pax_global_header00006660000000000000000000000064145112570030014510gustar00rootroot0000000000000052 comment=5acbf27dcf69fec03cd4804b95f0a679a467320e UniMath-20231010/000077500000000000000000000000001451125700300133075ustar00rootroot00000000000000UniMath-20231010/.github/000077500000000000000000000000001451125700300146475ustar00rootroot00000000000000UniMath-20231010/.github/workflows/000077500000000000000000000000001451125700300167045ustar00rootroot00000000000000UniMath-20231010/.github/workflows/build-unimath.yml000066400000000000000000000154661451125700300222050ustar00rootroot00000000000000name: CI Build UniMath on: push: branches: [master] pull_request: branches: [master] # Allows you to run this workflow manually from the Actions tab workflow_dispatch: schedule: # Based on https://github.com/marketplace/actions/set-up-ocaml # Prime the caches every Monday - cron: '0 1 * * MON' concurrency: group: ${{ github.workflow }}-${{ github.ref }} cancel-in-progress: true jobs: # This workflow contains four jobs: # - sanity-checks # - build-Unimath-ubuntu: (Linux, docker-coq, latest Coq >= 8.16, manual cache) # - build-macos: (MacOS, Opam, Coq 8.16.0, cache using actions/setup-ocaml) # - build-satellites: (Linux, docker-coq, Coq 8.16.x, manual cache) sanity-checks: name: Sanity Checks runs-on: ubuntu-22.04 steps: - uses: actions/checkout@v3 - name: Install build dependencies run: | sudo apt-get update sudo apt-get install coq type coqc coqc --version - name: Run sanity checks run: | cd $GITHUB_WORKSPACE time make -k sanity-checks || time make sanity-checks # Build the current PR/branch with the latest stable release of Coq. build-Unimath-ubuntu: strategy: fail-fast: false matrix: os: [ubuntu-22.04] # https://github.com/coq-community/docker-coq/wiki#ocaml-versions-policy coq-version: [latest, dev] # coq-version: [8.16] or [latest, 8.16] (when 8.17 is released) ocaml-version: [default] name: Build on Linux (Coq ${{ matrix.coq-version }}) runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v3 # Grab the cache if available and extract it to dune-cache/. We tell dune # to use $(pwd)/dune-cache/ in the custom_script when initiating the # docker run. - uses: actions/cache/restore@v3 id: cache with: path: dune-cache # Example key: UniMath-Linux-coq-8.16-123456789-10 key: UniMath-${{ runner.os }}-coq-${{ matrix.coq-version }}-${{ github.run_id }}-${{ github.run_number }} restore-keys: | UniMath-${{ runner.os }}-coq-${{ matrix.coq-version }}-${{ github.run_id }} UniMath-${{ runner.os }}-coq-${{ matrix.coq-version }}- - name: Build UniMath uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ matrix.coq-version }} ocaml_version: ${{ matrix.ocaml-version }} custom_script: | startGroup "Workaround permission issue" sudo chown -R coq:coq . endGroup startGroup "Print versions" opam --version opam exec -- dune --version opam exec -- coqc --version endGroup startGroup "Build UniMath" export DUNE_CACHE_ROOT=$(pwd)/dune-cache/ opam exec -- dune build -j 2 --display=short \ --cache=enabled --error-reporting=twice endGroup - name: Revert permissions if: ${{ always() }} run: sudo chown -R 1001:116 . - uses: actions/cache/save@v3 if: always() with: path: dune-cache key: UniMath-${{ runner.os }}-coq-${{ matrix.coq-version }}-${{ github.run_id }}-${{ github.run_number }} # Build UniMath on MacOS using latest stable release of Coq installed with # Homebrew (currently 8.16.1). Build files are cached. build-macos: name: Build on macOS (Coq 8.16) runs-on: macos-latest steps: - uses: actions/checkout@v3 - name: Install Coq run: | brew install coq ocaml-findlib dune coqc --version dune --version - uses: actions/cache/restore@v3 id: cache with: path: dune-cache key: UniMath-MacOS-${{ github.run_id }}-${{ github.run_number }} restore-keys: | UniMath-MacOS-${{ github.run_id }} UniMath-MacOS - name: Build UniMath run: | export DUNE_CACHE_ROOT=$(pwd)/dune-cache/ dune build --display=short --error-reporting=twice --cache=enabled UniMath/ - uses: actions/cache/save@v3 if: always () with: path: dune-cache key: UniMath-MacOS-${{ github.run_id }}-${{ github.run_number }} # Build the satellites in parallel using docker-coq images with the latest # stable patch-release of Coq 8.16, except for TypeTheory, which is built # using the latest stable 8.15 release. build-satellites: strategy: fail-fast: false matrix: satellite: [SetHITs, largecatmodules, GrpdHITs, TypeTheory] coq-version: [latest, dev] ocaml-version: [4.14-flambda] exclude: - satellite: GrpdHITs coq-version: dev name: Build ${{ matrix.satellite }} (Coq ${{ matrix.coq-version }}) runs-on: ubuntu-22.04 steps: # Check out the current branch of UniMath in the current directory. - uses: actions/checkout@v3 # Check out the satellite we want to build in Satellite/. - name: Clone ${{ matrix.satellite }} uses: actions/checkout@v3 with: repository: UniMath/${{ matrix.satellite }} path: Satellite # Grab the cache if available. We tell dune to use $(pwd)/dune-cache/ in # the custom_script below. - uses: actions/cache/restore@v3 id: cache with: path: dune-cache # Example key: SetHITs-coq-8.15-123456789-10 key: ${{ matrix.satellite }}-coq-${{ matrix.coq-version }}-${{ github.run_id }}-${{ github.run_number }} restore-keys: | ${{ matrix.satellite }}-coq-${{ matrix.coq-version }}-${{ github.run_id }} ${{ matrix.satellite }}-coq-${{ matrix.coq-version }}- - name: Build ${{ matrix.satellite }} uses: coq-community/docker-coq-action@v1 with: coq_version: ${{ matrix.coq-version }} ocaml_version: ${{ matrix.ocaml-version }} custom_script: | startGroup "Workaround permission issue" sudo chown -R coq:coq . endGroup startGroup "Print versions" opam --version opam exec -- dune --version opam exec -- coqc --version endGroup startGroup "Build Satellite" export DUNE_CACHE_ROOT=$(pwd)/dune-cache/ opam exec -- dune build -j 2 Satellite --display=short \ --cache=enabled --error-reporting=twice endGroup - name: Revert permissions if: ${{ always() }} run: sudo chown -R 1001:116 . - uses: actions/cache/save@v3 if: always () with: path: dune-cache key: ${{ matrix.satellite }}-coq-${{ matrix.coq-version }}-${{ github.run_id }}-${{ github.run_number }} UniMath-20231010/.github/workflows/clean-cache.yml000066400000000000000000000024331451125700300215540ustar00rootroot00000000000000--- # When a PR is closed (this includes merged into master) this job # will remove any cache entries owned by that PR. # This is based on: # https://github.com/actions/cache/blob/main/tips-and-workarounds.md#force-deletion-of-caches-overriding-default-cache-eviction-policy name: Cleanup cache from PR on: pull_request_target: types: - closed jobs: cleanup: runs-on: ubuntu-latest permissions: actions: write contents: read steps: - name: Check out code uses: actions/checkout@v3 - name: Cleanup env: GH_TOKEN: ${{ secrets.GITHUB_TOKEN }} run: | gh extension install actions/gh-actions-cache REPO=${{ github.repository }} BRANCH=refs/pull/${{ github.event.pull_request.number }}/merge echo -n "Fetching list of cache keys:" KEYS=$(gh actions-cache list --limit 100 -R $REPO -B $BRANCH | cut -f 1 ) echo $KEYS ## Setting this to not fail the workflow while deleting cache keys. set +e echo "Deleting caches..." for cacheKey in $KEYS do echo "Deleting" $cacheKey "from" $BRANCH gh actions-cache delete $cacheKey -R $REPO -B $BRANCH --confirm done echo "Done" UniMath-20231010/.github/workflows/scheduled.yml000066400000000000000000000015041451125700300213670ustar00rootroot00000000000000 name: Scheduled build on: schedule: # This job will run at 02:05 UTC on the 1st and 15th every month - cron: '5 2 1,15 * *' workflow_dispatch: jobs: # This build UniMath using UniMaths Makefile and the bundled Coq version, # i.e. with `make BUILD_COQ=yes`. build-coq-and-Unimath-ubuntu: name: Build Coq and UniMath (Ubuntu) runs-on: ubuntu-22.04 steps: - uses: actions/checkout@v3 - name: Install build dependencies run: | sudo apt-get update sudo apt-get install build-essential git ocaml ocaml-nox ocaml-native-compilers camlp5 libgtk2.0 liblablgtk-extras-ocaml-dev ocaml-findlib libnum-ocaml-dev emacs ocaml-dune libzarith-ocaml-dev - name: Build UniMath run: | cd $GITHUB_WORKSPACE time make -j2 TIMECMD=time BUILD_COQ=yes UniMath-20231010/.gitignore000066400000000000000000000007101451125700300152750ustar00rootroot00000000000000/build/Makefile-coq.make.bak /TAGS* /html /enhanced-html /build/Makefile-configuration /.coq_makefile_input /.coq_makefile_output /.coq_makefile_output.conf /.coqdeps.d /build/CoqMakefile.make /latex/*.log /latex/*.aux /latex/*.pdf /latex/*.tex /latex/*.out /latex/*.bbl /latex/*.blg /latex/*.fdb_latexmk /latex/*.fls /latex/coqdoc.sty /COQC.log /.*.okay .vscode _CoqProject *.zip *.vos *.vok *.v~ /..coq_makefile_output.d /UniMath/.dir-locals.el /_build/ UniMath-20231010/.gitmodules000066400000000000000000000002551451125700300154660ustar00rootroot00000000000000[submodule "sub/coq"] path = sub/coq url = https://github.com/coq/coq.git [submodule "sub/coq-tools"] path = sub/coq-tools url = https://github.com/JasonGross/coq-tools UniMath-20231010/.mailmap000066400000000000000000000236351451125700300147410ustar00rootroot00000000000000## This file allows joining different accounts of a single person. ## Cf for instance: git shortlog -nse. More details via: man git shortlog # having the same name name on a line will fix capitalization Alex Kavvos Alex Kavvos Alex Kavvos Alex Kavvos Ambroise Ambroise Ambroise Jack Ambroise Lafont Ambroise Lafont Anders Mörtberg Anders Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Anders Mörtberg Hoi Nguyen Anders Mörtberg anders mortberg Anthony Bordg Anthony Bordg Auke Booij Auke Booij Benedikt Ahrens Benedikt Ahrens Benedikt Ahrens Benedikt Ahrens Benedikt Ahrens benediktahrens Catherine Lelay Catherine Lelay Catherine Lelay Catherine Lelay Catherine Lelay Catherine LelayC Catherine Lelay cathlelay Christian Graulund Chgrau <34510751+Chgrau@users.noreply.github.com> Christian Graulund Christian Graulund <34510751+Chgrau@users.noreply.github.com> Christian Graulund Christian Graulund Christian Graulund Christian Graulund Christian Graulund Christian Uldal Graulund Cosimo Perini Cosimo Cosimo Perini Cosimo Perini <33255888+logicosimo@users.noreply.github.com> Cosimo Perini Cosimo Perini Dan Frumin Dan Frumin Daniel R. Grayson Daniel R. Grayson Daniel R. Grayson Daniel R. Grayson Dimitris Tsementzis Dimitris Tsementzis Dimitris Tsementzis Unknown Dominik Kirst Dominik Kirst Dominik Kirst Dominik Kirst Dominik Kirst dominik-kirst Elisabeth Bonnevier Elisabeth Bonnevier Emil Skoeldberg Emil Skoeldberg Emilio Jesus Gallego Arias Emilio Jesus Gallego Arias Enrico Tassi Enrico Tassi Enrico Tassi Enrico Tassi Felix Rech Felix Rech Floris van Doorn Floris van Doorn Gaëtan Gilbert Gaëtan Gilbert Hichem Saghrouni Hichem Saghrouni Hichem Saghrouni Marmann Hugo Herbelin Hugo Herbelin Jannis Limperg Jannis Limperg Jason Gross Jason Gross Jason Gross Jason Gross Joseph Helfer Joseph Helfer Karl Palmskog Karl Palmskog Langston Barrett Langston Barrett Luis Scoccola Luis Scoccola Marco Maggesi Marco Maggesi <1809783+maggesi@users.noreply.github.com> Marco Maggesi Marco Maggesi Marcus Aloysius Bezem Marcus Aloysius Bezem Mario Román Mario Román <5337877+mroman42@users.noreply.github.com> Mario Román Mario Román Matthew Weaver Matthew Weaver Matthew Weaver mweav Matthew Weaver mweav Maxime Dénès Maxime Dénès Michael A. Warren Michael A. Warren Mike Shulman Mike Shulman Mike Shulman mikeshulman Mitchell Riley Mitchell Riley N. Raghavendra N. Raghavendra Niccolo Veltri Niccolo Veltri Niccolo Veltri niccoloveltri Niels van der Weide Niels van der Weide Niels van der Weide Niels van der Weide Nikolai Kudasov Nikolai Kudasov Peter LeFanu Lumsdaine Peter LeFanu Lumsdaine Ralph Matthes Ralph Matthes Ralph Matthes Ralph Matthes Ralph Matthes Ralph Matthes Ralph Matthes rmatthes Tamara von Glehn Tamara von Glehn Théo Zimmermann Théo Zimmermann Tom de Jong Tom de Jong Tomi Pannila Tomi Pannila Tony Beta Lambda Tony Beta Lambda Vincent Laporte Vincent Laporte Vladimir Voevodsky Vladimir Voevodsky Vladimir Voevodsky Vladimir Voevodsky amblaf amblaf amblaf amblaf bcldoherty <34450242+bcldoherty@users.noreply.github.com> bcldoherty <34450242+bcldoherty@users.noreply.github.com> sspeight93 sspeight93 tamaravonglehn <34451125+tamaravonglehn@users.noreply.github.com> tamaravonglehn <34451125+tamaravonglehn@users.noreply.github.com> varkor varkor UniMath-20231010/.travis.yml-old000066400000000000000000000073131451125700300162000ustar00rootroot00000000000000language: generic sudo: false services: - docker env: global: - THIS_REPO=UniMath.git - LIMIT_MEMORY=yes - IMAGE=danielgrayson/unimath matrix: - PACKAGES= BUILD_ALSO=sanity-checks - PACKAGES="Foundations Combinatorics Algebra NumberSystems PAdics Paradoxes" - PACKAGES=CategoryTheory - PACKAGES=Bicategories - PACKAGES="MoreFoundations Ktheory SyntheticHomotopyTheory" - PACKAGES=HomologicalAlgebra - PACKAGES="Topology AlgebraicGeometry" - PACKAGES=RealNumbers - PACKAGES=SubstitutionSystems - PACKAGES=Tactics BUILD_COQIDE=yes - PACKAGES=Folds - PACKAGES=Induction - PACKAGES="Foundations Combinatorics Algebra NumberSystems" COQ_BRANCH=master # The docker image we formerly used is hosted at https://hub.docker.com/r/palmskog/xenial-unimath, and was created for us by Karl Palmskog. # Now we use the one at https://cloud.docker.com/repository/docker/danielgrayson/unimath # It was made this way: # docker create --privileged --name ubuntu19 --hostname ubuntu19 --tty --interactive ubuntu:19.04 /bin/bash # docker start ubuntu19 # docker exec -it --privileged ubuntu19 bash -c 'stty -echo -onlcr ; cd /root ; exec bash -l' # apt-get update # apt-get upgrade -y # apt-get install -y --quiet --no-install-recommends opam pkg-config libcairo2-dev libexpat1-dev libgtk-3-dev libgtksourceview-3.0-dev libexpat1-dev libgtk2.0-dev mccs m4 git ca-certificates camlp5 libgtksourceview2.0-dev time # opam init --bare # opam switch create --empty empty # opam install -y --solver=mccs num lablgtk conf-gtksourceview lablgtk3-sourceview3 camlp5 # root's home directory has these files: # # cat .profile # . .bashrc # eval `opam env` # # cat .bashrc # PS1="# " # And I cloned a clean copy of the UniMath repository there. # The "docker run" command will pull if needed, but we run this first in case of network interruptions. before_script: - timeout 5m docker pull ${IMAGE} || timeout 5m docker pull ${IMAGE} || timeout 5m docker pull ${IMAGE} # Using travis_wait here seems to cause the job to terminate after 1 minute with no error, so we avoid it. # The fcntl line works around a bug where Travis truncates logs and fails. script: - python -c "import fcntl; fcntl.fcntl(1, fcntl.F_SETFL, 0)" - echo "THIS_REPO=${THIS_REPO}" - echo "LIMIT_MEMORY=${LIMIT_MEMORY}" - echo "PACKAGES=${PACKAGES}" - echo "BUILD_COQIDE=${BUILD_COQIDE}" - echo "BUILD_ALSO=${BUILD_ALSO}" - echo "TRAVIS_BRANCH=${TRAVIS_BRANCH}" - echo "TRAVIS_EVENT_TYPE=${TRAVIS_EVENT_TYPE}" - echo "TRAVIS_COMMIT=${TRAVIS_COMMIT}" - echo "TRAVIS_PULL_REQUEST=${TRAVIS_PULL_REQUEST}" - echo "TRAVIS_PULL_REQUEST_BRANCH=${TRAVIS_PULL_REQUEST_BRANCH}" - echo "TRAVIS_PULL_REQUEST_SHA=${TRAVIS_PULL_REQUEST_SHA}" - echo "TRAVIS_REPO_SLUG=${TRAVIS_REPO_SLUG}" - >- docker run ${IMAGE} /bin/bash -x -c " cd . .profile cd $THIS_REPO if [ $TRAVIS_EVENT_TYPE = pull_request ] then git fetch origin pull/$TRAVIS_PULL_REQUEST/merge git checkout -qf $TRAVIS_PULL_REQUEST_SHA git config user.email noone@cares.com git config user.name Noone Cares git pull origin $TRAVIS_BRANCH else git fetch git checkout -qf $TRAVIS_COMMIT fi if [ '$COQ_BRANCH' != '' ] then ( cd sub/coq git checkout $COQ_BRANCH git pull) fi git clean -Xdfq git submodule foreach git clean -Xdfq git submodule update ( cd sub/coq git branch git describe --dirty --long --always --abbrev=40 --tags ) time make build-coq BUILD_COQIDE=$BUILD_COQIDE && time make TIMECMD=time $PACKAGES $BUILD_ALSO " UniMath-20231010/BUILD_DUNE.md000066400000000000000000000051401451125700300153030ustar00rootroot00000000000000 ## Building UniMath using Dune This document describes how to build UniMath using [Dune](https://dune.build/), a build system for the OCaml ecosystem. There are many advantages to using Dune over make, but one of the main advantages for UniMath is that Dune has better support for incremental builds, and also the functionality to cache builds. Rebuilding UniMath is a time-consuming operation and Dune does a lot to keep rebuilds to a minimum. ### Installing dune The [recommended](https://dune.build/install) way to install Dune is by using opam, but it is also possible to compile and install it by following the instructions on [GitHub/Dune](https://github.com/ocaml/dune). Make sure that the version of dune installed is at least 3.5.0. ### Building UniMath If you have previously compiled UniMath using `make` you need to clean up your repository or else dune will complain about files that it does not know how to compile. Running `make clean` should be enough. Assuming coq is installed (otherwise see for example [INSTALL.md](INSTALL.md)) and in your `PATH` you should now be able to build UniMath with the command `dune build`. **Note** that dune by default does not have caching enabled. To enable this once give the flag `--cache=enabled` to dune: ```bash $ dune build --cache=enabled ``` To always have caching enabled you need to find where dune keeps it configuration file. See the man-page `dune-config(5)`. On many systems it's the file `~/.config/dune/config`. Change the contents of this file to something like: ``` (lang dune 3.5) (cache enabled) (display short) ``` This enables caching and also tells dune to be more verbose during building (by default dune is very quiet). This configuration corresponds to giving the flags `--display=short --cache=enabled` when calling `dune build`. So now to build UniMath (with cache enabled) all you have to do is: ```bash $ dune build ``` To build a specific subsystem of UniMath, for example Algebra, you can do ```bash $ dune build UniMath/Algebra ``` ### dune with coqtop / Proof General Dune stores all the `.vo` files it produces in the `_build/` folder as opposed to in the source tree. For `coqtop` to find these you need to give it the `-R` flag, e.g ``` -R /your/path/to/UniMath/_build/default/UniMath UniMath ``` There is a very nice command `dune coq top` that will call `coqtop` with the correct flags, but unfortunately Proof General currently does not support it (see issue [477](https://github.com/ProofGeneral/PG/issues/477)). We hope this issue gets resolved soon as this would remove any need to configure PG/coqtop beyond telling it to call `dune coq top`. UniMath-20231010/INSTALL.md000066400000000000000000000364321451125700300147470ustar00rootroot00000000000000Installation of UniMath on Unix-like systems ============================================ ## Remarks - This file describes the default method for installing UniMath. An alternative method using the [Nix Package Manager](https://nixos.org/nix/) is available in the file [INSTALL\_NIX.md](https://github.com/UniMath/UniMath/blob/master/INSTALL_NIX.md). - A sketch for getting UniMath to run on Windows is given at [INSTALL\_WIN.md](./INSTALL_WIN.md). ## Preparing your computer In this section, we explain how to prepare your computer for the compilation of UniMath under [Mac OS X](#preparing-for-the-installation-under-mac-os-x), under [Ubuntu/Debian](#preparing-for-the-installation-under-ubuntu-or-debian-linux), and under [Arch/Manjaro Linux](#preparing-for-the-installation-under-arch-linux-or-manjaro-linux). ### Preparing for the installation under Mac OS X The simplest method, recommended for most users, is to first install Coq, Emacs, and Proof General, and then build and install UniMath. Coq can be installed using the package manager *Homebrew*: 1. Install Homebrew according to the instructions at http://brew.sh/. 2. Install Coq from Homebrew with the command ```bash brew install coq ``` Alternatively, you can install Coq in any other standard way; or you can ask UniMath to build its own copy of Coq, which may be useful if your globally installed Coq is a version incompatible with UniMath. If you plan to do this, then you must first install its dependencies, e.g. with the Homebrew command: ```bash brew install bash objective-caml ocaml-num ocaml-findlib camlp5 ``` or, for more customisability, using the "opam" OCaml package manager, according to the detailed instructions in [`INSTALL_OPAM.md`](./INSTALL_OPAM.md). Emacs may be installed using https://emacsformacosx.com/, http://aquamacs.org, or any other flavour of Emacs you prefer. Now you may proceed to the instructions for [Installation of Proof General](#installation-of-proofgeneral-all-operating-systems) and [Installing UniMath](#installing-unimath) below. The automated sanity checks (for contributions to UniMath) may require a more recent version of bash than the one preinstalled on Mac OS; this can be installed with `brew install bash`. ### Preparing for the installation under Ubuntu or Debian (Linux) Under Ubuntu or Debian, you may install Coq with the following shell command. ```bash sudo apt-get install coq ``` (Ubuntu 21.10 provides Coq version 8.12.0.) Alternatively, if you wish to compile a version of Coq known to work with Unimath, you may install OCaml with the following shell command. ```bash sudo apt-get install build-essential git ocaml ocaml-nox ocaml-native-compilers camlp5 libgtk2.0 libgtksourceview2.0 liblablgtk-extras-ocaml-dev ocaml-findlib libnum-ocaml-dev emacs ``` Now proceed with [Installation of Proof General](#installation-of-proofgeneral-all-operating-systems) and [Installing UniMath](#installing-unimath) below. ### Preparing for the installation under Arch Linux or Manjaro Linux Under Arch Linux or Manjaro Linux you may install OCaml and Emacs with the following shell commands. ```bash sudo pacman --sync --needed archlinux-keyring sudo pacman-key --populate archlinux sudo pacman --sync --needed ocaml camlp5 ocaml-findlib ocaml-num sudo pacman -S emacs ``` Now proceed with [Installation of Proof General](#installation-of-proofgeneral-all-operating-systems) and [Installing UniMath](#installing-unimath) below. ## Installation of Proof General (all operating systems) You may obtain Proof General from by using the quick installation instructions at http://proofgeneral.inf.ed.ac.uk/ or at https://proofgeneral.github.io/. Your version of emacs determines which version of Proof General you need, roughly, so some experimentation may be required; you may even need the current development version if your emacs is recent. For those unfamiliar with Emacs, `M-x` means "hold Alt, press x". Similarly, `C-g` means "hold Ctrl, press g". This cancels any action you have started. Finally, `RET` means "press Enter". Hence, the first Proof General installation instruction ``` M-x package-refresh-contents RET ``` reads "hold Alt, press x; type package-refresh-contents; press Enter". Optional: some useful Proof General add-ons are available for installation at https://github.com/cpitclaudel/company-coq/. ## Installing UniMath To download UniMath, issue the following shell commands. ```bash $ git clone https://github.com/UniMath/UniMath $ cd UniMath ``` To compile the Coq formalizations (in all the packages), issue the following shell command (in this directory). ```bash make ``` Alternatively, if you want to build a specific version of Coq for UniMath (not usually needed, but sometimes useful for compatibility reasons), and you have installed its dependencies as described above, you may issue the following command. ```bash make BUILD_COQ=yes ``` Once this is done, you can start [browsing and editing UniMath](./USAGE.md). Below, we explain how to compile individual packages of UniMath, and how to create HTML documentation. ### Building individual packages and HTML documentation - To compile an individual package and the files it depends on, e.g., the package `CategoryTheory`, issue ```bash $ make CategoryTheory ``` - To compile an individual file and the files it depends on, e.g., the file `CategoryTheory/Categories.v`, issue ```bash $ make UniMath/CategoryTheory/Categories.vo ``` Note the extension `*.vo` required in the command. - To create the standard HTML documentation provided by coqdoc: ```bash $ make html ``` The documentation is created in the subdirectory `html`. - To create HTML documentation with "hidden" proofs: ```bash $ make doc ``` In this version of the documentation, any proof enclosed within `Proof.` and `Qed.`/`Defined.` is replaced by a button `Show proof.`. Clicking on this button unveils (unfolds) the corresponding proof. A `Hide proof` button can be used to fold the proof again. The documentation is created in the subdirectory `enhanced-html`. (This feature requires the use of the otherwise optional `Proof` command of the Coq vernacular language to indicate the beginning of the proof. Toggling of proofs requires an internet connection for downloading the `jquery` library.) - To install UniMath in the `user-contrib` directory of Coq, for use by other developments: ```bash $ make install ``` The path to that directory from here, by default, is ./sub/coq/user-contrib/. - To install [CoqIDE](https://coq.inria.fr/refman/practical-tools/coqide.html), see [INSTALL\_COQIDE](./INSTALL_COQIDE.md). ## TAGS files Emacs (which every UniMath user should become expert with) includes a facility called "tags" which enables easy navigation between Coq proof files. For example, you may be examining a proof containing a reference to a symbol such as "has_homsets", and you may wonder where the source code of its definition is. To do that, one positions the cursor on the symbol, presses `M-.`, accepts (or modifies) the proffered string, and presses return. Emacs then takes you to the source code of the definition. One may repeat that as often as desired, and return one level upward in the chain of locations visited with `M-*`. Another use of the tags file is to search through all the source files for the occurrence of text matching a given regular expression. For example, you can use `M-x tags-search` with the regular expression `^Notation *" *\[ *. *\(, *[[:alpha:]]+ *\)*\]"` to locate the following lines in various files: ```coq Notation "[ C , D , hs ]" := (functor_precategory C D hs) : cat. Notation "[ C , D , hs ]" := (functor_precategory C D hs) : cat. Notation "[ C , D ]" := (functor_category C D) : cat. Notation "[ C , D ]" := (functor_category C D) : cat. ``` In order to enable this facility, make a "TAGS" file as follows. To make a TAGS file for use with emacs `etags` commands: ```bash $ make TAGS ``` To make a TAGS file dealing with a single package, for example, `Foundations`: ```bash $ make TAGS-Foundations ``` The first time the tags facility is used, the user will be prompted for the location of a TAGS file to use -- it will be in the top-level directory of UniMath. ## Measuring compilation time To obtain information about the compilation time of each file, add `TIMED=yes` to the `make` command line. For this to work, you need the GNU `time` utility installed on your system in `/usr/bin`. Alternatively, add `TIMECMD=time` to the `make` command line, where `time` is a time command that works on your system. On both Linux and Mac OS X systems, `time` is a built in bash shell command that differs from GNU time, available on Linux systems as `\time`. Under Mac OS X, you can install GNU time as `gtime` by running `brew install gnu-time`. Since `make` variables can be included in the time command, the following example (using GNU time `gtime`) shows how to display the user time and the name of the file on the same line. ``` $ time make TIMECMD='gtime -f "user time %U: $*"' ``` The first `time` command provides overall time for the whole build. Timing of execution of individual tactics and vernacular commands can be obtained by ```bash $ make MOREFLAGS=-time ``` For postprocessing of the (huge) output, use our utility `slowest`, like this: ```bash $ make MOREFLAGS=-time TIMECMD='util/slowest 10 0.5' ``` For each Coq file compiled, the timing of the 10 slowest steps taking at least 0.5 seconds will be displayed. You may time both steps and files like this: ```bash $ make MOREFLAGS=-time TIMECMD='gtime -f "user time %U: $(basename $*)" util/slowest 10 0.5' ``` To speed up execution on a machine with multiple cores or pseudo-cores, specify the use of multiple processes in paralle, e.g, 4, as follows. ``` $ make -j4 ``` ## Further details The correct version of Coq is built and used automatically by the command `make`. (If you wish to bypass the building of Coq and use your own version, then follow the instructions in the file build/Makefile-configuration-template.) The file `UniMath/.dir-locals.el` contains code that arranges for Proof General to use the Coq programs built by `make` when one of the proof files of UniMath is opened in emacs; in order to use them more generally, such as from the command line,, then add the full path for the directory `./sub/coq/bin` to your `PATH` environment variable, or set the emacs variable `coq-prog-name` in your emacs initialization file, `.emacs`. The various *.v files are compiled by Coq in such a way that the fully qualified name of each identifier begins with UniMath. For example, the fully qualified name of `maponpaths` in uu0.v is `UniMath.Foundations.Basics.PartA.maponpaths`. The preferred way to interact with the Coq code is with Proof General, running in a modern version of emacs. The file UniMath/.dir-locals.el will set the emacs variable `coq-prog-args` appropriately. In particular, it will add the directory UniMath to the path, using the `-R` option, and it will arrange for files with names of the form `*.v` to be edited in "Coq mode". We are using some unicode characters in our Coq files. One way to type such characters easily is with the "Agda input method": to type σ, for example, one types \sigma, which is automatically replaced by σ. We have arranged for the Agda input method to be automatically enabled in buffers containing one of the UniMath Coq files. The emacs command for viewing the typing shortcuts offered by the Agda input method is `C-H I`. ## Problems In this section we describe some problems that have been encountered during compilation, and how to fix them. ### Errors while compiling Coq The following type mismatch error during compilation of Coq results from a mismatch between the version of OCaml used and the version of Coq being compiled. ``` "/usr/local/bin/ocamlfind" opt -rectypes -dtypes -w -3-52-56 -I config -I lib -I kernel -I kernel/byterun -I library -I proofs -I tactics -I pretyping -I interp -I stm -I toplevel -I parsing -I printing -I intf -I engine -I ltac -I tools -I tools/coqdoc -I plugins/omega -I plugins/romega -I plugins/micromega -I plugins/quote -I plugins/setoid_ring -I plugins/extraction -I plugins/fourier -I plugins/cc -I plugins/funind -I plugins/firstorder -I plugins/derive -I plugins/rtauto -I plugins/nsatz -I plugins/syntax -I plugins/decl_mode -I plugins/btauto -I plugins/ssrmatching -I plugins/ltac -I "/usr/local/Cellar/camlp5/7.03_1/lib/ocaml/camlp5" -thread -g -c lib/pp_control.ml File "lib/pp_control.ml", line 61, characters 22-33: Error: This expression has type bytes -> int -> int -> unit but an expression was expected of type string -> int -> int -> unit Type bytes is not compatible with type string ``` For example, Coq 8.6.1 cannot be compiled by OCaml 4.06.0, and must instead be compiled by an older version. In the instructions above, we arrange for OCaml 4.02.3 to be used to compile Coq 8.6.1. ### Problems caused by ill-formed input to make When calling `make`, various files are read, some of them not under version control by git. If those files are ill-formed, `make` stops working; in particular, `make` cannot be used to delete and recreate those files. When such a situation arises, one solution is to try cleaning everything with this command: ```bash $ make INCLUDE=no distclean ``` Another solution is to let git do the cleaning, by running: ```bash $ git clean -Xdfq $ git submodule foreach git clean -Xdfq ``` The Makefile provides this pair of commands, too: ```bash $ make INCLUDE=no git-clean ``` ### Problems specific to MacOS If you get error messages involving the command line option `-fno-defer-pop`, you might be running Mac OS X 10.9 with an OCaml compiler installed by `brew`. In that case try ```bash brew update brew upgrade objective-caml ``` If that doesn't work, try ```bash brew remove objective-caml brew install objective-caml ``` ### Problems specific to Linux (e.g., Debian and Ubuntu) If you get the error message `Error: cannot find 'ocamlc.opt' in your path!`, you need to install `ocaml-native-compilers`, e.g., by running ```bash $ sudo apt-get install ocaml-native-compilers ``` This package is not among the build dependencies for older versions of Coq. ### Hints for developers - To regularly update the TAGS file, you may build with the command `make TAGS all`. - Before submitting a pull request, developers should run the sanity checks that are specified in the Makefile by adding `sanity-checks` to the "make" command line. - One of the sanity checks checks that all proof files in the directory tree are listed in the corresponding package, but it will complain even about files you haven't checked in; to disable the test, add `-o check-listing-of-proof-files` to the "make" command line. Other sanity checks can be skipped the same way. For example, if you intend to make a change to the Foundations package, then you can add `-o check-for-change-to-Foundations` to the "make" command line. - Memory limits: pull requests are tested automatically by "travis" at github, and at that point, a memory limit is imposed to ensure reproducibility of results to and to prevent excessive memory usage. To apply the same memory limit on your own machine before submitting a pull request, add `LIMIT_MEMORY=yes` to the `make` command line. Unfortunately, under Mac OS X, such memory limits are ineffective, so you may prefer to run the test under Linux. UniMath-20231010/INSTALL_COQIDE.md000066400000000000000000000013421451125700300157630ustar00rootroot00000000000000Installing CoqIDE ================= If you wish also to build the program `coqide`, then issue the following command. ```bash $ make BUILD_COQIDE=yes ``` Alternatively, you can specify the value of the BUILD_COQIDE option more permanently by following the instructions in the file build/Makefile-configuration-template. Later on, after running the command `make install` as instructed below, in order to run the program `coqide`, you may use the following command. ```bash $ sub/coq/bin/coqide ``` where `` are the options passed to Coq as per the [Emacs configuration file](./UniMath/.dir-locals.el), which is made from the file [`UniMath/.dir-locals.el.in`](./UniMath/.dir-locals.el) as a result of running `make`.. UniMath-20231010/INSTALL_NIX.md000066400000000000000000000046541451125700300154660ustar00rootroot00000000000000Building UniMath with Nix ===================================== ## Introduction These are instructions to install UniMath on a Unix-like system using the Nix Package Manager. This method has some advantages: 1. Should work both on Mac and on any major Linux distribution without any difference. 2. Does not require to install OCaml or Git or other dependencies separately (only Nix itself). 3. Does not interfere with or modify other software already present on the same system (other versions of OCaml, camlp5, etc). 4. It makes possible to uninstall cleanly all the software. The main disadvantage of this method is that it is not the most used (see [INSTALL.md](https://github.com/UniMath/UniMath/blob/master/INSTALL.md)) and it is not very well tested at the moment. ## Installation step-by-step 1. If you already have the Nix Package Manager installed, skip this step. Otherwise, type the following command to install Nix (as a user other than root): ```bash $ curl https://nixos.org/nix/install | sh ``` Follow the instructions output by the script. The installation script requires that you have sudo access to `root`. (Go to the [NixOS website](https://nixos.org) to get [more detailed instructions](https://nixos.org/nix/download.html).) 2. Start a "nix-shell" with the following command: ```bash $ nix-shell -p ocaml ocamlPackages.findlib ocamlPackages.camlp5 ocamlPackages.num gnumake git ``` (This may require some time to download and deploy the OCaml environment into the Nix storage.) 3. Clone UniMath, move to the top directory and launch the build: ```bash $ git clone https://github.com/UniMath/UniMath.git $ cd UniMath $ make ``` Once the building is finished, you can quit the nix-shell (type `exit`). 4. You may also want to install emacs using Nix: ```bash $ nix-env -i emacs ``` (Or skip this step if you have emacs already installed.) 5. Finally, you need to install Proof-General following the instructions on the [website](https://proofgeneral.github.io). ## How to uninstall UniMath and its dependencies If you want to uninstall UniMath and OCaml to reclaim disk space: 1. Delete the UniMath directory: ```bash $ rm -rf UniMath ``` 2. Purge the software installed with Nix: ``` $ nix-collect-garbage ``` If you want to uninstall the Nix Package Manager directly, consult the [Nix Manual](https://nixos.org/nix/manual/#chap-installation). UniMath-20231010/INSTALL_OPAM.md000066400000000000000000000063731451125700300155640ustar00rootroot00000000000000# Second method to install ocaml This method for installing OCaml (in order to also build Coq) allows more flexibility, but is more involved than the method in [INSTALL.md](./INSTALL.md), because it depends on "opam". First install opam and needed prerequisites: - Under Mac OS X, this is done by install "Homebrew", available from http://brew.sh/, and then using it to install opam with the following command. ```bash $ brew install opam gtksourceview3 ``` Then set up the opam system as follows. - with latest OCaml (not guaranteed to work well with Coq): ```bash $ opam init --bare $ opam switch create --empty empty $ opam install -y num lablgtk conf-gtksourceview lablgtk3-sourceview3 camlp5 ``` - with OCaml 4.07.1+flambda (should work on most systems, refer to [#1315](https://github.com/UniMath/UniMath/issues/1315) for details) ```bash $ opam init --bare $ opam switch create with-coq 4.07.1+flambda $ opam install -y num lablgtk conf-gtksourceview lablgtk3-sourceview3 camlp5 ``` - Under Ubuntu: First, install "opam": ```bash sudo apt-get install -y opam ``` Now check which version of opam is installed with the command `opam --version`. If it is less than version 2, then we need to get opam from a "ppa", as follows. ```bash sudo add-apt-repository -y ppa:avsm/ppa sudo apt update sudo apt install -y opam ``` (Ubuntu 18.04 comes with opam 1.2.2, whereas Ubuntu 19.04 comes with opam 2.0.3.) Then install needed libraries as follows. ```bash sudo apt-get install --quiet --no-install-recommends pkg-config libcairo2-dev libexpat1-dev libgtk-3-dev libgtksourceview-3.0-dev libexpat1-dev libgtk2.0-dev mccs m4 git ca-certificates camlp5 libgtksourceview2.0-dev ``` Then set up the opam system as follows. ```bash $ opam init --bare $ opam switch create --empty empty $ opam install -y --solver=mccs num lablgtk conf-gtksourceview lablgtk3-sourceview3 camlp5 ``` In both of the procedures above, we ignore any OCaml compiler offered by the system, preferring to let opam install its preferred compiler. That avoid problems with version skew, which I don't understand. The packages involving "gtk", installed above, are relevant only if coqide is to be built. Now arrange for the programs installed by opam to be available to the currently running shell: ```bash $ eval `opam env` ``` If you haven't done it previously in connection with installing opam, as you have just done, arrange for the programs (such as ocamlc) that opam will install for you to be found by your shell the next time you log in by also adding the line above to your file `~/.profile`, after any lines in the file that add `/usr/local/bin` to the `PATH` environment variable. (Homebrew and opam both know how to install `ocamlc`, and we intend to use `opam` to get a version of `ocamlc` appropriate for compiling the version of Coq used by UniMath.) At any time, you may check that the progams installed by opam are accessible by you as follows. ```bash $ type ocamlc ocamlc is hashed (/Users/XXXXXXXX/.opam/empty/bin/ocamlc) ``` A result displaying a path that doesn't pass through `.opam` or `.opamroot` indicates that the wrong compiler is visible in the directories listed in your `PATH` environment variable. UniMath-20231010/INSTALL_WIN.md000066400000000000000000000054251451125700300154620ustar00rootroot00000000000000Running UniMath in Windows ========================== --- These notes are copied verbatim from the report at https://github.com/UniMath/UniMath/issues/1351. They are recorded here for convenience, with permission of their author. You are very welcome to expand these notes and adapt them, if necessary. The UniMath maintainers cannot provide support for UniMath in Windows. --- I helped someone with a minimal setup running UniMath on Windows inside VSCode, and wanted to quickly write down what worked for me. OCaml, Coq, and Emacs all run natively on Windows, so if you make it past the "make" step in Cygwin, everything should work one way or another from there. This process was mostly trial an error, and far from perfect. In particular, you should only need one Coq installation (I'm not really sure why UniMath builds its own anyway), and it would be much better to include the UniMath files in the correct path variable (it looks like this is setup with Emacs in this repository) rather than include them through the command line. Good luck! ## Install Coq through Cygwin Followed directions [here](https://github.com/coq/platform/blob/2021.02.1/README_Windows.md) to install Coq from source using cygwin. This was probably overkill, but since the UniMath makefile builds Coq from source, it seemed like a good setup and sanity check. ## Install UniMath Inside cygwin, `git clone` UniMath and `make`. (The makefile does let you specific `BUILD_COQ=no`, but I did not try this.) There is now a second Coq installation located at `path/to/UniMath/sub/coq/bin`. E.g. in Cygwin you can run: ```$ path/to/UniMath/sub/coq/bin/coqtop.exe``` And test that Coq is working. ## Include the UniMath files At this point the UniMath library is not loaded, if you try to run ```Coq < Require Export UniMath.Foundations.Sets.``` You will get an error saying there is no physical path bound to the logical path One way to fix this is to provide it at the command line. Run ```$ path/to/UniMath/sub/coq/bin/coqtop.exe -R "path/to/UniMath/UniMath" UniMath``` (See `coqtop --help`, the `-R` option recursively binds a physical folder to a logical folder) Afterwhich the import should be resolved correctly: ```Coq < Require Export UniMath.Foundations.Set.``` At this point, I seem to be able to run UniMath files through the command line without issue. ## Visual Studio Code The VSCoq plugin lets you point to the `path\to\UniMath\sub\coq\bin` (we're now outside cygwin, so this is a windows path, probably pointing to `C:\cygwin64_coq\home\user\UniMath`) Change the name of the binaries to `coqtop.exe` and `coqidetop.exe` and finally pass in additional command line arguments to include the UniMath files. (Again the path is now a windows path.) (The arguments should be given as a three part list, not a single string.) UniMath-20231010/LICENSE.md000066400000000000000000000014121451125700300147110ustar00rootroot00000000000000UniMath copyright and license ============================= UniMath consists of the files in the UniMath github repository at https://github.com/UniMath/UniMath . UniMath is copyright 2015 by the UniMath Development Team, whose members are listed at https://github.com/UniMath/UniMath in the file README.md . Permission is hereby granted, free of charge, to any person obtaining a copy of UniMath, to deal in UniMath without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of UniMath, and to permit persons to whom UniMath is furnished to do so, subject to the following conditions: * This copyright and license shall be included in all copies or substantial portions of the Software. UniMath-20231010/Makefile000066400000000000000000000467121451125700300147610ustar00rootroot00000000000000# -*- makefile-gmake -*- UMAKEFILES += Makefile ifneq "$(INCLUDE)" "no" ifeq ($(shell test -f build/Makefile-configuration && echo yes),yes) UMAKEFILES += build/Makefile-configuration include build/Makefile-configuration endif endif ############################################ # The packages, listed in order by dependency: PACKAGES += Foundations PACKAGES += MoreFoundations PACKAGES += Combinatorics PACKAGES += Algebra PACKAGES += Tactics PACKAGES += NumberSystems PACKAGES += SyntheticHomotopyTheory PACKAGES += PAdics PACKAGES += OrderTheory PACKAGES += CategoryTheory PACKAGES += Bicategories PACKAGES += Ktheory PACKAGES += Topology PACKAGES += RealNumbers PACKAGES += SubstitutionSystems PACKAGES += Folds PACKAGES += HomologicalAlgebra PACKAGES += AlgebraicGeometry PACKAGES += Paradoxes PACKAGES += Induction PACKAGES += AlgebraicTheories PACKAGES += Semantics ############################################ # other user options; see also build/Makefile-configuration-template BUILD_COQ ?= no BUILD_COQIDE ?= no DEBUG_COQ ?= no COQBIN ?= MEMORY_LIMIT ?= 2500000 LIMIT_MEMORY ?= no ############################################ SHOW := $(if $(VERBOSE),@true "",@echo "") HIDE := $(if $(VERBOSE),,@) ############################################ export COQBIN ############################################ .PHONY: all everything install lc lcp wc describe clean distclean build-coq doc build-coqide html sanity-checks other-checks .PHONY all: make-summary-files everything: TAGS all html install .PHONY sanity-checks: check-prescribed-ordering \ check-listing-of-proof-files \ check-for-change-to-Foundations \ check-for-submodule-changes \ check-for-changes-to-CONTENTS.md .PHONY other-checks: check-max-line-length # empty target prevents implicit rule search, saving time Makefile :; COQIDE_OPTION := no ifeq "$(BUILD_COQ)" "yes" COQBIN=sub/coq/bin/ all: build-coq build-coq: sub/coq/bin/coqc ifeq "$(BUILD_COQIDE)" "yes" all: build-coqide COQIDE_OPTION := opt endif endif COQ_PATH := -Q UniMath UniMath # override the definition in build/CoqMakefile.make, to eliminate the -utf8 option COQDOC := coqdoc COQDOCFLAGS := -interpolate --charset utf-8 $(COQ_PATH) COQDOC_OPTIONS := -toc $(COQDOCFLAGS) $(COQDOCLIBS) -utf8 PACKAGE_FILES := $(patsubst %, UniMath/%/.package/files, $(PACKAGES)) ifneq "$(INCLUDE)" "no" include .coq_makefile_output.conf VFILES := $(COQMF_VFILES) VOFILES := $(VFILES:.v=.vo) endif ifeq ($(BUILD_COQ),yes) $(VOFILES) : $(COQBIN)coqc endif ifeq ($(LIMIT_MEMORY),yes) EFFECTIVE_MEMORY_LIMIT = $(MEMORY_LIMIT) else EFFECTIVE_MEMORY_LIMIT = unlimited endif install: build/CoqMakefile.make ulimit -v $(EFFECTIVE_MEMORY_LIMIT) ; $(MAKE) -f build/CoqMakefile.make $@ all html uninstall: build/CoqMakefile.make ulimit -v $(EFFECTIVE_MEMORY_LIMIT) ; $(MAKE) -f build/CoqMakefile.make $@ clean:: build/CoqMakefile.make $(MAKE) -f build/CoqMakefile.make $@ distclean:: build/CoqMakefile.make $(MAKE) -f build/CoqMakefile.make cleanall archclean WARNING_FLAGS := -notation-overridden OTHERFLAGS += $(MOREFLAGS) OTHERFLAGS += -noinit -indices-matter -type-in-type -w '\'"$(WARNING_FLAGS)"\'' ifeq ($(VERBOSE),yes) OTHERFLAGS += -verbose endif ENHANCEDDOCTARGET = enhanced-html ENHANCEDDOCSOURCE = util/enhanced-doc LATEXDIR = latex COQDOCLATEXOPTIONS := -latex -utf8 --body-only DEFINERS := DEFINERS := $(DEFINERS)Axiom\| DEFINERS := $(DEFINERS)Class\| DEFINERS := $(DEFINERS)Coercion\| DEFINERS := $(DEFINERS)CoFixpoint\| DEFINERS := $(DEFINERS)CoInductive\| DEFINERS := $(DEFINERS)Corollary\| DEFINERS := $(DEFINERS)Definition\| DEFINERS := $(DEFINERS)Example\| DEFINERS := $(DEFINERS)Fact\| DEFINERS := $(DEFINERS)Fixpoint\| DEFINERS := $(DEFINERS)Function\| DEFINERS := $(DEFINERS)Identity[[:space:]]+Coercion\| DEFINERS := $(DEFINERS)Inductive\| DEFINERS := $(DEFINERS)Instance\| DEFINERS := $(DEFINERS)Lemma\| DEFINERS := $(DEFINERS)Ltac\| DEFINERS := $(DEFINERS)Module[[:space:]]+Import\| DEFINERS := $(DEFINERS)Module\| DEFINERS := $(DEFINERS)Notation\| DEFINERS := $(DEFINERS)Proposition\| DEFINERS := $(DEFINERS)Record\| DEFINERS := $(DEFINERS)Remark\| DEFINERS := $(DEFINERS)Scheme[[:space:]]+Equality[[:space:]]+for\| DEFINERS := $(DEFINERS)Scheme[[:space:]]+Induction[[:space:]]+for\| DEFINERS := $(DEFINERS)Scheme\| DEFINERS := $(DEFINERS)Structure\| DEFINERS := $(DEFINERS)Theorem\| DEFINERS := $(DEFINERS)Universe MODIFIERS := MODIFIERS := $(MODIFIERS)Canonical\| MODIFIERS := $(MODIFIERS)Monomorphic\| MODIFIERS := $(MODIFIERS)Global\| MODIFIERS := $(MODIFIERS)Local\| MODIFIERS := $(MODIFIERS)Private\| MODIFIERS := $(MODIFIERS)Program\| COQDEFS := --language=none \ -r '/^[ \t]*\(\($(MODIFIERS)\)[ \t]+\)?\($(DEFINERS)\)[ \t]+\([0-9A-Za-z'\''_]+\)/\4/' \ -r "/^[ \t]*Notation.* \"'\([0-9A-Za-z'\''_]+\)'/\1/" \ -r '/^[ \t]*Tactic[ \t]+Notation.*[ \t]"\([0-9A-Za-z'\''_]+\)"[ \t]/\1/' \ -r '/^[ \t]*Delimit[ \t]+Scope[ \t]+[0-9A-Za-z'\''_]+[ \t]+with[ \t]+\([0-9A-Za-z'\''_]+\)[ \t]*\./\1/' # this function reverses the order of items in a list reverse = $(if $(1),$(call reverse,$(wordlist 2,$(words $(1)),$(1)))) $(firstword $(1)) $(foreach P,$(PACKAGES),$(eval TAGS-$P: Makefile $(filter UniMath/$P/%,$(VFILES)); etags $(COQDEFS) -o $$@ $$^)) TAGS : Makefile $(PACKAGE_FILES) $(VFILES) $(SHOW)ETAGS $(HIDE)etags $(COQDEFS) $(VFILES) FILES_FILTER := grep -vE '^[ \t]*(\#.*)?$$' FILES_FILTER_2 := grep -vE '^[ \t]*(\#.*)?$$$$' $(foreach P,$(PACKAGES), \ $(eval $P: make-summary-files build/CoqMakefile.make UniMath/.dir-locals.el; \ + ulimit -v $(EFFECTIVE_MEMORY_LIMIT) ; \ $(MAKE) -f build/CoqMakefile.make \ $(shell $@ # the '' above prevents emacs from mistaking the lines above as providing local variables when visiting this file ifdef COQBIN build/CoqMakefile.make .coq_makefile_output.conf: $(COQBIN)coq_makefile endif build/CoqMakefile.make .coq_makefile_output.conf: .coq_makefile_input $(COQBIN)coq_makefile -f .coq_makefile_input -o .coq_makefile_output mv .coq_makefile_output build/CoqMakefile.make # "clean::" occurs also in build/CoqMakefile.make, hence both colons clean:: rm -f .coq_makefile_input .coq_makefile_output .coq_makefile_output.conf build/CoqMakefile.make COQC.log find UniMath \( -name .\*.aux -o -name \*.glob -o -name \*.d -o -name \*.vo \) -delete find UniMath -type d -empty -delete clean::; rm -rf $(ENHANCEDDOCTARGET) latex-clean clean::; cd $(LATEXDIR) ; rm -f *.pdf *.tex *.log *.aux *.out *.blg *.bbl distclean:: clean distclean:: ; - $(MAKE) -C sub/coq distclean distclean:: ; rm -f build/Makefile-configuration ############################################################################# # building coq: export PATH:=$(shell pwd)/sub/coq/bin:$(PATH) CONFIGURE_OPTIONS := -coqide "$(COQIDE_OPTION)" -with-doc no -prefix $(shell pwd) BUILD_TARGETS := coqbinaries tools states coq ifeq ($(DEBUG_COQ),yes) CONFIGURE_OPTIONS += -annot BUILD_TARGETS += byte BUILD_OPTIONS += VERBOSE=true BUILD_OPTIONS += READABLE_ML4=yes endif ifeq ($(BUILD_COQIDE),yes) BUILD_TARGETS += coqide-files bin/coqide endif sub/coq/configure.ml: git submodule update --init sub/coq sub/coq/config/coq_config.ml: sub/coq/configure.ml @echo --- making $@ because of $? cd sub/coq && ./configure $(CONFIGURE_OPTIONS) sub/coq/bin/coq_makefile sub/coq/bin/coqc: sub/coq/config/coq_config.ml .PHONY: rebuild-coq rebuild-coq sub/coq/bin/coq_makefile sub/coq/bin/coqc: $(MAKE) -w -C sub/coq $(BUILD_OPTIONS) $(BUILD_TARGETS) $(MAKE) -w -C sub/coq install ifeq ($(DEBUG_COQ),yes) $(MAKE) -w -C sub/coq tags endif ############################################################################# git-describe: git describe --dirty --long --always --abbrev=40 git submodule foreach git describe --dirty --long --always --abbrev=40 --tags doc: $(GLOBFILES) mkdir -p $(ENHANCEDDOCTARGET) cp $(ENHANCEDDOCSOURCE)/proofs-toggle.js $(ENHANCEDDOCTARGET)/proofs-toggle.js $(SHOW)COQDOC $(HIDE)$(COQDOC) \ -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d $(ENHANCEDDOCTARGET) \ --with-header $(ENHANCEDDOCSOURCE)/header.html \ $(VFILES) sed -i'.bk' -f $(ENHANCEDDOCSOURCE)/proofs-toggle.sed $(ENHANCEDDOCTARGET)/*html # Jason Gross' coq-tools bug isolator: # The isolated bug will appear in this file, in the UniMath directory: ISOLATED_BUG_FILE := isolated_bug.v # To use it, run something like this command in an interactive shell: # make isolate-bug BUGGY_FILE=Foundations/Basics/PartB.v sub/coq-tools/find-bug.py: git submodule update --init sub/coq-tools help-find-bug: sub/coq-tools/find-bug.py --help isolate-bug: sub/coq-tools/find-bug.py cd UniMath && \ rm -f $(ISOLATED_BUG_FILE) && \ ../sub/coq-tools/find-bug.py --coqbin ../sub/coq/bin -R . UniMath \ --arg " -indices-matter" \ --arg " -type-in-type" \ --arg " -noinit" \ --arg " -indices-matter" \ --arg " -type-in-type" \ --arg " -w" \ --arg " -notation-overridden,-local-declaration,+uniform-inheritance,-deprecated-option" \ $(BUGGY_FILE) $(ISOLATED_BUG_FILE) @echo "===" @echo "=== the isolated bug has been deposited in the file UniMath/$(ISOLATED_BUG_FILE)" @echo "===" world: all html doc latex-doc latex-doc: $(LATEXDIR)/doc.pdf $(LATEXDIR)/doc.pdf : $(LATEXDIR)/helper.tex $(LATEXDIR)/references.bib $(LATEXDIR)/latex-preamble.txt $(LATEXDIR)/helper.tex $(LATEXDIR)/latex-epilogue.txt cd $(LATEXDIR) && cat latex-preamble.txt helper.tex latex-epilogue.txt > doc.tex cd $(LATEXDIR) && latexmk -pdf -interaction=nonstopmode doc $(LATEXDIR)/coqdoc.sty $(LATEXDIR)/helper.tex : $(VFILES:.v=.glob) $(VFILES) $(COQDOC) $(COQ_PATH) $(COQDOC_OPTIONS) $(COQDOCLATEXOPTIONS) $(VFILES) -o $@ .PHONY: check-max-line-length check-max-line-length: LC_ALL="en_US.UTF-8" gwc -L $(VFILES) | grep -vw total | awk '{ if ($$1 > 100) { printf "%6d %s\n", $$1, $$2 }}' | sort -r | grep . show-long-lines: LC_ALL="en_US.UTF-8" grep -nE '.{101}' $(VFILES) # here we assume the shell is bash, which it usually is nowadays, so we can get associative arrays: SHELL = bash check-prescribed-ordering: .check-prescribed-ordering.okay clean::; rm -f .check-prescribed-ordering.okay # The ordering check assumes Coq version ≥8.8, and gives up otherwise. (Prior to 8.8, dependency files *.d were handled differently.) VDFILE := ..coq_makefile_output.d clean::; rm -f $(VDFILE) ifeq ($(shell test -f build/CoqMakefile.make && grep -q ^VDFILE build/CoqMakefile.make && echo yes),yes) # Coq >= 8.8 DEPFILES := $(VDFILE) .check-prescribed-ordering.okay: Makefile $(DEPFILES) $(PACKAGE_FILES) @echo "--- checking the ordering prescribed by the files UniMath/*/.packages/files ---" @set -e ; \ if declare -A seqnum 2>/dev/null ; \ then n=0 ; \ for i in $(VOFILES) ; \ do n=$$(( $$n + 1 )) ; \ seqnum[$$i]=$$n ; \ done ; \ for i in $(VFILES:.v=.vo); \ do grep "^$$i" $(DEPFILES) ; \ done \ | sed -E -e 's/[^ ]*\.(glob|v|vos|vok|required_vo|required_vos|v\.beautified)([ :]|$$)/\2/g' -e 's/ *: */ /' \ | awk NF \ | ( while read line ; \ do \ for i in $$line ; do echo $$i ; done \ | ( read target ; \ [ "$${seqnum[$$target]}" ] || (echo unknown target: $$target; false) >&2 ; \ while read prereq ; \ do \ [ "$${seqnum[$$prereq]}" ] || (echo "unknown prereq of $$target : $$prereq" ; false) >&2 ; \ (if [ "$${seqnum[$$prereq]}" -gt "$${seqnum[$$target]}" ] ; \ then echo "error: *** $$target should not require $$prereq" ; \ fi) ;\ done ) ; \ done ) \ | ( haderror= ; \ while read line ; \ do haderror=$$(($$haderror+1)) ; \ echo "$$line" ; \ done ; \ [ ! "$$haderror" ] || (echo "$$haderror dependency order errors in package listings"; false)) ; \ touch $@ ; \ echo "check succeeded: file dependency order follows package listings" ; \ else echo "make: *** skipping checking the linear ordering of packages, because 'bash' is too old" ; \ fi else DEPFILES := $(VFILES:.v=.v.d) .check-prescribed-ordering.okay: Makefile $(DEPFILES) $(PACKAGE_FILES) @echo "make: *** skipping checking the linear ordering of packages, because Coq version is <8.8" endif # DEPFILES is defined above $(DEPFILES): make-summary-files | build/CoqMakefile.make $(MAKE) -f build/CoqMakefile.make $@ # here we ensure that the travis script checks every package check-travis:.check-travis.okay clean::; rm -f .check-travis.okay .check-travis.okay: Makefile .travis.yml @echo --- checking travis script --- @set -e ; \ for p in $(PACKAGES) ; \ do grep -q "PACKAGES=.*$$p" .travis.yml || ( echo "package $$p not checked by .travis.yml" >&2 ; exit 1 ) ; \ done touch "$@" # here we ensure that every *.v file F in each package P is listed in the corresponding file UniMath/P/.package/files # except for those listed in $GRANDFATHER_UNLISTED (currently none) GRANDFATHER_UNLISTED = check-listing-of-proof-files: @ echo "--- checking every proof file is listed in one of the packages ---" @ if declare -A islisted 2>/dev/null ; \ then for i in $(VFILES) $(GRANDFATHER_UNLISTED) ; \ do islisted[$$i]=yes ; \ done ; \ m=0 ; \ for P in $(PACKAGES) ; \ do find UniMath/$$P -name '*.v' | \ ( \ n=0 ; \ while read F ; \ do if [ "$${islisted[$$F]}" != yes ] ; \ then echo "error: *** file $$F not listed in appropriate file UniMath/*/.package/files" >&2 ; \ n=$$(( $$n + 1 )) ; \ fi ; \ done ; exit $$n ) ; \ m=$$(( $$m + $$? )) ; \ done ; \ if [ $$m != 0 ] ; \ then echo "error: *** $$m unlisted proof files encountered" >&2 ; \ exit 1 ; \ else echo "check succeeded: all proof files listed in packages" ; \ fi ; \ else echo "make: *** skipping checking the listing of proof files, because 'bash' is too old" ; \ fi # Here we check for changes to UniMath/Foundations, which normally does not change. # One step of the travis job will fail if a change is made, see .travis.yml check-for-change-to-Foundations: @echo "--- checking for changes to the Foundations package ---" git fetch origin test -z "`git diff --stat origin/master -- UniMath/Foundations`" @echo "check succeeded: no changes to Foundations" # Here we check for changes to sub/coq, which normally does not change. # One step of the travis job will fail if a change is made, see .travis.yml check-for-submodule-changes: @echo "--- checking for submodule changes ---" git fetch origin test -z "`git diff origin/master sub`" @echo "check succeeded: no changes to submodules" # Here we check that the CONTENTS.md file has been correctly updated, # and committed if any changes have occurred. # One step of the travis job will fail if there are outstanding changes, see .travis.yml check-for-changes-to-CONTENTS.md : UniMath/CONTENTS.md @echo "--- checking that CONTENTS.md is up-to-date ---" test -z "`git diff UniMath/CONTENTS.md`" @echo "check succeeded: CONTENTS.md is up-to-date" # Here we create a table of contents file, in markdown format, for browsing on github # When the file UniMath/CONTENTS.md changes, the new version should be committed to github. all: UniMath/CONTENTS.md UniMath/CONTENTS.md: Makefile UniMath/*/.package/files $(SHOW)'--- making $@' $(HIDE) exec >$@ ; \ echo "# Contents of the UniMath library" ; \ echo "The packages and files are listed here in logical order: each file depends only on files occurring earlier." ; \ for P in $(PACKAGES) ; \ do if [ -f UniMath/$$P/README.md ] ; \ then echo "## Package [$$P]($$P/README.md)" ; \ elif [ -f UniMath/$$P/README ] ; \ then echo "## Package [$$P]($$P/README)" ; \ else echo "## Package $$P" ; \ fi ; \ for F in ` $$@ ; \ echo "(* This file has been auto-generated, do not edit it. *)" ; \ $@ ; \ echo "(* This file has been auto-generated, do not edit it. *)" ; \ for P in $(PACKAGES); \ do echo "Require Export UniMath.$$P.All."; \ done # here we make the emacs local values file all: UniMath/.dir-locals.el UniMath/.dir-locals.el : UniMath/.dir-locals.el.in ifeq ($(BUILD_COQ),yes) sed -e "s/@LOCAL@ //" <$< >$@ else sed -e "s/@LOCAL@ /;;/" <$< >$@ endif distclean::; rm -f UniMath/.dir-locals.el # make *.vo files by calling the coq makefile %.vo : always; $(MAKE) -f build/CoqMakefile.make $@ always: .PHONY: always ################################# # targets best used with INCLUDE=no git-clean: git clean -Xdfq git submodule foreach git clean -xdfq git-deinit: git submodule foreach git clean -xdfq git submodule deinit -f sub/* ################################# UniMath-20231010/README.md000066400000000000000000000074101451125700300145700ustar00rootroot00000000000000[![DOI](https://zenodo.org/badge/17321421.svg)](https://zenodo.org/badge/latestdoi/17321421) Univalent Mathematics ===================== This [Coq](https://coq.inria.fr/) library aims to formalize a substantial body of mathematics using the [univalent point of view](https://en.wikipedia.org/wiki/Univalent_foundations). Trying out UniMath ------------------ You can try out UniMath in the browser by clicking [here](https://unimath.github.io/live/). For instance, you can run the files from the [School on Univalent Mathematics](https://unimath.github.io/Schools/) in the browser. Using UniMath on your computer ------------------------------ To install UniMath on your computer, there are two options: - Install a released binary version of UniMath via the [Coq Platform](https://coq.inria.fr/download). - To develop, and contribute to, UniMath, you should compile the latest version of UniMath yourself - see [INSTALL.md](https://github.com/UniMath/UniMath/blob/master/INSTALL.md). Usage ----- See [USAGE.md](./USAGE.md) Contents -------- The [UniMath subdirectory](UniMath/) contains various packages of formalized mathematics. For more information, see the [UniMath Table of Contents](UniMath/CONTENTS.md). Some scientific articles describing the contents of the UniMath library or work using it are listed in the [wiki](https://github.com/UniMath/UniMath/wiki/Articles-with-accompanying-formalization-in-UniMath). Contributing to UniMath ----------------------- To contribute to UniMath, submit a pull request. Your code will be subject to the copyright and license agreement in [LICENSE.md](LICENSE.md). For the style guide and other instructions, see [UniMath/README.md](UniMath/README.md). Discussing UniMath & Getting Help --------------------------------- - **Questions** about the UniMath library, compilation, and installation of UniMath, etc., can be asked in the [UniMath Zulip](https://unimath.zulipchat.com) (click [here](https://unimath.zulipchat.com/register/) to register) or on the [UniMath mailing list](mailto:univalent-mathematics@googlegroups.com) (archived in a [Google Group](https://groups.google.com/forum/#!forum/univalent-mathematics)). - **Bugs** should be reported in our [UniMath bug tracker on Github](https://github.com/UniMath/UniMath/issues). Citing UniMath -------------- To cite UniMath in your article, you can use the following bibtex item: ```bibtex @Misc{UniMath, author = {Voevodsky, Vladimir and Ahrens, Benedikt and Grayson, Daniel and others}, title = {UniMath --- a computer-checked library of univalent mathematics}, url = {https://github.com/UniMath/UniMath}, howpublished = {available at \url{http://unimath.org}}, doi = {10.5281/zenodo.7848572}, url = {https://doi.org/10.5281/zenodo.7848572} } ``` Note that this requires ```\usepackage{url}``` or ```\usepackage{hyperref}```. The UniMath Coordinating Committee ---------------------------- The UniMath project was started in 2014 by merging the repository [Foundations](https://github.com/UniMath/Foundations), by Vladimir Voevodsky (written in 2010), with two repositories based on it: [rezk_completion](https://github.com/benediktahrens/rezk_completion), by Benedikt Ahrens, and [Ktheory](https://github.com/DanGrayson/Ktheory), by Daniel Grayson. Vladimir Voevodsky was a member of the team until his death in September, 2017. The current members of the UniMath Coordinating Committee are: - Benedikt Ahrens - Daniel Grayson - Michael Lindgren - Peter LeFanu Lumsdaine - Ralph Matthes - Niels van der Weide Acknowledgments --------------- The UniMath development team gratefully acknowledges the great work by the Coq development team in providing the [Coq proof assistant](https://coq.inria.fr/), as well as their support in keeping UniMath compatible with Coq. UniMath-20231010/USAGE.md000066400000000000000000000134241451125700300145010ustar00rootroot00000000000000Using UniMath ============= Browsing and editing a file in the UniMath source tree ------------------------------------------------------ The UniMath library consists of Coq source files (file ending *.v) in the subdirectory `UniMath/UniMath`. Once you have [installed](./INSTALL.md) UniMath, you can start browsing and editing the source files. There are several programs to interactively edit and step through the files, among which are 1. [CoqIDE](https://coq.inria.fr/refman/practical-tools/coqide.html) and 2. Emacs with the [Proof General](https://proofgeneral.github.io/) add-on. Here, we focus on Emacs/Proof General. Automatic setup of work environment using Emacs ----------------------------------------------- When first opening a file in `UniMath/UniMath`, you will be asked to apply a list of local variables, similar to the screenshot below. To accept permanently and not be asked again, type "!". These variables are needed to achieve the automatic setup described below. ![Screenshot Emacs](https://raw.githubusercontent.com/wiki/UniMath/UniMath/Screenshot_Emacs.png) When opening a source file in the directory `UniMath/UniMath` in Emacs, the following happens **automatically**. 1. *The Proof General add-on to Emacs is loaded.* Proof General is an add-on to the text editor Emacs, adding buttons, menus, and keyboard shortcuts to interact with Coq, the proof assistant that UniMath relies on. During the [installation procedure](./INSTALL.md) you have set up Proof General on your computer. 2. *A Unicode input method is loaded.* It allows you to insert Unicode symbols using a LaTeX-like syntax. See [Section on Unicode input below](USAGE.md/#unicode-input) 3. Proof General is informed about the location of the Coq proof assistant installed during the installation of UniMath, and of the options that need to passed to Coq. Items 2 and 3 are achieved through the Emacs configuration file [`.dir-locals.el`](./UniMath/.dir-locals.el) located in the subdirectory `UniMath/UniMath`. For this reason, we recommend you save your UniMath files in this subdirectory as well. Stepping through a Coq file in Emacs/Proof General ------------------------------------------------- Andrej Bauer has a [screencast](https://www.youtube.com/watch?v=l6zqLJQCnzo) on using Emacs/Proof General for writing and stepping through a Coq file. (More screencasts are listed on his [website](http://math.andrej.com/2011/02/22/video-tutorials-for-the-coq-proof-assistant/).) For following his instructions using his example, we recommend you save the Coq file in the subdirectory `UniMath/UniMath` to profit from the automatic setup mentioned above. Note that for Bauer's specific example to work in UniMath, you need to insert the line ``` Require Import Coq.Init.Prelude. ``` at the beginning of the file, since the setup above does not load this library by default when reading a file. Various special commands for dealing with proof scripts are bound to keys in Proof General's proof mode. To get a list of such key bindings, type ` C-h f proof-mode RETURN `. Symbols used in UniMath ----------------------- UniMath uses both ASCII and Unicode notation. Below we give an overview of the most important symbols. To see how to input a specific Unicode character, type `C-u C-x =` (meaning: hold CTRL, then press u and x; release CTRL, press =) while hovering over that character. Below is a partial list of Unicode symbols and identifiers used in UniMath. | Item | UniMath symbol | Unicode input |UniMath ASCII alternative | | -------------------------- | --------------- | ------------------------------ | ------------------------ | | **Type and term constructors** | Product type | `∏ (x : A), B` | `\prod` | `forall x : A, B` | | Function type | `A → B` | `\to` | `A -> B` | | Lambda abstraction | `λ x, e` | `\lambda` | `fun x => e` | | Sigma type | `∑ (x : A), B` | `\sum` | `total2 (fun x => B)` | | Cartesian product type | `X × Y` | `\times` | `dirprod X Y` | | Pair term | `a,,b` | | `a,,b` | | Coproduct type | `X ⨿ Y` | `\union` then select from menu | `coprod X Y` | | Identity type | `a = b` | | `a = b` | | **Univalent logic in `hProp`** | Conjunction | `A ∧ B` | `\and` | `hconj A B` | | Disjunction | `A ∨ B` | `\or` | `hdisj A B` | | Implication | `A ⇒ B` | `\=>` | `himpl A B` | | Negation | `¬ X` | `\neg` | `hneg X` | | Universal quantification | `∀ x , P x` | `\forall` | `forall_hProp A` | | Existential quantification | `∃ x, P x` | `\ex` | `hexists P` | | Propositional truncation | `∥ A ∥` | `\\|\|` | `ishinh A` | | **Category theory** | Object type of `C` | `ob C` or `C` | | | | Morphisms | `C⟦a,b⟧` | `\[[` and `\]]` | `a --> b` | | Functor `F` on objects | `F a` | | | | Functor `F` on morphisms | `#F f` | | | UniMath-20231010/UniMath/000077500000000000000000000000001451125700300146545ustar00rootroot00000000000000UniMath-20231010/UniMath/.dir-locals.el.in000066400000000000000000000023631451125700300177160ustar00rootroot00000000000000((coq-mode . ((eval . (let ((unimath-topdir (expand-file-name (locate-dominating-file buffer-file-name "UniMath")))) (setq fill-column 100) (make-local-variable 'coq-use-project-file) (setq coq-use-project-file nil) (make-local-variable 'coq-prog-args) (setq coq-prog-args ;; these options should match what's used in ../Makefile `("-quiet" "-emacs" "-noinit" "-indices-matter" "-type-in-type" "-w" "-notation-overridden" "-Q" ,(concat unimath-topdir "UniMath") "UniMath" ) ) (make-local-variable 'coq-prog-name) @LOCAL@ (setq coq-prog-name (concat unimath-topdir "sub/coq/bin/coqtop")) (make-local-variable 'before-save-hook) (add-hook 'before-save-hook 'delete-trailing-whitespace) (modify-syntax-entry ?' "w") (modify-syntax-entry ?_ "w") (if (not (memq 'agda-input features)) (load (concat unimath-topdir "emacs/agda/agda-input"))) (if (not (member '("chimney" "╝") agda-input-user-translations)) (progn (setq agda-input-user-translations (cons '("chimney" "╝") agda-input-user-translations)) (setq agda-input-user-translations (cons '("==>" "⟹") agda-input-user-translations)) (agda-input-setup))) (set-input-method "Agda")))))) UniMath-20231010/UniMath/.gitignore000066400000000000000000000002151451125700300166420ustar00rootroot00000000000000*.cmi *.cmx *.cmxs *.css *.glob *.html *.native *.o *.timing *.v# *.v.d *.vo .#* .*.aux N*.cmi N*.cmx N*.cmxs N*.native N*.o /All.v /*/All.v UniMath-20231010/UniMath/Algebra/000077500000000000000000000000001451125700300162115ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/.package/000077500000000000000000000000001451125700300176625ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/.package/files000066400000000000000000000017121451125700300207100ustar00rootroot00000000000000 BinaryOperations.v Monoids.v Groups.v GroupAction.v RigsAndRings.v RigsAndRings/Ideals.v Domains_and_Fields.v DivisionRig.v Apartness.v ConstructiveStructures.v Archimedean.v IteratedBinaryOperations.v Free_Monoids_and_Groups.v Tests.v Modules/Core.v Modules/Submodule.v Modules/Multimodules.v Modules/Examples.v Modules/Quotient.v Modules.v Matrix.v Universal/HVectors.v Universal/SortedTypes.v Universal/Signatures.v Universal/Algebras.v Universal/Terms.v Universal/TermAlgebras.v Universal/VTerms.v Universal/FreeAlgebras.v Universal/Equations.v Universal/EqAlgebras.v Universal/Examples/Nat.v Universal/Examples/Bool.v Universal/Examples/Monoid.v Universal/Examples/Group.v Universal/Examples/ListDataType.v Universal/Examples/Tests.v Universal.v GaussianElimination/Auxiliary.v GaussianElimination/Vectors.v GaussianElimination/Matrices.v GaussianElimination/RowOps.v GaussianElimination/Elimination.v GaussianElimination/Corollaries.v GaussianElimination/Tests.v UniMath-20231010/UniMath/Algebra/Apartness.v000066400000000000000000000172171451125700300203500ustar00rootroot00000000000000(** * Definition of appartness relation *) (** Catherine Lelay. Sep. 2015 *) Unset Kernel Term Sharing. Require Export UniMath.Algebra.BinaryOperations. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.DecidablePropositions. (** ** Apartness *) Definition isaprel {X : UU} (ap : hrel X) := isirrefl ap × issymm ap × iscotrans ap. Lemma isaprop_isaprel {X : UU} (ap : hrel X) : isaprop (isaprel ap). Proof. apply isapropdirprod. apply isaprop_isirrefl. apply isapropdirprod. apply isaprop_issymm. apply isaprop_iscotrans. Qed. Definition aprel (X : UU) := ∑ ap : hrel X, isaprel ap. Definition aprel_pr1 {X : UU} (ap : aprel X) : hrel X := pr1 ap. Coercion aprel_pr1 : aprel >-> hrel. Definition apSet := ∑ X : hSet, aprel X. Definition apSet_pr1 (X : apSet) : hSet := pr1 X. Coercion apSet_pr1 : apSet >-> hSet. Arguments apSet_pr1 X: simpl never. Definition apSet_pr2 (X : apSet) : aprel X := pr2 X. Declare Scope ap_scope. Notation "x # y" := (apSet_pr2 _ x y) : ap_scope. Delimit Scope ap_scope with ap. Local Open Scope ap_scope. (** Lemmas about apartness *) Lemma isirreflapSet {X : apSet} : ∏ x : X, ¬ (x # x). Proof. exact (pr1 (pr2 (pr2 X))). Qed. Lemma issymmapSet {X : apSet} : ∏ x y : X, x # y -> y # x. Proof. exact (pr1 (pr2 (pr2 (pr2 X)))). Qed. Lemma iscotransapSet {X : apSet} : ∏ x y z : X, x # z -> x # y ∨ y # z. Proof. exact (pr2 (pr2 (pr2 (pr2 X)))). Qed. Close Scope ap_scope. (** ** Tight apartness *) Definition istight {X : UU} (R : hrel X) := ∏ x y : X, ¬ (R x y) -> x = y. Definition istightap {X : UU} (ap : hrel X) := isaprel ap × istight ap. Definition tightap (X : UU) := ∑ ap : hrel X, istightap ap. Definition tightap_aprel {X : UU} (ap : tightap X) : aprel X := pr1 ap ,, (pr1 (pr2 ap)). Coercion tightap_aprel : tightap >-> aprel. Definition tightapSet := ∑ X : hSet, tightap X. Definition tightapSet_apSet (X : tightapSet) : apSet := pr1 X ,, (tightap_aprel (pr2 X)). Coercion tightapSet_apSet : tightapSet >-> apSet. Definition tightapSet_rel (X : tightapSet) : hrel X := (pr1 (pr2 X)). Declare Scope tap_scope. Notation "x ≠ y" := (tightapSet_rel _ x y) (at level 70, no associativity) : tap_scope. Delimit Scope tap_scope with tap. Local Open Scope tap_scope. (** Some lemmas *) Lemma isirrefltightapSet {X : tightapSet} : ∏ x : X, ¬ (x ≠ x). Proof. exact isirreflapSet. Qed. Lemma issymmtightapSet {X : tightapSet} : ∏ x y : X, x ≠ y -> y ≠ x. Proof. exact issymmapSet. Qed. Lemma iscotranstightapSet {X : tightapSet} : ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z. Proof. exact iscotransapSet. Qed. Lemma istighttightapSet {X : tightapSet} : ∏ x y : X, ¬ (x ≠ y) -> x = y. Proof. exact (pr2 (pr2 (pr2 X))). Qed. Lemma istighttightapSet_rev {X : tightapSet} : ∏ x y : X, x = y -> ¬ (x ≠ y). Proof. intros x _ <-. now apply isirrefltightapSet. Qed. Lemma tightapSet_dec {X : tightapSet} : LEM -> ∏ x y : X, (x != y <-> x ≠ y). Proof. intros Hdec x y. destruct (Hdec (x ≠ y)) as [ Hneq | Heq ]. - split. + intros _ ; apply Hneq. + intros _ Heq. rewrite <- Heq in Hneq. revert Hneq. now apply isirrefltightapSet. - split. + intros Hneq. apply fromempty, Hneq. now apply istighttightapSet. + intros Hneq. exact (fromempty (Heq Hneq)). Qed. (** ** Operations and apartness *) Definition isapunop {X : tightapSet} (op :unop X) := ∏ x y : X, op x ≠ op y -> x ≠ y. Lemma isaprop_isapunop {X : tightapSet} (op :unop X) : isaprop (isapunop op). Proof. intros ap. apply impred_isaprop ; intro x. apply impred_isaprop ; intro y. apply isapropimpl. now apply pr2. Qed. Definition islapbinop {X : tightapSet} (op : binop X) := ∏ x, isapunop (λ y, op y x). Definition israpbinop {X : tightapSet} (op : binop X) := ∏ x, isapunop (λ y, op x y). Definition isapbinop {X : tightapSet} (op : binop X) := (islapbinop op) × (israpbinop op). Lemma isaprop_islapbinop {X : tightapSet} (op : binop X) : isaprop (islapbinop op). Proof. apply impred_isaprop ; intro x. now apply isaprop_isapunop. Qed. Lemma isaprop_israpbinop {X : tightapSet} (op : binop X) : isaprop (israpbinop op). Proof. apply impred_isaprop ; intro x. now apply isaprop_isapunop. Qed. Lemma isaprop_isapbinop {X : tightapSet} (op :binop X) : isaprop (isapbinop op). Proof. intros ap. apply isapropdirprod. now apply isaprop_islapbinop. now apply isaprop_israpbinop. Qed. Definition apbinop (X : tightapSet) := ∑ op : binop X, isapbinop op. Definition apbinop_pr1 {X : tightapSet} (op : apbinop X) : binop X := pr1 op. Coercion apbinop_pr1 : apbinop >-> binop. Definition apsetwithbinop := ∑ X : tightapSet, apbinop X. Definition apsetwithbinop_pr1 (X : apsetwithbinop) : tightapSet := pr1 X. Coercion apsetwithbinop_pr1 : apsetwithbinop >-> tightapSet. Definition apsetwithbinop_setwithbinop : apsetwithbinop -> setwithbinop := λ X : apsetwithbinop, (apSet_pr1 (apsetwithbinop_pr1 X)),, (pr1 (pr2 X)). Definition op {X : apsetwithbinop} : binop X := op (X := apsetwithbinop_setwithbinop X). Definition apsetwith2binop := ∑ X : tightapSet, apbinop X × apbinop X. Definition apsetwith2binop_pr1 (X : apsetwith2binop) : tightapSet := pr1 X. Coercion apsetwith2binop_pr1 : apsetwith2binop >-> tightapSet. Definition apsetwith2binop_setwith2binop : apsetwith2binop -> setwith2binop := λ X : apsetwith2binop, apSet_pr1 (apsetwith2binop_pr1 X),, pr1 (pr1 (pr2 X)),, pr1 (pr2 (pr2 X)). Definition op1 {X : apsetwith2binop} : binop X := op1 (X := apsetwith2binop_setwith2binop X). Definition op2 {X : apsetwith2binop} : binop X := op2 (X := apsetwith2binop_setwith2binop X). (** Lemmas about sets with binops *) Section apsetwithbinop_pty. Context {X : apsetwithbinop}. Lemma islapbinop_op : ∏ x x' y : X, op x y ≠ op x' y -> x ≠ x'. Proof. intros x y y'. now apply (pr1 (pr2 (pr2 X))). Qed. Lemma israpbinop_op : ∏ x y y' : X, op x y ≠ op x y' -> y ≠ y'. Proof. intros x y y'. now apply (pr2 (pr2 (pr2 X))). Qed. Lemma isapbinop_op : ∏ x x' y y' : X, op x y ≠ op x' y' -> x ≠ x' ∨ y ≠ y'. Proof. intros x x' y y' Hop. apply (iscotranstightapSet _ (op x' y)) in Hop. revert Hop ; apply hinhfun ; intros [Hop | Hop]. - left ; revert Hop. now apply islapbinop_op. - right ; revert Hop. now apply israpbinop_op. Qed. End apsetwithbinop_pty. Section apsetwith2binop_pty. Context {X : apsetwith2binop}. Definition apsetwith2binop_apsetwithbinop1 : apsetwithbinop := (pr1 X) ,, (pr1 (pr2 X)). Definition apsetwith2binop_apsetwithbinop2 : apsetwithbinop := (pr1 X) ,, (pr2 (pr2 X)). Lemma islapbinop_op1 : ∏ x x' y : X, op1 x y ≠ op1 x' y -> x ≠ x'. Proof. exact (islapbinop_op (X := apsetwith2binop_apsetwithbinop1)). Qed. Lemma israpbinop_op1 : ∏ x y y' : X, op1 x y ≠ op1 x y' -> y ≠ y'. Proof. exact (israpbinop_op (X := apsetwith2binop_apsetwithbinop1)). Qed. Lemma isapbinop_op1 : ∏ x x' y y' : X, op1 x y ≠ op1 x' y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (isapbinop_op (X := apsetwith2binop_apsetwithbinop1)). Qed. Lemma islapbinop_op2 : ∏ x x' y : X, op2 x y ≠ op2 x' y -> x ≠ x'. Proof. exact (islapbinop_op (X := apsetwith2binop_apsetwithbinop2)). Qed. Lemma israpbinop_op2 : ∏ x y y' : X, op2 x y ≠ op2 x y' -> y ≠ y'. Proof. exact (israpbinop_op (X := apsetwith2binop_apsetwithbinop2)). Qed. Lemma isapbinop_op2 : ∏ x x' y y' : X, op2 x y ≠ op2 x' y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (isapbinop_op (X := apsetwith2binop_apsetwithbinop2)). Qed. End apsetwith2binop_pty. Close Scope tap_scope. UniMath-20231010/UniMath/Algebra/Archimedean.v000066400000000000000000000712621451125700300206100ustar00rootroot00000000000000(** * Archimedean property *) (** ** Preamble *) (** Settings *) Unset Kernel Term Sharing. (** Imports *) Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.DivisionRig. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.ConstructiveStructures. Require Import UniMath.MoreFoundations.Tactics. Import UniMath.Algebra.Monoids.AddNotation. (** ** The standard function from the natural numbers to a monoid *) Fixpoint natmult {X : monoid} (n : nat) (x : X) : X := match n with | O => 0%addmonoid | S O => x | S m => (x + natmult m x)%addmonoid end. Definition nattorig {X : rig} (n : nat) : X := natmult (X := rigaddabmonoid X) n 1%rig. Definition nattoring {X : ring} (n : nat) : X := nattorig (X := ringtorig X) n. Lemma natmultS : ∏ {X : monoid} (n : nat) (x : X), natmult (S n) x = (x + natmult n x)%addmonoid. Proof. intros X n x. induction n as [|n]. - now rewrite runax. - reflexivity. Qed. Lemma nattorigS {X : rig} : ∏ (n : nat), nattorig (X := X) (S n) = (1 + nattorig n)%rig. Proof. intros. now apply (natmultS (X := rigaddabmonoid X)). Qed. Lemma nattorig_natmult : ∏ {X : rig} (n : nat) (x : X), (nattorig n * x)%rig = natmult (X := rigaddabmonoid X) n x. Proof. intros. induction n as [|n IHn]. - now apply rigmult0x. - rewrite nattorigS, natmultS. now rewrite rigrdistr, IHn, riglunax2. Qed. Lemma natmult_plus : ∏ {X : monoid} (n m : nat) (x : X), natmult (n + m) x = (natmult n x + natmult m x)%addmonoid. Proof. induction n as [|n IHn] ; intros m x. - rewrite lunax. reflexivity. - change (S n + m)%nat with (S (n + m))%nat. rewrite !natmultS, IHn, assocax. reflexivity. Qed. Lemma nattorig_plus : ∏ {X : rig} (n m : nat), (nattorig (n + m) : X) = (nattorig n + nattorig m)%rig. Proof. intros X n m. apply (natmult_plus (X := rigaddabmonoid X)). Qed. Lemma natmult_mult : ∏ {X : monoid} (n m : nat) (x : X), natmult (n * m) x = (natmult n (natmult m x))%addmonoid. Proof. induction n as [|n IHn] ; intros m x. - reflexivity. - simpl (_ * _)%nat. assert (H : S n = (n + 1)%nat). { rewrite <- plus_n_Sm, natplusr0. reflexivity. } rewrite H ; clear H. rewrite !natmult_plus, IHn. reflexivity. Qed. Lemma nattorig_mult : ∏ {X : rig} (n m : nat), (nattorig (n * m) : X) = (nattorig n * nattorig m)%rig. Proof. intros X n m. unfold nattorig. rewrite (natmult_mult (X := rigaddabmonoid X)), <- nattorig_natmult. reflexivity. Qed. Lemma natmult_op {X : monoid} : ∏ (n : nat) (x y : X), (x + y = y + x)%addmonoid -> natmult n (x + y)%addmonoid = (natmult n x + natmult n y)%addmonoid. Proof. intros. induction n as [|n IHn]. - rewrite lunax. reflexivity. - rewrite natmultS, assocax, IHn, <- (assocax _ y). assert (X1 : (y + natmult n x = natmult n x + y)%addmonoid). { clear IHn. induction n as [|n IHn]. - rewrite lunax, runax. reflexivity. - rewrite !natmultS, <- assocax, <- X0, !assocax, IHn. reflexivity. } rewrite X1, assocax, <- natmultS, <- assocax, <- natmultS. reflexivity. Qed. Lemma natmult_binophrel {X : monoid} (R : hrel X) : istrans R -> isbinophrel R -> ∏ (n : nat) (x y : X), R x y -> R (natmult (S n) x) (natmult (S n) y). Proof. intros Hr Hop n x y H. induction n as [|n IHn]. exact H. rewrite !(natmultS (S _)). eapply Hr. apply (pr1 Hop). exact IHn. apply (pr2 Hop). exact H. Qed. (** ** relation *) Definition setquot_aux {X : monoid} (R : hrel X) : hrel X := λ x y : X, ∃ c : X, R (x + c)%addmonoid (y + c)%addmonoid. Lemma istrans_setquot_aux {X : abmonoid} (R : hrel X) : istrans R -> isbinophrel R -> istrans (setquot_aux R). Proof. intros Hr Hop. intros x y z. apply hinhfun2. intros (c1,Hc1) (c2,Hc2). exists (c1 + c2)%addmonoid. eapply Hr. rewrite <- assocax. apply (pr2 Hop). exact Hc1. rewrite assocax, (commax _ c1), <- !assocax. apply (pr2 Hop). exact Hc2. Qed. Lemma isbinophrel_setquot_aux {X : abmonoid} (R : hrel X) : isbinophrel R -> isbinophrel (setquot_aux R). Proof. intros Hop. split. - intros x y z. apply hinhfun. intros (c,Hc). exists c. rewrite !assocax. apply (pr1 Hop). exact Hc. - intros x y z. apply hinhfun. intros (c,Hc). exists c. rewrite !assocax, (commax _ z), <- !assocax. apply (pr2 Hop). exact Hc. Qed. Lemma isequiv_setquot_aux {X : abmonoid} (R : hrel X) : isinvbinophrel R -> ∏ x y : X, (setquot_aux R) x y <-> R x y. Proof. intros H x y. split. apply hinhuniv. intros (c,H'). generalize H'; clear H'. apply (pr2 H). intros H1. apply hinhpr. exists 0%addmonoid. rewrite !runax. exact H1. Qed. (** ** Archimedean property in a monoid *) Definition isarchmonoid {X : abmonoid} (R : hrel X) := ∏ x y1 y2 : X, R y1 y2 -> (∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2)) × (∃ n : nat, R (natmult n y1) (natmult n y2 + x)%addmonoid). Definition isarchmonoid_1 {X : abmonoid} (R : hrel X) : isarchmonoid R -> ∏ x y1 y2 : X, R y1 y2 -> ∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2) := λ H x y1 y2 Hy, (pr1 (H x y1 y2 Hy)). Definition isarchmonoid_2 {X : abmonoid} (R : hrel X) : isarchmonoid R -> ∏ x y1 y2 : X, R y1 y2 -> ∃ n : nat, R (natmult n y1) (natmult n y2 + x)%addmonoid := λ H x y1 y2 Hy, (pr2 (H x y1 y2 Hy)). (** ** Archimedean property in a group *) Definition isarchgr {X : abgr} (R : hrel X) := ∏ x y1 y2 : X, R y1 y2 -> ∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2). Local Lemma isarchgr_isarchmonoid_aux {X : abgr} (R : hrel X) : isbinophrel R -> ∏ (n : nat) (x y1 y2 : X), R (natmult n y1 * grinv X x)%multmonoid (natmult n y2) -> R (natmult n y1) (natmult n y2 * x)%multmonoid. Proof. intros Hop. intros n x y1 y2 Hy. apply (pr2 (isinvbinophrelgr _ Hop) _ _ (grinv X x)). rewrite assocax, (grrinvax X), runax. exact Hy. Qed. Lemma isarchgr_isarchmonoid {X : abgr} (R : hrel X) : isbinophrel R -> isarchgr R -> isarchmonoid (X := abgrtoabmonoid X) R. Proof. intros Hop H x y1 y2 Hy. split. - now apply H. - generalize (H (grinv X x) _ _ Hy). apply hinhfun. intros (n,Hn). exists n. apply isarchgr_isarchmonoid_aux. exact Hop. exact Hn. Defined. Lemma isarchmonoid_isarchgr {X : abgr} (R : hrel X) : isarchmonoid (X := abgrtoabmonoid X) R -> isarchgr R. Proof. intros H x y1 y2 Hy. apply (isarchmonoid_1 _ H x y1 y2 Hy). Defined. Local Lemma isarchabgrdiff_aux {X : abmonoid} (R : hrel X) (Hr : isbinophrel R) (Hr' : istrans R) (y1 y2 x : abmonoiddirprod X X) (n1 : nat) (Hn1 : setquot_aux R (natmult n1 (pr1 y1 * pr2 y2) * pr1 x)%multmonoid (natmult n1 (pr1 y2 * pr2 y1)%multmonoid)) (n2 : nat) (Hn2 : setquot_aux R (natmult n2 (pr1 y1 * pr2 y2)%multmonoid) (natmult n2 (pr1 y2 * pr2 y1) * pr2 x)%multmonoid) : abgrdiffrel X Hr (natmult (X := abgrdiff X) (n1 + n2) (setquotpr (binopeqrelabgrdiff X) y1) * setquotpr (binopeqrelabgrdiff X) x)%multmonoid (natmult (X := abgrdiff X) (n1 + n2) (setquotpr (binopeqrelabgrdiff X) y2)). Proof. intros. assert (H0 : ∏ n y, natmult (X := abgrdiff X) n (setquotpr (binopeqrelabgrdiff X) y) = setquotpr (binopeqrelabgrdiff X) (natmult n (pr1 y) ,, natmult n (pr2 y))). { intros n y. induction n as [|n IHn]. reflexivity. rewrite !natmultS, IHn. reflexivity. } rewrite !H0. revert Hn1 Hn2. apply hinhfun2 ; simpl. intros (c1,Hc1) (c2,Hc2). exists (c1 * c2)%multmonoid. eapply Hr'. assert (X0 : (natmult (n1 + n2) (pr1 y1) * pr1 x * natmult (n1 + n2) (pr2 y2) * (c1 * c2) = (natmult n1 (pr1 y1 * pr2 y2) * pr1 x * c1) * (natmult n2 (pr1 y1 * pr2 y2) * c2))%multmonoid). { rewrite !natmult_op, !natmult_plus, !assocax. apply maponpaths. rewrite commax, !assocax. rewrite commax, !assocax. apply maponpaths. rewrite commax, !assocax. rewrite commax, !assocax. rewrite commax, !assocax. rewrite commax, !assocax. apply maponpaths. rewrite commax, !assocax. apply maponpaths. rewrite commax, !assocax. reflexivity. apply commax. apply commax. } simpl in X0 |- *. rewrite X0 ; clear X0. apply (pr2 Hr). apply Hc1. assert (X0 : (natmult (n1 + n2) (pr1 y2) * (natmult (n1 + n2) (pr2 y1) * pr2 x) * (c1 * c2) = (natmult n1 (pr1 y2 * pr2 y1) * c1) * (natmult n2 (pr1 y2 * pr2 y1) * pr2 x * c2))%multmonoid). { rewrite !natmult_op, !natmult_plus, !assocax. apply maponpaths. rewrite commax, !assocax. apply maponpaths. rewrite commax, !assocax. rewrite commax, !assocax. apply maponpaths. rewrite commax, !assocax. reflexivity. apply commax. apply commax. } simpl in X0 |- *. rewrite X0 ; clear X0. apply (pr1 Hr). apply Hc2. Qed. Lemma isarchabgrdiff {X : abmonoid} (R : hrel X) (Hr : isbinophrel R) : istrans R -> isarchmonoid (setquot_aux R) -> isarchgr (X := abgrdiff X) (abgrdiffrel X (L := R) Hr). Proof. intros Hr' H. simple refine (setquotuniv3prop _ (λ x y1 y2, (abgrdiffrel X Hr y1 y2 -> ∃ n : nat, abgrdiffrel X Hr (natmult (X := abgrdiff X) n y1 * x)%multmonoid (natmult (X := abgrdiff X) n y2)) ,, _) _). abstract apply isapropimpl, propproperty. intros x y1 y2 Hy. eapply hinhfun2. 2: apply (isarchmonoid_1 _ H (pr1 x) (pr1 y1 * pr2 y2)%multmonoid (pr1 y2 * pr2 y1)%multmonoid), Hy. 2: apply (isarchmonoid_2 _ H (pr2 x) (pr1 y1 * pr2 y2)%multmonoid (pr1 y2 * pr2 y1)%multmonoid), Hy. intros n1 n2. exists (pr1 n1 + pr1 n2)%nat. apply isarchabgrdiff_aux. exact Hr'. exact (pr2 n1). exact (pr2 n2). Defined. (** ** Archimedean property in a rig *) Definition isarchrig {X : rig} (R : hrel X) := (∏ y1 y2 : X, R y1 y2 -> ∃ n : nat, R (nattorig n * y1)%rig (1 + nattorig n * y2)%rig) × (∏ x : X, ∃ n : nat, R (nattorig n) x) × (∏ x : X, ∃ n : nat, R (nattorig n + x)%rig 0%rig). Definition isarchrig_diff {X : rig} (R : hrel X) : isarchrig R -> ∏ y1 y2 : X, R y1 y2 -> ∃ n : nat, R (nattorig n * y1)%rig (1 + nattorig n * y2)%rig := pr1. Definition isarchrig_gt {X : rig} (R : hrel X) : isarchrig R -> ∏ x : X, ∃ n : nat, R (nattorig n) x := λ H, (pr1 (pr2 H)). Definition isarchrig_pos {X : rig} (R : hrel X) : isarchrig R -> ∏ x : X, ∃ n : nat, R (nattorig n + x)%rig 0%rig := λ H, (pr2 (pr2 H)). Lemma isarchrig_setquot_aux {X : rig} (R : hrel X) : isinvbinophrel (X := rigaddabmonoid X) R → isarchrig R → isarchrig (setquot_aux (X := rigaddabmonoid X) R). Proof. intros Hr H. split ; [ | split]. - intros y1 y2. apply hinhuniv. intros Hy. generalize (isarchrig_diff R H y1 y2 (pr2 Hr _ _ _ (pr2 Hy))). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%rig. rewrite runax, runax. exact (pr2 n). - intros x. generalize (isarchrig_gt R H x). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%rig. rewrite runax, runax. exact (pr2 n). - intros x. generalize (isarchrig_pos R H x). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%rig. rewrite runax, runax. exact (pr2 n). Qed. Local Lemma isarchrig_isarchmonoid_1_aux {X : rig} (R : hrel X) (Hr1 : R 1%rig 0%rig) (Hr : istrans R) (Hop1 : isbinophrel (X := rigaddabmonoid X) R) (x y1 y2 : rigaddabmonoid X) (m : nat) (Hm : R (nattorig m * y1)%ring (1%rig + nattorig m * y2)%ring) (n : nat) (Hn : R (nattorig n + x)%ring 0%rig) : R (natmult (max 1 n * m) y1 * x)%multmonoid (natmult (max 1 n * m) y2). Proof. intros. rewrite !nattorig_natmult in Hm. destruct n. + rewrite riglunax1 in Hn. eapply Hr. apply (pr1 Hop1). exact Hn. rewrite runax. simpl. rewrite <- (lunax _ (natmult m y2)). eapply Hr. exact Hm. apply (pr2 Hop1). exact Hr1. + rewrite natmult_mult. simpl max. rewrite <- (runax _ (natmult (S n * m) y2)). refine (Hr _ _ _ _ _). apply (pr2 Hop1). apply natmult_binophrel. exact Hr. exact Hop1. exact Hm. rewrite rigcomm1. change BinaryOperations.op1 with (BinaryOperations.op (X := rigaddabmonoid X)). rewrite natmult_op, assocax, <- natmult_mult. apply (pr1 Hop1). exact Hn. apply rigcomm1. Qed. Local Lemma isarchrig_isarchmonoid_2_aux {X : rig} (R : hrel X) (Hr1 : R 1%rig 0%rig) (Hr : istrans R) (Hop1 : isbinophrel (X := rigaddabmonoid X) R) (x y1 y2 : rigaddabmonoid X) (m : nat) (Hm : R (nattorig m * y1)%ring (1%rig + nattorig m * y2)%ring) (n : nat) (Hn : R (nattorig n) x) : R (natmult (max 1 n * m) y1) (natmult (max 1 n * m) y2 * x)%multmonoid. Proof. intros. rewrite !nattorig_natmult in Hm. destruct n. + eapply Hr. exact Hm. rewrite rigcomm1. apply (pr1 Hop1). eapply Hr. exact Hr1. exact Hn. + rewrite natmult_mult. eapply Hr. simpl max. apply natmult_binophrel. exact Hr. exact Hop1. exact Hm. rewrite rigcomm1. change BinaryOperations.op1 with (BinaryOperations.op (X := rigaddabmonoid X)). rewrite natmult_op, <- natmult_mult. apply (pr1 Hop1). exact Hn. apply rigcomm1. Qed. Lemma isarchrig_isarchmonoid {X : rig} (R : hrel X) : R 1%rig 0%rig -> istrans R -> isbinophrel (X := rigaddabmonoid X) R -> isarchrig R -> isarchmonoid (X := rigaddabmonoid X) R. Proof. intros Hr1 Hr Hop1 H x y1 y2 Hy. split. - generalize (isarchrig_diff _ H _ _ Hy) (isarchrig_pos _ H x). apply hinhfun2. intros m n. exists (max 1 (pr1 n) * (pr1 m))%nat. apply isarchrig_isarchmonoid_1_aux. exact Hr1. exact Hr. exact Hop1. exact (pr2 m). exact (pr2 n). - generalize (isarchrig_diff _ H _ _ Hy) (isarchrig_gt _ H x). apply hinhfun2. intros m n. exists (max 1 (pr1 n) * (pr1 m))%nat. apply isarchrig_isarchmonoid_2_aux. exact Hr1. exact Hr. exact Hop1. exact (pr2 m). exact (pr2 n). Defined. Lemma isarchmonoid_isarchrig {X : rig} (R : hrel X) : (R 1%rig 0%rig) -> isarchmonoid (X := rigaddabmonoid X) R -> isarchrig R. Proof. intros H01 H. repeat split. - intros y1 y2 Hy. generalize (isarchmonoid_2 _ H 1%rig y1 y2 Hy). apply hinhfun. intros n. exists (pr1 n). abstract (rewrite !nattorig_natmult, rigcomm1 ; exact (pr2 n)). - intros x. generalize (isarchmonoid_2 _ H x _ _ H01). apply hinhfun. intros n. exists (pr1 n). abstract ( pattern x at 1; rewrite <- (riglunax1 X x) ; pattern (0%rig : X) at 1; rewrite <- (rigmultx0 X (nattorig (pr1 n))) ; rewrite nattorig_natmult ; exact (pr2 n)). - intros x. generalize (isarchmonoid_1 _ H x _ _ H01). apply hinhfun. intros n. exists (pr1 n). abstract ( pattern (0%rig : X) at 1; rewrite <- (rigmultx0 X (nattorig (pr1 n))), nattorig_natmult ; exact (pr2 n)). Defined. (** ** Archimedean property in a ring *) Definition isarchring {X : ring} (R : hrel X) := (∏ x : X, R x 0%ring -> ∃ n : nat, R (nattoring n * x)%ring 1%ring) × (∏ x : X, ∃ n : nat, R (nattoring n) x). Definition isarchring_1 {X : ring} (R : hrel X) : isarchring R -> ∏ x : X, R x 0%ring -> ∃ n : nat, R (nattoring n * x)%ring 1%ring := pr1. Definition isarchring_2 {X : ring} (R : hrel X) : isarchring R -> ∏ x : X, ∃ n : nat, R (nattoring n) x := pr2. Lemma isarchring_isarchrig {X : ring} (R : hrel X) : isbinophrel (X := rigaddabmonoid X) R -> isarchring R -> isarchrig (X := ringtorig X) R. Proof. intros Hop1 H. repeat split. - intros y1 y2 Hy. assert (X0 : R (y1 - y2)%ring 0%ring). abstract (apply (pr2 (isinvbinophrelgr X Hop1)) with y2 ; change BinaryOperations.op with (@BinaryOperations.op1 X) ; rewrite ringassoc1, ringlinvax1, ringlunax1, ringrunax1 ; exact Hy). generalize (isarchring_1 _ H _ X0). apply hinhfun. intros n. exists (pr1 n). abstract (rewrite <- (ringrunax1 _ (nattorig (pr1 n) * y1)%ring), <- (ringlinvax1 _ (nattorig (pr1 n) * y2)%ring), <- ringassoc1 ; apply (pr2 Hop1) ; rewrite <- ringrmultminus, <- ringldistr ; exact (pr2 n)). - apply isarchring_2. exact H. - intros x. generalize (isarchring_2 _ H (- x)%ring). apply hinhfun. intros n. exists (pr1 n). abstract (change 0%rig with (0%ring : X) ; rewrite <- (ringlinvax1 _ x) ; apply (pr2 Hop1) ; exact (pr2 n)). Defined. Lemma isarchrig_isarchring {X : ring} (R : hrel X) : isbinophrel (X := rigaddabmonoid X) R -> isarchrig (X := ringtorig X) R -> isarchring R. Proof. intros Hr H. split. - intros x Hx. generalize (isarchrig_diff _ H _ _ Hx). apply hinhfun. intros (n,Hn). exists n. rewrite <- (ringrunax1 _ 1%ring), <- (ringmultx0 _ (nattoring n)). exact Hn. - apply (isarchrig_gt (X := ringtorig X)). exact H. Defined. Lemma isarchring_isarchgr {X : ring} (R : hrel X) : R 1%ring 0%ring -> istrans R -> isbinophrel (X := X) R -> isarchring R -> isarchgr (X := X) R. Proof. intros Hr0 Hr Hop1 H. apply isarchmonoid_isarchgr. apply (isarchrig_isarchmonoid (X := X)). exact Hr0. exact Hr. exact Hop1. now apply isarchring_isarchrig. Defined. Lemma isarchgr_isarchring {X : ring} (R : hrel X) : R 1%ring 0%ring -> istrans R -> isbinophrel (X := X) R -> isarchgr (X := X) R -> isarchring R. Proof. intros Hr0 Hr Hop1 H. apply isarchrig_isarchring. exact Hop1. apply isarchmonoid_isarchrig. exact Hr0. now apply (isarchgr_isarchmonoid (X := X)). Defined. Theorem isarchrigtoring : ∏ (X : rig) (R : hrel X) (Hr : R 1%rig 0%rig) (Hadd : isbinophrel (X := rigaddabmonoid X) R) (Htra : istrans R) (Harch : isarchrig (setquot_aux (X := rigaddabmonoid X) R)), isarchring (X := rigtoring X) (rigtoringrel X Hadd). Proof. intros. apply isarchgr_isarchring. abstract (apply hinhpr ; simpl ; exists 0%rig ; rewrite !rigrunax1 ; exact Hr). now apply (istransabgrdiffrel (rigaddabmonoid X)). now generalize Hadd ; apply isbinopabgrdiffrel. apply (isarchabgrdiff (X := rigaddabmonoid X)). exact Htra. apply isarchrig_isarchmonoid. abstract (apply hinhpr ; simpl ; exists 0%rig ; rewrite !rigrunax1 ; exact Hr). (now apply (istrans_setquot_aux (X := rigaddabmonoid X))). (now apply (isbinophrel_setquot_aux (X := rigaddabmonoid X))). exact Harch. (* Proof without (Hr : R 1%rig 0%rig) split. - intros xx Hx0. generalize (pr1 (pr2 xx)). apply hinhuniv ; intros (x,Hx). rewrite <- (setquotl0 _ xx (x,,Hx)) in Hx0 |- * ; simpl pr1 in Hx0 |- * ; clear xx Hx. eapply hinhfun. 2: apply (isarchrig_diff _ Harch (pr1 x) (pr2 x)). intros (n,Hn). exists n. assert ((nattoring (X := rigtoring X) n * setquotpr (binopeqrelabgrdiff (rigaddabmonoid X)) x)%ring = (setquotpr (binopeqrelabgrdiff (rigaddabmonoid X)) (nattorig n * pr1 x ,, nattorig n * pr2 x))%ring). { clear. induction n as [|n IHn]. - rewrite !rigmult0x, ringmult0x. reflexivity. - unfold nattoring. rewrite !nattorigS, !rigrdistr, ringrdistr, !riglunax2, ringlunax2. simpl. eapply pathscomp0. apply maponpaths. apply IHn. reflexivity. } rewrite X0 ; clear X0. revert Hn. apply hinhfun ; simpl. intros (c,Hc). exists c. rewrite rigrunax1. exact Hc. revert Hx0. apply hinhfun ; simpl. intros (c,Hc). exists c. rewrite riglunax1, rigrunax1 in Hc. exact Hc. - intros xx. generalize (pr1 (pr2 xx)). apply hinhuniv ; intros (x,Hx). rewrite <- (setquotl0 _ xx (x,,Hx)) ; simpl pr1 ; clear xx Hx. generalize (isarchrig_gt _ Harch (pr1 x)) (isarchrig_pos _ Harch (pr2 x)). apply hinhfun2. intros (n1,Hn1) (n2,Hn2). exists (n1 + n2)%nat. revert Hn1 Hn2. assert (nattoring (X := rigtoring X) (n1 + n2) = setquotpr (binopeqrelabgrdiff (rigaddabmonoid X)) (nattorig (n1 + n2) ,, 0%rig)). { generalize (n1 + n2) ; clear. induction n as [|n IHn]. - reflexivity. - unfold nattoring ; rewrite !nattorigS. rewrite <- (riglunax1 _ 0%rig). eapply pathscomp0. apply maponpaths. exact IHn. reflexivity. } rewrite X0 ; clear X0. apply hinhfun2 ; simpl. intros (c1,Hc1) (c2,Hc2). exists (c1+c2)%rig. eapply Htra. assert (nattorig (n1 + n2) + pr2 x + (c1 + c2) = ((nattorig n1 + c1) + (nattorig n2 + pr2 x + c2)))%rig. { rewrite nattorig_plus, !rigassoc1. apply maponpaths. rewrite rigcomm1, !rigassoc1. rewrite rigcomm1, !rigassoc1. apply maponpaths. rewrite rigcomm1, !rigassoc1. reflexivity. } simpl in X0 |- * ; rewrite X0 ; clear X0. apply (pr2 Hadd). exact Hc1. rewrite rigrunax1, <- rigassoc1. apply (pr1 Hadd). rewrite riglunax1 in Hc2. exact Hc2.*) Defined. Lemma natmult_commringfrac {X : commring} {S : subabmonoid _} : ∏ n (x : X × S), natmult (X := commringfrac X S) n (setquotpr (eqrelcommringfrac X S) x) = setquotpr (eqrelcommringfrac X S) (natmult (X := X) n (pr1 x) ,, (pr2 x)). Proof. simpl ; intros n x. induction n as [|n IHn]. - apply (iscompsetquotpr (eqrelcommringfrac X S)). apply hinhpr ; simpl. exists (pr2 x). rewrite !(ringmult0x X). reflexivity. - rewrite !natmultS, IHn. apply (iscompsetquotpr (eqrelcommringfrac X S)). apply hinhpr ; simpl. exists (pr2 x) ; simpl. rewrite <- (ringldistr X). rewrite (ringcomm2 X (pr1 (pr2 x))). rewrite !(ringassoc2 X). reflexivity. Qed. Lemma isarchcommringfrac {X : commring} {S : subabmonoid _} (R : hrel X) Hop1 Hop2 Hs: R 1%ring 0%ring -> istrans R -> isarchring R -> isarchring (X := commringfrac X S) (commringfracgt X S (R := R) Hop1 Hop2 Hs). Proof. intros H0 Htra Hr. split. - simple refine (setquotunivprop _ (λ _, (_,,_)) _). apply isapropimpl, propproperty. intros x Hx. revert Hx ; apply hinhuniv ; intros (c,Hx) ; simpl in Hx. rewrite !(ringmult0x X), (ringrunax2 X) in Hx. apply (hinhfun (X := ∑ n, commringfracgt X S Hop1 Hop2 Hs (setquotpr (eqrelcommringfrac X S) ((nattoring n * pr1 x)%ring,, pr2 x)) 1%ring)). intros H. eexists (pr1 H). unfold nattoring. rewrite (nattorig_natmult (X := commringfrac X S)). rewrite (natmult_commringfrac (X := X) (S := S)). rewrite <- (nattorig_natmult (X := X)). now apply (pr2 H). generalize (isarchring_1 _ Hr _ Hx) (isarchring_2 _ Hr (pr1 (pr2 x) * pr1 c)%ring). apply hinhfun2. intros (m,Hm) (n,Hn). exists (max 1 n * m)%nat. destruct n ; simpl max. + apply hinhpr ; simpl. exists c. rewrite (ringrunax2 X), (ringlunax2 X), (ringassoc2 X). eapply Htra. exact Hm. eapply Htra. exact H0. exact Hn. + unfold nattoring. rewrite (nattorig_natmult (X := X)), natmult_mult. apply hinhpr ; simpl. exists c. change (R (natmult (succ n) (natmult (X := X) m (pr1 x)) * 1 * pr1 c)%ring (1 * pr1 (pr2 x) * pr1 c)%ring). rewrite <- (nattorig_natmult (X := X)), (ringrunax2 X), (ringlunax2 X), (ringassoc2 X), (nattorig_natmult (X := X)). eapply Htra. apply (natmult_binophrel (X := X) R). exact Htra. exact Hop1. rewrite <- (nattorig_natmult (X := X)), (ringassoc2 X). exact Hm. exact Hn. - simple refine (setquotunivprop _ _ _). intros x. apply (hinhfun (X := ∑ n : nat, commringfracgt X S Hop1 Hop2 Hs (setquotpr (eqrelcommringfrac X S) (nattoring n,, unel S)) (setquotpr (eqrelcommringfrac X S) x))). intros (n,Hn). exists n. unfold nattoring, nattorig. change 1%rig with (setquotpr (eqrelcommringfrac X S) (1%ring,, unel S)). rewrite (natmult_commringfrac (X := X) (S := S) n). exact Hn. generalize (isarchring_1 _ Hr _ (Hs (pr1 (pr2 x)) (pr2 (pr2 x)))) (isarchring_2 _ Hr (pr1 x)%ring). apply hinhfun2. intros (m,Hm) (n,Hn). exists (max 1 n * m)%nat. destruct n ; simpl max. + apply hinhpr ; simpl. exists (pr2 x). apply (isringmultgttoisrringmultgt X). exact Hop1. exact Hop2. apply Hs. apply (pr2 (pr2 x)). eapply Htra. exact Hm. eapply Htra. exact H0. rewrite (ringrunax2 X). exact Hn. + apply hinhpr ; simpl. exists (pr2 x). change (n * m + m)%nat with (succ n * m)%nat. unfold nattoring. apply (isringmultgttoisrringmultgt X). exact Hop1. exact Hop2. apply Hs. apply (pr2 (pr2 x)). rewrite (ringrunax2 X), (nattorig_natmult (X := X)), natmult_mult. eapply Htra. apply (natmult_binophrel (X := X) R). exact Htra. exact Hop1. rewrite <- (nattorig_natmult (X := X)). exact Hm. exact Hn. Qed. (** ** Archimedean property in a field *) Definition isarchfld {X : fld} (R : hrel X) := ∏ x : X, ∃ n : nat, R (nattoring n) x. Lemma isarchfld_isarchring {X : fld} (R : hrel X) : ∏ (Hadd : isbinophrel (X := rigaddabmonoid X) R) ( Hmult : isringmultgt X R) (Hirr : isirrefl R), isarchfld R -> isarchring R. Proof. intros Hadd Hmult Hirr H. split. - intros x Hx. case (fldchoice x) ; intros x'. + generalize (H (pr1 x')). apply hinhfun. intros n. exists (pr1 n). abstract (pattern (1%ring : X) at 1 ; rewrite <- (pr1 (pr2 x')) ; apply (isringmultgttoisrringmultgt _ Hadd Hmult _ _ _ Hx (pr2 n))). + apply hinhpr. exists O. abstract (apply fromempty ; refine (Hirr _ _) ; rewrite x' in Hx ; apply Hx). - exact H. Defined. Lemma isarchring_isarchfld {X : fld} (R : hrel X) : isarchring R -> isarchfld R. Proof. intros H. intros x. apply (isarchring_2 R H x). Defined. Theorem isarchfldfrac ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is0 : @isbinophrel X R ) ( is1 : isringmultgt X R ) ( is2 : R 1%ring 0%ring ) ( nc : neqchoice R ) ( irr : isirrefl R ) ( tra : istrans R ) : isarchring R -> isarchfld (X := fldfrac X is ) (fldfracgt _ is is0 is1 is2 nc). Proof. intros. apply isarchring_isarchfld. unfold fldfracgt. generalize (isarchcommringfrac (X := X) (S := ringpossubmonoid X is1 is2) R is0 is1 (λ (c : X) (r : (ringpossubmonoid X is1 is2) c), r) is2 tra X0). intros. assert (H_f : ∏ n x, (weqfldfracgt_f X is is0 is1 is2 nc (nattoring n * x)%ring) = (nattoring n * weqfldfracgt_f X is is0 is1 is2 nc x)%ring). { clear -irr. intros n x. unfold nattoring. rewrite (nattorig_natmult (X := fldfrac X is)), (nattorig_natmult (X := commringfrac X (@ringpossubmonoid X R is1 is2))). induction n as [|n IHn]. - refine (pr2 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))). exact irr. - rewrite !natmultS, <- IHn. refine (pr1 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _)) _ _). exact irr. } assert (H_0 : (weqfldfracgt_f X is is0 is1 is2 nc 0%ring) = 0%ring). { refine (pr2 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))). exact irr. } assert (H_1 : (weqfldfracgt_f X is is0 is1 is2 nc 1%ring) = 1%ring). { refine (pr2 (pr2 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))). exact irr. } split. - intros x Hx. eapply hinhfun. 2: apply (isarchring_1 _ X1 (weqfldfracgt_f X is is0 is1 is2 nc x)). intros (n,Hn). exists n. rewrite H_f, H_1. exact Hn. rewrite H_0 in Hx. exact Hx. - intros x. eapply hinhfun. 2: apply (isarchring_2 _ X1 (weqfldfracgt_f X is is0 is1 is2 nc x)). intros (n,Hn). exists n. rewrite <- (ringrunax2 _ (nattoring n)), H_f, H_1, ringrunax2. exact Hn. Defined. (** ** Archimedean property in a constructive field *) Definition isarchCF {X : ConstructiveField} (R : hrel X) := ∏ x : X, ∃ n : nat, R (nattoring n) x. Lemma isarchCF_isarchring {X : ConstructiveField} (R : hrel X) : ∏ (Hadd : isbinophrel (X := rigaddabmonoid X) R) ( Hmult : isringmultgt X R) (Hirr : isirrefl R), (∏ x : X, R x 0%CF -> (x ≠ 0)%CF) -> isarchCF R -> isarchring R. Proof. intros Hadd Hmult Hirr H0 H. split. - intros x Hx. generalize (H (CFinv x (H0 _ Hx))). apply hinhfun. intros (n,Hn). exists n. change 1%ring with (1%CF : X). rewrite <- (islinv_CFinv x (H0 x Hx)). apply isringmultgttoisrringmultgt. exact Hadd. exact Hmult. exact Hx. exact Hn. - exact H. Defined. Lemma isarchring_isarchCF {X : ConstructiveField} (R : hrel X) : isarchring R -> isarchCF R. Proof. intros H. intros x. apply (isarchring_2 R H x). Defined.UniMath-20231010/UniMath/Algebra/BinaryOperations.v000066400000000000000000003172411451125700300217000ustar00rootroot00000000000000(** * Algebra 1. Part A. Generalities. Vladimir Voevodsky. Aug. 2011 -. *) (** ** Contents - Sets with one and two binary operations - Unary operations - Binary operations - General definitions - Standard conditions on one binary operation on a set - Elements with inverses - Group operations - Standard conditions on a pair of binary operations on a set - Sets with one binary operation - General definitions - Functions compatible with a binary operation (homomorphism) and their properties - Transport of properties of a binary operation - Subobject - Relations compatible with a binary operation and quotient objects - Relations inversely compatible with a binary operation - Homomorphisms and relations - Quotient relations - Direct products - Sets with two binary operations - General definitions - Functions compatible with a pair of binary operation (homomorphisms) and their properties - Transport of properties of a pair of binary operations - Subobjects - Quotient objects - Direct products - Infinitary operations *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.Sets. Require Export UniMath.MoreFoundations.Propositions. Local Open Scope logic. (** To upstream files *) (** ** Sets with one and two binary operations *) (** *** Unary operations *) Definition unop (X : UU) : UU := X -> X. (** *** Binary operations *) (** **** General definitions *) Definition islcancelable {X : UU} (opp : binop X) (x : X) : UU := isincl (λ x0 : X, opp x x0). Definition lcancel {X : UU} {opp : binop X} {x : X} (H_x : islcancelable opp x) (y z : X) : opp x y = opp x z -> y = z. Proof. apply invmaponpathsincl, H_x. Defined. Definition isrcancelable {X : UU} (opp : binop X) (x : X) : UU := isincl (λ x0 : X, opp x0 x). Definition rcancel {X : UU} {opp : binop X} {x : X} (H_x : isrcancelable opp x) (y z : X) : opp y x = opp z x -> y = z. Proof. apply (invmaponpathsincl (fun y => opp y x)), H_x. Defined. Definition iscancelable {X : UU} (opp : binop X) (x : X) : UU := (islcancelable opp x) × (isrcancelable opp x). Definition islinvertible {X : UU} (opp : binop X) (x : X) : UU := isweq (λ x0 : X, opp x x0). Definition isrinvertible {X : UU} (opp : binop X) (x : X) : UU := isweq (λ x0 : X, opp x0 x). Definition isinvertible {X : UU} (opp : binop X) (x : X) : UU := (islinvertible opp x) × (isrinvertible opp x). (** **** Transfer of binary operations relative to weak equivalences *) Definition binop_weq_fwd {X Y : UU} (H : X ≃ Y) : binop X → binop Y := λ (opp : binop X) (x y : Y), H (opp (invmap H x) (invmap H y)). Definition binop_weq_bck {X Y : UU} (H : X ≃ Y) : binop Y → binop X := λ (opp : binop Y) (x y : X), invmap H (opp (H x) (H y)). (** **** Standard conditions on one binary operation on a set *) (** *) Definition isassoc {X : UU} (opp : binop X) : UU := ∏ x x' x'', paths (opp (opp x x') x'') (opp x (opp x' x'')). Lemma isapropisassoc {X : hSet} (opp : binop X) : isaprop (isassoc opp). Proof. apply impred. intro x. apply impred. intro x'. apply impred. intro x''. simpl. apply (setproperty X). Defined. (** Compare to [CategoryTheory.Categories.assoc4] *) Lemma assoc4 {X : UU} (opp : binop X) (isa : isassoc opp) : ∏ w x y z : X, opp (opp (opp w x) y) z = opp (opp w (opp x y)) z. Proof. intros. repeat rewrite isa; exact (idpath _). Qed. (** cancellativity *) Definition isrcancellative {X : UU} (opp : binop X) : UU := ∏ x:X, isrcancelable opp x. Definition islcancellative {X : UU} (opp : binop X) : UU := ∏ x:X, islcancelable opp x. (** *) Definition islunit {X : UU} (opp : binop X) (un0 : X) : UU := ∏ x : X, (opp un0 x) = x. Lemma isapropislunit {X : hSet} (opp : binop X) (un0 : X) : isaprop (islunit opp un0). Proof. apply impred. intro x. simpl. apply (setproperty X). Defined. Definition isrunit {X : UU} (opp : binop X) (un0 : X) : UU := ∏ x : X, (opp x un0) = x. Lemma isapropisrunit {X : hSet} (opp : binop X) (un0 : X) : isaprop (isrunit opp un0). Proof. apply impred. intro x. simpl. apply (setproperty X). Defined. Definition isunit {X : UU} (opp : binop X) (un0 : X) : UU := (islunit opp un0) × (isrunit opp un0). Definition make_isunit {X : UU} {opp : binop X} {un0 : X} (H1 : islunit opp un0) (H2 : isrunit opp un0) : isunit opp un0 := make_dirprod H1 H2. Definition isunital {X : UU} (opp : binop X) : UU := total2 (λ un0 : X, isunit opp un0). Definition make_isunital {X : UU} {opp : binop X} (un0 : X) (is : isunit opp un0) : isunital opp := tpair _ un0 is. Lemma isapropisunital {X : hSet} (opp : binop X) : isaprop (isunital opp). Proof. apply (@isapropsubtype X (λ un0 : _, hconj (make_hProp _ (isapropislunit opp un0)) (make_hProp _ (isapropisrunit opp un0)))). intros u1 u2. intros ua1 ua2. apply (pathscomp0 (pathsinv0 (pr2 ua2 u1)) (pr1 ua1 u2)). Defined. (** *) Definition ismonoidop {X : UU} (opp : binop X) : UU := (isassoc opp) × (isunital opp). Definition make_ismonoidop {X : UU} {opp : binop X} (H1 : isassoc opp) (H2 : isunital opp) : ismonoidop opp := make_dirprod H1 H2. Definition assocax_is {X : UU} {opp : binop X} : ismonoidop opp -> isassoc opp := @pr1 _ _. Definition unel_is {X : UU} {opp : binop X} (is : ismonoidop opp) : X := pr1 (pr2 is). Definition lunax_is {X : UU} {opp : binop X} (is : ismonoidop opp) : islunit opp (pr1 (pr2 is)) := pr1 (pr2 (pr2 is)). Definition runax_is {X : UU} {opp : binop X} (is : ismonoidop opp) : isrunit opp (pr1 (pr2 is)) := pr2 (pr2 (pr2 is)). Definition unax_is {X : UU} {opp : binop X} (is : ismonoidop opp) : isunit opp (pr1 (pr2 is)) := make_dirprod (lunax_is is) (runax_is is). Lemma isapropismonoidop {X : hSet} (opp : binop X) : isaprop (ismonoidop opp). Proof. apply (isofhleveldirprod 1). apply isapropisassoc. apply isapropisunital. Defined. (** ***** Elements with inverses *) Section ElementsWithInverses. Context {X : UU} (opp : binop X) (is : ismonoidop opp). Local Notation "x * y" := (opp x y). Local Notation u := (unel_is is). (** Is this element x0 the left/right inverse of x? *) Definition islinvel (x : X) : X -> UU := fun x0 => paths (x0 * x) u. Definition isrinvel (x : X) : X -> UU := fun x0 => paths (x * x0) u. Definition isinvel (x : X) : X -> UU := fun x0 => (islinvel x x0) × (isrinvel x x0). (** Is there some element x0 that is the left/right inverse of x? *) Definition haslinv (x : X) : UU := ∑ x0 : X, islinvel x x0. Definition hasrinv (x : X) : UU := ∑ x0 : X, isrinvel x x0. Definition hasinv (x : X) : UU := ∑ x0 : X, isinvel x x0. (** Accessor functions *) Definition haslinv_to_linvel {x : X} : haslinv x → X := pr1. Definition hasrinv_to_rinvel {x : X} : hasrinv x → X := pr1. Definition hasinv_to_invel {x : X} : hasinv x → X := pr1. Definition merely_haslinv (x : X) : hProp := ∥ haslinv x ∥. Definition merely_hasrinv (x : X) : hProp := ∥ hasrinv x ∥. Definition merely_hasinv (x : X) : hProp := ∥ hasinv x ∥. (** Lemmas for elements with inverses *) (** The inverse of an element's two-sided inverse is just that element *) Definition is_inv_inv : ∏ (x x0 : X), (isinvel x x0 -> isinvel x0 x) := fun x x0 isinv => (make_dirprod (pr2 isinv) (pr1 isinv)). (** If two elements have left inverses, so does their product. *) Lemma invop_l : ∏ (x y x' y' : X), (islinvel x x' -> islinvel y y' -> islinvel (x * y) (y' * x')). Proof. intros x y x' y' xinv yinv. unfold islinvel. pose (assoc := pr1 is). cbn; unfold islinvel. rewrite <- assoc. rewrite (assoc4 opp assoc), xinv. rewrite (runax_is is). exact yinv. Qed. (** If two elements have right inverses, so does their product. *) Lemma invop_r : ∏ (x y x' y' : X), (isrinvel x x' -> isrinvel y y' -> isrinvel (x * y) (y' * x')). Proof. intros x y x' y' xinv yinv. pose (assoc := pr1 is). cbn; unfold isrinvel. rewrite <- assoc. rewrite (assoc4 opp assoc), yinv. rewrite (runax_is is). exact xinv. Qed. (** This is a similar statement to [grinvop] *) Lemma invop : ∏ (x y x' y' : X), (isinvel x x' -> isinvel y y' -> isinvel (x * y) (y' * x')). Proof. intros x y x' y' xinv yinv. use make_dirprod. - apply invop_l. + exact (dirprod_pr1 xinv). + exact (dirprod_pr1 yinv). - apply invop_r. + exact (dirprod_pr2 xinv). + exact (dirprod_pr2 yinv). Defined. Lemma mere_invop : ∏ (x y : X), (merely_hasinv x -> merely_hasinv y -> merely_hasinv (x * y)). Proof. intros x y. apply hinhfun2. intros xinv yinv. exists ((hasinv_to_invel yinv) * (hasinv_to_invel xinv)). apply invop. - exact (pr2 xinv). - exact (pr2 yinv). Defined. (** If an element has both left and right inverses, they're equal. *) Lemma linv_eq_rinv (x lx rx : X) (lxlinv : islinvel x lx) (rxrinv : isrinvel x rx) : lx = rx. Proof. intros. refine (!runax_is is _ @ _). refine (!maponpaths (λ z, lx * z) rxrinv @ _). refine (!assocax_is is _ _ _ @ _). refine (maponpaths (λ z, z * rx) lxlinv @ _). apply lunax_is. Defined. End ElementsWithInverses. Section InverseOperations. Context {X : UU} (opp : binop X) (u : X) (inv : X -> X). Local Notation "x * y" := (opp x y). Definition islinv : UU := ∏ x : X, ((inv x) * x) = u. Definition isrinv : UU := ∏ x : X, (x * (inv x)) = u. Definition isinv : UU := islinv × isrinv. End InverseOperations. Section ElementsWithInversesSet. (** When working with an hSet instead of a general type, many of the above statements become propositions *) Context {X : hSet} (opp : binop X) (is : ismonoidop opp). Local Notation "x * y" := (opp x y). Definition isapropislinvel (x x0 : X) : isaprop (islinvel opp is x x0) := setproperty X _ _. Definition isapropisrinvel (x x0 : X) : isaprop (isrinvel opp is x x0) := setproperty X _ _. Definition isapropisinvel (x x0 : X) : isaprop (isinvel opp is x x0) := isapropdirprod _ _ (isapropislinvel _ _) (isapropisrinvel _ _). (** If the operation is left cancellable, right inverses are unique. *) Definition isaprop_haslinv (x : X) (can : islcancelable opp x) : isaprop (hasrinv opp is x). Proof. apply isaproptotal2. - intro; apply isapropislinvel. - intros x' x'' islinvx' islinvx''. apply (Injectivity (λ x0 : X, x * x0)). + apply incl_injectivity; assumption. + exact (islinvx' @ !islinvx''). Defined. (** If the operation is right cancellable, left inverses are unique. *) Definition isaprop_hasrinv (x : X) (can : isrcancelable opp x) : isaprop (haslinv opp is x). Proof. apply isaproptotal2. - intro; apply isapropisrinvel. - intros x' x'' isrinvx' isrinvx''. apply (Injectivity (λ x0 : X, x0 * x)). + apply incl_injectivity; assumption. + exact (isrinvx' @ !isrinvx''). Defined. (** For the two-sided case, we can just reuse the argument from the left-cancellable case. *) Definition isaprop_hasinv (x : X) (can : iscancelable opp x) : isaprop (hasinv opp is x). Proof. apply isaproptotal2. - intro; apply isapropdirprod. + apply isapropislinvel. + apply isapropisrinvel. - intros x' x'' isinvx' isinvx''. apply (Injectivity (λ x0 : X, x * x0)). + apply incl_injectivity; apply (pr1 can). + exact (pr2 isinvx' @ !pr2 isinvx''). Defined. (** The subset of elements that have inverses *) Definition merely_invertible_elements : hsubtype X := merely_hasinv opp is. Definition invertible_elements (can : ∏ x, iscancelable opp x) : hsubtype X. Proof. intro x. use make_hProp. - exact (hasinv opp is x). - apply isaprop_hasinv, can. Defined. (** If an element has an inverse, then it is cancellable *) Definition lcanfromlinv (a b c : X) (c' : haslinv opp is c) : (c * a) = (c * b) → a = b. Proof. intros e. refine (!lunax_is is a @ _ @ lunax_is is b). refine (!maponpaths (λ z, z * _) (pr2 c') @ _ @ maponpaths (λ z, z * _) (pr2 c')). refine (assocax_is is _ _ _ @ _ @ !assocax_is is _ _ _). apply maponpaths. assumption. Defined. Definition rcanfromrinv (a b c : X) (c' : hasrinv opp is c) : (a * c) = (b * c) → a = b. Proof. intros e. refine (!runax_is is a @ _ @ runax_is is b). refine (!maponpaths (λ z, _ * z) (pr2 c') @ _ @ maponpaths (λ z, _ * z) (pr2 c')). refine (!assocax_is is _ _ _ @ _ @ assocax_is is _ _ _). apply (maponpaths (λ z, z * _)). assumption. Defined. End ElementsWithInversesSet. Section InversesSet. (** Similarly, these are propositions for hSets *) Context {X : hSet} (opp : binop X) (u : X) (inv : X -> X). Lemma isapropislinv : isaprop (islinv opp u inv). Proof. intros; apply impred; intro; apply setproperty. Defined. Lemma isapropisrinv : isaprop (isrinv opp u inv). Proof. intros; apply impred; intro; apply setproperty. Defined. Lemma isapropisinv : isaprop (isinv opp u inv). Proof. exact (isofhleveldirprod 1 _ _ isapropislinv isapropisrinv). Defined. End InversesSet. Definition make_isinv {X : UU} {opp : binop X} {un0 : X} {inv0 : X -> X} (H1 : islinv opp un0 inv0) (H2 : isrinv opp un0 inv0) : isinv opp un0 inv0 := make_dirprod H1 H2. Definition invstruct {X : UU} (opp : binop X) (is : ismonoidop opp) : UU := total2 (fun inv0 : X -> X => isinv opp (unel_is is) inv0). Definition make_invstruct {X : UU} {opp : binop X} {is : ismonoidop opp} (inv0 : X -> X) (H : isinv opp (unel_is is) inv0) : invstruct opp is := tpair _ inv0 H. (** ***** Group operations *) Definition isgrop {X : UU} (opp : binop X) : UU := total2 (λ is : ismonoidop opp, invstruct opp is). Definition make_isgrop {X : UU} {opp : binop X} (is1 : ismonoidop opp) (is2 : invstruct opp is1) : isgrop opp := tpair (λ is : ismonoidop opp, invstruct opp is) is1 is2. Definition pr1isgrop (X : UU) (opp : binop X) : isgrop opp -> ismonoidop opp := @pr1 _ _. Coercion pr1isgrop : isgrop >-> ismonoidop. Definition grinv_is {X : UU} {opp : binop X} (is : isgrop opp) : X -> X := pr1 (pr2 is). Definition grlinvax_is {X : UU} {opp : binop X} (is : isgrop opp) : islinv opp (unel_is is) (pr1 (pr2 is)) := pr1 (pr2 (pr2 is)). Definition grrinvax_is {X : UU} {opp : binop X} (is : isgrop opp) : isrinv opp (unel_is is) (pr1 (pr2 is)) := pr2 (pr2 (pr2 is)). Lemma isweqrmultingr_is {X : UU} {opp : binop X} (is : isgrop opp) (x0 : X) : isrinvertible opp x0. Proof. destruct is as [ is istr ]. set (f := λ x : X, opp x x0). set (g := λ x : X, opp x ((pr1 istr) x0)). destruct is as [ assoc isun0 ]. destruct istr as [ inv0 axs ]. destruct isun0 as [ un0 unaxs ]. simpl in * |-. assert (egf : ∏ x : _, paths (g (f x)) x). { intro x. unfold f. unfold g. destruct (pathsinv0 (assoc x x0 (inv0 x0))). set (e := pr2 axs x0). simpl in e. rewrite e. apply (pr2 unaxs x). } assert (efg : ∏ x : _, paths (f (g x)) x). { intro x. unfold f. unfold g. destruct (pathsinv0 (assoc x (inv0 x0) x0)). set (e := pr1 axs x0). simpl in e. rewrite e. apply (pr2 unaxs x). } apply (isweq_iso _ _ egf efg). Defined. Lemma isweqlmultingr_is {X : UU} {opp : binop X} (is : isgrop opp) (x0 : X) : islinvertible opp x0. Proof. destruct is as [ is istr ]. set (f := λ x : X, opp x0 x). set (g := λ x : X, opp ((pr1 istr) x0) x). destruct is as [ assoc isun0 ]. destruct istr as [ inv0 axs ]. destruct isun0 as [ un0 unaxs ]. simpl in * |-. assert (egf : ∏ x : _, paths (g (f x)) x). { intro x. unfold f. unfold g. destruct (assoc (inv0 x0) x0 x). set (e := pr1 axs x0). simpl in e. rewrite e. apply (pr1 unaxs x). } assert (efg : ∏ x : _, paths (f (g x)) x). { intro x. unfold f. unfold g. destruct (assoc x0 (inv0 x0) x). set (e := pr2 axs x0). simpl in e. rewrite e. apply (pr1 unaxs x). } apply (isweq_iso _ _ egf efg). Defined. Lemma isapropinvstruct {X : hSet} {opp : binop X} (is : ismonoidop opp) : isaprop (invstruct opp is). Proof. apply isofhlevelsn. intro is0. set (un0 := pr1 (pr2 is)). assert (int : ∏ (i : X -> X), isaprop (dirprod (∏ x : X, paths (opp (i x) x) un0) (∏ x : X, paths (opp x (i x)) un0))). { intro i. apply (isofhleveldirprod 1). - apply impred. intro x. simpl. apply (setproperty X). - apply impred. intro x. simpl. apply (setproperty X). } apply (isapropsubtype (λ i : _, make_hProp _ (int i))). intros inv1 inv2. simpl. intro ax1. intro ax2. apply funextfun. intro x0. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is (tpair _ is is0) x0))). simpl. rewrite (pr1 ax1 x0). rewrite (pr1 ax2 x0). apply idpath. Defined. Lemma isapropisgrop {X : hSet} (opp : binop X) : isaprop (isgrop opp). Proof. apply (isofhleveltotal2 1). - apply isapropismonoidop. - apply isapropinvstruct. Defined. (* (** Unitary monoid where all elements are invertible is a group *) Definition allinvvertibleinv {X : hSet} {opp : binop X} (is : ismonoidop opp) (allinv : ∏ x : X, islinvertible opp x) : X -> X := λ x : X, invmap (make_weq _ (allinv x)) (unel_is is). *) (** The following lemma is an analog of [Bourbaki, Alg. 1, ex. 2, p. 132] *) Lemma isgropif {X : hSet} {opp : binop X} (is0 : ismonoidop opp) (is : ∏ x : X, merely_hasrinv opp is0 x) : isgrop opp. Proof. split with is0. destruct is0 as [ assoc isun0 ]. destruct isun0 as [ un0 unaxs0 ]. simpl in is. simpl in unaxs0. simpl in un0. simpl in assoc. simpl in unaxs0. assert (l1 : ∏ x' : X, isincl (λ x0 : X, opp x0 x')). { intro x'. apply (@hinhuniv (total2 (λ x0 : X, (opp x' x0) = un0)) (make_hProp _ (isapropisincl (λ x0 : X, opp x0 x')))). - intro int1. simpl. apply isinclbetweensets. + apply (pr2 X). + apply (pr2 X). + intros a b. intro e. rewrite (pathsinv0 (pr2 unaxs0 a)). rewrite (pathsinv0 (pr2 unaxs0 b)). destruct int1 as [ invx' eq ]. rewrite (pathsinv0 eq). destruct (assoc a x' invx'). destruct (assoc b x' invx'). rewrite e. apply idpath. - apply (is x'). } assert (is' : ∏ x : X, hexists (λ x0 : X, (opp x0 x) = un0)). { intro x. apply (λ f : _ , hinhuniv f (is x)). intro s1. destruct s1 as [ x' eq ]. apply hinhpr. split with x'. simpl. apply (invmaponpathsincl _ (l1 x')). rewrite (assoc x' x x'). rewrite eq. rewrite (pr1 unaxs0 x'). unfold unel_is. simpl. rewrite (pr2 unaxs0 x'). apply idpath. } assert (l1' : ∏ x' : X, isincl (λ x0 : X, opp x' x0)). { intro x'. apply (@hinhuniv (total2 (λ x0 : X, (opp x0 x') = un0)) (make_hProp _ (isapropisincl (λ x0 : X, opp x' x0)))). - intro int1. simpl. apply isinclbetweensets. + apply (pr2 X). + apply (pr2 X). + intros a b. intro e. rewrite (pathsinv0 (pr1 unaxs0 a)). rewrite (pathsinv0 (pr1 unaxs0 b)). destruct int1 as [ invx' eq ]. rewrite (pathsinv0 eq). destruct (pathsinv0 (assoc invx' x' a)). destruct (pathsinv0 (assoc invx' x' b)). rewrite e. apply idpath. - apply (is' x'). } assert (int : ∏ x : X, isaprop (total2 (λ x0 : X, (opp x0 x) = un0))). { intro x. apply isapropsubtype. intros x1 x2. intros eq1 eq2. apply (invmaponpathsincl _ (l1 x)). rewrite eq1. rewrite eq2. apply idpath. } simpl. set (linv0 := λ x : X, hinhunivcor1 (make_hProp _ (int x)) (is' x)). simpl in linv0. set (inv0 := λ x : X, pr1 (linv0 x)). split with inv0. simpl. split with (λ x : _, pr2 (linv0 x)). intro x. apply (invmaponpathsincl _ (l1 x)). rewrite (assoc x (inv0 x) x). change (inv0 x) with (pr1 (linv0 x)). rewrite (pr2 (linv0 x)). unfold unel_is. simpl. rewrite (pr1 unaxs0 x). rewrite (pr2 unaxs0 x). apply idpath. Defined. (** *) Definition iscomm {X : UU} (opp : binop X) : UU := ∏ x x' : X, paths (opp x x') (opp x' x). Lemma isapropiscomm {X : hSet} (opp : binop X) : isaprop (iscomm opp). Proof. apply impred. intros x. apply impred. intro x'. simpl. apply (setproperty X). Defined. Definition isabmonoidop {X : UU} (opp : binop X) : UU := (ismonoidop opp) × (iscomm opp). Definition make_isabmonoidop {X : UU} {opp : binop X} (H1 : ismonoidop opp) (H2 : iscomm opp) : isabmonoidop opp := make_dirprod H1 H2. Definition pr1isabmonoidop (X : UU) (opp : binop X) : isabmonoidop opp -> ismonoidop opp := @pr1 _ _. Coercion pr1isabmonoidop : isabmonoidop >-> ismonoidop. Definition commax_is {X : UU} {opp : binop X} (is : isabmonoidop opp) : iscomm opp := pr2 is. Lemma isapropisabmonoidop {X : hSet} (opp : binop X) : isaprop (isabmonoidop opp). Proof. apply (isofhleveldirprod 1). apply isapropismonoidop. apply isapropiscomm. Defined. Lemma abmonoidoprer {X : UU} {opp : binop X} (is : isabmonoidop opp) (a b c d : X) : paths (opp (opp a b) (opp c d)) (opp (opp a c) (opp b d)). Proof. destruct is as [ is comm ]. destruct is as [ assoc unital0 ]. simpl in *. destruct (assoc (opp a b) c d). destruct (assoc (opp a c) b d). destruct (pathsinv0 (assoc a b c)). destruct (pathsinv0 (assoc a c b)). destruct (comm b c). apply idpath. Defined. (** *) Lemma weqlcancelablercancelable {X : UU} (opp : binop X) (is : iscomm opp) (x : X) : (islcancelable opp x) ≃ (isrcancelable opp x). Proof. assert (f : (islcancelable opp x) -> (isrcancelable opp x)). { unfold islcancelable. unfold isrcancelable. intro isl. apply (λ h : _, isinclhomot _ _ h isl). intro x0. apply is. } assert (g : (isrcancelable opp x) -> (islcancelable opp x)). { unfold islcancelable. unfold isrcancelable. intro isr. apply (λ h : _, isinclhomot _ _ h isr). intro x0. apply is. } split with f. apply (isweqimplimpl f g (isapropisincl (λ x0 : X, opp x x0)) (isapropisincl (λ x0 : X, opp x0 x))). Defined. Lemma weqlinvertiblerinvertible {X : UU} (opp : binop X) (is : iscomm opp) (x : X) : (islinvertible opp x) ≃ (isrinvertible opp x). Proof. assert (f : (islinvertible opp x) -> (isrinvertible opp x)). { unfold islinvertible. unfold isrinvertible. intro isl. apply (isweqhomot (λ y, opp x y)). - intro z. apply is. - apply isl. } assert (g : (isrinvertible opp x) -> (islinvertible opp x)). { unfold islinvertible. unfold isrinvertible. intro isr. apply (λ h : _, isweqhomot _ _ h isr). intro x0. apply is. } split with f. apply (isweqimplimpl f g (isapropisweq (λ x0 : X, opp x x0)) (isapropisweq (λ x0 : X, opp x0 x))). Defined. (* Lemma below currently requires X:hSet but should have a proof for X:UU *) Lemma weqlunitrunit {X : hSet} (opp : binop X) (is : iscomm opp) (un0 : X) : (islunit opp un0) ≃ (isrunit opp un0). Proof. assert (f : (islunit opp un0) -> (isrunit opp un0)). { unfold islunit. unfold isrunit. intro isl. intro x. destruct (is un0 x). apply (isl x). } assert (g : (isrunit opp un0) -> (islunit opp un0)). { unfold islunit. unfold isrunit. intro isr. intro x. destruct (is x un0). apply (isr x). } split with f. apply (isweqimplimpl f g (isapropislunit opp un0) (isapropisrunit opp un0)). Defined. (* Same for the following lemma *) Lemma weqlinvrinv {X : hSet} (opp : binop X) (is : iscomm opp) (un0 : X) (inv0 : X -> X) : (islinv opp un0 inv0) ≃ (isrinv opp un0 inv0). Proof. assert (f : (islinv opp un0 inv0) -> (isrinv opp un0 inv0)). { unfold islinv. unfold isrinv. intro isl. intro x. destruct (is (inv0 x) x). apply (isl x). } assert (g : (isrinv opp un0 inv0) -> (islinv opp un0 inv0)). { unfold islinv. unfold isrinv. intro isr. intro x. destruct (is x (inv0 x)). apply (isr x). } split with f. apply (isweqimplimpl f g (isapropislinv opp un0 inv0) (isapropisrinv opp un0 inv0)). Defined. Opaque abmonoidoprer. (** *) Definition isabgrop {X : UU} (opp : binop X) : UU := (isgrop opp) × (iscomm opp). Definition make_isabgrop {X : UU} {opp : binop X} (H1 : isgrop opp) (H2 : iscomm opp) : isabgrop opp := make_dirprod H1 H2. Definition pr1isabgrop (X : UU) (opp : binop X) : isabgrop opp -> isgrop opp := @pr1 _ _. Coercion pr1isabgrop : isabgrop >-> isgrop. Definition isabgroptoisabmonoidop (X : UU) (opp : binop X) : isabgrop opp -> isabmonoidop opp := λ is : _, make_dirprod (pr1 (pr1 is)) (pr2 is). Coercion isabgroptoisabmonoidop : isabgrop >-> isabmonoidop. Lemma isapropisabgrop {X : hSet} (opp : binop X) : isaprop (isabgrop opp). Proof. apply (isofhleveldirprod 1). apply isapropisgrop. apply isapropiscomm. Defined. (** **** Standard conditions on a pair of binary operations on a set *) (** *) Definition isldistr {X : UU} (opp1 opp2 : binop X) : UU := ∏ x x' x'' : X, paths (opp2 x'' (opp1 x x')) (opp1 (opp2 x'' x) (opp2 x'' x')). Lemma isapropisldistr {X : hSet} (opp1 opp2 : binop X) : isaprop (isldistr opp1 opp2). Proof. apply impred. intro x. apply impred. intro x'. apply impred. intro x''. simpl. apply (setproperty X). Defined. Definition isrdistr {X : UU} (opp1 opp2 : binop X) : UU := ∏ x x' x'' : X, paths (opp2 (opp1 x x') x'') (opp1 (opp2 x x'') (opp2 x' x'')). Lemma isapropisrdistr {X : hSet} (opp1 opp2 : binop X) : isaprop (isrdistr opp1 opp2). Proof. apply impred. intro x. apply impred. intro x'. apply impred. intro x''. simpl. apply (setproperty X). Defined. Definition isdistr {X : UU} (opp1 opp2 : binop X) : UU := (isldistr opp1 opp2) × (isrdistr opp1 opp2). Lemma isapropisdistr {X : hSet} (opp1 opp2 : binop X) : isaprop (isdistr opp1 opp2). Proof. apply (isofhleveldirprod 1 _ _ (isapropisldistr _ _) (isapropisrdistr _ _)). Defined. (** *) Lemma weqldistrrdistr {X : hSet} (opp1 opp2 : binop X) (is : iscomm opp2) : (isldistr opp1 opp2) ≃ (isrdistr opp1 opp2). Proof. assert (f : (isldistr opp1 opp2) -> (isrdistr opp1 opp2)). { unfold isldistr. unfold isrdistr. intro isl. intros x x' x''. destruct (is x'' (opp1 x x')). destruct (is x'' x). destruct (is x'' x'). apply (isl x x' x''). } assert (g : (isrdistr opp1 opp2) -> (isldistr opp1 opp2)). { unfold isldistr. unfold isrdistr. intro isr. intros x x' x''. destruct (is (opp1 x x') x''). destruct (is x x''). destruct (is x' x''). apply (isr x x' x''). } split with f. apply (isweqimplimpl f g (isapropisldistr opp1 opp2) (isapropisrdistr opp1 opp2)). Defined. (** *) Definition isabsorb {X : UU} (opp1 opp2 : binop X) : UU := ∏ x y : X, opp1 x (opp2 x y) = x. Lemma isapropisabsorb {X : hSet} (opp1 opp2 : binop X) : isaprop (isabsorb opp1 opp2). Proof. apply impred_isaprop ; intros x. apply impred_isaprop ; intros y. apply (setproperty X). Defined. (** *) Definition isrigops {X : UU} (opp1 opp2 : binop X) : UU := (∑ axs : (isabmonoidop opp1) × (ismonoidop opp2), (∏ x : X, (opp2 (unel_is (pr1 axs)) x) = (unel_is (pr1 axs))) × (∏ x : X, (opp2 x (unel_is (pr1 axs))) = (unel_is (pr1 axs)))) × (isdistr opp1 opp2). Definition make_isrigops {X : UU} {opp1 opp2 : binop X} (H1 : isabmonoidop opp1) (H2 : ismonoidop opp2) (H3 : ∏ x : X, (opp2 (unel_is H1) x) = (unel_is H1)) (H4 : ∏ x : X, (opp2 x (unel_is H1)) = (unel_is H1)) (H5 : isdistr opp1 opp2) : isrigops opp1 opp2 := tpair _ (tpair _ (make_dirprod H1 H2) (make_dirprod H3 H4)) H5. Definition rigop1axs_is {X : UU} {opp1 opp2 : binop X} : isrigops opp1 opp2 -> isabmonoidop opp1 := λ is : _, pr1 (pr1 (pr1 is)). Definition rigop2axs_is {X : UU} {opp1 opp2 : binop X} : isrigops opp1 opp2 -> ismonoidop opp2 := λ is : _, pr2 (pr1 (pr1 is)). Definition rigdistraxs_is {X : UU} {opp1 opp2 : binop X} : isrigops opp1 opp2 -> isdistr opp1 opp2 := λ is : _, pr2 is. Definition rigldistrax_is {X : UU} {opp1 opp2 : binop X} : isrigops opp1 opp2 -> isldistr opp1 opp2 := λ is : _, pr1 (pr2 is). Definition rigrdistrax_is {X : UU} {opp1 opp2 : binop X} : isrigops opp1 opp2 -> isrdistr opp1 opp2 := λ is : _, pr2 (pr2 is). Definition rigunel1_is {X : UU} {opp1 opp2 : binop X} (is : isrigops opp1 opp2) : X := pr1 (pr2 (pr1 (rigop1axs_is is))). Definition rigunel2_is {X : UU} {opp1 opp2 : binop X} (is : isrigops opp1 opp2) : X := (pr1 (pr2 (rigop2axs_is is))). Definition rigmult0x_is {X : UU} {opp1 opp2 : binop X} (is : isrigops opp1 opp2) (x : X) : paths (opp2 (rigunel1_is is) x) (rigunel1_is is) := pr1 (pr2 (pr1 is)) x. Definition rigmultx0_is {X : UU} {opp1 opp2 : binop X} (is : isrigops opp1 opp2) (x : X) : paths (opp2 x (rigunel1_is is)) (rigunel1_is is) := pr2 (pr2 (pr1 is)) x. Lemma isapropisrigops {X : hSet} (opp1 opp2 : binop X) : isaprop (isrigops opp1 opp2). Proof. apply (isofhleveldirprod 1). - apply (isofhleveltotal2 1). + apply (isofhleveldirprod 1). * apply isapropisabmonoidop. * apply isapropismonoidop. + intro x. apply (isofhleveldirprod 1). * apply impred. intro x'. apply (setproperty X). * apply impred. intro x'. apply (setproperty X). - apply isapropisdistr. Defined. (** *) Definition isringops {X : UU} (opp1 opp2 : binop X) : UU := dirprod ((isabgrop opp1) × (ismonoidop opp2)) (isdistr opp1 opp2). Definition make_isringops {X : UU} {opp1 opp2 : binop X} (H1 : isabgrop opp1) (H2 : ismonoidop opp2) (H3 : isdistr opp1 opp2) : isringops opp1 opp2 := make_dirprod (make_dirprod H1 H2) H3. Definition ringop1axs_is {X : UU} {opp1 opp2 : binop X} : isringops opp1 opp2 -> isabgrop opp1 := λ is : _, pr1 (pr1 is). Definition ringop2axs_is {X : UU} {opp1 opp2 : binop X} : isringops opp1 opp2 -> ismonoidop opp2 := λ is : _, pr2 (pr1 is). Definition ringdistraxs_is {X : UU} {opp1 opp2 : binop X} : isringops opp1 opp2 -> isdistr opp1 opp2 := λ is : _, pr2 is. Definition ringldistrax_is {X : UU} {opp1 opp2 : binop X} : isringops opp1 opp2 -> isldistr opp1 opp2 := λ is : _, pr1 (pr2 is). Definition ringrdistrax_is {X : UU} {opp1 opp2 : binop X} : isringops opp1 opp2 -> isrdistr opp1 opp2 := λ is : _, pr2 (pr2 is). Definition ringunel1_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : X := unel_is (pr1 (pr1 is)). Definition ringunel2_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : X := unel_is (pr2 (pr1 is)). Lemma isapropisringops {X : hSet} (opp1 opp2 : binop X) : isaprop (isringops opp1 opp2). Proof. apply (isofhleveldirprod 1). - apply (isofhleveldirprod 1). + apply isapropisabgrop. + apply isapropismonoidop. - apply isapropisdistr. Defined. Lemma multx0_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) (x : X) : paths (opp2 x (unel_is (pr1 is1))) (unel_is (pr1 is1)). Proof. destruct is12 as [ ldistr0 rdistr0 ]. destruct is2 as [ assoc2 [ un2 [ lun2 run2 ] ] ]. simpl in *. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is is1 (opp2 x un2)))). simpl. destruct is1 as [ [ assoc1 [ un1 [ lun1 run1 ] ] ] [ inv0 [ linv0 rinv0 ] ] ]. unfold unel_is. simpl in *. rewrite (lun1 (opp2 x un2)). destruct (ldistr0 un1 un2 x). rewrite (run2 x). rewrite (lun1 un2). rewrite (run2 x). apply idpath. Defined. Opaque multx0_is_l. Lemma mult0x_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) (x : X) : paths (opp2 (unel_is (pr1 is1)) x) (unel_is (pr1 is1)). Proof. destruct is12 as [ ldistr0 rdistr0 ]. destruct is2 as [ assoc2 [ un2 [ lun2 run2 ] ] ]. simpl in *. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is is1 (opp2 un2 x)))). simpl. destruct is1 as [ [ assoc1 [ un1 [ lun1 run1 ] ] ] [ inv0 [ linv0 rinv0 ] ] ]. unfold unel_is. simpl in *. rewrite (lun1 (opp2 un2 x)). destruct (rdistr0 un1 un2 x). rewrite (lun2 x). rewrite (lun1 un2). rewrite (lun2 x). apply idpath. Defined. Opaque mult0x_is_l. Definition minus1_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) := (grinv_is is1) (unel_is is2). Lemma islinvmultwithminus1_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) (x : X) : paths (opp1 (opp2 (minus1_is_l is1 is2) x) x) (unel_is (pr1 is1)). Proof. set (xinv := opp2 (minus1_is_l is1 is2) x). rewrite (pathsinv0 (lunax_is is2 x)). unfold xinv. rewrite (pathsinv0 (pr2 is12 _ _ x)). unfold minus1_is_l. unfold grinv_is. rewrite (grlinvax_is is1 _). apply mult0x_is_l. - apply is2. - apply is12. Defined. Opaque islinvmultwithminus1_is_l. Lemma isrinvmultwithminus1_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) (x : X) : paths (opp1 x (opp2 (minus1_is_l is1 is2) x)) (unel_is (pr1 is1)). Proof. set (xinv := opp2 (minus1_is_l is1 is2) x). rewrite (pathsinv0 (lunax_is is2 x)). unfold xinv. rewrite (pathsinv0 (pr2 is12 _ _ x)). unfold minus1_is_l. unfold grinv_is. rewrite (grrinvax_is is1 _). apply mult0x_is_l. apply is2. apply is12. Defined. Opaque isrinvmultwithminus1_is_l. Lemma isminusmultwithminus1_is_l {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) (x : X) : paths (opp2 (minus1_is_l is1 is2) x) (grinv_is is1 x). Proof. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is is1 x))). simpl. rewrite (islinvmultwithminus1_is_l is1 is2 is12 x). unfold grinv_is. rewrite (grlinvax_is is1 x). apply idpath. Defined. Opaque isminusmultwithminus1_is_l. Lemma isringopsif {X : UU} {opp1 opp2 : binop X} (is1 : isgrop opp1) (is2 : ismonoidop opp2) (is12 : isdistr opp1 opp2) : isringops opp1 opp2. Proof. set (assoc1 := pr1 (pr1 is1)). split. - split. + split with is1. intros x y. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is is1 (opp2 (minus1_is_l is1 is2) (opp1 x y))))). simpl. rewrite (isrinvmultwithminus1_is_l is1 is2 is12 (opp1 x y)). rewrite (pr1 is12 x y _). destruct (assoc1 (opp1 y x) (opp2 (minus1_is_l is1 is2) x) (opp2 (minus1_is_l is1 is2) y)). rewrite (assoc1 y x _). destruct (pathsinv0 (isrinvmultwithminus1_is_l is1 is2 is12 x)). unfold unel_is. rewrite (runax_is (pr1 is1) y). rewrite (isrinvmultwithminus1_is_l is1 is2 is12 y). apply idpath. + apply is2. - apply is12. Defined. Definition ringmultx0_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : ∏ (x : X), opp2 x (unel_is (pr1 (ringop1axs_is is))) = unel_is (pr1 (ringop1axs_is is)) := multx0_is_l (ringop1axs_is is) (ringop2axs_is is) (ringdistraxs_is is). Definition ringmult0x_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : ∏ (x : X), opp2 (unel_is (pr1 (ringop1axs_is is))) x = unel_is (pr1 (ringop1axs_is is)) := mult0x_is_l (ringop1axs_is is) (ringop2axs_is is) (ringdistraxs_is is). Definition ringminus1_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : X := minus1_is_l (ringop1axs_is is) (ringop2axs_is is). Definition ringmultwithminus1_is {X : UU} {opp1 opp2 : binop X} (is : isringops opp1 opp2) : ∏ (x : X), opp2 (minus1_is_l (ringop1axs_is is) (ringop2axs_is is)) x = grinv_is (ringop1axs_is is) x := isminusmultwithminus1_is_l (ringop1axs_is is) (ringop2axs_is is) (ringdistraxs_is is). Definition isringopstoisrigops (X : UU) (opp1 opp2 : binop X) (is : isringops opp1 opp2) : isrigops opp1 opp2. Proof. split. - split with (make_dirprod (isabgroptoisabmonoidop _ _ (ringop1axs_is is)) (ringop2axs_is is)). split. + simpl. apply (ringmult0x_is). + simpl. apply (ringmultx0_is). - apply (ringdistraxs_is is). Defined. Coercion isringopstoisrigops : isringops >-> isrigops. (** *) Definition iscommrigops {X : UU} (opp1 opp2 : binop X) : UU := (isrigops opp1 opp2) × (iscomm opp2). Definition pr1iscommrigops (X : UU) (opp1 opp2 : binop X) : iscommrigops opp1 opp2 -> isrigops opp1 opp2 := @pr1 _ _. Coercion pr1iscommrigops : iscommrigops >-> isrigops. Definition rigiscommop2_is {X : UU} {opp1 opp2 : binop X} (is : iscommrigops opp1 opp2) : iscomm opp2 := pr2 is. Lemma isapropiscommrig {X : hSet} (opp1 opp2 : binop X) : isaprop (iscommrigops opp1 opp2). Proof. apply (isofhleveldirprod 1). - apply isapropisrigops. - apply isapropiscomm. Defined. (** *) Definition iscommringops {X : UU} (opp1 opp2 : binop X) : UU := (isringops opp1 opp2) × (iscomm opp2). Definition pr1iscommringops (X : UU) (opp1 opp2 : binop X) : iscommringops opp1 opp2 -> isringops opp1 opp2 := @pr1 _ _. Coercion pr1iscommringops : iscommringops >-> isringops. Definition ringiscommop2_is {X : UU} {opp1 opp2 : binop X} (is : iscommringops opp1 opp2) : iscomm opp2 := pr2 is. Lemma isapropiscommring {X : hSet} (opp1 opp2 : binop X) : isaprop (iscommringops opp1 opp2). Proof. apply (isofhleveldirprod 1). - apply isapropisringops. - apply isapropiscomm. Defined. Definition iscommringopstoiscommrigops (X : UU) (opp1 opp2 : binop X) (is : iscommringops opp1 opp2) : iscommrigops opp1 opp2 := make_dirprod (isringopstoisrigops _ _ _ (pr1 is)) (pr2 is). Coercion iscommringopstoiscommrigops : iscommringops >-> iscommrigops. (** **** Transfer properties of binary operations relative to weak equivalences *) (** binop_weq_fwd *) Lemma isassoc_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : isassoc opp → isassoc (binop_weq_fwd H opp). Proof. intros is x y z. apply (maponpaths H). refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply (maponpaths (λ x, opp x _)). apply homotinvweqweq. - apply maponpaths. apply homotinvweqweq0. Defined. Lemma islunit_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) : islunit opp x0 → islunit (binop_weq_fwd H opp) (H x0). Proof. intros is y. unfold binop_weq_fwd. refine (pathscomp0 (maponpaths _ _) _). - refine (pathscomp0 (maponpaths (λ x, opp x _) _) _). + apply homotinvweqweq. + apply is. - apply homotweqinvweq. Defined. Lemma isrunit_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) : isrunit opp x0 → isrunit (binop_weq_fwd H opp) (H x0). Proof. intros is y. unfold binop_weq_fwd. refine (pathscomp0 (maponpaths _ _) _). - refine (pathscomp0 (maponpaths (opp _) _) _). + apply homotinvweqweq. + apply is. - apply homotweqinvweq. Defined. Lemma isunit_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) : isunit opp x0 → isunit (binop_weq_fwd H opp) (H x0). Proof. intro is. split. apply islunit_weq_fwd, (pr1 is). apply isrunit_weq_fwd, (pr2 is). Defined. Lemma isunital_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : isunital opp → isunital (binop_weq_fwd H opp). Proof. intro is. exists (H (pr1 is)). apply isunit_weq_fwd, (pr2 is). Defined. Lemma ismonoidop_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : ismonoidop opp → ismonoidop (binop_weq_fwd H opp). Proof. intro is. split. apply isassoc_weq_fwd, (pr1 is). apply isunital_weq_fwd, (pr2 is). Defined. Lemma islinv_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) (inv : X → X) : islinv opp x0 inv → islinv (binop_weq_fwd H opp) (H x0) (λ y : Y, H (inv (invmap H y))). Proof. intros is y. unfold binop_weq_fwd. apply maponpaths. refine (pathscomp0 _ (is _)). apply (maponpaths (λ x, opp x _)). apply homotinvweqweq. Defined. Lemma isrinv_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) (inv : X → X) : isrinv opp x0 inv → isrinv (binop_weq_fwd H opp) (H x0) (λ y : Y, H (inv (invmap H y))). Proof. intros is y. unfold binop_weq_fwd. apply maponpaths. refine (pathscomp0 _ (is _)). apply (maponpaths (opp _)). apply homotinvweqweq. Defined. Lemma isinv_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (x0 : X) (inv : X → X) : isinv opp x0 inv → isinv (binop_weq_fwd H opp) (H x0) (λ y : Y, H (inv (invmap H y))). Proof. intro is. split. apply islinv_weq_fwd, (pr1 is). apply isrinv_weq_fwd, (pr2 is). Defined. Lemma invstruct_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) (is : ismonoidop opp) : invstruct opp is → invstruct (binop_weq_fwd H opp) (ismonoidop_weq_fwd H opp is). Proof. intro inv. exists (λ y : Y, H (pr1 inv (invmap H y))). apply isinv_weq_fwd, (pr2 inv). Defined. Lemma isgrop_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : isgrop opp → isgrop (binop_weq_fwd H opp). Proof. intro is. use tpair. - apply ismonoidop_weq_fwd, (pr1 is). - apply invstruct_weq_fwd, (pr2 is). Defined. Lemma iscomm_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : iscomm opp → iscomm (binop_weq_fwd H opp). Proof. intros is x y. unfold binop_weq_fwd. apply maponpaths, is. Defined. Lemma isabmonoidop_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : isabmonoidop opp → isabmonoidop (binop_weq_fwd H opp). Proof. intro is. split. apply ismonoidop_weq_fwd, (pr1 is). apply iscomm_weq_fwd, (pr2 is). Defined. Lemma isabgrop_weq_fwd {X Y : UU} (H : X ≃ Y) (opp : binop X) : isabgrop opp → isabgrop (binop_weq_fwd H opp). Proof. intro is. split. apply isgrop_weq_fwd, (pr1 is). apply iscomm_weq_fwd, (pr2 is). Defined. Lemma isldistr_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isldistr op1 op2 → isldistr (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intros is x y z. unfold binop_weq_fwd. apply maponpaths. refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply maponpaths. apply homotinvweqweq. - apply map_on_two_paths ; apply homotinvweqweq0. Defined. Lemma isrdistr_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isrdistr op1 op2 → isrdistr (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intros is x y z. unfold binop_weq_fwd. apply maponpaths. refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply (maponpaths (λ x, op2 x _)). apply homotinvweqweq. - apply map_on_two_paths ; apply homotinvweqweq0. Defined. Lemma isdistr_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isdistr op1 op2 → isdistr (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intro is. split. apply isldistr_weq_fwd, (pr1 is). apply isrdistr_weq_fwd, (pr2 is). Defined. Lemma isabsorb_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isabsorb op1 op2 → isabsorb (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intros is x y. unfold binop_weq_fwd. refine (pathscomp0 _ (homotweqinvweq H _)). apply maponpaths. refine (pathscomp0 _ (is _ _)). apply maponpaths. apply (homotinvweqweq H). Defined. Lemma isrigops_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isrigops op1 op2 → isrigops (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intro is. split. - use tpair. + split. apply isabmonoidop_weq_fwd, (pr1 (pr1 (pr1 is))). apply ismonoidop_weq_fwd, (pr2 (pr1 (pr1 is))). + split ; simpl. * intros x. apply (maponpaths H). refine (pathscomp0 _ (pr1 (pr2 (pr1 is)) _)). apply (maponpaths (λ x, op2 x _)). apply homotinvweqweq. * intros x. apply (maponpaths H). refine (pathscomp0 _ (pr2 (pr2 (pr1 is)) _)). apply (maponpaths (op2 _)). apply homotinvweqweq. - apply isdistr_weq_fwd, (pr2 is). Defined. Lemma isringops_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : isringops op1 op2 → isringops (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intro is. split. - split. + apply isabgrop_weq_fwd, (pr1 (pr1 is)). + apply ismonoidop_weq_fwd, (pr2 (pr1 is)). - apply isdistr_weq_fwd, (pr2 is). Defined. Lemma iscommrigops_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : iscommrigops op1 op2 → iscommrigops (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intro is. split. - apply isrigops_weq_fwd, (pr1 is). - apply iscomm_weq_fwd, (pr2 is). Defined. Lemma iscommringops_weq_fwd {X Y : UU} (H : X ≃ Y) (op1 op2 : binop X) : iscommringops op1 op2 → iscommringops (binop_weq_fwd H op1) (binop_weq_fwd H op2). Proof. intro is. split. - apply isringops_weq_fwd, (pr1 is). - apply iscomm_weq_fwd, (pr2 is). Defined. (** binop_weq_bck *) Lemma isassoc_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : isassoc opp → isassoc (binop_weq_bck H opp). Proof. intros is x y z. apply (maponpaths (invmap H)). refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply (maponpaths (λ x, opp x _)). apply homotweqinvweq. - apply maponpaths. apply pathsinv0, homotweqinvweq. Defined. Lemma islunit_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) : islunit opp x0 → islunit (binop_weq_bck H opp) (invmap H x0). Proof. intros is y. unfold binop_weq_bck. refine (pathscomp0 (maponpaths _ _) _). - refine (pathscomp0 (maponpaths (λ x, opp x _) _) _). + apply homotweqinvweq. + apply is. - apply homotinvweqweq. Defined. Lemma isrunit_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) : isrunit opp x0 → isrunit (binop_weq_bck H opp) (invmap H x0). Proof. intros is y. unfold binop_weq_bck. refine (pathscomp0 (maponpaths _ _) _). - refine (pathscomp0 (maponpaths (opp _) _) _). + apply homotweqinvweq. + apply is. - apply homotinvweqweq. Defined. Lemma isunit_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) : isunit opp x0 → isunit (binop_weq_bck H opp) (invmap H x0). Proof. intro is. split. apply islunit_weq_bck, (pr1 is). apply isrunit_weq_bck, (pr2 is). Defined. Lemma isunital_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : isunital opp → isunital (binop_weq_bck H opp). Proof. intro is. exists (invmap H (pr1 is)). apply isunit_weq_bck, (pr2 is). Defined. Lemma ismonoidop_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : ismonoidop opp → ismonoidop (binop_weq_bck H opp). Proof. intro is. split. apply isassoc_weq_bck, (pr1 is). apply isunital_weq_bck, (pr2 is). Defined. Lemma islinv_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) (inv : Y → Y) : islinv opp x0 inv → islinv (binop_weq_bck H opp) (invmap H x0) (λ y : X, invmap H (inv (H y))). Proof. intros is y. unfold binop_weq_bck. apply maponpaths. refine (pathscomp0 _ (is _)). apply (maponpaths (λ x, opp x _)). apply homotweqinvweq. Defined. Lemma isrinv_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) (inv : Y → Y) : isrinv opp x0 inv → isrinv (binop_weq_bck H opp) (invmap H x0) (λ y : X, invmap H (inv (H y))). Proof. intros is y. unfold binop_weq_bck. apply maponpaths. refine (pathscomp0 _ (is _)). apply (maponpaths (opp _)). apply homotweqinvweq. Defined. Lemma isinv_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (x0 : Y) (inv : Y → Y) : isinv opp x0 inv → isinv (binop_weq_bck H opp) (invmap H x0) (λ y : X, invmap H (inv (H y))). Proof. intro is. split. apply islinv_weq_bck, (pr1 is). apply isrinv_weq_bck, (pr2 is). Defined. Lemma invstruct_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) (is : ismonoidop opp) : invstruct opp is → invstruct (binop_weq_bck H opp) (ismonoidop_weq_bck H opp is). Proof. intro inv. exists (λ y : X, invmap H (pr1 inv (H y))). apply isinv_weq_bck, (pr2 inv). Defined. Lemma isgrop_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : isgrop opp → isgrop (binop_weq_bck H opp). Proof. intro is. use tpair. apply ismonoidop_weq_bck, (pr1 is). apply invstruct_weq_bck, (pr2 is). Defined. Lemma iscomm_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : iscomm opp → iscomm (binop_weq_bck H opp). Proof. intros is x y. unfold binop_weq_bck. apply maponpaths, is. Defined. Lemma isabmonoidop_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : isabmonoidop opp → isabmonoidop (binop_weq_bck H opp). Proof. intro is. split. apply ismonoidop_weq_bck, (pr1 is). apply iscomm_weq_bck, (pr2 is). Defined. Lemma isabgrop_weq_bck {X Y : UU} (H : X ≃ Y) (opp : binop Y) : isabgrop opp → isabgrop (binop_weq_bck H opp). Proof. intro is. split. apply isgrop_weq_bck, (pr1 is). apply iscomm_weq_bck, (pr2 is). Defined. Lemma isldistr_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isldistr op1 op2 → isldistr (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intros is x y z. unfold binop_weq_bck. apply maponpaths. refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply maponpaths. apply homotweqinvweq. - apply map_on_two_paths ; apply pathsinv0, homotweqinvweq. Defined. Lemma isrdistr_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isrdistr op1 op2 → isrdistr (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intros is x y z. unfold binop_weq_bck. apply maponpaths. refine (pathscomp0 _ (pathscomp0 (is _ _ _) _)). - apply (maponpaths (λ x, op2 x _)). apply homotweqinvweq. - apply map_on_two_paths ; apply pathsinv0, homotweqinvweq. Defined. Lemma isdistr_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isdistr op1 op2 → isdistr (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intro is. split. apply isldistr_weq_bck, (pr1 is). apply isrdistr_weq_bck, (pr2 is). Defined. Lemma isabsorb_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isabsorb op1 op2 → isabsorb (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intros is x y. unfold binop_weq_bck. refine (pathscomp0 _ (homotinvweqweq H _)). apply maponpaths. refine (pathscomp0 _ (is _ _)). apply maponpaths. apply (homotweqinvweq H). Defined. Lemma isrigops_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isrigops op1 op2 → isrigops (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intro is. split. - use tpair. + split. apply isabmonoidop_weq_bck, (pr1 (pr1 (pr1 is))). apply ismonoidop_weq_bck, (pr2 (pr1 (pr1 is))). + split ; simpl. * intros x. apply (maponpaths (invmap H)). refine (pathscomp0 _ (pr1 (pr2 (pr1 is)) _)). apply (maponpaths (λ x, op2 x _)). apply homotweqinvweq. * intros x. apply (maponpaths (invmap H)). refine (pathscomp0 _ (pr2 (pr2 (pr1 is)) _)). apply (maponpaths (op2 _)). apply homotweqinvweq. - apply isdistr_weq_bck, (pr2 is). Defined. Lemma isringops_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : isringops op1 op2 → isringops (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intro is. split. - split. + apply isabgrop_weq_bck, (pr1 (pr1 is)). + apply ismonoidop_weq_bck, (pr2 (pr1 is)). - apply isdistr_weq_bck, (pr2 is). Defined. Lemma iscommrigops_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : iscommrigops op1 op2 → iscommrigops (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intro is. split. - apply isrigops_weq_bck, (pr1 is). - apply iscomm_weq_bck, (pr2 is). Defined. Lemma iscommringops_weq_bck {X Y : UU} (H : X ≃ Y) (op1 op2 : binop Y) : iscommringops op1 op2 → iscommringops (binop_weq_bck H op1) (binop_weq_bck H op2). Proof. intro is. split. - apply isringops_weq_bck, (pr1 is). - apply iscomm_weq_bck, (pr2 is). Defined. (** *** Sets with one binary operation *) (** **** General definitions *) Definition setwithbinop : UU := total2 (λ X : hSet, binop X). Definition make_setwithbinop (X : hSet) (opp : binop X) : setwithbinop := tpair (λ X : hSet, binop X) X opp. Definition pr1setwithbinop : setwithbinop -> hSet := @pr1 _ (λ X : hSet, binop X). Coercion pr1setwithbinop : setwithbinop >-> hSet. Definition op {X : setwithbinop} : binop X := pr2 X. Definition isasetbinoponhSet (X : hSet) : isaset (@binop X). Proof. use impred_isaset. intros t1. use impred_isaset. intros t2. use setproperty. Defined. Opaque isasetbinoponhSet. Declare Scope addoperation_scope. Delimit Scope addoperation_scope with addoperation. Notation "x + y" := (op x y) : addoperation_scope. Declare Scope multoperation_scope. Delimit Scope multoperation_scope with multoperation. Notation "x * y" := (op x y) : multoperation_scope. (* The reverse/opposite binary operation where the arguments are flipped. *) Definition setwithbinop_rev (X : setwithbinop) : setwithbinop := make_setwithbinop X (λ x y, op y x). (** **** Functions compatible with a binary operation (homomorphisms) and their properties *) Definition isbinopfun {X Y : setwithbinop} (f : X -> Y) : UU := ∏ x x' : X, paths (f (op x x')) (op (f x) (f x')). Definition make_isbinopfun {X Y : setwithbinop} {f : X -> Y} (H : ∏ x x' : X, f (op x x') = op (f x) (f x')) : isbinopfun f := H. Lemma isapropisbinopfun {X Y : setwithbinop} (f : X -> Y) : isaprop (isbinopfun f). Proof. apply impred. intro x. apply impred. intro x'. apply (setproperty Y). Defined. Definition isbinopfun_twooutof3b {A B C : setwithbinop} (f : A -> B) (g : B -> C) (H : issurjective f) : isbinopfun (g ∘ f)%functions -> isbinopfun f -> isbinopfun g. Proof. intros H1 H2. use make_isbinopfun. intros b1 b2. use (squash_to_prop (H b1) (@setproperty C _ _)). intros H1'. use (squash_to_prop (H b2) (@setproperty C _ _)). intros H2'. rewrite <- (hfiberpr2 _ _ H1'). rewrite <- (hfiberpr2 _ _ H2'). use (pathscomp0 (! (maponpaths (λ b : B, g b) (H2 (hfiberpr1 f b1 H1') (hfiberpr1 f b2 H2'))))). exact (H1 (hfiberpr1 f b1 H1') (hfiberpr1 f b2 H2')). Qed. Definition binopfun (X Y : setwithbinop) : UU := total2 (fun f : X -> Y => isbinopfun f). Definition make_binopfun {X Y : setwithbinop} (f : X -> Y) (is : isbinopfun f) : binopfun X Y := tpair _ f is. Definition pr1binopfun (X Y : setwithbinop) : binopfun X Y -> (X -> Y) := @pr1 _ _. Coercion pr1binopfun : binopfun >-> Funclass. Definition binopfunisbinopfun {X Y : setwithbinop} (f : binopfun X Y) : isbinopfun f := pr2 f. Lemma isasetbinopfun (X Y : setwithbinop) : isaset (binopfun X Y). Proof. apply (isasetsubset (pr1binopfun X Y)). - change (isofhlevel 2 (X -> Y)). apply impred. intro. apply (setproperty Y). - refine (isinclpr1 _ _). intro. apply isapropisbinopfun. Defined. Lemma isbinopfuncomp {X Y Z : setwithbinop} (f : binopfun X Y) (g : binopfun Y Z) : isbinopfun (funcomp (pr1 f) (pr1 g)). Proof. set (axf := pr2 f). set (axg := pr2 g). intros a b. simpl. rewrite (axf a b). rewrite (axg (pr1 f a) (pr1 f b)). apply idpath. Defined. Opaque isbinopfuncomp. Definition binopfuncomp {X Y Z : setwithbinop} (f : binopfun X Y) (g : binopfun Y Z) : binopfun X Z := make_binopfun (funcomp (pr1 f) (pr1 g)) (isbinopfuncomp f g). Definition binopmono (X Y : setwithbinop) : UU := total2 (λ f : incl X Y, isbinopfun (pr1 f)). Definition make_binopmono {X Y : setwithbinop} (f : incl X Y) (is : isbinopfun f) : binopmono X Y := tpair _ f is. Definition pr1binopmono (X Y : setwithbinop) : binopmono X Y -> incl X Y := @pr1 _ _. Coercion pr1binopmono : binopmono >-> incl. Definition binopincltobinopfun (X Y : setwithbinop) : binopmono X Y -> binopfun X Y := λ f, make_binopfun (pr1 (pr1 f)) (pr2 f). Coercion binopincltobinopfun : binopmono >-> binopfun. Definition binopmonocomp {X Y Z : setwithbinop} (f : binopmono X Y) (g : binopmono Y Z) : binopmono X Z := make_binopmono (inclcomp (pr1 f) (pr1 g)) (isbinopfuncomp f g). Definition binopiso (X Y : setwithbinop) : UU := total2 (λ f : X ≃ Y, isbinopfun f). Definition make_binopiso {X Y : setwithbinop} (f : X ≃ Y) (is : isbinopfun f) : binopiso X Y := tpair _ f is. Definition pr1binopiso (X Y : setwithbinop) : binopiso X Y -> X ≃ Y := @pr1 _ _. Coercion pr1binopiso : binopiso >-> weq. Lemma isasetbinopiso (X Y : setwithbinop) : isaset (binopiso X Y). Proof. use isaset_total2. - use isaset_total2. + use impred_isaset. intros t. use setproperty. + intros x. use isasetaprop. use isapropisweq. - intros w. use isasetaprop. use isapropisbinopfun. Defined. Opaque isasetbinopiso. Definition binopisotobinopmono (X Y : setwithbinop) : binopiso X Y -> binopmono X Y := λ f, make_binopmono (weqtoincl (pr1 f)) (pr2 f). Coercion binopisotobinopmono : binopiso >-> binopmono. Definition binopisocomp {X Y Z : setwithbinop} (f : binopiso X Y) (g : binopiso Y Z) : binopiso X Z := make_binopiso (weqcomp (pr1 f) (pr1 g)) (isbinopfuncomp f g). Lemma isbinopfuninvmap {X Y : setwithbinop} (f : binopiso X Y) : isbinopfun (invmap (pr1 f)). Proof. set (axf := pr2 f). intros a b. apply (invmaponpathsweq (pr1 f)). rewrite (homotweqinvweq (pr1 f) (op a b)). rewrite (axf (invmap (pr1 f) a) (invmap (pr1 f) b)). rewrite (homotweqinvweq (pr1 f) a). rewrite (homotweqinvweq (pr1 f) b). apply idpath. Defined. Opaque isbinopfuninvmap. Definition invbinopiso {X Y : setwithbinop} (f : binopiso X Y) : binopiso Y X := make_binopiso (invweq (pr1 f)) (isbinopfuninvmap f). Definition idbinopiso (X : setwithbinop) : binopiso X X. Proof. use make_binopiso. - exact (idweq X). - intros x1 x2. use idpath. Defined. (** **** (X = Y) ≃ (binopiso X Y) The idea is to use the composition (X = Y) ≃ (X ╝ Y) ≃ (binopiso X Y) *) Definition setwithbinop_univalence_weq1 (X Y : setwithbinop) : (X = Y) ≃ (X ╝ Y) := total2_paths_equiv _ X Y. Definition setwithbinop_univalence_weq2 (X Y : setwithbinop) : (X ╝ Y) ≃ (binopiso X Y). Proof. use weqbandf. - use hSet_univalence. - intros e. use invweq. induction X as [X Xop]. induction Y as [Y Yop]. cbn in e. induction e. use weqimplimpl. + intros i. use funextfun. intros x1. use funextfun. intros x2. exact (i x1 x2). + intros e. cbn in e. intros x1 x2. induction e. use idpath. + use isapropisbinopfun. + use isasetbinoponhSet. Defined. Definition setwithbinop_univalence_map (X Y : setwithbinop) : X = Y -> binopiso X Y. Proof. intro e. induction e. exact (idbinopiso X). Defined. Lemma setwithbinop_univalence_isweq (X Y : setwithbinop) : isweq (setwithbinop_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (setwithbinop_univalence_weq1 X Y) (setwithbinop_univalence_weq2 X Y)). - intros e. induction e. use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque setwithbinop_univalence_isweq. Definition setwithbinop_univalence (X Y : setwithbinop) : (X = Y) ≃ (binopiso X Y). Proof. use make_weq. - exact (setwithbinop_univalence_map X Y). - exact (setwithbinop_univalence_isweq X Y). Defined. Opaque setwithbinop_univalence. (** **** hfiber and binop*) Local Lemma hfiberbinop_path {A B : setwithbinop} (f : binopfun A B) (b1 b2 : B) (hf1 : hfiber (pr1 f) b1) (hf2 : hfiber (pr1 f) b2) : pr1 f (@op A (pr1 hf1) (pr1 hf2)) = (@op B b1 b2). Proof. use (pathscomp0 (binopfunisbinopfun f _ _)). rewrite <- (hfiberpr2 _ _ hf1). rewrite <- (hfiberpr2 _ _ hf2). use idpath. Qed. Definition hfiberbinop {A B : setwithbinop} (f : binopfun A B) (b1 b2 : B) (hf1 : hfiber (pr1 f) b1) (hf2 : hfiber (pr1 f) b2) : hfiber (pr1 f) (@op B b1 b2) := make_hfiber (pr1 f) (@op A (pr1 hf1) (pr1 hf2)) (hfiberbinop_path f b1 b2 hf1 hf2). (** **** Transport of properties of a binary operation *) Lemma islcancelablemonob {X Y : setwithbinop} (f : binopmono X Y) (x : X) (is : islcancelable (@op Y) (f x)) : islcancelable (@op X) x. Proof. unfold islcancelable. apply (isincltwooutof3a (λ x0 : X, op x x0) f (pr2 (pr1 f))). assert (h : homot (funcomp f (λ y0 : Y, op (f x) y0)) (funcomp (λ x0 : X, op x x0) f)). { intro x0; simpl. apply (pathsinv0 ((pr2 f) x x0)). } apply (isinclhomot _ _ h). apply (isinclcomp f (make_incl _ is)). Defined. Lemma isrcancelablemonob {X Y : setwithbinop} (f : binopmono X Y) (x : X) (is : isrcancelable (@op Y) (f x)) : isrcancelable (@op X) x. Proof. unfold islcancelable. apply (isincltwooutof3a (λ x0 : X, op x0 x) f (pr2 (pr1 f))). assert (h : homot (funcomp f (λ y0 : Y, op y0 (f x))) (funcomp (λ x0 : X, op x0 x) f)). { intro x0; simpl. apply (pathsinv0 ((pr2 f) x0 x)). } apply (isinclhomot _ _ h). apply (isinclcomp f (make_incl _ is)). Defined. Lemma iscancelablemonob {X Y : setwithbinop} (f : binopmono X Y) (x : X) (is : iscancelable (@op Y) (f x)) : iscancelable (@op X) x. Proof. apply (make_dirprod (islcancelablemonob f x (pr1 is)) (isrcancelablemonob f x (pr2 is))). Defined. Notation islcancelableisob := islcancelablemonob. Notation isrcancelableisob := isrcancelablemonob. Notation iscancelableisob := iscancelablemonob. Lemma islinvertibleisob {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : islinvertible (@op Y) (f x)) : islinvertible (@op X) x. Proof. unfold islinvertible. apply (twooutof3a (λ x0 : X, op x x0) f). - assert (h : homot (funcomp f (λ y0 : Y, op (f x) y0)) (funcomp (λ x0 : X, op x x0) f)). { intro x0; simpl. apply (pathsinv0 ((pr2 f) x x0)). } apply (isweqhomot _ _ h). apply (pr2 (weqcomp f (make_weq _ is))). - apply (pr2 (pr1 f)). Defined. Lemma isrinvertibleisob {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : isrinvertible (@op Y) (f x)) : isrinvertible (@op X) x. Proof. unfold islinvertible. apply (twooutof3a (λ x0 : X, op x0 x) f). - assert (h : homot (funcomp f (λ y0 : Y, op y0 (f x))) (funcomp (λ x0 : X, op x0 x) f)). { intro x0; simpl. apply (pathsinv0 ((pr2 f) x0 x)). } apply (isweqhomot _ _ h). apply (pr2 (weqcomp f (make_weq _ is))). - apply (pr2 (pr1 f)). Defined. Lemma isinvertiblemonob {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : isinvertible (@op Y) (f x)) : isinvertible (@op X) x. Proof. apply (make_dirprod (islinvertibleisob f x (pr1 is)) (isrinvertibleisob f x (pr2 is))). Defined. Definition islinvertibleisof {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : islinvertible (@op X) x) : islinvertible (@op Y) (f x). Proof. unfold islinvertible. apply (twooutof3b f). - apply (pr2 (pr1 f)). - assert (h : homot (funcomp (λ x0 : X, op x x0) f) (λ x0 : X, op (f x) (f x0))). { intro x0; simpl. apply (pr2 f x x0). } apply (isweqhomot _ _ h). apply (pr2 (weqcomp (make_weq _ is) f)). Defined. Definition isrinvertibleisof {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : isrinvertible (@op X) x) : isrinvertible (@op Y) (f x). Proof. unfold isrinvertible. apply (twooutof3b f). - apply (pr2 (pr1 f)). - assert (h : homot (funcomp (λ x0 : X, op x0 x) f) (λ x0 : X, op (f x0) (f x))). { intro x0; simpl. apply (pr2 f x0 x). } apply (isweqhomot _ _ h). apply (pr2 (weqcomp (make_weq _ is) f)). Defined. Lemma isinvertiblemonof {X Y : setwithbinop} (f : binopiso X Y) (x : X) (is : isinvertible (@op X) x) : isinvertible (@op Y) (f x). Proof. apply (make_dirprod (islinvertibleisof f x (pr1 is)) (isrinvertibleisof f x (pr2 is))). Defined. Lemma isassocmonob {X Y : setwithbinop} (f : binopmono X Y) (is : isassoc (@op Y)) : isassoc (@op X). Proof. set (axf := pr2 f). simpl in axf. intros a b c. apply (invmaponpathsincl _ (pr2 (pr1 f))). rewrite (axf (op a b) c). rewrite (axf a b). rewrite (axf a (op b c)). rewrite (axf b c). apply is. Defined. Opaque isassocmonob. Lemma iscommmonob {X Y : setwithbinop} (f : binopmono X Y) (is : iscomm (@op Y)) : iscomm (@op X). Proof. set (axf := pr2 f). simpl in axf. intros a b. apply (invmaponpathsincl _ (pr2 (pr1 f))). rewrite (axf a b). rewrite (axf b a). apply is. Defined. Opaque iscommmonob. Notation isassocisob := isassocmonob. Notation iscommisob := iscommmonob. Lemma isassocisof {X Y : setwithbinop} (f : binopiso X Y) (is : isassoc (@op X)) : isassoc (@op Y). Proof. apply (isassocmonob (invbinopiso f) is). Defined. Opaque isassocisof. Lemma iscommisof {X Y : setwithbinop} (f : binopiso X Y) (is : iscomm (@op X)) : iscomm (@op Y). Proof. apply (iscommmonob (invbinopiso f) is). Defined. Opaque iscommisof. Lemma isunitisof {X Y : setwithbinop} (f : binopiso X Y) (unx : X) (is : isunit (@op X) unx) : isunit (@op Y) (f unx). Proof. set (axf := pr2 f). split. - intro a. change (f unx) with (pr1 f unx). apply (invmaponpathsweq (pr1 (invbinopiso f))). rewrite (pr2 (invbinopiso f) (pr1 f unx) a). simpl. rewrite (homotinvweqweq (pr1 f) unx). apply (pr1 is). - intro a. change (f unx) with (pr1 f unx). apply (invmaponpathsweq (pr1 (invbinopiso f))). rewrite (pr2 (invbinopiso f) a (pr1 f unx)). simpl. rewrite (homotinvweqweq (pr1 f) unx). apply (pr2 is). Defined. Opaque isunitisof. Definition isunitalisof {X Y : setwithbinop} (f : binopiso X Y) (is : isunital (@op X)) : isunital (@op Y) := make_isunital (f (pr1 is)) (isunitisof f (pr1 is) (pr2 is)). Lemma isunitisob {X Y : setwithbinop} (f : binopiso X Y) (uny : Y) (is : isunit (@op Y) uny) : isunit (@op X) ((invmap f) uny). Proof. set (int := isunitisof (invbinopiso f)). simpl. simpl in int. apply int. apply is. Defined. Opaque isunitisob. Definition isunitalisob {X Y : setwithbinop} (f : binopiso X Y) (is : isunital (@op Y)) : isunital (@op X) := make_isunital ((invmap f) (pr1 is)) (isunitisob f (pr1 is) (pr2 is)). Definition ismonoidopisof {X Y : setwithbinop} (f : binopiso X Y) (is : ismonoidop (@op X)) : ismonoidop (@op Y) := make_dirprod (isassocisof f (pr1 is)) (isunitalisof f (pr2 is)). Definition ismonoidopisob {X Y : setwithbinop} (f : binopiso X Y) (is : ismonoidop (@op Y)) : ismonoidop (@op X) := make_dirprod (isassocisob f (pr1 is)) (isunitalisob f (pr2 is)). Lemma isinvisof {X Y : setwithbinop} (f : binopiso X Y) (unx : X) (invx : X -> X) (is : isinv (@op X) unx invx) : isinv (@op Y) (pr1 f unx) (funcomp (invmap (pr1 f)) (funcomp invx (pr1 f))). Proof. set (axf := pr2 f). set (axinvf := pr2 (invbinopiso f)). simpl in axf, axinvf. split. - intro a. apply (invmaponpathsweq (pr1 (invbinopiso f))). simpl. rewrite (axinvf ((pr1 f) (invx (invmap (pr1 f) a))) a). rewrite (homotinvweqweq (pr1 f) unx). rewrite (homotinvweqweq (pr1 f) (invx (invmap (pr1 f) a))). apply (pr1 is). - intro a. apply (invmaponpathsweq (pr1 (invbinopiso f))). simpl. rewrite (axinvf a ((pr1 f) (invx (invmap (pr1 f) a)))). rewrite (homotinvweqweq (pr1 f) unx). rewrite (homotinvweqweq (pr1 f) (invx (invmap (pr1 f) a))). apply (pr2 is). Defined. Opaque isinvisof. Definition isgropisof {X Y : setwithbinop} (f : binopiso X Y) (is : isgrop (@op X)) : isgrop (@op Y) := tpair _ (ismonoidopisof f is) (tpair _ (funcomp (invmap (pr1 f)) (funcomp (grinv_is is) (pr1 f))) (isinvisof f (unel_is is) (grinv_is is) (pr2 (pr2 is)))). Lemma isinvisob {X Y : setwithbinop} (f : binopiso X Y) (uny : Y) (invy : Y -> Y) (is : isinv (@op Y) uny invy) : isinv (@op X) (invmap (pr1 f) uny) (funcomp (pr1 f) (funcomp invy (invmap (pr1 f)))). Proof. apply (isinvisof (invbinopiso f) uny invy is). Defined. Opaque isinvisob. Definition isgropisob {X Y : setwithbinop} (f : binopiso X Y) (is : isgrop (@op Y)) : isgrop (@op X) := tpair _ (ismonoidopisob f is) (tpair _ (funcomp (pr1 f) (funcomp (grinv_is is) (invmap (pr1 f)))) (isinvisob f (unel_is is) (grinv_is is) (pr2 (pr2 is)))). Definition isabmonoidopisof {X Y : setwithbinop} (f : binopiso X Y) (is : isabmonoidop (@op X)) : isabmonoidop (@op Y) := tpair _ (ismonoidopisof f is) (iscommisof f (commax_is is)). Definition isabmonoidopisob {X Y : setwithbinop} (f : binopiso X Y) (is : isabmonoidop (@op Y)) : isabmonoidop (@op X) := tpair _ (ismonoidopisob f is) (iscommisob f (commax_is is)). Definition isabgropisof {X Y : setwithbinop} (f : binopiso X Y) (is : isabgrop (@op X)) : isabgrop (@op Y) := tpair _ (isgropisof f is) (iscommisof f (commax_is is)). Definition isabgropisob {X Y : setwithbinop} (f : binopiso X Y) (is : isabgrop (@op Y)) : isabgrop (@op X) := tpair _ (isgropisob f is) (iscommisob f (commax_is is)). (** **** Subobjects *) Definition issubsetwithbinop {X : hSet} (opp : binop X) (A : hsubtype X) : UU := ∏ a a' : A, A (opp (pr1 a) (pr1 a')). Lemma isapropissubsetwithbinop {X : hSet} (opp : binop X) (A : hsubtype X) : isaprop (issubsetwithbinop opp A). Proof. apply impred. intro a. apply impred. intros a'. apply (pr2 (A (opp (pr1 a) (pr1 a')))). Defined. Definition subsetswithbinop (X : setwithbinop) : UU := total2 (λ A : hsubtype X, issubsetwithbinop (@op X) A). Definition make_subsetswithbinop {X : setwithbinop} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubsetwithbinop op A) t → ∑ A : hsubtype X, issubsetwithbinop op A := tpair (λ A : hsubtype X, issubsetwithbinop (@op X) A). Definition subsetswithbinopconstr {X : setwithbinop} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubsetwithbinop op A) t → ∑ A : hsubtype X, issubsetwithbinop op A := @make_subsetswithbinop X. Definition pr1subsetswithbinop (X : setwithbinop) : subsetswithbinop X -> hsubtype X := @pr1 _ (λ A : hsubtype X, issubsetwithbinop (@op X) A). Coercion pr1subsetswithbinop : subsetswithbinop >-> hsubtype. Definition pr2subsetswithbinop {X : setwithbinop} (Y : subsetswithbinop X) : issubsetwithbinop (@op X) (pr1subsetswithbinop X Y) := pr2 Y. Definition totalsubsetwithbinop (X : setwithbinop) : subsetswithbinop X. Proof. split with (λ x : X, htrue). intros x x'. apply tt. Defined. Definition carrierofasubsetwithbinop {X : setwithbinop} (A : subsetswithbinop X) : setwithbinop. Proof. set (aset := (make_hSet (carrier A) (isasetsubset (pr1carrier A) (setproperty X) (isinclpr1carrier A))) : hSet). split with aset. set (subopp := (λ a a' : A, make_carrier A (op (pr1carrier _ a) (pr1carrier _ a')) (pr2 A a a')) : (A -> A -> A)). simpl. unfold binop. apply subopp. Defined. Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop. (** **** Relations compatible with a binary operation and quotient objects *) Definition isbinophrel {X : setwithbinop} (R : hrel X) : UU := dirprod (∏ a b c : X, R a b -> R (op c a) (op c b)) (∏ a b c : X, R a b -> R (op a c) (op b c)). Definition make_isbinophrel {X : setwithbinop} {R : hrel X} (H1 : ∏ a b c : X, R a b -> R (op c a) (op c b)) (H2 : ∏ a b c : X, R a b -> R (op a c) (op b c)) : isbinophrel R := tpair _ H1 H2. Definition isbinophrellogeqf {X : setwithbinop} {L R : hrel X} (lg : hrellogeq L R) (isl : isbinophrel L) : isbinophrel R. Proof. split. - intros a b c rab. apply ((pr1 (lg _ _) ((pr1 isl) _ _ _ (pr2 (lg _ _) rab)))). - intros a b c rab. apply ((pr1 (lg _ _) ((pr2 isl) _ _ _ (pr2 (lg _ _) rab)))). Defined. Lemma isapropisbinophrel {X : setwithbinop} (R : hrel X) : isaprop (isbinophrel R). Proof. apply isapropdirprod. - apply impred. intro a. apply impred. intro b. apply impred. intro c. apply impred. intro r. apply (pr2 (R _ _)). - apply impred. intro a. apply impred. intro b. apply impred. intro c. apply impred. intro r. apply (pr2 (R _ _)). Defined. Lemma isbinophrelif {X : setwithbinop} (R : hrel X) (is : iscomm (@op X)) (isl : ∏ a b c : X, R a b -> R (op c a) (op c b)) : isbinophrel R. Proof. split with isl. intros a b c rab. destruct (is c a). destruct (is c b). apply (isl _ _ _ rab). Defined. Lemma iscompbinoptransrel {X : setwithbinop} (R : hrel X) (ist : istrans R) (isb : isbinophrel R) : iscomprelrelfun2 R R (@op X). Proof. intros a b c d. intros rab rcd. set (racbc := pr2 isb a b c rab). set (rbcbd := pr1 isb c d b rcd). apply (ist _ _ _ racbc rbcbd). Defined. Lemma isbinopreflrel {X : setwithbinop} (R : hrel X) (isr : isrefl R) (isb : iscomprelrelfun2 R R (@op X)) : isbinophrel R. Proof. split. - intros a b c rab. apply (isb c c a b (isr c) rab). - intros a b c rab. apply (isb a b c c rab (isr c)). Defined. Definition binophrel (X : setwithbinop) : UU := total2 (λ R : hrel X, isbinophrel R). Definition make_binophrel {X : setwithbinop} : ∏ (t : hrel X), (λ R : hrel X, isbinophrel R) t → ∑ R : hrel X, isbinophrel R := tpair (λ R : hrel X, isbinophrel R). Definition pr1binophrel (X : setwithbinop) : binophrel X -> hrel X := @pr1 _ (λ R : hrel X, isbinophrel R). Coercion pr1binophrel : binophrel >-> hrel. Definition binophrel_resp_left {X : setwithbinop} (R : binophrel X) {a b : X} (c : X) (r : R a b) : R (op c a) (op c b) := pr1 (pr2 R) a b c r. Definition binophrel_resp_right {X : setwithbinop} (R : binophrel X) {a b : X} (c : X) (r : R a b) : R (op a c) (op b c) := pr2 (pr2 R) a b c r. Definition binoppo (X : setwithbinop) : UU := total2 (λ R : po X, isbinophrel R). Definition make_binoppo {X : setwithbinop} : ∏ (t : po X), (λ R : po X, isbinophrel R) t → ∑ R : po X, isbinophrel R := tpair (λ R : po X, isbinophrel R). Definition pr1binoppo (X : setwithbinop) : binoppo X -> po X := @pr1 _ (λ R : po X, isbinophrel R). Coercion pr1binoppo : binoppo >-> po. Definition binopeqrel (X : setwithbinop) : UU := total2 (λ R : eqrel X, isbinophrel R). Definition make_binopeqrel {X : setwithbinop} : ∏ (t : eqrel X), (λ R : eqrel X, isbinophrel R) t → ∑ R : eqrel X, isbinophrel R := tpair (λ R : eqrel X, isbinophrel R). Definition pr1binopeqrel (X : setwithbinop) : binopeqrel X -> eqrel X := @pr1 _ (λ R : eqrel X, isbinophrel R). Coercion pr1binopeqrel : binopeqrel >-> eqrel. Definition binopeqrel_resp_left {X : setwithbinop} (R : binopeqrel X) {a b : X} (c : X) (r : R a b) : R (op c a) (op c b) := pr1 (pr2 R) a b c r. Definition binopeqrel_resp_right {X : setwithbinop} (R : binopeqrel X) {a b : X} (c : X) (r : R a b) : R (op a c) (op b c) := pr2 (pr2 R) a b c r. Definition setwithbinopquot {X : setwithbinop} (R : binopeqrel X) : setwithbinop. Proof. split with (setquotinset R). set (qt := setquot R). set (qtset := setquotinset R). assert (iscomp : iscomprelrelfun2 R R op) by apply (iscompbinoptransrel R (eqreltrans R) (pr2 R)). set (qtmlt := setquotfun2 R R op iscomp). simpl. unfold binop. apply qtmlt. Defined. Definition ispartbinophrel {X : setwithbinop} (S : hsubtype X) (R : hrel X) : UU := dirprod (∏ a b c : X, S c -> R a b -> R (op c a) (op c b)) (∏ a b c : X, S c -> R a b -> R (op a c) (op b c)). Lemma isaprop_ispartbinophrel {X : setwithbinop} (S : hsubtype X) (R : hrel X) : isaprop (ispartbinophrel S R). Proof. apply isapropdirprod ; apply impred_isaprop ; intros a ; apply impred_isaprop ; intros b ; apply impred_isaprop ; intros c ; apply isapropimpl, isapropimpl, propproperty. Defined. Definition isbinoptoispartbinop {X : setwithbinop} (S : hsubtype X) (L : hrel X) (d2 : isbinophrel L) : ispartbinophrel S L. Proof. unfold isbinophrel in d2. unfold ispartbinophrel. split. - intros a b c is. apply (pr1 d2 a b c). - intros a b c is. apply (pr2 d2 a b c). Defined. Definition ispartbinophrellogeqf {X : setwithbinop} (S : hsubtype X) {L R : hrel X} (lg : hrellogeq L R) (isl : ispartbinophrel S L) : ispartbinophrel S R. Proof. split. - intros a b c is rab. apply ((pr1 (lg _ _) ((pr1 isl) _ _ _ is (pr2 (lg _ _) rab)))). - intros a b c is rab. apply ((pr1 (lg _ _) ((pr2 isl) _ _ _ is (pr2 (lg _ _) rab)))). Defined. Lemma ispartbinophrelif {X : setwithbinop} (S : hsubtype X) (R : hrel X) (is : iscomm (@op X)) (isl : ∏ a b c : X, S c -> R a b -> R (op c a) (op c b)) : ispartbinophrel S R. Proof. split with isl. intros a b c s rab. destruct (is c a). destruct (is c b). apply (isl _ _ _ s rab). Defined. (* The binophrel generated by an arbitrary hrel *) Local Notation "A ⇒ B" := (himpl A B). Definition generated_binophrel_hrel {X : setwithbinop} (R : hrel X) : hrel X := λ x x', ∀(R' : binophrel X), (∏ x₁ x₂, R x₁ x₂ → R' x₁ x₂) ⇒ R' x x'. Lemma isbinophrel_generated_binophrel {X : setwithbinop} (R : hrel X) : isbinophrel (generated_binophrel_hrel R). Proof. split. - intros a b c H R' H2. apply binophrel_resp_left. exact (H R' H2). - intros a b c H R' H2. apply binophrel_resp_right. exact (H R' H2). Defined. Definition generated_binophrel {X : setwithbinop} (R : hrel X) : binophrel X := make_binophrel (generated_binophrel_hrel R) (isbinophrel_generated_binophrel R). Lemma generated_binophrel_intro {X : setwithbinop} {R : hrel X} {x x' : X} (r : R x x') : generated_binophrel R x x'. Proof. intros R' H. exact (H x x' r). Defined. (* The binopeqrel generated by an arbitrary hrel *) Definition generated_binopeqrel_hrel {X : setwithbinop} (R : hrel X) : hrel X := λ x x', ∀(R' : binopeqrel X), (∏ x₁ x₂, R x₁ x₂ → R' x₁ x₂) ⇒ R' x x'. Lemma isbinophrel_generated_binopeqrel {X : setwithbinop} (R : hrel X) : isbinophrel (generated_binopeqrel_hrel R). Proof. split. - intros a b c H R' H2. apply binopeqrel_resp_left. exact (H R' H2). - intros a b c H R' H2. apply binopeqrel_resp_right. exact (H R' H2). Defined. Lemma iseqrel_generated_binopeqrel {X : setwithbinop} (R : hrel X) : iseqrel (generated_binopeqrel_hrel R). Proof. use iseqrelconstr. - intros x1 x2 x3 H1 H2 R' HR. eapply eqreltrans. + exact (H1 R' HR). + exact (H2 R' HR). - intros x R' HR. apply eqrelrefl. - intros x1 x2 H R' HR. apply eqrelsymm. exact (H R' HR). Defined. Definition generated_binopeqrel {X : setwithbinop} (R : hrel X) : binopeqrel X := make_binopeqrel (make_eqrel (generated_binopeqrel_hrel R) (iseqrel_generated_binopeqrel R)) (isbinophrel_generated_binopeqrel R). Lemma generated_binopeqrel_intro {X : setwithbinop} {R : hrel X} {x x' : X} (r : R x x') : generated_binopeqrel R x x'. Proof. intros R' H. exact (H x x' r). Defined. (* A proof that homomorphisms preserve the generated relations if they preserve the original one *) Definition pullback_binopeqrel {X Y : setwithbinop} (f : binopfun X Y) (R : binopeqrel Y) : binopeqrel X. Proof. use make_binopeqrel. - use make_eqrel. + intros x x'. exact (R (f x) (f x')). + apply iseqrelconstr. * intros x1 x2 x3 r1 r2. exact (eqreltrans R _ _ _ r1 r2). * intro x. exact (eqrelrefl R _). * intros x x' r. exact (eqrelsymm R _ _ r). - apply make_isbinophrel; simpl; intros x1 x2 x3 r; rewrite !binopfunisbinopfun. + exact (binopeqrel_resp_left R _ r). + exact (binopeqrel_resp_right R _ r). Defined. Definition pullback_binopeqrel_rev {X Y : setwithbinop} (f : binopfun X (setwithbinop_rev Y)) (R : binopeqrel Y) : binopeqrel X. Proof. apply (pullback_binopeqrel f). use make_binopeqrel. - exact R. - apply make_isbinophrel; intros x1 x2 x3 r; apply (pr2 R); exact r. Defined. Definition binopeqrel_eq (X : setwithbinop) : binopeqrel X. Proof. use make_binopeqrel. - use make_eqrel. + intros x x'. exact (make_hProp (x = x') (pr2 (pr1 X) _ _)). + apply iseqrelconstr. * intros x1 x2 x3 r1 r2. exact (r1 @ r2). * intro x. reflexivity. * intros x x' r. exact (!r). - apply make_isbinophrel; simpl; intros x1 x2 x3 r; rewrite r; reflexivity. Defined. Definition binopeqrel_of_binopfun {X Y : setwithbinop} (f : binopfun X Y) : binopeqrel X := pullback_binopeqrel f (binopeqrel_eq Y). Lemma iscomprelfun_generated_binopeqrel {X Y : setwithbinop} {R : hrel X} (f : binopfun X Y) (H : iscomprelfun R f) : iscomprelfun (generated_binopeqrel R) f. Proof. intros x x' r. exact (r (binopeqrel_of_binopfun f) H). Defined. Lemma iscomprelrelfun_generated_binopeqrel {X Y : setwithbinop} {R : hrel X} {S : hrel Y} (f : binopfun X Y) (H : iscomprelrelfun R S f) : iscomprelrelfun (generated_binopeqrel R) (generated_binopeqrel S) f. Proof. intros x x' r. apply (r (pullback_binopeqrel f (generated_binopeqrel S))). intros x1 x2 r' S' s. use s. apply H. exact r'. Defined. (* It is also true for "contravariant" homomorphisms, where f (x * y) = f y * f x *) Lemma iscomprelrelfun_generated_binopeqrel_rev {X Y : setwithbinop} {R : hrel X} {S : hrel Y} (f : binopfun X (setwithbinop_rev Y)) (H : iscomprelrelfun R S f) : iscomprelrelfun (generated_binopeqrel R) (generated_binopeqrel S) f. Proof. intros x x' r. apply (r (pullback_binopeqrel_rev f (generated_binopeqrel S))). intros x1 x2 r' S' s. use s. apply H. exact r'. Defined. (** **** Relations inversely compatible with a binary operation *) Definition isinvbinophrel {X : setwithbinop} (R : hrel X) : UU := dirprod (∏ a b c : X, R (op c a) (op c b) -> R a b) (∏ a b c : X, R (op a c) (op b c) -> R a b). Definition isinvbinophrellogeqf {X : setwithbinop} {L R : hrel X} (lg : hrellogeq L R) (isl : isinvbinophrel L) : isinvbinophrel R. Proof. split. - intros a b c rab. apply ((pr1 (lg _ _) ((pr1 isl) _ _ _ (pr2 (lg _ _) rab)))). - intros a b c rab. apply ((pr1 (lg _ _) ((pr2 isl) _ _ _ (pr2 (lg _ _) rab)))). Defined. Lemma isapropisinvbinophrel {X : setwithbinop} (R : hrel X) : isaprop (isinvbinophrel R). Proof. apply isapropdirprod. - apply impred. intro a. apply impred. intro b. apply impred. intro c. apply impred. intro r. apply (pr2 (R _ _)). - apply impred. intro a. apply impred. intro b. apply impred. intro c. apply impred. intro r. apply (pr2 (R _ _)). Defined. Lemma isinvbinophrelif {X : setwithbinop} (R : hrel X) (is : iscomm (@op X)) (isl : ∏ a b c : X, R (op c a) (op c b) -> R a b) : isinvbinophrel R. Proof. split with isl. intros a b c rab. destruct (is c a). destruct (is c b). apply (isl _ _ _ rab). Defined. Definition ispartinvbinophrel {X : setwithbinop} (S : hsubtype X) (R : hrel X) : UU := dirprod (∏ a b c : X, S c -> R (op c a) (op c b) -> R a b) (∏ a b c : X, S c -> R (op a c) (op b c) -> R a b). Definition isinvbinoptoispartinvbinop {X : setwithbinop} (S : hsubtype X) (L : hrel X) (d2 : isinvbinophrel L) : ispartinvbinophrel S L. Proof. unfold isinvbinophrel in d2. unfold ispartinvbinophrel. split. - intros a b c s. apply (pr1 d2 a b c). - intros a b c s. apply (pr2 d2 a b c). Defined. Definition ispartinvbinophrellogeqf {X : setwithbinop} (S : hsubtype X) {L R : hrel X} (lg : hrellogeq L R) (isl : ispartinvbinophrel S L) : ispartinvbinophrel S R. Proof. split. - intros a b c s rab. apply ((pr1 (lg _ _) ((pr1 isl) _ _ _ s (pr2 (lg _ _) rab)))). - intros a b c s rab. apply ((pr1 (lg _ _) ((pr2 isl) _ _ _ s (pr2 (lg _ _) rab)))). Defined. Lemma ispartinvbinophrelif {X : setwithbinop} (S : hsubtype X) (R : hrel X) (is : iscomm (@op X)) (isl : ∏ a b c : X, S c -> R (op c a) (op c b) -> R a b) : ispartinvbinophrel S R. Proof. split with isl. intros a b c s rab. destruct (is c a). destruct (is c b). apply (isl _ _ _ s rab). Defined. (** **** Homomorphisms and relations *) Lemma binophrelandfun {X Y : setwithbinop} (f : binopfun X Y) (R : hrel Y) (is : @isbinophrel Y R) : @isbinophrel X (λ x x', R (f x) (f x')). Proof. set (ish := (pr2 f) : ∏ a0 b0, paths (f (op a0 b0)) (op (f a0) (f b0))). split. - intros a b c r. rewrite (ish _ _). rewrite (ish _ _). apply (pr1 is). apply r. - intros a b c r. rewrite (ish _ _). rewrite (ish _ _). apply (pr2 is). apply r. Defined. Lemma ispartbinophrelandfun {X Y : setwithbinop} (f : binopfun X Y) (SX : hsubtype X) (SY : hsubtype Y) (iss : ∏ x : X, (SX x) -> (SY (f x))) (R : hrel Y) (is : @ispartbinophrel Y SY R) : @ispartbinophrel X SX (λ x x', R (f x) (f x')). Proof. set (ish := (pr2 f) : ∏ a0 b0, paths (f (op a0 b0)) (op (f a0) (f b0))). split. - intros a b c s r. rewrite (ish _ _). rewrite (ish _ _). apply ((pr1 is) _ _ _ (iss _ s) r). - intros a b c s r. rewrite (ish _ _). rewrite (ish _ _). apply ((pr2 is) _ _ _ (iss _ s) r). Defined. Lemma invbinophrelandfun {X Y : setwithbinop} (f : binopfun X Y) (R : hrel Y) (is : @isinvbinophrel Y R) : @isinvbinophrel X (λ x x', R (f x) (f x')). Proof. set (ish := (pr2 f) : ∏ a0 b0, paths (f (op a0 b0)) (op (f a0) (f b0))). split. - intros a b c r. rewrite (ish _ _) in r. rewrite (ish _ _) in r. apply ((pr1 is) _ _ _ r). - intros a b c r. rewrite (ish _ _) in r. rewrite (ish _ _) in r. apply ((pr2 is) _ _ _ r). Defined. Lemma ispartinvbinophrelandfun {X Y : setwithbinop} (f : binopfun X Y) (SX : hsubtype X) (SY : hsubtype Y) (iss : ∏ x : X, (SX x) -> (SY (f x))) (R : hrel Y) (is : @ispartinvbinophrel Y SY R) : @ispartinvbinophrel X SX (λ x x', R (f x) (f x')). Proof. set (ish := (pr2 f) : ∏ a0 b0, paths (f (op a0 b0)) (op (f a0) (f b0))). split. - intros a b c s r. rewrite (ish _ _) in r. rewrite (ish _ _) in r. apply ((pr1 is) _ _ _ (iss _ s) r). - intros a b c s r. rewrite (ish _ _) in r. rewrite (ish _ _) in r. apply ((pr2 is) _ _ _ (iss _ s) r). Defined. (** **** Quotient relations *) Lemma isbinopquotrel {X : setwithbinop} (R : binopeqrel X) {L : hrel X} (is : iscomprelrel R L) (isl : isbinophrel L) : @isbinophrel (setwithbinopquot R) (quotrel is). Proof. unfold isbinophrel. split. - assert (int : ∏ (a b c : setwithbinopquot R), isaprop (quotrel is a b -> quotrel is (op c a) (op c b))). { intros a b c. apply impred. intro. apply (pr2 (quotrel is _ _)). } apply (setquotuniv3prop R (λ a b c, make_hProp _ (int a b c))). exact (pr1 isl). - assert (int : ∏ (a b c : setwithbinopquot R), isaprop (quotrel is a b -> quotrel is (op a c) (op b c))). { intros a b c. apply impred. intro. apply (pr2 (quotrel is _ _)). } apply (setquotuniv3prop R (λ a b c, make_hProp _ (int a b c))). exact (pr2 isl). Defined. (** **** Direct products *) Definition setwithbinopdirprod (X Y : setwithbinop) : setwithbinop. Proof. split with (setdirprod X Y). unfold binop. simpl. (* ??? in 8.4-8.5-trunk the following apply generates an error message if the type of xy and xy' is left as _ despite the fact that the type of goal is dirprod X Y -> dirprod X Y ->.. *) apply (λ xy xy' : dirprod X Y, make_dirprod (op (pr1 xy) (pr1 xy')) (op (pr2 xy) (pr2 xy'))). Defined. (** *** Sets with two binary operations *) (** **** General definitions *) Definition setwith2binop : UU := total2 (λ X : hSet, (binop X) × (binop X)). Definition make_setwith2binop (X : hSet) (opps : (binop X) × (binop X)) : setwith2binop := tpair (λ X : hSet, (binop X) × (binop X)) X opps. Definition pr1setwith2binop : setwith2binop -> hSet := @pr1 _ (λ X : hSet, (binop X) × (binop X)). Coercion pr1setwith2binop : setwith2binop >-> hSet. Definition op1 {X : setwith2binop} : binop X := pr1 (pr2 X). Definition op2 {X : setwith2binop} : binop X := pr2 (pr2 X). Definition setwithbinop1 (X : setwith2binop) : setwithbinop := make_setwithbinop (pr1 X) (@op1 X). Definition setwithbinop2 (X : setwith2binop) : setwithbinop := make_setwithbinop (pr1 X) (@op2 X). Declare Scope twobinops_scope. Notation "x + y" := (op1 x y) : twobinops_scope. Notation "x * y" := (op2 x y) : twobinops_scope. Definition isasettwobinoponhSet (X : hSet) : isaset ((binop X) × (binop X)). Proof. use isasetdirprod. - use isasetbinoponhSet. - use isasetbinoponhSet. Defined. Opaque isasettwobinoponhSet. (** **** Functions compatible with a pair of binary operation (homomorphisms) and their properties *) Definition istwobinopfun {X Y : setwith2binop} (f : X -> Y) : UU := dirprod (∏ x x' : X, paths (f (op1 x x')) (op1 (f x) (f x'))) (∏ x x' : X, paths (f (op2 x x')) (op2 (f x) (f x'))). Definition make_istwobinopfun {X Y : setwith2binop} (f : X -> Y) (H1 : ∏ x x' : X, paths (f (op1 x x')) (op1 (f x) (f x'))) (H2 : ∏ x x' : X, paths (f (op2 x x')) (op2 (f x) (f x'))) : istwobinopfun f := make_dirprod H1 H2. Lemma isapropistwobinopfun {X Y : setwith2binop} (f : X -> Y) : isaprop (istwobinopfun f). Proof. apply isofhleveldirprod. - apply impred. intro x. apply impred. intro x'. apply (setproperty Y). - apply impred. intro x. apply impred. intro x'. apply (setproperty Y). Defined. Definition twobinopfun (X Y : setwith2binop) : UU := total2 (fun f : X -> Y => istwobinopfun f). Definition make_twobinopfun {X Y : setwith2binop} (f : X -> Y) (is : istwobinopfun f) : twobinopfun X Y := tpair _ f is. Definition pr1twobinopfun (X Y : setwith2binop) : twobinopfun X Y -> (X -> Y) := @pr1 _ _. Coercion pr1twobinopfun : twobinopfun >-> Funclass. Definition binop1fun {X Y : setwith2binop} (f : twobinopfun X Y) : binopfun (setwithbinop1 X) (setwithbinop1 Y) := @make_binopfun (setwithbinop1 X) (setwithbinop1 Y) (pr1 f) (pr1 (pr2 f)). Definition binop2fun {X Y : setwith2binop} (f : twobinopfun X Y) : binopfun (setwithbinop2 X) (setwithbinop2 Y) := @make_binopfun (setwithbinop2 X) (setwithbinop2 Y) (pr1 f) (pr2 (pr2 f)). Definition twobinopfun_paths {X Y : setwith2binop} (f g : twobinopfun X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropistwobinopfun. Defined. Opaque twobinopfun_paths. Lemma isasettwobinopfun (X Y : setwith2binop) : isaset (twobinopfun X Y). Proof. apply (isasetsubset (pr1twobinopfun X Y)). - change (isofhlevel 2 (X -> Y)). apply impred. intro. apply (setproperty Y). - refine (isinclpr1 _ _). intro. apply isapropistwobinopfun. Defined. Opaque isasettwobinopfun. Lemma istwobinopfuncomp {X Y Z : setwith2binop} (f : twobinopfun X Y) (g : twobinopfun Y Z) : istwobinopfun (funcomp (pr1 f) (pr1 g)). Proof. set (ax1f := pr1 (pr2 f)). set (ax2f := pr2 (pr2 f)). set (ax1g := pr1 (pr2 g)). set (ax2g := pr2 (pr2 g)). split. - intros a b. simpl. rewrite (ax1f a b). rewrite (ax1g (pr1 f a) (pr1 f b)). apply idpath. - intros a b. simpl. rewrite (ax2f a b). rewrite (ax2g (pr1 f a) (pr1 f b)). apply idpath. Defined. Opaque istwobinopfuncomp. Definition twobinopfuncomp {X Y Z : setwith2binop} (f : twobinopfun X Y) (g : twobinopfun Y Z) : twobinopfun X Z := make_twobinopfun (funcomp (pr1 f) (pr1 g)) (istwobinopfuncomp f g). Definition twobinopmono (X Y : setwith2binop) : UU := total2 (λ f : incl X Y, istwobinopfun f). Definition make_twobinopmono {X Y : setwith2binop} (f : incl X Y) (is : istwobinopfun f) : twobinopmono X Y := tpair _ f is. Definition pr1twobinopmono (X Y : setwith2binop) : twobinopmono X Y -> incl X Y := @pr1 _ _. Coercion pr1twobinopmono : twobinopmono >-> incl. Definition twobinopincltotwobinopfun (X Y : setwith2binop) : twobinopmono X Y -> twobinopfun X Y := λ f, make_twobinopfun (pr1 (pr1 f)) (pr2 f). Coercion twobinopincltotwobinopfun : twobinopmono >-> twobinopfun. Definition binop1mono {X Y : setwith2binop} (f : twobinopmono X Y) : binopmono (setwithbinop1 X) (setwithbinop1 Y) := @make_binopmono (setwithbinop1 X) (setwithbinop1 Y) (pr1 f) (pr1 (pr2 f)). Definition binop2mono {X Y : setwith2binop} (f : twobinopmono X Y) : binopmono (setwithbinop2 X) (setwithbinop2 Y) := @make_binopmono (setwithbinop2 X) (setwithbinop2 Y) (pr1 f) (pr2 (pr2 f)). Definition twobinopmonocomp {X Y Z : setwith2binop} (f : twobinopmono X Y) (g : twobinopmono Y Z) : twobinopmono X Z := make_twobinopmono (inclcomp (pr1 f) (pr1 g)) (istwobinopfuncomp f g). Definition twobinopiso (X Y : setwith2binop) : UU := total2 (λ f : X ≃ Y, istwobinopfun f). Definition make_twobinopiso {X Y : setwith2binop} (f : X ≃ Y) (is : istwobinopfun f) : twobinopiso X Y := tpair _ f is. Definition pr1twobinopiso (X Y : setwith2binop) : twobinopiso X Y -> X ≃ Y := @pr1 _ _. Coercion pr1twobinopiso : twobinopiso >-> weq. Definition twobinopisototwobinopmono (X Y : setwith2binop) : twobinopiso X Y -> twobinopmono X Y := λ f, make_twobinopmono (weqtoincl (pr1 f)) (pr2 f). Coercion twobinopisototwobinopmono : twobinopiso >-> twobinopmono. Definition twobinopisototwobinopfun {X Y : setwith2binop} (f : twobinopiso X Y) : twobinopfun X Y := make_twobinopfun f (pr2 f). Lemma twobinopiso_paths {X Y : setwith2binop} (f g : twobinopiso X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropistwobinopfun. Defined. Opaque twobinopiso_paths. Definition binop1iso {X Y : setwith2binop} (f : twobinopiso X Y) : binopiso (setwithbinop1 X) (setwithbinop1 Y) := @make_binopiso (setwithbinop1 X) (setwithbinop1 Y) (pr1 f) (pr1 (pr2 f)). Definition binop2iso {X Y : setwith2binop} (f : twobinopiso X Y) : binopiso (setwithbinop2 X) (setwithbinop2 Y) := @make_binopiso (setwithbinop2 X) (setwithbinop2 Y) (pr1 f) (pr2 (pr2 f)). Definition twobinopisocomp {X Y Z : setwith2binop} (f : twobinopiso X Y) (g : twobinopiso Y Z) : twobinopiso X Z := make_twobinopiso (weqcomp (pr1 f) (pr1 g)) (istwobinopfuncomp f g). Lemma istwobinopfuninvmap {X Y : setwith2binop} (f : twobinopiso X Y) : istwobinopfun (invmap (pr1 f)). Proof. set (ax1f := pr1 (pr2 f)). set (ax2f := pr2 (pr2 f)). split. - intros a b. apply (invmaponpathsweq (pr1 f)). rewrite (homotweqinvweq (pr1 f) (op1 a b)). rewrite (ax1f (invmap (pr1 f) a) (invmap (pr1 f) b)). rewrite (homotweqinvweq (pr1 f) a). rewrite (homotweqinvweq (pr1 f) b). apply idpath. - intros a b. apply (invmaponpathsweq (pr1 f)). rewrite (homotweqinvweq (pr1 f) (op2 a b)). rewrite (ax2f (invmap (pr1 f) a) (invmap (pr1 f) b)). rewrite (homotweqinvweq (pr1 f) a). rewrite (homotweqinvweq (pr1 f) b). apply idpath. Defined. Opaque istwobinopfuninvmap. Definition invtwobinopiso {X Y : setwith2binop} (f : twobinopiso X Y) : twobinopiso Y X := make_twobinopiso (invweq (pr1 f)) (istwobinopfuninvmap f). Definition idtwobinopiso (X : setwith2binop) : twobinopiso X X. Proof. use make_twobinopiso. - use (idweq X). - use make_istwobinopfun. + intros x x'. use idpath. + intros x x'. use idpath. Defined. (** **** X = Y ≃ (X ≃ Y) The idea is to use the composition X = Y ≃ X ╝ Y ≃ (twobinopiso X Y) *) Definition setwith2binop_univalence_weq1 (X Y : setwith2binop) : (X = Y) ≃ (X ╝ Y) := total2_paths_equiv _ X Y. Definition setwith2binop_univalence_weq2 (X Y : setwith2binop) : (X ╝ Y) ≃ (twobinopiso X Y). Proof. use weqbandf. - use hSet_univalence. - intros e. use invweq. induction X as [X Xop]. induction Y as [Y Yop]. cbn in e. induction e. use weqimplimpl. + intros i. use dirprod_paths. * use funextfun. intros x1. use funextfun. intros x2. exact ((dirprod_pr1 i) x1 x2). * use funextfun. intros x1. use funextfun. intros x2. exact ((dirprod_pr2 i) x1 x2). + intros e. cbn in e. use make_istwobinopfun. * intros x1 x2. induction e. use idpath. * intros x1 x2. induction e. use idpath. + use isapropistwobinopfun. + use isasettwobinoponhSet. Defined. Opaque setwith2binop_univalence_weq2. Definition setwith2binop_univalence_map (X Y : setwith2binop) : X = Y -> twobinopiso X Y. Proof. intro e. induction e. exact (idtwobinopiso X). Defined. Lemma setwith2binop_univalence_isweq (X Y : setwith2binop) : isweq (setwith2binop_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (setwith2binop_univalence_weq1 X Y) (setwith2binop_univalence_weq2 X Y)). - intros e. induction e. use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque setwith2binop_univalence_isweq. Definition setwith2binop_univalence (X Y : setwith2binop) : (X = Y) ≃ (twobinopiso X Y). Proof. use make_weq. - exact (setwith2binop_univalence_map X Y). - exact (setwith2binop_univalence_isweq X Y). Defined. Opaque setwith2binop_univalence. (** **** Transport of properties of a pair of binary operations *) Lemma isldistrmonob {X Y : setwith2binop} (f : twobinopmono X Y) (is : isldistr (@op1 Y) (@op2 Y)) : isldistr (@op1 X) (@op2 X). Proof. set (ax1f := pr1 (pr2 f)). set (ax2f := pr2 (pr2 f)). intros a b c. apply (invmaponpathsincl _ (pr2 (pr1 f))). change (paths ((pr1 f) (op2 c (op1 a b))) ((pr1 f) (op1 (op2 c a) (op2 c b)))). rewrite (ax2f c (op1 a b)). rewrite (ax1f a b). rewrite (ax1f (op2 c a) (op2 c b)). rewrite (ax2f c a). rewrite (ax2f c b). apply is. Defined. Opaque isldistrmonob. Lemma isrdistrmonob {X Y : setwith2binop} (f : twobinopmono X Y) (is : isrdistr (@op1 Y) (@op2 Y)) : isrdistr (@op1 X) (@op2 X). Proof. set (ax1f := pr1 (pr2 f)). set (ax2f := pr2 (pr2 f)). intros a b c. apply (invmaponpathsincl _ (pr2 (pr1 f))). change (paths ((pr1 f) (op2 (op1 a b) c)) ((pr1 f) (op1 (op2 a c) (op2 b c)))). rewrite (ax2f (op1 a b) c). rewrite (ax1f a b). rewrite (ax1f (op2 a c) (op2 b c)). rewrite (ax2f a c). rewrite (ax2f b c). apply is. Defined. Opaque isrdistrmonob. Definition isdistrmonob {X Y : setwith2binop} (f : twobinopmono X Y) (is : isdistr (@op1 Y) (@op2 Y)) : isdistr (@op1 X) (@op2 X) := make_dirprod (isldistrmonob f (pr1 is)) (isrdistrmonob f (pr2 is)). Notation isldistrisob := isldistrmonob. Notation isrdistrisob := isrdistrmonob. Notation isdistrisob := isdistrmonob. Lemma isldistrisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : isldistr (@op1 X) (@op2 X)) : isldistr (@op1 Y) (@op2 Y). Proof. apply (isldistrisob (invtwobinopiso f) is). Defined. Lemma isrdistrisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : isrdistr (@op1 X) (@op2 X)) : isrdistr (@op1 Y) (@op2 Y). Proof. apply (isrdistrisob (invtwobinopiso f) is). Defined. Lemma isdistrisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : isdistr (@op1 X) (@op2 X)) : isdistr (@op1 Y) (@op2 Y). Proof. apply (isdistrisob (invtwobinopiso f) is). Defined. Definition isrigopsisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : isrigops (@op1 X) (@op2 X)) : isrigops (@op1 Y) (@op2 Y). Proof. split. - split with (make_dirprod (isabmonoidopisof (binop1iso f) (rigop1axs_is is)) (ismonoidopisof (binop2iso f) (rigop2axs_is is))). simpl. change (unel_is (ismonoidopisof (binop1iso f) (rigop1axs_is is))) with ((pr1 f) (rigunel1_is is)). split. + intro y. rewrite (pathsinv0 (homotweqinvweq f y)). rewrite (pathsinv0 ((pr2 (pr2 f)) _ _)). apply (maponpaths (pr1 f)). apply (rigmult0x_is is). + intro y. rewrite (pathsinv0 (homotweqinvweq f y)). rewrite (pathsinv0 ((pr2 (pr2 f)) _ _)). apply (maponpaths (pr1 f)). apply (rigmultx0_is is). - apply (isdistrisof f). apply (rigdistraxs_is is). Defined. Definition isrigopsisob {X Y : setwith2binop} (f : twobinopiso X Y) (is : isrigops (@op1 Y) (@op2 Y)) : isrigops (@op1 X) (@op2 X). Proof. apply (isrigopsisof (invtwobinopiso f) is). Defined. Definition isringopsisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : isringops (@op1 X) (@op2 X)) : isringops (@op1 Y) (@op2 Y) := make_dirprod (make_dirprod (isabgropisof (binop1iso f) (ringop1axs_is is)) (ismonoidopisof (binop2iso f) (ringop2axs_is is))) (isdistrisof f (pr2 is)). Definition isringopsisob {X Y : setwith2binop} (f : twobinopiso X Y) (is : isringops (@op1 Y) (@op2 Y)) : isringops (@op1 X) (@op2 X) := make_dirprod (make_dirprod (isabgropisob (binop1iso f) (ringop1axs_is is)) (ismonoidopisob (binop2iso f) (ringop2axs_is is))) (isdistrisob f (pr2 is)). Definition iscommringopsisof {X Y : setwith2binop} (f : twobinopiso X Y) (is : iscommringops (@op1 X) (@op2 X)) : iscommringops (@op1 Y) (@op2 Y) := make_dirprod (isringopsisof f is) (iscommisof (binop2iso f) (pr2 is)). Definition iscommringopsisob {X Y : setwith2binop} (f : twobinopiso X Y) (is : iscommringops (@op1 Y) (@op2 Y)) : iscommringops (@op1 X) (@op2 X) := make_dirprod (isringopsisob f is) (iscommisob (binop2iso f) (pr2 is)). (** **** Subobjects *) Definition issubsetwith2binop {X : setwith2binop} (A : hsubtype X) : UU := dirprod (∏ a a' : A, A (op1 (pr1 a) (pr1 a'))) (∏ a a' : A, A (op2 (pr1 a) (pr1 a'))). Lemma isapropissubsetwith2binop {X : setwith2binop} (A : hsubtype X) : isaprop (issubsetwith2binop A). Proof. apply (isofhleveldirprod 1). - apply impred. intro a. apply impred. intros a'. apply (pr2 (A (op1 (pr1 a) (pr1 a')))). - apply impred. intro a. apply impred. intros a'. apply (pr2 (A (op2 (pr1 a) (pr1 a')))). Defined. Definition subsetswith2binop (X : setwith2binop) : UU := total2 (λ A : hsubtype X, issubsetwith2binop A). Definition make_subsetswith2binop {X : setwith2binop} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubsetwith2binop A) t → ∑ A : hsubtype X, issubsetwith2binop A := tpair (λ A : hsubtype X, issubsetwith2binop A). Definition subsetswith2binopconstr {X : setwith2binop} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubsetwith2binop A) t → ∑ A : hsubtype X, issubsetwith2binop A := @make_subsetswith2binop X. Definition pr1subsetswith2binop (X : setwith2binop) : subsetswith2binop X -> hsubtype X := @pr1 _ (λ A : hsubtype X, issubsetwith2binop A). Coercion pr1subsetswith2binop : subsetswith2binop >-> hsubtype. Definition totalsubsetwith2binop (X : setwith2binop) : subsetswith2binop X. Proof. split with (λ x : X, htrue). split. - intros x x'. apply tt. - intros. apply tt. Defined. Definition carrierofsubsetwith2binop {X : setwith2binop} (A : subsetswith2binop X) : setwith2binop. Proof. set (aset := (make_hSet (carrier A) (isasetsubset (pr1carrier A) (setproperty X) (isinclpr1carrier A))) : hSet). split with aset. set (subopp1 := (λ a a' : A, make_carrier A (op1 (pr1carrier _ a) (pr1carrier _ a')) (pr1 (pr2 A) a a')) : (A -> A -> A)). set (subopp2 := (λ a a' : A, make_carrier A (op2 (pr1carrier _ a) (pr1carrier _ a')) (pr2 (pr2 A) a a')) : (A -> A -> A)). simpl. apply (make_dirprod subopp1 subopp2). Defined. Coercion carrierofsubsetwith2binop : subsetswith2binop >-> setwith2binop. (** **** Quotient objects *) Definition is2binophrel {X : setwith2binop} (R : hrel X) : UU := dirprod (@isbinophrel (setwithbinop1 X) R) (@isbinophrel (setwithbinop2 X) R). Lemma isapropis2binophrel {X : setwith2binop} (R : hrel X) : isaprop (is2binophrel R). Proof. apply (isofhleveldirprod 1). - apply isapropisbinophrel. - apply isapropisbinophrel. Defined. Lemma iscomp2binoptransrel {X : setwith2binop} (R : hrel X) (is : istrans R) (isb : is2binophrel R) : dirprod (iscomprelrelfun2 R R (@op1 X)) (iscomprelrelfun2 R R (@op2 X)). Proof. split. - apply (@iscompbinoptransrel (setwithbinop1 X) R is (pr1 isb)). - apply (@iscompbinoptransrel (setwithbinop2 X) R is (pr2 isb)). Defined. Definition twobinophrel (X : setwith2binop) : UU := total2 (λ R : hrel X, is2binophrel R). Definition make_twobinophrel {X : setwith2binop} : ∏ (t : hrel X), (λ R : hrel X, is2binophrel R) t → ∑ R : hrel X, is2binophrel R := tpair (λ R : hrel X, is2binophrel R). Definition pr1twobinophrel (X : setwith2binop) : twobinophrel X -> hrel X := @pr1 _ (λ R : hrel X, is2binophrel R). Coercion pr1twobinophrel : twobinophrel >-> hrel. Definition twobinoppo (X : setwith2binop) : UU := total2 (λ R : po X, is2binophrel R). Definition make_twobinoppo {X : setwith2binop} : ∏ (t : po X), (λ R : po X, is2binophrel R) t → ∑ R : po X, is2binophrel R := tpair (λ R : po X, is2binophrel R). Definition pr1twobinoppo (X : setwith2binop) : twobinoppo X -> po X := @pr1 _ (λ R : po X, is2binophrel R). Coercion pr1twobinoppo : twobinoppo >-> po. Definition twobinopeqrel (X : setwith2binop) : UU := total2 (λ R : eqrel X, is2binophrel R). Definition make_twobinopeqrel {X : setwith2binop} : ∏ (t : eqrel X), (λ R : eqrel X, is2binophrel R) t → ∑ R : eqrel X, is2binophrel R := tpair (λ R : eqrel X, is2binophrel R). Definition pr1twobinopeqrel (X : setwith2binop) : twobinopeqrel X -> eqrel X := @pr1 _ (λ R : eqrel X, is2binophrel R). Coercion pr1twobinopeqrel : twobinopeqrel >-> eqrel. Definition setwith2binopquot {X : setwith2binop} (R : twobinopeqrel X) : setwith2binop. Proof. split with (setquotinset R). set (qt := setquot R). set (qtset := setquotinset R). assert (iscomp1 : iscomprelrelfun2 R R (@op1 X)) by apply (pr1 (iscomp2binoptransrel (pr1 R) (eqreltrans _) (pr2 R))). set (qtop1 := setquotfun2 R R (@op1 X) iscomp1). assert (iscomp2 : iscomprelrelfun2 R R (@op2 X)) by apply (pr2 (iscomp2binoptransrel (pr1 R) (eqreltrans _) (pr2 R))). set (qtop2 := setquotfun2 R R (@op2 X) iscomp2). simpl. apply (make_dirprod qtop1 qtop2). Defined. (** **** Direct products *) Definition setwith2binopdirprod (X Y : setwith2binop) : setwith2binop. Proof. split with (setdirprod X Y). simpl. (* ??? same issue as with setwithbinopdirpro above *) apply (make_dirprod (λ xy xy' : dirprod X Y, make_dirprod (op1 (pr1 xy) (pr1 xy')) (op1 (pr2 xy) (pr2 xy'))) (λ xy xy' : dirprod X Y, make_dirprod (op2 (pr1 xy) (pr1 xy')) (op2 (pr2 xy) (pr2 xy')))). Defined. (** ** Infinitary operations *) (** Limit a more general infinitary operation to a binary operation *) Lemma infinitary_op_to_binop {X : hSet} (op : ∏ I : UU, (I -> X) -> X) : binop X. Proof. intros x y; exact (op _ (bool_rect (fun _ => X) x y)). Defined. (* End of file *) UniMath-20231010/UniMath/Algebra/ConstructiveStructures.v000066400000000000000000000451451451125700300232050ustar00rootroot00000000000000(** * Definition of appartness relationConstructive Algebraic Structures *) (** Catherine Lelay. Sep. 2015 *) Unset Kernel Term Sharing. Require Export UniMath.Algebra.DivisionRig. Require Export UniMath.Algebra.Domains_and_Fields. Require Export UniMath.Algebra.Apartness. Require Import UniMath.MoreFoundations.Tactics. (** ** Predicats in a rig with a tight appartness relation *) Definition isnonzeroCR (X : rig) (R : tightap X) := R 1%rig 0%rig. Definition isConstrDivRig (X : rig) (R : tightap X) := isnonzeroCR X R × (∏ x : X, R x 0%rig -> multinvpair X x). (** ** Constructive rig with division *) Definition ConstructiveDivisionRig := ∑ X : rig, ∑ R : tightap X, isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1 × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2 × isConstrDivRig X R. Definition ConstructiveDivisionRig_rig : ConstructiveDivisionRig -> rig := pr1. Coercion ConstructiveDivisionRig_rig : ConstructiveDivisionRig >-> rig. Definition ConstructiveDivisionRig_apsetwith2binop : ConstructiveDivisionRig -> apsetwith2binop. Proof. intros X. exists (pr1 (pr1 (pr1 X)),,(pr1 (pr2 X))). split. exact (_,,(pr1 (pr2 (pr2 X)))). exact (_,,(pr1 (pr2 (pr2 (pr2 X))))). Defined. Definition CDRap {X : ConstructiveDivisionRig} : hrel X := λ x y : X, (pr1 (pr2 X)) x y. Definition CDRzero {X : ConstructiveDivisionRig} : X := 0%rig. Definition CDRone {X : ConstructiveDivisionRig} : X := 1%rig. Definition CDRplus {X : ConstructiveDivisionRig} : binop X := λ x y : X, op1 (X := ConstructiveDivisionRig_apsetwith2binop X) x y. Definition CDRmult {X : ConstructiveDivisionRig} : binop X := λ x y : X, op2 (X := ConstructiveDivisionRig_apsetwith2binop X) x y. Declare Scope CDR_scope. Delimit Scope CDR_scope with CDR. Local Open Scope CDR_scope. Notation "x ≠ y" := (CDRap x y) (at level 70, no associativity) : CDR_scope. Notation "0" := CDRzero : CDR_scope. Notation "1" := CDRone : CDR_scope. Notation "x + y" := (CDRplus x y) : CDR_scope. Notation "x * y" := (CDRmult x y) : CDR_scope. Definition CDRinv {X : ConstructiveDivisionRig} (x : X) (Hx0 : x ≠ 0) : X := (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0)). Definition CDRdiv {X : ConstructiveDivisionRig} (x y : X) (Hy0 : y ≠ 0) : X := CDRmult x (CDRinv y Hy0). (** Lemmas *) Section CDR_pty. Context {X : ConstructiveDivisionRig}. Lemma isirrefl_CDRap : ∏ x : X, ¬ (x ≠ x). Proof. exact (pr1 (pr1 (pr2 (pr1 (pr2 X))))). Qed. Lemma issymm_CDRap : ∏ x y : X, x ≠ y -> y ≠ x. Proof. exact (pr1 (pr2 (pr1 (pr2 (pr1 (pr2 X)))))). Qed. Lemma iscotrans_CDRap : ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z. Proof. exact (pr2 (pr2 (pr1 (pr2 (pr1 (pr2 X)))))). Qed. Lemma istight_CDRap : ∏ x y : X, ¬ (x ≠ y) -> x = y. Proof. exact (pr2 (pr2 (pr1 (pr2 X)))). Qed. Lemma isnonzeroCDR : (1 : X) ≠ (0 : X). Proof. exact (pr1 (pr2 (pr2 (pr2 (pr2 X))))). Qed. Lemma islunit_CDRzero_CDRplus : ∏ x : X, 0 + x = x. Proof. now apply riglunax1. Qed. Lemma isrunit_CDRzero_CDRplus : ∏ x : X, x + 0 = x. Proof. now apply rigrunax1. Qed. Lemma isassoc_CDRplus : ∏ x y z : X, x + y + z = x + (y + z). Proof. now apply rigassoc1. Qed. Lemma iscomm_CDRplus : ∏ x y : X, x + y = y + x. Proof. now apply rigcomm1. Qed. Lemma islunit_CDRone_CDRmult : ∏ x : X, 1 * x = x. Proof. now apply riglunax2. Qed. Lemma isrunit_CDRone_CDRmult : ∏ x : X, x * 1 = x. Proof. now apply rigrunax2. Qed. Lemma isassoc_CDRmult : ∏ x y z : X, x * y * z = x * (y * z). Proof. now apply rigassoc2. Qed. Lemma islinv_CDRinv : ∏ (x : X) (Hx0 : x ≠ (0 : X)), (CDRinv x Hx0) * x = 1. Proof. intros x Hx0. apply (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0))). Qed. Lemma isrinv_CDRinv : ∏ (x : X) (Hx0 : x ≠ (0 : X)), x * (CDRinv x Hx0) = 1. Proof. intros x Hx0. apply (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0))). Qed. Lemma islabsorb_CDRzero_CDRmult : ∏ x : X, 0 * x = 0. Proof. now apply rigmult0x. Qed. Lemma israbsorb_CDRzero_CDRmult : ∏ x : X, x * 0 = 0. Proof. now apply rigmultx0. Qed. Lemma isldistr_CDRplus_CDRmult : ∏ x y z : X, z * (x + y) = z * x + z * y. Proof. now apply rigdistraxs. Qed. Lemma apCDRplus : ∏ x x' y y' : X, x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (isapbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X)). Qed. Lemma CDRplus_apcompat_l : ∏ x y z : X, y + x ≠ z + x -> y ≠ z. Proof. intros x y z. exact (islapbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X) _ _ _). Qed. Lemma CDRplus_apcompat_r : ∏ x y z : X, x + y ≠ x + z -> y ≠ z. Proof. exact (israpbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X)). Qed. Lemma apCDRmult : ∏ x x' y y' : X, x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (isapbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X)). Qed. Lemma CDRmult_apcompat_l : ∏ x y z : X, y * x ≠ z * x -> y ≠ z. Proof. intros x y z. exact (islapbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X) _ _ _). Qed. Lemma CDRmult_apcompat_l' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x. Proof. intros x y z Hx Hap. refine (CDRmult_apcompat_l (CDRinv x Hx) _ _ _). rewrite !isassoc_CDRmult, isrinv_CDRinv, !isrunit_CDRone_CDRmult. exact Hap. Qed. Lemma CDRmult_apcompat_r : ∏ x y z : X, x * y ≠ x * z -> y ≠ z. Proof. exact (israpbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X)). Qed. Lemma CDRmult_apcompat_r' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z. Proof. intros x y z Hx Hap. refine (CDRmult_apcompat_r (CDRinv x Hx) _ _ _). rewrite <- !isassoc_CDRmult, islinv_CDRinv, !islunit_CDRone_CDRmult. exact Hap. Qed. Lemma CDRmultapCDRzero : ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0. Proof. intros x y Hmult. split. - apply CDRmult_apcompat_l with y. rewrite islabsorb_CDRzero_CDRmult. exact Hmult. - apply CDRmult_apcompat_r with x. rewrite israbsorb_CDRzero_CDRmult. exact Hmult. Qed. Close Scope CDR_scope. End CDR_pty. (** ** Constructive commutative rig with division *) Definition ConstructiveCommutativeDivisionRig := ∑ X : commrig, ∑ R : tightap X, isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1 × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2 × isConstrDivRig X R. Definition ConstructiveCommutativeDivisionRig_commrig : ConstructiveCommutativeDivisionRig -> commrig := pr1. Coercion ConstructiveCommutativeDivisionRig_commrig : ConstructiveCommutativeDivisionRig >-> commrig. Definition ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig : ConstructiveCommutativeDivisionRig -> ConstructiveDivisionRig := λ X, (pr1 (pr1 X),,pr1 (pr2 (pr1 X))) ,, (pr2 X). Coercion ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig : ConstructiveCommutativeDivisionRig >-> ConstructiveDivisionRig. Definition CCDRap {X : ConstructiveCommutativeDivisionRig} : hrel X := λ x y : X, CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y. Definition CCDRzero {X : ConstructiveCommutativeDivisionRig} : X := 0%rig. Definition CCDRone {X : ConstructiveCommutativeDivisionRig} : X := 1%rig. Definition CCDRplus {X : ConstructiveCommutativeDivisionRig} : binop X := λ x y : X, CDRplus (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y. Definition CCDRmult {X : ConstructiveCommutativeDivisionRig} : binop X := λ x y : X, CDRmult (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y. Declare Scope CCDR_scope. Delimit Scope CCDR_scope with CCDR. Local Open Scope CCDR_scope. Notation "x ≠ y" := (CCDRap x y) (at level 70, no associativity) : CCDR_scope. Notation "0" := CCDRzero : CCDR_scope. Notation "1" := CCDRone : CCDR_scope. Notation "x + y" := (CCDRplus x y) : CCDR_scope. Notation "x * y" := (CCDRmult x y) : CCDR_scope. Definition CCDRinv {X : ConstructiveCommutativeDivisionRig} (x : X) (Hx0 : x ≠ CCDRzero) : X := CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x Hx0. Definition CCDRdiv {X : ConstructiveCommutativeDivisionRig} (x y : X) (Hy0 : y ≠ CCDRzero) : X := CCDRmult x (CCDRinv y Hy0). (** Lemmas *) Section CCDR_pty. Context {X : ConstructiveCommutativeDivisionRig}. Lemma isirrefl_CCDRap : ∏ x : X, ¬ (x ≠ x). Proof. exact (isirrefl_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma issymm_CCDRap : ∏ x y : X, x ≠ y -> y ≠ x. Proof. exact (issymm_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma iscotrans_CCDRap : ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z. Proof. exact (iscotrans_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma istight_CCDRap : ∏ x y : X, ¬ (x ≠ y) -> x = y. Proof. exact (istight_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma isnonzeroCCDR : (1 : X) ≠ (0 : X). Proof. exact isnonzeroCDR. Qed. Lemma islunit_CCDRzero_CCDRplus : ∏ x : X, 0 + x = x. Proof. now apply riglunax1. Qed. Lemma isrunit_CCDRzero_CCDRplus : ∏ x : X, x + 0 = x. Proof. now apply rigrunax1. Qed. Lemma isassoc_CCDRplus : ∏ x y z : X, x + y + z = x + (y + z). Proof. now apply rigassoc1. Qed. Lemma iscomm_CCDRplus : ∏ x y : X, x + y = y + x. Proof. now apply rigcomm1. Qed. Lemma islunit_CCDRone_CCDRmult : ∏ x : X, 1 * x = x. Proof. now apply riglunax2. Qed. Lemma isrunit_CCDRone_CCDRmult : ∏ x : X, x * 1 = x. Proof. now apply rigrunax2. Qed. Lemma isassoc_CCDRmult : ∏ x y z : X, x * y * z = x * (y * z). Proof. now apply rigassoc2. Qed. Lemma iscomm_CCDRmult : ∏ x y : X, x * y = y * x. Proof. now apply rigcomm2. Qed. Lemma islinv_CCDRinv : ∏ (x : X) (Hx0 : x ≠ (0 : X)), (CDRinv (X := X) x Hx0) * x = 1. Proof. exact (islinv_CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma isrinv_CCDRinv : ∏ (x : X) (Hx0 : x ≠ (0 : X)), x * (CDRinv (X := X) x Hx0) = 1. Proof. exact (isrinv_CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma islabsorb_CCDRzero_CCDRmult : ∏ x : X, 0 * x = 0. Proof. now apply rigmult0x. Qed. Lemma israbsorb_CCDRzero_CCDRmult : ∏ x : X, x * 0 = 0. Proof. now apply rigmultx0. Qed. Lemma isldistr_CCDRplus_CCDRmult : ∏ x y z : X, z * (x + y) = z * x + z * y. Proof. now apply rigdistraxs. Qed. Lemma isrdistr_CCDRplus_CCDRmult : ∏ x y z : X, (x + y) * z = x * z + y * z. Proof. intros x y z. rewrite !(iscomm_CCDRmult _ z). now apply rigdistraxs. Qed. Lemma apCCDRplus : ∏ x x' y y' : X, x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (apCDRplus (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRplus_apcompat_l : ∏ x y z : X, y + x ≠ z + x -> y ≠ z. Proof. exact (CDRplus_apcompat_l (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRplus_apcompat_r : ∏ x y z : X, x + y ≠ x + z -> y ≠ z. Proof. exact (CDRplus_apcompat_r (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma apCCDRmult : ∏ x x' y y' : X, x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (apCDRmult (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRmult_apcompat_l : ∏ x y z : X, y * x ≠ z * x -> y ≠ z. Proof. exact (CDRmult_apcompat_l (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRmult_apcompat_l' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x. Proof. exact (CDRmult_apcompat_l' (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRmult_apcompat_r : ∏ x y z : X, x * y ≠ x * z -> y ≠ z. Proof. exact (CDRmult_apcompat_r (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRmult_apcompat_r' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z. Proof. exact (CDRmult_apcompat_r' (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Lemma CCDRmultapCCDRzero : ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0. Proof. exact (CDRmultapCDRzero (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)). Qed. Close Scope CCDR_scope. End CCDR_pty. (** ** Constructive Field *) Definition ConstructiveField := ∑ X : commring, ∑ R : tightap X, isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1 × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2 × isConstrDivRig X R. Definition ConstructiveField_commring : ConstructiveField -> commring := pr1. Coercion ConstructiveField_commring : ConstructiveField >-> commring. Definition ConstructiveField_ConstructiveCommutativeDivisionRig : ConstructiveField -> ConstructiveCommutativeDivisionRig := λ X, (commringtocommrig (pr1 X)) ,, (pr2 X). Coercion ConstructiveField_ConstructiveCommutativeDivisionRig : ConstructiveField >-> ConstructiveCommutativeDivisionRig. Definition CFap {X : ConstructiveField} : hrel X := λ x y : X, CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y. Definition CFzero {X : ConstructiveField} : X := 0%ring. Definition CFone {X : ConstructiveField} : X := 1%ring. Definition CFplus {X : ConstructiveField} : binop X := λ x y : X, CCDRplus (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y. Definition CFopp {X : ConstructiveField} : unop X := λ x : X, (- x)%ring. Definition CFminus {X : ConstructiveField} : binop X := λ x y : X, CFplus x (CFopp y). Definition CFmult {X : ConstructiveField} : binop X := λ x y : X, CCDRmult (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y. Declare Scope CF_scope. Delimit Scope CF_scope with CF. Local Open Scope CF_scope. Notation "x ≠ y" := (CFap x y) (at level 70, no associativity) : CF_scope. Notation "0" := CFzero : CF_scope. Notation "1" := CFone : CF_scope. Notation "x + y" := (CFplus x y) : CF_scope. Notation "- x" := (CFopp x) : CF_scope. Notation "x - y" := (CFminus x y) : CF_scope. Notation "x * y" := (CFmult x y) : CF_scope. Definition CFinv {X : ConstructiveField} (x : X) (Hx0 : x ≠ CFzero) : X := CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x Hx0. Definition CFdiv {X : ConstructiveField} (x y : X) (Hy0 : y ≠ CFzero) : X := CFmult x (CFinv y Hy0). (** Lemmas *) Section CF_pty. Context {X : ConstructiveField}. Lemma isirrefl_CFap : ∏ x : X, ¬ (x ≠ x). Proof. exact (isirrefl_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma issymm_CFap : ∏ x y : X, x ≠ y -> y ≠ x. Proof. exact (issymm_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma iscotrans_CFap : ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z. Proof. exact (iscotrans_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma istight_CFap : ∏ x y : X, ¬ (x ≠ y) -> x = y. Proof. exact (istight_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma isnonzeroCF : (1 : X) ≠ (0 : X). Proof. exact (isnonzeroCCDR (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma islunit_CFzero_CFplus : ∏ x : X, 0 + x = x. Proof. now apply ringlunax1. Qed. Lemma isrunit_CFzero_CFplus : ∏ x : X, x + 0 = x. Proof. now apply ringrunax1. Qed. Lemma isassoc_CFplus : ∏ x y z : X, x + y + z = x + (y + z). Proof. now apply ringassoc1. Qed. Lemma islinv_CFopp : ∏ x : X, - x + x = 0. Proof. now apply ringlinvax1. Qed. Lemma isrinv_CFopp : ∏ x : X, x + - x = 0. Proof. now apply ringrinvax1. Qed. Lemma iscomm_CFplus : ∏ x y : X, x + y = y + x. Proof. now apply ringcomm1. Qed. Lemma islunit_CFone_CFmult : ∏ x : X, 1 * x = x. Proof. now apply ringlunax2. Qed. Lemma isrunit_CFone_CFmult : ∏ x : X, x * 1 = x. Proof. now apply ringrunax2. Qed. Lemma isassoc_CFmult : ∏ x y z : X, x * y * z = x * (y * z). Proof. now apply ringassoc2. Qed. Lemma iscomm_CFmult : ∏ x y : X, x * y = y * x. Proof. now apply ringcomm2. Qed. Lemma islinv_CFinv : ∏ (x : X) (Hx0 : x ≠ 0), (CFinv x Hx0) * x = 1. Proof. exact (islinv_CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma isrinv_CFinv : ∏ (x : X) (Hx0 : x ≠ 0), x * (CFinv x Hx0) = 1. Proof. exact (isrinv_CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma islabsorb_CFzero_CFmult : ∏ x : X, 0 * x = 0. Proof. now apply ringmult0x. Qed. Lemma israbsorb_CFzero_CFmult : ∏ x : X, x * 0 = 0. Proof. now apply ringmultx0. Qed. Lemma isldistr_CFplus_CFmult : ∏ x y z : X, z * (x + y) = z * x + z * y. Proof. now apply ringdistraxs. Qed. Lemma isrdistr_CFplus_CFmult : ∏ x y z : X, (x + y) * z = x * z + y * z. Proof. intros. rewrite !(iscomm_CFmult _ z). now apply isldistr_CFplus_CFmult. Qed. Lemma apCFplus : ∏ x x' y y' : X, x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (apCCDRplus (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFplus_apcompat_l : ∏ x y z : X, y + x ≠ z + x <-> y ≠ z. Proof. intros x y z. split. - exact (CCDRplus_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) _ _ _). - intros Hap. apply (CCDRplus_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) (- x)). change ((y + x) + - x ≠ (z + x) + - x). rewrite !isassoc_CFplus, isrinv_CFopp, !isrunit_CFzero_CFplus. exact Hap. Qed. Lemma CFplus_apcompat_r : ∏ x y z : X, x + y ≠ x + z <-> y ≠ z. Proof. intros x y z. rewrite !(iscomm_CFplus x). now apply CFplus_apcompat_l. Qed. Lemma apCFmult : ∏ x x' y y' : X, x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'. Proof. exact (apCCDRmult (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFmult_apcompat_l : ∏ x y z : X, y * x ≠ z * x -> y ≠ z. Proof. exact (CCDRmult_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFmult_apcompat_l' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x. Proof. exact (CCDRmult_apcompat_l' (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFmult_apcompat_r : ∏ x y z : X, x * y ≠ x * z -> y ≠ z. Proof. exact (CCDRmult_apcompat_r (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFmult_apcompat_r' : ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z. Proof. exact (CCDRmult_apcompat_r' (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. Lemma CFmultapCFzero : ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0. Proof. exact (CCDRmultapCCDRzero (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)). Qed. End CF_pty. Close Scope CF_scope. UniMath-20231010/UniMath/Algebra/DivisionRig.v000066400000000000000000000153221451125700300206310ustar00rootroot00000000000000(** * Division Rig *) (** Definition of an algebraic structure (F,0,1,+,*,/) where: - (F,0,+,* ) is a commutative - / is a multiplicative inverse - * distribute over + on both sides *) (** Examples of such structure : non-negative rationnal numbers, non-negative real numbers *) (** Catherine Lelay. Sep. 2015 *) Unset Kernel Term Sharing. Require Export UniMath.Foundations.Sets. Require Export UniMath.Algebra.RigsAndRings. Require Export UniMath.Algebra.Domains_and_Fields. Require Import UniMath.MoreFoundations.Tactics. (** ** Definition of a DivRig *) Definition isnonzerorig (X : rig) : UU := (1%rig : X) != 0%rig. Definition isDivRig (X : rig) : UU := isnonzerorig X × (∏ x : X, x != 0%rig -> multinvpair X x). Lemma isaprop_isDivRig (X : rig) : isaprop (isDivRig X). Proof. apply isofhleveldirprod. - now apply isapropneg. - apply impred_isaprop ; intro. apply isapropimpl. now apply isapropinvpair. Qed. Definition isDivRig_zero {X : rig} (is : isDivRig X) : X := 0%rig. Definition isDivRig_one {X : rig} (is : isDivRig X) : X := 1%rig. Definition isDivRig_plus {X : rig} (is : isDivRig X) : binop X := λ x y : X, (x + y)%rig. Definition isDivRig_mult {X : rig} (is : isDivRig X) : binop X := λ x y : X, (x * y)%rig. Definition isDivRig_inv {X : rig} (is : isDivRig X) : (∑ x : X, x != isDivRig_zero is) -> X := λ x, pr1 ((pr2 is) (pr1 x) (pr2 x)). Definition isDivRig_isassoc_plus {X : rig} (is : isDivRig X) : isassoc (isDivRig_plus is) := rigassoc1 X. Definition isDivRig_islunit_x0 {X : rig} (is : isDivRig X) : islunit (isDivRig_plus is) (isDivRig_zero is) := riglunax1 X. Definition isDivRig_isrunit_x0 {X : rig} (is : isDivRig X) : isrunit (isDivRig_plus is) (isDivRig_zero is) := rigrunax1 X. Definition isDivRig_iscomm_plus {X : rig} (is : isDivRig X) : iscomm (isDivRig_plus is) := rigcomm1 X. Definition isDivRig_isassoc_mult {X : rig} (is : isDivRig X) : isassoc (isDivRig_mult is) := rigassoc2 X. Definition isDivRig_islunit_x1 {X : rig} (is : isDivRig X) : islunit (isDivRig_mult is) (isDivRig_one is) := riglunax2 X. Definition isDivRig_isrunit_x1 {X : rig} (is : isDivRig X) : isrunit (isDivRig_mult is) (isDivRig_one is) := rigrunax2 X. Definition isDivRig_islinv {X : rig} (is : isDivRig X) : ∏ (x : X) (Hx : x != isDivRig_zero is), isDivRig_mult is (isDivRig_inv is (x,, Hx)) x = isDivRig_one is := λ (x : X) (Hx : x != isDivRig_zero is), pr1 (pr2 (pr2 is x Hx)). Definition isDivRig_isrinv {X : rig} (is : isDivRig X) : ∏ (x : X) (Hx : x != isDivRig_zero is), isDivRig_mult is x (isDivRig_inv is (x,, Hx)) = isDivRig_one is := λ (x : X) (Hx : x != isDivRig_zero is), pr2 (pr2 (pr2 is x Hx)). Definition isDivRig_isldistr {X : rig} (is : isDivRig X) : isldistr (isDivRig_plus is) (isDivRig_mult is) := rigldistr X. Definition isDivRig_isrdistr {X : rig} (is : isDivRig X) : isrdistr (isDivRig_plus is) (isDivRig_mult is) := rigrdistr X. (** DivRig *) Definition DivRig : UU := ∑ (X : rig), isDivRig X. Definition pr1DivRig (F : DivRig) : hSet := pr1 F. Coercion pr1DivRig : DivRig >-> hSet. Definition zeroDivRig {F : DivRig} : F := isDivRig_zero (pr2 F). Definition oneDivRig {F : DivRig} : F := isDivRig_one (pr2 F). Definition plusDivRig {F : DivRig} : binop F := isDivRig_plus (pr2 F). Definition multDivRig {F : DivRig} : binop F := isDivRig_mult (pr2 F). Definition invDivRig {F : DivRig} : (∑ x : F, x != zeroDivRig) -> F := isDivRig_inv (pr2 F). Definition divDivRig {F : DivRig} : F -> (∑ x : F, x != zeroDivRig) -> F := λ x y, multDivRig x (invDivRig y). Definition DivRig_isDivRig (F : DivRig) : isDivRig (pr1 F) := (pr2 F). Definition isDivRig_DivRig {X : rig} : isDivRig X -> DivRig := λ is : isDivRig X, X ,, is. Declare Scope dr_scope. Delimit Scope dr_scope with dr. Local Open Scope dr_scope. Notation "0" := zeroDivRig : dr_scope. Notation "1" := oneDivRig : dr_scope. Notation "x + y" := (plusDivRig x y) : dr_scope. Notation "x * y" := (multDivRig x y) : dr_scope. Notation "/ x" := (invDivRig x) : dr_scope. Notation "x / y" := (divDivRig x y) : dr_scope. Section DivRig_pty. Context {F : DivRig}. Definition DivRig_isassoc_plus: ∏ x y z : F, x + y + z = x + (y + z) := isDivRig_isassoc_plus (DivRig_isDivRig F). Definition DivRig_islunit_zero: ∏ x : F, 0 + x = x := isDivRig_islunit_x0 (DivRig_isDivRig F). Definition DivRig_isrunit_zero: ∏ x : F, x + 0 = x := isDivRig_isrunit_x0 (DivRig_isDivRig F). Definition DivRig_iscomm_plus: ∏ x y : F, x + y = y + x := isDivRig_iscomm_plus (DivRig_isDivRig F). Definition DivRig_isassoc_mult: ∏ x y z : F, x * y * z = x * (y * z) := isDivRig_isassoc_mult (DivRig_isDivRig F). Definition DivRig_islunit_one: ∏ x : F, 1 * x = x := isDivRig_islunit_x1 (DivRig_isDivRig F). Definition DivRig_isrunit_one: ∏ x : F, x * 1 = x := isDivRig_isrunit_x1 (DivRig_isDivRig F). Definition DivRig_islinv: ∏ (x : F) (Hx : x != 0), / (x,, Hx) * x = 1 := isDivRig_islinv (DivRig_isDivRig F). Definition DivRig_isrinv: ∏ (x : F) (Hx : x != 0), x * / (x,, Hx) = 1 := isDivRig_isrinv (DivRig_isDivRig F). Definition DivRig_isldistr: ∏ x y z : F, z * (x + y) = z * x + z * y := isDivRig_isldistr (DivRig_isDivRig F). Definition DivRig_isrdistr: ∏ x y z : F, (x + y) * z = x * z + y * z := isDivRig_isrdistr (DivRig_isDivRig F). End DivRig_pty. (** ** Definition of a Commutative DivRig *) Definition CommDivRig : UU := ∑ (X : commrig), isDivRig X. Definition CommDivRig_DivRig (F : CommDivRig) : DivRig := commrigtorig (pr1 F) ,, pr2 F. Coercion CommDivRig_DivRig : CommDivRig >-> DivRig. Section CommDivRig_pty. Local Open Scope dr_scope. Context {F : CommDivRig}. Definition CommDivRig_isassoc_plus: ∏ x y z : F, x + y + z = x + (y + z) := DivRig_isassoc_plus. Definition CommDivRig_islunit_zero: ∏ x : F, 0 + x = x := DivRig_islunit_zero. Definition CommDivRig_isrunit_zero: ∏ x : F, x + 0 = x := DivRig_isrunit_zero. Definition CommDivRig_iscomm_plus: ∏ x y : F, x + y = y + x := DivRig_iscomm_plus. Definition CommDivRig_isassoc_mult: ∏ x y z : F, x * y * z = x * (y * z) := DivRig_isassoc_mult. Definition CommDivRig_islunit_one: ∏ x : F, 1 * x = x := DivRig_islunit_one. Definition CommDivRig_isrunit_one: ∏ x : F, x * 1 = x := DivRig_isrunit_one. Definition CommDivRig_iscomm_mult: ∏ x y : F, x * y = y * x := rigcomm2 (pr1 F). Definition CommDivRig_islinv: ∏ (x : F) (Hx : x != 0), / (x,, Hx) * x = 1 := DivRig_islinv. Definition CommDivRig_isrinv: ∏ (x : F) (Hx : x != 0), x * / (x,, Hx) = 1 := DivRig_isrinv. Definition CommDivRig_isldistr: ∏ x y z : F, z * (x + y) = z * x + z * y := DivRig_isldistr. Definition CommDivRig_isrdistr: ∏ x y z : F, (x + y) * z = x * z + y * z := DivRig_isrdistr. Close Scope dr_scope. End CommDivRig_pty. UniMath-20231010/UniMath/Algebra/Domains_and_Fields.v000066400000000000000000001305671451125700300221160ustar00rootroot00000000000000(** * Algebra I. Part E. Integral domains and fields. Vladimir Voevodsky. Aug. 2011 - . *) Require Import UniMath.Algebra.Groups. (** ** Contents - Integral domains and fields - Integral domains - General definitions - Computation lemmas for integral domains - Multiplicative submonoid of non-zero elements - Relations similar to "greater" on integral domains - Fields - Main definitions - Field of fractions of an integral domain with decidable equality - Canonical homomorphism to the field of fractions - Relations similar to "greater" on field of fractions - Description of the field of fractions as the ring of fractions with respect to the submonoid of "positive" elements - Definition and properties of "greater" on the field of fractions - Relations and the canonical homomorphism to the field of fractions *) Local Open Scope logic. (** ** Preamble *) (** Settings *) Unset Kernel Term Sharing. (** Imports *) Require Export UniMath.Algebra.RigsAndRings. (** To upstream files *) (** To one binary operation *) Lemma islcancelableif {X : hSet} (opp : binop X) (x : X) (is : ∏ a b : X, paths (opp x a) (opp x b) -> a = b) : islcancelable opp x. Proof. intros. apply isinclbetweensets. - apply (setproperty X). - apply (setproperty X). - apply is. Defined. Lemma isrcancelableif {X : hSet} (opp : binop X) (x : X) (is : ∏ a b : X, paths (opp a x) (opp b x) -> a = b) : isrcancelable opp x. Proof. intros. apply isinclbetweensets. - apply (setproperty X). - apply (setproperty X). - apply is. Defined. Definition iscancelableif {X : hSet} (opp : binop X) (x : X) (isl : ∏ a b : X, paths (opp x a) (opp x b) -> a = b) (isr : ∏ a b : X, paths (opp a x) (opp b x) -> a = b) : iscancelable opp x := make_dirprod (islcancelableif opp x isl) (isrcancelableif opp x isr). (** To monoids *) (** TODO: this has now been upstreamed to BinaryOperations.v, these should be expunged. *) Local Open Scope multmonoid_scope. Definition linvpair (X : monoid) (x : X) : UU := total2 (λ x' : X, paths (x' * x) 1). Definition pr1linvpair (X : monoid) (x : X) : linvpair X x -> X := @pr1 _ _. Definition linvpairxy (X : monoid) (x y : X) (x' : linvpair X x) (y' : linvpair X y) : linvpair X (x * y). Proof. intros. split with ((pr1 y') * (pr1 x')). rewrite (assocax _ _ _ (x * y)). rewrite (pathsinv0 (assocax _ _ x y)). rewrite (pr2 x'). rewrite (lunax _ y). rewrite (pr2 y'). apply idpath. Defined. Definition lcanfromlinv (X : monoid) (a b c : X) (c' : linvpair X c) (e : paths (c * a) (c * b)) : a = b. Proof. intros. set (e' := maponpaths (λ x : X, (pr1 c') * x) e). simpl in e'. rewrite (pathsinv0 (assocax X _ _ _)) in e'. rewrite (pathsinv0 (assocax X _ _ _)) in e'. rewrite (pr2 c') in e'. rewrite (lunax X a) in e'. rewrite (lunax X b) in e'. apply e'. Defined. Definition rinvpair (X : monoid) (x : X) : UU := total2 (λ x' : X, paths (x * x') 1). Definition pr1rinvpair (X : monoid) (x : X) : rinvpair X x -> X := @pr1 _ _. Definition rinvpairxy (X : monoid) (x y : X) (x' : rinvpair X x) (y' : rinvpair X y) : rinvpair X (x * y). Proof. intros. split with ((pr1 y') * (pr1 x')). rewrite (assocax _ x y _). rewrite (pathsinv0 (assocax _ y _ _)). rewrite (pr2 y'). rewrite (lunax _ _). rewrite (pr2 x'). apply idpath. Defined. Definition rcanfromrinv (X : monoid) (a b c : X) (c' : rinvpair X c) (e : paths (a * c ) (b * c)) : a = b. Proof. intros. set (e' := maponpaths (λ x : X, x * (pr1 c')) e). simpl in e'. rewrite (assocax X _ _ _) in e'. rewrite (assocax X _ _ _) in e'. rewrite (pr2 c') in e'. rewrite (runax X a) in e'. rewrite (runax X b) in e'. apply e'. Defined. Lemma pathslinvtorinv (X : monoid) (x : X) (x' : linvpair X x) (x'' : rinvpair X x) : paths (pr1 x') (pr1 x''). Proof. intros. destruct (runax X (pr1 x')). (*unfold p.*) destruct (pr2 x''). set (int := x * pr1 x''). rewrite <- (lunax X (pr1 x'')). destruct (pr2 x'). (*unfold p1.*) unfold int. apply (pathsinv0 (assocax X _ _ _)). Defined. Definition invpair (X : monoid) (x : X) : UU := total2 (λ x' : X, dirprod (paths (x' * x) 1) (paths (x * x') 1)). Definition pr1invpair (X : monoid) (x : X) : invpair X x -> X := @pr1 _ _. Definition invtolinv (X : monoid) (x : X) (x' : invpair X x) : linvpair X x := tpair _ (pr1 x') (pr1 (pr2 x')). Definition invtorinv (X : monoid) (x : X) (x' : invpair X x) : rinvpair X x := tpair _ (pr1 x') (pr2 (pr2 x')). Lemma isapropinvpair (X : monoid) (x : X) : isaprop (invpair X x). Proof. intros. apply invproofirrelevance. intros x' x''. apply (invmaponpathsincl _ (isinclpr1 _ (λ a, isapropdirprod _ _ (setproperty X _ _) (setproperty X _ _)))). apply (pathslinvtorinv X x (invtolinv X x x') (invtorinv X x x'')). Defined. Definition invpairxy (X : monoid) (x y : X) (x' : invpair X x) (y' : invpair X y) : invpair X (x * y). Proof. intros. split with ((pr1 y') * (pr1 x')). split. - apply (pr2 (linvpairxy _ x y (invtolinv _ x x') (invtolinv _ y y'))). - apply (pr2 (rinvpairxy _ x y (invtorinv _ x x') (invtorinv _ y y'))). Defined. (** To groups *) Lemma grfrompathsxy (X : gr) {a b : X} (e : a = b) : paths (op a (grinv X b)) (unel X). Proof. intros. set (e' := maponpaths (λ x : X, op x (grinv X b)) e). simpl in e'. rewrite (grrinvax X _) in e'. apply e'. Defined. Lemma grtopathsxy (X : gr) {a b : X} (e : paths (op a (grinv X b)) (unel X) ) : a = b . Proof. intros. set (e' := maponpaths (λ x, op x b) e). simpl in e'. rewrite (assocax X) in e'. rewrite (grlinvax X) in e'. rewrite (lunax X) in e'. rewrite (runax X) in e'. apply e'. Defined. (** To rigs *) Definition multlinvpair (X : rig) (x : X) : UU := linvpair (rigmultmonoid X) x. Definition multrinvpair (X : rig) (x : X) : UU := rinvpair (rigmultmonoid X) x. Definition multinvpair (X : rig) (x : X) : UU := invpair (rigmultmonoid X) x. Definition rigneq0andmultlinv (X : rig) (n m : X) (isnm : ((n * m) != 0)%rig) : n != 0%rig. Proof. intros. intro e. rewrite e in isnm. rewrite (rigmult0x X) in isnm. destruct (isnm (idpath _)). Defined. Definition rigneq0andmultrinv (X : rig) (n m : X) (isnm : ((n * m) != 0)%rig) : m != 0%rig. Proof. intros. intro e. rewrite e in isnm. rewrite (rigmultx0 _) in isnm. destruct (isnm (idpath _)). Defined. (** To rings *) Local Open Scope ring_scope. Definition ringneq0andmultlinv (X : ring) (n m : X) (isnm : ((n * m) != 0)) : n != 0. Proof. intros. intro e. rewrite e in isnm. rewrite (ringmult0x X) in isnm. destruct (isnm (idpath _)). Defined. Definition ringneq0andmultrinv (X : ring) (n m : X) (isnm : ((n * m) != 0)) : m != 0. Proof. intros. intro e. rewrite e in isnm. rewrite (ringmultx0 _) in isnm. destruct (isnm (idpath _)). Defined. Definition ringpossubmonoid (X : ring) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) : @submonoid (ringmultmonoid X). Proof. intros. split with (λ x, R x 0). split. - intros x1 x2. apply is1. apply (pr2 x1). apply (pr2 x2). - apply is2. Defined. Lemma isinvringmultgtif (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (nc : neqchoice R) (isa : isasymm R) : isinvringmultgt X R. Proof. intros. split. - intros a b rab0 ra0. assert (int : b != 0). { intro e. rewrite e in rab0. rewrite (ringmultx0 X _) in rab0. apply (isa _ _ rab0 rab0). } destruct (nc _ _ int) as [ g | l ]. + apply g. + set (int' := ringmultgt0lt0 X is0 is1 ra0 l). destruct (isa _ _ rab0 int'). - intros a b rab0 rb0. assert (int : a != 0). { intro e. rewrite e in rab0. rewrite (ringmult0x X _) in rab0. apply (isa _ _ rab0 rab0). } destruct (nc _ _ int) as [ g | l ]. + apply g. + set (int' := ringmultlt0gt0 X is0 is1 l rb0). destruct (isa _ _ rab0 int'). Defined. (** ** Standard Algebraic Structures (cont.) Integral domains and Fileds. Some of the notions considered in this section were introduced in C. Mulvey "Intuitionistic algebra and representations of rings". See also P.T. Johnstone "Rings, fields and spectra". We only consider here the strongest ("geometric") forms of the conditions of integrality and of being a field. In particular all our fileds have decidable equality and p-adic numbers or reals are not fileds in the sense of the definitions considered here. *) Local Open Scope ring_scope. (** *** Integral domains *) (** **** General definitions *) Lemma isnonzerolinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multlinvpair X x) : ((pr1 x') != 0). Proof. intros. apply (negf (maponpaths (λ a : X, a * x))). assert (e := pr2 x'). change (paths (pr1 x' * x) 1) in e. change (neg (paths (pr1 x' * x) (0 * x))). rewrite e. rewrite (ringmult0x X _). apply is. Defined. Lemma isnonzerorinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multrinvpair X x) : ((pr1 x') != 0). Proof. intros. apply (negf (maponpaths (λ a : X, x * a))). assert (e := pr2 x'). change (paths (x * pr1 x') 1) in e. change (neg (paths (x * pr1 x') (x * 0))). rewrite e. rewrite (ringmultx0 X _). apply is. Defined. Lemma isnonzerofromlinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multlinvpair X x) : x != 0. Proof. intros. apply (negf (maponpaths (λ a : X, (pr1 x') * a))). assert (e := pr2 x'). change (paths (pr1 x' * x) 1) in e. change (neg (paths (pr1 x' * x) ((pr1 x') * 0))). rewrite e. rewrite (ringmultx0 X _). apply is. Defined. Lemma isnonzerofromrinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multrinvpair X x) : x != 0. Proof. intros. apply (negf (maponpaths (λ a : X, a * (pr1 x')))). assert (e := pr2 x'). change (paths (x * pr1 x') 1) in e. change (neg (paths (x * pr1 x') (0 * (pr1 x')))). rewrite e. rewrite (ringmult0x X _). apply is. Defined. Definition isintdom (X : commring) : UU := dirprod (isnonzerorig X) (∏ (a1 a2 : X), (a1 * a2 = 0) -> (a1 = 0) ∨ (a2 = 0)). Lemma isapropisintdom (X : commring) : isaprop (isintdom X). Proof. use isapropdirprod. - apply propproperty. - use impred. intros x1. use impred. intros x2. use impred. intros H. use propproperty. Defined. Opaque isapropisintdom. Definition intdom : UU := total2 (λ X : commring, isintdom X). Definition pr1intdom : intdom -> commring := @pr1 _ _. Coercion pr1intdom : intdom >-> commring. Definition nonzeroax (X : intdom) : neg (@paths X 1 0) := pr1 (pr2 X). Definition intdomax (X : intdom) : ∏ (a1 a2 : X), (a1 * a2) = 0 -> (a1 = 0) ∨ (a2 = 0) := pr2 (pr2 X). (** **** (X = Y) ≃ (ringiso X Y) We use the following composition (X = Y) ≃ (pr1 X = pr1 Y) ≃ (ringiso X Y) where the second weak equivalence is given by univalence for commrings, [commring_univalence]. *) Definition intdom_univalence_weq1 (X Y : intdom) : (X = Y) ≃ (pr1 X = pr1 Y). Proof. use subtypeInjectivity. intros w. use isapropisintdom. Defined. Opaque intdom_univalence_weq1. Definition intdom_univalence_weq2 (X Y : intdom) : (pr1 X = pr1 Y) ≃ (ringiso X Y) := commring_univalence (pr1 X) (pr1 Y). Definition intdom_univalence_map (X Y : intdom) : (X = Y) -> (ringiso X Y). Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma intdom_univalence_isweq (X Y : intdom) : isweq (intdom_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (intdom_univalence_weq1 X Y) (intdom_univalence_weq2 X Y)). - intros e. induction e. use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque intdom_univalence_isweq. Definition intdom_univalence (X Y : intdom) : (X = Y) ≃ (ringiso X Y). Proof. use make_weq. - exact (intdom_univalence_map X Y). - exact (intdom_univalence_isweq X Y). Defined. Opaque intdom_univalence. (** **** Computational lemmas for integral domains *) Lemma intdomax2l (X : intdom) (x y : X) (is : paths (x * y) 0) (ne : x != 0) : y = 0. Proof. intros. set (int := intdomax X _ _ is). generalize ne. assert (int' : isaprop (x != 0 -> y = 0)). { apply impred. intro. apply (setproperty X _ _). } generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')). intro ene. destruct ene as [ e'' | ne' ]. - destruct (ne e''). - intro. apply ne'. Defined. Lemma intdomax2r (X : intdom) (x y : X) (is : paths (x * y) 0) (ne : y != 0) : x = 0. Proof. intros. set (int := intdomax X _ _ is). generalize ne. assert (int' : isaprop (y != 0 -> x = 0)). { apply impred. intro. apply (setproperty X _ _). } generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')). intro ene. destruct ene as [ e'' | ne' ]. - intro. apply e''. - destruct (ne ne'). Defined. Definition intdomneq0andmult (X : intdom) (n m : X) (isn : n != 0) (ism : m != 0) : ((n * m) != 0). Proof. intros. intro e. destruct (ism (intdomax2l X n m e isn )). Defined. Lemma intdomlcan (X : intdom) : ∏ (a b c : X), c != 0 -> paths (c * a) (c * b) -> a = b. Proof. intros a b c ne e. apply (@grtopathsxy X a b). change (paths (a - b) 0). assert (e' := grfrompathsxy X e). change (paths ((c * a) - (c * b)) 0) in e'. rewrite (pathsinv0 (ringrmultminus X _ _)) in e'. rewrite (pathsinv0 (ringldistr X _ _ c)) in e'. set (int := intdomax X _ _ e'). generalize ne. assert (int' : isaprop (c != 0 -> paths (a - b) 0)). { apply impred. intro. apply (setproperty X _ _). } generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')). intro ene. destruct ene as [ e'' | ne' ]. - destruct (ne e''). - intro. apply ne'. Defined. Opaque intdomlcan. Lemma intdomrcan (X : intdom) : ∏ (a b c : X), c != 0 -> paths (a * c) (b * c) -> a = b. Proof. intros a b c ne e. apply (@grtopathsxy X a b). change (paths (a - b) 0). assert (e' := grfrompathsxy X e). change (paths ((a * c) - (b * c)) 0) in e'. rewrite (pathsinv0 (ringlmultminus X _ _)) in e'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in e'. set (int := intdomax X _ _ e'). generalize ne. assert (int' : isaprop (c != 0 -> paths (a - b) 0)). { apply impred. intro. apply (setproperty X _ _). } generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')). intro ene. destruct ene as [ e'' | ne' ]. - intro. apply e''. - destruct (ne ne'). Defined. Opaque intdomrcan. Lemma intdomiscancelable (X : intdom) (x : X) (is : x != 0) : iscancelable (@op2 X) x. Proof. intros. apply iscancelableif. - intros a b. apply (intdomlcan X a b x is). - intros a b. apply (intdomrcan X a b x is). Defined. (** **** Multiplicative submonoid of non-zero elements *) Definition intdomnonzerosubmonoid (X : intdom) : @subabmonoid (ringmultabmonoid X). Proof. intros. split with (λ x : X, make_hProp _ (isapropneg (x = 0))). split. - intros a b. simpl in *. intro e. set (int := intdomax X (pr1 a) (pr1 b) e). clearbody int. generalize int. apply toneghdisj. apply (make_dirprod (pr2 a) (pr2 b)). - simpl. apply (nonzeroax X). Defined. (** **** Relations similar to "greater" on integral domains *) Definition intdomnonzerotopos (X : intdom) (R : hrel X) (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (x : intdomnonzerosubmonoid X) : ringpossubmonoid X is1 is2. Proof. intros. destruct (nc (pr1 x) 0 (pr2 x)) as [ g | l ]. - apply (tpair _ (pr1 x) g). - split with (- (pr1 x)). simpl. apply ringtogt0. + apply is0. + rewrite (ringminusminus X _). apply l. Defined. (** *** Ring units (i.e. multilicatively invertible elements) *) (** *** Fields *) (** **** Main definitions *) Definition isafield (X : commring) : UU := (isnonzerorig X) × (∏ x : X, (multinvpair X x) ⨿ (x = 0)). Lemma isapropisafield (X : commring) : isaprop (isafield X). Proof. use isofhleveltotal2. - apply propproperty. - intros H. use impred. intros x. use isapropcoprod. + use isapropinvpair. + use setproperty. + intros H' e. use H. use (pathscomp0 _ (@multx0_is_l X (@op1 X) (@op2 X) (dirprod_pr1 (ringop1axs X)) (ringop2axs X) (ringdistraxs X) (pr1 H'))). use (pathscomp0 _ (maponpaths (λ y : X , op2 (pr1 H') y) e)). exact (! dirprod_pr1 (pr2 H')). Defined. Opaque isapropisafield. Definition fld : UU := total2 (λ X : commring, isafield X). Definition make_fld (X : commring) (is : isafield X) : fld := tpair _ X is. Definition pr1fld : fld -> commring := @pr1 _ _. Definition fldtointdom (X : fld) : intdom. Proof. split with (pr1 X). split with (pr1 (pr2 X)). intros a1 a2. destruct (pr2 (pr2 X) a1) as [ a1' | e0 ]. - intro e12. rewrite (pathsinv0 (ringmultx0 (pr1 X) a1)) in e12. set (e2 := lcanfromlinv _ _ _ _ (invtolinv _ _ a1') e12). apply (hinhpr (ii2 e2)). - intro e12. apply (hinhpr (ii1 e0)). Defined. Coercion fldtointdom : fld >-> intdom. Definition fldchoice {X : fld} (x : X) : (multinvpair X x) ⨿ (x = 0) := pr2 (pr2 X) x. Definition fldmultinvpair (X : fld) (x : X) (ne : x != 0) : multinvpair X x. Proof. intros. destruct (fldchoice x) as [ ne0 | e0 ]. - apply ne0. - destruct (ne e0). Defined. Definition fldmultinv {X : fld} (x : X) (ne : x != 0) : X := pr1 (fldmultinvpair X x ne). (** **** (X = Y) ≃ (ringiso X Y) We use the following composition (X = Y) ≃ (pr1 X = pr1 Y) ≃ (ringiso X Y) where the second weak equivalence is given by univalence for commrings, [commring_univalence]. *) Definition fld_univalence_weq1 (X Y : fld) : (X = Y) ≃ (pr1 X = pr1 Y). Proof. use subtypeInjectivity. intros w. use isapropisafield. Defined. Opaque fld_univalence_weq1. Definition fld_univalence_weq2 (X Y : fld) : (pr1 X = pr1 Y) ≃ (ringiso X Y) := commring_univalence (pr1 X) (pr1 Y). Definition fld_univalence_map (X Y : fld) : (X = Y) -> (ringiso X Y). Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma fld_univalence_isweq (X Y : fld) : isweq (fld_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (fld_univalence_weq1 X Y) (fld_univalence_weq2 X Y)). - intros e. induction e. use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque fld_univalence_isweq. Definition fld_univalence (X Y : fld) : (X = Y) ≃ (ringiso X Y). Proof. use make_weq. - exact (fld_univalence_map X Y). - exact (fld_univalence_isweq X Y). Defined. Opaque fld_univalence. (** **** Field of fractions of an integral domain with decidable equality *) Definition fldfracmultinvint (X : intdom) (is : isdeceq X) (xa : dirprod X (intdomnonzerosubmonoid X)) : dirprod X (intdomnonzerosubmonoid X). Proof. intros. destruct (is (pr1 xa) 0) as [ e0 | ne0 ]. - apply (make_dirprod 1 (tpair (λ x, x != 0) 1 (nonzeroax X))). - apply (make_dirprod (pr1 (pr2 xa)) (tpair (λ x, x != 0) (pr1 xa) ne0)). Defined. (** Note: we choose a strange from the mathematicians perspective approach to the definition of the multiplicative inverse on non-zero elements of a field due to the current, somewhat less than satisfactory, situation with computational behavior of our construction of set-quotients. The particular problem is that the weak equivalence between "quotient of subtype" and "subtype of a quotient" is not isomorphism in the syntactic category. This can be corrected by extension of the type system with tfc-terms. See discussion in hSet.v *) Lemma fldfracmultinvintcomp (X : intdom) (is : isdeceq X) : iscomprelrelfun (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (fldfracmultinvint X is). Proof. intros. intros xa1 xa2. set (x1 := pr1 xa1). set (aa1 := pr2 xa1). set (a1 := pr1 aa1). set (x2 := pr1 xa2). set (aa2 := pr2 xa2). set (a2 := pr1 aa2). simpl. apply hinhfun. intro t2. unfold fldfracmultinvint. destruct (is (pr1 xa1) 0) as [ e1 | ne1 ]. - destruct (is (pr1 xa2) 0) as [ e2 | ne2 ]. + simpl. split with (tpair (λ x, x != 0) 1 (nonzeroax X)). apply idpath. + simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0). assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e. change (x1 = 0) in e1. rewrite e1 in e. rewrite (ringmult0x X _) in e. rewrite (ringmult0x X _) in e. assert (e' := intdomax2r X _ _ (pathsinv0 e) (pr2 aa0)). assert (e'' := intdomax2r X _ _ e' (pr2 aa1)). destruct (ne2 e''). - destruct (is (pr1 xa2) 0) as [ e2 | ne2 ]. + simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0). assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e. change (x2 = 0) in e2. rewrite e2 in e. rewrite (ringmult0x X _) in e. rewrite (ringmult0x X _) in e. assert (e' := intdomax2r X _ _ e (pr2 aa0)). assert (e'' := intdomax2r X _ _ e' (pr2 aa2)). destruct (ne1 e''). + simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0). assert (e := pr2 t2). split with aa0. change (paths (a1 * x2 * a0) (a2 * x1 * a0)). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e. rewrite (ringcomm2 X a1 x2). rewrite (ringcomm2 X a2 x1). apply (pathsinv0 e). Defined. Opaque fldfracmultinvintcomp. Definition fldfracmultinv0 (X : intdom) (is : isdeceq X) (x : commringfrac X (intdomnonzerosubmonoid X)) : commringfrac X (intdomnonzerosubmonoid X) := setquotfun _ _ _ (fldfracmultinvintcomp X is) x. Lemma nonzeroincommringfrac (X : commring) (S : @submonoid (ringmultmonoid X)) (xa : dirprod X S) (ne : (setquotpr (eqrelcommringfrac X S) xa != setquotpr _ (make_dirprod 0 (unel S)))%type) : (pr1 xa != 0). Proof. intros. set (x := pr1 xa). set (aa := pr2 xa). assert (e' := negf (weqpathsinsetquot (eqrelcommringfrac X S) _ _) ne). simpl in e'. generalize e'. apply negf. intro e. apply hinhpr. split with (unel S). change (paths (x * 1 * 1) (0 * (pr1 aa) * 1)). rewrite e. repeat rewrite (ringmult0x X _). apply idpath. Defined. Opaque nonzeroincommringfrac. Lemma zeroincommringfrac (X : intdom) (S : @submonoid (ringmultmonoid X)) (is : ∏ s : S, (pr1 s != 0)) (x : X) (aa : S) (e : paths (setquotpr (eqrelcommringfrac X S) (make_dirprod x aa)) (setquotpr _ (make_dirprod 0 (unel S)))) : x = 0. Proof. intros. set (e' := invweq (weqpathsinsetquot _ _ _) e). simpl in e'. generalize e'. apply (@hinhuniv _ (make_hProp _ (setproperty X _ _))). intro t2. simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0). set (a := pr1 aa). assert (e2 := pr2 t2). simpl in e2. change (paths (x * 1 * a0) (0 * a * a0)) in e2. rewrite (ringmult0x X _) in e2. rewrite (ringmult0x X _) in e2. rewrite (ringrunax2 X _) in e2. apply (intdomax2r X x a0 e2 (is aa0)). Defined. Opaque zeroincommringfrac. Lemma isdeceqfldfrac (X : intdom) (is : isdeceq X) : isdeceq (commringfrac X (intdomnonzerosubmonoid X)). Proof. intros. apply isdeceqcommringfrac. - intro a. apply isrcancelableif. intros b0 b1 e. apply (intdomrcan X _ _ (pr1 a) (pr2 a) e). - apply is. Defined. Lemma islinvinfldfrac (X : intdom) (is : isdeceq X) (x : commringfrac X (intdomnonzerosubmonoid X)) (ne : x != 0) : paths ((fldfracmultinv0 X is x) * x) 1. Proof. revert x ne. assert (int : ∏ x0, isaprop (x0 != 0 -> paths ((fldfracmultinv0 X is x0) * x0) 1)). { intro x0. apply impred. intro. apply (setproperty (commringfrac X (intdomnonzerosubmonoid X)) (fldfracmultinv0 X is x0 * x0) _). } apply (setquotunivprop _ (λ x0, make_hProp _ (int x0))). simpl. intros xa ne. change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (make_dirprod ((pr1 (fldfracmultinvint X is xa)) * (pr1 xa)) (@op (intdomnonzerosubmonoid X) (pr2 (fldfracmultinvint X is xa)) (pr2 xa)))) (setquotpr _ (make_dirprod 1 (tpair _ 1 (nonzeroax X))))). apply (weqpathsinsetquot). unfold fldfracmultinvint. simpl. destruct (is (pr1 xa) 0 ) as [ e0 | ne0' ]. - destruct (nonzeroincommringfrac X (intdomnonzerosubmonoid X) xa ne e0). - apply hinhpr. split with (tpair (λ a, a != 0) 1 (nonzeroax X)). set (x := (pr1 xa) : X). set (aa := pr2 xa). set (a := (pr1 aa) : X). simpl. change (paths (a * x * 1 * 1) (1 * (x * a) * 1)). rewrite (ringcomm2 X a x). repeat rewrite (ringrunax2 X _). rewrite (ringlunax2 X _). apply idpath. Defined. Opaque islinvinfldfrac. Lemma isrinvinfldfrac (X : intdom) (is : isdeceq X) (x : commringfrac X (intdomnonzerosubmonoid X)) (ne : x != 0) : paths (x * (fldfracmultinv0 X is x)) 1. Proof. intros. rewrite (ringcomm2 _ _ _). apply islinvinfldfrac. apply ne. Defined. Definition fldfrac (X : intdom) (is : isdeceq X) : fld. Proof. intros. split with (commringfrac X (intdomnonzerosubmonoid X)). split. - intro e. set (e' := zeroincommringfrac X (intdomnonzerosubmonoid X) (λ a : (intdomnonzerosubmonoid X), pr2 a) 1 (unel (intdomnonzerosubmonoid X)) e). apply (nonzeroax X e'). - intro x. destruct (isdeceqfldfrac X is x 0) as [ e | ne ]. apply (ii2 e). apply ii1. split with (fldfracmultinv0 X is x). split. + apply (islinvinfldfrac X is x ne) . + apply (isrinvinfldfrac X is x ne). Defined. (** **** Canonical homomorphism to the field of fractions *) Definition tofldfrac (X : intdom) (is : isdeceq X) (x : X) : fldfrac X is := setquotpr _ (make_dirprod x (tpair (λ x, x != 0) 1 (nonzeroax X))). Definition isbinop1funtofldfrac (X : intdom) (is : isdeceq X) : @isbinopfun X (fldfrac X is) (tofldfrac X is) := isbinop1funtocommringfrac X _. Lemma isunital1funtofldfrac (X : intdom) (is : isdeceq X) : (tofldfrac X is 0) = 0. Proof. intros. apply idpath. Defined. Definition isaddmonoidfuntofldfrac (X : intdom) (is : isdeceq X) : @ismonoidfun X (fldfrac X is) (tofldfrac X is) := make_dirprod (isbinop1funtofldfrac X is) (isunital1funtofldfrac X is). Definition tofldfracandminus0 (X : intdom) (is : isdeceq X) (x : X) : paths (tofldfrac X is (- x)) (- tofldfrac X is x) := tocommringfracandminus0 _ _ x. Definition tofldfracandminus (X : intdom) (is : isdeceq X) (x y : X) : paths (tofldfrac X is (x - y)) (tofldfrac X is x - tofldfrac X is y) := tocommringfracandminus _ _ x y. Definition isbinop2funtofldfrac (X : intdom) (is : isdeceq X) : @isbinopfun (ringmultmonoid X) (ringmultmonoid (fldfrac X is)) (tofldfrac X is) := isbinopfuntoabmonoidfrac (ringmultabmonoid X) (intdomnonzerosubmonoid X). Opaque isbinop2funtofldfrac. Lemma isunital2funtofldfrac (X : intdom) (is : isdeceq X) : (tofldfrac X is 1) = 1. Proof. intros. apply idpath. Defined. Opaque isunital2funtofldfrac. Definition ismultmonoidfuntofldfrac (X : intdom) (is : isdeceq X) : @ismonoidfun (ringmultmonoid X) (ringmultmonoid (fldfrac X is)) (tofldfrac X is) := make_dirprod (isbinop2funtofldfrac X is) (isunital2funtofldfrac X is). Definition isringfuntofldfrac (X : intdom) (is : isdeceq X) : @isringfun X (fldfrac X is) (tofldfrac X is) := make_dirprod (isaddmonoidfuntofldfrac X is) (ismultmonoidfuntofldfrac X is). Definition isincltofldfrac (X : intdom) (is : isdeceq X) : isincl (tofldfrac X is) := isincltocommringfrac X (intdomnonzerosubmonoid X) (λ x : _, pr2 (intdomiscancelable X (pr1 x) (pr2 x))). (** *** Relations similar to "greater" on fields of fractions Our approach here is slightly different from the tranditional one used for example in Bourbaki Algebra II, Ch. VI, Section 2 where one starts with a total ordering on a ring and extends it to its field of fractions. This situation woud be exemplified by the extension of "greater or equal" from integers to rationals. We have chosen to use instead as our archetypical example the extension of "greater" from integers to rationals. There is no particular difference between the two choices for types with decidable equality but in the setting of general rings in constructive mathematics the relations such as "greater" appear to be more fundamental than relations such as "greater or equal". For example, "greater or equal" on constructive real numbers can be obtained from "greater" but not vice versa. *) (** **** Description of the field of fractions as the ring of fractions with respect to the submonoid of "positive" elements *) Definition weqfldfracgtint_f (X : intdom) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (xa : dirprod X (intdomnonzerosubmonoid X)) : dirprod X (ringpossubmonoid X is1 is2). Proof. intros. destruct (nc (pr1 (pr2 xa)) 0 (pr2 (pr2 xa))) as [ g | l ]. - apply (make_dirprod (pr1 xa) (tpair _ (pr1 (pr2 xa)) g)). - split with (- (pr1 xa)). split with (- (pr1 (pr2 xa))). simpl. apply (ringfromlt0 X is0 l). Defined. Lemma weqfldfracgtintcomp_f (X : intdom) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) : iscomprelrelfun (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) (weqfldfracgtint_f X is0 is1 is2 nc). Proof. intros. intros xa1 xa2. simpl. set (x1 := pr1 xa1). set (aa1 := pr2 xa1). set (a1 := pr1 aa1). set (x2 := pr1 xa2). set (aa2 := pr2 xa2). set (a2 := pr1 aa2). apply hinhfun. intro t2. split with (tpair (λ x, R x 0) 1 is2). set (aa0 := pr1 t2). set (a0 := pr1 aa0). assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e. unfold weqfldfracgtint_f. destruct (nc (pr1 (pr2 xa1)) 0 (pr2 (pr2 xa1))) as [ g1 | l1 ]. - destruct (nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2))) as [ g2 | l2 ]. + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _). apply (intdomrcan X _ _ _ (pr2 aa0) e). + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _). rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). apply (maponpaths (λ x : X, - x)). apply (intdomrcan X _ _ _ (pr2 aa0) e). - destruct (nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2))) as [ g2 | l2 ]. + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _). rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). apply (maponpaths (λ x : X, - x)). apply (intdomrcan X _ _ _ (pr2 aa0) e). + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _). rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). apply (maponpaths (λ x : X, - - x)). apply (intdomrcan X _ _ _ (pr2 aa0) e). Defined. Opaque weqfldfracgtintcomp_f. Definition weqfldfracgt_f (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) : fldfrac X is -> commringfrac X (ringpossubmonoid X is1 is2) := setquotfun _ _ _ (weqfldfracgtintcomp_f X is0 is1 is2 nc). Definition weqfldfracgtint_b (X : intdom) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) (ir : isirrefl R) (xa : dirprod X (ringpossubmonoid X is1 is2)) : dirprod X (intdomnonzerosubmonoid X) := make_dirprod (pr1 xa) (tpair _ (pr1 (pr2 xa)) (rtoneq ir (pr2 (pr2 xa)))). Lemma weqfldfracgtintcomp_b (X : intdom) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) (ir : isirrefl R) : iscomprelrelfun (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (weqfldfracgtint_b X is1 is2 ir). Proof. intros. intros xa1 xa2. simpl. apply hinhfun. intro t2. split with (tpair _ (pr1 (pr1 t2)) (rtoneq ir (pr2 (pr1 t2)))). apply (pr2 t2). Defined. Definition weqfldfracgt_b (X : intdom) (is : isdeceq X) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) (ir : isirrefl R) : commringfrac X (ringpossubmonoid X is1 is2) -> fldfrac X is := setquotfun _ _ _ (weqfldfracgtintcomp_b X is1 is2 ir). Definition weqfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) : weq (fldfrac X is) (commringfrac X (ringpossubmonoid X is1 is2)). Proof. intros. set (f := weqfldfracgt_f X is is0 is1 is2 nc). set (g := weqfldfracgt_b X is is1 is2 ir). split with f. assert (egf : ∏ a, paths (g (f a)) a). { unfold fldfrac. simpl. apply (setquotunivprop _ (λ a, make_hProp _ (isasetsetquot _ (g (f a)) a))). intro xa. simpl. change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (weqfldfracgtint_b X is1 is2 ir (weqfldfracgtint_f X is0 is1 is2 nc xa))) (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) xa)). apply (weqpathsinsetquot). simpl. apply hinhpr. split with (tpair (λ x, x != 0) 1 (nonzeroax X)). simpl. unfold weqfldfracgtint_f. destruct (nc (pr1 (pr2 xa)) 0 (pr2 (pr2 xa))) as [ g' | l' ]. - simpl. apply idpath. - simpl. rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). apply idpath. } assert (efg : ∏ a, paths (f (g a)) a). { unfold fldfrac. simpl. apply (setquotunivprop _ (λ a, make_hProp _ (isasetsetquot _ (f (g a)) a))). intro xa. simpl. change (paths (setquotpr _ (weqfldfracgtint_f X is0 is1 is2 nc (weqfldfracgtint_b X is1 is2 ir xa))) (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) xa)). apply weqpathsinsetquot. simpl. apply hinhpr. split with (tpair (λ x, R x 0) 1 is2). unfold weqfldfracgtint_f. unfold weqfldfracgtint_b. simpl. set (int := nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa))) ). change (nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa)))) with int. destruct int as [ g' | l' ]. - simpl. apply idpath. - simpl. rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _). apply idpath. } apply (isweq_iso _ _ egf efg). Defined. Lemma isringfunweqfldfracgt_b (X : intdom) (is : isdeceq X) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) (ir : isirrefl R) : isringfun (weqfldfracgt_b X is is1 is2 ir). Proof. intros. set (g := weqfldfracgt_b X is is1 is2 ir). set (g0 := weqfldfracgtint_b X is1 is2 ir). split. - split. + unfold isbinopfun. change (∏ x x' : commringfrac X (ringpossubmonoid X is1 is2), paths (g (x + x')) ((g x) + (g x'))). apply (setquotuniv2prop _ (λ x x' : commringfrac X (ringpossubmonoid X is1 is2), make_hProp _ (setproperty (fldfrac X is) (g (x + x')) ((g x) + (g x'))))). intros xa1 xa2. change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (g0 (commringfracop1int X (ringpossubmonoid X is1 is2) xa1 xa2))) (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (commringfracop1int X (intdomnonzerosubmonoid X) (g0 xa1) (g0 xa2)))). apply (maponpaths (setquotpr _)). unfold g0. unfold weqfldfracgtint_b. unfold commringfracop1int. simpl. apply (pathsdirprod). * apply idpath. * destruct xa1 as [ x1 aa1 ]. destruct xa2 as [ x2 aa2 ]. simpl. destruct aa1 as [ a1 ia1 ]. destruct aa2 as [ a2 ia2 ]. simpl. apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0)))) (tpair _ (a1 * a2) (rtoneq ir (is1 a1 a2 ia1 ia2))) (make_carrier (λ x : pr1 X, make_hProp (x = 0 -> empty) (isapropneg (x = 0))) (a1 * a2) (fun e : paths (a1 * a2) 0 => toneghdisj (make_dirprod (rtoneq ir ia1) (rtoneq ir ia2)) (intdomax X a1 a2 e))) (idpath _)). + change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (g0 (make_dirprod 0 (tpair _ 1 is2)))) (setquotpr _ (make_dirprod 0 (tpair _ 1 (nonzeroax X))))). apply (maponpaths (setquotpr _)). unfold g0. unfold weqfldfracgtint_b. simpl. apply pathsdirprod. * apply idpath. * apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0)))) (tpair _ 1 (rtoneq ir is2)) (tpair _ 1 (nonzeroax X))). simpl. apply idpath. - split. + unfold isbinopfun. change (∏ x x' : commringfrac X (ringpossubmonoid X is1 is2), paths (g (x * x')) ((g x) * (g x'))). apply (setquotuniv2prop _ (λ x x' : commringfrac X (ringpossubmonoid X is1 is2), make_hProp _ (setproperty (fldfrac X is) (g (x * x')) ((g x) * (g x'))))). intros xa1 xa2. change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (g0 (commringfracop2int X (ringpossubmonoid X is1 is2) xa1 xa2))) (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (commringfracop2int X (intdomnonzerosubmonoid X) (g0 xa1) (g0 xa2)))). apply (maponpaths (setquotpr _)). unfold g0. unfold weqfldfracgtint_b. unfold commringfracop2int. unfold abmonoidfracopint. simpl. apply (pathsdirprod). * apply idpath. * destruct xa1 as [ x1 aa1 ]. destruct xa2 as [ x2 aa2 ]. simpl. destruct aa1 as [ a1 ia1 ]. destruct aa2 as [ a2 ia2 ]. simpl. apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0)))) (tpair _ (a1 * a2) (rtoneq ir (is1 a1 a2 ia1 ia2))) (make_carrier (λ x : pr1 X, make_hProp (x = 0 -> empty) (isapropneg (x = 0))) (a1 * a2) (fun e : paths (a1 * a2) 0 => toneghdisj (make_dirprod (rtoneq ir ia1) (rtoneq ir ia2)) (intdomax X a1 a2 e))) (idpath _)). + change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) (g0 (make_dirprod 1 (tpair _ 1 is2)))) (setquotpr _ (make_dirprod 1 (tpair _ 1 (nonzeroax X))))). apply (maponpaths (setquotpr _)). unfold g0. unfold weqfldfracgtint_b. simpl. apply pathsdirprod. * apply idpath. * apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0)))) (tpair _ 1 (rtoneq ir is2)) (tpair _ 1 (nonzeroax X))). simpl. apply idpath. Defined. Opaque isringfunweqfldfracgt_b. Lemma isringfunweqfldfracgt_f (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) : isringfun (weqfldfracgt_f X is is0 is1 is2 nc). Proof. intros. unfold weqfldfracgt_f. set (int := make_ringiso (invweq (weqfldfracgt X is is0 is1 is2 nc ir)) (isringfunweqfldfracgt_b X is is1 is2 ir)). change (@isringfun (fldfrac X is) (commringfrac X (ringpossubmonoid X is1 is2)) (invmap int)). apply isringfuninvmap. Defined. Opaque isringfunweqfldfracgt_f. (** **** Definition and properties of "greater" on the field of fractions *) Definition fldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) : hrel (fldfrac X is) := λ a b, commringfracgt X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r) (weqfldfracgt_f X is is0 is1 is2 nc a) (weqfldfracgt_f X is is0 is1 is2 nc b). Lemma isringmultfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) : isringmultgt (fldfrac X is) (fldfracgt X is is0 is1 is2 nc). Proof. intros. refine (ringmultgtandfun (ringfunconstr (isringfunweqfldfracgt_f X is is0 is1 is2 nc ir)) _ _). apply isringmultcommringfracgt. Defined. Opaque isringmultfldfracgt. Lemma isringaddfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) : @isbinophrel (fldfrac X is) (fldfracgt X is is0 is1 is2 nc). Proof. intros. refine (ringaddhrelandfun (ringfunconstr (isringfunweqfldfracgt_f X is is0 is1 is2 nc ir)) _ _). apply isringaddcommringfracgt. Defined. Opaque isringaddfldfracgt. Lemma istransfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : istrans R) : istrans (fldfracgt X is is0 is1 is2 nc). Proof. intros. intros a b c. unfold fldfracgt. apply istransabmonoidfracrel. apply isr. Defined. Opaque istransfldfracgt. Lemma isirreflfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : isirrefl R) : isirrefl (fldfracgt X is is0 is1 is2 nc). Proof. intros. intros a. unfold fldfracgt . apply isirreflabmonoidfracrel. apply isr. Defined. Opaque isirreflfldfracgt. Lemma isasymmfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : isasymm R) : isasymm (fldfracgt X is is0 is1 is2 nc). Proof. intros. intros a b. unfold fldfracgt . apply isasymmabmonoidfracrel. apply isr. Defined. Opaque isasymmfldfracgt. Lemma iscotransfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : iscotrans R) : iscotrans (fldfracgt X is is0 is1 is2 nc). Proof. intros. intros a b c. unfold fldfracgt . apply iscotransabmonoidfracrel. apply isr. Defined. Opaque iscotransfldfracgt. Lemma isantisymmnegfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) (isr : isantisymmneg R) : isantisymmneg (fldfracgt X is is0 is1 is2 nc). Proof. intros. assert (int : isantisymmneg (commringfracgt X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r))). { unfold commringfracgt. apply (isantisymmnegabmonoidfracrel (ringmultabmonoid X) (ringpossubmonoid X is1 is2) (ispartbinopcommringfracgt X (ringpossubmonoid X is1 is2) is0 is1 (fun (c : X) (r : (ringpossubmonoid X is1 is2) c) => r))). apply isr. } intros a b n1 n2. set (e := int _ _ n1 n2). apply (invmaponpathsweq (weqfldfracgt X is is0 is1 is2 nc ir) _ _ e). Defined. Opaque isantisymmnegfldfracgt. Definition isdecfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isa : isasymm R) (isr : isdecrel R) : isdecrel (fldfracgt X is is0 is1 is2 nc). Proof. intros. unfold fldfracgt. intros a b. apply isdecabmonoidfracrel. - apply (pr1 (isinvringmultgtaspartinvbinophrel X R is0)). apply isinvringmultgtif. + apply is0. + apply is1. + apply nc. + apply isa. - apply isr. Defined. (** **** Relations and the canonical homomorphism to the field of fractions *) Definition iscomptofldfrac (X : intdom) (is : isdeceq X) {L : hrel X} (is0 : @isbinophrel X L) (is1 : isringmultgt X L) (is2 : L 1 0) (nc : neqchoice L) (isa : isasymm L) : iscomprelrelfun L (fldfracgt X is is0 is1 is2 nc) (tofldfrac X is). Proof. intros. intros x1 x2 l. assert (int := iscomptocommringfrac X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r)). simpl in int. unfold fldfracgt. unfold iscomprelrelfun in int. assert (ee : ∏ x : X, paths (tocommringfrac X (ringpossubmonoid X is1 is2) x) (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x))). { intros x. change (tocommringfrac X (ringpossubmonoid X is1 is2) x) with (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) (make_dirprod x (tpair (λ a, L a 0) _ is2))). change (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x)) with (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) (weqfldfracgtint_f X is0 is1 is2 nc (make_dirprod x (tpair (λ a, a != 0) 1 (nonzeroax X))))). apply (maponpaths (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)))). unfold weqfldfracgtint_f. simpl. destruct (nc 1 0 (nonzeroax X) ) as [ l' | nl ]. - apply pathsdirprod. + apply idpath. + apply (invmaponpathsincl _ (isinclpr1 _ (λ a, (pr2 (L a 0))))). apply idpath. - destruct (isa _ _ is2 nl). } assert (int' := int x1 x2). rewrite (ee x1) in int'. rewrite (ee x2) in int'. apply int'. apply l. Defined. Opaque iscomptofldfrac. (* End of the file *) UniMath-20231010/UniMath/Algebra/Free_Monoids_and_Groups.v000066400000000000000000000715551451125700300231470ustar00rootroot00000000000000(** Authors Floris van Doorn, December 2017 *) Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Combinatorics.Lists. (** ** Contents - Free monoid on a set - Monoid presented by a set of generators and relations - Free abelian monoid on a set - Abelian monoid presented by a set of generators and relations - Free group on a set - Group presented by a set of generators and relations - Free abelian group on set - Abelian group presented by a set of generators and relations *) Local Open Scope multmonoid_scope. Local Notation "[]" := nil (at level 0, format "[]"). Local Infix "::" := cons. (* Free monoid on a set *) Lemma ismonoidop_concatenate (X : UU) : ismonoidop (@concatenate X). Proof. use make_ismonoidop. - use assoc_concatenate. - use make_isunital. + exact []. + use make_isunit. * use nil_concatenate. * use concatenate_nil. Defined. Definition free_monoid (X : hSet) : monoid := make_monoid (make_setwithbinop (make_hSet (list X) (isofhlevellist 0 (pr2 X))) _) (ismonoidop_concatenate X). Definition free_monoid_unit {X : hSet} (x : X) : free_monoid X := x::[]. Definition free_monoid_extend {X : hSet} {Y : monoid} (f : X → Y) : monoidfun (free_monoid X) Y. Proof. use monoidfunconstr. - intro l. exact (iterop_list_mon (map f l)). - use make_ismonoidfun. + intros l1 l2. refine (maponpaths _ (map_concatenate _ _ _) @ _). apply iterop_list_mon_concatenate. + reflexivity. Defined. Lemma free_monoid_extend_homot {X : hSet} {Y : monoid} {f f' : X → Y} (h : f ~ f') : free_monoid_extend f ~ free_monoid_extend f'. Proof. intro x. apply (maponpaths iterop_list_mon). exact (map_homot h x). Defined. Lemma free_monoid_extend_comp {X : hSet} {Y : monoid} (g : monoidfun (free_monoid X) Y): free_monoid_extend (g ∘ free_monoid_unit) ~ g. Proof. unfold homot. simpl. apply list_ind. + exact (! monoidfununel g). + intros x xs IH. rewrite map_cons, iterop_list_mon_step, IH. exact (!pr1 (pr2 g) _ _). Defined. Definition free_monoid_universal_property (X : hSet) (Y : monoid) : (X → Y) ≃ monoidfun (free_monoid X) Y. Proof. use weq_iso. - apply free_monoid_extend. - intro g. exact (g ∘ free_monoid_unit). - intro f. apply funextfun. intro x. reflexivity. - intro g. apply monoidfun_paths. apply funextfun. exact (free_monoid_extend_comp g). Defined. (* We don't use free_monoid_extend, so that the underlying function is map *) Definition free_monoidfun {X Y : hSet} (f : X → Y) : monoidfun (free_monoid X) (free_monoid Y). Proof. use monoidfunconstr. - intro l. exact (map f l). - use make_ismonoidfun. + intros l1 l2. apply map_concatenate. + reflexivity. Defined. Lemma free_monoidfun_homot_extend {X Y : hSet} (f : X → Y) : free_monoidfun f ~ free_monoid_extend (free_monoid_unit ∘ f). Proof. exact (foldr1_concatenate f). Defined. Lemma free_monoid_extend_funcomp {X Y : hSet} {Z : monoid} (f : X → Y) (g : Y → Z) : free_monoid_extend (g ∘ f) ~ free_monoid_extend g ∘ free_monoidfun f. Proof. unfold homot. simpl. apply list_ind. + reflexivity. + intros x xs IH. now rewrite !map_cons, !iterop_list_mon_step, IH. Defined. Lemma free_monoid_extend_funcomp2 {X Y : hSet} {Z : monoid} (f: (X → free_monoid Y)) (g: (Y → Z)) : monoidfuncomp (free_monoid_extend f) (free_monoid_extend g) = free_monoid_extend (λ x, free_monoid_extend g (f x)). Proof. apply (invmaponpathsweq (invweq (free_monoid_universal_property _ _)) _ _). now apply idpath. Qed. (** Functoriality of the [free_monoidfun] *) Lemma free_monoidfun_comp_homot {X Y Z : hSet} (f : X -> Y) (g : Y -> Z) : (free_monoidfun (g ∘ f)) ~ free_monoidfun g ∘ free_monoidfun f. Proof. intro; apply map_compose. Qed. Definition reverse_binopfun (X : hSet) : binopfun (free_monoid X) (setwithbinop_rev (free_monoid X)). Proof. use make_binopfun. - exact reverse. - intros x x'. apply reverse_concatenate. Defined. (* Monoid presented by a set of generators and relations *) Definition presented_monoid (X : hSet) (R : hrel (free_monoid X)) : monoid := monoidquot (generated_binopeqrel R). Definition presented_monoid_pr {X : hSet} (R : hrel (free_monoid X)) : monoidfun (free_monoid X) (presented_monoid X R) := monoidquotpr _. Definition presented_monoid_intro {X : hSet} {R : hrel (free_monoid X)} : X → presented_monoid X R := presented_monoid_pr R ∘ free_monoid_unit. Definition presented_monoid_extend {X : hSet} {R : hrel (free_monoid X)} {Y : monoid} (f : X → Y) (H : iscomprelfun R (free_monoid_extend f)) : monoidfun (presented_monoid X R) Y. Proof. use monoidquotuniv. - exact (free_monoid_extend f). - exact (iscomprelfun_generated_binopeqrel _ H). Defined. Lemma iscomprelfun_presented_monoidfun {X : hSet} {R : hrel (free_monoid X)} {Y : monoid} (g : monoidfun (presented_monoid X R) Y) : iscomprelfun R (free_monoid_extend (g ∘ presented_monoid_intro)). Proof. intros x x' r. rewrite !(free_monoid_extend_comp (monoidfuncomp (presented_monoid_pr R) g)). apply (maponpaths (pr1 g)). apply iscompsetquotpr. exact (generated_binopeqrel_intro r). Defined. Lemma presented_monoid_extend_comp {X : hSet} {R : hrel (free_monoid X)} {Y : monoid} (g : monoidfun (presented_monoid X R) Y) (H : iscomprelfun R (free_monoid_extend (g ∘ presented_monoid_intro))) : presented_monoid_extend (g ∘ presented_monoid_intro) H ~ g. Proof. unfold homot. apply setquotunivprop'. + intro. apply isasetmonoid. + intro x. refine (setquotunivcomm _ _ _ _ _ @ _). exact (free_monoid_extend_comp (monoidfuncomp (presented_monoid_pr R) g) x). Defined. Definition presented_monoid_universal_property {X : hSet} (R : hrel (free_monoid X)) (Y : monoid) : monoidfun (presented_monoid X R) Y ≃ ∑(f : X → Y), iscomprelfun R (free_monoid_extend f). Proof. use weq_iso. - intro g. exact (tpair _ (g ∘ presented_monoid_intro) (iscomprelfun_presented_monoidfun g)). - intro f. exact (presented_monoid_extend (pr1 f) (pr2 f)). - intro g. apply monoidfun_paths, funextfun, presented_monoid_extend_comp. - intro f. use total2_paths_f. + apply funextfun. intro x. reflexivity. + apply isapropiscomprelfun. Defined. Definition presented_monoidfun {X Y : hSet} {R : hrel (free_monoid X)} {S : hrel (free_monoid Y)} (f : X → Y) (H : iscomprelrelfun R S (free_monoidfun f)) : monoidfun (presented_monoid X R) (presented_monoid Y S). Proof. apply (presented_monoid_extend (presented_monoid_intro ∘ f)). intros x x' r. rewrite !free_monoid_extend_funcomp. unfold funcomp. rewrite !(free_monoid_extend_comp (presented_monoid_pr S)). apply iscompsetquotpr. apply generated_binopeqrel_intro. exact (H x x' r). Defined. (* Free abelian monoid on a set *) Definition free_abmonoid_hrel (X : hSet) : hrel (free_monoid X) := λ g h, ∃ x y, x * y = g × y * x = h. Lemma free_abmonoid_hrel_intro {X : hSet} (l1 l2 : free_monoid X) : free_abmonoid_hrel X (l1 * l2) (l2 * l1). Proof. apply wittohexists with l1. split with l2. split; reflexivity. Defined. Lemma free_abmonoid_hrel_univ {X : hSet} (P : free_monoid X → free_monoid X → UU) (HP : ∏ (x y : free_monoid X), isaprop (P x y)) (Hind : ∏ x y, P (x * y) (y * x)) (x y : free_monoid X) : free_abmonoid_hrel X x y → P x y. Proof. apply (@hinhuniv _ (make_hProp (P x y) (HP x y))). intro v. induction v as (x',v). induction v as (y',v). induction v as (p1,p2). induction p1. induction p2. apply Hind. Defined. Definition free_abmonoid' (X : hSet) : monoid := presented_monoid X (free_abmonoid_hrel X). Lemma iscomm_free_abmonoid (X : hSet) : iscomm (@op (free_abmonoid' X)). Proof. refine (setquotuniv2prop' _ _ _). - intros. apply (isasetmonoid (free_abmonoid' X)). - intros x1 x2. apply (iscompsetquotpr _ (x1 * x2) (x2 * x1)). apply generated_binopeqrel_intro, free_abmonoid_hrel_intro. Defined. Definition free_abmonoid (X : hSet) : abmonoid := abmonoid_of_monoid (free_abmonoid' X) (iscomm_free_abmonoid X). Definition free_abmonoid_pr (X : hSet) : monoidfun (free_monoid X) (free_abmonoid X) := presented_monoid_pr _. Definition free_abmonoid_unit {X : hSet} (x : X) : free_abmonoid X := presented_monoid_intro x. Definition free_abmonoid_extend {X : hSet} {Y : abmonoid} (f : X → Y) : monoidfun (free_abmonoid X) Y. Proof. apply (presented_monoid_extend f). unfold iscomprelfun. apply free_abmonoid_hrel_univ. - intros. apply (isasetmonoid Y). - intros x y. rewrite !monoidfunmul. apply commax. Defined. Lemma free_abmonoid_extend_homot {X : hSet} {Y : abmonoid} {f f' : X → Y} (h : f ~ f') : free_abmonoid_extend f ~ free_abmonoid_extend f'. Proof. unfold homot. apply setquotunivprop'. - intro x. apply isasetmonoid. - exact (free_monoid_extend_homot h). Defined. Lemma free_abmonoid_extend_comp {X : hSet} {Y : abmonoid} (g : monoidfun (free_abmonoid X) Y): free_abmonoid_extend (g ∘ free_abmonoid_unit) ~ g. Proof. apply (presented_monoid_extend_comp g). Defined. Definition free_abmonoid_universal_property (X : hSet) (Y : abmonoid) : (X → Y) ≃ monoidfun (free_abmonoid X) Y. Proof. use weq_iso. - apply free_abmonoid_extend. - intro g. exact (g ∘ free_abmonoid_unit). - intro f. apply funextfun. intro x. reflexivity. - intro g. apply monoidfun_paths, funextfun, free_abmonoid_extend_comp. Defined. Definition free_abmonoidfun {X Y : hSet} (f : X → Y) : monoidfun (free_abmonoid X) (free_abmonoid Y) := free_abmonoid_extend (free_abmonoid_unit ∘ f). Lemma free_abmonoidfun_setquotpr {X Y : hSet} (f : X → Y) (x : free_monoid X) : free_abmonoidfun f (setquotpr _ x) = setquotpr _ (free_monoidfun f x). Proof. refine (setquotunivcomm _ _ _ _ _ @ _). rewrite free_monoid_extend_funcomp. apply free_monoid_extend_comp. Defined. Lemma free_abmonoid_extend_funcomp {X Y : hSet} {Z : abmonoid} (f : X → Y) (g : Y → Z) : free_abmonoid_extend (g ∘ f) ~ free_abmonoid_extend g ∘ free_abmonoidfun f. Proof. unfold homot. apply setquotunivprop'. - intro. apply isasetmonoid. - intro x. refine (setquotunivcomm _ _ _ _ _ @ _). refine (free_monoid_extend_funcomp f g x @ _). unfold funcomp. rewrite free_abmonoidfun_setquotpr. refine (!setquotunivcomm _ _ _ _ _). Defined. Proposition free_abmonoid_mor_eq {X : hSet} {Y : abmonoid} {f g : monoidfun (free_abmonoid X) Y} (p : ∏ (x : X), f (free_abmonoid_unit x) = g (free_abmonoid_unit x)) : f = g. Proof. use (invmaponpathsweq (invweq (free_abmonoid_universal_property X Y)) f g). use funextsec. exact p. Qed. (* Abelian monoid presented by a set of generators and relations *) Definition presented_abmonoid (X : hSet) (R : hrel (free_abmonoid X)) : abmonoid := abmonoidquot (generated_binopeqrel R). Definition presented_abmonoid_pr {X : hSet} (R : hrel (free_abmonoid X)) : monoidfun (free_abmonoid X) (presented_abmonoid X R) := monoidquotpr _. Definition presented_abmonoid_intro {X : hSet} {R : hrel (free_abmonoid X)} : X → presented_abmonoid X R := presented_abmonoid_pr R ∘ free_abmonoid_unit. Definition presented_abmonoid_extend {X : hSet} {R : hrel (free_abmonoid X)} {Y : abmonoid} (f : X → Y) (H : iscomprelfun R (free_abmonoid_extend f)) : monoidfun (presented_abmonoid X R) Y. Proof. use monoidquotuniv. - exact (free_abmonoid_extend f). - exact (iscomprelfun_generated_binopeqrel _ H). Defined. Lemma iscomprelfun_presented_abmonoidfun {X : hSet} {R : hrel (free_abmonoid X)} {Y : abmonoid} (g : monoidfun (presented_abmonoid X R) Y) : iscomprelfun R (free_abmonoid_extend (g ∘ presented_abmonoid_intro)). Proof. intros x x' r. rewrite !(free_abmonoid_extend_comp (monoidfuncomp (presented_abmonoid_pr R) g)). apply (maponpaths (pr1 g)). apply iscompsetquotpr. exact (generated_binopeqrel_intro r). Defined. Lemma presented_abmonoid_extend_comp {X : hSet} {R : hrel (free_abmonoid X)} {Y : abmonoid} (g : monoidfun (presented_abmonoid X R) Y) (H : iscomprelfun R (free_abmonoid_extend (g ∘ presented_abmonoid_intro))) : presented_abmonoid_extend (g ∘ presented_abmonoid_intro) H ~ g. Proof. unfold homot. apply setquotunivprop'. + intro. apply isasetmonoid. + intro x. refine (setquotunivcomm _ _ _ _ _ @ _). exact (free_abmonoid_extend_comp (monoidfuncomp (presented_abmonoid_pr R) g) x). Defined. Definition presented_abmonoid_universal_property {X : hSet} (R : hrel (free_abmonoid X)) (Y : abmonoid) : monoidfun (presented_abmonoid X R) Y ≃ ∑(f : X → Y), iscomprelfun R (free_abmonoid_extend f). Proof. use weq_iso. - intro g. exact (tpair _ (g ∘ presented_abmonoid_intro) (iscomprelfun_presented_abmonoidfun g)). - intro f. exact (presented_abmonoid_extend (pr1 f) (pr2 f)). - intro g. apply monoidfun_paths, funextfun, presented_abmonoid_extend_comp. - intro f. use total2_paths_f. + apply funextfun. intro x. reflexivity. + apply isapropiscomprelfun. Defined. Definition presented_abmonoidfun {X Y : hSet} {R : hrel (free_abmonoid X)} {S : hrel (free_abmonoid Y)} (f : X → Y) (H : iscomprelrelfun R S (free_abmonoidfun f)) : monoidfun (presented_abmonoid X R) (presented_abmonoid Y S). Proof. apply (presented_abmonoid_extend (presented_abmonoid_intro ∘ f)). intros x x' r. rewrite !(free_abmonoid_extend_funcomp _ _ _). unfold funcomp. rewrite !(free_abmonoid_extend_comp (presented_abmonoid_pr S)). apply iscompsetquotpr. apply generated_binopeqrel_intro. exact (H x x' r). Defined. (* Free group on a set. We define it as a quotient of the free monoid on X ⨿ X, where (inr x) is to be treated as the inverse of x. *) Definition free_gr_hrel (X : hSet) : hrel (free_monoid (setcoprod X X)) := λ g h, ∃ x, x::coprodcomm X X x::[] = g × [] = h. Lemma free_gr_hrel_in {X : hSet} (x : X ⨿ X) : free_gr_hrel X (x::coprodcomm X X x::[]) []. Proof. apply wittohexists with x. split; reflexivity. Defined. Lemma free_gr_hrel_in_rev {X : hSet} (x : X ⨿ X) : free_gr_hrel X (coprodcomm X X x::x::[]) []. Proof. pose (H := free_gr_hrel_in (coprodcomm X X x)). rewrite coprodcomm_coprodcomm in H. exact H. Defined. Lemma free_gr_hrel_univ {X : hSet} (P : free_monoid (setcoprod X X) → free_monoid (setcoprod X X) → UU) (HP : ∏ x y, isaprop (P x y)) (Hind : ∏ x, P (x::coprodcomm X X x::[]) []) (x y : free_monoid (setcoprod X X)) : free_gr_hrel X x y → P x y. Proof. apply (@hinhuniv _ (make_hProp (P x y) (HP x y))). intro v. induction v as (x',v), v as (p1,p2), p1, p2. apply Hind. Defined. (* [fginv x] will be the inverse of [x] in the free group *) Local Definition fginv {X : hSet} (l : free_monoid (setcoprod X X)) : free_monoid (setcoprod X X) := reverse (map (coprodcomm X X) l). Definition fginv_binopfun (X : hSet) : binopfun (free_monoid (setcoprod X X)) (setwithbinop_rev (free_monoid (setcoprod X X))). Proof. refine (binopfuncomp (free_monoidfun _) (reverse_binopfun _)). exact (coprodcomm X X). Defined. Definition fginv_binopfun_homot {X : hSet} (l : free_monoid (setcoprod X X)) : fginv_binopfun X l = fginv l := idpath _. Lemma fginv_fginv {X : hSet} (l : free_monoid (setcoprod X X)) : fginv (fginv l) = l. Proof. unfold fginv. rewrite map_reverse, reverse_reverse, <- map_compose, <- map_idfun. apply map_homot. exact coprodcomm_coprodcomm. Defined. Lemma generated_free_gr_hrel_in {X : hSet} (l : free_monoid (setcoprod X X)) : generated_binopeqrel (free_gr_hrel X) (l * fginv l) []. Proof. intros R H. revert l. apply list_ind. - apply eqrelrefl. - intros x xs IH. change (R ((free_monoid_unit x * xs) * (fginv xs * @free_monoid_unit (setcoprod X X) (coprodcomm X X x))) []). rewrite assocax, <- (assocax _ _ _ (free_monoid_unit _)). refine (eqreltrans (pr1 R) _ _ _ (binopeqrel_resp_left R _ (binopeqrel_resp_right R _ IH)) _). apply H, free_gr_hrel_in. Defined. Lemma generated_free_gr_hrel_in_rev {X : hSet} (l : free_monoid (setcoprod X X)) : generated_binopeqrel (free_gr_hrel X) (fginv l * l) []. Proof. pose (H := generated_free_gr_hrel_in (fginv l)). rewrite fginv_fginv in H. exact H. Defined. Local Definition free_gr' (X : hSet) : monoid := presented_monoid (setcoprod X X) (free_gr_hrel X). Definition invstruct_free_gr (X : hSet) : invstruct (@op (free_gr' X)) (pr2 (free_gr' X)). Proof. use make_invstruct. - use setquotfun. + exact fginv. + refine (iscomprelrelfun_generated_binopeqrel_rev (fginv_binopfun X) _). unfold iscomprelrelfun. apply free_gr_hrel_univ. * intros. apply pr2. * intro x. rewrite fginv_binopfun_homot. apply free_gr_hrel_in_rev. - apply make_isinv. + refine (setquotunivprop' _ _ _). * intro. apply isasetmonoid. * intro l. refine (maponpaths (λ x, x * _) (setquotunivcomm _ _ _ _ _) @ _). apply (iscompsetquotpr _ (fginv l * l) []). apply generated_free_gr_hrel_in_rev. + refine (setquotunivprop' _ _ _). * intro. apply isasetmonoid. * intro l. refine (maponpaths (λ x, _ * x) (setquotunivcomm _ _ _ _ _) @ _). apply (iscompsetquotpr _ (l * fginv l) []). apply generated_free_gr_hrel_in. Defined. (* The free group is actually a group *) Definition free_gr (X : hSet) : gr := gr_of_monoid (free_gr' X) (invstruct_free_gr X). Definition free_gr_pr (X : hSet) : monoidfun (free_monoid (setcoprod X X)) (free_gr X) := monoidquotpr _. Definition free_gr_unit {X : hSet} (x : X) : free_gr X. Proof. apply presented_monoid_intro. exact (inl x). Defined. Definition free_gr_extend {X : hSet} {Y : gr} (f : X → Y) : monoidfun (free_gr X) Y. Proof. use presented_monoid_extend. - exact (sumofmaps f (grinv Y ∘ f)). - unfold iscomprelfun. apply free_gr_hrel_univ. + intros x y. apply (isasetmonoid Y). + intro x. induction x as [x|x]. * apply (grrinvax Y (f x)). * apply (grlinvax Y (f x)). Defined. Lemma free_gr_extend_homot {X : hSet} {Y : gr} {f f' : X → Y} (h : f ~ f') : free_gr_extend f ~ free_gr_extend f'. Proof. unfold homot. apply setquotunivprop'. - intro x. apply isasetmonoid. - refine (free_monoid_extend_homot _). apply sumofmaps_homot. + exact h. + intro x. exact (maponpaths (grinv Y) (h x)). Defined. Lemma free_gr_extend_comp {X : hSet} {Y : gr} (g : monoidfun (free_gr X) Y): free_gr_extend (g ∘ free_gr_unit) ~ g. Proof. unfold homot. apply setquotunivprop'. - intro. apply (isasetmonoid Y). - intro l. refine (setquotunivcomm _ _ _ _ _ @ _). refine (_ @ (free_monoid_extend_comp (monoidfuncomp (free_gr_pr X) g)) l). apply (maponpaths iterop_list_mon). apply map_homot. intro x. induction x as [x|x]. + reflexivity. + simpl. refine (!monoidfuninvtoinv g _ @ _). reflexivity. Defined. Definition free_gr_universal_property (X : hSet) (Y : gr) : (X → Y) ≃ monoidfun (free_gr X) Y. Proof. use weq_iso. - apply free_gr_extend. - intro g. exact (g ∘ free_gr_unit). - intro f. apply funextfun. intro x. reflexivity. - intro g. apply monoidfun_paths, funextfun, free_gr_extend_comp. Defined. Definition free_grfun {X Y : hSet} (f : X → Y) : monoidfun (free_gr X) (free_gr Y) := free_gr_extend (free_gr_unit ∘ f). Lemma sumofmaps_free_gr_unit {X : hSet} : sumofmaps free_gr_unit (grinv (free_gr X) ∘ free_gr_unit) ~ @presented_monoid_intro (setcoprod X X) (free_gr_hrel X). Proof. intro x. induction x as [x|x]; reflexivity. Defined. Lemma free_grfun_setquotpr {X Y : hSet} (f : X → Y) (x : free_monoid (setcoprod X X)) : free_grfun f (setquotpr _ x) = setquotpr _ (@free_monoidfun (setcoprod X X) (setcoprod Y Y) (coprodf f f) x). Proof. refine (setquotunivcomm _ _ _ _ _ @ _). refine (free_monoid_extend_homot _ x @ _). exact (sumofmaps_funcomp f free_gr_unit f (grinv (free_gr Y) ∘ free_gr_unit)). rewrite (@free_monoid_extend_funcomp (setcoprod X X) (setcoprod Y Y)). refine (free_monoid_extend_homot _ _ @ _). exact (sumofmaps_free_gr_unit). apply (@free_monoid_extend_comp (setcoprod _ _)). Defined. Lemma free_gr_extend_funcomp {X Y : hSet} {Z : gr} (f : X → Y) (g : Y → Z) : free_gr_extend (g ∘ f) ~ free_gr_extend g ∘ free_grfun f. Proof. unfold homot. apply setquotunivprop'. - intro. apply isasetmonoid. - intro x. refine (setquotunivcomm _ _ _ _ _ @ _). refine (free_monoid_extend_homot _ x @ _). exact (sumofmaps_funcomp f g f (grinv Z ∘ g)). refine (@free_monoid_extend_funcomp (setcoprod X X) (setcoprod Y Y) _ _ _ x @ _). unfold funcomp. rewrite free_grfun_setquotpr. refine (!setquotunivcomm _ _ _ _ _). Defined. (* Group presented by a set of generators and relations *) Definition presented_gr (X : hSet) (R : hrel (free_gr X)) : gr := grquot (generated_binopeqrel R). Definition presented_gr_pr {X : hSet} (R : hrel (free_gr X)) : monoidfun (free_gr X) (presented_gr X R) := monoidquotpr _. Definition presented_gr_intro {X : hSet} {R : hrel (free_gr X)} : X → presented_gr X R := presented_gr_pr R ∘ free_gr_unit. Definition presented_gr_extend {X : hSet} {R : hrel (free_gr X)} {Y : gr} (f : X → Y) (H : iscomprelfun R (free_gr_extend f)) : monoidfun (presented_gr X R) Y. Proof. use monoidquotuniv. - exact (free_gr_extend f). - exact (iscomprelfun_generated_binopeqrel _ H). Defined. Lemma iscomprelfun_presented_grfun {X : hSet} {R : hrel (free_gr X)} {Y : gr} (g : monoidfun (presented_gr X R) Y) : iscomprelfun R (free_gr_extend (g ∘ presented_gr_intro)). Proof. intros x x' r. rewrite !(free_gr_extend_comp (monoidfuncomp (presented_gr_pr R) g)). apply (maponpaths (pr1 g)). apply iscompsetquotpr. exact (generated_binopeqrel_intro r). Defined. Lemma presented_gr_extend_comp {X : hSet} {R : hrel (free_gr X)} {Y : gr} (g : monoidfun (presented_gr X R) Y) (H : iscomprelfun R (free_gr_extend (g ∘ presented_gr_intro))) : presented_gr_extend (g ∘ presented_gr_intro) H ~ g. Proof. unfold homot. apply setquotunivprop'. + intro. apply isasetmonoid. + intro x. refine (setquotunivcomm _ _ _ _ _ @ _). exact (free_gr_extend_comp (monoidfuncomp (presented_gr_pr R) g) _). Defined. Definition presented_gr_universal_property {X : hSet} (R : hrel (free_gr X)) (Y : gr) : monoidfun (presented_gr X R) Y ≃ ∑(f : X → Y), iscomprelfun R (free_gr_extend f). Proof. use weq_iso. - intro g. exact (tpair _ (g ∘ presented_gr_intro) (iscomprelfun_presented_grfun g)). - intro f. exact (presented_gr_extend (pr1 f) (pr2 f)). - intro g. apply monoidfun_paths, funextfun, presented_gr_extend_comp. - intro f. use total2_paths_f. + apply funextfun. intro x. reflexivity. + apply isapropiscomprelfun. Defined. Definition presented_grfun {X Y : hSet} {R : hrel (free_gr X)} {S : hrel (free_gr Y)} (f : X → Y) (H : iscomprelrelfun R S (free_grfun f)) : monoidfun (presented_gr X R) (presented_gr Y S). Proof. apply (presented_gr_extend (presented_gr_intro ∘ f)). intros x x' r. rewrite !(free_gr_extend_funcomp _ _ _). unfold funcomp. rewrite !(free_gr_extend_comp (presented_gr_pr S)). apply iscompsetquotpr. apply generated_binopeqrel_intro. exact (H x x' r). Defined. (* Free abelian group on a set *) Definition free_abgr_hrel (X : hSet) : hrel (free_gr X) := λ g h, ∃ x y, x * y = g × y * x = h. Lemma free_abgr_hrel_intro {X : hSet} (l1 l2 : free_gr X) : free_abgr_hrel X (l1 * l2) (l2 * l1). Proof. apply wittohexists with l1. split with l2. split; reflexivity. Defined. Lemma free_abgr_hrel_univ {X : hSet} (P : free_gr X → free_gr X → UU) (HP : ∏ (x y : free_gr X), isaprop (P x y)) (Hind : ∏ x y, P (x * y) (y * x)) (x y : free_gr X) : free_abgr_hrel X x y → P x y. Proof. apply (@hinhuniv _ (make_hProp (P x y) (HP x y))). intro v. induction v as (x',v). induction v as (y',v). induction v as (p1,p2). induction p1. induction p2. apply Hind. Defined. Definition free_abgr' (X : hSet) : gr := presented_gr X (free_abgr_hrel X). Lemma iscomm_free_abgr (X : hSet) : iscomm (@op (free_abgr' X)). Proof. refine (setquotuniv2prop' _ _ _). - intros. apply (isasetmonoid (free_abgr' X)). - intros x1 x2. apply (iscompsetquotpr _ (x1 * x2) (x2 * x1)). apply generated_binopeqrel_intro, free_abgr_hrel_intro. Defined. Definition free_abgr (X : hSet) : abgr := abgr_of_gr (free_abgr' X) (iscomm_free_abgr X). Definition free_abgr_pr (X : hSet) : monoidfun (free_gr X) (free_abgr X) := monoidquotpr _. Definition free_abgr_unit {X : hSet} (x : X) : free_abgr X := presented_gr_intro x. Definition free_abgr_extend {X : hSet} {Y : abgr} (f : X → Y) : monoidfun (free_abgr X) Y. Proof. apply (presented_gr_extend f). unfold iscomprelfun. apply free_abgr_hrel_univ. - intros. apply (isasetmonoid Y). - intros x y. rewrite !monoidfunmul. apply (commax Y). Defined. Lemma free_abgr_extend_homot {X : hSet} {Y : abgr} {f f' : X → Y} (h : f ~ f') : free_abgr_extend f ~ free_abgr_extend f'. Proof. unfold homot. apply setquotunivprop'. - intro x. apply isasetmonoid. - exact (free_gr_extend_homot h). Defined. Lemma free_abgr_extend_comp {X : hSet} {Y : abgr} (g : monoidfun (free_abgr X) Y): free_abgr_extend (g ∘ free_abgr_unit) ~ g. Proof. exact (presented_gr_extend_comp g _). Defined. Definition free_abgr_universal_property (X : hSet) (Y : abgr) : (X → Y) ≃ monoidfun (free_abgr X) Y. Proof. use weq_iso. - apply free_abgr_extend. - intro g. exact (g ∘ free_abgr_unit). - intro f. apply funextfun. intro x. reflexivity. - intro g. apply monoidfun_paths, funextfun, free_abgr_extend_comp. Defined. Definition free_abgrfun {X Y : hSet} (f : X → Y) : monoidfun (free_abgr X) (free_abgr Y) := free_abgr_extend (free_abgr_unit ∘ f). Lemma free_abgrfun_setquotpr {X Y : hSet} (f : X → Y) (x : free_gr X) : free_abgrfun f (setquotpr _ x) = setquotpr _ (free_grfun f x). Proof. refine (setquotunivcomm _ _ _ _ _ @ _). rewrite free_gr_extend_funcomp. exact (free_gr_extend_comp _ (free_grfun f x)). Defined. Lemma free_abgr_extend_funcomp {X Y : hSet} {Z : abgr} (f : X → Y) (g : Y → Z) : free_abgr_extend (g ∘ f) ~ free_abgr_extend g ∘ free_abgrfun f. Proof. unfold homot. apply setquotunivprop'. - intro. apply isasetmonoid. - intro x. refine (setquotunivcomm _ _ _ _ _ @ _). refine (free_gr_extend_funcomp _ _ x @ _). unfold funcomp. rewrite free_abgrfun_setquotpr. refine (!setquotunivcomm _ _ _ _ _). Defined. (* Abelian group presented by a set of generators and relations *) Definition presented_abgr (X : hSet) (R : hrel (free_abgr X)) : abgr := abgrquot (generated_binopeqrel R). Definition presented_abgr_pr {X : hSet} (R : hrel (free_abgr X)) : monoidfun (free_abgr X) (presented_abgr X R) := monoidquotpr _. Definition presented_abgr_intro {X : hSet} {R : hrel (free_abgr X)} : X → presented_abgr X R := presented_abgr_pr R ∘ free_abgr_unit. Definition presented_abgr_extend {X : hSet} {R : hrel (free_abgr X)} {Y : abgr} (f : X → Y) (H : iscomprelfun R (free_abgr_extend f)) : monoidfun (presented_abgr X R) Y. Proof. use monoidquotuniv. - exact (free_abgr_extend f). - exact (iscomprelfun_generated_binopeqrel _ H). Defined. Lemma iscomprelfun_presented_abgrfun {X : hSet} {R : hrel (free_abgr X)} {Y : abgr} (g : monoidfun (presented_abgr X R) Y) : iscomprelfun R (free_abgr_extend (g ∘ presented_abgr_intro)). Proof. intros x x' r. rewrite !(free_abgr_extend_comp (monoidfuncomp (presented_abgr_pr R) g)). apply (maponpaths (pr1 g)). apply iscompsetquotpr. exact (generated_binopeqrel_intro r). Defined. Lemma presented_abgr_extend_comp {X : hSet} {R : hrel (free_abgr X)} {Y : abgr} (g : monoidfun (presented_abgr X R) Y) (H : iscomprelfun R (free_abgr_extend (g ∘ presented_abgr_intro))) : presented_abgr_extend (g ∘ presented_abgr_intro) H ~ g. Proof. unfold homot. apply setquotunivprop'. + intro. apply isasetmonoid. + intro x. refine (setquotunivcomm _ _ _ _ _ @ _). exact (free_abgr_extend_comp (monoidfuncomp (presented_abgr_pr R) g) x). Defined. Definition presented_abgr_universal_property {X : hSet} (R : hrel (free_abgr X)) (Y : abgr) : monoidfun (presented_abgr X R) Y ≃ ∑(f : X → Y), iscomprelfun R (free_abgr_extend f). Proof. use weq_iso. - intro g. exact (tpair _ (g ∘ presented_abgr_intro) (iscomprelfun_presented_abgrfun g)). - intro f. exact (presented_abgr_extend (pr1 f) (pr2 f)). - intro g. apply monoidfun_paths, funextfun, presented_abgr_extend_comp. - intro f. use total2_paths_f. + apply funextfun. intro x. reflexivity. + apply isapropiscomprelfun. Defined. Definition presented_abgrfun {X Y : hSet} {R : hrel (free_abgr X)} {S : hrel (free_abgr Y)} (f : X → Y) (H : iscomprelrelfun R S (free_abgrfun f)) : monoidfun (presented_abgr X R) (presented_abgr Y S). Proof. apply (presented_abgr_extend (presented_abgr_intro ∘ f)). intros x x' r. rewrite !(free_abgr_extend_funcomp _ _ _). unfold funcomp. rewrite !(free_abgr_extend_comp (presented_abgr_pr S)). apply iscompsetquotpr. apply generated_binopeqrel_intro. exact (H x x' r). Defined. UniMath-20231010/UniMath/Algebra/GaussianElimination/000077500000000000000000000000001451125700300221545ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/GaussianElimination/Auxiliary.v000066400000000000000000000434771451125700300243310ustar00rootroot00000000000000(** * Matrices Miscellaneous background lemmas for [GaussianElimination.Elimination] Primary Author: Daniel @Skantz (November 2022) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Maybe. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.RigsAndRings. (** Results of this file are required for the [Elimination] subpackage but aren’t specifically part of the topic; probably could/should be upstreamed within [UniMath] *) (** * Logic *) Section Logic. (* not obvious how to deduce this from existing [isapropisdecprop] *) Lemma isaprop_dec_with_negProp {P : hProp} (Q : negProp P) : isaprop (P ⨿ Q). Proof. apply isapropcoprod. - apply propproperty. - apply propproperty. - intros p q; revert p. apply (negProp_to_neg q). Defined. End Logic. (** * Naturals *) (** Lemmas for standard functions on natural numbers *) Section Nat. Lemma natminus1lthn (n : nat) : n > 0 -> n - 1 < n. Proof. intros n_gt_0. apply natminuslthn. - assumption. - reflexivity. Defined. (* Next two lemmas are from PAdics.lemmas, restated here for accessibility. They are only used in this file, in the dualelement section. *) Lemma minussn1' ( n : nat ) : ( S n ) - 1 = n. Proof. destruct n; apply idpath. Defined. Local Lemma pathssminus' ( n m : nat ) ( p : natlth m ( S n ) ) : S ( n - m ) = ( S n ) - m. Proof. revert m p; induction n. intros m p; destruct m. {auto. } apply fromempty. apply nopathstruetofalse. apply pathsinv0. assumption. - intros m p. destruct m. + auto. + apply IHn. apply p. Defined. (* End duplicated proofs. *) Lemma eq_of_le_le {a b : nat} (le_a_b : a ≤ b) (le_b_a : b ≤ a) : a = b. Proof. destruct (natlehchoice _ _ le_a_b) as [lt_a_b | e_a_b]. 2: { assumption. } apply fromempty. eapply natlthtonegnatgeh; eassumption. Qed. Lemma prev_nat (n : nat) (p : n > 0): ∑ m, S m = n. Proof. destruct n as [| n]. { contradiction (negnatlthn0 _ p). } exists n; reflexivity. Defined. Lemma from_natneq_eq {X : UU} (m n : nat) : (m = n) -> (m ≠ n) -> X. Proof. intros m_eq_n m_neq_n. apply fromempty. destruct m_eq_n. eapply isirrefl_natneq. exact (m_neq_n). Defined. Lemma isaprop_nat_eq_or_neq {m n : nat} : isaprop ((m = n) ⨿ (m ≠ n)). Proof. refine (@isaprop_dec_with_negProp (_,,_) (natneq _ _)). apply isasetnat. Defined. Lemma nat_eq_or_neq_refl (i : nat) : nat_eq_or_neq i i = inl (idpath i). Proof. apply isaprop_nat_eq_or_neq. Defined. Lemma nat_eq_or_neq_left {i j: nat} (p : i = j) : nat_eq_or_neq i j = inl p. Proof. apply isaprop_nat_eq_or_neq. Defined. Lemma nat_eq_or_neq_right {i j: nat} (p : i ≠ j) : nat_eq_or_neq i j = inr p. Proof. apply isaprop_nat_eq_or_neq. Defined. Lemma min_le_l: ∏ a b : (nat), min a b ≤ a. Proof. intros; unfold min; revert a. induction b as [| b IH]; destruct a ; try reflexivity. apply IH. Defined. Lemma min_le_r: ∏ a b : (nat), min a b ≤ b. Proof. intros; unfold min; revert a. induction b as [| b IH]; destruct a ; try reflexivity. apply IH. Defined. Lemma min_le_iff : ∏ a b c : nat, (a ≤ min b c) <-> (a ≤ b ∧ a ≤ c). Proof. intros a b c; split. - intros le_a_mbc; split; eapply (istransnatleh le_a_mbc). + apply min_le_l. + apply min_le_r. - revert a c; induction b as [ | b' IH ]; intros a c [le_a_b le_a_c]. { intros; exact le_a_b. } (* case b = 0 *) destruct c as [ | c' ]. { exact le_a_c. } (* case c = 0 *) destruct a as [ | a' ]. { apply natleh0n. } (* case a = 0 *) (* when all successors, done by the reductions [ min (S b') (S c') ~~> S (min b' c') ] [ S x ≤ S y ~~> x ≤ y ] *) apply IH. split; assumption. Qed. (** All further properties of [min] should be derivable from [min_le_iff]: the inductive definition of [min] should never need unfolding again (though of course it can be, if that makes a proof nicer). *) Lemma min_of_le {a b : nat} (le_a_b : a ≤ b) : min a b = a. Proof. apply eq_of_le_le. - apply min_le_l. - apply min_le_iff. split; try assumption. apply isreflnatleh. Qed. Lemma min_comm (a b : nat) : min a b = min b a. Proof. apply eq_of_le_le; apply min_le_iff; split; auto using min_le_l, min_le_r. Qed. Lemma min_eq_a_or_eq_b : ∏ a b : (nat), coprod (min a b = a) (min a b = b). Proof. intros a b. destruct (natleorle a b) as [le_a_b | le_b_a]. - apply inl. apply min_of_le; assumption. - apply inr. rewrite min_comm. apply min_of_le; assumption. Qed. End Nat. (** * Standard finite sets *) (** lemmas for working with [Stn], the standard finite sets *) Section Stn. Lemma minabstn_to_astn { a b : nat } : ⟦ min a b ⟧%stn -> ⟦ a ⟧%stn. Proof. apply stnmtostnn, min_le_l. Defined. Lemma minabstn_to_bstn { a b : nat } : ⟦ min a b ⟧%stn -> ⟦ b ⟧%stn. Proof. apply stnmtostnn, min_le_r. Defined. Lemma stn_inhabited_implies_succ {n:nat} (i : ⟦ n ⟧%stn) : ∑ m, n = S m. Proof. destruct n as [| m]. - destruct i as [i le_i_0]. destruct (negnatlthn0 _ le_i_0). - exists m. apply idpath. Defined. Lemma isaprop_stn_eq_or_neq {n} (i j : ⟦n⟧%stn) : isaprop ((i = j) ⨿ (i ≠ j)). Proof. refine (@isaprop_dec_with_negProp (_,,_) (stnneq _ _)). apply isasetstn. Defined. Lemma stn_eq_or_neq_refl {n} {i : ⟦ n ⟧%stn} : stn_eq_or_neq i i = inl (idpath i). Proof. apply isaprop_stn_eq_or_neq. Defined. Lemma stn_eq_or_neq_left {n} {i j: (⟦ n ⟧)%stn} : forall p : i = j, stn_eq_or_neq i j = inl p. Proof. intros; apply isaprop_stn_eq_or_neq. Defined. Lemma stn_eq_or_neq_right {n} {i j : (⟦ n ⟧)%stn} : forall (p : i ≠ j), stn_eq_or_neq i j = inr p. Proof. intros; apply isaprop_stn_eq_or_neq. Defined. Lemma stn_implies_ngt0 { n : nat} (i : ⟦ n ⟧%stn) : n > 0. Proof. eapply natgthgehtrans. { exact (stnlt i). } apply natgehn0. Defined. Lemma stn_implies_nneq0 { n : nat } (i : ⟦ n ⟧%stn) : n ≠ 0. Proof. apply natgthtoneq, stn_implies_ngt0, i. Defined. Lemma snlehm_to_nltm (m n : nat) : (S n ≤ m) -> n < m. Proof. intros le_sn_m; exact le_sn_m. Defined. Lemma stn_eq {k : nat} (i j : stn k) (eq : pr1 i = pr1 j) : i = j. Proof. now apply subtypePath_prop. Defined. Lemma stn_eq_2 {k : nat} (i: stn k) (j : nat) (eq : pr1 i = j) (P : j < k) : i = (j,, P). Proof. intros; apply stn_eq, eq. Defined. (* perhaps generalise to a version for any [isincl], and use [isinclstntonat]? *) Lemma stn_eq_nat_eq { n : nat } (i j : ⟦ n ⟧%stn) : i = j <-> (pr1 i = pr1 j). Proof. split. - apply maponpaths. - apply subtypePath_prop. Defined. Lemma stn_neq_nat_neq { n : nat } (i j : ⟦ n ⟧%stn) : i ≠ j <-> (pr1 i ≠ pr1 j). Proof. split; apply idfun. Defined. Lemma issymm_stnneq {n : nat} {i j : stn n} (neq : i ≠ j) : (j ≠ i). Proof. apply issymm_natneq; assumption. Defined. Lemma prev_stn {n : nat} (i : ⟦ n ⟧%stn) (p : i > 0) : ∑ j : ⟦ n ⟧%stn, S j = i. Proof. destruct (prev_nat i p) as [j Sj_i]. use tpair. - exists j. refine (istransnatlth _ _ _ (natgthsnn j) _ ). rewrite Sj_i. apply (pr2 i). - exact Sj_i. Defined. (** General symmetry for decidable equality is tricky to state+prove (requires Hedberg’s theorem); but for non-dependent case-splits, it’s cleaner. *) (** Should also be generalisable using [negProp], ideally *) Lemma stn_eq_or_neq_symm_nondep {n} {x y : ⟦n⟧%stn} (de_xy : (x = y) ⨿ (x ≠ y)%stn) (de_yx : (y = x) ⨿ (y ≠ x)%stn) {Z} (z1 z2 : Z) : coprod_rect (fun _ => Z) (fun _ => z1) (fun _ => z2) de_xy = coprod_rect (fun _ => Z) (fun _ => z1) (fun _ => z2) de_yx. Proof. destruct de_xy as [e_xy | ne_xy]; destruct de_yx as [e_yx | ne_yx]; simpl; (** consistent cases: *) try reflexivity; (** inconsistent cases: *) eapply fromempty, nat_neq_to_nopath; try eassumption; apply pathsinv0, maponpaths; assumption. Defined. End Stn. (** Lemmas on the “dual” function on the standard finite sets, reversing the order *) (** Note: the definition of [dualelement] upstream has an unnecessary case split. We provide an alternative to simplify proofs in this section, that could potentially be upstreamed. *) Section Dual. Definition dualelement' {n : nat} (i : ⟦ n ⟧%stn) : ⟦ n ⟧%stn. Proof. refine (make_stn n (n - 1 - i) _). apply StandardFiniteSets.dualelement_lt. (* Make non-local upstream? *) now apply stn_implies_ngt0. Defined. Definition dualelement_defs_eq {n : nat} (i : ⟦ n ⟧%stn) : dualelement i = dualelement' i. Proof. unfold dualelement', dualelement. apply subtypePath_prop; simpl. destruct (natchoice0 _) as [eq0 | gt]; reflexivity. Defined. Lemma dualelement_2x {n : nat} (i : ⟦ n ⟧%stn) : dualelement (dualelement i) = i. Proof. do 2 rewrite dualelement_defs_eq; unfold dualelement'. unfold make_stn. apply subtypePath_prop; simpl. rewrite minusminusmmn; try reflexivity. apply natgthtogehm1, (pr2 i). Defined. Lemma dualelement_eq {n : nat} (i j : ⟦ n ⟧%stn) : dualelement i = j -> i = dualelement j. Proof. do 2 rewrite dualelement_defs_eq; unfold dualelement'. intros H; apply subtypePath_prop; revert H; simpl. intros eq; rewrite <- eq; simpl. rewrite minusminusmmn; try reflexivity. apply natlthsntoleh. apply natgthtogehm1, (pr2 i). Defined. Lemma dualelement_lt_comp {n : nat} (i j : ⟦ n ⟧%stn) : i < j -> (dualelement i) > (dualelement j). Proof. intros lt. do 2 rewrite dualelement_defs_eq; unfold dualelement'. apply minusgth0inv; simpl. rewrite natminusminusassoc, natpluscomm, <- natminusminusassoc, minusminusmmn. 2: {apply (natgthtogehm1 _ _ (pr2 j)). } apply (minusgth0 _ _ lt). Defined. Lemma dualelement_lt_comp' {n : nat} (i j : ⟦ n ⟧%stn) : (dualelement i) < (dualelement j) -> j < i. Proof. intros lt. pose (H := @dualelement_lt_comp _ (dualelement i) (dualelement j) lt). now do 2 rewrite dualelement_2x in H. Defined. Lemma dualelement_le_comp {n : nat} (i j : ⟦ n ⟧%stn) : i ≤ j -> (dualelement j) ≤ (dualelement i). Proof. intros le. destruct (natlehchoice i j) as [lt | eq]; try assumption. { apply natlthtoleh. apply (dualelement_lt_comp _ _ lt). } rewrite (stn_eq _ _ eq). apply isreflnatgeh. Defined. Lemma dualelement_le_comp' {n : nat} (i j : ⟦ n ⟧%stn) : (dualelement i) ≤ (dualelement j) -> j ≤ i. Proof. intros le. pose (H := @dualelement_le_comp _ (dualelement i) (dualelement j) le). now do 2 rewrite dualelement_2x in H. Defined. Lemma dualelement_lt_trans_2 {m n k q: nat} (p1 : n < k ) (p2 : n < q) (p3 : k < q) (lt_dual : m < dualelement (n,, p1)) : (m < (dualelement (n,, p2))). Proof. rewrite dualelement_defs_eq; unfold dualelement'. refine (istransnatlth _ _ _ _ _). {exact lt_dual. } rewrite dualelement_defs_eq. simpl; do 2 rewrite natminusminus. apply natlthandminusl; try assumption. refine (natlehlthtrans _ _ _ _ _); try assumption. 2: { exact p3. } rewrite natpluscomm. apply natlthtolehp1. exact p1; assumption. Defined. Lemma dualelement_sn_eq {m n k q: nat} (lt : S n < S k) : pr1 (dualelement (n,, lt)) = (pr1 (dualelement (S n,, lt))). Proof. do 2 rewrite dualelement_defs_eq; unfold dualelement'; simpl. now rewrite natminuseqn, natminusminus. Defined. Lemma dualelement_sn_le {m n k q: nat} (lt : S n < S k) : pr1 (dualelement (n,, lt)) <= (pr1 (dualelement (S n,, lt))). Proof. rewrite (@dualelement_sn_eq n n k k lt). apply isreflnatleh. Defined. Lemma dualelement_sn_le_2 {m n k q: nat} (lt : S n < S k) : pr1 (dualelement (n,, lt)) >= (pr1 (dualelement (S n,, lt))). Proof. rewrite (@dualelement_sn_eq n n k k lt). apply isreflnatleh. Defined. Lemma dualelement_sn_stn_nge_0 {n : nat} (i : stn n) : forall lt : (0 < S n), i >= (dualelement (0,, lt)) -> empty. Proof. intros lt gt. rewrite dualelement_defs_eq in gt; unfold dualelement' in gt. simpl in gt. do 2 rewrite natminuseqn in gt. contradiction (natgthtonegnatleh _ _ (pr2 i)). Defined. Lemma dualelement_sn_stn_ge_n {n : nat} (i : stn n) : i >= (dualelement (n,, natgthsnn n)). Proof. rewrite dualelement_defs_eq. simpl. rewrite (@natminuseqn _), minuseq0'. apply idpath. Defined. Lemma dualelement_lt_to_le_s {n k : nat} (i : stn n) (p : k < n) (leh: dualelement (k,, p) < i) : dualelement (k,, istransnatlth _ _ (S n) (natgthsnn k) p) <= i. Proof. rewrite dualelement_defs_eq; rewrite dualelement_defs_eq in leh; unfold dualelement' in leh |- *; simpl in leh |- *. rewrite natminuseqn. apply natgthtogehsn in leh. rewrite pathssminus' in leh. 2: { rewrite pathssminus'. - now rewrite minussn1'. - now apply (stn_implies_ngt0 i). } assert (e : n = S (n - 1)). { change (S (n - 1)) with (1 + (n - 1)). rewrite natpluscomm. apply pathsinv0, minusplusnmm, (natlthtolehp1 _ _ (stn_implies_ngt0 i)). } now destruct (!e). Defined. Lemma dualvalue_eq {X : UU} {n : nat} (v : ⟦ n ⟧%stn -> X) (i : ⟦ n ⟧%stn) : (v i) = (λ i' : ⟦ n ⟧%stn, v (dualelement i')) (dualelement i). Proof. simpl; now rewrite dualelement_2x. Defined. End Dual. (** * Rings, fields *) (** Lemmas on general rings and fields, and in particular their decidable equality *) Section Rings_and_Fields. Coercion multlinvpair_of_multinvpair {R : rig} (x : R) : @multinvpair R x -> @multlinvpair R x. Proof. intros [y [xy yx]]. esplit; eauto. Defined. Coercion multrinvpair_of_multinvpair {R : rig} (x : R) : @multinvpair R x -> @multrinvpair R x. Proof. intros [y [xy yx]]. esplit; eauto. Defined. Lemma ringplusminus {R: ring} (a b : R) : (a + b - b)%ring = a. Proof. rewrite ringassoc1. rewrite ringrinvax1. apply (rigrunax1 R). Defined. Lemma ringminusdistr' { X : commring } ( a b c : X ) : (a * (b - c))%ring = (a * b - a * c)%ring. Proof. intros. rewrite ringldistr. rewrite ringrmultminus. apply idpath. Defined. Lemma fldchoice0 {X : fld} (e : X) : coprod (e = 0%ring) (e != 0%ring). Proof. destruct (fldchoice e) as [ x_inv | x_0 ]. - right. apply isnonzerofromrinvel. { apply nonzeroax. } exact x_inv. - left; assumption. Defined. Lemma fldchoice0_left {X : fld} (e : X) (eq : (e = 0)%ring): (fldchoice0 e) = inl eq. Proof. apply isapropdec, setproperty. Defined. Lemma fldchoice0_right {X : fld} (e : X) (neq : (e != 0)%ring): (fldchoice0 e) = inr neq. Proof. apply isapropdec, setproperty. Defined. Lemma fldmultinvlax {X: fld} (e : X) (ne : e != 0%ring) : (fldmultinv e ne * e)%ring = 1%ring. Proof. exact (pr1 (pr2 (fldmultinvpair _ e ne))). Defined. Lemma fldmultinvrax {X: fld} (e : X) (ne : e != 0%ring) : (e * fldmultinv e ne)%ring = 1%ring. Proof. exact (pr2 (pr2 (fldmultinvpair _ e ne))). Defined. Definition fldmultinv' {X : fld} (e : X) : X. Proof. destruct (fldchoice0 e) as [eq0 | neq]. - exact 0%ring. - exact (fldmultinv e neq). Defined. Lemma fldmultinvlax' {X: fld} (e : X) (ne : e != 0%ring) : (fldmultinv' e * e)%ring = 1%ring. Proof. unfold fldmultinv'. destruct (fldchoice0 _). - contradiction. - apply fldmultinvlax. Defined. Lemma fldmultinvrax' {X: fld} (e : X) (ne : e != 0%ring) : (e * fldmultinv' e)%ring = 1%ring. Proof. unfold fldmultinv'. destruct (fldchoice0 _). - contradiction. - apply fldmultinvrax. Defined. End Rings_and_Fields. (** * Rationals. Commented out to respect import dependency ordering. Could be downstreamed or removed. *) (* Section Rationals. Lemma hqone_neq_hqzero : 1%hq != 0%hq. Proof. intro contr. assert (contr_hz : intpart 1%hq != intpart 0%hq). { unfold intpart. apply hzone_neg_hzzero. } apply contr_hz. apply maponpaths, contr. Defined. (* A more obvious approach might be to use the injectivity of the map from the integers: [apply hzone_neg_hzzero; refine (invmaponpathsincl _ isinclhztohq 1%hz 0%hz contr).] However, this turns out very slow, apparently because recognising [hztohq 1%hz = 1%hq] is slow (and similarly for 0). Seems surprising that this is slower than computing [intpart 1%hq = 1%hz]! *) Lemma hqplusminus (a b : hq) : (a + b - b)%hq = a. Proof. apply (@ringplusminus hq). Defined. End Rationals. *) (** * Maybe *) (** Lemmas on the general “maybe” construction *) Section Maybe. Lemma isdeceqmaybe {X : UU} (dec : isdeceq X) : isdeceq (maybe X). Proof. apply isdeceqcoprod. - exact dec. - exact isdecequnit. Defined. Definition maybe_choice {X : UU} (e : maybe X) : coprod (e != nothing) (e = nothing). Proof. destruct e as [? | u]. - apply ii1. apply negpathsii1ii2. - apply ii2. now induction u. Defined. Definition maybe_choice' {X : UU} (e : maybe X) : coprod (∑ x:X, e = just x) (e = nothing). Proof. destruct e as [x | u]. - apply ii1. exists x; reflexivity. - apply ii2. now induction u. Defined. Definition from_maybe {X : UU} (m : maybe X) (p : m != nothing) : X. Proof. unfold nothing in p. destruct m as [x | u]. - exact x. - contradiction p. now induction u. Defined. End Maybe. UniMath-20231010/UniMath/Algebra/GaussianElimination/Corollaries.v000066400000000000000000000700651451125700300246310ustar00rootroot00000000000000 Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Nat. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.GaussianElimination.Auxiliary. Require Import UniMath.Algebra.GaussianElimination.Vectors. Require Import UniMath.Algebra.GaussianElimination.Matrices. Require Import UniMath.Algebra.GaussianElimination.Elimination. (** In this module, we define a back-substitution procedure that works on nxn matrices that are upper triangular with all non-zero diagonal. We use this procedure to show that any nxn matrix either not invertible, or calculate its inverse. Primary Author: Daniel @Skantz (November 2022) *) Definition matrix_inverse_or_non_invertible_stmt { n : nat } {F : fld} (A : Matrix F n n) := coprod (@matrix_inverse F n A) (@matrix_inverse F n A -> empty). Definition back_sub_stmt { n : nat } {F : fld} (mat : Matrix F n n) (vec : Vector F n) (ut : @is_upper_triangular F _ _ mat) (df : @diagonal_all_nonzero F _ mat) := ∑ v : (Vector F n), (@matrix_mult F _ _ mat _ (col_vec v)) = (col_vec vec). Section BackSub. Context (F : fld). Local Notation Σ := (iterop_fun (@ringunel1 F) op1). Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). (** output: a solution [x]_[row] to [mat ** x = b]_[row] if one exists - given mat upper triangular, non-zero diagonal. Later applied inductively in [back_sub]. *) Definition back_sub_step { n : nat } ( row : (⟦ n ⟧)%stn ) (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) : Vector F n. Proof. intros i. destruct (nat_eq_or_neq row i). - exact (((b i) * fldmultinv' (mat i i)) - ((Σ (mat i *pw x) - (x i)* (mat i i)) * (fldmultinv' (mat i i))))%ring. - exact (x i). Defined. (** procedure gives [x_i] s.t. [(mat ** x)_i = b_i], given previous assumptions *) Lemma back_sub_step_inv0 { n : nat } (row : ⟦ n ⟧%stn) (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (p: @is_upper_triangular F n n mat) (p' : (mat row row != 0)%ring) : (mat ** (col_vec (back_sub_step row mat x b))) row = (col_vec b) row. Proof. unfold back_sub_step, col_vec. unfold fldmultinv'. rewrite matrix_mult_eq; unfold matrix_mult_unf, pointwise. set (m := n - (S row)). assert (split_eq : n = (S row) + m). { unfold m. rewrite natpluscomm, minusplusnmm. - apply idpath. - exact (pr2 row). } destruct (stn_inhabited_implies_succ row) as [s_row s_row_eq], (!s_row_eq). apply funextfun; intros ?. rewrite (@vecsum_dni _ (s_row) _ row) , nat_eq_or_neq_refl. destruct (fldchoice0 _) as [? | neq]. {contradiction. } etrans. { apply maponpaths_2; apply maponpaths. apply funextfun; intros q. unfold funcomp. now rewrite (nat_eq_or_neq_right (dni_neq_i row q)). } rewrite (@vecsum_dni F (s_row) _ row). etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite (@ringcomm2 F). apply maponpaths. now rewrite (@ringcomm2 F). } apply (@ringminusdistr' F (mat row row)). } etrans. { apply maponpaths; apply map_on_two_paths. - rewrite <- (@rigassoc2 F), (@fldmultinvrax F). { now rewrite (@riglunax2 F). } - apply maponpaths. rewrite <- (@rigassoc2 F), (@fldmultinvrax F). apply (@riglunax2 F). } etrans. { do 3 apply maponpaths. now rewrite (@rigcomm2 F), (@ringplusminus F). } rewrite (@rigcomm1 F); rewrite (@rigassoc1 F). now rewrite (@ringlinvax1 F), (@rigrunax1 F). Defined. (** [back_sub_step] only modifies target element *) Lemma back_sub_step_inv1 { n : nat } (row : ⟦ n ⟧%stn) (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) : ∏ i : ⟦ n ⟧%stn, i ≠ row -> (col_vec (back_sub_step row mat x b) i = (col_vec x) i). Proof. intros i ne. unfold back_sub_step, col_vec. apply funextfun. intros j; simpl. destruct (nat_eq_or_neq row i) as [eq | ?]; try apply idpath. rewrite eq in ne. contradiction (isirrefl_natneq _ ne). Defined. Lemma back_sub_step_inv2 { n : nat } (row : ⟦ n ⟧%stn) (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (is_ut: @is_upper_triangular F n n mat) : ∏ i : ⟦ n ⟧%stn, i ≥ row -> (mat i i != 0)%ring -> (mat ** (col_vec x)) i = (col_vec b) i -> (mat ** (col_vec (back_sub_step row mat x b))) i = (col_vec b) i. Proof. unfold transpose, flip. intros i le neq0 H. rewrite <- H. destruct (natlehchoice row i) as [lt | eq]. {apply le. } - rewrite matrix_mult_eq in *. apply pathsinv0. rewrite matrix_mult_eq. unfold matrix_mult_unf in *. apply funextfun; intros ?. apply maponpaths, funextfun; intros i'. destruct (stn_eq_or_neq i' (row)) as [eq | neq]. 2 : { now rewrite back_sub_step_inv1. } rewrite is_ut. 2: { rewrite eq. assumption. } do 2 rewrite (@rigmult0x F). apply idpath. - rewrite (stn_eq _ _ eq) , back_sub_step_inv0; try assumption. now rewrite H. Defined. (** Back-substituting repeatedly using step procedure defined earlier. Carries an additional [row] parameter that allows for partially applying the substition, that is used later for showing that diagonal must be non-zero. *) Definition back_sub_internal { n : nat } (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (sep : ⟦ S n ⟧%stn) (row : ⟦ S n ⟧%stn) : Vector F n. Proof. destruct sep as [sep p]. induction sep as [| m IH]. {exact x. } destruct (natlthorgeh (dualelement (m,, p)) row). 2: {exact x. } refine (back_sub_step (dualelement (m,, p)) mat (IH _) b). apply (istransnatlth _ _ _ (natgthsnn m) p). Defined. Lemma back_sub_internal_inv0 { n : nat } (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (ut : @is_upper_triangular F _ _ mat) (sep : ⟦ S n ⟧%stn) (row : ⟦ S n ⟧%stn) : ∏ (i : ⟦ n ⟧%stn), i >= row -> (col_vec (back_sub_internal mat x b sep row)) i = (col_vec x) i. Proof. destruct sep as [sep p]. induction sep as [| sep IH]. { intros i H; now destruct (natchoice0 (S n)) in H. } unfold back_sub_internal. intros i i_lt_row. rewrite nat_rect_step. destruct (natlthorgeh _ _) as [lt | geh]. 2: {reflexivity. } assert (p': sep < S n). { apply (istransnatlth _ _ _ (natgthsnn sep) p). } rewrite <- (IH p'); try assumption. unfold back_sub_internal. rewrite back_sub_step_inv1; try easy. {apply maponpaths_2, maponpaths, proofirrelevance, propproperty. } apply natgthtoneq. refine (natlthlehtrans _ _ _ lt i_lt_row). Defined. Lemma back_sub_internal_inv1 { n : nat } (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (ut : @is_upper_triangular F _ _ mat) (sep : ⟦ S n ⟧%stn) (row : ⟦ S n ⟧%stn) : ∏ i : stn n, i >= row -> (back_sub_internal mat x b sep row) i = x i. Proof. intros. rewrite (@col_vec_inj_pointwise F n (back_sub_internal mat x b sep row) x i). - apply idpath. - now apply (back_sub_internal_inv0). Defined. Lemma back_sub_internal_inv2 { n : nat } (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) (ut : @is_upper_triangular F _ _ mat) (sep : ⟦ S n ⟧%stn) (row : ⟦ S n ⟧%stn) : ∏ (i : ⟦ n ⟧%stn), i ≥ (dualelement sep) -> (mat i i != 0)%ring -> i < row -> (mat ** (col_vec (back_sub_internal mat x b sep row))) i = (col_vec b) i. Proof. unfold transpose, flip. intros i i_le_sep neq0 lt. unfold back_sub_internal. destruct sep as [sep p]. induction sep as [| sep IH]. { apply fromempty, (dualelement_sn_stn_nge_0 _ _ i_le_sep). } rewrite nat_rect_step. destruct (natlehchoice (dualelement (sep,, p)) i) as [leh | eq]. { refine (istransnatleh _ i_le_sep). now apply (@dualelement_sn_le). } - destruct (natlthorgeh _ _) as [? | contr_geh]. 2 : { contradiction (isirreflnatlth _ (natlthlehtrans _ _ _ (istransnatlth _ _ _ leh lt) contr_geh)). } rewrite back_sub_step_inv2; try easy. { unfold dualelement. unfold dualelement in leh. destruct (natchoice0 _) as [contr_eq | ?]. {apply fromstn0. now rewrite contr_eq. } now apply natgthtogeh. } rewrite IH; try reflexivity. now apply dualelement_lt_to_le_s. - destruct (natlthorgeh _ _) as [? | contr_geh]. + rewrite (stn_eq _ _ eq). now rewrite back_sub_step_inv0. + rewrite <- (stn_eq _ _ eq) in lt. contradiction (isirreflnatlth _ (natlthlehtrans _ _ _ lt contr_geh)). Defined. Definition back_sub {n : nat} (mat : Matrix F n n) (vec : Vector F n) := back_sub_internal mat vec vec (n,, natgthsnn _) (n,, natgthsnn _). Lemma back_sub_inv0 { n : nat } (mat : Matrix F n n) (b : Vector F n) (ut : @is_upper_triangular F _ _ mat) (df : @diagonal_all_nonzero F _ mat) : back_sub_stmt mat b ut df. Proof. exists (back_sub mat b). intros; unfold back_sub. destruct (natchoice0 n) as [eq0 | ?]. { apply funextfun. intros i. apply fromstn0. now rewrite eq0. } apply funextfun; intros i. apply back_sub_internal_inv2; try assumption; unfold dualelement; try easy. 2: {exact (pr2 i). } destruct (natchoice0 _) as [eq0 | ?]. { apply fromempty; now apply negpaths0sx in eq0. } simpl; now rewrite natminuseqn, minuseq0'. Defined. End BackSub. Section BackSubZero. (** First, Helper functions for finding first zero value in a vector. Then proof we can't have invertible, upper triangular matrix unless non-zero diagonal *) Context (F : fld). Local Notation Σ := (iterop_fun (@ringunel1 F) op1). Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). Local Notation "0" := (@rigunel1 F). (* For using nonzeroax *) Local Definition flip_fld_bin (e : F) : F. Proof. destruct (fldchoice0 e). - exact 1%ring. - exact 0%ring. Defined. Local Definition flip_fld_bin_vec {n : nat} (v : Vector F n) := λ i : (stn n), flip_fld_bin (v i). (* Below, we find the first zero value in a vector [v] by looking for the leading element in the transformed vector. Perhaps not a pretty solution, maybe we instead want to generalize the notion of leading entry. *) Local Definition vector_all_nonzero_compute_internal {n : nat} (v : Vector F n) : coprod (∏ j : (stn n), (v j) != 0%ring) (∑ i : (stn n), ((v i) = 0%ring) × (forall j : stn n, (j < (pr1 i) -> (v j) != 0%ring))). Proof. pose (leading_entry := leading_entry_compute F (flip_fld_bin_vec v)). destruct (maybe_choice' leading_entry) as [some | none]. - right; use tpair; simpl. {apply some. } destruct (@leading_entry_compute_inv2 F _ (flip_fld_bin_vec v) (pr1 some) (pr2 some)) as [some_neq_0 prev_eq_0]. unfold is_leading_entry, flip_fld_bin_vec, flip_fld_bin in * |-. destruct (fldchoice0 (v _)); try contradiction. use tpair; try assumption. intros ? lt. specialize (prev_eq_0 _ lt). now destruct (fldchoice0 (v j)). - left; intros j. rewrite <- (@leading_entry_compute_inv1 _ _ (flip_fld_bin_vec v) none j). try apply (pr2 (dualelement j)). destruct (fldchoice0 (v j)) as [eq | neq]; unfold is_leading_entry, flip_fld_bin_vec, flip_fld_bin in * ; destruct (fldchoice0 _); try assumption. + rewrite eq; intros contr_neq. contradiction (nonzeroax _ (pathsinv0 contr_neq)). + destruct (fldchoice0 (v j)) as [contr_eq | ?]. * rewrite contr_eq in neq. contradiction. * contradiction. Defined. Local Definition vector_all_nonzero_compute {n : nat} (v : Vector F n) : coprod (∏ j : (stn n), (v j) != 0%ring) (∑ i : (stn n), (v i) = 0%ring). Proof. destruct (@vector_all_nonzero_compute_internal n v) as [l | r]. {now left. } right; exists (pr1 r); exact (pr1 (pr2 r)). Defined. (** Showing that right invertible matrix, upper triangular, must have all non-zero diagonal. *) (** Ax = 0 would have two solutions for x, but A invertible... *) Lemma back_sub_zero { n : nat } (mat : Matrix F n n) (ut : @is_upper_triangular F _ _ mat) (zero: ∑ i : stn n, (mat i i = 0)%ring × (forall j : stn n, j < i -> ((mat j j) != 0)%ring)) (inv : @matrix_left_inverse F _ _ mat) : empty. Proof. unfold transpose, flip. destruct (natchoice0 (pr1 zero)) as [eq0_1 | gt]. { apply (zero_row_to_non_right_invertibility (transpose mat) (pr1 zero)); try assumption. 2: { now apply (@matrix_left_inverse_to_transpose_right_inverse F). } apply funextfun; intros k. destruct (natchoice0 k) as [eq0_2 | ?]. - rewrite <- (pr1 (pr2 zero)). unfold const_vec. rewrite eq0_1 in eq0_2. now rewrite (stn_eq _ _ eq0_2). - unfold transpose, flip. rewrite ut; try reflexivity. now rewrite <- eq0_1. } assert (contr_exists : ∑ x : (Vector F n), (∑ i' : stn n, (x i' != 0) × (mat ** (col_vec x)) = (@col_vec F _ (const_vec 0)))). 2: { assert (eqz : (mat ** (@col_vec F _ (const_vec 0))) = (@col_vec F _ (const_vec 0))). { rewrite matrix_mult_eq; unfold matrix_mult_unf. apply funextfun; intros k. unfold col_vec, const_vec. etrans. { rewrite vecsum_eq_zero. - apply idpath. - intros ?; apply rigmultx0. } reflexivity. } assert (contr_eq' : (@ringunel1 F) != (@ringunel1 F)). 2: {contradiction. } rewrite <- eqz in contr_exists. destruct contr_exists as [x1 [x2 [x3 contr_exists]]]. destruct inv as [inv isinv]. rewrite <- contr_exists in eqz. assert (eq : @matrix_mult F _ _ inv _ (@matrix_mult F _ _ mat _ (col_vec x1)) = @matrix_mult F _ _ inv _ (@col_vec F _ (const_vec 0))). {now rewrite eqz. } rewrite <- matrix_mult_assoc, isinv, matlunax2 in eq. pose (eq' := @matrix_mult_zero_vec_eq _ _ _ inv). unfold col_vec, const_vec in * |-. rewrite eq' in eq. destruct zero as [zero iszero]. apply toforallpaths in eq. set (idx0 := (make_stn _ 0 (stn_implies_ngt0 zero))). assert (contr_eq' : (λ (_ : _) (_ : _), (@rigunel1 F)) idx0 = (λ (_ : _) (_ : (⟦ 1 ⟧)%stn), x1 x2) idx0 ). { now rewrite eq. } apply toforallpaths in contr_eq'. rewrite contr_eq' in x3. 2: { exact (make_stn _ _ (natgthsnn 0)). } contradiction. } destruct zero as [zero iszero]. use tpair. { apply back_sub_internal. - exact mat. - intros j. destruct (natlthorgeh (pr1 zero) j). + exact 0. + destruct (natgehchoice (pr1 zero) j); try assumption. * exact 0. * exact (@rigunel2 F). - exact (const_vec 0). - exact (n,, natgthsnn _). - exact (pr1 zero,, (istransnatlth _ _ _ (pr2 zero) (natgthsnn _))). } exists zero. use tpair. - rewrite back_sub_internal_inv1; try assumption. 2: {apply isreflnatleh. } destruct (natlthorgeh _ _) as [lt | ge]. * contradiction (isirreflnatgth _ lt). * simpl; clear gt. destruct (natgehchoice _ _) as [gt | eq]. {contradiction (isirreflnatlth _ gt). } apply (@nonzeroax F). - apply funextfun; intros j. destruct (natlthorgeh j zero) as [? | ge]. + rewrite back_sub_internal_inv2; try easy. * apply dualelement_sn_stn_ge_n. * now apply (pr2 iszero). + rewrite matrix_mult_eq; unfold matrix_mult_unf. unfold col_vec, const_vec. apply funextfun; intros ?. eapply (@vecsum_eq_zero F). intros k. destruct (natgthorleh j k) as [? | le]. {rewrite ut; try assumption; apply rigmult0x. } destruct (stn_eq_or_neq (zero) k) as [eq | ?]. * rewrite <- eq in *. rewrite <- (stn_eq _ _ (isantisymmnatgeh _ _ le ge)). rewrite (pr1 iszero); apply rigmult0x. * etrans. 2: {apply rigmultx0. } apply maponpaths. rewrite back_sub_internal_inv1; try assumption. 2: {apply (istransnatleh ge le). } destruct (natlthorgeh _ _) as [? | ?]; try reflexivity. destruct (natgehchoice _ _) as [? | eq]; try reflexivity. rewrite (stn_eq _ _ eq) in * |-. contradiction (isirrefl_natneq k). Defined. End BackSubZero. (** Some results that are useful in the next section. *) Section Misc. Context (F: fld). (** Row echelon form implies upper triangularity*) Lemma row_echelon_partial_to_upper_triangular_partial { m n : nat } (mat : Matrix F m n) (p : n > 0) (iter : ⟦ S m ⟧%stn) : @is_row_echelon_partial F m n mat iter -> @is_upper_triangular_partial F m n iter mat. Proof. unfold is_row_echelon_partial, is_upper_triangular_partial. destruct iter as [iter p']. unfold is_row_echelon_partial_1, is_row_echelon_partial_2. induction iter as [| iter IH]. { intros ? ? ? ? contr; contradiction (negnatlthn0 n contr). } intros [re_1 re_2] i j lt lt'. simpl in p'. pose (iter_lt_sn := (istransnatlth _ _ _ p' (natgthsnn m))). destruct (natlehchoice i iter) as [? | eq]. {now apply natlthsntoleh. } - destruct (maybe_choice' (leading_entry_compute _ (mat i))) as [t | none]. + destruct t as [t eq]. rewrite (IH iter_lt_sn); try easy. use tpair; simpl. * intros i_1 i_2 j_1 j_2 i1_lt_iter H ? ?. rewrite (re_1 i_1 i_2 j_1 j_2); try easy. apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)). * intros i_1 i_2 i1_lt_iter ? ?; rewrite (re_2 i_1 i_2); try easy. apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)). + now rewrite (leading_entry_compute_inv1 _ _ none). - assert (eq' : i = (iter,, p')). { apply subtypePath_prop; apply eq. } destruct (maybe_choice' (leading_entry_compute F (mat i))) as [[t jst] | none]. 2: { now rewrite (leading_entry_compute_inv1 _ _ none). } destruct (natlthorgeh j t) as [j_lt_t | contr_gt]. { rewrite (pr2 (leading_entry_compute_inv2 _ _ _ jst)); try easy. } pose (H1 := leading_entry_compute_inv2 _ _ _ jst). destruct (natchoice0 i) as [contr0 | ?]. { apply fromempty; refine (negnatgth0n _ _); rewrite contr0; apply lt. } destruct (prev_stn i) as [u u_lt]; try assumption. destruct (maybe_choice' (leading_entry_compute _ (mat u))) as [[prev eq''] | none_prev]. + pose (H2 := (leading_entry_compute_inv2 _ _ _ eq'')). contradiction (pr1 H2); rewrite (IH iter_lt_sn); try easy. * use tpair; simpl. -- intros i_1 i_2 j_1 j_2 i1_lt_iter H' ? ?. rewrite (re_1 i_1 i_2 j_1 j_2); try easy. apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)). -- intros i_1 i_2 i1_lt_iter ? ?; rewrite (re_2 i_1 i_2); try easy. apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn _)). * destruct (natgthorleh u prev) as [gt | leh]; try assumption. contradiction (pr1 H1); rewrite (re_1 u i t prev); try easy. -- apply natgehsntogth; rewrite u_lt, eq'; apply natgehsnn. -- apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh. -- destruct (natgthorleh t prev) as [gt | leh']; try assumption. apply (istransnatleh contr_gt); refine (istransnatleh _ leh). apply natlehsntolth, natlthsntoleh; rewrite u_lt; apply lt. * apply natgehsntogth; rewrite u_lt, eq'; apply (isreflnatleh). + rewrite (re_2 u i ); try easy. * simpl; apply natlthtolths. rewrite <- eq. try apply (natlehlthtrans _ _ _ contr_gt lt ). apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh. * apply funextfun; intros j'; rewrite ((leading_entry_compute_inv1 _ _ none_prev) j'); reflexivity. * try apply (natlehlthtrans _ _ _ contr_gt lt). apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh. Defined. Lemma row_echelon_to_upper_triangular { m n : nat } (mat : Matrix F m n) : is_row_echelon mat -> @is_upper_triangular F _ _ mat. Proof. destruct (natchoice0 n) as [contr_eq0 | p]. { intros ? ? j; apply fromstn0; now rewrite contr_eq0. } intros H; unfold is_upper_triangular; intros. rewrite (row_echelon_partial_to_upper_triangular_partial mat p (m,, natgthsnn _)) ; try easy. 2: {exact (pr2 i). } use tpair; intros i_1 i_2 j_1 j_2; intros; simpl. - destruct (H i_1 i_2) as [H1 _]; now rewrite (H1 j_2 j_1). - destruct (H i_1 i_2) as [_ H2]; now rewrite H2. Defined. End Misc. Section Inverse. (** Some additional properties of matrix inverses, having now defined Gaussian elimination and back-substitution. Computes a matrix inverse or shows it is non-invertible. *) Context (F : fld). Local Notation Σ := (iterop_fun (@ringunel1 F) op1). Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). (** Construct the inverse, if additionally mat is upper triangular with non-zero diagonal *) Definition upper_triangular_right_inverse_construction { n : nat } (mat : Matrix F n n) := transpose (λ i : (stn n), (back_sub _ mat (@identity_matrix F n i))). Lemma left_invertible_upper_triangular_to_diagonal_all_nonzero {n : nat } (A : Matrix F n n) (p : @is_upper_triangular F _ _ A) (p': @matrix_left_inverse F _ _ A) : (@diagonal_all_nonzero F _ A). Proof. destruct (@vector_all_nonzero_compute_internal _ _ (@diagonal_sq F _ A)) as [l | r]. { unfold diagonal_all_nonzero; intros; unfold diagonal_sq in l; apply l. } unfold diagonal_sq in r; apply fromempty; now apply (@back_sub_zero _ _ A p). Defined. Lemma matrix_right_inverse_construction_inv { n : nat } (mat : Matrix F n n) (ut : @is_upper_triangular F _ _ mat) (df: @diagonal_all_nonzero F _ mat) : (mat ** (upper_triangular_right_inverse_construction mat)) = (@identity_matrix F n). Proof. apply funextfun; intros i. unfold matrix_mult, row, col, transpose, flip. apply funextfun; intros ?. unfold upper_triangular_right_inverse_construction. rewrite (@col_vec_mult_eq F _ _ mat _ (@identity_matrix F _ x)). - destruct (stn_eq_or_neq i x) as [eq | neq]. { now rewrite eq. } rewrite id_mat_ij; try rewrite id_mat_ij; try easy. apply (issymm_natneq _ _ neq). - unfold upper_triangular_right_inverse_construction. pose (back_sub_inv := @back_sub_inv0). destruct (natchoice0 n) as [eq | ?]. {apply fromstn0; now rewrite eq. } apply (back_sub_inv _ _ _ _ ut df). Defined. Lemma matrix_left_inverse_implies_right { n : nat } (A B: Matrix F n n) : (B ** A) = (@identity_matrix F n) -> (@matrix_right_inverse F n n A). Proof. intros ?. destruct (natchoice0 n) as [eq0 | gt]. { destruct eq0; now use tpair. } pose (C := pr1 (gaussian_elimination _ A)). pose (is_gauss := pr2 (gaussian_elimination _ A)). destruct is_gauss as [inv is_re]. pose (CA := C ** A). pose (D := @upper_triangular_right_inverse_construction _ CA). exists (D ** C). assert (CA_ut : is_upper_triangular CA). { apply (@row_echelon_to_upper_triangular _ _ _ CA), is_re. } assert (nonz : @diagonal_all_nonzero F _ CA). { apply left_invertible_upper_triangular_to_diagonal_all_nonzero; try assumption. apply left_inv_matrix_prod_is_left_inv. - exists (pr1 inv). apply (pr2 (pr2 inv)). - now exists B. } pose (invmat := @matrix_right_inverse_construction_inv _ _ CA_ut nonz). unfold CA in invmat. rewrite matrix_mult_assoc in invmat. assert (eq : (C ** A ** D) = (A ** D ** C)). { unfold CA in invmat. unfold D, CA. rewrite matrix_mult_assoc, invmat. pose (left_inv_eq_right := @matrix_left_inverse_equals_right_inverse). apply pathsinv0. pose (gauss_mat_invertible := inv). apply (matrix_inverse_to_right_and_left_inverse) in gauss_mat_invertible. destruct gauss_mat_invertible as [gauss_mat gauss_mat_invertible]. pose (left_inv_eq_right_app := left_inv_eq_right F n _ n C gauss_mat ((A ** D),, invmat)). set (constr := (upper_triangular_right_inverse_construction (@matrix_mult F _ _ C _ A))). assert (eq: (@matrix_mult F _ _ A n constr) = (pr1 gauss_mat)). { apply pathsinv0. apply (left_inv_eq_right_app). } rewrite eq. apply gauss_mat. } refine (_ @ invmat); rewrite <- matrix_mult_assoc; refine (!eq @ _). apply matrix_mult_assoc. Defined. Lemma matrix_right_inverse_implies_left { n : nat } (A B: Matrix F n n) : @matrix_right_inverse F _ _ A -> (@matrix_left_inverse F _ _ A). Proof. intros [rinv isrinv]. pose (linv := @make_matrix_left_inverse F _ _ n A rinv isrinv). pose (linv_to_rinv := @matrix_left_inverse_implies_right _ _ _ isrinv). exists rinv. pose (inv_eq := @matrix_left_inverse_equals_right_inverse _ n _ n _ linv linv_to_rinv). simpl in inv_eq; rewrite inv_eq; apply linv_to_rinv. Defined. Theorem matrix_inverse_or_non_invertible { n : nat } (A : Matrix F n n) : @matrix_inverse_or_non_invertible_stmt _ _ A. Proof. unfold matrix_inverse_or_non_invertible_stmt. destruct (natchoice0 n) as [eq0 | gt]. { left; destruct eq0; apply (@nil_matrix_invertible F 0 A). } set (B:= @gauss_clear_all_rows_as_left_matrix _ _ _ A gt). set (BA := B ** A). set (C := upper_triangular_right_inverse_construction BA). assert (ut : is_upper_triangular BA). { unfold BA. pose (is_echelon := @gauss_clear_all_rows_inv3 F _ _ A gt). rewrite <- (gauss_clear_all_rows_as_matrix_eq _ _ gt) in is_echelon. now apply row_echelon_to_upper_triangular. } destruct (vector_all_nonzero_compute _ (λ i : stn n, BA i i)) as [nz | [idx isnotz]]. - left. set (BAC_id := @matrix_right_inverse_construction_inv _ _ ut nz). assert (rinv_eq : (C ** BA) = identity_matrix). { apply (@matrix_right_inverse_implies_left _ _ C (C,, BAC_id)). } exists (C ** B); simpl; use tpair. 2: { simpl; rewrite matrix_mult_assoc; apply rinv_eq. } rewrite <- matrix_mult_assoc. unfold BA in BAC_id. assert (linv_eq : ((B ** A ** C) = (A ** C ** B))). { rewrite matrix_mult_assoc in BAC_id |- *. unfold C in *; clear C; set (C := (upper_triangular_right_inverse_construction BA)). pose (B_rinv := @make_matrix_right_inverse F _ _ n B (A ** C) BAC_id). pose (linv := @matrix_right_inverse_implies_left _ _ C B_rinv). pose (eq := @matrix_left_inverse_equals_right_inverse F n _ n B linv ((A ** C),, BAC_id)). etrans. { change (@matrix_mult F _ _ A _ C) with (pr1 B_rinv). rewrite (pr2 B_rinv); reflexivity. } change (pr1 (@matrix_mult F _ _ A _ C,, BAC_id)) with (@matrix_mult F _ _ A _ C) in *. rewrite <- eq, (pr2 linv). apply idpath. } simpl in * |- ; now rewrite <- BAC_id, <- linv_eq. - right. intros [invM [isl isr]]. pose (isinv := @make_matrix_left_inverse _ _ _ n _ _ isr). assert (isinvprod : (matrix_left_inverse BA)). { apply left_inv_matrix_prod_is_left_inv; try assumption. apply (@matrix_inverse_to_right_and_left_inverse F _ B), gauss_clear_all_rows_matrix_invertible. } pose (contr_eq := @left_invertible_upper_triangular_to_diagonal_all_nonzero _ _ ut isinvprod idx). rewrite isnotz in contr_eq. contradiction. Defined. End Inverse. UniMath-20231010/UniMath/Algebra/GaussianElimination/Elimination.v000066400000000000000000001476051451125700300246300ustar00rootroot00000000000000 (** Gaussian Elimination over fields. Primary Author: Daniel @Skantz (November 2022) With much help from, and thanks to, Peter LeFanu Lumsdaine *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Nat. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.FiniteSequences. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Combinatorics.Maybe. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.GaussianElimination.Auxiliary. Require Import UniMath.Algebra.GaussianElimination.Vectors. Require Import UniMath.Algebra.GaussianElimination.Matrices. Require Import UniMath.Algebra.GaussianElimination.RowOps. (** In this module we formalize Gaussian elimination, using elementary row operations to put a matrix into row echelon form. *) Local Notation Σ := (iterop_fun 0%rig op1). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). Local Notation "R1 +pw R2" := ((pointwise _ op1) R1 R2) (at level 50, left associativity). Local Notation "A ** B" := (@matrix_mult (_:ring) _ _ A _ B) (at level 40, left associativity). (** * Key definitions, and main goal theorem We start by stating the main goal theorem of the module, [gaussian_elimination_theorem_stmt]; this require the preliminary definition of (weak) row echelon form. *) Section Echelon_Form. Context {R: ring}. Definition is_leading_entry {n : nat} (v : Vector R n) (i_1 : ⟦ n ⟧%stn) := (v i_1 != 0%ring) × (∏ i_2 : ⟦ n ⟧%stn, i_2 < i_1 -> (v i_2) = 0%ring). (** A matrix is in row echelon form if two conditions hold: 1. each leading entry is strictly to the right of earlier leading entries 2. any zero rows are below all non-zero rows In the presence of the second condition, the first is equivalent to: 1'. for each leading entry, every entry strictly below and non-strictly left of it is 0 . We take (1') in the definition, and show its equivalence with (1) later in the file. Sometimes this notion is called _weak_ echelon form, with full echelon form also insisting that all leading entries are 1. *) Definition is_row_echelon {m n : nat} (mat : Matrix R m n) := ∏ i_1 i_2 : ⟦ m ⟧%stn, (∏ j_1 j_2 : ⟦ n ⟧%stn, is_leading_entry (mat i_1) j_1 -> i_1 < i_2 -> j_2 ≤ j_1 -> mat i_2 j_2 = 0%ring) × ((mat i_1 = const_vec 0%ring) -> (i_1 < i_2) -> (mat i_2 = const_vec 0%ring)). End Echelon_Form. Definition gaussian_elimination_stmt : UU := forall (F : fld) (m n : nat) (A : Matrix F m n), ∑ (B : Matrix F _ _), (@matrix_inverse F _ B) × (is_row_echelon (B ** A)). (** * Leading entries In this section, give functions for finding the leading entry of a vector, and related lemmata *) Section LeadingEntry. Context (F: fld). (** This section doesn’t really require full field structure, just a ring with decidable equality.*) (* There is also some related material in Combinatorics.StandardFiniteSets - could it be used here/for inspiration to simplify or generalize some of these proofs? *) (** The leading entry of a (dual <-> "flipped") vector: [... _ _ X 0 0 0] -> index of X (Up to a separator variable) *) Definition leading_entry_compute_dual_internal_general {X : UU} { n : nat } (v : Vector F n) (iter : ⟦ S n ⟧%stn) : maybe (⟦ n ⟧%stn). Proof. destruct iter as [iter lt]. induction iter as [| iter IH]. { exact nothing. } simpl in lt. destruct (fldchoice0 (v (iter,, lt))). - refine (IH _); apply (istransnatlth _ _ _ lt (natgthsnn n)). - exact (just (iter,, lt)). Defined. (** The leading entry of a (dual <-> "flipped") vector: [... _ _ X 0 0 0] -> index of X (Up to a separator variable) *) Definition leading_entry_compute_dual_internal { n : nat } (v : Vector F n) (iter : ⟦ S n ⟧%stn) : maybe (⟦ n ⟧%stn). Proof. destruct iter as [iter lt]. induction iter as [| iter IH]. { exact nothing. } simpl in lt. destruct (fldchoice0 (v (iter,, lt))). - refine (IH _); apply (istransnatlth _ _ _ lt (natgthsnn n)). - exact (just (iter,, lt)). Defined. (** Leading entry of a vector in terms of dual *) Definition leading_entry_compute_internal { n : nat } (v : Vector F n) (iter : ⟦ S n ⟧%stn) : maybe (⟦ n ⟧)%stn. Proof. destruct (leading_entry_compute_dual_internal (λ i : ⟦ n ⟧%stn, v (dualelement i)) iter) as [s | ?]. - exact (just (dualelement s)). - exact nothing. Defined. Definition leading_entry_compute {n : nat} (v : Vector F n) := leading_entry_compute_internal v (n,, natgthsnn _). Definition leading_entry_dual_compute {n : nat} (v : Vector F n) := leading_entry_compute_dual_internal v (n,, natgthsnn _). Lemma leading_entry_compute_eq {n : nat} (v : Vector F n) (i_1 i_2 : ⟦ n ⟧%stn) (e_1 : leading_entry_compute v = just i_1) (e_2 : leading_entry_dual_compute (λ i : ⟦ n ⟧%stn, v (dualelement i)) = just i_2) : i_1 = dualelement i_2. Proof. unfold leading_entry_compute, leading_entry_dual_compute, leading_entry_compute_internal in * |-. destruct (leading_entry_compute_dual_internal (λ i : (⟦ n ⟧)%stn, v (dualelement i)) (n,, natgthsnn _)) as [s | contr]. 2: { contradiction (negpathsii1ii2 i_1 tt); apply pathsinv0, e_1. } assert (e_3 : (dualelement s) = i_1). { apply just_injectivity; exact (e_1). } assert (e_4 : s = i_2). { unfold just in e_2; now apply ii1_injectivity in e_2. } now rewrite <- e_3, e_4. Defined. Lemma leading_entry_compute_impl {n : nat} (v : Vector F n) (i_1 : ⟦ n ⟧%stn) (e_1 : leading_entry_compute_internal v (n,, natgthsnn _) = just i_1) : ∑ (i_2 : ⟦ n ⟧%stn), leading_entry_compute_dual_internal (λ i : ⟦ n ⟧%stn, v (dualelement i)) (n,, natgthsnn _) = just i_2. Proof. unfold leading_entry_compute_internal in * |-. destruct (leading_entry_compute_dual_internal (λ i : (⟦ n ⟧)%stn, _) (n,, natgthsnn _)) as [s | contr]. - assert (e_2 : dualelement s = i_1). {apply just_injectivity. apply e_1. } apply dualelement_eq in e_2; rewrite e_2. exists s; now rewrite e_2. - unfold just, nothing in e_1. contradiction (negpathsii1ii2 i_1 tt). apply pathsinv0, e_1. Defined. Lemma leading_entry_compute_dual_internal_inv1 { n : nat } (v : Vector F n) (iter : ⟦ S n ⟧%stn) {i : stn n} (not_nothing : (leading_entry_compute_dual_internal v iter) = just i) : i < iter × (v i != 0%ring). Proof. revert not_nothing. unfold leading_entry_compute_dual_internal. destruct iter as [iter p]. induction iter as [| iter IH]. { simpl; intros. contradiction (negpathsii1ii2 _ _ (!not_nothing)). } rewrite nat_rect_step. destruct (fldchoice0 _) as [eq0| neq0]. - intros H; apply IH in H; destruct H as [lt neq0]. use tpair. {apply (istransnatlth _ _ _ lt (natgthsnn iter) ). } apply neq0. - intros ?. rename not_nothing into eq; apply just_injectivity in eq. use tpair. {rewrite <- eq. apply natgthsnn. } rewrite <- eq; exact neq0. Defined. Definition leading_entry_compute_dual_internal_inv2 {n : nat} (v : Vector F n) (iter : ⟦ S n ⟧%stn) (not_nothing : (leading_entry_compute_dual_internal v iter) = nothing) : ∏ i : ⟦ n ⟧%stn, i < iter -> v i = 0%ring. Proof. intros i i_lt_iter. revert not_nothing. unfold leading_entry_compute_dual_internal. destruct iter as [iter p]. induction iter as [| iter IH]. { apply fromempty; now apply negnatlthn0 in i_lt_iter. } rewrite nat_rect_step. destruct (fldchoice0 (v (iter,, p))) as [eq0 | ?]. 2 : { intros contr; now apply negpathsii1ii2 in contr. } destruct (natlehchoice i iter) as [le | eq]. {now apply natlthsntoleh. } - intros H; now apply IH in H. - intros ?; refine (_ @ eq0); apply maponpaths, stn_eq, eq. Defined. Definition leading_entry_compute_dual_internal_inv3 {n : nat} (v : Vector F n) (iter : ⟦ S n ⟧%stn) (i : ⟦ n ⟧%stn) (eq : (leading_entry_compute_dual_internal v iter) = just i) : (∏ i' : ⟦ n ⟧%stn, i < i' -> i' < iter -> v i' = 0%ring). Proof. revert eq. destruct iter as [iter p]. induction iter as [| iter IH]. { intros _ ? _ x; contradiction (negnatgth0n _ x). } set (p' := istransnatlth iter _ _ p (natgthsnn _)). pose (@leading_entry_compute_dual_internal n v (S _,, p)) as H. destruct (maybe_choice' H) as [s | c]. 2: {unfold H in c; intros; rewrite eq in c; contradiction (negpathsii1ii2 _ _ c). } unfold leading_entry_compute_dual_internal; rewrite nat_rect_step. destruct (fldchoice0 (v (iter,, p) )) as [z | nz]. - intros H'. simpl; intros i' ? ?. destruct (natlehchoice i' iter) as [? | eq']. {assumption. } 2: {refine (_ @ z); apply maponpaths, stn_eq, eq'. } apply (IH p'); try assumption. - intros ? j i_le_iter lts. apply natlthtonegnatgeh in i_le_iter. unfold leading_entry_compute_dual_internal in eq. apply just_injectivity in eq. now rewrite <- eq in * |-. Defined. Definition leading_entry_compute_dual_internal_inv4 {n : nat} (v : Vector F n) (iter : ⟦ S n ⟧%stn) (i : ⟦ n ⟧%stn) (eq : (leading_entry_compute_dual_internal v iter) = just i) : (v i != 0%ring) × (∏ i' : ⟦ n ⟧%stn, i < i' -> i' < iter -> v i' = 0%ring). Proof. use tpair. - apply (leading_entry_compute_dual_internal_inv1 _ iter); assumption. - simpl. apply (leading_entry_compute_dual_internal_inv3 _ iter); assumption. Defined. Lemma leading_entry_compute_internal_inv1 {n : nat} (v : Vector F n) (i : ⟦ n ⟧%stn) (eq : (leading_entry_compute_internal v (n,, natgthsnn _)) = (just i)) : is_leading_entry v i. Proof. unfold is_leading_entry. destruct (leading_entry_compute_impl v i eq) as [i' H1]. pose (H2 := leading_entry_compute_eq v i i' eq H1). unfold leading_entry_compute_internal in eq. pose (H3 := @leading_entry_compute_dual_internal_inv4 _ (λ i : (⟦ n ⟧)%stn, v (dualelement i)) (n,, natgthsnn _) (dualelement i)). destruct (maybe_choice' (leading_entry_compute_dual_internal (λ i : (⟦ n ⟧)%stn, v (dualelement i)) (n,, natgthsnn _))) as [t | contr_eq]. 2: { contradiction (@negpathsii1ii2 ((⟦ n ⟧)%stn) unit i' tt). unfold just in H1; rewrite <- H1; now rewrite contr_eq. } destruct t as [t H4], (!H2), H3 as [H5 H6]; try now rewrite dualelement_2x. use tpair; simpl. { now rewrite dualelement_2x in H5. } intros j lt. change 0%ring with (@rigunel1 F) in *. rewrite <- (H6 (dualelement j)). - now rewrite dualelement_2x. - apply dualelement_lt_comp; exact lt. - exact (pr2 (dualelement j)). Defined. Lemma leading_entry_compute_internal_inv2 {n : nat} (v : Vector F n) (iter : ⟦ S n ⟧%stn) (eq_nothing : (leading_entry_compute_internal v iter) = nothing) : ∏ i : ⟦ n ⟧%stn, (dualelement i) < iter -> v i = 0%ring. Proof. intros i i_lt_iter. revert eq_nothing. unfold leading_entry_compute_internal, leading_entry_compute_dual_internal. destruct iter as [iter pr2_]. induction iter as [| iter IH]. - now apply negnatlthn0 in i_lt_iter. - rewrite nat_rect_step. destruct (fldchoice0 _) as [? | _]. 2 : { simpl; unfold just; intros contr. apply negpathsii1ii2 in contr. now apply fromempty. } destruct (natlehchoice (dualelement i) (iter)). { now apply natlthsntoleh. } + now apply IH. + intros ?. rewrite (dualelement_eq i (iter,, pr2_)); try easy. now apply subtypePath_prop. Defined. Lemma leading_entry_compute_inv1 {n : nat} (v : Vector F n) (eq_nothing : (leading_entry_compute v) = nothing) : ∏ i : ⟦ n ⟧%stn, v i = 0%ring. Proof. intros i. rewrite (leading_entry_compute_internal_inv2 _ _ eq_nothing i); try reflexivity. unfold dualelement. destruct (natchoice0 n) as [eq | ?]; simpl. - apply fromstn0; now rewrite eq. - refine (natlehlthtrans (n - 1 - i) (n - 1) n _ _ ). + apply natminuslehn. + now apply natminus1lthn. Defined. Lemma leading_entry_compute_inv2 {n : nat} (v : Vector F n) (i : ⟦ n ⟧%stn) (eq : (leading_entry_compute v) = just i) : is_leading_entry v i. Proof. use tpair; simpl. { now apply leading_entry_compute_internal_inv1. } intros i' i_gt_i'. destruct (@leading_entry_compute_impl _ _ _ eq) as [entry compeq]. pose (H := @leading_entry_compute_dual_internal_inv4 _ _ _ _ compeq). simpl in H; destruct H as [neq0 eq0]. rewrite <- (eq0 (dualelement i')). - now rewrite dualelement_2x. - apply dualelement_lt_comp'. rewrite dualelement_2x. rewrite <- (@leading_entry_compute_eq _ _ _ entry eq compeq). exact i_gt_i'. - exact (pr2 (dualelement i')). Defined. End LeadingEntry. (** * Pivot-selection *) Section Pivot. Context (F: fld). Definition select_pivot_row_coprod {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ m ⟧%stn) (k : ⟦ n ⟧%stn) : coprod ((∑ i: ⟦ m ⟧%stn, row_sep ≤ i × ((mat i k) != 0%ring))) (∏ i : ⟦ m ⟧%stn, row_sep ≤ i -> mat i k = 0%ring). Proof. pose (H := (@leading_entry_compute_dual_internal_inv1 _ _ (col mat k) (m,, natgthsnn _))). destruct (maybe_choice' (leading_entry_compute_dual_internal _ (col mat k) (m,, natgthsnn _))) as [some | none]. - destruct some as [t ist]. destruct (H t) as [lt neq0]; try assumption. destruct (natlthorgeh t row_sep) as [? | gt]. 2: { apply ii1; exists t, gt; apply neq0. } apply ii2. destruct (@leading_entry_compute_dual_internal_inv4 _ _ (col mat k) (m,, natgthsnn _) t ist) as [H3 H4]. intros i ke_le_i. unfold col, transpose, flip in * |-. rewrite H4; try easy; try now apply (natlthlehtrans _ row_sep i). exact (pr2 i). - apply ii2; intros. pose (H' := @leading_entry_compute_dual_internal_inv2). rewrite <- (H' _ _ (col mat k) (m,, natgthsnn _) none i); try reflexivity. apply (pr2 i). Defined. Local Definition exists_first_uncleared {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ m ⟧%stn) (col_iter : ⟦ S n ⟧%stn) := ((∑ j: ⟦ n ⟧%stn, j < col_iter × (∑ i: ⟦ m ⟧%stn, row_sep ≤ i × (mat i j != 0%ring) × ∏ i' : (⟦ m ⟧)%stn, ∏ (j' : stn n), row_sep ≤ i' -> j' < j -> mat i' j' = 0%ring))). Local Definition lower_left_zero {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ m ⟧%stn) (col_iter : ⟦ S n ⟧%stn) := (∏ i : ⟦ m ⟧%stn, row_sep ≤ i -> (∏ j : ⟦ n ⟧%stn, j < col_iter -> mat i j = 0%ring)). Lemma select_uncleared_column_internal {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ m ⟧%stn) (col_iter : ⟦ S n ⟧%stn) (p : n > 0) : coprod (exists_first_uncleared mat row_sep col_iter) (lower_left_zero mat row_sep col_iter). Proof. destruct (natchoice0 m) as [contr_eq | _]. { apply fromstn0; now rewrite contr_eq. } destruct col_iter as [col_iter lt]. induction col_iter as [| col_iter IH]. { right; intros ? _ ? contr. contradiction (negnatgth0n n contr). } assert (lt' : col_iter < S n). { simpl in lt. apply (istransnatlth _ _ _ lt (natgthsnn n)). } destruct (IH lt') as [IH_left | IH_right]. - destruct IH_left as [m' [H1 [H2 H3]]]. left; exists m', (istransnatlth _ _ _ H1 (natgthsnn col_iter)), H2. apply H3. - destruct (select_pivot_row_coprod mat row_sep (col_iter,, lt)) as [nz | z]. + left; exists (col_iter,, lt) , (natgthsnn col_iter); do 3 (use tpair; try apply nz); simpl; intros; now apply IH_right. + right. intros i rowsep_le_i j j_lt_scoliter. destruct (natlehchoice j col_iter) as [? | eq]; intros. { apply (natlehlthtrans _ _ _ j_lt_scoliter). apply (natgthsnn col_iter). } { now apply IH_right. } rewrite <- (z i); try assumption. now apply maponpaths, subtypePath_prop. Defined. (** Either finding all rows {r} >= [row_sep] are zero, or finding the first column segment with a non-zero element *) Definition select_uncleared_column {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ m ⟧%stn) (p : n > 0) := select_uncleared_column_internal mat row_sep (n,, natgthsnn _) p. End Pivot. (** * Gaussian elimination *) Section Gauss. (** - Defining procedures for gaussian elimination as direct operations on matrix / left matrix multiplication equivalents - Proving their correctness - First defining & showing procedure for clearing individual entries, then segments of columns, then working over multiple such segments. *) Context (F : fld). (** Clearing a target entry [i], if it does not equal the pivot row : [i] != [k_i]. *) Definition gauss_clear_column_step {m n : nat} (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (i : (stn m)) (mat : Matrix F m n) : Matrix F m n. Proof. destruct (stn_eq_or_neq i k_i). - exact mat. - refine ((@add_row_mult_matrix F _ k_i i _)%ring ** mat). exact (- ((mat i k_j) * fldmultinv' (mat k_i k_j)))%ring. Defined. Definition gauss_clear_column_step' {m n : nat} (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (i : (stn m)) (mat : Matrix F m n) : Matrix F m n. Proof. destruct (stn_eq_or_neq i k_i). - exact mat. - refine (add_row_mult k_i i _ mat). exact (- ((mat i k_j) * fldmultinv' (mat k_i k_j)))%ring. Defined. Lemma gauss_clear_column_step_eq {m n : nat} (k_i i: (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (mat : Matrix F m n) : (gauss_clear_column_step k_i k_j i mat) = (gauss_clear_column_step' k_i k_j i mat). Proof. unfold gauss_clear_column_step, gauss_clear_column_step'. destruct (stn_eq_or_neq i k_i). { apply idpath. } rewrite add_row_mult_as_matrix. - apply idpath. - now apply issymm_natneq. Defined. (** Zeroing the column segment below [k_i]: elements [mat {i} k_j], for {i} > [k_i]*) Definition gauss_clear_column { m n : nat } (mat : Matrix F m n) (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (row_sep : ⟦ S m ⟧%stn) : Matrix F m n. Proof. destruct row_sep as [iter lt']. generalize lt'; intros lt; clear lt'. induction iter as [ | iter gauss_clear_column_IH ]. { exact mat. } destruct (natgthorleh iter k_i). 2: {exact mat. } refine (gauss_clear_column_step k_i k_j (iter,, lt) _ ). refine (gauss_clear_column_IH _). now refine (istransnatlth _ _ _ (natgthsnn iter) _). Defined. (* This could be rewritten to use the step variant internally -- would simplify the clear_column_eq_matrix_def proof. *) Lemma gauss_clear_column_as_left_matrix { m n : nat } (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) : Matrix F m m. Proof. destruct iter as [iter p]. generalize p; intros lt; clear p. induction iter as [| iter IH]. {exact (@identity_matrix F m). } assert (p': iter < S m). { apply (istransnatlth _ _ _ (natgthsnn iter) lt). } destruct (natgthorleh iter k_i). 2: { exact (@identity_matrix F m ** (IH p')). } refine (@add_row_mult_matrix F _ k_i (iter,, lt) (- (_ * _))%ring ** _). - exact (mat (iter,, lt) k_j). - exact (fldmultinv' (mat k_i k_j)). - exact (IH p'). Defined. Lemma gauss_clear_column_as_left_matrix_inv0 { m n : nat } (iter : stn (S m)) (mat : Matrix F m n) (k_i : (⟦ m ⟧%stn)) (k_j : (stn n)) (i : ⟦ m ⟧%stn) (i_leh_k : i ≤ k_i) : (gauss_clear_column_as_left_matrix iter mat k_i k_j ** mat) i = mat i. Proof. unfold gauss_clear_column_as_left_matrix. destruct iter as [iter p]. induction iter as [| iter IH]; intros. { simpl; now rewrite matlunax2. } unfold gauss_clear_column_as_left_matrix. rewrite nat_rect_step. destruct (natgthorleh iter k_i) as [gt | _]. 2: {rewrite matlunax2; now rewrite IH. } assert (lt: iter < S m). {apply (istransnatlth _ _ _ (natgthsnn iter) p). } rewrite <- (IH lt). rewrite IH, matrix_mult_assoc, add_row_mult_as_matrix. 2: {now apply issymm_natneq, natgthtoneq. } rewrite add_row_mult_nontarget_row. 2: {apply natgthtoneq. apply (natlehlthtrans _ _ _ i_leh_k gt). } now rewrite IH. Defined. (** Proving [mat r] is unchanged after column clearance if [r > sep]. *) Lemma gauss_clear_column_inv0 { m n : nat } (k_i : (⟦ m ⟧%stn)) (k_j : stn n) (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (r : ⟦ m ⟧%stn) (r_gt_sep : r ≥ iter) : (gauss_clear_column mat k_i k_j iter) r = mat r. Proof. unfold gauss_clear_column. destruct iter as [sep p]. induction sep as [| sep IH]. {easy. } rewrite nat_rect_step. destruct (natgthorleh sep k_i). 2: { apply idpath. } rewrite gauss_clear_column_step_eq. unfold gauss_clear_column_step'. destruct (stn_eq_or_neq _ _). { unfold gauss_clear_column, gauss_clear_column_step. unfold gauss_clear_column in IH. now apply IH, natgthtogeh. } unfold gauss_clear_column in IH. rewrite add_row_mult_nontarget_row. 2: {now apply natlthtoneq. } rewrite IH. { apply idpath. } apply natgthtogeh, r_gt_sep. Defined. Lemma clear_column_eq_matrix_def { m n : nat } (iter : ⟦ S m ⟧%stn) (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (mat : Matrix F m n) : ((gauss_clear_column_as_left_matrix iter mat k_i k_j) ** mat) = gauss_clear_column mat k_i k_j iter. Proof. intros. destruct iter as [iter p]. set (p' := (stn_implies_ngt0 k_i)). induction iter as [| iter IH]; try apply matlunax2. unfold gauss_clear_column, gauss_clear_column_as_left_matrix. unfold gauss_clear_column, gauss_clear_column_as_left_matrix in IH. do 2 rewrite nat_rect_step. rewrite gauss_clear_column_step_eq. destruct (natgthorleh iter k_i) as [gt | leh]. 2 : { rewrite matlunax2; rewrite IH. induction iter as [| iter IH']; try apply idpath. rewrite nat_rect_step. destruct (natgthorleh iter k_i) as [gt' | ?]; try apply idpath. apply natgehsntogth in gt'. apply fromempty, (isasymmnatgth _ _ gt' leh). } rewrite matrix_mult_assoc, <- IH. unfold gauss_clear_column_step'. destruct (stn_eq_or_neq _ _) as [eq | neq]. { apply fromempty. apply neggth_logeq_leh in gt; try assumption. rewrite <- eq. apply isreflnatgeh. } rewrite add_row_mult_as_matrix. 2 : { now apply issymm_natneq, natgthtoneq. } apply pathsinv0, maponpaths_2. etrans. { set (f := @gauss_clear_column_as_left_matrix_inv0 m n). unfold gauss_clear_column_as_left_matrix in f. set (lt' := (istransnatlth _ _ _ (natgthsnn iter) p)). change iter with (pr1 (make_stn _ iter lt')). change (istransnatlth _ _ _ _ p) with (make_stn _ iter lt'). rewrite (f (make_stn _ iter lt') _ _ _ _ (isreflnatleh k_i)). change (pr1 (make_stn _ iter lt')) with iter. change (make_stn _ iter lt') with (istransnatlth _ _ _ _ p) . reflexivity. } apply maponpaths_1, maponpaths_2. rewrite IH. pose (H := @gauss_clear_column_inv0). unfold gauss_clear_column in H. set (lt' := (istransnatlth _ _ _ (natgthsnn iter) p)). change iter with (pr1 (make_stn _ iter lt')). change (istransnatlth _ _ _ _ p) with (make_stn _ iter lt'). rewrite H; try easy. apply isreflnatleh. Defined. Lemma clear_column_matrix_invertible { m n : nat } (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (k_i : (⟦ m ⟧%stn)) (k_j : stn n) : @matrix_inverse F _ (gauss_clear_column_as_left_matrix iter mat k_i k_j). Proof. unfold gauss_clear_column_as_left_matrix. destruct iter as [iter p]. induction iter as [| iter IH]. { apply identity_matrix_invertible. } rewrite nat_rect_step. destruct (natgthorleh iter k_i). - apply inv_matrix_prod_invertible. { apply add_row_mult_matrix_invertible. now apply natlthtoneq. } apply IH. - apply inv_matrix_prod_invertible. { apply identity_matrix_invertible. } apply IH. Defined. (** The notion of clearing a row is finding the next uncleared column {c} (having non-zero element below [row] at {r}) and performing elimination over it. We inline a pivoting operation here as well, switching [row] and {r} *) Definition gauss_clear_row { m n : nat } (mat : Matrix F m n) (row : (⟦ m ⟧%stn)) : Matrix F m n. Proof. destruct (natchoice0 n) as [contr_eq | p]. { unfold Matrix, Vector; intros; apply fromstn0. now rewrite contr_eq. } destruct (select_uncleared_column _ mat row p) as [[piv_col [? [piv_row ?]]] | none]. 2: {exact mat. } refine (gauss_clear_column _ row piv_col (m,, natlthnsn _)). exact (@switch_row F _ _ row piv_row mat). Defined. Definition gauss_clear_row_as_left_matrix { m n : nat } (mat : Matrix F m n) (row : (⟦ m ⟧%stn)) (p : n > 0) : Matrix F m m. Proof. destruct (select_uncleared_column F mat row p) as [[piv_col [_ [piv_row _]]] | none]. 2 : {exact (@identity_matrix F _). } set (mat_by_normal_op := (@switch_row F _ _ row piv_row mat)). refine ((gauss_clear_column_as_left_matrix (m,, natgthsnn _) mat_by_normal_op row piv_col) ** _). refine (@switch_row_matrix _ _ row piv_row). Defined. Lemma clear_row_eq_matrix_def { m n : nat } (mat : Matrix F m n) (r : ⟦ m ⟧%stn) (p : n > 0): ((gauss_clear_row_as_left_matrix mat r p) ** mat) = gauss_clear_row mat r. Proof. intros. unfold gauss_clear_row, gauss_clear_row_as_left_matrix. destruct (natchoice0 _) as [contr_eq | gt]. { apply fromempty; rewrite contr_eq in p; contradiction (isirreflnatgth _ p). } assert (eq : p = gt). { apply propproperty. } rewrite eq. destruct (select_uncleared_column F mat r _). 2: {apply matlunax2. } now rewrite matrix_mult_assoc, switch_row_as_matrix, clear_column_eq_matrix_def. Defined. Lemma clear_row_matrix_invertible { m n : nat } (mat : Matrix F m n) (row : (⟦ m ⟧%stn)) (p : n > 0) : @matrix_inverse F _ (gauss_clear_row_as_left_matrix mat row p). Proof. unfold gauss_clear_row_as_left_matrix. destruct (select_uncleared_column F mat row p) as [some | none]. 2: { destruct (natchoice0 m); try apply identity_matrix_invertible; now apply nil_matrix_invertible, identity_matrix_invertible. } apply inv_matrix_prod_invertible. - apply clear_column_matrix_invertible. - apply switch_row_matrix_invertible. Defined. Definition gauss_clear_rows_up_to { m n : nat } (mat : Matrix F m n) (row_sep : (⟦ S m ⟧%stn)) : (Matrix F m n). Proof. destruct row_sep as [row_sep row_sep_lt_n]. induction row_sep as [| row_sep gauss_clear_earlier_rows]. {exact mat. } refine (gauss_clear_row _ (row_sep,, row_sep_lt_n)). refine (gauss_clear_earlier_rows _). exact (istransnatlth _ _ _ (natgthsnn row_sep) row_sep_lt_n ). Defined. (** invertible matrix, such that left-multiplication by this corresponds to [gauss_clear_columns_up_to] *) Lemma clear_rows_up_to_as_left_matrix { m n : nat } (mat : Matrix F m n) (row_sep : (⟦ S m ⟧%stn)) (p : n > 0) : (Matrix F m m). Proof. destruct row_sep as [row_sep row_sep_lt_n]. induction row_sep as [ | row_sep gauss_clear_earlier_rows]. { exact (@identity_matrix F m). } assert (lt : row_sep < S m). {apply (istransnatlth _ _ _ (natgthsnn row_sep) row_sep_lt_n ). } set (mat_by_normal_op := (gauss_clear_rows_up_to mat (row_sep,, lt))). refine ((gauss_clear_row_as_left_matrix mat_by_normal_op (row_sep,, row_sep_lt_n) p ** _)). exact (gauss_clear_earlier_rows lt). Defined. Lemma gauss_clear_rows_up_to_as_matrix_eq { m n : nat } (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (p : n > 0) : ((@clear_rows_up_to_as_left_matrix _ _ mat iter p) ** mat) = (gauss_clear_rows_up_to mat iter). Proof. intros. unfold clear_rows_up_to_as_left_matrix, gauss_clear_rows_up_to, clear_rows_up_to_as_left_matrix, gauss_clear_rows_up_to. destruct iter as [iter ?]. induction iter as [| iter IH ]. {simpl; now rewrite matlunax2. } do 2 rewrite nat_rect_step, <- IH. now rewrite <- (clear_row_eq_matrix_def _ _ p), <- matrix_mult_assoc. Defined. Lemma gauss_clear_rows_up_to_matrix_invertible {m n : nat} (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (p : n > 0) : @matrix_inverse F _ (clear_rows_up_to_as_left_matrix mat iter p). Proof. unfold clear_rows_up_to_as_left_matrix. set (pre := gauss_clear_column_as_left_matrix iter mat ). unfold gauss_clear_column_as_left_matrix in pre. destruct iter as [iter lt]. induction iter as [| ? IH]. - simpl. apply identity_matrix_invertible. - unfold clear_rows_up_to_as_left_matrix. rewrite nat_rect_step. apply inv_matrix_prod_invertible. + now apply clear_row_matrix_invertible. + apply IH. Defined. (** Inputting a matrix and transforming it into an upper-triangular matrix by elementary matrix operations or equivalent *) Definition gauss_clear_all_rows { m n : nat } (mat : Matrix F m n) : Matrix F m n. Proof. refine (gauss_clear_rows_up_to mat (m,,_)); exact (natgthsnn m). Defined. Definition gauss_clear_all_rows_as_left_matrix { m n : nat } (mat : Matrix F m n) (p : n > 0) : Matrix F m m. Proof. refine (clear_rows_up_to_as_left_matrix mat (m,,_) p); exact (natgthsnn m). Defined. Definition gauss_clear_all_rows_as_matrix_eq { m n : nat } (mat : Matrix F m n) (p : n > 0) : ((gauss_clear_all_rows_as_left_matrix mat p) ** mat) = gauss_clear_all_rows mat. Proof. apply (gauss_clear_rows_up_to_as_matrix_eq (m,, natgthsnn _) mat p). Defined. Lemma gauss_clear_all_rows_matrix_invertible {m n : nat} (mat : Matrix F m n) (p : n > 0) : @matrix_inverse F _ (gauss_clear_all_rows_as_left_matrix mat p). Proof. apply gauss_clear_rows_up_to_matrix_invertible. Defined. Lemma gauss_clear_column_step_inv1 {m n : nat} (r_pivot : ⟦m⟧%stn) (c_pivot : ⟦ n ⟧%stn) (r : (⟦ m ⟧%stn)) (mat : Matrix F m n) (p_1 : mat r_pivot c_pivot != 0%ring) (p_2 : r ≠ r_pivot) : (gauss_clear_column_step r_pivot c_pivot r mat) r c_pivot = 0%ring. Proof. intros; unfold gauss_clear_column_step. destruct (stn_eq_or_neq r r_pivot) as [p | _]. { rewrite p in p_2. now apply isirrefl_natneq in p_2. } rewrite add_row_mult_as_matrix. 2: { now apply issymm_natneq. } rewrite add_row_mult_target_row. rewrite <- (@ringlmultminus F), ringassoc2. etrans. { now apply maponpaths, maponpaths, fldmultinvlax'. } rewrite (@rigrunax2 F); apply ringrinvax1. Defined. Lemma gauss_clear_column_step_inv2 {m n : nat} (k_i : stn m) (k_j : (⟦ n ⟧%stn)) (r : (⟦ m ⟧%stn)) (mat : Matrix F m n) (j : ⟦ m ⟧%stn) (p : r ≠ j) : (gauss_clear_column_step k_i k_j j mat) r = mat r. Proof. intros. rewrite gauss_clear_column_step_eq. unfold gauss_clear_column_step'. destruct (stn_eq_or_neq j k_i). { apply idpath. } apply funextfun; intros ?. rewrite add_row_mult_nontarget_row; try reflexivity. now apply issymm_natneq. Defined. Lemma gauss_clear_column_step_inv3 {m n : nat} (k_i : stn m) (k_j : (⟦ n ⟧%stn)) (r : (⟦ m ⟧%stn)) (mat : Matrix F m n) (j : ⟦ m ⟧%stn) (j' : stn n) (p : r < j) : (gauss_clear_column_step k_i k_j j mat) r j' = mat r j'. Proof. assert (p': r ≠ j). {now apply issymm_natneq, natgthtoneq. } now rewrite (gauss_clear_column_step_inv2 k_i k_j r mat j p'). Defined. (** if the target row r ≤ the pivot row k, mat r is not changed by the clearing procedure. *) Lemma gauss_clear_column_inv1 { m n : nat } (k_i : (⟦ m ⟧%stn)) (k_j : stn n) (r : stn m) (iter : ⟦ S m ⟧%stn) (p' : r ≤ k_i) (mat : Matrix F m n) : (gauss_clear_column mat k_i k_j iter) r = mat r. Proof. unfold gauss_clear_column. destruct iter as [sep p]. induction sep as [| sep IH]. {easy. } unfold gauss_clear_column. apply funextfun. intros q. rewrite nat_rect_step. destruct (natgthorleh _ _)as [gt | ?]; try reflexivity. rewrite gauss_clear_column_step_inv3. 2 : {now refine (natgthgehtrans _ _ _ gt _). } unfold gauss_clear_column in IH. now rewrite IH. Defined. (** Given a target row and pivot, proving the column clearing procedure equals applying step on it *) Lemma gauss_clear_column_inv2 { m n : nat } (k_i : (⟦ m ⟧%stn)) (k_j : stn n) (row_sep : ⟦ S m ⟧%stn) (mat : Matrix F m n) : ∏ r : (⟦ m ⟧%stn), r < row_sep -> k_i < r -> ((gauss_clear_column mat k_i k_j row_sep) r = (gauss_clear_column_step' k_i k_j r mat) r). Proof. unfold gauss_clear_column. destruct row_sep as [sep p]. induction sep as [| sep IH]. { intros r r_le_0. contradiction (negnatgth0n r r_le_0). } intros r r_le_sn k_le_r. set (p' := istransnatlth _ _ _ (natgthsnn _) p). destruct (natlehchoice r sep) as [lt | eq]. {assumption. } - assert (le: r ≤ sep). { now apply natlthtoleh in lt. } unfold gauss_clear_column. rewrite nat_rect_step. unfold gauss_clear_column in IH. destruct (natgthorleh _ _) as [le' | gt]. + rewrite (gauss_clear_column_step_inv2). 2 : { apply natgthtoneq in lt; apply issymm_natneq; apply lt. } now rewrite <- (IH p'). + assert (absurd : sep ≤ r). * apply natgthtogeh in k_le_r. apply (istransnatleh gt k_le_r). * now apply natgehtonegnatlth in absurd. - rewrite nat_rect_step. unfold gauss_clear_column_step'. destruct (natgthorleh _ _) as [gt | leh]. 2 : { unfold gauss_clear_column_step. destruct (stn_eq_or_neq _ _); try reflexivity. assert (absurd : sep ≤ r). { apply natgthtogeh in k_le_r. rewrite eq; apply isreflnatgeh. } destruct (!eq). now apply natlehneggth in leh. } destruct (stn_eq_or_neq _ _) as [contr_eq | ?]. { rewrite contr_eq in k_le_r. contradiction (isirreflnatgth _ k_le_r). } assert (interchange : gauss_clear_column_step k_i k_j (sep,, p) (gauss_clear_column mat k_i k_j (sep,, p')) r = gauss_clear_column (gauss_clear_column_step k_i k_j (sep,, p) mat) k_i k_j (sep,, p') r). { do 2 rewrite gauss_clear_column_step_eq. unfold gauss_clear_column_step'. destruct (stn_eq_or_neq _ _); try reflexivity. unfold add_row_mult. rewrite gauss_clear_column_inv0; simpl; try apply natlthnsn. generalize p; generalize p'; rewrite <- eq; intros q q'; simpl. destruct (stn_eq_or_neq _ _) as [? | contr_neq]; simpl. 2: { contradiction (isirrefl_natneq _ contr_neq). } etrans. 2: { rewrite (gauss_clear_column_inv0); try reflexivity; simpl. rewrite eq; apply natlthnsn. } destruct (stn_eq_or_neq _ _) as [? | contr_neq]; simpl. 2: { contradiction (isirrefl_natneq _ contr_neq). } apply funextfun; intros y. apply maponpaths, maponpaths_12. - do 2 apply maponpaths. rewrite gauss_clear_column_inv1. {reflexivity. } apply isreflnatgeh. - rewrite gauss_clear_column_inv1; try reflexivity; apply isreflnatleh. } pose (@gauss_clear_column_inv0 m n k_i k_j (sep,, p')) as p1. change (istransnatlth _ _ _ (natgthsnn _) p) with p'. rewrite <- (stn_eq_2 _ _ eq p) in interchange |- *. do 2 rewrite gauss_clear_column_step_eq in interchange. rewrite gauss_clear_column_step_eq in *; unfold gauss_clear_column_step' in *. destruct (stn_eq_or_neq _ _) as [contr_eq | ?]; try reflexivity. { rewrite contr_eq in k_le_r; contradiction (isirreflnatgth _ k_le_r). } unfold gauss_clear_column in interchange, p1 |-; rewrite interchange. rewrite p1; rewrite (stn_eq_2 _ _ eq p); now try apply isreflnatleh. Defined. Lemma gauss_clear_column_inv3 { m n : nat } (k_i : (⟦ m ⟧%stn)) (k_j : (⟦ n ⟧%stn)) (iter : ⟦ S m ⟧%stn) (mat : Matrix F m n) (p' : mat k_i k_j != 0%ring) : ∏ r : (⟦ m ⟧%stn), r < iter -> r > k_i -> ((gauss_clear_column mat k_i k_j iter) r k_j = 0%ring). Proof. destruct iter as [sep p]. intros r r_le_sep r_gt_k. rewrite (gauss_clear_column_inv2 k_i k_j (sep ,, p) mat r r_le_sep) , <- gauss_clear_column_step_eq. 2: {exact r_gt_k. } rewrite (gauss_clear_column_step_inv1 k_i k_j r mat); try easy. now apply natgthtoneq. Defined. (** 0 in pivot row -> corresponding col is unchanged after gcc *) Lemma gauss_clear_column_inv4 { m n : nat } (mat : Matrix F m n) (k_i : (⟦ m ⟧%stn)) (k_j : stn n) (iter : ⟦ S m ⟧%stn) (j : ⟦ n ⟧%stn) (eq0 : mat k_i j = 0%ring) : ∏ i : ⟦ m ⟧%stn, gauss_clear_column mat k_i k_j iter i j = mat i j. Proof. unfold gauss_clear_column. destruct iter as [iter lt]. induction iter as [| iter IH]. { easy. } intros i. rewrite nat_rect_step, gauss_clear_column_step_eq. destruct (stn_eq_or_neq (iter,, lt) k_i) as [eq | ?]. - rewrite <- eq. destruct (natgthorleh _ _) as [contr | ?]. { now apply isirreflnatgth in contr. } reflexivity. - rewrite <- (IH (istransnatlth _ _ _ (natlthnsn iter) lt)) , <- gauss_clear_column_step_eq. unfold gauss_clear_column_step'. destruct (natgthorleh _ _) as [_ | _]. 2: { now rewrite IH. } rewrite gauss_clear_column_step_eq. unfold gauss_clear_column_step'. destruct (stn_eq_or_neq _ _); try reflexivity. unfold add_row_mult. destruct (stn_eq_or_neq _ _) as [eq | ?]; try apply coprod_rect_compute_1; try apply coprod_rect_compute_2. + rewrite coprod_rect_compute_1. do 3 rewrite IH. now rewrite eq0, <- eq, (@rigmultx0 F), (@rigrunax1 F). + now rewrite coprod_rect_compute_2. Defined. (** Notion of being row echelon "up to" a separator, and fulfilling criteria 1 and 2 from the preamble separately. *) Definition is_row_echelon_partial_1 {m n : nat} (mat : Matrix F m n) (row_sep : ⟦ S m ⟧%stn) := ∏ i_1 i_2 : ⟦ m ⟧%stn, ∏ j_1 j_2 : ⟦ n ⟧%stn, i_1 < row_sep -> is_leading_entry (mat i_1) j_2 -> i_1 < i_2 -> j_1 ≤ j_2 -> mat i_2 j_1 = 0%ring. Definition is_row_echelon_partial_2 {m n : nat} (mat : Matrix F m n) (iter : ⟦ S m ⟧%stn) := ∏ (i_1 i_2 : ⟦ m ⟧%stn), i_1 < iter -> (mat i_1 = const_vec 0%ring) -> i_1 < i_2 -> mat i_2 = const_vec 0%ring. Definition is_row_echelon_partial {m n : nat} (mat : Matrix F m n) (iter : ⟦ S m ⟧%stn) := is_row_echelon_partial_1 mat iter × is_row_echelon_partial_2 mat iter. (** Step lemma *) Lemma gauss_clear_row_inv0 { m n : nat } (mat : Matrix F m n) (p : n > 0) (row_sep : (⟦ S m ⟧%stn)) (p' : row_sep < m) : is_row_echelon_partial_1 mat row_sep -> is_row_echelon_partial_1 (gauss_clear_row mat (pr1 row_sep,, p')) (S (pr1 row_sep),, p'). Proof. intros H1. unfold is_row_echelon_partial_1. unfold gauss_clear_rows_up_to. intros i_1 i_2 j_1 j_2 i1_lt H2 i1_lt_i2 j1_lt_j2. revert H2; unfold gauss_clear_row; clear p. destruct (natchoice0 n) as [contr_eq | p]. { apply fromstn0. now rewrite contr_eq. } destruct (select_uncleared_column _ _) as [[piv_c [_ [piv_r [leh [neq0 eq0]]]]] | none]; simpl. 2 : { intros isle. destruct (natlehchoice i_1 (pr1 row_sep)) as [? | eq]; try assumption. {rewrite (H1 i_1 i_2 j_1 j_2); try easy. } rewrite none; intros; try easy. 2: {exact (pr2 (j_1)). } apply natgthtogeh; simpl. now rewrite <- eq. } intros is_le. rewrite gauss_clear_column_inv1 in is_le. 2 : { now apply natlthsntoleh. } destruct (natlehchoice i_1 (pr1 row_sep)) as [lt | eq]. { now apply natlthsntoleh. } { rewrite switch_row_other_row' in is_le. 3: { apply natlthtoneq. refine (natlthlehtrans _ _ _ lt leh). } 2: { now apply natlthtoneq. } rewrite gauss_clear_column_inv4. { rewrite switch_row_equal_entries. - now rewrite (H1 i_1 i_2 j_1 j_2). - do 2 (rewrite (H1 i_1 _ j_1 j_2); try easy). refine (natlthlehtrans _ _ _ lt leh). } rewrite switch_row_equal_entries. + rewrite (H1 i_1 _ j_1 j_2); easy. + do 2 (rewrite (H1 i_1 _ j_1 j_2); try easy). refine (natlthlehtrans _ _ _ lt leh). } destruct (natgthorleh piv_c j_1). { rewrite gauss_clear_column_inv4; try easy. - unfold switch_row. destruct (stn_eq_or_neq _ _) as [eq' | neq]; simpl. + destruct (stn_eq_or_neq _ _) as [contr_eq | neq']; simpl. { now rewrite eq0. } rewrite eq0; try easy. apply (isreflnatleh). + destruct (stn_eq_or_neq _ _) as [contr_eq | neq']; simpl. { now rewrite eq0. } rewrite eq0; try easy. rewrite <- (stn_eq_2 _ _ eq). now apply natgthtogeh. - rewrite switch_row_equal_entries; (rewrite eq0; try easy; try apply isreflnatleh). now rewrite eq0. } destruct (natlehchoice piv_c j_1) as [gt | eq']; try assumption. 2 : { rewrite (stn_eq j_1 piv_c (!eq')). rewrite gauss_clear_column_inv3; try easy. - unfold switch_row. rewrite stn_eq_or_neq_refl; simpl. apply neq0. - exact (pr2 i_2). - now rewrite <- (stn_eq_2 _ _ eq). } contradiction neq0. destruct (natlehchoice i_1 (pr1 row_sep)) as [lt | eq']. { now apply natlthsntoleh. } - rewrite switch_row_other_row' in is_le. 3: { apply natlthtoneq. refine (natlthlehtrans _ _ _ lt leh). } 2: { now apply natlthtoneq. } refine (H1 _ _ _ _ lt is_le _ _). + refine (natlthlehtrans _ _ _ lt leh). + now refine (istransnatleh _ j1_lt_j2). - rewrite eq in * |-. assert (is_le' : is_leading_entry (mat piv_r) j_2). { unfold is_leading_entry, switch_row in * |-; destruct (stn_eq_or_neq _ _) as [? | ?]; destruct (stn_eq_or_neq _ _) as [? | contr_neq]; simpl in is_le; try apply is_le; simpl in contr_neq; rewrite <- eq in contr_neq; contradiction (isirrefl_natneq _ contr_neq). } unfold is_leading_entry in is_le'. rewrite (pr2 (is_le')); try reflexivity. refine (natlthlehtrans _ _ _ gt j1_lt_j2). Defined. Lemma gauss_clear_rows_up_to_inv0 { m n : nat } (mat : Matrix F m n) (row_sep : (⟦ S m ⟧%stn)) (p : n > 0) : ∏ i_1 : ⟦ m ⟧%stn, i_1 < row_sep -> (gauss_clear_rows_up_to mat row_sep) i_1 = const_vec 0%ring -> ∏ i_2 : ⟦ m ⟧%stn, i_1 < i_2 -> (gauss_clear_rows_up_to mat row_sep) i_2 = const_vec 0%ring. Proof. unfold is_row_echelon_partial_2. intros i_1 i1_lt_rowsep no_leading. unfold gauss_clear_rows_up_to in *. destruct row_sep as [row_sep lt]. induction row_sep as [| row_sep IH]. {contradiction (negnatgth0n i_1 i1_lt_rowsep). } rename i1_lt_rowsep into i1_lt_srowsep. set (lt' := (istransnatlth _ _ _ (natgthsnn row_sep) lt)). rewrite nat_rect_step in no_leading |- *. unfold gauss_clear_row in IH, no_leading |- *. destruct (natchoice0 n) as [contr_eq | gt]. { rewrite contr_eq in p. contradiction (isirreflnatgth _ p). } revert no_leading. destruct (natlehchoice i_1 row_sep) as [i1_lt_rowsep | eq]. {apply natlthsntoleh. assumption. } - destruct (select_uncleared_column _ _) as [[piv_c [_ [piv_r [leh [neq0 eq0]]]]] | none]; simpl. 2: { now apply IH. } intros ? ? i1_lt_i2. destruct (natgthorleh i_2 row_sep) as [i2_gt_rowsep | i2_le_rowsep]. + rewrite switch_row_equal_rows in no_leading; try assumption. * rewrite gauss_clear_column_inv1 in no_leading. 2: { now apply natlthtoleh. } rewrite gauss_clear_column_inv2; try assumption. 2: {apply (pr2 i_2). } unfold gauss_clear_column_step'. destruct (stn_eq_or_neq _ _) as [contr_eq | ?]. { contradiction (isirreflnatgth row_sep). now rewrite contr_eq in * |-. } rewrite add_row_mult_source_row_zero; try assumption. -- rewrite switch_row_equal_rows. ++ now rewrite IH. ++ do 2 (rewrite IH; try easy). apply (natgehgthtrans _ _ _ leh i1_lt_rowsep). -- rewrite switch_row_equal_rows; try assumption. ++ now rewrite IH. ++ do 2 (rewrite IH; try assumption; try reflexivity). apply (natgehgthtrans _ _ _ leh i1_lt_rowsep). * rewrite gauss_clear_column_inv1 in no_leading. 2: { now apply natlthtoleh. } rewrite switch_row_other_row' in no_leading. 3: { apply natlthtoneq, (natgehgthtrans _ _ _ leh i1_lt_rowsep). } 2: { now apply natlthtoneq. } do 2 (rewrite IH; try easy). apply (natgehgthtrans _ _ _ leh i1_lt_rowsep). + rewrite switch_row_equal_rows in no_leading; try assumption. * rewrite gauss_clear_column_inv1 in no_leading. 2: { apply natgthtogeh in i1_lt_i2; apply (istransnatleh i1_lt_i2 i2_le_rowsep). } rewrite gauss_clear_column_inv1; try assumption. rewrite switch_row_equal_rows; try assumption. -- now rewrite IH. -- do 2 (rewrite IH; try easy). apply (natgehgthtrans _ _ _ leh i1_lt_rowsep). * rewrite gauss_clear_column_inv1 in no_leading. 2: { now apply natlthtoleh in i1_lt_rowsep. } rewrite switch_row_other_row' in no_leading. 3: { apply natlthtoneq, (natgehgthtrans _ _ _ leh i1_lt_rowsep). } 2: { apply natlthtoneq, (natlthlehtrans _ _ _ i1_lt_i2 i2_le_rowsep). } do 2 (rewrite IH; try easy). apply (natgehgthtrans _ _ _ leh i1_lt_rowsep). - intros; unfold gauss_clear_row in * |-. destruct (select_uncleared_column _ _) as [[? [? [? [? [neq0 ?]]]]] | no_col]. 2: { apply funextfun; intros j_2. assert (le : row_sep ≤ i_2). {apply natgthtogeh. now rewrite <- eq. } apply no_col; try assumption. apply (pr2 j_2). } unfold leading_entry_compute in no_leading. contradiction neq0. refine (const_vec_eq _ _ _ _). rewrite <- no_leading. unfold switch_row. rewrite gauss_clear_column_inv1. 2: { rewrite eq. apply isreflnatleh. } destruct (stn_eq_or_neq _ _); destruct (stn_eq_or_neq _ _) as [? | contr_neq]; try reflexivity; contradiction (nat_neq_to_nopath contr_neq). Defined. Lemma gauss_clear_rows_up_to_inv1 { m n : nat } (mat : Matrix F m n) (p : n > 0) (row_sep : (⟦ S m ⟧%stn)) : is_row_echelon_partial_1 (gauss_clear_rows_up_to mat row_sep) row_sep. Proof. unfold gauss_clear_rows_up_to. destruct row_sep as [row_sep p'']. induction row_sep as [| row_sep IH]. { simpl; intros ? ? ? ? contr; contradiction (negnatlthn0 n contr). } rewrite nat_rect_step. set (inner := nat_rect _ _ _ _). set (lt' := (istransnatlth _ _ _ (natgthsnn row_sep) p'')). apply (gauss_clear_row_inv0 (inner lt') p (row_sep,, lt') _), IH. Defined. Lemma gauss_clear_rows_up_to_inv2 { m n : nat } (mat : Matrix F m n) (p : n > 0) (row_sep : (⟦ S m ⟧%stn)) : is_row_echelon_partial_2 (gauss_clear_rows_up_to mat row_sep) row_sep. Proof. intro i_1; intros i_2 lt eq ?. rewrite (gauss_clear_rows_up_to_inv0 _ row_sep p i_1 lt eq i_2); try assumption. now destruct row_sep. Defined. Lemma is_row_echelon_from_partial {m n : nat} (mat : Matrix F m n) : (is_row_echelon_partial mat (m,, natgthsnn _)) -> is_row_echelon mat. Proof. unfold is_row_echelon, is_row_echelon_partial. unfold is_row_echelon_partial_1, is_row_echelon_partial_2. intros H ? ?; intros; use tpair. { intros j_1 j_2 X. refine (pr1 H i_1 i_2 j_2 _ _ _ ); try apply X; try assumption; exact (pr2 i_1). } simpl; intros. refine ((pr2 H) i_1 i_2 _ _ _ ); try assumption. exact (pr2 i_1). Defined. Lemma gauss_clear_rows_up_to_inv3 { m n : nat } (mat : Matrix F m n) (p : n > 0) (row_sep : (⟦ S m ⟧%stn)) : is_row_echelon (gauss_clear_rows_up_to mat (m,, natgthsnn _)). Proof. apply (@is_row_echelon_from_partial _ _ (gauss_clear_rows_up_to mat (m,, natgthsnn _))). use tpair. - now apply gauss_clear_rows_up_to_inv1. - now apply gauss_clear_rows_up_to_inv2. Defined. Definition gauss_clear_all_rows_inv3 { m n : nat } (mat : Matrix F m n) (p : n > 0) : is_row_echelon (gauss_clear_all_rows mat). Proof. apply (gauss_clear_rows_up_to_inv3 mat p (m,, natgthsnn _)). Defined. Lemma is_row_echelon_nil_matrix {m n : nat} {A : Matrix F m n} (eq0 : n = 0) : (@is_row_echelon _ m n A). Proof. unfold is_row_echelon; intros i_1 i_2. use tpair. {intros ?; apply fromstn0; now rewrite <- eq0. } simpl; intros eq ?. rewrite <- eq. apply funextfun; intros j. apply fromstn0; rewrite <- eq0; exact j. Defined. (** A variant on the echelon form given in the introduction. *) Lemma is_row_echelon_eq { m n : nat } (mat : Matrix F m n) : is_row_echelon mat -> ∏ i_1 i_2 : ⟦ m ⟧%stn, ∏ j_1 j_2 : ⟦ n ⟧%stn, i_1 < i_2 -> is_leading_entry (mat i_1) j_1 -> is_leading_entry (mat i_2) j_2 -> j_1 < j_2. Proof. destruct (natchoice0 n) as [contr_eq0 | p]. { unfold is_upper_triangular. intros ? ? ? j. apply fromstn0; now rewrite contr_eq0. } unfold is_row_echelon. intros H1 i_1 i_2 j_1 j_2 lt H2 H3. destruct (natgthorleh j_2 j_1) as [gt | leh]. {now apply gt. } destruct (H1 i_1 i_2) as [H4 H5]. destruct (natgthorleh j_2 j_1); try assumption. unfold is_leading_entry in H3. contradiction (pr1 H3). apply (H4 _ _ H2 lt leh). Defined. Lemma gaussian_elimination_width_0 {m n} (A : Matrix F m n) {eq0 : 0 = n} : ∑ (B : Matrix F _ _), (@matrix_inverse F _ B) × (is_row_echelon (B ** A)). Proof. exists (@identity_matrix F m). use tpair. { apply identity_matrix_invertible. } rewrite matlunax2. apply is_row_echelon_nil_matrix; now rewrite eq0. Defined. (** The main theorem: Gaussian elimination over arbitrary fields *) Theorem gaussian_elimination {m n} (A : Matrix F m n) : ∑ (B : Matrix F _ _), (@matrix_inverse F _ B) × (is_row_echelon (B ** A)). Proof. destruct (natchoice0 n) as [eq0 | gt]. { now apply gaussian_elimination_width_0. } exists (@gauss_clear_all_rows_as_left_matrix m n A gt). use tpair. { apply gauss_clear_all_rows_matrix_invertible. } rewrite gauss_clear_all_rows_as_matrix_eq; try assumption. now apply gauss_clear_all_rows_inv3. Defined. End Gauss. (** We now confirm that this fulfils the goal stated at the start of the file. But we do this as a duplicate, leaving the actual main theorem above with a transparent statement, for better searchability downstream. *) Local Theorem gaussian_elimination_summary : gaussian_elimination_stmt. Proof. intros F; apply gaussian_elimination. Defined. UniMath-20231010/UniMath/Algebra/GaussianElimination/Matrices.v000066400000000000000000000532151451125700300241200ustar00rootroot00000000000000 (** * Matrices Some matrix background material for [Algebra.GaussianElimination] Primary Author: Daniel @Skantz (November 2022) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.GaussianElimination.Auxiliary. Require Import UniMath.Algebra.GaussianElimination.Vectors. Local Notation Σ := (iterop_fun rigunel1 op1). Local Notation "A ** B" := (matrix_mult A B) (at level 40, left associativity). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). (** * Arbitrary types *) (** Purely structural facts about matrices over arbitary types *) Section Arbitrary_Types. Section Misc. Lemma col_inj {X : UU} (m n : nat) (mat1 mat2 : Matrix X m n) : (∏ i : (stn n), col mat1 i = col mat2 i) -> mat1 = mat2. Proof. intro H. apply funextfun; intro i; apply funextfun; intro j. specialize (H j). apply toforallpaths in H. apply H. Defined. End Misc. Section Vectors_as_Matrices. (** Vectors as column and row vectors *) Lemma weq_rowvec : ∏ X : UU, ∏ n : nat, Vector X n ≃ Matrix X 1 n. Proof. intros; apply weq_vector_1. Defined. Lemma row_vec_inj { X : rig } { n : nat } (v1 v2 : Vector X n) : row_vec v1 = row_vec v2 -> v1 = v2. Proof. intros H; apply (invmaponpathsweq (@weq_rowvec X n) _ _ H). Defined. Lemma weq_colvec : ∏ X : UU, ∏ n : nat, weq (Vector X n) (Matrix X n 1). Proof. intros; apply weqffun, weq_vector_1. Defined. Lemma col_vec_inj { X : rig } { n : nat } (v1 v2 : Vector X n) : col_vec v1 = col_vec v2 -> v1 = v2. Proof. intros H; apply (invmaponpathsweq (@weq_colvec X n) _ _ H). Defined. Lemma col_vec_inj_pointwise { X : rig } { n : nat } (v1 v2 : Vector X n) : forall i : (stn n), (col_vec v1 i) = (col_vec v2 i) -> (v1 i) = (v2 i). Proof. intros i eq; apply (invmaponpathsweq (@weq_vector_1 X) _ _ eq). Defined. Lemma col_vec_eq {X : UU} {n : nat} (v : Vector X n) : ∏ i : (stn 1), v = col (col_vec v) i. Proof. easy. Defined. End Vectors_as_Matrices. Section Transposition. Definition transpose_transpose {X : UU} {m n : nat} (mat : Matrix X m n) : transpose (transpose mat) = mat. Proof. easy. Defined. Lemma transpose_inj {X : UU} {m n : nat} (mat1 mat2 : Matrix X m n) : transpose mat1 = transpose mat2 -> mat1 = mat2. Proof. apply (maponpaths transpose). Defined. Definition is_symmetric_mat {X : UU} {n : nat} (mat : Matrix X n n) := transpose mat = mat. Lemma symmetric_mat_row_eq_col {X : UU} {n : nat} (mat : Matrix X n n) (i : ⟦ n ⟧%stn) : is_symmetric_mat mat -> row mat i = col mat i. Proof. intros H. unfold col, row. exact (toforallpaths _ _ _ (!H) i). Defined. End Transposition. End Arbitrary_Types. (** * Arbitary rigs Matrix algebra facts that hold over an arbitrary rig, not yet assumed commutative. *) Section General_Rigs. Context {R : rig}. Section General. Definition matrix_mult_unf {m n p} (mat1 : Matrix R m n) (mat2 : Matrix R n p) : Matrix R m p := λ i j, Σ (λ k, (mat1 i k * mat2 k j))%rig. Lemma matrix_mult_eq {m n p} (mat1 : Matrix R m n) (mat2 : Matrix R n p) : mat1 ** mat2 = matrix_mult_unf mat1 mat2. Proof. reflexivity. Defined. Definition matrix_add {m n} (mat1 : Matrix R m n) (mat2 : Matrix R m n) : Matrix R m n := entrywise _ _ op1 mat1 mat2. Local Notation "A ++' B" := (matrix_add A B) (at level 50, left associativity). Lemma matrix_add_comm {m n} (mat1 : Matrix R m n) (mat2 : Matrix R m n) : matrix_add mat1 mat2 = matrix_add mat2 mat1. Proof. apply entrywise_comm, rigcomm1. Defined. Lemma matrix_add_assoc {m n : nat} (mat1 : Matrix R m n) (mat2 : Matrix R m n) (mat3 : Matrix R m n) : matrix_add (matrix_add mat1 mat2) mat3 = matrix_add mat1 (matrix_add mat2 mat3). Proof. apply entrywise_assoc, rigassoc1. Defined. Lemma matrix_mult_assoc {m n p q} (mat1 : Matrix R m n) (mat2 : Matrix R n p) (mat3 : Matrix R p q) : (mat1 ** mat2) ** mat3 = mat1 ** (mat2 ** mat3). Proof. intros; unfold matrix_mult. apply funextfun; intro i; apply funextfun; intro j. etrans. 2: { symmetry. apply maponpaths, funextfun. intros k. apply vecsum_ldistr. } etrans. { apply maponpaths. apply funextfun. intros k. apply vecsum_rdistr. } rewrite vecsum_interchange. apply maponpaths, funextfun; intros k. apply maponpaths, funextfun; intros l. apply rigassoc2. Defined. Lemma matrix_mult_ldistr {m n p} (mat1 : Matrix R m n) (mat2 : Matrix R n p) (mat3 : Matrix R n p) : mat1 ** (mat2 ++' mat3) = (mat1 ** mat2) ++' (mat1 ** mat3). Proof. intros. rewrite matrix_mult_eq. unfold matrix_mult_unf, matrix_add , entrywise, pointwise. apply funextfun. intros i. apply funextfun. intros j. etrans. { apply maponpaths, funextfun; intros k. rewrite rigldistr; apply idpath. } apply vecsum_add. Defined. Lemma matrix_mult_rdistr {m n p} (mat1 : Matrix R m n) (mat2 : Matrix R m n) (mat3 : Matrix R n p) : (mat1 ++' mat2) ** mat3 = (mat1 ** mat3) ++' (mat2 ** mat3). Proof. intros. rewrite matrix_mult_eq. unfold matrix_mult_unf, matrix_add. unfold entrywise, pointwise. apply funextfun. intros i. apply funextfun. intros j. etrans. { apply maponpaths, funextfun; intros k. rewrite rigrdistr. exact (idpath _). } apply vecsum_add. Defined. Lemma matrix_mult_zero_vec_eq {m n : nat} {mat : Matrix R m n} : mat ** col_vec (const_vec 0%rig) = col_vec (const_vec 0%rig). Proof. rewrite matrix_mult_eq; unfold matrix_mult_unf. apply funextfun; intros i. unfold col_vec. apply funextfun; intros _. apply vecsum_eq_zero. intros k. apply rigmultx0. Defined. End General. Section Identity_Matrix. Lemma identity_matrix_symmetric {n : nat} : is_symmetric_mat (@identity_matrix R n). Proof. unfold is_symmetric_mat. apply funextfun. intros i. apply funextfun. intros j. unfold identity_matrix, transpose, flip. apply stn_eq_or_neq_symm_nondep. Defined. Definition id_row_stdb_vector {n} (i : ⟦n⟧%stn) : row (@identity_matrix R n) i = stdb_vector i. Proof. easy. Defined. Definition id_col_stdb_vector {n} (i : ⟦n⟧%stn) : col (@identity_matrix R n) i = stdb_vector i. Proof. apply funextfun; intros j. apply stn_eq_or_neq_symm_nondep. Defined. Lemma id_pointwise_prod { n : nat } (v : Vector R n) (i : ⟦ n ⟧%stn) : (@identity_matrix R n i) *pw v = (@scalar_lmult_vec R (v i) n (identity_matrix i)). Proof. unfold identity_matrix, scalar_lmult_vec, pointwise, vector_fmap. apply funextfun. intros k. destruct (stn_eq_or_neq i k) as [eq | neq]. - now rewrite riglunax2, rigrunax2, eq. - now rewrite rigmultx0, rigmult0x. Defined. Lemma sum_id_pointwise_prod { n : nat } (v : Vector R n) (i : ⟦ n ⟧%stn) : Σ ((identity_matrix i) *pw v) = (v i). Proof. apply sum_stdb_vector_pointwise_prod. Defined. Definition matlunel2 (n : nat) := @identity_matrix R n. Definition matrunel2 (n : nat) := @identity_matrix R n. Lemma matlunax2 : ∏ (m n: nat) (mat : Matrix R n m), (identity_matrix ** mat) = mat. Proof. intros. apply funextfun. intros i. apply funextfun. intros j. unfold matrix_mult, row. use sum_id_pointwise_prod. Defined. Lemma col_vec_mult_eq { m n : nat } (mat : Matrix R m n) (v1 : Vector R n) (v2 : Vector R m) (e : (mat ** (col_vec v1)) = col_vec v2) : ∏ i : (stn m), Σ ((mat i) *pw v1) = v2 i. Proof. now apply toforallpaths; use col_vec_inj. Defined. Lemma idmat_i_to_idvec {n : nat} (i : ⟦ n ⟧%stn) : (@identity_matrix R) i = (@stdb_vector R i). Proof. apply funextfun. intros j. apply funextfun. intros k. now destruct (stn_eq_or_neq j k). Defined. Lemma id_mat_ii {n : nat} (i : ⟦ n ⟧%stn) : (@identity_matrix R n) i i = rigunel2. Proof. unfold identity_matrix; now rewrite (stn_eq_or_neq_refl). Defined. Lemma id_mat_ij {n : nat} (i j : ⟦ n ⟧%stn) : i ≠ j -> (@identity_matrix R n) i j = rigunel1. Proof. intros i_neq_j. unfold identity_matrix. now rewrite (stn_eq_or_neq_right i_neq_j). Defined. Lemma matrunax2 : ∏ (m n : nat) (mat : Matrix R m n), (mat ** identity_matrix) = mat. Proof. intros m n mat. apply funextfun. intros i. apply funextfun. intros j. unfold matrix_mult. rewrite (pulse_function_sums_to_point _ j); rewrite <- (symmetric_mat_row_eq_col _ _ identity_matrix_symmetric); unfold pointwise, row. - now rewrite id_mat_ii, rigrunax2. - intros k j_neq_k; now rewrite (id_mat_ij _ _ j_neq_k), rigmultx0. Defined. Lemma identity_matrix_unique_left {m : nat} (Z : Matrix R m m) : (∏ n : nat, ∏ A : (Matrix R m n), (Z ** A) = A) -> Z = identity_matrix. Proof. intros impl. etrans. { apply pathsinv0, matrunax2. } apply impl. Defined. Lemma identity_matrix_unique_right {n : nat} (Z : Matrix R n n) : (∏ m : nat, ∏ A : (Matrix R m n), (A ** Z) = A) -> Z = identity_matrix. Proof. intros impl. etrans. { apply pathsinv0, matlunax2. } apply impl. Defined. Lemma idrow_sums_to_1 { n : nat } (i : ⟦ n ⟧%stn) : Σ ((@identity_matrix R n ) i) = 1%rig. Proof. apply stdb_vector_sums_to_1. Defined. End Identity_Matrix. Section Inverses. Definition matrix_left_inverse {m n : nat} (A : Matrix R m n) := ∑ (B : Matrix R n m), ((B ** A) = identity_matrix). Definition matrix_right_inverse {m n : nat} (A : Matrix R m n) := ∑ (B : Matrix R n m), ((A ** B) = identity_matrix). Definition matrix_inverse {n : nat} (A : Matrix R n n) := ∑ (B : Matrix R n n), ((A ** B) = identity_matrix) × ((B ** A) = identity_matrix). Coercion matrix_left_inverse_of_inverse {n : nat} (A : Matrix R n n) : @matrix_inverse n A -> @matrix_left_inverse n n A. Proof. intros [y [xy yx]]. esplit; eauto. Defined. Coercion matrix_right_inverse_of_inverse {n : nat} (A : Matrix R n n) : @matrix_inverse n A -> @matrix_right_inverse n n A. Proof. intros [y [xy yx]]. esplit; eauto. Defined. Lemma matrix_inverse_to_right_and_left_inverse {n : nat} (A : Matrix R n n) : (matrix_inverse A) -> matrix_left_inverse A × matrix_right_inverse A. Proof. intros inv; split. - apply matrix_left_inverse_of_inverse; exact inv. - apply matrix_right_inverse_of_inverse; exact inv. Defined. Lemma make_matrix_left_inverse {m n k: nat} (A : Matrix R m n) (B : Matrix R n m) (eq : matrix_mult A B = identity_matrix) : matrix_left_inverse B. Proof. now exists A. Defined. Lemma make_matrix_right_inverse {m n k: nat} (A : Matrix R m n) (B : Matrix R n m) (eq : matrix_mult A B = identity_matrix) : matrix_right_inverse A. Proof. now exists B. Defined. Lemma matrix_left_inverse_equals_right_inverse {m n k: nat} (A : Matrix R n n) (lft : matrix_left_inverse A) (rght : matrix_right_inverse A) : pr1 lft = pr1 rght. Proof. destruct lft as [? islft]. destruct rght as [rght isrght]; simpl. pose (H0 := matlunax2 n n rght). now rewrite <- islft, matrix_mult_assoc, isrght, matrunax2 in H0. Defined. Lemma matrix_right_left_inverse_to_inverse {n : nat} (A : Matrix R n n) : matrix_left_inverse A -> matrix_right_inverse A -> (matrix_inverse A). Proof. intros lft rght. use tpair; simpl. {apply lft. } split. 2: {apply lft. } rewrite (@matrix_left_inverse_equals_right_inverse n _ n _ lft rght). apply rght. Defined. Lemma matrix_inverse_unique {n : nat} (A : Matrix R n n) (B C : matrix_inverse A) : pr1 B = pr1 C. Proof. assert (eq : pr1 B = ((pr1 B) ** (A ** (pr1 C)))). { rewrite (pr1 (pr2 C)). now rewrite matrunax2. } rewrite eq, <- matrix_mult_assoc, (pr2 (pr2 B)). now rewrite matlunax2. Defined. Lemma left_inv_matrix_prod_is_left_inv {m n : nat} (A : Matrix R m n) (A' : Matrix R n n) (pa : matrix_left_inverse A) (pb : matrix_left_inverse A') : (matrix_left_inverse (A ** A')). Proof. intros. exists ((pr1 pb) ** (pr1 pa)); simpl. rewrite matrix_mult_assoc, <- (matrix_mult_assoc _ A _). now rewrite (pr2 pa), matlunax2, (pr2 pb). Defined. Lemma right_inv_matrix_prod_is_right_inv {m n : nat} (A : Matrix R m n) (A' : Matrix R n n) (pa : matrix_right_inverse A) (pb : matrix_right_inverse A') : (matrix_right_inverse (A ** A')). Proof. intros. use tpair; simpl. { exact ((pr1 pb) ** (pr1 pa)). } rewrite matrix_mult_assoc, <- (matrix_mult_assoc _ (pr1 pb) _). now rewrite (pr2 pb), matlunax2, (pr2 pa). Defined. Lemma inv_matrix_prod_invertible {n : nat} (A : Matrix R n n) (A' : Matrix R n n) (pa : matrix_inverse A) (pb : matrix_inverse A') : (matrix_inverse (A ** A')). Proof. use tpair; simpl. { exact ((pr1 pb) ** (pr1 pa)). } use tpair. - rewrite matrix_mult_assoc. rewrite <- (matrix_mult_assoc _ (pr1 pb) _). rewrite (pr1 (pr2 pb)), matlunax2. now rewrite (pr1 (pr2 pa)). - simpl; rewrite matrix_mult_assoc. now rewrite <- (matrix_mult_assoc _ A _), (pr2 (pr2 pa)), matlunax2, (pr2 (pr2 pb)). Defined. Lemma identity_matrix_invertible { n : nat } : matrix_inverse (@identity_matrix _ n). Proof. exists identity_matrix. use tpair; apply matrunax2. Defined. End Inverses. Section Nil_Matrices. Lemma iscontr_nil_row_matrix {X : UU} {n : nat} : iscontr (Matrix X 0 n). Proof. apply iscontr_nil_vector. Defined. Lemma iscontr_nil_col_matrix {X : UU} {m : nat} : iscontr (Matrix X m 0). Proof. apply impred_iscontr; intro; apply iscontr_nil_vector. Defined. Lemma nil_matrix_invertible {n : nat} (A : Matrix R 0 0): matrix_inverse A. Proof. exists identity_matrix. use tpair. - etrans. apply matrunax2. apply funextfun; intro i. now apply(@iscontr_nil_row_matrix _ 0). - etrans. apply matlunax2. apply funextfun; intro. now apply (@iscontr_nil_row_matrix _ 0). Defined. End Nil_Matrices. Section Diagonal. Definition diagonal_sq { n : nat } (mat : Matrix R n n) := λ i : (stn n), mat i i. Definition is_diagonal { m n : nat } (mat : Matrix R m n) := ∏ (i : ⟦ m ⟧%stn) (j : ⟦ n ⟧%stn), (stntonat _ i ≠ (stntonat _ j)) -> (mat i j) = 0%rig. Definition diagonal_all_nonzero { n : nat } (mat : Matrix R n n) := ∏ i : ⟦ n ⟧%stn, mat i i != 0%rig. Lemma diagonal_nonzero_iff_transpose_nonzero { n : nat } (A : Matrix R n n) : diagonal_all_nonzero A <-> diagonal_all_nonzero (transpose A). Proof. split ; intros H; unfold diagonal_all_nonzero, transpose, flip; apply H. Defined. End Diagonal. Section Triangular. Definition is_upper_triangular { m n : nat } (mat : Matrix R m n) := ∏ (i : ⟦ m ⟧%stn ) (j : ⟦ n ⟧%stn ), (stntonat _ i > (stntonat _ j)) -> (mat i j) = 0%rig. Definition is_lower_triangular { m n : nat } (mat : Matrix R m n) := ∏ (i : ⟦ m ⟧%stn ) (j : ⟦ n ⟧%stn ), (stntonat _ i < (stntonat _ j)) -> (mat i j) = 0%rig. Definition is_upper_triangular_partial { m n k : nat } (mat : Matrix R m n) := ∏ (i : ⟦ m ⟧%stn ) (j : ⟦ n ⟧%stn ), (stntonat _ i > (stntonat _ j)) -> i < k -> (mat i j) = 0%rig. Lemma upper_triangular_iff_transpose_lower_triangular { m n : nat } ( iter : ⟦ n ⟧%stn ) (mat : Matrix R m n) : is_upper_triangular mat <-> is_lower_triangular (transpose mat). Proof. unfold is_upper_triangular, is_lower_triangular, transpose, flip. split. - intros inv i j i_lt_j. rewrite inv; try assumption; reflexivity. - intros inv i j i_gt_j. rewrite inv; try assumption; reflexivity. Defined. End Triangular. Section Misc. Definition ij_minor {X : rig} {n : nat} ( i j : ⟦ S n ⟧%stn ) (mat : Matrix X (S n) (S n)) : Matrix X n n. Proof. intros i' j'. exact (mat (dni i i') (dni j j')). Defined. Lemma zero_row_product { m n p : nat } (A : Matrix R m n) (B : Matrix R n p) (i : ⟦m⟧%stn) (Ai_zero : row A i = const_vec 0%rig) : row (A ** B) i = const_vec 0%rig. Proof. apply toforallpaths in Ai_zero. apply funextfun; intro k. apply vecsum_eq_zero. intro j; unfold pointwise. etrans. { apply maponpaths_2, Ai_zero. } apply rigmult0x. Defined. End Misc. End General_Rigs. (** * Commutative rigs *) Section MatricesCommrig. Context {CR : commrig }. Lemma matrix_product_transpose { m n p : nat } (A : Matrix CR m n) (B : Matrix CR n p) : (transpose (A ** B)) = ((transpose B) ** (transpose A)). Proof. intros. apply funextfun. intros i. apply funextfun. intros k. apply vecsum_eq. intros j. unfold col, row, pointwise, transpose, flip; cbn. apply rigcomm2. Defined. Lemma row_vec_col_vec_mult_eq {m n} (A : Matrix CR m n) (x : Vector CR n) : transpose ((row_vec x) ** (transpose A)) = A ** (col_vec x). Proof. etrans. { apply matrix_product_transpose. } apply idpath. Defined. Lemma invertible_to_transpose_invertible { n } (mat : Matrix CR n n) : (@matrix_inverse CR n mat) -> (@matrix_inverse CR n (transpose mat)). Proof. intros [mat_inv [e_mi e_im]]. exists (transpose mat_inv). split; refine (!matrix_product_transpose _ _ @ maponpaths _ _ @ identity_matrix_symmetric); assumption. Defined. Lemma transpose_invertible_to_invertible { n } (mat : Matrix CR n n) : (@matrix_inverse CR n (transpose mat)) -> (@matrix_inverse CR n mat). Proof. apply invertible_to_transpose_invertible. Defined. Lemma matrix_left_inverse_to_transpose_right_inverse {m n} (A : Matrix CR m n) (inv: @matrix_left_inverse CR m n A) : (@matrix_right_inverse CR n m (@transpose CR n m A)). Proof. destruct inv as [inv isinv]. exists (transpose inv). etrans. { apply pathsinv0, matrix_product_transpose. } etrans. { apply maponpaths, isinv. } apply identity_matrix_symmetric. Defined. End MatricesCommrig. Section MatricesIntDom. Context {R : intdom}. (** Note: these results don’t really require that R is an integral domain, just that R is non-trivial. *) Lemma zero_row_to_non_right_invertibility { m n : nat } (A : Matrix R m n) (i : ⟦ m ⟧%stn) (zero_row : A i = (const_vec 0%ring)) : (@matrix_right_inverse R m n A) -> empty. Proof. intros [inv isrightinv]. contradiction (@nonzeroax R). etrans. { apply pathsinv0, (@id_mat_ii R). } do 2 (apply toforallpaths in isrightinv; specialize (isrightinv i)). etrans. { apply pathsinv0, isrightinv. } refine (toforallpaths _ _ _ _ i). apply (@zero_row_product R). apply zero_row. Defined. Lemma zero_row_to_non_invertibility { n : nat } (A : Matrix R n n) (i : ⟦ n ⟧%stn) (zero_row : A i = (const_vec 0%ring)) : (@matrix_inverse R n A) -> empty. Proof. intros invA. apply matrix_inverse_to_right_and_left_inverse in invA. destruct invA as [? rinvA]. apply (zero_row_to_non_right_invertibility A i); assumption. Defined. End MatricesIntDom. (** * Matrices representing permutations *) Section Transpositions. Context { R : rig }. Definition transposition_fun {n : nat} (i j : ⟦ n ⟧%stn) : ⟦ n ⟧%stn -> ⟦ n ⟧%stn. Proof. intros k. destruct (stn_eq_or_neq i k). - exact j. - destruct (stn_eq_or_neq j k). + exact i. + exact k. Defined. Definition transposition_self_inverse {n} (i j : ⟦ n ⟧%stn) : transposition_fun i j ∘ transposition_fun i j = idfun _. Proof. apply funextsec; intros k; simpl; unfold transposition_fun. destruct (stn_eq_or_neq i k) as [i_eq_k | i_neq_k]; destruct (stn_eq_or_neq i j) as [i_eq_j | i_neq_j]. - now destruct i_eq_j. - now rewrite stn_eq_or_neq_refl. - destruct i_eq_j. do 2 rewrite (stn_eq_or_neq_right i_neq_k). reflexivity. - destruct (stn_eq_or_neq j k) as [j_eq_k | j_neq_k]. + now rewrite stn_eq_or_neq_refl. + rewrite (stn_eq_or_neq_right i_neq_k). rewrite (stn_eq_or_neq_right j_neq_k). reflexivity. Defined. Definition transposition_perm {n : nat} (i j : ⟦ n ⟧%stn) : ⟦ n ⟧%stn ≃ ⟦ n ⟧%stn. Proof. exists (transposition_fun i j). use isweq_iso. - exact (transposition_fun i j). - apply toforallpaths, transposition_self_inverse. - apply toforallpaths, transposition_self_inverse. Defined. (* Note: can be generalize to functions on rows? *) Definition transposition_mat_rows {X : UU} {m n : nat} (i j : ⟦ m ⟧%stn) : (Matrix X m n) -> Matrix X m n. Proof. intros mat k. destruct (stn_eq_or_neq i k). - apply (mat j). - destruct (stn_eq_or_neq j k). + exact (mat i). + exact (mat k). Defined. Definition tranposition_mat_rows_perm_stmt {X : UU} {m n : nat} (i j : ⟦ m ⟧%stn) := (Matrix X m n) ≃ Matrix X m n. Definition is_permutation_fun {n : nat} (p : ⟦ n ⟧%stn -> ⟦ n ⟧%stn) := ∏ i j: ⟦ n ⟧%stn, (p i = p j) -> i = j. Definition id_permutation_fun (n : nat) : ⟦ n ⟧%stn -> ⟦ n ⟧%stn := λ i : ⟦ n ⟧%stn, i. Lemma idp_is_permutation_fun {n : nat} : is_permutation_fun (id_permutation_fun n). Proof. unfold is_permutation_fun, id_permutation_fun. intros; assumption. Defined. End Transpositions. UniMath-20231010/UniMath/Algebra/GaussianElimination/RowOps.v000066400000000000000000000372331451125700300236040ustar00rootroot00000000000000(** * Matrices Elementary row operations on matrices, for elimination procedures Primary Author: Daniel @Skantz (November 2022) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.GaussianElimination.Auxiliary. Require Import UniMath.Algebra.GaussianElimination.Vectors. Require Import UniMath.Algebra.GaussianElimination.Matrices. (** This file defines the traditional elementary row operations on matrices over a ring, as used in Gaussian elimination and related procedures: - addition of a multiple of a row to another row; - interchange of two rows; - multiplication of a row by a nonzero scalar. For each operation, we describe its action on matrices directly, and also equivalently as left multiplication by an elementary matrix. We further show that these elementary matrices are invertible (with inverses just the elementary matrices corresponding to inverse row operations). Hopefully the material can be easily re-used for column operations too. *) Local Notation Σ := (iterop_fun 0%rig op1). Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity). Local Notation "R1 +pw R2" := ((pointwise _ op1) R1 R2) (at level 50, left associativity). Local Notation "A ** B" := (@matrix_mult _ _ _ A _ B) (at level 40, left associativity). Local Notation "A **' B" := (@matrix_mult (_:ring) _ _ A _ B) (at level 40, left associativity). (* second notation is needed since [pr1ring] being a coercion means the inferred coercions to [setwithbinop] from [ring] and further structures factor syntactically through [ring] but NOT always [rig] *) Section Add_Row. Context { R : ring }. Definition add_row_mult { m n } (r1 r2 : ⟦ m ⟧%stn) (s : R) (mat : Matrix R m n) : ( Matrix R m n ). Proof. intros i j. induction (stn_eq_or_neq i r2). - exact ((mat r2 j) + (s * (mat r1 j)))%rig. - exact (mat i j). Defined. (* Note: There’s a tradeoff here (and similarly in other row-operations) between doing the case-split before or after introducing [j]. Putting the case-split first allows defining the rows as linear combinations of vectors, providing useful abstractions in some calculations later, but means the function isn’t in canonical form, which obstructs pointwise calculations. *) (** Basic properties of [add_row_mult] *) Lemma add_row_mult_nontarget_row {m n} (r1 r2 : ⟦ m ⟧%stn) (s : R) (mat : Matrix R m n) : ∏ (i : ⟦ m ⟧%stn), r2 ≠ i -> add_row_mult r1 r2 s mat i = mat i. Proof. intros i r2_ne_i. unfold add_row_mult. now rewrite (stn_eq_or_neq_right (issymm_stnneq r2_ne_i)). Defined. Definition add_row_mult_target_row {m n} (r1 r2 : ⟦ m ⟧%stn) (s : R) (mat : Matrix R m n) (c : ⟦ n ⟧%stn) : (add_row_mult r1 r2 s mat) r2 c = (mat r2 c + s * mat r1 c)%rig. Proof. unfold add_row_mult. now rewrite stn_eq_or_neq_refl. Defined. (** The add-a-row-multiple operation as a matrix *) Definition add_row_mult_matrix { n : nat } (r1 r2 : ⟦ n ⟧%stn) (s : R) : Matrix R n n. Proof. intros i. induction (stn_eq_or_neq i r2). - refine ((@stdb_vector R _ i) +pw (@scalar_lmult_vec R s _ (@stdb_vector R _ r1))). - refine (@stdb_vector R _ i). Defined. Lemma add_row_mult_as_matrix { m n } (r1 r2 : ⟦ m ⟧%stn) (ne : r1 ≠ r2) (s : R) (mat : Matrix R m n) : (add_row_mult_matrix r1 r2 s) **' mat = add_row_mult r1 r2 s mat. Proof. intros. apply funextfun; intros i; apply funextfun; intros j. unfold matrix_mult, add_row_mult_matrix, add_row_mult, col, row. destruct (stn_eq_or_neq i r2) as [i_eq_r2 | i_neq_r2]; simpl coprod_rect. - etrans. { apply maponpaths, (@pointwise_rdistr_vector R). } etrans. { apply vecsum_add. } apply map_on_two_paths. + etrans. 2: { apply maponpaths_2, i_eq_r2. } use sum_stdb_vector_pointwise_prod. + etrans. { apply vecsum_scalar_lmult. } apply maponpaths, @sum_stdb_vector_pointwise_prod. - use sum_stdb_vector_pointwise_prod. Defined. Lemma add_row_mult_matrix_sum { n : nat } ( r1 r2 : ⟦ n ⟧%stn ) (ne : r1 ≠ r2) ( s1 s2 : R ) : ((add_row_mult_matrix r1 r2 s1 ) **' (add_row_mult_matrix r1 r2 s2)) = (add_row_mult_matrix r1 r2 (s1 + s2)%ring). Proof. rewrite add_row_mult_as_matrix; try assumption. apply funextfun; intros i; apply funextfun; intros j. unfold add_row_mult, add_row_mult_matrix. destruct (stn_eq_or_neq i r2) as [i_eq_r2 | i_neq_r2]. 2: {apply idpath. } destruct i_eq_r2. rewrite stn_eq_or_neq_refl, (stn_eq_or_neq_right ne); simpl. unfold scalar_lmult_vec, pointwise, vector_fmap. rewrite (@rigrdistr R), rigcomm1, (@rigassoc1 R). reflexivity. Defined. Lemma add_row_mult_matrix_zero { n } ( r1 r2 : ⟦ n ⟧%stn ) (ne : r1 ≠ r2) : add_row_mult_matrix r1 r2 (@rigunel1 R) = @identity_matrix R _. Proof. apply funextfun; intros i. unfold add_row_mult_matrix. destruct (stn_eq_or_neq i r2) as [i_eq_r2 | i_neq_r2]. 2: { apply idpath. } destruct i_eq_r2. simpl. apply funextfun; intros j. unfold scalar_lmult_vec, pointwise, vector_fmap. rewrite (@rigmult0x R). apply (@rigrunax1 R). Defined. Lemma add_row_mult_matrix_commutes {n} ( r1 r2 : ⟦ n ⟧%stn) (ne : r1 ≠ r2) ( s1 s2 : R ) : ((add_row_mult_matrix r1 r2 s1 ) **' (add_row_mult_matrix r1 r2 s2 )) = ((add_row_mult_matrix r1 r2 s2 ) **' (add_row_mult_matrix r1 r2 s1 )). Proof. do 2 (rewrite add_row_mult_matrix_sum; try assumption). apply maponpaths, (@rigcomm1 R). Defined. Lemma add_row_mult_matrix_invertible { n } (r1 r2 : ⟦ n ⟧%stn) (ne : r1 ≠ r2) (s : R) : @matrix_inverse R n (add_row_mult_matrix r1 r2 s). Proof. exists (add_row_mult_matrix r1 r2 (- s)%ring). split; refine (add_row_mult_matrix_sum _ _ ne _ _ @ _); refine (_ @ add_row_mult_matrix_zero _ _ ne); apply maponpaths. - apply (@ringrinvax1 R). - apply (@ringlinvax1 R). Defined. (** Miscellaneous properties of [add_row_mult], used in [Algebra.GaussianElimination.Elimination] *) Lemma add_row_mult_source_row_zero {m n} (r1 r2 : ⟦ m ⟧%stn) (s : R) (mat : Matrix R m n) : mat r1 = const_vec 0%ring -> add_row_mult r1 r2 s mat = mat. Proof. intros eq0. apply funextfun; intros i'; apply funextfun; intros j'. unfold add_row_mult. destruct (stn_eq_or_neq _ _ ) as [i'_eq_j' | i'_neq_j']; simpl; try reflexivity. rewrite <- i'_eq_j', eq0. unfold const_vec ; simpl. rewrite (@rigmultx0 R). apply (@rigrunax1 R). Defined. End Add_Row. Section Mult_Row. Context { F : fld }. Definition scalar_mult_row { m n : nat} (r : ⟦ m ⟧%stn) (s : F) (mat : Matrix F m n) : Matrix F m n. Proof. intros i j. induction (stn_eq_or_neq i r). - exact (s * (mat i j))%ring. - exact (mat i j). Defined. (** The multiply-row operation as a matrix *) Definition scalar_mult_row_matrix {n : nat} (r : ⟦ n ⟧%stn) (s : F) : Matrix F n n. Proof. intros i. induction (stn_eq_or_neq i r). - exact (const_vec s *pw @stdb_vector F _ i). - exact (@stdb_vector F _ i). Defined. Lemma scalar_mult_as_matrix {m n : nat} (r : ⟦ m ⟧%stn) (s : F) (mat : Matrix F m n) : ((scalar_mult_row_matrix r s) **' mat) = scalar_mult_row r s mat. Proof. use funextfun; intros i; use funextfun; intros ?. unfold matrix_mult, scalar_mult_row_matrix, scalar_mult_row, row. destruct (stn_eq_or_neq i r) as [? | ?]. - simpl coprod_rect. etrans. { apply maponpaths. etrans. { apply maponpaths_2, (@pointwise_comm2_vector F). } apply pointwise_assoc2_vector. } use sum_stdb_vector_pointwise_prod. - simpl coprod_rect. use sum_stdb_vector_pointwise_prod. Defined. Lemma scalar_mult_matrix_product { n } ( r : ⟦ n ⟧%stn ) ( s1 s2 : F ) : ((scalar_mult_row_matrix r s1 ) **' (scalar_mult_row_matrix r s2 )) = (scalar_mult_row_matrix r (s1 * s2)%ring ). Proof. rewrite scalar_mult_as_matrix. unfold scalar_mult_row. unfold scalar_mult_row_matrix. apply funextfun; intros i. apply funextfun; intros j. destruct (stn_eq_or_neq i r); simpl coprod_rect. 2: { reflexivity. } unfold pointwise. apply pathsinv0, rigassoc2. Defined. Lemma scalar_mult_matrix_one {n : nat} (r : ⟦ n ⟧%stn) : scalar_mult_row_matrix r (@rigunel2 F) = @identity_matrix F _. Proof. unfold scalar_mult_row_matrix. apply funextfun; intros i. destruct (stn_eq_or_neq i r); simpl coprod_rect. 2: { reflexivity. } apply funextfun; intros j. apply (@riglunax2 F). Defined. Lemma scalar_mult_matrix_comm { n : nat } ( r : ⟦ n ⟧%stn ) ( s1 s2 : F ) : ((scalar_mult_row_matrix r s1) **' (scalar_mult_row_matrix r s2)) = ((scalar_mult_row_matrix r s2) **' (scalar_mult_row_matrix r s1)). Proof. do 2 rewrite scalar_mult_matrix_product. apply maponpaths, (rigcomm2 F). Defined. Lemma scalar_mult_matrix_invertible { n } ( i : ⟦ n ⟧%stn ) ( s : F ) ( ne : s != (@rigunel1 F)) : @matrix_inverse F _ (scalar_mult_row_matrix i s). Proof. exists (scalar_mult_row_matrix i (fldmultinv s ne)). split; refine (scalar_mult_matrix_product _ _ _ @ _); refine (_ @ scalar_mult_matrix_one i); apply maponpaths. - apply fldmultinvrax; assumption. - apply fldmultinvlax; assumption. Defined. End Mult_Row. Section Switch_Row. Context { R : rig }. Definition switch_row {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : Matrix R m n. Proof. intros i j. induction (stn_eq_or_neq i r1). - exact (mat r2 j). - induction (stn_eq_or_neq i r2). + exact (mat r1 j). + exact (mat i j). Defined. (** Basic properties of [switch_row] *) Lemma switch_row_former_row {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) (j : ⟦n⟧%stn) : switch_row r1 r2 mat r1 j = mat r2 j. Proof. unfold switch_row. rewrite stn_eq_or_neq_refl; simpl. reflexivity. Defined. Lemma switch_row_latter_row {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) (j : ⟦n⟧%stn) : switch_row r1 r2 mat r2 j = mat r1 j. Proof. unfold switch_row. rewrite stn_eq_or_neq_refl; simpl. destruct (stn_eq_or_neq r2 r1) as [ e | ? ]; simpl; try destruct e; reflexivity. Defined. Lemma switch_row_other_row {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) (i : ⟦ m ⟧%stn) (ne1 : i ≠ r1) (ne2 : i ≠ r2) (j : ⟦n⟧%stn) : switch_row r1 r2 mat i j = mat i j. Proof. unfold switch_row. rewrite (stn_eq_or_neq_right ne1), (stn_eq_or_neq_right ne2). simpl; reflexivity. Defined. Lemma switch_row_former_row' {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) (i : ⟦m⟧%stn) (e : i = r1) (j : ⟦n⟧%stn) : switch_row r1 r2 mat i j = mat r2 j. Proof. destruct e; apply switch_row_former_row. Defined. Lemma switch_row_latter_row' {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) (i : ⟦m⟧%stn) (e : i = r2) (j : ⟦n⟧%stn) : switch_row r1 r2 mat i j = mat r1 j. Proof. destruct e; apply switch_row_latter_row. Defined. Lemma switch_row_other_row' {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : ∏ (i : ⟦ m ⟧%stn), i ≠ r1 -> i ≠ r2 -> (switch_row r1 r2 mat) i = mat i. Proof. intros i i_ne_r1 i_ne_r2. apply funextfun; intros j. apply switch_row_other_row; assumption. Defined. (** The switch-row operation as a matrix *) Definition switch_row_matrix {n : nat} (r1 r2 : ⟦ n ⟧ %stn) : Matrix R n n. Proof. intros i. induction (stn_eq_or_neq i r1). - exact (@identity_matrix R n r2). - induction (stn_eq_or_neq i r2). + exact (@identity_matrix R n r1). + exact (@identity_matrix R n i). Defined. Lemma switch_row_as_matrix {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : ((switch_row_matrix r1 r2) ** mat) = switch_row r1 r2 mat. Proof. apply funextfun; intros i; apply funextfun; intros j. rewrite matrix_mult_eq; unfold matrix_mult_unf. unfold switch_row_matrix, switch_row. destruct (stn_eq_or_neq i r1) as [i_eq_r1 | i_neq_r1]; destruct (stn_eq_or_neq i r2) as [i_eq_r2 | i_neq_r2]; simpl; use sum_stdb_vector_pointwise_prod. Defined. Definition switch_row_involution {m n : nat} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : switch_row r1 r2 (switch_row r1 r2 mat) = mat. Proof. apply funextfun; intros i; apply funextfun; intros j. destruct (stn_eq_or_neq i r1) as [ e_i_r1 | ne_i_r1 ]; [ | destruct (stn_eq_or_neq i r2) as [ e_i_r2 | ne_i_r2 ]]. - destruct e_i_r1. etrans. { apply switch_row_former_row. } apply switch_row_latter_row. - destruct e_i_r2. etrans. { apply switch_row_latter_row. } apply switch_row_former_row. - etrans; apply switch_row_other_row; assumption. Defined. Lemma switch_row_matrix_involution { n : nat } ( r1 r2 : ⟦ n ⟧%stn ) : ((switch_row_matrix r1 r2) ** (switch_row_matrix r1 r2)) = @identity_matrix _ _. Proof. intros. rewrite switch_row_as_matrix. unfold switch_row, switch_row_matrix. apply funextfun; intros i. destruct (stn_eq_or_neq i r1) as [eq | neq]; destruct (stn_eq_or_neq r1 r2) as [eq' | neq']; rewrite stn_eq_or_neq_refl; simpl. - rewrite eq'; rewrite stn_eq_or_neq_refl; simpl. apply funextfun; intros j. rewrite <- eq', eq; apply idpath. - rewrite eq; simpl. rewrite (stn_eq_or_neq_right (issymm_stnneq neq')); simpl. reflexivity. - rewrite <- eq'; rewrite stn_eq_or_neq_refl; simpl. rewrite (stn_eq_or_neq_right neq); simpl. reflexivity. - rewrite stn_eq_or_neq_refl; simpl. destruct (stn_eq_or_neq _ _) as [eq | ?]; simpl. + now rewrite eq. + reflexivity. Defined. Lemma switch_row_matrix_invertible { n : nat } ( r1 r2 : ⟦ n ⟧%stn ) : @matrix_inverse R n (switch_row_matrix r1 r2). Proof. exists (switch_row_matrix r1 r2). split; apply switch_row_matrix_involution. Defined. (** Miscellaneous properties of [switch_row], used in [Algebra.GaussianElimination.Elimination] *) Lemma switch_row_equal_rows {m n} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : (mat r1) = (mat r2) -> (switch_row r1 r2 mat) = mat. Proof. intros m_eq. unfold switch_row. apply funextfun. intros i'. destruct (stn_eq_or_neq _ _) as [eq | neq]. - destruct (stn_eq_or_neq _ _) as [eq' | neq']. + now apply maponpaths. + etrans. apply m_eq. now apply maponpaths. - destruct (stn_eq_or_neq _ _) as [eq | cec]. + cbn. etrans. apply(!m_eq). apply maponpaths, (!eq). + apply idpath. Qed. Lemma switch_row_equal_entries {m n : nat} (r1 r2 : ⟦ m ⟧%stn) (mat : Matrix R m n) : ∏ (j : ⟦ n ⟧%stn), (mat r1 j) = (mat r2 j) -> ∏ (r3 : ⟦ m ⟧%stn), (switch_row r1 r2 mat) r3 j = mat r3 j. Proof. intros j m_eq r3. unfold switch_row. destruct (stn_eq_or_neq _ _) as [eq | neq]. - destruct (stn_eq_or_neq _ _) as [eq' | neq']; cbn. + now apply maponpaths_2. + etrans. apply m_eq. now apply maponpaths_2. - destruct (stn_eq_or_neq _ _) as [eq | cec]; cbn. + etrans. apply(!m_eq). now apply maponpaths_2. + apply idpath. Qed. End Switch_Row. UniMath-20231010/UniMath/Algebra/GaussianElimination/Tests.v000066400000000000000000000124061451125700300234500ustar00rootroot00000000000000Require Import UniMath.Algebra.GaussianElimination.Elimination. Require Import UniMath.Algebra.GaussianElimination.RowOps. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Combinatorics.Maybe. Require Import UniMath.Combinatorics.FiniteSequences. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Algebra.Archimedean. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.RigsAndRings. (** Observing/testing the extent that it is possible to compute some of the Elimination material. Primary author: Daniel @Skantz (November 2022) *) (** This section tests just the matrix/vector operations, avoiding use of the ring operations as far as possible. *) Section Tests_1. Context (R : rig). Context (F : fld). (* natcommrig is not available at this point (requires the later package NaturalNumbersAlgebra). Restating the below is sufficient for the tests, which could still be nice to have. *) Local Definition natcommrig' : commrig. Proof. split with (make_setwith2binop natset (make_dirprod (λ n m : nat, n + m) (λ n m : nat, n * m))). split. - split. + split with (make_dirprod (make_dirprod (make_dirprod natplusassoc (@make_isunital natset _ 0 (make_dirprod natplusl0 natplusr0))) natpluscomm) (make_dirprod natmultassoc (@make_isunital natset _ 1 (make_dirprod natmultl1 natmultr1)))). apply (make_dirprod natmult0n natmultn0). + apply (make_dirprod natldistr natrdistr). - unfold iscomm. apply natmultcomm. Defined. Local Definition nattorig' {X : rig} (n : nat) : X := natmult (X := rigaddabmonoid X) n 1%rig. (* End duplicated definitions. *) Let v1 := (append_vec empty_vec 2). Let v2 := (append_vec empty_vec 3). Let eval1 := Eval compute in firstValue (@pointwise nat _ mul v1 v2). Local Lemma eq1 : eval1 = 6. Proof. apply idpath. Defined. Let v3 := (append_vec (append_vec empty_vec 2) 3). Let v4 := (append_vec (append_vec empty_vec 3) 4). Let eval2 := Eval compute in firstValue (@pointwise nat _ mul v1 v2). Local Lemma eq2 : eval2 = 6. Proof. apply idpath. Defined. Let eval3 := Eval compute in stnsum (@pointwise nat _ mul v3 v4). Local Lemma eq3 : eval3 = 18. Proof. apply idpath. Defined. Let e1 := (@nattorig natcommrig' 2). Let e2 := (@nattorig natcommrig' 3). Let v5 := (append_vec (append_vec empty_vec e1) e1). Let v6 := (append_vec (append_vec empty_vec e2) e2). Let m1 := append_vec (row_vec v5) v6. (* dot product of [2, 2], [3, 3] *) Let eval4 := Eval compute in ((iterop_fun (@rigunel2 natcommrig') op1 (pointwise _ op2 v5 v6))). (* 12 *) Local Lemma eq4 : eval4 = 12. Proof. apply idpath. Defined. (* matrix product : [2, 2] [2, 2] = [10, 10] [3, 3] [3, 3] [15, 15] *) (* Computing entry (1, 1) : *) Let eval5 := Eval compute in firstValue (firstValue (@matrix_mult _ _ _ m1 _ m1)). Local Lemma eq5 : eval5 = 10. Proof. apply idpath. Defined. Let m5 := (@identity_matrix natcommrig' 10). Let eval6 := Eval cbn in (@matrix_mult _ _ _ m5 _ m5). Local Lemma eq6 : firstValue (firstValue eval6) = (@nattorig natcommrig' 1). Proof. apply idpath. Defined. (* Switch : [1, 0] -> [0, 1] [0, 1] [1, 0]*) Let eval7 := @switch_row _ 2 2 (0,, (natgthsnn 0)) (1,, (natgthsnn _)) (@identity_matrix R 2). Local Lemma eq7 : (firstValue (firstValue eval7)) = (@rigunel1 R). Proof. apply idpath. Defined. Local Lemma eq8 : (firstValue (lastValue eval7)) = (@rigunel2 R). Proof. apply idpath. Defined. Let m9 := (@identity_matrix natcommrig' 2). Let v9 := @iterop_fun (Matrix natcommrig' 2 2) m9 (λ X : Matrix natcommrig' 2 2, matrix_mult X). (* [ [I_2 * I_2 * I_2]_{1, 1}*) Let eval9 := Eval vm_compute in (firstValue (firstValue (v9 3 (λ X : stn 3, m9)))). Let eq9 : eval9 = (@rigunel2 natcommrig'). Proof. apply idpath. Defined. End Tests_1. (** This section tests computation in the integers [hz] and rationals [hq]. Requires importing NaturalNumberSystems.{RationalNumbers, Integers}. Section Tests_2. (* Context {R: rig}. Context {F: fld}. *) (* Very slow *) (* Eval cbn in (1 + 1 + 1 + 1 + 1)%hz. *) Let v3 := (append_vec empty_vec (1 + 1)%hz). Let v4 := (append_vec empty_vec (1 + 1)%hq). (* Let eval6 := Eval cbn in (op2 (1 + 1) (1 + 1))%hz. *) (* rigtoringop2int natcommrig (make_dirprod 2 0) (make_dirprod 2 0)) *) (* < 1 second, not computing. *) (* Eval cbn in (firstValue (@pointwise hz _ op2 v3 v3)). (* rigtoringop2int _ (make_dirprod 2 0) (make_dirprod 2 0) *) *) (* < 1 second, not computing. *) (* Eval cbn in firstValue (firstValue (@matrix_mult hz _ _ (row_vec v3) _ (col_vec v3))). *) (* Let v9 := (append_vec (append_vec empty_vec (@rigunel1 hq)) (@rigunel2 hq)). *) (* Slow, not computing. Neither is the dual. *) (* Let eval9 := Eval native_compute in leading_entry_compute _ v9. *) (* A minute - and not computing *) (* Let eval6 := Eval cbn in ((@gaussian_elimination hq _ _ (row_vec v3))). *) End Tests_2. *)UniMath-20231010/UniMath/Algebra/GaussianElimination/Vectors.v000066400000000000000000000347621451125700300240040ustar00rootroot00000000000000 (** * Matrices Background on vectors, for [Algebra.GaussianElimination.Elimination] Author: Daniel @Skantz (September 2022) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Nat. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.Matrix. Require Import UniMath.Algebra.GaussianElimination.Auxiliary. Section Arbitrary_Vectors. (** * Vectors in arbitrary types *) Lemma vector_fmap {X Y : UU} (f : X -> Y) {n} : Vector X n -> Vector Y n. Proof. intros ? ?; auto. Defined. Lemma iscontr_nil_vector {X : UU} : iscontr (Vector X 0). Proof. apply iscontrfunfromempty2. apply fromstn0. Defined. Lemma vector_1_inj { X : rig } { n : nat } (e1 e2 : X) : (λ y : (⟦ 1 ⟧)%stn, e1) = (λ y : (⟦ 1 ⟧)%stn, e2) -> e1 = e2. Proof. intros eq; apply (invmaponpathsweq (@weq_vector_1 X) _ _ eq). Defined. Lemma const_vec_eq {X : UU} {n : nat} (v : Vector X n) (e : X) (i : ⟦ n ⟧%stn) : v = const_vec e -> v i = e. Proof. intros eq. rewrite eq. reflexivity. Defined. End Arbitrary_Vectors. (** * Basic vector algebra over rigs *) (** First basic algebra on vectors in rigs: pointwise operations, standard basis vectors, etc. *) Local Notation "v1 *pw v2" := ((pointwise _ op2) v1 v2) (at level 40, left associativity). Local Notation "v1 +pw v2" := ((pointwise _ op1) v1 v2) (at level 50, left associativity). Section Basic_Vector_Algebra. Context { R : rig }. Definition scalar_lmult_vec (s : R) {n} (vec: Vector R n) := vector_fmap (fun x => s * x)%rig vec. Definition scalar_rmult_vec {n} (vec: Vector R n) (s : R) := vector_fmap (fun x => x * s)%rig vec. Lemma pointwise_rdistr_vector { n : nat } (v1 v2 v3 : Vector R n) : (v1 +pw v2) *pw v3 = (v1 *pw v3) +pw (v2 *pw v3). Proof. use (pointwise_rdistr (rigrdistr R)). Defined. Lemma pointwise_assoc2_vector { n : nat } (v1 v2 v3 : Vector R n) : (v1 *pw v2) *pw v3 = v1 *pw (v2 *pw v3). Proof. use (pointwise_assoc (rigassoc2 R)). Defined. Lemma pointwise_comm2_vector {CR: commrig} { n : nat } (v1 v2 : Vector CR n) : v1 *pw v2 = v2 *pw v1. Proof. use (pointwise_comm (rigcomm2 CR)). Defined. Definition stdb_vector { n : nat } (i : ⟦ n ⟧%stn) : Vector R n. Proof. intros j. induction (stn_eq_or_neq i j). - exact rigunel2. - exact rigunel1. Defined. Definition stdb_ii {n : nat} (i : ⟦ n ⟧%stn) : (stdb_vector i) i = rigunel2. Proof. unfold stdb_vector; rewrite (stn_eq_or_neq_refl); apply idpath. Defined. Definition stdb_ij {n : nat} (i j : ⟦ n ⟧%stn) : i ≠ j -> (stdb_vector i) j = rigunel1. Proof. intros i_neq_j. unfold stdb_vector. now rewrite (stn_eq_or_neq_right i_neq_j). Defined. End Basic_Vector_Algebra. (** * Total sums of vectors *) Local Notation Σ := (iterop_fun 0%rig op1). Section Vector_Sums. Context { R : rig }. (** Many of the following are generalisations of versions for natural numbers, given in [Combinatorics.StandardFiniteSets] using the keyword [stnsum]. For now they are given here for rigs; many use only the additive structure, so could be generalised to commutative monoids (or arbitrary monoids). Lemmas involving the least structure are given first. *) Lemma vecsum_empty (v1 : Vector R 0) : Σ v1 = 0%rig. Proof. reflexivity. Defined. Lemma vecsum_step {n : nat} (f : ⟦ S n ⟧%stn -> R) : Σ f = (Σ (f ∘ (dni lastelement)) + f lastelement)%rig. Proof. intros; apply iterop_fun_step; apply riglunax1. Defined. Lemma transport_vecsum {m n : nat} (e: m = n) (g: ⟦ n ⟧%stn -> R) : Σ g = Σ (λ i, g (transportf stn e i)). Proof. intros; now induction e. Defined. Lemma vecsum_eq {n : nat} (f g : ⟦ n ⟧%stn -> R) : f ~ g -> Σ f = Σ g. Proof. intros H. induction n as [|n IH]; try apply idpath. rewrite 2 vecsum_step. induction (H lastelement). apply (maponpaths (λ i, op1 i (f lastelement))). apply IH; intro x; apply H. Defined. Lemma vecsum_zero {n} : Σ (@const_vec R n 0%rig) = 0%rig. Proof. induction n as [ | n IH]. { reflexivity. } rewrite vecsum_step. rewrite rigrunax1. apply IH. Defined. Lemma vecsum_eq_zero {n} (v : Vector R n) (v_0 : v ~ const_vec 0%rig) : Σ v = 0%rig. Proof. etrans. { apply vecsum_eq, v_0. } apply vecsum_zero. Defined. Lemma vecsum_left_right : ∏ (m n : nat) (f : (⟦ m + n ⟧)%stn → R), Σ f = op1 (Σ (f ∘ stn_left m n)) (Σ (f ∘ stn_right m n)). Proof. intros. induction n as [| n IHn]. { change (Σ _) with (@rigunel1 R) at 3. set (a := m + 0). assert (a = m). { apply natplusr0. } assert (e := ! natplusr0 m). rewrite (transport_vecsum e). unfold funcomp. rewrite rigrunax1. apply maponpaths. apply pathsinv0. apply funextfun. intros i. now rewrite <- stn_left_0. } rewrite vecsum_step. assert (e : S (m + n) = m + S n). { apply pathsinv0. apply natplusnsm. } rewrite (transport_vecsum e). rewrite vecsum_step. rewrite <- rigassoc1. apply map_on_two_paths. { rewrite IHn; clear IHn. apply map_on_two_paths. { apply vecsum_eq; intro i. unfold funcomp. apply maponpaths. apply subtypePath_prop. rewrite stn_left_compute. induction e. rewrite idpath_transportf. rewrite dni_last. apply idpath. } { apply vecsum_eq; intro i. unfold funcomp. apply maponpaths. apply subtypePath_prop. rewrite stn_right_compute. unfold stntonat. induction e. rewrite idpath_transportf. rewrite 2? dni_last. apply idpath. } } unfold funcomp. apply maponpaths. apply subtypePath_prop. now induction e. Defined. Lemma vecsum_dni {n : nat} (f : ⟦ S n ⟧%stn -> R) (j : ⟦ S n ⟧%stn ) : Σ f = op1 (Σ (f ∘ dni j)) (f j). Proof. intros. induction j as [j J]. assert (e2 : j + (n - j) = n). { rewrite natpluscomm. apply minusplusnmm. apply natlthsntoleh. exact J. } assert (e : (S j) + (n - j) = S n). { change (S j + (n - j)) with (S (j + (n - j))). apply maponpaths. exact e2. } intermediate_path (Σ (λ i, f (transportf stn e i))). - apply (transport_vecsum e). - rewrite (vecsum_left_right (S j) (n - j)); unfold funcomp. apply pathsinv0. rewrite (transport_vecsum e2). rewrite (vecsum_left_right j (n-j)); unfold funcomp. rewrite (vecsum_step (λ x, f (transportf stn e _))); unfold funcomp. apply pathsinv0. rewrite rigassoc1. rewrite (@rigcomm1 R (f _) ). rewrite <- rigassoc1. apply map_on_two_paths. + apply map_on_two_paths. * apply vecsum_eq; intro i. induction i as [i I]. apply maponpaths. apply subtypePath_prop. induction e. rewrite idpath_transportf. rewrite stn_left_compute. unfold dni,di, stntonat; simpl. induction (natlthorgeh i j) as [R'|R']. -- unfold stntonat; simpl; rewrite transport_stn; simpl. induction (natlthorgeh i j) as [a|b]. ++ apply idpath. ++ contradicts R' (natlehneggth b). -- unfold stntonat; simpl; rewrite transport_stn; simpl. induction (natlthorgeh i j) as [V|V]. ++ contradicts I (natlehneggth R'). ++ apply idpath. * apply vecsum_eq; intro i. induction i as [i I]. apply maponpaths. unfold dni,di, stn_right, stntonat; repeat rewrite transport_stn; simpl. induction (natlthorgeh (j+i) j) as [X|X]. -- contradicts (negnatlthplusnmn j i) X. -- apply subtypePath_prop. simpl. apply idpath. + apply maponpaths. rewrite transport_stn; simpl. apply subtypePath_prop, idpath. Defined. Lemma vecsum_to_rightsum {n m' n' : nat} (p : m' + n' = n) (f : ⟦ m' + n' ⟧%stn -> R) (left_part_is_zero : (f ∘ stn_left m' n') = const_vec 0%rig): Σ f = Σ (f ∘ stn_right m' n' ). Proof. rewrite vecsum_left_right, vecsum_eq_zero. - now rewrite riglunax1. - now rewrite (left_part_is_zero ). Defined. Lemma vecsum_to_leftsum {n m' n' : nat} (p : m' + n' = n) (f : ⟦ m' + n' ⟧%stn -> R) (right_part_is_zero : (f ∘ stn_right m' n') = const_vec 0%rig): Σ f = Σ (f ∘ stn_left m' n' ). Proof. rewrite vecsum_left_right, rigcomm1, vecsum_eq_zero. - now rewrite riglunax1. - now rewrite right_part_is_zero. Defined. Lemma vecsum_add {n} (v1 v2 : (⟦ n ⟧)%stn -> R) : Σ (v1 +pw v2) = (Σ v1 + Σ v2)%rig. Proof. induction n as [| n IH]. - cbn. apply pathsinv0, riglunax1. - rewrite 3 vecsum_step. etrans. { apply maponpaths_2. apply IH. } refine (rigassoc1 _ _ _ _ @ _ @ !rigassoc1 _ _ _ _). apply maponpaths. refine (!rigassoc1 _ _ _ _ @ _ @ rigassoc1 _ _ _ _). apply maponpaths_2. apply rigcomm1. Defined. Lemma vecsum_interchange : ∏ (m n : nat) (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn -> R), Σ (λ i: (⟦ m ⟧)%stn, Σ (λ j : (⟦ n ⟧)%stn, f j i) ) = Σ (λ j: (⟦ n ⟧)%stn, Σ (λ i : (⟦ m ⟧)%stn, f j i)). Proof. intros. induction n as [| n IH]. - induction m. { reflexivity. } change (Σ (λ i : (⟦ 0 ⟧)%stn, Σ ((λ j : (⟦ _ ⟧)%stn, f i j) ))) with (@rigunel1 R). apply vecsum_zero. - rewrite vecsum_step. unfold funcomp. rewrite <- IH, <- vecsum_add. apply maponpaths, funextfun; intros i. rewrite vecsum_step. reflexivity. Defined. (** From here on, we are really using the ring structure *) Lemma vecsum_ldistr : ∏ (n : nat) (vec : Vector R n) (s : R), op2 s (Σ vec) = Σ (scalar_lmult_vec s vec). Proof. intros. induction n as [| n IH]. - simpl. apply rigmultx0. - rewrite 2 vecsum_step. rewrite rigldistr. apply maponpaths_2, IH. Defined. Lemma vecsum_rdistr: ∏ (n : nat) (vec : Vector R n) (s : R), op2 (Σ vec) s = Σ (scalar_rmult_vec vec s). Proof. intros. induction n as [| n IH]. - apply rigmult0x. - rewrite 2 vecsum_step. rewrite rigrdistr. apply maponpaths_2, IH. Defined. Lemma vecsum_scalar_lmult {m} (s : R) (v w : Vector R m) : Σ (scalar_lmult_vec s v *pw w) = (s * Σ (v *pw w))%rig. Proof. etrans. 2: { apply pathsinv0, vecsum_ldistr. } apply vecsum_eq. intro i. apply rigassoc2. Defined. End Vector_Sums. Section Pulse_Functions. (** * Pulse functions Some lemmata on “pulse functions”, i.e. vectors with only one or two non-zero values; this turns out to be a useful framework for arguments with elementary row operations. *) Context { R : rig }. Definition is_pulse_function { n : nat } ( i : ⟦ n ⟧%stn ) (f : ⟦ n ⟧%stn -> R) := ∏ (j: ⟦ n ⟧%stn), (i ≠ j) -> (f j = 0%rig). Lemma pulse_function_sums_to_point { n : nat } (f : ⟦ n ⟧%stn -> R) (i : ⟦ n ⟧%stn) (f_pulse_function : is_pulse_function i f) : Σ f = f i. Proof. destruct (stn_inhabited_implies_succ i) as [n' e_n_Sn']. destruct (!e_n_Sn'). rewrite (vecsum_dni f i). rewrite vecsum_eq_zero. { rewrite riglunax1. apply idpath. } intros k. unfold funcomp. unfold const_vec. assert (i_neq_dni : i ≠ dni i k). {exact (dni_neq_i i k). } intros; destruct (stn_eq_or_neq i (dni i k) ) as [eq | neq]. - apply (stnneq_iff_nopath i (dni i k)) in eq. apply weqtoempty. intros. apply eq. assumption. exact (dni_neq_i i k). - apply f_pulse_function; exact neq. Defined. Lemma is_pulse_function_stdb_vector { n : nat } (i : ⟦ n ⟧%stn) : is_pulse_function i (stdb_vector i). Proof. intros j i_neq_j. unfold stdb_vector, pointwise. now rewrite (stn_eq_or_neq_right i_neq_j). Defined. Lemma stdb_vector_sums_to_1 { n : nat } (i : ⟦ n ⟧%stn) : Σ (@stdb_vector R n i) = 1%rig. Proof. etrans. { apply (pulse_function_sums_to_point _ i), is_pulse_function_stdb_vector. } unfold stdb_vector; now rewrite stn_eq_or_neq_refl. Defined. Lemma pulse_prod_is_pulse {n : nat} (f g : stn n -> R) {i : stn n} (H : is_pulse_function i f) : is_pulse_function i (f *pw g). Proof. unfold is_pulse_function in * |- ; intros j. intros neq; unfold pointwise. etrans. { apply maponpaths_2. apply(H j neq). } apply rigmult0x. Defined. Lemma sum_stdb_vector_pointwise_prod { n : nat } (v : Vector R n) (i : ⟦ n ⟧%stn) : Σ (stdb_vector i *pw v) = (v i). Proof. etrans. { apply (pulse_function_sums_to_point _ i) , (pulse_prod_is_pulse _ _ ) , is_pulse_function_stdb_vector. } unfold pointwise, stdb_vector. rewrite stn_eq_or_neq_refl. apply riglunax2. Defined. Lemma pointwise_prod_stdb_vector {n : nat} (v : Vector R n) (i : ⟦ n ⟧%stn) : v *pw (stdb_vector i) = scalar_lmult_vec (v i) (stdb_vector i). Proof. apply funextfun. intros j. unfold scalar_lmult_vec, vector_fmap, pointwise. destruct (stn_eq_or_neq i j) as [i_eq_j | i_neq_j]. - rewrite i_eq_j; apply idpath. - unfold stdb_vector. rewrite (stn_eq_or_neq_right i_neq_j). now do 2 rewrite rigmultx0. Defined. Lemma two_pulse_function_sums_to_points { n : nat } (f : ⟦ n ⟧%stn -> R) (i : ⟦ n ⟧%stn) (j : ⟦ n ⟧%stn) (ne_i_j : i ≠ j) (f_two_pulse : ∏ (k: ⟦ n ⟧%stn), (k ≠ i) -> (k ≠ j) -> (f k = 0%rig)) : (Σ f = f i + f j)%rig. Proof. assert (H : f = (scalar_lmult_vec (f i) (stdb_vector i)) +pw (scalar_lmult_vec (f j) (stdb_vector j))). { apply funextfun. intros k. unfold stdb_vector, scalar_lmult_vec, vector_fmap, pointwise. destruct (stn_eq_or_neq i k) as [i_eq_k | i_neq_k]. - destruct (stn_eq_or_neq j k) as [j_eq_k | j_neq_k]; destruct i_eq_k. + destruct j_eq_k. now apply isirrefl_natneq in ne_i_j. + now rewrite rigmultx0, rigrunax1, rigrunax2. - rewrite rigmultx0, riglunax1. destruct (stn_eq_or_neq j k) as [j_eq_k | j_neq_k]. + now rewrite rigrunax2, j_eq_k. + rewrite rigmultx0; apply f_two_pulse; now apply issymm_natneq. } etrans. { apply maponpaths, H. } etrans. { apply vecsum_add. } apply maponpaths_12; rewrite <- vecsum_ldistr, stdb_vector_sums_to_1; apply rigrunax2. Defined. End Pulse_Functions. UniMath-20231010/UniMath/Algebra/GroupAction.v000066400000000000000000000613551451125700300206440ustar00rootroot00000000000000(* -*- coding: utf-8 *) (** * Group actions *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Combinatorics.OrderedSets. Import UniMath.MoreFoundations.PartA. (** ** Definitions *) Definition action_op G (X:hSet) : Type := ∏ (g:G) (x:X), X. Section A. Context (G:gr) (X:hSet). Definition ActionStructure : Type := ∑ (act_mult : action_op G X) (act_unit : ∏ x, act_mult (unel G) x = x), (* act_assoc : *) ∏ g h x, act_mult (op g h) x = act_mult g (act_mult h x). Definition make act_mult act_unit act_assoc : ActionStructure := act_mult,, act_unit,, act_assoc. Definition act_mult (x:ActionStructure) := pr1 x. Definition act_unit (x:ActionStructure) := pr12 x. Definition act_assoc (x:ActionStructure) := pr22 x. End A. Arguments act_mult {_ _} _ _ _. Lemma isaset_ActionStructure (G:gr) (X:hSet) : isaset (ActionStructure G X). Proof. intros. apply isaset_total2. { apply (impred 2); intro g. apply impred; intro x. apply setproperty. } intro op. apply isaset_total2. { apply (impred 2); intro x. apply hlevelntosn. apply setproperty. } intro un. apply (impred 2); intro g. apply (impred 2); intro h. apply (impred 2); intro x. apply hlevelntosn. apply setproperty. Qed. Definition Action (G:gr) := total2 (ActionStructure G). Definition makeAction {G:gr} (X:hSet) (ac:ActionStructure G X) := X,,ac : Action G. Definition ac_set {G:gr} (X:Action G) := pr1 X. Coercion ac_set : Action >-> hSet. Definition ac_type {G:gr} (X:Action G) := pr1hSet (ac_set X). Definition ac_str {G:gr} (X:Action G) := pr2 X : ActionStructure G (ac_set X). Definition ac_mult {G:gr} (X:Action G) := act_mult (pr2 X). Declare Scope action_scope. Delimit Scope action_scope with action. Local Notation "g * x" := (ac_mult _ g x) : action_scope. Local Open Scope action_scope. Definition ac_assoc {G:gr} (X:Action G) := act_assoc _ _ (pr2 X) : ∏ g h x, (op g h)*x = g*(h*x). Definition right_mult {G:gr} {X:Action G} (x:X) := λ g, g*x. Definition left_mult {G:gr} {X:Action G} (g:G) := λ x:X, g*x. Definition is_equivariant {G:gr} {X Y:Action G} (f:X->Y) : hProp := (∀ g x, f (g*x) = g*(f x))%logic. Definition is_equivariant_isaprop {G:gr} {X Y:Action G} (f:X->Y) : isaprop (is_equivariant f). Proof. apply propproperty. Qed. (** The following fact is fundamental: it shows that our definition of [is_equivariant] captures all of the structure. The proof reduces to showing that if G acts on a set X in two ways, and the identity function is equivariant, then the two actions are equal. A similar fact will hold in other cases: groups, rings, monoids, etc. Refer to section 9.8 of the HoTT book, on the "structure identity principle", a term coined by Peter Aczel. *) Local Open Scope transport. Definition is_equivariant_identity {G:gr} {X Y:Action G} (p:ac_set X = ac_set Y) : p # ac_str X = ac_str Y ≃ is_equivariant (cast (maponpaths pr1hSet p)). Proof. revert X Y p; intros [X [Xm [Xu Xa]]] [Y [Ym [Yu Ya]]] ? . (* should just apply hPropUnivalence at this point, as in Poset_univalence_prelim! *) simpl in p. destruct p; simpl. unfold transportf; simpl. simple refine (make_weq _ _). { intros p g x. simpl in x. simpl. exact (eqtohomot (eqtohomot (maponpaths act_mult p) g) x). } use isweq_iso. { unfold cast; simpl. intro i. assert (p:Xm=Ym). { apply funextsec; intro g. apply funextsec; intro x; simpl in x. exact (i g x). } destruct p. clear i. assert (p:Xu=Yu). { apply funextsec; intro x; simpl in x. apply setproperty. } destruct p. assert (p:Xa=Ya). { apply funextsec; intro g. apply funextsec; intro h. apply funextsec; intro x. apply setproperty. } destruct p. apply idpath. } { intro p. apply isaset_ActionStructure. } { intro is. apply proofirrelevance. apply impred; intros g. apply impred; intros x. apply setproperty. } Defined. Definition is_equivariant_comp {G:gr} {X Y Z:Action G} (p:X->Y) (i:is_equivariant p) (q:Y->Z) (j:is_equivariant q) : is_equivariant (funcomp p q). Proof. intros. intros g x. exact (maponpaths q (i g x) @ j g (p x)). Defined. Definition ActionMap {G:gr} (X Y:Action G) := total2 (@is_equivariant _ X Y). Definition underlyingFunction {G:gr} {X Y:Action G} (f:ActionMap X Y) := pr1 f. Coercion underlyingFunction : ActionMap >-> Funclass. Definition equivariance {G:gr} {X Y:Action G} (f:ActionMap X Y) : is_equivariant f := pr2 f. Definition composeActionMap {G:gr} (X Y Z:Action G) (p:ActionMap X Y) (q:ActionMap Y Z) : ActionMap X Z. Proof. revert p q; intros [p i] [q j]. exists (funcomp p q). apply is_equivariant_comp. assumption. assumption. Defined. Definition ActionIso {G:gr} (X Y:Action G) : Type. Proof. exact (∑ f:(ac_set X) ≃ (ac_set Y), is_equivariant f). Defined. Lemma ActionIso_isaset {G:gr} (X Y:Action G) : isaset (ActionIso X Y). Proof. apply (isofhlevelsninclb _ pr1). { apply isinclpr1; intro f. apply propproperty. } apply isofhlevelsnweqtohlevelsn. apply setproperty. Defined. Coercion underlyingIso {G:gr} {X Y:Action G} (e:ActionIso X Y) : X ≃ Y := pr1 e. Lemma underlyingIso_incl {G:gr} {X Y:Action G} : isincl (underlyingIso : ActionIso X Y -> X ≃ Y). Proof. intros. apply isinclpr1; intro f. apply propproperty. Defined. Local Goal ∏ G (X Y:Action G) (i : ActionIso X Y) (x:X), Y. intros. exact (i x). Qed. Lemma underlyingIso_injectivity {G:gr} {X Y:Action G} (e f:ActionIso X Y) : (e = f) ≃ (underlyingIso e = underlyingIso f). Proof. intros. apply weqonpathsincl. apply underlyingIso_incl. Defined. Definition underlyingActionMap {G:gr} {X Y:Action G} (e:ActionIso X Y) : ActionMap X Y := pr1weq (pr1 e),, pr2 e. Definition idActionIso {G:gr} (X:Action G) : ActionIso X X. Proof. intros. exists (idweq _). intros g x. reflexivity. Defined. Definition composeActionIso {G:gr} {X Y Z:Action G} (e:ActionIso X Y) (f:ActionIso Y Z) : ActionIso X Z. Proof. revert e f; intros [e i] [f j]. exists (weqcomp e f). destruct e as [e e'], f as [f f']; simpl. apply is_equivariant_comp. exact i. exact j. Defined. Lemma composeActionIsoId {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso (idActionIso X) f = f. Proof. apply subtypePath. { intros g. apply propproperty. } apply subtypePath. { intros g. apply isapropisweq. } reflexivity. Defined. Lemma composeActionIsoId' {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso f (idActionIso Y) = f. Proof. apply subtypePath. { intros g. apply propproperty. } apply subtypePath. { intros g. apply isapropisweq. } reflexivity. Defined. Definition path_to_ActionIso {G:gr} {X Y:Action G} (e:X = Y) : ActionIso X Y. Proof. intros. destruct e. exact (idActionIso X). Defined. Definition castAction {G:gr} {X Y:Action G} (e:X = Y) : X -> Y. Proof. intros x. exact (path_to_ActionIso e x). Defined. (** ** Applications of univalence *) Definition Action_univalence_prelim {G:gr} {X Y:Action G} : (X = Y) ≃ (ActionIso X Y). Proof. intros. simple refine (weqcomp (total2_paths_equiv (ActionStructure G) X Y) _). simple refine (weqbandf _ _ _ _). { apply hSet_univalence. } simpl. intro p. simple refine (weqcomp (is_equivariant_identity p) _). exact (eqweqmap (maponpaths (λ f, hProptoType (is_equivariant f)) (pr1_eqweqmap (maponpaths pr1hSet p)))). Defined. Definition Action_univalence_prelim_comp {G:gr} {X Y:Action G} (p:X = Y) : Action_univalence_prelim p = path_to_ActionIso p. Proof. intros. destruct p. apply (maponpaths (tpair _ _)). apply funextsec; intro g. apply funextsec; intro x. apply setproperty. Defined. Lemma path_to_ActionIsweq_iso {G:gr} {X Y:Action G} : isweq (@path_to_ActionIso G X Y). Proof. intros. exact (isweqhomot Action_univalence_prelim path_to_ActionIso Action_univalence_prelim_comp (pr2 Action_univalence_prelim)). Qed. Definition Action_univalence {G:gr} {X Y:Action G} : (X = Y) ≃ (ActionIso X Y). Proof. intros. exists path_to_ActionIso. apply path_to_ActionIsweq_iso. Defined. Definition Action_univalence_comp {G:gr} {X Y:Action G} (p:X = Y) : Action_univalence p = path_to_ActionIso p. Proof. reflexivity. Defined. Definition Action_univalence_inv {G:gr} {X Y:Action G} : (ActionIso X Y) ≃ (X=Y) := invweq Action_univalence. Definition Action_univalence_inv_comp {G:gr} {X Y:Action G} (f:ActionIso X Y) : path_to_ActionIso (Action_univalence_inv f) = f. Proof. intros. unfold Action_univalence_inv, Action_univalence. apply (homotweqinvweq Action_univalence f). Defined. Definition Action_univalence_inv_comp_eval {G:gr} {X Y:Action G} (f:ActionIso X Y) (x:X) : castAction (Action_univalence_inv f) x = f x. Proof. intros. exact (eqtohomot (maponpaths pr1weq (maponpaths underlyingIso (Action_univalence_inv_comp f))) x). Defined. (** ** Torsors *) Definition is_torsor {G:gr} (X:Action G) := nonempty X × ∏ x:X, isweq (right_mult x). Lemma is_torsor_isaprop {G:gr} (X:Action G) : isaprop (is_torsor X). Proof. intros. apply isapropdirprod. { apply propproperty. } { apply impred; intro x. apply isapropisweq. } Qed. Definition Torsor (G:gr) := total2 (@is_torsor G). Coercion underlyingAction {G} (X:Torsor G) := pr1 X : Action G. Definition is_torsor_prop {G} (X:Torsor G) := pr2 X. Definition torsor_nonempty {G} (X:Torsor G) := pr1 (is_torsor_prop X). Definition torsor_splitting {G} (X:Torsor G) := pr2 (is_torsor_prop X). Definition torsor_mult_weq {G} (X:Torsor G) (x:X) := make_weq (right_mult x) (torsor_splitting X x) : G ≃ X. Definition torsor_mult_weq' {G} (X:Torsor G) (g:G) : X ≃ X. Proof. exists (left_mult g). use isweq_iso. - exact (left_mult (grinv G g)). - intros x. unfold left_mult. intermediate_path ((grinv G g * g)%multmonoid * x). + apply pathsinv0,act_assoc. + intermediate_path (unel G * x). * apply (maponpaths (right_mult x)). apply grlinvax. * apply act_unit. - intros x. unfold left_mult. intermediate_path ((g * grinv G g)%multmonoid * x). + apply pathsinv0,act_assoc. + intermediate_path (unel G * x). * apply (maponpaths (right_mult x)). apply grrinvax. * apply act_unit. Defined. Definition left_mult_Iso {G:abgr} (X:Torsor G) (g:G) : ActionIso X X. Proof. exists (torsor_mult_weq' X g). intros h x. change (g * (h * x) = h * (g * x)). refine (! ac_assoc X g h x @ _ @ ac_assoc X h g x). exact (maponpaths (right_mult x) (commax G g h)). Defined. Definition torsor_update_nonempty {G} (X:Torsor G) (x:nonempty X) : Torsor G. Proof. exact (underlyingAction X,,(x,,pr2(is_torsor_prop X))). Defined. Definition castTorsor {G} {T T':Torsor G} (q:T = T') : T -> T'. Proof. exact (castAction (maponpaths underlyingAction q)). Defined. Lemma castTorsor_transportf {G} {T T':Torsor G} (q:T = T') (t:T) : transportf (λ S, underlyingAction S) q t = castTorsor q t. Proof. now induction q. Defined. Lemma underlyingAction_incl {G:gr} : isincl (underlyingAction : Torsor G -> Action G). Proof. intros. refine (isinclpr1 _ _); intro X. apply is_torsor_isaprop. Defined. Lemma underlyingAction_injectivity {G:gr} {X Y:Torsor G} : (X = Y) ≃ (underlyingAction X = underlyingAction Y). Proof. intros. apply weqonpathsincl. apply underlyingAction_incl. Defined. Definition underlyingAction_injectivity_comp {G:gr} {X Y:Torsor G} (p:X = Y) : underlyingAction_injectivity p = maponpaths underlyingAction p. Proof. reflexivity. Defined. Definition underlyingAction_injectivity_comp' {G:gr} {X Y:Torsor G} : pr1weq (@underlyingAction_injectivity G X Y) = @maponpaths (Torsor G) (Action G) (@underlyingAction G) X Y. Proof. reflexivity. Defined. Definition underlyingAction_injectivity_inv_comp {G:gr} {X Y:Torsor G} (f:underlyingAction X = underlyingAction Y) : maponpaths underlyingAction (invmap underlyingAction_injectivity f) = f. Proof. intros. apply (homotweqinvweq underlyingAction_injectivity f). Defined. Definition PointedTorsor (G:gr) := ∑ X:Torsor G, X. Definition underlyingTorsor {G} (X:PointedTorsor G) := pr1 X : Torsor G. Coercion underlyingTorsor : PointedTorsor >-> Torsor. Definition underlyingPoint {G} (X:PointedTorsor G) := pr2 X : X. Lemma is_quotient {G} (X:Torsor G) (y x:X) : ∃! g, g*x = y. Proof. intros. exact (pr2 (is_torsor_prop X) x y). Defined. Definition quotient {G} (X:Torsor G) (y x:X) := pr1 (iscontrpr1 (is_quotient X y x)) : G. Local Notation "y / x" := (quotient _ y x) : action_scope. Lemma quotient_times {G} {X:Torsor G} (y x:X) : (y/x)*x = y. Proof. intros. exact (pr2 (iscontrpr1 (is_quotient _ y x))). Defined. Lemma quotient_uniqueness {G} {X:Torsor G} (y x:X) (g:G) : g*x = y -> g = y/x. Proof. intros e. exact (maponpaths pr1 (uniqueness (is_quotient _ y x) (g,,e))). Defined. Lemma quotient_mult {G} (X:Torsor G) (g:G) (x:X) : (g*x)/x = g. Proof. intros. apply pathsinv0. apply quotient_uniqueness. reflexivity. Defined. Lemma quotient_1 {G} (X:Torsor G) (x:X) : x/x = 1%multmonoid. Proof. intros. apply pathsinv0. apply quotient_uniqueness. apply act_unit. Defined. Lemma quotient_product {G} (X:Torsor G) (z y x:X) : op (z/y) (y/x) = z/x. Proof. intros. apply quotient_uniqueness. exact (ac_assoc _ _ _ _ @ maponpaths (left_mult (z/y)) (quotient_times y x) @ quotient_times z y). Defined. Lemma quotient_map {G} {X Y:Torsor G} (f : ActionMap X Y) (x x':X) : f x' / f x = x' / x. Proof. refine (! (quotient_uniqueness (f x') (f x) (x' / x) _)). assert (p := equivariance f (x'/x) x). refine (!p @ _); clear p. apply maponpaths. apply quotient_times. Qed. Lemma torsorMapIsIso {G} {X Y : Torsor G} (f : ActionMap X Y) : isweq f. Proof. apply (squash_to_prop (torsor_nonempty X)). - apply isapropisweq. - intros x. set (y := f x). set (f' := λ y', y' / y * x). apply (isweq_iso f f'). + intros x'. unfold f', y. assert (p := quotient_times x' x). refine (_ @ p); clear p. apply (maponpaths (λ g, g * x)). apply quotient_map. + intros y'. unfold f'. assert (p := equivariance f (y'/y) x). refine (p @ _); clear p. fold y. apply quotient_times. Defined. Definition torsorMap_to_torsorIso {G} {X Y : Torsor G} (f : ActionMap X Y) : ActionIso X Y. Proof. use tpair. - exists f. apply torsorMapIsIso. - simpl. apply equivariance. Defined. Definition trivialTorsor (G:gr) : Torsor G. Proof. intros. exists (makeAction G (make G G op (lunax G) (assocax G))). exact (hinhpr (unel G),, λ x, isweq_iso (λ g, op g x) (λ g, op g (grinv _ x)) (λ g, assocax _ g x (grinv _ x) @ maponpaths (op g) (grrinvax G x) @ runax _ g) (λ g, assocax _ g (grinv _ x) x @ maponpaths (op g) (grlinvax G x) @ runax _ g)). Defined. Definition toTrivialTorsor {G:gr} (g:G) : trivialTorsor G. Proof. exact g. Defined. Definition pointedTrivialTorsor (G:gr) : PointedTorsor G. Proof. intros. exists (trivialTorsor G). exact (unel G). Defined. Definition univ_function {G:gr} (X:Torsor G) (x:X) : trivialTorsor G -> X. Proof. apply right_mult. assumption. Defined. Definition univ_function_pointed {G:gr} (X:Torsor G) (x:X) : univ_function X x (unel _) = x. Proof. intros. apply act_unit. Defined. Definition univ_function_is_equivariant {G:gr} (X:Torsor G) (x:X) : is_equivariant (univ_function X x). Proof. intros. intros g h. apply act_assoc. Defined. Definition triviality_isomorphism {G:gr} (X:Torsor G) (x:X) : ActionIso (trivialTorsor G) X. Proof. intros. exact (torsor_mult_weq X x,, univ_function_is_equivariant X x). Defined. Lemma triviality_isomorphism_compute (G:gr) : triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G). Proof. apply subtypePath_prop. apply subtypePath. { intros X. apply isapropisweq. } apply funextsec; intros g. change (op g (unel _) = g). apply runax. Defined. Definition trivialTorsor_weq (G:gr) (g:G) : (trivialTorsor G) ≃ (trivialTorsor G). Proof. intros. exists (λ h, op h g). apply (isweq_iso _ (λ h, op h (grinv G g))). { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grrinvax _ _) @ runax _ _). } { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grlinvax _ _) @ runax _ _). } Defined. Definition trivialTorsorAuto (G:gr) (g:G) : ActionIso (trivialTorsor G) (trivialTorsor G). Proof. intros. exists (trivialTorsor_weq G g). intros h x. simpl. exact (assocax _ h x g). Defined. Lemma pr1weq_injectivity {X Y} (f g:X ≃ Y) : (f = g) ≃ (pr1weq f = pr1weq g). Proof. intros. apply weqonpathsincl. apply isinclpr1weq. Defined. Definition trivialTorsorRightMultiplication (G:gr) : G ≃ ActionIso (trivialTorsor G) (trivialTorsor G). Proof. exists (trivialTorsorAuto G). simple refine (isweq_iso _ _ _ _). { intro f. exact (f (unel G)). } { intro g; simpl. exact (lunax _ g). } { intro f; simpl. apply (invweq (underlyingIso_injectivity _ _)); simpl. apply (invweq (pr1weq_injectivity _ _)). apply funextsec; intro g. simpl. exact ((! (pr2 f) g (unel G)) @ (maponpaths (pr1 f) (runax G g))). } Defined. Definition autos_comp (G:gr) (g:G) : underlyingIso (trivialTorsorRightMultiplication G g) = trivialTorsor_weq G g. Proof. reflexivity. (* don't change the proof *) Defined. Definition autos_comp_apply (G:gr) (g h:G) : (trivialTorsorRightMultiplication _ g) h = (h * g)%multmonoid. Proof. reflexivity. (* don't change the proof *) Defined. Lemma trivialTorsorAuto_unit (G:gr) : trivialTorsorAuto G (unel _) = idActionIso _. Proof. intros. simple refine (subtypePath _ _). { intro k. apply is_equivariant_isaprop. } { simple refine (subtypePath _ _). { intro; apply isapropisweq. } { apply funextsec; intro x; simpl. exact (runax G x). } } Defined. Lemma trivialTorsorAuto_mult (G:gr) (g h:G) : composeActionIso (trivialTorsorAuto G g) (trivialTorsorAuto G h) = (trivialTorsorAuto G (op g h)). Proof. intros. simple refine (subtypePath _ _). { intro; apply is_equivariant_isaprop. } { simple refine (subtypePath _ _). { intro; apply isapropisweq. } { apply funextsec; intro x; simpl. exact (assocax _ x g h). } } Defined. (** ** Applications of univalence *) Definition torsor_univalence {G:gr} {X Y:Torsor G} : (X = Y) ≃ (ActionIso X Y). Proof. intros. simple refine (weqcomp underlyingAction_injectivity _). apply Action_univalence. Defined. Definition torsor_univalence_transport {G:gr} {X Y:Torsor G} (p:X=Y) (x:X) : torsor_univalence p x = transportf (λ X:Torsor G, X:Type) p x. (* compare with castTorsor_transportf above *) Proof. now induction p. Defined. Corollary torsor_hlevel {G:gr} : isofhlevel 3 (Torsor G). Proof. intros X Y. apply (isofhlevelweqb 2 torsor_univalence). apply ActionIso_isaset. Defined. Definition torsor_univalence_comp {G:gr} {X Y:Torsor G} (p:X = Y) : torsor_univalence p = path_to_ActionIso (maponpaths underlyingAction p). Proof. reflexivity. Defined. Definition torsor_univalence_inv_comp_eval {G:gr} {X Y:Torsor G} (f:ActionIso X Y) (x:X) : castTorsor (invmap torsor_univalence f) x = f x. Proof. intros. unfold torsor_univalence. unfold castTorsor. rewrite invmapweqcomp. (* too slow *) unfold weqcomp; simpl. rewrite underlyingAction_injectivity_inv_comp. apply Action_univalence_inv_comp_eval. Defined. Definition torsor_eqweq_to_path {G:gr} {X Y:Torsor G} : ActionIso X Y -> X = Y. Proof. intros f. exact (invweq torsor_univalence f). Defined. Definition torsorMap_to_path {G:gr} {X Y:Torsor G} : ActionMap X Y -> X = Y. Proof. intros f. apply (invweq torsor_univalence). apply torsorMap_to_torsorIso. exact f. Defined. Theorem TorsorIso_rect {G:gr} {X Y : Torsor G} (P : ActionIso X Y -> UU) : (∏ e : X = Y, P (torsor_univalence e)) -> ∏ f, P f. Proof. intros ih ?. set (p := ih (invmap torsor_univalence f)). set (h := homotweqinvweq torsor_univalence f). exact (transportf P h p). Defined. Ltac torsor_induction f e := generalize f; apply TorsorIso_rect; intro e; clear f. Theorem TorsorIso_rect' {G:gr} {X : Torsor G} (P : ∏ Y : Torsor G, ActionIso X Y -> Type) : P X (idActionIso X) -> ∏ (Y : Torsor G) (f:ActionIso X Y), P Y f. Proof. intros p ? ?. torsor_induction f q. induction q. exact p. Defined. Ltac torsor_induction' f X := generalize f; generalize X; apply TorsorIso_rect'; clear f X. Lemma torsor_univalence_id {G:gr} (X:Torsor G) : invmap torsor_univalence (idActionIso X) = idpath X. (* upstream *) Proof. change (idActionIso X) with (torsor_univalence (idpath X)). apply homotinvweqweq. Defined. Definition invUnivalenceCompose {G:gr} {X Y Z : Torsor G} (f : ActionIso X Y) (g : ActionIso Y Z) : invmap torsor_univalence f @ invmap torsor_univalence g = invmap torsor_univalence (composeActionIso f g). Proof. torsor_induction' g Z. rewrite composeActionIsoId'. rewrite torsor_univalence_id. apply pathscomp0rid. Defined. Definition PointedActionIso {G:gr} (X Y:PointedTorsor G) := ∑ f:ActionIso X Y, f (underlyingPoint X) = underlyingPoint Y. Definition pointed_triviality_isomorphism {G:gr} (X:PointedTorsor G) : PointedActionIso (pointedTrivialTorsor G) X. Proof. revert X; intros [X x]. exists (triviality_isomorphism X x). simpl. apply univ_function_pointed. Defined. Definition Pointedtorsor_univalence {G:gr} {X Y:PointedTorsor G} : (X = Y) ≃ (PointedActionIso X Y). Proof. intros. simple refine (weqcomp (total2_paths_equiv _ X Y) _). simple refine (weqbandf _ _ _ _). { intros. exact (weqcomp (weqonpathsincl underlyingAction underlyingAction_incl X Y) Action_univalence). } destruct X as [X x], Y as [Y y]; simpl. intro p. destruct p; simpl. exact (idweq _). Defined. Definition ClassifyingSpace G := pointedType (Torsor G) (trivialTorsor G). Definition E := PointedTorsor. Definition B := ClassifyingSpace. Definition π {G:gr} := underlyingTorsor : E G -> B G. Lemma isBaseConnected_BG (G:gr) : isBaseConnected (B G). Proof. intros X. use (hinhfun _ (torsor_nonempty X)); intros x. exact (torsor_eqweq_to_path (triviality_isomorphism X x)). Defined. Goal ∏ (G:gr), triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G). Fail reflexivity. Abort. Goal ∏ (G:gr), isBaseConnected_BG G (trivialTorsor G) = hinhpr (idpath (trivialTorsor G)). intros. unfold isBaseConnected_BG, pr2. change (pr1 (trivialTorsor G) : Type) with (G : Type). change (torsor_nonempty (trivialTorsor G)) with (hinhpr (unel G)). change (hinhpr (torsor_eqweq_to_path (triviality_isomorphism (trivialTorsor G) (unel G))) = hinhpr (idpath (trivialTorsor G))). apply maponpaths. Fail reflexivity. Abort. Lemma isConnected_BG (G:gr) : isConnected (B G). Proof. apply baseConnectedness. apply isBaseConnected_BG. Defined. Lemma iscontr_EG (G:gr) : iscontr (E G). Proof. intros. exists (pointedTrivialTorsor G). intros [X x]. apply pathsinv0. apply (invweq Pointedtorsor_univalence). apply pointed_triviality_isomorphism. Defined. Theorem loopsBG (G:gr) : G ≃ Ω (B G). Proof. intros. simple refine (weqcomp _ (invweq torsor_univalence)). apply trivialTorsorRightMultiplication. Defined. Definition loopsBG_comp (G:gr) (g:G) : loopsBG G g = invmap torsor_univalence (trivialTorsorAuto G g). Proof. reflexivity. Defined. Definition loopsBG_comp' {G:gr} (p : Ω (B G)) : invmap (loopsBG G) p = path_to_ActionIso (maponpaths underlyingAction p) (unel G). Proof. reflexivity. Defined. Definition loopsBG_comp_2 (G:gr) (g h:G) : castTorsor (loopsBG G g) h = (h*g)%multmonoid. Proof. exact (torsor_univalence_inv_comp_eval (trivialTorsorAuto G g) h). Defined. (** Theorem [loopsBG] also follows from the Rezk Completion theorem of the CategoryTheory package. To see that, regard G as a category with one object. Consider a merely representable functor F : G^op -> Set. Let X be F of the object *. Apply F to the arrows to get an action of G on X. Try to prove that X is a torsor. Since being a torsor is a mere property, we may assume F is actually representable. There is only one object *, so F is isomorphic to h_*. Apply h_* to * and we get Hom(*,*), which is G, regarded as a G-set. That's a torsor. So the Rezk completion RCG is equivalent to BG, the type of G-torsors. Now the theorem also says there is an equivalence G -> RCG. So RCG is connected and its loop space is G. A formalization of that argument should be added eventually. *) (* Local Variables: compile-command: "make -C ../.. UniMath/CategoryTheory/RepresentableFunctors/GroupAction.vo" End: *) UniMath-20231010/UniMath/Algebra/Groups.v000066400000000000000000001522331451125700300176650ustar00rootroot00000000000000(** * Algebra I. Part C. Groups, abelian groups. Vladimir Voevodsky. Aug. 2011 - . *) (** ** Contents - Groups - Basic definitions - Univalence for groups - Computation lemmas for groups - Relations on groups - Subobjects - Quotient objects - Cosets - Normal Subgroups - Direct products - Group of invertible elements in a monoid - Abelian groups - Basic definitions - Univalence for abelian groups - Subobjects - Kernels - Quotient objects - Direct products - Abelian group of fractions of an abelian unitary monoid - Abelian group of fractions and abelian monoid of fractions - Canonical homomorphism to the abelian group of fractions - Abelian group of fractions in the case when all elements are cancelable - Relations on the abelian group of fractions - Relations and the canonical homomorphism to [abgrdiff] *) Require Import UniMath.MoreFoundations.Orders. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Subtypes. Require Export UniMath.Algebra.BinaryOperations. Require Export UniMath.Algebra.Monoids. Local Open Scope logic. (** ** Groups *) (** *** Basic definitions *) Definition gr : UU := total2 (λ X : setwithbinop, isgrop (@op X)). Definition make_gr : ∏ (t : setwithbinop), (λ X : setwithbinop, isgrop op) t → ∑ X : setwithbinop, isgrop op := tpair (λ X : setwithbinop, isgrop (@op X)). Definition grtomonoid : gr -> monoid := λ X : _, make_monoid (pr1 X) (pr1 (pr2 X)). Coercion grtomonoid : gr >-> monoid. Definition grinv (X : gr) : X -> X := pr1 (pr2 (pr2 X)). Definition grlinvax (X : gr) : islinv (@op X) (unel X) (grinv X) := pr1 (pr2 (pr2 (pr2 X))). Definition grrinvax (X : gr) : isrinv (@op X) (unel X) (grinv X) := pr2 (pr2 (pr2 (pr2 X))). Definition gr_of_monoid (X : monoid) (H : invstruct (@op X) (pr2 X)) : gr := make_gr X (make_isgrop (pr2 X) H). Lemma monoidfuninvtoinv {X Y : gr} (f : monoidfun X Y) (x : X) : f (grinv X x) = grinv Y (f x). Proof. intros. apply (invmaponpathsweq (make_weq _ (isweqrmultingr_is (pr2 Y) (f x)))). simpl. change (paths (op (pr1 f (grinv X x)) (pr1 f x)) (op (grinv Y (pr1 f x)) (pr1 f x))). rewrite (grlinvax Y (pr1 f x)). destruct (pr1 (pr2 f) (grinv X x) x). rewrite (grlinvax X x). apply (pr2 (pr2 f)). Defined. Lemma grinv_path_from_op_path {X : gr} {x y : X} (p : (x * y)%multmonoid = unel X) : grinv X x = y. Proof. now rewrite <- (lunax X y), <- (grlinvax X x), assocax, p, runax. Defined. (** *** Construction of the trivial abmonoid consisting of one element given by unit. *) Definition unitgr_isgrop : isgrop (@op unitmonoid). Proof. use make_isgrop. - exact unitmonoid_ismonoid. - use make_invstruct. + intros i. exact i. + use make_isinv. * intros x. use isProofIrrelevantUnit. * intros x. use isProofIrrelevantUnit. Qed. Definition unitgr : gr := make_gr unitmonoid unitgr_isgrop. Lemma grfuntounit_ismonoidfun (X : gr) : ismonoidfun (λ x : X, (unel unitgr)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit. - use isProofIrrelevantUnit. Qed. Definition grfuntounit (X : gr) : monoidfun X unitgr := monoidfunconstr (grfuntounit_ismonoidfun X). Lemma grfunfromunit_ismonoidfun (X : gr) : ismonoidfun (λ x : unitgr, (unel X)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X). - use idpath. Qed. Definition grfunfromunit (X : gr) : monoidfun unitmonoid X := monoidfunconstr (monoidfunfromunit_ismonoidfun X). Lemma unelgrfun_ismonoidfun (X Y : gr) : ismonoidfun (λ x : X, (unel Y)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use lunax. - use idpath. Qed. Definition unelgrfun (X Y : gr) : monoidfun X Y := monoidfunconstr (unelgrfun_ismonoidfun X Y). (** *** (X = Y) ≃ (monoidiso X Y) The idea is to use the composition (X = Y) ≃ (make_gr' X = make_gr' Y) ≃ ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y))) ≃ (monoidiso X Y). The reason why we use gr' is that then we can use univalence for monoids. See [gr_univalence_weq3]. *) Local Definition gr' : UU := ∑ g : (∑ X : setwithbinop, ismonoidop (@op X)), invstruct (@op (pr1 g)) (pr2 g). Local Definition make_gr' (X : gr) : gr' := tpair _ (tpair _ (pr1 X) (pr1 (pr2 X))) (pr2 (pr2 X)). Local Definition gr'_to_monoid (X : gr') : monoid := pr1 X. Definition gr_univalence_weq1 : gr ≃ gr' := weqtotal2asstol (λ Z : setwithbinop, ismonoidop (@op Z)) (fun y : (∑ (x : setwithbinop), ismonoidop (@op x)) => invstruct (@op (pr1 y)) (pr2 y)). Definition gr_univalence_weq1' (X Y : gr) : (X = Y) ≃ (make_gr' X = make_gr' Y) := make_weq _ (@isweqmaponpaths gr gr' gr_univalence_weq1 X Y). Definition gr_univalence_weq2 (X Y : gr) : ((make_gr' X) = (make_gr' Y)) ≃ ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y))). Proof. use subtypeInjectivity. intros w. use isapropinvstruct. Defined. Opaque gr_univalence_weq2. Definition gr_univalence_weq3 (X Y : gr) : ((gr'_to_monoid (make_gr' X)) = (gr'_to_monoid (make_gr' Y))) ≃ (monoidiso X Y) := monoid_univalence (gr'_to_monoid (make_gr' X)) (gr'_to_monoid (make_gr' Y)). Definition gr_univalence_map (X Y : gr) : (X = Y) -> (monoidiso X Y). Proof. intro e. induction e. exact (idmonoidiso X). Defined. Lemma gr_univalence_isweq (X Y : gr) : isweq (gr_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (gr_univalence_weq1' X Y) (weqcomp (gr_univalence_weq2 X Y) (gr_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque gr_univalence_isweq. Definition gr_univalence (X Y : gr) : (X = Y) ≃ (monoidiso X Y). Proof. use make_weq. - exact (gr_univalence_map X Y). - exact (gr_univalence_isweq X Y). Defined. Opaque gr_univalence. (** *** Computation lemmas for groups *) Definition weqlmultingr (X : gr) (x0 : X) : pr1 X ≃ pr1 X := make_weq _ (isweqlmultingr_is (pr2 X) x0). Definition weqrmultingr (X : gr) (x0 : X) : pr1 X ≃ pr1 X := make_weq _ (isweqrmultingr_is (pr2 X) x0). Lemma grlcan (X : gr) {a b : X} (c : X) (e : paths (op c a) (op c b)) : a = b. Proof. apply (invmaponpathsweq (weqlmultingr X c) _ _ e). Defined. Lemma grrcan (X : gr) {a b : X} (c : X) (e : paths (op a c) (op b c)) : a = b. Proof. apply (invmaponpathsweq (weqrmultingr X c) _ _ e). Defined. Lemma grinvunel (X : gr) : paths (grinv X (unel X)) (unel X). Proof. apply (grrcan X (unel X)). rewrite (grlinvax X). rewrite (runax X). apply idpath. Defined. Lemma grinvinv (X : gr) (a : X) : paths (grinv X (grinv X a)) a. Proof. apply (grlcan X (grinv X a)). rewrite (grlinvax X a). rewrite (grrinvax X _). apply idpath. Defined. Lemma grinvmaponpathsinv (X : gr) {a b : X} (e : paths (grinv X a) (grinv X b)) : a = b. Proof. assert (e' := maponpaths (λ x, grinv X x) e). simpl in e'. rewrite (grinvinv X _) in e'. rewrite (grinvinv X _) in e'. apply e'. Defined. Lemma grinvandmonoidfun (X Y : gr) {f : X -> Y} (is : ismonoidfun f) (x : X) : paths (f (grinv X x)) (grinv Y (f x)). Proof. apply (grrcan Y (f x)). rewrite (pathsinv0 (pr1 is _ _)). rewrite (grlinvax X). rewrite (grlinvax Y). apply (pr2 is). Defined. Lemma grinvop (Y : gr) : ∏ y1 y2 : Y, grinv Y (@op Y y1 y2) = @op Y (grinv Y y2) (grinv Y y1). Proof. intros y1 y2. apply (grrcan Y y1). rewrite (assocax Y). rewrite (grlinvax Y). rewrite (runax Y). apply (grrcan Y y2). rewrite (grlinvax Y). rewrite (assocax Y). rewrite (grlinvax Y). apply idpath. Qed. (** *** Relations on groups *) Lemma isinvbinophrelgr (X : gr) {R : hrel X} (is : isbinophrel R) : isinvbinophrel R. Proof. set (is1 := pr1 is). set (is2 := pr2 is). split. - intros a b c r. set (r' := is1 _ _ (grinv X c) r). clearbody r'. rewrite (pathsinv0 (assocax X _ _ a)) in r'. rewrite (pathsinv0 (assocax X _ _ b)) in r'. rewrite (grlinvax X c) in r'. rewrite (lunax X a) in r'. rewrite (lunax X b) in r'. apply r'. - intros a b c r. set (r' := is2 _ _ (grinv X c) r). clearbody r'. rewrite ((assocax X a _ _)) in r'. rewrite ((assocax X b _ _)) in r'. rewrite (grrinvax X c) in r'. rewrite (runax X a) in r'. rewrite (runax X b) in r'. apply r'. Defined. Opaque isinvbinophrelgr. Lemma isbinophrelgr (X : gr) {R : hrel X} (is : isinvbinophrel R) : isbinophrel R. Proof. set (is1 := pr1 is). set (is2 := pr2 is). split. - intros a b c r. rewrite (pathsinv0 (lunax X a)) in r. rewrite (pathsinv0 (lunax X b)) in r. rewrite (pathsinv0 (grlinvax X c)) in r. rewrite (assocax X _ _ a) in r. rewrite (assocax X _ _ b) in r. apply (is1 _ _ (grinv X c) r). - intros a b c r. rewrite (pathsinv0 (runax X a)) in r. rewrite (pathsinv0 (runax X b)) in r. rewrite (pathsinv0 (grrinvax X c)) in r. rewrite (pathsinv0 (assocax X a _ _)) in r. rewrite (pathsinv0 (assocax X b _ _)) in r. apply (is2 _ _ (grinv X c) r). Defined. Opaque isbinophrelgr. Lemma grfromgtunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R x (unel X)) : R (unel X) (grinv X x). Proof. intros. set (r := (pr2 is) _ _ (grinv X x) isg). rewrite (grrinvax X x) in r. rewrite (lunax X _) in r. apply r. Defined. Lemma grtogtunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (unel X) (grinv X x)) : R x (unel X). Proof. assert (r := (pr2 is) _ _ x isg). rewrite (grlinvax X x) in r. rewrite (lunax X _) in r. apply r. Defined. Lemma grfromltunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (unel X) x) : R (grinv X x) (unel X). Proof. assert (r := (pr1 is) _ _ (grinv X x) isg). rewrite (grlinvax X x) in r. rewrite (runax X _) in r. apply r. Defined. Lemma grtoltunel (X : gr) {R : hrel X} (is : isbinophrel R) {x : X} (isg : R (grinv X x) (unel X)) : R (unel X) x. Proof. assert (r := (pr1 is) _ _ x isg). rewrite (grrinvax X x) in r. rewrite (runax X _) in r. apply r. Defined. (** *** Subobjects *) Definition issubgr {X : gr} (A : hsubtype X) : UU := dirprod (issubmonoid A) (∏ x : X, A x -> A (grinv X x)). Definition make_issubgr {X : gr} {A : hsubtype X} (H1 : issubmonoid A) (H2 : ∏ x : X, A x -> A (grinv X x)) : issubgr A := make_dirprod H1 H2. Lemma isapropissubgr {X : gr} (A : hsubtype X) : isaprop (issubgr A). Proof. apply (isofhleveldirprod 1). - apply isapropissubmonoid. - apply impred. intro x. apply impred. intro a. apply (pr2 (A (grinv X x))). Defined. Definition subgr (X : gr) : UU := total2 (λ A : hsubtype X, issubgr A). Definition make_subgr {X : gr} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubgr A) t → ∑ A : hsubtype X, issubgr A := tpair (λ A : hsubtype X, issubgr A). Definition subgrconstr {X : gr} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubgr A) t → ∑ A : hsubtype X, issubgr A := @make_subgr X. Definition subgrtosubmonoid (X : gr) : subgr X -> submonoid X := λ A : _, make_submonoid (pr1 A) (pr1 (pr2 A)). Coercion subgrtosubmonoid : subgr >-> submonoid. Definition totalsubgr (X : gr) : subgr X. Proof. split with (@totalsubtype X). split. - exact (pr2 (totalsubmonoid X)). - exact (fun _ _ => tt). Defined. Definition trivialsubgr (X : gr) : subgr X. Proof. exists (λ x, x = @unel X)%logic. split. - exact (pr2 (@trivialsubmonoid X)). - intro. intro eq_1. induction (!eq_1). apply grinvunel. Defined. Lemma isinvoncarrier {X : gr} (A : subgr X) : isinv (@op A) (unel A) (λ a : A, make_carrier _ (grinv X (pr1 a)) (pr2 (pr2 A) (pr1 a) (pr2 a))). Proof. split. - intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (grlinvax X (pr1 a)). - intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (grrinvax X (pr1 a)). Defined. Definition isgrcarrier {X : gr} (A : subgr X) : isgrop (@op A) := tpair _ (ismonoidcarrier A) (tpair _ (λ a : A, make_carrier _ (grinv X (pr1 a)) (pr2 (pr2 A) (pr1 a) (pr2 a))) (isinvoncarrier A)). Definition carrierofasubgr {X : gr} (A : subgr X) : gr. Proof. split with A. apply (isgrcarrier A). Defined. Coercion carrierofasubgr : subgr >-> gr. Lemma intersection_subgr : forall {X : gr} {I : UU} (S : I -> hsubtype X) (each_is_subgr : ∏ i : I, issubgr (S i)), issubgr (subtype_intersection S). Proof. intros. use make_issubgr. - exact (intersection_submonoid S (λ i, (pr1 (each_is_subgr i)))). - exact (λ x x_in_S i, pr2 (each_is_subgr i) x (x_in_S i)). Qed. Definition subgr_incl {X : gr} (A : subgr X) : monoidfun A X := submonoid_incl A. (** *** Quotient objects *) Lemma grquotinvcomp {X : gr} (R : binopeqrel X) : iscomprelrelfun R R (grinv X). Proof. destruct R as [ R isb ]. set (isc := iscompbinoptransrel _ (eqreltrans _) isb). unfold iscomprelrelfun. intros x x' r. destruct R as [ R iseq ]. destruct iseq as [ ispo0 symm0 ]. destruct ispo0 as [ trans0 refl0 ]. unfold isbinophrel in isb. set (r0 := isc _ _ _ _ (isc _ _ _ _ (refl0 (grinv X x')) r) (refl0 (grinv X x))). rewrite (grlinvax X x') in r0. rewrite (assocax X (grinv X x') x (grinv X x)) in r0. rewrite (grrinvax X x) in r0. rewrite (lunax X _) in r0. rewrite (runax X _) in r0. apply (symm0 _ _ r0). Defined. Opaque grquotinvcomp. Definition invongrquot {X : gr} (R : binopeqrel X) : setquot R -> setquot R := setquotfun R R (grinv X) (grquotinvcomp R). Lemma isinvongrquot {X : gr} (R : binopeqrel X) : isinv (@op (setwithbinopquot R)) (setquotpr R (unel X)) (invongrquot R). Proof. split. - unfold islinv. apply (setquotunivprop R (λ x, _ = _)). intro x. apply (@maponpaths _ _ (setquotpr R) (@op X (grinv X x) x) (unel X)). apply (grlinvax X). - unfold isrinv. apply (setquotunivprop R (λ x, _ = _)). intro x. apply (@maponpaths _ _ (setquotpr R) (@op X x (grinv X x)) (unel X)). apply (grrinvax X). Defined. Opaque isinvongrquot. Definition isgrquot {X : gr} (R : binopeqrel X) : isgrop (@op (setwithbinopquot R)) := tpair _ (ismonoidquot R) (tpair _ (invongrquot R) (isinvongrquot R)). Definition grquot {X : gr} (R : binopeqrel X) : gr. Proof. split with (setwithbinopquot R). apply isgrquot. Defined. (** *** Cosets *) Section GrCosets. Context {X : gr}. Local Open Scope multmonoid. Local Lemma isaprop_mult_eq_r (x y : X) : isaprop (∑ z : X, x * z = y). Proof. apply invproofirrelevance; intros z1 z2. apply subtypePath. { intros x'. apply setproperty. } refine (!lunax _ _ @ _ @ lunax _ _). refine (maponpaths (λ z, z * _) (!grlinvax X x) @ _ @ maponpaths (λ z, z * _) (grlinvax X x)). refine (assocax _ _ _ _ @ _ @ !assocax _ _ _ _). refine (maponpaths _ (pr2 z1) @ _ @ !maponpaths _ (pr2 z2)). reflexivity. Defined. Local Lemma isaprop_mult_eq_l (x y : X) : isaprop (∑ z : X, z * x = y). Proof. apply invproofirrelevance; intros z1 z2. apply subtypePath. { intros x'. apply setproperty. } refine (!runax _ _ @ _ @ runax _ _). refine (maponpaths (λ z, _ * z) (!grrinvax X x) @ _ @ maponpaths (λ z, _ * z) (grrinvax X x)). refine (!assocax _ _ _ _ @ _ @ assocax _ _ _ _). refine (maponpaths (λ z, z * _) (pr2 z1) @ _ @ !maponpaths (λ z, z * _) (pr2 z2)). reflexivity. Defined. Context (Y : subgr X). Lemma isaprop_in_same_left_coset (x1 x2 : X) : isaprop (in_same_left_coset Y x1 x2). Proof. unfold in_same_left_coset. apply invproofirrelevance; intros p q. apply subtypePath. { intros x'. apply setproperty. } apply subtypePath. { intros x'. apply propproperty. } pose (p' := (pr11 p,, pr2 p) : ∑ y : X, x1 * y = x2). pose (q' := (pr11 q,, pr2 q) : ∑ y : X, x1 * y = x2). apply (maponpaths pr1 (iscontrpr1 (isaprop_mult_eq_r _ _ p' q'))). Defined. Lemma isaprop_in_same_right_coset (x1 x2 : X) : isaprop (in_same_right_coset Y x1 x2). Proof. apply invproofirrelevance. intros p q. apply subtypePath; [intros x; apply setproperty|]. apply subtypePath; [intros x; apply propproperty|]. pose (p' := (pr11 p,, pr2 p) : ∑ y : X, y * x1 = x2). pose (q' := (pr11 q,, pr2 q) : ∑ y : X, y * x1 = x2). apply (maponpaths pr1 (iscontrpr1 (isaprop_mult_eq_l _ _ p' q'))). Defined. (** The property of being in the same coset defines an equivalence relation. *) Definition in_same_left_coset_prop : X -> X -> hProp. Proof. intros x1 x2. use make_hProp. + exact (in_same_left_coset Y x1 x2). + apply isaprop_in_same_left_coset. Defined. Definition in_same_right_coset_prop : X -> X -> hProp. Proof. intros x1 x2. use make_hProp. + exact (in_same_right_coset Y x1 x2). + apply isaprop_in_same_right_coset. Defined. Definition in_same_left_coset_eqrel : eqrel X. use make_eqrel. - exact in_same_left_coset_prop. - use iseqrelconstr. + (** Transitivity *) intros ? ? ?; cbn; intros inxy inyz. unfold in_same_left_coset in *. use tpair. * exists (pr11 inxy * pr11 inyz). apply (pr2 Y). * cbn. refine (_ @ pr2 inyz). refine (_ @ maponpaths (λ z, z * _) (pr2 inxy)). apply pathsinv0, assocax. + (** Reflexivity *) intro; cbn. use tpair. * exists 1; apply (pr2 Y). * apply runax. + (** Symmetry *) intros x y inxy. use tpair. * exists (grinv X (pr1 (pr1 inxy))). apply (pr2 Y). exact (pr2 (pr1 inxy)). * cbn in *. refine (!maponpaths (λ z, z * _) (pr2 inxy) @ _). refine (assocax _ _ _ _ @ _). refine (maponpaths _ (grrinvax _ _) @ _). apply runax. Defined. (** x₁ and x₂ are in the same Y-coset if and only if x₁⁻¹ * x₂ is in Y. (Proposition 4 in Dummit and Foote) *) Definition in_same_coset_test (x1 x2 : X) : (Y ((grinv _ x1) * x2)) ≃ in_same_left_coset Y x1 x2. Proof. apply weqimplimpl; unfold in_same_left_coset in *. - intros yx1x2. exists ((grinv _ x1) * x2,, yx1x2); cbn. refine (!assocax X _ _ _ @ _). refine (maponpaths (λ z, z * _) (grrinvax X _) @ _). apply lunax. - intros y. use (transportf (pr1 Y)). + exact (pr11 y). + refine (_ @ maponpaths _ (pr2 y)). refine (_ @ assocax _ _ _ _). refine (_ @ !maponpaths (λ z, z * _) (grlinvax X _)). apply pathsinv0, lunax. + exact (pr2 (pr1 y)). - apply propproperty. - apply isaprop_in_same_left_coset. Defined. End GrCosets. (** *** Normal Subgroups *) Section NormalSubGroups. Local Open Scope multmonoid. Definition isnormalsubgr {X : gr} (N : subgr X) : hProp := ∀ g : X, ∀ n1 : N, N ((g * (pr1 n1)) * (grinv X g)). Definition normalsubgr (X : gr) : UU := ∑ N : subgr X, isnormalsubgr N. Definition normalsubgrtosubgr (X : gr) : normalsubgr X -> subgr X := pr1. Coercion normalsubgrtosubgr : normalsubgr >-> subgr. Definition normalsubgrprop {X : gr} (N : normalsubgr X) : isnormalsubgr N := pr2 N. Definition lcoset_in_rcoset {X : gr} (N : subgr X) : UU := ∏ g : X, ∏ n1 : N, ∑ n2 : N, g * (pr1 n1) = (pr1 n2) * g. Definition lcoset_in_rcoset_witness {X : gr} {N : subgr X} : lcoset_in_rcoset N -> (X -> N -> N) := fun H g n1 => pr1 (H g n1). Definition lcoset_in_rcoset_property {X : gr} {N : subgr X} (H : lcoset_in_rcoset N) (g : X) (n1 : N) : N (pr1 (lcoset_in_rcoset_witness H g n1)) := pr2 (lcoset_in_rcoset_witness H g n1). Definition lcoset_in_rcoset_equation {X : gr} {N : subgr X} (H : lcoset_in_rcoset N) (g : X) (n1 : N) : g * (pr1 n1) = (pr1 (lcoset_in_rcoset_witness H g n1)) * g := pr2 (H g n1). Definition rcoset_in_lcoset {X : gr} (N : subgr X) : UU := ∏ g : X, ∏ n1 : N, ∑ n2 : N, (pr1 n1) * g = g * (pr1 n2). Definition rcoset_in_lcoset_witness {X : gr} {N : subgr X} : rcoset_in_lcoset N -> (X -> N -> N) := fun H g n1 => pr1 (H g n1). Definition rcoset_in_lcoset_property {X : gr} {N : subgr X} (H : rcoset_in_lcoset N) (g : X) (n1 : N) : N (pr1 (rcoset_in_lcoset_witness H g n1)) := pr2 (rcoset_in_lcoset_witness H g n1). Definition rcoset_in_lcoset_equation {X : gr} {N : subgr X} (H : rcoset_in_lcoset N) (g : X) (n1 : N) : (pr1 n1) * g = g * (pr1 (rcoset_in_lcoset_witness H g n1)) := pr2 (H g n1). Definition lcoset_equal_rcoset {X : gr} (N : subgr X) : UU := lcoset_in_rcoset N × rcoset_in_lcoset N. Lemma lcoset_in_rcoset_impl_normal {X : gr} (N : subgr X) : lcoset_in_rcoset N -> isnormalsubgr N. Proof. intros lcinrc. unfold isnormalsubgr. intros g n1. refine (@transportb _ (fun x => N x) _ _ _ _). { etrans. { apply maponpaths_2, (lcoset_in_rcoset_equation lcinrc). } etrans. { apply assocax. } etrans. { apply maponpaths, grrinvax. } apply runax. } apply lcoset_in_rcoset_property. Defined. Lemma lcoset_equal_rcoset_impl_normal {X : gr} (N : subgr X) : lcoset_equal_rcoset N -> isnormalsubgr N. Proof. intros H. apply lcoset_in_rcoset_impl_normal. exact (pr1 H). Defined. Lemma normal_lcoset_in_rcoset {X : gr} (N : normalsubgr X) : lcoset_in_rcoset N. Proof. unfold normalsubgr in N. induction N as [N normalprop]. simpl. unfold lcoset_in_rcoset. intros g n1. use tpair. - exact (tpair _ (g * (pr1 n1) * (grinv X g)) (normalprop g n1)). - simpl. rewrite (assocax _ _ _ g). rewrite (grlinvax X _). rewrite (runax X). reflexivity. Defined. Definition normal_rcoset_in_lcoset {X : gr} (N : normalsubgr X) : rcoset_in_lcoset N. Proof. induction N as [N normalprop]. simpl. unfold rcoset_in_lcoset. intros g n1. use tpair. - exists ((grinv X g) * (pr1 n1) * (grinv X (grinv X g))). use normalprop. - simpl. rewrite (assocax _ (grinv X g) _ _). rewrite (!assocax _ g _ _). rewrite (grrinvax X). rewrite (lunax X). rewrite (grinvinv X). reflexivity. Defined. Definition normal_lcoset_equal_rcoset {X : gr} (N : normalsubgr X) : lcoset_equal_rcoset N := (normal_lcoset_in_rcoset N,,normal_rcoset_in_lcoset N). Lemma in_same_coset_isbinophrel {X : gr} (N : normalsubgr X) : isbinophrel (in_same_left_coset_eqrel N). Proof. unfold isbinophrel. split. - intros a b c. unfold in_same_left_coset_eqrel. simpl. unfold in_same_left_coset. intros ab_same_lcoset. use tpair. + exact (pr1 ab_same_lcoset). + simpl. rewrite (assocax _ c _ _). apply maponpaths. exact (pr2 ab_same_lcoset). - intros a b c. unfold in_same_left_coset_eqrel. simpl. unfold in_same_left_coset. intros ab_same_lcoset. use tpair. + refine (rcoset_in_lcoset_witness _ c (pr1 ab_same_lcoset)); apply normal_rcoset_in_lcoset. + simpl. rewrite (grinvinv _). rewrite (assocax _ a _ _). rewrite (assocax _ (grinv X c) _ _). rewrite (!assocax _ c _ _). rewrite (grrinvax _). rewrite (lunax _). rewrite (!assocax _ a _ _). apply maponpaths_2. exact (pr2 ab_same_lcoset). Defined. Definition in_same_coset_binopeqrel {X : gr} (N : normalsubgr X) : binopeqrel X := tpair _ (in_same_left_coset_eqrel N) (in_same_coset_isbinophrel N). Definition grquot_by_normal_subgr (X : gr) (N : normalsubgr X) : gr := grquot (in_same_coset_binopeqrel N). End NormalSubGroups. (** *** Direct products *) Lemma isgrdirprod (X Y : gr) : isgrop (@op (setwithbinopdirprod X Y)). Proof. split with (ismonoiddirprod X Y). split with (λ xy : _, make_dirprod (grinv X (pr1 xy)) (grinv Y (pr2 xy))). split. - intro xy. destruct xy as [ x y ]. unfold unel_is. simpl. apply pathsdirprod. apply (grlinvax X x). apply (grlinvax Y y). - intro xy. destruct xy as [ x y ]. unfold unel_is. simpl. apply pathsdirprod. apply (grrinvax X x). apply (grrinvax Y y). Defined. Definition grdirprod (X Y : gr) : gr. Proof. split with (setwithbinopdirprod X Y). apply isgrdirprod. Defined. (** *** Group of invertible elements in a monoid *) Local Open Scope multmonoid. Definition invertible_submonoid_grop X : isgrop (@op (invertible_submonoid X)). Proof. pose (submon := invertible_submonoid X). pose (submon_carrier := ismonoidcarrier submon). (** We know that if each element has an inverse, it's a grop *) apply (isgropif submon_carrier). intros xpair. pose (x := pr1 xpair). pose (unel := (unel_is submon_carrier)). (** We can use other hProps when proving an hProp (assume it has an inverse) *) apply (squash_to_prop (pr2 xpair) (propproperty _)). intros xinv. unfold haslinv. apply hinhpr. refine ((pr1 xinv,, inverse_in_submonoid _ x (pr1 xinv) (pr2 xpair) (pr2 xinv)),, _). apply subtypePath_prop. exact (pr2 (pr2 xinv)). Defined. Local Close Scope multmonoid. Definition gr_merely_invertible_elements : monoid -> gr := fun X => (carrierofasubsetwithbinop (submonoidtosubsetswithbinop _ (invertible_submonoid X)),, invertible_submonoid_grop X). (** ** Abelian groups *) (** *** Basic definitions *) Definition abgr : UU := total2 (λ X : setwithbinop, isabgrop (@op X)). Definition make_abgr (X : setwithbinop) (is : isabgrop (@op X)) : abgr := tpair (λ X : setwithbinop, isabgrop (@op X)) X is. Definition abgrconstr (X : abmonoid) (inv0 : X -> X) (is : isinv (@op X) (unel X) inv0) : abgr := make_abgr X (make_dirprod (make_isgrop (pr2 X) (tpair _ inv0 is)) (commax X)). Definition abgrtogr : abgr -> gr := λ X : _, make_gr (pr1 X) (pr1 (pr2 X)). Coercion abgrtogr : abgr >-> gr. Definition abgrtoabmonoid : abgr -> abmonoid := λ X : _, make_abmonoid (pr1 X) (make_dirprod (pr1 (pr1 (pr2 X))) (pr2 (pr2 X))). Coercion abgrtoabmonoid : abgr >-> abmonoid. Definition abgr_of_gr (X : gr) (H : iscomm (@op X)) : abgr := make_abgr X (make_isabgrop (pr2 X) H). Declare Scope abgr. Delimit Scope abgr with abgr. Notation "x - y" := (op x (grinv _ y)) : abgr. Notation "- y" := (grinv _ y) : abgr. (** *** Construction of the trivial abgr consisting of one element given by unit. *) Definition unitabgr_isabgrop : isabgrop (@op unitabmonoid). Proof. use make_isabgrop. - exact unitgr_isgrop. - exact (commax unitabmonoid). Qed. Definition unitabgr : abgr := make_abgr unitabmonoid unitabgr_isabgrop. Lemma abgrfuntounit_ismonoidfun (X : abgr) : ismonoidfun (λ x : X, (unel unitabgr)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit. - use isProofIrrelevantUnit. Qed. Definition abgrfuntounit (X : abgr) : monoidfun X unitabgr := monoidfunconstr (abgrfuntounit_ismonoidfun X). Lemma abgrfunfromunit_ismonoidfun (X : abgr) : ismonoidfun (λ x : unitabgr, (unel X)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X). - use idpath. Qed. Definition abgrfunfromunit (X : abgr) : monoidfun unitabgr X := monoidfunconstr (abgrfunfromunit_ismonoidfun X). Lemma unelabgrfun_ismonoidfun (X Y : abgr) : ismonoidfun (λ x : X, (unel Y)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use lunax. - use idpath. Qed. Definition unelabgrfun (X Y : abgr) : monoidfun X Y := monoidfunconstr (unelgrfun_ismonoidfun X Y). (** *** Abelian group structure on morphism between abelian groups *) Definition abgrshombinop_inv_ismonoidfun {X Y : abgr} (f : monoidfun X Y) : ismonoidfun (λ x : X, grinv Y (pr1 f x)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. cbn. rewrite (pr1 (pr2 f)). rewrite (pr2 (pr2 Y)). use (grinvop Y). - use (pathscomp0 (maponpaths (λ y : Y, grinv Y y) (monoidfununel f))). use grinvunel. Qed. Definition abgrshombinop_inv {X Y : abgr} (f : monoidfun X Y) : monoidfun X Y := monoidfunconstr (abgrshombinop_inv_ismonoidfun f). Definition abgrshombinop_linvax {X Y : abgr} (f : monoidfun X Y) : @abmonoidshombinop X Y (abgrshombinop_inv f) f = unelmonoidfun X Y. Proof. use monoidfun_paths. use funextfun. intros x. use (@grlinvax Y). Qed. Definition abgrshombinop_rinvax {X Y : abgr} (f : monoidfun X Y) : @abmonoidshombinop X Y f (abgrshombinop_inv f) = unelmonoidfun X Y. Proof. use monoidfun_paths. use funextfun. intros x. use (grrinvax Y). Qed. Lemma abgrshomabgr_isabgrop (X Y : abgr) : @isabgrop (abmonoidshomabmonoid X Y) (λ f g : monoidfun X Y, @abmonoidshombinop X Y f g). Proof. use make_isabgrop. - use make_isgrop. + exact (abmonoidshomabmonoid_ismonoidop X Y). + use make_invstruct. * intros f. exact (abgrshombinop_inv f). * use make_isinv. intros f. exact (abgrshombinop_linvax f). intros f. exact (abgrshombinop_rinvax f). - intros f g. exact (abmonoidshombinop_comm f g). Defined. Definition abgrshomabgr (X Y : abgr) : abgr. Proof. use make_abgr. - exact (abmonoidshomabmonoid X Y). - exact (abgrshomabgr_isabgrop X Y). Defined. (** *** (X = Y) ≃ (monoidiso X Y) The idea is to use the following composition (X = Y) ≃ (make_abgr' X = make_abgr' Y) ≃ (pr1 (make_abgr' X) = pr1 (make_abgr' Y)) ≃ (monoidiso X Y) We use abgr' so that we can use univalence for groups, [gr_univalence]. See [abgr_univalence_weq3]. *) Local Definition abgr' : UU := ∑ g : (∑ X : setwithbinop, isgrop (@op X)), iscomm (pr2 (pr1 g)). Local Definition make_abgr' (X : abgr) : abgr' := tpair _ (tpair _ (pr1 X) (dirprod_pr1 (pr2 X))) (dirprod_pr2 (pr2 X)). Local Definition abgr_univalence_weq1 : abgr ≃ abgr' := weqtotal2asstol (λ Z : setwithbinop, isgrop (@op Z)) (fun y : (∑ x : setwithbinop, isgrop (@op x)) => iscomm (@op (pr1 y))). Definition abgr_univalence_weq1' (X Y : abgr) : (X = Y) ≃ (make_abgr' X = make_abgr' Y) := make_weq _ (@isweqmaponpaths abgr abgr' abgr_univalence_weq1 X Y). Definition abgr_univalence_weq2 (X Y : abgr) : (make_abgr' X = make_abgr' Y) ≃ (pr1 (make_abgr' X) = pr1 (make_abgr' Y)). Proof. use subtypeInjectivity. intros w. use isapropiscomm. Defined. Opaque abgr_univalence_weq2. Definition abgr_univalence_weq3 (X Y : abgr) : (pr1 (make_abgr' X) = pr1 (make_abgr' Y)) ≃ (monoidiso X Y) := gr_univalence (pr1 (make_abgr' X)) (pr1 (make_abgr' Y)). Definition abgr_univalence_map (X Y : abgr) : (X = Y) -> (monoidiso X Y). Proof. intro e. induction e. exact (idmonoidiso X). Defined. Lemma abgr_univalence_isweq (X Y : abgr) : isweq (abgr_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (abgr_univalence_weq1' X Y) (weqcomp (abgr_univalence_weq2 X Y) (abgr_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque abgr_univalence_isweq. Definition abgr_univalence (X Y : abgr) : (X = Y) ≃ (monoidiso X Y). Proof. use make_weq. - exact (abgr_univalence_map X Y). - exact (abgr_univalence_isweq X Y). Defined. Opaque abgr_univalence. (** *** Subobjects *) Definition subabgr (X : abgr) := subgr X. Identity Coercion id_subabgr : subabgr >-> subgr. Lemma isabgrcarrier {X : abgr} (A : subgr X) : isabgrop (@op A). Proof. split with (isgrcarrier A). apply (pr2 (@isabmonoidcarrier X A)). Defined. Definition carrierofasubabgr {X : abgr} (A : subabgr X) : abgr. Proof. split with A. apply isabgrcarrier. Defined. Coercion carrierofasubabgr : subabgr >-> abgr. Definition subabgr_incl {X : abgr} (A : subabgr X) : monoidfun A X := submonoid_incl A. Definition abgr_kernel_hsubtype {A B : abgr} (f : monoidfun A B) : hsubtype A := monoid_kernel_hsubtype f. Definition abgr_image_hsubtype {A B : abgr} (f : monoidfun A B) : hsubtype B := (λ y : B, ∃ x : A, (f x) = y). (** * Kernels Let f : X -> Y be a morphism of abelian groups. A kernel of f is given by the subgroup of X consisting of elements x such that [f x = unel Y]. *) (** ** Kernel as abelian group *) Definition abgr_Kernel_subabgr_issubgr {A B : abgr} (f : monoidfun A B) : issubgr (abgr_kernel_hsubtype f). Proof. use make_issubgr. - apply kernel_issubmonoid. - intros x a. apply (grrcan B (f x)). apply (pathscomp0 (! (binopfunisbinopfun f (grinv A x) x))). apply (pathscomp0 (maponpaths (λ a : A, f a) (grlinvax A x))). apply (pathscomp0 (monoidfununel f)). apply pathsinv0. apply (pathscomp0 (lunax B (f x))). exact a. Defined. Definition abgr_Kernel_subabgr {A B : abgr} (f : monoidfun A B) : @subabgr A := subgrconstr (@abgr_kernel_hsubtype A B f) (abgr_Kernel_subabgr_issubgr f). (** ** The inclusion Kernel f --> X is a morphism of abelian groups *) Definition abgr_Kernel_monoidfun_ismonoidfun {A B : abgr} (f : monoidfun A B) : @ismonoidfun (abgr_Kernel_subabgr f) A (make_incl (pr1carrier (abgr_kernel_hsubtype f)) (isinclpr1carrier (abgr_kernel_hsubtype f))). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use idpath. - use idpath. Qed. (** ** Image of f is a subgroup *) Definition abgr_image_issubgr {A B : abgr} (f : monoidfun A B) : issubgr (abgr_image_hsubtype f). Proof. use make_issubgr. - use make_issubmonoid. + intros a a'. use (hinhuniv _ (pr2 a)). intros ae. use (hinhuniv _ (pr2 a')). intros a'e. use hinhpr. use tpair. * exact (@op A (pr1 ae) (pr1 a'e)). * use (pathscomp0 (binopfunisbinopfun f (pr1 ae) (pr1 a'e))). use two_arg_paths. exact (pr2 ae). exact (pr2 a'e). + use hinhpr. use tpair. * exact (unel A). * exact (monoidfununel f). - intros b b'. use (hinhuniv _ b'). intros eb. use hinhpr. use tpair. + exact (grinv A (pr1 eb)). + use (pathscomp0 _ (maponpaths (λ bb : B, (grinv B bb)) (pr2 eb))). use monoidfuninvtoinv. Qed. Definition abgr_image {A B : abgr} (f : monoidfun A B) : @subabgr B := @subgrconstr B (@abgr_image_hsubtype A B f) (abgr_image_issubgr f). (** *** Quotient objects *) Lemma isabgrquot {X : abgr} (R : binopeqrel X) : isabgrop (@op (setwithbinopquot R)). Proof. split with (isgrquot R). apply (pr2 (@isabmonoidquot X R)). Defined. Definition abgrquot {X : abgr} (R : binopeqrel X) : abgr. Proof. split with (setwithbinopquot R). apply isabgrquot. Defined. (** *** Direct products *) Lemma isabgrdirprod (X Y : abgr) : isabgrop (@op (setwithbinopdirprod X Y)). Proof. split with (isgrdirprod X Y). apply (pr2 (isabmonoiddirprod X Y)). Defined. Definition abgrdirprod (X Y : abgr) : abgr. Proof. split with (setwithbinopdirprod X Y). apply isabgrdirprod. Defined. (** *** Abelian group of fractions of an abelian unitary monoid *) Section Fractions. Import UniMath.Algebra.Monoids.AddNotation. Local Open Scope addmonoid. Definition hrelabgrdiff (X : abmonoid) : hrel (X × X) := λ xa1 xa2, hexists (λ x0 : X, paths (((pr1 xa1) + (pr2 xa2)) + x0) (((pr1 xa2) + (pr2 xa1)) + x0)). Definition abgrdiffphi (X : abmonoid) (xa : dirprod X X) : dirprod X (totalsubtype X) := make_dirprod (pr1 xa) (make_carrier (λ x : X, htrue) (pr2 xa) tt). Definition hrelabgrdiff' (X : abmonoid) : hrel (X × X) := λ xa1 xa2, eqrelabmonoidfrac X (totalsubmonoid X) (abgrdiffphi X xa1) (abgrdiffphi X xa2). Lemma logeqhrelsabgrdiff (X : abmonoid) : hrellogeq (hrelabgrdiff' X) (hrelabgrdiff X). Proof. split. simpl. apply hinhfun. intro t2. set (a0 := pr1 (pr1 t2)). split with a0. apply (pr2 t2). simpl. apply hinhfun. intro t2. set (x0 := pr1 t2). split with (tpair _ x0 tt). apply (pr2 t2). Defined. Lemma iseqrelabgrdiff (X : abmonoid) : iseqrel (hrelabgrdiff X). Proof. apply (iseqrellogeqf (logeqhrelsabgrdiff X)). apply (iseqrelconstr). intros xx' xx'' xx'''. intros r1 r2. apply (eqreltrans (eqrelabmonoidfrac X (totalsubmonoid X)) _ _ _ r1 r2). intro xx. apply (eqrelrefl (eqrelabmonoidfrac X (totalsubmonoid X)) _). intros xx xx'. intro r. apply (eqrelsymm (eqrelabmonoidfrac X (totalsubmonoid X)) _ _ r). Defined. Opaque iseqrelabgrdiff. Definition eqrelabgrdiff (X : abmonoid) : @eqrel (abmonoiddirprod X X) := make_eqrel _ (iseqrelabgrdiff X). Lemma isbinophrelabgrdiff (X : abmonoid) : @isbinophrel (abmonoiddirprod X X) (hrelabgrdiff X). Proof. apply (@isbinophrellogeqf (abmonoiddirprod X X) _ _ (logeqhrelsabgrdiff X)). split. intros a b c r. apply (pr1 (isbinophrelabmonoidfrac X (totalsubmonoid X)) _ _ (make_dirprod (pr1 c) (make_carrier (λ x : X, htrue) (pr2 c) tt)) r). intros a b c r. apply (pr2 (isbinophrelabmonoidfrac X (totalsubmonoid X)) _ _ (make_dirprod (pr1 c) (make_carrier (λ x : X, htrue) (pr2 c) tt)) r). Defined. Opaque isbinophrelabgrdiff. Definition binopeqrelabgrdiff (X : abmonoid) : binopeqrel (abmonoiddirprod X X) := make_binopeqrel (eqrelabgrdiff X) (isbinophrelabgrdiff X). Definition abgrdiffcarrier (X : abmonoid) : abmonoid := @abmonoidquot (abmonoiddirprod X X) (binopeqrelabgrdiff X). Definition abgrdiffinvint (X : abmonoid) : dirprod X X -> dirprod X X := λ xs : _, make_dirprod (pr2 xs) (pr1 xs). Lemma abgrdiffinvcomp (X : abmonoid) : iscomprelrelfun (hrelabgrdiff X) (eqrelabgrdiff X) (abgrdiffinvint X). Proof. unfold iscomprelrelfun. unfold eqrelabgrdiff. unfold hrelabgrdiff. unfold eqrelabmonoidfrac. unfold hrelabmonoidfrac. simpl. intros xs xs'. apply (hinhfun). intro tt0. set (x := pr1 xs). set (s := pr2 xs). set (x' := pr1 xs'). set (s' := pr2 xs'). split with (pr1 tt0). destruct tt0 as [ a eq ]. change (paths (s + x' + a) (s' + x + a)). apply pathsinv0. simpl. set(e := commax X s' x). simpl in e. rewrite e. clear e. set (e := commax X s x'). simpl in e. rewrite e. clear e. apply eq. Defined. Opaque abgrdiffinvcomp. Definition abgrdiffinv (X : abmonoid) : abgrdiffcarrier X -> abgrdiffcarrier X := setquotfun (hrelabgrdiff X) (eqrelabgrdiff X) (abgrdiffinvint X) (abgrdiffinvcomp X). Lemma abgrdiffisinv (X : abmonoid) : isinv (@op (abgrdiffcarrier X)) (unel (abgrdiffcarrier X)) (abgrdiffinv X). Proof. set (R := eqrelabgrdiff X). assert (isl : islinv (@op (abgrdiffcarrier X)) (unel (abgrdiffcarrier X)) (abgrdiffinv X)). { unfold islinv. apply (setquotunivprop R (λ x, _ = _)). intro xs. set (x := pr1 xs). set (s := pr2 xs). apply (iscompsetquotpr R (@op (abmonoiddirprod X X) (abgrdiffinvint X xs) xs) (unel _)). simpl. apply hinhpr. split with (unel X). change (paths (s + x + (unel X) + (unel X)) ((unel X) + (x + s) + (unel X))). destruct (commax X x s). destruct (commax X (unel X) (x + s)). apply idpath. } apply (make_dirprod isl (weqlinvrinv (@op (abgrdiffcarrier X)) (commax (abgrdiffcarrier X)) (unel (abgrdiffcarrier X)) (abgrdiffinv X) isl)). Defined. Opaque abgrdiffisinv. Definition abgrdiff (X : abmonoid) : abgr := abgrconstr (abgrdiffcarrier X) (abgrdiffinv X) (abgrdiffisinv X). Definition prabgrdiff (X : abmonoid) : X -> X -> abgrdiff X := λ x x' : X, setquotpr (eqrelabgrdiff X) (make_dirprod x x'). (** *** Abelian group of fractions and abelian monoid of fractions *) Definition weqabgrdiffint (X : abmonoid) : weq (X × X) (dirprod X (totalsubtype X)) := weqdirprodf (idweq X) (invweq (weqtotalsubtype X)). Definition weqabgrdiff (X : abmonoid) : weq (abgrdiff X) (abmonoidfrac X (totalsubmonoid X)). Proof. intros. apply (weqsetquotweq (eqrelabgrdiff X) (eqrelabmonoidfrac X (totalsubmonoid X)) (weqabgrdiffint X)). - simpl. intros x x'. destruct x as [ x1 x2 ]. destruct x' as [ x1' x2' ]. simpl in *. apply hinhfun. intro tt0. destruct tt0 as [ xx0 is0 ]. split with (make_carrier (λ x : X, htrue) xx0 tt). apply is0. - simpl. intros x x'. destruct x as [ x1 x2 ]. destruct x' as [ x1' x2' ]. simpl in *. apply hinhfun. intro tt0. destruct tt0 as [ xx0 is0 ]. split with (pr1 xx0). apply is0. Defined. (** *** Canonical homomorphism to the abelian group of fractions *) Definition toabgrdiff (X : abmonoid) (x : X) : abgrdiff X := setquotpr _ (make_dirprod x (unel X)). Lemma isbinopfuntoabgrdiff (X : abmonoid) : isbinopfun (toabgrdiff X). Proof. unfold isbinopfun. intros x1 x2. change (paths (setquotpr _ (make_dirprod (x1 + x2) (unel X))) (setquotpr (eqrelabgrdiff X) (make_dirprod (x1 + x2) ((unel X) + (unel X))))). apply (maponpaths (setquotpr _)). apply (@pathsdirprod X X). apply idpath. apply (pathsinv0 (lunax X 0)). Defined. Lemma isunitalfuntoabgrdiff (X : abmonoid) : paths (toabgrdiff X (unel X)) (unel (abgrdiff X)). Proof. apply idpath. Defined. Definition ismonoidfuntoabgrdiff (X : abmonoid) : ismonoidfun (toabgrdiff X) := make_dirprod (isbinopfuntoabgrdiff X) (isunitalfuntoabgrdiff X). (** *** Abelian group of fractions in the case when all elements are cancelable *) Lemma isinclprabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) : ∏ x' : X, isincl (λ x, prabgrdiff X x x'). Proof. intros. set (int := isinclprabmonoidfrac X (totalsubmonoid X) (λ a : totalsubmonoid X, iscanc (pr1 a)) (make_carrier (λ x : X, htrue) x' tt)). set (int1 := isinclcomp (make_incl _ int) (weqtoincl (invweq (weqabgrdiff X)))). apply int1. Defined. Definition isincltoabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) : isincl (toabgrdiff X) := isinclprabgrdiff X iscanc (unel X). Lemma isdeceqabgrdiff (X : abmonoid) (iscanc : ∏ x : X, isrcancelable (@op X) x) (is : isdeceq X) : isdeceq (abgrdiff X). Proof. intros. apply (isdeceqweqf (invweq (weqabgrdiff X))). apply (isdeceqabmonoidfrac X (totalsubmonoid X) (λ a : totalsubmonoid X, iscanc (pr1 a)) is). Defined. (** *** Relations on the abelian group of fractions *) Definition abgrdiffrelint (X : abmonoid) (L : hrel X) : hrel (setwithbinopdirprod X X) := λ xa yb, hexists (λ c0 : X, L (((pr1 xa) + (pr2 yb)) + c0) (((pr1 yb) + (pr2 xa)) + c0)). Definition abgrdiffrelint' (X : abmonoid) (L : hrel X) : hrel (setwithbinopdirprod X X) := λ xa1 xa2, abmonoidfracrelint _ (totalsubmonoid X) L (abgrdiffphi X xa1) (abgrdiffphi X xa2). Lemma logeqabgrdiffrelints (X : abmonoid) (L : hrel X) : hrellogeq (abgrdiffrelint' X L) (abgrdiffrelint X L). Proof. split. unfold abgrdiffrelint. unfold abgrdiffrelint'. simpl. apply hinhfun. intro t2. set (a0 := pr1 (pr1 t2)). split with a0. apply (pr2 t2). simpl. apply hinhfun. intro t2. set (x0 := pr1 t2). split with (tpair _ x0 tt). apply (pr2 t2). Defined. Lemma iscomprelabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) : iscomprelrel (eqrelabgrdiff X) (abgrdiffrelint X L). Proof. apply (iscomprelrellogeqf1 _ (logeqhrelsabgrdiff X)). apply (iscomprelrellogeqf2 _ (logeqabgrdiffrelints X L)). intros x x' x0 x0' r r0. apply (iscomprelabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) _ _ _ _ r r0). Defined. Opaque iscomprelabgrdiffrelint. Definition abgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) := quotrel (iscomprelabgrdiffrelint X is). Definition abgrdiffrel' (X : abmonoid) {L : hrel X} (is : isbinophrel L) : hrel (abgrdiff X) := λ x x', abmonoidfracrel X (totalsubmonoid X) (isbinoptoispartbinop _ _ is) (weqabgrdiff X x) (weqabgrdiff X x'). Definition logeqabgrdiffrels (X : abmonoid) {L : hrel X} (is : isbinophrel L) : hrellogeq (abgrdiffrel' X is) (abgrdiffrel X is). Proof. intros x1 x2. split. - assert (int : ∏ x x', isaprop (abgrdiffrel' X is x x' -> abgrdiffrel X is x x')). { intros x x'. apply impred. intro. apply (pr2 _). } generalize x1 x2. clear x1 x2. apply (setquotuniv2prop _ (λ x x', make_hProp _ (int x x'))). intros x x'. change ((abgrdiffrelint' X L x x') -> (abgrdiffrelint _ L x x')). apply (pr1 (logeqabgrdiffrelints X L x x')). - assert (int : ∏ x x', isaprop (abgrdiffrel X is x x' -> abgrdiffrel' X is x x')). intros x x'. apply impred. intro. apply (pr2 _). generalize x1 x2. clear x1 x2. apply (setquotuniv2prop _ (λ x x', make_hProp _ (int x x'))). intros x x'. change ((abgrdiffrelint X L x x') -> (abgrdiffrelint' _ L x x')). apply (pr2 (logeqabgrdiffrelints X L x x')). Defined. Lemma istransabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istrans L) : istrans (abgrdiffrelint X L). Proof. apply (istranslogeqf (logeqabgrdiffrelints X L)). intros a b c rab rbc. apply (istransabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl _ _ _ rab rbc). Defined. Opaque istransabgrdiffrelint. Lemma istransabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istrans L) : istrans (abgrdiffrel X is). Proof. refine (istransquotrel _ _). apply istransabgrdiffrelint. - apply is. - apply isl. Defined. Lemma issymmabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : issymm L) : issymm (abgrdiffrelint X L). Proof. apply (issymmlogeqf (logeqabgrdiffrelints X L)). intros a b rab. apply (issymmabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl _ _ rab). Defined. Opaque issymmabgrdiffrelint. Lemma issymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : issymm L) : issymm (abgrdiffrel X is). Proof. refine (issymmquotrel _ _). apply issymmabgrdiffrelint. - apply is. - apply isl. Defined. Lemma isreflabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isrefl L) : isrefl (abgrdiffrelint X L). Proof. intro xa. unfold abgrdiffrelint. simpl. apply hinhpr. split with (unel X). apply (isl _). Defined. Lemma isreflabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isrefl L) : isrefl (abgrdiffrel X is). Proof. refine (isreflquotrel _ _). apply isreflabgrdiffrelint. - apply is. - apply isl. Defined. Lemma ispoabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : ispreorder L) : ispreorder (abgrdiffrelint X L). Proof. split with (istransabgrdiffrelint X is (pr1 isl)). apply (isreflabgrdiffrelint X is (pr2 isl)). Defined. Lemma ispoabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : ispreorder L) : ispreorder (abgrdiffrel X is). Proof. refine (ispoquotrel _ _). apply ispoabgrdiffrelint. - apply is. - apply isl. Defined. Lemma iseqrelabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iseqrel L) : iseqrel (abgrdiffrelint X L). Proof. split with (ispoabgrdiffrelint X is (pr1 isl)). apply (issymmabgrdiffrelint X is (pr2 isl)). Defined. Lemma iseqrelabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iseqrel L) : iseqrel (abgrdiffrel X is). Proof. refine (iseqrelquotrel _ _). apply iseqrelabgrdiffrelint. - apply is. - apply isl. Defined. Lemma isantisymmnegabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isantisymmneg L) : isantisymmneg (abgrdiffrel X is). Proof. apply (isantisymmneglogeqf (logeqabgrdiffrels X is)). intros a b rab rba. set (int := isantisymmnegabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba). apply (invmaponpathsweq _ _ _ int). Defined. Lemma isantisymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isantisymm L) : isantisymm (abgrdiffrel X is). Proof. apply (isantisymmlogeqf (logeqabgrdiffrels X is)). intros a b rab rba. set (int := isantisymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba). apply (invmaponpathsweq _ _ _ int). Defined. Opaque isantisymmabgrdiffrel. Lemma isirreflabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isirrefl L) : isirrefl (abgrdiffrel X is). Proof. apply (isirrefllogeqf (logeqabgrdiffrels X is)). intros a raa. apply (isirreflabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) raa). Defined. Opaque isirreflabgrdiffrel. Lemma isasymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : isasymm L) : isasymm (abgrdiffrel X is). Proof. apply (isasymmlogeqf (logeqabgrdiffrels X is)). intros a b rab rba. apply (isasymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b) rab rba). Defined. Opaque isasymmabgrdiffrel. Lemma iscoasymmabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iscoasymm L) : iscoasymm (abgrdiffrel X is). Proof. apply (iscoasymmlogeqf (logeqabgrdiffrels X is)). intros a b rab. apply (iscoasymmabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b) rab). Defined. Opaque iscoasymmabgrdiffrel. Lemma istotalabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : istotal L) : istotal (abgrdiffrel X is). Proof. apply (istotallogeqf (logeqabgrdiffrels X is)). intros a b. apply (istotalabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b)). Defined. Opaque istotalabgrdiffrel. Lemma iscotransabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isl : iscotrans L) : iscotrans (abgrdiffrel X is). Proof. apply (iscotranslogeqf (logeqabgrdiffrels X is)). intros a b c. apply (iscotransabmonoidfracrel _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is) isl (weqabgrdiff X a) (weqabgrdiff X b) (weqabgrdiff X c)). Defined. Opaque iscotransabgrdiffrel. Lemma isStrongOrder_abgrdiff {X : abmonoid} (gt : hrel X) (Hgt : isbinophrel gt) : isStrongOrder gt → isStrongOrder (abgrdiffrel X Hgt). Proof. intros H. repeat split. - apply istransabgrdiffrel, (istrans_isStrongOrder H). - apply iscotransabgrdiffrel, (iscotrans_isStrongOrder H). - apply isirreflabgrdiffrel, (isirrefl_isStrongOrder H). Defined. Opaque isStrongOrder_abgrdiff. Definition StrongOrder_abgrdiff {X : abmonoid} (gt : StrongOrder X) (Hgt : isbinophrel gt) : StrongOrder (abgrdiff X) := abgrdiffrel X Hgt,, isStrongOrder_abgrdiff gt Hgt (pr2 gt). Lemma abgrdiffrelimpl (X : abmonoid) {L L' : hrel X} (is : isbinophrel L) (is' : isbinophrel L') (impl : ∏ x x', L x x' -> L' x x') (x x' : abgrdiff X) (ql : abgrdiffrel X is x x') : abgrdiffrel X is' x x'. Proof. generalize ql. refine (quotrelimpl _ _ _ _ _). intros x0 x0'. simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (impl _ _ (pr2 t2)). Defined. Opaque abgrdiffrelimpl. Lemma abgrdiffrellogeq (X : abmonoid) {L L' : hrel X} (is : isbinophrel L) (is' : isbinophrel L') (lg : ∏ x x', L x x' <-> L' x x') (x x' : abgrdiff X) : (abgrdiffrel X is x x') <-> (abgrdiffrel X is' x x'). Proof. refine (quotrellogeq _ _ _ _ _). intros x0 x0'. split. - simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (pr1 (lg _ _) (pr2 t2)). - simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (pr2 (lg _ _) (pr2 t2)). Defined. Opaque abgrdiffrellogeq. Lemma isbinopabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isbinophrel L) : @isbinophrel (setwithbinopdirprod X X) (abgrdiffrelint X L). Proof. apply (isbinophrellogeqf (logeqabgrdiffrelints X L)). split. - intros a b c lab. apply (pr1 (ispartbinopabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)) (abgrdiffphi X a) (abgrdiffphi X b) (abgrdiffphi X c) tt lab). - intros a b c lab. apply (pr2 (ispartbinopabmonoidfracrelint _ (totalsubmonoid X) (isbinoptoispartbinop _ _ is)) (abgrdiffphi X a) (abgrdiffphi X b) (abgrdiffphi X c) tt lab). Defined. Opaque isbinopabgrdiffrelint. Lemma isbinopabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) : @isbinophrel (abgrdiff X) (abgrdiffrel X is). Proof. intros. apply (isbinopquotrel (binopeqrelabgrdiff X) (iscomprelabgrdiffrelint X is)). apply (isbinopabgrdiffrelint X is). Defined. Definition isdecabgrdiffrelint (X : abmonoid) {L : hrel X} (is : isinvbinophrel L) (isl : isdecrel L) : isdecrel (abgrdiffrelint X L). Proof. intros xa1 xa2. set (x1 := pr1 xa1). set (a1 := pr2 xa1). set (x2 := pr1 xa2). set (a2 := pr2 xa2). assert (int : coprod (L (x1 + a2) (x2 + a1)) (neg (L (x1 + a2) (x2 + a1)))) by apply (isl _ _). destruct int as [ l | nl ]. - apply ii1. unfold abgrdiffrelint. apply hinhpr. split with (unel X). rewrite (runax X _). rewrite (runax X _). apply l. - apply ii2. generalize nl. clear nl. apply negf. unfold abgrdiffrelint. simpl. apply (@hinhuniv _ (make_hProp _ (pr2 (L _ _)))). intro t2l. destruct t2l as [ c0a l ]. simpl. apply ((pr2 is) _ _ c0a l). Defined. Definition isdecabgrdiffrel (X : abmonoid) {L : hrel X} (is : isbinophrel L) (isi : isinvbinophrel L) (isl : isdecrel L) : isdecrel (abgrdiffrel X is). Proof. refine (isdecquotrel _ _). apply isdecabgrdiffrelint. - apply isi. - apply isl. Defined. (** *** Relations and the canonical homomorphism to [ abgrdiff ] *) Lemma iscomptoabgrdiff (X : abmonoid) {L : hrel X} (is : isbinophrel L) : iscomprelrelfun L (abgrdiffrel X is) (toabgrdiff X). Proof. unfold iscomprelrelfun. intros x x' l. change (abgrdiffrelint X L (make_dirprod x (unel X)) (make_dirprod x' (unel X))). simpl. apply (hinhpr). split with (unel X). apply ((pr2 is) _ _ 0). apply ((pr2 is) _ _ 0). apply l. Defined. Opaque iscomptoabgrdiff. Close Scope addmonoid_scope. End Fractions. UniMath-20231010/UniMath/Algebra/IteratedBinaryOperations.v000066400000000000000000000466411451125700300233650ustar00rootroot00000000000000Require Export UniMath.Combinatorics.Lists. Require Export UniMath.Combinatorics.FiniteSequences. Require Export UniMath.Algebra.RigsAndRings. Require Export UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.Groups. Require Import UniMath.MoreFoundations.NegativePropositions. (* move upstream *) (* end of move upstream *) Local Notation "[]" := Lists.nil (at level 0, format "[]"). Local Infix "::" := cons. (** general associativity for binary operations on types *) Section BinaryOperations. Context {X:UU} (unel:X) (op:binop X). (* we use an extra induction step in each of the following definitions so we don't end up with superfluous unel factors *) Definition iterop_list : list X -> X := foldr1 op unel. Definition iterop_fun {n} (x:stn n->X) : X. Proof. intros. induction n as [|n _]. { exact unel. } { induction n as [|n I]. { exact (x lastelement). } { exact (op (I (x ∘ dni lastelement)) (x lastelement)). }} Defined. Definition iterop_seq : Sequence X -> X. Proof. intros x. exact (iterop_fun x). Defined. (* now define products of products *) Definition iterop_list_list : list(list X) -> X. Proof. intros w. exact (iterop_list (map iterop_list w)). Defined. Definition iterop_fun_fun {n} {m:stn n -> nat} : (∏ i (j:stn (m i)), X) -> X. Proof. intros x. exact (iterop_fun (λ i, iterop_fun (x i))). Defined. Definition iterop_seq_seq : Sequence (Sequence X) -> X. Proof. intros x. exact (iterop_fun_fun (λ i j, x i j)). Defined. Definition isAssociative_list := ∏ (x:list (list X)), iterop_list (Lists.flatten x) = iterop_list_list x. Definition isAssociative_fun := ∏ n (m:stn n -> nat) (x : ∏ i (j:stn (m i)), X), iterop_fun (StandardFiniteSets.flatten' x) = iterop_fun_fun x. Definition isAssociative_seq := ∏ (x : Sequence (Sequence X)), iterop_seq (FiniteSequences.flatten x) = iterop_seq_seq x. Local Open Scope stn. Definition isCommutative_fun := ∏ n (x:⟦n⟧ -> X) (f:⟦n⟧≃⟦n⟧), iterop_fun (x ∘ f) = iterop_fun x. Lemma assoc_fun_to_seq : isAssociative_fun -> isAssociative_seq. Proof. intros assoc x. exact (assoc _ _ (λ i j, x i j)). Defined. Lemma assoc_seq_to_fun : isAssociative_seq -> isAssociative_fun. Proof. intros assoc n m x. exact (assoc (functionToSequence (λ i, functionToSequence (x i)))). Defined. Definition iterop_list_step (runax : isrunit op unel) (x:X) (xs:list X) : iterop_list (x::xs) = op x (iterop_list xs). Proof. generalize x; clear x. apply (list_ind (λ xs, ∏ x : X, iterop_list (x :: xs) = op x (iterop_list xs))). { intro x. simpl. apply pathsinv0,runax. } intros y rest IH x. reflexivity. Defined. Definition iterop_fun_step' (lunax : islunit op unel) {m} (xs:stn m -> X) (x:X) : iterop_fun (append_vec xs x) = op (iterop_fun xs) x. Proof. unfold iterop_fun at 1. simpl. induction m as [|m _]. - simpl. rewrite append_vec_compute_2. apply pathsinv0. apply lunax. - simpl. rewrite append_vec_compute_2. apply (maponpaths (λ y, op y x)). apply maponpaths. apply append_and_drop_fun. Defined. Definition iterop_fun_step (lunax : islunit op unel) {m} (x:stn(S m) -> X) : iterop_fun x = op (iterop_fun (x ∘ dni lastelement)) (x lastelement). Proof. intros. unfold iterop_fun at 1. simpl. induction m as [|m _]. - simpl. apply pathsinv0, lunax. - simpl. reflexivity. Defined. Definition iterop_fun_append (lunax : islunit op unel) {m} (x:stn m -> X) (y:X) : iterop_fun (append_vec x y) = op (iterop_fun x) y. Proof. rewrite (iterop_fun_step lunax). rewrite append_vec_compute_2. apply (maponpaths (λ x, op (iterop_fun x) y)). apply funextfun; intro i. simpl. rewrite append_vec_compute_1. reflexivity. Defined. End BinaryOperations. (** general associativity for monoids *) Local Open Scope multmonoid. Section Monoids. Context {M:monoid}. Let oo := @op M. Let uu := unel M. Definition iterop_fun_mon {n} (x:stn n->M) : M := iterop_fun uu oo x. Definition iterop_list_mon : list M -> M := iterop_list uu oo. Definition iterop_seq_mon : Sequence M -> M := iterop_seq uu oo. Definition iterop_seq_seq_mon : Sequence (Sequence M) -> M := iterop_seq_seq uu oo. Definition iterop_list_list_mon : list (list M) -> M := iterop_list_list uu oo. (* some rewriting rules *) Lemma iterop_seq_mon_len1 (x : stn 1 -> M) : iterop_seq_mon (functionToSequence x) = x lastelement. Proof. reflexivity. Defined. Lemma iterop_seq_mon_step {n} (x:stn (S n) -> M) : iterop_seq_mon (S n,,x) = iterop_seq_mon (n,,x ∘ dni lastelement) * x lastelement. Proof. intros. induction n as [|n _]. - cbn. apply pathsinv0, lunax. - reflexivity. Defined. Lemma iterop_list_mon_nil : iterop_list_mon [] = 1. Proof. reflexivity. Defined. Lemma iterop_list_mon_step (x:M) (xs:list M) : iterop_list_mon (x::xs) = x * iterop_list_mon xs. Proof. apply iterop_list_step. apply runax. Defined. Lemma iterop_list_mon_singleton (x : M) : iterop_list_mon (x::[]) = x. Proof. reflexivity. Defined. Local Lemma iterop_seq_mon_append (x:Sequence M) (m:M) : iterop_seq_mon (append x m) = iterop_seq_mon x * m. Proof. revert x m. intros [n x] ?. unfold append. rewrite iterop_seq_mon_step. rewrite append_vec_compute_2. apply (maponpaths (λ a, a * m)). apply (maponpaths (λ x, iterop_seq_mon (n,,x))). apply funextfun; intros [i b]; simpl. now rewrite append_vec_compute_1. Defined. Local Lemma iterop_seq_seq_mon_step {n} (x:stn (S n) -> Sequence M) : iterop_seq_seq_mon (S n,,x) = iterop_seq_seq_mon (n,,x ∘ dni lastelement) * iterop_seq_mon (x lastelement). Proof. intros. induction n as [|n _]. - simpl. apply pathsinv0,lunax. - reflexivity. Defined. Lemma iterop_seq_mon_homot {n} (x y : stn n -> M) : x ~ y -> iterop_seq_mon(n,,x) = iterop_seq_mon(n,,y). Proof. revert x y. induction n as [|n N]. - reflexivity. - intros x y h. rewrite 2 iterop_seq_mon_step. apply two_arg_paths. + apply N. apply funhomot. exact h. + apply h. Defined. End Monoids. Section Monoids2. Context (M:monoid). Let op := @op M. Let unel := unel M. Definition isAssociative_list_mon := isAssociative_list unel op. Definition isAssociative_fun_mon := isAssociative_fun unel op. Definition isAssociative_seq_mon := isAssociative_seq unel op. Definition isCommutative_fun_mon := isCommutative_fun unel op. End Monoids2. (** The general associativity theorem. *) Lemma iterop_list_mon_concatenate {M : monoid} (l s : list M) : iterop_list_mon (Lists.concatenate l s) = iterop_list_mon l * iterop_list_mon s. Proof. revert l. apply list_ind. - apply pathsinv0, lunax. - intros x xs J. rewrite Lists.concatenateStep. unfold iterop_list_mon. rewrite 2 (iterop_list_step _ _ (runax M)). rewrite assocax. apply maponpaths. exact J. Defined. Theorem associativityOfProducts_list (M:monoid) : isAssociative_list (unel M) (@op M). Proof. (** This proof comes from the Associativity theorem, % \cite[section 1.3, Theorem 1, page 4]{BourbakiAlgebraI}. \par % *) (* this proof comes from the Associativity theorem, Bourbaki, Algebra, § 1.3, Theorem 1, page 4. *) unfold isAssociative_list. apply list_ind. - simpl. reflexivity. - intros x xs I. simpl in I. rewrite Lists.flattenStep. refine (iterop_list_mon_concatenate _ _ @ _). unfold iterop_list_list. rewrite mapStep. rewrite (iterop_list_step _ _ (runax M)). + apply (maponpaths (λ x, _ * x)). exact I. Defined. Theorem associativityOfProducts_seq (M:monoid) : isAssociative_seq (unel M) (@op M). Proof. (** This proof comes from the Associativity theorem, % \cite[section 1.3, Theorem 1, page 4]{BourbakiAlgebraI}. \par % *) (* this proof comes from the Associativity theorem, Bourbaki, Algebra, § 1.3, Theorem 1, page 4. *) unfold isAssociative_seq; intros. induction x as [n x]. induction n as [|n IHn]. { reflexivity. } change (flatten _) with (flatten ((n,,x): NonemptySequence _)). rewrite flattenStep. change (lastValue _) with (x lastelement). unfold iterop_seq_seq. simpl. unfold iterop_fun_fun. rewrite (iterop_fun_step _ _ (lunax M)). generalize (x lastelement) as z; intro z. unfold iterop_seq. induction z as [m z]. induction m as [|m IHm]. { simpl. rewrite runax. simple refine (_ @ IHn (x ∘ dni lastelement)). rewrite concatenate'_r0. now apply (two_arg_paths_b (natplusr0 (stnsum (length ∘ (x ∘ dni lastelement))))). } change (length (S m,, z)) with (S m). change (sequenceToFunction (S m,,z)) with z. rewrite (iterop_fun_step _ _ (lunax M)). rewrite concatenateStep. generalize (z lastelement) as w; intros. rewrite <- assocax. unfold append. Opaque iterop_fun. simpl. Transparent iterop_fun. rewrite (iterop_fun_append _ _ (lunax M)). apply (maponpaths (λ u, u*w)). simpl in IHm. apply IHm. Defined. Corollary associativityOfProducts' {M:monoid} {n} (f:stn n -> nat) (x:stn (stnsum f) -> M) : iterop_seq_mon (stnsum f,,x) = iterop_seq_seq_mon (partition f x). Proof. intros. refine (_ @ associativityOfProducts_seq M (partition f x)). assert (L := flatten_partition f x). apply pathsinv0. exact (iterop_seq_mon_homot _ _ L). Defined. (** generalized commutativity *) Local Notation "s □ x" := (append s x) (at level 64, left associativity). Ltac change_lhs a := match goal with |- @paths ?T ?x ?y => change (@paths T x y) with (@paths T a y) end. Ltac change_rhs a := match goal with |- @paths ?T ?x ?y => change (@paths T x y) with (@paths T x a) end. Local Open Scope stn. Lemma commutativityOfProducts_helper {M:abmonoid} {n} (x:stn (S n) -> M) (j:stn (S n)) : iterop_seq_mon (S n,,x) = iterop_seq_mon (n,,x ∘ dni j) * x j. Proof. induction j as [j jlt]. assert (jle := natlthsntoleh _ _ jlt). Local Open Scope transport. set (f := nil □ j □ S O □ n-j : stn 3 -> nat). assert (B : stnsum f = S n). { unfold stnsum, f; simpl. repeat unfold append_vec; simpl. rewrite natplusassoc. rewrite (natpluscomm 1). rewrite <- natplusassoc. rewrite natpluscomm. apply (maponpaths S). rewrite natpluscomm. now apply minusplusnmm. } set (r := weqfibtototal _ _ (λ k, eqweqmap (maponpaths (λ n, k < n : UU) B) ) : stn (stnsum f) ≃ stn (S n)). set (x' := x ∘ r). intermediate_path (iterop_seq_mon (stnsum f,, x')). { induction B. apply iterop_seq_mon_homot. intros i. unfold x'. simpl. apply maponpaths. apply ( invmaponpathsincl _ ( isinclstntonat _ ) _ _). reflexivity. } unfold iterop_seq_mon. unfold iterop_seq. refine (associativityOfProducts' f x' @ _). unfold partition. rewrite 3 iterop_seq_seq_mon_step. change (iterop_seq_seq_mon (0,,_)) with (unel M); rewrite lunax. set (s0 := dni lastelement (dni lastelement (@lastelement 0))). unfold funcomp at 1 2 3. set (s1 := dni lastelement (@lastelement 1)). set (s2 := @lastelement 2). unfold partition'. unfold inverse_lexicalEnumeration. change (f s0) with j; change (f s1) with (S O); change (f s2) with (n-j). set (f' := nil □ j □ n-j : stn 2 -> nat). assert (B' : stnsum f' = n). { unfold stnsum, f'; simpl. repeat unfold append_vec; simpl. rewrite natpluscomm. now apply minusplusnmm. } set (r' := weqfibtototal _ _ (λ k, eqweqmap (maponpaths (λ n, k < n : UU) B') ) : stn (stnsum f') ≃ stn n). set (x'' := x ∘ dni (j,, jlt) ∘ r'). intermediate_path (iterop_seq_mon (stnsum f',, x'') * x (j,, jlt)). { assert (L := iterop_seq_mon_len1 (λ j0 : stn 1, x' ((weqstnsum1 f) (s1,, j0)))). unfold functionToSequence in L. rewrite L. rewrite assocax. refine (transportf (λ k, _*k=_) (commax _ _ _) _). rewrite <- assocax. apply two_arg_paths. { refine (_ @ !associativityOfProducts' f' x''). unfold partition. rewrite 2 iterop_seq_seq_mon_step. change (iterop_seq_seq_mon (0,,_)) with (unel M); rewrite lunax. apply two_arg_paths. { unfold funcomp. set (s0' := dni lastelement (@lastelement 0)). unfold partition'. change (f' s0') with j. apply iterop_seq_mon_homot. intro i. unfold x', x'', funcomp. apply maponpaths. apply subtypePath_prop. change_lhs (stntonat _ i). unfold dni. unfold di. unfold stntonat. match goal with |- context [ match ?x with _ => _ end ] => induction x as [c|c] end. { reflexivity. } { apply fromempty. assert (P := c : i ≥ j); clear c. exact (natlthtonegnatgeh _ _ (stnlt i) P). } } { unfold partition'. change (f' lastelement) with (n-j). apply iterop_seq_mon_homot. intro i. unfold x', x'', funcomp. apply maponpaths. apply subtypePath_prop. change_lhs (j+1+i). unfold dni, di. unfold stntonat. match goal with |- context [ match ?x with _ => _ end ] => induction x as [c|c] end. { apply fromempty. exact (negnatlthplusnmn j i c). } { change_rhs (1 + (j + i)). rewrite <- natplusassoc. rewrite (natpluscomm j 1). reflexivity. } } } unfold x'; simpl. apply maponpaths. apply subtypePath_prop. change (j+0 = j). apply natplusr0. } { apply (maponpaths (λ k, k * _)). induction (!B'). change_rhs (iterop_seq_mon (n,, x ∘ dni (j,, jlt))). apply iterop_seq_mon_homot; intros i. unfold x''; simpl. apply maponpaths. apply ( invmaponpathsincl _ ( isinclstntonat _ ) _ _). reflexivity. } Qed. Theorem commutativityOfProducts {M:abmonoid} {n} (x:stn n->M) (f:stn n ≃ stn n) : iterop_seq_mon (n,,x) = iterop_seq_mon (n,,x∘f). Proof. (* this proof comes from Bourbaki, Algebra, § 1.5, Theorem 2, page 9 *) intros. induction n as [|n IH]. - reflexivity. - set (i := @lastelement n); set (i' := f i). rewrite (iterop_seq_mon_step (x ∘ f)). change ((x ∘ f) lastelement) with (x i'). rewrite (commutativityOfProducts_helper x i'). apply (maponpaths (λ k, k*_)). set (f' := weqoncompl_ne f i (stnneq i) (stnneq i') : stn_compl i ≃ stn_compl i'). set (g := weqdnicompl i); set (g' := weqdnicompl i'). apply pathsinv0. set (h := (invweq g' ∘ f' ∘ g)%weq). assert (L : x ∘ f ∘ dni lastelement ~ x ∘ dni i' ∘ h). { intro j. unfold funcomp. apply maponpaths. apply (invmaponpathsincl _ ( isinclstntonat _ ) _ _). unfold h. rewrite 2 weqcomp_to_funcomp_app. rewrite pr1_invweq. induction j as [j J]. unfold g, i, f', g', stntonat. rewrite <- (weqdnicompl_compute i'). unfold pr1compl_ne. rewrite homotweqinvweq. rewrite (weqoncompl_ne_compute f i (stnneq i) (stnneq i') _). apply maponpaths, maponpaths. apply subtypePath_prop. unfold stntonat. now rewrite weqdnicompl_compute. } rewrite (IH (x ∘ dni i') h). now apply iterop_seq_mon_homot. Defined. (** finite products (or sums) in monoids *) Require Export UniMath.Combinatorics.FiniteSets. Require Export UniMath.Foundations.NaturalNumbers. Section NatCard. (** first a toy warm-up with addition in nat, based on cardinalities of standard finite sets *) Theorem nat_plus_associativity {n} {m:stn n->nat} (k:∏ (ij : ∑ i, stn (m i)), nat) : stnsum (λ i, stnsum (curry k i)) = stnsum (k ∘ lexicalEnumeration m). Proof. intros. apply weqtoeqstn. intermediate_weq (∑ i, stn (stnsum (curry k i))). { apply invweq. apply weqstnsum1. } intermediate_weq (∑ i j, stn (curry k i j)). { apply weqfibtototal; intro i. apply invweq. apply weqstnsum1. } intermediate_weq (∑ ij, stn (k ij)). { exact (weqtotal2asstol (stn ∘ m) (stn ∘ k)). } intermediate_weq (∑ ij, stn (k (lexicalEnumeration m ij))). { apply (weqbandf (inverse_lexicalEnumeration m)). intro ij. apply eqweqmap. apply (maponpaths stn), (maponpaths k). apply pathsinv0, homotinvweqweq. } apply inverse_lexicalEnumeration. Defined. Corollary nat_plus_associativity' n (m:stn n->nat) (k:∏ i, stn (m i) -> nat) : stnsum (λ i, stnsum (k i)) = stnsum (uncurry (Z := λ _,_) k ∘ lexicalEnumeration m). Proof. intros. exact (nat_plus_associativity (uncurry k)). Defined. Lemma iterop_fun_nat {n:nat} (x:stn n->nat) : iterop_fun 0 add x = stnsum x. Proof. (* these are different because iterop_fun is careful to not add 0 in the case where n=1 *) intros. induction n as [|n I]. - reflexivity. - induction n as [|n _]. + reflexivity. + simple refine (iterop_fun_step 0 add natplusl0 _ @ _ @ ! stnsum_step _). apply (maponpaths (λ i, i + x lastelement)). apply I. Defined. Theorem associativityNat : isAssociative_fun 0 add. Proof. intros n m x. unfold iterop_fun_fun. apply pathsinv0. rewrite 2 iterop_fun_nat. intermediate_path (stnsum (λ i : stn n, stnsum (x i))). - apply maponpaths. apply funextfun; intro. apply iterop_fun_nat. - now apply nat_plus_associativity'. Defined. (* A shorter definition: *) Definition finsum' {X} (fin : isfinite X) (f : X -> nat) : nat. Proof. intros. exact (fincard (isfinitetotal2 (stn∘f) fin (λ i, isfinitestn (f i)))). Defined. (* exercise : show finsum = finsum' *) End NatCard. Definition MultipleOperation (X:UU) : UU := UnorderedSequence X -> X. Section Mult. Context {X:UU} (op : MultipleOperation X). Definition composeMultipleOperation : UnorderedSequence (UnorderedSequence X) -> X. Proof. intros s. exact (op (composeUnorderedSequence op s)). Defined. Definition isAssociativeMultipleOperation := ∏ x, op (flattenUnorderedSequence x) = composeMultipleOperation x. End Mult. Definition AssociativeMultipleOperation {X} := ∑ op:MultipleOperation X, isAssociativeMultipleOperation op. Definition iterop_unoseq_mon {M:abmonoid} : MultipleOperation M. (* iterate the monoid operation over an unordered finite sequence of elements of M *) Proof. intros m. induction m as [J m]. induction J as [I fin]. simpl in m. unfold isfinite, finstruct in fin. simple refine (squash_to_set (setproperty M) (λ (g : finstruct I), iterop_fun_mon (m ∘ g : _ -> M)) _ fin). intros. induction x as [n x]. induction x' as [n' x']. assert (p := weqtoeqstn (invweq x' ∘ x)%weq). induction p. assert (w := commutativityOfProducts (m ∘ x') (invweq x' ∘ x)%weq). simple refine (_ @ ! w); clear w. unfold iterop_seq_mon, iterop_fun_mon, iterop_seq. apply maponpaths. rewrite weqcomp_to_funcomp. apply funextfun; intro i. simpl. apply maponpaths. exact (! homotweqinvweq x' (x i)). Defined. Definition iterop_unoseq_abgr {G:abgr} : MultipleOperation G. Proof. exact (iterop_unoseq_mon (M:=G)). Defined. Definition sum_unoseq_ring {R:ring} : MultipleOperation R. Proof. exact (iterop_unoseq_mon (M:=R)). Defined. Definition product_unoseq_ring {R:commring} : MultipleOperation R. Proof. exact (iterop_unoseq_mon (M:=ringmultabmonoid R)). Defined. Definition iterop_unoseq_unoseq_mon {M:abmonoid} : UnorderedSequence (UnorderedSequence M) -> M. Proof. intros s. exact (composeMultipleOperation iterop_unoseq_mon s). Defined. Definition abmonoidMultipleOperation {M:abmonoid} (op := @iterop_unoseq_mon M) : MultipleOperation M := iterop_unoseq_mon. Theorem isAssociativeMultipleOperation_abmonoid {M:abmonoid} : isAssociativeMultipleOperation (@iterop_unoseq_mon M). Proof. Abort. UniMath-20231010/UniMath/Algebra/Matrix.v000066400000000000000000000241041451125700300176450ustar00rootroot00000000000000(** * Matrices Operations on vectors and matrices. Author: Langston Barrett (@siddharthist) (March 2018) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Combinatorics.FiniteSequences. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.Algebra.RigsAndRings. (** ** Contents - Vectors - Standard conditions on one binary operation - Standard conditions on a pair of binary operations - Structures - Matrices - Standard conditions on one binary operation - Structures - Matrix rig *) (** ** Vectors *) Definition pointwise {X : UU} (n : nat) (op : binop X) : binop (Vector X n) := λ v1 v2 i, op (v1 i) (v2 i). (** *** Standard conditions on one binary operation *) (** Most features of binary operations (associativity, unity, etc) carry over to pointwise operations. *) Section OneOp. Context {X : UU} {n : nat} {op : binop X}. Definition pointwise_assoc (assocax : isassoc op) : isassoc (pointwise n op). Proof. intros ? ? ?; apply funextfun; intro; apply assocax. Defined. Definition pointwise_lunit (lun : X) (lunax : islunit op lun) : islunit (pointwise n op) (const_vec lun). Proof. intros ?; apply funextfun; intro; apply lunax. Defined. Definition pointwise_runit (run : X) (runax : isrunit op run) : isrunit (pointwise n op) (const_vec run). Proof. intros ?; apply funextfun; intro; apply runax. Defined. Definition pointwise_unit (un : X) (unax : isunit op un) : isunit (pointwise n op) (const_vec un). Proof. use make_isunit. - apply pointwise_lunit; exact (pr1 unax). - apply pointwise_runit; exact (pr2 unax). Defined. Definition pointwise_comm (commax : iscomm op) : iscomm (pointwise n op). Proof. intros ? ?; apply funextfun; intro; apply commax. Defined. Definition pointwise_monoidop (monoidax : ismonoidop op) : ismonoidop (pointwise n op). Proof. use make_ismonoidop. - apply pointwise_assoc, assocax_is; assumption. - use make_isunital. + apply (const_vec (unel_is monoidax)). + apply pointwise_unit, unax_is. Defined. Definition pointwise_abmonoidop (abmonoidax : isabmonoidop op) : isabmonoidop (pointwise n op). Proof. use make_isabmonoidop. - apply pointwise_monoidop; exact (pr1isabmonoidop _ _ abmonoidax). - apply pointwise_comm; exact (pr2 abmonoidax). Defined. End OneOp. (** *** Standard conditions on a pair of binary operations *) Section TwoOps. Context {X : UU} {n : nat} {op : binop X} {op' : binop X}. Definition pointwise_ldistr (isldistrax : isldistr op op') : isldistr (pointwise n op) (pointwise n op'). Proof. intros ? ? ?; apply funextfun; intro; apply isldistrax. Defined. Definition pointwise_rdistr (isrdistrax : isrdistr op op') : isrdistr (pointwise n op) (pointwise n op'). Proof. intros ? ? ?; apply funextfun; intro; apply isrdistrax. Defined. Definition pointwise_distr (isdistrax : isdistr op op') : isdistr (pointwise n op) (pointwise n op'). Proof. use make_dirprod. - apply pointwise_ldistr; apply (dirprod_pr1 isdistrax). - apply pointwise_rdistr; apply (dirprod_pr2 isdistrax). Defined. End TwoOps. (** *** Structures *) Section Structures. Definition pointwise_hSet (X : hSet) (n : nat) : hSet. Proof. use make_hSet. - exact (Vector X n). - change isaset with (isofhlevel 2). apply vector_hlevel, setproperty. Defined. Definition pointwise_setwithbinop (X : setwithbinop) (n : nat) : setwithbinop. Proof. use make_setwithbinop. - apply pointwise_hSet; [exact X|assumption]. - exact (pointwise n op). Defined. Definition pointwise_setwith2binop (X : setwith2binop) (n : nat) : setwith2binop. Proof. use make_setwith2binop. - apply pointwise_hSet; [exact X|assumption]. - split. + exact (pointwise n op1). + exact (pointwise n op2). Defined. Definition pointwise_monoid (X : monoid) (n : nat) : monoid. Proof. use make_monoid. - apply pointwise_setwithbinop; [exact X|assumption]. - apply pointwise_monoidop; exact (pr2 X). Defined. Definition pointwise_abmonoid (X : abmonoid) (n : nat) : abmonoid. Proof. use make_abmonoid. - apply pointwise_setwithbinop; [exact X|assumption]. - apply pointwise_abmonoidop; exact (pr2 X). Defined. End Structures. (** ** Matrices *) Definition entrywise {X : UU} (n m : nat) (op : binop X) : binop (Matrix X n m) := λ mat1 mat2 i, pointwise _ op (mat1 i) (mat2 i). (** *** Standard conditions on one binary operation *) Section OneOpMat. Context {X : UU} {n m : nat} {op : binop X}. Definition entrywise_assoc (assocax : isassoc op) : isassoc (entrywise n m op). Proof. intros ? ? ?; apply funextfun; intro; apply pointwise_assoc, assocax. Defined. Definition entrywise_lunit (lun : X) (lunax : islunit op lun) : islunit (entrywise n m op) (const_matrix lun). Proof. intros ?; apply funextfun; intro; apply pointwise_lunit, lunax. Defined. Definition entrywise_runit (run : X) (runax : isrunit op run) : isrunit (entrywise n m op) (const_matrix run). Proof. intros ?; apply funextfun; intro; apply pointwise_runit, runax. Defined. Definition entrywise_unit (un : X) (unax : isunit op un) : isunit (entrywise n m op) (const_matrix un). Proof. use make_isunit. - apply entrywise_lunit; exact (pr1 unax). - apply entrywise_runit; exact (pr2 unax). Defined. Definition entrywise_comm (commax : iscomm op) : iscomm (entrywise n m op). Proof. intros ? ?; apply funextfun; intro; apply pointwise_comm, commax. Defined. Definition entrywise_monoidop (monoidax : ismonoidop op) : ismonoidop (entrywise n m op). Proof. use make_ismonoidop. - apply entrywise_assoc, assocax_is; assumption. - use make_isunital. + apply (const_matrix (unel_is monoidax)). + apply entrywise_unit, unax_is. Defined. Definition entrywise_abmonoidop (abmonoidax : isabmonoidop op) : isabmonoidop (entrywise n m op). Proof. use make_isabmonoidop. - apply entrywise_monoidop; exact (pr1isabmonoidop _ _ abmonoidax). - apply entrywise_comm; exact (pr2 abmonoidax). Defined. End OneOpMat. (** It is uncommon to consider two entrywise binary operations on matrices, so we don't derive "standard conditions on a pair of binar operations" for matrices. *) (** *** Structures *) (** *** Matrix rig *) Section MatrixMult. Context {R : rig}. (** Summation and pointwise multiplication *) Local Notation Σ := (iterop_fun rigunel1 op1). Local Notation "R1 ^ R2" := ((pointwise _ op2) R1 R2). (** If A is m × n (so B is n × p), << AB(i, j) = A(i, 1) * B(1, j) + A(i, 2) * B(2, j) + ⋯ + A(i, n) * B(n, j) >> The order of the arguments allows currying the first matrix. *) Definition matrix_mult {m n : nat} (mat1 : Matrix R m n) {p : nat} (mat2 : Matrix R n p) : (Matrix R m p) := λ i j, Σ ((row mat1 i) ^ (col mat2 j)). Local Notation "A ** B" := (matrix_mult A B) (at level 80). Lemma identity_matrix {n : nat} : (Matrix R n n). Proof. intros i j. induction (stn_eq_or_neq i j). - exact (rigunel2). (* The multiplicative identity *) - exact (rigunel1). (* The additive identity *) Defined. End MatrixMult. Local Notation Σ := (iterop_fun rigunel1 op1). Local Notation "R1 ^ R2" := ((pointwise _ op2) R1 R2). Local Notation "A ** B" := (matrix_mult A B) (at level 80). (** The following is based on "The magnitude of metric spaces" by Tom Leinster (arXiv:1012.5857v3). *) Section Weighting. Context {R : rig}. (** Definition 1.1.1 in arXiv:1012.5857v3 *) Definition weighting {m n : nat} (mat : Matrix R m n) : UU := ∑ vec : Vector R n, (mat ** (col_vec vec)) = col_vec (const_vec (1%rig)). Definition coweighting {m n : nat} (mat : Matrix R m n) : UU := ∑ vec : Vector R m, ((row_vec vec) ** mat) = row_vec (const_vec (1%rig)). Lemma matrix_mult_vectors {n : nat} (vec1 vec2 : Vector R n) : ((row_vec vec1) ** (col_vec vec2)) = weq_matrix_1_1 (Σ (vec1 ^ vec2)). Proof. apply funextfun; intro i; apply funextfun; intro j; reflexivity. Defined. (** Multiplying a column vector by the identity row vector is the same as taking the sum of its entries. *) Local Lemma sum_entries1 {n : nat} (vec : Vector R n) : weq_matrix_1_1 (Σ vec) = ((row_vec (const_vec (1%rig))) ** (col_vec vec)). Proof. refine (_ @ !matrix_mult_vectors _ _). do 2 apply maponpaths. apply pathsinv0. refine (pointwise_lunit 1%rig _ vec). apply riglunax2. Defined. Local Lemma sum_entries2 {n : nat} (vec : Vector R n) : weq_matrix_1_1 (Σ vec) = (row_vec vec ** col_vec (const_vec 1%rig)). Proof. refine (_ @ !matrix_mult_vectors _ _). do 2 apply maponpaths. apply pathsinv0. refine (pointwise_runit 1%rig _ vec). apply rigrunax2. Defined. (** TODO: prove this so that the below isn't hypothetical *) Definition matrix_mult_assoc_statement : UU := ∏ (m n : nat) (mat1 : Matrix R m n) (p : nat) (mat2 : Matrix R n p) (q : nat) (mat3 : Matrix R p q), ((mat1 ** mat2) ** mat3) = (mat1 ** (mat2 ** mat3)). (** Lemma 1.1.2 in arXiv:1012.5857v3 *) Lemma weighting_coweighting_sum {m n : nat} (mat : Matrix R m n) (wei : weighting mat) (cowei : coweighting mat) (assocax : matrix_mult_assoc_statement) : Σ (pr1 wei) = Σ (pr1 cowei). Proof. apply (invmaponpathsweq weq_matrix_1_1). intermediate_path ((row_vec (const_vec (1%rig))) ** (col_vec (pr1 wei))). - apply sum_entries1. - refine (!maponpaths (λ z, z ** _) (pr2 cowei) @ _). refine (assocax _ _ _ _ _ _ _ @ _). refine (maponpaths (λ z, _ ** z) (pr2 wei) @ _). apply pathsinv0, sum_entries2 . Defined. (** Definition 1.1.3 in arXiv:1012.5857v3 *) Definition has_magnitude {n m : nat} (mat : Matrix R m n) : UU := (weighting mat) × (coweighting mat). Definition magnitude {n m : nat} (m : Matrix R m n) (has : has_magnitude m) : R := Σ (pr1 (dirprod_pr1 has)). End Weighting. UniMath-20231010/UniMath/Algebra/Modules.v000066400000000000000000000000541451125700300200070ustar00rootroot00000000000000Require Export UniMath.Algebra.Modules.Core.UniMath-20231010/UniMath/Algebra/Modules/000077500000000000000000000000001451125700300176215ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/Modules/Core.v000066400000000000000000000654251451125700300207140ustar00rootroot00000000000000(** Authors Anthony Bordg and Floris van Doorn, February-December 2017 *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Monoids. (** ** Contents - The ring of endomorphisms of an abelian group - Modules (the definition of the small type of R-modules over a ring R) - R-module morphisms - Linearity - [modulefun] - R-module homomorphisms form an R-module - Isomorphisms ([moduleiso]) *) Local Open Scope addmonoid_scope. Import UniMath.Algebra.Monoids.AddNotation. (** ** The ring of endomorphisms of an abelian group *) (** Two binary operations on the set of endomorphisms of an abelian group *) Definition monoidfun_to_isbinopfun {G : abgr} (f : monoidfun G G) : isbinopfun f := pr1 (pr2 f). Definition ringofendabgr_op1 {G: abgr} : binop (monoidfun G G). Proof. intros f g. apply (@monoidfunconstr _ _ (λ x : G, f x + g x)). apply tpair. - intros x x'. rewrite (monoidfun_to_isbinopfun f). rewrite (monoidfun_to_isbinopfun g). apply (abmonoidrer G). - rewrite (monoidfununel f). rewrite (monoidfununel g). rewrite (lunax G). reflexivity. Defined. Definition ringofendabgr_op2 {G : abgr} : binop (monoidfun G G). Proof. intros f g. apply (monoidfuncomp g f). Defined. Declare Scope abgr_scope. Notation "f + g" := (ringofendabgr_op1 f g) : abgr_scope. (** The underlying set of the ring of endomorphisms of an abelian group *) Definition setofendabgr (G : abgr) : hSet := make_hSet (monoidfun G G) (isasetmonoidfun G G). (** A few access functions *) Definition pr1setofendabgr {G : abgr} (f : setofendabgr G) : G -> G := pr1 f. Definition pr2setofendabgr {G : abgr} (f : setofendabgr G) : ismonoidfun (pr1 f) := pr2 f. Definition setofendabgr_to_isbinopfun {G : abgr} (f : setofendabgr G) : isbinopfun (pr1setofendabgr f) := pr1 (pr2 f). Definition setofendabgr_to_unel {G : abgr} (f : setofendabgr G) : pr1setofendabgr f 0 = 0 := pr2 (pr2setofendabgr f). (** We endow setofendabgr with the two binary operations defined above *) Definition setwith2binopofendabgr (G : abgr) : setwith2binop := make_setwith2binop (setofendabgr G) (make_dirprod (ringofendabgr_op1) (ringofendabgr_op2)). (** ringofendabgr_op1 G and ringofendabgr_op2 G are ring operations *) (** ringofendabgr_op1 is a monoid operation *) Local Open Scope abgr_scope. Lemma isassoc_ringofendabgr_op1 {G : abgr} : isassoc (@ringofendabgr_op1 G). Proof. intros f g h. use total2_paths_f. - apply funextfun. intro. apply (pr2 G). - apply isapropismonoidfun. Defined. Lemma setofendabgr_un0 {G: abgr} : monoidfun G G. Proof. apply (@monoidfunconstr _ _ (λ x : G, 0)). apply make_dirprod. - intros x x'. rewrite (lunax G). reflexivity. - reflexivity. Defined. Lemma islunit_setofendabgr_un0 {G : abgr} : islunit (@ringofendabgr_op1 G) setofendabgr_un0. Proof. intro f. use total2_paths_f. - apply funextfun. intro x. apply (lunax G (pr1setofendabgr f x)). - apply isapropismonoidfun. Defined. Lemma isrunit_setofendabgr_un0 {G : abgr} : isrunit (@ringofendabgr_op1 G) setofendabgr_un0. Proof. intros f. use total2_paths_f. - apply funextfun. intro x. apply (runax G (pr1setofendabgr f x)). - apply isapropismonoidfun. Defined. Lemma isunit_setofendabgr_un0 {G : abgr} : isunit (@ringofendabgr_op1 G) setofendabgr_un0. Proof. exact (make_isunit islunit_setofendabgr_un0 isrunit_setofendabgr_un0). Defined. Lemma isunital_ringofendabgr_op1 {G : abgr} : isunital (@ringofendabgr_op1 G). Proof. exact (make_isunital setofendabgr_un0 isunit_setofendabgr_un0). Defined. Lemma ismonoidop_ringofendabgr_op1 {G : abgr} : ismonoidop (@ringofendabgr_op1 G). Proof. exact (make_ismonoidop isassoc_ringofendabgr_op1 isunital_ringofendabgr_op1). Defined. Local Close Scope abgr_scope. (** ringofendabgr_op1 is a group operation *) Definition setofendabgr_inv {G : abgr} : monoidfun G G -> monoidfun G G. Proof. intro f. apply (@monoidfunconstr G G (λ x : G, grinv G (pr1setofendabgr f x))). apply make_dirprod. - intros x x'. rewrite (setofendabgr_to_isbinopfun f). rewrite (grinvop G). apply (commax G). - rewrite (setofendabgr_to_unel f). apply (grinvunel G). Defined. Local Open Scope abgr_scope. Lemma islinv_setofendabgr_inv {G : abgr} : islinv (@ringofendabgr_op1 G) (unel_is (@ismonoidop_ringofendabgr_op1 G)) setofendabgr_inv. Proof. intro f. use total2_paths_f. - apply funextfun. intro x. apply (grlinvax G). - apply isapropismonoidfun. Defined. Lemma isrinv_setofendabgr_inv {G : abgr} : isrinv (@ringofendabgr_op1 G) (unel_is (@ismonoidop_ringofendabgr_op1 G)) setofendabgr_inv. Proof. intro f. use total2_paths_f. - apply funextfun. intro x. apply (grrinvax G). - apply isapropismonoidfun. Defined. Lemma isinv_setofendabgr_inv {G : abgr} : isinv (@ringofendabgr_op1 G) (unel_is (@ismonoidop_ringofendabgr_op1 G)) setofendabgr_inv. Proof. exact (make_isinv islinv_setofendabgr_inv isrinv_setofendabgr_inv). Defined. Definition invstruct_setofendabgr_inv {G : abgr} : invstruct (@ringofendabgr_op1 G) ismonoidop_ringofendabgr_op1. Proof. exact (make_invstruct (@setofendabgr_inv G) (@isinv_setofendabgr_inv G)). Defined. Lemma isgrop_ringofendabgr_op1 {G : abgr} : isgrop (@ringofendabgr_op1 G). Proof. exact (make_isgrop ismonoidop_ringofendabgr_op1 invstruct_setofendabgr_inv). Defined. Lemma iscomm_ringofendabgr_op1 {G : abgr} : iscomm (@ringofendabgr_op1 G). Proof. intros f g. use total2_paths_f. - apply funextfun. intro x. apply (commax G). - apply (isapropismonoidfun). Defined. Lemma isabgrop_ringofendabgr_op1 {G : abgr} : isabgrop (@ringofendabgr_op1 G). Proof. exact (make_isabgrop isgrop_ringofendabgr_op1 iscomm_ringofendabgr_op1). Defined. (** ringofendabgr_op2 is a monoid operation *) Lemma isassoc_ringofendabgr_op2 {G : abgr} : isassoc (@ringofendabgr_op2 G). Proof. intros f g h. use total2_paths_f. - apply funcomp_assoc. - apply isapropismonoidfun. Defined. Definition setofendabgr_un1 {G: abgr} : monoidfun G G. Proof. apply (@monoidfunconstr _ _ (idfun G)). apply make_dirprod. - intros x x'. reflexivity. - reflexivity. Defined. Lemma islunit_setofendabgr_un1 {G : abgr} : islunit (@ringofendabgr_op2 G) setofendabgr_un1. Proof. intro f. use total2_paths_f. - apply funextfun. intro x. reflexivity. - apply isapropismonoidfun. Defined. Lemma isrunit_setofendabgr_un1 {G : abgr} : isrunit (@ringofendabgr_op2 G) setofendabgr_un1. Proof. intros f. use total2_paths_f. - apply funextfun. intro x. reflexivity. - apply isapropismonoidfun. Defined. Lemma isunit_setofendabgr_un1 {G : abgr} : isunit (@ringofendabgr_op2 G) setofendabgr_un1. Proof. exact (make_isunit islunit_setofendabgr_un1 isrunit_setofendabgr_un1). Defined. Lemma isunital_ringofendabgr_op2 {G : abgr} : isunital (@ringofendabgr_op2 G). Proof. exact (make_isunital setofendabgr_un1 isunit_setofendabgr_un1). Defined. Lemma ismonoidop_ringofendabgr_op2 {G : abgr} : ismonoidop (@ringofendabgr_op2 G). Proof. exact (make_ismonoidop isassoc_ringofendabgr_op2 isunital_ringofendabgr_op2). Defined. (** ringofendabgr_op2 is distributive over ringofendabgr_op1 *) Lemma isldistr_setofendabgr_op {G : abgr} : isldistr (@ringofendabgr_op1 G) (@ringofendabgr_op2 G). Proof. intros f g h. use total2_paths_f. - apply funextfun. intro x. apply (setofendabgr_to_isbinopfun h). - apply isapropismonoidfun. Defined. Lemma isrdistr_setofendabgr_op {G : abgr} : isrdistr (@ringofendabgr_op1 G) (@ringofendabgr_op2 G). Proof. intros f g h. use total2_paths_f. - apply funextfun. intro x. reflexivity. - apply isapropismonoidfun. Defined. Lemma isdistr_setofendabgr_op {G : abgr} : isdistr (@ringofendabgr_op1 G) (@ringofendabgr_op2 G). Proof. exact (make_dirprod isldistr_setofendabgr_op isrdistr_setofendabgr_op). Defined. Lemma isringops_setofendabgr_op {G : abgr} : isringops (@ringofendabgr_op1 G) (@ringofendabgr_op2 G). Proof. exact (make_isringops isabgrop_ringofendabgr_op1 ismonoidop_ringofendabgr_op2 isdistr_setofendabgr_op). Defined. (** The set of endomorphisms of an abelian group is a ring *) Definition ringofendabgr (G : abgr) : ring := @make_ring (setwith2binopofendabgr G) (@isringops_setofendabgr_op G). (** ** Modules: the definition of the small type of R-modules over a ring R *) (** A module over R may be defined as a ring homomorphism from R to the ring of endomorphisms of an Abelian group (in other words, a ring action on the abelian group). An equivalence with the more common axiomatic definition is established below. In this development, we concern ourselves with left modules. Recall that a right module is equivalent to a left module over the opposite ring. *) Definition module_struct (R : ring) (G : abgr) : UU := ringfun R (ringofendabgr G). Definition module (R : ring) : UU := ∑ G, module_struct R G. Definition pr1module {R : ring} (M : module R) : abgr := pr1 M. Coercion pr1module : module >-> abgr. Definition pr2module {R : ring} (M : module R) : module_struct R (pr1module M) := pr2 M. Identity Coercion id_module_struct : module_struct >-> ringfun. Definition make_module {R : ring} (G : abgr) (f : module_struct R G) : module R := tpair _ G f. Lemma isasetmodule {R : ring} (M : module R) : isaset M. Proof. exact (pr2 (pr1 (pr1 (pr1 M)))). Defined. (** The ring action gives rise to a notion of multiplication. *) Definition module_mult {R : ring} (M : module R) : R -> M -> M := λ r : R, λ x : M, (pr1setofendabgr (pr2module M r) x). Declare Scope module_scope. Notation "r * x" := (module_mult _ r x) : module_scope. Delimit Scope module_scope with module. Local Open Scope module. Lemma module_mult_0_to_0 {R : ring} {M : module R} (x : M) : ringunel1 * x = @unel M. Proof. unfold module_mult. cbn. assert (pr2module M ringunel1 = @ringunel1 (ringofendabgr M)). - exact (rigfun_to_unel_rigaddmonoid (pr2module M)). - rewrite X. reflexivity. Defined. Local Open Scope addmonoid. Lemma module_mult_is_ldistr {R : ring} {M : module R} (r : R) (x y : M) : r * (x + y) = r * x + r * y. Proof. exact (pr1 (pr2 (pr2module M r)) x y). Defined. Lemma module_mult_is_rdistr {R : ring} {M : module R} (r s : R) (x : M) : (op1 r s) * x = r * x + s * x. Proof. exact (maponpaths (λ r, pr1setofendabgr r x) (pr1 (pr1 (pr2 (pr2module M))) r s)). Defined. Lemma module_mult_assoc {R : ring} {M : module R} (r s : R) (x : M) : (op2 r s) * x = r * (s * x). Proof. exact (maponpaths (λ r, pr1setofendabgr r x) (pr1 (pr2 (pr2 (pr2module M))) r s)). Defined. Lemma module_mult_1 {R : ring} {M : module R} (r : R) : r * unel M = unel M. Proof. exact (pr2 (pr2 (pr2module M r))). Defined. Lemma module_mult_unel2 {R : ring} {M : module R} (m : M) : ringunel2 * m = m. Proof. exact (maponpaths (λ r, pr1setofendabgr r m) (pr2 (pr2 (pr2 (pr2module M))))). Defined. Lemma module_inv_mult {R : ring} {M : module R} (r : R) (x : M) : @grinv _ (r * x) = r * @grinv _ x. Proof. apply grinv_path_from_op_path. now rewrite <- module_mult_is_ldistr, grrinvax, module_mult_1. Defined. Lemma module_mult_neg1 {R : ring} {M : module R} (x : M) : ringminus1 * x = @grinv _ x. Proof. apply pathsinv0. apply grinv_path_from_op_path. refine (maponpaths (λ y, y * ((_ * x)%module))%multmonoid (!(module_mult_unel2 x)) @ _). now rewrite <- module_mult_is_rdistr, ringrinvax1, module_mult_0_to_0. Defined. Lemma module_inv_mult_to_inv1 {R : ring} {M : module R} (r : R) (x : M) : @grinv _ (r * x) = ringinv1 r * x. Proof. apply grinv_path_from_op_path. now rewrite <- module_mult_is_rdistr, ringrinvax1, module_mult_0_to_0. Defined. Lemma module_mult_inv_to_inv1 {R : ring} {M : module R} (r : R) (x : M) : r * @grinv _ x = ringinv1 r * x. Proof. now rewrite <- module_inv_mult_to_inv1, module_inv_mult. Defined. (** To construct a module from a left action satisfying four axioms *) Definition mult_isldistr_wrt_grop {R : ring} {G : abgr} (m : R -> G -> G) : UU := ∏ r : R, ∏ x y : G, m r (x + y) = (m r x) + (m r y). Definition mult_isrdistr_wrt_ringop1 {R : ring} {G : abgr} (m : R -> G -> G) : UU := ∏ r s : R, ∏ x : G, m (op1 r s) x = (m r x) + (m s x). Definition mult_isrdistr_wrt_ringop2 {R : ring} {G : abgr} (m : R -> G -> G) : UU := ∏ r s : R, ∏ x : G, m (op2 r s) x = m r (m s x). Definition mult_unel {R : ring} {G : abgr} (m : R -> G -> G) : UU := ∏ x : G, m ringunel2 x = x. Local Close Scope addmonoid. Definition mult_to_ringofendabgr {R : ring} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (r : R) : ringofendabgr G. Proof. use monoidfunconstr. intro x. exact (m r x). apply make_dirprod. + intros x y. apply ax1. + apply (grlcan G (m r (unel G))). rewrite runax. rewrite <- (ax1 r (unel G) (unel G)). rewrite runax. apply idpath. Defined. Definition mult_to_module_struct {R : ring} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (ax2 : mult_isrdistr_wrt_ringop1 m) (ax3 : mult_isrdistr_wrt_ringop2 m) (ax4 : mult_unel m) : module_struct R G. Proof. split with (λ r : R, mult_to_ringofendabgr ax1 r). apply make_dirprod. - apply make_dirprod. + intros r s. use total2_paths2_f. * apply funextfun. intro x. apply ax2. * apply isapropismonoidfun. + use total2_paths2_f. * apply funextfun. intro x. change (m ringunel1 x = unel G). apply (grlcan G (m (ringunel1) x)). rewrite runax. rewrite <- (ax2 ringunel1 ringunel1 x). rewrite ringrunax1. apply idpath. * apply isapropismonoidfun. - apply make_dirprod. + intros r s. use total2_paths2_f. * apply funextfun. intro x. apply ax3. * apply isapropismonoidfun. + use total2_paths2_f. * apply funextfun. intro x. apply ax4. * apply isapropismonoidfun. Defined. Definition mult_to_module {R : ring} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (ax2 : mult_isrdistr_wrt_ringop1 m) (ax3 : mult_isrdistr_wrt_ringop2 m) (ax4 : mult_unel m) : module R := make_module G (mult_to_module_struct ax1 ax2 ax3 ax4). (** *** R-module morphisms *) (** **** Linearity *) Definition islinear {R : ring} {M N : module R} (f : M -> N) := ∏ r : R, ∏ x : M, f (r * x) = r * (f x). Definition linearfun {R : ring} (M N : module R) : UU := ∑ f : M -> N, islinear f. Definition make_linearfun {R : ring} {M N : module R} (f : M -> N) (is : islinear f) : linearfun M N := tpair _ f is. Definition pr1linearfun {R : ring} {M N : module R} (f : linearfun M N) : M -> N := pr1 f. Coercion pr1linearfun : linearfun >-> Funclass. Definition linearfun_islinear {R} {M N : module R} (f : linearfun M N) : islinear f := pr2 f. Lemma islinearfuncomp {R : ring} {M N P : module R} (f : linearfun M N) (g : linearfun N P) : islinear (funcomp f g). Proof. intros r x; simpl. rewrite (linearfun_islinear f). rewrite (linearfun_islinear g). apply idpath. Defined. Definition linearfuncomp {R : ring} {M N P : module R} (f : linearfun M N) (g : linearfun N P) : linearfun M P := tpair _ (funcomp f g) (islinearfuncomp f g). Lemma isapropislinear {R : ring} {M N : module R} (f : M -> N) : isaprop (islinear f). Proof. apply (impred 1 _). intro r. apply (impred 1 _). intro x. apply (setproperty N). Defined. (** The type of linear functions M -> N is a set. *) Lemma isasetlinearfun {R : ring} (M N : module R) : isaset (linearfun M N). Proof. intros. apply (isasetsubset (@pr1linearfun R M N)). - change (isofhlevel 2 (M -> N)). apply impred. exact (fun x => setproperty N). - refine (isinclpr1 _ _). intro. apply isapropislinear. Defined. (** **** [modulefun] *) Definition ismodulefun {R : ring} {M N : module R} (f : M -> N) : UU := (isbinopfun f) × (islinear f). Definition make_ismodulefun {R : ring} {M N : module R} {f : M -> N} (H1 : isbinopfun f) (H2 : islinear f) : ismodulefun f := tpair _ H1 H2. Lemma isapropismodulefun {R : ring} {M N : module R} (f : M -> N) : isaprop (ismodulefun f). Proof. exact (@isofhleveldirprod 1 (isbinopfun f) (islinear f) (isapropisbinopfun f) (isapropislinear f)). Defined. Definition modulefun {R : ring} (M N : module R) : UU := ∑ f : M -> N, ismodulefun f. Definition make_modulefun {R : ring} {M N : module R} (f : M -> N) (is : ismodulefun f) : modulefun M N := tpair _ f is. Local Notation "R-mod( M , N )" := (modulefun M N) : module_scope. Section accessors. Context {R : ring} {M N : module R} (f : R-mod(M, N)). Definition pr1modulefun : M -> N := pr1 f. Definition modulefun_ismodulefun : ismodulefun pr1modulefun := pr2 f. Definition modulefun_to_isbinopfun : isbinopfun pr1modulefun := pr1 modulefun_ismodulefun. Definition modulefun_to_binopfun : binopfun M N := make_binopfun pr1modulefun modulefun_to_isbinopfun. Definition modulefun_to_islinear : islinear pr1modulefun := pr2 modulefun_ismodulefun. Definition modulefun_to_linearfun : linearfun M N := make_linearfun pr1modulefun modulefun_to_islinear. End accessors. Coercion pr1modulefun : modulefun >-> Funclass. Lemma ismodulefun_comp {R} {M N P : module R} (f : R-mod(M,N)) (g : R-mod(N,P)) : ismodulefun (g ∘ f)%functions. Proof. exact (make_dirprod (isbinopfuncomp (modulefun_to_binopfun f) (modulefun_to_binopfun g)) (islinearfuncomp (modulefun_to_linearfun f) (modulefun_to_linearfun g))). Defined. Definition modulefun_comp {R} {M N P : module R} (f : R-mod(M, N)) (g : R-mod(N,P)) : R-mod(M,P) := (funcomp f g,, ismodulefun_comp f g). Lemma modulefun_unel {R : ring} {M N : module R} (f : R-mod(M, N)) : f (unel M) = unel N. Proof. rewrite <- (module_mult_0_to_0 (unel M)). rewrite ((modulefun_to_islinear f) ringunel1 (unel M)). rewrite (module_mult_0_to_0 _). reflexivity. Defined. Definition moduletomonoid {R : ring} (M : module R) : abmonoid := abgrtoabmonoid (pr1module M). Definition modulefun_to_monoidfun {R : ring} {M N : module R} (f : R-mod(M, N)) : monoidfun (moduletomonoid M) (moduletomonoid N) := tpair _ (pr1 f) (tpair _ (pr1 (pr2 f)) (modulefun_unel f)). Definition modulefun_from_monoidfun {R : ring} {M N : module R} (f : R-mod(M, N)) (H : islinear (pr1 f)) : R-mod(M, N) := make_modulefun (pr1 f) (make_ismodulefun (pr1 (pr2 f)) H). Lemma modulefun_paths {R : ring} {M N : module R} {f g : R-mod(M, N)} (p : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact p. - use proofirrelevance. use isapropismodulefun. Defined. Lemma modulefun_paths2 {R : ring} {M N : module R} {f g : modulefun M N} (p : pr1 f ~ pr1 g) : f = g. Proof. exact (modulefun_paths (funextfun _ _ p)). Defined. Lemma isasetmodulefun {R : ring} (M N : module R) : isaset (R-mod(M, N)). Proof. intros. apply (isasetsubset (@pr1modulefun R M N)). - change (isofhlevel 2 (M -> N)). apply impred. intro. apply (setproperty N). - refine (isinclpr1 _ _). intro. apply isapropismodulefun. Defined. (* module structure of morphisms between modules *) Lemma modulehombinop_ismodulefun {R : ring} {M N : module R} (f g : R-mod(M, N)) : @ismodulefun R M N (λ x : pr1 M, (pr1 f x * pr1 g x)%multmonoid). Proof. use make_ismodulefun. - exact (pr1 (abmonoidshombinop_ismonoidfun (modulefun_to_monoidfun f) (modulefun_to_monoidfun g))). - intros r m. rewrite (modulefun_to_islinear f). rewrite (modulefun_to_islinear g). rewrite <- module_mult_is_ldistr. reflexivity. Defined. Definition modulehombinop {R : ring} {M N : module R} : binop (R-mod(M, N)) := (λ f g, make_modulefun _ (modulehombinop_ismodulefun f g)). Lemma unelmodulefun_ismodulefun {R : ring} (M N : module R) : ismodulefun (λ x : M, (unel N)). Proof. use make_ismodulefun. - use make_isbinopfun. intros m m'. use pathsinv0. use lunax. - intros r m. rewrite module_mult_1. reflexivity. Qed. Definition unelmodulefun {R : ring} (M N : module R) : R-mod(M, N) := make_modulefun _ (unelmodulefun_ismodulefun M N). Lemma modulebinop_runax {R : ring} {M N : module R} (f : R-mod(M, N)) : modulehombinop f (unelmodulefun M N) = f. Proof. use modulefun_paths2. intros x. use (runax N). Qed. Lemma modulebinop_lunax {R : ring} {M N : module R} (f : R-mod(M, N)) : modulehombinop (unelmodulefun M N) f = f. Proof. use modulefun_paths2. intros x. use (lunax N). Qed. Lemma modulehombinop_assoc {R : ring} {M N : module R} (f g h : R-mod(M, N)) : modulehombinop (modulehombinop f g) h = modulehombinop f (modulehombinop g h). Proof. use modulefun_paths2. intros x. use assocax. Qed. Lemma modulehombinop_comm {R : ring} {M N : module R} (f g : R-mod(M, N)) : modulehombinop f g = modulehombinop g f. Proof. use modulefun_paths2. intros x. use (commax N). Qed. Lemma modulehomabmodule_ismoduleop {R : ring} {M N : module R} : ismonoidop (λ f g : R-mod(M, N), modulehombinop f g). Proof. use make_ismonoidop. - intros f g h. exact (modulehombinop_assoc f g h). - use make_isunital. + exact (unelmodulefun M N). + use make_isunit. * intros f. exact (modulebinop_lunax f). * intros f. exact (modulebinop_runax f). Defined. Lemma modulehombinop_inv_ismodulefun {R : ring} {M N : module R} (f : R-mod(M, N)) : ismodulefun (λ m : M, grinv N (pr1 f m)). Proof. use tpair. - use make_isbinopfun. intros x x'. cbn. rewrite (pr1 (pr2 f)). rewrite (pr2 (pr2 (pr1module N))). use (grinvop N). - intros r m. rewrite <- module_inv_mult. apply maponpaths. apply (pr2 f). Qed. Definition modulehombinop_inv {R : ring} {M N : module R} (f : R-mod(M, N)) : R-mod(M, N) := tpair _ _ (modulehombinop_inv_ismodulefun f). Lemma modulehombinop_linvax {R : ring} {M N : module R} (f : R-mod(M, N)) : modulehombinop (modulehombinop_inv f) f = unelmodulefun M N. Proof. use modulefun_paths2. intros x. use (@grlinvax N). Qed. Lemma modulehombinop_rinvax {R : ring} {M N : module R} (f : R-mod(M, N)) : modulehombinop f (modulehombinop_inv f) = unelmodulefun M N. Proof. use modulefun_paths2. intros x. use (grrinvax N). Qed. Lemma modulehomabgr_isabgrop {R : ring} (M N : module R) : isabgrop (λ f g : R-mod(M, N), modulehombinop f g). Proof. use make_isabgrop. use make_isgrop. - use modulehomabmodule_ismoduleop. - use make_invstruct. + intros f. exact (modulehombinop_inv f). + use make_isinv. * intros f. exact (modulehombinop_linvax f). * intros f. exact (modulehombinop_rinvax f). - intros f g. exact (modulehombinop_comm f g). Defined. Definition modulehomabgr {R : ring} (M N : module R) : abgr. Proof. use make_abgr. use make_setwithbinop. use make_hSet. - exact (R-mod(M, N)). - exact (isasetmodulefun M N). - exact (@modulehombinop R M N). - exact (modulehomabgr_isabgrop M N). Defined. Definition modulehombinop_scalar_ismodulefun {R : commring} {M N : module R} (r : R) (f : R-mod(M, N)) : ismodulefun (λ m : M, r * (pr1 f m)). Proof. use tpair. - use make_isbinopfun. intros x x'. cbn. rewrite (pr1 (pr2 f)). rewrite module_mult_is_ldistr. reflexivity. - intros r0 m. rewrite (modulefun_to_islinear f). do 2 rewrite <- module_mult_assoc. rewrite ringcomm2. reflexivity. Qed. Definition modulehombinop_smul {R : commring} {M N : module R} (r : R) (f : R-mod(M, N)) : modulefun M N := make_modulefun _ (modulehombinop_scalar_ismodulefun r f). Definition modulehommodule {R : commring} (M N : module R) : module R. Proof. use make_module. use (modulehomabgr M N). use mult_to_module_struct. exact modulehombinop_smul. - intros r f g. use modulefun_paths2. intros x. apply module_mult_is_ldistr. - intros r r0 f. use modulefun_paths2. intros x. apply module_mult_is_rdistr. - intros r r0 f. use modulefun_paths2. intros x. apply module_mult_assoc. - intros f. use modulefun_paths2. intros x. cbn. apply module_mult_unel2. Defined. (** **** Isomorphisms ([moduleiso]) *) Definition moduleiso {R : ring} (M N : module R) : UU := ∑ w : pr1module M ≃ pr1module N, ismodulefun w. Section accessors_moduleiso. Context {R : ring} {M N : module R} (f : moduleiso M N). Definition moduleiso_to_weq : (pr1module M) ≃ (pr1module N) := pr1 f. Definition moduleiso_ismodulefun : ismodulefun moduleiso_to_weq := pr2 f. Definition moduleiso_to_modulefun : R-mod(M, N) := (tpair _ (pr1weq moduleiso_to_weq) (pr2 f)). End accessors_moduleiso. Coercion moduleiso_to_weq : moduleiso >-> weq. Coercion moduleiso_to_modulefun : moduleiso >-> modulefun. Definition make_moduleiso {R} {M N : module R} f is : moduleiso M N := tpair _ f is. Lemma isbinopfuninvmap {R} {M N : module R} (f : moduleiso M N) : isbinopfun (invmap f). Proof. intros x y. apply (invmaponpathsweq f). rewrite (homotweqinvweq f (op x y)). apply pathsinv0. transitivity (op ((moduleiso_to_weq f) (invmap f x)) ((moduleiso_to_weq f) (invmap f y))). apply (modulefun_to_isbinopfun f (invmap f x) (invmap f y)). rewrite 2 (homotweqinvweq f). apply idpath. Defined. Lemma islinearinvmap {R} {M N : module R} (f : moduleiso M N) : islinear (invmap f). Proof. intros r x. apply (invmaponpathsweq f). transitivity (module_mult N r x). exact (homotweqinvweq f (module_mult N r x)). transitivity (module_mult N r (moduleiso_to_weq f (invmap (moduleiso_to_weq f) x))). rewrite (homotweqinvweq (moduleiso_to_weq f) x). apply idpath. apply pathsinv0. apply (pr2 (moduleiso_ismodulefun f) r (invmap f x)). Defined. Definition invmoduleiso {R} {M N : module R} (f : moduleiso M N) : moduleiso N M. Proof. use make_moduleiso. - exact (invweq f). - apply make_dirprod. + exact (isbinopfuninvmap f). + exact (islinearinvmap f). Defined. Definition moduleiso' {R} (M N : module R) : UU := ∑ w : monoidiso (pr1module M) (pr1module N), islinear w. Lemma moduleiso_to_moduleiso' {R} (M N : module R) : moduleiso M N -> moduleiso' M N. Proof. intro w. use tpair. - use tpair. + exact w. + use tpair. * exact (modulefun_to_isbinopfun w). * apply (modulefun_unel w). - exact (modulefun_to_islinear w). Defined. Lemma moduleiso'_to_moduleiso {R} (M N : module R) : moduleiso' M N -> moduleiso M N. Proof. intro w. use tpair. - exact (pr1 w). - apply make_dirprod. + exact (pr1 (pr2 (pr1 w))). + exact (pr2 w). Defined. Lemma moduleiso'_to_moduleisweq_iso {R} (M N : module R) : isweq (moduleiso'_to_moduleiso M N). Proof. use (isweq_iso _ (moduleiso_to_moduleiso' M N)). - intro w. unfold moduleiso'_to_moduleiso, moduleiso_to_moduleiso'. cbn. induction w as [w1 w2]; cbn. use total2_paths_f; cbn. * use total2_paths_f; cbn. + reflexivity. + apply isapropismonoidfun. * apply isapropislinear. - reflexivity. Defined. Definition moduleiso'_to_moduleweq_iso {R} (M N : module R) : (moduleiso' M N) ≃ (moduleiso M N) := make_weq (moduleiso'_to_moduleiso M N) (moduleiso'_to_moduleisweq_iso M N). UniMath-20231010/UniMath/Algebra/Modules/Examples.v000066400000000000000000000127571451125700300216020ustar00rootroot00000000000000(** Authors Langston Barrett (@siddharthist), November-December 2017 *) Require Import UniMath.Algebra.Modules.Core. Require Import UniMath.Algebra.Modules.Multimodules. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Tactics. (** ** Contents - Morphisms - (Multi)modules - Bimodules *) (** ** Morphisms *) Local Open Scope ring_scope. (** The identity function is linear *) Definition idfun_linear {R : ring} (M : module R) : islinear (idfun M). Proof. easy. Defined. (** The identity function is multilinear *) Definition idfun_multilinear {I : UU} {rings : I -> ring} (MM : multimodule rings) : @ismultilinear I rings MM MM (idfun MM) := (fun i => idfun_linear (ith_module MM i)). (** The identity function is a morphism of modules *) Definition id_modulefun {R : ring} (M : module R) : ismodulefun (idfun M). Proof. easy. Defined. (** The identity function is a morphism of modules *) Definition idmoduleiso {R : ring} (M : module R) : moduleiso M M. Proof. use make_moduleiso. - exact (idweq (pr1module M)). - apply make_dirprod. + intros x y. apply idpath. + intros r x. apply idpath. Defined. (** The identity function is a multimodule morphism *) Definition id_multimodulefun {I : UU} {rings : I -> ring} (MM : multimodule rings) : @ismultimodulefun I rings MM MM (idfun MM) := (make_dirprod (λ x y : MM, idpath _) (fun i => idfun_linear (ith_module MM i))). (** ** (Multi)modules *) (** The left action of a ring through a ring homomorphism See Bourbaki's Algebra, II §1.4, no. 1, Example 1. *) Definition ringfun_left_mult {R S : ring} (f : ringfun R S) (r : R) : ringofendabgr S. Proof. refine (* This is the actual definition of the function *) ((λ x : S, (f r * x)),, (* And this is the justification that it's a monoid morphism *) (λ _ _, _),, _). apply (rigldistr S _ _ _). apply (rigmultx0 S). Defined. (** An important special case: the left action of a ring on itself *) Example ring_left_mult {R : ring} : R -> ringofendabgr R := ringfun_left_mult (rigisotorigfun (idrigiso R)). (** A ring morphism R -> S defines an R-module structure on the additive abelian group of S *) Definition ringfun_module {R S : ring} (f : ringfun R S) : module R. refine (@ringaddabgr S,, _). apply (@mult_to_module_struct R S (pr1 ∘ ringfun_left_mult f)%functions); unfold funcomp, pr1, ringfun_left_mult. - exact (fun r x y => ringldistr S x y (f r)). - exact (fun r s x => (maponpaths (λ x, x * _) ((pr1 (pr1 (pr2 f))) r s)) @ (ringrdistr _ (f r) (f s) x)). - exact (fun r s x => ((maponpaths (fun y => y * x) ((pr1 (pr2 (pr2 f))) r s) @ (rigassoc2 S (f r) (f s) x)))). - exact (fun x => maponpaths (fun y => y * x) (pr2 (pr2 (pr2 f))) @ (@riglunax2 S x)). Defined. (** An important special case: a ring is a module over itself *) Definition ring_is_module (R : ring) : module R := ringfun_module (rigisotorigfun (idrigiso R)). (** The zero module is the unique R-module structure on the zero group (the group with a single element) *) Definition zero_module (R : ring) : module R. Proof. refine (unitabgr,, _). apply (@mult_to_module_struct _ _ (λ _ u, u)); easy. Defined. (** *** Bimodules *) Local Open Scope ring. (** An R-S-bimodule is a left R module and a right S module, that is With our definitions, this means a multimodule over bool with an R-module structre, an S⁰-module structure, and some compatibility between them. *) Definition bimodule (R S : ring) : UU := @multimodule _ (bool_rect _ R (S⁰)). (** The more immediate/intuitive description of a bimodule. Below, we provide a way to construct a bimodule from this definition (make_bimodule). *) Definition bimodule_struct' (R S : ring) (G : abgr) : UU := (* A bimodule structure consists of two modules structures... *) ∑ (mr : module_struct R G) (ms : module_struct (S⁰) G), (* ...and a notion of compatibility between them. *) let mulr := module_mult (G,, mr) in let muls := module_mult (G,, ms) in ∏ (r : R) (s : S), mulr r ∘ muls s = muls s ∘ mulr r. Definition make_bimodule (R S : ring) {G} (str : bimodule_struct' R S G) : bimodule R S. refine (G,, _). (** Index the module structs over bool *) refine (bool_rect _ (pr1 str) (pr1 (pr2 str)),, _). unfold multimodule_struct. (** the [ | ] pattern yields cases with hypotheses false ≠ false and true ≠ true, so we use them as contradictions or clear the useless hypothesis *) intros [ | ] [ | ] neq r s; try (contradiction (neq (idpath _))); clear neq; cbn in *. - exact ((pr2 (pr2 str)) r s). - exact (!((pr2 (pr2 str)) s r)). Defined. (** A commutative ring is a bimodule over itself *) Example commring_bimodule (R : commring) : bimodule R R. apply (@make_bimodule R R (@ringaddabgr R)). unfold bimodule_struct'. refine (pr2module (ring_is_module R),, _). (** We transport the module structure across the isomorphism R ≅ R⁰ *) refine (pr2module (ringfun_module (rigisotorigfun (invrigiso (iso_commring_opposite R)))),, _). simpl. intros r s. apply funextfun. intros x. exact (!@rigassoc2 R r s x @ (maponpaths (fun z => z * x) (@ringcomm2 R r s)) @ (rigassoc2 R s r x)). Defined. (* TODO: this line takes a while, not sure why *) Local Close Scope ring. UniMath-20231010/UniMath/Algebra/Modules/Multimodules.v000066400000000000000000000172121451125700300224760ustar00rootroot00000000000000(** Authors Langston Barrett (@siddharthist), November-December 2017 *) Require Import UniMath.Algebra.Modules.Core. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.Sets. (** ** Contents - Definitions - Propositions - Multimodule morphisms - Multilinearity - Multimodule morphisms *) (** ** Definitions *) (** The definition of a compatible R-S-bimodule structure is phrased in terms of associativity for left and right actions, (rm)s=r(ms). Modulo notation, this is really a statement about the actions intertwining one another. More generally, we can define a multimodule based on every action being compatible. Definition from Algebra by Bourbaki, II §1, no. 14. *) Definition arecompatibleactions {R S G} (mr : module_struct R G) (ms : module_struct S G) := let m1 := module_mult (G,, mr) in let m2 := module_mult (G,, ms) in ∏ (r1 : R) (r2 : S), (m1 r1 ∘ m2 r2 = m2 r2 ∘ m1 r1)%functions. Definition multimodule_struct {I : UU} {rings : I -> ring} {G : abgr} (structs : ∏ i : I, module_struct (rings i) G) := ∏ (i1 i2 : I) (ne : (i1 = i2) -> hfalse), arecompatibleactions (structs i1) (structs i2). Definition multimodule {I : UU} (rings : I -> ring) : UU := ∑ G (ms : ∏ i : I, module_struct (rings i) G), multimodule_struct ms. (** We define a few things in the same way for multimodules as we did for modules *) Definition pr1multimodule {I : UU} {rings : I -> ring} (MM : multimodule rings) : abgr := pr1 MM. Coercion pr1multimodule : multimodule >-> abgr. Definition pr2multimodule {I : UU} {rings : I -> ring} (MM : multimodule rings) : ∏ i : I, module_struct (rings i) (pr1multimodule MM) := (pr1 (pr2 MM)). Definition pr3bimodule {I : UU} {rings : I -> ring} (MM : multimodule rings) : multimodule_struct (pr2multimodule MM) := (pr2 (pr2 MM)). Definition ith_module {I : UU} {rings : I -> ring} (MM : multimodule rings) (i : I) : module (rings i) := (pr1multimodule MM,, pr2multimodule MM i). (** **** Propositions *) Lemma isaproparecompatibleactions {R S G} (mr : module_struct R G) (ms : module_struct S G) : isaprop (arecompatibleactions mr ms). Proof. apply (impredtwice 1); intros r s. (* We'll prove that all the homotopies are identical *) apply (isofhlevelweqb 1 (Y := (module_mult (G,, mr) r ∘ module_mult (G,, ms) s ~ module_mult (G,, ms) s ∘ module_mult (G,, mr) r))). apply invweq. apply weqfunextsec. apply (impred 1); intros x. apply (pr2 (pr1 (pr1 G))). Defined. Lemma isapropmultimodule_struct {I : UU} {rings : I -> ring} {G : abgr} (structs : ∏ i : I, module_struct (rings i) G) : isaprop (multimodule_struct structs). Proof. apply (impredtwice 1); intros i1 i2. apply impredfun. apply isaproparecompatibleactions. Defined. (** *** Multimodule morphisms *) (** **** Multilinearity*) (** A function is multilinear precisely when it is linear for each module *) Definition ismultilinear {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : MM -> NN) := ∏ i : I, @islinear (rings i) (ith_module MM i) (ith_module NN i) f. Definition multilinearfun {I : UU} {rings : I -> ring} (MM NN : multimodule rings) : UU := ∑ f : MM -> NN, ismultilinear f. Definition make_multilinearfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : MM -> NN) (is : ismultilinear f) : multilinearfun MM NN := tpair _ f is. Definition pr1multilinearfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multilinearfun MM NN) : MM -> NN := pr1 f. Coercion pr1multilinearfun : multilinearfun >-> Funclass. Definition ith_linearfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multilinearfun MM NN) (i : I) : linearfun (ith_module MM i) (ith_module NN i) := (pr1 f,, pr2 f i). Definition ismultilinearfuncomp {I : UU} {rings : I -> ring} {MM NN PP : multimodule rings} (f : multilinearfun MM NN) (g : multilinearfun NN PP) : ismultilinear (pr1 g ∘ pr1 f)%functions := (fun i => islinearfuncomp (ith_linearfun f i) (ith_linearfun g i)). Definition multilinearfuncomp {I : UU} {rings : I -> ring} {MM NN PP : multimodule rings} (f : multilinearfun MM NN) (g : multilinearfun NN PP) : multilinearfun MM PP := (funcomp f g,, ismultilinearfuncomp f g). (** **** Multimodule morphisms *) Definition ismultimodulefun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : MM -> NN) : UU := (isbinopfun f) × (ismultilinear f). Lemma isapropismultimodulefun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : MM -> NN) : isaprop (ismultimodulefun f). Proof. refine (@isofhleveldirprod 1 (isbinopfun f) (ismultilinear f) (isapropisbinopfun f) _). do 3 (apply (impred 1 _); intros ?). apply setproperty. Defined. Definition multimodulefun {I : UU} {rings : I -> ring} (MM NN : multimodule rings) : UU := ∑ f : MM -> NN, ismultimodulefun f. Definition make_multimodulefun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : MM -> NN) (is : ismultimodulefun f) : multimodulefun MM NN := tpair _ f is. Definition pr1multimodulefun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) : MM -> NN := pr1 f. Coercion pr1multimodulefun : multimodulefun >-> Funclass. Definition ith_modulefun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) (i : I) : modulefun (ith_module MM i) (ith_module NN i) := (pr1 f,, (make_dirprod (pr1 (pr2 f)) (pr2 (pr2 f) i))). Definition multimodulefun_to_isbinopfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) : isbinopfun (pr1multimodulefun f) := pr1 (pr2 f). Definition multimodulefun_to_binopfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) : binopfun MM NN := make_binopfun (pr1multimodulefun f) (multimodulefun_to_isbinopfun f). Definition multimodulefun_to_ith_islinear {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) (i : I) : islinear (ith_modulefun f i) := pr2 (pr2 (ith_modulefun f i)). Definition multimodulefun_to_ith_linearfun {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) (i : I) : linearfun (ith_module MM i) (ith_module NN i) := make_linearfun (ith_modulefun f i) (multimodulefun_to_ith_islinear f i). (** Properties of the ring actions *) Definition multimodule_ith_mult {I : UU} {rings : I -> ring} (MM : multimodule rings) (i : I) : (rings i) -> MM -> MM := @module_mult (rings i) (ith_module MM i). (** If you take the underlying group of the ith module, its the same as the underlying group of the multimodule. *) Lemma multimodule_same_abgrp {I : UU} {rings : I -> ring} (MM : multimodule rings) (i : I) : @paths abgr MM (ith_module MM i). Proof. reflexivity. Defined. (** Multiplying something by 0 always gives you the identity. Equationally, 0R * x = 0G for all x. *) Definition multimodule_ith_mult_0_to_0 {I : UU} {rings : I -> ring} {MM : multimodule rings} (i : I) (x : MM) : multimodule_ith_mult MM i (@ringunel1 (rings i)) x = @unel MM := @module_mult_0_to_0 (rings i) (ith_module MM i) x. (* TODO *) Definition multimodulefun_unel {I : UU} {rings : I -> ring} {MM NN : multimodule rings} (f : multimodulefun MM NN) : f (unel MM) = unel NN. Abort.UniMath-20231010/UniMath/Algebra/Modules/Quotient.v000066400000000000000000000203051451125700300216200ustar00rootroot00000000000000(** * Taking a quotient of a submodule of a module over a fixed ring Auke Booij, December 2017 *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Modules.Core. Require Import UniMath.Algebra.Modules.Submodule. (** * Preliminaries: notion of an equivalence relation on a module that is closed under the module structure *) Section quotmod_rel. Context {R : ring} (M : module R). Local Open Scope module_scope. Definition isactionhrel (E : hrel M) : UU := ∏ r a b, E a b -> E (r * a) (r * b). Definition module_eqrel : UU := ∑ E : eqrel M, isbinophrel E × isactionhrel E. Definition hrelmodule_eqrel (E : module_eqrel) : eqrel M := pr1 E. Coercion hrelmodule_eqrel : module_eqrel >-> eqrel. Definition binophrelmodule_eqrel (E : module_eqrel) : binopeqrel M := make_binopeqrel E (pr1 (pr2 E)). Coercion binophrelmodule_eqrel : module_eqrel >-> binopeqrel. Definition isactionhrelmodule_eqrel (E : module_eqrel) : isactionhrel E := pr2 (pr2 E). Coercion isactionhrelmodule_eqrel : module_eqrel >-> isactionhrel. Definition make_module_eqrel (E : eqrel M) : isbinophrel E -> isactionhrel E -> module_eqrel := λ H0 H1, (E,,(H0,,H1)). End quotmod_rel. (** * Preliminaries: construction of an appropriate equivalence relation from a submodule *) Section quotmod_submodule. Context {R : ring} (M : module R) (A : submodule M). Local Notation "x + y" := (@op _ x y). Local Notation "x - y" := (@op _ x (grinv _ y)). Local Notation " - y" := (grinv _ y). Local Notation "0" := (unel _). Local Open Scope module_scope. Definition eqrelsubmodule : eqrel M. Proof. use eqrelconstr. - exact (λ m m', A (m - m')). - intros x y z xy yz. assert (K := submoduleadd A (x - y) (y - z) xy yz). rewrite (assocax M) in K. rewrite <- (assocax M (grinv _ y) y) in K. rewrite grlinvax in K. rewrite lunax in K. exact K. - intros x. rewrite (grrinvax M x). exact (submodule0 A). - intros x y axy. assert (K := submoduleinv A (x - y) axy). rewrite grinvop in K. rewrite grinvinv in K. exact K. Defined. Definition module_eqrelsubmodule : module_eqrel M. Proof. use make_module_eqrel. - exact eqrelsubmodule. - split. + intros a b c. assert (H : a - b = c + a - (c + b)). { etrans; [|eapply (maponpaths (λ z, z - (c + b))); apply (commax M)]; rewrite assocax. apply maponpaths. now rewrite grinvop, commax, assocax, grlinvax, runax. } simpl in *. now rewrite H. + intros a b c. assert (H : a - b = a + c - (b + c)). { rewrite assocax. apply maponpaths. now rewrite grinvop, <- (assocax M), grrinvax, lunax. } simpl in *. now rewrite H. - intros r m m'. assert (H : (r * m) - (r * m') = r * (m - m')) by now rewrite module_inv_mult, module_mult_is_ldistr. generalize (submodulemult A r (m - m')). simpl in *. now rewrite H. Defined. End quotmod_submodule. (** * Construction of quotient module, as well as its universal property *) Section quotmod_def. Context {R : ring} (M : module R) (E : module_eqrel M). Local Notation "x + y" := (@op _ x y). Local Notation "x - y" := (@op _ x (grinv _ y)). Local Open Scope module_scope. Definition quotmod_abgr : abgr := abgrquot E. Definition quotmod_ringact (r : R) : quotmod_abgr -> quotmod_abgr. Proof. use setquotuniv. - intros m. exact (setquotpr E (r * m)). - intros m m' Hmm'. apply weqpathsinsetquot. now apply isactionhrelmodule_eqrel. Defined. Definition quotmod_ringmap : R -> ringofendabgr quotmod_abgr. Proof. intros r. use tpair. + exact (quotmod_ringact r). + use make_ismonoidfun. * use make_isbinopfun. use (setquotuniv2prop E (λ a b, make_hProp _ _)); [use isasetsetquot|]. intros m m'. unfold quotmod_ringact, setquotfun2; rewrite (setquotunivcomm E), (setquotunivcomm E); simpl; unfold setquotfun2; rewrite (setquotuniv2comm E), (setquotuniv2comm E), (setquotunivcomm E). apply weqpathsinsetquot. assert (H : r * (m + m') = r * m + r * m') by use module_mult_is_ldistr. simpl in H; rewrite H. use eqrelrefl. * unfold unel, quotmod_ringact; simpl; rewrite (setquotunivcomm E). apply maponpaths. apply module_mult_1. Defined. Definition quotmod_ringfun : ringfun R (ringofendabgr quotmod_abgr). Proof. unfold ringfun, rigfun. use rigfunconstr. - exact quotmod_ringmap. - use make_isrigfun. (* To show that quotmod_ringmap is a ring action, we show it is a monoid homomorphism with respect to both monoids on R. *) all: use make_ismonoidfun; (* To show that a map is a monoid homomorphism, we show that it respects the binary operation, as well as that it preserves the unit. *) [ use make_isbinopfun; intros r r' | ]. (* It suffices to prove the underlying maps of the resulting automorphism of our group are equal. *) all: use monoidfun_paths; use funextfun. (* We show this using the universal property of the set quotient. *) all: use (setquotunivprop E (λ m, make_hProp _ _)); [use isasetsetquot|]. (* Expand out some definitions. *) all: intros m; simpl; unfold unel, quotmod_ringact. (* Apply the computation rule of the universal property of the set quotient. *) all: [> do 3 rewrite (setquotunivcomm E) | rewrite (setquotunivcomm E) | do 3 rewrite (setquotunivcomm E) | rewrite (setquotunivcomm E)]. (* We can show the required equalities because the representatives of the equivalence classes are already equal. *) all: use maponpaths; simpl. (* The representatives are equal because of the fact that our input map was a ring action. *) + use module_mult_is_rdistr. + use module_mult_0_to_0. + use module_mult_assoc. + use module_mult_unel2. Defined. Definition quotmod_mod_struct : module_struct R quotmod_abgr := quotmod_ringfun. Definition quotmod : module R. Proof. use make_module. - exact quotmod_abgr. - exact quotmod_mod_struct. Defined. Notation "M / A" := (quotmod M (module_eqrelsubmodule M A)) : module_scope. Notation "R-mod( M , N )" := (modulefun M N) : module_scope. Definition quotmod_quotmap : R-mod(M, quotmod). Proof. use make_modulefun. - exact (setquotpr E). - now use (make_ismodulefun (make_isbinopfun _)). Defined. Definition quotmoduniv (N : module R) (f : R-mod(M, N)) (is : iscomprelfun E f) : R-mod(quotmod, N). Proof. use make_modulefun. - now use (setquotuniv E _ f). - use make_ismodulefun. + use make_isbinopfun. use (setquotuniv2prop E (λ m n, make_hProp _ _)); [use isasetmodule|]. intros m m'. simpl. unfold op, setquotfun2. rewrite setquotuniv2comm. do 3 rewrite (setquotunivcomm E). apply modulefun_to_isbinopfun. + intros r. use (setquotunivprop E (λ m, make_hProp _ _)); [use isasetmodule|]. intros m. assert (H : r * quotmod_quotmap m = quotmod_quotmap (r * m)) by use (! modulefun_to_islinear _ _ _). simpl in H. simpl. rewrite H. do 2 rewrite (setquotunivcomm E). apply modulefun_to_islinear. Defined. End quotmod_def. (** * Universal property in terms of submodules *) Section from_submodule. Context {R : ring} (M : module R) (A : submodule M). Notation "R-mod( M , N )" := (modulefun M N) : module_scope. Local Open Scope module_scope. Definition quotmoduniv_submodule (N : module R) (f : R-mod(M, N)) (is : iscomprelfun (module_eqrelsubmodule M A) f) : R-mod(quotmod M (module_eqrelsubmodule M A), N) := quotmoduniv M (module_eqrelsubmodule M A) N f is. End from_submodule. UniMath-20231010/UniMath/Algebra/Modules/Submodule.v000066400000000000000000000120311451125700300217440ustar00rootroot00000000000000(** Authors Floris van Doorn, December 2017 *) Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Modules.Core. (** ** Contents - Subobjects of modules - Kernels - Images *) Definition issubsetwithsmul {R : hSet} {M : hSet} (smul : R → M → M) (A : hsubtype M) : UU := ∏ r m, A m → A (smul r m). Definition issubmodule {R : ring} {M : module R} (A : hsubtype M) : UU := issubgr A × issubsetwithsmul (module_mult M) A. Definition make_issubmodule {R : ring} {M : module R} {A : hsubtype M} (H1 : issubgr A) (H2 : issubsetwithsmul (module_mult M) A) : issubmodule A := make_dirprod H1 H2. Definition issubmodule_is {R : ring} {M : module R} (A : hsubtype M) : UU := issubgr A × issubsetwithsmul (module_mult M) A. Lemma isapropissubmodule {R : ring} {M : module R} (A : hsubtype M) : isaprop (issubmodule A). Proof. intros. apply (isofhleveldirprod 1). - apply isapropissubgr. - apply impred. intro x. apply impred. intro m. apply impred. intro a. apply (pr2 (A _)). Defined. (* Submodules *) Definition submodule {R : ring} (M : module R) : UU := total2 (λ A : hsubtype M, issubmodule A). Definition make_submodule {R : ring} {M : module R} : ∏ (t : hsubtype M), (λ A : hsubtype M, issubmodule A) t → ∑ A : hsubtype M, issubmodule A := tpair (λ A : hsubtype M, issubmodule A). Definition submoduletosubabgr {R : ring} {M : module R} : submodule M -> @subabgr M := λ A : _, make_subgr (pr1 A) (pr1 (pr2 A)). Coercion submoduletosubabgr : submodule >-> subabgr. Definition submodule_to_issubsetwithsmul {R : ring} {M : module R} (A : submodule M) : issubsetwithsmul (module_mult M) A := pr2 (pr2 A). Local Open Scope module_scope. Definition submodule_smul {R : ring} {M : module R} {A : submodule M} (r : R) (m : A) : A. Proof. use tpair. - exact (r * pr1 m). - exact (submodule_to_issubsetwithsmul A r (pr1 m) (pr2 m)). Defined. Definition carrierofasubmodule {R : ring} {M : module R} (A : submodule M) : module R. Proof. use mult_to_module. - exact (carrierofasubabgr A). - exact (submodule_smul). - intros r a b. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_is_ldistr. - intros r s a. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_is_rdistr. - intros r s a. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_assoc. - intros f. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_unel2. Defined. Coercion carrierofasubmodule : submodule >-> module. Lemma intersection_submodule {R : ring} {M : module R} {I : UU} (S : I -> hsubtype M) (each_is_submodule : ∏ i : I, issubmodule (S i)) : issubmodule (subtype_intersection S). Proof. intros. use make_issubmodule. - exact (intersection_subgr S (λ i, (pr1 (each_is_submodule i)))). - intros r m a i. exact (pr2 (each_is_submodule i) r m (a i)). Qed. Lemma ismodulefun_pr1 {R : ring} {M : module R} (A : submodule M) : @ismodulefun R A M pr1. Proof. use make_ismodulefun. exact (pr1 (ismonoidfun_pr1 A)). intros r a. reflexivity. Defined. Definition submodule_incl {R : ring} {M : module R} (A : submodule M) : modulefun A M := make_modulefun _ (ismodulefun_pr1 A). (* Kernel and image *) Lemma issubmodule_kernel {R : ring} {A B : module R} (f : modulefun A B) : issubmodule (abgr_kernel_hsubtype (modulefun_to_monoidfun f)). Proof. split. - apply abgr_Kernel_subabgr_issubgr. - intros r x p. cbn. rewrite (modulefun_to_islinear f). rewrite <- (module_mult_1 r), <- p. reflexivity. Defined. Definition module_kernel {R : ring} {A B : module R} (f : modulefun A B) : submodule A := make_submodule _ (issubmodule_kernel f). Definition module_kernel_eq {R : ring} {A B : module R} (f : modulefun A B) x : f (submodule_incl (module_kernel f) x) = unel B := (pr2 x). Lemma issubmodule_image {R : ring} {A B : module R} (f : modulefun A B) : issubmodule (abgr_image_hsubtype (modulefun_to_monoidfun f)). Proof. split. - apply abgr_image_issubgr. - intros r x. apply hinhfun. cbn. intro ap. induction ap as [a p]. split with (r * a). now rewrite (modulefun_to_islinear f), <- p. Defined. Definition module_image {R : ring} {A B : module R} (f : modulefun A B) : submodule B := make_submodule _ (issubmodule_image f). Section submodule_helpers. Context {R : ring} {M : module R} (A : submodule M). Local Notation "x + y" := (@op _ x y). Local Notation "x - y" := (@op _ x (grinv _ y)). Definition submoduleadd (x y : M) : A x -> A y -> A (x + y). Proof. intros ax ay. exact (pr1 (pr1 (pr1 (pr2 A))) (make_carrier A x ax) (make_carrier A y ay)). Defined. Definition submodule0 : A (unel M) := pr2 (pr1 (pr1 (pr2 A))). Definition submoduleinv (x : M) : A x -> A (grinv _ x) := λ ax, (pr2 (pr1 (pr2 A)) x ax). Local Open Scope module. Definition submodulemult (r : R) (m : M) : A m -> A (r * m) := (pr2 (pr2 A) r m). End submodule_helpers. UniMath-20231010/UniMath/Algebra/Monoids.v000066400000000000000000002002711451125700300200120ustar00rootroot00000000000000(** * Algebra I. Part B. Monoids, abelian monoids. Vladimir Voevodsky. Aug. 2011 - . *) (** ** Contents - Monoids - Basics definitions - Univalence for monoids - Functions between monoids compatible with structures (homomorphisms) and their properties - Subobjects - Kernels - Quotient objects - Cosets - Direct products - Abelian (commutative) monoids - Basic definitions - Univalence for abelian monoids - Subobjects - Quotient objects - Direct products - Monoid of fractions of an abelian monoid - Canonical homomorphism to the monoid of fractions - Abelian monoid of fractions in the case when elements of the localization submonoid are cancelable - Relations on the abelian monoid of fractions - Relations and canonical homomorphism to [abmonoidfrac] *) (** For some examples, see [UniMath.NumberSystems.NaturalNumbersAlgebra] *) (** ** Preamble *) (** Settings *) (** The following line has to be removed for the file to compile with Coq8.2 *) Unset Kernel Term Sharing. (** Imports *) Require Export UniMath.Algebra.BinaryOperations. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.Orders. Local Open Scope logic. (** ** Standard Algebraic Structures *) (** *** Monoids *) (** **** Basic definitions *) Definition monoid : UU := total2 (λ X : setwithbinop, ismonoidop (@op X)). Definition make_monoid : ∏ (t : setwithbinop), (λ X : setwithbinop, ismonoidop op) t → ∑ X : setwithbinop, ismonoidop op := tpair (λ X : setwithbinop, ismonoidop (@op X)). Definition pr1monoid : monoid -> setwithbinop := @pr1 _ _. Coercion pr1monoid : monoid >-> setwithbinop. Definition assocax (X : monoid) : isassoc (@op X) := pr1 (pr2 X). Definition unel (X : monoid) : X := pr1 (pr2 (pr2 X)). Definition lunax (X : monoid) : islunit (@op X) (unel X) := pr1 (pr2 (pr2 (pr2 X))). Definition runax (X : monoid) : isrunit (@op X) (unel X) := pr2 (pr2 (pr2 (pr2 X))). Definition unax (X : monoid) : isunit (@op X) (unel X) := make_dirprod (lunax X) (runax X). Definition isasetmonoid (X : monoid) : isaset X := pr2 (pr1 (pr1 X)). Declare Scope addmonoid_scope. Delimit Scope addmonoid_scope with addmonoid. Declare Scope multmonoid_scope. Delimit Scope multmonoid_scope with multmonoid. Notation "x * y" := (op x y) : multmonoid_scope. Notation "1" := (unel _) : multmonoid_scope. Module AddNotation. Notation "x + y" := (op x y) : addmonoid_scope. Notation "0" := (unel _) : addmonoid_scope. End AddNotation. (* To get additive notation in a file that uses this one, insert the following command: Import UniMath.Algebra.Monoids.AddNotation. *) (** **** Construction of the trivial monoid consisting of one element given by unit. *) Definition unitmonoid_ismonoid : ismonoidop (λ x : unitset, λ y : unitset, x). Proof. use make_ismonoidop. - intros x x' x''. use isProofIrrelevantUnit. - use make_isunital. + exact tt. + use make_isunit. * intros x. use isProofIrrelevantUnit. * intros x. use isProofIrrelevantUnit. Qed. Definition unitmonoid : monoid := make_monoid (make_setwithbinop unitset (λ x : unitset, λ y : unitset, x)) unitmonoid_ismonoid. (** **** Functions between monoids compatible with structure (homomorphisms) and their properties *) Definition ismonoidfun {X Y : monoid} (f : X -> Y) : UU := dirprod (isbinopfun f) (f (unel X) = (unel Y)). Definition make_ismonoidfun {X Y : monoid} {f : X -> Y} (H1 : isbinopfun f) (H2 : f (unel X) = unel Y) : ismonoidfun f := make_dirprod H1 H2. Definition ismonoidfunisbinopfun {X Y : monoid} {f : X -> Y} (H : ismonoidfun f) : isbinopfun f := dirprod_pr1 H. Definition ismonoidfununel {X Y : monoid} {f : X -> Y} (H : ismonoidfun f) : f (unel X) = unel Y := dirprod_pr2 H. Lemma isapropismonoidfun {X Y : monoid} (f : X -> Y) : isaprop (ismonoidfun f). Proof. apply isofhleveldirprod. - apply isapropisbinopfun. - apply (setproperty Y). Defined. Definition monoidfun (X Y : monoid) : UU := total2 (fun f : X -> Y => ismonoidfun f). Definition monoidfunconstr {X Y : monoid} {f : X -> Y} (is : ismonoidfun f) : monoidfun X Y := tpair _ f is. Definition pr1monoidfun (X Y : monoid) : monoidfun X Y -> (X -> Y) := @pr1 _ _. Definition monoidfuntobinopfun (X Y : monoid) : monoidfun X Y -> binopfun X Y := λ f, make_binopfun (pr1 f) (pr1 (pr2 f)). Coercion monoidfuntobinopfun : monoidfun >-> binopfun. Definition monoidfununel {X Y : monoid} (f : monoidfun X Y) : f (unel X) = (unel Y) := pr2 (pr2 f). Definition monoidfunmul {X Y : monoid} (f : monoidfun X Y) (x x' : X) : f (op x x') = op (f x) (f x') := pr1 (pr2 f) x x'. Definition monoidfun_paths {X Y : monoid} (f g : monoidfun X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropismonoidfun. Defined. Opaque monoidfun_paths. Lemma isasetmonoidfun (X Y : monoid) : isaset (monoidfun X Y). Proof. apply (isasetsubset (pr1monoidfun X Y)). - change (isofhlevel 2 (X -> Y)). apply impred. intro. apply (setproperty Y). - refine (isinclpr1 _ _). intro. apply isapropismonoidfun. Defined. Lemma ismonoidfuncomp {X Y Z : monoid} (f : monoidfun X Y) (g : monoidfun Y Z) : ismonoidfun (funcomp (pr1 f) (pr1 g)). Proof. split with (isbinopfuncomp f g). simpl. rewrite (pr2 (pr2 f)). apply (pr2 (pr2 g)). Defined. Opaque ismonoidfuncomp. Definition monoidfuncomp {X Y Z : monoid} (f : monoidfun X Y) (g : monoidfun Y Z) : monoidfun X Z := monoidfunconstr (ismonoidfuncomp f g). Lemma monoidfunassoc {X Y Z W : monoid} (f : monoidfun X Y) (g : monoidfun Y Z) (h : monoidfun Z W) : monoidfuncomp f (monoidfuncomp g h) = monoidfuncomp (monoidfuncomp f g) h. Proof. use monoidfun_paths. use idpath. Qed. Lemma unelmonoidfun_ismonoidfun (X Y : monoid) : ismonoidfun (λ x : X, (unel Y)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use lunax. - use idpath. Qed. Definition unelmonoidfun (X Y : monoid) : monoidfun X Y := monoidfunconstr (unelmonoidfun_ismonoidfun X Y). Lemma monoidfuntounit_ismonoidfun (X : monoid) : ismonoidfun (λ x : X, (unel unitmonoid)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit. - use isProofIrrelevantUnit. Qed. Definition monoidfuntounit (X : monoid) : monoidfun X unitmonoid := monoidfunconstr (monoidfuntounit_ismonoidfun X). Lemma monoidfunfromunit_ismonoidfun (X : monoid) : ismonoidfun (λ x : unitmonoid, (unel X)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X). - use idpath. Qed. Definition monoidfunfromunit (X : monoid) : monoidfun unitmonoid X := monoidfunconstr (monoidfunfromunit_ismonoidfun X). Definition monoidmono (X Y : monoid) : UU := total2 (λ f : incl X Y, ismonoidfun f). Definition make_monoidmono {X Y : monoid} (f : incl X Y) (is : ismonoidfun f) : monoidmono X Y := tpair _ f is. Definition pr1monoidmono (X Y : monoid) : monoidmono X Y -> incl X Y := @pr1 _ _. Coercion pr1monoidmono : monoidmono >-> incl. Definition monoidincltomonoidfun (X Y : monoid) : monoidmono X Y -> monoidfun X Y := λ f, monoidfunconstr (pr2 f). Coercion monoidincltomonoidfun : monoidmono >-> monoidfun. Definition monoidmonotobinopmono (X Y : monoid) : monoidmono X Y -> binopmono X Y := λ f, make_binopmono (pr1 f) (pr1 (pr2 f)). Coercion monoidmonotobinopmono : monoidmono >-> binopmono. Definition monoidmonocomp {X Y Z : monoid} (f : monoidmono X Y) (g : monoidmono Y Z) : monoidmono X Z := make_monoidmono (inclcomp (pr1 f) (pr1 g)) (ismonoidfuncomp f g). Definition monoidiso (X Y : monoid) : UU := total2 (λ f : X ≃ Y, ismonoidfun f). Definition make_monoidiso {X Y : monoid} (f : X ≃ Y) (is : ismonoidfun f) : monoidiso X Y := tpair _ f is. Definition pr1monoidiso (X Y : monoid) : monoidiso X Y -> X ≃ Y := @pr1 _ _. Coercion pr1monoidiso : monoidiso >-> weq. Definition monoidisotomonoidmono (X Y : monoid) : monoidiso X Y -> monoidmono X Y := λ f, make_monoidmono (weqtoincl (pr1 f)) (pr2 f). Coercion monoidisotomonoidmono : monoidiso >-> monoidmono. Definition monoidisotobinopiso (X Y : monoid) : monoidiso X Y -> binopiso X Y := λ f, make_binopiso (pr1 f) (pr1 (pr2 f)). Coercion monoidisotobinopiso : monoidiso >-> binopiso. Definition monoidiso_paths {X Y : monoid} (f g : monoidiso X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropismonoidfun. Defined. Opaque monoidiso_paths. Lemma ismonoidfuninvmap {X Y : monoid} (f : monoidiso X Y) : ismonoidfun (invmap (pr1 f)). Proof. split with (isbinopfuninvmap f). apply (invmaponpathsweq (pr1 f)). rewrite (homotweqinvweq (pr1 f)). apply (pathsinv0 (pr2 (pr2 f))). Defined. Opaque ismonoidfuninvmap. Definition invmonoidiso {X Y : monoid} (f : monoidiso X Y) : monoidiso Y X := make_monoidiso (invweq (pr1 f)) (ismonoidfuninvmap f). Definition idmonoidiso (X : monoid) : monoidiso X X. Proof. use make_monoidiso. - exact (idweq X). - use make_dirprod. + intros x x'. use idpath. + use idpath. Defined. Lemma monoidfunidleft {A B : monoid} (f : monoidfun A B) : monoidfuncomp (idmonoidiso A) f = f. Proof. use monoidfun_paths. use idpath. Qed. Lemma monoidfunidright {A B : monoid} (f : monoidfun A B) : monoidfuncomp f (idmonoidiso B) = f. Proof. use monoidfun_paths. use idpath. Qed. (** **** (X = Y) ≃ (monoidiso X Y) The idea here is to use the following composition (X = Y) ≃ (X ╝ Y) ≃ (monoidiso' X Y) ≃ (monoidiso X Y). The reason why we use monoidiso' is that then we can use univalence for sets with binops, [setwithbinop_univalence]. See [monoid_univalence_weq2]. *) Local Definition monoidiso' (X Y : monoid) : UU := ∑ g : (∑ f : X ≃ Y, isbinopfun f), (pr1 g) (unel X) = unel Y. Definition monoid_univalence_weq1 (X Y : monoid) : (X = Y) ≃ (X ╝ Y) := total2_paths_equiv _ X Y. Definition monoid_univalence_weq2 (X Y : monoid) : (X ╝ Y) ≃ (monoidiso' X Y). Proof. use weqbandf. - exact (setwithbinop_univalence X Y). - intros e. cbn. use invweq. induction X as [X Xop]. induction Y as [Y Yop]. cbn in e. cbn. induction e. use weqimplimpl. + intros i. use proofirrelevance. use isapropismonoidop. + intros i. induction i. use idpath. + use setproperty. + use isapropifcontr. exact (@isapropismonoidop X (pr2 X) Xop Yop). Defined. Opaque monoid_univalence_weq2. Definition monoid_univalence_weq3 (X Y : monoid) : (monoidiso' X Y) ≃ (monoidiso X Y) := weqtotal2asstor (λ w : X ≃ Y, isbinopfun w) (λ y : (∑ w : weq X Y, isbinopfun w), (pr1 y) (unel X) = unel Y). Definition monoid_univalence_map (X Y : monoid) : X = Y -> monoidiso X Y. Proof. intro e. induction e. exact (idmonoidiso X). Defined. Lemma monoid_univalence_isweq (X Y : monoid) : isweq (monoid_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (monoid_univalence_weq1 X Y) (weqcomp (monoid_univalence_weq2 X Y) (monoid_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque monoid_univalence_isweq. Definition monoid_univalence (X Y : monoid) : (X = Y) ≃ (monoidiso X Y). Proof. use make_weq. - exact (monoid_univalence_map X Y). - exact (monoid_univalence_isweq X Y). Defined. Opaque monoid_univalence. (** **** Subobjects *) Definition issubmonoid {X : monoid} (A : hsubtype X) : UU := dirprod (issubsetwithbinop (@op X) A) (A (unel X)). Definition make_issubmonoid {X : monoid} {A : hsubtype X} (H1 : issubsetwithbinop (@op X) A) (H2 : A (unel X)) : issubmonoid A := make_dirprod H1 H2. Lemma isapropissubmonoid {X : monoid} (A : hsubtype X) : isaprop (issubmonoid A). Proof. apply (isofhleveldirprod 1). - apply isapropissubsetwithbinop. - apply (pr2 (A (unel X))). Defined. Definition submonoid (X : monoid) : UU := total2 (λ A : hsubtype X, issubmonoid A). Definition make_submonoid {X : monoid} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubmonoid A) t → ∑ A : hsubtype X, issubmonoid A := tpair (λ A : hsubtype X, issubmonoid A). Definition pr1submonoid (X : monoid) : submonoid X -> hsubtype X := @pr1 _ _. Lemma isaset_submonoid (A : monoid) : isaset (submonoid A). Proof. apply isaset_total2. - apply isasethsubtype. - intro P. apply isasetaprop, isapropissubmonoid. Defined. Definition totalsubmonoid (X : monoid) : submonoid X. Proof. split with (totalsubtype X). split. - intros x x'. apply tt. - apply tt. Defined. Definition trivialsubmonoid (X : monoid) : @submonoid X. Proof. intros. exists (λ x, x = @unel X). split. - intros b c. induction b as [x p], c as [y q]. cbn in *. induction (!p), (!q). rewrite lunax. apply idpath. - apply idpath. Defined. Definition submonoidtosubsetswithbinop (X : monoid) : submonoid X -> @subsetswithbinop X := λ A : _, make_subsetswithbinop (pr1 A) (pr1 (pr2 A)). Coercion submonoidtosubsetswithbinop : submonoid >-> subsetswithbinop. Lemma ismonoidcarrier {X : monoid} (A : submonoid X) : ismonoidop (@op A). Proof. split. - intros a a' a''. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (assocax X). - split with (make_carrier _ (unel X) (pr2 (pr2 A))). split. + simpl. intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (lunax X). + intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (runax X). Defined. Definition carrierofsubmonoid {X : monoid} (A : submonoid X) : monoid. Proof. split with A. apply ismonoidcarrier. Defined. Coercion carrierofsubmonoid : submonoid >-> monoid. Lemma intersection_submonoid : forall {X : monoid} {I : UU} (S : I -> hsubtype X) (each_is_submonoid : ∏ i : I, issubmonoid (S i)), issubmonoid (subtype_intersection S). Proof. intros. use make_issubmonoid. + intros g h i. pose (is_subgr := pr1 (each_is_submonoid i)). exact (is_subgr (pr1 g,, (pr2 g) i) (pr1 h,, (pr2 h) i)). + exact (λ i, pr2 (each_is_submonoid i)). Qed. (* Lemma ismonoidfun_pr1 {X : monoid} (A : submonoid X) : ismonoidfun (pr1submonoid X A). *) (* ismonoidfunconstr _ _. *) Lemma ismonoidfun_pr1 {X : monoid} (A : submonoid X) : @ismonoidfun A X pr1. Proof. use make_ismonoidfun. - intros a a'. reflexivity. - reflexivity. Defined. Definition submonoid_incl {X : monoid} (A : submonoid X) : monoidfun A X := monoidfunconstr (ismonoidfun_pr1 A). (** Every monoid has a submonoid which is a group, the collection of elements with inverses. This is used to construct the automorphism group from the endomorphism monoid, for instance. *) Local Open Scope multmonoid. Definition invertible_submonoid (X : monoid) : @submonoid X. Proof. refine (merely_invertible_elements (@op X) (pr2 X),, _). split. (** This is a similar statement to [grinvop] *) - intros xpair ypair. apply mere_invop. + exact (pr2 xpair). + exact (pr2 ypair). - apply hinhpr; exact (1,, make_dirprod (lunax _ 1) (lunax _ 1)). Defined. (** This submonoid is closed under inversion *) Lemma inverse_in_submonoid (X : monoid) : ∏ (x x0 : X), merely_invertible_elements (@op X) (pr2 X) x -> isinvel (@op X) (pr2 X) x x0 -> merely_invertible_elements (@op X) (pr2 X) x0. Proof. intros x x0 _ x0isxinv. unfold merely_invertible_elements, hasinv. apply hinhpr. exact (x,, is_inv_inv (@op X) _ _ _ x0isxinv). Defined. Local Close Scope multmonoid. (** **** Kernels *) (** Kernels Let f : X → Y be a morphism of monoids. The kernel of f is the submonoid of X consisting of elements x such that [f x = unel Y]. *) Definition monoid_kernel_hsubtype {A B : monoid} (f : monoidfun A B) : hsubtype A. Proof. intros a. use make_hProp. - exact (f a = unel B). - apply setproperty. Defined. (** Kernel as a monoid *) Definition kernel_issubmonoid {A B : monoid} (f : monoidfun A B) : issubmonoid (monoid_kernel_hsubtype f). Proof. use make_issubmonoid. - intros x y. refine (monoidfunmul f _ _ @ _). refine (maponpaths _ (pr2 y) @ _). refine (runax _ _ @ _). exact (pr2 x). - apply monoidfununel. Defined. Definition kernel_submonoid {A B : monoid} (f : monoidfun A B) : @submonoid A := make_submonoid _ (kernel_issubmonoid f). (** **** Quotient objects *) Lemma isassocquot {X : monoid} (R : binopeqrel X) : isassoc (@op (setwithbinopquot R)). Proof. intros a b c. apply (setquotuniv3prop R (λ x x' x'' : setwithbinopquot R, make_hProp _ (setproperty (setwithbinopquot R) (op (op x x') x'') (op x (op x' x''))))). intros x x' x''. apply (maponpaths (setquotpr R) (assocax X x x' x'')). Defined. Opaque isassocquot. Lemma isunitquot {X : monoid} (R : binopeqrel X) : isunit (@op (setwithbinopquot R)) (setquotpr R (pr1 (pr2 (pr2 X)))). Proof. intros. set (qun := setquotpr R (pr1 (pr2 (pr2 X)))). set (qsetwithop := setwithbinopquot R). split. - intro x. apply (setquotunivprop R (λ x, (@op qsetwithop) qun x = x)). simpl. intro x0. apply (maponpaths (setquotpr R) (lunax X x0)). - intro x. apply (setquotunivprop R (λ x, (@op qsetwithop) x qun = x)). simpl. intro x0. apply (maponpaths (setquotpr R) (runax X x0)). Defined. Opaque isunitquot. Definition ismonoidquot {X : monoid} (R : binopeqrel X) : ismonoidop (@op (setwithbinopquot R)) := tpair _ (isassocquot R) (tpair _ (setquotpr R (pr1 (pr2 (pr2 X)))) (isunitquot R)). Definition monoidquot {X : monoid} (R : binopeqrel X) : monoid. Proof. split with (setwithbinopquot R). apply ismonoidquot. Defined. Lemma ismonoidfun_setquotpr {X : monoid} (R : binopeqrel X) : @ismonoidfun X (monoidquot R) (setquotpr R). Proof. use make_ismonoidfun. - intros x y. reflexivity. - reflexivity. Defined. Definition monoidquotpr {X : monoid} (R : binopeqrel X) : monoidfun X (monoidquot R) := monoidfunconstr (ismonoidfun_setquotpr R). Lemma ismonoidfun_setquotuniv {X Y : monoid} {R : binopeqrel X} (f : monoidfun X Y) (H : iscomprelfun R f) : @ismonoidfun (monoidquot R) Y (setquotuniv R Y f H). Proof. use make_ismonoidfun. - refine (setquotuniv2prop' _ _ _). + intros. apply isasetmonoid. + intros. simpl. rewrite setquotfun2comm. rewrite !setquotunivcomm. apply monoidfunmul. - exact (setquotunivcomm _ _ _ _ _ @ monoidfununel _). Defined. (** The universal property of the quotient monoid. If X, Y are monoids, R is a congruence on X, and [f : X → Y] is a homomorphism which respects R, then there exists a unique homomorphism [f' : X/R → Y] making the following diagram commute: << X -π-> X/R \ | f | ∃! f' \ | V V Y >> *) Definition monoidquotuniv {X Y : monoid} {R : binopeqrel X} (f : monoidfun X Y) (H : iscomprelfun R f) : monoidfun (monoidquot R) Y := monoidfunconstr (ismonoidfun_setquotuniv f H). Definition monoidquotfun {X Y : monoid} {R : binopeqrel X} {S : binopeqrel Y} (f : monoidfun X Y) (H : ∏ x x' : X, R x x' → S (f x) (f x')) : monoidfun (monoidquot R) (monoidquot S) := monoidquotuniv (monoidfuncomp f (monoidquotpr S)) (λ x x' r, iscompsetquotpr _ _ _ (H _ _ r)). (** Quotients by the equivalence relation of being in the same fiber. This is exactly X / ker f for a homomorphism f. *) Local Open Scope multmonoid. Definition fiber_binopeqrel {X Y : monoid} (f : monoidfun X Y) : binopeqrel X. Proof. use make_binopeqrel. - exact (same_fiber_eqrel f). - use make_isbinophrel; intros ? ? ? same; refine (monoidfunmul _ _ _ @ _ @ !monoidfunmul _ _ _). + (** Prove that it's a congruence for left multiplication *) apply maponpaths. exact same. + (** Prove that it's a congruence for right multiplication *) apply (maponpaths (λ z, z * f c)). exact same. Defined. Definition quotient_by_monoidfun {X Y : monoid} (f : monoidfun X Y) : monoid := monoidquot (fiber_binopeqrel f). (** **** Cosets *) Section Cosets. Context {X : monoid} (Y : submonoid X). Definition in_same_left_coset (x1 x2 : X) : UU := ∑ y : Y, x1 * (pr1 y) = x2. Definition in_same_right_coset (x1 x2 : X) : UU := ∑ y : Y, (pr1 y) * x1 = x2. End Cosets. (** **** Direct products *) Lemma isassocdirprod (X Y : monoid) : isassoc (@op (setwithbinopdirprod X Y)). Proof. simpl. intros xy xy' xy''. simpl. apply pathsdirprod. - apply (assocax X). - apply (assocax Y). Defined. Opaque isassocdirprod. Lemma isunitindirprod (X Y : monoid) : isunit (@op (setwithbinopdirprod X Y)) (make_dirprod (unel X) (unel Y)). Proof. split. - intro xy. destruct xy as [ x y ]. simpl. apply pathsdirprod. apply (lunax X). apply (lunax Y). - intro xy. destruct xy as [ x y ]. simpl. apply pathsdirprod. apply (runax X). apply (runax Y). Defined. Opaque isunitindirprod. Definition ismonoiddirprod (X Y : monoid) : ismonoidop (@op (setwithbinopdirprod X Y)) := tpair _ (isassocdirprod X Y) (tpair _ (make_dirprod (unel X) (unel Y)) (isunitindirprod X Y)). Definition monoiddirprod (X Y : monoid) : monoid. Proof. split with (setwithbinopdirprod X Y). apply ismonoiddirprod. Defined. (** *** Abelian (commutative) monoids *) (** **** Basic definitions *) Definition abmonoid : UU := total2 (λ X : setwithbinop, isabmonoidop (@op X)). Definition make_abmonoid : ∏ (t : setwithbinop), (λ X : setwithbinop, isabmonoidop op) t → ∑ X : setwithbinop, isabmonoidop op := tpair (λ X : setwithbinop, isabmonoidop (@op X)). Definition abmonoidtomonoid : abmonoid -> monoid := λ X : _, make_monoid (pr1 X) (pr1 (pr2 X)). Coercion abmonoidtomonoid : abmonoid >-> monoid. Definition commax (X : abmonoid) : iscomm (@op X) := pr2 (pr2 X). Definition abmonoidrer (X : abmonoid) (a b c d : X) : paths (op (op a b) (op c d)) (op (op a c) (op b d)) := abmonoidoprer (pr2 X) a b c d. Definition abmonoid_of_monoid (X : monoid) (H : iscomm (@op X)) : abmonoid := make_abmonoid X (make_isabmonoidop (pr2 X) H). (** **** Construction of the trivial abmonoid consisting of one element given by unit. *) Definition unitabmonoid_isabmonoid : isabmonoidop (@op unitmonoid). Proof. use make_isabmonoidop. - exact unitmonoid_ismonoid. - intros x x'. use isProofIrrelevantUnit. Qed. Definition unitabmonoid : abmonoid := make_abmonoid unitmonoid unitabmonoid_isabmonoid. Lemma abmonoidfuntounit_ismonoidfun (X : abmonoid) : ismonoidfun (λ x : X, (unel unitabmonoid)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use isProofIrrelevantUnit. - use isProofIrrelevantUnit. Qed. Definition abmonoidfuntounit (X : abmonoid) : monoidfun X unitabmonoid := monoidfunconstr (abmonoidfuntounit_ismonoidfun X). Lemma abmonoidfunfromunit_ismonoidfun (X : abmonoid) : ismonoidfun (λ x : unitabmonoid, (unel X)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use (runax X). - use idpath. Qed. Definition abmonoidfunfromunit (X : abmonoid) : monoidfun unitabmonoid X := monoidfunconstr (abmonoidfunfromunit_ismonoidfun X). Lemma unelabmonoidfun_ismonoidfun (X Y : abmonoid) : ismonoidfun (λ x : X, (unel Y)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use pathsinv0. use lunax. - use idpath. Qed. Definition unelabmonoidfun (X Y : abmonoid) : monoidfun X Y := monoidfunconstr (unelabmonoidfun_ismonoidfun X Y). (** **** Abelian monoid structure on homsets If f g : X -> Y are morphisms of abelian monoids, then we define f + g to be the morphism (f + g)(x) = f(x) + g(x). *) Lemma abmonoidshombinop_ismonoidfun {X Y : abmonoid} (f g : monoidfun X Y) : @ismonoidfun X Y (λ x : pr1 X, (pr1 f x * pr1 g x)%multmonoid). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. cbn. rewrite (pr1 (pr2 f)). rewrite (pr1 (pr2 g)). rewrite (assocax Y). rewrite (assocax Y). use maponpaths. rewrite <- (assocax Y). rewrite <- (assocax Y). use (maponpaths (λ y : Y, (y * (pr1 g x'))%multmonoid)). use (commax Y). - use (pathscomp0 (maponpaths (λ h : Y, (pr1 f (unel X) * h)%multmonoid) (monoidfununel g))). rewrite runax. exact (monoidfununel f). Qed. Definition abmonoidshombinop {X Y : abmonoid} : binop (monoidfun X Y) := (λ f g, monoidfunconstr (abmonoidshombinop_ismonoidfun f g)). Lemma abmonoidsbinop_runax {X Y : abmonoid} (f : monoidfun X Y) : abmonoidshombinop f (unelmonoidfun X Y) = f. Proof. use monoidfun_paths. use funextfun. intros x. use (runax Y). Qed. Lemma abmonoidsbinop_lunax {X Y : abmonoid} (f : monoidfun X Y) : abmonoidshombinop (unelmonoidfun X Y) f = f. Proof. use monoidfun_paths. use funextfun. intros x. use (lunax Y). Qed. Lemma abmonoidshombinop_assoc {X Y : abmonoid} (f g h : monoidfun X Y) : abmonoidshombinop (abmonoidshombinop f g) h = abmonoidshombinop f (abmonoidshombinop g h). Proof. use monoidfun_paths. use funextfun. intros x. use assocax. Qed. Lemma abmonoidshombinop_comm {X Y : abmonoid} (f g : monoidfun X Y) : abmonoidshombinop f g = abmonoidshombinop g f. Proof. use monoidfun_paths. use funextfun. intros x. use (commax Y). Qed. Lemma abmonoidshomabmonoid_ismonoidop (X Y : abmonoid) : @ismonoidop (make_hSet (monoidfun X Y) (isasetmonoidfun X Y)) (λ f g : monoidfun X Y, abmonoidshombinop f g). Proof. use make_ismonoidop. - intros f g h. exact (abmonoidshombinop_assoc f g h). - use make_isunital. + exact (unelmonoidfun X Y). + use make_isunit. * intros f. exact (abmonoidsbinop_lunax f). * intros f. exact (abmonoidsbinop_runax f). Defined. Lemma abmonoidshomabmonoid_isabmonoid (X Y : abmonoid) : @isabmonoidop (make_hSet (monoidfun X Y) (isasetmonoidfun X Y)) (λ f g : monoidfun X Y, abmonoidshombinop f g). Proof. use make_isabmonoidop. - exact (abmonoidshomabmonoid_ismonoidop X Y). - intros f g. exact (abmonoidshombinop_comm f g). Defined. Definition abmonoidshomabmonoid (X Y : abmonoid) : abmonoid. Proof. use make_abmonoid. - use make_setwithbinop. + use make_hSet. * exact (monoidfun X Y). * exact (isasetmonoidfun X Y). + intros f g. exact (abmonoidshombinop f g). - exact (abmonoidshomabmonoid_isabmonoid X Y). Defined. (** **** (X = Y) ≃ (monoidiso X Y) We use the following composition (X = Y) ≃ ((make_abmonoid' X) = (make_abmonoid' Y)) ≃ ((pr1 (make_abmonoid' X)) = (pr1 (make_abmonoid' Y))) ≃ (monoidiso X Y) where the third weak equivalence is given by univalence for monoids, [monoid_univalence]. *) Local Definition abmonoid' : UU := ∑ m : monoid, iscomm (@op m). Local Definition make_abmonoid' (X : abmonoid) : abmonoid' := tpair _ (tpair _ (pr1 X) (dirprod_pr1 (pr2 X))) (dirprod_pr2 (pr2 X)). Definition abmonoid_univalence_weq1 : abmonoid ≃ abmonoid' := weqtotal2asstol (λ X : setwithbinop, ismonoidop (@op X)) (fun y : (∑ X : setwithbinop, ismonoidop op) => iscomm (@op (pr1 y))). Definition abmonoid_univalence_weq1' (X Y : abmonoid) : (X = Y) ≃ ((make_abmonoid' X) = (make_abmonoid' Y)) := make_weq _ (@isweqmaponpaths abmonoid abmonoid' abmonoid_univalence_weq1 X Y). Definition abmonoid_univalence_weq2 (X Y : abmonoid) : ((make_abmonoid' X) = (make_abmonoid' Y)) ≃ ((pr1 (make_abmonoid' X)) = (pr1 (make_abmonoid' Y))). Proof. use subtypeInjectivity. intros w. use isapropiscomm. Defined. Opaque abmonoid_univalence_weq2. Definition abmonoid_univalence_weq3 (X Y : abmonoid) : ((pr1 (make_abmonoid' X)) = (pr1 (make_abmonoid' Y))) ≃ (monoidiso X Y) := monoid_univalence (pr1 (make_abmonoid' X)) (pr1 (make_abmonoid' Y)). Definition abmonoid_univalence_map (X Y : abmonoid) : (X = Y) -> (monoidiso X Y). Proof. intro e. induction e. exact (idmonoidiso X). Defined. Lemma abmonoid_univalence_isweq (X Y : abmonoid) : isweq (abmonoid_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (abmonoid_univalence_weq1' X Y) (weqcomp (abmonoid_univalence_weq2 X Y) (abmonoid_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque abmonoid_univalence_isweq. Definition abmonoid_univalence (X Y : abmonoid) : (X = Y) ≃ (monoidiso X Y). Proof. use make_weq. - exact (abmonoid_univalence_map X Y). - exact (abmonoid_univalence_isweq X Y). Defined. Opaque abmonoid_univalence. (** **** Subobjects *) Definition subabmonoid (X : abmonoid) := submonoid X. Identity Coercion id_subabmonoid : subabmonoid >-> submonoid. Lemma iscommcarrier {X : abmonoid} (A : submonoid X) : iscomm (@op A). Proof. intros a a'. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply (pr2 (pr2 X)). Defined. Opaque iscommcarrier. Definition isabmonoidcarrier {X : abmonoid} (A : submonoid X) : isabmonoidop (@op A) := make_dirprod (ismonoidcarrier A) (iscommcarrier A). Definition carrierofsubabmonoid {X : abmonoid} (A : subabmonoid X) : abmonoid. Proof. unfold subabmonoid in A. split with A. apply isabmonoidcarrier. Defined. Coercion carrierofsubabmonoid : subabmonoid >-> abmonoid. Definition subabmonoid_incl {X : abmonoid} (A : subabmonoid X) : monoidfun A X := submonoid_incl A. (** **** Quotient objects *) Lemma iscommquot {X : abmonoid} (R : binopeqrel X) : iscomm (@op (setwithbinopquot R)). Proof. intros. set (X0 := setwithbinopquot R). intros x x'. apply (setquotuniv2prop R (λ x x' : X0, make_hProp _ (setproperty X0 (op x x') (op x' x)))). intros x0 x0'. apply (maponpaths (setquotpr R) ((commax X) x0 x0')). Defined. Opaque iscommquot. Definition isabmonoidquot {X : abmonoid} (R : binopeqrel X) : isabmonoidop (@op (setwithbinopquot R)) := make_dirprod (ismonoidquot R) (iscommquot R). Definition abmonoidquot {X : abmonoid} (R : binopeqrel X) : abmonoid. Proof. split with (setwithbinopquot R). apply isabmonoidquot. Defined. (** **** Direct products *) Lemma iscommdirprod (X Y : abmonoid) : iscomm (@op (setwithbinopdirprod X Y)). Proof. intros xy xy'. destruct xy as [ x y ]. destruct xy' as [ x' y' ]. simpl. apply pathsdirprod. - apply (commax X). - apply (commax Y). Defined. Opaque iscommdirprod. Definition isabmonoiddirprod (X Y : abmonoid) : isabmonoidop (@op (setwithbinopdirprod X Y)) := make_dirprod (ismonoiddirprod X Y) (iscommdirprod X Y). Definition abmonoiddirprod (X Y : abmonoid) : abmonoid. Proof. split with (setwithbinopdirprod X Y). apply isabmonoiddirprod. Defined. (** **** Monoid of fractions of an abelian monoid Note : the following construction uses onbly associativity and commutativity of the [abmonoid] operations but does not use the unit element. *) Local Open Scope addmonoid_scope. Import AddNotation. Definition abmonoidfracopint (X : abmonoid) (A : submonoid X) : binop (X × A) := @op (setwithbinopdirprod X A). Definition hrelabmonoidfrac (X : abmonoid) (A : submonoid X) : hrel (setwithbinopdirprod X A) := λ xa yb : dirprod X A, hexists (λ a0 : A, paths (((pr1 xa) + (pr1 (pr2 yb))) + (pr1 a0)) (((pr1 yb) + (pr1 (pr2 xa)) + (pr1 a0)))). Lemma iseqrelabmonoidfrac (X : abmonoid) (A : submonoid X) : iseqrel (hrelabmonoidfrac X A). Proof. intros. set (assoc := assocax X). set (comm := commax X). set (R := hrelabmonoidfrac X A). assert (symm : issymm R). { intros xa yb. unfold R. simpl. apply hinhfun. intro eq1. destruct eq1 as [ x1 eq1 ]. split with x1. destruct x1 as [ x1 isx1 ]. simpl. apply (pathsinv0 eq1). } assert (trans : istrans R). { unfold istrans. intros ab cd ef. simpl. apply hinhfun2. destruct ab as [ a b ]. destruct cd as [ c d ]. destruct ef as [ e f ]. destruct b as [ b isb ]. destruct d as [ d isd ]. destruct f as [ f isf ]. intros eq1 eq2. destruct eq1 as [ x1 eq1 ]. destruct eq2 as [ x2 eq2 ]. simpl in *. split with (@op A (tpair _ d isd) (@op A x1 x2)). destruct x1 as [ x1 isx1 ]. destruct x2 as [ x2 isx2 ]. destruct A as [ A ax ]. simpl in *. rewrite (assoc a f (d + (x1 + x2))). rewrite (comm f (d + (x1 + x2))). destruct (assoc a (d + (x1 + x2)) f). destruct (assoc a d (x1 + x2)). destruct (assoc (a + d) x1 x2). rewrite eq1. rewrite (comm x1 x2). rewrite (assoc e b (d + (x2 + x1))). rewrite (comm b (d + (x2 + x1))). destruct (assoc e (d + (x2 + x1)) b). destruct (assoc e d (x2 + x1)). destruct (assoc (e + d) x2 x1). destruct eq2. rewrite (assoc (c + b) x1 x2). rewrite (assoc (c + f) x2 x1). rewrite (comm x1 x2). rewrite (assoc (c + b) (x2 + x1) f). rewrite (assoc (c + f) (x2 + x1) b). rewrite (comm (x2 + x1) f). rewrite (comm (x2 + x1) b). destruct (assoc (c + b) f (x2 + x1)). destruct (assoc (c + f) b (x2 + x1)). rewrite (assoc c b f). rewrite (assoc c f b). rewrite (comm b f). apply idpath. } assert (refl : isrefl R). { intro xa. simpl. apply hinhpr. split with (pr2 xa). apply idpath. } apply (iseqrelconstr trans refl symm). Defined. Opaque iseqrelabmonoidfrac. Definition eqrelabmonoidfrac (X : abmonoid) (A : submonoid X) : eqrel (setwithbinopdirprod X A) := make_eqrel (hrelabmonoidfrac X A) (iseqrelabmonoidfrac X A). Lemma isbinophrelabmonoidfrac (X : abmonoid) (A : submonoid X) : @isbinophrel (setwithbinopdirprod X A) (eqrelabmonoidfrac X A). Proof. intros. apply (isbinopreflrel (eqrelabmonoidfrac X A) (eqrelrefl (eqrelabmonoidfrac X A))). set (rer := abmonoidoprer (pr2 X)). intros a b c d. simpl. apply hinhfun2. destruct a as [ a a' ]. destruct a' as [ a' isa' ]. destruct b as [ b b' ]. destruct b' as [ b' isb' ]. destruct c as [ c c' ]. destruct c' as [ c' isc' ]. destruct d as [ d d' ]. destruct d' as [ d' isd' ]. intros ax ay. destruct ax as [ a1 eq1 ]. destruct ay as [ a2 eq2 ]. split with (@op A a1 a2). destruct a1 as [ a1 aa1 ]. destruct a2 as [ a2 aa2 ]. simpl in *. rewrite (rer a c b' d'). rewrite (rer b d a' c'). rewrite (rer (a + b') (c + d') a1 a2). rewrite (rer (b + a') (d + c') a1 a2). destruct eq1. destruct eq2. apply idpath. Defined. Opaque isbinophrelabmonoidfrac. Definition abmonoidfracop (X : abmonoid) (A : submonoid X) : binop (setquot (hrelabmonoidfrac X A)) := setquotfun2 (hrelabmonoidfrac X A) (eqrelabmonoidfrac X A) (abmonoidfracopint X A) ((iscompbinoptransrel _ (eqreltrans _) (isbinophrelabmonoidfrac X A))). Definition binopeqrelabmonoidfrac (X : abmonoid) (A : subabmonoid X) : binopeqrel (abmonoiddirprod X A) := @make_binopeqrel (setwithbinopdirprod X A) (eqrelabmonoidfrac X A) (isbinophrelabmonoidfrac X A). Definition abmonoidfrac (X : abmonoid) (A : submonoid X) : abmonoid := abmonoidquot (binopeqrelabmonoidfrac X A). Definition prabmonoidfrac (X : abmonoid) (A : submonoid X) : X -> A -> abmonoidfrac X A := fun (x : X) (a : A) => setquotpr (eqrelabmonoidfrac X A) (make_dirprod x a). (* ??? could the use of [issubabmonoid] in [binopeqrelabmonoidfrac] and [submonoid] in [abmonoidfrac] lead to complications for the unification machinery? See also [abmonoidfracisbinoprelint] below. *) Lemma invertibilityinabmonoidfrac (X : abmonoid) (A : submonoid X) : ∏ a a' : A, isinvertible (@op (abmonoidfrac X A)) (prabmonoidfrac X A (pr1 a) a'). Proof. intros a a'. set (R := eqrelabmonoidfrac X A). unfold isinvertible. assert (isl : islinvertible (@op (abmonoidfrac X A)) (prabmonoidfrac X A (pr1 a) a')). { unfold islinvertible. set (f := λ x0 : abmonoidfrac X A, prabmonoidfrac X A (pr1 a) a' + x0). set (g := λ x0 : abmonoidfrac X A, prabmonoidfrac X A (pr1 a') a + x0). assert (egf : ∏ x0 : _, paths (g (f x0)) x0). { apply (setquotunivprop R (λ x, _ = _)). intro xb. simpl. apply (iscompsetquotpr R (@make_dirprod X A ((pr1 a') + ((pr1 a) + (pr1 xb))) ((@op A) a ((@op A) a' (pr2 xb))))). simpl. apply hinhpr. split with (unel A). unfold pr1carrier. simpl. set (e := assocax X (pr1 a) (pr1 a') (pr1 (pr2 xb))). simpl in e. destruct e. set (e := assocax X (pr1 xb) (pr1 a + pr1 a') (pr1 (pr2 xb))). simpl in e. destruct e. set (e := assocax X (pr1 a') (pr1 a) (pr1 xb)). simpl in e. destruct e. set (e := commax X (pr1 a) (pr1 a')). simpl in e. destruct e. set (e := commax X (pr1 a + pr1 a') (pr1 xb)). simpl in e. destruct e. apply idpath. } assert (efg : ∏ x0 : _, paths (f (g x0)) x0). { apply (setquotunivprop R (λ x0, _ = _)). intro xb. simpl. apply (iscompsetquotpr R (@make_dirprod X A ((pr1 a) + ((pr1 a') + (pr1 xb))) ((@op A) a' ((@op A) a (pr2 xb))))). simpl. apply hinhpr. split with (unel A). unfold pr1carrier. simpl. set (e := assocax X (pr1 a') (pr1 a) (pr1 (pr2 xb))). simpl in e. destruct e. set (e := assocax X (pr1 xb) (pr1 a' + pr1 a) (pr1 (pr2 xb))). simpl in e. destruct e. set (e := assocax X (pr1 a) (pr1 a') (pr1 xb)). simpl in e. destruct e. set (e := commax X (pr1 a') (pr1 a)). simpl in e. destruct e. set (e := commax X (pr1 a' + pr1 a) (pr1 xb)). simpl in e. destruct e. apply idpath. } apply (isweq_iso _ _ egf efg). } apply (make_dirprod isl (weqlinvertiblerinvertible (@op (abmonoidfrac X A)) (commax (abmonoidfrac X A)) (prabmonoidfrac X A (pr1 a) a') isl)). Defined. (** **** Canonical homomorphism to the monoid of fractions *) Definition toabmonoidfrac (X : abmonoid) (A : submonoid X) (x : X) : abmonoidfrac X A := setquotpr _ (make_dirprod x (unel A)). Lemma isbinopfuntoabmonoidfrac (X : abmonoid) (A : submonoid X) : isbinopfun (toabmonoidfrac X A). Proof. unfold isbinopfun. intros x1 x2. change (paths (setquotpr _ (make_dirprod (x1 + x2) (@unel A))) (setquotpr (eqrelabmonoidfrac X A) (make_dirprod (x1 + x2) ((unel A) + (unel A))))). apply (maponpaths (setquotpr _)). apply (@pathsdirprod X A). apply idpath. apply (pathsinv0 (lunax A 0)). Defined. Lemma isunitalfuntoabmonoidfrac (X : abmonoid) (A : submonoid X) : paths (toabmonoidfrac X A (unel X)) (unel (abmonoidfrac X A)). Proof. apply idpath. Defined. Definition ismonoidfuntoabmonoidfrac (X : abmonoid) (A : submonoid X) : ismonoidfun (toabmonoidfrac X A) := make_dirprod (isbinopfuntoabmonoidfrac X A) (isunitalfuntoabmonoidfrac X A). (** **** Abelian monoid of fractions in the case when elements of the localziation submonoid are cancelable *) Definition hrel0abmonoidfrac (X : abmonoid) (A : submonoid X) : hrel (X × A) := λ xa yb : setdirprod X A, (pr1 xa) + (pr1 (pr2 yb)) = (pr1 yb) + (pr1 (pr2 xa)). Lemma weqhrelhrel0abmonoidfrac (X : abmonoid) (A : submonoid X) (iscanc : ∏ a : A, isrcancelable (@op X) (pr1carrier _ a)) (xa xa' : dirprod X A) : (eqrelabmonoidfrac X A xa xa') ≃ (hrel0abmonoidfrac X A xa xa'). Proof. unfold eqrelabmonoidfrac. unfold hrelabmonoidfrac. simpl. apply weqimplimpl. apply (@hinhuniv _ (pr1 xa + pr1 (pr2 xa') = pr1 xa' + pr1 (pr2 xa))). intro ae. destruct ae as [ a eq ]. apply (invmaponpathsincl _ (iscanc a) _ _ eq). intro eq. apply hinhpr. split with (unel A). rewrite (runax X). rewrite (runax X). apply eq. apply (isapropishinh _). apply (setproperty X). Defined. Lemma isinclprabmonoidfrac (X : abmonoid) (A : submonoid X) (iscanc : ∏ a : A, isrcancelable (@op X) (pr1carrier _ a)) : ∏ a' : A, isincl (λ x, prabmonoidfrac X A x a'). Proof. intro a'. apply isinclbetweensets. - apply (setproperty X). - apply (setproperty (abmonoidfrac X A)). - intros x x'. intro e. set (e' := invweq (weqpathsinsetquot (eqrelabmonoidfrac X A) (make_dirprod x a') (make_dirprod x' a')) e). set (e'' := weqhrelhrel0abmonoidfrac X A iscanc (make_dirprod _ _) (make_dirprod _ _) e'). simpl in e''. apply (invmaponpathsincl _ (iscanc a')). apply e''. Defined. Definition isincltoabmonoidfrac (X : abmonoid) (A : submonoid X) (iscanc : ∏ a : A, isrcancelable (@op X) (pr1carrier _ a)) : isincl (toabmonoidfrac X A) := isinclprabmonoidfrac X A iscanc (unel A). Lemma isdeceqabmonoidfrac (X : abmonoid) (A : submonoid X) (iscanc : ∏ a : A, isrcancelable (@op X) (pr1carrier _ a)) (is : isdeceq X) : isdeceq (abmonoidfrac X A). Proof. apply (isdeceqsetquot (eqrelabmonoidfrac X A)). intros xa xa'. apply (isdecpropweqb (weqhrelhrel0abmonoidfrac X A iscanc xa xa')). apply isdecpropif. unfold isaprop. simpl. set (int := setproperty X (pr1 xa + pr1 (pr2 xa')) (pr1 xa' + pr1 (pr2 xa))). simpl in int. apply int. unfold hrel0abmonoidfrac. simpl. apply (is _ _). Defined. (** **** Relations on the abelian monoid of fractions *) Definition abmonoidfracrelint (X : abmonoid) (A : subabmonoid X) (L : hrel X) : hrel (setwithbinopdirprod X A) := λ xa yb, hexists (λ c0 : A, L (((pr1 xa) + (pr1 (pr2 yb))) + (pr1 c0)) (((pr1 yb) + (pr1 (pr2 xa))) + (pr1 c0))). Lemma iscomprelabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) : iscomprelrel (eqrelabmonoidfrac X A) (abmonoidfracrelint X A L). Proof. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. set (rer := abmonoidrer X). apply iscomprelrelif. apply (eqrelsymm (eqrelabmonoidfrac X A)). - intros xa xa' yb. unfold hrelabmonoidfrac. simpl. apply (@hinhfun2). intros t2e t2l. destruct t2e as [ c1a e ]. destruct t2l as [ c0a l ]. set (x := pr1 xa). set (a := pr1 (pr2 xa)). set (x' := pr1 xa'). set (a' := pr1 (pr2 xa')). set (y := pr1 yb). set (b := pr1 (pr2 yb)). set (c0 := pr1 c0a). set (c1 := pr1 c1a). split with ((pr2 xa) + c1a + c0a). change (L ((x' + b) + ((a + c1) + c0)) ((y + a') + ((a + c1) + c0))). change (paths (x + a' + c1) (x' + a + c1)) in e. rewrite (rer x' _ _ c0). destruct (assoc x' a c1). destruct e. rewrite (assoc x a' c1). rewrite (rer x _ _ c0). rewrite (assoc a c1 c0). rewrite (rer _ a' a _). rewrite (assoc a' c1 c0). rewrite (comm a' _). rewrite (comm c1 _). rewrite (assoc c0 c1 a'). destruct (assoc (x + b) c0 (@op X c1 a')). destruct (assoc (y + a) c0 (@op X c1 a')). apply ((pr2 is) _ _ _ (pr2 (@op A c1a (pr2 xa'))) l). - intros xa yb yb'. unfold hrelabmonoidfrac. simpl. apply (@hinhfun2). intros t2e t2l. destruct t2e as [ c1a e ]. destruct t2l as [ c0a l ]. set (x := pr1 xa). set (a := pr1 (pr2 xa)). set (y' := pr1 yb'). set (b' := pr1 (pr2 yb')). set (y := pr1 yb). set (b := pr1 (pr2 yb)). set (c0 := pr1 c0a). set (c1 := pr1 c1a). split with ((pr2 yb) + c1a + c0a). change (L ((x + b') + ((b + c1) + c0)) ((y' + a) + ((b + c1) + c0))). change (paths (y + b' + c1) (y' + b + c1)) in e. rewrite (rer y' _ _ c0). destruct (assoc y' b c1). destruct e. rewrite (assoc y b' c1). rewrite (rer y _ _ c0). rewrite (assoc b c1 c0). rewrite (rer _ b' b _). rewrite (assoc b' c1 c0). rewrite (comm b' _). rewrite (comm c1 _). rewrite (assoc c0 c1 b'). destruct (assoc (x + b) c0 (@op X c1 b')). destruct (assoc (y + a) c0 (@op X c1 b')). apply ((pr2 is) _ _ _ (pr2 (@op A c1a (pr2 yb'))) l). Defined. Opaque iscomprelabmonoidfracrelint. Definition abmonoidfracrel (X : abmonoid) (A : submonoid X) {L : hrel X} (is : ispartbinophrel A L) := quotrel (iscomprelabmonoidfracrelint X A is). Lemma istransabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : istrans L) : istrans (abmonoidfracrelint X A L). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. set (rer := abmonoidrer X). intros xa1 xa2 xa3. unfold abmonoidfracrelint. simpl. apply hinhfun2. intros t2l1 t2l2. set (c1a := pr1 t2l1). set (l1 := pr2 t2l1). set (c2a := pr1 t2l2). set (l2 := pr2 t2l2). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). set (x3 := pr1 xa3). set (a3 := pr1 (pr2 xa3)). set (c1 := pr1 c1a). set (c2 := pr1 c2a). split with ((pr2 xa2) + (@op A c1a c2a)). change (L ((x1 + a3) + (a2 + (c1 + c2))) ((x3 + a1) + (a2 + (c1 + c2)))). assert (ll1 : L ((x1 + a3) + (a2 + (@op X c1 c2))) (((x2 + a1) + c1) + (c2 + a3))). { rewrite (rer _ a3 a2 _). rewrite (comm a3 (@op X c1 c2)). rewrite (assoc c1 c2 a3). destruct (assoc (x1 + a2) c1 (@op X c2 a3)). apply ((pr2 is) _ _ _ (pr2 (@op A c2a (pr2 xa3))) l1). } assert (ll2 : L (((x2 + a3) + c2) + (@op X a1 c1)) ((x3 + a1) + (a2 + (@op X c1 c2)))). { rewrite (rer _ a1 a2 _). destruct (assoc a1 c1 c2). rewrite (comm (a1 + c1) c2). destruct (assoc (x3 + a2) c2 (@op X a1 c1)). apply ((pr2 is) _ _ _ (pr2 (@op A (pr2 xa1) c1a)) l2). } assert (e : paths (x2 + a1 + c1 + (c2 + a3)) (x2 + a3 + c2 + (a1 + c1))). { rewrite (assoc (x2 + a1) c1 _). rewrite (assoc (x2 + a3) c2 _). rewrite (assoc x2 a1 _). rewrite (assoc x2 a3 _). destruct (assoc a1 c1 (c2 + a3)). destruct (assoc a3 c2 (a1 + c1)). destruct (comm (c2 + a3) (a1 + c1)). rewrite (comm a3 c2). apply idpath. } destruct e. apply (isl _ _ _ ll1 ll2). Defined. Opaque istransabmonoidfracrelint. Lemma istransabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : istrans L) : istrans (abmonoidfracrel X A is). Proof. apply istransquotrel. apply istransabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma issymmabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : issymm L) : issymm (abmonoidfracrelint X A L). Proof. intros xa1 xa2. unfold abmonoidfracrelint. simpl. apply hinhfun. intros t2l1. set (c1a := pr1 t2l1). set (l1 := pr2 t2l1). split with (c1a). apply (isl _ _ l1). Defined. Opaque issymmabmonoidfracrelint. Lemma issymmabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : issymm L) : issymm (abmonoidfracrel X A is). Proof. apply issymmquotrel. apply issymmabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma isreflabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isrefl L) : isrefl (abmonoidfracrelint X A L). Proof. intro xa. unfold abmonoidfracrelint. simpl. apply hinhpr. split with (unel A). apply (isl _). Defined. Lemma isreflabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isrefl L) : isrefl (abmonoidfracrel X A is). Proof. apply isreflquotrel. apply isreflabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma ispoabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : ispreorder L) : ispreorder (abmonoidfracrelint X A L). Proof. split with (istransabmonoidfracrelint X A is (pr1 isl)). apply (isreflabmonoidfracrelint X A is (pr2 isl)). Defined. Lemma ispoabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : ispreorder L) : ispreorder (abmonoidfracrel X A is). Proof. apply ispoquotrel. apply ispoabmonoidfracrelint. apply is. apply isl. Defined. Lemma iseqrelabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iseqrel L) : iseqrel (abmonoidfracrelint X A L). Proof. split with (ispoabmonoidfracrelint X A is (pr1 isl)). apply (issymmabmonoidfracrelint X A is (pr2 isl)). Defined. Lemma iseqrelabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iseqrel L) : iseqrel (abmonoidfracrel X A is). Proof. apply iseqrelquotrel. apply iseqrelabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma isirreflabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isirrefl L) : isirrefl (abmonoidfracrelint X A L). Proof. unfold isirrefl. intro xa. unfold abmonoidfracrelint. simpl. unfold neg. apply (@hinhuniv _ (make_hProp _ isapropempty)). intro t2. apply (isl _ (pr2 t2)). Defined. Lemma isirreflabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isirrefl L) : isirrefl (abmonoidfracrel X A is). Proof. apply isirreflquotrel. apply isirreflabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma isasymmabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isasymm L) : isasymm (abmonoidfracrelint X A L). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. unfold isasymm. intros xa1 xa2. unfold abmonoidfracrelint. simpl. apply (@hinhuniv2 _ _ (make_hProp _ isapropempty)). intros t2l1 t2l2. set (c1a := pr1 t2l1). set (l1 := pr2 t2l1). set (c2a := pr1 t2l2). set (l2 := pr2 t2l2). set (c1 := pr1 c1a). set (c2 := pr1 c2a). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). assert (ll1 : L ((x1 + a2) + (@op X c1 c2)) ((x2 + a1) + (@op X c1 c2))). { destruct (assoc (x1 + a2) c1 c2). destruct (assoc (x2 + a1) c1 c2). apply ((pr2 is) _ _ _ (pr2 c2a)). apply l1. } assert (ll2 : L ((x2 + a1) + (@op X c1 c2)) ((x1 + a2) + (@op X c1 c2))). { destruct (comm c2 c1). destruct (assoc (x1 + a2) c2 c1). destruct (assoc (x2 + a1) c2 c1). apply ((pr2 is) _ _ _ (pr2 c1a)). apply l2. } apply (isl _ _ ll1 ll2). Defined. Opaque isasymmabmonoidfracrelint. Lemma isasymmabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isasymm L) : isasymm (abmonoidfracrel X A is). Proof. apply isasymmquotrel. apply isasymmabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma iscoasymmabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iscoasymm L) : iscoasymm (abmonoidfracrelint X A L). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. unfold iscoasymm. intros xa1 xa2. intro nl0. set (nl := neghexisttoforallneg _ nl0 (unel A)). simpl in nl. set (l := isl _ _ nl). apply hinhpr. split with (unel A). apply l. Defined. Opaque isasymmabmonoidfracrelint. Lemma iscoasymmabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iscoasymm L) : iscoasymm (abmonoidfracrel X A is). Proof. apply iscoasymmquotrel. apply iscoasymmabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma istotalabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : istotal L) : istotal (abmonoidfracrelint X A L). Proof. unfold istotal. intros x1 x2. unfold abmonoidfracrelint. set (int := isl (pr1 x1 + pr1 (pr2 x2)) (pr1 x2 + pr1 (pr2 x1))). generalize int. clear int. simpl. apply hinhfun. apply coprodf. intro l. apply hinhpr. split with (unel A). rewrite (runax X _). rewrite (runax X _). apply l. intro l. apply hinhpr. split with (unel A). rewrite (runax X _). rewrite (runax X _). apply l. Defined. Lemma istotalabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : istotal L) : istotal (abmonoidfracrel X A is). Proof. apply istotalquotrel. apply istotalabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma iscotransabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iscotrans L) : iscotrans (abmonoidfracrelint X A L). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := (commax X) : iscomm (@op X)). unfold iscomm in comm. set (rer := abmonoidrer X). unfold iscotrans. intros xa1 xa2 xa3. unfold abmonoidfracrelint. simpl. apply (@hinhuniv _ (ishinh _)). intro t2. set (c0a := pr1 t2). set (l0 := pr2 t2). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). set (x3 := pr1 xa3). set (a3 := pr1 (pr2 xa3)). set (c0 := pr1 c0a). set (z1 := (x1 + a3 + (a2 + c0))). set (z2 := x2 + a1 + (a3 + c0)). set (z3 := x3 + a1 + (a2 + c0)). assert (int : L z1 z3). { unfold z1. unfold z3. rewrite (comm a2 c0). rewrite (pathsinv0 (assoc _ _ a2)). rewrite (pathsinv0 (assoc _ _ a2)). apply ((pr2 is) _ _ _ (pr2 (pr2 xa2)) l0). } set (int' := isl z1 z2 z3 int). generalize int'. clear int'. simpl. apply hinhfun. intro cc. destruct cc as [ l12 | l23 ]. - apply ii1. apply hinhpr. split with ((pr2 xa3) + c0a). change (L (x1 + a2 + (a3 + c0)) (x2 + a1 + (a3 + c0))). rewrite (rer _ a2 a3 _). apply l12. - apply ii2. apply hinhpr. split with ((pr2 xa1) + c0a). change (L (x2 + a3 + (a1 + c0)) (x3 + a2 + (a1 + c0))). rewrite (rer _ a3 a1 _). rewrite (rer _ a2 a1 _). apply l23. Defined. Opaque iscotransabmonoidfracrelint. Lemma iscotransabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : iscotrans L) : iscotrans (abmonoidfracrel X A is). Proof. apply iscotransquotrel. apply iscotransabmonoidfracrelint. - apply is. - apply isl. Defined. Lemma isStrongOrder_abmonoidfrac {X : abmonoid} (Y : @submonoid X) (gt : hrel X) (Hgt : ispartbinophrel Y gt) : isStrongOrder gt → isStrongOrder (abmonoidfracrel X Y Hgt). Proof. intros H. split ; [ | split]. - apply istransabmonoidfracrel, (istrans_isStrongOrder H). - apply iscotransabmonoidfracrel, (iscotrans_isStrongOrder H). - apply isirreflabmonoidfracrel, (isirrefl_isStrongOrder H). Defined. Opaque isStrongOrder_abmonoidfrac. Definition StrongOrder_abmonoidfrac {X : abmonoid} (Y : @submonoid X) (gt : StrongOrder X) (Hgt : ispartbinophrel Y gt) : StrongOrder (abmonoidfrac X Y) := abmonoidfracrel X Y Hgt,, isStrongOrder_abmonoidfrac Y gt Hgt (pr2 gt). Lemma isantisymmnegabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isantisymmneg L) : isantisymmneg (abmonoidfracrel X A is). Proof. intros. assert (int : ∏ x1 x2, isaprop (neg (abmonoidfracrel X A is x1 x2) -> neg (abmonoidfracrel X A is x2 x1) -> x1 = x2)). { intros x1 x2. apply impred. intro. apply impred. intro. apply (isasetsetquot _ x1 x2). } unfold isantisymmneg. apply (setquotuniv2prop _ (λ x1 x2, make_hProp _ (int x1 x2))). intros xa1 xa2. intros r r'. apply (weqpathsinsetquot _). generalize r r'. clear r r'. change (neg (abmonoidfracrelint X A L xa1 xa2) -> neg (abmonoidfracrelint X A L xa2 xa1) -> (eqrelabmonoidfrac X A xa1 xa2)). intros nr12 nr21. set (nr12' := neghexisttoforallneg _ nr12 (unel A)). set (nr21' := neghexisttoforallneg _ nr21 (unel A)). set (int' := isl _ _ nr12' nr21'). simpl. apply hinhpr. split with (unel A). apply int'. Defined. Opaque isantisymmnegabmonoidfracrel. Lemma isantisymmabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (isl : isantisymm L) : isantisymm (abmonoidfracrel X A is). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. unfold isantisymm. assert (int : ∏ x1 x2, isaprop ((abmonoidfracrel X A is x1 x2) -> (abmonoidfracrel X A is x2 x1) -> x1 = x2)). { intros x1 x2. apply impred. intro. apply impred. intro. apply (isasetsetquot _ x1 x2). } apply (setquotuniv2prop _ (λ x1 x2, make_hProp _ (int x1 x2))). intros xa1 xa2. intros r r'. apply (weqpathsinsetquot _). generalize r r'. clear r r'. change ((abmonoidfracrelint X A L xa1 xa2) -> (abmonoidfracrelint X A L xa2 xa1) -> (eqrelabmonoidfrac X A xa1 xa2)). unfold abmonoidfracrelint. unfold eqrelabmonoidfrac. simpl. apply hinhfun2. intros t2l1 t2l2. set (c1a := pr1 t2l1). set (l1 := pr2 t2l1). set (c2a := pr1 t2l2). set (l2 := pr2 t2l2). set (c1 := pr1 c1a). set (c2 := pr1 c2a). split with (@op A c1a c2a). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). change (paths (x1 + a2 + (@op X c1 c2)) (x2 + a1 + (@op X c1 c2))). assert (ll1 : L ((x1 + a2) + (@op X c1 c2)) ((x2 + a1) + (@op X c1 c2))). { destruct (assoc (x1 + a2) c1 c2). destruct (assoc (x2 + a1) c1 c2). apply ((pr2 is) _ _ _ (pr2 c2a)). apply l1. } assert (ll2 : L ((x2 + a1) + (@op X c1 c2)) ((x1 + a2) + (@op X c1 c2))). { destruct (comm c2 c1). destruct (assoc (x1 + a2) c2 c1). destruct (assoc (x2 + a1) c2 c1). apply ((pr2 is) _ _ _ (pr2 c1a)). apply l2. } apply (isl _ _ ll1 ll2). Defined. Opaque isantisymmabmonoidfracrel. Lemma ispartbinopabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) : @ispartbinophrel (setwithbinopdirprod X A) (λ xa, A (pr1 xa)) (abmonoidfracrelint X A L). Proof. intros. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. set (rer := abmonoidrer X). apply ispartbinophrelif. apply (commax (abmonoiddirprod X A)). intros xa yb zc s. unfold abmonoidfracrelint. simpl. apply (@hinhfun). intro t2l. destruct t2l as [ c0a l ]. set (x := pr1 xa). set (a := pr1 (pr2 xa)). set (y := pr1 yb). set (b := pr1 (pr2 yb)). set (z := pr1 zc). set (c := pr1 (pr2 zc)). set (c0 := pr1 c0a). split with c0a. change (L (((z + x) + (c + b)) + c0) (((z + y) + (c + a)) + c0)). change (pr1 (L ((x + b) + c0) ((y + a) + c0))) in l. rewrite (rer z _ _ b). rewrite (assoc (z + c) _ _). rewrite (rer z _ _ a). rewrite (assoc (z + c) _ _). apply ((pr1 is) _ _ _ (pr2 (@op A (make_carrier A z s) (pr2 zc)))). apply l. Defined. Opaque ispartbinopabmonoidfracrelint. Lemma ispartlbinopabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (aa aa' : A) (z z' : abmonoidfrac X A) (l : abmonoidfracrel X A is z z') : abmonoidfracrel X A is ((prabmonoidfrac X A (pr1 aa) aa') + z) ((prabmonoidfrac X A (pr1 aa) aa') + z'). Proof. revert z z' l. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. set (rer := abmonoidrer X). assert (int : ∏ z z', isaprop (abmonoidfracrel X A is z z' -> abmonoidfracrel X A is (prabmonoidfrac X A (pr1 aa) aa' + z) (prabmonoidfrac X A (pr1 aa) aa' + z'))). { intros z z'. apply impred. intro. apply (pr2 (abmonoidfracrel _ _ _ _ _)). } apply (setquotuniv2prop _ (λ z z', make_hProp _ (int z z'))). intros xa1 xa2. change (abmonoidfracrelint X A L xa1 xa2 -> abmonoidfracrelint X A L (@op (abmonoiddirprod X A) (make_dirprod (pr1 aa) aa') xa1) (@op (abmonoiddirprod X A) (make_dirprod (pr1 aa) aa') xa2)). unfold abmonoidfracrelint. simpl. apply hinhfun. intro t2l. set (a := pr1 aa). set (a' := pr1 aa'). set (c0a := pr1 t2l). set (l := pr2 t2l). set (c0 := pr1 c0a). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). split with c0a. change (L (a + x1 + (a' + a2) + c0) (a + x2 + (a' + a1) + c0)). rewrite (rer _ x1 a' _). rewrite (rer _ x2 a' _). rewrite (assoc _ (x1 + a2) c0). rewrite (assoc _ (x2 + a1) c0). apply ((pr1 is) _ _ _ (pr2 (@op A aa aa'))). apply l. Defined. Opaque ispartlbinopabmonoidfracrel. Lemma ispartrbinopabmonoidfracrel (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartbinophrel A L) (aa aa' : A) (z z' : abmonoidfrac X A) (l : abmonoidfracrel X A is z z') : abmonoidfracrel X A is (z + (prabmonoidfrac X A (pr1 aa) aa')) (z' + (prabmonoidfrac X A (pr1 aa) aa')). Proof. revert z z' l. set (assoc := (assocax X) : isassoc (@op X)). unfold isassoc in assoc. set (comm := commax X). unfold iscomm in comm. set (rer := abmonoidrer X). assert (int : ∏ (z z' : abmonoidfrac X A), isaprop (abmonoidfracrel X A is z z' -> abmonoidfracrel X A is (z + (prabmonoidfrac X A (pr1 aa) aa')) (z' + prabmonoidfrac X A (pr1 aa) aa'))). { intros z z'. apply impred. intro. apply (pr2 (abmonoidfracrel _ _ _ _ _)). } apply (setquotuniv2prop _ (λ z z', make_hProp _ (int z z'))). intros xa1 xa2. change (abmonoidfracrelint X A L xa1 xa2 -> abmonoidfracrelint X A L (@op (abmonoiddirprod X A) xa1 (make_dirprod (pr1 aa) aa')) (@op (abmonoiddirprod X A) xa2 (make_dirprod (pr1 aa) aa'))). unfold abmonoidfracrelint. simpl. apply hinhfun. intro t2l. set (a := pr1 aa). set (a' := pr1 aa'). set (c0a := pr1 t2l). set (l := pr2 t2l). set (c0 := pr1 c0a). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). split with c0a. change (L (x1 + a + (a2 + a') + c0) (x2 + a + (a1 + a') + c0)). rewrite (rer _ a a2 _). rewrite (rer _ a a1 _). rewrite (assoc (x1 + a2) _ c0). rewrite (assoc (x2 + a1) _ c0). rewrite (comm _ c0). destruct (assoc (x1 + a2) c0 (a + a')). destruct (assoc (x2 + a1) c0 (a + a')). apply ((pr2 is) _ _ _ (pr2 (@op A aa aa'))). apply l. Defined. Opaque ispartrbinopabmonoidfracrel. Lemma abmonoidfracrelimpl (X : abmonoid) (A : subabmonoid X) {L L' : hrel X} (is : ispartbinophrel A L) (is' : ispartbinophrel A L') (impl : ∏ x x', L x x' -> L' x x') (x x' : abmonoidfrac X A) (ql : abmonoidfracrel X A is x x') : abmonoidfracrel X A is' x x'. Proof. generalize ql. apply quotrelimpl. intros x0 x0'. unfold abmonoidfracrelint. simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (impl _ _ (pr2 t2)). Defined. Opaque abmonoidfracrelimpl. Lemma abmonoidfracrellogeq (X : abmonoid) (A : subabmonoid X) {L L' : hrel X} (is : ispartbinophrel A L) (is' : ispartbinophrel A L') (lg : ∏ x x', L x x' <-> L' x x') (x x' : abmonoidfrac X A) : (abmonoidfracrel X A is x x') <-> (abmonoidfracrel X A is' x x'). Proof. apply quotrellogeq. intros x0 x0'. split. - unfold abmonoidfracrelint. simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (pr1 (lg _ _) (pr2 t2)). - unfold abmonoidfracrelint. simpl. apply hinhfun. intro t2. split with (pr1 t2). apply (pr2 (lg _ _) (pr2 t2)). Defined. Opaque abmonoidfracrellogeq. Definition isdecabmonoidfracrelint (X : abmonoid) (A : subabmonoid X) {L : hrel X} (is : ispartinvbinophrel A L) (isl : isdecrel L) : isdecrel (abmonoidfracrelint X A L). Proof. intros xa1 xa2. set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). assert (int : coprod (L (x1 + a2) (x2 + a1)) (neg (L (x1 + a2) (x2 + a1)))) by apply (isl _ _). destruct int as [ l | nl ]. - apply ii1. unfold abmonoidfracrelint. apply hinhpr. split with (unel A). rewrite (runax X _). rewrite (runax X _). apply l. - apply ii2. generalize nl. clear nl. apply negf. unfold abmonoidfracrelint. simpl. apply (@hinhuniv _ (make_hProp _ (pr2 (L _ _)))). intro t2l. destruct t2l as [ c0a l ]. simpl. apply ((pr2 is) _ _ _ (pr2 c0a) l). Defined. Definition isdecabmonoidfracrel (X : abmonoid) (A : submonoid X) {L : hrel X} (is : ispartbinophrel A L) (isi : ispartinvbinophrel A L) (isl : isdecrel L) : isdecrel (abmonoidfracrel X A is). Proof. apply isdecquotrel. apply isdecabmonoidfracrelint. - apply isi. - apply isl. Defined. (** **** Relations and the canonical homomorphism to [abmonoidfrac] *) Lemma iscomptoabmonoidfrac (X : abmonoid) (A : submonoid X) {L : hrel X} (is : ispartbinophrel A L) : iscomprelrelfun L (abmonoidfracrel X A is) (toabmonoidfrac X A). Proof. unfold iscomprelrelfun. intros x x' l. change (abmonoidfracrelint X A L (make_dirprod x (unel A)) (make_dirprod x' (unel A))). simpl. apply (hinhpr). split with (unel A). apply ((pr2 is) _ _ 0). apply (pr2 (unel A)). apply ((pr2 is) _ _ 0). apply (pr2 (unel A)). apply l. Defined. Opaque iscomptoabmonoidfrac. Close Scope addmonoid_scope. UniMath-20231010/UniMath/Algebra/README.md000066400000000000000000000003701451125700300174700ustar00rootroot00000000000000Algebra ======= ## GroupAction.v Generalities about groups G acting on sets, including the structure identity principle. Definition of torsor. Definition of BG and its covering space EG. Proof (using univalence) that the loop space of BG is G. UniMath-20231010/UniMath/Algebra/RigsAndRings.v000066400000000000000000003250401451125700300207360ustar00rootroot00000000000000(** * Algebra I. Part D. Rigs and rings. Vladimir Voevodsky. Aug. 2011 - . *) Require Import UniMath.Algebra.Groups. (** Contents - Standard Algebraic Structures - Rigs - semirings with 1, 0, and x * 0 = 0 * x = 0 - General definitions - Homomorphisms of rigs (rig functions) - Relations similar to "greater" or "greater or equal" on rigs - Subobjects - Quotient objects - Direct products - Opposite rigs - Nonzero rigs - Group of units - Commutative rigs - General definitions - Relations similar to "greater" on commutative rigs - Subobjects - Quotient objects - Direct products - Opposite commutative rigs - Rings - General definitions - Homomorphisms of rings - Computation lemmas for rings - Relations compatible with the additive structure on rings - Relations compatible with the multiplicative structure on rings - Relations "inversely compatible" with the multiplicative structure on rings - Relations on rings and ring homomorphisms - Subobjects - Quotient objects - Direct products - Opposite rings - Ring of differences associated with a rig - Canonical homomorphism to the ring associated with a rig (ring of differences) - Relations similar to "greater" or "greater or equal" on the ring associated with a rig - Relations and the canonical homomorphism to the ring associated with a rig (ring of differences) - Commutative rings - General definitions - Computational lemmas for commutative rings - Subobjects - Quotient objects - Direct products - Opposite commutative rings - Commutative rigs to commutative rings - Rings of fractions - Canonical homomorphism to the ring of fractions - Ring of fractions in the case when all elements which are being inverted are cancelable - Relations similar to "greater" or "greater or equal" on the rings of fractions - Relations and the canonical homomorphism to the ring of fractions *) (** ** Preamble *) (** Settings *) Unset Kernel Term Sharing. (** Imports *) Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.Orders. Require Export UniMath.Algebra.Monoids. Local Open Scope logic. (** To upstream files *) (** ** Standard Algebraic Structures (cont.) *) (** *** Rigs - semirings with 1, 0 and x * 0 = 0 * x = 0 *) (** **** General definitions *) Definition rig : UU := total2 (λ X : setwith2binop, isrigops (@op1 X) (@op2 X)). Definition make_rig {X : setwith2binop} (is : isrigops (@op1 X) (@op2 X)) : rig := tpair (λ X : setwith2binop, isrigops (@op1 X) (@op2 X)) X is. Definition pr1rig : rig -> setwith2binop := @pr1 _ (λ X : setwith2binop, isrigops (@op1 X) (@op2 X)). Coercion pr1rig : rig >-> setwith2binop. Definition rigaxs (X : rig) : isrigops (@op1 X) (@op2 X) := pr2 X. Definition rigop1axs (X : rig) : isabmonoidop (@op1 X) := rigop1axs_is (pr2 X). Definition rigassoc1 (X : rig) : isassoc (@op1 X) := assocax_is (rigop1axs X). Definition rigunel1 {X : rig} : X := unel_is (rigop1axs X). Definition riglunax1 (X : rig) : islunit op1 (@rigunel1 X) := lunax_is (rigop1axs X). Definition rigrunax1 (X : rig) : isrunit op1 (@rigunel1 X) := runax_is (rigop1axs X). Definition rigmult0x (X : rig) : ∏ x : X, paths (op2 (@rigunel1 X) x) (@rigunel1 X) := rigmult0x_is (pr2 X). Definition rigmultx0 (X : rig) : ∏ x : X, paths (op2 x (@rigunel1 X)) (@rigunel1 X) := rigmultx0_is (pr2 X). Definition rigcomm1 (X : rig) : iscomm (@op1 X) := commax_is (rigop1axs X). Definition rigop2axs (X : rig) : ismonoidop (@op2 X) := rigop2axs_is (pr2 X). Definition rigassoc2 (X : rig) : isassoc (@op2 X) := assocax_is (rigop2axs X). Definition rigunel2 {X : rig} : X := unel_is (rigop2axs X). Definition riglunax2 (X : rig) : islunit op2 (@rigunel2 X) := lunax_is (rigop2axs X). Definition rigrunax2 (X : rig) : isrunit op2 (@rigunel2 X) := runax_is (rigop2axs X). Definition rigdistraxs (X : rig) : isdistr (@op1 X) (@op2 X) := pr2 (pr2 X). Definition rigldistr (X : rig) : isldistr (@op1 X) (@op2 X) := pr1 (pr2 (pr2 X)). Definition rigrdistr (X : rig) : isrdistr (@op1 X) (@op2 X) := pr2 (pr2 (pr2 X)). Definition rigconstr {X : hSet} (opp1 opp2 : binop X) (ax11 : ismonoidop opp1) (ax12 : iscomm opp1) (ax2 : ismonoidop opp2) (m0x : ∏ x : X, paths (opp2 (unel_is ax11) x) (unel_is ax11)) (mx0 : ∏ x : X, paths (opp2 x (unel_is ax11)) (unel_is ax11)) (dax : isdistr opp1 opp2) : rig. Proof. intros. split with (make_setwith2binop X (make_dirprod opp1 opp2)). split. - split with (make_dirprod (make_dirprod ax11 ax12) ax2). apply (make_dirprod m0x mx0). - apply dax. Defined. Definition rigaddabmonoid (X : rig) : abmonoid := make_abmonoid (make_setwithbinop X op1) (rigop1axs X). Definition rigmultmonoid (X : rig) : monoid := make_monoid (make_setwithbinop X op2) (rigop2axs X). Declare Scope rig_scope. Notation "x + y" := (op1 x y) : rig_scope. Notation "x * y" := (op2 x y) : rig_scope. Notation "0" := (rigunel1) : rig_scope. Notation "1" := (rigunel2) : rig_scope. Delimit Scope rig_scope with rig. (** **** Homomorphisms of rigs (rig functions) *) Definition isrigfun {X Y : rig} (f : X -> Y) : UU := dirprod (@ismonoidfun (rigaddabmonoid X) (rigaddabmonoid Y) f) (@ismonoidfun (rigmultmonoid X) (rigmultmonoid Y) f). Definition make_isrigfun {X Y : rig} {f : X -> Y} (H1 : @ismonoidfun (rigaddabmonoid X) (rigaddabmonoid Y) f) (H2 : @ismonoidfun (rigmultmonoid X) (rigmultmonoid Y) f) : isrigfun f := make_dirprod H1 H2. Definition isrigfunisaddmonoidfun {X Y : rig} {f : X -> Y} (H : isrigfun f) : @ismonoidfun (rigaddabmonoid X) (rigaddabmonoid Y) f := dirprod_pr1 H. Definition isrigfunismultmonoidfun {X Y : rig} {f : X -> Y} (H : isrigfun f) : @ismonoidfun (rigmultmonoid X) (rigmultmonoid Y) f := dirprod_pr2 H. Lemma isapropisrigfun {X Y : rig} (f : X -> Y) : isaprop (isrigfun f). Proof. use isapropdirprod. - use isapropismonoidfun. - use isapropismonoidfun. Defined. Opaque isapropisrigfun. Definition rigfun (X Y : rig) : UU := total2 (fun f : X -> Y => isrigfun f). Definition isasetrigfun (X Y : rig) : isaset (rigfun X Y). Proof. use isaset_total2. - use isaset_set_fun_space. - intros x. use isasetaprop. use isapropisrigfun. Defined. Opaque isasetrigfun. Definition rigfunconstr {X Y : rig} {f : X -> Y} (is : isrigfun f) : rigfun X Y := tpair _ f is. Definition pr1rigfun (X Y : rig) : rigfun X Y -> (X -> Y) := @pr1 _ _. Coercion pr1rigfun : rigfun >-> Funclass. Definition rigaddfun {X Y : rig} (f : rigfun X Y) : monoidfun (rigaddabmonoid X) (rigaddabmonoid Y) := monoidfunconstr (pr1 (pr2 f)). Definition rigmultfun {X Y : rig} (f : rigfun X Y) : monoidfun (rigmultmonoid X) (rigmultmonoid Y) := monoidfunconstr (pr2 (pr2 f)). Definition rigfun_to_unel_rigaddmonoid {X Y : rig} (f : rigfun X Y) : f (0%rig) = 0%rig := pr2 (pr1 (pr2 f)). Definition rigfuncomp {X Y Z : rig} (f : rigfun X Y) (g : rigfun Y Z) : rigfun X Z. Proof. use rigfunconstr. - exact (g ∘ f). - use make_isrigfun. + exact (pr2 (monoidfuncomp (rigaddfun f) (rigaddfun g))). + exact (pr2 (monoidfuncomp (rigmultfun f) (rigmultfun g))). Defined. Lemma rigfun_paths {X Y : rig} (f g : rigfun X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropisrigfun. Defined. Opaque rigfun_paths. Definition rigiso (X Y : rig) : UU := total2 (λ f : X ≃ Y, isrigfun f). Definition make_rigiso {X Y : rig} (f : X ≃ Y) (is : isrigfun f) : rigiso X Y := tpair _ f is. Definition pr1rigiso (X Y : rig) : rigiso X Y -> X ≃ Y := @pr1 _ _. Coercion pr1rigiso : rigiso >-> weq. Definition rigisoisrigfun {X Y : rig} (f : rigiso X Y) : isrigfun f := pr2 f. Definition rigaddiso {X Y : rig} (f : rigiso X Y) : monoidiso (rigaddabmonoid X) (rigaddabmonoid Y) := @make_monoidiso (rigaddabmonoid X) (rigaddabmonoid Y) (pr1 f) (pr1 (pr2 f)). Definition rigmultiso {X Y : rig} (f : rigiso X Y) : monoidiso (rigmultmonoid X) (rigmultmonoid Y) := @make_monoidiso (rigmultmonoid X) (rigmultmonoid Y) (pr1 f) (pr2 (pr2 f)). Definition rigiso_paths {X Y : rig} (f g : rigiso X Y) (e : pr1 f = pr1 g) : f = g. Proof. use total2_paths_f. - exact e. - use proofirrelevance. use isapropisrigfun. Defined. Opaque rigiso_paths. Definition rigisotorigfun {X Y : rig} (f : rigiso X Y) : rigfun X Y := rigfunconstr (pr2 f). Lemma isrigfuninvmap {X Y : rig} (f : rigiso X Y) : isrigfun (invmap f). Proof. intros. split. - apply (ismonoidfuninvmap (rigaddiso f)). - apply (ismonoidfuninvmap (rigmultiso f)). Defined. Definition invrigiso {X Y : rig} (f : rigiso X Y) : rigiso Y X := make_rigiso (invweq f) (isrigfuninvmap f). Definition idrigiso (X : rig) : rigiso X X. Proof. use make_rigiso. - exact (idweq X). - use make_isrigfun. + use make_ismonoidfun. * use make_isbinopfun. intros x x'. use idpath. * use idpath. + use make_ismonoidfun. * use make_isbinopfun. intros x x'. use idpath. * use idpath. Defined. (** **** (X = Y) ≃ (rigiso X Y) We use the following composition (X = Y) ≃ (X ╝ Y) ≃ (rigiso' X Y) ≃ (rigiso X Y) where the second weak equivalence is given by univalence for setwith2binop, [setwith2binop_univalence]. The reason to define rigiso' is that it allows us to use [setwith2binop_univalence]. *) Local Definition rigiso' (X Y : rig) : UU := ∑ D : (∑ w : X ≃ Y, istwobinopfun w), ((pr1 D) (@rigunel1 X) = @rigunel1 Y) × ((pr1 D) (@rigunel2 X) = @rigunel2 Y). Local Definition make_rigiso' (X Y : rig) (w : X ≃ Y) (H1 : istwobinopfun w) (H2 : w (@rigunel1 X) = @rigunel1 Y) (H3 : w (@rigunel2 X) = @rigunel2 Y) : rigiso' X Y := tpair _ (tpair _ w H1) (make_dirprod H2 H3). Definition rig_univalence_weq1 (X Y : rig) : (X = Y) ≃ (X ╝ Y) := total2_paths_equiv _ _ _. Definition rig_univalence_weq2 (X Y : rig) : (X ╝ Y) ≃ (rigiso' X Y). Proof. use weqbandf. - exact (setwith2binop_univalence X Y). - intros e. cbn. use invweq. induction X as [X Xop]. induction Y as [Y Yop]. cbn in e. cbn. induction e. use weqimplimpl. + intros i. use proofirrelevance. use isapropisrigops. + intros i. use make_dirprod. * induction i. use idpath. * induction i. use idpath. + use isapropdirprod. * use setproperty. * use setproperty. + use isapropifcontr. exact (@isapropisrigops X op1 op2 Xop Yop). Defined. Opaque rig_univalence_weq2. Definition rig_univalence_weq3 (X Y : rig) : (rigiso' X Y) ≃ (rigiso X Y). Proof. use make_weq. - intros i'. use make_rigiso. + exact (pr1 (pr1 i')). + use make_isrigfun. * use make_ismonoidfun. -- use make_isbinopfun. exact (dirprod_pr1 (pr2 (pr1 i'))). -- exact (dirprod_pr1 (pr2 i')). * use make_ismonoidfun. -- use make_isbinopfun. exact (dirprod_pr2 (pr2 (pr1 i'))). -- exact (dirprod_pr2 (pr2 i')). - use isweq_iso. + intros i. use make_rigiso'. * exact (pr1rigiso _ _ i). * use make_istwobinopfun. -- exact (ismonoidfunisbinopfun (isrigfunisaddmonoidfun (rigisoisrigfun i))). -- exact (ismonoidfunisbinopfun (isrigfunismultmonoidfun (rigisoisrigfun i))). * exact (ismonoidfununel (isrigfunisaddmonoidfun (rigisoisrigfun i))). * exact (ismonoidfununel (isrigfunismultmonoidfun (rigisoisrigfun i))). + intros x. use idpath. + intros x. use idpath. Defined. Opaque rig_univalence_weq3. Definition rig_univlalence_map (X Y : rig) : X = Y → rigiso X Y. Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma rig_univalence_isweq (X Y : rig) : isweq (rig_univlalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (rig_univalence_weq1 X Y) (weqcomp (rig_univalence_weq2 X Y) (rig_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque rig_univalence_isweq. Definition rig_univalence (X Y : rig) : (X = Y) ≃ (rigiso X Y). Proof. use make_weq. - exact (rig_univlalence_map X Y). - exact (rig_univalence_isweq X Y). Defined. Opaque rig_univalence. (** **** Relations similar to "greater" or "greater or equal" on rigs *) Definition isrigmultgt (X : rig) (R : hrel X) := ∏ (a b c d : X), R a b -> R c d -> R (op1 (op2 a c) (op2 b d)) (op1 (op2 a d) (op2 b c)). Definition isinvrigmultgt (X : rig) (R : hrel X) : UU := dirprod (∏ (a b c d : X), R (op1 (op2 a c) (op2 b d)) (op1 (op2 a d) (op2 b c)) -> R a b -> R c d) (∏ (a b c d : X), R (op1 (op2 a c) (op2 b d)) (op1 (op2 a d) (op2 b c)) -> R c d -> R a b). (** **** Subobjects *) Definition issubrig {X : rig} (A : hsubtype X) : UU := dirprod (@issubmonoid (rigaddabmonoid X) A) (@issubmonoid (rigmultmonoid X) A). Lemma isapropissubrig {X : rig} (A : hsubtype X) : isaprop (issubrig A). Proof. intros. apply (isofhleveldirprod 1). - apply isapropissubmonoid. - apply isapropissubmonoid. Defined. Definition subrig (X : rig) : UU := total2 (λ A : hsubtype X, issubrig A). Definition make_subrig {X : rig} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubrig A) t → ∑ A : hsubtype X, issubrig A := tpair (λ A : hsubtype X, issubrig A). Definition pr1subrig (X : rig) : @subrig X -> hsubtype X := @pr1 _ (λ A : hsubtype X, issubrig A). Definition subrigtosubsetswith2binop (X : rig) : subrig X -> @subsetswith2binop X := λ A : _, make_subsetswith2binop (pr1 A) (make_dirprod (pr1 (pr1 (pr2 A))) (pr1 (pr2 (pr2 A)))). Coercion subrigtosubsetswith2binop : subrig >-> subsetswith2binop. Definition rigaddsubmonoid {X : rig} : subrig X -> @subabmonoid (rigaddabmonoid X) := λ A : _, @make_submonoid (rigaddabmonoid X) (pr1 A) (pr1 (pr2 A)). Definition rigmultsubmonoid {X : rig} : subrig X -> @submonoid (rigmultmonoid X) := λ A : _, @make_submonoid (rigmultmonoid X) (pr1 A) (pr2 (pr2 A)). Lemma isrigcarrier {X : rig} (A : subrig X) : isrigops (@op1 A) (@op2 A). Proof. intros. split. - split with (make_dirprod (isabmonoidcarrier (rigaddsubmonoid A)) (ismonoidcarrier (rigmultsubmonoid A))). + split. * intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply rigmult0x. * intro a. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply rigmultx0. - split. * intros a b c. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply rigldistr. * intros a b c. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply rigrdistr. Defined. Definition carrierofasubrig (X : rig) (A : subrig X) : rig. Proof. intros. split with A. apply isrigcarrier. Defined. Coercion carrierofasubrig : subrig >-> rig. (** **** Quotient objects *) Definition rigeqrel {X : rig} : UU := @twobinopeqrel X. Identity Coercion id_rigeqrel : rigeqrel >-> twobinopeqrel. Definition addabmonoideqrel {X : rig} (R : @rigeqrel X) : @binopeqrel (rigaddabmonoid X) := @make_binopeqrel (rigaddabmonoid X) (pr1 R) (pr1 (pr2 R)). Definition multmonoideqrel {X : rig} (R : @rigeqrel X) : @binopeqrel (rigmultmonoid X) := @make_binopeqrel (rigmultmonoid X) (pr1 R) (pr2 (pr2 R)). Lemma isrigquot {X : rig} (R : @rigeqrel X) : isrigops (@op1 (setwith2binopquot R)) (@op2 (setwith2binopquot R)). Proof. intros. split. - split with (make_dirprod (isabmonoidquot (addabmonoideqrel R)) (ismonoidquot (multmonoideqrel R))). set (opp1 := @op1 (setwith2binopquot R)). set (opp2 := @op2 (setwith2binopquot R)). set (zr := setquotpr R (@rigunel1 X)). split. + apply (setquotunivprop R (λ x , make_hProp _ (setproperty (setwith2binopquot R) (opp2 zr x) zr))). intro x. apply (maponpaths (setquotpr R) (rigmult0x X x)). + apply (setquotunivprop R (λ x , make_hProp _ (setproperty (setwith2binopquot R) (opp2 x zr) zr))). intro x. apply (maponpaths (setquotpr R) (rigmultx0 X x)). - set (opp1 := @op1 (setwith2binopquot R)). set (opp2 := @op2 (setwith2binopquot R)). split. + unfold isldistr. apply (setquotuniv3prop R (λ x x' x'', make_hProp _ (setproperty (setwith2binopquot R) (opp2 x'' (opp1 x x')) (opp1 (opp2 x'' x) (opp2 x'' x'))))). intros x x' x''. apply (maponpaths (setquotpr R) (rigldistr X x x' x'')). + unfold isrdistr. apply (setquotuniv3prop R (λ x x' x'', make_hProp _ (setproperty (setwith2binopquot R) (opp2 (opp1 x x') x'') (opp1 (opp2 x x'') (opp2 x' x''))))). intros x x' x''. apply (maponpaths (setquotpr R) (rigrdistr X x x' x'')). Defined. Definition rigquot {X : rig} (R : @rigeqrel X) : rig := @make_rig (setwith2binopquot R) (isrigquot R). (** **** Direct products *) Lemma isrigdirprod (X Y : rig) : isrigops (@op1 (setwith2binopdirprod X Y)) (@op2 (setwith2binopdirprod X Y)). Proof. intros. split. - split with (make_dirprod (isabmonoiddirprod (rigaddabmonoid X) (rigaddabmonoid Y)) (ismonoiddirprod (rigmultmonoid X) (rigmultmonoid Y))). simpl. split. + intro xy. unfold setwith2binopdirprod. unfold op1. unfold op2. unfold ismonoiddirprod. unfold unel_is. simpl. apply pathsdirprod. apply (rigmult0x X). apply (rigmult0x Y). + intro xy. unfold setwith2binopdirprod. unfold op1. unfold op2. unfold ismonoiddirprod. unfold unel_is. simpl. apply pathsdirprod. apply (rigmultx0 X). apply (rigmultx0 Y). - split. + intros xy xy' xy''. unfold setwith2binopdirprod. unfold op1. unfold op2. simpl. apply pathsdirprod. apply (rigldistr X). apply (rigldistr Y). + intros xy xy' xy''. unfold setwith2binopdirprod. unfold op1. unfold op2. simpl. apply pathsdirprod. apply (rigrdistr X). apply (rigrdistr Y). Defined. Definition rigdirprod (X Y : rig) : rig := @make_rig (setwith2binopdirprod X Y) (isrigdirprod X Y). (** **** Opposite rigs *) Local Open Scope rig. (** Following Bourbaki's Algebra, I, §8.3, Example V *) Definition opposite_rig (X : rig) : rig. Proof. (* Use the same underlying set and addition, flip the multiplication *) refine (make_setwith2binop (pr1 (pr1rig X)) (make_dirprod (pr1 (pr2 (pr1rig X))) (fun x y => y * x)%rig),, _). unfold op2; cbn; fold (@op1 X) (@op2 X). apply (make_isrigops (rigop1axs X)). (* For these proofs, we just have to switch some arguments around *) - apply make_ismonoidop. * exact (fun x y z => !(rigassoc2 _ z y x)). * refine (1,, _). (* same unit, opposite proofs *) exact (make_dirprod (rigrunax2 _) (riglunax2 _)). - exact (rigmultx0 _). - exact (rigmult0x _). - exact (make_dirprod (rigrdistr _) (rigldistr _)). Defined. (** In Emacs, use the function insert-char and choose SUPERSCRIPT ZERO *) Notation "X ⁰" := (opposite_rig X) (at level 12) : rig_scope. Definition opposite_opposite_rig (X : rig) : rigiso X ((X⁰)⁰). Proof. refine ((idfun X,, idisweq X),, _). repeat split. Defined. (** **** Nonzero rigs *) Definition isnonzerorig (X : rig) : hProp. Proof. intros; use make_hProp. - exact (¬ (@paths X 1 0)). - apply isapropneg. Defined. Local Close Scope rig. (** *** Commutative rigs *) (** **** General definitions *) Definition commrig : UU := total2 (λ X : setwith2binop, iscommrigops (@op1 X) (@op2 X)). Definition make_commrig (X : setwith2binop) (is : iscommrigops (@op1 X) (@op2 X)) : commrig := tpair (λ X : setwith2binop, iscommrigops (@op1 X) (@op2 X)) X is. Definition commrigconstr {X : hSet} (opp1 opp2 : binop X) (ax11 : ismonoidop opp1) (ax12 : iscomm opp1) (ax2 : ismonoidop opp2) (ax22 : iscomm opp2) (m0x : ∏ x : X, paths (opp2 (unel_is ax11) x) (unel_is ax11)) (mx0 : ∏ x : X, paths (opp2 x (unel_is ax11)) (unel_is ax11)) (dax : isdistr opp1 opp2) : commrig. Proof. intros. split with (make_setwith2binop X (make_dirprod opp1 opp2)). split. - split. + split with (make_dirprod (make_dirprod ax11 ax12) ax2). apply (make_dirprod m0x mx0). + apply dax. - apply ax22. Defined. Definition commrigtorig : commrig -> rig := λ X : _, @make_rig (pr1 X) (pr1 (pr2 X)). Coercion commrigtorig : commrig >-> rig. Definition rigcomm2 (X : commrig) : iscomm (@op2 X) := pr2 (pr2 X). Definition commrigop2axs (X : commrig) : isabmonoidop (@op2 X) := tpair _ (rigop2axs X) (rigcomm2 X). Definition commrigmultabmonoid (X : commrig) : abmonoid := make_abmonoid (make_setwithbinop X op2) (make_dirprod (rigop2axs X) (rigcomm2 X)). (** **** (X = Y) ≃ (rigiso X Y) We use the following composition (X = Y) ≃ (make_commrig' X = make_commrig' Y) ≃ ((pr1 (make_commrig' X)) = (pr1 (make_commrig' Y))) ≃ (rigiso X Y) where the third weak equivalence uses univalence for rigs, [rig_univalence]. We define [commrig'] to be able to apply it. *) Local Definition commrig' : UU := ∑ D : (∑ X : setwith2binop, isrigops (@op1 X) (@op2 X)), iscomm (@op2 (pr1 D)). Local Definition make_commrig' (CR : commrig) : commrig' := tpair _ (tpair _ (pr1 CR) (dirprod_pr1 (pr2 CR))) (dirprod_pr2 (pr2 CR)). Definition commrig_univalence_weq1 : commrig ≃ commrig' := weqtotal2asstol (λ X : setwith2binop, isrigops (@op1 X) (@op2 X)) (fun y : (∑ (X : setwith2binop), isrigops (@op1 X) (@op2 X)) => iscomm (@op2 (pr1 y))). Definition commrig_univalence_weq1' (X Y : commrig) : (X = Y) ≃ (make_commrig' X = make_commrig' Y) := make_weq _ (@isweqmaponpaths commrig commrig' commrig_univalence_weq1 X Y). Definition commrig_univalence_weq2 (X Y : commrig) : ((make_commrig' X) = (make_commrig' Y)) ≃ ((pr1 (make_commrig' X)) = (pr1 (make_commrig' Y))). Proof. use subtypeInjectivity. intros w. use isapropiscomm. Defined. Opaque commrig_univalence_weq2. Definition commrig_univalence_weq3 (X Y : commrig) : ((pr1 (make_commrig' X)) = (pr1 (make_commrig' Y))) ≃ (rigiso X Y) := rig_univalence (pr1 (make_commrig' X)) (pr1 (make_commrig' Y)). Definition commrig_univalence_map (X Y : commrig) : (X = Y) -> (rigiso X Y). Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma commrig_univalence_isweq (X Y : commrig) : isweq (commrig_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (commrig_univalence_weq1' X Y) (weqcomp (commrig_univalence_weq2 X Y) (commrig_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque commrig_univalence_isweq. Definition commrig_univalence (X Y : commrig) : (X = Y) ≃ (rigiso X Y). Proof. use make_weq. - exact (commrig_univalence_map X Y). - exact (commrig_univalence_isweq X Y). Defined. Opaque commrig_univalence. (** **** Relations similar to "greater" on commutative rigs *) Lemma isinvrigmultgtif (X : commrig) (R : hrel X) (is2 : ∏ a b c d, R (op1 (op2 a c) (op2 b d)) (op1 (op2 a d) (op2 b c)) -> R a b -> R c d) : isinvrigmultgt X R. Proof. intros. split. - apply is2. - intros a b c d r rcd. rewrite (rigcomm1 X (op2 a d) _) in r. rewrite (rigcomm2 X a c) in r. rewrite (rigcomm2 X b d) in r. rewrite (rigcomm2 X b c) in r. rewrite (rigcomm2 X a d) in r. apply (is2 _ _ _ _ r rcd). Defined. (** **** Subobjects *) Lemma iscommrigcarrier {X : commrig} (A : @subrig X) : iscommrigops (@op1 A) (@op2 A). Proof. intros. split with (isrigcarrier A). apply (pr2 (@isabmonoidcarrier (commrigmultabmonoid X) (rigmultsubmonoid A))). Defined. (* ??? slows down at the last [ apply ] and at [ Defined ] (oct.16.2011 - does not slow down anymore with two Dan's patches) *) Definition carrierofasubcommrig {X : commrig} (A : @subrig X) : commrig := make_commrig A (iscommrigcarrier A). (** **** Quotient objects *) Lemma iscommrigquot {X : commrig} (R : @rigeqrel X) : iscommrigops (@op1 (setwith2binopquot R)) (@op2 (setwith2binopquot R)). Proof. intros. split with (isrigquot R). apply (pr2 (@isabmonoidquot (commrigmultabmonoid X) (multmonoideqrel R))). Defined. Definition commrigquot {X : commrig} (R : @rigeqrel X) : commrig := make_commrig (setwith2binopquot R) (iscommrigquot R). (** **** Direct products *) Lemma iscommrigdirprod (X Y : commrig) : iscommrigops (@op1 (setwith2binopdirprod X Y)) (@op2 (setwith2binopdirprod X Y)). Proof. intros. split with (isrigdirprod X Y). apply (pr2 (isabmonoiddirprod (commrigmultabmonoid X) (commrigmultabmonoid Y))). Defined. Definition commrigdirprod (X Y : commrig) : commrig := make_commrig (setwith2binopdirprod X Y) (iscommrigdirprod X Y). (** **** Opposite commutative rigs *) Local Open Scope rig. (** We reuse much of the proof for general rigs *) Definition opposite_commrig (X : commrig) : commrig := ((pr1 (X⁰)),, (make_dirprod (pr2 (X⁰)) (fun x y => @rigcomm2 X y x))). (** Commutativity makes taking the opposite trivial *) Definition iso_commrig_opposite (X : commrig) : rigiso X (opposite_commrig X). Proof. refine ((idfun X,, idisweq X),, _). repeat split. unfold isbinopfun. exact (fun x y => @rigcomm2 X x y). Defined. Local Close Scope rig. (** *** Rings *) (** **** General definitions *) Definition ring : UU := total2 (λ X : setwith2binop, isringops (@op1 X) (@op2 X)). Definition make_ring {X : setwith2binop} (is : isringops (@op1 X) (@op2 X)) : ring := tpair (λ X : setwith2binop, isringops (@op1 X) (@op2 X)) X is. Definition pr1ring : ring -> setwith2binop := @pr1 _ (λ X : setwith2binop, isringops (@op1 X) (@op2 X)). Coercion pr1ring : ring >-> setwith2binop. Definition ringaxs (X : ring) : isringops (@op1 X) (@op2 X) := pr2 X. Definition ringop1axs (X : ring) : isabgrop (@op1 X) := pr1 (pr1 (pr2 X)). Definition ringassoc1 (X : ring) : isassoc (@op1 X) := assocax_is (ringop1axs X). Definition ringunel1 {X : ring} : X := unel_is (ringop1axs X). Definition ringlunax1 (X : ring) : islunit op1 (@ringunel1 X) := lunax_is (ringop1axs X). Definition ringrunax1 (X : ring) : isrunit op1 (@ringunel1 X) := runax_is (ringop1axs X). Definition ringinv1 {X : ring} : X -> X := grinv_is (ringop1axs X). Definition ringlinvax1 (X : ring) : ∏ x : X, paths (op1 (ringinv1 x) x) ringunel1 := grlinvax_is (ringop1axs X). Definition ringrinvax1 (X : ring) : ∏ x : X, paths (op1 x (ringinv1 x)) ringunel1 := grrinvax_is (ringop1axs X). Definition ringcomm1 (X : ring) : iscomm (@op1 X) := commax_is (ringop1axs X). Definition ringop2axs (X : ring) : ismonoidop (@op2 X) := pr2 (pr1 (pr2 X)). Definition ringassoc2 (X : ring) : isassoc (@op2 X) := assocax_is (ringop2axs X). Definition ringunel2 {X : ring} : X := unel_is (ringop2axs X). Definition ringlunax2 (X : ring) : islunit op2 (@ringunel2 X) := lunax_is (ringop2axs X). Definition ringrunax2 (X : ring) : isrunit op2 (@ringunel2 X) := runax_is (ringop2axs X). Definition ringdistraxs (X : ring) : isdistr (@op1 X) (@op2 X) := pr2 (pr2 X). Definition ringldistr (X : ring) : isldistr (@op1 X) (@op2 X) := pr1 (pr2 (pr2 X)). Definition ringrdistr (X : ring) : isrdistr (@op1 X) (@op2 X) := pr2 (pr2 (pr2 X)). Definition ringconstr {X : hSet} (opp1 opp2 : binop X) (ax11 : isgrop opp1) (ax12 : iscomm opp1) (ax2 : ismonoidop opp2) (dax : isdistr opp1 opp2) : ring := @make_ring (make_setwith2binop X (make_dirprod opp1 opp2)) (make_dirprod (make_dirprod (make_dirprod ax11 ax12) ax2) dax). Definition ringmultx0 (X : ring) : ∏ x : X, (op2 x ringunel1) = ringunel1 := ringmultx0_is (ringaxs X). Definition ringmult0x (X : ring) : ∏ x : X, (op2 ringunel1 x) = ringunel1 := ringmult0x_is (ringaxs X). Definition ringminus1 {X : ring} : X := ringminus1_is (ringaxs X). Definition ringmultwithminus1 (X : ring) : ∏ x : X, paths (op2 ringminus1 x) (ringinv1 x) := ringmultwithminus1_is (ringaxs X). Definition ringaddabgr (X : ring) : abgr := make_abgr (make_setwithbinop X op1) (ringop1axs X). Coercion ringaddabgr : ring >-> abgr. Definition ringmultmonoid (X : ring) : monoid := make_monoid (make_setwithbinop X op2) (ringop2axs X). Declare Scope ring_scope. Notation "x + y" := (op1 x y) : ring_scope. Notation "x - y" := (op1 x (ringinv1 y)) : ring_scope. Notation "x * y" := (op2 x y) : ring_scope. Notation "0" := (ringunel1) : ring_scope. Notation "1" := (ringunel2) : ring_scope. Notation "-1" := (ringminus1) (at level 0) : ring_scope. Notation " - x " := (ringinv1 x) : ring_scope. Delimit Scope ring_scope with ring. Definition ringtorig (X : ring) : rig := @make_rig _ (pr2 X). Coercion ringtorig : ring >-> rig. (** **** Homomorphisms of rings *) Definition isringfun {X Y : ring} (f : X -> Y) := @isrigfun X Y f. Definition ringfun (X Y : ring) := rigfun X Y. Lemma isaset_ringfun (X Y : ring) : isaset (ringfun X Y). Proof. apply (isofhleveltotal2 2). - use impred_isaset. intro x. apply setproperty. - intro f. apply isasetaprop. apply isapropisrigfun. Defined. Definition ringfunconstr {X Y : ring} {f : X -> Y} (is : isringfun f) : ringfun X Y := rigfunconstr is. Identity Coercion id_ringfun : ringfun >-> rigfun. Definition ringaddfun {X Y : ring} (f : ringfun X Y) : monoidfun X Y := monoidfunconstr (pr1 (pr2 f)). Definition ringmultfun {X Y : ring} (f : ringfun X Y) : monoidfun (ringmultmonoid X) (ringmultmonoid Y) := monoidfunconstr (pr2 (pr2 f)). Definition ringiso (X Y : ring) := rigiso X Y. Definition make_ringiso {X Y : ring} (f : X ≃ Y) (is : isringfun f) : ringiso X Y := tpair _ f is. Identity Coercion id_ringiso : ringiso >-> rigiso. Definition isringfuninvmap {X Y : ring} (f : ringiso X Y) : isringfun (invmap f) := isrigfuninvmap f. (** **** (X = Y) ≃ (ringiso X Y) We use the following composition (X = Y) ≃ (make_ring' X = make_ring' Y) ≃ ((pr1 (make_ring' X)) = (pr1 (make_ring' Y))) ≃ (ringiso X Y) where the third weak equivalence is given by univalence for rigs, [rig_univalence]. We define ring' to be able to apply [rig_univalence]. *) Local Definition ring' : UU := ∑ D : (∑ X : setwith2binop, isrigops (@op1 X) (@op2 X)), invstruct (@op1 (pr1 D)) (dirprod_pr1 (dirprod_pr1 (pr1 (pr1 (pr2 D))))). Local Definition make_ring' (R : ring) : ring'. Proof. use tpair. - use tpair. + exact (pr1 R). + use make_isrigops. * use make_isabmonoidop. -- exact (pr1 (dirprod_pr1 (dirprod_pr1 (dirprod_pr1 (pr2 R))))). -- exact (dirprod_pr2 (dirprod_pr1 (dirprod_pr1 (pr2 R)))). * exact (dirprod_pr2 (dirprod_pr1 (pr2 R))). * exact (@mult0x_is_l (pr1 R) (@op1 (pr1 R)) (@op2 (pr1 R)) (dirprod_pr1 (dirprod_pr1 (dirprod_pr1 (pr2 R)))) (dirprod_pr2 (dirprod_pr1 (pr2 R))) (dirprod_pr2 (pr2 R))). * exact (@multx0_is_l (pr1 R) (@op1 (pr1 R)) (@op2 (pr1 R)) (dirprod_pr1 (dirprod_pr1 (dirprod_pr1 (pr2 R)))) (dirprod_pr2 (dirprod_pr1 (pr2 R))) (dirprod_pr2 (pr2 R))). * exact (dirprod_pr2 (pr2 R)). - exact (pr2 (dirprod_pr1 (dirprod_pr1 (dirprod_pr1 (pr2 R))))). Defined. Local Definition make_ring_from_ring' (R : ring') : ring. Proof. use make_ring. - exact (pr1 (pr1 R)). - use make_isringops. + use make_isabgrop. * use make_isgrop. -- exact (dirprod_pr1 (dirprod_pr1 (pr1 (dirprod_pr1 (pr2 (pr1 R)))))). -- exact (pr2 R). * exact (dirprod_pr2 (dirprod_pr1 (pr1 (dirprod_pr1 (pr2 (pr1 R)))))). + exact (dirprod_pr2 (pr1 (dirprod_pr1 (pr2 (pr1 R))))). + exact (dirprod_pr2 (pr2 (pr1 R))). Defined. Definition ring_univalence_weq1 : ring ≃ ring'. Proof. use make_weq. - intros R. exact (make_ring' R). - use isweq_iso. + intros R'. exact (make_ring_from_ring' R'). + intros R. use idpath. + intros R'. use total2_paths_f. * use total2_paths_f. -- use idpath. -- use proofirrelevance. use isapropisrigops. * use proofirrelevance. use isapropinvstruct. Defined. Definition ring_univalence_weq1' (X Y : ring) : (X = Y) ≃ (make_ring' X = make_ring' Y) := make_weq _ (@isweqmaponpaths ring ring' ring_univalence_weq1 X Y). Definition ring_univalence_weq2 (X Y : ring) : ((make_ring' X) = (make_ring' Y)) ≃ ((pr1 (make_ring' X)) = (pr1 (make_ring' Y))). Proof. use subtypeInjectivity. intros w. use isapropinvstruct. Defined. Opaque ring_univalence_weq2. Definition ring_univalence_weq3 (X Y : ring) : ((pr1 (make_ring' X)) = (pr1 (make_ring' Y))) ≃ (rigiso X Y) := rig_univalence (pr1 (make_ring' X)) (pr1 (make_ring' Y)). Definition ring_univalence_map (X Y : ring) : (X = Y) -> (ringiso X Y). Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma ring_univalence_isweq (X Y : ring) : isweq (ring_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (ring_univalence_weq1' X Y) (weqcomp (ring_univalence_weq2 X Y) (ring_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque ring_univalence_isweq. Definition ring_univalence (X Y : ring) : (X = Y) ≃ (ringiso X Y). Proof. use make_weq. - exact (ring_univalence_map X Y). - exact (ring_univalence_isweq X Y). Defined. Opaque ring_univalence. (** **** Computation lemmas for rings *) Local Open Scope ring_scope. Definition ringinvunel1 (X : ring) : -0 = 0 := grinvunel X. Lemma ringismultlcancelableif (X : ring) (x : X) (isl : ∏ y, paths (x * y) 0 -> y = 0) : islcancelable op2 x. Proof. intros. apply (@isinclbetweensets X X). - apply setproperty. - apply setproperty. - intros x1 x2 e. set (e' := maponpaths (λ a, a + (x * (-x2))) e). simpl in e'. rewrite (pathsinv0 (ringldistr X _ _ x)) in e'. rewrite (pathsinv0 (ringldistr X _ _ x)) in e'. rewrite (ringrinvax1 X x2) in e'. rewrite (ringmultx0 X _) in e'. set (e'' := isl (x1 - x2) e'). set (e''' := maponpaths (λ a, a + x2) e''). simpl in e'''. rewrite (ringassoc1 X _ _ x2) in e'''. rewrite (ringlinvax1 X x2) in e'''. rewrite (ringlunax1 X _) in e'''. rewrite (ringrunax1 X _) in e'''. apply e'''. Defined. Opaque ringismultlcancelableif. Lemma ringismultrcancelableif (X : ring) (x : X) (isr : ∏ y, paths (y * x) 0 -> y = 0) : isrcancelable op2 x. Proof. intros. apply (@isinclbetweensets X X). - apply setproperty. - apply setproperty. - intros x1 x2 e. set (e' := maponpaths (λ a, a + ((-x2) * x)) e). simpl in e'. rewrite (pathsinv0 (ringrdistr X _ _ x)) in e'. rewrite (pathsinv0 (ringrdistr X _ _ x)) in e'. rewrite (ringrinvax1 X x2) in e'. rewrite (ringmult0x X _) in e'. set (e'' := isr (x1 - x2) e'). set (e''' := maponpaths (λ a, a + x2) e''). simpl in e'''. rewrite (ringassoc1 X _ _ x2) in e'''. rewrite (ringlinvax1 X x2) in e'''. rewrite (ringlunax1 X _) in e'''. rewrite (ringrunax1 X _) in e'''. apply e'''. Defined. Opaque ringismultrcancelableif. Lemma ringismultcancelableif (X : ring) (x : X) (isl : ∏ y, paths (x * y) 0 -> y = 0) (isr : ∏ y, paths (y * x) 0 -> y = 0) : iscancelable op2 x. Proof. intros. apply (make_dirprod (ringismultlcancelableif X x isl) (ringismultrcancelableif X x isr)). Defined. Lemma ringlmultminus (X : ring) (a b : X) : paths ((- a) * b) (- (a * b)). Proof. intros. apply (@grrcan X _ _ (a * b)). change (paths (-a * b + a * b) (- (a * b) + a * b)). rewrite (ringlinvax1 X _). rewrite (pathsinv0 (ringrdistr X _ _ _)). rewrite (ringlinvax1 X _). rewrite (ringmult0x X _). apply idpath. Defined. Opaque ringlmultminus. Lemma ringrmultminus (X : ring) (a b : X) : paths (a * (- b)) (- (a * b)). Proof. intros. apply (@grrcan X _ _ (a * b)). change (paths (a * (- b) + a * b) (- (a * b) + a * b)). rewrite (ringlinvax1 X _). rewrite (pathsinv0 (ringldistr X _ _ _)). rewrite (ringlinvax1 X _). rewrite (ringmultx0 X _). apply idpath. Defined. Opaque ringrmultminus. Lemma ringmultminusminus (X : ring) (a b : X) : paths (-a * - b) (a * b). Proof. intros. apply (@grrcan X _ _ (- a * b)). simpl. rewrite (pathsinv0 (ringldistr X _ _ (- a))). rewrite (pathsinv0 (ringrdistr X _ _ b)). rewrite (ringlinvax1 X b). rewrite (ringrinvax1 X a). rewrite (ringmult0x X _). rewrite (ringmultx0 X _). apply idpath. Defined. Opaque ringmultminusminus. Lemma ringminusminus (X : ring) (a : X) : --a = a. Proof. intros. apply (grinvinv X a). Defined. Definition ringinvmaponpathsminus (X : ring) {a b : X} : -a = -b -> a = b := grinvmaponpathsinv X. (** **** Relations compatible with the additive structure on rings *) Definition ringfromgt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) {x : X} (is : R x 0) : R 0 (- x) := grfromgtunel X is0 is. Definition ringtogt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) {x : X} (is : R 0 (- x)) : R x 0 := grtogtunel X is0 is. Definition ringfromlt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) {x : X} (is : R 0 x) : R (- x) 0 := grfromltunel X is0 is. Definition ringtolt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) {x : X} (is : R (- x) 0) : R 0 x := grtoltunel X is0 is. (** **** Relations compatible with the multiplicative structure on rings *) Definition isringmultgt (X : ring) (R : hrel X) : UU := ∏ a b, R a 0 -> R b 0 -> R (a * b) 0. Lemma ringmultgt0lt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) {x y : X} (isx : R x 0) (isy : R 0 y) : R 0 (x * y). Proof. intros. set (isy' := grfromltunel X is0 isy). assert (r := is _ _ isx isy'). change (pr1 (R (x * (- y)) 0)) in r. rewrite (ringrmultminus X _ _) in r. assert (r' := grfromgtunel X is0 r). change (pr1 (R 0 (- - (x * y)))) in r'. rewrite (ringminusminus X (x * y)) in r'. apply r'. Defined. Opaque ringmultgt0lt0. Lemma ringmultlt0gt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) {x y : X} (isx : R 0 x) (isy : R y 0) : R 0 (x * y). Proof. intros. set (isx' := grfromltunel X is0 isx). assert (r := is _ _ isx' isy). change (pr1 (R ((- x) * y) 0)) in r. rewrite (ringlmultminus X _ _) in r. assert (r' := grfromgtunel X is0 r). change (pr1 (R 0 (- - (x * y)))) in r'. rewrite (ringminusminus X (x * y)) in r'. apply r'. Defined. Opaque ringmultlt0gt0. Lemma ringmultlt0lt0 (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) {x y : X} (isx : R 0 x) (isy : R 0 y) : R (x * y) 0. Proof. intros. set (rx := ringfromlt0 _ is0 isx). assert (ry := ringfromlt0 _ is0 isy). assert (int := is _ _ rx ry). rewrite (ringmultminusminus X _ _) in int. apply int. Defined. Opaque ringmultlt0lt0. Lemma isringmultgttoislringmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) : ∏ a b c : X, R c 0 -> R a b -> R (c * a) (c * b). Proof. intros a b c rc0 rab. set (rab':= (pr2 is0) _ _ (- b) rab). clearbody rab'. change (pr1 (R (a - b) (b - b))) in rab'. rewrite (ringrinvax1 X b) in rab'. set (r' := is _ _ rc0 rab'). clearbody r'. set (r'' := (pr2 is0) _ _ (c * b) r'). clearbody r''. change (pr1 (R (c * (a - b) + c * b) (0 + c * b))) in r''. rewrite (ringlunax1 X _) in r''. rewrite (pathsinv0 (ringldistr X _ _ c)) in r''. rewrite (ringassoc1 X a _ _) in r''. rewrite (ringlinvax1 X b) in r''. rewrite (ringrunax1 X _) in r''. apply r''. Defined. Opaque isringmultgttoislringmultgt. Lemma islringmultgttoisringmultgt (X : ring) {R : hrel X} (is : ∏ a b c : X, R c 0 -> R a b -> R (c * a) (c * b)) : isringmultgt X R. Proof. intros. intros a b ra rb. set (int := is b 0 a ra rb). clearbody int. rewrite (ringmultx0 X _) in int. apply int. Defined. Opaque islringmultgttoisringmultgt. Lemma isringmultgttoisrringmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) : ∏ a b c : X, R c 0 -> R a b -> R (a * c) (b * c). Proof. intros a b c rc0 rab. set (rab' := (pr2 is0) _ _ (- b) rab). clearbody rab'. change (pr1 (R (a - b) (b - b))) in rab'. rewrite (ringrinvax1 X b) in rab'. set (r' := is _ _ rab' rc0). clearbody r'. set (r'' := (pr2 is0) _ _ (b * c) r'). clearbody r''. change (pr1 (R ((a - b) * c + b * c) (0 + b * c))) in r''. rewrite (ringlunax1 X _) in r''. rewrite (pathsinv0 (ringrdistr X _ _ c)) in r''. rewrite (ringassoc1 X a _ _) in r''. rewrite (ringlinvax1 X b) in r''. rewrite (ringrunax1 X _) in r''. apply r''. Defined. Opaque isringmultgttoisrringmultgt. Lemma isrringmultgttoisringmultgt (X : ring) {R : hrel X} (is1 : ∏ a b c : X, R c 0 -> R a b -> R (a * c) (b * c)) : isringmultgt X R. Proof. intros. intros a b ra rb. set (int := is1 _ _ _ rb ra). clearbody int. rewrite (ringmult0x X _) in int. apply int. Defined. Opaque isrringmultgttoisringmultgt. Lemma isringmultgtaspartbinophrel (X : ring) (R : hrel X) (is0 : @isbinophrel X R) : (isringmultgt X R) <-> (@ispartbinophrel (ringmultmonoid X) (λ a, R a 0) R). Proof. intros. split. - intro ism. split. + apply (isringmultgttoislringmultgt X is0 ism). + apply (isringmultgttoisrringmultgt X is0 ism). - intro isp. apply (islringmultgttoisringmultgt X (pr1 isp)). Defined. Lemma isringmultgttoisrigmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isringmultgt X R) : isrigmultgt X R. Proof. intros. set (rer := abmonoidrer X). simpl in rer. intros a b c d rab rcd. assert (intab : R (a - b) 0). { destruct (ringrinvax1 X b). apply ((pr2 is0) _ _ (- b)). apply rab. } assert (intcd : R (c - d) 0). { destruct (ringrinvax1 X d). apply ((pr2 is0) _ _ (- d)). apply rcd. } set (int := is _ _ intab intcd). rewrite (ringrdistr X _ _ _) in int. rewrite (ringldistr X _ _ _) in int. rewrite (ringldistr X _ _ _) in int. set (int' := (pr2 is0) _ _ (a * d + b * c) int). clearbody int'. simpl in int'. rewrite (ringlunax1 _) in int'. rewrite (ringcomm1 X (- b * c) _) in int'. rewrite (rer _ (a * - d) _ _) in int'. rewrite (ringassoc1 X _ (a * - d + - b * c) _) in int'. rewrite (rer _ _ (a * d) _) in int'. rewrite (pathsinv0 (ringldistr X _ _ a)) in int'. rewrite (ringlinvax1 X d) in int'. rewrite (ringmultx0 X _) in int'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in int'. rewrite (ringlinvax1 X b) in int'. rewrite (ringmult0x X _) in int'. rewrite (ringrunax1 X _) in int'. rewrite (ringrunax1 X _) in int'. rewrite (ringmultminusminus X b d) in int'. apply int'. Defined. Opaque isringmultgttoisrigmultgt. Lemma isrigmultgttoisringmultgt (X : ring) {R : hrel X} (is : isrigmultgt X R) : isringmultgt X R. Proof. intros. intros a b ra0 rb0. set (is' := is _ _ _ _ ra0 rb0). simpl in is'. fold (pr1ring) in is'. rewrite 2? (ringmult0x X _) in is'. rewrite (ringmultx0 X _) in is'. rewrite 2? (ringrunax1 X _) in is'. exact is'. Defined. Opaque isrigmultgttoisringmultgt. (** **** Relations "inversely compatible" with the multiplicative structure on rings *) Definition isinvringmultgt (X : ring) (R : hrel X) : UU := dirprod (∏ a b, R (a * b) 0 -> R a 0 -> R b 0) (∏ a b, R (a * b) 0 -> R b 0 -> R a 0). Lemma isinvringmultgttoislinvringmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isinvringmultgt X R) : ∏ a b c : X, R c 0 -> R (c * a) (c * b) -> R a b. Proof. intros a b c rc0 r. set (rab':= (pr2 is0) _ _ (c * - b) r). clearbody rab'. change (pr1 (R (c * a + c * - b) (c * b + c * - b))) in rab'. rewrite (pathsinv0 (ringldistr X _ _ c)) in rab'. rewrite (pathsinv0 (ringldistr X _ _ c)) in rab'. rewrite (ringrinvax1 X b) in rab'. rewrite (ringmultx0 X _) in rab'. set (r' := (pr1 is) _ _ rab' rc0). clearbody r'. set (r'' := (pr2 is0) _ _ b r'). clearbody r''. change (pr1 (R (a - b + b) (0 + b))) in r''. rewrite (ringlunax1 X _) in r''. rewrite (ringassoc1 X a _ _) in r''. rewrite (ringlinvax1 X b) in r''. rewrite (ringrunax1 X _) in r''. apply r''. Defined. Opaque isinvringmultgttoislinvringmultgt. Lemma isinvringmultgttoisrinvringmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isinvringmultgt X R) : ∏ a b c : X, R c 0 -> R (a * c) (b * c) -> R a b. Proof. intros a b c rc0 r. set (rab':= (pr2 is0) _ _ (- b * c) r). clearbody rab'. change (pr1 (R (a * c + - b * c) (b * c + - b * c))) in rab'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in rab'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in rab'. rewrite (ringrinvax1 X b) in rab'. rewrite (ringmult0x X _) in rab'. set (r' := (pr2 is) _ _ rab' rc0). clearbody r'. set (r'' := (pr2 is0) _ _ b r'). clearbody r''. change (pr1 (R (a - b + b) (0 + b))) in r''. rewrite (ringlunax1 X _) in r''. rewrite (ringassoc1 X a _ _) in r''. rewrite (ringlinvax1 X b) in r''. rewrite (ringrunax1 X _) in r''. apply r''. Defined. Opaque isinvringmultgttoisrinvringmultgt. Lemma islrinvringmultgttoisinvringmultgt (X : ring) {R : hrel X} (isl : ∏ a b c : X, R c 0 -> R (c * a) (c * b) -> R a b) (isr : ∏ a b c : X, R c 0 -> R (a * c) (b * c) -> R a b) : isinvringmultgt X R. Proof. intros. split. - intros a b rab ra. rewrite (pathsinv0 (ringmultx0 X a)) in rab. apply (isl _ _ _ ra rab). - intros a b rab rb. rewrite (pathsinv0 (ringmult0x X b)) in rab. apply (isr _ _ _ rb rab). Defined. Opaque islrinvringmultgttoisinvringmultgt. Lemma isinvringmultgtaspartinvbinophrel (X : ring) (R : hrel X) (is0 : @isbinophrel X R) : (isinvringmultgt X R) <-> (@ispartinvbinophrel (ringmultmonoid X) (λ a, R a 0) R). Proof. intros. split. - intro ism. split. + apply (isinvringmultgttoislinvringmultgt X is0 ism). + apply (isinvringmultgttoisrinvringmultgt X is0 ism). - intro isp. apply (islrinvringmultgttoisinvringmultgt X (pr1 isp) (pr2 isp)). Defined. Lemma isinvringmultgttoisinvrigmultgt (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is : isinvringmultgt X R) : isinvrigmultgt X R. Proof. intros. set (rer := abmonoidrer X). simpl in rer. split. - intros a b c d r rab. set (r' := (pr2 is0) _ _ (a * - d + - b * c) r). clearbody r'. simpl in r'. rewrite (rer _ (b * c) _ _) in r'. rewrite (pathsinv0 (ringldistr X _ _ a)) in r'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in r'. rewrite (ringrinvax1 X d) in r'. rewrite (ringrinvax1 X b) in r'. rewrite (ringmult0x X _) in r'. rewrite (ringmultx0 X _) in r'. rewrite (ringlunax1 X) in r'. rewrite (rer _ (b * d) _ _) in r'. rewrite (pathsinv0 (ringldistr X _ _ a)) in r'. simpl in r'. fold pr1ring in r'. (* fold stopped working *) change (pr1 X) with (pr1ring X) in r'. rewrite (pathsinv0 (ringmultminusminus X b d)) in r'. rewrite (pathsinv0 (ringldistr X _ _ (- b))) in r'. rewrite (ringcomm1 X _ c) in r'. rewrite (pathsinv0 (ringrdistr X _ _ _)) in r'. set (rab' := (pr2 is0) _ _ (- b) rab). clearbody rab'. simpl in rab'. rewrite (ringrinvax1 X b) in rab'. set (rcd' := (pr1 is) _ _ r' rab'). set (rcd'' := (pr2 is0) _ _ d rcd'). simpl in rcd''. rewrite (ringassoc1 _ _ _) in rcd''. rewrite (ringlinvax1 X _) in rcd''. rewrite (ringlunax1 X _) in rcd''. rewrite (ringrunax1 X _) in rcd''. apply rcd''. - intros a b c d r rcd. set (r' := (pr2 is0) _ _ (a * - d + - b * c) r). clearbody r'. simpl in r'. rewrite (rer _ (b * c) _ _) in r'. rewrite (pathsinv0 (ringldistr X _ _ a)) in r'. rewrite (pathsinv0 (ringrdistr X _ _ c)) in r'. rewrite (ringrinvax1 X d) in r'. rewrite (ringrinvax1 X b) in r'. rewrite (ringmult0x X _) in r'. rewrite (ringmultx0 X _) in r'. rewrite (ringlunax1 X) in r'. rewrite (rer _ (b * d) _ _) in r'. rewrite (pathsinv0 (ringldistr X _ _ a)) in r'. simpl in r'. fold pr1ring in r'. (* fold stopped working *) change (pr1 X) with (pr1ring X) in r'. rewrite (pathsinv0 (ringmultminusminus X b d)) in r'. rewrite (pathsinv0 (ringldistr X _ _ (- b))) in r'. rewrite (ringcomm1 X _ c) in r'. rewrite (pathsinv0 (ringrdistr X _ _ _)) in r'. set (rcd' := (pr2 is0) _ _ (- d) rcd). clearbody rcd'. simpl in rcd'. rewrite (ringrinvax1 X d) in rcd'. set (rab' := (pr2 is) _ _ r' rcd'). set (rab'' := (pr2 is0) _ _ b rab'). simpl in rab''. rewrite (ringassoc1 _ _ _) in rab''. rewrite (ringlinvax1 X _) in rab''. rewrite (ringlunax1 X _) in rab''. rewrite (ringrunax1 X _) in rab''. apply rab''. Defined. Opaque isinvringmultgttoisinvrigmultgt. (** **** Relations on rings and ring homomorphisms *) Lemma ringaddhrelandfun {X Y : ring} (f : ringfun X Y) (R : hrel Y) (isr : @isbinophrel Y R) : @isbinophrel X (λ x x', R (f x) (f x')). Proof. intros. apply (binophrelandfun (ringaddfun f) R isr). Defined. Lemma ringmultgtandfun {X Y : ring} (f : ringfun X Y) (R : hrel Y) (isr : isringmultgt Y R) : isringmultgt X (λ x x', R (f x) (f x')). Proof. intros. intros a b ra rb. set (ax0 := (pr2 (pr1 (pr2 f))) : (f 0) = 0). set (ax1 := (pr1 (pr2 (pr2 f))) : ∏ a b, paths (f (a * b)) ((f a) * (f b))). rewrite ax0 in ra. rewrite ax0 in rb. rewrite ax0. rewrite (ax1 _ _). apply (isr _ _ ra rb). Defined. Lemma ringinvmultgtandfun {X Y : ring} (f : ringfun X Y) (R : hrel Y) (isr : isinvringmultgt Y R) : isinvringmultgt X (λ x x', R (f x) (f x')). Proof. intros. set (ax0 := (pr2 (pr1 (pr2 f))) : (f 0) = 0). set (ax1 := (pr1 (pr2 (pr2 f))) : ∏ a b, paths (f (a * b)) ((f a) * (f b))). split. - intros a b rab ra. rewrite ax0 in ra. rewrite ax0 in rab. rewrite ax0. rewrite (ax1 _ _) in rab. apply ((pr1 isr) _ _ rab ra). - intros a b rab rb. rewrite ax0 in rb. rewrite ax0 in rab. rewrite ax0. rewrite (ax1 _ _) in rab. apply ((pr2 isr) _ _ rab rb). Defined. Close Scope ring_scope. (** **** Subobjects *) Definition issubring {X : ring} (A : hsubtype X) : UU := dirprod (@issubgr X A) (@issubmonoid (ringmultmonoid X) A). Lemma isapropissubring {X : ring} (A : hsubtype X) : isaprop (issubring A). Proof. intros. apply (isofhleveldirprod 1). - apply isapropissubgr. - apply isapropissubmonoid. Defined. Definition subring (X : ring) : UU := total2 (λ A : hsubtype X, issubring A). Definition make_gsubring {X : ring} : ∏ (t : hsubtype X), (λ A : hsubtype X, issubring A) t → ∑ A : hsubtype X, issubring A := tpair (λ A : hsubtype X, issubring A). Definition pr1subring (X : ring) : @subring X -> hsubtype X := @pr1 _ (λ A : hsubtype X, issubring A). Definition subringtosubsetswith2binop (X : ring) : subring X -> @subsetswith2binop X := λ A : _, make_subsetswith2binop (pr1 A) (make_dirprod (pr1 (pr1 (pr1 (pr2 A)))) (pr1 (pr2 (pr2 A)))). Coercion subringtosubsetswith2binop : subring >-> subsetswith2binop. Definition addsubgr {X : ring} : subring X -> @subgr X := λ A : _, @make_subgr X (pr1 A) (pr1 (pr2 A)). Definition multsubmonoid {X : ring} : subring X -> @submonoid (ringmultmonoid X) := λ A : _, @make_submonoid (ringmultmonoid X) (pr1 A) (pr2 (pr2 A)). Lemma isringcarrier {X : ring} (A : subring X) : isringops (@op1 A) (@op2 A). Proof. intros. split with (make_dirprod (isabgrcarrier (addsubgr A)) (ismonoidcarrier (multsubmonoid A))). split. - intros a b c. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply ringldistr. - intros a b c. apply (invmaponpathsincl _ (isinclpr1carrier A)). simpl. apply ringrdistr. Defined. Definition carrierofasubring (X : ring) (A : subring X) : ring. Proof. intros. split with A. apply isringcarrier. Defined. Coercion carrierofasubring : subring >-> ring. (** **** Quotient objects *) Definition ringeqrel {X : ring} := @twobinopeqrel X. Identity Coercion id_ringeqrel : ringeqrel >-> twobinopeqrel. Definition ringaddabgreqrel {X : ring} (R : @ringeqrel X) : @binopeqrel X := @make_binopeqrel X (pr1 R) (pr1 (pr2 R)). Definition ringmultmonoideqrel {X : ring} (R : @ringeqrel X) : @binopeqrel (ringmultmonoid X) := @make_binopeqrel (ringmultmonoid X) (pr1 R) (pr2 (pr2 R)). Lemma isringquot {X : ring} (R : @ringeqrel X) : isringops (@op1 (setwith2binopquot R)) (@op2 (setwith2binopquot R)). Proof. intros. split with (make_dirprod (isabgrquot (ringaddabgreqrel R)) (ismonoidquot (ringmultmonoideqrel R))). simpl. set (opp1 := @op1 (setwith2binopquot R)). set (opp2 := @op2 (setwith2binopquot R)). split. - unfold isldistr. apply (setquotuniv3prop R (λ x x' x'', make_hProp _ (setproperty (setwith2binopquot R) (opp2 x'' (opp1 x x')) (opp1 (opp2 x'' x) (opp2 x'' x'))))). intros x x' x''. apply (maponpaths (setquotpr R) (ringldistr X x x' x'')). - unfold isrdistr. apply (setquotuniv3prop R (λ x x' x'', make_hProp _ (setproperty (setwith2binopquot R) (opp2 (opp1 x x') x'') (opp1 (opp2 x x'') (opp2 x' x''))))). intros x x' x''. apply (maponpaths (setquotpr R) (ringrdistr X x x' x'')). Defined. Definition ringquot {X : ring} (R : @ringeqrel X) : ring := @make_ring (setwith2binopquot R) (isringquot R). (** **** Direct products *) Lemma isringdirprod (X Y : ring) : isringops (@op1 (setwith2binopdirprod X Y)) (@op2 (setwith2binopdirprod X Y)). Proof. intros. split with (make_dirprod (isabgrdirprod X Y) (ismonoiddirprod (ringmultmonoid X) (ringmultmonoid Y))). simpl. split. - intros xy xy' xy''. unfold setwith2binopdirprod. unfold op1. unfold op2. simpl. apply pathsdirprod. + apply (ringldistr X). + apply (ringldistr Y). - intros xy xy' xy''. unfold setwith2binopdirprod. unfold op1. unfold op2. simpl. apply pathsdirprod. + apply (ringrdistr X). + apply (ringrdistr Y). Defined. Definition ringdirprod (X Y : ring) : ring := @make_ring (setwith2binopdirprod X Y) (isringdirprod X Y). (** **** Opposite rings *) Local Open Scope rig. (** We just need to reuse and rearrange the opposite rig *) Definition opposite_ring (X : ring) : ring. Proof. refine (pr1 (X⁰),, _). split. - split. apply make_isabgrop. * exact (pr1 (rigop1axs (X⁰)),, pr2 (pr1 (ringop1axs X))). * exact (pr2 (ringop1axs X)). * exact (rigop2axs (X⁰)). - exact (rigdistraxs (X⁰)). Defined. Notation "X ⁰" := (opposite_ring X) (at level 12) : ring_scope. Local Close Scope rig. (** **** Ring of differences associated with a rig *) Local Open Scope rig_scope. Definition rigtoringaddabgr (X : rig) : abgr := abgrdiff (rigaddabmonoid X). Definition rigtoringcarrier (X : rig) : hSet := pr1 (pr1 (rigtoringaddabgr X)). Definition rigtoringop1int (X : rig) : binop (X × X) := λ x x', make_dirprod ((pr1 x) + (pr1 x')) ((pr2 x) + (pr2 x')). Definition rigtoringop1 (X : rig) : binop (rigtoringcarrier X) := @op (rigtoringaddabgr X). Definition rigtoringop1axs (X : rig) : isabgrop (rigtoringop1 X) := pr2 (rigtoringaddabgr X). Definition rigtoringunel1 (X : rig) : rigtoringcarrier X := unel (rigtoringaddabgr X). Definition eqrelrigtoring (X : rig) : eqrel (X × X) := eqrelabgrdiff (rigaddabmonoid X). Definition rigtoringop2int (X : rig) : binop (X × X) := λ xx xx' : dirprod X X, make_dirprod (pr1 xx * pr1 xx' + pr2 xx * pr2 xx') (pr1 xx * pr2 xx' + pr2 xx * pr1 xx'). Definition rigtoringunel2int (X : rig) : dirprod X X := make_dirprod 1 0. Lemma rigtoringop2comp (X : rig) : iscomprelrelfun2 (eqrelrigtoring X) (eqrelrigtoring X) (rigtoringop2int X). Proof. intros. apply iscomprelrelfun2if. - intros xx xx' aa. simpl. apply @hinhfun. intro tt1. destruct tt1 as [ x0 e ]. split with (x0 * pr2 aa + x0 * pr1 aa). set (rd := rigrdistr X). set (cm1 := rigcomm1 X). set (as1 := rigassoc1 X). set (rr := abmonoidoprer (rigop1axs X)). rewrite (cm1 (pr1 xx * pr1 aa) (pr2 xx * pr2 aa)). rewrite (rr _ (pr1 xx * pr1 aa) (pr1 xx' * pr2 aa) _). rewrite (cm1 (pr2 xx * pr2 aa) (pr1 xx' * pr2 aa)). destruct (rd (pr1 xx) (pr2 xx') (pr1 aa)). destruct (rd (pr1 xx') (pr2 xx) (pr2 aa)). rewrite (rr ((pr1 xx' + pr2 xx) * pr2 aa) ((pr1 xx + pr2 xx') * pr1 aa) (x0 * pr2 aa) (x0 * pr1 aa)). destruct (rd (pr1 xx' + pr2 xx) x0 (pr2 aa)). destruct (rd (pr1 xx + pr2 xx') x0 (pr1 aa)). rewrite (cm1 (pr1 xx' * pr1 aa) (pr2 xx' * pr2 aa)). rewrite (rr _ (pr1 xx' * pr1 aa) (pr1 xx * pr2 aa) _). rewrite (cm1 (pr2 xx' * pr2 aa) (pr1 xx * pr2 aa)). destruct (rd (pr1 xx') (pr2 xx) (pr1 aa)). destruct (rd (pr1 xx) (pr2 xx') (pr2 aa)). rewrite (rr ((pr1 xx + pr2 xx') * pr2 aa) ((pr1 xx' + pr2 xx) * pr1 aa) (x0 * pr2 aa) (x0 * pr1 aa)). destruct (rd (pr1 xx + pr2 xx') x0 (pr2 aa)). destruct (rd (pr1 xx' + pr2 xx) x0 (pr1 aa)). destruct e. apply idpath. - intros aa xx xx'. simpl. apply @hinhfun. intro tt1. destruct tt1 as [ x0 e ]. split with (pr1 aa * x0 + pr2 aa * x0). set (ld := rigldistr X). set (cm1 := rigcomm1 X). set (as1 := rigassoc1 X). set (rr := abmonoidoprer (rigop1axs X)). rewrite (rr _ (pr2 aa * pr2 xx) (pr1 aa * pr2 xx') _). destruct (ld (pr1 xx) (pr2 xx') (pr1 aa)). destruct (ld (pr2 xx) (pr1 xx') (pr2 aa)). rewrite (rr _ (pr2 aa * (pr2 xx + pr1 xx')) (pr1 aa * x0) _). destruct (ld (pr1 xx + pr2 xx') x0 (pr1 aa)). destruct (ld (pr2 xx + pr1 xx') x0 (pr2 aa)). rewrite (rr _ (pr2 aa * pr2 xx') (pr1 aa * pr2 xx) _). destruct (ld (pr1 xx') (pr2 xx) (pr1 aa)). destruct (ld (pr2 xx') (pr1 xx) (pr2 aa)). rewrite (rr _ (pr2 aa * (pr2 xx' + pr1 xx)) (pr1 aa * x0) _). destruct (ld (pr1 xx' + pr2 xx) x0 (pr1 aa)). destruct (ld (pr2 xx' + pr1 xx) x0 (pr2 aa)). rewrite (cm1 (pr2 xx) (pr1 xx')). rewrite (cm1 (pr2 xx') (pr1 xx)). destruct e. apply idpath. Defined. Opaque rigtoringop2comp. Definition rigtoringop2 (X : rig) : binop (rigtoringcarrier X) := setquotfun2 (eqrelrigtoring X) (eqrelrigtoring X) (rigtoringop2int X) (rigtoringop2comp X). Lemma rigtoringassoc2 (X : rig) : isassoc (rigtoringop2 X). Proof. unfold isassoc. apply (setquotuniv3prop _ (λ x x' x'', _ = _)). intros x x' x''. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X (rigtoringop2int X x x') x'')) (setquotpr (eqrelrigtoring X) (rigtoringop2int X x (rigtoringop2int X x' x'')))). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop2int. simpl. set (rd := rigrdistr X). set (ld := rigldistr X). set (cm1 := rigcomm1 X). set (as1 := rigassoc1 X). set (as2 := rigassoc2 X). set (rr := abmonoidoprer (rigop1axs X)). apply pathsdirprod. rewrite (rd _ _ (pr1 x'')). rewrite (rd _ _ (pr2 x'')). rewrite (ld _ _ (pr1 x)). rewrite (ld _ _ (pr2 x)). destruct (as2 (pr1 x) (pr1 x') (pr1 x'')). destruct (as2 (pr1 x) (pr2 x') (pr2 x'')). destruct (as2 (pr2 x) (pr1 x') (pr2 x'')). destruct (as2 (pr2 x) (pr2 x') (pr1 x'')). destruct (cm1 (pr2 x * pr2 x' * pr1 x'') (pr2 x * pr1 x' * pr2 x'')). rewrite (rr _ (pr2 x * pr2 x' * pr1 x'') (pr1 x * pr2 x' * pr2 x'') _). apply idpath. rewrite (rd _ _ (pr1 x'')). rewrite (rd _ _ (pr2 x'')). rewrite (ld _ _ (pr1 x)). rewrite (ld _ _ (pr2 x)). destruct (as2 (pr1 x) (pr1 x') (pr2 x'')). destruct (as2 (pr1 x) (pr2 x') (pr1 x'')). destruct (as2 (pr2 x) (pr1 x') (pr1 x'')). destruct (as2 (pr2 x) (pr2 x') (pr2 x'')). destruct (cm1 (pr2 x * pr2 x' * pr2 x'') (pr2 x * pr1 x' * pr1 x'')). rewrite (rr _ (pr1 x * pr2 x' * pr1 x'') (pr2 x * pr2 x' * pr2 x'') _). apply idpath. Defined. Opaque rigtoringassoc2. Definition rigtoringunel2 (X : rig) : rigtoringcarrier X := setquotpr (eqrelrigtoring X) (rigtoringunel2int X). Lemma rigtoringlunit2 (X : rig) : islunit (rigtoringop2 X) (rigtoringunel2 X). Proof. unfold islunit. apply (setquotunivprop _ (λ x, _ = _)). intro x. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X (rigtoringunel2int X) x)) (setquotpr (eqrelrigtoring X) x)). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop2int. simpl. destruct x as [ x1 x2 ]. simpl. set (lu2 := riglunax2 X). set (ru1 := rigrunax1 X). set (m0x := rigmult0x X). apply pathsdirprod. - rewrite (lu2 x1). rewrite (m0x x2). apply (ru1 x1). - rewrite (lu2 x2). rewrite (m0x x1). apply (ru1 x2). Defined. Opaque rigtoringlunit2. Lemma rigtoringrunit2 (X : rig) : isrunit (rigtoringop2 X) (rigtoringunel2 X). Proof. unfold isrunit. apply (setquotunivprop _ (λ x, _ = _)). intro x. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X x (rigtoringunel2int X))) (setquotpr (eqrelrigtoring X) x)). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop2int. simpl. destruct x as [ x1 x2 ]. simpl. set (ru1 := rigrunax1 X). set (ru2 := rigrunax2 X). set (lu1 := riglunax1 X). set (mx0 := rigmultx0 X). apply pathsdirprod. - rewrite (ru2 x1). rewrite (mx0 x2). apply (ru1 x1). - rewrite (ru2 x2). rewrite (mx0 x1). apply (lu1 x2). Defined. Opaque rigtoringrunit2. Definition rigtoringisunit (X : rig) : isunit (rigtoringop2 X) (rigtoringunel2 X) := make_dirprod (rigtoringlunit2 X) (rigtoringrunit2 X). Definition rigtoringisunital (X : rig) : isunital (rigtoringop2 X) := tpair _ (rigtoringunel2 X) (rigtoringisunit X). Definition rigtoringismonoidop2 (X : rig) : ismonoidop (rigtoringop2 X) := make_dirprod (rigtoringassoc2 X) (rigtoringisunital X). Lemma rigtoringldistr (X : rig) : isldistr (rigtoringop1 X) (rigtoringop2 X). Proof. unfold isldistr. apply (setquotuniv3prop _ (λ x x' x'', _ = _)). intros x x' x''. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X x'' (rigtoringop1int X x x'))) (setquotpr (eqrelrigtoring X) (rigtoringop1int X (rigtoringop2int X x'' x) (rigtoringop2int X x'' x')))). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop1int. unfold rigtoringop2int. simpl. set (ld := rigldistr X). set (cm1 := rigcomm1 X). set (rr := abmonoidoprer (rigop1axs X)). apply pathsdirprod. - rewrite (ld _ _ (pr1 x'')). rewrite (ld _ _ (pr2 x'')). apply (rr _ (pr1 x'' * pr1 x') (pr2 x'' * pr2 x) _). - rewrite (ld _ _ (pr1 x'')). rewrite (ld _ _ (pr2 x'')). apply (rr _ (pr1 x'' * pr2 x') (pr2 x'' * pr1 x) _). Defined. Opaque rigtoringldistr. Lemma rigtoringrdistr (X : rig) : isrdistr (rigtoringop1 X) (rigtoringop2 X). Proof. unfold isrdistr. apply (setquotuniv3prop _ (λ x x' x'', _ = _)). intros x x' x''. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X (rigtoringop1int X x x') x'')) (setquotpr (eqrelrigtoring X) (rigtoringop1int X (rigtoringop2int X x x'') (rigtoringop2int X x' x'')))). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop1int. unfold rigtoringop2int. simpl. set (rd := rigrdistr X). set (cm1 := rigcomm1 X). set (rr := abmonoidoprer (rigop1axs X)). apply pathsdirprod. - rewrite (rd _ _ (pr1 x'')). rewrite (rd _ _ (pr2 x'')). apply (rr _ (pr1 x' * pr1 x'') (pr2 x * pr2 x'') _). - rewrite (rd _ _ (pr1 x'')). rewrite (rd _ _ (pr2 x'')). apply (rr _ (pr1 x' * pr2 x'') (pr2 x * pr1 x'') _). Defined. Opaque rigtoringrdistr. Definition rigtoringdistr (X : rig) : isdistr (rigtoringop1 X) (rigtoringop2 X) := make_dirprod (rigtoringldistr X) (rigtoringrdistr X). Definition rigtoring (X : rig) : ring. Proof. split with (@make_setwith2binop (rigtoringcarrier X) (make_dirprod (rigtoringop1 X) (rigtoringop2 X))). split. - apply (make_dirprod (rigtoringop1axs X) (rigtoringismonoidop2 X)). - apply (rigtoringdistr X). Defined. (** **** Canonical homomorphism to the ring associated with a rig (ring of differences) *) Definition toringdiff (X : rig) (x : X) : rigtoring X := setquotpr _ (make_dirprod x 0). Lemma isbinop1funtoringdiff (X : rig) : @isbinopfun (rigaddabmonoid X) (rigtoring X) (toringdiff X). Proof. intros. unfold isbinopfun. intros x x'. apply (isbinopfuntoabgrdiff (rigaddabmonoid X) x x'). Defined. Opaque isbinop1funtoringdiff. Lemma isunital1funtoringdiff (X : rig) : (toringdiff X 0) = 0%ring. Proof. apply idpath. Defined. Opaque isunital1funtoringdiff. Definition isaddmonoidfuntoringdiff (X : rig) : @ismonoidfun (rigaddabmonoid X) (rigtoring X) (toringdiff X) := make_dirprod (isbinop1funtoringdiff X) (isunital1funtoringdiff X). Lemma isbinop2funtoringdiff (X : rig) : @isbinopfun (rigmultmonoid X) (ringmultmonoid (rigtoring X)) (toringdiff X). Proof. intros. unfold isbinopfun. intros x x'. change (paths (setquotpr _ (make_dirprod (x * x') 0)) (setquotpr (eqrelrigtoring X) (rigtoringop2int X (make_dirprod x 0) (make_dirprod x' 0)))). apply (maponpaths (setquotpr _)). unfold rigtoringop2int. simpl. apply pathsdirprod. - rewrite (rigmultx0 X _). rewrite (rigrunax1 X _). apply idpath. - rewrite (rigmult0x X _). rewrite (rigmultx0 X _). rewrite (rigrunax1 X _). apply idpath. Defined. Lemma isunital2funtoringdiff (X : rig) : (toringdiff X 1) = 1%ring. Proof. apply idpath. Defined. Opaque isunital2funtoringdiff. Definition ismultmonoidfuntoringdiff (X : rig) : @ismonoidfun (rigmultmonoid X) (ringmultmonoid (rigtoring X)) (toringdiff X) := make_dirprod (isbinop2funtoringdiff X) (isunital2funtoringdiff X). Definition isrigfuntoringdiff (X : rig) : @isrigfun X (rigtoring X) (toringdiff X) := make_dirprod (isaddmonoidfuntoringdiff X) (ismultmonoidfuntoringdiff X). Definition isincltoringdiff (X : rig) (iscanc : ∏ x : X, @isrcancelable X (@op1 X) x) : isincl (toringdiff X) := isincltoabgrdiff (rigaddabmonoid X) iscanc. (** **** Relations similar to "greater" or "greater or equal" on the ring associated with a rig *) Definition rigtoringrel (X : rig) {R : hrel X} (is : @isbinophrel (rigaddabmonoid X) R) : hrel (rigtoring X) := abgrdiffrel (rigaddabmonoid X) is. Lemma isringrigtoringmultgt (X : rig) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is : isrigmultgt X R) : isringmultgt (rigtoring X) (rigtoringrel X is0). Proof. intros. set (assoc := rigassoc1 X). set (comm := rigcomm1 X). set (rer := (abmonoidrer (rigaddabmonoid X)) : ∏ a b c d : X, paths ((a + b) + (c + d)) ((a + c) + (b + d))). set (ld := rigldistr X). set (rd := rigrdistr X). assert (int : ∏ a b, isaprop (rigtoringrel X is0 a ringunel1 -> rigtoringrel X is0 b ringunel1 -> rigtoringrel X is0 (a * b) ringunel1)). { intros a b. apply impred. intro. apply impred. intro. apply (pr2 _). } unfold isringmultgt. apply (setquotuniv2prop _ (λ a b, make_hProp _ (int a b))). intros xa1 xa2. change ((abgrdiffrelint (rigaddabmonoid X) R) xa1 (make_dirprod (@rigunel1 X) (@rigunel1 X)) -> (abgrdiffrelint (rigaddabmonoid X) R) xa2 (make_dirprod (@rigunel1 X) (@rigunel1 X)) -> (abgrdiffrelint (rigaddabmonoid X) R (@rigtoringop2int X xa1 xa2) (make_dirprod (@rigunel1 X) (@rigunel1 X)))). unfold abgrdiffrelint. simpl. apply hinhfun2. intros t22 t21. set (c2 := pr1 t21). set (c1 := pr1 t22). set (r1 := pr2 t21). set (r2 := pr2 t22). set (x1 := pr1 xa1). set (a1 := pr2 xa1). set (x2 := pr1 xa2). set (a2 := pr2 xa2). split with ((x1 * c2 + a1 * c2) + ((c1 * x2 + c1 * c2) + (c1 * a2 + c1 * c2))). change (pr1 (R (x1 * x2 + a1 * a2 + 0 + ((x1 * c2 + a1 * c2) + ((c1 * x2 + c1 * c2) + (c1 * a2 + c1 * c2)))) (0 + (x1 * a2 + a1 * x2) + (x1 * c2 + a1 * c2 + ((c1 * x2 + c1 * c2) + (c1 * a2 + c1 * c2)))))). rewrite (riglunax1 X _). rewrite (rigrunax1 X _). rewrite (assoc (x1 * c2) _ _). rewrite (rer _ (a1 * a2) _ _). rewrite (rer _ (a1 * x2) _ _). rewrite (pathsinv0 (assoc (a1 * a2) _ _)). rewrite (pathsinv0 (assoc (a1 * x2) _ _)). rewrite (pathsinv0 (assoc (x1 * x2 + _) _ _)). rewrite (pathsinv0 (assoc (x1 * a2 + _) _ _)). rewrite (rer _ (a1 * a2 + _) _ _). rewrite (rer _ (a1 * x2 + _) _ _). rewrite (pathsinv0 (ld _ _ x1)). rewrite (pathsinv0 (ld _ _ x1)). rewrite (pathsinv0 (ld _ _ c1)). rewrite (pathsinv0 (ld _ _ c1)). rewrite (pathsinv0 (ld _ _ a1)). rewrite (pathsinv0 (ld _ _ a1)). rewrite (pathsinv0 (rd _ _ (x2 + c2))). rewrite (pathsinv0 (rd _ _ (a2 + c2))). rewrite (comm (a1 * _) _). rewrite (rer _ (c1 * _) _ _). rewrite (pathsinv0 (rd _ _ (x2 + c2))). rewrite (pathsinv0 (rd _ _ (a2 + c2))). clearbody r1. clearbody r2. change (pr1 (R (x2 + 0 + c2) (0 + a2 + c2))) in r1. change (pr1 (R (x1 + 0 + c1) (0 + a1 + c1))) in r2. rewrite (rigrunax1 X _) in r1. rewrite (riglunax1 X _) in r1. rewrite (rigrunax1 X _) in r2. rewrite (riglunax1 X _) in r2. rewrite (comm c1 a1). apply (is _ _ _ _ r2 r1). Defined. Opaque isringrigtoringmultgt. Definition isdecrigtoringrel (X : rig) {R : hrel X} (is : @isbinophrel (rigaddabmonoid X) R) (is' : @isinvbinophrel (rigaddabmonoid X) R) (isd : isdecrel R) : isdecrel (rigtoringrel X is). Proof. intros. apply (isdecabgrdiffrel (rigaddabmonoid X) is is' isd). Defined. Lemma isinvringrigtoringmultgt (X : rig) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : @isinvbinophrel (rigaddabmonoid X) R) (is : isinvrigmultgt X R) : isinvringmultgt (rigtoring X) (rigtoringrel X is0). Proof. intros. split. - assert (int : ∏ a b, isaprop (rigtoringrel X is0 (a * b) ringunel1 -> rigtoringrel X is0 a ringunel1 -> rigtoringrel X is0 b ringunel1)). intros. apply impred. intro. apply impred. intro. apply (pr2 _). apply (setquotuniv2prop _ (λ a b, make_hProp _ (int a b))). intros xa1 xa2. change ((abgrdiffrelint (rigaddabmonoid X) R (@rigtoringop2int X xa1 xa2) (make_dirprod (@rigunel1 X) (@rigunel1 X))) -> (abgrdiffrelint (rigaddabmonoid X) R) xa1 (make_dirprod (@rigunel1 X) (@rigunel1 X)) -> (abgrdiffrelint (rigaddabmonoid X) R) xa2 (make_dirprod (@rigunel1 X) (@rigunel1 X))). unfold abgrdiffrelint. simpl. apply hinhfun2. intros t22 t21. set (c2 := pr1 t22). set (c1 := pr1 t21). set (r1 := pr2 t21). set (r2 := pr2 t22). set (x1 := pr1 xa1). set (a1 := pr2 xa1). set (x2 := pr1 xa2). set (a2 := pr2 xa2). simpl in r2. clearbody r2. change (pr1 (R (x1 * x2 + a1 * a2 + 0 + c2) (0 + (x1 * a2 + a1 * x2) + c2))) in r2. rewrite (riglunax1 X _) in r2. rewrite (rigrunax1 X _) in r2. rewrite (rigrunax1 X _). rewrite (riglunax1 X _). set (r2' := (pr2 is1) _ _ c2 r2). clearbody r1. change (pr1 (R (x1 + 0 + c1) (0 + a1 + c1))) in r1. rewrite (riglunax1 X _) in r1. rewrite (rigrunax1 X _) in r1. set (r1' := (pr2 is1) _ _ c1 r1). split with 0. rewrite (rigrunax1 X _). rewrite (rigrunax1 X _). apply ((pr1 is) _ _ _ _ r2' r1'). - assert (int : ∏ a b, isaprop (rigtoringrel X is0 (a * b) ringunel1 -> rigtoringrel X is0 b ringunel1 -> rigtoringrel X is0 a ringunel1)). intros. apply impred. intro. apply impred. intro. apply (pr2 _). apply (setquotuniv2prop _ (λ a b, make_hProp _ (int a b))). intros xa1 xa2. change ((abgrdiffrelint (rigaddabmonoid X) R (@rigtoringop2int X xa1 xa2) (make_dirprod (@rigunel1 X) (@rigunel1 X))) -> (abgrdiffrelint (rigaddabmonoid X) R) xa2 (make_dirprod (@rigunel1 X) (@rigunel1 X)) -> (abgrdiffrelint (rigaddabmonoid X) R) xa1 (make_dirprod (@rigunel1 X) (@rigunel1 X))). unfold abgrdiffrelint. simpl. apply hinhfun2. intros t22 t21. set (c2 := pr1 t22). set (c1 := pr1 t21). set (r1 := pr2 t21). set (r2 := pr2 t22). set (x1 := pr1 xa1). set (a1 := pr2 xa1). set (x2 := pr1 xa2). set (a2 := pr2 xa2). simpl in r2. clearbody r2. change (pr1 (R (x1 * x2 + a1 * a2 + 0 + c2) (0 + (x1 * a2 + a1 * x2) + c2))) in r2. rewrite (riglunax1 X _) in r2. rewrite (rigrunax1 X _) in r2. rewrite (rigrunax1 X _). rewrite (riglunax1 X _). set (r2' := (pr2 is1) _ _ c2 r2). clearbody r1. change (pr1 (R (x2 + 0 + c1) (0 + a2 + c1))) in r1. rewrite (riglunax1 X _) in r1. rewrite (rigrunax1 X _) in r1. set (r1' := (pr2 is1) _ _ c1 r1). split with 0. rewrite (rigrunax1 X _). rewrite (rigrunax1 X _). apply ((pr2 is) _ _ _ _ r2' r1'). Defined. Opaque isinvringrigtoringmultgt. (** **** Relations and the canonical homomorphism to the ring associated with a rig (ring of differences) *) Definition iscomptoringdiff (X : rig) {L : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) L) : iscomprelrelfun L (rigtoringrel X is0) (toringdiff X) := iscomptoabgrdiff (rigaddabmonoid X) is0. Opaque iscomptoringdiff. Close Scope rig_scope. (** *** Commutative rings *) (** **** General definitions *) Definition iscommring (X : setwith2binop) : UU := iscommringops (@op1 X) (@op2 X). Definition commring : UU := total2 (λ X : setwith2binop, iscommringops (@op1 X) (@op2 X)). Definition make_commring (X : setwith2binop) (is : iscommringops (@op1 X) (@op2 X)) : ∑ X0 : setwith2binop, iscommringops op1 op2 := tpair (λ X : setwith2binop, iscommringops (@op1 X) (@op2 X)) X is. Definition commringconstr {X : hSet} (opp1 opp2 : binop X) (ax11 : isgrop opp1) (ax12 : iscomm opp1) (ax21 : ismonoidop opp2) (ax22 : iscomm opp2) (dax : isdistr opp1 opp2) : commring := @make_commring (make_setwith2binop X (make_dirprod opp1 opp2)) (make_dirprod (make_dirprod (make_dirprod (make_dirprod ax11 ax12) ax21) dax) ax22). Definition commringtoring : commring -> ring := λ X : _, @make_ring (pr1 X) (pr1 (pr2 X)). Coercion commringtoring : commring >-> ring. Definition ringcomm2 (X : commring) : iscomm (@op2 X) := pr2 (pr2 X). Definition commringop2axs (X : commring) : isabmonoidop (@op2 X) := tpair _ (ringop2axs X) (ringcomm2 X). Definition ringmultabmonoid (X : commring) : abmonoid := make_abmonoid (make_setwithbinop X op2) (make_dirprod (ringop2axs X) (ringcomm2 X)). Definition commringtocommrig (X : commring) : commrig := make_commrig _ (pr2 X). Coercion commringtocommrig : commring >-> commrig. (** **** (X = Y) ≃ (ringiso X Y) We use the following composition (X = Y) ≃ (make_commring' X = make_commring' Y) ≃ ((pr1 (make_commring' X)) = (pr1 (make_commring' Y))) ≃ (ringiso X Y) where the third weak equivalence is given by univalence for ring, [ring_univalence]. We define [commring'] to be able to use [ring_univalence]. *) Local Definition commring' : UU := ∑ D : (∑ X : setwith2binop, isringops (@op1 X) (@op2 X)), iscomm (@op2 (pr1 D)). Local Definition make_commring' (CR : commring) : commring' := tpair _ (tpair _ (pr1 CR) (dirprod_pr1 (pr2 CR))) (dirprod_pr2 (pr2 CR)). Definition commring_univalence_weq1 : commring ≃ commring' := weqtotal2asstol (λ X : setwith2binop, isringops (@op1 X) (@op2 X)) (fun y : (∑ (X : setwith2binop), isringops (@op1 X) (@op2 X)) => iscomm (@op2 (pr1 y))). Definition commring_univalence_weq1' (X Y : commring) : (X = Y) ≃ (make_commring' X = make_commring' Y) := make_weq _ (@isweqmaponpaths commring commring' commring_univalence_weq1 X Y). Definition commring_univalence_weq2 (X Y : commring) : ((make_commring' X) = (make_commring' Y)) ≃ ((pr1 (make_commring' X)) = (pr1 (make_commring' Y))). Proof. use subtypeInjectivity. intros w. use isapropiscomm. Defined. Opaque commring_univalence_weq2. Definition commring_univalence_weq3 (X Y : commring) : ((pr1 (make_commring' X)) = (pr1 (make_commring' Y))) ≃ (ringiso X Y) := ring_univalence (pr1 (make_commring' X)) (pr1 (make_commring' Y)). Definition commring_univalence_map (X Y : commring) : (X = Y) -> (ringiso X Y). Proof. intros e. induction e. exact (idrigiso X). Defined. Lemma commring_univalence_isweq (X Y : commring) : isweq (commring_univalence_map X Y). Proof. use isweqhomot. - exact (weqcomp (commring_univalence_weq1' X Y) (weqcomp (commring_univalence_weq2 X Y) (commring_univalence_weq3 X Y))). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use weqcomp_to_funcomp_app. - use weqproperty. Defined. Opaque commring_univalence_isweq. Definition commring_univalence (X Y : commring) : (X = Y) ≃ (ringiso X Y). Proof. use make_weq. - exact (commring_univalence_map X Y). - exact (commring_univalence_isweq X Y). Defined. Opaque commring_univalence. (** **** Computational lemmas for commutative rings *) Local Open Scope ring_scope. Lemma commringismultcancelableif (X : commring) (x : X) (isl : ∏ y, paths (x * y) 0 -> y = 0) : iscancelable op2 x. Proof. intros. split. - apply (ringismultlcancelableif X x isl). - assert (isr : ∏ y, paths (y * x) 0 -> y = 0). intros y e. rewrite (ringcomm2 X _ _) in e. apply (isl y e). apply (ringismultrcancelableif X x isr). Defined. Opaque commringismultcancelableif. Close Scope ring_scope. (** **** Subobjects *) Lemma iscommringcarrier {X : commring} (A : @subring X) : iscommringops (@op1 A) (@op2 A). Proof. intros. split with (isringcarrier A). apply (pr2 (@isabmonoidcarrier (ringmultabmonoid X) (multsubmonoid A))). Defined. Definition carrierofasubcommring {X : commring} (A : @subring X) : commring := make_commring A (iscommringcarrier A). (** **** Quotient objects *) Lemma iscommringquot {X : commring} (R : @ringeqrel X) : iscommringops (@op1 (setwith2binopquot R)) (@op2 (setwith2binopquot R)). Proof. intros. split with (isringquot R). apply (pr2 (@isabmonoidquot (ringmultabmonoid X) (ringmultmonoideqrel R))). Defined. Definition commringquot {X : commring} (R : @ringeqrel X) : commring := make_commring (setwith2binopquot R) (iscommringquot R). (** **** Direct products *) Lemma iscommringdirprod (X Y : commring) : iscommringops (@op1 (setwith2binopdirprod X Y)) (@op2 (setwith2binopdirprod X Y)). Proof. intros. split with (isringdirprod X Y). apply (pr2 (isabmonoiddirprod (ringmultabmonoid X) (ringmultabmonoid Y))). Defined. Definition commringdirprod (X Y : commring) : commring := make_commring (setwith2binopdirprod X Y) (iscommringdirprod X Y). (** **** Opposite commutative rings *) Local Open Scope ring. (** We reuse much of the proof for general rigs *) Definition opposite_commring (X : commring) : commring := ((pr1 (X⁰)),, (make_dirprod (pr2 (X⁰)) (fun x y => @ringcomm2 X y x))). (** Commutativity makes taking the opposite trivial *) Definition iso_commring_opposite (X : commring) : rigiso X (opposite_commring X) := iso_commrig_opposite X. Local Close Scope rig. (** **** Commutative rigs to commutative rings *) Local Open Scope rig_scope. Lemma commrigtocommringcomm2 (X : commrig) : iscomm (rigtoringop2 X). Proof. unfold iscomm. apply (setquotuniv2prop _ (λ x x', _ = _)). intros x x'. change (paths (setquotpr (eqrelrigtoring X) (rigtoringop2int X x x')) (setquotpr (eqrelrigtoring X) (rigtoringop2int X x' x))). apply (maponpaths (setquotpr (eqrelrigtoring X))). unfold rigtoringop2int. set (cm1 := rigcomm1 X). set (cm2 := rigcomm2 X). apply pathsdirprod. - rewrite (cm2 (pr1 x) (pr1 x')). rewrite (cm2 (pr2 x) (pr2 x')). apply idpath. - rewrite (cm2 (pr1 x) (pr2 x')). rewrite (cm2 (pr2 x) (pr1 x')). apply cm1. Defined. Opaque commrigtocommringcomm2. Definition commrigtocommring (X : commrig) : commring. Proof. split with (rigtoring X). split. - apply (pr2 (rigtoring X)). - apply (commrigtocommringcomm2 X). Defined. Close Scope rig_scope. (** **** Rings of fractions *) Local Open Scope ring_scope. Definition commringfracop1int (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : binop (X × S) := λ x1s1 x2s2 : dirprod X S, @make_dirprod X S (((pr1 (pr2 x2s2)) * (pr1 x1s1)) + ((pr1 (pr2 x1s1)) * (pr1 x2s2))) (@op S (pr2 x1s1) (pr2 x2s2)). Definition commringfracop2int (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : binop (X × S) := abmonoidfracopint (ringmultabmonoid X) S. Definition commringfracunel1int (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : dirprod X S := make_dirprod 0 (unel S). Definition commringfracunel2int (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : dirprod X S := make_dirprod 1 (unel S). Definition commringfracinv1int (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : dirprod X S -> dirprod X S := λ xs : _, make_dirprod ((-1) * (pr1 xs)) (pr2 xs). Definition eqrelcommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : eqrel (X × S) := eqrelabmonoidfrac (ringmultabmonoid X) S. Lemma commringfracl1 (X : commring) (x1 x2 x3 x4 a1 a2 s1 s2 s3 s4 : X) (eq1 : paths ((x1 * s2) * a1) ((x2 * s1) * a1)) (eq2 : paths ((x3 * s4) * a2) ((x4 * s3) * a2)) : paths ((((s3 * x1) + (s1 * x3)) * (s2 * s4)) * (a1 * a2)) ((((s4 * x2) + (s2 * x4)) * (s1 * s3)) * (a1 * a2)). Proof. intros. set (rdistr := ringrdistr X). set (assoc2 := ringassoc2 X). set (op2axs := commringop2axs X). set (comm2 := ringcomm2 X). set (rer := abmonoidoprer op2axs). rewrite (rdistr (s3 * x1) (s1 * x3) (s2 * s4)). rewrite (rdistr (s4 * x2) (s2 * x4) (s1 * s3)). rewrite (rdistr ((s3 * x1) * (s2 * s4)) ((s1 * x3) * (s2 * s4)) (a1 * a2)). rewrite (rdistr ((s4 * x2) * (s1 * s3)) ((s2 * x4) * (s1 * s3)) (a1 * a2)). clear rdistr. assert (e1 : paths (((s3 * x1) * (s2 * s4)) * (a1 * a2)) (((s4 * x2) * (s1 * s3)) * (a1 * a2))). { destruct (assoc2 (s3 * x1) s2 s4). rewrite (assoc2 s3 x1 s2). rewrite (rer (s3 * (x1 * s2)) s4 a1 a2). rewrite (assoc2 s3 (x1 * s2) a1). destruct (assoc2 (s4 * x2) s1 s3). rewrite (assoc2 s4 x2 s1). rewrite (rer (s4 * (x2 * s1)) s3 a1 a2). rewrite (assoc2 s4 (x2 * s1) a1). destruct eq1. rewrite (comm2 s3 ((x1 * s2) * a1)). rewrite (comm2 s4 ((x1 * s2) * a1)). rewrite (rer ((x1 * s2) * a1) s3 s4 a2). apply idpath. } assert (e2 : paths (((s1 * x3) * (s2 * s4)) * (a1 * a2)) (((s2 * x4) * (s1 * s3)) * (a1 * a2))). { destruct (comm2 s4 s2). destruct (comm2 s3 s1). destruct (comm2 a2 a1). destruct (assoc2 (s1 * x3) s4 s2). destruct (assoc2 (s2 * x4) s3 s1). rewrite (assoc2 s1 x3 s4). rewrite (assoc2 s2 x4 s3). rewrite (rer (s1 * (x3 * s4)) s2 a2 a1). rewrite (rer (s2 * (x4 * s3)) s1 a2 a1). rewrite (assoc2 s1 (x3 * s4) a2). rewrite (assoc2 s2 (x4 * s3) a2). destruct eq2. destruct (comm2 ((x3 * s4) * a2) s1). destruct (comm2 ((x3 *s4) * a2) s2). rewrite (rer ((x3 * s4) * a2) s1 s2 a1). apply idpath. } destruct e1. destruct e2. apply idpath. Defined. Opaque commringfracl1. Lemma commringfracop1comp (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : iscomprelrelfun2 (eqrelcommringfrac X S) (eqrelcommringfrac X S) (commringfracop1int X S). Proof. intros. intros xs1 xs2 xs3 xs4. simpl. set (ff := @hinhfun2). simpl in ff. apply ff. clear ff. intros tt1 tt2. split with (@op S (pr1 tt1) (pr1 tt2)). set (eq1 := pr2 tt1). simpl in eq1. set (eq2 := pr2 tt2). simpl in eq2. unfold pr1carrier. apply (commringfracl1 X (pr1 xs1) (pr1 xs2) (pr1 xs3) (pr1 xs4) (pr1 (pr1 tt1)) (pr1 (pr1 tt2)) (pr1 (pr2 xs1)) (pr1 (pr2 xs2)) (pr1 (pr2 xs3)) (pr1 (pr2 xs4)) eq1 eq2). Defined. Opaque commringfracop1comp. Definition commringfracop1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : binop (setquotinset (eqrelcommringfrac X S)) := setquotfun2 (eqrelcommringfrac X S) (eqrelcommringfrac X S) (commringfracop1int X S) (commringfracop1comp X S). Lemma commringfracl2 (X : commring) (x x' x'' s s' s'' : X) : paths ((s'' * ((s' * x) + (s * x'))) + ((s * s') * x'')) (((s' * s'') * x) + (s * ((s'' * x') + (s' * x'')))). Proof. intros. set (ldistr := ringldistr X). set (comm2 := ringcomm2 X). set (assoc2 := ringassoc2 X). set (assoc1 := ringassoc1 X). rewrite (ldistr (s' * x) (s * x') s''). rewrite (ldistr (s'' * x') (s' * x'') s). destruct (comm2 s'' s'). destruct (assoc2 s'' s' x). destruct (assoc2 s'' s x'). destruct (assoc2 s s'' x'). destruct (comm2 s s''). destruct (assoc2 s s' x''). apply (assoc1 ((s'' * s') * x) ((s * s'') * x') ((s * s') * x'')). Defined. Opaque commringfracl2. Lemma commringfracassoc1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : isassoc (commringfracop1 X S). Proof. intros. set (R := eqrelcommringfrac X S). set (add1int := commringfracop1int X S). set (add1 := commringfracop1 X S). unfold isassoc. assert (int : ∏ (xs xs' xs'' : dirprod X S), paths (setquotpr R (add1int (add1int xs xs') xs'')) (setquotpr R (add1int xs (add1int xs' xs'')))). unfold add1int. unfold commringfracop1int. intros xs xs' xs''. apply (@maponpaths _ _ (setquotpr R)). simpl. apply pathsdirprod. - unfold pr1carrier. apply (commringfracl2 X (pr1 xs) (pr1 xs') (pr1 xs'') (pr1 (pr2 xs)) (pr1 (pr2 xs')) (pr1 (pr2 xs''))). - apply (invmaponpathsincl _ (isinclpr1carrier (pr1 S))). unfold pr1carrier. simpl. set (assoc2 := ringassoc2 X). apply (assoc2 (pr1 (pr2 xs)) (pr1 (pr2 xs')) (pr1 (pr2 xs''))). - apply (setquotuniv3prop R (λ x x' x'', _ = _)), int. Defined. Opaque commringfracassoc1. Lemma commringfraccomm1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : iscomm (commringfracop1 X S). Proof. intros. set (R := eqrelcommringfrac X S). set (add1int := commringfracop1int X S). set (add1 := commringfracop1 X S). unfold iscomm. apply (setquotuniv2prop _ (λ x x', _ = _)). intros xs xs'. apply (@maponpaths _ _ (setquotpr R) (add1int xs xs') (add1int xs' xs)). unfold add1int. unfold commringfracop1int. destruct xs as [ x s ]. destruct s as [ s iss ]. destruct xs' as [ x' s' ]. destruct s' as [ s' iss' ]. simpl. apply pathsdirprod. - change (paths ((s' * x) + (s * x')) ((s * x') + (s' * x))). destruct (ringcomm1 X (s' * x) (s * x')). apply idpath. - apply (invmaponpathsincl _ (isinclpr1carrier (pr1 S))). simpl. change (paths (s * s') (s' * s)). apply (ringcomm2 X). Defined. Opaque commringfraccomm1. Definition commringfracunel1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : setquot (eqrelcommringfrac X S) := setquotpr (eqrelcommringfrac X S) (commringfracunel1int X S). Definition commringfracunel2 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : setquot (eqrelcommringfrac X S) := setquotpr (eqrelcommringfrac X S) (commringfracunel2int X S). Lemma commringfracinv1comp (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : iscomprelrelfun (eqrelcommringfrac X S) (eqrelcommringfrac X S) (commringfracinv1int X S). Proof. intros. set (assoc2 := ringassoc2 X). intros xs xs'. simpl. set (ff := @hinhfun). simpl in ff. apply ff. clear ff. intro tt0. split with (pr1 tt0). set (x := pr1 xs). set (s := pr1 (pr2 xs)). set (x' := pr1 xs'). set (s' := pr1 (pr2 xs')). set (a0 := pr1 (pr1 tt0)). change (paths (-1 * x * s' * a0) (-1 * x' * s * a0)). rewrite (assoc2 -1 x s'). rewrite (assoc2 -1 x' s). rewrite (assoc2 -1 (x * s') a0). rewrite (assoc2 -1 (x' * s) a0). apply (maponpaths (λ x0 : X, -1 * x0) (pr2 tt0)). Defined. Definition commringfracinv1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : setquot (eqrelcommringfrac X S) → setquot (eqrelcommringfrac X S) := setquotfun (eqrelcommringfrac X S) (eqrelcommringfrac X S) (commringfracinv1int X S) (commringfracinv1comp X S). Lemma commringfracisinv1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : isinv (commringfracop1 X S) (commringfracunel1 X S) (commringfracinv1 X S). Proof. intros. assert (isl : islinv (commringfracop1 X S) (commringfracunel1 X S) (commringfracinv1 X S)). { set (R := eqrelcommringfrac X S). set (add1int := commringfracop1int X S). set (add1 := commringfracop1 X S). set (inv1 := commringfracinv1 X S). set (inv1int := commringfracinv1int X S). set (qunel1int := commringfracunel1int X S). set (qunel1 := commringfracunel1 X S). set (assoc2 := ringassoc2 X). unfold islinv. apply (setquotunivprop _ (λ x, _ = _)). intro xs. apply (iscompsetquotpr R (add1int (inv1int xs) xs) qunel1int). simpl. apply hinhpr. split with (unel S). set (x := pr1 xs). set (s := pr1 (pr2 xs)). change (paths ((s * (-1 * x) + s * x) * 1 * 1) (0 * (s * s) * 1)). destruct (ringldistr X (-1 * x) x s). rewrite (ringmultwithminus1 X x). rewrite (ringlinvax1 X x). rewrite (ringmultx0 X s). rewrite (ringmult0x X 1). rewrite (ringmult0x X 1). rewrite (ringmult0x X (s * s)). apply (pathsinv0 (ringmult0x X 1)). } apply (make_dirprod isl (weqlinvrinv (commringfracop1 X S) (commringfraccomm1 X S) (commringfracunel1 X S) (commringfracinv1 X S) isl)). Defined. Opaque commringfracisinv1. Lemma commringfraclunit1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : islunit (commringfracop1 X S) (commringfracunel1 X S). Proof. intros. set (R := eqrelcommringfrac X S). set (add1int := commringfracop1int X S). set (add1 := commringfracop1 X S). set (un1 := commringfracunel1 X S). unfold islunit. apply (setquotunivprop R (λ x, _ = _)). intro xs. assert (e0 : paths (add1int (commringfracunel1int X S) xs) xs). { unfold add1int. unfold commringfracop1int. destruct xs as [ x s ]. destruct s as [ s iss ]. apply pathsdirprod. - simpl. change (paths ((s * 0) + (1 * x)) x). rewrite (@ringmultx0 X s). rewrite (ringlunax2 X x). rewrite (ringlunax1 X x). apply idpath. - apply (invmaponpathsincl _ (isinclpr1carrier (pr1 S))). change (paths (1 * s) s). apply (ringlunax2 X s). } apply (maponpaths (setquotpr R) e0). Defined. Opaque commringfraclunit1. Lemma commringfracrunit1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : isrunit (commringfracop1 X S) (commringfracunel1 X S). Proof. intros. apply (weqlunitrunit (commringfracop1 X S) (commringfraccomm1 X S) (commringfracunel1 X S) (commringfraclunit1 X S)). Defined. Opaque commringfracrunit1. Definition commringfracunit1 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : ismonoidop (commringfracop1 X S) := tpair _ (commringfracassoc1 X S) (tpair _ (commringfracunel1 X S) (make_dirprod (commringfraclunit1 X S) (commringfracrunit1 X S))). Definition commringfracop2 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : binop (setquotinset (eqrelcommringfrac X S)) := abmonoidfracop (ringmultabmonoid X) S. Lemma commringfraccomm2 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : iscomm (commringfracop2 X S). Proof. intros. apply (commax (abmonoidfrac (ringmultabmonoid X) S)). Defined. Opaque commringfraccomm2. Lemma commringfracldistr (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : isldistr (commringfracop1 X S) (commringfracop2 X S). Proof. intros. set (R := eqrelcommringfrac X S). set (mult1int := commringfracop2int X S). set (mult1 := commringfracop2 X S). set (add1int := commringfracop1int X S). set (add1 := commringfracop1 X S). unfold isldistr. apply (setquotuniv3prop _ (λ x x' x'', _ = _)). intros xs xs' xs''. apply (iscompsetquotpr R (mult1int xs'' (add1int xs xs')) (add1int (mult1int xs'' xs) (mult1int xs'' xs'))). destruct xs as [ x s ]. destruct xs' as [ x' s' ]. destruct xs'' as [ x'' s'' ]. destruct s'' as [ s'' iss'' ]. simpl. apply hinhpr. split with (unel S). destruct s as [ s iss ]. destruct s' as [ s' iss' ]. simpl. change (paths (((x'' * ((s' * x) + (s * x'))) * ((s'' * s) * (s'' * s'))) * 1) (((((s'' * s') * (x'' * x)) + ((s'' * s) * (x'' * x'))) * (s'' * (s * s'))) * 1)). rewrite (ringldistr X (s' * x) (s * x') x''). rewrite (ringrdistr X _ _ ((s'' * s) * (s'' * s'))). rewrite (ringrdistr X _ _ (s'' * (s * s'))). set (assoc := ringassoc2 X). set (comm := ringcomm2 X). set (rer := @abmonoidoprer X (@op2 X) (commringop2axs X)). assert (e1 : paths ((x'' * (s' * x)) * ((s'' * s) * (s'' * s'))) (((s'' * s') * (x'' * x)) * (s'' * (s * s')))). { destruct (assoc x'' s' x). destruct (comm s' x''). rewrite (assoc s' x'' x). destruct (comm (x'' * x) s'). destruct (comm (x'' * x) (s'' * s')). destruct (assoc s'' s s'). destruct (comm (s'' * s') (s'' * s)). destruct (comm s' (s'' * s)). destruct (rer (x'' * x) s' (s'' * s') (s'' * s)). apply idpath. } assert (e2 : paths ((x'' * (s * x')) * ((s'' * s) * (s'' * s'))) (((s'' * s) * (x'' * x')) * (s'' * (s * s')))). { destruct (assoc x'' s x'). destruct (comm s x''). rewrite (assoc s x'' x'). destruct (comm (x'' * x') s). destruct (comm (x'' * x') (s'' * s)). destruct (rer (x'' * x') (s'' * s) s (s'' * s')). destruct (assoc s s'' s'). destruct (assoc s'' s s'). destruct (comm s s''). apply idpath. } rewrite e1. rewrite e2. apply idpath. Defined. Opaque commringfracldistr. Lemma commringfracrdistr (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : isrdistr (commringfracop1 X S) (commringfracop2 X S). Proof. intros. apply (weqldistrrdistr (commringfracop1 X S) (commringfracop2 X S) (commringfraccomm2 X S) (commringfracldistr X S)). Defined. (** Notes : 1. Construction of the addition on the multiplicative monoid of fractions requires only commutativity and associativity of multiplication and (right) distributivity. No properties of the addition are used. 2. The proof of associtivity for the addition on the multiplicative monoid of fractions requires in the associativity of the original addition but no other properties. *) Definition commringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : commring. Proof. intros. set (R := eqrelcommringfrac X S). set (mult1 := commringfracop2 X S). set (add1 := commringfracop1 X S). set (uset := setquotinset R). apply (commringconstr add1 mult1). - split with (commringfracunit1 X S). split with (commringfracinv1 X S). apply (commringfracisinv1 X S). - apply (commringfraccomm1 X S). - apply (pr2 (abmonoidfrac (ringmultabmonoid X) S)). - apply (commringfraccomm2 X S). - apply (make_dirprod (commringfracldistr X S) (commringfracrdistr X S)). Defined. Definition prcommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : X -> S -> commringfrac X S := λ x s, setquotpr _ (make_dirprod x s). Lemma invertibilityincommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : ∏ a a' : S, isinvertible (@op2 (commringfrac X S)) (prcommringfrac X S (pr1 a) a'). Proof. intros. apply (invertibilityinabmonoidfrac (ringmultabmonoid X) S). Defined. (** **** Canonical homomorphism to the ring of fractions *) Definition tocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) (x : X) : commringfrac X S := setquotpr _ (make_dirprod x (unel S)). Lemma isbinop1funtocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : @isbinopfun X (commringfrac X S) (tocommringfrac X S). Proof. intros. unfold isbinopfun. intros x x'. change (paths (setquotpr _ (make_dirprod (x + x') (unel S))) (setquotpr (eqrelcommringfrac X S) (commringfracop1int X S (make_dirprod x (unel S)) (make_dirprod x' (unel S))))). apply (maponpaths (setquotpr _)). unfold commringfracop1int. simpl. apply pathsdirprod. - rewrite (ringlunax2 X _). rewrite (ringlunax2 X _). apply idpath. - change (paths (unel S) (op (unel S) (unel S))). apply (pathsinv0 (runax S _)). Defined. Opaque isbinop1funtocommringfrac. Lemma isunital1funtocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : (tocommringfrac X S 0) = 0. Proof. intros. apply idpath. Defined. Opaque isunital1funtocommringfrac. Definition isaddmonoidfuntocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : @ismonoidfun X (commringfrac X S) (tocommringfrac X S) := make_dirprod (isbinop1funtocommringfrac X S) (isunital1funtocommringfrac X S). Definition tocommringfracandminus0 (X : commring) (S : @subabmonoid (ringmultabmonoid X)) (x : X) : paths (tocommringfrac X S (- x)) (- tocommringfrac X S x) := grinvandmonoidfun _ _ (isaddmonoidfuntocommringfrac X S) x. Definition tocommringfracandminus (X : commring) (S : @subabmonoid (ringmultabmonoid X)) (x y : X) : paths (tocommringfrac X S (x - y)) (tocommringfrac X S x - tocommringfrac X S y). Proof. intros. rewrite ((isbinop1funtocommringfrac X S x (- y)) : paths (tocommringfrac X S (x - y)) ((tocommringfrac X S x + tocommringfrac X S (- y)))). rewrite (tocommringfracandminus0 X S y). apply idpath. Defined. Opaque tocommringfracandminus. Definition isbinop2funtocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : @isbinopfun (ringmultmonoid X) (ringmultmonoid (commringfrac X S)) (tocommringfrac X S) := isbinopfuntoabmonoidfrac (ringmultabmonoid X) S. Opaque isbinop2funtocommringfrac. Lemma isunital2funtocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : (tocommringfrac X S 1) = 1. Proof. intros. apply idpath. Defined. Opaque isunital2funtocommringfrac. Definition ismultmonoidfuntocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : @ismonoidfun (ringmultmonoid X) (ringmultmonoid (commringfrac X S)) (tocommringfrac X S) := make_dirprod (isbinop2funtocommringfrac X S) (isunital2funtocommringfrac X S). Definition isringfuntocommringfrac (X : commring) (S : @subabmonoid (ringmultabmonoid X)) : @isringfun X (commringfrac X S) (tocommringfrac X S) := make_dirprod (isaddmonoidfuntocommringfrac X S) (ismultmonoidfuntocommringfrac X S). (** **** Ring of fractions in the case when all elements which are being inverted are cancelable *) Definition hrelcommringfrac0 (X : commring) (S : @submonoid (ringmultabmonoid X)) : hrel (X × S) := λ xa yb : setdirprod X S, (pr1 xa) * (pr1 (pr2 yb)) = (pr1 yb) * (pr1 (pr2 xa)). Lemma weqhrelhrel0commringfrac (X : commring) (S : @submonoid (ringmultabmonoid X)) (iscanc : ∏ a : S, isrcancelable (@op2 X) (pr1carrier _ a)) (xa xa' : dirprod X S) : (eqrelcommringfrac X S xa xa') ≃ (hrelcommringfrac0 X S xa xa'). Proof. intros. unfold eqrelabmonoidfrac. unfold hrelabmonoidfrac. simpl. apply weqimplimpl. - apply (@hinhuniv _ (_ = _)). intro ae. destruct ae as [ a eq ]. apply (invmaponpathsincl _ (iscanc a) _ _ eq). - intro eq. apply hinhpr. split with (unel S). rewrite (ringrunax2 X). rewrite (ringrunax2 X). apply eq. - apply (isapropishinh _). - apply (setproperty X). Defined. Opaque weqhrelhrel0abmonoidfrac. Lemma isinclprcommringfrac (X : commring) (S : @submonoid (ringmultabmonoid X)) (iscanc : ∏ a : S, isrcancelable (@op2 X) (pr1carrier _ a)) : ∏ a' : S, isincl (λ x, prcommringfrac X S x a'). Proof. intros. apply isinclbetweensets. apply (setproperty X). apply (setproperty (commringfrac X S)). intros x x'. intro e. set (e' := invweq (weqpathsinsetquot (eqrelcommringfrac X S) (make_dirprod x a') (make_dirprod x' a')) e). set (e'' := weqhrelhrel0commringfrac X S iscanc (make_dirprod _ _) (make_dirprod _ _) e'). simpl in e''. apply (invmaponpathsincl _ (iscanc a')). apply e''. Defined. Definition isincltocommringfrac (X : commring) (S : @submonoid (ringmultabmonoid X)) (iscanc : ∏ a : S, isrcancelable (@op2 X) (pr1carrier _ a)) : isincl (tocommringfrac X S) := isinclprcommringfrac X S iscanc (unel S). Lemma isdeceqcommringfrac (X : commring) (S : @submonoid (ringmultabmonoid X)) (iscanc : ∏ a : S, isrcancelable (@op2 X) (pr1carrier _ a)) (is : isdeceq X) : isdeceq (commringfrac X S). Proof. intros. apply (isdeceqsetquot (eqrelcommringfrac X S)). intros xa xa'. apply (isdecpropweqb (weqhrelhrel0commringfrac X S iscanc xa xa')). apply isdecpropif. unfold isaprop. simpl. set (int := setproperty X (pr1 xa * pr1 (pr2 xa')) (pr1 xa' * pr1 (pr2 xa))). simpl in int. apply int. unfold hrelcommringfrac0. simpl. apply (is _ _). Defined. (** **** Relations similar to "greater" or "greater or equal" on the rings of fractions *) Lemma ispartbinopcommringfracgt (X : commring) (S : @submonoid (ringmultabmonoid X)) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : isringmultgt X R) (is2 : ∏ c : X, S c -> R c 0) : @ispartbinophrel (ringmultabmonoid X) S R. Proof. intros. split. - intros a b c s rab. apply (isringmultgttoislringmultgt X is0 is1 _ _ _ (is2 c s) rab). - intros a b c s rab. apply (isringmultgttoisrringmultgt X is0 is1 _ _ _ (is2 c s) rab). Defined. Definition commringfracgt (X : commring) (S : @submonoid (ringmultabmonoid X)) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : isringmultgt X R) (is2 : ∏ c : X, S c -> R c 0) : hrel (commringfrac X S) := abmonoidfracrel (ringmultabmonoid X) S (ispartbinopcommringfracgt X S is0 is1 is2). Lemma isringmultcommringfracgt (X : commring) (S : @submonoid (ringmultabmonoid X)) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : isringmultgt X R) (is2 : ∏ c : X, S c -> R c 0) : isringmultgt (commringfrac X S) (commringfracgt X S is0 is1 is2). Proof. intros. set (rer2 := (abmonoidrer (ringmultabmonoid X)) : ∏ a b c d : X, paths ((a * b) * (c * d)) ((a * c) * (b * d))). apply islringmultgttoisringmultgt. assert (int : ∏ (a b c : ringaddabgr (commringfrac X S)), isaprop (commringfracgt X S is0 is1 is2 c 0 -> commringfracgt X S is0 is1 is2 a b -> commringfracgt X S is0 is1 is2 (c * a) (c * b))). { intros a b c. apply impred. intro. apply impred. intro. apply (pr2 _). } apply (setquotuniv3prop _ (λ a b c, make_hProp _ (int a b c))). intros xa1 xa2 xa3. change (abmonoidfracrelint (ringmultabmonoid X) S R xa3 (make_dirprod 0 (unel S)) -> abmonoidfracrelint (ringmultabmonoid X) S R xa1 xa2 -> abmonoidfracrelint (ringmultabmonoid X) S R (commringfracop2int X S xa3 xa1) (commringfracop2int X S xa3 xa2)). simpl. apply hinhfun2. intros t21 t22. set (c1s := pr1 t21). set (c1 := pr1 c1s). set (r1 := pr2 t21). set (c2s := pr1 t22). set (c2 := pr1 c2s). set (r2 := pr2 t22). set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). set (x3 := pr1 xa3). set (a3 := pr1 (pr2 xa3)). split with (@op S c1s c2s). change (pr1 (R (x3 * x1 * (a3 * a2) * (c1 * c2)) (x3 * x2 * (a3 * a1) * (c1 * c2)))). rewrite (ringcomm2 X a3 a2). rewrite (ringcomm2 X a3 a1). rewrite (ringassoc2 X _ _ (c1 * c2)). rewrite (ringassoc2 X (x3 * x2) _ (c1 * c2)). rewrite (rer2 _ a3 c1 _). rewrite (rer2 _ a3 c1 _). rewrite (ringcomm2 X a2 c1). rewrite (ringcomm2 X a1 c1). rewrite (pathsinv0 (ringassoc2 X (x3 * x1) _ _)). rewrite (pathsinv0 (ringassoc2 X (x3 * x2) _ _)). rewrite (rer2 _ x1 c1 _). rewrite (rer2 _ x2 c1 _). rewrite (ringcomm2 X a3 c2). rewrite (pathsinv0 (ringassoc2 X _ c2 a3)). rewrite (pathsinv0 (ringassoc2 X _ c2 _)). apply ((isringmultgttoisrringmultgt X is0 is1) _ _ _ (is2 _ (pr2 (pr2 xa3)))). rewrite (ringassoc2 X _ _ c2). rewrite (ringassoc2 X _ (x2 * a1) c2). simpl in r1. clearbody r1. simpl in r2. clearbody r2. change (pr1 (R (x3 * 1 * c1) (0 * a3 * c1))) in r1. rewrite (ringrunax2 _ _) in r1. rewrite (ringmult0x X _) in r1. rewrite (ringmult0x X _) in r1. apply ((isringmultgttoislringmultgt X is0 is1) _ _ _ r1 r2). Defined. Opaque isringmultcommringfracgt. Lemma isringaddcommringfracgt (X : commring) (S : @submonoid (ringmultabmonoid X)) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : isringmultgt X R) (is2 : ∏ c : X, S c -> R c 0) : @isbinophrel (commringfrac X S) (commringfracgt X S is0 is1 is2). Proof. intros. set (rer2 := (abmonoidrer (ringmultabmonoid X)) : ∏ a b c d : X, paths ((a * b) * (c * d)) ((a * c) * (b * d))). apply isbinophrelif. intros a b. apply (ringcomm1 (commringfrac X S) a b). assert (int : ∏ (a b c : ringaddabgr (commringfrac X S)), isaprop (commringfracgt X S is0 is1 is2 a b -> commringfracgt X S is0 is1 is2 (op c a) (op c b))). { intros a b c. apply impred. intro. apply (pr2 _). } apply (setquotuniv3prop _ (λ a b c, make_hProp _ (int a b c))). intros xa1 xa2 xa3. change (abmonoidfracrelint (ringmultabmonoid X) S R xa1 xa2 -> abmonoidfracrelint (ringmultabmonoid X) S R (commringfracop1int X S xa3 xa1) (commringfracop1int X S xa3 xa2)). simpl. apply hinhfun. intro t2. set (c0s := pr1 t2). set (c0 := pr1 c0s). set (r := pr2 t2). split with c0s. set (x1 := pr1 xa1). set (a1 := pr1 (pr2 xa1)). set (x2 := pr1 xa2). set (a2 := pr1 (pr2 xa2)). set (x3 := pr1 xa3). set (a3 := pr1 (pr2 xa3)). change (pr1 (R ((a1 * x3 + a3 * x1) * (a3 * a2) * c0) ((a2 * x3 + a3 * x2) * (a3 * a1) * c0))). rewrite (ringassoc2 X _ _ c0). rewrite (ringassoc2 X _ (a3 * _) c0). rewrite (ringrdistr X _ _ _). rewrite (ringrdistr X _ _ _). rewrite (rer2 _ x3 _ _). rewrite (rer2 _ x3 _ _). rewrite (ringcomm2 X a3 a2). rewrite (ringcomm2 X a3 a1). rewrite (pathsinv0 (ringassoc2 X a1 a2 a3)). rewrite (pathsinv0 (ringassoc2 X a2 a1 a3)). rewrite (ringcomm2 X a1 a2). apply ((pr1 is0) _ _ _). rewrite (ringcomm2 X a2 a3). rewrite (ringcomm2 X a1 a3). rewrite (ringassoc2 X a3 a2 c0). rewrite (ringassoc2 X a3 a1 c0). rewrite (rer2 _ x1 a3 _). rewrite (rer2 _ x2 a3 _). rewrite (pathsinv0 (ringassoc2 X x1 _ _)). rewrite (pathsinv0 (ringassoc2 X x2 _ _)). apply ((isringmultgttoislringmultgt X is0 is1) _ _ _ (is2 _ (pr2 (@op S (pr2 xa3) (pr2 xa3)))) r). Defined. Opaque isringaddcommringfracgt. Definition isdeccommringfracgt (X : commring) (S : @submonoid (ringmultabmonoid X)) {R : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) R) (is1 : isringmultgt X R) (is2 : ∏ c : X, S c -> R c 0) (is' : @ispartinvbinophrel (ringmultabmonoid X) S R) (isd : isdecrel R) : isdecrel (commringfracgt X S is0 is1 is2). Proof. intros. apply (isdecabmonoidfracrel (ringmultabmonoid X) S (ispartbinopcommringfracgt X S is0 is1 is2) is' isd). Defined. Lemma StrongOrder_correct_commrngfrac (X : commring) (Y : @subabmonoid (ringmultabmonoid X)) (gt : StrongOrder X) Hgt Hle Hmult Hpos : commringfracgt X Y (R := gt) Hle Hmult Hpos = StrongOrder_abmonoidfrac Y gt Hgt. Proof. apply funextfun ; intros x. apply funextfun ; intros y. apply (maponpaths (λ H, abmonoidfracrel (ringmultabmonoid X) Y H x y)). apply isaprop_ispartbinophrel. Defined. (** **** Relations and the canonical homomorphism to the ring of fractions *) Definition iscomptocommringfrac (X : commring) (S : @submonoid (ringmultabmonoid X)) {L : hrel X} (is0 : @isbinophrel (rigaddabmonoid X) L) (is1 : isringmultgt X L) (is2 : ∏ c : X, S c -> L c 0) : iscomprelrelfun L (commringfracgt X S is0 is1 is2) (tocommringfrac X S) := iscomptoabmonoidfrac (ringmultabmonoid X) S (ispartbinopcommringfracgt X S is0 is1 is2). Opaque iscomptocommringfrac. Close Scope ring_scope. (* End of the file *) UniMath-20231010/UniMath/Algebra/RigsAndRings/000077500000000000000000000000001451125700300205435ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/RigsAndRings/Ideals.v000066400000000000000000000131211451125700300221310ustar00rootroot00000000000000(** * Ideals Author: Langston Barrett (@siddharthist) *) (** ** Contents - Definitions - Left ideals ([lideal]) - Right ideals ([rideal]) - Two-sided ideals ([ideal]) - The above notions coincide for commutative rigs - Kernel ideal - Unit ideal - Prime ideal - Localization at a prime ideal *) Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.MoreFoundations.Notations. Local Open Scope logic. Local Open Scope ring. Local Open Scope rig. Section Definitions. Context {R : rig}. (** *** Left ideals ([lideal]) *) Definition is_lideal (S : subabmonoid (rigaddabmonoid R)) : hProp := ∀ r s : R, S s ⇒ S (r * s). Definition lideal : UU := ∑ S : subabmonoid (rigaddabmonoid R), is_lideal S. Definition make_lideal : ∏ (S : subabmonoid (rigaddabmonoid R)), is_lideal S → lideal := tpair _. (** *** Right ideals ([rideal]) *) Definition is_rideal (S : subabmonoid (rigaddabmonoid R)) : hProp := ∀ r s : R, S s ⇒ S (s * r). Definition rideal : UU := ∑ S : subabmonoid (rigaddabmonoid R), is_rideal S. Definition make_rideal : ∏ (S : subabmonoid (rigaddabmonoid R)), is_rideal S → rideal := tpair _. (** *** Two-sided ideals ([ideal]) *) Definition is_ideal (S : subabmonoid (rigaddabmonoid R)) : hProp := hconj (is_lideal S) (is_rideal S). Definition ideal : UU := ∑ S : subabmonoid (rigaddabmonoid R), is_ideal S. Definition make_ideal (S : subabmonoid (rigaddabmonoid R)) (isl : is_lideal S) (isr : is_rideal S) : ideal := tpair _ S (make_dirprod isl isr). Definition ideal_subabmonoid (I : ideal) : subabmonoid (rigaddabmonoid R) := pr1 I. Coercion ideal_subabmonoid : ideal >-> subabmonoid. Definition ideal_isl (I : ideal) : is_lideal I := pr12 I. Definition ideal_isr (I : ideal) : is_rideal I := pr22 I. Lemma isaset_ideal : isaset ideal. Proof. apply isaset_total2. - apply isaset_submonoid. - intro S. apply isasetaprop, propproperty. Defined. End Definitions. Arguments lideal _ : clear implicits. Arguments rideal _ : clear implicits. Arguments ideal _ : clear implicits. Arguments isaset_ideal _ : clear implicits. (** *** The above notions for commutative rigs *) Lemma commrig_ideals (R : commrig) (S : subabmonoid (rigaddabmonoid R)) : is_lideal S ≃ is_rideal S. Proof. apply weqimplimpl. - intros islid r s ss. use transportf. + exact (S (r * s)). + exact (maponpaths S (rigcomm2 _ _ _)). + apply (islid r s ss). - intros isrid r s ss. use transportf. + exact (S (s * r)). + exact (maponpaths S (rigcomm2 _ _ _)). + apply (isrid r s ss). - apply propproperty. - apply propproperty. Defined. Corollary commrig_ideals' (R : commrig) : lideal R ≃ rideal R. Proof. apply weqfibtototal; intro; apply commrig_ideals. Defined. (** ** Kernel ideal *) (** The kernel of a rig homomorphism is a two-sided ideal. *) Definition kernel_ideal {R S : rig} (f : rigfun R S) : @ideal R. Proof. use make_ideal. - use make_submonoid. + exact (@monoid_kernel_hsubtype (rigaddabmonoid R) (rigaddabmonoid S) (rigaddfun f)). + (** This does, in fact, describe a submonoid *) apply kernel_issubmonoid. - (** It's closed under × from the left *) intros r s ss; cbn in *. refine (monoidfunmul (rigmultfun f) _ _ @ _); cbn. refine (maponpaths _ ss @ _). refine (rigmultx0 _ (pr1 f r) @ _). reflexivity. - intros r s ss; cbn in *. refine (monoidfunmul (rigmultfun f) _ _ @ _); cbn. abstract (rewrite ss; refine (rigmult0x _ (pr1 f r) @ _); reflexivity). Defined. (** ** Unit ideal *) Lemma ideal_rigunel2 {R : rig} (I : ideal R) : I 1 -> forall x, I x. Proof. intros H x. apply (transportf (λ x, I x) (rigrunax2 _ x)). exact (ideal_isl _ _ _ H). Qed. (** ** Prime ideal *) Section prime. Context {R : commring}. Definition is_prime (I : ideal R) : hProp := (∀ a b, I (a * b) ⇒ I a ∨ I b) ∧ (¬ I 1). Definition prime_ideal : UU := ∑ p : ideal R, is_prime p. Definition make_prime_ideal (p : ideal R) (H1 : ∀ a b, p (a * b) ⇒ p a ∨ p b) (H2 : ¬ p 1) : prime_ideal := p ,, H1 ,, H2. Definition prime_ideal_ideal (p : prime_ideal) : ideal R := pr1 p. Coercion prime_ideal_ideal : prime_ideal >-> ideal. Definition prime_ideal_ax1 (p : prime_ideal) : ∀ a b, p (a * b) ⇒ p a ∨ p b := pr12 p. Definition prime_ideal_ax2 (p : prime_ideal) : ¬ p 1 := pr22 p. End prime. Arguments prime_ideal _ : clear implicits. Section prime_facts. Context {R : commring} (p : prime_ideal R). Lemma isaset_prime_ideal : isaset (prime_ideal R). Proof. apply isaset_total2. - apply isaset_ideal. - intro I. apply isasetaprop, propproperty. Qed. Lemma prime_ideal_ax1_contraposition : ∀ a b : R, ¬ p a ⇒ ¬ p b ⇒ ¬ p (a * b). Proof. intros a b Ha Hb. apply (negf (prime_ideal_ax1 p a b)), toneghdisj. exact (make_dirprod Ha Hb). Qed. End prime_facts. (** ** Localization at a prime ideal *) Section localization. Context {R : commring}. Definition prime_ideal_complement (p : prime_ideal R) : subabmonoid (ringmultabmonoid R). Proof. use make_submonoid. - intro x. exact (¬ p x). - use make_issubmonoid. + intros a b. exact (prime_ideal_ax1_contraposition _ _ _ (pr2 a) (pr2 b)). + exact (prime_ideal_ax2 p). Defined. Definition localization_at (p : prime_ideal R) : commring := commringfrac _ (prime_ideal_complement p). Definition quotient {p : prime_ideal R} (a : R) (b : prime_ideal_complement p) : localization_at p := prcommringfrac _ _ a b. End localization. UniMath-20231010/UniMath/Algebra/Tests.v000066400000000000000000000035651451125700300175130ustar00rootroot00000000000000Require UniMath.Algebra.IteratedBinaryOperations. Require UniMath.Foundations.NaturalNumbers. Require UniMath.Algebra.IteratedBinaryOperations. Require UniMath.Combinatorics.FiniteSets. Module Test_assoc. Import UniMath.Algebra.IteratedBinaryOperations. Import UniMath.Foundations.NaturalNumbers. (* verify that our associativity matches that of the parser, without an extra "1" *) Local Notation "[]" := Lists.nil (at level 0, format "[]"). Local Infix "::" := cons. Section Test. Context (X:UU) (e:X) (op:binop X) (w x y z:X). Goal iterop_list e op [] = e. reflexivity. Qed. Goal iterop_list e op (x::[]) = x. reflexivity. Qed. Goal iterop_list e op (x::y::[]) = op x y. reflexivity. Qed. Goal iterop_list e op (w::x::y::z::[]) = op w (op x (op y z)). reflexivity. Qed. End Test. Local Open Scope stn. Open Scope multmonoid. Goal ∏ (M:monoid) (f:stn 3 -> M), iterop_seq_mon(3,,f) = f(●O) * f(●1%nat) * f(●2). Proof. reflexivity. Defined. Goal ∏ (M:monoid) (f:stn 3 -> Sequence M), iterop_seq_seq_mon(3,,f) = iterop_seq_mon (f(●0)) * iterop_seq_mon (f(●1%nat)) * iterop_seq_mon (f(●2)). Proof. reflexivity. Defined. (* demonstrate that the Coq parser is left-associative with "*" *) Goal ∏ (M:monoid) (x y z:M), x*y*z = (x*y)*z. Proof. reflexivity. Defined. Goal ∏ (M:monoid) (x y z:M), x*y*z = x*(y*z). Proof. apply assocax. Defined. (* demonstrate that the Coq parser is left-associative with "+" *) Local Open Scope addmonoid. Import UniMath.Algebra.Monoids.AddNotation. Goal ∏ (M:monoid) (x y z:M), x+y+z = (x+y)+z. Proof. reflexivity. Defined. Goal ∏ (M:monoid) (x y z:M), x+y+z = x+(y+z). Proof. apply assocax. Defined. End Test_assoc. (* Local Variables: compile-command: "make -C ../../.. TAGS UniMath/Foundations/Algebra/Tests.vo" End: *) UniMath-20231010/UniMath/Algebra/Universal.v000066400000000000000000000001631451125700300203500ustar00rootroot00000000000000(** * Universal algebra: signatures, algebras and terms *) Require Export UniMath.Algebra.Universal.FreeAlgebras. UniMath-20231010/UniMath/Algebra/Universal/000077500000000000000000000000001451125700300201615ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/Universal/Algebras.v000066400000000000000000000115761451125700300221020ustar00rootroot00000000000000(** * Algebra for a given signature. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.All. Require Export UniMath.Algebra.Universal.SortedTypes. Require Export UniMath.Algebra.Universal.Signatures. Local Open Scope sorted. (** ** Basic definitions. *) Definition algebra (σ: signature): UU := ∑ A: shSet (sorts σ), ∏ nm: names σ, A⋆ (arity nm) → A (sort nm). Definition supportset {σ: signature} (A: algebra σ) : shSet (sorts σ) := pr1 A. Definition support {σ: signature} (A: algebra σ): sUU (sorts σ) := pr1 A. Coercion support: algebra >-> sUU. Definition ops {σ: signature} (A: algebra σ) := pr2 A. Definition make_algebra {σ: signature} (A : shSet (sorts σ)) (ops: ∏ nm: names σ, A⋆ (arity nm) → A (sort nm)) : algebra σ := A ,, ops. Definition dom {σ: signature} (A: algebra σ) (nm: names σ): UU := A⋆ (arity nm). Definition rng {σ: signature} (A: algebra σ) (nm: names σ): UU := support A (sort nm). (** ** Helper for building an algebra starting from a simple signature. A simple signature is either a [signature_simple_single_sorted] for the single-sorted case or a [signature_single] for the multi-sorted case. *) Definition make_algebra_simple_single_sorted (σ : signature_simple_single_sorted) (A : hSet) (ops : (λ n: nat, vec A n → A)⋆ σ) : algebra σ. Proof. exists (λ _, A). unfold arity. revert σ ops. refine (list_ind _ _ _). - intros. cbn in nm. apply fromstn0. assumption. - intros x xs IHxs ops nm. simpl in ops. induction nm as [nm nmproof]. induction nm. + unfold star. exact (pr1 ops ∘ h1lower). + exact (IHxs (pr2 ops) (nm ,, nmproof)). Defined. Definition make_algebra_simple (σ: signature_simple) (A: vec hSet (pr1 σ)) (ops: (λ a, (el A)⋆ (dirprod_pr1 a) → el A (dirprod_pr2 a))⋆ (pr2 σ)) : algebra σ. Proof. exists (el A). unfold arity. induction σ as [ns ar]. simpl in A. revert ar ops. refine (list_ind _ _ _). - intros. cbn in nm. apply fromstn0. assumption. - simpl. intros x xs IHxs ops. induction ops as [op ops]. intro. cbn in nm. induction nm as [nm nmproof]. induction nm. + unfold star. exact op. + exact (IHxs ops (nm ,, nmproof)). Defined. (** ** Homomorphisms of algebras. *) Definition ishom {σ: signature} {A1 A2: algebra σ} (h: A1 s→ A2) : UU := ∏ (nm: names σ) (x: dom A1 nm), h _ (ops A1 nm x) = ops A2 nm (h⋆⋆ _ x). Definition hom {σ: signature} (A1 A2: algebra σ): UU := ∑ (h: A1 s→ A2), ishom h. Declare Scope hom_scope. Notation "a1 ↷ a2" := (hom a1 a2) (at level 80, right associativity): hom_scope. Delimit Scope hom_scope with hom. Bind Scope hom_scope with hom. Local Open Scope hom. Definition hom2fun {σ: signature} {A1 A2: algebra σ} (f: A1 ↷ A2): ∏ s: sorts σ, support A1 s → support A2 s:= pr1 f. Coercion hom2fun: hom >-> Funclass. Definition hom2axiom {σ: signature} {A1 A2: algebra σ} (f: A1 ↷ A2) := pr2 f. Definition make_hom {σ: signature} {A1 A2: algebra σ} {f: sfun A1 A2} (is: ishom f): A1 ↷ A2 := f ,, is. Theorem isapropishom {σ: signature} {A1 A2: algebra σ} (f: sfun A1 A2): isaprop (ishom f). Proof. red. apply impred_isaprop. intros. apply impred_isaprop. intros. apply setproperty. Defined. Theorem isasethom {σ: signature} (A1 A2: algebra σ): isaset (A1 ↷ A2). Proof. red. apply isaset_total2. - apply isaset_set_sfun_space. - intros. apply isasetaprop. apply isapropishom. Defined. (** ** Identity and composition of homomorphisms. *) Lemma ishomid {σ: signature} (A: algebra σ): ishom (idsfun A). Proof. red. intros. rewrite staridfun. apply idpath. Defined. Definition homid {σ: signature} (A: algebra σ): A ↷ A := make_hom (ishomid A). Lemma ishomcomp {σ: signature} {A1 A2 A3: algebra σ} (h1: A1 ↷ A2) (h2: A2 ↷ A3): ishom (h2 s∘ h1). Proof. red. intros. induction h1 as [h1 ishomh1]. induction h2 as [h2 ishomh2]. cbn. rewrite starcomp. rewrite ishomh1. rewrite ishomh2. apply idpath. Defined. Definition homcomp {σ: signature} {a1 a2 a3: algebra σ} (h1: a1 ↷ a2) (h2: a2 ↷ a3) : a1 ↷ a3 := make_hom (ishomcomp h1 h2). (** ** The unit algebra and the proof it is final. *) Definition unitalgebra (σ: signature): algebra σ := make_algebra (sunitset (sorts σ)) tosunit. Lemma ishomtounit {σ: signature} (A: algebra σ): @ishom σ A (unitalgebra σ) tosunit. Proof. red. intros. apply iscontrunit. Defined. Definition unithom {σ: signature} (A : algebra σ): hom A (unitalgebra σ) := make_hom (ishomtounit A). Theorem iscontrhomstounit {σ: signature} (A: algebra σ): iscontr (hom A (unitalgebra σ)). Proof. exists (unithom A). intro. apply subtypePairEquality'. - apply proofirrelevancecontr. apply iscontr_sfuntosunit. - apply isapropishom. Defined. UniMath-20231010/UniMath/Algebra/Universal/EqAlgebras.v000066400000000000000000000022241451125700300223560ustar00rootroot00000000000000(** * Varieties. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains a formalization of equational algebras, i.e., algebra which are models of an equation system. *) Require Import UniMath.MoreFoundations.Notations. Require Export UniMath.Algebra.Universal.Algebras. Require Export UniMath.Algebra.Universal.Equations. Section Varieties. Definition holds {σ: signature} {V: varspec σ} (a: algebra σ) (e: equation σ V) : UU := ∏ α, fromterm (ops a) α (eqsort e) (lhs e) = fromterm (ops a) α (eqsort e) (rhs e). Definition is_eqalgebra {σ : eqspec} (a : algebra σ) : UU := ∏ e: equations σ, holds a (geteq e). Definition eqalgebra (σ : eqspec) : UU := ∑ a : algebra σ, is_eqalgebra a. Definition algebra_of_eqalgebra {σ : eqspec} : eqalgebra σ -> algebra σ := pr1. Coercion algebra_of_eqalgebra : eqalgebra >-> algebra. Definition eqalgebra_proof {σ : eqspec} (a : eqalgebra σ) : is_eqalgebra a := pr2 a. Definition make_eqalgebra {σ : eqspec} (a : algebra σ) (H : is_eqalgebra a) : eqalgebra σ := tpair is_eqalgebra a H. End Varieties. UniMath-20231010/UniMath/Algebra/Universal/Equations.v000066400000000000000000000034611451125700300223240ustar00rootroot00000000000000(** * Equations over a signature and equational theories *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains a formalization of equations and equation systems over a signature. *) Require Import UniMath.MoreFoundations.Notations. Require Export UniMath.Algebra.Universal.VTerms. Section Equations. (** An equation is a pair of terms (with variables) of the same sort *) Definition equation (σ : signature) (V: varspec σ): UU := ∑ s: sorts σ, term σ V s × term σ V s. Definition eqsort {σ: signature} {V: varspec σ} (eq: equation σ V) : sorts σ := pr1 eq. Definition lhs {σ : signature} {V: varspec σ} (eq: equation σ V): term σ V (eqsort eq) := pr12 eq. Definition rhs {σ : signature} {V: varspec σ} (eq: equation σ V): term σ V (eqsort eq) := pr22 eq. (** Since we do not have power types, we define an equation system as a type of equation identifiers endowed with a map from identifiers to equations. *) Definition eqsystem (σ : signature) (V: varspec σ): UU := ∑ E : UU, E → equation σ V. Definition eqsystemids (σ : signature) (V: varspec σ): eqsystem σ V → UU := pr1. Coercion eqsystemids : eqsystem >-> UU. Definition geteq {σ: signature} {V: varspec σ} {sys : eqsystem σ V}: sys → equation σ V := pr2 sys. (** An equational specification is a signature endowed with an equation system (and the necessary variable specification). *) Definition eqspec: UU := ∑ (σ : signature) (V: varspec σ), eqsystem σ V. Definition signature_of_eqspec: eqspec → signature := pr1. Coercion signature_of_eqspec : eqspec >-> signature. Definition variables (σ: eqspec): varspec σ := pr12 σ. Definition equations (σ: eqspec): eqsystem σ (variables σ) := pr22 σ. End Equations. UniMath-20231010/UniMath/Algebra/Universal/Examples/000077500000000000000000000000001451125700300217375ustar00rootroot00000000000000UniMath-20231010/UniMath/Algebra/Universal/Examples/Bool.v000066400000000000000000000075761451125700300230400ustar00rootroot00000000000000(** * Example on booleans. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains the definition of the signature of booleans and the standard boolean algebra. *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.Bool. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.MoreLists. Require Import UniMath.Algebra.Universal.Algebras. Require Import UniMath.Algebra.Universal.VTerms. Local Open Scope stn. Definition bool_signature := make_signature_simple_single_sorted [0; 0; 1; 2; 2; 2]. (** ** Algebra structure over type bool. *) Definition bool_algebra := make_algebra_simple_single_sorted bool_signature boolset [( λ _, false ; λ _, true ; λ x, negb (pr1 x) ; λ x, andb (pr1 x) (pr12 x) ; λ x, orb (pr1 x) (pr12 x) ; λ x, implb (pr1 x) (pr12 x) )]. (** ** Boolean ground terms. *) Module GTerm. (** The type of ground terms. *) Definition T := gterm bool_signature tt. (** Constructors for ground terms. *) Definition bot : T := build_gterm_curried (●0 : names bool_signature). Definition top : T := build_gterm_curried (●1 : names bool_signature). Definition neg : T → T := build_gterm_curried (●2 : names bool_signature). Definition conj : T → T → T := build_gterm_curried (●3 : names bool_signature). Definition disj : T → T → T := build_gterm_curried (●4 : names bool_signature). Definition impl : T → T → T := build_gterm_curried (●5 : names bool_signature). End GTerm. (** ** Booleans terms and semantics for boolean formulae. *) Module Term. Definition bool_varspec := make_varspec bool_signature natset (λ _, tt). (** Type for boolean (open) terms. *) Definition T := term bool_signature bool_varspec tt. (** Constructors for terms. *) Definition bot : T := build_term_curried (●0 : names bool_signature). Definition top : T := build_term_curried (●1 : names bool_signature). Definition neg : T → T := build_term_curried (●2 : names bool_signature). Definition conj : T → T → T := build_term_curried (●3 : names bool_signature). Definition disj : T → T → T := build_term_curried (●4 : names bool_signature). Definition impl : T → T → T := build_term_curried (●5 : names bool_signature). (** Interpretation of propositional formulae. *) Definition interp (α: assignment bool_algebra bool_varspec) (t: T) : bool := fromterm (ops bool_algebra) α tt t. (** Computations and interactive proofs. *) Module Tests. Definition x : T := varterm (0: bool_varspec). Definition y : T := varterm (1: bool_varspec). Definition z : T := varterm (2: bool_varspec). (** Example: evaluation of true & false *) Eval lazy in interp (λ n, false) (conj top bot). (** A simple evaluation function for variables: assign true to x and y (the 0th and 1st variable) and false otherwise. *) Definition v n := match n with 0 => true | 1 => true | _ => false end. (** Example: evaluation of x ∧ (¬ y ∧ z) *) Eval lazy in interp v (conj x (conj (neg y) z)). (** Example: evaluation of x ∧ (z → ¬ y) *) Eval lazy in interp v (conj x (impl z (neg y))). (** Dummett tautology *) Local Lemma Dummett : ∏ i, interp i (disj (impl x y) (impl y x)) = true. Proof. intro i. lazy. induction (i 0); induction (i 1); apply idpath. Qed. (** x ∨ ¬ (y ∧ z → x) *) Local Lemma not_tautology : ∑ i, interp i (disj x (neg (impl (conj y z) x))) = false. Proof. use tpair. - exact (λ n, match n with _ => false end). - lazy. apply idpath. Qed. (** Further tests. *) Definition f (n : nat) : bool. Proof. induction n as [|n Hn]. - exact true. - exact false. Defined. Eval lazy in interp f (conj x top). Eval lazy in interp f (conj x y). Eval lazy in interp f (disj x y). Eval lazy in interp f (disj x (conj y bot)). End Tests. End Term. UniMath-20231010/UniMath/Algebra/Universal/Examples/Group.v000066400000000000000000000051531451125700300232260ustar00rootroot00000000000000(** * Example on groups. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains the definition of the signature of groups and the way to turn a group (as defined in [UniMath.Algebra.Groups]) into an algebra. *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.MoreLists. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Universal.EqAlgebras. Local Open Scope stn. (** Group structure without equations. *) Definition group_signature := make_signature_simple_single_sorted [2; 0; 1]. (** Algebra of groups. *) Module Algebra. Definition group_mul_op: names group_signature := ●0. Definition group_id_op: names group_signature := ●1. Definition group_inv_op: names group_signature := ●2. Section GroupAlgebra. Context (G: gr). Definition group_algebra := make_algebra_simple_single_sorted group_signature G [( λ p, op (pr1 p) (pr12 p) ; λ _, unel G ; λ p, grinv G (pr1 p) )]. End GroupAlgebra. Definition group_mul := build_gterm_curried group_mul_op. Definition group_id := build_gterm_curried group_id_op. Definition group_inv := build_gterm_curried group_inv_op. End Algebra. Module Eqspec. (** Equational specification and the free algebra of open terms. *) Definition group_varspec : varspec group_signature := make_varspec group_signature natset (λ _, tt). Definition G := term group_signature group_varspec tt. Definition group_mul: G → G → G := build_term_curried (●0 : names group_signature). Definition group_id: G := build_term_curried (●1 : names group_signature). Definition group_inv: G → G := build_term_curried (●2 : names group_signature). Definition x : G := varterm (0: group_varspec). Definition y : G := varterm (1: group_varspec). Definition z : G := varterm (2: group_varspec). Definition group_equation := equation group_signature group_varspec. Definition group_mul_assoc : group_equation := tt,, make_dirprod (group_mul (group_mul x y) z) (group_mul x (group_mul y z)). Definition group_mul_lid : group_equation := tt,, make_dirprod (group_mul group_id x) x. Definition group_mul_rid : group_equation := tt,, make_dirprod (group_mul group_id x) x. Definition group_axioms : eqsystem group_signature group_varspec := ⟦ 3 ⟧,, three_rec group_mul_assoc group_mul_lid group_mul_rid. Definition group_eqspec : eqspec. Proof. use tpair. { exact group_signature. } use tpair. { exact group_varspec. } exact group_axioms. Defined. Definition group_eqalgebra := eqalgebra group_eqspec. End Eqspec. UniMath-20231010/UniMath/Algebra/Universal/Examples/ListDataType.v000066400000000000000000000036311451125700300245000ustar00rootroot00000000000000(** * Example of lists *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.MoreLists. Require Import UniMath.Algebra.Universal.Algebras. Require Import UniMath.Algebra.Universal.Terms. Local Open Scope stn. (** Indexes for the sorts. *) Definition elem_sort_idx: ⟦ 2 ⟧ := ●0. Definition list_sort_idx: ⟦ 2 ⟧ := ●1. (** Signature for lists with two symbols: nil and cons constructors. *) Definition list_signature: signature_simple := make_signature_simple [ (nil ,, list_sort_idx) ; ( [elem_sort_idx ; list_sort_idx] ,, list_sort_idx ) ]%list. (** Names for the constructors. *) Definition nil_idx: names list_signature := ●0. Definition cons_idx: names list_signature := ●1. Definition list_algebra (A: hSet) : algebra list_signature := make_algebra_simple list_signature [( A ; listset A )] [( λ _, nil ; λ p, cons (pr1 p) (pr12 p) )]. (** Correspondence between structures and operations in the universal algebra of lists and standard structures and operations on lists. *) Lemma elem_sort_id (A: hSet) : support (list_algebra A) elem_sort_idx = A. Proof. reflexivity. Qed. Lemma list_sort_id (A: hSet) : support (list_algebra A) list_sort_idx = listset A. Proof. reflexivity. Qed. Definition list_nil (A: hSet) : listset A := ops (list_algebra A) nil_idx tt. Lemma list_nil_id (A: hSet) : list_nil A = @nil A. Proof. reflexivity. Qed. Lemma list_cons_dom_id (A: hSet) : dom (list_algebra A) cons_idx = (dirprod A (dirprod (listset A) unit)). Proof. reflexivity. Qed. Definition list_cons (A: hSet) : A × listset A × unit → listset A := ops (list_algebra A) cons_idx. Lemma cons_nil_id (A: hSet) (x: A) (l: listset A) : list_cons A (x,, (l,, tt)) = cons x l. Proof. reflexivity. Qed. UniMath-20231010/UniMath/Algebra/Universal/Examples/Monoid.v000066400000000000000000000061131451125700300233540ustar00rootroot00000000000000(** * Example on monoids. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains the definition of the signature of monoids and the way to turn a monoid (as defined in [UniMath.Algebra.Monoids]) into an algebra. *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Universal.EqAlgebras. Local Open Scope stn. (** Signature. *) Definition monoid_signature := make_signature_simple_single_sorted [2; 0]. (** Algebra of monoids without equations. *) Definition monoid_algebra (M: monoid) : algebra monoid_signature := make_algebra_simple_single_sorted monoid_signature M [( λ p, op (pr1 p) (pr12 p) ; λ _, unel M )]. Module Eqspec. (** Free algebra of open terms. *) Definition monoid_varspec : varspec monoid_signature := make_varspec monoid_signature natset (λ _, tt). Definition Mon : UU := term monoid_signature monoid_varspec tt. Definition mul : Mon → Mon → Mon := build_term_curried (●0: names monoid_signature). Definition id : Mon := build_term_curried (●1: names monoid_signature). Definition x : Mon := varterm (0: monoid_varspec). Definition y : Mon := varterm (1: monoid_varspec). Definition z : Mon := varterm (2: monoid_varspec). Definition monoid_equation : UU := equation monoid_signature monoid_varspec. Definition monoid_mul_assoc : monoid_equation := tt,, make_dirprod (mul (mul x y) z) (mul x (mul y z)). Definition monoid_mul_lid : monoid_equation := tt,, make_dirprod (mul id x) x. Definition monoid_mul_rid : monoid_equation := tt,, make_dirprod (mul x id) x. Definition monoid_axioms : eqsystem monoid_signature monoid_varspec := ⟦ 3 ⟧,, three_rec monoid_mul_assoc monoid_mul_lid monoid_mul_rid. Definition monoid_eqspec : eqspec. Proof. use tpair. { exact monoid_signature. } use tpair. { exact monoid_varspec. } exact monoid_axioms. Defined. Definition monoid_eqalgebra := eqalgebra monoid_eqspec. (** Every monoid is a monoid eqalgebra. *) Section Make_Monoid_Eqalgebra. Variable M : monoid. Lemma holds_monoid_mul_lid : holds (monoid_algebra M) monoid_mul_lid. Proof. intro. cbn in α. change (fromterm (ops (monoid_algebra M)) α tt (mul id x) = α 0). change (op (unel M) (α 0) = α 0). apply lunax. Qed. Lemma holds_monoid_mul_rid : holds (monoid_algebra M) monoid_mul_rid. Proof. intro. change (op (α 0) (unel M) = α 0). apply runax. Qed. Lemma holds_monoid_mul_assoc : holds (monoid_algebra M) monoid_mul_assoc. Proof. intro. change (op (op (α 0) (α 1)) (α 2) = op (α 0) (op (α 1) (α 2))). apply assocax. Qed. Definition is_eqalgebra_monoid : is_eqalgebra (σ := monoid_eqspec) (monoid_algebra M). Proof. red. simpl. apply three_rec_dep; cbn. - exact holds_monoid_mul_assoc. - exact holds_monoid_mul_lid. - exact holds_monoid_mul_rid. Defined. Definition make_monoid_eqalgebra : monoid_eqalgebra. use make_eqalgebra. - exact (monoid_algebra M). - exact is_eqalgebra_monoid. Defined. End Make_Monoid_Eqalgebra. End Eqspec. UniMath-20231010/UniMath/Algebra/Universal/Examples/Nat.v000066400000000000000000000040641451125700300226540ustar00rootroot00000000000000(** * Example on natural numbers *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains the definition of the signature of natural numbers with zero and addition, the algebras of natural numbers and booleans and the morphism between them. *) Require Import UniMath.Foundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.MoreLists. Require Import UniMath.Algebra.Universal.Algebras. Require Import UniMath.Algebra.Universal.Terms. Local Open Scope stn. Local Open Scope hom. Definition nat_signature := make_signature_simple_single_sorted [ 0 ; 1 ]. Definition nat_sort: sorts nat_signature := tt. Definition nat_zero_op: names nat_signature := ●0. Definition nat_succ_op: names nat_signature := ●1. Definition nat_algebra := make_algebra_simple_single_sorted nat_signature natset [( λ _, 0 ; λ x, S (pr1 x) )]. Goal ops nat_algebra nat_zero_op tt = 0. Proof. apply idpath. Defined. Goal ops nat_algebra nat_succ_op (1 ,, tt) = 2. Proof. apply idpath. Defined. Definition z2_algebra := make_algebra_simple_single_sorted nat_signature boolset [( λ _, false ; λ x, negb (pr1 x) )]. Definition nat_to_z2 : nat_algebra s→ z2_algebra := λ s: sorts nat_signature, nat_rect (λ _, bool) false (λ n HP, negb HP). Goal nat_to_z2 nat_sort 0 = false. Proof. apply idpath. Defined. Goal nat_to_z2 nat_sort 1 = true. Proof. apply idpath. Defined. Goal nat_to_z2 nat_sort 2 = false. Proof. apply idpath. Defined. Lemma ishom_nat_to_z2: @ishom _ nat_algebra z2_algebra (nat_to_z2). Proof. unfold ishom. intros. induction nm as [n proofn]. inductive_reflexivity n proofn. Defined. Definition natz2 : nat_algebra ↷ z2_algebra := make_hom ishom_nat_to_z2. Definition nat_zero := build_gterm_curried nat_zero_op. Definition nat_succ := build_gterm_curried nat_succ_op. Definition nat2term (n: nat): gterm nat_signature nat_sort := nat_rect (λ _, gterm nat_signature nat_sort) nat_zero (λ (n: nat) (tn: gterm nat_signature nat_sort), nat_succ tn) n. UniMath-20231010/UniMath/Algebra/Universal/Examples/Tests.v000066400000000000000000000144471451125700300232420ustar00rootroot00000000000000(** * Several tests for univeral algebra operations. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.MoreLists. Require Import UniMath.Algebra.Universal.TermAlgebras. Require Import UniMath.Algebra.Universal.Examples.Nat. Require Import UniMath.Algebra.Universal.Examples.Bool. Local Open Scope stn. Local Open Scope sorted. Local Open Scope hvec. Local Open Scope list. Section SortedTypes. Local Definition A : sUU bool := bool_ind _ nat unit. Goal A⋆ (cons true (cons false (cons true nil))) = (nat × unit × nat × unit). Proof. apply idpath. Defined. End SortedTypes. Section NatLowLevel. Goal Terms.opexec nat_succ_op (just [nat_sort]) = just [nat_sort]. Proof. apply idpath. Qed. Goal Terms.opexec nat_succ_op (just []) = nothing. Proof. apply idpath. Qed. Local Definition zero_one_oplist: Terms.oplist nat_signature := [nat_zero_op ; nat_succ_op ; nat_zero_op]. Local Definition one_oplist: Terms.oplist nat_signature := [nat_succ_op ; nat_zero_op]. Local Definition zero_oplist: Terms.oplist nat_signature := [nat_zero_op]. Goal @Terms.oplistexec nat_signature [] = just []. Proof. apply idpath. Qed. Goal Terms.oplistexec one_oplist = just [nat_sort]. Proof. apply idpath. Qed. Goal Terms.oplistexec zero_one_oplist = just [nat_sort ; nat_sort]. Proof. apply idpath. Qed. Goal Terms.oplistexec [nat_succ_op] = nothing. Proof. apply idpath. Qed. Goal Terms.isaterm nat_sort (nat2term 10). Proof. apply idpath. Qed. Goal Terms.stackconcatenate (just [nat_sort]) (just [nat_sort ; nat_sort]) = just [nat_sort ; nat_sort ; nat_sort]. Proof. apply idpath. Qed. Local Definition one_term : gterm nat_signature nat_sort := make_term(l:=one_oplist) (idpath _). Local Definition zero_term : gterm nat_signature nat_sort := make_term(l:=zero_oplist) (idpath _). Goal Terms.oplistsplit zero_one_oplist 0 = nil ,, zero_one_oplist. Proof. apply idpath. Qed. Goal Terms.oplistsplit zero_one_oplist 1 = zero_oplist ,, one_oplist. Proof. apply idpath. Qed. Goal Terms.vecoplist2oplist [( zero_oplist; one_oplist )] = zero_one_oplist. Proof. apply idpath. Qed. Goal h1map_vec (λ _, term2oplist) (pr1 (Terms.oplist2vecoplist zero_one_oplist (idpath _))) = vcons zero_oplist (vcons one_oplist vnil). Proof. apply idpath. Qed. Goal pr1 (Terms.oplist2vecoplist zero_one_oplist (idpath _)) = vcons zero_term (vcons one_term vnil). Proof. apply idpath. Qed. Goal Terms.oplist_build nat_succ_op [( zero_oplist )] = one_oplist. Proof. apply idpath. Qed. End NatLowLevel. Section Nat. Local Definition term_zero := nat_zero. Local Definition term_one := nat_succ nat_zero. Local Definition term_two := nat_succ (nat_succ nat_zero). Local Definition term_four := nat_succ (nat_succ (nat_succ (nat_succ nat_zero))). Goal nat2term 4 = term_four. Proof. apply idpath. Qed. (* ----- term_decompose ----- *) (* works but slow, faster with lazy *) (* Eval compute in Terms.term_decompose term_one. *) Goal princop term_four = nat_succ_op. Proof. apply idpath. Qed. Goal subterms term_one = [( term_zero )]. Proof. apply idpath. Qed. Goal subterms term_two = [( term_one )] . Proof. apply idpath. Qed. Goal build_gterm (princop term_four) (subterms term_four) = term_four. Proof. apply idpath. Qed. Goal depth term_four = 5. Proof. apply idpath. Qed. (* works *) (* Eval lazy in depth term_four. *) (* does not terminate: compute is call-by-value, hence it needs to compute all the proofs involved in the recursion *) (* Eval compute in depth term_four. *) Goal geval nat_algebra tt term_zero = 0. Proof. apply idpath. Qed. Goal geval nat_algebra tt term_one = 1. Proof. apply idpath. Qed. Goal geval nat_algebra tt (nat2term 4) = 4. Proof. apply idpath. Qed. End Nat. Section NatHom. Goal ∏ x: nat, homid nat_algebra tt x = x. Proof. apply idpath. Qed. Local Definition nat_algebra2 := make_algebra_simple_single_sorted nat_signature natset [( λ _, 1 ; λ x, S (pr1 x) )]. Local Definition homnats: hom nat_algebra nat_algebra2. Proof. exists (λ (s: unit) (x: nat), S x). unfold ishom. intros. induction nm as [n proofn]. induction n. { cbn. apply idpath. } induction n. { cbn. apply idpath. } { exact (fromempty (nopathsfalsetotrue proofn)). } Defined. Goal homnats nat_sort 2 = 3. Proof. apply idpath. Qed. Goal homcomp (homid nat_algebra) homnats nat_sort 2 = 3. Proof. apply idpath. Qed. Goal unithom nat_algebra nat_sort 2 = tt. Proof. apply idpath. Qed. End NatHom. Section Bool. Import UniMath.Algebra.Universal.Examples.Bool.GTerm. Local Open Scope stn. Local Definition bot_op : names bool_signature := ●0. Local Definition top_op : names bool_signature := ●1. Local Definition neg_op : names bool_signature := ●2. Local Definition conj_op : names bool_signature := ●3. Local Definition disj_op : names bool_signature := ●4. Local Definition impl_op : names bool_signature := ●5. Local Definition t1 := conj top bot. Local Definition t2 := neg t1. Goal princop t1 = conj_op. Proof. apply idpath. Qed. Goal term2oplist t2 = [ neg_op ; conj_op ; top_op ; bot_op ]. Proof. apply idpath. Qed. Goal pr1 (Terms.oplistsplit (term2oplist t1) 0) = []. Proof. apply idpath. Qed. Goal pr2 (Terms.oplistsplit (term2oplist t1) 0) = (term2oplist t1). Proof. apply idpath. Qed. Goal pr1 (Terms.oplistsplit (term2oplist t1) 1) = (term2oplist t1). Proof. apply idpath. Qed. Goal pr2 (Terms.oplistsplit (term2oplist t1) 1) = []. Proof. apply idpath. Qed. Goal subterms t2 = [( t1 )]. Proof. apply idpath. Qed. Goal subterms t1 = [( top ; bot )]. Proof. apply idpath. Qed. Goal depth t2 = 3. Proof. apply idpath. Qed. Definition simple_t := neg (conj (disj top bot) (neg bot)). Local Lemma l1: geval bool_algebra tt top = true. Proof. apply idpath. Defined. Local Lemma l2: geval bool_algebra tt (neg top) = false. Proof. apply idpath. Defined. Local Lemma l3: geval bool_algebra tt (conj top bot) = false. Proof. apply idpath. Defined. Local Lemma l4: geval bool_algebra tt simple_t = false. Proof. apply idpath. Defined. End Bool. UniMath-20231010/UniMath/Algebra/Universal/FreeAlgebras.v000066400000000000000000000057241451125700300227020ustar00rootroot00000000000000(** * Free algebras. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains a formalization of free algebras over a signature (i.e., the algebra of terms over a signature and a set of variables. *) Require Import UniMath.Foundations.All. Require Export UniMath.Algebra.Universal.Algebras. Require Export UniMath.Algebra.Universal.VTerms. Local Open Scope sorted. Local Open Scope hom. Section FreeAlgebras. Definition free_algebra (σ: signature) (V: varspec σ): algebra σ := @make_algebra σ (termset σ V) build_term. Context {σ: signature} (a : algebra σ) {V: varspec σ} (α: assignment a V). Definition eval: free_algebra σ V s→ a := fromterm (ops a) α. Lemma evalstep (nm: names σ) (v: (term σ V)⋆ (arity nm)) : eval (sort nm) (build_term nm v) = ops a nm (eval⋆⋆ (arity nm) v). Proof. unfold eval. change (sort nm) with (sort nm). apply fromtermstep. Defined. Lemma ishomeval: ishom eval. Proof. red. intros. apply evalstep. Defined. Definition evalhom: free_algebra σ V ↷ a := make_hom ishomeval. Definition universalmap: ∑ h: free_algebra σ V ↷ a, ∏ v: V, h _ (varterm v) = α v. Proof. exists evalhom. intro v. simpl. unfold eval, varterm. apply fromtermstep'. Defined. Definition iscontr_universalmap : iscontr (∑ h: free_algebra σ V ↷ a, ∏ v: V, h (varsort v) (varterm v) = α v). Proof. exists universalmap. intro h. induction h as [h honvars]. apply subtypePairEquality'. - induction h as [h hishom]. apply subtypePairEquality'. 2: apply isapropishom. apply funextsec. intro s. apply funextfun. unfold homot. revert s. apply (term_ind(σ := vsignature σ V)). unfold term_ind_HP. intros nm hv IHhv. induction nm as [nm | v]. * change (inl nm) with (namelift V nm). change (sort (namelift V nm)) with (sort nm). change (build_gterm (namelift V nm) hv) with (ops (free_algebra σ V) nm hv) at 1. change (build_gterm (namelift V nm) hv) with (build_term nm hv). rewrite hishom. rewrite evalstep. apply maponpaths. revert hv IHhv. change (@arity (vsignature σ V) (inl nm)) with (arity nm). generalize (arity nm). refine (list_ind _ _ _). -- reflexivity. -- intros x xs IHxs hv IHhv. unfold starfun. simpl. simpl in IHhv. apply hcons_paths. + exact (pr1 IHhv). + exact (IHxs (pr2 hv) (pr2 IHhv)). * induction hv. change (inr v) with (varname v). change (sort (varname v)) with (varsort v). change (build_gterm (varname v) tt) with (varterm v). rewrite honvars. unfold eval. rewrite fromtermstep'. apply idpath. - apply impred_isaprop. intros. apply (supportset a (varsort t)). Defined. End FreeAlgebras. UniMath-20231010/UniMath/Algebra/Universal/HVectors.v000066400000000000000000000245031451125700300221110ustar00rootroot00000000000000(** * Heterogeneous vectors. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Export UniMath.Combinatorics.Vectors. Local Open Scope stn. (** ** Basic definitions. If [v] is a vector of types [U1], [U2], ..., [Un], then [hvec v] is the product type [U1 × (U2 × ... × Un)]. We introduce several basic operations on heterogeneous vectors: often they have the same syntax then the corresponding operation on plain vectors, and a name which begins with h. We also introduce a new scope, [hvec_scope], delimited by [hvec], which adds useful notations for heterogeneous vectors. A vector of elements [x1], [x2], ..., [xn] may be written a [[x1; x2; ...; xn]]. Moreover [[]] denotes the empty vector and [:::] is the cons operator. *) Definition hvec {n: nat} (v: vec UU n): UU. Proof. revert n v. exact (vec_ind (λ _ _, UU) unit (λ x _ _ IHv, x × IHv)). Defined. Declare Scope hvec_scope. Delimit Scope hvec_scope with hvec. Local Open Scope hvec_scope. Bind Scope hvec_scope with hvec. Definition hnil : hvec vnil := tt. Definition hcons {A: UU} (x: A) {n: nat} {v: vec UU n} (hv: hvec v) : hvec (A ::: v) := x ,, hv. Notation "[( x ; .. ; y )]" := (hcons x .. (hcons y hnil) ..): hvec_scope. Notation "[()]" := hnil (at level 0, format "[()]"): hvec_scope. Infix ":::" := hcons: hvec_scope. Definition functionToHVec {n: nat} {P: ⟦ n ⟧ → UU} (f: ∏ i: ⟦ n ⟧, P i) : hvec (make_vec P). Proof. induction n. - exact [()]. - exact ((f firstelement) ::: (IHn (P ∘ dni_firstelement) (f ∘ dni_firstelement))). Defined. Definition hhd {A: UU} {n: nat} {v: vec UU n} (hv: hvec (A ::: v)): A := pr1 hv. Definition htl {A: UU} {n: nat} {v: vec UU n} (hv: hvec (A ::: v)): hvec v := pr2 hv. Definition hel {n: nat} {v: vec UU n} (hv: hvec v): ∏ i: ⟦ n ⟧, el v i. Proof. revert n v hv. refine (vec_ind _ _ _). - intros. apply (fromempty (negnatlthn0 (pr1 i) (pr2 i))). - intros x n xs IHxs. induction i as [i iproof]. induction i. + exact (hhd hv). + exact (IHxs (htl hv) (make_stn _ i iproof)). Defined. Lemma hcons_paths {A: UU} (x y: A) {n: nat} (v: vec UU n) (xs ys: hvec v) (p: x = y) (ps: xs = ys) : x ::: xs = y ::: ys. Proof. apply (map_on_two_paths (λ x xs, @hcons A x n v xs)) ; assumption. Defined. Lemma isofhlevelhvec {m: nat} {n: nat} (v: vec UU n) (levels: hvec (vec_map (isofhlevel m) v)) : isofhlevel m (hvec v). Proof. revert n v levels. refine (vec_ind _ _ _). - intro. apply isofhlevelcontr. apply iscontrunit. - intros x n xs IHxs levels. simpl. apply isofhleveldirprod. + apply (pr1 levels). + apply (IHxs (pr2 levels)). Defined. Lemma hvec_vec_fill {A: UU} {n: nat} : hvec (vec_fill A n) = vec A n. Proof. induction n. - apply idpath. - simpl. apply maponpaths. assumption. Defined. (** ** Level-1 heterogeneous vectors. A level-1 hvec is a term of type [hvec (vec_map P v)] for some [v: vec A n] and [P: A → UU]. Some operations may be easily defined for a level-1 hvec but not for a generic heterogeneous. Operations on level-1 hvec have names beginning with h1. *) (** *** Miscellanea of operations on level-1 hvecs. *) (** [h1const_is_vec] proves that an [hvec (vec_map P v)] is a [vec] when [P] is a constant map. *) Definition h1const_is_vec {A: UU} {n: nat} (v: vec A n) (B: UU) : hvec (vec_map (λ _, B) v) = vec B n. Proof. induction n. - apply idpath. - simpl. apply maponpaths. apply IHn. Defined. (** [h1lower] transforms a [hvec (vec_map P v)] into a [vec] when [P] is a constant map. Although it would be possibile to define [h1lower] starting from [h1const_is_vec], this would make difficult to work by induction over [v]. *) Definition h1lower {A: UU} {n: nat} {v: vec A n} {B: UU} (h1v: hvec (vec_map (λ _, B) v)) : vec B n. Proof. revert n v h1v. refine (vec_ind _ _ _). - apply idfun. - intros x n xs IHxs h1v. exact (vcons (hhd h1v) (IHxs (htl h1v))). Defined. (** [h1foldr] is the analogous of [foldr] for level-1 hvecs. *) Definition h1foldr {A: UU} {n: nat} {v: vec A n} {P: A → UU} {B: UU} (comb: ∏ (a: A), P a → B → B) (s: B) (h1v: hvec (vec_map P v)): B. Proof. revert n v h1v. refine (vec_ind _ _ _). - intro. exact s. - intros x n xs IHxs. simpl. intro. exact (comb _ (pr1 h1v) (IHxs (pr2 h1v))). Defined. (** *** Map for level-1 hvecs. The [h1map] function is analogous to [map] for level-1 hvecs: [hmap f hv] applies the function [f] to all elements of [hv]. The result is of type [hvec (vec_map Q v)] for an appropriate [Q: A → UU]. When [Q] is the constant map in [hmap], we may instead use [h1map_vec] which returns a vec instead of an hvec. *) Definition h1map {A: UU} {n: nat} {v: vec A n} {P: A → UU} {Q: A → UU} (f: ∏ (a: A), P a → Q a) (h1v: hvec (vec_map P v)) : hvec (vec_map Q v). Proof. revert n v f h1v. refine (vec_ind _ _ _ ). - intros. exact [()]. - intros x n xs IHxs. simpl. intros f h1v. exact (f x (pr1 h1v) ::: IHxs f (pr2 h1v)). Defined. Lemma h1map_idfun {A: UU} {n: nat} {v: vec A n} {P: A → UU} (h1v: hvec (vec_map P v)) : h1map (λ a: A, idfun (P a)) h1v = h1v. Proof. revert n v h1v. refine (vec_ind _ _ _). - induction h1v. apply idpath. - simpl. intros x n xs IHxs h1v. change h1v with (pr1 h1v ::: pr2 h1v). apply maponpaths. apply (IHxs (pr2 h1v)). Defined. Lemma h1map_compose {A: UU} {n: nat} {v: vec A n} {P: A → UU} {Q: A → UU} {R: A → UU} (f: ∏ a: A, P a → Q a) (g: ∏ (a: A), Q a → R a) (h1v: hvec (vec_map P v)) : h1map g (h1map f h1v) = h1map (λ a: A, (g a) ∘ (f a)) h1v. Proof. revert n v h1v. refine (vec_ind _ _ _). - induction h1v. apply idpath. - simpl. intros x n xs IHxs h1v. apply maponpaths. apply (IHxs (pr2 h1v)). Defined. (** [h1map_vec] is just the composition of [h1map] and [h1lower], but it deserves a name since it is used in the definition of level-2 hvecs (see later). *) Definition h1map_vec {A: UU} {n: nat} {v: vec A n} {P: A → UU} {B: UU} (f: ∏ (a: A), P a → B) (h1v: hvec (vec_map P v)) : vec B n := h1lower (h1map f h1v). (** ** Level-2 heterogeneous vectors. A level-2 hvec is a term of type [hvec (h1map_vec Q h1v)] for some [h1v: hvec (vec_map P v)], [v: vec A n], [P: A → UU], [Q: ∏ a: A, P a → UU]. Operators on level-2 hvecs have names which begins with h2. The need to work explicitly with level-1 and level-2 hvecs, instead of generic heterogeneous vecs, seems unfortunate. A refactoring of this library could free us from the burden of working with such articulate data types *) (** [h2map] is like [h1map] for level-2 hvecs. *) Definition h2map {A: UU} {n: nat} {v: vec A n} {P: A → UU} {h1v: hvec (vec_map P v)} {Q: ∏ (a: A) (p: P a), UU} {R: ∏ (a: A) (p: P a), UU} (f: ∏ (a: A) (p: P a), Q a p → R a p) (h2v: hvec (h1map_vec Q h1v)) : hvec (h1map_vec R h1v). Proof. revert n v f h1v h2v. refine (vec_ind _ _ _ ). - intros. exact [()]. - intros x n xs IHv f h1v h2v. exact (f x (pr1 h1v) (pr1 h2v) ::: IHv f (pr2 h1v) (pr2 h2v)). Defined. (** [h1lift] transforms a level-1 hvec into a level-2 hvec. *) Definition h1lift {A: UU} {n: nat} {v: vec A n} {P: A → UU} (h1v: hvec (vec_map P v)) : hvec (h1map_vec (λ a _, P a) h1v). Proof. revert n v h1v. refine (vec_ind _ _ _ ). - intros. exact [()]. - intros x n xs IHv h1v. exact ((pr1 h1v) ::: IHv (pr2 h1v)). Defined. (** [h2lower] transforms a level-2 hvec [h2v: hvec (hmap_vec Q h1v)] into a level-1 hvec when [Q: ∏ a: A, P a → UU] is constant on the argument of type [P a]. *) Definition h2lower {A: UU} {n: nat} {v: vec A n} {P: A → UU} {h1v: hvec (vec_map P v)} {Q: A → UU} (h2v: hvec (h1map_vec (λ a _, Q a) h1v)) : hvec (vec_map Q v). Proof. revert n v h1v h2v. refine (vec_ind _ _ _). - reflexivity. - simpl. intros x n xs IHxs h1v h2v. split. + exact (pr1 h2v). + exact (IHxs (pr2 h1v) (pr2 h2v)). Defined. (** [h2lower_h1map_h1lift] and [h1map_h1lift_as_h2map] are two normalization lemmas relating level-1 and level-2 hvecs. *) Lemma h2lower_h1map_h1lift {A: UU} {n: nat} {v: vec A n} {P: A → UU} {Q: ∏ (a: A), UU} (f: ∏ (a: A), P a → Q a) (h1v: hvec (vec_map P v)) : h2lower (h2map (λ a p _, f a p) (h1lift h1v)) = h1map f h1v. Proof. revert n v h1v. refine (vec_ind _ _ _). - reflexivity. - intros x n xs IHxs h1v. simpl. apply maponpaths. exact (IHxs (pr2 h1v)). Defined. Lemma h1map_h1lift_as_h2map {A: UU} {n: nat} {v: vec A n} {P: A → UU} (h1v: hvec (vec_map P v)) {Q: ∏ (a: A) (p: P a), UU} (h2v: hvec (h1map_vec Q h1v)) {R: ∏ (a: A) (p: P a), UU} (f: ∏ (a: A) (p: P a), R a p) : h2map (λ a p _, f a p) (h1lift h1v) = h2map (λ a p _, f a p) h2v. Proof. revert n v h1v h2v. refine (vec_ind _ _ _). - reflexivity. - simpl. intros x n xs IHxs h1v h2v. apply maponpaths. exact (IHxs (pr2 h1v) (pr2 h2v)). Defined. (** [h2foldr] is the analogous of [foldr] for level-2 hvecs. *) Definition h2foldr {A: UU} {n: nat} {v: vec A n} {P: A → UU} {h1v: hvec (vec_map P v)} {Q: ∏ (a: A) (p: P a), UU} {B: UU} (comp: ∏ (a: A) (p: P a), Q a p → B → B) (s: B) (h2v: hvec (h1map_vec Q h1v)) : B. Proof. revert n v h1v h2v. refine (vec_ind _ _ _). - intros. exact s. - simpl. intros x n xs IHxs h1v h2v. exact (comp _ _ (pr1 h2v) (IHxs (pr2 h1v) (pr2 h2v))). Defined. (** [h1map_path] returns a proof that [hmap f h1v] and [hmap g h1v] are equal, provided that we have a level-2 hvec [h2path] of proofs that the images of [f] and [g] on corresponding elements of [h1v] are equal. *) Lemma h1map_path {A: UU} {n: nat} {v: vec A n} {P: A → UU} {Q: A → UU} (f: ∏ a: A, P a → Q a) (g: ∏ (a: A), P a → Q a) (h1v: hvec (vec_map P v)) (h2path: hvec (h1map_vec (λ a p, f a p = g a p) h1v)) : h1map f h1v = h1map g h1v. Proof. revert n v h1v h2path. refine (vec_ind _ _ _). - induction h1v. reflexivity. - simpl. intros x n xs IHxs h1v h2path. use map_on_two_paths. + exact (pr1 h2path). + exact (IHxs (pr2 h1v) (pr2 h2path)). Defined. UniMath-20231010/UniMath/Algebra/Universal/Signatures.v000066400000000000000000000047231451125700300225020ustar00rootroot00000000000000(** * Signatures for universal algebra. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (* This file contains a formalization of multi-sorted signatures. *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Export UniMath.Combinatorics.DecSet. Require Import UniMath.Combinatorics.MoreLists. Local Open Scope stn. (** A _signature_ is given by a decidable set of sorts, a set of of operation symbols and a map from operation symbols to pair [(l,, s)] where [l] is the _arity_ (or _domain_) and [s] is the _sort_ (or _range_). *) Definition signature : UU := ∑ (S: decSet) (O: hSet), O → list S × S. Definition sorts (σ: signature) := pr1 σ. Definition names (σ: signature) := pr12 σ. Definition ar (σ: signature) := pr22 σ. Definition arity {σ: signature} (nm: names σ) : list (sorts σ) := pr1 (ar σ nm). Definition sort {σ: signature} (nm: names σ) : sorts σ := pr2 (ar σ nm). (** Helper function for creating signatures. *) Definition make_signature (S: decSet) (O: hSet) (ar: O → list S × S) : signature := S ,, (O ,, ar). Definition make_signature_single_sorted (O: hSet) (ar: O → nat) : signature := make_signature (unit,, isdecequnit) O (λ op, fill tt (ar op) ,, tt). (** A signature may be alternatively specified trough a [signature_simple]. In a simple signature, the types for sorts and operation symbols are standard finite sets, and the map from operations symbols to domain and range is replaced by a list. In this way, the definition of a new signature is made simpler. We have decided to define new types for simple signatures instead of only defining helper functions, since this make it simpler to define simplified means of defining a new algebra, too. *) Definition signature_simple : UU := ∑ (ns: nat), list (list (⟦ ns ⟧) × ⟦ ns ⟧). Definition make_signature_simple {ns: nat} (ar: list (list (⟦ ns ⟧) × ⟦ ns ⟧)) : signature_simple := ns ,, ar. Coercion signature_simple_compile (σ: signature_simple) : signature := make_signature (⟦ pr1 σ ⟧ ,, isdeceqstn _) (stnset (length (pr2 σ))) (nth (pr2 σ)). Definition signature_simple_single_sorted : UU := list nat. Definition make_signature_simple_single_sorted (ar: list nat) : signature_simple_single_sorted := ar. Coercion signature_simple_single_sorted_compile (σ: signature_simple_single_sorted): signature := make_signature_single_sorted (stnset (length σ)) (nth σ). UniMath-20231010/UniMath/Algebra/Universal/SortedTypes.v000066400000000000000000000065621451125700300226460ustar00rootroot00000000000000(** * Sorted types. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (* This file contains a formalization of _sorted types_, i.e. types indexed by elements of another type, called _index type_. Notation and terminologies are inspired by Wolfgang Wechler, _Universal Algebra for Computer Scientist_, Springer. *) Require Import UniMath.Foundations.All. Require Export UniMath.Combinatorics.MoreLists. Require Export UniMath.Algebra.Universal.HVectors. Declare Scope sorted_scope. Delimit Scope sorted_scope with sorted. Local Open Scope sorted_scope. (** An element of [sUU S] is an [S]-sorted type, i.e., an [S]-indexed family of types. *) Definition sUU (S: UU): UU := S → UU. (** If [X] and [Y] are [S]-sorted types, then [sfun X Y] is an [S]-sorted mapping, i.e., a [S]-indexed family of functions [X s → Y s]. *) Definition sfun {S: UU} (X Y: sUU S): UU := ∏ s: S, X s → Y s. Notation "x s→ y" := (sfun x y) (at level 99, y at level 200, right associativity): type_scope. Bind Scope sorted_scope with sUU. Bind Scope sorted_scope with sfun. Definition idsfun {S: UU} (X: sUU S): X s→ X := λ s: S, idfun (X s). Definition scomp {S: UU} {X Y Z: sUU S} (f: Y s→ Z) (g: X s→ Y): sfun X Z := λ s: S, (f s) ∘ (g s). Infix "s∘" := scomp (at level 40, left associativity): sorted_scope. Definition sunit (S: UU): sUU S := λ σ: S, unit. Definition tosunit {S: UU} {X: sUU S}: X s→ sunit S := λ σ: S, tounit. Lemma iscontr_sfuntosunit {S: UU} {X: sUU S}: iscontr (X s→ sunit S). Proof. apply impred_iscontr. intros. apply iscontrfuntounit. Defined. (** An element of [shSet S] is an [S]-sorted set, i.e., an [S]-indexed family of sets. It can be immediately coerced to an [S]-sorted type. *) Definition shSet (S: UU): UU := S → hSet. Definition sunitset (S: UU): shSet S := λ _, unitset. Lemma isaset_set_sfun_space {S: UU} {X: sUU S} {Y: shSet S}: isaset (X s→ Y). Proof. change (isaset (X s→ Y)). apply impred_isaset. intros. apply isaset_forall_hSet. Defined. (** If [X: sUU S], then [star X] is the lifting of [X] to the index type [list S], given by [star X] [s1; s2; ...; sn] = [X s1 ; X s2 ; ... ; X sn]. *) Definition star {S: UU} (X: sUU S): sUU (list S) := λ l: list S, hvec (vec_map X (pr2 l)). Bind Scope hvec_scope with star. Notation "A ⋆" := (star A) (at level 3, format "'[ ' A '⋆' ']'"): sorted_scope. (** If [f] is an indexed mapping between [S]-indexed types [X] and [Y], then [starfun X] is the lifting of [f] to a [list S]-indexed mapping between [list S]-indexed sets [star X] and [star Y]. *) Definition starfun {S: UU} {X Y: sUU S} (f: sfun X Y) : sfun X⋆ Y⋆ := λ s: list S, h1map f. Notation "f ⋆⋆" := (starfun f) (at level 3, format "'[ ' f '⋆⋆' ']'"): sorted_scope. (** Here follows the proof that [starfun] is functorial. Compositionality w.r.t. [s∘] is presented as [(f s∘ g)⋆⋆ _ x = f⋆⋆ _ (g⋆⋆ _ x)] instead of [(f s∘ g)⋆⋆ = (f⋆⋆) s∘ (g⋆⋆ )] since the former does not require function extensionality. *) Lemma staridfun {S: UU} {X: sUU S} (l: list S) (x: X⋆ l): (idsfun X)⋆⋆ _ x = idsfun X⋆ _ x. Proof. apply h1map_idfun. Defined. Lemma starcomp {S: UU} {X Y Z: sUU S} (f: Y s→ Z) (g: X s→ Y) (l: list S) (x: X⋆ l) : (f s∘ g)⋆⋆ _ x = f⋆⋆ _ (g⋆⋆ _ x). Proof. unfold starfun. apply pathsinv0. apply h1map_compose. Defined. UniMath-20231010/UniMath/Algebra/Universal/TermAlgebras.v000066400000000000000000000031011451125700300227130ustar00rootroot00000000000000(** * The ground term algebra and the proof it is initial. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.All. Require Export UniMath.Algebra.Universal.Algebras. Require Export UniMath.Algebra.Universal.Terms. Local Open Scope sorted. Local Open Scope hom. Section TermAlgebra. Definition term_algebra (σ: signature): algebra σ := make_algebra (gtermset σ) build_gterm. Context {σ: signature}. Definition geval (a: algebra σ): term_algebra σ s→ a := @fromgterm σ a (ops a). Lemma gevalstep {a: algebra σ} (nm: names σ) (v: (gterm σ)⋆ (arity nm)) : geval a _ (build_gterm nm v) = ops a nm (h1map (geval a) v). Proof. unfold geval. apply fromtermstep. Defined. Lemma ishomgeval (a: algebra σ): ishom (geval a). Proof. red. intros. unfold starfun. apply gevalstep. Defined. Definition gevalhom (a: algebra σ): term_algebra σ ↷ a := make_hom (ishomgeval a). Definition iscontrhomsfromgterm (a: algebra σ): iscontr (term_algebra σ ↷ a). Proof. exists (gevalhom a). intro f. induction f as [f fishom]. apply subtypePairEquality'. 2: apply isapropishom. apply funextsec. intro s. apply funextfun. intro t. apply (term_ind (λ s t, f s t = geval a s t)). unfold term_ind_HP. intros. change (build_gterm nm v) with (ops (term_algebra σ) nm v) at 1. rewrite fishom. rewrite gevalstep. apply maponpaths. unfold starfun. apply h1map_path. exact IH. Defined. End TermAlgebra. UniMath-20231010/UniMath/Algebra/Universal/Terms.v000066400000000000000000000776221451125700300214600ustar00rootroot00000000000000(** * Terms for a given signature. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** This file contains a formalization of terms over a signature, implemented as a sequence of operation symbols. This sequence is though to be executed by a stack machine: each symbol of arity _n_ virtually pops _n_ elements from the stack and pushes a new element. A sequence of function symbols is a term when the result of the execution is a stack with a single element and no stack underflow or type errors occur. Here we only define ground terms, while terms with variables will be defined in <>. *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.Maybe. Require Import UniMath.Algebra.Universal.SortedTypes. Require Export UniMath.Algebra.Universal.Signatures. Local Open Scope sorted. Local Open Scope hvec. Local Open Scope list. (** ** Definition of [oplist] (operations list). *) (** An [oplist] is a list of operation symbols, interpreted as commands to be executed by a stack machine. Elements of the stack are sorts. When an operation symbol is executed its arity is popped out from the stack and replaced by its range. When a stack underflow occurs, or when the sorts present in the stack are not the ones expected by the operator, the stack goes into an error condition which is propagated by successive operations. A term is an [oplist] that produces a stack of length one, when execution starts from the empty stack. Operation symbols are executed in order from the last element of the [oplist] to the first. *) Local Definition oplist (σ: signature):= list (names σ). Bind Scope list_scope with oplist. Identity Coercion oplistislist: oplist >-> list. Local Corollary isasetoplist (σ: signature): isaset (oplist σ). Proof. apply isofhlevellist. apply setproperty. Defined. Local Definition stack (σ: signature): UU := maybe (list (sorts σ)). Local Lemma isasetstack (σ: signature): isaset (stack σ). Proof. apply isasetmaybe. apply isofhlevellist. apply isasetifdeceq. apply decproperty. Defined. Section Oplists. Context {σ: signature}. (** *** The [opexec] and [oplistexec] functions. *) (** The function [opexec nm] is the stack transformation corresponding to the execution of the operation symbol [nm], while [oplistexec l] returns the stack corresponding to the execution of the entire oplist [l] starting from the empty stack. The list is executed from the last to the first operation symbol. Finally [isaterm l] holds when the result of [oplistexec l] is a stack of length one. *) Local Definition opexec (nm: names σ): stack σ → stack σ := flatmap (λ ss, just (sort nm :: ss)) ∘ flatmap (λ ss, prefix_remove (arity nm) ss). Local Definition oplistexec (l: oplist σ): stack σ := foldr opexec (just []) l. Local Definition isaterm (s: sorts σ) (l: oplist σ): UU := oplistexec l = just ([s]). Local Lemma isapropisaterm (s: sorts σ) (l: oplist σ): isaprop (isaterm s l). Proof. apply isasetstack. Defined. Local Lemma opexec_dec (nm: names σ) (ss: list (sorts σ)) : ((opexec nm (just ss) = nothing) × (prefix_remove (arity nm) ss = nothing)) ⨿ ∑ (ss': list (sorts σ)), (opexec nm (just ss) = just ((sort nm) :: ss')) × (prefix_remove (arity nm) ss = just ss'). Proof. unfold opexec, just. simpl. induction (prefix_remove (arity nm) ss) as [ ss' | error ]. - apply ii2. exists ss'. split; apply idpath. - apply ii1. split. + apply idpath. + induction error. apply idpath. Defined. Local Lemma opexec_just_f (nm: names σ) (ss: list (sorts σ)) (arityok: isprefix (arity nm) ss) : ∑ ss': list (sorts σ), opexec nm (just ss) = just ((sort nm) :: ss') × prefix_remove (arity nm) ss = just ss'. Proof. induction (opexec_dec nm ss) as [err | ok]. - induction err as [_ err]. contradicts arityok err. - assumption. Defined. Local Lemma opexec_just_b (nm: names σ) (st: stack σ) (ss: list (sorts σ)) : opexec nm st = just ss → ∑ ss', ss = sort nm :: ss' × st = just ((arity nm) ++ ss'). Proof. intro scons. induction st as [stok | sterror]. - induction (opexec_dec nm stok) as [scons_err | scons_ok]. + induction scons_err as [scons_err _]. set (H := ! scons @ scons_err). contradiction (negpathsii1ii2 _ _ H). + induction scons_ok as [ss' [X1 X2]]. exists ss'. split. * apply just_injectivity. exact (!scons @ X1). * apply maponpaths. apply prefix_remove_back. assumption. - contradiction (negpathsii2ii1 _ _ scons). Defined. Local Lemma opexec_zero_b (nm: names σ) (st: stack σ) : ¬ (opexec nm st = just nil). Proof. induction st as [stok | sterror]. - induction (opexec_dec nm stok) as [scons_err| scons_ok]. + induction scons_err as [scons_err _]. intro H. set (H' := (!! scons_err @ H)). apply negpathsii1ii2 in H'. assumption. + induction scons_ok as [p [proofp _]]. intro H. set (H' := (!proofp @ H)). apply ii1_injectivity in H'. apply negpathsconsnil in H'. assumption. - apply negpathsii2ii1. Defined. Local Lemma oplistexec_nil : oplistexec (nil: oplist σ) = just nil. Proof. apply idpath. Defined. Local Lemma oplistexec_cons (nm: names σ) (l: oplist σ) : oplistexec (nm :: l) = opexec nm (oplistexec l). Proof. apply idpath. Defined. Local Lemma oplistexec_zero_b (l: oplist σ): oplistexec l = just nil → l = nil. Proof. revert l. refine (list_ind _ _ _). - reflexivity. - intros x xs _ lstack. apply opexec_zero_b in lstack. contradiction. Defined. Local Lemma oplistexec_positive_b (l: oplist σ) (s: sorts σ) (ss: list (sorts σ)) : oplistexec l = just (s :: ss) → ∑ (x: names σ) (xs: oplist σ), l = x :: xs. Proof. revert l. refine (list_ind _ _ _). - intro nilstack. cbn in nilstack. apply ii1_injectivity in nilstack. apply negpathsnilcons in nilstack. contradiction. - intros x xs _ lstack. exists x. exists xs. apply idpath. Defined. (** *** The [stackconcatenate] function. *) (** [stackconcatenate] simply appends the two lists which make the stacks, possibly propagating erroneous states. *) Local Definition stackconcatenate (st1 st2: stack σ): stack σ := flatmap (λ st2', flatmap (λ st1', just (st1' ++ st2')) st1) st2. Local Lemma stackconcatenate_opexec (nm: names σ) (st1 st2: stack σ) : opexec nm st1 != nothing → stackconcatenate (opexec nm st1) st2 = opexec nm (stackconcatenate st1 st2). Proof. induction st1 as [ss1 | ]. 2: contradiction. induction st2 as [ss2| ]. 2: reflexivity. intro H. induction (opexec_dec nm ss1) as [Xerr | Xok]. - contradicts H (pr1 Xerr). - induction Xok as [tl [scons pref]]. unfold just in scons. rewrite scons. simpl. rewrite concatenateStep. unfold opexec. simpl. erewrite prefix_remove_concatenate. * apply idpath. * assumption. Defined. Local Lemma oplistexec_concatenate (l1 l2: oplist σ) : oplistexec l1 != nothing → oplistexec (concatenate l1 l2) = stackconcatenate (oplistexec l1) (oplistexec l2). Proof. revert l1. refine (list_ind _ _ _). - intros. change ([] ++ l2) with (l2). induction (oplistexec l2) as [l2ok | l2error]. + apply idpath. + induction l2error. apply idpath. - intros x xs IHxs noerror. change (oplistexec (x :: xs)) with (opexec x (oplistexec xs)) in *. rewrite stackconcatenate_opexec by (assumption). rewrite <- IHxs. + apply idpath. + intro error. rewrite error in noerror. contradiction. Defined. (** *** The [oplistsplit] function. *) (** [oplistsplit] splits an oplist into an oplist of up to [n] terms and an oplist of the remaining terms. *) Local Definition oplistsplit (l: oplist σ) (n: nat): oplist σ × oplist σ. Proof. revert l n. refine (list_ind _ _ _). - intros. exact (nil ,, nil). - intros x xs IHxs n. induction n. + exact (nil,, (x :: xs)). + induction (IHxs (length (arity x) + n)) as [IHfirst IHsecond]. exact ((x :: IHfirst) ,, IHsecond). Defined. Local Lemma oplistsplit_zero (l: oplist σ): oplistsplit l 0 = nil,, l. Proof. revert l. refine (list_ind _ _ _) ; reflexivity. Defined. Local Lemma oplistsplit_nil (n: nat): oplistsplit nil n = nil,, nil. Proof. apply idpath. Defined. Local Lemma oplistsplit_cons (x: names σ) (xs: oplist σ) (n: nat) : oplistsplit (x :: xs) (S n) = (x :: (pr1 (oplistsplit xs (length (arity x) + n)))) ,, (pr2 (oplistsplit xs (length (arity x) + n))). Proof. apply idpath. Defined. Local Lemma oplistsplit_concatenate (l1 l2: oplist σ) (n: nat) (ss: list (sorts σ)) : oplistexec l1 = just ss → n ≤ length ss → oplistsplit (l1 ++ l2) n = make_dirprod (pr1 (oplistsplit l1 n)) (pr2 (oplistsplit l1 n) ++ l2). Proof. revert l1 ss n. refine (list_ind _ _ _). - intros ss n l1stack nlehss. apply ii1_injectivity in l1stack. rewrite <- l1stack in nlehss. apply natleh0tois0 in nlehss. rewrite nlehss. rewrite oplistsplit_zero. apply idpath. - intros x1 xs1 IHxs1 ss n l1stack nlehss. change ((x1 :: xs1) ++ l2) with (x1 :: (xs1 ++ l2)). induction n. + apply idpath. + change (oplistexec (x1 :: xs1)) with (opexec x1 (oplistexec xs1)) in l1stack. apply opexec_just_b in l1stack. induction l1stack as [sstail [ssdef xs1stack]]. eset (IHinst := IHxs1 (arity x1 ++ sstail) (length (arity x1) + n) xs1stack _). do 2 rewrite oplistsplit_cons. apply pathsdirprod. * cbn. apply maponpaths. apply (maponpaths pr1) in IHinst. cbn in IHinst. assumption. * apply (maponpaths dirprod_pr2) in IHinst. assumption. Unshelve. rewrite length_concatenate. apply natlehandplusl. rewrite ssdef in nlehss. assumption. Defined. Local Lemma concatenate_oplistsplit (l: oplist σ) (n: nat): pr1 (oplistsplit l n) ++ pr2 (oplistsplit l n) = l. Proof. revert l n. refine (list_ind _ _ _). - reflexivity. - intros x xs IHxs n. induction n. + apply idpath. + rewrite oplistsplit_cons. simpl. rewrite concatenateStep. apply maponpaths. apply IHxs. Defined. Local Lemma oplistexec_oplistsplit (l: oplist σ) {ss: list (sorts σ)} (n: nat) : oplistexec l = just ss → n ≤ length ss → ∑ t1 t2: list (sorts σ), ss = t1 ++ t2 × oplistexec (pr1 (oplistsplit l n)) = just t1 × oplistexec (pr2 (oplistsplit l n)) = just t2 × length t1 = n. Proof. revert l ss n. refine (list_ind _ _ _). - intros m ss nilstack nlehss. cbn. apply ii1_injectivity in nilstack. rewrite <- nilstack in *. apply natleh0tois0 in nlehss. rewrite nlehss. exists nil. exists nil. repeat split. - intros x xs IHxs ss n lstack nlehss. induction n. + rewrite oplistsplit_zero. exists nil. exists ss. repeat split. assumption. + rewrite oplistsplit_cons. simpl. change (oplistexec (x :: xs)) with (opexec x (oplistexec xs)) in lstack. apply opexec_just_b in lstack. induction lstack as [sstail [ssdef xsstack]]. eset (IHinst := IHxs (arity x ++ sstail) (length (arity x) + n) xsstack _). induction IHinst as [t1 [ t2 [ t1t2concat [ t1def [ t2def t1len ] ] ] ] ]. exists ((sort x) :: MoreLists.drop t1 (length (arity x))). exists t2. repeat split. * rewrite concatenateStep. rewrite <- drop_concatenate. -- rewrite <- t1t2concat. rewrite drop_concatenate. 2: apply isreflnatleh. rewrite drop_full. assumption. -- rewrite t1len. apply natlehnplusnm. * rewrite oplistexec_cons. rewrite t1def. unfold opexec. simpl. rewrite prefix_remove_drop. -- simpl. apply maponpaths. apply idpath. -- intro H. apply (prefix_remove_concatenate2 _ _ t2) in H. ++ rewrite <- t1t2concat in H. rewrite prefix_remove_prefix in H. exact (negpathsii1ii2 _ _ H). ++ rewrite t1len. apply natlehnplusnm. * apply t2def. * rewrite length_cons. apply maponpaths. rewrite length_drop. rewrite t1len. rewrite natpluscomm. apply plusminusnmm. Unshelve. rewrite length_concatenate. apply natlehandplusl. rewrite ssdef in nlehss. assumption. Defined. Local Corollary oplistsplit_self {l: oplist σ} {ss: list (sorts σ)} : oplistexec l = just ss → oplistsplit l (length ss) = l ,, nil. Proof. intro lstack. set (H := oplistexec_oplistsplit l (length ss) lstack (isreflnatleh (length ss))). induction H as [t1 [t2 [t1t2 [t1def [t2def t1len]]]]]. set (normalization := concatenate_oplistsplit l (length ss)). apply (maponpaths length) in t1t2. rewrite length_concatenate in t1t2. rewrite t1len in t1t2. apply pathsinv0 in t1t2. rewrite natpluscomm in t1t2. apply (maponpaths (λ a, a - length ss)) in t1t2. rewrite plusminusnmm in t1t2. rewrite minuseq0' in t1t2. apply length_zero_back in t1t2. rewrite t1t2 in t2def. apply oplistexec_zero_b in t2def. rewrite t2def in normalization. rewrite concatenate_nil in normalization. induction (oplistsplit l (length ss)) as [l1 l2]. simpl in *. rewrite t2def. rewrite normalization. apply idpath. Defined. End Oplists. Section Term. (** ** Terms and related constructors and destructors. *) (** A [term] is an oplist together with the proof it is a term. *) Local Definition term (σ: signature) (s: sorts σ): UU := ∑ t: oplist σ, isaterm s t. Definition make_term {σ: signature} {s: sorts σ} {l: oplist σ} (lstack: isaterm s l) : term σ s := l ,, lstack. Coercion term2oplist {σ: signature} {s: sorts σ}: term σ s → oplist σ := pr1. Definition term2proof {σ: signature} {s: sorts σ}: ∏ t: term σ s, isaterm s t := pr2. Lemma isasetterm {σ: signature} (s: sorts σ): isaset (term σ s). Proof. apply isaset_total2. - apply isasetoplist. - intros. apply isasetaprop. apply isasetstack. Defined. Local Definition termset (σ: signature) (s: sorts σ): hSet := make_hSet (term σ s) (isasetterm s). Context {σ: signature}. Lemma term_extens {s: sorts σ} {t1 t2 : term σ s} (p : term2oplist t1 = term2oplist t2) : t1 = t2. Proof. apply subtypePairEquality'. 2: apply isapropisaterm. assumption. Defined. (** *** The [vecoplist2oplist] and [oplist2vecoplist] functions *) (** These functions transform a vec of [n] oplists into an oplists of stack [n] ([vecoplist2oplist]) and viceversa ([oplist2vecoplist]). *) Local Definition vecoplist2oplist {n: nat} (v: vec (oplist σ) n): oplist σ := vec_foldr concatenate nil v. Local Lemma vecoplist2oplist_vcons {n: nat} (x: oplist σ) (v: vec (oplist σ) n) : vecoplist2oplist (x ::: v) = concatenate x (vecoplist2oplist v). Proof. apply idpath. Defined. Local Lemma vecoplist2oplist_inj {n: nat} {ar: vec (sorts σ) n} {v1 v2: hvec (vec_map (term σ) ar)} : vecoplist2oplist (h1map_vec (λ _, term2oplist) v1) = vecoplist2oplist (h1map_vec (λ _, term2oplist) v2) → v1 = v2. Proof. revert n ar v1 v2. refine (vec_ind _ _ _). - intros. induction v1. induction v2. apply idpath. - intros x n xs IHxs v1 v2 eq. induction v1 as [v1x v1xs]. induction v2 as [v2x v2xs]. simpl in eq. apply (maponpaths (λ l, oplistsplit l 1)) in eq. rewrite (oplistsplit_concatenate _ _ 1 [x] (term2proof v1x) (isreflnatleh _)) in eq. rewrite (oplistsplit_concatenate _ _ 1 [x] (term2proof v2x) (isreflnatleh _)) in eq. do 2 change 1 with (length (hd (x ::: xs) :: [])) in eq at 1. do 2 change 1 with (length (hd (x ::: xs) :: [])) in eq at 1. rewrite (oplistsplit_self (term2proof v1x)) in eq. rewrite (oplistsplit_self (term2proof v2x)) in eq. cbn in eq. simpl. apply map_on_two_paths. + apply subtypePairEquality'. * apply (maponpaths pr1 eq). * apply isapropisaterm. + apply IHxs. apply (maponpaths (λ l, pr2 l: oplist σ) eq). Defined. Local Lemma oplistexec_vecoplist2oplist {n: nat} {ar: vec (sorts σ) n} {v: hvec (vec_map (term σ) ar)} : oplistexec (vecoplist2oplist (h1map_vec (λ _, term2oplist) v)) = just (n ,, ar). Proof. revert n ar v. refine (vec_ind _ _ _). - induction v. reflexivity. - intros x n xs IHxs v. induction v as [vx vxs]. simpl in *. rewrite oplistexec_concatenate. unfold h1map_vec in IHxs. + rewrite IHxs. rewrite (term2proof vx). apply idpath. + rewrite (term2proof vx). apply negpathsii1ii2. Defined. Local Definition oplist2vecoplist {n: nat} {ar: vec (sorts σ) n} (l: oplist σ) (lstack: oplistexec l = just (n,, ar)) : ∑ (v: hvec (vec_map (term σ) ar)) , (hvec (h1map_vec (λ _ t, hProptoType (length (term2oplist t) ≤ length l)) v)) × vecoplist2oplist (h1map_vec (λ _, term2oplist) v) = l. Proof. revert n ar l lstack. refine (vec_ind _ _ _). - intros. exists [()]. exists [()]. apply oplistexec_zero_b in lstack. rewrite lstack. apply idpath. - intros x n xs IHxs l lstack. induction (oplistexec_oplistsplit l 1 lstack (natleh0n 0)) as [firststack [reststack [concstack [firststackp [reststackp firstlen]]]]]. change (S n,, (x ::: xs)%vec) with (x :: (n ,, xs)) in concstack. set (first := pr1 (oplistsplit l 1)) in *. set (rest := pr2 (oplistsplit l 1)) in *. apply length_one_back in firstlen. induction firstlen as [a firststack']. induction (!firststack'). change ((a :: []) ++ reststack) with (a :: reststack) in concstack. pose (concstack' := concstack). apply cons_inj1 in concstack'. apply cons_inj2 in concstack. induction (!concstack). induction (!concstack'). induction (IHxs rest reststackp) as [v [vlen vflatten]]. exists ((make_term firststackp) ::: v). repeat split. + change (length first ≤ length l). rewrite <- (concatenate_oplistsplit l 1). apply length_sublist1. + change (hvec (h1map_vec (λ (s: sorts σ) (t: term σ s), hProptoType (length (term2oplist t) ≤ length l)) v)). eapply (h2map (λ _ _ p, istransnatleh p _) vlen). Unshelve. rewrite <- (concatenate_oplistsplit l 1). apply length_sublist2. + simpl. unfold h1map_vec in vflatten. rewrite vflatten. apply concatenate_oplistsplit. Defined. (** ** Constructors and destuctors. *) (** [build_term] builds a term starting from principal operation symbol and subterms, while [princop] and [subterms] are the corresponding destructors. *) Local Definition oplist_build (nm: names σ) (v: vec (oplist σ) (length (arity nm))) : oplist σ := cons nm (vecoplist2oplist v). Local Lemma oplist_build_isaterm (nm: names σ) (v: (term σ)⋆ (arity nm)) : isaterm (sort nm) (oplist_build nm (h1map_vec (λ _, term2oplist) v)). Proof. unfold oplist_build, isaterm. rewrite oplistexec_cons. rewrite oplistexec_vecoplist2oplist. change (length (arity nm),, pr2 (arity nm)) with (arity nm). induction (opexec_just_f nm (arity nm) (isprefix_self _)) as [rest [p1 p2]]. rewrite prefix_remove_self in p2. apply just_injectivity in p2. induction p2. assumption. Defined. Local Definition build_term (nm: names σ) (v: (term σ)⋆ (arity nm)): term σ (sort nm). Proof. exists (oplist_build nm (h1map_vec (λ _, term2oplist) v)). apply oplist_build_isaterm. Defined. Local Definition term_decompose {s: sorts σ} (t: term σ s): ∑ (nm:names σ) (v: (term σ)⋆ (arity nm)) , (hvec (h1map_vec (λ _ t', hProptoType (length (term2oplist t') < length t)) v)) × sort nm = s × oplist_build nm (h1map_vec (λ _, term2oplist) v) = t. Proof. induction t as [l lstack]. cbv [pr1 term2oplist]. revert l lstack. refine (list_ind _ _ _). - intro lstack. apply ii1_injectivity in lstack. apply (maponpaths length) in lstack. apply negpaths0sx in lstack. contradiction. - intros x xs IHxs lstack. exists x. unfold isaterm in lstack. rewrite oplistexec_cons in lstack. apply opexec_just_b in lstack. induction lstack as [xssort [xsdef stackxs]]. pose (xsdef' := xsdef). apply cons_inj1 in xsdef'. apply cons_inj2 in xsdef. induction xsdef'. induction xsdef. rewrite concatenate_nil in stackxs. induction (oplist2vecoplist xs stackxs) as [vtail [vlen vflatten]]. exists vtail. repeat split. + exact (h2map (λ _ _ p, natlehtolthsn _ _ p) vlen). + unfold oplist_build. rewrite <- vflatten. apply idpath. Defined. Definition princop {s: sorts σ} (t: term σ s): names σ := pr1 (term_decompose t). Definition subterms {s: sorts σ} (t: term σ s): (term σ)⋆ (arity (princop t)) := pr12 (term_decompose t). Local Definition subterms_length {s: sorts σ} (t: term σ s) : hvec (h1map_vec (λ _ t', hProptoType (length (term2oplist t') < length t)) (subterms t)) := pr122 (term_decompose t). Local Definition princop_sorteq {s: sorts σ} (t: term σ s): sort (princop t) = s := pr122 (pr2 (term_decompose t)). Local Definition oplist_normalization {s: sorts σ} (t: term σ s) : term2oplist (build_term (princop t) (subterms t)) = t := pr222 (pr2 (term_decompose t)). (** *** Term normalization *) (** We prove that [princop (build_term nm v) = nm], [subterms (build_term nm v) = v] and [build_term (princop t) (subterms t))] is equal to [t] modulo [transport]. *) Local Lemma term_normalization {s: sorts σ} (t: term σ s) : transportf (term σ) (princop_sorteq t) (build_term (princop t) (subterms t)) = t. Proof. unfold princop, subterms, princop_sorteq. induction (term_decompose t) as [nm [v [vlen [nmsort normalization]]]]. induction nmsort. change (build_term nm v = t). apply subtypePairEquality'. - apply normalization. - apply isapropisaterm. Defined. Local Lemma princop_build_term (nm: names σ) (v: (term σ)⋆ (arity nm)) : princop (build_term nm v) = nm. Proof. apply idpath. Defined. Local Lemma subterms_build_term (nm: names σ) (v: (term σ)⋆ (arity nm)) : subterms (build_term nm v) = v. Proof. set (t := build_term nm v). set (tnorm := term_normalization t). assert (princop_sorteq_idpath: princop_sorteq t = idpath (sort nm)). { apply proofirrelevance. apply isasetifdeceq. apply decproperty. } rewrite princop_sorteq_idpath in tnorm. change (transportb (term σ) (idpath (sort nm)) t) with t in tnorm. set (tnorm_list := maponpaths pr1 tnorm). apply cons_inj2 in tnorm_list. apply vecoplist2oplist_inj in tnorm_list. exact tnorm_list. Defined. (** *** Miscellanea properties for terms. *) Local Lemma length_term {s: sorts σ} (t: term σ s): length t > 0. Proof. induction t as [l stackl]. induction (oplistexec_positive_b _ _ _ stackl) as [x [xs lstruct]]. induction (! lstruct). apply idpath. Defined. Local Lemma term_notnil {X: UU} {s: sorts σ} {t: term σ s}: length t ≤ 0 → X. Proof. intro tlen. apply natlehneggth in tlen. contradicts tlen (length_term t). Defined. End Term. (** ** Term induction. *) (** If [P] is a map from terms to properties, then [term_ind_HP P] is the inductive hypothesis for terms: given an operation symbol [nm], a sequence of terms of type specified by the arity of [nm], a proof of the property [P] for eache of the terms in [v], we need a proof of [P] for the term built from [nm] and [v]. *) Section TermInduction. Context {σ: signature}. Definition term_ind_HP (P: ∏ (s: sorts σ), term σ s → UU) := ∏ (nm: names σ) (v: (term σ)⋆ (arity nm)) (IH: hvec (h1map_vec P v)) , P (sort nm) (build_term nm v). (** The proof of the induction principle [term_ind] for terms proceeds by induction on the lenght of the oplist forming the terms in [term_ind_onlength]. *) Local Lemma term_ind_onlength (P: ∏ (s: sorts σ), term σ s → UU) (R: term_ind_HP P) : ∏ (n: nat) (s: sorts σ) (t: term σ s), length t ≤ n → P s t. Proof. induction n. - intros s t tlen. exact (term_notnil tlen). - intros s t tlen. apply (transportf (P s) (term_normalization t)). induction (princop_sorteq t). change (P (sort (princop t)) (build_term (princop t) (subterms t))). apply (R (princop t) (subterms t)). refine (h2map _ (subterms_length t)). intros. apply IHn. apply natlthsntoleh. eapply natlthlehtrans. + exact X. + exact tlen. Defined. (* I would like to prove something like the following: Lemma term_ind_onlength_step (P: ∏ (s: sorts σ), term σ s → UU) (R: term_ind_HP P) (nm: names σ) (v: (term σ)⋆ (arity nm)) : ∏ (n: nat) (tlehn: length (build_term nm v) ≤ n), term_ind_onlength P R n _ _ tlehn = R nm v (transportf (λ x, hvec (hmap_vec P x)) (subterms_build_term nm v) (hhmap (subterms_length (build_term nm v)) (λ s t p, term_ind_onlength P R n s t (istransnatleh (natlthtoleh _ _ p) tlehn)))). *) Theorem term_ind (P: ∏ (s: sorts σ), term σ s → UU) (R: term_ind_HP P) {s: sorts σ} (t: term σ s) : P s t. Proof. exact (term_ind_onlength P R (length t) s t (isreflnatleh _)). Defined. (** *** Term induction step *) (** In order to use term_induction, we need to prove an unfolding property. For example, for natural number induction the unfolding property is [nat_rect P a IH (S n) = IH n (nat_rect P a IH n)], in our case is given by [term_ind_step]. *) Local Lemma term_ind_onlength_nirrelevant (P: ∏ (s: sorts σ), term σ s → UU) (R: term_ind_HP P) : ∏ (n m1 m2: nat) (m1lehn: m1 ≤ n) (m2lehn: m2 ≤ n) (s: sorts σ) (t: term σ s) (lenm1: length t ≤ m1) (lenm2: length t ≤ m2) , term_ind_onlength P R m1 s t lenm1 = term_ind_onlength P R m2 s t lenm2. Proof. induction n. - intros. exact (term_notnil (istransnatleh lenm1 m1lehn)). - intros. induction m1. + exact (term_notnil lenm1). + induction m2. * exact (term_notnil lenm2). * simpl. apply maponpaths. set (f := paths_rect _ _ _). apply (maponpaths (λ x, f x _ _)). apply maponpaths. apply (maponpaths (λ x, h2map x _)). do 3 (apply funextsec; intro). apply IHn. -- apply m1lehn. -- apply m2lehn. Defined. Local Lemma nat_rect_step {P: nat → UU} (a: P 0) (IH: ∏ n: nat, P n → P (S n)) (n: nat): nat_rect P a IH (S n) = IH n (nat_rect P a IH n). Proof. apply idpath. Defined. Local Lemma paths_rect_step (A : UU) (a : A) (P : ∏ a0 : A, a = a0 → UU) (x: P a (idpath a)) : paths_rect A a P x a (idpath a) = x. Proof. apply idpath. Defined. Lemma term_ind_step (P: ∏ (s: sorts σ), term σ s → UU) (R: term_ind_HP P) (nm: names σ) (v: (term σ)⋆ (arity nm)) : term_ind P R (build_term nm v) = R nm v (h2map (λ s t q, term_ind P R t) (h1lift v)). Proof. unfold term_ind. set (t := build_term nm v). simpl (length t). unfold term_ind_onlength at 1. rewrite nat_rect_step. set (v0len := subterms_length t). set (v0norm := term_normalization t). clearbody v0len v0norm. (* Needed to make induction work *) change (princop t) with nm in *. induction (! (subterms_build_term nm v: subterms t = v)). assert (princop_sorteq_idpath: princop_sorteq t = idpath (sort nm)). { apply proofirrelevance. apply isasetifdeceq. apply decproperty. } induction (! princop_sorteq_idpath). change (build_term nm v = t) in v0norm. assert (v0normisid: v0norm = idpath _). { apply proofirrelevance. apply isasetterm. } induction (! v0normisid). rewrite idpath_transportf. rewrite paths_rect_step. apply maponpaths. rewrite (h1map_h1lift_as_h2map v v0len). apply (maponpaths (λ x, h2map x _)). repeat (apply funextsec; intro). apply (term_ind_onlength_nirrelevant P R (pr1 (vecoplist2oplist (h1map_vec (λ x2 : sorts σ, term2oplist) v)))). - apply isreflnatleh. - apply natlthsntoleh. apply x1. Defined. (** *** Immediate applications of term induction *) (** [depth] returns the depth of a term, while [fromterm] is the evaluation map from terms to an algebra. Finally, [fromtermstep] is the unfolding property for [fromterm]. *) Definition depth {s: sorts σ}: term σ s → nat := term_ind (λ _ _, nat) (λ (nm: names σ) (v: (term σ)⋆ (arity nm)) (depths: hvec (h1map_vec (λ _ _, nat) v)), 1 + h2foldr (λ _ _, max) 0 depths). Local Definition fromterm {A: sUU (sorts σ)} (op : ∏ (nm : names σ), A⋆ (arity nm) → A (sort nm)) {s: sorts σ} : term σ s → A s := term_ind (λ s _, A s) (λ nm v rec, op nm (h2lower rec)). Lemma fromtermstep {A: sUU (sorts σ)} (nm: names σ) (op : ∏ (nm : names σ), A⋆ (arity nm) → A (sort nm)) (v: (term σ)⋆ (arity nm)) : fromterm op (build_term nm v) = op nm (h1map (@fromterm A op) v). Proof. unfold fromterm. rewrite term_ind_step. rewrite h2lower_h1map_h1lift. apply idpath. Defined. End TermInduction. (** ** Notations for ground terms. *) (** Since [term], [termset], [fromterm] and [fromtermstep] will be redefined in [UniMath.Algebra.Universal.VTerms] in their more general form with variables, we introduce here notations [gterm], [make_gterm] and similar to make the ground version publically available with special names. *) Notation gterm := term. Notation gtermset := termset. Notation fromgterm := fromterm. Notation fromgtermstep := fromtermstep. Notation build_gterm := build_term. (** * Curried version of [build_term] *) (** Defines a curried version of [build_term] which is easier to use in practice. **) Section iterbuild. (** If [v] is a vector of types of length [n], [iterfun v B] is the curried version of [v → B], i.e. [iterfun v B] = [(el v 1) → ((el v 2) → ...... → ((el v n) → B)]. *) Definition iterfun {n: nat} (v: vec UU n) (B: UU): UU. Proof. revert n v. refine (vec_ind _ _ _). - exact B. - intros x n xs IHxs. exact (x → IHxs). Defined. (** If [f: hvec v → B], then [itercurry f] is the curried version of [f], which has type [iterfun v B]. *) Definition itercurry {n: nat} {v: vec UU n} {B: UU} (f: hvec v → B): iterfun v B. Proof. revert n v f. refine (vec_ind _ _ _). - intros. exact (f tt). - intros x n xs IHxs f. simpl in f. simpl. intro a. exact (IHxs (λ l, f (a,, l))). Defined. (** [build_term_curried nm t1 ... tn] builds a term from the operation symbol [nm] and terms (of the correct sort) [t1] ... [tn]. *) Definition build_gterm_curried {σ: signature} (nm: names σ) : iterfun (vec_map (term σ) (pr2 (arity nm))) (term σ (sort nm)) := itercurry (build_term nm). End iterbuild. UniMath-20231010/UniMath/Algebra/Universal/VTerms.v000066400000000000000000000070551451125700300215770ustar00rootroot00000000000000(** ** Variables and terms with variables *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** Given a signature σ, a [varspec] (variable specification) is a map from an [hSet] of _variables_ to the corresponding sort. A signature σ and a variable specification [V] give origin to a new signature, [vsignature σ V] where variables in [v] become constant symbols. A term over signature σ and variables in V is, i.e., a [vterm σ v], is a plain (ground) term over this extended signature. *) Require Import UniMath.Foundations.All. Require Import UniMath.Algebra.Universal.SortedTypes. Require Export UniMath.Algebra.Universal.Terms. Local Open Scope sorted. Section Variables. Definition varspec (σ: signature) := ∑ V: hSet, V → sorts σ. Definition make_varspec (σ: signature) (varsupp: hSet) (varsorts: varsupp → sorts σ) : varspec σ := (varsupp,, varsorts). Coercion varsupp {σ: signature}: varspec σ → hSet := pr1. Definition varsort {σ: signature} {V: varspec σ}: V → sorts σ := pr2 V. Definition vsignature (σ : signature) (V: varspec σ): signature := make_signature (sorts σ) (setcoprod (names σ) V) (sumofmaps (ar σ) (λ v, nil ,, varsort v)). Context {σ : signature}. Definition namelift (V: varspec σ) (nm: names σ): names (vsignature σ V) := inl nm. Definition varname {V: varspec σ} (v: V): names (vsignature σ V) := inr v. Definition term (σ: signature) (V: varspec σ): sUU (sorts σ) := gterm (vsignature σ V). Definition termset (σ: signature) (V: varspec σ): shSet (sorts σ) := gtermset (vsignature σ V). Definition build_term {V: varspec σ} (nm: names σ) (v: (term σ V)⋆ (arity nm)) : term σ V (sort nm) := build_gterm (namelift V nm) v. Definition varterm {V: varspec σ} (v: V): term σ V (varsort v) := build_gterm (varname v) [()]. Definition assignment {σ: signature} (A: sUU (sorts σ)) (V: varspec σ) : UU := ∏ v: V, A (varsort v). Definition build_term_curried {V: varspec σ} (nm: names σ) : iterfun (vec_map (term σ V) (pr2 (arity (namelift V nm)))) (term σ V (sort (namelift V nm))) := build_gterm_curried (namelift V nm). (** Evaluation maps for terms and corresponding unfolding properties *) Definition fromterm {A: sUU (sorts σ)} {V: varspec σ} (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm))) (α : assignment A V) : term σ V s→ A. Proof. refine (@fromgterm (vsignature σ V) A _). induction nm as [nm | v]. - exact (op nm). - exact (λ _, α v). Defined. Lemma fromtermstep {A: sUU (sorts σ)} {V: varspec σ} (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm))) (α : assignment A V) (nm: names σ) (v: (term σ V)⋆ (arity nm)) : fromterm op α (sort nm) (build_term nm v) = op nm ((fromterm op α)⋆⋆ (arity nm) v). Proof. unfold fromterm, fromgterm, build_term. rewrite (term_ind_step _ _ (namelift V nm)). simpl. rewrite h2lower_h1map_h1lift. apply idpath. Defined. (** This used to be provable with apply idpath in the single sorted case **) Lemma fromtermstep' {A: sUU (sorts σ)} {V: varspec σ} (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm))) (α : assignment A V) (v: V) : fromterm op α (varsort v) (varterm v) = α v. Proof. unfold fromterm, fromgterm, varterm. rewrite (term_ind_step _ _ (varname v)). apply idpath. Defined. End Variables. UniMath-20231010/UniMath/AlgebraicGeometry/000077500000000000000000000000001451125700300202415ustar00rootroot00000000000000UniMath-20231010/UniMath/AlgebraicGeometry/.package/000077500000000000000000000000001451125700300217125ustar00rootroot00000000000000UniMath-20231010/UniMath/AlgebraicGeometry/.package/files000066400000000000000000000000431451125700300227340ustar00rootroot00000000000000Topology.v SheavesOfRings.v Spec.v UniMath-20231010/UniMath/AlgebraicGeometry/README.md000066400000000000000000000000461451125700300215200ustar00rootroot00000000000000Algebraic Geometry ================== UniMath-20231010/UniMath/AlgebraicGeometry/SheavesOfRings.v000066400000000000000000000046761451125700300233330ustar00rootroot00000000000000Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.Topology.Topology. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.preorder_categories. Require Import UniMath.CategoryTheory.categories.commrings. Require Import UniMath.AlgebraicGeometry.Topology. Local Open Scope cat. Local Open Scope logic. Local Open Scope subtype. Local Open Scope open. (* The category of open subsets of a topological space. *) Section open_category. Context (X : TopologicalSpace). Definition open_po : po (@Open X) := make_po _ (isporesrel _ _ (subtype_containment_ispreorder X)). Definition open_category : category := po_category open_po. End open_category. Section sheaf_commring_prop. Context {X : TopologicalSpace} (F' : functor_data (open_category X)^op commring_precategory). Definition F (U : Open) : commring := F' U. Definition restriction {U V : Open} (H : U ⊆ V) : ringfun (F V) (F U) := #F' H. Definition restrict (A : hsubtype Open) (f : F (⋃ A)) (U : A) : F (pr1 U) := restriction (contained_in_union_open U) f. Definition agree_on_intersections {A : hsubtype Open} (g : ∏ U : A, F (pr1 U)) : UU := ∏ U V : A, restriction (intersection_contained1 _ _) (g U) = restriction (intersection_contained2 _ _) (g V). Definition locality : hProp := ∀ (A : hsubtype Open) (f g : F (⋃ A)), restrict A f ~ restrict A g ⇒ f = g. Definition gluing : hProp := ∀ (A : hsubtype Open) (g : ∏ U : A, F (pr1 U)), agree_on_intersections g ⇒ ∃ f, restrict A f ~ g. End sheaf_commring_prop. Section sheaf_commring. Context {X : TopologicalSpace}. Definition sheaf_commring : UU := ∑ F : (open_category X)^op ⟶ commring_precategory, locality F ∧ gluing F. Definition make_sheaf_commring F l g : sheaf_commring := F ,, l ,, g. Definition sheaf_commring_functor (F : sheaf_commring) : (open_category X)^op ⟶ commring_precategory := pr1 F. Coercion sheaf_commring_functor : sheaf_commring >-> functor. Definition sheaf_commring_locality (F : sheaf_commring) : locality F := pr12 F. Definition sheaf_commring_gluing (F : sheaf_commring) : gluing F := pr22 F. End sheaf_commring. Arguments sheaf_commring _ : clear implicits. UniMath-20231010/UniMath/AlgebraicGeometry/Spec.v000066400000000000000000000515541451125700300213340ustar00rootroot00000000000000(** ** Contents - Zariski topology - Structure sheaf - Sections - Restriction of a section - Definition of the structure sheaf *) Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.RigsAndRings.Ideals. Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.Topology.Topology. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.commrings. Require Import UniMath.AlgebraicGeometry.Topology. Require Import UniMath.AlgebraicGeometry.SheavesOfRings. Local Open Scope cat. Local Open Scope ring. Local Open Scope logic. Local Open Scope subtype. Local Open Scope open. (** ** Zariski topology *) Section spec. Context {R : commring}. Definition zariski_topology : (prime_ideal R -> hProp) -> hProp := λ U, ∃ A, U ≡ (λ p, A ⊈ p). Lemma zariski_topology_union : isSetOfOpen_union zariski_topology. Proof. intros O H0. unfold zariski_topology. set (S := λ A, ∃ U, O U ∧ U ≡ (λ p, A ⊈ p)). apply hinhpr. exists (union S). intro p. apply issymm_logeq, (logeq_trans (union_not_contained_in S p)). unfold union. use make_dirprod; intro H. - use (hinhuniv _ H); intro HA. induction HA as [A HA]. use (hinhfun _ (dirprod_pr1 HA)); intro HU. induction HU as [U HU]. exists U. use make_dirprod. + exact (dirprod_pr1 HU). + apply (dirprod_pr2 (dirprod_pr2 HU p)), (dirprod_pr2 HA). - use (hinhuniv _ H); intro HU. induction HU as [U HU]. use (hinhfun _ (H0 U (dirprod_pr1 HU))); intro HA. induction HA as [A HA]. exists A. use make_dirprod. + apply hinhpr. exists U. exact (make_dirprod (dirprod_pr1 HU) HA). + apply (dirprod_pr1 (HA p)), (dirprod_pr2 HU). Defined. Lemma zariski_topology_htrue : isSetOfOpen_htrue zariski_topology. Proof. apply hinhpr. exists (λ x, htrue). intro p. use make_dirprod; intro H. - apply hinhpr. exists rigunel2. exact (make_dirprod tt (prime_ideal_ax2 p)). - exact tt. Defined. Lemma zariski_topology_and : isSetOfOpen_and zariski_topology. Proof. unfold zariski_topology. intros U V HU HV. use (hinhuniv _ HU); intros HA. use (hinhfun _ HV); intros HB. induction HA as [A HA]. induction HB as [B HB]. exists (λ x, ∃ a b, A a × B b × x = (a * b)%ring). intro p. assert (H0 : U p ∧ V p ⇔ A ⊈ p ∧ B ⊈ p). { use make_dirprod; intro H. - use make_dirprod. + apply (dirprod_pr1 (HA p)), (dirprod_pr1 H). + apply (dirprod_pr1 (HB p)), (dirprod_pr2 H). - use make_dirprod. + apply (dirprod_pr2 (HA p)), (dirprod_pr1 H). + apply (dirprod_pr2 (HB p)), (dirprod_pr2 H). } apply (logeq_trans H0). unfold subtype_notContainedIn. use make_dirprod; intro H. - use (hinhuniv _ (dirprod_pr1 H)); intro Ha. use (hinhfun _ (dirprod_pr2 H)); intro Hb. induction Ha as [a Ha]. induction Hb as [b Hb]. exists (a * b)%ring. use make_dirprod. + apply hinhpr. exists a, b. exact (make_dirprod (dirprod_pr1 Ha) (make_dirprod (dirprod_pr1 Hb) (idpath _))). + apply (@negf _ (p a ∨ p b)). * exact (prime_ideal_ax1 _ a b). * apply toneghdisj. exact (make_dirprod (dirprod_pr2 Ha) (dirprod_pr2 Hb)). - use (hinhuniv _ H); intro Hx. induction Hx as [x Hx]. induction Hx as [Hx Hpx]. use (hinhuniv _ Hx); intro Hab. induction Hab as [a Hab]. induction Hab as [b Hab]. induction Hab as [Ha Hab]. induction Hab as [Hb Hab]. use make_dirprod; apply hinhpr. + exists a. use make_dirprod. * exact Ha. * use (negf _ Hpx). intro Hpa. apply (transportb (λ y, p y) Hab). apply (ideal_isr p b a), Hpa. + exists b. use make_dirprod. * exact Hb. * use (negf _ Hpx). intro Hpb. apply (transportb (λ y, p y) Hab). apply (ideal_isl p a b), Hpb. Defined. Definition Spec : TopologicalSpace := make_TopologicalSpace (make_hSet (prime_ideal R) isaset_prime_ideal) zariski_topology zariski_topology_union zariski_topology_htrue zariski_topology_and. End spec. Arguments Spec _ : clear implicits. (** ** Structure sheaf *) (** *** Sections *) (** For each prime ideal p of R, let R_p be the localization of R at p. For an open set U from the spectrum of R, we define [section U] to be the family of functions s : ∏ p, R_p, such that s is locally a quotient of elements of R: to be precise, we require that for each p in U there is a neighborhood V of p, contained in U, and elements f, g in R, such that for each q in V, g not in q, and s q = f/g. *) Section section. Context {R : commring} {U : @Open (Spec R)}. Definition is_quotient_on (V : Open) (s : ∏ q : carrier U, localization_at (pr1 q)) : hProp := ∃ (f g : R), ∀ q : carrier U, V (pr1 q) ⇒ ∃ Hg : ¬ (pr1 q : prime_ideal R) g, s q = quotient f (g ,, Hg). Definition is_section (s : ∏ p : carrier U, localization_at (pr1 p)) : hProp := ∀ p : carrier U, ∃ V : Open, V (pr1 p) ∧ V ⊆ U ∧ is_quotient_on V s. Definition section : UU := ∑ s : (∏ p : carrier U, localization_at (pr1 p)), is_section s. Definition make_section (s : ∏ p : carrier U, localization_at (pr1 p)) (H : is_section s) : section := s ,, H. Definition section_map (s : section) : ∏ p : carrier U, localization_at (pr1 p) := pr1 s. Coercion section_map : section >-> Funclass. Definition section_prop (s : section) : is_section s := pr2 s. Definition funext_section (s t : section) : (∀ p, s p = t p) -> s = t := λ H, subtypePath_prop (funextsec _ _ _ H). End section. Arguments section {_} _. (* [section U] is a commutative ring. *) Section section_commring. Context {R : commring} {U : @Open (Spec R)}. Lemma isaset_section : isaset (section U). Proof. apply isaset_total2. - apply impred_isaset. intro p. apply setproperty. - intro s. apply isasetaprop, propproperty. Qed. Definition section_hset : hSet := make_hSet _ isaset_section. Lemma is_section_op1 (s t : section U) : is_section (λ p, s p + t p). Proof. intro p. induction s as [s Hs]. induction t as [t Ht]. use (hinhuniv _ (Hs p)); intro H1. use (hinhuniv _ (Ht p)); intro H2. induction H1 as [V1 H1]. induction H1 as [Hp1 H1]. induction H1 as [HU1 H1]. induction H2 as [V2 H2]. induction H2 as [Hp2 H2]. induction H2 as [HU2 H2]. use (hinhuniv _ H1); intro Hfg1. use (hinhuniv _ H2); intro Hfg2. induction Hfg1 as [f1 Hfg1]. induction Hfg1 as [g1 Hq1]. induction Hfg2 as [f2 Hfg2]. induction Hfg2 as [g2 Hq2]. apply hinhpr. exists (V1 ∩ V2). use make_dirprod. - exact (make_dirprod Hp1 Hp2). - use make_dirprod. + intros x Hx. apply (HU1 x), (dirprod_pr1 Hx). + apply hinhpr. exists (g2 * f1 + g1 * f2), (g1 * g2). intros q HVq. use (hinhuniv _ (Hq1 q (dirprod_pr1 HVq))); intro Hg1. use (hinhuniv _ (Hq2 q (dirprod_pr2 HVq))); intro Hg2. induction Hg1 as [Hg1 Heq1]. induction Hg2 as [Hg2 Heq2]. set (Hg := prime_ideal_ax1_contraposition (pr1 q) _ _ Hg1 Hg2). apply hinhpr. exists Hg. exact (map_on_two_paths op1 Heq1 Heq2 @ idpath _). Qed. Definition section_op1 : binop (section U) := λ s t, make_section _ (is_section_op1 s t). Lemma isassoc_section_op1 : isassoc section_op1. Proof. intros r s t. apply funext_section. intro p. simpl. apply (rigassoc1 (localization_at (pr1 p))). Qed. Lemma iscomm_section_op1 : iscomm section_op1. Proof. intros s t. apply funext_section. intro p. simpl. apply (rigcomm1 (localization_at (pr1 p))). Qed. Lemma is_section_unel1 : is_section (λ p : carrier U, @rigunel1 (localization_at (pr1 p))). Proof. intro p. apply hinhpr. exists U. use make_dirprod. - exact (pr2 p). - use make_dirprod. + intros x H. exact H. + apply hinhpr. exists 0, 1. intros q Hq. apply hinhpr. exists (prime_ideal_ax2 _). apply idpath. Qed. Definition section_unel1 : section U := make_section _ is_section_unel1. Lemma islunit_section_unel1 : islunit section_op1 section_unel1. Proof. intro s. apply funext_section. intro p. apply (riglunax1 (localization_at (pr1 p))). Qed. Lemma isrunit_section_unel1 : isrunit section_op1 section_unel1. Proof. apply (@weqlunitrunit section_hset). - exact iscomm_section_op1. - exact islunit_section_unel1. Qed. Lemma isunit_section_unel1 : isunit section_op1 section_unel1. Proof. exact (make_dirprod islunit_section_unel1 isrunit_section_unel1). Qed. Definition ismonoidop_section_op1 : ismonoidop section_op1 := make_ismonoidop isassoc_section_op1 (make_isunital section_unel1 isunit_section_unel1). Lemma is_section_inv (s : section U) : is_section (λ p, - s p). Proof. intro p. induction s as [s Hs]. use (hinhuniv _ (Hs p)); intro H. induction H as [V H]. induction H as [HVp H]. induction H as [HV H]. use (hinhuniv _ H); intro Hfg. induction Hfg as [f Hfg]. induction Hfg as [g Hfg]. apply hinhpr. exists V. use make_dirprod. - exact HVp. - use make_dirprod. + exact HV. + apply hinhpr. exists (-1 * f), g. intros q Hq. use (hinhuniv _ (Hfg q Hq)); intros Hg. induction Hg as [Hg Heq]. apply hinhpr. exists Hg. exact (maponpaths ringinv1 Heq @ idpath _). Qed. Definition section_inv : section U -> section U := λ s, make_section _ (is_section_inv s). Lemma islinv_section_inv : islinv section_op1 section_unel1 section_inv. Proof. intro s. apply funext_section. intro p. simpl. apply (ringlinvax1 (localization_at (pr1 p))). Qed. Lemma isrinv_section_inv : isrinv section_op1 section_unel1 section_inv. Proof. apply (@weqlinvrinv section_hset). - exact iscomm_section_op1. - exact islinv_section_inv. Qed. Lemma isinv_section_inv : isinv section_op1 section_unel1 section_inv. Proof. exact (make_isinv islinv_section_inv isrinv_section_inv). Qed. Definition invstruct_section_op1 : invstruct section_op1 ismonoidop_section_op1. Proof. use make_invstruct. - exact section_inv. - exact isinv_section_inv. Defined. Definition isgrop_section_op1 : isgrop section_op1 := make_isgrop ismonoidop_section_op1 invstruct_section_op1. Lemma is_section_op2 (s t : section U) : is_section (λ p, s p * t p). Proof. intros p. induction s as [s Hs]. induction t as [t Ht]. use (hinhuniv _ (Hs p)); intro H1. use (hinhuniv _ (Ht p)); intro H2. induction H1 as [V1 H1]. induction H1 as [Hp1 H1]. induction H1 as [HU1 H1]. induction H2 as [V2 H2]. induction H2 as [Hp2 H2]. induction H2 as [HU2 H2]. use (hinhuniv _ H1); intro Hfg1. use (hinhuniv _ H2); intro Hfg2. induction Hfg1 as [f1 Hfg1]. induction Hfg1 as [g1 Hq1]. induction Hfg2 as [f2 Hfg2]. induction Hfg2 as [g2 Hq2]. apply hinhpr. exists (V1 ∩ V2). use make_dirprod. + exact (make_dirprod Hp1 Hp2). + use make_dirprod. * intros x Hx. apply (HU1 x), (dirprod_pr1 Hx). * apply hinhpr. exists (f1 * f2), (g1 * g2). intros q HVq. use (hinhuniv _ (Hq1 q (dirprod_pr1 HVq))); intro Hg1. use (hinhuniv _ (Hq2 q (dirprod_pr2 HVq))); intro Hg2. induction Hg1 as [Hg1 Heq1]. induction Hg2 as [Hg2 Heq2]. set (Hg := prime_ideal_ax1_contraposition (pr1 q) _ _ Hg1 Hg2). apply hinhpr. exists Hg. exact (map_on_two_paths op2 Heq1 Heq2 @ idpath _). Qed. Definition section_op2 : binop (section U) := λ s t, make_section _ (is_section_op2 s t). Lemma isassoc_section_op2 : isassoc section_op2. Proof. intros r s t. apply funext_section. intro p. simpl. apply (rigassoc2 (localization_at (pr1 p))). Qed. Lemma iscomm_section_op2 : iscomm section_op2. Proof. intros s t. apply funext_section. intro p. simpl. apply (rigcomm2 (localization_at (pr1 p))). Qed. Lemma is_section_unel2 : is_section (λ p : carrier U, @rigunel2 (localization_at (pr1 p))). Proof. intro p. apply hinhpr. exists U. use make_dirprod. - exact (pr2 p). - use make_dirprod. + intros x H. exact H. + apply hinhpr. exists 1, 1. intros q Hq. apply hinhpr. exists (prime_ideal_ax2 _). apply idpath. Qed. Definition section_unel2 : section U := make_section _ is_section_unel2. Lemma islunit_section_unel2 : islunit section_op2 section_unel2. Proof. intro s. apply funext_section. intro p. apply (riglunax2 (localization_at (pr1 p))). Qed. Lemma isrunit_section_unel2 : isrunit section_op2 section_unel2. Proof. apply (@weqlunitrunit section_hset). - exact iscomm_section_op2. - exact islunit_section_unel2. Qed. Lemma isunit_section_unel2 : isunit section_op2 section_unel2. Proof. exact (make_dirprod islunit_section_unel2 isrunit_section_unel2). Qed. Definition ismonoidop_section_op2 : ismonoidop section_op2 := make_ismonoidop isassoc_section_op2 (make_isunital section_unel2 isunit_section_unel2). Lemma isldistr_section_ops : isldistr section_op1 section_op2. Proof. intros r s t. apply funext_section. intro p. simpl. apply (rigldistr (localization_at (pr1 p))). Qed. Lemma isrdistr_section_ops : isrdistr section_op1 section_op2. Proof. apply (@weqldistrrdistr section_hset). - exact iscomm_section_op2. - exact isldistr_section_ops. Qed. Lemma isdistr_section_ops : isdistr section_op1 section_op2. Proof. exact (isldistr_section_ops ,, isrdistr_section_ops). Qed. Definition section_commring : commring := @commringconstr section_hset section_op1 section_op2 isgrop_section_op1 iscomm_section_op1 ismonoidop_section_op2 iscomm_section_op2 isdistr_section_ops. End section_commring. Arguments section_hset {_} _. Arguments section_commring {_} _. (** *** Restriction of a section *) Section restriction. Context {R : commring} {U V : @Open (Spec R)} (H : V ⊆ U). Definition restriction_section_map : (∏ p : carrier U, localization_at (pr1 p)) -> (∏ p : carrier V, localization_at (pr1 p)) := λ s p, s (pr1 p ,, H (pr1 p) (pr2 p)). Lemma is_section_restriction_section_map (s : section U) : is_section (restriction_section_map s). Proof. intro p. induction p as [p HVp]. induction s as [s Hs]. use (hinhuniv _ (Hs (p ,, (H _ HVp)))); intro HW. induction HW as [W HW]. induction HW as [HWp HW]. induction HW as [HUW Hfg]. use (hinhfun _ Hfg); intro Hq. induction Hq as [f Hq]. induction Hq as [g Hq]. exists (V ∩ W). use make_dirprod. - exact (make_dirprod HVp HWp). - use make_dirprod. + intros x Hx. exact (dirprod_pr1 Hx). + apply hinhpr. exists f, g. intros q H0. induction q as [q HVq]. use (hinhfun _ (Hq (q ,, H _ HVq) (dirprod_pr2 H0))); intro Hg. induction Hg as [Hg Heq]. exists Hg. exact Heq. Qed. Definition restriction_section : section U -> section V := λ s, make_section _ (is_section_restriction_section_map s). (* The [restriction_section] map is a ring homomorphism. *) Lemma isaddmonoidfun_restriction_section : @ismonoidfun (rigaddabmonoid (section_commring U)) (rigaddabmonoid (section_commring V)) restriction_section. Proof. use make_ismonoidfun. - intros s t. apply subtypePath_prop, idpath. - apply subtypePath_prop, idpath. Qed. Lemma ismultmonoidfun_restriction_section : @ismonoidfun (rigmultmonoid (section_commring U)) (rigmultmonoid (section_commring V)) restriction_section. Proof. use make_ismonoidfun. - intros s t. apply subtypePath_prop, idpath. - apply subtypePath_prop, idpath. Qed. Lemma isringfun_restriction_section : @isringfun (section_commring U) (section_commring V) restriction_section. Proof. use make_isrigfun. - exact isaddmonoidfun_restriction_section. - exact ismultmonoidfun_restriction_section. Qed. Definition restriction_ringfun : ringfun (section_commring U) (section_commring V) := rigfunconstr isringfun_restriction_section. End restriction. Section restriction_facts. Context {R : commring} {U V : @Open (Spec R)}. Lemma restriction_paths (H : V ⊆ U) (s : section U) {p : Spec R} (HUp : U p) (HVp : V p) : restriction_section H s (p ,, HVp) = s (p ,, HUp). Proof. induction (proofirrelevance_hProp _ (H _ HVp) HUp). apply idpath. Qed. Lemma section_subset {H : V ⊆ U} {s t : section U} : restriction_section H s = restriction_section H t -> ∏ p : carrier U, V (pr1 p) -> s p = t p. Proof. intros Heq p HVp. apply (@pathscomp0 _ _ (restriction_section H s (pr1 p ,, HVp))). - apply pathsinv0, restriction_paths. - apply (@pathscomp0 _ _ (restriction_section H t (pr1 p ,, HVp))). + induction Heq. apply idpath. + apply restriction_paths. Qed. Lemma section_intersection (s : section U) (t : section V) : restriction_section (intersection_contained1 U V) s = restriction_section (intersection_contained2 U V) t -> ∏ p (HUp : U p) (HVp : V p), s (p ,, HUp) = t (p ,, HVp). Proof. intros Heq p HUp HVp. set (Hp := make_dirprod HUp HVp). assert (H : restriction_section (intersection_contained1 U V) s (p ,, Hp) = restriction_section (intersection_contained2 U V) t (p ,, Hp)). { induction Heq. apply idpath. } apply H. Qed. End restriction_facts. (** *** Definition of the structure sheaf *) Section structure_sheaf. Context (R : commring). (* presheaf *) Definition structure_presheaf_data : functor_data (open_category (Spec R))^op commring_precategory. Proof. use make_functor_data. - exact section_commring. - exact (@restriction_ringfun R). Defined. Lemma is_functor_structure_presheaf_data : is_functor structure_presheaf_data. Proof. use make_dirprod. - intro U. apply rigfun_paths, funextsec. intro s. apply subtypePath_prop, idpath. - intros U V W f g. apply rigfun_paths, funextsec. intro s. apply subtypePath_prop, idpath. Qed. Definition structure_presheaf : (open_category (Spec R))^op ⟶ commring_precategory := make_functor structure_presheaf_data is_functor_structure_presheaf_data. (* locality *) Lemma locality_structure_presheaf : locality structure_presheaf. Proof. intros A s t H. apply funext_section. intro p. use (hinhuniv _ (hexists_open_neighborhood p)); intro HU. induction HU as [U HUp]. apply (section_subset (H U)), HUp. Qed. (* gluing *) Definition agree_on_intersections_section {A : hsubtype (@Open (Spec R))} (g : ∏ U : A, section_commring (pr1 U)) : UU := ∏ U V : A, restriction_section (intersection_contained1 _ _) (g U) = restriction_section (intersection_contained2 _ _) (g V). Definition glue_sections {A : hsubtype (@Open (Spec R))} (g : ∏ U : A, section_commring (pr1 U)) (Hg : agree_on_intersections_section g) (H : ∏ p : carrier (⋃ A), ∑ U : A, pr1 U (pr1 p)) : section_commring (⋃ A). Proof. use make_section; intro x; induction (H x) as [U HUx]; set (s := g U); set (p := make_carrier _ _ HUx). - exact (section_map s p). - use (hinhfun _ (section_prop s p)); intro H1. induction H1 as [V HV]. induction HV as [HVp HV]. induction HV as [HVU HV]. exists V. apply make_dirprod. + exact HVp. + apply make_dirprod. * apply (subtype_containment_istrans _ _ _ _ HVU), contained_in_union_open. * use (hinhfun _ HV). intro H2. induction H2 as [f Hh]. induction Hh as [h H3]. exists f, h. intros q HVq. induction q as [q Hq]. use (hinhfun _ (H3 (q ,, HVU q HVq) HVq)); intro H4. induction H4 as [Hh Heq]. exists Hh. use (pathscomp0 _ Heq). simpl. apply section_intersection. apply Hg. Defined. Lemma gluing_structure_presheaf (ac : AxiomOfChoice) : gluing structure_presheaf. Proof. intros A g Hg. set (H0 := ac (carrier_subset (⋃ A)) _ (@hexists_open_neighborhood _ A)). use (hinhfun _ H0); intro H. exists (glue_sections g Hg H). intro U. apply funext_section. intro q. induction q as [q HUq]. cbn. apply section_intersection, Hg. Qed. (* structure sheaf *) Definition structure_sheaf (ac : AxiomOfChoice) : sheaf_commring (Spec R) := make_sheaf_commring structure_presheaf locality_structure_presheaf (gluing_structure_presheaf ac). End structure_sheaf. UniMath-20231010/UniMath/AlgebraicGeometry/Topology.v000066400000000000000000000037731451125700300222560ustar00rootroot00000000000000(* Additional definitions and facts from topology. Maybe this should go in UniMath.Topology. *) Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.Topology.Topology. Local Open Scope subtype. Section union. Context {X : TopologicalSpace}. Definition union_open_hsubtype (A : hsubtype Open) : hsubtype X := union (λ U, ∃ H : isOpen U, A (U ,, H)). Lemma is_open_union_open_hsubtype (A : hsubtype Open) : isOpen (union_open_hsubtype A). Proof. apply isOpen_union. intros U HU. use (hinhuniv _ HU); intros H. exact (pr1 H). Qed. Definition union_open (A : hsubtype Open) : Open := union_open_hsubtype A ,, is_open_union_open_hsubtype A. End union. Declare Scope open_scope. Delimit Scope open_scope with open. Open Scope open. Notation "⋃ S" := (union_open S) (at level 100, no associativity) : open_scope. Section union_facts. Context {X : TopologicalSpace} {A : hsubtype (@Open X)}. Lemma contained_in_union_open (U : A) : pr1 U ⊆ ⋃ A. Proof. intros x Hx. apply hinhpr. exists (pr1 U). use make_dirprod. - apply hinhpr. exists (pr21 U). exact (pr2 U). - exact Hx. Qed. Lemma hexists_open_neighborhood (p : carrier (⋃ A)): ∃ U : A, pr1 U (pr1 p). Proof. induction p as [p Hp]. simpl in Hp. use (hinhuniv _ Hp); intro Hu. induction Hu as [u Hu]. induction Hu as [Hu Hup]. use (hinhfun _ Hu); intro H. induction H as [H HUu]. exists (make_carrier _ _ HUu). exact Hup. Qed. End union_facts. Definition binary_intersection_open {X : TopologicalSpace} (u v : @Open X) : Open := (λ x : X, u x ∧ v x) ,, isOpen_and _ _ (pr2 u) (pr2 v). Notation "u ∩ v" := (binary_intersection_open u v) (at level 40, left associativity) : open_scope. Section intersection_facts. Context {X : TopologicalSpace} (u v : @Open X). Definition intersection_contained1 : (u ∩ v) ⊆ u := λ _ Hx, pr1 Hx. Definition intersection_contained2 : (u ∩ v) ⊆ v := λ _ Hx, pr2 Hx. End intersection_facts. UniMath-20231010/UniMath/AlgebraicTheories/000077500000000000000000000000001451125700300202305ustar00rootroot00000000000000UniMath-20231010/UniMath/AlgebraicTheories/.package/000077500000000000000000000000001451125700300217015ustar00rootroot00000000000000UniMath-20231010/UniMath/AlgebraicTheories/.package/files000066400000000000000000000006671451125700300227370ustar00rootroot00000000000000FiniteSetSkeleton.v AlgebraicTheories2.v AlgebraicTheories.v AlgebraicTheoryMorphisms2.v AlgebraicTheoryMorphisms.v AlgebraicTheoryCategory.v AlgebraicTheoryAlgebras.v AlgebraicTheoryAlgebraMorphisms.v AlgebraicTheoryAlgebraCategory.v AlgebraicTheoryAlgebraFibration.v Examples/OnePointTheory.v Examples/ProjectionsTheory.v Examples/EndomorphismTheory.v Examples/FreeMonoidTheory.v AlgebraicTheoryAlgebraWeqEndomorphismTheoryMorphism.v UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheories.v000066400000000000000000000227741451125700300240070ustar00rootroot00000000000000(* These objects are known by many names: algebraic theories, abstract clones, cartesian operads and lawvere theories. This file defines them, gives two ways of constructing them, gives corresponding accessors of the data and some derived properties and provides an equality lemma. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.AlgebraicTheories.FiniteSetSkeleton. Require Import UniMath.AlgebraicTheories.AlgebraicTheories2. Declare Scope algebraic_theories. Local Open Scope cat. Local Open Scope algebraic_theories. Definition base_functor : UU := finite_set_skeleton_category ⟶ HSET. Coercion base_functor_to_functor (T : base_functor) : finite_set_skeleton_category ⟶ HSET := T. Definition pointed_functor : UU := ∑ (T : base_functor), (T 1 : hSet). Coercion pointed_functor_to_base_functor (T : pointed_functor) : base_functor := pr1 T. Definition id_pr {T : pointed_functor} : (T 1 : hSet) := pr2 T. (* Accessor for the projections *) Definition pr {T : pointed_functor} {n : nat} (i : stn n) : (T n : hSet) := # T (λ _, i) id_pr. Definition algebraic_theory_data : UU := ∑ (T : pointed_functor), ∏ m n, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet). Coercion algebraic_theory_data_to_pointed_functor (T : algebraic_theory_data) : pointed_functor := pr1 T. (* Accessor for the composition *) Definition comp {T : algebraic_theory_data} {m n : nat} : ((T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)) := pr2 T m n. Notation "f • g" := (comp f g) (at level 35) : algebraic_theories. Definition comp_is_assoc (T : algebraic_theory_data) : UU := ∏ (l m n : nat) (f_l : (T l : hSet)) (f_m : stn l → T m : hSet) (f_n : stn m → T n : hSet), (f_l • f_m) • f_n = f_l • (λ t_l, (f_m t_l) • f_n). Definition comp_is_unital (T : algebraic_theory_data) : UU := ∏ (n : nat) (f : (T n : hSet)), id_pr • (λ _, f) = f. Definition comp_identity_projections (T : algebraic_theory_data) : UU := ∏ (n : nat) (f : (T n : hSet)), f • (λ i, pr i) = f. Definition comp_is_natural_l (T : algebraic_theory_data) : UU := ∏ (m m' n : finite_set_skeleton_category) (a : finite_set_skeleton_category⟦m, m'⟧) (f : (T m : hSet)) (g : stn m' → T n : hSet), (# T a f) • g = f • (λ i, g (a i)). Definition is_algebraic_theory (T : algebraic_theory_data) : UU := comp_is_assoc T × comp_is_unital T × comp_identity_projections T × comp_is_natural_l T. Definition algebraic_theory : UU := ∑ (T : algebraic_theory_data), is_algebraic_theory T. Coercion algebraic_theory_to_algebraic_theory_data (T : algebraic_theory) : algebraic_theory_data := pr1 T. (* Constructors for the algebraic theory type *) Definition make_algebraic_theory_data (T : base_functor) (id_pr : (T 1 : hSet)) (comp : ∏ m n, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)) : algebraic_theory_data := ((T ,, id_pr) ,, comp). Definition make_is_algebraic_theory (T : algebraic_theory_data) (H1 : comp_is_assoc T) (H2 : comp_is_unital T) (H3 : comp_identity_projections T) (H4 : comp_is_natural_l T) : is_algebraic_theory T := (H1 ,, H2 ,, H3 ,, H4). Definition make_algebraic_theory (T : algebraic_theory_data) (H : is_algebraic_theory T) : algebraic_theory := T ,, H. Section MakeAlgebraicTheory'. Definition algebraic_theory'_to_functor_data (C : algebraic_theory') : functor_data finite_set_skeleton_category HSET. Proof. use make_functor_data. - exact C. - exact (λ _ _ a f, comp' f (λ i, pr' (a i))). Defined. Lemma algebraic_theory'_to_is_functor (C : algebraic_theory') : is_functor (algebraic_theory'_to_functor_data C). Proof. apply tpair. - intro. apply funextfun. intro. apply algebraic_theory'_comp_identity_projections. - intros l m n f g. apply funextfun. intro h. rewrite (algebraic_theory'_comp_is_assoc _ _ _ _ _ _ _ : (_ · (# (algebraic_theory'_to_functor_data C) g)) _ = _). apply (maponpaths (comp' h)), funextfun. intro. symmetry. apply algebraic_theory'_comp_project_component. Qed. Definition algebraic_theory'_to_algebraic_theory_data (C : algebraic_theory') : algebraic_theory_data. Proof. use make_algebraic_theory_data. - exact (make_functor _ (algebraic_theory'_to_is_functor C)). - exact (pr' firstelement). - exact (λ _ _, comp'). Defined. Lemma algebraic_theory'_to_is_algebraic_theory (C : algebraic_theory') : is_algebraic_theory (algebraic_theory'_to_algebraic_theory_data C). Proof. use make_is_algebraic_theory. - apply algebraic_theory'_comp_is_assoc. - do 2 intro. apply algebraic_theory'_comp_project_component. - do 2 intro. rewrite <- algebraic_theory'_comp_identity_projections. apply maponpaths, funextfun. intro. apply algebraic_theory'_comp_project_component. - do 6 intro. simpl. rewrite (algebraic_theory'_comp_is_assoc C). apply maponpaths, funextfun. intro. apply algebraic_theory'_comp_project_component. Qed. Definition make_algebraic_theory' (C : algebraic_theory'_data) (H : is_algebraic_theory' C) : algebraic_theory := make_algebraic_theory _ (algebraic_theory'_to_is_algebraic_theory (C ,, H)). End MakeAlgebraicTheory'. Lemma isaprop_is_algebraic_theory (T : algebraic_theory_data) : isaprop (is_algebraic_theory T). Proof. repeat apply isapropdirprod; repeat (apply impred_isaprop; intro); apply setproperty. Qed. Definition algebraic_theory_comp_is_assoc (T : algebraic_theory) : comp_is_assoc T := pr12 T. Definition algebraic_theory_comp_is_unital (T : algebraic_theory) : comp_is_unital T := pr122 T. Definition algebraic_theory_comp_identity_projections (T : algebraic_theory) : comp_identity_projections T := pr1 (pr222 T). Definition algebraic_theory_comp_is_natural_l (T : algebraic_theory) : comp_is_natural_l T := pr2 (pr222 T). Lemma algebraic_theory_eq (X Y : algebraic_theory) (H1 : (X : nat → hSet) = (Y : nat → hSet)) (H2 : transportf (λ T : nat → hSet, ∏ m n : nat, (stn m → stn n) → T m → T n) H1 (@functor_on_morphisms _ _ X) = (@functor_on_morphisms _ _ Y)) (H3 : transportf (λ (T : nat → hSet), T 1) H1 id_pr = id_pr) (H4 : transportf (λ (T : nat → hSet), ∏ m n : nat, T m → (stn m → T n) → T n) H1 (@comp X) = (@comp Y)) : X = Y. Proof. use (subtypePairEquality' _ (isaprop_is_algebraic_theory _)). use total2_paths_f. - use total2_paths_f. + apply (functor_eq _ _ (homset_property HSET)). exact (total2_paths_f H1 H2). + unfold functor_eq. rewrite (@transportf_total2_paths_f (functor_data finite_set_skeleton_category HSET) (λ T, is_functor T) (λ T, T 1 : hSet) ). rewrite (@transportf_total2_paths_f (nat → hSet) (λ T, ∏ m n, (stn m → stn n) → T m → T n) (λ T, T 1) ). exact H3. - unfold functor_eq. rewrite (@transportf_total2_paths_f base_functor (λ T, T 1 : hSet) (λ (T : base_functor), ∏ m n : nat, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)) ). rewrite (@transportf_total2_paths_f (functor_data finite_set_skeleton_category HSET) (λ T, is_functor T) (λ (T : functor_data _ _), ∏ m n : nat, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)) ). rewrite (@transportf_total2_paths_f (nat → hSet) (λ T, ∏ m n, (stn m → stn n) → T m → T n) (λ (T : nat → hSet), ∏ m n : nat, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)) ). exact H4. Qed. Definition lift_constant {T : algebraic_theory_data} (n : nat) (f : (T 0 : hSet)) : (T n : hSet) := f • (weqvecfun _ vnil). (* Properties of algebraic theories *) Lemma algebraic_theory_functor_uses_projections (T : algebraic_theory) (m n : finite_set_skeleton_category) (a : finite_set_skeleton_category⟦m, n⟧) (f : T m : hSet) : #T a f = f • (λ i, pr (a i)). Proof. rewrite <- (algebraic_theory_comp_identity_projections _ _ (#T _ _)). apply algebraic_theory_comp_is_natural_l. Qed. Lemma algebraic_theory_comp_projects_component (T : algebraic_theory) (m n : nat) (i : stn m) (f : stn m → T n : hSet) : (pr i) • f = f i. Proof. unfold pr. rewrite algebraic_theory_comp_is_natural_l. apply algebraic_theory_comp_is_unital. Qed. Lemma algebraic_theory_comp_is_natural_r (T : algebraic_theory) (m n n' : finite_set_skeleton_category) (a: finite_set_skeleton_category⟦n, n'⟧) (f : (T m : hSet)) (g : stn m → (T n : hSet)) : f • (λ i, #T a (g i)) = #T a (f • g). Proof. rewrite algebraic_theory_functor_uses_projections. rewrite algebraic_theory_comp_is_assoc. apply maponpaths, funextfun. intro. apply algebraic_theory_functor_uses_projections. Qed. Lemma algebraic_theory_id_pr_is_pr (T : algebraic_theory) : id_pr = pr (T := T) (@firstelement 0). Proof. unfold pr. assert (H : identity (1 : finite_set_skeleton_category) = (λ _, firstelement)). { apply funextfun. intro. use (subtypePairEquality' _ (isasetbool _ _)). exact (natlth1tois0 _ (stnlt x)). } rewrite <- H. now rewrite (functor_id T). Qed. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheories2.v000066400000000000000000000050061451125700300240560ustar00rootroot00000000000000(* Defines a type for passing data to make_algebraic_theory' in AlgebraicTheories.v. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Definition algebraic_theory'_data := ∑ (C : nat → hSet), (∏ n, stn n → C n) × (∏ m n, C m → (stn m → C n) → C n). Definition make_algebraic_theory'_data (C : nat → hSet) (pr : ∏ n, stn n → C n) (comp : ∏ m n, C m → (stn m → C n) → C n) : algebraic_theory'_data. Proof. exact (C ,, pr ,, comp). Defined. Definition algebraic_theory'_data_to_function (C : algebraic_theory'_data) : nat → hSet := pr1 C. Coercion algebraic_theory'_data_to_function : algebraic_theory'_data >-> Funclass. Definition pr' {C : algebraic_theory'_data} {n} : stn n → C n := pr12 C n. Definition comp' {C : algebraic_theory'_data} {m n} : C m → (stn m → C n) → C n := pr22 C m n. (* Define the unitality property of the algebraic theory *) Definition comp_project_component (C : algebraic_theory'_data) : UU := ∏ (m n : nat) (i : stn m) (f : stn m → C n), comp' (pr' i) f = f i. (* Define the compatibility of the projection function with composition *) Definition comp_identity_projections (C : algebraic_theory'_data) : UU := ∏ (n : nat) (f : C n), comp' f (λ i, pr' i) = f. (* Define the associativity property of the algebraic theory *) Definition comp_is_assoc (C : algebraic_theory'_data) : UU := ∏ (l m n : nat) (f_l : C l) (f_m : stn l → C m) (f_n : stn m → C n), comp' (comp' f_l f_m) f_n = comp' f_l (λ t_l, comp' (f_m t_l) f_n). Definition is_algebraic_theory' (C : algebraic_theory'_data) := (comp_project_component C) × (comp_identity_projections C) × (comp_is_assoc C). Definition make_is_algebraic_theory' (C : algebraic_theory'_data) (H1 : comp_project_component C) (H2 : comp_identity_projections C) (H3 : comp_is_assoc C) : is_algebraic_theory' C := (H1 ,, H2 ,, H3). Definition algebraic_theory' := ∑ C, is_algebraic_theory' C. Coercion algebraic_theory'_data_from_algebraic_theory' (C : algebraic_theory') : algebraic_theory'_data := pr1 C. Definition algebraic_theory'_comp_project_component (C : algebraic_theory') : comp_project_component C := pr12 C. Definition algebraic_theory'_comp_identity_projections (C : algebraic_theory') : comp_identity_projections C := pr122 C. Definition algebraic_theory'_comp_is_assoc (C : algebraic_theory') : comp_is_assoc C := pr222 C. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryAlgebraCategory.v000066400000000000000000000141011451125700300264340ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Examples. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryCategory. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebraMorphisms. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope cat. Local Open Scope algebraic_theories. Definition algebraic_theory_algebra_data_full_disp_cat : disp_cat (cartesian algebraic_theory_cat HSET). Proof. use disp_struct. - intro X. pose (T := pr1 X : algebraic_theory). pose (A := pr2 X : hSet). exact (∏ n, (T n : hSet) → (stn n → A) → A). - intros X X' action action' Y. pose (A := make_algebraic_theory_algebra_data (pr2 X) action). pose (A' := make_algebraic_theory_algebra_data (pr2 X') action'). pose (F := pr1 Y : algebraic_theory_morphism _ _). pose (G := pr2 Y : A → A'). exact (∏ n f a, G (action n f a) = action' n (F _ f) (λ i, G (a i))). - abstract ( intros; do 3 (apply impred_isaprop; intro); apply setproperty ). - abstract ( intros X action n f a; now rewrite ((eqtohomot (transportf_const _ ((pr2 X : hSet) → (pr2 X : hSet))) _) : pr2 (identity X) = identity _) ). - abstract ( intros X X' X'' action action' action'' y y' Gcommutes G'commutes n f a; rewrite ((eqtohomot (transportf_const _ ((pr2 X : hSet) → (pr2 X'' : hSet))) _) : pr2 (y · y') = ((pr2 y) : HSET⟦_, _⟧) · (pr2 y')); unfold compose; simpl; now rewrite Gcommutes, G'commutes ). Defined. Definition algebraic_theory_algebra_data_full_cat : category := total_category algebraic_theory_algebra_data_full_disp_cat. Definition algebraic_theory_algebra_full_disp_cat : disp_cat algebraic_theory_algebra_data_full_cat := disp_full_sub algebraic_theory_algebra_data_full_cat (λ X, is_algebraic_theory_algebra (make_algebraic_theory_algebra_data (pr21 X) (pr2 X))). Definition algebraic_theory_algebra_full_cat : category := total_category algebraic_theory_algebra_full_disp_cat. Definition algebraic_theory_algebra_disp_cat : disp_cat algebraic_theory_cat := sigma_disp_cat (sigma_disp_cat algebraic_theory_algebra_full_disp_cat). Definition algebraic_theory_algebra_cat (T : algebraic_theory) := fiber_category algebraic_theory_algebra_disp_cat T. Lemma displayed_algebra_morphism_eq {T T' : algebraic_theory} {F : algebraic_theory_morphism T T'} {A : algebraic_theory_algebra T} {A' : algebraic_theory_algebra T'} (G G' : (A : algebraic_theory_algebra_disp_cat _) -->[F] A') (H : pr1 G = pr1 G') : G = G'. Proof. apply (subtypePairEquality' H). use (isapropdirprod _ _ _ isapropunit). repeat (apply impred_isaprop; intro). apply setproperty. Qed. Lemma is_univalent_disp_algebraic_theory_algebra_data_full_disp_cat : is_univalent_disp algebraic_theory_algebra_data_full_disp_cat. Proof. apply is_univalent_disp_iff_fibers_are_univalent. intros TA action action'. use isweq_iso. - intro f. do 3 (apply funextsec; intro). pose (H := pr1 f x x0 x1). refine (!_ @ H @ maponpaths (action' x x0) _). + refine (maponpaths (λ a, a (action x x0 x1)) (transportf_set _ _ _ _)). exact (isasetaprop (isasetunit _ _)). + apply funextfun. intro. refine (maponpaths (λ a, a (x1 _)) (transportf_set _ _ _ _)). exact (isasetaprop (isasetunit _ _)). - intro. do 3 (apply impred_isaset; intro). apply setproperty. - intro. apply z_iso_eq. do 3 (apply impred_isaprop; intro). apply setproperty. Qed. Lemma is_univalent_algebraic_theory_algebra_data_full_cat : is_univalent algebraic_theory_algebra_data_full_cat. Proof. use is_univalent_total_category. - rewrite cartesian_is_binproduct. exact (is_univalent_category_binproduct is_univalent_algebraic_theory_cat is_univalent_HSET). - exact is_univalent_disp_algebraic_theory_algebra_data_full_disp_cat. Qed. Lemma is_univalent_disp_algebraic_theory_algebra_full_disp_cat : is_univalent_disp algebraic_theory_algebra_full_disp_cat. Proof. apply disp_full_sub_univalent. exact (λ _, isaprop_is_algebraic_theory_algebra _). Qed. Lemma is_univalent_algebraic_theory_algebra_full_cat : is_univalent algebraic_theory_algebra_full_cat. Proof. apply (is_univalent_total_category is_univalent_algebraic_theory_algebra_data_full_cat). exact is_univalent_disp_algebraic_theory_algebra_full_disp_cat. Qed. Lemma is_univalent_algebraic_theory_algebra_cat (T : algebraic_theory) : is_univalent (algebraic_theory_algebra_cat T). Proof. refine (is_univalent_fiber_cat _ _ _). unfold algebraic_theory_algebra_disp_cat. repeat use is_univalent_sigma_disp. - apply is_univalent_reindex_disp_cat. apply is_univalent_disp_disp_over_unit. exact is_univalent_HSET. - exact is_univalent_disp_algebraic_theory_algebra_data_full_disp_cat. - exact is_univalent_disp_algebraic_theory_algebra_full_disp_cat. Qed. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryAlgebraFibration.v000066400000000000000000000121701451125700300266000ustar00rootroot00000000000000(* Shows that algebraic theory algebras are fibered over algebraic theories. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Examples. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryCategory. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebraCategory. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Local Open Scope cat. Local Open Scope mor_disp. Lemma concat_displayed_cartesian_morphisms {C C' : category} (D := disp_cartesian C C') {c c' c'' : C} {F : C⟦c, c'⟧} {F' : C⟦c', c''⟧} {A : D c} {A' : D c'} {A'' : D c''} (G : A -->[F] A') (G' : A' -->[F'] A'') : (G ;; G') = G · G'. Proof. unfold comp_disp. simpl. unfold transportb. rewrite transportf_set. - apply idpath. - apply isasetaprop, isasetunit. Qed. Definition algebra_cleaving_algebra_data {T T' : algebraic_theory} (F : algebraic_theory_morphism T' T) (A : algebraic_theory_algebra T) : algebraic_theory_algebra_data T'. Proof. use tpair. - exact A. - intros n f a. exact (action (F _ f) a). Defined. Lemma algebra_cleaving_is_algebra {T T' : algebraic_theory} (F : algebraic_theory_morphism T' T) (A : algebraic_theory_algebra T) : is_algebraic_theory_algebra (algebra_cleaving_algebra_data F A). Proof. use (_ ,, _ ,, _). - do 5 intro. simpl. rewrite (algebraic_theory_morphism_preserves_composition F). apply algebraic_theory_algebra_is_assoc. - intro. rewrite <- algebraic_theory_algebra_is_unital. simpl. apply (maponpaths (λ i, _ _ i _)). apply algebraic_theory_morphism_preserves_id_pr. - do 5 intro. simpl. rewrite (maponpaths (λ x, x _) (nat_trans_ax (F : algebraic_theory_morphism _ _) _ _ _ : (λ x, _ _ (# (T' : algebraic_theory) _ _)) = _)). apply algebraic_theory_algebra_is_natural. Qed. Definition algebra_cleaving_algebra {T T' : algebraic_theory} (F : algebraic_theory_morphism T' T) (A : algebraic_theory_algebra T) : algebraic_theory_algebra T' := make_algebraic_theory_algebra _ (algebra_cleaving_is_algebra F A). Definition algebra_cleaving_morphism {T T' : algebraic_theory} (F : algebraic_theory_morphism T' T) (A : algebraic_theory_algebra T) : (algebra_cleaving_algebra F A : algebraic_theory_algebra_disp_cat _) -->[F] A. Proof. use (idfun _ ,, _ ,, tt). abstract now do 3 intro. Defined. Definition algebra_cleaving_induced_morphism {T T' T'' : algebraic_theory} {A : algebraic_theory_algebra T} {A'' : algebraic_theory_algebra T''} (F : algebraic_theory_morphism T' T) (F' : algebraic_theory_morphism T'' T') (G' : (A'' : algebraic_theory_algebra_disp_cat _) -->[(F' : algebraic_theory_cat⟦_, _⟧) · F] A) : (A'' : algebraic_theory_algebra_disp_cat _) -->[F'] algebra_cleaving_algebra F A. Proof. use (pr1 G' ,, _ ,, tt). abstract (do 3 intro; now rewrite (pr12 G')). Defined. Definition algebra_lift {T T' T'' : algebraic_theory} {A : algebraic_theory_algebra T} {A'' : algebraic_theory_algebra T''} (F : algebraic_theory_morphism T' T) (F' : algebraic_theory_morphism T'' T') (G' : (A'' : algebraic_theory_algebra_disp_cat _) -->[(F' : algebraic_theory_cat⟦_, _⟧) · F] A) : ∑ gg, (gg ;; algebra_cleaving_morphism F A) = G'. Proof. exists (algebra_cleaving_induced_morphism F F' G'). apply displayed_algebra_morphism_eq. exact (concat_displayed_cartesian_morphisms _ _). Defined. Lemma algebra_lift_is_unique {T T' T'' : algebraic_theory} {A : algebraic_theory_algebra T} {A'' : algebraic_theory_algebra T''} (F : algebraic_theory_morphism T' T) (F' : algebraic_theory_morphism T'' T') (G' : (A'' : algebraic_theory_algebra_disp_cat _) -->[(F' : algebraic_theory_cat⟦_, _⟧) · F] A) : ∏ t : (∑ gg, (gg ;; algebra_cleaving_morphism F A) = G'), t = (algebra_lift F F' G'). Proof. intro. apply subtypePairEquality'. + apply displayed_algebra_morphism_eq. exact (!concat_displayed_cartesian_morphisms (pr11 t) _ @ maponpaths _ (pr2 t)). + apply homsets_disp. Qed. Definition algebra_cleaving_is_cartesian {T T' : algebraic_theory} (F : algebraic_theory_morphism T' T) (A : algebraic_theory_algebra T) : is_cartesian (algebra_cleaving_morphism F A) := (λ _ F' _ G', algebra_lift F F' G' ,, algebra_lift_is_unique F F' G'). Definition algebra_cleaving : cleaving algebraic_theory_algebra_disp_cat := λ _ _ F A, algebra_cleaving_algebra F A ,, algebra_cleaving_morphism F A ,, algebra_cleaving_is_cartesian F A. Definition algebra_fibration : fibration algebraic_theory_cat := _ ,, algebra_cleaving. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryAlgebraMorphisms.v000066400000000000000000000026711451125700300266510ustar00rootroot00000000000000(* Defines morphisms of algebraic theory algebras. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Definition preserves_action {T : algebraic_theory_data} {A A' : algebraic_theory_algebra_data T} (F : A → A') : UU := ∏ n f (a : stn n → A), F (action f a) = action f (λ i, F (a i)). Definition algebraic_theory_algebra_morphism {T : algebraic_theory_data} (A A' : algebraic_theory_algebra_data T) : UU := ∑ (F : A → A') (H : preserves_action F), unit. Definition algebraic_theory_algebra_morphism_to_function {T : algebraic_theory_data} {A A' : algebraic_theory_algebra_data T} (F : algebraic_theory_algebra_morphism A A') : A → A' := pr1 F. Coercion algebraic_theory_algebra_morphism_to_function : algebraic_theory_algebra_morphism >-> Funclass. Definition algebraic_theory_algebra_morphism_preserves_action {T : algebraic_theory_data} {A A' : algebraic_theory_algebra_data T} (F : algebraic_theory_algebra_morphism A A') : preserves_action F := pr12 F. Lemma isaprop_preserves_action {T : algebraic_theory_data} {A A' : algebraic_theory_algebra_data T} (F : A → A') : isaprop (preserves_action F). Proof. repeat (apply impred_isaprop; intro). apply setproperty. Qed. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryAlgebraWeqEndomorphismTheoryMorphism.v000066400000000000000000000071151451125700300327210ustar00rootroot00000000000000(* Shows that, given an algebraic theory T, there is an equivalence between its algebras and tuples of a set X and a morphism from T to the endomorphism theory on X. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms2. Require Import UniMath.AlgebraicTheories.Examples.EndomorphismTheory. Definition algebra_to_algebraic_theory_morphism'_data {T : algebraic_theory} (X : algebraic_theory_algebra T) : algebraic_theory_morphism'_data T (set_endomorphism_theory X) := @action T X. Lemma algebra_to_is_algebraic_theory_morphism' {T : algebraic_theory} (X : algebraic_theory_algebra T) : is_algebraic_theory_morphism' (algebra_to_algebraic_theory_morphism'_data X). Proof. use make_is_algebraic_theory_morphism'. - do 4 intro. apply funextfun. intro. apply algebraic_theory_algebra_is_assoc. - intros n i. apply funextfun. intro. apply (algebraic_theory_algebra_projects_component _ _ i). Qed. Definition algebra_to_algebraic_theory_morphism {T : algebraic_theory} (X : algebraic_theory_algebra T) : algebraic_theory_morphism T (set_endomorphism_theory X) := make_algebraic_theory_morphism' _ (algebra_to_is_algebraic_theory_morphism' X). Definition algebraic_theory_morphism_to_algebra_data {T : algebraic_theory} {X : hSet} (F : algebraic_theory_morphism T (set_endomorphism_theory X)) : algebraic_theory_algebra_data T := make_algebraic_theory_algebra_data X F. Lemma algebraic_theory_morphism_to_is_algebra {T : algebraic_theory} {X : hSet} (F : algebraic_theory_morphism T (set_endomorphism_theory X)) : is_algebraic_theory_algebra (algebraic_theory_morphism_to_algebra_data F). Proof. use make_is_algebraic_theory_algebra'. - do 5 intro. simpl. now rewrite (algebraic_theory_morphism_preserves_composition F). - do 3 intro. simpl. now rewrite (algebraic_theory_morphism_preserves_projections F). Qed. Definition algebraic_theory_morphism_to_algebra {T : algebraic_theory} {X : hSet} (F : algebraic_theory_morphism T (set_endomorphism_theory X)) : algebraic_theory_algebra T := make_algebraic_theory_algebra _ (algebraic_theory_morphism_to_is_algebra F). Lemma algebra_to_algebraic_theory_morphism_and_back {T : algebraic_theory} (A : algebraic_theory_algebra T) : algebraic_theory_morphism_to_algebra (algebra_to_algebraic_theory_morphism A) = A. Proof. simpl. use algebraic_theory_algebra_eq. + apply idpath. + now intro. Qed. Lemma algebraic_theory_morphism_to_algebra_and_back {T : algebraic_theory} (y : ∑ X, algebraic_theory_morphism T (set_endomorphism_theory X)) : pr1 y ,, algebra_to_algebraic_theory_morphism (algebraic_theory_morphism_to_algebra (pr2 y)) = y. Proof. use total2_paths2_f. + apply idpath. + rewrite idpath_transportf. apply algebraic_theory_morphism_eq. now do 2 intro. Qed. Definition algebra_weq_algebraic_theory_morphism {T : algebraic_theory} : algebraic_theory_algebra T ≃ ∑ X, algebraic_theory_morphism T (set_endomorphism_theory X) := weq_iso (λ (A : algebraic_theory_algebra T), (A : hSet) ,, algebra_to_algebraic_theory_morphism A) (λ X, algebraic_theory_morphism_to_algebra (pr2 X)) algebra_to_algebraic_theory_morphism_and_back algebraic_theory_morphism_to_algebra_and_back. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryAlgebras.v000066400000000000000000000123371451125700300251320ustar00rootroot00000000000000(* Defines algebraic theory algebras with accessors for the data, some properties and two constructors for is_algebraic_theory_algebra. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Local Open Scope cat. Local Open Scope algebraic_theories. Definition algebraic_theory_algebra_data (T : algebraic_theory_data) : UU := ∑ (A : hSet), ∏ (n : nat), (T n : hSet) → (stn n → A) → A. Definition make_algebraic_theory_algebra_data {T : algebraic_theory_data} (A : hSet) (action : ∏ (n : nat), (T n : hSet) → (stn n → A) → A) : algebraic_theory_algebra_data T := (A ,, action). Coercion algebraic_theory_algebra_data_to_hset {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : hSet := pr1 A. Definition action {T : algebraic_theory_data} {A : algebraic_theory_algebra_data T} {n : nat} : (T n : hSet) → (stn n → A) → A := pr2 A n. Definition is_assoc {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : UU := ∏ m n (f : (T m : hSet)) g (a : stn n → A), action (f • g) a = action f (λ i, action (g i) a). Definition is_unital {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : UU := ∏ (a : stn 1 → A), action id_pr a = a firstelement. Definition is_natural {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : UU := ∏ n n' t (f : (T n : hSet)) (a : stn n' → A), action (#T t f) a = action f (λ i, a (t i)). Definition is_algebraic_theory_algebra {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : UU := is_assoc A × is_unital A × is_natural A. Definition make_is_algebraic_theory_algebra {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) (H1 : is_assoc A) (H2 : is_unital A) (H3 : is_natural A) : is_algebraic_theory_algebra A := (H1 ,, H2 ,, H3). Lemma make_is_algebraic_theory_algebra' {T : algebraic_theory} {A : algebraic_theory_algebra_data T} (is_assoc : is_assoc A) (projects_component : ∏ n i (a : stn n → A), action (pr i) a = a i) : is_algebraic_theory_algebra A. Proof. use make_is_algebraic_theory_algebra. - exact is_assoc. - intro. rewrite algebraic_theory_id_pr_is_pr. apply projects_component. - do 5 intro. rewrite algebraic_theory_functor_uses_projections, is_assoc. apply maponpaths, funextfun. intro. apply projects_component. Qed. Definition algebraic_theory_algebra (T : algebraic_theory_data) := ∑ (A : hSet) (action : ∏ (n : nat), (T n : hSet) → (stn n → A) → A), is_algebraic_theory_algebra (make_algebraic_theory_algebra_data A action). Definition make_algebraic_theory_algebra {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) (H : is_algebraic_theory_algebra A) : algebraic_theory_algebra T := (pr1 A ,, pr2 A ,, H). Coercion algebraic_theory_algebra_to_algebraic_theory_algebra_data {T : algebraic_theory_data} (A : algebraic_theory_algebra T) : algebraic_theory_algebra_data T := make_algebraic_theory_algebra_data (pr1 A) (pr12 A). Definition algebraic_theory_algebra_is_assoc {T : algebraic_theory_data} (A : algebraic_theory_algebra T) : is_assoc A := pr122 A. Definition algebraic_theory_algebra_is_unital {T : algebraic_theory_data} (A : algebraic_theory_algebra T) : is_unital A := pr1 (pr222 A). Definition algebraic_theory_algebra_is_natural {T : algebraic_theory_data} (A : algebraic_theory_algebra T) : is_natural A := pr2 (pr222 A). Lemma isaprop_is_algebraic_theory_algebra {T : algebraic_theory_data} (A : algebraic_theory_algebra_data T) : isaprop (is_algebraic_theory_algebra A). Proof. repeat apply isapropdirprod; repeat (apply impred_isaprop; intro); apply setproperty. Qed. Lemma algebraic_theory_algebra_eq {T : algebraic_theory_data} (A B : algebraic_theory_algebra T) (H1 : (A : hSet) = (B : hSet)) (H2 : ∏ n f, transportf (λ (X : hSet), (stn n → X) → X) H1 (action f) = action f) : A = B. Proof. use total2_paths_f. - exact H1. - rewrite transportf_total2. use subtypePairEquality'. + rewrite transportf_sec_constant. apply funextsec. intro. rewrite transportf_sec_constant. apply funextsec. intro. apply H2. + exact (isaprop_is_algebraic_theory_algebra _). Qed. (* Properties of algebraic theory algebras *) Lemma lift_constant_action {T : algebraic_theory_data} {A : algebraic_theory_algebra T} (n : nat) (f : (T 0 : hSet)) (a : stn n → A) : action (lift_constant n f) a = action f (weqvecfun _ vnil). Proof. unfold lift_constant. rewrite algebraic_theory_algebra_is_assoc. apply maponpaths, funextfun. intro i. exact (fromempty (negnatlthn0 _ (stnlt i))). Qed. Lemma algebraic_theory_algebra_projects_component {T : algebraic_theory} (A : algebraic_theory_algebra T) : ∏ n i (a : stn n → A), action (pr i) a = a i. Proof. intros. unfold pr. rewrite algebraic_theory_algebra_is_natural. apply algebraic_theory_algebra_is_unital. Qed. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryCategory.v000066400000000000000000000076531451125700300251740ustar00rootroot00000000000000(* Defines the univalent category of algebraic theories. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms. Require Import UniMath.AlgebraicTheories.FiniteSetSkeleton. Local Open Scope cat. Local Open Scope algebraic_theories. Definition base_functor_category : category := [finite_set_skeleton_category, HSET]. Definition pointed_functor_disp_cat : disp_cat base_functor_category. Proof. use disp_struct. - intro T. exact ((T : base_functor) 1 : hSet). - intros T T' Tdata T'data F. exact ((F : base_nat_trans _ _) _ Tdata = T'data). - abstract (intros; apply setproperty). - now intros. - intros T T' T'' e e' e'' F F' HF HF'. now rewrite (!HF'), (!HF). Defined. Definition pointed_functor_cat : category := total_category pointed_functor_disp_cat. Definition algebraic_theory_data_disp_cat : disp_cat pointed_functor_cat. Proof. use disp_struct. - exact (λ (T : pointed_functor), ∏ m n, (T m : hSet) → (stn m → (T n : hSet)) → (T n : hSet)). - exact (λ T T' Tdata T'data (F : pointed_functor_morphism T T'), ∏ m n f g, (F _ (Tdata m n f g)) = T'data m n (F _ f) (λ i, F _ (g i))). - intros. repeat (apply impred_isaprop; intro). apply setproperty. - now intros. - intros T T' T'' Tdata T'data T''data F F' Fdata F'data m n f g. cbn. now rewrite Fdata, F'data. Defined. Definition algebraic_theory_data_cat : category := total_category algebraic_theory_data_disp_cat. Definition algebraic_theory_disp_cat : disp_cat algebraic_theory_data_cat := disp_full_sub algebraic_theory_data_cat is_algebraic_theory. Definition algebraic_theory_cat : category := total_category algebraic_theory_disp_cat. Lemma is_univalent_pointed_functor_cat : is_univalent pointed_functor_cat. Proof. apply (is_univalent_total_category (is_univalent_functor_category _ _ is_univalent_HSET)). apply is_univalent_disp_iff_fibers_are_univalent. do 3 intro. use isweq_iso. - exact pr1. - intro. apply setproperty. - intro. apply z_iso_eq. apply setproperty. Qed. Lemma is_univalent_algebraic_theory_data_cat : is_univalent algebraic_theory_data_cat. Proof. apply (is_univalent_total_category is_univalent_pointed_functor_cat). apply is_univalent_disp_iff_fibers_are_univalent. intros T comp comp'. use isweq_iso. - intro f. do 4 (apply funextsec; intro). apply (pr1 f _). - intro. assert (H : isaset algebraic_theory_data_disp_cat[{T}]); [ | apply H]. do 4 (apply impred_isaset; intro). apply setproperty. - intro. apply z_iso_eq. do 4 (apply impred_isaprop; intro). apply setproperty. Qed. Lemma is_univalent_algebraic_theory_cat : is_univalent algebraic_theory_cat. Proof. apply (is_univalent_total_category is_univalent_algebraic_theory_data_cat). apply disp_full_sub_univalent. exact isaprop_is_algebraic_theory. Qed. Definition algebraic_theory_univalent_category : univalent_category := make_univalent_category _ is_univalent_algebraic_theory_cat. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryMorphisms.v000066400000000000000000000130601451125700300253650ustar00rootroot00000000000000(* Defines morphisms of algebraic theories, gives two ways of constructing them, gives corresponding accessors for the data and properties and provides an equality lemma. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.AlgebraicTheories.FiniteSetSkeleton. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryMorphisms2. Local Open Scope cat. Local Open Scope algebraic_theories. Definition base_nat_trans (T T' : base_functor) : UU := T ⟹ T'. Coercion base_nat_trans_to_nat_trans (T T' : base_functor) (F : base_nat_trans T T') : T ⟹ T' := F. Definition preserves_id_pr {T T' : pointed_functor} (F : base_nat_trans T T') : UU := (F _ id_pr) = id_pr. Definition pointed_functor_morphism (T T' : pointed_functor) : UU := ∑ (F : base_nat_trans T T'), preserves_id_pr F. Coercion pointed_functor_morphism_to_nat_trans {T T'} (F : pointed_functor_morphism T T') : nat_trans T T' := pr1 F. Definition preserves_composition {T T' : algebraic_theory_data} (F : base_nat_trans T T') : UU := ∏ (m n : nat) (f_m : (T m : hSet)) (f_n : stn m → (T n : hSet)), (F _ (f_m • f_n)) = ((F m f_m) • (λ i, F _ (f_n i))). Definition algebraic_theory_data_morphism (T T' : algebraic_theory_data) : UU := ∑ (F : pointed_functor_morphism T T'), preserves_composition F. Coercion algebraic_theory_data_morphism_to_pointed_functor_morphism {T T'} (F : algebraic_theory_data_morphism T T') : pointed_functor_morphism T T' := pr1 F. Definition algebraic_theory_morphism (T T' : algebraic_theory) : UU := ∑ X : algebraic_theory_data_morphism T T', unit. Coercion algebraic_theory_morphism_to_algebraic_theory_data_morphism {T T'} (F : algebraic_theory_morphism T T') : algebraic_theory_data_morphism T T' := pr1 F. Definition is_algebraic_theory_morphism {T T' : algebraic_theory_data} (F : base_nat_trans T T') : UU := preserves_id_pr F × preserves_composition F. Definition make_is_algebraic_theory_morphism {T T' : algebraic_theory} (F : base_nat_trans T T') (H1 : preserves_id_pr F) (H2 : preserves_composition F) := (H1 ,, H2). Lemma isaprop_is_algebraic_theory_morphism {T T' : algebraic_theory} (F : base_nat_trans T T') : isaprop (is_algebraic_theory_morphism F). Proof. intro. repeat apply isapropdirprod; repeat (apply impred_isaprop; intro); apply setproperty. Qed. Definition make_algebraic_theory_morphism {T T' : algebraic_theory} (F : base_nat_trans T T') (H : is_algebraic_theory_morphism F) : algebraic_theory_morphism T T' := (((F ,, pr1 H) ,, pr2 H) ,, tt). Section MakeAlgebraicTheoryMorphisms2. Lemma algebraic_theory_morphism'_to_is_nat_trans {T T' : algebraic_theory} (F : algebraic_theory_morphism' T T') : is_nat_trans T T' F. Proof. do 3 intro. apply funextfun. intro. unfold compose. simpl. do 2 rewrite (algebraic_theory_functor_uses_projections). etrans. - apply algebraic_theory_morphism'_preserves_composition. - apply maponpaths, funextfun. intro. apply algebraic_theory_morphism'_preserves_projections. Qed. Definition algebraic_theory_morphism'_to_base_nat_trans {T T' : algebraic_theory} (F : algebraic_theory_morphism' T T') : base_nat_trans T T' := make_nat_trans _ _ _ (algebraic_theory_morphism'_to_is_nat_trans F). Lemma algebraic_theory_morphism'_to_is_algebraic_theory_morphism {T T' : algebraic_theory} (F : algebraic_theory_morphism' T T') : is_algebraic_theory_morphism (algebraic_theory_morphism'_to_base_nat_trans F). Proof. use make_is_algebraic_theory_morphism. - unfold preserves_id_pr. simpl. do 2 rewrite algebraic_theory_id_pr_is_pr. apply algebraic_theory_morphism'_preserves_projections. - exact (algebraic_theory_morphism'_preserves_composition F). Qed. Definition make_algebraic_theory_morphism' {T T' : algebraic_theory} (F : algebraic_theory_morphism'_data T T') (H : is_algebraic_theory_morphism' F) : algebraic_theory_morphism T T' := make_algebraic_theory_morphism _ (algebraic_theory_morphism'_to_is_algebraic_theory_morphism (F ,, H)). End MakeAlgebraicTheoryMorphisms2. Definition algebraic_theory_morphism_preserves_id_pr {T T'} (F : algebraic_theory_morphism T T') : preserves_id_pr F := pr211 F. Definition algebraic_theory_morphism_preserves_composition {T T'} (F : algebraic_theory_morphism T T') : preserves_composition F := pr21 F. Lemma algebraic_theory_morphism_preserves_projections {T T'} (F : algebraic_theory_morphism T T') {n : nat} (i : stn n) : F _ (pr i) = pr i. Proof. unfold pr. rewrite <- (algebraic_theory_morphism_preserves_id_pr F). apply (maponpaths (λ x, x id_pr) : ((λ x, F _ (# T _ x)) = (λ x, # T' _ (F _ x))) → _). apply (nat_trans_ax F). Qed. Lemma algebraic_theory_morphism_eq {T T'} (F F' : algebraic_theory_morphism T T') (H1 : ∏ n f, F n f = F' n f) : F = F'. Proof. repeat use subtypePairEquality'. - do 2 (apply funextsec; intro). apply H1. - apply isaprop_is_nat_trans, homset_property. - apply setproperty. - repeat (apply impred_isaprop; intro). apply setproperty. - exact isapropunit. Qed. UniMath-20231010/UniMath/AlgebraicTheories/AlgebraicTheoryMorphisms2.v000066400000000000000000000045121451125700300254510ustar00rootroot00000000000000(* Defines a type for passing data to make_algebraic_theory_morphism' in AlgebraicTheoryMorphisms.v. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Local Open Scope algebraic_theories. Definition algebraic_theory_morphism'_data (T T' : algebraic_theory_data) : UU := ∏ n, (T n : hSet) → (T' n : hSet). Definition algebraic_theory_morphism'_data_to_function {T T'} (F : algebraic_theory_morphism'_data T T') : ∏ n, (T n : hSet) → (T' n : hSet) := F. Coercion algebraic_theory_morphism'_data_to_function : algebraic_theory_morphism'_data >-> Funclass. Definition preserves_composition {T T'} (F : algebraic_theory_morphism'_data T T') := ∏ (m n : nat) (f : (T m : hSet)) (g : stn m → (T n : hSet)), F _ (f • g) = (F _ f) • (λ i, F _ (g i)). Definition preserves_projections {T T'} (F : algebraic_theory_morphism'_data T T') := ∏ (n : nat) (i : stn n), F _ (pr i) = pr i. Definition is_algebraic_theory_morphism' {T T'} (F : algebraic_theory_morphism'_data T T') := preserves_composition F × preserves_projections F. Definition make_is_algebraic_theory_morphism' {T T'} (F : algebraic_theory_morphism'_data T T') (H1 : preserves_composition F) (H2 : preserves_projections F) : is_algebraic_theory_morphism' F := (H1 ,, H2). Lemma isaprop_is_algebraic_theory_morphism' {T T'} (F : algebraic_theory_morphism'_data T T') : isaprop (is_algebraic_theory_morphism' F). Proof. repeat apply isapropdirprod; repeat (apply impred_isaprop; intros); apply setproperty. Qed. Definition algebraic_theory_morphism' (T T' : algebraic_theory_data) := ∑ F : algebraic_theory_morphism'_data T T', is_algebraic_theory_morphism' F. Coercion algebraic_theory_morphism'_to_function {T T'} (F : algebraic_theory_morphism' T T') : algebraic_theory_morphism'_data T T' := pr1 F. Definition algebraic_theory_morphism'_preserves_composition {T T'} (F : algebraic_theory_morphism' T T') : preserves_composition F := pr12 F. Definition algebraic_theory_morphism'_preserves_projections {T T'} (F : algebraic_theory_morphism' T T') : preserves_projections F := pr22 F. UniMath-20231010/UniMath/AlgebraicTheories/Examples/000077500000000000000000000000001451125700300220065ustar00rootroot00000000000000UniMath-20231010/UniMath/AlgebraicTheories/Examples/EndomorphismTheory.v000066400000000000000000000042201451125700300260320ustar00rootroot00000000000000(* Defines the endomorphism theory of an object X in some category with products, given by T(n) = (X^n → X). Also gives a specialization for X a set. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheories2. Local Open Scope cat. Section EndomorphismAlgebraicTheory. Context {C : category}. Context (C_finite_products : finite_products C). Variable (X : C). Definition endomorphism_theory'_data : algebraic_theory'_data. Proof. use make_algebraic_theory'_data. - intro n. pose (power := ProductObject _ _ (C_finite_products n (λ _, X))). exact (homset power X). - intro. apply ProductPr. - intros m n f g. exact (f ∘ (ProductArrow _ _ _ g)). Defined. Definition endomorphism_is_theory' : is_algebraic_theory' endomorphism_theory'_data. Proof. use make_is_algebraic_theory'. - do 4 intro. exact (ProductPrCommutes _ _ _ _ _ _ _). - do 2 intro. rewrite <- id_left. apply (maponpaths (λ x, x · _)). rewrite (ProductArrowEta _ _ _ _ _ (identity _)). apply maponpaths, funextfun. intro. symmetry. apply id_left. - intros l m n f_l f_m f_n. unfold comp'. simpl. rewrite assoc. apply (maponpaths (λ f, f · f_l)). rewrite (ProductArrowEta _ _ _ _ _ (_ · _)). apply maponpaths, funextfun. intro. rewrite assoc'. apply maponpaths. exact (ProductPrCommutes _ _ _ _ _ _ _). Qed. Definition endomorphism_theory : algebraic_theory := make_algebraic_theory' _ endomorphism_is_theory'. End EndomorphismAlgebraicTheory. Definition set_endomorphism_theory (X : hSet) : algebraic_theory := endomorphism_theory (λ n, ProductsHSET (stn n)) (X : ob HSET). UniMath-20231010/UniMath/AlgebraicTheories/Examples/FreeMonoidTheory.v000066400000000000000000000161671451125700300254320ustar00rootroot00000000000000(* Defines the algebraic theory given by T(n) the free monoid on n generators and shows that the type of its algebras is equivalent to the type of monoids. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Functors. Require Export UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Free_Monoids_and_Groups. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheories2. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Local Open Scope algebraic_theories. Local Open Scope vec_scope. Definition free_monoid_theory'_data : algebraic_theory'_data. Proof. use make_algebraic_theory'_data. - intro n. use tpair. * exact (free_monoid (stnset n)). * apply isasetmonoid. - intros n i. exact (free_monoid_unit (i : stnset n)). - intros m n f g. exact (free_monoid_extend (λ i : stnset m, g i) f). Defined. Lemma free_monoid_is_theory' : is_algebraic_theory' free_monoid_theory'_data. Proof. use make_is_algebraic_theory'. - now do 4 intro. - intros n f. apply (free_monoid_extend_comp (idmonoidiso (free_monoid (stnset n)))). - intros l m n f_l f_m f_n. exact (maponpaths (λ x, pr1monoidfun _ _ x f_l) (free_monoid_extend_funcomp2 (X := stnset l) f_m f_n)). Qed. Definition free_monoid_theory : algebraic_theory := make_algebraic_theory' _ free_monoid_is_theory'. Definition free_monoid_theory_algebra_to_setwithbinop (A : algebraic_theory_algebra free_monoid_theory) : setwithbinop. Proof. use make_setwithbinop. - exact A. - intros a b. eapply action. + exact (op (free_monoid_unit (make_stn 2 0 (idpath _) : stnset _)) (free_monoid_unit (make_stn 2 1 (idpath _) : stnset _))). + exact (weqvecfun _ [(a ; b)]). Defined. Local Lemma move_action_through_weqvecfun {A : algebraic_theory_algebra free_monoid_theory} {n : nat} {f g : (free_monoid_theory n : hSet)} (h : stn n → A) : weqvecfun _ [( action f h ; action g h )] = λ i, action (weqvecfun _ [(f ; g)] i) h. Proof. now apply (invmaponpathsweq (invweq (weqvecfun _))). Qed. Lemma free_monoid_theory_algebra_to_setwithbinop_op_is_assoc (A : algebraic_theory_algebra free_monoid_theory) : isassoc (op (X := free_monoid_theory_algebra_to_setwithbinop A)). Proof. intros a b c. pose (f := weqvecfun _ [(a ; b ; c)]). pose (Hf := λ i Hi, !(algebraic_theory_algebra_projects_component _ _ (make_stn 3 i Hi) f)). do 4 rewrite (idpath _ : op (X := (free_monoid_theory_algebra_to_setwithbinop A)) _ _ = action _ _). rewrite (Hf 0 (idpath true) : a = _), (Hf 1 (idpath true) : b = _), (Hf 2 (idpath true) : c = _). now do 4 (rewrite move_action_through_weqvecfun, <- algebraic_theory_algebra_is_assoc). Qed. Definition free_monoid_theory_algebra_to_unit (A : algebraic_theory_algebra free_monoid_theory) : A := action (T := free_monoid_theory) (unel _) (weqvecfun _ [()]). Lemma free_monoid_theory_algebra_to_isunit (A : algebraic_theory_algebra free_monoid_theory) : isunit (op (X := free_monoid_theory_algebra_to_setwithbinop A)) (free_monoid_theory_algebra_to_unit A). Proof. use tpair; intro x; now rewrite (idpath _ : op (X := free_monoid_theory_algebra_to_setwithbinop A) _ _ = action (T := free_monoid_theory) _ _), <- (algebraic_theory_algebra_projects_component _ _ (make_stn 1 0 (idpath _)) (λ _, x)), <- (lift_constant_action 1 _ (λ _, x) : _ = free_monoid_theory_algebra_to_unit A), move_action_through_weqvecfun, <- algebraic_theory_algebra_is_assoc. Qed. Definition free_monoid_theory_algebra_to_setwithbinop_op_is_unital (A : algebraic_theory_algebra free_monoid_theory) : isunital (op (X := free_monoid_theory_algebra_to_setwithbinop A)) := _ ,, free_monoid_theory_algebra_to_isunit A. Definition free_monoid_theory_algebra_to_setwithbinop_op_is_monoidop (A : algebraic_theory_algebra free_monoid_theory) : ismonoidop (op (X := free_monoid_theory_algebra_to_setwithbinop A)) := free_monoid_theory_algebra_to_setwithbinop_op_is_assoc A ,, free_monoid_theory_algebra_to_setwithbinop_op_is_unital A. Definition free_monoid_theory_algebra_to_monoid (A : algebraic_theory_algebra free_monoid_theory) : monoid := free_monoid_theory_algebra_to_setwithbinop A ,, free_monoid_theory_algebra_to_setwithbinop_op_is_monoidop A. Definition monoid_to_free_monoid_theory_algebra_data (M : monoid) : algebraic_theory_algebra_data free_monoid_theory. Proof. use make_algebraic_theory_algebra_data. - exact M. - intros n f m. exact (free_monoid_extend (X := stnset n) m f). Defined. Lemma monoid_to_is_free_monoid_theory_algebra (M : monoid) : is_algebraic_theory_algebra (monoid_to_free_monoid_theory_algebra_data M). Proof. use make_is_algebraic_theory_algebra'. - intros m n f g a. now rewrite (idpath _ : action f (λ _, action _ a) = free_monoid_extend (X := stnset m) (λ _, free_monoid_extend (X := stnset n) _ _) _), <- free_monoid_extend_funcomp2. - now do 3 intro. Qed. Definition monoid_to_free_monoid_theory_algebra (M : monoid) : algebraic_theory_algebra free_monoid_theory := make_algebraic_theory_algebra _ (monoid_to_is_free_monoid_theory_algebra M). Lemma monoid_to_free_monoid_theory_algebra_and_back (M : monoid) : free_monoid_theory_algebra_to_monoid (monoid_to_free_monoid_theory_algebra M) = M. Proof. exact (subtypePairEquality' (idpath (pr1monoid _)) (isapropismonoidop _)). Qed. Lemma free_monoid_theory_algebra_to_monoid_and_back (A : algebraic_theory_algebra free_monoid_theory) : monoid_to_free_monoid_theory_algebra (free_monoid_theory_algebra_to_monoid A) = A. Proof. use algebraic_theory_algebra_eq. - apply idpath. - intros n f. rewrite idpath_transportf. apply funextfun. intro a. pose (A' := monoid_to_free_monoid_theory_algebra (free_monoid_theory_algebra_to_monoid A)). apply (list_ind (λ x, action (A := A') x a = action (A := A) x a)). + exact (!(lift_constant_action (A := A) _ (unel _) _)). + intros i xs Haction. rewrite (idpath _ : cons i xs = (op (free_monoid_unit (make_stn 2 0 (idpath true) : stnset _)) (free_monoid_unit (make_stn 2 1 (idpath true) : stnset _)) : (free_monoid_theory 2 : hSet)) • (weqvecfun _ [((free_monoid_unit i) ; xs)])). do 2 rewrite algebraic_theory_algebra_is_assoc. now rewrite <- (move_action_through_weqvecfun (A := A) a), <- Haction, (algebraic_theory_algebra_projects_component A _ _ _ : action (free_monoid_unit i : (free_monoid_theory n : hSet)) _ = _). Qed. Definition monoid_weq_free_monoid_theory_algebra : monoid ≃ (algebraic_theory_algebra free_monoid_theory) := weq_iso monoid_to_free_monoid_theory_algebra free_monoid_theory_algebra_to_monoid monoid_to_free_monoid_theory_algebra_and_back free_monoid_theory_algebra_to_monoid_and_back. UniMath-20231010/UniMath/AlgebraicTheories/Examples/OnePointTheory.v000066400000000000000000000027141451125700300251270ustar00rootroot00000000000000(* Define the terminal algebraic theory given by T(n) = unit and show that its only algebra is the unit type. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheories2. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Local Open Scope vec_scope. Definition one_point_theory'_data : algebraic_theory'_data := make_algebraic_theory'_data (λ _, (unit ,, isasetunit)) (λ _ _, tt) (λ _ _ _ _, tt). Lemma one_point_is_theory' : is_algebraic_theory' one_point_theory'_data. Proof. use make_is_algebraic_theory'. - intros m n i f. now induction (f i). - intros n f. now induction f. - now do 6 intro. Qed. Definition one_point_theory : algebraic_theory := make_algebraic_theory' _ one_point_is_theory'. Lemma one_point_clone_algebra_is_trivial : ∏ (A : algebraic_theory_algebra one_point_theory), A ≃ unit. Proof. intro A. apply weqcontrtounit. use tpair. - use (action (tt : (one_point_theory 0 : hSet)) (weqvecfun 0 vnil)). - intro a. rewrite <- (algebraic_theory_algebra_projects_component _ _ (make_stn 1 0 (idpath _)) (λ _, a) : _ = a). exact (lift_constant_action _ _ _). Qed. UniMath-20231010/UniMath/AlgebraicTheories/Examples/ProjectionsTheory.v000066400000000000000000000027521451125700300256750ustar00rootroot00000000000000(* Define the initial algebraic theory given by T(n) = {0, ..., n-1} and pr i = i and show that every set can be an algebra for this theory. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.AlgebraicTheories.AlgebraicTheories. Require Import UniMath.AlgebraicTheories.AlgebraicTheories2. Require Import UniMath.AlgebraicTheories.AlgebraicTheoryAlgebras. Definition projections_theory'_data : algebraic_theory'_data := make_algebraic_theory'_data stnset (λ _ i, i) (λ _ _ f g, g f). Lemma projections_is_theory' : is_algebraic_theory' projections_theory'_data. Proof. now use make_is_algebraic_theory'; repeat intro. Qed. Definition projections_theory : algebraic_theory := make_algebraic_theory' _ projections_is_theory'. Definition projections_theory_algebra_data (A : hSet) : algebraic_theory_algebra_data projections_theory := make_algebraic_theory_algebra_data A (λ n (i : (projections_theory n : hSet)) f, f i). Lemma projections_theory_algebra_is_algebra (A : hSet) : is_algebraic_theory_algebra (projections_theory_algebra_data A). Proof. now use make_is_algebraic_theory_algebra; repeat intro. Qed. Definition projections_theory_algebra (A : hSet) : algebraic_theory_algebra projections_theory := make_algebraic_theory_algebra _ (projections_theory_algebra_is_algebra A). UniMath-20231010/UniMath/AlgebraicTheories/FiniteSetSkeleton.v000066400000000000000000000014411451125700300240160ustar00rootroot00000000000000(* Defines the full subcategory of SET, consisting of the sets {0, ..., n-1} and their functions. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Definition finite_set_skeleton_precat : precategory. Proof. use make_precategory. - use make_precategory_data. + use make_precategory_ob_mor. * exact nat. * exact (λ m n, stn m → stn n). + intro. exact (idfun _). + do 3 intro. exact funcomp. - do 3 split. Defined. Definition finite_set_skeleton_category : category. Proof. use make_category. - exact finite_set_skeleton_precat. - do 2 intro. apply funspace_isaset. apply isasetstn. Defined. UniMath-20231010/UniMath/Bicategories/000077500000000000000000000000001451125700300172545ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/.package/000077500000000000000000000000001451125700300207255ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/.package/files000066400000000000000000000312541451125700300217570ustar00rootroot00000000000000Core/Bicat.v Core/Invertible_2cells.v Morphisms/Adjunctions.v Morphisms/FullyFaithful.v Morphisms/DiscreteMorphisms.v Core/Examples/OpMorBicat.v Morphisms/Examples/MorphismsInOp1Bicat.v Core/Examples/OpCellBicat.v Core/Unitors.v Core/BicategoryLaws.v Core/Univalence.v Core/TransportLaws.v Core/EquivToAdjequiv.v Core/AdjointUnique.v Core/UnivalenceOp.v Core/Discreteness.v Morphisms/ExtensionsAndLiftings.v Morphisms/InternalStreetFibration.v Morphisms/InternalStreetOpFibration.v Morphisms/Properties/ContainsAdjEquiv.v Morphisms/Properties/Composition.v Morphisms/Properties/ClosedUnderInvertibles.v Morphisms/Properties.v Core/Examples/DiscreteBicat.v Core/Examples/OneTypes.v Core/Examples/PointedOneTypesBicat.v Core/Examples/TwoType.v Core/Examples/BicatOfUnivCats.v Core/Examples/BicatOfCats.v Core/Strictness.v Core/Examples/StrictCats.v Core/Examples/Initial.v Core/Examples/Final.v Core/Examples/BicategoryFromMonoidal.v Core/Examples/BicategoryFromWhiskeredMonoidal.v Core/Examples/FibSlice.v Core/Examples/OpFibSlice.v Morphisms/Properties/AdjunctionsRepresentable.v Morphisms/Examples/MorphismsInBicatOfUnivCats.v Morphisms/Examples/FibrationsInBicatOfUnivCats.v Morphisms/Examples/FibrationsInStrictCats.v Morphisms/Examples/MorphismsInOp2Bicat.v DisplayedBicats/DispBicat.v DisplayedBicats/DispInvertibles.v DisplayedBicats/DispAdjunctions.v DisplayedBicats/DispUnivalence.v DisplayedBicats/CleavingOfBicat.v DisplayedBicats/FiberCategory.v DisplayedBicats/FiberBicategory/FiberBicategory1.v DisplayedBicats/FiberBicategory/FiberBicategory2.v DisplayedBicats/FiberBicategory.v DisplayedBicats/Examples/Sigma.v DisplayedBicats/Examples/DisplayedCatToBicat.v DisplayedBicats/Examples/FullSub.v DisplayedBicats/Examples/Slice.v DisplayedBicats/Examples/Sub1Cell.v DisplayedBicats/Examples/DispBicatOfDispCats.v DisplayedBicats/Examples/Prod.v DisplayedBicats/Examples/DispDepProd.v DisplayedBicats/Examples/Trivial.v DisplayedBicats/Examples/BicatOfInvertibles.v DisplayedBicats/Examples/EndoMap.v Core/Examples/StructuredCategories.v DisplayedBicats/Examples/CategoriesWithStructure.v MonoidalCategories/MonoidalFromBicategory.v MonoidalCategories/EndofunctorsMonoidal.v MonoidalCategories/PointedFunctorsMonoidal.v MonoidalCategories/Actions.v MonoidalCategories/ConstructionOfActions.v MonoidalCategories/WhiskeredMonoidalFromBicategory.v MonoidalCategories/ActionOfEndomorphismsInBicatWhiskered.v MonoidalCategories/BicatOfWhiskeredMonCatsLax.v MonoidalCategories/BicatOfWhiskeredMonCats.v MonoidalCategories/EndofunctorsWhiskeredMonoidal.v MonoidalCategories/PointedFunctorsWhiskeredMonoidal.v MonoidalCategories/IdempotencePointedFunctorsWhiskeredMonoidal.v MonoidalCategories/ActionBasedStrength.v MonoidalCategories/ActionBasedStrongFunctorsMonoidal.v MonoidalCategories/ActionOfEndomorphismsInBicat.v MonoidalCategories/ActionBasedStrongFunctorCategory.v MonoidalCategories/ActionsFormBicategory.v MonoidalCategories/ActionBasedStrongFunctorsWhiskeredMonoidal.v MonoidalCategories/BicatOfActegories.v MonoidalCategories/BicatOfActionsInBicat.v MonoidalCategories/UnivalenceMonCat/CurriedMonoidalCategories.v MonoidalCategories/UnivalenceMonCat/EquivalenceWhiskeredCurried.v MonoidalCategories/UnivalenceMonCat/UnitLayer.v MonoidalCategories/UnivalenceMonCat/TensorLayer.v MonoidalCategories/UnivalenceMonCat/TensorUnitLayer.v MonoidalCategories/UnivalenceMonCat/AssociatorUnitorsLayer.v MonoidalCategories/UnivalenceMonCat/FinalLayer.v MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatCurried.v MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatNonCurried.v Core/Examples/Groupoids.v PseudoFunctors/Display/Base.v PseudoFunctors/Display/Map1Cells.v PseudoFunctors/Display/Map2Cells.v PseudoFunctors/Display/Identitor.v PseudoFunctors/Display/Compositor.v PseudoFunctors/Display/PseudoFunctorBicat.v PseudoFunctors/Display/StrictIdentitor.v PseudoFunctors/Display/StrictCompositor.v PseudoFunctors/Display/StrictPseudoFunctorBicat.v PseudoFunctors/PseudoFunctor.v PseudoFunctors/StrictPseudoFunctor.v PseudoFunctors/Examples/Identity.v PseudoFunctors/Examples/Composition.v PseudoFunctors/Examples/Constant.v PseudoFunctors/Examples/ApFunctor.v PseudoFunctors/Examples/OpFunctor.v PseudoFunctors/Examples/CatDiag.v PseudoFunctors/Examples/PseudofunctorFromMonoidal.v PseudoFunctors/Examples/Op2OfPseudoFunctor.v PseudoFunctors/Examples/BicatOfCatToUnivCat.v PseudoFunctors/Examples/PseudoFunctorsIntoCat.v Transformations/PseudoTransformation.v Transformations/Examples/Whiskering.v Transformations/Examples/Unitality.v Transformations/Examples/Associativity.v Transformations/Examples/ApTransformation.v Transformations/Examples/PseudoTransformationIntoCat.v Modifications/Modification.v Modifications/Examples/ApModification.v Modifications/Examples/Unitality.v Modifications/Examples/Associativity.v Modifications/Examples/ModificationIntoCat.v PseudoFunctors/Representable.v PseudoFunctors/Yoneda.v PseudoFunctors/Biequivalence.v PseudoFunctors/Examples/StrictToPseudo.v PseudoFunctors/Examples/Projection.v MonoidalCategories/EquivalenceActegoriesAndActions.v PseudoFunctors/Biadjunction.v PseudoFunctors/UniversalArrow.v DisplayedBicats/DispBicatSection.v DisplayedBicats/Examples/PointedOneTypes.v DisplayedBicats/Examples/DisplayedInserter.v DisplayedBicats/Examples/Displayed2Inserter.v DisplayedBicats/Examples/Algebras.v DisplayedBicats/Examples/Add2Cell.v DisplayedBicats/Examples/ContravariantFunctor.v DisplayedBicats/Examples/Cofunctormap.v DisplayedBicats/Examples/CwF.v DisplayedBicats/Examples/LaxSlice.v DisplayedBicats/Examples/FunctorsIntoCat.v DisplayedBicats/Examples/Codomain.v DisplayedBicats/DispPseudofunctor.v DisplayedBicats/DispTransportLaws.v DisplayedBicats/UnivalenceTechniques.v Transformations/Examples/AlgebraMap.v DisplayedBicats/Examples/Monads.v DisplayedBicats/Examples/KleisliTriple.v DisplayedBicats/Examples/EnrichedCats.v DisplayedBicats/Examples/DispBicatOfTwoSidedDispCat.v DisplayedBicats/DispTransformation.v DisplayedBicats/DispModification.v DisplayedBicats/DispBiequivalence.v DoubleCategories/DoubleCategoryBasics.v DoubleCategories/DoubleFunctor/Basics.v DoubleCategories/DoubleFunctor/LeftUnitor.v DoubleCategories/DoubleFunctor/RightUnitor.v DoubleCategories/DoubleFunctor/Associator.v DoubleCategories/DoubleFunctor.v DoubleCategories/DoubleTransformation.v DoubleCategories/BicatOfDoubleCats.v DoubleCategories/DoubleCats.v DoubleCategories/InvertiblesAndEquivalences.v DoubleCategories/Examples/UnitDoubleCat.v DoubleCategories/Examples/ProductDoubleCat.v DoubleCategories/Examples/SquareDoubleCat.v DoubleCategories/Examples/LensesDoubleCat.v DoubleCategories/Examples/SpansDoubleCat.v DoubleCategories/Examples/KleisliDoubleCat.v DoubleCategories/Examples/StructuredCospansDoubleCat.v DoubleCategories/Examples/StructuredCospansDoubleFunctor.v DoubleCategories/DoubleCatsUnfolded.v DoubleCategories/DoubleCatsEquivalentDefinitions.v PseudoFunctors/Examples/ChangeOfBaseEnriched.v DisplayedBicats/Examples/MonadsLax.v DisplayedBicats/Examples/DispBicatOnCatToUniv.v PseudoFunctors/Examples/MonadInclusion.v PseudoFunctors/Examples/OpFunctorEnriched.v Monads/Examples/AdjunctionToMonad.v Monads/Examples/ToMonadInCat.v Monads/Examples/MonadsInBicatOfUnivCats.v Monads/Examples/MonadsInBicatOfCats.v Monads/Examples/MonadsInOp1Bicat.v Monads/Examples/MonadsInOp2Bicat.v Monads/Examples/MonadsInTotalBicat.v Monads/Examples/MonadsInBicatOfEnrichedCats.v Monads/DistributiveLaws.v Monads/MixedDistributiveLaws.v Monads/Examples/MonadsInMonads.v Monads/Examples/Composition.v Monads/Examples/PsfunctorOnMonad.v Core/Examples/Image.v PseudoFunctors/Examples/CorestrictImage.v Core/YonedaLemma.v Limits/Final.v Limits/Products.v Limits/Pullbacks.v Limits/CommaObjects.v Limits/Inserters.v Limits/IsoInserters.v Limits/Equifiers.v Limits/EilenbergMooreObjects.v Limits/EilenbergMooreComonad.v Monads/ConstructionOfAlgebras.v Monads/MonadToAdjunction.v Limits/Examples/OneTypesLimits.v Limits/Examples/BicatOfCatsLimits.v Limits/Examples/BicatOfUnivCatsLimits.v Limits/Examples/BicatOfEnrichedCatsLimits.v Limits/Examples/OpCellBicatLimits.v Limits/Examples/UnivGroupoidsLimits.v Limits/Examples/SliceBicategoryLimits.v Limits/Examples/TotalBicategoryLimits.v Limits/Examples/DispConstructionsLimits.v Limits/Examples/SubbicatLimits.v Limits/Examples/LimitsStructuredCategories.v MonoidalCategories/BicatOfWhiskeredMonCatsFinalObject.v Morphisms/Monadic.v MonoidalCategories/MonoidalDialgebrasInserters.v MonoidalCategories/BicatOfActegoriesFinalObject.v MonoidalCategories/MonadsAsMonoidsWhiskered.v Monads/Examples/MonadsInStructuredCategories.v Limits/ProductEquivalences.v Limits/PullbackFunctions.v Limits/PullbackEquivalences.v Limits/InserterEquivalences.v Limits/EquifierEquivalences.v Morphisms/Eso.v Morphisms/Properties/Projections.v Morphisms/Properties/ClosedUnderPullback.v Morphisms/Properties/EsoProperties.v Morphisms/Examples/MorphismsInOneTypes.v Morphisms/Examples/EsosInBicatOfUnivCats.v Morphisms/Examples/MorphismsInSliceBicat.v Morphisms/Examples/MorphismsInStructuredCat.v Morphisms/Examples/MorphismsInBicatOfEnrichedCats.v Colimits/Initial.v Colimits/Coproducts.v Colimits/Extensive.v Colimits/KleisliObjects.v Limits/Examples/OpMorBicatLimits.v Colimits/Examples/OpCellBicatColimits.v Colimits/Examples/OneTypesColimits.v Colimits/Examples/BicatOfCatsColimits.v Colimits/Examples/BicatOfUnivCatsColimits.v Colimits/Examples/SliceBicategoryColimits.v Colimits/CoproductEquivalences.v Morphisms/Properties/FromInitial.v Objects/CartesianObject.v Objects/CocartesianObject.v Objects/Examples/BicatOfUnivCatsObjects.v PseudoFunctors/Examples/ConstProduct.v PseudoFunctors/Examples/CurryingInBicatOfCats.v PseudoFunctors/PseudoFunctorLimits.v DisplayedBicats/DispBiadjunction.v PseudoFunctors/Examples/PathGroupoid.v DisplayedBicats/DispToFiberEquivalence.v DisplayedBicats/DispBuilders.v DisplayedBicats/Examples/MonadKtripleBiequiv.v DisplayedBicats/Examples/PointedGroupoid.v PseudoFunctors/Examples/LiftingActegories.v WkCatEnrichment/prebicategory.v WkCatEnrichment/Notations.v WkCatEnrichment/whiskering.v WkCatEnrichment/Cat.v WkCatEnrichment/internal_equivalence.v WkCatEnrichment/bicategory.v WkCatEnrichment/hcomp_bicat.v PseudoFunctors/Examples/Strictify.v PseudoFunctors/Preservation/Preservation.v PseudoFunctors/Preservation/BiadjunctionPreservation.v PseudoFunctors/Preservation/BiadjunctionPreserveProducts.v PseudoFunctors/Preservation/BiadjunctionPreserveInserters.v PseudoFunctors/Preservation/BiadjunctionPreserveEquifiers.v PseudoFunctors/Preservation/BiadjunctionPreserveCoproducts.v PseudoFunctors/Preservation/ClosedUnderEquivalence.v BicategoryOfBicat.v BicatOfBicategory.v DisplayedBicats/Cartesians.v DisplayedBicats/EquivalenceBetweenCartesians.v DisplayedBicats/CleavingOfBicatIsAProp.v DisplayedBicats/CartesianPseudoFunctor.v DisplayedBicats/ExamplesOfCleavings/TrivialCleaving.v DisplayedBicats/ExamplesOfCleavings/SliceCleaving.v DisplayedBicats/ExamplesOfCleavings/FunctorsIntoCatCleaving.v DisplayedBicats/ExamplesOfCleavings/CodomainCleaving.v DisplayedBicats/ExamplesOfCleavings/FibrationCleaving.v DisplayedBicats/ExamplesOfCleavings/OpFibrationCleaving.v DisplayedBicats/FiberBicategory/FunctorFromCleaving.v PseudoFunctors/Examples/Reindexing.v Logic/DisplayMapBicat.v DisplayedBicats/Examples/DisplayMapBicatToDispBicat.v DisplayedBicats/Examples/DisplayMapBicatSlice.v DisplayedBicats/ExamplesOfCleavings/DisplayMapBicatCleaving.v PseudoFunctors/Examples/PullbackFunctor.v PseudoFunctors/Examples/CompositionPseudoFunctor.v PseudoFunctors/Preservation/PullbackPreservation.v Limits/Examples/DisplayMapSliceLimits.v Colimits/Examples/DisplayMapSliceColimits.v DisplayedBicats/FiberBicategory/TrivialFiber.v DisplayedBicats/FiberBicategory/CodomainFiber.v DisplayedBicats/FiberBicategory/SliceFiber.v DisplayedBicats/FiberBicategory/DisplayMapFiber.v Grothendieck/FibrationToPseudoFunctor.v Grothendieck/PseudoFunctorToFibration.v Grothendieck/Unit.v Grothendieck/Counit.v Grothendieck/Biequivalence.v Grothendieck/FiberwiseEquiv.v Logic/ComprehensionBicat.v Logic/Examples/TrivialComprehensionBicat.v Logic/Examples/PullbackComprehensionBicat.v Logic/Examples/FibrationsComprehensionBicat.v Logic/Examples/OpfibrationsComprehensionBicat.v Logic/Examples/DisplayMapComprehensionBicat.v Logic/Examples/FunctorsIntoCatComprehensionBicat.v OtherStructure/DualityInvolution.v OtherStructure/ClassifyingDiscreteOpfib.v OtherStructure/Exponentials.v OtherStructure/Cores.v OtherStructure/Examples/StructureBicatOfUnivCats.v OtherStructure/Examples/StructureOneTypes.v OtherStructure/Examples/StructureBicatOfEnrichedCats.v DisplayedBicats/DisplayedUniversalArrow.v DisplayedBicats/DisplayedUniversalArrowOnCat.v RezkCompletions/BicatToLocalUnivalentBicat.v RezkCompletions/RezkCompletionOfBicategory.v RezkCompletions/StructuredCats/TerminalObject.v DaggerCategories/BicatOfDaggerCats.v UniMath-20231010/UniMath/Bicategories/BicatOfBicategory.v000066400000000000000000000152561451125700300227740ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) (* ========================================================================= *) (* Every (pre)bicategory of UniMath.Bicategories.WkCatEnrichment is a *) (* (pre)bicategory of UniMath.Bicategories.Core.Bicat. *) (* ========================================================================= *) (* Note: an equivalence is established in WkCatEnrichment/hcomp_bicat.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.WkCatEnrichment.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.WkCatEnrichment.Notations. Local Open Scope cat. (* ------------------------------------------------------------------------- *) (* Missing lemmas. *) (* ------------------------------------------------------------------------- *) Lemma whisker_left_left {C : prebicategory} {a b c d : C} (f : a -1-> b) (g : b -1-> c) {h i : c -1-> d} (x : h -2-> i) : whisker_left f (whisker_left g x) ;v; associator_2mor f g i = associator_2mor f g h ;v; whisker_left (f ;1; g) x. Proof. unfold whisker_left. etrans; [ apply associator_naturality | idtac]. apply maponpaths. apply maponpaths_2. exact horizontal_comp_id. Defined. Lemma whisker_left_right {C : prebicategory} {a b c d : C} (f : a -1-> b) (g h : b -1-> c) (i : c -1-> d) (x : g -2-> h) : whisker_left f (whisker_right x i) ;v; associator_2mor f h i = associator_2mor f g i ;v; whisker_right (whisker_left f x) i. Proof. exact (associator_naturality (identity f) x (identity i)). Defined. Lemma whisker_right_right {C : prebicategory} {a b c d : C} (f g : a -1-> b) (h : b -1-> c) (i : c -1-> d) (x : f -2-> g) : associator_2mor f h i ;v; whisker_right (whisker_right x h) i = whisker_right x (h ;1; i) ;v; associator_2mor g h i. Proof. unfold whisker_right. etrans; [ apply pathsinv0, associator_naturality | idtac]. apply maponpaths_2, maponpaths. exact horizontal_comp_id. Defined. (* ------------------------------------------------------------------------- *) (* From bicategory structure to bicat structure. *) (* ------------------------------------------------------------------------- *) Section unfold_data. Variable C : prebicategory. Definition bcat_precategory_ob_mor : precategory_ob_mor. Proof. exists C. exact (λ a b, homcat a b). Defined. Definition bcat_cell_struct : prebicat_2cell_struct bcat_precategory_ob_mor := λ (a b : C) (f g : homcat a b), (homcat a b) ⟦ f, g ⟧. Definition bcat_ob_mor_cells : ∑ (C : precategory_ob_mor), prebicat_2cell_struct C. Proof. exists bcat_precategory_ob_mor. exact bcat_cell_struct. Defined. Definition bcat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. use tpair. - exists bcat_precategory_ob_mor. use tpair. + simpl. intros. exact (identity1 _). + simpl. intros a b c f g. exact (compose1 f g). - exact bcat_cell_struct. Defined. (* Definition bcat_cells_1_id_comp : ∑ C : prebicat_ob_mor_cells, precategory_id_comp C. Proof. exists bcat_ob_mor_cells. split. - simpl. intros. exact (identity1 _). - simpl. intros a b c f g. exact (compose1 f g). Defined. *) Definition bcat_2_id_comp_struct : prebicat_2_id_comp_struct bcat_1_id_comp_cells. Proof. repeat split; simpl; unfold bcat_cell_struct. - (* 2-unit *) intros. exact (identity _). - (* left unitor *) intros. exact (left_unitor f). - (* right unitor *) intros. exact (right_unitor f). - (* left inverse unitor *) intros. exact (inv_from_z_iso (left_unitor f)). - (* right inverse unitor *) intros. exact (inv_from_z_iso (right_unitor f)). - (* right associator *) intros. exact (inv_from_z_iso (associator f g h)). - (* left associator *) intros. exact (associator_2mor f g h). - (* vertical composition *) intros a b f g h x y. exact (x · y). - (* left whiskering *) intros a b c f g1 g2 x. exact (whisker_left f x). - (* right whiskering *) intros a b c f1 f2 g x. exact (whisker_right x g). Defined. Definition bcat_data : ∑ C, prebicat_2_id_comp_struct C. Proof. exists bcat_1_id_comp_cells. exact bcat_2_id_comp_struct. Defined. Theorem bcat_laws : prebicat_laws bcat_data. Proof. repeat split; unfold id2, vcomp2, runitor, lunitor, rinvunitor, linvunitor, rassociator, lassociator, lwhisker, rwhisker; simpl; unfold bcat_precategory_ob_mor, bcat_cell_struct, bcat_ob_mor_cells, bcat_1_id_comp_cells, bcat_2_id_comp_struct, bcat_data; simpl; first [ intros until 1 | intros ]. - (* 1a id2_left *) apply id_left. - (* 1b id2_right *) apply id_right. - (* 2 vassocr *) apply assoc. - (* 3a lwhisker_id2 *) apply whisker_left_id_2mor. - (* 3b id2_rwhisker *) apply whisker_right_id_2mor. - (* 4 lwhisker_vcomp *) apply pathsinv0, whisker_left_on_comp. - (* 5 rwhisker_vcomp *) apply pathsinv0, whisker_right_on_comp. - (* 6 vcomp_lunitor *) apply left_unitor_naturality. - (* 7 vcomp_runitor *) apply right_unitor_naturality. - (* 8 lwhisker_lwhisker *) apply whisker_left_left. - (* 9 rwhisker_lwhisker *) apply whisker_left_right. - (* 10 rwhisker_rwhisker *) apply whisker_right_right. - (* 11 vcomp_whisker *) apply twomor_naturality. - (* 12a lunitor_linvunitor *) apply (z_iso_inv_after_z_iso (left_unitor f)). - (* 12b linvunitor_lunitor *) apply (z_iso_after_z_iso_inv (left_unitor f)). - (* 13a runitor_rinvunitor *) apply (z_iso_inv_after_z_iso (right_unitor f)). - (* 13b rinvunitor_runitor *) apply (z_iso_after_z_iso_inv (right_unitor f)). - (* 14a lassociator_rassociator *) apply (z_iso_inv_after_z_iso (associator f g h)). - (* 14b rassociator_lassociator *) apply (z_iso_after_z_iso_inv (associator f g h)). - (* 15 runitor_rwhisker *) apply pathsinv0, (triangle_axiom f g). - (* 16 lassociator_lassociator *) apply pathsinv0, (pentagon_axiom f g h). Defined. Definition bcat : prebicat := (bcat_data,, bcat_laws). End unfold_data. UniMath-20231010/UniMath/Bicategories/BicategoryOfBicat.v000066400000000000000000000121031451125700300227600ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) (* =================================================================================== *) (* Every (pre)bicategory of UniMath.Bicategories.Core.Bicat is a *) (* (pre)bicategory of UniMath.Bicategories.WkCatEnrichment. *) (* =================================================================================== *) (* Note: an equivalence is established in WkCatEnrichment/hcomp_bicat.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.WkCatEnrichment.Notations. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Local Open Scope cat. Local Notation "C 'c×' D" := (precategory_binproduct C D) (at level 75, right associativity). Section Build_Bicategory. Variable C : bicat. Definition bicate_ob_hom : prebicategory_ob_hom. Proof. exists C. exact (λ a b : C, hom a b). Defined. Definition bicate_id_comp : prebicategory_id_comp. Proof. exists bicate_ob_hom; unfold bicate_ob_hom; simpl; split. - exact identity. - unfold hom_data, hom_ob_mor. simpl. intros a b c. apply hcomp_functor. Defined. (* ----------------------------------------------------------------------------------- *) (* Left associator. *) Definition bicate_lassociator_fun {a b c d : bicate_id_comp} (x : C ⟦ a, b ⟧ × C ⟦ b, c ⟧ × C ⟦ c, d ⟧) : pr1 x · (pr12 x · pr22 x) ==> pr1 x · pr12 x · pr22 x := lassociator (pr1 x) (pr12 x) (pr22 x). Lemma bicate_lassociator_fun_natural {a b c d : bicate_id_comp} : is_nat_trans (functor_composite (pair_functor (functor_identity _) (compose_functor b c d)) hcomp_functor) (functor_composite (precategory_binproduct_assoc (hom a b) (hom b c) (hom c d)) (functor_composite (pair_functor (compose_functor a b c) (functor_identity _)) hcomp_functor)) bicate_lassociator_fun. Proof. red; cbn. intros (f1, (f2, f3)) (g1, (g2, g3)). unfold precategory_binproduct_mor, hom_ob_mor. simpl. unfold precategory_binproduct_mor, hom_ob_mor. simpl. intros (x1, (x2, x3)). simpl. unfold bicate_lassociator_fun. simpl. apply hcomp_lassoc. Defined. Definition bicate_lassociator (a b c d : bicate_id_comp) : associator_trans_type a b c d. Proof. exists bicate_lassociator_fun. exact bicate_lassociator_fun_natural. Defined. Lemma bicate_transfs : (∏ a b c d : bicate_id_comp, associator_trans_type a b c d) × (∏ a b : bicate_id_comp, left_unitor_trans_type a b) × (∏ a b : bicate_id_comp, right_unitor_trans_type a b). Proof. repeat split; red; cbn. - exact lassociator_transf. - exact lunitor_transf. - exact runitor_transf. Defined. Definition bicate_data : prebicategory_data. Proof. exists bicate_id_comp. exact bicate_transfs. Defined. Lemma prebicat_associator_and_unitors_are_iso : associator_and_unitors_are_iso bicate_data. Proof. repeat split; cbn; intros. - apply is_z_iso_lassociator. - apply is_z_iso_lunitor. - apply is_z_iso_runitor. Defined. Lemma triangle_identity {a b c : C} (f : C ⟦ a, b ⟧) (g : C ⟦ b, c ⟧) : id2 f ⋆ lunitor g = lassociator f (identity b) g • (runitor f ⋆ id2 g). Proof. unfold hcomp at 2. rewrite vassocr. rewrite runitor_rwhisker. rewrite hcomp_hcomp'. unfold hcomp'. apply maponpaths. rewrite lwhisker_id2. apply id2_rwhisker. Defined. Lemma pentagon_identity {a b c d e : C} (k : C ⟦ a, b ⟧) (h : C ⟦ b, c ⟧) (g : C ⟦ c, d ⟧) (f : C ⟦ d, e ⟧) : lassociator k h (g · f) • lassociator (k · h) g f = ((id2 k ⋆ lassociator h g f) • lassociator k (h · g) f) • (lassociator k h g ⋆ id2 f). Proof. rewrite <- lassociator_lassociator. unfold hcomp at 2. rewrite lwhisker_id2. rewrite id2_right. apply maponpaths_2. apply maponpaths_2. unfold hcomp. rewrite id2_rwhisker. apply pathsinv0. apply id2_left. Defined. Lemma prebicat_prebicategory_coherence : prebicategory_coherence bicate_data. Proof. split. - intros. apply pentagon_identity. - intros. apply triangle_identity. Defined. Hypothesis sc : isaset_cells C. Lemma is_prebicategory_bicate : is_prebicategory bicate_data. Proof. split. - exact prebicat_associator_and_unitors_are_iso. - exact prebicat_prebicategory_coherence. Qed. Definition prebicategory_of_prebicat : prebicategory. Proof. exists bicate_data. exact is_prebicategory_bicate. Defined. End Build_Bicategory. UniMath-20231010/UniMath/Bicategories/Colimits/000077500000000000000000000000001451125700300210375ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Colimits/CoproductEquivalences.v000066400000000000000000000331711451125700300255420ustar00rootroot00000000000000(************************************************************************ Equivalences for coproducts ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Colimits.Coproducts. Local Open Scope cat. (** Suppose, we have a diagram as follows ι₁ ι₂ x₁ ------> p <------ x₂ | | | l₁ ≃ l₃ ≃ l₂ | γ₁ | γ₂ | V V V y₁ ------> q <------ y₂ λ₁ κ₂ where l₁, l₂, and l₃ are adjoint equivalences. If the top row is a product cone, then so is the bottom row *) Section CoproductEquivalence. Context {B : bicat} {x₁ x₂ p y₁ y₂ q : B} (ι₁ : x₁ --> p) (ι₂ : x₂ --> p) (cone₁ := make_bincoprod_cocone p ι₁ ι₂) (Hp : has_bincoprod_ump cone₁) (κ₁ : y₁ --> q) (κ₂ : y₂ --> q) (cone₂ := make_bincoprod_cocone q κ₁ κ₂) (l₁ : x₁ --> y₁) (l₂ : x₂ --> y₂) (l₃ : p --> q) (Hl₁ : left_adjoint_equivalence l₁) (Hl₂ : left_adjoint_equivalence l₂) (Hl₃ : left_adjoint_equivalence l₃) (γ₁ : invertible_2cell (l₁ · κ₁) (ι₁ · l₃)) (γ₂ : invertible_2cell (l₂ · κ₂) (ι₂ · l₃)). Let r₁ : y₁ --> x₁ := left_adjoint_right_adjoint Hl₁. Let η₁ : invertible_2cell (id₁ _) (l₁ · r₁) := left_equivalence_unit_iso Hl₁. Let ε₁ : invertible_2cell (r₁ · l₁) (id₁ _) := left_equivalence_counit_iso Hl₁. Let r₂ : y₂ --> x₂ := left_adjoint_right_adjoint Hl₂. Let η₂ : invertible_2cell (id₁ _) (l₂ · r₂) := left_equivalence_unit_iso Hl₂. Let ε₂ : invertible_2cell (r₂ · l₂) (id₁ _) := left_equivalence_counit_iso Hl₂. Let r₃ : q --> p := left_adjoint_right_adjoint Hl₃. Let η₃ : invertible_2cell (id₁ _) (l₃ · r₃) := left_equivalence_unit_iso Hl₃. Let ε₃ : invertible_2cell (r₃ · l₃) (id₁ _) := left_equivalence_counit_iso Hl₃. Let γ₁' : invertible_2cell (κ₁ · r₃) (r₁ · ι₁) := comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell ε₁)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ γ₁) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell η₃)) (runitor_invertible_2cell _)))))))). Let γ₂' : invertible_2cell (κ₂ · r₃) (r₂ · ι₂) := comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell ε₂)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ γ₂) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell η₃)) (runitor_invertible_2cell _)))))))). Definition has_bincoprod_ump_1_left_adjoint_equivalence : bincoprod_ump_1 cone₂. Proof. intros c. use make_bincoprod_1cell. - refine (r₃ · _). exact (bincoprod_ump_1cell Hp (l₁ · bincoprod_cocone_inl c) (l₂ · bincoprod_cocone_inr c)). - exact (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ γ₁') (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (bincoprod_ump_1cell_inl Hp _ _ _)) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ ε₁) (lunitor_invertible_2cell _))))))). - exact (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ γ₂') (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (bincoprod_ump_1cell_inr Hp _ _ _)) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ ε₂) (lunitor_invertible_2cell _))))))). Defined. Section UMP2. Context {c : B} {φ ψ : q --> c} (α : κ₁ · φ ==> κ₁ · ψ) (β : κ₂ · φ ==> κ₂ · ψ). Definition has_bincoprod_ump_2_left_adjoint_equivalence_unique : isaprop (∑ (γ : φ ==> ψ), κ₁ ◃ γ = α × κ₂ ◃ γ = β). Proof. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } apply (adj_equiv_faithful (bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence _ Hl₃)). cbn. use (bincoprod_ump_2cell_unique_alt Hp) ; cbn. - use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !lwhisker_lwhisker_rassociator. apply maponpaths_2. use (vcomp_lcancel (γ₁ ▹ _)). { is_iso. apply property_from_invertible_2cell. } rewrite !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- !lwhisker_lwhisker. apply maponpaths_2. apply maponpaths. exact (pr12 ζ₁ @ !(pr12 ζ₂)). - use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !lwhisker_lwhisker_rassociator. apply maponpaths_2. use (vcomp_lcancel (γ₂ ▹ _)). { is_iso. apply property_from_invertible_2cell. } rewrite !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- !lwhisker_lwhisker. apply maponpaths_2. apply maponpaths. exact (pr22 ζ₁ @ !(pr22 ζ₂)). Qed. Let Hr₁ : @left_adjoint_equivalence (op1_bicat B) _ _ r₁ := bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence _ (pr2 (inv_adjequiv (_ ,, Hl₁))). Let Hr₂ : @left_adjoint_equivalence (op1_bicat B) _ _ r₂ := bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence _ (pr2 (inv_adjequiv (_ ,, Hl₂))). Let α' : ι₁ · (l₃ · φ) ==> ι₁ · (l₃ · ψ) := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hr₁) (lassociator _ _ _ • ((γ₁')^-1 ▹ _) • rassociator _ _ _ • (_ ◃ lassociator _ _ _) • (_ ◃ (ε₃ ▹ _)) • (_ ◃ lunitor φ) • α • (_ ◃ linvunitor ψ) • (_ ◃ (ε₃^-1 ▹ _)) • (_ ◃ rassociator _ _ _) • lassociator _ _ _ • (γ₁' ▹ _) • rassociator _ _ _). Let β' : ι₂ · (l₃ · φ) ==> ι₂ · (l₃ · ψ) := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hr₂) (lassociator _ _ _ • ((γ₂')^-1 ▹ _) • rassociator _ _ _ • (_ ◃ lassociator _ _ _) • (_ ◃ (ε₃ ▹ _)) • (_ ◃ lunitor _) • β • (_ ◃ linvunitor _) • (_ ◃ (ε₃^-1 ▹ _)) • (_ ◃ rassociator _ _ _) • lassociator _ _ _ • (γ₂' ▹ _) • rassociator _ _ _). Definition has_bincoprod_ump_2_left_adjoint_equivalence_cell : φ ==> ψ := linvunitor _ • (ε₃^-1 ▹ _) • rassociator _ _ _ • (_ ◃ bincoprod_ump_2cell Hp α' β') • lassociator _ _ _ • (ε₃ ▹ _) • lunitor _. Definition has_bincoprod_ump_2_left_adjoint_equivalence_inl : κ₁ ◃ has_bincoprod_ump_2_left_adjoint_equivalence_cell = α. Proof. unfold has_bincoprod_ump_2_left_adjoint_equivalence_cell. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn -[ε₃ α' β']. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. use (vcomp_lcancel ((γ₁')^-1 ▹ _)). { is_iso. } rewrite !vassocr. rewrite vcomp_whisker. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply( bincoprod_ump_2cell_inl Hp). } use vcomp_move_R_Mp. { is_iso. apply ε₃. } cbn -[ε₃ γ₁' α']. rewrite !vassocr. apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hr₁)). Qed. Definition has_bincoprod_ump_2_left_adjoint_equivalence_inr : κ₂ ◃ has_bincoprod_ump_2_left_adjoint_equivalence_cell = β. Proof. unfold has_bincoprod_ump_2_left_adjoint_equivalence_cell. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn -[ε₃ α' β']. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. use (vcomp_lcancel ((γ₂')^-1 ▹ _)). { is_iso. } rewrite !vassocr. rewrite vcomp_whisker. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply( bincoprod_ump_2cell_inr Hp). } use vcomp_move_R_Mp. { is_iso. apply ε₃. } cbn -[ε₃ γ₂' β']. rewrite !vassocr. apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hr₂)). Qed. End UMP2. Definition has_bincoprod_ump_2_left_adjoint_equivalence : bincoprod_ump_2 cone₂. Proof. intros c φ ψ α β. use iscontraprop1. - exact (has_bincoprod_ump_2_left_adjoint_equivalence_unique α β). - simple refine (_ ,, _ ,, _). + exact (has_bincoprod_ump_2_left_adjoint_equivalence_cell α β). + exact (has_bincoprod_ump_2_left_adjoint_equivalence_inl α β). + exact (has_bincoprod_ump_2_left_adjoint_equivalence_inr α β). Defined. Definition has_bincoprod_ump_left_adjoint_equivalence : has_bincoprod_ump cone₂. Proof. simple refine (_ ,, _). - exact has_bincoprod_ump_1_left_adjoint_equivalence. - exact has_bincoprod_ump_2_left_adjoint_equivalence. Defined. End CoproductEquivalence. UniMath-20231010/UniMath/Bicategories/Colimits/Coproducts.v000066400000000000000000000731441451125700300233640ustar00rootroot00000000000000(**************************************************************** Coproducts in bicategories In this file we define the notion of coproduct diagram in arbitrary bicategories. For this definition, there are 2 possibilities. One could either write universal properties, which expresses the existence of a morphism up to a unique 2-cell. Alternatively, one could define the universal property via the hom-categories. Here, we choose the first approach. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Local Open Scope cat. Section Coproduct. Context {B : bicat} {b₁ b₂ : B}. (** Cones on the diagram *) Definition bincoprod_cocone : UU := ∑ (p : B), b₁ --> p × b₂ --> p. Coercion bincoprod_cocone_obj (p : bincoprod_cocone) : B := pr1 p. Definition bincoprod_cocone_inl (p : bincoprod_cocone) : b₁ --> p := pr12 p. Definition bincoprod_cocone_inr (p : bincoprod_cocone) : b₂ --> p := pr22 p. Definition make_bincoprod_cocone (p : B) (π₁ : b₁ --> p) (π₂ : b₂ --> p) : bincoprod_cocone := (p ,, π₁ ,, π₂). (** 1-cells between cocones *) Definition bincoprod_1cell (p q : bincoprod_cocone) : UU := ∑ (φ : p --> q), invertible_2cell (bincoprod_cocone_inl p · φ) (bincoprod_cocone_inl q) × invertible_2cell (bincoprod_cocone_inr p · φ) (bincoprod_cocone_inr q). Coercion bincoprod_1cell_1cell {p q : bincoprod_cocone} (φ : bincoprod_1cell p q) : p --> q := pr1 φ. Definition bincoprod_1cell_inl {p q : bincoprod_cocone} (φ : bincoprod_1cell p q) : invertible_2cell (bincoprod_cocone_inl p · φ) (bincoprod_cocone_inl q) := pr12 φ. Definition bincoprod_1cell_inr {p q : bincoprod_cocone} (φ : bincoprod_1cell p q) : invertible_2cell (bincoprod_cocone_inr p · φ) (bincoprod_cocone_inr q) := pr22 φ. Definition make_bincoprod_1cell {p q : bincoprod_cocone} (φ : p --> q) (τ : invertible_2cell (bincoprod_cocone_inl p · φ) (bincoprod_cocone_inl q)) (θ : invertible_2cell (bincoprod_cocone_inr p · φ) (bincoprod_cocone_inr q)) : bincoprod_1cell p q := (φ ,, τ ,, θ). Definition eq_bincoprod_1cell {p q : bincoprod_cocone} (φ ψ : bincoprod_1cell p q) (r₁ : pr1 φ = pr1 ψ) (r₂ : pr1 (bincoprod_1cell_inl φ) = (bincoprod_cocone_inl p ◃ idtoiso_2_1 _ _ r₁) • pr1 (bincoprod_1cell_inl ψ)) (r₃ : pr1 (bincoprod_1cell_inr φ) = (bincoprod_cocone_inr p ◃ idtoiso_2_1 _ _ r₁) • pr1 (bincoprod_1cell_inr ψ)) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ [ φ₃ φ₄ ]]]. induction ψ as [ ψ₁ [ ψ₂ [ ψ₃ ψ₄ ]]]. cbn in r₁. induction r₁ ; cbn in r₂. apply maponpaths. assert (φ₂ = ψ₂) as r'. { use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite lwhisker_id2, id2_left in r₂. exact r₂. } induction r'. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. cbn in r₃. rewrite lwhisker_id2, id2_left in r₃. exact r₃. Qed. (** Statements of universal mapping properties of coproducts *) Section UniversalMappingPropertyStatements. Variable (p : bincoprod_cocone). Definition bincoprod_ump_1 : UU := ∏ (q : bincoprod_cocone), bincoprod_1cell p q. Definition bincoprod_ump_2 : UU := ∏ (a : B) (φ ψ : p --> a) (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ), ∃! (γ : φ ==> ψ), (bincoprod_cocone_inl p ◃ γ = α) × (bincoprod_cocone_inr p ◃ γ = β). Definition has_bincoprod_ump : UU := bincoprod_ump_1 × bincoprod_ump_2. Definition has_bincoprod_ump_1 (H : has_bincoprod_ump) : bincoprod_ump_1 := pr1 H. Definition has_bincoprod_ump_2 (H : has_bincoprod_ump) : bincoprod_ump_2 := pr2 H. Definition has_bincoprod_ump_2_cell : UU := ∏ (a : B) (φ ψ : p --> a) (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ), φ ==> ψ. Definition has_bincoprod_ump_2_cell_pr1 (υ : has_bincoprod_ump_2_cell) := ∏ (a : B) (φ ψ : p --> a) (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ), bincoprod_cocone_inl p ◃ υ a φ ψ α β = α. Definition has_bincoprod_ump_2_cell_pr2 (υ : has_bincoprod_ump_2_cell) := ∏ (a : B) (φ ψ : p --> a) (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ), bincoprod_cocone_inr p ◃ υ a φ ψ α β = β. Definition has_bincoprod_ump_2_cell_unique : UU := ∏ (a : B) (φ ψ : p --> a) (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) (γ δ : φ ==> ψ) (γinl : bincoprod_cocone_inl p ◃ γ = α) (γinr : bincoprod_cocone_inr p ◃ γ = β) (δinl : bincoprod_cocone_inl p ◃ δ = α) (δinr : bincoprod_cocone_inr p ◃ δ = β), γ = δ. Definition make_bincoprod_ump (υ₁ : bincoprod_ump_1) (υ₂ : has_bincoprod_ump_2_cell) (υ₂pr1 : has_bincoprod_ump_2_cell_pr1 υ₂) (υ₂pr2 : has_bincoprod_ump_2_cell_pr2 υ₂) (υ₃ : has_bincoprod_ump_2_cell_unique) : has_bincoprod_ump. Proof. split. - exact υ₁. - intros q f₁ f₂ α β. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (υ₃ q f₁ f₂ α β (pr1 φ₁) (pr1 φ₂) (pr12 φ₁) (pr22 φ₁) (pr12 φ₂) (pr22 φ₂))). + simple refine (_ ,, _ ,, _). * exact (υ₂ q f₁ f₂ α β). * abstract (apply υ₂pr1). * abstract (apply υ₂pr2). Defined. End UniversalMappingPropertyStatements. Section Projections. Context {p : bincoprod_cocone} (H : has_bincoprod_ump p). Definition bincoprod_ump_1cell {a : B} (ainl : b₁ --> a) (ainr : b₂ --> a) : p --> a := has_bincoprod_ump_1 _ H (make_bincoprod_cocone a ainl ainr). Definition bincoprod_ump_1cell_inl (a : B) (ainl : b₁ --> a) (ainr : b₂ --> a) : invertible_2cell (bincoprod_cocone_inl p · bincoprod_ump_1cell ainl ainr) ainl := bincoprod_1cell_inl (has_bincoprod_ump_1 _ H (make_bincoprod_cocone a ainl ainr)). Definition bincoprod_ump_1cell_inr (a : B) (ainl : b₁ --> a) (ainr : b₂ --> a) : invertible_2cell (bincoprod_cocone_inr p · bincoprod_ump_1cell ainl ainr) ainr := bincoprod_1cell_inr (has_bincoprod_ump_1 _ H (make_bincoprod_cocone a ainl ainr)). Definition bincoprod_ump_2cell {a : B} {φ ψ : p --> a} (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) : φ ==> ψ := pr11 (has_bincoprod_ump_2 _ H a φ ψ α β). Definition bincoprod_ump_2cell_inl {a : B} {φ ψ : p --> a} (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) : bincoprod_cocone_inl p ◃ bincoprod_ump_2cell α β = α := pr121 (has_bincoprod_ump_2 _ H a φ ψ α β). Definition bincoprod_ump_2cell_inr {a : B} {φ ψ : p --> a} (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) : bincoprod_cocone_inr p ◃ bincoprod_ump_2cell α β = β := pr221 (has_bincoprod_ump_2 _ H a φ ψ α β). Definition bincoprod_ump_2cell_unique {a : B} {φ ψ : p --> a} (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) (γ δ : φ ==> ψ) (γinl : bincoprod_cocone_inl p ◃ γ = α) (γinr : bincoprod_cocone_inr p ◃ γ = β) (δinl : bincoprod_cocone_inl p ◃ δ = α) (δinr : bincoprod_cocone_inr p ◃ δ = β) : γ = δ. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (has_bincoprod_ump_2 _ H a φ ψ α β)) (γ ,, (γinl ,, γinr)) (δ ,, (δinl ,, δinr)))). Qed. Definition bincoprod_ump_2cell_unique_alt {a : B} {φ ψ : p --> a} (γ δ : φ ==> ψ) (pinl : bincoprod_cocone_inl p ◃ γ = bincoprod_cocone_inl p ◃ δ) (pinr : bincoprod_cocone_inr p ◃ γ = bincoprod_cocone_inr p ◃ δ) : γ = δ. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (has_bincoprod_ump_2 _ H a φ ψ _ _)) (γ ,, (idpath _ ,, idpath _)) (δ ,, (!pinl ,, !pinr)))). Qed. Definition bincoprod_ump_2cell_invertible {a : B} {φ ψ : p --> a} (α : bincoprod_cocone_inl p · φ ==> bincoprod_cocone_inl p · ψ) (β : bincoprod_cocone_inr p · φ ==> bincoprod_cocone_inr p · ψ) (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β) : is_invertible_2cell (bincoprod_ump_2cell α β). Proof. use make_is_invertible_2cell. - exact (bincoprod_ump_2cell (Hα^-1) (Hβ^-1)). - use (bincoprod_ump_2cell_unique (id2 _) (id2 _)). + abstract (rewrite <- !lwhisker_vcomp ; rewrite !bincoprod_ump_2cell_inl ; rewrite vcomp_rinv ; apply idpath). + abstract (rewrite <- !lwhisker_vcomp ; rewrite !bincoprod_ump_2cell_inr ; rewrite vcomp_rinv ; apply idpath). + abstract (apply lwhisker_id2). + abstract (apply lwhisker_id2). - use (bincoprod_ump_2cell_unique (id2 _) (id2 _)). + abstract (rewrite <- !lwhisker_vcomp ; rewrite !bincoprod_ump_2cell_inl ; rewrite vcomp_linv ; apply idpath). + abstract (rewrite <- !lwhisker_vcomp ; rewrite !bincoprod_ump_2cell_inr ; rewrite vcomp_linv ; apply idpath). + abstract (apply lwhisker_id2). + abstract (apply lwhisker_id2). Defined. End Projections. Definition isaprop_has_bincoprod_ump (p : bincoprod_cocone) (HB_2_1 : is_univalent_2_1 B) : isaprop (has_bincoprod_ump p). Proof. use invproofirrelevance. intros χ₁ χ₂. use pathsdirprod. - use funextsec ; intro q. use eq_bincoprod_1cell. + use (isotoid_2_1 HB_2_1). use make_invertible_2cell. * use (bincoprod_ump_2cell χ₂). ** exact (comp_of_invertible_2cell (bincoprod_1cell_inl (pr1 χ₁ q)) (inv_of_invertible_2cell (bincoprod_1cell_inl (pr1 χ₂ q)))). ** exact (comp_of_invertible_2cell (bincoprod_1cell_inr (pr1 χ₁ q)) (inv_of_invertible_2cell (bincoprod_1cell_inr (pr1 χ₂ q)))). * use bincoprod_ump_2cell_invertible. ** apply property_from_invertible_2cell. ** apply property_from_invertible_2cell. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite bincoprod_ump_2cell_inl. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite bincoprod_ump_2cell_inr. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - repeat (use funextsec ; intro). apply isapropiscontr. Qed. (** Formulation via hom-categories *) Definition universal_coprod_functor_data (p : bincoprod_cocone) (x : B) : functor_data (hom p x) (category_binproduct (hom b₁ x) (hom b₂ x)). Proof. use make_functor_data. - exact (λ f, bincoprod_cocone_inl p · f ,, bincoprod_cocone_inr p · f). - exact (λ f₁ f₂ α, _ ◃ α ,, _ ◃ α). Defined. Definition universal_coprod_is_functor (p : bincoprod_cocone) (x : B) : is_functor (universal_coprod_functor_data p x). Proof. split. - intro f. use pathsdirprod ; cbn. + apply lwhisker_id2. + apply lwhisker_id2. - intros f₁ f₂ f₃ α β. use pathsdirprod ; cbn. + refine (!_). apply lwhisker_vcomp. + refine (!_). apply lwhisker_vcomp. Qed. Definition universal_coprod_functor (p : bincoprod_cocone) (x : B) : hom p x ⟶ category_binproduct (hom b₁ x) (hom b₂ x). Proof. use make_functor. - exact (universal_coprod_functor_data p x). - exact (universal_coprod_is_functor p x). Defined. Definition is_universal_coprod_cocone (p : bincoprod_cocone) : UU := ∏ (x : B), adj_equivalence_of_cats (universal_coprod_functor p x). (** Equivalence of the two formulations *) Section UniversalFromUMP. Context {p : bincoprod_cocone} (Hp : has_bincoprod_ump p) (x : B). Definition make_is_universal_coprod_cocone_full : full (universal_coprod_functor p x). Proof. intros u₁ u₂ α. apply hinhpr. simple refine (_ ,, _). - use (bincoprod_ump_2cell Hp). + exact (pr1 α). + exact (pr2 α). - use pathsdirprod. + apply bincoprod_ump_2cell_inl. + apply bincoprod_ump_2cell_inr. Defined. Definition make_is_universal_coprod_cocone_faithful : faithful (universal_coprod_functor p x). Proof. intros u₁ u₂ α. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (bincoprod_ump_2cell_unique Hp). - exact (pr1 α). - exact (pr2 α). - exact (maponpaths pr1 (pr2 φ₁)). - exact (maponpaths dirprod_pr2 (pr2 φ₁)). - exact (maponpaths pr1 (pr2 φ₂)). - exact (maponpaths dirprod_pr2 (pr2 φ₂)). Qed. Definition make_is_universal_coprod_cocone_essentially_surjective : essentially_surjective (universal_coprod_functor p x). Proof. intros f. use hinhpr. simple refine (_ ,, _). - exact (bincoprod_ump_1cell Hp (pr1 f) (pr2 f)). - use category_binproduct_z_iso_map. refine (_ ,, _). + use inv2cell_to_z_iso ; cbn. apply bincoprod_ump_1cell_inl. + use inv2cell_to_z_iso ; cbn. apply bincoprod_ump_1cell_inr. Defined. End UniversalFromUMP. Definition make_is_universal_coprod_cocone (HB_2_1 : is_univalent_2_1 B) (p : bincoprod_cocone) (Hp : has_bincoprod_ump p) : is_universal_coprod_cocone p. Proof. intro x. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + apply make_is_universal_coprod_cocone_full. apply Hp. + apply make_is_universal_coprod_cocone_faithful. apply Hp. - apply make_is_universal_coprod_cocone_essentially_surjective. apply Hp. Defined. Section UniversalCoprodHasUMP. Context (p : bincoprod_cocone) (Hp : is_universal_coprod_cocone p). Definition universal_coprod_cocone_has_ump_1 : bincoprod_ump_1 p. Proof. intro q. use make_bincoprod_1cell. - exact (right_adjoint (Hp q) (bincoprod_cocone_inl q ,, bincoprod_cocone_inr q)). - apply z_iso_to_inv2cell. exact (pr1 (category_binproduct_z_iso_inv _ _ (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (Hp q)) (bincoprod_cocone_inl q ,, bincoprod_cocone_inr q)))). - apply z_iso_to_inv2cell. exact (pr2 (category_binproduct_z_iso_inv _ _ (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (Hp q)) (bincoprod_cocone_inl q ,, bincoprod_cocone_inr q)))). Defined. Definition universal_coprod_cocone_has_ump_2_unique {x : B} {u₁ u₂ : p --> x} (ζ₁ : bincoprod_cocone_inl p · u₁ ==> bincoprod_cocone_inl p · u₂) (ζ₂ : bincoprod_cocone_inr p · u₁ ==> bincoprod_cocone_inr p · u₂) : isaprop (∑ (γ : u₁ ==> u₂), bincoprod_cocone_inl p ◃ γ = ζ₁ × bincoprod_cocone_inr p ◃ γ = ζ₂). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use (invmaponpathsweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (Hp x) u₁ u₂))) ; cbn. apply pathsdirprod. - exact (pr12 φ₁ @ !(pr12 φ₂)). - exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Definition universal_coprod_cocone_has_ump_2 : bincoprod_ump_2 p. Proof. intros x u₁ u₂ ζ₁ ζ₂. use iscontraprop1. - exact (universal_coprod_cocone_has_ump_2_unique ζ₁ ζ₂). - simple refine (_ ,, _ ,, _). + exact (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (Hp x) u₁ u₂)) (ζ₁ ,, ζ₂)). + abstract (exact (maponpaths pr1 (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (Hp x) u₁ u₂)) (ζ₁ ,, ζ₂)))). + abstract (exact (maponpaths dirprod_pr2 (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (Hp x) u₁ u₂)) (ζ₁ ,, ζ₂)))). Defined. End UniversalCoprodHasUMP. Definition universal_coprod_cocone_has_ump (p : bincoprod_cocone) (Hp : is_universal_coprod_cocone p) : has_bincoprod_ump p. Proof. refine (_ ,, _). - exact (universal_coprod_cocone_has_ump_1 p Hp). - exact (universal_coprod_cocone_has_ump_2 p Hp). Defined. Definition isaprop_is_universal_inserter_cone (HB_2_1 : is_univalent_2_1 B) (p : bincoprod_cocone) : isaprop (is_universal_coprod_cocone p). Proof. use impred ; intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 _ _) (univalent_category_binproduct (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _)) (universal_coprod_functor p x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 _ _) (univalent_category_binproduct (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _)) (universal_coprod_functor p x)). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. Definition has_binprod_ump_weq_universal (HB_2_1 : is_univalent_2_1 B) (p : bincoprod_cocone) : has_bincoprod_ump p ≃ is_universal_coprod_cocone p. Proof. use weqimplimpl. - exact (make_is_universal_coprod_cocone HB_2_1 p). - exact (universal_coprod_cocone_has_ump p). - apply isaprop_has_bincoprod_ump. exact HB_2_1. - apply isaprop_is_universal_inserter_cone. exact HB_2_1. Defined. End Coproduct. Arguments bincoprod_cocone {_} _ _. Definition has_bincoprod (B : bicat) : UU := ∏ (b₁ b₂ : B), ∑ (p : bincoprod_cocone b₁ b₂), has_bincoprod_ump p. Definition bicat_with_bincoprod : UU := ∑ (B : bicat), has_bincoprod B. Coercion bicat_with_bincoprod_to_bicat (B : bicat_with_bincoprod) : bicat := pr1 B. Definition bincoprod_of (B : bicat_with_bincoprod) : has_bincoprod B := pr2 B. (** Some useful functions *) Section StandardFunctions. Context (B : bicat_with_bincoprod). Definition bincoprod (b₁ b₂ : B) : B := pr1 (bincoprod_of B b₁ b₂). Local Notation "b₁ ⊕ b₂" := (bincoprod b₁ b₂). Definition bincoprod_inl (b₁ b₂ : B) : b₁ --> b₁ ⊕ b₂ := bincoprod_cocone_inl (pr1 (bincoprod_of B b₁ b₂)). Definition bincoprod_inr (b₁ b₂ : B) : b₂ --> b₁ ⊕ b₂ := bincoprod_cocone_inr (pr1 (bincoprod_of B b₁ b₂)). Local Notation "'ι₁'" := (bincoprod_inl _ _). Local Notation "'ι₂'" := (bincoprod_inr _ _). Definition coprod_1cell {b₁ b₂ c : B} (f : b₁ --> c) (g : b₂ --> c) : b₁ ⊕ b₂ --> c := bincoprod_ump_1cell (pr2 (bincoprod_of B b₁ b₂)) f g. Local Notation "[ f , g ]" := (coprod_1cell f g). Definition coprod_1cell_inl {b₁ b₂ c : B} (f : b₁ --> c) (g : b₂ --> c) : invertible_2cell (ι₁ · [ f , g ]) f := bincoprod_ump_1cell_inl (pr2 (bincoprod_of B b₁ b₂)) _ f g. Definition coprod_1cell_inr {b₁ b₂ c : B} (f : b₁ --> c) (g : b₂ --> c) : invertible_2cell (ι₂ · [ f , g ]) g := bincoprod_ump_1cell_inr (pr2 (bincoprod_of B b₁ b₂)) _ f g. Definition sum_1cell {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : a₁ ⊕ a₂ --> b₁ ⊕ b₂ := [ f · ι₁ , g · ι₂ ]. Local Notation "f '⊕₁' g" := (sum_1cell f g) (at level 34, left associativity). Definition sum_1cell_inl {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : invertible_2cell (ι₁ · f ⊕₁ g) (f · ι₁) := coprod_1cell_inl (f · ι₁) (g · ι₂). Definition sum_1cell_inr {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : invertible_2cell (ι₂ · f ⊕₁ g) (g · ι₂) := coprod_1cell_inr (f · ι₁) (g · ι₂). Definition coprod_2cell {b₁ b₂ c : B} {f₁ f₂ : b₁ --> c} {g₁ g₂ : b₂ --> c} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : [ f₁ , g₁ ] ==> [ f₂ , g₂ ]. Proof. use (bincoprod_ump_2cell (pr2 (bincoprod_of B b₁ b₂))). - exact (coprod_1cell_inl f₁ g₁ • α • (coprod_1cell_inl f₂ g₂)^-1). - exact (coprod_1cell_inr f₁ g₁ • β • (coprod_1cell_inr f₂ g₂)^-1). Defined. Local Notation "[[ α , β ]]" := (coprod_2cell α β). Definition coprod_2cell_is_invertible {b₁ b₂ c : B} {f₁ f₂ : b₁ --> c} {g₁ g₂ : b₂ --> c} {α : f₁ ==> f₂} {β : g₁ ==> g₂} (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β) : is_invertible_2cell [[ α , β ]]. Proof. use bincoprod_ump_2cell_invertible. - is_iso. apply property_from_invertible_2cell. - is_iso. apply property_from_invertible_2cell. Defined. Definition coprod_2cell_inl {b₁ b₂ c : B} {f₁ f₂ : b₁ --> c} {g₁ g₂ : b₂ --> c} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ι₁ ◃ [[ α , β ]] = coprod_1cell_inl f₁ g₁ • α • (coprod_1cell_inl f₂ g₂)^-1 := bincoprod_ump_2cell_inl _ _ _. Definition coprod_2cell_inr {b₁ b₂ c : B} {f₁ f₂ : b₁ --> c} {g₁ g₂ : b₂ --> c} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ι₂ ◃ [[ α , β ]] = coprod_1cell_inr f₁ g₁ • β • (coprod_1cell_inr f₂ g₂)^-1 := bincoprod_ump_2cell_inr _ _ _. Definition sum_2cell {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : f₁ ⊕₁ g₁ ==> f₂ ⊕₁ g₂ := [[ α ▹ ι₁ , β ▹ ι₂ ]]. Local Notation "α '⊕₂' β" := (sum_2cell α β) (at level 34, left associativity). Definition sum_2cell_inl {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ι₁ ◃ (α ⊕₂ β) = sum_1cell_inl f₁ g₁ • (α ▹ ι₁) • (sum_1cell_inl f₂ g₂)^-1 := coprod_2cell_inl (α ▹ ι₁) (β ▹ ι₂). Definition sum_2cell_inr {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ι₂ ◃ (α ⊕₂ β) = sum_1cell_inr f₁ g₁ • (β ▹ ι₂) • (sum_1cell_inr f₂ g₂)^-1 := coprod_2cell_inr (α ▹ ι₁) (β ▹ ι₂). End StandardFunctions. Module Notations. Notation "b₁ ⊕ b₂" := (bincoprod _ b₁ b₂). Notation "'ι₁'" := (bincoprod_inl _ _ _). Notation "'ι₂'" := (bincoprod_inr _ _ _). Notation "[ f , g ]" := (coprod_1cell _ f g). Notation "[[ α , β ]]" := (coprod_2cell _ α β). Notation "f '⊕₁' g" := (sum_1cell _ f g) (at level 34, left associativity). Notation "α '⊕₂' β" := (sum_2cell _ α β) (at level 34, left associativity). End Notations. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/000077500000000000000000000000001451125700300226155ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Colimits/Examples/BicatOfCatsColimits.v000066400000000000000000000102161451125700300266320ustar00rootroot00000000000000(******************************************************************** Colimits in the bicategory of categories Contents 1. Kleisli objects ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KleisliCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat. Require Import UniMath.Bicategories.Colimits.KleisliObjects. Local Open Scope cat. (** 1. Kleisli objects *) Section KleisliCategoryUMP. Context (m : mnd (op1_bicat bicat_of_cats)). Let C : category := ob_of_mnd m. Let M : Monad C := mnd_bicat_of_cats_to_Monad (mnd_op1_to_mnd m). Definition bicat_of_cats_has_kleisli_cocone : kleisli_cocone m. Proof. use make_kleisli_cocone. - exact (Kleisli_cat_monad M). - exact (Left_Kleisli_functor M). - exact (kleisli_monad_nat_trans M). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro x ; exact (η_η_bind M x)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro x ; exact (η_bind_bind M x)). Defined. Definition bicat_of_cats_has_kleisli_ump_1 : has_kleisli_ump_1 m bicat_of_cats_has_kleisli_cocone. Proof. intro q. pose (F := mor_of_kleisli_cocone _ q). pose (γ := cell_of_kleisli_cocone _ q). pose (p₁ := nat_trans_eq_pointwise (kleisli_cocone_unit _ q)). assert (p₂ : ∏ (x : C), pr1 γ (M x) · pr1 γ x = # (pr1 F) (μ M x) · pr1 γ x). { intro x. pose (p₂ := nat_trans_eq_pointwise (kleisli_cocone_mult _ q) x). cbn in p₂. rewrite !id_left in p₂. exact p₂. } use make_kleisli_cocone_mor. - exact (functor_from_kleisli_cat_monad M F γ p₁ p₂). - exact (functor_from_kleisli_cat_monad_nat_trans M F γ p₁ p₂). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite functor_id ; rewrite !id_left, id_right ; apply idpath). - use is_nat_z_iso_to_is_invertible_2cell. intro. apply is_z_isomorphism_identity. Defined. Definition bicat_of_cats_has_kleisli_ump_2 : has_kleisli_ump_2 m bicat_of_cats_has_kleisli_cocone. Proof. intros C' G₁ G₂ α p. assert (p' : ∏ (x : C), # (pr1 G₁) (kleisli_monad_nat_trans M x) · pr1 α x = pr1 α (M x) · # (pr1 G₂) (kleisli_monad_nat_trans M x)). { intro x. pose (q := nat_trans_eq_pointwise p x). cbn in q. rewrite !id_left, !id_right in q. exact q. } use iscontraprop1. - use invproofirrelevance. intros β₁ β₂. use subtypePath ; [ intro ; apply cellset_property | ]. exact (nat_trans_from_kleisli_cat_monad_unique M α (pr2 β₁) (pr2 β₂)). - simple refine (_ ,, _). + exact (nat_trans_from_kleisli_cat_monad M α p'). + exact (pre_whisker_nat_trans_from_kleisli_cat_monad M α p'). Defined. End KleisliCategoryUMP. Definition bicat_of_cats_has_kleisli : has_kleisli bicat_of_cats. Proof. intro m. simple refine (_ ,, _ ,, _). - exact (bicat_of_cats_has_kleisli_cocone m). - exact (bicat_of_cats_has_kleisli_ump_1 m). - exact (bicat_of_cats_has_kleisli_ump_2 m). Defined. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/BicatOfUnivCatsColimits.v000066400000000000000000001165341451125700300275060ustar00rootroot00000000000000(********************************************************************************* Colimits of categories Contents: 1. Initial object 2. Coproducts 3. Extensivity 4. Kleisli objects *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.categories.KleisliCategory. Require Import UniMath.CategoryTheory.CategorySum. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KleisliCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Require Import UniMath.Bicategories.Colimits.Extensive. Require Import UniMath.Bicategories.Colimits.KleisliObjects. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat. Local Open Scope cat. (** 1. Initial object *) Definition empty_category_is_biinitial : @is_biinitial bicat_of_univ_cats empty_category. Proof. use make_is_biinitial. - exact (λ C, functor_from_empty (pr1 C)). - exact (λ _ F G, nat_trans_from_empty F G). - abstract (intros Y f g α β ; use nat_trans_eq ; [ apply homset_property | ] ; exact (λ z, fromempty z)). Defined. Definition biinitial_obj_bicat_of_univ_cats : biinitial_obj bicat_of_univ_cats := empty_category ,, empty_category_is_biinitial. Definition strict_biinitial_univ_cats : @is_strict_biinitial_obj bicat_of_univ_cats empty_category. Proof. refine (empty_category_is_biinitial ,, _). intros C F. use equiv_to_adjequiv. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (functor_from_empty _). - apply nat_trans_to_empty. - exact (nat_trans_from_empty _ _). - use is_nat_z_iso_to_is_invertible_2cell. apply nat_trans_to_empty_is_nat_z_iso. - use is_nat_z_iso_to_is_invertible_2cell. intro z. apply (fromempty z). Defined. (** 2. Coproducts *) Definition bincoprod_cocone_bicat_of_univ_cats (C₁ C₂ : bicat_of_univ_cats) : bincoprod_cocone C₁ C₂. Proof. use make_bincoprod_cocone. - exact (bincoprod_of_univalent_category C₁ C₂). - exact (inl_functor (pr1 C₁) (pr1 C₂)). - exact (inr_functor (pr1 C₁) (pr1 C₂)). Defined. Section BincoprodUMP. Context (C₁ C₂ : bicat_of_univ_cats). Definition has_bincoprod_ump_1_bicat_of_univ_cats : bincoprod_ump_1 (bincoprod_cocone_bicat_of_univ_cats C₁ C₂). Proof. intros Q. use make_bincoprod_1cell. - exact (sum_of_functors (bincoprod_cocone_inl Q) (bincoprod_cocone_inr Q)). - use nat_z_iso_to_invertible_2cell. exact (sum_of_functor_inl_nat_z_iso (bincoprod_cocone_inl Q) (bincoprod_cocone_inr Q)). - use nat_z_iso_to_invertible_2cell. exact (sum_of_functor_inr_nat_z_iso (bincoprod_cocone_inl Q) (bincoprod_cocone_inr Q)). Defined. Definition has_bincoprod_ump_2_bicat_of_univ_cats_unique {Q : bicat_of_univ_cats} {F G : bincoprod_cocone_bicat_of_univ_cats C₁ C₂ --> Q} (α : bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · F ==> bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · G) (β : bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · F ==> bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · G) : isaprop (∑ γ, bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) ◃ γ = α × bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) ◃ γ = β). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use nat_trans_eq ; [ apply homset_property | ]. intro z ; induction z as [ x | y ]. - exact (nat_trans_eq_pointwise (pr12 φ₁) x @ !(nat_trans_eq_pointwise (pr12 φ₂) x)). - exact (nat_trans_eq_pointwise (pr22 φ₁) y @ !(nat_trans_eq_pointwise (pr22 φ₂) y)). Qed. Definition has_bincoprod_ump_2_bicat_of_univ_cats : bincoprod_ump_2 (bincoprod_cocone_bicat_of_univ_cats C₁ C₂). Proof. intros Q F G α β. use iscontraprop1. - exact (has_bincoprod_ump_2_bicat_of_univ_cats_unique α β). - simple refine (_ ,, _ ,, _). + exact (sum_of_nat_trans α β). + exact (sum_of_nat_trans_inl α β). + exact (sum_of_nat_trans_inr α β). Defined. Definition has_bincoprod_ump_bicat_of_univ_cats : has_bincoprod_ump (bincoprod_cocone_bicat_of_univ_cats C₁ C₂). Proof. split. - exact has_bincoprod_ump_1_bicat_of_univ_cats. - exact has_bincoprod_ump_2_bicat_of_univ_cats. Defined. End BincoprodUMP. Definition bincoprod_bicat_of_univ_cats : has_bincoprod bicat_of_univ_cats := λ C₁ C₂, bincoprod_cocone_bicat_of_univ_cats C₁ C₂ ,, has_bincoprod_ump_bicat_of_univ_cats C₁ C₂. Definition bicat_of_univ_cats_with_biinitial_bincoprod : bicat_with_biinitial_bincoprod := bicat_of_univ_cats ,, biinitial_obj_bicat_of_univ_cats ,, bincoprod_bicat_of_univ_cats. (** 3. Extensivity *) Section DisjointCoproducts. Context (C₁ C₂ : bicat_of_univ_cats_with_biinitial_bincoprod). Notation "∁" := bicat_of_univ_cats_with_biinitial_bincoprod. Let R := @biinitial_comma_cone ∁ C₁ C₂ (pr1 (bincoprod_of ∁ C₁ C₂)) (inl_functor _ _) (inr_functor _ _). Section OneCell. Context (Q : @comma_cone ∁ C₁ C₂ (pr1 (bincoprod_of ∁ C₁ C₂)) (inl_functor _ _) (inr_functor _ _)). Definition bicat_of_univ_cats_inl_inr_1cell_functor_data : functor_data (pr11 Q) (pr11 R). Proof. use make_functor_data. - exact (λ q, pr1 (comma_cone_cell Q) q). - exact (λ q _ _, fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inl_inr_1cell_functor_is_functor : is_functor bicat_of_univ_cats_inl_inr_1cell_functor_data. Proof. split. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - intros q ? ? ? ?. exact (fromempty (pr1 (comma_cone_cell Q) q)). Qed. Definition bicat_of_univ_cats_inl_inr_1cell_functor : Q --> R. Proof. use make_functor. - exact bicat_of_univ_cats_inl_inr_1cell_functor_data. - exact bicat_of_univ_cats_inl_inr_1cell_functor_is_functor. Defined. Definition bicat_of_univ_cats_inl_inr_1cell_pr1_nat_trans : bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr1 R ==> comma_cone_pr1 Q. Proof. use make_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - abstract (intros q ? ? ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. Definition bicat_of_univ_cats_inl_inr_1cell_pr1 : nat_z_iso (bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr1 R) (comma_cone_pr1 Q). Proof. use make_nat_z_iso. - exact bicat_of_univ_cats_inl_inr_1cell_pr1_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inl_inr_1cell_pr2_nat_trans : bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr2 R ==> comma_cone_pr2 Q. Proof. use make_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - abstract (intros q ? ? ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. Definition bicat_of_univ_cats_inl_inr_1cell_pr2 : nat_z_iso (bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr2 R) (comma_cone_pr2 Q). Proof. use make_nat_z_iso. - exact bicat_of_univ_cats_inl_inr_1cell_pr2_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inl_inr_1cell : comma_1cell Q R. Proof. use make_comma_1cell. + exact bicat_of_univ_cats_inl_inr_1cell_functor. + use nat_z_iso_to_invertible_2cell. exact bicat_of_univ_cats_inl_inr_1cell_pr1. + use nat_z_iso_to_invertible_2cell. exact bicat_of_univ_cats_inl_inr_1cell_pr2. + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro q ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. End OneCell. Definition bicat_of_univ_cats_inl_inr : has_comma_ump R. Proof. split. - exact bicat_of_univ_cats_inl_inr_1cell. - intros Q φ ψ α β p. use iscontraprop1. + abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). + simple refine (_ ,, _ ,, _). * use make_nat_trans. ** intros q. exact (fromempty (pr1 φ q)). ** abstract (intros q ? ? ; exact (fromempty (pr1 φ q))). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). Defined. Let R' := @biinitial_comma_cone ∁ C₂ C₁ (pr1 (bincoprod_of ∁ C₁ C₂)) (inr_functor _ _) (inl_functor _ _). Section OneCell. Context (Q : @comma_cone ∁ C₂ C₁ (pr1 (bincoprod_of ∁ C₁ C₂)) (inr_functor _ _) (inl_functor _ _)). Definition bicat_of_univ_cats_inr_inl_1cell_functor_data : functor_data (pr11 Q) (pr11 R'). Proof. use make_functor_data. - exact (λ q, pr1 (comma_cone_cell Q) q). - exact (λ q _ _, fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inr_inl_1cell_functor_is_functor : is_functor bicat_of_univ_cats_inr_inl_1cell_functor_data. Proof. split. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - intros q ? ? ? ?. exact (fromempty (pr1 (comma_cone_cell Q) q)). Qed. Definition bicat_of_univ_cats_inr_inl_1cell_functor : Q --> R. Proof. use make_functor. - exact bicat_of_univ_cats_inr_inl_1cell_functor_data. - exact bicat_of_univ_cats_inr_inl_1cell_functor_is_functor. Defined. Definition bicat_of_univ_cats_inr_inl_1cell_pr1_nat_trans : bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr1 R' ==> comma_cone_pr1 Q. Proof. use make_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - abstract (intros q ? ? ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. Definition bicat_of_univ_cats_inr_inl_1cell_pr1 : nat_z_iso (bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr1 R') (comma_cone_pr1 Q). Proof. use make_nat_z_iso. - exact bicat_of_univ_cats_inr_inl_1cell_pr1_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inr_inl_1cell_pr2_nat_trans : bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr2 R' ==> comma_cone_pr2 Q. Proof. use make_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). - abstract (intros q ? ? ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. Definition bicat_of_univ_cats_inr_inl_1cell_pr2 : nat_z_iso (bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr2 R') (comma_cone_pr2 Q). Proof. use make_nat_z_iso. - exact bicat_of_univ_cats_inr_inl_1cell_pr2_nat_trans. - intro q. exact (fromempty (pr1 (comma_cone_cell Q) q)). Defined. Definition bicat_of_univ_cats_inr_inl_1cell : comma_1cell Q R'. Proof. use make_comma_1cell. + exact bicat_of_univ_cats_inr_inl_1cell_functor. + use nat_z_iso_to_invertible_2cell. exact bicat_of_univ_cats_inr_inl_1cell_pr1. + use nat_z_iso_to_invertible_2cell. exact bicat_of_univ_cats_inr_inl_1cell_pr2. + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro q ; exact (fromempty (pr1 (comma_cone_cell Q) q))). Defined. End OneCell. Definition bicat_of_univ_cats_inr_inl : has_comma_ump R'. Proof. split. - exact bicat_of_univ_cats_inr_inl_1cell. - intros Q φ ψ α β p. use iscontraprop1. + abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). + simple refine (_ ,, _ ,, _). * use make_nat_trans. ** intros q. exact (fromempty (pr1 φ q)). ** abstract (intros q ? ? ; exact (fromempty (pr1 φ q))). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros q ; exact (fromempty (pr1 φ q))). Defined. End DisjointCoproducts. Section UniversalCoproducts. Notation "∁" := bicat_of_univ_cats_with_biinitial_bincoprod. Context {C₁ C₂ Z : ∁} (F : Z --> pr1 (bincoprod_of ∁ C₁ C₂)). Let ι₁ : C₁ --> pr1 (bincoprod_of ∁ C₁ C₂) := inl_functor (pr1 C₁) (pr1 C₂). Let ι₂ : C₂ --> pr1 (bincoprod_of ∁ C₁ C₂) := inr_functor (pr1 C₁) (pr1 C₂). Let κ₁ : bicat_of_univ_cats ⟦ univalent_iso_comma ι₁ F , Z ⟧ := iso_comma_pr2 _ _. Let κ₂ : bicat_of_univ_cats ⟦ univalent_iso_comma ι₂ F , Z ⟧ := iso_comma_pr2 _ _. Section UniversalCoproductsOne. Context (W : @bincoprod_cocone bicat_of_univ_cats (univalent_iso_comma ι₁ F) (univalent_iso_comma ι₂ F)). Local Definition pb_of_sum_cats_ob {z : pr1 Z} {q : pr111 (bincoprod_of ∁ C₁ C₂)} (i : z_iso q (pr1 F z)) : pr11 W. Proof. induction q as [ x | y ]. - apply (bincoprod_cocone_inl W). exact ((x ,, z) ,, i). - apply (bincoprod_cocone_inr W). exact ((y ,, z) ,, i). Defined. Notation "'H₀'" := pb_of_sum_cats_ob. Local Definition pb_of_sum_cats_mor {z₁ z₂ : pr1 Z} (f : z₁ --> z₂) {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)} (g : q₁ --> q₂) (i₁ : z_iso q₁ (pr1 F z₁)) (i₂ : z_iso q₂ (pr1 F z₂)) (p : g · i₂ = i₁ · # (pr1 F) f) : H₀ i₁ --> H₀ i₂. Proof. induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ] ; cbn. - use (#(pr1 (bincoprod_cocone_inl W))). exact ((g ,, f) ,, p). - exact (fromempty g). - exact (fromempty g). - use (#(pr1 (bincoprod_cocone_inr W))). exact ((g ,, f) ,, p). Defined. Local Notation "'H₁'" := pb_of_sum_cats_mor. Local Definition pb_of_sum_cats_mor_eq {z₁ z₂ : pr1 Z} (f : z₁ --> z₂) {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)} {g₁ g₂ : q₁ --> q₂} (p : g₁ = g₂) (i₁ : z_iso q₁ (pr1 F z₁)) (i₂ : z_iso q₂ (pr1 F z₂)) (r₁ : g₁ · i₂ = i₁ · # (pr1 F) f) (r₂ : g₂ · i₂ = i₁ · # (pr1 F) f) : H₁ f g₁ i₁ i₂ r₁ = H₁ f g₂ i₁ i₂ r₂. Proof. induction p ; cbn. apply maponpaths. apply homset_property. Qed. Local Definition pb_of_sum_cats_data : functor_data (pr1 Z) (pr11 W). Proof. use make_functor_data. - exact (λ z, H₀ (identity_z_iso (pr1 F z))). - refine (λ z₁ z₂ f, H₁ f (#(pr1 F) f) (identity_z_iso _) (identity_z_iso _) _). abstract (rewrite id_left, id_right ; apply idpath). Defined. Local Lemma pb_of_sum_cats_id (z : pr1 Z) (q : pr111 (bincoprod_of ∁ C₁ C₂)) (i : z_iso q (pr1 F z)) (p : id₁ q · i = i · # (pr1 F) (id₁ z)) : H₁ (identity z) (identity q) i i p = identity _. Proof. induction q as [ x | y ] ; cbn. - refine (_ @ functor_id (bincoprod_cocone_inl W) _). apply maponpaths ; cbn. apply maponpaths. apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inl x) (pr1 F z)). - refine (_ @ functor_id (bincoprod_cocone_inr W) _). apply maponpaths ; cbn. apply maponpaths. apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inr y) (pr1 F z)). Qed. Local Lemma pb_of_sum_cats_comp {z₁ z₂ z₃ : pr1 Z} (f : z₁ --> z₂) (g : z₂ --> z₃) {q₁ q₂ q₃ : pr111 (bincoprod_of ∁ C₁ C₂)} (ff : q₁ --> q₂) (gg : q₂ --> q₃) (i₁ : z_iso q₁ (pr1 F z₁)) (i₂ : z_iso q₂ (pr1 F z₂)) (i₃ : z_iso q₃ (pr1 F z₃)) (p₁ : ff · gg · i₃ = i₁ · # (pr1 F) (f · g)) (p₂ : ff · i₂ = i₁ · # (pr1 F) f) (p₃ : gg · i₃ = i₂ · # (pr1 F) g) : H₁ (f · g) (ff · gg) i₁ i₃ p₁ = H₁ f ff i₁ i₂ p₂ · H₁ g gg i₂ i₃ p₃. Proof. induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ] ; induction q₃ as [ x₃ | y₃ ] ; cbn. - refine (_ @ functor_comp _ _ _). apply maponpaths ; cbn. apply maponpaths. apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inl x₁)). - apply (fromempty gg). - apply (fromempty gg). - apply (fromempty ff). - apply (fromempty ff). - apply (fromempty gg). - apply (fromempty gg). - refine (_ @ functor_comp _ _ _). apply maponpaths ; cbn. apply maponpaths. apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inr y₁)). Qed. Local Lemma pb_of_sum_cats_is_functor : is_functor pb_of_sum_cats_data. Proof. split. - intro z ; cbn. simple refine (_ @ pb_of_sum_cats_id z (pr1 F z) (identity_z_iso _) _). + use pb_of_sum_cats_mor_eq. apply functor_id. + exact (id_left _ @ !(functor_id _ _) @ !(id_left _)). - intros z₁ z₂ z₃ f g ; cbn. simple refine (_ @ pb_of_sum_cats_comp _ _ _ _ _ _ _ _ _ _). + use pb_of_sum_cats_mor_eq. apply functor_comp. + refine (id_right _ @ !_ @ !(id_left _)). apply functor_comp. Qed. Local Definition pb_of_sum_cats : Z --> W. Proof. use make_functor. - exact pb_of_sum_cats_data. - exact pb_of_sum_cats_is_functor. Defined. Local Definition pb_of_cats_iso_mor (z : pr1 Z) (q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)) (i₁ : z_iso q₁ (pr1 F z)) (i₂ : z_iso q₂ (pr1 F z)) (k : q₁ --> q₂) (p : k · i₂ = i₁) : H₀ i₁ --> H₀ i₂. Proof. induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ]. - cbn. refine (#(pr1 (bincoprod_cocone_inl W)) _). simple refine ((k ,, identity _) ,, _). abstract (simpl ; refine (_ @ maponpaths (λ z, i₁ · z) (!(functor_id F z))) ; refine (_ @ !(id_right _)) ; exact p). - apply fromempty. exact (pr1 i₁ · inv_from_z_iso i₂). - apply fromempty. exact (pr1 i₁ · inv_from_z_iso i₂). - cbn. refine (#(pr1 (bincoprod_cocone_inr W)) _). simple refine ((k ,, identity _) ,, _). abstract (simpl ; refine (_ @ maponpaths (λ z, i₁ · z) (!(functor_id F z))) ; refine (_ @ !(id_right _)) ; exact p). Defined. Local Definition pb_of_cats_is_z_iso (z : pr1 Z) (q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)) (i₁ : z_iso q₁ (pr1 F z)) (i₂ : z_iso q₂ (pr1 F z)) (k : z_iso q₁ q₂) (p : pr1 k · i₂ = i₁) : is_z_isomorphism (pb_of_cats_iso_mor z q₁ q₂ i₁ i₂ k p). Proof. induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ]. - use functor_on_is_z_isomorphism. use is_z_iso_iso_comma. + cbn. use tpair; [ | split ]. * exact (inv_from_z_iso k). * apply (z_iso_inv_after_z_iso k). * apply (z_iso_after_z_iso_inv k). + cbn. apply identity_is_z_iso. - apply fromempty. exact (pr1 i₁ · inv_from_z_iso i₂). - apply fromempty. exact (pr1 i₁ · inv_from_z_iso i₂). - use functor_on_is_z_isomorphism. use is_z_iso_iso_comma. + cbn. use tpair; [ | split ]. * exact (inv_from_z_iso k). * apply (z_iso_inv_after_z_iso k). * apply (z_iso_after_z_iso_inv k). + cbn. apply identity_is_z_iso. Defined. Local Definition pb_of_sum_cats_z_iso (z : pr1 Z) (q : pr111 (bincoprod_of ∁ C₁ C₂)) (i : z_iso q (pr1 F z)) : z_iso (H₀ (identity_z_iso (pr1 F z))) (H₀ i). Proof. use make_z_iso'. - use pb_of_cats_iso_mor. + exact (z_iso_inv_from_z_iso i). + simpl. exact (z_iso_after_z_iso_inv i). - apply pb_of_cats_is_z_iso. Defined. Local Definition pb_of_sum_cats_inl_data : nat_trans_data (κ₁ ∙ pb_of_sum_cats) (pr1 (bincoprod_cocone_inl W)) := λ z, pb_of_sum_cats_z_iso (pr21 z) _ (pr2 z). Local Lemma pb_of_sum_cats_nat_trans_help {z₁ z₂ : pr1 Z} (f : z₁ --> z₂) {q₁ q₂ q₃ q₄ : pr111 (bincoprod_of ∁ C₁ C₂)} (g₁ : q₁ --> q₂) (g₂ : q₂ --> q₃) (g₃ : q₃ --> q₄) (i₁ : z_iso q₁ (pr1 F z₁)) (i₂ : z_iso q₂ (pr1 F z₁)) (i₃ : z_iso q₃ (pr1 F z₂)) (i₄ : z_iso q₄ (pr1 F z₂)) (p₁ : g₁ · i₂ = i₁) (p₂ : g₃ · i₄ = i₃) (r₁ : g₁ · g₂ · i₃ = i₁ · # (pr1 F) f) (r₂ : g₂ · g₃ · i₄ = i₂ · # (pr1 F) f) : H₁ f (g₁ · g₂) i₁ i₃ r₁ · pb_of_cats_iso_mor z₂ q₃ q₄ i₃ i₄ g₃ p₂ = pb_of_cats_iso_mor z₁ q₁ q₂ i₁ i₂ g₁ p₁ · H₁ f (g₂ · g₃) i₂ i₄ r₂. Proof. induction q₁, q₂, q₃, q₄ ; cbn. - refine (!functor_comp _ _ _ @ _ @ functor_comp _ _ _). apply maponpaths. use subtypePath ; [ intro ; apply homset_property | ]. cbn. use pathsdirprod. + rewrite assoc. apply idpath. + rewrite id_left, id_right. apply idpath. - exact (fromempty g₃). - exact (fromempty g₂). - exact (fromempty g₂). - exact (fromempty g₂). - exact (fromempty g₂). - exact (fromempty g₁). - exact (fromempty g₁). - exact (fromempty g₁). - exact (fromempty g₁). - exact (fromempty g₁). - exact (fromempty g₁). - exact (fromempty g₂). - exact (fromempty g₂). - exact (fromempty g₃). - refine (!functor_comp _ _ _ @ _ @ functor_comp _ _ _). apply maponpaths. use subtypePath ; [ intro ; apply homset_property | ]. cbn. use pathsdirprod. + rewrite assoc. apply idpath. + rewrite id_left, id_right. apply idpath. Qed. Local Lemma pb_of_sum_cats_inl_is_nat_trans : is_nat_trans _ _ pb_of_sum_cats_inl_data. Proof. intros x y f. cbn. simple refine (maponpaths (λ z, z · _) _ @ pb_of_sum_cats_nat_trans_help (pr21 f) (inv_from_z_iso (pr2 x)) (pr12 x · # (pr1 F) (pr21 f)) (inv_from_z_iso (pr2 y)) (identity_z_iso (pr1 F (pr21 x))) (pr2 x) (identity_z_iso (pr1 F (pr21 y))) (pr2 y) (z_iso_after_z_iso_inv _) (z_iso_after_z_iso_inv _) _ _ @ maponpaths (λ z, _ · z) _). - use pb_of_sum_cats_mor_eq. rewrite !assoc. rewrite z_iso_after_z_iso_inv. rewrite id_left. apply idpath. - abstract (rewrite id_left, id_right ; rewrite assoc ; rewrite z_iso_after_z_iso_inv ; apply id_left). - abstract (rewrite !assoc' ; rewrite z_iso_after_z_iso_inv ; rewrite id_right ; apply idpath). - use pb_of_sum_cats_mor_eq. pose (pr2 f) as p. simpl in p. etrans. { apply maponpaths_2. exact (!p). } rewrite !assoc'. rewrite z_iso_inv_after_z_iso. apply id_right. Qed. Local Definition pb_of_sum_cats_inl_nat_trans : κ₁ ∙ pb_of_sum_cats ⟹ pr1 (bincoprod_cocone_inl W). Proof. use make_nat_trans. - exact pb_of_sum_cats_inl_data. - exact pb_of_sum_cats_inl_is_nat_trans. Defined. Local Definition pb_of_sum_cats_inl : nat_z_iso (κ₁ ∙ pb_of_sum_cats) (bincoprod_cocone_inl W). Proof. use make_nat_z_iso. - exact pb_of_sum_cats_inl_nat_trans. - intro. apply z_iso_is_z_isomorphism. Defined. Local Definition pb_of_sum_cats_inr_data : nat_trans_data (κ₂ ∙ pb_of_sum_cats) (pr1 (bincoprod_cocone_inr W)) := λ z, pb_of_sum_cats_z_iso (pr21 z) _ (pr2 z). Local Lemma pb_of_sum_cats_inr_is_nat_trans : is_nat_trans _ _ pb_of_sum_cats_inr_data. Proof. intros x y f. cbn. simple refine (maponpaths (λ z, z · _) _ @ pb_of_sum_cats_nat_trans_help (pr21 f) (inv_from_z_iso (pr2 x)) (pr12 x · # (pr1 F) (pr21 f)) (inv_from_z_iso (pr2 y)) (identity_z_iso (pr1 F (pr21 x))) (pr2 x) (identity_z_iso (pr1 F (pr21 y))) (pr2 y) (z_iso_after_z_iso_inv _) (z_iso_after_z_iso_inv _) _ _ @ maponpaths (λ z, _ · z) _). - use pb_of_sum_cats_mor_eq. rewrite !assoc. rewrite z_iso_after_z_iso_inv. rewrite id_left. apply idpath. - abstract (rewrite id_left, id_right ; rewrite assoc ; rewrite z_iso_after_z_iso_inv ; apply id_left). - abstract (rewrite !assoc' ; rewrite z_iso_after_z_iso_inv ; rewrite id_right ; apply idpath). - use pb_of_sum_cats_mor_eq. pose (pr2 f) as p. simpl in p. etrans. { apply maponpaths_2. exact (!p). } rewrite !assoc'. rewrite z_iso_inv_after_z_iso. apply id_right. Qed. Local Definition pb_of_sum_cats_inr_nat_trans : κ₂ ∙ pb_of_sum_cats ⟹ pr1 (bincoprod_cocone_inr W). Proof. use make_nat_trans. - exact pb_of_sum_cats_inr_data. - exact pb_of_sum_cats_inr_is_nat_trans. Defined. Local Definition pb_of_sum_cats_inr : nat_z_iso (κ₂ ∙ pb_of_sum_cats) (bincoprod_cocone_inr W). Proof. use make_nat_z_iso. - exact pb_of_sum_cats_inr_nat_trans. - intro. apply z_iso_is_z_isomorphism. Defined. End UniversalCoproductsOne. Section UniversalCoproductsTwo. Context {W : ∁} {φ ψ : ∁ ⟦ make_bincoprod_cocone Z κ₁ κ₂, W ⟧} (α : κ₁ · φ ==> κ₁ · ψ) (β : κ₂ · φ ==> κ₂ · ψ). Local Definition pb_of_sum_cats_nat_trans_ob (z : pr1 Z) (q : pr111 (bincoprod_of ∁ C₁ C₂)) (i : z_iso q (pr1 F z)) : pr1 φ z --> pr1 ψ z. Proof. induction q as [ x | y ]. - exact (pr1 α ((x ,, z) ,, i)). - exact (pr1 β ((y ,, z) ,, i)). Defined. Local Definition pb_of_sum_cats_nat_trans_data : nat_trans_data (pr1 φ) (pr1 ψ) := λ z, pb_of_sum_cats_nat_trans_ob z (pr1 F z) (identity_z_iso _). Local Definition pb_of_sum_cats_is_nat_trans_help {z₁ z₂ : pr1 Z} (f : z₁ --> z₂) {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)} (g : q₁ --> q₂) (i₁ : z_iso q₁ (pr1 F z₁)) (i₂ : z_iso q₂ (pr1 F z₂)) (p : g · i₂ = i₁ · # (pr1 F) f) : # (pr1 φ) f · pb_of_sum_cats_nat_trans_ob _ _ i₂ = pb_of_sum_cats_nat_trans_ob _ _ i₁ · # (pr1 ψ) f. Proof. induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ] ; cbn. - exact (nat_trans_ax α ((x₁ ,, z₁) ,, i₁) ((x₂ ,, z₂) ,, i₂) ((g ,, _) ,, p)). - exact (fromempty (i₁ · # (pr1 F) f · inv_from_z_iso i₂)). - exact (fromempty (i₁ · # (pr1 F) f · inv_from_z_iso i₂)). - exact (nat_trans_ax β ((y₁ ,, z₁) ,, i₁) ((y₂ ,, z₂) ,, i₂) ((g ,, _) ,, p)). Qed. Local Lemma pb_of_sum_cats_is_nat_trans : is_nat_trans _ _ pb_of_sum_cats_nat_trans_data. Proof. intros x y f ; unfold pb_of_sum_cats_nat_trans_data ; cbn. use pb_of_sum_cats_is_nat_trans_help. - exact (# (pr1 F) f). - rewrite id_left, id_right. apply idpath. Qed. Local Definition pb_of_sum_cats_nat_trans : φ ==> ψ. Proof. use make_nat_trans. - exact pb_of_sum_cats_nat_trans_data. - exact pb_of_sum_cats_is_nat_trans. Defined. Local Lemma pb_of_sum_cats_nat_trans_ob_id (z : pr1 Z) (q : pr111 (bincoprod_of ∁ C₁ C₂)) (i : z_iso q (pr1 F z)) : pb_of_sum_cats_nat_trans_ob z _ (identity_z_iso _) = pb_of_sum_cats_nat_trans_ob z q i. Proof. refine (!(id_left _) @ _ @ id_right _). etrans. { apply maponpaths_2. refine (!_). apply functor_id. } refine (!_). etrans. { apply maponpaths. refine (!_). apply functor_id. } refine (!_). refine (pb_of_sum_cats_is_nat_trans_help (identity z) i i (identity_z_iso _) _). rewrite (functor_id F). rewrite !id_right. apply idpath. Qed. Local Definition pb_of_sum_cats_nat_trans_inl : κ₁ ◃ pb_of_sum_cats_nat_trans = α. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn ; unfold pb_of_sum_cats_nat_trans_data. exact (pb_of_sum_cats_nat_trans_ob_id _ _ (pr2 x)). Qed. Local Definition pb_of_sum_cats_nat_trans_inr : κ₂ ◃ pb_of_sum_cats_nat_trans = β. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn ; unfold pb_of_sum_cats_nat_trans_data. exact (pb_of_sum_cats_nat_trans_ob_id _ _ (pr2 x)). Qed. Local Lemma pb_of_sum_cats_nat_trans_unique : isaprop (∑ (γ : φ ==> ψ), κ₁ ◃ γ = α × κ₂ ◃ γ = β). Proof. use invproofirrelevance. intros τ₁ τ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro z ; cbn in z. pose (q := pr1 F z). assert (i := identity_z_iso _ : z_iso q (pr1 F z)). induction q as [ x | y] ; cbn. - refine (nat_trans_eq_pointwise (pr12 τ₁) ((x ,, z) ,, i) @ !_). exact (nat_trans_eq_pointwise (pr12 τ₂) ((x ,, z) ,, i)). - refine (nat_trans_eq_pointwise (pr22 τ₁) ((y ,, z) ,, i) @ !_). exact (nat_trans_eq_pointwise (pr22 τ₂) ((y ,, z) ,, i)). Qed. End UniversalCoproductsTwo. Definition universal_bicat_of_univ_cats : has_bincoprod_ump (make_bincoprod_cocone Z κ₁ κ₂). Proof. split. - intro W. use make_bincoprod_1cell. + exact (pb_of_sum_cats W). + use nat_z_iso_to_invertible_2cell. exact (pb_of_sum_cats_inl W). + use nat_z_iso_to_invertible_2cell. exact (pb_of_sum_cats_inr W). - intros W φ ψ α β. use iscontraprop1. + exact (pb_of_sum_cats_nat_trans_unique α β). + simple refine (_ ,, _ ,, _). * exact (pb_of_sum_cats_nat_trans α β). * exact (pb_of_sum_cats_nat_trans_inl α β). * exact (pb_of_sum_cats_nat_trans_inr α β). Defined. End UniversalCoproducts. Definition is_extensive_bicat_of_univ_cats : is_extensive bicat_of_univ_cats_with_biinitial_bincoprod. Proof. intros C₁ C₂. split. - refine (_ ,, _ ,, _ ,, _). + apply cat_fully_faithful_is_fully_faithful_1cell. apply fully_faithful_inl_functor. + apply cat_fully_faithful_is_fully_faithful_1cell. apply fully_faithful_inr_functor. + apply bicat_of_univ_cats_inl_inr. + apply bicat_of_univ_cats_inr_inl. - use is_universal_from_pb_alt. + apply has_pb_bicat_of_univ_cats. + intros Z F. exact (universal_bicat_of_univ_cats F). Defined. (** 4. Kleisli objects *) Section KleisliCategoryUMP. Context (m : mnd (op1_bicat bicat_of_univ_cats)). Let C : univalent_category := ob_of_mnd m. Let M : Monad C := mnd_bicat_of_univ_cats_to_Monad (mnd_op1_to_mnd m). Definition bicat_of_univ_cats_has_kleisli_cocone : kleisli_cocone m. Proof. use make_kleisli_cocone. - exact (univalent_kleisli_cat M). - exact (kleisli_incl M). - exact (kleisli_nat_trans M). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; use eq_mor_kleisli_cat ; exact (@Monad_law2 _ M x)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; use eq_mor_kleisli_cat ; cbn ; rewrite id_left ; apply (!(@Monad_law3 _ M x))). Defined. Definition bicat_of_univ_cats_has_kleisli_ump_1 : has_kleisli_ump_1 m bicat_of_univ_cats_has_kleisli_cocone. Proof. intro q. pose (F := mor_of_kleisli_cocone _ q). pose (γ := cell_of_kleisli_cocone _ q). pose (p₁ := nat_trans_eq_pointwise (kleisli_cocone_unit _ q)). assert (p₂ : ∏ (x : C), pr1 γ (M x) · pr1 γ x = # (pr1 F) (μ M x) · pr1 γ x). { intro x. pose (p₂ := nat_trans_eq_pointwise (kleisli_cocone_mult _ q) x). cbn in p₂. rewrite !id_left in p₂. exact p₂. } use make_kleisli_cocone_mor. - exact (functor_from_univalent_kleisli_cat M F γ p₁ p₂). - exact (functor_from_univalent_kleisli_cat_nat_trans M F γ p₁ p₂). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; refine (_ @ maponpaths (λ z, z · _) (!(id_left _))) ; exact (functor_from_univalent_kleisli_cat_eq M F γ p₁ p₂ x)). - use is_nat_z_iso_to_is_invertible_2cell. exact (functor_from_univalent_kleisli_cat_nat_trans_is_z_iso M F γ p₁ p₂). Defined. Definition bicat_of_univ_cats_has_kleisli_ump_2 : has_kleisli_ump_2 m bicat_of_univ_cats_has_kleisli_cocone. Proof. intros C' G₁ G₂ α p. assert (p' : ∏ (x : C), # (pr1 G₁) (kleisli_nat_trans M x) · pr1 α x = pr1 α (M x) · # (pr1 G₂) (kleisli_nat_trans M x)). { intro x. pose (q := nat_trans_eq_pointwise p x). cbn in q. rewrite !id_left, !id_right in q. exact q. } use iscontraprop1. - use invproofirrelevance. intros β₁ β₂. use subtypePath ; [ intro ; apply cellset_property | ]. exact (nat_trans_from_univalent_kleisli_cat_unique M α (pr2 β₁) (pr2 β₂)). - simple refine (_ ,, _). + exact (nat_trans_from_univalent_kleisli_cat M α p'). + exact (pre_whisker_nat_trans_from_univalent_kleisli_cat M α p'). Defined. End KleisliCategoryUMP. Definition bicat_of_univ_cats_has_kleisli : has_kleisli bicat_of_univ_cats. Proof. intro m. simple refine (_ ,, _ ,, _). - exact (bicat_of_univ_cats_has_kleisli_cocone m). - exact (bicat_of_univ_cats_has_kleisli_ump_1 m). - exact (bicat_of_univ_cats_has_kleisli_ump_2 m). Defined. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/DisplayMapSliceColimits.v000066400000000000000000000052001451125700300275300ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Local Open Scope cat. Section ArrowSubbicatInitial. Context {B : bicat} (I : biinitial_obj B) (D : arrow_subbicat B) (b : B) (HD : arrow_subbicat_biinitial I D). Definition disp_map_slice_biinitial_obj : disp_map_slice_bicat D b. Proof. simple refine (_ ,, _ ,, _). - exact (pr1 I). - exact (is_biinitial_1cell_property (pr2 I) b). - exact (pr1 HD b). Defined. Definition disp_map_slice_biinitial_1cell_property : biinitial_1cell_property disp_map_slice_biinitial_obj. Proof. intros h. simple refine (_ ,, _ ,, _). - exact (is_biinitial_1cell_property (pr2 I) (pr1 h)). - exact (pr2 HD _ _ (pr12 h)). - use make_invertible_2cell ; cbn. + apply (is_biinitial_2cell_property (pr2 I)). + use make_is_invertible_2cell. * apply (is_biinitial_2cell_property (pr2 I)). * apply (is_biinitial_eq_property (pr2 I)). * apply (is_biinitial_eq_property (pr2 I)). Defined. Definition disp_map_slice_biinitial_2cell_property (h : disp_map_slice_bicat D b) : biinitial_2cell_property disp_map_slice_biinitial_obj h. Proof. intros α β. simple refine (_ ,, _). - apply (is_biinitial_2cell_property (pr2 I)). - apply (is_biinitial_eq_property (pr2 I)). Defined. Definition disp_map_slice_biinitial_eq_property (h : disp_map_slice_bicat D b) : biinitial_eq_property disp_map_slice_biinitial_obj h. Proof. intros α β p q. use eq_2cell_disp_map_slice. apply (is_biinitial_eq_property (pr2 I)). Defined. Definition disp_map_slice_biinitial : biinitial_obj (disp_map_slice_bicat D b). Proof. simple refine (_ ,, _). - exact disp_map_slice_biinitial_obj. - use make_is_biinitial. + exact disp_map_slice_biinitial_1cell_property. + exact disp_map_slice_biinitial_2cell_property. + exact disp_map_slice_biinitial_eq_property. Defined. End ArrowSubbicatInitial. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/OneTypesColimits.v000066400000000000000000000316661451125700300262720ustar00rootroot00000000000000(********************************************************************************* Colimits of 1-types Contents: 1. Initial object 2. Coproducts 3. Extensivity *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInOneTypes. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Require Import UniMath.Bicategories.Colimits.Extensive. Local Open Scope cat. (** 1. Initial object *) Definition empty_one_type : one_types := empty_HLevel 2. Definition empty_is_biinitial_one_types : is_biinitial empty_one_type. Proof. use make_is_biinitial. - exact (λ _, fromempty). - exact (λ _ _ _ z, fromempty z). - exact (λ _ _ _ _ _, funextsec _ _ _ (λ z, fromempty z)). Defined. Definition biinitial_obj_one_types : biinitial_obj one_types := empty_one_type ,, empty_is_biinitial_one_types. Definition strict_biinitial_one_types : is_strict_biinitial_obj empty_one_type. Proof. refine (empty_is_biinitial_one_types ,, _). intros X f. use weq_is_adjoint_equivalence. apply isweqtoempty. Defined. (** 2. Coproducts *) Definition coprod_one_types (X Y : one_type) : one_type. Proof. use make_one_type. - exact (X ⨿ Y). - apply isofhlevelssncoprod. + apply X. + apply Y. Defined. Definition bincoprod_cocone_one_types (X Y : one_types) : bincoprod_cocone X Y. Proof. use make_bincoprod_cocone. - exact (coprod_one_types X Y). - exact inl. - exact inr. Defined. Section CoprodUMP. Context (X Y : one_types). Definition binprod_cocone_has_binprod_ump_1_one_types : bincoprod_ump_1 (bincoprod_cocone_one_types X Y). Proof. intros Z. use make_bincoprod_1cell. - cbn ; intro z. induction z as [ x | y ]. + exact (bincoprod_cocone_inl Z x). + exact (bincoprod_cocone_inr Z y). - use make_invertible_2cell. + intro ; apply idpath. + apply one_type_2cell_iso. - use make_invertible_2cell. + intro ; apply idpath. + apply one_type_2cell_iso. Defined. Definition binprod_cocone_has_binprod_ump_2_one_types : bincoprod_ump_2 (bincoprod_cocone_one_types X Y). Proof. intros Z φ ψ α β. use iscontraprop1. - abstract (use invproofirrelevance ; intros γ₁ γ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use funextsec ; intro z ; induction z as [ x | y ] ; [ exact (eqtohomot (pr12 γ₁) x @ !(eqtohomot (pr12 γ₂) x)) | exact (eqtohomot (pr22 γ₁) y @ !(eqtohomot (pr22 γ₂) y)) ]). - simple refine (_ ,, _ ,, _). + cbn ; intro z. induction z as [ x | y ]. * exact (α x). * exact (β y). + abstract (use funextsec ; intro z ; cbn ; apply idpath). + abstract (use funextsec ; intro z ; cbn ; apply idpath). Defined. Definition binprod_cocone_has_binprod_ump_one_types : has_bincoprod_ump (bincoprod_cocone_one_types X Y). Proof. split. - exact binprod_cocone_has_binprod_ump_1_one_types. - exact binprod_cocone_has_binprod_ump_2_one_types. Defined. End CoprodUMP. Definition has_bincoprod_one_types : has_bincoprod one_types := λ X Y, bincoprod_cocone_one_types X Y ,, binprod_cocone_has_binprod_ump_one_types X Y. Definition one_types_with_biinitial_bincoprod : bicat_with_biinitial_bincoprod := one_types ,, biinitial_obj_one_types ,, has_bincoprod_one_types. (** 3. Extensivity *) Section OneTypesDisjoint. Notation "∁" := one_types_with_biinitial_bincoprod. Context (X Y : ∁). Let ι₁ : X --> pr1 (bincoprod_of ∁ X Y) := bincoprod_cocone_inl (pr1 (bincoprod_of ∁ X Y)). Let ι₂ : Y --> pr1 (bincoprod_of ∁ X Y) := bincoprod_cocone_inr (pr1 (bincoprod_of ∁ X Y)). Definition one_types_inl_inr : has_comma_ump (@biinitial_comma_cone ∁ _ _ _ ι₁ ι₂). Proof. split. - intro Z. use make_comma_1cell. + intro z. exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))). + use make_invertible_2cell. * intro z. exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))). * apply one_type_2cell_iso. + use make_invertible_2cell. * intro z. exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))). * apply one_type_2cell_iso. + abstract (use funextsec ; intro z ; exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z)))). - intros Z φ ψ α β p. use iscontraprop1. + abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use funextsec ; intro z ; exact (fromempty (φ z))). + simple refine (_ ,, _ ,, _). * intro z. exact (fromempty (φ z)). * abstract (use funextsec ; intro z ; exact (fromempty (φ z))). * abstract (use funextsec ; intro z ; exact (fromempty (φ z))). Defined. Definition one_types_inr_inl : has_comma_ump (@biinitial_comma_cone ∁ _ _ _ ι₂ ι₁). Proof. split. - intro Z. use make_comma_1cell. + intro z. exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))). + use make_invertible_2cell. * intro z. exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))). * apply one_type_2cell_iso. + use make_invertible_2cell. * intro z. exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))). * apply one_type_2cell_iso. + abstract (use funextsec ; intro z ; exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z)))). - intros Z φ ψ α β p. use iscontraprop1. + abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use funextsec ; intro z ; exact (fromempty (φ z))). + simple refine (_ ,, _ ,, _). * intro z. exact (fromempty (φ z)). * abstract (use funextsec ; intro z ; exact (fromempty (φ z))). * abstract (use funextsec ; intro z ; exact (fromempty (φ z))). Defined. End OneTypesDisjoint. Section OneTypesUniversal. Notation "∁" := one_types_with_biinitial_bincoprod. Context {X Y Z : ∁} (h : Z --> pr1 (bincoprod_of ∁ X Y)). Let ι₁ : one_types ⟦ X , pr1 (bincoprod_of ∁ X Y) ⟧ := inl. Let ι₂ : one_types ⟦ Y , pr1 (bincoprod_of ∁ X Y) ⟧ := inr. Let κ₁ : one_types ⟦ hfp_HLevel 3 _ h , Z ⟧ := hfpg' ι₁ h. Let κ₂ : one_types ⟦ hfp_HLevel 3 _ h , Z ⟧ := hfpg' ι₂ h. Definition one_types_universal_coprod_map (W : @bincoprod_cocone ∁ (hfp_HLevel 3 ι₁ h) (hfp_HLevel 3 ι₂ h)) : ∏ (z : pr1 Z) (q : pr1 X ⨿ pr1 Y) (p : h z = q), pr11 W. Proof. intros z q. induction q as [ x | y ]. - intro p. refine (bincoprod_cocone_inl W _). exact ((x ,, z) ,, p). - intro p. refine (bincoprod_cocone_inr W _). exact ((y ,, z) ,, p). Defined. Definition one_types_universal_coprod_map_idpath (W : @bincoprod_cocone ∁ (hfp_HLevel 3 (bincoprod_cocone_inl (pr1 (bincoprod_of ∁ X Y))) h) (hfp_HLevel 3 (bincoprod_cocone_inr (pr1 (bincoprod_of ∁ X Y))) h)) (z : pr1 Z) (q : pr1 X ⨿ pr1 Y) (p : h z = q) : one_types_universal_coprod_map W z q p = one_types_universal_coprod_map W z (h z) (idpath _). Proof. induction p. apply idpath. Defined. Section Universal. Context {W : one_types} {φ ψ : Z --> W} (α : κ₁ · φ ==> κ₁ · ψ) (β : κ₂ · φ ==> κ₂ · ψ). Definition one_types_universal_coprod_cell_help (z : pr1 Z) (q : pr111 (bincoprod_of ∁ X Y)) (p : h z = q) : φ z = ψ z. Proof. cbn in z, p, q. induction q as [ x | y ]. - exact (α ((x ,, z) ,, p)). - exact (β ((y ,, z) ,, p)). Defined. Definition one_types_universal_coprod_cell_help_eq (z : pr1 Z) (q : pr111 (bincoprod_of ∁ X Y)) (p : h z = q) : one_types_universal_coprod_cell_help z (h z) (idpath _) = one_types_universal_coprod_cell_help z q p. Proof. induction p. apply idpath. Qed. Definition one_types_universal_coprod_cell : φ ==> ψ := λ z, one_types_universal_coprod_cell_help z (h z) (idpath _). Definition one_types_universal_coprod_cell_inl : funhomotsec (hfpg' inl h) one_types_universal_coprod_cell = α. Proof. use funextsec. intro z. unfold funhomotsec, one_types_universal_coprod_cell. exact (one_types_universal_coprod_cell_help_eq _ _ (pr2 z)). Qed. Definition one_types_universal_coprod_cell_inr : funhomotsec (hfpg' inr h) one_types_universal_coprod_cell = β. Proof. use funextsec. intro z. unfold funhomotsec, one_types_universal_coprod_cell. exact (one_types_universal_coprod_cell_help_eq _ _ (pr2 z)). Qed. Definition one_types_universal_coprod_unique : isaprop (∑ (γ : φ ==> ψ), bincoprod_cocone_inl (make_bincoprod_cocone Z κ₁ κ₂) ◃ γ = α × bincoprod_cocone_inr (make_bincoprod_cocone Z κ₁ κ₂) ◃ γ = β). Proof. use invproofirrelevance. intros τ₁ τ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use funextsec. intro z. pose (q := h z). assert (p : h z = q). { apply idpath. } induction q as [ x | y ]. - exact (eqtohomot (pr12 τ₁) ((x ,, z) ,, p) @ !(eqtohomot (pr12 τ₂) ((x ,, z) ,, p))). - exact (eqtohomot (pr22 τ₁) ((y ,, z) ,, p) @ !(eqtohomot (pr22 τ₂) ((y ,, z) ,, p))). Qed. End Universal. Definition one_types_universal_coprod : has_bincoprod_ump (@make_bincoprod_cocone ∁ (hfp_HLevel 3 _ h) (hfp_HLevel 3 _ h) Z (hfpg' inl h) (hfpg' inr h)). Proof. split. - intro W. use make_bincoprod_1cell. + intro z ; cbn. exact (one_types_universal_coprod_map W z (h z) (idpath _)). + use make_invertible_2cell. * intro z. induction z as [ [ x z ] p ] ; cbn in *. exact (!one_types_universal_coprod_map_idpath W z (inl x) p). * apply one_type_2cell_iso. + use make_invertible_2cell. * intro z. induction z as [ [ x z ] p ] ; cbn in *. exact (!one_types_universal_coprod_map_idpath W z (inr x) p). * apply one_type_2cell_iso. - intros W φ ψ α β. use iscontraprop1. + apply one_types_universal_coprod_unique. + simple refine (_ ,, _ ,, _). * exact (one_types_universal_coprod_cell α β). * exact (one_types_universal_coprod_cell_inl α β). * exact (one_types_universal_coprod_cell_inr α β). Defined. End OneTypesUniversal. Definition is_extensive_one_types : is_extensive one_types_with_biinitial_bincoprod. Proof. intros X Y. split. - refine (_ ,, _ ,, _ ,, _). + apply one_types_isInjective_fully_faithful_1cell ; cbn. apply isweqonpathsincl. apply isinclii1. + apply one_types_isInjective_fully_faithful_1cell ; cbn. apply isweqonpathsincl. apply isinclii2. + exact (one_types_inl_inr X Y). + exact (one_types_inr_inl X Y). - use is_universal_from_pb_alt. + exact one_types_has_pb. + intros Z h. exact (one_types_universal_coprod h). Defined. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/OpCellBicatColimits.v000066400000000000000000000120641451125700300266340ustar00rootroot00000000000000(***************************************************************** Colimits in op2 bicat Contents: 1. Biinitial object 2. Coproducts 3. Extensive *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInOp2Bicat. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Require Import UniMath.Bicategories.Colimits.Extensive. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Local Open Scope cat. (** 1. Biinitial object *) Section OpCellBiinitial. Context {B : bicat} (b : B) (H : is_biinitial b). Definition op_cell_is_biinitial : @is_biinitial (op2_bicat B) b. Proof. use make_is_biinitial. - exact (λ y, is_biinitial_1cell_property H y). - exact (λ y f g, is_biinitial_2cell_property H _ g f). - exact (λ y f g α β, is_biinitial_eq_property H _ _ _ α β). Defined. End OpCellBiinitial. Definition op_cell_biinitial {B : bicat} (I : biinitial_obj B) : biinitial_obj (op2_bicat B) := pr1 I ,, op_cell_is_biinitial _ (pr2 I). (** 2. Coproducts *) Section OpCellCoproduct. Context {B : bicat} {b₁ b₂ s : B} (ι₁ : b₁ --> s) (ι₂ : b₂ --> s) (cocone := make_bincoprod_cocone s ι₁ ι₂) (ump : has_bincoprod_ump cocone). Definition op_cell_cocone : @bincoprod_cocone (op2_bicat B) b₁ b₂ := make_bincoprod_cocone s ι₁ ι₂. Definition has_bincoprod_ump_1_op_cell (q : @bincoprod_cocone (op2_bicat B) b₁ b₂) : bincoprod_1cell op_cell_cocone q. Proof. pose (k₁ := bincoprod_cocone_inl q). pose (k₂ := bincoprod_cocone_inr q). use make_bincoprod_1cell. - exact (bincoprod_ump_1cell ump k₁ k₂). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inl ump _ k₁ k₂)). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inr ump _ k₁ k₂)). Defined. Definition has_bincoprod_ump_2_op_cell : bincoprod_ump_2 op_cell_cocone. Proof. intros q φ ψ α β. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (bincoprod_ump_2cell_unique_alt ump _ _ (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). - simple refine (_ ,, _ ,, _). + exact (bincoprod_ump_2cell ump α β). + exact (bincoprod_ump_2cell_inl ump α β). + exact (bincoprod_ump_2cell_inr ump α β). Defined. Definition has_bincoprod_ump_op_cell : has_bincoprod_ump op_cell_cocone. Proof. split. - exact has_bincoprod_ump_1_op_cell. - exact has_bincoprod_ump_2_op_cell. Defined. End OpCellCoproduct. Definition op2_bicat_has_bincoprod {B : bicat} (HB : has_bincoprod B) : has_bincoprod (op2_bicat B) := λ x y, _ ,, has_bincoprod_ump_op_cell _ _ (pr2 (HB x y)). Definition op2_bicat_biinitial_coproduct (B : bicat_with_biinitial_bincoprod) : bicat_with_biinitial_bincoprod := op2_bicat B ,, op_cell_biinitial (pr12 B) ,, op2_bicat_has_bincoprod (pr22 B). (** 3. Extensive *) Definition op2_bicat_is_extensive (B : bicat_with_biinitial_bincoprod) (HB : is_extensive B) : is_extensive (op2_bicat_biinitial_coproduct B). Proof. intros x y. split. - simple refine (_ ,, _ ,, _ ,, _). + apply fully_faithful_op2_bicat. exact (pr1 (pr1 (HB x y))). + apply fully_faithful_op2_bicat. exact (pr12 (pr1 (HB x y))). + exact (op2_comma_has_comma_ump (pr222 (pr1 (HB x y)))). + exact (op2_comma_has_comma_ump (pr122 (pr1 (HB x y)))). - intros z h. pose (H := pr2 (HB x y) z h). refine (pr1 H ,, pr12 H ,, pr122 H ,, _). refine (pr1 (pr222 H) ,, pr12 (pr222 H) ,, pr122 (pr222 H) ,, _). refine (weq_op2_invertible_2cell _ _ (inv_of_invertible_2cell (pr1 (pr222 (pr222 H)))) ,, _). refine (weq_op2_invertible_2cell _ _ (inv_of_invertible_2cell (pr12 (pr222 (pr222 H)))) ,, _). simple refine (_ ,, _ ,, _). + exact (to_op2_has_pb_ump _ (pr122 (pr222 (pr222 H)))). + exact (to_op2_has_pb_ump _ (pr1 (pr222 (pr222 (pr222 H))))). + exact (has_bincoprod_ump_op_cell _ _ (pr2 (pr222 (pr222 (pr222 H))))). Defined. UniMath-20231010/UniMath/Bicategories/Colimits/Examples/SliceBicategoryColimits.v000066400000000000000000000256641451125700300275750ustar00rootroot00000000000000(********************************************************************************* Colimits in slice bicategory Contents: 1. Initial object 2. Coproducts *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Local Open Scope cat. (** 1. Initial object *) Section InitialSlice. Context {B : bicat} (I : biinitial_obj B) (b : B). Let κ : slice_bicat b := pr1 I ,, is_biinitial_1cell_property (pr2 I) b. Definition biinitial_1cell_property_slice : biinitial_1cell_property κ. Proof. intros f. refine (is_biinitial_1cell_property (pr2 I) _ ,, _) ; cbn. apply (is_biinitial_invertible_2cell_property (pr2 I)). Defined. Definition biinitial_2cell_property_slice (f : slice_bicat b) : biinitial_2cell_property κ f. Proof. intros g₁ g₂. simple refine (_ ,, _). - apply (is_biinitial_2cell_property (pr2 I)). - apply (is_biinitial_eq_property (pr2 I)). Defined. Definition biinitial_eq_property_slice (f : slice_bicat b) : biinitial_eq_property κ f. Proof. intros g₁ g₂ α β. use subtypePath. { intro. apply cellset_property. } apply (is_biinitial_eq_property (pr2 I)). Qed. Definition is_biinitial_slice : is_biinitial κ. Proof. refine (_ ,, _). - exact biinitial_1cell_property_slice. - intro f. split. + exact (biinitial_2cell_property_slice f). + exact (biinitial_eq_property_slice f). Defined. Definition biinitial_in_slice : biinitial_obj (slice_bicat b) := κ ,, is_biinitial_slice. End InitialSlice. (** 2. Coproducts *) Section CoproductSlice. Context {B : bicat} (b : B) {x₁ x₂ : B} (h₁ : x₁ --> b) (h₂ : x₂ --> b) (sum : B) (ι₁ : x₁ --> sum) (ι₂ : x₂ --> sum) (sum_cone := make_bincoprod_cocone sum ι₁ ι₂) (ump : has_bincoprod_ump sum_cone). Let hh₁ : slice_bicat b := make_ob_slice h₁. Let hh₂ : slice_bicat b := make_ob_slice h₂. Definition sum_slice : slice_bicat b := make_ob_slice (bincoprod_ump_1cell ump h₁ h₂). Definition inl_slice : hh₁ --> sum_slice. Proof. simple refine (make_1cell_slice _ _). - exact ι₁. - exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inl ump _ h₁ h₂)). Defined. Definition inr_slice : hh₂ --> sum_slice. Proof. simple refine (make_1cell_slice _ _). - exact ι₂. - exact (inv_of_invertible_2cell (bincoprod_ump_1cell_inr ump _ h₁ h₂)). Defined. Definition slice_coprod_cone : bincoprod_cocone hh₁ hh₂. Proof. use make_bincoprod_cocone. - exact sum_slice. - exact inl_slice. - exact inr_slice. Defined. Section UMP1. Context (q : bincoprod_cocone hh₁ hh₂). Definition slice_coprod_ump_1_map_mor : sum --> pr11 q. Proof. use (bincoprod_ump_1cell ump). - exact (pr1 (bincoprod_cocone_inl q)). - exact (pr1 (bincoprod_cocone_inr q)). Defined. Definition slice_coprod_ump_1_map_inv2cell : invertible_2cell (bincoprod_ump_1cell ump h₁ h₂) (slice_coprod_ump_1_map_mor · pr21 q). Proof. use make_invertible_2cell. - use (bincoprod_ump_2cell ump). + exact (bincoprod_ump_1cell_inl _ _ _ _ • pr1 (pr2 (bincoprod_cocone_inl q)) • ((bincoprod_ump_1cell_inl _ _ _ _)^-1 ▹ _) • rassociator _ _ _). + exact (bincoprod_ump_1cell_inr _ _ _ _ • pr1 (pr2 (bincoprod_cocone_inr q)) • ((bincoprod_ump_1cell_inr _ _ _ _)^-1 ▹ _) • rassociator _ _ _). - use bincoprod_ump_2cell_invertible. + is_iso ; apply property_from_invertible_2cell. + is_iso ; apply property_from_invertible_2cell. Defined. Definition slice_coprod_ump_1_map : slice_coprod_cone --> q. Proof. use make_1cell_slice ; cbn. - exact slice_coprod_ump_1_map_mor. - exact slice_coprod_ump_1_map_inv2cell. Defined. Definition slice_coprod_ump_1_map_inl_cell : ι₁ · slice_coprod_ump_1_map_mor ==> pr1 (bincoprod_cocone_inl q) := bincoprod_ump_1cell_inl ump _ (pr1 (bincoprod_cocone_inl q)) (pr1 (bincoprod_cocone_inr q)). Definition slice_coprod_ump_1_map_inl_eq : cell_slice_homot (bincoprod_cocone_inl slice_coprod_cone · slice_coprod_ump_1_map) (bincoprod_cocone_inl q) slice_coprod_ump_1_map_inl_cell. Proof. unfold cell_slice_homot. cbn. etrans. { apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply (bincoprod_ump_2cell_inl ump). } rewrite !vassocr. rewrite vcomp_linv, id2_left. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition slice_coprod_ump_1_map_inl : invertible_2cell (bincoprod_cocone_inl slice_coprod_cone · slice_coprod_ump_1_map) (bincoprod_cocone_inl q). Proof. use make_invertible_2cell. - use make_2cell_slice. + exact slice_coprod_ump_1_map_inl_cell. + exact slice_coprod_ump_1_map_inl_eq. - use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. Defined. Definition slice_coprod_ump_1_map_inr_cell : ι₂ · slice_coprod_ump_1_map_mor ==> pr1 (bincoprod_cocone_inr q) := bincoprod_ump_1cell_inr ump _ (pr1 (bincoprod_cocone_inl q)) (pr1 (bincoprod_cocone_inr q)). Definition slice_coprod_ump_1_map_inr_eq : cell_slice_homot (bincoprod_cocone_inr slice_coprod_cone · slice_coprod_ump_1_map) (bincoprod_cocone_inr q) slice_coprod_ump_1_map_inr_cell. Proof. unfold cell_slice_homot. cbn. etrans. { apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply (bincoprod_ump_2cell_inr ump). } rewrite !vassocr. rewrite vcomp_linv, id2_left. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition slice_coprod_ump_1_map_inr : invertible_2cell (bincoprod_cocone_inr slice_coprod_cone · slice_coprod_ump_1_map) (bincoprod_cocone_inr q). Proof. use make_invertible_2cell. - use make_2cell_slice. + exact slice_coprod_ump_1_map_inr_cell. + exact slice_coprod_ump_1_map_inr_eq. - use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. Defined. End UMP1. Definition slice_coprod_ump_1 : bincoprod_ump_1 slice_coprod_cone. Proof. intros q. use make_bincoprod_1cell. - exact (slice_coprod_ump_1_map q). - exact (slice_coprod_ump_1_map_inl q). - exact (slice_coprod_ump_1_map_inr q). Defined. Definition slice_coprod_ump_unique {q : slice_bicat b} {φ ψ : slice_coprod_cone --> q} (α : bincoprod_cocone_inl slice_coprod_cone · φ ==> bincoprod_cocone_inl slice_coprod_cone · ψ) (β : bincoprod_cocone_inr slice_coprod_cone · φ ==> bincoprod_cocone_inr slice_coprod_cone · ψ) : isaprop (∑ (γ : φ ==> ψ), bincoprod_cocone_inl slice_coprod_cone ◃ γ = α × bincoprod_cocone_inr slice_coprod_cone ◃ γ = β). Proof. use invproofirrelevance. intros γ₁ γ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use eq_2cell_slice. use (bincoprod_ump_2cell_unique_alt ump). - exact (maponpaths pr1 (pr12 γ₁) @ !(maponpaths pr1 (pr12 γ₂))). - exact (maponpaths pr1 (pr22 γ₁) @ !(maponpaths pr1 (pr22 γ₂))). Qed. Definition slice_coprod_ump_2 : bincoprod_ump_2 slice_coprod_cone. Proof. intros q φ ψ α β. use iscontraprop1. - exact (slice_coprod_ump_unique α β). - simple refine ((_ ,, _) ,, _ ,, _). + exact (bincoprod_ump_2cell ump (pr1 α) (pr1 β)). + cbn. use (bincoprod_ump_2cell_unique_alt ump). * abstract (rewrite <- lwhisker_vcomp ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite rwhisker_lwhisker ; rewrite bincoprod_ump_2cell_inl ; use (vcomp_lcancel ((bincoprod_ump_1cell_inl ump b h₁ h₂) ^-1)) ; [ is_iso | ] ; rewrite !vassocr ; pose (pr2 α) as p ; cbn in p ; rewrite !vassocr in p ; exact p). * abstract (rewrite <- lwhisker_vcomp ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite rwhisker_lwhisker ; rewrite bincoprod_ump_2cell_inr ; use (vcomp_lcancel ((bincoprod_ump_1cell_inr ump b h₁ h₂) ^-1)) ; [ is_iso | ] ; rewrite !vassocr ; pose (pr2 β) as p ; cbn in p ; rewrite !vassocr in p ; exact p). + abstract (use eq_2cell_slice ; cbn ; apply (bincoprod_ump_2cell_inl ump)). + abstract (use eq_2cell_slice ; cbn ; apply (bincoprod_ump_2cell_inr ump)). Defined. End CoproductSlice. Definition has_bincoprod_slice_bicat {B : bicat} (HB : has_bincoprod B) (b : B) : has_bincoprod (slice_bicat b). Proof. intros h₁ h₂. pose (sum := HB (pr1 h₁) (pr1 h₂)). refine (slice_coprod_cone b (pr2 h₁) (pr2 h₂) _ _ _ (pr2 sum) ,, _). split. - apply (slice_coprod_ump_1 b (pr2 h₁) (pr2 h₂)). - apply (slice_coprod_ump_2 b (pr2 h₁) (pr2 h₂)). Defined. UniMath-20231010/UniMath/Bicategories/Colimits/Extensive.v000066400000000000000000000126161451125700300232060ustar00rootroot00000000000000(********************************************************** Extensive bicategories Contents: 1. Disjoint coproducts 2. Universal coproducts **********************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Import PullbackFunctions.Notations. Local Open Scope cat. (** 1. Disjoint coproducts *) (******************************************* the initial object gives a comma cone on x --> z <-- y *******************************************) Definition biinitial_comma_cone {B : bicat_with_biinitial} {x y z : B} (f : x --> z) (g : y --> z) : comma_cone f g. Proof. use make_comma_cone. - exact (pr1 (biinitial_of B)). - exact (is_biinitial_1cell_property (pr2 (biinitial_of B)) _). - exact (is_biinitial_1cell_property (pr2 (biinitial_of B)) _). - exact (is_biinitial_2cell_property (pr2 (biinitial_of B)) _ _ _). Defined. Definition is_disjoint_coproduct {B : bicat_with_biinitial} {x p y : B} (ι₁ : x --> p) (ι₂ : y --> p) : UU := fully_faithful_1cell ι₁ × fully_faithful_1cell ι₂ × has_comma_ump (biinitial_comma_cone ι₁ ι₂) × has_comma_ump (biinitial_comma_cone ι₂ ι₁). Definition is_disjoint_coproduct_cone {B : bicat_with_biinitial} {x y : B} (p : bincoprod_cocone x y) : UU := is_disjoint_coproduct (bincoprod_cocone_inl p) (bincoprod_cocone_inr p). (** 2. Universal coproducts *) (******************************************* Given z | V x --> p <-- y we have pullbacks v --> z <-- w | | | V V V x --> p <-- y such that z is the coproduct of v and w *******************************************) Definition is_universal_coproduct {B : bicat} {x p y : B} (ι₁ : x --> p) (ι₂ : y --> p) : UU := ∏ (z : B) (h : z --> p), ∑ (v w : B) (f₁ : v --> x) (f₂ : w --> y) (g₁ : v --> z) (g₂ : w --> z) (γ₁ : invertible_2cell (f₁ · ι₁) (g₁ · h)) (γ₂ : invertible_2cell (f₂ · ι₂) (g₂ · h)) (H₁ : has_pb_ump (make_pb_cone _ f₁ g₁ γ₁)) (H₂ : has_pb_ump (make_pb_cone w f₂ g₂ γ₂)), has_bincoprod_ump (make_bincoprod_cocone _ g₁ g₂). Definition is_universal_coproduct_cone {B : bicat} {x y : B} (p : bincoprod_cocone x y) : UU := is_universal_coproduct (bincoprod_cocone_inl p) (bincoprod_cocone_inr p). Definition bicat_with_pb_is_universal_coproduct {B : bicat_with_pb} {x p y : B} (ι₁ : x --> p) (ι₂ : y --> p) : UU := ∏ (z : B) (h : z --> p), has_bincoprod_ump (make_bincoprod_cocone z (pb_pr2 ι₁ h) (pb_pr2 ι₂ h)). Definition is_universal_from_pb {B : bicat_with_pb} {x p y : B} (ι₁ : x --> p) (ι₂ : y --> p) (H : bicat_with_pb_is_universal_coproduct ι₁ ι₂) : is_universal_coproduct ι₁ ι₂ := λ z h, ι₁ /≃ h ,, ι₂ /≃ h ,, π₁ ,, π₁ ,, π₂ ,, π₂ ,, pb_cell ι₁ h ,, pb_cell ι₂ h ,, pb_obj_has_pb_ump ι₁ h ,, pb_obj_has_pb_ump ι₂ h ,, H z h. Definition is_universal_from_pb_alt {B : bicat} (HB : has_pb B) {x p y : B} (ι₁ : x --> p) (ι₂ : y --> p) (H : @bicat_with_pb_is_universal_coproduct (B ,, HB) _ _ _ ι₁ ι₂) : is_universal_coproduct ι₁ ι₂ := is_universal_from_pb _ _ H. (** 3. Extensive bicategory *) Definition bicat_with_biinitial_bincoprod : UU := ∑ (B : bicat), biinitial_obj B × has_bincoprod B. Coercion bicat_with_biinitial_bincoprod_to_bicat_with_biinitial (B : bicat_with_biinitial_bincoprod) : bicat_with_biinitial := pr1 B ,, pr12 B. Coercion bicat_with_biinitial_bincoprod_to_bicat_with_bincoprod (B : bicat_with_biinitial_bincoprod) : bicat_with_bincoprod := pr1 B ,, pr22 B. Definition is_extensive (B : bicat_with_biinitial_bincoprod) : UU := ∏ (x y : B), @is_disjoint_coproduct_cone B x y (pr1 (bincoprod_of B x y)) × @is_universal_coproduct_cone B x y (pr1 (bincoprod_of B x y)). UniMath-20231010/UniMath/Bicategories/Colimits/Initial.v000066400000000000000000000366371451125700300226360ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Biinitial object in a bicategory Niccolò Veltri, Niels van der Weide April 2019 Marco Maggesi, July 2019 Contents: 1. Definition of biinitial objects 2. Representable definition of biinitial objects 3. Equivalence between the two definitions 4. Bicategories with biinitial objects 5. Biinitial objects are unique 6. Biinitial objects are closed under equivalence 7. Strict biinitial objects ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope bicategory_scope. Local Open Scope cat. Section Initial. Context {B : bicat}. (** 1. Definition of biinitial objects *) Definition biinitial_1cell_property (X : B) : UU := ∏ (Y : B), X --> Y. Definition biinitial_2cell_property (X Y : B) : UU := ∏ (f g : X --> Y), f ==> g. Definition biinitial_eq_property (X Y : B) : UU := ∏ (f g : X --> Y) (α β : f ==> g), α = β. Definition is_biinitial (X : B) := biinitial_1cell_property X × ∏ (Y : B), biinitial_2cell_property X Y × biinitial_eq_property X Y. Definition is_biinitial_1cell_property {X : B} (HX : is_biinitial X) : biinitial_1cell_property X := pr1 HX. Definition is_biinitial_2cell_property {X : B} (HX : is_biinitial X) (Y : B) : biinitial_2cell_property X Y := pr1 (pr2 HX Y). Definition is_biinitial_eq_property {X : B} (HX : is_biinitial X) (Y : B) : biinitial_eq_property X Y := pr2 (pr2 HX Y). Definition is_biinitial_invertible_2cell_property {X : B} (HX : is_biinitial X) {Y : B} (f g : X --> Y) : invertible_2cell f g. Proof. use make_invertible_2cell. - apply (is_biinitial_2cell_property HX Y). - use make_is_invertible_2cell. + apply (is_biinitial_2cell_property HX Y). + apply (is_biinitial_eq_property HX Y). + apply (is_biinitial_eq_property HX Y). Defined. Definition make_is_biinitial (X : B) (H1 : biinitial_1cell_property X) (H2 : ∏ (Y : B), biinitial_2cell_property X Y) (H3 : ∏ (Y : B), biinitial_eq_property X Y) : is_biinitial X. Proof. refine (H1,, _). intro Y. exact (H2 Y,, H3 Y). Defined. Definition isaprop_biinitial_2cell_property {X Y : B} (H : biinitial_eq_property X Y) : isaprop (biinitial_2cell_property X Y). Proof. apply impred ; intro f. apply impred ; intro g. use invproofirrelevance. intros α β. apply H. Qed. Definition isaprop_biinitial_eq_property (X Y : B) : isaprop (biinitial_eq_property X Y). Proof. repeat (apply impred ; intro). apply cellset_property. Qed. Definition isaprop_is_biinitial (H : is_univalent_2_1 B) (X : B) : isaprop (is_biinitial X). Proof. apply invproofirrelevance. intros x y. induction x as [f Hf]. induction y as [g Hg]. use subtypePath. - intro ; simpl. apply impred ; intro Y. apply isapropdirprod. + apply isaprop_biinitial_2cell_property. apply Hf. + apply isaprop_biinitial_eq_property. - simpl. apply funextsec ; intro Y. apply (isotoid_2_1 H). apply (is_biinitial_invertible_2cell_property (f ,, Hf)). Qed. (** 2. Representable definition of biinitial objects *) Definition is_biinitial_repr (X : B) : UU := ∏ (Y : B), adj_equivalence_of_cats (functor_to_unit (hom X Y)). Definition isaprop_is_biinitial_repr (H : is_univalent_2_1 B) (X : B) : isaprop (is_biinitial_repr X). Proof. use impred. intros Y. use (isofhlevelweqf _ (adj_equiv_is_equiv_cat (functor_to_unit (univ_hom H X Y)))). apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. (** 3. Equivalence between the two definitions *) Definition biinitial_repr_1cell {X : B} (HX : is_biinitial_repr X) : biinitial_1cell_property X := λ Y, right_adjoint (HX Y) tt. Definition biinitial_repr_2cell {X : B} (HX : is_biinitial_repr X) {Y : B} : biinitial_2cell_property X Y. Proof. intros f g. pose (L := functor_to_unit (hom Y X)). pose (R := right_adjoint (HX Y)). pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)). pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)). pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)). exact (comp_of_invertible_2cell θ₁ (inv_of_invertible_2cell θ₂)). Defined. Definition biinitial_repr_eq {X : B} (HX : is_biinitial_repr X) {Y : B} : biinitial_eq_property X Y. Proof. intros f g α β. pose (L := functor_to_unit (hom Y X)). pose (R := right_adjoint (HX Y)). pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)). pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)). pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)). use (invmaponpathsincl _ (isinclweq _ _ _ (fully_faithful_from_equivalence _ _ _ (HX Y) _ _))). apply idpath. Qed. Definition is_biinitial_repr_to_is_biinitial {X : B} (HX : is_biinitial_repr X) : is_biinitial X. Proof. repeat split. - exact (biinitial_repr_1cell HX). - exact (biinitial_repr_2cell HX). - exact (biinitial_repr_eq HX). Defined. Definition biinitial_inv_data {X : B} (HX : is_biinitial X) (Y : B) : functor_data unit_category (hom X Y). Proof. use make_functor_data. - exact (λ _, is_biinitial_1cell_property HX Y). - exact (λ _ _ _, id₂ _). Defined. Definition biinitial_inv_is_functor {X : B} (HX : is_biinitial X) (Y : B) : is_functor (biinitial_inv_data HX Y). Proof. split. - intro ; intros. apply idpath. - intro ; intros. cbn. rewrite id2_left. apply idpath. Qed. Definition biinitial_inv {X : B} (HX : is_biinitial X) (Y : B) : unit_category ⟶ hom X Y. Proof. use make_functor. - exact (biinitial_inv_data HX Y). - exact (biinitial_inv_is_functor HX Y). Defined. Definition biinitial_inv_unit_data {X : B} (HX : is_biinitial X) (Y : B) : nat_trans_data (functor_identity (hom X Y)) (functor_composite (functor_to_unit (hom X Y)) (biinitial_inv HX Y)) := λ f, is_biinitial_2cell_property HX Y f (is_biinitial_1cell_property HX Y). Definition biinitial_inv_unit_is_nat_trans {X : B} (HX : is_biinitial X) (Y : B) : is_nat_trans _ _ (biinitial_inv_unit_data HX Y). Proof. intros f g α. simpl in * ; cbn. rewrite id2_right. apply (is_biinitial_eq_property HX Y). Qed. Definition biinitial_inv_unit {X : B} (HX : is_biinitial X) (Y : B) : (functor_identity (hom X Y)) ⟹ functor_composite (functor_to_unit (hom X Y)) (biinitial_inv HX Y). Proof. use make_nat_trans. - exact (biinitial_inv_unit_data HX Y). - exact (biinitial_inv_unit_is_nat_trans HX Y). Defined. Definition biinitial_inv_counit_data {X : B} (HX : is_biinitial X) (Y : B) : nat_trans_data (functor_composite (biinitial_inv HX Y) (functor_to_unit (hom X Y))) (functor_identity _). Proof. intros f. apply isapropunit. Defined. Definition biinitial_inv_counit_is_nat_trans {X : B} (HX : is_biinitial X) (Y : B) : is_nat_trans _ _ (biinitial_inv_counit_data HX Y). Proof. intros f g α. apply isasetunit. Qed. Definition biinitial_inv_counit {X : B} (HX : is_biinitial X) (Y : B) : (functor_composite (biinitial_inv HX Y) (functor_to_unit (hom X Y))) ⟹ (functor_identity _). Proof. use make_nat_trans. - exact (biinitial_inv_counit_data HX Y). - exact (biinitial_inv_counit_is_nat_trans HX Y). Defined. Definition is_biinitial_to_is_biinitial_repr_help {X : B} (HX : is_biinitial X) (Y : B) : equivalence_of_cats (hom X Y) unit_category. Proof. simple refine ((_ ,, (_ ,, (_ ,, _))) ,, (_ ,, _)). - exact (functor_to_unit _). - exact (biinitial_inv HX Y). - exact (biinitial_inv_unit HX Y). - exact (biinitial_inv_counit HX Y). - intros f. cbn ; unfold biinitial_inv_unit_data. apply is_inv2cell_to_is_z_iso. apply is_biinitial_invertible_2cell_property. - intro g. cbn. apply path_univalent_groupoid. Defined. Definition is_biinitial_to_is_biinitial_repr {X : B} (HX : is_biinitial X) : is_biinitial_repr X. Proof. intros Y. exact (adjointification (is_biinitial_to_is_biinitial_repr_help HX Y)). Defined. Definition is_biinitial_weq_is_biinitial_repr (H : is_univalent_2_1 B) (X : B) : is_biinitial X ≃ is_biinitial_repr X. Proof. use weqimplimpl. - exact is_biinitial_to_is_biinitial_repr. - exact is_biinitial_repr_to_is_biinitial. - exact (isaprop_is_biinitial H X). - exact (isaprop_is_biinitial_repr H X). Defined. End Initial. (** 4. Bicategories with biinitial objects *) Definition biinitial_obj (B : bicat) : UU := ∑ (X : B), is_biinitial X. Definition has_biinitial (B : bicat) : UU := ∥ biinitial_obj B ∥. Definition bicat_with_biinitial : UU := ∑ (B : bicat), biinitial_obj B. Coercion bicat_with_biinitial_to_bicat (B : bicat_with_biinitial) : bicat := pr1 B. Definition biinitial_of (B : bicat_with_biinitial) : biinitial_obj B := pr2 B. (** 5. Biinitial objects are unique *) Section Uniqueness. Context {B : bicat} (HB : is_univalent_2 B) {X : B} (HX : is_biinitial X) {Y : B} (HY : is_biinitial Y). Let HC0 : is_univalent_2_0 B := pr1 HB. Let HC1 : is_univalent_2_1 B := pr2 HB. Definition biinitial_unique_adj_unit : id₁ Y ==> is_biinitial_1cell_property HY X · is_biinitial_1cell_property HX Y := is_biinitial_2cell_property HY _ _ _. Definition biinitial_unique_adj_counit : is_biinitial_1cell_property HX Y · is_biinitial_1cell_property HY X ==> id₁ X := is_biinitial_2cell_property HX _ _ _. Definition biinitial_unique_adj_data : left_adjoint_data (is_biinitial_1cell_property HY X) := is_biinitial_1cell_property HX Y ,, biinitial_unique_adj_unit ,, biinitial_unique_adj_counit. Lemma biinitial_unique_left_eqv : left_equivalence_axioms biinitial_unique_adj_data. Proof. split. - apply is_biinitial_invertible_2cell_property. - apply is_biinitial_invertible_2cell_property. Qed. Definition biinitial_unique_adj_eqv : left_adjoint_equivalence (is_biinitial_1cell_property HY X). Proof. apply equiv_to_isadjequiv. unfold left_equivalence. exact (biinitial_unique_adj_data ,, biinitial_unique_left_eqv). Defined. Definition biinitial_unique : Y = X := isotoid_2_0 HC0 (_ ,, biinitial_unique_adj_eqv). End Uniqueness. (** 6. Biinitial objects are closed under equivalence *) Section EquivToBiinitial. Context {B : bicat} {X Y : B} (HX : is_biinitial X) {l : X --> Y} (Hl : left_adjoint_equivalence l). Let r : Y --> X := left_adjoint_right_adjoint Hl. Let ε : invertible_2cell (r · l) (id₁ Y) := left_equivalence_counit_iso Hl. Definition equiv_from_biinitial : is_biinitial Y. Proof. use make_is_biinitial. - exact (λ Z, r · is_biinitial_1cell_property HX Z). - exact (λ Z f g, linvunitor _ • (ε^-1 ▹ f) • rassociator _ _ _ • (r ◃ is_biinitial_2cell_property HX _ (l · f) (l · g)) • lassociator _ _ _ • (ε ▹ g) • lunitor _). - abstract (intros Z f g α β ; use (vcomp_lcancel (lunitor _)) ; [ is_iso | ] ; rewrite <- !vcomp_lunitor ; apply maponpaths_2 ; use (vcomp_lcancel (ε ▹ f)) ; [ is_iso ; apply property_from_invertible_2cell | ] ; rewrite !vcomp_whisker ; apply maponpaths_2 ; use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite <- !lwhisker_lwhisker ; apply maponpaths_2 ; apply maponpaths ; apply (is_biinitial_eq_property HX)). Defined. End EquivToBiinitial. Definition equiv_to_biinitial {B : bicat} {X Y : B} (HX : is_biinitial X) {l : Y --> X} (Hl : left_adjoint_equivalence l) : is_biinitial Y := equiv_from_biinitial HX (inv_adjequiv (l ,, Hl)). (** 7. Strict biinitial objects *) Definition biinitial_is_strict_biinitial_obj {B : bicat} {X : B} (HX : is_biinitial X) : UU := ∏ (Y : B) (f : Y --> X), left_adjoint_equivalence f. Definition is_strict_biinitial_obj {B : bicat} (X : B) : UU := ∑ (HX : is_biinitial X), biinitial_is_strict_biinitial_obj HX. Definition strict_biinitial_obj (B : bicat) : UU := ∑ (X : B), is_strict_biinitial_obj X. Definition bicat_with_strict_biinitial : UU := ∑ (B : bicat), strict_biinitial_obj B. Coercion bicat_with_strict_biinitial_to_bicat (B : bicat_with_strict_biinitial) : bicat := pr1 B. Definition strict_biinitial_of (B : bicat_with_strict_biinitial) : strict_biinitial_obj B := pr2 B. Definition map_to_strict_biinitial_is_biinitial {B : bicat} {X Y : B} (HX : is_strict_biinitial_obj X) (f : Y --> X) : is_biinitial Y := equiv_to_biinitial (pr1 HX) (pr2 HX _ f). UniMath-20231010/UniMath/Bicategories/Colimits/KleisliObjects.v000066400000000000000000000351431451125700300241420ustar00rootroot00000000000000(******************************************************************* Kleisli objects in bicategories Contents 1. Kleisli objects via universal mapping properties 2. It is a proposition 3. Bicategories with Kleisli objects *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. Section KleisliObject. Context {B : bicat} (m : mnd (op1_bicat B)). Let z : B := ob_of_mnd m. Let h : z --> z := endo_of_mnd m. Let η : id₁ _ ==> h := unit_of_mnd m. Let μ : h · h ==> h := mult_of_mnd m. (** 1. Kleisli objects via universal mapping properties *) Definition kleisli_cocone : UU := ∑ (x : B) (f : z --> x) (γ : h · f ==> f), (η ▹ f • γ = lunitor _) × (rassociator _ _ _ • (_ ◃ γ) • γ = (μ ▹ f) • γ). Definition make_kleisli_cocone {x : B} (f : z --> x) (γ : h · f ==> f) (fη : η ▹ f • γ = lunitor _) (fμ : rassociator _ _ _ • (_ ◃ γ) • γ = (μ ▹ f) • γ) : kleisli_cocone := x ,, f ,, γ ,, fη ,, fμ. Coercion kleisli_cocone_ob (q : kleisli_cocone) : B := pr1 q. Section Projections. Context (q : kleisli_cocone). Definition mor_of_kleisli_cocone : z --> q := pr12 q. Definition cell_of_kleisli_cocone : h · mor_of_kleisli_cocone ==> mor_of_kleisli_cocone := pr122 q. Definition kleisli_cocone_unit : (η ▹ _) • cell_of_kleisli_cocone = lunitor _ := pr1 (pr222 q). Definition kleisli_cocone_mult : rassociator _ _ _ • (_ ◃ cell_of_kleisli_cocone) • cell_of_kleisli_cocone = (μ ▹ _) • cell_of_kleisli_cocone := pr2 (pr222 q). End Projections. Definition kleisli_cocone_mor (q₁ q₂ : kleisli_cocone) : UU := ∑ (f : q₁ --> q₂) (α : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂), ((_ ◃ α) • cell_of_kleisli_cocone q₂ = lassociator _ _ _ • (cell_of_kleisli_cocone q₁ ▹ _) • α) × is_invertible_2cell α. Definition make_kleisli_cocone_mor {q₁ q₂ : kleisli_cocone} (f : q₁ --> q₂) (α : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂) (p : (_ ◃ α) • cell_of_kleisli_cocone q₂ = lassociator _ _ _ • (cell_of_kleisli_cocone q₁ ▹ _) • α) (Hα : is_invertible_2cell α) : kleisli_cocone_mor q₁ q₂ := f ,, α ,, p ,, Hα. Coercion mor_of_kleisli_cocone_mor {q₁ q₂ : kleisli_cocone} (f : kleisli_cocone_mor q₁ q₂) : q₁ --> q₂ := pr1 f. Definition cell_of_kleisli_cocone_mor {q₁ q₂ : kleisli_cocone} (f : kleisli_cocone_mor q₁ q₂) : mor_of_kleisli_cocone q₁ · f ==> mor_of_kleisli_cocone q₂ := pr12 f. Definition kleisli_cocone_mor_endo {q₁ q₂ : kleisli_cocone} (f : kleisli_cocone_mor q₁ q₂) : (_ ◃ cell_of_kleisli_cocone_mor f) • cell_of_kleisli_cocone q₂ = lassociator _ _ _ • (cell_of_kleisli_cocone q₁ ▹ _) • cell_of_kleisli_cocone_mor f := pr122 f. Definition cell_of_kleisli_cocone_mor_is_invertible {q₁ q₂ : kleisli_cocone} (f : kleisli_cocone_mor q₁ q₂) : is_invertible_2cell (cell_of_kleisli_cocone_mor f) := pr222 f. Definition inv2cell_of_kleisli_cocone_mor {q₁ q₂ : kleisli_cocone} (f : kleisli_cocone_mor q₁ q₂) : invertible_2cell (mor_of_kleisli_cocone q₁ · f) (mor_of_kleisli_cocone q₂). Proof. use make_invertible_2cell. - exact (cell_of_kleisli_cocone_mor f). - exact (cell_of_kleisli_cocone_mor_is_invertible f). Defined. Definition path_kleisli_cocone_mor (HB : is_univalent_2_1 B) {q₁ q₂ : kleisli_cocone} {f₁ f₂ : kleisli_cocone_mor q₁ q₂} (α : invertible_2cell f₁ f₂) (p : (mor_of_kleisli_cocone q₁ ◃ α) • cell_of_kleisli_cocone_mor f₂ = cell_of_kleisli_cocone_mor f₁) : f₁ = f₂. Proof. use total2_paths_f. - exact (isotoid_2_1 HB α). - use subtypePath. { intro. apply isapropdirprod ; [ apply cellset_property | apply isaprop_is_invertible_2cell ]. } rewrite pr1_transportf. rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function. cbn. rewrite id2_right. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite <- idtoiso_2_1_lwhisker. rewrite idtoiso_2_1_isotoid_2_1. exact (!p). Qed. Definition has_kleisli_ump_1 (k : kleisli_cocone) : UU := ∏ (q : kleisli_cocone), kleisli_cocone_mor k q. Definition has_kleisli_ump_2 (k : kleisli_cocone) : UU := ∏ (x : B) (g₁ g₂ : k --> x) (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)), ∃! (β : g₁ ==> g₂), _ ◃ β = α. Definition has_kleisli_ump (k : kleisli_cocone) : UU := has_kleisli_ump_1 k × has_kleisli_ump_2 k. Section Projections. Context {k : kleisli_cocone} (Hk : has_kleisli_ump k). Definition kleisli_ump_mor {a : B} {g : z --> a} (γ : h · g ==> g) (p₁ : (η ▹ g) • γ = lunitor g) (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ) : k --> a := pr1 Hk (make_kleisli_cocone g γ p₁ p₂). Definition kleisli_ump_mor_cell {a : B} {g : z --> a} (γ : h · g ==> g) (p₁ : (η ▹ g) • γ = lunitor g) (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ) : mor_of_kleisli_cocone k · kleisli_ump_mor γ p₁ p₂ ==> g := cell_of_kleisli_cocone_mor (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)). Definition kleisli_ump_mor_cell_endo {a : B} {g : z --> a} (γ : h · g ==> g) (p₁ : (η ▹ g) • γ = lunitor g) (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ) : (h ◃ kleisli_ump_mor_cell γ p₁ p₂) • γ = lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • kleisli_ump_mor_cell γ p₁ p₂ := kleisli_cocone_mor_endo (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)). Definition kleisli_ump_mor_cell_is_invertible {a : B} {g : z --> a} (γ : h · g ==> g) (p₁ : (η ▹ g) • γ = lunitor g) (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ) : is_invertible_2cell (kleisli_ump_mor_cell γ p₁ p₂) := cell_of_kleisli_cocone_mor_is_invertible (pr1 Hk (make_kleisli_cocone g γ p₁ p₂)). Definition kleisli_ump_mor_inv2cell {a : B} {g : z --> a} (γ : h · g ==> g) (p₁ : (η ▹ g) • γ = lunitor g) (p₂ : (rassociator h h g • (h ◃ γ)) • γ = (μ ▹ g) • γ) : invertible_2cell (mor_of_kleisli_cocone k · kleisli_ump_mor γ p₁ p₂) g. Proof. use make_invertible_2cell. - exact (kleisli_ump_mor_cell γ p₁ p₂). - exact (kleisli_ump_mor_cell_is_invertible γ p₁ p₂). Defined. Definition kleisli_ump_cell {x : B} {g₁ g₂ : k --> x} (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)) : g₁ ==> g₂ := pr11 (pr2 Hk x g₁ g₂ α p). Definition kleisli_ump_cell_eq {x : B} {g₁ g₂ : k --> x} (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)) : _ ◃ kleisli_ump_cell α p = α := pr21 (pr2 Hk x g₁ g₂ α p). Definition kleisli_ump_eq {x : B} {g₁ g₂ : k --> x} (α : mor_of_kleisli_cocone k · g₁ ==> mor_of_kleisli_cocone k · g₂) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)) {β₁ β₂ : g₁ ==> g₂} (q₁ : _ ◃ β₁ = α) (q₂ : _ ◃ β₂ = α) : β₁ = β₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr2 Hk x g₁ g₂ α p)) (β₁ ,, q₁) (β₂ ,, q₂))). Qed. Section Invertible. Context {x : B} {g₁ g₂ : k --> x} (α : invertible_2cell (mor_of_kleisli_cocone k · g₁) (mor_of_kleisli_cocone k · g₂)) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)). Definition kleisi_ump_cell_inv : g₂ ==> g₁. Proof. refine (kleisli_ump_cell (α^-1) _). abstract (use vcomp_move_R_Mp ; [ is_iso | ] ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; exact (!p)). Defined. Definition kleisi_ump_cell_inv_left : kleisli_ump_cell α p • kleisi_ump_cell_inv = id₂ _. Proof. use kleisli_ump_eq. - exact (id2 _). - rewrite id2_right. rewrite lwhisker_id2, id2_left. apply idpath. - rewrite <- !lwhisker_vcomp. unfold kleisi_ump_cell_inv. rewrite !kleisli_ump_cell_eq. apply vcomp_rinv. - apply lwhisker_id2. Qed. Definition kleisi_ump_cell_inv_right : kleisi_ump_cell_inv • kleisli_ump_cell α p = id₂ _. Proof. use kleisli_ump_eq. - exact (id2 _). - rewrite id2_right. rewrite lwhisker_id2, id2_left. apply idpath. - rewrite <- !lwhisker_vcomp. unfold kleisi_ump_cell_inv. rewrite !kleisli_ump_cell_eq. apply vcomp_linv. - apply lwhisker_id2. Qed. Definition kleisi_ump_cell_is_invertible : is_invertible_2cell (kleisli_ump_cell α p). Proof. use make_is_invertible_2cell. - exact kleisi_ump_cell_inv. - exact kleisi_ump_cell_inv_left. - exact kleisi_ump_cell_inv_right. Defined. End Invertible. Definition kleisli_ump_inv2cell {x : B} {g₁ g₂ : k --> x} (α : invertible_2cell (mor_of_kleisli_cocone k · g₁) (mor_of_kleisli_cocone k · g₂)) (p : lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _) • α = (_ ◃ α) • lassociator _ _ _ • (cell_of_kleisli_cocone k ▹ _)) : invertible_2cell g₁ g₂. Proof. use make_invertible_2cell. - exact (kleisli_ump_cell α p). - exact (kleisi_ump_cell_is_invertible α p). Defined. End Projections. (** 2. It is a proposition *) Definition isaprop_has_kleisli_ump (HB : is_univalent_2_1 B) (k : kleisli_cocone) : isaprop (has_kleisli_ump k). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. repeat (use impred ; intro). apply isapropiscontr. } use funextsec ; intro. use (path_kleisli_cocone_mor HB). - use (kleisli_ump_inv2cell φ₁). + exact (comp_of_invertible_2cell (inv2cell_of_kleisli_cocone_mor (pr1 φ₁ x)) (inv_of_invertible_2cell (inv2cell_of_kleisli_cocone_mor (pr1 φ₂ x)))). + abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite <- (kleisli_cocone_mor_endo (pr1 φ₁ x)) ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; exact (kleisli_cocone_mor_endo (pr1 φ₂ x))). - cbn. rewrite kleisli_ump_cell_eq. rewrite !vassocl. rewrite vcomp_linv. apply id2_right. Qed. End KleisliObject. (** 3. Bicategories with Kleisli objects *) Definition has_kleisli (B : bicat) : UU := ∏ (m : mnd (op1_bicat B)), ∑ (k : kleisli_cocone m), has_kleisli_ump m k. UniMath-20231010/UniMath/Bicategories/Core/000077500000000000000000000000001451125700300201445ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Core/AdjointUnique.v000066400000000000000000000516651451125700300231270ustar00rootroot00000000000000(** Right adjoints, units, counits are unique up to isomorphism. In addition, if the bicategory is locally univalent, then being an adjoint equivalence is a proposition. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Local Open Scope cat. Local Open Scope bicategory_scope. Definition adjoint_unique_map {C : bicat} {X Y : C} (l : C⟦X,Y⟧) (A₁ : left_adjoint l) (A₂ : left_adjoint l) : left_adjoint_right_adjoint A₁ ==> left_adjoint_right_adjoint A₂ := (lunitor _) o _ ◅ left_adjoint_counit A₁ o lassociator _ _ _ o left_adjoint_unit A₂ ▻ _ o rinvunitor _. Section AdjointUniqueMapCompose. Context {C : bicat} {X Y : C}. Lemma help₁ (f : C⟦X,Y⟧) (g g' : C⟦Y,X⟧) (η : id₁ X ==> g ∘ f) (η' : id₁ X ==> g' ∘ f) : ((g ∘ f) ◅ (η' ▻ g o rinvunitor _)) o η ▻ g = (η ▻ (g' ∘ f ∘ g) o rinvunitor _) o η' ▻ g. Proof. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite rinvunitor_natural. rewrite <- !vassocr. rewrite <- !interchange. rewrite !id2_left, !id2_right. rewrite <- (id2_left η). rewrite interchange. rewrite id2_left. apply (maponpaths (λ z, z • _)). rewrite left_unit_inv_assoc₂. rewrite <- triangle_l_inv. rewrite lunitor_V_id_is_left_unit_V_id. rewrite !lwhisker_hcomp. reflexivity. Qed. Lemma help₂ (f : C⟦X,Y⟧) (g g' : C⟦Y,X⟧) (η : id₁ X ==> g ∘ f) (η' : id₁ X ==> g' ∘ f) : g ◅ ((f ◅ η') ▻ g) o (g ◅ (linvunitor f ▻ g) o (lassociator _ _ _ o η ▻ g)) = g ◅ (rassociator _ _ _) o lassociator _ _ _ o η ▻ (g' ∘ f ∘ g) o rinvunitor _ o η' ▻ g. Proof. rewrite !vassocr. rewrite !(maponpaths (λ z, _ o (_ o z)) (!(vassocr _ _ _))). rewrite <- help₁. rewrite <- !vassocr. apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite <- hcomp_identity. rewrite hcomp_lassoc. rewrite !vassocr. rewrite hcomp_lassoc. rewrite <- !vassocr. apply maponpaths. rewrite <- !interchange. rewrite !id2_left. rewrite hcomp_rassoc. rewrite !vassocr. rewrite <- (id2_right (id₂ g)). rewrite !interchange. rewrite triangle_r_inv. rewrite id2_right. reflexivity. Qed. Variable (l : C⟦X,Y⟧) (A₁ : left_adjoint l) (A₂ : left_adjoint l). Local Notation r₁ := (left_adjoint_right_adjoint A₁). Local Notation r₂ := (left_adjoint_right_adjoint A₂). Local Notation η₁ := (left_adjoint_unit A₁). Local Notation η₂ := (left_adjoint_unit A₂). Local Notation ε₁ := (left_adjoint_counit A₁). Local Notation ε₂ := (left_adjoint_counit A₂). Local Notation r₁_to_r₂ := (adjoint_unique_map l A₁ A₂). Local Notation r₂_to_r₁ := (adjoint_unique_map l A₂ A₁). Local Definition composition_of_triangles : r₁ ==> r₁ := (lunitor r₁) o r₁ ◅ ε₁ o lassociator r₁ l r₁ o (r₁ ◅ ((runitor l) o ε₂ ▻ l o rassociator l r₂ l o l ◅ η₂ o linvunitor l) o η₁) ▻ r₁ o rinvunitor r₁. Local Lemma composition_of_triangles_is_identity : composition_of_triangles = id₂ r₁. Proof. unfold composition_of_triangles. rewrite !vassocr. rewrite (internal_triangle1 A₂). rewrite id2_rwhisker, id2_right. exact (internal_triangle2 A₁). Qed. Local Lemma ε₁_natural : ε₁ o (runitor l o ε₂ ⋆⋆ id₂ l) ⋆⋆ id₂ r₁ = ε₂ o l ◅ (lunitor r₂ o r₂ ◅ ε₁) o lassociator (l ∘ r₁) r₂ l o lassociator r₁ l (l ∘ r₂). Proof. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o (_ o z)) (!(vassocr _ _ _))). rewrite !rwhisker_hcomp. rewrite <- hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite <- !rwhisker_hcomp. rewrite lunitor_triangle. rewrite <- !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite <- !interchange. rewrite !hcomp_identity, id2_right, id2_left. rewrite <- (id2_left ε₁). rewrite <- (id2_right ε₂). rewrite interchange. rewrite <- !vassocr, !id2_right, !id2_left. rewrite <- runitor_lunitor_identity. rewrite <- !rwhisker_hcomp. rewrite !vcomp_runitor. rewrite !vassocr. rewrite <- hcomp_identity. rewrite <- hcomp_lassoc. rewrite <- !lwhisker_hcomp. rewrite <- lwhisker_vcomp. rewrite <- !vassocr. apply maponpaths. rewrite !vassocr. apply (maponpaths (λ z, z • ε₁)). rewrite <- runitor_triangle. rewrite !vassocr. rewrite lassociator_rassociator, id2_left. apply idpath. Qed. Lemma composition_of_maps : r₂_to_r₁ o r₁_to_r₂ = composition_of_triangles. Proof. unfold r₁_to_r₂, r₂_to_r₁, composition_of_triangles. rewrite !vassocr. apply (maponpaths (λ z, z • lunitor r₁)). rewrite <- !vassocr. apply (maponpaths (λ z, rinvunitor r₁ • z)). rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite <- !vassocr. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite !vassocr. rewrite !(maponpaths (fun z => z • _) (!(vassocr _ _ _))). rewrite hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (fun z => (z • _) • _) (!(vassocr _ _ _))). rewrite hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (fun z => ((z • _) • _) • _) (!(vassocr _ _ _))). rewrite hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (fun z => (((z • _) • _) • _) • _) (!(vassocr _ _ _))). rewrite hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (fun z => ((((z • _) • _) • _) • _) • _) (!(vassocr _ _ _))). rewrite hcomp_lassoc. rewrite !vassocr. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite help₂. rewrite <- !vassocr. apply maponpaths. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite <- !interchange. rewrite !vassocr. rewrite <- inverse_pentagon_3. rewrite <- !vassocr. do 3 rewrite interchange. rewrite !id2_left. rewrite !vassocr. rewrite !(maponpaths (λ z, ((z • _) • _) • _) (!(vassocr _ _ _))). rewrite <- hcomp_lassoc. rewrite <- interchange. rewrite !hcomp_identity. rewrite !vassocr, id2_left. rewrite ε₁_natural. rewrite <- rwhisker_vcomp. repeat (rewrite <- (id2_right (id₂ r₁)) ; rewrite interchange). rewrite !id2_right. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !(maponpaths (λ z, ((z • _) • _) • _) (!(vassocr _ _ _))). rewrite <- !rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite rassociator_lassociator, id2_rwhisker, id2_right. rewrite !vassocr. rewrite !(maponpaths (λ z, (z • _) • _) (!(vassocr _ _ _))). rewrite rwhisker_vcomp. rewrite rassociator_lassociator, id2_rwhisker, id2_right. rewrite !vassocr. rewrite !(maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite !rwhisker_hcomp. rewrite <- hcomp_lassoc. rewrite <- !vassocr. rewrite <- hcomp_lassoc. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !hcomp_identity. rewrite <- !vassocr. rewrite <- !interchange. rewrite !vassocr, !id2_left, !id2_right. rewrite <- (id2_right (lunitor r₂)). rewrite !vassocr. rewrite <- (id2_left η₁). rewrite interchange. rewrite !vassocr. rewrite !id2_right, !id2_left. apply (maponpaths (λ z, z • _)). apply rinvunitor_natural. Qed. End AdjointUniqueMapCompose. Section UniquenessAdjoint. Context {C : bicat} {X Y : C}. Variable (l : C⟦X,Y⟧) (A₁ : left_adjoint l) (A₂ : left_adjoint l). Local Notation r₁ := (left_adjoint_right_adjoint A₁). Local Notation r₂ := (left_adjoint_right_adjoint A₂). Local Notation η₁ := (left_adjoint_unit A₁). Local Notation η₂ := (left_adjoint_unit A₂). Local Notation ε₁ := (left_adjoint_counit A₁). Local Notation ε₂ := (left_adjoint_counit A₂). Local Notation r₁_to_r₂ := (adjoint_unique_map l A₁ A₂). Local Notation r₂_to_r₁ := (adjoint_unique_map l A₂ A₁). Definition adjoint_unique_map_iso : is_invertible_2cell r₁_to_r₂. Proof. use tpair. - exact r₂_to_r₁. - cbn. split. + rewrite (composition_of_maps l A₁ A₂). apply composition_of_triangles_is_identity. + rewrite (composition_of_maps l A₂ A₁). apply composition_of_triangles_is_identity. Defined. Lemma remove_η₂ : r₂ ◅ (runitor l o ε₁ ▻ l o rassociator l r₁ l o l ◅ η₁) o lassociator (id₁ X) l r₂ o linvunitor (r₂ ∘ l) o η₂ = η₂. Proof. refine (_ @ id2_right _). apply maponpaths. rewrite <- hcomp_identity. rewrite <- (internal_triangle1 A₁). rewrite <- rwhisker_hcomp. rewrite <- !rwhisker_vcomp. rewrite linvunitor_assoc. rewrite <- !vassocr. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply (maponpaths (fun z => ((z • _) • _) • _)). apply id2_left. Qed. Lemma help_triangle_η : (η₂ ▻ r₁) ▻ l o (rinvunitor r₁ ▻ l o η₁) = (rassociator l r₁ (r₂ ∘ l)) o rassociator (r₁ ∘ l) l r₂ o r₂ ◅ (l ◅ η₁) o lassociator (id₁ X) l r₂ o linvunitor (r₂ ∘ l) o η₂. Proof. rewrite !vassocr. rewrite !(maponpaths (λ z, (z • _) • _) (!(vassocr _ _ _))). rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite <- hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite lassociator_rassociator, id2_right. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. rewrite linvunitor_natural. rewrite <- !vassocr. rewrite <- interchange, id2_left, hcomp_identity, id2_right. rewrite hcomp_lassoc, hcomp_identity. rewrite lunitor_V_id_is_left_unit_V_id. rewrite !vassocr. rewrite !(maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite <- lwhisker_hcomp. rewrite <- left_unit_inv_assoc₂. rewrite rinvunitor_natural. rewrite <- !vassocr. apply maponpaths. rewrite <- interchange. rewrite !id2_right. apply (maponpaths (fun z => (z ⋆⋆ _))), id2_left. Qed. Lemma transport_unit : r₁_to_r₂ ▻ l o η₁ = η₂. Proof. rewrite <- remove_η₂. unfold r₁_to_r₂. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite help_triangle_η. rewrite linvunitor_assoc. rewrite !vassocr. rewrite !(maponpaths (λ z, ((((((z • _) • _) • _) • _) • _) • _)) (!(vassocr _ _ _))). rewrite rassociator_lassociator, id2_right. rewrite !(maponpaths (λ z, (((((z • _) • _) • _) • _) • _)) (!(vassocr _ _ _))). rewrite rwhisker_vcomp. rewrite <- !vassocr. rewrite <- !rwhisker_vcomp. repeat (apply maponpaths). rewrite <- !vassocr. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator, id2_left. rewrite <- !vassocr. apply maponpaths. rewrite !vassocr. rewrite inverse_pentagon. rewrite <- !vassocr. rewrite !rwhisker_hcomp. apply maponpaths. rewrite !vassocr. rewrite !(maponpaths (λ z, (z • _) • _) (!(vassocr _ _ _))). rewrite <- !lwhisker_hcomp. rewrite !lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2, id2_right. rewrite !lwhisker_hcomp. rewrite <- hcomp_rassoc. rewrite <- !vassocr. apply maponpaths. apply triangle_l. Qed. Lemma help_triangle_ε : ε₂ o l ◅ (lunitor r₂ o r₂ ◅ ε₁) = ε₁ o runitor (l ∘ r₁) o lassociator _ _ _ o ε₂ ▻ l ▻ r₁ o rassociator _ _ _ o rassociator _ _ _. Proof. rewrite !vassocr. rewrite !(maponpaths (λ z, (z • _) • _) (!(vassocr _ _ _))). rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite hcomp_lassoc. rewrite !vassocr. rewrite !(maponpaths (λ z, ((z • _) • _) • _) (!(vassocr _ _ _))). rewrite rassociator_lassociator, id2_right. rewrite <- !vassocr. use vcomp_move_L_pM. { is_iso. } cbn. rewrite <- runitor_natural. rewrite !vassocr. rewrite hcomp_identity. rewrite <- interchange. rewrite !id2_right, id2_left. rewrite <- !rwhisker_hcomp. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite !rwhisker_hcomp. rewrite <- hcomp_lassoc. rewrite !(maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite <- !rwhisker_hcomp. rewrite lunitor_triangle. rewrite <- !vassocr. rewrite <- vcomp_lunitor. rewrite lunitor_runitor_identity. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite hcomp_identity. rewrite <- interchange. rewrite !id2_right. apply (maponpaths (fun z => (z ⋆⋆ _))), id2_left. Qed. Lemma remove_ε₁ : ε₁ o runitor (l ∘ r₁) o lassociator r₁ l (id₁ Y) o (ε₂ ▻ l o rassociator l r₂ l o l ◅ η₂ o linvunitor l) ▻ r₁ = ε₁. Proof. rewrite !vassocr. rewrite !(maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite <- runitor_triangle. rewrite !vassocr. refine (_ @ id2_left _). apply (maponpaths (λ z, z • _)). rewrite <- !vassocr. rewrite <- lwhisker_id2. rewrite <- (internal_triangle1 A₂). rewrite <- !lwhisker_vcomp. rewrite <- !vassocr. repeat (apply maponpaths). rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. Qed. Lemma transport_counit : ε₂ o l ◅ r₁_to_r₂ = ε₁. Proof. rewrite <- remove_ε₁. unfold r₁_to_r₂. do 3 rewrite <- rwhisker_vcomp. rewrite <- !vassocr. rewrite help_triangle_ε. rewrite !vassocr. rewrite <- !lwhisker_vcomp. repeat (apply (maponpaths (λ z, z • _))). use vcomp_move_L_Mp. { is_iso. } cbn. rewrite (maponpaths (λ z, z • _) (!(vassocr _ _ _))). rewrite inverse_pentagon. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite <- !vassocr. rewrite (maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite <- interchange. rewrite lassociator_rassociator, !id2_right, hcomp_identity. rewrite id2_left. rewrite <- interchange. rewrite rassociator_lassociator, !id2_right, hcomp_identity. rewrite id2_right. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite <- lwhisker_vcomp. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite triangle_r_inv. rewrite <- !vassocr. apply maponpaths. apply hcomp_rassoc. Qed. End UniquenessAdjoint. Lemma unique_internal_adjoint_equivalence {C : bicat} {X Y : C} (l : C⟦X,Y⟧) (HC : is_univalent_2_1 C) (A₁ : left_adjoint_equivalence l) (A₂ : left_adjoint_equivalence l) : A₁ = A₂. Proof. use subtypePath. - intro x. apply isapropdirprod. + apply isapropdirprod ; apply C. + apply isapropdirprod ; apply isaprop_is_invertible_2cell. - cbn. use total2_paths_f. + apply (isotoid_2_1 HC). refine (adjoint_unique_map l A₁ A₂ ,, _). exact (adjoint_unique_map_iso l A₁ A₂). + rewrite transportf_dirprod. apply dirprod_paths. * rewrite transport_two_cell_FlFr. rewrite !maponpaths_for_constant_function ; cbn. rewrite id2_left. rewrite <- idtoiso_2_1_lwhisker. unfold isotoid_2_1. pose (homotweqinvweq (idtoiso_2_1 _ _,, HC Y X (left_adjoint_right_adjoint A₁) (left_adjoint_right_adjoint A₂))) as p. cbn in p. rewrite p ; clear p. cbn. exact (transport_unit l A₁ A₂). * cbn. rewrite transport_two_cell_FlFr. rewrite !maponpaths_for_constant_function ; cbn. rewrite id2_right. use vcomp_move_R_pM. { is_iso. } cbn. rewrite <- idtoiso_2_1_rwhisker. unfold isotoid_2_1. pose (homotweqinvweq (idtoiso_2_1 _ _,, HC Y X (left_adjoint_right_adjoint A₁) (left_adjoint_right_adjoint A₂))) as p. cbn in p. rewrite p ; clear p. cbn. symmetry. exact (transport_counit l A₁ A₂). Qed. Lemma path_internal_adjoint_equivalence {C : bicat} {X Y : C} (HC : is_univalent_2_1 C) (A₁ A₂ : adjoint_equivalence X Y) (H : arrow_of_adjunction A₁ = A₂) : A₁ = A₂. Proof. use total2_paths_f. - exact H. - apply unique_internal_adjoint_equivalence. apply HC. Qed. Lemma isaprop_left_adjoint_equivalence {C : bicat} {X Y : C} (f : X --> Y) : is_univalent_2_1 C → isaprop (left_adjoint_equivalence f). Proof. intros HU. apply invproofirrelevance. intros A1 A2. apply unique_internal_adjoint_equivalence. assumption. Qed. Definition isaprop_left_adjoint {B : bicat} (HB : is_univalent_2_1 B) {x y : B} (l : x --> y) : isaprop (left_adjoint l). Proof. use invproofirrelevance. intros Hl₁ Hl₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use total2_paths_f. - apply (isotoid_2_1 HB). refine (adjoint_unique_map l Hl₁ Hl₂ ,, _). exact (adjoint_unique_map_iso l Hl₁ Hl₂). - rewrite transportf_dirprod. apply pathsdirprod. + rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function ; cbn. rewrite id2_left. rewrite isotoid_2_1_lwhisker. rewrite idtoiso_2_1_isotoid_2_1 ; cbn. exact (transport_unit l Hl₁ Hl₂). + rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function ; cbn. rewrite id2_right. rewrite isotoid_2_1_rwhisker. rewrite idtoiso_2_1_isotoid_2_1 ; cbn. exact (transport_counit l Hl₂ Hl₁). Qed. (** As a corollary, in a univalent bicategory 0-cells are 2-types. *) Lemma univalent_bicategory_0_cell_hlevel_4 (C : bicat) (HC : is_univalent_2 C) : isofhlevel 4 C. Proof. change (isofhlevel 4 C) with (∏ a b : C, isofhlevel 3 (a = b)). intros a b. apply (isofhlevelweqb _ (idtoiso_2_0 a b,, pr1 HC a b)). apply (isofhleveltotal2 3). - apply univalent_bicategory_1_cell_hlevel_3, HC. - intros f. do 2 apply hlevelntosn. apply isaprop_left_adjoint_equivalence, HC. Qed. Section AdjointEquivUniqueCompInv. Context {B : bicat} (HB : is_univalent_2 B). Lemma unique_adjoint_equivalence_inv {a b : B} : ∏ (f : adjoint_equivalence a b), inv_adjequiv f = inv_adjoint_equivalence (pr1 HB) a b f. Proof. use (J_2_0 (pr1 HB) (λ a b f, _)). intro x; simpl. unfold inv_adjoint_equivalence. rewrite J_2_0_comp. use subtypePath. { intro. exact (isaprop_left_adjoint_equivalence _ (pr2 HB)). } apply idpath. Qed. End AdjointEquivUniqueCompInv. UniMath-20231010/UniMath/Bicategories/Core/Bicat.v000066400000000000000000001601041451125700300213570ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. (* ----------------------------------------------------------------------------------- *) (** ** Definition of prebicategory *) (* *) (** *** Data *) (* ----------------------------------------------------------------------------------- *) Definition prebicat_2cell_struct (C : precategory_ob_mor) : UU := ∏ (a b: C), C⟦a, b⟧ → C⟦a, b⟧ → UU. Definition prebicat_1_id_comp_cells : UU := ∑ (C : precategory_data), prebicat_2cell_struct C. Coercion precat_data_from_prebicat_1_id_comp_cells (C : prebicat_1_id_comp_cells) : precategory_data := pr1 C. Definition prebicat_cells (C : prebicat_1_id_comp_cells) {a b : C} (f g : C⟦a, b⟧) : UU := pr2 C a b f g. Local Notation "f '==>' g" := (prebicat_cells _ f g) (at level 60). Local Notation "f '<==' g" := (prebicat_cells _ g f) (at level 60, only parsing). Definition prebicat_2_id_comp_struct (C : prebicat_1_id_comp_cells) : UU := (* 2-unit *) (∏ (a b : C) (f : C⟦a, b⟧), f ==> f) × (* left unitor *) (∏ (a b : C) (f : C⟦a, b⟧), identity _ · f ==> f) × (* right unitor *) (∏ (a b : C) (f : C⟦a, b⟧), f · identity _ ==> f) × (* left inverse unitor *) (∏ (a b : C) (f : C⟦a, b⟧), identity _ · f <== f) × (* right inverse unitor *) (∏ (a b : C) (f : C⟦a, b⟧), f · identity _ <== f) × (* right associator *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧), (f · g) · h ==> f · (g · h)) × (* left associator *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧), f · (g · h) ==> (f · g) · h) × (* vertical composition *) (∏ (a b : C) (f g h : C⟦a, b⟧), f ==> g -> g ==> h -> f ==> h) × (* left whiskering *) (∏ (a b c : C) (f : C⟦a, b⟧) (g1 g2 : C⟦b, c⟧), g1 ==> g2 → f · g1 ==> f · g2) × (* right whiskering *) (∏ (a b c : C) (f1 f2 : C⟦a, b⟧) (g : C⟦b, c⟧), f1 ==> f2 → f1 · g ==> f2 · g). Definition prebicat_data : UU := ∑ C, prebicat_2_id_comp_struct C. Definition make_prebicat_data C (str : prebicat_2_id_comp_struct C) : prebicat_data := C,, str. (* ----------------------------------------------------------------------------------- *) (** Data projections. *) (* ----------------------------------------------------------------------------------- *) Coercion prebicat_cells_1_id_comp_from_prebicat_data (C : prebicat_data) : prebicat_1_id_comp_cells := pr1 C. Definition id2 {C : prebicat_data} {a b : C} (f : C⟦a, b⟧) : f ==> f := pr1 (pr2 C) a b f. Definition lunitor {C : prebicat_data} {a b : C} (f : C⟦a, b⟧) : identity _ · f ==> f := pr1 (pr2 (pr2 C)) a b f. Definition runitor {C : prebicat_data} {a b : C} (f : C⟦a, b⟧) : f · identity _ ==> f := pr1 (pr2 (pr2 (pr2 C))) a b f. Definition linvunitor {C : prebicat_data} {a b : C} (f : C⟦a, b⟧) : identity _ · f <== f := pr1 (pr2 (pr2 (pr2 (pr2 C)))) a b f. Definition rinvunitor {C : prebicat_data} {a b : C} (f : C⟦a, b⟧) : f · identity _ <== f := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 C))))) a b f. Definition rassociator {C : prebicat_data} {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : (f · g) · h ==> f · (g · h) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))) a b c d f g h. Definition lassociator {C : prebicat_data} {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : f · (g · h) ==> (f · g) · h := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))) a b c d f g h. Definition vcomp2 {C : prebicat_data} {a b : C} {f g h: C⟦a, b⟧} : f ==> g → g ==> h → f ==> h := λ x y, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))) _ _ _ _ _ x y. Definition lwhisker {C : prebicat_data} {a b c : C} (f : C⟦a, b⟧) {g1 g2 : C⟦b, c⟧} : g1 ==> g2 → f · g1 ==> f · g2 := λ x, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))) _ _ _ _ _ _ x. Definition rwhisker {C : prebicat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} (g : C⟦b, c⟧) : f1 ==> f2 → f1 · g ==> f2 · g := λ x, pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))) _ _ _ _ _ _ x. Local Notation "x • y" := (vcomp2 x y) (at level 60). Local Notation "f ◃ x" := (lwhisker f x) (at level 60). (* \tw *) Local Notation "y ▹ g" := (rwhisker g y) (at level 60). (* \tw nr 2 *) Definition hcomp {C : prebicat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} {g1 g2 : C⟦b, c⟧} : f1 ==> f2 -> g1 ==> g2 -> f1 · g1 ==> f2 · g2 := λ x y, (x ▹ g1) • (f2 ◃ y). Definition hcomp' {C : prebicat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} {g1 g2 : C⟦b, c⟧} : f1 ==> f2 -> g1 ==> g2 -> f1 · g1 ==> f2 · g2 := λ x y, (f1 ◃ y) • (x ▹ g2). Local Notation "x ⋆ y" := (hcomp x y) (at level 50, left associativity). (* ----------------------------------------------------------------------------------- *) (** ** Laws *) (* ----------------------------------------------------------------------------------- *) (* ----------------------------------------------------------------------------------- *) (** The numbers in the following laws refer to the list of axioms given in ncatlab (Section "Definition / Details") https://ncatlab.org/nlab/show/bicategory#detailedDefn version of October 7, 2015 10:35:36 *) (* ----------------------------------------------------------------------------------- *) Definition prebicat_laws (C : prebicat_data) : UU := (** 1a id2_left *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), id2 f • x = x) × (** 1b id2_right *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), x • id2 g = x) × (** 2 vassocr *) (∏ (a b : C) (f g h k : C⟦a, b⟧) (x : f ==> g) (y : g ==> h) (z : h ==> k), x • (y • z) = (x • y) • z) × (** 3a lwhisker_id2 *) (∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧), f ◃ id2 g = id2 _) × (** 3b id2_rwhisker *) (∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧), id2 f ▹ g = id2 _) × (** 4 lwhisker_vcomp *) (∏ (a b c : C) (f : C⟦a, b⟧) (g h i : C⟦b, c⟧) (x : g ==> h) (y : h ==> i), (f ◃ x) • (f ◃ y) = f ◃ (x • y)) × (** 5 rwhisker_vcomp *) (∏ (a b c : C) (f g h : C⟦a, b⟧) (i : C⟦b, c⟧) (x : f ==> g) (y : g ==> h), (x ▹ i) • (y ▹ i) = (x • y) ▹ i) × (** 6 vcomp_lunitor *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), (identity _ ◃ x) • lunitor g = lunitor f • x) × (** 7 vcomp_runitor *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), (x ▹ identity _) • runitor g = runitor f • x) × (** 8 lwhisker_lwhisker *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h i : c --> d) (x : h ==> i), f ◃ (g ◃ x) • lassociator _ _ _ = lassociator _ _ _ • (f · g ◃ x)) × (** 9 rwhisker_lwhisker *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g h : C⟦b, c⟧) (i : c --> d) (x : g ==> h), (f ◃ (x ▹ i)) • lassociator _ _ _ = lassociator _ _ _ • ((f ◃ x) ▹ i)) × (** 10 rwhisker_rwhisker *) (∏ (a b c d : C) (f g : C⟦a, b⟧) (h : C⟦b, c⟧) (i : c --> d) (x : f ==> g), lassociator _ _ _ • ((x ▹ h) ▹ i) = (x ▹ h · i) • lassociator _ _ _) × (** 11 vcomp_whisker *) (∏ (a b c : C) (f g : C⟦a, b⟧) (h i : C⟦b, c⟧) (x : f ==> g) (y : h ==> i), (x ▹ h) • (g ◃ y) = (f ◃ y) • (x ▹ i)) × (** 12a lunitor_linvunitor *) (∏ (a b : C) (f : C⟦a, b⟧), lunitor f • linvunitor _ = id2 _) × (** 12b linvunitor_lunitor *) (∏ (a b : C) (f : C⟦a, b⟧), linvunitor f • lunitor _ = id2 _) × (** 13a runitor_rinvunitor *) (∏ (a b : C) (f : C⟦a, b⟧), runitor f • rinvunitor _ = id2 _) × (** 13b rinvunitor_runitor *) (∏ (a b : C) (f : C⟦a, b⟧), rinvunitor f • runitor _ = id2 _) × (** 14a lassociator_rassociator *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d), lassociator f g h • rassociator _ _ _ = id2 _) × (** 14b rassociator_lassociator *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d), rassociator f g h • lassociator _ _ _ = id2 _) × (** 15 runitor_rwhisker *) (∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧), lassociator _ _ _ • (runitor f ▹ g) = f ◃ lunitor g) × (** 16 lassociator_lassociator *) (∏ (a b c d e: C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d) (i : C⟦d, e⟧), (f ◃ lassociator g h i) • lassociator _ _ _ • (lassociator _ _ _ ▹ i) = lassociator f g _ • lassociator _ _ _). Lemma isaprop_prebicat_laws (B : prebicat_data) (H : ∏ (a b : B) (f g : B ⟦ a, b ⟧), isaset (f ==> g)) : isaprop (prebicat_laws B). Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; apply H. Qed. Definition prebicat : UU := ∑ C : prebicat_data, prebicat_laws C. Coercion prebicat_data_from_bicat (C : prebicat) : prebicat_data := pr1 C. Coercion prebicat_laws_from_bicat (C : prebicat) : prebicat_laws C := pr2 C. (* ----------------------------------------------------------------------------------- *) (** Laws projections. *) (* ----------------------------------------------------------------------------------- *) Section prebicat_law_projections. Context {C : prebicat}. (** 1a id2_left *) Definition id2_left {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : id2 f • x = x := pr1 (pr2 C) _ _ _ _ x. (** 1b id2_right *) Definition id2_right {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : x • id2 g = x := pr1 (pr2 (pr2 C)) _ _ _ _ x. (** 2 vassocr *) Definition vassocr {a b : C} {f g h k : C⟦a, b⟧} (x : f ==> g) (y : g ==> h) (z : h ==> k) : x • (y • z) = (x • y) • z := pr1 (pr2 (pr2 (pr2 C))) _ _ _ _ _ _ x y z. (** 3a lwhisker_id2 *) Definition lwhisker_id2 {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : f ◃ id2 g = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 C)))) _ _ _ f g. (** 3b id2_rwhisker *) Definition id2_rwhisker {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : id2 f ▹ g = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 C))))) _ _ _ f g. (** 4 lwhisker_vcomp *) Definition lwhisker_vcomp {a b c : C} (f : C⟦a, b⟧) {g h i : C⟦b, c⟧} (x : g ==> h) (y : h ==> i) : (f ◃ x) • (f ◃ y) = f ◃ (x • y) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))) _ _ _ f _ _ _ x y. (** 5 rwhisker_vcomp *) Definition rwhisker_vcomp {a b c : C} {f g h : C⟦a, b⟧} (i : C⟦b, c⟧) (x : f ==> g) (y : g ==> h) : (x ▹ i) • (y ▹ i) = (x • y) ▹ i := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))) _ _ _ _ _ _ i x y. (** 6 vcomp_lunitor *) Definition vcomp_lunitor {a b : C} (f g : C⟦a, b⟧) (x : f ==> g) : (identity _ ◃ x) • lunitor g = lunitor f • x := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))) _ _ f g x. (** 7 vcomp_runitor *) Definition vcomp_runitor {a b : C} (f g : C⟦a, b⟧) (x : f ==> g) : (x ▹ identity _) • runitor g = runitor f • x := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))) _ _ f g x. (** 8 lwhisker_lwhisker *) Definition lwhisker_lwhisker {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) {h i : c --> d} (x : h ==> i) : f ◃ (g ◃ x) • lassociator _ _ _ = lassociator _ _ _ • (f · g ◃ x) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))) _ _ _ _ f g _ _ x. (** 9 rwhisker_lwhisker *) Definition rwhisker_lwhisker {a b c d : C} (f : C⟦a, b⟧) {g h : C⟦b, c⟧} (i : c --> d) (x : g ==> h) : (f ◃ (x ▹ i)) • lassociator _ _ _ = lassociator _ _ _ • ((f ◃ x) ▹ i) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))) _ _ _ _ f _ _ i x. (** 10 rwhisker_rwhisker *) Definition rwhisker_rwhisker {a b c d : C} {f g : C⟦a, b⟧} (h : C⟦b, c⟧) (i : c --> d) (x : f ==> g) : lassociator _ _ _ • ((x ▹ h) ▹ i) = (x ▹ h · i) • lassociator _ _ _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))) _ _ _ _ _ _ h i x. (** 11 vcomp_whisker *) Definition vcomp_whisker {a b c : C} {f g : C⟦a, b⟧} {h i : C⟦b, c⟧} (x : f ==> g) (y : h ==> i) : (x ▹ h) • (g ◃ y) = (f ◃ y) • (x ▹ i) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))))) _ _ _ _ _ _ _ x y. (** 12a lunitor_linvunitor *) Definition lunitor_linvunitor {a b : C} (f : C⟦a, b⟧) : lunitor f • linvunitor _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))))) _ _ f. (** 12b linvunitor_lunitor *) Definition linvunitor_lunitor {a b : C} (f : C⟦a, b⟧) : linvunitor f • lunitor _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))))))) _ _ f. (** 13a runitor_rinvunitor *) Definition runitor_rinvunitor {a b : C} (f : C⟦a, b⟧) : runitor f • rinvunitor _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))))))) _ _ f. (** 13b rinvunitor_runitor *) Definition rinvunitor_runitor {a b : C} (f : C⟦a, b⟧) : rinvunitor f • runitor _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))))))))) _ _ f. (** 14a lassociator_rassociator *) Definition lassociator_rassociator {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d) : lassociator f g h • rassociator _ _ _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))))))))) _ _ _ _ f g h. (** 14b rassociator_lassociator *) Definition rassociator_lassociator {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d) : rassociator f g h • lassociator _ _ _ = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))))))))))) _ _ _ _ f g h. (** 15 runitor_rwhisker *) Definition runitor_rwhisker {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : lassociator _ _ _ • (runitor f ▹ g) = f ◃ lunitor g := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))))))))))) _ _ _ f g . (** 16 lassociator_lassociator *) Definition lassociator_lassociator {a b c d e: C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : c --> d) (i : C⟦d, e⟧) : (f ◃ lassociator g h i) • lassociator _ _ _ • (lassociator _ _ _ ▹ i) = lassociator f g _ • lassociator _ _ _ := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))))))))))) _ _ _ _ _ f g h i. End prebicat_law_projections. (* ----------------------------------------------------------------------------------- *) (** ** Bicategories *) (* ----------------------------------------------------------------------------------- *) Definition isaset_cells (C : prebicat) : UU := ∏ (a b : C) (f g : a --> b), isaset (f ==> g). Definition bicat : UU := ∑ C : prebicat, isaset_cells C. Definition build_bicategory (C : prebicat_data) (HC1 : prebicat_laws C) (HC2 : isaset_cells (tpair _ C HC1)) : bicat := tpair _ (tpair _ C HC1) HC2. Definition build_prebicat_data (ob : UU) (mor : ob -> ob -> UU) (cell : ∏ {X Y : ob}, mor X Y -> mor X Y -> UU) (id₁ : ∏ (X : ob), mor X X) (comp : ∏ {X Y Z : ob}, mor X Y -> mor Y Z -> mor X Z) (id₂ : ∏ {X Y : ob} (f : mor X Y), cell f f) (vcomp : ∏ {X Y : ob} {f g h : mor X Y}, cell f g -> cell g h -> cell f h) (lwhisk : ∏ {X Y Z : ob} (f : mor X Y) {g h : mor Y Z}, cell g h -> cell (comp f g) (comp f h)) (rwhisk : ∏ {X Y Z : ob} {g h : mor X Y} (f : mor Y Z), cell g h -> cell (comp g f) (comp h f)) (lunitor : ∏ {X Y : ob} (f : mor X Y), cell (comp (id₁ X) f) f) (lunitor_inv : ∏ {X Y : ob} (f : mor X Y), cell f (comp (id₁ X) f)) (runitor : ∏ {X Y : ob} (f : mor X Y), cell (comp f (id₁ Y)) f) (runitor_inv : ∏ {X Y : ob} (f : mor X Y), cell f (comp f (id₁ Y))) (lassocor : ∏ {W X Y Z : ob} (f : mor W X) (g : mor X Y) (h : mor Y Z), cell (comp f (comp g h)) (comp (comp f g) h)) (rassocor : ∏ {W X Y Z : ob} (f : mor W X) (g : mor X Y) (h : mor Y Z), cell (comp (comp f g) h) (comp f (comp g h))) : prebicat_data. Proof. use tpair. - use tpair. + use tpair. * use tpair. ** exact ob. ** exact mor. * use tpair. ** exact id₁. ** exact comp. + exact cell. - use tpair. + exact id₂. + repeat (use tpair) ; simpl. * exact lunitor. * exact runitor. * exact lunitor_inv. * exact runitor_inv. * exact rassocor. * exact lassocor. * exact vcomp. * exact lwhisk. * exact rwhisk. Defined. Coercion prebicat_of_bicat (C : bicat) : prebicat := pr1 C. Definition cellset_property {C : bicat} {a b : C} (f g : a --> b) : isaset (f ==> g) := pr2 C a b f g. (* ----------------------------------------------------------------------------------- *) (** ** Invertible 2-cells *) (* ----------------------------------------------------------------------------------- *) Definition is_invertible_2cell {C : prebicat_data} {a b : C} {f g : a --> b} (η : f ==> g) : UU := ∑ φ : g ==> f, η • φ = id2 f × φ • η = id2 g. Definition make_is_invertible_2cell {C : prebicat_data} {a b : C} {f g : a --> b} {η : f ==> g} {φ : g ==> f} (ηφ : η • φ = id2 f) (φη : φ • η = id2 g) : is_invertible_2cell η := φ,, make_dirprod ηφ φη. Definition inv_cell {C : prebicat_data} {a b : C} {f g : a --> b} {η : f ==> g} : is_invertible_2cell η → g ==> f := pr1. (* TODO: Reorganize notations. *) Declare Scope bicategory_scope. Notation "inv_η ^-1" := (inv_cell inv_η) : bicategory_scope. Delimit Scope bicategory_scope with bicategory. Bind Scope bicategory_scope with bicat. Local Open Scope bicategory_scope. Definition vcomp_rinv {C : prebicat_data} {a b : C} {f g : a --> b} {η : f ==> g} (inv_η : is_invertible_2cell η) : η • inv_η^-1 = id2 f := pr1 (pr2 inv_η). Definition vcomp_linv {C : prebicat_data} {a b : C} {f g : a --> b} {η : f ==> g} (inv_η : is_invertible_2cell η) : inv_η^-1 • η = id2 g := pr2 (pr2 inv_η). Definition is_invertible_2cell_inv {C : prebicat_data} {a b : C} {f g : a --> b} {η : f ==> g} (inv_η : is_invertible_2cell η) : is_invertible_2cell (inv_η^-1) := make_is_invertible_2cell (vcomp_linv inv_η) (vcomp_rinv inv_η). Definition is_invertible_2cell_id₂ {C : prebicat} {a b : C} (f : a --> b) : is_invertible_2cell (id2 f) := make_is_invertible_2cell (id2_left (id2 f)) (id2_left (id2 f)). Lemma isaprop_is_invertible_2cell {C : bicat} {a b : C} {f g : C ⟦a, b⟧} (x : f ==> g) : isaprop (is_invertible_2cell x). Proof. apply invproofirrelevance. intros p q. apply subtypePath. { intro. apply isapropdirprod; apply cellset_property. } set (Hz1 := pr12 q). set (Hy2 := pr22 p). set (y := pr1 p). set (z := pr1 q). cbn in *. intermediate_path (y • (x • z)). - apply pathsinv0. etrans. { apply maponpaths. apply Hz1. } apply id2_right. - etrans. { apply vassocr. } etrans. { apply maponpaths_2. apply Hy2. } apply id2_left. Qed. Lemma isPredicate_is_invertible_2cell {C : bicat} {a b : C} {f g: C⟦a,b⟧} : isPredicate (is_invertible_2cell (f := f) (g := g)). Proof. intro x. apply isaprop_is_invertible_2cell. Qed. Lemma vcomp_rcancel {C : prebicat} {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) (inv_x : is_invertible_2cell x) {e : C⟦a, b⟧} {y z : e ==> f} : y • x = z • x -> y = z. Proof. intro R. transitivity ((y • x) • inv_x^-1). - rewrite <- vassocr, vcomp_rinv. apply (!id2_right _). - rewrite R, <- vassocr, vcomp_rinv. apply id2_right. Qed. Lemma vcomp_lcancel {C : prebicat} {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) (inv_x : is_invertible_2cell x) {h : C⟦a, b⟧} {y z : g ==> h} : x • y = x • z -> y = z. Proof. intro R. transitivity (inv_x^-1 • (x • y)). - rewrite vassocr, vcomp_linv. apply (!id2_left _). - rewrite R, vassocr, vcomp_linv. apply id2_left. Qed. Lemma inv_cell_eq {C : bicat} {a b : C} {f g : C ⟦a, b⟧} (x y : f ==> g) (inv_x : is_invertible_2cell x) (inv_y : is_invertible_2cell y) (p : inv_x^-1 = inv_y^-1) : x = y. Proof. apply (vcomp_rcancel _ (is_invertible_2cell_inv inv_x)). rewrite vcomp_rinv, p. apply (!vcomp_rinv _). Qed. (* ------------------------------------------------------------------------- *) (* Locally groupoidal *) (* ------------------------------------------------------------------------- *) Definition locally_groupoid (B : bicat) : UU := ∏ (x y : B) (f g : x --> y) (α : f ==> g), is_invertible_2cell α. Definition isaprop_locally_groupoid (B : bicat) : isaprop (locally_groupoid B). Proof. repeat (use impred ; intro). apply isaprop_is_invertible_2cell. Qed. (* ------------------------------------------------------------------------- *) (* invertible_2cell *) (* ------------------------------------------------------------------------- *) Definition invertible_2cell {C : prebicat_data} {a b : C} (f g : a --> b) : UU := ∑ η : f ==> g, is_invertible_2cell η. Definition make_invertible_2cell {C : prebicat_data} {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} (inv_η : is_invertible_2cell η) : invertible_2cell f g := η,, inv_η. Coercion cell_from_invertible_2cell {C : prebicat_data} {a b : C} {f g : a --> b} (η : invertible_2cell f g) : f ==> g := pr1 η. Coercion property_from_invertible_2cell {C : prebicat_data} {a b : C} {f g : a --> b} (η : invertible_2cell f g) : is_invertible_2cell η := pr2 η. Definition id2_invertible_2cell {C : prebicat} {a b : C} (f : a --> b) : invertible_2cell f f := make_invertible_2cell (is_invertible_2cell_id₂ f). Lemma cell_from_invertible_2cell_eq {C : bicat} {a b : C} {f g : C⟦a,b⟧} {x y : invertible_2cell f g} (p : cell_from_invertible_2cell x = cell_from_invertible_2cell y) : x = y. Proof. unfold cell_from_invertible_2cell. apply subtypePath. - intro. apply isPredicate_is_invertible_2cell. - apply p. Defined. (* ----------------------------------------------------------------------------------- *) (** ** Derived laws *) (* ----------------------------------------------------------------------------------- *) Section Derived_laws. Context {C : prebicat}. Definition vassocl {a b : C} {f g h k : C⟦a, b⟧} (x : f ==> g) (y : g ==> h) (z : h ==> k) : (x • y) • z = x • (y • z) := !vassocr x y z. Lemma vassoc4 {a b : C} {f g h i j: C ⟦a, b⟧} (w : f ==> g) (x : g ==> h) (y : h ==> i) (z : i ==> j) : w • (x • (y • z)) = w • (x • y) • z. Proof. repeat rewrite vassocr. apply idpath. Qed. Lemma is_invertible_2cell_rassociator {a b c d : C} (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧) : is_invertible_2cell (rassociator f g h). Proof. exists (lassociator f g h). split; [ apply rassociator_lassociator | apply lassociator_rassociator ]. Defined. Lemma is_invertible_2cell_lassociator {a b c d : C} (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧) : is_invertible_2cell (lassociator f g h). Proof. exists (rassociator f g h). split; [ apply lassociator_rassociator | apply rassociator_lassociator ]. Defined. Lemma lhs_right_invert_cell {a b : C} {f g h : a --> b} (x : f ==> g) (y : g ==> h) (z : f ==> h) (inv_y : is_invertible_2cell y) : x = z • inv_y^-1 -> x • y = z. Proof. intro H1. etrans. { apply maponpaths_2. apply H1. } etrans. { apply vassocl. } etrans. { apply maponpaths. apply (vcomp_linv inv_y). } apply id2_right. Qed. Lemma lhs_left_invert_cell {a b : C} {f g h : a --> b} (x : f ==> g) (y : g ==> h) (z : f ==> h) (inv_x : is_invertible_2cell x) : y = inv_x^-1 • z -> x • y = z. Proof. intro H1. etrans. { apply maponpaths. apply H1. } etrans. { apply vassocr. } etrans. { apply maponpaths_2. apply (vcomp_rinv inv_x). } apply id2_left. Qed. Lemma rhs_right_inv_cell {a b : C} {f g h : a --> b} (x : f ==> g) (y : g ==> h) (z : f ==> h) (inv_y : is_invertible_2cell y) : x • y = z -> x = z • inv_y^-1. Proof. intro H1. apply (vcomp_rcancel _ inv_y). etrans. { apply H1. } etrans. 2: apply vassocr. apply pathsinv0. etrans. { apply maponpaths. apply vcomp_linv. } apply id2_right. Qed. Lemma rhs_left_inv_cell {a b : C} {f g h : a --> b} (x : g ==> h) (y : f ==> g) (z : f ==> h) (inv_y : is_invertible_2cell y) : y • x = z -> x = inv_y^-1 • z. Proof. intro H1. apply (vcomp_lcancel _ inv_y). etrans. { apply H1. } etrans. 2: apply vassocl. apply pathsinv0. etrans. { apply maponpaths_2. apply (vcomp_rinv inv_y). } apply id2_left. Qed. Lemma rassociator_to_lassociator_post {a b c d : C} {f : C ⟦ a, b ⟧} {g : C ⟦ b, c ⟧} {h : C ⟦ c, d ⟧} {k : C ⟦ a, d ⟧} (x : k ==> (f · g) · h) (y : k ==> f · (g · h)) (p : x • rassociator f g h = y) : x = y • lassociator f g h. Proof. apply pathsinv0. use lhs_right_invert_cell. - apply is_invertible_2cell_lassociator. - cbn. exact (!p). Qed. Lemma lassociator_to_rassociator_post {a b c d : C} {f : C ⟦ a, b ⟧} {g : C ⟦ b, c ⟧} {h : C ⟦ c, d ⟧} {k : C ⟦ a, d ⟧} (x : k ==> (f · g) · h) (y : k ==> f · (g · h)) (p : x = y • lassociator f g h) : x • rassociator f g h = y. Proof. use lhs_right_invert_cell. - apply is_invertible_2cell_rassociator. - exact p. Qed. Lemma lassociator_to_rassociator_pre {a b c d : C} {f : C ⟦ a, b ⟧} {g : C ⟦ b, c ⟧} {h : C ⟦ c, d ⟧} {k : C ⟦ a, d ⟧} (x : f · (g · h) ==> k) (y : (f · g) · h ==> k) (p : x = lassociator f g h • y) : rassociator f g h • x = y. Proof. use lhs_left_invert_cell. - apply is_invertible_2cell_rassociator. - exact p. Qed. Lemma rassociator_to_lassociator_pre {a b c d : C} {f : C ⟦ a, b ⟧} {g : C ⟦ b, c ⟧} {h : C ⟦ c, d ⟧} {k : C ⟦ a, d ⟧} (x : f · (g · h) ==> k) (y : (f · g) · h ==> k) (p : rassociator f g h • x = y) : x = lassociator f g h • y. Proof. apply pathsinv0. use lhs_left_invert_cell. - apply is_invertible_2cell_lassociator. - exact (!p). Qed. Lemma lunitor_lwhisker {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : rassociator _ _ _ • (f ◃ lunitor g) = runitor f ▹ g. Proof. use lhs_left_invert_cell. { apply is_invertible_2cell_rassociator. } cbn. apply pathsinv0. apply runitor_rwhisker. Qed. Corollary unit_triangle {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : rassociator f (identity b) g • id2 f ⋆ lunitor g = runitor f ⋆ id2 g. Proof. unfold hcomp. rewrite id2_rwhisker. rewrite lwhisker_id2. rewrite id2_right. rewrite id2_left. apply lunitor_lwhisker. Qed. Lemma hcomp_hcomp' {a b c : C} {f1 f2 : C⟦a, b⟧} {g1 g2 : C⟦b, c⟧} (η : f1 ==> f2) (φ : g1 ==> g2) : hcomp η φ = hcomp' η φ. Proof. apply vcomp_whisker. Qed. Lemma hcomp_lassoc {a b c d : C} {f1 g1 : C ⟦ a, b ⟧} {f2 g2 : C ⟦ b, c ⟧} {f3 g3 : C ⟦ c, d ⟧} (x1 : f1 ==> g1) (x2 : f2 ==> g2) (x3 : f3 ==> g3) : x1 ⋆ (x2 ⋆ x3) • lassociator g1 g2 g3 = lassociator f1 f2 f3 • (x1 ⋆ x2) ⋆ x3. Proof. unfold hcomp. rewrite <- lwhisker_vcomp. repeat rewrite <- vassocr. rewrite lwhisker_lwhisker. repeat rewrite vassocr. apply maponpaths_2. rewrite <- vassocr. rewrite rwhisker_lwhisker. rewrite vassocr. rewrite <- rwhisker_rwhisker. rewrite <- vassocr. apply maponpaths. apply rwhisker_vcomp. Qed. Lemma is_invertible_2cell_lunitor {a b : C} (f : C ⟦ a, b ⟧) : is_invertible_2cell (lunitor f). Proof. exists (linvunitor f). abstract (apply (lunitor_linvunitor _ ,, linvunitor_lunitor _)). Defined. Lemma is_invertible_2cell_linvunitor {a b : C} (f : C ⟦ a, b ⟧) : is_invertible_2cell (linvunitor f). Proof. exists (lunitor f). abstract (apply (linvunitor_lunitor _ ,, lunitor_linvunitor _)). Defined. Lemma is_invertible_2cell_runitor {a b : C} (f : C ⟦ a, b ⟧) : is_invertible_2cell (runitor f). Proof. exists (rinvunitor f). abstract (apply (runitor_rinvunitor _ ,, rinvunitor_runitor _)). Defined. Lemma is_invertible_2cell_rinvunitor {a b : C} (f : C ⟦ a, b ⟧) : is_invertible_2cell (rinvunitor f). Proof. exists (runitor f). abstract (apply (rinvunitor_runitor _ ,, runitor_rinvunitor _)). Defined. Lemma hcomp_rassoc {a b c d : C} (f1 g1 : C ⟦ a, b ⟧) (f2 g2 : C ⟦ b, c ⟧) (f3 g3 : C ⟦ c, d ⟧) (x1 : f1 ==> g1) (x2 : f2 ==> g2) (x3 : f3 ==> g3) : (x1 ⋆ x2) ⋆ x3 • rassociator g1 g2 g3 = rassociator f1 f2 f3 • x1 ⋆ (x2 ⋆ x3). Proof. use lhs_right_invert_cell. { apply is_invertible_2cell_rassociator. } etrans; [ | apply vassocr ]. apply pathsinv0. use lhs_left_invert_cell. { apply is_invertible_2cell_rassociator. } apply hcomp_lassoc. Qed. Lemma hcomp_identity_left {a b c : C} (f : C ⟦ a, b ⟧)(g1 g2 : C ⟦ b, c ⟧) (y : g1 ==> g2) : id2 f ⋆ y = lwhisker f y. Proof. unfold hcomp. rewrite id2_rwhisker. apply id2_left. Qed. Lemma hcomp_identity_right {a b c : C} (f1 f2 : C ⟦ a, b ⟧)(g : C ⟦ b, c ⟧) (x : f1 ==> f2) : x ⋆ id2 g = rwhisker g x. Proof. unfold hcomp. rewrite lwhisker_id2. apply id2_right. Qed. Lemma hcomp_identity {a b c : C} (f1 : C ⟦ a, b ⟧) (f2 : C ⟦ b, c ⟧) : id2 f1 ⋆ id2 f2 = id2 (f1 · f2). Proof. rewrite hcomp_identity_left. apply lwhisker_id2. Qed. (* ----------------------------------------------------------------------------------- *) (** ** Interchange law *) (* ----------------------------------------------------------------------------------- *) Lemma hcomp_vcomp {a b c : C} (f1 g1 h1 : C ⟦ a, b ⟧) (f2 g2 h2 : C ⟦ b, c ⟧) (x1 : f1 ==> g1) (x2 : f2 ==> g2) (y1 : g1 ==> h1) (y2 : g2 ==> h2) : (x1 • y1) ⋆ (x2 • y2) = (x1 ⋆ x2) • (y1 ⋆ y2). Proof. unfold hcomp at 2 3. rewrite vassocr. rewrite vcomp_whisker. transitivity (((f1 ◃ x2) • ((x1 ▹ g2) • (y1 ▹ g2))) • (h1 ◃ y2)). 2: repeat rewrite vassocr; apply idpath. rewrite rwhisker_vcomp. rewrite <- vcomp_whisker. rewrite <- vassocr. rewrite lwhisker_vcomp. unfold hcomp. apply idpath. Qed. Lemma rwhisker_lwhisker_rassociator (a b c d : C) (f : C⟦a, b⟧) (g h : C⟦b, c⟧) (i : c --> d) (x : g ==> h) : rassociator _ _ _ • (f ◃ (x ▹ i)) = ((f ◃ x) ▹ i) • rassociator _ _ _ . Proof. apply (vcomp_lcancel (lassociator f g i)). { apply is_invertible_2cell_lassociator. } etrans. { etrans; [ apply vassocr |]. apply maponpaths_2. apply lassociator_rassociator. } etrans; [ apply id2_left |]. apply (vcomp_rcancel (lassociator f h i)). { apply is_invertible_2cell_lassociator. } apply pathsinv0. etrans; [ apply vassocl |]. etrans. { apply maponpaths. apply vassocl. } etrans. { do 2 apply maponpaths. apply rassociator_lassociator. } etrans. { apply maponpaths. apply id2_right. } apply pathsinv0, rwhisker_lwhisker. Qed. (** Analog to law 8, lwhisker_lwhisker *) Lemma lwhisker_lwhisker_rassociator (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h i : c --> d) (x : h ==> i) : rassociator f g h • (f ◃ (g ◃ x)) = (f · g ◃ x) • rassociator _ _ _ . Proof. apply (vcomp_lcancel (lassociator f g h)). { apply is_invertible_2cell_lassociator. } etrans. { etrans; [ apply vassocr |]. apply maponpaths_2. apply lassociator_rassociator. } etrans; [ apply id2_left |]. apply (vcomp_rcancel (lassociator f g i)). { apply is_invertible_2cell_lassociator. } apply pathsinv0. etrans; [ apply vassocl |]. etrans. { apply maponpaths. apply vassocl. } etrans. { do 2 apply maponpaths. apply rassociator_lassociator. } etrans. { apply maponpaths. apply id2_right. } apply pathsinv0, lwhisker_lwhisker. Qed. (** Analog to [rwhisker_rwhisker]. *) Lemma rwhisker_rwhisker_alt {a b c d : C} (f : C ⟦ b, a ⟧) (g : C ⟦ c, b ⟧) {h i : C ⟦ d, c ⟧} (x : h ==> i) : ((x ▹ g) ▹ f) • rassociator i g f = rassociator h g f • (x ▹ g · f). Proof. apply (vcomp_lcancel (lassociator h g f)). { apply is_invertible_2cell_lassociator. } etrans. { apply vassocr. } etrans. { apply maponpaths_2, rwhisker_rwhisker. } etrans. { apply vassocl. } etrans. { apply maponpaths, lassociator_rassociator. } apply pathsinv0. etrans. { apply vassocr. } etrans. { apply maponpaths_2, lassociator_rassociator. } etrans. - apply id2_left. - apply pathsinv0, id2_right. Qed. Lemma rassociator_rassociator {a b c d e : C} (f : C ⟦ a, b ⟧) (g : C ⟦ b, c ⟧) (h : C ⟦ c, d ⟧) (i : C ⟦ d, e ⟧) : ((rassociator f g h ▹ i) • rassociator f (g · h) i) • (f ◃ rassociator g h i) = rassociator (f · g) h i • rassociator f g (h · i). Proof. apply (vcomp_lcancel (lassociator (f · g) h i)). { apply is_invertible_2cell_lassociator. } apply (vcomp_lcancel (lassociator f g (h · i))). { apply is_invertible_2cell_lassociator. } etrans. { apply vassocr. } etrans. { apply maponpaths_2, pathsinv0. apply lassociator_lassociator. } etrans. { apply vassocl. } etrans. { apply maponpaths. etrans. { apply maponpaths, vassocl. } etrans. { apply vassocr. } apply maponpaths_2. etrans. { apply rwhisker_vcomp. } apply maponpaths, lassociator_rassociator. } apply pathsinv0. etrans. { apply maponpaths. etrans. { apply vassocr. } etrans. { apply maponpaths_2, lassociator_rassociator. } apply id2_left. } etrans. { apply lassociator_rassociator. } apply pathsinv0. etrans. { apply maponpaths. etrans. { apply vassocr. } apply maponpaths_2. etrans. { apply maponpaths_2, id2_rwhisker. } apply id2_left. } etrans. { apply vassocl. } etrans. { apply maponpaths. etrans. { apply vassocr. } etrans. { apply maponpaths_2. apply lassociator_rassociator. } apply id2_left. } etrans. { apply lwhisker_vcomp. } etrans. { apply maponpaths. apply lassociator_rassociator. } apply lwhisker_id2. Qed. Corollary associativity_pentagon {a b c d e : C} (f : C ⟦ a, b ⟧) (g : C ⟦ b, c ⟧) (h : C ⟦ c, d ⟧) (i : C ⟦ d, e ⟧) : (rassociator f g h ⋆ id2 i • rassociator f (g · h) i) • id2 f ⋆ rassociator g h i = rassociator (f · g) h i • rassociator f g (h · i). Proof. unfold hcomp. rewrite id2_rwhisker. rewrite lwhisker_id2. rewrite id2_right. rewrite id2_left. apply rassociator_rassociator. Qed. End Derived_laws. (* ----------------------------------------------------------------------------------- *) (** ** Homs are categories *) (* ----------------------------------------------------------------------------------- *) Section Hom_Spaces. Context {C : prebicat} (a b : C). Definition hom_ob_mor : precategory_ob_mor := make_precategory_ob_mor (C⟦a,b⟧) (λ (f g : C⟦a,b⟧), f ==> g). Definition hom_data : precategory_data := make_precategory_data hom_ob_mor id2 (λ f g h x y, x • y). Lemma is_precategory_hom : is_precategory hom_data. Proof. apply is_precategory_one_assoc_to_two. repeat split; cbn. - intros f g. apply id2_left. - intros f g. apply id2_right. - intros f g h i. apply vassocr. Qed. Definition hom_precategory : precategory := make_precategory hom_data is_precategory_hom. End Hom_Spaces. Lemma has_homsets_hom_data {C : bicat} (a b : C): has_homsets (hom_data a b). Proof. exact (@cellset_property C a b). Qed. Definition hom {C : bicat} (a b : C) : category := hom_precategory a b ,, @cellset_property C a b. (* ----------------------------------------------------------------------------------- *) (** ** Functor structure on horizontal composition. *) (* ----------------------------------------------------------------------------------- *) Section hcomp_functor. Context {C : bicat} {a b c : C}. Definition hcomp_functor_data : functor_data (category_binproduct (hom a b) (hom b c)) (hom a c). Proof. exists (λ p : (a-->b) × (b-->c), pr1 p · pr2 p). unfold hom_ob_mor. simpl. intros (f1, f2) (g1, g2). unfold precategory_binproduct_mor. simpl. intros (x, y). apply hcomp; assumption. Defined. Lemma is_functor_hcomp : is_functor hcomp_functor_data. Proof. split; red; cbn. - intros (f1, f2). cbn. apply hcomp_identity. - intros (f1, f2) (g1, g2) (h1, h2). unfold precategory_binproduct_mor. cbn. intros (x1, x2) (y1, y2). cbn. apply hcomp_vcomp. Qed. Definition hcomp_functor : category_binproduct (hom a b) (hom b c) ⟶ hom a c := make_functor hcomp_functor_data is_functor_hcomp. (** and the two whiskering functors separately so as to avoid [category_binproduct] *) Definition lwhisker_functor_data (f : C⟦a, b⟧) : functor_data (hom b c) (hom a c). Proof. exists (fun g => f · g). exact (fun g1 g2 x => f ◃ x). Defined. Lemma is_functor_lwhisker (f : C⟦a, b⟧) : is_functor (lwhisker_functor_data f). Proof. split; red; cbn. - intro g. apply lwhisker_id2. - intros g1 g2 g3 x y. apply pathsinv0, lwhisker_vcomp. Qed. Definition lwhisker_functor (f : C⟦a, b⟧) : functor (hom b c) (hom a c) := make_functor (lwhisker_functor_data f) (is_functor_lwhisker f). Definition rwhisker_functor_data (g : C⟦b, c⟧) : functor_data (hom a b) (hom a c). Proof. exists (fun f => f · g). exact (fun f1 f2 x => x ▹ g). Defined. Lemma is_functor_rwhisker (g : C⟦b, c⟧) : is_functor (rwhisker_functor_data g). Proof. split; red; cbn. - intro f. apply id2_rwhisker. - intros f1 f2 f3 x y. apply pathsinv0, rwhisker_vcomp. Qed. Definition rwhisker_functor (g : C⟦b, c⟧) : functor (hom a b) (hom a c) := make_functor (rwhisker_functor_data g) (is_functor_rwhisker g). End hcomp_functor. (* ----------------------------------------------------------------------------------- *) (** ** Chaotic bicat *) (* ----------------------------------------------------------------------------------- *) Section chaotic_bicat. Variable C : precategory. Definition chaotic_prebicat_data : prebicat_data. Proof. use tpair. - use tpair. + exact C. + cbn. intros a b f g. exact unit. - cbn; repeat (use tpair); cbn; intros; exact tt. Defined. Lemma chaotic_prebicat_laws : prebicat_laws chaotic_prebicat_data. Proof. repeat apply make_dirprod; intros; apply isProofIrrelevantUnit. Qed. Definition chaotic_prebicat : prebicat := chaotic_prebicat_data,, chaotic_prebicat_laws. Lemma isaset_chaotic_cells : isaset_cells chaotic_prebicat. Proof. red. cbn. intros. exact isasetunit. Qed. Definition chaotic_bicat : bicat := chaotic_prebicat,, isaset_chaotic_cells. End chaotic_bicat. (* ----------------------------------------------------------------------------------- *) (** ** Associators and unitors are isos. *) (* ----------------------------------------------------------------------------------- *) Section Associators_Unitors_Iso. Context {C : prebicat}. Lemma is_z_iso_lassociator {a b c d : C} (f : hom_precategory a b) (g : hom_precategory b c) (h : hom_precategory c d) : is_z_isomorphism (lassociator f g h : (hom_precategory a d) ⟦ f · (g · h), (f · g) · h ⟧). Proof. exists (rassociator f g h). split. - apply lassociator_rassociator. - apply rassociator_lassociator. Defined. Lemma is_iso_lassociator {a b c d : C} (f : hom_precategory a b) (g : hom_precategory b c) (h : hom_precategory c d) : is_iso (lassociator f g h : (hom_precategory a d) ⟦ f · (g · h), (f · g) · h ⟧). Proof. apply is_iso_from_is_z_iso. apply is_z_iso_lassociator. Defined. Lemma is_z_iso_rassociator {a b c d : C} (f : hom_precategory a b) (g : hom_precategory b c) (h : hom_precategory c d) : is_z_isomorphism (rassociator f g h : (hom_precategory a d) ⟦ (f · g) · h, f · (g · h) ⟧). Proof. exists (lassociator f g h). split. - apply rassociator_lassociator. - apply lassociator_rassociator. Defined. Lemma is_iso_rassociator {a b c d : C} (f : hom_precategory a b) (g : hom_precategory b c) (h : hom_precategory c d) : is_iso (rassociator f g h : (hom_precategory a d) ⟦ (f · g) · h, f · (g · h) ⟧). Proof. apply is_iso_from_is_z_iso. apply is_z_iso_rassociator. Defined. Lemma is_z_iso_lunitor {a b : C} (f : hom_precategory a b) : is_z_isomorphism (lunitor f : (hom_precategory a b) ⟦ identity a · f, f ⟧). Proof. exists (linvunitor f). split. - apply lunitor_linvunitor. - apply linvunitor_lunitor. Defined. Lemma is_iso_lunitor {a b : C} (f : hom_precategory a b) : is_iso (lunitor f : (hom_precategory a b) ⟦ identity a · f, f ⟧). Proof. apply is_iso_from_is_z_iso. apply is_z_iso_lunitor. Defined. Lemma is_z_iso_runitor {a b : C} (f : hom_precategory a b) : is_z_isomorphism (runitor f : (hom_precategory a b) ⟦ f · identity b, f ⟧). Proof. exists (rinvunitor f). split. - apply runitor_rinvunitor. - apply rinvunitor_runitor. Defined. Lemma is_iso_runitor {a b : C} (f : hom_precategory a b) : is_iso (runitor f : (hom_precategory a b) ⟦ f · identity b, f ⟧). Proof. apply is_iso_from_is_z_iso. apply is_z_iso_runitor. Defined. End Associators_Unitors_Iso. (* ----------------------------------------------------------------------------------- *) (** ** Functor structure on associators and unitors. *) (* ----------------------------------------------------------------------------------- *) Section Associators_Unitors_Natural. Context {C : prebicat}. (* -----------------------------------------------------------------------------------*) (** Left unitor *) (* -----------------------------------------------------------------------------------*) Lemma lunitor_natural (a b : C) (f g : C ⟦ a, b ⟧) (x : f ==> g) : id2 (identity a) ⋆ x • lunitor g = lunitor f • x. Proof. unfold hcomp. rewrite <- vassocr. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. rewrite id2_rwhisker. apply id2_left. Qed. (* Definition lunitor_transf (a b : C) : bindelta_pair_functor (constant_functor (hom_precategory a b) (hom_precategory a a) (identity a)) (functor_identity (hom_precategory a b)) ∙ hcomp_functor ⟹ functor_identity (hom_precategory a b) := lunitor,, lunitor_natural a b. *) (* -----------------------------------------------------------------------------------*) (** Right unitor *) (* -----------------------------------------------------------------------------------*) Lemma runitor_natural (a b : C) (f g : C ⟦ a, b ⟧) (x : f ==> g) : x ⋆ id2 (identity b) • runitor g = runitor f • x. Proof. rewrite hcomp_hcomp'. unfold hcomp'. rewrite <- vassocr. rewrite vcomp_runitor. rewrite vassocr. apply maponpaths_2. rewrite lwhisker_id2. apply id2_left. Qed. (* Definition runitor_transf (a b : C) : bindelta_pair_functor (functor_identity (hom_precategory a b)) (constant_functor (hom_precategory a b) (hom_precategory b b) (identity b)) ∙ hcomp_functor ⟹ functor_identity (hom_precategory a b). Proof. exists runitor. red. apply runitor_natural. Defined. *) (* -----------------------------------------------------------------------------------*) (** Left associator. *) (* -----------------------------------------------------------------------------------*) Definition lassociator_fun {a b c d : C} (x : C⟦a,b⟧ × C⟦b,c⟧ × C⟦c,d⟧) : pr1 x · (pr12 x · pr22 x) ==> (pr1 x · pr12 x) · pr22 x := lassociator (pr1 x) (pr12 x) (pr22 x). (* Lemma lassociator_fun_natural {a b c d : C} : is_nat_trans (pair_functor (functor_identity (hom_precategory a b)) hcomp_functor ∙ hcomp_functor) (precategory_binproduct_assoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) lassociator_fun. Proof. red; cbn. intros (f1, (f2, f3)) (g1, (g2, g3)). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros (x1, (x2, x3)). cbn. unfold lassociator_fun. cbn. apply hcomp_lassoc. Qed. Definition lassociator_transf (a b c d : C) : pair_functor (functor_identity (hom_precategory a b)) hcomp_functor ∙ hcomp_functor ⟹ precategory_binproduct_assoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor := lassociator_fun,, lassociator_fun_natural. *) (* -----------------------------------------------------------------------------------*) (** Right associator. *) (* -----------------------------------------------------------------------------------*) Definition rassociator_fun {a b c d : C} (x : C⟦a,b⟧ × C⟦b,c⟧ × C⟦c,d⟧) : (pr1 x · pr12 x) · pr22 x ==> pr1 x · (pr12 x · pr22 x) := rassociator (pr1 x) (pr12 x) (pr22 x). (* Lemma rassociator_fun_natural {a b c d : C} : is_nat_trans (precategory_binproduct_assoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) (pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor) rassociator_fun. Proof. red; cbn. intros (f1, (f2, f3)) (g1, (g2, g3)). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros (x1, (x2, x3)). cbn. unfold rassociator_fun. cbn. apply hcomp_rassoc. Qed. Definition rassociator_transf (a b c d : C) : precategory_binproduct_assoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor ⟹ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor := rassociator_fun,, rassociator_fun_natural. *) Definition rassociator_fun' {a b c d : C} (x : (C⟦a,b⟧ × C⟦b,c⟧) × C⟦c,d⟧) : (pr11 x · pr21 x) · pr2 x ==> pr11 x · (pr21 x · pr2 x) := rassociator (pr11 x) (pr21 x) (pr2 x). (* Lemma rassociator_fun'_natural {a b c d : C} : is_nat_trans (pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) (precategory_binproduct_unassoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor) rassociator_fun'. Proof. red; cbn. intros ((f1, f2), f3) ((g1, g2), g3). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros ((x1, x2), x3). cbn. unfold rassociator_fun. cbn. apply hcomp_rassoc. Qed. Definition rassociator_transf' (a b c d : C) : pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor ⟹ precategory_binproduct_unassoc (hom_precategory a b) (hom_precategory b c) (hom_precategory c d) ∙ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor := rassociator_fun',, rassociator_fun'_natural. *) End Associators_Unitors_Natural. Section Associators_Unitors_Natural_bicat. Context {C : bicat}. Definition lunitor_transf (a b : C) : bindelta_pair_functor (constant_functor (hom a b) (hom a a) (identity a)) (functor_identity (hom a b)) ∙ hcomp_functor ⟹ functor_identity (hom a b) := lunitor,, lunitor_natural a b. Definition runitor_transf (a b : C) : bindelta_pair_functor (functor_identity (hom a b)) (constant_functor (hom a b) (hom b b) (identity b)) ∙ hcomp_functor ⟹ functor_identity (hom a b). Proof. exists runitor. red. apply runitor_natural. Defined. Lemma lassociator_fun_natural {a b c d : C} : is_nat_trans (pair_functor (functor_identity (hom a b)) hcomp_functor ∙ hcomp_functor) (precategory_binproduct_assoc (hom a b) (hom b c) (hom c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) lassociator_fun. Proof. red; cbn. intros (f1, (f2, f3)) (g1, (g2, g3)). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros (x1, (x2, x3)). cbn. unfold lassociator_fun. cbn. apply hcomp_lassoc. Qed. Definition lassociator_transf (a b c d : C) : pair_functor (functor_identity (hom a b)) hcomp_functor ∙ hcomp_functor ⟹ precategory_binproduct_assoc (hom a b) (hom b c) (hom c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor := lassociator_fun,, lassociator_fun_natural. Lemma rassociator_fun_natural {a b c d : C} : is_nat_trans (precategory_binproduct_assoc (hom a b) (hom b c) (hom c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) (pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor) rassociator_fun. Proof. red; cbn. intros (f1, (f2, f3)) (g1, (g2, g3)). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros (x1, (x2, x3)). cbn. unfold rassociator_fun. cbn. apply hcomp_rassoc. Qed. Definition rassociator_transf (a b c d : C) : precategory_binproduct_assoc (hom a b) (hom b c) (hom c d) ∙ pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor ⟹ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor := rassociator_fun,, rassociator_fun_natural. Lemma rassociator_fun'_natural {a b c d : C} : is_nat_trans (pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor) (precategory_binproduct_unassoc (hom a b) (hom b c) (hom c d) ∙ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor) rassociator_fun'. Proof. red; cbn. intros ((f1, f2), f3) ((g1, g2), g3). unfold precategory_binproduct_mor, hom_ob_mor. cbn. unfold precategory_binproduct_mor, hom_ob_mor. cbn. intros ((x1, x2), x3). cbn. unfold rassociator_fun. cbn. apply hcomp_rassoc. Qed. Definition rassociator_transf' (a b c d : C) : pair_functor hcomp_functor (functor_identity _) ∙ hcomp_functor ⟹ precategory_binproduct_unassoc (hom a b) (hom b c) (hom c d) ∙ pair_functor (functor_identity _) hcomp_functor ∙ hcomp_functor := rassociator_fun',, rassociator_fun'_natural. End Associators_Unitors_Natural_bicat. (* -----------------------------------------------------------------------------------*) (** ** Precomposition functor *) (* -----------------------------------------------------------------------------------*) Definition pre_comp_data {B : bicat} (z : B) {a b : B} (f : a --> b) : functor_data (hom b z) (hom a z). Proof. use make_functor_data. - exact (λ g, f · g). - exact (λ g₁ g₂ α, f ◃ α). Defined. Definition pre_comp_is_functor {B : bicat} (z : B) {a b : B} (f : a --> b) : is_functor (pre_comp_data z f). Proof. split. - intro ; cbn. apply lwhisker_id2. - intro ; intros ; cbn. refine (!_). apply lwhisker_vcomp. Qed. Definition pre_comp {B : bicat} (z : B) {a b : B} (f : a --> b) : hom b z ⟶ hom a z. Proof. use make_functor. - exact (pre_comp_data z f). - exact (pre_comp_is_functor z f). Defined. (* -----------------------------------------------------------------------------------*) (** ** Postcomposition functor *) (* -----------------------------------------------------------------------------------*) Definition post_comp_data {B : bicat} (z : B) {a b : B} (f : a --> b) : functor_data (hom z a) (hom z b). Proof. use make_functor_data. - exact (λ g, g · f). - exact (λ g₁ g₂ α, α ▹ f). Defined. Definition post_comp_is_functor {B : bicat} (z : B) {a b : B} (f : a --> b) : is_functor (post_comp_data z f). Proof. split. - intro ; cbn. apply id2_rwhisker. - intro ; intros ; cbn. refine (!_). apply rwhisker_vcomp. Qed. Definition post_comp {B : bicat} (z : B) {a b : B} (f : a --> b) : hom z a ⟶ hom z b. Proof. use make_functor. - exact (post_comp_data z f). - exact (post_comp_is_functor z f). Defined. (* -----------------------------------------------------------------------------------*) (** ** Notations. *) (* -----------------------------------------------------------------------------------*) Module Notations. Notation "f '==>' g" := (prebicat_cells _ f g) (at level 60). Notation "f '<==' g" := (prebicat_cells _ g f) (at level 60, only parsing). Notation "x • y" := (vcomp2 x y) (at level 60). Notation "f ◃ x" := (lwhisker f x) (at level 60). (* \tw *) Notation "y ▹ g" := (rwhisker g y) (at level 60). (* \tw nr 2 *) Notation "f ◅ x" := (rwhisker f x) (at level 60, only parsing). (* \tw nr 5*) Notation "y ▻ g" := (lwhisker g y) (at level 60, only parsing). (* \tw nr 6 *) Notation "x ⋆ y" := (hcomp x y) (at level 50, left associativity). Notation "x 'o' y" := (y • x) (at level 67, only parsing, left associativity). Notation "'id₁'" := identity. Notation "'id₂'" := id2. Notation " b ⋆⋆ a" := (a ⋆ b) (at level 30). Open Scope bicategory_scope. End Notations. UniMath-20231010/UniMath/Bicategories/Core/BicategoryLaws.v000066400000000000000000000342001451125700300232510ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Local Open Scope cat. Section laws. Context {C : bicat}. Lemma triangle_r {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : lunitor g ⋆⋆ id₂ f = (id₂ g ⋆⋆ runitor f) o lassociator f (id₁ Y) g. Proof. cbn. apply pathsinv0. unfold hcomp. etrans. { apply maponpaths. etrans. { apply maponpaths. apply lwhisker_id2. } apply id2_right. } etrans. { apply runitor_rwhisker. } apply pathsinv0. etrans. { apply maponpaths_2. apply id2_rwhisker. } apply id2_left. Qed. Lemma interchange {X Y Z : C} {f₁ g₁ h₁ : C⟦Y,Z⟧} {f₂ g₂ h₂ : C⟦X,Y⟧} (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂) (ε₁ : g₁ ==> h₁) (ε₂ : g₂ ==> h₂) : (ε₁ o η₁) ⋆⋆ (ε₂ o η₂) = (ε₁ ⋆⋆ ε₂) o (η₁ ⋆⋆ η₂). Proof. apply hcomp_vcomp. Qed. Lemma rinvunitor_natural {X Y : C} {f g : C⟦X, Y⟧} (η : f ==> g) : rinvunitor g o η = (id₂ (id₁ Y) ⋆⋆ η) o rinvunitor f. Proof. use (vcomp_rcancel (runitor _ )). { apply is_invertible_2cell_runitor. } rewrite vassocl. rewrite rinvunitor_runitor. use (vcomp_lcancel (runitor _ )). { apply is_invertible_2cell_runitor. } repeat rewrite vassocr. rewrite runitor_rinvunitor. rewrite id2_left, id2_right. apply (! runitor_natural _ _ _ _ _ ). Qed. Lemma linvunitor_natural {X Y : C} {f g : C⟦X, Y⟧} (η : f ==> g) : linvunitor g o η = (η ⋆⋆ id₂ (id₁ X)) o linvunitor f. Proof. use (vcomp_rcancel (lunitor _ )). { apply is_invertible_2cell_lunitor. } rewrite vassocl. rewrite linvunitor_lunitor. use (vcomp_lcancel (lunitor _ )). { apply is_invertible_2cell_lunitor. } repeat rewrite vassocr. rewrite lunitor_linvunitor. rewrite id2_left, id2_right. apply (! lunitor_natural _ _ _ _ _ ). Qed. Lemma lwhisker_hcomp {X Y Z : C} {f g : C⟦Y,Z⟧} (h : C⟦X, Y⟧) (α : f ==> g) : h ◃ α = id₂ h ⋆ α. Proof. apply pathsinv0. apply hcomp_identity_left. Qed. Lemma rwhisker_hcomp {X Y Z : C} {f g : C⟦X,Y⟧} (h : C⟦Y,Z⟧) (α : f ==> g) : α ▹ h = α ⋆ id₂ h. Proof. apply pathsinv0. apply hcomp_identity_right. Qed. Lemma inverse_pentagon {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : rassociator f g (k ∘ h) o rassociator (g ∘ f) h k = (id₂ f ⋆ rassociator g h k) o (rassociator f (h ∘ g) k) o (rassociator f g h ⋆ id₂ k). Proof. use inv_cell_eq. - is_iso. - is_iso. - cbn. rewrite <- !vassocr. apply pentagon. Qed. Lemma inverse_pentagon_2 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : rassociator (g ∘ f) h k o (lassociator f g h ⋆ id2 k) = lassociator f g (k ∘ h) o (f ◃ rassociator g h k) o rassociator f (h ∘ g) k. Proof. rewrite <- !inverse_of_assoc. use vcomp_move_R_Mp. { is_iso. } rewrite <- vassocr. use vcomp_move_L_pM. { is_iso. } rewrite <- vassocr. use vcomp_move_L_pM. { is_iso. } symmetry. pose (pentagon k h g f) as p. unfold hcomp in p. rewrite id2_rwhisker in p. rewrite id2_left in p. exact p. Qed. Lemma inverse_pentagon_3 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : rassociator f g (k ∘ h) o rassociator (g ∘ f) h k o (id₂ k ⋆⋆ lassociator f g h) = rassociator g h k ⋆⋆ id₂ f o rassociator f (h ∘ g) k. Proof. use vcomp_move_R_pM. { is_iso. } cbn. apply inverse_pentagon. Qed. Lemma inverse_pentagon_4 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : (lassociator g h k ⋆⋆ id₂ f) o rassociator f g (k ∘ h) = rassociator f (h ∘ g) k o id₂ k ⋆⋆ rassociator f g h o lassociator (g ∘ f) h k. Proof. rewrite <- !inverse_of_assoc. use vcomp_move_R_pM. { is_iso. } rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } use vcomp_move_L_Mp. { is_iso. } rewrite <- !vassocr. symmetry ; apply pentagon. Qed. Lemma inverse_pentagon_5 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : lassociator f g (k ∘ h) o (rassociator g h k ⋆⋆ id₂ f) = rassociator (g ∘ f) h k o (id₂ k ⋆⋆ lassociator f g h) o lassociator f (h ∘ g) k. Proof. rewrite <- !inverse_of_assoc. use vcomp_move_R_pM. { is_iso. } rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } rewrite <- !vassocr. apply pentagon. Qed. Lemma inverse_pentagon_6 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : rassociator f (h ∘ g) k o id₂ k ⋆⋆ rassociator f g h = lassociator g h k ⋆⋆ id₂ f o rassociator f g (k ∘ h) o rassociator (g ∘ f) h k. Proof. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. symmetry. rewrite <- !vassocr. apply inverse_pentagon. Qed. Lemma pentagon_2 {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : lassociator f (h ∘ g) k o lassociator g h k ⋆⋆ id₂ f = id₂ k ⋆⋆ rassociator f g h o lassociator (g ∘ f) h k o lassociator f g (k ∘ h). Proof. rewrite <- !inverse_of_assoc. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } rewrite <- !vassocr. symmetry ; apply pentagon. Qed. Lemma triangle_r_inv {X Y Z : C} (g : C ⟦ Y, Z ⟧) (f : C ⟦ X, Y ⟧) : linvunitor g ⋆⋆ id₂ f = rassociator _ _ _ o id₂ g ⋆⋆ rinvunitor f. Proof. use inv_cell_eq. - is_iso. - is_iso. - cbn. apply triangle_r. Qed. Lemma triangle_l {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : lunitor g ⋆⋆ id₂ f o rassociator _ _ _ = id₂ g ⋆⋆ runitor f. Proof. rewrite triangle_r. rewrite vassocr. rewrite <- inverse_of_assoc. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. Lemma whisker_l_hcomp {W X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,Z⟧} (k₁ k₂ : C⟦W,X⟧) (α : k₁ ==> k₂) : lassociator _ _ _ o (g ∘ f ◅ α) = g ◅ (f ◅ α) o lassociator _ _ _. Proof. symmetry. apply rwhisker_rwhisker. Qed. Lemma whisker_r_hcomp {W X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,Z⟧} (k₁ k₂ : C⟦Z,W⟧) (α : k₁ ==> k₂) : rassociator _ _ _ o (α ▻ g ∘ f) = (α ▻ g) ▻ f o rassociator _ _ _. Proof. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite <- vassocr. use vcomp_move_L_pM. { is_iso. } cbn. symmetry. apply @lwhisker_lwhisker. Qed. Lemma whisker_l_natural {X Y : C} {f : C⟦X,X⟧} (η : id₁ X ==> f) (k₁ k₂ : C⟦X,Y⟧) (α : k₁ ==> k₂) : k₂ ◅ η o linvunitor k₂ o α = α ▻ f o (k₁ ◅ η) o linvunitor k₁. Proof. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite !vassocr. rewrite linvunitor_natural. rewrite <- !vassocr. apply maponpaths. rewrite rwhisker_hcomp. rewrite <- !interchange. rewrite !id2_right, !id2_left. apply idpath. Qed. Lemma whisker_r_natural {X Y : C} {f : C⟦X,X⟧} (η : id₁ X ==> f) (k₁ k₂ : C⟦Y,X⟧) (α : k₁ ==> k₂) : η ▻ k₂ o rinvunitor k₂ o α = (f ◅ α) o (η ▻ k₁) o rinvunitor k₁. Proof. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- !vassocr. apply maponpaths. rewrite lwhisker_hcomp. rewrite <- !interchange. rewrite !id2_right, !id2_left. apply idpath. Qed. Lemma whisker_l_iso_id₁ {X Y : C} {f : C⟦X,X⟧} (η : id₁ X ==> f) (k₁ k₂ : C⟦Y,X⟧) (α : k₁ ==> k₂) (inv_η : is_invertible_2cell η) : α = runitor k₂ o (inv_η^-1 ▻ k₂) o (f ◅ α) o (η ▻ k₁) o rinvunitor k₁. Proof. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } use vcomp_move_L_Mp. { is_iso. } rewrite <- !vassocr. exact (whisker_r_natural η k₁ k₂ α). Qed. Lemma whisker_r_iso_id₁ {X Y : C} {f : C⟦X,X⟧} (η : id₁ X ==> f) (k₁ k₂ : C⟦X,Y⟧) (α : k₁ ==> k₂) (inv_η : is_invertible_2cell η) : α = lunitor k₂ o (k₂ ◅ inv_η^-1) o (α ▻ f) o (k₁ ◅ η) o linvunitor k₁. Proof. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } use vcomp_move_L_Mp. { is_iso. } rewrite <- !vassocr. exact (whisker_l_natural η k₁ k₂ α). Qed. Lemma whisker_l_eq {W X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,Z⟧} (k₁ k₂ : C⟦W,X⟧) (α β : k₁ ==> k₂) : f ◅ α = f ◅ β -> (g ∘ f) ◅ α = (g ∘ f) ◅ β. Proof. intros Hαβ. rewrite !rwhisker_hcomp. rewrite !rwhisker_hcomp in Hαβ. rewrite <- !hcomp_identity. apply (vcomp_rcancel (lassociator _ _ _)). { is_iso. } rewrite !hcomp_lassoc. rewrite Hαβ. apply idpath. Qed. Lemma whisker_r_eq {W X Y Z : C} {f : C⟦Y,Z⟧} {g : C⟦X,Y⟧} (k₁ k₂ : C⟦Z,W⟧) (α β : k₁ ==> k₂) : α ▻ f = β ▻ f -> α ▻ (f ∘ g) = β ▻ (f ∘ g). Proof. intros Hαβ. rewrite !lwhisker_hcomp. rewrite !lwhisker_hcomp in Hαβ. rewrite <- !hcomp_identity. apply (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- !hcomp_lassoc. rewrite Hαβ. apply idpath. Qed. Lemma left_unit_assoc {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : (runitor g) ▻ f = runitor (g ∘ f) o lassociator f g (id₁ Z). Proof. rewrite <- runitor_triangle. unfold assoc. rewrite vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Lemma left_unit_inv_assoc {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : (rinvunitor g) ▻ f = rassociator _ _ _ o rinvunitor (g ∘ f). Proof. rewrite <- rinvunitor_triangle. rewrite <- vassocr. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. Qed. Lemma lunitor_assoc {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : lunitor (g ∘ f) = g ◅ (lunitor f) o lassociator (id₁ X) f g. Proof. symmetry. apply lunitor_triangle. Qed. Lemma linvunitor_assoc {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : linvunitor (g ∘ f) = rassociator (id₁ X) f g o (g ◅ (linvunitor f)). Proof. use vcomp_move_L_pM. { is_iso. } cbn. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite <- lunitor_triangle. rewrite vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. Qed. Lemma lunitor_id_is_left_unit_id (X : C) : lunitor (id₁ X) = runitor (id₁ X). Proof. apply lunitor_runitor_identity. Qed. Lemma lunitor_V_id_is_left_unit_V_id (X : C) : linvunitor (id₁ X) = rinvunitor (id₁ X). Proof. use inv_cell_eq. - is_iso. - is_iso. - cbn. apply lunitor_runitor_identity. Qed. Lemma left_unit_inv_assoc₂ {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : rinvunitor (g ∘ f) = lassociator f g (id₁ Z) o (rinvunitor g ▻ f). Proof. rewrite left_unit_inv_assoc. rewrite <- !vassocr. rewrite rassociator_lassociator. rewrite id2_right. apply idpath. Qed. Lemma triangle_l_inv {X Y Z : C} (g : C⟦Y,Z⟧) (f : C⟦X,Y⟧) : lassociator f (id₁ Y) g o linvunitor g ⋆⋆ id₂ f = id₂ g ⋆⋆ rinvunitor f. Proof. use inv_cell_eq. - is_iso. - is_iso. - cbn. apply triangle_l. Qed. End laws. Lemma inverse_pentagon_7 {B : bicat} {v w x y z : B} (k : y --> z) (h : x --> y) (g : w --> x) (f : v --> w) : lassociator (f · g) h k • (rassociator f g h ▹ k) = rassociator f g (h · k) • (f ◃ lassociator g h k) • lassociator f (g · h) k. Proof. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- lassociator_lassociator. rewrite !vassocl. apply idpath. Qed. Lemma pentagon_6 {B : bicat} {v w x y z : B} (k : y --> z) (h : x --> y) (g : w --> x) (f : v --> w) : lassociator f (g · h) k • (lassociator f g h ▹ k) = (f ◃ rassociator g h k) • lassociator f g (h · k) • lassociator (f · g) h k. Proof. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite <- lassociator_lassociator. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/Core/Discreteness.v000066400000000000000000000145371451125700300230000ustar00rootroot00000000000000(* ************************************************************************* *) (** Discreteness for Bicategories. *) (* ************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope cat. Definition isaprop_2cells (B : bicat) : UU := ∏ (x y : B) (f g : x --> y) (α β : f ==> g), α = β. Definition is_discrete_bicat (B : bicat) : UU := is_univalent_2_1 B × locally_groupoid B × isaprop_2cells B. (** Category from a discrete bicategory *) Definition discrete_bicat_to_precategory_data {B : bicat} (HB : is_discrete_bicat B) : precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact B. + exact (λ x y, x --> y). - exact (λ x, id₁ x). - exact (λ x y z f g, f · g). Defined. Definition discrete_bicat_is_precategory {B : bicat} (HB : is_discrete_bicat B) : is_precategory (discrete_bicat_to_precategory_data HB). Proof. use make_is_precategory. - intros x y f. use (isotoid_2_1 (pr1 HB)). apply lunitor_invertible_2cell. - intros x y f. use (isotoid_2_1 (pr1 HB)). apply runitor_invertible_2cell. - intros w x y z f g h. use (isotoid_2_1 (pr1 HB)). apply lassociator_invertible_2cell. - intros w x y z f g h. use (isotoid_2_1 (pr1 HB)). apply rassociator_invertible_2cell. Qed. Definition discrete_bicat_to_precategory {B : bicat} (HB : is_discrete_bicat B) : precategory. Proof. use make_precategory. - exact (discrete_bicat_to_precategory_data HB). - exact (discrete_bicat_is_precategory HB). Defined. Definition discrete_bicat_locally_set {B : bicat} (HB : is_discrete_bicat B) (x y : B) : isaset (x --> y). Proof. intros f g. use (isofhlevelweqb _ (make_weq (idtoiso_2_1 f g) (pr1 HB _ _ f g))). use invproofirrelevance. intros α β. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply HB. Qed. Definition discrete_bicat_to_category {B : bicat} (HB : is_discrete_bicat B) : category. Proof. use make_category. - exact (discrete_bicat_to_precategory HB). - exact (discrete_bicat_locally_set HB). Defined. (** Adjoint equivalences in discrete bicategories *) Definition discrete_left_adj_equiv_to_z_iso {B : bicat} (HB : is_discrete_bicat B) {x y : B} {f : x --> y} (Hf : left_adjoint_equivalence f) : @is_z_isomorphism (discrete_bicat_to_category HB) x y f. Proof. exists (left_adjoint_right_adjoint Hf). split. + abstract (use (isotoid_2_1 (pr1 HB)) ; exact (inv_of_invertible_2cell (left_equivalence_unit_iso Hf))). + abstract (use (isotoid_2_1 (pr1 HB)) ; exact (left_equivalence_counit_iso Hf)). Defined. Definition z_iso_to_discrete_left_adj_equiv {B : bicat} (HB : is_discrete_bicat B) {x y : B} {f : x --> y} (Hf : @is_z_isomorphism (discrete_bicat_to_category HB) x y f) : left_adjoint_equivalence f. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (inv_from_z_iso (make_z_iso' _ Hf)). - abstract (apply idtoiso_2_1 ; refine (!_) ; exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf))). - abstract (apply idtoiso_2_1 ; exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf))). - apply HB. - apply HB. - apply HB. - apply HB. Defined. Definition discrete_left_adj_equiv_weq_z_iso {B : bicat} (HB : is_discrete_bicat B) (x y : B) : @z_iso (discrete_bicat_to_category HB) x y ≃ adjoint_equivalence x y. Proof. use make_weq. - exact (λ f, _ ,, z_iso_to_discrete_left_adj_equiv HB (pr2 f)). - use isweq_iso. + exact (λ f, make_z_iso' _ (discrete_left_adj_equiv_to_z_iso HB f)). + abstract (intro Hf ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). + abstract (intro Hf ; use subtypePath ; [ intro ; apply isaprop_left_adjoint_equivalence ; apply HB | ] ; apply idpath). Defined. Definition discrete_bicat_univalent_2_0 {B : bicat} (HB : is_discrete_bicat B) (H : is_univalent (discrete_bicat_to_category HB)) : is_univalent_2_0 B. Proof. intros x y. use weqhomot. - exact (discrete_left_adj_equiv_weq_z_iso HB x y ∘ make_weq _ (H x y))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_left_adjoint_equivalence ; apply HB | ] ; apply idpath). Defined. Definition discrete_bicat_to_category_is_univalent {B : bicat} (HB : is_discrete_bicat B) (H : is_univalent_2_0 B) : is_univalent (discrete_bicat_to_category HB). Proof. intros x y. use weqhomot. - exact (invweq (discrete_left_adj_equiv_weq_z_iso HB x y) ∘ make_weq _ (H x y))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. Definition discrete_bicat_weq_univalence {B : bicat} (HB : is_discrete_bicat B) : is_univalent_2_0 B ≃ is_univalent (discrete_bicat_to_category HB). Proof. use weqimplimpl. - exact (discrete_bicat_to_category_is_univalent HB). - exact (discrete_bicat_univalent_2_0 HB). - apply isaprop_is_univalent_2_0. - apply isaprop_is_univalent. Defined. UniMath-20231010/UniMath/Bicategories/Core/EquivToAdjequiv.v000066400000000000000000000240211451125700300234170ustar00rootroot00000000000000(** Internal equivalences in bicategories can be refined to adjoint equivalences. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope bicategory_scope. Lemma representable_faithful {C : bicat} {X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,X⟧} (η : id₁ X ==> g ∘ f) (k₁ k₂ : C⟦Z,X⟧) (α β : k₁ ==> k₂) (Hη : is_invertible_2cell η) : f ◅ α = f ◅ β -> α = β. Proof. intros Hαβ. rewrite (whisker_l_iso_id₁ η _ _ α Hη). rewrite (whisker_l_iso_id₁ η _ _ β Hη). do 2 apply maponpaths. apply (maponpaths (fun z => _ o z)). apply (whisker_l_eq k₁ k₂ α β Hαβ). Qed. Definition representable_full {C : bicat} {X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,X⟧} (η : id₁ X ==> g ∘ f) (θ : f ∘ g ==> id₁ Y) (Hη : is_invertible_2cell η) (k₁ k₂ : C⟦Z,X⟧) (α : f ∘ k₁ ==> f ∘ k₂) : k₁ ==> k₂. Proof. refine (_ o rinvunitor _). refine (_ o η ▻ _). refine (_ o lassociator _ _ _). refine (_ o g ◅ α). refine (_ o rassociator _ _ _). refine (_ o Hη^-1 ▻ k₂). apply runitor. Defined. Lemma full_spec {C : bicat} {X Y Z : C} {f : C⟦X,Y⟧} {g : C⟦Y,X⟧} (η : id₁ X ==> g ∘ f) (θ : f ∘ g ==> id₁ Y) (Hη : is_invertible_2cell η) (Hθ : is_invertible_2cell θ) (k₁ k₂ : C⟦Z,X⟧) (α : f ∘ k₁ ==> f ∘ k₂) : f ◅ (representable_full η θ Hη k₁ k₂ α) = α. Proof. refine (representable_faithful (Hθ^-1) (f ∘ k₁) (f ∘ k₂) _ α _ _). { is_iso. } apply (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- whisker_l_hcomp. apply (vcomp_rcancel (rassociator _ _ _)). { is_iso. } rewrite <- !vassocr. rewrite lassociator_rassociator, id2_right. apply (vcomp_rcancel (Hη^-1 ▻ k₂)). { is_iso. } apply (vcomp_rcancel (runitor k₂)). { is_iso. } apply (vcomp_lcancel (η ▻ k₁)). { is_iso. } apply (vcomp_lcancel (rinvunitor k₁)). { is_iso. } rewrite <- !vassocr. rewrite <- (whisker_l_iso_id₁ η k₁ k₂ (representable_full η θ Hη k₁ k₂ α) Hη). apply idpath. Qed. Section EquivToAdjEquiv. Context {C : bicat} {X Y : C}. Variable (f : C⟦X,Y⟧) (Hf : left_equivalence f). Local Definition g : C⟦Y,X⟧ := left_adjoint_right_adjoint Hf. Local Definition η : id₁ X ==> g ∘ f := left_adjoint_unit Hf. Local Definition θ : f ∘ g ==> id₁ Y := left_adjoint_counit Hf. Local Definition ηiso := left_equivalence_unit_iso Hf. Local Definition θiso := left_equivalence_counit_iso Hf. Local Definition ε : f ∘ g ==> id₁ Y. Proof. refine (representable_full (θiso^-1) (ηiso^-1) _ (f ∘ g) (id₁ Y) _). { is_iso. } exact ((linvunitor g) o runitor g o ηiso^-1 ▻ g o rassociator _ _ _). Defined. Definition εiso : is_invertible_2cell ε. Proof. unfold ε, representable_full. is_iso. Defined. Definition equiv_to_adjequiv_d : left_adjoint_data f. Proof. refine (g ,, _). split. - exact η. - exact ε. Defined. Local Lemma first_triangle_law : (lunitor g) o g ◅ ε o lassociator g f g o η ▻ g o rinvunitor _ = id₂ g. Proof. rewrite !vassocr. unfold ε. rewrite (full_spec (θiso^-1) (ηiso^-1) _ (is_invertible_2cell_inv _) (f ∘ g) (id₁ Y) _). rewrite <- !vassocr. rewrite linvunitor_lunitor, id2_right. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o (_ o z)) (!(vassocr _ _ _))). rewrite lassociator_rassociator, id2_right. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_right. apply rinvunitor_runitor. Qed. Local Definition whisker_ηg_type : Type. Proof. refine (η ▻ g = inv_cell (η := (lunitor g o g ◅ ε o lassociator g f g)) _ o runitor g). unfold ε, representable_full. is_iso. Defined. Local Lemma whisker_ηg : whisker_ηg_type. Proof. use vcomp_move_L_Mp. { cbn. is_iso. - apply Hf. - apply Hf. } cbn. refine (_ @ id2_right _). use vcomp_move_L_pM. { is_iso. } cbn. apply first_triangle_law. Qed. Local Lemma η_natural : η ▻ (g ∘ f) o rinvunitor (g ∘ f) o η = (g ∘ f) ◅ η o linvunitor (g ∘ f) o η. Proof. rewrite !vassocr. rewrite rinvunitor_natural. rewrite linvunitor_natural. rewrite <- !vassocr. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- !interchange. rewrite !id2_left, !id2_right. apply (maponpaths (fun z => z • _)). apply pathsinv0. apply lunitor_V_id_is_left_unit_V_id. Qed. Local Definition η_natural_help : η ▻ (g ∘ f) o rinvunitor (g ∘ f) = (g ∘ f) ◅ η o linvunitor (g ∘ f) := vcomp_lcancel η ηiso η_natural. Local Lemma η_whisker_l_hcomp : (g ∘ f) ◅ η = rassociator (g ∘ f) f g o g ◅ (f ◅ η) o lassociator (id₁ X) f g. Proof. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. apply pathsinv0. apply rwhisker_rwhisker. Qed. Local Lemma η_whisker_r_hcomp : η ▻ (g ∘ f) = lassociator f g(g ∘ f) o η ▻ g ▻ f o rassociator f g (id₁ X). Proof. use vcomp_move_L_pM. { is_iso. } cbn. apply pathsinv0. apply lwhisker_lwhisker. Qed. Local Lemma help1 : lassociator f g (g ∘ f) o (η ▻ g o rinvunitor _) ▻ f = (rassociator (g ∘ f) f g) o g ◅ (f ◅ η) o lassociator (id₁ X) f g o linvunitor (g ∘ f). Proof. rewrite <- η_whisker_l_hcomp. rewrite <- lwhisker_vcomp. rewrite left_unit_inv_assoc. rewrite <- !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocr. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite rassociator_lassociator, id2_right. exact η_natural_help. Qed. Local Lemma help2 : g ◅ (lassociator f g f o εiso^-1 ▻ f o rinvunitor _) = g ◅ (f ◅ η o linvunitor f). Proof. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). unfold assoc. rewrite <- !lwhisker_hcomp. rewrite <- rwhisker_lwhisker. pose help1 as p. rewrite whisker_ηg in p. cbn in p. rewrite !vassocr in p. rewrite rinvunitor_runitor, id2_left in p. rewrite <- !lwhisker_vcomp in p. rewrite linvunitor_assoc in p. rewrite <- !vassocr in p. rewrite !vassocr in p. rewrite !(maponpaths (fun z => _ o (_ o z)) (!(vassocr _ _ _))) in p. rewrite rassociator_lassociator, id2_right in p. rewrite rwhisker_vcomp in p. rewrite <- !vassocr in p. pose @inverse_pentagon_5 as q. rewrite !lwhisker_hcomp in p. rewrite q in p ; clear q. rewrite !vassocr in p. use vcomp_rcancel. 2: exact (rassociator (f · g) f g). { is_iso. } rewrite rwhisker_vcomp. refine (_ @ p) ; clear p. cbn. rewrite !vassocr, !lwhisker_hcomp, !rwhisker_hcomp. apply idpath. Qed. Local Lemma help3 : lassociator f g f o εiso^-1 ▻ f o rinvunitor f = f ◅ η o linvunitor f. Proof. use (representable_faithful _ _ _ _ _ _ help2). - exact f. - exact (εiso^-1). - is_iso. Qed. Lemma equiv_to_adjequiv_isadj : left_adjoint_axioms equiv_to_adjequiv_d. Proof. split ; cbn. - refine (maponpaths (fun z => ((z • _) • _) • _) (!help3) @ _). rewrite !vassocr. rewrite !(maponpaths (fun z => _ o (_ o z)) (!(vassocr _ _ _))). rewrite lassociator_rassociator, id2_right. rewrite !(maponpaths (fun z => _ o z) (!(vassocr _ _ _))). rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_right. rewrite rinvunitor_runitor. reflexivity. - rewrite <- !vassocr. exact first_triangle_law. Qed. Definition equiv_to_isadjequiv : left_adjoint_equivalence f. Proof. use tpair. - exact equiv_to_adjequiv_d. - cbn. split. + exact equiv_to_adjequiv_isadj. + split. * exact ηiso. * exact εiso. Defined. Definition equiv_to_adjequiv : adjoint_equivalence X Y := (f ,, equiv_to_isadjequiv). End EquivToAdjEquiv. Definition inv_equiv {C : bicat} {X Y : C} {f : X --> Y} (Hf : left_equivalence f) : left_equivalence (pr11 Hf). Proof. use tpair. - use tpair. + exact f. + split. * exact ((left_equivalence_counit_iso Hf)^-1). * exact ((left_equivalence_unit_iso Hf)^-1). - split ; cbn ; is_iso. Defined. Definition inv_left_adjoint_equivalence {B : bicat} {x y : B} {f : x --> y} (Hf : left_adjoint_equivalence f) : left_adjoint_equivalence (left_adjoint_right_adjoint Hf). Proof. use equiv_to_adjequiv. exact (inv_equiv (left_equivalence_of_left_adjoint_equivalence Hf)). Defined. Definition inv_adjequiv {C : bicat} {X Y : C} : adjoint_equivalence X Y → adjoint_equivalence Y X. Proof. intro f. use equiv_to_adjequiv. - exact (left_adjoint_right_adjoint f). - exact (inv_equiv (left_equivalence_of_left_adjoint_equivalence f)). Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/000077500000000000000000000000001451125700300217225ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Core/Examples/BicatOfCats.v000066400000000000000000000215641451125700300242430ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategory of 1-categories Benedikt Ahrens, Marco Maggesi February 2018 a variant by Ralph Matthes in 2021 without asking for univalence of the object ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Local Open Scope cat. Definition cat_prebicat_nouniv_data : prebicat_data. Proof. use build_prebicat_data. - exact category. - exact (λ C D, functor C D). - exact (λ _ _ F G, nat_trans F G). - exact (λ C, functor_identity C). - exact (λ _ _ _ F G, functor_composite F G). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ α β, nat_trans_comp _ _ _ α β). - exact (λ _ _ _ F _ _ α, pre_whisker F α). - exact (λ _ _ _ _ _ H α, post_whisker α H). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). Defined. Lemma cat_prebicat_nouniv_laws : prebicat_laws cat_prebicat_nouniv_data. Proof. split21; cbn. - intros C D F G η. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F G η. apply nat_trans_eq; try apply D. intros ; cbn. apply id_right. - intros C D F₁ F₂ F₃ F₄ α β γ. apply nat_trans_eq; try apply D. intros ; cbn. apply assoc. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intro; apply idpath. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intros ; cbn. apply functor_id. - intros C₁ C₂ C₃ F G₁ G₂ G₃ α β. apply nat_trans_eq; try apply C₃. intro; apply idpath. - intros C₁ C₂ C₃ F₁ F₂ F₃ G α β. apply nat_trans_eq; try apply C₃. intros ; cbn. exact (!(functor_comp G _ _)). - intros C D F G α. apply nat_trans_eq; try apply D. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C D F G α. apply nat_trans_eq; try apply D. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G H₁ H₂ α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G₁ G₂ H α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F₁ F₂ G H α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ F₁ F₂ G₁ H₂ α β. apply nat_trans_eq; try apply C₃. intros ; cbn. exact ((nat_trans_ax β _ _ _)). - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply C₄. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply C₄. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intros ; cbn. exact (id_left _ @ functor_id G _). - intros C₁ C₂ C₃ C₄ C₅ F₁ F₂ F₃ F₄. apply nat_trans_eq; try apply C₅. intros ; cbn. rewrite !id_left. exact (functor_id F₄ _). Qed. Definition prebicat_of_cats : prebicat := _ ,, cat_prebicat_nouniv_laws. Lemma isaset_cells_prebicat_of_cats : isaset_cells prebicat_of_cats. Proof. intros a b f g. apply isaset_nat_trans. apply homset_property. Defined. Definition bicat_of_cats : bicat := (prebicat_of_cats ,, isaset_cells_prebicat_of_cats). Definition is_invertible_2cell_to_is_nat_z_iso {C D : bicat_of_cats} {F G : C --> D} (η : F ==> G) : is_invertible_2cell η → is_nat_z_iso (pr1 η). Proof. intros Hη X. use tpair. - apply (Hη^-1). - abstract (split ; cbn ; [ exact (nat_trans_eq_pointwise (vcomp_rinv Hη) X) | exact (nat_trans_eq_pointwise (vcomp_linv Hη) X)]). Defined. Definition invertible_2cell_to_nat_z_iso {C D : bicat_of_cats} (F G : C --> D) : invertible_2cell F G → nat_z_iso F G. Proof. intros η. use make_nat_z_iso. - exact (cell_from_invertible_2cell η). - apply is_invertible_2cell_to_is_nat_z_iso. apply η. Defined. Definition is_nat_z_iso_to_is_invertible_2cell {C D : bicat_of_cats} {F G : C --> D} (η : F ==> G) : is_nat_z_iso (pr1 η) → is_invertible_2cell η. Proof. intros Hη. use tpair. - apply (nat_z_iso_inv (η ,, Hη)). - abstract (split ; [ apply nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; exact (z_iso_inv_after_z_iso (pr1 η x ,, _)) | apply nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; exact (z_iso_after_z_iso_inv (pr1 η x ,, _)) ]). Defined. Definition nat_z_iso_to_invertible_2cell {C D : bicat_of_cats} (F G : C --> D) : nat_z_iso F G → invertible_2cell F G. Proof. intros η. use tpair. - apply η. - apply is_nat_z_iso_to_is_invertible_2cell. apply η. Defined. Definition invertible_2cell_is_nat_z_iso {C D : bicat_of_cats} (F G : C --> D) : nat_z_iso F G ≃ invertible_2cell F G. Proof. use make_weq. - exact (nat_z_iso_to_invertible_2cell F G). - use isweq_iso. + exact (invertible_2cell_to_nat_z_iso F G). + intros x. use subtypePath. * intro. apply isaprop_is_nat_z_iso. * apply idpath. + intros x. use subtypePath. * intro. apply isaprop_is_invertible_2cell. * apply idpath. Defined. Local Definition CAT : bicat := bicat_of_cats. Local Definition lwhisker := @lwhisker CAT. Local Lemma pre_whisker_as_lwhisker (A B C: category) (F: A ⟶ B)(G H: B ⟶ C)(γ: G ⟹ H): pre_whisker F γ = lwhisker A B C F G H γ. Proof. apply idpath. Qed. Local Definition rwhisker := @rwhisker CAT. Local Lemma post_whisker_as_rwhisker (B C D: category) (G H: B ⟶ C) (γ: G ⟹ H) (K: C ⟶ D): post_whisker γ K = rwhisker B C D G H K γ. Proof. apply idpath. Qed. Local Definition hcomp := @hcomp CAT. Local Definition hcomp' := @hcomp' CAT. (** demonstrates the mismatch: [horcomp] only corresponds to [hcomp'] *) Local Lemma horcomp_as_hcomp'_pointwise (C D E : category) (F F' : C ⟶ D) (G G' : D ⟶ E) (α : F ⟹ F') (β: G ⟹ G'): horcomp α β = hcomp' C D E F F' G G' α β. Proof. apply (nat_trans_eq (homset_property E)). intro c. apply idpath. Qed. Local Definition hcomp_functor_data := @hcomp_functor_data CAT. Local Definition hcomp_functor := @hcomp_functor CAT. (** no more mismatch when using [functorial_composition] *) Local Lemma functorial_composition_as_hcomp_functor (A B C : category): functorial_composition_data A B C = hcomp_functor_data A B C. Proof. apply idpath. Qed. (** as a corollary: *) Local Lemma functorial_composition_as_hcomp_functor_datawise (A B C : category): functorial_composition A B C = hcomp_functor A B C. Proof. use functor_eq. - apply functor_category_has_homsets. - apply functorial_composition_as_hcomp_functor. Qed. Local Definition hcomp_vcomp := @hcomp_vcomp CAT. (** here, we obtain the result by inheriting from the abstract bicategorical development *) Lemma interchange_functorial_composition (A B C: category) (F1 G1 H1: A ⟶ B) (F2 G2 H2: B ⟶ C) (α1 : F1 ⟹ G1) (α2: F2 ⟹ G2) (β1: G1 ⟹ H1) (β2: G2 ⟹ H2): # (functorial_composition A B C) (catbinprodmor ((α1:(functor_category A B)⟦F1,G1⟧) · β1) ((α2:(functor_category B C)⟦F2,G2⟧) · β2)) = # (functorial_composition A B C) (catbinprodmor(C:=functor_category A B)(D:=functor_category B C) α1 α2) · # (functorial_composition A B C) (catbinprodmor(C:=functor_category A B)(D:=functor_category B C) β1 β2). Proof. exact (hcomp_vcomp A B C F1 G1 H1 F2 G2 H2 α1 α2 β1 β2). Qed. UniMath-20231010/UniMath/Bicategories/Core/Examples/BicatOfUnivCats.v000066400000000000000000000571021451125700300251020ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategory of 1-categories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.CategoryEquality. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Definition cat_prebicat_data : prebicat_data. Proof. use build_prebicat_data. - exact univalent_category. - exact (λ C D, functor C D). - exact (λ _ _ F G, nat_trans F G). - exact (λ C, functor_identity C). - exact (λ _ _ _ F G, functor_composite F G). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ α β, nat_trans_comp _ _ _ α β). - exact (λ _ _ _ F _ _ α, pre_whisker F α). - exact (λ _ _ _ _ _ H α, post_whisker α H). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). Defined. Lemma cat_prebicat_laws : prebicat_laws cat_prebicat_data. Proof. repeat split; cbn. - intros C D F G η. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C D F G η. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_right. - intros C D F₁ F₂ F₃ F₄ α β γ. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply assoc. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply homset_property. intro; apply idpath. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply functor_id. - intros C₁ C₂ C₃ F G₁ G₂ G₃ α β. apply nat_trans_eq; try apply homset_property. intros; apply idpath. - intros C₁ C₂ C₃ F₁ F₂ F₃ G α β. apply nat_trans_eq; try apply homset_property. intros ; cbn. exact (!(functor_comp G _ _)). - intros C D F G α. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C D F G α. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G H₁ H₂ α. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G₁ G₂ H α. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F₁ F₂ G H α. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ F₁ F₂ G₁ H₂ α β. apply nat_trans_eq; try apply homset_property. intros ; cbn. exact ((nat_trans_ax β _ _ _)). - intros C D F. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply homset_property. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply homset_property. intros ; cbn. exact (id_left _ @ functor_id G _). - intros C₁ C₂ C₃ C₄ C₅ F₁ F₂ F₃ F₄. apply nat_trans_eq; try apply homset_property. intros ; cbn. rewrite !id_left. exact (functor_id F₄ _). Qed. Definition prebicat_of_univ_cats : prebicat := _ ,, cat_prebicat_laws. Lemma isaset_cells_prebicat_of_univ_cats : isaset_cells prebicat_of_univ_cats. Proof. intros a b f g. apply isaset_nat_trans. apply homset_property. Qed. Definition bicat_of_univ_cats : bicat := (prebicat_of_univ_cats,, isaset_cells_prebicat_of_univ_cats). Definition is_invertible_2cell_to_is_nat_z_iso {C D : bicat_of_univ_cats} {F G : C --> D} (η : F ==> G) : is_invertible_2cell η → is_nat_z_iso (pr1 η). Proof. intros Hη X. use tpair. - apply (Hη^-1). - abstract (split ; cbn ; [ exact (nat_trans_eq_pointwise (vcomp_rinv Hη) X) | exact (nat_trans_eq_pointwise (vcomp_linv Hη) X)]). Defined. Definition invertible_2cell_to_nat_z_iso {C D : bicat_of_univ_cats} (F G : C --> D) : invertible_2cell F G → nat_z_iso F G. Proof. intros η. use make_nat_z_iso. - exact (cell_from_invertible_2cell η). - apply is_invertible_2cell_to_is_nat_z_iso. apply η. Defined. Definition is_nat_z_iso_to_is_invertible_2cell {C D : bicat_of_univ_cats} {F G : C --> D} (η : F ==> G) : is_nat_z_iso (pr1 η) → is_invertible_2cell η. Proof. intros Hη. use tpair. - apply (nat_z_iso_inv (η ,, Hη)). - abstract (split ; [ apply nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; exact (z_iso_inv_after_z_iso (pr1 η x ,, _)) | apply nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; exact (z_iso_after_z_iso_inv (pr1 η x ,, _)) ]). Defined. Definition nat_z_iso_to_invertible_2cell {C D : bicat_of_univ_cats} (F G : C --> D) : nat_z_iso F G → invertible_2cell F G. Proof. intros η. use tpair. - apply η. - apply is_nat_z_iso_to_is_invertible_2cell. apply η. Defined. Definition invertible_2cell_is_nat_z_iso {C D : bicat_of_univ_cats} (F G : C --> D) : nat_z_iso F G ≃ invertible_2cell F G. Proof. use make_weq. - exact (nat_z_iso_to_invertible_2cell F G). - use isweq_iso. + exact (invertible_2cell_to_nat_z_iso F G). + intros x. use subtypePath. * intro. apply isaprop_is_nat_z_iso. * apply idpath. + intros x. use subtypePath. * intro. apply isaprop_is_invertible_2cell. * apply idpath. Defined. Definition adj_equiv_to_equiv_cat {C D : bicat_of_univ_cats} (F : C --> D) : left_adjoint_equivalence F → adj_equivalence_of_cats F. Proof. intros A. use make_adj_equivalence_of_cats. - exact (left_adjoint_right_adjoint A). - exact (left_adjoint_unit A). - exact (left_adjoint_counit A). - split. + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle1 A) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle2 A) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). - split. + intro X. apply (invertible_2cell_to_nat_z_iso _ _ (left_equivalence_unit_iso A)). + intro X. apply (invertible_2cell_to_nat_z_iso _ _ (left_equivalence_counit_iso A)). Defined. Definition equiv_cat_to_adj_equiv {C D : bicat_of_univ_cats} (F : C --> D) : adj_equivalence_of_cats F → left_adjoint_equivalence F. Proof. intros A. use tpair. - use tpair. + apply A. + split ; cbn. * exact (pr1 (pr121 A)). * exact (pr2 (pr121 A)). - split ; split. + abstract (apply nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left, !id_right ; apply (pr2(pr2(pr1 A)))). + abstract (apply nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left, !id_right ; apply (pr2(pr2(pr1 A)))). + apply is_nat_z_iso_to_is_invertible_2cell. intro x. apply (pr2 A). + apply is_nat_z_iso_to_is_invertible_2cell. intro x. apply (pr2 A). Defined. Definition adj_equiv_is_equiv_cat {C D : bicat_of_univ_cats} (F : C --> D) : left_adjoint_equivalence F ≃ adj_equivalence_of_cats F. Proof. use make_weq. - exact (adj_equiv_to_equiv_cat F). - use isweq_iso. + exact (equiv_cat_to_adj_equiv F). + intros A. use subtypePath. * intro. do 2 apply isapropdirprod. ** apply cellset_property. ** apply cellset_property. ** apply isaprop_is_invertible_2cell. ** apply isaprop_is_invertible_2cell. * apply idpath. + intros A. use subtypePath. * intro. apply isapropdirprod ; apply impred ; intro ; apply isaprop_is_z_isomorphism. * use total2_paths_b. ** apply idpath. ** use subtypePath. *** intro ; simpl. apply (@isaprop_form_adjunction (pr1 C) (pr1 D)). *** apply idpath. Defined. Definition univalent_cat_idtoiso_2_1 {C D : univalent_category} (F G : bicat_of_univ_cats⟦C,D⟧) : F = G ≃ invertible_2cell F G. Proof. refine ((invertible_2cell_is_nat_z_iso F G) ∘ z_iso_is_nat_z_iso F G ∘ make_weq (@idtoiso (functor_category C D) F G) _)%weq. refine (is_univalent_functor_category C D _ F G). apply D. Defined. Proposition idtoiso_2_1_in_bicat_of_univ_cats {C₁ C₂ : bicat_of_univ_cats} {F G : C₁ --> C₂} (p : F = G) (x : pr1 C₁) : pr11 (@idtoiso_2_1 bicat_of_univ_cats C₁ C₂ F G p) x = idtoiso (maponpaths (λ H, pr11 H x) p). Proof. induction p ; cbn. apply idpath. Qed. Definition univalent_cat_is_univalent_2_1 : is_univalent_2_1 bicat_of_univ_cats. Proof. intros C D f g. use weqhomot. - exact (univalent_cat_idtoiso_2_1 f g). - intros p. induction p. use subtypePath. + intro. apply isaprop_is_invertible_2cell. + apply nat_trans_eq. { apply homset_property. } intros; apply idpath. Defined. Definition path_univalent_cat (C D : bicat_of_univ_cats) : C = D ≃ pr1 C = pr1 D. Proof. apply path_sigma_hprop. simpl. apply isaprop_is_univalent. Defined. Definition path_cat (C D : category) : C = D ≃ pr1 C = pr1 D. Proof. apply path_sigma_hprop. simpl. apply isaprop_has_homsets. Defined. Section CatIso_To_LeftAdjEquiv. Context {C D : univalent_category}. Variable (F : C ⟶ D) (HF : is_catiso F). Local Definition cat_iso_unit : nat_z_iso (functor_identity C) (functor_composite F (inv_catiso (F ,, HF))). Proof. use tpair. - use make_nat_trans. + intros X ; cbn. exact (pr1 (idtoiso (! homotinvweqweq (catiso_ob_weq (F ,, HF)) X))). + intros X Y f ; cbn. use (invmaponpathsweq (#F ,, _)). { apply HF. } cbn. refine (functor_comp _ _ _ @ !_). refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. match goal with [ |- _ (invmap ?FFF ?fff) = _ ] => apply (homotweqinvweq FFF fff) end. } rewrite !assoc. etrans. { refine (maponpaths (λ z, ((z · _) · _) · _) _). apply (!(base_paths _ _ (maponpaths_idtoiso _ _ F _ _ _))). } etrans. { refine (maponpaths (λ z, (z · _) · _) (!_)). apply (base_paths _ _ (idtoiso_concat _ _ _ _ _ _)). } rewrite maponpathsinv0. etrans. { refine (maponpaths (λ z, (pr1 (idtoiso (! z @ _)) · _) · _) _). match goal with [ |- _ (homotinvweqweq ?w _) = _] => apply (homotweqinvweqweq w) end. } rewrite pathsinv0l ; cbn. rewrite id_left. apply maponpaths. etrans. { repeat apply maponpaths. match goal with [ |- (homotweqinvweq ?w _) = _] => apply (! homotweqinvweqweq w Y) end. } rewrite <- maponpathsinv0. apply (base_paths _ _ (maponpaths_idtoiso _ _ F _ _ _)). - intros X. apply (idtoiso (! homotinvweqweq (catiso_ob_weq (F ,, HF)) X)). Defined. Local Definition cat_iso_counit : nat_z_iso (functor_composite (inv_catiso (F ,, HF)) F) (functor_identity (pr1 (pr1 D))). Proof. use tpair. - use make_nat_trans. + intros X ; cbn. exact (pr1 (idtoiso (homotweqinvweq (catiso_ob_weq (F ,, HF)) X))). + intros X Y f ; cbn. etrans. { apply maponpaths_2. match goal with [ |- _ (invmap ?FFF ?fff) = _ ] => apply (homotweqinvweq FFF fff) end. } rewrite <- !assoc. etrans. { refine (maponpaths (λ z, _ · (_ · z)) _). apply (base_paths _ _ (!(idtoiso_concat _ _ _ _ _ _))). } rewrite pathsinv0l ; cbn. rewrite id_right. apply idpath. - intros X. apply (idtoiso (homotweqinvweq (catiso_ob_weq (F ,, HF)) X)). Defined. Definition is_catiso_to_left_adjoint_equivalence : @left_adjoint_equivalence bicat_of_univ_cats _ _ F. Proof. use equiv_to_adjequiv. use tpair. - use tpair. + exact (inv_catiso (F ,, HF)). + split. * apply cat_iso_unit. * apply cat_iso_counit. - split. + use tpair ; try split. * apply (nat_z_iso_inv cat_iso_unit). * apply nat_trans_eq. { apply homset_property. } intro X ; cbn. rewrite idtoiso_inv; cbn. apply z_iso_after_z_iso_inv. * apply nat_trans_eq. { apply homset_property. } intro X ; cbn. rewrite idtoiso_inv; cbn. apply z_iso_inv_after_z_iso. + use tpair ; try split. * apply (nat_z_iso_inv cat_iso_counit). * apply nat_trans_eq. { apply homset_property. } intro X ; cbn. apply z_iso_inv_after_z_iso. * apply nat_trans_eq. { apply homset_property. } intro X ; cbn. apply z_iso_after_z_iso_inv. Qed. End CatIso_To_LeftAdjEquiv. Definition left_adjoint_equivalence_to_is_catiso {C D : bicat_of_univ_cats} (L : (pr1 C) ⟶ (pr1 D)) : @left_adjoint_equivalence bicat_of_univ_cats _ _ L → is_catiso L. Proof. intros HF. pose (R := pr1 (left_adjoint_right_adjoint HF)). pose (η := left_adjoint_unit HF). pose (ηinv := (left_equivalence_unit_iso HF)^-1). pose (ε := left_adjoint_counit HF). pose (εinv := (left_equivalence_counit_iso HF)^-1). assert (ηηinv := nat_trans_eq_pointwise (pr1(pr2(pr2 (left_equivalence_unit_iso HF))))). assert (ηinvη := nat_trans_eq_pointwise (pr2(pr2(pr2 (left_equivalence_unit_iso HF))))). assert (εεinv := nat_trans_eq_pointwise (pr1(pr2(pr2 (left_equivalence_counit_iso HF))))). assert (εinvε := nat_trans_eq_pointwise (pr2(pr2(pr2 (left_equivalence_counit_iso HF))))). assert (LηεL := nat_trans_eq_pointwise (internal_triangle1 HF)). assert (ηRRε := nat_trans_eq_pointwise (internal_triangle2 HF)). cbn in *. use tpair. - intros X Y. use isweq_iso. + intros f. exact (η X · #R f · ηinv Y). + intros f ; cbn. etrans. { apply maponpaths_2. exact (!(pr2 η X Y f)). } rewrite <- assoc. refine (maponpaths (λ z, _ · z) (ηηinv Y) @ _). apply id_right. + intros f ; cbn. rewrite !functor_comp. assert (#L (ηinv Y) = ε (L Y)) as X0. { specialize (LηεL Y). rewrite !id_left, !id_right in LηεL. refine (!(id_right _) @ _). refine (maponpaths (λ z, _ · z) (!LηεL) @ _). rewrite assoc. rewrite <- functor_comp. refine (maponpaths (λ z, # L z · _) (ηinvη Y) @ _). rewrite functor_id, id_left. apply idpath. } etrans. { apply maponpaths. exact X0. } rewrite <- assoc. refine (maponpaths _ (nat_trans_ax ε (L X) (L Y) f) @ _). rewrite assoc. specialize (LηεL X). rewrite !id_left, !id_right in LηεL. etrans. { apply maponpaths_2. exact LηεL. } apply id_left. - cbn. use isweq_iso. + apply R. + intros X ; cbn. apply isotoid. * apply C. * use tpair. ** exact (ηinv X). ** exists (η X); split. *** exact (ηinvη X). *** exact (ηηinv X). + intros Y ; cbn. apply isotoid. * apply D. * use tpair. ** exact (ε Y). ** exists (εinv Y); split. *** exact (εεinv Y). *** exact (εinvε Y). Qed. Definition is_catiso_left_adjoint_equivalence {C D : univalent_category} (F : C ⟶ D) : is_catiso F ≃ @left_adjoint_equivalence bicat_of_univ_cats C D F. Proof. use weqimplimpl. - exact (is_catiso_to_left_adjoint_equivalence F). - exact (left_adjoint_equivalence_to_is_catiso F). - apply isaprop_is_catiso. - apply invproofirrelevance. intros A₁ A₂. apply unique_internal_adjoint_equivalence. apply univalent_cat_is_univalent_2_1. Defined. Definition cat_iso_to_adjequiv (C D : bicat_of_univ_cats) : catiso (pr1 C) (pr1 D) ≃ adjoint_equivalence C D. Proof. use weqfibtototal. intros. apply is_catiso_left_adjoint_equivalence. Defined. Definition idtoiso_2_0_univalent_cat (C D : bicat_of_univ_cats) : C = D ≃ adjoint_equivalence C D := (cat_iso_to_adjequiv C D ∘ catiso_is_path_precat (pr11 C) (pr11 D) (pr21 D) ∘ path_cat (pr1 C) (pr1 D) ∘ path_univalent_cat C D)%weq. Definition univalent_cat_is_univalent_2_0 : is_univalent_2_0 bicat_of_univ_cats. Proof. intros C D. use weqhomot. - exact (idtoiso_2_0_univalent_cat C D). - intro p. induction p. apply path_internal_adjoint_equivalence. + apply univalent_cat_is_univalent_2_1. + apply idpath. Defined. Definition univalent_cat_is_univalent_2 : is_univalent_2 bicat_of_univ_cats. Proof. split. - exact univalent_cat_is_univalent_2_0. - exact univalent_cat_is_univalent_2_1. Defined. Definition adj_equivalence_to_left_equivalence {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} (A : adj_equivalence_of_cats F) : @left_equivalence bicat_of_univ_cats _ _ F. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (adj_equivalence_inv A). - exact (pr1 (unit_nat_z_iso_from_adj_equivalence_of_cats A)). - exact (pr1 (counit_nat_z_iso_from_adj_equivalence_of_cats A)). - apply is_nat_z_iso_to_is_invertible_2cell. exact (pr2 (unit_nat_z_iso_from_adj_equivalence_of_cats A)). - apply is_nat_z_iso_to_is_invertible_2cell. exact (pr2 (counit_nat_z_iso_from_adj_equivalence_of_cats A)). Defined. (** Left adjoints and right adjoints of categories *) Definition left_adjoint_to_is_left_adjoint {C₁ C₂ : bicat_of_univ_cats} {L : C₁ --> C₂} (HL : left_adjoint L) : is_left_adjoint L. Proof. simple refine (left_adjoint_right_adjoint HL ,, ((left_adjoint_unit HL ,, left_adjoint_counit HL) ,, _)). split. - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle1 HL) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle2 HL) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). Defined. Definition is_left_adjoint_to_left_adjoint {C₁ C₂ : bicat_of_univ_cats} {L : C₁ --> C₂} (HL : is_left_adjoint L) : left_adjoint L. Proof. simple refine ((right_functor HL ,, (adjunit HL ,, adjcounit HL)) ,, _). split. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; apply (pr122 HL)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; apply (pr222 HL)). Defined. Definition left_adjoint_weq_is_left_adjoint {C₁ C₂ : bicat_of_univ_cats} (L : C₁ --> C₂) : left_adjoint L ≃ is_left_adjoint L. Proof. use make_weq. - exact left_adjoint_to_is_left_adjoint. - use isweq_iso. + exact is_left_adjoint_to_left_adjoint. + abstract (intro HL ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply idpath). + abstract (intro HL ; refine (maponpaths (λ z, _ ,, z) _) ; use subtypePath ; [ | apply idpath ] ; intro ; apply isapropdirprod ; use impred ; intro ; apply homset_property). Defined. Definition right_adjoint_to_is_right_adjoint {C₁ C₂ : bicat_of_univ_cats} {R : C₁ --> C₂} (HR : internal_right_adj R) : is_right_adjoint R. Proof. simple refine (pr11 HR ,, ((pr121 HR ,, pr221 HR) ,, _)). split. - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (pr12 HR) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (pr22 HR) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). Defined. Definition is_right_adjoint_to_right_adjoint {C₁ C₂ : bicat_of_univ_cats} {R : C₁ --> C₂} (HR : is_right_adjoint R) : internal_right_adj R. Proof. simple refine ((pr1 HR ,, (pr112 HR ,, pr212 HR)) ,, _). split. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; apply (pr122 HR)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; apply (pr222 HR)). Defined. Definition right_adjoint_weq_is_right_adjoint {C₁ C₂ : bicat_of_univ_cats} (R : C₁ --> C₂) : internal_right_adj R ≃ is_right_adjoint R. Proof. use make_weq. - exact right_adjoint_to_is_right_adjoint. - use isweq_iso. + exact is_right_adjoint_to_right_adjoint. + abstract (intro HL ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply idpath). + abstract (intro HL ; refine (maponpaths (λ z, _ ,, z) _) ; use subtypePath ; [ | apply idpath ] ; intro ; apply isapropdirprod ; use impred ; intro ; apply homset_property). Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/BicategoryFromMonoidal.v000066400000000000000000000200671451125700300265150ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Local Open Scope cat. (* Defines a bicategory from a monoidal category. *) Section Bicat_From_Monoidal_Cat. Context (M : monoidal_cat). Let pM := monoidal_cat_cat M. Let I := monoidal_cat_unit M. Let tensor := monoidal_cat_tensor M. Let α := monoidal_cat_associator M. Let l := monoidal_cat_left_unitor M. Let ρ := monoidal_cat_right_unitor M. Let triangle_equality := pr1 (pr222 (pr222 M)). Let pentagon_equation := pr2 (pr222 (pr222 M)). Notation "X ⊗ Y" := (tensor (X, Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Local Notation "f '==>' g" := (prebicat_cells _ f g) (at level 60). Local Notation "f '<==' g" := (prebicat_cells _ g f) (at level 60, only parsing). (* The type of 0-cells is unit type and the 1-cells are the objects of the monoidal category. The 2-cells are given by the morphisms of the original monoidal category. *) Definition one_cells_data_from_monoidal : precategory_data. Proof. red. use tpair. - exact (unit ,, (λ _ _, ob pM)). - cbn. red. cbn. split. + intros _. exact I. + intros _ _ _. exact (λ a b, tensor (a , b)). Defined. Definition two_cells_from_monoidal : prebicat_2cell_struct (one_cells_data_from_monoidal) := λ _ _ a b, pM ⟦ a , b⟧. Definition prebicat_data_from_monoidal : prebicat_data. Proof. use make_prebicat_data. - exact (one_cells_data_from_monoidal ,, two_cells_from_monoidal). - split. { intros ? ? f. exact (id f). } split. { intros ? ? f. apply l. } split. { intros ? ? f. apply ρ. } split. { intros ? ? f. apply (nat_z_iso_inv l). } split. { intros ? ? f. apply (nat_z_iso_inv ρ). } split. { intros ? ? ? ? f g h. apply (α ((f , g) , h)). } split. { intros ? ? ? ? f g h. apply ((nat_z_iso_inv α) ((f , g) , h)). } split. { intros ? ? f g h. exact compose. } split. { intros ? ? ? f g h. exact (λ u, (id f #⊗ u)). } intros ? ? ? f g h. exact (λ u, (u #⊗ id h)). Defined. Lemma prebicat_laws_from_monoidal : prebicat_laws (prebicat_data_from_monoidal). Proof. (* 1. Identities. *) split. { intros. apply id_left. } split. { intros. apply id_right. } (* 2. Vertical right associativity. *) split. { intros. apply assoc. } (* 3. Whiskering and identities. *) split. { intros ? ? ? f g. exact (functor_id tensor (f , g)). } split. { intros ? ? ? f g. exact (functor_id tensor (f , g)). } (* 4. Left whiskering vertical composition. *) split. { intros ? ? ? f g h i x y. etrans. { exact (!(functor_comp tensor (id f #, x) (id f #, y))). } exact (maponpaths (fun z => z #⊗ (x · y)) (id_left _)). } (* 5. Right whiskering vertical composition. *) split. { intros ? ? ? f g h i x y. etrans. { exact (!(functor_comp tensor _ _)). } exact (maponpaths (fun z => (x · y) #⊗ z) (id_left _)). } (* 6 and 7. Vertical composition and unitors. *) split. { intros. exact (pr21 l _ _ _). } split. { intros. exact (pr21 ρ _ _ _). } (* 8. Associator and left/left whiskering *) split. { intros ? ? ? ? f g h i x. etrans. { exact (pr21 (nat_z_iso_inv α) _ _ ((id f #, id g) #, x)). } exact (maponpaths (fun z => _ · (z #⊗ _)) (functor_id tensor (f , g))). } (* 9. Associator and right/left whiskering *) split. { intros ? ? ? ? f g h i x. etrans. { exact (pr21 (nat_z_iso_inv α) _ _ ((id f #, x) #, id i)). } apply idpath. } (* 10. Associator and right/right whiskering *) split. { intros ? ? ? ? f g h i x. etrans. { exact (!(pr21 (nat_z_iso_inv α) _ _ ((x #, id h) #, id i))). } exact (maponpaths (fun z => (_ #⊗ z) · _) (functor_id tensor (h , i))). } (* 11. Vertical composition and whiskering *) split. { intros. etrans. { exact (!(functor_comp tensor _ _)). } etrans. { exact (maponpaths (fun z => (_ #⊗ z)) (id_left _)). } etrans. { exact (maponpaths (fun z => (z #⊗ _)) (id_right _)). } apply pathsinv0. etrans. { exact (!(functor_comp tensor _ _)). } etrans. { exact (maponpaths (fun z => (z #⊗ _)) (id_left _)). } etrans. { exact (maponpaths (fun z => (_ #⊗ z)) (id_right _)). } apply idpath. } (* 12. Left unitor invertible. *) split. { intros ? ? f. exact (z_iso_inv_after_z_iso (l f,, pr2 l f)). } split. { intros ? ? f. exact (z_iso_after_z_iso_inv (l f,, pr2 l f)). } (* 13. Right unitor invertible. *) split. { intros ? ? f. exact (z_iso_inv_after_z_iso (ρ f,, pr2 ρ f)). } split. { intros ? ? f. exact (z_iso_after_z_iso_inv (ρ f,, pr2 ρ f)). } (* 14. Associator invertible. *) split. { intros ? ? ? ? f g h. exact (z_iso_after_z_iso_inv (α ((f, g), h) ,, pr2 α ((f, g), h) )). } split. { intros ? ? ? ? f g h. exact (z_iso_inv_after_z_iso (α ((f, g), h) ,, pr2 α ((f, g), h) )). } (* 15. Right unitor whiskering. *) split. { intros ? ? ? f g. etrans. { exact (maponpaths (fun z => _ · z) (triangle_equality _ _)). } etrans. { exact (assoc _ _ _). } etrans. { exact (maponpaths (fun z => z · _) (z_iso_after_z_iso_inv (α ((f, I), g) ,, pr2 α ((f, I), g) ))). } exact (id_left _). } (* 16. Pentagon equation *) (* The pentagon equation is backwards on the definition of bicategory and in the definition of monoidal category, we need to rewrite the equation in order to apply it. *) intros ? ? ? ? ? f g h i. cbn. apply (pre_comp_with_z_iso_is_inj'(f := α ((f, g), h ⊗ i)) (pr2 α _)). apply (pre_comp_with_z_iso_is_inj'(f := α (((f ⊗ g), h) , i)) (pr2 α _)). apply pathsinv0. etrans. { exact (maponpaths (fun z => _ · z) (assoc _ _ _)). } etrans. { exact (maponpaths (fun z => _ · (z · _)) (z_iso_inv_after_z_iso (α ((f, g), _) ,, pr2 α _ ))). } etrans. { exact (maponpaths (fun z => _ · z) (id_left _)). } etrans. { exact (z_iso_inv_after_z_iso (α ((f ⊗ g, h), _) ,, pr2 α _ )). } apply pathsinv0. etrans. { exact (assoc _ _ _). } etrans. { exact (assoc _ _ _). } etrans. { exact (maponpaths (fun z => (z · _) · _) (pentagon_equation _ _ _ _)). } etrans. { exact (maponpaths (fun z => (z · _)) (!(assoc _ _ _))). } etrans. { exact (maponpaths (fun z => (_ · z · _)) (assoc _ _ _)). } etrans. { exact (maponpaths (fun z => (_ · (z · _) · _)) (!(functor_comp tensor _ _))). } cbn. etrans. { exact (maponpaths (fun z => (_ · ((z #⊗ _) · _) · _)) (id_left _)). } etrans. { exact (maponpaths (fun z => (_ · ((_ #⊗ z) · _) · _)) (z_iso_inv_after_z_iso (α ((g, h), i) ,, pr2 α _))). } assert (aux: # tensor (id (f, (assoc_left (pr12 M)) ((g, h), i))) = id (f ⊗ (assoc_left (pr12 M)) ((g, h), i))) by exact (functor_id tensor ( f , (assoc_left (pr12 M)) ((g, h), i))). etrans. { exact (maponpaths (fun z => (_ · (z · _) · _)) aux). } etrans. { exact (maponpaths (fun z => (_ · z · _)) (id_left _)). } etrans. { exact (maponpaths (fun z => (z · _)) (!(assoc _ _ _))). } etrans. { exact (maponpaths (fun z => (_ · z · _)) (z_iso_inv_after_z_iso (α ((f,g ⊗ h),i) ,, pr2 α _))). } etrans. { exact (maponpaths (fun z => (z · _)) (id_right _)). } etrans. { exact (!(functor_comp tensor _ _)). } etrans. { exact (maponpaths (fun z => (_ #⊗ z)) (id_right _)). } etrans. { exact (maponpaths (fun z => (z #⊗ _)) (z_iso_inv_after_z_iso (α ((f,g),h) ,, pr2 α _))). } apply (functor_id tensor). Qed. Definition prebicat_from_monoidal : prebicat := prebicat_data_from_monoidal ,, prebicat_laws_from_monoidal. Definition bicat_from_monoidal : bicat. use build_bicategory. - exact prebicat_data_from_monoidal. - exact prebicat_laws_from_monoidal. - red. intros. apply homset_property. Defined. End Bicat_From_Monoidal_Cat. UniMath-20231010/UniMath/Bicategories/Core/Examples/BicategoryFromWhiskeredMonoidal.v000066400000000000000000000135471451125700300303700ustar00rootroot00000000000000(** adaptation to whiskered notions by Ralph Matthes 2022 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Local Open Scope cat. (* Defines a bicategory from a whiskered monoidal category. *) Section Bicat_From_Monoidal_Cat. Import Bicat.Notations. Import BifunctorNotations. Import MonoidalNotations. Context {C: category} (M : monoidal C). (* The type of 0-cells is unit type and the 1-cells are the objects of the monoidal category. The 2-cells are given by the morphisms of the original monoidal category. *) Definition one_cells_data_from_monoidal : precategory_data. Proof. use tpair. - exact (unit ,, (λ _ _, ob C)). - split. + intros dummy. exact I_{ M }. + intros dummy0 dummy1 dummy2. exact (λ a b, a ⊗_{M} b). Defined. Definition two_cells_from_monoidal : prebicat_2cell_struct (one_cells_data_from_monoidal) := λ _ _ a b, C ⟦ a , b⟧. Definition prebicat_data_from_monoidal : prebicat_data. Proof. use make_prebicat_data. - exact (one_cells_data_from_monoidal ,, two_cells_from_monoidal). - split. { intros ? ? f. exact (id₁ f). } split. { intros ? ? f. apply monoidal_leftunitordata. } split. { intros ? ? f. apply monoidal_rightunitordata. } split. { intros ? ? f. apply monoidal_leftunitorinvdata. } split. { intros ? ? f. apply monoidal_rightunitorinvdata. } split. { intros ? ? ? ? f g h. exact ( α_{ M } f g h ). } split. { intros ? ? ? ? f g h. exact ( αinv_{ M } f g h ). } split. { intros ? ? f g h. exact compose. } split. { intros ? ? ? f g h. exact (λ u, (f ⊗^{ M }_{l} u)). } intros ? ? ? f g h. exact (λ u, (u ⊗^{ M }_{r} h)). Defined. Lemma prebicat_laws_from_monoidal : prebicat_laws (prebicat_data_from_monoidal). Proof. (* 1. Identities. *) split. { intros. apply id_left. } split. { intros. apply id_right. } (* 2. Vertical right associativity. *) split. { intros. apply assoc. } (* 3. Whiskering and identities. *) split. { intros ? ? ? f g. apply (bifunctor_leftid M). } split. { intros ? ? ? f g. apply (bifunctor_rightid M). } (* 4. Left whiskering vertical composition. *) split. { intros ? ? ? f g h i x y. apply pathsinv0, (bifunctor_leftcomp M). } (* 5. Right whiskering vertical composition. *) split. { intros ? ? ? f g h i x y. apply pathsinv0, (bifunctor_rightcomp M). } (* 6 and 7. Vertical composition and unitors. *) split. { intros. apply (leftunitorlaw_nat (monoidal_leftunitorlaw M)). } split. { intros. apply (rightunitorlaw_nat (monoidal_rightunitorlaw M)). } (* 8. Associator and left/left whiskering *) split. { intros ? ? ? ? f g h i x. cbn. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g h))). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g i))). apply (associatorlaw_natleft (monoidal_associatorlaw M)). } (* 9. Associator and right/left whiskering *) split. { intros ? ? ? ? f g h i x. cbn. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f g i))). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f h i))). apply (associatorlaw_natleftright (monoidal_associatorlaw M)). } (* 10. Associator and right/right whiskering *) split. { intros ? ? ? ? f g h i x. cbn. apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f h i))). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) g h i))). apply (associatorlaw_natright (monoidal_associatorlaw M)). } (* 11. Vertical composition and whiskering *) split. { intros. cbn. apply (bifunctor_equalwhiskers M). } (* 12. Left unitor invertible. *) split. { intros ? ? f. exact (pr1 (leftunitorlaw_iso_law (monoidal_leftunitorlaw M) f)). } split. { intros ? ? f. exact (pr2 (leftunitorlaw_iso_law (monoidal_leftunitorlaw M) f)). } (* 13. Right unitor invertible. *) split. { intros ? ? f. exact (pr1 (rightunitorlaw_iso_law (monoidal_rightunitorlaw M) f)). } split. { intros ? ? f. exact (pr2 (rightunitorlaw_iso_law (monoidal_rightunitorlaw M) f)). } (* 14. Associator invertible. *) split. { intros ? ? ? ? f g h. exact (pr2 (associatorlaw_iso_law (monoidal_associatorlaw M) f g h)). } split. { intros ? ? ? ? f g h. exact (pr1 (associatorlaw_iso_law (monoidal_associatorlaw M) f g h)). } (* 15. Right unitor whiskering. *) split. { intros ? ? ? f g. apply (z_iso_inv_on_right _ _ _ (_,,(_,,associatorlaw_iso_law (monoidal_associatorlaw M) f I_{ M} g))). apply pathsinv0, monoidal_triangleidentity. } (* 16. Pentagon equation *) intros ? ? ? ? ? f g h i. cbn. (* the pentagon equation in bicategories is formulated for the left associator while it is based on the right associator in whiskered monoidal categories *) apply monoidal_pentagon_identity_inv. Qed. Definition prebicat_from_monoidal : prebicat := prebicat_data_from_monoidal ,, prebicat_laws_from_monoidal. Definition bicat_from_monoidal : bicat. use build_bicategory. - exact prebicat_data_from_monoidal. - exact prebicat_laws_from_monoidal. - red. intros. apply homset_property. Defined. End Bicat_From_Monoidal_Cat. UniMath-20231010/UniMath/Bicategories/Core/Examples/DiscreteBicat.v000066400000000000000000000071641451125700300246260ustar00rootroot00000000000000(***************************************************************************** Discrete bicategories Every category gives rise to a discrete bicategory, namely the bicategory whose objects and 1-cells are objects and morphisms in the category respectively, and whose 2-cells are equalities of morphisms in the category. We show that this bicategory is discrete (locally univalent, all 2-cells are invertible, and all 2-cells with the same source and target are equal). Contents 1. The discrete bicategory 2. The discrete bicategory is discrete *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section CatToBicat. Context (C : category). (** 1. The discrete bicategory *) Definition cat_to_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. simple refine (_ ,, _). - exact C. - exact (λ x y f g, f = g). Defined. Definition cat_to_prebicat_2_id_comp_struct : prebicat_2_id_comp_struct cat_to_prebicat_1_id_comp_cells. Proof. repeat split. - intros x y f ; cbn. apply id_left. - intros x y f ; cbn. apply id_right. - intros x y f ; cbn. exact (!(id_left _)). - intros x y f ; cbn. exact (!(id_right _)). - intros w x y z f g h ; cbn. apply assoc'. - intros w x y z f g h ; cbn. apply assoc. - intros x y f g h p q ; cbn. exact (p @ q). - intros x y z f g₁ g₂ p ; cbn. exact (maponpaths (λ z, f · z) p). - intros x y z f₁ f₂ g p ; cbn. exact (maponpaths (λ z, z · g) p). Qed. Definition cat_to_prebicat_data : prebicat_data. Proof. simple refine (_ ,, _). - exact cat_to_prebicat_1_id_comp_cells. - exact cat_to_prebicat_2_id_comp_struct. Defined. Proposition cat_to_prebicat_laws : prebicat_laws cat_to_prebicat_data. Proof. repeat split ; intro ; intros ; apply homset_property. Qed. Definition cat_to_prebicat : prebicat. Proof. simple refine (_ ,, _). - exact cat_to_prebicat_data. - exact cat_to_prebicat_laws. Defined. Definition cat_to_bicat : bicat. Proof. refine (cat_to_prebicat ,, _). abstract (intros x y f g p q ; apply isasetaprop ; apply homset_property). Defined. (** 2. The discrete bicategory is discrete *) Proposition isaprop_2cells_cat_to_bicat : isaprop_2cells cat_to_bicat. Proof. intros x y f g p q. apply homset_property. Qed. Proposition locally_groupoid_cat_to_bicat : locally_groupoid cat_to_bicat. Proof. intros x y f g α. refine (!α ,, _ ,, _). - apply isaprop_2cells_cat_to_bicat. - apply isaprop_2cells_cat_to_bicat. Defined. Proposition is_univalent_2_1_cat_to_bicat : is_univalent_2_1 cat_to_bicat. Proof. intros x y f g. use isweqimplimpl. - exact (λ p, pr1 p). - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_invertible_2cell. + intros. apply homset_property. Qed. Proposition is_discrete_cat_to_bicat : is_discrete_bicat cat_to_bicat. Proof. repeat split. - exact is_univalent_2_1_cat_to_bicat. - exact locally_groupoid_cat_to_bicat. - exact isaprop_2cells_cat_to_bicat. Qed. End CatToBicat. UniMath-20231010/UniMath/Bicategories/Core/Examples/FibSlice.v000066400000000000000000000453261451125700300236030ustar00rootroot00000000000000(********************************************************************************* The fibrational slice bicategory In this file, we define the fibrational slice bicategory. More specifically, given a *univalent* category `C`, we define the fibrational slice bicategory as follows: - Objects: (cloven) fibrations over `C` - 1-cells: cartesian functors making a triangle commute - 2-cells: natural transformations that satisfy some equality We also prove that this bicategory is univalent. For this, we need that the category `C` is univalent. In addition, we use the structure identity principle for displayed categories, which says that two displayed categories are equal if and only if we have an adjoint equivalence between them. Contents 1. The fibrational slice bicategory 2. Invertible 2-cells in the fibrational slice bicategory 3. Local univalence of the fibrational slice bicategory 4. Adjoint equivalences in the fibrational slice bicategory 5. Global univalence of the fibrational slice bicategory *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedFunctorEq. Require Import UniMath.CategoryTheory.DisplayedCats.EquivalenceOverId. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedCatEq. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section FibSlice. Context (C : univalent_category). (** 1. The fibrational slice bicategory *) Definition fib_slice_precategory_ob_mor : precategory_ob_mor. Proof. simple refine (_ ,, _). - exact (∑ (D : disp_univalent_category C), cleaving D). - exact (λ D₁ D₂, cartesian_disp_functor (functor_identity _) (pr1 D₁) (pr1 D₂)). Defined. Definition fib_slice_precategory_id_comp : precategory_id_comp fib_slice_precategory_ob_mor. Proof. simple refine (_ ,, _). - exact (λ D, disp_functor_identity (pr1 D) ,, disp_functor_identity_is_cartesian_disp_functor (pr1 D)). - exact (λ D₁ D₂ D₃ FF GG, disp_functor_over_id_composite (pr1 FF) (pr1 GG) ,, disp_functor_over_id_composite_is_cartesian (pr2 FF) (pr2 GG)). Defined. Definition fib_slice_precategory_data : precategory_data. Proof. simple refine (_ ,, _). - exact fib_slice_precategory_ob_mor. - exact fib_slice_precategory_id_comp. Defined. Definition fib_slice_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. simple refine (_ ,, _). - exact fib_slice_precategory_data. - exact (λ D₁ D₂ FF GG, disp_nat_trans (nat_trans_id _) (pr1 FF) (pr1 GG)). Defined. Definition fib_slice_prebicat_2_id_comp_struct : prebicat_2_id_comp_struct fib_slice_prebicat_1_id_comp_cells. Proof. repeat split. - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ D₃ D₃ FF GG HH, disp_nat_trans_id _). - exact (λ D₁ D₂ D₃ D₃ FF GG HH, disp_nat_trans_id _). - exact (λ D₁ D₂ FF GG HH α β, disp_nat_trans_over_id_comp α β). - exact (λ D₁ D₂ D₃ FF GG₁ GG₂ α, disp_nat_trans_over_id_prewhisker (pr1 FF) α). - exact (λ D₁ D₂ D₃ FF₁ FF₂ GG α, disp_nat_trans_over_id_postwhisker (pr1 GG) α). Defined. Definition fib_slice_prebicat_data : prebicat_data. Proof. simple refine (_ ,, _). - exact fib_slice_prebicat_1_id_comp_cells. - exact fib_slice_prebicat_2_id_comp_struct. Defined. Definition fib_slice_prebicat_laws : prebicat_laws fib_slice_prebicat_data. Proof. repeat split. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. apply idpath. - intros ? ? ? F G ; use disp_nat_trans_eq ; intros ; cbn. exact (disp_functor_id (pr1 G) _). - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. apply idpath. - intros D₁ D₂ D₃ FF₁ FF₂ FF₃ GG α β. use disp_nat_trans_eq ; intros x xx ; cbn. rewrite (disp_functor_transportf _ (pr1 GG)). rewrite disp_functor_comp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ FF GG HH II α β. use disp_nat_trans_eq ; intros x xx ; cbn in *. etrans. { apply maponpaths. exact (disp_nat_trans_ax β (α x xx)). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intros D₁ D₂ D₃ F G. use disp_nat_trans_eq ; intros x xx ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite (disp_functor_id (pr1 G)). cbn. apply transportf_set. apply homset_property. - intros D₁ D₂ D₃ D₄ D₅ FF GG HH II. use disp_nat_trans_eq ; intros ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite !id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. rewrite (disp_functor_id (pr1 II)). unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition fib_slice_prebicat : prebicat. Proof. simple refine (_ ,, _). - exact fib_slice_prebicat_data. - exact fib_slice_prebicat_laws. Defined. Definition fib_slice_bicat : bicat. Proof. simple refine (_ ,, _). - exact fib_slice_prebicat. - intro ; intros. apply isaset_disp_nat_trans. Defined. (** 2. Invertible 2-cells in the fibrational slice bicategory *) Definition is_invertible_2cell_fib_slice {D₁ D₂ : fib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (α : G₁ ==> G₂) (Hα : is_disp_nat_z_iso (nat_z_iso_id (functor_identity C)) α) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (pointwise_inverse_disp_nat_trans α Hα). - apply pointwise_inverse_disp_nat_trans_over_id_left. - apply pointwise_inverse_disp_nat_trans_over_id_right. Defined. Definition disp_nat_z_iso_to_inv2cell_fib {D₁ D₂ : fib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (τ : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id (functor_identity C))) : invertible_2cell G₁ G₂. Proof. use make_invertible_2cell. - exact (pr1 τ). - apply is_invertible_2cell_fib_slice. exact (pr2 τ). Defined. Definition from_is_invertible_2cell_fib_slice {D₁ D₂ : fib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (α : G₁ ==> G₂) (Hα : is_invertible_2cell α) : is_disp_nat_z_iso (nat_z_iso_id (functor_identity C)) α. Proof. intros x xx. simple refine (_ ,, _ ,, _). - exact (pr1 (Hα^-1) x xx). - abstract (use transportb_transpose_right ; refine (_ @ maponpaths (λ z, pr1 z x xx) (vcomp_linv Hα)) ; cbn ; apply maponpaths_2 ; apply homset_property). - abstract (use transportb_transpose_right ; refine (_ @ maponpaths (λ z, pr1 z x xx) (vcomp_rinv Hα)) ; cbn ; apply maponpaths_2 ; apply homset_property). Defined. Definition inv2cell_to_disp_nat_z_iso_fib {D₁ D₂ : fib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (τ : invertible_2cell G₁ G₂) : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id (functor_identity C)) := pr1 τ ,, from_is_invertible_2cell_fib_slice (pr1 τ) (pr2 τ). Definition invertible_2cell_fib_slice_weq {D₁ D₂ : fib_slice_bicat} (G₁ G₂ : D₁ --> D₂) : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id _) ≃ invertible_2cell G₁ G₂. Proof. use weq_iso. - exact disp_nat_z_iso_to_inv2cell_fib. - exact inv2cell_to_disp_nat_z_iso_fib. - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_is_disp_nat_z_iso | ] ; apply idpath). - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). Defined. (** 3. Local univalence of the fibrational slice bicategory *) Proposition is_univalent_2_1_fib_slice_bicat : is_univalent_2_1 fib_slice_bicat. Proof. intros D₁ D₂ F G. use weqhomot. - refine (invertible_2cell_fib_slice_weq F G ∘ disp_functor_eq_weq (pr1 F) (pr1 G) (pr1 D₂) ∘ path_sigma_hprop _ _ _ _)%weq. apply isaprop_is_cartesian_disp_functor. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; use disp_nat_trans_eq ; intros x xx ; cbn ; apply idpath). Defined. (** 4. Adjoint equivalences in the fibrational slice bicategory *) Definition left_adjoint_equivalence_fib_slice {D₁ D₂ : fib_slice_bicat} (F : D₁ --> D₂) (HF : is_equiv_over_id (pr1 F)) : left_adjoint_equivalence F. Proof. use equiv_to_adjequiv. simple refine (((_ ,, _) ,, (_ ,, _)) ,, _ ,, _). - exact HF. - exact (is_cartesian_equiv_over_id (equiv_inv _ HF)). - exact (unit_over_id HF). - exact (counit_over_id HF). - use is_invertible_2cell_fib_slice. intros x xx. exact (is_z_iso_unit_over_id HF x xx). - use is_invertible_2cell_fib_slice. intros x xx. exact (is_z_iso_counit_over_id HF x xx). Defined. Definition adj_equiv_fib_slice {D₁ D₂ : fib_slice_bicat} (F : disp_functor (functor_identity C) (pr1 D₁) (pr1 D₂)) (HF : is_equiv_over_id F) : adjoint_equivalence D₁ D₂. Proof. simple refine ((F ,, _) ,, _). - exact (is_cartesian_equiv_over_id HF). - exact (left_adjoint_equivalence_fib_slice (_ ,, _) HF). Defined. Proposition from_left_adjoint_equivalence_fib_slice {D₁ D₂ : fib_slice_bicat} (F : D₁ --> D₂) (HF : left_adjoint_equivalence F) : is_equiv_over_id (pr1 F). Proof. simple refine (((_ ,, (_ ,, _)) ,, (_ ,, _)) ,, (_ ,, _)). - exact (pr1 (left_adjoint_right_adjoint HF)). - exact (left_adjoint_unit HF). - exact (left_adjoint_counit HF). - abstract (intros x xx ; cbn ; pose (p := maponpaths (λ z, pr1 z x xx) (internal_triangle1 HF)) ; cbn in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; rewrite id_left_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; refine (transportb_transpose_right p @ _) ; apply maponpaths_2 ; apply homset_property). - abstract (intros x xx ; cbn ; pose (p := maponpaths (λ z, pr1 z x xx) (internal_triangle2 HF)) ; cbn in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; rewrite id_left_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; refine (transportb_transpose_right p @ _) ; apply maponpaths_2 ; apply homset_property). - intros x xx. exact (from_is_invertible_2cell_fib_slice _ (pr122 HF) x xx). - intros x xx. exact (from_is_invertible_2cell_fib_slice _ (pr222 HF) x xx). Defined. Definition adj_equiv_fib_slice_weq (D₁ D₂ : fib_slice_bicat) : (∑ (F : disp_functor (functor_identity C) (pr1 D₁) (pr1 D₂)), is_equiv_over_id F) ≃ adjoint_equivalence D₁ D₂. Proof. use weq_iso. - exact (λ F, adj_equiv_fib_slice (pr1 F) (pr2 F)). - exact (λ F, pr11 F ,, from_left_adjoint_equivalence_fib_slice _ (pr2 F)). - abstract (intros F ; use subtypePath ; [ intro ; apply (isaprop_is_equiv_over_id (pr1 D₁) (pr1 D₂)) | ] ; apply idpath). - abstract (intro F ; use subtypePath ; [ intro ; apply (isaprop_left_adjoint_equivalence _ is_univalent_2_1_fib_slice_bicat) | ] ; use subtypePath ; [ intro ; apply isaprop_is_cartesian_disp_functor | ] ; cbn ; apply idpath). Defined. (** 5. Global univalence of the fibrational slice bicategory *) Proposition is_univalent_2_0_fib_slice_bicat : is_univalent_2_0 fib_slice_bicat. Proof. intros D₁ D₂. use weqhomot. - refine (adj_equiv_fib_slice_weq D₁ D₂ ∘ disp_cat_eq (pr1 D₁) (pr1 D₂) (pr1 D₁) (pr1 D₂) ∘ path_sigma_hprop _ _ _ _ ∘ path_sigma_hprop _ _ _ _)%weq. + apply isaprop_cleaving. apply (pr1 D₂). + apply isaprop_is_univalent_disp. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply (isaprop_left_adjoint_equivalence _ is_univalent_2_1_fib_slice_bicat) | ] ; use subtypePath ; [ intro ; apply isaprop_is_cartesian_disp_functor | ] ; apply idpath). Defined. Proposition is_univalent_2_fib_slice_bicat : is_univalent_2 fib_slice_bicat. Proof. split. - exact is_univalent_2_0_fib_slice_bicat. - exact is_univalent_2_1_fib_slice_bicat. Defined. End FibSlice. UniMath-20231010/UniMath/Bicategories/Core/Examples/Final.v000066400000000000000000000074141451125700300231500ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** ** Final bicategory and proof that it's univalent. Note: UniMath.CategoryTheory.categories.StandardCategories has the definition of final 1-category ([unit_category]). *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope cat. Local Open Scope bicategory_scope. Section Final_Bicategory. Definition final_1_id_comp_cells : prebicat_1_id_comp_cells := tpair (λ C : precategory_data, prebicat_2cell_struct C) unit_category (λ (a b : unit_category) (f g : a --> b), unit). Definition final_2_id_comp_struct : prebicat_2_id_comp_struct final_1_id_comp_cells. Proof. repeat split; exact tounit. Defined. Definition final_prebicat_data : prebicat_data := final_1_id_comp_cells,, final_2_id_comp_struct. Lemma final_bicat_laws : prebicat_laws final_prebicat_data. Proof. repeat apply make_dirprod; intros; apply isProofIrrelevantUnit. Qed. Definition final_prebicat : prebicat := final_prebicat_data,, final_bicat_laws. Lemma cellset_final_prebicat : isaset_cells final_prebicat. Proof. red. cbn. intros. exact isasetunit. Qed. Definition final_bicat : bicat := final_prebicat,, cellset_final_prebicat. Definition final_bicat_invertible_2cell {x y : final_bicat} {f g : x --> y} (α : f ==> g) : is_invertible_2cell α. Proof. refine (tt ,, (_ ,, _)) ; reflexivity. Defined. Definition final_bicat_adjoint_equivalence {x y : final_bicat} (f : x --> y) : left_adjoint_equivalence f. Proof. use tpair. - use tpair. + exact (!f). + exact (tt ,, tt). - split ; split ; cbn. + reflexivity. + reflexivity. + apply final_bicat_invertible_2cell. + apply final_bicat_invertible_2cell. Defined. (** It is univalent *) Definition final_bicat_is_univalent_2_1 : is_univalent_2_1 final_bicat. Proof. intros x y p q. use isweqimplimpl. - intros. apply isasetaprop. apply isapropunit. - apply isasetaprop. apply isasetaprop. exact isapropunit. - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)). + exact isapropunit. + apply isaprop_is_invertible_2cell. Defined. Definition final_bicat_is_univalent_2_0 : is_univalent_2_0 final_bicat. Proof. intros x y. apply isweqimplimpl. - intros. induction x, y. reflexivity. - apply isasetaprop. exact isapropunit. - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)). + apply isasetaprop. exact isapropunit. + apply isaprop_left_adjoint_equivalence. exact final_bicat_is_univalent_2_1. Defined. Definition final_bicat_is_univalent_2 : is_univalent_2 final_bicat. Proof. split. - exact final_bicat_is_univalent_2_0. - exact final_bicat_is_univalent_2_1. Defined. End Final_Bicategory. UniMath-20231010/UniMath/Bicategories/Core/Examples/Groupoids.v000066400000000000000000000047441451125700300240750ustar00rootroot00000000000000(* ******************************************************************************* *) (** Groupoids ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Local Open Scope cat. Definition grpds : bicat := fullsubbicat bicat_of_univ_cats (λ X, is_pregroupoid (pr1 X)). Definition grpds_univalent : is_univalent_2 grpds. Proof. apply is_univalent_2_fullsubbicat. - apply univalent_cat_is_univalent_2. - intro. apply isaprop_is_pregroupoid. Defined. Definition locally_groupoid_grpds : locally_groupoid grpds. Proof. intros G₁ G₂ F₁ F₂ α. use make_is_invertible_2cell. - refine (_ ,, tt). use make_nat_trans. + exact (λ x, inv_from_z_iso (_ ,, pr2 G₂ _ _ (pr11 α x))). + abstract (intros x y f ; cbn ; refine (!_) ; apply z_iso_inv_on_right ; rewrite !assoc ; apply z_iso_inv_on_left ; simpl ; exact (!(pr21 α x y f))). - abstract (apply subtypePath ; try (intro ; apply isapropunit) ; apply nat_trans_eq ; try apply homset_property ; intro x ; cbn ; exact (z_iso_inv_after_z_iso (_ ,, _))). - abstract (apply subtypePath ; try (intro ; apply isapropunit) ; apply nat_trans_eq ; try apply homset_property ; intro x ; cbn ; exact (z_iso_after_z_iso_inv (_ ,, _))). Defined. Definition grpds_2cell_to_nat_z_iso {G₁ G₂ : grpds} {F₁ F₂ : G₁ --> G₂} (α : F₁ ==> F₂) : nat_z_iso (pr1 F₁) (pr1 F₂). Proof. use make_nat_z_iso. - exact (pr1 α). - intros x. exact (pr2 G₂ (pr11 F₁ x) (pr11 F₂ x) (pr11 α x)). Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/Image.v000066400000000000000000000043351451125700300231400ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** Image of a pseudofunctor *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Local Open Scope cat. Definition full_image {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) : bicat := fullsubbicat B₂ (λ y, ∃ (x : B₁), F x = y). Definition is_univalent_2_1_full_image {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) (B₂_is_univalent_2_1 : is_univalent_2_1 B₂) : is_univalent_2_1 (full_image F). Proof. apply is_univalent_2_1_fullsubbicat. exact B₂_is_univalent_2_1. Defined. Definition is_univalent_2_0_full_image {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) (B₂_is_univalent_2 : is_univalent_2 B₂) : is_univalent_2_0 (full_image F). Proof. apply is_univalent_2_0_fullsubbicat. - exact B₂_is_univalent_2. - intro. apply isapropishinh. Defined. Definition is_univalent_2_full_image {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) (B₂_is_univalent_2 : is_univalent_2 B₂) : is_univalent_2 (full_image F). Proof. apply is_univalent_2_fullsubbicat. - exact B₂_is_univalent_2. - intro. apply isapropishinh. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/Initial.v000066400000000000000000000056601451125700300235110ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** ** Initial bicategory and proof that it's univalent. Note: UniMath.CategoryTheory.categories.StandardCategories has the definition of initial 1-category ([empty_category]). *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope cat. Section Initial_Bicategory. Definition initial_1_id_comp_cells : prebicat_1_id_comp_cells := tpair (λ C : precategory_data, prebicat_2cell_struct C) empty_category (λ (a b : empty_category) (f g : a --> b), ∅). Definition initial_2_id_comp_struct : prebicat_2_id_comp_struct initial_1_id_comp_cells. Proof. repeat split; exact (λ u : ∅, fromempty u). Defined. Definition initial_prebicat_data : prebicat_data := initial_1_id_comp_cells,, initial_2_id_comp_struct. Lemma initial_bicat_laws : prebicat_laws initial_prebicat_data. Proof. repeat split; exact (λ u : ∅, fromempty u). Qed. Definition initial_prebicat : prebicat := initial_prebicat_data,, initial_bicat_laws. Definition cellset_initial_prebicat : isaset_cells initial_prebicat := λ u : ∅, fromempty u. Definition initial_bicat : bicat := initial_prebicat,, cellset_initial_prebicat. Definition initial_bicat_invertible_2cell {x y : initial_bicat} {f g : x --> y} (α : f ==> g) : is_invertible_2cell α. Proof. exact (fromempty x). Defined. Definition initial_bicat_adjoint_equivalence {x y : initial_bicat} (f : x --> y) : left_adjoint_equivalence f. Proof. exact (fromempty x). Defined. (** It is univalent *) Definition initial_bicat_is_univalent_2_1 : is_univalent_2_1 initial_bicat. Proof. intros x. exact (fromempty x). Defined. Definition initial_bicat_is_univalent_2_0 : is_univalent_2_0 initial_bicat. Proof. intros x. exact (fromempty x). Defined. Definition initial_bicat_is_univalent_2 : is_univalent_2 initial_bicat. Proof. split. - exact initial_bicat_is_univalent_2_0. - exact initial_bicat_is_univalent_2_1. Defined. End Initial_Bicategory. UniMath-20231010/UniMath/Bicategories/Core/Examples/OneTypes.v000066400000000000000000000145661451125700300236730ustar00rootroot00000000000000(** The bicategory of 1-types. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope cat. Local Open Scope bicategory_scope. Definition one_type : UU := HLevel 3. Definition make_one_type (X : UU) (i : isofhlevel 3 X) : one_type := tpair (λ A, isofhlevel 3 A) X i. Definition one_type_to_type : one_type -> UU := pr1. Coercion one_type_to_type : one_type >-> UU. Definition one_type_isofhlevel (X : one_type) : isofhlevel 3 X. Proof. apply X. Defined. (** The bicategory *) Definition one_type_bicat_data : prebicat_data. Proof. use build_prebicat_data. - exact one_type. - exact (λ X Y, X → Y). - exact (λ _ _ f g, f ~ g). - exact (λ _ x, x). - exact (λ _ _ _ f g x, g(f x)). - intros. exact (homotrefl _). - cbn ; intros X Y f g h p q. exact (homotcomp p q). - cbn ; intros X Y Z f g h p. exact (funhomotsec f p). - cbn ; intros X Y Z f g h p. exact (homotfun p h). - intros ; intro. apply idpath. - intros ; intro. apply idpath. - intros ; intro. apply idpath. - intros ; intro. apply idpath. - intros ; intro. apply idpath. - intros ; intro. apply idpath. Defined. Lemma one_type_bicat_laws : prebicat_laws one_type_bicat_data. Proof. repeat (use tpair). - intros X Y f g p ; cbn in *. apply idpath. - intros X Y f g p ; cbn in *. unfold homotcomp, homotrefl. apply funextsec. intro x. apply pathscomp0rid. - intros X Y f g h k p q r. apply funextsec. intro x. apply path_assoc. - intros; apply idpath. - intros; apply idpath. - intros X Y Z f g h i p q ; cbn in *. apply funextsec. intro x. apply idpath. - intros X Y Z f g h i p q ; cbn in *. apply funextsec. intro x. unfold homotcomp, homotfun. simpl. apply (! maponpathscomp0 _ _ _). - intros X Y f g p ; cbn in *. apply funextsec. intro x. unfold homotcomp, homotfun. simpl. apply pathscomp0rid. - intros X Y f g p ; cbn in *. apply funextsec. intro x. unfold homotcomp, homotfun. simpl. etrans. { apply pathscomp0rid. } apply maponpathsidfun. - intros W X Y Z f g h i p ; cbn in *. apply funextsec. intro x. unfold homotcomp, funhomotsec. simpl. apply pathscomp0rid. - intros W X Y Z f g h i p ; cbn in *. apply funextsec. intro x. apply pathscomp0rid. - intros W X Y Z f g h i p ; cbn in *. apply funextsec. intro x. unfold homotcomp, homotfun. simpl. etrans. { apply maponpathscomp. } apply (! pathscomp0rid _). - intros X Y Z f g h i p q ; cbn in *. apply funextsec. intro x. unfold homotcomp, homotfun, funhomotsec. induction (p x). apply (! pathscomp0rid _). - intros; apply idpath. - intros; apply idpath. - intros; apply idpath. - intros; apply idpath. - intros; apply idpath. - intros; apply idpath. - intros; apply idpath. - intros V W X Y Z f g h i ; cbn in *. apply idpath. Qed. Definition one_types : bicat. Proof. use build_bicategory. - exact one_type_bicat_data. - exact one_type_bicat_laws. - intros X Y f g ; cbn in *. apply (impred 2 (λ x, f x = g x)). exact (λ x, pr2 Y (f x) (g x)). Defined. (** Each 2-cell is an iso *) Definition one_type_2cell_iso : locally_groupoid one_types. Proof. intros X Y f g α. refine (invhomot α ,, _). split ; cbn. - apply funextsec. intro x. apply pathsinv0r. - apply funextsec. intro x. apply pathsinv0l. Defined. (** It is univalent *) Definition one_types_is_univalent_2_1 : is_univalent_2_1 one_types. Proof. intros X Y f g. use isweq_iso. - intros α. apply funextsec. apply α. - intros p. induction p ; cbn. change (homotrefl f) with (toforallpaths _ f f (idpath f)). apply funextsec_toforallpaths. - intros α. cbn. use subtypePath ; cbn. + intro. exact (@isaprop_is_invertible_2cell one_types X Y f g _). + etrans. 2:{ apply toforallpaths_funextsec. } unfold idtoiso_2_1, toforallpaths. cbn. apply funextsec. intro x. induction (funextsec _ f g (pr1 α)). apply idpath. Defined. Definition adjoint_equivalence_is_weq {X Y : one_types} (f : one_types⟦X,Y⟧) (Hf : left_adjoint_equivalence f) : isweq f. Proof. use isweq_iso. - exact (left_adjoint_right_adjoint Hf). - intros x. exact (!left_adjoint_unit Hf x). - intros x. exact (left_adjoint_counit Hf x). Defined. Definition weq_is_adjoint_equivalence_help {X Y : one_types} (f : X --> Y) (Hf : isweq f) : left_equivalence f. Proof. use tpair. - refine (invmap (f ,, Hf) ,, _). split. + intros x. exact (!(homotinvweqweq (f ,, Hf) x)). + intros x. exact (homotweqinvweq (f ,, Hf) x). - split ; apply one_type_2cell_iso. Defined. Definition weq_is_adjoint_equivalence {X Y : one_types} (f : X --> Y) (Hf : isweq f) : left_adjoint_equivalence f. Proof. apply equiv_to_isadjequiv. exact (weq_is_adjoint_equivalence_help f Hf). Defined. Definition adjequiv_to_weq (X Y : one_types) : (pr1 X ≃ pr1 Y) ≃ adjoint_equivalence X Y. Proof. use weqfibtototal. intro f. apply weqimplimpl. - intro Hf. exact (weq_is_adjoint_equivalence f Hf). - exact (adjoint_equivalence_is_weq f). - apply isapropisweq. - apply isaprop_left_adjoint_equivalence. exact one_types_is_univalent_2_1. Defined. Definition idoiso_2_0_onetypes (X Y : one_types) : X = Y ≃ adjoint_equivalence X Y := (adjequiv_to_weq X Y ∘ UA_for_HLevels 3 X Y)%weq. Definition one_types_is_univalent_2_0 : is_univalent_2_0 one_types. Proof. intros X Y. use weqhomot. - exact (idoiso_2_0_onetypes X Y). - intros p. induction p ; cbn. apply path_internal_adjoint_equivalence. + apply one_types_is_univalent_2_1. + apply idpath. Defined. Definition one_types_is_univalent_2 : is_univalent_2 one_types. Proof. split. - exact one_types_is_univalent_2_0. - exact one_types_is_univalent_2_1. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/OpCellBicat.v000066400000000000000000000215401451125700300242340ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** ** op2 bicategory. Bicategory obtained by formally reversing 2-cells. Benedikt Ahrens, Marco Maggesi February 2018 *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Local Open Scope cat. Section OpCell. Context (B : bicat). Definition op2_prebicat_data : prebicat_data. Proof. use build_prebicat_data. - exact B. - exact (λ x y, x --> y). - exact (λ x y f g, g ==> f). - exact (λ x, id₁ _). - exact (λ x y z f g, f · g). - exact (λ x y f, id₂ _). - exact (λ x y f g h α β, β • α). - exact (λ x y z f g h α, f ◃ α). - exact (λ x y z g h f α, α ▹ f). - exact (λ x y f, linvunitor f). - exact (λ x y f, lunitor f). - exact (λ x y f, rinvunitor f). - exact (λ x y f, runitor f). - exact (λ w x y z f g h, rassociator f g h). - exact (λ w x y z f g h, lassociator f g h). Defined. Lemma op2_prebicat_laws : prebicat_laws op2_prebicat_data. Proof. repeat split; intros; cbn. - apply id2_right. - apply id2_left. - apply (!vassocr _ _ _ ). - apply lwhisker_id2. - apply id2_rwhisker. - apply lwhisker_vcomp. - apply rwhisker_vcomp. - use lhs_left_invert_cell; [ apply is_invertible_2cell_linvunitor |]. cbn. apply pathsinv0. etrans. { apply vassocr. } use lhs_right_invert_cell; [ apply is_invertible_2cell_linvunitor |]. cbn. apply pathsinv0. apply vcomp_lunitor. - use lhs_left_invert_cell; [ apply is_invertible_2cell_rinvunitor |]. cbn. apply pathsinv0. etrans. { apply vassocr. } use lhs_right_invert_cell; [ apply is_invertible_2cell_rinvunitor |]. cbn. apply pathsinv0. apply vcomp_runitor. - apply lassociator_to_rassociator_pre. apply pathsinv0. etrans. { apply (vassocr _ _ _ ). } apply lassociator_to_rassociator_post. apply pathsinv0. apply lwhisker_lwhisker. - apply lassociator_to_rassociator_pre. apply pathsinv0. etrans. { apply (vassocr _ _ _ ). } apply lassociator_to_rassociator_post. apply pathsinv0. apply rwhisker_lwhisker. - apply pathsinv0, lassociator_to_rassociator_pre. apply pathsinv0. etrans. { apply (vassocr _ _ _ ). } apply lassociator_to_rassociator_post. apply rwhisker_rwhisker. - apply (!vcomp_whisker _ _ ). - apply lunitor_linvunitor. - apply linvunitor_lunitor. - apply runitor_rinvunitor. - apply rinvunitor_runitor. - apply lassociator_rassociator. - apply rassociator_lassociator. - use lhs_left_invert_cell. { use is_invertible_2cell_rwhisker. apply is_invertible_2cell_rinvunitor. } cbn. apply pathsinv0. use lhs_right_invert_cell. { use is_invertible_2cell_lwhisker. apply is_invertible_2cell_linvunitor. } cbn. apply pathsinv0. apply lassociator_to_rassociator_pre. apply pathsinv0, runitor_rwhisker. - use lhs_left_invert_cell. { use is_invertible_2cell_rwhisker. apply is_invertible_2cell_rassociator. } cbn. apply pathsinv0. etrans. { apply vassocr. } use lhs_right_invert_cell. { apply is_invertible_2cell_rassociator. } cbn. use lhs_right_invert_cell. { apply is_invertible_2cell_rassociator. } cbn. apply pathsinv0. repeat rewrite <- vassocr. use lhs_left_invert_cell. { apply is_invertible_2cell_rassociator. } cbn. use lhs_left_invert_cell. { apply is_invertible_2cell_lwhisker. apply is_invertible_2cell_rassociator. } cbn. apply pathsinv0. rewrite vassocr. apply lassociator_lassociator. Qed. Definition op2_prebicat : prebicat := op2_prebicat_data ,, op2_prebicat_laws. Definition op2_bicat : bicat. Proof. refine (op2_prebicat ,, _). intro ; intros. apply cellset_property. Defined. End OpCell. Definition from_op2_is_invertible_2cell {B : bicat} {x y : op2_bicat B} {f g : x --> y} {α : f ==> g} (Hα : is_invertible_2cell α) : @is_invertible_2cell B x y g f α. Proof. use make_is_invertible_2cell. - exact (Hα^-1). - exact (vcomp_linv Hα). - exact (vcomp_rinv Hα). Defined. Definition to_op2_is_invertible_2cell {B : bicat} {x y : op2_bicat B} {f g : x --> y} {α : f ==> g} (Hα : @is_invertible_2cell B x y g f α) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (Hα^-1). - exact (vcomp_linv Hα). - exact (vcomp_rinv Hα). Defined. Definition weq_op2_is_invertible_2cell {B : bicat} {x y : op2_bicat B} {f g : x --> y} (α : f ==> g) : @is_invertible_2cell B x y g f α ≃ is_invertible_2cell α. Proof. use weqimplimpl. - exact to_op2_is_invertible_2cell. - exact from_op2_is_invertible_2cell. - apply isaprop_is_invertible_2cell. - apply isaprop_is_invertible_2cell. Defined. Definition weq_op2_invertible_2cell {B : bicat} {x y : op2_bicat B} (f g : x --> y) : @invertible_2cell B x y g f ≃ invertible_2cell f g. Proof. use weqfibtototal. intro α. apply weq_op2_is_invertible_2cell. Defined. Definition from_op2_left_adjequiv {B : bicat} {x y : op2_bicat B} (f : x --> y) : left_adjoint_equivalence f → @left_adjoint_equivalence B x y f. Proof. intros Hf. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (left_adjoint_right_adjoint Hf). - exact ((left_equivalence_unit_iso Hf)^-1). - exact ((left_equivalence_counit_iso Hf)^-1). - abstract (use inv_cell_eq ; cbn ; [ is_iso ; [ apply from_op2_is_invertible_2cell ; is_iso | apply from_op2_is_invertible_2cell ; is_iso ] | is_iso | exact (internal_triangle1 Hf) ]). - abstract (use inv_cell_eq ; cbn ; [ is_iso ; [ apply from_op2_is_invertible_2cell ; is_iso | apply from_op2_is_invertible_2cell ; is_iso ] | is_iso | exact (internal_triangle2 Hf) ]). - cbn. apply from_op2_is_invertible_2cell. is_iso. - cbn. apply from_op2_is_invertible_2cell. is_iso. Defined. Definition to_op2_left_adjequiv {B : bicat} {x y : op2_bicat B} (f : x --> y) : @left_adjoint_equivalence B x y f → left_adjoint_equivalence f. Proof. intros Hf. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (left_adjoint_right_adjoint Hf). - exact ((left_equivalence_unit_iso Hf)^-1). - exact ((left_equivalence_counit_iso Hf)^-1). - abstract (use inv_cell_eq ; cbn ; [ apply to_op2_is_invertible_2cell ; is_iso | apply to_op2_is_invertible_2cell ; is_iso | exact (internal_triangle1 Hf) ]). - abstract (use inv_cell_eq ; cbn ; [ apply to_op2_is_invertible_2cell ; is_iso | apply to_op2_is_invertible_2cell ; is_iso | exact (internal_triangle2 Hf)]). - cbn. apply to_op2_is_invertible_2cell. is_iso. - cbn. apply to_op2_is_invertible_2cell. is_iso. Defined. Definition weq_op2_left_adjequiv {B : bicat} {x y : op2_bicat B} (f : x --> y) : @left_adjoint_equivalence B x y f ≃ left_adjoint_equivalence f. Proof. use make_weq. - exact (to_op2_left_adjequiv f). - use isweq_iso. + exact (from_op2_left_adjequiv f). + abstract (intros Hf ; refine (maponpaths (λ z, _ ,, z) _) ; apply isapropdirprod ; [ apply isapropdirprod ; apply cellset_property | apply isapropdirprod ; apply isaprop_is_invertible_2cell ]). + abstract (intros Hf ; refine (maponpaths (λ z, _ ,, z) _) ; apply isapropdirprod ; [ apply isapropdirprod ; apply cellset_property | apply isapropdirprod ; apply isaprop_is_invertible_2cell ]). Defined. Definition weq_op2_adjequiv {B : bicat} (x y : op2_bicat B) : @adjoint_equivalence B x y ≃ adjoint_equivalence x y. Proof. use weqfibtototal. intro α. apply weq_op2_left_adjequiv. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/OpFibSlice.v000066400000000000000000000456061451125700300241030ustar00rootroot00000000000000(********************************************************************************* The opfibrational slice bicategory In this file, we define the opfibrational slice bicategory. More specifically, given a *univalent* category `C`, we define the opfibrational slice bicategory as follows: - Objects: (cloven) opfibrations over `C` - 1-cells: opcartesian functors making a triangle commute - 2-cells: natural transformations that satisfy some equality We also prove that this bicategory is univalent. For this, we need that the category `C` is univalent. In addition, we use the structure identity principle for displayed categories, which says that two displayed categories are equal if and only if we have an adjoint equivalence between them. Contents 1. The opfibrational slice bicategory 2. Invertible 2-cells in the opfibrational slice bicategory 3. Local univalence of the opfibrational slice bicategory 4. Adjoint equivalences in the opfibrational slice bicategory 5. Global univalence of the opfibrational slice bicategory *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedFunctorEq. Require Import UniMath.CategoryTheory.DisplayedCats.EquivalenceOverId. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedCatEq. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section OpFibSlice. Context (C : univalent_category). (** 1. The opfibrational slice bicategory *) Definition opfib_slice_precategory_ob_mor : precategory_ob_mor. Proof. simple refine (_ ,, _). - exact (∑ (D : disp_univalent_category C), opcleaving D). - exact (λ D₁ D₂, opcartesian_disp_functor (functor_identity _) (pr1 D₁) (pr1 D₂)). Defined. Definition opfib_slice_precategory_id_comp : precategory_id_comp opfib_slice_precategory_ob_mor. Proof. simple refine (_ ,, _). - exact (λ D, disp_functor_identity (pr1 D) ,, disp_functor_identity_is_opcartesian_disp_functor (pr1 D)). - exact (λ D₁ D₂ D₃ FF GG, disp_functor_over_id_composite (pr1 FF) (pr1 GG) ,, disp_functor_over_id_composite_is_opcartesian (pr2 FF) (pr2 GG)). Defined. Definition opfib_slice_precategory_data : precategory_data. Proof. simple refine (_ ,, _). - exact opfib_slice_precategory_ob_mor. - exact opfib_slice_precategory_id_comp. Defined. Definition opfib_slice_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. simple refine (_ ,, _). - exact opfib_slice_precategory_data. - exact (λ D₁ D₂ FF GG, disp_nat_trans (nat_trans_id _) (pr1 FF) (pr1 GG)). Defined. Definition opfib_slice_prebicat_2_id_comp_struct : prebicat_2_id_comp_struct opfib_slice_prebicat_1_id_comp_cells. Proof. repeat split. - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ FF, disp_nat_trans_id (pr1 FF)). - exact (λ D₁ D₂ D₃ D₃ FF GG HH, disp_nat_trans_id _). - exact (λ D₁ D₂ D₃ D₃ FF GG HH, disp_nat_trans_id _). - exact (λ D₁ D₂ FF GG HH α β, disp_nat_trans_over_id_comp α β). - exact (λ D₁ D₂ D₃ FF GG₁ GG₂ α, disp_nat_trans_over_id_prewhisker (pr1 FF) α). - exact (λ D₁ D₂ D₃ FF₁ FF₂ GG α, disp_nat_trans_over_id_postwhisker (pr1 GG) α). Defined. Definition opfib_slice_prebicat_data : prebicat_data. Proof. simple refine (_ ,, _). - exact opfib_slice_prebicat_1_id_comp_cells. - exact opfib_slice_prebicat_2_id_comp_struct. Defined. Definition opfib_slice_prebicat_laws : prebicat_laws opfib_slice_prebicat_data. Proof. repeat split. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. apply idpath. - intros ? ? ? F G ; use disp_nat_trans_eq ; intros ; cbn. exact (disp_functor_id (pr1 G) _). - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. apply idpath. - intros D₁ D₂ D₃ FF₁ FF₂ FF₃ GG α β. use disp_nat_trans_eq ; intros x xx ; cbn. rewrite (disp_functor_transportf _ (pr1 GG)). rewrite disp_functor_comp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ FF GG HH II α β. use disp_nat_trans_eq ; intros x xx ; cbn in *. etrans. { apply maponpaths. exact (disp_nat_trans_ax β (α x xx)). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intro ; intros ; use disp_nat_trans_eq ; intros ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply transportf_set. apply homset_property. - intros D₁ D₂ D₃ F G. use disp_nat_trans_eq ; intros x xx ; cbn. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite (disp_functor_id (pr1 G)). cbn. apply transportf_set. apply homset_property. - intros D₁ D₂ D₃ D₄ D₅ FF GG HH II. use disp_nat_trans_eq ; intros ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite !id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. rewrite (disp_functor_id (pr1 II)). unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition opfib_slice_prebicat : prebicat. Proof. simple refine (_ ,, _). - exact opfib_slice_prebicat_data. - exact opfib_slice_prebicat_laws. Defined. Definition opfib_slice_bicat : bicat. Proof. simple refine (_ ,, _). - exact opfib_slice_prebicat. - intro ; intros. apply isaset_disp_nat_trans. Defined. (** 2. Invertible 2-cells in the opfibrational slice bicategory *) Definition is_invertible_2cell_opfib_slice {D₁ D₂ : opfib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (α : G₁ ==> G₂) (Hα : is_disp_nat_z_iso (nat_z_iso_id (functor_identity C)) α) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (pointwise_inverse_disp_nat_trans α Hα). - apply pointwise_inverse_disp_nat_trans_over_id_left. - apply pointwise_inverse_disp_nat_trans_over_id_right. Defined. Definition disp_nat_z_iso_to_inv2cell_opfib {D₁ D₂ : opfib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (τ : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id (functor_identity C))) : invertible_2cell G₁ G₂. Proof. use make_invertible_2cell. - exact (pr1 τ). - apply is_invertible_2cell_opfib_slice. exact (pr2 τ). Defined. Definition from_is_invertible_2cell_opfib_slice {D₁ D₂ : opfib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (α : G₁ ==> G₂) (Hα : is_invertible_2cell α) : is_disp_nat_z_iso (nat_z_iso_id (functor_identity C)) α. Proof. intros x xx. simple refine (_ ,, _ ,, _). - exact (pr1 (Hα^-1) x xx). - abstract (use transportb_transpose_right ; refine (_ @ maponpaths (λ z, pr1 z x xx) (vcomp_linv Hα)) ; cbn ; apply maponpaths_2 ; apply homset_property). - abstract (use transportb_transpose_right ; refine (_ @ maponpaths (λ z, pr1 z x xx) (vcomp_rinv Hα)) ; cbn ; apply maponpaths_2 ; apply homset_property). Defined. Definition inv2cell_to_disp_nat_z_iso_opfib {D₁ D₂ : opfib_slice_bicat} {G₁ G₂ : D₁ --> D₂} (τ : invertible_2cell G₁ G₂) : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id (functor_identity C)) := pr1 τ ,, from_is_invertible_2cell_opfib_slice (pr1 τ) (pr2 τ). Definition invertible_2cell_opfib_slice_weq {D₁ D₂ : opfib_slice_bicat} (G₁ G₂ : D₁ --> D₂) : disp_nat_z_iso (pr1 G₁) (pr1 G₂) (nat_z_iso_id _) ≃ invertible_2cell G₁ G₂. Proof. use weq_iso. - exact disp_nat_z_iso_to_inv2cell_opfib. - exact inv2cell_to_disp_nat_z_iso_opfib. - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_is_disp_nat_z_iso | ] ; apply idpath). - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). Defined. (** 3. Local univalence of the opfibrational slice bicategory *) Proposition is_univalent_2_1_opfib_slice_bicat : is_univalent_2_1 opfib_slice_bicat. Proof. intros D₁ D₂ F G. use weqhomot. - refine (invertible_2cell_opfib_slice_weq F G ∘ disp_functor_eq_weq (pr1 F) (pr1 G) (pr1 D₂) ∘ path_sigma_hprop _ _ _ _)%weq. apply isaprop_is_opcartesian_disp_functor. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; use disp_nat_trans_eq ; intros x xx ; cbn ; apply idpath). Defined. (** 4. Adjoint equivalences in the opfibrational slice bicategory *) Definition left_adjoint_equivalence_opfib_slice {D₁ D₂ : opfib_slice_bicat} (F : D₁ --> D₂) (HF : is_equiv_over_id (pr1 F)) : left_adjoint_equivalence F. Proof. use equiv_to_adjequiv. simple refine (((_ ,, _) ,, (_ ,, _)) ,, _ ,, _). - exact HF. - exact (is_opcartesian_equiv_over_id (equiv_inv _ HF)). - exact (unit_over_id HF). - exact (counit_over_id HF). - use is_invertible_2cell_opfib_slice. intros x xx. exact (is_z_iso_unit_over_id HF x xx). - use is_invertible_2cell_opfib_slice. intros x xx. exact (is_z_iso_counit_over_id HF x xx). Defined. Definition adj_equiv_opfib_slice {D₁ D₂ : opfib_slice_bicat} (F : disp_functor (functor_identity C) (pr1 D₁) (pr1 D₂)) (HF : is_equiv_over_id F) : adjoint_equivalence D₁ D₂. Proof. simple refine ((F ,, _) ,, _). - exact (is_opcartesian_equiv_over_id HF). - exact (left_adjoint_equivalence_opfib_slice (_ ,, _) HF). Defined. Proposition from_left_adjoint_equivalence_opfib_slice {D₁ D₂ : opfib_slice_bicat} (F : D₁ --> D₂) (HF : left_adjoint_equivalence F) : is_equiv_over_id (pr1 F). Proof. simple refine (((_ ,, (_ ,, _)) ,, (_ ,, _)) ,, (_ ,, _)). - exact (pr1 (left_adjoint_right_adjoint HF)). - exact (left_adjoint_unit HF). - exact (left_adjoint_counit HF). - abstract (intros x xx ; cbn ; pose (p := maponpaths (λ z, pr1 z x xx) (internal_triangle1 HF)) ; cbn in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; rewrite id_left_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; refine (transportb_transpose_right p @ _) ; apply maponpaths_2 ; apply homset_property). - abstract (intros x xx ; cbn ; pose (p := maponpaths (λ z, pr1 z x xx) (internal_triangle2 HF)) ; cbn in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite transport_f_f in p ; rewrite id_right_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; rewrite id_left_disp in p ; unfold transportb in p ; rewrite mor_disp_transportf_postwhisker in p ; rewrite transport_f_f in p ; refine (transportb_transpose_right p @ _) ; apply maponpaths_2 ; apply homset_property). - intros x xx. exact (from_is_invertible_2cell_opfib_slice _ (pr122 HF) x xx). - intros x xx. exact (from_is_invertible_2cell_opfib_slice _ (pr222 HF) x xx). Defined. Definition adj_equiv_opfib_slice_weq (D₁ D₂ : opfib_slice_bicat) : (∑ (F : disp_functor (functor_identity C) (pr1 D₁) (pr1 D₂)), is_equiv_over_id F) ≃ adjoint_equivalence D₁ D₂. Proof. use weq_iso. - exact (λ F, adj_equiv_opfib_slice (pr1 F) (pr2 F)). - exact (λ F, pr11 F ,, from_left_adjoint_equivalence_opfib_slice _ (pr2 F)). - abstract (intros F ; use subtypePath ; [ intro ; apply (isaprop_is_equiv_over_id (pr1 D₁) (pr1 D₂)) | ] ; apply idpath). - abstract (intro F ; use subtypePath ; [ intro ; apply (isaprop_left_adjoint_equivalence _ is_univalent_2_1_opfib_slice_bicat) | ] ; use subtypePath ; [ intro ; apply isaprop_is_opcartesian_disp_functor | ] ; cbn ; apply idpath). Defined. (** 5. Global univalence of the opfibrational slice bicategory *) Proposition is_univalent_2_0_opfib_slice_bicat : is_univalent_2_0 opfib_slice_bicat. Proof. intros D₁ D₂. use weqhomot. - refine (adj_equiv_opfib_slice_weq D₁ D₂ ∘ disp_cat_eq (pr1 D₁) (pr1 D₂) (pr1 D₁) (pr1 D₂) ∘ path_sigma_hprop _ _ _ _ ∘ path_sigma_hprop _ _ _ _)%weq. + apply isaprop_opcleaving. apply (pr1 D₂). + apply isaprop_is_univalent_disp. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply (isaprop_left_adjoint_equivalence _ is_univalent_2_1_opfib_slice_bicat) | ] ; use subtypePath ; [ intro ; apply isaprop_is_opcartesian_disp_functor | ] ; apply idpath). Defined. Proposition is_univalent_2_opfib_slice_bicat : is_univalent_2 opfib_slice_bicat. Proof. split. - exact is_univalent_2_0_opfib_slice_bicat. - exact is_univalent_2_1_opfib_slice_bicat. Defined. End OpFibSlice. UniMath-20231010/UniMath/Bicategories/Core/Examples/OpMorBicat.v000066400000000000000000000173301451125700300241140ustar00rootroot00000000000000(* *********************************************************************************** *) (** op1 bicategory. Bicategory obtained by formally reversing 1-arrows. Benedikt Ahrens, Marco Maggesi June 2018 *) (* *********************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Local Open Scope cat. Definition op1_2cell_struct (C : prebicat_1_id_comp_cells) : prebicat_2cell_struct (opp_precat_data C) := λ (a b : C) (f g : C ⟦ b, a ⟧), f ==> g. Definition op1_prebicat_1_id_comp_cells (C : prebicat_1_id_comp_cells) : prebicat_1_id_comp_cells := (opp_precat_data C),, op1_2cell_struct C. Definition op1_prebicat_data (C : prebicat_data) : prebicat_data. Proof. exists (op1_prebicat_1_id_comp_cells C). red. cbn. unfold op1_2cell_struct. repeat use make_dirprod; intros *. - apply id2. - apply runitor. - apply lunitor. - apply rinvunitor. - apply linvunitor. - apply lassociator. - apply rassociator. - intros α β. exact ( α • β ). - intros α. exact (α ▹ f). - intros α. exact (g ◃ α). Defined. Lemma op1_prebicat_laws (C : prebicat) : prebicat_laws (op1_prebicat_data C). Proof. red. cbn. unfold op1_2cell_struct. cbn. repeat use tpair; cbn; intros *. - apply id2_left. - apply id2_right. - apply vassocr. - apply id2_rwhisker. - apply lwhisker_id2. - apply rwhisker_vcomp. - apply lwhisker_vcomp. - apply vcomp_runitor. - apply vcomp_lunitor. - apply rwhisker_rwhisker_alt. - apply pathsinv0, rwhisker_lwhisker_rassociator. - apply lwhisker_lwhisker_rassociator. - apply pathsinv0, vcomp_whisker. - apply runitor_rinvunitor. - apply rinvunitor_runitor. - apply lunitor_linvunitor. - apply linvunitor_lunitor. - apply rassociator_lassociator. - apply lassociator_rassociator. - apply lunitor_lwhisker. - apply rassociator_rassociator. Qed. Definition op1_prebicat (C : prebicat) : prebicat := op1_prebicat_data C,, op1_prebicat_laws C. Definition op1_isaset_cells (C : bicat) : isaset_cells (op1_prebicat C) := λ (a b : C) (f g : C ⟦ b, a ⟧), cellset_property f g. Definition op1_bicat (C : bicat) : bicat := op1_prebicat C,, op1_isaset_cells C. Definition op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell {C : bicat} {X Y : op1_bicat C} {f g : X --> Y} (α : f ==> g) : is_invertible_2cell α → @is_invertible_2cell C Y X f g α. Proof. intros Hα. use tpair. - apply Hα. - split ; apply Hα. Defined. Definition bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell {C : bicat} {X Y : op1_bicat C} {f g : X --> Y} (α : f ==> g) : @is_invertible_2cell C Y X f g α → is_invertible_2cell α. Proof. intros Hα. use tpair. - apply Hα. - split ; apply Hα. Defined. Definition op1_bicat_is_invertible_2cell_is_bicat_is_invertible_2cell {C : bicat} {X Y : op1_bicat C} {f g : X --> Y} (α : f ==> g) : @is_invertible_2cell C Y X f g α ≃ is_invertible_2cell α. Proof. use weqimplimpl. - exact (bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell α). - exact (op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell α). - apply isaprop_is_invertible_2cell. - apply isaprop_is_invertible_2cell. Defined. Definition bicat_invertible_2cell_is_op1_bicat_invertible_2cell {C : bicat} {X Y : op1_bicat C} (f g : X --> Y) : @invertible_2cell C Y X f g ≃ invertible_2cell f g. Proof. use weqfibtototal. intro α. apply op1_bicat_is_invertible_2cell_is_bicat_is_invertible_2cell. Defined. Definition op1_bicat_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence {C : bicat} {X Y : op1_bicat C} (f : X --> Y) : left_adjoint_equivalence f → @left_adjoint_equivalence C Y X f. Proof. intros Hf. use tpair. - use tpair. + exact (left_adjoint_right_adjoint Hf). + split. * exact ((left_equivalence_counit_iso Hf)^-1). * exact ((left_equivalence_unit_iso Hf)^-1). - split ; split. + use inv_cell_eq ; cbn. * is_iso. ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. * is_iso. * cbn. rewrite !vassocr. exact (internal_triangle1 Hf). + use inv_cell_eq ; cbn. * is_iso. ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. * is_iso. * cbn. rewrite !vassocr. exact (internal_triangle2 Hf). + cbn. apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. + cbn. apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell. is_iso. Defined. Definition bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence {C : bicat} {X Y : op1_bicat C} (f : X --> Y) : @left_adjoint_equivalence C Y X f → left_adjoint_equivalence f. Proof. intros Hf. use tpair. - use tpair. + exact (left_adjoint_right_adjoint Hf). + split. * exact ((left_equivalence_counit_iso Hf)^-1). * exact ((left_equivalence_unit_iso Hf)^-1). - split ; split. + use inv_cell_eq ; cbn. * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. * cbn. rewrite !vassocr. exact (internal_triangle1 Hf). + use inv_cell_eq ; cbn. * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. * cbn. rewrite !vassocr. exact (internal_triangle2 Hf). + cbn. apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. + cbn. apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell. is_iso. Defined. Definition op1_bicat_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence {C : bicat} {X Y : op1_bicat C} (f : X --> Y) : @left_adjoint_equivalence C Y X f ≃ left_adjoint_equivalence f. Proof. use make_weq. - exact (bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence f). - use isweq_iso. + exact (op1_bicat_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence f). + intros x. use subtypePath. * intro. do 2 apply isapropdirprod ; try (apply C) ; apply isaprop_is_invertible_2cell. * apply idpath. + intros x. use subtypePath. * intro. do 2 apply isapropdirprod ; try (apply C) ; apply isaprop_is_invertible_2cell. * apply idpath. Defined. Definition bicat_adjoint_equivalence_is_op1_bicat_adjoint_equivalence {C : bicat} (X Y : op1_bicat C) : @adjoint_equivalence C Y X ≃ adjoint_equivalence X Y. Proof. use weqfibtototal. intro α. apply op1_bicat_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/PointedOneTypesBicat.v000066400000000000000000000131021451125700300261420ustar00rootroot00000000000000Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. (** The bicategory *) Definition pointed_one_type_bicat_data : prebicat_data. Proof. use build_prebicat_data. - exact (∑ (X : one_type), X). - exact (λ X Y, ∑ (f : pr1 X → pr1 Y), f (pr2 X) = pr2 Y). - exact (λ X Y f g, ∑ (h : pr1 f = pr1 g), transportf (λ φ, φ (pr2 X) = pr2 Y) h (pr2 f) = pr2 g). - exact (λ X, (λ x, x) ,, idpath _). - exact (λ X Y Z f g, (λ x,pr1 g(pr1 f x)) ,, maponpaths (pr1 g) (pr2 f) @ pr2 g). - exact (λ X Y f, idpath _ ,, idpath _). - refine (λ X Y f g h p q, (pr1 p @ pr1 q) ,, _) ; cbn in *. exact (!(transport_f_f _ _ _ _) @ maponpaths _ (pr2 p) @ pr2 q). - refine (λ X Y Z f g h p, (maponpaths (λ φ x, φ (pr1 f x)) (pr1 p)) ,, _) ; cbn in *. induction g as [g1 g2], h as [h1 h2], p as [p1 p2] ; cbn in *. induction p1, p2 ; cbn. apply idpath. - refine (λ X Y Z f g h p, (maponpaths (λ φ x, pr1 h (φ x)) (pr1 p)) ,, _) ; cbn in *. induction g as [g1 g2], h as [h1 h2], p as [p1 p2] ; cbn in *. induction p1, p2 ; cbn. apply idpath. - exact (λ X Y f, idpath _ ,, idpath _). - exact (λ X Y f, idpath _ ,, idpath _). - refine (λ X Y f, idpath _ ,, _) ; cbn in *. exact (pathscomp0rid _ @ maponpathsidfun _). - refine (λ X Y f, idpath _ ,, _) ; cbn in *. exact (!(pathscomp0rid _ @ maponpathsidfun _)). - refine (λ W X Y Z f g h, idpath _ ,, _) ; cbn in *. refine (path_assoc _ _ _ @ _). apply maponpaths_2. refine (_ @ !(maponpathscomp0 _ _ _)). apply maponpaths_2. exact (!(maponpathscomp _ _ _)). - refine (λ W X Y Z f g h, idpath _ ,, ! _) ; cbn in *. refine (path_assoc _ _ _ @ _). apply maponpaths_2. refine (_ @ !(maponpathscomp0 _ _ _)). apply maponpaths_2. exact (!(maponpathscomp _ _ _)). Defined. Lemma pointed_one_type_bicat_laws : prebicat_laws pointed_one_type_bicat_data. Proof. repeat (use tpair). - intros X Y f g p ; cbn in *. induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *. induction p1 ; cbn. apply idpath. - intros X Y f g p ; cbn in *. induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *. induction p1, p2 ; cbn. apply idpath. - intros X Y f g h k p q r ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], k as [k1 k2]. induction p as [p1 p2], q as [q1 q2], r as [r1 r2] ; cbn in *. induction p1, p2, q1, q2, r1, r2. apply idpath. - intros; apply idpath. - intros; apply idpath. - intros X Y Z f g h i p q ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2], q as [q1 q2] ; cbn in *. induction p1, p2, q1, q2 ; cbn. apply idpath. - intros X Y Z f g h i p q ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2], q as [q1 q2] ; cbn in *. induction p1, p2, q1, q2 ; cbn. apply idpath. - intros X Y f g p ; cbn in *. induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *. induction p1, p2 ; cbn. apply idpath. - intros X Y f g p ; cbn in *. induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *. induction p1, p2, f2 ; cbn. apply idpath. - intros W X Y Z f g h i p ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2] ; cbn in *. induction p1, p2, f2, g2, h2 ; cbn. apply idpath. - intros W X Y Z f g h i p ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2] ; cbn in *. induction p1, p2, f2, g2 ; cbn. apply idpath. - intros W X Y Z f g h i p ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2] ; cbn in *. induction p1, p2, f2, h2 ; cbn. apply idpath. - intros X Y Z f g h i p q ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2]. induction p as [p1 p2], q as [q1 q2] ; cbn in *. induction p1, p2, q1, q2, f2, h2 ; cbn. apply idpath. - intros; apply idpath. - intros; apply idpath. - intros X Y p ; cbn in *. induction p as [p1 p2]. induction p2 ; cbn. apply idpath. - intros X Y p ; cbn in *. induction p as [p1 p2]. induction p2 ; cbn. apply idpath. - intros W X Y Z f g h ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2] ; cbn in *. induction f2, g2, h2 ; cbn. apply idpath. - intros W X Y Z f g h ; cbn in *. induction f as [f1 f2], g as [g1 g2], h as [h1 h2] ; cbn in *. induction f2, g2, h2 ; cbn. apply idpath. - intros X Y Z f g ; cbn in *. induction f as [f1 f2], g as [g1 g2] ; cbn in *. induction f2, g2 ; cbn. apply idpath. - intros V W X Y Z f g h i. induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2] ; cbn in *. induction f2, g2, h2, i2 ; cbn. apply idpath. Qed. Definition pointed_one_types : bicat. Proof. use build_bicategory. - exact pointed_one_type_bicat_data. - exact pointed_one_type_bicat_laws. - intros X Y f g ; cbn in *. use isaset_total2. + exact (impredfun 3 (pr1 X) (pr1 Y) (pr21 Y) (pr1 f) (pr1 g)). + intro ; cbn. repeat intro. apply hlevelntosn. apply (pr21 Y). Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/StrictCats.v000066400000000000000000000205471451125700300242040ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategory of strict categories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.CategoryEquality. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Strictness. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Definition strict_cat_prebicat_data : prebicat_data. Proof. use build_prebicat_data. - exact setcategory. - exact (λ C D, functor C D). - exact (λ _ _ F G, nat_trans F G). - exact (λ C, functor_identity C). - exact (λ _ _ _ F G, functor_composite F G). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ α β, nat_trans_comp _ _ _ α β). - exact (λ _ _ _ F _ _ α, pre_whisker F α). - exact (λ _ _ _ _ _ H α, post_whisker α H). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ F, nat_trans_id F). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). - exact (λ _ _ _ _ _ _ _, nat_trans_id _). Defined. Lemma strict_cat_prebicat_laws : prebicat_laws strict_cat_prebicat_data. Proof. repeat split; cbn. - intros C D F G η. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F G η. apply nat_trans_eq; try apply D. intros ; cbn. apply id_right. - intros C D F₁ F₂ F₃ F₄ α β γ. apply nat_trans_eq; try apply D. intros ; cbn. apply assoc. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intros; apply idpath. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intros ; cbn. apply functor_id. - intros C₁ C₂ C₃ F G₁ G₂ G₃ α β. apply nat_trans_eq; try apply C₃. intros; apply idpath. - intros C₁ C₂ C₃ F₁ F₂ F₃ G α β. apply nat_trans_eq; try apply C₃. intros ; cbn. exact (!(functor_comp G _ _)). - intros C D F G α. apply nat_trans_eq; try apply D. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C D F G α. apply nat_trans_eq; try apply D. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G H₁ H₂ α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F G₁ G₂ H α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ C₄ F₁ F₂ G H α. apply nat_trans_eq; try apply C₄. intros ; cbn. rewrite id_left, id_right. apply idpath. - intros C₁ C₂ C₃ F₁ F₂ G₁ H₂ α β. apply nat_trans_eq; try apply C₃. intros ; cbn. exact ((nat_trans_ax β _ _ _)). - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C D F. apply nat_trans_eq; try apply D. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply C₄. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃. apply nat_trans_eq; try apply C₄. intros ; cbn. apply id_left. - intros C₁ C₂ C₃ F G. apply nat_trans_eq; try apply C₃. intros ; cbn. exact (id_left _ @ functor_id G _). - intros C₁ C₂ C₃ C₄ C₅ F₁ F₂ F₃ F₄. apply nat_trans_eq; try apply C₅. intros ; cbn. rewrite !id_left. exact (functor_id F₄ _). Qed. Definition prebicat_of_strict_cats : prebicat := _ ,, strict_cat_prebicat_laws. Lemma isaset_cells_prebicat_of_strict_cats : isaset_cells prebicat_of_strict_cats. Proof. intros a b f g. apply isaset_nat_trans. apply homset_property. Qed. Definition bicat_of_strict_cats : bicat := (prebicat_of_strict_cats,, isaset_cells_prebicat_of_strict_cats). Definition is_invertible_2cell_bicat_of_strict_cat {C₁ C₂ : bicat_of_strict_cats} {F G : C₁ --> C₂} (α : F ==> G) (Hα : is_nat_z_iso (pr1 α)) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (pr1 (nat_z_iso_inv (make_nat_z_iso _ _ α Hα))). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; exact (z_iso_inv_after_z_iso (make_z_iso _ _ (Hα x)))). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; exact (z_iso_after_z_iso_inv (make_z_iso _ _ (Hα x)))). Defined. Definition from_is_invertible_2cell_bicat_of_strict_cat {C₁ C₂ : bicat_of_strict_cats} {F G : C₁ --> C₂} (α : F ==> G) (Hα : is_invertible_2cell α) : is_nat_z_iso (pr1 α). Proof. intros x. use make_is_z_isomorphism. - exact (pr1 (Hα^-1) x). - abstract (split ; [ exact (nat_trans_eq_pointwise (vcomp_rinv Hα) x) | exact (nat_trans_eq_pointwise (vcomp_linv Hα) x) ]). Defined. Lemma idtoiso_2_1_strict_cat_help {c d : bicat_of_strict_cats} {f : functor_data (pr1 c) (pr1 d)} {Hf Hf' : is_functor f} (p : Hf = Hf') (x : pr1 c) : pr11 (@idtoiso_2_1 bicat_of_strict_cats _ _ _ _ (maponpaths (λ z, f ,, z) p)) x = id₁ (f x). Proof. induction p. apply idpath. Qed. Lemma idtoiso_2_1_strict_cat {c d : bicat_of_strict_cats} {f g : functor (pr1 c) (pr1 d)} (p : pr1 f = pr1 g) (x : pr1 c) : pr11 (@idtoiso_2_1 bicat_of_strict_cats _ _ f g (functor_eq _ _ (isaset_mor d) f g p)) x = idtoiso (maponpaths (λ q, pr1 q x) p). Proof. induction f as [f Hf]. induction g as [g Hg]. simpl in *. induction p. apply idtoiso_2_1_strict_cat_help. Qed. Lemma bicat_of_strict_cats_is_strict_bicat : is_strict_bicat bicat_of_strict_cats. Proof. use make_is_strict_bicat. - intros c d. repeat use isaset_total2. + apply funspace_isaset. apply d. + intro f ; simpl. repeat (use impred_isaset ; intro). apply (isaset_mor d). + intro. apply isasetaprop. apply isaprop_is_functor. apply d. - repeat use tpair. + intros c d f. use functor_eq. { apply d. } apply idpath. + intros c d f. use functor_eq. { apply d. } apply idpath. + intros a b c d f g h. use functor_eq. { apply d. } apply idpath. + intros c d f. use nat_trans_eq. { apply d. } intro x. etrans. { apply idtoiso_2_1_strict_cat. } apply idpath. + intros c d f. use nat_trans_eq. { apply d. } intro x. etrans. { apply idtoiso_2_1_strict_cat. } apply idpath. + intros a b c d f g h. use nat_trans_eq. { apply d. } intro x. etrans. { apply idtoiso_2_1_strict_cat. } apply idpath. Qed. Definition strict_bicat_of_strict_cats : strict_bicat. Proof. use tpair. - exact bicat_of_strict_cats. - exact bicat_of_strict_cats_is_strict_bicat. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/StructuredCategories.v000066400000000000000000000311741451125700300262710ustar00rootroot00000000000000(*********************************************************************************** Bicategories of categories with structure We define a number of bicategories whose objects are categories with a certain structure and whose 1-cells are functors preserving that structure. The 2-cells are just natural transformations. Contents 1. Categories with a terminal object 2. Categories with binary products 3. Categories with pullbacks 4. Categories with finite limits 5. Categories with an initial object 6. Categories with binary coproducts ***********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Local Open Scope cat. (** 1. Categories with a terminal object *) Definition disp_bicat_terminal_obj : disp_bicat bicat_of_univ_cats. Proof. use disp_subbicat. - exact (λ C, Terminal (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_terminal F). - exact (λ C _, identity_preserves_terminal _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_terminal HF HG). Defined. Definition univ_cat_with_terminal_obj : bicat := total_bicat disp_bicat_terminal_obj. Definition disp_univalent_2_1_disp_bicat_terminal_obj : disp_univalent_2_1 disp_bicat_terminal_obj. Proof. use disp_subbicat_univalent_2_1. intros. apply isaprop_preserves_terminal. Qed. Definition disp_univalent_2_0_disp_bicat_terminal_obj : disp_univalent_2_0 disp_bicat_terminal_obj. Proof. use disp_subbicat_univalent_2_0. - exact univalent_cat_is_univalent_2. - intro C. apply isaprop_Terminal. exact (pr2 C). - intros. apply isaprop_preserves_terminal. Qed. Definition disp_univalent_2_disp_bicat_terminal_obj : disp_univalent_2 disp_bicat_terminal_obj. Proof. split. - exact disp_univalent_2_0_disp_bicat_terminal_obj. - exact disp_univalent_2_1_disp_bicat_terminal_obj. Defined. Definition is_univalent_2_1_univ_cat_with_terminal_obj : is_univalent_2_1 univ_cat_with_terminal_obj. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_terminal_obj. Defined. Definition is_univalent_2_0_univ_cat_with_terminal_obj : is_univalent_2_0 univ_cat_with_terminal_obj. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_terminal_obj. Defined. Definition is_univalent_2_univ_cat_with_terminal_obj : is_univalent_2 univ_cat_with_terminal_obj. Proof. split. - exact is_univalent_2_0_univ_cat_with_terminal_obj. - exact is_univalent_2_1_univ_cat_with_terminal_obj. Defined. (** 2. Categories with binary products *) Definition disp_bicat_binprod : disp_bicat bicat_of_univ_cats. Proof. use disp_subbicat. - exact (λ C, BinProducts (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_binproduct F). - exact (λ C _, identity_preserves_binproduct _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_binproduct HF HG). Defined. Definition univ_cat_with_binprod : bicat := total_bicat disp_bicat_binprod. Definition disp_univalent_2_1_disp_bicat_binprod : disp_univalent_2_1 disp_bicat_binprod. Proof. use disp_subbicat_univalent_2_1. intros. apply isaprop_preserves_binproduct. Qed. Definition disp_univalent_2_0_disp_bicat_binprod : disp_univalent_2_0 disp_bicat_binprod. Proof. use disp_subbicat_univalent_2_0. - exact univalent_cat_is_univalent_2. - intro C. use impred ; intro x. use impred ; intro y. use isaprop_BinProduct. exact (pr2 C). - intros. apply isaprop_preserves_binproduct. Defined. Definition disp_univalent_2_disp_bicat_binprod : disp_univalent_2 disp_bicat_binprod. Proof. split. - exact disp_univalent_2_0_disp_bicat_binprod. - exact disp_univalent_2_1_disp_bicat_binprod. Defined. Definition is_univalent_2_1_univ_cat_with_binprod : is_univalent_2_1 univ_cat_with_binprod. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_binprod. Defined. Definition is_univalent_2_0_univ_cat_with_binprod : is_univalent_2_0 univ_cat_with_binprod. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_binprod. Defined. Definition is_univalent_2_univ_cat_with_binprod : is_univalent_2 univ_cat_with_binprod. Proof. split. - exact is_univalent_2_0_univ_cat_with_binprod. - exact is_univalent_2_1_univ_cat_with_binprod. Defined. (** 3. Categories with pullbacks *) Definition disp_bicat_pullback : disp_bicat bicat_of_univ_cats. Proof. use disp_subbicat. - exact (λ C, Pullbacks (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_pullback F). - exact (λ C _, identity_preserves_pullback _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_pullback HF HG). Defined. Definition univ_cat_with_pb : bicat := total_bicat disp_bicat_pullback. Definition disp_univalent_2_1_disp_bicat_pullback : disp_univalent_2_1 disp_bicat_pullback. Proof. use disp_subbicat_univalent_2_1. intros. apply isaprop_preserves_pullback. Qed. Definition disp_univalent_2_0_disp_bicat_pullback : disp_univalent_2_0 disp_bicat_pullback. Proof. use disp_subbicat_univalent_2_0. - exact univalent_cat_is_univalent_2. - intro C. repeat (use impred ; intro). apply isaprop_Pullback. exact (pr2 C). - intros. apply isaprop_preserves_pullback. Qed. Definition disp_univalent_2_disp_bicat_pullback : disp_univalent_2 disp_bicat_pullback. Proof. split. - exact disp_univalent_2_0_disp_bicat_pullback. - exact disp_univalent_2_1_disp_bicat_pullback. Defined. Definition is_univalent_2_1_univ_cat_with_pb : is_univalent_2_1 univ_cat_with_pb. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_pullback. Defined. Definition is_univalent_2_0_univ_cat_with_pb : is_univalent_2_0 univ_cat_with_pb. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_pullback. Defined. Definition is_univalent_2_univ_cat_with_pb : is_univalent_2 univ_cat_with_pb. Proof. split. - exact is_univalent_2_0_univ_cat_with_pb. - exact is_univalent_2_1_univ_cat_with_pb. Defined. (** 4. Categories with finite limits *) Definition disp_bicat_finlim : disp_bicat bicat_of_univ_cats := disp_dirprod_bicat disp_bicat_terminal_obj disp_bicat_pullback. Definition univ_cat_with_finlim : bicat := total_bicat disp_bicat_finlim. Definition disp_univalent_2_1_disp_bicat_finlim : disp_univalent_2_1 disp_bicat_finlim. Proof. use is_univalent_2_1_dirprod_bicat. - exact disp_univalent_2_1_disp_bicat_terminal_obj. - exact disp_univalent_2_1_disp_bicat_pullback. Qed. Definition disp_univalent_2_0_disp_bicat_finlim : disp_univalent_2_0 disp_bicat_finlim. Proof. use is_univalent_2_0_dirprod_bicat. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_disp_bicat_terminal_obj. - exact disp_univalent_2_disp_bicat_pullback. Defined. Definition disp_univalent_2_disp_bicat_finlim : disp_univalent_2 disp_bicat_finlim. Proof. split. - exact disp_univalent_2_0_disp_bicat_finlim. - exact disp_univalent_2_1_disp_bicat_finlim. Defined. Definition is_univalent_2_1_univ_cat_with_finlim : is_univalent_2_1 univ_cat_with_finlim. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_finlim. Defined. Definition is_univalent_2_0_univ_cat_with_finlim : is_univalent_2_0 univ_cat_with_finlim. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_finlim. Defined. Definition is_univalent_2_univ_cat_with_finlim : is_univalent_2 univ_cat_with_finlim. Proof. split. - exact is_univalent_2_0_univ_cat_with_finlim. - exact is_univalent_2_1_univ_cat_with_finlim. Defined. (** 5. Categories with an initial object *) Definition disp_bicat_initial_obj : disp_bicat bicat_of_univ_cats. Proof. use disp_subbicat. - exact (λ C, Initial (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_initial F). - exact (λ C _, identity_preserves_initial _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_initial HF HG). Defined. Definition univ_cat_with_initial : bicat := total_bicat disp_bicat_initial_obj. Definition disp_univalent_2_1_disp_bicat_initial_obj : disp_univalent_2_1 disp_bicat_initial_obj. Proof. use disp_subbicat_univalent_2_1. intros. apply isaprop_preserves_initial. Qed. Definition disp_univalent_2_0_disp_bicat_initial_obj : disp_univalent_2_0 disp_bicat_initial_obj. Proof. use disp_subbicat_univalent_2_0. - exact univalent_cat_is_univalent_2. - intro C. apply isaprop_Initial. exact (pr2 C). - intros. apply isaprop_preserves_initial. Qed. Definition disp_univalent_2_disp_bicat_initial_obj : disp_univalent_2 disp_bicat_initial_obj. Proof. split. - exact disp_univalent_2_0_disp_bicat_initial_obj. - exact disp_univalent_2_1_disp_bicat_initial_obj. Defined. Definition is_univalent_2_1_univ_cat_with_initial : is_univalent_2_1 univ_cat_with_initial. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_initial_obj. Defined. Definition is_univalent_2_0_univ_cat_with_initial : is_univalent_2_0 univ_cat_with_initial. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_initial_obj. Defined. Definition is_univalent_2_univ_cat_with_initial : is_univalent_2 univ_cat_with_initial. Proof. split. - exact is_univalent_2_0_univ_cat_with_initial. - exact is_univalent_2_1_univ_cat_with_initial. Defined. (** 6. Categories with binary coproducts *) Definition disp_bicat_bincoprod : disp_bicat bicat_of_univ_cats. Proof. use disp_subbicat. - exact (λ C, BinCoproducts (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_bincoproduct F). - exact (λ C _, identity_preserves_bincoproduct _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_bincoproduct HF HG). Defined. Definition univ_cat_with_bincoprod : bicat := total_bicat disp_bicat_bincoprod. Definition disp_univalent_2_1_disp_bicat_bincoprod : disp_univalent_2_1 disp_bicat_bincoprod. Proof. use disp_subbicat_univalent_2_1. intros. apply isaprop_preserves_bincoproduct. Qed. Definition disp_univalent_2_0_disp_bicat_bincoprod : disp_univalent_2_0 disp_bicat_bincoprod. Proof. use disp_subbicat_univalent_2_0. - exact univalent_cat_is_univalent_2. - intro C. repeat (use impred ; intro). apply isaprop_BinCoproduct. exact (pr2 C). - intros. apply isaprop_preserves_bincoproduct. Defined. Definition disp_univalent_2_disp_bicat_bincoprod : disp_univalent_2 disp_bicat_bincoprod. Proof. split. - exact disp_univalent_2_0_disp_bicat_bincoprod. - exact disp_univalent_2_1_disp_bicat_bincoprod. Defined. Definition is_univalent_2_1_univ_cat_with_bincoprod : is_univalent_2_1 univ_cat_with_bincoprod. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_disp_bicat_bincoprod. Defined. Definition is_univalent_2_0_univ_cat_with_bincoprod : is_univalent_2_0 univ_cat_with_bincoprod. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact disp_univalent_2_0_disp_bicat_bincoprod. Defined. Definition is_univalent_2_univ_cat_with_bincoprod : is_univalent_2 univ_cat_with_bincoprod. Proof. split. - exact is_univalent_2_0_univ_cat_with_bincoprod. - exact is_univalent_2_1_univ_cat_with_bincoprod. Defined. UniMath-20231010/UniMath/Bicategories/Core/Examples/TwoType.v000066400000000000000000000124221451125700300235250ustar00rootroot00000000000000(** The fundamental groupoid of a 2-type. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope bicategory_scope. Section TwoTypeBiGroupoid. Variable (X : Type) (HX : isofhlevel 4 X). Definition two_type_bicat_data : prebicat_data. Proof. use build_prebicat_data. - exact X. - exact (λ x y, x = y). - exact (λ _ _ p q, p = q). - exact (fun _ => idpath _). - exact (λ _ _ _ p q, p @ q). - exact (λ _ _ p, idpath p). - exact (λ _ _ _ _ _ q₁ q₂, q₁ @ q₂). - exact (λ _ _ _ p _ _ r, maponpaths (λ s, p @ s) r). - exact (λ _ _ _ _ _ q r, maponpaths (λ s, s @ q) r). - exact (λ _ _ p, idpath p). - exact (λ _ _ p, idpath p). - exact (λ _ _ p, pathscomp0rid p). - exact (λ _ _ p, !(pathscomp0rid p)). - exact (λ _ _ _ _ p q r, path_assoc p q r). - exact (λ _ _ _ _ p q r, !(path_assoc p q r)). Defined. Lemma two_type_bicat_laws : prebicat_laws two_type_bicat_data. Proof. repeat (use tpair) ; try (intros; apply idpath). - intros ; cbn in *. apply pathscomp0rid. - intros ; cbn in *. apply path_assoc. - intros ; cbn in *. symmetry. apply maponpathscomp0. - intros ; cbn in *. rewrite maponpathscomp0. apply idpath. - intros x y p₁ p₂ q ; cbn in *. induction q ; cbn. apply idpath. - intros x y p₁ p₂ q ; cbn in *. induction q ; cbn. exact (!(pathscomp0rid _)). - intros w x y z p₁ p₂ p₃ p₄ q ; cbn in *. induction q ; cbn. exact (!(pathscomp0rid _)). - intros w x y z p₁ p₂ p₃ p₄ q ; cbn in *. induction q ; cbn. exact (!(pathscomp0rid _)). - intros w x y z p₁ p₂ p₃ p₄ q ; cbn in *. induction q ; cbn. exact ((pathscomp0rid _)). - intros w x y z p₁ p₂ p₃ p₄ q ; cbn in *. induction q ; cbn. exact ((pathscomp0rid _)). - intros x y p ; cbn in *. apply pathsinv0r. - intros x y p ; cbn in *. apply pathsinv0l. - intros w x y z p₁ p₂ p₃ ; cbn in *. apply pathsinv0r. - intros w x y z p₁ p₂ p₃ ; cbn in *. apply pathsinv0l. - intros x y z p q ; cbn in *. induction p ; cbn. apply idpath. - intros v w x y z p₁ p₂ p₃ p₄ ; cbn in *. induction p₁, p₂, p₃, p₄ ; cbn. apply idpath. Qed. Definition fundamental_bigroupoid : bicat. Proof. use build_bicategory. - exact two_type_bicat_data. - exact two_type_bicat_laws. - intros x y p₁ p₂ ; cbn in *. exact (HX x y p₁ p₂). Defined. (** Each 2-cell is an iso *) Definition fundamental_groupoid_2cell_iso {x y : fundamental_bigroupoid} {p₁ p₂ : fundamental_bigroupoid⟦x,y⟧} (s : p₁ ==> p₂) : is_invertible_2cell s. Proof. refine (!s ,, _). split ; cbn. - apply pathsinv0r. - apply pathsinv0l. Defined. (** Each 1-cell is an adjoint equivalence *) Definition fundamental_bigroupoid_1cell_equivalence {x y : fundamental_bigroupoid} (p : fundamental_bigroupoid⟦x,y⟧) : left_equivalence p. Proof. use tpair. - refine (!p ,, _). split ; cbn. + exact (! (pathsinv0r p)). + exact (pathsinv0l p). - split ; cbn. + apply fundamental_groupoid_2cell_iso. + apply fundamental_groupoid_2cell_iso. Defined. Definition fundamental_bigroupoid_1cell_adj_equiv {x y : fundamental_bigroupoid} (p : fundamental_bigroupoid⟦x,y⟧) : left_adjoint_equivalence p := equiv_to_isadjequiv p (fundamental_bigroupoid_1cell_equivalence p). (** It is univalent *) Definition fundamental_bigroupoid_is_univalent_2_1 : is_univalent_2_1 fundamental_bigroupoid. Proof. intros x y p₁ p₂. use isweq_iso ; cbn in *. - intros q. apply q. - intros q. induction q ; cbn. apply idpath. - intros q. induction q as [q Hq]. induction q ; cbn. use subtypePath ; cbn. + intro. apply (isaprop_is_invertible_2cell (C:=fundamental_bigroupoid)). + apply idpath. Defined. Definition fundamental_bigroupoid_is_univalent_2_0 : is_univalent_2_0 fundamental_bigroupoid. Proof. intros x y. use isweq_iso. - intros p. apply p. - intros p ; cbn in *. induction p ; cbn. apply idpath. - intros p ; cbn in *. apply path_internal_adjoint_equivalence. + apply fundamental_bigroupoid_is_univalent_2_1. + cbn in *. induction (pr1 p) ; cbn. apply idpath. Defined. Definition fundamental_bigroupoid_is_univalent_2 : is_univalent_2 fundamental_bigroupoid. Proof. split. - exact fundamental_bigroupoid_is_univalent_2_0. - exact fundamental_bigroupoid_is_univalent_2_1. Defined. End TwoTypeBiGroupoid. UniMath-20231010/UniMath/Bicategories/Core/Invertible_2cells.v000066400000000000000000000346421451125700300237130ustar00rootroot00000000000000(* *********************************************************************************** *) (** * More on invertible 2cells *) (* *********************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Local Open Scope cat. Definition eq_is_invertible_2cell {B : bicat} {a b : B} {f g : a --> b} {α β : f ==> g} (p : α = β) (Hα : is_invertible_2cell α) : is_invertible_2cell β. Proof. use make_is_invertible_2cell. - exact (Hα^-1). - abstract (rewrite <- p ; apply vcomp_rinv). - abstract (rewrite <- p ; apply vcomp_linv). Defined. (* ----------------------------------------------------------------------------------- *) (** ** Inverse 2cell of a composition *) (* ----------------------------------------------------------------------------------- *) Lemma is_invertible_2cell_vcomp {C : prebicat} {a b : C} {f g h: C ⟦a, b⟧} {x : f ==> g} (inv_x : is_invertible_2cell x) {y : g ==> h} (inv_y : is_invertible_2cell y) : is_invertible_2cell (x • y). Proof. use make_is_invertible_2cell. - exact (inv_y^-1 • inv_x^-1). - abstract ( repeat rewrite vassocl; etrans; [apply vassoc4|]; etrans; [ apply maponpaths_2, maponpaths; apply (vcomp_rinv inv_y) |]; rewrite id2_right; apply (vcomp_rinv inv_x) ). - abstract ( repeat rewrite vassocl; etrans; [apply vassoc4|]; etrans; [ apply maponpaths_2, maponpaths; apply (vcomp_linv inv_x) |]; rewrite id2_right; apply (vcomp_linv inv_y) ). Defined. Lemma is_invertible_2cell_lwhisker {C : prebicat} {a b c : C} (f : a --> b) {g1 g2 : b --> c} {x : g1 ==> g2} (inv_x : is_invertible_2cell x) : is_invertible_2cell (f ◃ x). Proof. use make_is_invertible_2cell. - exact (f ◃ inv_x^-1). - abstract ( etrans; [ apply lwhisker_vcomp |]; etrans; [ apply maponpaths; apply (vcomp_rinv inv_x) |]; apply lwhisker_id2). - abstract ( etrans; [ apply lwhisker_vcomp |]; etrans; [ apply maponpaths; apply (vcomp_linv inv_x) |]; apply lwhisker_id2). Defined. Lemma is_invertible_2cell_rwhisker {C : prebicat} {a b c : C} {f1 f2 : a --> b} (g : b --> c) {x : f1 ==> f2} (inv_x : is_invertible_2cell x) : is_invertible_2cell (x ▹ g). Proof. use make_is_invertible_2cell. - exact (inv_x^-1 ▹ g). - abstract ( etrans; [ apply rwhisker_vcomp |]; etrans; [ apply maponpaths; apply (vcomp_rinv inv_x) |]; apply id2_rwhisker). - abstract ( etrans; [ apply rwhisker_vcomp |]; etrans; [ apply maponpaths; apply (vcomp_linv inv_x) |]; apply id2_rwhisker). Defined. (** ** Two-cells that are isomorphisms **) Lemma pentagon {C : bicat} {V W X Y Z : C} (k : C⟦Y,Z⟧) (h : C⟦X,Y⟧) (g : C⟦W,X⟧) (f : C⟦V,W⟧) : (lassociator (g ∘ f) h k o lassociator f g (k ∘ h)) = (id₂ k ⋆⋆ lassociator f g h) o lassociator f (h ∘ g) k o (lassociator g h k ⋆⋆ id₂ f). Proof. unfold assoc. unfold hcomp. apply pathsinv0. rewrite id2_rwhisker. rewrite id2_left. rewrite lwhisker_id2. rewrite id2_right. rewrite vassocr. apply lassociator_lassociator. Qed. Definition is_invertible_2cell_hcomp {C : bicat} {X Y Z : C} {f₁ g₁ : C⟦Y,Z⟧} {f₂ g₂ : C⟦X,Y⟧} (η₁ : f₁ ==> g₁) (η₂ : f₂ ==> g₂) (inv_η₁ : is_invertible_2cell η₁) (inv_η₂ : is_invertible_2cell η₂) : is_invertible_2cell (η₁ ⋆⋆ η₂). Proof. use make_is_invertible_2cell. - exact (inv_η₁^-1 ⋆⋆ inv_η₂^-1). - abstract (rewrite <- hcomp_vcomp, !vcomp_rinv; apply hcomp_identity). - abstract (rewrite <- hcomp_vcomp, !vcomp_linv; apply hcomp_identity). Defined. Definition bc_whisker_l {C : bicat} {X Y Z : C} {f₁ : C⟦X,Y⟧} {f₂ : C⟦X,Y⟧} (g : C⟦Y,Z⟧) (α : f₁ ==> f₂) : (g ∘ f₁) ==> (g ∘ f₂) := id₂ g ⋆⋆ α. (* Notation "g '◅' α" := (bc_whisker_l g α) (at level 40) : bicategory_scope. *) Lemma bc_whisker_l_id₂ {C : bicat} {X Y Z : C} (f : C⟦X,Y⟧) (g : C⟦Y,Z⟧) : g ◅ (id₂ f) = id₂ (g ∘ f). Proof. apply id2_rwhisker. Qed. Definition bc_whisker_r {C : bicat} {X Y Z : C} {g₁ : C⟦Y,Z⟧} {g₂ : C⟦Y,Z⟧} (β : g₁ ==> g₂) (f : C⟦X,Y⟧) : (g₁ ∘ f) ==> (g₂ ∘ f) := β ⋆⋆ id₂ f. (* Notation "β '▻' f" := (bc_whisker_r β f) (at level 40) : bicategory_scope. *) Lemma bc_whisker_r_id₂ {C : bicat} {X Y Z : C} (f : C⟦X,Y⟧) (g : C⟦Y,Z⟧) : (id₂ g) ▻ f = id₂ (g ∘ f). Proof. apply lwhisker_id2. Qed. Lemma inverse_of_assoc {C : bicat} {W X Y Z : C} (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧) : (is_invertible_2cell_lassociator f g h)^-1 = rassociator f g h. Proof. apply idpath. Qed. (**** Properties of isomorphisms ***) Lemma vcomp_move_L_Vp {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : f ==> g) (η₂ : f ==> h) (ε : g ==> h) (Hε : is_invertible_2cell ε) : ε o η₁ = η₂ -> η₁ = Hε^-1 o η₂. Proof. intro. rewrite <- (id2_right η₁). rewrite <- (vcomp_rinv Hε). rewrite vassocr. apply maponpaths_2. assumption. Qed. Lemma vcomp_move_L_pV {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : g ==> h) (η₂ : f ==> h) (ε : f ==> g) (Hε : is_invertible_2cell ε) : η₁ o ε = η₂ -> η₁ = η₂ o Hε^-1. Proof. intros Hη. rewrite <- (id2_left η₁). rewrite <- (vcomp_linv Hε). rewrite <- vassocr. apply maponpaths. exact Hη. Qed. Lemma vcomp_move_R_Mp {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : f ==> g) (η₂ : f ==> h) (ε : g ==> h) (Hε : is_invertible_2cell ε) : η₁ = Hε^-1 o η₂ -> ε o η₁ = η₂. Proof. intro. rewrite <- (id2_right η₂). rewrite <- (vcomp_linv Hε). rewrite vassocr. apply maponpaths_2. assumption. Qed. Lemma vcomp_move_R_pM {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : g ==> h) (η₂ : f ==> h) (ε : f ==> g) (Hε : is_invertible_2cell ε) : η₁ = η₂ o Hε^-1 -> η₁ o ε = η₂. Proof. intros Hη. rewrite <- (id2_left η₂). rewrite <- (vcomp_rinv Hε). rewrite <- vassocr. apply maponpaths. apply Hη. Qed. Lemma vcomp_move_L_Mp {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : f ==> h) (η₂ : f ==> g) (ε : g ==> h) (Hε : is_invertible_2cell ε) : Hε^-1 o η₁ = η₂ -> η₁ = ε o η₂. Proof. intros. rewrite <- (id2_right η₁). rewrite <- (vcomp_linv Hε). rewrite vassocr. apply maponpaths_2. assumption. Qed. Lemma vcomp_move_L_pM {C : bicat} {X Y : C} {f g h : C⟦X,Y⟧} (η₁ : f ==> h) (η₂ : g ==> h) (ε : f ==> g) (Hε : is_invertible_2cell ε) : η₁ o Hε^-1 = η₂ -> η₁ = η₂ o ε. Proof. intros Hη. rewrite <- (id2_left η₁). rewrite <- (vcomp_rinv Hε). rewrite <- vassocr. apply maponpaths. apply Hη. Qed. Lemma path_inverse_2cell {C : bicat} {X Y : C} {f g : C⟦X,Y⟧} (η₁ η₂ : f ==> g) {inv_η₁ : is_invertible_2cell η₁} {inv_η₂ : is_invertible_2cell η₂} : η₁ = η₂ -> inv_η₁^-1 = inv_η₂^-1. Proof. intros p. rewrite <- (id2_left (inv_η₁^-1)). rewrite <- (id2_right (inv_η₂^-1)). rewrite <- (vcomp_linv inv_η₂). rewrite <- vassocr. apply maponpaths. rewrite <- p. apply vcomp_rinv. Qed. Lemma isaset_invertible_2cell {C : bicat} {X Y : C} (f g : X --> Y) : isaset (invertible_2cell f g). Proof. use isaset_total2. - apply C. - intro. apply isasetaprop. apply isaprop_is_invertible_2cell. Qed. Ltac is_iso := match goal with | [ |- is_invertible_2cell (runitor _) ] => apply is_invertible_2cell_runitor | [ |- is_invertible_2cell (rinvunitor _) ] => apply is_invertible_2cell_rinvunitor | [ |- is_invertible_2cell (lunitor _) ] => apply is_invertible_2cell_lunitor | [ |- is_invertible_2cell (linvunitor _) ] => apply is_invertible_2cell_linvunitor | [ |- is_invertible_2cell (rassociator _ _ _)] => apply is_invertible_2cell_rassociator | [ |- is_invertible_2cell (lassociator _ _ _)] => apply is_invertible_2cell_lassociator | [ |- is_invertible_2cell (_ ^-1)] => apply is_invertible_2cell_inv ; is_iso | [ |- is_invertible_2cell (_ • _)] => apply is_invertible_2cell_vcomp ; is_iso | [ |- is_invertible_2cell (_ ◃ _)] => apply is_invertible_2cell_lwhisker ; is_iso | [ |- is_invertible_2cell (_ ▹ _)] => apply is_invertible_2cell_rwhisker ; is_iso | [ |- is_invertible_2cell (_ ⋆⋆ _)] => apply is_invertible_2cell_hcomp ; is_iso | [ |- is_invertible_2cell (_ ⋆ _)] => apply is_invertible_2cell_hcomp ; is_iso | [ |- is_invertible_2cell (id₂ _)] => apply is_invertible_2cell_id₂ | _ => try assumption end. Definition inv_of_invertible_2cell {C : bicat} {X Y : C} {f g : X --> Y} : invertible_2cell f g → invertible_2cell g f. Proof. intro α. use make_invertible_2cell. - exact (α^-1). - is_iso. Defined. Definition comp_of_invertible_2cell {C : bicat} {X Y : C} {f g h : X --> Y} : invertible_2cell f g → invertible_2cell g h → invertible_2cell f h. Proof. intros α β. use make_invertible_2cell. - exact (α • β). - is_iso. + apply α. + apply β. Defined. Definition lwhisker_of_invertible_2cell {B : bicat} {x y z : B} (f : x --> y) {g₁ g₂ : y --> z} (α : invertible_2cell g₁ g₂) : invertible_2cell (f · g₁) (f · g₂). Proof. use make_invertible_2cell. - exact (f ◃ α). - is_iso. apply α. Defined. Definition rwhisker_of_invertible_2cell {B : bicat} {x y z : B} {f₁ f₂ : x --> y} (g : y --> z) (α : invertible_2cell f₁ f₂) : invertible_2cell (f₁ · g) (f₂ · g). Proof. use make_invertible_2cell. - exact (α ▹ g). - is_iso. apply α. Defined. Definition lunitor_invertible_2cell {B : bicat} {a b : B} (f : a --> b) : invertible_2cell (id₁ a · f) f. Proof. use make_invertible_2cell. - exact (lunitor f). - is_iso. Defined. Definition linvunitor_invertible_2cell {B : bicat} {a b : B} (f : a --> b) : invertible_2cell f (id₁ a · f). Proof. use make_invertible_2cell. - exact (linvunitor f). - is_iso. Defined. Definition runitor_invertible_2cell {B : bicat} {a b : B} (f : a --> b) : invertible_2cell (f · id₁ b) f. Proof. use make_invertible_2cell. - exact (runitor f). - is_iso. Defined. Definition rinvunitor_invertible_2cell {B : bicat} {a b : B} (f : a --> b) : invertible_2cell f (f · id₁ b). Proof. use make_invertible_2cell. - exact (rinvunitor f). - is_iso. Defined. Definition lassociator_invertible_2cell {B : bicat} {a b c d : B} (f : a --> b) (g : b --> c) (h : c --> d) : invertible_2cell (f · (g · h)) (f · g · h). Proof. use make_invertible_2cell. - exact (lassociator f g h). - is_iso. Defined. Definition rassociator_invertible_2cell {B : bicat} {a b c d : B} (f : a --> b) (g : b --> c) (h : c --> d) : invertible_2cell (f · g · h) (f · (g · h)). Proof. use make_invertible_2cell. - exact (rassociator f g h). - is_iso. Defined. (** Invertible 2-cells are the same as isos in the hom category *) Section InvertibleIsIso. Context {B : bicat}. Definition is_inv2cell_to_is_z_iso {a b : B} {f g : hom a b} (α : f ==> g) (Hα : is_invertible_2cell α) : is_z_isomorphism α. Proof. exists (Hα^-1). abstract (split ; [ apply vcomp_rinv | apply vcomp_linv]). Defined. Definition inv2cell_to_z_iso {a b : B} {f g : hom a b} (α : invertible_2cell f g) : z_iso f g. Proof. use make_z_iso'. - apply α. - apply is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. Defined. Definition is_z_iso_to_is_inv2cell {a b : B} {f g : hom a b} (α : f ==> g) (Hα : is_z_isomorphism α) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (inv_from_z_iso (α ,, Hα)). - exact (z_iso_inv_after_z_iso (α ,, Hα)). - exact (z_iso_after_z_iso_inv (α ,, Hα)). Defined. Definition z_iso_to_inv2cell {a b : B} {f g : hom a b} (α : z_iso f g) : invertible_2cell f g. Proof. use make_invertible_2cell. - exact (pr1 α). - exact (is_z_iso_to_is_inv2cell _ (pr2 α)). Defined. Definition inv2cell_to_z_iso_isweq {a b : B} (f g : hom a b) : isweq (@inv2cell_to_z_iso _ _ f g). Proof. use isweq_iso. - exact z_iso_to_inv2cell. - abstract (intro i ; apply cell_from_invertible_2cell_eq ; apply idpath). - abstract (intro i ; apply z_iso_eq ; apply idpath). Defined. Definition inv2cell_to_z_iso_weq {a b : B} (f g : hom a b) : invertible_2cell f g ≃ z_iso f g. Proof. use make_weq. - exact (λ α, inv2cell_to_z_iso α). - exact (inv2cell_to_z_iso_isweq f g). Defined. End InvertibleIsIso. UniMath-20231010/UniMath/Bicategories/Core/Strictness.v000066400000000000000000000626431451125700300225070ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Strict bicategories ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.TwoCategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.TransportLaws. Local Open Scope bicategory_scope. Local Open Scope cat. (** Data of strictness structure *) Definition strictness_structure_data (B : bicat) : UU := (∏ (a b : B) (f : a --> b), id₁ a · f = f) × (∏ (a b : B) (f : a --> b), f · id₁ b = f) × (∏ (a b c d : B) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = f · g · h). (** Projections *) Definition plunitor {B : bicat} (S : strictness_structure_data B) {a b : B} (f : a --> b) : id₁ a · f = f := pr1 S _ _ f. Definition plinvunitor {B : bicat} (S : strictness_structure_data B) {a b : B} (f : a --> b) : f = id₁ a · f := !(pr1 S _ _ f). Definition prunitor {B : bicat} (S : strictness_structure_data B) {a b : B} (f : a --> b) : f · id₁ b = f := pr12 S _ _ f. Definition prinvunitor {B : bicat} (S : strictness_structure_data B) {a b : B} (f : a --> b) : f = f · id₁ b := !(pr12 S _ _ f). Definition plassociator {B : bicat} (S : strictness_structure_data B) {a b c d : B} (f : a --> b) (g : b --> c) (h : c --> d) : f · (g · h) = f · g · h := pr22 S _ _ _ _ f g h. Definition prassociator {B : bicat} (S : strictness_structure_data B) {a b c d : B} (f : a --> b) (g : b --> c) (h : c --> d) : f · g · h = f · (g · h) := !(pr22 S _ _ _ _ f g h). (** The requirements for the data *) Definition strictness_structure_laws {B : bicat} (S : strictness_structure_data B) : UU := (∏ (a b : B) (f : a --> b), pr1 (idtoiso_2_1 _ _ (plunitor S f)) = lunitor f) × (∏ (a b : B) (f : a --> b), pr1 (idtoiso_2_1 _ _ (prunitor S f)) = runitor f) × (∏ (a b c d : B) (f : a --> b) (g : b --> c) (h : c --> d), pr1 (idtoiso_2_1 _ _ (plassociator S f g h)) = lassociator f g h). Definition strictness_structure (B : bicat) : UU := ∑ (S : strictness_structure_data B), strictness_structure_laws S. (** The laws form a proposition *) Lemma isPredicate_strictness_structure_laws (B : bicat) : isPredicate (@strictness_structure_laws B). Proof. intro S. repeat use isapropdirprod. - do 3 (use impred ; intro). apply B. - do 3 (use impred ; intro). apply B. - do 7 (use impred ; intro). apply B. Qed. (** Projections *) Coercion strictness_structure_to_data {B : bicat} (S : strictness_structure B) : strictness_structure_data B := pr1 S. Definition idtoiso_plunitor {B : bicat} (S : strictness_structure B) {a b : B} (f : a --> b) : pr1 (idtoiso_2_1 _ _ (plunitor S f)) = lunitor f := pr12 S _ _ f. Definition idtoiso_prunitor {B : bicat} (S : strictness_structure B) {a b : B} (f : a --> b) : pr1 (idtoiso_2_1 _ _ (prunitor S f)) = runitor f := pr122 S _ _ f. Definition idtoiso_plassociator {B : bicat} (S : strictness_structure B) {a b c d : B} (f : a --> b) (g : b --> c) (h : c --> d) : pr1 (idtoiso_2_1 _ _ (plassociator S f g h)) = lassociator f g h := pr222 S _ _ _ _ f g h. (** Coherent strictness structure. For these, one also needs the triangle and pentagon. *) Definition is_coh_strictness_structure {B : bicat} (S : strictness_structure B) : UU := (∏ (a b c : B) (f : a --> b) (g : b --> c), maponpaths (λ z, f · z) (plunitor S g) = plassociator S _ _ _ @ maponpaths (λ z, z · g) (prunitor S f)) × ∏ (v w x y z : B) (f : v --> w) (g : w --> x) (h : x --> y) (k : y --> z), maponpaths (λ z, f · z) (plassociator S g h k) @ plassociator S f (g · h) k @ maponpaths (λ z, z · k) (plassociator S f g h) = plassociator S f g (h · k) @ plassociator S (f · g) h k. Definition coh_strictness_structure (B : bicat) := ∑ (S : strictness_structure B), is_coh_strictness_structure S. Coercion pr_strictness_structure {B : bicat} (S : coh_strictness_structure B) : strictness_structure B := pr1 S. (** Being coherent is a proposition *) Lemma isPredicate_is_coh_strictness_structure {B : bicat} (HB : is_univalent_2_1 B) : isPredicate (@is_coh_strictness_structure B). Proof. intro S. use isapropdirprod. - do 5 (use impred ; intro). exact (univalent_bicategory_1_cell_hlevel_3 _ HB _ _ _ _ _ _). - do 9 (use impred ; intro). exact (univalent_bicategory_1_cell_hlevel_3 _ HB _ _ _ _ _ _). Qed. (** Definition of 2-category *) Definition locally_strict (B : bicat) : UU := ∏ (a b : B), isaset (a --> b). Definition is_strict_bicat (B : bicat) : UU := locally_strict B × coh_strictness_structure B. Definition make_is_strict_bicat {B : bicat} (HB : locally_strict B) (S : strictness_structure B) : is_strict_bicat B. Proof. use tpair. - exact HB. - repeat use tpair. + exact (@plunitor _ S). + exact (@prunitor _ S). + exact (@plassociator _ S). + exact (@idtoiso_plunitor _ S). + exact (@idtoiso_prunitor _ S). + exact (@idtoiso_plassociator _ S). + abstract (simpl ; intros ; apply HB). + abstract (simpl ; intros ; apply HB). Defined. Lemma isPredicate_is_coh_strictness_structure_from_locally_strict {B : bicat} (HB : locally_strict B) : isPredicate (@is_coh_strictness_structure B). Proof. intro z. apply invproofirrelevance. intros c₁ c₂. use pathsdirprod. - do 5 (use funextsec ; intro). apply (isasetaprop (HB _ _ _ _)). - do 9 (use funextsec ; intro). apply (isasetaprop (HB _ _ _ _)). Qed. Lemma isaprop_is_strict_bicat (B : bicat) : isaprop (is_strict_bicat B). Proof. apply invproofirrelevance. intros x y. induction x as [LSx CSx]. induction y as [LSY CSy]. use pathsdirprod. - do 2 (use funextsec ; intro). apply isapropisaset. - use subtypePath. { exact (isPredicate_is_coh_strictness_structure_from_locally_strict LSx). } use subtypePath. { exact (isPredicate_strictness_structure_laws B). } repeat use pathsdirprod. + repeat (use funextsec ; intro). apply LSx. + repeat (use funextsec ; intro). apply LSx. + repeat (use funextsec ; intro). apply LSx. Qed. Definition strict_bicat := ∑ (B : bicat), is_strict_bicat B. Coercion bicat_of_strict_bicat (B : strict_bicat) : bicat := pr1 B. (** Strict bicat to 2-cat *) Definition strict_bicat_to_precategory_data (B : strict_bicat) : precategory_data. Proof. - use make_precategory_data. + use make_precategory_ob_mor. * exact (ob B). * exact (λ b₁ b₂, b₁ --> b₂). + exact (λ z, id₁ z). + exact (λ _ _ _ f g, f · g). Defined. Definition strict_bicat_to_precategory_is_precategory (B : strict_bicat) : is_precategory (strict_bicat_to_precategory_data B). Proof. repeat split ; cbn. - exact (λ _ _ f, plunitor (pr22 B) f). - exact (λ _ _ f, prunitor (pr22 B) f). - exact (λ _ _ _ _ f g h, plassociator (pr22 B) f g h). - exact (λ _ _ _ _ f g h, prassociator (pr22 B) f g h). Defined. (* the definition is exploited further down in Lemma [strict_bicat_to_two_cat_laws] *) Lemma strict_bicat_to_precategory_has_homsets (B : strict_bicat) : has_homsets (strict_bicat_to_precategory_data B). Proof. exact (pr12 B). Qed. Definition strict_bicat_to_two_cat_data (B : strict_bicat) : two_cat_data. Proof. use tpair. - exact (strict_bicat_to_precategory_data B). - use tpair. + exact (λ _ _ f g, f ==> g). + repeat split. * exact (λ _ _ f, id₂ f). * exact (λ _ _ _ _ _ α β, α • β). * exact (λ _ _ _ f _ _ α, f ◃ α). * exact (λ _ _ _ _ _ g α, α ▹ g). Defined. Definition strict_bicat_to_two_cat_category (B : strict_bicat) : two_cat_category. Proof. use tpair. - exact (strict_bicat_to_two_cat_data B). - split. + exact (strict_bicat_to_precategory_is_precategory B). + exact (strict_bicat_to_precategory_has_homsets B). Defined. Lemma idto2mor_idtoiso {B : strict_bicat} {a b : B} {f g : a --> b} (p : f = g) : @idto2mor (strict_bicat_to_two_cat_data B) _ _ _ _ p = pr1 (idtoiso_2_1 _ _ p). Proof. induction p. apply idpath. Qed. Lemma strict_bicat_to_two_cat_laws (B : strict_bicat) : two_cat_laws (strict_bicat_to_two_cat_category B). Proof. repeat split. - intros ; apply id2_left. - intros ; apply id2_right. - intros ; apply vassocr. - intros ; apply lwhisker_id2. - intros ; apply id2_rwhisker. - intros ; apply lwhisker_vcomp. - intros ; apply rwhisker_vcomp. - intros ; apply vcomp_whisker. - intros ; cbn. rewrite !idto2mor_idtoiso. rewrite !idtoiso_plunitor. apply vcomp_lunitor. - intros ; cbn. rewrite !idto2mor_idtoiso. rewrite !idtoiso_prunitor. apply vcomp_runitor. - intros ; cbn. rewrite !idto2mor_idtoiso. rewrite !idtoiso_plassociator. apply lwhisker_lwhisker. - intros ; cbn. rewrite !idto2mor_idtoiso. rewrite !idtoiso_plassociator. apply rwhisker_lwhisker. - intros ; cbn. rewrite !idto2mor_idtoiso. rewrite !idtoiso_plassociator. apply rwhisker_rwhisker. Qed. Definition strict_bicat_to_two_cat (B : strict_bicat) : two_cat. Proof. use tpair. - use tpair. + exact (strict_bicat_to_two_cat_category B). + exact (strict_bicat_to_two_cat_laws B). - intros x y f g ; simpl. apply (pr1 B). Defined. (** Univalent 2-categories *) Lemma univalent_two_cat_2cells_are_prop (B : strict_bicat) (HB : is_univalent_2_1 B) {a b : B} (f g : a --> b) : isaprop (invertible_2cell f g). Proof. refine (isofhlevelweqf 1 (make_weq _ (HB _ _ f g)) _). exact (pr12 B _ _ f g). Qed. (** Univalent categories do not form a 2-category *) Definition diag_set : HSET_univalent_category ⟶ HSET_univalent_category. Proof. use make_functor. - use make_functor_data. + exact (λ X, setdirprod X X). + exact (λ _ _ f x, f (pr1 x) ,, f (pr2 x)). - split. + intro X. apply idpath. + intros X Y Z f g. apply idpath. Defined. Definition swap : nat_z_iso diag_set diag_set. Proof. use make_nat_z_iso. - use make_nat_trans. + intros X x. exact (pr2 x ,, pr1 x). + intros X Y f. apply idpath. - intros X. cbn. use tpair. + exact (λ z, pr2 z ,, pr1 z). + split. * apply idpath. * apply idpath. Defined. Lemma cat_not_a_two_cat : ¬ (is_strict_bicat bicat_of_univ_cats). Proof. intro H. pose (maponpaths pr1 (eqtohomot (nat_trans_eq_pointwise (maponpaths (λ z, pr1 z) (proofirrelevance _ (@univalent_two_cat_2cells_are_prop (bicat_of_univ_cats ,, H) univalent_cat_is_univalent_2_1 HSET_univalent_category HSET_univalent_category diag_set diag_set) (id2_invertible_2cell _) (nat_z_iso_to_invertible_2cell _ _ swap))) boolset) (true ,, false))) as C. exact (nopathstruetofalse C). Qed. (** Local univalence gives rise to a unique strictness structure *) Definition strictness_from_univalent_2_1 {B : bicat} (HB : is_univalent_2_1 B) : strictness_structure B. Proof. repeat use tpair. - refine (λ _ _ f, isotoid_2_1 HB (lunitor f ,, _)). is_iso. - refine (λ _ _ f, isotoid_2_1 HB (runitor f ,, _)). is_iso. - refine (λ _ _ _ _ f g h, isotoid_2_1 HB (lassociator f g h ,, _)). is_iso. - abstract (cbn ; intros ; rewrite idtoiso_2_1_isotoid_2_1 ; apply idpath). - abstract (cbn ; intros ; rewrite idtoiso_2_1_isotoid_2_1 ; apply idpath). - abstract (cbn ; intros ; rewrite idtoiso_2_1_isotoid_2_1 ; apply idpath). Defined. Lemma is_coh_strictness_from_univalent_2_1 {B : bicat} (HB : is_univalent_2_1 B) : is_coh_strictness_structure (strictness_from_univalent_2_1 HB). Proof. split. - intros a b c f g ; cbn. rewrite isotoid_2_1_lwhisker. rewrite isotoid_2_1_rwhisker. rewrite isotoid_2_1_vcomp. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } simpl. refine (!_). apply runitor_rwhisker. - intros v w x y z f g h k ; cbn. rewrite isotoid_2_1_lwhisker. rewrite isotoid_2_1_rwhisker. rewrite !isotoid_2_1_vcomp. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } simpl. rewrite vassocr. apply lassociator_lassociator. Qed. Definition coh_strictness_from_univalent_2_1 (B : bicat) (HB : is_univalent_2_1 B) : coh_strictness_structure B. Proof. use tpair. - exact (strictness_from_univalent_2_1 HB). - exact (is_coh_strictness_from_univalent_2_1 HB). Defined. Lemma isaprop_coh_strictness_from_univalence_2_1 (B : bicat) (HB : is_univalent_2_1 B) : isaprop (coh_strictness_structure B). Proof. apply invproofirrelevance. intros S₁ S₂. use subtypePath. { exact (isPredicate_is_coh_strictness_structure HB). } use subtypePath. { exact (isPredicate_strictness_structure_laws B). } repeat use pathsdirprod. - use funextsec ; intro a. use funextsec ; intro b. use funextsec ; intro f. refine (_ @ isotoid_2_1_idtoiso_2_1 HB (plunitor S₂ f)). refine (!(isotoid_2_1_idtoiso_2_1 HB (plunitor S₁ f)) @ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite !idtoiso_plunitor. apply idpath. - use funextsec ; intro a. use funextsec ; intro b. use funextsec ; intro f. refine (_ @ isotoid_2_1_idtoiso_2_1 HB (prunitor S₂ f)). refine (!(isotoid_2_1_idtoiso_2_1 HB (prunitor S₁ f)) @ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite !idtoiso_prunitor. apply idpath. - use funextsec ; intro a. use funextsec ; intro b. use funextsec ; intro c. use funextsec ; intro d. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro h. refine (_ @ isotoid_2_1_idtoiso_2_1 HB (plassociator S₂ f g h)). refine (!(isotoid_2_1_idtoiso_2_1 HB (plassociator S₁ f g h)) @ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite !idtoiso_plassociator. apply idpath. Qed. Definition unique_strictness_structure_is_univalent_2_1 (B : bicat) (HB : is_univalent_2_1 B) : iscontr (coh_strictness_structure B). Proof. use tpair. - exact (coh_strictness_from_univalent_2_1 B HB). - intro. apply isaprop_coh_strictness_from_univalence_2_1. exact HB. Defined. Lemma idto2mor_transport (C : two_cat) {x y : pr1 C} {f g : x --> y} (p : f = g) : idto2mor p = transportf _ p (TwoCategories.id2 f). Proof. induction p. apply idpath. Qed. Lemma precomp_transportf (C : two_cat) {x y : pr1 C} {f g h: x --> y} (p : g = h) (α : two_cat_cells _ f g) : TwoCategories.vcomp2 α (transportf (two_cat_cells _ g) p (TwoCategories.id2 g)) = transportf (two_cat_cells _ f) p α. Proof. induction p. cbn. unfold idfun. rewrite TwoCategories.id2_right. apply idpath. Qed. Lemma postcomp_transportf (C : two_cat) {x y : pr1 C} {f g h: x --> y} (p : f = g) (α : two_cat_cells _ g h) : TwoCategories.vcomp2 (transportf (two_cat_cells _ f) p (TwoCategories.id2 f)) α = transportb (λ z, two_cat_cells _ z h) p α. Proof. induction p. cbn. unfold idfun. rewrite TwoCategories.id2_left. apply idpath. Qed. Definition two_cat_to_prebicat_data (C : two_cat) : prebicat_data. Proof. use build_prebicat_data. - apply C. - simpl. intros x y. refine (x --> y). - simpl. intros ? ? f g. exact (two_cat_cells _ f g). - simpl. intros. apply identity. - simpl. intros ? ? ? f g. refine (f · g). - simpl. intros. apply TwoCategories.id2. - simpl. intros ? ? ? ? ? α β. exact (TwoCategories.vcomp2 α β). - simpl. intros ? ? ? f g h α. refine (TwoCategories.lwhisker f α). - simpl. intros ? ? ? g h f α. refine (TwoCategories.rwhisker f α). - simpl. intros ? ? f. apply idto2mor. exact (id_left (f : pr1 C ⟦ X , Y ⟧)). - simpl. intros ? ? f. apply idto2mor. exact (!id_left (f : pr1 C ⟦ X , Y ⟧)). - simpl. intros ? ? f. apply idto2mor. exact (id_right (f : pr1 C ⟦ X , Y ⟧)). - simpl. intros ? ? f. apply idto2mor. exact (!id_right (f : pr1 C ⟦ X , Y ⟧)). - simpl. intros ? ? ? ? f g h. apply idto2mor. refine (assoc (f : pr1 C ⟦ _ , _ ⟧) g h). - simpl. intros ? ? ? ? f g h. apply idto2mor. refine (!assoc (f : pr1 C ⟦ _ , _ ⟧) g h). Defined. Lemma two_cat_to_prebicat_laws (C : two_cat) : prebicat_laws (two_cat_to_prebicat_data C). Proof. repeat split. - intros. apply TwoCategories.id2_left. - intros. apply TwoCategories.id2_right. - intros. apply TwoCategories.vassocr. - intros. apply TwoCategories.lwhisker_id2. - intros. apply TwoCategories.id2_rwhisker. - intros. apply TwoCategories.lwhisker_vcomp. - intros. apply TwoCategories.rwhisker_vcomp. - intros. apply TwoCategories.vcomp_lunitor. - intros. apply TwoCategories.vcomp_runitor. - intros. apply TwoCategories.lwhisker_lwhisker. - intros. apply TwoCategories.rwhisker_lwhisker. - intros. apply TwoCategories.rwhisker_rwhisker. - intros. apply TwoCategories.vcomp_whisker. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0r. apply idpath. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0l. apply idpath. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0r. apply idpath. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0l. apply idpath. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0r. apply idpath. - intros ; cbn. etrans. { apply idto2mor_comp. } rewrite pathsinv0l. apply idpath. - intros ; cbn. etrans. { apply maponpaths. apply idto2mor_rwhisker. } etrans. { apply idto2mor_comp. } refine (!_). etrans. { apply idto2mor_lwhisker. } refine (!_). apply maponpaths. apply (homset_property C). - intros ; cbn. etrans. { apply maponpaths. apply idto2mor_rwhisker. } etrans. { do 2 apply maponpaths_2. apply idto2mor_lwhisker. } etrans. { apply maponpaths_2. apply idto2mor_comp. } etrans. { apply idto2mor_comp. } refine (!_). etrans. { apply idto2mor_comp. } refine (!_). apply maponpaths. apply (homset_property C). Qed. Definition two_cat_to_prebicat (C : two_cat) : prebicat. Proof. use tpair. - apply (two_cat_to_prebicat_data C). - apply two_cat_to_prebicat_laws. Defined. Definition two_cat_to_bicat (C : two_cat) : bicat. Proof. use tpair. - exact (two_cat_to_prebicat C). - apply C. Defined. Lemma idto2mor_idtoiso_two_cat {C : two_cat} {a b : C} {f g : a --> b} (p : f = g) : pr1 (@idtoiso_2_1 (two_cat_to_bicat C) _ _ _ _ p) = idto2mor p. Proof. induction p. apply idpath. Qed. Lemma two_cat_is_strict_bicat (C : two_cat) : is_strict_bicat (two_cat_to_bicat C). Proof. use make_is_strict_bicat. - apply (homset_property C). - use tpair. + repeat split. * intros a b f. exact (id_left (f : pr1 C ⟦ _ , _ ⟧)). * intros a b f. exact (id_right (f : pr1 C ⟦ _ , _ ⟧)). * intros a b c d f g h. exact (assoc (f : pr1 C ⟦ _ , _ ⟧) g h). + simpl. repeat split ; intros ; apply idto2mor_idtoiso_two_cat. Qed. (* it is remarkable that this can be opaque although [strictness_structure_data] is being constructed under the first + item *) Definition two_cat_to_strict_bicat (C : two_cat) : strict_bicat. Proof. use tpair. - exact (two_cat_to_bicat C). - exact (two_cat_is_strict_bicat C). Defined. Lemma strict_bicat_to_two_cat_to_strict_bicat (C : strict_bicat) : two_cat_to_strict_bicat (strict_bicat_to_two_cat C) = C. Proof. use subtypePath. { intro. apply isaprop_is_strict_bicat. } use subtypePath. { intro. do 4 (apply impred ; intro). apply isapropisaset. } use total2_paths2_f. - use total2_paths2_f. + apply idpath. + cbn. repeat use pathsdirprod ; try apply idpath. * use funextsec. intro x. use funextsec. intro y. use funextsec. intro f. rewrite !idto2mor_idtoiso. apply idtoiso_plunitor. * use funextsec. intro x. use funextsec. intro y. use funextsec. intro f. rewrite !idto2mor_idtoiso. apply idtoiso_prunitor. * use funextsec. intro x. use funextsec. intro y. use funextsec. intro f. rewrite !idto2mor_idtoiso. rewrite idtoiso_2_1_inv ; simpl. refine (!(id2_right _) @ _). use vcomp_move_R_pM. { is_iso. } simpl. refine (!_). etrans. { apply maponpaths_2. apply idtoiso_plunitor. } apply lunitor_linvunitor. * use funextsec. intro x. use funextsec. intro y. use funextsec. intro f. rewrite !idto2mor_idtoiso. rewrite idtoiso_2_1_inv ; simpl. refine (!(id2_right _) @ _). use vcomp_move_R_pM. { is_iso. } simpl. refine (!_). etrans. { apply maponpaths_2. apply idtoiso_prunitor. } apply runitor_rinvunitor. * use funextsec ; intro w. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro h. rewrite !idto2mor_idtoiso. rewrite idtoiso_2_1_inv ; simpl. refine (!(id2_right _) @ _). use vcomp_move_R_pM. { is_iso. } simpl. refine (!_). etrans. { apply maponpaths_2. apply idtoiso_plassociator. } apply lassociator_rassociator. * use funextsec ; intro w. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro h. rewrite !idto2mor_idtoiso. apply idtoiso_plassociator. - apply isaprop_prebicat_laws. intros. apply cellset_property. Qed. Lemma two_cat_to_strict_bicat_to_two_cat (C : two_cat) : strict_bicat_to_two_cat (two_cat_to_strict_bicat C) = C. Proof. use subtypePath. { intro. do 4 (use impred ; intro). apply isapropisaset. } use total2_paths2_f. - use total2_paths2_f. + apply idpath. + apply isapropdirprod. * apply isaprop_is_precategory. intros x y. apply (pr22 (pr11 C)). * apply isaprop_has_homsets. - apply isaprop_two_cat_laws. Qed. Definition two_cat_equiv_strict_bicat : two_cat ≃ strict_bicat. Proof. use make_weq. - exact two_cat_to_strict_bicat. - use isweq_iso. + exact strict_bicat_to_two_cat. + exact two_cat_to_strict_bicat_to_two_cat. + exact strict_bicat_to_two_cat_to_strict_bicat. Defined. UniMath-20231010/UniMath/Bicategories/Core/TransportLaws.v000066400000000000000000000146221451125700300231630ustar00rootroot00000000000000(** Some laws on transporting along families of 2-cells. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope bicategory_scope. (** laws for idtoiso_2_0 *) Definition transport_one_cell_FlFr {C : bicat} {A : Type} (f g : A -> C) {a₁ a₂ : A} (p : a₁ = a₂) (h : C⟦f a₁,g a₁⟧) : (transportf (λ (z : A), C⟦f z,g z⟧) p h) ==> (idtoiso_2_0 _ _ (maponpaths g p)) ∘ h ∘ (idtoiso_2_0 _ _ (maponpaths f (!p))). Proof. induction p ; cbn. exact (linvunitor _ o rinvunitor _). Defined. Definition transport_one_cell_FlFr_inv {C : bicat} {A : Type} (f g : A -> C) {a₁ a₂ : A} (p : a₁ = a₂) (h : C⟦f a₁,g a₁⟧) : ((idtoiso_2_0 _ _ (maponpaths g p))) ∘ h ∘ (idtoiso_2_0 _ _ (maponpaths f (!p))) ==> (transportf (λ (z : A), C⟦f z,g z⟧) p h). Proof. induction p ; cbn. exact (runitor _ o lunitor _). Defined. Definition transport_one_cell_FlFr_iso {C : bicat} {A : Type} (f g : A -> C) {a₁ a₂ : A} (p : a₁ = a₂) (h : C⟦f a₁,g a₁⟧) : is_invertible_2cell (transport_one_cell_FlFr f g p h). Proof. refine (transport_one_cell_FlFr_inv f g p h ,, _). split ; cbn. - induction p ; cbn. rewrite <- !vassocr. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite linvunitor_lunitor, id2_left. apply rinvunitor_runitor. - induction p ; cbn. rewrite <- !vassocr. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite runitor_rinvunitor, id2_left. apply lunitor_linvunitor. Defined. Definition idtoiso_2_0_inv {B : bicat} {b₁ b₂ : B} (p : b₁ = b₂) : pr1 (idtoiso_2_0 _ _ (!p)) = left_adjoint_right_adjoint (idtoiso_2_0 _ _ p). Proof. induction p. apply idpath. Qed. (** laws for idtoiso_2_1 *) Lemma idtoiso_2_1_inv {C : bicat} {a b : C} {f g : a --> b} (p : f = g) : idtoiso_2_1 _ _ (!p) = inv_of_invertible_2cell (idtoiso_2_1 _ _ p). Proof. induction p. apply idpath. Qed. Lemma idtoiso_2_1_concat {C : bicat} {a b : C} {f₁ f₂ f₃ : a --> b} (p : f₁ = f₂) (q : f₂ = f₃) : idtoiso_2_1 _ _ (p @ q) = comp_of_invertible_2cell (idtoiso_2_1 _ _ p) (idtoiso_2_1 _ _ q). Proof. induction p ; induction q ; cbn. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact (!(id2_left _)). Qed. Lemma idtoiso_2_1_rwhisker {C : bicat} {X Y Z : C} (g : C⟦Y,Z⟧) {f₁ f₂ : C⟦X,Y⟧} (q : f₁ = f₂) : g ◅ (idtoiso_2_1 _ _ q) = idtoiso_2_1 _ _ (maponpaths (λ z, z · g) q). Proof. induction q ; cbn. apply id2_rwhisker. Qed. Lemma idtoiso_2_1_lwhisker {C : bicat} {X Y Z : C} (g : C⟦X,Y⟧) {f₁ f₂ : C⟦Y,Z⟧} (q : f₁ = f₂) : (idtoiso_2_1 _ _ q) ▻ g = idtoiso_2_1 _ _ (maponpaths (λ z, g · z) q). Proof. induction q ; cbn. apply lwhisker_id2. Qed. Lemma transport_two_cell_FlFr {C : bicat} {A : Type} {X Y : C} (F G : A -> C⟦X,Y⟧) {a₁ a₂ : A} (p : a₁ = a₂) (α : F a₁ ==> G a₁) : transportf (λ z, F z ==> G z) p α = idtoiso_2_1 _ _ (maponpaths G p) o α o (idtoiso_2_1 _ _ (maponpaths F p))^-1. Proof. induction p ; cbn. rewrite id2_right, id2_left. apply idpath. Qed. Lemma isotoid_2_1_id {B : bicat} (HB : is_univalent_2_1 B) {a b : B} (f : a --> b) : idpath f = isotoid_2_1 HB (id2_invertible_2cell f). Proof. use (invmaponpathsincl (idtoiso_2_1 _ _)). - apply isinclweq. exact (HB _ _ _ _). - rewrite idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Lemma isotoid_2_1_lwhisker {B : bicat} (HB : is_univalent_2_1 B) {a b c : B} (f : a --> b) {g₁ g₂ : b --> c} (α : invertible_2cell g₁ g₂) : maponpaths (λ z : b --> c, f · z) (isotoid_2_1 HB α) = isotoid_2_1 HB (f ◃ α ,, is_invertible_2cell_lwhisker _ (pr2 α)). Proof. use (invmaponpathsincl (idtoiso_2_1 _ _)). - apply isinclweq. exact (HB _ _ _ _). - use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } etrans. { refine (!_). apply idtoiso_2_1_lwhisker. } rewrite !idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Lemma isotoid_2_1_rwhisker {B : bicat} (HB : is_univalent_2_1 B) {a b c : B} {f₁ f₂ : a --> b} (α : invertible_2cell f₁ f₂) (g : b --> c) : maponpaths (λ z : a --> b, z · g) (isotoid_2_1 HB α) = isotoid_2_1 HB (α ▹ g ,, is_invertible_2cell_rwhisker _ (pr2 α)). Proof. use (invmaponpathsincl (idtoiso_2_1 _ _)). - apply isinclweq. exact (HB _ _ _ _). - use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } etrans. { refine (!_). apply idtoiso_2_1_rwhisker. } rewrite !idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Lemma isotoid_2_1_vcomp {B : bicat} (HB : is_univalent_2_1 B) {a b : B} {f₁ f₂ f₃ : a --> b} (α : invertible_2cell f₁ f₂) (β : invertible_2cell f₂ f₃) : isotoid_2_1 HB α @ isotoid_2_1 HB β = isotoid_2_1 HB (α • β ,, is_invertible_2cell_vcomp (pr2 α) (pr2 β)). Proof. use (invmaponpathsincl (idtoiso_2_1 _ _)). - apply isinclweq. exact (HB _ _ _ _). - etrans. { apply idtoiso_2_1_concat. } use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite !idtoiso_2_1_isotoid_2_1. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/Core/Unitors.v000066400000000000000000000134071451125700300220030ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi April 2018 We formalize the proof showing that in a bicategory, left and right unitor coincide on the identity. We follow Joyal and Ross' Braided Tensor Categories, Proposition 1.1 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Local Open Scope cat. Section unitors. Context {C : bicat}. (** The triangle with "?" in the proof of the Proposition *) Lemma runitor_rwhisker_rwhisker {a b c d: C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : (rassociator f g (identity c) ▹ h) • ((f ◃ runitor g) ▹ h) = runitor (f · g) ▹ h. Proof. (** rewrite with uppler left triangle *) apply pathsinv0. etrans. { apply pathsinv0. apply lunitor_lwhisker. } (** attach rassociator on both sides *) apply (vcomp_rcancel (rassociator _ _ _ )). { apply is_invertible_2cell_rassociator. } (** rewrite upper right square *) etrans. { apply vassocl. } etrans. { apply maponpaths. apply pathsinv0, lwhisker_lwhisker_rassociator. } (** rewrite lower middle square *) apply pathsinv0. etrans. { apply vassocl. } etrans. { apply maponpaths. apply pathsinv0, rwhisker_lwhisker_rassociator. } (** rewrite lower right triangle *) etrans. { do 3 apply maponpaths. apply pathsinv0. apply lunitor_lwhisker. } (** distribute the whiskering *) etrans. { do 2 apply maponpaths. apply pathsinv0, lwhisker_vcomp. } (** remove trailing lunitor *) etrans. { apply vassocr. } etrans. { apply vassocr. } apply pathsinv0. etrans. { apply vassocr. } apply maponpaths_2. (** turn the rassociators into lassociators *) use inv_cell_eq. - use is_invertible_2cell_vcomp. + apply is_invertible_2cell_rassociator. + apply is_invertible_2cell_rassociator. - use is_invertible_2cell_vcomp. + use is_invertible_2cell_vcomp. * apply is_invertible_2cell_rwhisker. apply is_invertible_2cell_rassociator. * apply is_invertible_2cell_rassociator. + apply is_invertible_2cell_lwhisker. apply is_invertible_2cell_rassociator. - cbn. apply pathsinv0. etrans. { apply vassocr. } apply lassociator_lassociator. Qed. Lemma rwhisker_id_inj {a b : C} (f g : C⟦a, b⟧) (x y : f ==> g) : x ▹ identity b = y ▹ identity b → x = y. Proof. intro H. apply (vcomp_lcancel (runitor _)). - apply is_invertible_2cell_runitor. - etrans. { apply pathsinv0, vcomp_runitor. } etrans. 2: apply vcomp_runitor. apply maponpaths_2. apply H. Qed. Lemma lwhisker_id_inj {a b : C} (f g : C⟦a, b⟧) (x y : f ==> g) : identity a ◃ x = identity a ◃ y → x = y. Proof. intro H. apply (vcomp_lcancel (lunitor _)). - apply is_invertible_2cell_lunitor. - etrans. { apply pathsinv0, vcomp_lunitor. } etrans. 2: apply vcomp_lunitor. apply maponpaths_2. apply H. Qed. (** The first triangle in the Proposition *) (** a · (1 ⊗ r) = r *) Lemma runitor_triangle {a b c: C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : rassociator f g (identity c) • (f ◃ runitor g) = runitor (f · g). Proof. apply rwhisker_id_inj. etrans. 2: apply runitor_rwhisker_rwhisker. apply pathsinv0, rwhisker_vcomp. Qed. (** The square in the Proposition *) (** r = r ⊗ 1 *) Lemma runitor_is_runitor_rwhisker (a : C) : runitor (identity a · identity a) = runitor (identity a) ▹ (identity a). Proof. apply (vcomp_rcancel (runitor _ )). - apply is_invertible_2cell_runitor. - apply pathsinv0. apply vcomp_runitor . Qed. (** l = 1 ⊗ l *) Lemma lunitor_is_lunitor_lwhisker (a : C) : lunitor (identity a · identity a) = identity a ◃ lunitor (identity a). Proof. apply (vcomp_rcancel (lunitor _ )). - apply is_invertible_2cell_lunitor. - apply pathsinv0. apply vcomp_lunitor . Qed. (** 1 ⊗ r = 1 ⊗ l *) Lemma lwhisker_runitor_lunitor (a : C) : identity a ◃ runitor (identity a) = identity a ◃ lunitor (identity a). Proof. apply (vcomp_lcancel (rassociator _ _ _ )). - apply is_invertible_2cell_rassociator. - rewrite runitor_triangle. rewrite lunitor_lwhisker. apply runitor_is_runitor_rwhisker. Qed. Lemma runitor_lunitor_identity (a : C) : runitor (identity a) = lunitor (identity a). Proof. apply (vcomp_lcancel (lunitor _ )). { apply is_invertible_2cell_lunitor. } etrans. { apply pathsinv0. apply vcomp_lunitor. } etrans. { apply maponpaths_2. apply lwhisker_runitor_lunitor. } apply maponpaths_2. apply (!lunitor_is_lunitor_lwhisker _). Qed. Lemma lunitor_runitor_identity (a : C) : lunitor (identity a) = runitor (identity a). Proof. apply (! runitor_lunitor_identity _ ). Qed. End unitors. (* ----------------------------------------------------------------------------------- *) (** ** Examples of laws derived by reversing morphisms or cells. *) (* ----------------------------------------------------------------------------------- *) Definition rinvunitor_triangle (C : bicat) (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) : (f ◃ rinvunitor g) • lassociator f g (identity c) = rinvunitor (f · g) := runitor_triangle (C := op2_bicat C) f g. Definition lunitor_triangle (C : bicat) (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) : lassociator (identity a) f g • (lunitor f ▹ g) = lunitor (f · g) := runitor_triangle (C := op1_bicat C) g f. UniMath-20231010/UniMath/Bicategories/Core/Univalence.v000066400000000000000000000416521451125700300224340ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Univalence for bicategories Benedikt Ahrens, Marco Maggesi May 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.BicategoryLaws. Local Open Scope bicategory_scope. Local Open Scope cat. Section Idtoiso. Context {C : bicat}. Definition internal_adjunction_data_identity (a : C) : left_adjoint_data (identity a). Proof. exists (identity a). exact (linvunitor (identity a),, lunitor (identity a)). Defined. Lemma is_internal_adjunction_identity (a : C) : left_adjoint_axioms (internal_adjunction_data_identity a). Proof. split. - etrans. { apply maponpaths_2. etrans; [apply (!vassocr _ _ _) | ]. etrans. { apply maponpaths. etrans; [apply lunitor_lwhisker | ]. apply maponpaths, pathsinv0, lunitor_runitor_identity. } etrans; [apply (!vassocr _ _ _) | ]. etrans. { apply maponpaths. etrans; [apply rwhisker_vcomp | ]. etrans; [apply maponpaths, linvunitor_lunitor | ]. apply id2_rwhisker. } apply id2_right. } etrans; [apply maponpaths, pathsinv0, lunitor_runitor_identity | ]. apply linvunitor_lunitor. - etrans. { apply maponpaths_2. etrans; [apply (!vassocr _ _ _) | ]. etrans. { apply maponpaths. etrans. { apply maponpaths. apply maponpaths. apply lunitor_runitor_identity. } apply runitor_rwhisker. } etrans; [apply (!vassocr _ _ _) | ]. apply maponpaths. etrans; [ apply lwhisker_vcomp | ]. apply maponpaths. apply linvunitor_lunitor. } etrans; [apply (!vassocr _ _ _) | ]. etrans. { apply maponpaths. etrans; [apply maponpaths_2, lwhisker_id2 | ]. apply id2_left. } etrans; [apply maponpaths, lunitor_runitor_identity | ]. apply rinvunitor_runitor. Qed. Definition internal_adjoint_equivalence_identity (a : C) : adjoint_equivalence a a. Proof. exists (identity a). use tpair. - apply internal_adjunction_data_identity. - split; [ apply is_internal_adjunction_identity |]. split. + apply is_invertible_2cell_linvunitor. + apply is_invertible_2cell_lunitor. Defined. Definition idtoiso_2_0 (a b : C) : a = b -> adjoint_equivalence a b. Proof. induction 1. apply internal_adjoint_equivalence_identity. Defined. Definition idtoiso_2_1 {a b : C} (f g : C⟦a,b⟧) : f = g -> invertible_2cell f g. Proof. induction 1. apply id2_invertible_2cell. Defined. End Idtoiso. Definition is_univalent_2_1 (C : bicat) : UU := ∏ (a b : C) (f g : C⟦a,b⟧), isweq (idtoiso_2_1 f g). Definition is_univalent_2_0 (C : bicat) : UU := ∏ (a b : C), isweq (idtoiso_2_0 a b). Definition is_univalent_2 (C : bicat) : UU := is_univalent_2_0 C × is_univalent_2_1 C. Lemma isaprop_is_univalent_2_1 (C : bicat) : isaprop (is_univalent_2_1 C). Proof. do 4 (apply impred ; intro). apply isapropisweq. Qed. Lemma isaprop_is_univalent_2_0 (C : bicat) : isaprop (is_univalent_2_0 C). Proof. do 2 (apply impred ; intro). apply isapropisweq. Qed. Lemma isaprop_is_univalent_2 (C : bicat) : isaprop (is_univalent_2 C). Proof. apply isapropdirprod. - apply isaprop_is_univalent_2_0. - apply isaprop_is_univalent_2_1. Qed. Definition isotoid_2_1 {C : bicat} (HC : is_univalent_2_1 C) {a b : C} {f g : C⟦a,b⟧} (α : invertible_2cell f g) : f = g := invmap (idtoiso_2_1 f g ,, HC a b f g) α. Definition isotoid_2_0 {C : bicat} (HC : is_univalent_2_0 C) {a b : C} (f : adjoint_equivalence a b) : a = b := invmap (idtoiso_2_0 a b ,, HC a b) f. (** In a univalent bicategory 0-cells are 1-types. For the proofs that 1-cells are 2-types see AdjointUnique.v *) Lemma univalent_bicategory_1_cell_hlevel_3 (C : bicat) (HC : is_univalent_2_1 C) (a b : C) : isofhlevel 3 (C⟦a,b⟧). Proof. intros f g. apply (isofhlevelweqb _ (idtoiso_2_1 f g,, HC _ _ f g)). apply isaset_invertible_2cell. Qed. (** Local Univalence implies the hom cats are univalent *) Section IsoInvertible2Cells. Context {C : bicat}. Variable (C_is_univalent_2_1 : is_univalent_2_1 C). Definition idtoiso_alt_weq {a b : C} (f g : hom a b) : f = g ≃ z_iso f g. Proof. refine (inv2cell_to_z_iso_weq f g ∘ _)%weq. use make_weq. - exact (idtoiso_2_1 f g). - apply C_is_univalent_2_1. Defined. Definition idtoiso_weq {a b : C} (f g : hom a b) : isweq (λ p : f = g, idtoiso p). Proof. use weqhomot. + exact (idtoiso_alt_weq f g). + intro p. apply z_iso_eq. induction p. apply idpath. Defined. End IsoInvertible2Cells. Definition is_univ_hom {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) (X Y : C) : is_univalent (hom X Y). Proof. unfold is_univalent. intros a b. apply idtoiso_weq. exact C_is_univalent_2_1. Defined. Definition is_univalent_2_1_if_hom_is_univ {C : bicat} (C_local_univalent : ∏ (X Y : C), is_univalent (hom X Y)) : is_univalent_2_1 C. Proof. intros a b f g. use weqhomot. - exact (invweq (inv2cell_to_z_iso_weq f g) ∘ make_weq idtoiso (C_local_univalent _ _ _ _))%weq. - intro p. induction p. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } apply idpath. Defined. Definition is_univalent_2_1_weq_local_univ (C : bicat) : is_univalent_2_1 C ≃ (∏ (X Y : C), is_univalent (hom X Y)). Proof. use weqiff. - split. + exact is_univ_hom. + exact is_univalent_2_1_if_hom_is_univ. - apply isaprop_is_univalent_2_1. - use impred ; intro. use impred ; intro. apply isaprop_is_univalent. Defined. Definition univ_hom {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) (X Y : C) : univalent_category. Proof. use make_univalent_category. - exact (hom X Y). - exact (is_univ_hom C_is_univalent_2_1 X Y). Defined. Definition idtoiso_2_1_isotoid_2_1 {B : bicat} (HB : is_univalent_2_1 B) {a b : B} {f g : a --> b} (α : invertible_2cell f g) : idtoiso_2_1 _ _ (isotoid_2_1 HB α) = α. Proof. unfold isotoid_2_1. exact (homotweqinvweq (make_weq (idtoiso_2_1 f g) (HB _ _ f g)) α). Defined. Definition isotoid_2_1_idtoiso_2_1 {B : bicat} (HB : is_univalent_2_1 B) {a b : B} {f g : a --> b} (p : f = g) : isotoid_2_1 HB (idtoiso_2_1 _ _ p) = p. Proof. unfold isotoid_2_1. exact (homotinvweqweq (make_weq (idtoiso_2_1 f g) (HB _ _ f g)) p). Defined. Definition idtoiso_2_0_isotoid_2_0 {B : bicat} (HB : is_univalent_2_0 B) {a b : B} (f : adjoint_equivalence a b) : idtoiso_2_0 _ _ (isotoid_2_0 HB f) = f. Proof. unfold isotoid_2_0. exact (homotweqinvweq (make_weq (idtoiso_2_0 a b) (HB a b)) f). Defined. Definition isotoid_2_0_idtoiso_2_0 {B : bicat} (HB : is_univalent_2_0 B) {a b : B} (p : a = b) : isotoid_2_0 HB (idtoiso_2_0 _ _ p) = p. Proof. unfold isotoid_2_0. exact (homotinvweqweq (make_weq (idtoiso_2_0 a b) (HB a b)) p). Defined. (* ----------------------------------------------------------------------------------- *) (** ** J rule for locally univalent bicategories *) (* ----------------------------------------------------------------------------------- *) Section J21. Context {B : bicat}. Variable (HB : is_univalent_2_1 B) (Y : ∏ (a b : B) (f g : a --> b), invertible_2cell f g → UU) (r : ∏ (a b : B) (f : a --> b), Y _ _ _ _ (id2_invertible_2cell f)). Local Definition Y'_2_1 {a b : B} {f g : a --> b} (p : f = g) : UU := Y a b f g (idtoiso_2_1 f g p). Local Definition J'_2_1 {a b : B} {f g : a --> b} (p : f = g) : Y'_2_1 p. Proof. induction p. exact (r a b f). Defined. Local Lemma J'_2_1_transport {a b : B} {f g : a --> b} (p q : f = g) (s : p = q) : transportf Y'_2_1 s (J'_2_1 p) = J'_2_1 q. Proof. induction s. exact (idpath _). Defined. Definition J_2_1 {a b : B} {f g : a --> b} (α : invertible_2cell f g) : Y a b f g α := transportf (Y a b f g) (idtoiso_2_1_isotoid_2_1 HB α) (J'_2_1 (isotoid_2_1 HB α)). Definition J_2_1_comp {a b : B} {f : a --> b} : J_2_1 (id2_invertible_2cell f) = r a b f. Proof. unfold J_2_1. refine (! (!_ @ _)). + exact (J'_2_1_transport _ _ (isotoid_2_1_idtoiso_2_1 HB (idpath f))). + rewrite (functtransportf (idtoiso_2_1 f f) (Y a b f f)). apply maponpaths_2. exact (homotweqinvweqweq (make_weq (idtoiso_2_1 f f) (HB _ _ f f)) (idpath f)). Qed. End J21. (* ----------------------------------------------------------------------------------- *) (** ** J rule for globally univalent bicategories *) (* ----------------------------------------------------------------------------------- *) Section J20. Context {B : bicat}. Variable (HB : is_univalent_2_0 B) (Y : ∏ (a b : B), adjoint_equivalence a b → UU) (r : ∏ (a : B), Y _ _ (internal_adjoint_equivalence_identity a)). Local Definition Y'_2_0 : ∏ {a b : B}, a = b → UU := λ a b p, Y a b (idtoiso_2_0 a b p). Local Definition J'_2_0 {a b : B} (p : a = b) : Y'_2_0 p. Proof. induction p. exact (r a). Defined. Local Lemma J'_2_0_transport {a b : B} (p q : a = b) (s : p = q) : transportf Y'_2_0 s (J'_2_0 p) = J'_2_0 q. Proof. induction s. exact (idpath _). Qed. Definition J_2_0 {a b : B} (f : adjoint_equivalence a b) : Y a b f := transportf (Y a b) (idtoiso_2_0_isotoid_2_0 HB f) (J'_2_0 (isotoid_2_0 HB f)). Lemma J_2_0_comp {a : B} : J_2_0 (internal_adjoint_equivalence_identity a) = r a. Proof. unfold J_2_0. refine (! (!_ @ _)). + exact (J'_2_0_transport _ _ (isotoid_2_0_idtoiso_2_0 HB (idpath a))). + rewrite (functtransportf (idtoiso_2_0 a a) (Y a a)). apply maponpaths_2. exact (homotweqinvweqweq (make_weq (idtoiso_2_0 a a) (HB a a)) (idpath a)). Qed. End J20. (* ----------------------------------------------------------------------------------- *) (** ** Application of J: *) (** ** Adjoint equivalences in a globally univalent bicategory form a bigroupoid *) (* ----------------------------------------------------------------------------------- *) Section AdjointEquivPregroupoid. Context {B : bicat}. Variable (HB : is_univalent_2_0 B). Definition comp_adjoint_equivalence (a b c : B) (f : adjoint_equivalence a b) (g : adjoint_equivalence b c) : adjoint_equivalence a c := J_2_0 HB (λ a b _, ∏ (c : B), adjoint_equivalence b c → adjoint_equivalence a c) (λ _ _ h, h) f c g. Definition inv_adjoint_equivalence (a b : B) (f : adjoint_equivalence a b) : adjoint_equivalence b a := J_2_0 HB (λ a b _, adjoint_equivalence b a) internal_adjoint_equivalence_identity f. Lemma adjoint_equivalence_lid (a b : B) (f : adjoint_equivalence a b) : comp_adjoint_equivalence a a b (internal_adjoint_equivalence_identity a) f = f. Proof. apply (J_2_0 HB (λ a b f, comp_adjoint_equivalence a a b (internal_adjoint_equivalence_identity a) f = f)). intro c. unfold comp_adjoint_equivalence. rewrite J_2_0_comp. apply idpath. Qed. Lemma adjoint_equivalence_rid (a b : B) (f : adjoint_equivalence a b) : comp_adjoint_equivalence a b b f (internal_adjoint_equivalence_identity b) = f. Proof. apply (J_2_0 HB (λ a b f, comp_adjoint_equivalence a b b f (internal_adjoint_equivalence_identity b) = f)). intro c. unfold comp_adjoint_equivalence. rewrite J_2_0_comp. apply idpath. Qed. Lemma adjoint_equivalence_assoc (a b c d : B) (f : adjoint_equivalence a b) (g : adjoint_equivalence b c) (h : adjoint_equivalence c d) : comp_adjoint_equivalence a b d f (comp_adjoint_equivalence b c d g h) = comp_adjoint_equivalence a c d (comp_adjoint_equivalence a b c f g) h. Proof. apply (J_2_0 HB (λ a b f, ∏ (c d : B) (g : adjoint_equivalence b c) (h : adjoint_equivalence c d), comp_adjoint_equivalence a b d f (comp_adjoint_equivalence b c d g h) = comp_adjoint_equivalence a c d (comp_adjoint_equivalence a b c f g) h)). intros. rewrite adjoint_equivalence_lid. apply maponpaths_2. rewrite adjoint_equivalence_lid. exact (idpath _). Qed. Lemma adjoint_equivalence_linv (a b : B) (f : adjoint_equivalence a b) : comp_adjoint_equivalence b a b (inv_adjoint_equivalence a b f) f = internal_adjoint_equivalence_identity b. Proof. apply (J_2_0 HB (λ a b f, comp_adjoint_equivalence b a b (inv_adjoint_equivalence a b f) f = internal_adjoint_equivalence_identity b)). intro c. rewrite adjoint_equivalence_rid. unfold inv_adjoint_equivalence. rewrite J_2_0_comp. exact (idpath _). Qed. Lemma adjoint_equivalence_rinv (a b : B) (f : adjoint_equivalence a b) : comp_adjoint_equivalence a b a f (inv_adjoint_equivalence a b f) = internal_adjoint_equivalence_identity a. Proof. apply (J_2_0 HB (λ a b f, comp_adjoint_equivalence a b a f (inv_adjoint_equivalence a b f) = internal_adjoint_equivalence_identity a)). intro c. rewrite adjoint_equivalence_lid. unfold inv_adjoint_equivalence. rewrite J_2_0_comp. exact (idpath _). Qed. Definition adjoint_equivalence_precategory_data : precategory_data. Proof. use make_precategory_data. - use tpair. + exact B. + exact adjoint_equivalence. - exact internal_adjoint_equivalence_identity. - exact comp_adjoint_equivalence. Defined. Lemma adjoint_equivalence_is_precategory : is_precategory adjoint_equivalence_precategory_data. Proof. use make_is_precategory_one_assoc. - exact adjoint_equivalence_lid. - exact adjoint_equivalence_rid. - exact adjoint_equivalence_assoc. Qed. Definition adjoint_equivalence_precategory : precategory. Proof. use make_precategory. - exact adjoint_equivalence_precategory_data. - exact adjoint_equivalence_is_precategory. Defined. (* Definition adjoint_equivalence_is_pregroupoid : is_pregroupoid adjoint_equivalence_precategory. Proof. intros a b f. use is_iso_qinv. - exact (inv_adjoint_equivalence a b f). - split. + exact (adjoint_equivalence_rinv a b f). + exact (adjoint_equivalence_linv a b f). Defined. Definition adjoint_equivalence_pregroupoid : pregroupoid. Proof. use make_pregroupoid. - exact adjoint_equivalence_precategory. - exact adjoint_equivalence_is_pregroupoid. Defined. *) End AdjointEquivPregroupoid. Definition left_adjequiv_invertible_2cell {D : bicat} (HD : is_univalent_2_1 D) {a b : D} (f g : a --> b) (α : invertible_2cell f g) : left_adjoint_equivalence f → left_adjoint_equivalence g := J_2_1 HD (λ a b f g α, left_adjoint_equivalence f → left_adjoint_equivalence g) (λ _ _ _ p, p) α. UniMath-20231010/UniMath/Bicategories/Core/UnivalenceOp.v000066400000000000000000000122151451125700300227240ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Univalence for opposite bicategories Benedikt Ahrens, Marco Maggesi May 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInOp1Bicat. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Local Open Scope bicategory_scope. Local Open Scope cat. Definition op1_bicat_idtoiso_2_1_alt {C : bicat} {X Y : op1_bicat C} (C_is_univalent_2_1 : is_univalent_2_1 C) (f g : X --> Y) : f = g ≃ invertible_2cell f g := ((bicat_invertible_2cell_is_op1_bicat_invertible_2cell f g) ∘ make_weq (@idtoiso_2_1 C Y X f g) (C_is_univalent_2_1 Y X f g))%weq. Definition op1_bicat_is_univalent_2_1 {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) : is_univalent_2_1 (op1_bicat C). Proof. intros X Y f g. use weqhomot. - exact (op1_bicat_idtoiso_2_1_alt C_is_univalent_2_1 f g). - intros p. induction p. use subtypePath. { apply isPredicate_is_invertible_2cell. } apply idpath. Defined. Definition op1_bicat_idtoiso_2_0_alt {C : bicat} (C_is_univalent_2_0 : is_univalent_2_0 C) (X Y : op1_bicat C) : X = Y ≃ adjoint_equivalence X Y := ((bicat_adjoint_equivalence_is_op1_bicat_adjoint_equivalence X Y) ∘ make_weq (@idtoiso_2_0 C Y X) (C_is_univalent_2_0 Y X) ∘ weqpathsinv0 _ _)%weq. Definition op1_bicat_is_univalent_2_0 {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) (C_is_univalent_2_0 : is_univalent_2_0 C) : is_univalent_2_0 (op1_bicat C). Proof. intros X Y. use weqhomot. - exact (op1_bicat_idtoiso_2_0_alt C_is_univalent_2_0 X Y). - intros p. induction p. use subtypePath. { intro ; apply isaprop_left_adjoint_equivalence. apply op1_bicat_is_univalent_2_1. exact C_is_univalent_2_1. } apply idpath. Defined. Definition op1_bicat_is_univalent_2 {C : bicat} (C_is_univalent_2 : is_univalent_2 C) : is_univalent_2 (op1_bicat C). Proof. split. - apply op1_bicat_is_univalent_2_0 ; apply C_is_univalent_2. - apply op1_bicat_is_univalent_2_1 ; apply C_is_univalent_2. Defined. Definition op2_bicat_idtoiso_2_1_alt {C : bicat} {X Y : op2_bicat C} (C_is_univalent_2_1 : is_univalent_2_1 C) (f g : X --> Y) : f = g ≃ invertible_2cell f g := ((weq_op2_invertible_2cell f g) ∘ make_weq (@idtoiso_2_1 C _ _ g f) (C_is_univalent_2_1 _ _ g f) ∘ weqpathsinv0 _ _)%weq. Definition op2_bicat_is_univalent_2_1 {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) : is_univalent_2_1 (op2_bicat C). Proof. intros X Y f g. use weqhomot. - exact (op2_bicat_idtoiso_2_1_alt C_is_univalent_2_1 f g). - intros p. induction p. use subtypePath. { apply isPredicate_is_invertible_2cell. } apply idpath. Defined. Definition op2_bicat_idtoiso_2_0_alt {C : bicat} (C_is_univalent_2_0 : is_univalent_2_0 C) (X Y : op2_bicat C) : X = Y ≃ adjoint_equivalence X Y := ((weq_op2_adjequiv X Y) ∘ make_weq (@idtoiso_2_0 C X Y) (C_is_univalent_2_0 X Y))%weq. Definition op2_bicat_is_univalent_2_0 {C : bicat} (C_is_univalent_2_1 : is_univalent_2_1 C) (C_is_univalent_2_0 : is_univalent_2_0 C) : is_univalent_2_0 (op2_bicat C). Proof. intros X Y. use weqhomot. - exact (op2_bicat_idtoiso_2_0_alt C_is_univalent_2_0 X Y). - intros p. induction p. use subtypePath. { intro ; apply isaprop_left_adjoint_equivalence. apply op2_bicat_is_univalent_2_1. exact C_is_univalent_2_1. } apply idpath. Defined. Definition op2_bicat_is_univalent_2 {C : bicat} (C_is_univalent_2 : is_univalent_2 C) : is_univalent_2 (op2_bicat C). Proof. split. - apply op2_bicat_is_univalent_2_0 ; apply C_is_univalent_2. - apply op2_bicat_is_univalent_2_1 ; apply C_is_univalent_2. Defined. (** Being a right-adjoint is a property *) Definition isaprop_internal_right_adj {B : bicat} (HB : is_univalent_2_1 B) {x y : B} (f : x --> y) : isaprop (internal_right_adj f). Proof. apply (isofhlevelweqf 1 (@op1_left_adjoint_weq_right_adjoint B x y f)). apply isaprop_left_adjoint. apply op1_bicat_is_univalent_2_1. exact HB. Qed. UniMath-20231010/UniMath/Bicategories/Core/YonedaLemma.v000066400000000000000000000665051451125700300225420ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Yoneda Lemma Niccolo Veltri, Niels van der Weide June 2019 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.UnivalenceOp. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Yoneda. Require Import UniMath.Bicategories.PseudoFunctors.Representable. Require Import UniMath.Bicategories.Core.Examples.Image. Require Import UniMath.Bicategories.PseudoFunctors.Examples.CorestrictImage. Local Open Scope bicategory_scope. Local Open Scope cat. Opaque psfunctor. Section YonedaLemma. Context {B : bicat}. Variable (B_is_univalent_2_1 : is_univalent_2_1 B) (F : psfunctor (op1_bicat B) bicat_of_univ_cats) (X : B). (** First, we construct a functor from the yoneda to the presheaf *) Definition yoneda_to_presheaf_data_ob : pstrans (representable B_is_univalent_2_1 X) F → pr1 (F X). Proof. intro τ. pose (τ X) as f; cbn in f. exact (f (identity X)). Defined. Definition yoneda_to_presheaf_data_mor (η₁ η₂ : pstrans (representable B_is_univalent_2_1 X) F) (m : modification η₁ η₂) : yoneda_to_presheaf_data_ob η₁ --> yoneda_to_presheaf_data_ob η₂. Proof. pose (m X) as n; cbn in n. exact (n (identity X)). Defined. Definition yoneda_to_presheaf_data : functor_data (univ_hom (psfunctor_bicat_is_univalent_2_1 (op1_bicat B) bicat_of_univ_cats univalent_cat_is_univalent_2_1) (y B_is_univalent_2_1 X) F) (F X : univalent_category). Proof. use make_functor_data. - exact yoneda_to_presheaf_data_ob. - exact yoneda_to_presheaf_data_mor. Defined. Lemma yoneda_to_presheaf_is_functor : is_functor yoneda_to_presheaf_data. Proof. split. - intro η ; cbn. apply idpath. - intros η₁ η₂ η₃ f g ; cbn. apply idpath. Qed. Definition yoneda_to_presheaf : bicat_of_univ_cats ⟦ univ_hom (psfunctor_bicat_is_univalent_2_1 _ _ univalent_cat_is_univalent_2_1) (y B_is_univalent_2_1 X) F , F X ⟧. Proof. use make_functor. - exact yoneda_to_presheaf_data. - exact yoneda_to_presheaf_is_functor. Defined. (** Next, we construct a functor in the opposite direction *) Section PresheafToYonedaOb. Variable (x : (F X : univalent_category)). Definition presheaf_to_yoneda_ob_pstrans_functor_ob (Y : op1_bicat B) : B ⟦ Y , X ⟧ → pr1 (F Y) := λ f, (#F f : _ ⟶ _) x. Definition presheaf_to_yoneda_ob_pstrans_functor_mor (Y : op1_bicat B) (f g : B ⟦ Y , X ⟧) (α : f ==> g) : (presheaf_to_yoneda_ob_pstrans_functor_ob Y f) --> presheaf_to_yoneda_ob_pstrans_functor_ob Y g := (##F α : nat_trans _ _) x. Definition presheaf_to_yoneda_ob_pstrans_functor_data (Y : op1_bicat B) : functor_data (@hom B Y X) (pr1 (F Y)). Proof. use make_functor_data. - exact (presheaf_to_yoneda_ob_pstrans_functor_ob Y). - exact (presheaf_to_yoneda_ob_pstrans_functor_mor Y). Defined. Lemma presheaf_to_yoneda_ob_pstrans_is_functor (Y : op1_bicat B) : is_functor (presheaf_to_yoneda_ob_pstrans_functor_data Y). Proof. split. - intro f ; cbn. unfold presheaf_to_yoneda_ob_pstrans_functor_mor ; unfold presheaf_to_yoneda_ob_pstrans_functor_ob. exact (nat_trans_eq_pointwise (psfunctor_id2 F f) x). - intros f₁ f₂ f₃ α₁ α₂ ; cbn. unfold presheaf_to_yoneda_ob_pstrans_functor_mor. exact (nat_trans_eq_pointwise (psfunctor_vcomp F α₁ α₂) x). Qed. Definition presheaf_to_yoneda_ob_pstrans_functor (Y : op1_bicat B) : bicat_of_univ_cats ⟦ @univ_hom B B_is_univalent_2_1 Y X , F Y ⟧. Proof. use make_functor. - exact (presheaf_to_yoneda_ob_pstrans_functor_data Y). - exact (presheaf_to_yoneda_ob_pstrans_is_functor Y). Defined. Definition presheaf_to_yoneda_ob_pstrans_nat_trans_data (Y₁ Y₂ : op1_bicat B) (f : B ⟦ Y₂ , Y₁ ⟧) : nat_trans_data (presheaf_to_yoneda_ob_pstrans_functor Y₁ · # F f : _ ⟶ _) (#(y B_is_univalent_2_1 X : psfunctor _ _) f · presheaf_to_yoneda_ob_pstrans_functor Y₂ : _ ⟶ _). Proof. intros g ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_ob. pose (psfunctor_comp F g f : _ ==> _) as p ; cbn in p. exact (p x). Defined. Lemma presheaf_to_yoneda_ob_pstrans_is_nat_trans (Y₁ Y₂ : op1_bicat B) (f : B ⟦ Y₂ , Y₁ ⟧) : is_nat_trans _ _ (presheaf_to_yoneda_ob_pstrans_nat_trans_data Y₁ Y₂ f). Proof. intros g₁ g₂ α ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_mor ; unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data. pose (psfunctor_rwhisker F f α) as p. pose (nat_trans_eq_pointwise p x) as q. exact (!q). Qed. Definition presheaf_to_yoneda_ob_pstrans_nat_trans (Y₁ Y₂ : op1_bicat B) (f : B ⟦ Y₂ , Y₁ ⟧) : (presheaf_to_yoneda_ob_pstrans_functor Y₁ · # F f) ==> #(y B_is_univalent_2_1 X : psfunctor _ _) f · presheaf_to_yoneda_ob_pstrans_functor Y₂. Proof. use make_nat_trans. - exact (presheaf_to_yoneda_ob_pstrans_nat_trans_data Y₁ Y₂ f). - exact (presheaf_to_yoneda_ob_pstrans_is_nat_trans Y₁ Y₂ f). Defined. Definition presheaf_to_yoneda_ob_pstrans_is_nat_z_iso (Y₁ Y₂ : op1_bicat B) (f : B ⟦ Y₂ , Y₁ ⟧) : is_nat_z_iso (pr1 (presheaf_to_yoneda_ob_pstrans_nat_trans Y₁ Y₂ f)). Proof. intro g ; cbn in g. unfold presheaf_to_yoneda_ob_pstrans_nat_trans. simpl. unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data. pose (is_invertible_2cell_to_is_nat_z_iso (psfunctor_comp F g f)) as i. apply i. exact (psfunctor_comp F g f). Defined. Definition presheaf_to_yoneda_ob_pstrans_data : pstrans_data ((y B_is_univalent_2_1) X) F. Proof. pose x. use make_pstrans_data. - exact presheaf_to_yoneda_ob_pstrans_functor. - intros Y₁ Y₂ f. use make_invertible_2cell. + exact (presheaf_to_yoneda_ob_pstrans_nat_trans Y₁ Y₂ f). + apply is_nat_z_iso_to_is_invertible_2cell. exact (presheaf_to_yoneda_ob_pstrans_is_nat_z_iso Y₁ Y₂ f). Defined. Lemma presheaf_to_yoneda_ob_pstrans_is_pstrans : is_pstrans presheaf_to_yoneda_ob_pstrans_data. Proof. repeat split. - intros Y₁ Y₂ g₁ g₂ α. apply nat_trans_eq. { apply homset_property. } intro h ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_ob, presheaf_to_yoneda_ob_pstrans_functor_mor, presheaf_to_yoneda_ob_pstrans_nat_trans_data. pose (psfunctor_lwhisker F h α). pose (nat_trans_eq_pointwise p x) as q. exact (!q). - intros Y. apply nat_trans_eq. { apply homset_property. } intro h ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_ob, presheaf_to_yoneda_ob_pstrans_functor_mor, presheaf_to_yoneda_ob_pstrans_nat_trans_data. refine (!_). etrans. { etrans. { apply maponpaths_2. apply id_left. } etrans. { apply id_left. } exact (nat_trans_eq_pointwise (psfunctor_rinvunitor F h) x). } cbn -[psfunctor_id psfunctor_comp]. apply maponpaths_2. apply id_left. - intros Y₁ Y₂ Y₃ g₁ g₂. apply nat_trans_eq. { apply homset_property. } intro h ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_ob, presheaf_to_yoneda_ob_pstrans_functor_mor, presheaf_to_yoneda_ob_pstrans_nat_trans_data. refine (!_). etrans. { etrans. { apply maponpaths_2. etrans. { apply id_right. } apply maponpaths_2. etrans. { apply id_right. } apply id_left. } exact (nat_trans_eq_pointwise (psfunctor_rassociator F h g₁ g₂) x). } simpl. etrans. { apply maponpaths_2. apply id_left. } apply idpath. Qed. Definition presheaf_to_yoneda_ob : pstrans (y B_is_univalent_2_1 X) F. Proof. use make_pstrans. - exact presheaf_to_yoneda_ob_pstrans_data. - exact presheaf_to_yoneda_ob_pstrans_is_pstrans. Defined. End PresheafToYonedaOb. Section PresheafToYonedaMor. Variable (a b : (F X : univalent_category)) (f : a --> b). Definition presheaf_to_yoneda_mor_modification_nat_trans_data (Y : op1_bicat B) : nat_trans_data ((presheaf_to_yoneda_ob a) Y : _ ⟶ _) ((presheaf_to_yoneda_ob b) Y : _ ⟶ _) := λ h, #(#F h : _ ⟶ _) f. Lemma presheaf_to_yoneda_mor_modification_is_nat_trans (Y : op1_bicat B) : is_nat_trans _ _ (presheaf_to_yoneda_mor_modification_nat_trans_data Y). Proof. intros h₁ h₂ α ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_functor_mor, presheaf_to_yoneda_mor_modification_nat_trans_data. pose (pr2 (##F α : _ ⟹ _)) as p. exact (!(p a b f)). Qed. Definition presheaf_to_yoneda_mor_modification_data : modification_data (presheaf_to_yoneda_ob a) (presheaf_to_yoneda_ob b). Proof. intros Y. use make_nat_trans. - exact (presheaf_to_yoneda_mor_modification_nat_trans_data Y). - exact (presheaf_to_yoneda_mor_modification_is_nat_trans Y). Defined. Lemma presheaf_to_yoneda_mor_is_modification : is_modification presheaf_to_yoneda_mor_modification_data. Proof. intros Y₁ Y₂ g. apply nat_trans_eq. { apply homset_property. } intros h ; cbn in *. unfold presheaf_to_yoneda_ob_pstrans_nat_trans_data, presheaf_to_yoneda_mor_modification_nat_trans_data. pose (pr21 (psfunctor_comp F h g)) as p. exact (!(p a b f)). Qed. Definition presheaf_to_yoneda_mor_modification : modification (presheaf_to_yoneda_ob a) (presheaf_to_yoneda_ob b). Proof. use make_modification. - exact presheaf_to_yoneda_mor_modification_data. - exact presheaf_to_yoneda_mor_is_modification. Defined. End PresheafToYonedaMor. Definition presheaf_to_yoneda_data : functor_data (F X : univalent_category) (univ_hom (psfunctor_bicat_is_univalent_2_1 (op1_bicat B) bicat_of_univ_cats univalent_cat_is_univalent_2_1) ((y B_is_univalent_2_1) X) F). Proof. use make_functor_data. - exact presheaf_to_yoneda_ob. - exact presheaf_to_yoneda_mor_modification. Defined. Lemma presheaf_to_yoneda_is_functor : is_functor presheaf_to_yoneda_data. Proof. split. - intros z. apply modification_eq. intros Z. apply nat_trans_eq. { apply homset_property. } intros f. cbn in *. unfold presheaf_to_yoneda_mor_modification_nat_trans_data, presheaf_to_yoneda_ob_pstrans_functor_ob. apply functor_id. - intros z₁ z₂ z₃ f₁ f₂. apply modification_eq. intros Z. apply nat_trans_eq. { apply homset_property. } intros f. cbn in *. unfold presheaf_to_yoneda_mor_modification_nat_trans_data, presheaf_to_yoneda_ob_pstrans_functor_ob. apply functor_comp. Qed. Definition presheaf_to_yoneda : bicat_of_univ_cats ⟦ F X , univ_hom (psfunctor_bicat_is_univalent_2_1 _ _ univalent_cat_is_univalent_2_1) (y B_is_univalent_2_1 X) F ⟧. Proof. use make_functor. - exact presheaf_to_yoneda_data. - exact presheaf_to_yoneda_is_functor. Defined. Definition yoneda_unit_component_mod_component_nat_component (η : pstrans (representable B_is_univalent_2_1 X) F) (Z : op1_bicat B) (f : B ⟦ Z , X ⟧) : pr1 (F Z) ⟦ (η Z : _ ⟶ _) f , (# F f : _ ⟶ _) ((η X : _ ⟶ _) (id₁ X)) ⟧ := #(η Z : _ ⟶ _) (rinvunitor f) · pr1 ((psnaturality_of η f)^-1) (id₁ X). Lemma yoneda_unit_component_mod_component_is_nat_trans (η : pstrans (representable B_is_univalent_2_1 X) F) (Z : op1_bicat B) (f₁ f₂ : B ⟦ Z , X ⟧) (α : f₁ ==> f₂) : # (η Z : _ ⟶ _) α · yoneda_unit_component_mod_component_nat_component η Z f₂ = (yoneda_unit_component_mod_component_nat_component η Z f₁) · (## F α : _ ⟹ _) ((η X : _ ⟶ _) (id₁ X)). Proof. cbn ; unfold yoneda_unit_component_mod_component_nat_component. pose (nat_trans_eq_pointwise (psnaturality_inv_natural η _ _ _ _ α) (id₁ X)). cbn in p. refine (!_). etrans. { refine (!(assoc _ _ _) @ _). apply maponpaths. exact (nat_trans_eq_pointwise (psnaturality_inv_natural η _ _ _ _ α) (id₁ X)). } cbn. refine (assoc _ _ _ @ _ @ !(assoc _ _ _)). apply maponpaths_2. refine (!(functor_comp _ _ _) @ _ @ functor_comp _ _ _). apply maponpaths. refine (!_). refine (rinvunitor_natural _ @ _). apply maponpaths. refine (!_). apply rwhisker_hcomp. Qed. Definition yoneda_unit_component_mod_component_nat (η : pstrans (representable B_is_univalent_2_1 X) F) : modification_data ((functor_identity (hom_data (representable B_is_univalent_2_1 X) F)) η) ((yoneda_to_presheaf ∙ presheaf_to_yoneda) η). Proof. intro Z. use make_nat_trans. - exact (yoneda_unit_component_mod_component_nat_component η Z). - exact (yoneda_unit_component_mod_component_is_nat_trans η Z). Defined. Lemma yoneda_unit_component_is_modification (η : pstrans (representable B_is_univalent_2_1 X) F) : is_modification (yoneda_unit_component_mod_component_nat η). Proof. intros Z₁ Z₂ f. apply nat_trans_eq. { apply homset_property. } intro g ; cbn in g. cbn. unfold yoneda_unit_component_mod_component_nat_component, yoneda_to_presheaf_data_ob, presheaf_to_yoneda_ob_pstrans_nat_trans_data. cbn in f. etrans. { do 2 apply maponpaths. exact (nat_trans_eq_pointwise (pstrans_inv_comp_alt η g f) (id₁ X)). } cbn. rewrite !id_right. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply functor_comp. } apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. refine (!(assoc _ _ _) @ _). apply maponpaths. etrans. { refine (!_). apply functor_comp. } apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply rinvunitor_triangle. } cbn. refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply lassociator_rassociator. } apply id2_right. } etrans. { apply maponpaths_2. refine (!_). exact (pr21 (psnaturality_of η f) g (g · id₁ X) (rinvunitor g)). } cbn. etrans. { refine (!(assoc _ _ _) @ _). apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv (psnaturality_of η f)) (g · id₁ X)). } apply id_right. Qed. Definition yoneda_unit_component_mod (η : pstrans (representable B_is_univalent_2_1 X) F) : modification (functor_identity (hom_data (representable B_is_univalent_2_1 X) F) η) ((yoneda_to_presheaf ∙ presheaf_to_yoneda) η). Proof. use make_modification. - exact (yoneda_unit_component_mod_component_nat η). - exact (yoneda_unit_component_is_modification η). Defined. Lemma yoneda_unit_is_nat_trans : is_nat_trans (functor_identity (hom_data (representable B_is_univalent_2_1 X) F)) (yoneda_to_presheaf ∙ presheaf_to_yoneda) yoneda_unit_component_mod. Proof. intros η₁ η₂ m. apply modification_eq. intros Z. apply nat_trans_eq. { apply homset_property. } intros g ; cbn in g. cbn. unfold yoneda_unit_component_mod_component_nat_component, yoneda_to_presheaf_data_ob, presheaf_to_yoneda_mor_modification_nat_trans_data, yoneda_to_presheaf_data_mor. refine (!_). etrans. { rewrite <- assoc. apply maponpaths. exact (!(nat_trans_eq_pointwise (mod_inv_naturality_of m X Z g) (id₁ X))). } simpl. rewrite !assoc. apply maponpaths_2. exact (pr2 ((m : modification _ _) Z) _ _ (rinvunitor g)). Qed. Definition yoneda_unit : functor_identity _ ⟹ yoneda_to_presheaf ∙ presheaf_to_yoneda. Proof. use make_nat_trans. - exact yoneda_unit_component_mod. - exact yoneda_unit_is_nat_trans. Defined. Lemma yoneda_unit_is_inverses (g : pstrans (representable B_is_univalent_2_1 X) F) (Z : B) (Y : Z --> X) : is_inverse_in_precat (# (g Z : _ ⟶ _) (rinvunitor Y) · pr1 ((psnaturality_of g Y) ^-1) (id₁ X)) ((pr11 (psnaturality_of g Y)) (id₁ X) · # (g Z : _ ⟶ _) (runitor Y)). Proof. split. - rewrite <- !assoc. etrans. { apply maponpaths. etrans. { rewrite assoc. apply maponpaths_2. exact (nat_trans_eq_pointwise (vcomp_linv (psnaturality_of g Y)) (id₁ X)). } apply id_left. } refine (!(functor_comp _ _ _) @ _ @ functor_id (g Z) _). apply maponpaths. exact (rinvunitor_runitor Y). - rewrite <- !assoc. etrans. { apply maponpaths. etrans. { rewrite assoc. apply maponpaths_2. refine (!(functor_comp (g Z) _ _) @ _ @ functor_id (g Z) _). apply maponpaths. apply runitor_rinvunitor. } apply id_left. } exact (nat_trans_eq_pointwise (vcomp_rinv (psnaturality_of g Y)) (id₁ X)). Qed. Definition yoneda_unit_z_iso (g : pstrans (representable B_is_univalent_2_1 X) F) (Z : B) (Y : Z --> X) : is_z_isomorphism (# (g Z : _ ⟶ _) (rinvunitor Y) · pr1 ((psnaturality_of g Y) ^-1) (id₁ X)). Proof. use tpair. - exact (pr11 (psnaturality_of g Y) (id₁ X) · #(g Z : _ ⟶ _) (runitor Y)). - exact (yoneda_unit_is_inverses g Z Y). Defined. Definition yoneda_counit_component (Z : pr1 (F X)) : pr1 (F X) ⟦ (# F (id₁ X) : _ ⟶ _) Z, Z ⟧ := pr1 ((psfunctor_id F X)^-1) Z. Lemma yoneda_counit_is_natural : is_nat_trans _ (functor_identity _) yoneda_counit_component. Proof. intros Z₁ Z₂ h ; cbn. unfold yoneda_counit_component. pose (pr2 ((psfunctor_id F X)^-1) _ _ h) as p. exact p. Qed. Definition yoneda_counit : presheaf_to_yoneda ∙ yoneda_to_presheaf ⟹ functor_identity _. Proof. use make_nat_trans. - exact yoneda_counit_component. - exact yoneda_counit_is_natural. Defined. Definition bicategorical_yoneda_lemma : left_adjoint_equivalence yoneda_to_presheaf. Proof. apply equiv_to_isadjequiv. use tpair. - use tpair. + exact presheaf_to_yoneda. + split. * exact yoneda_unit. * exact yoneda_counit. - split. + cbn. apply is_nat_z_iso_to_is_invertible_2cell. intro g. apply is_inv2cell_to_is_z_iso. apply make_is_invertible_modification. intro Z. apply is_nat_z_iso_to_is_invertible_2cell. intros Y. exact (yoneda_unit_z_iso g Z Y). + apply is_nat_z_iso_to_is_invertible_2cell. intros Z ; cbn. unfold yoneda_counit_component. exists (pr1 (pr1 (psfunctor_id F X)) Z). split. * abstract (exact (nat_trans_eq_pointwise (vcomp_linv (psfunctor_id F X)) Z)). * abstract (exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F X)) Z)). Defined. Definition bicategorical_yoneda_lemma_inv : left_adjoint_equivalence presheaf_to_yoneda := inv_adjequiv (_ ,, bicategorical_yoneda_lemma). End YonedaLemma. Section YonedaLocalEquivalence. Context {B : bicat}. Variable (B_is_univalent_2_1 : is_univalent_2_1 B) (X Y : B). Definition yoneda_to_presheaf_representable_component_mod_component_nat (f : X --> Y) (Z : B) (g : Z --> X) : g · f ==> g · f := id₂ (g · f). Lemma yoneda_to_presheaf_representable_component_mod_is_nat_trans (f : X --> Y) (Z : B) : is_nat_trans (representable1 B_is_univalent_2_1 f Z : _ ⟶ _) (presheaf_to_yoneda_ob B_is_univalent_2_1 (representable B_is_univalent_2_1 Y) X f Z : _ ⟶ _) (yoneda_to_presheaf_representable_component_mod_component_nat f Z). Proof. intros h₁ h₂ α. cbn in *. unfold yoneda_to_presheaf_representable_component_mod_component_nat. rewrite id2_left,id2_right. apply idpath. Qed. Definition yoneda_to_presheaf_representable_component_mod_component (f : X --> Y) : modification_data (representable1 B_is_univalent_2_1 f) (presheaf_to_yoneda_ob B_is_univalent_2_1 (representable B_is_univalent_2_1 Y) X f). Proof. intros Z. use make_nat_trans. - exact (yoneda_to_presheaf_representable_component_mod_component_nat f Z). - exact (yoneda_to_presheaf_representable_component_mod_is_nat_trans f Z). Defined. Lemma yoneda_to_presheaf_representable_is_modification (f : X --> Y) : is_modification (yoneda_to_presheaf_representable_component_mod_component f). Proof. intros Z₁ Z₂ h. apply nat_trans_eq. { apply homset_property. } intros g. cbn in *. unfold yoneda_to_presheaf_representable_component_mod_component_nat. rewrite id2_right, lwhisker_id2, id2_left. apply idpath. Qed. Definition yoneda_to_presheaf_representable_component_mod (f : X --> Y) : modification (Fmor (y B_is_univalent_2_1) X Y f) ((presheaf_to_yoneda B_is_univalent_2_1 (representable B_is_univalent_2_1 Y) X : _ ⟶ _) f). Proof. use make_modification. - exact (yoneda_to_presheaf_representable_component_mod_component f). - exact (yoneda_to_presheaf_representable_is_modification f). Defined. Lemma yoneda_to_presheaf_representable_is_natural : is_nat_trans (Fmor_data (y B_is_univalent_2_1) X Y) _ yoneda_to_presheaf_representable_component_mod. Proof. intros g₁ g₂ α. apply modification_eq. intros Z. apply nat_trans_eq. { apply homset_property. } intros h. cbn in *. unfold yoneda_to_presheaf_representable_component_mod_component_nat. rewrite id2_right, id2_left. apply idpath. Qed. Definition yoneda_to_presheaf_representable : (Fmor_univ (y B_is_univalent_2_1) X Y _ _) ⟹ (presheaf_to_yoneda B_is_univalent_2_1 (representable B_is_univalent_2_1 Y) X : _⟶ _). Proof. use make_nat_trans. - exact yoneda_to_presheaf_representable_component_mod. - exact yoneda_to_presheaf_representable_is_natural. Defined. Definition yoneda_to_presheaf_representable_is_iso : @is_invertible_2cell bicat_of_univ_cats _ _ (Fmor_univ (y B_is_univalent_2_1) X Y _ _ : _ ⟶ _) _ (yoneda_to_presheaf_representable). Proof. apply is_nat_z_iso_to_is_invertible_2cell. intro g. apply is_inv2cell_to_is_z_iso. apply make_is_invertible_modification. intro Z. apply is_nat_z_iso_to_is_invertible_2cell. intros h. cbn in *. unfold yoneda_to_presheaf_representable_component_mod_component_nat. apply is_inv2cell_to_is_z_iso. is_iso. Defined. Definition yoneda_mor_is_equivalence : @left_adjoint_equivalence bicat_of_univ_cats _ _ (Fmor_univ (y B_is_univalent_2_1) X Y B_is_univalent_2_1 (psfunctor_bicat_is_univalent_2_1 (op1_bicat B) _ univalent_cat_is_univalent_2_1)). Proof. apply equiv_to_isadjequiv. exact (@left_equivalence_invertible bicat_of_univ_cats _ _ _ (presheaf_to_yoneda B_is_univalent_2_1 (representable B_is_univalent_2_1 Y) X : _⟶ _) (bicategorical_yoneda_lemma_inv B_is_univalent_2_1 _ _) _ yoneda_to_presheaf_representable_is_iso). Defined. End YonedaLocalEquivalence. Definition yoneda_local_equivalence {B : bicat} (B_is_univalent_2_1 : is_univalent_2_1 B) : local_equivalence B_is_univalent_2_1 (psfunctor_bicat_is_univalent_2_1 (op1_bicat B) _ univalent_cat_is_univalent_2_1) (y B_is_univalent_2_1). Proof. intros x y. apply yoneda_mor_is_equivalence. Defined. Definition rezk_completion_2_0 (B : bicat) (HB : is_univalent_2_1 B) : ∑ (GC : bicat) (CB : psfunctor B GC) (HGC : is_univalent_2 GC), weak_equivalence HB (pr2 HGC) CB. Proof. refine (full_image (y HB) ,, _). refine (corestrict_full_image (y HB) ,, _). use tpair. - apply is_univalent_2_full_image. apply psfunctor_bicat_is_univalent_2. exact univalent_cat_is_univalent_2. - exact (corestrict_full_image_weak_equivalence (y HB) HB _ _ (yoneda_local_equivalence HB)). Defined. UniMath-20231010/UniMath/Bicategories/DaggerCategories/000077500000000000000000000000001451125700300224535ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DaggerCategories/BicatOfDaggerCats.v000066400000000000000000000121031451125700300260730ustar00rootroot00000000000000(* In this file, we construct the bicategory DAG of dagger categories as a displayed bicategory (over CAT) and we show that the displayed bicategory is univalent. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Transformations. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.FunctorCategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Local Definition CAT : bicat := bicat_of_cats. Local Open Scope cat. Section BicatOfDaggerCategories. Definition DAG_disp_cat_ob_mor : disp_cat_ob_mor CAT. Proof. exists (λ C, dagger C). exact (λ C D dC dD F, is_dagger_functor dC dD F). Defined. Definition DAG_disp_cat_id_comp : disp_cat_id_comp CAT DAG_disp_cat_ob_mor. Proof. exists (λ C dC, dagger_functor_id dC). exact (λ C D E F G dC dD dE dF dG, is_dagger_functor_comp dF dG). Qed. Definition DAG_disp_cat_data : disp_cat_data CAT. Proof. exists DAG_disp_cat_ob_mor. exact DAG_disp_cat_id_comp. Defined. Definition DAG_disp_bicat : disp_bicat CAT := disp_cell_unit_bicat DAG_disp_cat_data. Definition DAG : bicat := total_bicat DAG_disp_bicat. Definition is_dagger_univalent (D : DAG) : UU := is_univalent_dagger (dagger_category_to_dagger D). Definition UDAG_disp_bicat : disp_bicat DAG := disp_fullsubbicat DAG (λ D, is_dagger_univalent D). Definition UDAG_sigma_disp_bicat := sigma_bicat _ _ UDAG_disp_bicat. End BicatOfDaggerCategories. Section Destructors. Definition DAG_to_cat (C : DAG) : category := pr1 C. Coercion DAG_to_cat : ob >-> category. Definition DAG_to_dagger (C : DAG) : dagger C := pr2 C. End Destructors. Section DaggerFunctorCategories. Local Definition hom_equals_dagger_functor_cat (C D : DAG) : hom C D = dagger_functor_cat (DAG_to_dagger C) (DAG_to_dagger D). Proof. use subtypePath. { intro ; apply isaprop_has_homsets. } use total2_paths_f. - apply idpath. - use proofirrelevance. repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply (cellset_property (C := DAG)). Defined. End DaggerFunctorCategories. Section DagDisplayedUnivalence. Lemma DAG_disp_univalent_2_0 : disp_univalent_2_0 DAG_disp_bicat. Proof. intros C1 C2 p dag1 dag2. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros C udag1 udag2. apply isweqimplimpl. - intro a. apply dagger_equality. repeat (apply funextsec ; intro). apply (pr1 a _). - intro ; apply isaset_dagger. - intro a. apply (isaprop_disp_adjoint_equivalence_cell_unit_bicat a) ; apply isaprop_is_dagger_functor. Qed. Lemma DAG_disp_univalent_2_1 : disp_univalent_2_1 DAG_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intro ; intros ; apply isaprop_is_dagger_functor. Qed. (* Notice that for global univalence, we don't use the premade lemma for disp_cell_unit_bicat, as is used in the local univalence. Otherwise, we would have to restrict ourselves to CatUniv instead of Cat *) Definition DAG_disp_univalent_2 : disp_univalent_2 DAG_disp_bicat := DAG_disp_univalent_2_0 ,, DAG_disp_univalent_2_1. End DagDisplayedUnivalence. Section Constructors. Definition make_dagger_transformation {C D : category} {F G : functor C D} (α : nat_trans F G) {dagC : dagger C} {dagD : dagger D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) : (hom (C := DAG) (C,,dagC) (D,,dagD)) ⟦make_dagger_functor _ _ dagF, make_dagger_functor _ _ dagG⟧ := α ,, tt. Definition make_dagger_transformation' {C D : category} {F G : functor C D} {dagC : dagger C} {dagD : dagger D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) {α : nat_trans_data F G} (αn : is_nat_trans _ _ α) : (hom (C := DAG) (C,,dagC) (D,,dagD)) ⟦make_dagger_functor _ _ dagF, make_dagger_functor _ _ dagG⟧ := make_nat_trans _ _ α αn ,, tt. End Constructors. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/000077500000000000000000000000001451125700300223205ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DisplayedBicats/CartesianPseudoFunctor.v000066400000000000000000000234711451125700300271500ustar00rootroot00000000000000(********************************************************************* Cleavings of bicategories In this file, we define cleaving of bicategories 1. Cartesian pseudofunctors 2. Cartesian pseudofunctors from global cleavings *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Cartesians. Require Import UniMath.Bicategories.DisplayedBicats.EquivalenceBetweenCartesians. Local Open Scope cat. Local Open Scope mor_disp. (** 1. Cartesian pseudofunctors *) Definition global_cartesian_disp_psfunctor {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) : UU := ∏ (b₁ b₂ : B₁) (f : b₁ --> b₂) (bb₁ : D₁ b₁) (bb₂ : D₁ b₂) (ff : bb₁ -->[ f ] bb₂) (Hff : cartesian_1cell D₁ ff), cartesian_1cell D₂ (disp_psfunctor_mor _ _ _ FF ff). Definition local_cartesian_disp_psfunctor {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) : UU := ∏ (b₁ b₂ : B₁) (f g : b₁ --> b₂) (α : f ==> g) (bb₁ : D₁ b₁) (bb₂ : D₁ b₂) (ff : bb₁ -->[ f ] bb₂) (gg : bb₁ -->[ g ] bb₂) (αα : ff ==>[ α ] gg) (Hαα : is_cartesian_2cell D₁ αα), is_cartesian_2cell D₂ (disp_psfunctor_cell _ _ _ FF αα). Definition local_opcartesian_disp_psfunctor {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) : UU := ∏ (b₁ b₂ : B₁) (f g : b₁ --> b₂) (α : f ==> g) (bb₁ : D₁ b₁) (bb₂ : D₁ b₂) (ff : bb₁ -->[ f ] bb₂) (gg : bb₁ -->[ g ] bb₂) (αα : ff ==>[ α ] gg) (Hαα : is_opcartesian_2cell D₁ αα), is_opcartesian_2cell D₂ (disp_psfunctor_cell _ _ _ FF αα). Definition cartesian_disp_psfunctor {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) : UU := global_cartesian_disp_psfunctor FF × local_cartesian_disp_psfunctor FF. (** Lmmas on cartesian pseudofunctors *) Definition global_cartesian_id_psfunctor {B : bicat} (D : disp_bicat B) : global_cartesian_disp_psfunctor (disp_pseudo_id D). Proof. intros ? ? ? ? ? ? H. exact H. Defined. Definition global_cartesian_comp_psfunctor {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₃ G} (HFF : global_cartesian_disp_psfunctor FF) (HGG : global_cartesian_disp_psfunctor GG) : global_cartesian_disp_psfunctor (disp_pseudo_comp _ _ _ _ _ FF GG). Proof. intros ? ? ? ? ? ? H. apply HGG. apply HFF. exact H. Defined. Definition local_cartesian_id_psfunctor {B : bicat} (D : disp_bicat B) : local_cartesian_disp_psfunctor (disp_pseudo_id D). Proof. intros ? ? ? ? ? ? ? ? ? ? H. exact H. Defined. Definition local_cartesian_comp_psfunctor {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₃ G} (HFF : local_cartesian_disp_psfunctor FF) (HGG : local_cartesian_disp_psfunctor GG) : local_cartesian_disp_psfunctor (disp_pseudo_comp _ _ _ _ _ FF GG). Proof. intros ? ? ? ? ? ? ? ? ? ? H. apply HGG. apply HFF. exact H. Defined. Definition local_opcartesian_id_psfunctor {B : bicat} (D : disp_bicat B) : local_opcartesian_disp_psfunctor (disp_pseudo_id D). Proof. intros ? ? ? ? ? ? ? ? ? ? H. exact H. Defined. Definition local_opcartesian_comp_psfunctor {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₃ G} (HFF : local_opcartesian_disp_psfunctor FF) (HGG : local_opcartesian_disp_psfunctor GG) : local_opcartesian_disp_psfunctor (disp_pseudo_comp _ _ _ _ _ FF GG). Proof. intros ? ? ? ? ? ? ? ? ? ? H. apply HGG. apply HFF. exact H. Defined. Definition cartesian_id_psfunctor {B : bicat} (D : disp_bicat B) : cartesian_disp_psfunctor (disp_pseudo_id D). Proof. split. - apply global_cartesian_id_psfunctor. - apply local_cartesian_id_psfunctor. Defined. Definition cartesian_comp_psfunctor {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₃ G} (HFF : cartesian_disp_psfunctor FF) (HGG : cartesian_disp_psfunctor GG) : cartesian_disp_psfunctor (disp_pseudo_comp _ _ _ _ _ FF GG). Proof. split. - apply global_cartesian_comp_psfunctor. + exact (pr1 HFF). + exact (pr1 HGG). - apply local_cartesian_comp_psfunctor. + exact (pr2 HFF). + exact (pr2 HGG). Defined. (** 2. Cartesian pseudofunctors from global cleavings *) Definition preserves_global_lifts {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (HD₁ : global_cleaving D₁) (FF : disp_psfunctor D₁ D₂ F) : UU := ∏ (b₁ b₂ : B₁) (f : b₁ --> b₂) (bb₂ : D₁ b₂), cartesian_1cell D₂ (disp_psfunctor_mor _ _ _ FF (pr12 (HD₁ b₁ b₂ bb₂ f))). Definition preserves_global_lifts_to_cartesian {B : bicat} {D₁ : disp_bicat B} {D₂ : disp_bicat B} (HB : is_univalent_2 B) (HD₂ : disp_univalent_2 D₂) (HD₁ : global_cleaving D₁) {FF : disp_psfunctor D₁ D₂ (id_psfunctor _)} (HFF : preserves_global_lifts HD₁ FF) : global_cartesian_disp_psfunctor FF. Proof. intros b₁ b₂ f bb₁ bb₂ ff Hff. refine (invertible_2cell_from_cartesian HB (pr2 HD₂) _ (pr2 (disp_psfunctor_invertible_2cell FF (map_between_cartesian_1cell_commute (pr2 HB) ff (pr22 (HD₁ b₁ b₂ bb₂ f)))))). use (invertible_2cell_from_cartesian HB (pr2 HD₂) _ (pr2 (disp_psfunctor_comp _ _ _ _ _ _))). use (comp_cartesian_1cell HB). - exact (cartesian_1cell_disp_adj_equiv HB (pr1 HD₂) (@disp_psfunctor_id_on_disp_adjequiv _ _ _ FF _ _ (_ ,, pr1 (disp_adj_equiv_between_cartesian_1cell (pr2 HB) Hff (pr22 (HD₁ b₁ b₂ bb₂ f)))) _ _ _ (pr2 (disp_adj_equiv_between_cartesian_1cell (pr2 HB) Hff (pr22 (HD₁ b₁ b₂ bb₂ f)))))). - apply HFF. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Cartesians.v000066400000000000000000001706351451125700300246170ustar00rootroot00000000000000(********************************************************************* Cartesian 1-cells In this file, we study properties of cartesian 1-cells. Content: 1. Invertibility of 2-cell factorisation 2. Being a cartesian 1-cell is a proposition 3. Weak cartesian 1-cells 4. Every weak cartesian 1-cell is cartesian 5. Examples of cartesian 1-cells *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Local Open Scope cat. Local Open Scope mor_disp. (** 1. Invertibility of 2-cell factorisation *) Section Lift2CellInvertible. Context {B : bicat} (D : disp_bicat B) {a b : B} {f : a --> b} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} (Hff : cartesian_1cell _ ff) {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} (Hδ : is_invertible_2cell δ) {σσ : gg ==>[ δ ▹ f] gg'} (Hσσ : is_disp_invertible_2cell (is_invertible_2cell_rwhisker f Hδ) σσ) (Lh : lift_1cell_factor _ ff gg) (Lh' : lift_1cell_factor _ ff gg'). Let inv : Lh' ==>[ Hδ ^-1] Lh := cartesian_1cell_lift_2cell _ _ Hff (pr1 Hσσ) Lh' Lh. Local Lemma cartesian_1cell_lift_inv₁ : cartesian_1cell_lift_2cell D ff Hff σσ Lh Lh' •• inv = transportb (λ α, Lh ==>[ α] Lh) (vcomp_rinv Hδ) (disp_id2 Lh). Proof. use (isaprop_lift_of_lift_2cell D ff). - refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (rewrite vcomp_rinv ; rewrite id2_rwhisker ; apply idpath). - use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply D | ]. induction φ₁ as [ φ₁ p₁ ]. induction φ₂ as [ φ₂ p₂ ]. cbn. rewrite disp_mor_transportf_prewhisker in p₁, p₂. rewrite disp_id2_right in p₁, p₂. unfold transportb in *. rewrite transport_f_f in p₁, p₂. assert (r := p₁ @ !p₂). assert (r' : φ₁ ▹▹ ff = φ₂ ▹▹ ff). { use (disp_vcomp_rcancel _ (pr22 Lh)). pose (@transportb_transpose_left _ (λ z, Lh ;; ff ==>[ z] gg) _ _ _ _ _ r) as ρ. rewrite transportbfinv in ρ. exact ρ. } pose (l := pr1 Lh ,, disp_id2_invertible_2cell (pr1 Lh ;; ff) : lift_1cell_factor _ _ (Lh ;; ff)). apply (isaprop_lift_of_lift_2cell _ _ (pr2 Hff _ _ _ _ _ _ _ (φ₁ ▹▹ ff) l l) φ₁ φ₂). * cbn. rewrite disp_id2_right, disp_id2_left. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. * cbn. rewrite disp_id2_right, disp_id2_left. unfold transportb. rewrite r'. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. + simple refine (_ ,, _). * simple refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (rewrite vcomp_rinv ; apply idpath). * cbn. rewrite !disp_mor_transportf_prewhisker. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. - unfold cartesian_1cell_lift_2cell, inv. rewrite disp_rwhisker_vcomp_alt. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply eq_lift_2cell_alt. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_vassocr. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply eq_lift_2cell_alt. } unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply Hσσ. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Local Lemma cartesian_1cell_lift_inv₂ : inv •• cartesian_1cell_lift_2cell D ff Hff σσ Lh Lh' = transportb (λ α, Lh' ==>[ α] Lh') (vcomp_linv Hδ) (disp_id2 Lh'). Proof. use (isaprop_lift_of_lift_2cell D ff). - refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (rewrite vcomp_linv ; rewrite id2_rwhisker ; apply idpath). - use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply D | ]. induction φ₁ as [ φ₁ p₁ ]. induction φ₂ as [ φ₂ p₂ ]. cbn. rewrite disp_mor_transportf_prewhisker in p₁, p₂. rewrite disp_id2_right in p₁, p₂. unfold transportb in *. rewrite transport_f_f in p₁, p₂. assert (r := p₁ @ !p₂). assert (r' : φ₁ ▹▹ ff = φ₂ ▹▹ ff). { use (disp_vcomp_rcancel _ (pr22 Lh')). pose (@transportb_transpose_left _ (λ z, Lh' ;; ff ==>[ z] gg') _ _ _ _ _ r) as ρ. rewrite transportbfinv in ρ. exact ρ. } pose (l := pr1 Lh' ,, disp_id2_invertible_2cell (pr1 Lh' ;; ff) : lift_1cell_factor _ _ (Lh' ;; ff)). apply (isaprop_lift_of_lift_2cell _ _ (pr2 Hff _ _ _ _ _ _ _ (φ₁ ▹▹ ff) l l) φ₁ φ₂). * cbn. rewrite disp_id2_right, disp_id2_left. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. * cbn. rewrite disp_id2_right, disp_id2_left. unfold transportb. rewrite r'. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. + simple refine (_ ,, _). * simple refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (rewrite vcomp_linv ; apply idpath). * cbn. rewrite !disp_mor_transportf_prewhisker. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. - unfold cartesian_1cell_lift_2cell, inv. rewrite disp_rwhisker_vcomp_alt. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply eq_lift_2cell_alt. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_vassocr. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply eq_lift_2cell_alt. } unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply Hσσ. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Definition cartesian_1cell_lift_2cell_invertible : is_disp_invertible_2cell Hδ (cartesian_1cell_lift_2cell _ _ Hff σσ Lh Lh'). Proof. simple refine (_ ,, _ ,, _). - exact inv. - exact cartesian_1cell_lift_inv₁. - exact cartesian_1cell_lift_inv₂. Defined. End Lift2CellInvertible. (** 2. Being a cartesian 1-cell is a proposition *) Definition isaprop_cartesian_1cell {B : bicat} {D : disp_bicat B} (HD : disp_univalent_2_1 D) {b₁ b₂ : B} {f : b₁ --> b₂} {bb₁ : D b₁} {bb₂ : D b₂} (ff : bb₁ -->[ f ] bb₂) : isaprop (cartesian_1cell D ff). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. do 10 (use impred ; intro). apply isapropiscontr. } use funextsec ; intro c. use funextsec ; intro cc. use funextsec ; intro h. use funextsec ; intro gg. use total2_paths_f. - use (disp_isotoid_2_1 _ HD (idpath _)). simple refine (_ ,, _). + refine (cartesian_1cell_lift_2cell _ _ φ₁ _ (pr1 φ₁ c cc h gg) (pr1 φ₂ c cc h gg)). exact (transportf (λ z, _ ==>[ z ] _) (!(id2_rwhisker _ _)) (disp_id2 _)). + simpl. apply cartesian_1cell_lift_2cell_invertible. simple refine (_ ,, _ ,, _). * exact (transportf (λ z, _ ==>[ z ] _) (!(id2_rwhisker _ _)) (disp_id2 _)). * rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. * simpl. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. - simpl. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } unfold disp_invertible_2cell. rewrite pr1_transportf. cbn. rewrite disp_1cell_transport_rwhisker. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply disp_idtoiso_2_1_inv. } rewrite disp_idtoiso_isotoid_2_1. cbn. etrans. { apply maponpaths. apply eq_lift_2cell_alt. } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. use (transportf_set (λ α, pr1 φ₂ c cc h gg ;; ff ==>[ α] gg)). apply cellset_property. Qed. (** 3. Weak cartesian 1-cells For a weak cartesian 1-cell, the factorisation only lives above the given cell up to isomorphism. We use this to show that the identity is cartesian. *) Section WeakCartesians. Context {B : bicat} (D : disp_bicat B) {a b : B} {f : a --> b} {aa : D a} {bb : D b} (ff : aa -->[ f ] bb). Definition wk_lift_1cell_factor {c : B} {cc : D c} {h : c --> a} (gg : cc -->[ h · f ] bb) : UU := ∑ (h' : c --> a) (β : invertible_2cell h' h) (hh : cc -->[ h' ] aa), disp_invertible_2cell (rwhisker_of_invertible_2cell f β) (hh ;; ff) gg. Definition wk_lift_1cell_factor_over {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : wk_lift_1cell_factor gg) : c --> a := pr1 Lh. Definition wk_lift_1cell_factor_over_iso {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : wk_lift_1cell_factor gg) : invertible_2cell (wk_lift_1cell_factor_over Lh) h := pr12 Lh. Coercion disp_mor_wk_lift_1cell_factor {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : wk_lift_1cell_factor gg) : cc -->[ wk_lift_1cell_factor_over Lh ] aa := pr122 Lh. Definition disp_cell_wk_lift_1cell_factor {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : wk_lift_1cell_factor gg) : disp_invertible_2cell (rwhisker_of_invertible_2cell f (wk_lift_1cell_factor_over_iso Lh)) (Lh ;; ff) gg := pr222 Lh. Definition wk_lift_2cell_factor_type_path {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[ h · f ] bb} {gg' : cc -->[ h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : wk_lift_1cell_factor gg) (Lh' : wk_lift_1cell_factor gg') : (((pr12 Lh • δ) • (pr12 Lh')^-1) ▹ f) • (wk_lift_1cell_factor_over_iso Lh' ▹ f) = (wk_lift_1cell_factor_over_iso Lh ▹ f) • (δ ▹ f). Proof. rewrite !rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. Qed. Definition wk_lift_2cell_factor_type {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[ h · f ] bb} {gg' : cc -->[ h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : wk_lift_1cell_factor gg) (Lh' : wk_lift_1cell_factor gg') : UU := ∑ (δδ : Lh ==>[ pr12 Lh • δ • (pr12 Lh')^-1 ] Lh'), transportf (λ z, _ ==>[ z ] _) (wk_lift_2cell_factor_type_path σσ Lh Lh') (δδ ▹▹ ff •• disp_cell_wk_lift_1cell_factor Lh') = disp_cell_wk_lift_1cell_factor Lh •• σσ. Definition wk_lift_2cell_factor {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : wk_lift_1cell_factor gg) (Lh' : wk_lift_1cell_factor gg') : UU := iscontr (wk_lift_2cell_factor_type σσ Lh Lh'). Coercion disp_cell_wk_lift_2cell_factor {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : wk_lift_1cell_factor gg} {Lh' : wk_lift_1cell_factor gg'} (Hσσ : wk_lift_2cell_factor σσ Lh Lh') : Lh ==>[ pr12 Lh • δ • (pr12 Lh')^-1 ] Lh' := pr11 Hσσ. Definition eq_wk_lift_2cell {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : wk_lift_1cell_factor gg} {Lh' : wk_lift_1cell_factor gg'} (Hσσ : wk_lift_2cell_factor σσ Lh Lh') : transportf (λ z, _ ==>[ z ] _) (wk_lift_2cell_factor_type_path σσ Lh Lh') (Hσσ ▹▹ ff •• disp_cell_wk_lift_1cell_factor Lh') = disp_cell_wk_lift_1cell_factor Lh •• σσ := pr21 Hσσ. Definition isaprop_wk_lift_of_lift_2cell {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : wk_lift_1cell_factor gg} {Lh' : wk_lift_1cell_factor gg'} (Hσσ : wk_lift_2cell_factor σσ Lh Lh') (δδ₁ : Lh ==>[ pr12 Lh • δ • (pr12 Lh')^-1 ] Lh') (δδ₂ : Lh ==>[ pr12 Lh • δ • (pr12 Lh')^-1 ] Lh') (Pδδ₁ : transportf (λ z, _ ==>[ z ] _) (wk_lift_2cell_factor_type_path σσ Lh Lh') (δδ₁ ▹▹ ff •• disp_cell_wk_lift_1cell_factor Lh') = disp_cell_wk_lift_1cell_factor Lh •• σσ) (Pδδ₂ : transportf (λ z, _ ==>[ z ] _) (wk_lift_2cell_factor_type_path σσ Lh Lh') (δδ₂ ▹▹ ff •• disp_cell_wk_lift_1cell_factor Lh') = disp_cell_wk_lift_1cell_factor Lh •• σσ) : δδ₁ = δδ₂. Proof. pose (proofirrelevance _ (isapropifcontr Hσσ) (δδ₁ ,, Pδδ₁) (δδ₂ ,, Pδδ₂)) as p. exact (maponpaths pr1 p). Qed. Definition wk_cartesian_1cell : UU := (∏ (c : B) (cc : D c) (h : c --> a) (gg : cc -->[ h · f ] bb), wk_lift_1cell_factor gg) × ∏ (c : B) (cc : D c) (h h' : c --> a) (gg : cc -->[h · f ] bb) (gg' : cc -->[h' · f ] bb) (δ : h ==> h') (σσ : gg ==>[ δ ▹ f] gg') (Lh : wk_lift_1cell_factor gg) (Lh' : wk_lift_1cell_factor gg'), wk_lift_2cell_factor σσ Lh Lh'. End WeakCartesians. (** 4. Every weak cartesian 1-cell is cartesian *) Lemma lift_1cell_factor_to_wk_lift_1cell_factor_path {B : bicat} {a b : B} (f : a --> b) {c : B} (h : c --> a) : id2_invertible_2cell (h · f) = rwhisker_of_invertible_2cell f (id2_invertible_2cell h). Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } exact (!(id2_rwhisker _ _)). Qed. Definition lift_1cell_factor_to_wk_lift_1cell_factor {B : bicat} {D : disp_bicat B} {a b : B} {f : a --> b} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f] bb} (ℓ : lift_1cell_factor D ff gg) : wk_lift_1cell_factor D ff gg. Proof. refine (h ,, id2_invertible_2cell _ ,, disp_mor_lift_1cell_factor D _ ℓ ,, _). exact (transportf (λ z, disp_invertible_2cell z _ _) (lift_1cell_factor_to_wk_lift_1cell_factor_path f h) (disp_cell_lift_1cell_factor D _ ℓ)). Defined. Section WkLiftToLift. Context {B : bicat} {D : disp_bicat B} (HB : is_univalent_2_1 B) {a b : B} {f : a --> b} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {c : B} {cc : D c} {h : B ⟦ c, a ⟧} {gg : cc -->[ h · f] bb} (ℓ : wk_lift_1cell_factor D ff gg). Local Definition wk_lift_1cell_factor_to_lift_1cell_factor_lift : cc -->[ h] aa := transport_along_inv_2cell HB (wk_lift_1cell_factor_over_iso D _ ℓ) (disp_mor_wk_lift_1cell_factor D _ ℓ). Local Definition wk_lift_1cell_factor_to_lift_1cell_factor_cell : wk_lift_1cell_factor_to_lift_1cell_factor_lift ;; ff ==>[ id₂ _ ] gg. Proof. refine (transportf (λ z, _ ==>[ z ] _) _ ((transport_along_inv_2cell_disp_invertible_2cell HB _ _ ▹▹ ff) •• disp_cell_wk_lift_1cell_factor D _ ℓ)). abstract (cbn ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply idpath). Defined. Definition wk_lift_1cell_factor_to_lift_1cell_factor_invertible : is_disp_invertible_2cell (is_invertible_2cell_id₂ (h · f)) wk_lift_1cell_factor_to_lift_1cell_factor_cell. Proof. unfold wk_lift_1cell_factor_to_lift_1cell_factor_cell. use transportf_is_disp_invertible_2cell. - cbn. is_iso. apply property_from_invertible_2cell. - apply (vcomp_disp_is_invertible (disp_invertible_2cell_rwhisker ff (transport_along_inv_2cell_disp_invertible_2cell HB (wk_lift_1cell_factor_over_iso D ff ℓ) ℓ)) (disp_cell_wk_lift_1cell_factor D ff ℓ)). Defined. Definition wk_lift_1cell_factor_to_lift_1cell_factor : lift_1cell_factor D ff gg. Proof. refine (wk_lift_1cell_factor_to_lift_1cell_factor_lift ,, _). simple refine (_ ,, _) ; cbn. - exact wk_lift_1cell_factor_to_lift_1cell_factor_cell. - exact wk_lift_1cell_factor_to_lift_1cell_factor_invertible. Defined. End WkLiftToLift. Section WkCartesianToCartesian. Context {B : bicat} {D : disp_bicat B} (HB : is_univalent_2_1 B) {a b : B} {f : a --> b} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} (Hff : wk_cartesian_1cell D ff). Section WkCartesianToCartesianTwoCell. Context {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[ h · f ] bb} {gg' : cc -->[ h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f ] gg') (Lh : lift_1cell_factor D ff gg) (Lh' : lift_1cell_factor D ff gg'). Let ℓ : wk_lift_1cell_factor D ff gg := lift_1cell_factor_to_wk_lift_1cell_factor Lh. Let ℓ' : wk_lift_1cell_factor D ff gg' := lift_1cell_factor_to_wk_lift_1cell_factor Lh'. Let w : wk_lift_2cell_factor D ff σσ ℓ ℓ' := pr2 Hff c cc h h' gg gg' δ σσ ℓ ℓ'. Local Lemma help_path_wk_cartesian : (pr12 ℓ • δ) • (pr12 ℓ') ^-1 = δ. Proof. cbn. rewrite id2_left, id2_right. apply idpath. Qed. Local Definition wk_cartesian_1cell_to_cartesian_1cell_2cell : Lh ==>[ δ ] Lh' := transportf (λ z, _ ==>[ z ] _) help_path_wk_cartesian (pr11 w). Local Lemma wk_cartesian_1cell_to_cartesian_1cell_comm : transportf (λ z, _ ==>[ z] _) (id2_right (δ ▹ f) @ ! id2_left (δ ▹ f)) ((wk_cartesian_1cell_to_cartesian_1cell_2cell ▹▹ ff) •• disp_cell_lift_1cell_factor D ff Lh') = disp_cell_lift_1cell_factor D ff Lh •• σσ. Proof. unfold wk_cartesian_1cell_to_cartesian_1cell_2cell. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. pose (pr21 w) as p₁. cbn in p₁. pose (q₁ := transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h) (disp_cell_lift_1cell_factor D ff Lh)). pose (p₂ := p₁ @ maponpaths (λ z, z •• _) q₁). rewrite disp_mor_transportf_postwhisker in p₂. pose (p₃ := @transportb_transpose_left _ (λ z, _ ==>[ z ] _) _ _ _ _ _ p₂). refine (_ @ p₃). clear p₁ q₁ p₂ p₃. unfold transportb. rewrite transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. exact (transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h') (disp_cell_lift_1cell_factor D ff Lh')). } rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Local Lemma wk_cartesian_1cell_to_cartesian_1cell_unique : isaprop (lift_2cell_factor_type D ff σσ Lh Lh'). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply disp_cellset_property. } pose (p₁ := pr2 φ₁). pose (p₂ := pr2 φ₂). cbn in p₁, p₂. assert (path : δ = (id₂ h • δ) • id₂ h'). { rewrite id2_left, id2_right. apply idpath. } pose (δδ₁ := transportf (λ z, _ ==>[ z ] _) path (pr1 φ₁)). pose (δδ₂ := transportf (λ z, _ ==>[ z ] _) path (pr1 φ₂)). enough (δδ₁ = δδ₂) as H. { pose (r := maponpaths (transportb (λ z, _ ==>[ z ] _) path) H). unfold δδ₁, δδ₂ in r. rewrite !transportbfinv in r. exact r. } use (isaprop_wk_lift_of_lift_2cell D ff w δδ₁ δδ₂) ; cbn ; unfold δδ₁, δδ₂. - etrans. { do 2 apply maponpaths. apply (transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h')). } rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. refine (!_). etrans. { apply maponpaths_2. apply (transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h)). } rewrite disp_mor_transportf_postwhisker. etrans. { apply maponpaths. exact (!p₁). } rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - etrans. { do 2 apply maponpaths. apply (transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h')). } rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. refine (!_). etrans. { apply maponpaths_2. apply (transportf_disp_invertible_2cell (lift_1cell_factor_to_wk_lift_1cell_factor_path f h)). } rewrite disp_mor_transportf_postwhisker. etrans. { apply maponpaths. exact (!p₂). } rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. End WkCartesianToCartesianTwoCell. Definition wk_cartesian_1cell_to_cartesian_1cell : cartesian_1cell D ff. Proof. split. - exact (λ c cc h gg, wk_lift_1cell_factor_to_lift_1cell_factor HB (pr1 Hff _ _ _ gg)). - intros c cc h h' gg gg' δ σσ Lh Lh'. use iscontraprop1. + exact (wk_cartesian_1cell_to_cartesian_1cell_unique σσ Lh Lh'). + simple refine (_ ,, _). ** exact (wk_cartesian_1cell_to_cartesian_1cell_2cell σσ Lh Lh'). ** exact (wk_cartesian_1cell_to_cartesian_1cell_comm σσ Lh Lh'). Defined. End WkCartesianToCartesian. (** 5. Examples of cartesian 1-cells *) Section ExamplesOfCartesian1Cells. Context {B : bicat} {D : disp_bicat B} (HB : is_univalent_2 B). Section IdCartesian. Context {x : B} (xx : D x). Section IdCartesianOneLift. Context {c : B} {cc : D c} {h : c --> x} (gg : cc -->[ h · id₁ _ ] xx). Definition cartesian_1cell_id_wk_1cell_lift : wk_lift_1cell_factor D (id_disp xx) gg. Proof. refine (h · id₁ _ ,, runitor_invertible_2cell _ ,, gg ,, _). simple refine (_ ,, _). - refine (transportf (λ z, _ ==>[ z ] _) _ (disp_runitor gg)). abstract (cbn ; rewrite <- runitor_triangle ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite runitor_rwhisker ; apply maponpaths ; apply runitor_lunitor_identity). - cbn. use transportf_is_disp_invertible_2cell. + is_iso. + apply is_disp_invertible_2cell_runitor. Defined. End IdCartesianOneLift. Section IdCartesianTwoLift. Context {c : B} {cc : D c} (h h' : B ⟦ c, x ⟧) {gg : cc -->[ h · id₁ _ ] xx} {gg' : cc -->[ h' · id₁ _ ] xx} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ id₁ _ ] gg') (Lh : wk_lift_1cell_factor D (id_disp xx) gg) (Lh' : wk_lift_1cell_factor D (id_disp xx) gg'). Local Definition cartesian_1cell_id_wk_2cell_lift_cell : Lh ==>[ (pr12 Lh • δ) • (pr12 Lh')^-1 ] Lh'. Proof. refine (transportf (λ z, _ ==>[ z ] _) _ (disp_rinvunitor _ •• disp_cell_wk_lift_1cell_factor D _ Lh •• σσ •• disp_inv_cell (disp_cell_wk_lift_1cell_factor D _ Lh') •• disp_runitor _)). abstract (cbn ; rewrite !vassocl ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite vcomp_runitor ; rewrite !vassocr ; rewrite rinvunitor_runitor ; apply id2_left). Defined. Local Definition cartesian_1cell_id_wk_2cell_lift_comm : transportf (λ z, Lh ;; id_disp xx ==>[ z] gg') (wk_lift_2cell_factor_type_path D (id_disp xx) σσ Lh Lh') ((cartesian_1cell_id_wk_2cell_lift_cell ▹▹ id_disp xx) •• disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh') = disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh •• σσ. Proof. unfold cartesian_1cell_id_wk_2cell_lift_cell. rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f ; cbn. etrans. { do 2 apply maponpaths. apply disp_id2_left_alt. } rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply maponpaths_2. exact (!(@transportf_transpose_left _ (λ z, _ ==>[ z ] _) _ _ _ _ _ (disp_runitor_rinvunitor Lh'))). } rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite !disp_vassocr. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite disp_vcomp_runitor. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite !disp_vassocr. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_runitor_rinvunitor. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. do 5 apply maponpaths_2. apply disp_id2_left. } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. do 3 (refine (disp_vassocl _ _ _ @ _) ; apply maponpaths). do 2 apply maponpaths. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply disp_runitor_rinvunitor. } unfold transportb. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. apply (disp_vcomp_linv (disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh')). } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply disp_id2_right. } unfold transportb. rewrite transport_f_f. apply (transportf_set (λ z, _ ==>[ z ] _)). apply cellset_property. Qed. Local Definition cartesian_1cell_id_wk_2cell_lift_unique : isaprop (wk_lift_2cell_factor_type D (id_disp xx) σσ Lh Lh'). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply disp_cellset_property. } pose (p₁ := maponpaths (transportb (λ z, _ ==>[ z ] _) (wk_lift_2cell_factor_type_path D (id_disp xx) σσ Lh Lh')) (pr2 φ₁ @ !(pr2 φ₂))). rewrite !transportbfinv in p₁. pose (maponpaths (λ z, z •• disp_inv_cell (disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh')) p₁) as p₂. cbn in p₂. rewrite !disp_vassocl in p₂. pose (p₃ := maponpaths (transportf (λ z, _ ==>[ z ] _) (vassocl _ _ _)) p₂). rewrite !transportfbinv in p₃. pose (p₄ := maponpaths (λ z, _ •• z) (!disp_vcomp_rinv (disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh')) @ p₃ @ maponpaths (λ z, _ •• z) (disp_vcomp_rinv (disp_cell_wk_lift_1cell_factor D (id_disp xx) Lh'))). cbn in p₄. unfold transportb in p₄. rewrite !disp_mor_transportf_prewhisker in p₄. pose (p₅ := !(transportbfinv _ _ _) @ maponpaths _ p₄ @ transportbfinv _ _ _). rewrite !disp_id2_right in p₅. pose (p₆ := maponpaths (transportf (λ z, _ ==>[ z ] _) (id2_right _)) p₅). rewrite !transportfbinv in p₆. pose (p₇ := maponpaths (λ z, disp_rinvunitor _ •• (z •• disp_runitor _)) p₆). cbn in p₇. rewrite !disp_vcomp_runitor in p₇. unfold transportb in p₇. rewrite !disp_mor_transportf_prewhisker in p₇. rewrite !disp_vassocr in p₇. unfold transportb in p₇. rewrite !transport_f_f in p₇. rewrite !disp_rinvunitor_runitor in p₇. unfold transportb in p₇. rewrite !disp_mor_transportf_postwhisker in p₇. rewrite transport_f_f in p₇. rewrite !disp_id2_left in p₇. unfold transportb in p₇. rewrite !transport_f_f in p₇. pose (p := !(transportbfinv _ _ _) @ maponpaths _ p₇ @ transportbfinv _ _ _). exact p. Qed. Definition cartesian_1cell_id_wk_2cell_lift : wk_lift_2cell_factor D (id_disp xx) σσ Lh Lh'. Proof. use iscontraprop1. - exact cartesian_1cell_id_wk_2cell_lift_unique. - exact (cartesian_1cell_id_wk_2cell_lift_cell ,, cartesian_1cell_id_wk_2cell_lift_comm). Defined. End IdCartesianTwoLift. Definition cartesian_1cell_id : cartesian_1cell D (id_disp xx). Proof. apply (wk_cartesian_1cell_to_cartesian_1cell (pr2 HB)). split. - exact @cartesian_1cell_id_wk_1cell_lift. - exact @cartesian_1cell_id_wk_2cell_lift. Defined. End IdCartesian. Section CompCartesian. Context {x y z : B} {f : x --> y} {g : y --> z} {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} (Hff : cartesian_1cell D ff) (Hgg : cartesian_1cell D gg). Section CompCartesianLiftOneCell. Context {c : B} {cc : D c} {h : c --> x} (kk : cc -->[ h · (f · g) ] zz). Let kk' : cc -->[ (h · f) · g ] zz := transport_along_inv_2cell (pr2 HB) (lassociator_invertible_2cell _ _ _) kk. Let ℓ₁ : cc -->[ h · f ] yy := pr1 (cartesian_1cell_lift_1cell _ _ Hgg kk'). Let ℓ₂ : cc -->[ h ] xx := pr1 (cartesian_1cell_lift_1cell _ _ Hff ℓ₁). Let γ₁ : disp_invertible_2cell (id2_invertible_2cell _) (ℓ₁ ;; gg) kk' := pr2 (cartesian_1cell_lift_1cell _ _ Hgg kk'). Let γ₂ : disp_invertible_2cell (id2_invertible_2cell _) (ℓ₂ ;; ff) ℓ₁ := pr2 (cartesian_1cell_lift_1cell _ _ Hff ℓ₁). Let γ₃ : disp_invertible_2cell (rassociator_invertible_2cell h f g) kk' kk := transport_along_inv_2cell_disp_invertible_2cell (pr2 HB) (lassociator_invertible_2cell _ _ _) kk. Definition comp_cartesian_1cell_lift_1cell_factor : lift_1cell_factor D (ff ;; gg) kk. Proof. refine (ℓ₂ ,, _). refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (disp_invertible_2cell_lassociator ℓ₂ ff gg) (disp_invertible_2cell_rwhisker gg γ₂)) γ₁) γ₃)). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite id2_rwhisker, !id2_right ; apply lassociator_rassociator). Defined. End CompCartesianLiftOneCell. Section CompCartesianLiftTwoCell. Context {c : B} {cc : D c} {h h' : c --> x} {kk₁ : cc -->[ h · (f · g) ] zz} {kk₂ : cc -->[ h' · (f · g) ] zz} {δ : h ==> h'} (σσ : kk₁ ==>[ δ ▹ f · g] kk₂) (Lh : lift_1cell_factor D (ff ;; gg) kk₁) (Lh' : lift_1cell_factor D (ff ;; gg) kk₂). Let κκ₁ : cc -->[ h · f · g] zz := transport_along_inv_2cell (pr2 HB) (lassociator_invertible_2cell h f g) kk₁. Let γ₁ : disp_invertible_2cell (rassociator_invertible_2cell h f g) κκ₁ kk₁ := transport_along_inv_2cell_disp_invertible_2cell (pr2 HB) (lassociator_invertible_2cell h f g) kk₁. Let κκ₂ : cc -->[ h' · f · g] zz := transport_along_inv_2cell (pr2 HB) (lassociator_invertible_2cell h' f g) kk₂. Let γ₂ : disp_invertible_2cell (rassociator_invertible_2cell h' f g) κκ₂ kk₂ := transport_along_inv_2cell_disp_invertible_2cell (pr2 HB) (lassociator_invertible_2cell h' f g) kk₂. Local Lemma help_path {w : B} (q : w --> x) : comp_of_invertible_2cell (rassociator_invertible_2cell q f g) (comp_of_invertible_2cell (id2_invertible_2cell (q · (f · g))) (lassociator_invertible_2cell q f g)) = id2_invertible_2cell (q · f · g). Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. rewrite id2_left. apply rassociator_lassociator. Qed. Let Lκ₁ : lift_1cell_factor D gg κκ₁. Proof. refine (pr1 Lh ;; ff ,, _). exact (transportf (λ z, disp_invertible_2cell z _ _) (help_path h) (vcomp_disp_invertible (disp_invertible_2cell_rassociator (pr1 Lh) ff gg) (vcomp_disp_invertible (pr2 Lh) (inverse_of_disp_invertible_2cell γ₁)))). Defined. Let Lκ₂ : lift_1cell_factor D gg κκ₂. Proof. refine (pr1 Lh' ;; ff ,, _). exact (transportf (λ z, disp_invertible_2cell z _ _) (help_path h') (vcomp_disp_invertible (disp_invertible_2cell_rassociator (pr1 Lh') ff gg) (vcomp_disp_invertible (pr2 Lh') (inverse_of_disp_invertible_2cell γ₂)))). Defined. Let Lq₁ : lift_1cell_factor D ff Lκ₁. Proof. simple refine (_ ,, _). - exact (pr1 Lh). - apply disp_id2_invertible_2cell. Defined. Let Lq₂ : lift_1cell_factor D ff Lκ₂. Proof. simple refine (_ ,, _). - exact (pr1 Lh'). - apply disp_id2_invertible_2cell. Defined. Let σσ' : κκ₁ ==>[ δ ▹ f ▹ g ] κκ₂. Proof. refine (transportb (λ z, _ ==>[ z ] _) _ (γ₁ •• σσ •• disp_inv_cell γ₂)). abstract (cbn ; rewrite <- rwhisker_rwhisker_alt ; rewrite !vassocl ; rewrite rassociator_lassociator ; rewrite id2_right ; apply idpath). Defined. Definition comp_cartesian_1cell_lift_2cell_factor_unique : isaprop (lift_2cell_factor_type D (ff ;; gg) σσ Lh Lh'). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply disp_cellset_property. } use (isaprop_lift_of_lift_2cell _ _ (pr2 Hff c cc h h' _ _ δ _ Lq₁ Lq₂)). - exact (pr2 Hgg c cc (h · f) (h' · f) κκ₁ κκ₂ (δ ▹ f) σσ' Lκ₁ Lκ₂). - unfold disp_cell_lift_1cell_factor. unfold Lq₂ ; cbn. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. rewrite disp_id2_left. unfold transportb. enough (pr1 φ₁ ▹▹ ff = pr11 (pr2 Hgg c cc (h · f) (h' · f) κκ₁ κκ₂ (δ ▹ f) σσ' Lκ₁ Lκ₂)) as H. { etrans. { apply maponpaths. exact H. } apply maponpaths_2. apply cellset_property. } use (isaprop_lift_of_lift_2cell _ _ (pr2 Hgg c cc (h · f) (h' · f) κκ₁ κκ₂ (δ ▹ f) σσ' Lκ₁ Lκ₂)). + unfold σσ' ; cbn. etrans. { do 2 apply maponpaths. exact (transportf_disp_invertible_2cell (help_path _) _). } cbn. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. refine (!_). etrans. { apply maponpaths_2. exact (transportf_disp_invertible_2cell (help_path _) _). } cbn. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. etrans. { rewrite !disp_vassocl. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 3 apply maponpaths. rewrite !disp_vassocr. unfold transportb. rewrite transport_f_f. apply maponpaths. do 2 apply maponpaths_2. exact (disp_vcomp_linv γ₁). } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite disp_id2_left. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. apply idpath. } etrans. { do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. exact (!(pr2 φ₁)). } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite !disp_vassocr. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite <- disp_rwhisker_rwhisker_rassociator. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. + apply eq_lift_2cell. - unfold disp_cell_lift_1cell_factor. unfold Lq₂ ; cbn. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. rewrite disp_id2_left. unfold transportb. enough (pr1 φ₂ ▹▹ ff = pr11 (pr2 Hgg c cc (h · f) (h' · f) κκ₁ κκ₂ (δ ▹ f) σσ' Lκ₁ Lκ₂)) as H. { etrans. { apply maponpaths. exact H. } apply maponpaths_2. apply cellset_property. } use (isaprop_lift_of_lift_2cell _ _ (pr2 Hgg c cc (h · f) (h' · f) κκ₁ κκ₂ (δ ▹ f) σσ' Lκ₁ Lκ₂)). + unfold σσ' ; cbn. etrans. { do 2 apply maponpaths. exact (transportf_disp_invertible_2cell (help_path _) _). } cbn. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. refine (!_). etrans. { apply maponpaths_2. exact (transportf_disp_invertible_2cell (help_path _) _). } cbn. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. etrans. { rewrite !disp_vassocl. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 3 apply maponpaths. rewrite !disp_vassocr. unfold transportb. rewrite transport_f_f. apply maponpaths. do 2 apply maponpaths_2. exact (disp_vcomp_linv γ₁). } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite disp_id2_left. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. apply idpath. } etrans. { do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. exact (!(pr2 φ₂)). } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite !disp_vassocr. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite <- disp_rwhisker_rwhisker_rassociator. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. + apply eq_lift_2cell. Qed. Let ℓ₁ : Lκ₁ ==>[ δ ▹ f] Lκ₂ := cartesian_1cell_lift_2cell _ _ Hgg σσ' Lκ₁ Lκ₂. Let ℓ₂ : Lh ==>[ δ] Lh' := cartesian_1cell_lift_2cell _ _ Hff ℓ₁ Lq₁ Lq₂. Local Lemma comp_cartesian_1cell_lift_2cell_factor_commute : transportf (λ q, _ ==>[ q ] _) (id2_right (δ ▹ f · g) @ ! id2_left (δ ▹ f · g)) ((ℓ₂ ▹▹ ff ;; gg) •• disp_cell_lift_1cell_factor D (ff ;; gg) Lh') = disp_cell_lift_1cell_factor D (ff ;; gg) Lh •• σσ. Proof. use (disp_vcomp_rcancel _ (pr2 (inverse_of_disp_invertible_2cell γ₂))). use (disp_vcomp_lcancel _ (is_disp_invertible_2cell_rassociator _ _ _)). rewrite !disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. etrans. { rewrite !disp_vassocr. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite (@transportf_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ (disp_rwhisker_rwhisker_rassociator ℓ₂ ff gg)). rewrite !disp_mor_transportf_postwhisker. rewrite transport_f_f. apply idpath. } assert (q₁ : cartesian_1cell_lift_2cell D ff Hff ℓ₁ Lq₁ Lq₂ ▹▹ ff = ℓ₁). { pose (p := cartesian_1cell_lift_2cell_commutes _ _ Hff ℓ₁ Lq₁ Lq₂). cbn in p. rewrite disp_id2_left in p. rewrite disp_id2_right in p. unfold transportb in p. rewrite transport_f_f in p. etrans. { exact (@transportb_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ p). } unfold transportb. rewrite !transport_f_f. apply (transportf_set (λ z, _ ==>[ z ] _)). apply cellset_property. } etrans. { apply maponpaths. do 3 apply maponpaths_2. apply maponpaths. exact q₁. } assert (q₂ : ∑ w, ℓ₁ ▹▹ gg •• disp_rassociator _ _ _ •• pr2 Lh' •• disp_inv_cell γ₂ = transportf (λ z, _ ==>[ z ] _) w (disp_rassociator _ _ _ •• pr2 Lh •• disp_inv_cell γ₁ •• σσ')). { pose (p := cartesian_1cell_lift_2cell_commutes _ _ Hgg σσ' Lκ₁ Lκ₂). cbn in p. pose (p' := p @ maponpaths (λ z, z •• _) (transportf_disp_invertible_2cell (help_path h) _)). cbn in p'. rewrite !disp_vassocr in p'. unfold transportb in p'. rewrite transport_f_f in p'. rewrite disp_mor_transportf_postwhisker in p'. pose (p'' := @transportb_transpose_left _ (λ z, _ ==>[ z ] _) _ _ _ _ _ p'). unfold transportb in p''. rewrite transport_f_f in p''. simple refine (_ ,, _). { abstract (cbn ; rewrite !id2_right ; rewrite rassociator_lassociator, id2_left ; rewrite !vassocl ; rewrite rassociator_lassociator, id2_right ; apply idpath). } cbn. refine (_ @ maponpaths _ p''). rewrite !transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. apply (transportf_disp_invertible_2cell (help_path h')). } rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. cbn. rewrite !disp_vassocr. unfold transportb. rewrite !transport_f_f. apply (transportf_set (λ z, _ ==>[ z ] _)). apply cellset_property. } etrans. { apply maponpaths. exact (pr2 q₂). } rewrite transport_f_f. unfold σσ'. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite !disp_vassocl. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 3 apply maponpaths. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. etrans. { apply maponpaths_2. apply disp_vcomp_linv. } unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite transport_f_f. apply idpath. } unfold transportb. rewrite transport_f_f. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Definition comp_cartesian_1cell_lift_2cell_factor : lift_2cell_factor D (ff ;; gg) σσ Lh Lh'. Proof. use iscontraprop1. - exact comp_cartesian_1cell_lift_2cell_factor_unique. - exact (ℓ₂ ,, comp_cartesian_1cell_lift_2cell_factor_commute). Defined. End CompCartesianLiftTwoCell. Definition comp_cartesian_1cell : cartesian_1cell D (ff ;; gg). Proof. split. - exact @comp_cartesian_1cell_lift_1cell_factor. - exact @comp_cartesian_1cell_lift_2cell_factor. Defined. End CompCartesian. Definition cartesian_1cell_disp_adj_equiv (HD : disp_univalent_2_0 D) {x y : B} {f : x --> y} {Hf : left_adjoint_equivalence f} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : disp_left_adjoint_equivalence Hf ff) : cartesian_1cell D ff. Proof. use (disp_J_2_0 (pr1 HB) HD (λ x y f xx yy ff, cartesian_1cell D (pr1 ff)) _ ((ff ,, Hff) : disp_adjoint_equivalence (f ,, Hf) xx yy)) ; cbn. intros. apply cartesian_1cell_id. Defined. Definition invertible_2cell_from_cartesian_help {x y : B} {f g : x --> y} {p : f = g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : cartesian_1cell D ff) {gg : xx -->[ g ] yy} (pp : transportf (λ z, _ -->[ z ] _) p ff = gg) : cartesian_1cell D gg. Proof. induction p, pp. exact Hff. Defined. Definition invertible_2cell_from_cartesian (HD : disp_univalent_2_1 D) {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : cartesian_1cell D ff) {gg : xx -->[ g ] yy} {αα : ff ==>[ α ] gg} (Hαα : is_disp_invertible_2cell Hα αα) : cartesian_1cell D gg. Proof. use (invertible_2cell_from_cartesian_help Hff). - exact (isotoid_2_1 (pr2 HB) (make_invertible_2cell Hα)). - refine (disp_isotoid_2_1 _ HD (isotoid_2_1 (pr2 HB) (make_invertible_2cell Hα)) ff gg _). simple refine (transportb (λ z, disp_invertible_2cell z ff gg) (idtoiso_2_1_isotoid_2_1 _ _) (_ ,, _)). + exact αα. + exact Hαα. Defined. End ExamplesOfCartesian1Cells. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/CleavingOfBicat.v000066400000000000000000001306441451125700300254770ustar00rootroot00000000000000(********************************************************************* Cleavings of bicategories In this file, we define cleaving of bicategories Content: 1. Definition of cleaving 2. Properties of cartesian 2-cells 3. Local opcleavings 4. Properties of opcartesian 2-cells 5. Local isocleavings 6. Local isocleavings from local (op)cleavings *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Local Open Scope cat. Local Open Scope mor_disp. (** 1. Definition of cleaving *) Section BicatCleaving. Context {B : bicat} (D : disp_bicat B). Section Cartesian1cell. Context {a b : B} {f : a --> b} {aa : D a} {bb : D b} (ff : aa -->[ f ] bb). Definition lift_1cell_factor {c : B} {cc : D c} {h : c --> a} (gg : cc -->[ h · f ] bb) : UU := ∑ (hh : cc -->[ h ] aa), disp_invertible_2cell (id2_invertible_2cell _) (hh ;; ff) gg. Coercion disp_mor_lift_1cell_factor {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : lift_1cell_factor gg) : cc -->[ h ] aa := pr1 Lh. Definition disp_cell_lift_1cell_factor {c : B} {cc : D c} {h : c --> a} {gg : cc -->[ h · f ] bb} (Lh : lift_1cell_factor gg) : disp_invertible_2cell _ (Lh ;; ff) gg := pr2 Lh. Definition lift_2cell_factor_type {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[ h · f ] bb} {gg' : cc -->[ h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor gg) (Lh' : lift_1cell_factor gg') : UU := ∑ (δδ : Lh ==>[ δ ] Lh'), transportf (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (δδ ▹▹ ff •• disp_cell_lift_1cell_factor Lh') = disp_cell_lift_1cell_factor Lh •• σσ. Definition lift_2cell_factor {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor gg) (Lh' : lift_1cell_factor gg') : UU := iscontr (lift_2cell_factor_type σσ Lh Lh'). Coercion disp_cell_lift_2cell_factor {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : lift_1cell_factor gg} {Lh' : lift_1cell_factor gg'} (Hσσ : lift_2cell_factor σσ Lh Lh') : Lh ==>[ δ ] Lh' := pr11 Hσσ. Definition eq_lift_2cell {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : lift_1cell_factor gg} {Lh' : lift_1cell_factor gg'} (Hσσ : lift_2cell_factor σσ Lh Lh') : transportf (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (Hσσ ▹▹ ff •• disp_cell_lift_1cell_factor Lh') = disp_cell_lift_1cell_factor Lh •• σσ := pr21 Hσσ. Definition eq_lift_2cell_alt {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : lift_1cell_factor gg} {Lh' : lift_1cell_factor gg'} (Hσσ : lift_2cell_factor σσ Lh Lh') : Hσσ ▹▹ ff •• disp_cell_lift_1cell_factor Lh' = transportb (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (disp_cell_lift_1cell_factor Lh •• σσ). Proof. rewrite <- (eq_lift_2cell Hσσ). rewrite transportbfinv. apply idpath. Qed. Definition isaprop_lift_of_lift_2cell {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} {σσ : gg ==>[ δ ▹ f] gg'} {Lh : lift_1cell_factor gg} {Lh' : lift_1cell_factor gg'} (Hσσ : lift_2cell_factor σσ Lh Lh') (δδ₁ : Lh ==>[ δ ] Lh') (δδ₂ : Lh ==>[ δ ] Lh') (Pδδ₁ : transportf (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (δδ₁ ▹▹ ff •• disp_cell_lift_1cell_factor Lh') = disp_cell_lift_1cell_factor Lh •• σσ) (Pδδ₂ : transportf (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (δδ₂ ▹▹ ff •• disp_cell_lift_1cell_factor Lh') = disp_cell_lift_1cell_factor Lh •• σσ) : δδ₁ = δδ₂. Proof. pose (proofirrelevance _ (isapropifcontr Hσσ) (δδ₁ ,, Pδδ₁) (δδ₂ ,, Pδδ₂)) as p. exact (maponpaths pr1 p). Qed. Definition cartesian_1cell : UU := (∏ (c : B) (cc : D c) (h : c --> a) (gg : cc -->[ h · f ] bb), lift_1cell_factor gg) × ∏ (c : B) (cc : D c) (h h' : c --> a) (gg : cc -->[h · f ] bb) (gg' : cc -->[h' · f ] bb) (δ : h ==> h') (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor gg) (Lh' : lift_1cell_factor gg'), lift_2cell_factor σσ Lh Lh'. Definition cartesian_1cell_lift_1cell (Hff : cartesian_1cell) {c : B} {cc : D c} {h : c --> a} (gg : cc -->[ h · f ] bb) : lift_1cell_factor gg := pr1 Hff c cc h gg. Definition cartesian_1cell_lift_2cell (Hff : cartesian_1cell) {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor gg) (Lh' : lift_1cell_factor gg') : Lh ==>[ δ ] Lh' := pr2 Hff c cc h h' gg gg' δ σσ Lh Lh'. Definition cartesian_1cell_lift_2cell_commutes (Hff : cartesian_1cell) {c : B} {cc : D c} {h h' : c --> a} {gg : cc -->[h · f ] bb} {gg' : cc -->[h' · f ] bb} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor gg) (Lh' : lift_1cell_factor gg') : transportf (λ z, _ ==>[ z ] _) (id2_right _ @ ! id2_left _ ) (cartesian_1cell_lift_2cell Hff σσ Lh Lh' ▹▹ ff •• disp_cell_lift_1cell_factor Lh') = disp_cell_lift_1cell_factor Lh •• σσ := eq_lift_2cell (pr2 Hff c cc h h' gg gg' δ σσ Lh Lh'). End Cartesian1cell. Definition is_cartesian_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {α : f ==> g} (αα : ff ==>[ α ] gg) : UU := ∏ (h : x --> y) (hh : xx -->[ h ] yy) (γ : h ==> f) (ββ : hh ==>[ γ • α ] gg), ∃! (γγ : hh ==>[ γ ] ff), (γγ •• αα) = ββ. Section Cartesian2Cell. Context {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {α : f ==> g} {αα : ff ==>[ α ] gg} (Hαα : is_cartesian_2cell αα). Definition is_cartesian_2cell_factor {h : x --> y} (hh : xx -->[ h ] yy) (γ : h ==> f) (ββ : hh ==>[ γ • α ] gg) : hh ==>[ γ ] ff := pr11 (Hαα h hh γ ββ). Definition is_cartesian_2cell_comm {h : x --> y} (hh : xx -->[ h ] yy) (γ : h ==> f) (ββ : hh ==>[ γ • α ] gg) : (is_cartesian_2cell_factor hh γ ββ •• αα) = ββ := pr21 (Hαα h hh γ ββ). Definition is_cartesian_2cell_unique {h : x --> y} (hh : xx -->[ h ] yy) (γ : h ==> f) (ββ : hh ==>[ γ • α ] gg) {γγ₁ γγ₂ : hh ==>[ γ ] ff} (pγγ₁ : (γγ₁ •• αα) = ββ) (pγγ₂ : (γγ₂ •• αα) = ββ) : γγ₁ = γγ₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hαα h hh γ ββ)) (γγ₁ ,, pγγ₁) (γγ₂ ,, pγγ₂))). Qed. End Cartesian2Cell. Definition cartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} (gg : xx -->[ g ] yy) (α : f ==> g) : UU := ∑ (ff : xx -->[ f ] yy) (αα : ff ==>[ α ] gg), is_cartesian_2cell αα. Coercion mor_of_cartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {gg : xx -->[ g ] yy} {α : f ==> g} (ℓ : cartesian_lift_2cell gg α) : xx -->[ f ] yy := pr1 ℓ. Definition cell_of_cartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {gg : xx -->[ g ] yy} {α : f ==> g} (ℓ : cartesian_lift_2cell gg α) : ℓ ==>[ α] gg := pr12 ℓ. Definition cell_of_cartesian_lift_2cell_is_cartesian {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {gg : xx -->[ g ] yy} {α : f ==> g} (ℓ : cartesian_lift_2cell gg α) : is_cartesian_2cell (cell_of_cartesian_lift_2cell ℓ) := pr22 ℓ. Definition local_cleaving : UU := ∏ (x y : B) (xx : D x) (yy : D y) (f g : x --> y) (gg : xx -->[ g ] yy) (α : f ==> g), cartesian_lift_2cell gg α. Definition global_cleaving : UU := ∏ (a b : B) (bb : D b) (f : a --> b), ∑ (aa : D a) (ff : aa -->[ f ] bb), cartesian_1cell ff. Definition lwhisker_cartesian : UU := ∏ (w x y : B) (ww : D w) (xx : D x) (yy : D y) (h : w --> x) (f g : x --> y) (hh : ww -->[ h ] xx) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (α : f ==> g) (αα : ff ==>[ α ] gg), is_cartesian_2cell αα → is_cartesian_2cell (hh ◃◃ αα). Definition rwhisker_cartesian : UU := ∏ (x y z : B) (xx : D x) (yy : D y) (zz : D z) (f g : x --> y) (h : y --> z) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (hh : yy -->[ h ] zz) (α : f ==> g) (αα : ff ==>[ α ] gg), is_cartesian_2cell αα → is_cartesian_2cell (αα ▹▹ hh). Definition cleaving_of_bicats : UU := local_cleaving × global_cleaving × lwhisker_cartesian × rwhisker_cartesian. End BicatCleaving. (** 2. Properties of cartesian 2-cells *) Definition local_fib {B : bicat} (D : disp_bicat B) : UU := ∏ (x y : B) (xx : D x) (yy : D y), cleaving (disp_hom xx yy). (** Being a cartesian 2-cell is a proposition *) Definition isaprop_is_cartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) : isaprop (is_cartesian_2cell D αα). Proof. unfold is_cartesian_2cell. repeat (use impred ; intro). apply isapropiscontr. Qed. (** The two definitions of local cleavings coincide *) Definition cartesian_2cell_to_cartesian {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) (Hαα : is_cartesian_2cell D αα) : @is_cartesian _ (disp_hom xx yy) _ _ _ _ _ αα. Proof. intros h γ hh γα. exact (Hαα h hh γ γα). Qed. Definition cartesian_to_cartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) (Hαα : @is_cartesian _ (disp_hom xx yy) _ _ _ _ _ αα) : is_cartesian_2cell D αα. Proof. intros h hh γ γα. exact (Hαα h γ hh γα). Qed. Definition cartesian_2cell_weq_cartesian {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) : (@is_cartesian _ (disp_hom xx yy) _ _ _ _ _ αα) ≃ is_cartesian_2cell D αα. Proof. use weqimplimpl. - apply cartesian_to_cartesian_2cell. - apply cartesian_2cell_to_cartesian. - apply isaprop_is_cartesian. - apply isaprop_is_cartesian_2cell. Qed. Definition local_cleaving_to_local_fib {B : bicat} {D : disp_bicat B} (HD : local_cleaving D) : local_fib D. Proof. intros x y xx yy g f α gg ; cbn in *. pose (HD x y xx yy f g gg α) as lift. unfold cartesian_lift. unfold cartesian_lift_2cell in lift. cbn. refine (pr1 lift ,, pr12 lift ,, _). apply cartesian_2cell_to_cartesian. exact (pr22 lift). Defined. Definition local_fib_to_local_cleaving {B : bicat} {D : disp_bicat B} (HD : local_fib D) : local_cleaving D. Proof. intros x y xx yy g f α gg ; cbn in *. pose (HD x y xx yy f g gg α) as lift. unfold cartesian_lift in lift. unfold cartesian_lift_2cell. cbn. refine (pr1 lift ,, pr12 lift ,, _). apply cartesian_to_cartesian_2cell. exact (pr22 lift). Defined. Definition local_fib_weq_local_cleaving {B : bicat} (D : disp_bicat B) : local_cleaving D ≃ local_fib D. Proof. use make_weq. - exact local_cleaving_to_local_fib. - use isweq_iso. + exact local_fib_to_local_cleaving. + abstract (intro HD ; repeat (use funextsec ; intro) ; use total2_paths_f ; [ apply idpath | ] ; cbn ; use total2_paths_f ; [ apply idpath | ] ; cbn ; apply isaprop_is_cartesian_2cell). + abstract (intro HD ; repeat (use funextsec ; intro) ; use total2_paths_f ; [ apply idpath | ] ; cbn ; use total2_paths_f ; [ apply idpath | ] ; cbn ; apply isaprop_is_cartesian). Defined. (** Properties of cartesian 2-cells *) Definition identity_is_cartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : is_cartesian_2cell D (disp_id2 ff). Proof. apply cartesian_to_cartesian_2cell. exact (@is_cartesian_id_disp _ (disp_hom xx yy) f ff). Defined. Definition vcomp_is_cartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g h : x --> y} {α : f ==> g} {β : g ==> h} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {hh : xx -->[ h ] yy} {αα : ff ==>[ α ] gg} {ββ : gg ==>[ β ] hh} (Hαα : is_cartesian_2cell D αα) (Hββ : is_cartesian_2cell D ββ) : is_cartesian_2cell D (αα •• ββ). Proof. apply cartesian_to_cartesian_2cell. exact (@is_cartesian_comp_disp _ (disp_hom xx yy) f ff g gg h hh α β αα ββ (cartesian_2cell_to_cartesian _ Hαα) (cartesian_2cell_to_cartesian _ Hββ)). Defined. Definition invertible_is_cartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {αα : ff ==>[ α ] gg} (Hαα : is_disp_invertible_2cell Hα αα) : is_cartesian_2cell D αα. Proof. apply cartesian_to_cartesian_2cell. apply (is_cartesian_z_iso_disp (disp_hom_disp_invertible_2cell_to_z_iso _ Hαα)). Defined. Section Cartesian2CellUnique. Context {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff₁ ff₂ : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {αα : ff₁ ==>[ α ] gg} {ββ : ff₂ ==>[ α ] gg} (Hαα : is_cartesian_2cell D αα) (Hββ : is_cartesian_2cell D ββ). Let m : ff₁ ==>[ id₂ f] ff₂. Proof. use (is_cartesian_2cell_factor _ Hββ). exact (transportb (λ z, _ ==>[ z ] _) (id2_left _) αα). Defined. Let i : ff₂ ==>[ id₂ f] ff₁. Proof. use (is_cartesian_2cell_factor _ Hαα). exact (transportb (λ z, _ ==>[ z ] _) (id2_left _) ββ). Defined. Local Lemma is_cartesian_2cell_unique_iso_inv₁ : m •• i = transportb (λ z, ff₁ ==>[ z ] ff₁) (id2_left (id₂ f)) (disp_id2 ff₁). Proof. use (is_cartesian_2cell_unique _ Hαα). - refine (transportb (λ z, _ ==>[ z ] _) _ αα). abstract (rewrite !vassocl ; rewrite !id2_left ; apply idpath). - rewrite disp_vassocl. unfold i. rewrite is_cartesian_2cell_comm. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. unfold m. rewrite is_cartesian_2cell_comm. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Local Lemma is_cartesian_2cell_unique_iso_inv₂ : i •• m = transportb (λ z, ff₂ ==>[ z ] ff₂) (id2_left (id₂ f)) (disp_id2 ff₂). Proof. use (is_cartesian_2cell_unique _ Hββ). - refine (transportb (λ z, _ ==>[ z ] _) _ ββ). abstract (rewrite !vassocl ; rewrite !id2_left ; apply idpath). - rewrite disp_vassocl. unfold m. rewrite is_cartesian_2cell_comm. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. unfold i. rewrite is_cartesian_2cell_comm. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Definition is_cartesian_2cell_unique_iso : disp_invertible_2cell (id2_invertible_2cell _) ff₁ ff₂ := (m ,, i ,, is_cartesian_2cell_unique_iso_inv₁ ,, is_cartesian_2cell_unique_iso_inv₂). Definition is_cartesian_2cell_unique_iso_com : αα = transportf (λ z, _ ==>[ z ] _) (id2_left _) (is_cartesian_2cell_unique_iso •• ββ). Proof. cbn ; unfold m. rewrite is_cartesian_2cell_comm. unfold transportb. rewrite transport_f_f. rewrite pathsinv0l. apply idpath. Qed. End Cartesian2CellUnique. Definition disp_hcomp_is_cartesian_2cell {B : bicat} {D : disp_bicat B} (CD : cleaving_of_bicats D) {b₁ b₂ b₃ : B} {f₁ f₂ : b₁ --> b₂} {g₁ g₂ : b₂ --> b₃} {α : f₁ ==> f₂} {β : g₁ ==> g₂} {bb₁ : D b₁} {bb₂ : D b₂} {bb₃ : D b₃} {ff₁ : bb₁ -->[ f₁ ] bb₂} {ff₂ : bb₁ -->[ f₂ ] bb₂} {gg₁ : bb₂ -->[ g₁ ] bb₃} {gg₂ : bb₂ -->[ g₂ ] bb₃} {αα : ff₁ ==>[ α ] ff₂} {ββ : gg₁ ==>[ β ] gg₂} (Hαα : is_cartesian_2cell D αα) (Hββ : is_cartesian_2cell D ββ) : is_cartesian_2cell D (disp_hcomp αα ββ). Proof. use vcomp_is_cartesian_2cell. - apply CD. exact Hαα. - apply CD. exact Hββ. Defined. (** 3. Local Opcleavings *) Section LocalOpcleaving. Context {B : bicat} (D : disp_bicat B). Definition is_opcartesian_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {α : f ==> g} (αα : ff ==>[ α ] gg) : UU := ∏ (h : x --> y) (hh : xx -->[ h ] yy) (γ : g ==> h) (ββ : ff ==>[ α • γ ] hh), ∃! (γγ : gg ==>[ γ ] hh), (αα •• γγ) = ββ. Section OpCartesian2Cell. Context {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {α : f ==> g} {αα : ff ==>[ α ] gg} (Hαα : is_opcartesian_2cell αα). Definition is_opcartesian_2cell_factor {h : x --> y} (hh : xx -->[ h ] yy) (γ : g ==> h) (ββ : ff ==>[ α • γ ] hh) : gg ==>[ γ ] hh := pr11 (Hαα h hh γ ββ). Definition is_opcartesian_2cell_comm {h : x --> y} (hh : xx -->[ h ] yy) (γ : g ==> h) (ββ : ff ==>[ α • γ ] hh) : (αα •• is_opcartesian_2cell_factor hh γ ββ) = ββ := pr21 (Hαα h hh γ ββ). Definition is_opcartesian_2cell_unique {h : x --> y} (hh : xx -->[ h ] yy) (γ : g ==> h) (ββ : ff ==>[ α • γ ] hh) {γγ₁ γγ₂ : gg ==>[ γ ] hh} (pγγ₁ : (αα •• γγ₁) = ββ) (pγγ₂ : (αα •• γγ₂) = ββ) : γγ₁ = γγ₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hαα h hh γ ββ)) (γγ₁ ,, pγγ₁) (γγ₂ ,, pγγ₂))). Qed. End OpCartesian2Cell. Definition opcartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} (ff : xx -->[ f ] yy) (α : f ==> g) : UU := ∑ (gg : xx -->[ g ] yy) (αα : ff ==>[ α ] gg), is_opcartesian_2cell αα. Coercion mor_of_opcartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {α : f ==> g} (ℓ : opcartesian_lift_2cell ff α) : xx -->[ g ] yy := pr1 ℓ. Definition cell_of_opcartesian_lift_2cell {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {α : f ==> g} (ℓ : opcartesian_lift_2cell ff α) : ff ==>[ α ] ℓ := pr12 ℓ. Definition cell_of_opcartesian_lift_2cell_is_opcartesian {x y : B} {xx : D x} {yy : D y} {f g : x --> y} {ff : xx -->[ f ] yy} {α : f ==> g} (ℓ : opcartesian_lift_2cell ff α) : is_opcartesian_2cell (cell_of_opcartesian_lift_2cell ℓ) := pr22 ℓ. Definition local_opcleaving : UU := ∏ (x y : B) (xx : D x) (yy : D y) (f g : x --> y) (ff : xx -->[ f ] yy) (α : f ==> g), opcartesian_lift_2cell ff α. End LocalOpcleaving. (** 4. Properties of opcartesian 2-cells *) Definition local_opfib {B : bicat} (D : disp_bicat B) : UU := ∏ (x y : B) (xx : D x) (yy : D y), opcleaving (disp_hom xx yy). (** Being a cartesian 2-cell is a proposition *) Definition isaprop_is_opcartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) : isaprop (is_opcartesian_2cell D αα). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. (** The two definitions of local cleavings coincide *) Definition opcartesian_2cell_to_opcartesian {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) (Hαα : is_opcartesian_2cell D αα) : @is_opcartesian _ (disp_hom xx yy) _ _ _ _ _ αα. Proof. intros h γ hh γα. apply Hαα. Qed. Definition opcartesian_to_opcartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) (Hαα : @is_opcartesian _ (disp_hom xx yy) _ _ _ _ _ αα) : is_opcartesian_2cell D αα. Proof. intros h hh γ γα. apply Hαα. Qed. Definition opcartesian_2cell_weq_opcartesian {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : ff ==>[ α ] gg) : (@is_opcartesian _ (disp_hom xx yy) _ _ _ _ _ αα) ≃ is_opcartesian_2cell D αα. Proof. use weqimplimpl. - apply opcartesian_to_opcartesian_2cell. - apply opcartesian_2cell_to_opcartesian. - apply isaprop_is_opcartesian. - apply isaprop_is_opcartesian_2cell. Qed. Definition local_opcleaving_to_local_opfib {B : bicat} {D : disp_bicat B} (HD : local_opcleaving D) : local_opfib D. Proof. intros x y xx yy f g ff α ; cbn in *. pose (HD x y xx yy f g ff α) as lift. refine (pr1 lift ,, pr12 lift ,, _). apply opcartesian_2cell_to_opcartesian. exact (pr22 lift). Defined. Definition local_opfib_to_local_opcleaving {B : bicat} {D : disp_bicat B} (HD : local_opfib D) : local_opcleaving D. Proof. intros x y xx yy f g ff α ; cbn in *. pose (HD x y xx yy f g ff α) as lift. refine (pr1 lift ,, pr12 lift ,, _). apply opcartesian_to_opcartesian_2cell. exact (pr22 lift). Defined. Definition local_opfib_weq_local_opcleaving {B : bicat} (D : disp_bicat B) : local_opcleaving D ≃ local_opfib D. Proof. use make_weq. - exact local_opcleaving_to_local_opfib. - use isweq_iso. + exact local_opfib_to_local_opcleaving. + abstract (intro HD ; repeat (use funextsec ; intro) ; use total2_paths_f ; [ apply idpath | ] ; cbn ; use total2_paths_f ; [ apply idpath | ] ; cbn ; apply isaprop_is_opcartesian_2cell). + abstract (intro HD ; repeat (use funextsec ; intro) ; use total2_paths_f ; [ apply idpath | ] ; cbn ; use total2_paths_f ; [ apply idpath | ] ; cbn ; apply isaprop_is_opcartesian). Defined. Definition identity_is_opcartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : is_opcartesian_2cell D (disp_id2 ff). Proof. apply opcartesian_to_opcartesian_2cell. exact (@is_opcartesian_id_disp _ (disp_hom xx yy) f ff). Defined. Definition vcomp_is_opcartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g h : x --> y} {α : f ==> g} {β : g ==> h} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {hh : xx -->[ h ] yy} {αα : ff ==>[ α ] gg} {ββ : gg ==>[ β ] hh} (Hαα : is_opcartesian_2cell D αα) (Hββ : is_opcartesian_2cell D ββ) : is_opcartesian_2cell D (αα •• ββ). Proof. apply opcartesian_to_opcartesian_2cell. exact (@is_opcartesian_comp_disp _ (disp_hom xx yy) f ff g gg h hh α β αα ββ (opcartesian_2cell_to_opcartesian _ Hαα) (opcartesian_2cell_to_opcartesian _ Hββ)). Defined. Definition invertible_is_opcartesian_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {αα : ff ==>[ α ] gg} (Hαα : is_disp_invertible_2cell Hα αα) : is_opcartesian_2cell D αα. Proof. apply opcartesian_to_opcartesian_2cell. apply (is_opcartesian_z_iso_disp (disp_hom_disp_invertible_2cell_to_z_iso _ Hαα)). Defined. Definition lwhisker_opcartesian {B : bicat} (D : disp_bicat B) : UU := ∏ (w x y : B) (ww : D w) (xx : D x) (yy : D y) (h : w --> x) (f g : x --> y) (hh : ww -->[ h ] xx) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (α : f ==> g) (αα : ff ==>[ α ] gg), is_opcartesian_2cell _ αα → is_opcartesian_2cell _ (hh ◃◃ αα). Definition rwhisker_opcartesian {B : bicat} (D : disp_bicat B) : UU := ∏ (x y z : B) (xx : D x) (yy : D y) (zz : D z) (f g : x --> y) (h : y --> z) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (hh : yy -->[ h ] zz) (α : f ==> g) (αα : ff ==>[ α ] gg), is_opcartesian_2cell _ αα → is_opcartesian_2cell _ (αα ▹▹ hh). Section OpCartesian2CellUnique. Context {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg₁ gg₂ : xx -->[ g ] yy} {αα : ff ==>[ α ] gg₁} {ββ : ff ==>[ α ] gg₂} (Hαα : is_opcartesian_2cell D αα) (Hββ : is_opcartesian_2cell D ββ). Let m : gg₁ ==>[ id₂ g ] gg₂. Proof. use (is_opcartesian_2cell_factor _ Hαα). exact (transportb (λ z, _ ==>[ z ] _) (id2_right _) ββ). Defined. Let i : gg₂ ==>[ id₂ g ] gg₁. Proof. use (is_opcartesian_2cell_factor _ Hββ). exact (transportb (λ z, _ ==>[ z ] _) (id2_right _) αα). Defined. Local Lemma is_opcartesian_2cell_unique_iso_inv₁ : i •• m = transportb (λ z, _ ==>[ z ] _) (id2_left _) (disp_id2 _). Proof. use (is_opcartesian_2cell_unique _ Hββ). - refine (transportb (λ z, _ ==>[ z ] _) _ ββ). abstract (rewrite !id2_right ; apply idpath). - unfold i, m. rewrite disp_vassocr. rewrite is_opcartesian_2cell_comm. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite is_opcartesian_2cell_comm. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Local Lemma is_opcartesian_2cell_unique_iso_inv₂ : m •• i = transportb (λ z, _ ==>[ z ] _) (id2_left _) (disp_id2 gg₁). Proof. use (is_opcartesian_2cell_unique _ Hαα). - refine (transportb (λ z, _ ==>[ z ] _) _ αα). abstract (rewrite !id2_right ; apply idpath). - unfold i, m. rewrite disp_vassocr. rewrite is_opcartesian_2cell_comm. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite is_opcartesian_2cell_comm. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Definition is_opcartesian_2cell_unique_iso : disp_invertible_2cell (id2_invertible_2cell _) gg₂ gg₁ := (i ,, m ,, is_opcartesian_2cell_unique_iso_inv₁ ,, is_opcartesian_2cell_unique_iso_inv₂). Definition is_opcartesian_2cell_unique_iso_com : αα = transportf (λ z, _ ==>[ z ] _) (id2_right _) (ββ •• is_opcartesian_2cell_unique_iso). Proof. cbn ; unfold i. rewrite is_opcartesian_2cell_comm. unfold transportb. rewrite transport_f_f. rewrite pathsinv0l. apply idpath. Qed. End OpCartesian2CellUnique. Definition disp_hcomp_is_opcartesian_2cell {B : bicat} {D : disp_bicat B} (HD_l : lwhisker_opcartesian D) (HD_r : rwhisker_opcartesian D) {b₁ b₂ b₃ : B} {f₁ f₂ : b₁ --> b₂} {g₁ g₂ : b₂ --> b₃} {α : f₁ ==> f₂} {β : g₁ ==> g₂} {bb₁ : D b₁} {bb₂ : D b₂} {bb₃ : D b₃} {ff₁ : bb₁ -->[ f₁ ] bb₂} {ff₂ : bb₁ -->[ f₂ ] bb₂} {gg₁ : bb₂ -->[ g₁ ] bb₃} {gg₂ : bb₂ -->[ g₂ ] bb₃} {αα : ff₁ ==>[ α ] ff₂} {ββ : gg₁ ==>[ β ] gg₂} (Hαα : is_opcartesian_2cell D αα) (Hββ : is_opcartesian_2cell D ββ) : is_opcartesian_2cell D (disp_hcomp αα ββ). Proof. use vcomp_is_opcartesian_2cell. - apply HD_r. exact Hαα. - apply HD_l. exact Hββ. Defined. (** 5. Local isocleavings *) Section LocalIsoCleaving. Context {C : bicat}. Definition local_iso_cleaving (D : disp_prebicat C) : UU := ∏ (c c' : C) (f f' : C⟦c,c'⟧) (d : D c) (d' : D c') (ff' : d -->[f'] d') (α : invertible_2cell f f'), ∑ ff : d -->[f] d', disp_invertible_2cell α ff ff'. Section Projections. Context {D : disp_prebicat C} (lic : local_iso_cleaving D) {c c' : C} {f f' : C⟦c,c'⟧} {d : D c} {d' : D c'} (ff' : d -->[f'] d') (α : invertible_2cell f f'). Definition local_iso_cleaving_1cell : d -->[f] d' := pr1 (lic c c' f f' d d' ff' α). Definition disp_local_iso_cleaving_invertible_2cell : disp_invertible_2cell α local_iso_cleaving_1cell ff' := pr2 (lic c c' f f' d d' ff' α). End Projections. End LocalIsoCleaving. Definition univalent_2_1_to_local_iso_cleaving_help {C : bicat} {D : disp_prebicat C} {c c' : C} {f f' : C⟦c,c'⟧} {d : D c} {d' : D c'} (ff' : d -->[f'] d') (α : f = f') : ∑ ff : d -->[f] d', disp_invertible_2cell (idtoiso_2_1 _ _ α) ff ff'. Proof. induction α. refine (ff' ,, _). apply disp_id2_invertible_2cell. Defined. Definition univalent_2_1_to_local_iso_cleaving {C : bicat} (HC : is_univalent_2_1 C) (D : disp_prebicat C) : local_iso_cleaving D. Proof. intros x y f g xx yy gg α. pose (univalent_2_1_to_local_iso_cleaving_help gg (isotoid_2_1 HC α)) as t. rewrite idtoiso_2_1_isotoid_2_1 in t. exact t. Defined. (** 6. Local isocleavings from local (op)cleavings *) Section LocalCleavingToLocalIsoCleaving. Context {B : bicat} {D : disp_bicat B} (HD : local_cleaving D) {x y : B} {f g : x --> y} {xx : D x} {yy : D y} (gg : xx -->[ g ] yy) (α : invertible_2cell f g). Definition local_cleaving_to_local_iso_cleaving_lift : xx -->[ f ] yy := HD x y xx yy f g gg α. Let ff : xx -->[ f ] yy := local_cleaving_to_local_iso_cleaving_lift. Let γ : ff ==>[ α ] gg := cell_of_cartesian_lift_2cell _ (HD x y xx yy f g gg α). Let Hγ : is_cartesian_2cell _ γ := cell_of_cartesian_lift_2cell_is_cartesian _ (HD x y xx yy f g gg α). Definition local_cleaving_to_local_iso_cleaving_disp_inv : gg ==>[ α^-1 ] ff. Proof. use (is_cartesian_2cell_factor _ Hγ). refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (cbn ; rewrite vcomp_linv ; apply idpath). Defined. Let δ : gg ==>[ α^-1 ] ff := local_cleaving_to_local_iso_cleaving_disp_inv. Lemma local_cleaving_to_local_iso_cleaving_disp_left_inv : γ •• δ = transportb (λ z, ff ==>[ z ] ff) (vcomp_rinv α) (disp_id2 ff). Proof. unfold δ, local_cleaving_to_local_iso_cleaving_disp_inv. use (is_cartesian_2cell_unique _ Hγ). - refine (transportf (λ z, _ ==>[ z ] _) _ γ). abstract (rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). - rewrite disp_vassocl. rewrite is_cartesian_2cell_comm. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Lemma local_cleaving_to_local_iso_cleaving_disp_right_inv : δ •• γ = transportb (λ z, gg ==>[ z ] gg) (vcomp_linv α) (disp_id2 gg). Proof. unfold δ, local_cleaving_to_local_iso_cleaving_disp_inv. rewrite is_cartesian_2cell_comm. unfold transportb. apply maponpaths_2. apply cellset_property. Qed. Definition local_cleaving_to_local_iso_cleaving_disp_iso : disp_invertible_2cell α ff gg. Proof. simple refine (_ ,, _). - exact γ. - refine (δ ,, _ ,, _). * exact local_cleaving_to_local_iso_cleaving_disp_left_inv. * exact local_cleaving_to_local_iso_cleaving_disp_right_inv. Defined. End LocalCleavingToLocalIsoCleaving. Definition local_cleaving_to_local_iso_cleaving {B : bicat} {D : disp_bicat B} (HD : local_cleaving D) : local_iso_cleaving D := λ x y f g xx yy gg α, local_cleaving_to_local_iso_cleaving_lift HD gg α ,, local_cleaving_to_local_iso_cleaving_disp_iso HD gg α. Section LocalOpCleavingToLocalIsoCleaving. Context {B : bicat} {D : disp_bicat B} (HD : local_opcleaving D) {x y : B} {f g : x --> y} {xx : D x} {yy : D y} (gg : xx -->[ g ] yy) (α : invertible_2cell f g). Definition local_opcleaving_to_local_iso_cleaving_lift : xx -->[ f ] yy := HD x y xx yy g f gg (α^-1). Let ff : xx -->[ f ] yy := local_opcleaving_to_local_iso_cleaving_lift. Let γ : gg ==>[ α^-1 ] ff := cell_of_opcartesian_lift_2cell _ (HD x y xx yy g f gg (α^-1)). Let Hγ : is_opcartesian_2cell _ γ := cell_of_opcartesian_lift_2cell_is_opcartesian _ (HD x y xx yy g f gg (α^-1)). Definition local_opcleaving_to_local_iso_cleaving_disp_iso_cell : ff ==>[ α ] gg. Proof. use (is_opcartesian_2cell_factor _ Hγ). refine (transportf (λ z, _ ==>[ z ] _) _ (disp_id2 _)). abstract (rewrite vcomp_linv ; apply idpath). Defined. Let δ : ff ==>[ α ] gg := local_opcleaving_to_local_iso_cleaving_disp_iso_cell. Lemma local_opcleaving_to_local_iso_cleaving_left_inv : δ •• γ = transportb (λ z, ff ==>[ z ] ff) (vcomp_rinv α) (disp_id2 ff). Proof. unfold δ, local_opcleaving_to_local_iso_cleaving_disp_iso_cell. use (is_opcartesian_2cell_unique _ Hγ). - refine (transportf (λ z, _ ==>[ z ] _) _ γ). abstract (rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). - rewrite disp_vassocr. rewrite is_opcartesian_2cell_comm. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. - unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Lemma local_opcleaving_to_local_iso_cleaving_right_inv : γ •• δ = transportb (λ z, gg ==>[ z ] gg) (vcomp_linv α) (disp_id2 gg). Proof. unfold δ, local_opcleaving_to_local_iso_cleaving_disp_iso_cell. rewrite is_opcartesian_2cell_comm. unfold transportb. apply maponpaths_2. apply cellset_property. Qed. Definition local_opcleaving_to_local_iso_cleaving_disp_iso : disp_invertible_2cell α ff gg. Proof. simple refine (_ ,, _). - exact δ. - refine (γ ,, _ ,, _). + exact local_opcleaving_to_local_iso_cleaving_left_inv. + exact local_opcleaving_to_local_iso_cleaving_right_inv. Defined. End LocalOpCleavingToLocalIsoCleaving. Definition local_opcleaving_to_local_iso_cleaving {B : bicat} {D : disp_bicat B} (HD : local_opcleaving D) : local_iso_cleaving D := λ x y f g xx yy gg α, local_opcleaving_to_local_iso_cleaving_lift HD gg α ,, local_opcleaving_to_local_iso_cleaving_disp_iso HD gg α. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/CleavingOfBicatIsAProp.v000066400000000000000000000173361451125700300267370ustar00rootroot00000000000000(******************************************************************** Cleaving properties There are several definitions of cleaving of bicategories, namely local (op)cleavings and global cleavings. If we assume that the involved (displayed) bicategories are univalent, then we can show that these notions are propositional Contents 1. Propositionality of preservation of cartesian cells 2. Propositionality of local (op)cleavings 3. Propositionality of global cleavings ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Cartesians. Require Import UniMath.Bicategories.DisplayedBicats.EquivalenceBetweenCartesians. Local Open Scope cat. (** 1. Propositionality of preservation of cartesian cells *) Definition isaprop_lwhisker_cartesian {B : bicat} (D : disp_bicat B) : isaprop (lwhisker_cartesian D). Proof. do 15 (use impred ; intro). apply isaprop_is_cartesian_2cell. Qed. Definition isaprop_rwhisker_cartesian {B : bicat} (D : disp_bicat B) : isaprop (rwhisker_cartesian D). Proof. do 15 (use impred ; intro). apply isaprop_is_cartesian_2cell. Qed. Definition isaprop_lwhisker_opcartesian {B : bicat} (D : disp_bicat B) : isaprop (lwhisker_opcartesian D). Proof. do 15 (use impred ; intro). apply isaprop_is_opcartesian_2cell. Qed. Definition isaprop_rwhisker_opcartesian {B : bicat} (D : disp_bicat B) : isaprop (rwhisker_opcartesian D). Proof. do 15 (use impred ; intro). apply isaprop_is_opcartesian_2cell. Qed. (** 2. Propositionality of local (op)cleavings *) Definition isaprop_local_cleaving {B : bicat} (HB : is_univalent_2_1 B) (D : disp_bicat B) (HD : disp_univalent_2_1 D) : isaprop (local_cleaving D). Proof. use (isofhlevelweqb 1 (local_fib_weq_local_cleaving D)). use impred ; intro x. use impred ; intro y. use impred ; intro xx. use impred ; intro yy. use (@isaprop_cleaving (univ_hom HB x y)). use is_univalent_disp_disp_hom. exact HD. Defined. Definition isaprop_local_opcleaving {B : bicat} (HB : is_univalent_2_1 B) (D : disp_bicat B) (HD : disp_univalent_2_1 D) : isaprop (local_opcleaving D). Proof. use (isofhlevelweqb 1 (local_opfib_weq_local_opcleaving D)). unfold local_opfib. use impred ; intro x. use impred ; intro y. use impred ; intro xx. use impred ; intro yy. use (isofhlevelweqb 1 (opcleaving_weq_cleaving _)). use (@isaprop_cleaving (op_unicat (univ_hom HB x y))). apply is_univalent_op_disp_cat. apply is_univalent_disp_disp_hom. exact HD. Defined. (** 3. Propositionality of global cleavings *) Definition eq_cartesian_lift {B : bicat} (D : disp_bicat B) (HD : disp_univalent_2_1 D) {x y : B} {yy : D y} {f : x --> y} (ℓ₁ ℓ₂ : ∑ (xx : D x) (ff : xx -->[ f ] yy), cartesian_1cell D ff) (p₁ : pr1 ℓ₁ = pr1 ℓ₂) (p₂ : transportf (λ z, z -->[ f ] yy) p₁ (pr12 ℓ₁) = pr12 ℓ₂) : ℓ₁ = ℓ₂. Proof. induction ℓ₁ as [ xx₁ [ ff₁ Hff₁ ]]. induction ℓ₂ as [ xx₂ [ ff₂ Hff₂ ]]. cbn in *. induction p₁ ; cbn in *. induction p₂ ; cbn in *. do 2 apply maponpaths. apply isaprop_cartesian_1cell. apply HD. Defined. Definition eq_cartesian_lift_from_adjequiv_transport {B : bicat} (HB : is_univalent_2 B) {D : disp_bicat B} (HD : disp_univalent_2 D) {x y : B} (f : x --> y) (yy : D y) {xx₁ xx₂ : D x} (p : xx₁ = xx₂) (ff : xx₂ -->[ f] yy) : transportb (λ z, z -->[ f ] yy) p ff = transportf (λ z, _ -->[ z ] _) (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell _)) (disp_idtoiso_2_0 _ (idpath _) _ _ p ;; ff)%mor_disp. Proof. induction p. cbn. refine (!_). refine (disp_isotoid_2_1 _ (pr2 HD) (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell f)) _ _ (transportf (λ z, disp_invertible_2cell z _ _) _ (disp_invertible_2cell_lunitor ff))). use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. rewrite idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Definition eq_cartesian_lift_from_adjequiv {B : bicat} (HB : is_univalent_2 B) (D : disp_bicat B) (HD : disp_univalent_2 D) {x y : B} {yy : D y} {f : x --> y} (ℓ₁ ℓ₂ : ∑ (xx : D x) (ff : xx -->[ f ] yy), cartesian_1cell D ff) (e : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 ℓ₁) (pr1 ℓ₂)) (γ : disp_invertible_2cell (lunitor_invertible_2cell _) (e ;; pr12 ℓ₂) (pr12 ℓ₁)) : ℓ₁ = ℓ₂. Proof. use eq_cartesian_lift. - apply HD. - exact (disp_isotoid_2_0 (pr1 HD) e). - pose (disp_isotoid_2_1 _ (pr2 HD) (isotoid_2_1 (pr2 HB) (lunitor_invertible_2cell _)) _ _ (transportb (λ z, disp_invertible_2cell z _ _) (idtoiso_2_1_isotoid_2_1 _ _) γ)) as p. use (@transportf_transpose_left _ (λ z, z -->[ f ] yy)). refine (!_). refine (_ @ p) ; clear p. refine (eq_cartesian_lift_from_adjequiv_transport HB HD _ _ _ _ @ _). apply maponpaths. apply maponpaths_2. rewrite disp_idtoiso_2_0_isotoid_2_0. apply idpath. Qed. Definition isaprop_global_cleaving {B : bicat} (HB : is_univalent_2 B) (D : disp_bicat B) (HD : disp_univalent_2 D) : isaprop (global_cleaving D). Proof. use impred ; intro x. use impred ; intro y. use impred ; intro xx. use impred ; intro f. use invproofirrelevance. intros ℓ₁ ℓ₂. use eq_cartesian_lift_from_adjequiv. - apply HB. - apply HD. - refine (map_between_cartesian_1cell (pr2 HB) (pr12 ℓ₁) (pr22 ℓ₂) ,, _). refine (transportf (λ z, disp_left_adjoint_equivalence z _) _ (pr2 (disp_adj_equiv_between_cartesian_1cell (pr2 HB) (pr22 ℓ₁) (pr22 ℓ₂)))). use unique_internal_adjoint_equivalence. apply HB. - cbn. apply map_between_cartesian_1cell_commute. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispAdjunctions.v000066400000000000000000000733051451125700300256200ustar00rootroot00000000000000(* *********************************************************************************** *) (** * Internal adjunction in displayed bicategories Benedikt Ahrens, Marco Maggesi, Niels van der Weide, Dan Frumin April 2018 *) (* *********************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Export UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Local Open Scope cat. Local Open Scope mor_disp_scope. (** * Definitions and properties of displayed adjunctions *) Section Displayed_Internal_Adjunction. Context {C : bicat} {D : disp_prebicat C}. (** ** Displayed left adjoints *) (** *** Data & laws for left adjoints *) Definition disp_left_adjoint_data {a b : C} {f : a --> b} (αd : left_adjoint_data f) {aa : D a} {bb : D b} (ff : aa -->[f] bb) : UU := ∑ (gg : bb -->[left_adjoint_right_adjoint αd] aa), (id_disp aa ==>[left_adjoint_unit αd] ff ;; gg) × (gg ;; ff ==>[left_adjoint_counit αd] id_disp bb). Definition disp_left_adjoint_right_adjoint {a b : C} {f : a --> b} (αd : left_adjoint_data f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααd : disp_left_adjoint_data αd ff) : bb -->[left_adjoint_right_adjoint αd] aa := pr1 ααd. Definition disp_left_adjoint_unit {a b : C} {f : a --> b} (αd : left_adjoint_data f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααd : disp_left_adjoint_data αd ff) : id_disp aa ==>[left_adjoint_unit αd] ff ;; disp_left_adjoint_right_adjoint αd ααd := pr12 ααd. Definition disp_left_adjoint_counit {a b : C} {f : a --> b} (αd : left_adjoint_data f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααd : disp_left_adjoint_data αd ff) : disp_left_adjoint_right_adjoint αd ααd ;; ff ==>[left_adjoint_counit αd] id_disp bb := pr22 ααd. Definition disp_left_adjoint_axioms {a b : C} {f : a --> b} (j : left_adjoint f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααd : disp_left_adjoint_data j ff) : UU := let gg := disp_left_adjoint_right_adjoint j ααd in let ηη := disp_left_adjoint_unit j ααd in let εε := disp_left_adjoint_counit j ααd in ( disp_linvunitor ff •• (ηη ▹▹ ff) •• disp_rassociator _ _ _ •• (ff ◃◃ εε) •• disp_runitor ff = transportb (λ x, _ ==>[x] _) (internal_triangle1 j) (disp_id2 ff) ) × ( disp_rinvunitor gg •• (gg ◃◃ ηη) •• disp_lassociator _ _ _ •• (εε ▹▹ gg) •• disp_lunitor gg = transportb (λ x, _ ==>[x] _) (internal_triangle2 j) (disp_id2 gg) ). Definition disp_internal_triangle1 {a b : C} {f : a --> b} (j : left_adjoint f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {ααd : disp_left_adjoint_data j ff} (H : disp_left_adjoint_axioms j ααd) := pr1 H. Definition disp_internal_triangle2 {a b : C} {f : a --> b} (j : left_adjoint f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {ααd : disp_left_adjoint_data j ff} (H : disp_left_adjoint_axioms j ααd) := pr2 H. Definition internal_triangle2 {a b : C} {f : C⟦a,b⟧} {adj : left_adjoint_data f} (L : left_adjoint_axioms adj) (g := left_adjoint_right_adjoint adj) : rinvunitor g • (g ◃ left_adjoint_unit adj) • lassociator _ _ _ • (left_adjoint_counit adj ▹ g) • lunitor g = id2 g := pr2 L. Definition disp_left_adjoint {a b : C} {f : a --> b} (α : left_adjoint f) {aa : D a} {bb : D b} (ff : aa -->[f] bb) := ∑ (ααd : disp_left_adjoint_data α ff), disp_left_adjoint_axioms α ααd. Coercion disp_data_of_left_adjoint {a b : C} {f : a --> b} (α : left_adjoint f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (αα : disp_left_adjoint α ff) : disp_left_adjoint_data α ff := pr1 αα. Coercion disp_axioms_of_left_adjoint {a b : C} {f : a --> b} (α : left_adjoint f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (αα : disp_left_adjoint α ff) : disp_left_adjoint_axioms α αα := pr2 αα. (** *** Laws for equivalences *) Definition disp_left_equivalence_axioms {a b : C} {f : a --> b} (αe : left_equivalence f) {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααd : disp_left_adjoint_data αe ff) : UU := is_disp_invertible_2cell (left_equivalence_unit_iso _) (disp_left_adjoint_unit αe ααd) × is_disp_invertible_2cell (left_equivalence_counit_iso _) (disp_left_adjoint_counit αe ααd). Definition disp_left_equivalence {x y : C} {f : x --> y} (Hf : left_equivalence f) {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : UU := ∑ (d : disp_left_adjoint_data Hf ff), disp_left_equivalence_axioms Hf d. Definition disp_left_adjoint_equivalence {a b : C} {f : a --> b} (αe : left_adjoint_equivalence f) {aa : D a} {bb : D b} (ff : aa -->[f] bb) := ∑ (ααd : disp_left_adjoint_data αe ff), disp_left_adjoint_axioms αe ααd × disp_left_equivalence_axioms αe ααd. (* the coercion to the adjoint axioms will be induced *) Coercion disp_left_adjoint_of_left_adjoint_equivalence {a b : C} {f : a --> b} {αe : left_adjoint_equivalence f} {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααe : disp_left_adjoint_equivalence αe ff) : disp_left_adjoint αe ff := (pr1 ααe,, pr12 ααe). Coercion axioms_of_left_adjoint_equivalence {a b : C} {f : a --> b} {αe : left_adjoint_equivalence f} {aa : D a} {bb : D b} {ff : aa -->[f] bb} (ααe : disp_left_adjoint_equivalence αe ff) : disp_left_equivalence_axioms αe ααe := pr22 ααe. (** *** Packaged *) Definition disp_adjunction {a b : C} (f : adjunction a b) (aa : D a) (bb : D b) : UU := ∑ ff : aa -->[f] bb, disp_left_adjoint f ff. Coercion disp_arrow_of_adjunction {a b : C} {f : adjunction a b} {aa : D a} {bb : D b} (ff : disp_adjunction f aa bb) : aa -->[f] bb := pr1 ff. Coercion disp_left_adjoint_of_adjunction {a b : C} {f : adjunction a b} {aa : D a} {bb : D b} (ff : disp_adjunction f aa bb) : disp_left_adjoint f ff := pr2 ff. Definition disp_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) (aa : D a) (bb : D b) : UU := ∑ ff : aa -->[f] bb, disp_left_adjoint_equivalence f ff. Coercion disp_adjunction_of_adjoint_equivalence {a b : C} {f : adjoint_equivalence a b} {aa : D a} {bb : D b} (ff : disp_adjoint_equivalence f aa bb) : disp_adjunction f aa bb. Proof. refine (pr1 ff,, _). apply (disp_left_adjoint_of_left_adjoint_equivalence (pr2 ff)). Defined. Coercion disp_left_adjoint_equivalence_of_adjoint_equivalence {a b : C} {f : adjoint_equivalence a b} {aa : D a} {bb : D b} (ff : disp_adjoint_equivalence f aa bb) : disp_left_adjoint_equivalence f ff := pr2 ff. (* Definition internal_right_adjoint {a b : C} *) (* (f : adjunction a b) : C⟦b,a⟧ := *) (* left_adjoint_right_adjoint f. *) End Displayed_Internal_Adjunction. (** From now on, we need the [has_disp_cellset property]. *) (** ** Identity is a displayed adjoint *) (* TODO LOL MOVE THIS TO DISPLAYED UNIVALNCE *) Require Import UniMath.Bicategories.Core.Univalence. Definition disp_internal_adjunction_data_identity {C : bicat} {D : disp_bicat C} {a : C} (aa : D a) : disp_left_adjoint_data (internal_adjoint_equivalence_identity a) (id_disp aa). Proof. exists (id_disp _ ). split. - exact (disp_linvunitor _ ). - exact (disp_lunitor _ ). Defined. Definition is_disp_internal_adjunction_identity {C : bicat} {D : disp_bicat C} {a : C} (aa : D a) : disp_left_adjoint_axioms (internal_adjoint_equivalence_identity a) (disp_internal_adjunction_data_identity aa). Proof. split. - etrans. { apply maponpaths_2. etrans; [apply disp_vassocl | ]. etrans. { apply maponpaths. apply maponpaths. etrans; [apply disp_lunitor_lwhisker | ]. apply maponpaths. apply maponpaths. apply disp_runitor_lunitor_identity. } etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). } etrans. { etrans. { apply maponpaths. apply maponpaths. apply disp_rwhisker_transport_left_new. } cbn. etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). } etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). } etrans. { apply maponpaths. apply maponpaths. etrans; [apply disp_rwhisker_vcomp | ]. etrans; [apply maponpaths, maponpaths, disp_linvunitor_lunitor | ]. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). } apply maponpaths. apply disp_id2_rwhisker. } etrans. { apply maponpaths, disp_mor_transportf_prewhisker. } etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans. { apply maponpaths, disp_mor_transportf_prewhisker. } etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. apply maponpaths, disp_id2_right. } apply (transport_f_f (λ x, _ ==>[x] _)). } etrans; [ apply disp_mor_transportf_postwhisker | ]. etrans. { apply maponpaths. etrans; [ apply maponpaths, disp_runitor_lunitor_identity | ]. etrans; [ apply disp_mor_transportf_prewhisker | ]. apply maponpaths. apply disp_linvunitor_lunitor. } etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. cbn. unfold transportb. apply maponpaths_2. apply cellset_property. - etrans. { apply maponpaths_2. etrans; [apply disp_vassocl | ]. etrans. { apply maponpaths, maponpaths. etrans; [ apply maponpaths, maponpaths, disp_lunitor_runitor_identity | ]. etrans; [ apply maponpaths, disp_rwhisker_transport_left_new | ]. etrans; [ apply disp_mor_transportf_prewhisker | ]. apply maponpaths, disp_runitor_rwhisker. } etrans; [apply maponpaths, disp_vassocl | ]. apply maponpaths, maponpaths. etrans; [ apply maponpaths, disp_mor_transportf_prewhisker | ]. etrans; [ apply disp_mor_transportf_prewhisker | ]. etrans. { apply maponpaths, maponpaths. etrans; [ apply disp_mor_transportf_prewhisker | ]. apply maponpaths, disp_lwhisker_vcomp. } etrans; [ apply maponpaths, disp_mor_transportf_prewhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. apply maponpaths. etrans; [ apply disp_mor_transportf_prewhisker | ]. { apply maponpaths, maponpaths, maponpaths. apply disp_linvunitor_lunitor. } } etrans; [ apply disp_mor_transportf_postwhisker | ]. etrans; [ apply maponpaths, disp_mor_transportf_postwhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans; [ apply maponpaths, disp_mor_transportf_postwhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans; [ apply maponpaths, disp_mor_transportf_postwhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans. { apply maponpaths. etrans; [apply disp_vassocl | ]. apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_transport_right. } cbn. etrans; [ apply disp_mor_transportf_postwhisker | ]. etrans; [ apply maponpaths, maponpaths_2, disp_lwhisker_id2 | ]. etrans; [ apply maponpaths, disp_mor_transportf_postwhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. apply maponpaths. apply disp_id2_left. } etrans; [ apply maponpaths, (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans; [ apply disp_mor_transportf_prewhisker | ]. etrans; [ apply maponpaths, maponpaths, disp_lunitor_runitor_identity | ]. etrans; [ apply maponpaths, disp_mor_transportf_prewhisker | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans. { apply maponpaths. apply disp_rinvunitor_runitor. } apply (transport_f_f (λ x, _ ==>[x] _)). } etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. etrans; [ apply (transport_f_f (λ x, _ ==>[x] _)) | ]. cbn. unfold transportb. apply maponpaths_2. apply cellset_property. Qed. Definition disp_identity_adjoint_equivalence {C : bicat} {D : disp_bicat C} {a : C} (aa : D a) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa aa. Proof. use tpair. - apply disp_internal_adjunction_data_identity. - cbn. use tpair. + apply disp_internal_adjunction_data_identity. + cbn. split. { apply is_disp_internal_adjunction_identity. } { split. - use tpair. + apply disp_lunitor. + split. * cbn. refine (disp_linvunitor_lunitor (id_disp aa) @ _). apply (@transportf_paths _ (λ z, _ ==>[ z ] _)). apply C. * cbn. refine (disp_lunitor_linvunitor (id_disp aa) @ _). apply (@transportf_paths _ (λ z, _ ==>[ z ] _)). apply C. - use tpair. + apply disp_linvunitor. + split. * cbn. refine (disp_lunitor_linvunitor (id_disp aa) @ _). apply (@transportf_paths _ (λ z, _ ==>[ z ] _)). apply C. * cbn. refine (disp_linvunitor_lunitor (id_disp aa) @ _). apply (@transportf_paths _ (λ z, _ ==>[ z ] _)). apply C. } Defined. (** * Classification of internal adjunctions in the total category *) Section Total_Internal_Adjunction. Context {B : bicat} {D : disp_bicat B}. Local Definition E := total_bicat D. (** Equivalences for data *) Local Definition left_adjoint_data_total_to_base {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff) → left_adjoint_data f. Proof. intros f_d. set (g' := pr1 f_d). set (Hdat := pr2 f_d). set (g := pr1 g'). set (η := pr1 (pr1 Hdat)). set (ε := pr1 (pr2 Hdat)). exists g. exact (η,,ε). Defined. Local Definition left_adjoint_data_total_to_fiber {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} : forall (j : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)), disp_left_adjoint_data (left_adjoint_data_total_to_base j) ff. Proof. intros f_d. set (g' := pr1 f_d). set (Hdat := pr2 f_d). set (gg := pr2 g'). set (ηη := pr2 (pr1 Hdat)). set (εε := pr2 (pr2 Hdat)). exists gg. exact (ηη,,εε). Defined. Definition left_adjoint_data_total_to_disp {a b : B} {aa : D a} {bb : D b} {f : a --> b} (ff : aa -->[f] bb) : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff) → ∑ (α : left_adjoint_data f), disp_left_adjoint_data α ff. Proof. intros j. exists (left_adjoint_data_total_to_base j). apply left_adjoint_data_total_to_fiber. Defined. Definition left_adjoint_data_disp_to_total {a b : B} {aa : D a} {bb : D b} {f : a --> b} (ff : aa -->[f] bb) : (∑ (α : left_adjoint_data f), disp_left_adjoint_data α ff) → @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff). Proof. intros j'. pose (j := pr1 j'). pose (jj := pr2 j'). pose (g := left_adjoint_right_adjoint j). pose (gg := (disp_left_adjoint_right_adjoint _ jj : bb -->[g] aa)). use tpair. - exact (g,, gg). - simpl. (* Units/counits *) use tpair. + (* Units *) use tpair; simpl. * apply (left_adjoint_unit j). * apply (disp_left_adjoint_unit _ jj). + (* Counits *) use tpair; simpl. * apply (left_adjoint_counit j). * apply (disp_left_adjoint_counit _ jj). Defined. Definition left_adjoint_data_total_weq {a b : B} {aa : D a} {bb : D b} {f : a --> b} (ff : aa -->[f] bb) : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff) ≃ ∑ (α : left_adjoint_data f), disp_left_adjoint_data α ff. Proof. exists (left_adjoint_data_total_to_disp ff). use isweq_iso. - exact (left_adjoint_data_disp_to_total ff). - intro. reflexivity. - intro. reflexivity. Defined. (** The equivalence for adjunction laws *) Definition left_adjoint_axioms_total_to_base {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} {td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)} : left_adjoint_axioms td → left_adjoint_axioms (left_adjoint_data_total_to_base td). Proof. intros Hlaw. use tpair. + apply (base_paths _ _ (pr1 Hlaw)). + apply (base_paths _ _ (pr2 Hlaw)). Defined. Definition left_adjoint_axioms_total_to_fiber {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) (ta : left_adjoint_axioms td) : disp_left_adjoint_axioms (_,, left_adjoint_axioms_total_to_base ta) (left_adjoint_data_total_to_fiber td). Proof. use tpair. - apply (transportf_transpose_right (P:=λ x, _ ==>[x] _)). etrans; [| apply (fiber_paths (pr1 ta)) ]. apply (transportf_transpose_right (P:=λ x, _ ==>[x] _)). apply (transportfbinv (λ x, _ ==>[x] _)). - apply (transportf_transpose_right (P:=λ x, _ ==>[x] _)). etrans; [| apply (fiber_paths (pr2 ta)) ]. apply (transportf_transpose_right (P:=λ x, _ ==>[x] _)). apply (transportfbinv (λ x, _ ==>[x] _)). Qed. Definition left_adjoint_axioms_total_to_disp {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) (ta : left_adjoint_axioms td) : ∑ (ba : left_adjoint_axioms _), disp_left_adjoint_axioms (_,, ba) (left_adjoint_data_total_to_fiber td). Proof. exists (left_adjoint_axioms_total_to_base ta). apply left_adjoint_axioms_total_to_fiber. Defined. Definition left_adjoint_axioms_disp_to_total {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) : (∑ (ba : left_adjoint_axioms _), disp_left_adjoint_axioms (_,, ba) (left_adjoint_data_total_to_fiber td)) → left_adjoint_axioms td. Proof. intros j'. pose (j := pr1 j'). pose (jj := pr2 j'). simpl; split; use total2_paths_b; (apply j || apply jj). Qed. Definition left_adjoint_axioms_total_weq {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)): left_adjoint_axioms td ≃ ∑ (ba : left_adjoint_axioms _), disp_left_adjoint_axioms (_,, ba) (left_adjoint_data_total_to_fiber td). Proof. apply weqimplimpl. - exact (left_adjoint_axioms_total_to_disp td). - exact (left_adjoint_axioms_disp_to_total td). - apply isofhleveltotal2; try intro; apply cellset_property. - apply isofhleveltotal2. { apply isofhleveltotal2; try intro; apply cellset_property. } intro. apply isofhleveltotal2; try intro; apply disp_cellset_property. Defined. (** The equivalence for equivalence laws *) Definition left_equivalence_axioms_total_to_base {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} {td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)} : left_equivalence_axioms td → left_equivalence_axioms (left_adjoint_data_total_to_base td). Proof. intros Hlaw. pose (Hη := pr1 Hlaw). pose (Hε := pr2 Hlaw). use tpair. + apply (is_invertible_total_to_base _ _ Hη). + apply (is_invertible_total_to_base _ _ Hε). Defined. Definition left_equivalence_axioms_total_to_fiber {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) (ta : left_equivalence_axioms td) : disp_left_equivalence_axioms (left_adjoint_data_total_to_base td,, left_equivalence_axioms_total_to_base ta) (left_adjoint_data_total_to_fiber td). Proof. pose (Hη := pr1 ta). pose (Hε := pr2 ta). cbn in Hη,Hε. use tpair. - apply (is_invertible_total_to_fiber _ _ Hη). - apply (is_invertible_total_to_fiber _ _ Hε). Qed. Definition left_equivalence_axioms_total_to_disp {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) (ta : left_equivalence_axioms td) : ∑ (ba : left_equivalence_axioms _), disp_left_equivalence_axioms (_,, ba) (left_adjoint_data_total_to_fiber td). Proof. exists (left_equivalence_axioms_total_to_base ta). apply left_equivalence_axioms_total_to_fiber. Defined. Definition left_equivalence_axioms_disp_to_total {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)) : (∑ (ba : left_equivalence_axioms _), disp_left_equivalence_axioms (_,, ba) (left_adjoint_data_total_to_fiber td)) → left_equivalence_axioms td. Proof. intros αe. pose (ba := pr1 αe). pose (ta := pr2 αe). cbn in ba, ta. split. - apply is_invertible_disp_to_total. use tpair. + apply ba. + apply ta. - apply is_invertible_disp_to_total. use tpair. + apply ba. + apply ta. Qed. Definition left_equivalence_axioms_total_weq {a b : B} {aa : D a} {bb : D b} {f : a --> b} {ff : aa -->[f] bb} (td : @left_adjoint_data E (a,,aa) (b,,bb) (f,,ff)): left_equivalence_axioms td ≃ ∑ (ba : left_equivalence_axioms _), disp_left_equivalence_axioms (_,, ba) (left_adjoint_data_total_to_fiber td). Proof. apply weqimplimpl. - exact (left_equivalence_axioms_total_to_disp td). - exact (left_equivalence_axioms_disp_to_total td). - apply isapropdirprod; apply isaprop_is_invertible_2cell. - apply isofhleveltotal2. { apply isapropdirprod; apply isaprop_is_invertible_2cell. } intro. apply isapropdirprod; apply isaprop_is_disp_invertible_2cell. Defined. (***************************************************) (***************************************************) (***************************************************) Lemma adjunction_total_disp_weq {a b : B} (aa : D a) (bb : D b) : @adjunction E (a,,aa) (b,,bb) ≃ ∑ (f : adjunction a b), disp_adjunction f aa bb. Proof. unfold adjunction. cbn. (* First we get out the base left adjoint f *) eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } eapply weqcomp. 2: { apply weqtotal2asstol. } eapply weqfibtototal. intros f. (* Getting rid of the displayed arrow ff *) unfold disp_adjunction. cbn. eapply weqcomp. 2: { apply weqtotal2comm. } eapply weqfibtototal. intros ff. unfold left_adjoint. (* Apply the equivalence for data & laws *) eapply weqcomp. { pose (Q:=λ (w : (∑ αd, disp_left_adjoint_data αd ff)), (∑ l, disp_left_adjoint_axioms (pr1 w,,l) (pr2 w))). eapply (weqbandf (left_adjoint_data_total_weq ff) _ Q). intros td. unfold Q; cbn. apply left_adjoint_axioms_total_weq. } cbn. (* Move the quantifiers around *) eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } cbn. eapply weqcomp. 2: { apply weqtotal2asstol. } cbn. eapply weqfibtototal. intros αd. eapply weqcomp. { apply weqtotal2comm. } cbn. apply idweq. Defined. Lemma left_adjoint_equivalence_total_disp_weq {a b : B} {aa : D a} {bb : D b} (f : a --> b) (ff : aa -->[f] bb) : @left_adjoint_equivalence E (a,,aa) (b,,bb) (f,,ff) ≃ ∑ (αe : left_adjoint_equivalence f), disp_left_adjoint_equivalence αe ff. Proof. (* Factor this out *) (* left adjoint equivalences part *) unfold left_adjoint_equivalence. cbn. (* Apply the equivalence for data & laws *) eapply weqcomp. { pose (Q:= λ (w : (∑ αd, disp_left_adjoint_data αd ff)), (∑ l, disp_left_adjoint_axioms (pr1 w,,l) (pr2 w)) × (∑ l, disp_left_equivalence_axioms (pr1 w,,l) (pr2 w))). eapply (weqbandf (left_adjoint_data_total_weq ff) _ Q). intros td. unfold Q; cbn. apply weqdirprodf. - apply left_adjoint_axioms_total_weq. - apply left_equivalence_axioms_total_weq. } cbn. (* TIME TO REARANGE THE QUANTIFIERS OwO *) cbn. (* Getting rid of the left adjoint data for the base *) eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } cbn. eapply weqcomp. 2: { apply weqtotal2asstol. } cbn. eapply weqfibtototal. intros αd. (* Getting rid of the displayed left adjoint data *) unfold disp_left_adjoint_equivalence. cbn. eapply weqcomp. 2: { apply weqtotal2comm. } cbn. eapply weqfibtototal. intros ααd. cbn. (* now to distribute the ∑s *) eapply weqcomp. 2: { apply weqtotal2asstol. } cbn. eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } cbn. eapply weqfibtototal. intros αa. cbn. eapply weqcomp. { apply weqtotal2comm. } apply idweq. Defined. Lemma adjoint_equivalence_total_disp_weq {a b : B} (aa : D a) (bb : D b) : @adjoint_equivalence E (a,,aa) (b,,bb) ≃ ∑ (f : adjoint_equivalence a b), disp_adjoint_equivalence f aa bb. Proof. unfold adjoint_equivalence, disp_adjoint_equivalence. cbn. (* First we get out the base left adjoint f *) eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } eapply weqcomp. 2: { apply weqtotal2asstol. } eapply weqfibtototal. intros f. (* Getting rid of the displayed arrow ff *) cbn. eapply weqcomp. 2: { apply weqtotal2comm. } eapply weqfibtototal. intros ff. apply left_adjoint_equivalence_total_disp_weq. Defined. (* TODO. DF: MOVE TO A SANER PLACE, merge with transportf_subtypePath' *) (* Definition transportf_subtypePath'_QUALITY *) (* {A : UU} *) (* {P : A → UU} *) (* (Pprop : ∏ (a : A), isaprop (P a)) *) (* {C : total2 P → UU} *) (* (x : A) (P₁ P₂ : P x) *) (* (y : C (x,,P₁)) : *) (* transportf (λ (z : total2 P), C z) *) (* (@subtypePath' _ _ (x,,P₁) (x,,P₂) (idpath x) (Pprop x)) *) (* y *) (* = transportf (λ (p : P x), C (x,, p)) (pr1 (Pprop x P₁ P₂)) y. *) (* Proof. *) (* cbn. *) (* induction (Pprop x P₁ P₂) as [p q]. *) (* induction p. *) (* reflexivity. *) (* Defined. *) End Total_Internal_Adjunction. Definition disp_left_equivalence_to_total {B : bicat} {D : disp_bicat B} {x y : B} {f : x --> y} {Hf : left_equivalence f} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : disp_left_equivalence Hf ff) : @left_equivalence (total_bicat D) (x ,, xx) (y ,, yy) (f ,, ff). Proof. simple refine (_ ,, _). - exact (left_adjoint_data_disp_to_total ff (pr1 Hf ,, pr1 Hff)). - use (left_equivalence_axioms_disp_to_total _ (_ ,, _)). + exact (pr2 Hf). + exact (pr2 Hff). Defined. Definition disp_left_equivalence_to_left_adjoint_equivalence {B : bicat} {D : disp_bicat B} {x y : B} {f : x --> y} {Hf : left_equivalence f} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : disp_left_equivalence Hf ff) : ∑ (Hf' : left_adjoint_equivalence f), disp_left_adjoint_equivalence Hf' ff := left_adjoint_equivalence_total_disp_weq f ff (pr2 (equiv_to_adjequiv _ (disp_left_equivalence_to_total Hff))). Definition disp_left_equivalence_to_left_adjoint_equivalence_over_id {B : bicat} {D : disp_bicat B} (HB : is_univalent_2_1 B) {x : B} {xx yy : D x} {ff : xx -->[ id₁ x ] yy} (Hff : disp_left_equivalence (internal_adjoint_equivalence_identity _) ff) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity _) ff. Proof. refine (transportf (λ z, disp_left_adjoint_equivalence z ff) _ (pr2 (disp_left_equivalence_to_left_adjoint_equivalence Hff))). apply (isaprop_left_adjoint_equivalence _ HB). Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispBiadjunction.v000066400000000000000000000161631451125700300257470ustar00rootroot00000000000000(* ------------------------------------------------------------------------- *) (** Displayed biadjunction. Contents: - Definition of displayed biadjunction. - Associated total biadjunction. *) (* ------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Import PseudoFunctor.Notations. Local Open Scope cat. Section DisplayedBiadjunction. Context {B₁ B₂ : bicat} (D₁ : disp_bicat B₁) (D₂ : disp_bicat B₂). Definition disp_left_biadj_unit_counit {L : psfunctor B₁ B₂} (e : left_biadj_unit_counit L) (LL : disp_psfunctor D₁ D₂ L) : UU := ∑ (RR : disp_psfunctor D₂ D₁ e), disp_pstrans (disp_pseudo_id D₁) (disp_pseudo_comp _ _ _ _ _ LL RR) (biadj_unit e) × disp_pstrans (disp_pseudo_comp _ _ _ _ _ RR LL) (disp_pseudo_id D₂) (biadj_counit e). Definition right_adj_of_disp_left_biadj {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) : disp_psfunctor D₂ D₁ e := pr1 ee. Definition unit_of_disp_left_biadj {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) : disp_pstrans (disp_pseudo_id D₁) (disp_pseudo_comp _ _ _ _ _ LL (right_adj_of_disp_left_biadj ee)) (biadj_unit e) := pr12 ee. Definition counit_of_disp_left_biadj {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) : disp_pstrans (disp_pseudo_comp _ _ _ _ _ (right_adj_of_disp_left_biadj ee) LL) (disp_pseudo_id D₂) (biadj_counit e) := pr22 ee. Definition total_left_biadj_unit_counit {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) : left_biadj_unit_counit (total_psfunctor _ _ _ LL). Proof. use make_biadj_unit_counit. - exact (total_psfunctor _ _ _ (right_adj_of_disp_left_biadj ee)). - apply pstrans_on_data_to_pstrans. pose (unit_of_disp_left_biadj ee) as uu. pose (total_pstrans _ _ _ uu) as tuu. apply tuu. - apply pstrans_on_data_to_pstrans. pose (counit_of_disp_left_biadj ee) as uu. pose (total_pstrans _ _ _ uu) as tuu. apply tuu. Defined. (** ** Triangles *) Definition disp_left_biadj_left_triangle {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) (e_lt : biadj_triangle_l_law e) : UU := disp_invmodification _ _ _ _ (disp_comp_pstrans (disp_rinvunitor_pstrans LL) (disp_comp_pstrans (disp_left_whisker LL (unit_of_disp_left_biadj ee)) (disp_comp_pstrans (disp_lassociator_pstrans _ _ _) (disp_comp_pstrans (disp_right_whisker LL (counit_of_disp_left_biadj ee)) (disp_lunitor_pstrans LL)) ) ) ) (disp_id_pstrans LL) e_lt. Definition disp_left_biadj_right_triangle {L : psfunctor B₁ B₂} {e : left_biadj_unit_counit L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_unit_counit e LL) (e_lt : biadj_triangle_r_law e) : UU := let RR := right_adj_of_disp_left_biadj ee in disp_invmodification _ _ _ _ (disp_comp_pstrans (disp_pstrans_linvunitor RR) (disp_comp_pstrans (disp_right_whisker RR (unit_of_disp_left_biadj ee)) (disp_comp_pstrans (disp_pstrans_rassociator _ _ _) (disp_comp_pstrans (disp_left_whisker RR (counit_of_disp_left_biadj ee)) (disp_runitor_pstrans RR)) ) ) ) (disp_id_pstrans RR) e_lt. (** ** Data *) Definition disp_left_biadj_data {L : psfunctor B₁ B₂} (e : left_biadj_data L) (LL : disp_psfunctor D₁ D₂ L) : UU := ∑ (ee : disp_left_biadj_unit_counit e LL), (disp_left_biadj_left_triangle ee (pr12 e)) × disp_left_biadj_right_triangle ee (pr22 e). (** ** Total biadjunction. *) Definition total_left_biadj_data {L : psfunctor B₁ B₂} {e : left_biadj_data L} {LL : disp_psfunctor D₁ D₂ L} (ee : disp_left_biadj_data e LL) : left_biadj_data (total_psfunctor _ _ _ LL). Proof. use make_biadj_data. - exact (total_left_biadj_unit_counit (pr1 ee)). - pose (total_invmodification _ _ _ _ _ _ _ (pr12 ee)) as m. unfold biadj_triangle_l_law. apply make_invertible_modification_on_data. use tpair. + intro X. exact (invertible_modcomponent_of m X). + exact (modnaturality_of (pr1 m)). - pose (total_invmodification _ _ _ _ _ _ _ (pr22 ee)) as m. unfold biadj_triangle_r_law. apply make_invertible_modification_on_data. use tpair. + intro X. exact (invertible_modcomponent_of m X). + exact (modnaturality_of (pr1 m)). Defined. End DisplayedBiadjunction. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispBicat.v000066400000000000000000001772561451125700300243730ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Displayed bicategories Benedikt Ahrens, Marco Maggesi February 2018 This file develops displayed bicategories analogous to displayed (1-)categories as presented in Benedikt Ahrens and Peter LeFanu Lumsdaine, Displayed categories http://dx.doi.org/10.4230/LIPIcs.FSCD.2017.5 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Local Open Scope mor_disp_scope. (* =================================================================================== *) (** ** Displayed bicategories. *) (* =================================================================================== *) (* ----------------------------------------------------------------------------------- *) (** ** Transport of displayed cells. Transport of displayed cells is used pervasively, to make the code more terse and ease certain proofs we define some ad hoc functions and theorems. TODO: These definitions are not used yet. *) (* ----------------------------------------------------------------------------------- *) (* ----------------------------------------------------------------------------------- *) (** ** Definition of displayed bicategories. *) (* ----------------------------------------------------------------------------------- *) Definition disp_2cell_struct {C : prebicat_1_id_comp_cells} (D : disp_cat_ob_mor C) : UU := ∏ (c c' : C) (f g : C⟦c,c'⟧) (x : f ==> g) (d : D c) (d' : D c') (f' : d -->[f] d') (g' : d -->[g] d'), UU. Definition disp_prebicat_1_id_comp_cells (C : prebicat_1_id_comp_cells) : UU := ∑ D : disp_cat_data C, disp_2cell_struct D. Coercion disp_cat_data_from_disp_prebicat_1_id_comp_cells {C : prebicat_1_id_comp_cells} (D : disp_prebicat_1_id_comp_cells C) : disp_cat_data C := pr1 D. Definition disp_2cells {C : prebicat_1_id_comp_cells} {D : disp_prebicat_1_id_comp_cells C} {c c' : C} {f g : C⟦c,c'⟧} (x : f ==> g) {d : D c} {d' : D c'} (f' : d -->[f] d') (g' : d -->[g] d') : UU := pr2 D c c' f g x d d' f' g'. Section Cell_Transport. Context {C : bicat} {D : disp_prebicat_1_id_comp_cells C}. Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60). Definition cell_transportf {a b : C} {f g : C⟦a,b⟧} {α β : f ==> g} (e : α = β) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} (αα : ff ==>[α] gg) : ff ==>[β] gg := transportf (λ x : f ==> g, ff ==>[x] gg) e αα. Definition cell_transportb {a b : C} {f g : C⟦a,b⟧} {α β : f ==> g} (e : α = β) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} (ββ : ff ==>[β] gg) : ff ==>[α] gg := transportb (λ x : f ==> g, ff ==>[x] gg) e ββ. Lemma cell_transportf_pathsinv0 {a b : C} {f g : C⟦a,b⟧} {α β : f ==> g} (e : α = β) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {αα : ff ==>[α] gg} {ββ : ff ==>[β] gg} (ee : cell_transportf (!e) ββ = αα) : cell_transportf e αα = ββ. Proof. unfold cell_transportf. apply (transportf_pathsinv0 (λ x : f ==> g, ff ==>[x] gg)). exact ee. Defined. Lemma cell_transportb_to_f {a b : C} {f g : C⟦a,b⟧} {α β : f ==> g} {e : α = β} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {αα : ff ==>[α] gg} {ββ : ff ==>[β] gg} (ee : αα = cell_transportb e ββ) : cell_transportf e αα = ββ. Proof. apply cell_transportf_pathsinv0. apply pathsinv0. exact ee. Defined. Lemma cell_transportf_to_b {a b : C} {f g : C⟦a,b⟧} {α β : f ==> g} {e : α = β} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {αα : ff ==>[α] gg} {ββ : ff ==>[β] gg} (ee : cell_transportf e αα = ββ) : αα = cell_transportb e ββ. Proof. apply pathsinv0. apply (transportf_pathsinv0 (λ x : f ==> g, ff ==>[ x] gg)). etrans. { apply maponpaths_2. apply pathsinv0inv0. } exact ee. Defined. End Cell_Transport. (* ----------------------------------------------------------------------------------- *) (** ** Operations on bicategories *) (* ----------------------------------------------------------------------------------- *) Section disp_prebicat. Context {C : bicat}. Local Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60). Local Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing). Definition disp_prebicat_ops (D : disp_prebicat_1_id_comp_cells C) : UU := (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y), f' ==>[id2 _] f') × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y), id_disp x ;; f' ==>[lunitor _] f') × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y), f' ;; id_disp y ==>[runitor _] f') × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y), id_disp x ;; f' <==[linvunitor _] f') × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y), f' ;; id_disp y <==[rinvunitor _] f') × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z), (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh)) × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z), ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh) × (∏ (a b : C) (f g h : C⟦a,b⟧) (r : f ==> g) (s : g ==> h) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y), ff ==>[r] gg → gg ==>[s] hh → ff ==>[r • s] hh) × (∏ (a b c : C) (f : C⟦a,b⟧) (g1 g2 : C⟦b,c⟧) (r : g1 ==> g2) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg1 : y -->[g1] z) (gg2 : y -->[g2] z), gg1 ==>[r] gg2 → ff ;; gg1 ==>[f ◃ r] ff ;; gg2) × (∏ (a b c : C) (f1 f2 : C⟦a,b⟧) (g : C⟦b,c⟧) (r : f1 ==> f2) (x : D a) (y : D b) (z : D c) (ff1 : x -->[f1] y) (ff2 : x -->[f2] y) (gg : y -->[g] z), ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg). Definition disp_prebicat_data : UU := ∑ D : disp_prebicat_1_id_comp_cells C, disp_prebicat_ops D. Coercion disp_prebicat_ob_mor_cells_1_id_comp_from_disp_prebicat_data (D : disp_prebicat_data) : disp_prebicat_1_id_comp_cells C := pr1 D. Coercion disp_prebicat_ops_from_disp_prebicat_data (D : disp_prebicat_data) : disp_prebicat_ops D := pr2 D. (* ----------------------------------------------------------------------------------- *) (** ** Data projections *) (* ----------------------------------------------------------------------------------- *) Section disp_prebicat_ops_projections. Context {D : disp_prebicat_data}. Definition disp_id2 {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y) : f' ==>[id2 _] f' := pr1 (pr2 D) a b f x y f'. Definition disp_lunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y) : id_disp x ;; f' ==>[lunitor _] f' := pr1 (pr2 (pr2 D)) a b f x y f'. Definition disp_runitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y) : f' ;; id_disp y ==>[runitor _] f' := pr1 (pr2 (pr2 (pr2 D))) _ _ f _ _ f'. Definition disp_linvunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y) : id_disp x ;; f' <==[linvunitor _] f' := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ f _ _ f'. Definition disp_rinvunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y) : f' ;; id_disp y <==[rinvunitor _] f' := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ f _ _ f'. Definition disp_rassociator {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) : (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh. Definition disp_lassociator {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) : ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh. Definition disp_vcomp2 {a b : C} {f g h : C⟦a,b⟧} {r : f ==> g} {s : g ==> h} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} : ff ==>[r] gg → gg ==>[s] hh → ff ==>[r • s] hh := λ rr ss, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))) _ _ _ _ _ _ _ _ _ _ _ _ rr ss. Definition disp_lwhisker {a b c : C} {f : C⟦a,b⟧} {g1 g2 : C⟦b,c⟧} {r : g1 ==> g2} {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) {gg1 : y -->[g1] z} {gg2 : y -->[g2] z} : gg1 ==>[r] gg2 → ff ;; gg1 ==>[f ◃ r] ff ;; gg2 := λ rr, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ rr. Definition disp_rwhisker {a b c : C} {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧} {r : f1 ==> f2} {x : D a} {y : D b} {z : D c} {ff1 : x -->[f1] y} {ff2 : x -->[f2] y} (gg : y -->[g] z) : ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg := λ rr, pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ rr. End disp_prebicat_ops_projections. Local Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60). Local Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60). Local Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60). Section disp_prebicat_laws. Context (D : disp_prebicat_data). Definition disp_id2_left_law : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (ηη : ff ==>[η] gg), disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη. Definition disp_id2_right_law : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (ηη : ff ==>[η] gg), ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη. Definition disp_vassocr_law : UU := ∏ (a b : C) (f g h k : C⟦a,b⟧) (η : f ==> g) (φ : g ==> h) (ψ : h ==> k) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y) (kk : x -->[k] y) (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk), ηη •• (φφ •• ψψ) = transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ). Definition disp_lwhisker_id2_law : UU := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z), ff ◃◃ disp_id2 gg = transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg)). Definition disp_id2_rwhisker_law : UU := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z), disp_id2 ff ▹▹ gg = transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg)). Definition disp_lwhisker_vcomp_law : UU := ∏ (a b c : C) (f : C⟦a,b⟧) (g h i : C⟦b,c⟧) (η : g ==> h) (φ : h ==> i) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z) (hh : y -->[h] z) (ii : y -->[i] z) (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii), (ff ◃◃ ηη) •• (ff ◃◃ φφ) = transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ)). Definition disp_rwhisker_vcomp_law : UU := ∏ (a b c : C) (f g h : C⟦a,b⟧) (i : C⟦b,c⟧) (η : f ==> g) (φ : g ==> h) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y) (ii : y -->[i] z) (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh), (ηη ▹▹ ii) •• (φφ ▹▹ ii) = transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii). Definition disp_vcomp_lunitor_law : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (ηη : ff ==>[η] gg), (id_disp _ ◃◃ ηη) •• disp_lunitor gg = transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη). Definition disp_vcomp_runitor_law : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g) (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (ηη : ff ==>[η] gg), (ηη ▹▹ id_disp _) •• disp_runitor gg = transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη). Definition disp_lwhisker_lwhisker_law : UU := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h i : c --> d) (η : h ==> i) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z) (ηη : hh ==>[η] ii), ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _) (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη)). Definition disp_rwhisker_lwhisker_law : UU := ∏ (a b c d : C) (f : C⟦a,b⟧) (g h : C⟦b,c⟧) (i : c --> d) (η : g ==> h) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : x -->[h] y) (ii : y -->[i] z) (ηη : gg ==>[η] hh), (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _) (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii)). Definition disp_rwhisker_rwhisker_law : UU := ∏ (a b c d : C) (f g : C⟦a,b⟧) (h : C⟦b,c⟧) (i : c --> d) (η : f ==> g) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z) (ηη : ff ==>[η] gg), disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) = transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _) ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _). Definition disp_vcomp_whisker_law : UU := ∏ (a b c : C) (f g : C⟦a,b⟧) (h i : C⟦b,c⟧) (η : f ==> g) (φ : h ==> i) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z) (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii), (ηη ▹▹ hh) •• (gg ◃◃ φφ) = transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii)). Definition disp_lunitor_linvunitor_law : UU := ∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (ff : x -->[f] y), disp_lunitor ff •• disp_linvunitor _ = transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff)). Definition disp_linvunitor_lunitor_law : UU := ∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (ff : x -->[f] y), disp_linvunitor ff •• disp_lunitor _ = transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _). Definition disp_runitor_rinvunitor_law : UU := ∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (ff : x -->[f] y), disp_runitor ff •• disp_rinvunitor _ = transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _). Definition disp_rinvunitor_runitor_law : UU := ∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (ff : x -->[f] y), disp_rinvunitor ff •• disp_runitor _ = transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _). Definition disp_lassociator_rassociator_law : UU := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z), disp_lassociator ff gg hh •• disp_rassociator _ _ _ = transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2 _). Definition disp_rassociator_lassociator_law : UU := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d) (w : D a) (x : D b) (y : D c) (z : D d) (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z), disp_rassociator ff gg hh •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _). Definition disp_runitor_rwhisker_law : UU := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z), disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) = transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg). Definition disp_lassociator_lassociator_law : UU := ∏ (a b c d e: C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d) (i : C⟦d,e⟧) (v : D a) (w : D b) (x : D c) (y : D d) (z : D e) (ff : v -->[f] w) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z), (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ •• (disp_lassociator _ _ _ ▹▹ ii) = transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _) (disp_lassociator ff gg _ •• disp_lassociator _ _ _). (* ----------------------------------------------------------------------------------- *) (** ** Laws *) (* ----------------------------------------------------------------------------------- *) Definition disp_prebicat_laws : UU := disp_id2_left_law × disp_id2_right_law × disp_vassocr_law × disp_lwhisker_id2_law × disp_id2_rwhisker_law × disp_lwhisker_vcomp_law × disp_rwhisker_vcomp_law × disp_vcomp_lunitor_law × disp_vcomp_runitor_law × disp_lwhisker_lwhisker_law × disp_rwhisker_lwhisker_law × disp_rwhisker_rwhisker_law × disp_vcomp_whisker_law × disp_lunitor_linvunitor_law × disp_linvunitor_lunitor_law × disp_runitor_rinvunitor_law × disp_rinvunitor_runitor_law × disp_lassociator_rassociator_law × disp_rassociator_lassociator_law × disp_runitor_rwhisker_law × disp_lassociator_lassociator_law. End disp_prebicat_laws. (* ----------------------------------------------------------------------------------- *) (** Laws projections *) (* ----------------------------------------------------------------------------------- *) Definition disp_prebicat : UU := ∑ D : disp_prebicat_data, disp_prebicat_laws D. Coercion disp_prebicat_data_from_disp_prebicat (D : disp_prebicat) : disp_prebicat_data := pr1 D. Section disp_prebicat_law_projections. Context {D : disp_prebicat}. Definition disp_id2_left {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} (ηη : ff ==>[η] gg) : disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη := pr1 (pr2 D) _ _ _ _ _ x y ff gg ηη. Definition disp_id2_right {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} (ηη : ff ==>[η] gg) : ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη := pr1 (pr2 (pr2 D)) _ _ _ _ _ _ _ _ _ ηη. Definition disp_vassocr {a b : C} {f g h k : C⟦a,b⟧} {η : f ==> g} {φ : g ==> h} {ψ : h ==> k} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y} (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk) : ηη •• (φφ •• ψψ) = transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ) := pr1 (pr2 (pr2 (pr2 D))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ ψψ . Definition disp_vassocr' {a b : C} {f g h k : C⟦a,b⟧} {η : f ==> g} {φ : g ==> h} {ψ : h ==> k} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y} (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk) : transportf (λ α, _ ==>[α] _) (vassocr _ _ _) (ηη •• (φφ •• ψψ)) = ((ηη •• φφ) •• ψψ). Proof. use (transportf_transpose_left (P := λ x' : f ==> k, ff ==>[x'] kk)). apply disp_vassocr. Defined. Definition disp_lwhisker_id2 {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z) : ff ◃◃ disp_id2 gg = transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg)) := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ _ _ _ _ _ _ ff gg. Definition disp_id2_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z) : disp_id2 ff ▹▹ gg = transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ _ _ _ _ _ _ ff gg. Definition disp_lwhisker_vcomp {a b c : C} {f : C⟦a,b⟧} {g h i : C⟦b,c⟧} {η : g ==> h} {φ : h ==> i} {x : D a} {y : D b} {z : D c} {ff : x -->[f] y} {gg : y -->[g] z} {hh : y -->[h] z} {ii : y -->[i] z} (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii) : (ff ◃◃ ηη) •• (ff ◃◃ φφ) = transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ. Definition disp_rwhisker_vcomp {a b c : C} {f g h : C⟦a,b⟧} {i : C⟦b,c⟧} {η : f ==> g} {φ : g ==> h} {x : D a} {y : D b} {z : D c} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {ii : y -->[i] z} (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) : (ηη ▹▹ ii) •• (φφ ▹▹ ii) = transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ. Definition disp_vcomp_lunitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} (ηη : ff ==>[η] gg) : (id_disp _ ◃◃ ηη) •• disp_lunitor gg = transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))) _ _ _ _ _ _ _ _ _ ηη. Definition disp_vcomp_runitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} (ηη : ff ==>[η] gg) : (ηη ▹▹ id_disp _) •• disp_runitor gg = transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))) _ _ _ _ _ _ _ _ _ ηη. Definition disp_lwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h i : c --> d} {η : h ==> i} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) (gg : x -->[g] y) {hh : y -->[h] z} {ii : y -->[i] z} (ηη : hh ==>[η] ii) : ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _) (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη. Definition disp_rwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g h : C⟦b,c⟧} {i : c --> d} {η : g ==> h} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) {gg : x -->[g] y} {hh : x -->[h] y} (ii : y -->[i] z) (ηη : gg ==>[η] hh) : (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _) (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη. Definition disp_rwhisker_rwhisker {a b c d : C} {f g : C⟦a,b⟧} {h : C⟦b,c⟧} (i : c --> d) (η : f ==> g) {w : D a} {x : D b} {y : D c} {z : D d} {ff : w -->[f] x} {gg : w -->[g] x} (hh : x -->[h] y) (ii : y -->[i] z) (ηη : ff ==>[η] gg) : disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) = transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _) ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη. Definition disp_vcomp_whisker {a b c : C} {f g : C⟦a,b⟧} {h i : C⟦b,c⟧} (η : f ==> g) (φ : h ==> i) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z) (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii) : (ηη ▹▹ hh) •• (gg ◃◃ φφ) = transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ. Definition disp_lunitor_linvunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (ff : x -->[f] y) : disp_lunitor ff •• disp_linvunitor _ = transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))) _ _ _ _ _ ff. Definition disp_linvunitor_lunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (ff : x -->[f] y) : disp_linvunitor ff •• disp_lunitor _ = transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))) _ _ _ _ _ ff. Definition disp_runitor_rinvunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (ff : x -->[f] y) : disp_runitor ff •• disp_rinvunitor _ = transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))) _ _ _ _ _ ff. Definition disp_rinvunitor_runitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (ff : x -->[f] y) : disp_rinvunitor ff •• disp_runitor _ = transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))) _ _ _ _ _ ff. Definition disp_lassociator_rassociator {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : c --> d} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) : disp_lassociator ff gg hh •• disp_rassociator _ _ _ = transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2 _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))))) _ _ _ _ _ _ _ _ _ _ _ ff gg hh. Definition disp_rassociator_lassociator {a b c d : C} (f : C⟦a,b⟧) {g : C⟦b,c⟧} {h : c --> d} {w : D a} {x : D b} {y : D c} {z : D d} (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) : disp_rassociator ff gg hh •• disp_lassociator _ _ _ = transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))) _ _ _ _ _ _ _ _ _ _ _ ff gg hh. Definition disp_runitor_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z) : disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) = transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))))))) _ _ _ _ _ _ _ _ ff gg. Definition disp_lassociator_lassociator {a b c d e: C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : c --> d} {i : C⟦d,e⟧} {v : D a} {w : D b} {x : D c} {y : D d} {z : D e} (ff : v -->[f] w) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z) : (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ •• (disp_lassociator _ _ _ ▹▹ ii) = transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _) (disp_lassociator ff gg _ •• disp_lassociator _ _ _) := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ ff gg hh ii. End disp_prebicat_law_projections. Definition disp_hcomp {D : disp_prebicat} {b₁ b₂ b₃ : C} {f₁ f₂ : b₁ --> b₂} {g₁ g₂ : b₂ --> b₃} {α : f₁ ==> f₂} {β : g₁ ==> g₂} {bb₁ : D b₁} {bb₂ : D b₂} {bb₃ : D b₃} {ff₁ : bb₁ -->[ f₁ ] bb₂} {ff₂ : bb₁ -->[ f₂ ] bb₂} {gg₁ : bb₂ -->[ g₁ ] bb₃} {gg₂ : bb₂ -->[ g₂ ] bb₃} (αα : ff₁ ==>[ α ] ff₂) (ββ : gg₁ ==>[ β ] gg₂) : ff₁ ;; gg₁ ==>[ β ⋆⋆ α ] ff₂ ;; gg₂ := (αα ▹▹ gg₁) •• (ff₂ ◃◃ ββ). (* ----------------------------------------------------------------------------------- *) (** ** Invertible displayed 2-cells. *) (* ----------------------------------------------------------------------------------- *) Lemma disp_vassocl {D : disp_prebicat} {a b : C} {f g h k : C⟦a,b⟧} {η : f ==> g} {φ : g ==> h} {ψ : h ==> k} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y} (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk) : (ηη •• φφ) •• ψψ = transportb (λ α, _ ==>[α] _) (vassocl _ _ _) (ηη •• (φφ •• ψψ)). Proof. apply (transportf_transpose_right (P := λ x', _ ==>[x'] _)). apply pathsinv0. etrans. { apply disp_vassocr. } apply maponpaths_2. unfold vassocl. apply pathsinv0, pathsinv0inv0. Qed. Section Display_Invertible_2cell. Context {D : disp_prebicat}. Section Def_inv_2cell. Context {c c' : C} {f f' : C⟦c,c'⟧} {d : D c} {d' : D c'}. Definition is_disp_invertible_2cell' {α : invertible_2cell f f'} {ff : d -->[f] d'} {ff' : d -->[f'] d'} (x : ff ==>[α] ff') : UU := ∑ (y : ff' ==>[α^-1] ff), (x •• y = transportb (λ α, _ ==>[α] _) (vcomp_rinv α) (disp_id2 ff)) × (y •• x = transportb (λ α, _ ==>[α] _) (vcomp_linv α) (disp_id2 ff')). Definition is_disp_invertible_2cell {α : f ==> f'} (inv_α : is_invertible_2cell α) {ff : d -->[f] d'} {ff' : d -->[f'] d'} (x : ff ==>[α] ff') : UU := ∑ (y : ff' ==>[inv_α^-1] ff), (x •• y = transportb (λ α, _ ==>[α] _) (vcomp_rinv inv_α) (disp_id2 ff)) × (y •• x = transportb (λ α, _ ==>[α] _) (vcomp_linv inv_α) (disp_id2 ff')). Definition disp_invertible_2cell (α : invertible_2cell f f') (ff : d -->[f] d') (ff' : d -->[f'] d') : UU := ∑ (x : ff ==>[α] ff'), is_disp_invertible_2cell α x. Coercion disp_cell_from_invertible_2cell {α : invertible_2cell f f'} {ff : d -->[f] d'} {ff' : d -->[f'] d'} (e : disp_invertible_2cell α ff ff') : ff ==>[α] ff' := pr1 e. Definition disp_inv_cell {α : invertible_2cell f f'} {ff : d -->[f] d'} {ff' : d -->[f'] d'} (e : disp_invertible_2cell α ff ff') : ff' ==>[α^-1] ff := pr1 (pr2 e). Definition disp_vcomp_rinv {α : invertible_2cell f f'} {ff : d -->[f] d'} {ff' : d -->[f'] d'} (e : disp_invertible_2cell α ff ff') : e •• disp_inv_cell e = transportb (λ α, _ ==>[α] _) (vcomp_rinv α) (disp_id2 ff) := pr1 (pr2 (pr2 e)). Definition disp_vcomp_linv {α : invertible_2cell f f'} {ff : d -->[f] d'} {ff' : d -->[f'] d'} (e : disp_invertible_2cell α ff ff') : disp_inv_cell e •• e = transportb (λ α, _ ==>[α] _) (vcomp_linv α) (disp_id2 ff') := pr2 (pr2 (pr2 e)). End Def_inv_2cell. Lemma disp_mor_transportf_postwhisker (a b : C) {x y z : C⟦a,b⟧} {f f' : x ==> y} (ef : f = f') {g : y ==> z} {aa : D a} {bb : D b} {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[g] zz) : (transportf (λ x, _ ==>[x] _) ef ff) •• gg = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, h • g) ef) (ff •• gg). Proof. induction ef; apply idpath. Qed. Lemma disp_mor_transportf_prewhisker (a b : C) {x y z : C⟦a,b⟧} {f : x ==> y} {g g' : y ==> z} (ef : g = g') {aa : D a} {bb : D b} {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[g] zz) : ff •• (transportf (λ x, _ ==>[x] _) ef gg) = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, f • h) ef) (ff •• gg). Proof. induction ef; apply idpath. Qed. Lemma disp_mor_transportf_prewhisker_gen (a b : C) {x y z : C⟦a,b⟧} {f : x ==> y} {A : UU} {t : A → y ==> z} {g g' : A} (ef : g = g') {aa : D a} {bb : D b} {xx : aa -->[x] bb} {yy} {zz} (ff : xx ==>[f] yy) (gg : yy ==>[t g] zz) : ff •• (transportf (λ x, _ ==>[t x] _) ef gg) = transportf (λ x, _ ==>[x] _) (maponpaths (λ h, f • t h) ef) (ff •• gg). Proof. induction ef; apply idpath. Qed. Lemma disp_lhs_right_invert_cell' {a b : C} {f g h : a --> b} {x : f ==> g} {y : invertible_2cell g h} {z : f ==> h} {p : x = z • y^-1} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {hh : aa -->[h] bb} (xx : ff ==>[x] gg) (yy : gg ==>[y] hh) (zz : ff ==>[z] hh) (H : is_disp_invertible_2cell y yy) (q := lhs_right_invert_cell _ _ _ _ p) (pp : xx = transportb (λ x, _ ==>[x] _) p (zz •• disp_inv_cell (yy,,H))) : xx •• yy = transportb (λ x, _ ==>[x] _) q zz. Proof. set (yy' := (yy,,H) : disp_invertible_2cell _ _ _). etrans. { apply maponpaths_2. apply pp. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_vassocl. } etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). } etrans. { apply maponpaths. apply maponpaths. apply disp_vcomp_linv. } etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). } etrans. { apply maponpaths. apply disp_id2_right. } etrans. { unfold transportb. apply (transport_f_f (λ x' : f ==> h, ff ==>[x'] hh)). } unfold transportb. apply maponpaths_2. apply cellset_property. Qed. Lemma disp_lhs_right_invert_cell {a b : C} {f g h : a --> b} {x : f ==> g} {y : g ==> h} {z : f ==> h} (inv_y : is_invertible_2cell y) {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {hh : aa -->[h] bb} (xx : ff ==>[x] gg) (yy : gg ==>[y] hh) (zz : ff ==>[z] hh) (H : is_disp_invertible_2cell inv_y yy) (q : x • y = z) (p := rhs_right_inv_cell _ _ _ inv_y q : x = z • inv_y^-1) (pp : xx = transportb (λ x, _ ==>[x] _) p (zz •• disp_inv_cell ((yy,,H):disp_invertible_2cell (y,,inv_y) gg hh))) : xx •• yy = transportb (λ x, _ ==>[x] _) q zz. Proof. etrans. { use (disp_lhs_right_invert_cell' _ _ _ _ pp). } apply maponpaths_2. apply cellset_property. Qed. Lemma disp_lhs_left_invert_cell {a b : C} {f g h : a --> b} {x : f ==> g} {y : g ==> h} {z : f ==> h} {inv_x : is_invertible_2cell x} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} {hh : aa -->[h] bb} (xx : ff ==>[x] gg) (yy : gg ==>[y] hh) (zz : ff ==>[z] hh) (inv_xx : is_disp_invertible_2cell inv_x xx) (q : x • y = z) (p := rhs_left_inv_cell _ _ _ inv_x q : y = inv_x^-1 • z) (pp : yy = transportb (λ x, _ ==>[x] _) p (disp_inv_cell ((xx,,inv_xx):disp_invertible_2cell (x,,inv_x) ff gg) •• zz)) : xx •• yy = transportb (λ x, _ ==>[x] _) q zz. Proof. etrans. { apply maponpaths. apply pp. } etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_vassocr. } etrans. { apply (transport_f_f (λ x, _ ==>[x] _)). } etrans. { apply maponpaths. apply maponpaths_2. apply (disp_vcomp_rinv ((xx,,inv_xx):disp_invertible_2cell (x,,inv_x) _ _)). } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } etrans. { unfold transportb. apply (transport_f_f (λ x, _ ==>[x] _)). } etrans. { apply maponpaths. apply disp_id2_left. } etrans. { unfold transportb. apply (transport_f_f (λ x, _ ==>[x] _)). } unfold transportb. apply maponpaths_2. apply cellset_property. Qed. End Display_Invertible_2cell. (* ----------------------------------------------------------------------------------- *) (** ** Derived laws *) (* ----------------------------------------------------------------------------------- *) Section Derived_Laws. Context {D : disp_prebicat}. Definition is_disp_invertible_2cell_lassociator {a b c d : C} {f1 : C⟦a,b⟧} {f2 : C⟦b,c⟧} {f3 : C⟦c,d⟧} {aa : D a} {bb : D b} {cc : D c} {dd : D d} (ff1 : aa -->[f1] bb) (ff2 : bb -->[f2] cc) (ff3 : cc -->[f3] dd) : is_disp_invertible_2cell (is_invertible_2cell_lassociator _ _ _) (disp_lassociator ff1 ff2 ff3). Proof. exists (disp_rassociator ff1 ff2 ff3). split. - apply disp_lassociator_rassociator. - apply disp_rassociator_lassociator. Defined. Definition is_disp_invertible_2cell_rassociator {a b c d : C} {f1 : C⟦a,b⟧} {f2 : C⟦b,c⟧} {f3 : C⟦c,d⟧} {aa : D a} {bb : D b} {cc : D c} {dd : D d} (ff1 : aa -->[f1] bb) (ff2 : bb -->[f2] cc) (ff3 : cc -->[f3] dd) : is_disp_invertible_2cell (is_invertible_2cell_rassociator _ _ _) (disp_rassociator ff1 ff2 ff3). Proof. exists (disp_lassociator ff1 ff2 ff3). split. - apply disp_rassociator_lassociator. - apply disp_lassociator_rassociator. Defined. Lemma disp_lassociator_to_rassociator_post' {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {k : C⟦a,d⟧} {x : k ==> (f · g) · h} {y : k ==> f · (g · h)} (p : x = y • lassociator f g h) {aa : D a} {bb : D b} {cc : D c} {dd : D d} {ff : aa -->[f] bb} {gg : bb -->[g] cc} {hh : cc -->[h] dd} {kk : aa -->[k] dd} (xx : kk ==>[x] (ff ;; gg) ;; hh) (yy : kk ==>[y] ff ;; (gg ;; hh)) (q := lassociator_to_rassociator_post x y p) (pp : xx = transportb (λ x, _ ==>[x] _) p (yy •• disp_lassociator ff gg hh)) : xx •• disp_rassociator ff gg hh = transportb (λ x, _ ==>[x] _) q (yy). Proof. etrans. { use disp_lhs_right_invert_cell. - exact y. - apply is_invertible_2cell_rassociator. - exact yy. - apply is_disp_invertible_2cell_rassociator. - apply lassociator_to_rassociator_post. exact p. - cbn. etrans. { apply pp. } apply maponpaths_2. apply cellset_property. } apply maponpaths_2. apply cellset_property. Qed. Lemma disp_lassociator_to_rassociator_post {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧} {k : C⟦a,d⟧} {x : k ==> (f · g) · h} {y : k ==> f · (g · h)} {aa : D a} {bb : D b} {cc : D c} {dd : D d} {ff : aa -->[f] bb} {gg : bb -->[g] cc} {hh : cc -->[h] dd} {kk : aa -->[k] dd} (xx : kk ==>[x] (ff ;; gg) ;; hh) (yy : kk ==>[y] ff ;; (gg ;; hh)) (q : x • rassociator f g h = y) (p := rassociator_to_lassociator_post _ _ q : x = y • lassociator f g h) (pp : xx = transportb (λ x, _ ==>[x] _) p (yy •• disp_lassociator ff gg hh)) : xx •• disp_rassociator ff gg hh = transportb (λ x, _ ==>[x] _) q (yy). Proof. etrans. { use disp_lassociator_to_rassociator_post'. - exact y. - exact p. - exact yy. - exact pp. } apply maponpaths_2. apply cellset_property. Qed. Lemma disp_lassociator_to_rassociator_pre {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c, d⟧} {k : C⟦a,d⟧} {x : f · (g · h) ==> k} {y : (f · g) · h ==> k} {aa : D a} {bb : D b} {cc : D c} {dd : D d} {ff : aa -->[f] bb} {gg : bb -->[g] cc} {hh : cc -->[h] dd} {kk : aa -->[k] dd} (xx : ff ;; (gg ;; hh) ==>[x] kk) (yy : (ff ;; gg) ;; hh ==>[y] kk) (q : rassociator f g h • x = y) (p := rassociator_to_lassociator_pre _ _ q : x = lassociator f g h • y) (pp : xx = transportb (λ x, _ ==>[x] _) p (disp_lassociator ff gg hh •• yy)) : disp_rassociator ff gg hh •• xx = transportb (λ x, _ ==>[x] _) q (yy). Proof. etrans. { use disp_lhs_left_invert_cell. - exact y. - apply is_invertible_2cell_rassociator. - exact yy. - apply is_disp_invertible_2cell_rassociator. - apply lassociator_to_rassociator_pre. exact p. - cbn. etrans. { apply pp. } apply maponpaths_2. apply cellset_property. } apply maponpaths_2. apply cellset_property. Qed. Lemma disp_lunitor_lwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {aa : D a} {bb : D b} {cc : D c} (ff : aa -->[f] bb) (gg : bb -->[g] cc) : (disp_rassociator _ _ _ •• (ff ◃◃ disp_lunitor gg)) = transportb (λ α, _ ==>[α] _) (lunitor_lwhisker _ _) (disp_runitor ff ▹▹ gg). Proof. etrans. { use disp_lassociator_to_rassociator_pre. - exact (runitor f ▹ g). - exact (disp_runitor ff ▹▹ gg). - apply lunitor_lwhisker. - apply pathsinv0. etrans. { apply maponpaths. apply disp_runitor_rwhisker. } etrans. { apply (transport_f_f (λ α, _ ==>[α] _)). } apply (transportf_set (λ α, _ ==>[α] _)). apply cellset_property. } apply maponpaths_2, cellset_property. Qed. Lemma disp_rwhisker_transport_left {a b c : C} {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧} {x x' : f1 ==> f2} (p : x = x') {aa : D a} {bb : D b} {cc : D c} {ff1 : aa -->[f1] bb} {ff2 : aa -->[f2] bb} (xx : ff1 ==>[x] ff2) (gg : bb -->[g] cc) : (transportf (λ x, _ ==>[x] _) p xx) ▹▹ gg = transportf (λ x, _ ==>[x ▹ g] _) p (xx ▹▹ gg). Proof. induction p. apply idpath. Defined. Lemma disp_rwhisker_transport_left_new {a b c : C} {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧} {x x' : f1 ==> f2} (p : x = x') {aa : D a} {bb : D b} {cc : D c} {ff1 : aa -->[f1] bb} {ff2 : aa -->[f2] bb} (xx : ff1 ==>[x] ff2) (gg : bb -->[g] cc) : (transportf (λ x, _ ==>[x] _) p xx) ▹▹ gg = transportf (λ x, _ ==>[x] _) (maponpaths (λ x, x ▹ g) p) (xx ▹▹ gg). Proof. induction p. apply idpath. Defined. Lemma disp_rwhisker_transport_right {a b c : C} {f : C⟦a,b⟧} {g1 g2 : C⟦b,c⟧} {x x' : g1 ==> g2} (p : x = x') {aa : D a} {bb : D b} {cc : D c} {ff : aa -->[f] bb} (gg1 : bb -->[g1] cc) (gg2 : bb -->[g2] cc) (xx : gg1 ==>[x] gg2) : ff ◃◃ (transportf (λ x, _ ==>[x] _) p xx) = transportf (λ x, _ ==>[x] _) (maponpaths (λ x, f ◃ x) p) (ff ◃◃ xx). Proof. induction p. apply idpath. Defined. Definition disp_lwhisker_vcomp_alt {a b c : C} {f : C⟦a,b⟧} {g h i : C⟦b,c⟧} {η : g ==> h} {φ : h ==> i} {x : D a} {y : D b} {z : D c} {ff : x -->[f] y} {gg : y -->[g] z} {hh : y -->[h] z} {ii : y -->[i] z} (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii) : ff ◃◃ (ηη •• φφ) = transportf (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) ((ff ◃◃ ηη) •• (ff ◃◃ φφ)). Proof. refine (!_). apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)). apply disp_lwhisker_vcomp. Qed. Definition disp_rwhisker_vcomp_alt {a b c : C} {f g h : C⟦a,b⟧} {i : C⟦b,c⟧} {η : f ==> g} {φ : g ==> h} {x : D a} {y : D b} {z : D c} {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {ii : y -->[i] z} (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) : (ηη •• φφ) ▹▹ ii = transportf (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη ▹▹ ii) •• (φφ ▹▹ ii)). Proof. refine (!_). apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)). apply disp_rwhisker_vcomp. Qed. Definition disp_vcomp_whisker_alt {a b c : C} {f g : C⟦a,b⟧} {h i : C⟦b,c⟧} (η : f ==> g) (φ : h ==> i) (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z) (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii) : (ff ◃◃ φφ) •• (ηη ▹▹ ii) = transportf (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ηη ▹▹ hh) •• (gg ◃◃ φφ)). Proof. refine (!_). apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)). apply disp_vcomp_whisker. Qed. Definition disp_id2_rwhisker_alt {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z) : transportf (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 ff ▹▹ gg) = disp_id2 (ff ;; gg). Proof. apply (@transportf_transpose_left _ (λ α, _ ==>[α] _)). apply disp_id2_rwhisker. Qed. Definition disp_vcomp_runitor_alt {a b : C} {f g : C⟦a,b⟧} {η : f ==> g} {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y} (ηη : ff ==>[η] gg) : disp_runitor ff •• ηη = transportf (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) ((ηη ▹▹ id_disp _) •• disp_runitor gg). Proof. refine (!_). etrans. { apply maponpaths. apply disp_vcomp_runitor. } apply (transportfbinv (λ z, _ ==>[ z ] _) _ _). Qed. Definition disp_vcomp_lcancel {b₁ b₂ : C} {f g h : b₁ --> b₂} {α : f ==> g} {β : g ==> h} (Hα : is_invertible_2cell α) {bb₁ : D b₁} {bb₂ : D b₂} {ff : bb₁ -->[ f ] bb₂} {gg : bb₁ -->[ g ] bb₂} {hh : bb₁ -->[ h ] bb₂} {αα : ff ==>[ α ] gg} {ββ₁ ββ₂ : gg ==>[ β ] hh} (Hαα : is_disp_invertible_2cell Hα αα) (p : αα •• ββ₁ = αα •• ββ₂) : ββ₁ = ββ₂. Proof. pose (αα_cell := (αα ,, Hαα) : disp_invertible_2cell (make_invertible_2cell Hα) ff gg). assert (q := maponpaths (λ z, disp_inv_cell αα_cell •• z) p). cbn in q. rewrite !disp_vassocr in q. pose (disp_vcomp_linv αα_cell) as z. cbn in z. rewrite !z in q. unfold transportb in q. rewrite !disp_mor_transportf_postwhisker in q. rewrite !transport_f_f in q. rewrite !disp_id2_left in q. unfold transportb in q. rewrite !transport_f_f in q. pose (q' := @transportb_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ q). rewrite transportbfinv in q'. exact q'. Qed. Definition disp_vcomp_rcancel {b₁ b₂ : C} {f g h : b₁ --> b₂} {α : f ==> g} {β : g ==> h} (Hβ : is_invertible_2cell β) {bb₁ : D b₁} {bb₂ : D b₂} {ff : bb₁ -->[ f ] bb₂} {gg : bb₁ -->[ g ] bb₂} {hh : bb₁ -->[ h ] bb₂} {αα₁ : ff ==>[ α ] gg} {αα₂ : ff ==>[ α ] gg} {ββ : gg ==>[ β ] hh} (Hββ : is_disp_invertible_2cell Hβ ββ) (p : αα₁ •• ββ = αα₂ •• ββ) : αα₁ = αα₂. Proof. assert (q := maponpaths (λ z, z •• pr1 Hββ) p). cbn in q. rewrite !disp_vassocl in q. rewrite !(pr12 Hββ) in q. unfold transportb in q. rewrite !disp_mor_transportf_prewhisker in q. rewrite !transport_f_f in q. rewrite !disp_id2_right in q. unfold transportb in q. rewrite !transport_f_f in q. pose (q' := @transportb_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ q). rewrite transportbfinv in q'. exact q'. Qed. Definition disp_id2_left_alt {x y : C} {f g : x --> y} {η : f ==> g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (ηη : ff ==>[ η ] gg) : ηη = transportf (λ z, ff ==>[ z ] gg) (id2_left η) (disp_id2 ff •• ηη). Proof. exact (!(@transportf_transpose_left _ (λ z, _ ==>[ z ] _) _ _ _ _ _ (disp_id2_left ηη))). Qed. Definition disp_rwhisker_rwhisker_rassociator {w x y z : C} {f₁ f₂ : w --> x} {α : f₁ ==> f₂} {g : x --> y} {h : y --> z} {ww : D w} {xx : D x} {yy : D y} {zz : D z} {ff₁ : ww -->[ f₁ ] xx} {ff₂ : ww -->[ f₂ ] xx} (αα : ff₁ ==>[ α ] ff₂) (gg : xx -->[ g ] yy) (hh : yy -->[ h ] zz) : transportb (λ z, _ ==>[ z ] _) (rwhisker_rwhisker_alt h g α) (disp_rassociator ff₁ gg hh •• (αα ▹▹ (gg ;; hh))) = (αα ▹▹ gg ▹▹ hh) •• disp_rassociator ff₂ gg hh. Proof. refine (!_). refine (disp_id2_left_alt _ @ _). etrans. { apply maponpaths. apply maponpaths_2. exact (!(@transportf_transpose_left _ (λ z, _ ==>[ z ] _) _ _ _ _ _ (disp_rassociator_lassociator _ ff₁ gg hh))). } rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite !disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. rewrite disp_vassocr. rewrite disp_rwhisker_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite !disp_vassocl. rewrite disp_lassociator_rassociator. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_id2_right. unfold transportb. rewrite !transport_f_f. apply idpath. } rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. Qed. End Derived_Laws. (* ----------------------------------------------------------------------------------- *) (** ** Total bicategory of a displayed bicategory *) (* ----------------------------------------------------------------------------------- *) Section total_prebicat. Variable D : disp_prebicat. Definition total_prebicat_1_data : precategory_data := total_category_ob_mor D ,, total_category_id_comp D. Definition total_prebicat_cell_struct : prebicat_2cell_struct (total_category_ob_mor D) := λ a b f g, ∑ η : pr1 f ==> pr1 g, pr2 f ==>[η] pr2 g. Definition total_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells := (total_prebicat_1_data,, total_prebicat_cell_struct). Definition total_prebicat_2_id_comp_struct : prebicat_2_id_comp_struct total_prebicat_1_id_comp_cells. Proof. repeat split; cbn; unfold total_prebicat_cell_struct. - intros. exists (id2 _). exact (disp_id2 _). - intros. exists (lunitor _). exact (disp_lunitor _). - intros. exists (runitor _). exact (disp_runitor _). - intros. exists (linvunitor _). exact (disp_linvunitor _). - intros. exists (rinvunitor _). exact (disp_rinvunitor _). - intros. exists (rassociator _ _ _). exact (disp_rassociator _ _ _). - intros. exists (lassociator _ _ _). exact (disp_lassociator _ _ _). - intros a b f g h r s. exists (pr1 r • pr1 s). exact (pr2 r •• pr2 s). - intros a b d f g1 g2 r. exists (pr1 f ◃ pr1 r). exact (pr2 f ◃◃ pr2 r). - intros a b c f1 f2 g r. exists (pr1 r ▹ pr1 g). exact (pr2 r ▹▹ pr2 g). Defined. Definition total_prebicat_data : prebicat_data := _ ,, total_prebicat_2_id_comp_struct. Lemma total_prebicat_laws : prebicat_laws total_prebicat_data. Proof. repeat split; intros. - use total2_paths_b. + apply id2_left. + apply disp_id2_left. - use total2_paths_b. + apply id2_right. + apply disp_id2_right. - use total2_paths_b. + apply vassocr. + apply disp_vassocr. - use total2_paths_b. + apply lwhisker_id2. + apply disp_lwhisker_id2. - use total2_paths_b. + apply id2_rwhisker. + apply disp_id2_rwhisker. - use total2_paths_b. + apply lwhisker_vcomp. + apply disp_lwhisker_vcomp. - use total2_paths_b. + apply rwhisker_vcomp. + apply disp_rwhisker_vcomp. - use total2_paths_b. + apply vcomp_lunitor. + apply disp_vcomp_lunitor. - use total2_paths_b. + apply vcomp_runitor. + apply disp_vcomp_runitor. - use total2_paths_b. + apply lwhisker_lwhisker. + apply disp_lwhisker_lwhisker. - use total2_paths_b. + apply rwhisker_lwhisker. + apply disp_rwhisker_lwhisker. - use total2_paths_b. + apply rwhisker_rwhisker. + apply disp_rwhisker_rwhisker. - use total2_paths_b. + apply vcomp_whisker. + apply disp_vcomp_whisker. - use total2_paths_b. + apply lunitor_linvunitor. + apply disp_lunitor_linvunitor. - use total2_paths_b. + apply linvunitor_lunitor. + apply disp_linvunitor_lunitor. - use total2_paths_b. + apply runitor_rinvunitor. + apply disp_runitor_rinvunitor. - use total2_paths_b. + apply rinvunitor_runitor. + apply disp_rinvunitor_runitor. - use total2_paths_b. + apply lassociator_rassociator. + apply disp_lassociator_rassociator. - use total2_paths_b. + apply rassociator_lassociator. + apply disp_rassociator_lassociator. - use total2_paths_b. + apply runitor_rwhisker. + apply disp_runitor_rwhisker. - use total2_paths_b. + apply lassociator_lassociator. + apply disp_lassociator_lassociator. Defined. Definition total_prebicat : prebicat := _ ,, total_prebicat_laws. End total_prebicat. Definition has_disp_cellset (D : disp_prebicat) : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (x : f ==> g) (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb), isaset (ff ==>[x] gg). Definition disp_bicat : UU := ∑ D : disp_prebicat, has_disp_cellset D. Coercion disp_prebicat_of_disp_bicat (D : disp_bicat) : disp_prebicat := pr1 D. Definition disp_cellset_property (D : disp_bicat) : has_disp_cellset D := pr2 D. Lemma isaset_cells_total_prebicat (D : disp_bicat) : isaset_cells (total_prebicat D). Proof. red. cbn. intros. unfold total_prebicat_cell_struct. apply isaset_total2. - apply cellset_property. - intros. apply disp_cellset_property. Qed. Definition total_bicat (D : disp_bicat) : bicat := total_prebicat D,, isaset_cells_total_prebicat D. End disp_prebicat. Arguments disp_prebicat_1_id_comp_cells _ : clear implicits. Arguments disp_prebicat_data _ : clear implicits. Arguments disp_prebicat _ : clear implicits. Arguments disp_bicat _ : clear implicits. (* ----------------------------------------------------------------------------------- *) (** ** Displayed left and right unitors coincide on the identity *) (* ----------------------------------------------------------------------------------- *) Theorem disp_lunitor_runitor_identity {C : bicat} {D : disp_bicat C} (a : C) (aa : D a) : disp_lunitor (id_disp aa) = cell_transportb (lunitor_runitor_identity a) (disp_runitor (id_disp aa)). Proof. set (TT := fiber_paths (lunitor_runitor_identity (C := total_bicat D) (a ,, aa))). cbn in TT. apply cell_transportf_to_b. etrans. 2: now apply TT. unfold cell_transportf. apply maponpaths_2. apply cellset_property. Qed. Theorem disp_runitor_lunitor_identity {C : bicat} {D : disp_bicat C} {a : C} (aa : D a) : disp_runitor (id_disp aa) = transportb (λ x, disp_2cells x _ _) (runitor_lunitor_identity a) (disp_lunitor (id_disp aa)). Proof. apply (transportf_transpose_right (P := (λ x, disp_2cells x _ _))). apply pathsinv0. etrans. 1: now apply disp_lunitor_runitor_identity. unfold cell_transportb. apply maponpaths_2, cellset_property. Qed. Lemma adjequiv_base_adjequiv_tot {B : bicat} (HB : is_univalent_2_0 B) {D : disp_bicat B} {a b : B} : adjoint_equivalence a b → ∏ (aa : D a), ∑ (bb : D b), @adjoint_equivalence (total_bicat D) (a ,, aa) (b ,, bb). Proof. use (J_2_0 HB (λ _ _ _, _)). intros c aa. exact (aa ,, internal_adjoint_equivalence_identity _). Defined. (* ----------------------------------------------------------------------------------- *) (** ** Useful properties *) (* ----------------------------------------------------------------------------------- *) Definition disp_2cells_isaprop {B : bicat} (D : disp_prebicat_1_id_comp_cells B) := ∏ (a b : B) (f g : a --> b) (x : f ==> g) (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb), isaprop (disp_2cells x ff gg). Definition disp_2cells_iscontr {B : bicat} (D : disp_prebicat_1_id_comp_cells B) := ∏ (a b : B) (f g : a --> b) (x : f ==> g) (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb), iscontr (disp_2cells x ff gg). Definition disp_locally_groupoid {B : bicat} (D : disp_bicat B) := ∏ (a b : B) (f g : a --> b) (x : invertible_2cell f g) (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (xx : disp_2cells x ff gg), is_disp_invertible_2cell x xx. Definition disp_locally_sym {B : bicat} (D : disp_bicat B) := ∏ (a b : B) (f g : a --> b) (x : invertible_2cell f g) (aa : D a) (bb : D b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (xx : disp_2cells x ff gg), disp_2cells (x^-1) gg ff. Definition make_disp_locally_groupoid {B : bicat} (D : disp_bicat B) (H : disp_locally_sym D) (HD : disp_2cells_isaprop D) : disp_locally_groupoid D. Proof. intros a b f g x aa bb ff gg xx. use tpair. - apply H. exact xx. - split; apply HD. Defined. Definition disp_locally_groupoid_over_id {B : bicat} (D : disp_bicat B) : UU := ∏ (a b : B) (f : B ⟦ a, b ⟧) (aa : D a) (bb : D b) (ff gg : aa -->[ f] bb) (xx : disp_2cells (id2_invertible_2cell f) ff gg), is_disp_invertible_2cell (is_invertible_2cell_id₂ f) xx. Definition make_disp_locally_groupoid_univalent_2_1 {B : bicat} (D : disp_bicat B) (HD : disp_locally_groupoid_over_id D) (HB : is_univalent_2_1 B) : disp_locally_groupoid D. Proof. use (J_2_1 HB). exact HD. Defined. Definition disp_2cells_isaprop_from_disp_2cells_iscontr {B : bicat} (D : disp_prebicat_1_id_comp_cells B) : disp_2cells_iscontr D -> disp_2cells_isaprop D. Proof. intro c ; intro ; intros. apply isapropifcontr. apply c. Qed. Definition disp_2cells_isgroupoid_from_disp_2cells_iscontr {B : bicat} (D : disp_bicat B) : disp_2cells_iscontr D -> disp_locally_groupoid D. Proof. intro c ; intro ; intros. simple refine (_ ,, _). - apply c. - split; apply isapropifcontr, c. Qed. Section HomDisplayedCategory. Context {B : bicat} {D : disp_bicat B}. Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60). Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60). Definition disp_hom_ob_mor {x y : B} (xx : D x) (yy : D y) : disp_cat_ob_mor (hom x y). Proof. simple refine (_ ,, _). - exact (λ f, xx -->[ f ] yy). - exact (λ f g ff gg α, ff ==>[ α ] gg). Defined. Definition disp_hom_id_comp {x y : B} (xx : D x) (yy : D y) : disp_cat_id_comp _ (disp_hom_ob_mor xx yy). Proof. simple refine (_ ,, _). - exact (λ f ff, disp_id2 ff). - exact (λ f g h α β ff gg hh αα ββ, αα •• ββ). Defined. Definition disp_hom_data {x y : B} (xx : D x) (yy : D y) : disp_cat_data (hom x y). Proof. simple refine (_ ,, _). - exact (disp_hom_ob_mor xx yy). - exact (disp_hom_id_comp xx yy). Defined. Definition disp_hom_laws {x y : B} (xx : D x) (yy : D y) : disp_cat_axioms _ (disp_hom_data xx yy). Proof. repeat split ; intro ; intros ; cbn. - rewrite disp_id2_left. apply maponpaths_2. apply cellset_property. - rewrite disp_id2_right. apply maponpaths_2. apply cellset_property. - rewrite disp_vassocr. apply maponpaths_2. apply cellset_property. - apply D. Qed. Definition disp_hom {x y : B} (xx : D x) (yy : D y) : disp_cat (hom x y). Proof. simple refine (_ ,, _). - exact (disp_hom_data xx yy). - exact (disp_hom_laws xx yy). Defined. End HomDisplayedCategory. (* ----------------------------------------------------------------------------------- *) (** ** Notations. *) (* ----------------------------------------------------------------------------------- *) Module Notations. Export Bicat.Notations. Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60). Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing). Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60). Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60). Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60). End Notations. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispBicatSection.v000066400000000000000000000324721451125700300257060ustar00rootroot00000000000000(******************************************************************************* Sections of displayed bicategories Contents: 1. Definition of a section 2. Builder for locally propositional/groupoidal displayed bicategories 3. Every section gives a pseudofunctor from the base to the total bicategory *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Local Open Scope cat. (** 1. Definition of a section *) Definition section_disp_bicat_data {B : bicat} (D : disp_bicat B) : UU := ∑ (s_ob : ∏ (x : B), D x) (s_mor : ∏ (x y : B) (f : x --> y), s_ob x -->[ f ] s_ob y), (∏ (x y : B) (f g : x --> y) (τ : f ==> g), s_mor _ _ f ==>[ τ ] s_mor _ _ g) × (∏ (x : B), disp_invertible_2cell (id2_invertible_2cell _) (id_disp _) (s_mor _ _ (id₁ x))) × (∏ (x y z : B) (f : x --> y) (g : y --> z), disp_invertible_2cell (id2_invertible_2cell _) (s_mor _ _ f ;; s_mor _ _ g) (s_mor _ _ (f · g))). Section SectionDataProjections. Context {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D). Definition section_on_ob (x : B) : D x := pr1 s x. Definition section_on_mor {x y : B} (f : x --> y) : section_on_ob x -->[ f ] section_on_ob y := pr12 s _ _ f. Definition section_on_cell {x y : B} {f g : x --> y} (τ : f ==> g) : section_on_mor f ==>[ τ ] section_on_mor g := pr122 s _ _ _ _ τ. Definition section_on_id (x : B) : disp_invertible_2cell (id2_invertible_2cell _) (id_disp _) (section_on_mor (id₁ x)) := pr1 (pr222 s) x. Definition section_on_comp {x y z : B} (f : x --> y) (g : y --> z) : disp_invertible_2cell (id2_invertible_2cell _) (section_on_mor f ;; section_on_mor g) (section_on_mor (f · g)) := pr2 (pr222 s) _ _ _ f g. End SectionDataProjections. Definition section_disp_bicat_laws_id {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y : B) (f : x --> y), section_on_cell s (id₂ f) = disp_id2 (section_on_mor s f). Definition section_disp_bicat_laws_comp {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y : B) (f g h : x --> y) (τ : f ==> g) (θ : g ==> h), section_on_cell s (τ • θ) = section_on_cell s τ •• section_on_cell s θ. Definition section_disp_bicat_laws_lunitor_base {B : bicat} {x y : B} (f : x --> y) : lunitor f = ((id₂ _ ▹ f) • id₂ _) • lunitor f. Proof. rewrite id2_rwhisker. rewrite !id2_left. apply idpath. Qed. Definition section_disp_bicat_laws_lunitor {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y : B) (f : x --> y), transportf (λ z, _ ==>[ z ] _) (section_disp_bicat_laws_lunitor_base f) (disp_lunitor (section_on_mor s f)) = ((pr1 (section_on_id s _) ▹▹ section_on_mor s f) •• pr1 (section_on_comp s (id₁ _) f)) •• section_on_cell s (lunitor f). Definition section_disp_bicat_laws_runitor_base {B : bicat} {x y : B} (f : x --> y) : runitor f = ((f ◃ id₂ _) • id₂ _) • runitor f. Proof. rewrite lwhisker_id2. rewrite !id2_left. apply idpath. Qed. Definition section_disp_bicat_laws_runitor {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y : B) (f : x --> y), transportf (λ z, _ ==>[ z ] _) (section_disp_bicat_laws_runitor_base f) (disp_runitor (section_on_mor s f)) = ((section_on_mor s f ◃◃ pr1 (section_on_id s _)) •• pr1 (section_on_comp s f (id₁ _))) •• section_on_cell s (runitor f). Definition section_disp_bicat_laws_lassociator_base {B : bicat} {w x y z : B} (f : w --> x) (g : x --> y) (h : y --> z) : ((f ◃ id₂ _) • id₂ _) • lassociator f g h = (lassociator f g h • (id₂ _ ▹ h)) • id₂ _. Proof. rewrite id2_rwhisker, lwhisker_id2. rewrite !id2_left, !id2_right. apply idpath. Qed. Definition section_disp_bicat_laws_lassociator {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) := ∏ (w x y z : B) (f : w --> x) (g : x --> y) (h : y --> z), transportf (λ z, _ ==>[ z ] _) (section_disp_bicat_laws_lassociator_base f g h) (((section_on_mor s f ◃◃ pr1 (section_on_comp s g h)) •• pr1 (section_on_comp s f (g · h))) •• section_on_cell s (lassociator f g h)) = (disp_lassociator (section_on_mor s f) (section_on_mor s g) (section_on_mor s h) •• (pr1 (section_on_comp s f g) ▹▹ section_on_mor s h)) •• pr1 (section_on_comp s (f · g) h). Definition section_disp_bicat_laws_lwhisker_base {B : bicat} {x y z : B} (f : x --> y) {g₁ g₂ : y --> z} (η : g₁ ==> g₂) : id₂ _ • (f ◃ η) = (f ◃ η) • id₂ _. Proof. rewrite id2_left, id2_right. apply idpath. Qed. Definition section_disp_bicat_laws_lwhisker {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y z : B) (f : x --> y) (g₁ g₂ : y --> z) (η : g₁ ==> g₂), transportf (λ z, _ ==>[ z ] _) (section_disp_bicat_laws_lwhisker_base f η) (pr1 (section_on_comp s f g₁) •• section_on_cell s (f ◃ η)) = (section_on_mor s f ◃◃ section_on_cell s η) •• pr1 (section_on_comp s f g₂). Definition section_disp_bicat_laws_rwhisker_base {B : bicat} {x y z : B} {f₁ f₂ : x --> y} (g : y --> z) (η : f₁ ==> f₂) : id₂ _ • (η ▹ g) = (η ▹ g) • id₂ _. Proof. rewrite id2_left, id2_right. apply idpath. Qed. Definition section_disp_bicat_laws_rwhisker {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := ∏ (x y z : B) (f₁ f₂ : x --> y) (g : y --> z) (η : f₁ ==> f₂), transportf (λ z, _ ==>[ z ] _) (section_disp_bicat_laws_rwhisker_base g η) (pr1 (section_on_comp s f₁ g) •• section_on_cell s (η ▹ g)) = (section_on_cell s η ▹▹ section_on_mor s g) •• pr1 (section_on_comp s f₂ g). Definition section_disp_bicat_laws {B : bicat} {D : disp_bicat B} (s : section_disp_bicat_data D) : UU := section_disp_bicat_laws_id s × section_disp_bicat_laws_comp s × section_disp_bicat_laws_lunitor s × section_disp_bicat_laws_runitor s × section_disp_bicat_laws_lassociator s × section_disp_bicat_laws_lwhisker s × section_disp_bicat_laws_rwhisker s. Definition section_disp_bicat {B : bicat} (D : disp_bicat B) : UU := ∑ (s : section_disp_bicat_data D), section_disp_bicat_laws s. Coercion section_to_section_data {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_data D := pr1 s. Definition section_disp_bicat_id {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_id s := pr12 s. Definition section_disp_bicat_comp {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_comp s := pr122 s. Definition section_disp_bicat_lunitor {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_lunitor s := pr1 (pr222 s). Definition section_disp_bicat_runitor {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_runitor s := pr12 (pr222 s). Definition section_disp_bicat_lassociator {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_lassociator s := pr122 (pr222 s). Definition section_disp_bicat_lwhisker {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_lwhisker s := pr1 (pr222 (pr222 s)). Definition section_disp_bicat_rwhisker {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D) : section_disp_bicat_laws_rwhisker s := pr2 (pr222 (pr222 s)). (** 2. Builder for locally propositional/groupoidal displayed bicategories *) Section MakeSection. Context {B : bicat} (D : disp_bicat B) (HD₁ : disp_2cells_isaprop D) (HD₂ : disp_locally_groupoid D) (s_ob : ∏ (x : B), D x) (s_mor : ∏ (x y : B) (f : x --> y), s_ob x -->[ f ] s_ob y) (s_cell : ∏ (x y : B) (f g : x --> y) (τ : f ==> g), s_mor _ _ f ==>[ τ ] s_mor _ _ g) (s_id : ∏ (x : B), id_disp _ ==>[ id2 _ ] s_mor _ _ (id₁ x)) (s_comp : ∏ (x y z : B) (f : x --> y) (g : y --> z), s_mor _ _ f ;; s_mor _ _ g ==>[ id2 _ ] s_mor _ _ (f · g)). Definition make_section_disp_bicat_data : section_disp_bicat_data D. Proof. simple refine (s_ob ,, s_mor ,, s_cell ,, _ ,, _). - intro x. refine (s_id x ,, _). apply HD₂. - intros x y z f g. refine (s_comp _ _ _ f g ,, _). apply HD₂. Defined. Definition make_section_disp_bicat_laws : section_disp_bicat_laws make_section_disp_bicat_data. Proof. repeat split ; intro ; intros ; apply HD₁. Qed. Definition make_section_disp_bicat : section_disp_bicat D. Proof. simple refine (_ ,, _). - exact make_section_disp_bicat_data. - exact make_section_disp_bicat_laws. Defined. End MakeSection. (** 3. Every section gives a pseudofunctor from the base to the total bicategory *) Section SectionToPsfunctor. Context {B : bicat} {D : disp_bicat B} (s : section_disp_bicat D). Definition section_to_psfunctor_data : psfunctor_data B (total_bicat D). Proof. use make_psfunctor_data. - exact (λ x, x ,, section_on_ob s x). - exact (λ x y f, f ,, section_on_mor s f). - exact (λ x y f g τ, τ ,, section_on_cell s τ). - exact (λ x, id2 _ ,, pr1 (section_on_id s x)). - exact (λ x y z f g, id2 _ ,, pr1 (section_on_comp s f g)). Defined. Definition section_to_psfunctor_laws : psfunctor_laws section_to_psfunctor_data. Proof. repeat split ; intro ; intros ; cbn. - apply maponpaths. apply (section_disp_bicat_id s). - apply maponpaths. apply (section_disp_bicat_comp s). - use total2_paths_f. + apply section_disp_bicat_laws_lunitor_base. + apply (section_disp_bicat_lunitor s). - use total2_paths_f. + apply section_disp_bicat_laws_runitor_base. + apply (section_disp_bicat_runitor s). - use total2_paths_f. + apply section_disp_bicat_laws_lassociator_base. + apply (section_disp_bicat_lassociator s). - use total2_paths_f. + apply section_disp_bicat_laws_lwhisker_base. + apply (section_disp_bicat_lwhisker s). - use total2_paths_f. + apply section_disp_bicat_laws_rwhisker_base. + apply (section_disp_bicat_rwhisker s). Qed. Definition section_to_psfunctor_invertible_cells : invertible_cells section_to_psfunctor_data. Proof. split. - intro x ; cbn. use is_invertible_disp_to_total. simple refine (_ ,, _). + apply is_invertible_2cell_id₂. + exact (pr2 (section_on_id s x)). - intros x y z f g ; cbn. use is_invertible_disp_to_total. simple refine (_ ,, _). + apply is_invertible_2cell_id₂. + exact (pr2 (section_on_comp s f g)). Defined. Definition section_to_psfunctor : psfunctor B (total_bicat D). Proof. use make_psfunctor. - exact section_to_psfunctor_data. - exact section_to_psfunctor_laws. - exact section_to_psfunctor_invertible_cells. Defined. End SectionToPsfunctor. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispBiequivalence.v000066400000000000000000000235231451125700300261100ustar00rootroot00000000000000(* ------------------------------------------------------------------------- *) (** Displayed biequivalence. Contents: - Definition of displayed biequivalence. - Associated total biequivalence. *) (* ------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Import PseudoFunctor.Notations. Local Open Scope cat. Section DisplayedBiequivalence. Context {B₁ B₂ : bicat} (D₁ : disp_bicat B₁) (D₂ : disp_bicat B₂). Definition is_disp_biequivalence_unit_counit {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} (e : is_biequivalence_unit_counit F G) (FF : disp_psfunctor D₁ D₂ F) (GG : disp_psfunctor D₂ D₁ G) : UU := disp_pstrans (disp_pseudo_comp F G D₁ D₂ D₁ FF GG) (disp_pseudo_id D₁) (unit_of_is_biequivalence e) × disp_pstrans (disp_pseudo_comp G F D₂ D₁ D₂ GG FF) (disp_pseudo_id D₂) (counit_of_is_biequivalence e). Definition unit_of_is_disp_biequivalence {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} {e : is_biequivalence_unit_counit F G} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₁ G} (ee : is_disp_biequivalence_unit_counit e FF GG) : disp_pstrans (disp_pseudo_comp F G D₁ D₂ D₁ FF GG) (disp_pseudo_id D₁) (unit_of_is_biequivalence e) := pr1 ee. Definition counit_of_is_disp_biequivalence {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} {e : is_biequivalence_unit_counit F G} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₁ G} (ee : is_disp_biequivalence_unit_counit e FF GG) : disp_pstrans (disp_pseudo_comp G F D₂ D₁ D₂ GG FF) (disp_pseudo_id D₂) (counit_of_is_biequivalence e) := pr2 ee. Definition total_is_biequivalence_unit_counit {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} {e : is_biequivalence_unit_counit F G} {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₁ G} (ee : is_disp_biequivalence_unit_counit e FF GG) : is_biequivalence_unit_counit (total_psfunctor _ _ _ FF) (total_psfunctor _ _ _ GG). Proof. split. - apply pstrans_on_data_to_pstrans. pose (unit_of_is_disp_biequivalence ee) as uu. pose (total_pstrans _ _ _ uu) as tuu. apply tuu. - apply pstrans_on_data_to_pstrans. pose (counit_of_is_disp_biequivalence ee) as uu. pose (total_pstrans _ _ _ uu) as tuu. apply tuu. Defined. (** ** Data *) Definition disp_is_biequivalence_data {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₁ G} (ee : is_disp_biequivalence_unit_counit e FF GG) : UU := ∑ (uu : disp_pstrans (disp_pseudo_id D₁) (disp_pseudo_comp _ _ _ _ _ FF GG) (invunit_of_is_biequivalence a)) (cc : disp_pstrans (disp_pseudo_id D₂) (disp_pseudo_comp _ _ _ _ _ GG FF) (invcounit_of_is_biequivalence a)), (disp_invmodification _ _ _ _ (disp_comp_pstrans uu (unit_of_is_disp_biequivalence ee)) (disp_id_pstrans _) (unitcounit_of_is_biequivalence _) × disp_invmodification _ _ _ _ (disp_comp_pstrans (unit_of_is_disp_biequivalence ee) uu) (disp_id_pstrans _) (unitunit_of_is_biequivalence _)) × (disp_invmodification _ _ _ _ (disp_comp_pstrans cc (counit_of_is_disp_biequivalence ee)) (disp_id_pstrans _) (counitcounit_of_is_biequivalence _) × disp_invmodification _ _ _ _ (disp_comp_pstrans (counit_of_is_disp_biequivalence ee) cc) (disp_id_pstrans _) (counitunit_of_is_biequivalence _)). (** ** Total biequivalence. *) Section total_biequivalence. Context {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₁} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) {FF : disp_psfunctor D₁ D₂ F} {GG : disp_psfunctor D₂ D₁ G} {ee : is_disp_biequivalence_unit_counit e FF GG} (aa : disp_is_biequivalence_data a ee). Definition total_biequivalence_unit_inv : pstrans (id_psfunctor (total_bicat D₁)) (comp_psfunctor (total_psfunctor D₂ D₁ G GG) (total_psfunctor D₁ D₂ F FF)). Proof. apply pstrans_on_data_to_pstrans. pose (pr1 aa) as aapr. pose (total_pstrans _ _ _ aapr) as taapr. apply taapr. Defined. Definition total_biequivalence_counit_inv : pstrans (id_psfunctor (total_bicat D₂)) (comp_psfunctor (total_psfunctor D₁ D₂ F FF) (total_psfunctor D₂ D₁ G GG)). Proof. apply pstrans_on_data_to_pstrans. pose (pr12 aa) as aapr. pose (total_pstrans _ _ _ aapr) as taapr. apply taapr. Defined. Opaque comp_psfunctor. Definition total_biequivalence_unit_unit_inv : invertible_modification (comp_pstrans (unit_of_is_biequivalence (total_is_biequivalence_unit_counit ee)) total_biequivalence_unit_inv) (id_pstrans (comp_psfunctor (total_psfunctor D₂ D₁ G GG) (total_psfunctor D₁ D₂ F FF))). Proof. pose (total_invmodification _ _ _ _ _ _ _ (pr21 (pr22 aa))) as m. apply make_invertible_modification_on_data. use tpair. - intro X. exact (invertible_modcomponent_of m X). - exact (modnaturality_of (pr1 m)). Defined. Definition total_biequivalence_unit_inv_unit : invertible_modification (comp_pstrans total_biequivalence_unit_inv (unit_of_is_biequivalence (total_is_biequivalence_unit_counit ee))) (id_pstrans (id_psfunctor (total_bicat D₁))). Proof. pose (total_invmodification _ _ _ _ _ _ _ (pr11 (pr22 aa))) as m. apply make_invertible_modification_on_data. use tpair. - intro X. exact (invertible_modcomponent_of m X). - exact (modnaturality_of (pr1 m)). Defined. Definition total_biequivalence_counit_counit_inv : invertible_modification (comp_pstrans (counit_of_is_biequivalence (total_is_biequivalence_unit_counit ee)) total_biequivalence_counit_inv) (id_pstrans (comp_psfunctor (total_psfunctor D₁ D₂ F FF) (total_psfunctor D₂ D₁ G GG))). Proof. pose (total_invmodification _ _ _ _ _ _ _ (pr22 (pr22 aa))) as m. apply make_invertible_modification_on_data. use tpair. - intro X. exact (invertible_modcomponent_of m X). - exact (modnaturality_of (pr1 m)). Defined. Definition total_biequivalence_counit_inv_counit : invertible_modification (comp_pstrans total_biequivalence_counit_inv (counit_of_is_biequivalence (total_is_biequivalence_unit_counit ee))) (id_pstrans (id_psfunctor (total_bicat D₂))). Proof. pose (total_invmodification _ _ _ _ _ _ _ (pr12 (pr22 aa))) as m. apply make_invertible_modification_on_data. use tpair. - intro X. exact (invertible_modcomponent_of m X). - exact (modnaturality_of (pr1 m)). Defined. Definition total_is_biequivalence : is_biequivalence (total_psfunctor _ _ _ FF). Proof. use make_is_biequivalence_from_unit_counit. - exact (total_psfunctor _ _ _ GG). - exact (total_is_biequivalence_unit_counit ee). - exact total_biequivalence_unit_inv. - exact total_biequivalence_counit_inv. - exact total_biequivalence_unit_unit_inv. - exact total_biequivalence_unit_inv_unit. - exact total_biequivalence_counit_counit_inv. - exact total_biequivalence_counit_inv_counit. Defined. End total_biequivalence. End DisplayedBiequivalence. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispBuilders.v000066400000000000000000000127541451125700300251110ustar00rootroot00000000000000Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PathGroupoid. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Local Open Scope cat. Local Open Scope bicategory_scope. Section NiceBuilders. Context {B₁ B₂ : bicat} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂}. Variable (HD₁ : disp_2cells_isaprop D₂) (HD₂ : disp_locally_groupoid D₂). Definition make_disp_psfunctor {F : psfunctor B₁ B₂} (obFF : ∏ x:B₁, D₁ x → D₂ (F x)) (morFF : ∏ (x y : B₁) (f : B₁⟦x,y⟧) (xx : D₁ x) (yy : D₁ y), (xx -->[f] yy) → (obFF x xx -->[#F f] obFF y yy)) (cellFF : ∏ (x y : B₁) (f g : B₁⟦x,y⟧) (α : f ==> g) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[f] yy) (gg : xx -->[g] yy), (ff ==>[α] gg) → (morFF x y f xx yy ff ==>[##F α] morFF x y g xx yy gg)) (disp_psfunctor_id : ∏ (x : B₁) (xx : D₁ x), id_disp (obFF x xx) ==>[ psfunctor_id F x ] morFF x x (id₁ x) xx xx (id_disp xx)) (disp_psfunctor_comp : ∏ (x y z : B₁) (f : x --> y) (g : y --> z) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[f] yy) (gg : yy -->[g] zz), (comp_disp (morFF x y f xx yy ff) (morFF y z g yy zz gg)) ==>[ psfunctor_comp F f g ] morFF x z (f · g) xx zz (comp_disp ff gg)) : disp_psfunctor D₁ D₂ F. Proof. use tpair. - use make_disp_psfunctor_data. + exact obFF. + exact morFF. + exact cellFF. + intros. use tpair. * apply disp_psfunctor_id. * apply HD₂. + intros. use tpair. * apply disp_psfunctor_comp. * apply HD₂. - abstract (repeat split; intro; intros; apply HD₁). Defined. Definition make_disp_pstrans {F₁ F₂ : psfunctor B₁ B₂} {FF₁ : disp_psfunctor D₁ D₂ F₁} {FF₂ : disp_psfunctor D₁ D₂ F₂} {α : pstrans F₁ F₂} (αα₁ : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx) (αα₂ : ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy), (αα₁ x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) ==>[ psnaturality_of α f ] disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα₁ y yy) : disp_pstrans FF₁ FF₂ α. Proof. use tpair. - use make_disp_pstrans_data. + exact αα₁. + intros. use tpair. * apply αα₂. * apply HD₂. - abstract (repeat split; intro; intros; apply HD₁). Defined. Definition make_disp_invmodification {F₁ F₂ : psfunctor B₁ B₂} {α β : pstrans F₁ F₂} {FF₁ : disp_psfunctor D₁ D₂ F₁} {FF₂ : disp_psfunctor D₁ D₂ F₂} {αα : disp_pstrans FF₁ FF₂ α} {ββ : disp_pstrans FF₁ FF₂ β} {m : invertible_modification α β} (mm : ∏ (x : B₁) (xx : D₁ x), αα x xx ==>[ invertible_modcomponent_of m x ] ββ x xx) : disp_invmodification _ _ _ _ αα ββ m. Proof. use tpair. - intro ; intros. use tpair. + apply mm. + apply HD₂. - abstract (repeat split; intro; intros; apply HD₁). Defined. Definition make_disp_invmodification' {F₁ F₂ : psfunctor B₁ B₂} {α β : pstrans F₁ F₂} {FF₁ : disp_psfunctor D₁ D₂ F₁} {FF₂ : disp_psfunctor D₁ D₂ F₂} (αα : disp_pstrans FF₁ FF₂ α) (ββ : disp_pstrans FF₁ FF₂ β) (m : modification α β) (Hm : is_invertible_modification m) (mm : disp_modification _ _ _ _ αα ββ m) (Hmm : ∏ (x : B₁) (xx : D₁ x), is_disp_invertible_2cell (is_invertible_modcomponent_of m Hm x) (pr1 mm x xx)) : disp_invmodification _ _ _ _ αα ββ (m,,Hm). Proof. use tpair. - intros x xx. use tpair. + exact (pr1 mm x xx). + simpl. exact (Hmm x xx). - simpl. exact (pr2 mm). Defined. End NiceBuilders. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispInvertibles.v000066400000000000000000001121471451125700300256230ustar00rootroot00000000000000(* *********************************************************************************** *) (** * Displayed invertible 2-cells This file contains: - Proof that being an displayed invertible 2-cell is a proposition - The classification of invertible 2-cells in the total category in terms of displayed invertible 2-cells. *) (* *********************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition transportf_subtypePath' {A : UU} {B : A → UU} (Bprop : ∏ (a : A), isaprop (B a)) {C : A → UU} {a : A} (b₁ : B a) (b₂ : B a) (x : C a) : transportf (λ (z : ∑ (x : A), B x), C (pr1 z)) (@subtypePath' A B (a ,, b₁) (a ,, b₂) (idpath _) (Bprop _)) x = x. Proof. cbn. induction (Bprop a b₁ b₂) as [p q]. induction p. cbn. reflexivity. Defined. (* TODO: should be moved to Bicat.v or bicategory_laws.v *) Definition transportf_cell_from_invertible_2cell_eq {C : bicat} {a b : C} {f g : C⟦a,b⟧} (Y : f ==> g → UU) {α : f ==> g} (H₁ : is_invertible_2cell α) (H₂ : is_invertible_2cell α) (y : Y α) : transportf (λ (z : invertible_2cell f g), Y (pr1 z)) (@cell_from_invertible_2cell_eq C _ _ _ _ (α ,, H₁) (α ,, H₂) (idpath α)) y = y. Proof. apply transportf_subtypePath'. Qed. (** The displayed identity 2-cells are invertible *) Definition disp_id2_invertible_2cell {C : bicat} {D : disp_prebicat C} {a b : C} {f : C⟦a, b⟧} {aa : D a} {bb : D b} (ff : aa -->[ f ] bb) : disp_invertible_2cell (id2_invertible_2cell f) ff ff. Proof. use tpair. - exact (disp_id2 ff). - use tpair. + cbn. exact (disp_id2 ff). + split ; cbn. * exact (disp_id2_left (disp_id2 ff)). * exact (disp_id2_left (disp_id2 ff)). Defined. (** ** Being a displayed invertible 2-cell is a proposition *) (** The proof of this fact is a bit tricky, and used an intermediate datastructure [disp_iso_total]. *) Section Prop_disp_invertible_2cell. Context {C : bicat}. Context {D : disp_bicat C}. Definition disp_iso_total {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : UU := ∑ (zz : gg ==>[ x^-1 ] ff), (@vcomp2 (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff) (g ,, gg) (f ,, ff) (pr1 x ,, xx) (x^-1 ,, zz) = @id2 (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff)) × (@vcomp2 (total_bicat D) (a ,, aa) (b ,, bb) (g ,, gg) (f ,, ff) (g ,, gg) (x^-1 ,, zz) (pr1 x ,, xx) = @id2 (total_bicat D) (a ,, aa) (b ,, bb) (g ,, gg)). Definition disp_invertible_2cell_to_disp_iso {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x xx → disp_iso_total xx. Proof. intros p. use tpair. - exact (pr1 p). - split ; cbn. + use total2_paths2_b. * apply vcomp_rinv. * apply p. + use total2_paths2_b. * apply vcomp_linv. * apply p. Defined. Definition disp_invertible_2cell_to_disp_iso_inv {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : disp_iso_total xx → is_disp_invertible_2cell x xx. Proof. intros z. use tpair. - exact (pr1 z). - split ; cbn. + cbn in *. apply (@transportf_transpose_right _ (λ α : f ==> f, ff ==>[ α] ff)). refine (_ @ fiber_paths (pr1 (pr2 z))). apply (@transportf_paths _ (λ α : f ==> f, ff ==>[ α] ff)). apply C. + apply (@transportf_transpose_right _ (λ α : g ==> g, gg ==>[ α] gg)). refine (_ @ fiber_paths (pr2 (pr2 z))). apply (@transportf_paths _ (λ α : g ==> g, gg ==>[ α] gg)). apply C. Defined. Definition disp_invertible_2cell_to_disp_iso_weq {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x xx ≃ disp_iso_total xx. Proof. exists (disp_invertible_2cell_to_disp_iso xx). use isweq_iso. - apply disp_invertible_2cell_to_disp_iso_inv. - intros z. apply subtypePath. + intro; apply isapropdirprod ; apply D. + reflexivity. - intros z. apply subtypePath. + intro; apply isapropdirprod ; apply (total_bicat D). + reflexivity. Defined. Definition disp_iso_to_invetible_2cell {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : disp_iso_total xx → @is_invertible_2cell (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff) (g ,, gg) (pr1 x ,, xx). Proof. intros z. use tpair. - use tpair. + exact (x^-1). + exact (pr1 z). - split ; cbn. + use total2_paths_f ; cbn. * apply vcomp_rinv. * refine (_ @ fiber_paths (pr1 (pr2 z))) ; cbn. apply (@transportf_paths _ (λ α : f ==> f, ff ==>[ α] ff)). apply C. + use total2_paths_f ; cbn. * apply vcomp_linv. * refine (_ @ fiber_paths (pr2 (pr2 z))) ; cbn. apply (@transportf_paths _ (λ α : g ==> g, gg ==>[ α] gg)). apply C. Defined. Definition pr1_invertible_2cell_total {a b : C} {f g : C⟦a,b⟧} {x : f ==> g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : @is_invertible_2cell (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff) (g ,, gg) (x ,, xx) → is_invertible_2cell x. Proof. intros z. use tpair. - exact (pr11 z). - split. + exact (base_paths _ _ (pr12 z)). + exact (base_paths _ _ (pr22 z)). Defined. Definition disp_iso_to_invetible_2cell_inv {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : @is_invertible_2cell (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff) (g ,, gg) (pr1 x ,, xx) → disp_iso_total xx. Proof. intros z. use tpair. - refine (transportb (λ z, _ ==>[ z ] _) _ (pr2 (pr1 z))). exact (base_paths _ _ (pr1 (isaprop_is_invertible_2cell (pr1 x) (pr2 x) (pr1_invertible_2cell_total xx z)))). - split ; cbn. + use total2_paths_b. * apply vcomp_rinv. * cbn. induction z as [inv Hz]. induction inv as [inv1 inv2]. induction Hz as [H1 H2]. cbn in H1, H2. pose (fiber_paths H1) as p. cbn in p. rewrite <- p ; clear p. rewrite transport_b_f. cbn. unfold transportb. rewrite (@disp_mor_transportf_prewhisker). apply (@transportf_paths _ (λ z, ff ==>[ z ] ff)). apply C. + use total2_paths_b. * apply vcomp_linv. * cbn. induction z as [inv Hz]. induction inv as [inv1 inv2]. induction Hz as [H1 H2]. cbn in H1, H2. pose (fiber_paths H2) as p. cbn in p. rewrite <- p ; clear p. rewrite transport_b_f. cbn. unfold transportb. rewrite (@disp_mor_transportf_postwhisker). apply (@transportf_paths _ (λ z, gg ==>[ z ] gg)). apply C. Defined. Definition disp_iso_to_invetible_2cell_weq {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : disp_iso_total xx ≃ @is_invertible_2cell (total_bicat D) (a ,, aa) (b ,, bb) (f ,, ff) (g ,, gg) (pr1 x ,, xx). Proof. exists (disp_iso_to_invetible_2cell xx). use isweq_iso. - apply disp_iso_to_invetible_2cell_inv. - intros z. use subtypePath. + intro; apply isapropdirprod ; apply (total_bicat D). + cbn. apply (transportf_set (λ z, gg ==>[ z ] ff)). apply C. - intros z. use subtypePath. + intro; apply isapropdirprod ; apply (total_bicat D). + use total2_paths_b. * cbn. exact (base_paths _ _ (pr1 (isaprop_is_invertible_2cell (pr1 x) (pr2 x) (pr1_invertible_2cell_total xx z)))). * cbn. reflexivity. Defined. Definition isaprop_is_disp_invertible_2cell {a b : C} {f g : C⟦a,b⟧} {x : invertible_2cell f g} {aa : D a} {bb : D b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : isaprop (is_disp_invertible_2cell x xx) := isofhlevelweqb 1 ((disp_iso_to_invetible_2cell_weq xx) ∘ disp_invertible_2cell_to_disp_iso_weq xx)%weq (isaprop_is_invertible_2cell _). End Prop_disp_invertible_2cell. (** ** Classification of invertible 2-cells in the total bicategory *) Section Total_invertible_2cells. Context {C : bicat}. Context {D : disp_bicat C}. Local Definition E := (total_bicat D). (** *** If a 2-cell is invertible in the total category, then it is invertible in the base category *) Definition is_invertible_total_to_base {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (α : f ==> g) (αα : ff ==>[α] gg) : @is_invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) (α,,αα) → is_invertible_2cell α. Proof. intros Hz. induction Hz as [inv Hz]. induction inv as [i ii]. induction Hz as [Hz1 Hz2]. cbn in *. use tpair. - exact i. - cbn. split. + exact (base_paths _ _ Hz1). + exact (base_paths _ _ Hz2). Defined. (** *** If a 2-cell is invertible in the total category, then it is invertible in the fiber *) Definition is_invertible_total_to_fiber {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (α : f ==> g) (αα : ff ==>[α] gg) : forall (Hαα: @is_invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) (α,,αα)), is_disp_invertible_2cell (is_invertible_total_to_base _ _ Hαα) αα. Proof. intros Hz. induction Hz as [inv Hz]. induction inv as [i ii]. induction Hz as [Hz1 Hz2]. cbn in *. use tpair. - exact ii. - cbn. split. * apply (@transportf_transpose_right _ (λ α : f ==> f, ff ==>[ α] ff)). refine (_ @ fiber_paths Hz1). apply (@transportf_paths _ (λ α : f ==> f, ff ==>[ α] ff)). apply pathsinv0inv0. * apply (@transportf_transpose_right _ (λ α : g ==> g, gg ==>[ α] gg)). refine (_ @ fiber_paths Hz2). apply (@transportf_paths _ (λ α : g ==> g, gg ==>[ α] gg)). apply pathsinv0inv0. Defined. Definition is_invertible_total_to_disp {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (α : f ==> g) (αα : ff ==>[α] gg) : @is_invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) (α,,αα) → ∑ (Hα : is_invertible_2cell α), is_disp_invertible_2cell Hα αα. Proof. intros Hαα. refine (is_invertible_total_to_base _ _ Hαα,, is_invertible_total_to_fiber _ _ Hαα). Defined. (** *** If the displayed 2-cell is invertible, then the corresponding 2-cell in the total bicategory is also invertible. *) Definition is_invertible_disp_to_total {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (α : f ==> g) (αα : ff ==>[α] gg) : (∑ (Hα : is_invertible_2cell α), is_disp_invertible_2cell Hα αα) → (@is_invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) (α,,αα)). Proof. intros H. pose (Hα := pr1 H). pose (Hαα := pr2 H). cbn in Hαα. pose (αα' := (αα,,Hαα) : disp_invertible_2cell (α,,Hα) _ _). use tpair. - use tpair. + exact (inv_cell Hα). + exact (disp_inv_cell αα'). - split. + cbn. use total2_paths_b. ** apply vcomp_rinv. ** apply (disp_vcomp_rinv αα'). + cbn. use total2_paths_b. ** apply vcomp_linv. ** apply (disp_vcomp_linv αα'). Defined. (** those maps form a weak equivalence *) Definition is_invertible_total_to_disp_weq {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (α : f ==> g) (αα : ff ==>[α] gg) : @is_invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) (α,,αα) ≃ ∑ (Hα : is_invertible_2cell α), is_disp_invertible_2cell Hα αα. Proof. apply weqimplimpl. 3: apply isaprop_is_invertible_2cell. 3: { apply isofhleveltotal2. { apply isaprop_is_invertible_2cell. } intro Hα. pose (α' := (α,,Hα) : invertible_2cell _ _). apply (isaprop_is_disp_invertible_2cell (x:=α') αα). } { apply is_invertible_total_to_disp. } apply is_invertible_disp_to_total. Defined. (** Now we add some data in front of the [is_(disp)_invertible_2cell], and massage it a bit to get an equivalence between [(disp)_invertible_2cell]. *) Lemma step1 {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} : @invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg) ≃ (∑ (α : f ==> g) (αα : ff ==>[α] gg), ∑ (Hα : is_invertible_2cell α), is_disp_invertible_2cell Hα αα). Proof. eapply weqcomp. { apply weqfibtototal. intro. apply is_invertible_total_to_disp_weq. } eapply weqcomp. { apply weqinvweq. apply weqtotal2asstol. } apply idweq. Defined. Lemma step2 {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} : (∑ (α : f ==> g) (αα : ff ==>[α] gg), ∑ (Hα : is_invertible_2cell α), is_disp_invertible_2cell Hα αα) ≃ (∑ (i : invertible_2cell f g), disp_invertible_2cell i ff gg). Proof. eapply weqcomp. 2: { apply weqtotal2asstol. } unfold disp_invertible_2cell. eapply weqfibtototal. intros α. cbn. apply weqtotal2comm. Defined. (** Finally we combine all of the above into a single theorem *) Definition iso_in_E_weq {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) : (∑ (i : invertible_2cell f g), disp_invertible_2cell i ff gg) ≃ (@invertible_2cell E (x ,, xx) (y ,, yy) (f,, ff) (g,, gg)). Proof. apply weqinvweq. eapply weqcomp. - apply step1. - apply step2. Defined. End Total_invertible_2cells. (** Examples of invertible 2-cells *) Definition disp_inv_cell_is_disp_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : invertible_2cell f g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {αα : ff ==>[ α ] gg} (Hαα : is_disp_invertible_2cell α αα) : is_disp_invertible_2cell (is_invertible_2cell_inv α) (disp_inv_cell (αα ,, Hαα)). Proof. refine (αα ,, _ ,, _). - exact (disp_vcomp_linv (αα ,, Hαα)). - exact (disp_vcomp_rinv (αα ,, Hαα)). Defined. Definition inverse_of_disp_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : invertible_2cell f g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : disp_invertible_2cell α ff gg) : disp_invertible_2cell (inv_of_invertible_2cell α) gg ff. Proof. simple refine (_ ,, _). - exact (disp_inv_cell αα). - exact (disp_inv_cell_is_disp_invertible_2cell (pr2 αα)). Defined. Section VCompDispIsInvertible. Context {B : bicat} {D : disp_bicat B} {a b : B} {aa : D a} {bb : D b} {f g h : a --> b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} {hh : aa -->[ h ] bb} {α : invertible_2cell f g} {β : invertible_2cell g h} (αα : disp_invertible_2cell α ff gg) (ββ : disp_invertible_2cell β gg hh). Definition vcomp_disp_is_invertible_rinv : (αα •• ββ) •• (disp_inv_cell ββ •• disp_inv_cell αα) = transportb (λ z, ff ==>[z] ff) (vcomp_rinv (comp_of_invertible_2cell α β)) (disp_id2 ff). Proof. cbn. rewrite disp_vassocl. etrans. { do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. apply disp_vcomp_rinv. } unfold transportb. rewrite !disp_mor_transportf_postwhisker, !disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_id2_left. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { apply maponpaths. exact (disp_vcomp_rinv αα). } unfold transportb. rewrite !transport_f_f. refine (maponpaths (λ p, transportf (λ z, _ ==>[ z ] _) p _) _). apply B. Qed. Definition vcomp_disp_is_invertible_linv : (disp_inv_cell ββ •• disp_inv_cell αα) •• (αα •• ββ) = transportb (λ z, hh ==>[z] hh) (vcomp_linv (comp_of_invertible_2cell α β)) (disp_id2 hh). Proof. cbn. etrans. { rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. apply disp_vcomp_linv. } unfold transportb. rewrite !disp_mor_transportf_postwhisker, !disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_id2_left. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { apply maponpaths. exact (disp_vcomp_linv ββ). } unfold transportb. rewrite !transport_f_f. refine (maponpaths (λ p, transportf (λ z, _ ==>[ z ] _) p _) _). apply B. Qed. Definition vcomp_disp_is_invertible : is_disp_invertible_2cell (comp_of_invertible_2cell α β) (αα •• ββ). Proof. use tpair. - exact (disp_inv_cell ββ •• disp_inv_cell αα). - split. + exact vcomp_disp_is_invertible_rinv. + exact vcomp_disp_is_invertible_linv. Defined. End VCompDispIsInvertible. Definition vcomp_disp_invertible {B : bicat} {D : disp_bicat B} {a b : B} {aa : D a} {bb : D b} {f g h : a --> b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} {hh : aa -->[ h ] bb} {α : invertible_2cell f g} {β : invertible_2cell g h} (αα : disp_invertible_2cell α ff gg) (ββ : disp_invertible_2cell β gg hh) : disp_invertible_2cell (comp_of_invertible_2cell α β) ff hh. Proof. use tpair. { repeat use tpair. exact (αα •• ββ). } apply vcomp_disp_is_invertible. Defined. Definition is_disp_invertible_2cell_lunitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : is_disp_invertible_2cell (is_invertible_2cell_lunitor f) (disp_lunitor ff). Proof. use tpair. - exact (disp_linvunitor ff). - split. + etrans. { apply disp_lunitor_linvunitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. + etrans. { apply disp_linvunitor_lunitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. Defined. Definition disp_invertible_2cell_lunitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : disp_invertible_2cell (lunitor f,, is_invertible_2cell_lunitor f) (id_disp xx;; ff) ff := disp_lunitor ff,, is_disp_invertible_2cell_lunitor ff. Definition is_disp_invertible_2cell_runitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : is_disp_invertible_2cell (is_invertible_2cell_runitor f) (disp_runitor ff). Proof. use tpair. - exact (disp_rinvunitor ff). - split. + etrans. { apply disp_runitor_rinvunitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. + etrans. { apply disp_rinvunitor_runitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. Defined. Definition disp_invertible_2cell_runitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : disp_invertible_2cell (runitor f,, is_invertible_2cell_runitor f) (ff;; id_disp yy) ff := disp_runitor ff,, is_disp_invertible_2cell_runitor ff. Definition is_disp_invertible_2cell_rinvunitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : is_disp_invertible_2cell (is_invertible_2cell_rinvunitor f) (disp_rinvunitor ff). Proof. use tpair. - exact (disp_runitor ff). - split. + etrans. { apply disp_rinvunitor_runitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. + etrans. { apply disp_runitor_rinvunitor. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. Defined. Definition disp_invertible_2cell_rinvunitor {B : bicat} {x y : B} {f : x --> y} {D : disp_bicat B} {xx : D x} {yy : D y} (ff : xx -->[f] yy) : disp_invertible_2cell (rinvunitor f,, is_invertible_2cell_rinvunitor f) ff (ff;; id_disp yy) := disp_rinvunitor ff,, is_disp_invertible_2cell_rinvunitor ff. Definition is_disp_invertible_2cell_lassociator {B : bicat} {w x y z : B} {f : w --> x} {g : x --> y} {h : y --> z} {D : disp_bicat B} {ww : D w} {xx : D x} {yy : D y} {zz : D z} (ff : ww -->[f] xx) (gg : xx -->[g] yy) (hh : yy -->[h] zz) : is_disp_invertible_2cell (is_invertible_2cell_lassociator f g h) (disp_lassociator ff gg hh). Proof. use tpair. - exact (disp_rassociator ff gg hh). - split. + etrans. { apply disp_lassociator_rassociator. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. + etrans. { apply disp_rassociator_lassociator. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. Defined. Definition disp_invertible_2cell_lassociator {B : bicat} {w x y z : B} {f : w --> x} {g : x --> y} {h : y --> z} {D : disp_bicat B} {ww : D w} {xx : D x} {yy : D y} {zz : D z} (ff : ww -->[f] xx) (gg : xx -->[g] yy) (hh : yy -->[h] zz) : disp_invertible_2cell (lassociator f g h,, is_invertible_2cell_lassociator f g h) _ _ := disp_lassociator ff gg hh,, is_disp_invertible_2cell_lassociator ff gg hh. Definition is_disp_invertible_2cell_rassociator {B : bicat} {w x y z : B} {f : w --> x} {g : x --> y} {h : y --> z} {D : disp_bicat B} {ww : D w} {xx : D x} {yy : D y} {zz : D z} (ff : ww -->[f] xx) (gg : xx -->[g] yy) (hh : yy -->[h] zz) : is_disp_invertible_2cell (is_invertible_2cell_rassociator f g h) (disp_rassociator ff gg hh). Proof. use tpair. - exact (disp_lassociator ff gg hh). - split. + etrans. { apply disp_rassociator_lassociator. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. + etrans. { apply disp_lassociator_rassociator. } apply (transportf_paths (λ p, _ ==>[p] _)). apply B. Defined. Definition disp_invertible_2cell_rassociator {B : bicat} {w x y z : B} {f : w --> x} {g : x --> y} {h : y --> z} {D : disp_bicat B} {ww : D w} {xx : D x} {yy : D y} {zz : D z} (ff : ww -->[f] xx) (gg : xx -->[g] yy) (hh : yy -->[h] zz) : disp_invertible_2cell (rassociator f g h,, is_invertible_2cell_rassociator f g h) _ _ := disp_rassociator ff gg hh,, is_disp_invertible_2cell_rassociator ff gg hh. Definition is_disp_invertible_2cell_lwhisker {B : bicat} {x y z : B} {f : x --> y} {g₁ g₂ : y --> z} {α : invertible_2cell g₁ g₂} {D : disp_bicat B} {xx : D x} {yy : D y} {zz : D z} (ff : xx -->[f] yy) {gg₁ : yy -->[g₁] zz} {gg₂ : yy -->[g₂] zz} (αα : disp_invertible_2cell α gg₁ gg₂) : is_disp_invertible_2cell (is_invertible_2cell_lwhisker f (pr2 α)) (ff ◃◃ αα). Proof. use tpair. - exact (ff ◃◃ disp_inv_cell αα). - split. + abstract (refine (disp_lwhisker_vcomp _ _ @ _) ; refine (maponpaths _ (maponpaths _ (disp_vcomp_rinv _)) @ _) ; unfold transportb ; rewrite disp_rwhisker_transport_right ; rewrite disp_lwhisker_id2 ; unfold transportb ; rewrite !transport_f_f ; apply (transportf_paths (λ p, _ ==>[ p ] _)) ; apply B). + abstract (refine (disp_lwhisker_vcomp _ _ @ _) ; refine (maponpaths _ (maponpaths _ (disp_vcomp_linv _)) @ _) ; unfold transportb ; rewrite disp_rwhisker_transport_right ; rewrite disp_lwhisker_id2 ; unfold transportb ; rewrite !transport_f_f ; apply (transportf_paths (λ p, _ ==>[ p ] _)) ; apply B). Defined. Definition disp_invertible_2cell_lwhisker {B : bicat} {x y z : B} {f : x --> y} {g₁ g₂ : y --> z} {α : invertible_2cell g₁ g₂} {D : disp_bicat B} {xx : D x} {yy : D y} {zz : D z} (ff : xx -->[f] yy) {gg₁ : yy -->[g₁] zz} {gg₂ : yy -->[g₂] zz} (αα : disp_invertible_2cell α gg₁ gg₂) : disp_invertible_2cell (_ ,, is_invertible_2cell_lwhisker f (pr2 α)) _ _ := disp_lwhisker ff αα,, is_disp_invertible_2cell_lwhisker ff αα. Definition is_disp_invertible_2cell_rwhisker {B : bicat} {x y z : B} {f₁ f₂ : x --> y} {g : y --> z} {α : invertible_2cell f₁ f₂} {D : disp_bicat B} {xx : D x} {yy : D y} {zz : D z} {ff₁ : xx -->[f₁] yy} {ff₂ : xx -->[f₂] yy} (gg : yy -->[g] zz) (αα : disp_invertible_2cell α ff₁ ff₂) : is_disp_invertible_2cell (is_invertible_2cell_rwhisker g (pr2 α)) (αα ▹▹ gg). Proof. use tpair. - exact (disp_inv_cell αα ▹▹ gg). - split. + abstract (refine (disp_rwhisker_vcomp _ _ @ _) ; refine (maponpaths _ (maponpaths _ (disp_vcomp_rinv _)) @ _) ; unfold transportb ; rewrite disp_rwhisker_transport_left_new ; rewrite disp_id2_rwhisker ; unfold transportb ; rewrite !transport_f_f ; apply (transportf_paths (λ p, _ ==>[ p ] _)) ; apply B). +abstract (refine (disp_rwhisker_vcomp _ _ @ _) ; refine (maponpaths _ (maponpaths _ (disp_vcomp_linv _)) @ _) ; unfold transportb ; rewrite disp_rwhisker_transport_left_new ; rewrite disp_id2_rwhisker ; unfold transportb ; rewrite !transport_f_f ; apply (transportf_paths (λ p, _ ==>[ p ] _)) ; apply B). Defined. Definition disp_invertible_2cell_rwhisker {B : bicat} {x y z : B} {f₁ f₂ : x --> y} {g : y --> z} {α : invertible_2cell f₁ f₂} {D : disp_bicat B} {xx : D x} {yy : D y} {zz : D z} {ff₁ : xx -->[f₁] yy} {ff₂ : xx -->[f₂] yy} (gg : yy -->[g] zz) (αα : disp_invertible_2cell α ff₁ ff₂) : disp_invertible_2cell (_ ,, is_invertible_2cell_rwhisker g (pr2 α)) _ _ := disp_rwhisker gg αα,, is_disp_invertible_2cell_rwhisker gg αα. Definition transportf_is_disp_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α β : f ==> g} (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β) {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {αα : ff ==>[ α ] gg} (p : α = β) (Hαα : is_disp_invertible_2cell Hα αα) : is_disp_invertible_2cell Hβ (transportf (λ z, _ ==>[ z ] _) p αα). Proof. induction p ; cbn. refine (transportf (λ z, is_disp_invertible_2cell z αα) _ Hαα). apply isaprop_is_invertible_2cell. Defined. Definition disp_hom_disp_z_iso_to_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : disp_hom xx yy f} {gg : disp_hom xx yy g} (αα : ff -->[ α ] gg) (Hαα : @is_z_iso_disp _ (disp_hom xx yy) _ _ (α ,, is_inv2cell_to_is_z_iso _ Hα) _ _ αα) : is_disp_invertible_2cell Hα αα. Proof. simple refine (_ ,, (_ ,, _)). - exact (inv_mor_disp_from_z_iso Hαα). - abstract (cbn; etrans; [apply (inv_mor_after_z_iso_disp Hαα)|]; unfold transportb; apply maponpaths_2 ; apply cellset_property). - abstract (cbn; etrans; [ apply (z_iso_disp_after_inv_mor Hαα) |]; unfold transportb; apply maponpaths_2; apply cellset_property). Defined. Definition disp_hom_disp_invertible_2cell_to_z_iso {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : disp_hom xx yy f} {gg : disp_hom xx yy g} (αα : ff -->[ α ] gg) (Hαα : is_disp_invertible_2cell Hα αα) : @is_z_iso_disp _ (disp_hom xx yy) _ _ (α ,, is_inv2cell_to_is_z_iso _ Hα) _ _ αα. Proof. pose (d := (αα ,, Hαα) : disp_invertible_2cell (α ,, Hα) ff gg). simple refine (_ ,, (_ ,, _)). - exact (disp_inv_cell d). - abstract (cbn; unfold transportb; etrans; [ exact (disp_vcomp_linv d) |]; unfold transportb; apply maponpaths_2; apply cellset_property). - abstract (cbn; unfold transportb; etrans; [ exact (disp_vcomp_rinv d) |]; unfold transportb; apply maponpaths_2; apply cellset_property). Defined. Definition disp_hom_disp_z_iso_weq_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : f ==> g} {Hα : is_invertible_2cell α} {xx : D x} {yy : D y} {ff : disp_hom xx yy f} {gg : disp_hom xx yy g} (αα : ff -->[ α ] gg) : (@is_z_iso_disp _ (disp_hom xx yy) _ _ (α ,, is_inv2cell_to_is_z_iso _ Hα) _ _ αα) ≃ is_disp_invertible_2cell Hα αα. Proof. use weqimplimpl. - apply disp_hom_disp_z_iso_to_invertible_2cell. - apply disp_hom_disp_invertible_2cell_to_z_iso. - apply isaprop_is_z_iso_disp. - apply (@isaprop_is_disp_invertible_2cell _ D _ _ _ _ (α ,, Hα)). Qed. Definition transportf_disp_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {α β : invertible_2cell f g} (p : α = β) (αα : disp_invertible_2cell α ff gg) : pr1 (transportf (λ (z : invertible_2cell f g), disp_invertible_2cell z ff gg) p αα) = transportf (λ z, ff ==>[ z ] gg) (maponpaths pr1 p) αα. Proof. induction p ; cbn. apply idpath. Qed. (** Transporting along displayed invertible 2-cells *) Definition transport_1cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} (p : f = g) {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : xx -->[ g ] yy := transportf (λ z, _ -->[ z ] _) p ff. Definition transport_1cell_disp_invertible_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} (p : f = g) {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : disp_invertible_2cell (inv_of_invertible_2cell (idtoiso_2_1 _ _ p)) (transport_1cell p ff) ff. Proof. induction p. exact (disp_id2_invertible_2cell ff). Defined. Definition transport_along_inv_2cell {B : bicat} (HB : is_univalent_2_1 B) {D : disp_bicat B} {x y : B} {f g : x --> y} (α : invertible_2cell f g) {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : xx -->[ g ] yy := transport_1cell (isotoid_2_1 HB α) ff. Definition transport_along_inv_2cell_disp_invertible_2cell {B : bicat} (HB : is_univalent_2_1 B) {D : disp_bicat B} {x y : B} {f g : x --> y} (α : invertible_2cell f g) {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) : disp_invertible_2cell (inv_of_invertible_2cell α) (transport_along_inv_2cell HB α ff) ff. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (transport_1cell_disp_invertible_2cell (isotoid_2_1 HB α) ff)). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispModification.v000066400000000000000000000170771451125700300257500ustar00rootroot00000000000000(* ------------------------------------------------------------------------- *) (** Displayed modifications. Contents: - Definition of displayed pseudofunctors. - Identity and composition of displayed pseudofunctors. *) (* ------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Import PseudoFunctor.Notations. Local Open Scope cat. (** ** Definition of displayed modifications *) Section DispModification. Context {B₁ : bicat} {D₁ : disp_bicat B₁} {B₂ : bicat} {D₂ : disp_bicat B₂} {F₁ F₂ : psfunctor B₁ B₂} (α β : pstrans F₁ F₂) (FF₁ : disp_psfunctor D₁ D₂ F₁) (FF₂ : disp_psfunctor D₁ D₂ F₂) (αα : disp_pstrans FF₁ FF₂ α) (ββ : disp_pstrans FF₁ FF₂ β) (m : modification α β). (** *** Data *) Definition disp_modification_data : UU := ∏ (x : B₁) (xx : D₁ x), (αα x xx) ==>[m x] (ββ x xx). Definition total_modification_data (mmdata : disp_modification_data) : modification_data (total_pstrans _ _ _ αα) (total_pstrans _ _ _ ββ) := λ (x : total_bicat D₁), m (pr1 x),, mmdata (pr1 x) (pr2 x). Definition is_disp_modification (mm : disp_modification_data) : UU := ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy), disp_psnaturality_of FF₁ FF₂ α αα ff •• (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff ◃◃ mm y yy) = transportb (λ p, _ ==>[p] _) (modnaturality_of m x y f) ((mm x xx ▹▹ disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) •• disp_psnaturality_of FF₁ FF₂ β ββ ff). Definition disp_modification : UU := ∑ mm : disp_modification_data, is_disp_modification mm. Coercion disp_modification_to_disp_modification_data (αα : disp_modification) : disp_modification_data := pr1 αα. Lemma is_disp_modification_from_total (mm : disp_modification_data) : is_modification (total_modification_data mm) → is_disp_modification mm. Proof. intros Hmm. pose (Em := make_modification _ Hmm). intros x y f xx yy ff. pose (P := !fiber_paths (@modnaturality_of _ _ _ _ _ _ Em (x,,xx) (y,,yy) (f,,ff))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. Qed. Lemma total_modification_laws (mm : disp_modification) : is_modification (total_modification_data mm). Proof. intros x y f. use total2_paths_b. - apply (modnaturality_of m (pr1 x) (pr1 y) (pr1 f)). - apply mm. Qed. Definition is_invertible_disp_modification (mm : disp_modification) : UU := ∑ (m_inv : is_invertible_modification m), ∏ (x : B₁) (xx : D₁ x), (* Each underlying displayed 2-cell is invertible *) is_disp_invertible_2cell (@is_invertible_modcomponent_of _ _ _ _ _ _ m m_inv x) (pr1 mm x xx). End DispModification. (** Invertible displayed modifications *) Section DispInvModification. Context {B₁ : bicat} {D₁ : disp_bicat B₁} {B₂ : bicat} {D₂ : disp_bicat B₂} {F₁ F₂ : psfunctor B₁ B₂} (α β : pstrans F₁ F₂) (FF₁ : disp_psfunctor D₁ D₂ F₁) (FF₂ : disp_psfunctor D₁ D₂ F₂) (αα : disp_pstrans FF₁ FF₂ α) (ββ : disp_pstrans FF₁ FF₂ β) (m : invertible_modification α β). (** *** Data *) Definition disp_invmodification_data : UU := ∏ (x : B₁) (xx : D₁ x), disp_invertible_2cell (invertible_modcomponent_of m x) (αα x xx) (ββ x xx). Definition total_invmodification_data (mmdata : disp_invmodification_data) : invertible_modification_data (total_pstrans _ _ _ αα) (total_pstrans _ _ _ ββ) := λ (x : total_bicat D₁), (iso_in_E_weq (αα (pr1 x) (pr2 x)) (ββ (pr1 x) (pr2 x))) (invertible_modcomponent_of m (pr1 x),, mmdata (pr1 x) (pr2 x)). Definition is_disp_invmodification (mm : disp_invmodification_data) : UU := ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy), disp_psnaturality_of FF₁ FF₂ α αα ff •• (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff ◃◃ mm y yy) = transportb (λ p, _ ==>[p] _) (modnaturality_of (pr1 m) x y f) ((mm x xx ▹▹ disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) •• disp_psnaturality_of FF₁ FF₂ β ββ ff). Definition disp_invmodification : UU := ∑ mm : disp_invmodification_data, is_disp_invmodification mm. Coercion disp_invmodification_to_disp_invmodification_data (αα : disp_invmodification) : disp_invmodification_data := pr1 αα. Definition disp_modification_of_invmodification (mm : disp_invmodification) : disp_modification α β FF₁ FF₂ αα ββ (pr1 m). Proof. use tpair. - intros x xx. exact (pr1 mm x xx). - simpl. exact (pr2 mm). Defined. Lemma is_invertible_disp_invmodification (mm : disp_invmodification) : is_invertible_disp_modification _ _ _ _ _ _ _ (disp_modification_of_invmodification mm). Proof. use tpair. - exact (pr2 m). - simpl. intros x xx. exact (pr2 (pr1 mm x xx)). Qed. Lemma is_disp_invmodification_from_total (mm : disp_invmodification_data) : is_modification (total_invmodification_data mm) → is_disp_invmodification mm. Proof. intros Hmm. pose (Em := make_modification _ Hmm). intros x y f xx yy ff. pose (P := !fiber_paths (@modnaturality_of _ _ _ _ _ _ Em (x,,xx) (y,,yy) (f,,ff))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. Qed. Lemma total_invmodification_laws (mm : disp_invmodification) : is_modification (total_invmodification_data mm). Proof. intros x y f. use total2_paths_b. - apply (modnaturality_of (pr1 m) (pr1 x) (pr1 y) (pr1 f)). - apply mm. Qed. Definition total_invmodification (mm : disp_invmodification) : invertible_modification (total_pstrans _ _ _ αα) (total_pstrans _ _ _ ββ). Proof. use make_invertible_modification. - exact (total_invmodification_data mm). - exact (total_invmodification_laws mm). Defined. End DispInvModification. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispPseudofunctor.v000066400000000000000000000600701451125700300261720ustar00rootroot00000000000000(* ------------------------------------------------------------------------- *) (** Displayed pseudofunctors. Marco Maggesi, Niccolò Veltri, Niels van der Weide July 2019 Contents: - Definition of displayed pseudofunctors. - Identity and composition of displayed pseudofunctors. *) (* ------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Import PseudoFunctor.Notations. Local Open Scope cat. (** ** Definition of displayed pseudofunctor *) Section DispPseudofunctor. Context {B₁ : bicat} (D₁ : disp_bicat B₁) {B₂ : bicat} (D₂ : disp_bicat B₂) (F : psfunctor B₁ B₂). (** *** Data *) Definition disp_psfunctor_data : UU := ∑ (obFF : ∏ x:B₁, D₁ x → D₂ (F x)) (morFF : ∏ (x y : B₁) (f : B₁⟦x,y⟧) (xx : D₁ x) (yy : D₁ y), (xx -->[f] yy) → (obFF x xx -->[#F f] obFF y yy)) (cellFF : ∏ (x y : B₁) (f g : B₁⟦x,y⟧) (α : f ==> g) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[f] yy) (gg : xx -->[g] yy), (ff ==>[α] gg) → (morFF x y f xx yy ff ==>[##F α] morFF x y g xx yy gg)) (disp_psfunctor_id : ∏ (x : B₁) (xx : D₁ x), disp_invertible_2cell (psfunctor_id F x) (id_disp (obFF x xx)) (morFF x x (id₁ x) xx xx (id_disp xx))), (∏ (x y z : B₁) (f : x --> y) (g : y --> z) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[f] yy) (gg : yy -->[g] zz), disp_invertible_2cell (psfunctor_comp F f g) (comp_disp (morFF x y f xx yy ff) (morFF y z g yy zz gg)) (morFF x z (f · g) xx zz (comp_disp ff gg))). Definition make_disp_psfunctor_data (obFF : ∏ x:B₁, D₁ x → D₂ (F x)) (morFF : ∏ (x y : B₁) (f : B₁⟦x,y⟧) (xx : D₁ x) (yy : D₁ y), (xx -->[f] yy) → (obFF x xx -->[#F f] obFF y yy)) (cellFF : ∏ (x y : B₁) (f g : B₁⟦x,y⟧) (α : f ==> g) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[f] yy) (gg : xx -->[g] yy), (ff ==>[α] gg) → (morFF x y f xx yy ff ==>[##F α] morFF x y g xx yy gg)) (disp_psfunctor_id : ∏ (x : B₁) (xx : D₁ x), disp_invertible_2cell (psfunctor_id F x) (id_disp (obFF x xx)) (morFF x x (id₁ x) xx xx (id_disp xx))) (disp_psfunctor_comp : ∏ (x y z : B₁) (f : x --> y) (g : y --> z) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[f] yy) (gg : yy -->[g] zz), disp_invertible_2cell (psfunctor_comp F f g) (comp_disp (morFF x y f xx yy ff) (morFF y z g yy zz gg)) (morFF x z (f · g) xx zz (comp_disp ff gg))) : disp_psfunctor_data := (obFF,, morFF,, cellFF,, disp_psfunctor_id,, disp_psfunctor_comp). Definition disp_psfunctor_ob (FFdata : disp_psfunctor_data) {x : B₁} (xx : D₁ x) : D₂ (F x) := pr1 FFdata x xx. Coercion disp_psfunctor_ob : disp_psfunctor_data >-> Funclass. Section Projections. Variable (FFdata : disp_psfunctor_data). Definition disp_psfunctor_mor {x y : B₁} {f : B₁⟦x,y⟧} {xx : D₁ x} {yy : D₁ y} (ff : xx -->[f] yy) : FFdata x xx -->[#F f] FFdata y yy := pr12 FFdata x y f xx yy ff. Definition disp_psfunctor_cell {x y : B₁} {f g : B₁⟦x,y⟧} {α : f ==> g} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[f] yy} {gg : xx -->[g] yy} (αα : ff ==>[α] gg) : disp_psfunctor_mor ff ==>[##F α] disp_psfunctor_mor gg := pr122 FFdata x y f g α xx yy ff gg αα. Definition disp_psfunctor_id {x : B₁} (xx : D₁ x) : disp_invertible_2cell (psfunctor_id F x) (id_disp (FFdata x xx)) (disp_psfunctor_mor (id_disp xx)) := pr122 (pr2 FFdata) x xx. Definition disp_psfunctor_comp {x y z : B₁} {f : x --> y} {g : y --> z} {xx : D₁ x} {yy : D₁ y} {zz : D₁ z} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : disp_invertible_2cell (psfunctor_comp F f g) (comp_disp (disp_psfunctor_mor ff) (disp_psfunctor_mor gg)) (disp_psfunctor_mor (comp_disp ff gg)) := pr222 (pr2 FFdata) x y z f g xx yy zz ff gg. End Projections. Definition total_psfunctor_data (FFdata : disp_psfunctor_data) : psfunctor_data (total_bicat D₁) (total_bicat D₂). Proof. use make_psfunctor_data. - exact (λ x, (F (pr1 x),, FFdata _ (pr2 x))). - exact (λ x y f, (#F (pr1 f) ,, disp_psfunctor_mor FFdata (pr2 f))). - exact (λ x y f g α, (##F (pr1 α),, disp_psfunctor_cell FFdata (pr2 α))). - exact (λ x, iso_in_E_weq _ _ (psfunctor_id F (pr1 x),, disp_psfunctor_id FFdata (pr2 x))). - refine (λ x y z f g, iso_in_E_weq _ _ _). exact (psfunctor_comp F (pr1 f) (pr1 g),, disp_psfunctor_comp FFdata (pr2 f) (pr2 g)). Defined. (** *** Properties *) Section DispPseudofunctorLaws. Variable FFdata : disp_psfunctor_data. Definition disp_psfunctor_id2_law : UU := ∏ (a b : B₁) (f : a --> b) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[f] bb), disp_psfunctor_cell FFdata (disp_id2 ff) = transportb (λ p : # F f ==> # F f, disp_psfunctor_mor FFdata ff ==>[p] disp_psfunctor_mor FFdata ff) (psfunctor_id2 F f) (disp_id2 (disp_psfunctor_mor FFdata ff)). Definition disp_psfunctor_vcomp2_law : UU := ∏ (a b : B₁) (f g h : B₁ ⟦a, b⟧) (η : f ==> g) (φ : g ==> h) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (hh : aa -->[h] bb) (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh), disp_psfunctor_cell FFdata (ηη •• φφ) = transportb (λ p : # F f ==> # F h, disp_psfunctor_mor FFdata ff ==>[ p] disp_psfunctor_mor FFdata hh) (psfunctor_vcomp F η φ) (disp_psfunctor_cell FFdata ηη •• disp_psfunctor_cell FFdata φφ). Definition disp_psfunctor_lunitor_law : UU := ∏ (a b : B₁) (f : B₁ ⟦ a, b ⟧) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[ f] bb), disp_lunitor (disp_psfunctor_mor FFdata ff) = transportb (λ p, _ ==>[p] _) (psfunctor_lunitor F f) (((disp_psfunctor_id FFdata aa ▹▹ disp_psfunctor_mor FFdata ff) •• disp_psfunctor_comp FFdata (id_disp aa) ff) •• disp_psfunctor_cell FFdata (disp_lunitor ff)). Definition disp_psfunctor_runitor_law : UU := ∏ (a b : B₁) (f : B₁ ⟦ a, b ⟧) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[ f] bb), disp_runitor (disp_psfunctor_mor FFdata ff) = transportb (λ p, _ ==>[p] _) (psfunctor_runitor F f) (((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_id FFdata _) •• disp_psfunctor_comp FFdata _ _) •• disp_psfunctor_cell FFdata (disp_runitor ff)). Definition disp_psfunctor_lassociator_law : UU := ∏ (a b c d : B₁) (f : B₁ ⟦ a, b ⟧) (g : B₁ ⟦ b, c ⟧) (h : B₁ ⟦ c, d ⟧) (aa : D₁ a) (bb : D₁ b) (cc : D₁ c) (dd : D₁ d) (ff : aa -->[ f] bb) (gg : bb -->[ g] cc) (hh : cc -->[ h] dd), ((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_comp FFdata gg hh) •• disp_psfunctor_comp FFdata ff (gg;; hh)) •• disp_psfunctor_cell FFdata (disp_lassociator ff gg hh) = transportb (λ p, _ ==>[p] _) (psfunctor_lassociator F f g h) ((disp_lassociator (disp_psfunctor_mor FFdata ff) (disp_psfunctor_mor FFdata gg) (disp_psfunctor_mor FFdata hh) •• (disp_psfunctor_comp FFdata ff gg ▹▹ disp_psfunctor_mor FFdata hh)) •• disp_psfunctor_comp FFdata (ff;; gg) hh). Definition disp_psfunctor_lwhisker_law : UU := ∏ (a b c : B₁) (f : B₁ ⟦ a, b ⟧) (g₁ g₂ : B₁ ⟦ b, c ⟧) (η : g₁ ==> g₂) (aa : D₁ a) (bb : D₁ b) (cc : D₁ c) (ff : aa -->[ f] bb) (gg₁ : bb -->[ g₁] cc) (gg₂ : bb -->[ g₂] cc) (ηη : gg₁ ==>[ η] gg₂), disp_psfunctor_comp FFdata ff gg₁ •• disp_psfunctor_cell FFdata (ff ◃◃ ηη) = transportb (λ p, _ ==>[p] _) (psfunctor_lwhisker F f η) ((disp_psfunctor_mor FFdata ff ◃◃ disp_psfunctor_cell FFdata ηη) •• disp_psfunctor_comp FFdata ff gg₂). Definition disp_psfunctor_rwhisker_law : UU := ∏ (a b c : B₁) (f₁ f₂ : B₁ ⟦ a, b ⟧) (g : B₁ ⟦ b, c ⟧) (η : f₁ ==> f₂) (aa : D₁ a) (bb : D₁ b) (cc : D₁ c) (ff₁ : aa -->[f₁] bb) (ff₂ : aa -->[f₂] bb) (gg : bb -->[g] cc) (ηη : ff₁ ==>[ η] ff₂), disp_psfunctor_comp FFdata _ _ •• disp_psfunctor_cell FFdata (ηη ▹▹ gg) = transportb (λ p, _ ==>[p] _) (psfunctor_rwhisker F g η) ((disp_psfunctor_cell FFdata ηη ▹▹ _) •• disp_psfunctor_comp FFdata _ _). Definition is_disp_psfunctor : UU := disp_psfunctor_id2_law × disp_psfunctor_vcomp2_law × disp_psfunctor_lunitor_law × disp_psfunctor_runitor_law × disp_psfunctor_lassociator_law × disp_psfunctor_lwhisker_law × disp_psfunctor_rwhisker_law. Definition disp_psfunctor_id2 (H : is_disp_psfunctor) := pr1 H. Definition disp_psfunctor_vcomp2 (H : is_disp_psfunctor) := pr12 H. Definition disp_psfunctor_vcomp2_alt (H : is_disp_psfunctor) (a b : B₁) (f g h : B₁ ⟦a, b⟧) (η : f ==> g) (φ : g ==> h) (aa : D₁ a) (bb : D₁ b) (ff : aa -->[f] bb) (gg : aa -->[g] bb) (hh : aa -->[h] bb) (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) : transportf (λ p : # F f ==> # F h, disp_psfunctor_mor FFdata ff ==>[ p] disp_psfunctor_mor FFdata hh) (psfunctor_vcomp F η φ) (disp_psfunctor_cell FFdata (ηη •• φφ)) = disp_psfunctor_cell FFdata ηη •• disp_psfunctor_cell FFdata φφ. Proof. refine (transportf_transpose_left (P := λ p, _ ==>[p] _) _). apply (disp_psfunctor_vcomp2 H). Qed. End DispPseudofunctorLaws. (** *** Disp pseudofunct *) Definition disp_psfunctor : UU := ∑ FF : disp_psfunctor_data, is_disp_psfunctor FF. Coercion disp_psfunctor_to_disp_psfunctor_data (FF : disp_psfunctor) : disp_psfunctor_data := pr1 FF. Lemma total_psfunctor_laws (FF : disp_psfunctor) : psfunctor_laws (total_psfunctor_data FF). Proof. repeat apply make_dirprod; intro; intros; (use total2_paths_b; [ apply F | apply FF ]). Qed. Definition total_psfunctor (FF : disp_psfunctor) : psfunctor (total_bicat D₁) (total_bicat D₂). Proof. use make_psfunctor. - exact (total_psfunctor_data FF). - exact (total_psfunctor_laws FF). - split; intros; use iso_in_E_weq. Defined. Definition is_disp_psfunctor_from_total (FF : disp_psfunctor_data) : is_psfunctor (total_psfunctor_data FF) → is_disp_psfunctor FF. Proof. intros HFF. pose (EF := make_psfunctor _ (pr1 HFF) (pr2 HFF)). repeat split. - intros a b f aa bb ff. pose (P := !fiber_paths (@psfunctor_id2 _ _ EF (a,,aa) (b,,bb) (f,,ff))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b f g h η φ aa bb ff gg hh ηη φφ. pose (P := !fiber_paths (@psfunctor_vcomp _ _ EF (a,,aa) (b,,bb) (f,,ff) (g,,gg) (h,,hh) (η,,ηη) (φ,,φφ))). cbn in P; rewrite P. unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b f aa bb ff. pose (P := !fiber_paths (@psfunctor_lunitor _ _ EF (a,,aa) (b,,bb) (f,,ff))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b f aa bb ff. pose (P := !fiber_paths (@psfunctor_runitor _ _ EF (a,,aa) (b,,bb) (f,,ff))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b c d f g h aa bb cc dd ff gg hh. pose (P := !fiber_paths (@psfunctor_lassociator _ _ EF (a,,aa) (b,,bb) (c,,cc) (d,,dd) (f,,ff) (g,,gg) (h,,hh))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b c f g1 g2 η aa bb cc ff gg1 gg2 ηη. pose (P := !fiber_paths (@psfunctor_lwhisker _ _ EF (a,,aa) (b,,bb) (c,,cc) (f,,ff) (g1,,gg1) (g2,,gg2) (η,,ηη))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros a b c f1 f2 g η aa bb cc ff1 ff2 gg ηη. pose (P := !fiber_paths (@psfunctor_rwhisker _ _ EF (a,,aa) (b,,bb) (c,,cc) (f1,,ff1) (f2,,ff2) (g,,gg) (η,,ηη))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. Qed. End DispPseudofunctor. (** ** Identity *) Section DispPseudofunctor_identity. Context {B : bicat} (D : disp_bicat B). Definition disp_pseudo_id_data : disp_psfunctor_data D D (id_psfunctor B). Proof. use make_disp_psfunctor_data; cbn. - exact (λ _ y, y). - exact (λ _ _ _ _ _ ff, ff). - exact (λ _ _ _ _ _ _ _ _ _ αα, αα). - intros. apply disp_id2_invertible_2cell. - intros. apply disp_id2_invertible_2cell. Defined. Lemma disp_pseudo_id_laws : is_disp_psfunctor D D _ disp_pseudo_id_data. Proof. apply is_disp_psfunctor_from_total. apply id_psfunctor. Qed. Definition disp_pseudo_id : disp_psfunctor D D (id_psfunctor B) := disp_pseudo_id_data,, disp_pseudo_id_laws. End DispPseudofunctor_identity. Definition disp_psfunctor_cell_transportb {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) {x y : B₁} {f : x --> y} {φ ψ : f ==> f} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[f] yy} (p : φ = ψ) (ψψ : ff ==>[ ψ ] ff) : disp_psfunctor_cell _ _ _ (pr1 FF) (transportb (λ z, ff ==>[ z ] ff) p ψψ) = transportb (λ z, _ ==>[ z ] _) (maponpaths (λ z, ##F z) p) (disp_psfunctor_cell _ _ _ (pr1 FF) ψψ). Proof. induction p. cbn. apply idpath. Defined. Definition disp_psfunctor_cell_transportf {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) {x y : B₁} {f g : x --> y} {φ ψ : f ==> g} (p : φ = ψ) {xx : D₁ x} {yy : D₁ y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (φφ : ff ==>[ φ ] gg) : disp_psfunctor_cell _ _ _ (pr1 FF) (transportf (λ z, ff ==>[ z ] gg) p φφ) = transportf (λ z, _ ==>[ z ] _) (maponpaths (## F) p) (disp_psfunctor_cell _ _ _ (pr1 FF) φφ). Proof. induction p ; cbn. apply idpath. Qed. Section DispPseudofunctorInvertible_2cell. Context {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) {x y : B₁} {f g : x --> y} {α : invertible_2cell f g} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[f] yy} {gg : xx -->[g] yy} (αα : disp_invertible_2cell α ff gg). Definition disp_psfunctor_invertible_2cell : disp_invertible_2cell (_,, psfunctor_is_iso F α) (disp_psfunctor_mor _ _ _ FF ff) (disp_psfunctor_mor _ _ _ FF gg). Proof. repeat use tpair; cbn. - exact (disp_psfunctor_cell _ _ _ FF αα). - exact (disp_psfunctor_cell _ _ _ FF (disp_inv_cell αα)). - abstract (rewrite <- (disp_psfunctor_vcomp2_alt _ _ _ _ (pr2 FF)); rewrite disp_vcomp_rinv; rewrite disp_psfunctor_cell_transportb; unfold transportb; rewrite transport_f_f; rewrite (disp_psfunctor_id2 _ _ _ _ (pr2 FF)); unfold transportb; rewrite transport_f_f; apply (@transportf_paths _ (λ p, _ ==>[ p ] _)); apply B₂). - abstract (rewrite <- (disp_psfunctor_vcomp2_alt _ _ _ _ (pr2 FF)); rewrite disp_vcomp_linv; rewrite disp_psfunctor_cell_transportb; unfold transportb; rewrite transport_f_f; rewrite (disp_psfunctor_id2 _ _ _ _ (pr2 FF)); unfold transportb; rewrite transport_f_f; apply (@transportf_paths _ (λ p, _ ==>[ p ] _)); apply B₂). Defined. End DispPseudofunctorInvertible_2cell. (** ** Composition *) Section DispPseudofunctor_comp. Context {B₁ B₂ B₃ : bicat} (F₁ : psfunctor B₁ B₂) (F₂ : psfunctor B₂ B₃) (D₁ : disp_bicat B₁) (D₂ : disp_bicat B₂) (D₃ : disp_bicat B₃) (FF₁ : disp_psfunctor D₁ D₂ F₁) (FF₂ : disp_psfunctor D₂ D₃ F₂). Definition disp_pseudo_comp_data : disp_psfunctor_data D₁ D₃ (comp_psfunctor F₂ F₁). Proof. use make_disp_psfunctor_data; cbn. - exact (λ x xx, FF₂ _ (FF₁ _ xx)). - exact (λ x y f xx yy ff, disp_psfunctor_mor _ _ _ FF₂ (disp_psfunctor_mor _ _ _ FF₁ ff)). - exact (λ x y f g α xx yy ff gg αα, disp_psfunctor_cell _ _ _ FF₂ (disp_psfunctor_cell _ _ _ FF₁ αα)). - intros x xx. exact (vcomp_disp_invertible (disp_psfunctor_id _ _ _ FF₂ (FF₁ _ xx)) (disp_psfunctor_invertible_2cell FF₂ (disp_psfunctor_id _ _ _ FF₁ xx))). - intros x y z f g xx yy zz ff gg. exact (vcomp_disp_invertible (disp_psfunctor_comp _ _ _ FF₂ (disp_psfunctor_mor _ _ _ FF₁ ff) (disp_psfunctor_mor _ _ _ FF₁ gg)) (disp_psfunctor_invertible_2cell FF₂ (disp_psfunctor_comp _ _ _ FF₁ ff gg))). Defined. Lemma disp_pseudo_comp_laws : is_disp_psfunctor _ _ _ disp_pseudo_comp_data. Proof. apply is_disp_psfunctor_from_total. apply (comp_psfunctor (total_psfunctor _ _ _ FF₂) (total_psfunctor _ _ _ FF₁)). Qed. Definition disp_pseudo_comp : disp_psfunctor _ _ (comp_psfunctor F₂ F₁) := disp_pseudo_comp_data,, disp_pseudo_comp_laws. End DispPseudofunctor_comp. (** Fiber of a pseudofunctor *) Local Open Scope mor_disp_scope. Definition transportb_disp_psfunctor {C : bicat} (HC : is_univalent_2_1 C) (D₁ : disp_bicat C) (D₂ : disp_bicat C) (F : disp_psfunctor D₁ D₂ (id_psfunctor C)) {x y : C} {f g : x --> y} {xx : D₁ x} {yy : D₁ y} (ff : xx -->[ f ] yy) (p : g = f) : transportb (mor_disp ((pr11 F) x xx) ((pr11 F) y yy)) p ((pr121 F) _ _ _ xx yy ff) = (pr121 F) x y g xx yy (transportb (mor_disp xx yy) p ff). Proof. induction p. apply idpath. Defined. Section FiberOfFunctor. Context {C : bicat} (HC : is_univalent_2_1 C) {D₁ : disp_bicat C} (HD₁ : disp_2cells_isaprop D₁) (HD₁_2_1 : disp_univalent_2_1 D₁) (h₁ : local_iso_cleaving D₁) {D₂ : disp_bicat C} (HD₂ : disp_2cells_isaprop D₂) (HD₂_2_1 : disp_univalent_2_1 D₂) (h₂ : local_iso_cleaving D₂) (F : disp_psfunctor D₁ D₂ (id_psfunctor C)). Definition fiber_functor_data (c : C) : functor_data (discrete_fiber_category D₁ HD₁ HD₁_2_1 h₁ c) (discrete_fiber_category D₂ HD₂ HD₂_2_1 h₂ c). Proof. use make_functor_data. - exact (pr11 F c). - exact (pr121 F c c (id₁ c)). Defined. Definition fiber_is_functor (c : C) : is_functor (fiber_functor_data c). Proof. split. - intros x. exact (!(disp_isotoid_2_1 _ HD₂_2_1 (idpath _) _ _ (pr12 (pr221 F) c x))). - intros x y z f g ; cbn. pose ((disp_isotoid_2_1 _ HD₂_2_1 (idpath _) _ _ (pr22 (pr221 F) c c c (id₁ c) (id₁ c) x y z f g))) as p. cbn in p. rewrite p ; clear p. pose (disp_local_iso_cleaving_invertible_2cell h₂ ((pr121 F) c c (id₁ c · id₁ c) x z (f;; g)) (idempunitor c)) as p1. pose (disp_local_iso_cleaving_invertible_2cell h₁ (f;; g) (idempunitor c)) as p2. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (idempunitor c)) in p1, p2. etrans. { apply maponpaths. pose (transportb_transpose_right (disp_isotoid_2_1 D₁ HD₁_2_1 _ _ _ p2)) as p. rewrite idtoiso_2_1_isotoid_2_1 in p. exact p. } clear p2. refine (!_). etrans. { pose (transportb_transpose_right (disp_isotoid_2_1 D₂ HD₂_2_1 _ _ _ p1)) as p. rewrite idtoiso_2_1_isotoid_2_1 in p. exact p. } clear p1. apply transportb_disp_psfunctor. exact HC. Qed. Definition fiber_functor (c : C) : discrete_fiber_category D₁ HD₁ HD₁_2_1 h₁ c ⟶ discrete_fiber_category D₂ HD₂ HD₂_2_1 h₂ c. Proof. use make_functor. - exact (fiber_functor_data c). - exact (fiber_is_functor c). Defined. End FiberOfFunctor. Definition disp_psfunctor_id_on_disp_adjequiv {B : bicat} {D₁ D₂ : disp_bicat B} (FF : disp_psfunctor D₁ D₂ (id_psfunctor _)) {x y : B} {f : adjoint_equivalence x y} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[ f ] yy} (Hff : disp_left_adjoint_equivalence f ff) : disp_left_adjoint_equivalence _ (disp_psfunctor_mor _ _ _ FF ff) := pr2 (left_adjoint_equivalence_total_disp_weq _ _ (psfunctor_preserves_adjequiv' (total_psfunctor _ _ _ FF) (invmap (left_adjoint_equivalence_total_disp_weq f ff) (pr2 f ,, Hff)))). UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispToFiberEquivalence.v000066400000000000000000000246071451125700300270540ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Displayed biequivalences give rise to equivalences on the fiber. This requires that the involved displayed bicategoies have propositions as displayed 2-cells, are locally groupoidal, and locally univalent. ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Require Import UniMath.Bicategories.DisplayedBicats.DispBiequivalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition local_iso_cleaving_id {C : bicat} (HC : is_univalent_2_1 C) {D : disp_bicat C} (HD_2_1 : disp_univalent_2_1 D) (h : local_iso_cleaving D) (c : C) {xx : D c} (p : xx -->[ id₁ c · id₁ c] xx) (α : disp_invertible_2cell (idempunitor c) (id_disp xx) p) : local_iso_cleaving_1cell h p (idempunitor c) = id_disp xx. Proof. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (idempunitor c)) in α. rewrite (transportb_transpose_right (disp_isotoid_2_1 _ HD_2_1 _ _ _ α)). pose (disp_local_iso_cleaving_invertible_2cell h p (idempunitor c)) as d. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (idempunitor c)) in d. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (idempunitor c)). rewrite (transportb_transpose_right (disp_isotoid_2_1 _ HD_2_1 _ _ _ d)). rewrite idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Section FiberOfBiequiv. Context {C : bicat} (HC : is_univalent_2_1 C) {D₁ : disp_bicat C} (HD₁ : disp_2cells_isaprop D₁) (LGD₁ : disp_locally_groupoid D₁) (HD₁_2_1 : disp_univalent_2_1 D₁) (h₁ : local_iso_cleaving D₁) {D₂ : disp_bicat C} (HD₂ : disp_2cells_isaprop D₂) (LGD₂ : disp_locally_groupoid D₂) (HD₂_2_1 : disp_univalent_2_1 D₂) (h₂ : local_iso_cleaving D₂) {F : disp_psfunctor D₁ D₂ (id_psfunctor C)} {G : disp_psfunctor D₂ D₁ (id_psfunctor C)} (E : is_disp_biequivalence_unit_counit _ _ (id_is_biequivalence C) F G) (EE : disp_is_biequivalence_data _ _ (id_is_biequivalence C) E) (c : C). Local Notation "'FF'" := (fiber_functor HC HD₁ HD₁_2_1 h₁ HD₂ HD₂_2_1 h₂ F c). Local Notation "'GG'" := (fiber_functor HC HD₂ HD₂_2_1 h₂ HD₁ HD₁_2_1 h₁ G c). Definition help_equation : ((((((rinvunitor (id₁ c)) • (id₁ c ◃ linvunitor (id₁ c))) • lassociator (id₁ c) (id₁ c) (id₁ c)) • ((((lunitor (id₁ c) • rinvunitor (id₁ c)) • (id₁ c ◃ linvunitor (id₁ c))) • lassociator (id₁ c) (id₁ c) (id₁ c)) ▹ id₁ c)) • rassociator (id₁ c · id₁ c) (id₁ c) (id₁ c)) • (id₁ c · id₁ c ◃ lunitor (id₁ c))) • runitor (id₁ c · id₁ c) = linvunitor (id₁ c). Proof. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply maponpaths. rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. rewrite !vassocl. apply id2_left. } use vcomp_move_R_pM. { is_iso. } cbn. rewrite runitor_lunitor_identity. rewrite lunitor_linvunitor. rewrite lwhisker_hcomp. rewrite !vassocr. rewrite triangle_l_inv. rewrite <- !rwhisker_hcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } use vcomp_move_R_pM. { is_iso. } cbn. rewrite id2_right. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } cbn. rewrite runitor_rwhisker. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite <- runitor_triangle. rewrite runitor_lunitor_identity. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Qed. Definition fiber_unit_is_nat_trans : is_nat_trans (FF ∙ GG) (functor_identity _) (λ z, unit_of_is_disp_biequivalence _ _ E c z). Proof. intros z₁ z₂ f. refine (maponpaths (λ z, local_iso_cleaving_1cell h₁ z (idempunitor c)) _). cbn. pose (disp_psnaturality_of _ _ _ (unit_of_is_disp_biequivalence D₁ D₂ E) f) as d. simpl in d. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (psnaturality_of (lunitor_pstrans (id_psfunctor C)) (id₁ c))) in d. pose (transportb_transpose_right (disp_isotoid_2_1 _ HD₁_2_1 _ _ _ d)) as p. refine (_ @ !p). clear d p. refine (!_). assert (isotoid_2_1 HC (psnaturality_of (lunitor_pstrans (id_psfunctor C)) (id₁ c)) = idpath _) as X. { cbn. refine (_ @ isotoid_2_1_idtoiso_2_1 HC _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. apply idpath. } rewrite X. apply idpath. Qed. Definition fiber_unit : nat_trans (FF ∙ GG) (functor_identity _) := _ ,, fiber_unit_is_nat_trans. Definition fiber_unit_nat_z_iso : is_nat_z_iso fiber_unit. Proof. intros z. exists (pr1 EE c z). split. + apply local_iso_cleaving_id. * exact HC. * exact HD₁_2_1. * use tpair. ** apply ((pr12 (pr122 EE)) c z). ** apply (LGD₁ _ _ _ _ (_ ,, is_invertible_2cell_linvunitor (id₁ c))). + apply local_iso_cleaving_id. * exact HC. * exact HD₁_2_1. * use tpair. ** pose ((pr111 (pr22 EE)) c z) as m. simpl in m. pose (disp_inv_cell m) as d. refine (transportf (λ z, _ ==>[ z ] _) _ d). exact help_equation. ** apply LGD₁. Qed. Definition fiber_unit_z_iso : nat_z_iso (FF ∙ GG) (functor_identity _). Proof. use tpair. 2: { apply fiber_unit_nat_z_iso. } Defined. Definition fiber_counit_is_nat_trans : is_nat_trans (GG ∙ FF) (functor_identity _) (λ z, counit_of_is_disp_biequivalence _ _ E c z). Proof. intros z₁ z₂ f. refine (maponpaths (λ z, local_iso_cleaving_1cell h₂ z (idempunitor c)) _). cbn. pose (disp_psnaturality_of _ _ _ (counit_of_is_disp_biequivalence D₁ D₂ E) f) as d. simpl in d. rewrite <- (idtoiso_2_1_isotoid_2_1 HC (psnaturality_of (lunitor_pstrans (id_psfunctor C)) (id₁ c))) in d. pose (transportb_transpose_right (disp_isotoid_2_1 _ HD₂_2_1 _ _ _ d)) as p. refine (_ @ !p). clear d p. refine (!_). assert (isotoid_2_1 HC (psnaturality_of (lunitor_pstrans (id_psfunctor C)) (id₁ c)) = idpath _) as X. { cbn. refine (_ @ isotoid_2_1_idtoiso_2_1 HC _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. apply idpath. } rewrite X. apply idpath. Qed. Definition fiber_counit : nat_trans (GG ∙ FF) (functor_identity _) := _ ,, fiber_counit_is_nat_trans. Definition fiber_counit_nat_z_iso : is_nat_z_iso fiber_counit. Proof. intros z. exists (pr12 EE c z). split. + apply local_iso_cleaving_id. * exact HC. * exact HD₂_2_1. * use tpair. ** apply (pr12 (pr222 EE) c z). ** apply (LGD₂ _ _ _ _ (_ ,, is_invertible_2cell_linvunitor (id₁ c))). + apply local_iso_cleaving_id. * exact HC. * exact HD₂_2_1. * use tpair. ** pose (pr11 (pr222 EE) c z) as m; simpl in m. simpl in m. pose (disp_inv_cell m) as d. refine (transportf (λ z, _ ==>[ z ] _) _ d). exact help_equation. ** apply LGD₂. Qed. Definition fiber_counit_z_iso : nat_z_iso (GG ∙ FF) (functor_identity _). Proof. use tpair. 2: { apply fiber_counit_nat_z_iso. } Defined. Definition fiber_equivalence : equivalence_of_cats (discrete_fiber_category D₁ HD₁ HD₁_2_1 h₁ c) (discrete_fiber_category D₂ HD₂ HD₂_2_1 h₂ c). Proof. simple refine ((FF ,, (GG ,, (_ ,, _))) ,, (_ ,, _)). - exact (pr1 (nat_z_iso_inv fiber_unit_z_iso)). - exact (pr1 fiber_counit_z_iso). - exact (pr2 (nat_z_iso_inv fiber_unit_z_iso)). - exact (pr2 fiber_counit_z_iso). Defined. End FiberOfBiequiv. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispTransformation.v000066400000000000000000000624671451125700300263540ustar00rootroot00000000000000(* ------------------------------------------------------------------------- *) (** Displayed transformation. Contents: - Definition of displayed transformation. - Identity and composition of displayed transformations. *) (* ------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Whiskering. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Import PseudoFunctor.Notations. Local Open Scope cat. (** ** Definition of displayed transformation. *) Section DispTransformation. Context {B₁ : bicat} {D₁ : disp_bicat B₁} {B₂ : bicat} {D₂ : disp_bicat B₂} {F₁ F₂ : psfunctor B₁ B₂} (FF₁ : disp_psfunctor D₁ D₂ F₁) (FF₂ : disp_psfunctor D₁ D₂ F₂) (α : pstrans F₁ F₂). (** *** Data *) Definition disp_pstrans_data : UU := ∑ αα₁ : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx, ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy), disp_invertible_2cell (psnaturality_of α f) (αα₁ x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα₁ y yy). Definition make_disp_pstrans_data (αα₁ : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx) (αα₂ : ∏ (x y : B₁) (f : B₁ ⟦ x, y ⟧) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy), disp_invertible_2cell (psnaturality_of α f) (αα₁ x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα₁ y yy)) : disp_pstrans_data := (αα₁,, αα₂). Definition disp_pscomponent_of (αα : disp_pstrans_data) : ∏ (x : B₁) (xx : D₁ x), FF₁ x xx -->[ α x] FF₂ x xx := pr1 αα. Coercion disp_pscomponent_of : disp_pstrans_data >-> Funclass. Definition disp_psnaturality_of (αα : disp_pstrans_data) {x y : B₁} {f : B₁ ⟦ x, y ⟧} {xx : D₁ x} {yy : D₁ y} (ff : xx -->[ f] yy) : disp_invertible_2cell (psnaturality_of α f) (αα x xx;; disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff;; αα y yy) := pr2 αα x y f xx yy ff. Definition total_pstrans_data (ααdata : disp_pstrans_data) : pstrans_data (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂). Proof. use make_pstrans_data. - exact (λ x, (α (pr1 x),, ααdata _ (pr2 x))). - exact (λ x y f, iso_in_E_weq _ _ (psnaturality_of α (pr1 f),, disp_psnaturality_of ααdata (pr2 f))). Defined. (** *** Properties *) Section DispPstransLaws. Variable ααdata : disp_pstrans_data. Definition disp_psnaturality_natural_law : UU := ∏ (x y : B₁) (f g : B₁ ⟦ x, y ⟧) (η : f ==> g) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f] yy) (gg : xx -->[ g] yy) (ηη : ff ==>[ η] gg), (ααdata x xx ◃◃ disp_psfunctor_cell D₁ D₂ F₂ FF₂ ηη) •• disp_psnaturality_of ααdata gg = transportb (λ p, _ ==>[p] _) (psnaturality_natural α x y f g η) (disp_psnaturality_of ααdata ff •• (disp_psfunctor_cell D₁ D₂ F₁ FF₁ ηη ▹▹ ααdata y yy)). Definition disp_pstrans_id_law : UU := ∏ (x : B₁) (xx : D₁ x), (ααdata x xx ◃◃ disp_psfunctor_id D₁ D₂ F₂ FF₂ xx) •• disp_psnaturality_of ααdata (id_disp xx) = transportb (λ p, _ ==>[p] _) (pstrans_id α x) ((disp_runitor (ααdata x xx) •• disp_linvunitor (ααdata x xx)) •• (disp_psfunctor_id D₁ D₂ F₁ FF₁ xx ▹▹ ααdata x xx)). Definition disp_pstrans_comp_law : UU := ∏ (x y z : B₁) (f : B₁ ⟦ x, y ⟧) (g : B₁ ⟦ y, z ⟧) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[ f] yy) (gg : yy -->[ g] zz), (ααdata x xx ◃◃ disp_psfunctor_comp D₁ D₂ F₂ FF₂ ff gg) •• disp_psnaturality_of ααdata (ff;; gg) = transportb (λ p, _ ==>[p] _) (pstrans_comp α f g) (((((disp_lassociator (ααdata x xx) (disp_psfunctor_mor D₁ D₂ F₂ FF₂ ff) (disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg) •• (disp_psnaturality_of ααdata ff ▹▹ disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg)) •• disp_rassociator (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff) (ααdata y yy) (disp_psfunctor_mor D₁ D₂ F₂ FF₂ gg)) •• (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff ◃◃ disp_psnaturality_of ααdata gg)) •• disp_lassociator (disp_psfunctor_mor D₁ D₂ F₁ FF₁ ff) (disp_psfunctor_mor D₁ D₂ F₁ FF₁ gg) (ααdata z zz)) •• (disp_psfunctor_comp D₁ D₂ F₁ FF₁ ff gg ▹▹ ααdata z zz)). Definition is_disp_pstrans : UU := disp_psnaturality_natural_law × disp_pstrans_id_law × disp_pstrans_comp_law. End DispPstransLaws. (** *** Displayed transformation *) Definition disp_pstrans : UU := ∑ αα : disp_pstrans_data, is_disp_pstrans αα. Coercion disp_pstrans_to_disp_pstrans_data (αα : disp_pstrans) : disp_pstrans_data := pr1 αα. Lemma total_pstrans_laws (αα : disp_pstrans) : is_pstrans (total_pstrans_data αα). Proof. repeat apply make_dirprod; intro; intros. - use total2_paths_b; [apply (psnaturality_natural α) | apply αα]. - use total2_paths_b; [apply (pstrans_id α) | apply αα]. - use total2_paths_b. 2: apply αα. Qed. Definition total_pstrans (αα : disp_pstrans) : pstrans (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂). Proof. use make_pstrans. - exact (total_pstrans_data αα). - exact (total_pstrans_laws αα). Defined. Definition is_disp_pstrans_from_total (αα : disp_pstrans_data) : is_pstrans (total_pstrans_data αα) → is_disp_pstrans αα. Proof. intros Hαα. pose (Eα := make_pstrans _ Hαα). repeat split. - intros x y f g η xx yy ff gg ηη. pose (P := !fiber_paths (@psnaturality_natural _ _ _ _ Eα (x,,xx) (y,,yy) (f,,ff) (g,,gg) (η,,ηη))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros x xx. pose (P := !fiber_paths (@pstrans_id _ _ _ _ Eα (x,,xx))). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. - intros x y z f g xx yy zz ff gg. pose (P := !fiber_paths (@pstrans_comp _ _ _ _ Eα (x,,xx) (y,,yy) (z,,zz) (f,,ff) (g,,gg) )). symmetry. etrans. { apply maponpaths. exact P. } unfold transportb. rewrite transport_f_f. rewrite transportf_set. * apply idpath. * apply B₂. Qed. End DispTransformation. (** ** Identity *) Section DispTrans_identity. Context {B₁ B₂ : bicat} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {F : psfunctor B₁ B₂} (FF : disp_psfunctor D₁ D₂ F). Definition disp_id_pstrans_data : disp_pstrans_data FF FF (id_pstrans F). Proof. use make_disp_pstrans_data; cbn. - exact (λ x xx, id_disp (FF x xx)). - intros. apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_id_pstrans_laws : is_disp_pstrans _ _ _ disp_id_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := id_pstrans (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (pr11 PP = total_pstrans_data FF FF (id_pstrans F) disp_id_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf _ X PP2). Qed. Definition disp_id_pstrans : disp_pstrans FF FF (id_pstrans F) := disp_id_pstrans_data,, disp_id_pstrans_laws. End DispTrans_identity. (** ** Composition *) Section DispTrans_comp. Context {B₁ B₂ : bicat} {F₁ : psfunctor B₁ B₂} {F₂ : psfunctor B₁ B₂} {F₃ : psfunctor B₁ B₂} {η₁ : pstrans F₁ F₂} {η₂ : pstrans F₂ F₃} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {FF₁ : disp_psfunctor D₁ D₂ F₁} {FF₂ : disp_psfunctor D₁ D₂ F₂} {FF₃ : disp_psfunctor D₁ D₂ F₃} (ηη₁ : disp_pstrans FF₁ FF₂ η₁) (ηη₂ : disp_pstrans FF₂ FF₃ η₂). Local Notation "αα '••' ββ" := (vcomp_disp_invertible αα ββ). Local Notation "ff '◃◃' αα" := (disp_invertible_2cell_lwhisker ff αα). Local Notation "αα '▹▹' ff" := (disp_invertible_2cell_rwhisker ff αα). Definition disp_comp_pstrans_data : disp_pstrans_data FF₁ FF₃ (comp_pstrans η₁ η₂). Proof. use make_disp_pstrans_data; cbn. - exact (λ x xx, comp_disp (ηη₁ x xx) (ηη₂ x xx)). - exact (λ x y f xx yy ff, (disp_invertible_2cell_rassociator _ _ _) •• (_ ◃◃ disp_psnaturality_of _ _ _ ηη₂ ff) •• disp_invertible_2cell_lassociator _ _ _ •• (disp_psnaturality_of _ _ _ ηη₁ ff ▹▹ _) •• disp_invertible_2cell_rassociator _ _ _). Defined. Lemma disp_comp_pstrans_laws : is_disp_pstrans _ _ _ disp_comp_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := comp_pstrans (total_pstrans _ _ _ ηη₁) (total_pstrans _ _ _ ηη₂)). pose (PP2 := pstrans_to_is_pstrans PP). assert (pr11 PP = total_pstrans_data _ _ _ disp_comp_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf _ X PP2). Qed. Definition disp_comp_pstrans : disp_pstrans _ _ (comp_pstrans η₁ η₂) := disp_comp_pstrans_data,, disp_comp_pstrans_laws. End DispTrans_comp. Definition disp_inv_invertible {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {α : invertible_2cell f g} {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (αα : disp_invertible_2cell α ff gg) : disp_invertible_2cell (inv_of_invertible_2cell α) gg ff. Proof. use tpair. - exact (disp_inv_cell αα). - use tpair. + apply αα. + split ; cbn. * apply disp_vcomp_linv. * apply disp_vcomp_rinv. Defined. Section DispTrans_lwhisker. Context {B₁ B₂ B₃ : bicat} {F₁ F₂ : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} {η : pstrans F₁ F₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {FF₁ : disp_psfunctor D₁ D₂ F₁} {FF₂ : disp_psfunctor D₁ D₂ F₂} (GG : disp_psfunctor D₂ D₃ G) (ηη : disp_pstrans FF₁ FF₂ η). Local Notation "αα '••' ββ" := (vcomp_disp_invertible αα ββ). Definition disp_left_whisker_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ FF₁ GG) (disp_pseudo_comp _ _ _ _ _ FF₂ GG) (G ◅ η). Proof. use make_disp_pstrans_data; cbn. - exact (λ x xx, pr121 GG _ _ _ _ _ (pr11 ηη x xx)). - exact (λ x y f xx yy ff, (disp_psfunctor_comp _ _ _ GG _ _) •• disp_psfunctor_invertible_2cell GG (disp_psnaturality_of _ _ _ ηη ff) •• (disp_inv_invertible (disp_psfunctor_comp _ _ _ GG _ _))). Defined. Lemma disp_left_whisker_laws : is_disp_pstrans _ _ _ disp_left_whisker_data. Proof. apply is_disp_pstrans_from_total. pose (PP := (total_psfunctor _ _ _ GG) ◅ total_pstrans _ _ _ ηη). pose (PP2 := pstrans_to_is_pstrans PP). assert (pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_left_whisker_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). (* Slow, dunno why *) Qed. Definition disp_left_whisker : disp_pstrans (disp_pseudo_comp _ _ _ _ _ FF₁ GG) (disp_pseudo_comp _ _ _ _ _ FF₂ GG) (G ◅ η) := disp_left_whisker_data,, disp_left_whisker_laws. End DispTrans_lwhisker. Section DispTrans_rwhisker. Context {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G₁ G₂ : psfunctor B₂ B₃} {η : pstrans G₁ G₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} (FF : disp_psfunctor D₁ D₂ F) {GG₁ : disp_psfunctor D₂ D₃ G₁} {GG₂ : disp_psfunctor D₂ D₃ G₂} (ηη : disp_pstrans GG₁ GG₂ η). Definition disp_right_whisker_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ FF GG₁) (disp_pseudo_comp _ _ _ _ _ FF GG₂) (η ▻ F). Proof. use make_disp_pstrans_data; cbn. - exact (λ x xx, (pr11 ηη _ (FF _ xx))). - exact (λ x y f xx yy ff, disp_psnaturality_of _ _ _ ηη (pr121 FF _ _ _ _ _ ff)). Defined. Lemma disp_right_whisker_laws : is_disp_pstrans _ _ _ disp_right_whisker_data. Proof. apply is_disp_pstrans_from_total. pose (PP := (total_pstrans _ _ _ ηη) ▻ (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_right_whisker_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } lazy. apply idpath. - exact (transportf is_pstrans X PP2). (* Also slow, dunno why *) Qed. Definition disp_right_whisker : disp_pstrans (disp_pseudo_comp _ _ _ _ _ FF GG₁) (disp_pseudo_comp _ _ _ _ _ FF GG₂) (η ▻ F) := disp_right_whisker_data,, disp_right_whisker_laws. End DispTrans_rwhisker. Section DispTransUnitality. Context {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F). Definition disp_lunitor_pstrans_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂)) FF (lunitor_pstrans F). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (FF x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_lunitor_pstrans_laws : is_disp_pstrans _ _ _ disp_lunitor_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := lunitor_pstrans (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_lunitor_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_lunitor_pstrans : disp_pstrans (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂)) FF (lunitor_pstrans F) := disp_lunitor_pstrans_data,, disp_lunitor_pstrans_laws. Definition disp_pstrans_linvunitor_data : disp_pstrans_data FF (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂)) (linvunitor_pstrans F). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (FF x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_pstrans_linvunitor_laws : is_disp_pstrans _ _ _ disp_pstrans_linvunitor_data. Proof. apply is_disp_pstrans_from_total. pose (PP := linvunitor_pstrans (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_pstrans_linvunitor_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_pstrans_linvunitor : disp_pstrans FF (disp_pseudo_comp _ _ _ _ _ FF (disp_pseudo_id D₂)) (linvunitor_pstrans F) := disp_pstrans_linvunitor_data,, disp_pstrans_linvunitor_laws. Definition disp_runitor_pstrans_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF) FF (runitor_pstrans F). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (FF x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_runitor_pstrans_laws : is_disp_pstrans _ _ _ disp_runitor_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := runitor_pstrans (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_runitor_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_runitor_pstrans : disp_pstrans (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF) FF (runitor_pstrans F) := disp_runitor_pstrans_data,, disp_runitor_pstrans_laws. Definition disp_rinvunitor_pstrans_data : disp_pstrans_data FF (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF) (rinvunitor_pstrans F). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (FF x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_rinvunitor_pstrans_laws : is_disp_pstrans _ _ _ disp_rinvunitor_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := rinvunitor_pstrans (total_psfunctor _ _ _ FF)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_rinvunitor_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_rinvunitor_pstrans : disp_pstrans FF (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_id D₁) FF) (rinvunitor_pstrans F) := disp_rinvunitor_pstrans_data,, disp_rinvunitor_pstrans_laws. End DispTransUnitality. Section DispTransAssociativiy. Context {B₁ B₂ B₃ B₄ : bicat} {F₁ : psfunctor B₁ B₂} {F₂ : psfunctor B₂ B₃} {F₃ : psfunctor B₃ B₄} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {D₃ : disp_bicat B₃} {D₄ : disp_bicat B₄} (FF₁ : disp_psfunctor D₁ D₂ F₁) (FF₂ : disp_psfunctor D₂ D₃ F₂) (FF₃ : disp_psfunctor D₃ D₄ F₃). Definition disp_lassociator_pstrans_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_comp _ _ _ _ _ FF₁ FF₂) FF₃ ) (disp_pseudo_comp _ _ _ _ _ FF₁ (disp_pseudo_comp _ _ _ _ _ FF₂ FF₃) ) (lassociator_pstrans F₁ F₂ F₃). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (_ x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_lassociator_pstrans_laws : is_disp_pstrans _ _ _ disp_lassociator_pstrans_data. Proof. apply is_disp_pstrans_from_total. pose (PP := lassociator_pstrans (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂) (total_psfunctor _ _ _ FF₃)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_lassociator_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_lassociator_pstrans : disp_pstrans (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_comp _ _ _ _ _ FF₁ FF₂) FF₃ ) (disp_pseudo_comp _ _ _ _ _ FF₁ (disp_pseudo_comp _ _ _ _ _ FF₂ FF₃) ) (lassociator_pstrans F₁ F₂ F₃) := disp_lassociator_pstrans_data,, disp_lassociator_pstrans_laws. Definition disp_pstrans_rassociator_data : disp_pstrans_data (disp_pseudo_comp _ _ _ _ _ FF₁ (disp_pseudo_comp _ _ _ _ _ FF₂ FF₃) ) (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_comp _ _ _ _ _ FF₁ FF₂) FF₃ ) (rassociator_pstrans F₁ F₂ F₃). Proof. use make_disp_pstrans_data. - exact (λ x xx, id_disp (_ x xx)). - cbn. refine (λ x y f xx yy ff, _). apply (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (disp_invertible_2cell_rinvunitor _)). Defined. Lemma disp_pstrans_rassociator_laws : is_disp_pstrans _ _ _ disp_pstrans_rassociator_data. Proof. apply is_disp_pstrans_from_total. pose (PP := rassociator_pstrans (total_psfunctor _ _ _ FF₁) (total_psfunctor _ _ _ FF₂) (total_psfunctor _ _ _ FF₃)). pose (PP2 := pstrans_to_is_pstrans PP). assert (X : pstrans_to_pstrans_data PP = total_pstrans_data _ _ _ disp_lassociator_pstrans_data). - use total2_paths_f. + apply idpath. + apply funextsec. intro x. apply funextsec. intro y. apply funextsec. intro f. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } apply idpath. - exact (transportf is_pstrans X PP2). Qed. Definition disp_pstrans_rassociator : disp_pstrans (disp_pseudo_comp _ _ _ _ _ FF₁ (disp_pseudo_comp _ _ _ _ _ FF₂ FF₃) ) (disp_pseudo_comp _ _ _ _ _ (disp_pseudo_comp _ _ _ _ _ FF₁ FF₂) FF₃ ) (rassociator_pstrans F₁ F₂ F₃) := disp_pstrans_rassociator_data,, disp_pstrans_rassociator_laws. End DispTransAssociativiy. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispTransportLaws.v000066400000000000000000000063741451125700300261640ustar00rootroot00000000000000(*************************************************************************************** Transport laws for displayed bicategories This file is a collection of random transport laws for displayed bicategories. ***************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Local Open Scope cat. Definition transportf_disp_2cell {B : bicat} {D : disp_bicat B} {x y : B} {f g : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (p : f = g) : disp_invertible_2cell (idtoiso_2_1 _ _ p) ff (transportf _ p ff). Proof. induction p. cbn. exact (disp_id2_invertible_2cell ff). Defined. Definition disp_psfunctor_mor_transportb {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) {x y : B₁} {f g : x --> y} (p : f = g) {xx : D₁ x} {yy : D₁ y} (gg : xx -->[ g ] yy) : disp_psfunctor_mor _ _ _ FF (transportb (λ z, xx -->[ z ] yy) p gg) = transportb (λ z, _ -->[ z ] _) (maponpaths (#F) p) (disp_psfunctor_mor _ _ _ FF gg). Proof. induction p ; cbn. apply idpath. Qed. Definition transportf_prewhisker_1cell {B : bicat} {D : disp_bicat B} {x y z : B} {xx : D x} {yy : D y} {zz : D z} {f₁ f₂ : x --> y} {g : y --> z} (p : f₁ = f₂) (ff : xx -->[ f₁ ] yy) (gg : yy -->[ g ] zz) : (transportf (λ z, xx -->[ z ] yy) p ff ;; gg = transportf (λ z, xx -->[ z ] zz) (maponpaths (λ z, z · _) p) (ff ;; gg))%mor_disp. Proof. induction p ; cbn. apply idpath. Defined. Definition transportf_postwhisker_1cell {B : bicat} {D : disp_bicat B} {x y z : B} {xx : D x} {yy : D y} {zz : D z} {f : x --> y} {g₁ g₂ : y --> z} (p : g₁ = g₂) (ff : xx -->[ f ] yy) (gg : yy -->[ g₁ ] zz) : (ff ;; transportf (λ z, yy -->[ z ] zz) p gg = transportf (λ z, xx -->[ z ] zz) (maponpaths (λ z, _ · z) p) (ff ;; gg))%mor_disp. Proof. induction p ; cbn. apply idpath. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DispUnivalence.v000066400000000000000000000447561451125700300254400ustar00rootroot00000000000000(* *********************************************************************************** *) (** * Internal adjunction in displayed bicategories Benedikt Ahrens, Marco Maggesi April 2018 *) (* *********************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. (* For showing that the being a displayed adjoint equivalence is a proposition *) Require Import UniMath.Bicategories.Core.AdjointUnique. Require Export UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Export UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Export UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Local Open Scope cat. Local Open Scope mor_disp_scope. Section Displayed_Local_Univalence. Context {C : bicat}. Variable (D : disp_prebicat C). Definition disp_idtoiso_2_1 {a b : C} {f g : C⟦a, b⟧} (p : f = g) {aa : D a} {bb : D b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) (pp : transportf (λ z, _ -->[ z ] _) p ff = gg) : disp_invertible_2cell (idtoiso_2_1 f g p) ff gg. Proof. induction p. induction pp. exact (disp_id2_invertible_2cell ff). Defined. Definition disp_univalent_2_1 : UU := ∏ (a b : C) (f g : C⟦a,b⟧) (p : f = g) (aa : D a) (bb : D b) (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb), isweq (disp_idtoiso_2_1 p ff gg). Definition disp_isotoid_2_1 (HD : disp_univalent_2_1) {a b : C} {f g : C⟦a, b⟧} (p : f = g) {aa : D a} {bb : D b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) (pp : disp_invertible_2cell (idtoiso_2_1 f g p) ff gg) : transportf (λ z, _ -->[ z ] _) p ff = gg := invmap (make_weq _ (HD a b f g p aa bb ff gg)) pp. End Displayed_Local_Univalence. (** Some laws of `disp_idtoiso_2_1` *) Definition disp_1cell_transport_rwhisker {B : bicat} {D : disp_bicat B} {b₁ b₂ b₃ : B} {h : b₁ --> b₂} {f : b₂ --> b₃} {g : b₁ --> b₃} {α : h · f ==> g} {bb₁ : D b₁} {bb₂ : D b₂} {bb₃ : D b₃} (ff : bb₂ -->[ f ] bb₃) (gg : bb₁ -->[ g ] bb₃) {hh₁ hh₂ : bb₁ -->[ h] bb₂} (p : hh₁ = hh₂) (αα : hh₁ ;; ff ==>[ α] gg) : transportf (λ (z : bb₁ -->[ h ] bb₂), z ;; ff ==>[ α ] gg) p αα = transportf (λ z, _ ==>[ z ] _) (maponpaths (λ z, z • _) (id2_rwhisker _ _) @ id2_left _) ((disp_idtoiso_2_1 _ (idpath _) _ _ (!p) ▹▹ ff) •• αα). Proof. induction p ; cbn. cbn. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite !transport_f_f. refine (!_). use (transportf_set (λ z : h · f ==> g, hh₁ ;; ff ==>[ z ] gg)). apply cellset_property. Qed. Definition disp_idtoiso_2_1_inv {B : bicat} {D : disp_bicat B} {b₁ b₂ : B} {f : b₁ --> b₂} {bb₁ : D b₁} {bb₂ : D b₂} (ff₁ ff₂ : bb₁ -->[ f ] bb₂) (p : ff₁ = ff₂) : pr1 (disp_idtoiso_2_1 _ (idpath _) _ _ (!p)) = disp_inv_cell (disp_idtoiso_2_1 _ (idpath _) _ _ p). Proof. induction p. apply idpath. Qed. Definition disp_idtoiso_isotoid_2_1 {B : bicat} {D : disp_bicat B} (HD_2_1 : disp_univalent_2_1 D) {b₁ b₂ : B} {f g : b₁ --> b₂} (p : f = g) {bb₁ : D b₁} {bb₂ : D b₂} {ff : bb₁ -->[ f ] bb₂} {gg : bb₁ -->[ g ] bb₂} (α : disp_invertible_2cell (idtoiso_2_1 f g p) ff gg) : disp_idtoiso_2_1 _ p ff gg (disp_isotoid_2_1 _ HD_2_1 p ff gg α) = α. Proof. exact (homotweqinvweq (make_weq _ (HD_2_1 b₁ b₂ f g p bb₁ bb₂ ff gg)) α). Qed. Definition disp_isotoid_idtoiso_2_1 {B : bicat} {D : disp_bicat B} (HD_2_1 : disp_univalent_2_1 D) {b₁ b₂ : B} {f g : b₁ --> b₂} (p : f = g) {bb₁ : D b₁} {bb₂ : D b₂} {ff : bb₁ -->[ f ] bb₂} {gg : bb₁ -->[ g ] bb₂} (pp : transportf (λ z, bb₁ -->[ z] bb₂) p ff = gg) : disp_isotoid_2_1 _ HD_2_1 p ff gg (disp_idtoiso_2_1 _ p ff gg pp) = pp. Proof. exact (homotinvweqweq (make_weq _ (HD_2_1 b₁ b₂ f g p bb₁ bb₂ ff gg)) pp). Qed. Section Total_Category_Univalent_2_1. Context {C : bicat}. Variable (D : disp_bicat C) (HC : is_univalent_2_1 C) (HD : disp_univalent_2_1 D). Local Definition E := (total_bicat D). Local Definition path_E {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) : (f,, ff = g,, gg) ≃ ∑ (p : f = g), transportf _ p ff = gg := total2_paths_equiv _ (f ,, ff) (g ,, gg). Local Definition path_to_iso_E {x y : C} {xx : D x} {yy : D y} {f g : C⟦x,y⟧} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) : (∑ (p : f = g), transportf _ p ff = gg) ≃ ∑ (i : invertible_2cell f g), disp_invertible_2cell i ff gg. Proof. use weqbandf. - exact (idtoiso_2_1 f g ,, HC x y f g). - cbn. intros p. exact (disp_idtoiso_2_1 D p ff gg ,, HD x y f g p xx yy ff gg). Defined. Local Definition idtoiso_alt {x y : E} (f g : E⟦x,y⟧) : (idtoiso_2_1 f g ~ (iso_in_E_weq (pr2 f) (pr2 g)) ∘ (path_to_iso_E (pr2 f) (pr2 g)) ∘ (path_E (pr2 f) (pr2 g)))%weq. Proof. intros p. induction p. apply (@cell_from_invertible_2cell_eq E). reflexivity. Defined. Definition total_is_univalent_2_1 : is_univalent_2_1 E. Proof. intros x y f g. exact (weqhomot (idtoiso_2_1 f g) _ (invhomot (idtoiso_alt f g))). Defined. End Total_Category_Univalent_2_1. Definition fiberwise_local_univalent {C : bicat} (D : disp_bicat C) : UU := ∏ (a b : C) (f : C ⟦ a, b ⟧) (aa : D a) (bb : D b) (ff : aa -->[ f] bb) (gg : aa -->[ f ] bb), isweq (disp_idtoiso_2_1 D (idpath f) ff gg). Definition fiberwise_local_univalent_is_univalent_2_1 {C : bicat} (D : disp_bicat C) (HD : fiberwise_local_univalent D) : disp_univalent_2_1 D. Proof. intros x y f g p xx yy ff gg. induction p. apply HD. Defined. Lemma isaprop_disp_left_adjoint_equivalence {C : bicat} {D : disp_bicat C} {a b : C} {aa : D a} {bb : D b} {f : a --> b} (Hf : left_adjoint_equivalence f) (ff : aa -->[f] bb) : is_univalent_2_1 C → disp_univalent_2_1 D → isaprop (disp_left_adjoint_equivalence Hf ff). Proof. intros HUC HUD. revert Hf. apply hlevel_total2. 2: { apply hlevelntosn. apply isaprop_left_adjoint_equivalence. assumption. } eapply isofhlevelweqf. { apply left_adjoint_equivalence_total_disp_weq. } apply isaprop_left_adjoint_equivalence. apply total_is_univalent_2_1; assumption. Defined. Section Displayed_Global_Univalence. Context {C : bicat}. Variable (D : disp_bicat C). Definition disp_idtoiso_2_0 {a b : C} (p : a = b) (aa : D a) (bb : D b) (pp : transportf (λ z, D z) p aa = bb) : disp_adjoint_equivalence (idtoiso_2_0 a b p) aa bb. Proof. induction p. induction pp. exact (disp_identity_adjoint_equivalence aa). Defined. Definition disp_univalent_2_0 : UU := ∏ (a b : C) (p : a = b) (aa : D a) (bb : D b), isweq (disp_idtoiso_2_0 p aa bb). End Displayed_Global_Univalence. Definition fiberwise_univalent_2_0 {C : bicat} (D : disp_bicat C) : UU := ∏ (a : C) (aa bb : D a), isweq (disp_idtoiso_2_0 D (idpath a) aa bb). Definition fiberwise_univalent_2_0_to_disp_univalent_2_0 {C : bicat} (D : disp_bicat C) : fiberwise_univalent_2_0 D → disp_univalent_2_0 D. Proof. intros HD. intros a b p aa bb. induction p. exact (HD a aa bb). Defined. Definition disp_isotoid_2_0 {B : bicat} {D : disp_bicat B} (HD_2_0 : disp_univalent_2_0 D) {x : B} {xx yy : D x} (ee : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy) : xx = yy := invmap (make_weq _ (HD_2_0 x x (idpath _) xx yy)) ee. Definition disp_idtoiso_2_0_isotoid_2_0 {B : bicat} {D : disp_bicat B} (HD_2_0 : disp_univalent_2_0 D) {x : B} {xx yy : D x} (ee : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy) : disp_idtoiso_2_0 D (idpath _) xx yy (disp_isotoid_2_0 HD_2_0 ee) = ee. Proof. exact (homotweqinvweq (make_weq _ (HD_2_0 x x (idpath _) xx yy)) ee). Defined. Definition disp_isotoid_2_0_idtoiso_2_0 {B : bicat} {D : disp_bicat B} (HD_2_0 : disp_univalent_2_0 D) {x : B} {xx yy : D x} (p : xx = yy) : disp_isotoid_2_0 HD_2_0 (disp_idtoiso_2_0 _ (idpath _) xx yy p) = p. Proof. exact (homotinvweqweq (make_weq _ (HD_2_0 x x (idpath _) xx yy)) p). Defined. Definition disp_J_2_0_help_on_paths {B : bicat} {D : disp_bicat B} (P : ∏ (x y : B) (f : adjoint_equivalence x y) (xx : D x) (yy : D y), disp_adjoint_equivalence f xx yy → UU) (P_id : ∏ (x : B) (xx : D x), P x x (internal_adjoint_equivalence_identity x) xx xx (disp_identity_adjoint_equivalence xx)) {x : B} {xx : D x} {yy : D x} (p : xx = yy) : P x x (internal_adjoint_equivalence_identity x) xx yy (disp_idtoiso_2_0 D (idpath x) xx yy p). Proof. induction p. apply P_id. Defined. Definition disp_J_2_0_help {B : bicat} {D : disp_bicat B} (HD_2_0 : disp_univalent_2_0 D) (P : ∏ (x y : B) (f : adjoint_equivalence x y) (xx : D x) (yy : D y), disp_adjoint_equivalence f xx yy → UU) (P_id : ∏ (x : B) (xx : D x), P x x (internal_adjoint_equivalence_identity x) xx xx (disp_identity_adjoint_equivalence xx)) {x : B} {xx : D x} {yy : D x} (ff : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy) : P x x (internal_adjoint_equivalence_identity x) xx yy ff. Proof. pose (disp_J_2_0_help_on_paths P P_id (disp_isotoid_2_0 HD_2_0 ff)). refine (transportf (P x x _ xx yy) _ (disp_J_2_0_help_on_paths P P_id (disp_isotoid_2_0 HD_2_0 ff))). apply disp_idtoiso_2_0_isotoid_2_0. Defined. Definition disp_J_2_0 {B : bicat} {D : disp_bicat B} (HB_2_0 : is_univalent_2_0 B) (HD_2_0 : disp_univalent_2_0 D) (P : ∏ (x y : B) (f : adjoint_equivalence x y) (xx : D x) (yy : D y), disp_adjoint_equivalence f xx yy → UU) (P_id : ∏ (x : B) (xx : D x), P x x (internal_adjoint_equivalence_identity x) xx xx (disp_identity_adjoint_equivalence xx)) {x y : B} {f : adjoint_equivalence x y} {xx : D x} {yy : D y} (ff : disp_adjoint_equivalence f xx yy) : P x y f xx yy ff. Proof. revert x y f xx yy ff. use (J_2_0 HB_2_0). intros x xx yy ff. exact (disp_J_2_0_help HD_2_0 P P_id ff). Defined. Section Total_Category_Globally_Univalent. Context {C : bicat}. Variable (D : disp_bicat C) (HC : is_univalent_2_0 C) (HD : disp_univalent_2_0 D). Local Notation E := (total_bicat D). Local Definition path_E_obj (x y : C) (xx : D x) (yy : D y) : ((x ,, xx) = (y ,,yy)) ≃ ∑ (p : x = y), transportf _ p xx = yy := total2_paths_equiv _ (x ,, xx) (y ,, yy). Local Definition path_to_adj_equiv_E (x y : C) (xx : D x) (yy : D y) : (∑ (p : x = y), transportf _ p xx = yy) ≃ ∑ (i : adjoint_equivalence x y), disp_adjoint_equivalence i xx yy. Proof. use weqbandf. - exact (idtoiso_2_0 x y ,, HC x y). - cbn. intros p. exact (disp_idtoiso_2_0 D p xx yy ,, HD x y p xx yy). Defined. Definition idtoiso_2_0_alt {a b : C} (aa : D a) (bb : D b) : a,, aa = b,, bb ≃ @adjoint_equivalence E (a,, aa) (b,, bb) := ((invweq (adjoint_equivalence_total_disp_weq aa bb)) ∘ path_to_adj_equiv_E a b aa bb ∘ path_E_obj a b aa bb)%weq. Definition idtoiso_2_0_is_idtoiso_id_2_0_alt (x y : E) : @idtoiso_2_0 E x y ~ idtoiso_2_0_alt (pr2 x) (pr2 y). Proof. intros p. induction p. use total2_paths_b. - reflexivity. - use subtypePath. + intro. apply isapropdirprod. * apply isapropdirprod ; apply E. * apply isapropdirprod ; apply isaprop_is_invertible_2cell. + reflexivity. Defined. Definition total_is_univalent_2_0 : is_univalent_2_0 E. Proof. intros x y. exact (weqhomot (idtoiso_2_0 x y) _ (invhomot (idtoiso_2_0_is_idtoiso_id_2_0_alt x y))). Defined. End Total_Category_Globally_Univalent. Section Disp_Univalent_2. Context {C : bicat}. Definition disp_univalent_2 (D : disp_bicat C) : UU := disp_univalent_2_0 D × disp_univalent_2_1 D. Definition make_disp_univalent_2 {D : disp_bicat C} (univ_2_0 : disp_univalent_2_0 D) (univ_2_1 : disp_univalent_2_1 D) : disp_univalent_2 D := make_dirprod univ_2_0 univ_2_1. Definition disp_univalent_2_0_of_2 {D : disp_bicat C} (univ_2 : disp_univalent_2 D) : disp_univalent_2_0 D := pr1 univ_2. Definition disp_univalent_2_1_of_2 {D : disp_bicat C} (univ_2 : disp_univalent_2 D) : disp_univalent_2_1 D := pr2 univ_2. End Disp_Univalent_2. Lemma total_is_univalent_2 {C : bicat} {D: disp_bicat C} : disp_univalent_2 D → is_univalent_2 C → is_univalent_2 (total_bicat D). Proof. intros UD UC. split. - apply total_is_univalent_2_0. { apply UC. } apply disp_univalent_2_0_of_2. assumption. - apply total_is_univalent_2_1. { apply UC. } apply disp_univalent_2_1_of_2. assumption. Defined. (** Displayed local univalence corresponds with the expected local condition *) Section DispLocallyUnivalent. Context {B : bicat} (D : disp_bicat B) {x y : B} {f : x --> y} {xx : D x} {yy : D y} (ff₁ ff₂ : xx -->[ f ] yy). Definition disp_inv2cell_to_disp_z_iso : disp_invertible_2cell (id2_invertible_2cell f) ff₁ ff₂ → @z_iso_disp _ (disp_hom xx yy) _ _ (identity_z_iso _) ff₁ ff₂. Proof. intro α. simple refine (@make_z_iso_disp _ (disp_hom xx yy) _ _ _ _ _ _ _). - exact (pr1 α). - simple refine (_ ,, _ ,, _). + exact (disp_inv_cell α). + abstract (refine (disp_vcomp_linv α @ _) ; cbn ; apply maponpaths_2 ; apply cellset_property). + abstract (refine (disp_vcomp_rinv α @ _) ; cbn ; apply maponpaths_2 ; apply cellset_property). Defined. Definition disp_z_iso_to_disp_inv2cell : @z_iso_disp _ (disp_hom xx yy) _ _ (identity_z_iso _) ff₁ ff₂ → disp_invertible_2cell (id2_invertible_2cell f) ff₁ ff₂. Proof. intro α. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 α). - exact (inv_mor_disp_from_z_iso α). - abstract (cbn ; refine (pr222 α @ _) ; apply maponpaths_2 ; apply cellset_property). - abstract (cbn ; refine (pr122 α @ _) ; apply maponpaths_2 ; apply cellset_property). Defined. Definition disp_inv2cell_weq_disp_z_iso : disp_invertible_2cell (id2_invertible_2cell f) ff₁ ff₂ ≃ @z_iso_disp _ (disp_hom xx yy) _ _ (identity_z_iso _) ff₁ ff₂. Proof. use make_weq. - exact disp_inv2cell_to_disp_z_iso. - use isweq_iso. + exact disp_z_iso_to_disp_inv2cell. + abstract (intro α ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; apply idpath). + abstract (intro α ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. End DispLocallyUnivalent. Definition is_univalent_disp_disp_hom {B : bicat} (D : disp_bicat B) (HD : disp_univalent_2_1 D) {x y : B} (xx : D x) (yy : D y) : is_univalent_disp (disp_hom xx yy). Proof. intros f g p ff gg. induction p. use weqhomot. - exact (disp_inv2cell_weq_disp_z_iso D _ _ ∘ make_weq _ (HD x y f f (idpath _) xx yy ff gg))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DisplayedUniversalArrow.v000066400000000000000000000356521451125700300273440ustar00rootroot00000000000000(* In this file, we define displayed left universal arrows and show how they define a left universal arrow for the corresponding total pseudo-functor. Created by Kobe Wullaert at 06/12/2022. Contents 1. Definition of a displayed universal arrow. 2. A make constructor when the 2-cells of the displayed bicategories are propositional. 3. A make constructor when the 2-cells of the displayed bicategories are propositional and groupoidal. 4. A make constructor when the 2-cells of the displayed bicategories are contractible. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.TotalAdjunction. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Import DispBicat.Notations. Local Open Scope cat. Local Open Scope mor_disp_scope. Lemma fiber_paths_transposed {A : UU} {B : A → UU} {a1 : A} {a2 : A} (b1 : B a1) (b2 : B a2) : ∏ p : a1,, b1 = a2,, b2, b1 = transportb B (base_paths _ _ p) b2 . Proof. intro q. use transportb_transpose_right. apply (fiber_paths q). Qed. Section DisplayedLeftUniversalArrow. Context {B1 B2 : bicat} {R : psfunctor B1 B2} (LUR : left_universal_arrow R). Let L : B2 -> B1 := pr1 LUR. Let η : ∏ x : B2, B2 ⟦ x, R (L x) ⟧ := pr12 LUR. Let adj : ∏ (x : B2) (y : B1), adj_equivalence_of_cats (left_universal_arrow_functor R x y η) := pr22 LUR. Context {D1 : disp_bicat B1} {D2 : disp_bicat B2} (RR : disp_psfunctor D1 D2 R). Definition disp_left_universal_arrow0 : UU := ∑ (LL : ∏ x : B2, D2 x → D1 (L x)), ∏ (x : B2) (xx : D2 x), xx -->[η x] (RR _ (LL _ xx)). Context (dLUR : disp_left_universal_arrow0). Let LL := pr1 dLUR. Let ηη := pr2 dLUR. Let η0 : ∏ x0 : total_bicat D2, total_bicat D2 ⟦ x0, (total_psfunctor D1 D2 R RR) (_,,LL (pr1 x0) (pr2 x0)) ⟧ := λ x, η (pr1 x) ,, ηη _ (pr2 x). Definition disp_left_universal_arrow_functor_data {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : disp_functor_data (left_universal_arrow_functor R x y η) (disp_hom (LL _ xx) yy) (disp_hom xx (RR _ yy)). Proof. exists (λ f ff, ηη _ xx ;; (disp_psfunctor_mor _ _ _ RR ff)). intros f g ff gg α αα. exact (disp_lwhisker (ηη _ xx) (disp_psfunctor_cell _ _ _ RR αα)). Defined. Lemma disp_left_universal_arrow_is_functor {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : disp_functor_axioms (disp_left_universal_arrow_functor_data xx yy). Proof. set (lur := left_universal_arrow_functor (total_psfunctor _ _ _ RR) (x,,xx) (y,,yy) η0). split. - intros f ff. set (p := pr12 lur (f,,ff)). refine (fiber_paths_transposed _ _ p @ _). apply maponpaths_2. apply cellset_property. - intros f g h ff gg hh α β αα ββ. set (p := pr22 lur (f,,ff) (g,,gg) (h,,hh) (α,,αα) (β,,ββ)). set (s := fiber_paths_transposed _ _ p). refine (s @ _). apply maponpaths_2. apply cellset_property. Qed. Definition disp_left_universal_arrow_functor {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : disp_functor (left_universal_arrow_functor R x y η) (disp_hom (LL _ xx) yy) (disp_hom xx (RR _ yy)) := _ ,, disp_left_universal_arrow_is_functor xx yy. Definition disp_left_universal_arrow_universality : UU := ∏ (x : B2) (xx : D2 x) (y : B1) (yy : D1 y), is_equiv_over (_ ,, adj x y) (disp_left_universal_arrow_functor xx yy). Definition total_disp_left_universal_arrow (dLURu : disp_left_universal_arrow_universality) : left_universal_arrow (total_psfunctor D1 D2 R RR). Proof. exists (λ x, L (pr1 x),, LL _ (pr2 x)). exists (λ x, η (pr1 x) ,, ηη _ (pr2 x)). intros [x xx] [y yy]. use nat_iso_adj_equivalence_of_cats. - exact (total_functor (disp_left_universal_arrow_functor xx yy)). - apply nat_trans_id. - use is_nat_z_iso_nat_trans_id. - exact (total_adj_equivalence_of_cats (dLURu x xx y yy)). Defined. End DisplayedLeftUniversalArrow. Section DisplayedLeftUniversalArrowDef. Context {B1 B2 : bicat} {R : psfunctor B1 B2} (LUR : left_universal_arrow R) {D1 : disp_bicat B1} {D2 : disp_bicat B2} (RR : disp_psfunctor D1 D2 R). Let L : B2 -> B1 := pr1 LUR. Let η : ∏ x : B2, B2 ⟦ x, R (L x) ⟧ := pr12 LUR. Let adj : ∏ (x : B2) (y : B1), adj_equivalence_of_cats (left_universal_arrow_functor R x y η) := pr22 LUR. Definition disp_left_universal_arrow : UU := ∑ (LL : ∏ x : B2, D2 x → D1 (L x)), ∑ ηη : ∏ (x : B2) (xx : D2 x), xx -->[η x] (RR _ (LL _ xx)), ∏ (x : B2) (xx : D2 x) (y : B1) (yy : D1 y), is_equiv_over (_ ,, adj x y) (disp_left_universal_arrow_functor LUR RR (LL,,ηη) xx yy). Definition total_left_universal_arrow (dLUR : disp_left_universal_arrow) : left_universal_arrow (total_psfunctor D1 D2 R RR) := total_disp_left_universal_arrow LUR RR (pr1 dLUR ,, pr12 dLUR) (pr22 dLUR). End DisplayedLeftUniversalArrowDef. Section MakeDisplayedLeftUniversalArrowIfPropositional. Context {B1 B2 : bicat} {R : psfunctor B1 B2} (LUR : left_universal_arrow R) {D1 : disp_bicat B1} {D2 : disp_bicat B2} (RR : disp_psfunctor D1 D2 R) (D1_2cells_prop : disp_2cells_isaprop D1) (D2_2cells_prop : disp_2cells_isaprop D2). Let L : B2 -> B1 := pr1 LUR. Let η : ∏ x : B2, B2 ⟦ x, R (L x) ⟧ := pr12 LUR. Let adj : ∏ (x : B2) (y : B1), adj_equivalence_of_cats (left_universal_arrow_functor R x y η) := pr22 LUR. Context (LL : ∏ x : B2, D2 x → D1 (L x)) (ηη : ∏ (x : B2) (xx : D2 x), xx -->[η x] (RR _ (LL _ xx))). Context (LL_mor : ∏ x xx y yy f (ff : xx -->[ f] RR y yy), LL x xx -->[ right_adjoint ((pr22 LUR) x y) f] yy). Context (LL_2cell : ∏ x xx y yy (f1 f2 : B2 ⟦ x, R y ⟧) (ff1 : xx -->[ f1] RR y yy) (ff2 : xx -->[ f2] RR y yy) (α : f1 ==> f2), ff1 ==>[α] ff2 → (LL_mor x xx y yy f1 ff1) ==>[(# (right_adjoint ((pr22 LUR) x y)))%Cat α] (LL_mor x xx y yy f2 ff2)). Context (LL_unit : ∏ x xx y yy f ff, ff ==>[adjunit (adj x y) f] (LL_mor x xx y yy (η x · (# R)%Cat f) (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR ff))). Context (LL_unit_inv : ∏ x xx y yy f ff, (LL_mor x xx y yy ((pr12 LUR) x · (# R)%Cat f) (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR ff)) ==>[inv_from_z_iso (unit_pointwise_z_iso_from_adj_equivalence (adj x y) _)] ff). Context (LL_counit : ∏ x xx y yy f ff, (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR (LL_mor x xx y yy f ff)) ==>[adjcounit (adj x y) f] ff). Context (LL_counit_inv : ∏ x xx y yy f ff, ff ==>[inv_from_z_iso (counit_pointwise_z_iso_from_adj_equivalence (adj x y) _)] (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR (LL_mor x xx y yy f ff))). Definition make_disp_functor_data_if_prop {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : disp_functor_data (right_adjoint ((pr22 LUR) x y)) (disp_hom xx (RR y yy)) (disp_hom (LL x xx) yy). Proof. simple refine (_ ,, _). - exact (LL_mor x xx y yy). - exact (LL_2cell x xx y yy). Defined. Definition make_disp_functor_if_prop {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : disp_functor (right_adjoint ((pr22 LUR) x y)) (disp_hom xx (RR y yy)) (disp_hom (LL x xx) yy). Proof. simple refine (make_disp_functor_data_if_prop xx yy ,, _). abstract (split ; intros ; apply D1_2cells_prop). Defined. Definition make_disp_univ_arrow_if_prop_equiv {x : B2} (xx : D2 x) {y : B1} (yy : D1 y) : is_equiv_over (left_universal_arrow_functor R x y (pr12 LUR),, (pr22 LUR) x y) (disp_left_universal_arrow_functor LUR RR (LL,, ηη) xx yy). Proof. simple refine (((_ ,, (_,,_)) ,, _) ,, (_ ,, _)). - exact (make_disp_functor_if_prop xx yy). - simple refine (_ ,, _). + exact (LL_unit x xx y yy). + abstract (intro ; intros ; apply D1_2cells_prop). - simple refine (_ ,, _). + exact (LL_counit x xx y yy). + abstract ( intro ; intros ; apply D2_2cells_prop). - abstract (split ; intro ; intros; [ apply D2_2cells_prop | apply D1_2cells_prop ]). - intros f ff. simple refine (_ ,, (_ ,, _)). + exact (LL_unit_inv x xx y yy f ff). + abstract (apply D1_2cells_prop). + abstract (apply D1_2cells_prop). - intros f ff. simple refine (_ ,, (_ ,, _)). + exact (LL_counit_inv x xx y yy f ff). + abstract (apply D2_2cells_prop). + abstract (apply D2_2cells_prop). Defined. Definition make_disp_univ_arrow_if_prop : disp_left_universal_arrow LUR RR. Proof. refine (LL ,, ηη ,, _). intros x xx y yy. exact (make_disp_univ_arrow_if_prop_equiv xx yy). Defined. End MakeDisplayedLeftUniversalArrowIfPropositional. Section MakeDisplayedLeftUniversalArrowIfGroupoidalAndProp. Context {B1 B2 : bicat} {R : psfunctor B1 B2} (LUR : left_universal_arrow R) {D1 : disp_bicat B1} {D2 : disp_bicat B2} (RR : disp_psfunctor D1 D2 R) (D1_2cells_grp : disp_locally_groupoid D1) (D2_2cells_grp : disp_locally_groupoid D2) (D1_2cells_prop : disp_2cells_isaprop D1) (D2_2cells_prop : disp_2cells_isaprop D2). Let L : B2 -> B1 := pr1 LUR. Let η : ∏ x : B2, B2 ⟦ x, R (L x) ⟧ := pr12 LUR. Let adj : ∏ (x : B2) (y : B1), adj_equivalence_of_cats (left_universal_arrow_functor R x y η) := pr22 LUR. Context (LL : ∏ x : B2, D2 x → D1 (L x)) (ηη : ∏ (x : B2) (xx : D2 x), xx -->[η x] (RR _ (LL _ xx))). Context (LL_mor : ∏ x xx y yy f (ff : xx -->[ f] RR y yy), LL x xx -->[ right_adjoint ((pr22 LUR) x y) f] yy). Context (LL_2cell : ∏ x xx y yy (f1 f2 : B2 ⟦ x, R y ⟧) (ff1 : xx -->[ f1] RR y yy) (ff2 : xx -->[ f2] RR y yy) (α : f1 ==> f2), ff1 ==>[α] ff2 → (LL_mor x xx y yy f1 ff1) ==>[(# (right_adjoint ((pr22 LUR) x y)))%Cat α] (LL_mor x xx y yy f2 ff2) ). Context (LL_unit : ∏ x xx y yy f ff, ff ==>[adjunit (adj x y) f] (LL_mor x xx y yy (η x · (# R)%Cat f) (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR ff))). Context (LL_counit : ∏ x xx y yy f ff, (ηη x xx ;; disp_psfunctor_mor D1 D2 R RR (LL_mor x xx y yy f ff)) ==>[adjcounit (adj x y) f] ff). Definition make_disp_univ_arrow_if_groupoid_and_prop : disp_left_universal_arrow LUR RR. Proof. use make_disp_univ_arrow_if_prop. - exact D1_2cells_prop. - exact D2_2cells_prop. - exact LL. - exact ηη. - exact LL_mor. - exact LL_2cell. - exact LL_unit. - intros x xx y yy f ff. use (pr1 (disp_hom_disp_invertible_2cell_to_z_iso _ _)). + apply LL_unit. + apply (D1_2cells_grp _ _ _ _ (_ ,, (pr12 (adj x y)) f)). - exact LL_counit. - intros x xx y yy f ff. use (pr1 (disp_hom_disp_invertible_2cell_to_z_iso _ _)). + apply LL_counit. + apply (D2_2cells_grp _ _ _ _ (_ ,, (pr22 (adj x y)) f)). Defined. End MakeDisplayedLeftUniversalArrowIfGroupoidalAndProp. Section MakeDisplayedLeftUniversalArrowIfContractible. Context {B1 B2 : bicat} {R : psfunctor B1 B2} (LUR : left_universal_arrow R) {D1 : disp_bicat B1} {D2 : disp_bicat B2} (RR : disp_psfunctor D1 D2 R) (D1_2cells_contr : disp_2cells_iscontr D1) (D2_2cells_contr : disp_2cells_iscontr D2). Let L : B2 -> B1 := pr1 LUR. Let η : ∏ x : B2, B2 ⟦ x, R (L x) ⟧ := pr12 LUR. Let adj : ∏ (x : B2) (y : B1), adj_equivalence_of_cats (left_universal_arrow_functor R x y η) := pr22 LUR. Context (LL : ∏ x : B2, D2 x → D1 (L x)) (ηη : ∏ (x : B2) (xx : D2 x), xx -->[η x] (RR _ (LL _ xx))). Context (LL_mor : ∏ x xx y yy f (ff : xx -->[ f] RR y yy), LL x xx -->[ right_adjoint ((pr22 LUR) x y) f] yy). Definition make_disp_univ_arrow_if_contr : disp_left_universal_arrow LUR RR. Proof. use make_disp_univ_arrow_if_groupoid_and_prop. - exact (disp_2cells_isgroupoid_from_disp_2cells_iscontr _ D1_2cells_contr). - exact (disp_2cells_isgroupoid_from_disp_2cells_iscontr _ D2_2cells_contr). - exact (disp_2cells_isaprop_from_disp_2cells_iscontr _ D1_2cells_contr). - exact (disp_2cells_isaprop_from_disp_2cells_iscontr _ D2_2cells_contr). - exact LL. - exact ηη. - exact LL_mor. - abstract (intro ; intros ; apply D1_2cells_contr). - abstract (intro ; intros ; apply D1_2cells_contr). - abstract (intro ; intros ; apply D2_2cells_contr). Defined. End MakeDisplayedLeftUniversalArrowIfContractible. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/DisplayedUniversalArrowOnCat.v000066400000000000000000000143421451125700300302620ustar00rootroot00000000000000(* In this file, we construct displayed universal arrows over the inclusion UnivCat to Cat (with left biadjoint the Rezk completion). Contents: 1. LocallyContr: A make constructor for a displayed universal arrow. 2. LocallyContrWeakEquivalences: A make constructor for a displayed universal arrow in terms of weak equivalences. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.TotalAdjunction. Require Import UniMath.CategoryTheory.WeakEquivalences. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DisplayedUniversalArrow. Require Import UniMath.Bicategories.PseudoFunctors.Examples.BicatOfCatToUnivCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOnCatToUniv. Require Import UniMath.Bicategories.DisplayedBicats.Examples.CategoriesWithStructure. Local Open Scope cat. Section LocallyContr. Let UnivCat := bicat_of_univ_cats. Let Cat := bicat_of_cats. Let R := univ_cats_to_cats. Context (D : disp_bicat Cat) (HD : disp_2cells_iscontr D) (LUR : left_universal_arrow R). Let D' := (disp_bicat_on_cat_to_univ_cat D). Let RR := (disp_psfunctor_on_cat_to_univ_cat D (disp_2cells_isaprop_from_disp_2cells_iscontr _ HD)). Let LL0 := λ C, (pr1 (pr1 LUR C)). Context (LL : ∏ C : category, D C → D (LL0 C)). Context (ηη : ∏ (C : category) (CC : D C), CC -->[ (pr12 LUR) C] LL C CC). Context (extension_preserve_structure : ∏ (C1 : category) (CC1 : pr1 D C1) (C2 : univalent_category) (CC2 : D (pr1 C2)) (F : C1 ⟶ pr1 C2), CC1 -->[F] CC2 → LL C1 CC1 -->[ right_adjoint ((pr22 LUR) C1 C2) F] CC2). Definition make_disp_left_universal_arrow_if_contr_CAT : disp_left_universal_arrow LUR RR. Proof. use make_disp_univ_arrow_if_contr. - exact (disp_2cells_iscontr_disp_bicat_on_cat_to_univ_cat _ HD). - exact HD. - exact LL. - exact ηη. - exact extension_preserve_structure. Defined. End LocallyContr. Section LocallyContrWeakEquivalences. Let UnivCat := bicat_of_univ_cats. Let Cat := bicat_of_cats. Let R := univ_cats_to_cats. Context (D : disp_bicat Cat) (HD : disp_2cells_iscontr D) (LUR : left_universal_arrow R). Let D' := (disp_bicat_on_cat_to_univ_cat D). Let RR := (disp_psfunctor_on_cat_to_univ_cat D (disp_2cells_isaprop_from_disp_2cells_iscontr _ HD)). Let LL0 := λ C, (pr1 (pr1 LUR C)). Let η := (pr12 LUR). Context (η_weak_equiv : ∏ C : category, is_weak_equiv (η C)). Context (weak_equiv_preserve_struct : ∏ (C1 C2 : category) (H : is_univalent C2) (F : C1 ⟶ C2), is_weak_equiv F -> D C1 -> D C2). Context (η_preserves_structs : ∏ (C : category) (CC : D C), CC -->[η C] weak_equiv_preserve_struct C (LL0 C) (pr2 (pr1 LUR C)) (η C) (η_weak_equiv C) CC). Context (extension_preserves_struct : ∏ (C1 : category) (C2 C3 : univalent_category) (F : C1 ⟶ C3) (G : C1 ⟶ C2) (H : C2 ⟶ C3) (n : nat_z_iso (G ∙ H) F) (CC1 : D C1) (CC2 : D (pr1 C2)) (CC3 : D (pr1 C3)), is_weak_equiv G -> CC1 -->[ F ] CC3 -> CC2 -->[ H ] CC3). Definition make_disp_left_universal_arrow_if_contr_CAT_from_weak_equiv : disp_left_universal_arrow LUR RR. Proof. use make_disp_left_universal_arrow_if_contr_CAT. - intros C CC. use (weak_equiv_preserve_struct _ _ _ (η C)). + apply (pr1 LUR C). + apply η_weak_equiv. + exact CC. - exact η_preserves_structs. - intros C1 CC1 C2 CC2 F FF. use (extension_preserves_struct C1 (LL0 C1) C2 F (η C1) _ _ CC1). + set (t := counit_nat_z_iso_from_adj_equivalence_of_cats (pr22 LUR C1 C2)). set (tg := nat_z_iso_pointwise_z_iso t F). exact (nat_z_iso_from_z_iso (homset_property _) tg). + apply η_weak_equiv. + exact FF. Defined. End LocallyContrWeakEquivalences. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/EquivalenceBetweenCartesians.v000066400000000000000000000556141451125700300303120ustar00rootroot00000000000000(********************************************************************* Cartesian 1-cells In this file, we show that if we have 2 cartesian 1-cells over some 1-cell, then we have an adjoint equivalence between their domains. *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Local Open Scope cat. Local Open Scope mor_disp. Section AdjEquivBetweenCartesian. Context {B : bicat} {D : disp_bicat B} (HB_2_1 : is_univalent_2_1 B). Section MapAndCellFromCartesians. Context {x y : B} {f : x --> y} {xx₁ xx₂ : D x} {yy : D y} (ff₁ : xx₁ -->[ f ] yy) {ff₂ : xx₂ -->[ f ] yy} (Hff₂ : cartesian_1cell D ff₂). Let ff' : xx₁ -->[ id₁ x · f ] yy := transport_along_inv_2cell HB_2_1 (linvunitor_invertible_2cell f) ff₁. Let ℓ : lift_1cell_factor D ff₂ ff' := pr1 Hff₂ x xx₁ (id₁ _) ff'. Definition map_between_cartesian_1cell : xx₁ -->[ id₁ _ ] xx₂ := ℓ. Definition map_between_cartesian_1cell_commute : disp_invertible_2cell (lunitor_invertible_2cell _) (map_between_cartesian_1cell ;; ff₂) ff₁. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (pr2 ℓ) (transport_along_inv_2cell_disp_invertible_2cell _ _ _))). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; apply id2_left). Defined. End MapAndCellFromCartesians. Section InverseOfCartesians. Context {x y : B} {f : x --> y} {xx₁ xx₂ : D x} {yy : D y} {ff₁ : xx₁ -->[ f ] yy} (Hff₁ : cartesian_1cell D ff₁) {ff₂ : xx₂ -->[ f ] yy} (Hff₂ : cartesian_1cell D ff₂). Let l : xx₁ -->[ id₁ x] xx₂ := map_between_cartesian_1cell ff₁ Hff₂. Let δl : disp_invertible_2cell (lunitor_invertible_2cell f) (l ;; ff₂) ff₁ := map_between_cartesian_1cell_commute ff₁ Hff₂. Let r : xx₂ -->[ id₁ x] xx₁ := map_between_cartesian_1cell ff₂ Hff₁. Let δr : disp_invertible_2cell (lunitor_invertible_2cell f) (r ;; ff₁) ff₂ := map_between_cartesian_1cell_commute ff₂ Hff₁. Let gg₁ : xx₂ -->[ id₁ x · f ] yy := transport_along_inv_2cell HB_2_1 (linvunitor_invertible_2cell f) ff₂. Let γ₁ : disp_invertible_2cell (inv_of_invertible_2cell (linvunitor_invertible_2cell f)) gg₁ ff₂ := transport_along_inv_2cell_disp_invertible_2cell HB_2_1 (linvunitor_invertible_2cell f) ff₂. Let gg₂ : xx₂ -->[ id₁ x · id₁ x · f ] yy := transport_along_inv_2cell HB_2_1 (comp_of_invertible_2cell (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (linvunitor_invertible_2cell _)) (lassociator_invertible_2cell _ _ _)) ff₂. Let γ₂ : disp_invertible_2cell _ gg₂ ff₂ := transport_along_inv_2cell_disp_invertible_2cell HB_2_1 (comp_of_invertible_2cell (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (linvunitor_invertible_2cell _)) (lassociator_invertible_2cell _ _ _)) ff₂. Local Lemma first_lift_path : comp_of_invertible_2cell (lunitor_invertible_2cell f) (inv_of_invertible_2cell (inv_of_invertible_2cell (linvunitor_invertible_2cell f))) = id2_invertible_2cell (id₁ x · f). Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. apply lunitor_linvunitor. Qed. Local Definition first_lift : lift_1cell_factor D ff₂ gg₁. Proof. refine (id_disp _ ,, _). exact (transportf (λ z, disp_invertible_2cell z _ _) first_lift_path (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (inverse_of_disp_invertible_2cell γ₁))). Defined. Local Lemma second_lift_path : comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)) (comp_of_invertible_2cell (lunitor_invertible_2cell f) (inv_of_invertible_2cell (inv_of_invertible_2cell (comp_of_invertible_2cell (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (linvunitor_invertible_2cell _)) (lassociator_invertible_2cell (id₁ x) (id₁ x) f)))))) = id2_invertible_2cell (id₁ x · id₁ x · f). Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lunitor_lwhisker. rewrite !vassocl. rewrite linvunitor_assoc. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. rewrite runitor_lunitor_identity. rewrite rwhisker_vcomp. rewrite lunitor_linvunitor. apply id2_rwhisker. Qed. Local Definition second_lift : lift_1cell_factor D ff₂ gg₂. Proof. refine (r ;; l ,, _). exact (transportf (λ z, disp_invertible_2cell z _ _) second_lift_path (vcomp_disp_invertible (disp_invertible_2cell_rassociator _ _ _) (vcomp_disp_invertible (disp_invertible_2cell_lwhisker r δl) (vcomp_disp_invertible δr (inverse_of_disp_invertible_2cell γ₂))))). Defined. Local Definition help_cell₁ : gg₂ ==>[ lunitor (id₁ x) ▹ f] gg₁. Proof. refine (transportf (λ z, _ ==>[ z ] _) _ (γ₂ •• disp_inv_cell γ₁)). abstract (cbn ; rewrite !vassocl ; rewrite lunitor_linvunitor ; rewrite id2_right ; rewrite <- lunitor_triangle ; rewrite !vassocr ; rewrite rassociator_lassociator ; apply id2_left). Defined. Let w₁ : lift_2cell_factor D ff₂ help_cell₁ second_lift first_lift := pr2 Hff₂ x xx₂ _ _ _ gg₁ (lunitor (id₁ x)) help_cell₁ second_lift first_lift. Definition disp_adj_equiv_between_cartesian_1cell_inv : r ;; l ==>[ lunitor _ ] id_disp _ := w₁. Let ζ : r ;; l ==>[ lunitor _ ] id_disp _ := disp_adj_equiv_between_cartesian_1cell_inv. Local Definition help_cell₂ : gg₁ ==>[ linvunitor (id₁ x) ▹ f] gg₂. Proof. refine (transportf (λ z, _ ==>[ z ] _) _ (γ₁ •• disp_inv_cell γ₂)). abstract (cbn ; rewrite !vassocr ; rewrite lunitor_linvunitor ; rewrite id2_left ; rewrite rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite <- triangle_l_inv ; rewrite <- lwhisker_hcomp ; apply maponpaths_2 ; rewrite linvunitor_assoc ; rewrite lwhisker_hcomp ; rewrite triangle_r_inv ; rewrite <- rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; apply idpath). Defined. Let w₂ : lift_2cell_factor D ff₂ help_cell₂ first_lift second_lift := pr2 Hff₂ x xx₂ _ _ _ gg₂ (linvunitor (id₁ x)) help_cell₂ first_lift second_lift. Definition inv_of_disp_adj_equiv_between_cartesian_1cell_inv : id_disp _ ==>[ linvunitor _ ] r ;; l := w₂. Let ξ : id_disp _ ==>[ linvunitor _ ] r ;; l := inv_of_disp_adj_equiv_between_cartesian_1cell_inv. Local Definition help_inv_cell₁ : gg₂ ==>[ id₂ _ ▹ f ] gg₂ := transportb (λ z, _ ==>[ z ] _) (id2_rwhisker _ _) (disp_id2 _). Local Lemma disp_adj_equiv_between_cartesian_inv₁ : ζ •• ξ = transportb (λ z, r ;; l ==>[ z ] r ;; l) (vcomp_rinv (is_invertible_2cell_lunitor (id₁ x))) (disp_id2 (r ;; l)). Proof. refine (!(transportbfinv (λ z, _ ==>[ z ] _) (lunitor_linvunitor _) _) @ _). refine (_ @ transportbfinv (λ z, _ ==>[ z ] _) (lunitor_linvunitor _) _). apply maponpaths. use (isaprop_lift_of_lift_2cell _ _ (pr2 Hff₂ _ _ _ _ _ _ _ help_inv_cell₁ second_lift second_lift)). - rewrite disp_rwhisker_transport_left_new. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_rwhisker_vcomp_alt. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_vassocl. unfold transportb. rewrite transport_f_f. etrans. { do 2 apply maponpaths. exact (eq_lift_2cell_alt _ _ w₂). } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. unfold help_cell₂. rewrite !disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. apply maponpaths_2. exact (eq_lift_2cell_alt _ _ w₁). } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. unfold help_cell₁. rewrite !disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite !disp_vassocl. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 3 apply maponpaths. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. rewrite disp_vcomp_linv. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite disp_id2_left. unfold transportb. rewrite transport_f_f. apply idpath. } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. apply disp_vcomp_rinv. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply disp_id2_right. } unfold transportb. rewrite transport_f_f. unfold help_inv_cell₁. unfold transportb. rewrite disp_mor_transportf_prewhisker. refine (!_). etrans. { apply maponpaths. apply disp_id2_right. } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold help_inv_cell₁, transportb. rewrite !disp_rwhisker_transport_left_new. rewrite !disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Local Definition help_inv_cell₂ : gg₁ ==>[ id₂ (id₁ x) ▹ f ] gg₁ := transportb (λ z, _ ==>[ z ] _) (id2_rwhisker _ _) (disp_id2 _). Local Lemma disp_adj_equiv_between_cartesian_inv₂ : ξ •• ζ = transportb (λ z, id_disp xx₂ ==>[ z ] id_disp xx₂) (vcomp_linv (is_invertible_2cell_lunitor (id₁ x))) (disp_id2 (id_disp xx₂)). Proof. refine (!(transportbfinv (λ z, _ ==>[ z ] _) (linvunitor_lunitor _) _) @ _). refine (_ @ transportbfinv (λ z, _ ==>[ z ] _) (linvunitor_lunitor _) _). apply maponpaths. use (isaprop_lift_of_lift_2cell _ _ (pr2 Hff₂ x _ _ _ _ _ _ help_inv_cell₂ first_lift first_lift)). - cbn. etrans. { do 2 apply maponpaths. exact (transportf_disp_invertible_2cell first_lift_path _). } cbn. rewrite disp_rwhisker_transport_left_new. rewrite !disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_rwhisker_vcomp_alt. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. refine (!_). etrans. { apply maponpaths_2. exact (transportf_disp_invertible_2cell first_lift_path _). } cbn. rewrite disp_mor_transportf_postwhisker. refine (!_). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _) ; apply maponpaths. apply maponpaths. pose (maponpaths (λ z, _ •• z) (!(transportf_disp_invertible_2cell first_lift_path _)) @ eq_lift_2cell_alt _ _ w₁) as p. cbn in p. rewrite disp_mor_transportf_prewhisker in p. pose (p' := @transportb_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ p). exact p'. } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. apply maponpaths_2. exact (transportf_disp_invertible_2cell second_lift_path _). } cbn. rewrite disp_mor_transportf_postwhisker. rewrite !disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. apply maponpaths_2. pose (maponpaths (λ z, _ •• z) (!(transportf_disp_invertible_2cell second_lift_path _)) @ eq_lift_2cell_alt _ _ w₂) as p. cbn in p. rewrite disp_mor_transportf_prewhisker in p. pose (p' := @transportb_transpose_right _ (λ z, _ ==>[ z ] _) _ _ _ _ _ p). exact p'. } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. do 2 apply maponpaths_2. exact (transportf_disp_invertible_2cell first_lift_path _). } cbn. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. unfold help_cell₂, help_cell₁. rewrite !disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite !disp_vassocl. unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _) ; apply maponpaths. apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. apply maponpaths_2. exact (disp_vcomp_linv γ₁). } unfold transportb. rewrite !disp_mor_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. apply maponpaths. refine (disp_vassocr _ _ _ @ _) ; apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv γ₂). } unfold transportb. rewrite disp_mor_transportf_postwhisker. apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite !transport_f_f. unfold help_inv_cell₂. unfold transportb. rewrite !disp_mor_transportf_prewhisker. rewrite transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. apply disp_id2_right. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply cellset_property. - unfold help_inv_cell₂. unfold transportb. rewrite !disp_rwhisker_transport_left_new. rewrite !disp_mor_transportf_prewhisker. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_left, disp_id2_right. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply cellset_property. Qed. Definition disp_adj_equiv_between_cartesian_1cell_inv_is_invertible : is_disp_invertible_2cell (is_invertible_2cell_lunitor _) ζ := ξ ,, disp_adj_equiv_between_cartesian_inv₁ ,, disp_adj_equiv_between_cartesian_inv₂. Definition disp_adj_equiv_between_cartesian_1cell_inv_2cell : disp_invertible_2cell (lunitor_invertible_2cell _) (r ;; l) (id_disp _). Proof. refine (ζ ,, _). apply disp_adj_equiv_between_cartesian_1cell_inv_is_invertible. Defined. End InverseOfCartesians. Section DispAdjEquivBetweenCartesians. Context {x y : B} {f : x --> y} {xx₁ xx₂ : D x} {yy : D y} {ff₁ : xx₁ -->[ f ] yy} (Hff₁ : cartesian_1cell D ff₁) {ff₂ : xx₂ -->[ f ] yy} (Hff₂ : cartesian_1cell D ff₂). Let l : xx₁ -->[ id₁ x] xx₂ := map_between_cartesian_1cell ff₁ Hff₂. Let r : xx₂ -->[ id₁ x] xx₁ := map_between_cartesian_1cell ff₂ Hff₁. Local Definition disp_adj_equiv_between_cartesian_1cell_unit : id_disp _ ==>[ linvunitor _ ] l ;; r. Proof. exact (pr1 (inverse_of_disp_invertible_2cell (disp_adj_equiv_between_cartesian_1cell_inv_2cell Hff₂ Hff₁))). Defined. Let η : id_disp _ ==>[ linvunitor _ ] l ;; r := disp_adj_equiv_between_cartesian_1cell_unit. Local Definition disp_adj_equiv_between_cartesian_1cell_unit_invertible : is_disp_invertible_2cell (is_invertible_2cell_linvunitor _) η. Proof. refine (transportf (λ z, is_disp_invertible_2cell z _) _ (pr2 (inverse_of_disp_invertible_2cell (disp_adj_equiv_between_cartesian_1cell_inv_2cell Hff₂ Hff₁)))). apply isaprop_is_invertible_2cell. Defined. Local Definition disp_adj_equiv_between_cartesian_1cell_counit : r ;; l ==>[ lunitor _ ] id_disp _ := disp_adj_equiv_between_cartesian_1cell_inv Hff₁ Hff₂. Let ε : r ;; l ==>[ lunitor _ ] id_disp _ := disp_adj_equiv_between_cartesian_1cell_counit. Local Definition disp_adj_equiv_between_cartesian_1cell_counit_invertible : is_disp_invertible_2cell (is_invertible_2cell_lunitor (id₁ x)) ε := disp_adj_equiv_between_cartesian_1cell_inv_is_invertible Hff₁ Hff₂. Definition disp_adj_equiv_between_cartesian_1cell : ∑ (e : left_adjoint_equivalence (id₁ x)), disp_left_adjoint_equivalence e l. Proof. use disp_left_equivalence_to_left_adjoint_equivalence. - exact (left_equivalence_of_left_adjoint_equivalence (internal_adjoint_equivalence_identity x)). - refine ((r ,, η ,, ε) ,, _ ,, _). + exact disp_adj_equiv_between_cartesian_1cell_unit_invertible. + exact disp_adj_equiv_between_cartesian_1cell_counit_invertible. Defined. End DispAdjEquivBetweenCartesians. End AdjEquivBetweenCartesian. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/000077500000000000000000000000001451125700300240765ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Add2Cell.v000066400000000000000000000161441451125700300256450ustar00rootroot00000000000000(** Given is a displayed bicategory on C. Then we have a total category E of which the objects are objects in C with some additional structure. In this file, we give a method for adding 2-cells to the structure, which represents an equation on the structure in the total category. The equation has two endpoints, l and r. These are given as natural maps in the underlying bicategory. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Local Open Scope cat. Section Add2Cell. Context {C : bicat}. Variable (D : disp_bicat C). Local Notation E := (total_bicat D). Local Notation F := (pr1_psfunctor D). Variable (S T : psfunctor C C) (l r : pstrans (@comp_psfunctor E C C S F) (@comp_psfunctor E C C T F)). Definition add_cell_disp_cat_data : disp_cat_ob_mor E. Proof. use make_disp_cat_ob_mor. - exact (λ X, l X ==> r X). - exact (λ X Y α β f, (α ▹ #T(#F f)) • psnaturality_of r f = (psnaturality_of l f) • (#S(#F f) ◃ β)). Defined. Definition add_cell_disp_cat_id_comp : disp_cat_id_comp E add_cell_disp_cat_data. Proof. split. - intros x xx. pose (pstrans_id_alt l x) as p. simpl. cbn in p. rewrite !psfunctor_id2 in p. rewrite id2_left, id2_right in p. refine (!_). etrans. { apply maponpaths_2. exact p. } clear p. refine (!_). pose (pstrans_id_alt r x) as p. cbn in p. rewrite !psfunctor_id2 in p. rewrite id2_left, id2_right in p. etrans. { apply maponpaths. exact p. } clear p. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocl. rewrite vcomp_whisker. apply idpath. - intros x y z f g xx yy zz Hf Hg ; cbn. pose (pstrans_comp_alt l f g) as pl. pose (pstrans_comp_alt r f g) as pr. cbn in pl, pr ; rewrite pl, pr ; clear pl pr. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. etrans. { apply maponpaths_2. apply maponpaths_2. apply maponpaths. apply Hf. } rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_vcomp. etrans. { apply maponpaths. apply Hg. } rewrite <- lwhisker_vcomp. reflexivity. Qed. Definition add_cell_disp_cat : disp_bicat E. Proof. use disp_cell_unit_bicat. use tpair. - exact add_cell_disp_cat_data. - exact add_cell_disp_cat_id_comp. Defined. Definition add_cell_disp_cat_univalent_2_1 : disp_univalent_2_1 add_cell_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros. apply C. Defined. Definition add_cell_disp_cat_univalent_2_0 (HC : is_univalent_2_1 C) (HD : disp_univalent_2_1 D) : disp_univalent_2_0 add_cell_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply total_is_univalent_2_1. + exact HC. + exact HD. - intros. apply C. - intros x xx yy. simpl in *. apply C. - abstract (intros x xx yy; intros p; induction p as [p q]; cbn; cbn in p, q; pose (pstrans_id_alt l) as pl; cbn in pl ; rewrite pl in p ; clear pl; pose (pstrans_id_alt r) as pr; cbn in pr ; rewrite pr in p ; clear pr; cbn in p; rewrite !psfunctor_id2 in p; rewrite !id2_right, !id2_left in p; rewrite !vassocr in p; rewrite vcomp_whisker in p; rewrite !vassocl in p; assert (is_invertible_2cell (l x ◃ ((pr122 T) (pr1 x)) ^-1)) as H; try is_iso ; pose (vcomp_lcancel _ H p) as p'; rewrite !vassocr in p'; rewrite vcomp_runitor in p'; rewrite !vassocl in p'; pose (vcomp_lcancel _ (is_invertible_2cell_runitor _) p') as p''; use (vcomp_rcancel (linvunitor (r x))) ; try is_iso; use (vcomp_rcancel (psfunctor_id S (pr1 x) ▹ r x)) ; try (is_iso ; exact (psfunctor_id S (pr1 x))); rewrite !vassocl; refine (p'' @ _); rewrite vcomp_whisker; rewrite !vassocr; apply maponpaths_2; rewrite lwhisker_hcomp; exact (!(linvunitor_natural _))). Defined. Definition add_cell_disp_cat_univalent_2 (HC : is_univalent_2_1 C) (HD : disp_univalent_2_1 D) : disp_univalent_2 add_cell_disp_cat. Proof. apply make_disp_univalent_2. - apply add_cell_disp_cat_univalent_2_0; assumption. - apply add_cell_disp_cat_univalent_2_1. Defined. Definition disp_2cells_isaprop_add_cell : disp_2cells_isaprop add_cell_disp_cat. Proof. intro; intros; exact isapropunit. Qed. Definition disp_locally_groupoid_add_cell : disp_locally_groupoid add_cell_disp_cat. Proof. use make_disp_locally_groupoid. - intro; intros. exact tt. - exact disp_2cells_isaprop_add_cell. Qed. End Add2Cell. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Algebras.v000066400000000000000000001117651451125700300260200ustar00rootroot00000000000000(** Lax algebras on a pseudofunctor. Morphisms are 2-cells which witness a certain diagram commutes. Since this 2-cell is not necessarily invertible, these are lax algebras. We define it as a displayed bicategory. We also prove that the total category is univalent if the base is univalent. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section Algebra. Context `{C : bicat}. Variable (F : psfunctor C C). Definition alg_disp_cat : disp_cat_ob_mor C. Proof. use tpair. - exact (λ X, C⟦F X,X⟧). - intros X Y f g h. exact (invertible_2cell (f · h) (#F h · g)). Defined. Definition alg_disp_cat_id_comp : disp_cat_id_comp C alg_disp_cat. Proof. split ; cbn. - intros X f. refine (runitor f • linvunitor f • (psfunctor_id F X ▹ f) ,, _). is_iso. exact (psfunctor_id F X). - intros X Y Z f g hX hY hZ α β. refine ((lassociator hX f g) • (α ▹ g) • rassociator (#F f) hY g • (#F f ◃ β) • lassociator (#F f) (#F g) hZ • (psfunctor_comp F f g ▹ hZ) ,, _). is_iso. + exact α. + exact β. + exact (psfunctor_comp F f g). Defined. Definition alg_disp_cat_2cell : disp_2cell_struct alg_disp_cat. Proof. intros X Y f g α hX hY αf αg ; cbn in *. exact ((hX ◃ α) • αg = αf • (##F α ▹ hY)). Defined. Definition disp_alg_prebicat_1 : disp_prebicat_1_id_comp_cells C. Proof. use tpair. - use tpair. + exact alg_disp_cat. + exact alg_disp_cat_id_comp. - exact alg_disp_cat_2cell. Defined. Definition disp_alg_lunitor {X Y : C} (f : C⟦X,Y⟧) (hX : C⟦F X,X⟧) (hY : C⟦F Y,Y⟧) (hf : invertible_2cell (hX · f) (#F f · hY)) : disp_2cells (lunitor f) (@id_disp C disp_alg_prebicat_1 X hX;; hf) hf. Proof. cbn ; red ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r. rewrite <- lwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso _ (lunitor f,,_)). is_iso. } cbn. rewrite psfunctor_linvunitor. rewrite !vassocl. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. assert ((lunitor hX ▹ f) • hf • (linvunitor (# F f) ▹ hY) = rassociator _ _ _ • (_ ◃ hf) • lassociator _ _ _) as ->. { use vcomp_move_R_Mp. { is_iso. } use vcomp_move_R_pM. { is_iso. } cbn. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite !vassocl. rewrite <- lunitor_assoc. rewrite lwhisker_hcomp. rewrite lunitor_natural. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. reflexivity. } rewrite !vassocl. rewrite rwhisker_rwhisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. reflexivity. Qed. Definition disp_alg_runitor_help {X Y : C} (f : C⟦X,Y⟧) (hX : C⟦F X,X⟧) (hY : C⟦F Y,Y⟧) (hf : hX · f ==> # F f · hY) : (hX ◃ runitor f) • hf = (lassociator hX f (identity Y)) • (hf ▹ identity Y) • rassociator (# F f) hY (identity Y) • (# F f ◃ runitor hY). Proof. use vcomp_move_R_pM. { is_iso. } cbn. rewrite !vassocl. rewrite runitor_triangle. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. reflexivity. Qed. Definition disp_alg_runitor {X Y : C} (f : C⟦X,Y⟧) (hX : disp_alg_prebicat_1 X) (hY : C⟦F Y,Y⟧) (hf : hX -->[ f ] hY) : disp_2cells (runitor f) (hf;; @id_disp C disp_alg_prebicat_1 Y hY) hf. Proof. cbn ; red ; cbn. rewrite disp_alg_runitor_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. apply maponpaths. apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (runitor f ,, _)). is_iso. } cbn. rewrite !vassocl. apply maponpaths. rewrite psfunctor_rinvunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite rwhisker_lwhisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite lwhisker_hcomp, rwhisker_hcomp. symmetry. apply triangle_l_inv. Qed. Definition disp_alg_lassociator {W X Y Z : C} {f : C ⟦W,X⟧} {g : C ⟦X,Y⟧} {h : C ⟦Y,Z⟧} {hW : disp_alg_prebicat_1 W} {hX : disp_alg_prebicat_1 X} {hY : disp_alg_prebicat_1 Y} {hZ : disp_alg_prebicat_1 Z} (hf : hW -->[ f] hX) (hg : hX -->[ g] hY) (hh : hY -->[ h] hZ) : disp_2cells (rassociator f g h) ((hf;; hg)%mor_disp;; hh) (hf;; (hg;; hh)%mor_disp). Proof. cbn ; red ; cbn. assert ((hW ◃ rassociator f g h) • lassociator hW f (g · h) = lassociator hW (f · g) h • (lassociator _ _ _ ▹ h) • rassociator _ _ _) as X0. { use vcomp_move_L_Mp. { is_iso. } cbn. rewrite !vassocl. rewrite pentagon. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. reflexivity. } rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite X0. rewrite !vassocl. apply maponpaths. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (rassociator f g h ,, _)). is_iso. } cbn. pose (psfunctor_lassociator F f g h). rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite (maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite !rwhisker_vcomp. rewrite vassocl in p. cbn in p. etrans. { do 5 apply maponpaths. exact p. } clear p. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). pose (pentagon hZ (#F h) (#F g) (#F f)) as p. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp in p. rewrite vassocr in p. rewrite <- p. rewrite <- lwhisker_vcomp. use vcomp_move_R_pM. { is_iso. } use vcomp_move_R_pM. { is_iso. } rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } cbn. assert ((#F f ◃ rassociator hX g h) • lassociator (#F f) hX (g · h) • lassociator (#F f · hX) g h • (rassociator (#F f) hX g ▹ h) = lassociator _ _ _) as X1. { rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite pentagon. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker, id2_right. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2, id2_left. reflexivity. } rewrite !vassocr. rewrite X1. rewrite <- rwhisker_lwhisker. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_lwhisker. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } use vcomp_move_R_pM. { is_iso. } cbn. assert ((rassociator (#F f) (#F g) (hY · h)) • (#F f ◃ lassociator (#F g) hY h) • lassociator (#F f) (#F g · hY) h • (lassociator (#F f) (#F g) hY ▹ h) = lassociator _ _ _) as X2. { rewrite !vassocl. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- pentagon. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite !vassocr. rewrite X2. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lassociator_rassociator. rewrite id2_left. rewrite rwhisker_rwhisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite vcomp_whisker. reflexivity. Qed. Definition disp_alg_ops : disp_prebicat_ops disp_alg_prebicat_1. Proof. repeat split. - intros X Y f hX hY α ; cbn ; unfold alg_disp_cat_2cell. rewrite lwhisker_id2, id2_left. rewrite psfunctor_id2, id2_rwhisker, id2_right. reflexivity. - intros X Y f hX hY hf. exact (disp_alg_lunitor f hX hY hf). - intros X Y f hX hY hf. exact (disp_alg_runitor f hX hY hf). - intros X Y f hX hY hf ; cbn ; red. use vcomp_move_R_pM. { is_iso. } rewrite vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (linvunitor f ,, _)). is_iso. } symmetry. exact (disp_alg_lunitor f hX hY hf). - intros X Y f hX hY hf ; cbn ; red. use vcomp_move_R_pM. { is_iso. } rewrite vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (rinvunitor f ,, _)). is_iso. } cbn. symmetry. exact (disp_alg_runitor f hX hY hf). - intros W X Y Z f g h hW hX hY hZ hf hg hh. exact (disp_alg_lassociator hf hg hh). - intros W X Y Z f g h hW hX hY hZ hf hg hh. cbn ; red. use vcomp_move_R_pM. { is_iso. } rewrite vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (lassociator f g h ,, _)). is_iso. } cbn. symmetry. exact (disp_alg_lassociator hf hg hh). - intros X Y f g h α β hX hY hf hg hh hα hβ ; cbn ; red. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite hβ. rewrite !vassocr. rewrite hα. rewrite !vassocl. rewrite !rwhisker_vcomp. rewrite <- !psfunctor_vcomp. reflexivity. - intros X Y Z f g₁ g₂ α hX hY hZ hf hg₁ hg₂ hα ; cbn ; red ; cbn. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. rewrite psfunctor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite lwhisker_vcomp. rewrite <- hα. rewrite <- lwhisker_vcomp. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_lwhisker_rassociator. rewrite !vassocr. apply (maponpaths (λ z, (z • _) • _)). rewrite vcomp_whisker. reflexivity. - intros X Y Z f g₁ g₂ α hX hY hZ hf hg₁ hg₂ hα ; cbn ; red ; cbn. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. rewrite psfunctor_rwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite rwhisker_rwhisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite rwhisker_vcomp. rewrite hα. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. reflexivity. Qed. Definition disp_alg_ops_laws : disp_prebicat_laws (_ ,, disp_alg_ops). Proof. repeat split ; intro ; intros ; apply C. Qed. Definition disp_alg_prebicat : disp_prebicat C := (_ ,, disp_alg_ops_laws). Definition disp_alg_bicat : disp_bicat C. Proof. refine (disp_alg_prebicat ,, _). intros X Y f g α hX hY hf hg hα hβ. apply isasetaprop. cbn in * ; unfold alg_disp_cat_2cell in *. exact (pr2 C _ _ _ _ ((hX ◃ α) • hg) (hf • (## F α ▹ hY))). Defined. Definition disp_alg_bicat_disp_is_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_alg_bicat a} {bb : disp_alg_bicat b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) (xx : ff ==>[x] gg) : is_disp_invertible_2cell x xx. Proof. use tpair. - cbn in *. unfold alg_disp_cat_2cell in *. use vcomp_move_R_pM. { is_iso. } cbn. rewrite vassocr. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso F (x ^-1 ,, _)). is_iso. } cbn. exact (!xx). - split ; apply C. Defined. Definition disp_alg_bicat_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_alg_bicat a} {bb : disp_alg_bicat b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) : isaprop (disp_invertible_2cell x ff gg). Proof. apply invproofirrelevance. intro ; intro. use subtypePath. - intro. apply isaprop_is_disp_invertible_2cell. - apply C. Defined. Definition disp_alg_bicat_univalent_2_1 : disp_univalent_2_1 disp_alg_bicat. Proof. intros a b f g p aa bb ff gg. induction p. apply isweqimplimpl. - cbn. intros x. pose (pr1 x) as d. cbn in *. unfold alg_disp_cat_2cell in *. rewrite lwhisker_id2 in d. rewrite id2_left in d. rewrite psfunctor_id2 in d. rewrite id2_rwhisker in d. rewrite id2_right in d. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact (!d). - apply isaset_invertible_2cell. - apply disp_alg_bicat_disp_invertible_2cell. Defined. Section Invertible2CellToDispAdjointEquivalence. Context {a : C}. Variable (aa bb : disp_alg_bicat a) (x : invertible_2cell aa bb). Local Definition left_adjoint_2cell : aa -->[ internal_adjoint_equivalence_identity a] bb. Proof. refine (runitor aa • x • linvunitor bb • (psfunctor_id F a ▹ bb) ,, _). is_iso. - exact x. - exact (psfunctor_id F a). Defined. Local Definition right_adjoint_2cell : bb -->[ left_adjoint_right_adjoint (internal_adjoint_equivalence_identity a)] aa. Proof. refine (runitor bb • inv_cell x • linvunitor aa • (psfunctor_id F a ▹ aa) ,, _). is_iso. exact (psfunctor_id F a). Defined. Local Definition η_2cell : (id_disp aa) ==>[ left_adjoint_unit (internal_adjoint_equivalence_identity a) ] left_adjoint_2cell;;right_adjoint_2cell. Proof. cbn ; unfold alg_disp_cat_2cell, left_adjoint_2cell, right_adjoint_2cell ; cbn. rewrite !(maponpaths (λ z, z ▹ _) (vassocl _ _ _)). rewrite !(maponpaths (λ z, (_ • z) ▹ _) (vassocr _ _ _)). rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !(maponpaths (λ z, (_ • z) ▹ _) (vassocl _ _ _)). rewrite <- vcomp_whisker. rewrite <- (runitor_natural _ _ _ _ (x^-1)). rewrite <- rwhisker_hcomp. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • z))))) (vassocr _ _ _)). rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • (_ • z)))))) (vassocr _ _ _)). rewrite lwhisker_vcomp, rwhisker_vcomp. rewrite vcomp_rinv, id2_rwhisker, lwhisker_id2, id2_left. rewrite psfunctor_linvunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite <- runitor_natural. rewrite lwhisker_hcomp. assert ((linvunitor (id₁ a) ⋆⋆ id₂ aa) • lassociator aa (id₁ a) (id₁ a) • (runitor aa ▹ id₁ a) • (linvunitor aa ▹ id₁ a) = (id₂ (id₁ a) ⋆⋆ linvunitor aa) • (runitor (id₁ (F a) · aa)) • rinvunitor _ ) as ->. { rewrite runitor_natural. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker, id2_left. rewrite left_unit_inv_assoc₂. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocr. rewrite runitor_rinvunitor, id2_left. use vcomp_move_L_Mp. { is_iso. } cbn. symmetry. apply linvunitor_assoc. } rewrite !vassocl. repeat (apply maponpaths). rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite <- left_unit_inv_assoc. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rinvunitor_runitor, lwhisker_id2, id2_left. rewrite !vassocl. rewrite rwhisker_lwhisker. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- !rwhisker_hcomp. rewrite !rwhisker_vcomp. apply maponpaths. use vcomp_move_R_Mp. { is_iso. apply F. } cbn. rewrite !vassocl. rewrite vcomp_whisker. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. apply F. } cbn. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- rinvunitor_natural, <- linvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. reflexivity. Qed. Local Definition ε_2cell : (right_adjoint_2cell;; left_adjoint_2cell) ==>[ left_adjoint_counit (internal_adjoint_equivalence_identity a) ] id_disp bb. Proof. cbn ; unfold alg_disp_cat_2cell, left_adjoint_2cell, right_adjoint_2cell ; cbn. rewrite !(maponpaths (λ z, z ▹ _) (vassocl _ _ _)). rewrite !(maponpaths (λ z, (_ • z) ▹ _) (vassocr _ _ _)). rewrite (linvunitor_natural (x ^-1)). rewrite <- lwhisker_hcomp. rewrite !(maponpaths (λ z, (_ • z) ▹ _) (vassocl _ _ _)). rewrite <- vcomp_whisker. rewrite <- (runitor_natural _ _ _ _ x). rewrite <- rwhisker_hcomp. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • z))))) (vassocr _ _ _)). rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)). rewrite rwhisker_vcomp, lwhisker_vcomp. rewrite vcomp_linv, lwhisker_id2, id2_rwhisker, id2_left. rewrite <- runitor_natural. rewrite <- !rwhisker_hcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocr. assert ((bb ◃ lunitor (id₁ a)) • (linvunitor bb ▹ id₁ a) = (lassociator bb (id₁ a) (id₁ a)) • (runitor bb ▹ id₁ a) • (linvunitor bb ▹ id₁ a)) as ->. { apply (maponpaths (λ z, z • _)). rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite triangle_r. reflexivity. } rewrite !vassocl. repeat (apply maponpaths). rewrite <- runitor_triangle. apply maponpaths. refine (!(id2_right _) @ _). apply maponpaths. rewrite psfunctor_F_lunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_rinv, id2_rwhisker, id2_left. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } use vcomp_move_L_Mp. { is_iso. } cbn ; rewrite id2_left. rewrite !vassocl. rewrite rwhisker_lwhisker. rewrite !lwhisker_hcomp, !rwhisker_hcomp. rewrite !vassocr. rewrite triangle_l_inv. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !rwhisker_vcomp. apply maponpaths. use vcomp_move_R_Mp. { is_iso. apply F. } cbn. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. apply F. } cbn. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- rinvunitor_natural, <- linvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. reflexivity. Qed. Definition disp_alg_bicat_adjoint_equivalence : disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb. Proof. use tpair. - exact left_adjoint_2cell. - use tpair. + use tpair. * exact right_adjoint_2cell. * split. ** exact η_2cell. ** exact ε_2cell. + refine ((_ ,, _) ,, (_ ,, _)). * apply C. * apply C. * apply disp_alg_bicat_disp_is_invertible_2cell. * apply disp_alg_bicat_disp_is_invertible_2cell. Defined. End Invertible2CellToDispAdjointEquivalence. Section DispAdjointEquivalenceToInvertible2cell. Context {a : C}. Variable (aa bb : disp_alg_bicat a) (x : disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb). Local Definition invertible_2cell_map_alg : aa ==> bb := (rinvunitor _) • (aa ◃ linvunitor (id₁ a)) • lassociator aa (id₁ a) (id₁ a) • (cell_from_invertible_2cell (pr1 x) ▹ id₁ a) • rassociator (# F (id₁ a)) bb (id₁ a) • (inv_cell (psfunctor_id F a) ▹ (bb · _)) • lunitor (bb · id₁ a) • runitor bb. Local Definition invertible_2cell_inv_alg : bb ==> aa := (rinvunitor bb) • linvunitor (bb · id₁ a) • (psfunctor_id F a ▹ (bb · id₁ a)) • (# F (id₁ a) ◃ cell_from_invertible_2cell (disp_left_adjoint_right_adjoint _ (pr12 x))) • lassociator (# F (id₁ a)) (# F (id₁ a)) aa • (psfunctor_comp F (id₁ a) (id₁ a) ▹ aa) • (##F (lunitor (id₁ a)) ▹ aa) • (inv_cell (psfunctor_id F a) ▹ aa) • lunitor aa. Definition invertible_2cell_map_alg' : aa ==> bb := (linvunitor aa) • (psfunctor_id F a ▹ aa) • (# F (id₁ a) ◃ rinvunitor aa) • (# F (id₁ a) ◃ cell_from_invertible_2cell (pr1 x)) • lassociator (# F (id₁ a)) (# F (id₁ a)) bb • (psfunctor_comp F (id₁ a) (id₁ a) ▹ bb) • (## F (lunitor (id₁ a)) ▹ bb) • ((psfunctor_id F a)^-1 ▹ bb) • lunitor bb. Local Definition invertible_2cell_inv_alg' : bb ==> aa := (rinvunitor bb) • (bb ◃ linvunitor (id₁ a)) • lassociator bb (id₁ a) (id₁ a) • (cell_from_invertible_2cell (disp_left_adjoint_right_adjoint _ (pr12 x)) ▹ id₁ a) • rassociator _ _ _ • (# F (id₁ a) ◃ runitor aa) • ((psfunctor_id F a)^-1 ▹ aa) • lunitor aa. Definition invertible_2cell_map_alg'' : aa ==> bb := (rinvunitor aa) • cell_from_invertible_2cell (pr1 x) • ((psfunctor_id F a)^-1 ▹ bb) • lunitor bb. Local Definition invertible_2cell_map_alg_eq : invertible_2cell_map_alg = invertible_2cell_map_alg'. Proof. unfold invertible_2cell_map_alg, invertible_2cell_map_alg'. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite (vcomp_whisker (psfunctor_id F a)). rewrite rwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_hcomp, lwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite <- linvunitor_natural. rewrite !vassocl. repeat (apply maponpaths). rewrite !vassocr. rewrite <- left_unit_inv_assoc. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite psfunctor_F_lunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_rinv, id2_rwhisker, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- rwhisker_rwhisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite !rwhisker_vcomp. rewrite vcomp_rinv, id2_rwhisker, id2_left. rewrite linvunitor_assoc. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rassociator_lassociator, id2_left. rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite !vassocl. apply maponpaths. rewrite lunitor_assoc. rewrite !vassocl. rewrite vcomp_runitor. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rinvunitor_runitor. apply id2_left. Qed. Local Definition invertible_2cell_map_alg_eq2 : invertible_2cell_map_alg = invertible_2cell_map_alg''. Proof. unfold invertible_2cell_map_alg, invertible_2cell_map_alg'' ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite <- rwhisker_rwhisker_alt. rewrite <- lunitor_triangle. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rassociator_lassociator, id2_left. rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite vcomp_runitor. rewrite !vassocr. rewrite runitor_rinvunitor, id2_left. reflexivity. Qed. Local Definition invertible_2cell_inv_alg_eq : invertible_2cell_inv_alg = invertible_2cell_inv_alg'. Proof. unfold invertible_2cell_inv_alg, invertible_2cell_inv_alg'. rewrite !vassocl. repeat (apply maponpaths). rewrite psfunctor_F_lunitor. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_rinv, id2_left. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite <- vcomp_whisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite !rwhisker_vcomp. rewrite vcomp_rinv, id2_rwhisker, id2_left. rewrite !vassocr. repeat (apply maponpaths_2). rewrite !vassocl. rewrite runitor_triangle, lunitor_triangle. rewrite vcomp_lunitor, vcomp_runitor. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite lwhisker_hcomp. rewrite triangle_l_inv. refine (!(id2_left _) @ _). apply maponpaths_2. rewrite <- rwhisker_hcomp. rewrite vcomp_runitor. exact (!(runitor_rinvunitor bb)). Qed. Local Definition map_inv_alg : invertible_2cell_map_alg • invertible_2cell_inv_alg = id₂ aa. Proof. unfold invertible_2cell_map_alg, invertible_2cell_inv_alg ; cbn. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • (_ • (_ • z))))))) (vassocr _ _ _)). rewrite runitor_rinvunitor, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • (_ • z)))))) (vassocr _ _ _)). rewrite lunitor_linvunitor, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • z))))) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). pose (disp_left_adjoint_unit _ x) as t1. cbn in t1. unfold alg_disp_cat_2cell in *. cbn in t1. rewrite !vassocr in t1. etrans. { apply maponpaths. do 3 apply maponpaths_2. apply t1. } clear t1. rewrite !vassocr. rewrite rinvunitor_runitor, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite <- psfunctor_vcomp. rewrite linvunitor_lunitor. rewrite psfunctor_id2. rewrite id2_rwhisker, id2_left. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker, id2_left. apply linvunitor_lunitor. Qed. Local Definition inv_map_alg : invertible_2cell_inv_alg • invertible_2cell_map_alg = id₂ bb. Proof. rewrite invertible_2cell_map_alg_eq, invertible_2cell_inv_alg_eq. unfold invertible_2cell_map_alg', invertible_2cell_inv_alg' ; cbn. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • (_ • (_ • z))))))) (vassocr _ _ _)). rewrite lunitor_linvunitor, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • (_ • z)))))) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • (_ • z))))) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite runitor_rinvunitor. rewrite lwhisker_id2, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). pose (disp_left_adjoint_counit _ x) as t1. cbn in t1. unfold alg_disp_cat_2cell in *. cbn in t1. rewrite !vassocr in t1. etrans. { do 2 apply maponpaths. do 2 apply maponpaths_2. apply (!t1). } clear t1. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. rewrite !vassocr. rewrite rinvunitor_runitor, id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker, id2_left. apply linvunitor_lunitor. Qed. Definition disp_alg_bicat_adjoint_equivalence_inv : invertible_2cell aa bb. Proof. use tpair. - exact invertible_2cell_map_alg. - use tpair. + exact invertible_2cell_inv_alg. + split. * exact map_inv_alg. * exact inv_map_alg. Defined. End DispAdjointEquivalenceToInvertible2cell. Definition disp_alg_bicat_adjoint_equivalence_weq (HC : is_univalent_2_1 C) {a : C} (aa bb : disp_alg_bicat a) : invertible_2cell aa bb ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb. Proof. use make_weq. - exact (disp_alg_bicat_adjoint_equivalence aa bb). - use isweq_iso. + exact (disp_alg_bicat_adjoint_equivalence_inv aa bb). + intros x. use subtypePath. * intro. apply isaprop_is_invertible_2cell. * cbn. abstract (rewrite invertible_2cell_map_alg_eq2 ; unfold invertible_2cell_map_alg'' ; cbn ; unfold left_adjoint_2cell ; rewrite !vassocr ; rewrite rinvunitor_runitor, id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rwhisker_vcomp, vcomp_rinv ; rewrite id2_rwhisker, id2_left ; rewrite linvunitor_lunitor, id2_right ; reflexivity). + intros x. use subtypePath. * intro. apply isaprop_disp_left_adjoint_equivalence. ** exact HC. ** exact disp_alg_bicat_univalent_2_1. * cbn. unfold left_adjoint_2cell. unfold disp_alg_bicat_adjoint_equivalence_inv ; cbn. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. abstract (rewrite invertible_2cell_map_alg_eq2 ; unfold invertible_2cell_map_alg'' ; cbn ; unfold left_adjoint_2cell ; rewrite !vassocr ; rewrite runitor_rinvunitor, id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite lunitor_linvunitor, id2_left ; rewrite rwhisker_vcomp, vcomp_linv ; rewrite id2_rwhisker, id2_right ; reflexivity). Defined. Definition disp_alg_bicat_univalent_2_0 (HC : is_univalent_2_1 C) : disp_univalent_2_0 disp_alg_bicat. Proof. intros a b p aa bb. induction p. use weqhomot. - exact (disp_alg_bicat_adjoint_equivalence_weq HC aa bb ∘ (_ ,, HC _ _ aa bb))%weq. - intros p. induction p ; cbn. use subtypePath. + intro ; simpl. apply (@isaprop_disp_left_adjoint_equivalence C disp_alg_bicat). * exact HC. * exact disp_alg_bicat_univalent_2_1. + cbn ; unfold left_adjoint_2cell ; cbn. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite id2_right. reflexivity. Defined. Definition bicat_algebra := total_bicat disp_alg_bicat. Definition bicat_algebra_is_univalent_2_1 (HC : is_univalent_2_1 C) : is_univalent_2_1 bicat_algebra. Proof. apply total_is_univalent_2_1. - exact HC. - exact disp_alg_bicat_univalent_2_1. Defined. Definition bicat_algebra_is_univalent_2_0 (HC : is_univalent_2 C) : is_univalent_2_0 bicat_algebra. Proof. apply total_is_univalent_2_0. - exact (pr1 HC). - exact (disp_alg_bicat_univalent_2_0 (pr2 HC)). Defined. Definition bicat_algebra_is_univalent_2 (HC : is_univalent_2 C) : is_univalent_2 bicat_algebra. Proof. split. - apply bicat_algebra_is_univalent_2_0. assumption. - apply bicat_algebra_is_univalent_2_1. exact (pr2 HC). Defined. Definition disp_2cells_isaprop_alg : disp_2cells_isaprop disp_alg_bicat. Proof. intro; intros; apply C. Qed. Definition disp_locally_groupoid_alg : disp_locally_groupoid disp_alg_bicat. Proof. intro; intros. apply disp_alg_bicat_disp_is_invertible_2cell. Qed. End Algebra. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/BicatOfInvertibles.v000066400000000000000000000143731451125700300300130ustar00rootroot00000000000000(************************************************************************* Bicat of invertible 2-cells This is the bicategory where we only consider the invertible 2-cells. Contents 1. Definition 2. Univalence *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section BicatOfInv2Cells. Context (B : bicat). (** 1. Definition *) Definition disp_prebicat_1_id_comp_cells_of_inv2cells : disp_prebicat_1_id_comp_cells B. Proof. simple refine (((_ ,, _) ,, (_ ,, _)) ,, _). - exact (λ _, unit). - exact (λ _ _ _ _ _, unit). - exact (λ _ _, tt). - exact (λ _ _ _ _ _ _ _ _ _ _, tt). - exact (λ x y f g α _ _ _ _, is_invertible_2cell α). Defined. Definition disp_prebicat_ops_of_inv2cells : disp_prebicat_ops disp_prebicat_1_id_comp_cells_of_inv2cells. Proof. repeat split ; intro ; intros ; cbn ; is_iso. Defined. Definition disp_prebicat_data_of_inv2cells : disp_prebicat_data B. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_of_inv2cells. - exact disp_prebicat_ops_of_inv2cells. Defined. Definition disp_prebicat_laws_of_inv2cells : disp_prebicat_laws disp_prebicat_data_of_inv2cells. Proof. repeat split ; intro ; intros ; apply isaprop_is_invertible_2cell. Qed. Definition disp_prebicat_of_inv2cells : disp_prebicat B. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_of_inv2cells. - exact disp_prebicat_laws_of_inv2cells. Defined. Definition disp_bicat_of_inv2cells : disp_bicat B. Proof. refine (disp_prebicat_of_inv2cells ,, _). intro ; intros. apply isasetaprop. apply isaprop_is_invertible_2cell. Defined. Definition disp_bicat_of_inv2cells_disp_2cells_isaprop : disp_2cells_isaprop disp_bicat_of_inv2cells. Proof. intro ; intros. apply isaprop_is_invertible_2cell. Qed. Definition disp_bicat_of_inv2cells_locally_groupoid : disp_locally_groupoid disp_bicat_of_inv2cells. Proof. use make_disp_locally_groupoid. - intro ; intros. cbn in *. is_iso. - exact disp_bicat_of_inv2cells_disp_2cells_isaprop. Defined. (** 2. Univalence *) Definition disp_univalent_2_1_disp_bicat_of_inv2cells : disp_univalent_2_1 disp_bicat_of_inv2cells. Proof. use fiberwise_local_univalent_is_univalent_2_1. intro ; intros. use isweqimplimpl. - intro. apply isapropunit. - apply isasetunit. - use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaprop_is_disp_invertible_2cell. } apply disp_bicat_of_inv2cells_disp_2cells_isaprop. Qed. Definition disp_univalent_2_0_disp_bicat_of_inv2cells (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2_0 disp_bicat_of_inv2cells. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intro ; intros. use isweqimplimpl. - intro. apply isapropunit. - apply isasetunit. - use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use (isaprop_disp_left_adjoint_equivalence _ _ HB_2_1). exact disp_univalent_2_1_disp_bicat_of_inv2cells. } apply isapropunit. Qed. Definition disp_univalent_2_disp_bicat_of_inv2cells (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2 disp_bicat_of_inv2cells. Proof. split. - exact (disp_univalent_2_0_disp_bicat_of_inv2cells HB_2_1). - exact disp_univalent_2_1_disp_bicat_of_inv2cells. Qed. Definition bicat_of_inv2cells : bicat := total_bicat disp_bicat_of_inv2cells. Definition is_univalent_2_1_bicat_of_inv2cells (HB_2_1 : is_univalent_2_1 B) : is_univalent_2_1 bicat_of_inv2cells. Proof. use total_is_univalent_2_1. - exact HB_2_1. - exact disp_univalent_2_1_disp_bicat_of_inv2cells. Defined. Definition is_univalent_2_0_bicat_of_inv2cells (HB_2_1 : is_univalent_2_1 B) (HB_2_0 : is_univalent_2_0 B) : is_univalent_2_0 bicat_of_inv2cells. Proof. use total_is_univalent_2_0. - exact HB_2_0. - use disp_univalent_2_0_disp_bicat_of_inv2cells. exact HB_2_1. Defined. Definition is_univalent_2_bicat_of_inv2cells (HB_2 : is_univalent_2 B) : is_univalent_2 bicat_of_inv2cells. Proof. use total_is_univalent_2. - apply disp_univalent_2_disp_bicat_of_inv2cells. exact (pr2 HB_2). - exact HB_2. Defined. Definition is_invertible_2cell_bicat_of_inv2cells {x y : bicat_of_inv2cells} {f g : x --> y} (α : f ==> g) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - simple refine (_ ,, _). + exact ((pr2 α)^-1). + cbn. is_iso. - abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply vcomp_rinv). - abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply vcomp_linv). Defined. Definition locally_groupoid_bicat_of_inv2cells : locally_groupoid bicat_of_inv2cells. Proof. intro ; intros. apply is_invertible_2cell_bicat_of_inv2cells. Defined. Definition eq_2cell_bicat_of_inv2cells {x y : bicat_of_inv2cells} {f g : x --> y} {α β : f ==> g} (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } exact p. Qed. End BicatOfInv2Cells. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/CategoriesWithStructure.v000066400000000000000000000106211451125700300311270ustar00rootroot00000000000000(************************************************************************************ Bicategories of categories with structure In set-theoretical foundations, there is a difference between chosen limits and existing limits. In this file, we define bicategories of categories with either chosen or existing limits. For the remainder of this paragraph, we focus on terminal objects. We have a bicategory of categories with chosen limits; the 1-cells are functors that preserve the chosen terminal objects up to strict equality. We also have a bicategory of categories with limits; the 1-cells are functors that preserve limits (up to iso). If we were to look at univalent categories, then these two bicategories coincide. Terminal objects are unique up to equality in univalent categories, so if we know that a terminal object exists, then we can choose one. In addition, since equality corresponds to isomorphism, the two notion of preservation also correspond. If we do not require the category to be univalent, then the two aforementioned bicategories are actually different. In this file, we define these different bicategories. The interest for these bicategories come from how the Rezk completion interacts with these notions. Note that [disp_bicat_chosen_terminal_obj] is defined as a subbicategory of the bicategory of categories, even though terminal objects are in general only unique up to equality in univalent categories. We use this construction more as a shortcut to obtain the desired definition. Contents 1. Categories with a chosen terminal object 2. Categories that have a terminal object 3. Each type of 2-cells in the bicategory of categories with a terminal object (chosen/have) is contractible. ************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Local Open Scope cat. (** 1. Categories with a chosen terminal object *) Definition disp_bicat_chosen_terminal_obj : disp_bicat bicat_of_cats. Proof. use disp_subbicat. - exact (λ C, Terminal (pr1 C)). - exact (λ C₁ C₂ T₁ T₂ F, preserves_chosen_terminal_eq F T₁ T₂). - exact (λ C T, identity_preserves_chosen_terminal_eq T). - exact (λ _ _ _ _ _ _ _ _ PF PG, composition_preserves_chosen_terminal_eq PF PG). Defined. Definition cat_with_chosen_terminal_obj : bicat := total_bicat disp_bicat_chosen_terminal_obj. (** 2. Categories that have a terminal object *) Definition disp_bicat_have_terminal_obj : disp_bicat bicat_of_cats. Proof. use disp_subbicat. - exact (λ C, @hasTerminal (pr1 C)). - exact (λ C₁ C₂ _ _ F, preserves_terminal F). - exact (λ C _, identity_preserves_terminal _). - exact (λ _ _ _ _ _ _ _ _ HF HG, composition_preserves_terminal HF HG). Defined. Definition cat_with_terminal_obj : bicat := total_bicat disp_bicat_have_terminal_obj. (* Homotopy levels of each type of 2-cells *) Lemma disp_2cells_is_contr_have_terminal_obj : disp_2cells_iscontr disp_bicat_have_terminal_obj. Proof. intro ; intros. exists (tt,,tt). intro. use total2_paths_f ; apply iscontrunit. Qed. Lemma disp_2cells_is_contr_chosen_terminal_obj : disp_2cells_iscontr disp_bicat_chosen_terminal_obj. Proof. intro ; intros. exists (tt,,tt). intro. use total2_paths_f ; apply iscontrunit. Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Codomain.v000066400000000000000000001072521451125700300260250ustar00rootroot00000000000000(************************************************************** The codomain displayed bicategory We look at the codomain displayed bicategory in this file. We restrict ourselves to locally groupoidal bicategories. 1. The definition 2. Displayed univalence ***************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition cod_1cell_path_help {B : bicat} {b c : B} (f₁ f₂ : B ⟦ b , c ⟧) : invertible_2cell f₁ f₂ ≃ invertible_2cell f₁ (id₁ _ · f₂). Proof. use make_weq. - intro α. refine (α • linvunitor _ ,, _). is_iso. apply α. - use isweq_iso. + intro α. use make_invertible_2cell. * exact (α • lunitor _). * is_iso. apply property_from_invertible_2cell. + abstract (intro p ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite vassocl ; rewrite linvunitor_lunitor ; apply id2_right). + abstract (intros α ; cbn ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite vassocl ; rewrite lunitor_linvunitor ; apply id2_right). Defined. (** 1. Definition of the displayed bicategory *) Section CodomainArrow. Variable (B : bicat). Definition cod_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells (prod_bicat B B). Proof. use tpair. - use tpair. + use tpair. * exact (λ X, pr2 X --> pr1 X). * exact (λ X Y fX fY f, invertible_2cell (fX · pr1 f) (pr2 f · fY)). + use tpair. * refine (λ X fX, (runitor _ • linvunitor _ ,, _)). is_iso. * refine (λ X Y Z f g fX fY fZ ff fg, (lassociator _ _ _ • (pr1 ff ▹ _) • rassociator _ _ _ • (_ ◃ pr1 fg) • lassociator _ _ _ ,, _)). cbn ; is_iso. ** exact (pr2 ff). ** exact (pr2 fg). - exact (λ X Y f g α fX fY ff fg, pr1 ff • (pr2 α ▹ _) = (_ ◃ pr1 α) • pr1 fg). Defined. Definition cod_disp_prebicat_ops : disp_prebicat_ops cod_disp_prebicat_1_id_comp_cells. Proof. repeat split. - intros X Y f fX fY pf. simpl ; cbn. rewrite id2_rwhisker, id2_right. rewrite lwhisker_id2, id2_left. apply idpath. - intros X Y f fX fY pf. simpl ; cbn. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite lunitor_triangle. rewrite linvunitor_lunitor. apply id2_right. - intros X Y f fX fY pf. simpl ; cbn. rewrite !vassocl. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite linvunitor_lunitor, id2_right. rewrite runitor_triangle. rewrite vcomp_runitor. rewrite !vassocr. apply maponpaths_2. rewrite left_unit_assoc. apply idpath. - intros X Y f fX fY pf. simpl ; cbn. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite rinvunitor_runitor, id2_left. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite linvunitor_assoc. rewrite !vassocl. rewrite rassociator_lassociator, id2_right. apply idpath. - intros X Y f fX fY pf. simpl ; cbn. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite !rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- left_unit_inv_assoc. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite rinvunitor_runitor, id2_left. rewrite lwhisker_hcomp. rewrite triangle_l_inv. apply idpath. - intros X₁ X₂ X₃ X₄ f g h fX₁ fX₂ fX₃ fX₄ pf pg ph. simpl ; cbn. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } simpl. etrans. { rewrite !vassocr. etrans. { do 8 apply maponpaths_2. apply lassociator_lassociator. } rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } simpl. rewrite !vassocl. refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. apply lassociator_lassociator. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp. { is_iso. } simpl. etrans. { rewrite !vassocl. do 4 apply maponpaths. exact (!(lassociator_lassociator _ _ _ _)). } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator, lwhisker_id2. apply id2_left. } rewrite rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } simpl. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } simpl. rewrite lassociator_lassociator. apply idpath. - intros X₁ X₂ X₃ X₄ f g h fX₁ fX₂ fX₃ fX₄ pf pg ph. simpl ; cbn. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocr. refine (!_). etrans. { do 7 apply maponpaths_2. rewrite lassociator_lassociator. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } simpl. etrans. { rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator, id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } simpl. etrans. { rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite <- lassociator_lassociator. rewrite vassocr. apply idpath. - intros X Y f g h p q fX fY pf pg ph pp pq. simpl ; cbn in *. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite pp. rewrite !vassocl. rewrite pq. rewrite !vassocr. apply maponpaths_2. apply lwhisker_vcomp. - intros X Y Z f g₁ g₂ p fX fY fZ pf pg₁ pg₂ pp. simpl ; cbn in *. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. apply maponpaths. exact pp. - intros X Y Z f₁ f₂ g p fX fY fZ pf₁ pf₂ pg pp. simpl ; cbn in *. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. rewrite <- pp. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. rewrite vcomp_whisker. apply idpath. Qed. Definition cod_disp_prebicat_data : disp_prebicat_data (prod_bicat B B). Proof. use tpair. - exact cod_disp_prebicat_1_id_comp_cells. - exact cod_disp_prebicat_ops. Defined. Definition cod_disp_prebicat_laws : disp_prebicat_laws cod_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply B. Qed. Definition cod_disp_prebicat : disp_prebicat (prod_bicat B B). Proof. use tpair. - exact cod_disp_prebicat_data. - exact cod_disp_prebicat_laws. Defined. Definition cod_has_disp_cellset : has_disp_cellset cod_disp_prebicat. Proof. intros X Y f g p fX fY pf pg. apply isasetaprop. apply B. Qed. Definition cod_disp_bicat_help : disp_bicat (prod_bicat B B). Proof. use tpair. - exact cod_disp_prebicat. - exact cod_has_disp_cellset. Defined. Definition cod_disp_bicat : disp_bicat B := sigma_bicat _ _ cod_disp_bicat_help. End CodomainArrow. (** Some projections and builders *) Definition dom {B : bicat} {X : B} (f : cod_disp_bicat B X) : B := pr1 f. Definition ar {B : bicat} {X : B} (f : cod_disp_bicat B X) : dom f --> X := pr2 f. Definition make_ar {B : bicat} {X Y : B} (f : X --> Y) : cod_disp_bicat B Y := (X ,, f). Definition make_disp_1cell_cod {B : bicat} {X Y : B} {f : X --> Y} {dX : cod_disp_bicat B X} {dY : cod_disp_bicat B Y} (h : dom dX --> dom dY) (p : invertible_2cell (pr2 dX · f) (h · pr2 dY)) : dX -->[ f ] dY := h ,, p. Definition coherent_homot {B : bicat} {X Y : B} {f g : X --> Y} (α : f ==> g) {dX : cod_disp_bicat B X} {dY : cod_disp_bicat B Y} {df : dX -->[ f ] dY} {dg : dX -->[ g ] dY} (h : pr1 df ==> pr1 dg) : UU := pr12 df • (h ▹ pr2 dY) = (pr2 dX ◃ α) • pr12 dg. Definition make_disp_2cell_cod {B : bicat} {X Y : B} {f g : X --> Y} {α : f ==> g} {dX : cod_disp_bicat B X} {dY : cod_disp_bicat B Y} {df : dX -->[ f ] dY} {dg : dX -->[ g ] dY} (h : pr1 df ==> pr1 dg) (hh : coherent_homot α h) : df ==>[ α ] dg := h ,, hh. Definition is_disp_invertible_2cell_cod {B : bicat} {X Y : B} {f g : X --> Y} {α : invertible_2cell f g} {dX : cod_disp_bicat B X} {dY : cod_disp_bicat B Y} {ff : dX -->[ f ] dY} {gg : dX -->[ g ] dY} (αα : ff ==>[ α ] gg) (Hαα : is_invertible_2cell (pr1 αα)) : is_disp_invertible_2cell α αα. Proof. use tpair. - use tpair. + exact (Hαα^-1). + abstract (simpl ; use vcomp_move_R_Mp ; is_iso ; simpl ; rewrite !vassocl ; use vcomp_move_L_pM ; is_iso ; simpl ; refine (!_) ; apply αα). - split. + abstract (use subtypePath ; [ intro ; apply B | ] ; simpl ; unfold transportb ; rewrite pr1_transportf ; rewrite transportf_const ; unfold idfun ; cbn ; apply vcomp_rinv). + abstract (use subtypePath ; [ intro ; apply B | ] ; simpl ; unfold transportb ; rewrite pr1_transportf ; rewrite transportf_const ; cbn ; apply vcomp_linv). Defined. Definition transportf_cell_of_cod_over {B : bicat} {b₁ b₂ : B} {f₁ f₂ : b₁ --> b₂} {α β : f₁ ==> f₂} {h₁ : cod_disp_bicat B b₁} {h₂ : cod_disp_bicat B b₂} {ff₁ : h₁ -->[ f₁ ] h₂} {ff₂ : h₁ -->[ f₂ ] h₂} (p : α = β) (αα : ff₁ ==>[ α ] ff₂) : pr1 (transportf (λ z, ff₁ ==>[ z ] ff₂) p αα) = pr1 αα. Proof. cbn. rewrite pr1_transportf, transportf_const. apply idpath. Qed. Definition transportb_cell_of_cod_over {B : bicat} {b₁ b₂ : B} {f₁ f₂ : b₁ --> b₂} {α β : f₁ ==> f₂} {h₁ : cod_disp_bicat B b₁} {h₂ : cod_disp_bicat B b₂} {ff₁ : h₁ -->[ f₁ ] h₂} {ff₂ : h₁ -->[ f₂ ] h₂} (p : α = β) (ββ : ff₁ ==>[ β ] ff₂) : pr1 (transportb (λ z, ff₁ ==>[ z ] ff₂) p ββ) = pr1 ββ. Proof. apply transportf_cell_of_cod_over. Qed. Definition from_is_disp_invertible_2cell_cod {B : bicat} {X Y : B} {f g : X --> Y} {α : invertible_2cell f g} {dX : cod_disp_bicat B X} {dY : cod_disp_bicat B Y} {ff : dX -->[ f ] dY} {gg : dX -->[ g ] dY} (αα : ff ==>[ α ] gg) (Hαα : is_disp_invertible_2cell α αα) : is_invertible_2cell (pr1 αα). Proof. use make_is_invertible_2cell. - exact (pr11 Hαα). - abstract (exact (maponpaths pr1 (pr12 Hαα) @ transportb_cell_of_cod_over _ _)). - abstract (exact (maponpaths pr1 (pr22 Hαα) @ transportb_cell_of_cod_over _ _)). Defined. Definition disp_locally_groupoid_cod (B : bicat) (inv_B : locally_groupoid B) : disp_locally_groupoid (cod_disp_bicat B). Proof. intro ; intros. apply is_disp_invertible_2cell_cod. apply inv_B. Defined. Definition disp_locally_groupoid_cod_one_types : disp_locally_groupoid (cod_disp_bicat one_types). Proof. use disp_locally_groupoid_cod. exact @one_type_2cell_iso. Defined. (** 2. The univalence *) Section UnivalenceOfCodomain. Context (B : bicat). Definition cod_invertible_2_cell_to_disp_invertible_help {c₁ c₂ : B} {f : B ⟦ c₁, c₂ ⟧} {φ₁ : cod_disp_bicat B c₁} {φ₂ : cod_disp_bicat B c₂} {ψ₁ ψ₂ : φ₁ -->[ f] φ₂} (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)) (Hα : coherent_homot (id2_invertible_2cell f) (pr1 α)) : disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂. Proof. simple refine (_ ,, _). - use make_disp_2cell_cod. + exact (pr1 α). + exact Hα. - apply is_disp_invertible_2cell_cod. exact (pr2 α). Defined. Definition cod_invertible_2_cell_to_disp_invertible {c₁ c₂ : B} {f : B ⟦ c₁, c₂ ⟧} {φ₁ : cod_disp_bicat B c₁} {φ₂ : cod_disp_bicat B c₂} {ψ₁ ψ₂ : φ₁ -->[ f] φ₂} : (∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)), coherent_homot (id2_invertible_2cell f) (pr1 α)) → disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂. Proof. intro α. exact (cod_invertible_2_cell_to_disp_invertible_help _ (pr2 α)). Defined. Definition cod_disp_invertible_invertible_2_cell {c₁ c₂ : B} {f : B ⟦ c₁, c₂ ⟧} {φ₁ : cod_disp_bicat B c₁} {φ₂ : cod_disp_bicat B c₂} {ψ₁ ψ₂ : φ₁ -->[ f] φ₂} : disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂ → ∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)), coherent_homot (id2_invertible_2cell f) (pr1 α). Proof. intro α. simple refine ((_ ,, _) ,, _). - exact (pr11 α). - simpl. use make_is_invertible_2cell. + exact (pr1 (disp_inv_cell α)). + abstract (pose (maponpaths pr1 (disp_vcomp_rinv α)) as p ; cbn in p ; unfold transportb in p ; rewrite pr1_transportf, transportf_const in p ; exact p). + abstract (pose (maponpaths pr1 (disp_vcomp_linv α)) as p ; cbn in p ; unfold transportb in p ; rewrite pr1_transportf, transportf_const in p ; exact p). - exact (pr21 α). Defined. Definition cod_invertible_2_cell_weq_disp_invertible {c₁ c₂ : B} {f : B ⟦ c₁, c₂ ⟧} {φ₁ : cod_disp_bicat B c₁} {φ₂ : cod_disp_bicat B c₂} {ψ₁ ψ₂ : φ₁ -->[ f] φ₂} : (∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)), coherent_homot (id2_invertible_2cell f) (pr1 α)) ≃ disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂. Proof. use make_weq. - exact cod_invertible_2_cell_to_disp_invertible. - use isweq_iso. + exact cod_disp_invertible_invertible_2_cell. + abstract (intro α ; use subtypePath ; [ intro ; apply B | ] ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). + abstract (intro α ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; use subtypePath ; [ intro ; apply B | ] ; apply idpath). Defined. Definition cod_2cell_path {c₁ c₂ : B} {f : B ⟦ c₁, c₂ ⟧} {φ₁ : cod_disp_bicat B c₁} {φ₂ : cod_disp_bicat B c₂} {ψ₁ ψ₂ : φ₁ -->[ f ] φ₂} (p : pr1 ψ₁ = pr1 ψ₂) : (transportf (λ x, invertible_2cell (pr2 φ₁ · f) (x · pr2 φ₂)) p (pr2 ψ₁) = pr2 ψ₂) ≃ coherent_homot (id₂ f) (pr1 (idtoiso_2_1 (pr1 ψ₁) (pr1 ψ₂) p)). Proof. induction ψ₁ as [ψ₁ q₁]. induction ψ₂ as [ψ₂ q₂]. cbn in *. induction p. cbn. unfold coherent_homot. cbn. rewrite id2_rwhisker. rewrite id2_right. rewrite lwhisker_id2. rewrite id2_left. apply path_sigma_hprop. apply isaprop_is_invertible_2cell. Qed. Definition cod_disp_univalent_2_1 (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2_1 (cod_disp_bicat B). Proof. use fiberwise_local_univalent_is_univalent_2_1. intros c₁ c₂ f φ₁ φ₂ ψ₁ ψ₂. use weqhomot. - exact (cod_invertible_2_cell_weq_disp_invertible ∘ weqtotal2 (make_weq _ (HB_2_1 _ _ _ _)) cod_2cell_path ∘ total2_paths_equiv _ _ _)%weq. - intro p. induction p. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } use subtypePath. { intro ; apply B. } apply idpath. Defined. Definition cod_1cell_path (HB_2_1 : is_univalent_2_1 B) {c : B} (f₁ f₂ : cod_disp_bicat B c) (p : pr1 f₁ = pr1 f₂) : (transportf (λ b, B ⟦ b, c ⟧) p (pr2 f₁) = pr2 f₂) ≃ invertible_2cell (pr2 f₁) (idtoiso_2_0 _ _ p · pr2 f₂). Proof. induction f₁ as [ c₁ f₁ ]. induction f₂ as [ c₂ f₂ ]. cbn in *. induction p. exact (cod_1cell_path_help f₁ f₂ ∘ make_weq _ (HB_2_1 _ _ _ _))%weq. Defined. Section AdjEquivToDispAdjEquiv. Context {c : B} {f₁ f₂ : cod_disp_bicat B c} (e : adjoint_equivalence (pr1 f₁) (pr1 f₂)) (α : invertible_2cell (pr2 f₁) (pr1 e · pr2 f₂)). Let l : pr1 f₁ --> pr1 f₂ := pr1 e. Let r : pr1 f₂ --> pr1 f₁ := left_adjoint_right_adjoint e. Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso e. Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso e. Definition cod_adj_equiv_to_disp_adj_equiv_map : f₁ -->[ internal_adjoint_equivalence_identity c] f₂. Proof. use make_disp_1cell_cod. - exact l. - refine (runitor _ • α ,, _). is_iso. apply α. Defined. Definition cod_adj_equiv_to_disp_adj_equiv_right_adj : f₂ -->[ internal_adjoint_equivalence_identity c] f₁. Proof. use make_disp_1cell_cod. - exact r. - simpl. use make_invertible_2cell. + refine (runitor _ • linvunitor _ • (ε^-1 ▹ _) • rassociator _ _ _ • (_ ◃ α^-1)). + is_iso. Defined. Definition cod_adj_equiv_to_disp_adj_equiv_unit : pr1 (id_disp f₁) ==> pr1 (cod_adj_equiv_to_disp_adj_equiv_map ;; cod_adj_equiv_to_disp_adj_equiv_right_adj) := η. Definition cod_adj_equiv_to_disp_adj_equiv_unit_homot : coherent_homot (left_adjoint_unit (internal_adjoint_equivalence_identity c)) cod_adj_equiv_to_disp_adj_equiv_unit. Proof. unfold coherent_homot, cod_adj_equiv_to_disp_adj_equiv_unit ; cbn. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !rwhisker_vcomp. rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. rewrite !vassocl. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_lwhisker. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } cbn. refine (!_). etrans. { rewrite !vassocl. rewrite vcomp_whisker. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite !vassocr. rewrite <- vcomp_runitor. apply idpath. } rewrite !vassocl. apply maponpaths ; clear α. rewrite <- runitor_triangle. rewrite !vassocl. do 2 apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. use vcomp_move_R_pM. { is_iso. } cbn. refine (!_). rewrite linvunitor_assoc. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_vcomp. apply maponpaths. assert (linvunitor (pr1 e) • (pr121 (pr2 e) ▹ pr1 e) = rinvunitor _ • (pr1 e ◃ (pr222 (pr2 e))^-1) • lassociator _ _ _) as p. { refine (_ @ id2_left _). use vcomp_move_L_Mp. { is_iso. } cbn. rewrite !vassocr. exact (pr1 (pr122 e)). } apply maponpaths. exact p. } unfold left_adjoint_right_adjoint. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite <- lassociator_lassociator. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (_ @ id2_right _). use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite runitor_rinvunitor. apply id2_rwhisker. } rewrite id2_left. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_rwhisker. apply idpath. Qed. Definition cod_adj_equiv_to_disp_adj_equiv_counit : pr1 (cod_adj_equiv_to_disp_adj_equiv_right_adj ;; cod_adj_equiv_to_disp_adj_equiv_map) ==> pr1 (id_disp f₂) := pr2 (pr212 e). Definition cod_adj_equiv_to_disp_adj_equiv_counit_homot : coherent_homot (left_adjoint_counit (internal_adjoint_equivalence_identity c)) cod_adj_equiv_to_disp_adj_equiv_counit. Proof. unfold coherent_homot, cod_adj_equiv_to_disp_adj_equiv_counit ; cbn. rewrite !vassocl. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite <- rwhisker_vcomp. rewrite !vassocl. assert (rassociator (pr112 e) (pr1 e) (pr2 f₂) ▹ id₁ c • rassociator (pr112 e) (pr1 e · pr2 f₂) (id₁ c) • (pr112 e ◃ runitor (pr1 e · pr2 f₂)) • lassociator (pr112 e) (pr1 e) (pr2 f₂) = runitor _) as p. { rewrite !vassocl. rewrite !left_unit_assoc. rewrite !vassocl. rewrite <- vcomp_runitor. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rassociator_lassociator. rewrite id2_rwhisker. apply id2_left. } rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. exact p. } rewrite <- vcomp_runitor. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite vcomp_linv. rewrite !id2_rwhisker. apply idpath. } rewrite id2_left. rewrite vcomp_runitor. apply idpath. Qed. Definition cod_adj_equiv_to_disp_adj_equiv_disp_adj : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) cod_adj_equiv_to_disp_adj_equiv_map. Proof. simple refine (_ ,, (_ ,, _)). - simple refine (_ ,, (_ ,, _)). + apply cod_adj_equiv_to_disp_adj_equiv_right_adj. + use make_disp_2cell_cod. * apply cod_adj_equiv_to_disp_adj_equiv_unit. * exact cod_adj_equiv_to_disp_adj_equiv_unit_homot. + use make_disp_2cell_cod. * apply cod_adj_equiv_to_disp_adj_equiv_counit. * exact cod_adj_equiv_to_disp_adj_equiv_counit_homot. - simple refine (_ ,, _). + cbn. use subtypePath. { intro. apply B. } cbn. etrans. { exact (pr1 (pr122 e)). } refine (!_). refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _). rewrite transportf_const. apply idpath. + cbn. use subtypePath. { intro. apply B. } cbn. etrans. { exact (pr2 (pr122 e)). } refine (!_). refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _). rewrite transportf_const. apply idpath. - split. + apply is_disp_invertible_2cell_cod ; cbn. apply η. + apply is_disp_invertible_2cell_cod ; cbn. apply ε. Qed. Definition cod_adj_equiv_to_disp_adj_equiv_help : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂. Proof. simple refine (_ ,, _). - exact cod_adj_equiv_to_disp_adj_equiv_map. - exact cod_adj_equiv_to_disp_adj_equiv_disp_adj. Defined. End AdjEquivToDispAdjEquiv. Definition cod_adj_equiv_to_disp_adj_equiv {c : B} {f₁ f₂ : cod_disp_bicat B c} : (∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)), invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂)) → disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂. Proof. intro e. exact (cod_adj_equiv_to_disp_adj_equiv_help (pr1 e) (pr2 e)). Defined. Definition cod_disp_adj_equiv_to_adj_equiv {c : B} {f₁ f₂ : cod_disp_bicat B c} : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂ → ∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)), invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂). Proof. intro e. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (pr11 e). + simpl. simple refine (_ ,, (_ ,, _)). * simple refine (_ ,, (_ ,, _)). ** exact (pr1 (pr112 e)). ** exact (pr11 (pr212 e)). ** exact (pr12 (pr212 e)). * split. ** abstract (refine (maponpaths pr1 (pr1 (pr122 e)) @ _) ; unfold transportb ; cbn ; refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _) ; rewrite transportf_const ; apply idpath). ** abstract (refine (maponpaths pr1 (pr2 (pr122 e)) @ _) ; unfold transportb ; cbn ; refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _) ; rewrite transportf_const ; apply idpath). * split. ** exact (from_is_disp_invertible_2cell_cod _ (pr12 (pr22 e))). ** exact (from_is_disp_invertible_2cell_cod _ (pr22 (pr22 e))). - refine (rinvunitor _ • pr121 e ,, _). is_iso. exact (pr221 e). Defined. Definition cod_adj_equiv_to_disp_to_adj (HB_2_1 : is_univalent_2_1 B) {c : B} {f₁ f₂ : cod_disp_bicat B c} (e : ∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)), invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂)) : cod_disp_adj_equiv_to_adj_equiv (cod_adj_equiv_to_disp_adj_equiv e) = e. Proof. use total2_paths_f. - simpl. use subtypePath. { intro ; apply isaprop_left_adjoint_equivalence. exact HB_2_1. } apply idpath. - unfold subtypePath. etrans. { apply (transportf_total2_paths_f (λ x, invertible_2cell (pr2 f₁) (x · pr2 f₂))). } cbn. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite vassocr. rewrite rinvunitor_runitor. apply id2_left. Qed. Definition cod_disp_adj_to_adj_to_disp (HB_2_1 : is_univalent_2_1 B) {c : B} {f₁ f₂ : cod_disp_bicat B c} (e : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂) : cod_adj_equiv_to_disp_adj_equiv (cod_disp_adj_equiv_to_adj_equiv e) = e. Proof. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact HB_2_1. - apply cod_disp_univalent_2_1. exact HB_2_1. } cbn. unfold cod_adj_equiv_to_disp_adj_equiv_map, make_disp_1cell_cod. use maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite vassocr. rewrite runitor_rinvunitor. apply id2_left. Qed. Definition cod_adj_equiv_weq_disp_adj_equiv (HB_2_1 : is_univalent_2_1 B) {c : B} (f₁ f₂ : cod_disp_bicat B c) : (∑ y : adjoint_equivalence (pr1 f₁) (pr1 f₂), invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂)) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂. Proof. use make_weq. - exact cod_adj_equiv_to_disp_adj_equiv. - use isweq_iso. + exact cod_disp_adj_equiv_to_adj_equiv. + exact (cod_adj_equiv_to_disp_to_adj HB_2_1). + exact (cod_disp_adj_to_adj_to_disp HB_2_1). Defined. Definition cod_disp_univalent_2_0 (HB_2 : is_univalent_2 B) : disp_univalent_2_0 (cod_disp_bicat B). Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros c f₁ f₂. use weqhomot. - exact (cod_adj_equiv_weq_disp_adj_equiv (pr2 HB_2) f₁ f₂ ∘ weqtotal2 (make_weq _ (pr1 HB_2 _ _)) (cod_1cell_path (pr2 HB_2) f₁ f₂) ∘ total2_paths_equiv _ _ _)%weq. - intro p. cbn in p. induction p. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact (pr2 HB_2). - apply cod_disp_univalent_2_1. exact (pr2 HB_2). } cbn ; unfold cod_adj_equiv_to_disp_adj_equiv_map, make_disp_1cell_cod ; cbn. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite id2_left. apply idpath. Qed. Definition cod_disp_univalent_2 (HB_2 : is_univalent_2 B) : disp_univalent_2 (cod_disp_bicat B). Proof. split. - exact (cod_disp_univalent_2_0 HB_2). - exact (cod_disp_univalent_2_1 (pr2 HB_2)). Defined. End UnivalenceOfCodomain. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Cofunctormap.v000066400000000000000000000200241451125700300267230ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) (* ============================================================================================= *) (* Displayed transformation of contravariant functors. *) (* ============================================================================================= *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.ContravariantFunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Local Open Scope cat. Local Open Scope mor_disp_scope. Arguments nat_trans_comp {C C' F G H} a b. Section Cofunctormaps. Variable (K : univalent_category). Definition disp_presheaf : disp_bicat bicat_of_univ_cats := disp_presheaf_bicat K. Definition disp_two_presheaves : disp_bicat bicat_of_univ_cats := disp_dirprod_bicat disp_presheaf disp_presheaf. Definition disp_two_presheaves_is_univalent_2_1 : disp_univalent_2_1 disp_two_presheaves. Proof. apply is_univalent_2_1_dirprod_bicat. - exact (disp_presheaves_is_univalent_2_1 K). - exact (disp_presheaves_is_univalent_2_1 K). Defined. Definition disp_two_presheaves_is_univalent_2_0 : disp_univalent_2_0 disp_two_presheaves. Proof. apply is_univalent_2_0_dirprod_bicat. - exact univalent_cat_is_univalent_2_1. - exact (disp_presheaves_is_univalent_2 K). - exact (disp_presheaves_is_univalent_2 K). Defined. Definition disp_two_presheaves_is_univalent_2 : disp_univalent_2 disp_two_presheaves. Proof. split. - exact disp_two_presheaves_is_univalent_2_0. - exact disp_two_presheaves_is_univalent_2_1. Defined. Definition disp_cofunctormaps_cat_ob_mor : disp_cat_ob_mor (total_bicat disp_two_presheaves). Proof. red. use tpair. - intros (C, (ty, tm)). cbn in *. exact (tm ⟹ ty). - intros (C, (ty, tm)) (C', (ty', tm')) p p' (f, (αty, αtm)). cbn in *. exact (nat_trans_comp p αty = nat_trans_comp αtm (pre_whisker _ p')). Defined. Definition disp_cofunctormaps_cat_id_comp : disp_cat_id_comp _ disp_cofunctormaps_cat_ob_mor. Proof. apply tpair. - intros (C, (ty, tm)) p. apply nat_trans_eq. + apply homset_property. + cbn. intros. etrans. * apply id_right. * apply pathsinv0. apply id_left. - intros (C, (ty, tm)). intros (C', (ty', tm')). intros (C'', (ty'', tm'')). cbn in *. intros (f, (αty,αtm)). intros (g, (βty,βtm)). cbn in *. intros p p' p''. cbn in *. intros eq1 eq2. apply nat_trans_eq. + apply homset_property. + cbn. intros x. set (h1 := nat_trans_eq_pointwise eq1 x). set (h2 := nat_trans_eq_pointwise eq2 (f x)). cbn in *. rewrite assoc. rewrite h1. rewrite <- assoc. rewrite <- assoc. apply maponpaths. apply h2. Defined. Definition disp_cofunctormaps_cat_data : disp_cat_data (total_bicat disp_two_presheaves) := (_ ,, disp_cofunctormaps_cat_id_comp). Definition disp_cofunctormaps_bicat : disp_bicat (total_bicat disp_two_presheaves) := disp_cell_unit_bicat disp_cofunctormaps_cat_data. Definition morphisms_of_presheaves_display : disp_bicat bicat_of_univ_cats. Proof. use sigma_bicat. - apply disp_two_presheaves. - exact disp_cofunctormaps_bicat. Defined. Definition morphisms_of_presheaves : bicat := total_bicat morphisms_of_presheaves_display. Definition disp_cofunctormaps_bicat_univalent_2_1 : disp_univalent_2_1 disp_cofunctormaps_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η x y ; simpl in *. apply isaset_nat_trans. apply homset_property. Qed. Definition morphisms_of_presheaves_univalent_2_1 : is_univalent_2_1 morphisms_of_presheaves. Proof. apply sigma_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_two_presheaves_is_univalent_2_1. - exact disp_cofunctormaps_bicat_univalent_2_1. Defined. Definition disp_cofunctormaps_bicat_univalent_2_0 : disp_univalent_2_0 disp_cofunctormaps_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_0. + apply total_is_univalent_2_1. * exact univalent_cat_is_univalent_2_1. * exact disp_two_presheaves_is_univalent_2_1. + intros F G η x y ; simpl in *. apply isaset_nat_trans. apply homset_property. + intros a ; simpl. apply isaset_nat_trans. apply homset_property. + intros F α₁ α₂ X ; cbn in *. induction X as [X1 X2] ; cbn in *. apply nat_trans_eq. { apply homset_property. } intros x ; cbn in *. pose (nat_trans_eq_pointwise X1 x) as p1. cbn in *. rewrite id_left, id_right in p1. exact p1. Qed. Definition disp_cofunctormaps_bicat_univalent_2 : disp_univalent_2 disp_cofunctormaps_bicat. Proof. split. - exact disp_cofunctormaps_bicat_univalent_2_0. - exact disp_cofunctormaps_bicat_univalent_2_1. Defined. Definition morphisms_of_presheaves_univalent_2_0 : is_univalent_2_0 morphisms_of_presheaves. Proof. apply sigma_is_univalent_2_0. - exact univalent_cat_is_univalent_2. - exact disp_two_presheaves_is_univalent_2. - exact disp_cofunctormaps_bicat_univalent_2. Defined. Definition morphisms_of_presheaves_univalent_2 : is_univalent_2 morphisms_of_presheaves. Proof. split. - exact morphisms_of_presheaves_univalent_2_0. - exact morphisms_of_presheaves_univalent_2_1. Defined. Definition disp_2cells_isaprop_cofunctormaps : disp_2cells_isaprop disp_cofunctormaps_bicat := disp_2cells_isaprop_cell_unit_bicat disp_cofunctormaps_cat_data. Definition disp_locally_groupoid_cofunctormaps : disp_locally_groupoid disp_cofunctormaps_bicat := disp_locally_groupoid_cell_unit_bicat disp_cofunctormaps_cat_data. Definition disp_2cells_isaprop_morphisms_of_presheaves_display : disp_2cells_isaprop morphisms_of_presheaves_display. Proof. apply disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf. - apply disp_2cells_isaprop_cofunctormaps. Qed. Definition disp_locally_groupoid_morphisms_of_presheaves_display : disp_locally_groupoid morphisms_of_presheaves_display. Proof. apply disp_locally_groupoid_sigma. - exact univalent_cat_is_univalent_2. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf. - apply disp_2cells_isaprop_cofunctormaps. - apply disp_locally_groupoid_prod ; apply disp_locally_groupoid_presheaf. - exact disp_locally_groupoid_cofunctormaps. Qed. End Cofunctormaps. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/ContravariantFunctor.v000066400000000000000000000253441451125700300304510ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 Displayed bicategory of contravariant functors into a fixed category K. ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope bicategory_scope. Section fix_a_category. Local Notation "∁" := bicat_of_univ_cats. Variable (K : univalent_category). Definition disp_presheaf_cat_ob_mor : disp_cat_ob_mor ∁. Proof. use tpair. + exact (λ c : univalent_category, functor (op_unicat c) K). + cbn. intros c d ty ty' f. exact (nat_trans ty (functor_composite (functor_opp f) ty')). Defined. Definition disp_presheaf_cat_data : disp_cat_data ∁. Proof. exists disp_presheaf_cat_ob_mor. use tpair. + intros c f. set (T:= nat_trans_id (pr1 f) ). exact T. + intros c d e f g ty ty' ty''. intros x y. set (T1 := x). set (T2 := @pre_whisker (op_unicat c) (op_unicat d) K (functor_opp f) _ _ (y : nat_trans (ty': functor _ _ ) _ )). exact (@nat_trans_comp (op_unicat c) K _ _ _ T1 T2 ). Defined. Definition disp_presheaf_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. exists disp_presheaf_cat_data. intros c d f g a. intros p p'. intros x y. exact (x = @nat_trans_comp (op_unicat c) K _ _ _ y (post_whisker (op_nt a) p')). Defined. Definition disp_presheaf_prebicat_ops : disp_prebicat_ops disp_presheaf_prebicat_1_id_comp_cells. Proof. repeat split; cbn. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id y). apply pathsinv0, id_right. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id y). rewrite id_left, id_right. apply idpath. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id y). apply idpath. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id y). rewrite id_left, id_right. apply idpath. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id y). repeat rewrite id_right. apply idpath. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id z). rewrite id_right. apply pathsinv0, assoc. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. intro. rewrite (functor_id z). rewrite id_right. apply assoc. - intros. apply nat_trans_eq; try apply (homset_property K). intro. rewrite X. rewrite X0. cbn. pose (T:= @functor_comp (op_cat b) _ y). rewrite <- assoc. rewrite <- T. apply idpath. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. rewrite X. intro. apply assoc. - intros. apply nat_trans_eq; try apply (homset_property K); cbn. rewrite X. intros. cbn. pose (T:= nat_trans_ax gg). cbn in T. rewrite <- assoc. rewrite T. apply assoc. Qed. Definition disp_presheaf_prebicat_data : disp_prebicat_data ∁ := _ ,, disp_presheaf_prebicat_ops. Lemma disp_presheaf_prebicat_laws : disp_prebicat_laws disp_presheaf_prebicat_data. Proof. repeat split; intro; intros; apply isaset_nat_trans; apply homset_property. Qed. Definition disp_presheaf_prebicat : disp_prebicat ∁ := (disp_presheaf_prebicat_data,, disp_presheaf_prebicat_laws). Lemma has_disp_cellset_disp_presheaf_prebicat : has_disp_cellset disp_presheaf_prebicat. Proof. red. intros. unfold disp_2cells. cbn. apply isasetaprop. cbn in *. apply isaset_nat_trans. apply homset_property. Qed. Definition disp_presheaf_bicat : disp_bicat ∁ := (disp_presheaf_prebicat,, has_disp_cellset_disp_presheaf_prebicat). Definition disp_presheaves_all_invertible {C D : ∁} {F G : ∁⟦C, D⟧} (α : invertible_2cell F G) {CD : disp_presheaf_bicat C} {FC : disp_presheaf_bicat D} {γF : CD -->[ F] FC} {γG : CD -->[ G ] FC} (p : disp_2cells α γF γG) : is_disp_invertible_2cell α p. Proof. use tpair. - apply nat_trans_eq. { apply homset_property. } intro x. refine (!_). refine (maponpaths (λ z, z · _) (nat_trans_eq_pointwise p x) @ _). refine (!(assoc _ _ _) @ _). refine (maponpaths (λ z, _ · z) (!(functor_comp FC _ _)) @ _). etrans. { do 2 apply maponpaths. exact (nat_trans_eq_pointwise (pr222 α) x). } etrans. { apply maponpaths. apply (functor_id FC). } apply id_right. - split ; apply isaset_nat_trans ; apply homset_property. Qed. Definition disp_presheaves_is_univalent_2_1 : disp_univalent_2_1 disp_presheaf_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros C D F CD FC α β. use isweqimplimpl. - intro p ; cbn in *. apply nat_trans_eq. { apply homset_property. } intro x. pose (nat_trans_eq_pointwise (pr1 p) x) as q. cbn in q. rewrite q. rewrite (functor_id FC), id_right. reflexivity. - apply isaset_nat_trans. apply homset_property. - apply isofhleveltotal2. + apply isaset_nat_trans. apply homset_property. + intro. apply isaprop_is_disp_invertible_2cell. Qed. Definition disp_presheaves_adjequiv {C : ∁} (FC FC' : disp_presheaf_bicat C) : @invertible_2cell bicat_of_univ_cats _ _ FC FC' -> disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'. Proof. intros α. use tpair. - apply α. - use tpair. + use tpair. * apply α. * split ; apply nat_trans_eq ; try (apply homset_property) ; intro x ; cbn. ** rewrite (functor_id FC), id_right. exact (!(nat_trans_eq_pointwise (pr122 α) x)). ** rewrite (functor_id FC'), id_left. exact (nat_trans_eq_pointwise (pr222 α) x). + split ; split. * apply isaset_nat_trans. apply homset_property. * apply isaset_nat_trans. apply homset_property. * apply disp_presheaves_all_invertible. * apply disp_presheaves_all_invertible. Defined. Definition disp_presheaves_adjequiv_inv {C : ∁} (FC FC' : disp_presheaf_bicat C) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC' → @invertible_2cell bicat_of_univ_cats _ _ FC FC'. Proof. intros α. use tpair. - apply α. - use tpair. + apply α. + split. * apply nat_trans_eq. { apply homset_property. } intro x ; cbn. pose (nat_trans_eq_pointwise (pr1(pr212 α)) x) as p. cbn in p. rewrite (functor_id FC), id_right in p. exact (!p). * apply nat_trans_eq. { apply homset_property. } intro x ; cbn. pose (nat_trans_eq_pointwise (pr2(pr212 α)) x) as p. cbn in p. rewrite (functor_id FC'), id_right in p. exact p. Defined. Definition disp_presheaves_adjequiv_weq {C : ∁} (FC FC' : disp_presheaf_bicat C) : @invertible_2cell bicat_of_univ_cats _ _ FC FC' ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'. Proof. exists (disp_presheaves_adjequiv FC FC'). use isweq_iso. - exact (disp_presheaves_adjequiv_inv FC FC'). - intro x. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } reflexivity. - intro x. apply subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. + apply univalent_cat_is_univalent_2_1. + apply disp_presheaves_is_univalent_2_1. } reflexivity. Defined. Definition disp_presheaves_idtoiso_2_0 {C : ∁} (FC FC' : disp_presheaf_bicat C) : FC = FC' ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC' := ((disp_presheaves_adjequiv_weq FC FC') ∘ (make_weq (@idtoiso_2_1 bicat_of_univ_cats _ _ FC FC') (univalent_cat_is_univalent_2_1 _ _ _ _)))%weq. Definition disp_presheaves_is_univalent_2_0 : disp_univalent_2_0 disp_presheaf_bicat. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros C FC FC'. use weqhomot. - exact (disp_presheaves_idtoiso_2_0 FC FC'). - intro p. apply subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. + apply univalent_cat_is_univalent_2_1. + apply disp_presheaves_is_univalent_2_1. } induction p ; cbn. reflexivity. Defined. Definition disp_presheaves_is_univalent_2 : disp_univalent_2 disp_presheaf_bicat. Proof. split. - exact disp_presheaves_is_univalent_2_0. - exact disp_presheaves_is_univalent_2_1. Defined. Definition disp_2cells_isaprop_presheaf : disp_2cells_isaprop disp_presheaf_bicat. Proof. intro; intros. apply isaset_nat_trans. apply homset_property. Qed. Definition disp_locally_groupoid_presheaf : disp_locally_groupoid disp_presheaf_bicat. Proof. intro; intros. apply disp_presheaves_all_invertible. Qed. End fix_a_category. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/CwF.v000066400000000000000000000341021451125700300247440ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) (* ============================================================================================= *) (* Categories with Families (CwF). *) (* *) (* The bicategory of CwF implemented as iterated displayed bicategories on Cat (the *) (* bicategory of categories). *) (* ============================================================================================= *) (* Foundations. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. (* Categories. *) Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.whiskering. Require Export UniMath.CategoryTheory.yoneda. Require Export UniMath.CategoryTheory.limits.pullbacks. (* Displayed categories. *) Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. (* (Displayed) Bicategories. *) Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.ContravariantFunctor. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Cofunctormap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Local Open Scope cat. Local Open Scope mor_disp_scope. Local Notation "'SET'" := HSET_univalent_category. Local Notation "'PreShv' C" := [C^op,SET] (at level 4) : cat. Local Notation "'Yo'" := (yoneda _ : functor _ (PreShv _)). Section Yoneda. Context {C : category} {hsC : has_homsets C}. Definition yy {F : PreShv C} {c : C} : ((F : C^op ⟶ SET) c : hSet) ≃ [C^op, HSET, has_homsets_HSET] ⟦ yoneda C c, F⟧. Proof. apply invweq. apply yoneda_weq. Defined. Lemma yy_natural (F : PreShv C) (c : C) (A : (F : C^op ⟶ SET) c : hSet) c' (f : C⟦c', c⟧) : yy (functor_on_morphisms (F : C^op ⟶ SET) f A) = functor_on_morphisms (yoneda C) f · yy A. Proof. assert (XTT := is_natural_yoneda_iso_inv _ F _ _ f). apply (toforallpaths _ _ _ XTT). Qed. Lemma yy_comp_nat_trans (F F' : PreShv C) (p : _ ⟦F, F'⟧) A (v : (F : C^op ⟶ SET) A : hSet) : yy v · p = yy ((p : nat_trans _ _ ) _ v). Proof. apply nat_trans_eq. - apply has_homsets_HSET. - intro c. simpl. apply funextsec. intro f. cbn. assert (XR := toforallpaths _ _ _ (nat_trans_ax p _ _ f) v ). cbn in XR. apply XR. Qed. End Yoneda. (* Adapted from TypeTheory/TypeTheory/Auxiliary/Auxiliary.v TypeTheory/ALV1/CwF_def.v *) (* Section Representation. Context {C : category} {Ty Tm : opp_precat_data C ⟶ SET} (pp : Tm ⟹ Ty). Definition map_into (Γ : C) : UU := ∑ (ΓA : C), C ⟦ΓA, Γ⟧. Definition cwf_tm_of_ty {Γ : C} (A : Ty Γ : hSet) : UU := ∑ (t : (Tm Γ : hSet)), (pp : nat_trans _ _) _ t = A. Lemma cwf_square_comm {Γ} {A} {ΓA : C} {π : ΓA --> Γ} {t : Tm ΓA : hSet} (e : (pp : nat_trans _ _) _ t = functor_on_morphisms Ty π A) : functor_on_morphisms Yo π · yy A = yy t · pp. Proof. apply pathsinv0. etrans. 2: apply yy_natural. etrans. apply yy_comp_nat_trans. apply maponpaths, e. Qed. Definition cwf_fiber_representation {Γ : C} (A : Ty Γ : hSet) : UU := ∑ (ΓAπ : map_into Γ) (te : cwf_tm_of_ty (functor_on_morphisms Ty (pr2 ΓAπ) A)), isPullback _ _ _ _ (cwf_square_comm (pr2 te)). Definition cwf_representation : UU := ∏ Γ (A : Ty Γ : hSet), cwf_fiber_representation A. End Representation. *) Lemma transportf_yy {C : category} (F : opp_precat_data C ⟶ SET) (c c' : C) (A : (F : functor _ _ ) c : hSet) (e : c = c') (* TODO: see #1470 *) : paths (pr1weq (@yy C F c') (@transportf _ (fun d => pr1hSet (functor_on_objects F d : hSet)) _ _ e A)) (@transportf _ (fun d => nat_trans _ F) _ _ e (pr1weq (@yy C F c) A)). Proof. induction e. apply idpath. Defined. Lemma inv_from_z_iso_iso_from_fully_faithful_reflection {C D : precategory} (F : functor C D) (HF : fully_faithful F) (a b : C) (i : z_iso (F a) (F b)) : inv_from_z_iso (iso_from_fully_faithful_reflection HF i) = iso_from_fully_faithful_reflection HF (z_iso_inv_from_z_iso i). Proof. apply idpath. Defined. Section CwFRepresentation. Context {C : category} {Ty Tm : opp_precat_data C ⟶ SET} (pp : Tm ⟹ Ty) (HC : is_univalent C). Definition cwf_fiber_rep_data {Γ:C} (A : Ty Γ : hSet) : UU := ∑ (ΓA : C), C ⟦ΓA, Γ⟧ × (Tm ΓA : hSet). Lemma cwf_square_comm {Γ} {A} {ΓA : C} {π : ΓA --> Γ} {t : Tm ΓA : hSet} (e : (pp : nat_trans _ _) _ t = functor_on_morphisms Ty π A) (* TODO: see #1470 *) : @paths _ (@compose _ _ (@functor_on_objects _ (functor_category _ HSET_univalent_category) _ Γ) Ty (functor_on_morphisms _ π) (pr1weq (@yy C Ty Γ) A)) (@compose _ (@functor_on_objects _ (functor_category _ hset_category) _ ΓA) Tm Ty (pr1weq (@yy C Tm ΓA) t) pp). Proof. apply pathsinv0. etrans. 2: apply yy_natural. etrans. { apply yy_comp_nat_trans. } apply maponpaths, e. Qed. Definition cwf_fiber_rep_ax {Γ:C} {A : Ty Γ : hSet} (ΓAπt : cwf_fiber_rep_data A) : UU := ∑ (H : pp _ (pr2 (pr2 ΓAπt)) = (#Ty)%cat (pr1 (pr2 ΓAπt)) A), isPullback (cwf_square_comm H). Definition cwf_fiber_representation {Γ:C} (A : Ty Γ : hSet) : UU := ∑ ΓAπt : cwf_fiber_rep_data A, cwf_fiber_rep_ax ΓAπt. Lemma isaprop_cwf_fiber_representation {Γ:C} (A : Ty Γ : hSet) : is_univalent C -> isaprop (cwf_fiber_representation A). Proof. intro isC. apply invproofirrelevance. intros x x'. apply subtypePath. { intro. apply isofhleveltotal2. - apply setproperty. - intro. apply isaprop_isPullback. } destruct x as [x H]. destruct x' as [x' H']. cbn. destruct x as [ΓA m]. destruct x' as [ΓA' m']. cbn in *. destruct H as [H isP]. destruct H' as [H' isP']. use (total2_paths_f). - set (T1 := make_Pullback _ isP). set (T2 := make_Pullback _ isP'). set (i := z_iso_from_Pullback_to_Pullback T1 T2). cbn in i. set (i' := invmap (weq_ff_functor_on_z_iso (yoneda_fully_faithful _) _ _ ) i ). set (TT := isotoid _ isC i'). apply TT. - cbn. set (XT := transportf_dirprod _ (fun a' => C⟦a', Γ⟧) (fun a' => Tm a' : hSet)). cbn in XT. set (XT' := XT (tpair _ ΓA m : ∑ R : C, C ⟦ R, Γ ⟧ × (Tm R : hSet) ) (tpair _ ΓA' m' : ∑ R : C, C ⟦ R, Γ ⟧ × (Tm R : hSet) )). cbn in *. match goal with | [ |- transportf _ ?e _ = _ ] => set (TT := e) end. rewrite XT'. clear XT' XT. destruct m as [π te]. destruct m' as [π' te']. cbn. apply pathsdirprod. + unfold TT; clear TT. rewrite transportf_isotoid. cbn. unfold from_Pullback_to_Pullback. cbn in *. pose (XR' := nat_trans_eq_pointwise (PullbackArrow_PullbackPr1 (make_Pullback _ isP) (yoneda_objects C ΓA') (yoneda_morphisms C ΓA' Γ π') (yoneda_map_2 C ΓA' Tm te') (PullbackSqrCommutes (make_Pullback _ isP'))) ΓA'). cbn in XR'. assert (XR'':= toforallpaths _ _ _ XR'). cbn in XR''. etrans. { apply XR''. } apply id_left. + unfold TT; clear TT. match goal with |[|- transportf ?r _ _ = _ ] => set (P:=r) end. match goal with |[|- transportf _ (_ _ _ (_ _ ?ii)) _ = _ ] => set (i:=ii) end. simpl in i. apply (invmaponpathsweq (@yy _ Tm ΓA')). etrans. { apply transportf_yy. } etrans. { apply (@transportf_functor_isotoid C (functor_category _ SET)). } rewrite inv_from_z_iso_iso_from_fully_faithful_reflection. assert (XX:=homotweqinvweq (weq_from_fully_faithful (yoneda_fully_faithful _) ΓA' ΓA )). etrans. { apply maponpaths_2. apply XX. } clear XX. etrans. { apply maponpaths_2. unfold from_Pullback_to_Pullback. apply idpath. } pose (XR' := PullbackArrow_PullbackPr2 (make_Pullback _ isP) (yoneda_objects C ΓA') (yoneda_morphisms C ΓA' Γ π') (yoneda_map_2 C ΓA' Tm te') (PullbackSqrCommutes (make_Pullback _ isP'))). apply XR'. Qed. Definition cwf_representation : UU := ∏ Γ (A : Ty Γ : hSet), cwf_fiber_representation A. Definition isaprop_cwf_representation : isaprop cwf_representation. Proof. do 2 (apply impred ; intro). apply isaprop_cwf_fiber_representation. exact HC. Defined. End CwFRepresentation. Section Projections. Context {C : category} {Ty Tm : opp_precat_data C ⟶ SET} {pp : Tm ⟹ Ty}. Variable (R : cwf_representation pp). Variable (Γ : C) (A : Ty Γ : hSet). Definition ext : C := pr1 (pr1 (R Γ A)). Definition π : C⟦ext,Γ⟧ := pr121 (R Γ A). Definition var : (Tm ext:hSet) := pr221 (R Γ A). Definition comm : pp ext var = functor_on_morphisms Ty π A := pr12 (R Γ A). Definition pullback : isPullback (cwf_square_comm pp comm) := pr2 (pr2 (R Γ A)). End Projections. Arguments iso _ _ _ : clear implicits. Section CwF. Definition disp_cwf' : disp_bicat (morphisms_of_presheaves SET). Proof. refine (disp_fullsubbicat (morphisms_of_presheaves SET) _). intros (C, ((Ty, Tm), pp)). cbn in *. exact (@cwf_representation C _ _ pp). Defined. Definition disp_cwf : disp_bicat bicat_of_univ_cats := sigma_bicat _ _ disp_cwf'. Definition disp_2cells_isaprop_disp_cwf : disp_2cells_isaprop disp_cwf. Proof. apply disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_morphisms_of_presheaves_display. - apply disp_2cells_isaprop_fullsubbicat. Qed. Definition disp_locally_groupoid_disp_cwf : disp_locally_groupoid disp_cwf. Proof. apply disp_locally_groupoid_sigma. - exact univalent_cat_is_univalent_2. - apply disp_2cells_isaprop_morphisms_of_presheaves_display. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_locally_groupoid_morphisms_of_presheaves_display. - apply disp_locally_groupoid_fullsubbicat. Qed. Definition cwf : bicat := total_bicat disp_cwf. Lemma disp_univalent_2_1_morphisms_of_presheaf_display : disp_univalent_2_1 (morphisms_of_presheaves_display SET). Proof. apply sigma_disp_univalent_2_1_with_props. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf. - apply disp_2cells_isaprop_cofunctormaps. - apply disp_two_presheaves_is_univalent_2_1. - apply disp_cofunctormaps_bicat_univalent_2_1. Qed. Lemma disp_univalent_2_0_morphisms_of_presheaf_display : disp_univalent_2_0 (morphisms_of_presheaves_display SET). Proof. apply sigma_disp_univalent_2_0_with_props. - exact univalent_cat_is_univalent_2. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_presheaf. - apply disp_2cells_isaprop_cofunctormaps. - apply disp_two_presheaves_is_univalent_2_1. - apply disp_cofunctormaps_bicat_univalent_2_1. - apply disp_locally_groupoid_prod ; apply disp_locally_groupoid_presheaf. - apply disp_locally_groupoid_cofunctormaps. - apply disp_two_presheaves_is_univalent_2_0. - apply disp_cofunctormaps_bicat_univalent_2_0. Qed. Definition cwf_is_univalent_2_1 : is_univalent_2_1 cwf. Proof. apply sigma_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_morphisms_of_presheaf_display. - apply disp_fullsubbicat_univalent_2_1. Qed. Definition cwf_is_univalent_2_0 : is_univalent_2_0 cwf. Proof. apply sigma_is_univalent_2_0. - exact univalent_cat_is_univalent_2. - split. + exact disp_univalent_2_0_morphisms_of_presheaf_display. + exact disp_univalent_2_1_morphisms_of_presheaf_display. - split. + apply disp_univalent_2_0_fullsubbicat. * apply morphisms_of_presheaves_univalent_2. * intros C. apply isaprop_cwf_representation. apply (pr1 C). + apply disp_fullsubbicat_univalent_2_1. Qed. Definition cwf_is_univalent_2 : is_univalent_2 cwf. Proof. split. - exact cwf_is_univalent_2_0. - exact cwf_is_univalent_2_1. Defined. End CwF. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DispBicatOfDispCats.v000066400000000000000000000761611451125700300300620ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 Displayed bicategory of displayed structures on 1-categories. Contents 1. The displayed bicategory of displayed categories 2. Invertible 2-cells in the displayed bicategory of displayed categories 3. The local univalence 4. Adjoints equivalences 5. The global univalence ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedFunctorEq. Require Import UniMath.CategoryTheory.DisplayedCats.EquivalenceOverId. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedCatEq. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Local Open Scope cat. Local Open Scope mor_disp_scope. (** 1. The displayed bicategory of displayed categories *) Definition disp_bicat_of_univ_disp_cats_disp_cat_data : disp_cat_data bicat_of_univ_cats. Proof. use tpair. - use tpair. + exact (λ C : univalent_category, disp_univalent_category C). + intros C C' D D' F. exact (disp_functor F D D'). - use tpair; cbn. + intros C D. apply disp_functor_identity. + cbn. intros C C' C'' F F' D D' D'' G G'. apply (disp_functor_composite G G'). Defined. Definition disp_bicat_of_univ_disp_cats_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. exists disp_bicat_of_univ_disp_cats_disp_cat_data. cbn. intros C C' F F' a D D' G G'. cbn in *. apply (disp_nat_trans a G G'). Defined. Definition disp_prebicat_of_univ_disp_cats_data : disp_prebicat_data bicat_of_univ_cats. Proof. exists disp_bicat_of_univ_disp_cats_1_id_comp_cells. repeat split. - intros ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id F'). - intros ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id F'). - intros ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id F'). - intros ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id F'). - intros ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id F'). - intros ? ? ? ? ? ? ? ? ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id (disp_functor_composite_data (disp_functor_composite ff gg) F')). - intros ? ? ? ? ? ? ? ? ? ? ? ? ? F' ; cbn in *. exact (disp_nat_trans_id (disp_functor_composite_data (disp_functor_composite ff gg) F')). - intros C D ? ? ? ? ? ? ? ? ? ? rr ss ; cbn in *. exact (@disp_nat_trans_comp C _ _ _ _ _ _ _ _ _ _ _ rr ss). - intros C₁ C₂ C₃ f g₁ g₂ r D₁ D₂ D₃ ff gg₁ gg₂ rr ; cbn in *. exact (@pre_whisker_disp_nat_trans C₁ C₂ _ _ _ _ _ _ _ _ _ _ _ rr). - intros C₁ C₂ C₃ ? ? ? ? ? ? ? ? ? ? rr ; cbn in *. exact (@post_whisker_disp_nat_trans C₁ C₂ _ _ _ _ _ _ _ _ _ _ rr _). Defined. Lemma disp_prebicat_of_univ_disp_cats_laws : disp_prebicat_laws disp_prebicat_of_univ_disp_cats_data. Proof. repeat split ; red ; intros; intros ; apply (@disp_nat_trans_eq) ; intros ; apply pathsinv0 ; unfold transportb ; (etrans ; [ apply disp_nat_trans_transportf | ]). - apply pathsinv0. etrans. { apply id_left_disp. } apply pathsinv0; unfold transportb. apply maponpaths_2. apply homset_property. - apply pathsinv0. etrans. { apply id_right_disp. } apply pathsinv0; unfold transportb. apply maponpaths_2. apply homset_property. - apply pathsinv0. etrans. { apply assoc_disp. } apply pathsinv0; unfold transportb. apply maponpaths_2. apply homset_property. - apply transportf_set. apply homset_property. - apply pathsinv0. etrans. { cbn. apply disp_functor_id. } unfold transportb. apply maponpaths_2. apply homset_property. - apply transportf_set. apply homset_property. - cbn. etrans. { apply maponpaths. apply disp_functor_comp. } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. - cbn. etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. etrans. { apply maponpaths. apply id_right_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply id_left_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. set (RR := @disp_nat_trans_ax_var _ _ _ _ _ _ _ _ _ φφ). etrans. { apply maponpaths. apply RR. } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_right_disp. } unfold transportb. apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply id_left_disp. } etrans. { apply maponpaths. apply disp_functor_id. } etrans. { apply transport_f_f. } apply maponpaths_2. apply homset_property. - cbn. apply pathsinv0. etrans. { apply assoc_disp_var. } etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply disp_functor_id. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. { apply maponpaths. apply id_left_disp. } etrans. { apply transport_f_f. } apply maponpaths_2. apply homset_property. Qed. Definition disp_prebicat_of_univ_disp_cats : disp_prebicat bicat_of_univ_cats := _ ,, disp_prebicat_of_univ_disp_cats_laws. Definition disp_bicat_of_univ_disp_cats : disp_bicat bicat_of_univ_cats. Proof. use tpair. - exact disp_prebicat_of_univ_disp_cats. - abstract (intros C₁ C₂ F₁ F₂ n D₁ D₂ FF₁ FF₂ ; simpl in * ; cbn ; exact (@isaset_disp_nat_trans C₁ C₂ D₁ D₂ F₁ F₂ n FF₁ FF₂)). Defined. (** 2. Invertible 2-cells in the displayed bicategory of displayed categories *) Definition disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_univ_disp_cats C} {D' : disp_bicat_of_univ_disp_cats C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (Hαα : is_disp_nat_z_iso (nat_z_iso_id _) αα) : is_disp_invertible_2cell (id2_invertible_2cell F) αα. Proof. use tpair. - exact (pointwise_inverse_disp_nat_trans αα Hαα). - split. + abstract (cbn ; simpl in * ; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (inv_mor_after_z_iso_disp (Hαα x xx) @ _) ; refine (!_) ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). + abstract (cbn ; simpl in * ; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (z_iso_disp_after_inv_mor (Hαα x xx) @ _) ; refine (!_) ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). Defined. (** This function is more convenient to use in certain cases. In the proof of global univalence, we look at invertible 2-cells over the unitors. The data of these 2-cells are equal to the identity transformations, but they have a different proof of invertibility. *) Lemma disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell_help {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_univ_disp_cats C} {D' : disp_bicat_of_univ_disp_cats C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (Hαα : is_disp_nat_z_iso (nat_z_iso_id _) αα) (H : @is_invertible_2cell bicat_of_univ_cats C C' F F (nat_trans_id _)) : is_disp_invertible_2cell H αα. Proof. refine (transportf (λ z, is_disp_invertible_2cell z αα) _ (disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell αα Hαα)). apply isaprop_is_invertible_2cell. Qed. Definition from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_univ_disp_cats C} {D' : disp_bicat_of_univ_disp_cats C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (Hαα : is_disp_invertible_2cell (id2_invertible_2cell F) αα) : is_disp_nat_z_iso (nat_z_iso_id _) αα. Proof. intros x xx. simple refine (_ ,, _ ,, _). - exact (pr11 Hαα x xx). - abstract (refine (maponpaths (λ z, pr1 z x xx) (pr22 Hαα) @ _) ; cbn ; unfold transportb ; rewrite disp_nat_trans_transportf ; apply maponpaths_2 ; apply homset_property). - abstract (refine (maponpaths (λ z, pr1 z x xx) (pr12 Hαα) @ _) ; cbn ; unfold transportb ; rewrite disp_nat_trans_transportf ; apply maponpaths_2 ; apply homset_property). Defined. (** This function is more convenient to use in certain cases. In the proof of global univalence, we look at invertible 2-cells over the unitors. The data of these 2-cells are equal to the identity transformations, but they have a different proof of invertibility. *) Lemma from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell_help {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_univ_disp_cats C} {D' : disp_bicat_of_univ_disp_cats C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (H : @is_invertible_2cell bicat_of_univ_cats C C' F F (nat_trans_id _)) (Hαα : is_disp_invertible_2cell H αα) : is_disp_nat_z_iso (nat_z_iso_id _) αα. Proof. apply from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell. refine (transportf (λ z, is_disp_invertible_2cell z αα) _ Hαα). apply isaprop_is_invertible_2cell. Qed. Definition disp_bicat_of_univ_disp_cats_inv2cell_weq {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} {D₁ : disp_bicat_of_univ_disp_cats C₁} {D₂ : disp_bicat_of_univ_disp_cats C₂} (FF GG : D₁ -->[ F ] D₂) : disp_nat_z_iso FF GG (nat_z_iso_id F) ≃ disp_invertible_2cell (id2_invertible_2cell F) FF GG. Proof. use weqfibtototal. intro τ. use weqimplimpl. - exact (disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell τ). - exact (from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell τ). - apply isaprop_is_disp_nat_z_iso. - apply isaprop_is_disp_invertible_2cell. Defined. (** 3. The local univalence *) Proposition disp_univalent_2_1_disp_bicat_of_univ_disp_cat : disp_univalent_2_1 disp_bicat_of_univ_disp_cats. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros C₁ C₂ F D₁ D₂ FF GG. use weqhomot. - exact (disp_bicat_of_univ_disp_cats_inv2cell_weq FF GG ∘ disp_functor_eq_weq FF GG (pr2 D₂))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; use disp_nat_trans_eq ; intros x xx ; cbn ; apply idpath). Defined. (** 4. Adjoints equivalences *) Definition disp_left_adjoint_equivalence_disp_bicat_of_univ_cats {C : bicat_of_univ_cats} {D₁ D₂ : disp_bicat_of_univ_disp_cats C} (F : D₁ -->[ functor_identity _ ] D₂) (HF : is_equiv_over_id F) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity C) F. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (pr111 HF). - exact (pr1 (pr211 HF)). - exact (pr2 (pr211 HF)). - abstract (use disp_nat_trans_eq ; intros x xx ; cbn ; rewrite id_left_disp ; rewrite !id_right_disp ; unfold transportb ; rewrite !mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; exact (pr121 HF x xx) | ] ; unfold transportb ; rewrite transport_f_f ; refine (!_) ; refine (disp_nat_trans_transportf _ _ _ _ (!(internal_triangle1 (is_internal_adjunction_identity C))) _ _ (disp_nat_trans_id _) x xx @ _) ; apply maponpaths_2 ; apply homset_property). - abstract (use disp_nat_trans_eq ; intros x xx ; cbn ; rewrite id_left_disp ; rewrite !id_right_disp ; unfold transportb ; rewrite !mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; exact (pr221 HF x xx) | ] ; unfold transportb ; rewrite transport_f_f ; refine (!_) ; refine (disp_nat_trans_transportf _ _ _ _ (!(internal_triangle2 (is_internal_adjunction_identity C))) _ _ (disp_nat_trans_id _) x _ @ _) ; apply maponpaths_2 ; apply homset_property). - abstract (use disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell_help ; cbn ; intros x xx ; exact (pr12 HF x xx)). - abstract (use disp_bicat_of_univ_disp_cats_is_disp_invertible_2cell_help ; cbn ; intros x xx ; exact (pr22 HF x xx)). Defined. Definition from_disp_left_adjoint_equivalence_disp_bicat_of_univ_cats {C : bicat_of_univ_cats} {D₁ D₂ : disp_bicat_of_univ_disp_cats C} (F : D₁ -->[ functor_identity _ ] D₂) (HF : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity C) F) : is_equiv_over_id F. Proof. simple refine (((_ ,, (_ ,, _)) ,, (_ ,, _)) ,, (_ ,, _)). - exact (pr11 HF). - exact (pr121 HF). - exact (pr221 HF). - abstract (intros x xx ; cbn ; pose (maponpaths (λ z, pr1 z x xx) (pr112 HF)) as p ; cbn in p ; rewrite !id_left_disp in p ; rewrite !id_right_disp in p ; unfold transportb in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; refine (transportb_transpose_right p @ _) ; etrans ; [ apply maponpaths ; apply (disp_nat_trans_transportf _ _ _ _ (!(internal_triangle1 (is_internal_adjunction_identity C))) _ _ (disp_nat_trans_id _) x xx) | ] ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). - abstract (intros x xx ; cbn ; pose (maponpaths (λ z, pr1 z x xx) (pr212 HF)) as p ; cbn in p ; rewrite !id_left_disp in p ; rewrite !id_right_disp in p ; unfold transportb in p ; rewrite !mor_disp_transportf_postwhisker in p ; rewrite !transport_f_f in p ; refine (transportb_transpose_right p @ _) ; etrans ; [ apply maponpaths ; apply (disp_nat_trans_transportf _ _ _ _ (!(internal_triangle2 (is_internal_adjunction_identity C))) _ _ (disp_nat_trans_id _) x xx) | ] ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). - abstract (cbn ; intros x xx ; apply (from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell_help _ _ (pr122 HF))). - abstract (cbn ; intros x xx ; apply (from_disp_bicat_of_univ_disp_cats_disp_invertible_2cell_help _ _ (pr222 HF))). Defined. Definition disp_bicat_of_univ_disp_cats_adjequiv_weq {C : bicat_of_univ_cats} (D₁ : disp_bicat_of_univ_disp_cats C) (D₂ : disp_bicat_of_univ_disp_cats C) : (∑ (F : disp_functor (functor_identity _) (pr1 D₁) (pr1 D₂)), is_equiv_over_id F) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) D₁ D₂. Proof. use weqfibtototal. intro F. use weqimplimpl. - exact (disp_left_adjoint_equivalence_disp_bicat_of_univ_cats F). - exact (from_disp_left_adjoint_equivalence_disp_bicat_of_univ_cats F). - apply isaprop_is_equiv_over_id. + exact (pr2 D₁). + exact (pr2 D₂). - use isaprop_disp_left_adjoint_equivalence. + exact univalent_cat_is_univalent_2_1. + exact disp_univalent_2_1_disp_bicat_of_univ_disp_cat. Defined. (** 5. The global univalence *) Proposition disp_univalent_2_0_disp_bicat_of_univ_disp_cat : disp_univalent_2_0 disp_bicat_of_univ_disp_cats. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros C D₁ D₂. use weqhomot. - refine (disp_bicat_of_univ_disp_cats_adjequiv_weq D₁ D₂ ∘ disp_cat_eq (pr1 D₁) (pr1 D₂) (pr2 D₁) (pr2 D₂) ∘ path_sigma_hprop _ _ _ _)%weq. apply isaprop_is_univalent_disp. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; use (isaprop_disp_left_adjoint_equivalence _ _ univalent_cat_is_univalent_2_1 disp_univalent_2_1_disp_bicat_of_univ_disp_cat) | ] ; apply idpath). Defined. (** Displayed bicategory of fibrations *) Definition disp_bicat_of_cleaving_ob_mor : disp_cat_ob_mor (total_bicat disp_bicat_of_univ_disp_cats). Proof. use tpair. - exact (λ X, cleaving (pr12 X)). - exact (λ X Y fibX fibY F, is_cartesian_disp_functor (pr2 F)). Defined. Definition disp_bicat_of_cleaving_id_comp : disp_cat_id_comp (total_bicat disp_bicat_of_univ_disp_cats) disp_bicat_of_cleaving_ob_mor. Proof. use tpair. - intros X fibX x y f xx yy ff p. exact p. - intros X Y Z F G fibX fibY fibZ cartF cartG x y f xx yy ff p ; simpl. apply cartG. apply cartF. exact p. Qed. Definition disp_bicat_of_cleaving_cat_data : disp_cat_data (total_bicat disp_bicat_of_univ_disp_cats). Proof. use tpair. - exact disp_bicat_of_cleaving_ob_mor. - exact disp_bicat_of_cleaving_id_comp. Defined. Definition disp_bicat_of_cleaving_help : disp_bicat (total_bicat disp_bicat_of_univ_disp_cats). Proof. use disp_cell_unit_bicat. exact disp_bicat_of_cleaving_cat_data. Defined. Definition disp_bicat_of_cleaving : disp_bicat bicat_of_univ_cats := sigma_bicat bicat_of_univ_cats disp_bicat_of_univ_disp_cats disp_bicat_of_cleaving_help. Definition disp_bicat_of_cleaving_is_disp_invertible_2cell {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_cleaving C} {D' : disp_bicat_of_cleaving C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (Hαα : ∏ (x : (C : univalent_category)) (xx : pr11 D x), is_z_iso_disp (identity_z_iso (pr1 F x)) (pr11 αα x xx)) : is_disp_invertible_2cell (id2_invertible_2cell F) αα. Proof. use tpair. - exact (pointwise_inverse_disp_nat_trans (pr1 αα) Hαα ,, tt). - split. + abstract (cbn ; simpl in * ; use subtypePath ; [intro ; apply isapropunit | ]; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (inv_mor_after_z_iso_disp (Hαα x xx) @ _) ; refine (!_) ; unfold transportb ; rewrite pr1_transportf ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). + abstract (cbn ; simpl in * ; use subtypePath ; [intro ; apply isapropunit | ]; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (z_iso_disp_after_inv_mor (Hαα x xx) @ _) ; refine (!_) ; unfold transportb ; rewrite pr1_transportf ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). Defined. Definition disp_bicat_of_cleaving_disp_invertible_2cell_pointwise_inv {C C' : bicat_of_univ_cats} {F G : C --> C'} {α : F ==> G} (Hα : is_invertible_2cell α) {D : disp_bicat_of_cleaving C} {D' : disp_bicat_of_cleaving C'} {FF : D -->[ F ] D'} {GG : D -->[ G ] D'} (αα : FF ==>[ α ] GG) (Hαα : is_disp_invertible_2cell Hα αα) {x : (C : univalent_category)} (xx : (pr1 D : disp_univalent_category _) x) : is_z_iso_disp (make_z_iso' (pr1 α x) (is_invertible_2cell_to_is_nat_z_iso _ Hα x)) (pr11 αα x xx). Proof. simple refine (_ ,, _). - exact (pr111 Hαα x xx). - split. + abstract (unfold transportb ; etrans ; [ apply (maponpaths (λ z, pr11 z x xx) (pr22 Hαα)) |] ; unfold transportb ; etrans ; [ refine (maponpaths (λ z, pr1 z x xx) _) ; exact (pr1_transportf (!(vcomp_linv Hα)) (disp_nat_trans_id (pr11 GG),, tt)) | ]; etrans ; [ exact (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(vcomp_linv Hα)) _ _ (disp_nat_trans_id (pr11 GG)) x xx) | ] ; apply maponpaths_2 ; apply homset_property). + abstract (unfold transportb ; etrans ; [ apply (maponpaths (λ z, pr11 z x xx) (pr12 Hαα)) |] ; unfold transportb ; etrans ; [ refine (maponpaths (λ z, pr1 z x xx) _) ; exact (pr1_transportf (!(vcomp_rinv Hα)) (disp_nat_trans_id (pr11 FF),, tt)) | ] ; etrans ; [ exact (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(vcomp_rinv Hα)) _ _ (disp_nat_trans_id (pr11 FF)) x xx) | ] ; apply maponpaths_2 ; apply homset_property). Defined. (** Displayed bicategory of opfibrations *) Definition disp_bicat_of_opcleaving_ob_mor : disp_cat_ob_mor (total_bicat disp_bicat_of_univ_disp_cats). Proof. use tpair. - exact (λ X, opcleaving (pr12 X)). - exact (λ X Y fibX fibY F, is_opcartesian_disp_functor (pr2 F)). Defined. Definition disp_bicat_of_opcleaving_id_comp : disp_cat_id_comp (total_bicat disp_bicat_of_univ_disp_cats) disp_bicat_of_opcleaving_ob_mor. Proof. use tpair. - intros X fibX x y f xx yy ff p. exact p. - intros X Y Z F G fibX fibY fibZ cartF cartG x y f xx yy ff p ; simpl. apply cartG. apply cartF. exact p. Qed. Definition disp_bicat_of_opcleaving_cat_data : disp_cat_data (total_bicat disp_bicat_of_univ_disp_cats). Proof. use tpair. - exact disp_bicat_of_opcleaving_ob_mor. - exact disp_bicat_of_opcleaving_id_comp. Defined. Definition disp_bicat_of_opcleaving_help : disp_bicat (total_bicat disp_bicat_of_univ_disp_cats). Proof. use disp_cell_unit_bicat. exact disp_bicat_of_opcleaving_cat_data. Defined. Definition disp_bicat_of_opcleaving : disp_bicat bicat_of_univ_cats := sigma_bicat bicat_of_univ_cats disp_bicat_of_univ_disp_cats disp_bicat_of_opcleaving_help. Definition disp_bicat_of_opcleaving_is_disp_invertible_2cell {C C' : bicat_of_univ_cats} {F : C --> C'} {D : disp_bicat_of_opcleaving C} {D' : disp_bicat_of_opcleaving C'} {FF : D -->[ F ] D'} {GG : D -->[ F ] D'} (αα : FF ==>[ id₂ F ] GG) (Hαα : ∏ (x : (C : univalent_category)) (xx : pr11 D x), is_z_iso_disp (identity_z_iso (pr1 F x)) (pr11 αα x xx)) : is_disp_invertible_2cell (id2_invertible_2cell F) αα. Proof. use tpair. - exact (pointwise_inverse_disp_nat_trans (pr1 αα) Hαα ,, tt). - split. + abstract (cbn ; simpl in * ; use subtypePath ; [intro ; apply isapropunit | ]; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (inv_mor_after_z_iso_disp (Hαα x xx) @ _) ; refine (!_) ; unfold transportb ; rewrite pr1_transportf ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). + abstract (cbn ; simpl in * ; use subtypePath ; [intro ; apply isapropunit | ]; use (@disp_nat_trans_eq C C') ; intros x xx ; cbn ; refine (z_iso_disp_after_inv_mor (Hαα x xx) @ _) ; refine (!_) ; unfold transportb ; rewrite pr1_transportf ; refine (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(@id2_left bicat_of_univ_cats _ _ _ _ (nat_trans_id F))) _ _ _ _ _ @ _) ; apply transportf_paths ; apply homset_property). Defined. Definition disp_bicat_of_opcleaving_disp_invertible_2cell_pointwise_inv {C C' : bicat_of_univ_cats} {F G : C --> C'} {α : F ==> G} (Hα : is_invertible_2cell α) {D : disp_bicat_of_opcleaving C} {D' : disp_bicat_of_opcleaving C'} {FF : D -->[ F ] D'} {GG : D -->[ G ] D'} (αα : FF ==>[ α ] GG) (Hαα : is_disp_invertible_2cell Hα αα) {x : (C : univalent_category)} (xx : (pr1 D : disp_univalent_category _) x) : is_z_iso_disp (make_z_iso' (pr1 α x) (is_invertible_2cell_to_is_nat_z_iso _ Hα x)) (pr11 αα x xx). Proof. simple refine (_ ,, _). - exact (pr111 Hαα x xx). - split. + abstract (unfold transportb ; etrans ; [ apply (maponpaths (λ z, pr11 z x xx) (pr22 Hαα)) |] ; unfold transportb ; etrans ; [ refine (maponpaths (λ z, pr1 z x xx) _) ; exact (pr1_transportf (!(vcomp_linv Hα)) (disp_nat_trans_id (pr11 GG),, tt)) | ]; etrans ; [ exact (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(vcomp_linv Hα)) _ _ (disp_nat_trans_id (pr11 GG)) x xx) | ] ; apply maponpaths_2 ; apply homset_property). + abstract (unfold transportb ; etrans ; [ apply (maponpaths (λ z, pr11 z x xx) (pr12 Hαα)) |] ; unfold transportb ; etrans ; [ refine (maponpaths (λ z, pr1 z x xx) _) ; exact (pr1_transportf (!(vcomp_rinv Hα)) (disp_nat_trans_id (pr11 FF),, tt)) | ] ; etrans ; [ exact (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ (!(vcomp_rinv Hα)) _ _ (disp_nat_trans_id (pr11 FF)) x xx) | ] ; apply maponpaths_2 ; apply homset_property). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DispBicatOfTwoSidedDispCat.v000066400000000000000000000663251451125700300313430ustar00rootroot00000000000000(********************************************************************************** The displayed bicategory of two-sided displayed categories In this file, we define the bicategory of two-sided displayed categories. The displayed objects over a univalent category `C` are univalent two-sided displayed categories from `C` to `C`. The displayed 1-cells and 2-cells are defined analogously, but with functors and natural transformations instead. We also prove that this displayed bicategory is univalent. For that, we use the following idea: - We already know that the displayed bicategory of displayed categories is univalent. - We have an isomorphism from the displayed bicategory of two-sided displayed categories to the displayed bicategory of displayed categories. - Isomorphisms of displayed bicategories transport univalence. Note that this isomorphism lies over the diagonal pseudofunctor, because a two-sided displayed category over `C` is the same as a displayed category over `C × C`. Contents 1. The displayed bicategory of two-sided displayed categories 2. A pseudofunctor into displayed categories 3. This pseudofunctor is an isomorphism 4. The univalence 5. Invertible 2-cells 6. Adjoints equivalences **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedNatTrans. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.UnivalenceTechniques. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.CatDiag. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Local Open Scope cat. (** 1. The displayed bicategory of two-sided displayed categories *) Definition disp_cat_ob_mor_twosided_disp_cat : disp_cat_ob_mor bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact (λ (C : univalent_category), univalent_twosided_disp_cat C C). - exact (λ (C₁ C₂ : univalent_category) (D₁ : univalent_twosided_disp_cat C₁ C₁) (D₂ : univalent_twosided_disp_cat C₂ C₂) (F : C₁ ⟶ C₂), twosided_disp_functor F F D₁ D₂). Defined. Definition disp_cat_id_comp_twosided_disp_cat : disp_cat_id_comp bicat_of_univ_cats disp_cat_ob_mor_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact (λ C D, twosided_disp_functor_identity _). - exact (λ C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG, comp_twosided_disp_functor FF GG). Defined. Definition disp_cat_data_twosided_disp_cat : disp_cat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_twosided_disp_cat. - exact disp_cat_id_comp_twosided_disp_cat. Defined. Definition disp_prebicat_1_id_comp_twosided_disp_cat : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_data_twosided_disp_cat. - exact (λ C₁ C₂ F G τ D₁ D₂ FF GG, twosided_disp_nat_trans τ τ (pr1 FF) (pr1 GG)). Defined. Definition disp_prebicat_ops_twosided_disp_cat : disp_prebicat_ops disp_prebicat_1_id_comp_twosided_disp_cat. Proof. repeat split. - exact (λ C₁ C₂ F D₁ D₂ FF, id_twosided_disp_nat_trans FF). - exact (λ C₁ C₂ F D₁ D₂ FF, id_twosided_disp_nat_trans FF). - exact (λ C₁ C₂ F D₁ D₂ FF, id_twosided_disp_nat_trans FF). - exact (λ C₁ C₂ F D₁ D₂ FF, id_twosided_disp_nat_trans FF). - exact (λ C₁ C₂ F D₁ D₂ FF, id_twosided_disp_nat_trans FF). - exact (λ C₁ C₂ C₃ C₄ F G H D₁ D₂ D₃ D₄ FF GG HH, id_twosided_disp_nat_trans (comp_twosided_disp_functor FF (comp_twosided_disp_functor GG HH))). - exact (λ C₁ C₂ C₃ C₄ F G H D₁ D₂ D₃ D₄ FF GG HH, id_twosided_disp_nat_trans (comp_twosided_disp_functor (comp_twosided_disp_functor FF GG) HH)). - exact (λ C₁ C₂ F G H τ θ D₁ D₂ FF GG HH ττ θθ, comp_twosided_disp_nat_trans ττ θθ). - exact (λ C₁ C₂ C₃ F G₁ G₂ τ D₁ D₂ D₃ FF GG₁ GG₂ ττ, pre_whisker_twosided_disp_nat_trans FF ττ). - exact (λ C₁ C₂ C₃ F₁ F₂ G τ D₁ D₂ D₃ FF₁ FF₂ GG ττ, post_whisker_twosided_disp_nat_trans GG ττ). Defined. Definition disp_prebicat_data_twosided_disp_cat : disp_prebicat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_twosided_disp_cat. - exact disp_prebicat_ops_twosided_disp_cat. Defined. Proposition transportb_prebicat_twosided_disp_cat {C₁ C₂ : bicat_of_univ_cats} {F G : C₁ --> C₂} {τ θ : F ==> G} (p : τ = θ) {D₁ : disp_prebicat_data_twosided_disp_cat C₁} {D₂ : disp_prebicat_data_twosided_disp_cat C₂} {FF : D₁ -->[ F ] D₂} {GG : D₁ -->[ G ] D₂} (θθ : FF ==>[ θ ] GG) (x y : pr11 C₁) (xy : pr11 D₁ x y) : pr1 (transportb (λ z, FF ==>[ z ] GG) p θθ) x y xy = transportb_disp_mor2 (maponpaths (λ n, pr1 n x) p) (maponpaths (λ n, pr1 n y) p) (pr1 θθ x y xy). Proof. induction p. cbn. apply idpath. Qed. Proposition disp_prebicat_laws_twosided_disp_cat : disp_prebicat_laws disp_prebicat_data_twosided_disp_cat. Proof. repeat split ; intro ; intros ; use eq_twosided_disp_nat_trans ; intros ; refine (_ @ !(transportb_prebicat_twosided_disp_cat _ _ _ _ _)) ; cbn. - cbn. rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_right. use transportb_disp_mor2_eq. apply idpath. - rewrite assoc_two_disp. use transportb_disp_mor2_eq. apply idpath. - refine (!_). use transportb_disp_mor2_idpath. - rewrite twosided_disp_functor_id. use transportb_disp_mor2_eq. apply idpath. - refine (!_). use transportb_disp_mor2_idpath. - rewrite twosided_disp_functor_comp_alt. use transportf_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - rewrite (pr2 φφ). use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. use transportb_disp_mor2_eq. apply idpath. - rewrite id_two_disp_left. rewrite twosided_disp_functor_id. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - etrans. { rewrite id_two_disp_left. unfold transportb. rewrite two_disp_pre_whisker_b. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite twosided_disp_functor_id. rewrite transport_b_b_disp_mor2. apply idpath. } refine (!_). etrans. { rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. apply idpath. } use transportb_disp_mor2_eq. apply idpath. Qed. Definition disp_prebicat_twosided_disp_cat : disp_prebicat bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_twosided_disp_cat. - exact disp_prebicat_laws_twosided_disp_cat. Defined. Definition disp_bicat_twosided_disp_cat : disp_bicat bicat_of_univ_cats. Proof. refine (disp_prebicat_twosided_disp_cat ,, _). intros C₁ C₂ F G τ D₁ D₂ FF GG. apply isaset_twosided_disp_nat_trans. Defined. Definition bicat_twosided_disp_cat : bicat := total_bicat disp_bicat_twosided_disp_cat. (** 2. A pseudofunctor into displayed categories *) Definition twosided_disp_cat_to_disp_cat_psfunctor_id {C : category} (D : twosided_disp_cat C C) : disp_nat_trans (nat_trans_id (functor_identity _)) (disp_functor_identity (twosided_disp_cat_to_disp_cat C C (pr1 D))) (two_sided_disp_functor_to_disp_functor (twosided_disp_functor_identity D)). Proof. refine ((λ x xx, id_disp _) ,, _). abstract (intros x y f xx yy ff ; cbn ; rewrite id_two_disp_right ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition twosided_disp_cat_to_disp_cat_psfunctor_comp {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} (FF : twosided_disp_functor F F D₁ D₂) (GG : twosided_disp_functor G G D₂ D₃) : disp_nat_trans (nat_trans_id _) (disp_functor_composite (two_sided_disp_functor_to_disp_functor FF) (two_sided_disp_functor_to_disp_functor GG)) (two_sided_disp_functor_to_disp_functor (comp_twosided_disp_functor FF GG)). Proof. refine ((λ x xx, id_disp _) ,, _). abstract (intros x y f xx yy ff ; cbn ; rewrite id_two_disp_right ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition twosided_disp_cat_to_disp_cat_psfunctor_data : disp_psfunctor_data disp_bicat_twosided_disp_cat disp_bicat_of_univ_disp_cats diag_univ_cat. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ C D, univalent_twosided_disp_cat_weq_univalent_disp_cat _ _ D). - exact (λ C₁ C₂ F D₁ D₂ FF, two_sided_disp_functor_to_disp_functor FF). - exact (λ C₁ C₂ F G τ D₁ D₂ FF GG ττ, twosided_disp_nat_trans_to_disp_nat_trans ττ). - intros C D. refine (twosided_disp_cat_to_disp_cat_psfunctor_id (pr1 D) ,, _). simple refine (_ ,, _ ,, _). + refine ((λ x xx, id_disp _) ,, _). abstract (intros x y f xx yy ff ; cbn ; rewrite id_two_disp_right ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). + abstract (use disp_nat_trans_eq ; intros x xx ; unfold transportb ; refine (_ @ !(disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _)) ; cbn ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). + abstract (use disp_nat_trans_eq ; intros x xx ; unfold transportb ; refine (_ @ !(disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _)) ; cbn ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG. refine (twosided_disp_cat_to_disp_cat_psfunctor_comp FF GG ,, _). simple refine (_ ,, _ ,, _). + refine ((λ x xx, id_disp _) ,, _). abstract (intros x y f xx yy ff ; cbn ; rewrite id_two_disp_right ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). + abstract (use disp_nat_trans_eq ; intros x xx ; unfold transportb ; refine (_ @ !(disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _)) ; cbn ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). + abstract (use disp_nat_trans_eq ; intros x xx ; unfold transportb ; refine (_ @ !(disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _)) ; cbn ; rewrite id_two_disp_left ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Proposition twosided_disp_cat_to_disp_cat_psfunctor_laws : is_disp_psfunctor disp_bicat_twosided_disp_cat disp_bicat_of_univ_disp_cats diag_univ_cat twosided_disp_cat_to_disp_cat_psfunctor_data. Proof. repeat split. - intros C₁ C₂ F D₁ D₂ FF. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. rewrite transportf_set. + apply idpath. + apply isasetdirprod ; apply homset_property. - intros C₁ C₂ F₁ F₂ F₃ τ θ D₁ D₂ FF₁ FF₂ FF₃ ττ θθ. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. rewrite transportf_set. + apply idpath. + apply isasetdirprod ; apply homset_property. - intros C₁ C₂ F D₁ D₂ FF. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. do 2 rewrite id_two_disp_right. rewrite twosided_disp_functor_id. unfold transportb_disp_mor2, transportf_disp_mor2, transportb. rewrite !twosided_prod_transport. rewrite !transport_f_f. rewrite transportf_set. + apply idpath. + apply isasetdirprod ; apply homset_property. - intros C₁ C₂ F D₁ D₂ FF. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. do 2 rewrite id_two_disp_right. unfold transportb_disp_mor2, transportf_disp_mor2, transportb. rewrite !twosided_prod_transport. rewrite !transport_f_f. rewrite transportf_set. + apply idpath. + apply isasetdirprod ; apply homset_property. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃ D₁ D₂ D₃ D₄ FF₁ FF₂ FF₃. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. rewrite twosided_disp_functor_id. do 3 rewrite id_two_disp_right. rewrite id_two_disp_left. unfold transportb_disp_mor2, transportf_disp_mor2, transportb. rewrite !twosided_prod_transport. rewrite !transport_f_f. apply maponpaths_2. apply isasetdirprod ; apply homset_property. - intros C₁ C₂ C₃ F G₁ G₂ θ D₁ D₂ D₃ FF₁ GG₁ GG₂ θθ. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. rewrite id_two_disp_right. rewrite id_two_disp_left. unfold transportb_disp_mor2, transportf_disp_mor2, transportb. rewrite !twosided_prod_transport. rewrite !transport_f_f. apply maponpaths_2. apply isasetdirprod ; apply homset_property. - intros C₁ C₂ C₃ F₁ F₂ G τ D₁ D₂ D₃ FF₁ FF₂ GG ττ. use disp_nat_trans_eq. intros x xx. unfold transportb. refine (!_). etrans. { apply disp_nat_trans_transportf. } cbn. rewrite id_two_disp_right. rewrite id_two_disp_left. unfold transportb_disp_mor2, transportf_disp_mor2, transportb. rewrite !twosided_prod_transport. rewrite !transport_f_f. apply maponpaths_2. apply isasetdirprod ; apply homset_property. Qed. Definition twosided_disp_cat_to_disp_cat_psfunctor : disp_psfunctor disp_bicat_twosided_disp_cat disp_bicat_of_univ_disp_cats diag_univ_cat. Proof. simple refine (_ ,, _). - exact twosided_disp_cat_to_disp_cat_psfunctor_data. - exact twosided_disp_cat_to_disp_cat_psfunctor_laws. Defined. (** 3. This pseudofunctor is an isomorphism *) Proposition twosided_disp_cat_to_disp_cat_psfunctor_iso : disp_psfunctor_iso twosided_disp_cat_to_disp_cat_psfunctor. Proof. repeat split. - intro C. exact (pr2 (univalent_twosided_disp_cat_weq_univalent_disp_cat _ _)). - intros C₁ C₂ F D₁ D₂. exact (pr2 (two_sided_disp_functor_weq_disp_functor F F (pr1 D₁) (pr1 D₂))). - intros C₁ C₂ F G τ D₁ D₂ FF GG. exact (pr2 (twosided_disp_nat_trans_weq_disp_nat_trans τ τ FF GG)). Defined. (** 4. The univalence *) Definition disp_univalent_2_disp_bicat_twosided_disp_cat : disp_univalent_2 disp_bicat_twosided_disp_cat. Proof. use (disp_univalent_2_along_iso twosided_disp_cat_to_disp_cat_psfunctor). - exact twosided_disp_cat_to_disp_cat_psfunctor_iso. - exact disp_univalent_2_1_disp_bicat_of_univ_disp_cat. - exact univalent_cat_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_0_disp_bicat_of_univ_disp_cat. Defined. Definition is_univalent_2_1_bicat_twosided_disp_cat : is_univalent_2_1 bicat_twosided_disp_cat. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact (pr2 disp_univalent_2_disp_bicat_twosided_disp_cat). Defined. Definition is_univalent_2_0_bicat_twosided_disp_cat : is_univalent_2_0 bicat_twosided_disp_cat. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - exact (pr1 disp_univalent_2_disp_bicat_twosided_disp_cat). Defined. Definition is_univalent_2_bicat_twosided_disp_cat : is_univalent_2 bicat_twosided_disp_cat. Proof. use total_is_univalent_2. - exact disp_univalent_2_disp_bicat_twosided_disp_cat. - exact univalent_cat_is_univalent_2. Defined. (** 5. Invertible 2-cells *) Section ToInvertible. Context {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {D₁ : disp_bicat_twosided_disp_cat C₁} {D₂ : disp_bicat_twosided_disp_cat C₂} {FF GG : D₁ -->[ F ] D₂} (ττ : FF ==>[ id2 _ ] GG) (Hττ : ∏ (x y : C₁) (f : pr1 D₁ x y), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 ττ x y f)). Definition is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_data : twosided_disp_nat_trans_data (nat_trans_id _) (nat_trans_id _) (pr1 GG) (pr1 FF) := λ x y f, iso_inv_twosided_disp (Hττ x y f). Arguments is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_data /. Proposition is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_laws : twosided_disp_nat_trans_laws (nat_trans_id _) (nat_trans_id _) (pr1 GG) (pr1 FF) is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_data. Proof. intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn. refine (!_). refine (id_two_disp_right_alt _ @ _). unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite (inv_after_iso_twosided_disp_alt (Hττ x₂ y₂ xy₂)). rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. apply ττ. } unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { apply maponpaths. do 2 apply maponpaths_2. exact (iso_after_inv_twosided_disp (Hττ x₁ y₁ xy₁)). } unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. Qed. Definition is_disp_invertible_2cell_twosided_disp_cat_over_id_inv : twosided_disp_nat_trans (nat_trans_id _) (nat_trans_id _) (pr1 GG) (pr1 FF). Proof. simple refine (_ ,, _). - exact is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_data. - exact is_disp_invertible_2cell_twosided_disp_cat_over_id_inv_laws. Defined. Definition is_disp_invertible_2cell_twosided_disp_cat_over_id : is_disp_invertible_2cell (id2_invertible_2cell _) ττ. Proof. refine (is_disp_invertible_2cell_twosided_disp_cat_over_id_inv ,, _ ,, _). - abstract (use eq_twosided_disp_nat_trans ; intros x y xy ; refine (_ @ !(transportb_prebicat_twosided_disp_cat _ _ _ _ _)) ; cbn ; refine (inv_after_iso_twosided_disp (Hττ x y xy) @ _) ; use transportf_disp_mor2_eq ; apply idpath). - abstract (use eq_twosided_disp_nat_trans ; intros x y xy ; refine (_ @ !(transportb_prebicat_twosided_disp_cat _ _ _ _ _)) ; cbn ; refine (iso_after_inv_twosided_disp (Hττ x y xy) @ _) ; use transportf_disp_mor2_eq ; apply idpath). Defined. End ToInvertible. Definition is_disp_invertible_2cell_twosided_disp_cat_help {C₁ C₂ : bicat_of_univ_cats} {F G : C₁ --> C₂} (τ : invertible_2cell F G) (Hτ := is_invertible_2cell_to_is_nat_z_iso _ (pr2 τ)) {D₁ : disp_bicat_twosided_disp_cat C₁} {D₂ : disp_bicat_twosided_disp_cat C₂} {FF : D₁ -->[ F ] D₂} {GG : D₁ -->[ G ] D₂} (ττ : FF ==>[ τ ] GG) (Hττ : ∏ (x y : pr1 C₁) (f : pr1 D₁ x y), is_iso_twosided_disp (Hτ x) (Hτ y) (pr1 ττ x y f)) : is_disp_invertible_2cell (is_nat_z_iso_to_is_invertible_2cell _ Hτ) ττ. Proof. revert C₁ C₂ F G τ Hτ D₁ D₂ FF GG ττ Hττ. use J_2_1. - exact univalent_cat_is_univalent_2_1. - intros C₁ C₂ F D₁ D₂ FF GG ττ Hττ. cbn ; cbn in Hττ. refine (transportf (λ z, is_disp_invertible_2cell z _) _ _). 2: apply is_disp_invertible_2cell_twosided_disp_cat_over_id. + apply isaprop_is_invertible_2cell. + intros x y f. refine (transportf (λ z, is_iso_twosided_disp z _ _) _ (transportf (λ z, is_iso_twosided_disp _ z _) _ (Hττ x y f))). * apply isaprop_is_z_isomorphism. * apply isaprop_is_z_isomorphism. Qed. Definition is_disp_invertible_2cell_twosided_disp_cat {C₁ C₂ : bicat_of_univ_cats} {F G : C₁ --> C₂} (τ : F ==> G) (Hτ : is_nat_z_iso (pr1 τ)) {D₁ : disp_bicat_twosided_disp_cat C₁} {D₂ : disp_bicat_twosided_disp_cat C₂} {FF : D₁ -->[ F ] D₂} {GG : D₁ -->[ G ] D₂} (ττ : FF ==>[ τ ] GG) (Hττ : ∏ (x y : pr1 C₁) (f : pr1 D₁ x y), is_iso_twosided_disp (Hτ x) (Hτ y) (pr1 ττ x y f)) : is_disp_invertible_2cell (is_nat_z_iso_to_is_invertible_2cell _ Hτ) ττ. Proof. refine (transportf (λ z, is_disp_invertible_2cell z _) _ _). 2: use (is_disp_invertible_2cell_twosided_disp_cat_help (τ ,, is_nat_z_iso_to_is_invertible_2cell _ Hτ)). - apply isaprop_is_invertible_2cell. - intros x y f. refine (transportf (λ z, is_iso_twosided_disp z _ _) _ (transportf (λ z, is_iso_twosided_disp _ z _) _ (Hττ x y f))). * apply isaprop_is_z_isomorphism. * apply isaprop_is_z_isomorphism. Qed. Definition is_invertible_2cell_bicat_twosided_disp_cat {CD₁ CD₂ : bicat_twosided_disp_cat} {F G : CD₁ --> CD₂} (τ : F ==> G) (Hτ : is_nat_z_iso (pr11 τ)) (Hττ : ∏ (x y : pr11 CD₁) (f : pr12 CD₁ x y), is_iso_twosided_disp (Hτ x) (Hτ y) (pr12 τ x y f)) : is_invertible_2cell τ. Proof. use is_invertible_disp_to_total. simple refine (_ ,, _). - use is_nat_z_iso_to_is_invertible_2cell. exact Hτ. - use is_disp_invertible_2cell_twosided_disp_cat. exact Hττ. Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DispBicatOnCatToUniv.v000066400000000000000000000270311451125700300302240ustar00rootroot00000000000000(*********************************************************************** Reindexing displayed bicategories over the bicategory of categories We prove that every displayed bicategory on the bicategory of (not necessarily univalent) categories gives rise to a displayed bicategory on the bicategory of univalent categories. This construction keeps the displayed objects/1-cells/2-cells to be the same, and thus the composition/identities are inherited as well. For displayed categories, we have a reindexing operator: if we have a displayed category `D` over `C₂` and a functor `F : C₁ ⟶ C₂`, then we get a displayed category `F^* D` over `C₁` and a displayed functor `FF : F^* D ⟶ D` over `F`. The construction we discuss in this file, is a special case of the bicategorical analogue of this operation where we use the inclusion. Hence, we look at two constructions: 1. The reindexed displayed bicategory [disp_bicat_on_cat_to_univ_cat] 2. The displayed pseudofunctor [disp_psfunctor_on_cat_to_univ_cat] Contents 1. The reindexed displayed bicategory 2. Properties of the reindexed displayed bicategory 3. The displayed pseudofunctor over the inclusion ***********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.BicatOfCatToUnivCat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Local Open Scope cat. Section DispBicatOnCats. Context (D : disp_bicat bicat_of_cats). (** 1. The reindexed displayed bicategory *) Definition disp_cat_ob_mor_on_cat_to_univ_cat : disp_cat_ob_mor bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact (λ C, D (pr1 C)). - exact (λ C₁ C₂ CC₁ CC₂ F, CC₁ -->[ F ] CC₂). Defined. Definition disp_cat_id_comp_on_cat_to_univ_cat : disp_cat_id_comp bicat_of_univ_cats disp_cat_ob_mor_on_cat_to_univ_cat. Proof. simple refine (_ ,, _) ; cbn. - exact (λ C CC, id_disp _). - exact (λ C₁ C₂ C₃ F G CC₁ CC₂ CC₃ FF GG, FF ;; GG)%mor_disp. Defined. Definition disp_cat_data_on_cat_to_univ_cat : disp_cat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_on_cat_to_univ_cat. - exact disp_cat_id_comp_on_cat_to_univ_cat. Defined. Definition disp_prebicat_1_id_comp_cells_on_cat_to_univ_cat : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_data_on_cat_to_univ_cat. - exact (λ (C₁ C₂ : univalent_category) (F G : bicat_of_cats ⟦ pr1 C₁ , pr1 C₂ ⟧) (τ : F ==> G) (CC₁ : D (pr1 C₁)) (CC₂ : D (pr1 C₂)) (FF : CC₁ -->[ F ] CC₂) (GG : CC₁ -->[ G ] CC₂), FF ==>[ τ ] GG). Defined. Definition disp_prebicat_ops_on_cat_to_univ_cat : disp_prebicat_ops disp_prebicat_1_id_comp_cells_on_cat_to_univ_cat. Proof. repeat split. - intros C₁ C₂ F CC₁ CC₂ FF. exact (@disp_id2 _ D _ _ _ _ _ FF). - intros C₁ C₂ F CC₁ CC₂ FF. exact (@disp_lunitor _ D _ _ _ _ _ FF). - intros C₁ C₂ F CC₁ CC₂ FF. exact (@disp_runitor _ D _ _ _ _ _ FF). - intros C₁ C₂ F CC₁ CC₂ FF. exact (@disp_linvunitor _ D _ _ _ _ _ FF). - intros C₁ C₂ F CC₁ CC₂ FF. exact (@disp_rinvunitor _ D _ _ _ _ _ FF). - intros C₁ C₂ C₃ C₄ F G H CC₁ CC₂ CC₃ CC₄ FF GG HH. exact (@disp_rassociator _ D _ _ _ _ _ _ _ _ _ _ _ FF GG HH). - intros C₁ C₂ C₃ C₄ F G H CC₁ CC₂ CC₃ CC₄ FF GG HH. exact (@disp_lassociator _ D _ _ _ _ _ _ _ _ _ _ _ FF GG HH). - intros C₁ C₂ F G H τ θ CC₁ CC₂ FF GG HH ττ θθ. exact (@disp_vcomp2 _ D _ _ _ _ _ _ _ _ _ _ _ _ ττ θθ). - intros C₁ C₂ C₃ F G₁ G₂ τ CC₁ CC₂ CC₃ FF GG₁ GG₂ ττ. exact (@disp_lwhisker _ D _ _ _ _ _ _ _ _ _ _ FF _ _ ττ). - intros C₁ C₂ C₃ F₁ F₂ G τ CC₁ CC₂ CC₃ FF₁ FF₂ GG ττ. exact (@disp_rwhisker _ D _ _ _ _ _ _ _ _ _ _ _ _ GG ττ). Defined. Definition disp_prebicat_data_on_cat_to_univ_cat : disp_prebicat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_on_cat_to_univ_cat. - exact disp_prebicat_ops_on_cat_to_univ_cat. Defined. Proposition disp_prebicat_laws_on_cat_to_univ_cat : disp_prebicat_laws disp_prebicat_data_on_cat_to_univ_cat. Proof. repeat split ; intro ; intros ; cbn. - refine (disp_id2_left _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_id2_right _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_vassocr _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lwhisker_id2 _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_id2_rwhisker _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lwhisker_vcomp _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_rwhisker_vcomp _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_vcomp_lunitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_vcomp_runitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lwhisker_lwhisker _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_rwhisker_lwhisker _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_rwhisker_rwhisker _ _ _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_vcomp_whisker _ _ _ _ _ _ _ _ _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lunitor_linvunitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_linvunitor_lunitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_runitor_rinvunitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_rinvunitor_runitor _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lassociator_rassociator _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_rassociator_lassociator _ _ _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_runitor_rwhisker _ _ @ _). apply maponpaths_2. apply cellset_property. - refine (disp_lassociator_lassociator _ _ _ _ @ _). apply maponpaths_2. apply cellset_property. Qed. Definition disp_prebicat_on_cat_to_univ_cat : disp_prebicat bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_on_cat_to_univ_cat. - exact disp_prebicat_laws_on_cat_to_univ_cat. Defined. Definition disp_bicat_on_cat_to_univ_cat : disp_bicat bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_on_cat_to_univ_cat. - intros C₁ C₂ F G τ CC₁ CC₂ FF GG. apply (pr2 D). Defined. (** 2. Properties of the reindexed displayed bicategory *) Proposition disp_2cells_isaprop_disp_bicat_on_cat_to_univ_cat (HD : disp_2cells_isaprop D) : disp_2cells_isaprop disp_bicat_on_cat_to_univ_cat. Proof. intros C₁ C₂ F G τ CC₁ CC₂ FF GG. apply HD. Qed. Proposition disp_2cells_iscontr_disp_bicat_on_cat_to_univ_cat (HD : disp_2cells_iscontr D) : disp_2cells_iscontr disp_bicat_on_cat_to_univ_cat. Proof. intros C₁ C₂ F G τ CC₁ CC₂ FF GG. apply HD. Qed. Proposition disp_locally_groupoid_bicat_on_cat_to_univ_cat (HD : disp_locally_groupoid D) : disp_locally_groupoid disp_bicat_on_cat_to_univ_cat. Proof. intros C₁ C₂ F G τ CC₁ CC₂ FF GG ττ. exact (HD (pr1 C₁) (pr1 C₂) F G τ CC₁ CC₂ FF GG ττ). Qed. Proposition disp_univalent_2_1_disp_bicat_on_cat_to_univ_cat (HD : disp_univalent_2_1 D) : disp_univalent_2_1 disp_bicat_on_cat_to_univ_cat. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros C₁ C₂ F CC₁ CC₂ FF GG. use weqhomot. - refine (weqfibtototal _ _ (λ τ, weqfibtototal _ _ (λ θ, weqdirprodf (weqimplimpl _ _ _ _) (weqimplimpl _ _ _ _))) ∘ make_weq _ (HD (pr1 C₁) (pr1 C₂) F F (idpath F) CC₁ CC₂ FF GG))%weq. + abstract (intro p ; refine (p @ _) ; apply maponpaths_2 ; apply cellset_property). + abstract (intro p ; refine (p @ _) ; apply maponpaths_2 ; apply cellset_property). + abstract (apply (pr2 D)). + abstract (apply (pr2 D)). + abstract (intro p ; refine (p @ _) ; apply maponpaths_2 ; apply cellset_property). + abstract (intro p ; refine (p @ _) ; apply maponpaths_2 ; apply cellset_property). + abstract (apply (pr2 D)). + abstract (apply (pr2 D)). - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; apply idpath). Defined. (** 3. The displayed pseudofunctor over the inclusion *) Definition disp_psfunctor_data_on_cat_to_univ_cat : disp_psfunctor_data disp_bicat_on_cat_to_univ_cat D univ_cats_to_cats. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ C CC, CC). - exact (λ C₁ C₂ F CC₁ CC₂ FF, FF). - exact (λ C₁ C₂ F G τ CC₁ CC₂ FF GG ττ, ττ). - exact (λ C CC, disp_id2_invertible_2cell (id_disp CC)). - exact (λ C₁ C₂ C₃ F G CC₁ CC₂ CC₃ FF GG, disp_id2_invertible_2cell (FF ;; GG)). Defined. Proposition is_disp_psfunctor_data_on_cat_to_univ_cat (HD : disp_2cells_isaprop D) : is_disp_psfunctor disp_bicat_on_cat_to_univ_cat D univ_cats_to_cats disp_psfunctor_data_on_cat_to_univ_cat. Proof. split7 ; intro ; intros ; apply (disp_2cells_isaprop_disp_bicat_on_cat_to_univ_cat HD). Qed. Definition disp_psfunctor_on_cat_to_univ_cat (HD : disp_2cells_isaprop D) : disp_psfunctor disp_bicat_on_cat_to_univ_cat D univ_cats_to_cats := disp_psfunctor_data_on_cat_to_univ_cat ,, is_disp_psfunctor_data_on_cat_to_univ_cat HD. End DispBicatOnCats. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DispDepProd.v000066400000000000000000000355131451125700300264510ustar00rootroot00000000000000(** Dependent product of diplayed bicategories. If we have a type `J` and a family indexed by `J` of displayed bicategories on `J`, then we can assemble this into a displayed bicategory whose objects are dependent functions. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Local Open Scope mor_disp. Section DispDepprod. Context {B : bicat} (I : UU) (D : I → disp_bicat B). Definition disp_depprod_cat_ob_mor : disp_cat_ob_mor B. Proof. use tpair. - exact (λ x, ∏ (i : I), D i x). - exact (λ x y xx yy f, ∏ (i : I), xx i -->[ f ] yy i). Defined. Definition disp_depprod_cat_data : disp_cat_data B. Proof. use tpair. - exact disp_depprod_cat_ob_mor. - split. + exact (λ x xx i, id_disp (xx i)). + exact (λ x y z f g xx yy zz ff gg i, ff i;;gg i). Defined. Definition disp_depprod_disp_2cell_struct : disp_2cell_struct disp_depprod_cat_ob_mor := λ x y f g α xx yy ff gg, ∏ (i : I), ff i ==>[ α ] gg i. Definition disp_depprod_disp_prebicat_ops : disp_prebicat_ops (disp_depprod_cat_data,, disp_depprod_disp_2cell_struct). Proof. repeat split. - exact (λ a b f aa bb ff i, disp_id2 (ff i)). - exact (λ a b f aa bb ff i, disp_lunitor (ff i)). - exact (λ a b f aa bb ff i, disp_runitor (ff i)). - exact (λ a b f aa bb ff i, disp_linvunitor (ff i)). - exact (λ a b f aa bb ff i, disp_rinvunitor (ff i)). - exact (λ a b c d f g h aa bb cc dd ff gg hh i, disp_rassociator (ff i) (gg i) (hh i)). - exact (λ a b c d f g h aa bb cc dd ff gg hh i, disp_lassociator (ff i) (gg i) (hh i)). - exact (λ a b f g h x y aa bb ff gg hh xx yy i, xx i •• yy i). - exact (λ a b c f g1 g2 x aa bb cc ff gg1 gg2 xx i, ff i ◃◃ xx i). - exact (λ a b c f1 f2 g x aa bb cc ff1 ff2 gg xx i, xx i ▹▹ gg i). Defined. Definition disp_depprod_prebicat_data : disp_prebicat_data B. Proof. use tpair. - use tpair. + exact disp_depprod_cat_data. + exact disp_depprod_disp_2cell_struct. - exact disp_depprod_disp_prebicat_ops. Defined. Definition disp_depprod_prebicat_laws_help {a b : B} {f g : a --> b} {x y : f ==> g} {aa : ∏ (i : I), D i a} {bb : ∏ (i : I), D i b} {ff : ∏ (i : I), aa i -->[ f ] bb i} {gg : ∏ (i : I), aa i -->[ g ] bb i} (xx : ∏ (i : I), ff i ==>[ y ] gg i) (p : x = y) (i : I) : transportb (λ α : f ==> g, ff i ==>[ α ] gg i) p (xx i) = transportb (λ α : f ==> g, ∏ (i : I), ff i ==>[ α ] gg i) p xx i. Proof. induction p. apply idpath. Qed. Definition disp_depprod_prebicat_laws : disp_prebicat_laws disp_depprod_prebicat_data. Proof. repeat split ; intro ; intros ; use funextsec ; intro ; refine (_ @ disp_depprod_prebicat_laws_help _ _ _). - apply disp_id2_left. - apply disp_id2_right. - apply disp_vassocr. - apply disp_lwhisker_id2. - apply disp_id2_rwhisker. - apply disp_lwhisker_vcomp. - apply disp_rwhisker_vcomp. - apply disp_vcomp_lunitor. - apply disp_vcomp_runitor. - apply disp_lwhisker_lwhisker. - apply disp_rwhisker_lwhisker. - apply disp_rwhisker_rwhisker. - apply disp_vcomp_whisker. - apply disp_lunitor_linvunitor. - apply disp_linvunitor_lunitor. - apply disp_runitor_rinvunitor. - apply disp_rinvunitor_runitor. - apply disp_lassociator_rassociator. - apply disp_rassociator_lassociator. - apply disp_runitor_rwhisker. - apply disp_lassociator_lassociator. Qed. Definition disp_depprod_prebicat : disp_prebicat B. Proof. use tpair. - exact disp_depprod_prebicat_data. - exact disp_depprod_prebicat_laws. Defined. Definition disp_depprod_bicat : disp_bicat B. Proof. use tpair. - exact disp_depprod_prebicat. - intros a b f g x aa bb ff gg. use impred_isaset. intro i. apply (D i). Defined. Definition disp_2cells_isaprop_depprod (HD : ∏ (i : I), disp_2cells_isaprop (D i)) : disp_2cells_isaprop disp_depprod_bicat. Proof. intro; intros. use impred. intro i. apply HD. Qed. Definition disp_depprod_bicat_disp_is_invertible_2cell_map {a b : B} {f g : B ⟦ a, b ⟧} {x : f ==> g} {xinv : is_invertible_2cell x} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} {ff : aa -->[ f] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) (Hx : ∏ (i : I), is_disp_invertible_2cell xinv (xx i)) : is_disp_invertible_2cell xinv xx. Proof. use tpair. - exact (λ i, pr1 (Hx i)). - split. + use funextsec. intro i. refine (_ @ disp_depprod_prebicat_laws_help _ _ _). exact (disp_vcomp_rinv ((xx i ,, Hx i) : disp_invertible_2cell (x ,, xinv) _ _)). + use funextsec. intro i. refine (_ @ disp_depprod_prebicat_laws_help _ _ _). exact (disp_vcomp_linv ((xx i ,, Hx i) : disp_invertible_2cell (x ,, xinv) _ _)). Defined. Definition disp_locally_groupoid_depprod (HD : ∏ (i : I), disp_locally_groupoid (D i)) : disp_locally_groupoid disp_depprod_bicat. Proof. intros a b f g x aa bb ff gg xx. apply disp_depprod_bicat_disp_is_invertible_2cell_map. intro i. apply HD. Qed. Definition disp_depprod_bicat_disp_invertible_2cell_map {a b : B} {f : B ⟦ a, b ⟧} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} (ff : aa -->[ f] bb) (gg : aa -->[ f] bb) : (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i)) → disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. intros x. use tpair. - exact (λ i, x i). - apply disp_depprod_bicat_disp_is_invertible_2cell_map. exact (λ i, pr2 (x i)). Defined. Definition disp_depprod_bicat_disp_is_invertible_2cell_pr {a b : B} {f g : B ⟦ a, b ⟧} {x : f ==> g} {xinv : is_invertible_2cell x} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} {ff : aa -->[ f] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) (Hx : is_disp_invertible_2cell xinv xx) : ∏ (i : I), is_disp_invertible_2cell xinv (xx i). Proof. intro i. use tpair. - exact (pr1 Hx i). - split. + refine (_ @ !(disp_depprod_prebicat_laws_help (disp_id2 ff) _ _)). exact (eqtohomot (disp_vcomp_rinv ((xx ,, Hx) : disp_invertible_2cell (x ,, xinv) _ _)) i). + refine (_ @ !(disp_depprod_prebicat_laws_help (disp_id2 gg) _ _)). exact (eqtohomot (disp_vcomp_linv ((xx ,, Hx) : disp_invertible_2cell (x ,, xinv) _ _)) i). Defined. Definition disp_depprod_bicat_disp_invertible_2cell_inv_map {a b : B} {f : B ⟦ a, b ⟧} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} (ff : aa -->[ f] bb) (gg : aa -->[ f] bb) : disp_invertible_2cell (id2_invertible_2cell f) ff gg → (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i)). Proof. intros x i. use tpair. - exact (pr1 x i). - exact (disp_depprod_bicat_disp_is_invertible_2cell_pr _ (pr2 x) i). Defined. Definition disp_depprod_bicat_disp_invertible_2cell_weq {a b : B} {f : B ⟦ a, b ⟧} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} (ff : aa -->[ f] bb) (gg : aa -->[ f] bb) : (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i)) ≃ disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. use make_weq. - exact (disp_depprod_bicat_disp_invertible_2cell_map ff gg). - use isweq_iso. + exact (disp_depprod_bicat_disp_invertible_2cell_inv_map ff gg). + intros x. use funextsec. intro i. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. + intros x. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. Defined. Section DepProdBicatDispLocallyUnivalent. Variable (HD_2_1 : ∏ (i : I), disp_univalent_2_1 (D i)). Definition disp_depprod_bicat_idtotiso_2_1 {a b : B} {f : B ⟦ a, b ⟧} {aa : disp_depprod_bicat a} {bb : disp_depprod_bicat b} (ff : aa -->[ f] bb) (gg : aa -->[ f] bb) : ff = gg ≃ disp_invertible_2cell (id2_invertible_2cell f) ff gg := ((disp_depprod_bicat_disp_invertible_2cell_weq ff gg) ∘ weqonsecfibers _ _ (λ i, make_weq _ (HD_2_1 i _ _ _ _ (idpath _) _ _ (ff i) (gg i))) ∘ invweq (weqfunextsec _ _ _))%weq. Definition disp_depprod_univalent_2_1 : disp_univalent_2_1 disp_depprod_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros a b f aa bb ff gg. use weqhomot. - exact (disp_depprod_bicat_idtotiso_2_1 ff gg). - intros p. induction p. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. Defined. End DepProdBicatDispLocallyUnivalent. Definition disp_depprod_bicat_disp_adjequiv_map {a : B} (aa bb : disp_depprod_bicat a) : (∏ (i : I), disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) (aa i) (bb i)) → disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb. Proof. intros f. use tpair. - exact (λ i, f i). - use tpair. + use tpair. * exact (λ i, disp_left_adjoint_right_adjoint _ (f i)). * split. ** exact (λ i, disp_left_adjoint_unit _ (f i)). ** exact (λ i, disp_left_adjoint_counit _ (f i)). + split. * split. ** abstract (use funextsec ; intro i ; refine (pr1 (pr122 (f i)) @ _) ; refine ((disp_depprod_prebicat_laws_help _ _ _))). ** abstract (use funextsec ; intro i ; refine (pr2 (pr122 (f i)) @ _) ; refine ((disp_depprod_prebicat_laws_help _ _ _))). * split. ** apply disp_depprod_bicat_disp_is_invertible_2cell_map. exact (λ i, pr1 (pr222 (f i))). ** apply disp_depprod_bicat_disp_is_invertible_2cell_map. exact (λ i, pr2 (pr222 (f i))). Defined. Definition disp_depprod_bicat_disp_adjequiv_inv {a : B} (aa bb : disp_depprod_bicat a) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb → (∏ (i : I), disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) (aa i) (bb i)). Proof. intros f i. use tpair. - exact (pr1 f i). - use tpair. + use tpair. * exact (disp_left_adjoint_right_adjoint _ f i). * split. ** exact (disp_left_adjoint_unit _ f i). ** exact (disp_left_adjoint_counit _ f i). + split. * split. ** abstract (refine (eqtohomot (pr1 (pr122 f)) i @ _) ; refine (!(disp_depprod_prebicat_laws_help _ _ _))). ** abstract (refine (eqtohomot (pr2 (pr122 f)) i @ _) ; refine (!(disp_depprod_prebicat_laws_help _ _ _))). * split. ** exact (disp_depprod_bicat_disp_is_invertible_2cell_pr _ (pr1 (pr222 f)) i). ** exact (disp_depprod_bicat_disp_is_invertible_2cell_pr _ (pr2 (pr222 f)) i). Defined. Variable (HB : is_univalent_2_1 B) (HD_2_1 : ∏ (i : I), disp_univalent_2_1 (D i)). Definition disp_depprod_bicat_disp_adjequiv_weq {a : B} (aa bb : disp_depprod_bicat a) : (∏ x : I, disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) (aa x) (bb x)) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb. Proof. use make_weq. - exact (disp_depprod_bicat_disp_adjequiv_map aa bb). - use isweq_iso. + exact (disp_depprod_bicat_disp_adjequiv_inv aa bb). + intros f. use funextsec. intros i. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence ; [ exact HB | exact (HD_2_1 i) ]. } apply idpath. + intros f. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence ; [ exact HB | exact (disp_depprod_univalent_2_1 HD_2_1) ]. } apply idpath. Defined. Section DepProdBicatDispGloballyUnivalent. Variable (HD_2_0 : ∏ (i : I), disp_univalent_2_0 (D i)). Definition disp_depprod_bicat_idtotiso_2_0 {a : B} (aa bb : disp_depprod_bicat a) : (aa = bb) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb := ((disp_depprod_bicat_disp_adjequiv_weq aa bb) ∘ weqonsecfibers _ _ (λ i, make_weq _ (HD_2_0 i _ _ (idpath a) _ _)) ∘ invweq (weqfunextsec _ _ _))%weq. Definition disp_depprod_univalent_2_0 : disp_univalent_2_0 disp_depprod_bicat. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros a aa bb. use weqhomot. - exact (disp_depprod_bicat_idtotiso_2_0 aa bb). - intros p. induction p. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence ; [ exact HB | exact (disp_depprod_univalent_2_1 HD_2_1) ]. } apply idpath. Defined. End DepProdBicatDispGloballyUnivalent. End DispDepprod. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DisplayMapBicatSlice.v000066400000000000000000000567251451125700300302720ustar00rootroot00000000000000(** Slice bicategories of display map bicategories Contents: 1. Definition of the slice displayed bicategory of display map bicategories 2. The univalence of the slice displayed bicategory of display map bicategories 3. The slice bicategory of display map bicategories 4. Invertible 2-cells 5. Adjoint equivalences 6. Discreteness 7. Instantiations *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. Section DispMapSliceBicat. Context {B : bicat} (D : arrow_subbicat B) (b : B). (** 1. Definition of the slice displayed bicategory of display map bicategories *) Definition disp_map_slice_disp_cat_ob_mor : disp_cat_ob_mor B. Proof. simple refine (_ ,, _). - exact (λ a, ∑ (f : a --> b), pred_ob D f). - exact (λ a₁ a₂ fa₁ fa₂ g, pred_mor D (pr1 fa₁) (pr1 fa₂) g × invertible_2cell (pr1 fa₁) (g · pr1 fa₂)). Defined. Definition disp_map_slice_disp_cat_id_comp : disp_cat_id_comp B disp_map_slice_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ a fa, id_pred_mor D _ ,, linvunitor_invertible_2cell (pr1 fa)). - exact (λ a₁ a₂ a₃ g₁ g₂ fa₁ fa₂ fa₃ α β, comp_pred_mor D (pr1 α) (pr1 β) ,, comp_of_invertible_2cell (pr2 α) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (pr2 β)) (lassociator_invertible_2cell _ _ _))). Defined. Definition disp_map_slice_disp_cat_data : disp_cat_data B. Proof. simple refine (_ ,, _). - exact disp_map_slice_disp_cat_ob_mor. - exact disp_map_slice_disp_cat_id_comp. Defined. Definition disp_map_slice_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. simple refine (_ ,, _). - exact disp_map_slice_disp_cat_data. - intros a₁ a₂ g₁ g₂ α fa₁ fa₂ β₁ β₂ ; cbn in *. exact (pr12 β₁ • (α ▹ _) = pr12 β₂). Defined. Definition disp_map_slice_disp_prebicat_ops : disp_prebicat_ops disp_map_slice_disp_prebicat_1_id_comp_cells. Proof. repeat split ; cbn. - intros. rewrite id2_rwhisker. rewrite id2_right. apply idpath. - intros. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite lunitor_triangle. rewrite linvunitor_lunitor. apply id2_right. - intros. rewrite !vassocl. rewrite <- lunitor_lwhisker. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply id2_right. - intros. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite lunitor_triangle. apply idpath. - intros. apply maponpaths. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite triangle_l_inv. apply idpath. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. refine (!_). apply lassociator_lassociator. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply lassociator_lassociator. - intros ? ? ? ? ? ? ? ? ? ? ? ? p q. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite p. exact q. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? p. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. exact p. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? p. rewrite !vassocl. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. exact p. Qed. Definition disp_map_slice_disp_prebicat_data : disp_prebicat_data B. Proof. simple refine (_ ,, _). - exact disp_map_slice_disp_prebicat_1_id_comp_cells. - exact disp_map_slice_disp_prebicat_ops. Defined. Definition disp_map_slice_disp_prebicat_laws : disp_prebicat_laws disp_map_slice_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply cellset_property. Qed. Definition disp_map_slice_disp_prebicat : disp_prebicat B. Proof. simple refine (_ ,, _). - exact disp_map_slice_disp_prebicat_data. - exact disp_map_slice_disp_prebicat_laws. Defined. Definition disp_map_slice_disp_bicat : disp_bicat B. Proof. simple refine (_ ,, _). - exact disp_map_slice_disp_prebicat. - cbn. intro ; intros. apply isasetaprop. apply cellset_property. Defined. Definition disp_2cells_isaprop_disp_map_slice : disp_2cells_isaprop disp_map_slice_disp_bicat. Proof. intro ; intros. apply cellset_property. Defined. Definition disp_locally_sym_disp_map_slice : disp_locally_sym disp_map_slice_disp_bicat. Proof. intros a₁ a₂ g₁ g₂ α fa₁ fa₂ β₁ β₂ p ; cbn in *. etrans. { apply maponpaths_2. exact (!p). } rewrite !vassocl. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_right. Qed. Definition disp_locally_groupoid_disp_map_slice_disp_bicat : disp_locally_groupoid disp_map_slice_disp_bicat. Proof. use make_disp_locally_groupoid. - exact disp_locally_sym_disp_map_slice. - exact disp_2cells_isaprop_disp_map_slice. Defined. (** 2. The univalence of the slice displayed bicategory of display map bicategories *) Definition disp_univalent_2_1_disp_map_slice (HD : arrow_subbicat_props D) : disp_univalent_2_1 disp_map_slice_disp_bicat. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros x y f g xx ff gg. use isweqimplimpl. - intros α. use pathsdirprod. + apply HD. + use subtypePath. { intro. apply isaprop_is_invertible_2cell. } refine (_ @ pr1 α) ; cbn. rewrite id2_rwhisker, id2_right. apply idpath. - use isasetdirprod. + apply isasetaprop. apply HD. + apply isaset_invertible_2cell. - use invproofirrelevance. intros α β. use subtypePath. { intro. apply isaprop_is_disp_invertible_2cell. } apply disp_2cells_isaprop_disp_map_slice. Qed. Definition disp_map_slice_inv2cell_to_disp_adj_equiv (HB : is_univalent_2 B) {x : B} {f g : disp_map_slice_disp_bicat x} (α : invertible_2cell (pr1 f) (pr1 g)) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g. Proof. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, (_ ,, _))). - simple refine (_ ,, _). + apply (arrow_subbicat_contains_equiv_over_id HB). * apply internal_adjoint_equivalence_identity. * exact (comp_of_invertible_2cell α (linvunitor_invertible_2cell _)). + exact (comp_of_invertible_2cell α (linvunitor_invertible_2cell _)). - simple refine (_ ,, _). + apply (arrow_subbicat_contains_equiv_over_id HB). * apply internal_adjoint_equivalence_identity. * exact (comp_of_invertible_2cell (inv_of_invertible_2cell α) (linvunitor_invertible_2cell _)). + exact (comp_of_invertible_2cell (inv_of_invertible_2cell α) (linvunitor_invertible_2cell _)). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; apply idpath). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; apply idpath). - abstract (split ; apply disp_2cells_isaprop_disp_map_slice). - abstract (split ; apply disp_locally_groupoid_disp_map_slice_disp_bicat). Defined. Definition disp_map_slice_disp_adj_equiv_to_inv2cell {x : B} {f g : disp_map_slice_disp_bicat x} (α : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g) : invertible_2cell (pr1 f) (pr1 g) := comp_of_invertible_2cell (pr21 α) (lunitor_invertible_2cell _). Definition disp_map_slice_inv2cell_weq_disp_adj_equiv (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) {x : B} (f g : disp_map_slice_disp_bicat x) : invertible_2cell (pr1 f) (pr1 g) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g. Proof. use make_weq. - exact (disp_map_slice_inv2cell_to_disp_adj_equiv HB). - use isweq_iso. + exact disp_map_slice_disp_adj_equiv_to_inv2cell. + abstract (intros α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocl ; rewrite linvunitor_lunitor ; apply id2_right). + abstract (intros α ; use subtypePath ; [ intro ; apply (isaprop_disp_left_adjoint_equivalence _ _ (pr2 HB) (disp_univalent_2_1_disp_map_slice HD)) | ] ; use pathsdirprod ; [ apply HD | use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocl ; rewrite lunitor_linvunitor ; apply id2_right]). Defined. Definition disp_univalent_2_0_disp_map_slice (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) : disp_univalent_2_0 disp_map_slice_disp_bicat. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x f g. use weqhomot. - refine (disp_map_slice_inv2cell_weq_disp_adj_equiv HB HD f g ∘ make_weq _ (pr2 HB _ _ (pr1 f) (pr1 g)) ∘ path_sigma_hprop _ _ _ _)%weq. apply HD. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply (isaprop_disp_left_adjoint_equivalence _ _ (pr2 HB) (disp_univalent_2_1_disp_map_slice HD)) | ] ; use pathsdirprod ; [ apply HD | ] ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; apply id2_left). Defined. Definition disp_univalent_2_disp_map_slice (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) : disp_univalent_2 disp_map_slice_disp_bicat. Proof. split. - exact (disp_univalent_2_0_disp_map_slice HB HD). - exact (disp_univalent_2_1_disp_map_slice HD). Defined. End DispMapSliceBicat. (** 3. The slice bicategory of display map bicategories *) Definition disp_map_slice_bicat {B : bicat} (D : arrow_subbicat B) (b : B) : bicat := total_bicat (disp_map_slice_disp_bicat D b). Definition is_univalent_2_1_disp_map_slice {B : bicat} (HB : is_univalent_2_1 B) (D : arrow_subbicat B) (HD : arrow_subbicat_props D) (b : B) : is_univalent_2_1 (disp_map_slice_bicat D b). Proof. use total_is_univalent_2_1. - exact HB. - exact (disp_univalent_2_1_disp_map_slice _ _ HD). Defined. Definition is_univalent_2_0_disp_map_slice {B : bicat} (HB : is_univalent_2 B) (D : arrow_subbicat B) (HD : arrow_subbicat_props D) (b : B) : is_univalent_2_0 (disp_map_slice_bicat D b). Proof. use total_is_univalent_2_0. - exact (pr1 HB). - exact (disp_univalent_2_0_disp_map_slice _ _ HB HD). Defined. Definition is_univalent_2_disp_map_slice {B : bicat} (HB : is_univalent_2 B) (D : arrow_subbicat B) (HD : arrow_subbicat_props D) (b : B) : is_univalent_2 (disp_map_slice_bicat D b). Proof. split. - exact (is_univalent_2_0_disp_map_slice HB D HD b). - exact (is_univalent_2_1_disp_map_slice (pr2 HB) D HD b). Defined. Definition eq_2cell_disp_map_slice {B : bicat} {D : arrow_subbicat B} {b : B} {y₁ y₂ : disp_map_slice_bicat D b} {f g : y₁ --> y₂} {α β : f ==> g} (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. (** 4. Invertible 2-cells *) Definition is_invertible_2cell_in_disp_map_slice_bicat {B : bicat} {D : arrow_subbicat B} {b : B} {f₁ f₂ : disp_map_slice_bicat D b} {g₁ g₂ : f₁ --> f₂} {α : g₁ ==> g₂} (Hα : is_invertible_2cell (pr1 α)) : is_invertible_2cell α. Proof. use is_invertible_disp_to_total. simple refine (_ ,, _). - exact Hα. - apply (disp_locally_groupoid_disp_map_slice_disp_bicat _ _ _ _ _ _ (make_invertible_2cell Hα)). Defined. (** 5. Adjoint equivalences *) Section LeftAdjointEquivalenceDispMapSlice. Context {B : bicat} (HB : is_univalent_2 B) {D : arrow_subbicat B} {b : B} {f₁ f₂ : disp_map_slice_bicat D b} (l : f₁ --> f₂) (Hl : left_adjoint_equivalence (pr1 l)). Let r : pr1 f₂ --> pr1 f₁ := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (pr1 l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · pr1 l) (id₁ _) := left_equivalence_counit_iso Hl. Definition left_adjoint_equivalence_in_disp_map_slice_right_adj_cell : invertible_2cell (pr12 f₂) (r · pr12 f₁) := comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell ε)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (pr22 l))))). Definition left_adjoint_equivalence_in_disp_map_slice_right_adj : f₂ --> f₁. Proof. refine (r ,, (_ ,, _)). - apply (arrow_subbicat_contains_equiv_over_id HB). + exact (inv_adjequiv (pr1 l ,, Hl)). + exact left_adjoint_equivalence_in_disp_map_slice_right_adj_cell. - exact left_adjoint_equivalence_in_disp_map_slice_right_adj_cell. Defined. Let slice_r : f₂ --> f₁ := left_adjoint_equivalence_in_disp_map_slice_right_adj. Definition left_adjoint_equivalence_in_disp_map_slice_unit_eq : linvunitor _ • (η ▹ _) = pr122 l • (_ ◃ (linvunitor _ • (ε^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (pr22 l)^-1))) • lassociator _ _ _. Proof. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_lwhisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocl. rewrite vcomp_whisker. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite linvunitor_assoc. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocl. rewrite <- lassociator_lassociator. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite !rwhisker_vcomp. apply maponpaths. do 2 (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]). refine (!(id2_left _) @ _). use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. exact (!(pr1 (axioms_of_left_adjoint Hl))). Qed. Definition left_adjoint_equivalence_in_disp_map_slice_unit : id₁ f₁ ==> l · slice_r. Proof. simple refine (_ ,, _). - exact η. - abstract (cbn ; rewrite !vassocr ; exact left_adjoint_equivalence_in_disp_map_slice_unit_eq). Defined. Definition left_adjoint_equivalence_in_disp_map_slice_counit_eq : linvunitor _ • (ε^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (pr22 l)^-1) • (_ ◃ pr122 l) • lassociator _ _ _ • (ε ▹ _) = linvunitor _. Proof. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition left_adjoint_equivalence_in_disp_map_slice_counit : slice_r · l ==> id₁ f₂. Proof. simple refine (_ ,, _). - exact ε. - abstract (cbn ; rewrite !vassocr ; exact left_adjoint_equivalence_in_disp_map_slice_counit_eq). Defined. Definition left_adjoint_equivalence_in_disp_map_slice_bicat : left_adjoint_equivalence l. Proof. use equiv_to_adjequiv. simple refine ((slice_r ,, (left_adjoint_equivalence_in_disp_map_slice_unit ,, left_adjoint_equivalence_in_disp_map_slice_counit)) ,, (_ ,, _)). - use is_invertible_2cell_in_disp_map_slice_bicat. apply property_from_invertible_2cell. - use is_invertible_2cell_in_disp_map_slice_bicat. apply property_from_invertible_2cell. Defined. End LeftAdjointEquivalenceDispMapSlice. (** 6. Discreteness *) Definition locally_groupoid_disp_map_slice {B : bicat} {D : arrow_subbicat B} (HD : contained_in_conservative D) (b : B) : locally_groupoid (disp_map_slice_bicat D b). Proof. intros x y f g α. use is_invertible_2cell_in_disp_map_slice_bicat. apply (HD _ _ _ (pr22 y)). use eq_is_invertible_2cell. - exact ((pr22 f)^-1 • pr122 g). - abstract (pose (pr2 α) as p ; cbn in p ; rewrite <- p ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; apply idpath). - is_iso. apply property_from_invertible_2cell. Defined. Definition isaprop_2cell_disp_map_slice {B : bicat} {D : arrow_subbicat B} (HD : contained_in_faithful D) (b : B) : isaprop_2cells (disp_map_slice_bicat D b). Proof. intros x y f g α β. use eq_2cell_disp_map_slice. apply (faithful_1cell_eq_cell (HD _ _ _ (pr22 y))). pose (p := pr2 α @ !(pr2 β)). use (vcomp_lcancel (pr22 f)) ; [ apply property_from_invertible_2cell | ]. exact p. Qed. Definition is_discrete_disp_map_slice {B : bicat} (HB : is_univalent_2_1 B) {D : arrow_subbicat B} (HD₁ : arrow_subbicat_props D) (HD₂ : contained_in_discrete D) (b : B) : is_discrete_bicat (disp_map_slice_bicat D b). Proof. repeat split. - exact (is_univalent_2_1_disp_map_slice HB D HD₁ b). - apply locally_groupoid_disp_map_slice. apply discrete_contained_in_conservative. exact HD₂. - apply isaprop_2cell_disp_map_slice. apply discrete_contained_in_faithful. exact HD₂. Defined. Definition discrete_disp_map_slice {B : bicat} (HB : is_univalent_2_1 B) {D : arrow_subbicat B} (HD₁ : arrow_subbicat_props D) (HD₂ : contained_in_discrete D) (b : B) : category := discrete_bicat_to_category (is_discrete_disp_map_slice HB HD₁ HD₂ b). (** 7. Instantiations *) Definition sfib_slice {B : bicat} (b : B) : bicat := disp_map_slice_bicat (sfib_subbicat B) b. Definition sopfib_slice {B : bicat} (b : B) : bicat := disp_map_slice_bicat (sopfib_subbicat B) b. Definition disc_sfib_slice {B : bicat} (HB : is_univalent_2_1 B) (b : B) : category := discrete_disp_map_slice HB (discrete_sfib_subbicat_props B HB) (discrete_sfib_disp_map_bicat_in_discrete B) b. Definition disc_sopfib_slice {B : bicat} (HB : is_univalent_2_1 B) (b : B) : category := discrete_disp_map_slice HB (discrete_sopfib_subbicat_props B HB) (discrete_sopfib_disp_map_bicat_in_discrete B) b. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DisplayMapBicatToDispBicat.v000066400000000000000000001225221451125700300313650ustar00rootroot00000000000000(***************************************************************************** Every display map bicategory gives rise to a displayed bicategory *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. Section ArrowSubBicatToDispBicat. Context {B : bicat} (D : arrow_subbicat B). Definition disp_map_bicat_ob (y : B) : UU := ∑ (x : B) (h : x --> y), pred_ob D h. Definition make_disp_map_bicat_ob {x y : B} (h : x --> y) (H : pred_ob D h) : disp_map_bicat_ob y := (x ,, h ,, H). Definition disp_map_bicat_mor {y₁ y₂ : B} (h₁ : disp_map_bicat_ob y₁) (h₂ : disp_map_bicat_ob y₂) (g : y₁ --> y₂) : UU := ∑ (f : pr1 h₁ --> pr1 h₂), pred_mor D (pr12 h₁) (pr12 h₂) f × invertible_2cell (pr12 h₁ · g) (f · pr12 h₂). Definition make_disp_map_bicat_mor {y₁ y₂ : B} {h₁ : disp_map_bicat_ob y₁} {h₂ : disp_map_bicat_ob y₂} (g : y₁ --> y₂) (f : pr1 h₁ --> pr1 h₂) (H : pred_mor D (pr12 h₁) (pr12 h₂) f) (γ : invertible_2cell (pr12 h₁ · g) (f · pr12 h₂)) : disp_map_bicat_mor h₁ h₂ g := (f ,, H ,, γ). Definition disp_map_bicat_to_disp_cat_ob_mor : disp_cat_ob_mor B. Proof. simple refine (_ ,, _). - exact disp_map_bicat_ob. - exact (λ _ _, disp_map_bicat_mor). Defined. Definition disp_map_bicat_to_disp_cat_id_comp : disp_cat_id_comp B disp_map_bicat_to_disp_cat_ob_mor. Proof. split. - intros y h. use make_disp_map_bicat_mor. + exact (id₁ _). + apply id_pred_mor. + exact (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)). - intros y₁ y₂ y₃ g₁ g₂ h₁ h₂ h₃ f₁ f₂. use make_disp_map_bicat_mor. + exact (pr1 f₁ · pr1 f₂). + exact (comp_pred_mor D (pr12 f₁) (pr12 f₂)). + exact (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (pr22 f₁)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (pr22 f₂)) (lassociator_invertible_2cell _ _ _))))). Defined. Definition disp_map_bicat_to_disp_cat_data : disp_cat_data B := (disp_map_bicat_to_disp_cat_ob_mor ,, disp_map_bicat_to_disp_cat_id_comp). Definition disp_map_bicat_cell {y₁ y₂ : B} {g₁ g₂ : y₁ --> y₂} {h₁ : disp_map_bicat_ob y₁} {h₂ : disp_map_bicat_ob y₂} (f₁ : disp_map_bicat_mor h₁ h₂ g₁) (f₂ : disp_map_bicat_mor h₁ h₂ g₂) (β : g₁ ==> g₂) : UU := ∑ (α : pr1 f₁ ==> pr1 f₂), pr122 f₁ • (α ▹ _) = (_ ◃ β) • pr122 f₂. Definition make_disp_map_bicat_cell {y₁ y₂ : B} {g₁ g₂ : y₁ --> y₂} {β : g₁ ==> g₂} {h₁ : disp_map_bicat_ob y₁} {h₂ : disp_map_bicat_ob y₂} {f₁ : disp_map_bicat_mor h₁ h₂ g₁} {f₂ : disp_map_bicat_mor h₁ h₂ g₂} (α : pr1 f₁ ==> pr1 f₂) (p : pr122 f₁ • (α ▹ _) = (_ ◃ β) • pr122 f₂) : disp_map_bicat_cell f₁ f₂ β := (α ,, p). Definition disp_map_bicat_to_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. refine (disp_map_bicat_to_disp_cat_data ,, _). exact (λ y₁ y₂ g₁ g₂ β h₁ h₂ f₁ f₂, disp_map_bicat_cell f₁ f₂ β). Defined. Definition disp_map_bicat_to_disp_prebicat_ops : disp_prebicat_ops disp_map_bicat_to_disp_prebicat_1_id_comp_cells. Proof. repeat split. - intros x y f hx hy hf ; cbn in *. use make_disp_map_bicat_cell. + exact (id2 _). + abstract (rewrite id2_rwhisker, lwhisker_id2 ; rewrite id2_left, id2_right ; apply idpath). - intros x y f hx hy hf ; cbn in *. use make_disp_map_bicat_cell. + exact (lunitor _). + abstract (cbn ; rewrite <- rwhisker_vcomp ; rewrite !vassocr ; rewrite runitor_rwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite lunitor_triangle ; rewrite vcomp_lunitor ; rewrite !vassocr ; rewrite <- linvunitor_assoc ; rewrite linvunitor_lunitor ; apply id2_left). - intros x y f hx hy hf ; cbn in *. use make_disp_map_bicat_cell. + exact (runitor _). + abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_right ; rewrite runitor_triangle ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; exact (!(left_unit_assoc _ _))). - intros x y f hx hy hf ; cbn in *. use make_disp_map_bicat_cell. + exact (linvunitor _). + abstract (cbn ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite runitor_rwhisker ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite <- linvunitor_assoc ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite rassociator_lassociator ; rewrite id2_right ; apply idpath). - intros x y f hx hy hf ; cbn in *. use make_disp_map_bicat_cell. + exact (rinvunitor _). + abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite !lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- !lwhisker_hcomp, <- rwhisker_hcomp ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; refine (!(id2_left _) @ _) ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- left_unit_assoc ; rewrite lwhisker_vcomp ; rewrite rinvunitor_runitor ; rewrite lwhisker_id2 ; apply idpath). - intros x₁ x₂ x₃ x₄ f g k hx₁ hx₂ hx₃ hx₄ hf hg hk ; cbn in *. use make_disp_map_bicat_cell. + exact (rassociator _ _ _). + abstract (cbn ; rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lassociator_lassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_rwhisker ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite <- lassociator_lassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rwhisker_vcomp ; rewrite lassociator_rassociator ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocr ; rewrite <- rwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lassociator_lassociator ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite <- lwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite <- lassociator_lassociator ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_vcomp ; rewrite lassociator_rassociator ; rewrite id2_rwhisker ; apply id2_right). - intros x₁ x₂ x₃ x₄ f g k hx₁ hx₂ hx₃ hx₄ hf hg hk ; cbn in *. use make_disp_map_bicat_cell. + exact (lassociator _ _ _). + abstract (cbn ; rewrite <- !rwhisker_vcomp, <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite lassociator_lassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_rwhisker ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite <- lassociator_lassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rwhisker_vcomp ; rewrite lassociator_rassociator ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocr ; rewrite <- rwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lassociator_lassociator ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite <- lwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite <- lassociator_lassociator ; rewrite !vassocl ; apply idpath). - intros x₁ x₂ f g h α β hx₁ hx₂ hf hg hh hα hβ ; cbn in *. use make_disp_map_bicat_cell. + exact (pr1 hα • pr1 hβ). + abstract (cbn ; rewrite <- !rwhisker_vcomp ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite (pr2 hα) ; rewrite !vassocl ; rewrite (pr2 hβ) ; apply idpath). - intros x₁ x₂ x₃ f₁ f₂ g α hx₁ hx₂ hx₃ hf₁ hf₂ hg hα ; cbn in *. use make_disp_map_bicat_cell. + exact (_ ◃ pr1 hα). + abstract (cbn ; rewrite !vassocl ; rewrite <- rwhisker_lwhisker ; rewrite !vassocr ; apply maponpaths_2 ; rewrite lwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite <- vcomp_whisker ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite <- lwhisker_lwhisker_rassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !lwhisker_vcomp ; apply maponpaths ; exact (pr2 hα)). - intros x₁ x₂ x₃ f₁ f₂ g α hx₁ hx₂ hx₃ hf₁ hf₂ hg hα ; cbn in *. use make_disp_map_bicat_cell. + exact (pr1 hα ▹ _). + abstract (cbn ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite <- vcomp_whisker ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker_alt ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !rwhisker_vcomp ; apply maponpaths ; exact (pr2 hα)). Defined. Definition transportf_disp_map_bicat_cell {y₁ y₂ : B} {g₁ g₂ : y₁ --> y₂} {β₁ β₂ : g₁ ==> g₂} (p : β₁ = β₂) {h₁ : disp_map_bicat_ob y₁} {h₂ : disp_map_bicat_ob y₂} {f₁ : disp_map_bicat_mor h₁ h₂ g₁} {f₂ : disp_map_bicat_mor h₁ h₂ g₂} (γ : disp_map_bicat_cell f₁ f₂ β₁) : pr1 (transportf (λ α, disp_map_bicat_cell f₁ f₂ α) p γ) = pr1 γ. Proof. induction p. apply idpath. Qed. Definition transportb_disp_map_bicat_cell {y₁ y₂ : B} {g₁ g₂ : y₁ --> y₂} {β₁ β₂ : g₁ ==> g₂} (p : β₁ = β₂) {h₁ : disp_map_bicat_ob y₁} {h₂ : disp_map_bicat_ob y₂} {f₁ : disp_map_bicat_mor h₁ h₂ g₁} {f₂ : disp_map_bicat_mor h₁ h₂ g₂} (γ : disp_map_bicat_cell f₁ f₂ β₂) : pr1 (transportb (λ α, disp_map_bicat_cell f₁ f₂ α) p γ) = pr1 γ. Proof. induction p. apply idpath. Qed. Definition disp_map_bicat_to_disp_prebicat_data : disp_prebicat_data B := (disp_map_bicat_to_disp_prebicat_1_id_comp_cells ,, disp_map_bicat_to_disp_prebicat_ops). Definition disp_map_bicat_to_disp_prebicat_laws : disp_prebicat_laws disp_map_bicat_to_disp_prebicat_data. Proof. repeat split ; intro ; intros ; cbn in * ; (use subtypePath ; [ intro ; apply cellset_property | ]) ; cbn ; rewrite transportb_disp_map_bicat_cell ; cbn. - apply id2_left. - apply id2_right. - apply vassocr. - apply lwhisker_id2. - apply id2_rwhisker. - apply lwhisker_vcomp. - apply rwhisker_vcomp. - apply vcomp_lunitor. - apply vcomp_runitor. - apply lwhisker_lwhisker. - apply rwhisker_lwhisker. - apply rwhisker_rwhisker. - apply vcomp_whisker. - apply lunitor_linvunitor. - apply linvunitor_lunitor. - apply runitor_rinvunitor. - apply rinvunitor_runitor. - apply lassociator_rassociator. - apply rassociator_lassociator. - apply runitor_rwhisker. - apply lassociator_lassociator. Qed. Definition disp_map_bicat_to_disp_prebicat : disp_prebicat B := (disp_map_bicat_to_disp_prebicat_data ,, disp_map_bicat_to_disp_prebicat_laws). Definition disp_map_bicat_to_disp_bicat : disp_bicat B. Proof. refine (disp_map_bicat_to_disp_prebicat ,, _). intro ; intros. use isaset_total2. - apply cellset_property. - intro. apply isasetaprop. apply cellset_property. Defined. Definition disp_2cells_isaprop_if_contained_in_faithful (HD : contained_in_faithful D) : disp_2cells_isaprop disp_map_bicat_to_disp_bicat. Proof. intros x y f g α xx yy ff gg. use invproofirrelevance. intros αα ββ. use subtypePath. { intro. apply cellset_property. } apply (faithful_1cell_eq_cell (HD _ _ _ (pr22 yy))). use (vcomp_lcancel (pr22 ff)) ; [ apply property_from_invertible_2cell | ]. exact (pr2 αα @ !(pr2 ββ)). Qed. (** Displayed invertible 2-cells *) Definition is_invertible_to_is_disp_invertible {x y : B} {f g : x --> y} {α : f ==> g} (Hα : is_invertible_2cell α) {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} {hf : hx -->[ f ] hy} {hg : hx -->[ g ] hy} (αα : hf ==>[ α ] hg) (Hαα : is_invertible_2cell (pr1 αα)) : is_disp_invertible_2cell Hα αα. Proof. simple refine (_ ,, _ ,, _). - use make_disp_map_bicat_cell. + exact (Hαα^-1). + abstract (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite (pr2 αα) ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). - abstract (use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ; rewrite transportb_disp_map_bicat_cell ; cbn ; apply vcomp_rinv). - abstract (use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ; rewrite transportb_disp_map_bicat_cell ; cbn ; apply vcomp_linv). Defined. Definition is_disp_invertible_to_is_invertible {x y : B} {f g : x --> y} {α : f ==> g} (Hα : is_invertible_2cell α) {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} {hf : hx -->[ f ] hy} {hg : hx -->[ g ] hy} (αα : hf ==>[ α ] hg) (Hαα : is_disp_invertible_2cell Hα αα) : is_invertible_2cell (pr1 αα). Proof. use make_is_invertible_2cell. - exact (pr11 Hαα). - abstract (exact (maponpaths pr1 (pr12 Hαα) @ transportb_disp_map_bicat_cell _ _)). - abstract (exact (maponpaths pr1 (pr22 Hαα) @ transportb_disp_map_bicat_cell _ _)). Defined. Definition make_disp_map_disp_invertible_2cell {x y : B} {f g : x --> y} {γ : f ==> g} (Hγ : is_invertible_2cell γ) {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} {hf : hx -->[ f ] hy} {hg : hx -->[ g ] hy} (hγ : hf ==>[ γ ] hg) (Hhγ : is_invertible_2cell (pr1 hγ)) : disp_invertible_2cell (make_invertible_2cell Hγ) hf hg. Proof. refine (hγ ,, _). use is_invertible_to_is_disp_invertible. exact Hhγ. Defined. Definition disp_map_inv_2cell_to_disp_invertible_2cell {x y : B} {f g : x --> y} {γ : invertible_2cell f g} {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} {hf : hx -->[ f ] hy} {hg : hx -->[ g ] hy} (α : ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ)) : disp_invertible_2cell γ hf hg. Proof. use make_disp_map_disp_invertible_2cell. - exact (pr1 α). - exact (pr2 α). Defined. Definition disp_map_disp_invertible_2cell_to_inv_2cell {x y : B} {f g : x --> y} {γ : invertible_2cell f g} {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} {hf : hx -->[ f ] hy} {hg : hx -->[ g ] hy} (α : disp_invertible_2cell γ hf hg) : ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ). Proof. refine (pr1 α ,, _). use is_disp_invertible_to_is_invertible. - exact (pr2 γ). - exact (pr2 α). Defined. Definition disp_map_inv_2cell_weq_disp_invertible_2cell {x y : B} {f g : x --> y} (γ : invertible_2cell f g) {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} (hf : hx -->[ f ] hy) (hg : hx -->[ g ] hy) : (∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ)) ≃ disp_invertible_2cell γ hf hg. Proof. use make_weq. - exact disp_map_inv_2cell_to_disp_invertible_2cell. - use isweq_iso. + exact disp_map_disp_invertible_2cell_to_inv_2cell. + abstract (intro α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). + abstract (intro α ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; apply idpath). Defined. (** 3. Local Univalence *) Local Definition refactor_weq {x y : B} {f g : x --> y} (γ : invertible_2cell f g) {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} (hf : hx -->[ f ] hy) (hg : hx -->[ g ] hy) : (∑ (γe : invertible_2cell (pr1 hf) (pr1 hg)), pr122 hf • (γe ▹ pr12 hy) = (pr12 hx ◃ γ) • pr122 hg) ≃ ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ). Proof. use make_weq. - exact (λ α, ((pr11 α ,, pr2 α) ,, pr21 α)). - use isweq_iso. + exact (λ α, (pr11 α ,, pr2 α) ,, pr21 α). + intro ; apply idpath. + intro ; apply idpath. Defined. Local Definition weq_on_fam (HD : arrow_subbicat_props D) {x y : B} {f : x --> y} {hx : disp_map_bicat_to_disp_bicat x} {hy : disp_map_bicat_to_disp_bicat y} (hf hg : hx -->[ f] hy) (p : pr1 hf = pr1 hg) : (transportf (λ z, pred_mor D (pr12 hx) (pr12 hy) z × invertible_2cell (pr12 hx · f) (z · pr12 hy)) p (pr2 hf) = pr2 hg) ≃ (pr122 hf • (idtoiso_2_1 (pr1 hf) (pr1 hg) p ▹ pr12 hy) = (pr12 hx ◃ id₂ f) • pr122 hg). Proof. induction hf as [ hf₁ hf₂ ]. induction hg as [ hg₁ hg₂ ]. cbn in *. induction p ; cbn. use weqimplimpl. - intro p. induction p. rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right. apply idpath. - intro p. use pathsdirprod. + apply (pr2 HD). + rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right in p. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact p. - use isasetdirprod. + apply isasetaprop. apply (pr2 HD). + apply isaset_invertible_2cell. - apply cellset_property. Qed. Definition disp_map_disp_univalent_2_1 (HD : arrow_subbicat_props D) (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2_1 disp_map_bicat_to_disp_bicat. Proof. intros x y f g p hx hy hf hg. induction p. use weqhomot. - refine (disp_map_inv_2cell_weq_disp_invertible_2cell _ _ _ ∘ refactor_weq _ _ _ ∘ weqtotal2 (make_weq _ (HB_2_1 _ _ _ _)) _ ∘ total2_paths_equiv _ _ _)%weq. exact (weq_on_fam HD _ _). - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; cbn ; use subtypePath ; [ intro ; apply cellset_property | ] ; apply idpath). Defined. (** 4. Adjoint equivalences *) Section AdjEquivToDispAdjEquiv. Context (HB : is_univalent_2 B) {x : B} {hx hy : disp_map_bicat_to_disp_bicat x} (e : adjoint_equivalence (pr1 hx) (pr1 hy)) (com : invertible_2cell (pr12 hx) (e · pr12 hy)). Local Definition adj_equiv_to_disp_adj_equiv_left_adj : hx -->[ internal_adjoint_equivalence_identity x] hy. Proof. use make_disp_map_bicat_mor. - exact e. - apply (arrow_subbicat_contains_equiv_over_id HB D). + exact e. + exact com. - exact (comp_of_invertible_2cell (runitor_invertible_2cell _) com). Defined. Local Notation "'L'" := adj_equiv_to_disp_adj_equiv_left_adj. Local Definition adj_equiv_to_disp_adj_equiv_right_adj : hy -->[ internal_adjoint_equivalence_identity x] hx. Proof. use make_disp_map_bicat_mor. - exact (left_adjoint_right_adjoint e). - pose (einv := inv_adjequiv e). apply (arrow_subbicat_contains_equiv_over_id HB D). + exact (pr2 einv). + exact (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (left_equivalence_unit_iso einv)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell com))))). - refine (runitor _ • linvunitor _ • ((left_equivalence_counit_iso e)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ com^-1) ,, _). is_iso. Defined. Local Notation "'R'" := adj_equiv_to_disp_adj_equiv_right_adj. Local Lemma adj_equiv_to_disp_adj_equiv_unit_coh : pr122 (id_disp hx) • (left_adjoint_unit e ▹ pr12 hx) = (pr12 hx ◃ left_adjoint_unit (internal_adjoint_equivalence_identity x)) • pr122 (L ;; R)%mor_disp. Proof. cbn. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !rwhisker_vcomp. rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. rewrite !vassocl. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_lwhisker. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } cbn. refine (!_). etrans. { rewrite !vassocl. rewrite vcomp_whisker. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite !vassocr. rewrite <- vcomp_runitor. apply idpath. } rewrite !vassocl. apply maponpaths ; clear com. rewrite <- runitor_triangle. rewrite !vassocl. do 2 apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. use vcomp_move_R_pM. { is_iso. } cbn. refine (!_). rewrite linvunitor_assoc. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_vcomp. apply maponpaths. assert (linvunitor (pr1 e) • (pr121 (pr2 e) ▹ pr1 e) = rinvunitor _ • (pr1 e ◃ (pr222 (pr2 e))^-1) • lassociator _ _ _) as p. { refine (_ @ id2_left _). use vcomp_move_L_Mp. { is_iso. } cbn. rewrite !vassocr. exact (pr1 (pr122 e)). } apply maponpaths. exact p. } unfold left_adjoint_right_adjoint. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite <- lassociator_lassociator. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (_ @ id2_right _). use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite runitor_rinvunitor. apply id2_rwhisker. } rewrite id2_left. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_rwhisker. apply idpath. Qed. Local Definition adj_equiv_to_disp_adj_equiv_unit : id_disp hx ==>[ left_adjoint_unit (internal_adjoint_equivalence_identity x) ] L ;; R. Proof. use make_disp_map_bicat_cell. - exact (left_adjoint_unit e). - exact adj_equiv_to_disp_adj_equiv_unit_coh. Defined. Local Notation "'η'" := adj_equiv_to_disp_adj_equiv_unit. Local Lemma adj_equiv_to_disp_adj_equiv_counit_coh : pr122 (R ;; L)%mor_disp • (left_adjoint_counit e ▹ pr12 hy) = (pr12 hy ◃ left_adjoint_counit (internal_adjoint_equivalence_identity x)) • pr122 (id_disp hy). Proof. cbn. rewrite !vassocl. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite <- rwhisker_vcomp. rewrite !vassocl. assert (rassociator (pr112 e) (pr1 e) (pr12 hy) ▹ id₁ _ • rassociator (pr112 e) (pr1 e · pr12 hy) (id₁ _) • (pr112 e ◃ runitor (pr1 e · pr12 hy)) • lassociator (pr112 e) (pr1 e) (pr12 hy) = runitor _) as p. { rewrite !vassocl. rewrite !left_unit_assoc. rewrite !vassocl. rewrite <- vcomp_runitor. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rassociator_lassociator. rewrite id2_rwhisker. apply id2_left. } rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. exact p. } rewrite <- vcomp_runitor. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite vcomp_linv. rewrite !id2_rwhisker. apply idpath. } rewrite id2_left. rewrite vcomp_runitor. apply idpath. Qed. Local Definition adj_equiv_to_disp_adj_equiv_counit : R ;; L ==>[ left_adjoint_counit (internal_adjoint_equivalence_identity x) ] id_disp hy. Proof. use make_disp_map_bicat_cell. - exact (left_adjoint_counit e). - exact adj_equiv_to_disp_adj_equiv_counit_coh. Defined. Local Notation "'ε'" := adj_equiv_to_disp_adj_equiv_counit. Local Definition adj_equiv_to_disp_adj_equiv_data : @disp_left_adjoint_data B disp_map_bicat_to_disp_bicat _ _ (internal_adjoint_equivalence_identity x) (internal_adjoint_equivalence_identity x) hx hy L := (R ,, (η ,, ε)). Local Definition adj_equiv_to_disp_adj_equiv_adjoint_axioms : disp_left_adjoint_axioms (internal_adjoint_equivalence_identity x) adj_equiv_to_disp_adj_equiv_data. Proof. split. - simpl. use subtypePath. { intro. apply cellset_property. } rewrite transportb_disp_map_bicat_cell. cbn. apply (pr2 e). - simpl. use subtypePath. { intro. apply cellset_property. } rewrite transportb_disp_map_bicat_cell. cbn. apply (pr2 e). Qed. Local Definition adj_equiv_to_disp_adj_equiv_equivalence_axioms : disp_left_equivalence_axioms (internal_adjoint_equivalence_identity x) adj_equiv_to_disp_adj_equiv_data. Proof. split. - apply is_invertible_to_is_disp_invertible. apply (pr2 e). - apply is_invertible_to_is_disp_invertible. apply (pr2 e). Defined. Definition disp_map_bicat_adj_equiv_to_disp_adj_equiv : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy. Proof. simple refine (L ,, (_ ,, (_ ,, _))). - exact adj_equiv_to_disp_adj_equiv_data. - exact adj_equiv_to_disp_adj_equiv_adjoint_axioms. - exact adj_equiv_to_disp_adj_equiv_equivalence_axioms. Defined. End AdjEquivToDispAdjEquiv. Section DispAdjEquivToAdjEquiv. Context {x : B} {hx hy : disp_map_bicat_to_disp_bicat x} (e : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy). Local Definition disp_adj_equiv_to_left_adj_data : left_adjoint_data (pr11 e) := (pr1 (pr112 e) ,, (pr11 (pr212 e) ,, pr12 (pr212 e))). Local Definition disp_adj_equiv_to_left_adjoint_axioms : left_adjoint_axioms disp_adj_equiv_to_left_adj_data. Proof. split. - pose (maponpaths pr1 (pr1 (pr122 e))) as p. cbn in p. rewrite transportb_disp_map_bicat_cell in p. exact p. - pose (maponpaths pr1 (pr2 (pr122 e))) as p. cbn in p. rewrite transportb_disp_map_bicat_cell in p. exact p. Qed. Local Definition disp_adj_equiv_to_left_equivalence_axioms : left_equivalence_axioms disp_adj_equiv_to_left_adj_data. Proof. split. - exact (is_disp_invertible_to_is_invertible _ _ (pr1 (pr222 e))). - exact (is_disp_invertible_to_is_invertible _ _ (pr2 (pr222 e))). Defined. Local Definition disp_adj_equiv_to_left_adj_equiv : left_adjoint_equivalence (pr11 e). Proof. refine (disp_adj_equiv_to_left_adj_data ,, _). split. - exact disp_adj_equiv_to_left_adjoint_axioms. - exact disp_adj_equiv_to_left_equivalence_axioms. Defined. Definition disp_adj_equiv_to_adj_equiv : adjoint_equivalence (pr1 hx) (pr1 hy) := (pr11 e ,, disp_adj_equiv_to_left_adj_equiv). Definition disp_adj_equiv_to_adj_equiv_comm : invertible_2cell (pr12 hx) (disp_adj_equiv_to_adj_equiv · pr12 hy) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (pr221 e). Definition disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair : ∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)), invertible_2cell (pr12 hx) (e · pr12 hy) := disp_adj_equiv_to_adj_equiv ,, disp_adj_equiv_to_adj_equiv_comm. End DispAdjEquivToAdjEquiv. Definition adj_equiv_to_disp_adj_equiv_to_adj_equiv (HB : is_univalent_2 B) {x : B} {hx hy : disp_map_bicat_to_disp_bicat x} (z : ∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)), invertible_2cell (pr12 hx) (pr1 e · pr12 hy)) : disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair (disp_map_bicat_adj_equiv_to_disp_adj_equiv HB (pr1 z) (pr2 z)) = z. Proof. use total2_paths_f. - simpl. use subtypePath. { intro ; apply isaprop_left_adjoint_equivalence. exact (pr2 HB). } apply idpath. - use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } unfold invertible_2cell. rewrite pr1_transportf. unfold subtypePath. unfold adjoint_equivalence. etrans. { apply (@transportf_total2_paths_f (pr1 hx --> pr1 hy) left_adjoint_equivalence (λ x, pr12 hx ==> x · pr12 hy)). } cbn. rewrite vassocr. rewrite rinvunitor_runitor. apply id2_left. Qed. Definition disp_adj_equiv_to_adj_equiv_to_disp_adj_equiv (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) {x : B} {hx hy : disp_map_bicat_to_disp_bicat x} (z : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy) : disp_map_bicat_adj_equiv_to_disp_adj_equiv HB (disp_adj_equiv_to_adj_equiv z) (disp_adj_equiv_to_adj_equiv_comm z) = z. Proof. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact (pr2 HB). - apply disp_map_disp_univalent_2_1. + exact HD. + exact (pr2 HB). } cbn. refine (maponpaths (λ z, _ ,, z) _). use pathsdirprod. - apply HD. - use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite vassocr. rewrite runitor_rinvunitor. apply id2_left. Qed. Definition adj_equiv_weq_disp_adj_equiv (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) {x : B} (hx hy : disp_map_bicat_to_disp_bicat x) : (∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)), invertible_2cell (pr12 hx) (e · pr12 hy)) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy. Proof. use make_weq. - exact (λ e, disp_map_bicat_adj_equiv_to_disp_adj_equiv HB (pr1 e) (pr2 e)). - use isweq_iso. + exact disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair. + exact (adj_equiv_to_disp_adj_equiv_to_adj_equiv HB). + exact (disp_adj_equiv_to_adj_equiv_to_disp_adj_equiv HB HD). Defined. (** 5. Global univalence *) Definition weq_fam_global (HB_2_1 : is_univalent_2_1 B) (HD : arrow_subbicat_props D) {x : B} (hx hy : disp_map_bicat_to_disp_bicat x) (p : pr1 hx = pr1 hy) : (transportf (λ z, ∑ (h : z --> x), pred_ob D h) p (pr2 hx) = pr2 hy) ≃ invertible_2cell (pr12 hx) (pr1 (idtoiso_2_0 (pr1 hx) (pr1 hy) p) · pr12 hy). Proof. induction hx as [ hx₁ [ hx₂ hx₃ ] ]. induction hy as [ hy₁ [ hy₂ hy₃ ] ]. cbn in *. induction p ; cbn. refine (_ ∘ path_sigma_hprop _ _ _ _)%weq. - apply HD. - exact (cod_1cell_path_help hx₂ hy₂ ∘ make_weq _ (HB_2_1 _ _ _ _))%weq. Defined. Definition disp_map_bicat_disp_univalent_2_0 (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) : disp_univalent_2_0 disp_map_bicat_to_disp_bicat. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x hx hy. use weqhomot. - exact (adj_equiv_weq_disp_adj_equiv HB HD hx hy ∘ weqtotal2 (make_weq _ (pr1 HB _ _)) (weq_fam_global (pr2 HB) HD _ _) ∘ total2_paths_equiv _ _ _)%weq. - intro p. cbn in p. induction p. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact (pr2 HB). - apply disp_map_disp_univalent_2_1. + exact HD. + exact (pr2 HB). } cbn. refine (maponpaths (λ z, _ ,, z) _). use pathsdirprod. + apply HD. + use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite id2_left. apply idpath. Qed. Definition disp_map_bicat_disp_univalent_2 (HB : is_univalent_2 B) (HD : arrow_subbicat_props D) : disp_univalent_2 disp_map_bicat_to_disp_bicat. Proof. split. - apply disp_map_bicat_disp_univalent_2_0. + exact HB. + exact HD. - apply disp_map_disp_univalent_2_1. + exact HD. + exact (pr2 HB). Defined. End ArrowSubBicatToDispBicat. Definition cod_sfibs (B : bicat) : disp_bicat B := disp_map_bicat_to_disp_bicat (sfib_subbicat B). Definition cod_sopfibs (B : bicat) : disp_bicat B := disp_map_bicat_to_disp_bicat (sopfib_subbicat B). UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Displayed2Inserter.v000066400000000000000000000130631451125700300300040ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Local Open Scope cat. Section DispTwoInserter. Context {B C : bicat} {F G : psfunctor B C} (α β : pstrans F G). Definition disp_two_inserter_disp_cat : disp_cat_ob_mor B. Proof. use make_disp_cat_ob_mor. - exact (λ x , α x ==> β x). - exact (λ x y θ τ f, (θ ▹ #G f) • psnaturality_of β f = psnaturality_of α f • (#F f ◃ τ)). Defined. Definition disp_two_inserter_disp_cat_id_comp : disp_cat_id_comp _ disp_two_inserter_disp_cat. Proof. use tpair ; simpl. - intros x xx. rewrite !pstrans_id_alt. etrans. { rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. apply idpath. - intros x y z f g xx yy zz p q. rewrite !pstrans_comp_alt. etrans. { rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. refine (!_). etrans. { rewrite !vassocl. rewrite <- lwhisker_lwhisker. rewrite !vassocr. apply idpath. } apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite <- q. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. apply maponpaths. rewrite p. apply idpath. Qed. Definition disp_two_inserter_disp_cat_data : disp_cat_data B. Proof. use tpair. - exact disp_two_inserter_disp_cat. - exact disp_two_inserter_disp_cat_id_comp. Defined. Definition disp_two_inserter_prebicat : disp_prebicat B := disp_cell_unit_bicat disp_two_inserter_disp_cat_data. Definition disp_two_inserter_bicat : disp_bicat B := disp_cell_unit_bicat disp_two_inserter_disp_cat_data. Definition disp_two_inserter_univalent_2_1 : disp_univalent_2_1 disp_two_inserter_bicat. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply C. Defined. Definition disp_two_inserter_univalent_2_0 (HB : is_univalent_2_1 B) : disp_univalent_2_0 disp_two_inserter_bicat. Proof. use disp_cell_unit_bicat_univalent_2_0. - exact HB. - intros ; apply C. - simpl ; intro. apply C. - simpl ; intros x xx yy p. induction p as [p₁ p₂]. rewrite !pstrans_id_alt in p₁. rewrite !vassocr in p₁. rewrite vcomp_whisker in p₁. rewrite !vassocl in p₁. assert (H : is_invertible_2cell (α x ◃ (psfunctor_id G x) ^-1)) by is_iso. assert (q₁ := vcomp_lcancel _ H p₁) ; clear p₁ H. cbn -[psfunctor_id] in q₁. rewrite vcomp_whisker in q₁. rewrite !vassocr in q₁. assert (H : is_invertible_2cell (psfunctor_id F x ▹ β x)). { is_iso. apply psfunctor_id. } assert (q₁' := vcomp_rcancel _ H q₁) ; clear q₁ H. rewrite vcomp_runitor in q₁'. rewrite !vassocl in q₁'. assert (H : is_invertible_2cell (runitor (α x))) by is_iso. assert (q₁'' := vcomp_lcancel _ H q₁') ; clear H q₁'. rewrite lwhisker_hcomp in q₁''. rewrite <- linvunitor_natural in q₁''. assert (H : is_invertible_2cell (linvunitor (β x))) by is_iso. assert (q₁''' := vcomp_rcancel _ H q₁'') ; clear H q₁''. exact q₁'''. Qed. Definition disp_two_inserter_cells_isaprop : disp_2cells_isaprop disp_two_inserter_bicat. Proof. intro; intros; exact isapropunit. Qed. Definition disp_two_inserter_locally_groupoid : disp_locally_groupoid disp_two_inserter_bicat. Proof. use make_disp_locally_groupoid. - intro ; intros. exact tt. - exact disp_two_inserter_cells_isaprop. Qed. End DispTwoInserter. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DisplayedCatToBicat.v000066400000000000000000000272201451125700300301040ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** Discrete displayed bicategories Given a displayed category on some bicategory, we construct a displayed bicategory from it. The 2-cells are from the unit type. *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition is_chaotic {C : bicat} (D : disp_bicat C) : UU := ∏ (a b : C) (f g : a --> b) (α : f ==> g) (aa : D a) (bb : D b) (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb), iscontr (ff ==>[ α ] gg). Definition isaprop_is_chaotic {C : bicat} (D : disp_bicat C) : isaprop (is_chaotic D). Proof. repeat (apply impred ; intro). apply isapropiscontr. Qed. Section Disp_Prebicat_Cells_Unit. Context {C : bicat} (D : disp_cat_data C). Definition disp_prebicat_cells_unit : disp_prebicat_1_id_comp_cells C. Proof. exists D. red. intros. exact unit. Defined. Definition disp_prebicat_cells_unit_ops : disp_prebicat_ops disp_prebicat_cells_unit. Proof. repeat use tpair; cbn; intros; exact tt. Defined. Definition disp_prebicat_cells_unit_data : disp_prebicat_data C := _ ,, disp_prebicat_cells_unit_ops. Lemma disp_prebicat_cells_unit_laws : disp_prebicat_laws disp_prebicat_cells_unit_data. Proof. repeat use tpair; red; intros; apply (proofirrelevance _ isapropunit). Qed. Definition disp_cell_unit_prebicat : disp_prebicat C := _ ,, disp_prebicat_cells_unit_laws. Definition disp_cell_unit_bicat : disp_bicat C. Proof. refine (disp_cell_unit_prebicat ,, _). intros a b f g x aa bb ff gg. apply isasetunit. Defined. (** Local Univalence *) Definition disp_cell_unit_bicat_univalent_2_1 (H : ∏ (a b : C) (f : a --> b) (aa : D a) (bb : D b), isaprop (aa -->[ f] bb)) : disp_univalent_2_1 disp_cell_unit_bicat. Proof. intros a b f g p aa bb ff gg. use isweqimplimpl. - cbn in *. intros. apply H. - apply isasetaprop. exact (H a b g aa bb). - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)). + exact isapropunit. + apply (@isaprop_is_disp_invertible_2cell C disp_cell_unit_bicat). Defined. (** Global Univalence *) Definition disp_cell_unit_bicat_is_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_cell_unit_bicat a} {bb : disp_cell_unit_bicat b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x xx. Proof. use tpair. - exact tt. - split ; apply isapropunit. Defined. Definition disp_cell_unit_bicat_left_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) {aa : disp_cell_unit_bicat a} {bb : disp_cell_unit_bicat b} (ff : aa -->[ f] bb) : bb -->[ left_adjoint_right_adjoint f] aa → disp_left_adjoint_equivalence f ff. Proof. intros gg. use tpair. - use tpair. + exact gg. + exact (tt ,, tt). - split ; split ; cbn. + apply isapropunit. + apply isapropunit. + exact (disp_cell_unit_bicat_is_disp_invertible_2cell (left_adjoint_unit f ,, _) tt). + exact (disp_cell_unit_bicat_is_disp_invertible_2cell (left_adjoint_counit f ,, _) tt). Defined. Definition disp_cell_unit_bicat_left_adjoint_equivalence_inv {a b : C} (f : adjoint_equivalence a b) {aa : disp_cell_unit_bicat a} {bb : disp_cell_unit_bicat b} (ff : aa -->[ f] bb) : disp_left_adjoint_equivalence f ff → bb -->[ left_adjoint_right_adjoint f] aa. Proof. intros H. apply H. Defined. Definition disp_cell_unit_bicat_disp_cellset : has_disp_cellset disp_cell_unit_bicat. Proof. intro ; intros. apply isasetunit. Defined. Definition disp_cell_unit_bicat_left_adjoint_equivalence_weq {a b : C} (f : adjoint_equivalence a b) {aa : disp_cell_unit_bicat a} {bb : disp_cell_unit_bicat b} (ff : aa -->[ f] bb) : (bb -->[ left_adjoint_right_adjoint f] aa) ≃ disp_left_adjoint_equivalence f ff. Proof. refine (disp_cell_unit_bicat_left_adjoint_equivalence f ff ,, _). use isweq_iso. - exact (disp_cell_unit_bicat_left_adjoint_equivalence_inv f ff). - reflexivity. - intros y. use subtypePath. + intro. do 2 apply isapropdirprod. * apply disp_cell_unit_bicat_disp_cellset. * apply disp_cell_unit_bicat_disp_cellset. * apply isaprop_is_disp_invertible_2cell. * apply isaprop_is_disp_invertible_2cell. + cbn. unfold disp_cell_unit_bicat_left_adjoint_equivalence_inv. use total2_paths_b. * reflexivity. * use total2_paths_b ; apply isapropunit. Defined. Definition disp_cell_unit_bicat_adjoint_equivalent {a b : C} (f : adjoint_equivalence a b) (aa : disp_cell_unit_bicat a) (bb : disp_cell_unit_bicat b) : (aa -->[ f] bb × bb -->[ left_adjoint_right_adjoint f] aa) ≃ disp_adjoint_equivalence f aa bb. Proof. use weqfibtototal ; cbn. intro. apply disp_cell_unit_bicat_left_adjoint_equivalence_weq. Defined. Definition disp_cell_unit_bicat_idtoiso {a b : C} (p : a = b) (aa : disp_cell_unit_bicat a) (bb : disp_cell_unit_bicat b) : transportf disp_cell_unit_bicat p aa = bb → (aa -->[ idtoiso_2_0 _ _ p ] bb) × (bb -->[ left_adjoint_right_adjoint (idtoiso_2_0 _ _ p)] aa). Proof. induction p ; cbn. intros pp. induction pp ; cbn. split ; apply id_disp. Defined. Definition disp_cell_unit_bicat_univalent_2_0 (HC : is_univalent_2_1 C) (HDP : ∏ (a b : C) (f : a --> b) (aa : D a) (bb : D b), isaprop (aa -->[ f] bb)) (Dset : ∏ (a : C), isaset (D a)) (inv : ∏ (a : C) (aa bb : disp_cell_unit_bicat a), (aa -->[ id₁ a ] bb × bb -->[ id₁ a ] aa) → aa = bb) : disp_univalent_2_0 disp_cell_unit_bicat. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros a aa bb. use isweqimplimpl. - intro η ; cbn. apply inv. exact (invmap (disp_cell_unit_bicat_adjoint_equivalent (idtoiso_2_0 a a (idpath a)) aa bb) η). - apply (Dset a). - apply (isofhlevelweqf 1 (disp_cell_unit_bicat_adjoint_equivalent _ _ _)). apply isapropdirprod ; apply HDP. Defined. Definition disp_cell_unit_bicat_univalent_2 (HC : is_univalent_2_1 C) (HDP : ∏ (a b : C) (f : a --> b) (aa : D a) (bb : D b), isaprop (aa -->[ f] bb)) (Dset : ∏ (a : C), isaset (D a)) (inv : ∏ (a : C) (aa bb : disp_cell_unit_bicat a), (aa -->[ id₁ a ] bb × bb -->[ id₁ a ] aa) → aa = bb) : disp_univalent_2 disp_cell_unit_bicat. Proof. split. - apply disp_cell_unit_bicat_univalent_2_0; assumption. - apply disp_cell_unit_bicat_univalent_2_1; assumption. Defined. End Disp_Prebicat_Cells_Unit. Definition is_chaotic_disp_bicat_cells_unit {C : bicat} (D : disp_cat_data C) : is_chaotic (disp_cell_unit_bicat D). Proof. intro ; intros. apply iscontrunit. Defined. Definition disp_2cells_isaprop_cell_unit_bicat {C : bicat} (D : disp_cat_data C) : disp_2cells_isaprop (disp_cell_unit_bicat D). Proof. intro; intros. apply isapropifcontr. apply (is_chaotic_disp_bicat_cells_unit D). Qed. Definition disp_locally_groupoid_cell_unit_bicat {C : bicat} (D : disp_cat_data C) : disp_locally_groupoid (disp_cell_unit_bicat D). Proof. use make_disp_locally_groupoid. - intro; intros; exact tt. - exact (disp_2cells_isaprop_cell_unit_bicat D). Qed. Lemma isaprop_disp_left_adjoint_data_cell_unit_bicat {C : bicat} {D : disp_cat_data C} {a b : C} {f : C⟦ a, b ⟧} (l : left_adjoint_data f) {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b} (ff : aa -->[ f] bb) : isaprop (bb -->[ left_adjoint_right_adjoint l] aa) -> isaprop (disp_left_adjoint_data l ff). Proof. intro p. use isaproptotal2. - intro ; apply isapropdirprod ; apply isapropunit. - intro ; intros ; apply p. Qed. Lemma isaprop_disp_left_adjoint_axioms_cell_unit_bicat {C : bicat} {D : disp_cat_data C} {a b : C} {f : C⟦ a, b ⟧} (j : left_adjoint f) {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b} {ff : aa -->[ f] bb} (jj : disp_left_adjoint_data j ff) : isaprop (disp_left_adjoint_axioms j jj). Proof. apply isapropdirprod ; apply isasetaprop, isapropunit. Qed. (* To be moved more upstream *) Lemma isaprop_disp_left_equivalence_axioms {C : bicat} {D : disp_cat_data C} {a b : C} {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b} {f : C⟦ a, b ⟧} {j : left_equivalence f} {ff : aa -->[ f] bb} (jj : disp_left_adjoint_data j ff) : isaprop (disp_left_equivalence_axioms j jj). Proof. apply isapropdirprod ; apply isaprop_is_disp_invertible_2cell. Qed. Lemma isaprop_disp_left_adjoint_equivalence_cell_unit_bicat {C : bicat} {D : disp_cat_data C} {a b : C} {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b} (f : adjoint_equivalence a b) (ff : aa -->[ f ] bb) : isaprop (bb -->[ left_adjoint_right_adjoint f] aa) -> isaprop (disp_left_adjoint_equivalence f ff). Proof. intro p. use isaproptotal2. - intro. apply isapropdirprod. + apply isaprop_disp_left_adjoint_axioms_cell_unit_bicat. + apply isaprop_disp_left_equivalence_axioms. - do 4 intro. apply isaprop_disp_left_adjoint_data_cell_unit_bicat, p. Qed. Lemma isaprop_disp_adjoint_equivalence_cell_unit_bicat {C : bicat} {D : disp_cat_data C} {a b : C} {aa : (disp_cell_unit_bicat D) a} {bb : (disp_cell_unit_bicat D) b} {f : adjoint_equivalence a b} (ff : aa -->[ f ] bb) : isaprop (bb -->[left_adjoint_right_adjoint f] aa) -> isaprop (aa -->[ f] bb) -> isaprop (disp_adjoint_equivalence f aa bb). Proof. exact (λ p q, isaprop_total2 (_,,q) (λ _ , _ ,, isaprop_disp_left_adjoint_equivalence_cell_unit_bicat _ _ p)). Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/DisplayedInserter.v000066400000000000000000001430571451125700300277310ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Local Open Scope cat. Definition vcomp_rinvunitor {C : bicat} {a b : C} {f g : a --> b} (α : f ==> g) : rinvunitor f • (α ▹ _) = α • rinvunitor g. Proof. use vcomp_move_R_pM. { is_iso. } simpl. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. apply vcomp_runitor. Qed. Section DisplayedInserter. Context {B C : bicat} (F G : psfunctor B C). (* https://ncatlab.org/nlab/show/dialgebra *) Definition disp_inserter_disp_cat : disp_cat_ob_mor B. Proof. use make_disp_cat_ob_mor. - exact (λ b, C⟦ F b , G b ⟧). - simpl. intros x y fx fy f. exact (#F f · fy ==> fx · #G f). Defined. Definition disp_inserter_disp_cat_id_comp : disp_cat_id_comp _ disp_inserter_disp_cat. Proof. use tpair. - simpl. intros x fx. exact (((psfunctor_id F x)^-1 ▹ fx) • lunitor _ • rinvunitor _ • (_ ◃ psfunctor_id G x)). - simpl. intros x y z f g fx fy fz αf βg. exact (((psfunctor_comp _ _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ βg) • lassociator _ _ _ • (αf ▹ _) • rassociator _ _ _ • (_ ◃ psfunctor_comp _ _ _)). Defined. Definition disp_inserter_disp_cat_2cell : disp_2cell_struct disp_inserter_disp_cat. Proof. intros x y f g α fx fy αf βg. simpl in *. exact (##F α ▹ fy • βg = αf • (_ ◃ ##G α)). Defined. (* F C = C^op G C = Set #G f = id ##G f = id2 *) Definition disp_inserter_prebicat_1 : disp_prebicat_1_id_comp_cells B. Proof. use tpair. - use tpair. + exact disp_inserter_disp_cat. + exact disp_inserter_disp_cat_id_comp. - exact disp_inserter_disp_cat_2cell. Defined. Definition disp_inserter_ops : disp_prebicat_ops disp_inserter_prebicat_1. Proof. repeat split. - simpl ; red. intros x y f fx fy αf. rewrite !psfunctor_id2. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. reflexivity. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros x y f fx fy αf. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp psfunctor_id]. rewrite <- !rwhisker_vcomp. refine (!_). etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. do 6 apply maponpaths_2. apply rwhisker_rwhisker. } rewrite !vassocr. do 7 apply maponpaths_2. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocl. refine (!_). use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite <- psfunctor_lunitor. apply idpath. } refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite vassocr. rewrite <- psfunctor_lunitor. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. apply lwhisker_id2. } rewrite id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros x y f fx gx αf. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp psfunctor_id]. rewrite <- !lwhisker_vcomp. refine (!_). etrans. { rewrite !vassocr. do 8 apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } rewrite !vassocl. refine (!_). use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite <- psfunctor_runitor. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite <- psfunctor_runitor. apply idpath. } rewrite runitor_triangle. rewrite vcomp_runitor. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- left_unit_assoc. rewrite lwhisker_vcomp. rewrite rinvunitor_runitor. rewrite lwhisker_id2. rewrite id2_right. apply lunitor_lwhisker. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros x y f fx fy αf. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 7 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite !lwhisker_vcomp. rewrite <- psfunctor_linvunitor. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. apply lunitor_triangle. } rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } rewrite vcomp_lunitor. do 2 apply maponpaths. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite !rwhisker_vcomp. refine (_ @ id2_left _). apply maponpaths_2. refine (_ @ id2_rwhisker _ _). apply maponpaths. do 3 (use vcomp_move_R_Mp ; is_iso). cbn -[psfunctor_comp psfunctor_id]. rewrite id2_left. apply psfunctor_linvunitor. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros x y f fx fy αf. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 5 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rinvunitor_triangle. rewrite vcomp_rinvunitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- left_unit_inv_assoc. rewrite !lwhisker_vcomp. rewrite <- psfunctor_rinvunitor. apply idpath. } rewrite !vassocr. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lunitor_lwhisker. apply idpath. } rewrite !vassocr. do 3 (use vcomp_move_R_Mp ; is_iso). cbn -[psfunctor_comp psfunctor_id]. rewrite id2_left. rewrite !rwhisker_vcomp. apply maponpaths. apply psfunctor_rinvunitor. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros w x y z f g h fw fx fy fz αf βg γh. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. refine (!_). etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } refine (!_). use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. do 12 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite psfunctor_rassociator. apply idpath. } rewrite !rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_rinv. rewrite id2_right. apply idpath. } rewrite !vassocl. refine (!_). etrans. { do 8 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite psfunctor_rassociator. rewrite !vassocl. rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. do 9 apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. etrans. { apply maponpaths_2. rewrite rwhisker_vcomp, lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2, id2_rwhisker. apply idpath. } apply id2_left. } rewrite !vassocr. etrans. { do 8 apply maponpaths_2. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. etrans. { do 6 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. do 4 apply maponpaths_2. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } refine (!_). etrans. { etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. reflexivity. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. intros w x y z f g h fw fx fy fz αf αg αh. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_L_pM ; is_iso). cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker. etrans. { do 7 apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite vassocr. rewrite !rwhisker_vcomp. rewrite psfunctor_lassociator. rewrite <- !rwhisker_vcomp. apply idpath. } rewrite !vassocl. apply idpath. } use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocl. do 3 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 6 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } refine (!_). etrans. { rewrite !vassocr. apply idpath. } use vcomp_move_R_Mp ; is_iso. { refine (psfunctor_is_iso G (lassociator _ _ _ ,, _)). is_iso. } cbn -[psfunctor_comp psfunctor_id]. rewrite !vassocl. refine (!_). etrans. { do 13 apply maponpaths. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite psfunctor_rassociator. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 9 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. rewrite lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite <- vcomp_whisker. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - simpl ; cbn -[psfunctor_comp psfunctor_id] ; red. unfold disp_inserter_disp_cat_2cell. intros x y f g h α β fx fy αf βg γh p q. rewrite !psfunctor_vcomp. rewrite <- rwhisker_vcomp. rewrite <- lwhisker_vcomp. rewrite vassocl. rewrite q. rewrite vassocr. rewrite p. rewrite vassocl. reflexivity. - simpl ; cbn -[psfunctor_comp psfunctor_id]. unfold disp_inserter_disp_cat_2cell. intros x y z f g₁ g₂ α fx fy fz αf βg₁ βg₂ hα. rewrite !vassocl. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. do 6 apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite psfunctor_lwhisker. rewrite !vassocl. rewrite vcomp_rinv. rewrite id2_right. apply idpath. } rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite hα. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite psfunctor_lwhisker. apply idpath. - simpl ; cbn -[psfunctor_comp psfunctor_id]. unfold disp_inserter_disp_cat_2cell. intros x y z f₁ f₂ g α fx fy fz αf₁ αf₂ βg hα. rewrite !vassocl. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_comp psfunctor_id]. etrans. { rewrite !vassocr. do 6 apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite psfunctor_rwhisker. rewrite !vassocl. rewrite vcomp_rinv. rewrite id2_right. apply idpath. } etrans. { rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } do 3 apply maponpaths. refine (!_). etrans. { rewrite lwhisker_vcomp. rewrite psfunctor_rwhisker. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. apply maponpaths. exact (!hα). Qed. Definition disp_inserter_ops_laws : disp_prebicat_laws (_ ,, disp_inserter_ops). Proof. repeat split ; intro ; intros ; apply C. Qed. Definition disp_inserter_prebicat : disp_prebicat B := (_ ,, disp_inserter_ops_laws). Definition disp_inserter_bicat : disp_bicat B. Proof. refine (disp_inserter_prebicat ,, _). abstract (intros X Y f g α hX hY hf hg hα hβ ; apply isasetaprop ; cbn in * ; unfold disp_inserter_disp_cat_2cell in * ; apply C). Defined. (** Some properties of the displayed inserter *) Definition disp_inserter_locally_propositional : disp_2cells_isaprop disp_inserter_bicat. Proof. intro ; intros. apply C. Qed. Definition disp_inserter_locally_sym : disp_locally_sym disp_inserter_bicat. Proof. intros x y f g α fx fy αf βg hα ; simpl in * ; red in *. use vcomp_move_L_Mp. { is_iso. refine (psfunctor_is_iso G ((_ ^-1) ,, _)). is_iso. } simpl. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. refine (psfunctor_is_iso F ((_ ^-1) ,, _)). is_iso. } simpl. rewrite hα. reflexivity. Qed. Definition disp_inserter_locally_groupoidal : disp_locally_groupoid disp_inserter_bicat. Proof. use make_disp_locally_groupoid. - exact disp_inserter_locally_sym. - exact disp_inserter_locally_propositional. Defined. (** Local univalence *) Definition disp_inserter_bicat_univalent_2_1 : disp_univalent_2_1 disp_inserter_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros x y f fx fy αf βg. apply isweqimplimpl. - cbn ; unfold idfun. intro p. pose (pr1 p) as h. cbn in h. unfold disp_inserter_disp_cat_2cell in h. rewrite !psfunctor_id2 in h. rewrite id2_rwhisker, lwhisker_id2 in h. rewrite id2_left, id2_right in h. exact (!h). - cbn -[isaprop] ; unfold idfun. apply C. - apply isaproptotal2. + exact isaprop_is_disp_invertible_2cell. + intros. apply disp_inserter_locally_propositional. Qed. (** Global univalence *) Section DispAdjEquivToInv2Cell. Context {x : B} {fx fy : disp_inserter_bicat x} (α : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) fx fy). Definition disp_adjequiv_to_inv2cell_cell : fx ==> fy := linvunitor _ • (psfunctor_id F x ▹ fx) • pr112 α • (fy ◃ (psfunctor_id G _)^-1) • runitor _. Definition disp_adjequiv_to_inv2cell_inv : fy ==> fx := linvunitor _ • (psfunctor_id F x ▹ fy) • pr1 α • (fx ◃ (psfunctor_id G _)^-1) • runitor _. Definition disp_adjequiv_to_inv2cell_cell_inv : disp_adjequiv_to_inv2cell_cell • disp_adjequiv_to_inv2cell_inv = id2 _. Proof. unfold disp_adjequiv_to_inv2cell_cell, disp_adjequiv_to_inv2cell_inv. rewrite !vassocl. use vcomp_move_R_pM ; is_iso. use vcomp_move_R_pM ; is_iso. { apply psfunctor_id. } cbn -[psfunctor_id psfunctor_comp]. rewrite !vassocr. use vcomp_move_R_Mp ; is_iso. use vcomp_move_R_Mp ; is_iso. cbn -[psfunctor_id psfunctor_comp]. rewrite !vassocl. rewrite id2_left. pose (pr1 (pr212 α)) as p. cbn -[psfunctor_id psfunctor_comp] in p. unfold disp_inserter_disp_cat_2cell in p. rewrite !vassocr in p. rewrite psfunctor_linvunitor in p. rewrite !rwhisker_vcomp in p. rewrite !vassocl in p. rewrite vcomp_rinv in p. rewrite id2_right in p. rewrite psfunctor_linvunitor in p. rewrite <- lwhisker_vcomp in p. assert (p' := maponpaths (λ z, z • (fx ◃ (psfunctor_comp G _ _)^-1)) p). cbn -[psfunctor_id psfunctor_comp] in p' ; clear p. rewrite !vassocl in p'. rewrite !lwhisker_vcomp in p'. rewrite vcomp_rinv in p'. rewrite lwhisker_id2 in p'. rewrite !id2_right in p'. rewrite <- rwhisker_vcomp in p'. rewrite !vassocl in p'. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) in p'. rewrite rwhisker_rwhisker_alt in p'. rewrite !vassocr in p'. rewrite <- linvunitor_assoc in p'. rewrite !vassocl in p'. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) in p'. rewrite vcomp_whisker in p'. rewrite !vassocl in p'. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) in p'. rewrite <- rwhisker_rwhisker in p'. rewrite !vassocl in p'. use (vcomp_rcancel (fx ◃ (linvunitor (# G (id₁ x)) • (psfunctor_id G x ▹ # G (id₁ x))))). { is_iso. apply psfunctor_id. } rewrite !vassocl. rewrite lwhisker_vcomp. refine (_ @ p') ; clear p'. refine (!_). etrans. { rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply idpath. } apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_runitor. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite linvunitor_assoc. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite <- runitor_triangle. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker_alt. apply idpath. } etrans. { rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite runitor_triangle. rewrite <- vcomp_runitor. apply idpath. } rewrite !vassocl. apply maponpaths. rewrite <- runitor_triangle. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite psfunctor_runitor. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. use vcomp_move_R_pM. { apply psfunctor_comp. } cbn -[psfunctor_id psfunctor_comp]. rewrite id2_right. refine (_ @ id2_left _). use vcomp_move_L_Mp ; is_iso. cbn -[psfunctor_id psfunctor_comp]. rewrite !vassocl. rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- psfunctor_linvunitor. rewrite <- psfunctor_vcomp. rewrite runitor_lunitor_identity. rewrite lunitor_linvunitor. rewrite psfunctor_id2. apply idpath. Qed. Definition disp_adjequiv_to_inv2cell_inv_cell : disp_adjequiv_to_inv2cell_inv • disp_adjequiv_to_inv2cell_cell = id2 _. Proof. unfold disp_adjequiv_to_inv2cell_cell, disp_adjequiv_to_inv2cell_inv. pose (pr2 (pr212 α)) as p. cbn -[psfunctor_id psfunctor_comp] in p. unfold disp_inserter_disp_cat_2cell in p. rewrite !vassocr. use vcomp_move_R_Mp ; is_iso. use vcomp_move_R_Mp ; is_iso. cbn -[psfunctor_id psfunctor_comp]. rewrite id2_left. rewrite !vassocl. use vcomp_move_R_pM ; is_iso. use vcomp_move_R_pM. { is_iso. apply psfunctor_id. } cbn -[psfunctor_id psfunctor_comp]. refine (vcomp_lcancel (## F (lunitor (id₁ x)) ▹ fy) _ _). { is_iso. refine (psfunctor_is_iso _ (lunitor _ ,, _)). is_iso. } rewrite !vassocl in p. refine (_ @ !p) ; clear p. rewrite psfunctor_F_lunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite psfunctor_F_lunitor. rewrite lwhisker_vcomp. refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. apply idpath. } etrans. { do 4 apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lunitor_lwhisker. apply idpath. } use vcomp_move_R_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. rewrite <- vcomp_lunitor. apply idpath. } rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- lunitor_triangle. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !rwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite <- vcomp_runitor. rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. apply maponpaths. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } rewrite !vassocl. rewrite <- rwhisker_vcomp. apply maponpaths. rewrite <- rwhisker_vcomp. rewrite <- lunitor_lwhisker. rewrite <- runitor_triangle. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. use vcomp_move_R_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. rewrite vcomp_lunitor, vcomp_runitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition disp_adjequiv_to_inv2cell : invertible_2cell fx fy. Proof. use make_invertible_2cell. - exact disp_adjequiv_to_inv2cell_cell. - use make_is_invertible_2cell. + exact disp_adjequiv_to_inv2cell_inv. + exact disp_adjequiv_to_inv2cell_cell_inv. + exact disp_adjequiv_to_inv2cell_inv_cell. Defined. End DispAdjEquivToInv2Cell. Section Inv2CellToDispAdjEquiv. Context {x : B} {fx fy : disp_inserter_bicat x} (α : invertible_2cell fx fy). Definition inv2_cell_to_disp_adjequiv_left_adj : fx -->[ internal_adjoint_equivalence_identity x] fy := ((psfunctor_id F x)^-1 ▹ fy) • lunitor _ • α^-1 • rinvunitor _ • (_ ◃ psfunctor_id G x). Definition inv2_cell_to_disp_adjequiv_right_adj : fy -->[ left_adjoint_right_adjoint (internal_adjoint_equivalence_identity x)] fx := ((psfunctor_id F x)^-1 ▹ fx) • lunitor _ • α • rinvunitor _ • (_ ◃ psfunctor_id G x). Definition inv2_cell_to_disp_adjequiv_unit : id_disp fx ==>[left_adjoint_unit (internal_adjoint_equivalence_identity x)] inv2_cell_to_disp_adjequiv_left_adj ;; inv2_cell_to_disp_adjequiv_right_adj. Proof. cbn -[psfunctor_id psfunctor_comp] ; unfold disp_inserter_disp_cat_2cell. cbn in fx, fy. unfold inv2_cell_to_disp_adjequiv_right_adj, inv2_cell_to_disp_adjequiv_left_adj. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } etrans. { rewrite !vassocr. do 13 apply maponpaths_2. rewrite !vassocl. rewrite psfunctor_linvunitor. rewrite !rwhisker_vcomp. rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_rinv. apply id2_left. } rewrite !vassocl. etrans. { do 11 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite psfunctor_linvunitor. rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. rewrite lwhisker_vcomp. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite vcomp_whisker. refine (!_). etrans. { rewrite !vassocr. do 10 apply maponpaths_2. apply maponpaths. apply maponpaths_2. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite vcomp_rinv. rewrite !id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { do 3 apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- lunitor_natural. rewrite <- lwhisker_hcomp. rewrite <- rwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } etrans. { rewrite !vassocr. rewrite runitor_lunitor_identity. rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. rewrite vassocr. rewrite <- vcomp_lunitor. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite vcomp_lunitor. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite rwhisker_hcomp, lwhisker_hcomp. rewrite triangle_r_inv. apply idpath. Qed. Definition inv2_cell_to_disp_adjequiv_counit : inv2_cell_to_disp_adjequiv_right_adj ;; inv2_cell_to_disp_adjequiv_left_adj ==>[left_adjoint_counit (internal_adjoint_equivalence_identity x)] id_disp fy. Proof. simpl ; cbn -[psfunctor_id psfunctor_comp] ; unfold disp_inserter_disp_cat_2cell. unfold inv2_cell_to_disp_adjequiv_left_adj, inv2_cell_to_disp_adjequiv_right_adj. cbn in fx, fy. rewrite !vassocl. use vcomp_move_L_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { etrans. { apply maponpaths. apply maponpaths_2. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocl. use vcomp_move_R_pM ; is_iso. cbn -[psfunctor_id psfunctor_comp]. etrans. { rewrite lwhisker_vcomp. do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite <- psfunctor_lunitor. apply idpath. } refine (!_). etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. rewrite <- vcomp_lunitor. apply idpath. } etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. rewrite psfunctor_F_lunitor. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. apply idpath. } rewrite !vassocl. rewrite <- vcomp_lunitor. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. } rewrite <- rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite runitor_lunitor_identity. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths_2. rewrite !vassocr. rewrite <- vcomp_rinvunitor. rewrite !vassocl. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. rewrite <- rwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp, lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left. apply idpath. } rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite <- lunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. } apply id2_right. Qed. Definition inv2_cell_to_disp_adjequiv : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) fx fy. Proof. use tpair. - exact inv2_cell_to_disp_adjequiv_left_adj. - use tpair. + use tpair. * exact inv2_cell_to_disp_adjequiv_right_adj. * split. ** exact inv2_cell_to_disp_adjequiv_unit. ** exact inv2_cell_to_disp_adjequiv_counit. + abstract (refine ((_ ,, _) ,, (_ ,, _)) ; try apply C ; apply disp_inserter_locally_groupoidal). Defined. End Inv2CellToDispAdjEquiv. Definition inv2_cell_to_disp_adjequiv_weq_left {x : B} {fx fy : disp_inserter_bicat x} (α : invertible_2cell fx fy) : disp_adjequiv_to_inv2cell (inv2_cell_to_disp_adjequiv α) = α. Proof. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. unfold disp_adjequiv_to_inv2cell_cell ; cbn -[psfunctor_id]. unfold inv2_cell_to_disp_adjequiv_right_adj. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. } apply rinvunitor_runitor. } apply id2_right. Qed. Definition inv2_cell_to_disp_adjequiv_weq_right (HB : is_univalent_2_1 B) {x : B} {fx fy : disp_inserter_bicat x} (α : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) fx fy) : inv2_cell_to_disp_adjequiv (disp_adjequiv_to_inv2cell α) = α. Proof. use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence ; try exact HB. exact disp_inserter_bicat_univalent_2_1. } simpl. unfold disp_adjequiv_to_inv2cell, inv2_cell_to_disp_adjequiv_left_adj ; cbn -[psfunctor_id]. unfold disp_adjequiv_to_inv2cell_inv. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite runitor_rinvunitor. apply id2_left. } rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. Qed. Definition inv2_cell_to_disp_adjequiv_weq (HB : is_univalent_2_1 B) {x : B} (fx fy : disp_inserter_bicat x) : invertible_2cell fx fy ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) fx fy. Proof. use make_weq. - exact inv2_cell_to_disp_adjequiv. - use isweq_iso. + exact disp_adjequiv_to_inv2cell. + exact inv2_cell_to_disp_adjequiv_weq_left. + intros. apply inv2_cell_to_disp_adjequiv_weq_right. exact HB. Defined. Definition disp_inserter_bicat_univalent_2_0 (HB : is_univalent_2_1 B) (HC : is_univalent_2_1 C) : disp_univalent_2_0 disp_inserter_bicat. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x fx fy. cbn ; unfold idfun. use weqhomot. - exact (inv2_cell_to_disp_adjequiv_weq HB fx fy ∘ make_weq _ (HC (F x) (G x) fx fy))%weq. - intros p. induction p ; cbn. use subtypePath. + intro ; simpl. apply (@isaprop_disp_left_adjoint_equivalence _ disp_inserter_bicat). * exact HB. * exact disp_inserter_bicat_univalent_2_1. + simpl. unfold inv2_cell_to_disp_adjequiv_left_adj. cbn -[psfunctor_id]. rewrite !vassocl. rewrite id2_left. reflexivity. Qed. End DisplayedInserter. (** Displayed inserters but with pseudo morphisms *) Section PseudoMorphism. Context {B C : bicat} (F G : psfunctor B C). Definition is_pseudo_morphism {x y : total_bicat (disp_inserter_bicat F G)} (f : x --> y) : UU := is_invertible_2cell (pr2 f). Definition identity_pseudo_morphism (x : total_bicat (disp_inserter_bicat F G)) : is_pseudo_morphism (id₁ x). Proof. red ; cbn -[psfunctor_id]. is_iso ; apply psfunctor_id. Qed. Definition comp_pseudo_morphism {x y z : total_bicat (disp_inserter_bicat F G)} {f : x --> y} {g : y --> z} (Hf : is_pseudo_morphism f) (Hg : is_pseudo_morphism g) : is_pseudo_morphism (f · g). Proof. red ; cbn -[psfunctor_comp]. is_iso ; apply psfunctor_comp. Qed. Definition disp_inserter_bicat_pseudo : disp_bicat (total_bicat (disp_inserter_bicat F G)). Proof. simple refine (disp_sub1cell_bicat _ _ _ _). - exact @is_pseudo_morphism. - exact identity_pseudo_morphism. - exact @comp_pseudo_morphism. Defined. Definition disp_inserter_bicat_pseudo_univalent_2_1 : disp_univalent_2_1 disp_inserter_bicat_pseudo. Proof. apply disp_sub1cell_univalent_2_1. intros. apply isaprop_is_invertible_2cell. Defined. Definition disp_inserter_bicat_pseudo_univalent_2_0 (HB : is_univalent_2_1 B) : disp_univalent_2_0 disp_inserter_bicat_pseudo. Proof. apply disp_sub1cell_univalent_2_0. - apply total_is_univalent_2_1. + exact HB. + apply disp_inserter_bicat_univalent_2_1. - intros. apply isaprop_is_invertible_2cell. Defined. End PseudoMorphism. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/EndoMap.v000066400000000000000000000446261451125700300256240ustar00rootroot00000000000000(************************************************************************ The bicategory of objects with an endomorphisms Note: if we would have defined this bicategory via algebras on a pseudofunctor, then we would have obtained a different notion of 1-cell. In this file, we define it in such a way, that the commutativity cell of 1-cells do not have to be invertible. Contents 1. The definition via displayed bicategories 2. The univalence ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section EndoMap. Context (B : bicat). (** 1. The definition via displayed bicategories *) Definition disp_end_ob_mor : disp_cat_ob_mor B. Proof. use make_disp_cat_ob_mor. - exact (λ x, x --> x). - exact (λ x y mx my f, f · my ==> mx · f). Defined. Definition disp_end_cat_id_comp : disp_cat_id_comp B disp_end_ob_mor. Proof. simple refine (_ ,, _). - exact (λ x mx, lunitor _ • rinvunitor _). - exact (λ x y z f g mx my mz mf mg, rassociator _ _ _ • (_ ◃ mg) • lassociator _ _ _ • (mf ▹ _) • rassociator _ _ _). Defined. Definition disp_end_cat_data : disp_cat_data B. Proof. simple refine (_ ,, _). - exact disp_end_ob_mor. - exact disp_end_cat_id_comp. Defined. Definition disp_end_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. simple refine (_ ,, _). - exact disp_end_cat_data. - exact (λ x y f g α mx my mf mg, mf • (_ ◃ α) = (α ▹ _) • mg). Defined. Definition disp_end_prebicat_ops : disp_prebicat_ops disp_end_prebicat_1_id_comp_cells. Proof. repeat split. - intros x y f mx my mf ; cbn in *. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. apply idpath. - intros x y f mx my mf ; cbn in *. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_triangle. rewrite !vcomp_lunitor. rewrite !vassocr. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - intros x y f mx my mf ; cbn in *. rewrite !vassocl. rewrite runitor_triangle. rewrite vcomp_runitor. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- runitor_triangle. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_lwhisker. apply idpath. - intros x y f mx my mf ; cbn in *. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite !lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite <- !lwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite linvunitor_assoc. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. - intros x y f mx my mf ; cbn in *. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite <- left_unit_inv_assoc₂. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. rewrite left_unit_inv_assoc₂. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. - intros w x y z f g h mw mx my mz mf mg mh ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 7 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_lwhisker_rassociator. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. apply maponpaths. rewrite <- rassociator_rassociator. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. apply maponpaths_2. rewrite <- rassociator_rassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. apply id2_left. } rewrite <- rwhisker_lwhisker_rassociator. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. apply idpath. - intros w x y z f g h mw mx my mz mf mg mh ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. do 2 (use vcomp_move_L_Mp ; [ is_iso | ] ; cbn). rewrite !vassocl. do 2 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn). etrans. { do 5 apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite lassociator_lassociator. refine (!_). rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite <- lassociator_lassociator. rewrite !vassocr. apply maponpaths_2. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. apply id2_left. } rewrite rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_right. apply idpath. - intros x y f g h α β mx my mf mg mh mα mβ ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. rewrite mα. rewrite !vassocl. apply maponpaths. exact mβ. - intros x y z f g₁ g₂ α mx my mz mf mg₁ mg₂ mα ; cbn in *. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- mα. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite lwhisker_lwhisker_rassociator. apply idpath. - intros x y z f₁ f₂ g α mx my mz mf₁ mf₂ mg mα ; cbn in *. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- mα. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_lwhisker_rassociator. apply idpath. Qed. Definition disp_end_prebicat_data : disp_prebicat_data B. Proof. simple refine (_ ,, _). - exact disp_end_prebicat_1_id_comp_cells. - exact disp_end_prebicat_ops. Defined. Definition disp_end_prebicat_laws : disp_prebicat_laws disp_end_prebicat_data. Proof. repeat split ; intro ; intros ; apply cellset_property. Qed. Definition disp_end_prebicat : disp_prebicat B. Proof. simple refine (_ ,, _). - exact disp_end_prebicat_data. - exact disp_end_prebicat_laws. Defined. Definition disp_end : disp_bicat B. Proof. simple refine (_ ,, _). - exact disp_end_prebicat. - intro ; intros. use isasetaprop. apply cellset_property. Defined. Definition end_bicat : bicat := total_bicat disp_end. Definition disp_2cells_isaprop_end_bicat : disp_2cells_isaprop disp_end. Proof. intros x y f g τ ex ey ef eg. apply cellset_property. Qed. Definition disp_locally_sym_end_bicat : disp_locally_sym disp_end. Proof. intros x y f g τ ex ey ef eg eτ ; cbn in eτ ; cbn. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. exact (!(eτ)). Qed. Definition disp_locally_groupoid_end_bicat : disp_locally_groupoid disp_end. Proof. use make_disp_locally_groupoid. - exact disp_locally_sym_end_bicat. - exact disp_2cells_isaprop_end_bicat. Qed. (** 2. The univalence *) Definition disp_univalent_2_1_disp_end : disp_univalent_2_1 disp_end. Proof. intros x y f g p ex ey ef eg. induction p. use isweqimplimpl. - intro τ. pose (p := pr1 τ). cbn in p. rewrite lwhisker_id2, id2_rwhisker in p. rewrite id2_left, id2_right in p. cbn. exact p. - apply cellset_property. - use invproofirrelevance. intros τ₁ τ₂. use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ]. apply disp_2cells_isaprop_end_bicat. Qed. Definition inv2cell_to_disp_adj_equiv_disp_end {x : B} {ex ey : disp_end x} (τ : invertible_2cell ex ey) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) ex ey. Proof. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))). - exact (lunitor _ • τ^-1 • rinvunitor _). - exact (lunitor _ • τ • rinvunitor _). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite <- !rwhisker_vcomp ; rewrite !vassocr ; rewrite <- linvunitor_assoc ; refine (!_) ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite !rwhisker_hcomp ; rewrite <- triangle_r_inv ; rewrite <- !lwhisker_hcomp ; rewrite <- !rwhisker_hcomp ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; etrans ; [ do 3 apply maponpaths ; rewrite !vassocr ; rewrite lunitor_triangle ; apply idpath | ] ; etrans ; [ do 2 apply maponpaths ; rewrite !vassocr ; rewrite vcomp_lunitor ; rewrite !vassocl; rewrite rwhisker_hcomp ; rewrite <- rinvunitor_natural ; apply idpath | ] ; rewrite !vassocr ; refine (_ @ id2_left _) ; apply maponpaths_2 ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_left ; rewrite vcomp_lunitor ; apply idpath). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite <- !rwhisker_vcomp ; rewrite !vassocr ; rewrite lunitor_lwhisker ; rewrite runitor_lunitor_identity ; rewrite !vassocl ; apply maponpaths ; rewrite lunitor_lwhisker ; rewrite rwhisker_vcomp ; rewrite rinvunitor_runitor ; rewrite id2_rwhisker ; rewrite id2_right ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite rinvunitor_triangle ; rewrite rwhisker_hcomp ; rewrite <- rinvunitor_natural ; rewrite vcomp_lunitor ; rewrite !vassocl ; apply maponpaths ; rewrite rinvunitor_natural ; rewrite <- rwhisker_hcomp ; apply idpath). - apply disp_2cells_isaprop_end_bicat. - apply disp_2cells_isaprop_end_bicat. - apply disp_locally_groupoid_end_bicat. - apply disp_locally_groupoid_end_bicat. Defined. Definition disp_adj_equiv_to_inv2cell_disp_end {x : B} {ex ey : disp_end x} (τ : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) ex ey) : invertible_2cell ex ey. Proof. use make_invertible_2cell. - exact (linvunitor _ • pr112 τ • runitor _). - use make_is_invertible_2cell. + exact (linvunitor _ • pr1 τ • runitor _). + abstract (rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_right ; use (vcomp_rcancel (ex ◃ linvunitor _)) ; [ is_iso | ] ; refine (_ @ !(pr1 (pr212 τ))) ; cbn ; rewrite !vassocr ; rewrite <- linvunitor_assoc ; refine (!_) ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite <- vcomp_runitor ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite <- vcomp_runitor ; rewrite !vassocl ; apply maponpaths ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite lunitor_linvunitor ; rewrite lwhisker_id2 ; rewrite id2_right ; apply idpath). + abstract (rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_right ; use (vcomp_lcancel (lunitor _ ▹ ey)) ; [ is_iso | ] ; refine (_ @ pr2 (pr212 τ)) ; cbn ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lunitor_triangle ; rewrite <- vcomp_lunitor ; rewrite !vassocl ; apply maponpaths ; rewrite lunitor_runitor_identity ; rewrite runitor_triangle ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite lunitor_triangle ; apply idpath). Defined. Definition inv2cell_weq_disp_adj_equiv_disp_end (HB : is_univalent_2_1 B) {x : B} (ex ey : disp_end x) : invertible_2cell ex ey ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) ex ey. Proof. use make_weq. - exact inv2cell_to_disp_adj_equiv_disp_end. - use isweq_iso. + exact disp_adj_equiv_to_inv2cell_disp_end. + abstract (intros τ ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocr ; rewrite linvunitor_lunitor ; rewrite id2_left ; rewrite !vassocl ; rewrite rinvunitor_runitor ; apply id2_right). + abstract (intros τ ; use subtypePath ; [ intro ; use (isaprop_disp_left_adjoint_equivalence _ _ HB) ; apply disp_univalent_2_1_disp_end | ] ; cbn ; rewrite !vassocr ; rewrite lunitor_linvunitor ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_rinvunitor ; apply id2_right). Defined. Definition disp_univalent_2_0_disp_end (HB : is_univalent_2_1 B) : disp_univalent_2_0 disp_end. Proof. intros x y p ex ey. induction p. use weqhomot. - exact (inv2cell_weq_disp_adj_equiv_disp_end HB ex ey ∘ make_weq _ (HB x x ex ey))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; use (isaprop_disp_left_adjoint_equivalence _ _ HB) ; apply disp_univalent_2_1_disp_end | ] ; cbn ; rewrite id2_right ; apply idpath). Defined. End EndoMap. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/EnrichedCats.v000066400000000000000000000747401451125700300266350ustar00rootroot00000000000000(***************************************************************** The bicategory of univalent enriched categories We construct the bicategory of univalent enriched categories and we prove that this bicategory is univalent. Note that in order to prove the univalence, it is sufficient to assume that the involved monoidal category is univalent as well. To define this bicategory, we use displayed bicategories. The base bicategory is the bicategory of univalent categories. Note that we cannot split this displayed bicategory into smaller parts. That is because to define natural transformations, we need to use composition of enriched categories. Note that the construction of the bicategories of enriched categories as a displayed bicategory, provides some explanation of what the notion of enrichment means. With the usual definition of enriched category, one has a pseudofunctor `V-Cat -> Cat`, which sends every enriched category to its underlying category. The projection pseudofunctor of the displayed bicategory defined in this file, is precisely this pseudofunctor. The notion of enrichment given in `Enrichment.v` represents the fibers of the underlying category pseudofunctor. Contents 1. The displayed bicategory 2. Local univalence 3. Global univalence *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Local Open Scope cat. Local Open Scope moncat. Opaque mon_linvunitor mon_rinvunitor. Section EnrichedCats. Context (V : monoidal_cat). (** 1. The displayed bicategory *) Definition disp_cat_ob_mor_of_enriched_cats : disp_cat_ob_mor bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact (λ (C : univalent_category), enrichment C V). - exact (λ (C₁ C₂ : univalent_category) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) (F : C₁ ⟶ C₂), functor_enrichment F E₁ E₂). Defined. Definition disp_cat_id_comp_of_enriched_cats : disp_cat_id_comp bicat_of_univ_cats disp_cat_ob_mor_of_enriched_cats. Proof. simple refine (_ ,, _). - exact (λ C E, functor_id_enrichment E). - exact (λ C₁ C₂ C₃ F G E₁ E₂ E₃ EF EG, functor_comp_enrichment EF EG). Defined. Definition disp_cat_data_of_enriched_cats : disp_cat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_of_enriched_cats. - exact disp_cat_id_comp_of_enriched_cats. Defined. Definition disp_prebicat_1_id_comp_cells_of_enriched_cats : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_cat_data_of_enriched_cats. - exact (λ C₁ C₂ F G τ E₁ E₂ EF EG, nat_trans_enrichment (pr1 τ) EF EG). Defined. Definition disp_prebicat_ops_of_enriched_cats : disp_prebicat_ops disp_prebicat_1_id_comp_cells_of_enriched_cats. Proof. repeat split ; cbn. - exact (λ C₁ C₂ F E₁ E₂ FE, id_trans_enrichment FE). - exact (λ C₁ C₂ F E₁ E₂ FE, lunitor_enrichment FE). - exact (λ C₁ C₂ F E₁ E₂ FE, runitor_enrichment FE). - exact (λ C₁ C₂ F E₁ E₂ FE, linvunitor_enrichment FE). - exact (λ C₁ C₂ F E₁ E₂ FE, rinvunitor_enrichment FE). - exact (λ C₁ C₂ C₃ C₄ F G H E₁ E₂ E₃ E₄ FE GE HE, lassociator_enrichment FE GE HE). - exact (λ C₁ C₂ C₃ C₄ F G H E₁ E₂ E₃ E₄ FE GE HE, rassociator_enrichment FE GE HE). - exact (λ C₁ C₂ F G H τ τ' E₁ E₂ EF EG EH Eτ Eτ', comp_trans_enrichment Eτ Eτ'). - exact (λ C₁ C₂ C₃ F G₁ G₂ τ E₁ E₂ E₃ EF EG₁ EG₂ Eτ, pre_whisker_enrichment EF Eτ). - exact (λ C₁ C₂ C₃ F₁ F₂ G τ E₁ E₂ E₃ EF₁ EF₂ EG Eτ, post_whisker_enrichment Eτ EG). Qed. Definition disp_prebicat_data_of_enriched_cats : disp_prebicat_data bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_of_enriched_cats. - exact disp_prebicat_ops_of_enriched_cats. Defined. Definition disp_prebicat_laws_of_enriched_cats : disp_prebicat_laws disp_prebicat_data_of_enriched_cats. Proof. repeat split ; intro ; intros ; cbn ; apply isaprop_nat_trans_enrichment. Qed. Definition disp_prebicat_of_enriched_cats : disp_prebicat bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_of_enriched_cats. - exact disp_prebicat_laws_of_enriched_cats. Defined. Definition disp_bicat_of_enriched_cats : disp_bicat bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_of_enriched_cats. - intros C₁ C₂ F G τ E₁ E₂ EF EG. apply isasetaprop. apply isaprop_nat_trans_enrichment. Defined. Definition disp_2cell_isapprop_enriched_cats : disp_2cells_isaprop disp_bicat_of_enriched_cats. Proof. intros C₁ C₂ F G τ E₁ E₂ EF EG. apply isaprop_nat_trans_enrichment. Qed. (** 2. Local univalence *) Definition disp_univalent_2_1_enriched_cats : disp_univalent_2_1 disp_bicat_of_enriched_cats. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros C F G E₁ E₂ FE GE. use isweqimplimpl. - cbn in * ; intro τ. use subtypePath. { intro. apply isaprop_is_functor_enrichment. } use funextsec ; intro x. use funextsec ; intro y. pose (p := pr1 τ x y). cbn in p. rewrite !enriched_from_arr_id in p. refine (_ @ !p @ _) ; clear p. + rewrite <- !(functor_enrichment_id FE). rewrite (tensor_comp_r_id_l _ _ (FE x y)). rewrite !assoc'. rewrite <- (functor_enrichment_comp FE). rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). exact (enrichment_id_left E₁ x y). } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. + rewrite <- !(functor_enrichment_id GE). rewrite (tensor_comp_l_id_l (GE x y)). rewrite !assoc'. rewrite <- (functor_enrichment_comp GE). rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). exact (enrichment_id_right E₁ x y). } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. - apply isaset_functor_enrichment. - use isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply isaprop_nat_trans_enrichment. Qed. (** 3. Global univalence *) Section DispAdjointEquivalence. Context {C : bicat_of_univ_cats} (E₁ E₂ : disp_bicat_of_enriched_cats C). Definition make_disp_adjequiv_enriched (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁) (η : nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂)) (ηinv : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁)) (ε : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂)) (εinv : nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁)) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) E₁ E₂. Proof. simple refine (F₁ ,, (F₂ ,, (η ,, ε)) ,, (_ ,, _)). - abstract (split ; apply disp_2cell_isapprop_enriched_cats). - split. + refine (ηinv ,, _ ,, _) ; apply disp_2cell_isapprop_enriched_cats. + refine (εinv ,, _ ,, _) ; apply disp_2cell_isapprop_enriched_cats. Defined. Definition from_disp_adjequiv_enriched (F : disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) E₁ E₂) : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁), (nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂)) × (nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂)) × (nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁)) × (nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁)). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _). - exact (pr1 F). - exact (pr112 F). - exact (pr1 (pr212 F)). - exact (pr2 (pr212 F)). - exact (pr11 (pr222 F)). - exact (pr12 (pr222 F)). Defined. Definition weq_disp_adjequiv_enriched : (∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁), (nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂)) × (nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂)) × (nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁)) × (nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁))) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) E₁ E₂. Proof. use weq_iso. - exact (λ F, make_disp_adjequiv_enriched (pr1 F) (pr12 F) (pr122 F) (pr12 (pr222 F)) (pr1 (pr222 F)) (pr22 (pr222 F))). - exact from_disp_adjequiv_enriched. - intros F. apply idpath. - abstract (intro F ; refine (maponpaths (λ z, _ ,, z) _) ; refine (maponpaths (λ z, _ ,, z) _) ; repeat (apply isapropdirprod) ; try (apply isaprop_is_disp_invertible_2cell) ; apply disp_bicat_of_enriched_cats). Defined. End DispAdjointEquivalence. Section FromEnrichmentPath. Context {C : bicat_of_univ_cats} {E₁ E₂ : disp_bicat_of_enriched_cats C} (F : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂)). Definition from_enrichment_path_functor_data : functor_enrichment_data (functor_identity _) E₁ E₂ := λ x y, pr1 F x y. Definition from_enrichment_path_functor_is_functor : is_functor_enrichment from_enrichment_path_functor_data. Proof. repeat split. - intro x. exact (pr12 F x). - intros x y z. exact (pr122 F x y z). - intros x y f. exact (!(pr1 (pr222 F) x y f)). Qed. Definition from_enrichment_path_functor : functor_enrichment (functor_identity _) E₁ E₂ := from_enrichment_path_functor_data ,, from_enrichment_path_functor_is_functor. Definition from_enrichment_path_functor_inv_data : functor_enrichment_data (functor_identity _) E₂ E₁ := λ x y, inv_from_z_iso (pr1 F x y). Definition from_enrichment_path_functor_inv_is_functor : is_functor_enrichment from_enrichment_path_functor_inv_data. Proof. repeat split. - intros x. cbn ; unfold from_enrichment_path_functor_inv_data. refine (!_). use z_iso_inv_on_left. refine (!_). exact (pr12 F x). - intros x y z. cbn ; unfold from_enrichment_path_functor_inv_data. refine (!_). use z_iso_inv_on_left. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. exact (pr122 F x y z). } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite !z_iso_after_z_iso_inv. rewrite tensor_id_id. apply id_left. - intros x y f. cbn ; unfold from_enrichment_path_functor_inv_data. use z_iso_inv_on_left. refine (!_). exact (pr1 (pr222 F) x y f). Qed. Definition from_enrichment_path_functor_inv : functor_enrichment (functor_identity _) E₂ E₁ := from_enrichment_path_functor_inv_data ,, from_enrichment_path_functor_inv_is_functor. Definition from_enrichment_path_unit : nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_id_enrichment E₁) (functor_comp_enrichment from_enrichment_path_functor from_enrichment_path_functor_inv). Proof. intros x y. cbn. unfold from_enrichment_path_functor_data. unfold from_enrichment_path_functor_inv_data. rewrite !z_iso_inv_after_z_iso. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } etrans. { apply mon_rinvunitor_runitor. } refine (!_). etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Definition from_enrichment_path_unit_inv : nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_comp_enrichment from_enrichment_path_functor from_enrichment_path_functor_inv) (functor_id_enrichment E₁). Proof. intros x y. cbn. unfold from_enrichment_path_functor_data. unfold from_enrichment_path_functor_inv_data. rewrite !z_iso_inv_after_z_iso. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } etrans. { apply mon_rinvunitor_runitor. } refine (!_). etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Definition from_enrichment_path_counit : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment from_enrichment_path_functor_inv from_enrichment_path_functor) (functor_id_enrichment E₂). Proof. intros x y. cbn. unfold from_enrichment_path_functor_data. unfold from_enrichment_path_functor_inv_data. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } etrans. { apply mon_rinvunitor_runitor. } refine (!_). rewrite z_iso_after_z_iso_inv. etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Definition from_enrichment_path_counit_inv : nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment from_enrichment_path_functor_inv from_enrichment_path_functor). Proof. intros x y. cbn. unfold from_enrichment_path_functor_data. unfold from_enrichment_path_functor_inv_data. rewrite !enriched_from_arr_id. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } etrans. { apply mon_linvunitor_lunitor. } refine (!_). rewrite z_iso_after_z_iso_inv. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply mon_rinvunitor_runitor. Qed. Definition from_enrichment_path : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁), nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁) × nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁) := from_enrichment_path_functor ,, from_enrichment_path_functor_inv ,, from_enrichment_path_unit ,, from_enrichment_path_counit ,, from_enrichment_path_unit_inv ,, from_enrichment_path_counit_inv. End FromEnrichmentPath. Section ToEnrichmentPath. Context {C : bicat_of_univ_cats} {E₁ E₂ : disp_bicat_of_enriched_cats C} (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁) (η : nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂)) (ε : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂)). Definition to_enrichment_path_inv_left (x y : (C : univalent_category)) : pr1 F₁ x y · pr1 F₂ x y = identity _. Proof. pose (p := η x y). cbn in p. rewrite !enriched_from_arr_id in p. rewrite !assoc' in p. assert (mon_rinvunitor _ · ((F₁ x y · F₂ x y) #⊗ enriched_id _ x · enriched_comp _ x x y) = identity _) as p'. { refine (p @ _). etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. } refine (_ @ p'). rewrite tensor_comp_r_id_l. rewrite !assoc. refine (!_). etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc' ; cbn. apply maponpaths. rewrite tensor_split'. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply mon_rinvunitor_runitor. Qed. Definition to_enrichment_path_inv_right (x y : (C : univalent_category)) : pr1 F₂ x y · pr1 F₁ x y = identity _. Proof. pose (p := ε x y). cbn in p. rewrite !enriched_from_arr_id in p. rewrite !assoc' in p. assert (mon_linvunitor _ · (enriched_id _ y #⊗ (F₂ x y · F₁ x y) · enriched_comp _ x y y) = identity _) as p'. { refine (!p @ _). etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply mon_rinvunitor_runitor. } refine (_ @ p'). rewrite tensor_comp_l_id_l. rewrite !assoc. refine (!_). etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_linvunitor. } rewrite !assoc' ; cbn. apply maponpaths. rewrite tensor_split. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_linvunitor. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Definition to_enrichment_path : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - refine (λ x y, _). use make_z_iso. + exact (pr1 F₁ x y). + exact (pr1 F₂ x y). + split. * exact (to_enrichment_path_inv_left x y). * exact (to_enrichment_path_inv_right x y). - abstract (intros x ; cbn ; exact (pr12 F₁ x)). - abstract (intros x y z ; cbn ; exact (pr122 F₁ x y z)). - abstract (intros x y f ; cbn ; exact (!(pr222 F₁ x y f))). - abstract (intros x y f ; cbn ; use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E₂ x y))) ; cbn ; rewrite !(enriched_from_to_arr E₂) ; refine (pr222 F₁ x y (enriched_to_arr (pr1 E₁) f) @ _) ; apply maponpaths_2 ; rewrite !(enriched_from_to_arr E₁) ; apply idpath). Defined. End ToEnrichmentPath. Definition disp_univalent_2_0_enriched_cats_help_path {C : bicat_of_univ_cats} {E₁ E₂ : disp_bicat_of_enriched_cats C} (F G : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁), nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁) × nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁)) (p : pr11 F = pr11 G) (q : pr112 F = pr112 G) : F = G. Proof. induction F as [ F₁ F₂ ]. induction F₁ as [ F₁ HF₁ ]. induction F₂ as [ F₂ R ]. induction F₂ as [ F₂ HF₂ ]. induction G as [ G₁ G₂ ]. induction G₁ as [ G₁ HG₁ ]. induction G₂ as [ G₂ Q ]. induction G₂ as [ G₂ HG₂ ]. cbn in *. induction p. induction q. assert (p : HF₁ = HG₁). { apply isaprop_is_functor_enrichment. } induction p. apply maponpaths. assert (p : HF₂ = HG₂). { apply isaprop_is_functor_enrichment. } induction p. apply maponpaths. repeat (apply isapropdirprod) ; apply isaprop_nat_trans_enrichment. Qed. Definition disp_univalent_2_0_enriched_cats_help {C : bicat_of_univ_cats} (E₁ E₂ : disp_bicat_of_enriched_cats C) : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂) ≃ (∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂) (F₂ : functor_enrichment (functor_identity _) E₂ E₁), nat_trans_enrichment (nat_trans_id (functor_identity _)) (functor_id_enrichment E₁) (functor_comp_enrichment F₁ F₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₂ F₁) (functor_id_enrichment E₂) × nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment F₁ F₂) (functor_id_enrichment E₁) × nat_trans_enrichment (nat_trans_id _) (functor_id_enrichment E₂) (functor_comp_enrichment F₂ F₁)). Proof. use weq_iso. - exact from_enrichment_path. - exact (λ F, to_enrichment_path (pr1 F) (pr12 F) (pr122 F) (pr1 (pr222 F))). - abstract (intros F ; use subtypePath ; [ intro ; repeat (apply isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property | ] ; use funextsec ; intro x ; use funextsec ; intro y ; use z_iso_eq ; apply idpath). - abstract (intros F ; use disp_univalent_2_0_enriched_cats_help_path ; apply idpath). Defined. Definition disp_univalent_2_0_enriched_cats (HV : is_univalent V) : disp_univalent_2_0 disp_bicat_of_enriched_cats. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros C₁ E₁ E₂. use weqhomot. - exact (weq_disp_adjequiv_enriched _ _ ∘ disp_univalent_2_0_enriched_cats_help E₁ E₂ ∘ enrichment_data_hom_path HV _ _ ∘ total2_paths_equiv _ _ _ ∘ path_sigma_hprop _ _ _ (isaprop_enrichment_laws _))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply isaprop_disp_left_adjoint_equivalence ; [ apply univalent_cat_is_univalent_2_1 | ] ; exact disp_univalent_2_1_enriched_cats | ] ; use subtypePath ; [ intro ; apply isaprop_is_functor_enrichment | ] ; apply idpath). Defined. Definition bicat_of_enriched_cats : bicat := total_bicat disp_bicat_of_enriched_cats. Definition is_univalent_2_1_bicat_of_enriched_cats : is_univalent_2_1 bicat_of_enriched_cats. Proof. use total_is_univalent_2_1. - exact univalent_cat_is_univalent_2_1. - exact disp_univalent_2_1_enriched_cats. Defined. Definition is_univalent_2_0_bicat_of_enriched_cats (HV : is_univalent V) : is_univalent_2_0 bicat_of_enriched_cats. Proof. use total_is_univalent_2_0. - exact univalent_cat_is_univalent_2_0. - use disp_univalent_2_0_enriched_cats. exact HV. Defined. Definition is_univalent_2_bicat_of_enriched_cats (HV : is_univalent V) : is_univalent_2 bicat_of_enriched_cats. Proof. split. - exact (is_univalent_2_0_bicat_of_enriched_cats HV). - exact is_univalent_2_1_bicat_of_enriched_cats. Defined. Definition underlying_cat : psfunctor bicat_of_enriched_cats bicat_of_univ_cats := pr1_psfunctor _. Definition eq_2cell_enriched {E₁ E₂ : bicat_of_enriched_cats} {F G : E₁ --> E₂} {τ₁ τ₂ : F ==> G} (p : ∏ x, pr11 τ₁ x = pr11 τ₂ x) : τ₁ = τ₂. Proof. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } exact p. Qed. Definition from_is_invertible_2cell_enriched {E₁ E₂ : bicat_of_enriched_cats} {F G : E₁ --> E₂} (τ : invertible_2cell F G) : nat_z_iso (pr1 F) (pr1 G). Proof. use invertible_2cell_to_nat_z_iso. exact (_ ,, psfunctor_is_iso underlying_cat τ). Defined. Definition make_is_invertible_2cell_enriched (HV : faithful_moncat V) {E₁ E₂ : bicat_of_enriched_cats} {F G : E₁ --> E₂} (τ : F ==> G) (Hτ : is_nat_z_iso (pr11 τ)) : is_invertible_2cell τ. Proof. use make_is_invertible_2cell. - simple refine (_ ,, _). + exact (pr1 (nat_z_iso_inv (make_nat_z_iso _ _ _ Hτ))). + apply (faithful_moncat_nat_trans_enrichment HV (pr1 (nat_z_iso_inv (make_nat_z_iso _ _ _ Hτ)))). - abstract (use eq_2cell_enriched ; intro x ; apply (z_iso_inv_after_z_iso (_ ,, Hτ x))). - abstract (use eq_2cell_enriched ; intro x ; apply (z_iso_after_z_iso_inv (_ ,, Hτ x))). Defined. End EnrichedCats. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/FullSub.v000066400000000000000000000244261451125700300256510ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 Full subbicategory of a bicategory and proof that it's univalent. ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Local Open Scope cat. Local Open Scope mor_disp_scope. (* ----------------------------------------------------------------------------------- *) (** Full sub-bicategory associated to a bicategory and a predicate on objects *) (* ----------------------------------------------------------------------------------- *) Section FullSubBicat. Variable (C : bicat) (P : C → UU). Definition disp_fullsubprebicat : disp_prebicat C := disp_cell_unit_prebicat (disp_full_sub_data C P). Definition disp_fullsubbicat : disp_bicat C. Proof. exists disp_fullsubprebicat. red. cbn. intros. exact isasetunit. Defined. Definition fullsubbicat : bicat := total_bicat disp_fullsubbicat. Definition fullsub : UU := fullsubbicat. Definition morfullsub (X Y : fullsub) : UU := fullsubbicat⟦X,Y⟧. Definition cellfullsub {X Y : fullsub} (f g : morfullsub X Y) : UU := f ==> g. Coercion ob_of_fullsub (X : fullsub) : ob C := pr1 X. Coercion fullsub_to_mor {X Y : fullsub} (f : morfullsub X Y) : C⟦pr1 X,pr1 Y⟧ := pr1 f. Coercion fullsub_to_cell {X Y : fullsub} {f g : morfullsub X Y} (α : cellfullsub f g) : prebicat_cells C f g := pr1 α. Definition mor_of_fullsub {X Y : fullsub} (f : @precategory_morphisms C X Y) : morfullsub X Y := (f ,, tt). Definition cell_of_fullsub {X Y : fullsubbicat} {f g : X --> Y} (α : pr1 f ==> pr1 g) : f ==> g := (α ,, tt). Definition fullsub_is_invertible_2cell_to_bicat_is_invertible_2cell {X Y : fullsubbicat} {f g : X --> Y} (α : f ==> g) : is_invertible_2cell α → @is_invertible_2cell C (pr1 X) (pr1 Y) (pr1 f) (pr1 g) (pr1 α). Proof. intros Hα. use tpair. - apply Hα. - split ; cbn. + exact (base_paths _ _ (vcomp_rinv Hα)). + exact (base_paths _ _ (vcomp_linv Hα)). Defined. Definition bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell {X Y : fullsubbicat} {f g : X --> Y} (α : f ==> g) : @is_invertible_2cell C (pr1 X) (pr1 Y) (pr1 f) (pr1 g) (pr1 α) → is_invertible_2cell α. Proof. intros Hα. use tpair. - refine (_ ,, tt). apply Hα. - split ; use subtypePath. + intro ; apply isapropunit. + apply Hα. + intro ; apply isapropunit. + apply Hα. Defined. Definition bicat_is_invertible_2cell_is_fullsub_is_invertible_2cell {X Y : fullsubbicat} {f g : X --> Y} (α : f ==> g) : @is_invertible_2cell C (pr1 X) (pr1 Y) (pr1 f) (pr1 g) (pr1 α) ≃ is_invertible_2cell α. Proof. use weqimplimpl. - exact (bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell α). - exact (fullsub_is_invertible_2cell_to_bicat_is_invertible_2cell α). - apply isaprop_is_invertible_2cell. - apply isaprop_is_invertible_2cell. Defined. Definition disp_fullsubbicat_univalent_2_1 : disp_univalent_2_1 disp_fullsubbicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros x y f xx yy ff gg. use isweqimplimpl. - intros. apply isapropunit. - apply isasetaprop. exact isapropunit. - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)). + exact isapropunit. + simpl. apply (@isaprop_is_disp_invertible_2cell C disp_fullsubbicat _ _ _ _ (id2_invertible_2cell f)). Defined. Definition is_univalent_2_1_fullsubbicat (HC : is_univalent_2_1 C) : is_univalent_2_1 fullsubbicat. Proof. apply total_is_univalent_2_1. - exact HC. - exact disp_fullsubbicat_univalent_2_1. Defined. Definition fullsub_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence {X Y : fullsubbicat} (f : X --> Y) : left_adjoint_equivalence f → @left_adjoint_equivalence C (pr1 X) (pr1 Y) (pr1 f). Proof. intros Hf. use tpair. - use tpair. + exact (pr1 (left_adjoint_right_adjoint Hf)). + split. * exact (pr1 (left_adjoint_unit Hf)). * exact (pr1 (left_adjoint_counit Hf)). - split ; split. + exact (base_paths _ _ (internal_triangle1 Hf)). + exact (base_paths _ _ (internal_triangle2 Hf)). + cbn. apply (fullsub_is_invertible_2cell_to_bicat_is_invertible_2cell (left_adjoint_unit (pr1 Hf))). apply Hf. + cbn. apply (fullsub_is_invertible_2cell_to_bicat_is_invertible_2cell (left_adjoint_counit (pr1 Hf))). apply Hf. Defined. Definition bicat_left_adjoint_equivalence_to_fullsub_left_adjoint_equivalence {X Y : fullsubbicat} (f : X --> Y) : @left_adjoint_equivalence C (pr1 X) (pr1 Y) (pr1 f) → left_adjoint_equivalence f. Proof. intros Hf. use tpair. - use tpair. + exact (left_adjoint_right_adjoint Hf ,, tt). + split. * exact (left_adjoint_unit Hf ,, tt). * exact (left_adjoint_counit Hf ,, tt). - split ; split. + use subtypePath. * intro ; apply isapropunit. * exact (internal_triangle1 Hf). + use subtypePath. * intro ; apply isapropunit. * exact (internal_triangle2 Hf). + apply bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell. apply Hf. + apply bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell. apply Hf. Defined. Definition fullsub_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence {X Y : fullsubbicat} (f : X --> Y) : left_adjoint_equivalence f ≃ @left_adjoint_equivalence C (pr1 X) (pr1 Y) (pr1 f). Proof. use make_weq. - exact (fullsub_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence f). - use isweq_iso. + exact (bicat_left_adjoint_equivalence_to_fullsub_left_adjoint_equivalence f). + intros x. use subtypePath. * intro. do 2 apply isapropdirprod. ** apply fullsubbicat. ** apply fullsubbicat. ** apply isaprop_is_invertible_2cell. ** apply isaprop_is_invertible_2cell. * induction x as [a hx]. induction a as [r uc]. induction uc as [η ε]. induction r as [r x]. induction x. induction η as [η x]. induction x. induction ε as [ε x]. induction x. cbn in *. reflexivity. + intros x. use subtypePath. * intro. do 2 apply isapropdirprod ; try (apply C) ; apply isaprop_is_invertible_2cell. * reflexivity. Defined. Definition bicat_adjoint_equivalence_is_fullsub_adjoint_equivalence (X Y : fullsubbicat) : @adjoint_equivalence C (pr1 X) (pr1 Y) ≃ adjoint_equivalence X Y. Proof. apply invweq. use weqtotal2. - apply invweq. apply weqtodirprodwithunit. - intro ; cbn. apply fullsub_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence. Defined. Definition disp_left_adjoint_equivalence_fullsubbicat {x y : C} {l : x --> y} (Hl : left_adjoint_equivalence l) {Hx : disp_fullsubbicat x} {Hy : disp_fullsubbicat y} (ll : Hx -->[ l ] Hy) : disp_left_adjoint_equivalence Hl ll. Proof. simple refine ((tt ,, (tt ,, tt)) ,, ((_ ,, _) ,, ((tt ,, (_ ,, _)) ,, (tt ,, (_ ,, _))))) ; apply isapropunit. Defined. Definition disp_univalent_2_0_fullsubbicat (HC : is_univalent_2 C) (HP : ∏ (x : C), isaprop (P x)) : disp_univalent_2_0 disp_fullsubbicat. Proof. intros x y p xx yy. induction p. use isweqimplimpl. - intros ; cbn in *. apply HP. - apply isasetaprop. apply HP. - simple refine (isaprop_total2 (_ ,, _) (λ η , _ ,, _)). + exact isapropunit. + apply isaprop_disp_left_adjoint_equivalence. * apply (pr2 HC). * exact disp_fullsubbicat_univalent_2_1. Defined. Definition is_univalent_2_0_fullsubbicat (HC : is_univalent_2 C) (HP : ∏ (x : C), isaprop (P x)) : is_univalent_2_0 fullsubbicat. Proof. apply total_is_univalent_2_0. - exact (pr1 HC). - exact (disp_univalent_2_0_fullsubbicat HC HP). Defined. Definition is_univalent_2_fullsubbicat (HC : is_univalent_2 C) (HP : ∏ (x : C), isaprop (P x)) : is_univalent_2 fullsubbicat. Proof. split. - apply is_univalent_2_0_fullsubbicat; assumption. - apply is_univalent_2_1_fullsubbicat. exact (pr2 HC). Defined. Definition disp_2cells_isaprop_fullsubbicat : disp_2cells_isaprop disp_fullsubbicat. Proof. intro; intros; exact isapropunit. Qed. Definition disp_locally_groupoid_fullsubbicat : disp_locally_groupoid disp_fullsubbicat. Proof. use make_disp_locally_groupoid. - intro; intros. exact tt. - exact disp_2cells_isaprop_fullsubbicat. Qed. End FullSubBicat. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/FunctorsIntoCat.v000066400000000000000000000170661451125700300273640ustar00rootroot00000000000000(****************************************************************************************** The displayed bicategory of functors into categories In this file, we look at the displayed bicategory of functors into the category of strict categories. Note that here, we restrict ourselves to functors starting in strict categories. In addition, note that a functor into the category of strict categories is the same as a split opfibration on the source. Contents: 1. Definition 2. Properties ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.StrictCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Local Open Scope cat. (** 1. Definition *) Definition disp_cat_ob_mor_of_functors_into_cat : disp_cat_ob_mor bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact (λ C, pr1 C ⟶ cat_of_setcategory). - exact (λ C₁ C₂ G₁ G₂ F, G₁ ⟹ F ∙ G₂). Defined. Definition disp_cat_id_comp_of_functors_into_cat : disp_cat_id_comp bicat_of_strict_cats disp_cat_ob_mor_of_functors_into_cat. Proof. simple refine (_ ,, _). - exact (λ C G, nat_trans_id _). - exact (λ C₁ C₂ C₃ F₁ F₂ G₁ G₂ G₃ α β, nat_trans_comp _ _ _ α (pre_whisker _ β)). Defined. Definition disp_cat_data_of_functors_into_cat : disp_cat_data bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_of_functors_into_cat. - exact disp_cat_id_comp_of_functors_into_cat. Defined. Definition disp_prebicat_1_id_comp_cells_of_functors_into_cat : disp_prebicat_1_id_comp_cells bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact disp_cat_data_of_functors_into_cat. - intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂. exact (∏ (x : pr1 C₁), pr1 β₁ x · # (pr1 G₂) (pr1 α x) = pr1 β₂ x). Defined. Definition disp_prebicat_ops_of_functors_into_cat : disp_prebicat_ops disp_prebicat_1_id_comp_cells_of_functors_into_cat. Proof. repeat split. - intros C₁ C₂ F G₁ G₂ α x ; cbn. etrans. { apply maponpaths. apply (functor_id G₂). } exact (id_right (pr1 α x)). - intros C₁ C₂ F G₁ G₂ α x ; cbn. etrans. { apply maponpaths. apply (functor_id G₂). } etrans. { apply maponpaths_2. exact (id_left (pr1 α x)). } exact (id_right (pr1 α x)). - intros C₁ C₂ F G₁ G₂ α x ; cbn. etrans. { apply maponpaths. apply (functor_id G₂). } etrans. { apply maponpaths_2. exact (id_right (pr1 α x)). } exact (id_right (pr1 α x)). - intros C₁ C₂ F G₁ G₂ α x ; cbn. etrans. { apply maponpaths. apply (functor_id G₂). } exact (id_right (pr1 α x) @ !(id_left (pr1 α x))). - intros C₁ C'_2 F G₁ G₂ α x ; cbn. apply maponpaths. apply (functor_id G₂). - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃ G₁ G₂ G₃ G₄ α₁ α₂ α₃ x ; cbn. etrans. { apply maponpaths. apply (functor_id G₄). } etrans. { exact (id_right (pr1 α₁ _ · pr1 α₂ _ · pr1 α₃ _)). } rewrite !assoc'. apply idpath. - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃ G₁ G₂ G₃ G₄ α₁ α₂ α₃ x ; cbn. etrans. { apply maponpaths. apply (functor_id G₄). } etrans. { exact (id_right (pr1 α₁ _ · (pr1 α₂ _ · pr1 α₃ _))). } rewrite !assoc. apply idpath. - intros C₁ C₂ F₁ F₂ F₃ α β G₁ G₂ γ₁ γ₂ γ₃ p₁ p₂ x ; cbn. etrans. { apply maponpaths. apply (functor_comp G₂). } refine (_ @ p₂ x). refine (_ @ maponpaths (λ z, z ∙ _) (p₁ x)). apply (assoc _ (# (pr1 G₂) (pr1 α x)) (# (pr1 G₂) (pr1 β x))). - intros C₁ C₂ C₃ F₁ F₂ F₃ α G₁ G₂ G₃ β₁ β₂ β₃ p x ; cbn. refine (assoc' (pr1 β₁ x) _ _ @ _). apply maponpaths. apply p. - intros C₁ C₂ C₃ F₁ F₂ F₃ α G₁ G₂ G₃ β₁ β₂ β₃ p x ; cbn. refine (!_). etrans. { apply maponpaths_2. exact (!(p _)). } refine (assoc' _ _ _ @ _ @ assoc (pr1 β₁ x) (pr1 β₃ (pr1 F₁ x)) _). apply maponpaths. apply (nat_trans_ax β₃). Qed. Definition disp_prebicat_data_of_functors_into_cat : disp_prebicat_data bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_of_functors_into_cat. - exact disp_prebicat_ops_of_functors_into_cat. Defined. Definition isaprop_2cells_of_functors_into_cat {C₁ C₂ : bicat_of_strict_cats} {F₁ F₂ : C₁ --> C₂} (α : F₁ ==> F₂) {G₁ : disp_prebicat_data_of_functors_into_cat C₁} {G₂ : disp_prebicat_data_of_functors_into_cat C₂} (β₁ : G₁ -->[ F₁ ] G₂) (β₂ : G₁ -->[ F₂ ] G₂) : isaprop (β₁ ==>[ α ] β₂). Proof. use impred ; intro. apply homset_property. Qed. Definition disp_prebicat_laws_of_functors_into_cat : disp_prebicat_laws disp_prebicat_data_of_functors_into_cat. Proof. repeat split ; intro ; intros ; apply isaprop_2cells_of_functors_into_cat. Qed. Definition disp_prebicat_of_functors_into_cat : disp_prebicat bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_of_functors_into_cat. - exact disp_prebicat_laws_of_functors_into_cat. Defined. Definition disp_bicat_of_functors_into_cat : disp_bicat bicat_of_strict_cats. Proof. simple refine (_ ,, _). - exact disp_prebicat_of_functors_into_cat. - intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂. apply isasetaprop. apply isaprop_2cells_of_functors_into_cat. Defined. (** 2. Properties *) Definition functors_into_cat_disp_2cells_isaprop : disp_2cells_isaprop disp_bicat_of_functors_into_cat. Proof. intro ; intros. apply isaprop_2cells_of_functors_into_cat. Qed. Definition functors_into_cat_disp_locally_sym : disp_locally_sym disp_bicat_of_functors_into_cat. Proof. intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂ p x. etrans. { apply maponpaths_2. exact (!(p x)). } refine (assoc' (pr1 β₁ x) _ _ @ _ @ id_right _). apply maponpaths. refine (!(functor_comp G₂ _ _) @ _ @ functor_id G₂ _). apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv α) x). Qed. Definition functors_into_cat_disp_locally_groupoid : disp_locally_groupoid disp_bicat_of_functors_into_cat. Proof. use make_disp_locally_groupoid. - exact functors_into_cat_disp_locally_sym. - exact functors_into_cat_disp_2cells_isaprop. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/KleisliTriple.v000066400000000000000000000327761451125700300270600ustar00rootroot00000000000000(* ******************************************************************************* *) (** Kleisli triples ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope bicategory_scope. Definition kleisli_triple (C : category) : UU := ∑ (M : ob C → ob C) (η : ∏ (A : C), A --> M A) (bind : ∏ (A B : C), A --> M B → M A --> M B), (∏ (A : C), bind A A (η A) = id₁ (M A)) × (∏ (A B : C) (f : A --> M B), η A · bind A B f = f) × ∏ (A B C : C) (f : A --> M B) (g : B --> M C), bind A B f · bind B C g = bind A C (f · bind B C g). Definition make_kleisli_triple {C : category} (M : ob C → ob C) (η : ∏ (A : C), A --> M A) (bind : ∏ (A B : C), A --> M B → M A --> M B) (bind_unit : ∏ (A : C), bind A A (η A) = id₁ (M A)) (unit_bind : ∏ (A B : C) (f : A --> M B), η A · bind A B f = f) (bind_bind : ∏ (A B C : C) (f : A --> M B) (g : B --> M C), bind A B f · bind B C g = bind A C (f · bind B C g)) : kleisli_triple C := (M,, η,, bind,, (bind_unit,, unit_bind,, bind_bind)). Definition object_map_kt {C : category} (M : kleisli_triple C) : ob C → ob C := pr1 M. Coercion object_map_kt : kleisli_triple >-> Funclass. Section Projections. Context {C : category} (M : kleisli_triple C). Definition unit_kt : ∏ (A : C), A --> M A := pr12 M. Definition bind_kt : ∏ {A B : C}, A --> M B → M A --> M B := pr122 M. Definition functor_data_of_kleisli_triple : functor_data C C. Proof. use make_functor_data. - exact (pr1 M). - exact (λ a b f, bind_kt (f · unit_kt b)). Defined. Definition bind_unit : ∏ (A : C), bind_kt (unit_kt A) = id₁ (M A) := pr1 (pr222 M). Definition unit_bind : ∏ {A B : C} (f : A --> M B), unit_kt A · bind_kt f = f := pr12 (pr222 M). Definition bind_bind : ∏ {A B C : C} (f : A --> M B) (g : B --> M C), bind_kt f · bind_kt g = bind_kt (f · bind_kt g) := pr22 (pr222 M). Definition functor_laws_of_kleisli_triple : is_functor functor_data_of_kleisli_triple. Proof. split. - intros X ; cbn. rewrite id_left, bind_unit. apply idpath. - intros X Y Z f g ; cbn. rewrite bind_bind. rewrite <- !assoc. rewrite unit_bind. apply idpath. Qed. Definition functor_of_kleisli_triple : functor C C. Proof. use make_functor. - exact functor_data_of_kleisli_triple. - exact functor_laws_of_kleisli_triple. Defined. End Projections. Definition kleisli_triple_on_functor {C D : category} (MC : kleisli_triple C) (MD : kleisli_triple D) (F : C ⟶ D) : UU := ∑ (MF : ∏ (X : C), z_iso (MD (F X)) (F (MC X))), (∏ (A : C), #F (unit_kt MC A) = unit_kt MD (F A) · MF A) × (∏ (A B : C) (f : A --> MC B), #F (bind_kt MC f) = inv_from_z_iso (MF A) · bind_kt MD (#F f · inv_from_z_iso (MF B)) · MF B). Definition make_kleisli_triple_on_functor {C D : category} {MC : kleisli_triple C} {MD : kleisli_triple D} {F : C ⟶ D} (MF : ∏ (X : C), z_iso (MD (F X)) (F (MC X))) (MFunit : ∏ (A : C), #F (unit_kt MC A) = unit_kt MD (F A) · MF A) (MFbind : ∏ (A B : C) (f : A --> MC B), #F (bind_kt MC f) = inv_from_z_iso (MF A) · bind_kt MD (#F f · inv_from_z_iso (MF B)) · MF B) : kleisli_triple_on_functor MC MD F := (MF,, MFunit,, MFbind). Section Projections. Context {C D : category} {MC : kleisli_triple C} {MD : kleisli_triple D} {F : C ⟶ D} (MF : kleisli_triple_on_functor MC MD F). Definition kleisli_triple_on_functor_z_iso : ∏ (X : C), z_iso (MD (F X)) (F (MC X)) := pr1 MF. Definition kleisli_triple_on_functor_unit_kt : ∏ (A : C), #F (unit_kt MC A) = unit_kt MD (F A) · kleisli_triple_on_functor_z_iso A := pr12 MF. Definition kleisli_triple_on_functor_bind_kt : ∏ (A B : C) (f : A --> MC B), #F (bind_kt MC f) = inv_from_z_iso (kleisli_triple_on_functor_z_iso A) · bind_kt MD (#F f · inv_from_z_iso (kleisli_triple_on_functor_z_iso B)) · kleisli_triple_on_functor_z_iso B := pr22 MF. End Projections. Definition kleisli_triple_on_identity_functor {C : category} (MC : kleisli_triple C) : kleisli_triple_on_functor MC MC (functor_identity C). Proof. use tpair. - exact (λ X, identity_z_iso _). - split ; cbn. + abstract (intro ; rewrite id_right ; apply idpath). + abstract (intros ; rewrite !id_right, id_left ; apply idpath). Defined. Definition inv_from_z_iso_z_iso_comp {C : category} {x y z : C} (f : z_iso x y) (g : z_iso y z) : inv_from_z_iso (z_iso_comp f g) = inv_from_z_iso g · inv_from_z_iso f. Proof. refine (!_). apply inv_z_iso_unique'. unfold precomp_with ; cbn. etrans. { rewrite <- !assoc. apply maponpaths. rewrite assoc. rewrite z_iso_inv_after_z_iso. apply id_left. } apply z_iso_inv_after_z_iso. Qed. Definition kleisli_triple_disp_cat_data : disp_cat_data bicat_of_univ_cats. Proof. use tpair. - use tpair ; cbn. + exact kleisli_triple. + exact @kleisli_triple_on_functor. - split ; cbn. + exact @kleisli_triple_on_identity_functor. + intros C₁ C₂ C₃ F₁ F₂ M₁ M₂ M₃ MF₁ MF₂. use tpair. * exact (λ X, z_iso_comp (pr1 MF₂ (F₁ X)) (functor_on_z_iso F₂ (pr1 MF₁ X))). * split. ** abstract (intros A ; cbn; rewrite (pr12 MF₁); rewrite functor_comp; rewrite (pr12 MF₂); rewrite assoc; apply idpath). ** abstract (intros A B f ; simpl; rewrite (pr22 MF₁); rewrite !functor_comp; rewrite (pr22 MF₂); rewrite !functor_comp; rewrite (inv_from_z_iso_z_iso_comp (pr1 MF₂ (F₁ A))); rewrite (inv_from_z_iso_z_iso_comp (pr1 MF₂ (F₁ B))); rewrite <- !functor_on_inv_from_z_iso; rewrite !assoc; apply idpath). Defined. Definition kleisli_triple_nat_trans {C₁ C₂ : univalent_category} {F₁ F₂ : C₁ ⟶ C₂} (n : F₁ ⟹ F₂) {MC₁ : kleisli_triple C₁} {MC₂ : kleisli_triple C₂} (MF₁ : kleisli_triple_on_functor MC₁ MC₂ F₁) (MF₂ : kleisli_triple_on_functor MC₁ MC₂ F₂) : UU := ∏ (X : C₁), pr1 MF₁ X · n (MC₁ X) = #(functor_data_of_kleisli_triple MC₂) (n X) · pr1 MF₂ X. Definition kleisli_triple_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats. Proof. use tpair. - exact kleisli_triple_disp_cat_data. - exact @kleisli_triple_nat_trans. Defined. Definition kleisli_triple_disp_prebicat_ops : disp_prebicat_ops kleisli_triple_disp_prebicat_1_id_comp_cells. Proof. repeat split. - intros ; intro ; cbn. rewrite ?id_left, ?id_right. rewrite bind_unit, id_left. apply idpath. - intros ; intro ; cbn. rewrite ?functor_id, ?id_left, ?id_right. rewrite bind_unit, id_left. apply idpath. - intros ; intro ; cbn. rewrite ?id_left, ?id_right. rewrite bind_unit, id_left. apply idpath. - intros ; intro ; cbn. rewrite ?functor_id, ?id_left, ?id_right. rewrite bind_unit, id_left. apply idpath. - intros ; intro ; cbn. rewrite ?id_left, ?id_right. rewrite bind_unit, id_left. apply idpath. - intros ; intro ; cbn. rewrite ?id_left, ?id_right. rewrite bind_unit, id_left. rewrite functor_comp. rewrite assoc. apply idpath. - intros ; intro ; cbn. rewrite ?id_left, ?id_right. rewrite bind_unit, id_left. rewrite functor_comp. rewrite assoc. apply idpath. - intros C₁ C₂ F₁ F₂ F₃ n₁ n₂ MC₁ MC₂ MF₁ MF₂ MF₃ MN₁ MN₂ X ; cbn in *. rewrite !assoc. rewrite MN₁. rewrite <- !assoc. unfold functor_data_of_kleisli_triple ; cbn. rewrite MN₂. rewrite !assoc. etrans. { apply maponpaths_2. apply (bind_bind MC₂). } apply maponpaths_2. apply maponpaths. rewrite <- !assoc. apply maponpaths. apply (unit_bind MC₂). - intros C₁ C₂ C₃ F G₁ G₂ n MC₁ MC₂ MC₃ MF MG₁ MG₂ Mn X ; cbn. rewrite <- !assoc. etrans. { apply maponpaths. apply (pr2 n _ _ (pr1 (pr1 MF X))). } rewrite !assoc. rewrite Mn. apply idpath. - intros C₁ C₂ C₃ F₁ F₂ G n MC₁ MC₂ MC₃ MF₁ MF₂ MG Mn X ; cbn. rewrite <- !assoc. rewrite <- functor_comp. rewrite Mn. rewrite functor_comp. rewrite !assoc. apply maponpaths_2. unfold functor_data_of_kleisli_triple ; cbn. rewrite (pr22 MG) ; cbn. rewrite !assoc. rewrite z_iso_inv_after_z_iso, id_left. apply maponpaths_2. rewrite functor_comp. rewrite (pr12 MG) ; cbn. rewrite <- !assoc. rewrite z_iso_inv_after_z_iso, id_right. apply idpath. Qed. Definition kleisli_triple_disp_prebicat_data: disp_prebicat_data bicat_of_univ_cats. Proof. use tpair. - exact kleisli_triple_disp_prebicat_1_id_comp_cells. - exact kleisli_triple_disp_prebicat_ops. Defined. Definition disp_2cellsisaprop {a b : bicat_of_univ_cats} {f g : a --> b} (η : f ==> g) {aa : kleisli_triple_disp_prebicat_data a} {bb : kleisli_triple_disp_prebicat_data b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) : isaprop (disp_2cells η ff gg). Proof. use impred. intro. apply homset_property. Qed. Definition kleisli_triple_disp_laws : disp_prebicat_laws kleisli_triple_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply disp_2cellsisaprop. Qed. Definition kleisli_triple_disp_prebicat : disp_prebicat bicat_of_univ_cats. Proof. use tpair. - exact kleisli_triple_disp_prebicat_data. - exact kleisli_triple_disp_laws. Defined. Definition kleisli_triple_disp_bicat : disp_bicat bicat_of_univ_cats. Proof. use tpair. - exact kleisli_triple_disp_prebicat. - cbn ; unfold has_disp_cellset ; intros. apply isasetaprop. apply disp_2cellsisaprop. Defined. Definition kleisli_triple_bicat : bicat := total_bicat kleisli_triple_disp_bicat. Definition disp_2cells_isaprop_kleisli : disp_2cells_isaprop kleisli_triple_disp_bicat. Proof. exact @disp_2cellsisaprop. Qed. Definition disp_locally_groupoid_kleisli_help (a b : univalent_category) (f g : bicat_of_univ_cats ⟦ a , b ⟧) (x : invertible_2cell f g) (aa : kleisli_triple a) (bb : kleisli_triple b) (ff : kleisli_triple_on_functor aa bb f) (gg : kleisli_triple_on_functor aa bb g) (xx : kleisli_triple_nat_trans (pr1 x) ff gg) (X : a) : pr1 (pr1 gg X) = (bind_kt bb (pr1 (x ^-1) X · unit_kt bb (pr1 f X))) · pr1 ff X · (pr11 x (pr1 aa X)). Proof. rewrite assoc'. rewrite xx. rewrite assoc. refine (!(_ @ _)). { apply maponpaths_2. apply bind_bind. } rewrite assoc'. etrans. { apply maponpaths_2. do 2 apply maponpaths. apply (unit_bind bb). } rewrite assoc. etrans. { apply maponpaths_2. apply maponpaths. apply maponpaths_2. pose (pr2 (invertible_2cell_to_nat_z_iso _ _ (inv_of_invertible_2cell x)) X) as q'. pose (z_iso_inv_after_z_iso (_ ,, q')) as p. cbn in p. apply p. } rewrite id_left. rewrite bind_unit. rewrite id_left. apply idpath. Qed. Definition disp_locally_groupoid_kleisli : disp_locally_groupoid kleisli_triple_disp_bicat. Proof. use make_disp_locally_groupoid. - intros a b f g x aa bb ff gg xx X. pose (pr2 (invertible_2cell_to_nat_z_iso _ _ (inv_of_invertible_2cell x)) (pr1 aa X)) as q. apply (z_iso_inv_to_right _ _ _ _ (_ ,, q)). apply disp_locally_groupoid_kleisli_help. exact xx. - exact disp_2cells_isaprop_kleisli. Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/LaxSlice.v000066400000000000000000000606531451125700300260030ustar00rootroot00000000000000(************************************************************************************* Lax and oplax slice bicategories In this file, we define lax and oplax slice bicategories. When adapting the definition of slice categories to bicategories, there are three options for the morphisms depending on how the triangle c₁ ----------> c₂ | | | | | | V V a ============ a commutes. If it commutes up to an invertible 2-cell, then we call it the slice bicategory (defined in Slice.v). If it commutes up to a (not necessarily invertible) 2-cell, then we call it the lax or oplax slice depending on how the particular 2-cell is oriented. Contents 1. Lax slice bicategories 2. Properties of the lax slice bicategory 3. Oplax slice bicategories 4. Properties of the oplax slice bicategory *************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Section LaxSlice. Variable (B : bicat) (a : B). (** 1. Lax slice bicategories *) Definition lax_slice_disp_cat_ob_mor : disp_cat_ob_mor B. Proof. use tpair. - exact (λ c, c --> a). - exact (λ c₁ c₂ t₁ t₂ s, t₁ ==> s · t₂). Defined. Definition lax_slice_disp_cat_id_comp : disp_cat_id_comp B lax_slice_disp_cat_ob_mor. Proof. use tpair. - exact (λ c t, linvunitor _). - exact (λ c₁ c₂ c₃ s₁ s₂ t₁ t₂ t₃ α β, α • (s₁ ◃ β) • lassociator _ _ _). Defined. Definition lax_slice_disp_cat_data : disp_cat_data B. Proof. use tpair. - exact lax_slice_disp_cat_ob_mor. - exact lax_slice_disp_cat_id_comp. Defined. Definition lax_slice_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. use tpair. - exact lax_slice_disp_cat_data. - exact (λ c₁ c₂ s₁ s₂ α t₁ t₂ ss₁ ss₂, ss₁ • (α ▹ t₂) = ss₂). Defined. Definition lax_slice_disp_prebicat_ops : disp_prebicat_ops lax_slice_disp_prebicat_1_id_comp_cells. Proof. repeat split ; cbn. - intros. rewrite id2_rwhisker. rewrite id2_right. apply idpath. - intros. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ;cbn. rewrite <- vcomp_lunitor. rewrite <- lunitor_triangle. apply idpath. - intros. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply idpath. - intros. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite <- vcomp_lunitor. rewrite !vassocl. rewrite <- lunitor_triangle. apply idpath. - intros. rewrite !vassocl. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. rewrite id2_right. apply idpath. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. apply id2_right. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply lassociator_lassociator. - intros ? ? ? ? ? ? ? ? ? ? ? ? α β. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite α. rewrite β. apply idpath. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. rewrite α. apply idpath. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α. rewrite !vassocl. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. rewrite α. apply idpath. Qed. Definition lax_slice_disp_prebicat_data : disp_prebicat_data B. Proof. use tpair. - exact lax_slice_disp_prebicat_1_id_comp_cells. - exact lax_slice_disp_prebicat_ops. Defined. Definition lax_slice_disp_prebicat_laws : disp_prebicat_laws lax_slice_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply B. Qed. Definition lax_slice_disp_prebicat : disp_prebicat B. Proof. use tpair. - exact lax_slice_disp_prebicat_data. - exact lax_slice_disp_prebicat_laws. Defined. Definition lax_slice_disp_bicat : disp_bicat B. Proof. use tpair. - exact lax_slice_disp_prebicat. - intro ; intros. apply isasetaprop. apply B. Defined. (** 2. Properties of the lax slice bicategory *) Definition lax_slice_disp_2cells_isaprop : disp_2cells_isaprop lax_slice_disp_bicat. Proof. intro ; intros. apply B. Qed. Definition lax_slice_disp_locally_sym : disp_locally_sym lax_slice_disp_bicat. Proof. intros c₁ c₂ s₁ s₂ α t₁ t₂ φ₁ φ₂ p ; cbn in *. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. exact (!p). Qed. Definition lax_slice_disp_locally_groupoid : disp_locally_groupoid lax_slice_disp_bicat. Proof. use make_disp_locally_groupoid. - exact lax_slice_disp_locally_sym. - exact lax_slice_disp_2cells_isaprop. Defined. Definition lax_slice_disp_univalent_2_1 : disp_univalent_2_1 lax_slice_disp_bicat. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros c₁ c₂ s t₁ t₂ φ₁ φ₂. use isweqimplimpl. - intros α. pose (pr1 α) as p ; cbn in p. rewrite id2_rwhisker in p. rewrite id2_right in p. exact p. - apply B. - use isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply B. Qed. Definition lax_slice_invertible_2cell_is_left_disp_adj_equiv {c : B} {t₁ t₂ : lax_slice_disp_bicat c} (f : t₁ -->[ id₁ _ ] t₂) (Hf : is_invertible_2cell f) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) f. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (linvunitor _ • Hf^-1 • linvunitor _). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite !lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- !lwhisker_hcomp, <- rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite !vassocr ; apply maponpaths_2 ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite rwhisker_hcomp ; rewrite <- triangle_l_inv ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; rewrite lassociator_rassociator ; apply id2_right). - abstract (cbn ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; do 2 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn ; rewrite id2_right ; rewrite <- vcomp_lunitor ; rewrite lunitor_triangle ; apply idpath). - apply lax_slice_disp_2cells_isaprop. - apply lax_slice_disp_2cells_isaprop. - apply lax_slice_disp_locally_groupoid. - apply lax_slice_disp_locally_groupoid. Defined. Definition lax_slice_invertible_2cell_to_disp_adj_equiv {c : B} {t₁ t₂ : lax_slice_disp_bicat c} : invertible_2cell t₁ t₂ → disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂. Proof. intros α. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))). - exact (α • linvunitor _). - exact (α^-1 • linvunitor _). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- rwhisker_hcomp ; apply maponpaths ; apply lunitor_V_id_is_left_unit_V_id). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- rwhisker_hcomp ; rewrite rwhisker_vcomp ; rewrite lunitor_runitor_identity ; rewrite rinvunitor_runitor ; apply id2_rwhisker). - apply lax_slice_disp_2cells_isaprop. - apply lax_slice_disp_2cells_isaprop. - apply lax_slice_disp_locally_groupoid. - apply lax_slice_disp_locally_groupoid. Defined. Definition lax_slice_disp_adj_equiv_to_invertible_2cell {c : B} {t₁ t₂ : lax_slice_disp_bicat c} : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂ → invertible_2cell t₁ t₂. Proof. intros e. use make_invertible_2cell. - exact (pr1 e • lunitor _). - use make_is_invertible_2cell. + exact (pr112 e • lunitor _). + abstract (pose (pr1 (pr212 e)) as m ; cbn in m ; rewrite !vassocl in m ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; rewrite !vassocl ; rewrite <- vcomp_lunitor ; rewrite <- lunitor_triangle ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; exact (!m)). + abstract (pose (pr2 (pr212 e)) as m ; cbn in m ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; rewrite !vassocl ; rewrite <- vcomp_lunitor ; rewrite <- lunitor_triangle ; rewrite !vassocr ; exact m). Defined. Definition lax_slice_invertible_2cell_weq_disp_adj_equiv (HB_2_1 : is_univalent_2_1 B) {c : B} (t₁ t₂ : lax_slice_disp_bicat c) : invertible_2cell t₁ t₂ ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂. Proof. use make_weq. - exact lax_slice_invertible_2cell_to_disp_adj_equiv. - use isweq_iso. + exact lax_slice_disp_adj_equiv_to_invertible_2cell. + abstract (intros α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite vassocl ; rewrite linvunitor_lunitor ; apply id2_right). + abstract (intros α ; use subtypePath ; [ intro ; use isaprop_disp_left_adjoint_equivalence ; [ exact HB_2_1 | apply lax_slice_disp_univalent_2_1 ] | ] ; cbn ; rewrite vassocl ; rewrite lunitor_linvunitor ; apply id2_right). Defined. Definition lax_slice_disp_univalent_2_0 (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2_0 lax_slice_disp_bicat. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros c t₁ t₂. use weqhomot. - exact (lax_slice_invertible_2cell_weq_disp_adj_equiv HB_2_1 t₁ t₂ ∘ make_weq _ (HB_2_1 _ _ _ _))%weq. - abstract (intros p ; cbn in p ; induction p ; use subtypePath ; [ intro ; use isaprop_disp_left_adjoint_equivalence ; [ exact HB_2_1 | apply lax_slice_disp_univalent_2_1 ] | ] ; apply id2_left). Qed. End LaxSlice. Section OplaxSlice. Variable (B : bicat) (a : B). (** 3. Oplax slice bicategories *) Definition oplax_slice_disp_cat_ob_mor : disp_cat_ob_mor B. Proof. use tpair. - exact (λ c, c --> a). - exact (λ c₁ c₂ t₁ t₂ s, s · t₂ ==> t₁). Defined. Definition oplax_slice_disp_cat_id_comp : disp_cat_id_comp B oplax_slice_disp_cat_ob_mor. Proof. use tpair. - exact (λ c t, lunitor _). - exact (λ c₁ c₂ c₃ s₁ s₂ t₁ t₂ t₃ α β, rassociator _ _ _ • (s₁ ◃ β) • α). Defined. Definition oplax_slice_disp_cat_data : disp_cat_data B. Proof. use tpair. - exact oplax_slice_disp_cat_ob_mor. - exact oplax_slice_disp_cat_id_comp. Defined. Definition oplax_slice_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. use tpair. - exact oplax_slice_disp_cat_data. - exact (λ c₁ c₂ s₁ s₂ α t₁ t₂ ss₁ ss₂, (α ▹ t₂) • ss₂ = ss₁). Defined. Definition oplax_slice_disp_prebicat_ops : disp_prebicat_ops oplax_slice_disp_prebicat_1_id_comp_cells. Proof. repeat split ; cbn. - intros. rewrite id2_rwhisker. rewrite id2_left. apply idpath. - intros. rewrite !vassocl. rewrite vcomp_lunitor. rewrite !vassocr. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - intros. rewrite !vassocl. rewrite <- runitor_rwhisker. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - intros. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite vcomp_lunitor. rewrite !vassocr. apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - intros. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. apply maponpaths_2. rewrite lunitor_lwhisker. apply idpath. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_lwhisker_rassociator. apply idpath. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_lwhisker_rassociator. apply idpath. - intros ? ? ? ? ? ? ? ? ? ? ? ? α β. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite β. rewrite α. apply idpath. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α. rewrite !vassocr. apply maponpaths_2. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_vcomp. apply maponpaths. exact α. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? α. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. exact α. Qed. Definition oplax_slice_disp_prebicat_data : disp_prebicat_data B. Proof. use tpair. - exact oplax_slice_disp_prebicat_1_id_comp_cells. - exact oplax_slice_disp_prebicat_ops. Defined. Definition oplax_slice_disp_prebicat_laws : disp_prebicat_laws oplax_slice_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply B. Qed. Definition oplax_slice_disp_prebicat : disp_prebicat B. Proof. use tpair. - exact oplax_slice_disp_prebicat_data. - exact oplax_slice_disp_prebicat_laws. Defined. Definition oplax_slice_disp_bicat : disp_bicat B. Proof. use tpair. - exact oplax_slice_disp_prebicat. - intro ; intros. apply isasetaprop. apply B. Defined. (** 4. Properties of the oplax slice bicategory *) Definition oplax_slice_disp_2cells_isaprop : disp_2cells_isaprop oplax_slice_disp_bicat. Proof. intro ; intros. apply B. Qed. Definition oplax_slice_disp_locally_sym : disp_locally_sym oplax_slice_disp_bicat. Proof. intros c₁ c₂ s₁ s₂ α t₁ t₂ φ₁ φ₂ p ; cbn in *. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. exact (!p). Qed. Definition oplax_slice_disp_locally_groupoid : disp_locally_groupoid oplax_slice_disp_bicat. Proof. use make_disp_locally_groupoid. - exact oplax_slice_disp_locally_sym. - exact oplax_slice_disp_2cells_isaprop. Defined. Definition oplax_slice_disp_univalent_2_1 : disp_univalent_2_1 oplax_slice_disp_bicat. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros c₁ c₂ s t₁ t₂ φ₁ φ₂. use isweqimplimpl. - intros α. pose (pr1 α) as p ; cbn in p. rewrite id2_rwhisker in p. rewrite id2_left in p. exact (!p). - apply B. - use isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply B. Qed. Definition oplax_slice_invertible_2cell_is_left_disp_adj_equiv {c : B} {t₁ t₂ : oplax_slice_disp_bicat c} (f : t₁ -->[ id₁ _ ] t₂) (Hf : is_invertible_2cell f) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) f. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact (lunitor _ • Hf^-1 • lunitor _). - abstract (cbn ; rewrite !vassocr ; rewrite <- linvunitor_assoc ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lunitor_linvunitor ; rewrite id2_left ; apply vcomp_linv). - abstract (cbn ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_lunitor ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; rewrite <- lunitor_triangle ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; apply idpath). - apply oplax_slice_disp_2cells_isaprop. - apply oplax_slice_disp_2cells_isaprop. - apply oplax_slice_disp_locally_groupoid. - apply oplax_slice_disp_locally_groupoid. Defined. Definition oplax_slice_invertible_2cell_to_disp_adj_equiv {c : B} {t₁ t₂ : oplax_slice_disp_bicat c} : invertible_2cell t₁ t₂ → disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂. Proof. intros α. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))). - exact (lunitor _ • α^-1). - exact (lunitor _ • α). - abstract (cbn ; rewrite !vassocr ; rewrite <- linvunitor_assoc ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite linvunitor_lunitor ; rewrite id2_left ; apply vcomp_rinv). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite lunitor_lwhisker ; rewrite runitor_lunitor_identity ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_lunitor ; rewrite !vassocl ; rewrite vcomp_linv ; rewrite id2_right ; apply idpath). - apply oplax_slice_disp_2cells_isaprop. - apply oplax_slice_disp_2cells_isaprop. - apply oplax_slice_disp_locally_groupoid. - apply oplax_slice_disp_locally_groupoid. Defined. Definition oplax_slice_disp_adj_equiv_to_invertible_2cell {c : B} {t₁ t₂ : oplax_slice_disp_bicat c} : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂ → invertible_2cell t₁ t₂. Proof. intros e. use make_invertible_2cell. - exact (linvunitor _ • pr112 e). - use make_is_invertible_2cell. + exact (linvunitor _ • pr1 e). + abstract (rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; refine (_ @ pr1 (pr212 e)) ; cbn ; rewrite !vassocr ; apply maponpaths_2 ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; apply maponpaths_2 ; rewrite linvunitor_assoc ; apply idpath). + abstract (rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite !vassocr ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite linvunitor_assoc ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; exact (!(pr2 (pr212 e)))). Defined. Definition oplax_slice_invertible_2cell_weq_disp_adj_equiv (HB_2_1 : is_univalent_2_1 B) {c : B} (t₁ t₂ : oplax_slice_disp_bicat c) : invertible_2cell t₁ t₂ ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) t₁ t₂. Proof. use make_weq. - exact oplax_slice_invertible_2cell_to_disp_adj_equiv. - use isweq_iso. + exact oplax_slice_disp_adj_equiv_to_invertible_2cell. + abstract (intros α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocr ; rewrite linvunitor_lunitor ; apply id2_left). + abstract (intros α ; use subtypePath ; [ intro ; use isaprop_disp_left_adjoint_equivalence ; [ exact HB_2_1 | apply oplax_slice_disp_univalent_2_1 ] | ] ; cbn ; rewrite vassocr ; rewrite lunitor_linvunitor ; apply id2_left). Defined. Definition oplax_slice_disp_univalent_2_0 (HB_2_1 : is_univalent_2_1 B) : disp_univalent_2_0 oplax_slice_disp_bicat. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros c t₁ t₂. use weqhomot. - exact (oplax_slice_invertible_2cell_weq_disp_adj_equiv HB_2_1 t₁ t₂ ∘ make_weq _ (HB_2_1 _ _ _ _))%weq. - abstract (intros p ; cbn in p ; induction p ; use subtypePath ; [ intro ; use isaprop_disp_left_adjoint_equivalence ; [ exact HB_2_1 | apply oplax_slice_disp_univalent_2_1 ] | ] ; apply id2_right). Qed. End OplaxSlice. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/MonadKtripleBiequiv.v000066400000000000000000000656371451125700300302240ustar00rootroot00000000000000(* ========================================================================= *) (** * Biequivalence between Monads and Ktriples *) (* ========================================================================= *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.AlgebraMap. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Monads. Require Import UniMath.Bicategories.DisplayedBicats.Examples.KleisliTriple. Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Require Import UniMath.Bicategories.DisplayedBicats.DispBiequivalence. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.DisplayedBicats.Examples.KleisliTriple. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Local Open Scope cat. Local Open Scope bicategory_scope. (* ------------------------------------------------------------------------- *) (** ** Miscellanea *) (* ------------------------------------------------------------------------- *) Definition isaprop_eq_2cell {B : bicat} {a b : B} {f g : a --> b} (x y : f ==> g) : isaprop (x = y). Proof. apply B. Defined. (* ------------------------------------------------------------------------- *) (** ** Basic monadic constructions built from a Ktriple. *) (* ------------------------------------------------------------------------- *) Section Monad_of_Kleisli_Data. Context {x : category} (k : kleisli_triple x). Local Lemma unit_kleisli_natural : is_nat_trans (functor_identity_data x) (functor_data_of_kleisli_triple k) (unit_kt k). Proof. intros a b f. cbn. refine (!_). apply (unit_bind k). Qed. Definition unit_kleisli : functor_identity x ⟹ functor_of_kleisli_triple k := make_nat_trans (functor_identity x) (functor_of_kleisli_triple k) (unit_kt k) unit_kleisli_natural. Local Lemma mu_kleisli_natural : is_nat_trans (functor_composite_data (functor_of_kleisli_triple k) (functor_of_kleisli_triple k)) (functor_of_kleisli_triple k) (λ a, bind_kt k (identity (k a))). Proof. intros a b f. cbn. do 2 rewrite (bind_bind k). apply maponpaths. rewrite assoc'. rewrite (unit_bind k). rewrite id_left. apply id_right. Qed. Definition mu_kleisli : functor_of_kleisli_triple k ∙ functor_of_kleisli_triple k ⟹ functor_of_kleisli_triple k := make_nat_trans (functor_of_kleisli_triple k ∙ functor_of_kleisli_triple k) (functor_of_kleisli_triple k) _ mu_kleisli_natural. End Monad_of_Kleisli_Data. Section Monad_of_Kleisli_Data. Context {x : univalent_category} (k : kleisli_triple x). Definition unit_mu_kleisli : monad bicat_of_univ_cats x. Proof. use make_cat_monad. - exact (functor_of_kleisli_triple k). - exact (unit_kleisli k). - exact (mu_kleisli k). - abstract (cbn; intros; rewrite (bind_bind k); rewrite assoc'; rewrite (unit_bind k); rewrite id_right; apply (bind_unit k)). - abstract (cbn; intros; apply (unit_bind k)). - abstract (cbn; intros; do 2 rewrite (bind_bind k); rewrite id_left; apply maponpaths; rewrite assoc'; rewrite (unit_bind k); rewrite id_right; apply idpath). Defined. End Monad_of_Kleisli_Data. (* ------------------------------------------------------------------------- *) (** ** Pseudofunctor Ktriples to Monads. *) (* ------------------------------------------------------------------------- *) Definition functor_of_kleisli_comm {x y : univalent_category} {f : x ⟶ y} {kx : kleisli_triple x} {ky : kleisli_triple y} (kf : kleisli_triple_on_functor kx ky f) : (functor_of_kleisli_triple kx ∙ f) ⟹ (f ∙ functor_of_kleisli_triple ky). Proof. use make_nat_trans. - exact (λ a, inv_from_z_iso (pr1 kf a)). - abstract (intros a b p; cbn; pose (pr22 kf) as H; cbn in H; rewrite H; rewrite !assoc'; apply maponpaths; rewrite z_iso_inv_after_z_iso; rewrite id_right; apply maponpaths; rewrite functor_comp; rewrite !assoc'; apply maponpaths; rewrite (pr12 kf); rewrite assoc'; rewrite z_iso_inv_after_z_iso; apply id_right). Defined. Lemma functor_of_kleisli_comm_nat_z_iso {x y : univalent_category} {f : x ⟶ y} {kx : kleisli_triple x} {ky : kleisli_triple y} (kf : kleisli_triple_on_functor kx ky f) : is_nat_z_iso (functor_of_kleisli_comm kf). Proof. intro a. apply is_z_iso_inv_from_z_iso. Defined. Definition functor_of_kleisli_z_iso {x y : univalent_category} {f : x ⟶ y} {kx : kleisli_triple x} {ky : kleisli_triple y} (kf : kleisli_triple_on_functor kx ky f) : nat_z_iso (functor_of_kleisli_triple kx ∙ f) (f ∙ functor_of_kleisli_triple ky). Proof. use make_nat_z_iso. - exact (functor_of_kleisli_comm kf). - exact (functor_of_kleisli_comm_nat_z_iso kf). Defined. Definition unit_mu_kleisli_functor {C D : univalent_category} {F : C ⟶ D} {KC : kleisli_triple_disp_bicat C} {KD : kleisli_triple_disp_bicat D} (KF : KC -->[F] KD) : unit_mu_kleisli KC -->[ F] unit_mu_kleisli KD. Proof. use make_cat_monad_mor ; cbn. - exact (functor_of_kleisli_z_iso KF). - abstract (intros X ; cbn ; rewrite (kleisli_triple_on_functor_unit_kt KF); rewrite assoc'; rewrite z_iso_inv_after_z_iso; rewrite id_right; apply idpath). - abstract (intros X ; cbn ; rewrite (kleisli_triple_on_functor_bind_kt KF); rewrite !assoc'; apply maponpaths; rewrite (bind_bind KD); rewrite !assoc'; rewrite (unit_bind KD), id_right; rewrite z_iso_inv_after_z_iso, id_right; rewrite functor_id, id_left; apply idpath). Defined. Definition Ktriple_to_Monad : disp_psfunctor kleisli_triple_disp_bicat (monad bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats). Proof. use make_disp_psfunctor. - apply disp_2cells_isaprop_monad. apply univalent_cat_is_univalent_2. - exact (disp_locally_groupoid_monad bicat_of_univ_cats univalent_cat_is_univalent_2). - exact @unit_mu_kleisli. - exact @unit_mu_kleisli_functor. - abstract (cbn; intros x y f g α kx ky kf kg e; refine ((_,, (tt,, tt)),, tt); use nat_trans_eq; try apply homset_property; cbn; intro a; apply pathsinv0; apply z_iso_inv_on_left; rewrite assoc'; rewrite <- e; rewrite assoc; rewrite z_iso_after_z_iso_inv; apply pathsinv0; apply id_left). - abstract (intros x kx; refine ((_,, (tt,, tt)),, tt); unfold alg_disp_cat_2cell; use nat_trans_eq; try apply homset_property; intro a; cbn; rewrite !id_left; rewrite (bind_bind kx); rewrite (unit_bind kx); apply pathsinv0; apply (bind_unit kx)). - abstract (simpl; intros x y z f g kx ky kz kf kg; refine ((_,, (tt,, tt)),, tt); use nat_trans_eq; try apply homset_property; intro a; cbn; rewrite !id_left; rewrite !id_right; rewrite assoc'; rewrite (bind_bind kz); rewrite (unit_bind kz); rewrite (bind_unit kz); rewrite id_right; apply idpath). Defined. (* ------------------------------------------------------------------------- *) (* Kleisli_of_Monad *) (* ------------------------------------------------------------------------- *) Definition Monad_to_Ktriple_data {x : univalent_category} (m : monad bicat_of_univ_cats x) : kleisli_triple_disp_bicat (id_psfunctor bicat_of_univ_cats x). Proof. use make_kleisli_triple. - apply m. - exact (pr1 (monad_unit m)). - exact (λ _ _ F, monad_bind m F). - intros A. apply (cat_monad_unit_bind m). - simpl. intros. apply (cat_monad_bind_unit m). - simpl. intros. apply (cat_monad_bind_bind m). Defined. (* NB: We need to take the inverse to match the definition used to build the biequivalence. *) Definition monad_mor_natural_pointwise {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) (X : C₁) : z_iso ((monad_endo M₂ : C₂ ⟶ C₂) (F X)) (F ((monad_endo M₁ : C₁ ⟶ C₁) X)) := CompositesAndInverses.nat_z_iso_to_pointwise_z_iso (nat_z_iso_inv (monad_mor_nat_z_iso FF)) X. Lemma inv_monad_mor_natural_pointwise {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) (X : C₁) : inv_from_z_iso (monad_mor_natural_pointwise FF X) = CompositesAndInverses.nat_z_iso_to_pointwise_z_iso (monad_mor_nat_z_iso FF) X. Proof. refine (!_). apply inv_z_iso_unique'. unfold precomp_with. cbn. apply (nat_trans_eq_pointwise (vcomp_linv (monad_mor_natural FF)) X). Qed. Definition Monad_to_Ktriple_functor {x y : univalent_category} {f : bicat_of_univ_cats ⟦ x, y ⟧} {mx : (monad bicat_of_univ_cats) x} {my : (monad bicat_of_univ_cats) y} (mf : mx -->[ f] my) : Monad_to_Ktriple_data mx -->[ f ] Monad_to_Ktriple_data my. Proof. use make_kleisli_triple_on_functor. - exact (monad_mor_natural_pointwise mf). - abstract ( refine (λ (X : x), _); simpl; pose (nat_trans_eq_pointwise (monad_mor_unit mf) X) as mf_unit; cbn in mf_unit; do 2 rewrite id_left in mf_unit; etrans; [ apply pathsinv0 | apply maponpaths_2; exact mf_unit ]; etrans; [ rewrite assoc' | apply id_right ]; apply maponpaths; exact (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (monad_mor_natural mf)) X)) ). - abstract ( refine (λ (X Y : x) (p : x ⟦ X, pr1 (Monad_to_Ktriple_data mx) Y ⟧), _); unfold Monad_to_Ktriple_data, bind_kt; simpl; etrans; [ apply (monad_mor_bind_alt mf) | idtac ]; do 2 rewrite (inv_monad_mor_natural_pointwise mf); do 2 rewrite assoc'; apply idpath ). Defined. (** the extra identities in the statement are no longer of use for [Monad_to_Ktriple] *) Definition Monad_to_Ktriple_2cell : ∏ (x y : univalent_category) (f g : x ⟶ y) (α : prebicat_cells bicat_of_univ_cats f g) (mx : (monad bicat_of_univ_cats) x) (my : (monad bicat_of_univ_cats) y) (mf : mx -->[ f] my) (mg : mx -->[ g] my), mf ==>[ α] mg → ∏ X, pr1 ((pr2 (monad_mor_natural mf)) ^-1) X · id₁ (f (pr1 (monad_endo mx) X)) · pr1 α ((pr111 (pr1 mx)) X) = monad_bind my (pr1 α X · pr1 (monad_unit my) (g X)) · (pr1 ((pr2 (monad_mor_natural mg)) ^-1) X · id₁ (g (pr1 (monad_endo mx) X))). Proof. intros x y f g α mx my mf mg mα. refine (λ X: (x:univalent_category), _). rewrite !id_right. pose (nat_trans_eq_pointwise (pr11 mα) X) as d. pose (maponpaths (λ z, z · pr1 ((pr2 (monad_mor_natural mg)) ^-1) X) d) as p₁. cbn in p₁. rewrite assoc' in p₁. pose (maponpaths (λ z, pr1 α (pr1 (pr11 mx) X) · z) (!(nat_trans_eq_pointwise (vcomp_rinv (monad_mor_natural mg)) X))) as p₂. pose (!(id_right _) @ p₂ @ p₁) as r. refine (maponpaths (λ z, _ · z) r @ _). clear d p₁ p₂ r. rewrite !assoc. apply maponpaths_2. pose (maponpaths (λ z, z · # (pr111 my) (pr1 α X)) (!(nat_trans_eq_pointwise (vcomp_linv (monad_mor_natural mf)) X))) as p. pose (!(id_left _) @ p) as r. refine (!r @ _). clear p r. apply cat_monad_map_as_bind. Qed. Definition Monad_to_Ktriple_identitor : ∏ (x : bicat_of_univ_cats) (xx : (monad bicat_of_univ_cats) x), (id_disp (Monad_to_Ktriple_data xx)) ==>[ psfunctor_id (id_psfunctor bicat_of_univ_cats) x] Monad_to_Ktriple_functor (id_disp xx). Proof. intros x mx X; cbn. do 2 rewrite id_left ; do 2 rewrite id_right. rewrite (functor_id (pr11 mx)), id_right. refine (!_). apply (cat_monad_unit_bind mx). Qed. Definition Monad_to_Ktriple_compositor : ∏ (x y z : univalent_category) (f : x ⟶ y) (g : y ⟶ z) (xx : (monad bicat_of_univ_cats) x) (yy : (monad bicat_of_univ_cats) y) (zz : (monad bicat_of_univ_cats) z) (ff : xx -->[ f] yy) (gg : yy -->[ g] zz), (Monad_to_Ktriple_functor ff;; Monad_to_Ktriple_functor gg) ==>[ id₂ _] Monad_to_Ktriple_functor (ff;; gg). Proof. intros x y z f g mx my mz mf mg. refine (λ X : pr1 x, _). cbn. etrans. { apply id_right. } refine (!_). etrans. { etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id_left. } exact (cat_monad_unit_bind mz). } refine (id_left _ @ _). apply maponpaths. refine (id_left _ @ _). apply maponpaths. refine (id_left _ @ _). apply id_right. } etrans. { etrans. { apply maponpaths_2. exact (functor_id (pr11 mz) (g(f X))). } apply id_left. } apply idpath. Qed. (* 32 seconds on my computer *) Definition Monad_to_Ktriple : disp_psfunctor (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (id_psfunctor bicat_of_univ_cats). Proof. use make_disp_psfunctor. - exact disp_2cells_isaprop_kleisli. - exact disp_locally_groupoid_kleisli. - exact @Monad_to_Ktriple_data. - exact @Monad_to_Ktriple_functor. - intros x y f g α mx my mf mg mα X. assert (Hyp := Monad_to_Ktriple_2cell x y f g α mx my mf mg mα X). cbn. do 2 rewrite id_right in Hyp. assumption. - exact Monad_to_Ktriple_identitor. - exact Monad_to_Ktriple_compositor. Defined. Lemma bind_kt_monad_to_kleisli {x : univalent_category} (k : kleisli_triple x) {a b : x} (f : x ⟦ a, k b ⟧) : bind_kt (Monad_to_Ktriple_data (unit_mu_kleisli k)) f = bind_kt k f. Proof. unfold bind_kt at 1; simpl. unfold monad_bind; simpl. rewrite (bind_bind k). apply maponpaths. etrans; [ idtac | apply id_right ]. rewrite assoc'. apply maponpaths. apply (unit_bind k). Qed. Definition Monad_biequiv_Ktriple_unit : disp_pstrans (disp_pseudo_comp (id_psfunctor bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (monad bicat_of_univ_cats) Monad_to_Ktriple Ktriple_to_Monad) (disp_pseudo_id (monad bicat_of_univ_cats)) (lunitor_pstrans (id_psfunctor bicat_of_univ_cats)). Proof. use make_disp_pstrans. - exact (disp_2cells_isaprop_monad bicat_of_univ_cats univalent_cat_is_univalent_2). - exact (disp_locally_groupoid_monad bicat_of_univ_cats univalent_cat_is_univalent_2). - intros. use make_cat_monad_mor. + simpl. cbn. use make_nat_z_iso. * use make_nat_trans. ** intro z. apply identity. ** abstract (intros z t f ; cbn; rewrite id_left, id_right; unfold monad_bind; rewrite (functor_comp (monad_endo xx : _ ⟶ _)); rewrite assoc'; etrans; [ apply maponpaths; apply (cat_monad_ημ xx) | apply id_right ]). * intros z. apply identity_is_z_iso. + intros z. apply id_right. + abstract ( simpl; intros X; rewrite id_left; apply id_right). - abstract ( intros; use make_cat_monad_cell; simpl; intros X; rewrite !(functor_id ((monad_endo yy) : _ ⟶ _)); rewrite (functor_id f); rewrite !id_left; rewrite !(functor_id ((monad_endo yy) : _ ⟶ _)); rewrite !id_right; apply pathsinv0; apply inv_z_iso_unique'; unfold precomp_with; simpl; exact (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (monad_mor_natural ff)) X)) ). Defined. Definition Monad_bequiv_Ktriple_counit : disp_pstrans (disp_pseudo_comp (id_psfunctor bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) kleisli_triple_disp_bicat (monad bicat_of_univ_cats) kleisli_triple_disp_bicat Ktriple_to_Monad Monad_to_Ktriple) (disp_pseudo_id kleisli_triple_disp_bicat) (lunitor_pstrans (id_psfunctor bicat_of_univ_cats)). Proof. use make_disp_pstrans. - exact disp_2cells_isaprop_kleisli. - exact disp_locally_groupoid_kleisli. - refine (λ (x : univalent_category) (kx : kleisli_triple x), _). use make_kleisli_triple_on_functor. + exact (λ X, identity_z_iso (kx X)). + abstract ( refine (λ A : x, _); apply pathsinv0; apply id_right). + abstract ( refine (λ (A B : pr1 x) (f : pr1 x ⟦ A, pr1 kx B ⟧), _); simpl; rewrite id_right; etrans; [ apply bind_kt_monad_to_kleisli | idtac ]; etrans; [ pose (kleisli_triple_on_functor_bind_kt (kleisli_triple_on_identity_functor kx) _ _ f ) as H; simpl in H; exact H | idtac ]; apply id_right ). - abstract ( refine (λ (x y : univalent_category) (f : pr1 x ⟶ pr1 y) (kx : kleisli_triple x) (ky : kleisli_triple y) (kf : kleisli_triple_on_functor kx ky f) (X : x), _); simpl; apply pathsinv0; etrans; [ apply maponpaths_2; do 2 rewrite id_left; apply (bind_unit ky) | idtac ]; etrans; [ apply id_left | idtac]; etrans; [ apply id_left | idtac]; apply pathsinv0; simpl; etrans; [ rewrite assoc'; apply maponpaths; rewrite functor_id; etrans; [ apply id_left | idtac]; apply id_left | idtac ]; etrans; [ apply id_right | idtac]; apply idpath ). Defined. Definition Monad_biequiv_Ktriple_unit_counit : is_disp_biequivalence_unit_counit (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (id_is_biequivalence _) Monad_to_Ktriple Ktriple_to_Monad. Proof. split. - exact Monad_biequiv_Ktriple_unit. - exact Monad_bequiv_Ktriple_counit. Defined. Definition Monad_biequiv_Ktriple_unit_inv : disp_pstrans (disp_pseudo_id (monad bicat_of_univ_cats)) (disp_pseudo_comp (id_psfunctor bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (monad bicat_of_univ_cats) Monad_to_Ktriple Ktriple_to_Monad) (linvunitor_pstrans (id_psfunctor bicat_of_univ_cats)). Proof. use make_disp_pstrans. - exact (disp_2cells_isaprop_monad bicat_of_univ_cats univalent_cat_is_univalent_2). - exact (disp_locally_groupoid_monad bicat_of_univ_cats univalent_cat_is_univalent_2). - intros. use make_cat_monad_mor. + simpl. cbn. use make_nat_z_iso. * use make_nat_trans. ** intro z. apply identity. ** abstract (intros z t f ; cbn ; rewrite id_left, id_right ; apply cat_monad_map_as_bind). * intros z. apply identity_is_z_iso. + intros z. apply id_right. + abstract (simpl ; intros X ; rewrite !id_left, id_right ; rewrite bind_unit ; rewrite id_left ; cbn ; unfold monad_bind ; rewrite functor_id ; rewrite id_left ; apply idpath). - abstract (intros ; use make_cat_monad_cell ; simpl ; intro z ; rewrite !id_left ; rewrite !id_right ; rewrite (functor_id f) ; rewrite id_left ; cbn ; rewrite <- assoc ; apply maponpaths ; refine (!_) ; refine (maponpaths (λ q, _ · q) (cat_monad_unit_bind _) @ _) ; apply id_right). Defined. Definition Monad_biequiv_Ktriple_counit_inv : disp_pstrans (disp_pseudo_id kleisli_triple_disp_bicat) (disp_pseudo_comp (id_psfunctor bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) kleisli_triple_disp_bicat (monad bicat_of_univ_cats) kleisli_triple_disp_bicat Ktriple_to_Monad Monad_to_Ktriple) (linvunitor_pstrans (id_psfunctor bicat_of_univ_cats)). Proof. use make_disp_pstrans. - exact disp_2cells_isaprop_kleisli. - exact disp_locally_groupoid_kleisli. - refine (λ (x : univalent_category) (kx : kleisli_triple x), _). use make_kleisli_triple_on_functor. + exact (λ X, identity_z_iso (kx X)). + abstract ( refine (λ A : x, _); apply pathsinv0; apply id_right). + abstract (intros A B f ; simpl ; rewrite id_left, id_right ; refine (!_) ; etrans ; [ apply bind_kt_monad_to_kleisli | ] ; apply maponpaths ; apply id_right). - abstract ( intros x y f kx ky kf z ; simpl ; cbn; rewrite !id_left, !id_right; rewrite functor_id, id_right; etrans; [| apply cancel_postcomposition, pathsinv0, (cat_monad_unit_bind (unit_mu_kleisli ky))]; apply pathsinv0, id_left ). Defined. Definition Monad_disp_biequiv_Ktriple : disp_is_biequivalence_data (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (id_is_biequivalence _) Monad_biequiv_Ktriple_unit_counit. Proof. simple refine (_ ,, _ ,, ((_ ,, _) ,, (_ ,, _))). - exact Monad_biequiv_Ktriple_unit_inv. - exact Monad_biequiv_Ktriple_counit_inv. - use make_disp_invmodification. + exact (disp_2cells_isaprop_monad bicat_of_univ_cats univalent_cat_is_univalent_2). + exact (disp_locally_groupoid_monad bicat_of_univ_cats univalent_cat_is_univalent_2). + abstract (intros x xx ; use make_cat_monad_cell ; intros z ; simpl ; rewrite !id_left ; rewrite (functor_id (pr11 xx)), (functor_id (monad_endo xx)) ; exact (!(id_left _))). - use make_disp_invmodification. + exact (disp_2cells_isaprop_monad bicat_of_univ_cats univalent_cat_is_univalent_2). + exact (disp_locally_groupoid_monad bicat_of_univ_cats univalent_cat_is_univalent_2). + abstract (intros x xx ; use make_cat_monad_cell ; intros z ; simpl ; rewrite !id_left ; refine (!_) ; refine (bind_bind (Monad_to_Ktriple_data xx) (unit_kt (Monad_to_Ktriple_data xx) z) (unit_kt (Monad_to_Ktriple_data xx) z) @ _) ; apply maponpaths ; apply unit_bind). - use make_disp_invmodification. + exact disp_2cells_isaprop_kleisli. + exact disp_locally_groupoid_kleisli. + abstract (intros x xx z ; simpl ; rewrite !id_left, id_right ; rewrite bind_unit ; apply idpath). - use make_disp_invmodification. + exact disp_2cells_isaprop_kleisli. + exact disp_locally_groupoid_kleisli. + abstract (intros x xx z ; simpl ; rewrite !id_left, id_right ; rewrite bind_unit ; apply idpath). Defined. Definition Monad_to_Ktriple_psfunctor : psfunctor (total_bicat (monad bicat_of_univ_cats)) (total_bicat kleisli_triple_disp_bicat) := total_psfunctor (monad bicat_of_univ_cats) kleisli_triple_disp_bicat (id_psfunctor bicat_of_univ_cats) Monad_to_Ktriple. Definition Monad_biequiv_Ktriple : is_biequivalence Monad_to_Ktriple_psfunctor := total_is_biequivalence _ _ _ Monad_disp_biequiv_Ktriple. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Monads.v000066400000000000000000000563101451125700300255130ustar00rootroot00000000000000(** Monads as a bicategory. The construction has 3 layers. In the first layer: we take algebras on the identity functor. In the second layer: we add η an μ. This is done by adding 2-cells (as in Add2Cell) In the third layer: we take the full subcategory and we add the monad laws. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.AlgebraMap. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Local Open Scope cat. Definition monad_support (C : bicat) : bicat := bicat_algebra (id_psfunctor C). Definition monad_support_is_univalent_2_1 {C : bicat} (HC_1 : is_univalent_2_1 C) : is_univalent_2_1 (monad_support C). Proof. apply bicat_algebra_is_univalent_2_1. exact HC_1. Defined. Definition monad_support_is_univalent_2_0 {C : bicat} (HC : is_univalent_2 C) : is_univalent_2_0 (monad_support C). Proof. apply bicat_algebra_is_univalent_2_0. exact HC. Defined. Definition monad_support_is_univalent_2 {C : bicat} (HC : is_univalent_2 C) : is_univalent_2 (monad_support C). Proof. split. - apply monad_support_is_univalent_2_0; assumption. - apply monad_support_is_univalent_2_1. exact (pr2 HC). Defined. Definition add_unit (C : bicat) : disp_bicat (monad_support C). Proof. use add_cell_disp_cat. - exact (id_psfunctor _). - exact (id_psfunctor _). - exact (var _ _). - exact (alg_map _). Defined. Definition add_mu (C : bicat) : disp_bicat (monad_support C). Proof. use add_cell_disp_cat. - exact (id_psfunctor _). - exact (id_psfunctor _). - exact ((alg_map _) · (alg_map _)). - exact (alg_map _). Defined. Definition monad_data (C : bicat) : disp_bicat C := sigma_bicat _ _ (disp_dirprod_bicat (add_unit C) (add_mu C)). Definition lawless_monad (C : bicat) := total_bicat (monad_data C). Definition lawless_monad_is_univalent_2_1 (C : bicat) (HC_1 : is_univalent_2_1 C) : is_univalent_2_1 (lawless_monad C). Proof. apply sigma_is_univalent_2_1. - exact HC_1. - apply disp_alg_bicat_univalent_2_1. - apply is_univalent_2_1_dirprod_bicat. + apply add_cell_disp_cat_univalent_2_1. + apply add_cell_disp_cat_univalent_2_1. Defined. Definition lawless_monad_is_univalent_2_0 (C : bicat) (HC : is_univalent_2 C) : is_univalent_2_0 (lawless_monad C). Proof. pose (HC_1 := pr2 HC). apply sigma_is_univalent_2_0. - exact HC. - split. + apply disp_alg_bicat_univalent_2_0. apply HC. + apply disp_alg_bicat_univalent_2_1. - split. + apply is_univalent_2_0_dirprod_bicat. * apply total_is_univalent_2_1. ** exact (pr2 HC). ** apply disp_alg_bicat_univalent_2_1. * apply add_cell_disp_cat_univalent_2. ** exact (pr2 HC). ** apply disp_alg_bicat_univalent_2_1. * apply add_cell_disp_cat_univalent_2. ** exact (pr2 HC). ** apply disp_alg_bicat_univalent_2_1. + apply is_univalent_2_1_dirprod_bicat. * apply add_cell_disp_cat_univalent_2_1. * apply add_cell_disp_cat_univalent_2_1. Defined. Definition lawless_monad_is_univalent_2 (C : bicat) (HC : is_univalent_2 C) : is_univalent_2 (lawless_monad C). Proof. split. - apply lawless_monad_is_univalent_2_0; assumption. - apply lawless_monad_is_univalent_2_1. exact (pr2 HC). Defined. Section BigProjections. Context {C : bicat}. Definition bigmonad_obj : lawless_monad C → C := λ m, pr1 m. Definition bigmonad_map : ∏ (m : lawless_monad C), bigmonad_obj m --> bigmonad_obj m := λ m, pr12 m. Definition bigmonad_unit : ∏ (m : lawless_monad C), id₁ (bigmonad_obj m) ==> bigmonad_map m := λ m, pr122 m. Definition bigmonad_mu : ∏ (m : lawless_monad C), bigmonad_map m · bigmonad_map m ==> bigmonad_map m := λ m, pr222 m. Definition bigmonad_laws (m : lawless_monad C) : UU := ((bigmonad_unit m ▹ bigmonad_map m) • bigmonad_mu m = lunitor (bigmonad_map m)) × ((bigmonad_map m ◃ bigmonad_unit m) • bigmonad_mu m = runitor (bigmonad_map m)) × ((bigmonad_map m ◃ bigmonad_mu m) • bigmonad_mu m = lassociator (bigmonad_map m) (bigmonad_map m) (bigmonad_map m) • (bigmonad_mu m ▹ bigmonad_map m) • bigmonad_mu m). End BigProjections. Definition monad (C : bicat) : disp_bicat C := sigma_bicat _ _ (disp_fullsubbicat (lawless_monad C) bigmonad_laws). (** Projections *) Section Projections. Context {C : bicat} {x : C} (m : monad C x). Definition monad_endo : x --> x := pr11 m. Definition monad_unit : id₁ x ==> monad_endo := pr121 m. Definition monad_mu : monad_endo · monad_endo ==> monad_endo := pr221 m. Definition monad_ημ : linvunitor monad_endo • (monad_unit ▹ monad_endo) • monad_mu = id₂ monad_endo. Proof. refine (vassocl _ _ _ @ _ @ linvunitor_lunitor _ ). refine (maponpaths _ _). exact (pr12 m). Defined. Definition monad_μη : rinvunitor monad_endo • (monad_endo ◃ monad_unit) • monad_mu = id₂ monad_endo. Proof. refine (vassocl _ _ _ @ _ @ rinvunitor_runitor _ ). refine (maponpaths _ _). exact (pr122 m). Defined. Definition monad_μμ : (monad_endo ◃ monad_mu) • monad_mu = lassociator monad_endo monad_endo monad_endo • (monad_mu ▹ monad_endo) • monad_mu := pr222 m. End Projections. Section Projections2. Context {C : bicat} {x y : C} {mx : monad C x} {my : monad C y} {f : x --> y} (mf : mx -->[f] my). Definition monad_mor_natural : invertible_2cell (monad_endo mx · f) (f · monad_endo my) := pr11 mf. Definition monad_mor_unit : (monad_unit mx ▹ f) • monad_mor_natural = (lunitor f • rinvunitor f) • (f ◃ monad_unit my) := pr121 mf. Definition monad_mor_mu : (monad_mu mx ▹ _) • monad_mor_natural = ((((rassociator _ _ _ • (_ ◃ monad_mor_natural)) • lassociator _ _ _) • (monad_mor_natural ▹ _)) • rassociator _ _ _) • (_ ◃ monad_mu my) := pr221 mf. End Projections2. Section Projections3. Context {C : bicat} {x y : C} {mx : monad C x} {my : monad C y} {f g : x --> y} {α : f ==> g} {mf : mx -->[f] my} {mg : mx -->[g] my} (αα : mf ==>[α] mg). Definition monad_cell_natural : (monad_endo mx ◃ α) • monad_mor_natural mg = monad_mor_natural mf • (α ▹ monad_endo my) := pr11 αα. End Projections3. (** Builders. *) Definition make_monad {C : bicat} (X : C) (f : C⟦X,X⟧) (η : id₁ X ==> f) (μ : f · f ==> f) (ημ : (η ▹ f) • μ = lunitor f) (μη : (f ◃ η) • μ = runitor f) (μμ : (f ◃ μ) • μ = lassociator f f f • (μ ▹ f) • μ) : monad C X. Proof. use tpair. - use tpair. + exact f. + split. * exact η. * exact μ. - repeat split. + exact ημ. + exact μη. + exact μμ. Defined. Definition make_monad_mor {C : bicat} {x y : C} {mx : monad C x} {my : monad C y} {f : x --> y} (mf_nat : invertible_2cell (monad_endo mx · f) (f · monad_endo my)) (mfη : (monad_unit mx ▹ f) • mf_nat = (lunitor f • rinvunitor f) • (f ◃ monad_unit my)) (mfμ : (monad_mu mx ▹ _) • mf_nat = ((((rassociator _ _ _ • (_ ◃ mf_nat)) • lassociator _ _ _) • (mf_nat ▹ _)) • rassociator _ _ _) • (_ ◃ monad_mu my)) : mx -->[f] my. Proof. refine (_,, tt). use tpair. - exact mf_nat. - apply make_dirprod. + exact mfη. + exact mfμ. Defined. Definition make_monad_cell {C : bicat} {x y : C} {mx : monad C x} {my : monad C y} {f g : x --> y} {α : f ==> g} {mf : mx -->[f] my} {mg : mx -->[g] my} (α_nat : (monad_endo mx ◃ α) • monad_mor_natural mg = monad_mor_natural mf • (α ▹ monad_endo my)) : mf ==>[ α ] mg := ((α_nat ,, (tt,,tt)),, tt). Definition bigmonad (C : bicat) := total_bicat (monad C). Definition base {C : bicat} (m : bigmonad C) : C := pr1 m. Definition bigmonad_to_monad (C : bicat) (m : bigmonad C) : monad C (base m) := pr2 m. Definition make_bigmonad {C : bicat} (X : C) (f : C⟦X,X⟧) (η : id₁ X ==> f) (μ : f · f ==> f) (ημ : (η ▹ f) • μ = lunitor f) (μη : (f ◃ η) • μ = runitor f) (μμ : (f ◃ μ) • μ = lassociator f f f • (μ ▹ f) • μ) : bigmonad C. Proof. use tpair. - exact X. - use make_monad. + exact f. + exact η. + exact μ. + exact ημ. + exact μη. + exact μμ. Defined. Definition monad_is_univalent_2_1 (C : bicat) : disp_univalent_2_1 (monad_data C). Proof. use sigma_disp_univalent_2_1_with_props. - apply disp_2cells_isaprop_alg. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_add_cell. - apply disp_alg_bicat_univalent_2_1. - apply is_univalent_2_1_dirprod_bicat ; apply add_cell_disp_cat_univalent_2_1. Defined. Definition monad_is_univalent_2_0 (C : bicat) (HC : is_univalent_2 C) : disp_univalent_2_0 (monad_data C). Proof. use sigma_disp_univalent_2_0_with_props. - exact HC. - apply disp_2cells_isaprop_alg. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_add_cell. - apply disp_alg_bicat_univalent_2_1. - apply is_univalent_2_1_dirprod_bicat ; apply add_cell_disp_cat_univalent_2_1. - apply disp_locally_groupoid_alg. - apply disp_locally_groupoid_prod ; apply disp_locally_groupoid_add_cell. - apply disp_alg_bicat_univalent_2_0. exact (pr2 HC). - apply is_univalent_2_0_dirprod_bicat. + apply total_is_univalent_2_1. * exact (pr2 HC). * apply disp_alg_bicat_univalent_2_1. + apply add_cell_disp_cat_univalent_2. * exact (pr2 HC). * apply disp_alg_bicat_univalent_2_1. + apply add_cell_disp_cat_univalent_2. * exact (pr2 HC). * apply disp_alg_bicat_univalent_2_1. Defined. Definition bigmonad_is_univalent_2_1 (C : bicat) (HC_1 : is_univalent_2_1 C) : is_univalent_2_1 (bigmonad C). Proof. apply sigma_is_univalent_2_1. - exact HC_1. - apply monad_is_univalent_2_1. - apply disp_fullsubbicat_univalent_2_1. Defined. Definition bigmonad_is_univalent_2_0 (C : bicat) (HC : is_univalent_2 C) : is_univalent_2_0 (bigmonad C). Proof. apply sigma_is_univalent_2_0. - exact HC. - split. + apply monad_is_univalent_2_0. exact HC. + apply monad_is_univalent_2_1. - split. + apply disp_univalent_2_0_fullsubbicat. * exact (lawless_monad_is_univalent_2 C HC). * intro ; simpl. repeat (apply isapropdirprod) ; apply C. + apply disp_fullsubbicat_univalent_2_1. Defined. Definition bigmonad_is_univalent_2 (C : bicat) (HC : is_univalent_2 C) : is_univalent_2 (bigmonad C). Proof. split. - apply bigmonad_is_univalent_2_0; assumption. - apply bigmonad_is_univalent_2_1. exact (pr2 HC). Defined. Definition disp_2cells_isaprop_monad (C : bicat) (HC : is_univalent_2 C) : disp_2cells_isaprop (monad C). Proof. apply disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_sigma. + apply disp_2cells_isaprop_alg. + apply disp_2cells_isaprop_prod. * apply disp_2cells_isaprop_add_cell. * apply disp_2cells_isaprop_add_cell. - apply disp_2cells_isaprop_fullsubbicat. Qed. Definition disp_locally_groupoid_monad (C : bicat) (HC : is_univalent_2 C) : disp_locally_groupoid (monad C). Proof. apply disp_locally_groupoid_sigma. - exact HC. - apply disp_2cells_isaprop_sigma. + apply disp_2cells_isaprop_alg. + apply disp_2cells_isaprop_prod. * apply disp_2cells_isaprop_add_cell. * apply disp_2cells_isaprop_add_cell. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_locally_groupoid_sigma. + exact HC. + apply disp_2cells_isaprop_alg. + apply disp_2cells_isaprop_prod. * apply disp_2cells_isaprop_add_cell. * apply disp_2cells_isaprop_add_cell. + apply disp_locally_groupoid_alg. + apply disp_locally_groupoid_prod. * apply disp_locally_groupoid_add_cell. * apply disp_locally_groupoid_add_cell. - apply disp_locally_groupoid_fullsubbicat. Qed. (* ------------------------------------------------------------------------- *) (* C = bicat_of_univ_cats. *) (* ------------------------------------------------------------------------- *) Definition make_cat_monad (C : univalent_category) (M : C ⟶ C) (η : functor_identity C ⟹ M) (μ : M ∙ M ⟹ M) (lid : ∏ (X : C), #M (η X) · μ X = id₁ (M X)) (rid : ∏ (X : C), η (M X) · μ X = id₁ (M X)) (massoc : ∏ (X : C), μ (M X) · μ X = #M (μ X) · μ X) : monad bicat_of_univ_cats C. Proof. use make_monad. - exact M. - exact η. - exact μ. - abstract (use nat_trans_eq; try apply homset_property; intros X ; cbn; apply lid). - abstract (use nat_trans_eq; try apply homset_property; intros X ; cbn; apply rid). - abstract (use nat_trans_eq; try apply homset_property; intros X ; cbn; rewrite id_left; apply massoc). Defined. Definition cat_monad_ημ {C : univalent_category} (M : monad bicat_of_univ_cats C) : ∏ (X : C), #(pr1(monad_endo M)) (pr1(monad_unit M) X) · pr1(monad_mu M) X = id₁ _. Proof. intros X. pose (nat_trans_eq_pointwise (monad_ημ M) X) as p. cbn in p. rewrite id_left in p. exact p. Qed. Definition cat_monad_μη {C : univalent_category} (M : monad bicat_of_univ_cats C) : ∏ (X : C), pr1(monad_unit M) (pr1(monad_endo M) X) · pr1(monad_mu M) X = id₁ _. Proof. intros X. pose (nat_trans_eq_pointwise (monad_μη M) X) as p. cbn in p. rewrite id_left in p. exact p. Qed. Definition cat_monad_μμ {C : univalent_category} (M : monad bicat_of_univ_cats C) : ∏ (X : C), pr1(monad_mu M) (pr1(monad_endo M) X) · pr1(monad_mu M) X = #(pr1(monad_endo M)) (pr1(monad_mu M) X) · pr1(monad_mu M) X. Proof. intros X. pose (nat_trans_eq_pointwise (monad_μμ M) X) as p. cbn in p. rewrite id_left in p. exact p. Qed. (* ------------------------------------------------------------------------- *) (* Bind and associated fusion laws. *) (* ------------------------------------------------------------------------- *) Section Bind. Context {C : univalent_category} (M : monad bicat_of_univ_cats C). Definition monad_bind {A B : C} (f : C⟦A, (monad_endo M : _ ⟶ _) B⟧) : C⟦(monad_endo M : _ ⟶ _) A, (monad_endo M : _ ⟶ _) B⟧ := #(monad_endo M : _ ⟶ _) f · pr1 (monad_mu M) B. Definition cat_monad_map_as_bind {x y : pr1 C} (f : x --> y) : #(monad_endo M : _ ⟶ _) f = monad_bind (f · pr1 (monad_unit M) y). Proof. unfold monad_bind. refine (!_). etrans. { apply maponpaths_2. apply functor_comp. } rewrite assoc'. etrans. { apply maponpaths. apply cat_monad_ημ. } apply id_right. Qed. Lemma cat_monad_bind_unit {A B : C} (f : C⟦A, (monad_endo M : _ ⟶ _) B⟧) : (monad_unit M : _ ⟹ _) A · monad_bind f = f. Proof. unfold monad_bind. etrans. { rewrite assoc. apply maponpaths_2. apply (!(nat_trans_ax ((monad_unit M : _ ⟹ _)) A _ f)). } etrans. 2: apply id_right. rewrite assoc'. apply maponpaths. apply (cat_monad_μη M). Qed. Lemma cat_monad_unit_bind {A : C} : monad_bind ((monad_unit M : _ ⟹ _) A) = id₁ _. Proof. apply (cat_monad_ημ M). Qed. Lemma cat_monad_bind_bind {a b c : C} (f : C⟦a, (monad_endo M : _ ⟶ _) b⟧) (g : C⟦b, (monad_endo M : _ ⟶ _) c⟧) : monad_bind f · monad_bind g = monad_bind (f · monad_bind g). Proof. unfold monad_bind. etrans. 2: { rewrite (functor_comp (monad_endo M : _ ⟶ _)). rewrite assoc'. apply maponpaths. rewrite (functor_comp (monad_endo M : _ ⟶ _)). rewrite assoc'. apply maponpaths. apply (cat_monad_μμ M). } pose (nat_trans_ax ((monad_mu M : _ ⟹ _)) _ _ g) as Hμ. simpl in Hμ. rewrite assoc'. apply maponpaths. etrans. { rewrite assoc. apply maponpaths_2. apply (!Hμ). } rewrite assoc. apply idpath. Qed. End Bind. (* ------------------------------------------------------------------------- *) (* Monad morphism on C = bicat_of_cats. *) (* ------------------------------------------------------------------------- *) Definition make_cat_monad_mor {C D : univalent_category} {mx : monad bicat_of_univ_cats C} {my : monad bicat_of_univ_cats D} {F : C ⟶ D} (mf_nat : nat_z_iso (monad_endo mx ∙ F) (F ∙ monad_endo my)) (mfη : ∏ (X : C), # F (pr1 (monad_unit mx) X) · mf_nat X = pr1 (monad_unit my) (F X)) (mfμ : ∏ (X : C), # F (pr1 (monad_mu mx) X) · mf_nat X = mf_nat (pr1 (monad_endo mx) X) · # (pr1 (monad_endo my)) (mf_nat X) · pr1 (monad_mu my) (F X)) : mx -->[F] my. Proof. use make_monad_mor. - apply nat_z_iso_to_invertible_2cell. exact mf_nat. - abstract (use nat_trans_eq; try apply homset_property; intros X ; cbn; do 2 rewrite id_left; apply mfη). - abstract (use nat_trans_eq; try apply homset_property; intros X ; cbn; rewrite id_left, !id_right; apply mfμ). Defined. Definition make_cat_monad_cell {C D : univalent_category} {mx : monad bicat_of_univ_cats C} {my : monad bicat_of_univ_cats D} {f g : C ⟶ D} {α : f ⟹ g} {mf : mx -->[f] my} {mg : mx -->[g] my} (H : ∏ (X : C), α (pr1 (monad_endo mx) X) · (pr11 (monad_mor_natural mg)) X = (pr11 (monad_mor_natural mf)) X · # (pr1 (monad_endo my)) (pr1 α X)) : mf ==>[α: prebicat_cells bicat_of_univ_cats _ _] mg. Proof. apply make_monad_cell. use nat_trans_eq; try apply homset_property. intros X; cbn. apply H. Qed. Definition monad_mor_nat_z_iso {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) : nat_z_iso (monad_endo M₁ ∙ F) (F ∙ monad_endo M₂) := invertible_2cell_to_nat_z_iso _ _ (monad_mor_natural FF). Definition monad_mor_natural_pointwise {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) (X : C₁) : z_iso ((monad_endo M₂ : C₂ ⟶ C₂) (F X)) (F ((monad_endo M₁ : C₁ ⟶ C₁) X)) := CompositesAndInverses.nat_z_iso_to_pointwise_z_iso (nat_z_iso_inv (monad_mor_nat_z_iso FF)) X. Definition monad_mor_z_iso {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) : ∏ X : C₁, z_iso (F ((monad_endo M₁ : C₁ ⟶ C₁) X)) ((monad_endo M₂ : C₂ ⟶ C₂) (F X)) := CompositesAndInverses.nat_z_iso_to_pointwise_z_iso (monad_mor_nat_z_iso FF). Lemma monad_mor_bind {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) {A B : C₁} (f : A --> (monad_endo M₁ : _ ⟶ _) B) : #F (monad_bind M₁ f) · monad_mor_z_iso FF B = monad_mor_z_iso FF A · monad_bind M₂ (# F f · pr1 (monad_mor_z_iso FF B)). Proof. unfold monad_bind, monad_mor_z_iso. simpl. etrans. 2: { rewrite assoc. apply maponpaths_2. rewrite (functor_comp (monad_endo M₂ : _ ⟶ _)). rewrite assoc. apply maponpaths_2. apply (nat_trans_ax (pr1 (monad_mor_natural FF)) _ _ f). } simpl. rewrite functor_comp. do 3 rewrite assoc'. apply maponpaths. etrans. { pose (nat_trans_eq_pointwise (monad_mor_mu FF) B) as H. simpl in H. rewrite id_left in H. do 2 rewrite id_right in H. apply H. } rewrite assoc'. apply idpath. Qed. Lemma monad_mor_bind_alt {C₁ C₂ : univalent_category} {F : C₁ ⟶ C₂} {M₁ : monad bicat_of_univ_cats C₁} {M₂ : monad bicat_of_univ_cats C₂} (FF : M₁ -->[F] M₂) {A B : C₁} (f : A --> (monad_endo M₁ : _ ⟶ _) B) : #F (monad_bind M₁ f) = monad_mor_z_iso FF A · monad_bind M₂ (# F f · pr1 (monad_mor_z_iso FF B)) · inv_from_z_iso (monad_mor_z_iso FF B). Proof. use z_iso_inv_on_left. apply pathsinv0. apply monad_mor_bind. Qed. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/MonadsLax.v000066400000000000000000001102301451125700300261500ustar00rootroot00000000000000(*********************************************************************** The bicategory of monads and lax morphisms We define the bicategory of monads and lax morphisms. Note: this is a different bicategory from the one defined in Monads.v. The bicategory defined in that file has 1-cells that preserve the unit and multiplication up to invertible 2-cell. The formal theory of monads as described by Street, makes use of the bicategory defined in this file. Contents 1. The bicategory 2. The univalence 3. Projections and constructions 4. Invertible 2-cells 5. Equivalences of monads 6. Underlying pseudofunctor ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Local Open Scope cat. Section Monad. Context (B : bicat). (** 1. The bicategory *) Definition disp_add_unit_cat_ob_mor : disp_cat_ob_mor (end_bicat B). Proof. use make_disp_cat_ob_mor. - exact (λ mx, id₁ _ ==> pr2 mx). - exact (λ mx my ηx ηy f, linvunitor _ • (ηx ▹ (pr1 f)) = rinvunitor _ • (pr1 f ◃ ηy) • pr2 f). Defined. Definition disp_add_unit_cat_id_comp : disp_cat_id_comp _ disp_add_unit_cat_ob_mor. Proof. refine (_ ,, _). - intros mx ηx ; cbn in *. rewrite !vassocl. rewrite lunitor_V_id_is_left_unit_V_id. apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite lunitor_runitor_identity. rewrite !vassocr. rewrite runitor_rinvunitor. rewrite id2_left. apply idpath. - intros mx my mz f g ηx ηy ηz ηf ηg ; cbn in *. rewrite linvunitor_assoc. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. rewrite ηf. rewrite <- !rwhisker_vcomp. apply maponpaths_2. rewrite <- rinvunitor_triangle. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite <- ηg. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. apply idpath. Qed. Definition disp_add_unit_cat_data : disp_cat_data (end_bicat B). Proof. simple refine (_ ,, _). - exact disp_add_unit_cat_ob_mor. - exact disp_add_unit_cat_id_comp. Defined. Definition disp_add_unit : disp_bicat (end_bicat B). Proof. use disp_cell_unit_bicat. exact disp_add_unit_cat_data. Defined. Definition disp_univalent_2_1_disp_add_unit : disp_univalent_2_1 disp_add_unit. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply cellset_property. Qed. Definition disp_univalent_2_0_disp_add_unit (HB : is_univalent_2_1 B) : disp_univalent_2_0 disp_add_unit. Proof. use disp_cell_unit_bicat_univalent_2_0. - use total_is_univalent_2_1. + exact HB. + apply disp_univalent_2_1_disp_end. - intros ; apply cellset_property. - intro ; apply cellset_property. - intros ex ef eg pq. pose (p := maponpaths (λ z, runitor _ • z • runitor _) (pr1 pq)). cbn in p. rewrite lunitor_V_id_is_left_unit_V_id in p. rewrite !vassocr in p. rewrite !runitor_rinvunitor in p. rewrite !id2_left in p. rewrite !vassocl in p. rewrite rinvunitor_runitor in p. rewrite id2_right in p. rewrite vcomp_lunitor, vcomp_runitor in p. rewrite runitor_lunitor_identity in p. pose (q := maponpaths (λ z, linvunitor _ • z) p). cbn in q. rewrite !vassocr in q. rewrite !linvunitor_lunitor in q. rewrite !id2_left in q. exact q. Qed. Definition disp_univalent_2_disp_add_unit (HB : is_univalent_2_1 B) : disp_univalent_2 disp_add_unit. Proof. split. - apply disp_univalent_2_0_disp_add_unit. exact HB. - apply disp_univalent_2_1_disp_add_unit. Qed. Definition disp_add_mu_cat_ob_mor : disp_cat_ob_mor (end_bicat B). Proof. use make_disp_cat_ob_mor. - exact (λ mx, pr2 mx · pr2 mx ==> pr2 mx). - exact (λ mx my μx μy f, lassociator _ _ _ • (pr2 f ▹ _) • rassociator _ _ _ • (_ ◃ pr2 f) • lassociator _ _ _ • (μx ▹ _) = (_ ◃ μy) • pr2 f). Defined. Definition disp_add_mu_cat_id_comp : disp_cat_id_comp _ disp_add_mu_cat_ob_mor. Proof. refine (_ ,, _). - intros mx μx ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocr. apply maponpaths_2. rewrite <- rinvunitor_triangle. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. - intros mx my mz mf mg μx μy μz μf μg ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !vassocl in μf. rewrite !vassocl in μg. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- μg. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply idpath. } clear μg. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- μf. rewrite <- !rwhisker_vcomp. apply idpath. } clear μf. etrans. { etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. apply idpath. } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. apply id2_left. } rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. apply rassociator_rassociator. Qed. Definition disp_add_mu_cat_data : disp_cat_data (end_bicat B). Proof. simple refine (_ ,, _). - exact disp_add_mu_cat_ob_mor. - exact disp_add_mu_cat_id_comp. Defined. Definition disp_add_mu : disp_bicat (end_bicat B). Proof. use disp_cell_unit_bicat. exact disp_add_mu_cat_data. Defined. Definition disp_univalent_2_1_disp_add_mu : disp_univalent_2_1 disp_add_mu. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply cellset_property. Qed. Definition disp_univalent_2_0_disp_add_mu (HB : is_univalent_2_1 B) : disp_univalent_2_0 disp_add_mu. Proof. use disp_cell_unit_bicat_univalent_2_0. - use total_is_univalent_2_1. + exact HB. + apply disp_univalent_2_1_disp_end. - intros ; apply cellset_property. - intro ; apply cellset_property. - intros ex ef eg pq. pose (p := pr1 pq). cbn in p. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp in p. rewrite !vassocl in p. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. rewrite <- !vcomp_lunitor. use (vcomp_rcancel (rinvunitor _)) ; [ is_iso | ]. rewrite !vassocl. refine (_ @ p). rewrite !vassocr. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. rewrite id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. Qed. Definition disp_univalent_2_disp_add_mu (HB : is_univalent_2_1 B) : disp_univalent_2 disp_add_mu. Proof. split. - apply disp_univalent_2_0_disp_add_mu. exact HB. - apply disp_univalent_2_1_disp_add_mu. Qed. Definition disp_mnd_data : disp_bicat B := sigma_bicat B _ (disp_dirprod_bicat disp_add_unit disp_add_mu). Definition disp_2cells_isaprop_disp_mnd_data : disp_2cells_isaprop disp_mnd_data. Proof. use disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_end_bicat. - use disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_cell_unit_bicat. Qed. Definition disp_locally_sym_disp_mnd_data : disp_locally_sym disp_mnd_data. Proof. intros x y f g τ mx my mf mg mτ. simple refine ((_ ,, (tt ,, tt))) ; cbn. pose (p := pr1 mτ) ; cbn in p. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. exact (!p). Qed. Definition disp_locally_groupoid_disp_mnd_data : disp_locally_groupoid disp_mnd_data. Proof. use make_disp_locally_groupoid. - exact disp_locally_sym_disp_mnd_data. - apply disp_2cells_isaprop_disp_mnd_data. Defined. Definition disp_univalent_2_1_disp_mnd_data : disp_univalent_2_1 disp_mnd_data. Proof. use sigma_disp_univalent_2_1_with_props. - apply disp_2cells_isaprop_end_bicat. - use disp_2cells_isaprop_prod. + apply disp_2cells_isaprop_cell_unit_bicat. + apply disp_2cells_isaprop_cell_unit_bicat. - apply disp_univalent_2_1_disp_end. - use is_univalent_2_1_dirprod_bicat. + apply disp_univalent_2_1_disp_add_unit. + apply disp_univalent_2_1_disp_add_mu. Defined. Definition disp_univalent_2_0_disp_mnd_data (HB : is_univalent_2 B) : disp_univalent_2_0 disp_mnd_data. Proof. use sigma_disp_univalent_2_0_with_props. - exact HB. - apply disp_2cells_isaprop_end_bicat. - use disp_2cells_isaprop_prod. + apply disp_2cells_isaprop_cell_unit_bicat. + apply disp_2cells_isaprop_cell_unit_bicat. - apply disp_univalent_2_1_disp_end. - use is_univalent_2_1_dirprod_bicat. + apply disp_univalent_2_1_disp_add_unit. + apply disp_univalent_2_1_disp_add_mu. - apply disp_locally_groupoid_end_bicat. - use disp_locally_groupoid_prod. + apply disp_locally_groupoid_cell_unit_bicat. + apply disp_locally_groupoid_cell_unit_bicat. - apply disp_univalent_2_0_disp_end. exact (pr2 HB). - use is_univalent_2_0_dirprod_bicat. + use total_is_univalent_2_1. * exact (pr2 HB). * apply disp_univalent_2_1_disp_end. + apply disp_univalent_2_disp_add_unit. exact (pr2 HB). + apply disp_univalent_2_disp_add_mu. exact (pr2 HB). Defined. Definition disp_univalent_2_disp_mnd_data (HB : is_univalent_2 B) : disp_univalent_2 disp_mnd_data. Proof. split. - apply disp_univalent_2_0_disp_mnd_data. exact HB. - apply disp_univalent_2_1_disp_mnd_data. Defined. Definition mnd_data : bicat := total_bicat disp_mnd_data. Definition is_mnd (m : mnd_data) : UU := let X := pr1 m in let f := pr12 m in let η := pr122 m in let μ := pr222 m in (linvunitor f • (η ▹ f) • μ = id2 f) × (rinvunitor f • (f ◃ η) • μ = id2 f) × (rassociator _ _ _ • (f ◃ μ) • μ = (μ ▹ f) • μ). Definition isaprop_is_mnd (m : mnd_data) : isaprop (is_mnd m). Proof. repeat (apply isapropdirprod) ; apply cellset_property. Qed. Definition disp_mnd : disp_bicat B := sigma_bicat B _ (disp_fullsubbicat _ is_mnd). Definition disp_2cells_isaprop_disp_mnd : disp_2cells_isaprop disp_mnd. Proof. use disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_disp_mnd_data. - apply disp_2cells_isaprop_fullsubbicat. Qed. Definition disp_locally_sym_disp_mnd : disp_locally_sym disp_mnd. Proof. intros x y f g τ mx my mf mg mτ. simple refine ((_ ,, (tt ,, tt)) ,, tt) ; cbn. pose (p := pr11 mτ) ; cbn in p. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. exact (!p). Qed. Definition disp_locally_groupoid_disp_mnd : disp_locally_groupoid disp_mnd. Proof. use make_disp_locally_groupoid. - exact disp_locally_sym_disp_mnd. - apply disp_2cells_isaprop_disp_mnd. Defined. Definition disp_univalent_2_1_disp_mnd : disp_univalent_2_1 disp_mnd. Proof. use sigma_disp_univalent_2_1_with_props. - apply disp_2cells_isaprop_disp_mnd_data. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_univalent_2_1_disp_mnd_data. - apply disp_fullsubbicat_univalent_2_1. Defined. Definition disp_univalent_2_0_disp_mnd (HB : is_univalent_2 B) : disp_univalent_2_0 disp_mnd. Proof. use sigma_disp_univalent_2_0_with_props. - exact HB. - apply disp_2cells_isaprop_disp_mnd_data. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_univalent_2_1_disp_mnd_data. - apply disp_fullsubbicat_univalent_2_1. - apply disp_locally_groupoid_disp_mnd_data. - apply disp_locally_groupoid_fullsubbicat. - apply disp_univalent_2_0_disp_mnd_data. exact HB. - use disp_univalent_2_0_fullsubbicat. + apply total_is_univalent_2. * apply disp_univalent_2_disp_mnd_data. exact HB. * exact HB. + intro. repeat (use isapropdirprod) ; apply cellset_property. Defined. Definition mnd : bicat := total_bicat disp_mnd. (** 2. The univalence *) Definition is_univalent_2_1_mnd (HB : is_univalent_2_1 B) : is_univalent_2_1 mnd. Proof. apply total_is_univalent_2_1. - exact HB. - apply disp_univalent_2_1_disp_mnd. Defined. Definition is_univalent_2_0_mnd (HB : is_univalent_2 B) : is_univalent_2_0 mnd. Proof. apply total_is_univalent_2_0. - exact (pr1 HB). - apply disp_univalent_2_0_disp_mnd. exact HB. Defined. Definition is_univalent_2_mnd (HB : is_univalent_2 B) : is_univalent_2 mnd. Proof. split. - exact (is_univalent_2_0_mnd HB). - exact (is_univalent_2_1_mnd (pr2 HB)). Defined. End Monad. (** 3. Projections and constructions *) Section MonadProjections. Context {B : bicat} (m : mnd B). Definition ob_of_mnd : B := pr1 m. Definition endo_of_mnd : ob_of_mnd --> ob_of_mnd := pr112 m. Definition unit_of_mnd : id₁ _ ==> endo_of_mnd := pr1 (pr212 m). Definition mult_of_mnd : endo_of_mnd · endo_of_mnd ==> endo_of_mnd := pr2 (pr212 m). Definition mnd_unit_left : linvunitor _ • (unit_of_mnd ▹ _) • mult_of_mnd = id2 _ := pr122 m. Definition mnd_unit_right : rinvunitor _ • (_ ◃ unit_of_mnd) • mult_of_mnd = id2 _ := pr1 (pr222 m). Definition mnd_mult_assoc : rassociator _ _ _ • (_ ◃ mult_of_mnd) • mult_of_mnd = (mult_of_mnd ▹ _) • mult_of_mnd := pr2 (pr222 m). Definition mnd_mult_assoc' : (_ ◃ mult_of_mnd) • mult_of_mnd = lassociator _ _ _ • (mult_of_mnd ▹ _) • mult_of_mnd. Proof. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. exact mnd_mult_assoc. Qed. End MonadProjections. Definition make_mnd_data {B : bicat} (x : B) (f : x --> x) (η : id₁ _ ==> f) (μ : f · f ==> f) : mnd_data B := x ,, (f ,, (η ,, μ)). Definition make_mnd {B : bicat} (m : mnd_data B) (Hm : is_mnd B m) : mnd B := pr1 m ,, (pr2 m ,, Hm). Section MonadMapProjections. Context {B : bicat} {m₁ m₂ : mnd B} (f : m₁ --> m₂). Definition mor_of_mnd_mor : ob_of_mnd m₁ --> ob_of_mnd m₂ := pr1 f. Definition mnd_mor_endo : mor_of_mnd_mor · endo_of_mnd m₂ ==> endo_of_mnd m₁ · mor_of_mnd_mor := pr112 f. Definition mnd_mor_unit : linvunitor _ • (unit_of_mnd m₁ ▹ _) = rinvunitor _ • (_ ◃ unit_of_mnd m₂) • mnd_mor_endo := pr1 (pr212 f). Definition mnd_mor_mu : lassociator _ _ _ • (mnd_mor_endo ▹ _) • rassociator _ _ _ • (_ ◃ mnd_mor_endo) • lassociator _ _ _ • (mult_of_mnd m₁ ▹ _) = (_ ◃ mult_of_mnd m₂) • mnd_mor_endo := pr2 (pr212 f). End MonadMapProjections. Definition mnd_mor_data {B : bicat} (m₁ m₂ : mnd B) : UU := ∑ (f : ob_of_mnd m₁ --> ob_of_mnd m₂), f · endo_of_mnd m₂ ==> endo_of_mnd m₁ · f. Definition make_mnd_mor_data {B : bicat} {m₁ m₂ : mnd B} (f : ob_of_mnd m₁ --> ob_of_mnd m₂) (f_e : f · endo_of_mnd m₂ ==> endo_of_mnd m₁ · f) : mnd_mor_data m₁ m₂ := f ,, f_e. Definition mnd_mor_laws {B : bicat} {m₁ m₂ : mnd B} (f : mnd_mor_data m₁ m₂) : UU := (linvunitor _ • (unit_of_mnd m₁ ▹ _) = rinvunitor _ • (_ ◃ unit_of_mnd m₂) • (pr2 f)) × (lassociator _ _ _ • (pr2 f ▹ _) • rassociator _ _ _ • (_ ◃ pr2 f) • lassociator _ _ _ • (mult_of_mnd m₁ ▹ _) = (_ ◃ mult_of_mnd m₂) • pr2 f). Definition make_mnd_mor_laws {B : bicat} {m₁ m₂ : mnd B} (f : mnd_mor_data m₁ m₂) (fη : linvunitor _ • (unit_of_mnd m₁ ▹ _) = rinvunitor _ • (_ ◃ unit_of_mnd m₂) • pr2 f) (fμ : lassociator _ _ _ • (pr2 f ▹ _) • rassociator _ _ _ • (_ ◃ pr2 f) • lassociator _ _ _ • (mult_of_mnd m₁ ▹ _) = (_ ◃ mult_of_mnd m₂) • pr2 f) : mnd_mor_laws f := fη ,, fμ. Definition make_mnd_mor {B : bicat} {m₁ m₂ : mnd B} (f : mnd_mor_data m₁ m₂) (Hf : mnd_mor_laws f) : m₁ --> m₂ := pr1 f ,, (pr2 f ,, Hf) ,, tt. Section MonadCellProjections. Context {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} (τ : f₁ ==> f₂). Definition cell_of_mnd_cell : mor_of_mnd_mor f₁ ==> mor_of_mnd_mor f₂ := pr1 τ. Definition mnd_cell_endo : mnd_mor_endo f₁ • (_ ◃ cell_of_mnd_cell) = (cell_of_mnd_cell ▹ _) • mnd_mor_endo f₂ := pr112 τ. End MonadCellProjections. Definition mnd_cell_data {B : bicat} {m₁ m₂ : mnd B} (f₁ f₂ : m₁ --> m₂) : UU := mor_of_mnd_mor f₁ ==> mor_of_mnd_mor f₂. Definition is_mnd_cell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} (τ : mnd_cell_data f₁ f₂) : UU := mnd_mor_endo f₁ • (_ ◃ τ) = (τ ▹ _) • mnd_mor_endo f₂. Definition make_mnd_cell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} (τ : mnd_cell_data f₁ f₂) (τ_e : is_mnd_cell τ) : f₁ ==> f₂ := τ ,, ((τ_e ,, (tt ,, tt)) ,, tt). Definition eq_mnd_cell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} {τ₁ τ₂ : f₁ ==> f₂} (p : cell_of_mnd_cell τ₁ = cell_of_mnd_cell τ₂) : τ₁ = τ₂. Proof. use subtypePath. { intro ; simpl. apply isapropdirprod ; [ | apply isapropunit ]. apply isapropdirprod ; [ apply cellset_property | ]. apply isapropdirprod ; apply isapropunit. } exact p. Qed. (** 4. Invertible 2-cells *) Section IsInvertibleMndCell. Context {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} {τ : f₁ ==> f₂} (Hτ : is_invertible_2cell (cell_of_mnd_cell τ)). Definition is_invertible_mnd_2cell_inverse : f₂ ==> f₁. Proof. use make_mnd_cell. - exact (Hτ^-1). - abstract (cbn ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; refine (!_) ; exact (mnd_cell_endo τ)). Defined. Definition is_invertible_mnd_2cell : is_invertible_2cell τ. Proof. use make_is_invertible_2cell. - exact is_invertible_mnd_2cell_inverse. - abstract (use eq_mnd_cell ; cbn ; apply vcomp_rinv). - abstract (use eq_mnd_cell ; cbn ; apply vcomp_linv). Defined. End IsInvertibleMndCell. Definition from_invertible_mnd_2cell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : m₁ --> m₂} {τ : f₁ ==> f₂} (Hτ : is_invertible_2cell τ) : is_invertible_2cell (cell_of_mnd_cell τ). Proof. use make_is_invertible_2cell. - exact (pr1 (Hτ^-1)). - abstract (exact (maponpaths pr1 (vcomp_rinv Hτ))). - abstract (exact (maponpaths pr1 (vcomp_linv Hτ))). Defined. (** 5. Equivalences of monads *) Section ToEquivalence. Context {B : bicat} {x : B} {mx mx' : disp_mnd B x} (m₁ := x,, mx : mnd B) (m₂ := x,, mx' : mnd B) (Hl : mx -->[ id₁ x ] mx'). Let l : m₁ --> m₂ := id₁ x ,, Hl. Context (Hγ : is_invertible_2cell (mnd_mor_endo l)). Definition to_equivalence_mnd_help_right_adj_data : mnd_mor_data m₂ m₁. Proof. use make_mnd_mor_data. - exact (id₁ x). - exact (lunitor _ • rinvunitor _ • Hγ^-1 • lunitor _ • rinvunitor _). Defined. Definition to_equivalence_mnd_help_right_adj_laws : mnd_mor_laws to_equivalence_mnd_help_right_adj_data. Proof. split. - cbn. rewrite !vassocl. rewrite lunitor_V_id_is_left_unit_V_id. apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. rewrite id2_left. apply maponpaths. do 2 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn. rewrite linvunitor_natural. rewrite rinvunitor_natural. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite lunitor_V_id_is_left_unit_V_id. refine (_ @ mnd_mor_unit l). rewrite <- lunitor_V_id_is_left_unit_V_id. apply idpath. - cbn. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocr. do 3 (use vcomp_move_L_Mp ; [ is_iso | ]) ; cbn. rewrite !vassocl. etrans. { do 13 apply maponpaths. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocl. apply maponpaths. exact (!(mnd_mor_mu l)). } rewrite !vassocl. refine (!_). etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite <- lunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. etrans. { rewrite !vassocr. do 12 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocl. do 4 apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rinvunitor_runitor. rewrite id2_left. rewrite linvunitor_assoc. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } cbn. rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. do 2 apply maponpaths_2. apply maponpaths. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. apply id2_left. } apply vcomp_linv. } apply id2_right. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !lwhisker_vcomp. apply maponpaths. refine (_ @ id2_right _). rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. apply id2_left. } apply vcomp_linv. Qed. Definition to_equivalence_mnd_help_right_adj : m₂ --> m₁. Proof. use make_mnd_mor. - exact to_equivalence_mnd_help_right_adj_data. - exact to_equivalence_mnd_help_right_adj_laws. Defined. Definition to_equivalence_mnd_help_equiv_unit_data : mnd_cell_data (id₁ m₁) (l · to_equivalence_mnd_help_right_adj) := linvunitor _. Definition to_equivalence_mnd_help_equiv_unit_is_mnd_cell : is_mnd_cell to_equivalence_mnd_help_equiv_unit_data. Proof. unfold is_mnd_cell, to_equivalence_mnd_help_equiv_unit_data ; cbn. rewrite !vassocr. refine (!_). rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite linvunitor_assoc. rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition to_equivalence_mnd_help_equiv_unit : id₁ m₁ ==> l · to_equivalence_mnd_help_right_adj. Proof. use make_mnd_cell. - exact to_equivalence_mnd_help_equiv_unit_data. - exact to_equivalence_mnd_help_equiv_unit_is_mnd_cell. Defined. Definition to_equivalence_mnd_help_equiv_counit_data : mnd_cell_data (to_equivalence_mnd_help_right_adj · l) (id₁ m₂) := lunitor _. Definition to_equivalence_mnd_help_equiv_counit_is_mnd_cell : is_mnd_cell to_equivalence_mnd_help_equiv_counit_data. Proof. unfold is_mnd_cell, to_equivalence_mnd_help_equiv_counit_data ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. apply idpath. } rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply maponpaths. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_right. rewrite !rwhisker_vcomp. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite vcomp_runitor. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_rinvunitor. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite vcomp_rinv. apply id2_left. Qed. Definition to_equivalence_mnd_help_equiv_counit : to_equivalence_mnd_help_right_adj · l ==> id₁ m₂. Proof. use make_mnd_cell. - exact to_equivalence_mnd_help_equiv_counit_data. - exact to_equivalence_mnd_help_equiv_counit_is_mnd_cell. Defined. Definition to_equivalence_mnd_help_equiv_data : left_adjoint_data l := to_equivalence_mnd_help_right_adj ,, (to_equivalence_mnd_help_equiv_unit ,, to_equivalence_mnd_help_equiv_counit). Definition to_equivalence_mnd_help_equiv_axioms : left_equivalence_axioms to_equivalence_mnd_help_equiv_data. Proof. split ; use is_invertible_mnd_2cell ; cbn. - unfold to_equivalence_mnd_help_equiv_unit_data. is_iso. - unfold to_equivalence_mnd_help_equiv_counit_data. is_iso. Defined. Definition to_equivalence_mnd_help_equiv : left_equivalence l := to_equivalence_mnd_help_equiv_data ,, to_equivalence_mnd_help_equiv_axioms. End ToEquivalence. Definition to_equivalence_mnd_help {B : bicat} (HB : is_univalent_2_0 B) {x y : B} (l : adjoint_equivalence x y) {mx : disp_mnd B x} {my : disp_mnd B y} (m₁ := x ,, mx : mnd B) (m₂ := y ,, my : mnd B) (Hl : mx -->[ l ] my) (ml := pr1 l ,, Hl : m₁ --> m₂) (Hγ : is_invertible_2cell (mnd_mor_endo ml)) : left_adjoint_equivalence ml. Proof. revert x y l mx my m₁ m₂ Hl ml Hγ. use (J_2_0 HB). intros x mx mx' m₁ m₂ Hl ml Hγ. use equiv_to_adjequiv. exact (to_equivalence_mnd_help_equiv Hl Hγ). Defined. Definition to_equivalence_mnd {B : bicat} (HB : is_univalent_2_0 B) {m₁ m₂ : mnd B} (l : m₁ --> m₂) (Hl : left_adjoint_equivalence (pr1 l)) (Hγ : is_invertible_2cell (mnd_mor_endo l)) : left_adjoint_equivalence l. Proof. exact (to_equivalence_mnd_help HB (pr1 l ,, Hl) (pr2 l) Hγ). Defined. (** 6. Underlying pseudofunctor *) Definition und_mnd (B : bicat) : psfunctor (mnd B) B := pr1_psfunctor _. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/PointedGroupoid.v000066400000000000000000000311701451125700300274020ustar00rootroot00000000000000(* The univalent bicategory of pointed groupoid. *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Core.Examples.Groupoids. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PathGroupoid. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.PointedOneTypes. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispModification. Require Import UniMath.Bicategories.DisplayedBicats.DispBiequivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders. Local Open Scope cat. Local Open Scope bicategory_scope. Definition pgrpds_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells grpds. Proof. use tpair. - use tpair. + (** Objects and 1-cells *) use tpair. * (** Objects over a groupoid are points of X *) exact (λ G, pr11 G). * cbn. intros G1 G2 x y F. (** 1-cells over F are properties: F preserves points *) exact (z_iso (pr1 F x) y). + (** Identity and composition of 1-cells: composition of properties *) use tpair. * exact (λ G x, identity_z_iso x). * intros G1 G2 G3 F1 F2 x y z i1 i2. exact (z_iso_comp (functor_on_z_iso (pr1 F2) i1) i2). - intros G1 G2 F1 F2 α x y i1 i2. cbn in *. (** Two cells over α : F1 ==> F2 *) unfold total_prebicat_cell_struct in α. cbn in *. (* α on the point of G1 is iso to identity *) exact (pr1 α x · i2 = i1). Defined. Definition pgrpds_disp_prebicat_ops : disp_prebicat_ops pgrpds_disp_prebicat_1_id_comp_cells. Proof. repeat split; cbn. - intros G1 G2 F x y i. apply id_left. - intros G1 G2 F x y i. rewrite functor_id. apply idpath. - intros G1 G2 F x y i. rewrite id_left. rewrite id_right. apply idpath. - intros G1 G2 F x y i. rewrite functor_id. rewrite !id_left. apply idpath. - intros G1 G2 F x y i. rewrite id_left. rewrite id_right. apply idpath. - intros G1 G2 G3 G4 F1 F2 F3 x y z w i1 i2 i3. rewrite id_left. rewrite functor_comp. rewrite assoc. apply idpath. - intros G1 G2 G3 G4 F1 F2 F3 x y z w i1 i2 i3. rewrite id_left. rewrite functor_comp. rewrite assoc. apply idpath. - intros G1 G2 F1 F2 F3 α β x y i1 i2 i3 p1 p2. rewrite assoc'. rewrite p2. apply p1. - intros G1 G2 G3 F1 F2 F3 α x y z i1 i2 i3 p. rewrite assoc. rewrite <- (nat_trans_ax (pr1 α)). rewrite assoc'. apply maponpaths. apply p. - intros G1 G2 G3 F1 F2 F3 α x y z i1 i2 i3 p. rewrite assoc. apply (maponpaths (λ z, z · i3)). rewrite <- functor_comp. apply maponpaths. apply p. Qed. Definition pgrpds_prebicat_laws : disp_prebicat_laws (pgrpds_disp_prebicat_1_id_comp_cells,, pgrpds_disp_prebicat_ops). Proof. cbn. repeat split; intro; intros ; apply homset_property. Qed. Definition pgrpds_prebicat : disp_prebicat grpds. Proof. use tpair. - exists pgrpds_disp_prebicat_1_id_comp_cells. apply pgrpds_disp_prebicat_ops. - exact pgrpds_prebicat_laws. Defined. Definition pgrpds_disp : disp_bicat grpds. Proof. use tpair. - apply pgrpds_prebicat. - repeat intro. apply hlevelntosn. apply homset_property. Defined. Definition pgrpds : bicat := total_bicat pgrpds_disp. (* The bicategory of pointed groupoids is biequivalent to the bicategory of pointed 1types. *) Definition pgrpds_disp_2cells_isaprop : disp_2cells_isaprop pgrpds_disp. Proof. intros G₁ G₂; intros. apply homset_property. Qed. Definition pgrpds_disp_locally_groupoid : disp_locally_groupoid pgrpds_disp. Proof. use make_disp_locally_groupoid. - intros G₁ G₂ F₁ F₂ n pG₁ pG₂ pF₁ pF₂ pn. cbn in *. rewrite <- pn. rewrite assoc. etrans. { apply maponpaths_2. apply (nat_trans_eq_pointwise (maponpaths pr1 (vcomp_linv (pr2 n)))). } apply id_left. - exact pgrpds_disp_2cells_isaprop. Qed. Definition p1types_disp_2cells_isaprop : disp_2cells_isaprop p1types_disp. Proof. intros A B; intros. exact (pr2 B _ _ _ _). Qed. Definition p1types_disp_locally_groupoid : disp_locally_groupoid p1types_disp. Proof. use make_disp_locally_groupoid. - intros G₁ G₂ F₁ F₂ n pG₁ pG₂ pF₁ pF₂ pn. cbn in *. refine (!_). apply hornRotation_rr. refine (!_). refine (maponpaths (λ z, _ @ ! z) pn @ _). etrans. { apply maponpaths. apply pathscomp_inv. } refine (path_assoc _ _ _ @ _). etrans. { apply maponpaths_2. apply pathsinv0r. } simpl. apply pathsinv0_to_right'. exact (!(maponpaths (λ z, z pG₁) (vcomp_rinv n))). - exact p1types_disp_2cells_isaprop. Qed. Definition disp_objects_of_pgrpd : disp_psfunctor pgrpds_disp p1types_disp objects_of_grpd. Proof. use make_disp_psfunctor. - exact p1types_disp_2cells_isaprop. - exact p1types_disp_locally_groupoid. - exact (λ G x, x). - intros G1 G2 F x y i. exact (isotoid _ (pr21 G2) i). - abstract (intros G1 G2 F1 F2 α x y i1 i2 p ; cbn in * ; rewrite <- isotoid_comp ; apply maponpaths ; apply z_iso_eq ; cbn ; refine (! p)). - abstract (intros G x ; cbn ; rewrite isotoid_identity_iso ; apply idpath). - abstract (intros G1 G2 G3 F1 F2 x y z i1 i2 ; cbn ; rewrite (maponpaths_isotoid _ _ _ (pr21 G2) (pr21 G3)) ; rewrite <- isotoid_comp ; apply idpath). Defined. Definition disp_path_pgroupoid : disp_psfunctor p1types_disp pgrpds_disp path_groupoid. Proof. use make_disp_psfunctor. - exact pgrpds_disp_2cells_isaprop. - exact pgrpds_disp_locally_groupoid. - exact (λ X x, x). - intros X Y f x y p. simpl in *. exact (p ,, pr2 (path_groupoid Y) _ _ p). - abstract (intros X Y f g α x y p q αα ; cbn in * ; exact (!αα)). - abstract (intros X x ; apply idpath). - abstract (intros X Y Z f g x y z p q ; apply idpath). Defined. Definition disp_path_pgroupoid_counit : disp_pstrans (disp_pseudo_comp _ _ _ _ _ disp_objects_of_pgrpd disp_path_pgroupoid) (disp_pseudo_id _) path_groupoid_counit. Proof. use make_disp_pstrans. - exact pgrpds_disp_2cells_isaprop. - exact pgrpds_disp_locally_groupoid. - exact (λ G x, identity_z_iso x). - abstract (intros G1 G2 F x y i ; cbn in * ; rewrite idtoiso_isotoid ; rewrite functor_id ; rewrite !id_left ; apply id_right). Defined. Definition disp_path_pgroupoid_unit : disp_pstrans (disp_pseudo_id _) (disp_pseudo_comp _ _ _ _ _ disp_path_pgroupoid disp_objects_of_pgrpd) path_groupoid_unit. Proof. use make_disp_pstrans. - exact p1types_disp_2cells_isaprop. - exact p1types_disp_locally_groupoid. - exact (λ X x, idpath x). - abstract (intros X Y f x y p; cbn in *; rewrite pathscomp0rid; rewrite maponpathsidfun; cbn; refine (_ @ isotoid_idtoiso _ (is_univalent_path_groupoid (pr1 Y) (pr2 Y)) _ _ _); apply maponpaths; apply z_iso_eq; cbn; induction p; apply idpath). Defined. Definition disp_path_pgroupoid_counit_inv : disp_pstrans (disp_pseudo_id _) (disp_pseudo_comp _ _ _ _ _ disp_objects_of_pgrpd disp_path_pgroupoid) path_groupoid_counit_inv. Proof. use make_disp_pstrans. - exact pgrpds_disp_2cells_isaprop. - exact pgrpds_disp_locally_groupoid. - intros G x. exact (@identity_z_iso (pr11 (path_groupoid (objects_of_grpd G))) x). - abstract (intros G1 G2 F x y i; cbn; rewrite pathscomp0rid; apply maponpaths; use z_iso_eq; apply idpath). Defined. Definition disp_path_pgroupoid_unit_inv : disp_pstrans (disp_pseudo_comp _ _ _ _ _ disp_path_pgroupoid disp_objects_of_pgrpd) (disp_pseudo_id _) path_groupoid_unit_inv. Proof. use make_disp_pstrans. - exact p1types_disp_2cells_isaprop. - exact p1types_disp_locally_groupoid. - exact (λ X x, idpath x). - abstract (intros X Y f x y p; cbn in *; rewrite pathscomp0rid; rewrite maponpathsidfun; refine (!(isotoid_idtoiso _ (is_univalent_path_groupoid (pr1 Y) (pr2 Y)) _ _ _) @_); apply maponpaths; induction p; use z_iso_eq; apply idpath). Defined. Definition is_disp_biequiv_unit_counit_path_pgroupoid : is_disp_biequivalence_unit_counit _ _ (unit_counit_from_is_biequivalence is_biequiv_path_groupoid) disp_path_pgroupoid disp_objects_of_pgrpd. Proof. use tpair. - exact disp_path_pgroupoid_unit_inv. - exact disp_path_pgroupoid_counit. Defined. Definition disp_path_pgroupoid_unit_unit_inv : disp_invmodification _ _ _ _ (disp_comp_pstrans disp_path_pgroupoid_unit disp_path_pgroupoid_unit_inv) (disp_id_pstrans _) (unitcounit_of_is_biequivalence is_biequiv_path_groupoid). Proof. use make_disp_invmodification. - exact p1types_disp_2cells_isaprop. - exact p1types_disp_locally_groupoid. - abstract (intros X x; apply idpath). Defined. Definition disp_path_pgroupoid_unit_inv_unit : disp_invmodification _ _ _ _ (disp_comp_pstrans disp_path_pgroupoid_unit_inv disp_path_pgroupoid_unit) (disp_id_pstrans _) (unitunit_of_is_biequivalence is_biequiv_path_groupoid). Proof. use make_disp_invmodification. - exact p1types_disp_2cells_isaprop. - exact p1types_disp_locally_groupoid. - abstract (intros X x; apply idpath). Defined. Definition disp_path_pgroupoid_counit_inv_counit : disp_invmodification _ _ _ _ (disp_comp_pstrans disp_path_pgroupoid_counit_inv disp_path_pgroupoid_counit) (disp_id_pstrans _) (counitcounit_of_is_biequivalence is_biequiv_path_groupoid). Proof. use make_disp_invmodification. - exact pgrpds_disp_2cells_isaprop. - exact pgrpds_disp_locally_groupoid. - abstract (intros G x; cbn; rewrite !id_right; apply (z_iso_inv_after_z_iso (id₁ x ,, _))). Defined. Definition disp_path_pgroupoid_counit_counit_inv : disp_invmodification _ _ _ _ (disp_comp_pstrans disp_path_pgroupoid_counit disp_path_pgroupoid_counit_inv) (disp_id_pstrans _) (counitunit_of_is_biequivalence is_biequiv_path_groupoid). Proof. use make_disp_invmodification. - exact pgrpds_disp_2cells_isaprop. - exact pgrpds_disp_locally_groupoid. - abstract (intros G x; cbn; rewrite pathscomp0rid; refine (! (isotoid_idtoiso _ (pr21 G) _ _ (idpath _)) @ _); apply maponpaths; apply z_iso_eq; apply idpath). Defined. Definition disp_biequiv_data_unit_counit_path_pgroupoid : disp_is_biequivalence_data _ _ is_biequiv_path_groupoid is_disp_biequiv_unit_counit_path_pgroupoid. Proof. use tpair. - exact disp_path_pgroupoid_unit. - use tpair. + exact disp_path_pgroupoid_counit_inv. + use tpair. * simpl. use tpair. -- exact disp_path_pgroupoid_unit_unit_inv. -- exact disp_path_pgroupoid_unit_inv_unit. * use tpair. -- exact disp_path_pgroupoid_counit_inv_counit. -- exact disp_path_pgroupoid_counit_counit_inv. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/PointedOneTypes.v000066400000000000000000000102331451125700300273550ustar00rootroot00000000000000(** The univalent bicategory of pointed 1-types. *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope bicategory_scope. Definition p1types_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells one_types. Proof. use tpair. - use tpair. + (** Objects and 1-cells *) use tpair. * (** Objects over a one type are points of X *) exact (λ X, pr1 X). * (** 1-cells over f are properties: f preserves points *) exact (λ _ _ x y f, f x = y). + (** Identity and composition of 1-cells: composition of properties *) use tpair. * exact (λ _ _, idpath _). * exact (λ _ _ _ f g x y z Hf Hg, maponpaths g Hf @ Hg). - exact (λ _ _ _ _ α x y ff gg, ff = α x @ gg). Defined. Definition p1types_disp_prebicat_ops : disp_prebicat_ops p1types_disp_prebicat_1_id_comp_cells. Proof. repeat split; cbn. - intros X Y f x y ff. exact (pathscomp0rid _ @ maponpathsidfun _). - intros X Y f x y ff. exact (!(pathscomp0rid _ @ maponpathsidfun _)). - intros X Y Z W f g h x y z w ff gg hh. refine (_ @ !(path_assoc _ _ _)). refine (maponpaths (λ z, z @ hh) _). refine (maponpathscomp0 h (maponpaths g ff) gg @ _). refine (maponpaths (λ z, z @ _) _). apply maponpathscomp. - intros X Y Z W f g h x y z w ff gg hh. refine (!_). refine (_ @ !(path_assoc _ _ _)). refine (maponpaths (λ z, z @ hh) _). refine (maponpathscomp0 h (maponpaths g ff) gg @ _). refine (maponpaths (λ z, z @ _) _). apply maponpathscomp. - intros X Y f g h α β x y ff gg hh αα ββ. exact (αα @ maponpaths (λ z, _ @ z) ββ @ path_assoc _ _ _). - (* Whiskering *) intros X Y Z f g h α x y z ff gg hh αα. unfold funhomotsec. refine (maponpaths (λ z, _ @ z) αα @ _). refine (path_assoc _ _ _ @ _ @ !(path_assoc _ _ _)). refine (maponpaths (λ z, z @ _) _). apply homotsec_natural. - (* Whiskering *) intros X Y Z f g h α x y z ff gg hh αα. unfold homotfun. refine (_ @ !(path_assoc _ _ _)). refine (maponpaths (λ z, z @ hh) _). exact (maponpaths (maponpaths h) αα @ maponpathscomp0 h (α x) gg). Defined. Definition p1types_prebicat : disp_prebicat one_types. Proof. use tpair. - exists p1types_disp_prebicat_1_id_comp_cells. apply p1types_disp_prebicat_ops. - repeat split; repeat intro; apply one_type_isofhlevel. Defined. Definition p1types_disp : disp_bicat one_types. Proof. use tpair. - apply p1types_prebicat. - repeat intro. apply hlevelntosn. apply one_type_isofhlevel. Defined. Definition p1types : bicat := total_bicat p1types_disp. Lemma p1types_disp_univalent_2_1 : disp_univalent_2_1 p1types_disp. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros X Y f x y. cbn. intros p q. use isweq_iso. - intro α. apply α. - intros α. apply Y. - intros α. cbn in *. use subtypePath. { intro. apply (isaprop_is_disp_invertible_2cell (D:=p1types_disp)). } apply Y. Defined. Lemma p1types_disp_univalent_2_0 : disp_univalent_2_0 p1types_disp. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros X x x'. cbn in *. use isweq_iso. - intros f. apply f. - intro p. induction p. apply idpath. - intros [f Hf]. use subtypePath. { intros y y'. apply (isaprop_disp_left_adjoint_equivalence (D:=p1types_disp)). + apply one_types_is_univalent_2. + apply p1types_disp_univalent_2_1. } cbn ; cbn in f. induction f. apply idpath. Defined. Lemma p1types_disp_univalent_2 : disp_univalent_2 p1types_disp. Proof. apply make_disp_univalent_2. - exact p1types_disp_univalent_2_0. - exact p1types_disp_univalent_2_1. Defined. Lemma p1types_univalent_2 : is_univalent_2 p1types. Proof. apply total_is_univalent_2. - apply p1types_disp_univalent_2. - apply one_types_is_univalent_2. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Prod.v000066400000000000000000001060441451125700300251760ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 Various basic constructions of displayed and non displayed bicategories: - Unit displayed bicategory of a displayed 1-category. - Full subbicategory of a bicategory. - Direct product of bicategories. ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope mor_disp_scope. (* ----------------------------------------------------------------------------------- *) (** ** Direct product of two displayed structures over a bicategory. *) (* ----------------------------------------------------------------------------------- *) Section Disp_PreDirprod. Context {C : bicat}. Variable (D1 D2 : disp_prebicat C). Definition disp_dirprod_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells C. Proof. exists (dirprod_disp_cat_data D1 D2). intros c c' f g x d d' f' g'. cbn in *. exact ( (pr1 f' ==>[ x ] pr1 g') × (pr2 f' ==>[ x ] pr2 g')). Defined. Definition disp_dirprod_prebicat_ops : disp_prebicat_ops disp_dirprod_prebicat_1_id_comp_cells. Proof. repeat (use tpair). - cbn. intros. apply (make_dirprod (disp_id2 _ ) (disp_id2 _)). - cbn. intros. apply (make_dirprod (disp_lunitor _ ) (disp_lunitor _)). - cbn. intros. apply (make_dirprod (disp_runitor _ ) (disp_runitor _)). - cbn. intros. apply (make_dirprod (disp_linvunitor _ ) (disp_linvunitor _)). - cbn. intros. apply (make_dirprod (disp_rinvunitor _ ) (disp_rinvunitor _)). - cbn. intros. apply (make_dirprod (disp_rassociator _ _ _ ) (disp_rassociator _ _ _)). - cbn. intros. apply (make_dirprod (disp_lassociator _ _ _ ) (disp_lassociator _ _ _)). - cbn. intros. apply (make_dirprod (disp_vcomp2 (pr1 X) (pr1 X0)) (disp_vcomp2 (pr2 X) (pr2 X0))). - cbn. intros. apply (make_dirprod (disp_lwhisker (pr1 ff) (pr1 X)) (disp_lwhisker (pr2 ff) (pr2 X))). - cbn. intros. apply (make_dirprod (disp_rwhisker (pr1 gg) (pr1 X)) (disp_rwhisker (pr2 gg) (pr2 X))). Defined. Definition disp_dirprod_prebicat_data : disp_prebicat_data C := _ ,, disp_dirprod_prebicat_ops. Definition disp_dirprod_brebicat_laws : disp_prebicat_laws disp_dirprod_prebicat_data. Proof. repeat split; intro. - cbn. intros. apply dirprod_paths; cbn; use (disp_id2_left _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_id2_right _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_vassocr _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lwhisker_id2 _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_id2_rwhisker _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lwhisker_vcomp _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_rwhisker_vcomp _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_vcomp_lunitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_vcomp_runitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lwhisker_lwhisker _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_rwhisker_lwhisker _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_rwhisker_rwhisker _ _ _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_vcomp_whisker _ _ _ _ _ _ _ _ _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lunitor_linvunitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_linvunitor_lunitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_runitor_rinvunitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_rinvunitor_runitor _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lassociator_rassociator _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_rassociator_lassociator _ _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_runitor_rwhisker _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). - cbn. intros. apply dirprod_paths; cbn; use (disp_lassociator_lassociator _ _ _ _ @ _ ); apply pathsinv0. + exact (@pr1_transportf (_ ==> _) _ (λ a _ , _ ) _ _ _ _ ). + apply (@pr2_transportf (_ ==> _) (λ a, _ ==>[a]_ ) (λ a, _ ==>[a]_ ) ). Qed. Definition disp_dirprod_prebicat : disp_prebicat C := _ ,, disp_dirprod_brebicat_laws. End Disp_PreDirprod. Section Disp_Dirprod. Context {C : bicat}. Variable (D1 D2 : disp_bicat C). Definition disp_dirprod_bicat : disp_bicat C. Proof. refine (disp_dirprod_prebicat D1 D2 ,, _). intros a b f g x aa bb ff gg. apply isasetdirprod. - apply D1. - apply D2. Defined. (** Local Univalence of the poduct *) Definition pair_is_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x (pr1 xx) × is_disp_invertible_2cell x (pr2 xx) → is_disp_invertible_2cell x xx. Proof. intros H. induction H as [H1 H2]. use tpair. - split. + exact (disp_inv_cell (_ ,, H1)). + exact (disp_inv_cell (_ ,, H2)). - split. + refine (total2_paths2 (disp_vcomp_rinv (_ ,, H1)) (disp_vcomp_rinv (_ ,, H2)) @ _). refine (!(transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_rinv x) )). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). + refine (total2_paths2 (disp_vcomp_linv (_ ,, H1)) (disp_vcomp_linv (_ ,, H2)) @ _). refine (!(transportb_dirprod (g ==> g) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_linv x) )). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). Defined. Definition pair_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} : disp_invertible_2cell x (pr1 ff) (pr1 gg) × disp_invertible_2cell x (pr2 ff) (pr2 gg) → disp_invertible_2cell x ff gg. Proof. intros H. use tpair. - split. + apply H. + apply H. - apply pair_is_disp_invertible_2cell. split. + exact (pr2 (pr1 H)). + exact (pr2 (pr2 H)). Defined. Definition pr1_is_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x xx → is_disp_invertible_2cell x (pr1 xx). Proof. intros H. use tpair. - exact (pr1 (pr1 H)). - split. + refine (maponpaths pr1 (@disp_vcomp_rinv C disp_dirprod_bicat a b f g aa bb x ff gg (_ ,, H)) @ _). cbn. refine (maponpaths pr1 ((transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_rinv x) ))). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). + refine (maponpaths pr1 (@disp_vcomp_linv C disp_dirprod_bicat a b f g aa bb x ff gg (_ ,, H)) @ _). cbn. refine (maponpaths pr1 ((transportb_dirprod (g ==> g) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_linv x) ))). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). Defined. Definition pr1_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) : disp_invertible_2cell x ff gg → disp_invertible_2cell x (pr1 ff) (pr1 gg). Proof. intros H. use tpair. - apply H. - refine (pr1_is_disp_invertible_2cell _ _ _). apply H. Defined. Definition pr2_is_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} {ff : aa -->[ f ] bb} {gg : aa -->[ g ] bb} (xx : ff ==>[ x ] gg) : is_disp_invertible_2cell x xx → is_disp_invertible_2cell x (pr2 xx). Proof. intros H. use tpair. - exact (pr2 (pr1 H)). - split. + refine (maponpaths dirprod_pr2 (@disp_vcomp_rinv C disp_dirprod_bicat a b f g aa bb x ff gg (_ ,, H)) @ _). cbn. refine (maponpaths dirprod_pr2 ((transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_rinv x) ))). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_rinv _) (disp_id2 _)). + refine (maponpaths dirprod_pr2 (@disp_vcomp_linv C disp_dirprod_bicat a b f g aa bb x ff gg (_ ,, H)) @ _). cbn. refine (maponpaths dirprod_pr2 ((transportb_dirprod (g ==> g) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (vcomp_linv x) ))). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (vcomp_linv _) (disp_id2 _)). Defined. Definition pr2_disp_invertible_2cell {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) : disp_invertible_2cell x ff gg → disp_invertible_2cell x (pr2 ff) (pr2 gg). Proof. intros H. use tpair. - apply H. - refine (pr2_is_disp_invertible_2cell _ _ _). apply H. Defined. Definition pair_disp_invertible_2cell_weq {a b : C} {f : a --> b} {g : a --> b} (x : invertible_2cell f g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f ] bb) (gg : aa -->[ g ] bb) : (disp_invertible_2cell x (pr1 ff) (pr1 gg) × disp_invertible_2cell x (pr2 ff) (pr2 gg)) ≃ disp_invertible_2cell x ff gg. Proof. use make_weq. - exact (pair_disp_invertible_2cell x). - use isweq_iso. + intros H. split. * apply pr1_disp_invertible_2cell. exact H. * apply pr2_disp_invertible_2cell. exact H. + intros H ; cbn. use total2_paths2. * use subtypePath. ** intro ; simpl. apply isaprop_is_disp_invertible_2cell. ** reflexivity. * use subtypePath. ** intro ; simpl. apply isaprop_is_disp_invertible_2cell. ** reflexivity. + intros H ; cbn. use subtypePath. * intro xx ; simpl. apply (@isaprop_is_disp_invertible_2cell C disp_dirprod_bicat). * reflexivity. Defined. Definition prod_idtoiso_2_1 {a b : C} {f : a --> b} {g : a --> b} (p : f = g) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[f] bb) (gg : aa -->[g] bb) (HD1 : disp_univalent_2_1 D1) (HD2 : disp_univalent_2_1 D2) : (transportf (λ z : C ⟦ a, b ⟧, aa -->[ z] bb) p ff = gg) ≃ disp_invertible_2cell (idtoiso_2_1 f g p) ff gg. Proof. refine (pair_disp_invertible_2cell_weq (idtoiso_2_1 _ _ p) ff gg ∘ _)%weq. refine (weqdirprodf (_ ,, HD1 a b f g p (pr1 aa) (pr1 bb) (pr1 ff) (pr1 gg)) (_ ,, HD2 a b f g p (pr2 aa) (pr2 bb) (pr2 ff) (pr2 gg)) ∘ _)%weq. induction p ; cbn. apply WeakEquivalences.pathsdirprodweq. Defined. Definition is_univalent_2_1_dirprod_bicat (HD1 : disp_univalent_2_1 D1) (HD2 : disp_univalent_2_1 D2) : disp_univalent_2_1 disp_dirprod_bicat. Proof. intros a b f g p aa bb ff gg. use weqhomot. - exact (prod_idtoiso_2_1 p ff gg HD1 HD2). - intros q. induction p, q. use subtypePath. + intro. apply (@isaprop_is_disp_invertible_2cell C disp_dirprod_bicat). + reflexivity. Defined. (** Global Univalence of the product *) Definition pair_left_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f] bb) : disp_left_adjoint_equivalence f (pr1 ff) × disp_left_adjoint_equivalence f (pr2 ff) → disp_left_adjoint_equivalence f ff. Proof. intros H. use tpair. - use tpair ; repeat split. + exact (disp_left_adjoint_right_adjoint f (pr1 H)). + exact (disp_left_adjoint_right_adjoint f (pr2 H)). + exact (disp_left_adjoint_unit f (pr1 H)). + exact (disp_left_adjoint_unit f (pr2 H)). + exact (disp_left_adjoint_counit f (pr1 H)). + exact (disp_left_adjoint_counit f (pr2 H)). - refine ((_ ,, _) ,, (_ ,, _)) ; cbn. + refine (total2_paths2 (disp_internal_triangle1 _ (pr1 H)) (disp_internal_triangle1 _ (pr2 H)) @ _). refine (!(transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) _ )). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). + refine (total2_paths2 (disp_internal_triangle2 _ (pr1 H)) (disp_internal_triangle2 _ (pr2 H)) @ _). refine (!(transportb_dirprod (_ ==> _) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) _ )). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). + apply (pair_is_disp_invertible_2cell (_ ,, pr1 (pr2 (pr2 (pr2 f))))). split. * apply (pr1 H). * apply (pr2 H). + cbn. apply (pair_is_disp_invertible_2cell (left_adjoint_counit (pr1 (pr2 f)) ,, pr2 (pr2 (pr2 (pr2 f))))). split. * apply (pr1 H). * apply (pr2 H). Defined. Definition pair_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) (aa : disp_dirprod_bicat a) (bb : disp_dirprod_bicat b) : disp_adjoint_equivalence f (pr1 aa) (pr1 bb) × disp_adjoint_equivalence f (pr2 aa) (pr2 bb) → disp_adjoint_equivalence f aa bb. Proof. intros H. use tpair. - split. + apply (pr1 H). + apply (pr2 H). - apply pair_left_adjoint_equivalence. cbn. split. + apply (pr1 H). + apply (pr2 H). Defined. Definition pr1_left_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f] bb) : disp_left_adjoint_equivalence f ff → disp_left_adjoint_equivalence f (pr1 ff). Proof. intros H. use tpair. - use tpair ; repeat split. + exact (pr1 (disp_left_adjoint_right_adjoint f H)). + exact (pr1 (disp_left_adjoint_unit f H)). + exact (pr1 (disp_left_adjoint_counit f H)). - refine ((_ ,, _) ,, (_ ,, _)) ; cbn. + refine (maponpaths pr1 (pr1(pr1(pr2 H))) @ _). refine (maponpaths pr1 ((transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (internal_triangle1 f) ))). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). + refine (maponpaths pr1 (pr2(pr1(pr2 H))) @ _). refine (maponpaths pr1 ((transportb_dirprod (_ ==> _) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) _ ))). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). + apply (pr1_is_disp_invertible_2cell (left_adjoint_unit f ,, pr1 (pr2 (pr2 (pr2 f)))) (disp_left_adjoint_unit (pr1 (pr2 f)) (pr1 H)) ). apply H. + apply (pr1_is_disp_invertible_2cell (left_adjoint_counit f ,, pr2 (pr2 (pr2 (pr2 f)))) (disp_left_adjoint_counit (pr1 (pr2 f)) (pr1 H)) ). apply H. Defined. Definition pr1_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) (aa : disp_dirprod_bicat a) (bb : disp_dirprod_bicat b) : disp_adjoint_equivalence f aa bb → disp_adjoint_equivalence f (pr1 aa) (pr1 bb). Proof. intros H. use tpair. - apply H. - apply pr1_left_adjoint_equivalence. apply H. Defined. Definition pr2_left_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) {aa : disp_dirprod_bicat a} {bb : disp_dirprod_bicat b} (ff : aa -->[ f] bb) : disp_left_adjoint_equivalence f ff → disp_left_adjoint_equivalence f (pr2 ff). Proof. intros H. use tpair. - use tpair ; repeat split. + exact (pr2 (disp_left_adjoint_right_adjoint f H)). + exact (pr2 (disp_left_adjoint_unit f H)). + exact (pr2 (disp_left_adjoint_counit f H)). - refine ((_ ,, _) ,, (_ ,, _)) ; cbn. + refine (maponpaths dirprod_pr2 (pr1(pr1(pr2 H))) @ _). refine (maponpaths dirprod_pr2 ((transportb_dirprod (f ==> f) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (internal_triangle1 f) ))). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle1 f) (disp_id2 _)). + refine (maponpaths dirprod_pr2 (pr2(pr1(pr2 H))) @ _). refine (maponpaths dirprod_pr2 ((transportb_dirprod (_ ==> _) (λ α, _ ==>[α] _) (λ α, _ ==>[α] _) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) _ ))). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). * exact (transportb (λ z, _ ==>[z] _) (internal_triangle2 f) (disp_id2 _)). + apply (pr2_is_disp_invertible_2cell (left_adjoint_unit f ,, pr1 (pr2 (pr2 (pr2 f)))) (disp_left_adjoint_unit (pr1 (pr2 f)) (pr1 H)) ). apply H. + apply (pr2_is_disp_invertible_2cell (left_adjoint_counit f ,, pr2 (pr2 (pr2 (pr2 f)))) (disp_left_adjoint_counit (pr1 (pr2 f)) (pr1 H)) ). apply H. Defined. Definition pr2_adjoint_equivalence {a b : C} (f : adjoint_equivalence a b) (aa : disp_dirprod_bicat a) (bb : disp_dirprod_bicat b) : disp_adjoint_equivalence f aa bb → disp_adjoint_equivalence f (pr2 aa) (pr2 bb). Proof. intros H. use tpair. - apply H. - apply pr2_left_adjoint_equivalence. apply H. Defined. Definition pair_adjoint_equivalence_weq {a b : C} (HC : is_univalent_2_1 C) (HD1 : disp_univalent_2_1 D1) (HD2 : disp_univalent_2_1 D2) (f : adjoint_equivalence a b) (aa : disp_dirprod_bicat a) (bb : disp_dirprod_bicat b) : (disp_adjoint_equivalence f (pr1 aa) (pr1 bb) × disp_adjoint_equivalence f (pr2 aa) (pr2 bb)) ≃ (disp_adjoint_equivalence f aa bb). Proof. use tpair. - exact (pair_adjoint_equivalence f aa bb). - use isweq_iso. + intros H. split. * exact (pr1_adjoint_equivalence f aa bb H). * exact (pr2_adjoint_equivalence f aa bb H). + intros A. use total2_paths2. * use subtypePath. ** intro ; simpl. apply isaprop_disp_left_adjoint_equivalence. *** exact HC. *** exact HD1. ** reflexivity. * use subtypePath. ** intro ; simpl. apply isaprop_disp_left_adjoint_equivalence. *** exact HC. *** exact HD2. ** reflexivity. + intros H ; cbn. use subtypePath. * intro xx ; simpl. apply (@isaprop_disp_left_adjoint_equivalence C disp_dirprod_bicat). ** exact HC. ** exact (is_univalent_2_1_dirprod_bicat HD1 HD2). * reflexivity. Defined. Definition prod_idtoiso_2_0 (HC : is_univalent_2_1 C) (HD1 : disp_univalent_2 D1) (HD2 : disp_univalent_2 D2) {a b : C} (p : a = b) (aa : disp_dirprod_bicat a) (bb : disp_dirprod_bicat b) : (transportf (λ z : C, disp_dirprod_bicat z) p aa = bb) ≃ disp_adjoint_equivalence (idtoiso_2_0 a b p) aa bb. Proof. refine (pair_adjoint_equivalence_weq HC (pr2 HD1) (pr2 HD2) (idtoiso_2_0 _ _ p) aa bb ∘ _)%weq. refine (weqdirprodf (_ ,, pr1 HD1 a b p (pr1 aa) (pr1 bb)) (_ ,, pr1 HD2 a b p (pr2 aa) (pr2 bb)) ∘ _)%weq. induction p ; cbn. apply WeakEquivalences.pathsdirprodweq. Defined. Definition is_univalent_2_0_dirprod_bicat (HC : is_univalent_2_1 C) (HD1 : disp_univalent_2 D1) (HD2 : disp_univalent_2 D2) : disp_univalent_2_0 disp_dirprod_bicat. Proof. intros a b p aa bb. use weqhomot. - exact (prod_idtoiso_2_0 HC HD1 HD2 p aa bb). - intros q. induction p, q. use subtypePath. + intro. apply (@isaprop_disp_left_adjoint_equivalence C disp_dirprod_bicat). * exact HC. * exact (is_univalent_2_1_dirprod_bicat (pr2 HD1) (pr2 HD2)). + reflexivity. Defined. Definition is_univalent_2_dirprod_bicat (HC : is_univalent_2_1 C) (HD1 : disp_univalent_2 D1) (HD2 : disp_univalent_2 D2) : disp_univalent_2 disp_dirprod_bicat. Proof. split. - apply is_univalent_2_0_dirprod_bicat; assumption. - apply is_univalent_2_1_dirprod_bicat. * exact (pr2 HD1). * exact (pr2 HD2). Defined. Definition is_univalent_2_1_total_dirprod (HC : is_univalent_2_1 C) (HD1 : disp_univalent_2_1 D1) (HD2 : disp_univalent_2_1 D2) : is_univalent_2_1 (total_bicat disp_dirprod_bicat). Proof. apply total_is_univalent_2_1. - exact HC. - apply is_univalent_2_1_dirprod_bicat. * exact HD1. * exact HD2. Defined. Definition is_univalent_2_0_total_dirprod (HC : is_univalent_2 C) (HD1 : disp_univalent_2 D1) (HD2 : disp_univalent_2 D2) : is_univalent_2_0 (total_bicat disp_dirprod_bicat). Proof. apply total_is_univalent_2_0. - exact (pr1 HC). - apply is_univalent_2_0_dirprod_bicat. + exact (pr2 HC). + exact HD1. + exact HD2. Defined. Definition is_univalent_2_total_dirprod (HC : is_univalent_2 C) (HD1 : disp_univalent_2 D1) (HD2 : disp_univalent_2 D2) : is_univalent_2 (total_bicat disp_dirprod_bicat). Proof. split. - apply is_univalent_2_0_total_dirprod; assumption. - apply is_univalent_2_1_total_dirprod. * exact (pr2 HC). * exact (pr2 HD1). * exact (pr2 HD2). Defined. Definition disp_2cells_isaprop_prod (HD1 : disp_2cells_isaprop D1) (HD2 : disp_2cells_isaprop D2) : disp_2cells_isaprop disp_dirprod_bicat. Proof. intro; intros. apply isapropdirprod. - apply HD1. - apply HD2. Qed. Definition disp_locally_groupoid_prod (HD1 : disp_locally_groupoid D1) (HD2 : disp_locally_groupoid D2) : disp_locally_groupoid disp_dirprod_bicat. Proof. intros a b f g x aa bb ff gg xx. apply pair_is_disp_invertible_2cell. split. - apply HD1. - apply HD2. Qed. End Disp_Dirprod. (** Invertible 2-cells in the total bicategory *) Definition pr1_dirprod_invertible_2cell {B : bicat} (D₁ D₂ : disp_bicat B) {x y : total_bicat (disp_dirprod_bicat D₁ D₂)} {f g : x --> y} (α : invertible_2cell f g) : @invertible_2cell (total_bicat D₁) (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g). Proof. use make_invertible_2cell. - exact (pr11 α ,, pr121 α). - use make_is_invertible_2cell. + exact (pr1 (α^-1) ,, pr12 (α^-1)). + abstract (use total2_paths_f ; [ apply (maponpaths pr1 (vcomp_rinv α)) | ] ; cbn ; refine (_ @ maponpaths pr1 (fiber_paths (vcomp_rinv α))) ; refine (!_) ; apply (@pr1_transportf (pr1 f ==> pr1 f) (λ z, pr12 f ==>[ z ] pr12 f) (λ z _, pr22 f ==>[ z ] pr22 f))). + abstract (use total2_paths_f ; [ apply (maponpaths pr1 (vcomp_linv α)) | ] ; cbn ; refine (_ @ maponpaths pr1 (fiber_paths (vcomp_linv α))) ; refine (!_) ; apply (@pr1_transportf (pr1 g ==> pr1 g) (λ z, pr12 g ==>[ z ] pr12 g) (λ z _, pr22 g ==>[ z ] pr22 g))). Defined. Definition pr2_dirprod_invertible_2cell {B : bicat} (D₁ D₂ : disp_bicat B) {x y : total_bicat (disp_dirprod_bicat D₁ D₂)} {f g : x --> y} (α : invertible_2cell f g) : @invertible_2cell (total_bicat D₂) (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g). Proof. use make_invertible_2cell. - exact (pr11 α ,, pr221 α). - use make_is_invertible_2cell. + exact (pr1 (α^-1) ,, pr22 (α^-1)). + abstract (use total2_paths_f ; [ apply (maponpaths pr1 (vcomp_rinv α)) | ] ; cbn ; refine (_ @ maponpaths dirprod_pr2 (fiber_paths (vcomp_rinv α))) ; refine (!_) ; apply (@pr2_transportf (pr1 f ==> pr1 f) (λ z, pr12 f ==>[ z ] pr12 f) (λ z, pr22 f ==>[ z ] pr22 f))). + abstract (use total2_paths_f ; [ apply (maponpaths pr1 (vcomp_linv α)) | ] ; cbn ; refine (_ @ maponpaths dirprod_pr2 (fiber_paths (vcomp_linv α))) ; refine (!_) ; apply (@pr2_transportf (pr1 g ==> pr1 g) (λ z, pr12 g ==>[ z ] pr12 g) (λ z, pr22 g ==>[ z ] pr22 g))). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Sigma.v000066400000000000000000001121001451125700300253200ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 Dependent sum of displayed bicategories ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition make_total_ob {C : bicat} {D : disp_bicat C} {a : C} (aa : D a) : total_bicat D := (a,, aa). Definition make_total_mor {C : bicat} {D : disp_bicat C} {a b : C} {f : C⟦a, b⟧} {aa : D a} {bb : D b} (ff : aa -->[f] bb) : make_total_ob aa --> make_total_ob bb := (f,, ff). Definition make_total_cell {C : bicat} {D : disp_bicat C} {a b : C} {f g : C⟦a, b⟧} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} (η : f ==> g) (ηη : ff ==>[η] gg) : (make_total_mor ff) ==> (make_total_mor gg) := (η,, ηη). (* Useful? *) Lemma total_cell_eq {C : bicat} {D : disp_bicat C} {a b : C} {f g : C⟦a, b⟧} {aa : D a} {bb : D b} {ff : aa -->[f] bb} {gg : aa -->[g] bb} (x y : make_total_mor ff ==> make_total_mor gg) (e : pr1 x = pr1 y) (ee : pr2 x = transportb (λ η : f ==> g, ff ==>[ η] gg) e (pr2 y)) : x = y. Proof. exact (total2_paths2_b e ee). Defined. Section Sigma. Variable (C : bicat) (D : disp_bicat C) (E : disp_bicat (total_bicat D)). Definition sigma_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. exists (λ c, ∑ (d : D c), (E (c,,d))). intros x y xx yy f. exact (∑ (fD : pr1 xx -->[f] pr1 yy), pr2 xx -->[f,,fD] pr2 yy). Defined. Definition sigma_disp_cat_id_comp : disp_cat_id_comp _ sigma_disp_cat_ob_mor. Proof. apply tpair. - intros x xx. exists (id_disp _). exact (id_disp (pr2 xx)). - intros x y z f g xx yy zz ff gg. exists (pr1 ff ;; pr1 gg). exact (pr2 ff ;; pr2 gg). Defined. Definition sigma_disp_cat_data : disp_cat_data C := (_ ,, sigma_disp_cat_id_comp). Definition sigma_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells C. Proof. exists sigma_disp_cat_data. red. intros c c' f g x d d' ff gg. cbn in *. use (∑ xx : pr1 ff ==>[x] pr1 gg , _). set (PPP := @prebicat_cells (total_bicat D) (c,, pr1 d) (c',, pr1 d') (f,, pr1 ff) (g,, pr1 gg)). exact (pr2 ff ==>[(x,, xx) : PPP] pr2 gg). Defined. Definition sigma_bicat_data : disp_prebicat_data C. Proof. exists sigma_prebicat_1_id_comp_cells. repeat split; cbn; first [intros * | intros]. - exists (disp_id2 _). exact (disp_id2 _). - exists (disp_lunitor (pr1 f')). exact (disp_lunitor (pr2 f')). - exists (disp_runitor (pr1 f')). exact (disp_runitor (pr2 f')). - exists (disp_linvunitor (pr1 f')). exact (disp_linvunitor (pr2 f')). - exists (disp_rinvunitor (pr1 f')). exact (disp_rinvunitor (pr2 f')). - exists (disp_rassociator (pr1 ff) (pr1 gg) (pr1 hh)). exact (disp_rassociator (pr2 ff) (pr2 gg) (pr2 hh)). - exists (disp_lassociator (pr1 ff) (pr1 gg) (pr1 hh)). exact (disp_lassociator (pr2 ff) (pr2 gg) (pr2 hh)). - intros xx yy. exists (disp_vcomp2 (pr1 xx) (pr1 yy)). exact (disp_vcomp2 (pr2 xx) (pr2 yy)). - intros xx. exists (disp_lwhisker (pr1 ff) (pr1 xx)). exact (disp_lwhisker (pr2 ff) (pr2 xx)). - intros xx. exists (disp_rwhisker (pr1 gg) (pr1 xx)). exact (disp_rwhisker (pr2 gg) (pr2 xx)). Defined. (* Needed? *) Lemma total_sigma_cell_eq {a b : total_bicat E} {f g : total_bicat E ⟦a,b⟧} (x y : f ==> g) (eq1 : pr1 x = pr1 y) (eq2 : pr2 x = transportb (λ z, pr2 f ==>[z] pr2 g) eq1 (pr2 y)) : x = y. Proof. induction x as (x, xx). induction y as (y, yy). cbn in *. induction eq1. cbn in *. apply pair_path_in2. exact eq2. Defined. Lemma sigma_prebicat_laws : disp_prebicat_laws sigma_bicat_data. Proof. repeat split; red; cbn; intros *; use (@total2_reassoc_paths' (_ ==> _) (fun x' => _ ==>[ x'] _) (fun x'xx => _ ==>[ make_total_cell (pr1 x'xx) (pr2 x'xx)] _)); cbn. - apply disp_id2_left. - apply (disp_id2_left (pr2 ηη)). - apply disp_id2_right. - apply (disp_id2_right (pr2 ηη)). - apply disp_vassocr. - apply (disp_vassocr (pr2 ηη) (pr2 φφ) (pr2 ψψ)). - apply disp_lwhisker_id2. - apply (disp_lwhisker_id2 (pr2 ff) (pr2 gg)). - apply disp_id2_rwhisker. - apply (disp_id2_rwhisker (pr2 ff) (pr2 gg)). - apply disp_lwhisker_vcomp. - apply (disp_lwhisker_vcomp (ff := (pr2 ff)) (pr2 ηη) (pr2 φφ)). - apply disp_rwhisker_vcomp. - apply (disp_rwhisker_vcomp (ii := pr2 ii) (pr2 ηη) (pr2 φφ)). - apply disp_vcomp_lunitor. - apply (disp_vcomp_lunitor (pr2 ηη)). - apply disp_vcomp_runitor. - apply (disp_vcomp_runitor (pr2 ηη)). - apply disp_lwhisker_lwhisker. - apply (disp_lwhisker_lwhisker (pr2 ff) (pr2 gg) (pr2 ηη)). - apply disp_rwhisker_lwhisker. - apply (disp_rwhisker_lwhisker (pr2 ff) (pr2 ii) (pr2 ηη)). - apply disp_rwhisker_rwhisker. - apply (disp_rwhisker_rwhisker _ _ (pr2 hh) (pr2 ii) (pr2 ηη)). - apply disp_vcomp_whisker. - apply (disp_vcomp_whisker _ _ _ _ _ (pr2 ff) (pr2 gg) (pr2 hh) (pr2 ii) (pr2 ηη) (pr2 φφ)). - apply disp_lunitor_linvunitor. - apply (disp_lunitor_linvunitor (pr2 ff)). - apply disp_linvunitor_lunitor. - apply (disp_linvunitor_lunitor (pr2 ff)). - apply disp_runitor_rinvunitor. - apply (disp_runitor_rinvunitor (pr2 ff)). - apply disp_rinvunitor_runitor. - apply (disp_rinvunitor_runitor (pr2 ff)). - apply disp_lassociator_rassociator. - apply (disp_lassociator_rassociator (pr2 ff) (pr2 gg) (pr2 hh)). - apply disp_rassociator_lassociator. - apply (disp_rassociator_lassociator _ (pr2 ff) (pr2 gg) (pr2 hh)). - apply disp_runitor_rwhisker. - apply (disp_runitor_rwhisker (pr2 ff) (pr2 gg)). - apply disp_lassociator_lassociator. - apply (disp_lassociator_lassociator (pr2 ff) (pr2 gg) (pr2 hh) (pr2 ii)). Qed. Definition sigma_prebicat : disp_prebicat C := sigma_bicat_data,, sigma_prebicat_laws. Lemma has_disp_cellset_sigma_prebicat : has_disp_cellset sigma_prebicat. Proof. red; cbn; intros. apply isaset_total2. - apply disp_cellset_property. - intros. apply disp_cellset_property. Qed. Definition sigma_bicat : disp_bicat C := sigma_prebicat,, has_disp_cellset_sigma_prebicat. Definition disp_2cells_isaprop_sigma (HD : disp_2cells_isaprop D) (HE : disp_2cells_isaprop E) : disp_2cells_isaprop sigma_bicat. Proof. intro; intros. apply isaproptotal2. - intro; apply HE. - intros; apply HD. Qed. End Sigma. Section SigmaTotalUnivalent. Context {C : bicat} {D₁ : disp_bicat C} (D₂ : disp_bicat (total_bicat D₁)). Local Notation E₁ := (total_bicat D₂). Local Notation E₂ := (total_bicat (sigma_bicat C D₁ D₂)). Definition E₁_univalent_2_0 (HC_2_0 : is_univalent_2_0 C) (HD₁_2_0 : disp_univalent_2_0 D₁) (HD₂_2_0 : disp_univalent_2_0 D₂) : is_univalent_2_0 E₁. Proof. apply total_is_univalent_2_0. - apply total_is_univalent_2_0. + exact HC_2_0. + exact HD₁_2_0. - exact HD₂_2_0. Defined. Definition E₁_univalent_2_1 (HC_2_1 : is_univalent_2_1 C) (HD₁_2_1 : disp_univalent_2_1 D₁) (HD₂_2_1 : disp_univalent_2_1 D₂) : is_univalent_2_1 E₁. Proof. apply total_is_univalent_2_1. - apply total_is_univalent_2_1. + exact HC_2_1. + exact HD₁_2_1. - exact HD₂_2_1. Defined. Definition E₁_to_E₂ : E₁ → E₂ := λ x, (pr11 x ,, (pr21 x ,, pr2 x)). Definition E₂_to_E₁ : E₂ → E₁ := λ x, ((pr1 x ,, pr12 x) ,, pr22 x). Definition E₂_to_E₁_weq : E₂ ≃ E₁. Proof. use make_weq. - exact E₂_to_E₁. - use isweq_iso. + exact E₁_to_E₂. + apply idpath. + apply idpath. Defined. Definition path_E₂_to_path_E₁_weq (x y : E₂) : x = y ≃ E₂_to_E₁ x = E₂_to_E₁ y. Proof. use make_weq. - exact (maponpaths E₂_to_E₁). - exact (isweqmaponpaths E₂_to_E₁_weq x y). Defined. Definition mor_E₁_to_E₂ {x y : E₁} : x --> y → E₁_to_E₂ x --> E₁_to_E₂ y := λ f, (pr11 f ,, (pr21 f ,, pr2 f)). Definition mor_E₂_to_E₁ {x y : E₂} : x --> y → E₂_to_E₁ x --> E₂_to_E₁ y := λ f, ((pr1 f ,, pr12 f) ,, pr22 f). Definition mor_E₂_to_E₁_weq {x y : E₂} : x --> y ≃ E₂_to_E₁ x --> E₂_to_E₁ y. Proof. use make_weq. - exact mor_E₂_to_E₁. - use isweq_iso. + exact mor_E₁_to_E₂. + apply idpath. + apply idpath. Defined. Definition path_mor_E₂_to_path_mor_E₁_weq {x y : E₂} (f g : x --> y) : f = g ≃ mor_E₂_to_E₁ f = mor_E₂_to_E₁ g. Proof. use make_weq. - exact (maponpaths mor_E₂_to_E₁). - exact (isweqmaponpaths mor_E₂_to_E₁_weq f g). Defined. Definition cell_E₁_to_E₂ {x y : E₁} {f g : x --> y} : f ==> g → mor_E₁_to_E₂ f ==> mor_E₁_to_E₂ g := λ α, (pr11 α ,, (pr21 α ,, pr2 α)). Definition cell_E₂_to_E₁ {x y : E₂} {f g : x --> y} : f ==> g → mor_E₂_to_E₁ f ==> mor_E₂_to_E₁ g := λ α, ((pr1 α ,, pr12 α) ,, pr22 α). Definition cell_E₁_to_E₂_id₂ {x y : E₁} (f : x --> y) : cell_E₁_to_E₂ (id₂ f) = id₂ (mor_E₁_to_E₂ f) := idpath _. Definition cell_E₂_to_E₁_id₂ {x y : E₂} (f : x --> y) : cell_E₂_to_E₁ (id₂ f) = id₂ (mor_E₂_to_E₁ f) := idpath _. Definition cell_E₁_to_E₂_vcomp {x y : E₁} {f g h : x --> y} (α : f ==> g) (β : g ==> h) : cell_E₁_to_E₂ α • cell_E₁_to_E₂ β = cell_E₁_to_E₂ (α • β) := idpath _. Definition cell_E₂_to_E₁_vcomp {x y : E₂} {f g h : x --> y} (α : f ==> g) (β : g ==> h) : cell_E₂_to_E₁ α • cell_E₂_to_E₁ β = cell_E₂_to_E₁ (α • β) := idpath _. Definition cell_E₁_to_E₂_is_invertible {x y : E₁} {f g : x --> y} (α : f ==> g) : is_invertible_2cell α → is_invertible_2cell (cell_E₁_to_E₂ α). Proof. intros Hα. use tpair. - exact (cell_E₁_to_E₂ (Hα^-1)). - split. + exact ((cell_E₁_to_E₂_vcomp α (Hα^-1)) @ maponpaths cell_E₁_to_E₂ (pr12 Hα) @ cell_E₁_to_E₂_id₂ _). + exact ((cell_E₁_to_E₂_vcomp (Hα^-1) α) @ maponpaths cell_E₁_to_E₂ (pr22 Hα) @ cell_E₁_to_E₂_id₂ _). Defined. Definition cell_E₂_to_E₁_is_invertible {x y : E₂} {f g : x --> y} (α : f ==> g) : is_invertible_2cell α → is_invertible_2cell (cell_E₂_to_E₁ α). Proof. intros Hα. use tpair. - exact (cell_E₂_to_E₁ (Hα^-1)). - split. + exact ((cell_E₂_to_E₁_vcomp α (Hα^-1)) @ maponpaths cell_E₂_to_E₁ (pr12 Hα) @ cell_E₂_to_E₁_id₂ _). + exact ((cell_E₂_to_E₁_vcomp (Hα^-1) α) @ maponpaths cell_E₂_to_E₁ (pr22 Hα) @ cell_E₂_to_E₁_id₂ _). Defined. Definition iso_in_E₂ {x y : E₂} (f g : x --> y) : invertible_2cell (mor_E₂_to_E₁ f) (mor_E₂_to_E₁ g) → invertible_2cell f g. Proof. intros α. use tpair. - exact (cell_E₁_to_E₂ (cell_from_invertible_2cell α)). - use tpair. + exact (cell_E₁_to_E₂ (α^-1)). + split. * exact ((cell_E₁_to_E₂_vcomp α (α^-1)) @ maponpaths cell_E₁_to_E₂ (pr122 α) @ cell_E₁_to_E₂_id₂ (mor_E₂_to_E₁ f)). * exact ((cell_E₁_to_E₂_vcomp (α^-1) α) @ maponpaths cell_E₁_to_E₂ (pr222 α) @ cell_E₁_to_E₂_id₂ (mor_E₂_to_E₁ g)). Defined. Definition iso_in_E₂_inv {x y : E₂} (f g : x --> y) : invertible_2cell f g → invertible_2cell (mor_E₂_to_E₁ f) (mor_E₂_to_E₁ g). Proof. intros α. use tpair. - exact (cell_E₂_to_E₁ (cell_from_invertible_2cell α)). - use tpair. + exact (cell_E₂_to_E₁ (α^-1)). + split. * exact ((cell_E₂_to_E₁_vcomp α (α^-1)) @ maponpaths cell_E₂_to_E₁ (pr122 α) @ cell_E₂_to_E₁_id₂ _). * exact ((cell_E₂_to_E₁_vcomp (α^-1) α) @ maponpaths cell_E₂_to_E₁ (pr222 α) @ cell_E₂_to_E₁_id₂ _). Defined. Definition iso_in_E₂_weq {x y : E₂} (f g : x --> y) : invertible_2cell (mor_E₂_to_E₁ f) (mor_E₂_to_E₁ g) ≃ invertible_2cell f g. Proof. use make_weq. - exact (iso_in_E₂ f g). - use isweq_iso. + exact (iso_in_E₂_inv f g). + intros α. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } apply idpath. + intros α. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } apply idpath. Defined. Definition idtoiso_2_1_alt_E₂ {x y : E₂} (f g : x --> y) (HC_2_1 : is_univalent_2_1 C) (HD₁_2_1 : disp_univalent_2_1 D₁) (HD₂_2_1 : disp_univalent_2_1 D₂) : f = g ≃ invertible_2cell f g. Proof. refine ((iso_in_E₂_weq f g) ∘ (idtoiso_2_1 _ _ ,, _) ∘ path_mor_E₂_to_path_mor_E₁_weq f g)%weq. apply E₁_univalent_2_1; assumption. Defined. Definition sigma_is_univalent_2_1 (HC_2_1 : is_univalent_2_1 C) (HD₁_2_1 : disp_univalent_2_1 D₁) (HD₂_2_1 : disp_univalent_2_1 D₂) : is_univalent_2_1 E₂. Proof. intros x y f g. use weqhomot. - exact (idtoiso_2_1_alt_E₂ f g HC_2_1 HD₁_2_1 HD₂_2_1). - intros p. induction p ; cbn. use subtypePath. { intro. apply (@isaprop_is_invertible_2cell (total_bicat (sigma_bicat C D₁ D₂))). } apply idpath. Defined. Definition adjequiv_in_E₂ (x y : E₂) : adjoint_equivalence (E₂_to_E₁ x) (E₂_to_E₁ y) → adjoint_equivalence x y. Proof. intros l. use equiv_to_adjequiv. - exact (mor_E₁_to_E₂ l). - use tpair. + use tpair. * exact (mor_E₁_to_E₂ (left_adjoint_right_adjoint l)). * split. ** exact (cell_E₁_to_E₂ (left_adjoint_unit l)). ** exact (cell_E₁_to_E₂ (left_adjoint_counit l)). + split. * exact (cell_E₁_to_E₂_is_invertible _ (left_equivalence_unit_iso l)). * exact (cell_E₁_to_E₂_is_invertible _ (left_equivalence_counit_iso l)). Defined. Definition adjequiv_in_E₂_inv (x y : E₂) : adjoint_equivalence x y → adjoint_equivalence (E₂_to_E₁ x) (E₂_to_E₁ y). Proof. intros l. use equiv_to_adjequiv. - exact (mor_E₂_to_E₁ l). - use tpair. + use tpair. * exact (mor_E₂_to_E₁ (left_adjoint_right_adjoint l)). * split. ** exact (cell_E₂_to_E₁ (left_adjoint_unit l)). ** exact (cell_E₂_to_E₁ (left_adjoint_counit l)). + split. * exact (cell_E₂_to_E₁_is_invertible _ (left_equivalence_unit_iso l)). * exact (cell_E₂_to_E₁_is_invertible _ (left_equivalence_counit_iso l)). Defined. Definition adjequiv_in_E₂_weq (x y : E₂) (HC_2_1 : is_univalent_2_1 C) (HD₁_2_1 : disp_univalent_2_1 D₁) (HD₂_2_1 : disp_univalent_2_1 D₂) : adjoint_equivalence (E₂_to_E₁ x) (E₂_to_E₁ y) ≃ adjoint_equivalence x y. Proof. use make_weq. - exact (adjequiv_in_E₂ x y). - use isweq_iso. + exact (adjequiv_in_E₂_inv x y). + intros l. use subtypePath. { intro. apply isaprop_left_adjoint_equivalence. apply E₁_univalent_2_1; assumption. } apply idpath. + intros l. use subtypePath. { intro. apply isaprop_left_adjoint_equivalence. apply sigma_is_univalent_2_1; assumption. } apply idpath. Defined. Definition idtoiso_2_0_alt_E₂ (x y : E₂) (HC : is_univalent_2 C) (HD₁ : disp_univalent_2 D₁) (HD₂ : disp_univalent_2 D₂) : x = y ≃ adjoint_equivalence x y. Proof. refine ((adjequiv_in_E₂_weq x y (pr2 HC) (pr2 HD₁) (pr2 HD₂)) ∘ (idtoiso_2_0 _ _ ,, _) ∘ path_E₂_to_path_E₁_weq x y)%weq. apply E₁_univalent_2_0. - exact (pr1 HC). - exact (pr1 HD₁). - exact (pr1 HD₂). Defined. Definition sigma_is_univalent_2_0 (HC : is_univalent_2 C) (HD₁ : disp_univalent_2 D₁) (HD₂ : disp_univalent_2 D₂) : is_univalent_2_0 E₂. Proof. intros x y. use weqhomot. - exact (idtoiso_2_0_alt_E₂ x y HC HD₁ HD₂). - intros p. induction p. use subtypePath. { intro. apply isaprop_left_adjoint_equivalence. apply sigma_is_univalent_2_1. - exact (pr2 HC). - exact (pr2 HD₁). - exact (pr2 HD₂). } reflexivity. Defined. Definition sigma_is_univalent_2 (HC : is_univalent_2 C) (HD₁ : disp_univalent_2 D₁) (HD₂ : disp_univalent_2 D₂) : is_univalent_2 E₂. Proof. split. - apply sigma_is_univalent_2_0; assumption. - apply sigma_is_univalent_2_1. * exact (pr2 HC). * exact (pr2 HD₁). * exact (pr2 HD₂). Defined. End SigmaTotalUnivalent. Definition help_disp_left_adjoint_axioms {C : bicat} (D : disp_bicat C) (HD : disp_2cells_isaprop D) {x y : C} {f : x --> y} (Af : left_adjoint f) {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {Aff : disp_left_adjoint_data Af ff} : disp_left_adjoint_axioms Af Aff. Proof. split ; apply HD. Qed. Definition transportf_subtypePath {A : UU} {P : A → UU} (Pprop : ∏ (a : A), isaprop (P a)) {C : total2 P → UU} (x : A) (P₁ P₂ : P x) (y : C (x,,P₂)) : transportf (λ (z : total2 P), C z) (!(@subtypePath A P Pprop (x ,, P₁) (x ,, P₂) (idpath x))) y = transportf (λ (p : P x), C (x,, p)) (!(pr1 (Pprop x P₁ P₂))) y. Proof. cbn. induction (Pprop x P₁ P₂) as [p q]. induction p. apply idpath. Defined. Section SigmaDisplayedUnivalent. Context {C : bicat} {D₁ : disp_bicat C} (D₂ : disp_bicat (total_bicat D₁)). Variable (HC : is_univalent_2 C) (HD₁ : disp_2cells_isaprop D₁) (HD₂ : disp_2cells_isaprop D₂) (HD₁_2_1 : disp_univalent_2_1 D₁) (HD₂_2_1 : disp_univalent_2_1 D₂). Definition pair_disp_invertible_to_sigma_disp_invertible {x y : C} {f : C ⟦ x, y ⟧} {xx : (sigma_bicat C D₁ D₂) x} {yy : (sigma_bicat C D₁ D₂) y} {ff1 : pr1 xx -->[ f] pr1 yy} (ff2 : pr2 xx -->[ f,, ff1] pr2 yy) {gg1 : pr1 xx -->[ f] pr1 yy} (gg2 : pr2 xx -->[ f,, gg1] pr2 yy) : (∑ (p : disp_invertible_2cell (id2_invertible_2cell f) ff1 gg1), disp_invertible_2cell (iso_in_E_weq _ _ (id2_invertible_2cell f ,, p)) ff2 gg2) → @disp_invertible_2cell C (sigma_prebicat C D₁ D₂) _ _ _ _ _ _ (id2_invertible_2cell f) (ff1,, ff2) (gg1,, gg2). Proof. intros p. use tpair. - exact (pr11 p ,, pr12 p). - simpl. simple refine (_ ,, (_ ,, _)). + exact (disp_inv_cell (pr1 p) ,, disp_inv_cell (pr2 p)). + apply disp_2cells_isaprop_sigma ; assumption. + apply disp_2cells_isaprop_sigma ; assumption. Defined. Definition disp_locally_groupoid_sigma (LG₁ : disp_locally_groupoid D₁) (LG₂ : disp_locally_groupoid D₂) : disp_locally_groupoid (sigma_bicat C D₁ D₂). Proof. use make_disp_locally_groupoid_univalent_2_1. - intros a b f aa bb ff gg xx. pose (p₁ := pr1 xx ,, LG₁ _ _ _ _ _ _ _ _ _ (pr1 xx) : disp_invertible_2cell _ _ _). pose (pr2 xx) as m. cbn in m. pose (p₂ := pr2 xx ,, LG₂ (a ,, pr1 aa) (b ,, pr1 bb) (f ,, pr1 ff) (f ,, pr1 gg) (iso_in_E_weq _ _ (id2_invertible_2cell f ,, p₁)) (pr2 aa) (pr2 bb) (pr2 ff) (pr2 gg) m). exact (pr2 (pair_disp_invertible_to_sigma_disp_invertible _ _ (p₁ ,, p₂))). - exact (pr2 HC). Defined. Definition sigma_disp_invertible_to_pair_disp_invertible {x y : C} {f : C ⟦ x, y ⟧} {xx : (sigma_bicat C D₁ D₂) x} {yy : (sigma_bicat C D₁ D₂) y} {ff1 : pr1 xx -->[ f] pr1 yy} (ff2 : pr2 xx -->[ f,, ff1] pr2 yy) {gg1 : pr1 xx -->[ f] pr1 yy} (gg2 : pr2 xx -->[ f,, gg1] pr2 yy) : @disp_invertible_2cell C (sigma_prebicat C D₁ D₂) _ _ _ _ _ _ (id2_invertible_2cell f) (ff1,, ff2) (gg1,, gg2) → (∑ (p : disp_invertible_2cell (id2_invertible_2cell f) ff1 gg1), disp_invertible_2cell (iso_in_E_weq _ _ (id2_invertible_2cell f ,, p)) ff2 gg2). Proof. intros p. use tpair. - use tpair. + exact (pr11 p). + simple refine (_ ,, (_ ,, _)). * exact (pr1 (disp_inv_cell p)). * apply HD₁. * apply HD₁. - use tpair. + exact (pr21 p). + simple refine (_ ,, (_ ,, _)). * exact (pr2 (disp_inv_cell p)). * apply HD₂. * apply HD₂. Defined. Definition pair_disp_invertible_to_sigma_disp_invertible_weq {x y : C} {f : C ⟦ x, y ⟧} {xx : (sigma_bicat C D₁ D₂) x} {yy : (sigma_bicat C D₁ D₂) y} {ff1 : pr1 xx -->[ f] pr1 yy} (ff2 : pr2 xx -->[ f,, ff1] pr2 yy) {gg1 : pr1 xx -->[ f] pr1 yy} (gg2 : pr2 xx -->[ f,, gg1] pr2 yy) : (∑ (p : disp_invertible_2cell (id2_invertible_2cell f) ff1 gg1), disp_invertible_2cell (iso_in_E_weq _ _ (id2_invertible_2cell f ,, p)) ff2 gg2) ≃ @disp_invertible_2cell C (sigma_prebicat C D₁ D₂) _ _ _ _ _ _ (id2_invertible_2cell f) (ff1,, ff2) (gg1,, gg2). Proof. use make_weq. - apply pair_disp_invertible_to_sigma_disp_invertible. - use isweq_iso. + apply sigma_disp_invertible_to_pair_disp_invertible. + intro p. induction p as [p1 p2]. use total2_paths_b. * use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. * use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply HD₂. + intro p. use subtypePath. { intro ; apply (@isaprop_is_disp_invertible_2cell C (sigma_bicat C D₁ D₂)). } apply idpath. Defined. Definition sigma_disp_univalent_2_1_with_props : disp_univalent_2_1 (sigma_bicat _ _ D₂). Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros x y f xx yy ff gg. use weqhomot. - cbn. refine (_ ∘ total2_paths_equiv _ _ _)%weq. refine (pair_disp_invertible_to_sigma_disp_invertible_weq _ _ ∘ _)%weq. induction ff as [ff1 ff2] ; induction gg as [gg1 gg2]. refine (weqtotal2 (make_weq _ (HD₁_2_1 _ _ _ _ (idpath _) _ _ ff1 gg1)) _). intro p ; cbn in p. induction p. exact (make_weq _ (HD₂_2_1 _ _ _ _ (idpath _) _ _ ff2 gg2)). - intros p. cbn in p. induction p. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. Defined. Opaque adjoint_equivalence_total_disp_weq. Variable (LG₁ : disp_locally_groupoid D₁) (LG₂ : disp_locally_groupoid D₂). Definition pair_disp_adjequiv_to_sigma_disp_adjequiv {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : (∑ (p : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 xx) (pr1 yy)), disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x ,, p)) (pr2 xx) (pr2 yy)) → disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy. Proof. intros p. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, _ ,, (_ ,, _))). - exact (pr11 p ,, pr12 p). - exact (pr112 (pr1 p) ,, pr112 (pr2 p)). - exact (pr1 (pr212 (pr1 p)) ,, pr1 (pr212 (pr2 p))). - exact (pr2 (pr212 (pr1 p)) ,, pr2 (pr212 (pr2 p))). - apply help_disp_left_adjoint_axioms. apply disp_2cells_isaprop_sigma ; assumption. - apply disp_locally_groupoid_sigma ; assumption. - apply disp_locally_groupoid_sigma ; assumption. Defined. Definition pair_disp_adjequiv_to_sigma_disp_adjequiv_inv_pr1 {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy → disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 xx) (pr1 yy). Proof. intro p. simple refine (pr11 p ,, ((_ ,, (_ ,, _)) ,, _ ,, (_ ,, _))). - exact (pr1 (pr112 p)). - exact (pr11 (pr212 p)). - exact (pr12 (pr212 p)). - apply help_disp_left_adjoint_axioms. exact HD₁. - apply LG₁. - apply LG₁. Defined. Definition pair_disp_adjequiv_to_sigma_disp_adjequiv_inv_pr2 {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : ∏ (p : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy), disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x,, pair_disp_adjequiv_to_sigma_disp_adjequiv_inv_pr1 xx yy p)) (pr2 xx) (pr2 yy). Proof. intro p. simple refine (pr21 p ,, ((pr2 (pr112 p) ,, (pr21 (pr212 p) ,, pr22 (pr212 p))) ,, _ ,, (_ ,, _))). - apply help_disp_left_adjoint_axioms. exact HD₂. - apply LG₂. - apply LG₂. Defined. Definition pair_disp_adjequiv_to_sigma_disp_adjequiv_inv {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy → (∑ (p : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 xx) (pr1 yy)), disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x ,, p)) (pr2 xx) (pr2 yy)). Proof. intros p. simple refine (_ ,, _). - exact (pair_disp_adjequiv_to_sigma_disp_adjequiv_inv_pr1 xx yy p). - exact (pair_disp_adjequiv_to_sigma_disp_adjequiv_inv_pr2 xx yy p). Defined. Definition pair_disp_adjequiv_to_sigma_disp_adjequiv_weq_help {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : homot ((pair_disp_adjequiv_to_sigma_disp_adjequiv_inv xx yy) ∘ pair_disp_adjequiv_to_sigma_disp_adjequiv xx yy)%functions (idfun _). Proof. intro p. induction p as [p1 p2]. use total2_paths_b. - use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence ; [ exact (pr2 HC) | exact HD₁_2_1 ]. } apply idpath. - use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence ; [ apply total_is_univalent_2_1 ; [ exact (pr2 HC) | exact HD₁_2_1 ] | exact HD₂_2_1 ]. } unfold transportb. refine (!(_ @ _)). { apply (@pr1_transportf _ (λ z : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 xx) (pr1 yy), pr2 xx -->[invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x,, z)] pr2 yy)). } etrans. { exact (@transportf_subtypePath (pr1 xx -->[ internal_adjoint_equivalence_identity x ] pr1 yy) (λ z, disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity x) z) (λ z, isaprop_disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity x) z (pr2 HC) HD₁_2_1) (λ z, pr2 xx -->[ invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x,, z) ] pr2 yy) (pr1 p1) (pr1 (pair_disp_adjequiv_to_sigma_disp_adjequiv_inv xx yy (pair_disp_adjequiv_to_sigma_disp_adjequiv xx yy (p1,, p2)))) (pr2 p1) (pr1 p2)). } match goal with | [ |- transportf _?p _ = _ ] => induction p end. apply idpath. Qed. Definition pair_disp_adjequiv_to_sigma_disp_adjequiv_weq {x : C} (xx : (sigma_bicat C D₁ D₂) x) (yy : (sigma_bicat C D₁ D₂) x) : (∑ (p : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) (pr1 xx) (pr1 yy)), disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq (pr1 xx) (pr1 yy)) (internal_adjoint_equivalence_identity x ,, p)) (pr2 xx) (pr2 yy)) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy. Proof. use make_weq. - exact (pair_disp_adjequiv_to_sigma_disp_adjequiv xx yy). - use isweq_iso. + exact (pair_disp_adjequiv_to_sigma_disp_adjequiv_inv xx yy). + exact (pair_disp_adjequiv_to_sigma_disp_adjequiv_weq_help xx yy). + intros p. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence ; [ exact (pr2 HC) | exact sigma_disp_univalent_2_1_with_props ]. } apply idpath. Defined. Definition disp_adjequiv_sigma_help (x : C) (xx1 : D₁ x) (xx2 yy2 : D₂ (x,, xx1)) : disp_adjoint_equivalence (@internal_adjoint_equivalence_identity (total_bicat D₁) (x,, xx1)) xx2 yy2 → disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq xx1 xx1) ((internal_adjoint_equivalence_identity x) ,,disp_identity_adjoint_equivalence xx1)) xx2 yy2. Proof. intros p. simple refine (pr1 p ,, ((pr112 p ,, (pr1 (pr212 p) ,, pr2 (pr212 p))) ,, _ ,, (_ ,, _))). - abstract (apply help_disp_left_adjoint_axioms ; apply HD₂). - abstract (apply LG₂). - abstract (apply LG₂). Defined. Definition disp_adjequiv_sigma_help_inv (x : C) (xx1 : D₁ x) (xx2 yy2 : D₂ (x,, xx1)) : disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq xx1 xx1) ((internal_adjoint_equivalence_identity x) ,,disp_identity_adjoint_equivalence xx1)) xx2 yy2 → disp_adjoint_equivalence (@internal_adjoint_equivalence_identity (total_bicat D₁) (x,, xx1)) xx2 yy2. Proof. intros p. simple refine (pr1 p ,, ((pr112 p ,, (pr1 (pr212 p) ,, pr2 (pr212 p))) ,, _ ,, (_ ,, _))). - abstract (apply help_disp_left_adjoint_axioms ; apply HD₂). - abstract (apply LG₂). - abstract (apply LG₂). Defined. Definition disp_adjequiv_sigma_help_weq (x : C) (xx1 : D₁ x) (xx2 yy2 : D₂ (x,, xx1)) : disp_adjoint_equivalence (@internal_adjoint_equivalence_identity (total_bicat D₁) (x,, xx1)) xx2 yy2 ≃ disp_adjoint_equivalence (invmap (adjoint_equivalence_total_disp_weq xx1 xx1) ((internal_adjoint_equivalence_identity x) ,,disp_identity_adjoint_equivalence xx1)) xx2 yy2. Proof. use make_weq. - exact (disp_adjequiv_sigma_help x xx1 xx2 yy2). - use isweq_iso. + exact (disp_adjequiv_sigma_help_inv x xx1 xx2 yy2). + intros p. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence. + apply total_is_univalent_2_1. * exact (pr2 HC). * exact HD₁_2_1. + exact HD₂_2_1. } apply idpath. + intros p. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence. + apply total_is_univalent_2_1. * exact (pr2 HC). * exact HD₁_2_1. + exact HD₂_2_1. } apply idpath. Defined. Definition sigma_idtoiso_2_0_alt (HD₁_2_0 : disp_univalent_2_0 D₁) (HD₂_2_0 : disp_univalent_2_0 D₂) {x : C} (xx yy : (sigma_bicat C D₁ D₂) x) : xx = yy ≃ disp_adjoint_equivalence (idtoiso_2_0 x x (idpath x)) xx yy. Proof. refine (_ ∘ total2_paths_equiv _ _ _)%weq. refine (pair_disp_adjequiv_to_sigma_disp_adjequiv_weq xx yy ∘ _)%weq. refine (weqtotal2 (make_weq _ (HD₁_2_0 x x (idpath _) (pr1 xx) (pr1 yy))) _)%weq. induction xx as [xx1 xx2]. induction yy as [yy1 yy2]. intro p ; cbn in p. induction p. unfold transportf ; simpl. refine (_ ∘ make_weq _ (HD₂_2_0 _ _ (idpath (x ,, xx1)) xx2 yy2))%weq. exact (disp_adjequiv_sigma_help_weq x xx1 xx2 yy2). Defined. Definition sigma_disp_univalent_2_0_with_props (HD₁_2_0 : disp_univalent_2_0 D₁) (HD₂_2_0 : disp_univalent_2_0 D₂) : disp_univalent_2_0 (sigma_bicat _ _ D₂). Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x xx yy. use weqhomot. - exact (sigma_idtoiso_2_0_alt HD₁_2_0 HD₂_2_0 xx yy). - intros p. cbn in p. induction p. use subtypePath. { intro ; apply isaprop_disp_left_adjoint_equivalence. + exact (pr2 HC). + apply sigma_disp_univalent_2_1_with_props ; assumption. } apply idpath. Defined. Definition sigma_disp_univalent_2_with_props (HD₁_2 : disp_univalent_2 D₁) (HD₂_2 : disp_univalent_2 D₂) : disp_univalent_2 (sigma_bicat _ _ D₂). Proof. split. - apply sigma_disp_univalent_2_0_with_props. + apply HD₁_2. + apply HD₂_2. - apply sigma_disp_univalent_2_1_with_props. Defined. End SigmaDisplayedUnivalent. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Slice.v000066400000000000000000000504651451125700300253360ustar00rootroot00000000000000(** Slice bicategories Contents: 1. Definition of the slice displayed bicategory 2. The univalence of the slice displayed bicategory 3. The slice bicategory 4. Invertible 2-cells in slice bicategory 5. Adjoint equivalences in slice bicategory *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section SliceBicat. Context {B : bicat} (b : B). (** 1. Definition of the slice displayed bicategory *) Definition slice_disp_cat_ob_mor : disp_cat_ob_mor B. Proof. simple refine (_ ,, _). - exact (λ a, a --> b). - exact (λ a₁ a₂ fa₁ fa₂ g, invertible_2cell fa₁ (g · fa₂)). Defined. Definition slice_disp_cat_id_comp : disp_cat_id_comp B slice_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ a fa, linvunitor_invertible_2cell _). - exact (λ a₁ a₂ a₃ g₁ g₂ fa₁ fa₂ fa₃ α β, comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ β) (lassociator_invertible_2cell _ _ _))). Defined. Definition slice_disp_cat_data : disp_cat_data B. Proof. simple refine (_ ,, _). - exact slice_disp_cat_ob_mor. - exact slice_disp_cat_id_comp. Defined. Definition slice_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B. Proof. simple refine (_ ,, _). - exact slice_disp_cat_data. - intros a₁ a₂ g₁ g₂ α fa₁ fa₂ β₁ β₂ ; cbn in *. exact (pr1 β₁ • (α ▹ _) = β₂). Defined. Definition slice_disp_prebicat_ops : disp_prebicat_ops slice_disp_prebicat_1_id_comp_cells. Proof. repeat split ; cbn. - intros. rewrite id2_rwhisker. rewrite id2_right. apply idpath. - intros. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite lunitor_triangle. rewrite linvunitor_lunitor. apply id2_right. - intros. rewrite !vassocl. rewrite <- lunitor_lwhisker. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply id2_right. - intros. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite lunitor_triangle. apply idpath. - intros. apply maponpaths. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite triangle_l_inv. apply idpath. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. refine (!_). apply lassociator_lassociator. - intros. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply lassociator_lassociator. - intros ? ? ? ? ? ? ? ? ? ? ? ? p q. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite p. exact q. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? p. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. exact p. - intros ? ? ? ? ? ? ? ? ? ? ? ? ? p. rewrite !vassocl. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. exact p. Qed. Definition slice_disp_prebicat_data : disp_prebicat_data B. Proof. simple refine (_ ,, _). - exact slice_disp_prebicat_1_id_comp_cells. - exact slice_disp_prebicat_ops. Defined. Definition slice_disp_prebicat_laws : disp_prebicat_laws slice_disp_prebicat_data. Proof. repeat split ; intro ; intros ; apply cellset_property. Qed. Definition slice_disp_prebicat : disp_prebicat B. Proof. simple refine (_ ,, _). - exact slice_disp_prebicat_data. - exact slice_disp_prebicat_laws. Defined. Definition slice_disp_bicat : disp_bicat B. Proof. simple refine (_ ,, _). - exact slice_disp_prebicat. - cbn. intro ; intros. apply isasetaprop. apply cellset_property. Defined. Definition disp_2cells_isaprop_slice : disp_2cells_isaprop slice_disp_bicat. Proof. intro ; intros. apply cellset_property. Defined. Definition disp_locally_sym_slice : disp_locally_sym slice_disp_bicat. Proof. intros a₁ a₂ g₁ g₂ α fa₁ fa₂ β₁ β₂ p ; cbn in *. etrans. { apply maponpaths_2. exact (!p). } rewrite !vassocl. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_right. Qed. Definition disp_locally_groupoid_slice_disp_bicat : disp_locally_groupoid slice_disp_bicat. Proof. use make_disp_locally_groupoid. - exact disp_locally_sym_slice. - exact disp_2cells_isaprop_slice. Defined. (** 2. The univalence of the slice displayed bicategory *) Definition disp_univalent_2_1_slice : disp_univalent_2_1 slice_disp_bicat. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros x y f g xx ff gg. use isweqimplimpl. - intros α. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } refine (_ @ pr1 α) ; cbn. rewrite id2_rwhisker, id2_right. apply idpath. - apply isaset_invertible_2cell. - use invproofirrelevance. intros α β. use subtypePath. { intro. apply isaprop_is_disp_invertible_2cell. } apply disp_2cells_isaprop_slice. Qed. Definition slice_is_inv2cell_to_is_disp_adj_equiv {x : B} {f g : slice_disp_bicat x} (α : f -->[ internal_adjoint_equivalence_identity x ] g) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity x) α. Proof. simple refine (((_ ,, (_ ,, _)) ,, (_ ,, _))). - exact (comp_of_invertible_2cell (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (inv_of_invertible_2cell α)) (linvunitor_invertible_2cell _)). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite !lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp ; rewrite !vassocr ; rewrite lunitor_V_id_is_left_unit_V_id ; apply maponpaths_2 ; refine (!(id2_left _) @ _) ; rewrite !vassocl ; rewrite !lwhisker_vcomp ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite vcomp_lunitor ; rewrite !vassocr ; do 2 (use vcomp_move_L_Mp ; [ is_iso | ]) ; cbn ; rewrite id2_left ; apply idpath). - abstract (cbn ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite !vassocr ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; apply id2_right). - split ; apply disp_2cells_isaprop_slice. - split ; apply disp_locally_groupoid_slice_disp_bicat. Defined. Definition slice_inv2cell_to_disp_adj_equiv {x : B} {f g : slice_disp_bicat x} (α : invertible_2cell f g) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g. Proof. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, (_ ,, _))). - exact (comp_of_invertible_2cell α (linvunitor_invertible_2cell _)). - exact (comp_of_invertible_2cell (inv_of_invertible_2cell α) (linvunitor_invertible_2cell _)). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite triangle_l_inv ; rewrite <- rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; apply idpath). - abstract (cbn ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; apply idpath). - split ; apply disp_2cells_isaprop_slice. - split ; apply disp_locally_groupoid_slice_disp_bicat. Defined. Definition slice_disp_adj_equiv_to_inv2cell {x : B} {f g : slice_disp_bicat x} (α : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g) : invertible_2cell f g := comp_of_invertible_2cell (pr1 α) (lunitor_invertible_2cell _). Definition slice_inv2cell_weq_disp_adj_equiv (HB : is_univalent_2_1 B) {x : B} (f g : slice_disp_bicat x) : invertible_2cell f g ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) f g. Proof. use make_weq. - exact slice_inv2cell_to_disp_adj_equiv. - use isweq_iso. + exact slice_disp_adj_equiv_to_inv2cell. + abstract (intros α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocl ; rewrite linvunitor_lunitor ; apply id2_right). + abstract (intros α ; use subtypePath ; [ intro ; apply (isaprop_disp_left_adjoint_equivalence _ _ HB disp_univalent_2_1_slice) | ] ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocl ; rewrite lunitor_linvunitor ; apply id2_right). Defined. Definition disp_univalent_2_0_slice (HB : is_univalent_2_1 B) : disp_univalent_2_0 slice_disp_bicat. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x f g. use weqhomot. - exact (slice_inv2cell_weq_disp_adj_equiv HB f g ∘ make_weq _ (HB _ _ f g))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply (isaprop_disp_left_adjoint_equivalence _ _ HB disp_univalent_2_1_slice) | ] ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; apply id2_left). Defined. Definition disp_univalent_2_slice (HB : is_univalent_2_1 B) : disp_univalent_2 slice_disp_bicat. Proof. split. - exact (disp_univalent_2_0_slice HB). - exact disp_univalent_2_1_slice. Defined. End SliceBicat. (** 3. The slice bicategory *) Definition slice_bicat {B : bicat} (b : B) : bicat := total_bicat (slice_disp_bicat b). Definition is_univalent_2_1_slice_bicat {B : bicat} (HB : is_univalent_2_1 B) (b : B) : is_univalent_2_1 (slice_bicat b). Proof. use total_is_univalent_2_1. - exact HB. - exact (disp_univalent_2_1_slice b). Defined. Definition is_univalent_2_0_slice_bicat {B : bicat} (HB : is_univalent_2 B) (b : B) : is_univalent_2_0 (slice_bicat b). Proof. use total_is_univalent_2_0. - exact (pr1 HB). - exact (disp_univalent_2_0_slice b (pr2 HB)). Defined. Definition is_univalent_2_slice_bicat {B : bicat} (HB : is_univalent_2 B) (b : B) : is_univalent_2 (slice_bicat b). Proof. split. - exact (is_univalent_2_0_slice_bicat HB b). - exact (is_univalent_2_1_slice_bicat (pr2 HB) b). Defined. Definition make_ob_slice {B : bicat} {b : B} {y : B} (f : y --> b) : slice_bicat b := y ,, f. Definition make_1cell_slice {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} (g : pr1 f₁ --> pr1 f₂) (α : invertible_2cell (pr2 f₁) (g · pr2 f₂)) : f₁ --> f₂ := g ,, α. Definition cell_slice_homot {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} (α β : f₁ --> f₂) (γ : pr1 α ==> pr1 β) : UU := pr12 α • (γ ▹ pr2 f₂) = pr12 β. Definition make_2cell_slice {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} {α β : f₁ --> f₂} (γ : pr1 α ==> pr1 β) (p : cell_slice_homot α β γ) : α ==> β := γ ,, p. Definition eq_2cell_slice {B : bicat} {b : B} {y₁ y₂ : slice_bicat b} {f g : y₁ --> y₂} {α β : f ==> g} (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. (** 4. Invertible 2-cells in slice bicategory *) Definition is_invertible_2cell_in_slice_bicat {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} {g₁ g₂ : f₁ --> f₂} {α : g₁ ==> g₂} (Hα : is_invertible_2cell (pr1 α)) : is_invertible_2cell α. Proof. use is_invertible_disp_to_total. simple refine (_ ,, _). - exact Hα. - apply (disp_locally_groupoid_slice_disp_bicat _ _ _ _ _ (make_invertible_2cell Hα)). Defined. Definition from_is_invertible_2cell_in_slice_bicat {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} {g₁ g₂ : f₁ --> f₂} {α : g₁ ==> g₂} (Hα : is_invertible_2cell α) : is_invertible_2cell (pr1 α). Proof. use make_is_invertible_2cell. - exact (pr1 (Hα^-1)). - exact (maponpaths pr1 (vcomp_rinv Hα)). - exact (maponpaths pr1 (vcomp_linv Hα)). Defined. (** 5. Adjoint equivalences in slice bicategory *) Section LeftAdjointEquivalenceSlice. Context {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} (l : f₁ --> f₂) (Hl : left_adjoint_equivalence (pr1 l)). Let r : pr1 f₂ --> pr1 f₁ := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (pr1 l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · pr1 l) (id₁ _) := left_equivalence_counit_iso Hl. Definition left_adjoint_equivalence_in_slice_right_adj_cell : invertible_2cell (pr2 f₂) (r · pr2 f₁) := comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell ε)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (pr2 l))))). Definition left_adjoint_equivalence_in_slice_right_adj : f₂ --> f₁ := make_1cell_slice r (left_adjoint_equivalence_in_slice_right_adj_cell). Let slice_r : f₂ --> f₁ := left_adjoint_equivalence_in_slice_right_adj. Definition left_adjoint_equivalence_in_slice_unit_eq : cell_slice_homot (id₁ f₁) (l · slice_r) η. Proof. unfold cell_slice_homot. cbn. rewrite !vassocr. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_lwhisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocl. rewrite vcomp_whisker. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite linvunitor_assoc. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocl. rewrite <- lassociator_lassociator. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite !rwhisker_vcomp. apply maponpaths. do 2 (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]). refine (!(id2_left _) @ _). use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. exact (!(pr1 (axioms_of_left_adjoint Hl))). Qed. Definition left_adjoint_equivalence_in_slice_unit : id₁ f₁ ==> l · slice_r. Proof. use make_2cell_slice. - exact η. - exact left_adjoint_equivalence_in_slice_unit_eq. Defined. Definition left_adjoint_equivalence_in_slice_counit_eq : cell_slice_homot (slice_r · l) (id₁ f₂) ε. Proof. unfold cell_slice_homot ; cbn. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition left_adjoint_equivalence_in_slice_counit : slice_r · l ==> id₁ f₂. Proof. use make_2cell_slice. - exact ε. - exact left_adjoint_equivalence_in_slice_counit_eq. Defined. Definition left_adjoint_equivalence_in_slice_bicat : left_adjoint_equivalence l. Proof. use equiv_to_adjequiv. simple refine ((slice_r ,, (left_adjoint_equivalence_in_slice_unit ,, left_adjoint_equivalence_in_slice_counit)) ,, (_ ,, _)). - use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. - use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. Defined. End LeftAdjointEquivalenceSlice. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Sub1Cell.v000066400000000000000000000303061451125700300257010ustar00rootroot00000000000000(*********************************************************************** Subbicategories We consider two ways of constructing subbicategories. One by selecting 1-cells and one by selecting both 0-cells and 1-cells. In the second construction (subbicategories by selecting both 0-cells and 1-cells) there are two type families: `P₀` on the objects and `P₁` on the 1-cells. For a well-behaved constructions, both type families should be pointwise propositions. We can use this to guarantee that the resulting bicategory is univalent ([is_univalent_2_subbicat]), although we also need that the original bicategory is univalent. In addition, to guaranteee that the resulting bicategory is actually a subbicategory of the original once, we do want both `P₀` and `P₁` to be propositions. If, for example, we choose `P₀` to be the type of booleans for every object and `P₁` the unit type, then the resulting bicategory has two copies of every object, and this is not a subbicategory of the original one. Contents 1. Subbicategory by selecting 1-cells 2. Subbicategory by selecting both 0-cells and 1-cells ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Local Open Scope cat. (** 1. Subbicategory by selecting 1-cells *) Section Sub1CellBicategory. Context (B : bicat) (P : ∏ (x y : B), x --> y -> UU) (Pid : ∏ (x : B), P _ _ (id₁ x)) (Pcomp : ∏ (x y z : B) (f : x --> y) (g : y --> z), P _ _ f → P _ _ g → P _ _ (f · g)). Definition disp_sub1cell_disp_cat : disp_cat_ob_mor B. Proof. use make_disp_cat_ob_mor. - exact (λ _, unit). - exact (λ _ _ _ _ f, P _ _ f). Defined. Definition disp_sub1cell_disp_cat_id_comp : disp_cat_id_comp _ disp_sub1cell_disp_cat. Proof. use tpair. - exact (λ _ _, Pid _). - exact (λ _ _ _ _ _ _ _ _ p q, Pcomp _ _ _ _ _ p q). Defined. Definition disp_sub1cell_disp_cat_data : disp_cat_data B. Proof. use tpair. - exact disp_sub1cell_disp_cat. - exact disp_sub1cell_disp_cat_id_comp. Defined. Definition disp_sub1cell_prebicat : disp_prebicat B := disp_cell_unit_bicat disp_sub1cell_disp_cat_data. Definition disp_sub1cell_bicat : disp_bicat B := disp_cell_unit_bicat disp_sub1cell_disp_cat_data. Definition disp_2cells_isaprop_sub1cell_bicat : disp_2cells_isaprop disp_sub1cell_bicat. Proof. apply disp_2cells_isaprop_cell_unit_bicat. Defined. Definition disp_locally_groupoid_sub1cell_bicat : disp_locally_groupoid disp_sub1cell_bicat. Proof. apply disp_locally_groupoid_cell_unit_bicat. Defined. Definition disp_sub1cell_univalent_2_1 (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : disp_univalent_2_1 disp_sub1cell_bicat. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply HP. Defined. Definition disp_sub1cell_univalent_2_0 (HB : is_univalent_2_1 B) (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : disp_univalent_2_0 disp_sub1cell_bicat. Proof. use disp_cell_unit_bicat_univalent_2_0. - exact HB. - intros ; apply HP. - simpl ; intro. apply isasetunit. - simpl. intros. apply isapropunit. Qed. Definition disp_sub1cell_univalent_2 (HB : is_univalent_2_1 B) (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : disp_univalent_2 disp_sub1cell_bicat. Proof. split. - use disp_sub1cell_univalent_2_0. + exact HB. + exact HP. - use disp_sub1cell_univalent_2_1. exact HP. Defined. Definition sub1cell_bicat : bicat := total_bicat disp_sub1cell_bicat. Definition is_univalent_2_1_sub1cell_bicat (HB : is_univalent_2_1 B) (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : is_univalent_2_1 sub1cell_bicat. Proof. use total_is_univalent_2_1. - exact HB. - use disp_sub1cell_univalent_2_1. exact HP. Defined. Definition is_univalent_2_0_sub1cell_bicat (HB : is_univalent_2 B) (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : is_univalent_2_0 sub1cell_bicat. Proof. use total_is_univalent_2_0. - exact (pr1 HB). - use disp_sub1cell_univalent_2_0. + exact (pr2 HB). + exact HP. Defined. Definition is_univalent_2_sub1cell_bicat (HB : is_univalent_2 B) (HP : ∏ (x y : B) (f : x --> y), isaprop (P _ _ f)) : is_univalent_2 sub1cell_bicat. Proof. split. - use is_univalent_2_0_sub1cell_bicat. + exact HB. + exact HP. - use is_univalent_2_1_sub1cell_bicat. + exact (pr2 HB). + exact HP. Defined. End Sub1CellBicategory. (** 2. Subbicategory by selecting both 0-cells and 1-cells *) Section SubBicategory. Context {B : bicat} (P₀ : B → UU) (P₁ : ∏ (x y : B), P₀ x → P₀ y → x --> y -> UU) (P₁id : ∏ (x : B) (Px : P₀ x), P₁ _ _ Px Px (id₁ x)) (P₁comp : ∏ (x y z : B) (Px : P₀ x) (Py : P₀ y) (Pz : P₀ z) (f : x --> y) (g : y --> z), P₁ _ _ Px Py f → P₁ _ _ Py Pz g → P₁ _ _ Px Pz (f · g)). Definition disp_subbicat : disp_bicat B := sigma_bicat _ _ (disp_sub1cell_bicat (total_bicat (disp_fullsubbicat B P₀)) (λ x y f, P₁ (pr1 x) (pr1 y) (pr2 x) (pr2 y) (pr1 f)) (λ x, P₁id (pr1 x) (pr2 x)) (λ x y z f g Pf Pg, P₁comp _ _ _ _ _ _ _ _ Pf Pg)). Definition disp_2cells_isaprop_subbicat : disp_2cells_isaprop disp_subbicat. Proof. apply disp_2cells_isaprop_sigma. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_2cells_isaprop_sub1cell_bicat. Defined. Definition disp_locally_groupoid_subbicat (HB : is_univalent_2 B) : disp_locally_groupoid disp_subbicat. Proof. use disp_locally_groupoid_sigma. - exact HB. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_2cells_isaprop_sub1cell_bicat. - apply disp_locally_groupoid_fullsubbicat. - apply disp_locally_groupoid_sub1cell_bicat. Defined. Definition disp_subbicat_univalent_2_1 (HP₁ : ∏ (x y : B) (Px : P₀ x) (Py : P₀ y) (f : x --> y), isaprop (P₁ x y Px Py f)) : disp_univalent_2_1 disp_subbicat. Proof. use sigma_disp_univalent_2_1_with_props. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_2cells_isaprop_sub1cell_bicat. - apply disp_fullsubbicat_univalent_2_1. - apply disp_sub1cell_univalent_2_1. intros. apply HP₁. Defined. Definition disp_subbicat_univalent_2_0 (HB : is_univalent_2 B) (HP₀ : ∏ (x : B), isaprop (P₀ x)) (HP₁ : ∏ (x y : B) (Px : P₀ x) (Py : P₀ y) (f : x --> y), isaprop (P₁ x y Px Py f)) : disp_univalent_2_0 disp_subbicat. Proof. use sigma_disp_univalent_2_0_with_props. - exact HB. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_2cells_isaprop_sub1cell_bicat. - apply disp_fullsubbicat_univalent_2_1. - apply disp_sub1cell_univalent_2_1. intros. apply HP₁. - apply disp_locally_groupoid_fullsubbicat. - apply disp_locally_groupoid_sub1cell_bicat. - use disp_univalent_2_0_fullsubbicat. + exact HB. + exact HP₀. - apply disp_sub1cell_univalent_2_0. + use total_is_univalent_2_1. * apply HB. * apply disp_fullsubbicat_univalent_2_1. + intros. apply HP₁. Defined. Definition subbicat : bicat := total_bicat disp_subbicat. Definition eq_2cell_subbicat {x y : subbicat} {f g : x --> y} {α β : f ==> g} (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. simpl. apply isapropdirprod ; apply isapropunit. } exact p. Qed. Definition is_invertible_2cell_subbicat {x y : subbicat} {f g : x --> y} (α : f ==> g) (Hα : is_invertible_2cell (pr1 α)) : is_invertible_2cell α. Proof. use make_is_invertible_2cell. - exact (Hα^-1 ,, tt ,, tt). - abstract (use eq_2cell_subbicat ; apply vcomp_rinv). - abstract (use eq_2cell_subbicat ; apply vcomp_linv). Defined. Definition invertible_2cell_subbicat {x y : subbicat} {f g : x --> y} (Hα : invertible_2cell (pr1 f) (pr1 g)) : invertible_2cell f g. Proof. use make_invertible_2cell. - exact (pr1 Hα ,, tt ,, tt). - use is_invertible_2cell_subbicat. exact Hα. Defined. Definition from_is_invertible_2cell_subbicat {x y : subbicat} {f g : x --> y} (α : f ==> g) (Hα : is_invertible_2cell α) : is_invertible_2cell (pr1 α). Proof. use make_is_invertible_2cell. - exact (pr1 (Hα^-1)). - abstract (exact (maponpaths pr1 (vcomp_rinv Hα))). - abstract (exact (maponpaths pr1 (vcomp_linv Hα))). Defined. Definition from_invertible_2cell_subbicat {x y : subbicat} {f g : x --> y} (Hα : invertible_2cell f g) : invertible_2cell (pr1 f) (pr1 g). Proof. use make_invertible_2cell. - exact (pr11 Hα). - use from_is_invertible_2cell_subbicat. exact Hα. Defined. Definition is_univalent_2_1_subbicat (HB : is_univalent_2_1 B) (HP₁ : ∏ (x y : B) (Px : P₀ x) (Py : P₀ y) (f : x --> y), isaprop (P₁ x y Px Py f)) : is_univalent_2_1 subbicat. Proof. use total_is_univalent_2_1. - exact HB. - use disp_subbicat_univalent_2_1. exact HP₁. Defined. Definition is_univalent_2_0_subbicat (HB : is_univalent_2 B) (HP₀ : ∏ (x : B), isaprop (P₀ x)) (HP₁ : ∏ (x y : B) (Px : P₀ x) (Py : P₀ y) (f : x --> y), isaprop (P₁ x y Px Py f)) : is_univalent_2_0 subbicat. Proof. use total_is_univalent_2_0. - exact (pr1 HB). - use disp_subbicat_univalent_2_0. + exact HB. + exact HP₀. + exact HP₁. Defined. Definition is_univalent_2_subbicat (HB : is_univalent_2 B) (HP₀ : ∏ (x : B), isaprop (P₀ x)) (HP₁ : ∏ (x y : B) (Px : P₀ x) (Py : P₀ y) (f : x --> y), isaprop (P₁ x y Px Py f)) : is_univalent_2 subbicat. Proof. split. - use is_univalent_2_0_subbicat. + exact HB. + exact HP₀. + exact HP₁. - use is_univalent_2_1_subbicat. + exact (pr2 HB). + exact HP₁. Defined. End SubBicategory. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/Examples/Trivial.v000066400000000000000000000366331451125700300257120ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** ** Trivial display. Every bicategory is, in a trivial way, a displayed bicategory over any other bicategory. *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Local Open Scope mor_disp_scope. (* ----------------------------------------------------------------------------------- *) (* Handy lemma about transport over a constant fibration. NB: This is similar to [transportf_const], but eta-expanded. *) (* ----------------------------------------------------------------------------------- *) Definition transportf_trivial (A B : UU) (a b : A) (p : a = b) (x : B) : x = transportf (λ x : A, B) p x. Proof. induction p. apply idpath. Defined. Section Trivial_Displayed. (* ----------------------------------------------------------------------------------- *) (** [B] is the the base bicategory and [C] is the bicategory that we trivially display over [B]. *) (* ----------------------------------------------------------------------------------- *) Variable (B C : bicat). Definition trivial_disp_cat_ob_mor : disp_cat_ob_mor B := make_disp_cat_ob_mor B (λ _ : B, C) (λ (_ _ : B) (a b : C) _, C⟦a,b⟧). Definition trivial_disp_cat_id_comp : disp_cat_id_comp B trivial_disp_cat_ob_mor := (λ (_ : B) (a : C), identity a),, (λ (_ _ _ : B) _ _ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧), f · g). Definition trivial_disp_cat_data : disp_cat_data B := trivial_disp_cat_ob_mor,, trivial_disp_cat_id_comp. Definition trivial_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B := tpair (λ C:disp_cat_data B, disp_2cell_struct C) trivial_disp_cat_data (λ _ _ _ _ _ a b f g, f ==> g). Definition trivial_displayed_data : disp_prebicat_data B. use (trivial_disp_prebicat_1_id_comp_cells,, _). repeat apply make_dirprod; cbn. - intros _ _ _. exact (λ a b f, id2 f). - intros _ _ _. exact (λ a b f, lunitor f). - intros _ _ _. exact (λ a b f, runitor f). - intros _ _ _. exact (λ a b f, linvunitor f). - intros _ _ _. exact (λ a b f, rinvunitor f). - intros _ _ _ _ _ _ _. exact (λ a b c d f g h, rassociator f g h). - intros _ _ _ _ _ _ _. exact (λ a b c d f g h, lassociator f g h). - intros _ _ _ _ _ _ _. exact (λ a b f g h x y, vcomp2 x y). - intros _ _ _ _ _ _ _. exact (λ a b c f g1 g2 x, lwhisker f x). - intros _ _ _ _ _ _ _. exact (λ a b c f1 f2 g x, rwhisker g x). Defined. Lemma trivial_disp_prebicat_laws : disp_prebicat_laws trivial_displayed_data. Proof. repeat apply make_dirprod; red; cbn; intros. - etrans. { apply id2_left. } apply transportf_trivial. - etrans. { apply id2_right. } apply transportf_trivial. - etrans. { apply vassocr. } apply transportf_trivial. - etrans. { apply lwhisker_id2. } apply transportf_trivial. - etrans. { apply id2_rwhisker. } apply transportf_trivial. - etrans. { apply lwhisker_vcomp. } apply transportf_trivial. - etrans. { apply rwhisker_vcomp. } apply transportf_trivial. - etrans. { apply vcomp_lunitor. } apply transportf_trivial. - etrans. { apply vcomp_runitor. } apply transportf_trivial. - etrans. { apply lwhisker_lwhisker. } apply transportf_trivial. - etrans. { apply rwhisker_lwhisker. } apply transportf_trivial. - etrans. { apply rwhisker_rwhisker. } apply transportf_trivial. - etrans. { apply vcomp_whisker. } apply transportf_trivial. - etrans. { apply lunitor_linvunitor. } apply transportf_trivial. - etrans. { apply linvunitor_lunitor. } apply transportf_trivial. - etrans. { apply runitor_rinvunitor. } apply transportf_trivial. - etrans. { apply rinvunitor_runitor. } apply transportf_trivial. - etrans. { apply lassociator_rassociator. } apply transportf_trivial. - etrans. { apply rassociator_lassociator. } apply transportf_trivial. - etrans. { apply runitor_rwhisker. } apply transportf_trivial. - etrans. { apply lassociator_lassociator. } apply transportf_trivial. Qed. Definition trivial_displayed_prebicat : disp_prebicat B := trivial_displayed_data,, trivial_disp_prebicat_laws. Definition trivial_displayed_bicat : disp_bicat B. Proof. refine (trivial_displayed_prebicat ,, _). repeat intro; apply C. Defined. End Trivial_Displayed. Definition prod_bicat (B C : bicat) : bicat := total_bicat (trivial_displayed_bicat B C). Definition pairobj {B C : bicat} (X : B) (Y : C) : prod_bicat B C := X ,, Y. Definition pairmor {B C : bicat} {X₁ X₂ : B} {Y₁ Y₂ : C} (f : X₁ --> X₂) (g : Y₁ --> Y₂) : pairobj X₁ Y₁ --> pairobj X₂ Y₂ := f ,, g. Definition paircell {B C : bicat} {X₁ X₂ : B} {Y₁ Y₂ : C} {f₁ f₂ : X₁ --> X₂} {g₁ g₂ : Y₁ --> Y₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : pairmor f₁ g₁ ==> pairmor f₂ g₂ := α ,, β. Definition trivial_is_invertible_2cell_to_is_disp_invertible {B C : bicat} {b₁ b₂ : B} {f g : B ⟦ b₁, b₂ ⟧} {α : f ==> g} (Hα : is_invertible_2cell α) {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff : c₁ -->[ f ] c₂} {gg : c₁ -->[ g ] c₂} (β : ff ==> gg) (Hβ : is_invertible_2cell β) : is_disp_invertible_2cell Hα β. Proof. simple refine (_ ,, (_ ,, _)). - exact (Hβ^-1). - abstract (unfold transportb ; cbn ; rewrite transportf_const ; apply vcomp_rinv). - abstract (unfold transportb ; cbn ; rewrite transportf_const ; apply vcomp_linv). Defined. Definition trivial_invertible_2cell_to_disp_invertible {B C : bicat} {b₁ b₂ : B} {f : B ⟦ b₁, b₂ ⟧} {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff gg : c₁ -->[ f] c₂} : invertible_2cell ff gg → disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. intros α. simple refine (_ ,, _). - exact (pr1 α). - apply trivial_is_invertible_2cell_to_is_disp_invertible. exact (pr2 α). Defined. Definition trivial_is_disp_invertible_to_is_invertible_2cell {B C : bicat} {b₁ b₂ : B} {f g : B ⟦ b₁, b₂ ⟧} {α : f ==> g} (Hα : is_invertible_2cell α) {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff gg : c₁ -->[ f] c₂} (β : ff ==> gg) (Hβ : is_disp_invertible_2cell Hα β) : is_invertible_2cell β. Proof. use make_is_invertible_2cell. - exact (pr1 Hβ). - abstract (pose (pr12 Hβ) as p ; cbn in p ; unfold transportb in p ; rewrite transportf_const in p ; exact p). - abstract (pose (pr22 Hβ) as p ; cbn in p ; unfold transportb in p ; rewrite transportf_const in p ; exact p). Defined. Definition trivial_disp_invertible_to_invertible_2cell {B C : bicat} {b₁ b₂ : B} {f : B ⟦ b₁, b₂ ⟧} {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff gg : c₁ -->[ f] c₂} : disp_invertible_2cell (id2_invertible_2cell f) ff gg → invertible_2cell ff gg. Proof. intros α. use make_invertible_2cell. - exact (pr1 α). - use (trivial_is_disp_invertible_to_is_invertible_2cell (is_invertible_2cell_id₂ f)). apply α. Defined. Definition trivial_invertible_to_disp_invertible_to_invertible {B C : bicat} {b₁ b₂ : B} {f : B ⟦ b₁, b₂ ⟧} {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff gg : c₁ -->[ f] c₂} (α : invertible_2cell ff gg) : trivial_disp_invertible_to_invertible_2cell (trivial_invertible_2cell_to_disp_invertible α) = α. Proof. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } apply idpath. Qed. Definition trivial_disp_invertible_to_invertible_to_disp_invertible {B C : bicat} {b₁ b₂ : B} {f : B ⟦ b₁, b₂ ⟧} {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} {ff gg : c₁ -->[ f] c₂} (α : disp_invertible_2cell (id2_invertible_2cell f) ff gg) : trivial_invertible_2cell_to_disp_invertible (trivial_disp_invertible_to_invertible_2cell α) = α. Proof. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. Qed. Definition trivial_invertible_2cell_weq_disp_invertible {B C : bicat} {b₁ b₂ : B} {f : B ⟦ b₁, b₂ ⟧} {c₁ : trivial_displayed_bicat B C b₁} {c₂ : trivial_displayed_bicat B C b₂} (ff gg : c₁ -->[ f] c₂) : invertible_2cell ff gg ≃ disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. use make_weq. - exact trivial_invertible_2cell_to_disp_invertible. - use isweq_iso. + exact trivial_disp_invertible_to_invertible_2cell. + exact trivial_invertible_to_disp_invertible_to_invertible. + exact trivial_disp_invertible_to_invertible_to_disp_invertible. Defined. Definition trivial_is_univalent_2_1 {B C : bicat} (HC : is_univalent_2_1 C) : disp_univalent_2_1 (trivial_displayed_bicat B C). Proof. use fiberwise_local_univalent_is_univalent_2_1. intros b₁ b₂ f c₁ c₂ ff gg. use weqhomot. - exact (trivial_invertible_2cell_weq_disp_invertible ff gg ∘ make_weq (idtoiso_2_1 ff gg) (HC _ _ ff gg))%weq. - intro p ; cbn in p. induction p. use subtypePath. { intro ; apply isaprop_is_disp_invertible_2cell. } apply idpath. Defined. Definition trivial_adj_equiv_to_disp_adj_equiv {B C : bicat} {b : B} {c₁ c₂ : trivial_displayed_bicat B C b} : adjoint_equivalence c₁ c₂ → disp_adjoint_equivalence (internal_adjoint_equivalence_identity b) c₁ c₂. Proof. intros e. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))). - exact (pr1 e). - exact (left_adjoint_right_adjoint e). - exact (left_adjoint_unit e). - exact (left_adjoint_counit e). - abstract (unfold transportb ; cbn ; rewrite transportf_const ; cbn ; exact (pr1 (pr122 e))). - abstract (unfold transportb ; cbn ; rewrite transportf_const ; cbn ; exact (pr2 (pr122 e))). - abstract (apply trivial_is_invertible_2cell_to_is_disp_invertible ; apply (pr2 e)). - abstract (apply trivial_is_invertible_2cell_to_is_disp_invertible ; apply (pr2 e)). Defined. Definition trivial_disp_adj_equiv_to_adj_equiv {B C : bicat} {b : B} {c₁ c₂ : trivial_displayed_bicat B C b} : disp_adjoint_equivalence (internal_adjoint_equivalence_identity b) c₁ c₂ → adjoint_equivalence c₁ c₂. Proof. intros e. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))). - exact (pr1 e). - exact (pr112 e). - exact (pr1 (pr212 e)). - exact (pr2 (pr212 e)). - abstract (pose (pr1 (pr122 e)) as p ; cbn in p ; unfold transportb in p ; rewrite transportf_const in p ; exact p). - abstract (pose (pr2 (pr122 e)) as p ; cbn in p ; unfold transportb in p ; rewrite transportf_const in p ; exact p). - abstract (apply (trivial_is_disp_invertible_to_is_invertible_2cell _ _ (pr1 (pr222 e)))). - abstract (apply (trivial_is_disp_invertible_to_is_invertible_2cell _ _ (pr2 (pr222 e)))). Defined. Definition trivial_adj_equiv_to_disp_to_adj {B C : bicat} (HC_2_1 : is_univalent_2_1 C) {b : B} {c₁ c₂ : trivial_displayed_bicat B C b} (e : adjoint_equivalence c₁ c₂) : trivial_disp_adj_equiv_to_adj_equiv (trivial_adj_equiv_to_disp_adj_equiv e) = e. Proof. use subtypePath. { intro. use isaprop_left_adjoint_equivalence. exact HC_2_1. } apply idpath. Qed. Definition trivial_disp_adj_equiv_to_adj_to_disp {B C : bicat} (HB_2_1 : is_univalent_2_1 B) (HC_2_1 : is_univalent_2_1 C) {b : B} {c₁ c₂ : trivial_displayed_bicat B C b} (e : disp_adjoint_equivalence (internal_adjoint_equivalence_identity b) c₁ c₂) : trivial_adj_equiv_to_disp_adj_equiv (trivial_disp_adj_equiv_to_adj_equiv e) = e. Proof. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact HB_2_1. - apply trivial_is_univalent_2_1. exact HC_2_1. } apply idpath. Qed. Definition trivial_adj_equiv_weq_disp_adj_equiv {B C : bicat} (HB_2_1 : is_univalent_2_1 B) (HC_2_1 : is_univalent_2_1 C) {b : B} (c₁ c₂ : trivial_displayed_bicat B C b) : adjoint_equivalence c₁ c₂ ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity b) c₁ c₂. Proof. use make_weq. - exact trivial_adj_equiv_to_disp_adj_equiv. - use isweq_iso. + exact trivial_disp_adj_equiv_to_adj_equiv. + exact (trivial_adj_equiv_to_disp_to_adj HC_2_1). + exact (trivial_disp_adj_equiv_to_adj_to_disp HB_2_1 HC_2_1). Defined. Definition trivial_is_univalent_2_0 {B C : bicat} (HB_2_1 : is_univalent_2_1 B) (HC_2_0 : is_univalent_2_0 C) (HC_2_1 : is_univalent_2_1 C) : disp_univalent_2_0 (trivial_displayed_bicat B C). Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros b c₁ c₂. use weqhomot. - exact (trivial_adj_equiv_weq_disp_adj_equiv HB_2_1 HC_2_1 c₁ c₂ ∘ make_weq (idtoiso_2_0 c₁ c₂) (HC_2_0 c₁ c₂))%weq. - intros p. cbn in p. induction p. use subtypePath. { intro. use isaprop_disp_left_adjoint_equivalence. - exact HB_2_1. - apply trivial_is_univalent_2_1. exact HC_2_1. } apply idpath. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/000077500000000000000000000000001451125700300262175ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/CodomainCleaving.v000066400000000000000000000761261451125700300316240ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits. Local Open Scope cat. (** The codomain displayed bicategory has a cleaving Here we assume that every 2-cell is invertible *) Section CodomainCleaving. Context (B : bicat). Definition cod_local_iso_cleaving : local_iso_cleaving (cod_disp_bicat B). Proof. intros x y f g hx hy hf α. simple refine (_ ,, _). - refine (pr1 hf ,, _) ; cbn. exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ α) (pr2 hf)). - simple refine ((id2 _ ,, _) ,, _) ; cbn. + abstract (rewrite id2_rwhisker, id2_right ; apply idpath). + use is_disp_invertible_2cell_cod. cbn. is_iso. Defined. Section CartesianOfSFibToCartesian. Context {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : cod_disp_bicat B c₁} {t₂ : cod_disp_bicat B c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_cartesian_2cell_sfib (pr2 t₂) (pr1 αα)). Section FixSome. Context {h : c₁ --> c₂} {hh : t₁ -->[ h] t₂} {γ : h ==> s₁} (γα : hh ==>[ γ • α] ss₂). Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique : isaprop (∑ γγ : hh ==>[ γ] ss₁, γγ •• αα = γα). Proof. cbn in *. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply cod_disp_bicat | ]. use subtypePath ; [ intro ; apply cellset_property | ]. use (is_cartesian_2cell_sfib_factor_unique _ Hαα). - exact (pr1 γα). - exact ((pr2 hh)^-1 • (_ ◃ γ) • pr2 ss₁). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; refine (pr2 γα @ _) ; rewrite <- lwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; exact (!(pr2 αα))). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₁)). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₂)). - exact (maponpaths pr1 (pr2 φ₁)). - exact (maponpaths pr1 (pr2 φ₂)). Qed. Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell : hh ==>[ γ ] ss₁. Proof. cbn in *. use make_disp_2cell_cod. - use (is_cartesian_2cell_sfib_factor _ Hαα (pr1 γα)). + exact ((pr2 hh)^-1 • (_ ◃ γ) • pr2 ss₁). + abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; refine (pr2 γα @ _) ; rewrite <- lwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; exact (!(pr2 αα))). - abstract (unfold coherent_homot ; rewrite is_cartesian_2cell_sfib_factor_over ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm : is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell •• αα = γα. Proof. cbn. use subtypePath. { intro. apply cellset_property. } apply is_cartesian_2cell_sfib_factor_comm. Qed. End FixSome. Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell : is_cartesian_2cell (cod_disp_bicat B) αα. Proof. intros h hh γ γα. use iscontraprop1. - exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique γα). - simple refine (_ ,, _). + exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell γα). + exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm γα). Defined. End CartesianOfSFibToCartesian. Definition cod_invertible_is_cartesian_2cell {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : cod_disp_bicat B c₁} {t₂ : cod_disp_bicat B c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_invertible_2cell (pr1 αα)) : is_cartesian_2cell (cod_disp_bicat B) αα. Proof. apply is_cartesian_2cell_sfib_to_is_cartesian_2cell. apply invertible_is_cartesian_2cell_sfib. exact Hαα. Defined. Section OpCartesianOfSOpFibToOpCartesian. Context {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : cod_disp_bicat B c₁} {t₂ : cod_disp_bicat B c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_opcartesian_2cell_sopfib (pr2 t₂) (pr1 αα)). Section FixSome. Context {h : c₁ --> c₂} {hh : t₁ -->[ h ] t₂} {γ : s₂ ==> h} (γα : ss₁ ==>[ α • γ ] hh). Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique : isaprop (∑ γγ : ss₂ ==>[ γ ] hh, αα •• γγ = γα). Proof. cbn in *. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply cod_disp_bicat | ]. use subtypePath ; [ intro ; apply cellset_property | ]. use (is_opcartesian_2cell_sopfib_factor_unique _ Hαα). - exact (pr1 γα). - exact ((pr2 ss₂)^-1 • (_ ◃ γ) • pr2 hh). - abstract (use (vcomp_lcancel (pr12 ss₁)) ; [ apply (pr2 ss₁) | ] ; rewrite !vassocr ; rewrite !(pr2 γα) ; apply maponpaths_2 ; rewrite <- lwhisker_vcomp ; apply maponpaths_2 ; rewrite (pr2 αα) ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₁)). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₂)). - exact (maponpaths pr1 (pr2 φ₁)). - exact (maponpaths pr1 (pr2 φ₂)). Qed. Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell : ss₂ ==>[ γ ] hh. Proof. cbn in *. use make_disp_2cell_cod. - use (is_opcartesian_2cell_sopfib_factor _ Hαα (pr1 γα)). + exact ((pr2 ss₂)^-1 • (_ ◃ γ) • pr2 hh). + abstract (use (vcomp_lcancel (pr12 ss₁)) ; [ apply (pr2 ss₁) | ] ; rewrite !vassocr ; rewrite !(pr2 γα) ; apply maponpaths_2 ; rewrite <- lwhisker_vcomp ; apply maponpaths_2 ; rewrite (pr2 αα) ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). - abstract (unfold coherent_homot ; rewrite is_opcartesian_2cell_sopfib_factor_over ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm : αα •• is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell = γα. Proof. cbn. use subtypePath. { intro. apply cellset_property. } apply is_opcartesian_2cell_sopfib_factor_comm. Qed. End FixSome. Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell : is_opcartesian_2cell (cod_disp_bicat B) αα. Proof. intros h hh γ γα. use iscontraprop1. - exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique γα). - simple refine (_ ,, _). + exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell γα). + exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm γα). Defined. End OpCartesianOfSOpFibToOpCartesian. Definition cod_invertible_is_opcartesian_2cell {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : cod_disp_bicat B c₁} {t₂ : cod_disp_bicat B c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_invertible_2cell (pr1 αα)) : is_opcartesian_2cell (cod_disp_bicat B) αα. Proof. apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. apply invertible_is_opcartesian_2cell_sopfib. exact Hαα. Defined. (** Characterization of cartesian 1-cells *) Section PullbackToCartesian. Context {x y : B} {f : x --> y} {hx : cod_disp_bicat B x} {hy : cod_disp_bicat B y} (π : pr1 hx --> pr1 hy) (p : invertible_2cell (pr2 hx · f) (π · pr2 hy)) (pb := make_pb_cone (pr1 hx) (pr2 hx) π p) (pb_sqr : has_pb_ump pb). Section Lift1CellConeMor. Context {z : B} {hz : cod_disp_bicat B z} {g : z --> x} (hg : hz -->[ g · f] hy). Let other_cone : pb_cone f (pr2 hy) := make_pb_cone (pr1 hz) (pr2 hz · g) (pr1 hg) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (pr2 hg)). Definition lift_1cell_to_pb_1cell (Hg : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg) : pb_1cell other_cone pb. Proof. use make_pb_1cell. - exact (pr11 Hg). - use inv_of_invertible_2cell. exact (pr21 Hg). - use make_invertible_2cell. + exact (pr112 Hg). + exact (pr21 (cod_disp_invertible_invertible_2_cell _ (pr2 Hg))). - abstract (pose (pr212 Hg) as q ; cbn ; cbn in q ; rewrite lwhisker_id2 in q ; rewrite id2_left in q ; rewrite !vassocl ; do 3 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn) ; refine (_ @ maponpaths (λ z, z • _) q) ; clear q ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rwhisker_vcomp ; pose (maponpaths pr1 (disp_vcomp_rinv (pr2 Hg))) as q ; unfold transportb in q ; cbn in q ; rewrite pr1_transportf, transportf_const in q ; cbn in q ; refine (!_) ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_2 ; apply maponpaths ; exact q | ] ; rewrite id2_rwhisker, id2_left ; rewrite lassociator_rassociator ; apply id2_right). Defined. Definition pb_1cell_to_lift_1cell (Hg : pb_1cell other_cone pb) : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg. Proof. simple refine ((_ ,, _) ,, ((_ ,, _) ,, _)). - exact (pb_1cell_1cell Hg). - exact (inv_of_invertible_2cell (pb_1cell_pr1 Hg)). - exact (pr1 (pb_1cell_pr2 Hg)). - abstract (cbn ; pose (pb_1cell_eq Hg) as q ; cbn in q ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; do 3 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn) ; refine (maponpaths (λ z, z • _) q @ _) ; clear q ; rewrite !vassocl ; do 3 apply maponpaths ; refine (_ @ id2_right _) ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left, id2_right ; apply idpath). - use is_disp_invertible_2cell_cod. exact (pr2 (pb_1cell_pr2 Hg)). Defined. End Lift1CellConeMor. Definition is_pb_to_cartesian_lift_1cell {z : B} {hz : cod_disp_bicat B z} {g : B ⟦ z, x ⟧} (hg : hz -->[ g · f] hy) : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg. Proof. apply pb_1cell_to_lift_1cell. apply (has_pb_ump_1 pb_sqr). Defined. Section Lift2CellConeCell. Context {c : B} {cc : cod_disp_bicat B c} {h h' : c --> x} {gg : cc -->[ h · f] hy} {gg' : cc -->[ h' · f] hy} {δ : h ==> h'} (σσ : gg ==>[ δ ▹ f] gg') (Lh : lift_1cell_factor (cod_disp_bicat B) (π,, p) gg) (Lh' : lift_1cell_factor (cod_disp_bicat B) (π,, p) gg'). Let ℓ : pr1 cc --> pr1 hx := pr11 Lh. Let ℓhx : invertible_2cell (pr2 cc · h) (ℓ · pr2 hx) := pr21 Lh. Let ℓπ : invertible_2cell (ℓ · π) (pr1 gg) := pr1 (cod_disp_invertible_invertible_2_cell _ (pr2 Lh)). Let ℓ' : pr1 cc --> pr1 hx := pr11 Lh'. Let ℓhx' : invertible_2cell (pr2 cc · h') (ℓ' · pr2 hx) := pr21 Lh'. Let ℓπ' : invertible_2cell (ℓ' · π) (pr1 gg') := pr1 (cod_disp_invertible_invertible_2_cell _ (pr2 Lh')). Definition is_pb_to_cartesian_lift_2cell_cell_eq : (ℓ ◃ p) • lassociator ℓ π (pr2 hy) • ((pr112 Lh • pr1 σσ • pr1 (disp_inv_cell (pr2 Lh'))) ▹ pr2 hy) • rassociator ℓ' π (pr2 hy) = lassociator ℓ (pr2 hx) f • ((ℓhx ^-1 • (pr2 cc ◃ δ) • ℓhx') ▹ f) • rassociator ℓ' (pr2 hx) f • (ℓ' ◃ p). Proof. pose (pr212 Lh) as d. pose (pr212 Lh') as d'. cbn in d, d'. rewrite lwhisker_id2, id2_left in d. rewrite lwhisker_id2, id2_left in d'. rewrite <- !rwhisker_vcomp. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_L_pM ; [ is_iso | ]. cbn. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. etrans. { do 3 apply maponpaths_2. exact d. } clear d. rewrite <- rwhisker_lwhisker. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. use vcomp_move_R_Mp. { is_iso. apply (is_invertible_2cell_inv (pr2 ℓπ')). } cbn. rewrite !vassocl. rewrite !vassocl in d'. refine (!_). etrans. { apply maponpaths. exact d'. } refine (!_). exact (pr2 σσ). Qed. Definition is_pb_to_cartesian_lift_2cell_cell : ℓ ==> ℓ'. Proof. use (pb_ump_cell pb_sqr) ; cbn. - exact (ℓhx^-1 • (_ ◃ δ) • ℓhx'). - exact (ℓπ • pr1 σσ • (ℓπ')^-1). - exact is_pb_to_cartesian_lift_2cell_cell_eq. Defined. Definition is_pb_to_cartesian_lift_2cell_cell_homot : coherent_homot δ is_pb_to_cartesian_lift_2cell_cell. Proof. unfold coherent_homot. etrans. { apply maponpaths. apply (pb_ump_cell_pr1 pb_sqr). } rewrite !vassocr. rewrite vcomp_rinv, id2_left. apply idpath. Qed. Definition is_pb_to_cartesian_lift_2cell_disp_cell : Lh ==>[ δ ] Lh'. Proof. use make_disp_2cell_cod. - exact is_pb_to_cartesian_lift_2cell_cell. - exact is_pb_to_cartesian_lift_2cell_cell_homot. Defined. Definition is_pb_to_cartesian_lift_2cell_unique : isaprop (lift_2cell_factor_type (cod_disp_bicat B) (π,, p) σσ Lh Lh'). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply disp_cellset_property. } use subtypePath. { intro ; apply cellset_property. } use (pb_ump_eq pb_sqr). - exact (ℓhx^-1 • (_ ◃ δ) • ℓhx'). - exact (ℓπ • pr1 σσ • (ℓπ')^-1). - apply is_pb_to_cartesian_lift_2cell_cell_eq. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (pr21 φ₁). - pose (!(transportf_cell_of_cod_over (id2_right (δ ▹ f) @ ! id2_left (δ ▹ f)) _) @ maponpaths pr1 (pr2 φ₁)) as d. use vcomp_move_L_Mp ; [ is_iso | ]. exact d. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (pr21 φ₂). - pose (!(transportf_cell_of_cod_over (id2_right (δ ▹ f) @ ! id2_left (δ ▹ f)) _) @ maponpaths pr1 (pr2 φ₂)) as d. use vcomp_move_L_Mp ; [ is_iso | ]. exact d. Qed. Definition is_pb_to_cartesian_lift_2cell : lift_2cell_factor (cod_disp_bicat B) (π,, p) σσ Lh Lh'. Proof. use iscontraprop1. - exact is_pb_to_cartesian_lift_2cell_unique. - simple refine (_ ,, _). + exact is_pb_to_cartesian_lift_2cell_disp_cell. + abstract (use subtypePath ; [ intro ; apply cellset_property | ] ; etrans ; [ exact (transportf_cell_of_cod_over _ _) | ] ; simpl ; etrans ; [ apply maponpaths_2 ; apply (pb_ump_cell_pr2 pb_sqr) | ] ; do 2 refine (vassocl _ _ _ @ _) ; apply maponpaths ; refine (_ @ id2_right _) ; apply maponpaths ; apply (pr2 ℓπ')). Defined. End Lift2CellConeCell. Definition is_pb_to_cartesian_1cell : cartesian_1cell (cod_disp_bicat B) (π ,, p). Proof. split. - exact @is_pb_to_cartesian_lift_1cell. - exact @is_pb_to_cartesian_lift_2cell. Defined. End PullbackToCartesian. Context (inv_B : locally_groupoid B). Section CartesianToPullback. Context {x y : B} {f : x --> y} {hx : cod_disp_bicat B x} {hy : cod_disp_bicat B y} (π : pr1 hx --> pr1 hy) (p : invertible_2cell (pr2 hx · f) (π · pr2 hy)) (Hp : cartesian_1cell (cod_disp_bicat B) (π,, p)). Let pb := make_pb_cone (pr1 hx) (pr2 hx) π p. Definition cartesian_1cell_pb_ump_1 : pb_ump_1 pb. Proof. intro q. pose (pr1 Hp x (make_ar (pb_cone_pr1 q)) (id₁ _) (pb_cone_pr2 q ,, comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)) (pb_cone_cell q))) as w. pose (lift_1cell_to_pb_1cell π p _ w) as r. use make_pb_1cell. - exact r. - exact (comp_of_invertible_2cell (pb_1cell_pr1 r) (runitor_invertible_2cell _)). - exact (pb_1cell_pr2 r). - abstract (refine (pb_1cell_eq r @ _) ; cbn ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite vassocl ; apply maponpaths ; rewrite !vassocr ; do 3 apply maponpaths_2 ; apply lunitor_lwhisker). Defined. Section PullbackUMP2. Context {q : B} {φ ψ : q --> pb} {α : φ · pb_cone_pr1 pb ==> ψ · pb_cone_pr1 pb} {β : φ · pb_cone_pr2 pb ==> ψ · pb_cone_pr2 pb} (r : (φ ◃ pb_cone_cell pb) • lassociator φ (pb_cone_pr2 pb) (pr2 hy) • (β ▹ pr2 hy) • rassociator ψ (pb_cone_pr2 pb) (pr2 hy) = lassociator φ (pb_cone_pr1 pb) f • (α ▹ f) • rassociator ψ (pb_cone_pr1 pb) f • (ψ ◃ pb_cone_cell pb)). Let φ_disp : make_ar φ -->[ pr2 hx · f] hy. Proof. use make_disp_1cell_cod. - exact (φ · π). - exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell φ p) (lassociator_invertible_2cell _ _ _)). Defined. Let φ_cone : pb_cone f (pr2 hy) := make_pb_cone q (φ · pr2 hx) (φ · π) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (pr2 φ_disp)). Let φ_cell : pb_1cell φ_cone pb. Proof. use make_pb_1cell. - exact φ. - apply id2_invertible_2cell. - apply id2_invertible_2cell. - abstract (cbn ; rewrite !id2_rwhisker, !id2_right ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_right ; apply idpath). Defined. Let ψ_disp : make_ar φ -->[ pr2 hx · f] hy. Proof. use make_disp_1cell_cod. - exact (ψ · π). - use make_invertible_2cell. + exact (lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ p) • lassociator _ _ _). + is_iso. * apply inv_B. * apply property_from_invertible_2cell. Defined. Let σσ : φ_disp ==>[ id₂ (pr2 hx) ▹ f] ψ_disp. Proof. use make_disp_2cell_cod. - exact β. - abstract (unfold coherent_homot ; cbn ; rewrite id2_rwhisker, lwhisker_id2, id2_left ; use vcomp_move_L_Mp ; [ is_iso | ] ; exact r). Defined. Let ψ_cone : pb_cone f (pr2 hy) := make_pb_cone q (φ · pr2 hx) (ψ · π) (comp_of_invertible_2cell (rassociator_invertible_2cell φ (pr2 hx) f) (pr2 ψ_disp)). Let ψ_cell : pb_1cell ψ_cone pb. Proof. use make_pb_1cell. - exact ψ. - refine (inv_of_invertible_2cell _). use make_invertible_2cell. + exact α. + apply inv_B. - apply id2_invertible_2cell. - abstract (cbn ; rewrite id2_rwhisker, id2_right ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_right ; do 3 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn ; rewrite !vassocr ; apply idpath). Defined. Let φ_lift : lift_1cell_factor (cod_disp_bicat B) (π,, p) φ_disp := pb_1cell_to_lift_1cell π p φ_disp φ_cell. Let ψ_lift : lift_1cell_factor (cod_disp_bicat B) (π,, p) ψ_disp := pb_1cell_to_lift_1cell π p ψ_disp ψ_cell. Definition cartesian_1cell_pb_2cell : φ ==> ψ := pr1 (cartesian_1cell_lift_2cell _ _ Hp σσ φ_lift ψ_lift). Definition cartesian_1cell_pb_2cell_pr1 : cartesian_1cell_pb_2cell ▹ pb_cone_pr1 pb = α. Proof. pose (pr2 (cartesian_1cell_lift_2cell _ _ Hp σσ φ_lift ψ_lift)) as d. cbn in d. rewrite lwhisker_id2, !id2_left in d. exact d. Qed. Definition cartesian_1cell_pb_2cell_pr2 : cartesian_1cell_pb_2cell ▹ pb_cone_pr2 pb = β. Proof. pose (maponpaths pr1 (cartesian_1cell_lift_2cell_commutes _ _ Hp σσ φ_lift ψ_lift)) as d. cbn in d. rewrite pr1_transportf, transportf_const in d. cbn in d. rewrite id2_right, id2_left in d. exact d. Qed. Section Uniqueness. Context (τ₁ τ₂ : φ ==> ψ) (pr1τ₁ : τ₁ ▹ pb_cone_pr1 pb = α) (pr2τ₁ : τ₁ ▹ pb_cone_pr2 pb = β) (pr1τ₂ : τ₂ ▹ pb_cone_pr1 pb = α) (pr2τ₂ : τ₂ ▹ pb_cone_pr2 pb = β). Let lift_τ₁ : φ_lift ==>[ id₂ (pr2 hx)] ψ_lift. Proof. use make_disp_2cell_cod. - exact τ₁. - abstract (unfold coherent_homot ; cbn ; rewrite lwhisker_id2, !id2_left ; exact pr1τ₁). Defined. Let lift_τ₂ : φ_lift ==>[ id₂ (pr2 hx)] ψ_lift. Proof. use make_disp_2cell_cod. - exact τ₂. - abstract (unfold coherent_homot ; cbn ; rewrite lwhisker_id2, !id2_left ; exact pr1τ₂). Defined. Definition cartesian_1cell_pb_2cell_unique : τ₁ = τ₂. Proof. refine (maponpaths pr1 (isaprop_lift_of_lift_2cell _ _ (pr2 Hp _ _ _ _ _ _ _ σσ φ_lift ψ_lift) lift_τ₁ lift_τ₂ _ _)) ; (use subtypePath ; [ intro ; apply cellset_property | ]) ; cbn ; rewrite pr1_transportf, transportf_const ; cbn. - rewrite id2_left, id2_right. exact pr2τ₁. - rewrite id2_left, id2_right. exact pr2τ₂. Qed. End Uniqueness. End PullbackUMP2. Definition cartesian_1cell_pb_ump_2 : pb_ump_2 pb. Proof. intros q φ ψ α β r. apply iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (cartesian_1cell_pb_2cell_unique r _ _ (pr12 τ₁) (pr22 τ₁) (pr12 τ₂) (pr22 τ₂))). - exact (cartesian_1cell_pb_2cell r ,, cartesian_1cell_pb_2cell_pr1 r ,, cartesian_1cell_pb_2cell_pr2 r). Defined. Definition cartesian_1cell_to_is_pb : has_pb_ump pb. Proof. split. - exact cartesian_1cell_pb_ump_1. - exact cartesian_1cell_pb_ump_2. Defined. End CartesianToPullback. Context (pb_B : has_pb B). Definition cod_global_cleaving : global_cleaving (cod_disp_bicat B). Proof. intros x y hx f ; cbn in *. pose (pb_B _ _ _ f (pr2 hx)) as pb. pose (pr1 pb) as pb₁. pose (pr2 pb) as pb₂. simple refine ((_ ,, _) ,, (_ ,, _) ,, _) ; cbn. - exact pb₁. - exact (pb_cone_pr1 pb₁). - exact (pb_cone_pr2 pb₁). - exact (pb_cone_cell pb₁). - apply is_pb_to_cartesian_1cell. exact pb₂. Defined. Definition cod_local_cleaving : local_cleaving (cod_disp_bicat B). Proof. intros x y hx hy f g hf hg. simple refine (_ ,, _). - simple refine (pr1 hf ,, pr2 hx ◃ hg • pr12 hf ,, _). cbn. is_iso. + apply inv_B. + apply (pr22 hf). - simple refine (_ ,, _). + simple refine (id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; apply idpath). + simpl. apply cod_invertible_is_cartesian_2cell ; cbn. is_iso. Defined. Definition cod_local_opcleaving : local_opcleaving (cod_disp_bicat B). Proof. intros x y hx hy f g hf hg. simple refine (_ ,, _). - cbn. simple refine (pr1 hf ,, (pr2 hx ◃ _^-1) • pr12 hf ,, _) ; cbn. + exact hg. + apply inv_B. + is_iso. apply (pr22 hf). - simple refine (_ ,, _). + simple refine (id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite vcomp_rinv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). + simpl. apply cod_invertible_is_opcartesian_2cell ; cbn. is_iso. Defined. Definition cod_cleaving_lwhisker_cartesian : lwhisker_cartesian (cod_disp_bicat B). Proof. intro ; intros. apply cod_invertible_is_cartesian_2cell. apply inv_B. Defined. Definition cod_cleaving_rwhisker_cartesian : rwhisker_cartesian (cod_disp_bicat B). Proof. intro ; intros. apply cod_invertible_is_cartesian_2cell. apply inv_B. Defined. Definition cod_cleaving_lwhisker_opcartesian : lwhisker_opcartesian (cod_disp_bicat B). Proof. intro ; intros. apply cod_invertible_is_opcartesian_2cell ; apply inv_B. Defined. Definition cod_cleaving_rwhisker_opcartesian : rwhisker_opcartesian (cod_disp_bicat B). Proof. intro ; intros. apply cod_invertible_is_opcartesian_2cell ; apply inv_B. Defined. Definition cod_cleaving_of_bicats : cleaving_of_bicats (cod_disp_bicat B). Proof. repeat split. - exact cod_local_cleaving. - exact cod_global_cleaving. - exact cod_cleaving_lwhisker_cartesian. - exact cod_cleaving_rwhisker_cartesian. Defined. End CodomainCleaving. Definition cod_fibration_one_types : cleaving_of_bicats (cod_disp_bicat one_types). Proof. use cod_cleaving_of_bicats. - exact one_type_2cell_iso. - exact one_types_has_pb. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/DisplayMapBicatCleaving.v000066400000000000000000001100041451125700300330610ustar00rootroot00000000000000(***************************************************************************** The cleaving associated to a display map bicategories Every display map bicategory gives rise to a cleaving. If the display map bicategory is covariant, then the associated cleaving has a local opcleaving. If the display map bicategory is contravariant, then so is the associated cleaving has a local cleaving. 1. Pullback squares are cartesian 1-cells 2. Global cleaving 3. Characterization of cartesian cells 4. Characterization of opcartesian cells 5. Local cleaving 6. Local opcleaving 7. Specialized to internal Street (op)fibrations *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatToDispBicat. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. Definition arrow_subbicat_local_iso_cleaving {B : bicat} (D : arrow_subbicat B) : local_iso_cleaving (disp_map_bicat_to_disp_bicat D). Proof. intros x y f g hx hy hf α. simple refine (_ ,, _). - refine (pr1 hf ,, pr12 hf ,, _) ; cbn. exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ α) (pr22 hf)). - simple refine ((id2 _ ,, _) ,, _) ; cbn. + abstract (rewrite id2_rwhisker, id2_right ; apply idpath). + use is_invertible_to_is_disp_invertible. cbn. is_iso. Defined. Section DispMapBicatCleaving. Context {B : bicat} (D : disp_map_bicat B). Let DD : disp_bicat B := disp_map_bicat_to_disp_bicat D. (** 1. Pullback squares are cartesian 1-cells *) Section PullbackToCartesian. Context {pb x y z : B} {f : y --> z} {g : x --> z} (p₁ : pb --> x) (p₂ : pb --> y) (Hp₂ : pred_ob D p₂) (Hg : pred_ob D g) (Hp₁ : pred_mor D p₂ g p₁) (γ : invertible_2cell (p₁ · g) (p₂ · f) ) (cone := make_pb_cone pb p₁ p₂ γ) (Hpb : has_pb_ump cone). Let hy : DD y. Proof. use make_disp_map_bicat_ob. - exact pb. - exact p₂. - exact Hp₂. Defined. Let hz : DD z. Proof. use make_disp_map_bicat_ob. - exact x. - exact g. - exact Hg. Defined. Let hf : hy -->[ f ] hz. Proof. use make_disp_map_bicat_mor. - exact p₁. - exact Hp₁. - exact (inv_of_invertible_2cell γ). Defined. Section LiftOneCellFactor. Context {c : B} {cc : DD c} {k : B ⟦ c, y ⟧} (gg : cc -->[ k · f ] hz). Let other_cone : pb_cone g f := make_pb_cone (pr1 cc) (pr1 gg) (pr12 cc · k) (comp_of_invertible_2cell (inv_of_invertible_2cell (pr22 gg)) (lassociator_invertible_2cell _ _ _)). Let φ : pb_1cell other_cone cone := has_pb_ump_1 Hpb other_cone. Definition pb_lift_1cell_factor : lift_1cell_factor DD hf gg. Proof. simple refine (_ ,, (_ ,, _) ,, _). - use make_disp_map_bicat_mor. + exact (pb_1cell_1cell φ). + exact (pred_mor_closed_under_pb_ump_mor D _ _ _ _ _ _ _ _ _ Hpb other_cone _ _ _ _ _ Hg Hp₁ (pr12 gg)). + exact (inv_of_invertible_2cell (pb_1cell_pr2 φ)). - exact (pb_1cell_pr1 φ). - abstract (cbn ; pose (pb_1cell_eq φ) as q ; cbn in q ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; do 4 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn) ; rewrite q ; rewrite !vassocl ; apply maponpaths ; refine (!_) ; etrans ; [ do 4 apply maponpaths ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocl ; apply idpath | ] ; etrans ; [ do 3 apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker, id2_left ; apply idpath | ] ; etrans ; [ do 2 apply maponpaths ; rewrite !vassocr ; rewrite lassociator_rassociator, id2_left ; apply idpath | ] ; rewrite vcomp_linv ; apply id2_right). - apply is_invertible_to_is_disp_invertible. apply property_from_invertible_2cell. Defined. End LiftOneCellFactor. Section LiftTwoCellFactor. Context {c : B} {cc : DD c} {h h' : c --> y} {gg : cc -->[ h · f ] hz} {gg' : cc -->[ h' · f ] hz} {δ : h ==> h'} (σσ : disp_2cells (δ ▹ f) gg gg') (Lh : lift_1cell_factor DD hf gg) (Lh' : lift_1cell_factor DD hf gg'). Let ℓ : pr1 cc --> pr1 hy := pr11 Lh. Let ℓp₂ : invertible_2cell (pr12 cc · h) (ℓ · p₂) := pr221 Lh. Let ℓp₁ : invertible_2cell (ℓ · p₁) (pr1 gg). Proof. use make_invertible_2cell. - exact (pr112 Lh). - apply (is_disp_invertible_to_is_invertible _ _ _ (pr22 Lh)). Defined. Let ℓ' : pr1 cc --> pb := pr11 Lh'. Let ℓ'p₂ : invertible_2cell (pr12 cc · h') (ℓ' · p₂) := pr221 Lh'. Let ℓ'p₁ : invertible_2cell (ℓ' · p₁) (pr1 gg'). Proof. use make_invertible_2cell. - exact (pr112 Lh'). - apply (is_disp_invertible_to_is_invertible _ _ _ (pr22 Lh')). Defined. Definition pb_lift_2cell_factor_cell_eq : (ℓ ◃ γ) • lassociator ℓ p₂ f • ((ℓp₂ ^-1 • (pr12 cc ◃ δ) • ℓ'p₂) ▹ f) • rassociator ℓ' p₂ f = lassociator ℓ p₁ g • ((ℓp₁ • pr1 σσ • ℓ'p₁ ^-1) ▹ g) • rassociator ℓ' p₁ g • (ℓ' ◃ γ). Proof. pose (pr212 Lh) as d. pose (pr212 Lh') as d'. pose (pr2 σσ) as d''. cbn in d, d', d''. rewrite lwhisker_id2, id2_left in d. rewrite lwhisker_id2, id2_left in d'. refine (!_). rewrite <- !rwhisker_vcomp. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. apply property_from_invertible_2cell. } cbn. do 2 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn). use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite !vassocr in d. etrans. { do 4 apply maponpaths_2. exact d. } clear d. rewrite d'' ; clear d''. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite <- d' ; clear d'. use vcomp_move_R_Mp. { is_iso ; [ apply (is_invertible_2cell_inv (pr2 ℓ'p₁)) | apply property_from_invertible_2cell ]. } cbn. rewrite !vassocl. apply idpath. Qed. Definition pb_lift_2cell_factor_cell : ℓ ==> ℓ'. Proof. use (pb_ump_cell Hpb) ; cbn. - exact (ℓp₁ • pr1 σσ • (ℓ'p₁)^-1). - exact (ℓp₂^-1 • (_ ◃ δ) • ℓ'p₂). - exact pb_lift_2cell_factor_cell_eq. Defined. Definition pb_lift_2cell_factor_unique : isaprop (lift_2cell_factor_type DD hf σσ Lh Lh'). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply disp_cellset_property. } use subtypePath. { intro ; apply cellset_property. } use (pb_ump_eq Hpb). - exact (ℓp₁ • pr1 σσ • (ℓ'p₁)^-1). - exact (ℓp₂^-1 • (_ ◃ δ) • ℓ'p₂). - apply pb_lift_2cell_factor_cell_eq. - use vcomp_move_L_Mp ; [ is_iso | ]. exact (!(transportf_disp_map_bicat_cell _ _ _) @ maponpaths pr1 (pr2 φ₁)). - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (pr21 φ₁). - use vcomp_move_L_Mp ; [ is_iso | ]. exact (!(transportf_disp_map_bicat_cell _ _ _) @ maponpaths pr1 (pr2 φ₂)). - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (pr21 φ₂). Qed. Definition pb_lift_2cell_factor : lift_2cell_factor DD hf σσ Lh Lh'. Proof. use iscontraprop1. - exact pb_lift_2cell_factor_unique. - simple refine (_ ,, _). + use make_disp_map_bicat_cell. * exact pb_lift_2cell_factor_cell. * abstract (etrans ; [ apply maponpaths ; apply (pb_ump_cell_pr2 Hpb) | ] ; rewrite !vassocr ; rewrite vcomp_rinv, id2_left ; apply idpath). + abstract (use subtypePath ; [ intro ; apply cellset_property | ] ; refine (transportf_disp_map_bicat_cell _ _ _ @ _) ; cbn ; etrans ; [ apply maponpaths_2 ; apply (pb_ump_cell_pr1 Hpb) | ] ; do 2 refine (vassocl _ _ _ @ _) ; apply maponpaths ; refine (_ @ id2_right _) ; apply maponpaths ; apply vcomp_linv). Defined. End LiftTwoCellFactor. Definition pb_to_cartesian_1cell : cartesian_1cell DD hf. Proof. split. - exact @pb_lift_1cell_factor. - exact @pb_lift_2cell_factor. Defined. End PullbackToCartesian. (** 2. Global cleaving *) Definition global_cleaving_of_disp_map_bicat : global_cleaving DD. Proof. intros x y yy f. pose (pb := pb_ob_of_pred_ob D (pr12 yy) f (pr22 yy)). pose (p₁ := pb_pr1_of_pred_ob D (pr12 yy) f (pr22 yy)). pose (p₂ := pb_pr2_of_pred_ob D (pr12 yy) f (pr22 yy)). pose (γ := pb_cell_of_pred_ob D (pr12 yy) f (pr22 yy)). pose (ump := pb_of_pred_ob_has_pb_ump D (pr12 yy) f (pr22 yy)). pose (Hp₁ := mor_of_pb_preserves_pred_ob D (pr22 yy) ump). pose (Hp₂ := pb_preserves_pred_ob D (pr22 yy) ump). simple refine (_ ,, _ ,, _). - use make_disp_map_bicat_ob. + exact pb. + exact p₂. + exact Hp₂. - use make_disp_map_bicat_mor ; cbn. + exact p₁. + exact Hp₁. + exact (inv_of_invertible_2cell γ). - apply pb_to_cartesian_1cell. apply ump. Defined. (** 3. Characterization of cartesian cells *) Section CartesianOfSFibToCartesian. Context {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : DD c₁} {t₂ : DD c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_cartesian_2cell_sfib (pr12 t₂) (pr1 αα)). Section FixSome. Context {h : c₁ --> c₂} {hh : t₁ -->[ h] t₂} {γ : h ==> s₁} (γα : hh ==>[ γ • α] ss₂). Definition disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique : isaprop (∑ γγ : hh ==>[ γ] ss₁, γγ •• αα = γα). Proof. cbn in *. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply disp_map_bicat_to_disp_bicat | ]. use subtypePath ; [ intro ; apply cellset_property | ]. use (is_cartesian_2cell_sfib_factor_unique _ Hαα). - exact (pr1 γα). - exact ((pr22 hh)^-1 • (_ ◃ γ) • pr22 ss₁). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; refine (pr2 γα @ _) ; rewrite <- lwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; exact (!(pr2 αα))). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₁)). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₂)). - exact (maponpaths pr1 (pr2 φ₁)). - exact (maponpaths pr1 (pr2 φ₂)). Qed. Definition disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell : hh ==>[ γ ] ss₁. Proof. use make_disp_map_bicat_cell. - use (is_cartesian_2cell_sfib_factor _ Hαα (pr1 γα)). + exact ((pr22 hh)^-1 • (_ ◃ γ) • pr22 ss₁). + abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; refine (pr2 γα @ _) ; rewrite <- lwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; exact (!(pr2 αα))). - abstract (rewrite is_cartesian_2cell_sfib_factor_over ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. Definition disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm : disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell •• αα = γα. Proof. cbn. use subtypePath. { intro. apply cellset_property. } apply is_cartesian_2cell_sfib_factor_comm. Qed. End FixSome. Definition disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell : is_cartesian_2cell DD αα. Proof. intros h hh γ γα. use iscontraprop1. - exact (disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique γα). - simple refine (_ ,, _). + exact (disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell γα). + exact (disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm γα). Defined. End CartesianOfSFibToCartesian. Section CartesianOfSFibToCartesian. Context (HD : is_contravariant_disp_map_bicat D) {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : DD c₁} {t₂ : DD c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_cartesian_2cell DD αα). Let Ht₂ : internal_sfib (pr12 t₂). Proof. apply HD. exact (pr22 t₂). Defined. Let f : pr1 t₁ --> pr1 t₂ := internal_sfib_cleaving_lift_mor _ Ht₂ ((_ ◃ α) • pr22 ss₂). Let β : f ==> pr1 ss₂ := internal_sfib_cleaving_lift_cell _ Ht₂ ((_ ◃ α) • pr22 ss₂). Let γ : invertible_2cell (f · pr12 t₂) (pr12 t₁ · s₁) := internal_sfib_cleaving_com _ Ht₂ ((_ ◃ α) • pr22 ss₂). Let Hss₂ : mor_preserves_cartesian (pr12 t₁) (pr12 t₂) (pr1 ss₂) := pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 ss₂). Local Definition disp_map_cartesian_2cell_sfib_src : t₁ -->[ s₁] t₂. Proof. use make_disp_map_bicat_mor. - exact f. - apply HD. unfold f. intros z h₁ h₂ δ Hδ. assert (H₁ : is_cartesian_2cell_sfib (pr12 t₂) (h₂ ◃ β)). { apply (pr2 Ht₂). apply internal_sfib_cleaving_is_cartesian. } assert (H₂ : is_cartesian_2cell_sfib (pr12 t₂) (h₁ ◃ β)). { apply (pr2 Ht₂). apply internal_sfib_cleaving_is_cartesian. } assert (H₃ : is_cartesian_2cell_sfib (pr12 t₂) (δ ▹ pr1 ss₂)). { apply Hss₂. exact Hδ. } use (is_cartesian_2cell_sfib_postcomp _ _ H₁ (vcomp_is_cartesian_2cell_sfib _ H₂ H₃)). abstract (rewrite vcomp_whisker ; apply idpath). - exact (inv_of_invertible_2cell γ). Defined. Local Definition disp_map_cartesian_2cell_sfib_src_cell : disp_map_cartesian_2cell_sfib_src ==>[ α ] ss₂. Proof. use make_disp_map_bicat_cell. - exact β. - abstract (cbn ; etrans ; [ apply maponpaths ; apply internal_sfib_cleaving_over | ] ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; apply idpath). Defined. Let Hβ : is_cartesian_2cell_sfib (pr12 t₂) (pr1 disp_map_cartesian_2cell_sfib_src_cell) := internal_sfib_cleaving_is_cartesian _ Ht₂ ((_ ◃ α) • pr22 ss₂). Definition disp_map_is_cartesian_2cell_to_is_cartesian_2cell_sfib : is_cartesian_2cell_sfib (pr12 t₂) (pr1 αα). Proof. pose (disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell _ Hβ) as Hβ'. rewrite (is_cartesian_2cell_unique_iso_com Hαα Hβ'). refine (transportf (is_cartesian_2cell_sfib (pr12 t₂)) _ _). - refine (!_). apply transportf_disp_map_bicat_cell. - use vcomp_is_cartesian_2cell_sfib. + use invertible_is_cartesian_2cell_sfib. exact (is_disp_invertible_to_is_invertible _ _ _ (pr2 (is_cartesian_2cell_unique_iso Hαα Hβ'))). + apply Hβ. Qed. End CartesianOfSFibToCartesian. (** 4. Characterization of opcartesian cells *) Section OpCartesianOfSOpFibToOpCartesian. Context {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : DD c₁} {t₂ : DD c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_opcartesian_2cell_sopfib (pr12 t₂) (pr1 αα)). Section FixSome. Context {h : c₁ --> c₂} {hh : t₁ -->[ h ] t₂} {γ : s₂ ==> h} (γα : ss₁ ==>[ α • γ ] hh). Definition disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique : isaprop (∑ γγ : ss₂ ==>[ γ ] hh, αα •• γγ = γα). Proof. cbn in *. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply DD | ]. use subtypePath ; [ intro ; apply cellset_property | ]. use (is_opcartesian_2cell_sopfib_factor_unique _ Hαα). - exact (pr1 γα). - exact ((pr22 ss₂)^-1 • (_ ◃ γ) • pr22 hh). - abstract (use (vcomp_lcancel (pr22 ss₁)) ; [ apply (pr22 ss₁) | ] ; rewrite !vassocr ; refine (pr2 γα @ _) ; apply maponpaths_2 ; rewrite <- lwhisker_vcomp ; apply maponpaths_2 ; refine (!_) ; refine (maponpaths (λ z, z • _) (pr2 αα) @ _) ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₁)). - abstract (rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; exact (pr21 φ₂)). - exact (maponpaths pr1 (pr2 φ₁)). - exact (maponpaths pr1 (pr2 φ₂)). Qed. Definition disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell : ss₂ ==>[ γ ] hh. Proof. use make_disp_map_bicat_cell. - use (is_opcartesian_2cell_sopfib_factor _ Hαα (pr1 γα)). + exact ((pr22 ss₂)^-1 • (_ ◃ γ) • pr22 hh). + abstract (use (vcomp_lcancel (pr22 ss₁)) ; [ apply (pr22 ss₁) | ] ; rewrite !vassocr ; refine (pr2 γα @ _) ; apply maponpaths_2 ; rewrite <- lwhisker_vcomp ; apply maponpaths_2 ; refine (!_) ; refine (maponpaths (λ z, z • _) (pr2 αα) @ _) ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). - abstract (rewrite is_opcartesian_2cell_sopfib_factor_over ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. Definition disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm : αα •• disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell = γα. Proof. cbn. use subtypePath. { intro. apply cellset_property. } apply is_opcartesian_2cell_sopfib_factor_comm. Qed. End FixSome. Definition disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell : is_opcartesian_2cell DD αα. Proof. intros h hh γ γα. use iscontraprop1. - exact (disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique γα). - simple refine (_ ,, _). + exact (disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell γα). + exact (disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm γα). Defined. End OpCartesianOfSOpFibToOpCartesian. Section OpCartesianOfSOpFibToOpCartesian. Context (HD : is_covariant_disp_map_bicat D) {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : DD c₁} {t₂ : DD c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) (Hαα : is_opcartesian_2cell DD αα). Let Ht₂ : internal_sopfib (pr12 t₂). Proof. apply HD. exact (pr22 t₂). Defined. Let f : pr1 t₁ --> pr1 t₂ := internal_sopfib_opcleaving_lift_mor _ Ht₂ ((pr22 ss₁)^-1 • (_ ◃ α)). Let β : pr1 ss₁ ==> f := internal_sopfib_opcleaving_lift_cell _ Ht₂ ((pr22 ss₁)^-1 • (_ ◃ α)). Let γ : invertible_2cell (pr12 t₁ · s₂) (f · pr12 t₂) := internal_sopfib_opcleaving_com _ Ht₂ ((pr22 ss₁)^-1 • (_ ◃ α)). Let Hss₁ : mor_preserves_opcartesian (pr12 t₁) (pr12 t₂) (pr1 ss₁) := pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 ss₁). Local Definition disp_map_opcartesian_2cell_sopfib_src : t₁ -->[ s₂ ] t₂. Proof. use make_disp_map_bicat_mor. - exact f. - apply HD. unfold f. intros z h₁ h₂ δ Hδ. assert (H₁ : is_opcartesian_2cell_sopfib (pr12 t₂) (h₂ ◃ β)). { apply (pr2 Ht₂). apply internal_sopfib_opcleaving_is_opcartesian. } assert (H₂ : is_opcartesian_2cell_sopfib (pr12 t₂) (h₁ ◃ β)). { apply (pr2 Ht₂). apply internal_sopfib_opcleaving_is_opcartesian. } assert (H₃ : is_opcartesian_2cell_sopfib (pr12 t₂) (δ ▹ pr1 ss₁)). { apply Hss₁. exact Hδ. } use (is_opcartesian_2cell_sopfib_precomp _ _ H₂ (vcomp_is_opcartesian_2cell_sopfib _ H₃ H₁)). abstract (rewrite vcomp_whisker ; apply idpath). - exact γ. Defined. Local Definition disp_map_opcartesian_2cell_sopfib_src_cell : ss₁ ==>[ α ] disp_map_opcartesian_2cell_sopfib_src. Proof. use make_disp_map_bicat_cell. - exact β. - abstract (cbn ; etrans ; [ apply maponpaths ; apply internal_sopfib_opcleaving_over | ] ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. Let Hβ : is_opcartesian_2cell_sopfib (pr12 t₂) (pr1 disp_map_opcartesian_2cell_sopfib_src_cell) := internal_sopfib_opcleaving_is_opcartesian _ Ht₂ ((pr22 ss₁)^-1 • (_ ◃ α)). Definition disp_map_is_opcartesian_2cell_to_is_opcartesian_2cell_sopfib : is_opcartesian_2cell_sopfib (pr12 t₂) (pr1 αα). Proof. pose (disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell _ Hβ) as Hβ'. rewrite (is_opcartesian_2cell_unique_iso_com Hαα Hβ'). refine (transportf (is_opcartesian_2cell_sopfib (pr12 t₂)) _ _). - refine (!_). apply transportf_disp_map_bicat_cell. - use vcomp_is_opcartesian_2cell_sopfib. + apply Hβ. + use invertible_is_opcartesian_2cell_sopfib. exact (is_disp_invertible_to_is_invertible _ _ _ (pr2 (is_opcartesian_2cell_unique_iso Hαα Hβ'))). Qed. End OpCartesianOfSOpFibToOpCartesian. (** 5. Local cleaving *) Section LocalCleaving. Context (HD : is_contravariant_disp_map_bicat D). Section LocalLift. Context {x y : B} {xx : DD x} {yy : DD y} {f g : x --> y} (gg : xx -->[ g ] yy) (α : f ==> g). Let H : internal_sfib (pr12 yy) := pr1 HD _ _ _ (pr22 yy). Let ff : pr1 xx --> pr1 yy := internal_sfib_cleaving_lift_mor _ H ((pr12 xx ◃ α) • pr22 gg). Let β : ff ==> pr1 gg := internal_sfib_cleaving_lift_cell (pr12 yy) H ((pr12 xx ◃ α) • pr22 gg). Let γ : invertible_2cell (ff · pr12 yy) (pr12 xx · f) := internal_sfib_cleaving_com (pr12 yy) H ((pr12 xx ◃ α) • pr22 gg). Let Hgg : mor_preserves_cartesian (pr12 xx) (pr12 yy) (pr1 gg) := pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 gg). Definition local_cleaving_of_disp_map_bicat_cartesian : pred_mor D (pr12 xx) (pr12 yy) ff. Proof. apply HD. intros z h₁ h₂ δ Hδ. assert (H₁ : is_cartesian_2cell_sfib (pr12 yy) (h₂ ◃ β)). { apply (pr2 H). apply internal_sfib_cleaving_is_cartesian. } assert (H₂ : is_cartesian_2cell_sfib (pr12 yy) (h₁ ◃ β)). { apply (pr2 H). apply internal_sfib_cleaving_is_cartesian. } assert (H₃ : is_cartesian_2cell_sfib (pr12 yy) (δ ▹ pr1 gg)). { apply Hgg. exact Hδ. } use (is_cartesian_2cell_sfib_postcomp _ _ H₁ (vcomp_is_cartesian_2cell_sfib _ H₂ H₃)). abstract (rewrite vcomp_whisker ; apply idpath). Defined. Definition local_cleaving_of_disp_map_bicat_lift : xx -->[ f ] yy. Proof. use make_disp_map_bicat_mor. - exact ff. - exact local_cleaving_of_disp_map_bicat_cartesian. - exact (inv_of_invertible_2cell γ). Defined. Definition local_cleaving_of_disp_map_bicat_cell : local_cleaving_of_disp_map_bicat_lift ==>[ α ] gg. Proof. use make_disp_map_bicat_cell. - exact (internal_sfib_cleaving_lift_cell _ H ((pr12 xx ◃ α) • pr22 gg)). - abstract (cbn ; etrans ; [ apply maponpaths ; apply internal_sfib_cleaving_over | ] ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; apply idpath). Defined. End LocalLift. Definition local_cleaving_of_disp_map_bicat : local_cleaving DD. Proof. intros x y xx yy f g gg α. simple refine (_ ,, _ ,, _). - exact (local_cleaving_of_disp_map_bicat_lift gg α). - exact (local_cleaving_of_disp_map_bicat_cell gg α). - apply disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell. apply internal_sfib_cleaving_is_cartesian. Defined. End LocalCleaving. Definition contravariant_disp_map_bicat_local_iso_cleaving (HD : is_contravariant_disp_map_bicat D) : local_iso_cleaving DD. Proof. apply local_cleaving_to_local_iso_cleaving. exact (local_cleaving_of_disp_map_bicat HD). Defined. Definition lwhisker_cartesian_disp_map_bicat (HD : is_contravariant_disp_map_bicat D) : lwhisker_cartesian DD. Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? H. apply disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell. apply (pr1 HD _ _ _ (pr22 yy)). apply disp_map_is_cartesian_2cell_to_is_cartesian_2cell_sfib. - exact HD. - exact H. Defined. Definition rwhisker_cartesian_disp_map_bicat (HD : is_contravariant_disp_map_bicat D) : rwhisker_cartesian DD. Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? H. apply disp_map_is_cartesian_2cell_sfib_to_is_cartesian_2cell. apply (pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 hh)). apply disp_map_is_cartesian_2cell_to_is_cartesian_2cell_sfib. - apply HD. - exact H. Qed. (** 6. Local opcleaving *) Section LocalOpCleaving. Context (HD : is_covariant_disp_map_bicat D). Section LocalLift. Context {x y : B} {xx : DD x} {yy : DD y} {f g : x --> y} (ff : xx -->[ f ] yy) (α : f ==> g). Let H : internal_sopfib (pr12 yy) := pr1 HD _ _ _ (pr22 yy). Let gg : pr1 xx --> pr1 yy := internal_sopfib_opcleaving_lift_mor _ H ((pr22 ff)^-1 • (pr12 xx ◃ α)). Let β : pr1 ff ==> gg := internal_sopfib_opcleaving_lift_cell _ H ((pr22 ff)^-1 • (pr12 xx ◃ α)). Let γ : invertible_2cell (pr12 xx · g) (gg · pr12 yy) := internal_sopfib_opcleaving_com _ H ((pr22 ff)^-1 • (pr12 xx ◃ α)). Let Hff : mor_preserves_opcartesian (pr12 xx) (pr12 yy) (pr1 ff) := pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 ff). Definition local_opcleaving_of_disp_map_bicat_opcartesian : pred_mor D (pr12 xx) (pr12 yy) gg. Proof. apply HD. intros z h₁ h₂ δ Hδ. assert (H₁ : is_opcartesian_2cell_sopfib (pr12 yy) (h₂ ◃ β)). { apply (pr2 H). apply internal_sopfib_opcleaving_is_opcartesian. } assert (H₂ : is_opcartesian_2cell_sopfib (pr12 yy) (h₁ ◃ β)). { apply (pr2 H). apply internal_sopfib_opcleaving_is_opcartesian. } assert (H₃ : is_opcartesian_2cell_sopfib (pr12 yy) (δ ▹ pr1 ff)). { apply Hff. exact Hδ. } use (is_opcartesian_2cell_sopfib_precomp _ _ H₂ (vcomp_is_opcartesian_2cell_sopfib _ H₃ H₁)). abstract (rewrite vcomp_whisker ; apply idpath). Defined. Definition local_opcleaving_of_disp_map_bicat_lift : xx -->[ g ] yy. Proof. use make_disp_map_bicat_mor. - exact gg. - exact local_opcleaving_of_disp_map_bicat_opcartesian. - exact γ. Defined. Definition local_opcleaving_of_disp_map_bicat_cell : ff ==>[ α ] local_opcleaving_of_disp_map_bicat_lift. Proof. use make_disp_map_bicat_cell. - exact (internal_sopfib_opcleaving_lift_cell _ H ((pr22 ff)^-1 • (pr12 xx ◃ α))). - abstract (cbn ; etrans ; [ apply maponpaths ; apply internal_sopfib_opcleaving_over | ] ; rewrite !vassocr ; rewrite vcomp_rinv ; rewrite id2_left ; apply idpath). Defined. End LocalLift. Definition local_opcleaving_of_disp_map_bicat : local_opcleaving DD. Proof. intros x y xx yy f g ff α. simple refine (_ ,, _ ,, _). - exact (local_opcleaving_of_disp_map_bicat_lift ff α). - exact (local_opcleaving_of_disp_map_bicat_cell ff α). - apply disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. apply internal_sopfib_opcleaving_is_opcartesian. Defined. End LocalOpCleaving. Definition covariant_disp_map_bicat_local_iso_cleaving (HD : is_covariant_disp_map_bicat D) : local_iso_cleaving DD. Proof. apply local_opcleaving_to_local_iso_cleaving. exact (local_opcleaving_of_disp_map_bicat HD). Defined. Definition lwhisker_opcartesian_disp_map_bicat (HD : is_covariant_disp_map_bicat D) : lwhisker_opcartesian DD. Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? H. apply disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. apply (pr1 HD _ _ _ (pr22 yy)). apply disp_map_is_opcartesian_2cell_to_is_opcartesian_2cell_sopfib. - exact HD. - exact H. Defined. Definition rwhisker_opcartesian_disp_map_bicat (HD : is_covariant_disp_map_bicat D) : rwhisker_opcartesian DD. Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? H. apply disp_map_is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. apply (pr1 (pr2 HD _ _ _ _ _ _ _) (pr12 hh)). apply disp_map_is_opcartesian_2cell_to_is_opcartesian_2cell_sopfib. - apply HD. - exact H. Qed. End DispMapBicatCleaving. (** 7. Specialized to internal Street (op)fibrations *) Section StreetFibs. Context (B : bicat_with_pb). Definition global_cleaving_sfib : global_cleaving (cod_sfibs B) := global_cleaving_of_disp_map_bicat (sfib_disp_map_bicat B). Definition local_cleaving_sfib : local_cleaving (cod_sfibs B) := local_cleaving_of_disp_map_bicat (sfib_disp_map_bicat B) (sfib_disp_map_bicat_is_contravariant B). Definition lwhisker_cartesian_sfib : lwhisker_cartesian (cod_sfibs B) := lwhisker_cartesian_disp_map_bicat (sfib_disp_map_bicat B) (sfib_disp_map_bicat_is_contravariant B). Definition rwhisker_cartesian_sfib : rwhisker_cartesian (cod_sfibs B) := rwhisker_cartesian_disp_map_bicat (sfib_disp_map_bicat B) (sfib_disp_map_bicat_is_contravariant B). Definition global_cleaving_sopfib : global_cleaving (cod_sfibs B) := global_cleaving_of_disp_map_bicat (sfib_disp_map_bicat B). Definition local_opcleaving_sopfib : local_opcleaving (cod_sopfibs B) := local_opcleaving_of_disp_map_bicat (sopfib_disp_map_bicat B) (sopfib_disp_map_bicat_is_covariant B). Definition lwhisker_opcartesian_sopfib : lwhisker_opcartesian (cod_sopfibs B) := lwhisker_opcartesian_disp_map_bicat (sopfib_disp_map_bicat B) (sopfib_disp_map_bicat_is_covariant B). Definition rwhisker_opcartesian_sopfib : rwhisker_opcartesian (cod_sopfibs B) := rwhisker_opcartesian_disp_map_bicat (sopfib_disp_map_bicat B) (sopfib_disp_map_bicat_is_covariant B). End StreetFibs. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/FibrationCleaving.v000066400000000000000000000511101451125700300317720ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Local Open Scope cat. (** Characterization of cartesian 2-cells *) Definition cleaving_of_cleaving_is_cartesian_2cell {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} {α : F₁ ==> F₂} {D₁ : disp_bicat_of_cleaving C₁} {D₂ : disp_bicat_of_cleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : FF₁ ==>[ α ] FF₂) (Hαα : ∏ (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x), is_cartesian (pr11 αα x xx)) : is_cartesian_2cell disp_bicat_of_cleaving αα. Proof. intros G GG β βα. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply disp_bicat_of_cleaving | ] ; use subtypePath ; [ intro ; apply isapropunit | ] ; use disp_nat_trans_eq ; intros x xx ; assert (p₁ := maponpaths (λ z, (pr11 z) x xx) (pr2 φ₁)) ; assert (p₂ := maponpaths (λ z, (pr11 z) x xx) (pr2 φ₂)) ; cbn in p₁, p₂ ; pose (r := p₁ @ !p₂) ; use (cartesian_factorisation_unique (Hαα x xx)) ; exact r). - simple refine ((_ ,, tt) ,, _). + exact (cartesian_factorisation_disp_nat_trans (pr1 αα) (pr1 βα) Hαα). + abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; use subtypePath ; [ intro ; apply isaprop_disp_nat_trans_axioms| ] ; use funextsec ; intro x ; use funextsec ; intro xx ; apply cartesian_factorisation_commutes). Defined. Section CleavingOfCleavingPointwiseCartesian. Context {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} {α : F₁ ==> F₂} {D₁ : disp_bicat_of_cleaving C₁} {D₂ : disp_bicat_of_cleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : FF₁ ==>[ α ] FF₂) (Hαα : is_cartesian_2cell disp_bicat_of_cleaving αα). Let lift_FF₂ : disp_functor F₁ (pr11 D₁) (pr11 D₂) := cartesian_factorisation_disp_functor (pr2 D₂) (pr1 FF₂) α. Let lift_FF₂_fib : D₁ -->[ F₁ ] D₂. Proof. refine (lift_FF₂ ,, _). apply cartesian_factorisation_disp_functor_is_cartesian. apply (pr2 FF₂). Defined. Definition pointwise_cartesian_lift_data : disp_nat_trans_data (pr1 α) lift_FF₂ (pr11 FF₂) := λ x xx, cleaving_mor (pr2 D₂) (pr1 α x) (pr11 FF₂ x xx). Definition pointwise_cartesian_lift_axioms : disp_nat_trans_axioms pointwise_cartesian_lift_data. Proof. intros x y f xx yy ff. apply cartesian_factorisation_commutes. Qed. Definition pointwise_cartesian_lift : disp_nat_trans α (cartesian_factorisation_disp_functor (pr2 D₂) (pr1 FF₂) α) (pr11 FF₂) := (pointwise_cartesian_lift_data ,, pointwise_cartesian_lift_axioms). Definition pointwise_cartesian_lift_fib : lift_FF₂_fib ==>[ α ] FF₂ := (pointwise_cartesian_lift ,, tt). Definition pointwise_cartesian_lift_data_pointwise_cartesian : ∏ (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x), is_cartesian (pointwise_cartesian_lift x xx). Proof. intros x xx. apply cartesian_lift_is_cartesian. Qed. Definition pointwise_cartesian_lift_data_is_cartesian : is_cartesian_2cell disp_bicat_of_cleaving pointwise_cartesian_lift_fib. Proof. apply cleaving_of_cleaving_is_cartesian_2cell. exact pointwise_cartesian_lift_data_pointwise_cartesian. Defined. Section PointwiseCartesian. Context (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x). Local Lemma cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian_path : (pr11 αα) x xx = transportf (λ z, _ -->[ z ] _) (nat_trans_eq_pointwise (id2_left α) x) (cartesian_factorisation_disp_nat_trans_data pointwise_cartesian_lift (pr1 (transportb (λ z, ∑ _ : disp_nat_trans z (pr11 FF₁) (pr11 FF₂), unit) (id2_left α) αα)) pointwise_cartesian_lift_data_pointwise_cartesian x xx ;; pointwise_cartesian_lift_data x xx)%mor_disp. Proof. pose (maponpaths (λ z, pr11 z x xx) (is_cartesian_2cell_unique_iso_com Hαα pointwise_cartesian_lift_data_is_cartesian)) as p. cbn in p. rewrite pr1_transportf in p. exact (p @ (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _ _ _ _ _)). Qed. Definition cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian : is_cartesian (pr11 αα x xx). Proof. refine (transportb is_cartesian cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian_path _). apply is_cartesian_transportf. use is_cartesian_comp_disp. - exact (is_cartesian_z_iso_disp (disp_bicat_of_cleaving_disp_invertible_2cell_pointwise_inv _ _ (pr2 (is_cartesian_2cell_unique_iso Hαα pointwise_cartesian_lift_data_is_cartesian)) xx)). - apply pointwise_cartesian_lift_data_pointwise_cartesian. Defined. End PointwiseCartesian. End CleavingOfCleavingPointwiseCartesian. Definition cleaving_of_cleaving_local_cleaving : local_cleaving disp_bicat_of_cleaving. Proof. intros C₁ C₂ D₁ D₂ F G GG α. cbn in *. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (cartesian_factorisation_disp_functor (pr2 D₂) (pr1 GG) α). + apply cartesian_factorisation_disp_functor_is_cartesian. exact (pr2 GG). - simpl. simple refine ((_ ,, tt) ,, _). + exact (cartesian_factorisation_disp_functor_cell (pr2 D₂) (pr1 GG) α). + apply cleaving_of_cleaving_is_cartesian_2cell. apply cartesian_factorisation_disp_functor_cell_is_cartesian. Defined. Definition cleaving_of_cleaving_local_iso_cleaving : local_iso_cleaving disp_bicat_of_cleaving. Proof. apply local_cleaving_to_local_iso_cleaving. exact cleaving_of_cleaving_local_cleaving. Defined. Definition cleaving_of_cleaving_lwhisker_cartesian : lwhisker_cartesian disp_bicat_of_cleaving. Proof. intros C₁ C₂ C₃ D₁ D₂ D₃ H F G HH FF GG α αα Hαα. apply cleaving_of_cleaving_is_cartesian_2cell. intros x xx. cbn. apply cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian. exact Hαα. Defined. Definition cleaving_of_cleaving_rwhisker_cartesian : rwhisker_cartesian disp_bicat_of_cleaving. Proof. intros C₁ C₂ C₃ D₁ D₂ D₃ H F G HH FF GG α αα Hαα. apply cleaving_of_cleaving_is_cartesian_2cell. intros x xx. pose (pr2 GG) as pr2GG. cbn ; cbn in pr2GG. apply pr2GG. apply cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian. exact Hαα. Defined. (** Global cleaving *) Definition cleaving_of_cleaving_lift_obj {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_cleaving C₂) (F : C₁ --> C₂) : disp_bicat_of_cleaving C₁. Proof. simple refine ((_ ,, _) ,, _). - exact (reindex_disp_cat F (pr11 D₂)). - exact (is_univalent_reindex_disp_cat F _ (pr21 D₂)). - exact (cleaving_reindex_disp_cat F _ (pr2 D₂)). Defined. Definition cleaving_of_cleaving_lift_mor {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_cleaving C₂) (F : C₁ --> C₂) : cleaving_of_cleaving_lift_obj D₂ F -->[ F ] D₂. Proof. simple refine (_ ,, _). - exact (reindex_disp_cat_disp_functor F (pr11 D₂)). - exact (is_cartesian_reindex_disp_cat_disp_functor F (pr11 D₂) (pr2 D₂)). Defined. Definition cleaving_of_cleaving_lift_mor_lift_1cell {C₁ C₂ C₃ : bicat_of_univ_cats} {D₂ : disp_bicat_of_cleaving C₂} {D₃ : disp_bicat_of_cleaving C₃} {F : C₁ --> C₂} {H : C₃ --> C₁} (HH : D₃ -->[ H · F] D₂) : lift_1cell_factor disp_bicat_of_cleaving (cleaving_of_cleaving_lift_mor D₂ F) HH. Proof. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (lift_functor_into_reindex (pr1 HH)). + exact (is_cartesian_lift_functor_into_reindex (pr2 HH)). - simple refine ((_ ,, tt) ,, _). + exact (lift_functor_into_reindex_commute (pr1 HH)). + apply disp_bicat_of_cleaving_is_disp_invertible_2cell. intros x xx. apply id_is_z_iso_disp. Defined. Section Lift2CellCleaving. Context {C₁ C₂ C₃ : bicat_of_univ_cats} {F : C₁ --> C₂} {H₁ H₂ : C₃ --> C₁} {α : H₁ ==> H₂} {D₂ : disp_bicat_of_cleaving C₂} {D₃ : disp_bicat_of_cleaving C₃} {HH₁ : D₃ -->[ H₁ · F] D₂} {HH₂ : D₃ -->[ H₂ · F] D₂} (αα : HH₁ ==>[ α ▹ F] HH₂) (Lh : lift_1cell_factor _ (cleaving_of_cleaving_lift_mor D₂ F) HH₁) (Lh' : lift_1cell_factor _ (cleaving_of_cleaving_lift_mor D₂ F) HH₂). Definition cleaving_of_cleaving_lift_2cell_data : disp_nat_trans_data (pr1 α) (pr11 Lh : disp_functor _ _ _) (pr11 Lh' : disp_functor _ _ _). Proof. intros x xx. simple refine (transportf (λ z, _ -->[ z ] _) _ (pr1 (pr112 Lh) x xx ;; pr11 αα x xx ;; inv_mor_disp_from_z_iso (disp_bicat_of_cleaving_disp_invertible_2cell_pointwise_inv _ (pr2 Lh') (pr22 Lh') xx))%mor_disp). abstract (cbn ; unfold precomp_with ; cbn ; rewrite !id_left, id_right ; apply idpath). Defined. Definition cleaving_of_cleaving_axioms : disp_nat_trans_axioms cleaving_of_cleaving_lift_2cell_data. Proof. intros x y f xx yy ff. unfold cleaving_of_cleaving_lift_2cell_data. cbn. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { pose (disp_nat_trans_ax (pr112 Lh) ff) as d. cbn in d. rewrite !assoc_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. do 2 apply maponpaths_2. exact d. } clear d. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite !assoc_disp_var. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. etrans. { apply maponpaths. apply maponpaths_2. exact (disp_nat_trans_ax (pr1 αα) ff). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. do 2 apply maponpaths. apply idpath. } rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. do 3 apply maponpaths. exact (disp_nat_trans_ax (pr11 (pr22 Lh')) ff). } unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. cbn. refine (!_). etrans. { apply transportf_reindex. } rewrite transport_f_f. refine (!_). rewrite !assoc_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition cleaving_of_cleaving_lift_2cell : disp_nat_trans α (pr11 Lh : disp_functor _ _ _) (pr11 Lh' : disp_functor _ _ _). Proof. simple refine (_ ,, _). - exact cleaving_of_cleaving_lift_2cell_data. - exact cleaving_of_cleaving_axioms. Defined. Definition cleaving_of_cleaving_unique_2_lifts (φ₁ φ₂ : lift_2cell_factor_type _ _ αα Lh Lh') : φ₁ = φ₂. Proof. use subtypePath. { intro. apply disp_bicat_of_cleaving. } use subtypePath. { intro. apply isapropunit. } use disp_nat_trans_eq. intros x xx. pose (maponpaths (λ d, pr11 d x xx) (pr2 φ₁)) as p₁. cbn in p₁. rewrite pr1_transportf in p₁. unfold disp_cell_lift_1cell_factor in p₁. pose (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans (pr11 φ₁) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx) as p₁'. pose (!p₁' @ p₁) as r₁. pose (maponpaths (λ d, pr11 d x xx) (pr2 φ₂)) as p₂. cbn in p₂. rewrite pr1_transportf in p₂. unfold disp_cell_lift_1cell_factor in p₂. pose (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans (pr11 φ₂) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx) as p₂'. pose (!p₂' @ p₂) as r₂. cbn in r₂. assert (r := r₁ @ !r₂). clear p₁ p₂ p₁' p₂' r₁ r₂. cbn in r. assert (r' := maponpaths (λ z₁, transportb (λ z₂, _ -->[ z₂ ] _) (nat_trans_eq_pointwise (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) x) z₁) r). clear r ; cbn in r'. rewrite !transportbfinv in r'. assert (p := transportf_transpose_left (inv_mor_after_z_iso_disp (disp_bicat_of_cleaving_disp_invertible_2cell_pointwise_inv _ (pr2 Lh') (pr22 Lh') xx))). simpl in p. cbn. refine (id_right_disp_var _ @ _ @ !(id_right_disp_var _)). cbn. etrans. { do 2 apply maponpaths. exact (!p). } refine (!_). etrans. { do 2 apply maponpaths. exact (!p). } clear p. refine (!_). cbn. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite !assoc_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact r'. } apply maponpaths_2. apply homset_property. Qed. Definition cleaving_of_cleaving_lift_mor_lift_2cell : lift_2cell_factor _ _ αα Lh Lh'. Proof. use iscontraprop1. - use invproofirrelevance. intros φ₁ φ₂. exact (cleaving_of_cleaving_unique_2_lifts φ₁ φ₂). - simple refine ((_ ,, tt) ,, _). + exact cleaving_of_cleaving_lift_2cell. + abstract (cbn ; use subtypePath ; [ intro ; apply isapropunit | ] ; use disp_nat_trans_eq ; intros x xx ; cbn ; rewrite pr1_transportf ; unfold disp_cell_lift_1cell_factor ; refine (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans cleaving_of_cleaving_lift_2cell (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx @ _) ; cbn ; unfold cleaving_of_cleaving_lift_2cell_data ; rewrite !mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; rewrite !assoc_disp_var ; rewrite !transport_f_f ; etrans ; [ do 3 apply maponpaths ; apply (z_iso_disp_after_inv_mor (disp_bicat_of_cleaving_disp_invertible_2cell_pointwise_inv (id2_invertible_2cell (H₂ · F)) (pr2 Lh') (pr22 Lh') xx)) | ] ; unfold transportb ; rewrite !mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite id_right_disp ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. End Lift2CellCleaving. Definition cleaving_of_cleaving_lift_mor_cartesian {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_cleaving C₂) (F : C₁ --> C₂) : cartesian_1cell disp_bicat_of_cleaving (cleaving_of_cleaving_lift_mor D₂ F). Proof. simple refine (_ ,, _). - intros C₃ D₃ H HH. exact (cleaving_of_cleaving_lift_mor_lift_1cell HH). - intros C₃ D₃ H₁ H₂ HH₁ HH₂ α αα Lh Lh'. exact (cleaving_of_cleaving_lift_mor_lift_2cell αα Lh Lh'). Defined. Definition cleaving_of_cleaving_global_cleaving : global_cleaving disp_bicat_of_cleaving. Proof. intros C₁ C₂ D₂ F. simple refine (_ ,, _ ,, _). - exact (cleaving_of_cleaving_lift_obj D₂ F). - exact (cleaving_of_cleaving_lift_mor D₂ F). - exact (cleaving_of_cleaving_lift_mor_cartesian D₂ F). Defined. Definition cleaving_of_cleaving : cleaving_of_bicats disp_bicat_of_cleaving. Proof. repeat split. - exact cleaving_of_cleaving_local_cleaving. - exact cleaving_of_cleaving_global_cleaving. - exact cleaving_of_cleaving_lwhisker_cartesian. - exact cleaving_of_cleaving_rwhisker_cartesian. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/FunctorsIntoCatCleaving.v000066400000000000000000000231621451125700300331500ustar00rootroot00000000000000(****************************************************************************************** The fibrations of functors into the category of strict categories In this file, we prove that the displayed bicategory of functors into the category of strict categories has a local opcleaving, a local isocleaving, and a global cleaving. Contents: 1. Local opcleaving 2. Local isocleaving 3. Global cleaving ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.StrictCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FunctorsIntoCat. Local Open Scope cat. (** 1. Local opcleaving *) Definition functors_into_cat_is_opcartesian_2cell {C₁ C₂ : bicat_of_strict_cats} {F₁ F₂ : C₁ --> C₂} {α : F₁ ==> F₂} {G₁ : disp_bicat_of_functors_into_cat C₁} {G₂ : disp_bicat_of_functors_into_cat C₂} {β₁ : G₁ -->[ F₁ ] G₂} {β₂ : G₁ -->[ F₂ ] G₂} (p : β₁ ==>[ α ] β₂) : is_opcartesian_2cell disp_bicat_of_functors_into_cat p. Proof. intros H GH γ ββ. use iscontraprop1. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use impred ; intro. apply homset_property. + apply disp_bicat_of_functors_into_cat. - simple refine (_ ,, _). + intro x ; cbn. refine (_ @ ββ x). refine (!_). etrans. { apply maponpaths. apply (functor_comp G₂). } refine (assoc (pr1 β₁ x) (# (pr1 G₂) (pr1 α x)) _ @ _). apply maponpaths_2. exact (p x). + apply functors_into_cat_disp_2cells_isaprop. Qed. Definition functors_into_cat_local_opcleaving : local_opcleaving disp_bicat_of_functors_into_cat. Proof. intros C₁ C₂ G₁ G₂ F₁ F₂ α β. simple refine (_ ,, _ ,, functors_into_cat_is_opcartesian_2cell _). - exact (nat_trans_comp _ _ _ α (post_whisker β _)). - abstract (intro x ; cbn ; apply idpath). Defined. (** 2. Local isocleaving *) Definition functors_into_cat_local_iso_cleaving : local_iso_cleaving disp_bicat_of_functors_into_cat. Proof. intros C₁ C₂ G₁ G₂ F₁ F₂ α β. simple refine (_ ,, _ ,, _). - exact (nat_trans_comp _ _ _ α (post_whisker (β^-1) _)). - abstract (intro x ; refine (assoc' (pr1 α x) _ _ @ _ @ id_right _) ; apply maponpaths ; refine (!(functor_comp F₂ _ _) @ _ @ functor_id F₂ _) ; apply maponpaths ; exact (nat_trans_eq_pointwise (vcomp_linv β) x)). - apply functors_into_cat_disp_locally_groupoid. Defined. (** 3. Global cleaving *) Definition functors_into_cat_nat_iso_is_cartesian_1cell {C₁ C₂ : bicat_of_strict_cats} {F : C₁ --> C₂} {G₁ : disp_bicat_of_functors_into_cat C₁} {G₂ : disp_bicat_of_functors_into_cat C₂} (α : G₁ -->[ F ] G₂) (Hα : is_nat_z_iso (pr1 α)) : cartesian_1cell disp_bicat_of_functors_into_cat α. Proof. split. - intros C₃ G₃ H HF. simple refine (_ ,, _). + exact (nat_trans_comp _ _ _ HF (pre_whisker _ (nat_z_iso_inv (make_nat_z_iso _ _ α Hα)))). + simple refine (_ ,, _). * abstract (intro x ; cbn ; etrans ; [ apply maponpaths ; apply (functor_id G₂) | ] ; refine (id_right (pr1 HF x · _ · _) @ _) ; refine (_ @ id_right _) ; rewrite assoc' ; apply maponpaths ; apply Hα). * apply functors_into_cat_disp_locally_groupoid. - intros C₃ G₃ F₁ F₂ β γ δ p ℓ₁ ℓ₂. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply disp_bicat_of_functors_into_cat | ] ; apply functors_into_cat_disp_2cells_isaprop). + simple refine (_ ,, _). * abstract (intro x ; pose (pr12 ℓ₁ x) as q₁ ; pose (pr12 ℓ₂ x @ !(p x) @ maponpaths (λ z, z · _) (!q₁)) as q₂ ; rewrite !(functor_id G₂) in q₂ ; pose (!(id_right (pr11 ℓ₂ x · pr1 α (pr1 F₂ x))) @ q₂) as q₃ ; pose (q₃ @ maponpaths (λ z, z · # (pr1 G₂) _) (id_right _) @ assoc' _ _ _) as q₄ ; pose (q₄ @ maponpaths (λ z, _ · z) (!(nat_trans_ax α _ _ (pr1 δ x)))) as q₅ ; pose (maponpaths (λ z, z · nat_z_iso_inv (make_nat_z_iso _ _ _ Hα) (pr1 F₂ x)) q₅) as q₆ ; refine (_ @ !q₆ @ _) ; [ refine (_ @ assoc (pr11 ℓ₁ x) _ _) ; apply maponpaths ; refine (_ @ assoc _ _ _) ; refine (!(id_right _) @ _) ; apply maponpaths ; refine (!_) ; apply Hα | refine (assoc' (pr11 ℓ₂ x) _ _ @ _) ; refine (_ @ id_right _) ; apply maponpaths ; apply Hα ]). * apply functors_into_cat_disp_2cells_isaprop. Defined. Section CartesianIsNatIso. Context {C₁ C₂ : bicat_of_strict_cats} {F : C₁ --> C₂} {G₁ : disp_bicat_of_functors_into_cat C₁} {G₂ : disp_bicat_of_functors_into_cat C₂} (α : G₁ -->[ F ] G₂) (Hα : cartesian_1cell disp_bicat_of_functors_into_cat α). Local Definition functors_into_cat_cartesian_1cell_is_nat_iso_inv (x : pr1 C₁) : (F ∙ G₂) x --> pr1 G₁ x := let l := pr1 Hα C₁ (F ∙ G₂) (functor_identity _) (nat_trans_id _) in pr1 (pr1 l) x. Local Lemma functors_into_cat_cartesian_1cell_is_nat_iso_is_inverse (x : pr1 C₁) : is_inverse_in_precat (pr1 α x) (functors_into_cat_cartesian_1cell_is_nat_iso_inv x). Proof. pose (l := pr1 Hα C₁ (F ∙ G₂) (functor_identity _) (nat_trans_id _)). split ; unfold functors_into_cat_cartesian_1cell_is_nat_iso_inv. - cbn. assert (α ==>[ nat_trans_id (functor_identity _) ▹ F] α) as p. { intro z ; cbn. etrans. { apply maponpaths. etrans. { apply maponpaths. apply (functor_id F). } apply (functor_id G₂). } apply (id_right (pr1 α z)). } simple refine (_ @ @cartesian_1cell_lift_2cell _ _ _ _ _ _ _ _ Hα C₁ G₁ (functor_identity _) (functor_identity _) α α (nat_trans_id _) p (nat_trans_comp _ _ _ α (pr1 l) ,, _) (nat_trans_id _ ,, _) x). + cbn. refine (!_). etrans. { apply maponpaths. apply (functor_id G₁). } apply (id_right (pr1 α x · _)). + simple refine (_ ,, _). * intro z. cbn. refine (_ @ id_right (pr1 α z)). refine (_ @ maponpaths (λ z, _ · z) (pr12 l z)). cbn. refine (assoc' (pr1 α z · pr11 l z) (pr1 α z) _ @ _). refine (assoc' _ _ _ @ _). apply maponpaths. apply assoc. * apply functors_into_cat_disp_locally_groupoid. + simple refine (_ ,, _). * intro z. cbn. etrans. { apply maponpaths. apply (functor_id G₂). } etrans. { apply (id_right (_ · pr1 α z)). } apply (id_left (pr1 α z)). * apply functors_into_cat_disp_locally_groupoid. - refine (_ @ pr12 l x) ; cbn. refine (!_). etrans. { apply maponpaths. apply (functor_id G₂). } apply (id_right (pr11 l x · _)). Qed. Definition functors_into_cat_cartesian_1cell_is_nat_iso : is_nat_z_iso (pr1 α). Proof. intro x. use make_is_z_isomorphism. - exact (functors_into_cat_cartesian_1cell_is_nat_iso_inv x). - exact (functors_into_cat_cartesian_1cell_is_nat_iso_is_inverse x). Defined. End CartesianIsNatIso. Definition functors_into_cat_global_cleaving : global_cleaving disp_bicat_of_functors_into_cat. Proof. intros C₁ C₂ G₁ F. refine (F ∙ G₁ ,, nat_trans_id _ ,, _). apply functors_into_cat_nat_iso_is_cartesian_1cell. intro. apply is_z_isomorphism_identity. Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/OpFibrationCleaving.v000066400000000000000000000514711451125700300323030ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Local Open Scope cat. (** Characterization of opcartesian 2-cells *) Definition opcleaving_of_opcleaving_is_opcartesian_2cell {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} {α : F₁ ==> F₂} {D₁ : disp_bicat_of_opcleaving C₁} {D₂ : disp_bicat_of_opcleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : FF₁ ==>[ α ] FF₂) (Hαα : ∏ (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x), is_opcartesian (pr11 αα x xx)) : is_opcartesian_2cell disp_bicat_of_opcleaving αα. Proof. intros G GG β βα. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply disp_cellset_property | ] ; use subtypePath ; [ intro ; apply isapropunit | ] ; use disp_nat_trans_eq ; intros x xx ; assert (p₁ := maponpaths (λ z, (pr11 z) x xx) (pr2 φ₁)) ; assert (p₂ := maponpaths (λ z, (pr11 z) x xx) (pr2 φ₂)) ; cbn in p₁, p₂ ; pose (r := p₁ @ !p₂) ; use (opcartesian_factorisation_unique (Hαα x xx)) ; exact r). - simple refine ((_ ,, tt) ,, _). + exact (opcartesian_factorisation_disp_nat_trans (pr1 αα) (pr1 βα) Hαα). + abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; use subtypePath ; [ intro ; apply isaprop_disp_nat_trans_axioms| ] ; use funextsec ; intro x ; use funextsec ; intro xx ; apply opcartesian_factorisation_commutes). Defined. (** Characterization of cartesian 2-cells *) Section OpCleavingOfOpCleavingPointwiseCartesian. Context {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} {α : F₁ ==> F₂} {D₁ : disp_bicat_of_opcleaving C₁} {D₂ : disp_bicat_of_opcleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : FF₁ ==>[ α ] FF₂) (Hαα : is_opcartesian_2cell disp_bicat_of_opcleaving αα). Let lift_FF₂ : disp_functor F₂ (pr11 D₁) (pr11 D₂) := opcartesian_factorisation_disp_functor (pr2 D₂) (pr1 FF₁) α. Let lift_FF₂_opfib : D₁ -->[ F₂ ] D₂. Proof. refine (lift_FF₂ ,, _). apply opcartesian_factorisation_disp_functor_is_opcartesian. apply (pr2 FF₁). Defined. Definition pointwise_opcartesian_lift_data : disp_nat_trans_data (pr1 α) (pr11 FF₁) lift_FF₂ := λ x xx, opcleaving_mor (pr2 D₂) (pr1 α x) (pr11 FF₁ x xx). Definition pointwise_opcartesian_lift_axioms : disp_nat_trans_axioms pointwise_opcartesian_lift_data. Proof. intros x y f xx yy ff. refine (!_). etrans. { apply maponpaths. apply opcartesian_factorisation_commutes. } unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Definition pointwise_opcartesian_lift : disp_nat_trans α (pr11 FF₁) lift_FF₂ := (pointwise_opcartesian_lift_data ,, pointwise_opcartesian_lift_axioms). Definition pointwise_opcartesian_lift_opfib : FF₁ ==>[ α ] lift_FF₂_opfib := (pointwise_opcartesian_lift ,, tt). Definition pointwise_opcartesian_lift_data_pointwise_opcartesian : ∏ (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x), is_opcartesian (pointwise_opcartesian_lift x xx). Proof. intros x xx. apply mor_of_opcartesian_lift_is_opcartesian. Qed. Definition pointwise_opcartesian_lift_data_is_opcartesian : is_opcartesian_2cell disp_bicat_of_opcleaving pointwise_opcartesian_lift_opfib. Proof. apply opcleaving_of_opcleaving_is_opcartesian_2cell. exact pointwise_opcartesian_lift_data_pointwise_opcartesian. Defined. Section PointwiseOpCartesian. Context (x : (C₁ : univalent_category)) (xx : (pr1 D₁ : disp_univalent_category _) x). Local Lemma opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian_path : pr11 αα x xx = transportf (λ z, _ -->[ z ] _) (nat_trans_eq_pointwise (id2_right α) x) (pointwise_opcartesian_lift_data x xx ;; opcartesian_factorisation_disp_nat_trans_data pointwise_opcartesian_lift (pr1 (transportb (λ z, ∑ _ : disp_nat_trans z (pr11 FF₁) (pr11 FF₂), unit) (id2_right α) αα)) pointwise_opcartesian_lift_data_pointwise_opcartesian x xx)%mor_disp. Proof. pose (maponpaths (λ z, pr11 z x xx) (is_opcartesian_2cell_unique_iso_com Hαα pointwise_opcartesian_lift_data_is_opcartesian)) as p. cbn in p. rewrite pr1_transportf in p. exact (p @ (@disp_nat_trans_transportf _ _ _ _ _ _ _ _ _ _ _ _ _ _)). Qed. Definition opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian : is_opcartesian (pr11 αα x xx). Proof. refine (transportb is_opcartesian opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian_path _). use is_opcartesian_transportf. use is_opcartesian_comp_disp. - apply pointwise_opcartesian_lift_data_pointwise_opcartesian. - exact (is_opcartesian_z_iso_disp (disp_bicat_of_opcleaving_disp_invertible_2cell_pointwise_inv _ _ (pr2 (is_opcartesian_2cell_unique_iso Hαα pointwise_opcartesian_lift_data_is_opcartesian)) xx)). Defined. End PointwiseOpCartesian. End OpCleavingOfOpCleavingPointwiseCartesian. Definition cleaving_of_opcleaving_local_opcleaving : local_opcleaving disp_bicat_of_opcleaving. Proof. intros C₁ C₂ D₁ D₂ F G FF α. cbn in *. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (opcartesian_factorisation_disp_functor (pr2 D₂) (pr1 FF) α). + apply opcartesian_factorisation_disp_functor_is_opcartesian. exact (pr2 FF). - simpl. simple refine ((_ ,, tt) ,, _). + exact (opcartesian_factorisation_disp_functor_cell (pr2 D₂) (pr1 FF) α). + apply opcleaving_of_opcleaving_is_opcartesian_2cell. apply opcartesian_factorisation_disp_functor_cell_is_opcartesian. Defined. Definition cleaving_of_opcleaving_local_iso_cleaving : local_iso_cleaving disp_bicat_of_opcleaving. Proof. apply local_opcleaving_to_local_iso_cleaving. exact cleaving_of_opcleaving_local_opcleaving. Defined. Definition cleaving_of_opcleaving_lwhisker_opcartesian : lwhisker_opcartesian disp_bicat_of_opcleaving. Proof. intros C₁ C₂ C₃ D₁ D₂ D₃ H F G HH FF GG α αα Hαα. apply opcleaving_of_opcleaving_is_opcartesian_2cell. intros x xx. cbn. apply opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian. exact Hαα. Defined. Definition cleaving_of_opcleaving_rwhisker_opcartesian : rwhisker_opcartesian disp_bicat_of_opcleaving. Proof. intros C₁ C₂ C₃ D₁ D₂ D₃ H F G HH FF GG α αα Hαα. apply opcleaving_of_opcleaving_is_opcartesian_2cell. intros x xx. pose (pr2 GG) as pr2GG. cbn ; cbn in pr2GG. apply pr2GG. apply opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian. exact Hαα. Defined. (** Global cleaving *) Definition cleaving_of_opcleaving_lift_obj {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_opcleaving C₂) (F : C₁ --> C₂) : disp_bicat_of_opcleaving C₁. Proof. simple refine ((_ ,, _) ,, _). - exact (reindex_disp_cat F (pr11 D₂)). - exact (is_univalent_reindex_disp_cat F _ (pr21 D₂)). - exact (opcleaving_reindex_disp_cat F _ (pr2 D₂)). Defined. Definition cleaving_of_opcleaving_lift_mor {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_opcleaving C₂) (F : C₁ --> C₂) : cleaving_of_opcleaving_lift_obj D₂ F -->[ F ] D₂. Proof. simple refine (_ ,, _). - exact (reindex_disp_cat_disp_functor F (pr11 D₂)). - exact (is_opcartesian_reindex_disp_cat_disp_functor F (pr11 D₂) (pr2 D₂)). Defined. Definition cleaving_of_opcleaving_lift_mor_lift_1cell {C₁ C₂ C₃ : bicat_of_univ_cats} {D₂ : disp_bicat_of_opcleaving C₂} {D₃ : disp_bicat_of_opcleaving C₃} {F : C₁ --> C₂} {H : C₃ --> C₁} (HH : D₃ -->[ H · F] D₂) : lift_1cell_factor disp_bicat_of_opcleaving (cleaving_of_opcleaving_lift_mor D₂ F) HH. Proof. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (lift_functor_into_reindex (pr1 HH)). + exact (is_opcartesian_lift_functor_into_reindex (pr2 HH)). - simple refine ((_ ,, tt) ,, _). + exact (lift_functor_into_reindex_commute (pr1 HH)). + apply disp_bicat_of_opcleaving_is_disp_invertible_2cell. intros x xx. apply id_is_z_iso_disp. Defined. Section Lift2CellOpCleaving. Context {C₁ C₂ C₃ : bicat_of_univ_cats} {F : C₁ --> C₂} {H₁ H₂ : C₃ --> C₁} {α : H₁ ==> H₂} {D₂ : disp_bicat_of_opcleaving C₂} {D₃ : disp_bicat_of_opcleaving C₃} {HH₁ : D₃ -->[ H₁ · F] D₂} {HH₂ : D₃ -->[ H₂ · F] D₂} (αα : HH₁ ==>[ α ▹ F] HH₂) (Lh : lift_1cell_factor _ (cleaving_of_opcleaving_lift_mor D₂ F) HH₁) (Lh' : lift_1cell_factor _ (cleaving_of_opcleaving_lift_mor D₂ F) HH₂). Definition cleaving_of_opcleaving_lift_2cell_data : disp_nat_trans_data (pr1 α) (pr11 Lh : disp_functor _ _ _) (pr11 Lh' : disp_functor _ _ _). Proof. intros x xx. simple refine (transportf (λ z, _ -->[ z ] _) _ (pr1 (pr112 Lh) x xx ;; pr11 αα x xx ;; inv_mor_disp_from_z_iso (disp_bicat_of_opcleaving_disp_invertible_2cell_pointwise_inv _ (pr2 Lh') (pr22 Lh') xx))%mor_disp). abstract (cbn ; unfold precomp_with ; cbn ; rewrite !id_left, id_right ; apply idpath). Defined. Definition cleaving_of_opcleaving_axioms : disp_nat_trans_axioms cleaving_of_opcleaving_lift_2cell_data. Proof. intros x y f xx yy ff. unfold cleaving_of_opcleaving_lift_2cell_data. cbn. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { pose (disp_nat_trans_ax (pr112 Lh) ff) as d. cbn in d. rewrite !assoc_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. do 2 apply maponpaths_2. exact d. } clear d. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite !assoc_disp_var. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. etrans. { apply maponpaths. apply maponpaths_2. exact (disp_nat_trans_ax (pr1 αα) ff). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. do 2 apply maponpaths. apply idpath. } rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. do 3 apply maponpaths. exact (disp_nat_trans_ax (pr11 (pr22 Lh')) ff). } unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. cbn. refine (!_). etrans. { apply transportf_reindex. } rewrite transport_f_f. refine (!_). rewrite !assoc_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition cleaving_of_opcleaving_lift_2cell : disp_nat_trans α (pr11 Lh : disp_functor _ _ _) (pr11 Lh' : disp_functor _ _ _). Proof. simple refine (_ ,, _). - exact cleaving_of_opcleaving_lift_2cell_data. - exact cleaving_of_opcleaving_axioms. Defined. Definition cleaving_of_opcleaving_unique_2_lifts (φ₁ φ₂ : lift_2cell_factor_type _ _ αα Lh Lh') : φ₁ = φ₂. Proof. use subtypePath. { intro. apply disp_bicat_of_opcleaving. } use subtypePath. { intro. apply isapropunit. } use disp_nat_trans_eq. intros x xx. pose (maponpaths (λ d, pr11 d x xx) (pr2 φ₁)) as p₁. cbn in p₁. rewrite pr1_transportf in p₁. unfold disp_cell_lift_1cell_factor in p₁. pose (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans (pr11 φ₁) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx) as p₁'. pose (!p₁' @ p₁) as r₁. pose (maponpaths (λ d, pr11 d x xx) (pr2 φ₂)) as p₂. cbn in p₂. rewrite pr1_transportf in p₂. unfold disp_cell_lift_1cell_factor in p₂. pose (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans (pr11 φ₂) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx) as p₂'. pose (!p₂' @ p₂) as r₂. cbn in r₂. assert (r := r₁ @ !r₂). clear p₁ p₂ p₁' p₂' r₁ r₂. cbn in r. assert (r' := maponpaths (λ z₁, transportb (λ z₂, _ -->[ z₂ ] _) (nat_trans_eq_pointwise (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) x) z₁) r). clear r ; cbn in r'. rewrite !transportbfinv in r'. assert (p := transportf_transpose_left (inv_mor_after_z_iso_disp (disp_bicat_of_opcleaving_disp_invertible_2cell_pointwise_inv _ (pr2 Lh') (pr22 Lh') xx))). simpl in p. cbn. refine (id_right_disp_var _ @ _ @ !(id_right_disp_var _)). cbn. etrans. { do 2 apply maponpaths. exact (!p). } refine (!_). etrans. { do 2 apply maponpaths. exact (!p). } clear p. refine (!_). cbn. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite !assoc_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact r'. } apply maponpaths_2. apply homset_property. Qed. Definition cleaving_of_opcleaving_lift_mor_lift_2cell : lift_2cell_factor _ _ αα Lh Lh'. Proof. use iscontraprop1. - use invproofirrelevance. intros φ₁ φ₂. exact (cleaving_of_opcleaving_unique_2_lifts φ₁ φ₂). - simple refine ((_ ,, tt) ,, _). + exact cleaving_of_opcleaving_lift_2cell. + abstract (cbn ; use subtypePath ; [ intro ; apply isapropunit | ] ; use disp_nat_trans_eq ; intros x xx ; cbn ; rewrite pr1_transportf ; unfold disp_cell_lift_1cell_factor ; refine (@disp_nat_trans_transportf _ _ _ _ (H₁ ∙ F) (H₂ ∙ F) _ _ (id2_right (α ▹ F) @ ! id2_left (α ▹ F)) (disp_functor_composite (pr11 Lh) (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr1 HH₂) (disp_nat_trans_comp (post_whisker_disp_nat_trans cleaving_of_opcleaving_lift_2cell (reindex_disp_cat_disp_functor F (pr11 D₂))) (pr112 Lh')) x xx @ _) ; cbn ; unfold cleaving_of_opcleaving_lift_2cell_data ; rewrite !mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; rewrite !assoc_disp_var ; rewrite !transport_f_f ; etrans ; [ do 3 apply maponpaths ; apply (z_iso_disp_after_inv_mor (disp_bicat_of_opcleaving_disp_invertible_2cell_pointwise_inv (id2_invertible_2cell (H₂ · F)) (pr2 Lh') (pr22 Lh') xx)) | ] ; unfold transportb ; rewrite !mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite id_right_disp ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. End Lift2CellOpCleaving. Definition cleaving_of_opcleaving_lift_mor_cartesian {C₁ C₂ : bicat_of_univ_cats} (D₂ : disp_bicat_of_opcleaving C₂) (F : C₁ --> C₂) : cartesian_1cell disp_bicat_of_opcleaving (cleaving_of_opcleaving_lift_mor D₂ F). Proof. simple refine (_ ,, _). - intros C₃ D₃ H HH. exact (cleaving_of_opcleaving_lift_mor_lift_1cell HH). - intros C₃ D₃ H₁ H₂ HH₁ HH₂ α αα Lh Lh'. exact (cleaving_of_opcleaving_lift_mor_lift_2cell αα Lh Lh'). Defined. Definition opcleaving_global_cleaving : global_cleaving disp_bicat_of_opcleaving. Proof. intros C₁ C₂ D₂ F. simple refine (_ ,, _ ,, _). - exact (cleaving_of_opcleaving_lift_obj D₂ F). - exact (cleaving_of_opcleaving_lift_mor D₂ F). - exact (cleaving_of_opcleaving_lift_mor_cartesian D₂ F). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/SliceCleaving.v000066400000000000000000000444001451125700300311200ustar00rootroot00000000000000(****************************************************************************************** The domain displayed bicategory has a cleaving Contents 1. Lax slices 1.1. Characterization of opcartesian 2-cells 1.2. Local opcleaving and isocleaving 1.3. Characterizations of cartesian 1-cells 1.4. Global cleaving 2. Oplax slices 2.1. Characterization of cartesian 2-cells 2.2. Local cleaving and isocleaving 2.3. Characterizations of cartesian 1-cells 2.4. Global cleaving 3. Slice bicatgories 3.1. Local isocleaving 3.2. Characterizations of cartesian 1-cells 3.3. Global cleaving ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.LaxSlice. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Local Open Scope cat. (** 1. Lax slices *) Section LaxSliceCleaving. Context {B : bicat} (a : B). (** 1.1. Characterization of opcartesian 2-cells *) Definition lax_slice_is_opcartesian_2cell {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : lax_slice_disp_bicat B a c₁} {t₂ : lax_slice_disp_bicat B a c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) : is_opcartesian_2cell (lax_slice_disp_bicat B a) αα. Proof. intros s₃ ss₃ γ γα. use iscontraprop1. - use isaproptotal2. + intro ; apply (lax_slice_disp_bicat B a). + intros. apply cellset_property. - simple refine (_ ,, _). + cbn in *. rewrite <- γα, <- αα. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. apply idpath. + apply cellset_property. Qed. (** 1.2. Local opcleaving and isocleaving *) Definition lax_slice_local_opcleaving : local_opcleaving (lax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ t₂ s₁ s₂ α β ; cbn in *. simple refine (_ ,, _) ; cbn. - exact (α • (β ▹ t₂)). - simple refine (idpath _ ,, _). apply lax_slice_is_opcartesian_2cell. Defined. Definition lax_slice_local_iso_cleaving : local_iso_cleaving (lax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ t₂ s₁ s₂ α β ; cbn in *. simple refine (α • (β^-1 ▹ s₂) ,, _ ,, _). - abstract (cbn ; rewrite !vassocl ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply id2_right). - apply lax_slice_disp_locally_groupoid. Defined. (** 1.3. Characterizations of cartesian 1-cells *) Definition lax_slice_invertible_2cell_is_cartesian_1cell {c₁ c₂ : B} {s : c₁ --> c₂} {t₁ : lax_slice_disp_bicat B a c₁} {t₂ : lax_slice_disp_bicat B a c₂} (ss : t₁ -->[ s ] t₂) (Hss : is_invertible_2cell ss) : cartesian_1cell (lax_slice_disp_bicat B a) ss. Proof. split. - intros c₃ t₃ s' ss'. simple refine (_ ,, _). + exact (ss' • rassociator _ _ _ • (s' ◃ Hss^-1)). + simple refine (_ ,, _). * abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply rassociator_lassociator). * apply lax_slice_disp_locally_groupoid. - cbn. intros c₃ t₃ s₁ s₂ α αα β ββ Lh Lh' ; cbn in *. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply (lax_slice_disp_bicat B a) | ] ; apply cellset_property). + cbn. simple refine (_ ,, _). * abstract (pose (pr12 Lh') as p ; cbn in p ; rewrite id2_rwhisker in p ; rewrite id2_right in p ; use (vcomp_rcancel (s₂ ◃ ss)) ; [ is_iso ; apply Hss | ] ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; refine (_ @ !p) ; clear p ; rewrite !vassocl ; pose (pr12 Lh) as p ; refine (_ @ ββ) ; cbn in p ; rewrite id2_rwhisker in p ; rewrite id2_right in p ; refine (_ @ maponpaths (λ z, z • _) p) ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_whisker ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; apply idpath). * apply cellset_property. Defined. Definition lax_slice_cartesian_1cell_is_invertible_2cell {c₁ c₂ : B} {s : c₁ --> c₂} {t₁ : lax_slice_disp_bicat B a c₁} {t₂ : lax_slice_disp_bicat B a c₂} (ss : t₁ -->[ s ] t₂) (Hss : cartesian_1cell (lax_slice_disp_bicat B a) ss) : is_invertible_2cell ss. Proof. cbn in *. pose (pr1 Hss c₁ (s · t₂) (id₁ _) (linvunitor _ • lassociator _ _ _)) as p. unfold lift_1cell_factor in p. cbn in p. pose (maponpaths (λ z, z • rassociator _ _ _) (pr12 p)) as d. cbn in d. rewrite id2_rwhisker in d. rewrite id2_right in d. rewrite !vassocl in d. rewrite !lassociator_rassociator in d. rewrite !id2_right in d. use make_is_invertible_2cell. - exact (pr1 p • lunitor _). - pose (@cartesian_1cell_lift_2cell _ _ _ _ _ _ _ _ Hss c₁ t₁ (id₁ _) (id₁ _) (ss • linvunitor _ • lassociator _ _ _) (ss • linvunitor _ • lassociator _ _ _) (id2 _)) as lift2. cbn in lift2. rewrite !id2_rwhisker, !id2_right in lift2. pose (lift2 (idpath _)) as l'. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite id2_left. refine (!(id2_right _) @ _). use (l' (ss • pr1 p ,, _) (linvunitor _ ,, _)) ; cbn. + simple refine (_ ,, _). * cbn. rewrite id2_rwhisker, id2_right. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite d. apply idpath. * apply lax_slice_disp_locally_groupoid. + simple refine (_ ,, _). * cbn. rewrite id2_rwhisker, id2_right. apply maponpaths_2. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. apply idpath. * apply lax_slice_disp_locally_groupoid. - rewrite !vassocl. rewrite <- vcomp_lunitor. rewrite !vassocr. rewrite d. apply linvunitor_lunitor. Qed. (** 1.4. Global cleaving *) Definition lax_slice_global_cleaving : global_cleaving (lax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ s. simple refine (s · t₁ ,, id₂ _ ,, _) ; cbn. apply lax_slice_invertible_2cell_is_cartesian_1cell. is_iso. Defined. End LaxSliceCleaving. (** 2. Oplax slices *) Section OplaxSliceCleaving. Context {B : bicat} (a : B). (** 2.1. Characterization of cartesian 2-cells *) Definition oplax_slice_is_cartesian_2cell {c₁ c₂ : B} {s₁ s₂ : c₁ --> c₂} {α : s₁ ==> s₂} {t₁ : oplax_slice_disp_bicat B a c₁} {t₂ : oplax_slice_disp_bicat B a c₂} {ss₁ : t₁ -->[ s₁ ] t₂} {ss₂ : t₁ -->[ s₂ ] t₂} (αα : ss₁ ==>[ α ] ss₂) : is_cartesian_2cell (oplax_slice_disp_bicat B a) αα. Proof. intros s₃ ss₃ γ γα. use iscontraprop1. - use isaproptotal2. + intro ; apply (oplax_slice_disp_bicat B a). + intros. apply cellset_property. - simple refine (_ ,, _). + cbn in *. rewrite <- αα, <- γα. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. apply idpath. + apply cellset_property. Qed. (** 2.2. Local cleaving and isocleaving *) Definition oplax_slice_local_cleaving : local_cleaving (oplax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ t₂ s₁ s₂ α β ; cbn in *. simple refine (_ ,, _) ; cbn. - exact ((β ▹ t₂) • α). - simple refine (idpath _ ,, _). apply oplax_slice_is_cartesian_2cell. Defined. Definition oplax_slice_local_iso_cleaving : local_iso_cleaving (oplax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ t₂ s₁ s₂ α β ; cbn in *. simple refine (_ ,, _ ,, _). - exact ((β ▹ s₂) • α). - abstract (cbn ; apply idpath). - apply oplax_slice_disp_locally_groupoid. Defined. (** 2.3. Characterizations of cartesian 1-cells *) Definition oplax_slice_invertible_2cell_is_cartesian_1cell {c₁ c₂ : B} {s : c₁ --> c₂} {t₁ : oplax_slice_disp_bicat B a c₁} {t₂ : oplax_slice_disp_bicat B a c₂} (ss : t₁ -->[ s ] t₂) (Hss : is_invertible_2cell ss) : cartesian_1cell (oplax_slice_disp_bicat B a) ss. Proof. split. - intros c₃ t₃ s' ss'. simple refine (_ ,, _). + exact ((s' ◃ Hss^-1) • lassociator _ _ _ • ss'). + simple refine (_ ,, _). * abstract (cbn ; rewrite id2_rwhisker, id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lwhisker_vcomp ; rewrite vcomp_rinv ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; apply idpath). * apply oplax_slice_disp_locally_groupoid. - cbn. intros c₃ t₃ s₁ s₂ α αα β ββ Lh Lh' ; cbn in *. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply (oplax_slice_disp_bicat B a) | ] ; apply cellset_property). + cbn. simple refine (_ ,, _). * abstract (pose (pr12 Lh) as p ; cbn in p ; rewrite id2_rwhisker in p ; rewrite id2_left in p ; pose (pr12 Lh') as p' ; cbn in p' ; rewrite id2_rwhisker in p' ; rewrite id2_left in p' ; cbn ; use (vcomp_lcancel (s₁ ◃ ss)) ; [ is_iso ; apply Hss | ] ; use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocr ; refine (_ @ p) ; refine (_ @ ββ) ; refine (_ @ maponpaths (λ z, _ • z) (!p')) ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; rewrite vcomp_whisker ; apply idpath). * apply cellset_property. Defined. Definition oplax_slice_cartesian_1cell_is_invertible_2cell {c₁ c₂ : B} {s : c₁ --> c₂} {t₁ : oplax_slice_disp_bicat B a c₁} {t₂ : oplax_slice_disp_bicat B a c₂} (ss : t₁ -->[ s ] t₂) (Hss : cartesian_1cell (oplax_slice_disp_bicat B a) ss) : is_invertible_2cell ss. Proof. cbn in *. pose (pr1 Hss c₁ (s · t₂) (id₁ _) (rassociator _ _ _ • lunitor _)) as p. unfold lift_1cell_factor in p. pose (pr12 p) as d. cbn in d. rewrite id2_rwhisker in d. rewrite id2_left in d. use make_is_invertible_2cell. - exact (linvunitor _ • pr1 p). - rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite linvunitor_assoc. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite <- d. rewrite id2_right. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - pose (@cartesian_1cell_lift_2cell _ _ _ _ _ _ _ _ Hss c₁ t₁ (id₁ _) (id₁ _) (rassociator _ _ _ • lunitor _ • ss) (rassociator _ _ _ • lunitor _ • ss) (id2 _)) as lift2. cbn in lift2. rewrite !id2_rwhisker, !id2_left in lift2. pose (lift2 (idpath _)) as l'. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (!(id2_left _) @ _). use (l' (lunitor _ ,, _) (pr1 p • ss ,, _)) ; cbn. + simple refine (_ ,, _). * cbn. rewrite id2_rwhisker, id2_left. rewrite !vassocl. apply maponpaths. rewrite vcomp_lunitor. apply idpath. * apply oplax_slice_disp_locally_groupoid. + simple refine (_ ,, _). * cbn. rewrite id2_rwhisker, id2_left. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite d. rewrite !vassocl. apply idpath. * apply oplax_slice_disp_locally_groupoid. Qed. (** 2.4. Global cleaving *) Definition oplax_slice_global_cleaving : global_cleaving (oplax_slice_disp_bicat B a). Proof. intros c₁ c₂ t₁ s. simple refine (s · t₁ ,, id₂ _ ,, _) ; cbn. apply oplax_slice_invertible_2cell_is_cartesian_1cell. is_iso. Defined. End OplaxSliceCleaving. (** 3. Slice bicatgories *) Section SliceCleaving. Context {B : bicat} (a : B). (** 3.1. Local isocleaving *) Definition slice_local_iso_cleaving : local_iso_cleaving (slice_disp_bicat a). Proof. intros c₁ c₂ t₁ t₂ s₁ s₂ α β ; cbn in *. simple refine (_ ,, _ ,, _). - exact (comp_of_invertible_2cell α (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell β))). - abstract (cbn ; rewrite !vassocl ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply id2_right). - apply disp_locally_groupoid_slice_disp_bicat. Defined. (** 3.2. Characterizations of cartesian 1-cells *) Definition slice_is_cartesian_1cell {c₁ c₂ : B} {s : c₁ --> c₂} {t₁ : slice_disp_bicat a c₁} {t₂ : slice_disp_bicat a c₂} (ss : t₁ -->[ s ] t₂) : cartesian_1cell (slice_disp_bicat a) ss. Proof. split. - intros c₃ t₃ s' ss'. simple refine (_ ,, _). + exact (comp_of_invertible_2cell ss' (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell ss)))). + simple refine (_ ,, _). * abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; refine (_ @ id2_right _) ; apply maponpaths ; rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply rassociator_lassociator). * apply disp_locally_groupoid_slice_disp_bicat. - cbn. intros c₃ t₃ s₁ s₂ α αα β ββ Lh Lh' ; cbn in *. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply (slice_disp_bicat a) | ] ; apply cellset_property). + cbn. simple refine (_ ,, _). * abstract (pose (pr12 Lh') as p ; cbn in p ; rewrite id2_rwhisker in p ; rewrite id2_right in p ; use (vcomp_rcancel (s₂ ◃ ss)) ; [ is_iso ; apply ss | ] ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; refine (_ @ !p) ; clear p ; pose (pr12 Lh) as p ; refine (_ @ ββ) ; cbn in p ; rewrite id2_rwhisker in p ; rewrite id2_right in p ; refine (_ @ maponpaths (λ z, z • _) p) ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_whisker ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; apply idpath). * apply cellset_property. Defined. (** 3.3. Global cleaving *) Definition slice_global_cleaving : global_cleaving (slice_disp_bicat a). Proof. intros c₁ c₂ t₁ s. cbn in *. simple refine (s · t₁ ,, id2_invertible_2cell _ ,, _) ; cbn. apply slice_is_cartesian_1cell. Defined. End SliceCleaving. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/ExamplesOfCleavings/TrivialCleaving.v000066400000000000000000000334221451125700300314750ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Cartesians. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial. Local Open Scope cat. (** The trivial bicategory has a cleaving *) Section ConstantCleaving. Variable (B₁ B₂ : bicat). (** Characterisation of cartesian 2-cells *) Definition trivial_invertible_is_cartesian_2cell {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} {f₁ f₂ : x₁ --> x₂} {g₁ : y₁ -->[ f₁ ] y₂} {g₂ : y₁ -->[ f₂ ] y₂} (α : f₁ ==> f₂) (β : g₁ ==>[ α ] g₂) (Hβ : is_invertible_2cell β) : is_cartesian_2cell (trivial_displayed_bicat B₁ B₂) β. Proof. intros h h' γ ββ ; cbn in *. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply cellset_property | ] ; use (vcomp_rcancel _ Hβ) ; exact (pr2 τ₁ @ !(pr2 τ₂))). - refine (ββ • Hβ^-1 ,, _). abstract (rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). Defined. Definition trivial_cartesian_2cell_is_invertible {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} {f₁ f₂ : x₁ --> x₂} {g₁ : y₁ -->[ f₁ ] y₂} {g₂ : y₁ -->[ f₂ ] y₂} (α : f₁ ==> f₂) (β : g₁ ==>[ α ] g₂) (Hβ : is_cartesian_2cell (trivial_displayed_bicat B₁ B₂) β) : is_invertible_2cell β. Proof. cbn in *. unfold is_cartesian_2cell in Hβ. pose (Hβ f₁ g₂ (id2 _) (id2 _)) as lift. pose (inv := iscontrpr1 lift). cbn in lift, inv. use make_is_invertible_2cell. - exact (pr1 inv). - abstract (pose (Hβ f₁ g₁ (id2 _) β) as m ; cbn in m ; pose (proofirrelevance _ (isapropifcontr m)) as i ; simple refine (maponpaths pr1 (i (β • pr1 inv ,, _) (id₂ g₁ ,, _))) ; cbn ; [ cbn ; rewrite vassocl ; rewrite (pr2 inv) ; apply id2_right | apply id2_left ]). - abstract (exact (pr2 inv)). Defined. (** Characterisation of cartesian 2-cells *) Definition trivial_invertible_is_opcartesian_2cell {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} {f₁ f₂ : x₁ --> x₂} {g₁ : y₁ -->[ f₁ ] y₂} {g₂ : y₁ -->[ f₂ ] y₂} (α : f₁ ==> f₂) (β : g₁ ==>[ α ] g₂) (Hβ : is_invertible_2cell β) : is_opcartesian_2cell (trivial_displayed_bicat B₁ B₂) β. Proof. intros h h' γ ββ ; cbn in *. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply cellset_property | ] ; use (vcomp_lcancel _ Hβ) ; exact (pr2 τ₁ @ !(pr2 τ₂))). - refine (Hβ^-1 • ββ,, _). abstract (rewrite !vassocr ; rewrite vcomp_rinv ; apply id2_left). Defined. Definition trivial_opcartesian_2cell_is_invertible {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} {f₁ f₂ : x₁ --> x₂} {g₁ : y₁ -->[ f₁ ] y₂} {g₂ : y₁ -->[ f₂ ] y₂} (α : f₁ ==> f₂) (β : g₁ ==>[ α ] g₂) (Hβ : is_opcartesian_2cell (trivial_displayed_bicat B₁ B₂) β) : is_invertible_2cell β. Proof. cbn in *. unfold is_cartesian_2cell in Hβ. pose (Hβ f₂ g₁ (id2 _) (id2 _)) as lift. pose (inv := iscontrpr1 lift). cbn in lift, inv. use make_is_invertible_2cell. - exact (pr1 inv). - abstract (exact (pr2 inv)). - abstract (pose (Hβ f₂ g₂ (id2 _) β) as m ; cbn in m ; pose (proofirrelevance _ (isapropifcontr m)) as i ; simple refine (maponpaths pr1 (i (pr1 inv • β,, _) (id₂ g₂ ,, _))) ; cbn ; [ cbn ; rewrite vassocr ; rewrite (pr2 inv) ; apply id2_left | apply id2_right ]). Defined. Definition trivial_local_cleaving : local_cleaving (trivial_displayed_bicat B₁ B₂). Proof. intros x₁ x₂ y₁ y₂ f₁ f₂ f α. simple refine (f ,, id2 _ ,, _) ; cbn. apply trivial_invertible_is_cartesian_2cell. is_iso. Defined. Definition trivial_local_opcleaving : local_opcleaving (trivial_displayed_bicat B₁ B₂). Proof. intros x₁ x₂ y₁ y₂ f₁ f₂ f α. simple refine (f ,, id2 _ ,, _) ; cbn. apply trivial_invertible_is_opcartesian_2cell. is_iso. Defined. Definition trivial_local_isocleaving : local_iso_cleaving (trivial_displayed_bicat B₁ B₂). Proof. intros x₁ x₂ y₁ y₂ f₁ f₂ f α. refine (f ,, id2 _ ,, _). apply trivial_is_invertible_2cell_to_is_disp_invertible. is_iso. Defined. Section TrivialCartesianOneCell. Context {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} (f : x₁ --> x₂) (g : y₁ -->[ f ] y₂) (Hg : left_adjoint_equivalence g). Definition trivial_lift_1cell {x₃ : B₁} {y₃ : trivial_displayed_bicat B₁ B₂ x₃} (h : x₃ --> x₁) (k : y₃ -->[ h · f] y₂) : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k. Proof. simple refine (_ ,, _) ; cbn in *. - exact (k · left_adjoint_right_adjoint Hg). - simple refine (_ ,, _) ; cbn. + refine (rassociator _ _ _ • (k ◃ _) • runitor _). exact (left_adjoint_counit Hg). + cbn. use trivial_is_invertible_2cell_to_is_disp_invertible. is_iso. apply (left_equivalence_counit_iso Hg). Defined. Definition trivial_lift_2cell {w : B₁} {z : B₂} {h h' : w --> x₁} {k k' : z --> y₂} (γ : h ==> h') (δ : k ==> k') (Lh : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k) (Lh' : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) g k') : lift_2cell_factor (trivial_displayed_bicat B₁ B₂) g (δ := γ) δ Lh Lh'. Proof. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; induction φ₁ as [ φ₁ ψ₁ ] ; induction φ₂ as [ φ₂ ψ₂ ] ; use subtypePath ; [ intro ; apply cellset_property | ] ; cbn in * ; rewrite transportf_const in ψ₁, ψ₂ ; cbn in * ; apply (fully_faithful_1cell_faithful (adj_equiv_fully_faithful Hg)) ; pose (p₂ := trivial_disp_invertible_to_invertible_2cell (pr2 Lh')) ; use (vcomp_rcancel p₂) ; [ apply p₂ | ] ; exact (ψ₁ @ !ψ₂)). - simple refine (_ ,, _) ; cbn. + exact (fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hg) (pr12 Lh • δ • trivial_disp_invertible_to_invertible_2cell (pr2 Lh')^-1)). + abstract (rewrite transportf_const ; cbn ; etrans ; [ apply maponpaths_2 ; apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hg)) | ] ; cbn in * ; rewrite !vassocl ; apply maponpaths ; refine (_ @ id2_right _) ; apply maponpaths ; apply (vcomp_linv (trivial_disp_invertible_to_invertible_2cell (pr2 Lh')))). Defined. Definition trivial_cartesian_1cell : cartesian_1cell (trivial_displayed_bicat B₁ B₂) g. Proof. split. - exact @trivial_lift_1cell. - exact @trivial_lift_2cell. Defined. End TrivialCartesianOneCell. Section Cartesian1CellToAdjEquiv. Context {x₁ x₂ : B₁} {y₁ : trivial_displayed_bicat B₁ B₂ x₁} {y₂ : trivial_displayed_bicat B₁ B₂ x₂} (f : x₁ --> x₂) (g : y₁ -->[ f ] y₂) (Hg : cartesian_1cell (trivial_displayed_bicat B₁ B₂) g). Let inv : y₂ --> y₁ := pr1 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _)). Let ε : inv · g ==> id₁ y₂ := pr12 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _)). Let εinv : is_invertible_2cell ε := trivial_disp_invertible_to_invertible_2cell (pr2 (pr1 Hg x₁ y₂ (id₁ _) (id₁ _))). Local Definition unit_help_lift₁ : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) (h := id₁ _) g g. Proof. simple refine (_ ,, _ ,, _) ; cbn. - apply id₁. - apply lunitor. - use trivial_is_invertible_2cell_to_is_disp_invertible. is_iso. Defined. Local Definition unit_help_lift₂ : lift_1cell_factor (trivial_displayed_bicat B₁ B₂) (h := id₁ _) g g. Proof. simple refine (_ ,, _ ,, _) ; cbn. - exact (g · inv). - exact (rassociator _ _ _ • (g ◃ ε) • runitor _). - use trivial_is_invertible_2cell_to_is_disp_invertible. is_iso. Defined. Local Definition unit : id₁ y₁ ==> g · inv := cartesian_1cell_lift_2cell _ _ Hg (δ := id2 _) (id2 _) unit_help_lift₁ unit_help_lift₂. Definition trivial_cartesian_1cell_left_adj_data : left_adjoint_data g := (inv ,, unit ,, ε). Definition trivial_cartesian_1cell_left_equiv_axioms : left_equivalence_axioms trivial_cartesian_1cell_left_adj_data. Proof. split. - use (trivial_is_disp_invertible_to_is_invertible_2cell (α := id2 (id₁ _))). + is_iso. + refine (cartesian_1cell_lift_2cell_invertible _ Hg _ _ unit_help_lift₁ unit_help_lift₂). use trivial_is_invertible_2cell_to_is_disp_invertible. is_iso. - exact εinv. Defined. Definition trivial_cartesian_1cell_is_adj_equiv : left_adjoint_equivalence g. Proof. use equiv_to_adjequiv. simple refine (_ ,, _). - exact trivial_cartesian_1cell_left_adj_data. - exact trivial_cartesian_1cell_left_equiv_axioms. Defined. End Cartesian1CellToAdjEquiv. Definition trivial_global_cleaving : global_cleaving (trivial_displayed_bicat B₁ B₂). Proof. intros x₁ x₂ y₁ y₂. simple refine (y₁ ,, id₁ _ ,, _) ; cbn. apply trivial_cartesian_1cell. apply (internal_adjoint_equivalence_identity y₁). Defined. Definition trivial_lwhisker_cartesian : lwhisker_cartesian (trivial_displayed_bicat B₁ B₂). Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα. apply trivial_invertible_is_cartesian_2cell. cbn. is_iso. apply trivial_cartesian_2cell_is_invertible. apply Hαα. Qed. Definition trivial_rwhisker_cartesian : rwhisker_cartesian (trivial_displayed_bicat B₁ B₂). Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα. apply trivial_invertible_is_cartesian_2cell. cbn. is_iso. apply trivial_cartesian_2cell_is_invertible. apply Hαα. Qed. Definition trivial_lwhisker_opcartesian : lwhisker_opcartesian (trivial_displayed_bicat B₁ B₂). Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα. apply trivial_invertible_is_opcartesian_2cell. cbn. is_iso. apply trivial_opcartesian_2cell_is_invertible. apply Hαα. Qed. Definition trivial_rwhisker_opcartesian : rwhisker_opcartesian (trivial_displayed_bicat B₁ B₂). Proof. intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? Hαα. apply trivial_invertible_is_opcartesian_2cell. cbn. is_iso. apply trivial_opcartesian_2cell_is_invertible. apply Hαα. Qed. Definition trivial_cleaving_of_bicats : cleaving_of_bicats (trivial_displayed_bicat B₁ B₂). Proof. repeat split. - exact trivial_local_cleaving. - exact trivial_global_cleaving. - exact trivial_lwhisker_cartesian. - exact trivial_rwhisker_cartesian. Defined. End ConstantCleaving. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory.v000066400000000000000000000005701451125700300255510ustar00rootroot00000000000000(* ******************************************************************************* *) (** Export file for fibrations ********************************************************************************* *) Require Export UniMath.Bicategories.DisplayedBicats.FiberBicategory.FiberBicategory1. Require Export UniMath.Bicategories.DisplayedBicats.FiberBicategory.FiberBicategory2. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/000077500000000000000000000000001451125700300253605ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/CodomainFiber.v000066400000000000000000001273101451125700300302540ustar00rootroot00000000000000(******************************************************************* Fibers of the arrow bicategory In this file, we calculate the fibers of the arrow bicategory 1. To the fiber 2. From the fiber 3. The unit 4. The counit 5. The modifications 6. The biequivalence *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Local Open Scope cat. Local Open Scope bicategory_scope. Section FiberOfCodomain. Context {B : bicat} (b : B). (** 1. Calculation of operations in fiber *) Definition comp_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} {f g h : x --> y} (α : f ==> g) (β : g ==> h) : pr1 (α • β) = pr1 α • pr1 β. Proof. apply transportf_cell_of_cod_over. Qed. Definition lunitor_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : x --> y) : pr1 (lunitor f) = lunitor (pr1 f). Proof. etrans. { apply transportf_cell_of_cod_over. } apply id2_left. Qed. Definition linvunitor_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : x --> y) : pr1 (linvunitor f) = linvunitor (pr1 f). Proof. etrans. { apply transportf_cell_of_cod_over. } apply id2_right. Qed. Definition runitor_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : x --> y) : pr1 (runitor f) = runitor (pr1 f). Proof. etrans. { apply transportf_cell_of_cod_over. } apply id2_left. Qed. Definition rinvunitor_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : x --> y) : pr1 (rinvunitor f) = rinvunitor (pr1 f). Proof. etrans. { apply transportf_cell_of_cod_over. } apply id2_right. Qed. Definition lassociator_cod_fiber {w x y z : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : w --> x) (g : x --> y) (h : y --> z) : pr1 (lassociator f g h) = lassociator (pr1 f) (pr1 g) (pr1 h). Proof. etrans. { apply transportf_cell_of_cod_over. } cbn. rewrite lwhisker_id2, id2_rwhisker, !id2_left, !id2_right. apply idpath. Qed. Definition rassociator_cod_fiber {w x y z : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : w --> x) (g : x --> y) (h : y --> z) : pr1 (rassociator f g h) = rassociator (pr1 f) (pr1 g) (pr1 h). Proof. etrans. { apply transportf_cell_of_cod_over. } cbn. rewrite lwhisker_id2, id2_rwhisker, !id2_left, !id2_right. apply idpath. Qed. Definition lwhisker_cod_fiber {x y z : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} (f : x --> y) {g h : y --> z} (α : g ==> h) : pr1 (f ◃ α) = _ ◃ pr1 α. Proof. etrans. { apply transportf_cell_of_cod_over. } cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition rwhisker_cod_fiber {x y z : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} {f g : x --> y} (α : f ==> g) (h : y --> z) : pr1 (α ▹ h) = pr1 α ▹ _. Proof. etrans. { apply transportf_cell_of_cod_over. } cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition path_2cell_cod_fiber {x y : strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b} {f g : x --> y} (α β : f ==> g) (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. (** 2. To the fiber *) Definition to_fiber_cod_data : psfunctor_data (slice_bicat b) (strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b). Proof. use make_psfunctor_data. - exact (λ f, f). - exact (λ a₁ a₂ g, pr1 g ,, comp_of_invertible_2cell (runitor_invertible_2cell _) (pr2 g)). - cbn. refine (λ a₁ a₂ g₁ g₂ β, pr1 β ,, _). abstract (rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; apply maponpaths ; exact (pr2 β)). - refine (λ a, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker, id2_right ; rewrite lwhisker_id2, id2_left ; apply idpath). - cbn. refine (λ a₁ a₂ a₃ g₁ g₂, id2 _ ,, _). abstract (rewrite lwhisker_id2, id2_left ; rewrite id2_rwhisker, id2_right ; rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). Defined. Definition to_fiber_cod_laws : psfunctor_laws to_fiber_cod_data. Proof. refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _) ; intro ; intros ; use path_2cell_cod_fiber. - apply idpath. - rewrite comp_cod_fiber. apply idpath. - rewrite !comp_cod_fiber. rewrite lunitor_cod_fiber. rewrite rwhisker_cod_fiber. cbn. rewrite id2_rwhisker, !id2_left. apply idpath. - rewrite !comp_cod_fiber. rewrite runitor_cod_fiber. rewrite lwhisker_cod_fiber. cbn. rewrite lwhisker_id2, !id2_left. apply idpath. - rewrite !comp_cod_fiber. rewrite lwhisker_cod_fiber, rwhisker_cod_fiber. rewrite lassociator_cod_fiber. cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite !id2_left, !id2_right. apply idpath. - rewrite !comp_cod_fiber. rewrite lwhisker_cod_fiber. cbn. rewrite id2_left, id2_right. apply idpath. - rewrite !comp_cod_fiber. rewrite rwhisker_cod_fiber. cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition to_fiber_cod : psfunctor (slice_bicat b) (strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b). Proof. use make_psfunctor. - exact to_fiber_cod_data. - exact to_fiber_cod_laws. - split. + intros. use strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod ; cbn. is_iso. + intros. use strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod ; cbn. is_iso. Defined. (** 3. From the fiber *) Definition from_fiber_cod_data : psfunctor_data (strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b) (slice_bicat b). Proof. use make_psfunctor_data. - exact (λ f, f). - exact (λ a₁ a₂ g, pr1 g ,, comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (pr2 g)). - cbn. refine (λ a₁ a₂ g₁ g₂ β, pr1 β ,, _). abstract (cbn ; rewrite !vassocl ; refine (maponpaths (λ z, _ • z) (pr2 β) @ _) ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). - cbn. refine (λ a, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; apply idpath). - cbn. refine (λ a₁ a₂ a₃ g₁ g₂, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; apply maponpaths ; rewrite <- lwhisker_vcomp ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !lwhisker_hcomp ; rewrite triangle_r_inv ; rewrite <- rwhisker_hcomp, <- lwhisker_hcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite left_unit_inv_assoc ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rinvunitor_natural ; rewrite <- rwhisker_hcomp ; apply maponpaths_2 ; refine (_ @ id2_right _) ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite lunitor_lwhisker ; apply idpath). Defined. Definition from_fiber_cod_laws : psfunctor_laws from_fiber_cod_data. Proof. repeat split ; intro ; intros ; use eq_2cell_slice. - apply idpath. - cbn -[vcomp2]. rewrite comp_cod_fiber. cbn. apply idpath. - cbn -[lunitor]. rewrite lunitor_cod_fiber. cbn. rewrite id2_rwhisker, !id2_left. apply idpath. - cbn -[runitor]. rewrite runitor_cod_fiber. cbn. rewrite lwhisker_id2, !id2_left. apply idpath. - cbn -[lassociator]. rewrite lassociator_cod_fiber. cbn. rewrite id2_rwhisker, lwhisker_id2, !id2_left, !id2_right. apply idpath. - cbn -[lwhisker]. rewrite lwhisker_cod_fiber. cbn. rewrite id2_left, id2_right. apply idpath. - cbn -[rwhisker]. rewrite rwhisker_cod_fiber. cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition from_fiber_cod : psfunctor (strict_fiber_bicat (cod_disp_bicat B) (cod_local_iso_cleaving B) b) (slice_bicat b). Proof. use make_psfunctor. - exact from_fiber_cod_data. - exact from_fiber_cod_laws. - split ; intros. + use is_invertible_2cell_in_slice_bicat ; cbn. is_iso. + use is_invertible_2cell_in_slice_bicat ; cbn. is_iso. Defined. (** 4. The unit *) Definition to_fiber_cod_unit_data : pstrans_data (id_psfunctor _) (comp_psfunctor from_fiber_cod to_fiber_cod). Proof. use make_pstrans_data. - cbn. exact (λ f, id₁ _ ,, linvunitor_invertible_2cell _). - cbn. refine (λ f₁ f₂ g, _). use make_invertible_2cell. + cbn. simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- rwhisker_vcomp ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; apply idpath). + apply is_invertible_2cell_in_slice_bicat ; cbn. is_iso. Defined. Definition to_fiber_cod_unit_is_pstrans : is_pstrans to_fiber_cod_unit_data. Proof. repeat split. - intros x y f g α. use eq_2cell_slice. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use eq_2cell_slice. cbn. rewrite id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity, runitor_rinvunitor. rewrite runitor_lunitor_identity, lunitor_linvunitor. apply idpath. - intros x y z f g. use eq_2cell_slice. cbn. rewrite id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite !vassocl. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite <- runitor_triangle. rewrite !vassocl. rewrite (maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)). rewrite lassociator_rassociator. rewrite id2_left. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_triangle. apply idpath. Qed. Definition to_fiber_cod_unit : pstrans (id_psfunctor _) (comp_psfunctor from_fiber_cod to_fiber_cod). Proof. use make_pstrans. - exact to_fiber_cod_unit_data. - exact to_fiber_cod_unit_is_pstrans. Defined. Definition to_fiber_cod_unit_inv_data : pstrans_data (comp_psfunctor from_fiber_cod to_fiber_cod) (id_psfunctor _). Proof. use make_pstrans_data. - cbn. exact (λ x, id₁ _ ,, linvunitor_invertible_2cell _). - cbn. refine (λ x y f, _). use make_invertible_2cell. + cbn. simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- rwhisker_vcomp ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; apply idpath). + apply is_invertible_2cell_in_slice_bicat ; cbn. is_iso. Defined. Definition to_fiber_cod_unit_inv_is_pstrans : is_pstrans to_fiber_cod_unit_inv_data. Proof. repeat split. - intros x y f g α. use eq_2cell_slice. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use eq_2cell_slice. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite runitor_lunitor_identity, lunitor_linvunitor. rewrite lunitor_runitor_identity, runitor_rinvunitor. apply idpath. - intros x y z f g. use eq_2cell_slice. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (!(id2_right _) @ _). apply maponpaths. rewrite <- runitor_triangle. rewrite (maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite lassociator_rassociator. rewrite id2_left. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite id2_right. rewrite lunitor_lwhisker. apply idpath. Qed. Definition to_fiber_cod_unit_inv : pstrans (comp_psfunctor from_fiber_cod to_fiber_cod) (id_psfunctor _). Proof. use make_pstrans. - exact to_fiber_cod_unit_inv_data. - exact to_fiber_cod_unit_inv_is_pstrans. Defined. (** 5. The counit *) Definition to_fiber_cod_counit_data : pstrans_data (comp_psfunctor to_fiber_cod from_fiber_cod) (id_psfunctor _). Proof. use make_pstrans_data. - cbn. refine (λ f, id₁ _ ,, _). exact (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)). - refine (λ x y f, _). use make_invertible_2cell. + simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; refine (!_) ; etrans ; [ do 4 apply maponpaths ; rewrite lwhisker_hcomp ; apply triangle_l_inv | ] ; rewrite <- rwhisker_hcomp ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite lunitor_triangle ; rewrite runitor_triangle ; rewrite vcomp_lunitor ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_triangle ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; apply lunitor_lwhisker). + apply strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod. cbn. is_iso. Defined. Definition to_fiber_cod_counit_is_pstrans : is_pstrans to_fiber_cod_counit_data. Proof. refine (_ ,, _ ,, _). - intros x y f g α. use path_2cell_cod_fiber. rewrite !comp_cod_fiber. rewrite lwhisker_cod_fiber. rewrite rwhisker_cod_fiber. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. apply lwhisker_cod_fiber. } refine (!_). refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. apply runitor_cod_fiber. } apply maponpaths. apply linvunitor_cod_fiber. } etrans. { apply maponpaths. etrans. { apply rwhisker_cod_fiber. } apply maponpaths. apply comp_cod_fiber. } cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite lunitor_runitor_identity, runitor_rinvunitor. rewrite runitor_lunitor_identity, lunitor_linvunitor. apply idpath. - intros x y z f g. Opaque comp_psfunctor. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (lwhisker_cod_fiber _ _) @ _). refine (!_). refine (comp_cod_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((z • _) • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, (((z • _) • _) • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((z • _) • _) • _) • _) • _) (lassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • z) • _) • _) • _) • _) (rwhisker_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • z) • _) • _) • _) (rassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • z) • _) • _) (lwhisker_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • z) • _) (lassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • z) (rwhisker_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • (z ▹ _)) (comp_cod_fiber _ _) @ _). Transparent comp_psfunctor. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite <- rwhisker_vcomp. rewrite <- lunitor_triangle. rewrite !vassocl. do 2 apply maponpaths. rewrite left_unit_inv_assoc₂. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition to_fiber_cod_counit : pstrans (comp_psfunctor to_fiber_cod from_fiber_cod) (id_psfunctor _). Proof. use make_pstrans. - exact to_fiber_cod_counit_data. - exact to_fiber_cod_counit_is_pstrans. Defined. Definition to_fiber_cod_counit_inv_data : pstrans_data (id_psfunctor _) (comp_psfunctor to_fiber_cod from_fiber_cod). Proof. use make_pstrans_data. - cbn. refine (λ x, id₁ _ ,, _). exact (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)). - intros x y f. use make_invertible_2cell. + simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; rewrite runitor_rinvunitor ; rewrite id2_left ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite runitor_triangle ; rewrite lunitor_triangle ; rewrite vcomp_lunitor ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_triangle ; rewrite (maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite lunitor_lwhisker ; apply idpath). + apply strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod. cbn. is_iso. Defined. Opaque strict_fiber_bicat. Definition to_fiber_cod_counit_inv_is_pstrans : is_pstrans to_fiber_cod_counit_inv_data. Proof. repeat split. - intros x y f g α. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _ @ !(comp_cod_fiber _ _)). etrans. { apply maponpaths_2. apply lwhisker_cod_fiber. } refine (!_). etrans. { apply maponpaths. apply rwhisker_cod_fiber. } cbn. refine (!_). refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply vcomp_lunitor. } refine (vassocl _ _ _ @ _ @ vassocr _ _ _). apply maponpaths. etrans. { apply rinvunitor_natural. } apply maponpaths. refine (!_). apply rwhisker_hcomp. - intros x. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. etrans. { apply lwhisker_cod_fiber. } apply maponpaths. exact (comp_cod_fiber (psfunctor_id to_fiber_cod x) (##to_fiber_cod (psfunctor_id from_fiber_cod x))). } refine (!_). refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. apply runitor_cod_fiber. } apply maponpaths. apply linvunitor_cod_fiber. } etrans. { apply maponpaths. apply rwhisker_cod_fiber. } cbn. etrans. { apply maponpaths. apply id2_rwhisker. } refine (id2_right _ @ _). refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id2_left. } apply lwhisker_id2. } refine (id2_left _ @ _). etrans. { apply maponpaths_2. apply lunitor_runitor_identity. } refine (runitor_rinvunitor _ @ _). refine (!_). etrans. { apply maponpaths_2. apply runitor_lunitor_identity. } apply lunitor_linvunitor. - intros x y z f g. Opaque comp_psfunctor. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (lwhisker_cod_fiber _ _) @ _). refine (!_). refine (comp_cod_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((z • _) • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, (((z • _) • _) • _) • _) (comp_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((z • _) • _) • _) • _) • _) (lassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • z) • _) • _) • _) • _) (rwhisker_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • z) • _) • _) • _) (rassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • z) • _) • _) (lwhisker_cod_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • z) • _) (lassociator_cod_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • z) (rwhisker_cod_fiber _ _) @ _). refine (!_). etrans. { apply maponpaths_2. apply maponpaths. exact (comp_cod_fiber (psfunctor_comp to_fiber_cod (# from_fiber_cod f) (# from_fiber_cod g)) (## to_fiber_cod (psfunctor_comp from_fiber_cod f g))). } Transparent comp_psfunctor. cbn. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id2_left. } apply lwhisker_id2. } refine (id2_left _ @ _). refine (!_). etrans. { apply maponpaths. apply id2_rwhisker. } refine (id2_right _ @ _). etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply rwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_triangle. } do 3 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply lwhisker_vcomp. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply left_unit_inv_assoc. } refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply rassociator_lassociator. } apply id2_right. } etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_lwhisker. } refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply rinvunitor_runitor. } apply id2_rwhisker. } apply id2_left. Opaque comp_psfunctor. Qed. Transparent strict_fiber_bicat comp_psfunctor. Definition to_fiber_cod_counit_inv : pstrans (id_psfunctor _) (comp_psfunctor to_fiber_cod from_fiber_cod). Proof. use make_pstrans. - exact to_fiber_cod_counit_inv_data. - exact to_fiber_cod_counit_inv_is_pstrans. Defined. (** 6. The modifications *) Definition cod_unit_inv_left_data : invertible_modification_data (id_pstrans _) (comp_pstrans to_fiber_cod_unit_inv to_fiber_cod_unit). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (linvunitor _). + abstract (cbn ; apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite lunitor_runitor_identity ; rewrite lwhisker_hcomp, rwhisker_hcomp ; apply triangle_r). - apply is_invertible_2cell_in_slice_bicat. cbn. is_iso. Defined. Definition cod_unit_inv_left_is_modification : is_modification cod_unit_inv_left_data. Proof. intros x y f. use eq_2cell_slice. cbn. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite <- lwhisker_vcomp. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite runitor_lunitor_identity. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. apply idpath. Qed. Definition cod_unit_inv_left : invertible_modification (id_pstrans _) (comp_pstrans to_fiber_cod_unit_inv to_fiber_cod_unit). Proof. use make_invertible_modification. - exact cod_unit_inv_left_data. - exact cod_unit_inv_left_is_modification. Defined. Definition cod_unit_inv_right_data : invertible_modification_data (comp_pstrans to_fiber_cod_unit to_fiber_cod_unit_inv) (id_pstrans _). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (lunitor _). + abstract (cbn ; refine (_ @ id2_right _) ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite lunitor_runitor_identity ; rewrite lwhisker_hcomp, rwhisker_hcomp ; refine (!_) ; apply triangle_r). - apply is_invertible_2cell_in_slice_bicat. cbn. is_iso. Defined. Definition cod_unit_inv_right_is_modification : is_modification cod_unit_inv_right_data. Proof. intros x y f. use eq_2cell_slice. cbn. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite <- lwhisker_vcomp. rewrite lunitor_triangle. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lunitor_triangle. rewrite lwhisker_vcomp. rewrite vcomp_lunitor. rewrite !vassocl. apply idpath. Qed. Definition cod_unit_inv_right : invertible_modification (comp_pstrans to_fiber_cod_unit to_fiber_cod_unit_inv) (id_pstrans _). Proof. use make_invertible_modification. - exact cod_unit_inv_right_data. - exact cod_unit_inv_right_is_modification. Defined. Definition cod_counit_inv_right_data : invertible_modification_data (id_pstrans _) (comp_pstrans to_fiber_cod_counit to_fiber_cod_counit_inv). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (linvunitor _). + abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite <- rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). - use strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod. cbn. is_iso. Defined. Opaque comp_psfunctor strict_fiber_bicat. Definition cod_counit_inv_right_is_modification : is_modification cod_counit_inv_right_data. Proof. intros x y f. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _ @ !(comp_cod_fiber _ _)). etrans. { apply maponpaths. apply lwhisker_cod_fiber. } etrans. { apply maponpaths_2. cbn. apply comp_cod_fiber. } etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply lunitor_cod_fiber. } apply maponpaths. apply rinvunitor_cod_fiber. } refine (!_). etrans. { apply maponpaths_2. apply rwhisker_cod_fiber. } etrans. { apply maponpaths. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply rassociator_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply rwhisker_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply lassociator_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply lwhisker_cod_fiber. } apply maponpaths_2. apply rassociator_cod_fiber. } cbn. rewrite !vassocl. etrans. { apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocr. do 4 apply maponpaths_2. apply lunitor_lwhisker. } etrans. { rewrite !vassocr. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply rwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. apply runitor_lunitor_identity. } apply linvunitor_lunitor. } etrans. { apply maponpaths_2. apply id2_rwhisker. } apply id2_left. } refine (!_). etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply vcomp_lunitor. } apply vassocl. } do 2 refine (_ @ vassocr _ _ _). apply maponpaths. refine (!_). etrans. { etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply rwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_triangle. } refine (vassocl _ _ _ @ _). apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ]. use vcomp_move_L_Mp ; [ is_iso | ]. apply lunitor_lwhisker. Qed. Transparent comp_psfunctor strict_fiber_bicat. Definition cod_counit_inv_right : invertible_modification (id_pstrans _) (comp_pstrans to_fiber_cod_counit to_fiber_cod_counit_inv). Proof. use make_invertible_modification. - exact cod_counit_inv_right_data. - exact cod_counit_inv_right_is_modification. Defined. Definition cod_counit_inv_left_data : invertible_modification_data (comp_pstrans to_fiber_cod_counit_inv to_fiber_cod_counit) (id_pstrans _). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (lunitor _). + abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite <- rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). - use strict_fiber_bicat_invertible_2cell. use is_disp_invertible_2cell_cod. cbn. is_iso. Defined. Opaque comp_psfunctor strict_fiber_bicat. Definition cod_counit_inv_left_is_modification : is_modification cod_counit_inv_left_data. Proof. intros x y f. use path_2cell_cod_fiber. refine (comp_cod_fiber _ _ @ _ @ !(comp_cod_fiber _ _)). refine (!_). etrans. { apply maponpaths_2. apply rwhisker_cod_fiber. } etrans. { apply maponpaths. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths_2. apply lunitor_cod_fiber. } apply maponpaths. apply rinvunitor_cod_fiber. } refine (!_). etrans. { apply maponpaths. apply lwhisker_cod_fiber. } etrans. { apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply rassociator_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply rwhisker_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply lassociator_cod_fiber. } apply maponpaths_2. refine (comp_cod_fiber _ _ @ _). etrans. { apply maponpaths. apply lwhisker_cod_fiber. } apply maponpaths_2. apply rassociator_cod_fiber. } cbn. etrans. { do 4 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply lwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. etrans. { apply lunitor_lwhisker. } apply maponpaths. apply runitor_lunitor_identity. } do 4 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. apply lunitor_lwhisker. } refine (rwhisker_vcomp _ _ _ @ _). cbn. apply maponpaths. refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply rinvunitor_runitor. } apply id2_right. } etrans. { apply maponpaths. apply lunitor_triangle. } apply vcomp_lunitor. Qed. Transparent comp_psfunctor strict_fiber_bicat. Definition cod_counit_inv_left : invertible_modification (comp_pstrans to_fiber_cod_counit_inv to_fiber_cod_counit) (id_pstrans _). Proof. use make_invertible_modification. - exact cod_counit_inv_left_data. - exact cod_counit_inv_left_is_modification. Defined. (** 7. The biequivalence *) Definition to_fiber_cod_is_biequivalence : is_biequivalence to_fiber_cod. Proof. use make_is_biequivalence. - exact from_fiber_cod. - exact to_fiber_cod_unit. - exact to_fiber_cod_unit_inv. - exact to_fiber_cod_counit. - exact to_fiber_cod_counit_inv. - exact cod_unit_inv_left. - exact cod_unit_inv_right. - exact cod_counit_inv_right. - exact cod_counit_inv_left. Defined. End FiberOfCodomain. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/DisplayMapFiber.v000066400000000000000000001317511451125700300305720ustar00rootroot00000000000000(******************************************************************* Fibers of a display map bicategory In this file, we calculate the fibers of a display map bicategory 1. To the fiber 2. From the fiber 3. The unit 4. The counit 5. The modifications 6. The biequivalence *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatToDispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.DisplayMapBicatCleaving. Local Open Scope cat. Local Open Scope bicategory_scope. Section FiberOfDisplayMap. Context {B : bicat} (D : arrow_subbicat B) (b : B). Let DD : disp_bicat B := disp_map_bicat_to_disp_bicat D. Let slice : bicat := disp_map_slice_bicat D b. Let fiber : bicat := strict_fiber_bicat DD (arrow_subbicat_local_iso_cleaving D) b. (** 1. Calculation of operations in fiber *) Definition comp_disp_map_fiber {x y : fiber} {f g h : x --> y} (α : f ==> g) (β : g ==> h) : pr1 (α • β) = pr1 α • pr1 β. Proof. apply transportf_disp_map_bicat_cell. Qed. Definition lunitor_disp_map_fiber {x y : fiber} (f : x --> y) : pr1 (lunitor f) = lunitor (pr1 f). Proof. etrans. { apply transportf_disp_map_bicat_cell. } apply id2_left. Qed. Definition linvunitor_disp_map_fiber {x y : fiber} (f : x --> y) : pr1 (linvunitor f) = linvunitor (pr1 f). Proof. etrans. { apply transportf_disp_map_bicat_cell. } apply id2_right. Qed. Definition runitor_disp_map_fiber {x y : fiber} (f : x --> y) : pr1 (runitor f) = runitor (pr1 f). Proof. etrans. { apply transportf_disp_map_bicat_cell. } apply id2_left. Qed. Definition rinvunitor_disp_map_fiber {x y : fiber} (f : x --> y) : pr1 (rinvunitor f) = rinvunitor (pr1 f). Proof. etrans. { apply transportf_disp_map_bicat_cell. } apply id2_right. Qed. Definition lassociator_disp_map_fiber {w x y z : fiber} (f : w --> x) (g : x --> y) (h : y --> z) : pr1 (lassociator f g h) = lassociator (pr1 f) (pr1 g) (pr1 h). Proof. etrans. { apply transportf_disp_map_bicat_cell. } cbn. rewrite lwhisker_id2, id2_rwhisker, !id2_left, !id2_right. apply idpath. Qed. Definition rassociator_disp_map_fiber {w x y z : fiber} (f : w --> x) (g : x --> y) (h : y --> z) : pr1 (rassociator f g h) = rassociator (pr1 f) (pr1 g) (pr1 h). Proof. etrans. { apply transportf_disp_map_bicat_cell. } cbn. rewrite lwhisker_id2, id2_rwhisker, !id2_left, !id2_right. apply idpath. Qed. Definition lwhisker_disp_map_fiber {x y z : fiber} (f : x --> y) {g h : y --> z} (α : g ==> h) : pr1 (f ◃ α) = _ ◃ pr1 α. Proof. etrans. { apply transportf_disp_map_bicat_cell. } cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition rwhisker_disp_map_fiber {x y z : fiber} {f g : x --> y} (α : f ==> g) (h : y --> z) : pr1 (α ▹ h) = pr1 α ▹ _. Proof. etrans. { apply transportf_disp_map_bicat_cell. } cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition path_2cell_disp_map_fiber {x y : fiber} {f g : x --> y} (α β : f ==> g) (p : pr1 α = pr1 β) : α = β. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. (** 2. To the fiber *) Definition to_fiber_disp_map_data : psfunctor_data slice fiber. Proof. use make_psfunctor_data. - exact (λ f, f). - exact (λ a₁ a₂ g, pr1 g ,, pr12 g ,, comp_of_invertible_2cell (runitor_invertible_2cell _) (pr22 g)). - refine (λ a₁ a₂ g₁ g₂ β, pr1 β ,, _). abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; apply maponpaths ; exact (pr2 β)). - refine (λ a, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker, id2_right ; rewrite lwhisker_id2, id2_left ; apply idpath). - refine (λ a₁ a₂ a₃ g₁ g₂, id2 _ ,, _). abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite id2_rwhisker, id2_right ; rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). Defined. Definition to_fiber_disp_map_laws : psfunctor_laws to_fiber_disp_map_data. Proof. refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _) ; intro ; intros ; use path_2cell_disp_map_fiber. - apply idpath. - rewrite comp_disp_map_fiber. apply idpath. - rewrite !comp_disp_map_fiber. rewrite lunitor_disp_map_fiber. rewrite rwhisker_disp_map_fiber. cbn. rewrite id2_rwhisker, !id2_left. apply idpath. - rewrite !comp_disp_map_fiber. rewrite runitor_disp_map_fiber. rewrite lwhisker_disp_map_fiber. cbn. rewrite lwhisker_id2, !id2_left. apply idpath. - rewrite !comp_disp_map_fiber. rewrite lwhisker_disp_map_fiber, rwhisker_disp_map_fiber. rewrite lassociator_disp_map_fiber. cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite !id2_left, !id2_right. apply idpath. - rewrite !comp_disp_map_fiber. rewrite lwhisker_disp_map_fiber. cbn. rewrite id2_left, id2_right. apply idpath. - rewrite !comp_disp_map_fiber. rewrite rwhisker_disp_map_fiber. cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition to_fiber_disp_map : psfunctor slice fiber. Proof. use make_psfunctor. - exact to_fiber_disp_map_data. - exact to_fiber_disp_map_laws. - split. + intros. use strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible ; cbn. is_iso. + intros. use strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible ; cbn. is_iso. Defined. (** 3. From the fiber *) Definition from_fiber_disp_map_data : psfunctor_data fiber slice. Proof. use make_psfunctor_data. - exact (λ f, f). - exact (λ a₁ a₂ g, pr1 g ,, pr12 g ,, comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (pr22 g)). - refine (λ a₁ a₂ g₁ g₂ β, pr1 β ,, _). abstract (cbn ; rewrite !vassocl ; refine (maponpaths (λ z, _ • z) (pr2 β) @ _) ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). - refine (λ a, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; apply idpath). - refine (λ a₁ a₂ a₃ g₁ g₂, id2 _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; apply maponpaths ; rewrite <- lwhisker_vcomp ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !lwhisker_hcomp ; rewrite triangle_r_inv ; rewrite <- rwhisker_hcomp, <- lwhisker_hcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite left_unit_inv_assoc ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rinvunitor_natural ; rewrite <- rwhisker_hcomp ; apply maponpaths_2 ; refine (_ @ id2_right _) ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite lunitor_lwhisker ; apply idpath). Defined. Definition from_fiber_disp_map_laws : psfunctor_laws from_fiber_disp_map_data. Proof. repeat split ; intro ; intros ; use eq_2cell_disp_map_slice. - apply idpath. - cbn -[vcomp2]. rewrite comp_disp_map_fiber. cbn. apply idpath. - cbn -[lunitor]. rewrite lunitor_disp_map_fiber. cbn. rewrite id2_rwhisker, !id2_left. apply idpath. - cbn -[runitor]. rewrite runitor_disp_map_fiber. cbn. rewrite lwhisker_id2, !id2_left. apply idpath. - cbn -[lassociator]. rewrite lassociator_disp_map_fiber. cbn. rewrite id2_rwhisker, lwhisker_id2, !id2_left, !id2_right. apply idpath. - cbn -[lwhisker]. rewrite lwhisker_disp_map_fiber. cbn. rewrite id2_left, id2_right. apply idpath. - cbn -[rwhisker]. rewrite rwhisker_disp_map_fiber. cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition from_fiber_disp_map : psfunctor fiber slice. Proof. use make_psfunctor. - exact from_fiber_disp_map_data. - exact from_fiber_disp_map_laws. - split ; intros. + use is_invertible_2cell_in_disp_map_slice_bicat ; cbn. is_iso. + use is_invertible_2cell_in_disp_map_slice_bicat ; cbn. is_iso. Defined. (** 4. The unit *) Definition to_fiber_disp_map_unit_data : pstrans_data (id_psfunctor _) (comp_psfunctor from_fiber_disp_map to_fiber_disp_map). Proof. use make_pstrans_data. - exact (λ f, id₁ _ ,, id_pred_mor D _ ,, linvunitor_invertible_2cell _). - cbn. refine (λ f₁ f₂ g, _). use make_invertible_2cell. + cbn. simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- rwhisker_vcomp ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; apply idpath). + apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn. is_iso. Defined. Definition to_fiber_disp_map_unit_is_pstrans : is_pstrans to_fiber_disp_map_unit_data. Proof. repeat split. - intros x y f g α. use eq_2cell_disp_map_slice. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use eq_2cell_disp_map_slice. cbn. rewrite id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity, runitor_rinvunitor. rewrite runitor_lunitor_identity, lunitor_linvunitor. apply idpath. - intros x y z f g. use eq_2cell_disp_map_slice. cbn. rewrite id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite !vassocl. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite <- runitor_triangle. rewrite !vassocl. rewrite (maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)). rewrite lassociator_rassociator. rewrite id2_left. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_triangle. apply idpath. Qed. Definition to_fiber_disp_map_unit : pstrans (id_psfunctor _) (comp_psfunctor from_fiber_disp_map to_fiber_disp_map). Proof. use make_pstrans. - exact to_fiber_disp_map_unit_data. - exact to_fiber_disp_map_unit_is_pstrans. Defined. Definition to_fiber_disp_map_unit_inv_data : pstrans_data (comp_psfunctor from_fiber_disp_map to_fiber_disp_map) (id_psfunctor _). Proof. use make_pstrans_data. - exact (λ x, id₁ _ ,, id_pred_mor D _ ,, linvunitor_invertible_2cell _). - cbn. refine (λ x y f, _). use make_invertible_2cell. + cbn. simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocl ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- rwhisker_vcomp ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; apply idpath). + apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn. is_iso. Defined. Definition to_fiber_disp_map_unit_inv_is_pstrans : is_pstrans to_fiber_disp_map_unit_inv_data. Proof. repeat split. - intros x y f g α. use eq_2cell_disp_map_slice. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use eq_2cell_disp_map_slice. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite runitor_lunitor_identity, lunitor_linvunitor. rewrite lunitor_runitor_identity, runitor_rinvunitor. apply idpath. - intros x y z f g. use eq_2cell_disp_map_slice. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (!(id2_right _) @ _). apply maponpaths. rewrite <- runitor_triangle. rewrite (maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite lassociator_rassociator. rewrite id2_left. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite id2_right. rewrite lunitor_lwhisker. apply idpath. Qed. Definition to_fiber_disp_map_unit_inv : pstrans (comp_psfunctor from_fiber_disp_map to_fiber_disp_map) (id_psfunctor _). Proof. use make_pstrans. - exact to_fiber_disp_map_unit_inv_data. - exact to_fiber_disp_map_unit_inv_is_pstrans. Defined. (** 5. The counit *) Definition to_fiber_disp_map_counit_data : pstrans_data (comp_psfunctor to_fiber_disp_map from_fiber_disp_map) (id_psfunctor _). Proof. use make_pstrans_data. - cbn. refine (λ f, id₁ _ ,, id_pred_mor D _ ,, _). exact (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)). - refine (λ x y f, _). use make_invertible_2cell. + simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; refine (!_) ; etrans ; [ do 4 apply maponpaths ; rewrite lwhisker_hcomp ; apply triangle_l_inv | ] ; rewrite <- rwhisker_hcomp ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite lunitor_triangle ; rewrite runitor_triangle ; rewrite vcomp_lunitor ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_triangle ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; apply lunitor_lwhisker). + apply strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible. cbn. is_iso. Defined. Opaque comp_psfunctor. Definition to_fiber_disp_map_counit_is_pstrans : is_pstrans to_fiber_disp_map_counit_data. Proof. refine (_ ,, _ ,, _). - intros x y f g α. use path_2cell_disp_map_fiber. rewrite !comp_disp_map_fiber. rewrite lwhisker_disp_map_fiber. rewrite rwhisker_disp_map_fiber. cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros x. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. apply lwhisker_disp_map_fiber. } refine (!_). refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. apply runitor_disp_map_fiber. } apply maponpaths. apply linvunitor_disp_map_fiber. } etrans. { apply maponpaths. etrans. { apply rwhisker_disp_map_fiber. } apply maponpaths. apply comp_disp_map_fiber. } cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite lunitor_runitor_identity, runitor_rinvunitor. rewrite runitor_lunitor_identity, lunitor_linvunitor. apply idpath. - intros x y z f g. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (lwhisker_disp_map_fiber _ _) @ _). refine (!_). refine (comp_disp_map_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((z • _) • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, (((z • _) • _) • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((z • _) • _) • _) • _) • _) (lassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • z) • _) • _) • _) • _) (rwhisker_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • z) • _) • _) • _) (rassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • z) • _) • _) (lwhisker_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • z) • _) (lassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • z) (rwhisker_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • (z ▹ _)) (comp_disp_map_fiber _ _) @ _). cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite <- rwhisker_vcomp. rewrite <- lunitor_triangle. rewrite !vassocl. do 2 apply maponpaths. rewrite left_unit_inv_assoc₂. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Qed. Transparent comp_psfunctor. Definition to_fiber_disp_map_counit : pstrans (comp_psfunctor to_fiber_disp_map from_fiber_disp_map) (id_psfunctor _). Proof. use make_pstrans. - exact to_fiber_disp_map_counit_data. - exact to_fiber_disp_map_counit_is_pstrans. Defined. Definition to_fiber_disp_map_counit_inv_data : pstrans_data (id_psfunctor _) (comp_psfunctor to_fiber_disp_map from_fiber_disp_map). Proof. use make_pstrans_data. - refine (λ x, id₁ _ ,, id_pred_mor D _ ,, _). exact (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)). - intros x y f. use make_invertible_2cell. + simple refine (_ ,, _). * cbn. exact (lunitor _ • rinvunitor _). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; rewrite runitor_rinvunitor ; rewrite id2_left ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite runitor_triangle ; rewrite lunitor_triangle ; rewrite vcomp_lunitor ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- lunitor_triangle ; rewrite (maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite lunitor_lwhisker ; apply idpath). + apply strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible. cbn. is_iso. Defined. Opaque strict_fiber_bicat comp_psfunctor. Definition to_fiber_disp_map_counit_inv_is_pstrans : is_pstrans to_fiber_disp_map_counit_inv_data. Proof. repeat split. - intros x y f g α. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _ @ !(comp_disp_map_fiber _ _)). etrans. { apply maponpaths_2. apply lwhisker_disp_map_fiber. } refine (!_). etrans. { apply maponpaths. apply rwhisker_disp_map_fiber. } cbn. refine (!_). refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply vcomp_lunitor. } refine (vassocl _ _ _ @ _ @ vassocr _ _ _). apply maponpaths. etrans. { apply rinvunitor_natural. } apply maponpaths. refine (!_). apply rwhisker_hcomp. - intros x. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. etrans. { apply lwhisker_disp_map_fiber. } apply maponpaths. exact (comp_disp_map_fiber (psfunctor_id to_fiber_disp_map x) (##to_fiber_disp_map (psfunctor_id from_fiber_disp_map x))). } refine (!_). refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. apply runitor_disp_map_fiber. } apply maponpaths. apply linvunitor_disp_map_fiber. } etrans. { apply maponpaths. apply rwhisker_disp_map_fiber. } cbn. etrans. { apply maponpaths. apply id2_rwhisker. } refine (id2_right _ @ _). refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id2_left. } apply lwhisker_id2. } refine (id2_left _ @ _). etrans. { apply maponpaths_2. apply lunitor_runitor_identity. } refine (runitor_rinvunitor _ @ _). refine (!_). etrans. { apply maponpaths_2. apply runitor_lunitor_identity. } apply lunitor_linvunitor. - intros x y z f g. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (lwhisker_disp_map_fiber _ _) @ _). refine (!_). refine (comp_disp_map_fiber _ _ @ _). refine (maponpaths (λ z, z • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((z • _) • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, (((z • _) • _) • _) • _) (comp_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((z • _) • _) • _) • _) • _) (lassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • z) • _) • _) • _) • _) (rwhisker_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • z) • _) • _) • _) (rassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • z) • _) • _) (lwhisker_disp_map_fiber _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • z) • _) (lassociator_disp_map_fiber _ _ _) @ _). refine (maponpaths (λ z, ((((_ • _) • _) • _) • _) • z) (rwhisker_disp_map_fiber _ _) @ _). refine (!_). etrans. { apply maponpaths_2. apply maponpaths. exact (comp_disp_map_fiber (psfunctor_comp to_fiber_disp_map (# from_fiber_disp_map f) (# from_fiber_disp_map g)) (## to_fiber_disp_map (psfunctor_comp from_fiber_disp_map f g))). } cbn. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id2_left. } apply lwhisker_id2. } refine (id2_left _ @ _). refine (!_). etrans. { apply maponpaths. apply id2_rwhisker. } refine (id2_right _ @ _). etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply rwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_triangle. } do 3 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply lwhisker_vcomp. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply left_unit_inv_assoc. } refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply rassociator_lassociator. } apply id2_right. } etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_lwhisker. } refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply rinvunitor_runitor. } apply id2_rwhisker. } apply id2_left. Qed. Transparent strict_fiber_bicat comp_psfunctor. Definition to_fiber_disp_map_counit_inv : pstrans (id_psfunctor _) (comp_psfunctor to_fiber_disp_map from_fiber_disp_map). Proof. use make_pstrans. - exact to_fiber_disp_map_counit_inv_data. - exact to_fiber_disp_map_counit_inv_is_pstrans. Defined. (** 6. The modifications *) Definition disp_map_unit_inv_left_data : invertible_modification_data (id_pstrans _) (comp_pstrans to_fiber_disp_map_unit_inv to_fiber_disp_map_unit). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (linvunitor _). + abstract (cbn ; apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite lunitor_runitor_identity ; rewrite lwhisker_hcomp, rwhisker_hcomp ; apply triangle_r). - apply is_invertible_2cell_in_disp_map_slice_bicat. cbn. is_iso. Defined. Definition disp_map_unit_inv_left_is_modification : is_modification disp_map_unit_inv_left_data. Proof. intros x y f. use eq_2cell_disp_map_slice. cbn. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite <- lwhisker_vcomp. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite runitor_lunitor_identity. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. apply idpath. Qed. Definition disp_map_unit_inv_left : invertible_modification (id_pstrans _) (comp_pstrans to_fiber_disp_map_unit_inv to_fiber_disp_map_unit). Proof. use make_invertible_modification. - exact disp_map_unit_inv_left_data. - exact disp_map_unit_inv_left_is_modification. Defined. Definition disp_map_unit_inv_right_data : invertible_modification_data (comp_pstrans to_fiber_disp_map_unit to_fiber_disp_map_unit_inv) (id_pstrans _). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (lunitor _). + abstract (cbn ; refine (_ @ id2_right _) ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite lunitor_runitor_identity ; rewrite lwhisker_hcomp, rwhisker_hcomp ; refine (!_) ; apply triangle_r). - apply is_invertible_2cell_in_disp_map_slice_bicat. cbn. is_iso. Defined. Definition disp_map_unit_inv_right_is_modification : is_modification disp_map_unit_inv_right_data. Proof. intros x y f. use eq_2cell_disp_map_slice. cbn. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite <- lwhisker_vcomp. rewrite lunitor_triangle. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lunitor_triangle. rewrite lwhisker_vcomp. rewrite vcomp_lunitor. rewrite !vassocl. apply idpath. Qed. Definition disp_map_unit_inv_right : invertible_modification (comp_pstrans to_fiber_disp_map_unit to_fiber_disp_map_unit_inv) (id_pstrans _). Proof. use make_invertible_modification. - exact disp_map_unit_inv_right_data. - exact disp_map_unit_inv_right_is_modification. Defined. Definition disp_map_counit_inv_right_data : invertible_modification_data (id_pstrans _) (comp_pstrans to_fiber_disp_map_counit to_fiber_disp_map_counit_inv). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (linvunitor _). + abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite <- rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). - use strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible. cbn. is_iso. Defined. Opaque comp_psfunctor strict_fiber_bicat. Definition disp_map_counit_inv_right_is_modification : is_modification disp_map_counit_inv_right_data. Proof. intros x y f. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _ @ !(comp_disp_map_fiber _ _)). etrans. { apply maponpaths. apply lwhisker_disp_map_fiber. } etrans. { apply maponpaths_2. cbn. apply comp_disp_map_fiber. } etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply lunitor_disp_map_fiber. } apply maponpaths. apply rinvunitor_disp_map_fiber. } refine (!_). etrans. { apply maponpaths_2. apply rwhisker_disp_map_fiber. } etrans. { apply maponpaths. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply rassociator_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply rwhisker_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply lassociator_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply lwhisker_disp_map_fiber. } apply maponpaths_2. apply rassociator_disp_map_fiber. } cbn. rewrite !vassocl. etrans. { apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocr. do 4 apply maponpaths_2. apply lunitor_lwhisker. } etrans. { rewrite !vassocr. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply rwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. apply runitor_lunitor_identity. } apply linvunitor_lunitor. } etrans. { apply maponpaths_2. apply id2_rwhisker. } apply id2_left. } refine (!_). etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply vcomp_lunitor. } apply vassocl. } do 2 refine (_ @ vassocr _ _ _). apply maponpaths. refine (!_). etrans. { etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply rwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lunitor_triangle. } refine (vassocl _ _ _ @ _). apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ]. use vcomp_move_L_Mp ; [ is_iso | ]. apply lunitor_lwhisker. Qed. Transparent comp_psfunctor strict_fiber_bicat. Definition disp_map_counit_inv_right : invertible_modification (id_pstrans _) (comp_pstrans to_fiber_disp_map_counit to_fiber_disp_map_counit_inv). Proof. use make_invertible_modification. - exact disp_map_counit_inv_right_data. - exact disp_map_counit_inv_right_is_modification. Defined. Definition disp_map_counit_inv_left_data : invertible_modification_data (comp_pstrans to_fiber_disp_map_counit_inv to_fiber_disp_map_counit) (id_pstrans _). Proof. intros x. use make_invertible_2cell. - simple refine (_ ,, _). + exact (lunitor _). + abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; rewrite lunitor_runitor_identity ; rewrite runitor_rwhisker ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite <- rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lunitor_lwhisker ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocl ; rewrite runitor_triangle ; rewrite vcomp_runitor ; apply idpath). - use strict_fiber_bicat_invertible_2cell. use is_invertible_to_is_disp_invertible. cbn. is_iso. Defined. Opaque comp_psfunctor strict_fiber_bicat. Definition disp_map_counit_inv_left_is_modification : is_modification disp_map_counit_inv_left_data. Proof. intros x y f. use path_2cell_disp_map_fiber. refine (comp_disp_map_fiber _ _ @ _ @ !(comp_disp_map_fiber _ _)). refine (!_). etrans. { apply maponpaths_2. apply rwhisker_disp_map_fiber. } etrans. { apply maponpaths. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths_2. apply lunitor_disp_map_fiber. } apply maponpaths. apply rinvunitor_disp_map_fiber. } refine (!_). etrans. { apply maponpaths. apply lwhisker_disp_map_fiber. } etrans. { apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply rassociator_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply rwhisker_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply lassociator_disp_map_fiber. } apply maponpaths_2. refine (comp_disp_map_fiber _ _ @ _). etrans. { apply maponpaths. apply lwhisker_disp_map_fiber. } apply maponpaths_2. apply rassociator_disp_map_fiber. } cbn. etrans. { do 4 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply lwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. etrans. { apply lunitor_lwhisker. } apply maponpaths. apply runitor_lunitor_identity. } do 4 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. apply lunitor_lwhisker. } refine (rwhisker_vcomp _ _ _ @ _). cbn. apply maponpaths. refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply rinvunitor_runitor. } apply id2_right. } etrans. { apply maponpaths. apply lunitor_triangle. } apply vcomp_lunitor. Qed. Transparent comp_psfunctor strict_fiber_bicat. Definition disp_map_counit_inv_left : invertible_modification (comp_pstrans to_fiber_disp_map_counit_inv to_fiber_disp_map_counit) (id_pstrans _). Proof. use make_invertible_modification. - exact disp_map_counit_inv_left_data. - exact disp_map_counit_inv_left_is_modification. Defined. (** 7. The biequivalence *) Definition to_fiber_disp_map_is_biequivalence : is_biequivalence to_fiber_disp_map. Proof. use make_is_biequivalence. - exact from_fiber_disp_map. - exact to_fiber_disp_map_unit. - exact to_fiber_disp_map_unit_inv. - exact to_fiber_disp_map_counit. - exact to_fiber_disp_map_counit_inv. - exact disp_map_unit_inv_left. - exact disp_map_unit_inv_right. - exact disp_map_counit_inv_right. - exact disp_map_counit_inv_left. Defined. End FiberOfDisplayMap. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/FiberBicategory1.v000066400000000000000000002453251451125700300307030ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Local Open Scope cat. Local Open Scope mor_disp_scope. Section Strict_Fiber_Bicat. Context {C : bicat} (D : disp_prebicat C) (h : local_iso_cleaving D) (c : C). Definition strict_fiber_bicat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. exists (discrete_fiber_precategory_data D h c). red. cbn. intros d d' f f'. exact (f ==>[id2 (identity c)] f'). Defined. Definition strict_fiber_bicat_data : prebicat_data. Proof. exists strict_fiber_bicat_1_id_comp_cells. repeat split; cbn. - intros. exact (disp_id2 _). - intros d d' ff. set (PP := disp_local_iso_cleaving_invertible_2cell h (id_disp d;; ff) (idempunitor c)). set (RR := PP •• disp_lunitor ff). assert (Heq : (idempunitor c) • lunitor (identity c) = id2 (identity c)). { abstract (apply linvunitor_lunitor). } exact (transportf (λ x, _ ==>[x] _) Heq RR). - intros d d' ff. assert (Heq : (idempunitor c) • runitor (identity c) = id2 (identity c)). { abstract (cbn ; rewrite <- lunitor_runitor_identity, linvunitor_lunitor ; reflexivity). } set (PP := disp_local_iso_cleaving_invertible_2cell h (ff;; id_disp d') (idempunitor c)). exact (transportf (λ x, _ ==>[x] _) Heq (PP •• disp_runitor ff)). - intros d d' ff. set (PP := disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (id_disp d;; ff) (idempunitor c))). assert (Heq : linvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)). { abstract (apply linvunitor_lunitor). } exact (transportf (λ x, _ ==>[x] _) Heq (disp_linvunitor ff •• PP)). - cbn. intros d d' ff. set (PP := disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (ff;; id_disp d') (idempunitor c))). assert (Heq : rinvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)). { unfold idempunitor. cbn. abstract (rewrite lunitor_runitor_identity, rinvunitor_runitor ; reflexivity). } exact (transportf (λ x, _ ==>[x] _) Heq (disp_rinvunitor ff •• PP)). - intros d0 d1 d2 d3 ff gg hh. assert (((idempunitor c) • ((idempunitor c) ▹ identity c)) • rassociator _ _ _ • ((identity c ◃ lunitor _) • lunitor _) = id2 _) as Heq. { abstract (cbn ; rewrite !lwhisker_hcomp, !rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite <- triangle_l_inv ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite lassociator_rassociator, id2_left ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- hcomp_vcomp ; rewrite id2_left, linvunitor_lunitor ; rewrite hcomp_identity, id2_left ; rewrite <- lunitor_V_id_is_left_unit_V_id ; rewrite linvunitor_lunitor ; reflexivity ). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). cbn. refine (_ •• disp_rassociator ff gg hh •• _). + refine (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c) •• _). refine (disp_rwhisker _ _). exact (disp_local_iso_cleaving_invertible_2cell h (ff ;; gg) (idempunitor c)). + refine (_ •• _). * refine (disp_lwhisker _ _). exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (gg ;; hh) (idempunitor c))). * exact (disp_inv_cell ((disp_local_iso_cleaving_invertible_2cell h (ff;;local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c)))). - intros d0 d1 d2 d3 ff gg hh. assert (((idempunitor c) • (identity c ◃ (idempunitor c))) • lassociator _ _ _ • ((lunitor _ ▹ identity c) • lunitor _) = id2 _) as Heq. { abstract (cbn ; rewrite !lwhisker_hcomp, !rwhisker_hcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite triangle_r_inv ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator, id2_left ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- hcomp_vcomp ; rewrite <- lunitor_V_id_is_left_unit_V_id ; rewrite id2_left, linvunitor_lunitor ; rewrite hcomp_identity, id2_left ; apply linvunitor_lunitor ). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). cbn. refine (_ •• disp_lassociator ff gg hh •• _). + refine (_ •• _). * exact (disp_local_iso_cleaving_invertible_2cell h (ff;;local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c)). * refine (disp_lwhisker _ _). exact (disp_local_iso_cleaving_invertible_2cell h (gg ;; hh) (idempunitor c)). + refine (_ •• _). * refine (disp_rwhisker _ _). exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (ff ;; gg) (idempunitor c))). * exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c))). - intros a b f1 f2 f3 x y. exact (transportf (λ z, _ ==>[ z ] _) (id2_left _) (x •• y)). - intros a1 a2 a3 f g1 g2 x. assert (linvunitor _ • (identity c ◃ id2 _) • lunitor _ = id2 (identity c)) as Heq. { abstract (rewrite lwhisker_id2 ; rewrite id2_right ; apply linvunitor_lunitor). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). refine (_ •• (f ◃◃ x) •• _). + exact (disp_local_iso_cleaving_invertible_2cell h (f ;; g1) (idempunitor c)). + exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (f ;; g2) (idempunitor c))). - intros a1 a2 a3 f1 f2 g x. assert (linvunitor _ • (id2 _ ▹ identity _) • lunitor _ = id2 (identity c)) as Heq. { abstract (rewrite id2_rwhisker ; rewrite id2_right ; apply linvunitor_lunitor). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). refine (_ •• (x ▹▹ g) •• _). + exact (disp_local_iso_cleaving_invertible_2cell h (f1 ;; g) (idempunitor c)). + exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (f2 ;; g) (idempunitor c))). Defined. Local Arguments transportf {_} {_} {_} {_} {_} _. Local Arguments transportb {_} {_} {_} {_} {_} _. Definition strict_fiber_bicat_data_laws_vcomp_left : ∏ (a b : strict_fiber_bicat_data) (f g : strict_fiber_bicat_data ⟦ a, b ⟧) (x : f ==> g), id₂ f • x = x. Proof. intros a b f g x ; cbn. rewrite disp_id2_left. rewrite transportfbinv. reflexivity. Qed. Definition strict_fiber_bicat_data_laws_vcomp_right : ∏ (a b : strict_fiber_bicat_data) (f g : strict_fiber_bicat_data ⟦ a, b ⟧) (x : f ==> g), x • id₂ g = x. Proof. intros a b f g x ; cbn. rewrite disp_id2_right. unfold transportb. rewrite transport_f_f. rewrite transportf_set. - reflexivity. - apply C. Qed. Definition strict_fiber_bicat_data_laws_vcomp_assoc : ∏ (a b : strict_fiber_bicat_data) (f₁ f₂ f₃ f₄ : strict_fiber_bicat_data ⟦ a, b ⟧) (x : f₁ ==> f₂) (y : f₂ ==> f₃) (z : f₃ ==> f₄), x • (y • z) = (x • y) • z. Proof. intros a b f₁ f₂ f₃ f₄ x y z ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite disp_vassocr. rewrite disp_mor_transportf_postwhisker. unfold transportb. rewrite !transport_f_f. apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, f₁ ==>[ α] f₄)). apply C. Qed. Definition strict_fiber_bicat_data_laws_rwhisker_id2 : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (g : strict_fiber_bicat_data ⟦ a₂, a₃ ⟧), f ◃ id₂ g = id₂ (f · g). Proof. intros a₁ a₂ a₃ f g ; cbn. rewrite disp_lwhisker_id2. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_right. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. apply (@transportf_transpose_left _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). refine (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f;; g) (idempunitor c)) @ _). unfold transportb. apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_id2_lwhisker : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (g : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧), id₂ f ▹ g = id₂ (f · g). Proof. intros a₁ a₂ a₃ f g ; cbn. rewrite disp_id2_rwhisker. unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. rewrite disp_id2_right. unfold transportb. rewrite disp_mor_transportf_postwhisker. rewrite transport_f_f. apply (@transportf_transpose_left _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). refine (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f;; g) (idempunitor c)) @ _). unfold transportb. apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_vcomp_lwhisker : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (g₁ g₂ g₃ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (x : g₁ ==> g₂) (y : g₂ ==> g₃), (f ◃ x) • (f ◃ y) = f ◃ (x • y). Proof. intros a₁ a₂ a₃ f g₁ g₂ g₃ x y ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. apply disp_mor_transportf_postwhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f;; g₂) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_right. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_vcomp_rwhisker : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data) (f₁ f₂ f₃ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (g : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (x : f₁ ==> f₂) (y : f₂ ==> f₃), (x ▹ g) • (y ▹ g) = (x • y) ▹ g. Proof. intros a₁ a₂ a₃ f₁ f₂ f₃ f₄ x y ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_mor_transportf_prewhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₂;; f₄) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. apply disp_rwhisker_vcomp. } apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_vcomp_lunitor : ∏ (a b : strict_fiber_bicat_data) (f g : strict_fiber_bicat_data ⟦ a, b ⟧) (x : f ==> g), (id₁ a ◃ x) • lunitor g = lunitor f • x. Proof. intros a b f g x ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (id_disp a;; g) (idempunitor c))). } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. apply disp_vcomp_lunitor. } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. refine (_ @ _). { apply maponpaths. apply disp_vassocr. } unfold transportb. rewrite transport_f_f. apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_vcomp_runitor : ∏ (a b : strict_fiber_bicat_data) (f g : strict_fiber_bicat_data ⟦ a, b ⟧) (x : f ==> g), (x ▹ id₁ b) • runitor g = runitor f • x. Proof. intros a b f g x ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite !disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths. apply maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (g;;id_disp b) (idempunitor c))). } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. apply disp_vcomp_runitor. } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. refine (_ @ _). { apply maponpaths. apply disp_vassocr. } unfold transportb. rewrite transport_f_f. apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply C. Qed. Definition strict_fiber_bicat_data_laws_lwhisker_lwhisker : ∏ (a₁ a₂ a₃ a₄ : strict_fiber_bicat_data) (f₁ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (f₂ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (f₃ f₄ : strict_fiber_bicat_data ⟦ a₃ , a₄ ⟧) (x : f₃ ==> f₄), (f₁ ◃ (f₂ ◃ x)) • lassociator f₁ f₂ f₄ = lassociator f₁ f₂ f₃ • (f₁ · f₂ ◃ x). Proof. intros a₁ a₂ a₃ a₄ f₁ f₂ g₁ g₂ x ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } do 2 apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_right. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } refine (!_). etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_mor_transportf_prewhisker. } refine (!_). do 3 (refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _)). do 2 refine (_ @ !(@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _)). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; local_iso_cleaving_1cell h (f₂;; g₂) (idempunitor c)) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_lwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply disp_rwhisker_transport_right. } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₂;; g₂) (idempunitor c))). } etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_id2_right. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_right. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp_alt. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_lwhisker_lwhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vcomp_whisker_alt. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f₁;; f₂) (idempunitor c);; g₁) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. Definition strict_fiber_bicat_data_laws_rwhisker_lwhisker : ∏ (a₁ a₂ a₃ a₄ : strict_fiber_bicat_data) (f₁ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (f₂ f₃ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (f₄ : strict_fiber_bicat_data ⟦ a₃ , a₄ ⟧) (x : f₂ ==> f₃), (f₁ ◃ (x ▹ f₄)) • lassociator f₁ f₃ f₄ = lassociator f₁ f₂ f₄ • ((f₁ ◃ x) ▹ f₄). Proof. intros a₁ a₂ a₃ a₄ f₁ f₂ f₃ f₄ x ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_right. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } refine (!_). etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_mor_transportf_prewhisker. } refine (!_). do 3 (refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _)). do 2 refine (_ @ !(@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _)). etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; local_iso_cleaving_1cell h (f₃;; f₄) (idempunitor c)) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_lwhisker_vcomp _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₃;; f₄) (idempunitor c))). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_id2_right. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_right. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp_alt. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (disp_vassocl _ _ _ @ _). do 2 apply maponpaths. apply disp_rwhisker_lwhisker. } unfold transportb. apply disp_mor_transportf_postwhisker. } etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. do 2 apply maponpaths_2. apply disp_mor_transportf_prewhisker. } etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } do 2 refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _). refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f₁;; f₂) (idempunitor c);; f₄) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_vcomp. } etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; f₂) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_rwhisker_transport_left_new. } etrans. { apply maponpaths. apply disp_rwhisker_vcomp_alt. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. Definition strict_fiber_bicat_data_laws_rwhisker_rwhisker : ∏ (a₁ a₂ a₃ a₄ : strict_fiber_bicat_data) (f₁ f₂ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (f₃ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (f₄ : strict_fiber_bicat_data ⟦ a₃ , a₄ ⟧) (x : f₁ ==> f₂), lassociator f₁ f₃ f₄ • ((x ▹ f₃) ▹ f₄) = (x ▹ f₃ · f₄) • lassociator f₂ f₃ f₄. Proof. intros a₁ a₂ a₃ a₄ f₁ f₂ f₃ f₄ x ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } do 3 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). refine (!_). etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_mor_transportf_prewhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₂;; local_iso_cleaving_1cell h (f₃;; f₄) (idempunitor c)) (idempunitor c))). } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply maponpaths. apply disp_id2_left. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). refine (!_). etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f₁;; f₃) (idempunitor c);; f₄) (idempunitor c))). } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_vcomp. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; f₃) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_id2_left. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_vcomp_alt. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_rwhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_vcomp_whisker_alt. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply disp_vassocr. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. Definition strict_fiber_bicat_data_vcomp_whisker : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data) (f₁ f₂ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (g₁ g₂ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (x : f₁ ==> f₂) (y : g₁ ==> g₂), (x ▹ g₁) • (f₂ ◃ y) = (f₁ ◃ y) • (x ▹ g₂). Proof. intros a₁ a₂ a₃ f₁ f₂ g₁ g₂ x y ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; g₂) (idempunitor c))). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₂;; g₁) (idempunitor c))). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_vcomp_whisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. Definition strict_fiber_bicat_data_laws_lunitor_linvunitor : ∏ (a b : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a, b ⟧), lunitor f • linvunitor f = id₂ (id₁ a · f). Proof. intros a b f ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths, maponpaths_2. apply disp_lunitor_linvunitor. } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (id_disp a;; f) (idempunitor c))). } unfold transportb. rewrite transport_f_f. apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. Definition strict_fiber_bicat_data_laws_linvunitor_lunitor : ∏ (a b : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a, b ⟧), linvunitor f • lunitor f = id₂ f. Proof. intros a b f ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths, maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (id_disp a;; f) (idempunitor c))). } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply disp_linvunitor_lunitor. } unfold transportb. rewrite transport_f_f. apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. Definition strict_fiber_bicat_data_laws_runitor_rinvunitor : ∏ (a b : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a, b ⟧), runitor f • rinvunitor f = id₂ (f · id₁ b). Proof. intros a b f ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths, maponpaths_2. apply disp_runitor_rinvunitor. } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f ;; id_disp b) (idempunitor c))). } unfold transportb. rewrite transport_f_f. apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. Definition strict_fiber_bicat_data_laws_rinvunitor_runitor : ∏ (a b : strict_fiber_bicat_data) (f : strict_fiber_bicat_data ⟦ a, b ⟧), rinvunitor f • runitor f = id₂ f. Proof. intros a b f ; cbn. rewrite disp_mor_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. rewrite disp_vassocl. do 2 apply maponpaths. rewrite disp_vassocr. apply maponpaths, maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f ;; id_disp b) (idempunitor c))). } unfold transportb. rewrite transport_f_f. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. rewrite disp_mor_transportf_postwhisker. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply disp_id2_left. } unfold transportb. rewrite disp_mor_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply disp_rinvunitor_runitor. } unfold transportb. rewrite transport_f_f. apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. Definition strict_fiber_bicat_data_laws_lassociator_rassociator : ∏ (a₁ a₂ a₃ a₄ : strict_fiber_bicat_data) (f₁ : strict_fiber_bicat_data ⟦ a₁ , a₂ ⟧) (f₂ : strict_fiber_bicat_data ⟦ a₂ , a₃ ⟧) (f₃ : strict_fiber_bicat_data ⟦ a₃ , a₄ ⟧), lassociator f₁ f₂ f₃ • rassociator f₁ f₂ f₃ = id₂ (f₁ · (f₂ · f₃)). Proof. intros a₁ a₂ a₃ a₄ f₁ f₂ f₃ ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. apply disp_mor_transportf_postwhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f₁;; f₂) (idempunitor c);; f₃) (idempunitor c))). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_rwhisker_vcomp _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; f₂) (idempunitor c))). } apply disp_rwhisker_transport_left_new. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_id2_rwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lassociator_rassociator. } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp. } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. exact (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f₂;; f₃) (idempunitor c))). } etrans. { apply disp_rwhisker_transport_right. } etrans. { apply maponpaths. apply disp_lwhisker_id2. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. exact (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f₁;; local_iso_cleaving_1cell h (f₂;; f₃) (idempunitor c)) (idempunitor c))). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. End Strict_Fiber_Bicat. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/FiberBicategory2.v000066400000000000000000002260511451125700300306770ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategories Benedikt Ahrens, Marco Maggesi February 2018 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory.FiberBicategory1. Local Open Scope cat. Local Open Scope mor_disp_scope. Section LocalIsoFibration. Context {C : bicat}. Variable (D : disp_bicat C) (h : local_iso_cleaving D) (c : C). Local Arguments transportf {_} {_} {_} {_} {_} _. Local Arguments transportb {_} {_} {_} {_} {_} _. Local Arguments disp_lassociator {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Local Arguments disp_rassociator {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Local Notation "'ℓ1'" := (local_iso_cleaving_1cell h _ (idempunitor c)) (at level 0). Local Notation "'ℓ2'" := (disp_local_iso_cleaving_invertible_2cell h _ (idempunitor c)) (at level 0). Local Notation "f ^-1" := (disp_inv_cell f). Definition strict_fiber_bicat_data_laws_rassociator_lassociator : ∏ (a₁ a₂ a₃ a₄ : strict_fiber_bicat_data D h c) (f₁ : strict_fiber_bicat_data D h c ⟦ a₁ , a₂ ⟧) (f₂ : strict_fiber_bicat_data D h c ⟦ a₂ , a₃ ⟧) (f₃ : strict_fiber_bicat_data D h c ⟦ a₃ , a₄ ⟧), rassociator f₁ f₂ f₃ • lassociator f₁ f₂ f₃ = id₂ (f₁ · f₂ · f₃). Proof. intros a₁ a₂ a₃ a₄ f₁ f₂ f₃ ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. apply disp_mor_transportf_postwhisker. } do 2 refine (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₁;; local_iso_cleaving_1cell h (f₂;; f₃) (idempunitor c)) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp. } etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f₂;; f₃) (idempunitor c))). } apply disp_rwhisker_transport_right. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_lwhisker_id2. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_rassociator_lassociator. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_rwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (f₁;; f₂) (idempunitor c))). } etrans. { apply disp_rwhisker_transport_left_new. } etrans. { apply maponpaths. apply disp_id2_rwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths_2. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. exact (disp_vcomp_rinv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f₁;; f₂) (idempunitor c);; f₃) (idempunitor c))). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (transportf_set (λ α : id₁ c ==> id₁ c, _ ==>[ α] _) _). apply C. Qed. Definition strict_fiber_bicat_data_laws_runitor_rwhisker : ∏ (a₁ a₂ a₃ : strict_fiber_bicat_data D h c) (f : strict_fiber_bicat_data D h c ⟦ a₁ , a₂ ⟧) (g : strict_fiber_bicat_data D h c ⟦ a₂ , a₃ ⟧), lassociator f (id₁ a₂) g • (runitor f ▹ g) = f ◃ lunitor g. Proof. intros a₁ a₂ a₃ f g ; cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. apply disp_mor_transportf_postwhisker. } do 3 refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _). refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_right. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _). refine (!_). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). do 2 apply maponpaths. refine (disp_vassocl _ _ _ @ _). do 2 apply maponpaths. refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (f;; id_disp a₂) (idempunitor c);; g) (idempunitor c))). } unfold transportb. etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. exact (disp_id2_left _). } unfold transportb. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } unfold transportb. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } unfold transportb. refine (@transport_f_f _ (λ z : id₁ c ==> id₁ c, _ ==>[ z ] _) _ _ _ _ _ _ @ _). etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_rwhisker_vcomp. } etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv (disp_local_iso_cleaving_invertible_2cell h (f;; id_disp a₂) (idempunitor c))). } etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_left_new. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_runitor_rwhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. exact (disp_vassocl _ _ _). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. Section LassociatorLassociator. Variable (a₁ a₂ a₃ a₄ a₅ : strict_fiber_bicat_data D h c) (f₁ : strict_fiber_bicat_data D h c ⟦ a₁ , a₂ ⟧) (f₂ : strict_fiber_bicat_data D h c ⟦ a₂ , a₃ ⟧) (f₃ : strict_fiber_bicat_data D h c ⟦ a₃ , a₄ ⟧) (f₄ : strict_fiber_bicat_data D h c ⟦ a₄ , a₅ ⟧). Arguments transportf {_} _ {_} {_} _ _. Local Definition step1 : ∑ p, ((f₁ ◃ lassociator f₂ f₃ f₄) • lassociator f₁ (f₂ · f₃) f₄) • (lassociator f₁ f₂ f₃ ▹ f₄) = transportf (λ z, _ ==>[ z] _) p ((((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2 ^-1)))) •• ℓ2 ^-1) •• (((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2^-1))) •• ((ℓ2 •• ((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄)) •• ℓ2^-1)). Proof. eexists. cbn. etrans. { etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. etrans. { apply maponpaths_2. apply disp_mor_transportf_prewhisker. } etrans. { etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_right. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_rwhisker_transport_left_new. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_postwhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply idpath. Qed. Local Definition step2 : ∑ p, transportf (λ z, _ ==>[ z] _) p ((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ ℓ1) •• ℓ2^-1)) •• (((ℓ2 •• (ℓ1 ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1))) = lassociator f₁ f₂ (f₃ · f₄) • lassociator (f₁ · f₂) f₃ f₄. Proof. eexists. refine (!_). cbn. etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step3 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step1) ((((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2 ^-1)))) •• ℓ2 ^-1) •• (((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2^-1))) •• ((ℓ2 •• ((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄)) •• ℓ2^-1)) = transportf (λ z, _ ==>[ z ] _) p ((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2^-1)))) •• ((((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)) •• ((ℓ2 •• ((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄)) •• ℓ2^-1))). Proof. eexists. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. {apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv ℓ2). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step4 : ∑ p, transportf (λ z, _ ==>[ z ] _) (pr1 step3) ((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2 ^-1 ▹▹ f₄) •• ℓ2^-1)))) •• ((((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)) •• ((ℓ2 •• ((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄)) •• ℓ2^-1))) = transportf (λ z, _ ==>[ z] _) p ((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)))) •• (((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1)))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (disp_vcomp_linv ℓ2). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step5 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step4) ((ℓ2 •• (f₁ ◃◃ (((ℓ2 •• (f₂ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)))) •• (((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1)))) = transportf (λ z, _ ==>[ z] _) p ((ℓ2 •• ((f₁ ◃◃ ℓ2) •• (f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• (disp_lassociator •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)))))) •• (((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1)))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply disp_rwhisker_transport_right. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply disp_rwhisker_transport_right. } apply maponpaths. apply disp_lwhisker_vcomp_alt. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step6 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step5) ((ℓ2 •• ((f₁ ◃◃ ℓ2) •• (f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• (disp_lassociator •• ((ℓ2^-1 ▹▹ f₄) •• ℓ2^-1)))))) •• (((f₁ ◃◃ ℓ2) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1)))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• (disp_lassociator •• (ℓ2^-1 ▹▹ f₄)))) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1))))). Proof. eexists. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. exact (disp_vcomp_linv ℓ2). } etrans. { apply disp_mor_transportf_prewhisker. } apply maponpaths. apply disp_id2_right. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_right. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step7 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step6) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• (disp_lassociator •• (ℓ2^-1 ▹▹ f₄)))) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1))))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((f₁ ◃◃ ℓ2^-1) ▹▹ f₄))) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1))))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply disp_vassocr. } etrans. { apply disp_rwhisker_transport_right. } etrans. { apply maponpaths. apply disp_lwhisker_vcomp_alt. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. refine (disp_vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_rwhisker_lwhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step8 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step7) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((f₁ ◃◃ ℓ2^-1) ▹▹ f₄))) •• ((ℓ2^-1 ▹▹ f₄) •• (((((ℓ2 •• (f₁ ◃◃ ℓ2)) •• disp_lassociator) •• ((ℓ2^-1 ▹▹ f₃) •• ℓ2^-1)) ▹▹ f₄) •• ℓ2^-1))))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((f₁ ◃◃ ℓ2 ^-1) ▹▹ f₄))) •• ((((((f₁ ◃◃ ℓ2) •• disp_lassociator) •• (ℓ2 ^-1 ▹▹ f₃)) •• ℓ2 ^-1) ▹▹ f₄) •• ℓ2 ^-1)))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (disp_vassocr _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_rwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. etrans. { apply disp_vassocr. } apply maponpaths. etrans. { apply disp_vassocr. } apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply disp_vassocr. } apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_vassocr. } apply maponpaths. etrans. { apply maponpaths_2. apply (disp_vcomp_linv ℓ2). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_left_new. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step9 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step8) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((f₁ ◃◃ ℓ2 ^-1) ▹▹ f₄))) •• ((((((f₁ ◃◃ ℓ2) •• disp_lassociator) •• (ℓ2 ^-1 ▹▹ f₃)) •• ℓ2 ^-1) ▹▹ f₄) •• ℓ2 ^-1)))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((((disp_lassociator •• (ℓ2 ^-1 ▹▹ f₃)) •• ℓ2 ^-1) ▹▹ f₄) •• ℓ2 ^-1))))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_rwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { etrans. { apply disp_lwhisker_vcomp. } apply maponpaths. etrans. { apply maponpaths. apply (disp_vcomp_linv ℓ2). } etrans. { apply disp_rwhisker_transport_right. } apply maponpaths. apply disp_lwhisker_id2. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_rwhisker_transport_left_new. } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step10 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step9) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((f₁ ◃◃ ((f₂ ◃◃ ℓ2) •• disp_lassociator)) •• (disp_lassociator •• ((((disp_lassociator •• (ℓ2 ^-1 ▹▹ f₃)) •• ℓ2 ^-1) ▹▹ f₄) •• ℓ2 ^-1))))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((f₁ ◃◃ (f₂ ◃◃ ℓ2)) •• (((disp_lassociator •• disp_lassociator) •• (((ℓ2 ^-1 ▹▹ f₃) •• ℓ2 ^-1) ▹▹ f₄)) •• ℓ2 ^-1)))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_vcomp_alt. } etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocl. } etrans. { apply disp_rwhisker_transport_left_new. } apply maponpaths. apply disp_rwhisker_vcomp_alt. } etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply disp_lassociator_lassociator. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step11 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step10) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((f₁ ◃◃ (f₂ ◃◃ ℓ2)) •• (((disp_lassociator •• disp_lassociator) •• (((ℓ2 ^-1 ▹▹ f₃) •• ℓ2 ^-1) ▹▹ f₄)) •• ℓ2 ^-1)))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((((disp_lassociator •• (f₁;; f₂ ◃◃ ℓ2)) •• disp_lassociator) •• (((ℓ2 ^-1 ▹▹ f₃) •• ℓ2 ^-1) ▹▹ f₄)) •• ℓ2 ^-1))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply disp_vassocr. } apply maponpaths. etrans. { apply maponpaths_2. apply disp_lwhisker_lwhisker. } apply disp_mor_transportf_postwhisker. } etrans. { etrans. { apply disp_mor_transportf_postwhisker. } apply maponpaths. apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step12 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step11) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• ((((disp_lassociator •• (f₁;; f₂ ◃◃ ℓ2)) •• disp_lassociator) •• (((ℓ2 ^-1 ▹▹ f₃) •• ℓ2 ^-1) ▹▹ f₄)) •• ℓ2 ^-1))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((disp_lassociator •• (f₁;; f₂ ◃◃ ℓ2)) •• (((ℓ2 ^-1 ▹▹ f₃;; f₄) •• disp_lassociator) •• (ℓ2 ^-1 ▹▹ f₄))) •• ℓ2 ^-1))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_rwhisker_vcomp_alt. } etrans. { apply disp_mor_transportf_prewhisker. } etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply disp_rwhisker_rwhisker. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Definition step13 : ∑ p, transportf (λ z, _ ==>[ z] _) (pr1 step12) (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((disp_lassociator •• (f₁;; f₂ ◃◃ ℓ2)) •• (((ℓ2 ^-1 ▹▹ f₃;; f₄) •• disp_lassociator) •• (ℓ2 ^-1 ▹▹ f₄))) •• ℓ2 ^-1))) = transportf (λ z, _ ==>[ z] _) p (ℓ2 •• ((f₁ ◃◃ ℓ2) •• (((disp_lassociator •• (((ℓ2 ^-1 ▹▹ ℓ1) •• (ℓ1 ◃◃ ℓ2)) •• disp_lassociator)) •• (ℓ2 ^-1 ▹▹ f₄)) •• ℓ2 ^-1))). Proof. eexists. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply disp_vcomp_whisker_alt. } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). Qed. Local Arguments transportf {_} _ {_} {_} {_} _. Definition strict_fiber_bicat_data_laws_lassociator_lassociator : ((f₁ ◃ lassociator f₂ f₃ f₄) • lassociator f₁ (f₂ · f₃) f₄) • (lassociator f₁ f₂ f₃ ▹ f₄) = lassociator f₁ f₂ (f₃ · f₄) • lassociator (f₁ · f₂) f₃ f₄. Proof. refine (pr2 step1 @ _). refine (_ @ pr2 step2). refine (pr2 step3 @ _). refine (pr2 step4 @ _). refine (pr2 step5 @ _). refine (pr2 step6 @ _). refine (pr2 step7 @ _). refine (pr2 step8 @ _). refine (pr2 step9 @ _). refine (pr2 step10 @ _). refine (pr2 step11 @ _). refine (pr2 step12 @ _). refine (pr2 step13 @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply disp_vassocl. } apply disp_mor_transportf_postwhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } refine (!_). etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. etrans. { refine (disp_vassocr _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply (disp_vcomp_linv ℓ2). } etrans. { apply disp_mor_transportf_postwhisker. } etrans. { apply maponpaths. apply disp_id2_left. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_postwhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply maponpaths. etrans. { refine (disp_vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply disp_vassocr. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply disp_mor_transportf_prewhisker. } apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } etrans. { apply (@transport_f_f _ (λ z : _ ==> _, _ ==>[ z ] _)). } apply (@transportf_paths _ (λ α : id₁ c ==> id₁ c, _ ==>[ α] _)). apply cellset_property. Qed. End LassociatorLassociator. Definition strict_fiber_bicat_data_laws : prebicat_laws (strict_fiber_bicat_data D h c). Proof. repeat split. - exact (strict_fiber_bicat_data_laws_vcomp_left D h c). - exact (strict_fiber_bicat_data_laws_vcomp_right D h c). - exact (strict_fiber_bicat_data_laws_vcomp_assoc D h c). - exact (strict_fiber_bicat_data_laws_rwhisker_id2 D h c). - exact (strict_fiber_bicat_data_laws_id2_lwhisker D h c). - exact (strict_fiber_bicat_data_laws_vcomp_lwhisker D h c). - exact (strict_fiber_bicat_data_laws_vcomp_rwhisker D h c). - exact (strict_fiber_bicat_data_laws_vcomp_lunitor D h c). - exact (strict_fiber_bicat_data_laws_vcomp_runitor D h c). - exact (strict_fiber_bicat_data_laws_lwhisker_lwhisker D h c). - exact (strict_fiber_bicat_data_laws_rwhisker_lwhisker D h c). - exact (strict_fiber_bicat_data_laws_rwhisker_rwhisker D h c). - exact (strict_fiber_bicat_data_vcomp_whisker D h c). - exact (strict_fiber_bicat_data_laws_lunitor_linvunitor D h c). - exact (strict_fiber_bicat_data_laws_linvunitor_lunitor D h c). - exact (strict_fiber_bicat_data_laws_runitor_rinvunitor D h c). - exact (strict_fiber_bicat_data_laws_rinvunitor_runitor D h c). - exact (strict_fiber_bicat_data_laws_lassociator_rassociator D h c). - exact strict_fiber_bicat_data_laws_rassociator_lassociator. - exact strict_fiber_bicat_data_laws_runitor_rwhisker. - exact strict_fiber_bicat_data_laws_lassociator_lassociator. Qed. Definition strict_fiber_prebicat : prebicat. Proof. use tpair. - exact (strict_fiber_bicat_data D h c). - exact strict_fiber_bicat_data_laws. Defined. Definition strict_fiber_bicat : bicat. Proof. use tpair. - exact strict_fiber_prebicat. - intros x y f g. apply disp_cellset_property. Defined. End LocalIsoFibration. Definition strict_fiber_bicat_invertible_2cell {B : bicat} {D : disp_bicat B} {HD : local_iso_cleaving D} {b : B} {x y : strict_fiber_bicat D HD b} {f g : x --> y} {α : f ==> g} (Hα : is_disp_invertible_2cell (id2_invertible_2cell _) α) : is_invertible_2cell α. Proof. pose (αcell := (α ,, Hα) : disp_invertible_2cell (id2_invertible_2cell _) f g). use make_is_invertible_2cell. - exact (disp_inv_cell αcell). - abstract (cbn ; refine (maponpaths _ (disp_vcomp_rinv αcell) @ _) ; unfold transportb ; rewrite transport_f_f ; refine (_ @ idpath_transportf (λ z, _ ==>[ z ] _) _) ; apply maponpaths_2 ; apply cellset_property). - abstract (cbn ; refine (maponpaths _ (disp_vcomp_linv αcell) @ _) ; unfold transportb ; rewrite transport_f_f ; refine (_ @ idpath_transportf (λ z, _ ==>[ z ] _) _) ; apply maponpaths_2 ; apply cellset_property). Defined. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/FunctorFromCleaving.v000066400000000000000000000370351451125700300314740ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.Cartesians. Local Open Scope cat. Local Open Scope mor_disp. Section ProjectionsGlobalCleaving. Context {B : bicat} {D : disp_bicat B} (global_D : global_cleaving D). Definition global_lift {x y : B} (f : x --> y) (yy : D y) : D x := pr1 (global_D x y yy f). Definition mor_from_global_lift {x y : B} (f : x --> y) (yy : D y) : global_lift f yy -->[ f ] yy := pr12 (global_D x y yy f). Definition is_cartesian_mor_from_global_lift {x y : B} (f : x --> y) (yy : D y) : cartesian_1cell D (mor_from_global_lift f yy) := pr22 (global_D x y yy f). Section GlobalCleavingOnMor. Context (local_D : local_iso_cleaving D) {x y : B} (f : x --> y). Definition global_lift_mor {yy₁ yy₂ : D y} (ff : yy₁ -->[ id₁ y ] yy₂) : global_lift f yy₁ -->[ id₁ x ] global_lift f yy₂ := cartesian_1cell_lift_1cell D _ (is_cartesian_mor_from_global_lift f yy₂) (local_iso_cleaving_1cell local_D (mor_from_global_lift f yy₁ ;; ff) (comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _))). Section OnId. Context (yy : D y). Local Definition global_mor_id_mor : global_lift f yy -->[ id₁ x · f] yy := local_iso_cleaving_1cell local_D (mor_from_global_lift f yy) (lunitor_invertible_2cell _). Local Definition global_mor_id_factor : disp_invertible_2cell (id2_invertible_2cell (id₁ x · f)) (id_disp (global_lift f yy) ;; mor_from_global_lift f yy) global_mor_id_mor. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (disp_invertible_2cell_lunitor _) (inverse_of_disp_invertible_2cell (disp_local_iso_cleaving_invertible_2cell local_D (mor_from_global_lift f yy) (lunitor_invertible_2cell f))))). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; apply lunitor_linvunitor). Defined. Definition global_mor_id_cell : disp_invertible_2cell (rwhisker_of_invertible_2cell _ (id2_invertible_2cell _)) (local_iso_cleaving_1cell local_D (mor_from_global_lift f yy ;; id_disp yy) (comp_of_invertible_2cell (lunitor_invertible_2cell f) (rinvunitor_invertible_2cell f))) global_mor_id_mor. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (disp_local_iso_cleaving_invertible_2cell local_D (mor_from_global_lift f yy ;; id_disp yy) (comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _))) (vcomp_disp_invertible (disp_invertible_2cell_runitor _) (inverse_of_disp_invertible_2cell (disp_local_iso_cleaving_invertible_2cell local_D (mor_from_global_lift f yy) (lunitor_invertible_2cell f)))))). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocl ; rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rinvunitor_runitor ; rewrite id2_left ; rewrite id2_rwhisker ; apply lunitor_linvunitor). Defined. Definition global_mor_id : disp_invertible_2cell (id2_invertible_2cell (id₁ x)) (global_lift_mor (id_disp yy)) (id_disp _). Proof. simple refine (_ ,, _). + exact (cartesian_1cell_lift_2cell D _ (is_cartesian_mor_from_global_lift f yy) global_mor_id_cell _ (id_disp (global_lift f yy) ,, global_mor_id_factor)). + use (cartesian_1cell_lift_2cell_invertible D (is_cartesian_mor_from_global_lift f yy) _ _ _ (id_disp (global_lift f yy) ,, global_mor_id_factor)). exact (pr2 global_mor_id_cell). Defined. End OnId. Section OnComp. Context {yy₁ yy₂ yy₃ : D y} (ff : yy₁ -->[ id₁ y] yy₂) (gg : yy₂ -->[ id₁ y] yy₃). Definition global_mor_comp_mor : global_lift f yy₁ -->[ id₁ x · f ] yy₃ := local_iso_cleaving_1cell local_D (mor_from_global_lift f yy₁ ;; ff ;; gg) (comp_of_invertible_2cell (lunitor_invertible_2cell _) (comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (rinvunitor_invertible_2cell _))). Definition global_mor_comp_factor : disp_invertible_2cell (id2_invertible_2cell (id₁ x · f)) (local_iso_cleaving_1cell local_D (global_lift_mor ff ;; global_lift_mor gg) (idempunitor x) ;; mor_from_global_lift f yy₃) global_mor_comp_mor. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (vcomp_disp_invertible (disp_invertible_2cell_rwhisker _ (disp_local_iso_cleaving_invertible_2cell local_D _ _)) (vcomp_disp_invertible (disp_invertible_2cell_rassociator _ _ _) (vcomp_disp_invertible (disp_invertible_2cell_lwhisker _ (pr2 (cartesian_1cell_lift_1cell D (mor_from_global_lift f yy₃) _ _))) (vcomp_disp_invertible (disp_invertible_2cell_lwhisker _ (disp_local_iso_cleaving_invertible_2cell local_D _ _)) (vcomp_disp_invertible (disp_invertible_2cell_lassociator _ _ _) (disp_invertible_2cell_rwhisker _ (vcomp_disp_invertible (pr2 (cartesian_1cell_lift_1cell D _ _ _)) (disp_local_iso_cleaving_invertible_2cell local_D _ _)))))))) (inverse_of_disp_invertible_2cell (disp_local_iso_cleaving_invertible_2cell local_D _ _)))). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite lwhisker_id2, !id2_left ; rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lunitor_lwhisker ; rewrite runitor_lunitor_identity ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite linvunitor_lunitor ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lunitor_triangle ; rewrite !vassocr ; rewrite vcomp_lunitor ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; refine (_ @ id2_right _) ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; refine (_ @ id2_left _) ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- runitor_triangle ; rewrite runitor_lunitor_identity ; rewrite lunitor_lwhisker ; rewrite rwhisker_vcomp ; rewrite rinvunitor_runitor ; apply id2_rwhisker). Defined. Definition global_mor_comp_cell : disp_invertible_2cell (rwhisker_of_invertible_2cell _ (id2_invertible_2cell _)) (local_iso_cleaving_1cell local_D (mor_from_global_lift f yy₁ ;; local_iso_cleaving_1cell local_D (ff ;; gg) (idempunitor y)) (comp_of_invertible_2cell (lunitor_invertible_2cell f) (rinvunitor_invertible_2cell f))) global_mor_comp_mor. Proof. refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (disp_local_iso_cleaving_invertible_2cell local_D _ _) (vcomp_disp_invertible (vcomp_disp_invertible (disp_invertible_2cell_lwhisker _ (disp_local_iso_cleaving_invertible_2cell local_D _ _)) (disp_invertible_2cell_lassociator _ _ _)) (inverse_of_disp_invertible_2cell (disp_local_iso_cleaving_invertible_2cell local_D _ _))))). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite id2_rwhisker ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; refine (_ @ id2_right _) ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; refine (_ @ id2_right _) ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite <- runitor_triangle ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite runitor_lunitor_identity ; apply idpath). Defined. Definition global_mor_comp : disp_invertible_2cell (id2_invertible_2cell _) (global_lift_mor (local_iso_cleaving_1cell local_D (ff ;; gg) (idempunitor y))) (local_iso_cleaving_1cell local_D (global_lift_mor ff ;; global_lift_mor gg) (idempunitor x)). Proof. simple refine (_ ,, _). - exact (cartesian_1cell_lift_2cell D _ (is_cartesian_mor_from_global_lift f yy₃) global_mor_comp_cell _ (local_iso_cleaving_1cell local_D (global_lift_mor ff ;; global_lift_mor gg) (idempunitor x) ,, global_mor_comp_factor)). - use (cartesian_1cell_lift_2cell_invertible D (is_cartesian_mor_from_global_lift f yy₃) _ _ _ (_ ,, _)). exact (pr2 global_mor_comp_cell). Defined. End OnComp. End GlobalCleavingOnMor. End ProjectionsGlobalCleaving. Section FiberFunctor. Context {B : bicat} (D : disp_bicat B) (HD₁ : disp_2cells_isaprop D) (HD₂ : disp_univalent_2_1 D) (global_D : global_cleaving D) (local_D : local_iso_cleaving D) {x y : B} (f : x --> y). Definition functor_from_cleaving_data : functor_data (discrete_fiber_category D HD₁ HD₂ local_D y) (discrete_fiber_category D HD₁ HD₂ local_D x). Proof. use make_functor_data. - exact (λ yy, global_lift global_D f yy). - exact (λ yy₁ yy₂ ff, global_lift_mor global_D local_D f ff). Defined. Definition functor_from_cleaving_is_functor : is_functor functor_from_cleaving_data. Proof. split. - intros yy. apply (disp_isotoid_2_1 _ HD₂ (idpath _)). exact (global_mor_id global_D local_D f yy). - intros yy₁ yy₂ yy₃ ff gg ; cbn in *. apply (disp_isotoid_2_1 _ HD₂ (idpath _)). exact (global_mor_comp global_D local_D f ff gg). Qed. Definition functor_from_cleaving : discrete_fiber_category D HD₁ HD₂ local_D y ⟶ discrete_fiber_category D HD₁ HD₂ local_D x. Proof. use make_functor. - exact functor_from_cleaving_data. - exact functor_from_cleaving_is_functor. Defined. End FiberFunctor. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/SliceFiber.v000066400000000000000000000550561451125700300275710ustar00rootroot00000000000000(************************************************************************************ Fibers of slice bicategories Each of the variations of slice bicategories has a local isocleaving, and thus we can talk about fiber categories. The slice of each of them is some variation of the hom-category: - for the lax slice, it is the hom-category - for the oplax slice, it is the opposite of the hom-category - for the slice, it is the core of the hom-category In addition, we determine the functor arising from a morphism in the base and the global cleaving. In all of the different variations of the slice bicategory, this functor is equivalent to precomposition. Contents 1. Fiber of lax slice 2. Fiber functor of lax slice 3. Fiber of oplax slice 4. Fiber functor of oplax slice 5. Fiber of slice 6. Fiber functor of oplax slice ************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.LaxSlice. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory. Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.SliceCleaving. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory.FunctorFromCleaving. Local Open Scope cat. (** 1. Fiber of lax slice *) Section LaxSliceFiber. Context {B : bicat} (c a : B). Let fib : category := discrete_fiber_category (lax_slice_disp_bicat B a) (lax_slice_disp_2cells_isaprop B a) (lax_slice_disp_univalent_2_1 B a) (lax_slice_local_iso_cleaving a) c. Let homc : category := hom c a. Definition hom_to_lax_slice_fib_data : functor_data homc fib. Proof. use make_functor_data. - exact (λ f, f). - exact (λ f g α, α • linvunitor _). Defined. Definition hom_to_lax_slice_fib_is_functor : is_functor hom_to_lax_slice_fib_data. Proof. split. - intro f ; cbn. apply id2_left. - intros f g h α β ; cbn. rewrite !vassocl. apply maponpaths. etrans. { apply linvunitor_natural. } rewrite <- lwhisker_hcomp. apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocl. refine (!(id2_right _) @ _). apply maponpaths. rewrite lunitor_runitor_identity. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply idpath. Qed. Definition hom_to_lax_slice_fib : homc ⟶ fib. Proof. use make_functor. - exact hom_to_lax_slice_fib_data. - exact hom_to_lax_slice_fib_is_functor. Defined. Definition lax_slice_fib_to_hom_data : functor_data fib homc. Proof. use make_functor_data. - exact (λ f, f). - exact (λ f g α, α • lunitor _). Defined. Definition lax_slice_fib_to_hom_is_functor : is_functor lax_slice_fib_to_hom_data. Proof. split. - intros f ; cbn. apply linvunitor_lunitor. - intros f g h α β ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite <- vcomp_lunitor. rewrite !vassocl. apply maponpaths. apply lunitor_triangle. Qed. Definition lax_slice_fib_to_hom : fib ⟶ homc. Proof. use make_functor. - exact lax_slice_fib_to_hom_data. - exact lax_slice_fib_to_hom_is_functor. Defined. Definition equiv_lax_slice_fib_hom_unit : functor_identity fib ⟹ lax_slice_fib_to_hom ∙ hom_to_lax_slice_fib. Proof. use make_nat_trans. - exact (λ f, linvunitor f). - abstract (intros f g α ; cbn ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite lunitor_linvunitor ; rewrite id2_right ; rewrite !lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite <- lwhisker_hcomp ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite lwhisker_hcomp, rwhisker_hcomp ; apply triangle_r_inv). Defined. Definition equiv_lax_slice_fib_hom_counit : hom_to_lax_slice_fib ∙ lax_slice_fib_to_hom ⟹ functor_identity homc. Proof. use make_nat_trans. - exact (λ f, id₂ f). - abstract (intros f g α ; cbn ; rewrite id2_left, id2_right ; rewrite !vassocl ; rewrite linvunitor_lunitor ; apply id2_right). Defined. Definition equiv_lax_slice_fib_hom : equivalence_of_cats fib homc. Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact lax_slice_fib_to_hom. + exact hom_to_lax_slice_fib. + exact equiv_lax_slice_fib_hom_unit. + exact equiv_lax_slice_fib_hom_counit. - split. + intro f. apply is_z_iso_discrete_fiber. apply lax_slice_invertible_2cell_is_left_disp_adj_equiv. cbn. is_iso. + intro f ; cbn. apply is_inv2cell_to_is_z_iso. is_iso. Defined. Definition adj_equivalence_lax_slice_fib_to_hom : adj_equivalence_of_cats lax_slice_fib_to_hom := adjointification equiv_lax_slice_fib_hom. Definition adj_equiv_lax_slice_fib_hom : adj_equiv fib homc := _ ,, adj_equivalence_lax_slice_fib_to_hom. End LaxSliceFiber. (** 2. Fiber functor of lax slice *) Section LaxSliceSubFiber. Context {B : bicat} (a : B) {c₁ c₂ : B} (f : c₁ --> c₂). Let fib₁ : category := discrete_fiber_category (lax_slice_disp_bicat B a) (lax_slice_disp_2cells_isaprop B a) (lax_slice_disp_univalent_2_1 B a) (lax_slice_local_iso_cleaving a) c₁. Let fib₂ : category := discrete_fiber_category (lax_slice_disp_bicat B a) (lax_slice_disp_2cells_isaprop B a) (lax_slice_disp_univalent_2_1 B a) (lax_slice_local_iso_cleaving a) c₂. Definition functor_from_lax_slice_cleaving_nat_trans : functor_from_cleaving (lax_slice_disp_bicat B a) (lax_slice_disp_2cells_isaprop B a) (lax_slice_disp_univalent_2_1 B a) (lax_slice_global_cleaving a) (lax_slice_local_iso_cleaving a) f ⟹ lax_slice_fib_to_hom _ _ ∙ pre_comp a f ∙ hom_to_lax_slice_fib _ _. Proof. use make_nat_trans. - exact (λ g, linvunitor _). - abstract (intros g₁ g₂ α ; cbn in * ; rewrite lwhisker_id2 ; rewrite id2_left, id2_right ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; do 3 apply maponpaths_2 ; rewrite !vassocl ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite runitor_rwhisker ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite <- vcomp_whisker ; rewrite linvunitor_assoc ; rewrite !vassocl ; apply maponpaths ; rewrite <- lwhisker_lwhisker_rassociator ; rewrite !lwhisker_vcomp ; apply idpath). Defined. Definition functor_from_lax_slice_cleaving_nat_z_iso : nat_z_iso (functor_from_cleaving (lax_slice_disp_bicat B a) (lax_slice_disp_2cells_isaprop B a) (lax_slice_disp_univalent_2_1 B a) (lax_slice_global_cleaving a) (lax_slice_local_iso_cleaving a) f) (lax_slice_fib_to_hom _ _ ∙ pre_comp a f ∙ hom_to_lax_slice_fib _ _). Proof. use make_nat_z_iso. - exact functor_from_lax_slice_cleaving_nat_trans. - intro g. apply is_z_iso_discrete_fiber. apply lax_slice_invertible_2cell_is_left_disp_adj_equiv. cbn. is_iso. Defined. End LaxSliceSubFiber. (** 3. Fiber of oplax slice *) Section OplaxSliceFiber. Context {B : bicat} (c a : B). Let fib : category := discrete_fiber_category (oplax_slice_disp_bicat B a) (oplax_slice_disp_2cells_isaprop B a) (oplax_slice_disp_univalent_2_1 B a) (oplax_slice_local_iso_cleaving a) c. Let homc : category := (hom c a)^op. Definition hom_to_oplax_slice_fib_data : functor_data homc fib. Proof. use make_functor_data. - exact (λ f, f). - exact (λ f g α, lunitor _ • α). Defined. Definition hom_to_oplax_slice_fib_is_functor : is_functor hom_to_oplax_slice_fib_data. Proof. split. - intro f ; cbn. apply id2_right. - intros f g h α β ; cbn. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite vcomp_lunitor. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. Qed. Definition hom_to_oplax_slice_fib : homc ⟶ fib. Proof. use make_functor. - exact hom_to_oplax_slice_fib_data. - exact hom_to_oplax_slice_fib_is_functor. Defined. Definition oplax_slice_fib_to_hom_data : functor_data fib homc. Proof. use make_functor_data. - exact (λ f, f). - exact (λ f g α, linvunitor _ • α). Defined. Definition oplax_slice_fib_to_hom_is_functor : is_functor oplax_slice_fib_to_hom_data. Proof. split. - intros f ; cbn. apply linvunitor_lunitor. - intros f g h α β ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite vcomp_lunitor. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. Definition oplax_slice_fib_to_hom : fib ⟶ homc. Proof. use make_functor. - exact oplax_slice_fib_to_hom_data. - exact oplax_slice_fib_to_hom_is_functor. Defined. Definition equiv_oplax_slice_fib_hom_unit : functor_identity fib ⟹ oplax_slice_fib_to_hom ∙ hom_to_oplax_slice_fib. Proof. use make_nat_trans. - exact (λ f, lunitor f). - abstract (intros f g α ; cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite !vassocr ; rewrite !lwhisker_vcomp ; rewrite vcomp_lunitor ; rewrite !vassocr ; rewrite lunitor_linvunitor ; rewrite id2_left ; apply idpath). Defined. Definition equiv_oplax_slice_fib_hom_counit : hom_to_oplax_slice_fib ∙ oplax_slice_fib_to_hom ⟹ functor_identity homc. Proof. use make_nat_trans. - exact (λ f, id₂ f). - abstract (intros f g α ; cbn ; rewrite id2_left, id2_right ; rewrite !vassocr ; rewrite linvunitor_lunitor ; apply id2_left). Defined. Definition equiv_oplax_slice_fib_hom : equivalence_of_cats fib homc. Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact oplax_slice_fib_to_hom. + exact hom_to_oplax_slice_fib. + exact equiv_oplax_slice_fib_hom_unit. + exact equiv_oplax_slice_fib_hom_counit. - split. + intro f. apply is_z_iso_discrete_fiber. apply oplax_slice_invertible_2cell_is_left_disp_adj_equiv. cbn. is_iso. + intro f. apply opp_is_z_isomorphism. apply is_inv2cell_to_is_z_iso ; cbn. is_iso. Defined. Definition adj_equivalence_oplax_slice_fib_to_hom : adj_equivalence_of_cats oplax_slice_fib_to_hom := adjointification equiv_oplax_slice_fib_hom. Definition adj_equiv_oplax_slice_fib_hom : adj_equiv fib homc := _ ,, adj_equivalence_oplax_slice_fib_to_hom. End OplaxSliceFiber. (** 4. Fiber functor of oplax slice *) Section OplaxSliceSubFiber. Context {B : bicat} (a : B) {c₁ c₂ : B} (f : c₁ --> c₂). Let fib₁ : category := discrete_fiber_category (oplax_slice_disp_bicat B a) (oplax_slice_disp_2cells_isaprop B a) (oplax_slice_disp_univalent_2_1 B a) (oplax_slice_local_iso_cleaving a) c₁. Let fib₂ : category := discrete_fiber_category (oplax_slice_disp_bicat B a) (oplax_slice_disp_2cells_isaprop B a) (oplax_slice_disp_univalent_2_1 B a) (oplax_slice_local_iso_cleaving a) c₂. Definition functor_from_oplax_slice_cleaving_nat_trans : functor_from_cleaving (oplax_slice_disp_bicat B a) (oplax_slice_disp_2cells_isaprop B a) (oplax_slice_disp_univalent_2_1 B a) (oplax_slice_global_cleaving a) (oplax_slice_local_iso_cleaving a) f ⟹ oplax_slice_fib_to_hom _ _ ∙ functor_opp (pre_comp a f) ∙ hom_to_oplax_slice_fib _ _. Proof. use make_nat_trans. - exact (λ g, lunitor _). - abstract (intros g₁ g₂ α ; cbn in * ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite lwhisker_id2, id2_left, id2_right ; do 3 apply maponpaths ; rewrite vcomp_lunitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- lunitor_triangle ; rewrite !vassocr ; rewrite lwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite <-vcomp_whisker ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_hcomp, lwhisker_hcomp ; rewrite triangle_r_inv ; apply idpath). Defined. Definition functor_from_oplax_slice_cleaving_nat_z_iso : nat_z_iso (functor_from_cleaving (oplax_slice_disp_bicat B a) (oplax_slice_disp_2cells_isaprop B a) (oplax_slice_disp_univalent_2_1 B a) (oplax_slice_global_cleaving a) (oplax_slice_local_iso_cleaving a) f) (oplax_slice_fib_to_hom _ _ ∙ functor_opp (pre_comp a f) ∙ hom_to_oplax_slice_fib _ _). Proof. use make_nat_z_iso. - exact functor_from_oplax_slice_cleaving_nat_trans. - intro g. apply is_z_iso_discrete_fiber. apply oplax_slice_invertible_2cell_is_left_disp_adj_equiv. cbn. is_iso. Defined. End OplaxSliceSubFiber. (** 5. Fiber of slice *) Section SliceFiber. Context {B : bicat} (c a : B). Let fib : category := discrete_fiber_category (slice_disp_bicat a) (disp_2cells_isaprop_slice a) (disp_univalent_2_1_slice a) (slice_local_iso_cleaving a) c. Let homc : category := core (hom c a). Definition hom_to_slice_fib_data : functor_data homc fib. Proof. use make_functor_data. - exact (λ f, f). - exact (λ f g α, comp_of_invertible_2cell (z_iso_to_inv2cell α) (linvunitor_invertible_2cell _)). Defined. Definition hom_to_slice_fib_is_functor : is_functor hom_to_slice_fib_data. Proof. split. - intro f. use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. apply id2_left. - intros f g h α β. use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. rewrite !vassocl. apply maponpaths. etrans. { apply linvunitor_natural. } rewrite <- lwhisker_hcomp. apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocl. refine (!(id2_right _) @ _). apply maponpaths. rewrite lunitor_runitor_identity. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply idpath. Qed. Definition hom_to_slice_fib : homc ⟶ fib. Proof. use make_functor. - exact hom_to_slice_fib_data. - exact hom_to_slice_fib_is_functor. Defined. Definition slice_fib_to_hom_data : functor_data fib homc. Proof. use make_functor_data. - exact (λ f, f). - intros f g α. simple refine (_ ,, _). + exact (pr1 α • lunitor _). + use is_inv2cell_to_is_z_iso. is_iso. apply property_from_invertible_2cell. Defined. Definition slice_fib_to_hom_is_functor : is_functor slice_fib_to_hom_data. Proof. split. - intros f. use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. apply linvunitor_lunitor. - intros f g h α β. use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite <- vcomp_lunitor. rewrite !vassocl. apply maponpaths. apply lunitor_triangle. Qed. Definition slice_fib_to_hom : fib ⟶ homc. Proof. use make_functor. - exact slice_fib_to_hom_data. - exact slice_fib_to_hom_is_functor. Defined. Definition equiv_slice_fib_hom_unit : functor_identity fib ⟹ slice_fib_to_hom ∙ hom_to_slice_fib. Proof. use make_nat_trans. - exact (λ f, linvunitor_invertible_2cell f). - abstract (intros f g α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite lunitor_linvunitor ; rewrite id2_right ; rewrite !lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite <- lwhisker_hcomp ; apply maponpaths ; rewrite linvunitor_assoc ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite lwhisker_hcomp, rwhisker_hcomp ; apply triangle_r_inv). Defined. Definition equiv_slice_fib_hom_counit : hom_to_slice_fib ∙ slice_fib_to_hom ⟹ functor_identity homc. Proof. use make_nat_trans. - exact (λ f, identity_z_iso f). - abstract (intros f g α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ; rewrite id2_left, id2_right ; rewrite !vassocl ; rewrite linvunitor_lunitor ; apply id2_right). Defined. Definition equiv_slice_fib_hom : equivalence_of_cats fib homc. Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact slice_fib_to_hom. + exact hom_to_slice_fib. + exact equiv_slice_fib_hom_unit. + exact equiv_slice_fib_hom_counit. - split. + intro f. apply is_z_iso_discrete_fiber. apply slice_is_inv2cell_to_is_disp_adj_equiv. + intro f ; cbn. apply is_z_iso_core. Defined. Definition adj_equivalence_slice_fib_to_hom : adj_equivalence_of_cats slice_fib_to_hom := adjointification equiv_slice_fib_hom. Definition adj_equiv_slice_fib_hom : adj_equiv fib homc := _ ,, adj_equivalence_slice_fib_to_hom. End SliceFiber. (** 6. Fiber functor of oplax slice *) Section SliceSubFiber. Context {B : bicat} (a : B) {c₁ c₂ : B} (f : c₁ --> c₂). Let fib₁ : category := discrete_fiber_category (slice_disp_bicat a) (disp_2cells_isaprop_slice a) (disp_univalent_2_1_slice a) (slice_local_iso_cleaving a) c₁. Let fib₂ : category := discrete_fiber_category (slice_disp_bicat a) (disp_2cells_isaprop_slice a) (disp_univalent_2_1_slice a) (slice_local_iso_cleaving a) c₂. Definition functor_from_slice_cleaving_nat_trans : functor_from_cleaving (slice_disp_bicat a) (disp_2cells_isaprop_slice a) (disp_univalent_2_1_slice a) (slice_global_cleaving a) (slice_local_iso_cleaving a) f ⟹ slice_fib_to_hom _ _ ∙ core_functor (pre_comp a f) ∙ hom_to_slice_fib _ _. Proof. use make_nat_trans. - exact (λ g, linvunitor_invertible_2cell _). - abstract (intros g₁ g₂ α ; use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn in * ; rewrite lwhisker_id2 ; rewrite id2_left, id2_right ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; do 3 apply maponpaths_2 ; rewrite !vassocl ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite runitor_rwhisker ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite <- vcomp_whisker ; rewrite linvunitor_assoc ; rewrite !vassocl ; apply maponpaths ; rewrite <- lwhisker_lwhisker_rassociator ; rewrite !lwhisker_vcomp ; apply idpath). Defined. Definition functor_from_slice_cleaving_nat_z_iso : nat_z_iso (functor_from_cleaving (slice_disp_bicat a) (disp_2cells_isaprop_slice a) (disp_univalent_2_1_slice a) (slice_global_cleaving a) (slice_local_iso_cleaving a) f) (slice_fib_to_hom _ _ ∙ core_functor (pre_comp a f) ∙ hom_to_slice_fib _ _). Proof. use make_nat_z_iso. - exact functor_from_slice_cleaving_nat_trans. - intro g. apply is_z_iso_discrete_fiber. apply slice_is_inv2cell_to_is_disp_adj_equiv. Defined. End SliceSubFiber. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberBicategory/TrivialFiber.v000066400000000000000000000455311451125700300301410ustar00rootroot00000000000000(******************************************************************* Fibers of the trivial displayed bicategory In this file, we calculate the fibers of the trivial displayed bicategory 1. To the fiber 2. From the fiber 3. The unit 4. The counit 5. The modifications 6. The biequivalence *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial. Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.TrivialCleaving. Local Open Scope cat. Local Open Scope bicategory_scope. Section FiberOfTrivial. Context (B₁ B₂ : bicat) (x : B₁). (** 1. To the fiber *) Definition to_fiber_trivial_data : psfunctor_data B₂ (strict_fiber_bicat (trivial_displayed_bicat B₁ B₂) (trivial_local_isocleaving B₁ B₂) x). Proof. use make_psfunctor_data. - exact (λ z, z). - exact (λ _ _ f, f). - exact (λ _ _ _ _ α, α). - exact (λ _, id2 _). - exact (λ _ _ _ _ _, id2 _). Defined. Definition to_fiber_trivial_laws : psfunctor_laws to_fiber_trivial_data. Proof. repeat split ; intro ; intros ; cbn ; rewrite !transportf_const ; cbn. - apply idpath. - rewrite id2_rwhisker, !id2_left. apply idpath. - rewrite lwhisker_id2, !id2_left. apply idpath. - rewrite !lwhisker_id2, !id2_rwhisker, !id2_left, !id2_right. apply idpath. - rewrite !id2_left, !id2_right. apply idpath. - rewrite !id2_left, !id2_right. apply idpath. Qed. Definition to_fiber_invertible_cells : invertible_cells to_fiber_trivial_data. Proof. split ; intros. - apply is_invertible_2cell_id₂. - apply is_invertible_2cell_id₂. Defined. Definition to_fiber_trivial : psfunctor B₂ (strict_fiber_bicat (trivial_displayed_bicat B₁ B₂) (trivial_local_isocleaving B₁ B₂) x). Proof. use make_psfunctor. - exact to_fiber_trivial_data. - exact to_fiber_trivial_laws. - exact to_fiber_invertible_cells. Defined. (** 2. From the fiber *) Definition from_fiber_trivial_data : psfunctor_data (strict_fiber_bicat (trivial_displayed_bicat B₁ B₂) (trivial_local_isocleaving B₁ B₂) x) B₂. Proof. use make_psfunctor_data. - exact (λ z, z). - exact (λ _ _ f, f). - exact (λ _ _ _ _ α, α). - exact (λ _, id2 _). - exact (λ a b c f g, id2 _). Defined. Definition from_fiber_trivial_data_laws : psfunctor_laws from_fiber_trivial_data. Proof. refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _) ; intro ; intros ; cbn ; try (rewrite !transportf_const). - apply idpath. - apply idpath. - rewrite id2_rwhisker, !id2_left. apply idpath. - rewrite lwhisker_id2, !id2_left. apply idpath. - rewrite !lwhisker_id2, !id2_rwhisker, !id2_left, !id2_right. apply idpath. - rewrite !id2_left, !id2_right. apply idpath. - rewrite !id2_left, !id2_right. apply idpath. Qed. Definition from_fiber_trivial : psfunctor (strict_fiber_bicat (trivial_displayed_bicat B₁ B₂) (trivial_local_isocleaving B₁ B₂) x) B₂. Proof. use make_psfunctor. - exact from_fiber_trivial_data. - exact from_fiber_trivial_data_laws. - split ; cbn ; intros ; is_iso. Defined. (** 3. The unit *) Definition fiber_trivial_unit_data : pstrans_data (id_psfunctor _) (comp_psfunctor from_fiber_trivial to_fiber_trivial). Proof. use make_pstrans_data ; cbn. - exact (λ _, id₁ _). - exact (λ x y f, comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _)). Defined. Definition fiber_trivial_unit_is_pstrans : is_pstrans fiber_trivial_unit_data. Proof. refine (_ ,, _ ,, _). - cbn. intros y₁ y₂ f g α. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - cbn. intro y. rewrite !id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - cbn. intros y₁ y₂ y₃ f g. rewrite !id2_left. rewrite !lwhisker_id2, !id2_rwhisker. rewrite !id2_left, !id2_right. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. refine (!(id2_left _) @_). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition fiber_trivial_unit : pstrans (id_psfunctor _) (comp_psfunctor from_fiber_trivial to_fiber_trivial). Proof. use make_pstrans. - exact fiber_trivial_unit_data. - exact fiber_trivial_unit_is_pstrans. Defined. Definition fiber_trivial_unit_inv_data : pstrans_data (comp_psfunctor from_fiber_trivial to_fiber_trivial) (id_psfunctor _). Proof. use make_pstrans_data. - exact (λ x, id₁ _). - exact (λ x y f, comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _)). Defined. Definition fiber_trivial_unit_inv_is_pstrans : is_pstrans fiber_trivial_unit_inv_data. Proof. refine (_ ,, _ ,, _). - intros y₁ y₂ f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros y ; cbn. rewrite id2_left. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros y₁ y₂ y₃ f g ; cbn. rewrite id2_left. rewrite !lwhisker_id2, !id2_rwhisker. rewrite !id2_left, !id2_right. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. refine (!(id2_left _) @_). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition fiber_trivial_unit_inv : pstrans (comp_psfunctor from_fiber_trivial to_fiber_trivial) (id_psfunctor _). Proof. use make_pstrans. - exact fiber_trivial_unit_inv_data. - exact fiber_trivial_unit_inv_is_pstrans. Defined. (** 4. The counit *) Definition fiber_trivial_counit_data : pstrans_data (comp_psfunctor to_fiber_trivial from_fiber_trivial) (id_psfunctor _). Proof. use make_pstrans_data. - cbn. exact (λ _, id₁ _). - simple refine (λ x y f, make_invertible_2cell _). + cbn. exact (lunitor _ • rinvunitor _). + use strict_fiber_bicat_invertible_2cell. apply trivial_is_invertible_2cell_to_is_disp_invertible ; cbn. is_iso. Defined. Definition fiber_trivial_counit_is_pstrans : is_pstrans fiber_trivial_counit_data. Proof. refine (_ ,, _ ,, _). - intros y₁ y₂ f g α ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - cbn. intro y. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - cbn. intros y₁ y₂ y₃ f g. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !lwhisker_id2, !id2_rwhisker. rewrite !id2_left, !id2_right. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. refine (!(id2_left _) @_). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition fiber_trivial_counit : pstrans (comp_psfunctor to_fiber_trivial from_fiber_trivial) (id_psfunctor _). Proof. use make_pstrans. - exact fiber_trivial_counit_data. - exact fiber_trivial_counit_is_pstrans. Defined. Definition fiber_trivial_counit_inv_data : pstrans_data (id_psfunctor _) (comp_psfunctor to_fiber_trivial from_fiber_trivial). Proof. use make_pstrans_data. - cbn. exact (λ z, id₁ _). - simple refine (λ x y f, make_invertible_2cell _). + cbn. exact (lunitor _ • rinvunitor _). + use strict_fiber_bicat_invertible_2cell. apply trivial_is_invertible_2cell_to_is_disp_invertible ; cbn. is_iso. Defined. Definition fiber_trivial_counit_inv_is_pstrans : is_pstrans fiber_trivial_counit_inv_data. Proof. refine (_ ,, _ ,, _). - intros y₁ y₂ f g α ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. - intros y ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros y₁ y₂ y₃ f g ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !lwhisker_id2, !id2_rwhisker. rewrite !id2_left, !id2_right. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. refine (!(id2_left _) @_). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition fiber_trivial_counit_inv : pstrans (id_psfunctor _) (comp_psfunctor to_fiber_trivial from_fiber_trivial). Proof. use make_pstrans. - exact fiber_trivial_counit_inv_data. - exact fiber_trivial_counit_inv_is_pstrans. Defined. (** 5. The modifications *) Definition trivial_unit_inv_left_data : invertible_modification_data (id_pstrans _) (comp_pstrans fiber_trivial_unit_inv fiber_trivial_unit). Proof. intros y. use make_invertible_2cell ; cbn. - exact (rinvunitor (id₁ y)). - is_iso. Defined. Definition trivial_unit_inv_left_is_modification : is_modification trivial_unit_inv_left_data. Proof. intros y₁ y₂ f. cbn. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_left. rewrite <- vcomp_lunitor. rewrite <- lunitor_triangle. rewrite !vassocl. do 3 apply maponpaths. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition trivial_unit_inv_left : invertible_modification (id_pstrans _) (comp_pstrans fiber_trivial_unit_inv fiber_trivial_unit). Proof. use make_invertible_modification. - exact trivial_unit_inv_left_data. - exact trivial_unit_inv_left_is_modification. Defined. Definition trivial_unit_inv_right_data : invertible_modification_data (comp_pstrans fiber_trivial_unit fiber_trivial_unit_inv) (id_pstrans _). Proof. intros y. use make_invertible_2cell ; cbn. - exact (runitor _). - is_iso. Defined. Definition trivial_unit_inv_right_is_modification : is_modification trivial_unit_inv_right_data. Proof. intros y₁ y₂ f ; cbn. cbn. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite !vassocl. apply maponpaths. rewrite <- vcomp_lunitor. apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite runitor_lunitor_identity. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. apply id2_rwhisker. Qed. Definition trivial_unit_inv_right : invertible_modification (comp_pstrans fiber_trivial_unit fiber_trivial_unit_inv) (id_pstrans _). Proof. use make_invertible_modification. - exact trivial_unit_inv_right_data. - exact trivial_unit_inv_right_is_modification. Defined. Definition trivial_counit_inv_right_data : invertible_modification_data (id_pstrans _) (comp_pstrans fiber_trivial_counit fiber_trivial_counit_inv). Proof. intros y. use make_invertible_2cell ; cbn. - exact (rinvunitor _). - use strict_fiber_bicat_invertible_2cell. apply trivial_is_invertible_2cell_to_is_disp_invertible ; cbn. is_iso. Defined. Definition trivial_counit_inv_right_is_modification : is_modification trivial_counit_inv_right_data. Proof. intros y₁ y₂ f ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !id2_rwhisker, !lwhisker_id2. rewrite !id2_left, !id2_right. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_left. rewrite <- vcomp_lunitor. rewrite <- lunitor_triangle. rewrite !vassocl. do 3 apply maponpaths. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition trivial_counit_inv_right : invertible_modification (id_pstrans _) (comp_pstrans fiber_trivial_counit fiber_trivial_counit_inv). Proof. use make_invertible_modification. - exact trivial_counit_inv_right_data. - exact trivial_counit_inv_right_is_modification. Defined. Definition trivial_counit_inv_left_data : invertible_modification_data (comp_pstrans fiber_trivial_counit_inv fiber_trivial_counit) (id_pstrans _). Proof. intros y. use make_invertible_2cell ; cbn. - exact (runitor _). - use strict_fiber_bicat_invertible_2cell. apply trivial_is_invertible_2cell_to_is_disp_invertible ; cbn. is_iso. Defined. Definition trivial_counit_inv_left_is_modification : is_modification trivial_counit_inv_left_data. Proof. intros y₁ y₂ f ; cbn. rewrite !transportf_const ; cbn. rewrite !id2_left, !id2_right. rewrite !id2_rwhisker, !lwhisker_id2. rewrite !id2_left, !id2_right. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite !vassocl. apply maponpaths. rewrite <- vcomp_lunitor. apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite runitor_lunitor_identity. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. apply id2_rwhisker. Qed. Definition trivial_counit_inv_left : invertible_modification (comp_pstrans fiber_trivial_counit_inv fiber_trivial_counit) (id_pstrans _). Proof. use make_invertible_modification. - exact trivial_counit_inv_left_data. - exact trivial_counit_inv_left_is_modification. Defined. (** 6. The biequivalence *) Definition to_fiber_trivial_is_biequivalence : is_biequivalence to_fiber_trivial. Proof. use make_is_biequivalence. - exact from_fiber_trivial. - exact fiber_trivial_unit. - exact fiber_trivial_unit_inv. - exact fiber_trivial_counit. - exact fiber_trivial_counit_inv. - exact trivial_unit_inv_left. - exact trivial_unit_inv_right. - exact trivial_counit_inv_right. - exact trivial_counit_inv_left. Defined. End FiberOfTrivial. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/FiberCategory.v000066400000000000000000000346441451125700300252470ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Fiber category of a displayed bicategory whose displayed 2-cells form a proposition. In addition, we ask the displayed bicategory to be locally univalent and to be equipped with a local iso-cleaving. ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Local Open Scope cat. Local Open Scope mor_disp_scope. Section Discrete_Fiber_Precategory. Context {C : bicat}. Variable (D : disp_prebicat C) (h : local_iso_cleaving D) (c : C). Definition discrete_fiber_ob_mor : precategory_ob_mor. Proof. use tpair. - exact (D c). - cbn. exact (λ (d : D c) (d' : D c), d -->[identity c] d'). Defined. Definition idempunitor : invertible_2cell (identity c) (identity c · identity c). Proof. exists (linvunitor (identity c)). apply is_invertible_2cell_linvunitor. Defined. Definition discrete_fiber_precategory_data : precategory_data. Proof. exists discrete_fiber_ob_mor. split; cbn. - intro d. exact (id_disp d). - intros x y z ff gg. use (local_iso_cleaving_1cell h). + exact (identity c · identity c). + exact (ff ;; gg). + exact idempunitor. Defined. End Discrete_Fiber_Precategory. Section Discrete_Fiber. Context {C : bicat}. Variable (D : disp_bicat C) (HD : disp_2cells_isaprop D) (HD_2_1 : disp_univalent_2_1 D) (h : local_iso_cleaving D) (c : C). (** Laws of category *) (** Left unitality *) Definition discrete_fiber_lunitor {d d' : D c} (ff : d -->[ id₁ c] d') : (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c)) ==>[ id₂ (id₁ c)] ff. Proof. set (PP := disp_local_iso_cleaving_invertible_2cell h (id_disp d;; ff) (idempunitor c)). set (RR := PP •• disp_lunitor ff). assert (Heq : idempunitor c • lunitor (identity c) = id2 (identity c)). { abstract (apply linvunitor_lunitor). } exact (transportf (λ x, _ ==>[x] _) Heq RR). Defined. Definition discrete_fiber_linvunitor {d d' : D c} (ff : d -->[ id₁ c] d') : ff ==>[id₂ (id₁ c) ] (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c)). Proof. set (PP := disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (id_disp d;; ff) (idempunitor c))). assert (Heq : linvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)). { abstract (apply linvunitor_lunitor). } exact (transportf (λ x, _ ==>[x] _) Heq (disp_linvunitor ff •• PP)). Defined. Definition discrete_fiber_lunitor_disp_invertible {d d' : D c} (ff : d -->[ id₁ c] d') : disp_invertible_2cell (id2_invertible_2cell (id₁ c)) (local_iso_cleaving_1cell h (id_disp d;; ff) (idempunitor c)) ff. Proof. use tpair. - exact (discrete_fiber_lunitor ff). - use tpair. + exact (discrete_fiber_linvunitor ff). + abstract (split ; apply HD). Defined. (** Right unitality *) Definition discrete_fiber_runitor {d d' : D c} (ff : d -->[ id₁ c] d') : (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c)) ==>[ id₂ (id₁ c)] ff. Proof. assert (Heq : idempunitor c • runitor (identity c) = id2 (identity c)). { abstract (cbn ; rewrite <- lunitor_runitor_identity, linvunitor_lunitor ; reflexivity). } set (PP := disp_local_iso_cleaving_invertible_2cell h (ff;; id_disp d') (idempunitor c)). exact (transportf (λ x, _ ==>[x] _) Heq (PP •• disp_runitor ff)). Defined. Definition discrete_fiber_rinvunitor {d d' : D c} (ff : d -->[ id₁ c] d') : ff ==>[ id₂ (id₁ c) ] (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c)). Proof. set (PP := disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (ff;; id_disp d') (idempunitor c))). assert (Heq : rinvunitor (identity c) • (idempunitor c)^-1 = id2 (identity c)). { unfold idempunitor. cbn. abstract (rewrite lunitor_runitor_identity, rinvunitor_runitor ; reflexivity). } exact (transportf (λ x, _ ==>[x] _) Heq (disp_rinvunitor ff •• PP)). Defined. Definition discrete_fiber_runitor_disp_invertible {d d' : D c} (ff : d -->[ id₁ c] d') : disp_invertible_2cell (id2_invertible_2cell (id₁ c)) (local_iso_cleaving_1cell h (ff;;id_disp d') (idempunitor c)) ff. Proof. use tpair. - exact (discrete_fiber_runitor ff). - use tpair. + exact (discrete_fiber_rinvunitor ff). + abstract (split ; apply HD). Defined. (** Associativity *) Definition discrete_fiber_lassociator {d0 d1 d2 d3 : D c} (ff : d0 -->[ id₁ c] d1) (gg : d1 -->[ id₁ c] d2) (hh : d2 -->[ id₁ c] d3) : local_iso_cleaving_1cell h (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c) ==>[ id₂ (id₁ c)] local_iso_cleaving_1cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c). Proof. assert ((idempunitor c • (identity c ◃ idempunitor c)) • lassociator _ _ _ • ((lunitor _ ▹ identity c) • lunitor _) = id2 _) as Heq. { abstract (cbn ; rewrite !lwhisker_hcomp, !rwhisker_hcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite triangle_r_inv ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator, id2_left ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- hcomp_vcomp ; rewrite <- lunitor_V_id_is_left_unit_V_id ; rewrite id2_left, linvunitor_lunitor ; rewrite hcomp_identity, id2_left ; apply linvunitor_lunitor ). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). cbn. refine (_ •• disp_lassociator ff gg hh •• _). - refine (_ •• _). + exact (disp_local_iso_cleaving_invertible_2cell h (ff;;local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c)). + refine (disp_lwhisker _ _). exact (disp_local_iso_cleaving_invertible_2cell h (gg ;; hh) (idempunitor c)). - refine (_ •• _). + refine (disp_rwhisker _ _). exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (ff ;; gg) (idempunitor c))). + exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c))). Defined. Definition discrete_fiber_rassociator {d0 d1 d2 d3 : D c} (ff : d0 -->[ id₁ c] d1) (gg : d1 -->[ id₁ c] d2) (hh : d2 -->[ id₁ c] d3) : local_iso_cleaving_1cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c) ==>[ id₂ (id₁ c)] local_iso_cleaving_1cell h (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c). Proof. assert ((idempunitor c • (idempunitor c ▹ identity c)) • rassociator _ _ _ • ((identity c ◃ lunitor _) • lunitor _) = id2 _) as Heq. { abstract (cbn ; rewrite !lwhisker_hcomp, !rwhisker_hcomp ; rewrite lunitor_V_id_is_left_unit_V_id ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite <- triangle_l_inv ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite lassociator_rassociator, id2_left ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- hcomp_vcomp ; rewrite id2_left, linvunitor_lunitor ; rewrite hcomp_identity, id2_left ; rewrite <- lunitor_V_id_is_left_unit_V_id ; rewrite linvunitor_lunitor ; reflexivity ). } refine (transportf (λ z, _ ==>[ z ] _) Heq _). cbn. refine (_ •• disp_rassociator ff gg hh •• _). - refine (disp_local_iso_cleaving_invertible_2cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c) •• _). refine (disp_rwhisker _ _). exact (disp_local_iso_cleaving_invertible_2cell h (ff ;; gg) (idempunitor c)). - refine (_ •• _). + refine (disp_lwhisker _ _). exact (disp_inv_cell (disp_local_iso_cleaving_invertible_2cell h (gg ;; hh) (idempunitor c))). + exact (disp_inv_cell ((disp_local_iso_cleaving_invertible_2cell h (ff;;local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c)))). Defined. Definition discrete_fiber_lassociator_disp_invertible {d0 d1 d2 d3 : D c} (ff : d0 -->[ id₁ c] d1) (gg : d1 -->[ id₁ c] d2) (hh : d2 -->[ id₁ c] d3) : disp_invertible_2cell (id2_invertible_2cell (id₁ c)) (local_iso_cleaving_1cell h (ff;; local_iso_cleaving_1cell h (gg;; hh) (idempunitor c)) (idempunitor c)) (local_iso_cleaving_1cell h (local_iso_cleaving_1cell h (ff;; gg) (idempunitor c);; hh) (idempunitor c)). Proof. use tpair. - exact (discrete_fiber_lassociator ff gg hh). - use tpair. + exact (discrete_fiber_rassociator ff gg hh). + abstract (split ; apply HD). Defined. Definition discrete_fiber_is_precategory : is_precategory (discrete_fiber_precategory_data D h c). Proof. apply is_precategory_one_assoc_to_two. repeat split. - cbn ; intros a b f. exact (disp_isotoid_2_1 D HD_2_1 (idpath _) _ _ (discrete_fiber_lunitor_disp_invertible f)). - cbn ; intros a b f. exact (disp_isotoid_2_1 D HD_2_1 (idpath _) _ _ (discrete_fiber_runitor_disp_invertible f)). -intros d0 d1 d2 d3 ff gg hh. exact (disp_isotoid_2_1 D HD_2_1 (idpath _) _ _ (discrete_fiber_lassociator_disp_invertible ff gg hh)). Qed. Definition discrete_fiber_precategory : precategory. Proof. use make_precategory. - exact (discrete_fiber_precategory_data D h c). - exact discrete_fiber_is_precategory. Defined. Definition discrete_fiber_category : category. Proof. use make_category. - exact discrete_fiber_precategory. - intros x y f g. apply (isofhlevelweqb 1 (make_weq _ (HD_2_1 _ _ _ _ (idpath _) x y f g))). use isofhleveltotal2. + apply HD. + intros. apply isaprop_is_disp_invertible_2cell. Defined. Section IsoInDiscreteFiber. Context {x y : discrete_fiber_category} (f : x --> y) (Hf : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity c) f). Let finv : y --> x := pr11 Hf. Let η : disp_invertible_2cell (linvunitor_invertible_2cell _) (id_disp x) (f ;; pr11 Hf) := pr121 Hf ,, pr122 Hf. Let ε : disp_invertible_2cell (lunitor_invertible_2cell _) (pr11 Hf ;; f) (id_disp y) := pr221 Hf ,, pr222 Hf. Local Lemma is_z_iso_discrete_fiber_left_inv : finv · f = id₁ y. Proof. use (disp_isotoid_2_1 D HD_2_1 (idpath _)). refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (disp_local_iso_cleaving_invertible_2cell h (finv ;; f) (idempunitor c)) ε)). use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. apply linvunitor_lunitor. Qed. Local Lemma is_z_iso_discrete_fiber_right_inv : f · finv = id₁ x. Proof. use (disp_isotoid_2_1 D HD_2_1 (idpath _)). refine (transportf (λ z, disp_invertible_2cell z _ _) _ (vcomp_disp_invertible (disp_local_iso_cleaving_invertible_2cell h (f ;; finv) (idempunitor c)) (inverse_of_disp_invertible_2cell η))). use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn. apply linvunitor_lunitor. Qed. Definition is_z_iso_discrete_fiber : is_z_isomorphism f. Proof. use make_is_z_isomorphism. - exact finv. - split. + exact is_z_iso_discrete_fiber_right_inv. + exact is_z_iso_discrete_fiber_left_inv. Defined. End IsoInDiscreteFiber. End Discrete_Fiber. UniMath-20231010/UniMath/Bicategories/DisplayedBicats/UnivalenceTechniques.v000066400000000000000000001121021451125700300266260ustar00rootroot00000000000000(************************************************************************************ Techniques for proving displayed univalence This file collects techniques for proving displayed univalence of bicategories. One way to prove displayed univalence for a displayed bicategory, is by constructing a displayed pseudofunctor to another displayed bicategory and showing that the action on objects, 1-cells and 2-cells of that pseudofunctor are equivalences. Note that this displayed pseudofunctor does not need to live over an isomorphism: it can lie over any pseudofunctor. Contents 1. Univalence along displayed pseudofunctors that are isomorphisms 1.1. Notion of isomorphism for displayed pseudofunctors 1.2. Invertible 2-cells 1.3. Local univalence 1.4. Adjoint equivalences 1.5. Global univalence ************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Initial. Require Import UniMath.Bicategories.Core.Examples.Final. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispTransportLaws. Local Open Scope cat. (** 1. Univalence along displayed pseudofunctors *) (** 1.1. Notion of isomorphism for displayed pseudofunctors *) Definition disp_psfunctor_iso {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) : UU := (∏ (x : B₁), isweq (FF x)) × (∏ (x y : B₁) (f : x --> y) (xx : D₁ x) (yy : D₁ y), isweq (λ (ff : xx -->[ f ] yy), disp_psfunctor_mor _ _ _ FF ff)) × (∏ (x y : B₁) (f g : x --> y) (τ : f ==> g) (xx : D₁ x) (yy : D₁ y) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy), isweq (λ (ττ : ff ==>[ τ ] gg), disp_psfunctor_cell _ _ _ FF ττ)). Section PseudofunctorIsos. Context {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} {FF : disp_psfunctor D₁ D₂ F} (HF : disp_psfunctor_iso FF). Definition disp_psfunctor_iso_ob_weq (x : B₁) : D₁ x ≃ D₂ (F x) := make_weq (FF x) (pr1 HF x). Definition disp_psfunctor_iso_mor_weq {x y : B₁} (f : x --> y) (xx : D₁ x) (yy : D₁ y) : xx -->[ f ] yy ≃ FF x xx -->[ # F f ] FF y yy := make_weq _ (pr12 HF x y f xx yy). Definition disp_psfunctor_iso_cell_weq {x y : B₁} {f g : x --> y} (τ : f ==> g) {xx : D₁ x} {yy : D₁ y} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) : ff ==>[ τ ] gg ≃ disp_psfunctor_mor D₁ D₂ F FF ff ==>[ ## F τ] disp_psfunctor_mor D₁ D₂ F FF gg := make_weq _ (pr22 HF x y f g τ xx yy ff gg). Definition disp_psfunctor_iso_invmap_2 {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff gg : xx -->[ f ] yy} (ττ : disp_psfunctor_mor D₁ D₂ F FF ff ==>[ ## F (id2 f)] disp_psfunctor_mor D₁ D₂ F FF gg) : ff ==>[ id2 f ] gg := invmap (disp_psfunctor_iso_cell_weq (id2 f) ff gg) ττ. Proposition disp_psfunctor_iso_invmap_2_eq_1 {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff gg : xx -->[ f ] yy} (ττ : disp_psfunctor_mor D₁ D₂ F FF ff ==>[ ## F (id2 f)] disp_psfunctor_mor D₁ D₂ F FF gg) : disp_psfunctor_cell _ _ _ FF (disp_psfunctor_iso_invmap_2 ττ) = ττ. Proof. apply (homotweqinvweq (disp_psfunctor_iso_cell_weq (id2 f) ff gg)). Qed. Proposition disp_psfunctor_iso_invmap_2_eq_2 {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff gg : xx -->[ f ] yy} (ττ : ff ==>[ id2 f ] gg) : disp_psfunctor_iso_invmap_2 (disp_psfunctor_cell _ _ _ FF ττ) = ττ. Proof. apply (homotinvweqweq (disp_psfunctor_iso_cell_weq (id2 f) ff gg)). Qed. Proposition disp_psfunctor_iso_invmap_2_id2 {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[ f ] yy} (p : id₂ (# F f) = ## F (id₂ f)) : disp_psfunctor_iso_invmap_2 (transportf (λ z, _ ==>[ z ] _) p (disp_id2 (disp_psfunctor_mor D₁ D₂ F FF ff))) = disp_id2 _. Proof. refine (_ @ disp_psfunctor_iso_invmap_2_eq_2 (disp_id2 ff)). apply maponpaths. rewrite (disp_psfunctor_id2 _ _ _ FF (pr2 FF)). unfold transportb. apply maponpaths_2. apply cellset_property. Qed. Proposition disp_psfunctor_iso_invmap_2_vcomp {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff gg hh : xx -->[ f ] yy} (ττ : disp_psfunctor_mor D₁ D₂ F FF ff ==>[ ## F (id2 f)] disp_psfunctor_mor D₁ D₂ F FF gg) (θθ : disp_psfunctor_mor D₁ D₂ F FF gg ==>[ ## F (id2 f)] disp_psfunctor_mor D₁ D₂ F FF hh) : disp_psfunctor_iso_invmap_2 ττ •• disp_psfunctor_iso_invmap_2 θθ = transportb (λ z, _ ==>[ z ] _) (id2_left _) (disp_psfunctor_iso_invmap_2 (transportb (λ z, _ ==>[ z ] _) (maponpaths (λ h, ##F h) (!(id2_left _)) @ psfunctor_vcomp F _ _) (ττ •• θθ))). Proof. simple refine (!(transportfbinv (λ z, _ ==>[ z ] _) (!(id2_left _)) (disp_psfunctor_iso_invmap_2 ττ •• disp_psfunctor_iso_invmap_2 θθ)) @ _). unfold transportb. apply maponpaths. etrans. { exact (!(disp_psfunctor_iso_invmap_2_eq_2 _)). } apply maponpaths. etrans. { apply disp_psfunctor_cell_transportf. } etrans. { apply maponpaths. apply (disp_psfunctor_vcomp2 _ _ _ FF (pr2 FF)). } unfold transportb. rewrite transport_f_f. rewrite !disp_psfunctor_iso_invmap_2_eq_1. apply maponpaths_2. apply cellset_property. Qed. Section OverId. Context (HB₂ : is_univalent_2_1 B₂). Definition disp_psfunctor_iso_id_mor_weq {x : B₁} (xx yy : D₁ x) : xx -->[ id₁ x ] yy ≃ FF x xx -->[ id₁ (F x) ] FF x yy. Proof. refine (_ ∘ disp_psfunctor_iso_mor_weq (id₁ x) xx yy)%weq. use weq_iso. - refine (λ f, transportb (λ z, _ -->[ z ] _) _ f). exact (isotoid_2_1 HB₂ (psfunctor_id F x)). - refine (λ f, transportf (λ z, _ -->[ z ] _) _ f). exact (isotoid_2_1 HB₂ (psfunctor_id F x)). - abstract (intro f ; cbn ; rewrite transportfbinv ; apply idpath). - abstract (intro f ; cbn ; rewrite transportbfinv ; apply idpath). Defined. Definition disp_psfunctor_invmap_1 {x : B₁} {xx yy : D₁ x} (f : FF x xx -->[ id₁ (F x) ] FF x yy) : xx -->[ id₁ x ] yy. Proof. exact (invmap (disp_psfunctor_iso_id_mor_weq xx yy) f). Defined. Definition disp_psfunctor_invmap_1_id_eq (HD₂ : disp_univalent_2_1 D₂) {x : B₁} (xx : D₁ x) : disp_psfunctor_invmap_1 (id_disp (FF x xx)) = id_disp xx. Proof. unfold disp_psfunctor_invmap_1. use (invmaponpathsweq (disp_psfunctor_iso_id_mor_weq xx xx)). etrans. { apply homotweqinvweq. } refine (!_). cbn. etrans. { apply maponpaths. refine (!_). pose (disp_psfunctor_id _ _ _ FF xx) as p. rewrite <- (idtoiso_2_1_isotoid_2_1 HB₂ (psfunctor_id F x)) in p. exact (disp_isotoid_2_1 _ HD₂ _ _ _ p). } rewrite transportbfinv. apply idpath. Qed. Definition disp_psfunctor_invmap_1_id (HD₂ : disp_univalent_2_1 D₂) {x : B₁} (xx : D₁ x) : disp_invertible_2cell (id2_invertible_2cell _) (disp_psfunctor_invmap_1 (id_disp (FF x xx))) (id_disp xx). Proof. exact (disp_idtoiso_2_1 _ (idpath _) _ _ (disp_psfunctor_invmap_1_id_eq HD₂ xx)). Qed. Definition disp_psfunctor_invmap_1_inv2cell_eq (HD₂ : disp_univalent_2_1 D₂) {x : B₁} {xx yy : D₁ x} {f g : FF x xx -->[ id₁ (F x) ] FF x yy} (τ : disp_invertible_2cell (id2_invertible_2cell _) f g) : disp_psfunctor_invmap_1 f = disp_psfunctor_invmap_1 g. Proof. assert (f = g) as p. { exact (disp_isotoid_2_1 _ HD₂ (idpath _) f g τ). } rewrite p. apply idpath. Qed. Definition disp_psfunctor_invmap_1_inv2cell (HD₂ : disp_univalent_2_1 D₂) {x : B₁} {xx yy : D₁ x} {f g : FF x xx -->[ id₁ (F x) ] FF x yy} (τ : disp_invertible_2cell (id2_invertible_2cell _) f g) : disp_invertible_2cell (id2_invertible_2cell _) (disp_psfunctor_invmap_1 f) (disp_psfunctor_invmap_1 g). Proof. exact (disp_idtoiso_2_1 _ (idpath _) _ _ (disp_psfunctor_invmap_1_inv2cell_eq HD₂ τ)). Qed. Definition disp_psfunctor_invmap_1_is_inv2cell (HD₂ : disp_univalent_2_1 D₂) {x : B₁} {xx yy : D₁ x} {f g : FF x xx -->[ id₁ (F x) ] FF x yy} (τ : f ==>[ id2 _ ] g) (Hτ : is_disp_invertible_2cell (id2_invertible_2cell _) τ) : disp_invertible_2cell (id2_invertible_2cell _) (disp_psfunctor_invmap_1 f) (disp_psfunctor_invmap_1 g). Proof. exact (disp_psfunctor_invmap_1_inv2cell HD₂ (τ ,, Hτ)). Qed. Definition disp_psfunctor_invmap_1_comp_eq (HB₁ : is_univalent_2_1 B₁) (HD₂ : disp_univalent_2_1 D₂) {x : B₁} {xx yy zz : D₁ x} (f : FF x xx -->[ id₁ (F x) ] FF x yy) (g : FF x yy -->[ id₁ (F x) ] FF x zz) : transportf (λ z, _ -->[ z ] _) (isotoid_2_1 HB₁ (linvunitor_invertible_2cell (id₁ _))) (disp_psfunctor_invmap_1 (transportf (λ z, _ -->[ z ] _) (isotoid_2_1 HB₂ (lunitor_invertible_2cell (id₁ _))) (f ;; g)%mor_disp)) = (disp_psfunctor_invmap_1 f ;; disp_psfunctor_invmap_1 g)%mor_disp. Proof. use transportf_transpose_left. use (invmaponpathsweq (disp_psfunctor_iso_id_mor_weq xx zz)). etrans. { apply homotweqinvweq. } cbn -[disp_psfunctor_invmap_1]. rewrite disp_psfunctor_mor_transportb. rewrite transport_b_b. refine (!_). pose (disp_psfunctor_comp _ _ _ FF (disp_psfunctor_invmap_1 f) (disp_psfunctor_invmap_1 g)) as p. rewrite <- (idtoiso_2_1_isotoid_2_1 HB₂ (psfunctor_comp F (id₁ x) (id₁ x))) in p. pose (disp_isotoid_2_1 _ HD₂ _ _ _ p) as q. rewrite <- q ; clear q. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. etrans. { apply maponpaths. apply (homotweqinvweq (disp_psfunctor_iso_mor_weq _ yy zz)). } apply maponpaths_2. apply (homotweqinvweq (disp_psfunctor_iso_mor_weq _ xx yy)). } cbn. rewrite transportf_postwhisker_1cell. rewrite transportf_prewhisker_1cell. rewrite !transport_f_f. apply maponpaths_2. use (invmaponpathsweq (_ ,, HB₂ _ _ _ _)). cbn. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } rewrite !idtoiso_2_1_concat. cbn. rewrite <- idtoiso_2_1_lwhisker. rewrite <- idtoiso_2_1_rwhisker. rewrite idtoiso_2_1_inv. rewrite !idtoiso_2_1_concat. cbn -[psfunctor_id psfunctor_comp]. rewrite (idtoiso_2_1_psfunctor F). rewrite !idtoiso_2_1_isotoid_2_1. cbn -[psfunctor_id psfunctor_comp]. rewrite psfunctor_F_lunitor. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite vcomp_rinv. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- vcomp_whisker. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite id2_left. rewrite vcomp_lunitor. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. Qed. Definition disp_psfunctor_invmap_1_comp (HB₁ : is_univalent_2_1 B₁) (HD₂ : disp_univalent_2_1 D₂) {x : B₁} {xx yy zz : D₁ x} (f : FF x xx -->[ id₁ (F x) ] FF x yy) (g : FF x yy -->[ id₁ (F x) ] FF x zz) : disp_invertible_2cell (id2_invertible_2cell _) (transportf (λ z, _ -->[ z ] _) (isotoid_2_1 HB₁ (linvunitor_invertible_2cell (id₁ _))) (disp_psfunctor_invmap_1 (transportf (λ z, _ -->[ z ] _) (isotoid_2_1 HB₂ (lunitor_invertible_2cell (id₁ _))) (f ;; g)%mor_disp))) (disp_psfunctor_invmap_1 f ;; disp_psfunctor_invmap_1 g). Proof. exact (disp_idtoiso_2_1 _ (idpath _) _ _ (disp_psfunctor_invmap_1_comp_eq HB₁ HD₂ f g)). Qed. End OverId. End PseudofunctorIsos. Section UnivalenceIso. Context {B₁ B₂ : bicat} {F : psfunctor B₁ B₂} {D₁ : disp_bicat B₁} {D₂ : disp_bicat B₂} (FF : disp_psfunctor D₁ D₂ F) (HF : disp_psfunctor_iso FF). (** 1.2. Invertible 2-cells *) Section DispInvertibles. Context {x y : B₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} (ff gg : xx -->[ f ] yy). Definition disp_invertible_2cell_weq_along_iso_left (τ : disp_invertible_2cell (id2_invertible_2cell (# F f)) (disp_psfunctor_mor _ _ _ FF ff) (disp_psfunctor_mor _ _ _ FF gg)) : disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. simple refine (_ ,, _ ,, _ ,, _). - refine (disp_psfunctor_iso_invmap_2 HF (transportb (λ z, _ ==>[ z ] _) _ (pr1 τ))). abstract (rewrite psfunctor_id2 ; apply idpath). - refine (disp_psfunctor_iso_invmap_2 HF (transportb (λ z, _ ==>[ z ] _) _ (pr12 τ))). abstract (cbn ; rewrite psfunctor_id2 ; apply idpath). - abstract (refine (disp_psfunctor_iso_invmap_2_vcomp _ _ _ @ _) ; unfold transportb ; rewrite disp_mor_transportf_prewhisker ; rewrite disp_mor_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ do 3 apply maponpaths ; apply (pr2 τ) | ] ; unfold transportb ; rewrite transport_f_f ; rewrite disp_psfunctor_iso_invmap_2_id2 ; apply maponpaths_2 ; apply cellset_property). - abstract (refine (disp_psfunctor_iso_invmap_2_vcomp _ _ _ @ _) ; unfold transportb ; rewrite disp_mor_transportf_prewhisker ; rewrite disp_mor_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ do 3 apply maponpaths ; apply (pr2 τ) | ] ; unfold transportb ; rewrite transport_f_f ; rewrite disp_psfunctor_iso_invmap_2_id2 ; apply maponpaths_2 ; apply cellset_property). Defined. Definition disp_invertible_2cell_weq_along_iso_right (τ : disp_invertible_2cell (id2_invertible_2cell f) ff gg) : disp_invertible_2cell (id2_invertible_2cell (# F f)) (disp_psfunctor_mor _ _ _ FF ff) (disp_psfunctor_mor _ _ _ FF gg). Proof. simple refine (_ ,, _ ,, _ ,, _). - refine (transportb (λ z, _ ==>[ z ] _) _ (disp_psfunctor_cell _ _ _ FF (pr1 τ))). abstract (cbn ; rewrite psfunctor_id2 ; apply idpath). - refine (transportb (λ z, _ ==>[ z ] _) _ (disp_psfunctor_cell _ _ _ FF (pr12 τ))). abstract (cbn ; rewrite psfunctor_id2 ; apply idpath). - abstract (cbn ; unfold transportb ; rewrite disp_mor_transportf_prewhisker ; rewrite disp_mor_transportf_postwhisker ; rewrite transport_f_f ; etrans ; [ apply maponpaths ; refine (!_) ; apply (disp_psfunctor_vcomp2_alt _ _ _ FF (pr2 FF)) | ] ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; apply (pr2 τ) | ] ; etrans ; [ apply maponpaths ; apply disp_psfunctor_cell_transportb | ] ; unfold transportb ; rewrite transport_f_f ; rewrite (disp_psfunctor_id2 _ _ _ FF (pr2 FF)) ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply cellset_property). - abstract (cbn ; unfold transportb ; rewrite disp_mor_transportf_prewhisker ; rewrite disp_mor_transportf_postwhisker ; rewrite transport_f_f ; etrans ; [ apply maponpaths ; refine (!_) ; apply (disp_psfunctor_vcomp2_alt _ _ _ FF (pr2 FF)) | ] ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; apply (pr2 τ) | ] ; etrans ; [ apply maponpaths ; apply disp_psfunctor_cell_transportb | ] ; unfold transportb ; rewrite transport_f_f ; rewrite (disp_psfunctor_id2 _ _ _ FF (pr2 FF)) ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply cellset_property). Defined. Definition disp_invertible_2cell_along_iso_weq : disp_invertible_2cell (id2_invertible_2cell (# F f)) (disp_psfunctor_mor _ _ _ FF ff) (disp_psfunctor_mor _ _ _ FF gg) ≃ disp_invertible_2cell (id2_invertible_2cell f) ff gg. Proof. use weq_iso. - exact disp_invertible_2cell_weq_along_iso_left. - exact disp_invertible_2cell_weq_along_iso_right. - abstract (intros τ ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; cbn ; rewrite disp_psfunctor_iso_invmap_2_eq_1 ; rewrite transport_b_b ; unfold transportb ; refine (_ @ idpath_transportf (λ z, _ ==>[ z ] _) _) ; apply maponpaths_2 ; apply cellset_property). - abstract (intros τ ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; cbn ; rewrite transport_b_b ; refine (_ @ disp_psfunctor_iso_invmap_2_eq_2 HF τ) ; apply maponpaths ; unfold transportb ; refine (_ @ idpath_transportf (λ z, _ ==>[ z ] _) _) ; apply maponpaths_2 ; apply cellset_property). Defined. End DispInvertibles. (** 1.3. Local univalence *) Context (HD₂ : disp_univalent_2_1 D₂). Definition disp_univalent_2_1_along_iso : disp_univalent_2_1 D₁. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros x y f xx yy ff gg. use weqhomot. - exact (disp_invertible_2cell_along_iso_weq ff gg ∘ make_weq _ (HD₂ _ _ _ _ (idpath (#F f)) (FF x xx) (FF y yy) _ _) ∘ make_weq _ (isweqonpathsincl _ (isinclweq _ _ _ (pr2 (disp_psfunctor_iso_mor_weq HF f xx yy))) ff gg))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ; cbn ; refine (_ @ disp_psfunctor_iso_invmap_2_eq_2 HF _) ; apply maponpaths ; rewrite (disp_psfunctor_id2 _ _ _ FF (pr2 FF)) ; apply maponpaths_2 ; apply cellset_property). Defined. (** 1.4. Adjoint equivalences *) Context (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂). Section DispAdjEquivs. Context {x : B₁} (xx yy : D₁ x). Definition disp_adjequiv_along_iso_weq_left_equiv (ff : disp_adjoint_equivalence (internal_adjoint_equivalence_identity (F x)) (FF x xx) (FF x yy)) : disp_left_equivalence (internal_adjoint_equivalence_identity x) (disp_psfunctor_invmap_1 HF HB₂ (pr1 ff)). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (disp_psfunctor_invmap_1 HF HB₂ (pr112 ff)). - simple refine (transportf (λ z, _ ==>[ z ] _) _ (inverse_of_disp_invertible_2cell (disp_psfunctor_invmap_1_id HF HB₂ HD₂ xx) •• disp_psfunctor_invmap_1_is_inv2cell HF HB₂ HD₂ (transportf (λ z, _ ==>[ z ] _) _ (pr1 (pr212 ff) •• transportf_disp_2cell (pr1 ff ;; pr112 ff)%mor_disp _)) _ •• transportf_disp_2cell _ _ •• disp_psfunctor_invmap_1_comp HF HB₂ HB₁ HD₂ _ _)). + abstract (cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; rewrite !id2_left, !id2_right ; apply idpath). + abstract (cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; apply linvunitor_lunitor). + use transportf_is_disp_invertible_2cell. * cbn. is_iso. apply property_from_invertible_2cell. * pose (pr1 (pr212 ff) ,, pr1 (pr222 ff) : disp_invertible_2cell (left_equivalence_unit_iso (internal_adjoint_equivalence_identity _)) (id_disp _) (pr1 ff ;; pr112 ff)) as p. exact (pr2 (vcomp_disp_invertible p (transportf_disp_2cell _ _))). - simpl. simple refine (transportf (λ z, _ ==>[ z ] _) _ (inverse_of_disp_invertible_2cell (disp_psfunctor_invmap_1_comp HF HB₂ HB₁ HD₂ _ _) •• inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _) •• disp_psfunctor_invmap_1_is_inv2cell HF HB₂ HD₂ (transportf (λ z, _ ==>[ z ] _) _ (inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _) •• pr2 (pr212 ff))) _ •• disp_psfunctor_invmap_1_id HF HB₂ HD₂ yy)). + abstract (cbn ; rewrite id2_left, !id2_right ; rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; apply idpath). + abstract (cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; apply linvunitor_lunitor). + use transportf_is_disp_invertible_2cell. * cbn. is_iso. * pose (pr2 (pr212 ff) ,, pr2 (pr222 ff) : disp_invertible_2cell (left_equivalence_counit_iso (internal_adjoint_equivalence_identity _)) (pr112 ff ;; pr1 ff) (id_disp _)) as p. exact (pr2 (vcomp_disp_invertible (inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _)) p)). - simpl. use transportf_is_disp_invertible_2cell. + is_iso. apply property_from_invertible_2cell. + exact (pr2 (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (inverse_of_disp_invertible_2cell (disp_psfunctor_invmap_1_id HF HB₂ HD₂ xx)) (disp_psfunctor_invmap_1_is_inv2cell _ _ _ _ _)) (transportf_disp_2cell _ _)) (disp_psfunctor_invmap_1_comp HF HB₂ HB₁ HD₂ _ _))). - simpl. use transportf_is_disp_invertible_2cell. + is_iso. + exact (pr2 (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (inverse_of_disp_invertible_2cell (disp_psfunctor_invmap_1_comp HF HB₂ HB₁ HD₂ _ _)) (inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _))) (disp_psfunctor_invmap_1_is_inv2cell _ _ _ _ _)) (disp_psfunctor_invmap_1_id HF HB₂ HD₂ yy))). Qed. Definition disp_adjequiv_along_iso_weq_left (ff : disp_adjoint_equivalence (internal_adjoint_equivalence_identity (F x)) (FF x xx) (FF x yy)) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy. Proof. simple refine (_ ,, _). - exact (disp_psfunctor_invmap_1 HF HB₂ (pr1 ff)). - use (disp_left_equivalence_to_left_adjoint_equivalence_over_id HB₁). exact (disp_adjequiv_along_iso_weq_left_equiv ff). Defined. Definition disp_adjequiv_along_iso_weq_right_equiv (ff : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy) : disp_left_equivalence (internal_adjoint_equivalence_identity (F x)) (disp_psfunctor_iso_id_mor_weq HF HB₂ xx yy (pr1 ff)). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (disp_psfunctor_iso_id_mor_weq HF HB₂ _ _ (pr112 ff)). - refine (transportf (λ z, _ ==>[ z ] _) _ (disp_psfunctor_id _ _ _ FF xx •• disp_psfunctor_cell _ _ _ FF (pr1 (pr212 ff)) •• pr12 (disp_psfunctor_comp _ _ _ FF (pr1 ff) (pr112 ff)) •• (_ ◃◃ transportf_disp_2cell _ _) •• (transportf_disp_2cell _ _ ▹▹ _))). abstract (cbn -[psfunctor_id psfunctor_comp] ; rewrite idtoiso_2_1_inv ; rewrite !idtoiso_2_1_isotoid_2_1 ; rewrite psfunctor_linvunitor ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) ; rewrite vcomp_rinv ; rewrite id2_left ; rewrite <- vcomp_whisker ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rwhisker_vcomp ; cbn -[psfunctor_id psfunctor_comp] ; rewrite vcomp_rinv ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocr ; rewrite linvunitor_natural ; rewrite <- lwhisker_hcomp ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_rinv ; rewrite lwhisker_id2 ; apply id2_right). - cbn. refine (transportf (λ z, _ ==>[ z ] _) _ ((_ ◃◃ pr12 (transportf_disp_2cell _ _)) •• (pr12 (transportf_disp_2cell _ _) ▹▹ _) •• disp_psfunctor_comp _ _ _ FF (pr112 ff) (pr1 ff) •• disp_psfunctor_cell _ _ _ FF (pr2 (pr212 ff)) •• pr12 (disp_psfunctor_id _ _ _ FF yy))). abstract (cbn -[psfunctor_id psfunctor_comp] ; rewrite idtoiso_2_1_inv ; rewrite !idtoiso_2_1_isotoid_2_1 ; rewrite psfunctor_F_lunitor ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite vcomp_rinv ; rewrite id2_left ; cbn -[psfunctor_id psfunctor_comp] ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rwhisker_vcomp ; rewrite vcomp_rinv ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocr ; rewrite vcomp_lunitor ; rewrite !vassocl ; rewrite vcomp_rinv ; apply id2_right). - cbn -[psfunctor_id psfunctor_comp]. use transportf_is_disp_invertible_2cell. + is_iso. * apply property_from_invertible_2cell. * exact (psfunctor_is_iso F (linvunitor_invertible_2cell _)). * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. + pose (pr1 (pr212 ff) ,, pr1 (pr222 ff) : disp_invertible_2cell (left_equivalence_unit_iso (internal_adjoint_equivalence_identity x)) (id_disp xx) (pr1 ff ;; pr112 ff)) as p. exact (pr2 (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (disp_psfunctor_id _ _ _ FF xx) (disp_psfunctor_invertible_2cell FF p)) (inverse_of_disp_invertible_2cell (disp_psfunctor_comp _ _ _ FF (pr1 ff) (pr112 ff)))) (disp_invertible_2cell_lwhisker _ (transportf_disp_2cell _ _))) (disp_invertible_2cell_rwhisker _ (transportf_disp_2cell _ _)))). - cbn -[psfunctor_id psfunctor_comp]. use transportf_is_disp_invertible_2cell. + is_iso. * apply property_from_invertible_2cell. * exact (psfunctor_is_iso F (lunitor_invertible_2cell _)). + cbn. pose (pr2 (pr212 ff) ,, pr2 (pr222 ff) : disp_invertible_2cell (left_equivalence_counit_iso (internal_adjoint_equivalence_identity x)) (pr112 ff ;; pr1 ff) (id_disp yy)) as p. exact (pr2 (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (vcomp_disp_invertible (disp_invertible_2cell_lwhisker _ (inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _))) (disp_invertible_2cell_rwhisker _ (inverse_of_disp_invertible_2cell (transportf_disp_2cell _ _)))) (disp_psfunctor_comp _ _ _ FF _ _)) (disp_psfunctor_invertible_2cell FF p)) (inverse_of_disp_invertible_2cell (disp_psfunctor_id D₁ D₂ F FF yy)))). Qed. Definition disp_adjequiv_along_iso_weq_right (ff : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity (F x)) (FF x xx) (FF x yy). Proof. simple refine (_ ,, _). - exact (disp_psfunctor_iso_id_mor_weq HF HB₂ _ _ (pr1 ff)). - use (disp_left_equivalence_to_left_adjoint_equivalence_over_id HB₂). exact (disp_adjequiv_along_iso_weq_right_equiv ff). Defined. Definition disp_adjequiv_along_iso_weq : disp_adjoint_equivalence (internal_adjoint_equivalence_identity (F x)) (FF x xx) (FF x yy) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) xx yy. Proof. use weq_iso. - exact disp_adjequiv_along_iso_weq_left. - exact disp_adjequiv_along_iso_weq_right. - abstract (intros f ; use subtypePath ; [ intro ; exact (isaprop_disp_left_adjoint_equivalence _ _ HB₂ HD₂) | ] ; cbn -[disp_psfunctor_iso_id_mor_weq disp_psfunctor_invmap_1] ; apply homotweqinvweq). - abstract (intros f ; use subtypePath ; [ intro ; exact (isaprop_disp_left_adjoint_equivalence _ _ HB₁ disp_univalent_2_1_along_iso) | ] ; cbn -[disp_psfunctor_iso_id_mor_weq disp_psfunctor_invmap_1] ; apply homotinvweqweq). Defined. End DispAdjEquivs. (** 1.5. Global univalence *) Definition disp_univalent_2_0_along_iso (HD₂' : disp_univalent_2_0 D₂) : disp_univalent_2_0 D₁. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros x xx yy. use weqhomot. - exact (disp_adjequiv_along_iso_weq xx yy ∘ make_weq _ (HD₂' _ _ (idpath _) _ _) ∘ make_weq _ (isweqonpathsincl _ (isinclweq _ _ _ (pr2 (disp_psfunctor_iso_ob_weq HF x))) xx yy))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; exact (isaprop_disp_left_adjoint_equivalence _ _ HB₁ disp_univalent_2_1_along_iso) | ] ; cbn -[disp_psfunctor_iso_id_mor_weq disp_psfunctor_invmap_1] ; exact (disp_psfunctor_invmap_1_id_eq HF HB₂ HD₂ xx)). Defined. Definition disp_univalent_2_along_iso (HD₂' : disp_univalent_2_0 D₂) : disp_univalent_2 D₁. Proof. split. - exact (disp_univalent_2_0_along_iso HD₂'). - exact disp_univalent_2_1_along_iso. Defined. End UnivalenceIso. UniMath-20231010/UniMath/Bicategories/DoubleCategories/000077500000000000000000000000001451125700300224745ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DoubleCategories/BicatOfDoubleCats.v000066400000000000000000002024621451125700300261460ustar00rootroot00000000000000(********************************************************************************** The Bicategory of Double Categories In this file, we define the bicategory of univalent double categories, and we prove that this bicategory is univalent. To do so, we make heavy use of the machinery of displayed bicategories. The idea behind this construction is to split up the notion of double category into several layers. More specifically, a univalent double category is a univalent category with another collection of morphisms and a collection of squares. As such, the starting point of this construction is the univalent bicategory of univalent categories. First, we add the collection of morphisms and squares to the structure, which is done by a 2-sided displayed category. This construction is defined in the file `DispBicatOfTwoSidedDispCat.v` where it is also proven that this gives rise to a univalent bicategory. Next, there are two pieces of data to add: identity morphisms and horizontal composition. So, we define two displayed bicategories on top of the bicategory of categories with a 2-sided displayed category - The displayed objects of the first one are horizontal identities, the displayed morphisms are squares that witness the lax preservation of identities, and the displayed 2-cells are coherences (i.e., the coherence for horizontal identities for double transformations). - The displayed objects of the first one are functions that take horizontal compositions, the displayed morphisms are squares that witness the lax preservation of composition, and the displayed 2-cells are coherences (i.e., the coherence for horizontal composition for double transformations). We take the product of these two displayed bicategories, and we continue with the resulting total bicategory. While the 2-cells in this bicategory are double transformations, we need to add more structure in order to get double categories as objects and double functors as morphisms. As such, we define three displayed bicategories on top of that total bicategory. - The displayed objects of the first one are left unitors, and the displayed morphisms are coherences (i.e., the coherence equation for left unitors by double functors). - The displayed objects of the first one are right unitors, and the displayed morphisms are coherences (i.e., the coherence equation for right unitors by double functors). - The displayed objects of the first one are associator, and the displayed morphisms are coherences (i.e., the coherence equation for associator by double functors). Again we take the product of these three displayed bicategories, and we look at the resulting total bicategory. The 1-cells are double functors and the 2-cells are double transformations. However, the objects are not yet double categories: the triangle and pentagon coherence are missing. We finish the construction by taking a full subbicategory where the condition that we require is precisely the triangle and the pentagon equation. As a consequence, the objects of the resulting bicategory are actually double categories. In every step, we also prove the displayed univalence of the involved displayed bicategories. This allows us to prove in the end that the bicategory of double categories is a univalent bicategory. Contents 1. Two-sided displayed categories with identities 2. Two-sided displayed categories with horizontal composition 3. Two-sided displayed categories with identities and horizontal composition 4. Two-sided displayed categories with left unitors 5. Two-sided displayed categories with right unitors 6. Two-sided displayed categories with associators 7. Two-sided displayed categories with unitors and associators 8. Displayed bicategory of double categories **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedNatTrans. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfTwoSidedDispCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleTransformation. Local Open Scope cat. (** 1. Two-sided displayed categories with identities *) Definition disp_cat_ob_mor_twosided_disp_cat_hor_id : disp_cat_ob_mor bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact (λ CD, hor_id (pr12 CD)). - exact (λ CD₁ CD₂ I₁ I₂ FFF, double_functor_hor_id (pr2 FFF) I₁ I₂). Defined. Definition disp_cat_id_comp_twosided_disp_cat_hor_id : disp_cat_id_comp bicat_twosided_disp_cat disp_cat_ob_mor_twosided_disp_cat_hor_id. Proof. split. - exact (λ C I, identity_hor_id I). - exact (λ C₁ C₂ C₃ FFF GGG I₁ I₂ I₃ FI GI, comp_hor_id FI GI). Defined. Definition disp_cat_data_twosided_disp_cat_hor_id : disp_cat_data bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_twosided_disp_cat_hor_id. - exact disp_cat_id_comp_twosided_disp_cat_hor_id. Defined. Definition disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_id : disp_prebicat_1_id_comp_cells bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_cat_data_twosided_disp_cat_hor_id. - exact (λ CD₁ CD₂ FFF GGG τττ I₁ I₂ FI GI, double_nat_trans_hor_id (pr2 τττ) FI GI). Defined. Definition disp_prebicat_1_ops_twosided_disp_cat_hor_id : disp_prebicat_ops disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_id. Proof. repeat split. - intros CD₁ CD₂ F I₁ I₂ IF. exact (id_twosided_disp_nat_trans_hor_id IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (lunitor_twosided_disp_nat_trans_hor_id IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (runitor_twosided_disp_nat_trans_hor_id IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (linvunitor_twosided_disp_nat_trans_hor_id IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (rinvunitor_twosided_disp_nat_trans_hor_id IF). - intros CD₁ CD₂ CD₃ CD₄ F G H I₁ I₂ I₃ I₄ IF IG IH. exact (rassociator_twosided_disp_nat_trans_hor_id IF IG IH). - intros CD₁ CD₂ CD₃ CD₄ F G H I₁ I₂ I₃ I₄ IF IG IH. exact (lassociator_twosided_disp_nat_trans_hor_id IF IG IH). - intros CD₁ CD₂ F G H τ θ I₁ I₂ IF IG IH Iτ Iθ ; cbn. exact (comp_twosided_disp_nat_trans_hor_id Iτ Iθ). - intros CD₁ CD₂ CD₃ F G₁ G₂ θ I₁ I₂ I₃ IF IG₁ IG₂ Iθ. exact (pre_whisker_twosided_disp_nat_trans_hor_id IF Iθ). - intros CD₁ CD₂ CD₃ F G₁ G₂ τ I₁ I₂ I₃ IF₁ IF₂ IG Iτ. exact (post_whisker_twosided_disp_nat_trans_hor_id IG Iτ). Qed. Definition disp_prebicat_data_twosided_disp_cat_hor_id : disp_prebicat_data bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_id. - exact disp_prebicat_1_ops_twosided_disp_cat_hor_id. Defined. Proposition disp_prebicat_laws_twosided_disp_cat_hor_id : disp_prebicat_laws disp_prebicat_data_twosided_disp_cat_hor_id. Proof. repeat split ; intro ; intros ; apply isaprop_double_nat_trans_hor_id. Qed. Definition disp_prebicat_twosided_disp_cat_hor_id : disp_prebicat bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_twosided_disp_cat_hor_id. - exact disp_prebicat_laws_twosided_disp_cat_hor_id. Defined. Definition disp_bicat_twosided_disp_cat_hor_id : disp_bicat bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_twosided_disp_cat_hor_id. - intro ; intros. apply isasetaprop. apply isaprop_double_nat_trans_hor_id. Defined. Definition isaprop_disp_2cell_hor_id {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} {FI GI : I₁ -->[ F] I₂} (τ τ' : FI ==>[ id2 _ ] GI) : τ = τ'. Proof. apply isaprop_double_nat_trans_hor_id. Qed. Definition is_disp_invertible_2cell_hor_id_over_id {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} {FI GI : I₁ -->[ F] I₂} (τ : FI ==>[ id2 _ ] GI) : is_disp_invertible_2cell (id2_invertible_2cell F) τ. Proof. simple refine (_ ,, _ ,, _). - intros x ; cbn. pose (p := τ x) ; cbn in p. rewrite id_two_disp_right. rewrite id_two_disp_right in p. rewrite double_id_mor_id. rewrite double_id_mor_id in p. rewrite id_two_disp_left. rewrite id_two_disp_left in p. rewrite transport_b_b_disp_mor2. rewrite transport_b_b_disp_mor2 in p. refine (_ @ !p @ _) ; use transportf_disp_mor2_eq ; apply idpath. - apply isaprop_double_nat_trans_hor_id. - apply isaprop_double_nat_trans_hor_id. Qed. Definition is_disp_invertible_2cell_hor_id {CD₁ CD₂ : bicat_twosided_disp_cat} {F G : CD₁ --> CD₂} {τ : invertible_2cell F G} {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} {FI : I₁ -->[ F ] I₂} {GI : I₁ -->[ G ] I₂} (ττ : FI ==>[ τ ] GI) : is_disp_invertible_2cell τ ττ. Proof. revert CD₁ CD₂ F G τ I₁ I₂ FI GI ττ. use J_2_1. - apply is_univalent_2_1_bicat_twosided_disp_cat. - cbn. intro ; intros. apply is_disp_invertible_2cell_hor_id_over_id. Qed. Section HorIdDispInv2cell. Context {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} (FI GI : I₁ -->[ F] I₂). Definition disp_bicat_twosided_disp_cat_hor_id_weq_inv2cell : pr1 FI ~ pr1 GI ≃ disp_invertible_2cell (id2_invertible_2cell F) FI GI. Proof. use weqimplimpl. - intro p. simple refine (_ ,, _). + intro x ; cbn. rewrite id_two_disp_right. rewrite double_id_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. etrans. { apply maponpaths. exact (p x). } use transportf_disp_mor2_eq. apply idpath. + apply is_disp_invertible_2cell_hor_id. - intros p x. pose (q := pr1 p x). cbn in q. rewrite id_two_disp_right in q. rewrite double_id_mor_id in q. rewrite id_two_disp_left in q. rewrite transport_b_b_disp_mor2 in q. refine (!_ @ maponpaths _ q @ transportfb_disp_mor2 _ _ _). unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. - use impred ; intro. apply isaset_disp_mor. - use isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply isaprop_double_nat_trans_hor_id. Qed. End HorIdDispInv2cell. Definition disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_id : disp_univalent_2_1 disp_bicat_twosided_disp_cat_hor_id. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros CD₁ CD₂ F I₁ I₂ FI GI. use weqhomot. - refine (disp_bicat_twosided_disp_cat_hor_id_weq_inv2cell FI GI ∘ weqtoforallpaths _ _ _ ∘ path_sigma_hprop _ _ _ _)%weq. apply isaprop_double_functor_hor_id_laws. - intro p. use subtypePath. { intro. apply isaprop_is_disp_invertible_2cell. } apply isaprop_double_nat_trans_hor_id. Qed. Section AdjEquivHorId. Context {CD : bicat_twosided_disp_cat} (FF GG : disp_bicat_twosided_disp_cat_hor_id CD) (τ : FF -->[ identity CD ] GG) (Hτ : ∏ (x : pr11 CD), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x)). Definition to_disp_left_adjequiv_hor_id_inv_data : double_functor_hor_id_data (twosided_disp_functor_identity _) GG FF := λ x, pr1 (Hτ x). Arguments to_disp_left_adjequiv_hor_id_inv_data /. Proposition to_disp_left_adjequiv_hor_id_inv_laws : double_functor_hor_id_laws to_disp_left_adjequiv_hor_id_inv_data. Proof. intros x y f ; cbn. pose (pr2 τ x y f) as p ; cbn in p. refine (!_). etrans. { apply maponpaths. apply id_two_disp_right_alt. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. etrans. { do 3 apply maponpaths. exact (inv_after_iso_twosided_disp_alt (Hτ y)). } rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. exact (pr2 τ x y f). } unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite !assoc_two_disp. unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. etrans. { apply maponpaths. do 2 apply maponpaths_2. apply Hτ. } unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. Qed. Definition to_disp_left_adjequiv_hor_id_inv : double_functor_hor_id (twosided_disp_functor_identity _) GG FF. Proof. use make_double_functor_hor_id. - exact to_disp_left_adjequiv_hor_id_inv_data. - exact to_disp_left_adjequiv_hor_id_inv_laws. Defined. Proposition to_disp_left_adjequiv_hor_id_unit : double_nat_trans_hor_id (id_twosided_disp_nat_trans (twosided_disp_functor_identity _)) (identity_hor_id FF) (comp_hor_id τ to_disp_left_adjequiv_hor_id_inv). Proof. intros x ; cbn. rewrite id_two_disp_left. rewrite two_disp_post_whisker_f. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite double_id_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). etrans. { apply maponpaths. apply Hτ. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition to_disp_left_adjequiv_hor_id_counit : double_nat_trans_hor_id (id_twosided_disp_nat_trans (twosided_disp_functor_identity _)) (comp_hor_id to_disp_left_adjequiv_hor_id_inv τ) (identity_hor_id GG). Proof. intros x ; cbn. rewrite !id_two_disp_right. unfold transportb_disp_mor2. rewrite !transport_f_f_disp_mor2. rewrite double_id_mor_id. etrans. { apply maponpaths. apply Hτ. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Definition to_disp_left_adjequiv_hor_id : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity CD) τ. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact to_disp_left_adjequiv_hor_id_inv. - exact to_disp_left_adjequiv_hor_id_unit. - exact to_disp_left_adjequiv_hor_id_counit. - apply isaprop_double_nat_trans_hor_id. - apply isaprop_double_nat_trans_hor_id. - apply is_disp_invertible_2cell_hor_id. - apply is_disp_invertible_2cell_hor_id. Qed. End AdjEquivHorId. Definition weq_disp_left_adjequiv_hor_id_map {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_id CD} (τ : ∏ (x : pr11 CD), iso_twosided_disp (identity_z_iso x) (identity_z_iso x) (double_id (pr1 GG) x) (double_id (pr1 FF) x)) (Hτ : double_functor_hor_id_laws (FF := twosided_disp_functor_identity _) (I₁ := FF) (I₂ := GG) (λ x, pr1 (τ x))) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG. Proof. simple refine (_ ,, _). - simple refine (_ ,, _). + exact (λ x, τ x). + exact Hτ. - use to_disp_left_adjequiv_hor_id. intro x. exact (pr2 (τ x)). Defined. Definition disp_left_adjequiv_hor_id_help {CD₁ CD₂ : bicat_twosided_disp_cat} (F : adjoint_equivalence CD₁ CD₂) {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} (τ : I₁ -->[ F ] I₂) (Hτ : ∏ (x : pr11 CD₁), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x)) : disp_left_adjoint_equivalence F τ. Proof. revert CD₁ CD₂ F I₁ I₂ τ Hτ. use J_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat. - intros CD I₁ I₂ τ Hτ. use to_disp_left_adjequiv_hor_id. exact Hτ. Qed. Definition disp_left_adjequiv_hor_id {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} (HF : left_adjoint_equivalence F) {I₁ : disp_bicat_twosided_disp_cat_hor_id CD₁} {I₂ : disp_bicat_twosided_disp_cat_hor_id CD₂} (τ : I₁ -->[ F ] I₂) (Hτ : ∏ (x : pr11 CD₁), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x)) : disp_left_adjoint_equivalence HF τ. Proof. exact (disp_left_adjequiv_hor_id_help (F ,, HF) τ Hτ). Qed. Section FromAdjEquivHorId. Context {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_id CD} (τ : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG). Definition weq_disp_left_adjequiv_hor_id_inv_iso (x : pr11 CD) : is_iso_twosided_disp (identity_is_z_iso x) (identity_is_z_iso x) ((pr11 τ) x). Proof. simple refine (_ ,, _). - exact (pr1 (pr112 τ) x). - split. + abstract (cbn ; pose (p := pr2 (pr212 τ) x) ; cbn in p ; rewrite id_two_disp_right in p ; rewrite double_id_mor_id in p ; rewrite id_two_disp_left in p ; unfold transportb_disp_mor2 in p ; rewrite !transport_f_f_disp_mor2 in p ; refine (!(transportbf_disp_mor2 _ _ _) @ maponpaths _ p @ _) ; unfold transportb_disp_mor2 ; rewrite transport_f_f_disp_mor2 ; use transportf_disp_mor2_eq ; apply idpath). + abstract (pose (p := pr1 (pr212 τ) x) ; cbn in p ; rewrite id_two_disp_left in p ; rewrite double_id_mor_id in p ; rewrite id_two_disp_left in p ; unfold transportb_disp_mor2 in p ; rewrite !transport_f_f_disp_mor2 in p ; refine (!(transportbf_disp_mor2 _ _ _) @ maponpaths _ (!p) @ _) ; unfold transportb_disp_mor2 ; rewrite transport_f_f_disp_mor2 ; use transportf_disp_mor2_eq ; apply idpath). Defined. Proposition weq_disp_left_adjequiv_hor_id_inv_laws : double_functor_hor_id_laws (FF := twosided_disp_functor_identity _) (I₁ := FF) (I₂ := GG) (λ x, pr11 τ x). Proof. intros x y f. exact (pr21 τ x y f). Qed. End FromAdjEquivHorId. Definition weq_disp_left_adjequiv_hor_id_inv {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_id CD} (τ : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG) : ∑ (F : ∏ (x : pr11 CD), iso_twosided_disp (identity_z_iso x) (identity_z_iso x) (double_id (pr1 GG) x) (double_id (pr1 FF) x)), double_functor_hor_id_laws (FF := twosided_disp_functor_identity _) (I₁ := FF) (I₂ := GG) (λ x, pr1 (F x)). Proof. simple refine (_ ,, _). - intro x. simple refine (_ ,, _). + exact (pr11 τ x). + exact (weq_disp_left_adjequiv_hor_id_inv_iso τ x). - exact (weq_disp_left_adjequiv_hor_id_inv_laws τ). Defined. Definition weq_disp_left_adjequiv_hor_id {CD : bicat_twosided_disp_cat} (FF GG : disp_bicat_twosided_disp_cat_hor_id CD) : (∑ (F : ∏ (x : pr11 CD), iso_twosided_disp (identity_z_iso x) (identity_z_iso x) (double_id (pr1 GG) x) (double_id (pr1 FF) x)), double_functor_hor_id_laws (FF := twosided_disp_functor_identity _) (I₁ := FF) (I₂ := GG) (λ x, pr1 (F x))) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG. Proof. use weq_iso. - intros F. exact (weq_disp_left_adjequiv_hor_id_map (pr1 F) (pr2 F)). - exact weq_disp_left_adjequiv_hor_id_inv. - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_double_functor_hor_id_laws | ] ; use funextsec ; intro ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_disp_left_adjoint_equivalence ; [ apply is_univalent_2_1_bicat_twosided_disp_cat | apply disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_id ] | ] ; use subtypePath ; [ intro ; apply isaprop_double_functor_hor_id_laws | ] ; use funextsec ; intro ; cbn ; apply idpath). Defined. Definition disp_univalent_2_0_disp_bicat_twosided_disp_cat_hor_id : disp_univalent_2_0 disp_bicat_twosided_disp_cat_hor_id. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros CD FF GG. use weqhomot. - refine (weq_disp_left_adjequiv_hor_id FF GG ∘ weqtotal2 (weqonsecfibers _ _ (λ x, make_weq _ (pr22 CD _ _ _ _ (idpath _) (idpath _) (pr11 GG x) (pr11 FF x)) ∘ weqpathsinv0 _ _) ∘ weqtoforallpaths _ _ _) _ ∘ total2_paths_equiv _ _ _ ∘ path_sigma_hprop _ _ _ (isaprop_hor_id_laws _))%weq. induction FF as [ [ FF₁ FF₂ ] H ]. induction GG as [ [ GG₁ GG₂ ] K ]. intro p. pose (q := p : FF₁ = GG₁). assert (p = q) by apply idpath. induction q. rewrite X ; clear p X. cbn. use weqimplimpl. + intro q. intros x y f. cbn. rewrite q. rewrite id_two_disp_left. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. + intro q. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. pose (q x y f) as p. cbn in p. rewrite id_two_disp_left in p. rewrite id_two_disp_right in p. rewrite transport_b_b_disp_mor2 in p. refine (!(transportfb_disp_mor2 _ _ _) @ maponpaths _ (!p) @ _). unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. + do 3 (use impred_isaset ; intro). apply isaset_disp_mor. + apply isaprop_double_functor_hor_id_laws. - intro p. cbn in p. induction p. use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. - apply is_univalent_2_1_bicat_twosided_disp_cat. - apply disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_id. } use subtypePath. { intro. apply isaprop_double_functor_hor_id_laws. } cbn. apply idpath. Qed. Definition disp_univalent_2_disp_bicat_twosided_disp_cat_hor_id : disp_univalent_2 disp_bicat_twosided_disp_cat_hor_id. Proof. split. - exact disp_univalent_2_0_disp_bicat_twosided_disp_cat_hor_id. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_id. Qed. (** 2. Two-sided displayed categories with horizontal composition *) Definition disp_cat_ob_mor_twosided_disp_cat_hor_comp : disp_cat_ob_mor bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact (λ CD, hor_comp (pr12 CD)). - exact (λ CD₁ CD₂ Cm₁ Cm₂ FFF, double_functor_hor_comp (pr2 FFF) Cm₁ Cm₂). Defined. Definition disp_cat_id_comp_twosided_disp_cat_hor_comp : disp_cat_id_comp bicat_twosided_disp_cat disp_cat_ob_mor_twosided_disp_cat_hor_comp. Proof. split. - exact (λ C Cm, identity_hor_comp Cm). - exact (λ C₁ C₂ C₃ FFF GGG Cm₁ Cm₂ Cm₃ FC GC, comp_hor_comp FC GC). Defined. Definition disp_cat_data_twosided_disp_cat_hor_comp : disp_cat_data bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_twosided_disp_cat_hor_comp. - exact disp_cat_id_comp_twosided_disp_cat_hor_comp. Defined. Definition disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_comp : disp_prebicat_1_id_comp_cells bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_cat_data_twosided_disp_cat_hor_comp. - exact (λ CD₁ CD₂ FFF GGG τττ I₁ I₂ FC GC, double_nat_trans_hor_comp (pr2 τττ) FC GC). Defined. Definition disp_prebicat_1_ops_twosided_disp_cat_hor_comp : disp_prebicat_ops disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_comp. Proof. repeat split. - intros CD₁ CD₂ F I₁ I₂ IF. exact (id_twosided_disp_nat_trans_hor_comp IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (lunitor_twosided_disp_nat_trans_hor_comp IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (runitor_twosided_disp_nat_trans_hor_comp IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (linvunitor_twosided_disp_nat_trans_hor_comp IF). - intros CD₁ CD₂ F I₁ I₂ IF. exact (rinvunitor_twosided_disp_nat_trans_hor_comp IF). - intros CD₁ CD₂ CD₃ CD₄ F G H I₁ I₂ I₃ I₄ IF IG IH. exact (rassociator_twosided_disp_nat_trans_hor_comp IF IG IH). - intros CD₁ CD₂ CD₃ CD₄ F G H I₁ I₂ I₃ I₄ IF IG IH. exact (lassociator_twosided_disp_nat_trans_hor_comp IF IG IH). - intros CD₁ CD₂ F G H τ θ I₁ I₂ IF IG IH Iτ Iθ ; cbn. exact (comp_twosided_disp_nat_trans_hor_comp Iτ Iθ). - intros CD₁ CD₂ CD₃ F G₁ G₂ θ I₁ I₂ I₃ IF IG₁ IG₂ Iθ. exact (pre_whisker_twosided_disp_nat_trans_hor_comp IF Iθ). - intros CD₁ CD₂ CD₃ F G₁ G₂ τ I₁ I₂ I₃ IF₁ IF₂ IG Iτ. exact (post_whisker_twosided_disp_nat_trans_hor_comp IG Iτ). Qed. Definition disp_prebicat_data_twosided_disp_cat_hor_comp : disp_prebicat_data bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_1_id_comp_cells_twosided_disp_cat_hor_comp. - exact disp_prebicat_1_ops_twosided_disp_cat_hor_comp. Defined. Proposition disp_prebicat_laws_twosided_disp_cat_hor_comp : disp_prebicat_laws disp_prebicat_data_twosided_disp_cat_hor_comp. Proof. repeat split ; intro ; intros ; apply isaprop_double_nat_trans_hor_comp. Qed. Definition disp_prebicat_twosided_disp_cat_hor_comp : disp_prebicat bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_data_twosided_disp_cat_hor_comp. - exact disp_prebicat_laws_twosided_disp_cat_hor_comp. Defined. Definition disp_bicat_twosided_disp_cat_hor_comp : disp_bicat bicat_twosided_disp_cat. Proof. simple refine (_ ,, _). - exact disp_prebicat_twosided_disp_cat_hor_comp. - intro ; intros. apply isasetaprop. apply isaprop_double_nat_trans_hor_comp. Defined. Definition is_disp_invertible_2cell_hor_comp_over_id {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} {Cm₁ : disp_bicat_twosided_disp_cat_hor_comp CD₁} {Cm₂ : disp_bicat_twosided_disp_cat_hor_comp CD₂} {FC GC : Cm₁ -->[ F ] Cm₂} (τ : FC ==>[ id2 _ ] GC) : is_disp_invertible_2cell (id2_invertible_2cell F) τ. Proof. simple refine (_ ,, _ ,, _). - intros x y z h k ; cbn. pose (p := τ x y z h k) ; cbn in p. rewrite id_two_disp_right. rewrite id_two_disp_right in p. rewrite double_hor_comp_mor_id. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left. rewrite id_two_disp_left in p. rewrite transport_b_b_disp_mor2. rewrite transport_b_b_disp_mor2 in p. refine (_ @ !p @ _) ; use transportf_disp_mor2_eq ; apply idpath. - apply isaprop_double_nat_trans_hor_comp. - apply isaprop_double_nat_trans_hor_comp. Qed. Definition is_disp_invertible_2cell_hor_comp {CD₁ CD₂ : bicat_twosided_disp_cat} {F G : CD₁ --> CD₂} {τ : invertible_2cell F G} {Cm₁ : disp_bicat_twosided_disp_cat_hor_comp CD₁} {Cm₂ : disp_bicat_twosided_disp_cat_hor_comp CD₂} {FC : Cm₁ -->[ F ] Cm₂} {GC : Cm₁ -->[ G ] Cm₂} (ττ : FC ==>[ τ ] GC) : is_disp_invertible_2cell τ ττ. Proof. revert CD₁ CD₂ F G τ Cm₁ Cm₂ FC GC ττ. use J_2_1. - apply is_univalent_2_1_bicat_twosided_disp_cat. - cbn. intro ; intros. apply is_disp_invertible_2cell_hor_comp_over_id. Qed. Section HorCompDispInv2cell. Context {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} {Cm₁ : disp_bicat_twosided_disp_cat_hor_comp CD₁} {Cm₂ : disp_bicat_twosided_disp_cat_hor_comp CD₂} (FC GC : Cm₁ -->[ F ] Cm₂). Definition disp_bicat_twosided_disp_cat_hor_comp_weq_inv2cell : (∏ x y z h k, pr1 FC x y z h k = pr1 GC x y z h k) ≃ disp_invertible_2cell (id2_invertible_2cell F) FC GC. Proof. use weqimplimpl. - intro p. simple refine (_ ,, _). + intros x y z h k ; cbn. rewrite id_two_disp_right. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. etrans. { apply maponpaths. exact (p x y z h k). } use transportf_disp_mor2_eq. apply idpath. + apply is_disp_invertible_2cell_hor_comp. - intros p x y z h k. pose (q := pr1 p x y z h k). cbn in q. rewrite id_two_disp_right in q. rewrite double_hor_comp_mor_id in q. rewrite id_two_disp_left in q. rewrite transport_b_b_disp_mor2 in q. refine (!_ @ maponpaths _ q @ transportfb_disp_mor2 _ _ _). unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. - repeat (use impred ; intro). apply isaset_disp_mor. - use isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply isaprop_double_nat_trans_hor_comp. Qed. End HorCompDispInv2cell. Definition disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_comp : disp_univalent_2_1 disp_bicat_twosided_disp_cat_hor_comp. Proof. use fiberwise_local_univalent_is_univalent_2_1. intros CD₁ CD₂ F Cm₁ Cm₂ FC GC. use weqhomot. - refine (disp_bicat_twosided_disp_cat_hor_comp_weq_inv2cell FC GC ∘ weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, weqonsecfibers _ _ (λ z, weqonsecfibers _ _ (λ h, weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _ ∘ path_sigma_hprop _ _ _ _)%weq. apply isaprop_double_functor_hor_comp_laws. - intro p. use subtypePath. { intro. apply isaprop_is_disp_invertible_2cell. } apply isaprop_double_nat_trans_hor_comp. Qed. Section AdjEquivHorComp. Context {CD : bicat_twosided_disp_cat} (FF GG : disp_bicat_twosided_disp_cat_hor_comp CD) (τ : FF -->[ identity CD ] GG) (Hτ : ∏ (x y z : pr11 CD) (h : pr12 CD x y) (k : pr12 CD y z), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x y z h k)). Definition to_disp_left_adjequiv_hor_comp_inv_data : double_functor_hor_comp_data (twosided_disp_functor_identity _) GG FF := λ x y z h k, pr1 (Hτ x y z h k). Arguments to_disp_left_adjequiv_hor_id_inv_data /. Proposition to_disp_left_adjequiv_hor_comp_inv_laws : double_functor_hor_comp_laws to_disp_left_adjequiv_hor_comp_inv_data. Proof. intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn. pose (pr2 τ x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂) as p ; cbn in p. refine (!_). etrans. { apply maponpaths. apply id_two_disp_right_alt. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. etrans. { do 3 apply maponpaths. exact (inv_after_iso_twosided_disp_alt (Hτ _ _ _ _ _)). } rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. apply (pr2 τ). } unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite !assoc_two_disp. unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. etrans. { apply maponpaths. do 2 apply maponpaths_2. apply Hτ. } unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. Qed. Definition to_disp_left_adjequiv_hor_comp_inv : double_functor_hor_comp (twosided_disp_functor_identity _) GG FF. Proof. use make_double_functor_hor_comp. - exact to_disp_left_adjequiv_hor_comp_inv_data. - exact to_disp_left_adjequiv_hor_comp_inv_laws. Defined. Proposition to_disp_left_adjequiv_hor_comp_unit : double_nat_trans_hor_comp (id_twosided_disp_nat_trans (twosided_disp_functor_identity _)) (identity_hor_comp FF) (comp_hor_comp τ to_disp_left_adjequiv_hor_comp_inv). Proof. intros x y z h k ; cbn. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). etrans. { apply maponpaths. apply Hτ. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition to_disp_left_adjequiv_hor_comp_counit : double_nat_trans_hor_comp (id_twosided_disp_nat_trans (twosided_disp_functor_identity _)) (comp_hor_comp to_disp_left_adjequiv_hor_comp_inv τ) (identity_hor_comp GG). Proof. intros x y z h k ; cbn. rewrite !id_two_disp_right. unfold transportb_disp_mor2. rewrite !transport_f_f_disp_mor2. rewrite double_hor_comp_mor_id. etrans. { apply maponpaths. apply Hτ. } unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Definition to_disp_left_adjequiv_hor_comp : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity CD) τ. Proof. simple refine ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _))). - exact to_disp_left_adjequiv_hor_comp_inv. - exact to_disp_left_adjequiv_hor_comp_unit. - exact to_disp_left_adjequiv_hor_comp_counit. - apply isaprop_double_nat_trans_hor_comp. - apply isaprop_double_nat_trans_hor_comp. - apply is_disp_invertible_2cell_hor_comp. - apply is_disp_invertible_2cell_hor_comp. Qed. End AdjEquivHorComp. Definition weq_disp_left_adjequiv_hor_comp_map {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_comp CD} (τ : ∏ (x y z : pr11 CD) (h : pr12 CD x y) (k : pr12 CD y z), iso_twosided_disp (identity_z_iso _) (identity_z_iso _) (double_hor_comp (pr1 GG) h k) (double_hor_comp (pr1 FF) h k)) (Hτ : double_functor_hor_comp_laws (FF := twosided_disp_functor_identity _) (Cm₁ := FF) (Cm₂ := GG) (λ x y z h k, pr1 (τ x y z h k))) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG. Proof. simple refine (_ ,, _). - simple refine (_ ,, _). + exact τ. + exact Hτ. - use to_disp_left_adjequiv_hor_comp. intros x y z h k. exact (pr2 (τ x y z h k)). Defined. Definition disp_left_adjequiv_hor_comp_help {CD₁ CD₂ : bicat_twosided_disp_cat} (F : adjoint_equivalence CD₁ CD₂) {Cm₁ : disp_bicat_twosided_disp_cat_hor_comp CD₁} {Cm₂ : disp_bicat_twosided_disp_cat_hor_comp CD₂} (τ : Cm₁ -->[ F ] Cm₂) (Hτ : ∏ (x y z : pr11 CD₁) (h : pr12 CD₁ x y) (k : pr12 CD₁ y z), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x y z h k)) : disp_left_adjoint_equivalence F τ. Proof. revert CD₁ CD₂ F Cm₁ Cm₂ τ Hτ. use J_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat. - intros CD I₁ I₂ τ Hτ. use to_disp_left_adjequiv_hor_comp. exact Hτ. Qed. Definition disp_left_adjequiv_hor_comp {CD₁ CD₂ : bicat_twosided_disp_cat} {F : CD₁ --> CD₂} (HF : left_adjoint_equivalence F) {Cm₁ : disp_bicat_twosided_disp_cat_hor_comp CD₁} {Cm₂ : disp_bicat_twosided_disp_cat_hor_comp CD₂} (τ : Cm₁ -->[ F ] Cm₂) (Hτ : ∏ (x y z : pr11 CD₁) (h : pr12 CD₁ x y) (k : pr12 CD₁ y z), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 τ x y z h k)) : disp_left_adjoint_equivalence HF τ. Proof. exact (disp_left_adjequiv_hor_comp_help (F ,, HF) τ Hτ). Qed. Section FromAdjEquivHorComp. Context {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_comp CD} (τ : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG). Definition weq_disp_left_adjequiv_hor_comp_inv_iso {x y z : pr11 CD} (h : pr12 CD x y) (k : pr12 CD y z) : is_iso_twosided_disp (identity_is_z_iso x) (identity_is_z_iso z) (pr11 τ x y z h k). Proof. simple refine (_ ,, _). - exact (pr1 (pr112 τ) x y z h k). - split. + abstract (cbn ; pose (p := pr2 (pr212 τ) x y z h k) ; cbn in p ; rewrite id_two_disp_right in p ; rewrite double_hor_comp_mor_id in p ; rewrite id_two_disp_left in p ; unfold transportb_disp_mor2 in p ; rewrite !transport_f_f_disp_mor2 in p ; refine (!(transportbf_disp_mor2 _ _ _) @ maponpaths _ p @ _) ; unfold transportb_disp_mor2 ; rewrite transport_f_f_disp_mor2 ; use transportf_disp_mor2_eq ; apply idpath). + abstract (pose (p := pr1 (pr212 τ) x y z h k) ; cbn in p ; rewrite id_two_disp_left in p ; rewrite double_hor_comp_mor_id in p ; rewrite id_two_disp_left in p ; unfold transportb_disp_mor2 in p ; rewrite !transport_f_f_disp_mor2 in p ; refine (!(transportbf_disp_mor2 _ _ _) @ maponpaths _ (!p) @ _) ; unfold transportb_disp_mor2 ; rewrite transport_f_f_disp_mor2 ; use transportf_disp_mor2_eq ; apply idpath). Defined. Proposition weq_disp_left_adjequiv_hor_comp_inv_laws : double_functor_hor_comp_laws (FF := twosided_disp_functor_identity _) (Cm₁ := FF) (Cm₂ := GG) (λ x, pr11 τ x). Proof. intros x y f. exact (pr21 τ x y f). Qed. End FromAdjEquivHorComp. Definition weq_disp_left_adjequiv_hor_comp_inv {CD : bicat_twosided_disp_cat} {FF GG : disp_bicat_twosided_disp_cat_hor_comp CD} (τ : disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG) : ∑ (F : ∏ (x y z : pr11 CD) (h : pr12 CD x y) (k : pr12 CD y z), iso_twosided_disp (identity_z_iso _) (identity_z_iso _) (double_hor_comp (pr1 GG) h k) (double_hor_comp (pr1 FF) h k)), double_functor_hor_comp_laws (FF := twosided_disp_functor_identity _) (Cm₁ := FF) (Cm₂ := GG) (λ x y z h k, pr1 (F x y z h k)). Proof. simple refine (_ ,, _). - intros x y z h k. simple refine (_ ,, _). + exact (pr11 τ x y z h k). + exact (weq_disp_left_adjequiv_hor_comp_inv_iso τ h k). - exact (weq_disp_left_adjequiv_hor_comp_inv_laws τ). Defined. Definition weq_disp_left_adjequiv_hor_comp {CD : bicat_twosided_disp_cat} (FF GG : disp_bicat_twosided_disp_cat_hor_comp CD) : (∑ (F : ∏ (x y z : pr11 CD) (h : pr12 CD x y) (k : pr12 CD y z), iso_twosided_disp (identity_z_iso _) (identity_z_iso _) (double_hor_comp (pr1 GG) h k) (double_hor_comp (pr1 FF) h k)), double_functor_hor_comp_laws (FF := twosided_disp_functor_identity _) (Cm₁ := FF) (Cm₂ := GG) (λ x y z h k, pr1 (F x y z h k))) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity CD) FF GG. Proof. use weq_iso. - intros F. exact (weq_disp_left_adjequiv_hor_comp_map (pr1 F) (pr2 F)). - exact weq_disp_left_adjequiv_hor_comp_inv. - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_double_functor_hor_comp_laws | ] ; repeat (use funextsec ; intro) ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). - abstract (intro τ ; use subtypePath ; [ intro ; apply isaprop_disp_left_adjoint_equivalence ; [ apply is_univalent_2_1_bicat_twosided_disp_cat | apply disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_comp ] | ] ; use subtypePath ; [ intro ; apply isaprop_double_functor_hor_comp_laws | ] ; use funextsec ; intro ; cbn ; apply idpath). Defined. Definition disp_univalent_2_0_disp_bicat_twosided_disp_cat_hor_comp : disp_univalent_2_0 disp_bicat_twosided_disp_cat_hor_comp. Proof. use fiberwise_univalent_2_0_to_disp_univalent_2_0. intros CD FF GG. use weqhomot. - refine (weq_disp_left_adjequiv_hor_comp FF GG ∘ weqtotal2 (weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, weqonsecfibers _ _ (λ z, weqonsecfibers _ _ (λ h, weqonsecfibers _ _ (λ k, make_weq _ (pr22 CD _ _ _ _ (idpath _) (idpath _) _ _) ∘ weqpathsinv0 _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _) _ ∘ total2_paths_equiv _ _ _ ∘ path_sigma_hprop _ _ _ (isaprop_hor_comp_laws _))%weq. cbn. induction FF as [ [ FF₁ FF₂ ] H ]. induction GG as [ [ GG₁ GG₂ ] K ]. intro p. pose (q := p : FF₁ = GG₁). assert (p = q) by apply idpath. induction q. rewrite X ; clear p X. cbn. use weqimplimpl. + intro q. intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn. rewrite q. rewrite id_two_disp_left. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. + intro q. use funextsec ; intro x₁. use funextsec ; intro x₂. use funextsec ; intro y₁. use funextsec ; intro y₂. use funextsec ; intro z₁. use funextsec ; intro z₂. use funextsec ; intro v₁. use funextsec ; intro v₂. use funextsec ; intro v₃. use funextsec ; intro h₁. use funextsec ; intro h₂. use funextsec ; intro k₁. use funextsec ; intro k₂. use funextsec ; intro s₁. use funextsec ; intro s₂. pose (q x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ k₁ h₂ k₂ s₁ s₂) as p. cbn in p. rewrite id_two_disp_left in p. rewrite id_two_disp_right in p. rewrite transport_b_b_disp_mor2 in p. refine (!(transportfb_disp_mor2 _ _ _) @ maponpaths _ (!p) @ _). unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. + do 15 (use impred_isaset ; intro). apply isaset_disp_mor. + apply isaprop_double_functor_hor_comp_laws. - intro p. cbn in p. induction p. use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. - apply is_univalent_2_1_bicat_twosided_disp_cat. - apply disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_comp. } use subtypePath. { intro. apply isaprop_double_functor_hor_comp_laws. } cbn. apply idpath. Qed. Definition disp_univalent_2_disp_bicat_twosided_disp_cat_hor_comp : disp_univalent_2 disp_bicat_twosided_disp_cat_hor_comp. Proof. split. - exact disp_univalent_2_0_disp_bicat_twosided_disp_cat_hor_comp. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_comp. Qed. (** 3. Two-sided displayed categories with identities and horizontal composition *) Definition disp_bicat_twosided_disp_cat_id_hor_comp : disp_bicat bicat_twosided_disp_cat := disp_dirprod_bicat disp_bicat_twosided_disp_cat_hor_id disp_bicat_twosided_disp_cat_hor_comp. Proposition disp_univalent_2_1_disp_bicat_twosided_disp_cat_id_hor_comp : disp_univalent_2_1 disp_bicat_twosided_disp_cat_id_hor_comp. Proof. use is_univalent_2_1_dirprod_bicat. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_id. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_hor_comp. Qed. Proposition disp_univalent_2_0_disp_bicat_twosided_disp_cat_id_hor_comp : disp_univalent_2_0 disp_bicat_twosided_disp_cat_id_hor_comp. Proof. use is_univalent_2_0_dirprod_bicat. - exact is_univalent_2_1_bicat_twosided_disp_cat. - exact disp_univalent_2_disp_bicat_twosided_disp_cat_hor_id. - exact disp_univalent_2_disp_bicat_twosided_disp_cat_hor_comp. Qed. Proposition disp_univalent_2_disp_bicat_twosided_disp_cat_id_hor_comp : disp_univalent_2 disp_bicat_twosided_disp_cat_id_hor_comp. Proof. split. - exact disp_univalent_2_0_disp_bicat_twosided_disp_cat_id_hor_comp. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_id_hor_comp. Qed. Definition bicat_twosided_disp_cat_id_hor_comp : bicat := total_bicat disp_bicat_twosided_disp_cat_id_hor_comp. Definition is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp : is_univalent_2_1 bicat_twosided_disp_cat_id_hor_comp. Proof. use total_is_univalent_2_1. - exact is_univalent_2_1_bicat_twosided_disp_cat. - exact disp_univalent_2_1_disp_bicat_twosided_disp_cat_id_hor_comp. Qed. Definition is_univalent_2_0_bicat_twosided_disp_cat_id_hor_comp : is_univalent_2_0 bicat_twosided_disp_cat_id_hor_comp. Proof. use total_is_univalent_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat. - exact disp_univalent_2_0_disp_bicat_twosided_disp_cat_id_hor_comp. Qed. Definition is_univalent_2_bicat_twosided_disp_cat_id_hor_comp : is_univalent_2 bicat_twosided_disp_cat_id_hor_comp. Proof. split. - exact is_univalent_2_0_bicat_twosided_disp_cat_id_hor_comp. - exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. Qed. (** 4. Two-sided displayed categories with left unitors *) Definition disp_cat_ob_mor_lunitor : disp_cat_ob_mor bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact (λ CD, double_cat_lunitor (pr12 CD) (pr22 CD)). - exact (λ CD₁ CD₂ l₁ l₂ FF, double_functor_lunitor l₁ l₂ (pr12 FF) (pr22 FF)). Defined. Definition disp_cat_id_comp_lunitor : disp_cat_id_comp bicat_twosided_disp_cat_id_hor_comp disp_cat_ob_mor_lunitor. Proof. split. - intros CD l. exact (identity_functor_lunitor l). - intros CD₁ CD₂ CD₃ FF GG l₁ l₂ l₃ FFl GGl. exact (comp_functor_lunitor FFl GGl). Qed. Definition disp_cat_data_lunitor : disp_cat_data bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_lunitor. - exact disp_cat_id_comp_lunitor. Defined. Definition disp_bicat_lunitor : disp_bicat bicat_twosided_disp_cat_id_hor_comp := disp_cell_unit_bicat disp_cat_data_lunitor. Definition disp_univalent_2_1_disp_bicat_lunitor : disp_univalent_2_1 disp_bicat_lunitor. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply isaprop_double_functor_lunitor. Qed. Definition disp_univalent_2_0_disp_bicat_lunitor : disp_univalent_2_0 disp_bicat_lunitor. Proof. use disp_cell_unit_bicat_univalent_2_0. - exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. - intros. apply isaprop_double_functor_lunitor. - intros. apply isaset_double_cat_lunitor. - intros CD FF GG H. induction H as [ H₁ H₂ ]. use subtypePath. { intro. apply isaprop_double_lunitor_laws. } use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. pose (p := H₁ x y f). pose (q := H₂ x y f). cbn in p, q. rewrite id_two_disp_right in p. rewrite two_disp_pre_whisker_b in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. use subtypePath. { intro. apply isaprop_is_iso_twosided_disp. } refine (_ @ !p). refine (!_). apply transportf_disp_mor2_idpath. Qed. Definition disp_univalent_2_disp_bicat_lunitor : disp_univalent_2 disp_bicat_lunitor. Proof. split. - exact disp_univalent_2_0_disp_bicat_lunitor. - exact disp_univalent_2_1_disp_bicat_lunitor. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_lunitor_help {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} (F : adjoint_equivalence C₁ C₂) {l₁ : disp_bicat_lunitor C₁} {l₂ : disp_bicat_lunitor C₂} (Fl : l₁ -->[ F ] l₂) : disp_left_adjoint_equivalence F Fl. Proof. revert C₁ C₂ F l₁ l₂ Fl. use J_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat_id_hor_comp. - intros C l₁ l₂ Fl. use disp_cell_unit_bicat_left_adjoint_equivalence. intros x y f ; cbn. pose (p := Fl x y f) ; cbn in p. rewrite double_hor_comp_mor_id. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite two_disp_pre_whisker_f in p. rewrite transport_f_f_disp_mor2 in p. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. rewrite p. rewrite transport_f_f_disp_mor2. refine (!_). apply transportf_disp_mor2_idpath. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_lunitor {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} {F : C₁ --> C₂} (HF : left_adjoint_equivalence F) {l₁ : disp_bicat_lunitor C₁} {l₂ : disp_bicat_lunitor C₂} (Fl : l₁ -->[ F ] l₂) : disp_left_adjoint_equivalence HF Fl. Proof. exact (is_disp_left_adjoint_equivalence_disp_bicat_lunitor_help (F ,, HF) Fl). Qed. (** 5. Two-sided displayed categories with right unitors *) Definition disp_cat_ob_mor_runitor : disp_cat_ob_mor bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact (λ CD, double_cat_runitor (pr12 CD) (pr22 CD)). - exact (λ CD₁ CD₂ l₁ l₂ FF, double_functor_runitor l₁ l₂ (pr12 FF) (pr22 FF)). Defined. Definition disp_cat_id_comp_runitor : disp_cat_id_comp bicat_twosided_disp_cat_id_hor_comp disp_cat_ob_mor_runitor. Proof. split. - intros CD l. exact (identity_functor_runitor l). - intros CD₁ CD₂ CD₃ FF GG l₁ l₂ l₃ FFl GGl. exact (comp_functor_runitor FFl GGl). Qed. Definition disp_cat_data_runitor : disp_cat_data bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_runitor. - exact disp_cat_id_comp_runitor. Defined. Definition disp_bicat_runitor : disp_bicat bicat_twosided_disp_cat_id_hor_comp := disp_cell_unit_bicat disp_cat_data_runitor. Definition disp_univalent_2_1_disp_bicat_runitor : disp_univalent_2_1 disp_bicat_runitor. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply isaprop_double_functor_runitor. Qed. Definition disp_univalent_2_0_disp_bicat_runitor : disp_univalent_2_0 disp_bicat_runitor. Proof. use disp_cell_unit_bicat_univalent_2_0. - exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. - intros. apply isaprop_double_functor_runitor. - intros. apply isaset_double_cat_runitor. - intros CD FF GG H. induction H as [ H₁ H₂ ]. use subtypePath. { intro. apply isaprop_double_runitor_laws. } use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. pose (p := H₁ x y f). pose (q := H₂ x y f). cbn in p, q. rewrite id_two_disp_right in p. rewrite two_disp_pre_whisker_b in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. use subtypePath. { intro. apply isaprop_is_iso_twosided_disp. } refine (_ @ !p). refine (!_). apply transportf_disp_mor2_idpath. Qed. Definition disp_univalent_2_disp_bicat_runitor : disp_univalent_2 disp_bicat_runitor. Proof. split. - exact disp_univalent_2_0_disp_bicat_runitor. - exact disp_univalent_2_1_disp_bicat_runitor. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_runitor_help {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} (F : adjoint_equivalence C₁ C₂) {r₁ : disp_bicat_runitor C₁} {r₂ : disp_bicat_runitor C₂} (Fr : r₁ -->[ F ] r₂) : disp_left_adjoint_equivalence F Fr. Proof. revert C₁ C₂ F r₁ r₂ Fr. use J_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat_id_hor_comp. - intros C r₁ r₂ Fr. use disp_cell_unit_bicat_left_adjoint_equivalence. intros x y f ; cbn. pose (p := Fr x y f) ; cbn in p. rewrite double_hor_comp_mor_id. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite two_disp_pre_whisker_f in p. rewrite transport_f_f_disp_mor2 in p. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. rewrite p. rewrite transport_f_f_disp_mor2. refine (!_). apply transportf_disp_mor2_idpath. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_runitor {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} {F : C₁ --> C₂} (HF : left_adjoint_equivalence F) {r₁ : disp_bicat_runitor C₁} {r₂ : disp_bicat_runitor C₂} (Fr : r₁ -->[ F ] r₂) : disp_left_adjoint_equivalence HF Fr. Proof. exact (is_disp_left_adjoint_equivalence_disp_bicat_runitor_help (F ,, HF) Fr). Qed. (** 6. Two-sided displayed categories with associators *) Definition disp_cat_ob_mor_lassociator : disp_cat_ob_mor bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact (λ CD, double_cat_associator (pr22 CD)). - exact (λ CD₁ CD₂ a₁ a₂ FF, double_functor_associator a₁ a₂ (pr22 FF)). Defined. Definition disp_cat_id_comp_lassociator : disp_cat_id_comp bicat_twosided_disp_cat_id_hor_comp disp_cat_ob_mor_lassociator. Proof. split. - intros. apply identity_functor_associator. - intros CD₁ CD₂ CD₃ FF GG a₁ a₂ a₃ FFa GGa. exact (comp_functor_associator FFa GGa). Qed. Definition disp_cat_data_lassociator : disp_cat_data bicat_twosided_disp_cat_id_hor_comp. Proof. simple refine (_ ,, _). - exact disp_cat_ob_mor_lassociator. - exact disp_cat_id_comp_lassociator. Defined. Definition disp_bicat_lassociator : disp_bicat bicat_twosided_disp_cat_id_hor_comp := disp_cell_unit_bicat disp_cat_data_lassociator. Definition disp_univalent_2_1_disp_bicat_lassociator : disp_univalent_2_1 disp_bicat_lassociator. Proof. use disp_cell_unit_bicat_univalent_2_1. intros. apply isaprop_double_functor_associator. Qed. Definition disp_univalent_2_0_disp_bicat_lassociator : disp_univalent_2_0 disp_bicat_lassociator. Proof. use disp_cell_unit_bicat_univalent_2_0. - exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. - intros. apply isaprop_double_functor_associator. - intros. apply isaset_double_cat_associator. - intros CD FF GG H. induction H as [ H₁ H₂ ]. use subtypePath. { intro. apply isaprop_double_associator_laws. } use funextsec ; intro w. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro h. pose (p := H₁ w x y z f g h). cbn in p. rewrite id_two_disp_right in p. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_right in p. rewrite transport_b_b_disp_mor2 in p. rewrite double_hor_comp_mor_id in p. rewrite id_two_disp_left in p. rewrite two_disp_pre_whisker_b in p. rewrite id_two_disp_left in p. rewrite transport_b_b_disp_mor2 in p. use subtypePath. { intro. apply isaprop_is_iso_twosided_disp. } refine (_ @ maponpaths _ (!p) @ transportfb_disp_mor2 _ _ _). refine (!_). unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply transportf_disp_mor2_idpath. Qed. Definition disp_univalent_2_disp_bicat_lassociator : disp_univalent_2 disp_bicat_lassociator. Proof. split. - exact disp_univalent_2_0_disp_bicat_lassociator. - exact disp_univalent_2_1_disp_bicat_lassociator. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_lassociator_help {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} (F : adjoint_equivalence C₁ C₂) {a₁ : disp_bicat_lassociator C₁} {a₂ : disp_bicat_lassociator C₂} (Fa : a₁ -->[ F ] a₂) : disp_left_adjoint_equivalence F Fa. Proof. revert C₁ C₂ F a₁ a₂ Fa. use J_2_0. - exact is_univalent_2_0_bicat_twosided_disp_cat_id_hor_comp. - intros C a₁ a₂ Fa. use disp_cell_unit_bicat_left_adjoint_equivalence. intros w x y z f g h ; cbn. pose (p := Fa w x y z f g h) ; cbn in p. rewrite !double_hor_comp_mor_id. rewrite !double_hor_comp_mor_id in p. rewrite id_two_disp_right. rewrite id_two_disp_right. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_right in p. rewrite id_two_disp_right in p. rewrite id_two_disp_right in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. rewrite two_disp_pre_whisker_f. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite two_disp_pre_whisker_f in p. rewrite id_two_disp_left in p. unfold transportb_disp_mor2 in p. rewrite transport_f_f_disp_mor2 in p. refine (_ @ !p @ _). + use transportf_disp_mor2_eq. apply idpath. + use transportf_disp_mor2_eq. apply idpath. Qed. Definition is_disp_left_adjoint_equivalence_disp_bicat_lassociator {C₁ C₂ : bicat_twosided_disp_cat_id_hor_comp} {F : C₁ --> C₂} (HF : left_adjoint_equivalence F) {a₁ : disp_bicat_lassociator C₁} {a₂ : disp_bicat_lassociator C₂} (Fa : a₁ -->[ F ] a₂) : disp_left_adjoint_equivalence HF Fa. Proof. exact (is_disp_left_adjoint_equivalence_disp_bicat_lassociator_help (F ,, HF) Fa). Qed. (** 7. Two-sided displayed categories with unitors and associators *) Definition disp_bicat_unitors_and_associator : disp_bicat bicat_twosided_disp_cat_id_hor_comp := disp_dirprod_bicat disp_bicat_lunitor (disp_dirprod_bicat disp_bicat_runitor disp_bicat_lassociator). Proposition disp_univalent_2_disp_bicat_unitors_and_associator : disp_univalent_2 disp_bicat_unitors_and_associator. Proof. use is_univalent_2_dirprod_bicat. - exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. - exact disp_univalent_2_disp_bicat_lunitor. - use is_univalent_2_dirprod_bicat. + exact is_univalent_2_1_bicat_twosided_disp_cat_id_hor_comp. + exact disp_univalent_2_disp_bicat_runitor. + exact disp_univalent_2_disp_bicat_lassociator. Qed. Definition bicat_unitors_and_associator : bicat := total_bicat disp_bicat_unitors_and_associator. Definition is_univalent_2_bicat_unitors_and_associator : is_univalent_2 bicat_unitors_and_associator. Proof. use total_is_univalent_2. - exact disp_univalent_2_disp_bicat_unitors_and_associator. - exact is_univalent_2_bicat_twosided_disp_cat_id_hor_comp. Qed. Definition is_univalent_2_1_bicat_unitors_and_associator : is_univalent_2_1 bicat_unitors_and_associator. Proof. exact (pr2 is_univalent_2_bicat_unitors_and_associator). Qed. Definition is_univalent_2_0_bicat_unitors_and_associator : is_univalent_2_0 bicat_unitors_and_associator. Proof. exact (pr1 is_univalent_2_bicat_unitors_and_associator). Qed. (** 8. Displayed bicategory of double categories *) Definition bicat_of_double_cats : bicat := fullsubbicat bicat_unitors_and_associator (λ CD, let l := pr12 CD in let r := pr122 CD in let a := pr222 CD in triangle_law l r a × pentagon_law a). Definition is_univalent_2_bicat_of_double_cats : is_univalent_2 bicat_of_double_cats. Proof. use is_univalent_2_fullsubbicat. - exact is_univalent_2_bicat_unitors_and_associator. - intros L. apply isapropdirprod. + apply isaprop_triangle_law. + apply isaprop_pentagon_law. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleCategoryBasics.v000066400000000000000000000654011451125700300267260ustar00rootroot00000000000000(********************************************************************************** Basics of double categories In this file, we define the basic notions for double categories. There are a couple of ideas behind the definition that we use: - First of all, a double category is a category with extra structure. This extra structure includes another collection of morphisms, and we use 2-sided displayed categories to represent these. - Second of all, ultimately, we use these definitions to define the bicategory of double categories. This bicategory is defined by adding structure to the bicategory of 2-sided displayed categories using the machinery of displayed bicategories. We identify which structure to add to a 2-sided displayed category in order to obtain a double category. Contents 1. Horizontal identities 2. Horizontal composition 3. Left unitor 4. Right unitor 5. Associator 6. Triangle and pentagon laws **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Local Open Scope cat. (** 1. Horizontal identities *) Definition hor_id_data {C : category} (D : twosided_disp_cat C C) : UU := ∑ (Im : ∏ (x : C), D x x), ∏ (x y : C) (f : x --> y), Im x -->[ f ][ f ] Im y. Definition double_id {C : category} {D : twosided_disp_cat C C} (I : hor_id_data D) (x : C) : D x x := pr1 I x. Definition double_id_mor {C : category} {D : twosided_disp_cat C C} (I : hor_id_data D) {x y : C} (f : x --> y) : double_id I x -->[ f ][ f ] double_id I y := pr2 I x y f. Definition hor_id_laws {C : category} {D : twosided_disp_cat C C} (I : hor_id_data D) : UU := (∏ (x : C), double_id_mor I (identity x) = id_two_disp _) × (∏ (x y z : C) (f : x --> y) (g : y --> z), double_id_mor I (f · g) = double_id_mor I f ;;2 double_id_mor I g). Proposition isaprop_hor_id_laws {C : category} {D : twosided_disp_cat C C} (I : hor_id_data D) : isaprop (hor_id_laws I). Proof. use isapropdirprod ; (repeat (use impred ; intro)) ; apply isaset_disp_mor. Qed. Definition hor_id {C : category} (D : twosided_disp_cat C C) : UU := ∑ (I : hor_id_data D), hor_id_laws I. Coercion hor_id_to_data {C : category} {D : twosided_disp_cat C C} (I : hor_id D) : hor_id_data D := pr1 I. Proposition double_id_mor_id {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (x : C) : double_id_mor I (identity x) = id_two_disp _. Proof. exact (pr12 I x). Qed. Definition double_id_mor_id_comp {C : category} {D : twosided_disp_cat C C} (I : hor_id D) {x y z : C} (f : x --> y) (g : y --> z) : double_id_mor I (f · g) = double_id_mor I f ;;2 double_id_mor I g. Proof. exact (pr22 I x y z f g). Qed. Definition make_hor_id_data {C : category} (D : twosided_disp_cat C C) (I : ∏ (x : C), D x x) (sI : ∏ (x y : C) (f : x --> y), I x -->[ f ][ f] I y) : hor_id_data D := I ,, sI. Definition make_hor_id {C : category} (D : twosided_disp_cat C C) (I : hor_id_data D) (HI : hor_id_laws I) : hor_id D := I ,, HI. (** 2. Horizontal composition *) Definition hor_comp_data {C : category} (D : twosided_disp_cat C C) : UU := ∑ (Cm : ∏ (x y z : C), D x y → D y z → D x z), ∏ (x₁ x₂ y₁ y₂ z₁ z₂ : C) (v₁ : x₁ --> x₂) (v₂ : y₁ --> y₂) (v₃ : z₁ --> z₂) (h₁ : D x₁ y₁) (h₂ : D y₁ z₁) (k₁ : D x₂ y₂) (k₂ : D y₂ z₂) (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂), Cm _ _ _ h₁ h₂ -->[ v₁ ][ v₃ ] Cm _ _ _ k₁ k₂. Definition double_hor_comp {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp_data D) {x y z : C} (h₁ : D x y) (h₂ : D y z) : D x z := pr1 Cm x y z h₁ h₂. Definition double_hor_comp_mor {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp_data D) {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) : double_hor_comp Cm h₁ h₂ -->[ v₁ ][ v₃ ] double_hor_comp Cm k₁ k₂ := pr2 Cm x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂. Definition hor_comp_laws {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp_data D) : UU := (∏ (x y z : C) (h₁ : D x y) (h₂ : D y z), double_hor_comp_mor Cm (id_two_disp h₁) (id_two_disp h₂) = id_two_disp (double_hor_comp Cm h₁ h₂)) × (∏ (x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ : C) (v₁ : x₁ --> x₂) (v₁' : x₂ --> x₃) (v₂ : y₁ --> y₂) (v₂' : y₂ --> y₃) (v₃ : z₁ --> z₂) (v₃' : z₂ --> z₃) (h₁ : D x₁ y₁) (h₂ : D y₁ z₁) (k₁ : D x₂ y₂) (k₂ : D y₂ z₂) (l₁ : D x₃ y₃) (l₂ : D y₃ z₃) (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₁' : k₁ -->[ v₁' ][ v₂' ] l₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) (s₂' : k₂ -->[ v₂' ][ v₃' ] l₂), double_hor_comp_mor Cm (s₁ ;;2 s₁') (s₂ ;;2 s₂') = double_hor_comp_mor Cm s₁ s₂ ;;2 double_hor_comp_mor Cm s₁' s₂'). Proposition isaprop_hor_comp_laws {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp_data D) : isaprop (hor_comp_laws Cm). Proof. use isapropdirprod ; (repeat (use impred ; intro)) ; apply isaset_disp_mor. Qed. Definition hor_comp {C : category} (D : twosided_disp_cat C C) : UU := ∑ (Cm : hor_comp_data D), hor_comp_laws Cm. Coercion hor_comp_to_data {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : hor_comp_data D := pr1 Cm. Proposition double_hor_comp_mor_id {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) {x y z : C} (h₁ : D x y) (h₂ : D y z) : double_hor_comp_mor Cm (id_two_disp h₁) (id_two_disp h₂) = id_two_disp (double_hor_comp Cm h₁ h₂). Proof. exact (pr12 Cm x y z h₁ h₂). Qed. Proposition double_hor_comp_mor_comp {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) {x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ : C} {v₁ : x₁ --> x₂} {v₁' : x₂ --> x₃} {v₂ : y₁ --> y₂} {v₂' : y₂ --> y₃} {v₃ : z₁ --> z₂} {v₃' : z₂ --> z₃} {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} {l₁ : D x₃ y₃} {l₂ : D y₃ z₃} (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₁' : k₁ -->[ v₁' ][ v₂' ] l₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) (s₂' : k₂ -->[ v₂' ][ v₃' ] l₂) : double_hor_comp_mor Cm (s₁ ;;2 s₁') (s₂ ;;2 s₂') = double_hor_comp_mor Cm s₁ s₂ ;;2 double_hor_comp_mor Cm s₁' s₂'. Proof. exact ((pr22 Cm) x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ v₁ v₁' v₂ v₂' v₃ v₃' h₁ h₂ k₁ k₂ l₁ l₂ s₁ s₁' s₂ s₂'). Qed. Definition make_hor_comp_data {C : category} {D : twosided_disp_cat C C} (Cm : ∏ (x y z : C), D x y → D y z → D x z) (sC : ∏ (x₁ x₂ y₁ y₂ z₁ z₂ : C) (v₁ : x₁ --> x₂) (v₂ : y₁ --> y₂) (v₃ : z₁ --> z₂) (h₁ : D x₁ y₁) (h₂ : D y₁ z₁) (k₁ : D x₂ y₂) (k₂ : D y₂ z₂) (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂), Cm _ _ _ h₁ h₂ -->[ v₁ ][ v₃ ] Cm _ _ _ k₁ k₂) : hor_comp_data D := Cm ,, sC. Definition make_hor_comp {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp_data D) (HC : hor_comp_laws Cm) : hor_comp D := Cm ,, HC. Proposition double_hor_comp_mor_transportf_disp_mor2_left {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ v₁' : x₁ --> x₂} (p : v₁ = v₁') {v₂ v₂' : y₁ --> y₂} (q : v₂ = v₂') {v₃ v₃' : z₁ --> z₂} (r : v₃ = v₃') {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₂ : h₂ -->[ v₂' ][ v₃ ] k₂) : double_hor_comp_mor Cm (transportf_disp_mor2 p q s₁) s₂ = transportf_disp_mor2 p (!r) (double_hor_comp_mor Cm s₁ (transportf_disp_mor2 (!q) r s₂)). Proof. induction p, q, r ; cbn. apply idpath. Qed. Proposition double_hor_comp_mor_transportf_disp_mor2_right_idpath {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ --> x₂} {v₂ v₂' : y₁ --> y₂} (q : v₂ = v₂') {v₃ v₃' : z₁ --> z₂} (r : v₃ = v₃') {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂' ] k₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) : double_hor_comp_mor Cm s₁ (transportf_disp_mor2 q r s₂) = transportf_disp_mor2 (idpath _) r (double_hor_comp_mor Cm (transportf_disp_mor2 (idpath _) (!q) s₁) s₂). Proof. induction q, r ; cbn. apply idpath. Qed. Proposition double_hor_comp_mor_transportf_disp_mor2_right {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ v₁' : x₁ --> x₂} (p : v₁' = v₁) {v₂ v₂' : y₁ --> y₂} (q : v₂ = v₂') {v₃ v₃' : z₁ --> z₂} (r : v₃ = v₃') {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} (s₁ : h₁ -->[ v₁' ][ v₂' ] k₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) : double_hor_comp_mor Cm s₁ (transportf_disp_mor2 q r s₂) = transportf_disp_mor2 (!p) r (double_hor_comp_mor Cm (transportf_disp_mor2 p (!q) s₁) s₂). Proof. induction p, q, r ; cbn. apply idpath. Qed. Proposition double_hor_comp_transport_mor {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} {x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ : C} {v₁ : x₁ --> x₂} {v₁' : x₂ --> x₃} {v₂ : y₁ --> y₂} {v₂' : y₂ --> y₃} {v₂'' : y₂ --> y₃} {v₃ : z₁ --> z₂} {v₃' : z₂ --> z₃} {u₁ : x₁ --> x₃} {u₂ : y₁ --> y₃} {u₃ : z₁ --> z₃} {h₁ : D x₁ y₁} {h₂ : D y₁ z₁} {k₁ : D x₂ y₂} {k₂ : D y₂ z₂} {l₁ : D x₃ y₃} {l₂ : D y₃ z₃} (s₁ : h₁ -->[ v₁ ][ v₂ ] k₁) (s₁' : k₁ -->[ v₁' ][ v₂'] l₁) (s₂ : h₂ -->[ v₂ ][ v₃ ] k₂) (s₂' : k₂ -->[ v₂'' ][ v₃' ] l₂) (p : v₁ · v₁' = u₁) (q : v₂ · v₂' = u₂) (q' : v₂ · v₂'' = u₂) (s : v₂' = v₂'') (r : v₃ · v₃' = u₃) : double_hor_comp_mor Cm (transportf_disp_mor2 p q (s₁ ;;2 s₁')) (transportf_disp_mor2 q' r (s₂ ;;2 s₂')) = transportf_disp_mor2 p r (double_hor_comp_mor Cm s₁ s₂ ;;2 double_hor_comp_mor Cm (transportf_disp_mor2 (idpath _) s s₁') s₂'). Proof. induction p, q, s, r. assert (q' = idpath _) as H. { apply homset_property. } rewrite H. cbn. rewrite double_hor_comp_mor_comp. apply idpath. Qed. (** 3. Left unitor *) Definition double_lunitor_data {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : UU := ∏ (x y : C) (h : D x y), iso_twosided_disp (identity_z_iso x) (identity_z_iso y) (double_hor_comp Cm (double_id I x) h) h. Proposition isaset_double_lunitor_data {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : isaset (double_lunitor_data I Cm). Proof. use impred_isaset ; intro x. use impred_isaset ; intro y. use impred_isaset ; intro h. apply isaset_iso_twosided_disp. Qed. Definition double_lunitor_laws {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_lunitor_data I Cm) : UU := ∏ (x₁ x₂ y₁ y₂ : C) (h₁ : D x₁ y₁) (h₂ : D x₂ y₂) (v₁ : x₁ --> x₂) (v₂ : y₁ --> y₂) (τ : h₁ -->[ v₁ ][ v₂ ] h₂), transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (l _ _ h₁ ;;2 τ) = double_hor_comp_mor Cm (double_id_mor I _) τ ;;2 l _ _ h₂. Proposition isaprop_double_lunitor_laws {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_lunitor_data I Cm) : isaprop (double_lunitor_laws l). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_cat_lunitor {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : UU := ∑ (l : double_lunitor_data I Cm), double_lunitor_laws l. Proposition isaset_double_cat_lunitor {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : isaset (double_cat_lunitor I Cm). Proof. use isaset_total2. - apply isaset_double_lunitor_data. - intro. apply isasetaprop. apply isaprop_double_lunitor_laws. Qed. Definition make_double_lunitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_lunitor_data I Cm) (Hl : double_lunitor_laws l) : double_cat_lunitor I Cm := l ,, Hl. Definition double_lunitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_cat_lunitor I Cm) {x y : C} (h : D x y) : double_hor_comp Cm (double_id I x) h -->[ identity x ][ identity y ] h := pr1 l x y h. Proposition double_lunitor_nat {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_cat_lunitor I Cm) {x₁ x₂ y₁ y₂ : C} {h₁ : D x₁ y₁} {h₂ : D x₂ y₂} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} (τ : h₁ -->[ v₁ ][ v₂ ] h₂) : transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (double_lunitor l h₁ ;;2 τ) = double_hor_comp_mor Cm (double_id_mor I _) τ ;;2 double_lunitor l h₂. Proof. exact (pr2 l x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ τ). Qed. (** 4. Right unitor *) Definition double_runitor_data {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : UU := ∏ (x y : C) (h : D x y), iso_twosided_disp (identity_z_iso x) (identity_z_iso y) (double_hor_comp Cm h (double_id I y)) h. Proposition isaset_double_runitor_data {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : isaset (double_runitor_data I Cm). Proof. use impred_isaset ; intro x. use impred_isaset ; intro y. use impred_isaset ; intro h. apply isaset_iso_twosided_disp. Qed. Definition double_runitor_laws {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (r : double_runitor_data I Cm) : UU := ∏ (x₁ x₂ y₁ y₂ : C) (h₁ : D x₁ y₁) (h₂ : D x₂ y₂) (v₁ : x₁ --> x₂) (v₂ : y₁ --> y₂) (τ : h₁ -->[ v₁ ][ v₂ ] h₂), transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (r _ _ h₁ ;;2 τ) = double_hor_comp_mor Cm τ (double_id_mor I _) ;;2 r _ _ h₂. Proposition isaprop_double_runitor_laws {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (r : double_runitor_data I Cm) : isaprop (double_runitor_laws r). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_cat_runitor {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : UU := ∑ (r : double_runitor_data I Cm), double_runitor_laws r. Proposition isaset_double_cat_runitor {C : category} {D : twosided_disp_cat C C} (I : hor_id D) (Cm : hor_comp D) : isaset (double_cat_runitor I Cm). Proof. use isaset_total2. - apply isaset_double_runitor_data. - intro. apply isasetaprop. apply isaprop_double_runitor_laws. Qed. Definition make_double_runitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_runitor_data I Cm) (Hl : double_runitor_laws l) : double_cat_runitor I Cm := l ,, Hl. Definition double_runitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (r : double_cat_runitor I Cm) {x y : C} (h : D x y) : double_hor_comp Cm h (double_id I y) -->[ identity x ][ identity y ] h := pr1 r x y h. Proposition double_runitor_nat {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (r : double_cat_runitor I Cm) {x₁ x₂ y₁ y₂ : C} {h₁ : D x₁ y₁} {h₂ : D x₂ y₂} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} (τ : h₁ -->[ v₁ ][ v₂ ] h₂) : transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (double_runitor r h₁ ;;2 τ) = double_hor_comp_mor Cm τ (double_id_mor I _) ;;2 double_runitor r h₂. Proof. exact (pr2 r x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ τ). Qed. (** 5. Associator *) Definition double_associator_data {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : UU := ∏ (w x y z : C) (h₁ : D w x) (h₂ : D x y) (h₃ : D y z), iso_twosided_disp (identity_z_iso w) (identity_z_iso z) (double_hor_comp Cm h₁ (double_hor_comp Cm h₂ h₃)) (double_hor_comp Cm (double_hor_comp Cm h₁ h₂) h₃). Proposition isaset_double_associator_data {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : isaset (double_associator_data Cm). Proof. repeat (use impred_isaset ; intro). apply isaset_iso_twosided_disp. Qed. Definition double_associator_laws {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_associator_data Cm) : UU := ∏ (w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ : C) (h₁ : D w₁ x₁) (h₂ : D w₂ x₂) (j₁ : D x₁ y₁) (j₂ : D x₂ y₂) (k₁ : D y₁ z₁) (k₂ : D y₂ z₂) (vw : w₁ --> w₂) (vx : x₁ --> x₂) (vy : y₁ --> y₂) (vz : z₁ --> z₂) (τ₁ : h₁ -->[ vw ][ vx ] h₂) (τ₂ : j₁ -->[ vx ][ vy ] j₂) (τ₃ : k₁ -->[ vy ][ vz ] k₂), transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (a _ _ _ _ h₁ j₁ k₁ ;;2 double_hor_comp_mor Cm (double_hor_comp_mor Cm τ₁ τ₂) τ₃) = double_hor_comp_mor Cm τ₁ (double_hor_comp_mor Cm τ₂ τ₃) ;;2 a _ _ _ _ h₂ j₂ k₂. Proposition isaprop_double_associator_laws {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_associator_data Cm) : isaprop (double_associator_laws a). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_cat_associator {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : UU := ∑ (a : double_associator_data Cm), double_associator_laws a. Proposition isaset_double_cat_associator {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : isaset (double_cat_associator Cm). Proof. use isaset_total2. - apply isaset_double_associator_data. - intro. apply isasetaprop. apply isaprop_double_associator_laws. Qed. Definition make_double_associator {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_associator_data Cm) (Ha : double_associator_laws a) : double_cat_associator Cm := a ,, Ha. Definition double_associator {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_cat_associator Cm) {w x y z : C} (h₁ : D w x) (h₂ : D x y) (h₃ : D y z) : double_hor_comp Cm h₁ (double_hor_comp Cm h₂ h₃) -->[ identity w ][ identity z ] double_hor_comp Cm (double_hor_comp Cm h₁ h₂) h₃ := pr1 a w x y z h₁ h₂ h₃. Proposition double_associator_nat {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_cat_associator Cm) {w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ : C} {h₁ : D w₁ x₁} {h₂ : D w₂ x₂} {j₁ : D x₁ y₁} {j₂ : D x₂ y₂} {k₁ : D y₁ z₁} {k₂ : D y₂ z₂} {vw : w₁ --> w₂} {vx : x₁ --> x₂} {vy : y₁ --> y₂} {vz : z₁ --> z₂} (τ₁ : h₁ -->[ vw ][ vx ] h₂) (τ₂ : j₁ -->[ vx ][ vy ] j₂) (τ₃ : k₁ -->[ vy ][ vz ] k₂) : transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (double_associator a h₁ j₁ k₁ ;;2 double_hor_comp_mor Cm (double_hor_comp_mor Cm τ₁ τ₂) τ₃) = double_hor_comp_mor Cm τ₁ (double_hor_comp_mor Cm τ₂ τ₃) ;;2 double_associator a h₂ j₂ k₂. Proof. apply (pr2 a). Qed. (** 6. Triangle and pentagon laws *) Definition triangle_law {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_cat_lunitor I Cm) (r : double_cat_runitor I Cm) (a : double_cat_associator Cm) : UU := ∏ (x y z : C) (h : D x y) (k : D y z), double_associator a h _ k ;;2 double_hor_comp_mor Cm (double_runitor r h) (id_two_disp _) = transportb_disp_mor2 (id_left _) (id_left _) (double_hor_comp_mor Cm (id_two_disp _) (double_lunitor l k)). Proposition isaprop_triangle_law {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_cat_lunitor I Cm) (r : double_cat_runitor I Cm) (a : double_cat_associator Cm) : isaprop (triangle_law l r a). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition pentagon_law {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_cat_associator Cm) : UU := ∏ (v w x y z : C) (h₁ : D v w) (h₂ : D w x) (h₃ : D x y) (h₄ : D y z), transportb_disp_mor2 (id_right _) (id_right _) (double_associator a h₁ h₂ (double_hor_comp Cm h₃ h₄) ;;2 double_associator a (double_hor_comp Cm h₁ h₂) h₃ h₄) = double_hor_comp_mor Cm (id_two_disp _) (double_associator a h₂ h₃ h₄) ;;2 double_associator a h₁ (double_hor_comp Cm h₂ h₃) h₄ ;;2 double_hor_comp_mor Cm (double_associator a h₁ h₂ h₃) (id_two_disp _). Proposition isaprop_pentagon_law {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_cat_associator Cm) : isaprop (pentagon_law a). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleCats.v000066400000000000000000001022331451125700300247110ustar00rootroot00000000000000(********************************************************************************** Double categories In this file, we provide an interface for the bicategory of double categories. More specifically, we give definitions and notations for accessors of double categories, double functors, and double transformations. We also give builders for each of them. Contents 1. Double categories 2. Accessors for double categories 2.1. The vertical category 2.2. Horizontal morphisms 2.3. Squares 2.4. Functoriality of horizontal identities 2.5. Functoriality of horizontal composition 2.6. Left unitor 2.7. Right unitor 2.8. Associator 2.9. Triangle and pentagon equations 3. Builder for double categories 4. Lax functors for double categories 5. Accessors for lax functors 6. Builder for lax functors 7. Strong double functors 8. Double transformations 9. Accessors for double transformations 10. Builder for double transformations **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedNatTrans. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfTwoSidedDispCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleTransformation. Require Import UniMath.Bicategories.DoubleCategories.BicatOfDoubleCats. Local Open Scope cat. Declare Scope double_cat. Local Open Scope double_cat. (** 1. Double categories *) Definition double_cat : UU := ob bicat_of_double_cats. (** 2. Accessors for double categories *) (** 2.1. The vertical category *) Definition ob_double_cat (C : double_cat) : category := pr11 (pr111 C). Coercion ob_double_cat : double_cat >-> category. Definition ver_mor_double_cat {C : double_cat} (x y : C) : UU := x --> y. Notation "x -->v y" := (ver_mor_double_cat x y) (at level 55) : double_cat. Definition identity_v {C : double_cat} (x : C) : x -->v x := identity _. Definition ver_comp_double_cat {C : double_cat} {x y z : C} (f : x -->v y) (g : y -->v z) : x -->v z := f · g. Notation "f ·v g" := (ver_comp_double_cat f g) (at level 60) : double_cat. Proposition id_v_left {C : double_cat} {x y : C} (f : x -->v y) : identity_v x · f = f. Proof. apply id_left. Defined. Proposition id_v_right {C : double_cat} {x y : C} (f : x -->v y) : f ·v identity_v y = f. Proof. apply id_right. Defined. Proposition assocl_v {C : double_cat} {w x y z : C} (f : w -->v x) (g : x -->v y) (h : y -->v z) : f ·v (g ·v h) = (f ·v g) ·v h. Proof. apply assoc. Defined. Proposition assocr_v {C : double_cat} {w x y z : C} (f : w -->v x) (g : x -->v y) (h : y -->v z) : (f ·v g) ·v h = f ·v (g ·v h). Proof. apply assoc'. Defined. Proposition isaset_ver_mor {C : double_cat} (x y : C) : isaset (x -->v y). Proof. apply homset_property. Qed. (** 2.2. Horizontal morphisms *) Definition hor_mor (C : double_cat) : twosided_disp_cat C C := pr12 (pr111 C). Notation "x -->h y" := (hor_mor _ x y) (at level 55) : double_cat. Proposition is_univalent_twosided_disp_cat_hor_mor (C : double_cat) : is_univalent_twosided_disp_cat (hor_mor C). Proof. exact (pr22 (pr111 C)). Qed. Definition hor_id_double_cat (C : double_cat) : hor_id (hor_mor C) := pr1 (pr211 C). Definition identity_h {C : double_cat} (x : C) : x -->h x := pr111 (pr211 C) x. Definition hor_comp_double_cat (C : double_cat) : hor_comp (hor_mor C) := pr2 (pr211 C). Definition hor_mor_comp_double_cat {C : double_cat} {x y z : C} (f : x -->h y) (g : y -->h z) : x -->h z := pr112 (pr211 C) x y z f g. Notation "f ·h g" := (hor_mor_comp_double_cat f g) (at level 60) : double_cat. (** 2.3. Squares *) Definition square {C : double_cat} {x₁ x₂ y₁ y₂ : C} (v₁ : x₁ -->v y₁) (v₂ : x₂ -->v y₂) (h₁ : x₁ -->h x₂) (h₂ : y₁ -->h y₂) : UU := h₁ -->[ v₁ ][ v₂ ] h₂. Definition id_v_square {C : double_cat} {x y : C} (h : x -->h y) : square (identity_v x) (identity_v y) h h := id_two_disp _. Definition comp_v_square {C : double_cat} {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ -->v y₁} {v₁' : y₁ --> z₁} {v₂ : x₂ -->v y₂} {v₂' : y₂ --> z₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} {h₃ : z₁ -->h z₂} (s₁ : square v₁ v₂ h₁ h₂) (s₂ : square v₁' v₂' h₂ h₃) : square (v₁ ·v v₁') (v₂ ·v v₂') h₁ h₃ := s₁ ;;2 s₂. Notation "s₁ ⋆v s₂" := (comp_v_square s₁ s₂) (at level 40, left associativity) : double_cat. Definition transportf_square {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ v₁' : x₁ -->v y₁} {v₂ v₂' : x₂ -->v y₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} (s₁ : square v₁ v₂ h₁ h₂) (p : v₁ = v₁') (q : v₂ = v₂') : square v₁' v₂' h₁ h₂ := transportf_disp_mor2 p q s₁. Definition transportb_square {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ v₁' : x₁ -->v y₁} {v₂ v₂' : x₂ -->v y₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} (s₁ : square v₁' v₂' h₁ h₂) (p : v₁ = v₁') (q : v₂ = v₂') : square v₁ v₂ h₁ h₂ := transportb_disp_mor2 p q s₁. Proposition square_id_left_v {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ : x₁ -->v y₁} {v₂ : x₂ -->v y₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} (s : square v₁ v₂ h₁ h₂) : id_v_square h₁ ⋆v s = transportb_square s (id_left _) (id_left _). Proof. apply id_two_disp_left. Defined. Proposition square_id_right_v {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ : x₁ -->v y₁} {v₂ : x₂ -->v y₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} (s : square v₁ v₂ h₁ h₂) : s ⋆v id_v_square h₂ = transportb_square s (id_right _) (id_right _). Proof. apply id_two_disp_right. Defined. Proposition square_assoc_v {C : double_cat} {w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : w₁ -->v x₁} {v₁' : x₁ -->v y₁} {v₁'' : y₁ -->v z₁} {v₂ : w₂ -->v x₂} {v₂' : x₂ -->v y₂} {v₂'' : y₂ -->v z₂} {h₁ : w₁ -->h w₂} {h₂ : x₁ -->h x₂} {h₃ : y₁ -->h y₂} {h₄ : z₁ -->h z₂} (s₁ : square v₁ v₂ h₁ h₂) (s₂ : square v₁' v₂' h₂ h₃) (s₃ : square v₁'' v₂'' h₃ h₄) : s₁ ⋆v (s₂ ⋆v s₃) = transportb_square ((s₁ ⋆v s₂) ⋆v s₃) (assoc _ _ _) (assoc _ _ _). Proof. exact (assoc_two_disp s₁ s₂ s₃). Defined. (** 2.4. Functoriality of horizontal identities *) Definition id_h_square {C : double_cat} {x y : C} (v : x -->v y) : square v v (identity_h x) (identity_h y) := pr211 (pr211 C) x y v. Proposition id_h_square_id {C : double_cat} (x : C) : id_h_square (identity_v x) = id_v_square (identity_h x). Proof. exact (pr121 (pr211 C) x). Defined. Proposition id_h_square_comp {C : double_cat} {x y z : C} (v₁ : x -->v y) (v₂ : y -->v z) : id_h_square (v₁ ·v v₂) = id_h_square v₁ ⋆v id_h_square v₂. Proof. exact (pr221 (pr211 C) x y z v₁ v₂). Defined. (** 2.5. Functoriality of horizontal composition *) Definition comp_h_square {C : double_cat} {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ -->v x₂} {v₂ : y₁ -->v y₂} {v₃ : z₁ -->v z₂} {h₁ : x₁ -->h y₁} {h₂ : y₁ -->h z₁} {k₁ : x₂ -->h y₂} {k₂ : y₂ -->h z₂} (s₁ : square v₁ v₂ h₁ k₁) (s₂ : square v₂ v₃ h₂ k₂) : square v₁ v₃ (h₁ ·h h₂) (k₁ ·h k₂) := pr212 (pr211 C) x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂. Notation "s₁ ⋆h s₂" := (comp_h_square s₁ s₂) (at level 40, left associativity) : double_cat. Proposition comp_h_square_id {C : double_cat} {x y z : C} (h₁ : x -->h y) (h₂ : y -->h z) : id_v_square h₁ ⋆h id_v_square h₂ = id_v_square (h₁ ·h h₂). Proof. exact (pr122 (pr211 C) x y z h₁ h₂). Defined. Proposition comp_h_square_comp {C : double_cat} {x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ : C} {v₁ : x₁ -->v x₂} {v₁' : x₂ -->v x₃} {v₂ : y₁ -->v y₂} {v₂' : y₂ -->v y₃} {v₃ : z₁ -->v z₂} {v₃' : z₂ -->v z₃} {h₁ : x₁ -->h y₁} {h₂ : y₁ -->h z₁} {k₁ : x₂ -->h y₂} {k₂ : y₂ -->h z₂} {l₁ : x₃ -->h y₃} {l₂ : y₃ -->h z₃} (s₁ : square v₁ v₂ h₁ k₁) (s₁' : square v₁' v₂' k₁ l₁) (s₂ : square v₂ v₃ h₂ k₂) (s₂' : square v₂' v₃' k₂ l₂) : (s₁ ⋆v s₁') ⋆h (s₂ ⋆v s₂') = (s₁ ⋆h s₂) ⋆v (s₁' ⋆h s₂'). Proof. exact (pr222 (pr211 C) x₁ x₂ x₃ y₁ y₂ y₃ z₁ z₂ z₃ v₁ v₁' v₂ v₂' v₃ v₃' h₁ h₂ k₁ k₂ l₁ l₂ s₁ s₁' s₂ s₂'). Defined. (** 2.6. Left unitor *) Definition double_cat_double_lunitor (C : double_cat) : double_cat_lunitor (hor_id_double_cat C) (hor_comp_double_cat C) := pr121 C. Definition lunitor_h {C : double_cat} {x y : C} (f : x -->h y) : square (identity_v x) (identity_v y) (identity_h x ·h f) f := pr1 (pr1 (pr121 C) x y f). Definition linvunitor_h {C : double_cat} {x y : C} (f : x -->h y) : square (identity_v x) (identity_v y) f (identity_h x ·h f) := pr12 (pr1 (pr121 C) x y f). Proposition lunitor_linvunitor_h {C : double_cat} {x y : C} (f : x -->h y) : lunitor_h f ⋆v linvunitor_h f = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr122 (pr1 (pr121 C) x y f)). Defined. Proposition linvunitor_lunitor_h {C : double_cat} {x y : C} (f : x -->h y) : linvunitor_h f ⋆v lunitor_h f = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr222 (pr1 (pr121 C) x y f)). Defined. Proposition lunitor_square {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ : x₁ -->v x₂} {v₂ : y₁ -->v y₂} {h₁ : x₁ -->h y₁} {h₂ : x₂ -->h y₂} (s : square v₁ v₂ h₁ h₂) : (id_h_square _ ⋆h s) ⋆v lunitor_h h₂ = transportb_square (lunitor_h h₁ ⋆v s) (id_v_right _ @ !(id_v_left _)) (id_v_right _ @ !(id_v_left _)). Proof. exact (!(pr2 (pr121 C) x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ s)). Defined. (** 2.7. Right unitor *) Definition double_cat_double_runitor (C : double_cat) : double_cat_runitor (hor_id_double_cat C) (hor_comp_double_cat C) := pr1 (pr221 C). Definition runitor_h {C : double_cat} {x y : C} (f : x -->h y) : square (identity_v x) (identity_v y) (f ·h identity_h y) f := pr1 (pr11 (pr221 C) x y f). Definition rinvunitor_h {C : double_cat} {x y : C} (f : x -->h y) : square (identity_v x) (identity_v y) f (f ·h identity_h y) := pr12 (pr11 (pr221 C) x y f). Proposition runitor_rinvunitor_h {C : double_cat} {x y : C} (f : x -->h y) : runitor_h f ⋆v rinvunitor_h f = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr122 (pr11 (pr221 C) x y f)). Defined. Proposition rinvunitor_runitor_h {C : double_cat} {x y : C} (f : x -->h y) : rinvunitor_h f ⋆v runitor_h f = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr222 (pr11 (pr221 C) x y f)). Defined. Proposition runitor_square {C : double_cat} {x₁ x₂ y₁ y₂ : C} {v₁ : x₁ -->v x₂} {v₂ : y₁ -->v y₂} {h₁ : x₁ -->h y₁} {h₂ : x₂ -->h y₂} (s : square v₁ v₂ h₁ h₂) : (s ⋆h id_h_square _) ⋆v runitor_h h₂ = transportb_square (runitor_h h₁ ⋆v s) (id_v_right _ @ !(id_v_left _)) (id_v_right _ @ !(id_v_left _)). Proof. exact (!(pr21 (pr221 C) x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ s)). Defined. (** 2.8. Associator *) Definition double_cat_double_associator (C : double_cat) : double_cat_associator (hor_comp_double_cat C) := pr2 (pr221 C). Definition lassociator_h {C : double_cat} {w x y z : C} (f : w -->h x) (g : x -->h y) (h : y -->h z) : square (identity_v w) (identity_v z) (f ·h (g ·h h)) ((f ·h g) ·h h) := pr1 (pr12 (pr221 C) w x y z f g h). Definition rassociator_h {C : double_cat} {w x y z : C} (f : w -->h x) (g : x -->h y) (h : y -->h z) : square (identity_v w) (identity_v z) ((f ·h g) ·h h) (f ·h (g ·h h)) := pr12 (pr12 (pr221 C) w x y z f g h). Proposition lassociator_rassociator_h {C : double_cat} {w x y z : C} (f : w -->h x) (g : x -->h y) (h : y -->h z) : lassociator_h f g h ⋆v rassociator_h f g h = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr122 (pr12 (pr221 C) w x y z f g h)). Defined. Proposition rassociator_lassociator_h {C : double_cat} {w x y z : C} (f : w -->h x) (g : x -->h y) (h : y -->h z) : rassociator_h f g h ⋆v lassociator_h f g h = transportb_square (id_v_square _) (id_v_left _) (id_v_left _). Proof. exact (pr222 (pr12 (pr221 C) w x y z f g h)). Defined. Proposition lassociator_h_square {C : double_cat} {w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ : C} {vw : w₁ -->v w₂} {vx : x₁ -->v x₂} {vy : y₁ -->v y₂} {vz : z₁ -->v z₂} {h₁ : w₁ -->h x₁} {h₂ : w₂ -->h x₂} {j₁ : x₁ -->h y₁} {j₂ : x₂ -->h y₂} {k₁ : y₁ -->h z₁} {k₂ : y₂ -->h z₂} (s₁ : square vw vx h₁ h₂) (s₂ : square vx vy j₁ j₂) (s₃ : square vy vz k₁ k₂) : (s₁ ⋆h (s₂ ⋆h s₃)) ⋆v lassociator_h h₂ j₂ k₂ = transportb_square (lassociator_h h₁ j₁ k₁ ⋆v ((s₁ ⋆h s₂) ⋆h s₃)) (id_v_right _ @ !(id_v_left _)) (id_v_right _ @ !(id_v_left _)). Proof. exact (!(pr22 (pr221 C) w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ h₁ h₂ j₁ j₂ k₁ k₂ vw vx vy vz s₁ s₂ s₃)). Defined. (** 2.9. Triangle and pentagon equations *) Proposition double_triangle {C : double_cat} {x y z : C} (h : x -->h y) (k : y -->h z) : lassociator_h h _ k ⋆v (runitor_h h ⋆h id_v_square _) = transportb_square (id_v_square h ⋆h lunitor_h k) (id_v_left _) (id_v_left _). Proof. exact (pr12 C x y z h k). Qed. Proposition double_pentagon {C : double_cat} {v w x y z : C} (h₁ : v -->h w) (h₂ : w -->h x) (h₃ : x -->h y) (h₄ : y -->h z) : transportb_square (lassociator_h h₁ h₂ (h₃ ·h h₄) ⋆v lassociator_h (h₁ ·h h₂) h₃ h₄) (id_right _) (id_right _) = (id_v_square h₁ ⋆h lassociator_h h₂ h₃ h₄) ⋆v lassociator_h h₁ (h₂ ·h h₃) h₄ ⋆v (lassociator_h h₁ h₂ h₃ ⋆h id_v_square h₄). Proof. exact (pr22 C v w x y z h₁ h₂ h₃ h₄). Qed. (** 3. Builder for double categories *) Definition make_double_cat (C : category) (D : twosided_disp_cat C C) (I : hor_id D) (Cm : hor_comp D) (l : double_cat_lunitor I Cm) (r : double_cat_runitor I Cm) (a : double_cat_associator Cm) (tr : triangle_law l r a) (pe : pentagon_law a) (HC : is_univalent C) (HD : is_univalent_twosided_disp_cat D) : double_cat. Proof. simple refine ((((_ ,, _) ,, _) ,, _) ,, _). - exact (C ,, HC). - exact (D ,, HD). - exact (I ,, Cm). - exact (l ,, r ,, a). - exact (tr ,, pe). Defined. (** 4. Lax functors for double categories *) Definition lax_double_functor (C₁ C₂ : double_cat) : UU := C₁ --> C₂. Definition id_lax_double_functor (C : double_cat) : lax_double_functor C C := identity _. Definition comp_lax_double_functor {C₁ C₂ C₃ : double_cat} (F : lax_double_functor C₁ C₂) (G : lax_double_functor C₂ C₃) : lax_double_functor C₁ C₃ := F · G. (** 5. Accessors for lax functors *) Definition lax_double_functor_ver {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : C₁ ⟶ C₂ := pr1 (pr111 F). Coercion lax_double_functor_ver : lax_double_functor >-> functor. Definition lax_double_functor_ver_mor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y : C₁} (f : x -->v y) : F x -->v F y := pr211 (pr111 F) x y f. Notation "'#v' F f" := (lax_double_functor_ver_mor F f) (at level 10, F at next level, f at next level) : double_cat. Proposition lax_double_functor_id_v {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) (x : C₁) : #v F (identity_v x) = identity_v _. Proof. apply functor_id. Defined. Proposition lax_double_functor_comp_v {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y z : C₁} (f : x -->v y) (g : y -->v z) : #v F (f ·v g) = #v F f ·v #v F g. Proof. apply functor_comp. Defined. Definition lax_double_functor_hor_mor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : twosided_disp_functor F F (hor_mor C₁) (hor_mor C₂) := pr2 (pr111 F). Notation "'#h' F f" := (lax_double_functor_hor_mor F _ _ f) (at level 10, F at next level, f at next level) : double_cat. Notation "'#s' F s" := (#2 (lax_double_functor_hor_mor F) s) (at level 10, F at next level, s at next level) : double_cat. Proposition lax_double_functor_id_square {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y : C₁} (h : x -->h y) : #s F (id_v_square h) = transportb_square (id_v_square _) (lax_double_functor_id_v _ _) (lax_double_functor_id_v _ _). Proof. exact (twosided_disp_functor_id _ _ _ _ (lax_double_functor_hor_mor F) h). Qed. Proposition lax_double_functor_comp_v_square {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x₁ x₂ y₁ y₂ z₁ z₂ : C₁} {v₁ : x₁ -->v y₁} {v₁' : y₁ --> z₁} {v₂ : x₂ -->v y₂} {v₂' : y₂ --> z₂} {h₁ : x₁ -->h x₂} {h₂ : y₁ -->h y₂} {h₃ : z₁ -->h z₂} (s₁ : square v₁ v₂ h₁ h₂) (s₂ : square v₁' v₂' h₂ h₃) : #s F (s₁ ⋆v s₂) = transportb_square (#s F s₁ ⋆v #s F s₂) (lax_double_functor_comp_v _ _ _) (lax_double_functor_comp_v _ _ _). Proof. apply (twosided_disp_functor_comp _ _ _ _ (lax_double_functor_hor_mor F)). Qed. Definition lax_double_functor_hor_id {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : double_functor_hor_id (lax_double_functor_hor_mor F) (hor_id_double_cat C₁) (hor_id_double_cat C₂) := pr1 (pr211 F). Definition lax_double_functor_id_h {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) (x : C₁) : square (identity_v _) (identity_v (F x)) (identity_h _) (#h F (identity_h _)). Proof. exact (pr11 (pr211 F) x). Defined. Proposition lax_double_functor_id_h_mor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y : C₁} (f : x -->v y) : id_h_square (#v F f) ⋆v lax_double_functor_id_h F y = transportb_square (lax_double_functor_id_h F x ⋆v #s F (id_h_square f)) (id_v_right _ @ !(id_v_left _)) (id_v_right _ @ !(id_v_left _)). Proof. exact (pr21 (pr211 F) x y f). Qed. Definition lax_double_functor_hor_comp {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : double_functor_hor_comp (lax_double_functor_hor_mor F) (hor_comp_double_cat C₁) (hor_comp_double_cat C₂) := pr2 (pr211 F). Definition lax_double_functor_comp_h {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y z : C₁} (h : x -->h y) (k : y -->h z) : square (identity _) (identity _) (#h F h ·h #h F k) (#h F (h ·h k)) := pr12 (pr211 F) x y z h k. Proposition lax_double_functor_comp_h_mor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x₁ x₂ y₁ y₂ z₁ z₂ : C₁} {vx : x₁ -->v x₂} {vy : y₁ -->v y₂} {vz : z₁ -->v z₂} {h₁ : x₁ -->h y₁} {h₂ : x₂ -->h y₂} {k₁ : y₁ -->h z₁} {k₂ : y₂ -->h z₂} (sh : square vx vy h₁ h₂) (sk : square vy vz k₁ k₂) : (#s F sh ⋆h #s F sk) ⋆v lax_double_functor_comp_h F h₂ k₂ = transportb_square (lax_double_functor_comp_h F h₁ k₁ ⋆v #s F (sh ⋆h sk)) (id_v_right _ @ !(id_v_left _)) (id_v_right _ @ !(id_v_left _)). Proof. exact (pr22 (pr211 F) x₁ x₂ y₁ y₂ z₁ z₂ vx vy vz h₁ h₂ k₁ k₂ sh sk). Qed. Proposition lax_double_functor_lunitor_h {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y : C₁} (f : x -->h y) : lunitor_h (#h F f) = transportf_square ((lax_double_functor_id_h F _ ⋆h id_v_square _) ⋆v lax_double_functor_comp_h F _ _ ⋆v #s F (lunitor_h f)) (assocr_v _ _ _ @ id_v_left _ @ id_v_left _ @ lax_double_functor_id_v _ _) (assocr_v _ _ _ @ id_v_left _ @ id_v_left _ @ lax_double_functor_id_v _ _). Proof. exact (pr121 F x y f). Qed. Proposition lax_double_functor_runitor_h {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {x y : C₁} (f : x -->h y) : runitor_h (#h F f) = transportf_square ((id_v_square _ ⋆h lax_double_functor_id_h F _) ⋆v lax_double_functor_comp_h F _ _ ⋆v #s F (runitor_h f)) (assocr_v _ _ _ @ id_v_left _ @ id_v_left _ @ lax_double_functor_id_v _ _) (assocr_v _ _ _ @ id_v_left _ @ id_v_left _ @ lax_double_functor_id_v _ _). Proof. exact (pr1 (pr221 F) x y f). Qed. Proposition lax_double_functor_lassociator_h {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) {w x y z : C₁} (f : w -->h x) (g : x -->h y) (h : y -->h z) : lassociator_h (#h F f) (#h F g) (#h F h) ⋆v (lax_double_functor_comp_h F f g ⋆h id_v_square _) ⋆v lax_double_functor_comp_h F (f ·h g) h = transportf_square ((id_v_square _ ⋆h lax_double_functor_comp_h F g h) ⋆v lax_double_functor_comp_h F f (g ·h h) ⋆v #s F (lassociator_h f g h)) (maponpaths _ (lax_double_functor_id_v _ _)) (maponpaths _ (lax_double_functor_id_v _ _)). Proof. exact (pr2 (pr221 F) w x y z f g h). Qed. (** 6. Builder for lax functors *) Definition make_lax_double_functor {C₁ C₂ : double_cat} (F : C₁ ⟶ C₂) (FF : twosided_disp_functor F F (hor_mor C₁) (hor_mor C₂)) (FI : double_functor_hor_id FF (hor_id_double_cat C₁) (hor_id_double_cat C₂)) (FC : double_functor_hor_comp FF (hor_comp_double_cat C₁) (hor_comp_double_cat C₂)) (Fl : double_functor_lunitor (double_cat_double_lunitor C₁) (double_cat_double_lunitor C₂) FI FC) (Fr : double_functor_runitor (double_cat_double_runitor C₁) (double_cat_double_runitor C₂) FI FC) (Fa : double_functor_associator (double_cat_double_associator C₁) (double_cat_double_associator C₂) FC) : lax_double_functor C₁ C₂. Proof. simple refine ((((F ,, FF) ,, _) ,, _) ,, tt). - split ; cbn. + exact FI. + exact FC. - repeat split ; cbn. + exact Fl. + exact Fr. + exact Fa. Defined. (** 7. Strong double functors *) Definition is_strong_double_functor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : UU := (∏ (x : C₁), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_id_h F x)) × (∏ (x y z : C₁) (h : x -->h y) (k : y -->h z), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_comp_h F h k)). Proposition isaprop_is_strong_double_functor {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : isaprop (is_strong_double_functor F). Proof. use isapropdirprod ; repeat (use impred ; intro) ; apply isaprop_is_iso_twosided_disp. Qed. Definition is_iso_strong_double_functor_id_h {C₁ C₂ : double_cat} {F : lax_double_functor C₁ C₂} (HF : is_strong_double_functor F) (x : C₁) : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_id_h F x) := pr1 HF x. Definition is_iso_strong_double_functor_comp_h {C₁ C₂ : double_cat} {F : lax_double_functor C₁ C₂} (HF : is_strong_double_functor F) {x y z : C₁} (h : x -->h y) (k : y -->h z) : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_comp_h F h k) := pr2 HF x y z h k. Proposition is_strong_double_functor_id (C : double_cat) : is_strong_double_functor (id₁ C). Proof. split. - intro x. apply id_is_iso_twosided_disp. - intros. apply id_is_iso_twosided_disp. Defined. Definition strong_double_functor (C₁ C₂ : double_cat) : UU := ∑ (F : lax_double_functor C₁ C₂), is_strong_double_functor F. Coercion strong_double_functor_to_lax {C₁ C₂ : double_cat} (F : strong_double_functor C₁ C₂) : lax_double_functor C₁ C₂ := pr1 F. Coercion strong_double_functor_to_strong {C₁ C₂ : double_cat} (F : strong_double_functor C₁ C₂) : is_strong_double_functor F := pr2 F. (** 8. Double transformations *) Definition double_transformation {C₁ C₂ : double_cat} (F G : lax_double_functor C₁ C₂) : UU := F ==> G. (** 9. Accessors for double transformations *) Definition double_transformation_to_nat_trans {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) : F ⟹ G := pr1 (pr111 τ). Coercion double_transformation_to_nat_trans : double_transformation >-> nat_trans. Proposition double_transformation_ver_mor {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) {x y : C₁} (f : x -->v y) : #v F f ·v τ y = τ x ·v #v G f. Proof. exact (nat_trans_ax τ x y f). Defined. Definition double_transformation_hor_mor {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) {x y : C₁} (f : x -->h y) : square (τ x) (τ y) (#h F f) (#h G f) := pr12 (pr111 τ) x y f. Proposition double_transformation_square {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) {x₁ x₂ y₁ y₂ : C₁} {vx : x₁ -->v x₂} {vy : y₁ -->v y₂} {h : x₁ -->h y₁} {k : x₂ -->h y₂} (s : square vx vy h k) : #s F s ⋆v double_transformation_hor_mor τ k = transportb_square (double_transformation_hor_mor τ h ⋆v #s G s) (double_transformation_ver_mor _ _) (double_transformation_ver_mor _ _). Proof. exact (pr22 (pr111 τ) x₁ x₂ y₁ y₂ vx vy h k s). Qed. Proposition double_transformation_id_h {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) (x : C₁) : lax_double_functor_id_h F x ⋆v double_transformation_hor_mor τ (identity_h x) = transportb_square (id_h_square (τ x) ⋆v lax_double_functor_id_h G x) (id_v_left _ @ !(id_v_right _)) (id_v_left _ @ !(id_v_right _)). Proof. exact (pr1 (pr211 τ) x). Qed. Proposition double_transformation_comp_h {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) {x y z : C₁} (h : x -->h y) (k : y -->h z) : lax_double_functor_comp_h F h k ⋆v double_transformation_hor_mor τ (h ·h k) = transportb_square ((double_transformation_hor_mor τ h ⋆h double_transformation_hor_mor τ k) ⋆v lax_double_functor_comp_h G h k) (id_v_left _ @ !(id_v_right _)) (id_v_left _ @ !(id_v_right _)). Proof. exact (pr2 (pr211 τ) x y z h k). Qed. (** 10. Builder for double transformations *) Definition make_double_transformation {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : F ⟹ G) (ττ : twosided_disp_nat_trans τ τ (lax_double_functor_hor_mor F) (lax_double_functor_hor_mor G)) (τI : double_nat_trans_hor_id ττ (lax_double_functor_hor_id F) (lax_double_functor_hor_id G)) (τC : double_nat_trans_hor_comp ττ (lax_double_functor_hor_comp F) (lax_double_functor_hor_comp G)) : double_transformation F G. Proof. simple refine ((((_ ,, _) ,, _) ,, (tt ,, tt ,, tt)) ,, tt). - exact τ. - exact ττ. - split ; cbn. + exact τI. + exact τC. Defined. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleCatsEquivalentDefinitions.v000066400000000000000000000360601451125700300311470ustar00rootroot00000000000000(** * Double Categories Authors: Benedikt Ahrens, Paige North, Nima Rasekh, Niels van der Weide June 2023 We construct an equivalence between the unfolded definition and the folded definition of double categories. The proof is a matter of reorganizing the sigma type. Contents: 1. The map from unfolded double categories to double categories 2. The inverse 3. It forms an equivalences *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.BicatOfDoubleCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCatsUnfolded. Local Open Scope cat. Local Open Scope double_cat. (** 1. The map from unfolded double categories to double categories *) Section DoubleCatsUnfolded_to_DoubleCats. Context (C : univalent_doublecategory). Definition doublecategory_to_cat : category := (und_ob_hor_cat C). Let D : twosided_disp_cat doublecategory_to_cat doublecategory_to_cat := doublecategory_to_twosided_disp_cat C. Definition doublecategory_to_horid : hor_id D. Proof. use make_hor_id. - use make_hor_id_data. + intro x. exact (ver_identity x). + intros x y f. exact (ver_sq_identity f). - split. + intro x. exact (get_predoublecategory_interchange_id_obj x). + intros x y z f g. exact ( get_predoublecategory_interchange_id_hor f g). Defined. Let I : hor_id D := doublecategory_to_horid. Definition doublecategory_to_horcomp : hor_comp D. Proof. use make_hor_comp. - use make_hor_comp_data. + intros x y z f g. exact (ver_compose f g). + cbn in *. intros x1 x2 y1 y2 z1 z2 v1 v2 v3 h1 h2 k1 k2 α β. exact (ver_sq_compose α β). - split. + cbn in *. intros x y z f g. exact (get_predoublecategory_interchange_id_ver f g). + cbn in *. intros a0 a1 a2 b0 b1 b2 c0 c1 c2 fa ga fb gb fc gc h0 k0 h1 k1 h2 k2 α β γ δ. exact (get_predoublecategory_interchange_comp α β γ δ). Defined. Let Cm : hor_comp D := doublecategory_to_horcomp. Definition doublecategory_to_lunitor : double_cat_lunitor I Cm. Proof. use make_double_lunitor. - intros x y h. use make_iso_twosided_disp. + cbn in *. exact (pr1 (get_ver_left_unitor h)). + simple refine (_ ,, _ ,, _). * exact (pr12 (get_ver_left_unitor h)). * cbn in *. exact (pr122 (get_ver_left_unitor h)). * exact (pr222 (get_ver_left_unitor h)). - cbn in *. intros a b c d f g h k α. exact (! get_predoublecategory_ver_left_unitor_naturality α). Defined. Let l : double_cat_lunitor I Cm := doublecategory_to_lunitor. Definition doublecategory_to_runitor : double_cat_runitor I Cm. Proof. use make_double_runitor. - intros x y h. use make_iso_twosided_disp. + cbn in *. exact (pr1 (get_ver_right_unitor h)). + simple refine (_ ,, _ ,, _). * exact (pr12 (get_ver_right_unitor h)). * cbn in *. exact (pr122 (get_ver_right_unitor h)). * exact (pr222 (get_ver_right_unitor h)). - cbn in *. intros a b c d f g h k α. exact (! get_predoublecategory_ver_right_unitor_naturality α). Defined. Let r : double_cat_runitor I Cm := doublecategory_to_runitor. Definition doublecategory_to_associator : double_cat_associator Cm. Proof. use make_double_associator. - intros w x y z f g h. use make_iso_twosided_disp. + exact (pr1 (get_ver_associator f g h)). + simple refine (_ ,, _ ,, _). * exact (pr12 (get_ver_associator f g h)). * exact (pr122 (get_ver_associator f g h)). * exact (pr222 (get_ver_associator f g h)). - cbn in *. intros a0 a1 a2 a3 b0 b1 b2 b3 fa fb ha hb ka kb g0 g1 g2 g3 α β γ. exact (! get_predoublecategory_ver_assoc_naturality α β γ). Defined. Let a : double_cat_associator Cm := doublecategory_to_associator. Proposition doublecategory_to_triangle : triangle_law l r a. Proof. intros x y z h k. cbn in *. exact (get_predoublecategory_ver_unitor_coherence h k). Defined. Let tr : triangle_law l r a := doublecategory_to_triangle. Proposition doublecategory_to_pentagon : pentagon_law a. Proof. intros i b c d e f g h k. exact (get_predoublecategory_ver_assoc_coherence f g h k). Defined. Let pe : pentagon_law a := doublecategory_to_pentagon. Definition is_univalent_und_ob_hor_cat : is_univalent (und_ob_hor_cat C). Proof. apply C. Defined. Let HC : is_univalent (und_ob_hor_cat C) := is_univalent_und_ob_hor_cat. Definition is_univalent_doublecategory_to_twosided_disp_cat : is_univalent_twosided_disp_cat D. Proof. apply C. Defined. Let HD : is_univalent_twosided_disp_cat D := is_univalent_doublecategory_to_twosided_disp_cat. Definition doublecategory_to_double_cat : double_cat := make_double_cat (und_ob_hor_cat C) D I Cm l r a tr pe HC HD. End DoubleCatsUnfolded_to_DoubleCats. (** 2. The inverse *) Section DoubleCats_to_DoubleCatsUnfolded. Context (C : double_cat). Definition double_cat_to_predoublecategory_ob_mor_hor : predoublecategory_ob_mor_hor. Proof. simple refine (_ ,, _). - exact C. - exact (λ x y, x -->v y). Defined. Definition double_cat_to_predoublecategory_ob_mor_data : predoublecategory_ob_mor_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_ob_mor_hor. - exact (λ x y, x -->h y). Defined. Definition double_cat_to_predoublecategory_hor_id_comp : predoublecategory_hor_id_comp double_cat_to_predoublecategory_ob_mor_data. Proof. split. - exact (λ x, identity x). - exact (λ x y z f g, f · g). Defined. Definition double_cat_to_predoublecategory_hor_precat_data : predoublecategory_hor_precat_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_ob_mor_data. - exact double_cat_to_predoublecategory_hor_id_comp. Defined. Proposition double_cat_to_is_predoublecategory_hor : is_predoublecategory_hor double_cat_to_predoublecategory_hor_precat_data. Proof. repeat split. - intro ; intros ; cbn. apply id_left. - intro ; intros ; cbn. apply id_right. - intro ; intros ; cbn. apply assoc. - intro ; intros ; cbn. apply assoc'. Defined. Definition double_cat_to_predoublecategory_hor : predoublecategory_hor. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_hor_precat_data. - exact double_cat_to_is_predoublecategory_hor. Defined. Definition double_cat_to_predoublecategory_ver_id_comp : predoublecategory_ver_id_comp double_cat_to_predoublecategory_hor. Proof. split. - exact (λ x, identity_h x). - exact (λ x y z f g, f ·h g). Defined. Definition double_cat_to_predoublecategory_hor_cat_ver_precat_data : predoublecategory_hor_cat_ver_precat_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_hor. - exact double_cat_to_predoublecategory_ver_id_comp. Defined. Definition double_cat_to_predoublecategory_ob_mor_sq_data : predoublecategory_ob_mor_sq_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_hor_cat_ver_precat_data. - exact (λ w x y z v₁ h₁ h₂ v₂, square v₁ v₂ h₁ h₂). Defined. Definition double_cat_to_predoublecategory_sq_hor_id_comp : predoublecategory_sq_hor_id_comp double_cat_to_predoublecategory_ob_mor_sq_data. Proof. split. - exact (λ x y f, id_v_square f). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ s₁ s₂, s₁ ⋆v s₂). Defined. Definition double_cat_to_predoublecategory_sq_hor_data : predoublecategory_sq_hor_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_ob_mor_sq_data. - exact double_cat_to_predoublecategory_sq_hor_id_comp. Defined. Proposition double_cat_to_is_predoublecategory_hor_sq : is_predoublecategory_hor_sq double_cat_to_predoublecategory_sq_hor_data. Proof. repeat split. - intro ; intros ; cbn. apply square_id_left_v. - intro ; intros ; cbn. apply square_id_right_v. - intro ; intros ; cbn. apply square_assoc_v. Defined. Definition double_cat_to_predoublecategory_hor_sq : predoublecategory_hor_sq. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_sq_hor_data. - exact double_cat_to_is_predoublecategory_hor_sq. Defined. Definition double_cat_to_predoublecategory_sq_ver_id_comp : predoublecategory_sq_ver_id_comp double_cat_to_predoublecategory_hor_sq. Proof. split. - exact (λ x y f, id_h_square f). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ s₁ s₂, s₁ ⋆h s₂). Defined. Definition double_cat_to_predoublecategory_sq_hor_ver_data : predoublecategory_sq_hor_ver_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_hor_sq. - exact double_cat_to_predoublecategory_sq_ver_id_comp. Defined. Proposition double_cat_to_has_predoublecategory_sq_hor_ver_unit_assoc : has_predoublecategory_sq_hor_ver_unit_assoc double_cat_to_predoublecategory_sq_hor_ver_data. Proof. repeat split ; cbn. - intros x y f. simple refine (_ ,, _ ,, _ ,, _) ; cbn. + exact (lunitor_h f). + exact (linvunitor_h f). + exact (lunitor_linvunitor_h f). + exact (linvunitor_lunitor_h f). - intros x y f. simple refine (_ ,, _ ,, _ ,, _) ; cbn. + exact (runitor_h f). + exact (rinvunitor_h f). + exact (runitor_rinvunitor_h f). + exact (rinvunitor_runitor_h f). - intros w x y z f g h. simple refine (_ ,, _ ,, _ ,, _) ; cbn. + exact (lassociator_h f g h). + exact (rassociator_h f g h). + exact (lassociator_rassociator_h f g h). + exact (rassociator_lassociator_h f g h). Defined. Definition double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data : predoublecategory_sq_hor_ver_unit_assoc_data. Proof. simple refine (_ ,, _). - exact double_cat_to_predoublecategory_sq_hor_ver_data. - exact double_cat_to_has_predoublecategory_sq_hor_ver_unit_assoc. Defined. Proposition double_cat_to_predoublecategory_ver_left_unitor_naturality : predoublecategory_ver_left_unitor_naturality double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. intros w x y z v₁ h₁ h₂ v₂ α. exact (lunitor_square α). Defined. Proposition double_cat_to_predoublecategory_ver_right_unitor_naturality : predoublecategory_ver_right_unitor_naturality double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. intros w x y z v₁ h₁ h₂ v₂ α. exact (runitor_square α). Defined. Proposition double_cat_to_predoublecategory_ver_assoc_naturality : predoublecategory_ver_assoc_naturality double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. intro ; intros ; cbn. apply lassociator_h_square. Defined. Proposition double_cat_to_predoublecategory_ver_unitor_coherence : predoublecategory_ver_unitor_coherence double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. intro ; intros ; cbn. apply double_triangle. Defined. Proposition double_cat_to_predoublecategory_ver_assoc_coherence : predoublecategory_ver_assoc_coherence double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. intro ; intros ; cbn. apply double_pentagon. Defined. Proposition double_cat_to_predoublecategory_interchange : predoublecategory_interchange double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. Proof. repeat split ; intro ; intros ; cbn. - apply id_h_square_id. - apply id_h_square_comp. - apply comp_h_square_id. - apply comp_h_square_comp. Defined. Definition double_cat_to_predoublecategory : predoublecategory. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _). - exact double_cat_to_predoublecategory_sq_hor_ver_unit_assoc_data. - exact double_cat_to_predoublecategory_ver_left_unitor_naturality. - exact double_cat_to_predoublecategory_ver_right_unitor_naturality. - exact double_cat_to_predoublecategory_ver_assoc_naturality. - exact double_cat_to_predoublecategory_ver_unitor_coherence. - exact double_cat_to_predoublecategory_ver_assoc_coherence. - exact double_cat_to_predoublecategory_interchange. Defined. Definition double_cat_to_doublecategory : doublecategory. Proof. use make_doublecategory. - exact double_cat_to_predoublecategory. - apply homset_property. - intro ; intros ; cbn. apply isaset_disp_mor. Defined. Definition double_cat_to_univalent_doublecategory : univalent_doublecategory. Proof. simple refine (double_cat_to_doublecategory ,, _ ,, _). - exact (pr21 (pr111 C)). - exact (pr22 (pr111 C)). Defined. End DoubleCats_to_DoubleCatsUnfolded. (** 3. It forms an equivalences *) Proposition double_cat_weq_univalent_doublecategory_inv₁ (C : double_cat) : doublecategory_to_double_cat (double_cat_to_univalent_doublecategory C) = C. Proof. induction C as [ C1 H ]. use subtypePath. { intro. apply isapropdirprod ; repeat (use impred ; intro) ; apply isaset_disp_mor. } use total2_paths_f ; [ apply idpath | ]. use pathsdirprod. - use subtypePath. { intro. apply isaprop_double_lunitor_laws. } apply idpath. - use pathsdirprod. + use subtypePath. { intro. apply isaprop_double_runitor_laws. } apply idpath. + use subtypePath. { intro. apply isaprop_double_associator_laws. } apply idpath. Qed. Proposition double_cat_weq_univalent_doublecategory_inv₂ (C : univalent_doublecategory) : double_cat_to_univalent_doublecategory (doublecategory_to_double_cat C) = C. Proof. use subtypePath. { intro. apply isapropdirprod. - apply isaprop_is_univalent. - apply isaprop_is_univalent_twosided_disp_cat. } use subtypePath. { intro. use isapropdirprod ; repeat (use impred ; intro) ; apply isapropiscontr. } use total2_paths_f ; [ apply idpath | ]. repeat (use pathsdirprod) ; repeat (use funextsec ; intro) ; apply get_has_sq_hor_homsets. Qed. Definition double_cat_weq_univalent_doublecategory : double_cat ≃ univalent_doublecategory. Proof. use weq_iso. - exact double_cat_to_univalent_doublecategory. - exact doublecategory_to_double_cat. - exact double_cat_weq_univalent_doublecategory_inv₁. - exact double_cat_weq_univalent_doublecategory_inv₂. Defined. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleCatsUnfolded.v000066400000000000000000001213241451125700300263740ustar00rootroot00000000000000(** * Double Categories Authors: Benedikt Ahrens, Paige North, Nima Rasekh, Niels van der Weide June 2023 Based on definition of weak double category in Section 3.3 of the book Higher Dimensional Categories by Marco Grandis. *) (** ** Contents : - Define a pre double category as a ``weak double category`` in the sense of Grandis. This means one direction is weak and the other direction is strict. - Double categories: A double category is a pre-double category with two set-truncated hom sets. - - Univalent Double Categories: A univalent double category is a double category with two univalent underlying categories. - The structure is defined from scratch rather than building on a category. This makes further generalizations easier. *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Section Definition_of_Double_Graphs. (* Definition of a double graph.*) Definition predoublecategory_ob_mor_hor : UU := ∑ obdb : UU, obdb -> obdb -> UU. Definition obdb (C : predoublecategory_ob_mor_hor) : UU := @pr1 _ _ C. Coercion obdb : predoublecategory_ob_mor_hor >-> UU. Definition predoublecategory_mor_ver (C : predoublecategory_ob_mor_hor) : UU := (C -> C -> UU). Definition predoublecategory_ob_mor_data : UU := ∑ C, predoublecategory_mor_ver C. Coercion precategory_ob_mor_from_predoublecategory_ob_mor_data (C : predoublecategory_ob_mor_data) : predoublecategory_ob_mor_hor := pr1 C. End Definition_of_Double_Graphs. Section Morphism_Helper_Functions. (* Couple helper functions for Approach 1 *) Definition get_predoublecat_hor_mor (C: predoublecategory_ob_mor_data) : C → C → UU := pr21 C. Definition get_predoublecat_ver_mor (C: predoublecategory_ob_mor_data) : C → C → UU := pr2 C. End Morphism_Helper_Functions. Notation "x '-h->' y" := (get_predoublecat_hor_mor _ x y) (at level 60). Notation "x '-v->' y" := (get_predoublecat_ver_mor _ x y) (at level 60). Section Underlying_Horizontal_Category. (* Now we construct the horizontal category. This is independent from squares. From here on we will take strictness in one direction for granted. *) (* Here we can take two approaches: 1) Take the ``underlying precategory`` and use the existing category definitions. This one is easier, but less generalizable. 2) Define everything from scratch. This one is much more pain, but offers a more straightforward path for generalization. For future purposes I took the first approach. Here the definition of category involves associativity in both directions, similar to the original formalization of categories, *) Definition predoublecategory_hor_id_comp (C : predoublecategory_ob_mor_data): UU (* Horizontal category data*) := (∏ c : C, c -h-> c) (* identities *) × (∏ a b c : C, a -h-> b -> b -h-> c -> a -h-> c). (* composition *) Definition predoublecategory_hor_precat_data : UU := ∑ C : predoublecategory_ob_mor_data, predoublecategory_hor_id_comp C. Definition predoublecategory_ob_mor_data_from_predoublecategory_hor_precat_data (C: predoublecategory_hor_precat_data) : predoublecategory_ob_mor_data := pr1 C. Coercion predoublecategory_ob_mor_data_from_predoublecategory_hor_precat_data : predoublecategory_hor_precat_data >-> predoublecategory_ob_mor_data. Definition hor_identity {C : predoublecategory_hor_precat_data} : ∏ c : C, c -h-> c := pr1 (pr2 C). Definition hor_compose {C : predoublecategory_hor_precat_data} { a b c : C } : a -h-> b -> b -h-> c -> a -h-> c := pr2 (pr2 C) a b c. Notation "f ·h g" := (hor_compose f g) (at level 60). Notation "g ∘h f" := (hor_compose f g) (at level 60). Definition is_predoublecategory_hor (C : predoublecategory_hor_precat_data) : UU (* Horizontal Category Condition *) := ((∏ (a b : C) (f : a -h-> b), hor_identity a ·h f = f) × (∏ (a b : C) (f : a -h-> b), f ·h hor_identity b = f)) × ((∏ (a b c d : C) (f : a -h-> b) (g : b -h-> c) (h : c -h-> d), f ·h (g ·h h) = (f ·h g) ·h h) × (∏ (a b c d : C) (f : a -h-> b) (g : b -h-> c) (h : c -h-> d), (f ·h g) ·h h = f ·h (g ·h h))). Definition predoublecategory_hor: UU := total2 is_predoublecategory_hor. (* horizontal precategory*) Definition make_predoublecategory_hor (C : predoublecategory_hor_precat_data) (H : is_predoublecategory_hor C) : predoublecategory_hor := tpair _ C H. Definition predoublecategory_hor_data_from_predoublecategory_hor (C : predoublecategory_hor) : predoublecategory_hor_precat_data := pr1 C. Coercion predoublecategory_hor_data_from_predoublecategory_hor : predoublecategory_hor >-> predoublecategory_hor_precat_data. Definition get_id_hor_left (C : predoublecategory_hor) : ∏ (a b : C) (f : a -h-> b), hor_identity a ·h f = f := pr112 C. Definition id_hor_left {C : predoublecategory_hor} {a b : C} (f: a -h-> b) : hor_identity a ·h f = f := get_id_hor_left C a b f. Definition get_id_hor_right (C : predoublecategory_hor) : ∏ (a b : C) (f : a -h-> b), f ·h hor_identity b = f := pr212 C. Definition id_hor_right {C : predoublecategory_hor} {a b : C} (f: a -h-> b) : f ·h hor_identity b = f := get_id_hor_right C a b f. Definition get_assoc_hor (C : predoublecategory_hor) : ∏ (a b c d : C) (f : a -h-> b) (g : b -h-> c) (h : c -h-> d), f ·h (g ·h h) = (f ·h g) ·h h := pr122 C. Definition assoc_hor {C : predoublecategory_hor} {a b c d : C} (f : a -h-> b) (g : b -h-> c) (h : c -h-> d) : f ·h (g ·h h) = (f ·h g) ·h h := get_assoc_hor C a b c d f g h. Definition und_ob_hor_ob_mor (C : predoublecategory_ob_mor_hor) : precategory_ob_mor := make_precategory_ob_mor (pr1 C) (pr2 C). Definition und_ob_hor_precategory_data (C: predoublecategory_hor_precat_data) : precategory_data := make_precategory_data (und_ob_hor_ob_mor C) (pr12 C) (pr22 C). Definition und_ob_hor_precategory_axioms (C: predoublecategory_hor) : is_precategory (und_ob_hor_precategory_data C) := @make_is_precategory (und_ob_hor_precategory_data C) (pr112 C) (pr212 C) (pr122 C) (pr222 C). Definition und_ob_hor_precategory (C : predoublecategory_hor) : precategory := make_precategory (und_ob_hor_precategory_data C) (und_ob_hor_precategory_axioms C). Definition has_hor_homsets (C : predoublecategory_ob_mor_data) : UU := ∏ a b : C, isaset (a -h-> b). (*Horizontal Hom sets *) Definition doublecategory_hor := ∑ C:predoublecategory_hor, has_hor_homsets C. Definition make_doublecategory_hor C h : doublecategory_hor := C,,h. Definition doublecategory_hor_to_predoublecategory_hor : doublecategory_hor -> predoublecategory_hor := pr1. Coercion doublecategory_hor_to_predoublecategory_hor : doublecategory_hor >-> predoublecategory_hor. Coercion double_homset_property (C : doublecategory_hor) : has_hor_homsets C := pr2 C. Definition und_ob_hor_category (C: doublecategory_hor) : category := make_category (und_ob_hor_precategory C) (pr2 C). End Underlying_Horizontal_Category. Notation "f ·h g" := (hor_compose f g) (at level 60). Notation "g ∘h f" := (hor_compose f g) (at level 60). Section Underlying_Vertical_Composition. (* In this section we describe the vertical composition, which does not give us a category. This builds on the data and axioms of the horizontal composition structure. *) Definition predoublecategory_ver_id_comp (C : predoublecategory_hor) : UU (* Vertical composition data *) := (∏ c : C, c -v-> c) (* vertical identities *) × (∏ a b c : C, a -v-> b -> b -v-> c -> a -v-> c). (* vertical composition *) Definition predoublecategory_hor_cat_ver_precat_data : UU (* double graph with horizontal and vertical composition*) := ∑ C : predoublecategory_hor, predoublecategory_ver_id_comp C. Definition predoublecategory_hor_from_predoublecategory_hor_cat_ver_precat_data (C: predoublecategory_hor_cat_ver_precat_data) : predoublecategory_hor := pr1 C. Coercion predoublecategory_hor_from_predoublecategory_hor_cat_ver_precat_data : predoublecategory_hor_cat_ver_precat_data >-> predoublecategory_hor. Definition ver_identity {C : predoublecategory_hor_cat_ver_precat_data} : ∏ c : C, c -v-> c := pr1 (pr2 C). Definition ver_compose {C : predoublecategory_hor_cat_ver_precat_data} { a b c : C } : a -v-> b -> b -v-> c -> a -v-> c := pr2 (pr2 C) a b c. End Underlying_Vertical_Composition. Notation "f ·v g" := (ver_compose f g) (at level 60). Notation "g ∘v f" := (ver_compose f g) (at level 60). Notation "'ver_comp' C f g" := (@ver_compose C _ _ _ f g) (at level 60). Section Squares. (* Define Squares and their helper functions *) Definition predoublecategory_square (C : predoublecategory_hor_cat_ver_precat_data) : UU := ∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d), UU. Definition predoublecategory_ob_mor_sq_data : UU := (*Ob, HorMor, VerMor, Sq hor ver compositions*) ∑ C, predoublecategory_square C. Definition predoublecategory_hor_cat_ver_precat_data_from_predoublecategory_square (C : predoublecategory_ob_mor_sq_data) : predoublecategory_hor_cat_ver_precat_data := pr1 C. (* Forget Sq *) Coercion predoublecategory_hor_cat_ver_precat_data_from_predoublecategory_square : predoublecategory_ob_mor_sq_data >-> predoublecategory_hor_cat_ver_precat_data. Definition get_predoublecat_sq (C: predoublecategory_ob_mor_sq_data) : ∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d), UU := pr2 C. Definition hom_sq_between_ver (C: predoublecategory_ob_mor_sq_data) {a b c d : C} (g: a -v-> c) (h: b -v-> d): UU := ∑ (f: a -h-> b) (k: c -h-> d), (get_predoublecat_sq C a b c d f g h k). Definition hom_sq_between_hor (C: predoublecategory_ob_mor_sq_data) {a b c d : C} (f: a -h-> b) (k: c -h-> d): UU := ∑ (g: a -v-> c) (h: b -v-> d), (get_predoublecat_sq C a b c d f g h k). Definition sqq {C: predoublecategory_ob_mor_sq_data} {a b c d : C} (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d): UU := get_predoublecat_sq C a b c d f g h k. Definition boundary_sq_transport {C : predoublecategory_ob_mor_sq_data} { a b c d : C } {f1: a -h-> b} {g1: a -v-> c} {h1: b -v-> d} {k1: c -h-> d} {f2: a -h-> b} {k2: c -h-> d} (eqf: f1 = f2) (eqk: k1 = k2) (α : sqq f2 g1 h1 k2) : sqq f1 g1 h1 k1 := transportb (fun f0 => sqq f0 _ _ _) eqf (transportb (fun k0 => sqq _ _ _ k0) eqk α). End Squares. Notation "'mor_sq'" := (get_predoublecat_sq). Notation "'Sq[' x '-hv-' f h '-hv->' y , z '-vh-' g k '-vh->' w ]" := (get_predoublecat_sq _ x y z w f g h k) (at level 200, x ident, y ident, z ident, w ident, f ident, g ident, h ident, k ident). Section Horizontal_Composition_Squares. (*We construct the horizontal composition of squares and study their properties, such as associativity and unitality. *) Definition predoublecategory_sq_hor_id_comp (C : predoublecategory_ob_mor_sq_data): UU (* Horizontal composition of squares *) := (∏ (a b : C) (f: a -v-> b), (sqq (hor_identity a) f f (hor_identity b))) (* identities *) × (∏ (a0 a1 b0 b1 c0 c1 : C) (f0: a0 -v-> a1) (f1: b0 -v-> b1) (f2: c0 -v-> c1) (g0: a0 -h-> b0) (h0: b0 -h-> c0) (g1: a1 -h-> b1) (h1: b1 -h-> c1), (sqq g0 f0 f1 g1) → (sqq h0 f1 f2 h1) → (sqq (g0 ·h h0) f0 f2 (g1 ·h h1)) (* composition *) ). Definition predoublecategory_sq_hor_data : UU (* Double Graph with Squares horizontal morphism and square composition *) := ∑ C : predoublecategory_ob_mor_sq_data, predoublecategory_sq_hor_id_comp C. Definition make_predoublecategory_sq_hor_data (C : predoublecategory_ob_mor_sq_data) (id : (∏ (a b : C) (f: a -v-> b), (mor_sq C a a b b (hor_identity a) f f (hor_identity b)))) (comp: (∏ (a0 a1 b0 b1 c0 c1 : C) (f0: a0 -v-> a1) (f1: b0 -v-> b1) (f2: c0 -v-> c1) (g0: a0 -h-> b0) (h0: b0 -h-> c0) (g1: a1 -h-> b1) (h1: b1 -h-> c1), (sqq g0 f0 f1 g1) → (sqq h0 f1 f2 h1) → (sqq (g0 ·h h0) f0 f2 (g1 ·h h1))) ) : predoublecategory_sq_hor_data := tpair _ C (make_dirprod id comp). Definition predoublecategory_ob_mor_sq_data_from_predoublecategory_sq_hor_data (C : predoublecategory_sq_hor_data) : predoublecategory_ob_mor_sq_data := pr1 C. Coercion predoublecategory_ob_mor_sq_data_from_predoublecategory_sq_hor_data : predoublecategory_sq_hor_data >-> predoublecategory_ob_mor_sq_data. Definition get_hor_sq_identity {C : predoublecategory_sq_hor_data} : (∏ (a b : C) (f: a -v-> b), (sqq (hor_identity a) f f (hor_identity b))) := pr1 (pr2 C). Definition hor_sq_identity {C : predoublecategory_sq_hor_data} {a b: C} (f: a -v-> b) : (sqq (hor_identity a) f f (hor_identity b)) := get_hor_sq_identity a b f. Definition hor_sq_compose {C : predoublecategory_sq_hor_data} { a0 a1 b0 b1 c0 c1 : C } {f0: a0 -v-> a1} {f1: b0 -v-> b1} {f2: c0 -v-> c1} {g0: a0 -h-> b0} {h0: b0 -h-> c0} {g1: a1 -h-> b1} {h1: b1 -h-> c1} : (sqq g0 f0 f1 g1) → (sqq h0 f1 f2 h1) → (sqq (g0 ·h h0) f0 f2 (g1 ·h h1)) := pr2 (pr2 C) a0 a1 b0 b1 c0 c1 f0 f1 f2 g0 h0 g1 h1. Notation "α ·sqh β" := (hor_sq_compose α β) (at level 60). Notation "α ∘sqh β" := (hor_sq_compose α β) (at level 60). (* The next 3 Definitions focus on various base changes along the boundary identities via identity and associativity. *) Definition hor_trans_id_left_sq {C : predoublecategory_sq_hor_data} { a b c d : C } {f: a -h-> b} {g: a -v-> c} {h: b -v-> d} {k: c -h-> d} (α: sqq f g h k) : sqq ((hor_identity a) ·h f) g h ((hor_identity c) ·h k ) := boundary_sq_transport (id_hor_left f) (id_hor_left k) α. Definition hor_trans_id_right_sq {C : predoublecategory_sq_hor_data} { a b c d : C } {f: a -h-> b} {g: a -v-> c} {h: b -v-> d} {k: c -h-> d} (α : sqq f g h k) : sqq (f ·h (hor_identity b)) g h (k ·h (hor_identity d)) := boundary_sq_transport (id_hor_right f) (id_hor_right k) α. Definition hor_trans_assoc_sq {C : predoublecategory_sq_hor_data} { a0 b0 c0 d0 a1 b1 c1 d1 : C } {f0: a0 -h-> b0} {g0: b0 -h-> c0} {h0: c0 -h-> d0} {f1: a1 -h-> b1} {g1: b1 -h-> c1} {h1: c1 -h-> d1} {ma: a0 -v-> a1} {md: d0 -v-> d1} (α: sqq ((f0 ·h g0) ·h h0) ma md ((f1 ·h g1) ·h h1)): sqq (f0 ·h (g0 ·h h0)) ma md (f1 ·h (g1 ·h h1)) := boundary_sq_transport (assoc_hor f0 g0 h0) (assoc_hor f1 g1 h1) α. Definition is_predoublecategory_hor_sq (C : predoublecategory_sq_hor_data) : UU (* Data of horizontal composition of squares *) := ((∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d) (α : mor_sq C a b c d f g h k), (hor_sq_identity g) ·sqh α = hor_trans_id_left_sq α)) × ((∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d) (α : mor_sq C a b c d f g h k), α ·sqh (hor_sq_identity h) = hor_trans_id_right_sq α)) × (∏ ( a0 b0 c0 d0 a1 b1 c1 d1 : C ) (f0: a0 -h-> b0) (g0: b0 -h-> c0) (h0: c0 -h-> d0) (f1: a1 -h-> b1) (g1: b1 -h-> c1) (h1: c1 -h-> d1) (ma: a0 -v-> a1) (mb: b0 -v-> b1) (mc: c0 -v-> c1) (md: d0 -v-> d1) (α: sqq f0 ma mb f1) (β: sqq g0 mb mc g1) (γ: sqq h0 mc md h1), α ·sqh (β ·sqh γ) = hor_trans_assoc_sq ((α ·sqh β) ·sqh γ)) . Definition predoublecategory_hor_sq: UU := total2 is_predoublecategory_hor_sq. (* Double Graph with Squares horizontal morphism and square composition + axioms*) Definition make_predoublecategory_hor_sq (C : predoublecategory_sq_hor_data) (H : is_predoublecategory_hor_sq C) : predoublecategory_hor_sq := tpair _ C H. Definition predoublecategory_sq_hor_data_from_predoublecategory_hor_sq (C : predoublecategory_hor_sq) : predoublecategory_sq_hor_data := pr1 C. Coercion predoublecategory_sq_hor_data_from_predoublecategory_hor_sq : predoublecategory_hor_sq >-> predoublecategory_sq_hor_data. Definition get_id_hor_sq_left (C : predoublecategory_hor_sq) : ∏ (a b c d : pr1 C) (f : a -h-> b) (g : a -v-> c) (h : b -v-> d) (k : c -h-> d) (α : sqq f g h k), (hor_sq_identity g) ·sqh α = hor_trans_id_left_sq α := pr12 C. Definition id_hor_sq_left {C : predoublecategory_hor_sq} {a b c d : pr1 C} {f : a -h-> b} {g : a -v-> c} {h : b -v-> d} {k : c -h-> d} (α : sqq f g h k) : (hor_sq_identity g) ·sqh α =hor_trans_id_left_sq α := get_id_hor_sq_left C a b c d f g h k α. Definition get_id_hor_sq_right (C : predoublecategory_hor_sq) : ∏ (a b c d : pr1 C) (f : a -h-> b) (g : a -v-> c) (h : b -v-> d) (k : c -h-> d) (α : sqq f g h k), α ·sqh (hor_sq_identity h) = hor_trans_id_right_sq α := pr122 C. Definition id_hor_sq_right {C : predoublecategory_hor_sq} {a b c d : pr1 C} {f : a -h-> b} {g : a -v-> c} {h : b -v-> d} {k : c -h-> d} (α : sqq f g h k) : α ·sqh (hor_sq_identity h) = hor_trans_id_right_sq α := get_id_hor_sq_right C a b c d f g h k α. Definition get_assoc_sq_hor (C : predoublecategory_hor_sq) : ∏ (a0 b0 c0 d0 a1 b1 c1 d1 : C ) (f0: a0 -h-> b0) (g0: b0 -h-> c0) (h0: c0 -h-> d0) (f1: a1 -h-> b1) (g1: b1 -h-> c1) (h1: c1 -h-> d1) (ma: a0 -v-> a1) (mb: b0 -v-> b1) (mc: c0 -v-> c1) (md: d0 -v-> d1) (α: sqq f0 ma mb f1) (β: sqq g0 mb mc g1) (γ: sqq h0 mc md h1), α ·sqh (β ·sqh γ) = hor_trans_assoc_sq( (α ·sqh β) ·sqh γ) := pr222 C. Definition assoc_sq_hor {C : predoublecategory_hor_sq} {a0 b0 c0 d0 a1 b1 c1 d1 : pr1 C} {f0: a0 -h-> b0} {g0: b0 -h-> c0} {h0: c0 -h-> d0} {f1: a1 -h-> b1} {g1: b1 -h-> c1} {h1: c1 -h-> d1} {ma: a0 -v-> a1} {mb: b0 -v-> b1} {mc: c0 -v-> c1} {md: d0 -v-> d1} (α: sqq f0 ma mb f1) (β: sqq g0 mb mc g1) (γ: sqq h0 mc md h1) : α ·sqh (β ·sqh γ) =hor_trans_assoc_sq ( (α ·sqh β) ·sqh γ) := get_assoc_sq_hor C a0 b0 c0 d0 a1 b1 c1 d1 f0 g0 h0 f1 g1 h1 ma mb mc md α β γ. End Horizontal_Composition_Squares. Notation "α ·sqh β" := (hor_sq_compose α β) (at level 60). Notation "α ∘sqh β" := (hor_sq_compose α β) (at level 60). Section Special_Iso_Squares. (* Define special iso squares which are necessary for the vertical composition *) Definition get_predoublecat_sq_special {C: predoublecategory_ob_mor_sq_data} {a b : C} (g: a -v-> b) (h: a -v-> b): UU := sqq (hor_identity a) g h (hor_identity b). Definition is_iso_square {C: predoublecategory_sq_hor_data} {a b : C} {g: a -v-> b} {h: a -v-> b} (α : get_predoublecat_sq_special g h): UU := ∑ (β : get_predoublecat_sq_special h g), ( (α ·sqh β) =hor_trans_id_left_sq (hor_sq_identity g)) × ( (β ·sqh α) = hor_trans_id_left_sq (hor_sq_identity h)). Definition get_special_iso_squares {C: predoublecategory_sq_hor_data} {a b : C} (g: a -v-> b) (h: a -v-> b) : UU := ∑ (α : get_predoublecat_sq_special g h), (is_iso_square α). Definition sqq_iso_special {C: predoublecategory_sq_hor_data} {a b : C} (f: a -v-> b) (g: a -v-> b): UU := get_special_iso_squares f g. End Special_Iso_Squares. Section Vertical_Composition_Squares. (* We construct the vertical composition, noting it does not form a category *) Definition predoublecategory_sq_ver_id_comp (C : predoublecategory_hor_sq): UU := (∏ (a b : C) (f: a -h-> b), (sqq f (ver_identity a) (ver_identity b) f)) (* identities *) × (∏ (a0 a1 b0 b1 c0 c1 : C) (f0: a0 -h-> a1) (f1: b0 -h-> b1) (f2: c0 -h-> c1) (g0: a0 -v-> b0) (h0: b0 -v-> c0) (g1: a1 -v-> b1) (h1: b1 -v-> c1), (sqq f0 g0 g1 f1) → (sqq f1 h0 h1 f2) → (sqq f0 (g0 ·v h0) (g1 ·v h1) f2) (* composition *) ). Definition predoublecategory_sq_hor_ver_data : UU := ∑ C : predoublecategory_hor_sq, predoublecategory_sq_ver_id_comp C. Definition make_predoublecategory_sq_hor_ver_data (C : predoublecategory_hor_sq) (id : (∏ (a b : C) (f: a -h-> b), (sqq f (ver_identity a) (ver_identity b) f))) (comp: (∏ (a0 a1 b0 b1 c0 c1 : C) (f0: a0 -h-> a1) (f1: b0 -h-> b1) (f2: c0 -h-> c1) (g0: a0 -v-> b0) (h0: b0 -v-> c0) (g1: a1 -v-> b1) (h1: b1 -v-> c1), (sqq f0 g0 g1 f1) → (sqq f1 h0 h1 f2) → (sqq f0 (g0 ·v h0) (g1 ·v h1) f2)) ) : predoublecategory_sq_hor_ver_data := tpair _ C (make_dirprod id comp). Definition predoublecategory_hor_sq_from_predoublecategory_sq_hor_ver_data (C : predoublecategory_sq_hor_ver_data) : predoublecategory_hor_sq := pr1 C. (* Predoublegraph with vertical morphisms and squares composition *) Coercion predoublecategory_hor_sq_from_predoublecategory_sq_hor_ver_data: predoublecategory_sq_hor_ver_data >-> predoublecategory_hor_sq. Definition get_ver_sq_identity {C : predoublecategory_sq_hor_ver_data} : (∏ (a b : C) (f: a -h-> b), (get_predoublecat_sq C a b a b f (ver_identity a) (ver_identity b) f)) := pr1 (pr2 C). Definition ver_sq_identity {C : predoublecategory_sq_hor_ver_data} {a b : C} (f: a -h-> b): (get_predoublecat_sq C a b a b f (ver_identity a) (ver_identity b) f) := get_ver_sq_identity a b f. Definition ver_sq_compose {C : predoublecategory_sq_hor_ver_data} { a0 a1 b0 b1 c0 c1 : C } {f0: a0 -h-> a1} {f1: b0 -h-> b1} {f2: c0 -h-> c1} {g0: a0 -v-> b0} {h0: b0 -v-> c0} {g1: a1 -v-> b1} {h1: b1 -v-> c1} : (sqq f0 g0 g1 f1) → (sqq f1 h0 h1 f2) → (sqq f0 (g0 ·v h0) (g1 ·v h1) f2) := pr2 (pr2 C) a0 a1 b0 b1 c0 c1 f0 f1 f2 g0 h0 g1 h1. End Vertical_Composition_Squares. Notation "α ·sqv β" := (ver_sq_compose α β) (at level 60). Notation "α ∘sqv β" := (ver_sq_compose α β) (at level 60). Section Vertical_Unitor_and_Associator_Coherences. (* Define unitor and associator for the vertical composition*) Definition ver_left_unitor { C:predoublecategory_sq_hor_ver_data} {a b: C} (f: a -v-> b) : UU := sqq_iso_special (ver_identity a ·v f) f. Definition ver_right_unitor { C:predoublecategory_sq_hor_ver_data} {a b: C} (f: a -v-> b) : UU := sqq_iso_special (f ·v ver_identity b) f. Definition ver_associator { C:predoublecategory_sq_hor_ver_data} {a b c d: C} (f : a -v-> b) (g : b -v-> c) (h : c -v-> d) := sqq_iso_special (f ·v (g ·v h)) ((f ·v g) ·v h). Definition has_predoublecategory_sq_hor_ver_unit_assoc ( C:predoublecategory_sq_hor_ver_data) : UU := (∏ (a b: C) (f: a -v-> b) , sqq_iso_special (ver_identity a ·v f) f) × (∏ (a b: C) (f: a -v-> b) , sqq_iso_special (f ·v ver_identity b) f) × (∏ (a b c d: C) (f : a -v-> b) (g : b -v-> c) (h : c -v-> d), sqq_iso_special (f ·v (g ·v h)) ((f ·v g) ·v h)). Definition predoublecategory_sq_hor_ver_unit_assoc_data : UU := ∑ (C:predoublecategory_sq_hor_ver_data), has_predoublecategory_sq_hor_ver_unit_assoc C. Coercion predoublecategory_sq_hor_ver_data_from_predoublecategory_sq_hor_ver_unit_assoc_data (C: predoublecategory_sq_hor_ver_unit_assoc_data) : predoublecategory_sq_hor_ver_data := pr1 C. Definition get_ver_left_unitor {C: predoublecategory_sq_hor_ver_unit_assoc_data} {a b : C} (f: a -v-> b) : sqq_iso_special (ver_identity a ·v f) f := (pr12 C) a b f. Definition get_ver_right_unitor {C: predoublecategory_sq_hor_ver_unit_assoc_data} {a b : C} (f: a -v-> b) : sqq_iso_special (f ·v ver_identity b) f := (pr122 C) a b f. Definition get_ver_associator {C: predoublecategory_sq_hor_ver_unit_assoc_data} {a b c d: C} (f : a -v-> b) (g : b -v-> c) (h : c -v-> d) : sqq_iso_special (f ·v (g ·v h)) ((f ·v g) ·v h) := (pr222 C) a b c d f g h. Definition predoublecategory_ver_left_unitor_naturality ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d) (α : sqq f g h k), ((ver_sq_identity f) ·sqv α) ·sqh (pr1 (get_ver_left_unitor h)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_left_unitor g)) ·sqh α). Definition predoublecategory_ver_right_unitor_naturality ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c d : C) (f: a -h-> b) (g: a -v-> c) (h: b -v-> d) (k: c -h-> d) (α : sqq f g h k), (α ·sqv (ver_sq_identity k)) ·sqh (pr1 (get_ver_right_unitor h)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_right_unitor g)) ·sqh α). Definition predoublecategory_ver_assoc_naturality ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a0 a1 a2 a3 b0 b1 b2 b3 : C) (fa: a0 -v-> a1) (fb: b0 -v-> b1) (ha: a1 -v-> a2) (hb: b1 -v-> b2) (ka: a2 -v-> a3) (kb: b2 -v-> b3) (g0: a0 -h-> b0) (g1: a1 -h-> b1) (g2: a2 -h-> b2) (g3: a3 -h-> b3) (α : sqq g0 fa fb g1) (β : sqq g1 ha hb g2) (γ : sqq g2 ka kb g3), ( (α) ·sqv ( (β) ·sqv (γ)) ) ·sqh (pr1 (get_ver_associator fb hb kb)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_associator fa ha ka)) ·sqh ( (α ·sqv β) ·sqv (γ) )). Definition predoublecategory_ver_unitor_coherence ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c: C) (f: a -v-> b) (g: b -v-> c), ( ((pr1 (get_ver_associator f (ver_identity b) g)) ·sqh ( (pr1 (get_ver_right_unitor f)) ·sqv (hor_sq_identity g) )) = hor_trans_id_left_sq ((hor_sq_identity f) ·sqv (pr1 (get_ver_left_unitor g)))). Definition predoublecategory_ver_assoc_coherence ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c d e: C) (f : a -v-> b) (g : b -v-> c) (h : c -v-> d) (k : d -v-> e), (hor_trans_id_right_sq ( (pr1 (get_ver_associator f g (h ·v k))) ·sqh (pr1 (get_ver_associator (f ·v g) h k)) )) = ( ( ( (hor_sq_identity f) ·sqv (pr1 (get_ver_associator g h k)) ) ·sqh (pr1 (get_ver_associator f (g ·v h) k)) ) ·sqh ( (pr1 (get_ver_associator f g h)) ·sqv (hor_sq_identity k)) ) . Definition predoublecategory_interchange_comp ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a0 a1 a2 b0 b1 b2 c0 c1 c2 : C) (fa: a0 -h-> a1) (ga: a1 -h-> a2) (fb: b0 -h-> b1) (gb: b1 -h-> b2) (fc: c0 -h-> c1) (gc: c1 -h-> c2) (h0: a0 -v-> b0) (k0: b0 -v-> c0) (h1: a1 -v-> b1) (k1: b1 -v-> c1) (h2: a2 -v-> b2) (k2: b2 -v-> c2) (α : sqq fa h0 h1 fb) (β : sqq ga h1 h2 gb) (γ : sqq fb k0 k1 fc) (δ : sqq gb k1 k2 gc), (α ·sqh β) ·sqv (γ ·sqh δ) = (α ·sqv γ) ·sqh (β ·sqv δ). Definition predoublecategory_interchange_id_obj ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a :C), ver_sq_identity (hor_identity a) = hor_sq_identity (ver_identity a). Definition predoublecategory_interchange_id_hor ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c: C) (f: a -h-> b) (g: b -h-> c), ver_sq_identity(f ·h g) = (ver_sq_identity f) ·sqh (ver_sq_identity g). Definition predoublecategory_interchange_id_ver ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := ∏ (a b c: C) (f: a -v-> b) (g: b -v-> c), (hor_sq_identity f) ·sqv (hor_sq_identity g) =hor_sq_identity(f ·v g). Definition predoublecategory_interchange ( C : predoublecategory_sq_hor_ver_unit_assoc_data) : UU := predoublecategory_interchange_id_obj C × predoublecategory_interchange_id_hor C × predoublecategory_interchange_id_ver C × predoublecategory_interchange_comp C. End Vertical_Unitor_and_Associator_Coherences. Notation "α ·sqv β" := (ver_sq_compose α β) (at level 60). Notation "α ∘sqv β" := (ver_sq_compose α β) (at level 60). Section Pre_Double_Categories. (*Finally we define double categories by adding appropriate set truncation conditions. *) Definition has_sq_hor_homsets (C : predoublecategory_hor_sq) : UU := ∏ (a b c d : C) (g: a -v-> c) (h: b -v-> d) (f : a -h-> b) (k : c -h-> d), isaset (Sq[ a -hv- f h -hv-> b, c -vh- g k -vh-> d]). Definition doublecategory_hor_sq := ∑ C:predoublecategory_hor_sq, has_sq_hor_homsets C. Definition make_doublecategory_hor_sq C h : doublecategory_hor_sq := C,,h. Definition doublecategory_hor_sq_to_predoublecategory_hor_sq : doublecategory_hor_sq -> predoublecategory_hor_sq := pr1. Definition predoublecategory : UU := ∑ (C:predoublecategory_sq_hor_ver_unit_assoc_data), ( (predoublecategory_ver_left_unitor_naturality C) × (predoublecategory_ver_right_unitor_naturality C) × (predoublecategory_ver_assoc_naturality C) × (predoublecategory_ver_unitor_coherence C) × (predoublecategory_ver_assoc_coherence C) × (predoublecategory_interchange C)). Coercion predoublecategory_sq_hor_ver_unit_assoc_data_from_predoublecategory (C: predoublecategory) : predoublecategory_sq_hor_ver_unit_assoc_data := pr1 C. Definition get_predoublecategory_ver_left_unitor_naturality {C : predoublecategory} {a b c d : C} {f: a -h-> b} {g: a -v-> c} {h: b -v-> d} {k: c -h-> d} (α : sqq f g h k) : ((ver_sq_identity f) ·sqv α) ·sqh (pr1 (get_ver_left_unitor h)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_left_unitor g)) ·sqh α) := (pr12 C) a b c d f g h k α. Definition get_predoublecategory_ver_right_unitor_naturality {C : predoublecategory} {a b c d : C} {f: a -h-> b} {g: a -v-> c} {h: b -v-> d} {k: c -h-> d} (α : sqq f g h k) : (α ·sqv (ver_sq_identity k)) ·sqh (pr1 (get_ver_right_unitor h)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_right_unitor g)) ·sqh α) := (pr122 C) a b c d f g h k α. Definition get_predoublecategory_ver_assoc_naturality {C : predoublecategory} {a0 a1 a2 a3 b0 b1 b2 b3 : C} {fa: a0 -v-> a1} {fb: b0 -v-> b1} {ha: a1 -v-> a2} {hb: b1 -v-> b2} {ka: a2 -v-> a3} {kb: b2 -v-> b3} {g0: a0 -h-> b0} {g1: a1 -h-> b1} {g2: a2 -h-> b2} {g3: a3 -h-> b3} (α : sqq g0 fa fb g1) (β : sqq g1 ha hb g2) (γ : sqq g2 ka kb g3) : ( ( (α) ·sqv ( (β) ·sqv (γ)) ) ·sqh (pr1 (get_ver_associator fb hb kb)) = boundary_sq_transport (id_hor_right _ @ !(id_hor_left _)) (id_hor_right _ @ !(id_hor_left _)) ((pr1 (get_ver_associator fa ha ka)) ·sqh ( (α ·sqv β) ·sqv (γ) )) ) := (pr1 (pr222 C)) a0 a1 a2 a3 b0 b1 b2 b3 fa fb ha hb ka kb g0 g1 g2 g3 α β γ. Definition get_predoublecategory_ver_unitor_coherence {C : predoublecategory} {a b c: C} (f: a -v-> b) (g: b -v-> c) : ( ((pr1 (get_ver_associator f (ver_identity b) g)) ·sqh ( (pr1 (get_ver_right_unitor f)) ·sqv (hor_sq_identity g) )) = hor_trans_id_left_sq ((hor_sq_identity f) ·sqv (pr1 (get_ver_left_unitor g)))) := (pr12 (pr222 C)) a b c f g. Definition get_predoublecategory_ver_assoc_coherence {C : predoublecategory} {a b c d e: C} (f : a -v-> b) (g : b -v-> c) (h : c -v-> d) (k : d -v-> e) : ( (hor_trans_id_right_sq ( (pr1 (get_ver_associator f g (h ·v k))) ·sqh (pr1 (get_ver_associator (f ·v g) h k)) )) = ( ( ( (hor_sq_identity f) ·sqv (pr1 (get_ver_associator g h k)) ) ·sqh (pr1 (get_ver_associator f (g ·v h) k)) ) ·sqh ( (pr1 (get_ver_associator f g h)) ·sqv (hor_sq_identity k)) ) ) := (pr122 (pr222 C)) a b c d e f g h k. Definition get_predoublecategory_interchange_comp {C : predoublecategory} {a0 a1 a2 b0 b1 b2 c0 c1 c2 : C} {fa: a0 -h-> a1} {ga: a1 -h-> a2} {fb: b0 -h-> b1} {gb: b1 -h-> b2} {fc: c0 -h-> c1} {gc: c1 -h-> c2} {h0: a0 -v-> b0} {k0: b0 -v-> c0} {h1: a1 -v-> b1} {k1: b1 -v-> c1} {h2: a2 -v-> b2} {k2: b2 -v-> c2} (α : sqq fa h0 h1 fb) (β : sqq ga h1 h2 gb) (γ : sqq fb k0 k1 fc) (δ : sqq gb k1 k2 gc) : (α ·sqh β) ·sqv (γ ·sqh δ) = (α ·sqv γ) ·sqh (β ·sqv δ) := pr222 (pr222 (pr222 C)) a0 a1 a2 b0 b1 b2 c0 c1 c2 fa ga fb gb fc gc h0 k0 h1 k1 h2 k2 α β γ δ. Definition get_predoublecategory_interchange_id_obj {C : predoublecategory} (a :C) : ver_sq_identity (hor_identity a) = hor_sq_identity (ver_identity a) := (pr1 (pr222 (pr222 C))) a. Definition get_predoublecategory_interchange_id_hor {C : predoublecategory} {a b c: C} (f: a -h-> b) (g: b -h-> c) : ver_sq_identity(f ·h g) = (ver_sq_identity f) ·sqh (ver_sq_identity g) := (pr12 (pr222 (pr222 C))) a b c f g. Definition get_predoublecategory_interchange_id_ver {C : predoublecategory} {a b c: C} (f: a -v-> b) (g: b -v-> c) : (hor_sq_identity f) ·sqv (hor_sq_identity g) =hor_sq_identity(f ·v g) := (pr122 (pr222 (pr222 C))) a b c f g. End Pre_Double_Categories. Section Underlying_Category_Vertical_Morphisms_Squares. (* We now show the horizontal composition of squares gives us a category. *) Definition und_ver_cat_ob (C: predoublecategory_hor_sq) : UU := ∑ (a b : C), a -v-> b. Definition get_und_ver_cat_ob {C: predoublecategory_hor_sq} {a b : C} (f: a -v-> b) : und_ver_cat_ob C := (a,, (b,, f)). Definition get_und_ver_cat_ob_mor {C: predoublecategory_hor_sq} (c d : und_ver_cat_ob C) : UU := ∑ (g: (pr1 c) -h-> (pr1 d)) (k: (pr12 c) -h-> (pr12 d)), (sqq g (pr22 c) (pr22 d) k ). Definition und_ver_cat_ob_mor (C: predoublecategory_hor_sq) : und_ver_cat_ob C → und_ver_cat_ob C → UU := fun c d => (get_und_ver_cat_ob_mor c d). Definition make_und_ver_cat_ob_mor {C: predoublecategory_hor_sq} {c d : und_ver_cat_ob C} {g: (pr1 c) -h-> (pr1 d)} {k: (pr12 c) -h-> (pr12 d)} (α : sqq g (pr22 c) (pr22 d) k ) : und_ver_cat_ob_mor C c d := (g ,, (k ,, α)). Definition has_hor_sq_homsets (C : predoublecategory_hor_sq) : UU := ∏ (a b c d: C) (f: a -v-> b) (g: c -v-> d), isaset (und_ver_cat_ob_mor C (get_und_ver_cat_ob f) (get_und_ver_cat_ob g)). (*Horizontal Square Hom sets *) Definition get_und_ver_cat_id {C: predoublecategory_hor_sq} (c : (und_ver_cat_ob C)) : und_ver_cat_ob_mor C c c := make_und_ver_cat_ob_mor (hor_sq_identity (pr22 c)). Definition und_ver_cat_id (C: predoublecategory_hor_sq) : ∏ c : und_ver_cat_ob C, und_ver_cat_ob_mor C c c := fun c => get_und_ver_cat_id c. Definition get_und_ver_cat_comp {C: predoublecategory_hor_sq} (c d e : (und_ver_cat_ob C)) : und_ver_cat_ob_mor C c d → und_ver_cat_ob_mor C d e → und_ver_cat_ob_mor C c e := fun α β => make_und_ver_cat_ob_mor ( (pr22 α) ·sqh (pr22 β)). Definition und_ver_cat_comp (C: predoublecategory_hor_sq) : ∏ c d e: und_ver_cat_ob C, und_ver_cat_ob_mor C c d → und_ver_cat_ob_mor C d e → und_ver_cat_ob_mor C c e := fun c d e => get_und_ver_cat_comp c d e. Definition make_und_ver_cat_comp {C: predoublecategory_hor_sq} {c d e : (und_ver_cat_ob C)} (f: und_ver_cat_ob_mor C c d) (g: und_ver_cat_ob_mor C d e) : und_ver_cat_ob_mor C c e := und_ver_cat_comp C c d e f g. Definition und_ver_cat_precategory_data (C: predoublecategory_hor_sq) : precategory_data := make_precategory_data (make_precategory_ob_mor (und_ver_cat_ob C) (und_ver_cat_ob_mor C)) (und_ver_cat_id C) (und_ver_cat_comp C). Lemma und_ver_cat_morphism_eq_principle {C: predoublecategory_hor_sq} {c d : und_ver_cat_ob C} (f g : und_ver_cat_ob_mor C c d) (equp: (pr1 f) = (pr1 g)) (eqdown: (pr12 f) = (pr12 g)) (eqmid: (pr22 f) = boundary_sq_transport (equp) (eqdown) (pr22 g) ) : f = g. Proof. induction f as [ f1 [ f2 sq1 ]]. induction g as [ g1 [ g2 sq2 ]]. cbn in *. induction equp. induction eqdown. apply maponpaths. apply maponpaths. exact (eqmid). Defined. Definition und_ver_left_unit {C: predoublecategory_hor_sq} {c d : und_ver_cat_ob C} (f: get_und_ver_cat_ob_mor c d) : (make_und_ver_cat_comp (und_ver_cat_id C c) f) = f := (und_ver_cat_morphism_eq_principle (make_und_ver_cat_comp (und_ver_cat_id C c) f) f (id_hor_left (pr1 f)) (id_hor_left (pr12 f)) (id_hor_sq_left (pr22 f))). Definition get_und_ver_left_unit (C: predoublecategory_hor_sq) : ∏ (c d : und_ver_cat_precategory_data C) (f: get_und_ver_cat_ob_mor c d), (make_und_ver_cat_comp (und_ver_cat_id C c) f) = f := fun c d f => und_ver_left_unit f. Definition und_ver_right_unit {C: predoublecategory_hor_sq} {c d : und_ver_cat_ob C} (f: get_und_ver_cat_ob_mor c d) : (make_und_ver_cat_comp f (und_ver_cat_id C d)) = f := (und_ver_cat_morphism_eq_principle (make_und_ver_cat_comp f (und_ver_cat_id C d)) f (id_hor_right (pr1 f)) (id_hor_right (pr12 f)) (id_hor_sq_right (pr22 f))). Definition get_und_ver_right_unit (C: predoublecategory_hor_sq) : ∏ (c d : und_ver_cat_ob C) (f: get_und_ver_cat_ob_mor c d), (make_und_ver_cat_comp f (und_ver_cat_id C d)) = f := fun c d f => und_ver_right_unit f. Definition und_ver_assoc {C: predoublecategory_hor_sq} {a b c d : und_ver_cat_ob C} (f: get_und_ver_cat_ob_mor a b) (g: get_und_ver_cat_ob_mor b c) (h: get_und_ver_cat_ob_mor c d) : make_und_ver_cat_comp f (make_und_ver_cat_comp g h) = make_und_ver_cat_comp (make_und_ver_cat_comp f g) h := (und_ver_cat_morphism_eq_principle (make_und_ver_cat_comp f (make_und_ver_cat_comp g h)) (make_und_ver_cat_comp (make_und_ver_cat_comp f g) h) (assoc_hor (pr1 f) (pr1 g) (pr1 h)) (assoc_hor (pr12 f) (pr12 g) (pr12 h)) (assoc_sq_hor (pr22 f) (pr22 g) (pr22 h))). Definition get_und_ver_assoc (C: predoublecategory_hor_sq) : ∏ (a b c d : und_ver_cat_ob C) (f: get_und_ver_cat_ob_mor a b) (g: get_und_ver_cat_ob_mor b c) (h: get_und_ver_cat_ob_mor c d), make_und_ver_cat_comp f (make_und_ver_cat_comp g h) = make_und_ver_cat_comp (make_und_ver_cat_comp f g) h := fun a b c d f g h => und_ver_assoc f g h. Definition und_ver_cat_is_precategory (C: predoublecategory_hor_sq) : is_precategory (und_ver_cat_precategory_data C) := make_is_precategory_one_assoc (get_und_ver_left_unit C) (get_und_ver_right_unit C) (get_und_ver_assoc C). Definition und_ver_precategory (C: predoublecategory_hor_sq) : precategory := make_precategory (und_ver_cat_precategory_data C) (und_ver_cat_is_precategory C). End Underlying_Category_Vertical_Morphisms_Squares. Section Double_Categories. (* We now use the underlying categories to define double categories *) Definition doublecategory := ∑ C:predoublecategory, (has_homsets (und_ob_hor_precategory C) × has_sq_hor_homsets C). Definition make_doublecategory C h k : doublecategory := C,,h,,k. Definition doublecategory_to_predoublecategory : doublecategory → predoublecategory := pr1. Coercion doublecategory_to_predoublecategory : doublecategory >-> predoublecategory. Coercion homset_sq_property (C : doublecategory) : (has_homsets (und_ob_hor_precategory C) × has_sq_hor_homsets C) := pr2 C. Definition get_has_sq_hor_homsets {C : doublecategory} {a b c d : C} (g: a -v-> c) (h: b -v-> d) (f : a -h-> b) (k : c -h-> d) :isaset (Sq[ a -hv- f h -hv-> b, c -vh- g k -vh-> d]) := (pr22 C) a b c d g h f k. Definition und_ob_hor_cat (C: doublecategory) : category := make_category (und_ob_hor_precategory C) (pr12 C). Definition und_ver_cat (C: doublecategory) : category. Proof. use (make_category (und_ver_precategory C)). intros x y. use isaset_total2. - apply C. - intro. use isaset_total2. + apply C. + intro. apply C. Defined. Definition doublecategory_to_twosided_disp_cat_data (C : doublecategory) : twosided_disp_cat_data (und_ob_hor_cat C) (und_ob_hor_cat C). Proof. use tpair. - use tpair. * intros x y. exact (x -v-> y). * intros x y z w f g h k. exact (sqq h f g k). - use tpair. * intros x y f. exact (hor_sq_identity f). * intros x y z a b c f1 f2 f3 f4 f5 f6 f7 α β. exact (α ·sqh β). Defined. Definition doublecategory_to_twosided_disp_cat (C : doublecategory) : twosided_disp_cat (und_ob_hor_cat C) (und_ob_hor_cat C). Proof. use tpair. - exact (doublecategory_to_twosided_disp_cat_data C). - repeat split. + intros x0 x1 y0 y1 f0 f1 g0 g1 α. exact (id_hor_sq_left α). + intros x0 x1 y0 y1 f0 f1 g0 g1 α. exact (id_hor_sq_right α). + intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? α β γ. exact (assoc_sq_hor α β γ). + intros x0 x1 y0 y1 f0 g0 f1 g1. exact (get_has_sq_hor_homsets f0 g0 f1 g1). Defined. End Double_Categories. Section Univalent_Double_Categories. (* We now use the underlying categories to define double univalence, as the univalence of the underlying two categories *) Definition is_double_univalent (C : doublecategory) := (is_univalent (und_ob_hor_cat C) × is_univalent_twosided_disp_cat (doublecategory_to_twosided_disp_cat C)). Definition univalent_doublecategory : UU := ∑ (C: doublecategory), is_double_univalent C. Coercion univalent_doublecategory_to_doublecategory (C: univalent_doublecategory) := pr1 C. End Univalent_Double_Categories. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor.v000066400000000000000000000010051451125700300254320ustar00rootroot00000000000000(********************************************************************************** Export file for double functors **********************************************************************************) Require Export UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Require Export UniMath.Bicategories.DoubleCategories.DoubleFunctor.LeftUnitor. Require Export UniMath.Bicategories.DoubleCategories.DoubleFunctor.RightUnitor. Require Export UniMath.Bicategories.DoubleCategories.DoubleFunctor.Associator. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor/000077500000000000000000000000001451125700300252475ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor/Associator.v000066400000000000000000000145071451125700300275540ustar00rootroot00000000000000(********************************************************************************** Preservation of the associator by the composition of double functors This file is split due to high memory consumption **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Local Open Scope cat. Unset Kernel Term Sharing. (** This is to reduce the memory consumption of this file. Usually, the Coq kernel uses lazy evaluation, but with this command, strict evaluation is used. As a result, the memory consumption might decrease while the time consumption might increase. On my laptop (M2 Macbook Air, 2022): Without kernel term sharing: - The final Qed takes 33.027 seconds - At the end of the file, 5.92 GB of RAM is used With kernel term sharing: - The final Qed takes 42.759 seconds - At the end of the file, 7.27 GB of RAM is used *) Proposition comp_functor_associator {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {a₁ : double_cat_associator Cm₁} {a₂ : double_cat_associator Cm₂} {a₃ : double_cat_associator Cm₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} {FC : double_functor_hor_comp FF Cm₁ Cm₂} {GC : double_functor_hor_comp GG Cm₂ Cm₃} (Fa : double_functor_associator a₁ a₂ FC) (Ga : double_functor_associator a₂ a₃ GC) : double_functor_associator a₁ a₃ (comp_hor_comp FC GC). Proof. intros w x y z f g h ; cbn. rewrite !two_disp_post_whisker_b. rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. etrans. { etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply maponpaths. exact (id_two_disp_left_alt _). } rewrite (double_hor_comp_transport_mor _ _ _ _ _ _ _ (functor_id _ _)). rewrite two_disp_post_whisker_f. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { do 3 apply maponpaths. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. rewrite twosided_disp_functor_id_alt. rewrite functor_double_comp_eq_transport. apply idpath. } unfold transportb_disp_mor2. rewrite !two_disp_post_whisker_f. rewrite two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { apply maponpaths. do 2 apply maponpaths_2. apply Ga. } rewrite !two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp_alt. rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp_alt. rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. etrans. { do 3 apply maponpaths. rewrite assoc_two_disp. rewrite Fa. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite transportf_twosided_disp_functor. apply idpath. } rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. do 2 rewrite twosided_disp_functor_comp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. apply idpath. } refine (!_). etrans. { etrans. { apply maponpaths. do 2 apply maponpaths_2. apply maponpaths_2. exact (id_two_disp_left_alt _). } rewrite (double_hor_comp_transport_mor _ _ _ _ _ _ _ (!(functor_id _ _))). rewrite !two_disp_pre_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite !transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite !transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. rewrite assoc_two_disp. apply maponpaths. apply maponpaths_2. rewrite twosided_disp_functor_id_alt. rewrite transport_f_f_disp_mor2. apply (functor_double_comp_eq_transport GC _ _ (idpath _) (idpath _)). } unfold transportb_disp_mor2. rewrite !two_disp_post_whisker_f. rewrite !two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. apply idpath. } rewrite assoc_two_disp_alt. rewrite !two_disp_post_whisker_f. rewrite !transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor/Basics.v000066400000000000000000000706521451125700300266540ustar00rootroot00000000000000(********************************************************************************** Basics of double functors We define the basic notions for double functors. Note that the double functors we consider are *lax* double functors. Note the direction of the squares in [double_functor_hor_id_data] and in [double_functor_hor_comp_data] and compare to definition 6.1 in 'Framed Bicategories and Monoidal Fibrations' by Shulman (http://www.tac.mta.ca/tac/volumes/20/18/20-18.pdf). In addition, we show that the identity is a double functor. The proof that the composition of double functors is again a double functor, is split over multiple files (LeftUnitor.v, RightUnitor.v, and Associator.v). Contents 1. Preservation of the identity 2. Preservation of composition 3. Preservation of the unitors and associators 4. The identity double functor **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Local Open Scope cat. (** 1. Preservation of the identity *) Definition double_functor_hor_id_data {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} (FF : twosided_disp_functor F F D₁ D₂) (I₁ : hor_id D₁) (I₂ : hor_id D₂) : UU := ∏ (x : C₁), double_id I₂ (F x) -->[ identity _ ][ identity _ ] FF _ _ (double_id I₁ x). Definition double_functor_hor_id_laws {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id_data FF I₁ I₂) : UU := ∏ (x y : C₁) (f : x --> y), double_id_mor I₂ (#F f) ;;2 FI y = transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (FI x ;;2 #2 FF (double_id_mor I₁ f)). Proposition isaprop_double_functor_hor_id_laws {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id_data FF I₁ I₂) : isaprop (double_functor_hor_id_laws FI). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_functor_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} (FF : twosided_disp_functor F F D₁ D₂) (I₁ : hor_id D₁) (I₂ : hor_id D₂) : UU := ∑ (FI : double_functor_hor_id_data FF I₁ I₂), double_functor_hor_id_laws FI. Definition make_double_functor_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id_data FF I₁ I₂) (HFI : double_functor_hor_id_laws FI) : double_functor_hor_id FF I₁ I₂ := FI ,, HFI. Definition functor_double_id_cell {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (IFF : double_functor_hor_id FF I₁ I₂) (x : C₁) : double_id I₂ (F x) -->[ identity _ ][ identity _ ] FF _ _ (double_id I₁ x) := pr1 IFF x. Proposition functor_double_id_eq {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (IFF : double_functor_hor_id FF I₁ I₂) {x y : C₁} (f : x --> y) : double_id_mor I₂ (#F f) ;;2 functor_double_id_cell IFF y = transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (functor_double_id_cell IFF x ;;2 #2 FF (double_id_mor I₁ f)). Proof. exact (pr2 IFF x y f). Qed. (** 2. Preservation of composition *) Definition double_functor_hor_comp_data {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} (FF : twosided_disp_functor F F D₁ D₂) (Cm₁ : hor_comp D₁) (Cm₂ : hor_comp D₂) : UU := ∏ (x y z : C₁) (h : D₁ x y) (k : D₁ y z), double_hor_comp Cm₂ (FF _ _ h) (FF _ _ k) -->[ identity _ ][ identity _ ] FF _ _ (double_hor_comp Cm₁ h k). Definition double_functor_hor_comp_laws {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp_data FF Cm₁ Cm₂) : UU := ∏ (x₁ x₂ y₁ y₂ z₁ z₂ : C₁) (v₁ : x₁ --> x₂) (v₂ : y₁ --> y₂) (v₃ : z₁ --> z₂) (h₁ : D₁ x₁ y₁) (h₂ : D₁ x₂ y₂) (k₁ : D₁ y₁ z₁) (k₂ : D₁ y₂ z₂) (s₁ : h₁ -->[ v₁ ][ v₂ ] h₂) (s₂ : k₁ -->[ v₂ ][ v₃ ] k₂), double_hor_comp_mor Cm₂ (#2 FF s₁) (#2 FF s₂) ;;2 FC _ _ _ _ _ = transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (FC _ _ _ _ _ ;;2 #2 FF (double_hor_comp_mor Cm₁ s₁ s₂)). Proposition isaprop_double_functor_hor_comp_laws {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp_data FF Cm₁ Cm₂) : isaprop (double_functor_hor_comp_laws FC). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_functor_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} (FF : twosided_disp_functor F F D₁ D₂) (Cm₁ : hor_comp D₁) (Cm₂ : hor_comp D₂) : UU := ∑ (FC : double_functor_hor_comp_data FF Cm₁ Cm₂), double_functor_hor_comp_laws FC. Definition make_double_functor_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp_data FF Cm₁ Cm₂) (HFC : double_functor_hor_comp_laws FC) : double_functor_hor_comp FF Cm₁ Cm₂ := FC ,, HFC. Definition functor_double_comp_cell {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (CFF : double_functor_hor_comp FF Cm₁ Cm₂) {x y z : C₁} (h : D₁ x y) (k : D₁ y z) : double_hor_comp Cm₂ (FF _ _ h) (FF _ _ k) -->[ identity _ ][ identity _ ] FF _ _ (double_hor_comp Cm₁ h k) := pr1 CFF x y z h k. Proposition functor_double_comp_eq {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) {x₁ x₂ y₁ y₂ z₁ z₂ : C₁} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {h₁ : D₁ x₁ y₁} {h₂ : D₁ x₂ y₂} {k₁ : D₁ y₁ z₁} {k₂ : D₁ y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂ ] h₂) (s₂ : k₁ -->[ v₂ ][ v₃ ] k₂) : double_hor_comp_mor Cm₂ (#2 FF s₁) (#2 FF s₂) ;;2 functor_double_comp_cell FC _ _ = transportb_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (functor_double_comp_cell FC _ _ ;;2 #2 FF (double_hor_comp_mor Cm₁ s₁ s₂)). Proof. exact (pr2 FC x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂). Qed. Proposition functor_double_comp_eq_alt {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) {x₁ x₂ y₁ y₂ z₁ z₂ : C₁} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {h₁ : D₁ x₁ y₁} {h₂ : D₁ x₂ y₂} {k₁ : D₁ y₁ z₁} {k₂ : D₁ y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂ ] h₂) (s₂ : k₁ -->[ v₂ ][ v₃ ] k₂) : functor_double_comp_cell FC _ _ ;;2 #2 FF (double_hor_comp_mor Cm₁ s₁ s₂) = transportf_disp_mor2 (id_right _ @ !(id_left _)) (id_right _ @ !(id_left _)) (double_hor_comp_mor Cm₂ (#2 FF s₁) (#2 FF s₂) ;;2 functor_double_comp_cell FC _ _). Proof. rewrite functor_double_comp_eq. rewrite transportfb_disp_mor2. apply idpath. Qed. Proposition functor_double_comp_eq_transport {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) {x₁ x₂ y₁ y₂ z₁ z₂ : C₁} {v₁ : x₁ --> x₂} {v₁' : F x₁ --> F x₂} {v₂ : y₁ --> y₂} {v₂' : F y₁ --> F y₂} {v₃ : z₁ --> z₂} {v₃' : F z₁ --> F z₂} (p : #F v₁ = v₁') (q q' : #F v₂ = v₂') (r : #F v₃ = v₃') {h₁ : D₁ x₁ y₁} {h₂ : D₁ x₂ y₂} {k₁ : D₁ y₁ z₁} {k₂ : D₁ y₂ z₂} (s₁ : h₁ -->[ v₁ ][ v₂ ] h₂) (s₂ : k₁ -->[ v₂ ][ v₃ ] k₂) : double_hor_comp_mor Cm₂ (transportf_disp_mor2 p q (#2 FF s₁)) (transportf_disp_mor2 q' r (#2 FF s₂)) ;;2 functor_double_comp_cell FC _ _ = transportf_disp_mor2 (id_left _ @ p @ !(id_right _)) (id_left _ @ r @ !(id_right _)) (functor_double_comp_cell FC _ _ ;;2 #2 FF (double_hor_comp_mor Cm₁ s₁ s₂)). Proof. induction p, q, r. assert (q' = idpath _) as H. { apply homset_property. } rewrite H. cbn. rewrite functor_double_comp_eq. unfold transportb_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. (** 3. Preservation of the unitors and associators *) Definition double_functor_lunitor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {I₁ : hor_id D₁} {Cm₁ : hor_comp D₁} {I₂ : hor_id D₂} {Cm₂ : hor_comp D₂} (l₁ : double_cat_lunitor I₁ Cm₁) (l₂ : double_cat_lunitor I₂ Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FI : double_functor_hor_id FF I₁ I₂) (FC : double_functor_hor_comp FF Cm₁ Cm₂) : UU := ∏ (x y : C₁) (f : D₁ x y), double_lunitor l₂ (FF _ _ f) = transportf_disp_mor2 (assoc' _ _ _ @ id_left _ @ id_left _ @ functor_id F _) (assoc' _ _ _ @ id_left _ @ id_left _ @ functor_id F _) (double_hor_comp_mor Cm₂ (functor_double_id_cell FI _) (id_two_disp _) ;;2 functor_double_comp_cell FC _ _ ;;2 #2 FF (double_lunitor l₁ f)). Proposition isaprop_double_functor_lunitor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {I₁ : hor_id D₁} {Cm₁ : hor_comp D₁} {I₂ : hor_id D₂} {Cm₂ : hor_comp D₂} (l₁ : double_cat_lunitor I₁ Cm₁) (l₂ : double_cat_lunitor I₂ Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FI : double_functor_hor_id FF I₁ I₂) (FC : double_functor_hor_comp FF Cm₁ Cm₂) : isaprop (double_functor_lunitor l₁ l₂ FI FC). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_functor_runitor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {I₁ : hor_id D₁} {Cm₁ : hor_comp D₁} {I₂ : hor_id D₂} {Cm₂ : hor_comp D₂} (r₁ : double_cat_runitor I₁ Cm₁) (r₂ : double_cat_runitor I₂ Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FI : double_functor_hor_id FF I₁ I₂) (FC : double_functor_hor_comp FF Cm₁ Cm₂) : UU := ∏ (x y : C₁) (f : D₁ x y), double_runitor r₂ (FF _ _ f) = transportf_disp_mor2 (assoc' _ _ _ @ id_left _ @ id_left _ @ functor_id F _) (assoc' _ _ _ @ id_left _ @ id_left _ @ functor_id F _) (double_hor_comp_mor Cm₂ (id_two_disp _) (functor_double_id_cell FI _) ;;2 functor_double_comp_cell FC _ _ ;;2 #2 FF (double_runitor r₁ f)). Proposition isaprop_double_functor_runitor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {I₁ : hor_id D₁} {Cm₁ : hor_comp D₁} {I₂ : hor_id D₂} {Cm₂ : hor_comp D₂} (r₁ : double_cat_runitor I₁ Cm₁) (r₂ : double_cat_runitor I₂ Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FI : double_functor_hor_id FF I₁ I₂) (FC : double_functor_hor_comp FF Cm₁ Cm₂) : isaprop (double_functor_runitor r₁ r₂ FI FC). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. Definition double_functor_associator {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (a₁ : double_cat_associator Cm₁) (a₂ : double_cat_associator Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : UU := ∏ (w x y z : C₁) (f : D₁ w x) (g : D₁ x y) (h : D₁ y z), double_associator a₂ (FF _ _ f) (FF _ _ g) (FF _ _ h) ;;2 double_hor_comp_mor Cm₂ (functor_double_comp_cell FC f g) (id_two_disp _) ;;2 functor_double_comp_cell FC (double_hor_comp Cm₁ f g) h = transportf_disp_mor2 (maponpaths (λ q, _ · q) (functor_id F _)) (maponpaths (λ q, _ · q) (functor_id F _)) (double_hor_comp_mor Cm₂ (id_two_disp _) (functor_double_comp_cell FC g h) ;;2 functor_double_comp_cell FC f (double_hor_comp Cm₁ g h) ;;2 #2 FF (double_associator a₁ f g h)). Proposition isaprop_double_functor_associator {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (a₁ : double_cat_associator Cm₁) (a₂ : double_cat_associator Cm₂) {FF : twosided_disp_functor F F D₁ D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : isaprop (double_functor_associator a₁ a₂ FC). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. (** 4. The identity double functor *) Definition identity_hor_id_data (C : category) (D : twosided_disp_cat C C) (I : hor_id D) : double_functor_hor_id_data (twosided_disp_functor_identity D) I I := λ x, id_two_disp _. Arguments identity_hor_id_data {C D} I /. Proposition identity_hor_id_laws {C : category} {D : twosided_disp_cat C C} (I : hor_id D) : double_functor_hor_id_laws (identity_hor_id_data I). Proof. intros x y f ; cbn. rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. Qed. Definition identity_hor_id {C : category} {D : twosided_disp_cat C C} (I : hor_id D) : double_functor_hor_id (twosided_disp_functor_identity D) I I. Proof. use make_double_functor_hor_id. - exact (identity_hor_id_data I). - exact (identity_hor_id_laws I). Defined. Definition identity_hor_comp_data (C : category) (D : twosided_disp_cat C C) (Cm : hor_comp D) : double_functor_hor_comp_data (twosided_disp_functor_identity D) Cm Cm := λ x y z h k, id_two_disp _. Arguments identity_hor_comp_data {C D} Cm /. Proposition identity_hor_comp_laws {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : double_functor_hor_comp_laws (identity_hor_comp_data Cm). Proof. intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn. rewrite id_two_disp_left, id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. Qed. Definition identity_hor_comp {C : category} {D : twosided_disp_cat C C} (Cm : hor_comp D) : double_functor_hor_comp (twosided_disp_functor_identity D) Cm Cm. Proof. use make_double_functor_hor_comp. - exact (identity_hor_comp_data Cm). - exact (identity_hor_comp_laws Cm). Defined. Proposition identity_functor_lunitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (l : double_cat_lunitor I Cm) : double_functor_lunitor l l (identity_hor_id I) (identity_hor_comp Cm). Proof. intros x y f ; cbn. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). apply transportf_disp_mor2_idpath. Qed. Proposition identity_functor_runitor {C : category} {D : twosided_disp_cat C C} {I : hor_id D} {Cm : hor_comp D} (r : double_cat_runitor I Cm) : double_functor_runitor r r (identity_hor_id I) (identity_hor_comp Cm). Proof. intros x y f ; cbn. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). apply transportf_disp_mor2_idpath. Qed. Proposition identity_functor_associator {C : category} {D : twosided_disp_cat C C} {Cm : hor_comp D} (a : double_cat_associator Cm) : double_functor_associator a a (identity_hor_comp Cm). Proof. intros w x y z f g h ; cbn. rewrite id_two_disp_right. rewrite double_hor_comp_mor_id. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. rewrite double_hor_comp_mor_id. rewrite two_disp_pre_whisker_b. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. (** 6. The composition of double functors *) Definition comp_hor_id_data {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_id FF I₁ I₂) (HGG : double_functor_hor_id GG I₂ I₃) : double_functor_hor_id_data (comp_twosided_disp_functor FF GG) I₁ I₃ := λ x, transportf_disp_mor2 (id_left _ @ functor_id _ _) (id_left _ @ functor_id _ _) (functor_double_id_cell HGG (F x) ;;2 #2 GG (functor_double_id_cell HFF x)). Arguments comp_hor_id_data /. Proposition comp_hor_id_laws {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_id FF I₁ I₂) (HGG : double_functor_hor_id GG I₂ I₃) : double_functor_hor_id_laws (comp_hor_id_data HFF HGG). Proof. intros x y f ; cbn. rewrite two_disp_post_whisker_f. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (functor_double_id_eq HGG). rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (twosided_disp_functor_comp_alt _ _ _ _ GG). rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite (functor_double_id_eq HFF). rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (twosided_disp_functor_comp _ _ _ _ GG). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Definition comp_hor_id {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_id FF I₁ I₂) (HGG : double_functor_hor_id GG I₂ I₃) : double_functor_hor_id (comp_twosided_disp_functor FF GG) I₁ I₃. Proof. use make_double_functor_hor_id. - exact (comp_hor_id_data HFF HGG). - exact (comp_hor_id_laws HFF HGG). Defined. Definition comp_hor_comp_data {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_comp FF Cm₁ Cm₂) (HGG : double_functor_hor_comp GG Cm₂ Cm₃) : double_functor_hor_comp_data (comp_twosided_disp_functor FF GG) Cm₁ Cm₃. Proof. refine (λ x y z h k, transportb_disp_mor2 _ _ (functor_double_comp_cell HGG (FF _ _ h) (FF _ _ k) ;;2 #2 GG (functor_double_comp_cell HFF h k))). - abstract (rewrite functor_id ; rewrite id_left ; apply idpath). - abstract (rewrite functor_id ; rewrite id_left ; apply idpath). Defined. Arguments comp_hor_comp_data /. Proposition comp_hor_comp_laws {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_comp FF Cm₁ Cm₂) (HGG : double_functor_hor_comp GG Cm₂ Cm₃) : double_functor_hor_comp_laws (comp_hor_comp_data HFF HGG). Proof. intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn. etrans. { rewrite two_disp_post_whisker_b. rewrite assoc_two_disp. rewrite transport_b_b_disp_mor2. rewrite functor_double_comp_eq. rewrite two_disp_pre_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp_alt. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite functor_double_comp_eq. rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } refine (!_). etrans. { rewrite two_disp_pre_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } use transportf_disp_mor2_eq. apply idpath. Qed. Definition comp_hor_comp {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} (HFF : double_functor_hor_comp FF Cm₁ Cm₂) (HGG : double_functor_hor_comp GG Cm₂ Cm₃) : double_functor_hor_comp (comp_twosided_disp_functor FF GG) Cm₁ Cm₃. Proof. use make_double_functor_hor_comp. - exact (comp_hor_comp_data HFF HGG). - exact (comp_hor_comp_laws HFF HGG). Defined. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor/LeftUnitor.v000066400000000000000000000107241451125700300275350ustar00rootroot00000000000000(********************************************************************************** Preservation of the left unitor by the composition of double functors This file is split due to high memory consumption **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Local Open Scope cat. Unset Kernel Term Sharing. (* this is to reduce the memory consumption of this file *) Proposition comp_functor_lunitor {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {l₁ : double_cat_lunitor I₁ Cm₁} {l₂ : double_cat_lunitor I₂ Cm₂} {l₃ : double_cat_lunitor I₃ Cm₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} {FI : double_functor_hor_id FF I₁ I₂} {GI : double_functor_hor_id GG I₂ I₃} {FC : double_functor_hor_comp FF Cm₁ Cm₂} {GC : double_functor_hor_comp GG Cm₂ Cm₃} (Fl : double_functor_lunitor l₁ l₂ FI FC) (Gl : double_functor_lunitor l₂ l₃ GI GC) : double_functor_lunitor l₁ l₃ (comp_hor_id FI GI) (comp_hor_comp FC GC). Proof. intros x y f ; cbn. rewrite two_disp_post_whisker_b. rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite Gl, Fl. rewrite transportf_twosided_disp_functor. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_pre_whisker_b. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply idpath. } rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. apply maponpaths_2. rewrite assoc_two_disp. rewrite functor_double_comp_eq_alt. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. apply idpath. } rewrite two_disp_pre_whisker_f. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite <- double_hor_comp_mor_comp. rewrite id_two_disp_left. rewrite twosided_disp_functor_id. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). etrans. { rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. apply idpath. } etrans. { apply maponpaths. do 3 apply maponpaths_2. apply (double_hor_comp_mor_transportf_disp_mor2_left _ _ _ (!(id_left _ @ functor_id _ _))). } rewrite !two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. do 3 apply maponpaths_2. apply maponpaths. use transportf_disp_mor2_eq. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleFunctor/RightUnitor.v000066400000000000000000000106761451125700300277260ustar00rootroot00000000000000(********************************************************************************** Preservation of the right unitor by the composition of double functors This file is split due to high memory consumption **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Local Open Scope cat. Unset Kernel Term Sharing. (* this is to reduce the memory consumption of this file *) Proposition comp_functor_runitor {C₁ C₂ C₃ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {r₁ : double_cat_runitor I₁ Cm₁} {r₂ : double_cat_runitor I₂ Cm₂} {r₃ : double_cat_runitor I₃ Cm₃} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {G : C₂ ⟶ C₃} {GG : twosided_disp_functor G G D₂ D₃} {FI : double_functor_hor_id FF I₁ I₂} {GI : double_functor_hor_id GG I₂ I₃} {FC : double_functor_hor_comp FF Cm₁ Cm₂} {GC : double_functor_hor_comp GG Cm₂ Cm₃} (Fl : double_functor_runitor r₁ r₂ FI FC) (Gl : double_functor_runitor r₂ r₃ GI GC) : double_functor_runitor r₁ r₃ (comp_hor_id FI GI) (comp_hor_comp FC GC). Proof. intros x y f ; cbn. rewrite two_disp_post_whisker_b. rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite Gl, Fl. rewrite transportf_twosided_disp_functor. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_pre_whisker_b. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. rewrite assoc_two_disp. apply idpath. } rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. etrans. { do 2 apply maponpaths. apply maponpaths_2. rewrite assoc_two_disp. rewrite functor_double_comp_eq_alt. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. apply idpath. } rewrite two_disp_pre_whisker_f. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite <- double_hor_comp_mor_comp. rewrite id_two_disp_left. rewrite twosided_disp_functor_id. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. refine (!_). etrans. { rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. apply idpath. } etrans. { apply maponpaths. do 3 apply maponpaths_2. apply (double_hor_comp_mor_transportf_disp_mor2_right _ (!(id_left _ @ functor_id _ _))). } rewrite !two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. do 4 apply maponpaths_2. use transportf_disp_mor2_eq. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/DoubleTransformation.v000066400000000000000000000763021451125700300270340ustar00rootroot00000000000000(********************************************************************************** Double Transformations We define double transformations between lax double functors. In addition, we give some examples of these, namely the examples that are needed to construct the bicategory of double categories. Contents 1. Preservation of the identity 2. Preservation of composition 3. Examples of double transformations **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedNatTrans. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor. Local Open Scope cat. (** 1. Preservation of the identity *) Definition double_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F G : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₁ D₂} {τ : F ⟹ G} (ττ : twosided_disp_nat_trans τ τ FF GG) {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) (GI : double_functor_hor_id GG I₁ I₂) : UU := ∏ (x : C₁), functor_double_id_cell FI x ;;2 ττ x x (double_id I₁ x) = transportb_disp_mor2 (id_left _ @ !(id_right _)) (id_left _ @ !(id_right _)) (double_id_mor I₂ (τ x) ;;2 functor_double_id_cell GI x). Proposition isaprop_double_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F G : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₁ D₂} {τ : F ⟹ G} (ττ : twosided_disp_nat_trans τ τ FF GG) {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) (GI : double_functor_hor_id GG I₁ I₂) : isaprop (double_nat_trans_hor_id ττ FI GI). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. (** 2. Preservation of composition *) Definition double_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F G : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₁ D₂} {τ : F ⟹ G} (ττ : twosided_disp_nat_trans τ τ FF GG) {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) (GC : double_functor_hor_comp GG Cm₁ Cm₂) : UU := ∏ (x y z : C₁) (h : D₁ x y) (k : D₁ y z), functor_double_comp_cell FC h k ;;2 ττ _ _ (double_hor_comp Cm₁ h k) = transportb_disp_mor2 (id_left _ @ !(id_right _)) (id_left _ @ !(id_right _)) (double_hor_comp_mor Cm₂ (ττ _ _ h) (ττ _ _ k) ;;2 functor_double_comp_cell GC h k). Proposition isaprop_double_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F G : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₁ D₂} {τ : F ⟹ G} (ττ : twosided_disp_nat_trans τ τ FF GG) {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) (GC : double_functor_hor_comp GG Cm₁ Cm₂) : isaprop (double_nat_trans_hor_comp ττ FC GC). Proof. repeat (use impred ; intro). apply isaset_disp_mor. Qed. (** 3. Examples of double transformations *) Proposition id_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) : double_nat_trans_hor_id (id_twosided_disp_nat_trans FF) FI FI. Proof. intros x ; cbn. rewrite double_id_mor_id. rewrite id_two_disp_left. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition comp_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {F F' F'' : C₁ ⟶ C₂} {τ : F ⟹ F'} {τ' : F' ⟹ F''} {D : twosided_disp_cat C₁ C₁} {D' : twosided_disp_cat C₂ C₂} {FF : twosided_disp_functor F F D D'} {FF' : twosided_disp_functor F' F' D D'} {FF'' : twosided_disp_functor F'' F'' D D'} {ττ : twosided_disp_nat_trans τ τ FF FF'} {ττ' : twosided_disp_nat_trans τ' τ' FF' FF''} {I : hor_id D} {I' : hor_id D'} {FFI : double_functor_hor_id FF I I'} {FFI' : double_functor_hor_id FF' I I'} {FFI'' : double_functor_hor_id FF'' I I'} (ττI : double_nat_trans_hor_id ττ FFI FFI') (ττI' : double_nat_trans_hor_id ττ' FFI' FFI'') : double_nat_trans_hor_id (comp_twosided_disp_nat_trans ττ ττ') FFI FFI''. Proof. intros x ; cbn. etrans. { rewrite assoc_two_disp. rewrite (ττI x). rewrite two_disp_pre_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (ττI' x). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } refine (!_). rewrite double_id_mor_id_comp. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition pre_whisker_twosided_disp_nat_trans_hor_id {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G G' : C₂ ⟶ C₃} {τ : G ⟹ G'} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {GG' : twosided_disp_functor G' G' D₂ D₃} {ττ : twosided_disp_nat_trans τ τ GG GG'} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} (FFI : double_functor_hor_id FF I₁ I₂) {GGI : double_functor_hor_id GG I₂ I₃} {GGI' : double_functor_hor_id GG' I₂ I₃} (ττI : double_nat_trans_hor_id ττ GGI GGI') : double_nat_trans_hor_id (pre_whisker_twosided_disp_nat_trans FF ττ) (comp_hor_id FFI GGI) (comp_hor_id FFI GGI'). Proof. intros x ; cbn. etrans. { rewrite two_disp_pre_whisker_f. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite (pr2 ττ). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. etrans. { apply maponpaths. apply maponpaths_2. exact (ττI (F x)). } rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } refine (!_). etrans. { rewrite two_disp_post_whisker_f. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } use transportf_disp_mor2_eq. apply idpath. Qed. Proposition post_whisker_twosided_disp_nat_trans_hor_id {C₁ C₂ C₃ : category} {F F' : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {τ : F ⟹ F'} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {FF : twosided_disp_functor F F D₁ D₂} {FF' : twosided_disp_functor F' F' D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {ττ : twosided_disp_nat_trans τ τ FF FF'} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {FFI : double_functor_hor_id FF I₁ I₂} {FFI' : double_functor_hor_id FF' I₁ I₂} (GGI : double_functor_hor_id GG I₂ I₃) (ττI : double_nat_trans_hor_id ττ FFI FFI') : double_nat_trans_hor_id (post_whisker_twosided_disp_nat_trans GG ττ) (comp_hor_id FFI GGI) (comp_hor_id FFI' GGI). Proof. intros x ; cbn. etrans. { rewrite two_disp_pre_whisker_f. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp_alt. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite (ττI x). rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } refine (!_). etrans. { unfold transportb. rewrite two_disp_post_whisker_f. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. etrans. { apply maponpaths. apply maponpaths_2. exact (functor_double_id_eq GGI (τ x)). } rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. apply idpath. } use transportf_disp_mor2_eq. apply idpath. Qed. Proposition lunitor_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) : double_nat_trans_hor_id (id_twosided_disp_nat_trans _) (comp_hor_id (identity_hor_id _) FI) FI. Proof. intros x ; cbn. rewrite double_id_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_id. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition runitor_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) : double_nat_trans_hor_id (id_twosided_disp_nat_trans _) (comp_hor_id FI (identity_hor_id _)) FI. Proof. intros x ; cbn. rewrite double_id_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition linvunitor_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) : double_nat_trans_hor_id (id_twosided_disp_nat_trans _) FI (comp_hor_id (identity_hor_id _) FI). Proof. intros x ; cbn. rewrite double_id_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_id. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition rinvunitor_twosided_disp_nat_trans_hor_id {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {I₁ : hor_id D₁} {I₂ : hor_id D₂} (FI : double_functor_hor_id FF I₁ I₂) : double_nat_trans_hor_id (id_twosided_disp_nat_trans _) FI (comp_hor_id FI (identity_hor_id _)). Proof. intros x ; cbn. rewrite double_id_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition rassociator_twosided_disp_nat_trans_hor_id {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {D₄ : twosided_disp_cat C₄ C₄} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {HH : twosided_disp_functor H H D₃ D₄} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {I₄ : hor_id D₄} (FI : double_functor_hor_id FF I₁ I₂) (GI : double_functor_hor_id GG I₂ I₃) (HI : double_functor_hor_id HH I₃ I₄) : double_nat_trans_hor_id (id_twosided_disp_nat_trans (comp_twosided_disp_functor _ (comp_twosided_disp_functor _ _))) (comp_hor_id (comp_hor_id FI GI) HI) (comp_hor_id FI (comp_hor_id GI HI)). Proof. intros x ; cbn. rewrite transportf_twosided_disp_functor. rewrite !two_disp_post_whisker_f. rewrite !two_disp_pre_whisker_f. rewrite !two_disp_post_whisker_f. unfold transportb_disp_mor2. rewrite !transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite double_id_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. unfold transportb_disp_mor2. rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition lassociator_twosided_disp_nat_trans_hor_id {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {D₄ : twosided_disp_cat C₄ C₄} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {HH : twosided_disp_functor H H D₃ D₄} {I₁ : hor_id D₁} {I₂ : hor_id D₂} {I₃ : hor_id D₃} {I₄ : hor_id D₄} (FI : double_functor_hor_id FF I₁ I₂) (GI : double_functor_hor_id GG I₂ I₃) (HI : double_functor_hor_id HH I₃ I₄) : double_nat_trans_hor_id (id_twosided_disp_nat_trans (comp_twosided_disp_functor _ (comp_twosided_disp_functor _ _))) (comp_hor_id FI (comp_hor_id GI HI)) (comp_hor_id (comp_hor_id FI GI) HI). Proof. intros x ; cbn. rewrite transportf_twosided_disp_functor. rewrite !two_disp_post_whisker_f. rewrite !two_disp_pre_whisker_f. unfold transportb_disp_mor2. rewrite !transport_f_f_disp_mor2. rewrite id_two_disp_right. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite double_id_mor_id. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. unfold transportb_disp_mor2. rewrite !two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition id_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans FF) FC FC. Proof. intros x y z h k ; cbn. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition comp_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {F F' F'' : C₁ ⟶ C₂} {τ : F ⟹ F'} {τ' : F' ⟹ F''} {D : twosided_disp_cat C₁ C₁} {D' : twosided_disp_cat C₂ C₂} {FF : twosided_disp_functor F F D D'} {FF' : twosided_disp_functor F' F' D D'} {FF'' : twosided_disp_functor F'' F'' D D'} {ττ : twosided_disp_nat_trans τ τ FF FF'} {ττ' : twosided_disp_nat_trans τ' τ' FF' FF''} {Cm : hor_comp D} {Cm' : hor_comp D'} {FFC : double_functor_hor_comp FF Cm Cm'} {FFC' : double_functor_hor_comp FF' Cm Cm'} {FFC'' : double_functor_hor_comp FF'' Cm Cm'} (ττC : double_nat_trans_hor_comp ττ FFC FFC') (ττC' : double_nat_trans_hor_comp ττ' FFC' FFC'') : double_nat_trans_hor_comp (comp_twosided_disp_nat_trans ττ ττ') FFC FFC''. Proof. intros x y z h k ; cbn. rewrite assoc_two_disp. rewrite (ττC x). rewrite two_disp_pre_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. unfold transportb. rewrite (ττC' x). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite double_hor_comp_mor_comp. rewrite assoc_two_disp_alt. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition pre_whisker_twosided_disp_nat_trans_hor_comp {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G G' : C₂ ⟶ C₃} {τ : G ⟹ G'} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {GG' : twosided_disp_functor G' G' D₂ D₃} {ττ : twosided_disp_nat_trans τ τ GG GG'} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} (FFC : double_functor_hor_comp FF Cm₁ Cm₂) {GGC : double_functor_hor_comp GG Cm₂ Cm₃} {GGC' : double_functor_hor_comp GG' Cm₂ Cm₃} (ττC : double_nat_trans_hor_comp ττ GGC GGC') : double_nat_trans_hor_comp (pre_whisker_twosided_disp_nat_trans FF ττ) (comp_hor_comp FFC GGC) (comp_hor_comp FFC GGC'). Proof. intros x y z h k ; cbn. rewrite two_disp_pre_whisker_b. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (pr2 ττ). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite ττC. rewrite two_disp_pre_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition post_whisker_twosided_disp_nat_trans_hor_comp {C₁ C₂ C₃ : category} {F F' : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {τ : F ⟹ F'} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {FF : twosided_disp_functor F F D₁ D₂} {FF' : twosided_disp_functor F' F' D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {ττ : twosided_disp_nat_trans τ τ FF FF'} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {FFC : double_functor_hor_comp FF Cm₁ Cm₂} {FFC' : double_functor_hor_comp FF' Cm₁ Cm₂} (GGC : double_functor_hor_comp GG Cm₂ Cm₃) (ττC : double_nat_trans_hor_comp ττ FFC FFC') : double_nat_trans_hor_comp (post_whisker_twosided_disp_nat_trans GG ττ) (comp_hor_comp FFC GGC) (comp_hor_comp FFC' GGC). Proof. intros x y z h k ; cbn. rewrite two_disp_pre_whisker_b. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp_alt. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite (ττC x y z h k). rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (functor_double_comp_eq GGC _ _). unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition lunitor_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FI : double_functor_hor_comp FF Cm₁ Cm₂) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans _) (comp_hor_comp (identity_hor_comp _) FI) FI. Proof. intros x y z h k ; cbn. rewrite double_hor_comp_mor_id. rewrite two_disp_pre_whisker_b. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite twosided_disp_functor_id. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition runitor_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans _) (comp_hor_comp FC (identity_hor_comp _)) FC. Proof. intros x y z h k ; cbn. rewrite double_hor_comp_mor_id. rewrite two_disp_pre_whisker_b. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition linvunitor_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans _) FC (comp_hor_comp (identity_hor_comp _) FC). Proof. intros x y z h k ; cbn. rewrite double_hor_comp_mor_id. rewrite two_disp_post_whisker_b. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite twosided_disp_functor_id. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition rinvunitor_twosided_disp_nat_trans_hor_comp {C₁ C₂ : category} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {F : C₁ ⟶ C₂} {FF : twosided_disp_functor F F D₁ D₂} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} (FC : double_functor_hor_comp FF Cm₁ Cm₂) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans _) FC (comp_hor_comp FC (identity_hor_comp _)). Proof. intros x y z h k ; cbn. rewrite double_hor_comp_mor_id. rewrite two_disp_post_whisker_b. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition rassociator_twosided_disp_nat_trans_hor_comp {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {D₄ : twosided_disp_cat C₄ C₄} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {HH : twosided_disp_functor H H D₃ D₄} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {Cm₄ : hor_comp D₄} (FC : double_functor_hor_comp FF Cm₁ Cm₂) (GC : double_functor_hor_comp GG Cm₂ Cm₃) (HC : double_functor_hor_comp HH Cm₃ Cm₄) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans (comp_twosided_disp_functor _ (comp_twosided_disp_functor _ _))) (comp_hor_comp (comp_hor_comp FC GC) HC) (comp_hor_comp FC (comp_hor_comp GC HC)). Proof. intros x y z h k ; cbn. rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite two_disp_post_whisker_b. rewrite two_disp_pre_whisker_b. rewrite two_disp_post_whisker_b. rewrite !transport_b_b_disp_mor2. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Proposition lassociator_twosided_disp_nat_trans_hor_comp {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {D₁ : twosided_disp_cat C₁ C₁} {D₂ : twosided_disp_cat C₂ C₂} {D₃ : twosided_disp_cat C₃ C₃} {D₄ : twosided_disp_cat C₄ C₄} {FF : twosided_disp_functor F F D₁ D₂} {GG : twosided_disp_functor G G D₂ D₃} {HH : twosided_disp_functor H H D₃ D₄} {Cm₁ : hor_comp D₁} {Cm₂ : hor_comp D₂} {Cm₃ : hor_comp D₃} {Cm₄ : hor_comp D₄} (FC : double_functor_hor_comp FF Cm₁ Cm₂) (GC : double_functor_hor_comp GG Cm₂ Cm₃) (HC : double_functor_hor_comp HH Cm₃ Cm₄) : double_nat_trans_hor_comp (id_twosided_disp_nat_trans (comp_twosided_disp_functor _ (comp_twosided_disp_functor _ _))) (comp_hor_comp FC (comp_hor_comp GC HC)) (comp_hor_comp (comp_hor_comp FC GC) HC). Proof. intros x y z h k ; cbn. rewrite transportb_twosided_disp_functor. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite id_two_disp_right. rewrite transport_b_b_disp_mor2. rewrite two_disp_post_whisker_b. rewrite two_disp_pre_whisker_b. rewrite two_disp_post_whisker_b. rewrite !transport_b_b_disp_mor2. rewrite double_hor_comp_mor_id. rewrite id_two_disp_left. rewrite transport_b_b_disp_mor2. rewrite twosided_disp_functor_comp. rewrite two_disp_post_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp. rewrite transport_b_b_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/000077500000000000000000000000001451125700300242525ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/KleisliDoubleCat.v000066400000000000000000000131611451125700300276220ustar00rootroot00000000000000(********************************************************************************** The Kleisli double category Let `C` be a category and let `M` be a monad on `C`. Then we can define the following double category: - Objects: objects of `C` - Vertical morphisms: morphisms of `C` - Horizontal morphisms: Kleisli morphisms - Squares: commuting squares Contents 1. Horizontal operations 2. The Kleisli double category **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Comma. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. (** 1. Horizontal operations *) Section Kleisli. Context {C : univalent_category} (M : Monad C). Let K : twosided_disp_cat C C := comma_twosided_disp_cat (functor_identity C) M. Definition hor_id_data_kleisli : hor_id_data K. Proof. use make_hor_id_data ; cbn. - exact (λ x, η M x). - abstract (intros x y f ; cbn ; exact (nat_trans_ax (η M) _ _ f)). Defined. Proposition hor_id_laws_kleisli : hor_id_laws hor_id_data_kleisli. Proof. repeat split ; intros. - apply homset_property. - apply homset_property. Qed. Definition hor_id_kleisli : hor_id K. Proof. use make_hor_id. - exact hor_id_data_kleisli. - exact hor_id_laws_kleisli. Defined. Definition hor_comp_data_kleisli : hor_comp_data K. Proof. use make_hor_comp_data. - exact (λ x y z f g, f · #M g · μ M z). - abstract (intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn in * ; rewrite !assoc ; rewrite s₁ ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite <- functor_comp ; rewrite s₂ ; rewrite functor_comp ; rewrite !assoc' ; apply maponpaths ; exact (nat_trans_ax (μ M) _ _ v₃)). Defined. Definition hor_comp_laws_kleisli : hor_comp_laws hor_comp_data_kleisli. Proof. repeat split ; intros. - apply homset_property. - apply homset_property. Qed. Definition hor_comp_kleisli : hor_comp K. Proof. use make_hor_comp. - exact hor_comp_data_kleisli. - exact hor_comp_laws_kleisli. Defined. Definition double_cat_lunitor_kleisli : double_cat_lunitor hor_id_kleisli hor_comp_kleisli. Proof. use make_double_lunitor. - intros x y f ; cbn. use make_iso_twosided_disp. + cbn. rewrite id_left. rewrite functor_id. rewrite id_right. refine (!_). etrans. { apply maponpaths_2. exact (!(nat_trans_ax (η M) _ _ f)). } cbn. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply Monad_law1. + apply comma_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. Definition double_cat_runitor_kleisli : double_cat_runitor hor_id_kleisli hor_comp_kleisli. Proof. use make_double_runitor. - intros x y f ; cbn. use make_iso_twosided_disp. + cbn. rewrite id_left. rewrite functor_id. rewrite id_right. refine (!_). rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply Monad_law2. + apply comma_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. Definition double_cat_associator_kleisli : double_cat_associator hor_comp_kleisli. Proof. use make_double_associator. - intros w x y z h₁ h₂ h₃ ; cbn. use make_iso_twosided_disp. + cbn. rewrite id_left. rewrite functor_id. rewrite id_right. rewrite !assoc'. apply maponpaths. rewrite !functor_comp. rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. exact (!(nat_trans_ax (μ M) _ _ h₃)). } cbn. rewrite !assoc'. apply maponpaths. refine (!_). apply Monad_law3. + apply comma_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. (** 2. The Kleisli double category *) Definition kleisli_double_cat : double_cat. Proof. use make_double_cat. - exact C. - exact K. - exact hor_id_kleisli. - exact hor_comp_kleisli. - exact double_cat_lunitor_kleisli. - exact double_cat_runitor_kleisli. - exact double_cat_associator_kleisli. - abstract (intro ; intros ; apply homset_property). - abstract (intro ; intros ; apply homset_property). - apply univalent_category_is_univalent. - apply is_univalent_comma_twosided_disp_cat. Defined. End Kleisli. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/LensesDoubleCat.v000066400000000000000000000164471451125700300274710ustar00rootroot00000000000000(********************************************************************************** The double category of lenses In this file, we define the double category of lenses. Suppose that `C` is a category with binary products. Then we define the following double category: - Objects: those of `C` - Vertical morphisms: morphisms in `C` - Horizontal morphisms: lenses in `C` The squares in this double category are commutative squares. This double category is essentially also constructed in Proposition 2.0.4 in "Categories of Optics" by Riley ( https://arxiv.org/pdf/1809.00738.pdf). There are two difference between the formalization in this file and the reference. In the reference, a category of lenses is constructed, and this amounts to constructing the horizontal composition and identities of lenses, whereas here a double category is constructed. The other difference is the method taken: the reference uses an abstract theorem about optics, whereas we construct the desired double category directly. Note that a double category of lenses has also been considered by Clarke in "The double category of lenses" (https://figshare.mq.edu.au/articles/thesis/The_double_category_of_lenses/22045073/1). The difference between the formalization and that thesis is that a different notion of lens is considered. Clarke looks at delta-lenses, so the resulting double category is as follows: - Objects: categories - Vertical morphisms: delta-lenses - Horizontal morphisms: functors This is different from what we look at, because we look at lenses in a category with finite products. Contents 1. The horizontal identity 2. Horizontal composition 3. Unitors and associators 4. The double category **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Lenses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. Section LensesDoubleCat. Context (C : univalent_category) (PC : BinProducts C). (** 1. The horizontal identity *) Definition lenses_double_cat_hor_id_data : hor_id_data (twosided_disp_cat_of_lenses C PC). Proof. use make_hor_id_data. - exact (identity_lens _ _). - exact (λ x y f, identity_lens_mor _ _ f). Defined. Definition lenses_double_cat_hor_id : hor_id (twosided_disp_cat_of_lenses C PC). Proof. use make_hor_id. - exact lenses_double_cat_hor_id_data. - abstract (split ; intros ; apply discrete_lenses_twosided_disp_cat). Defined. (** 2. Horizontal composition *) Definition lenses_double_cat_hor_comp_data : hor_comp_data (twosided_disp_cat_of_lenses C PC). Proof. use make_hor_comp_data. - exact (λ x y z l₁ l₂, comp_lens _ _ l₁ l₂). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ φ ψ, comp_lens_mor _ _ φ ψ). Defined. Definition lenses_double_cat_hor_comp : hor_comp (twosided_disp_cat_of_lenses C PC). Proof. use make_hor_comp. - exact lenses_double_cat_hor_comp_data. - abstract (split ; intros ; apply discrete_lenses_twosided_disp_cat). Defined. (** 3. Unitors and associators *) Definition lenses_double_cat_lunitor : double_cat_lunitor lenses_double_cat_hor_id lenses_double_cat_hor_comp. Proof. use make_double_lunitor. - intros x y f. use make_iso_twosided_disp. + use make_lens_mor ; cbn. * rewrite !id_left, !id_right. apply idpath. * rewrite id_right. rewrite !assoc'. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductPr1Commutes. rewrite id_left. apply idpath. + apply discrete_lenses_twosided_disp_cat. - intro ; intros. apply discrete_lenses_twosided_disp_cat. Qed. Definition lenses_double_cat_runitor : double_cat_runitor lenses_double_cat_hor_id lenses_double_cat_hor_comp. Proof. use make_double_runitor. - intros x y f. use make_iso_twosided_disp. + use make_lens_mor ; cbn. * rewrite !id_left, !id_right. apply idpath. * rewrite id_right. rewrite !assoc'. rewrite BinProductOfArrows_id. rewrite !assoc. apply maponpaths_2. refine (_ @ !(BinProductArrowEta _ _ _ _ _ _)). rewrite postcompWithBinProductArrow. rewrite !id_left, !id_right. rewrite BinProductOfArrowsPr1. rewrite id_right. apply idpath. + apply discrete_lenses_twosided_disp_cat. - intro ; intros. apply discrete_lenses_twosided_disp_cat. Qed. Definition lenses_double_cat_associator : double_cat_associator lenses_double_cat_hor_comp. Proof. use make_double_associator. - intros w x y z f g h. use make_iso_twosided_disp. + use make_lens_mor ; cbn. * rewrite !id_left, !id_right. rewrite !assoc. apply idpath. * rewrite id_right. rewrite !assoc'. rewrite BinProductOfArrows_id. rewrite !assoc. apply maponpaths_2. rewrite id_left. rewrite !postcompWithBinProductArrow. rewrite !precompWithBinProductArrow. rewrite id_right. rewrite !postcompWithBinProductArrow. rewrite !id_left, !id_right. rewrite BinProductOfArrowsPr2. rewrite BinProductPr2Commutes. apply maponpaths_2. rewrite !assoc. apply maponpaths_2. rewrite !postcompWithBinProductArrow. apply maponpaths_2. rewrite id_right. apply maponpaths_2. rewrite BinProductOfArrows_comp. rewrite id_right. apply idpath. + apply discrete_lenses_twosided_disp_cat. - intro ; intros. apply discrete_lenses_twosided_disp_cat. Qed. (** 4. The double category *) Definition lenses_double_cat : double_cat. Proof. use make_double_cat. - exact C. - exact (twosided_disp_cat_of_lenses C PC). - exact lenses_double_cat_hor_id. - exact lenses_double_cat_hor_comp. - exact lenses_double_cat_lunitor. - exact lenses_double_cat_runitor. - exact lenses_double_cat_associator. - abstract (intro ; intros ; apply discrete_lenses_twosided_disp_cat). - abstract (intro ; intros ; apply discrete_lenses_twosided_disp_cat). - apply univalent_category_is_univalent. - apply is_univalent_lenses_twosided_disp_cat. Defined. End LensesDoubleCat. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/ProductDoubleCat.v000066400000000000000000000217771451125700300276620ustar00rootroot00000000000000(************************************************************************************ The product of double categories In this file, we define the product of double categories. Given double categories `D₁` and `D₂`, the product of `D₁` and `D₂` is defined as follows: - Objects: pairs of objects in `D₁` and `D₂` - Vertical morphisms: pairs of vertical morphisms in `D₁` and `D₂` - Horizontal morphisms: pairs of horizontal morphisms in `D₁` and `D₂` - Squares: pairs of squares in `D₁` and `D₂` The operations are defined coordinate-wise. Contents 1. Horizontal identity and composition 2. Unitors and associator 3. The triangle and pentagon 4. The product of double categories ************************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.ProdOfTwosidedDispCat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. Local Open Scope double_cat. Section ProdOfDoubleCat. Context (D₁ D₂ : double_cat). (** 1. Horizontal identity and composition *) Definition prod_double_cat_hor_id_data : hor_id_data (twosided_disp_cat_product (hor_mor D₁) (hor_mor D₂)). Proof. use make_hor_id_data. - exact (λ wx, identity_h (pr1 wx) ,, identity_h (pr2 wx)). - exact (λ wx yz fg, id_h_square (pr1 fg) ,, id_h_square (pr2 fg)). Defined. Proposition prod_double_cat_hor_id_laws : hor_id_laws prod_double_cat_hor_id_data. Proof. split. - intros x. use dirprodeq ; cbn. + apply id_h_square_id. + apply id_h_square_id. - intros x y z f g. use dirprodeq ; cbn. + apply id_h_square_comp. + apply id_h_square_comp. Qed. Definition prod_double_cat_hor_id : hor_id (twosided_disp_cat_product (hor_mor D₁) (hor_mor D₂)). Proof. use make_hor_id. - exact prod_double_cat_hor_id_data. - exact prod_double_cat_hor_id_laws. Defined. Definition prod_double_cat_hor_comp_data : hor_comp_data (twosided_disp_cat_product (hor_mor D₁) (hor_mor D₂)). Proof. use make_hor_comp_data. - exact (λ xy₁ xy₂ xy₃ fg hk, pr1 fg ·h pr1 hk ,, pr2 fg ·h pr2 hk). - exact (λ x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂, comp_h_square (pr1 s₁) (pr1 s₂) ,, comp_h_square (pr2 s₁) (pr2 s₂)). Defined. Proposition prod_double_cat_hor_comp_laws : hor_comp_laws prod_double_cat_hor_comp_data. Proof. split. - intros. use dirprodeq ; cbn. + apply comp_h_square_id. + apply comp_h_square_id. - intros. use dirprodeq ; cbn. + apply comp_h_square_comp. + apply comp_h_square_comp. Qed. Definition prod_double_cat_hor_comp : hor_comp (twosided_disp_cat_product (hor_mor D₁) (hor_mor D₂)). Proof. use make_hor_comp. - exact prod_double_cat_hor_comp_data. - exact prod_double_cat_hor_comp_laws. Defined. (** 2. Unitors and associator *) Definition prod_double_cat_lunitor_data : double_lunitor_data prod_double_cat_hor_id prod_double_cat_hor_comp. Proof. simple refine (λ x y h, (lunitor_h (pr1 h) ,, lunitor_h (pr2 h)) ,, _). use is_isotwosided_disp_twosided_disp_cat_product. - refine (linvunitor_h (pr1 h) ,, _ ,, _). + apply lunitor_linvunitor_h. + apply linvunitor_lunitor_h. - refine (linvunitor_h (pr2 h) ,, _ ,, _). + apply lunitor_linvunitor_h. + apply linvunitor_lunitor_h. Defined. Proposition prod_double_cat_lunitor_laws : double_lunitor_laws prod_double_cat_lunitor_data. Proof. intro ; intros ; cbn. rewrite transportb_twosided_disp_cat_product. use dirprodeq ; cbn. - refine (_ @ !(lunitor_square _)). apply transportb_disp_mor2_eq. apply idpath. - refine (_ @ !(lunitor_square _)). apply transportb_disp_mor2_eq. apply idpath. Qed. Definition prod_double_cat_lunitor : double_cat_lunitor prod_double_cat_hor_id prod_double_cat_hor_comp. Proof. use make_double_lunitor. - exact prod_double_cat_lunitor_data. - exact prod_double_cat_lunitor_laws. Defined. Definition prod_double_cat_runitor_data : double_runitor_data prod_double_cat_hor_id prod_double_cat_hor_comp. Proof. simple refine (λ x y h, (runitor_h (pr1 h) ,, runitor_h (pr2 h)) ,, _). use is_isotwosided_disp_twosided_disp_cat_product. - refine (rinvunitor_h (pr1 h) ,, _ ,, _). + apply runitor_rinvunitor_h. + apply rinvunitor_runitor_h. - refine (rinvunitor_h (pr2 h) ,, _ ,, _). + apply runitor_rinvunitor_h. + apply rinvunitor_runitor_h. Defined. Proposition prod_double_cat_runitor_laws : double_runitor_laws prod_double_cat_runitor_data. Proof. intro ; intros ; cbn. rewrite transportb_twosided_disp_cat_product. use dirprodeq ; cbn. - refine (_ @ !(runitor_square _)). apply transportb_disp_mor2_eq. apply idpath. - refine (_ @ !(runitor_square _)). apply transportb_disp_mor2_eq. apply idpath. Qed. Definition prod_double_cat_runitor : double_cat_runitor prod_double_cat_hor_id prod_double_cat_hor_comp. Proof. use make_double_runitor. - exact prod_double_cat_runitor_data. - exact prod_double_cat_runitor_laws. Defined. Definition prod_double_cat_associator_data : double_associator_data prod_double_cat_hor_comp. Proof. refine (λ w x y z f g h, (lassociator_h (pr1 f) (pr1 g) (pr1 h) ,, lassociator_h (pr2 f) (pr2 g) (pr2 h)) ,, _). use is_isotwosided_disp_twosided_disp_cat_product. - refine (rassociator_h (pr1 f) (pr1 g) (pr1 h) ,, _ ,, _). + apply lassociator_rassociator_h. + apply rassociator_lassociator_h. - refine (rassociator_h (pr2 f) (pr2 g) (pr2 h) ,, _ ,, _). + apply lassociator_rassociator_h. + apply rassociator_lassociator_h. Defined. Proposition prod_double_cat_associator_laws : double_associator_laws prod_double_cat_associator_data. Proof. intro ; intros ; cbn. rewrite transportb_twosided_disp_cat_product. use dirprodeq ; cbn. - refine (_ @ !(lassociator_h_square _ _ _)). apply transportb_disp_mor2_eq. apply idpath. - refine (_ @ !(lassociator_h_square _ _ _)). apply transportb_disp_mor2_eq. apply idpath. Qed. Definition prod_double_cat_associator : double_cat_associator prod_double_cat_hor_comp. Proof. use make_double_associator. - exact prod_double_cat_associator_data. - exact prod_double_cat_associator_laws. Defined. (** 3. The triangle and pentagon *) Proposition prod_double_cat_triangle : triangle_law prod_double_cat_lunitor prod_double_cat_runitor prod_double_cat_associator. Proof. intro ; intros ; cbn. rewrite transportb_twosided_disp_cat_product. use dirprodeq ; cbn. - refine (double_triangle _ _ @ _). apply transportb_disp_mor2_eq. apply idpath. - refine (double_triangle _ _ @ _). apply transportb_disp_mor2_eq. apply idpath. Qed. Proposition prod_double_cat_pentagon : pentagon_law prod_double_cat_associator. Proof. intro ; intros ; cbn. rewrite transportb_twosided_disp_cat_product. use dirprodeq ; cbn. - refine (_ @ double_pentagon _ _ _ _). apply transportb_disp_mor2_eq. apply idpath. - refine (_ @ double_pentagon _ _ _ _). apply transportb_disp_mor2_eq. apply idpath. Qed. (** 4. The product of double categories *) Definition prod_double_cat : double_cat. Proof. use make_double_cat. - exact (univalent_category_binproduct D₁ D₂). - exact (twosided_disp_cat_product (hor_mor D₁) (hor_mor D₂)). - exact prod_double_cat_hor_id. - exact prod_double_cat_hor_comp. - exact prod_double_cat_lunitor. - exact prod_double_cat_runitor. - exact prod_double_cat_associator. - exact prod_double_cat_triangle. - exact prod_double_cat_pentagon. - apply univalent_category_is_univalent. - use is_univalent_twosided_disp_cat_product. + apply is_univalent_twosided_disp_cat_hor_mor. + apply is_univalent_twosided_disp_cat_hor_mor. Defined. End ProdOfDoubleCat. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/SpansDoubleCat.v000066400000000000000000000302431451125700300273120ustar00rootroot00000000000000(********************************************************************************** The double category of spans In this file, we define the double category of spans. If `C` is a category with pullbacks, then we have the following double category: - Objects: objects in `C` - Vertical morphisms: morphisms in `C` - Horizontal morphisms: spans in `C` - Squares: morphisms of spans Spans are composed by taking a pullback. Contents 1. Horizontal identities 2. Horizontal composition 3. The unitors and associators 4. The triangle and pentagon equations 5. The double category of spans **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Spans. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. Section SpansDoubleCat. Context {C : univalent_category} (PC : Pullbacks C). (** 1. Horizontal identities *) Definition spans_double_cat_hor_id_data : hor_id_data (twosided_disp_cat_of_spans C). Proof. use make_hor_id_data. - exact (id_span C). - exact (λ x y f, id_span_mor C f). Defined. Proposition spans_double_cat_hor_id_laws : hor_id_laws spans_double_cat_hor_id_data. Proof. split. - intros a. use span_sqr_eq ; cbn. apply idpath. - intros a₁ a₂ a₃ f g. use span_sqr_eq ; cbn. apply idpath. Qed. Definition spans_double_cat_hor_id : hor_id (twosided_disp_cat_of_spans C). Proof. use make_hor_id. - exact spans_double_cat_hor_id_data. - exact spans_double_cat_hor_id_laws. Defined. (** 2. Horizontal composition *) Definition spans_double_cat_hor_comp_data : hor_comp_data (twosided_disp_cat_of_spans C). Proof. use make_hor_comp_data. - exact (λ a₁ a₂ a₃ s t, comp_span C PC s t). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ s₁ s₂, comp_span_mor C PC s₁ s₂). Defined. Proposition spans_double_cat_hor_comp_laws : hor_comp_laws spans_double_cat_hor_comp_data. Proof. split. - intros a₁ a₂ a₃ h₁ h₂. use span_sqr_eq. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + unfold mor_of_comp_span_mor. rewrite PullbackArrow_PullbackPr1 ; cbn. rewrite id_left, id_right. apply idpath. + unfold mor_of_comp_span_mor. rewrite PullbackArrow_PullbackPr2 ; cbn. rewrite id_left, id_right. apply idpath. - intros. use span_sqr_eq. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite !assoc'. unfold mor_of_comp_span_mor. rewrite !PullbackArrow_PullbackPr1 ; cbn. rewrite !assoc. rewrite !PullbackArrow_PullbackPr1. rewrite !assoc'. apply idpath. + rewrite !assoc'. unfold mor_of_comp_span_mor. rewrite !PullbackArrow_PullbackPr2 ; cbn. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. apply idpath. Qed. Definition spans_double_cat_hor_comp : hor_comp (twosided_disp_cat_of_spans C). Proof. use make_hor_comp. - exact spans_double_cat_hor_comp_data. - exact spans_double_cat_hor_comp_laws. Defined. (** 3. The unitors and associators *) Definition spans_double_cat_lunitor_data : double_lunitor_data spans_double_cat_hor_id spans_double_cat_hor_comp. Proof. intros x y h. simple refine (_ ,, _). - exact (span_lunitor C PC h). - use is_iso_twosided_disp_span_sqr ; cbn. apply is_z_iso_span_lunitor_mor. Defined. Proposition spans_double_cat_lunitor_laws : double_lunitor_laws spans_double_cat_lunitor_data. Proof. intros x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ sq. use span_sqr_eq. rewrite transportb_disp_mor2_span ; cbn. unfold span_lunitor_mor, mor_of_comp_span_mor. rewrite PullbackArrow_PullbackPr2. apply idpath. Qed. Definition spans_double_cat_lunitor : double_cat_lunitor spans_double_cat_hor_id spans_double_cat_hor_comp. Proof. use make_double_lunitor. - exact spans_double_cat_lunitor_data. - exact spans_double_cat_lunitor_laws. Defined. Definition spans_double_cat_runitor_data : double_runitor_data spans_double_cat_hor_id spans_double_cat_hor_comp. Proof. intros x y h. simple refine (_ ,, _). - exact (span_runitor C PC h). - use is_iso_twosided_disp_span_sqr ; cbn. apply is_z_iso_span_runitor_mor. Defined. Proposition spans_double_cat_runitor_laws : double_runitor_laws spans_double_cat_runitor_data. Proof. intros x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ sq. use span_sqr_eq. rewrite transportb_disp_mor2_span ; cbn. unfold span_runitor_mor, mor_of_comp_span_mor. rewrite PullbackArrow_PullbackPr1. apply idpath. Qed. Definition spans_double_cat_runitor : double_cat_runitor spans_double_cat_hor_id spans_double_cat_hor_comp. Proof. use make_double_runitor. - exact spans_double_cat_runitor_data. - exact spans_double_cat_runitor_laws. Defined. Definition spans_double_cat_associator_data : double_associator_data spans_double_cat_hor_comp. Proof. intros w x y z h₁ h₂ h₃. simple refine (_ ,, _). - exact (span_associator C PC h₁ h₂ h₃). - use is_iso_twosided_disp_span_sqr ; cbn. apply is_z_iso_span_associator_mor. Defined. Proposition spans_double_cat_associator_laws : double_associator_laws spans_double_cat_associator_data. Proof. intros w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ h₁ h₂ j₁ j₂ k₁ k₂ vw vx vy vz sq₁ sq₂ sq₃. use span_sqr_eq. rewrite transportb_disp_mor2_span ; cbn. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. - rewrite !assoc'. unfold span_associator_mor, mor_of_comp_span_mor ; cbn. rewrite !PullbackArrow_PullbackPr1. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. unfold mor_of_comp_span_mor. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. apply idpath. + rewrite !assoc'. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. apply idpath. - rewrite !assoc'. unfold span_associator_mor, mor_of_comp_span_mor ; cbn. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. apply maponpaths. unfold mor_of_comp_span_mor. rewrite !PullbackArrow_PullbackPr2. apply idpath. Qed. Definition spans_double_cat_associator : double_cat_associator spans_double_cat_hor_comp. Proof. use make_double_associator. - exact spans_double_cat_associator_data. - exact spans_double_cat_associator_laws. Defined. (** 4. The triangle and pentagon equations *) Proposition spans_double_cat_triangle : triangle_law spans_double_cat_lunitor spans_double_cat_runitor spans_double_cat_associator. Proof. intro ; intros. use span_sqr_eq. rewrite transportb_disp_mor2_span ; cbn. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. - unfold span_associator_mor, mor_of_comp_span_mor ; cbn. rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. unfold span_runitor_mor. rewrite PullbackArrow_PullbackPr1, id_right. apply idpath. - unfold span_associator_mor, mor_of_comp_span_mor ; cbn. rewrite !assoc'. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc. rewrite PullbackArrow_PullbackPr2. refine (id_right _ @ _). apply idpath. Qed. Proposition spans_double_cat_pentagon : pentagon_law spans_double_cat_associator. Proof. intro ; intros. use span_sqr_eq. rewrite transportb_disp_mor2_span ; cbn. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. - unfold span_associator_mor, mor_of_comp_span_mor ; cbn. rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite !assoc'. unfold span_associator_mor. rewrite !PullbackArrow_PullbackPr1. refine (!_). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). rewrite PullbackArrow_PullbackPr1. apply idpath. } use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. * rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. apply id_right. * rewrite !assoc'. rewrite !PullbackArrow_PullbackPr2. etrans. { apply maponpaths. refine (assoc _ _ _ @ _). rewrite !PullbackArrow_PullbackPr2. apply idpath. } rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite !PullbackArrow_PullbackPr1. apply idpath. + rewrite !assoc'. unfold span_associator_mor. rewrite !PullbackArrow_PullbackPr2. refine (!_). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). rewrite PullbackArrow_PullbackPr1. refine (assoc _ _ _ @ _). rewrite PullbackArrow_PullbackPr2. apply idpath. } rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. rewrite PullbackArrow_PullbackPr2. apply idpath. - unfold span_associator_mor, mor_of_comp_span_mor. rewrite !assoc'. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). rewrite PullbackArrow_PullbackPr2. apply idpath. } rewrite !assoc. unfold span_sqr_ob_mor ; cbn. rewrite id_right. rewrite PullbackArrow_PullbackPr2. unfold span_associator_mor . rewrite !assoc'. rewrite PullbackArrow_PullbackPr2. apply idpath. Qed. (** 5. The double category of spans *) Definition spans_double_cat : double_cat. Proof. use make_double_cat. - exact C. - exact (twosided_disp_cat_of_spans C). - exact spans_double_cat_hor_id. - exact spans_double_cat_hor_comp. - exact spans_double_cat_lunitor. - exact spans_double_cat_runitor. - exact spans_double_cat_associator. - exact spans_double_cat_triangle. - exact spans_double_cat_pentagon. - apply univalent_category_is_univalent. - use is_univalent_spans_twosided_disp_cat. apply univalent_category_is_univalent. Defined. End SpansDoubleCat. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/SquareDoubleCat.v000066400000000000000000000134531451125700300274720ustar00rootroot00000000000000(********************************************************************************** The square double category of a category In this file, we construct a double category from any category `C`. This double category is called the square double category. The objects in this double category are objects in `C`, horizontal and vertical morphisms in this double category are morphisms in `C`, and the squares in this double category are commutative squares in `C`. To define this double category, we use the 2-sided displayed category of arrows. The operations on horizontal morphisms are inherited from `C`. Contents 1. Horizontal operations 2. The square double category **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Arrow. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. (** 1. Horizontal operations *) Section ArrowDoubleCategory. Context (C : category). Definition hor_id_data_arrow_twosided_disp_cat : hor_id_data (arrow_twosided_disp_cat C). Proof. use make_hor_id_data ; cbn. - exact (λ x, identity x). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Proposition hor_id_laws_arrow_twosided_disp_cat : hor_id_laws hor_id_data_arrow_twosided_disp_cat. Proof. repeat split ; intros. - apply homset_property. - apply homset_property. Qed. Definition hor_id_arrow_twosided_disp_cat : hor_id (arrow_twosided_disp_cat C). Proof. use make_hor_id. - exact hor_id_data_arrow_twosided_disp_cat. - exact hor_id_laws_arrow_twosided_disp_cat. Defined. Definition hor_comp_data_arrow_twosided_disp_cat : hor_comp_data (arrow_twosided_disp_cat C). Proof. use make_hor_comp_data. - exact (λ x y z f g, f · g). - abstract (intros x₁ x₂ y₁ y₂ z₁ z₂ v₁ v₂ v₃ h₁ h₂ k₁ k₂ s₁ s₂ ; cbn in * ; rewrite !assoc ; rewrite s₁ ; rewrite !assoc' ; rewrite s₂ ; apply idpath). Defined. Definition hor_comp_laws_arrow_twosided_disp_cat : hor_comp_laws hor_comp_data_arrow_twosided_disp_cat. Proof. repeat split ; intros. - apply homset_property. - apply homset_property. Qed. Definition hor_comp_arrow_twosided_disp_cat : hor_comp (arrow_twosided_disp_cat C). Proof. use make_hor_comp. - exact hor_comp_data_arrow_twosided_disp_cat. - exact hor_comp_laws_arrow_twosided_disp_cat. Defined. Definition double_cat_lunitor_arrow_twosided_disp_cat : double_cat_lunitor hor_id_arrow_twosided_disp_cat hor_comp_arrow_twosided_disp_cat. Proof. use make_double_lunitor. - intros x y f ; cbn. use make_iso_twosided_disp. + abstract (cbn ; rewrite !id_left, !id_right ; apply idpath). + apply arrow_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. Definition double_cat_runitor_arrow_twosided_disp_cat : double_cat_runitor hor_id_arrow_twosided_disp_cat hor_comp_arrow_twosided_disp_cat. Proof. use make_double_runitor. - intros x y f ; cbn. use make_iso_twosided_disp. + abstract (cbn ; rewrite !id_left, !id_right ; apply idpath). + apply arrow_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. Definition double_cat_associator_arrow_twosided_disp_cat : double_cat_associator hor_comp_arrow_twosided_disp_cat. Proof. use make_double_associator. - intros w x y z h₁ h₂ h₃ ; cbn. use make_iso_twosided_disp. + abstract (cbn ; rewrite !id_left, !id_right, !assoc' ; apply idpath). + apply arrow_twosided_disp_cat_is_iso. - intro ; intros. apply homset_property. Qed. Proposition triangle_law_arrow_twosided_disp_cat : triangle_law double_cat_lunitor_arrow_twosided_disp_cat double_cat_runitor_arrow_twosided_disp_cat double_cat_associator_arrow_twosided_disp_cat. Proof. intro ; intros. apply homset_property. Qed. Proposition pentagon_law_arrow_twosided_disp_cat : pentagon_law double_cat_associator_arrow_twosided_disp_cat. Proof. intro ; intros. apply homset_property. Qed. End ArrowDoubleCategory. (** 2. The square double category *) Definition square_double_cat (C : univalent_category) : double_cat. Proof. use make_double_cat. - exact C. - exact (arrow_twosided_disp_cat C). - exact (hor_id_arrow_twosided_disp_cat C). - exact (hor_comp_arrow_twosided_disp_cat C). - exact (double_cat_lunitor_arrow_twosided_disp_cat C). - exact (double_cat_runitor_arrow_twosided_disp_cat C). - exact (double_cat_associator_arrow_twosided_disp_cat C). - exact (triangle_law_arrow_twosided_disp_cat C). - exact (pentagon_law_arrow_twosided_disp_cat C). - apply univalent_category_is_univalent. - apply is_univalent_arrow_twosided_disp_cat. Defined. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/StructuredCospansDoubleCat.v000066400000000000000000000401131451125700300317160ustar00rootroot00000000000000(********************************************************************************** The double category of structured cospans In this file, we define the double category of structured cospans. Suppose that we have categories `A` and `X` such that `X` has pushouts and suppose that we also have a functor `L : A ⟶ X`. The double category of structured cospans is defined as follows: - Objects: objects of `A` - Vertical morphisms: morphisms in `A` - Horizontal morphisms from `a` to `b`: structured cospans. Concretely, an object `x` together with morphisms `L a --> x <-- L b`. - The squares from `L a₁ <-- x₁ --> L b₁` to `L a₂ <-- x₂ --> L b₂` whose vertical sides are `f : a₁ --> a₂` and `g : b₁ --> b₂` are morphisms `φ : x₁ --> x₂` such that the following squares commute L a₁ <-- x₁ --> L b₂ | | | V V V L a₂ <-- x₂ --> L b₂ Identities and composition of vertical morphisms is inherited from `A`. The identity structured cospans is `L a <-- L a --> L a`, and the composition of structured cospans is given by taking a pushout. A reference for this construction is Theorem 3.1 in "Structured Versus Decorated Cospans" by Baez, Courser, and Vasilakopoulou. https://compositionality-journal.org/papers/compositionality-4-3/pdf Note: we do not show that this double category is monoidal. Contents 1. Horizontal identities 2. Horizontal composition 3. The unitors and associators 4. The triangle and pentagon equations 5. The double category of structured cospans **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.StructuredCospans. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. Section StructuredCospansDoubleCat. Context {A X : univalent_category} (PX : Pushouts X) (L : A ⟶ X). (** 1. Horizontal identities *) Definition structured_cospans_double_cat_hor_id_data : hor_id_data (twosided_disp_cat_of_struct_cospans L). Proof. use make_hor_id_data. - exact (id_struct_cospan L). - exact (λ x y f, id_struct_cospan_mor L f). Defined. Proposition structured_cospans_double_cat_hor_id_laws : hor_id_laws structured_cospans_double_cat_hor_id_data. Proof. split. - intros a. use struct_cospan_sqr_eq ; cbn. apply functor_id. - intros a₁ a₂ a₃ f g. use struct_cospan_sqr_eq ; cbn. apply functor_comp. Qed. Definition structured_cospans_double_cat_hor_id : hor_id (twosided_disp_cat_of_struct_cospans L). Proof. use make_hor_id. - exact structured_cospans_double_cat_hor_id_data. - exact structured_cospans_double_cat_hor_id_laws. Defined. (** 2. Horizontal composition *) Definition structured_cospans_double_cat_hor_comp_data : hor_comp_data (twosided_disp_cat_of_struct_cospans L). Proof. use make_hor_comp_data. - exact (λ a₁ a₂ a₃ s t, comp_struct_cospan L PX s t). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ s₁ s₂, comp_struct_cospan_mor L PX s₁ s₂). Defined. Proposition structured_cospans_double_cat_hor_comp_laws : hor_comp_laws structured_cospans_double_cat_hor_comp_data. Proof. split. - intros a₁ a₂ a₃ h₁ h₂. use struct_cospan_sqr_eq. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + unfold mor_of_comp_struct_cospan_mor. rewrite PushoutArrow_PushoutIn1 ; cbn. rewrite id_left, id_right. apply idpath. + unfold mor_of_comp_struct_cospan_mor. rewrite PushoutArrow_PushoutIn2 ; cbn. rewrite id_left, id_right. apply idpath. - intros. use struct_cospan_sqr_eq. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. unfold mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn1 ; cbn. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc. apply idpath. + rewrite !assoc. unfold mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn2 ; cbn. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc. apply idpath. Qed. Definition structured_cospans_double_cat_hor_comp : hor_comp (twosided_disp_cat_of_struct_cospans L). Proof. use make_hor_comp. - exact structured_cospans_double_cat_hor_comp_data. - exact structured_cospans_double_cat_hor_comp_laws. Defined. (** 3. The unitors and associators *) Definition structured_cospans_double_cat_lunitor_data : double_lunitor_data structured_cospans_double_cat_hor_id structured_cospans_double_cat_hor_comp. Proof. intros x y h. simple refine (_ ,, _). - exact (struct_cospan_lunitor L PX h). - use is_iso_twosided_disp_struct_cospan_sqr ; cbn. apply is_z_iso_struct_cospan_lunitor_mor. Defined. Proposition structured_cospans_double_cat_lunitor_laws : double_lunitor_laws structured_cospans_double_cat_lunitor_data. Proof. intros x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ sq. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. - rewrite !assoc. unfold struct_cospan_lunitor_mor, mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. exact (struct_cospan_sqr_mor_left _ sq). - rewrite !assoc. unfold struct_cospan_lunitor_mor, mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. rewrite id_left, id_right. apply idpath. Qed. Definition structured_cospans_double_cat_lunitor : double_cat_lunitor structured_cospans_double_cat_hor_id structured_cospans_double_cat_hor_comp. Proof. use make_double_lunitor. - exact structured_cospans_double_cat_lunitor_data. - exact structured_cospans_double_cat_lunitor_laws. Defined. Definition structured_cospans_double_cat_runitor_data : double_runitor_data structured_cospans_double_cat_hor_id structured_cospans_double_cat_hor_comp. Proof. intros x y h. simple refine (_ ,, _). - exact (struct_cospan_runitor L PX h). - use is_iso_twosided_disp_struct_cospan_sqr ; cbn. apply is_z_iso_struct_cospan_runitor_mor. Defined. Proposition structured_cospans_double_cat_runitor_laws : double_runitor_laws structured_cospans_double_cat_runitor_data. Proof. intros x₁ x₂ y₁ y₂ h₁ h₂ v₁ v₂ sq. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. - rewrite !assoc. unfold struct_cospan_runitor_mor, mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. rewrite id_left, id_right. apply idpath. - rewrite !assoc. unfold struct_cospan_runitor_mor, mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. exact (struct_cospan_sqr_mor_right _ sq). Qed. Definition structured_cospans_double_cat_runitor : double_cat_runitor structured_cospans_double_cat_hor_id structured_cospans_double_cat_hor_comp. Proof. use make_double_runitor. - exact structured_cospans_double_cat_runitor_data. - exact structured_cospans_double_cat_runitor_laws. Defined. Definition structured_cospans_double_cat_associator_data : double_associator_data structured_cospans_double_cat_hor_comp. Proof. intros w x y z h₁ h₂ h₃. simple refine (_ ,, _). - exact (struct_cospan_associator L PX h₁ h₂ h₃). - use is_iso_twosided_disp_struct_cospan_sqr ; cbn. apply is_z_iso_struct_cospan_associator_mor. Defined. Proposition structured_cospans_double_cat_associator_laws : double_associator_laws structured_cospans_double_cat_associator_data. Proof. intros w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂ h₁ h₂ j₁ j₂ k₁ k₂ vw vx vy vz sq₁ sq₂ sq₃. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. - rewrite !assoc. unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor ; cbn. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. unfold mor_of_comp_struct_cospan_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. apply idpath. - rewrite !assoc. unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn2. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. unfold mor_of_comp_struct_cospan_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. rewrite PushoutArrow_PushoutIn1. apply idpath. + rewrite !assoc. unfold mor_of_comp_struct_cospan_mor. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn2. apply idpath. Qed. Definition structured_cospans_double_cat_associator : double_cat_associator structured_cospans_double_cat_hor_comp. Proof. use make_double_associator. - exact structured_cospans_double_cat_associator_data. - exact structured_cospans_double_cat_associator_laws. Defined. (** 4. The triangle and pentagon equations *) Proposition structured_cospans_double_cat_triangle : triangle_law structured_cospans_double_cat_lunitor structured_cospans_double_cat_runitor structured_cospans_double_cat_associator. Proof. intro ; intros. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. - unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor ; cbn. rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. rewrite id_left. unfold struct_cospan_runitor_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. apply id_left. - unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor ; cbn. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. unfold struct_cospan_lunitor_mor, struct_cospan_runitor_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. rewrite PushoutSqrCommutes. apply idpath. + rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. rewrite !id_left. apply idpath. Qed. Proposition structured_cospans_double_cat_pentagon : pentagon_law structured_cospans_double_cat_associator. Proof. intro ; intros. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. - unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor ; cbn. rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite id_left. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. unfold struct_cospan_associator_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. apply idpath. - unfold struct_cospan_associator_mor, mor_of_comp_struct_cospan_mor ; cbn. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. unfold struct_cospan_associator_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. refine (assoc' _ _ _ @ _). rewrite !PushoutArrow_PushoutIn1. refine (assoc _ _ _ @ _). rewrite !PushoutArrow_PushoutIn2. apply idpath. } rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. apply idpath. + rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. * rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. refine (!_). rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. refine (assoc' _ _ _ @ _). rewrite !PushoutArrow_PushoutIn1. refine (assoc _ _ _ @ _). rewrite !PushoutArrow_PushoutIn2. apply idpath. } rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. apply idpath. * rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. apply idpath. } rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. rewrite id_left. apply idpath. Qed. (** 5. The double category of structured cospans *) Definition structured_cospans_double_cat : double_cat. Proof. use make_double_cat. - exact A. - exact (twosided_disp_cat_of_struct_cospans L). - exact structured_cospans_double_cat_hor_id. - exact structured_cospans_double_cat_hor_comp. - exact structured_cospans_double_cat_lunitor. - exact structured_cospans_double_cat_runitor. - exact structured_cospans_double_cat_associator. - exact structured_cospans_double_cat_triangle. - exact structured_cospans_double_cat_pentagon. - apply univalent_category_is_univalent. - use is_univalent_struct_cospans_twosided_disp_cat. apply univalent_category_is_univalent. Defined. End StructuredCospansDoubleCat. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/StructuredCospansDoubleFunctor.v000066400000000000000000000461461451125700300326430ustar00rootroot00000000000000(********************************************************************************** Double functors between double categories of structured cospans Suppose that we have the following square of functors: << L₁ A₁ ⟶ X₁ FA | | FX V V A₂ ⟶ X₂ L₂ >> and suppose that we have a natural transformation from `FA ∙ L₂` to `L₁ ∙ FX`. Then we have a double functor from the double category of `L₁`-structured cospans to the double category of `L₂`-structured cospans. The description on this double functor on the vertical categories is given by `FA`. A structured cospan `L₁ a <-- x --> L₁ b` is sent to `L₂ (FA a) <-- FX x --> L₂ (FA b)`. A part of this construction is already given in the file `StructuredCospans.v`. In that file the action of this double functor on objects, horizontal morphisms, and on squares is defined. In this file, we show that this gives rise to a double functor. A reference for this construction is Theorem 4.2 in "Structured Cospans" by Baez, and Courser. https://arxiv.org/pdf/1911.04630.pdf Another reference is Theorem 2.4 in "Structured and decorated cospans from the viewpoint of double category theory" by Patterson. https://arxiv.org/pdf/2304.00447.pdf Note that Baez and Courser look at strong double functors, whereas our notion of double functor is lax be default. If we assume that the natural transformation is an isomorphism and that the functor `FX` preserves pushouts, then this double functor is strong. Contents 1. Preservation of horizontal identities 2. Preservation of horizontal composition 3. The coherences 4. The double functors between the double categories of structured cospans 5. Conditions under which this double functor is strong **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.StructuredCospans. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor.Basics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Require Import UniMath.Bicategories.DoubleCategories.Examples.StructuredCospansDoubleCat. Local Open Scope cat. Local Open Scope double_cat. Section StructuredCospansDoubleFunctor. Context {A₁ A₂ X₁ X₂ : univalent_category} (PX₁ : Pushouts X₁) (PX₂ : Pushouts X₂) {L₁ : A₁ ⟶ X₁} {L₂ : A₂ ⟶ X₂} {FA : A₁ ⟶ A₂} {FX : X₁ ⟶ X₂} (α : FA ∙ L₂ ⟹ L₁ ∙ FX). (** 1. Preservation of horizontal identities *) Definition structured_cospans_double_cat_functor_id_data : double_functor_hor_id_data (twosided_disp_cat_of_struct_cospans_functor α) (structured_cospans_double_cat_hor_id L₁) (structured_cospans_double_cat_hor_id L₂). Proof. intro x. use make_struct_cospan_sqr. - exact (α x). - abstract (split ; cbn ; rewrite !functor_id, !id_left, id_right ; apply idpath). Defined. Proposition structured_cospans_double_cat_functor_id_laws : double_functor_hor_id_laws structured_cospans_double_cat_functor_id_data. Proof. intros x y f. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. apply (nat_trans_ax α _ _ f). Qed. Definition structured_cospans_double_cat_functor_id : double_functor_hor_id (twosided_disp_cat_of_struct_cospans_functor α) (structured_cospans_double_cat_hor_id L₁) (structured_cospans_double_cat_hor_id L₂). Proof. use make_double_functor_hor_id. - exact structured_cospans_double_cat_functor_id_data. - exact structured_cospans_double_cat_functor_id_laws. Defined. (** 2. Preservation of horizontal composition *) Definition structured_cospans_double_cat_functor_comp_data : double_functor_hor_comp_data (twosided_disp_cat_of_struct_cospans_functor α) (structured_cospans_double_cat_hor_comp PX₁ L₁) (structured_cospans_double_cat_hor_comp PX₂ L₂). Proof. intros x y z h k. use make_struct_cospan_sqr. - use PushoutArrow ; cbn. + exact (#FX (PushoutIn1 _)). + exact (#FX (PushoutIn2 _)). + abstract (rewrite !assoc' ; apply maponpaths ; rewrite <- !functor_comp ; apply maponpaths ; apply PushoutSqrCommutes). - abstract (split ; [ cbn ; rewrite !assoc' ; rewrite functor_id, id_left ; rewrite PushoutArrow_PushoutIn1 ; rewrite <- !functor_comp ; apply idpath | cbn ; rewrite !assoc' ; rewrite functor_id, id_left ; rewrite PushoutArrow_PushoutIn2 ; rewrite <- !functor_comp ; apply idpath ]). Defined. Proposition structured_cospans_double_cat_functor_comp_laws : double_functor_hor_comp_laws structured_cospans_double_cat_functor_comp_data. Proof. intro ; intros. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. - unfold mor_of_comp_struct_cospan_mor. rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. cbn. rewrite <- !functor_comp. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. rewrite <- !functor_comp. apply idpath. - unfold mor_of_comp_struct_cospan_mor. rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. cbn. rewrite <- !functor_comp. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn2. rewrite <- !functor_comp. apply idpath. Qed. Definition structured_cospans_double_cat_functor_comp : double_functor_hor_comp (twosided_disp_cat_of_struct_cospans_functor α) (structured_cospans_double_cat_hor_comp PX₁ L₁) (structured_cospans_double_cat_hor_comp PX₂ L₂). Proof. use make_double_functor_hor_comp. - exact structured_cospans_double_cat_functor_comp_data. - exact structured_cospans_double_cat_functor_comp_laws. Defined. (** 3. The coherences *) Proposition structured_cospans_double_cat_functor_lunitor : double_functor_lunitor (structured_cospans_double_cat_lunitor PX₁ L₁) (structured_cospans_double_cat_lunitor PX₂ L₂) structured_cospans_double_cat_functor_id structured_cospans_double_cat_functor_comp. Proof. intros x y f. use struct_cospan_sqr_eq. rewrite transportf_disp_mor2_struct_cospan ; cbn. unfold struct_cospan_lunitor_mor, mor_of_comp_struct_cospan_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. - rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite PushoutArrow_PushoutIn1. rewrite <- functor_comp. rewrite PushoutArrow_PushoutIn1. apply idpath. - rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite PushoutArrow_PushoutIn2. rewrite <- functor_comp. rewrite PushoutArrow_PushoutIn2. rewrite functor_id. rewrite id_left. apply idpath. Qed. Proposition structured_cospans_double_cat_functor_runitor : double_functor_runitor (structured_cospans_double_cat_runitor PX₁ L₁) (structured_cospans_double_cat_runitor PX₂ L₂) structured_cospans_double_cat_functor_id structured_cospans_double_cat_functor_comp. Proof. intros x y f. use struct_cospan_sqr_eq. rewrite transportf_disp_mor2_struct_cospan ; cbn. unfold struct_cospan_runitor_mor, mor_of_comp_struct_cospan_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. - rewrite !assoc. rewrite !PushoutArrow_PushoutIn1. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite PushoutArrow_PushoutIn1. rewrite <- functor_comp. rewrite PushoutArrow_PushoutIn1. rewrite functor_id, id_left. apply idpath. - rewrite !assoc. rewrite !PushoutArrow_PushoutIn2. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite PushoutArrow_PushoutIn2. rewrite <- functor_comp. rewrite PushoutArrow_PushoutIn2. apply idpath. Qed. Proposition structured_cospans_double_cat_functor_associator : double_functor_associator (structured_cospans_double_cat_associator PX₁ L₁) (structured_cospans_double_cat_associator PX₂ L₂) structured_cospans_double_cat_functor_comp. Proof. intro ; intros. use struct_cospan_sqr_eq. rewrite transportf_disp_mor2_struct_cospan ; cbn. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. - refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. apply PushoutArrow_PushoutIn1. } refine (!_). refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } etrans. { apply maponpaths. refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply PushoutArrow_PushoutIn1. } refine (_ @ functor_comp _ _ _). refine (_ @ id_left _). apply maponpaths_2 ; cbn. apply idpath. - refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } refine (!_). refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. + refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } etrans. { apply maponpaths. refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply PushoutArrow_PushoutIn2. } etrans. { refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply PushoutArrow_PushoutIn1. } refine (!_). refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn1. } refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. apply PushoutArrow_PushoutIn1. } exact (!(functor_comp _ _ _)). + refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } etrans. { apply maponpaths. refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply PushoutArrow_PushoutIn2. } etrans. { refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply PushoutArrow_PushoutIn2. } refine (!_). refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply PushoutArrow_PushoutIn2. } etrans. { apply maponpaths_2. apply PushoutArrow_PushoutIn2. } refine (assoc' _ _ _ @ _). refine (id_left _ @ _). apply PushoutArrow_PushoutIn2. Qed. (** 4. The double functors between the double categories of structured cospans *) Definition structured_cospans_double_cat_functor : lax_double_functor (structured_cospans_double_cat PX₁ L₁) (structured_cospans_double_cat PX₂ L₂). Proof. use make_lax_double_functor. - exact FA. - exact (twosided_disp_cat_of_struct_cospans_functor α). - exact structured_cospans_double_cat_functor_id. - exact structured_cospans_double_cat_functor_comp. - exact structured_cospans_double_cat_functor_lunitor. - exact structured_cospans_double_cat_functor_runitor. - exact structured_cospans_double_cat_functor_associator. Defined. (** 5. Conditions under which this double functor is strong *) Context (Hα : is_nat_z_iso α) (HFX : preserves_pushout FX). Definition structured_cospans_double_cat_functor_unit_iso (x : A₁) : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_id_h structured_cospans_double_cat_functor x). Proof. use is_iso_twosided_disp_struct_cospan_sqr. apply Hα. Defined. Section PreservesComp. Context {x y z : structured_cospans_double_cat PX₁ L₁} (h : x -->h y) (k : y -->h z). Local Lemma structured_cospans_double_cat_functor_comp_iso_inv_eq : # FX (mor_right_of_struct_cospan L₁ h) · # FX (PushoutIn1 (comp_struct_cospan_Pushout L₁ PX₁ h k)) = # FX (mor_left_of_struct_cospan L₁ k) · # FX (PushoutIn2 (comp_struct_cospan_Pushout L₁ PX₁ h k)). Proof. rewrite <- !functor_comp. apply maponpaths. apply PushoutSqrCommutes. Qed. Let P : Pushout (# FX (mor_right_of_struct_cospan L₁ h)) (# FX (mor_left_of_struct_cospan L₁ k)) := make_Pushout _ _ _ _ _ structured_cospans_double_cat_functor_comp_iso_inv_eq (HFX _ _ _ _ _ _ _ _ _ _ (isPushout_Pushout (comp_struct_cospan_Pushout L₁ PX₁ h k))). Definition structured_cospans_double_cat_functor_comp_iso_inv : FX (comp_struct_cospan_Pushout L₁ PX₁ h k) --> comp_struct_cospan_Pushout L₂ PX₂ (functor_on_struct_cospan α h) (functor_on_struct_cospan α k). Proof. use (PushoutArrow P). - exact (PushoutIn1 _). - exact (PushoutIn2 _). - abstract (use (cancel_z_iso' (make_z_iso _ _ (Hα y))) ; rewrite !assoc ; apply PushoutSqrCommutes). Defined. Proposition structured_cospans_double_cat_functor_comp_iso_inv_laws : is_inverse_in_precat (struct_cospan_sqr_ob_mor L₂ (lax_double_functor_comp_h structured_cospans_double_cat_functor h k)) structured_cospans_double_cat_functor_comp_iso_inv. Proof. split ; unfold structured_cospans_double_cat_functor_comp_iso_inv. - use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX₂ _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite id_right. apply (PushoutArrow_PushoutIn1 P). + rewrite !assoc. rewrite PushoutArrow_PushoutIn2. rewrite id_right. apply (PushoutArrow_PushoutIn2 P). - use (MorphismsOutofPushoutEqual (isPushout_Pushout P)) ; cbn. + rewrite !assoc. rewrite (PushoutArrow_PushoutIn1 P). rewrite PushoutArrow_PushoutIn1. rewrite id_right. apply idpath. + rewrite !assoc. rewrite (PushoutArrow_PushoutIn2 P). rewrite PushoutArrow_PushoutIn2. rewrite id_right. apply idpath. Qed. Definition structured_cospans_double_cat_functor_comp_iso : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (lax_double_functor_comp_h structured_cospans_double_cat_functor h k). Proof. use is_iso_twosided_disp_struct_cospan_sqr. use make_is_z_isomorphism. - exact structured_cospans_double_cat_functor_comp_iso_inv. - exact structured_cospans_double_cat_functor_comp_iso_inv_laws. Defined. End PreservesComp. Definition is_strong_structured_cospans_double_cat_functor : is_strong_double_functor structured_cospans_double_cat_functor. Proof. split. - exact structured_cospans_double_cat_functor_unit_iso. - exact (λ x y z h k, structured_cospans_double_cat_functor_comp_iso h k). Defined. End StructuredCospansDoubleFunctor. UniMath-20231010/UniMath/Bicategories/DoubleCategories/Examples/UnitDoubleCat.v000066400000000000000000000106101451125700300271410ustar00rootroot00000000000000(********************************************************************************** The unit double category In this file, we define the unit double category. Its objects, vertical morphisms, horizontal morphisms, and squares are all inhabitants of the unit type. Contents 1. Horizontal operations of the unit double category 2. The unit double category **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. (** 1. Horizontal operations of the unit double category *) Definition unit_double_cat_hor_id_data : hor_id_data (constant_twosided_disp_cat unit_category unit_category unit_category). Proof. use make_hor_id_data. - exact (λ _, tt). - exact (λ _ _ _, idpath _). Defined. Proposition unit_double_cat_hor_id_laws : hor_id_laws unit_double_cat_hor_id_data. Proof. split. - intros. apply isapropunit. - intros. apply isapropunit. Qed. Definition unit_double_cat_hor_id : hor_id (constant_twosided_disp_cat unit_category unit_category unit_category). Proof. use make_hor_id. - exact unit_double_cat_hor_id_data. - exact unit_double_cat_hor_id_laws. Defined. Definition unit_double_cat_hor_comp_data : hor_comp_data (constant_twosided_disp_cat unit_category unit_category unit_category). Proof. use make_hor_comp_data. - exact (λ _ _ _ _ _, tt). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, idpath _). Defined. Proposition unit_double_cat_hor_comp_laws : hor_comp_laws unit_double_cat_hor_comp_data. Proof. split. - intros. apply isapropunit. - intros. apply isapropunit. Qed. Definition unit_double_cat_hor_comp : hor_comp (constant_twosided_disp_cat unit_category unit_category unit_category). Proof. use make_hor_comp. - exact unit_double_cat_hor_comp_data. - exact unit_double_cat_hor_comp_laws. Defined. Definition unit_double_lunitor : double_cat_lunitor unit_double_cat_hor_id unit_double_cat_hor_comp. Proof. use make_double_lunitor. - intros x y f. use make_iso_twosided_disp. + apply isapropunit. + use to_is_twosided_disp_cat_iso_constant. apply path_groupoid. - intro ; intros. apply isapropunit. Qed. Definition unit_double_runitor : double_cat_runitor unit_double_cat_hor_id unit_double_cat_hor_comp. Proof. use make_double_runitor. - intros x y f. use make_iso_twosided_disp. + apply isapropunit. + use to_is_twosided_disp_cat_iso_constant. apply path_groupoid. - intro ; intros. apply isapropunit. Qed. Definition unit_double_associator : double_cat_associator unit_double_cat_hor_comp. Proof. use make_double_associator. - intro ; intros. use make_iso_twosided_disp. + apply isapropunit. + use to_is_twosided_disp_cat_iso_constant. apply path_groupoid. - intro ; intros. apply isapropunit. Qed. (** 2. The unit double category *) Definition unit_double_cat : double_cat. Proof. use make_double_cat. - exact unit_category. - exact (constant_twosided_disp_cat unit_category unit_category unit_category). - exact unit_double_cat_hor_id. - exact unit_double_cat_hor_comp. - exact unit_double_lunitor. - exact unit_double_runitor. - exact unit_double_associator. - abstract (intro ; intros ; apply isasetunit). - abstract (intro ; intros ; apply isasetunit). - apply univalent_category_is_univalent. - apply is_univalent_constant_twosided_disp_cat. apply univalent_category_is_univalent. Defined. UniMath-20231010/UniMath/Bicategories/DoubleCategories/InvertiblesAndEquivalences.v000066400000000000000000000271431451125700300301500ustar00rootroot00000000000000(********************************************************************************** Equivalences and invertible 2-cells of double categories In this file, we give constructors for adjoints equivalences and invertible 2-cells in the bicategory of double categories. If we have a double transformation, then to show it is an invertible 2-cells, it suffices to prove that underlying vertical and horizontal transformations are pointwise inertible. To prove that a lax double functor `F` is an equivalence, it suffices to prove the following: - `F` is strong (it preserves the horizontal identity and composition up to isomorphism). - `F` is an adjoint equivalence on the level of 2-sided displayed categories. This means that the underlying vertical and horizontal functors are equivalences. This is proven in [left_adjoint_equivalence_lax_double_functor]. Note that we do not have to show that the inverse is a double functor or that the involved natural transformations are double transformations. We also show that these conditions are necessary. For the invertible 2-cells, this follows from the fact that the first projection of an invertible 2-cell in the total bicategory is also invertible. For adjoint equivalence, we need the analogous statement, but we also need to show that adjoint equivalences are strong double functors. For that, we use induction on adjoint equivalences, and the fact that the identity functor is a strong double functor. Contents 1. Invertible 2-cells 2. Adjoint equivalences **********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedNatTrans. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfTwoSidedDispCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCategoryBasics. Require Import UniMath.Bicategories.DoubleCategories.DoubleFunctor. Require Import UniMath.Bicategories.DoubleCategories.DoubleTransformation. Require Import UniMath.Bicategories.DoubleCategories.BicatOfDoubleCats. Require Import UniMath.Bicategories.DoubleCategories.DoubleCats. Local Open Scope cat. Local Open Scope double_cat. (** 1. Invertible 2-cells *) Section Invertibles. Context {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) (Hτ : is_invertible_2cell (pr111 τ)). Definition is_invertible_2cell_double_transformation_help : is_invertible_2cell (pr11 τ). Proof. use is_invertible_disp_to_total. simple refine (_ ,, _). - (* 2-sided displayed categories *) exact Hτ. - use (pair_is_disp_invertible_2cell _ _ (_ ,, _) (pr211 τ)). split. + (* horizontal identities *) apply is_disp_invertible_2cell_hor_id. + (* horizontal compositions *) apply is_disp_invertible_2cell_hor_comp. Qed. Definition is_invertible_2cell_double_transformation : is_invertible_2cell τ. Proof. use bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell. use is_invertible_disp_to_total. simple refine (_ ,, _). - exact is_invertible_2cell_double_transformation_help. - use (pair_is_disp_invertible_2cell _ _ (_ ,, _) (pr21 τ)). split. + (* left unitors *) apply disp_cell_unit_bicat_is_disp_invertible_2cell. + use (pair_is_disp_invertible_2cell _ _ (_ ,, _) (pr221 τ)). refine (_ ,, _). * (* right unitors *) apply disp_cell_unit_bicat_is_disp_invertible_2cell. * (* associators *) apply disp_cell_unit_bicat_is_disp_invertible_2cell. Qed. End Invertibles. Definition invertible_double_nat_trans_weq {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) : is_invertible_2cell τ ≃ is_invertible_2cell (pr111 τ). Proof. use weqimplimpl. - intros Hτ. exact (is_invertible_total_to_base _ _ (is_invertible_total_to_base _ _ (is_invertible_total_to_base _ _ Hτ))). - intros Hτ. use is_invertible_2cell_double_transformation. exact Hτ. - apply isaprop_is_invertible_2cell. - apply isaprop_is_invertible_2cell. Defined. Section InvertiblesUnfolded. Context {C₁ C₂ : double_cat} {F G : lax_double_functor C₁ C₂} (τ : double_transformation F G) (Hτ : ∏ (x : C₁), is_z_isomorphism (τ x)) (Hττ : ∏ (x y : C₁) (f : x -->h y), is_iso_twosided_disp (Hτ x) (Hτ y) (double_transformation_hor_mor τ f)). Definition is_invertible_2cell_double_transformation_unfolded : is_invertible_2cell τ. Proof. use is_invertible_2cell_double_transformation. use is_invertible_2cell_bicat_twosided_disp_cat. - exact Hτ. - exact Hττ. Qed. End InvertiblesUnfolded. (** 2. Adjoint equivalences *) Section Equivalences. Context {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) (HF : is_strong_double_functor F) (* `F` is an adjoint equivalence of 2-sided displayed categories *) (HF' : left_adjoint_equivalence (pr111 F)). Definition left_adjoint_equivalence_lax_double_functor_help : left_adjoint_equivalence (pr11 F). Proof. use (invmap (left_adjoint_equivalence_total_disp_weq _ _)). simple refine (_ ,, _). - (* 2-sided displayed categories *) exact HF'. - use (pair_left_adjoint_equivalence _ _ (_ ,, _) (pr211 F)). split. + (* horizontal identities *) use disp_left_adjequiv_hor_id. exact (is_iso_strong_double_functor_id_h HF). + (* horizontal compositions *) use disp_left_adjequiv_hor_comp. exact (λ x y z h k, is_iso_strong_double_functor_comp_h HF h k). Qed. Definition left_adjoint_equivalence_lax_double_functor : left_adjoint_equivalence F. Proof. use bicat_left_adjoint_equivalence_to_fullsub_left_adjoint_equivalence. use (invmap (left_adjoint_equivalence_total_disp_weq _ _)). simple refine (_ ,, _). - exact left_adjoint_equivalence_lax_double_functor_help. - use (pair_left_adjoint_equivalence _ _ (_ ,, _) (pr21 F)). split. + (* left unitors *) apply is_disp_left_adjoint_equivalence_disp_bicat_lunitor. + use (pair_left_adjoint_equivalence _ _ (_ ,, _) (pr221 F)). split. * (* right unitors *) apply is_disp_left_adjoint_equivalence_disp_bicat_runitor. * (* associators *) apply is_disp_left_adjoint_equivalence_disp_bicat_lassociator. Qed. End Equivalences. Section EquivalencesUnfolded. Context {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) (HF : is_strong_double_functor F) (R : C₂ ⟶ C₁) (RR : twosided_disp_functor R R (hor_mor C₂) (hor_mor C₁)) (η : functor_identity _ ⟹ F ∙ R) (Hη : is_nat_z_iso η) (ηη : twosided_disp_nat_trans η η (twosided_disp_functor_identity _) (comp_twosided_disp_functor_data (lax_double_functor_hor_mor F) RR)) (Hηη : ∏ (x y : C₁) (f : x -->h y), is_iso_twosided_disp (Hη x) (Hη y) (ηη x y f)) (ε : R ∙ F ⟹ functor_identity _) (Hε : is_nat_z_iso ε) (εε : twosided_disp_nat_trans ε ε (comp_twosided_disp_functor_data RR (lax_double_functor_hor_mor F)) (twosided_disp_functor_identity _)) (Hεε : ∏ (x y : C₂) (f : x -->h y), is_iso_twosided_disp (Hε x) (Hε y) (εε x y f)). Definition left_adjoint_equivalence_lax_double_functor_base : left_adjoint_equivalence (pr111 F). Proof. use equiv_to_adjequiv. simple refine (((R ,, RR) ,, (η ,, ηη) ,, (ε ,, εε)) ,, _ ,, _). - use is_invertible_2cell_bicat_twosided_disp_cat ; cbn. + exact Hη. + exact Hηη. - use is_invertible_2cell_bicat_twosided_disp_cat ; cbn. + exact Hε. + exact Hεε. Qed. Definition left_adjoint_equivalence_lax_double_functor_unfolded : left_adjoint_equivalence F. Proof. use left_adjoint_equivalence_lax_double_functor. - exact HF. - exact left_adjoint_equivalence_lax_double_functor_base. Qed. End EquivalencesUnfolded. Definition left_adjoint_equivalence_to_strong_help {C₁ C₂ : double_cat} (F : adjoint_equivalence C₁ C₂) : is_strong_double_functor (pr1 F). Proof. revert C₁ C₂ F. use J_2_0. - apply is_univalent_2_bicat_of_double_cats. - intro C. apply is_strong_double_functor_id. Defined. Section FromEquivalence. Context {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) (HF : left_adjoint_equivalence F). Let HF₁ : left_adjoint_equivalence (pr1 F) := pr1 (left_adjoint_equivalence_total_disp_weq _ _ HF). Let HF₂ : left_adjoint_equivalence (pr11 F) := pr1 (left_adjoint_equivalence_total_disp_weq _ _ HF₁). Definition left_adjoint_equivalence_to_strong : is_strong_double_functor F := left_adjoint_equivalence_to_strong_help (F ,, HF). Definition left_adjoint_equivalence_to_twosided_equiv : left_adjoint_equivalence (pr111 F). Proof. exact (pr1 (left_adjoint_equivalence_total_disp_weq _ _ HF₂)). Defined. End FromEquivalence. Definition left_adjoint_equivalence_lax_double_functor_weq {C₁ C₂ : double_cat} (F : lax_double_functor C₁ C₂) : left_adjoint_equivalence F ≃ (is_strong_double_functor F × left_adjoint_equivalence (pr111 F)). Proof. use weqimplimpl. - intros HF. split. + exact (left_adjoint_equivalence_to_strong F HF). + exact (left_adjoint_equivalence_to_twosided_equiv F HF). - intros HF. use left_adjoint_equivalence_lax_double_functor. + exact (pr1 HF). + exact (pr2 HF). - apply isaprop_left_adjoint_equivalence. apply is_univalent_2_bicat_of_double_cats. - apply isapropdirprod. + apply isaprop_is_strong_double_functor. + apply isaprop_left_adjoint_equivalence. exact is_univalent_2_1_bicat_twosided_disp_cat. Defined. UniMath-20231010/UniMath/Bicategories/Grothendieck/000077500000000000000000000000001451125700300216625ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Grothendieck/Biequivalence.v000066400000000000000000000147011451125700300246300ustar00rootroot00000000000000(************************************************************************ The Grothendieck Construction: the biequivalence The Grothendieck construction gives a biequivalence between the bicategory of fibrations over a fixed category `C` and the bicategory of indexed categories over `C`. To construct this biequivalence, we need to construct the following: 1. A pseudofunctor from the bicategory of fibrations to the bicategory of pseudofunctors 2. A pseudofunctor from the bicategory of pseudofunctors to the bicategory of fibrations 3. The unit and a proof that it is a pointwise adjoint equivalence 4. The counit and a proof that it is a pointwise adjoint equivalence In this file, we collect all statements together so that we obtain the desired biequivalence. In the proof, we make use of the fact that a pseudotransformation is an adjoint equivalence if it is a pointwise adjoint equivalence. The current proof of that in UniMath requires the univalence of the codomain, so that one can use induction on adjoint equivalences. Contents 1. Collecting the data of the biequivalence 2. Collecting that the unit and counit are adjoint equivalences 3. The Grothendieck construction as biequivalence ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.NatTransToIndexed. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformationToTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.ModificationIntoCat. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.Grothendieck.FibrationToPseudoFunctor. Require Import UniMath.Bicategories.Grothendieck.PseudoFunctorToFibration. Require Import UniMath.Bicategories.Grothendieck.Unit. Require Import UniMath.Bicategories.Grothendieck.Counit. Local Open Scope cat. Section GrothendieckConstruction. Context (C : univalent_category). (** 1. Collecting the data of the biequivalence *) Definition psfunctor_fib_to_psfunctor_bicat_unit_counit : is_biequivalence_unit_counit (psfunctor_fib_to_psfunctor_bicat C) (psfunctor_psfunctor_bicat_to_fib C). Proof. refine (_ ,, _). - exact psfunctor_fib_to_psfunctor_unit. - exact psfunctor_fib_to_psfunctor_counit. Defined. (** 2. Collecting that the unit and counit are adjoint equivalences *) Definition is_biequivalence_adjoints_psfunctor_fib_to_psfunctor_bicat : is_biequivalence_adjoints psfunctor_fib_to_psfunctor_bicat_unit_counit. Proof. split. - use pointwise_adjequiv_to_adjequiv. + exact (is_univalent_2_fib_slice_bicat C). + intro P. use equiv_to_adjequiv. exact (psfunctor_fib_to_psfunctor_unit_equiv (pr1 P) (pr2 P)). - use pointwise_adjequiv_to_adjequiv. + use psfunctor_bicat_is_univalent_2. exact univalent_cat_is_univalent_2. + intro F. use pointwise_adjequiv_to_adjequiv. * exact univalent_cat_is_univalent_2. * intro x. use equiv_to_adjequiv. exact (equiv_psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x). Defined. (** 3. The Grothendieck construction as biequivalence *) Definition is_biequivalence_psfunctor_fib_to_psfunctor_bicat : is_biequivalence (psfunctor_fib_to_psfunctor_bicat C) := psfunctor_psfunctor_bicat_to_fib C ,, psfunctor_fib_to_psfunctor_bicat_unit_counit ,, is_biequivalence_adjoints_psfunctor_fib_to_psfunctor_bicat. Definition grothendieck_construction : biequivalence (fib_slice_bicat C) (psfunctor_bicat (cat_to_bicat (C^op)) bicat_of_univ_cats) := psfunctor_fib_to_psfunctor_bicat C ,, is_biequivalence_psfunctor_fib_to_psfunctor_bicat. End GrothendieckConstruction. UniMath-20231010/UniMath/Bicategories/Grothendieck/Counit.v000066400000000000000000001065601451125700300233220ustar00rootroot00000000000000(************************************************************************ Grothendieck construction: the counit The Grothendieck construction gives a biequivalence between the bicategory of fibrations over a fixed category `C` and the bicategory of indexed categories over `C`. To construct this biequivalence, we need to construct the following: 1. A pseudofunctor from the bicategory of fibrations to the bicategory of pseudofunctors 2. A pseudofunctor from the bicategory of pseudofunctors to the bicategory of fibrations 3. The unit and a proof that it is a pointwise adjoint equivalence 4. The counit and a proof that it is a pointwise adjoint equivalence In this file, we construct the fourth part of this biequivalence, namely the counit. The counit gives a pseudotransformations between two endopseudofunctors on the bicategory of pseudofunctors. As such, for every object, we need to define a pseudotransformation. This is done in: [psfunctor_fib_to_psfunctor_counit_data_ob] In addition, we show that the counit is a pointwise adjoint equivalence. Since it is a pseudotransformation at every point, we must show that that particular pseudotransformation is a pointwise adjoint equivalence. This is done in: [equiv_psfunctor_fib_to_psfunctor_counit_data_ob_data_functor] Afterwards we construct invertible modifications that witness the naturality of this pseudotransformation. This is done in: [psfunctor_fib_to_psfunctor_counit_natural] Collecting all of these data and laws give us the desired pseudotransformation. Contents 1. Action of the counit on objects 2. Action of the counit on 1-cells 3. The data of the counit 4. The laws of the counit 5. The counit ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.NatTransToIndexed. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformationToTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.ModificationIntoCat. Require Import UniMath.Bicategories.Grothendieck.FibrationToPseudoFunctor. Require Import UniMath.Bicategories.Grothendieck.PseudoFunctorToFibration. Local Open Scope cat. Section GrothendieckConstruction. Context {C : univalent_category}. (** 1. Action of the counit on objects *) Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : functor_data (fiber_category (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) x) (F x : univalent_category). Proof. use make_functor_data. - exact (λ xx, xx). - intros xx yy ff. cbn in xx, yy, ff. exact (ff · pr1 ((psfunctor_id F x)^-1) yy). Defined. Proposition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : is_functor (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_data F x). Proof. split. - intros xx ; cbn -[psfunctor_id]. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F x)) xx). - intros xx yy zz ff gg ; cbn -[psfunctor_id psfunctor_comp]. cbn in xx, yy, zz, ff, gg. rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. exact (!(nat_trans_ax ((psfunctor_id F x)^-1) _ _ gg)). } assert (# F (identity x) ◃ (psfunctor_id F x)^-1 = psfunctor_comp F (identity x) (identity x) • ##F (runitor _) • rinvunitor _) as p. { rewrite (psfunctor_F_runitor F (identity x)). rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. rewrite !vassocl. rewrite runitor_rinvunitor. rewrite id2_right. apply idpath. } pose (q := nat_trans_eq_pointwise p zz). cbn -[psfunctor_id psfunctor_comp] in q. rewrite id_right in q. etrans. { do 2 apply maponpaths. exact q. } refine (!_). etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } rewrite !assoc'. do 3 apply maponpaths. refine (_ @ !(psfunctor_idtoiso F _ _)). do 3 apply maponpaths. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : bicat_of_univ_cats ⟦ univalent_fiber_category (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F) ,, is_univalent_disp_indexed_cat_to_disp_cat _) x , F x ⟧. Proof. use make_functor. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_data F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_laws F x). Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : functor_data (F x : univalent_category) (fiber_category (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) x). Proof. use make_functor_data. - exact (λ xx, xx). - exact (λ xx yy ff, ff · pr11 (psfunctor_id F x) yy). Defined. Proposition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : is_functor (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv_data F x). Proof. split. - intros xx. cbn -[psfunctor_id]. apply id_left. - intros xx yy zz ff gg. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id F x))). } cbn -[psfunctor_id psfunctor_comp]. pose (nat_trans_eq_pointwise (psfunctor_rinvunitor F (identity x)) zz) as p. cbn -[psfunctor_id psfunctor_comp] in p. etrans. { do 2 apply maponpaths. rewrite !assoc'. do 2 apply maponpaths. refine (!_ @ !p). rewrite !assoc'. apply id_left. } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } rewrite !assoc'. do 2 apply maponpaths. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths_2. apply (psfunctor_idtoiso F _ _). } refine (!(pr1_idtoiso_concat _ _) @ _). refine (_ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#F h) zz) _ _) @ _ @ maponpaths_idpath). apply maponpaths. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : (F x : univalent_category) ⟶ fiber_category (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) x. Proof. use make_functor. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv_data F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv_laws F x). Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : nat_trans_data (functor_identity _) (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv F x) := λ _, identity _. Proposition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : is_nat_trans _ _ (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit_data F x). Proof. intros xx yy ff. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. do 2 apply maponpaths. rewrite !assoc'. etrans. { apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_linv (psfunctor_id F x)) yy). } apply id_right. } etrans. { apply maponpaths. apply maponpaths_2. exact (!(nat_trans_ax (pr1 (psfunctor_id F x)) _ _ ff)). } cbn -[psfunctor_id psfunctor_comp]. pose (nat_trans_eq_pointwise (psfunctor_linvunitor F (identity x)) yy) as p. cbn -[psfunctor_id psfunctor_comp] in p. pose (nat_trans_eq_pointwise (psfunctor_rinvunitor F (identity x)) yy) as q. cbn -[psfunctor_id psfunctor_comp] in q. rewrite !assoc'. etrans. { do 2 apply maponpaths. refine (!_ @ !q). apply maponpaths_2. apply id_left. } refine (!_). etrans. { do 2 apply maponpaths. refine (!_ @ !p). apply maponpaths_2. apply id_left. } do 2 apply maponpaths. refine (psfunctor_idtoiso F _ _ @ _ @ !(psfunctor_idtoiso F _ _)). do 3 apply maponpaths. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : functor_identity _ ⟹ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv F x. Proof. use make_nat_trans. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit_data F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit_laws F x). Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : nat_trans_data (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv F x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x) (functor_identity _) := λ _, identity _. Proposition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : is_nat_trans _ _ (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_data F x). Proof. intros xx yy ff. cbn -[psfunctor_id psfunctor_comp]. unfold psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_data. rewrite id_left, id_right. rewrite !assoc'. etrans. { apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F x)) yy). } apply id_right. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv F x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ⟹ functor_identity _. Proof. use make_nat_trans. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_data F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit_laws F x). Defined. Definition equiv_psfunctor_fib_to_psfunctor_counit_data_ob_data_functor (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) (x : C) : left_equivalence (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_inv F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_unit F x). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor_counit F x). - use is_nat_z_iso_to_is_invertible_2cell. intros xx. apply is_z_isomorphism_identity. - use is_nat_z_iso_to_is_invertible_2cell. intros xx. apply is_z_isomorphism_identity. Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) {x y : C} (f : y --> x) : nat_trans_data (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ # F f) (fiber_functor_from_cleaving (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)) f ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F y) := λ _, identity _. Proposition psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) {x y : C} (f : y --> x) : is_nat_trans _ _ (psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data F f). Proof. intros xx yy ff. cbn -[psfunctor_id psfunctor_comp]. unfold psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data. unfold is_cartesian_indexed_cat_factorisation. cbn -[psfunctor_id psfunctor_comp]. refine (id_right _ @ _ @ !(id_left _)). rewrite functor_id. refine (!_). etrans. { apply maponpaths_2. refine (id_right _ @ _). apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply id_left. } pose (nat_trans_eq_pointwise (psfunctor_F_runitor F f) yy) as p. cbn -[psfunctor_id psfunctor_comp] in p. etrans. { rewrite !assoc'. apply maponpaths. refine (!_ @ !p). apply id_right. } clear p. etrans. { apply maponpaths. apply psfunctor_idtoiso. } etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } pose (nat_trans_eq_pointwise (psfunctor_F_lunitor F f) yy) as q. cbn -[psfunctor_id psfunctor_comp] in q. assert (# (pr1 (# F f)) (pr1 ((psfunctor_id F x) ^-1) yy) = pr11 (psfunctor_comp F (id₁ x) f) yy · pr1 (## F (lunitor _)) yy) as p. { refine (!_). etrans. { apply maponpaths. exact q. } rewrite !assoc. refine (id_right _ @ _ @ id_left _). apply maponpaths_2. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_comp F _ f)) yy). } refine (!_). refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. exact p. } etrans. { do 2 apply maponpaths. apply psfunctor_idtoiso. } rewrite !assoc'. do 2 apply maponpaths. refine (_ @ pr1_idtoiso_concat _ _). do 2 apply maponpaths. refine (_ @ maponpathscomp0 (λ h, (psfunctor_to_indexed_cat F $ h) yy) _ _). apply maponpaths. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) {x y : C} (f : y --> x) : nat_trans (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ # F f) (fiber_functor_from_cleaving (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)) f ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F y). Proof. use make_nat_trans. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data F f). - exact (psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_laws F f). Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_nat_z_iso (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) {x y : C} (f : y --> x) : nat_z_iso (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ # F f) (fiber_functor_from_cleaving (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)) f ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F y). Proof. use make_nat_z_iso. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans F f). - intro xx. apply is_z_isomorphism_identity. Defined. Definition psfunctor_fib_to_psfunctor_counit_data_ob_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : pstrans_data (indexed_cat_to_psfunctor (cleaving_to_indexed_cat (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F),, is_univalent_disp_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)))) F. Proof. use make_pstrans_data. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F). - intros x y f. use nat_z_iso_to_invertible_2cell. exact (psfunctor_fib_to_psfunctor_counit_data_ob_nat_z_iso F f). Defined. Definition psfunctor_fib_to_psfunctor_counit_data_data_on_ob (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : pstrans_from_cat_into_cat_data (indexed_cat_to_psfunctor (cleaving_to_indexed_cat (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F),, is_univalent_disp_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)))) F. Proof. use make_pstrans_from_cat_into_cat_data. - exact (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F). - intros x y f. exact (psfunctor_fib_to_psfunctor_counit_data_ob_nat_z_iso F f). Defined. Proposition psfunctor_fib_to_psfunctor_counit_data_laws_on_ob (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : pstrans_from_cat_into_cat_laws (psfunctor_fib_to_psfunctor_counit_data_data_on_ob F). Proof. split. - intros x xx ; cbn -[psfunctor_id]. unfold psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data. refine (id_right _ @ _). refine (!_). etrans. { apply maponpaths_2. cbn. unfold is_cartesian_indexed_cat_factorisation. cbn -[psfunctor_id psfunctor_comp]. apply idpath. } rewrite functor_id. rewrite id_right. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { pose (p := nat_trans_eq_pointwise (psfunctor_F_runitor F (identity x)) xx). cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). rewrite id_right. apply idpath. } apply psfunctor_idtoiso. } etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } refine (assoc' _ _ _ @ _ @ id_right _). apply maponpaths. refine (!(pr1_idtoiso_concat _ _) @ _ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ z, pr1 (#(pr11 F) z) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ z, pr1 (#(pr11 F) z) _) _). apply maponpaths. apply homset_property. - intros x y z f g xx ; cbn -[psfunctor_id psfunctor_comp]. unfold psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data. rewrite !id_right. refine (!_). etrans. { apply maponpaths_2. apply functor_id. } rewrite id_left. etrans. { apply maponpaths_2. cbn. unfold is_cartesian_indexed_cat_factorisation. cbn -[psfunctor_comp]. rewrite !functor_id. rewrite !id_right. apply maponpaths_2. apply maponpaths. apply id_left. } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } refine (assoc' _ _ _ @ _ @ id_right _). apply maponpaths. etrans. { apply maponpaths. cbn in g, f. pose (p := nat_trans_eq_pointwise (psfunctor_F_runitor F (g · f)) xx). cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). rewrite id_right. apply idpath. } etrans. { apply maponpaths. apply psfunctor_idtoiso. } refine (!(pr1_idtoiso_concat _ _) @ _ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ z, pr1 (#(pr11 F) z) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ z, pr1 (#(pr11 F) z) _) _). apply maponpaths. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_data_ob (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : pstrans (indexed_cat_to_psfunctor (cleaving_to_indexed_cat (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F),, is_univalent_disp_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)) (indexed_cat_to_cleaving (psfunctor_to_indexed_cat F)))) F. Proof. use pstrans_from_cat_into_cat. - exact (psfunctor_fib_to_psfunctor_counit_data_data_on_ob F). - exact (psfunctor_fib_to_psfunctor_counit_data_laws_on_ob F). Defined. (** 2. Action of the counit on 1-cells *) Definition psfunctor_fib_to_psfunctor_counit_natural_nat_trans_data {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) (x : C) : nat_trans_data (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ (pr111 τ) x) (fiber_functor (indexed_functor_to_disp_functor (pstrans_to_indexed_functor τ)) x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor G x) := λ _, identity _. Proposition psfunctor_fib_to_psfunctor_counit_natural_nat_trans_laws {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) (x : C) : is_nat_trans _ _ (psfunctor_fib_to_psfunctor_counit_natural_nat_trans_data τ x). Proof. intros xx yy ff. refine (id_right _ @ _). refine (_ @ !(id_left _)). cbn -[psfunctor_id]. rewrite functor_comp. rewrite !assoc'. apply maponpaths. pose (nat_trans_eq_pointwise (pstrans_id_inv τ x) yy) as p. cbn -[psfunctor_id] in p. rewrite !id_right in p. exact (!p). Qed. Definition psfunctor_fib_to_psfunctor_counit_natural_nat_trans {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) (x : C) : nat_trans (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ (pr111 τ) x) (fiber_functor (indexed_functor_to_disp_functor (pstrans_to_indexed_functor τ)) x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor G x). Proof. use make_nat_trans. - exact (psfunctor_fib_to_psfunctor_counit_natural_nat_trans_data τ x). - exact (psfunctor_fib_to_psfunctor_counit_natural_nat_trans_laws τ x). Defined. Definition psfunctor_fib_to_psfunctor_counit_natural_nat_z_iso {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) (x : C) : nat_z_iso (psfunctor_fib_to_psfunctor_counit_data_ob_data_functor F x ∙ (pr111 τ) x) (fiber_functor (indexed_functor_to_disp_functor (pstrans_to_indexed_functor τ)) x ∙ psfunctor_fib_to_psfunctor_counit_data_ob_data_functor G x). Proof. use make_nat_z_iso. - exact (psfunctor_fib_to_psfunctor_counit_natural_nat_trans τ x). - intro. apply is_z_isomorphism_identity. Defined. Definition psfunctor_fib_to_psfunctor_counit_natural_data {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) : invertible_modification_data (psfunctor_fib_to_psfunctor_counit_data_ob F · τ) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor _ _ (psfunctor_psfunctor_bicat_to_fib_mor C τ)) · psfunctor_fib_to_psfunctor_counit_data_ob G). Proof. intro x. use nat_z_iso_to_invertible_2cell. exact (psfunctor_fib_to_psfunctor_counit_natural_nat_z_iso τ x). Defined. Proposition psfunctor_fib_to_psfunctor_counit_natural_laws {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) : is_modification (psfunctor_fib_to_psfunctor_counit_natural_data τ). Proof. intros x y f. use nat_trans_eq. { apply homset_property. } intros xx. cbn -[psfunctor_id psfunctor_comp]. unfold psfunctor_fib_to_psfunctor_counit_natural_nat_trans_data. unfold psfunctor_fib_to_psfunctor_counit_data_ob_nat_trans_data. cbn in x, y, f, xx. etrans. { do 2 refine (id_right _ @ _). apply maponpaths_2. refine (id_right _ @ _). apply id_left. } etrans. { apply maponpaths. refine (functor_id (pr111 τ y) _). } refine (id_right _ @ _). refine (!_). etrans. { etrans. { apply maponpaths_2. apply functor_id. } refine (id_left _ @ _). refine (id_right _ @ _). etrans. { apply maponpaths_2. refine (id_right _ @ _). apply id_left. } apply id_left. } unfold is_cartesian_indexed_cat_factorisation. unfold is_cartesian_to_iso_indexed_cat_inv. cbn -[psfunctor_id psfunctor_comp]. unfold is_cartesian_indexed_cat_factorisation. cbn -[psfunctor_id psfunctor_comp]. etrans. { apply maponpaths_2. do 2 apply maponpaths. etrans. { do 2 apply maponpaths. apply maponpaths_2. etrans. { apply maponpaths. apply functor_id. } apply id_right. } etrans. { do 2 apply maponpaths. apply maponpaths_2. rewrite assoc'. etrans. { apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_comp F f (identity y))) xx). } apply id_right. } etrans. { apply maponpaths. etrans. { apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F y)) _). } apply functor_id. } apply id_right. } etrans. { rewrite !assoc'. do 2 apply maponpaths. apply (nat_trans_ax ((psfunctor_id G y) ^-1)). } refine (_ @ id_left _). do 2 refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (transportf_psfunctor_into_cat _ _ _ _ @ _). apply id_left. } pose (nat_trans_eq_pointwise (psfunctor_F_runitor G f) (pr1 ((pr111 τ) x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (_ @ !p). apply (!(id_right _)). } refine (!(nat_trans_eq_pointwise (psfunctor_vcomp G _ _) _) @ _). refine (_ @ nat_trans_eq_pointwise (psfunctor_id2 G _) _). refine (maponpaths (λ z, pr1 (##G z) _) _). apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_counit_natural {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (τ : pstrans F G) : invertible_2cell (psfunctor_fib_to_psfunctor_counit_data_ob F · τ) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor _ _ (psfunctor_psfunctor_bicat_to_fib_mor C τ)) · psfunctor_fib_to_psfunctor_counit_data_ob G). Proof. use make_invertible_modification. - exact (psfunctor_fib_to_psfunctor_counit_natural_data τ). - exact (psfunctor_fib_to_psfunctor_counit_natural_laws τ). Defined. (** 3. The data of the counit *) Definition psfunctor_fib_to_psfunctor_counit_data : pstrans_data (comp_psfunctor (psfunctor_fib_to_psfunctor_bicat C) (psfunctor_psfunctor_bicat_to_fib C)) (id_psfunctor _). Proof. use make_pstrans_data. - exact psfunctor_fib_to_psfunctor_counit_data_ob. - exact @psfunctor_fib_to_psfunctor_counit_natural. Defined. (** 4. The laws of the counit *) Proposition psfunctor_fib_to_psfunctor_counit_is_pstrans : is_pstrans psfunctor_fib_to_psfunctor_counit_data. Proof. refine (_ ,, _ ,, _). - intros F₁ F₂ n₁ n₂ m. Opaque comp_psfunctor. use modification_eq. Transparent comp_psfunctor. intro x. use nat_trans_eq ; [ apply homset_property | ]. intros xx. refine (id_right _ @ _). cbn -[psfunctor_id]. refine (_ @ !(id_left _)). refine (!_). refine (_ @ id_right _). refine (assoc' _ _ _ @ _). apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F₂ x)) (pr1 (pr111 n₂ x) xx)). - intros F. Opaque comp_psfunctor. use modification_eq. Transparent comp_psfunctor. intro x. use nat_trans_eq ; [ apply homset_property | ]. intros xx. refine (id_right _ @ _). cbn. refine (!_). etrans. { apply maponpaths_2. apply id_left. } refine (id_left _ @ _). etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } unfold psfunctor_psfunctor_bicat_to_fib_id_data. refine (_ @ nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F x)) xx). cbn -[psfunctor_id]. do 3 refine (assoc' _ _ _ @ _). apply maponpaths. refine (_ @ id_left _). do 2 refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { pose (p := nat_trans_eq_pointwise (psfunctor_linvunitor F (identity x)) xx). cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply psfunctor_idtoiso. } refine (!(pr1_idtoiso_concat _ _) @ _ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#(F : psfunctor _ _) h) xx) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ h, pr1 (#(F : psfunctor _ _) h) xx) _). apply maponpaths. apply homset_property. - intros F₁ F₂ F₃ τ θ. Opaque comp_psfunctor. use modification_eq. Transparent comp_psfunctor. intro x. use nat_trans_eq ; [ apply homset_property | ]. intros xx. refine (id_right _ @ _). cbn. refine (!_). etrans. { apply maponpaths_2. do 3 refine (id_right _ @ _). etrans. { apply maponpaths. apply functor_id. } apply id_right. } refine (id_left _ @ _). unfold psfunctor_psfunctor_bicat_to_fib_comp_data. cbn -[psfunctor_id]. etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₃)). } refine (_ @ nat_trans_eq_pointwise (vcomp_rinv (psfunctor_id F₃ x)) _). cbn -[psfunctor_id]. do 3 refine (assoc' _ _ _ @ _). apply maponpaths. refine (_ @ id_left _). do 2 refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { pose (p := nat_trans_eq_pointwise (psfunctor_linvunitor F₃ (identity x)) (pr1 (pr111 θ x) (pr1 (pr111 τ x) xx))). cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply psfunctor_idtoiso. } refine (!(pr1_idtoiso_concat _ _) @ _ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _). apply maponpaths. apply homset_property. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. (** 5. The counit *) Definition psfunctor_fib_to_psfunctor_counit : pstrans (comp_psfunctor (psfunctor_fib_to_psfunctor_bicat C) (psfunctor_psfunctor_bicat_to_fib C)) (id_psfunctor _). Proof. use make_pstrans. - exact psfunctor_fib_to_psfunctor_counit_data. - exact psfunctor_fib_to_psfunctor_counit_is_pstrans. Defined. End GrothendieckConstruction. UniMath-20231010/UniMath/Bicategories/Grothendieck/FiberwiseEquiv.v000066400000000000000000000131021451125700300247770ustar00rootroot00000000000000(********************************************************************* Fiberwise equivalences between fibrations are equivalences As an application of the Grothendieck construction, we can show that whenever we have cartesian functor between two fibrations which induces equivalences on the fibers, then this functor is actually an equivalence in the bicategory of fibrations. The proof goes as follows. Suppose that we have two fibrations `P₁` and `P₂` over `C` and a cartesian functor `F` from `P₁` to `P₂` that lives over the identity. In addition, note that `F` induces for every `x : C` a functor from the fiber of `x` along `P₁` and the fiber of `x` along `P₂` (this is [fiber_functor]). Now assume that for every object `x` this functor between the fibers is an equivalence. We want to prove that `F` is an adjoint equivalence in the bicategory of fibrations over `C`. Since the Grothendieck construction gives rise to a biequivalence and since biequivalences reflect adjoint equivalences, it suffices to check whether the image of `F` along the Grothendieck constructor is an adjoint equivalence. Note that the image of `F` is a pseudotransformation and that we can check pointwise whether a pseudotransformation is an adjoint equivalence. The action on objects of this pseudotransformation is actually given by the fiber functor mentioned before, so to check whether `F` is an adjoint equivalence, we need to check whether the fiber functor is an equivalence. This is precisely what we assumed. Note that to check whether the fiber functor is an equivalence, it suffices to check whether it is fully faithful and essentially surjective. For displayed categories, we have a similar statement: a displayed functor between displayed categories is an equivalence if that functor is fully faithful and essentially surjective. However, there is a slight difference between the statement that we obtain in this file and the corresponding statement for displayed categories: for displayed categories, we need to check fullness and faithfulness for all morphisms, whereas for fibrations, it suffices to check it only for those morphisms lying above the identity. Note the following as well: another version of the Grothendieck construction says that the bicategory of fibrations over `C` with all functors is equivalent to the bicategory of pseudofunctors with oplax transformations. However, using this version would not give a stronger statement than the one in this file. That is because to check whether an oplax transformation is an adjoint equivalence, we need to check whether it is a pointwise equivalence and whether it is a pseudotransformation. Checking whether the corresponding oplax transformation is a pseudotransformation, amounts to proving that the functor in question is cartesian. *********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.Grothendieck.Biequivalence. Local Open Scope cat. Definition fiberwise_equiv_to_adjequiv {C : univalent_category} {P₁ P₂ : fib_slice_bicat C} (F : P₁ --> P₂) (HF : ∏ (x : C), adj_equivalence_of_cats (fiber_functor (pr1 F) x)) : left_adjoint_equivalence F. Proof. use (biequiv_reflect_adjequiv (grothendieck_construction C)). use pointwise_adjequiv_to_adjequiv. - exact univalent_cat_is_univalent_2. - intros x ; cbn. use equiv_cat_to_adj_equiv. exact (HF x). Defined. Definition ff_and_eso_to_adjequiv {C : univalent_category} {P₁ P₂ : fib_slice_bicat C} (F : P₁ --> P₂) (F_full : ∏ (x : C), full (fiber_functor (pr1 F) x)) (F_faithful : ∏ (x : C), faithful (fiber_functor (pr1 F) x)) (F_eso : ∏ (x : C), Functors.essentially_surjective (fiber_functor (pr1 F) x)) : left_adjoint_equivalence F. Proof. use fiberwise_equiv_to_adjequiv. intro x. use rad_equivalence_of_cats. - use is_univalent_fiber. apply (pr1 P₁). - use full_and_faithful_implies_fully_faithful. split. + exact (F_full x). + exact (F_faithful x). - exact (F_eso x). Defined. UniMath-20231010/UniMath/Bicategories/Grothendieck/FibrationToPseudoFunctor.v000066400000000000000000000370311451125700300270160ustar00rootroot00000000000000(************************************************************************ Grothendieck construction: fibrations to pseudofunctors The Grothendieck construction gives a biequivalence between the bicategory of fibrations over a fixed category `C` and the bicategory of indexed categories over `C`. To construct this biequivalence, we need to construct the following: 1. A pseudofunctor from the bicategory of fibrations to the bicategory of pseudofunctors 2. A pseudofunctor from the bicategory of pseudofunctors to the bicategory of fibrations 3. The unit and a proof that it is a pointwise adjoint equivalence 4. The counit and a proof that it is a pointwise adjoint equivalence In this file, we construct the first part of this biequivalence (a pseudofunctor from fibrations to pseudofunctors). This construction mainly recollects statements that are already present in UniMath. There are a couple of ideas behind this formalization. First of all, for the Grothendieck construction, we are only interested in a rather particular class of pseudofunctors, namely those pseudofunctors for which the domain is a discrete bicategory (i.e., a category). This allows us to simplify some of the coherences of pseudofunctors, which is done in the file `PseudoTransformationIntoCat.v`. Second of all, we explicitly use the notion of indexed categories (see the directory `IndexedCategories` in `CategoryTheory`) for this construction, because this allows us to formulate the fundamental constructions purely in the language of category theory and without mentioning bicategories. Contents 1. Preservation of the identity 2. Preservation of composition 3. The data 4. The laws 5. Pseudofunctor from fibrations to pseudofunctors ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.NatTransToIndexed. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformationToTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.ModificationIntoCat. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Local Open Scope cat. (** 1. Preservation of the identity *) Definition psfunctor_id_fib_to_psfunctor_bicat_data {C : category} (D : disp_univalent_category C) (HD : cleaving D) : invertible_modification_data (id_pstrans (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD))) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD HD (disp_functor_identity D ,, disp_functor_identity_is_cartesian_disp_functor D))). Proof. intro x. use nat_z_iso_to_invertible_2cell. exact (fiber_functor_identity D x). Defined. Proposition psfunctor_id_fib_to_psfunctor_bicat_laws {C : category} (D : disp_univalent_category C) (HD : cleaving D) : is_modification (psfunctor_id_fib_to_psfunctor_bicat_data D HD). Proof. intros x y f. use nat_trans_eq ; [ apply homset_property | ]. intros xx ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_id_fib_to_psfunctor_bicat {C : category} (D : disp_univalent_category C) (HD : cleaving D) : invertible_modification (id_pstrans (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD))) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD HD (disp_functor_identity D ,, disp_functor_identity_is_cartesian_disp_functor D))). Proof. use make_invertible_modification. - exact (psfunctor_id_fib_to_psfunctor_bicat_data D HD). - exact (psfunctor_id_fib_to_psfunctor_bicat_laws D HD). Defined. (** 2. Preservation of composition *) Definition psfunctor_comp_fib_to_psfunctor_bicat_data {C : category} {D₁ D₂ D₃ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (HD₃ : cleaving D₃) (F : cartesian_disp_functor (functor_identity C) D₁ D₂) (G : cartesian_disp_functor (functor_identity C) D₂ D₃) : invertible_modification_data (comp_pstrans (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F)) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₂ HD₃ G))) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₃ (disp_functor_over_id_composite F G ,, disp_functor_over_id_composite_is_cartesian (pr2 F) (pr2 G)))). Proof. intro x. use nat_z_iso_to_invertible_2cell. exact (fiber_functor_comp F G x). Defined. Proposition psfunctor_comp_fib_to_psfunctor_bicat_laws {C : category} {D₁ D₂ D₃ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (HD₃ : cleaving D₃) (F : cartesian_disp_functor (functor_identity C) D₁ D₂) (G : cartesian_disp_functor (functor_identity C) D₂ D₃) : is_modification (psfunctor_comp_fib_to_psfunctor_bicat_data HD₁ HD₂ HD₃ F G). Proof. intros x y f. use nat_trans_eq ; [ apply homset_property | ]. intros xx ; cbn. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite id_left_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. use (cartesian_factorisation_unique (disp_functor_over_id_composite_is_cartesian (pr2 F) (pr2 G) _ _ _ _ _ _ (HD₁ _ _ _ _))). rewrite !mor_disp_transportf_postwhisker. cbn. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. refine (!_). apply (disp_functor_comp_var G). } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_comp_fib_to_psfunctor_bicat {C : category} {D₁ D₂ D₃ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (HD₃ : cleaving D₃) (F : cartesian_disp_functor (functor_identity C) D₁ D₂) (G : cartesian_disp_functor (functor_identity C) D₂ D₃) : invertible_modification (comp_pstrans (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F)) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₂ HD₃ G))) (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₃ (disp_functor_over_id_composite F G ,, disp_functor_over_id_composite_is_cartesian (pr2 F) (pr2 G)))). Proof. use make_invertible_modification. - exact (psfunctor_comp_fib_to_psfunctor_bicat_data HD₁ HD₂ HD₃ F G). - exact (psfunctor_comp_fib_to_psfunctor_bicat_laws HD₁ HD₂ HD₃ F G). Defined. Section GrothendieckConstruction. Context (C : univalent_category). (** 3. The data *) Definition psfunctor_fib_to_psfunctor_bicat_data : psfunctor_data (fib_slice_bicat C) (psfunctor_bicat (cat_to_bicat (C^op)) bicat_of_univ_cats). Proof. use make_psfunctor_data. - exact (λ P, indexed_cat_to_psfunctor (cleaving_to_indexed_cat (pr1 P) (pr2 P))). - exact (λ P₁ P₂ F, indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor (pr2 P₁) (pr2 P₂) F)). - exact (λ P₁ P₂ F G τ, indexed_nat_trans_to_modification (disp_nat_trans_to_indexed_nat_trans (pr2 P₁) (pr2 P₂) τ)). - exact (λ P, pr1 (psfunctor_id_fib_to_psfunctor_bicat (pr1 P) (pr2 P))). - exact (λ P₁ P₂ P₃ F G, pr1 (psfunctor_comp_fib_to_psfunctor_bicat _ _ _ F G)). Defined. (** 4. The laws *) Proposition psfunctor_fib_to_psfunctor_bicat_laws : psfunctor_laws psfunctor_fib_to_psfunctor_bicat_data. Proof. repeat split. - intros P₁ P₂ F. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. apply idpath. - intros P₁ P₂ F G H τ θ. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. apply maponpaths_2. apply homset_property. - intros P₁ P₂ F. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite (disp_functor_id (pr1 F)). unfold transportb. rewrite !transport_f_f. refine (!_). apply transportf_set. apply homset_property. - intros P₁ P₂ F. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite !transport_f_f. refine (!_). apply transportf_set. apply homset_property. - intros P₁ P₂ P₃ P₄ F G H. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_left_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite (disp_functor_id (pr1 H)). unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros P₁ P₂ P₃ F G₁ G₂ τ. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros P₁ P₂ P₃ F₁ F₂ G τ. use modification_eq. intros x. use nat_trans_eq. { apply homset_property. } intro xx. cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition invertible_cells_psfunctor_fib_to_psfunctor_bicat : invertible_cells psfunctor_fib_to_psfunctor_bicat_data. Proof. split. - intro P. exact (property_from_invertible_2cell (psfunctor_id_fib_to_psfunctor_bicat (pr1 P) (pr2 P))). - intros P₁ P₂ P₃ F G. exact (property_from_invertible_2cell (psfunctor_comp_fib_to_psfunctor_bicat _ _ _ F G)). Defined. (** 5. Pseudofunctor from fibrations to pseudofunctors *) Definition psfunctor_fib_to_psfunctor_bicat : psfunctor (fib_slice_bicat C) (psfunctor_bicat (cat_to_bicat (C^op)) bicat_of_univ_cats). Proof. use make_psfunctor. - exact psfunctor_fib_to_psfunctor_bicat_data. - exact psfunctor_fib_to_psfunctor_bicat_laws. - exact invertible_cells_psfunctor_fib_to_psfunctor_bicat. Defined. End GrothendieckConstruction. UniMath-20231010/UniMath/Bicategories/Grothendieck/PseudoFunctorToFibration.v000066400000000000000000000735011451125700300270200ustar00rootroot00000000000000(************************************************************************ Grothendieck construction: pseudofunctors to fibrations The Grothendieck construction gives a biequivalence between the bicategory of fibrations over a fixed category `C` and the bicategory of indexed categories over `C`. To construct this biequivalence, we need to construct the following: 1. A pseudofunctor from the bicategory of fibrations to the bicategory of pseudofunctors 2. A pseudofunctor from the bicategory of pseudofunctors to the bicategory of fibrations 3. The unit and a proof that it is a pointwise adjoint equivalence 4. The counit and a proof that it is a pointwise adjoint equivalence In this file, we construct the second part of this biequivalence (a pseudofunctor from pseudofunctors to fibrations). In this construction, we make use of indexed categories in the same way as in `FibrationToPseudoFunctor.v`. As such, the fundamental constructions can be stated purely in the language of category theory and without referring to bicategories. Most of the work in this file lies in proving all of the necessary coherences. Contents 1. The action on pseudofunctors 2. The action on pseudotransformations 3. The action on modifications 4. The identitor 5. The compositor 6. The data 7. The laws 8. The pseudofunctor from pseudofunctors to fibrations ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.NatTransToIndexed. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformationToTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.ModificationIntoCat. Local Open Scope cat. Section GrothendieckConstruction. Context (C : univalent_category). (** 1. The action on pseudofunctors *) Definition psfunctor_psfunctor_bicat_to_fib_ob (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : fib_slice_bicat C := let Φ := psfunctor_to_indexed_cat F in (indexed_cat_to_disp_cat Φ ,, is_univalent_disp_indexed_cat_to_disp_cat Φ) ,, indexed_cat_to_cleaving Φ. (** 2. The action on pseudotransformations *) Definition psfunctor_psfunctor_bicat_to_fib_mor {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (n : pstrans F G) : psfunctor_psfunctor_bicat_to_fib_ob F --> psfunctor_psfunctor_bicat_to_fib_ob G := let τ := pstrans_to_indexed_functor n in indexed_functor_to_cartesian_disp_functor τ. (** 3. The action on modifications *) Definition psfunctor_psfunctor_bicat_to_fib_cell {F G : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} {n₁ n₂ : pstrans F G} (w : modification n₁ n₂) : psfunctor_psfunctor_bicat_to_fib_mor n₁ ==> psfunctor_psfunctor_bicat_to_fib_mor n₂ := let m := modification_to_indexed_nat_trans w in indexed_nat_trans_to_disp_nat_trans m. Arguments psfunctor_psfunctor_bicat_to_fib_cell {_ _ _ _} _ /. (** 4. The identitor *) Definition psfunctor_psfunctor_bicat_to_fib_id_data (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : disp_nat_trans_data (nat_trans_id _) (disp_functor_identity _) (pr1 (psfunctor_psfunctor_bicat_to_fib_mor (id_pstrans F))) := λ x xx, pr11 (psfunctor_id F x) xx. Arguments psfunctor_psfunctor_bicat_to_fib_id_data _ /. Proposition psfunctor_psfunctor_bicat_to_fib_id_laws (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : disp_nat_trans_axioms (psfunctor_psfunctor_bicat_to_fib_id_data F). Proof. intros x y f xx yy ff ; cbn -[psfunctor_id psfunctor_comp]. pose (p := nat_trans_eq_pointwise (psfunctor_linvunitor F f) yy). cbn -[psfunctor_id psfunctor_comp] in p. rewrite id_left in p. rewrite assoc'. etrans. { apply maponpaths. exact (!p). } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. apply id_right. } apply id_right. } exact (!(nat_trans_ax (pr1 (psfunctor_id F x)) _ _ ff)). } cbn -[psfunctor_id psfunctor_comp]. pose (q := nat_trans_eq_pointwise (psfunctor_rinvunitor F f) yy). cbn -[psfunctor_id psfunctor_comp] in q. rewrite assoc'. etrans. { do 2 apply maponpaths. refine (_ @ !q). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F)). } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (_ @ !(psfunctor_idtoiso F _ _)). refine (!(pr1_idtoiso_concat _ _) @ _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#F h) yy) _ _) @ _). apply maponpaths. apply homset_property. Qed. Definition psfunctor_psfunctor_bicat_to_fib_id (F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats) : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (pr1 (psfunctor_psfunctor_bicat_to_fib_mor (id_pstrans F))). Proof. simple refine (_ ,, _). - exact (psfunctor_psfunctor_bicat_to_fib_id_data F). - exact (psfunctor_psfunctor_bicat_to_fib_id_laws F). Defined. (** 5. The compositor *) Definition psfunctor_psfunctor_bicat_to_fib_comp_data {F G H : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (n₁ : pstrans F G) (n₂ : pstrans G H) : disp_nat_trans_data (nat_trans_id _) (disp_functor_over_id_composite (indexed_functor_to_disp_functor (pstrans_to_indexed_functor n₁)) (indexed_functor_to_disp_functor (pstrans_to_indexed_functor n₂))) (indexed_functor_to_disp_functor_data (pstrans_to_indexed_functor (n₁ · n₂))) := λ x xx, pr11 (psfunctor_id H x) _. Arguments psfunctor_psfunctor_bicat_to_fib_comp_data {_ _ _} _ _ _ /. Proposition psfunctor_psfunctor_bicat_to_fib_comp_axioms {F G H : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (n₁ : pstrans F G) (n₂ : pstrans G H) : disp_nat_trans_axioms (psfunctor_psfunctor_bicat_to_fib_comp_data n₁ n₂). Proof. intros x y f xx yy ff ; cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. do 3 apply maponpaths. refine (id_left _ @ _). apply maponpaths. refine (id_left _ @ _). apply id_right. } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat H)). } etrans. { do 2 apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id H x))). } refine (!_). etrans. { do 3 apply maponpaths_2. apply functor_comp. } do 3 refine (assoc' _ _ _ @ _). refine (!_). do 3 refine (assoc' _ _ _ @ _). apply maponpaths. refine (assoc' _ _ _ @ _). do 2 apply maponpaths. etrans. { refine (assoc _ _ _ @ _). apply maponpaths_2. refine (_ @ !(nat_trans_eq_pointwise (psfunctor_rinvunitor H f) _)). refine (_ @ assoc _ _ _). exact (!(id_left _)). } etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!(pr1_idtoiso_concat _ _) @ _). refine (!_). etrans. { refine (_ @ !(nat_trans_eq_pointwise (psfunctor_linvunitor H f) _)). refine (_ @ assoc _ _ _). exact (!(id_left _)). } etrans. { apply psfunctor_idtoiso. } do 2 apply maponpaths. refine (_ @ maponpathscomp0 (λ z, pr1 (#H z) _) _ _). apply maponpaths. apply homset_property. Qed. Definition psfunctor_psfunctor_bicat_to_fib_comp {F G H : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} (n₁ : pstrans F G) (n₂ : pstrans G H) : disp_nat_trans (nat_trans_id _) (disp_functor_over_id_composite (indexed_functor_to_disp_functor (pstrans_to_indexed_functor n₁)) (indexed_functor_to_disp_functor (pstrans_to_indexed_functor n₂))) (indexed_functor_to_disp_functor_data (pstrans_to_indexed_functor (n₁ · n₂))). Proof. simple refine (_ ,, _). - exact (psfunctor_psfunctor_bicat_to_fib_comp_data n₁ n₂). - exact (psfunctor_psfunctor_bicat_to_fib_comp_axioms n₁ n₂). Defined. (** 6. The data *) Definition psfunctor_psfunctor_bicat_to_fib_data : psfunctor_data (psfunctor_bicat (cat_to_bicat (C^op)) bicat_of_univ_cats) (fib_slice_bicat C). Proof. use make_psfunctor_data. - exact psfunctor_psfunctor_bicat_to_fib_ob. - exact (λ F G n, psfunctor_psfunctor_bicat_to_fib_mor n). - exact (λ F G n₁ n₂ w, psfunctor_psfunctor_bicat_to_fib_cell w). - exact (λ F, psfunctor_psfunctor_bicat_to_fib_id F). - exact (λ F G H n₁ n₂, psfunctor_psfunctor_bicat_to_fib_comp n₁ n₂). Defined. (** 7. The laws *) Proposition psfunctor_psfunctor_bicat_to_fib_laws : psfunctor_laws psfunctor_psfunctor_bicat_to_fib_data. Proof. repeat split. - intros F G n. use disp_nat_trans_eq. intros x xx. apply id_left. - intros F G n₁ n₂ n₃ w₁ w₂. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. refine (!_). rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id G x))). } rewrite !assoc'. apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_rinvunitor G (identity x)) (pr1 (pr111 n₃ x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (!(p @ _)). apply maponpaths_2. apply id_left. } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat G)). } cbn -[psfunctor_id psfunctor_comp]. rewrite !assoc'. do 2 apply maponpaths. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!(pr1_idtoiso_concat _ _) @ _). refine (_ @ idtoiso_idpath _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ z, pr1 (#(pr11 G) z) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ z, pr1 (#(pr11 G) z) _) _). apply maponpaths. apply homset_property. - intros F G n. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { apply maponpaths. etrans. { do 2 apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat G)). } etrans. { apply maponpaths_2. do 2 apply maponpaths. apply id_left. } do 3 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. pose (nat_trans_eq_pointwise (pstrans_id_inv_alt n x) xx) as p. cbn -[psfunctor_id] in p. refine (p @ _). rewrite !id_left. apply idpath. } refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor G (identity x)) (pr1 (pr111 n x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. do 2 apply maponpaths_2. refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply (psfunctor_idtoiso G). } exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply maponpaths. do 2 refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor G (identity x)) (pr1 (pr111 n x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. apply (psfunctor_idtoiso G). } exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat G)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } refine (_ @ id_right _). apply maponpaths. refine (_ @ idtoiso_idpath _). do 2 apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. exact (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _)). } exact (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _)). } refine (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ h, pr1 (#(G : psfunctor _ _) h) _) _). apply maponpaths. apply homset_property. - intros F G n. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. refine (!_). etrans. { apply maponpaths. etrans. { do 2 apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat G)). } etrans. { apply maponpaths_2. do 2 apply maponpaths. apply id_left. } do 3 apply maponpaths_2. refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor G (identity x)) (pr1 (pr111 n x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. do 2 apply maponpaths_2. refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply (psfunctor_idtoiso G). } exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply maponpaths. do 2 refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor G (identity x)) (pr1 (pr111 n x) xx)) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. apply (psfunctor_idtoiso G). } exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat G)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } refine (_ @ id_right _). apply maponpaths. refine (_ @ idtoiso_idpath _). do 2 apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. exact (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _)). } exact (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _)). } refine (!(maponpathscomp0 (λ h, pr1 (#(G : psfunctor _ _) h) _) _ _) @ _). refine (_ @ @maponpaths_idpath _ _ (λ h, pr1 (#(G : psfunctor _ _) h) _) _). apply maponpaths. apply homset_property. - intros F₁ F₂ F₃ F₄ n₁ n₂ n₃. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. etrans. { apply maponpaths. refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply id_left. } etrans. { pose (nat_trans_eq_pointwise (psfunctor_linvunitor F₄ (identity x)) (pr1 (pr111 n₃ x) (pr1 (pr111 n₂ x) (pr1 (pr111 n₁ x) xx)))) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply (psfunctor_idtoiso F₄). } etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₄)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } do 2 refine (assoc' _ _ _ @ _). apply maponpaths. refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. etrans. { pose (nat_trans_eq_pointwise (psfunctor_linvunitor F₄ (identity x)) (pr1 (pr111 n₃ x) (pr1 (pr111 n₂ x) (pr1 (pr111 n₁ x) xx)))) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply (psfunctor_idtoiso F₄). } exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₄)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } refine (!_). etrans. { apply maponpaths. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { pose (nat_trans_eq_pointwise (psfunctor_linvunitor F₄ (identity x)) (pr1 (pr111 n₃ x) (pr1 (pr111 n₂ x) (pr1 (pr111 n₁ x) xx)))) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply (psfunctor_idtoiso F₄). } etrans. { apply maponpaths_2. apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₄)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id F₄ x))). } refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { pose (nat_trans_eq_pointwise (psfunctor_rinvunitor F₄ (identity x)) (pr1 (pr111 n₃ x) (pr1 (pr111 n₂ x) (pr1 (pr111 n₁ x) xx)))) as p. cbn -[psfunctor_id psfunctor_comp] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } apply (psfunctor_idtoiso F₄). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } cbn -[psfunctor_id]. apply maponpaths_2. pose (nat_trans_eq_pointwise (pstrans_id_inv_alt n₃ x) (pr1 (pr111 n₂ x) (pr1 (pr111 n₁ x) xx))) as p. cbn -[psfunctor_id] in p. refine (p @ _). rewrite !id_left. apply idpath. } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₄)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (!(pr1_idtoiso_concat _ _)). } do 3 apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. exact (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _)). } exact (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _)). } refine (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _) @ _). refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. exact (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _)). } exact (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _)). } refine (!(maponpathscomp0 (λ h, pr1 (#(F₄ : psfunctor _ _) h) _) _ _) @ _). apply maponpaths. apply homset_property. - intros F₁ F₂ F₃ n m₁ m₂ w. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id F₃ x))). } refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_rinvunitor F₃ (identity x)) (pr1 ((pr111 m₂) x) (pr1 (pr111 n x) xx))) as p. cbn -[psfunctor_comp psfunctor_id] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₃)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!_). apply pr1_idtoiso_concat. } refine (!_). etrans. { apply maponpaths. refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor F₃ (identity x)) (pr1 ((pr111 m₂) x) (pr1 (pr111 n x) xx))) as p. cbn -[psfunctor_comp psfunctor_id] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₃)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!_). apply pr1_idtoiso_concat. } cbn -[psfunctor_comp psfunctor_id]. do 3 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _ _) @ _). refine (_ @ maponpathscomp0 (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _ _). apply maponpaths. apply homset_property. - intros F₁ F₂ F₃ n₁ n₂ m w. use disp_nat_trans_eq. intros x xx. cbn -[psfunctor_id psfunctor_comp]. etrans. { apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (pr1 (psfunctor_id F₃ x))). } refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_rinvunitor F₃ (identity x)) (pr1 ((pr111 m) x) (pr1 (pr111 n₂ x) xx))) as p. cbn -[psfunctor_comp psfunctor_id] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₃)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!_). apply pr1_idtoiso_concat. } refine (!_). etrans. { apply maponpaths. refine (assoc' _ _ _ @ _). apply maponpaths. pose (nat_trans_eq_pointwise (psfunctor_linvunitor F₃ (identity x)) (pr1 ((pr111 m) x) (pr1 (pr111 n₂ x) xx))) as p. cbn -[psfunctor_comp psfunctor_id] in p. refine (_ @ !p). apply maponpaths_2. exact (!(id_left _)). } etrans. { apply (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat F₃)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply psfunctor_idtoiso. } refine (!_). apply pr1_idtoiso_concat. } cbn -[psfunctor_comp psfunctor_id]. etrans. { do 2 apply maponpaths_2. apply functor_comp. } refine (assoc' _ _ _ @ _ @ assoc _ _ _). refine (assoc' _ _ _ @ _). apply maponpaths. refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. pose (nat_trans_eq_pointwise (pstrans_id_inv_alt m x) (pr1 (pr111 n₂ x) xx)) as p. cbn -[psfunctor_id] in p. refine (p @ _). rewrite !id_left. apply idpath. } do 3 apply maponpaths. refine (!(maponpathscomp0 (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _ _) @ _). refine (_ @ maponpathscomp0 (λ h, pr1 (#(F₃ : psfunctor _ _) h) _) _ _). apply maponpaths. apply homset_property. Qed. Definition psfunctor_psfunctor_bicat_to_fib_invertible_cells : invertible_cells psfunctor_psfunctor_bicat_to_fib_data. Proof. split. - intro F. use is_invertible_2cell_fib_slice. intros x xx. simple refine (transportf (λ z, is_z_iso_disp _ z) _ (indexed_cat_to_disp_cat_to_disp_iso (psfunctor_to_indexed_cat F) _ _ _ _)). + apply id_left. + apply is_z_isomorphism_identity. - intros F G H n₁ n₂. use is_invertible_2cell_fib_slice. intros x xx. simple refine (transportf (λ z, is_z_iso_disp _ z) _ (indexed_cat_to_disp_cat_to_disp_iso (psfunctor_to_indexed_cat H) _ _ _ _)). + apply id_left. + apply is_z_isomorphism_identity. Qed. (** 8. The pseudofunctor from pseudofunctors to fibrations *) Definition psfunctor_psfunctor_bicat_to_fib : psfunctor (psfunctor_bicat (cat_to_bicat (C^op)) bicat_of_univ_cats) (fib_slice_bicat C). Proof. use make_psfunctor. - exact psfunctor_psfunctor_bicat_to_fib_data. - exact psfunctor_psfunctor_bicat_to_fib_laws. - exact psfunctor_psfunctor_bicat_to_fib_invertible_cells. Defined. End GrothendieckConstruction. UniMath-20231010/UniMath/Bicategories/Grothendieck/Unit.v000066400000000000000000000714571451125700300230060ustar00rootroot00000000000000(************************************************************************ Grothendieck construction: the unit The Grothendieck construction gives a biequivalence between the bicategory of fibrations over a fixed category `C` and the bicategory of indexed categories over `C`. To construct this biequivalence, we need to construct the following: 1. A pseudofunctor from the bicategory of fibrations to the bicategory of pseudofunctors 2. A pseudofunctor from the bicategory of pseudofunctors to the bicategory of fibrations 3. The unit and a proof that it is a pointwise adjoint equivalence 4. The counit and a proof that it is a pointwise adjoint equivalence In this file, we construct the third part of this biequivalence, namely the unit. Contents 1. Action on objects 2. Action on 1-cells 3. The data 4. The laws 5. The unit 6. The action on objects forms an equivalence 7. The unit is a pointwise adjoint equivalence ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.NatTransToIndexed. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformationToTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.ModificationIntoCat. Require Import UniMath.Bicategories.Grothendieck.FibrationToPseudoFunctor. Require Import UniMath.Bicategories.Grothendieck.PseudoFunctorToFibration. Local Open Scope cat. Section GrothendieckConstruction. Context {C : univalent_category}. Local Notation "'tr' P x" := (transportf P _ x) (at level 100, only printing). (** 1. Action on objects *) Definition psfunctor_fib_to_psfunctor_unit_disp_functor_data (D : disp_univalent_category C) (HD : cleaving D) : disp_functor_data (functor_identity C) (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))) D. Proof. simple refine (_ ,, _). - exact (λ x xx, xx). - cbn. refine (λ x y xx yy f ff, transportf (λ z, _ -->[ z ] _) _ (ff ;; HD y x f yy)%mor_disp). abstract (apply id_left). Defined. Proposition psfunctor_fib_to_psfunctor_unit_disp_functor_axioms (D : disp_univalent_category C) (HD : cleaving D) : disp_functor_axioms (psfunctor_fib_to_psfunctor_unit_disp_functor_data D HD). Proof. split. - intros x xx ; cbn. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. - intros x y z xx yy zz f g ff gg ; cbn. rewrite mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !assoc_disp_var. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. apply idpath. } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_disp_functor (D : disp_univalent_category C) (HD : cleaving D) : disp_functor (functor_identity C) (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))) D. Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor_data D HD). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor_axioms D HD). Defined. Opaque psfunctor_to_indexed_cat. Definition is_cartesian_psfunctor_fib_to_psfunctor_unit_disp_functor (D : disp_univalent_category C) (HD : cleaving D) : is_cartesian_disp_functor (psfunctor_fib_to_psfunctor_unit_disp_functor D HD). Proof. intros x y f xx yy ff Hff. use is_cartesian_transportf. use is_cartesian_comp_disp. - use is_cartesian_z_iso_disp. + exact (pr2 (identity_z_iso y)). + refine (z_iso_disp_from_z_iso_fiber D y yy (pr1 (HD x y f xx)) (ff ,, _)). cbn in xx, yy, ff. exact (is_cartesian_to_iso_indexed_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD))) ff Hff). - apply cartesian_lift_is_cartesian. Qed. Transparent psfunctor_to_indexed_cat. Definition psfunctor_fib_to_psfunctor_unit_cartesian_disp_functor (D : disp_univalent_category C) (HD : cleaving D) : cartesian_disp_functor (functor_identity C) (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))) D. Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor D HD). - exact (is_cartesian_psfunctor_fib_to_psfunctor_unit_disp_functor D HD). Defined. (** 2. Action on 1-cells *) Definition psfunctor_fib_to_psfunctor_unit_natural_data {D₁ D₂ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (F : cartesian_disp_functor (functor_identity _) D₁ D₂) : disp_nat_trans_data (nat_trans_id _) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor D₁ HD₁) F) (disp_functor_over_id_composite (indexed_functor_to_disp_functor (pstrans_to_indexed_functor (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F)))) (psfunctor_fib_to_psfunctor_unit_disp_functor D₂ HD₂)) := λ x xx, id_disp _. Proposition psfunctor_fib_to_psfunctor_unit_natural_axioms {D₁ D₂ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (F : cartesian_disp_functor (functor_identity _) D₁ D₂) : disp_nat_trans_axioms (psfunctor_fib_to_psfunctor_unit_natural_data HD₁ HD₂ F). Proof. intros x y f xx yy ff ; cbn. unfold transportb, fiber_functor_natural_inv, psfunctor_fib_to_psfunctor_unit_natural_data. rewrite (disp_functor_transportf _ F). rewrite mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite id_right_disp. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_natural {D₁ D₂ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (F : cartesian_disp_functor (functor_identity _) D₁ D₂) : disp_nat_trans (nat_trans_id _) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor D₁ HD₁) F) (disp_functor_over_id_composite (indexed_functor_to_disp_functor (pstrans_to_indexed_functor (indexed_functor_to_pstrans (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F)))) (psfunctor_fib_to_psfunctor_unit_disp_functor D₂ HD₂)). Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_natural_data HD₁ HD₂ F). - exact (psfunctor_fib_to_psfunctor_unit_natural_axioms HD₁ HD₂ F). Defined. (** 3. The data *) Definition psfunctor_fib_to_psfunctor_unit_data : pstrans_data (comp_psfunctor (psfunctor_psfunctor_bicat_to_fib C) (psfunctor_fib_to_psfunctor_bicat C)) (id_psfunctor _). Proof. use make_pstrans_data. - exact (λ P, psfunctor_fib_to_psfunctor_unit_cartesian_disp_functor (pr1 P) (pr2 P)). - simple refine (λ P₁ P₂ F, make_invertible_2cell _). + exact (psfunctor_fib_to_psfunctor_unit_natural (pr2 P₁) (pr2 P₂) F). + use is_invertible_2cell_fib_slice. intros x xx. apply id_is_z_iso_disp. Defined. (** 4. The laws *) Proposition is_pstrans_psfunctor_fib_to_psfunctor_unit : is_pstrans psfunctor_fib_to_psfunctor_unit_data. Proof. refine (_ ,, _ ,, _). - intros P₁ P₂ F G τ. use disp_nat_trans_eq. intros x xx. cbn ; unfold psfunctor_fib_to_psfunctor_unit_natural_data. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite id_right_disp. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros P. use disp_nat_trans_eq. intros x xx. cbn ; unfold psfunctor_fib_to_psfunctor_unit_natural_data. rewrite transportf_object_cartesian_lift. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_left_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite !id_left_disp. unfold transportb. rewrite !transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. unfold transportb. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. apply idpath. } rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite id_right_disp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros P₁ P₂ P₃ F G. use disp_nat_trans_eq. intros x xx. cbn ; unfold psfunctor_fib_to_psfunctor_unit_natural_data. rewrite transportf_object_cartesian_lift. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_left_disp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite (disp_functor_id (pr1 G)). rewrite !id_right_disp. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_left_disp. unfold transportb. rewrite !transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. unfold transportb. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply idpath. } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. (** 5. The unit *) Definition psfunctor_fib_to_psfunctor_unit : pstrans (comp_psfunctor (psfunctor_psfunctor_bicat_to_fib C) (psfunctor_fib_to_psfunctor_bicat C)) (id_psfunctor _). Proof. use make_pstrans. - exact psfunctor_fib_to_psfunctor_unit_data. - exact is_pstrans_psfunctor_fib_to_psfunctor_unit. Defined. (** 6. The action on objects forms an equivalence *) Definition psfunctor_fib_to_psfunctor_unit_disp_functor_inv_data (D : disp_univalent_category C) (HD : cleaving D) : disp_functor_data (functor_identity C) D (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))). Proof. simple refine (_ ,, _). - exact (λ x xx, xx). - cbn. refine (λ x y xx yy f ff, cartesian_factorisation (HD y x f yy) _ (transportf (λ z, _ -->[ z ] _) _ ff)). abstract (exact (!(id_left _))). Defined. Proposition psfunctor_fib_to_psfunctor_unit_disp_functor_inv_axioms (D : disp_univalent_category C) (HD : cleaving D) : disp_functor_axioms (psfunctor_fib_to_psfunctor_unit_disp_functor_inv_data D HD). Proof. split. - intros x xx ; cbn. apply maponpaths. unfold transportb. apply maponpaths_2. apply homset_property. - intros x y z xx yy zz f g ff gg ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc_disp. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. apply idpath. } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_disp_functor_inv (D : disp_univalent_category C) (HD : cleaving D) : disp_functor (functor_identity C) D (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))). Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor_inv_data D HD). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor_inv_axioms D HD). Defined. Definition is_cartesian_psfunctor_fib_to_psfunctor_unit_disp_functor_inv (D : disp_univalent_category C) (HD : cleaving D) : is_cartesian_disp_functor (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD). Proof. intros x y f xx yy ff Hff. cbn. use is_cartesian_indexed_cat. use is_z_iso_fiber_from_is_z_iso_disp. simple refine (_ ,, _ ,, _) ; cbn. - refine (cartesian_factorisation Hff (identity _) _). exact (transportb (λ z, _ -->[ z ] _) (id_left _) (HD x y f xx)). - use (cartesian_factorisation_unique (HD _ _ _ _)). unfold transportb. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite cartesian_factorisation_commutes. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - use (cartesian_factorisation_unique Hff). unfold transportb. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite cartesian_factorisation_commutes. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_cartesian_disp_functor_inv (D : disp_univalent_category C) (HD : cleaving D) : cartesian_disp_functor (functor_identity C) D (indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))). Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD). - exact (is_cartesian_psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD). Defined. Definition psfunctor_fib_to_psfunctor_unit_equiv_unit_data (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans_data (nat_trans_id (functor_identity C)) (disp_functor_identity _) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor D HD) (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD)). Proof. intros x xx ; cbn. refine (cartesian_factorisation (HD x x (identity x) xx) _ (transportf (λ z, _ -->[ z ] _) _ (id_disp _))). exact (!(id_left _)). Defined. Proposition psfunctor_fib_to_psfunctor_unit_equiv_unit_laws (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans_axioms (psfunctor_fib_to_psfunctor_unit_equiv_unit_data D HD). Proof. intros x y f xx yy ff. cbn. unfold psfunctor_fib_to_psfunctor_unit_equiv_unit_data. rewrite !mor_disp_transportf_postwhisker. unfold transportb. rewrite !transport_f_f. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite !mor_disp_transportf_postwhisker. etrans. { rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. apply idpath. } unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_postwhisker. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. apply idpath. } refine (!_). etrans. { rewrite (transportf_indexed_cat_to_disp_cat (psfunctor_to_indexed_cat (indexed_cat_to_psfunctor (cleaving_to_indexed_cat D HD)))). cbn. etrans. { apply maponpaths_2. do 2 apply maponpaths. apply idtoiso_fiber_category. } rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 3 apply maponpaths. apply idtoiso_disp_cartesian_lift. } rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. apply idpath. } rewrite mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply idpath. } apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_equiv_unit (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_identity _) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor D HD) (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD)). Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_equiv_unit_data D HD). - exact (psfunctor_fib_to_psfunctor_unit_equiv_unit_laws D HD). Defined. Definition psfunctor_fib_to_psfunctor_unit_equiv_counit_data (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans_data (nat_trans_id (functor_identity C)) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD) (psfunctor_fib_to_psfunctor_unit_disp_functor D HD)) (disp_functor_identity _) := λ x xx, id_disp _. Proposition psfunctor_fib_to_psfunctor_unit_equiv_counit_laws (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans_axioms (psfunctor_fib_to_psfunctor_unit_equiv_counit_data D HD). Proof. intros x y f xx yy zz ; cbn. unfold psfunctor_fib_to_psfunctor_unit_equiv_counit_data. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition psfunctor_fib_to_psfunctor_unit_equiv_counit (D : disp_univalent_category C) (HD : cleaving D) : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_over_id_composite (psfunctor_fib_to_psfunctor_unit_disp_functor_inv D HD) (psfunctor_fib_to_psfunctor_unit_disp_functor D HD)) (disp_functor_identity _). Proof. simple refine (_ ,, _). - exact (psfunctor_fib_to_psfunctor_unit_equiv_counit_data D HD). - exact (psfunctor_fib_to_psfunctor_unit_equiv_counit_laws D HD). Defined. (** 7. The unit is a pointwise adjoint equivalence *) Definition psfunctor_fib_to_psfunctor_unit_equiv (D : disp_univalent_category C) (HD : cleaving D) : @left_equivalence (fib_slice_bicat C) _ _ (psfunctor_fib_to_psfunctor_unit (D ,, HD)). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (psfunctor_fib_to_psfunctor_unit_cartesian_disp_functor_inv D HD). - exact (psfunctor_fib_to_psfunctor_unit_equiv_unit D HD). - exact (psfunctor_fib_to_psfunctor_unit_equiv_counit D HD). - cbn. use is_invertible_2cell_fib_slice. intros x xx. use is_z_iso_disp_indexed_cat_to_disp_cat. cbn ; cbn in xx. unfold psfunctor_fib_to_psfunctor_unit_equiv_unit_data. use is_z_iso_fiber_from_is_z_iso_disp. use (is_z_iso_disp_cartesian_factorisation (identity_is_z_iso x) (identity_is_z_iso x)). use (@is_z_iso_disp_transportf_fun_eq _ _ _ _ (identity_z_iso _)). apply id_is_z_iso_disp. - use is_invertible_2cell_fib_slice. intros x xx ; cbn. apply id_is_z_iso_disp. Defined. End GrothendieckConstruction. UniMath-20231010/UniMath/Bicategories/Limits/000077500000000000000000000000001451125700300205155ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Limits/CommaObjects.v000066400000000000000000000433751451125700300232660ustar00rootroot00000000000000(**************************************************************** Comma objects in bicategories In this file we define the notion of comma squares in arbitrary bicategories. This definition is expressed using universal properties. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section CommaObject. Context {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃}. (** 1. Cones *) Definition comma_cone : UU := ∑ (p : B) (π₁ : p --> b₁) (π₂ : p --> b₂), π₁ · f ==> π₂ · g. Coercion comma_cone_obj (p : comma_cone) : B := pr1 p. Definition comma_cone_pr1 (p : comma_cone) : p --> b₁ := pr12 p. Definition comma_cone_pr2 (p : comma_cone) : p --> b₂ := pr122 p. Definition comma_cone_cell (p : comma_cone) : comma_cone_pr1 p · f ==> comma_cone_pr2 p · g := pr222 p. Definition make_comma_cone (p : B) (π₁ : p --> b₁) (π₂ : p --> b₂) (η : π₁ · f ==> π₂ · g) : comma_cone := (p ,, π₁ ,, π₂ ,, η). (** 2. 1-cells and 2-cells of cones *) Definition comma_1cell (p q : comma_cone) : UU := ∑ (φ : p --> q) (τ : invertible_2cell (φ · comma_cone_pr1 q) (comma_cone_pr1 p)) (θ : invertible_2cell (φ · comma_cone_pr2 q) (comma_cone_pr2 p)), φ ◃ comma_cone_cell q = lassociator _ _ _ • (τ ▹ f) • comma_cone_cell p • (θ^-1 ▹ g) • rassociator _ _ _. Coercion comma_1cell_1cell {p q : comma_cone} (φ : comma_1cell p q) : p --> q := pr1 φ. Definition comma_1cell_pr1 {p q : comma_cone} (φ : comma_1cell p q) : invertible_2cell (φ · comma_cone_pr1 q) (comma_cone_pr1 p) := pr12 φ. Definition comma_1cell_pr2 {p q : comma_cone} (φ : comma_1cell p q) : invertible_2cell (φ · comma_cone_pr2 q) (comma_cone_pr2 p) := pr122 φ. Definition comma_1cell_eq {p q : comma_cone} (φ : comma_1cell p q) : φ ◃ comma_cone_cell q = lassociator _ _ _ • (comma_1cell_pr1 φ ▹ f) • comma_cone_cell p • ((comma_1cell_pr2 φ)^-1 ▹ g) • rassociator _ _ _ := pr222 φ. Definition make_comma_1cell {p q : comma_cone} (φ : p --> q) (τ : invertible_2cell (φ · comma_cone_pr1 q) (comma_cone_pr1 p)) (θ : invertible_2cell (φ · comma_cone_pr2 q) (comma_cone_pr2 p)) (H : φ ◃ comma_cone_cell q = lassociator _ _ _ • (τ ▹ f) • comma_cone_cell p • (θ^-1 ▹ g) • rassociator _ _ _) : comma_1cell p q := (φ ,, τ ,, θ ,, H). Definition eq_comma_1cell {p q : comma_cone} (φ ψ : comma_1cell p q) (r₁ : pr1 φ = pr1 ψ) (r₂ : pr1 (comma_1cell_pr1 φ) = (idtoiso_2_1 _ _ r₁ ▹ comma_cone_pr1 q) • pr1 (comma_1cell_pr1 ψ)) (r₃ : pr1 (comma_1cell_pr2 φ) = (idtoiso_2_1 _ _ r₁ ▹ comma_cone_pr2 q) • pr1 (comma_1cell_pr2 ψ)) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ [ φ₃ φ₄ ]]]. induction ψ as [ ψ₁ [ ψ₂ [ ψ₃ ψ₄ ]]]. cbn in r₁. induction r₁ ; cbn in r₂. apply maponpaths. assert (φ₂ = ψ₂) as r'. { use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite id2_rwhisker, id2_left in r₂. exact r₂. } induction r'. apply maponpaths. use subtypePath. { intro ; apply cellset_property. } cbn. cbn in r₃. rewrite id2_rwhisker, id2_left in r₃. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact r₃. Qed. (** 3. Statements of universal mapping properties of pullbacks *) Section UniversalMappingPropertyStatements. Variable (p : comma_cone). Definition comma_ump_1 : UU := ∏ (q : comma_cone), comma_1cell q p. Definition comma_ump_2 : UU := ∏ (q : B) (φ ψ : q --> p) (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p) (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p) (r : (φ ◃ comma_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ comma_cone_cell p)), ∃! (γ : φ ==> ψ), (γ ▹ comma_cone_pr1 p = α) × (γ ▹ comma_cone_pr2 p = β). Definition has_comma_ump : UU := comma_ump_1 × comma_ump_2. End UniversalMappingPropertyStatements. Definition has_comma_ump_1 {p : comma_cone} (H : has_comma_ump p) : comma_ump_1 p := pr1 H. Definition has_comma_ump_2 {p : comma_cone} (H : has_comma_ump p) : comma_ump_2 p := pr2 H. Section Projections. Context {p : comma_cone} (Hp : has_comma_ump p). Definition comma_ump_mor (q : comma_cone) : q --> p := pr1 Hp q. Definition comma_ump_mor_pr1 (q : comma_cone) : invertible_2cell (comma_ump_mor q · comma_cone_pr1 p) (comma_cone_pr1 q) := comma_1cell_pr1 (pr1 Hp q). Definition comma_ump_mor_pr2 (q : comma_cone) : invertible_2cell (comma_ump_mor q · comma_cone_pr2 p) (comma_cone_pr2 q) := comma_1cell_pr2 (pr1 Hp q). Definition comma_ump_mor_cell (q : comma_cone) : pr1 Hp q ◃ comma_cone_cell p = lassociator (pr1 Hp q) (comma_cone_pr1 p) f • (comma_1cell_pr1 (pr1 Hp q) ▹ f) • comma_cone_cell q • ((comma_1cell_pr2 (pr1 Hp q)) ^-1 ▹ g) • rassociator (pr1 Hp q) (comma_cone_pr2 p) g := comma_1cell_eq (pr1 Hp q). Section CellProperty. Context {q : B} (φ ψ : q --> p) (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p) (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p) (r : (φ ◃ comma_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ comma_cone_cell p)). Definition comma_ump_cell : φ ==> ψ := pr11 (pr2 Hp q φ ψ α β r). Definition comma_ump_cell_pr1 : comma_ump_cell ▹ comma_cone_pr1 p = α := pr121 (pr2 Hp q φ ψ α β r). Definition comma_ump_cell_pr2 : comma_ump_cell ▹ comma_cone_pr2 p = β := pr221 (pr2 Hp q φ ψ α β r). Definition comma_ump_eq (τ₁ τ₂ : φ ==> ψ) (τ₁_pr1 : τ₁ ▹ comma_cone_pr1 p = α) (τ₁_pr2 : τ₁ ▹ comma_cone_pr2 p = β) (τ₂_pr1 : τ₂ ▹ comma_cone_pr1 p = α) (τ₂_pr2 : τ₂ ▹ comma_cone_pr2 p = β) : τ₁ = τ₂ := maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr2 Hp q φ ψ α β r)) (τ₁ ,, τ₁_pr1 ,, τ₁_pr2) (τ₂ ,, τ₂_pr1 ,, τ₂_pr2)). End CellProperty. End Projections. Section InvertibleCommaUmpCell. Context {p : comma_cone} (Hp : has_comma_ump p) {q : B} {φ ψ : q --> p} {α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p} {β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p} (r : (φ ◃ comma_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ comma_cone_cell p)) (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β). Definition is_invertible_2cell_comma_ump_cell_inv : ψ ==> φ. Proof. use (comma_ump_cell Hp _ _ (Hα^-1) (Hβ^-1)). abstract (do 3 (use vcomp_move_R_Mp ; [ is_iso | ]) ; rewrite !vassocl ; do 3 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn ; rewrite !vassocr ; exact (!r)). Defined. Lemma is_invertible_2cell_comma_ump_cell_left : comma_ump_cell Hp φ ψ α β r • is_invertible_2cell_comma_ump_cell_inv = id₂ φ. Proof. use (comma_ump_eq Hp). - apply id2. - apply id2. - rewrite !id2_rwhisker, !id2_right. rewrite lassociator_rassociator, id2_left. rewrite vassocl. rewrite lassociator_rassociator. apply id2_right. - unfold is_invertible_2cell_comma_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !comma_ump_cell_pr1. apply vcomp_rinv. - unfold is_invertible_2cell_comma_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !comma_ump_cell_pr2. apply vcomp_rinv. - apply id2_rwhisker. - apply id2_rwhisker. Qed. Lemma is_invertible_2cell_comma_ump_cell_right : is_invertible_2cell_comma_ump_cell_inv • comma_ump_cell Hp φ ψ α β r = id₂ _. Proof. use (comma_ump_eq Hp). - apply id2. - apply id2. - rewrite !id2_rwhisker, !id2_right. rewrite lassociator_rassociator, id2_left. rewrite vassocl. rewrite lassociator_rassociator. apply id2_right. - unfold is_invertible_2cell_comma_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !comma_ump_cell_pr1. apply vcomp_linv. - unfold is_invertible_2cell_comma_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !comma_ump_cell_pr2. apply vcomp_linv. - apply id2_rwhisker. - apply id2_rwhisker. Qed. Definition is_invertible_2cell_comma_ump_cell : is_invertible_2cell (comma_ump_cell Hp φ ψ α β r). Proof. use make_is_invertible_2cell. - exact is_invertible_2cell_comma_ump_cell_inv. - exact is_invertible_2cell_comma_ump_cell_left. - exact is_invertible_2cell_comma_ump_cell_right. Defined. End InvertibleCommaUmpCell. (** 4. Being a pullback is a property (requires local univalence) *) Definition isaprop_has_comma_ump (HB_2_1 : is_univalent_2_1 B) (p : comma_cone) : isaprop (has_comma_ump p). Proof. use invproofirrelevance. intros χ₁ χ₂. use subtypePath. { intro. do 6 (use impred ; intro). apply isapropiscontr. } use funextsec ; intro q. use eq_comma_1cell ; cbn. - use (isotoid_2_1 HB_2_1). use make_invertible_2cell. + use (comma_ump_cell χ₁). * exact (comma_ump_mor_pr1 χ₁ q • (comma_ump_mor_pr1 χ₂ q)^-1). * exact (comma_ump_mor_pr2 χ₁ q • (comma_ump_mor_pr2 χ₂ q)^-1). * abstract (refine (!_) ; refine (maponpaths (λ z, _ • z) (comma_ump_mor_cell χ₂ q) @ _) ; rewrite !vassocl ; refine (!_) ; refine (maponpaths (λ z, z • _) (comma_ump_mor_cell χ₁ q) @ _) ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath). + use make_is_invertible_2cell. * use (comma_ump_cell χ₁). ** exact (comma_ump_mor_pr1 χ₂ q • (comma_ump_mor_pr1 χ₁ q)^-1). ** exact (comma_ump_mor_pr2 χ₂ q • (comma_ump_mor_pr2 χ₁ q)^-1). ** abstract (refine (!_) ; refine (maponpaths (λ z, _ • z) (comma_ump_mor_cell χ₁ q) @ _) ; rewrite !vassocl ; refine (!_) ; refine (maponpaths (λ z, z • _) (comma_ump_mor_cell χ₂ q) @ _) ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath). * use (comma_ump_eq χ₁ _ _ (id₂ _) (id₂ _)). ** abstract (rewrite !id2_rwhisker ; rewrite !id2_right ; rewrite lassociator_rassociator ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_left, id2_right ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !comma_ump_cell_pr1 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !comma_ump_cell_pr2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** apply id2_rwhisker. ** apply id2_rwhisker. * use (comma_ump_eq χ₁ _ _ (id₂ _) (id₂ _)). ** abstract (rewrite !id2_rwhisker ; rewrite !id2_right ; rewrite lassociator_rassociator ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_left, id2_right ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !comma_ump_cell_pr1 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !comma_ump_cell_pr2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** apply id2_rwhisker. ** apply id2_rwhisker. - abstract (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; refine (!_) ; rewrite comma_ump_cell_pr1 ; rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). - abstract (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; refine (!_) ; rewrite comma_ump_cell_pr2 ; rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). Qed. End CommaObject. Arguments comma_cone {_ _ _ _} _ _. (** 5. Bicategories with comma objects *) Definition has_comma (B : bicat) : UU := ∏ (b₁ b₂ b₃ : B) (f : b₁ --> b₃) (g : b₂ --> b₃), ∑ (p : comma_cone f g), has_comma_ump p. Definition bicat_with_comma : UU := ∑ (B : bicat), has_comma B. Coercion bicat_with_comma_to_bicat (B : bicat_with_comma) : bicat := pr1 B. UniMath-20231010/UniMath/Bicategories/Limits/EilenbergMooreComonad.v000066400000000000000000000360441451125700300251120ustar00rootroot00000000000000(************************************************************************* Eilenberg-Moore objects of comonads In this file, we define the notion of Eilenberg-Moore object for comonads. The main purpose of this notion, is that Eilenberg-Moore objects for comonads in `B` give rise to Eilenberg-Moore objects in `op2_bicat B`. Contents 1. Eilenberg-Moore objects of comonads via universal mapping properties 2. Being an Eilenberg-Moore object for a comonad is a proposition 3. Bicategories with Eilenberg-Moore objects for comonads *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. Section EilenbergMooreComonad. Context {B : bicat} (m : mnd (op2_bicat B)). Let z : B := ob_of_mnd m. Let h : z --> z := endo_of_mnd m. Let ε : h ==> id₁ _ := unit_of_mnd m. Let ν : h ==> h · h := mult_of_mnd m. (** 1. Eilenberg-Moore objects of comonads via universal mapping properties *) Definition em_comnd_cone : UU := ∑ (x : B) (f : x --> z) (γ : f ==> f · h), (γ • (f ◃ ε) = rinvunitor _) × (γ • (γ ▹ _) • rassociator _ _ _ = γ • (f ◃ ν)). Definition make_em_comnd_cone {x : B} (f : x --> z) (γ : f ==> f · h) (fε : γ • (f ◃ ε) = rinvunitor _) (fν : γ • (γ ▹ _) • rassociator _ _ _ = γ • (f ◃ ν)) : em_comnd_cone := x ,, f ,, γ ,, fε ,, fν. Coercion em_comnd_cone_ob (q : em_comnd_cone) : B := pr1 q. Section Projections. Context (q : em_comnd_cone). Definition mor_of_em_comnd_cone : q --> z := pr12 q. Definition cell_of_em_comnd_cone : mor_of_em_comnd_cone ==> mor_of_em_comnd_cone · h := pr122 q. Definition em_comnd_cone_counit : cell_of_em_comnd_cone • (_ ◃ ε) = rinvunitor _ := pr1 (pr222 q). Definition em_comnd_cone_comult : (cell_of_em_comnd_cone • (cell_of_em_comnd_cone ▹ _)) • rassociator _ _ _ = cell_of_em_comnd_cone • (_ ◃ ν) := pr2 (pr222 q). End Projections. Definition em_comnd_cone_mor (q₁ q₂ : em_comnd_cone) : UU := ∑ (f : q₁ --> q₂) (α : mor_of_em_comnd_cone q₁ ==> f · mor_of_em_comnd_cone q₂), (cell_of_em_comnd_cone q₁ • (α ▹ _) = α • (_ ◃ cell_of_em_comnd_cone q₂) • lassociator _ _ _) × is_invertible_2cell α. Definition make_em_comnd_cone_mor {q₁ q₂ : em_comnd_cone} (f : q₁ --> q₂) (α : mor_of_em_comnd_cone q₁ ==> f · mor_of_em_comnd_cone q₂) (p : cell_of_em_comnd_cone q₁ • (α ▹ _) = α • (_ ◃ cell_of_em_comnd_cone q₂) • lassociator _ _ _) (Hα : is_invertible_2cell α) : em_comnd_cone_mor q₁ q₂ := f ,, α ,, p ,, Hα. Coercion mor_of_em_comnd_cone_mor {q₁ q₂ : em_comnd_cone} (f : em_comnd_cone_mor q₁ q₂) : q₁ --> q₂ := pr1 f. Definition cell_of_em_comnd_cone_mor {q₁ q₂ : em_comnd_cone} (f : em_comnd_cone_mor q₁ q₂) : mor_of_em_comnd_cone q₁ ==> f · mor_of_em_comnd_cone q₂ := pr12 f. Definition em_comnd_cone_mor_endo {q₁ q₂ : em_comnd_cone} (f : em_comnd_cone_mor q₁ q₂) : cell_of_em_comnd_cone q₁ • (cell_of_em_comnd_cone_mor f ▹ _) = cell_of_em_comnd_cone_mor f • (_ ◃ cell_of_em_comnd_cone q₂) • lassociator _ _ _ := pr122 f. Definition cell_of_em_comnd_cone_mor_is_invertible {q₁ q₂ : em_comnd_cone} (f : em_comnd_cone_mor q₁ q₂) : is_invertible_2cell (cell_of_em_comnd_cone_mor f) := pr222 f. Definition inv2cell_of_em_comnd_cone_mor {q₁ q₂ : em_comnd_cone} (f : em_comnd_cone_mor q₁ q₂) : invertible_2cell (mor_of_em_comnd_cone q₁) (f · mor_of_em_comnd_cone q₂). Proof. use make_invertible_2cell. - exact (cell_of_em_comnd_cone_mor f). - exact (cell_of_em_comnd_cone_mor_is_invertible f). Defined. Definition path_em_comnd_cone_mor (HB : is_univalent_2_1 B) {q₁ q₂ : em_comnd_cone} {f₁ f₂ : em_comnd_cone_mor q₁ q₂} (α : invertible_2cell f₁ f₂) (p : cell_of_em_comnd_cone_mor f₁ • (α ▹ mor_of_em_comnd_cone q₂) = cell_of_em_comnd_cone_mor f₂) : f₁ = f₂. Proof. use total2_paths_f. - exact (isotoid_2_1 HB α). - use subtypePath. { intro. apply isapropdirprod ; [ apply cellset_property | apply isaprop_is_invertible_2cell ]. } rewrite pr1_transportf. rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function. cbn. rewrite id2_left. rewrite <- idtoiso_2_1_rwhisker. rewrite idtoiso_2_1_isotoid_2_1. exact p. Qed. Definition has_em_comnd_ump_1 (e : em_comnd_cone) : UU := ∏ (q : em_comnd_cone), em_comnd_cone_mor q e. Definition has_em_comnd_ump_2 (e : em_comnd_cone) : UU := ∏ (x : B) (g₁ g₂ : x --> e) (α : g₁ · mor_of_em_comnd_cone e ==> g₂ · mor_of_em_comnd_cone e) (p : α • (_ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (_ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ _)), ∃! (β : g₁ ==> g₂), β ▹ _ = α. Definition has_em_comnd_ump (e : em_comnd_cone) : UU := has_em_comnd_ump_1 e × has_em_comnd_ump_2 e. Section Projections. Context {e : em_comnd_cone} (He : has_em_comnd_ump e). Definition em_comnd_ump_mor {a : B} (g : a --> z) (γ : g ==> g · h) (p₁ : γ • (g ◃ ε) = rinvunitor g) (p₂ : (γ • (γ ▹ h)) • rassociator g h h = γ • (g ◃ ν)) : a --> e := pr1 He (make_em_comnd_cone g γ p₁ p₂). Definition em_comnd_ump_mor_cell {a : B} (g : a --> z) (γ : g ==> g · h) (p₁ : γ • (g ◃ ε) = rinvunitor g) (p₂ : (γ • (γ ▹ h)) • rassociator g h h = γ • (g ◃ ν)) : g ==> em_comnd_ump_mor g γ p₁ p₂ · mor_of_em_comnd_cone e := cell_of_em_comnd_cone_mor (pr1 He (make_em_comnd_cone g γ p₁ p₂)). Definition em_comnd_ump_mor_cell_endo {a : B} (g : a --> z) (γ : g ==> g · h) (p₁ : γ • (g ◃ ε) = rinvunitor g) (p₂ : (γ • (γ ▹ h)) • rassociator g h h = γ • (g ◃ ν)) : γ • (em_comnd_ump_mor_cell g γ p₁ p₂ ▹ h) = em_comnd_ump_mor_cell g γ p₁ p₂ • (em_comnd_ump_mor g γ p₁ p₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ := em_comnd_cone_mor_endo (pr1 He (make_em_comnd_cone g γ p₁ p₂)). Definition em_comnd_ump_mor_cell_is_invertible {a : B} (g : a --> z) (γ : g ==> g · h) (p₁ : γ • (g ◃ ε) = rinvunitor g) (p₂ : (γ • (γ ▹ h)) • rassociator g h h = γ • (g ◃ ν)) : is_invertible_2cell (em_comnd_ump_mor_cell g γ p₁ p₂) := cell_of_em_comnd_cone_mor_is_invertible (pr1 He (make_em_comnd_cone g γ p₁ p₂)). Definition em_comnd_ump_mor_inv2cell {a : B} (g : a --> z) (γ : g ==> g · h) (p₁ : γ • (g ◃ ε) = rinvunitor g) (p₂ : (γ • (γ ▹ h)) • rassociator g h h = γ • (g ◃ ν)) : invertible_2cell g (em_comnd_ump_mor g γ p₁ p₂ · mor_of_em_comnd_cone e). Proof. use make_invertible_2cell. - exact (em_comnd_ump_mor_cell g γ p₁ p₂). - exact (em_comnd_ump_mor_cell_is_invertible g γ p₁ p₂). Defined. Definition em_comnd_ump_cell {x : B} {g₁ g₂ : x --> e} (α : g₁ · mor_of_em_comnd_cone e ==> g₂ · mor_of_em_comnd_cone e) (p : α • (g₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (g₁ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ h)) : g₁ ==> g₂ := pr11 (pr2 He x g₁ g₂ α p). Definition em_comnd_ump_cell_eq {x : B} {g₁ g₂ : x --> e} (α : g₁ · mor_of_em_comnd_cone e ==> g₂ · mor_of_em_comnd_cone e) (p : α • (g₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (g₁ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ h)) : em_comnd_ump_cell α p ▹ _ = α := pr21 (pr2 He x g₁ g₂ α p). Definition em_comnd_ump_eq {x : B} {g₁ g₂ : x --> e} (α : g₁ · mor_of_em_comnd_cone e ==> g₂ · mor_of_em_comnd_cone e) (p : α • (g₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (g₁ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ h)) {β₁ β₂ : g₁ ==> g₂} (q₁ : β₁ ▹ _ = α) (q₂ : β₂ ▹ _ = α) : β₁ = β₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr2 He x g₁ g₂ α p)) (β₁ ,, q₁) (β₂ ,, q₂))). Qed. Section Invertible. Context {x : B} {g₁ g₂ : x --> e} (α : invertible_2cell (g₁ · mor_of_em_comnd_cone e) (g₂ · mor_of_em_comnd_cone e)) (p : α • (g₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (g₁ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ h)). Definition em_comnd_ump_cell_inv : g₂ ==> g₁. Proof. refine (em_comnd_ump_cell (α^-1) _). abstract (use vcomp_move_L_Mp ; [ is_iso | ] ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; exact (!p)). Defined. Definition em_comnd_ump_cell_inv_left : em_comnd_ump_cell α p • em_comnd_ump_cell_inv = id₂ _. Proof. use em_comnd_ump_eq. - exact (id2 _). - rewrite id2_left. rewrite id2_rwhisker, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold em_comnd_ump_cell_inv. rewrite !em_comnd_ump_cell_eq. apply vcomp_rinv. - apply id2_rwhisker. Qed. Definition em_comnd_ump_cell_inv_right : em_comnd_ump_cell_inv • em_comnd_ump_cell α p = id₂ _. Proof. use em_comnd_ump_eq. - exact (id2 _). - rewrite id2_left. rewrite id2_rwhisker, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold em_comnd_ump_cell_inv. rewrite !em_comnd_ump_cell_eq. apply vcomp_linv. - apply id2_rwhisker. Qed. Definition em_comnd_ump_cell_is_invertible : is_invertible_2cell (em_comnd_ump_cell α p). Proof. use make_is_invertible_2cell. - exact em_comnd_ump_cell_inv. - exact em_comnd_ump_cell_inv_left. - exact em_comnd_ump_cell_inv_right. Defined. End Invertible. Definition em_comnd_ump_inv2cell {x : B} {g₁ g₂ : x --> e} (α : invertible_2cell (g₁ · mor_of_em_comnd_cone e) (g₂ · mor_of_em_comnd_cone e)) (p : α • (g₂ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ = (g₁ ◃ cell_of_em_comnd_cone e) • lassociator _ _ _ • (α ▹ h)) : invertible_2cell g₁ g₂. Proof. use make_invertible_2cell. - exact (em_comnd_ump_cell α p). - exact (em_comnd_ump_cell_is_invertible α p). Defined. End Projections. (** 2. Being an Eilenberg-Moore object for a comonad is a proposition *) Definition isaprop_has_em_comnd_ump (HB : is_univalent_2_1 B) (e : em_comnd_cone) : isaprop (has_em_comnd_ump e). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. repeat (use impred ; intro). apply isapropiscontr. } use funextsec ; intro. use (path_em_comnd_cone_mor HB). - use (em_comnd_ump_inv2cell φ₁). + exact (comp_of_invertible_2cell (inv_of_invertible_2cell (inv2cell_of_em_comnd_cone_mor (pr1 φ₁ x))) (inv2cell_of_em_comnd_cone_mor (pr1 φ₂ x))). + abstract (cbn ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- (em_comnd_cone_mor_endo (pr1 φ₂ x)) ; rewrite !vassocr ; apply maponpaths_2 ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ; exact (em_comnd_cone_mor_endo (pr1 φ₁ x))). - cbn. rewrite em_comnd_ump_cell_eq. rewrite !vassocr. rewrite vcomp_rinv. apply id2_left. Qed. End EilenbergMooreComonad. (** 3. Bicategories with Eilenberg-Moore objects for comonads *) Definition has_em_comnd (B : bicat) : UU := ∏ (m : mnd (op2_bicat B)), ∑ (e : em_comnd_cone m), has_em_comnd_ump m e. UniMath-20231010/UniMath/Bicategories/Limits/EilenbergMooreObjects.v000066400000000000000000001451761451125700300251320ustar00rootroot00000000000000(*********************************************************************************** Eilenberg-Moore objects In this file, we study Eilenberg-Moore objects internal to arbitrary bicategories. This generalizes Eilenberg-Moore categories to arbitrary bicategories. We present three equivalent definitions. The first one expresses Eilenberg-Moore objects using universal properties. The second definition coincides with universal arrows, and it is remniscent of the work by Street (Formal Theory of Monads) where Eilenberg-Moore objects are defined as a right adjoint of the inclusion pseudofunctor of `B` into `mnd B`. The third definition is another reformulation where Eilenberg-Moore categories are used. Contents 1. Definition via universal properties 1.1 Cones and morphisms of cones 1.2 The mapping properties 1.3 It is a proposition 2. Definition similar to universal arrows 2.1 The functor 2.2 The definition 2.3 It is a proposition 3. Equivalence of the first two definitions 4. Definition via Eilenberg-Moore category 4.1 The functor 4.2 The definition 4.3 It is a proposition 5. Equivalence to the other two definitions 6. Bicategories with Eilenberg-Moore objects ***********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Monads.Examples.ToMonadInCat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. Definition idtoiso_mnd_incl {B : bicat} {a b : B} {f g : a --> b} (p : f = g) (m : mnd B) (h : mnd_incl B b --> m) : pr1 (idtoiso_2_1 _ _ (maponpaths (λ z, # (mnd_incl B) z · h) p)) = ## (mnd_incl B) (idtoiso_2_1 _ _ p) ▹ h. Proof. induction p. refine (!_). etrans. { apply maponpaths. apply psfunctor_id2. } apply id2_rwhisker. Qed. Section EMObject. Context {B : bicat} (m : mnd B). (** 1. Definition via universal properties *) (** 1.1 Cones and morphisms of cones *) Definition em_cone : UU := ∑ (x : B), mnd_incl B x --> m. Section MakeCone. Context (x : B) (f : x --> ob_of_mnd m) (fm : f · endo_of_mnd m ==> id₁ x · f) (fη : linvunitor f = rinvunitor f • (f ◃ unit_of_mnd m) • fm) (fμ : lassociator _ _ _ • (fm ▹ endo_of_mnd m) • (lunitor f ▹ endo_of_mnd m) • fm = (f ◃ mult_of_mnd m) • fm). Definition make_em_cone_mnd_mor_data : mnd_mor_data (mnd_incl B x) m. Proof. use make_mnd_mor_data. - exact f. - exact fm. Defined. Definition make_em_cone_mnd_mor_laws : mnd_mor_laws make_em_cone_mnd_mor_data. Proof. split. - cbn. rewrite id2_rwhisker. rewrite id2_right. exact fη. - cbn. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. exact fμ. Qed. Definition make_em_cone : em_cone. Proof. refine (x ,, _). use make_mnd_mor. - exact make_em_cone_mnd_mor_data. - exact make_em_cone_mnd_mor_laws. Defined. End MakeCone. Coercion em_cone_to_ob (e : em_cone) : B := pr1 e. Definition mor_of_em_cone (e : em_cone) : mnd_incl B e --> m := pr2 e. Definition em_cone_mor (e₁ e₂ : em_cone) : UU := ∑ (g : e₁ --> e₂), invertible_2cell (# (mnd_incl B) g · mor_of_em_cone e₂) (mor_of_em_cone e₁). Definition make_em_cone_mor {e₁ e₂ : em_cone} (g : e₁ --> e₂) (α : invertible_2cell (# (mnd_incl B) g · mor_of_em_cone e₂) (mor_of_em_cone e₁)) : em_cone_mor e₁ e₂ := g ,, α. Coercion mor_of_em_cone_mor {e₁ e₂ : em_cone} (f : em_cone_mor e₁ e₂) : e₁ --> e₂ := pr1 f. Definition cell_of_em_cone_mor {e₁ e₂ : em_cone} (f : em_cone_mor e₁ e₂) : invertible_2cell (# (mnd_incl B) f · mor_of_em_cone e₂) (mor_of_em_cone e₁) := pr2 f. Definition path_em_cone_mor (HB : is_univalent_2_1 B) {e₁ e₂ : em_cone} {f₁ f₂ : em_cone_mor e₁ e₂} (α : invertible_2cell f₁ f₂) (p : (## (mnd_incl B) α ▹ mor_of_em_cone e₂) • pr12 f₂ = pr12 f₁) : f₁ = f₂. Proof. use total2_paths_f. - exact (isotoid_2_1 HB α). - use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } etrans. { apply (@pr1_transportf (e₁ --> e₂) (λ x, # (mnd_incl B) x · mor_of_em_cone e₂ ==> mor_of_em_cone e₁)). } rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function. use vcomp_move_R_pM ; [ is_iso | ]. refine (id2_right _ @ _). refine (!_). etrans. { apply maponpaths_2. exact (idtoiso_mnd_incl (isotoid_2_1 HB α) m (mor_of_em_cone e₂)). } rewrite idtoiso_2_1_isotoid_2_1. exact p. Qed. (** 1.2 The mapping properties *) Definition em_ump_1 (e : em_cone) : UU := ∏ (q : em_cone), em_cone_mor q e. Definition em_ump_2 (e : em_cone) : UU := ∏ (x : B) (g₁ g₂ : x --> e) (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e), ∃! (β : g₁ ==> g₂), ## (mnd_incl B) β ▹ _ = α. Definition has_em_ump (e : em_cone) : UU := em_ump_1 e × em_ump_2 e. Section MappingProperties. Context {e : em_cone} (He : has_em_ump e). Definition em_ump_1_mor (q : em_cone) : q --> e := pr1 He q. Definition em_ump_1_inv2cell (q : em_cone) : invertible_2cell (# (mnd_incl B) (em_ump_1_mor q) · mor_of_em_cone e) (mor_of_em_cone q) := cell_of_em_cone_mor (pr1 He q). Definition em_ump_2_cell {x : B} {g₁ g₂ : x --> e} (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e) : g₁ ==> g₂ := pr11 (pr2 He x g₁ g₂ α). Definition em_ump_2_eq {x : B} {g₁ g₂ : x --> e} (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e) : ## (mnd_incl B) (em_ump_2_cell α) ▹ _ = α := pr21 (pr2 He x g₁ g₂ α). Definition em_ump_eq {x : B} {g₁ g₂ : x --> e} (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e) (β₁ β₂ : g₁ ==> g₂) (Hβ₁ : ## (mnd_incl B) β₁ ▹ _ = α) (Hβ₂ : ## (mnd_incl B) β₂ ▹ _ = α) : β₁ = β₂. Proof. exact (maponpaths pr1 (pr1 (isapropifcontr (pr2 He x g₁ g₂ α) (β₁ ,, Hβ₁) (β₂ ,, Hβ₂)))). Qed. Definition em_ump_2_cell_is_invertible {x : B} {g₁ g₂ : x --> e} (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e) (Hα : is_invertible_2cell α) : is_invertible_2cell (em_ump_2_cell α). Proof. use make_is_invertible_2cell. - exact (em_ump_2_cell (Hα^-1)). - use (em_ump_eq (id2 _)). + abstract (rewrite psfunctor_vcomp ; rewrite <- rwhisker_vcomp ; rewrite !em_ump_2_eq ; apply vcomp_rinv). + abstract (rewrite psfunctor_id2 ; apply id2_rwhisker). - use (em_ump_eq (id2 _)). + abstract (rewrite psfunctor_vcomp ; rewrite <- rwhisker_vcomp ; rewrite !em_ump_2_eq ; apply vcomp_linv). + abstract (rewrite psfunctor_id2 ; apply id2_rwhisker). Defined. Definition em_ump_2_inv2cell {x : B} {g₁ g₂ : x --> e} (α : invertible_2cell (# (mnd_incl B) g₁ · mor_of_em_cone e) (# (mnd_incl B) g₂ · mor_of_em_cone e)) : invertible_2cell g₁ g₂. Proof. use make_invertible_2cell. - exact (em_ump_2_cell α). - exact (em_ump_2_cell_is_invertible _ (pr2 α)). Defined. End MappingProperties. (** 1.3 It is a proposition *) Definition isaprop_has_em_ump (HB : is_univalent_2_1 B) (e : em_cone) : isaprop (has_em_ump e). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. do 4 (use impred ; intro). apply isapropiscontr. } use funextsec. intro q. use (path_em_cone_mor HB). - use (em_ump_2_inv2cell φ₁). exact (comp_of_invertible_2cell (cell_of_em_cone_mor (pr1 φ₁ q)) (inv_of_invertible_2cell (cell_of_em_cone_mor (pr1 φ₂ q)))). - etrans. { apply maponpaths_2. apply em_ump_2_eq. } refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. apply (vcomp_linv (pr2 (pr1 φ₂ q))). } apply id2_right. Qed. (** 2. Definition similar to universal arrows *) (** 2.1 The functor *) Section EilenbergMooreFunctor. Context (e : em_cone) (x : B). Definition em_hom_functor_ob_data (f : x --> e) : mnd_mor_data (mnd_incl B x) m. Proof. use make_mnd_mor_data. - exact (f · mor_of_mnd_mor (mor_of_em_cone e)). - exact (rassociator _ _ _ • (_ ◃ mnd_mor_endo (mor_of_em_cone e)) • (_ ◃ lunitor _) • linvunitor _). Defined. Definition em_hom_functor_ob_laws (f : x --> e) : mnd_mor_laws (em_hom_functor_ob_data f). Proof. split. - cbn. rewrite id2_rwhisker, id2_right. rewrite !vassocl. pose (mnd_mor_unit (mor_of_em_cone e)) as p. cbn in p. rewrite id2_rwhisker, id2_right in p. rewrite <- rinvunitor_triangle. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite <- p. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply id2_left. - cbn. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. etrans. { rewrite <- lunitor_triangle. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite linvunitor_lunitor. rewrite id2_right. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite inverse_pentagon_7. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite !lwhisker_vcomp. apply maponpaths. refine (_ @ mnd_mor_mu (mor_of_em_cone e)) ; cbn. rewrite !vassocl. do 2 apply maponpaths. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. Qed. Definition em_hom_functor_ob (f : x --> e) : mnd_incl B x --> m. Proof. use make_mnd_mor. - exact (em_hom_functor_ob_data f). - exact (em_hom_functor_ob_laws f). Defined. Definition em_hom_functor_mor_data {f g : x --> e} (α : f ==> g) : mnd_cell_data (em_hom_functor_ob f) (em_hom_functor_ob g) := α ▹ _. Definition em_hom_functor_mor_is_mnd_cell {f g : x --> e} (α : f ==> g) : is_mnd_cell (em_hom_functor_mor_data α). Proof. unfold is_mnd_cell ; cbn. unfold em_hom_functor_mor_data. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_whisker. apply idpath. Qed. Definition em_hom_functor_mor {f g : x --> e} (α : f ==> g) : em_hom_functor_ob f ==> em_hom_functor_ob g. Proof. use make_mnd_cell. - exact (em_hom_functor_mor_data α). - exact (em_hom_functor_mor_is_mnd_cell α). Defined. Definition em_hom_functor_data : functor_data (hom x e) (hom (mnd_incl B x) m). Proof. use make_functor_data. - exact em_hom_functor_ob. - exact (λ _ _ α, em_hom_functor_mor α). Defined. Definition em_hom_functor_is_functor : is_functor em_hom_functor_data. Proof. split. - intros f. use eq_mnd_cell ; cbn. unfold em_hom_functor_mor_data. apply id2_rwhisker. - intros f g h α β. use eq_mnd_cell ; cbn. unfold em_hom_functor_mor_data ; cbn. rewrite rwhisker_vcomp. apply idpath. Qed. End EilenbergMooreFunctor. Definition em_hom_functor (e : em_cone) (x : B) : hom x e ⟶ hom (mnd_incl B x) m. Proof. use make_functor. - exact (em_hom_functor_data e x). - exact (em_hom_functor_is_functor e x). Defined. (** 2.2 The definition *) Definition is_universal_em_cone (e : em_cone) : UU := ∏ (x : B), adj_equivalence_of_cats (em_hom_functor e x). (** 2.3 It is a proposition *) Definition isaprop_is_universal_em_cone (HB_2_1 : is_univalent_2_1 B) (e : em_cone) : isaprop (is_universal_em_cone e). Proof. use impred ; intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 x e) (univ_hom (is_univalent_2_1_mnd _ HB_2_1) (mnd_incl B x) m) (em_hom_functor e x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 x e) _ _). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. (** 3. Equivalence of the two definitions *) Section UMPIsUniversal. Context {e : em_cone} (He : has_em_ump e) (x : B). Definition has_em_ump_right_adjoint_data : functor_data (hom (mnd_incl B x) m) (hom x e). Proof. use make_functor_data. - exact (λ f, em_ump_1_mor He (x ,, f)). - exact (λ f g α, em_ump_2_cell He (em_ump_1_inv2cell He (x ,, f) • α • (em_ump_1_inv2cell He (x ,, g))^-1)). Defined. Definition has_em_ump_right_adjoint_is_functor : is_functor has_em_ump_right_adjoint_data. Proof. split. - intros f. use (em_ump_eq He). + apply id2. + etrans. { apply em_ump_2_eq. } etrans. { apply maponpaths_2. apply id2_right. } apply vcomp_rinv. + refine (_ @ id2_rwhisker _ _). apply maponpaths. apply psfunctor_id2. - intros f g h α β. use (em_ump_eq He). + exact (em_ump_1_inv2cell He (x ,, f) • α • β • (em_ump_1_inv2cell He (x ,, h))^-1). + etrans. { apply em_ump_2_eq. } rewrite !vassocl. apply maponpaths. refine (vassocl _ _ _ @ _). apply idpath. + etrans. { apply maponpaths. apply psfunctor_vcomp. } rewrite <- rwhisker_vcomp. etrans. { apply maponpaths. apply em_ump_2_eq. } etrans. { apply maponpaths_2. apply em_ump_2_eq. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. Definition has_em_ump_right_adjoint : hom (mnd_incl B x) m ⟶ hom x e. Proof. use make_functor. - exact has_em_ump_right_adjoint_data. - exact has_em_ump_right_adjoint_is_functor. Defined. Definition unit_help_data (f : x --> e) : mnd_cell_data (# (mnd_incl B) (functor_identity (hom x e) f) · mor_of_em_cone e) (mor_of_em_cone (x,, em_hom_functor_ob e x f)) := id2 _. Definition unit_help_is_mnd_cell (f : x --> e) : is_mnd_cell (unit_help_data f). Proof. red ; unfold unit_help_data. cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite !vassocl. do 2 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite linvunitor_assoc. apply idpath. Qed. Definition unit_help (f : x --> e) : # (mnd_incl B) f · mor_of_em_cone e ==> mor_of_em_cone (x,, em_hom_functor_ob e x f). Proof. use make_mnd_cell. - exact (unit_help_data f). - exact (unit_help_is_mnd_cell f). Defined. Definition has_em_ump_unit_data : nat_trans_data (functor_identity (hom x e)) (em_hom_functor e x ∙ has_em_ump_right_adjoint) := λ f, em_ump_2_cell He (unit_help f • (em_ump_1_inv2cell He (x,, em_hom_functor_ob e x f))^-1). Definition has_em_ump_unit_is_nat_trans : is_nat_trans _ _ has_em_ump_unit_data. Proof. intros f₁ f₂ α. use (em_ump_eq He). - refine (unit_help f₁ • _ • (em_ump_1_inv2cell He (x,, em_hom_functor_ob e x f₂))^-1). use make_mnd_cell. + exact (α ▹ _). + abstract (red ; cbn ; rewrite !vassocl ; etrans ; [ do 3 apply maponpaths ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; apply idpath | ] ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; rewrite <- vcomp_whisker ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). - use eq_mnd_cell. refine (_ @ maponpaths (λ z, z • _) (!(id2_left _))). refine (!(rwhisker_vcomp _ _ _) @ _). apply maponpaths. etrans. { exact (maponpaths pr1 (em_ump_2_eq He _)). } apply id2_left. - use eq_mnd_cell. refine (_ @ maponpaths (λ z, z • _) (!(id2_left _))). refine (!(rwhisker_vcomp _ _ _) @ _). etrans. { apply maponpaths_2. exact (maponpaths pr1 (em_ump_2_eq He _)). } etrans. { apply maponpaths. exact (maponpaths pr1 (em_ump_2_eq He _)). } refine (vassocl _ _ _ @ _). refine (id2_left _ @ _). refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. exact (maponpaths pr1 (vcomp_linv (em_ump_1_inv2cell He (x,, em_hom_functor e x f₁)))). } apply id2_left. } apply idpath. Qed. Definition has_em_ump_unit : functor_identity _ ⟹ em_hom_functor e x ∙ has_em_ump_right_adjoint. Proof. use make_nat_trans. - exact has_em_ump_unit_data. - exact has_em_ump_unit_is_nat_trans. Defined. Definition counit_help_data (f : hom (mnd_incl B x) m) : mnd_cell_data (em_hom_functor e x (em_ump_1_mor He (x,, f))) (# (mnd_incl B) (em_ump_1_mor He (x,, f)) · mor_of_em_cone e) := id2 _. Definition counit_help_is_mnd_cell (f : hom (mnd_incl B x) m) : is_mnd_cell (counit_help_data f). Proof. unfold is_mnd_cell. unfold counit_help_data. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. do 2 refine (vassocl _ _ _ @ _). do 3 refine (_ @ vassocr _ _ _). do 2 apply maponpaths. refine (!_). etrans. { etrans. { apply maponpaths. apply maponpaths_2. exact (!(rwhisker_vcomp _ _ _)). } refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply runitor_rwhisker. } apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. rewrite linvunitor_assoc. apply idpath. Qed. Definition counit_help (f : hom (mnd_incl B x) m) : em_hom_functor e x (em_ump_1_mor He (x ,, f)) ==> # (mnd_incl B) (em_ump_1_mor He (x,, f)) · mor_of_em_cone e. Proof. use make_mnd_cell. - exact (counit_help_data f). - exact (counit_help_is_mnd_cell f). Defined. Definition has_em_ump_counit_data : nat_trans_data (has_em_ump_right_adjoint ∙ em_hom_functor e x) (functor_identity _) := λ f, counit_help f • em_ump_1_inv2cell He (x,, f). Definition has_em_ump_counit_is_nat_trans : is_nat_trans _ _ has_em_ump_counit_data. Proof. intros f₁ f₂ α. use eq_mnd_cell. etrans. { refine (maponpaths (λ z, _ • z) _). apply id2_left. } refine (_ @ maponpaths (λ z, z • _) (!(id2_left _))). etrans. { apply maponpaths_2. exact (maponpaths pr1 (em_ump_2_eq He _)). } do 2 refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. exact (maponpaths pr1 (vcomp_linv (em_ump_1_inv2cell He (x ,, _)))). } apply id2_right. } apply idpath. Qed. Definition has_em_ump_counit : has_em_ump_right_adjoint ∙ em_hom_functor e x ⟹ functor_identity _. Proof. use make_nat_trans. - exact has_em_ump_counit_data. - exact has_em_ump_counit_is_nat_trans. Defined. Definition has_em_ump_adjunction_data : adjunction_data (hom x e) (hom (mnd_incl B x) m). Proof. use make_adjunction_data. - exact (em_hom_functor e x). - exact has_em_ump_right_adjoint. - exact has_em_ump_unit. - exact has_em_ump_counit. Defined. Definition has_em_ump_forms_equivalence : forms_equivalence has_em_ump_adjunction_data. Proof. split. - intro f. use is_inv2cell_to_is_z_iso. apply em_ump_2_cell_is_invertible. apply is_invertible_mnd_2cell. simpl. unfold unit_help_data. is_iso. exact (from_invertible_mnd_2cell (inv_of_invertible_2cell (em_ump_1_inv2cell He (x,, em_hom_functor_ob e x f)))). - intro f. use is_inv2cell_to_is_z_iso. apply is_invertible_mnd_2cell. simpl. unfold counit_help_data. is_iso. exact (from_invertible_mnd_2cell (em_ump_1_inv2cell He (x,, f))). Defined. Definition has_em_ump_equivalence_of_cats : equivalence_of_cats (hom x e) (hom (mnd_incl B x) m). Proof. use make_equivalence_of_cats. - exact has_em_ump_adjunction_data. - exact has_em_ump_forms_equivalence. Defined. Definition has_em_ump_adj_equivalence_of_cats : adj_equivalence_of_cats (em_hom_functor e x) := adjointification has_em_ump_equivalence_of_cats. End UMPIsUniversal. Definition has_em_ump_is_universal {e : em_cone} (He : has_em_ump e) : is_universal_em_cone e. Proof. intro x. exact (has_em_ump_adj_equivalence_of_cats He x). Defined. Section IsUniversalHasUMP. Context {e : em_cone} (He : is_universal_em_cone e). Definition is_universal_has_em_ump_1_help_cell_data (q : em_cone) : mnd_cell_data (# (mnd_incl B) (right_adjoint (He q) (mor_of_em_cone q)) · mor_of_em_cone e) (em_hom_functor_ob e q (right_adjoint (He q) (mor_of_em_cone q))) := id2 _. Definition is_universal_has_em_ump_1_help_cell_is_mnd_cell (q : em_cone) : is_mnd_cell (is_universal_has_em_ump_1_help_cell_data q). Proof. unfold is_mnd_cell, is_universal_has_em_ump_1_help_cell_data. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. cbn. do 3 refine (vassocl _ _ _ @ _). do 2 refine (_ @ vassocr _ _ _). do 2 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. apply maponpaths. refine (!_). apply linvunitor_assoc. Qed. Definition is_universal_has_em_ump_1_help_cell (q : em_cone) : # (mnd_incl B) (right_adjoint (He q) (mor_of_em_cone q)) · mor_of_em_cone e ==> em_hom_functor_ob e q (right_adjoint (He q) (mor_of_em_cone q)). Proof. use make_mnd_cell. - exact (is_universal_has_em_ump_1_help_cell_data q). - exact (is_universal_has_em_ump_1_help_cell_is_mnd_cell q). Defined. Definition is_universal_has_em_ump_1 : em_ump_1 e. Proof. intro q. use make_em_cone_mor. - exact (right_adjoint (He q) (mor_of_em_cone q)). - pose (z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (He q)) (mor_of_em_cone q))). refine (comp_of_invertible_2cell _ i). use make_invertible_2cell. + exact (is_universal_has_em_ump_1_help_cell q). + apply is_invertible_mnd_2cell. cbn. unfold is_universal_has_em_ump_1_help_cell_data. is_iso. Defined. Section UMP2. Context {x : B} {g₁ g₂ : x --> e} (α : # (mnd_incl B) g₁ · mor_of_em_cone e ==> # (mnd_incl B) g₂ · mor_of_em_cone e). Let H : fully_faithful (em_hom_functor e x) := fully_faithful_from_equivalence _ _ _ (He x). Definition is_universal_has_em_ump_2_unique : isaprop (∑ (β : g₁ ==> g₂), ## (mnd_incl B) β ▹ mor_of_em_cone e = α). Proof. use invproofirrelevance. intros β₁ β₂. use subtypePath. { intro. apply cellset_property. } use (invmaponpathsweq (make_weq _ (H g₁ g₂))). use eq_mnd_cell. exact (maponpaths pr1 (pr2 β₁ @ !(pr2 β₂))). Qed. Definition is_universal_has_em_ump_2_cell_mnd_cell_data : mnd_cell_data (em_hom_functor e x g₁) (em_hom_functor e x g₂) := pr1 α. Definition is_universal_has_em_ump_2_cell_mnd_cell_is_mnd_cell : is_mnd_cell is_universal_has_em_ump_2_cell_mnd_cell_data. Proof. unfold is_mnd_cell, is_universal_has_em_ump_2_cell_mnd_cell_data. cbn. pose (mnd_cell_endo α) as p. cbn in p. refine (_ @ p @ _). - apply maponpaths_2. do 2 refine (vassocl _ _ _ @ _). do 3 refine (_ @ vassocr _ _ _). do 2 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. rewrite linvunitor_assoc. apply idpath. - apply maponpaths. do 3 refine (vassocl _ _ _ @ _). do 2 refine (_ @ vassocr _ _ _). do 2 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. rewrite linvunitor_assoc. apply idpath. Qed. Definition is_universal_has_em_ump_2_cell_mnd_cell : em_hom_functor e x g₁ --> em_hom_functor e x g₂. Proof. use make_mnd_cell. - exact is_universal_has_em_ump_2_cell_mnd_cell_data. - exact is_universal_has_em_ump_2_cell_mnd_cell_is_mnd_cell. Defined. Definition is_universal_has_em_ump_2_cell : g₁ ==> g₂ := invmap (make_weq _ (H g₁ g₂)) is_universal_has_em_ump_2_cell_mnd_cell. Definition is_universal_has_em_ump_2_eq : ## (mnd_incl B) is_universal_has_em_ump_2_cell ▹ mor_of_em_cone e = α. Proof. use eq_mnd_cell. exact (maponpaths pr1 (homotweqinvweq (make_weq _ (H g₁ g₂)) is_universal_has_em_ump_2_cell_mnd_cell)). Qed. End UMP2. Definition is_universal_has_em_ump_2 : em_ump_2 e. Proof. intros x g₁ g₂ α. use iscontraprop1. - exact (is_universal_has_em_ump_2_unique α). - refine (is_universal_has_em_ump_2_cell α ,, _). exact (is_universal_has_em_ump_2_eq α). Defined. Definition is_universal_has_em_ump : has_em_ump e. Proof. split. - exact is_universal_has_em_ump_1. - exact is_universal_has_em_ump_2. Defined. End IsUniversalHasUMP. Definition has_em_ump_weq_is_universal_em_cone (HB_2_1 : is_univalent_2_1 B) (e : em_cone) : has_em_ump e ≃ is_universal_em_cone e. Proof. use weqimplimpl. - exact has_em_ump_is_universal. - exact is_universal_has_em_ump. - apply isaprop_has_em_ump. exact HB_2_1. - apply isaprop_is_universal_em_cone. exact HB_2_1. Defined. (* 4. Definition via Eilenberg-Moore category *) (** 4.1 The functor *) Definition is_em_universal_em_cone_functor_ob {e : em_cone} {x : B} (f : x --> e) : eilenberg_moore_cat (mnd_to_cat_Monad m x). Proof. use make_ob_eilenberg_moore. - exact (f · mor_of_mnd_mor (mor_of_em_cone e)). - exact (rassociator _ _ _ • (_ ◃ (mnd_mor_endo (mor_of_em_cone e) • lunitor _))). - abstract (cbn ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lwhisker_lwhisker_rassociator ; rewrite !vassocr ; rewrite <- rinvunitor_triangle ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite !lwhisker_vcomp ; rewrite !vassocr ; refine (_ @ lwhisker_id2 _ _) ; apply maponpaths ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; pose (mnd_mor_unit (mor_of_em_cone e)) as p ; cbn in p ; rewrite id2_rwhisker, id2_right in p ; exact (!p)). - abstract (cbn ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- lwhisker_lwhisker_rassociator ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite !vassocr ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_2 ; exact (!(mnd_mor_mu (mor_of_em_cone e))) | ] ; cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- rassociator_rassociator ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lwhisker_vcomp ; rewrite rassociator_lassociator ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocr ; rewrite rwhisker_lwhisker_rassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !lwhisker_vcomp ; rewrite lunitor_triangle ; rewrite vcomp_lunitor ; rewrite !vassocr ; rewrite <- lunitor_triangle ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite rwhisker_lwhisker_rassociator ; apply idpath). Defined. Definition is_em_universal_em_cone_functor_mor {e : em_cone} {x : B} {f g : x --> e} (α : f ==> g) : is_em_universal_em_cone_functor_ob f --> is_em_universal_em_cone_functor_ob g. Proof. use make_mor_eilenberg_moore. - exact (α ▹ _). - abstract (cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). Defined. Definition is_em_universal_em_cone_functor_data (e : em_cone) (x : B) : functor_data (hom x e) (eilenberg_moore_cat (mnd_to_cat_Monad m x)). Proof. use make_functor_data. - exact is_em_universal_em_cone_functor_ob. - exact (λ _ _ α, is_em_universal_em_cone_functor_mor α). Defined. Definition is_em_universal_em_cone_functor_is_functor (e : em_cone) (x : B) : is_functor (is_em_universal_em_cone_functor_data e x). Proof. split. - intros f. use eq_mor_eilenberg_moore ; cbn. rewrite id2_rwhisker. apply idpath. - intros f g h α β. use eq_mor_eilenberg_moore ; cbn. rewrite rwhisker_vcomp. apply idpath. Qed. Definition is_em_universal_em_cone_functor (e : em_cone) (x : B) : hom x e ⟶ eilenberg_moore_cat (mnd_to_cat_Monad m x). Proof. use make_functor. - exact (is_em_universal_em_cone_functor_data e x). - exact (is_em_universal_em_cone_functor_is_functor e x). Defined. (** 4.2 The definition *) Definition is_em_universal_em_cone (e : em_cone) : UU := ∏ (x : B), adj_equivalence_of_cats (is_em_universal_em_cone_functor e x). (** 4.3 It is a proposition *) Definition isaprop_is_em_universal_em_cone (HB_2_1 : is_univalent_2_1 B) (e : em_cone) : isaprop (is_em_universal_em_cone e). Proof. use impred ; intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 x e) (eilenberg_moore_univalent_cat (univ_hom HB_2_1 _ _) (mnd_to_cat_Monad m x)) (is_em_universal_em_cone_functor e x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 x e) _ _). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. (** 5. Equivalence to the other two definitions *) Section EilenbergMooreEquivalence. Context (x : B). Definition eilenberg_moore_to_hom_ob_data (h : eilenberg_moore_cat (mnd_to_cat_Monad m x)) : mnd_mor_data (mnd_incl B x) m. Proof. use make_mnd_mor_data. - exact (ob_of_eilenberg_moore_ob h). - exact (mor_of_eilenberg_moore_ob h • linvunitor _). Defined. Definition eilenberg_moore_to_hom_ob_laws (h : eilenberg_moore_cat (mnd_to_cat_Monad m x)) : mnd_mor_laws (eilenberg_moore_to_hom_ob_data h). Proof. repeat split ; cbn. - rewrite id2_rwhisker, id2_right. rewrite !vassocr. refine (!(id2_left _) @ _). apply maponpaths_2. exact (!(eilenberg_moore_ob_unit h)). - rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite linvunitor_lunitor. rewrite id2_right. apply idpath. } pose (eilenberg_moore_ob_mult h) as p. cbn in p. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocl in p. exact (!p). Qed. Definition eilenberg_moore_to_hom_ob (h : eilenberg_moore_cat (mnd_to_cat_Monad m x)) : mnd_incl B x --> m. Proof. use make_mnd_mor. - exact (eilenberg_moore_to_hom_ob_data h). - exact (eilenberg_moore_to_hom_ob_laws h). Defined. Definition eilenberg_moore_to_hom_mor {h₁ h₂ : eilenberg_moore_cat (mnd_to_cat_Monad m x)} (α : h₁ --> h₂) : eilenberg_moore_to_hom_ob h₁ ==> eilenberg_moore_to_hom_ob h₂. Proof. use make_mnd_cell. - exact (mor_of_eilenberg_moore_mor α). - abstract (unfold is_mnd_cell ; cbn ; rewrite !vassocl ; rewrite lwhisker_hcomp ; rewrite <- linvunitor_natural ; rewrite !vassocr ; apply maponpaths_2 ; exact (eq_of_eilenberg_moore_mor α)). Defined. Definition eilenberg_moore_to_hom_data : functor_data (eilenberg_moore_cat (mnd_to_cat_Monad m x)) (hom (mnd_incl B x) m). Proof. use make_functor_data. - exact eilenberg_moore_to_hom_ob. - exact (λ _ _ α, eilenberg_moore_to_hom_mor α). Defined. Definition eilenberg_moore_to_hom_is_functor : is_functor eilenberg_moore_to_hom_data. Proof. split. - intro h. use eq_mnd_cell ; cbn. apply idpath. - intros h₁ h₂ h₃ α β. use eq_mnd_cell ; cbn. apply idpath. Qed. Definition eilenberg_moore_to_hom : eilenberg_moore_cat (mnd_to_cat_Monad m x) ⟶ hom (mnd_incl B x) m. Proof. use make_functor. - exact eilenberg_moore_to_hom_data. - exact eilenberg_moore_to_hom_is_functor. Defined. Definition hom_to_eilenberg_moore_ob (f : mnd_incl B x --> m) : eilenberg_moore_cat (mnd_to_cat_Monad m x). Proof. use make_ob_eilenberg_moore. - exact (mor_of_mnd_mor f). - exact (mnd_mor_endo f • lunitor _). - abstract (cbn ; rewrite !vassocr ; refine (maponpaths (λ z, z • _) (!(mnd_mor_unit f)) @ _) ; cbn ; rewrite id2_rwhisker ; rewrite id2_right ; apply linvunitor_lunitor). - abstract (cbn ; pose (mnd_mor_mu f) as p ; cbn in p ; rewrite !vassocl ; refine (maponpaths (λ z, _ • z) (vassocr _ _ _) @ _) ; refine (maponpaths (λ z, _ • (z • _)) (!p) @ _) ; clear p ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lunitor_triangle ; rewrite <- vcomp_lunitor ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite lunitor_triangle ; apply idpath). Defined. Definition hom_to_eilenberg_moore_mor {f g : mnd_incl B x --> m} (α : f ==> g) : hom_to_eilenberg_moore_ob f --> hom_to_eilenberg_moore_ob g. Proof. use make_mor_eilenberg_moore. - exact (cell_of_mnd_cell α). - abstract (cbn ; rewrite !vassocl ; rewrite <- vcomp_lunitor ; rewrite !vassocr ; apply maponpaths_2 ; exact (mnd_cell_endo α)). Defined. Definition hom_to_eilenberg_moore_data : functor_data (hom (mnd_incl B x) m) (eilenberg_moore_cat (mnd_to_cat_Monad m x)). Proof. use make_functor_data. - exact hom_to_eilenberg_moore_ob. - exact (λ _ _ α, hom_to_eilenberg_moore_mor α). Defined. Definition hom_to_eilenberg_moore_is_functor : is_functor hom_to_eilenberg_moore_data. Proof. split. - intro f. use eq_mor_eilenberg_moore ; cbn. apply idpath. - intros f g h α β. use eq_mor_eilenberg_moore ; cbn. apply idpath. Qed. Definition hom_to_eilenberg_moore : hom (mnd_incl B x) m ⟶ eilenberg_moore_cat (mnd_to_cat_Monad m x). Proof. use make_functor. - exact hom_to_eilenberg_moore_data. - exact hom_to_eilenberg_moore_is_functor. Defined. Definition hom_to_eilenberg_moore_unit_data : nat_trans_data (functor_identity _) (eilenberg_moore_to_hom ∙ hom_to_eilenberg_moore). Proof. intro f. use make_mor_eilenberg_moore. - exact (id2 _). - abstract (cbn ; rewrite id2_rwhisker ; rewrite id2_left, id2_right ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; apply idpath). Defined. Definition hom_to_eilenberg_moore_unit_is_nat_trans : is_nat_trans _ _ hom_to_eilenberg_moore_unit_data. Proof. intros f g α. use eq_mor_eilenberg_moore ; cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition hom_to_eilenberg_moore_unit : functor_identity _ ⟹ eilenberg_moore_to_hom ∙ hom_to_eilenberg_moore. Proof. use make_nat_trans. - exact hom_to_eilenberg_moore_unit_data. - exact hom_to_eilenberg_moore_unit_is_nat_trans. Defined. Definition is_z_iso_hom_to_eilenberg_moore_unit (f : eilenberg_moore_cat (mnd_to_cat_Monad m x)) : is_z_isomorphism (hom_to_eilenberg_moore_unit f). Proof. use is_z_iso_eilenberg_moore. use is_inv2cell_to_is_z_iso. cbn. is_iso. Defined. Definition hom_to_eilenberg_moore_counit_data : nat_trans_data (hom_to_eilenberg_moore ∙ eilenberg_moore_to_hom) (functor_identity _). Proof. intro f. use make_mnd_cell. - exact (id2 _). - abstract (unfold is_mnd_cell ; cbn ; rewrite id2_rwhisker, lwhisker_id2 ; rewrite id2_left, id2_right ; rewrite !vassocl ; rewrite lunitor_linvunitor ; apply id2_right). Defined. Definition hom_to_eilenberg_moore_counit_is_nat_trans : is_nat_trans _ _ hom_to_eilenberg_moore_counit_data. Proof. intros f g α. use eq_mnd_cell ; cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition hom_to_eilenberg_moore_counit : hom_to_eilenberg_moore ∙ eilenberg_moore_to_hom ⟹ functor_identity _. Proof. use make_nat_trans. - exact hom_to_eilenberg_moore_counit_data. - exact hom_to_eilenberg_moore_counit_is_nat_trans. Defined. Definition is_z_iso_hom_to_eilenberg_moore_counit (f : mnd_incl B x --> m) : is_z_isomorphism (hom_to_eilenberg_moore_counit f). Proof. use is_inv2cell_to_is_z_iso. use is_invertible_mnd_2cell. cbn. is_iso. Defined. End EilenbergMooreEquivalence. Definition eilenberg_moore_equiv_mnd_incl (x : B) : equivalence_of_cats (eilenberg_moore_cat (mnd_to_cat_Monad m x)) (hom (mnd_incl B x) m). Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact (eilenberg_moore_to_hom x). + exact (hom_to_eilenberg_moore x). + exact (hom_to_eilenberg_moore_unit x). + exact (hom_to_eilenberg_moore_counit x). - split. + exact (is_z_iso_hom_to_eilenberg_moore_unit x). + exact (is_z_iso_hom_to_eilenberg_moore_counit x). Defined. Definition eilenberg_moore_adj_equiv_mnd_incl (x : B) : adj_equivalence_of_cats (eilenberg_moore_to_hom x) := adjointification (eilenberg_moore_equiv_mnd_incl x). Definition eilenberg_moore_adj_mnd_incl_nat_trans (e : em_cone) (x : B) : is_em_universal_em_cone_functor e x ∙ eilenberg_moore_to_hom x ⟹ em_hom_functor e x. Proof. use make_nat_trans. - intro f. use make_mnd_cell. + apply id2. + abstract (unfold is_mnd_cell ; cbn ; rewrite id2_rwhisker, lwhisker_id2 ; rewrite id2_left, id2_right ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; apply idpath). - abstract (intros f g α ; use eq_mnd_cell ; cbn ; rewrite id2_left, id2_right ; apply idpath). Defined. Definition eilenberg_moore_adj_mnd_incl_nat_z_iso (e : em_cone) (x : B) : nat_z_iso (is_em_universal_em_cone_functor e x ∙ eilenberg_moore_to_hom x) (em_hom_functor e x). Proof. use make_nat_z_iso. - exact (eilenberg_moore_adj_mnd_incl_nat_trans e x). - intro f. use is_inv2cell_to_is_z_iso. use is_invertible_mnd_2cell. cbn. is_iso. Defined. Definition is_universal_em_cone_weq_is_em_universal_em_cone (HB_2_1 : is_univalent_2_1 B) (e : em_cone) : is_universal_em_cone e ≃ is_em_universal_em_cone e. Proof. use weqimplimpl. - intros He x. use (two_out_of_three_first (is_em_universal_em_cone_functor e x) (eilenberg_moore_to_hom x) (em_hom_functor e x) (eilenberg_moore_adj_mnd_incl_nat_z_iso e x)). + apply eilenberg_moore_adj_equiv_mnd_incl. + exact (He x). - intros He x. use (two_out_of_three_comp (is_em_universal_em_cone_functor e x) (eilenberg_moore_to_hom x) (em_hom_functor e x) (eilenberg_moore_adj_mnd_incl_nat_z_iso e x)). + exact (He x). + apply eilenberg_moore_adj_equiv_mnd_incl. - apply isaprop_is_universal_em_cone. exact HB_2_1. - apply isaprop_is_em_universal_em_cone. exact HB_2_1. Defined. End EMObject. (** 6. Bicategories with Eilenberg-Moore objects *) Definition bicat_has_em (B : bicat) : UU := ∏ (m : mnd B), ∑ (e : em_cone m), has_em_ump m e. UniMath-20231010/UniMath/Bicategories/Limits/EquifierEquivalences.v000066400000000000000000000301261451125700300250240ustar00rootroot00000000000000(************************************************************************ Equivalences for equifiers ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Limits.Equifiers. Local Open Scope cat. (** Suppose, we have a diagram as follows ---- f₁ ----> p₁ ---- i₁ ----> x₁ y₁ ---- g₁ ----> | | | | | | l₃ ≃ l₁ ≃ l₂ | | | | | | V V V ---- f₂ ----> p₂ ---- i₂ ----> x₁ y₂ ---- g₂ ----> where the columns are adjoint equivalences and both rows are equifier cones. If the top row is an equifier, then so is the bottom row. *) Section EquifierEquivalence. Context {B : bicat} {p₁ x₁ y₁ p₂ x₂ y₂ : B} {e₁ : p₁ --> x₁} {f₁ g₁ : x₁ --> y₁} {α₁ β₁ : f₁ ==> g₁} {e₂ : p₂ --> x₂} {f₂ g₂ : x₂ --> y₂} {α₂ β₂ : f₂ ==> g₂} (ep₁ : e₁ ◃ α₁ = e₁ ◃ β₁) (ep₂ : e₂ ◃ α₂ = e₂ ◃ β₂) (cone₁ := make_equifier_cone p₁ e₁ ep₁) (cone₂ := make_equifier_cone p₂ e₂ ep₂) (lx : x₁ --> x₂) (ly : y₁ --> y₂) (lp : p₁ --> p₂) (Hlx : left_adjoint_equivalence lx) (Hly : left_adjoint_equivalence ly) (Hlp : left_adjoint_equivalence lp) (γ₁ : invertible_2cell (lp · e₂) (e₁ · lx)) (γ₂ : invertible_2cell (lx · f₂) (f₁ · ly)) (γ₃ : invertible_2cell (lx · g₂) (g₁ · ly)) (H : has_equifier_ump cone₁) (pα : lx ◃ α₂ • γ₃ = γ₂ • (α₁ ▹ _)) (pβ : lx ◃ β₂ • γ₃ = γ₂ • (β₁ ▹ _)). Let rx : x₂ --> x₁ := left_adjoint_right_adjoint Hlx. Let ηx : invertible_2cell (id₁ _) (lx · rx) := left_equivalence_unit_iso Hlx. Let εx : invertible_2cell (rx · lx) (id₁ _) := left_equivalence_counit_iso Hlx. Let ry : y₂ --> y₁ := left_adjoint_right_adjoint Hly. Let ηy : invertible_2cell (id₁ _) (ly · ry) := left_equivalence_unit_iso Hly. Let εy : invertible_2cell (ry · ly) (id₁ _) := left_equivalence_counit_iso Hly. Let rp : p₂ --> p₁ := left_adjoint_right_adjoint Hlp. Let ηp : invertible_2cell (id₁ _) (lp · rp) := left_equivalence_unit_iso Hlp. Let εp : invertible_2cell (rp · lp) (id₁ _) := left_equivalence_counit_iso Hlp. Definition has_equifier_ump_1_left_adjoint_equivalence_path (q : equifier_cone f₂ g₂ α₂ β₂) : equifier_cone_pr1 q · rx ◃ α₁ = equifier_cone_pr1 q · rx ◃ β₁. Proof. use (adj_equiv_faithful Hly). use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- !rwhisker_lwhisker. apply maponpaths_2. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite <- !lwhisker_lwhisker. apply maponpaths_2. use (vcomp_lcancel (_ ◃ (_ ◃ γ₂))). { is_iso. apply property_from_invertible_2cell. } rewrite !lwhisker_vcomp. rewrite <- pα, <- pβ. rewrite <- !lwhisker_vcomp. apply maponpaths_2. use (vcomp_lcancel (_ ◃ rassociator _ _ _)). { is_iso. } rewrite !lwhisker_vcomp. rewrite !lwhisker_lwhisker_rassociator. rewrite <- !lwhisker_vcomp. apply maponpaths_2. use (vcomp_lcancel (_ ◃ (εx^-1 ▹ _))). { is_iso. } rewrite !lwhisker_vcomp. rewrite !vcomp_whisker. rewrite <- !lwhisker_vcomp. apply maponpaths_2. use (vcomp_lcancel (_ ◃ linvunitor _)). { is_iso. } rewrite !lwhisker_vcomp. rewrite !lwhisker_hcomp. rewrite <- !linvunitor_natural. rewrite <- !lwhisker_hcomp. rewrite <- !lwhisker_vcomp. apply maponpaths_2. exact (equifier_cone_eq q). Qed. Definition has_equifier_ump_1_left_adjoint_equivalence_mor (q : equifier_cone f₂ g₂ α₂ β₂) : q --> p₂ := equifier_ump_mor H (equifier_cone_pr1 q · rx) (has_equifier_ump_1_left_adjoint_equivalence_path q) · lp. Definition has_equifier_ump_1_left_adjoint_equivalence_pr1 (q : equifier_cone f₂ g₂ α₂ β₂) : invertible_2cell (has_equifier_ump_1_left_adjoint_equivalence_mor q · equifier_cone_pr1 cone₂) (equifier_cone_pr1 q) := comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ γ₁) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (equifier_ump_mor_pr1 H _ _)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ εx) (runitor_invertible_2cell _)))))). Definition has_equifier_ump_1_left_adjoint_equivalence : has_equifier_ump_1 cone₂. Proof. intro q. use make_equifier_1cell. - exact (has_equifier_ump_1_left_adjoint_equivalence_mor q). - exact (has_equifier_ump_1_left_adjoint_equivalence_pr1 q). Defined. Let γ₁' : invertible_2cell (rp · e₁) (e₂ · rx) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ηx) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₁))) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ εp)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)))))))). Section UMP2. Context {z : B} (u₁ u₂ : z --> p₂) (ξ : u₁ · e₂ ==> u₂ · e₂). Let ξ' : u₁ · rp · e₁ ==> u₂ · rp · e₁ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hlx) (rassociator _ _ _ • (_ ◃ γ₁^-1) • lassociator _ _ _ • (rassociator _ _ _ ▹ _) • ((_ ◃ εp) ▹ _) • (runitor _ ▹ _) • ξ • (rinvunitor _ ▹ _) • ((_ ◃ εp ^-1) ▹ _) • (lassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ γ₁) • lassociator _ _ _). Definition has_equifier_ump_2_left_adjoint_equivalence_cell : u₁ ==> u₂ := rinvunitor _ • (_ ◃ εp^-1) • lassociator _ _ _ • (equifier_ump_cell H ξ' ▹ _) • rassociator _ _ _ • (_ ◃ εp) • runitor _. Definition has_equifier_ump_2_left_adjoint_equivalence_pr1 : has_equifier_ump_2_left_adjoint_equivalence_cell ▹ e₂ = ξ. Proof. unfold has_equifier_ump_2_left_adjoint_equivalence_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn -[εp ξ']. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ γ₁^-1)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. exact (equifier_ump_cell_pr1 H ξ'). } use vcomp_move_R_Mp. { is_iso. apply property_from_invertible_2cell. } cbn -[εp ξ']. rewrite !vassocr. apply fully_faithful_1cell_inv_map_eq. Qed. End UMP2. Definition has_equifier_ump_2_left_adjoint_equivalence : has_equifier_ump_2 cone₂. Proof. intros z u₁ u₂ ξ. simple refine (_ ,, _). - exact (has_equifier_ump_2_left_adjoint_equivalence_cell u₁ u₂ ξ). - exact (has_equifier_ump_2_left_adjoint_equivalence_pr1 u₁ u₂ ξ). Defined. Definition has_equifier_ump_eq_left_adjoint_equivalence : has_equifier_ump_eq cone₂. Proof. intros z u₁ u₂ ξ φ₁ φ₂ q₁ q₂. enough (φ₁ ▹ rp = φ₂ ▹ rp) as H'. { use (adj_equiv_faithful (inv_adjequiv (_ ,, Hlp))). exact H'. } use (equifier_ump_eq H) ; cbn. - simple refine (rassociator _ _ _ • (_ ◃ γ₁') • lassociator _ _ _ • (ξ ▹ _) • rassociator _ _ _ • (_ ◃ (γ₁')^-1) • lassociator _ _ _) ; cbn. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn -[γ₁']. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. { apply property_from_invertible_2cell. } cbn -[γ₁']. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact q₁. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn -[γ₁']. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. { apply property_from_invertible_2cell. } cbn -[γ₁']. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact q₂. Qed. Definition has_equifier_ump_left_adjoint_equivalence : has_equifier_ump cone₂. Proof. refine (_ ,, _ ,, _). - exact has_equifier_ump_1_left_adjoint_equivalence. - exact has_equifier_ump_2_left_adjoint_equivalence. - exact has_equifier_ump_eq_left_adjoint_equivalence. Defined. End EquifierEquivalence. UniMath-20231010/UniMath/Bicategories/Limits/Equifiers.v000066400000000000000000000460041451125700300226440ustar00rootroot00000000000000(**************************************************************************** Equifiers in bicategories Contents 1. Cones 2. The universal mapping property 3. Alternative formulation of equifier via universal cones 4. Bicategories with equifiers 5. Equifiers are fully faithful ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Local Open Scope cat. Section Equifiers. Context {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {α β : f ==> g}. (** 1. Cones *) Definition equifier_cone : UU := ∑ (i : B) (m : i --> b₁), m ◃ α = m ◃ β. Definition make_equifier_cone (i : B) (m : i --> b₁) (α : m ◃ α = m ◃ β) : equifier_cone := i ,, m ,, α. Coercion equifier_cone_ob (cone : equifier_cone) : B := pr1 cone. Definition equifier_cone_pr1 (cone : equifier_cone) : cone --> b₁ := pr12 cone. Definition equifier_cone_eq (cone : equifier_cone) : equifier_cone_pr1 cone ◃ α = equifier_cone_pr1 cone ◃ β := pr22 cone. Definition equifier_1cell (cone₁ cone₂ : equifier_cone) : UU := ∑ (k : cone₁ --> cone₂), invertible_2cell (k · equifier_cone_pr1 cone₂) (equifier_cone_pr1 cone₁). Definition make_equifier_1cell {cone₁ cone₂ : equifier_cone} (k : cone₁ --> cone₂) (α : invertible_2cell (k · equifier_cone_pr1 cone₂) (equifier_cone_pr1 cone₁)) : equifier_1cell cone₁ cone₂ := k ,, α. Coercion equifier_1cell_mor {cone₁ cone₂ : equifier_cone} (u : equifier_1cell cone₁ cone₂) : cone₁ --> cone₂ := pr1 u. Definition equifier_1cell_pr1 {cone₁ cone₂ : equifier_cone} (u : equifier_1cell cone₁ cone₂) : invertible_2cell (u · equifier_cone_pr1 cone₂) (equifier_cone_pr1 cone₁) := pr2 u. Definition path_equifier_1cell {cone₁ cone₂ : equifier_cone} (φ ψ : equifier_1cell cone₁ cone₂) (p₁ : pr1 φ = pr1 ψ) (p₂ : pr12 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr12 ψ) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ φ₃ ]]. induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]]. cbn in *. induction p₁. apply maponpaths. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn in p₂. rewrite id2_rwhisker, id2_left in p₂. exact p₂. Qed. (** 2. The universal mapping property *) Section UniversalMappingProperty. Context (cone : equifier_cone). Definition has_equifier_ump_1 : UU := ∏ (other_cone : equifier_cone), equifier_1cell other_cone cone. Definition has_equifier_ump_2 : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone), ∑ (ζ : u₁ ==> u₂), ζ ▹ equifier_cone_pr1 cone = α. Definition has_equifier_ump_eq : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ equifier_cone_pr1 cone = α) (q₂ : φ₂ ▹ equifier_cone_pr1 cone = α), φ₁ = φ₂. Definition has_equifier_ump : UU := has_equifier_ump_1 × has_equifier_ump_2 × has_equifier_ump_eq. End UniversalMappingProperty. Section Projections. Context {cone : equifier_cone} (H : has_equifier_ump cone). Definition equifier_ump_mor {i : B} (m : i --> b₁) (p : m ◃ α = m ◃ β) : i --> cone := pr1 H (make_equifier_cone i m p). Definition equifier_ump_mor_pr1 {i : B} (m : i --> b₁) (p : m ◃ α = m ◃ β) : invertible_2cell (equifier_ump_mor m p · equifier_cone_pr1 cone) m := equifier_1cell_pr1 (pr1 H (make_equifier_cone i m p)). Definition equifier_ump_cell {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) : u₁ ==> u₂ := pr1 (pr12 H x u₁ u₂ ζ). Definition equifier_ump_cell_pr1 {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) : equifier_ump_cell ζ ▹ equifier_cone_pr1 cone = ζ := pr2 (pr12 H x u₁ u₂ ζ). Definition equifier_ump_eq {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ equifier_cone_pr1 cone = ζ) (q₂ : φ₂ ▹ equifier_cone_pr1 cone = ζ) : φ₁ = φ₂ := pr22 H x u₁ u₂ ζ φ₁ φ₂ q₁ q₂. Definition equifier_ump_eq_alt {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) (φ₁ φ₂ : u₁ ==> u₂) (q : φ₁ ▹ equifier_cone_pr1 cone = φ₂ ▹ equifier_cone_pr1 cone) : φ₁ = φ₂. Proof. use equifier_ump_eq. - exact (φ₁ ▹ equifier_cone_pr1 cone). - apply idpath. - exact (!q). Qed. Definition is_invertible_equifier_ump_cell {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone) (Hζ : is_invertible_2cell ζ) : is_invertible_2cell (equifier_ump_cell ζ). Proof. use make_is_invertible_2cell. - exact (equifier_ump_cell (Hζ^-1)). - abstract (use (equifier_ump_eq_alt (id2 _)) ; rewrite <- !rwhisker_vcomp ; rewrite !equifier_ump_cell_pr1 ; rewrite vcomp_rinv ; rewrite id2_rwhisker ; apply idpath). - abstract (use (equifier_ump_eq_alt (id2 _)) ; rewrite <- !rwhisker_vcomp ; rewrite !equifier_ump_cell_pr1 ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply idpath). Defined. End Projections. (** 3. Alternative formulation of equifier via universal cones *) Definition universal_equifier_cat (x : B) : category. Proof. refine (full_sub_category (hom x b₁) (λ h, make_hProp (h ◃ α = h ◃ β) _)). apply cellset_property. Defined. Definition univalent_universal_equifier_cat (HB_2_1 : is_univalent_2_1 B) (x : B) : univalent_category. Proof. use make_univalent_category. - exact (universal_equifier_cat x). - use is_univalent_full_sub_category. use is_univ_hom. exact HB_2_1. Defined. Definition to_universal_equifier_cat_data (cone : equifier_cone) (x : B) : functor_data (hom x cone) (universal_equifier_cat x). Proof. use make_functor_data. - refine (λ h, h · equifier_cone_pr1 cone ,, _) ; cbn. abstract (use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite <- !lwhisker_lwhisker ; apply maponpaths_2 ; apply maponpaths ; exact (equifier_cone_eq cone)). - exact (λ h₁ h₂ ζ, ζ ▹ _ ,, tt). Defined. Definition to_universal_equifier_cat_is_functor (cone : equifier_cone) (x : B) : is_functor (to_universal_equifier_cat_data cone x). Proof. split. - intro h ; cbn. use subtypePath. { intro. apply isapropunit. } cbn. apply id2_rwhisker. - intros h₁ h₂ h₃ ζ₁ ζ₂ ; cbn. use subtypePath. { intro. apply isapropunit. } cbn. refine (!_). apply rwhisker_vcomp. Qed. Definition to_universal_equifier_cat (cone : equifier_cone) (x : B) : hom x cone ⟶ universal_equifier_cat x. Proof. use make_functor. - exact (to_universal_equifier_cat_data cone x). - exact (to_universal_equifier_cat_is_functor cone x). Defined. Definition is_univeral_equifier_cone (cone : equifier_cone) : UU := ∏ (x : B), adj_equivalence_of_cats (to_universal_equifier_cat cone x). Section MakeUniversalEquifierCone. Context (cone : equifier_cone) (H : has_equifier_ump cone) (x : B). Definition make_is_universal_equifier_cone_full : full (to_universal_equifier_cat cone x). Proof. intros u₁ u₂ ζ. apply hinhpr. simple refine (_ ,, _). - use (equifier_ump_cell H). exact (pr1 ζ). - abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; apply (equifier_ump_cell_pr1 H)). Defined. Definition make_is_universal_equifier_cone_faithful : faithful (to_universal_equifier_cat cone x). Proof. intros u₁ u₂ ζ₁. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (equifier_ump_eq_alt H). - exact (pr1 ζ₁). - exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))). Qed. Definition make_is_universal_equifier_cone_essentially_surjective : essentially_surjective (to_universal_equifier_cat cone x). Proof. intros h. apply hinhpr. simple refine (_ ,, _). - use (equifier_ump_mor H). + exact (pr1 h). + exact (pr2 h). - cbn. use iso_in_sub_from_iso ; cbn. use inv2cell_to_z_iso. apply equifier_ump_mor_pr1. Defined. End MakeUniversalEquifierCone. Definition make_is_universal_equifier_cone (HB_2_1 : is_univalent_2_1 B) (cone : equifier_cone) (H : has_equifier_ump cone) : is_univeral_equifier_cone cone. Proof. intro x. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + apply make_is_universal_equifier_cone_full. exact H. + apply make_is_universal_equifier_cone_faithful. exact H. - apply make_is_universal_equifier_cone_essentially_surjective. exact H. Defined. Section UniversalConeHasUMP. Context (cone : equifier_cone) (H : is_univeral_equifier_cone cone). Section UMP1. Context (q : equifier_cone). Let q' : universal_equifier_cat q := equifier_cone_pr1 q ,, equifier_cone_eq q. Definition universal_equifier_cone_has_ump_1_mor : q --> cone := right_adjoint (H q) q'. Definition universal_equifier_cone_has_ump_1_pr1 : invertible_2cell (universal_equifier_cone_has_ump_1_mor · equifier_cone_pr1 cone) (equifier_cone_pr1 q). Proof. use z_iso_to_inv2cell. exact (iso_from_iso_in_sub _ _ _ _ (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (H q)) q')). Defined. End UMP1. Definition universal_equifier_cone_has_ump_1 : has_equifier_ump_1 cone. Proof. intro q. use make_equifier_1cell. - exact (universal_equifier_cone_has_ump_1_mor q). - exact (universal_equifier_cone_has_ump_1_pr1 q). Defined. End UniversalConeHasUMP. Section UMP2. Context (cone : equifier_cone) (H : is_univeral_equifier_cone cone) {x : B} {u₁ u₂ : x --> cone} (ζ : u₁ · equifier_cone_pr1 cone ==> u₂ · equifier_cone_pr1 cone). Definition universal_equifier_cone_has_ump_2_cell : u₁ ==> u₂. Proof. apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))). simple refine (_ ,, _). - exact ζ. - exact tt. Defined. Definition universal_equifier_cone_has_ump_2_pr1 : universal_equifier_cone_has_ump_2_cell ▹ equifier_cone_pr1 cone = ζ. Proof. exact (maponpaths pr1 (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂)) _)). Qed. End UMP2. Definition universal_equifier_cone_has_ump_2 (cone : equifier_cone) (H : is_univeral_equifier_cone cone) : has_equifier_ump_2 cone. Proof. intros x u₁ u₂ ζ. simple refine (_ ,, _). - exact (universal_equifier_cone_has_ump_2_cell cone H ζ). - exact (universal_equifier_cone_has_ump_2_pr1 cone H ζ). Defined. Definition universal_equifier_cone_has_ump_eq (cone : equifier_cone) (H : is_univeral_equifier_cone cone) : has_equifier_ump_eq cone. Proof. intros x u₁ u₂ ζ φ₁ φ₂ p q. use (invmaponpathsweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn. use subtypePath. { intro. apply isapropunit. } cbn. exact (p @ !q). Qed. Definition universal_equifier_cone_has_ump (cone : equifier_cone) (H : is_univeral_equifier_cone cone) : has_equifier_ump cone. Proof. simple refine (_ ,, _ ,, _). - exact (universal_equifier_cone_has_ump_1 cone H). - exact (universal_equifier_cone_has_ump_2 cone H). - exact (universal_equifier_cone_has_ump_eq cone H). Defined. Definition isaprop_has_equifier_ump (HB_2_1 : is_univalent_2_1 B) (cone : equifier_cone) : isaprop (has_equifier_ump cone). Proof. use invproofirrelevance. intros χ₁ χ₂. use pathsdirprod. - use funextsec. intro q. use path_equifier_1cell. + apply (isotoid_2_1 HB_2_1). use make_invertible_2cell. * use (equifier_ump_cell χ₁). exact (equifier_1cell_pr1 (pr1 χ₁ q) • (equifier_1cell_pr1 (pr1 χ₂ q))^-1). * use is_invertible_equifier_ump_cell. is_iso. apply property_from_invertible_2cell. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite equifier_ump_cell_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - use pathsdirprod. + use funextsec ; intro x. use funextsec ; intro u₁. use funextsec ; intro u₂. use funextsec ; intro φ. use subtypePath. { intro. apply cellset_property. } use (equifier_ump_eq χ₁). * exact φ. * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ)). * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ)). + do 8 (use funextsec ; intro). apply cellset_property. Qed. Definition isaprop_is_universal_equifier_cone (HB_2_1 : is_univalent_2_1 B) (cone : equifier_cone) : isaprop (is_univeral_equifier_cone cone). Proof. use impred. intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 x cone) (univalent_universal_equifier_cat HB_2_1 x) (to_universal_equifier_cat cone x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 x cone) (univalent_universal_equifier_cat HB_2_1 x) (to_universal_equifier_cat cone x)). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Defined. Definition equifier_ump_weq_is_universal (HB_2_1 : is_univalent_2_1 B) (cone : equifier_cone) : has_equifier_ump cone ≃ is_univeral_equifier_cone cone. Proof. use weqimplimpl. - exact (make_is_universal_equifier_cone HB_2_1 cone). - exact (universal_equifier_cone_has_ump cone). - exact (isaprop_has_equifier_ump HB_2_1 cone). - exact (isaprop_is_universal_equifier_cone HB_2_1 cone). Defined. End Equifiers. Arguments equifier_cone {_ _ _} _ _. (** 4. Bicategories with equifiers *) Definition has_equifiers (B : bicat) : UU := ∏ (b₁ b₂ : B) (f g : b₁ --> b₂) (α β : f ==> g), ∑ (i : B) (m : i --> b₁) (p : m ◃ α = m ◃ β), has_equifier_ump (make_equifier_cone i m p). (** 5. Equifiers are fully faithful *) Definition equifier_faithful {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {α β : f ==> g} {i : B} (m : i --> b₁) (p : m ◃ α = m ◃ β) (H : has_equifier_ump (make_equifier_cone i m p)) : faithful_1cell m. Proof. intros x g₁ g₂ β₁ β₂ q. use (equifier_ump_eq_alt H) ; cbn. - exact (β₁ ▹ m). - exact q. Defined. Definition equifier_fully_faithful {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {α β : f ==> g} {i : B} (m : i --> b₁) (p : m ◃ α = m ◃ β) (H : has_equifier_ump (make_equifier_cone i m p)) : fully_faithful_1cell m. Proof. use make_fully_faithful. - exact (equifier_faithful m p H). - intros z g₁ g₂ βf. simple refine (_ ,, _). + exact (equifier_ump_cell H βf). + exact (equifier_ump_cell_pr1 H βf). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/000077500000000000000000000000001451125700300222735ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Limits/Examples/BicatOfCatsLimits.v000066400000000000000000000104031451125700300257640ustar00rootroot00000000000000(** copies the final object and the inserters from the treatment of the bicategory of univalent categories *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.CommaCategories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Local Open Scope cat. (** 1. Final object *) Definition bifinal_cats : @is_bifinal bicat_of_cats (pr1 unit_category). Proof. use make_is_bifinal. - exact (λ C, functor_to_unit (pr1 C)). - exact (λ C F G, unit_category_nat_trans F G). - intros Y f g α β. apply nat_trans_to_unit_eq. Defined. (** 6. Inserters *) Definition dialgebra_inserter_cone {C₁ C₂ : bicat_of_cats} (F G : C₁ --> C₂) : inserter_cone F G. Proof. use make_inserter_cone. - exact (dialgebra F G). - exact (dialgebra_pr1 F G). - exact (dialgebra_nat_trans F G). Defined. Definition dialgebra_inserter_ump_1 {C₁ C₂ : bicat_of_cats} (F G : C₁ --> C₂) : has_inserter_ump_1 (dialgebra_inserter_cone F G). Proof. intros q. use make_inserter_1cell. - exact (nat_trans_to_dialgebra (inserter_cone_pr1 q) (inserter_cone_cell q)). - use nat_z_iso_to_invertible_2cell. exact (nat_trans_to_dialgebra_pr1_nat_z_iso (inserter_cone_pr1 q) (inserter_cone_cell q)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !(functor_id F), !(functor_id G) ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition dialgebra_inserter_ump_2 {C₁ C₂ : bicat_of_cats} (F G : C₁ --> C₂) : has_inserter_ump_2 (dialgebra_inserter_cone F G). Proof. intros C₀ K₁ K₂ α p. simple refine (_ ,, _). - apply (build_nat_trans_to_dialgebra K₁ K₂ α). abstract (intro x ; pose (nat_trans_eq_pointwise p x) as p' ; cbn in p' ; rewrite !id_left, !id_right in p' ; exact p'). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply idpath). Defined. Definition dialgebra_inserter_ump_eq {C₁ C₂ : bicat_of_cats} (F G : C₁ --> C₂) : has_inserter_ump_eq (dialgebra_inserter_cone F G). Proof. intros C₀ K₁ K₂ α p n₁ n₂ q₁ q₂. use nat_trans_eq. { apply homset_property. } intro x. use eq_dialgebra. exact (nat_trans_eq_pointwise q₁ x @ !(nat_trans_eq_pointwise q₂ x)). Qed. Definition has_inserters_bicat_of_cats : has_inserters bicat_of_cats. Proof. intros C₁ C₂ F G. simple refine (dialgebra F G ,, _ ,, _ ,, _). - exact (dialgebra_pr1 F G). - exact (dialgebra_nat_trans F G). - refine (_ ,, _ ,, _). + exact (dialgebra_inserter_ump_1 F G). + exact (dialgebra_inserter_ump_2 F G). + exact (dialgebra_inserter_ump_eq F G). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/BicatOfEnrichedCatsLimits.v000066400000000000000000000767731451125700300274540ustar00rootroot00000000000000(********************************************************************************* Limits of enriched categories In this file we construct several limits of enriched categories. The construction of these limits is similar as for categories: final objects are constructed via the unit category, inserters are constructed via dialgebras, equifiers are constructed via full subcategories, and Eilenberg-Moore objects are constructed using the Eilenberg-Moore category of a monad. Note that we give two different constructions of the final object. For one of them, we assume that the monoidal category is semi-cartesian. This way, the enrichment is given by the unit of the monoidal category. In the other construction, we assume that the monoidal category has a terminal object. Another thing to notice, is that to construct inserters (and to construct Eilenberg-Moore objects), we assume that the category `V` over which we enrich, has equalizers. Morphisms in the category of dialgebras are given by a morphism such that a certain diagram commutes. Equalizers are used to phrase this commutativity condition. To construct equifiers, we don't need to make any additional assumptions on `V`, because full subcategories of enriched categories can be constructed in general. The largest part of the formalization of these limits is collecting functors and natural transformation that we already constructed in the directory on enriched categories. The only parts that remain to be proven, are the coherences that need to be proven. Contents: 1. Final object 2. Inserters 3. Equifiers 4. Eilenberg-Moore objects *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.UnitEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.EilenbergMooreEnriched. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfEnrichedCats. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section LimitsEnrichedCats. Context (V : monoidal_cat). (** 1. Final object *) (** Note that in this construction of the final object, we assume that the monoidal category `V` is semi-cartesian, which means that the unit is a terminal object. We use this to construct the univalent enriched unit category. *) Section FinalObject. Context (HV : is_semicartesian V). Let enriched_bifinal : bicat_of_enriched_cats V := unit_category ,, unit_enrichment V HV. Definition is_bifinal_enriched_cats : is_bifinal enriched_bifinal. Proof. use make_is_bifinal. - exact (λ E, functor_to_unit _ ,, functor_to_unit_enrichment V HV (pr2 E)). - exact (λ C F G, unit_category_nat_trans (pr1 F) (pr1 G) ,, nat_trans_to_unit_enrichment _ _ _ (pr2 F) (pr2 G)). - abstract (intros C f g α β ; use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; apply nat_trans_to_unit_eq). Defined. Definition bifinal_enriched_cats : bifinal_obj (bicat_of_enriched_cats V) := enriched_bifinal ,, is_bifinal_enriched_cats. End FinalObject. (** Note that in this construction of the final object, we assume that the monoidal category `V` has a terminal object. *) Section FinalObject. Context (T : Terminal V). Let enriched_bifinal_from_terminal : bicat_of_enriched_cats V := unit_category ,, unit_enrichment_from_terminal V T. Definition is_bifinal_enriched_cats_from_terminal : is_bifinal enriched_bifinal_from_terminal. Proof. use make_is_bifinal. - exact (λ E, functor_to_unit _ ,, functor_to_unit_enrichment_from_terminal V T (pr2 E)). - exact (λ C F G, unit_category_nat_trans (pr1 F) (pr1 G) ,, nat_trans_to_unit_enrichment_from_terminal _ _ _ (pr2 F) (pr2 G)). - abstract (intros C f g α β ; use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; apply nat_trans_to_unit_eq). Defined. Definition bifinal_enriched_cats_from_terminal : bifinal_obj (bicat_of_enriched_cats V) := enriched_bifinal_from_terminal ,, is_bifinal_enriched_cats_from_terminal. End FinalObject. (** 2. Inserters *) Section Inserters. Context (HV : Equalizers V) {E₁ E₂ : bicat_of_enriched_cats V} (F G : E₁ --> E₂). Definition enriched_inserter_cat : bicat_of_enriched_cats V := univalent_dialgebra (pr1 F) (pr1 G) ,, dialgebra_enrichment _ HV (pr2 F) (pr2 G). Definition enriched_inserter_pr1 : enriched_inserter_cat --> E₁ := dialgebra_pr1 (pr1 F) (pr1 G) ,, dialgebra_pr1_enrichment _ HV (pr2 F) (pr2 G). Definition enriched_inserter_cell : enriched_inserter_pr1 · F ==> enriched_inserter_pr1 · G := dialgebra_nat_trans (pr1 F) (pr1 G) ,, dialgebra_nat_trans_enrichment _ HV (pr2 F) (pr2 G). Definition enriched_inserter_cone : inserter_cone F G. Proof. use make_inserter_cone. - exact enriched_inserter_cat. - exact enriched_inserter_pr1. - exact enriched_inserter_cell. Defined. Definition enriched_inserter_ump_1 : has_inserter_ump_1 enriched_inserter_cone. Proof. intros q. use make_inserter_1cell. - simple refine (_ ,, _). + exact (nat_trans_to_dialgebra (pr1 (inserter_cone_pr1 q)) (pr1 (inserter_cone_cell q))). + exact (nat_trans_to_dialgebra_enrichment _ HV (pr2 F) (pr2 G) (pr1 (inserter_cone_cell q)) (pr2 (inserter_cone_cell q))). - use make_invertible_2cell. + simple refine (_ ,, _). * exact (nat_trans_to_dialgebra_pr1 (pr1 (inserter_cone_pr1 q)) (pr1 (inserter_cone_cell q))). * exact (nat_trans_to_dialgebra_pr1_enrichment _ HV (pr2 F) (pr2 G) (pr1 (inserter_cone_cell q)) (pr2 (inserter_cone_cell q))). + use make_is_invertible_2cell. * simple refine (_ ,, _). ** cbn. exact (nat_z_iso_inv (nat_trans_to_dialgebra_pr1_nat_z_iso (pr1 (inserter_cone_pr1 q)) (pr1 (inserter_cone_cell q)))). ** exact (nat_trans_to_dialgebra_pr1_enrichment_inv _ HV (pr2 F) (pr2 G) (pr1 (inserter_cone_cell q)) (pr2 (inserter_cone_cell q))). * abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply id_left). * abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply id_left). - abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !(functor_id (pr1 F)), !(functor_id (pr1 G)) ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition enriched_inserter_ump_2 : has_inserter_ump_2 enriched_inserter_cone. Proof. intros E₀ K₁ K₂ α p. simple refine (_ ,, _). - simple refine (_ ,, _). + apply (build_nat_trans_to_dialgebra (pr1 K₁) (pr1 K₂) (pr1 α)). abstract (intro x ; pose (maponpaths (λ z, pr11 z x) p) as p' ; cbn in p' ; rewrite !id_left, !id_right in p' ; exact p'). + apply build_nat_trans_to_dialgebra_enrichment. exact (pr2 α). - abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply idpath). Defined. Definition enriched_inserter_ump_eq : has_inserter_ump_eq enriched_inserter_cone. Proof. intros E₀ K₁ K₂ α p n₁ n₂ q₁ q₂. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. use eq_dialgebra. exact (maponpaths (λ z, pr11 z x) (q₁ @ !q₂)). Qed. End Inserters. Definition has_inserters_bicat_of_enriched_cats (HV : Equalizers V) : has_inserters (bicat_of_enriched_cats V). Proof. intros E₁ E₂ F G. simple refine (_ ,, _ ,, _ ,, _). - exact (enriched_inserter_cat HV F G). - exact (enriched_inserter_pr1 HV F G). - exact (enriched_inserter_cell HV F G). - simple refine (_ ,, _ ,, _). + exact (enriched_inserter_ump_1 HV F G). + exact (enriched_inserter_ump_2 HV F G). + exact (enriched_inserter_ump_eq HV F G). Defined. (** 3. Equifiers *) Section EquifierEnrichedCat. Context {E₁ E₂ : bicat_of_enriched_cats V} {F G : E₁ --> E₂} (τ θ : F ==> G). Definition equifier_bicat_of_enriched_cats : bicat_of_enriched_cats V. Proof. simple refine (_ ,, _). - use (subcategory_univalent (pr1 E₁)). intro x. use make_hProp. + exact (pr11 τ x = pr11 θ x). + apply homset_property. - apply (fullsub_enrichment _ (pr2 E₁)). Defined. Definition equifier_bicat_of_enriched_cats_pr1 : equifier_bicat_of_enriched_cats --> E₁ := sub_precategory_inclusion _ _ ,, fullsub_inclusion_enrichment _ _ _. Definition equifier_bicat_of_enriched_cats_eq : equifier_bicat_of_enriched_cats_pr1 ◃ τ = equifier_bicat_of_enriched_cats_pr1 ◃ θ. Proof. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. exact (pr2 x). Qed. Definition equifier_bicat_of_enriched_cats_cone : equifier_cone F G τ θ := make_equifier_cone equifier_bicat_of_enriched_cats equifier_bicat_of_enriched_cats_pr1 equifier_bicat_of_enriched_cats_eq. Section EquifierUMP1. Context (E₀ : bicat_of_enriched_cats V) (H : E₀ --> E₁) (q : H ◃ τ = H ◃ θ). Definition equifier_bicat_of_enriched_cats_ump_1_functor_data : functor_data (pr11 E₀) (pr11 equifier_bicat_of_enriched_cats). Proof. use make_functor_data. - refine (λ x, pr11 H x ,, _). exact (maponpaths (λ z, pr11 z x) q). - exact (λ x y f, # (pr11 H) f ,, tt). Defined. Definition equifier_bicat_of_enriched_cats_ump_1_functor_laws : is_functor equifier_bicat_of_enriched_cats_ump_1_functor_data. Proof. split ; intro ; intros. - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn. apply functor_id. - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn. apply functor_comp. Qed. Definition equifier_bicat_of_enriched_cats_ump_1_functor : pr11 E₀ ⟶ pr11 equifier_bicat_of_enriched_cats. Proof. use make_functor. - exact equifier_bicat_of_enriched_cats_ump_1_functor_data. - exact equifier_bicat_of_enriched_cats_ump_1_functor_laws. Defined. Definition equifier_bicat_of_enriched_cats_ump_1_enrichment : functor_enrichment equifier_bicat_of_enriched_cats_ump_1_functor (pr2 E₀) (fullsub_enrichment V (pr2 E₁) _). Proof. simple refine (_ ,, _). - exact (λ x y, pr12 H x y). - repeat split. + abstract (intros x ; cbn ; exact (functor_enrichment_id (pr2 H) x)). + abstract (intros x y z ; cbn ; exact (functor_enrichment_comp (pr2 H) x y z)). + abstract (intros x y f ; cbn ; exact (functor_enrichment_from_arr (pr2 H) f)). Defined. Definition equifier_bicat_of_enriched_cats_ump_1_mor : E₀ --> equifier_bicat_of_enriched_cats_cone. Proof. simple refine (_ ,, _). - exact equifier_bicat_of_enriched_cats_ump_1_functor. - exact equifier_bicat_of_enriched_cats_ump_1_enrichment. Defined. Definition equifier_bicat_of_enriched_cats_ump_1_cell : equifier_bicat_of_enriched_cats_ump_1_mor · equifier_bicat_of_enriched_cats_pr1 ==> H. Proof. simple refine (_ ,, _). - use make_nat_trans. + exact (λ _, identity _). + abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). - abstract (intros x y ; cbn ; rewrite id_right ; rewrite !enriched_from_arr_id ; rewrite tensor_split' ; rewrite !assoc' ; rewrite <- enrichment_id_right ; rewrite !assoc ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply tensor_rinvunitor | ] ; rewrite !assoc' ; rewrite mon_rinvunitor_runitor ; rewrite id_right ; rewrite tensor_split ; rewrite !assoc' ; rewrite <- enrichment_id_left ; rewrite !assoc ; refine (!_) ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply tensor_linvunitor | ] ; rewrite !assoc' ; rewrite mon_linvunitor_lunitor ; apply id_right). Defined. Definition equifier_bicat_of_enriched_cats_ump_1_inv : H ==> equifier_bicat_of_enriched_cats_ump_1_mor · equifier_bicat_of_enriched_cats_pr1. Proof. simple refine (_ ,, _). - use make_nat_trans. + exact (λ _, identity _). + abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). - abstract (intros x y ; cbn ; rewrite id_right ; rewrite !enriched_from_arr_id ; rewrite tensor_split' ; rewrite !assoc' ; rewrite <- enrichment_id_right ; rewrite !assoc ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply tensor_rinvunitor | ] ; rewrite !assoc' ; rewrite mon_rinvunitor_runitor ; rewrite id_right ; rewrite tensor_split ; rewrite !assoc' ; rewrite <- enrichment_id_left ; rewrite !assoc ; refine (!_) ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply tensor_linvunitor | ] ; rewrite !assoc' ; rewrite mon_linvunitor_lunitor ; apply id_right). Defined. Definition equifier_bicat_of_enriched_cats_ump_1_inv2cell : invertible_2cell (equifier_bicat_of_enriched_cats_ump_1_mor · equifier_bicat_of_enriched_cats_pr1) H. Proof. use make_invertible_2cell. - exact equifier_bicat_of_enriched_cats_ump_1_cell. - use make_is_invertible_2cell. + exact equifier_bicat_of_enriched_cats_ump_1_inv. + abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro ; apply id_right). + abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro ; apply id_right). Defined. End EquifierUMP1. Definition equifier_bicat_of_enriched_cats_ump_1 : has_equifier_ump_1 equifier_bicat_of_enriched_cats_cone. Proof. intros q. use make_equifier_1cell. - exact (equifier_bicat_of_enriched_cats_ump_1_mor (pr1 q) (pr12 q) (pr22 q)). - exact (equifier_bicat_of_enriched_cats_ump_1_inv2cell (pr1 q) (pr12 q) (pr22 q)). Defined. Section EquifierUMP2. Context {D : bicat_of_enriched_cats V} {H₁ H₂ : D --> equifier_bicat_of_enriched_cats_cone} (α : H₁ · equifier_cone_pr1 equifier_bicat_of_enriched_cats_cone ==> H₂ · equifier_cone_pr1 equifier_bicat_of_enriched_cats_cone). Definition equifier_bicat_of_univ_cats_ump_2_nat_trans : pr1 H₁ ==> pr1 H₂. Proof. use make_nat_trans. - exact (λ x, pr11 α x ,, tt). - abstract (intros x y f ; use subtypePath ; [ intro ; apply isapropunit | ] ; cbn ; exact (nat_trans_ax (pr1 α) _ _ f)). Defined. Definition equifier_bicat_of_enriched_cats_ump_2_enrichment : nat_trans_enrichment (pr1 equifier_bicat_of_univ_cats_ump_2_nat_trans) (pr2 H₁) (pr2 H₂). Proof. intros x y ; cbn. pose (pr2 α x y) as p. cbn in p. rewrite !id_right in p. exact p. Qed. Definition equifier_bicat_of_enriched_cats_ump_2_cell : H₁ ==> H₂. Proof. simple refine (_ ,, _). - exact equifier_bicat_of_univ_cats_ump_2_nat_trans. - exact equifier_bicat_of_enriched_cats_ump_2_enrichment. Defined. Definition equifier_bicat_of_enriched_cats_ump_2_eq : equifier_bicat_of_enriched_cats_ump_2_cell ▹ _ = α. Proof. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. apply idpath. Qed. End EquifierUMP2. Definition equifier_bicat_of_enriched_cats_ump_2 : has_equifier_ump_2 equifier_bicat_of_enriched_cats_cone. Proof. intros D H₁ H₂ α. exact (equifier_bicat_of_enriched_cats_ump_2_cell α ,, equifier_bicat_of_enriched_cats_ump_2_eq α). Defined. Definition equifier_bicat_of_enriched_cats_ump_eq : has_equifier_ump_eq equifier_bicat_of_enriched_cats_cone. Proof. intros D H₁ H₂ α φ₁ φ₂ p q. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. use subtypePath. { intro. apply isapropunit. } exact (maponpaths (λ z, pr11 z x) (p @ !q)). Qed. End EquifierEnrichedCat. Definition has_equifiers_bicat_of_enriched_cats : has_equifiers (bicat_of_enriched_cats V). Proof. intros E₁ E₂ F G τ θ. simple refine (_ ,, _ ,, _ ,, _). - exact (equifier_bicat_of_enriched_cats τ θ). - exact (equifier_bicat_of_enriched_cats_pr1 τ θ). - exact (equifier_bicat_of_enriched_cats_eq τ θ). - simple refine (_ ,, _ ,, _). + exact (equifier_bicat_of_enriched_cats_ump_1 τ θ). + exact (equifier_bicat_of_enriched_cats_ump_2 τ θ). + exact (equifier_bicat_of_enriched_cats_ump_eq τ θ). Defined. (** 4. Eilenberg-Moore objects *) Section EilenbergMooreEnrichedCat. Context (HV : Equalizers V) (EM : mnd (bicat_of_enriched_cats V)). Let C : univalent_category := pr1 (ob_of_mnd EM). Let E : enrichment C V := pr2 (ob_of_mnd EM). Let M : Monad C := Monad_from_mnd_enriched_cats _ EM. Let EM' : monad_enrichment E M := Monad_enrichment_from_mnd_enriched_cats _ EM. Definition em_enriched_cat_cone : em_cone EM. Proof. use make_em_cone. - exact (eilenberg_moore_univalent_cat C M ,, eilenberg_moore_enrichment HV EM'). - exact (eilenberg_moore_pr M ,, eilenberg_moore_pr_enrichment HV EM'). - exact (eilenberg_moore_nat_trans M ,, eilenberg_moore_nat_trans_enrichment HV EM'). - abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; exact (!(pr12 x))). - abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite (functor_id (pr1 (endo_of_mnd EM))) ; rewrite id_left, id_right ; exact (!(pr22 x))). Defined. Section EilenbergMooreUMP1. Context (q : em_cone EM). Let C' : univalent_category := pr11 q. Definition em_enriched_cat_ump_1_functor : C' ⟶ eilenberg_moore_cat M. Proof. use functor_to_eilenberg_moore_cat. - exact (pr1 (mor_of_mnd_mor (mor_of_em_cone _ q))). - exact (pr1 (mnd_mor_endo (mor_of_em_cone _ q))). - abstract (intro x ; refine (!(mnd_mor_unit_enriched _ (mor_of_em_cone _ q) x) @ _) ; apply (functor_id (pr1 (mor_of_mnd_mor (mor_of_em_cone EM q))))). - abstract (intro x ; refine (_ @ (mnd_mor_mu_enriched _ (mor_of_em_cone _ q) x) @ _) ; [ refine (!(id_right _) @ _) ; apply maponpaths ; refine (!_) ; apply (functor_id (pr1 (mor_of_mnd_mor (mor_of_em_cone EM q)))) | cbn ; apply idpath ]). Defined. Definition em_enriched_cat_ump_1_enrichment : functor_enrichment em_enriched_cat_ump_1_functor (pr21 q) (eilenberg_moore_enrichment HV EM'). Proof. use functor_to_eilenberg_moore_cat_enrichment. - exact (pr2 (mor_of_mnd_mor (mor_of_em_cone _ q))). - exact (pr2 (mnd_mor_endo (mor_of_em_cone _ q))). Defined. Definition em_enriched_cat_ump_1_mor : q --> em_enriched_cat_cone. Proof. simple refine (_ ,, _). - exact em_enriched_cat_ump_1_functor. - exact em_enriched_cat_ump_1_enrichment. Defined. Definition em_enriched_cat_ump_1_inv2cell_cell : # (mnd_incl (bicat_of_enriched_cats V)) em_enriched_cat_ump_1_mor · mor_of_em_cone EM em_enriched_cat_cone ==> mor_of_em_cone EM q. Proof. use make_mnd_cell. - simple refine (_ ,, _). + apply functor_to_eilenberg_moore_cat_pr. + apply (functor_to_eilenberg_moore_cat_pr_enrichment HV EM'). - abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; do 2 refine (id_right _ @ _) ; do 2 refine (assoc' _ _ _ @ _) ; refine (id_left _ @ _) ; do 2 refine (assoc _ _ _ @ _) ; do 3 refine (id_right _ @ _) ; refine (!_) ; refine (_ @ id_left _) ; refine (maponpaths (λ z, z · _) _) ; apply (functor_id M)). Defined. Definition em_enriched_cat_ump_1_inv2cell_inv : mor_of_mnd_mor (mor_of_em_cone EM q) ==> mor_of_mnd_mor (# (mnd_incl (bicat_of_enriched_cats V)) em_enriched_cat_ump_1_mor · mor_of_em_cone EM em_enriched_cat_cone). Proof. simple refine (_ ,, _). - exact (nat_z_iso_to_trans_inv (functor_to_eilenberg_moore_cat_pr_nat_z_iso M (pr1 (mor_of_mnd_mor (mor_of_em_cone _ q))) (pr1 (mnd_mor_endo (mor_of_em_cone _ q))) _ _)). - apply functor_to_eilenberg_moore_cat_pr_enrichment_inv. Defined. Definition em_enriched_cat_ump_1_inv2cell : invertible_2cell (# (mnd_incl (bicat_of_enriched_cats V)) em_enriched_cat_ump_1_mor · mor_of_em_cone EM em_enriched_cat_cone) (mor_of_em_cone EM q). Proof. use make_invertible_2cell. - exact em_enriched_cat_ump_1_inv2cell_cell. - use is_invertible_mnd_2cell. use make_is_invertible_2cell. + exact em_enriched_cat_ump_1_inv2cell_inv. + abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; apply id_left). + abstract (use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; apply id_left). Defined. End EilenbergMooreUMP1. Definition em_enriched_cat_ump_1 : em_ump_1 EM em_enriched_cat_cone. Proof. intro q. use make_em_cone_mor. - exact (em_enriched_cat_ump_1_mor q). - exact (em_enriched_cat_ump_1_inv2cell q). Defined. Section EilenbergMooreUMP2. Context {E' : bicat_of_enriched_cats V} (FE₁ FE₂ : E' --> em_enriched_cat_cone) (Eτ : # (mnd_incl (bicat_of_enriched_cats V)) FE₁ · mor_of_em_cone EM em_enriched_cat_cone ==> # (mnd_incl (bicat_of_enriched_cats V)) FE₂ · mor_of_em_cone EM em_enriched_cat_cone). Let C' : univalent_category := pr1 E'. Let F₁ : C' ⟶ eilenberg_moore_cat M := pr1 FE₁. Let F₂ : C' ⟶ eilenberg_moore_cat M := pr1 FE₂. Let τ : F₁ ∙ eilenberg_moore_pr M ⟹ F₂ ∙ eilenberg_moore_pr M := pr11 Eτ. Definition em_enriched_cat_ump_2_eq (x : C') : mor_of_eilenberg_moore_ob (F₁ x) · τ x = # M (τ x) · mor_of_eilenberg_moore_ob (F₂ x). Proof. etrans. { apply maponpaths_2. refine (!(id_right _) @ _). apply maponpaths_2. refine (!(id_right _) @ _). etrans. { apply maponpaths. exact (!(id_left _)). } apply maponpaths_2. refine (!(id_right _) @ _). apply maponpaths_2. exact (!(id_left _)). } refine (!_). etrans. { apply maponpaths. refine (!(id_right _) @ _). apply maponpaths_2. refine (!(id_right _) @ _). etrans. { apply maponpaths. exact (!(id_left _)). } apply maponpaths_2. refine (!(id_right _) @ _). apply maponpaths_2. exact (!(id_left _)). } refine (!_). pose (mnd_cell_endo_enriched _ Eτ x) as p. exact p. Qed. Definition em_enriched_cat_ump_2_nat_trans : F₁ ⟹ F₂ := nat_trans_to_eilenberg_moore_cat M F₁ F₂ τ em_enriched_cat_ump_2_eq. Definition em_enriched_cat_ump_2_cell : FE₁ ==> FE₂. Proof. simple refine (_ ,, _). - exact em_enriched_cat_ump_2_nat_trans. - use nat_trans_to_eilenberg_moore_cat_enrichment. apply (pr21 Eτ). Defined. End EilenbergMooreUMP2. Definition em_enriched_cat_ump_2 : em_ump_2 EM em_enriched_cat_cone. Proof. intros E' FE₁ FE₂ Eτ. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply cellset_property | ] ; use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; pose (maponpaths (λ z, pr111 z x) (pr2 φ₁)) as p₁ ; pose (maponpaths (λ z, pr111 z x) (pr2 φ₂)) as p₂ ; use eq_mor_eilenberg_moore ; exact (p₁ @ (!p₂))). - simple refine (_ ,, _). + exact (em_enriched_cat_ump_2_cell FE₁ FE₂ Eτ). + abstract (use eq_mnd_cell ; use subtypePath ; [ intro ; apply isaprop_nat_trans_enrichment | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; apply idpath). Defined. Definition em_enriched_cat_ump : has_em_ump EM em_enriched_cat_cone. Proof. split. - exact em_enriched_cat_ump_1. - exact em_enriched_cat_ump_2. Defined. End EilenbergMooreEnrichedCat. Definition has_em_bicat_of_enriched_cats (HV : Equalizers V) : bicat_has_em (bicat_of_enriched_cats V) := λ EM, em_enriched_cat_cone HV EM ,, em_enriched_cat_ump HV EM. End LimitsEnrichedCats. UniMath-20231010/UniMath/Bicategories/Limits/Examples/BicatOfUnivCatsLimits.v000066400000000000000000000744601451125700300266430ustar00rootroot00000000000000(********************************************************************************* Limits of categories Contents: 1. Final object 2. Products 3. Pullbacks 4. Strict pullbacks 5. Comma objects 6. Inserters 7. Equifiers 8. Iso-inserters 9. Eilenberg-Moore objects *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.categories.CatIsoInserter. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.CommaCategories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Require Import UniMath.Bicategories.Limits.IsoInserters. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats. Local Open Scope cat. (** 1. Final object *) Definition is_bifinal_cats : @is_bifinal bicat_of_univ_cats unit_category. Proof. use make_is_bifinal. - exact (λ C, functor_to_unit (pr1 C)). - exact (λ C F G, unit_category_nat_trans F G). - intros Y f g α β. apply nat_trans_to_unit_eq. Defined. Definition bifinal_cats : bifinal_obj bicat_of_univ_cats := unit_category ,, is_bifinal_cats. (** 2. Products *) Definition univ_cat_binprod_cone (C₁ C₂ : bicat_of_univ_cats) : binprod_cone C₁ C₂. Proof. use make_binprod_cone. - exact (univalent_category_binproduct C₁ C₂). - apply pr1_functor. - apply pr2_functor. Defined. Section CatsBinprodUMP. Context (C₁ C₂ : bicat_of_univ_cats). Definition binprod_ump_1_univ_cat : binprod_ump_1 (univ_cat_binprod_cone C₁ C₂). Proof. intro q. use make_binprod_1cell. - exact (bindelta_pair_functor (binprod_cone_pr1 q) (binprod_cone_pr2 q)). - apply nat_z_iso_to_invertible_2cell. apply bindelta_pair_pr1_z_iso. - apply nat_z_iso_to_invertible_2cell. apply bindelta_pair_pr2_z_iso. Defined. Definition binprod_ump_2_cell_univ_cat : has_binprod_ump_2_cell (univ_cat_binprod_cone C₁ C₂). Proof. intros q F₁ F₂ α β ; cbn -[functor_composite] in *. use make_nat_trans. - exact (λ x, α x ,, β x). - intros x y f. use pathsdirprod. + apply (nat_trans_ax α). + apply (nat_trans_ax β). Defined. Definition binprod_ump_2_cell_pr1_univ_cat : has_binprod_ump_2_cell_pr1 (univ_cat_binprod_cone C₁ C₂) binprod_ump_2_cell_univ_cat. Proof. intros q F₁ F₂ α β. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply idpath. Qed. Definition binprod_ump_2_cell_pr2_univ_cat : has_binprod_ump_2_cell_pr2 (univ_cat_binprod_cone C₁ C₂) binprod_ump_2_cell_univ_cat. Proof. intros q F₁ F₂ α β. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply idpath. Qed. Definition binprod_ump_2_cell_unique_univ_cat : has_binprod_ump_2_cell_unique (univ_cat_binprod_cone C₁ C₂). Proof. intros q F₁ F₂ α β γ δ p₁ p₂ p₃ p₄. use nat_trans_eq. { apply homset_property. } intro x. use pathsdirprod. - exact (nat_trans_eq_pointwise p₁ x @ !(nat_trans_eq_pointwise p₃ x)). - exact (nat_trans_eq_pointwise p₂ x @ !(nat_trans_eq_pointwise p₄ x)). Qed. Definition has_binprod_ump_univ_cats : has_binprod_ump (univ_cat_binprod_cone C₁ C₂). Proof. use make_binprod_ump. - exact binprod_ump_1_univ_cat. - exact binprod_ump_2_cell_univ_cat. - exact binprod_ump_2_cell_pr1_univ_cat. - exact binprod_ump_2_cell_pr2_univ_cat. - exact binprod_ump_2_cell_unique_univ_cat. Defined. End CatsBinprodUMP. Definition has_binprod_bicat_of_univ_cats : has_binprod bicat_of_univ_cats. Proof. intros C₁ C₂. simple refine (_ ,, _). - exact (univ_cat_binprod_cone C₁ C₂). - exact (has_binprod_ump_univ_cats C₁ C₂). Defined. (** 3. Pullbacks *) Definition iso_comma_pb_cone {C₁ C₂ C₃ : bicat_of_univ_cats} (F : C₁ --> C₃) (G : C₂ --> C₃) : pb_cone F G. Proof. use make_pb_cone. - exact (univalent_iso_comma F G). - exact (iso_comma_pr1 F G). - exact (iso_comma_pr2 F G). - apply nat_z_iso_to_invertible_2cell. exact (iso_comma_commute F G). Defined. Section IsoCommaUMP. Context {C₁ C₂ C₃ : bicat_of_univ_cats} (F : C₁ --> C₃) (G : C₂ --> C₃). Definition pb_ump_1_iso_comma : pb_ump_1 (iso_comma_pb_cone F G). Proof. intro q. use make_pb_1cell. - use iso_comma_ump1. + exact (pb_cone_pr1 q). + exact (pb_cone_pr2 q). + apply invertible_2cell_to_nat_z_iso. exact (pb_cone_cell q). - apply nat_z_iso_to_invertible_2cell. apply iso_comma_ump1_pr1. - apply nat_z_iso_to_invertible_2cell. apply iso_comma_ump1_pr2. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; unfold pb_cone_cell ; rewrite (functor_id F), (functor_id G) ; rewrite !id_left, !id_right ; apply idpath). Defined. Section CellUMP. Let p := iso_comma_pb_cone F G. Context {q : bicat_of_univ_cats} (φ ψ : q --> p) (α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p) (β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p) (r : (φ ◃ pb_cone_cell p) • lassociator _ _ _ • (β ▹ G) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ F) • rassociator _ _ _ • (ψ ◃ pb_cone_cell p)). Definition pb_ump_2_nat_trans : φ ==> ψ. Proof. use (iso_comma_ump2 _ _ _ _ α β). abstract (intros x ; pose (nat_trans_eq_pointwise r x) as z ; cbn in z ; unfold iso_comma_commute_nat_trans_data in z ; rewrite !id_left, !id_right in z ; exact z). Defined. Definition pb_ump_2_nat_trans_pr1 : pb_ump_2_nat_trans ▹ pb_cone_pr1 (iso_comma_pb_cone F G) = α. Proof. apply iso_comma_ump2_pr1. Qed. Definition pb_ump_2_nat_trans_pr2 : pb_ump_2_nat_trans ▹ pb_cone_pr2 (iso_comma_pb_cone F G) = β. Proof. apply iso_comma_ump2_pr2. Qed. End CellUMP. Definition pb_ump_2_iso_comma : pb_ump_2 (iso_comma_pb_cone F G). Proof. intros C φ ψ α β r. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (iso_comma_ump_eq _ _ _ _ α β (pr12 τ₁) (pr22 τ₁) (pr12 τ₂) (pr22 τ₂))). - simple refine (_ ,, _). + exact (pb_ump_2_nat_trans φ ψ α β r). + split. * exact (pb_ump_2_nat_trans_pr1 φ ψ α β r). * exact (pb_ump_2_nat_trans_pr2 φ ψ α β r). Defined. Definition iso_comma_has_pb_ump : has_pb_ump (iso_comma_pb_cone F G). Proof. split. - exact pb_ump_1_iso_comma. - exact pb_ump_2_iso_comma. Defined. End IsoCommaUMP. Definition has_pb_bicat_of_univ_cats : has_pb bicat_of_univ_cats. Proof. intros C₁ C₂ C₃ F G. simple refine (_ ,, _). - exact (iso_comma_pb_cone F G). - exact (iso_comma_has_pb_ump F G). Defined. (** 4. Strict pullbacks *) Section ReindexingPullback. Context {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) (D₂ : disp_univalent_category (pr1 C₂)) (HD₂ : iso_cleaving (pr1 D₂)). Let tot_D₂ : bicat_of_univ_cats := total_univalent_category D₂. Let pb : bicat_of_univ_cats := univalent_reindex_cat F D₂. Let π₁ : pb --> _ := pr1_category _. Let π₂ : pb --> tot_D₂ := total_functor (reindex_disp_cat_disp_functor F D₂). Let γ : invertible_2cell (π₁ · F) (π₂ · pr1_category D₂) := nat_z_iso_to_invertible_2cell (π₁ · F) (π₂ · pr1_category D₂) (total_functor_commute_z_iso (reindex_disp_cat_disp_functor F (pr1 D₂))). Let cone : pb_cone F (pr1_category _ : tot_D₂ --> C₂) := make_pb_cone pb π₁ π₂ γ. Definition reindexing_has_pb_ump_1_cell (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂)) : q --> cone. Proof. use reindex_pb_ump_1. - exact HD₂. - exact (pb_cone_pr2 q). - exact (pb_cone_pr1 q). - apply invertible_2cell_to_nat_z_iso. exact (pb_cone_cell q). Defined. Definition reindexing_has_pb_ump_1_pr1 (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂)) : invertible_2cell (reindexing_has_pb_ump_1_cell q · pb_cone_pr1 cone) (pb_cone_pr1 q). Proof. use nat_z_iso_to_invertible_2cell. exact (reindex_pb_ump_1_pr1_nat_iso F D₂ HD₂ (pb_cone_pr2 q) (pb_cone_pr1 q) (invertible_2cell_to_nat_z_iso _ _ (pb_cone_cell q))). Defined. Definition reindexing_has_pb_ump_1_pr2 (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂)) : invertible_2cell (reindexing_has_pb_ump_1_cell q · pb_cone_pr2 cone) (pb_cone_pr2 q). Proof. use nat_z_iso_to_invertible_2cell. exact (reindex_pb_ump_1_pr2_nat_z_iso F D₂ HD₂ (pb_cone_pr2 q) (pb_cone_pr1 q) (invertible_2cell_to_nat_z_iso _ _ (pb_cone_cell q))). Defined. Definition reindexing_has_pb_ump_1_pb_cell (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂)) : reindexing_has_pb_ump_1_cell q ◃ pb_cone_cell cone = lassociator _ _ _ • (reindexing_has_pb_ump_1_pr1 q ▹ F) • pb_cone_cell q • ((reindexing_has_pb_ump_1_pr2 q)^-1 ▹ _) • rassociator _ _ _. Proof. use nat_trans_eq ; [ apply homset_property | ]. intro x. refine (!_). refine (id_right _ @ _). etrans. { do 2 refine (maponpaths (λ z, z · _) _). apply id_left. } etrans. { do 2 refine (maponpaths (λ z, z · _) _). exact (functor_id F _). } etrans. { refine (maponpaths (λ z, z · _) _). apply id_left. } exact (nat_trans_eq_pointwise (vcomp_rinv (pb_cone_cell q)) x). Qed. Definition reindexing_has_pb_ump_1 : pb_ump_1 cone. Proof. intro q. use make_pb_1cell. - exact (reindexing_has_pb_ump_1_cell q). - exact (reindexing_has_pb_ump_1_pr1 q). - exact (reindexing_has_pb_ump_1_pr2 q). - exact (reindexing_has_pb_ump_1_pb_cell q). Defined. Definition reindexing_has_pb_ump_2 : pb_ump_2 cone. Proof. intros C₀ G₁ G₂ τ₁ τ₂ p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (reindex_pb_ump_eq _ _ _ _ τ₁ τ₂ _ _ (pr12 φ₁) (pr22 φ₁) (pr12 φ₂) (pr22 φ₂))). - simple refine (_ ,, _ ,, _). + use reindex_pb_ump_2. * exact τ₁. * exact τ₂. * abstract (intro x ; pose (nat_trans_eq_pointwise p x) as q ; cbn in q ; rewrite !id_left, !id_right in q ; exact q). + apply reindex_pb_ump_2_pr1. + apply reindex_pb_ump_2_pr2. Defined. Definition reindexing_has_pb_ump : has_pb_ump cone. Proof. split. - exact reindexing_has_pb_ump_1. - exact reindexing_has_pb_ump_2. Defined. End ReindexingPullback. (** 5. Comma objects *) Section CommaObject. Context {C₁ C₂ C₃ : bicat_of_univ_cats} (F : C₁ --> C₃) (G : C₂ --> C₃). Definition comma_comma_cone : comma_cone F G. Proof. use make_comma_cone. - exact (univalent_comma F G). - exact (comma_pr1 F G). - exact (comma_pr2 F G). - exact (comma_commute F G). Defined. Definition comma_ump_1_comma : comma_ump_1 comma_comma_cone. Proof. intro q. use make_comma_1cell. - use comma_ump1. + exact (comma_cone_pr1 q). + exact (comma_cone_pr2 q). + exact (comma_cone_cell q). - apply nat_z_iso_to_invertible_2cell. apply comma_ump1_pr1. - apply nat_z_iso_to_invertible_2cell. apply comma_ump1_pr2. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; unfold pb_cone_cell ; rewrite (functor_id F), (functor_id G) ; rewrite !id_left, !id_right ; apply idpath). Defined. Section CellUMP. Let p := comma_comma_cone. Context {q : bicat_of_univ_cats} (φ ψ : q --> p) (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p) (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p) (r : (φ ◃ comma_cone_cell p) • lassociator _ _ _ • (β ▹ G) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ F) • rassociator _ _ _ • (ψ ◃ comma_cone_cell p)). Definition comma_ump_2_nat_trans : φ ==> ψ. Proof. use (comma_ump2 _ _ _ _ α β). abstract (intros x ; pose (nat_trans_eq_pointwise r x) as z ; cbn in z ; unfold iso_comma_commute_nat_trans_data in z ; rewrite !id_left, !id_right in z ; exact z). Defined. Definition comma_ump_2_nat_trans_pr1 : comma_ump_2_nat_trans ▹ comma_cone_pr1 comma_comma_cone = α. Proof. apply comma_ump2_pr1. Qed. Definition comma_ump_2_nat_trans_pr2 : comma_ump_2_nat_trans ▹ comma_cone_pr2 comma_comma_cone = β. Proof. apply comma_ump2_pr2. Qed. End CellUMP. Definition comma_ump_2_comma : comma_ump_2 comma_comma_cone. Proof. intros C φ ψ α β r. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (comma_ump_eq_nat_trans _ _ _ _ α β (pr12 τ₁) (pr22 τ₁) (pr12 τ₂) (pr22 τ₂))). - simple refine (_ ,, _). + exact (comma_ump_2_nat_trans φ ψ α β r). + split. * exact (comma_ump_2_nat_trans_pr1 φ ψ α β r). * exact (comma_ump_2_nat_trans_pr2 φ ψ α β r). Defined. Definition comma_has_ump : has_comma_ump comma_comma_cone. Proof. split. - exact comma_ump_1_comma. - exact comma_ump_2_comma. Defined. End CommaObject. Definition has_comma_bicat_of_univ_cats : has_comma bicat_of_univ_cats := λ C₁ C₂ C₃ F G, comma_comma_cone F G ,, comma_has_ump F G. (** 6. Inserters *) Definition dialgebra_inserter_cone {C₁ C₂ : bicat_of_univ_cats} (F G : C₁ --> C₂) : inserter_cone F G. Proof. use make_inserter_cone. - exact (univalent_dialgebra F G). - exact (dialgebra_pr1 F G). - exact (dialgebra_nat_trans F G). Defined. Definition dialgebra_inserter_ump_1 {C₁ C₂ : bicat_of_univ_cats} (F G : C₁ --> C₂) : has_inserter_ump_1 (dialgebra_inserter_cone F G). Proof. intros q. use make_inserter_1cell. - exact (nat_trans_to_dialgebra (inserter_cone_pr1 q) (inserter_cone_cell q)). - use nat_z_iso_to_invertible_2cell. exact (nat_trans_to_dialgebra_pr1_nat_z_iso (inserter_cone_pr1 q) (inserter_cone_cell q)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !(functor_id F), !(functor_id G) ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition dialgebra_inserter_ump_2 {C₁ C₂ : bicat_of_univ_cats} (F G : C₁ --> C₂) : has_inserter_ump_2 (dialgebra_inserter_cone F G). Proof. intros C₀ K₁ K₂ α p. simple refine (_ ,, _). - apply (build_nat_trans_to_dialgebra K₁ K₂ α). abstract (intro x ; pose (nat_trans_eq_pointwise p x) as p' ; cbn in p' ; rewrite !id_left, !id_right in p' ; exact p'). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply idpath). Defined. Definition dialgebra_inserter_ump_eq {C₁ C₂ : bicat_of_univ_cats} (F G : C₁ --> C₂) : has_inserter_ump_eq (dialgebra_inserter_cone F G). Proof. intros C₀ K₁ K₂ α p n₁ n₂ q₁ q₂. use nat_trans_eq. { apply homset_property. } intro x. use eq_dialgebra. exact (nat_trans_eq_pointwise q₁ x @ !(nat_trans_eq_pointwise q₂ x)). Qed. Definition has_inserters_bicat_of_univ_cats : has_inserters bicat_of_univ_cats. Proof. intros C₁ C₂ F G. simple refine (univalent_dialgebra F G ,, _ ,, _ ,, _). - exact (dialgebra_pr1 F G). - exact (dialgebra_nat_trans F G). - refine (_ ,, _ ,, _). + exact (dialgebra_inserter_ump_1 F G). + exact (dialgebra_inserter_ump_2 F G). + exact (dialgebra_inserter_ump_eq F G). Defined. (** 7. Equifiers *) Section EquifiersCat. Context {C₁ C₂ : bicat_of_univ_cats} {F G : C₁ --> C₂} (n₁ n₂ : F ==> G). Definition equifier_bicat_of_univ_cats : bicat_of_univ_cats. Proof. use (subcategory_univalent C₁). intro x. use make_hProp. - exact (pr1 n₁ x = pr1 n₂ x). - apply homset_property. Defined. Definition equifier_bicat_of_univ_cats_pr1 : equifier_bicat_of_univ_cats --> C₁ := sub_precategory_inclusion _ _. Definition equifier_bicat_of_univ_cats_eq : equifier_bicat_of_univ_cats_pr1 ◃ n₁ = equifier_bicat_of_univ_cats_pr1 ◃ n₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. exact (pr2 x). Qed. Definition equifier_bicat_of_univ_cats_cone : equifier_cone F G n₁ n₂ := make_equifier_cone equifier_bicat_of_univ_cats equifier_bicat_of_univ_cats_pr1 equifier_bicat_of_univ_cats_eq. Section EquifierUMP1. Context (q : equifier_cone F G n₁ n₂). Definition equifier_bicat_of_univ_cats_ump_1_mor_data : functor_data (pr11 q) (pr1 equifier_bicat_of_univ_cats). Proof. use make_functor_data. - refine (λ x, pr1 (equifier_cone_pr1 q) x ,, _). exact (nat_trans_eq_pointwise (equifier_cone_eq q) x). - exact (λ x y f, # (pr1 (equifier_cone_pr1 q)) f ,, tt). Defined. Definition equifier_bicat_of_univ_cats_ump_1_mor_is_functor : is_functor equifier_bicat_of_univ_cats_ump_1_mor_data. Proof. split ; intro ; intros. - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn. apply functor_id. - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn. apply functor_comp. Qed. Definition equifier_bicat_of_univ_cats_ump_1_mor : q --> equifier_bicat_of_univ_cats_cone. Proof. use make_functor. - exact equifier_bicat_of_univ_cats_ump_1_mor_data. - exact equifier_bicat_of_univ_cats_ump_1_mor_is_functor. Defined. Definition equifier_bicat_of_univ_cats_ump_1_pr1 : equifier_bicat_of_univ_cats_ump_1_mor ∙ equifier_bicat_of_univ_cats_pr1 ⟹ pr1 (equifier_cone_pr1 q). Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition equifier_bicat_of_univ_cats_ump_1_pr1_nat_z_iso : nat_z_iso (equifier_bicat_of_univ_cats_ump_1_mor ∙ equifier_bicat_of_univ_cats_pr1) (equifier_cone_pr1 q). Proof. use make_nat_z_iso. - exact equifier_bicat_of_univ_cats_ump_1_pr1. - intro. apply identity_is_z_iso. Defined. End EquifierUMP1. Definition equifier_bicat_of_univ_cats_ump_1 : has_equifier_ump_1 equifier_bicat_of_univ_cats_cone. Proof. intro q. use make_equifier_1cell. - exact (equifier_bicat_of_univ_cats_ump_1_mor q). - apply nat_z_iso_to_invertible_2cell. exact (equifier_bicat_of_univ_cats_ump_1_pr1_nat_z_iso q). Defined. Section EquifierUMP2. Context {C₀ : bicat_of_univ_cats} {K₁ K₂ : C₀ --> equifier_bicat_of_univ_cats_cone} (α : K₁ · equifier_cone_pr1 equifier_bicat_of_univ_cats_cone ==> K₂ · equifier_cone_pr1 equifier_bicat_of_univ_cats_cone). Definition equifier_bicat_of_univ_cats_ump_2_cell : K₁ ==> K₂. Proof. use make_nat_trans. - exact (λ x, pr1 α x ,, tt). - abstract (intros x y f ; use subtypePath ; [ intro ; apply isapropunit | ] ; cbn ; exact (nat_trans_ax α _ _ f)). Defined. Definition equifier_bicat_of_univ_cats_ump_2_eq : equifier_bicat_of_univ_cats_ump_2_cell ▹ _ = α. Proof. use nat_trans_eq. { apply homset_property. } intro x. apply idpath. Qed. End EquifierUMP2. Definition equifier_bicat_of_univ_cats_ump_2 : has_equifier_ump_2 equifier_bicat_of_univ_cats_cone. Proof. intros C₀ K₁ K₂ α. simple refine (_ ,, _). - exact (equifier_bicat_of_univ_cats_ump_2_cell α). - exact (equifier_bicat_of_univ_cats_ump_2_eq α). Defined. Definition equifier_bicat_of_univ_cats_ump_eq : has_equifier_ump_eq equifier_bicat_of_univ_cats_cone. Proof. intros C₀ K₁ K₂ α β₁ β₂ p₁ p₂. use nat_trans_eq. { apply homset_property. } intro x. use subtypePath. { intro. apply isapropunit. } exact (nat_trans_eq_pointwise p₁ x @ !(nat_trans_eq_pointwise p₂ x)). Qed. End EquifiersCat. Definition has_equifiers_bicat_of_univ_cats : has_equifiers bicat_of_univ_cats. Proof. intros C₁ C₂ F G n₁ n₂. simple refine (_ ,, _ ,, _ ,, _). - exact (equifier_bicat_of_univ_cats n₁ n₂). - exact (equifier_bicat_of_univ_cats_pr1 n₁ n₂). - exact (equifier_bicat_of_univ_cats_eq n₁ n₂). - simple refine (_ ,, _ ,, _). + exact (equifier_bicat_of_univ_cats_ump_1 n₁ n₂). + exact (equifier_bicat_of_univ_cats_ump_2 n₁ n₂). + exact (equifier_bicat_of_univ_cats_ump_eq n₁ n₂). Defined. (** 8. Iso-inserters *) Definition iso_inserter_cone_bicat_of_univ_cats {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : @iso_inserter_cone bicat_of_univ_cats _ _ F G. Proof. use make_iso_inserter_cone. - exact (univalent_cat_iso_inserter F G). - exact (cat_iso_inserter_pr1 F G). - use nat_z_iso_to_invertible_2cell. exact (cat_iso_inserter_nat_iso F G). Defined. Definition iso_inserter_cone_bicat_of_univ_cats_ump_1 {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : has_iso_inserter_ump_1 (iso_inserter_cone_bicat_of_univ_cats F G). Proof. intros q. use make_iso_inserter_1cell. - refine (functor_to_cat_iso_inserter (iso_inserter_cone_pr1 q) _). apply invertible_2cell_to_nat_z_iso. exact (iso_inserter_cone_cell q). - apply nat_z_iso_to_invertible_2cell. apply functor_to_cat_iso_inserter_pr1_nat_z_iso. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite (functor_id F), (functor_id G) ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition iso_inserter_cone_bicat_of_univ_cats_ump_2 {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : has_iso_inserter_ump_2 (iso_inserter_cone_bicat_of_univ_cats F G). Proof. intros C₀ H₁ H₂ α p. simple refine (_ ,, _). - refine (nat_trans_to_cat_iso_inserter α _). abstract (intro x ; pose (nat_trans_eq_pointwise p x) as q ; cbn in q ; rewrite !id_left, !id_right in q ; exact q). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply idpath). Defined. Definition iso_inserter_cone_bicat_of_univ_cats_ump_eq {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : has_iso_inserter_ump_eq (iso_inserter_cone_bicat_of_univ_cats F G). Proof. intros C₀ H₁ H₂ α p ζ₁ ζ₂ q₁ q₂. use nat_trans_eq. { apply homset_property. } intro x. use eq_cat_iso_inserter. refine (nat_trans_eq_pointwise q₁ x @ !_). exact (nat_trans_eq_pointwise q₂ x). Qed. Definition has_iso_inserters_bicat_of_univ_cats : has_iso_inserters bicat_of_univ_cats. Proof. intros C₁ C₂ F G. simple refine (_ ,, _ ,, _ ,, _). - exact (univalent_cat_iso_inserter F G). - exact (cat_iso_inserter_pr1 F G). - use nat_z_iso_to_invertible_2cell. exact (cat_iso_inserter_nat_iso F G). - simple refine (_ ,, _ ,, _). + exact (iso_inserter_cone_bicat_of_univ_cats_ump_1 F G). + exact (iso_inserter_cone_bicat_of_univ_cats_ump_2 F G). + exact (iso_inserter_cone_bicat_of_univ_cats_ump_eq F G). Defined. (** 9. Eilenberg-Moore objects *) Section EilenbergMooreUMP. Context (m : mnd bicat_of_univ_cats). Let C : univalent_category := ob_of_mnd m. Let mC : Monad C := mnd_bicat_of_univ_cats_to_Monad m. Definition eilenberg_moore_cat_cone : em_cone m. Proof. use make_em_cone. - exact (eilenberg_moore_univalent_cat _ mC). - exact (eilenberg_moore_pr mC). - exact (eilenberg_moore_nat_trans mC). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; exact (!(pr12 x))). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite (functor_id (endo_of_mnd m)) ; rewrite id_left, id_right ; exact (!(pr22 x))). Defined. Definition eilenberg_moore_cat_ump_1 : em_ump_1 m eilenberg_moore_cat_cone. Proof. intro q. use make_em_cone_mor. - use functor_to_eilenberg_moore_cat. + exact (mor_of_mnd_mor (mor_of_em_cone _ q)). + exact (mnd_mor_endo (mor_of_em_cone _ q)). + abstract (intro x ; pose (nat_trans_eq_pointwise (mnd_mor_unit (mor_of_em_cone _ q)) x) as p ; cbn in p ; rewrite (functor_id (mor_of_mnd_mor (mor_of_em_cone m q))) in p ; rewrite !id_left in p ; exact (!p)). + abstract (intro x ; pose (nat_trans_eq_pointwise (mnd_mor_mu (mor_of_em_cone _ q)) x) as p ; cbn in p ; rewrite (functor_id (mor_of_mnd_mor (mor_of_em_cone m q))) in p ; rewrite !id_left, !id_right in p ; exact p). - use make_invertible_2cell. + use make_mnd_cell. * apply functor_to_eilenberg_moore_cat_pr. * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite (functor_id (endo_of_mnd m)) ; rewrite !id_left, !id_right ; apply idpath). + use is_invertible_mnd_2cell. use is_nat_z_iso_to_is_invertible_2cell. apply functor_to_eilenberg_moore_cat_pr_is_nat_z_iso. Defined. Definition eilenberg_moore_cat_ump_2 : em_ump_2 m eilenberg_moore_cat_cone. Proof. intros C' F₁ F₂ α. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply cellset_property | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; pose (nat_trans_eq_pointwise (maponpaths pr1 (pr2 φ₁)) x) as p₁ ; pose (nat_trans_eq_pointwise (maponpaths pr1 (pr2 φ₂)) x) as p₂ ; use eq_mor_eilenberg_moore ; exact (p₁ @ (!p₂))). - simple refine (_ ,, _). + use nat_trans_to_eilenberg_moore_cat. * exact (cell_of_mnd_cell α). * abstract (intro x ; pose (nat_trans_eq_pointwise (mnd_cell_endo α) x) as p ; simpl in p ; rewrite !id_left, !id_right in p ; exact p). + abstract (use eq_mnd_cell ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; apply idpath). Defined. Definition eilenberg_moore_cat_ump : has_em_ump m eilenberg_moore_cat_cone. Proof. split. - exact eilenberg_moore_cat_ump_1. - exact eilenberg_moore_cat_ump_2. Defined. End EilenbergMooreUMP. Definition has_em_bicat_of_univ_cats : bicat_has_em bicat_of_univ_cats := λ m, eilenberg_moore_cat_cone m ,, eilenberg_moore_cat_ump m. UniMath-20231010/UniMath/Bicategories/Limits/Examples/DispConstructionsLimits.v000066400000000000000000000200311451125700300273350ustar00rootroot00000000000000(******************************************************************** Limits in some standard constructions Contents 1. Limits in the full subbicategory 2. Limits in the product of displayed bicategories ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. (** 1. Limits in the full subbicategory *) Section LimitsFullSubbicat. Context {B : bicat} (P : B → UU). Definition disp_fullsubbicat_bifinal (HB : bifinal_obj B) (H : P (pr1 HB)) : disp_bifinal_obj (disp_fullsubbicat _ P) HB := H ,, λ _ _, tt. Definition disp_fullsubbicat_binprod (HB : has_binprod B) (H : ∏ (x y : B) (Hx : P x) (Hy : P y), P (pr1 (HB x y))) : disp_has_binprod (disp_fullsubbicat _ P) HB := λ x y, H _ _ (pr2 x) (pr2 y) ,, tt ,, tt ,, λ _ _ _, tt. Definition disp_fullsubbicat_has_pb (HB : has_pb B) (H : ∏ (x y z : B) (f : x --> z) (g : y --> z) (Hx : P x) (Hy : P y) (Hz : P z), P (pr1 (HB x y z f g))) : disp_has_pb (disp_fullsubbicat _ P) HB := λ x y z f g, H _ _ _ _ _ (pr2 x) (pr2 y) (pr2 z) ,, tt ,, tt ,, λ _, tt. Definition disp_fullsubbicat_em_obj (HB : bicat_has_em B) (H : ∏ (m : mnd (total_bicat (disp_fullsubbicat _ P))), P (pr11 (HB (pr1_of_mnd_total_bicat m)))) : disp_has_em (disp_fullsubbicat _ P) HB := λ m, H m ,, tt ,, tt ,, λ _, tt. End LimitsFullSubbicat. (** 2. Limits in the product of displayed bicategories *) Definition disp_dirprod_bifinal {B : bicat} (HB : bifinal_obj B) (D₁ D₂ : disp_bicat B) (HD₁ : disp_bifinal_obj D₁ HB) (HD₂ : disp_bifinal_obj D₂ HB) : disp_bifinal_obj (disp_dirprod_bicat D₁ D₂) HB. Proof. refine ((pr1 HD₁ ,, pr1 HD₂) ,, λ x xx, (_ ,, _)) ; cbn. - exact (pr2 HD₁ x (pr1 xx)). - exact (pr2 HD₂ x (pr2 xx)). Defined. Definition disp_dirprod_binprod {B : bicat} (HB : has_binprod B) (D₁ D₂ : disp_bicat B) (HD₁ : disp_has_binprod D₁ HB) (HD₂ : disp_has_binprod D₂ HB) : disp_has_binprod (disp_dirprod_bicat D₁ D₂) HB. Proof. simple refine (λ x y, _ ,, _ ,, _ ,, λ z f g, _). - simple refine (_ ,, _). + exact (pr1 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y))). + exact (pr1 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y))). - simple refine (_ ,, _). + exact (pr12 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y))). + exact (pr12 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y))). - simple refine (_ ,, _). + exact (pr122 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y))). + exact (pr122 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y))). - simple refine (_ ,, _). + exact (pr222 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y)) (pr1 z ,, pr12 z) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g)). + exact (pr222 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y)) (pr1 z ,, pr22 z) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g)). Defined. Definition disp_dirprod_pb {B : bicat} (HB : has_pb B) (D₁ D₂ : disp_bicat B) (HD₁ : disp_has_pb D₁ HB) (HD₂ : disp_has_pb D₂ HB) : disp_has_pb (disp_dirprod_bicat D₁ D₂) HB. Proof. simple refine (λ x y z f g, _ ,, _ ,, _ ,, λ q, _). - simple refine (_ ,, _). + exact (pr1 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 z ,, pr12 z) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g))). + exact (pr1 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 z ,, pr22 z) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g))). - simple refine (_ ,, _). + exact (pr12 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 z ,, pr12 z) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g))). + exact (pr12 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 z ,, pr22 z) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g))). - simple refine (_ ,, _). + exact (pr122 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 z ,, pr12 z) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g))). + exact (pr122 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 z ,, pr22 z) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g))). - simple refine (_ ,, _). + pose (q' := @make_pb_cone (total_bicat D₁) (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 z ,, pr12 z) (pr1 f,, pr12 f) (pr1 g,, pr12 g) (pr1 (pb_cone_obj q) ,, pr12 (pb_cone_obj q)) (pr1 (pb_cone_pr1 q) ,, pr12 (pb_cone_pr1 q)) (pr1 (pb_cone_pr2 q) ,, pr12 (pb_cone_pr2 q)) (pr1_dirprod_invertible_2cell _ _ (pb_cone_cell q))). pose (m := pr222 (HD₁ (pr1 x ,, pr12 x) (pr1 y ,, pr12 y) (pr1 z ,, pr12 z) (pr1 f ,, pr12 f) (pr1 g ,, pr12 g)) q'). cbn in m ; cbn. use (transportf (λ w, _ -->[ pb_ump_mor _ (make_pb_cone _ _ _ w) ] pr1 (HD₁ (pr1 x,, pr12 x) (pr1 y,, pr12 y) (pr1 z,, pr12 z) (pr1 f,, pr12 f) (pr1 g,, pr12 g))) _ m). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). + pose (q' := @make_pb_cone (total_bicat D₂) (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 z ,, pr22 z) (pr1 f,, pr22 f) (pr1 g,, pr22 g) (pr1 (pb_cone_obj q) ,, pr22 (pb_cone_obj q)) (pr1 (pb_cone_pr1 q) ,, pr22 (pb_cone_pr1 q)) (pr1 (pb_cone_pr2 q) ,, pr22 (pb_cone_pr2 q)) (pr2_dirprod_invertible_2cell _ _ (pb_cone_cell q))). pose (m := pr222 (HD₂ (pr1 x ,, pr22 x) (pr1 y ,, pr22 y) (pr1 z ,, pr22 z) (pr1 f ,, pr22 f) (pr1 g ,, pr22 g)) q'). cbn in m ; cbn. use (transportf (λ w, _ -->[ pb_ump_mor _ (make_pb_cone _ _ _ w) ] pr1 (HD₂ (pr1 x,, pr22 x) (pr1 y,, pr22 y) (pr1 z,, pr22 z) (pr1 f,, pr22 f) (pr1 g,, pr22 g))) _ m). abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/DisplayMapSliceLimits.v000066400000000000000000000344671451125700300267050ustar00rootroot00000000000000(********************************************************************** Limits in slices of display map bicategories Content 1. Final objects 2. Products **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Local Open Scope cat. (** 1. Final objects *) Section ArrowSubbicatFinal. Context {B : bicat} (D : arrow_subbicat B) (b : B) (H : arrow_subbicat_bifinal D). Definition disp_map_slice_bifinal_obj : disp_map_slice_bicat D b := b ,, id₁ b ,, pr1 H b. Definition disp_map_slice_bifinal_1cell_property : bifinal_1cell_property disp_map_slice_bifinal_obj. Proof. intros h. refine (pr12 h ,, _ ,, _). - exact (pr2 H _ _ (pr12 h)). - exact (rinvunitor_invertible_2cell (pr12 h)). Defined. Definition disp_map_slice_bifinal_2cell_property_eq {h : disp_map_slice_bicat D b} (α β : h --> disp_map_slice_bifinal_obj) : pr122 α • ((((rinvunitor (pr1 α) • (pr22 α) ^-1) • pr22 β) • runitor (pr1 β)) ▹ id₁ b) = pr122 β. Proof. cbn. use vcomp_move_R_pM ; [ apply property_from_invertible_2cell | ]. use (vcomp_lcancel (runitor _)) ; [ is_iso | ]. refine (_ @ vcomp_runitor _ _ _). rewrite <- !rwhisker_vcomp. rewrite !vassocr. etrans. { do 3 apply maponpaths_2. rewrite <- runitor_triangle. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite runitor_lunitor_identity. rewrite !vassocl. refine (maponpaths (λ z, _ • z) (vassocr _ _ _) @ _). rewrite lwhisker_vcomp. rewrite lunitor_linvunitor. rewrite lwhisker_id2. rewrite id2_left. rewrite rassociator_lassociator. apply idpath. } rewrite id2_left. rewrite !vassocl. do 2 apply maponpaths. rewrite <- runitor_triangle. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite runitor_rwhisker. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition disp_map_slice_bifinal_2cell_property (h : disp_map_slice_bicat D b) : bifinal_2cell_property disp_map_slice_bifinal_obj h. Proof. intros α β. simple refine (_ ,, _). - exact (rinvunitor _ • (pr22 α)^-1 • pr22 β • runitor _). - exact (disp_map_slice_bifinal_2cell_property_eq α β). Defined. Definition disp_map_slice_bifinal_eq_property (h : disp_map_slice_bicat D b) : bifinal_eq_property disp_map_slice_bifinal_obj h. Proof. intros α β p q. use subtypePath. { intro. apply cellset_property. } use (vcomp_lcancel (runitor _)) ; [ is_iso | ]. rewrite <- !vcomp_runitor. apply maponpaths_2. apply (vcomp_lcancel (pr122 α) (pr22 α)). exact (pr2 p @ !(pr2 q)). Qed. Definition disp_map_slice_bifinal : bifinal_obj (disp_map_slice_bicat D b). Proof. simple refine (_ ,, _). - exact disp_map_slice_bifinal_obj. - use make_is_bifinal. + exact disp_map_slice_bifinal_1cell_property. + exact disp_map_slice_bifinal_2cell_property. + exact disp_map_slice_bifinal_eq_property. Defined. End ArrowSubbicatFinal. (** 2. Products *) Section DisplayMapBicatProduct. Context {B : bicat} (D : disp_map_bicat B) (D_comp : arrow_subbicat_closed_composition D) (D_mor : arrow_subbicat_closed_prod_mor D) {pb x y b : B} {f : x --> b} (Hf : pred_ob D f) {g : y --> b} (Hg : pred_ob D g) (π₁ : pb --> x) (π₂ : pb --> y) (γ : invertible_2cell (π₁ · f) (π₂ · g)) (cone : pb_cone f g := make_pb_cone _ π₁ π₂ γ) (Hpb : has_pb_ump cone). Let ff : disp_map_slice_bicat D b := x ,, f ,, Hf. Let gg : disp_map_slice_bicat D b := y ,, g ,, Hg. Definition binprod_cone_in_disp_map_slice : @binprod_cone (disp_map_slice_bicat D b) ff gg. Proof. use make_binprod_cone. - refine (pb ,, π₁ · f ,, _). apply D_comp. + exact (pb_preserves_pred_ob D Hg (mirror_has_pb_ump Hpb)). + exact Hf. - refine (π₁ ,, _ ,, _) ; cbn. + apply D_comp. * exact (pb_preserves_pred_ob D Hg (mirror_has_pb_ump Hpb)). * exact Hf. + exact (id2_invertible_2cell (π₁ · f)). - refine (π₂ ,, _ ,, _) ; cbn. + use (invertible_pred_mor_1 D (inv_of_invertible_2cell γ)). apply D_comp. * exact (pb_preserves_pred_ob D Hf Hpb). * exact Hg. + exact γ. Defined. Section BinProdUmp1. Context (q : @binprod_cone (disp_map_slice_bicat D b) ff gg). Let other_cone : pb_cone f g := make_pb_cone (pr1 (binprod_cone_obj q)) (pr1 (binprod_cone_pr1 q)) (pr1 (binprod_cone_pr2 q)) (comp_of_invertible_2cell (inv_of_invertible_2cell (pr22 (binprod_cone_pr1 q))) (pr22 (binprod_cone_pr2 q))). Let φ : invertible_2cell (pr121 q) (pb_ump_mor Hpb other_cone · (π₁ · f)) := comp_of_invertible_2cell (comp_of_invertible_2cell (pr22 (binprod_cone_pr1 q)) (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (pb_ump_mor_pr1 Hpb other_cone)))) (rassociator_invertible_2cell _ _ _). Definition binprod_1_ump_in_disp_map_slice_cell_eq : pr22 (binprod_cone_pr1 q) • ((pb_ump_mor_pr1 Hpb other_cone)^-1 ▹ f) • rassociator _ _ _ • ((pb_ump_mor Hpb other_cone ◃ γ) • lassociator _ _ _) • (pb_ump_mor_pr2 Hpb other_cone ▹ g) = pr122 (binprod_cone_pr2 q). Proof. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. exact (pb_ump_mor_cell Hpb other_cone). } cbn ; rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rassociator_lassociator. rewrite id2_left. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition binprod_1_ump_in_disp_map_slice_cell : binprod_1cell q binprod_cone_in_disp_map_slice. Proof. use make_binprod_1cell. - simple refine (_ ,, _ ,, _) ; cbn. + exact (pb_ump_mor Hpb other_cone). + use (invertible_pred_mor_1 _ (inv_of_invertible_2cell (pr22 (binprod_cone_pr1 q)))). apply (D_mor _ _ _ _ _ _ _ _ _ Hpb _ _ _ (comp_of_invertible_2cell (inv_of_invertible_2cell (pr22 (binprod_cone_pr1 q))) (pr22 (binprod_cone_pr2 q))) Hf). * exact (invertible_pred_mor_1 _ (pr22 (binprod_cone_pr1 q)) (pr12 (binprod_cone_pr1 q))). * exact (invertible_pred_mor_1 _ (pr22 (binprod_cone_pr1 q)) (pr12 (binprod_cone_pr2 q))). + exact φ. - use make_invertible_2cell. + simple refine (_ ,, _). * exact (pb_ump_mor_pr1 Hpb other_cone). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply id2_right). + use is_invertible_2cell_in_disp_map_slice_bicat. apply property_from_invertible_2cell. - use make_invertible_2cell. + simple refine (_ ,, _). * exact (pb_ump_mor_pr2 Hpb other_cone). * apply binprod_1_ump_in_disp_map_slice_cell_eq. + use is_invertible_2cell_in_disp_map_slice_bicat. apply property_from_invertible_2cell. Defined. End BinProdUmp1. Definition binprod_1_ump_in_disp_map_slice : binprod_ump_1 binprod_cone_in_disp_map_slice := λ q, binprod_1_ump_in_disp_map_slice_cell q. Section BinProdUmp2. Context {h : disp_map_slice_bicat D b} {φ ψ : h --> binprod_cone_in_disp_map_slice} (α : φ · binprod_cone_pr1 binprod_cone_in_disp_map_slice ==> ψ · binprod_cone_pr1 binprod_cone_in_disp_map_slice) (β : φ · binprod_cone_pr2 binprod_cone_in_disp_map_slice ==> ψ · binprod_cone_pr2 binprod_cone_in_disp_map_slice). Definition binprod_2_ump_in_disp_map_slice_cell_unique : isaprop (∑ χ, χ ▹ binprod_cone_pr1 binprod_cone_in_disp_map_slice = α × χ ▹ binprod_cone_pr2 binprod_cone_in_disp_map_slice = β). Proof. use invproofirrelevance. intros χ₁ χ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use eq_2cell_disp_map_slice. use (pb_ump_eq Hpb). - exact (pr1 α). - exact (pr1 β). - cbn. pose (r₁ := pr2 α). pose (r₂ := pr2 β). cbn in r₁, r₂. rewrite !lwhisker_id2, !id2_left in r₁. use (vcomp_lcancel (pr22 φ)). { apply property_from_invertible_2cell. } rewrite !vassocr. rewrite !vassocr in r₂. refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂. refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁. rewrite !vassocl. apply maponpaths. rewrite lassociator_rassociator, id2_right. rewrite !vassocr. rewrite lassociator_rassociator, id2_left. apply idpath. - exact (maponpaths pr1 (pr12 χ₁)). - exact (maponpaths pr1 (pr22 χ₁)). - exact (maponpaths pr1 (pr12 χ₂)). - exact (maponpaths pr1 (pr22 χ₂)). Qed. Definition binprod_2_ump_in_disp_map_slice_cell : φ ==> ψ. Proof. simple refine (_ ,, _). - use (pb_ump_cell Hpb _ _ (pr1 α) (pr1 β)) ; cbn. abstract (pose (r₁ := pr2 α) ; pose (r₂ := pr2 β) ; cbn in r₁, r₂ ; rewrite !lwhisker_id2, !id2_left in r₁ ; use (vcomp_lcancel (pr22 φ)) ; [ apply property_from_invertible_2cell | ] ; rewrite !vassocr ; rewrite !vassocr in r₂ ; refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂ ; refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁ ; rewrite !vassocl ; apply maponpaths ; rewrite lassociator_rassociator, id2_right ; rewrite !vassocr ; rewrite lassociator_rassociator, id2_left ; apply idpath). - abstract (cbn ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite (pb_ump_cell_pr1 Hpb) ; pose (pr2 α) as r ; cbn in r ; rewrite !lwhisker_id2, !id2_left in r ; rewrite !vassocr ; exact r). Defined. Definition binprod_2_ump_in_disp_map_slice_cell_pr1 : binprod_2_ump_in_disp_map_slice_cell ▹ _ = α. Proof. unfold binprod_2_ump_in_disp_map_slice_cell. use eq_2cell_disp_map_slice. cbn. apply (pb_ump_cell_pr1 Hpb). Qed. Definition binprod_2_ump_in_disp_map_slice_cell_pr2 : binprod_2_ump_in_disp_map_slice_cell ▹ _ = β. Proof. unfold binprod_2_ump_in_disp_map_slice_cell. use eq_2cell_disp_map_slice. cbn. apply (pb_ump_cell_pr2 Hpb). Qed. End BinProdUmp2. Definition binprod_2_ump_in_disp_map_slice : binprod_ump_2 binprod_cone_in_disp_map_slice. Proof. intros h φ ψ α β. use iscontraprop1. - exact (binprod_2_ump_in_disp_map_slice_cell_unique α β). - refine (binprod_2_ump_in_disp_map_slice_cell α β ,, _ ,, _). + exact (binprod_2_ump_in_disp_map_slice_cell_pr1 α β). + exact (binprod_2_ump_in_disp_map_slice_cell_pr2 α β). Defined. Definition binprod_ump_in_disp_map_slice : has_binprod_ump binprod_cone_in_disp_map_slice. Proof. split. - exact binprod_1_ump_in_disp_map_slice. - exact binprod_2_ump_in_disp_map_slice. Defined. End DisplayMapBicatProduct. Definition disp_map_slice_binprod {B : bicat} (D : disp_map_bicat B) (D_comp : arrow_subbicat_closed_composition D) (D_mor : arrow_subbicat_closed_prod_mor D) (pb_B : has_pb B) (b : B) : has_binprod (disp_map_slice_bicat D b). Proof. intros f₁ f₂. refine (_ ,, _). exact (binprod_ump_in_disp_map_slice _ D_comp D_mor _ _ _ _ _ (pr2 (pb_B _ _ _ (pr12 f₁) (pr12 f₂)))). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/LimitsStructuredCategories.v000066400000000000000000000624221451125700300300240ustar00rootroot00000000000000(******************************************************************* Limits in bicategories of structured categories We look at terminal objects, products, pullbacks, and Eilenberg-Moore objects Contents 1. Limits of categories with a terminal objects 2. Limits of categories with products 3. Limits of categories with pullbacks 4. Limits of categories with finite limits 5. Limits of categories with initial objects 6. Limits of categories with coproducts *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.limits.Examples.UnitCategoryLimits. Require Import UniMath.CategoryTheory.limits.Examples.CategoryProductLimits. Require Import UniMath.CategoryTheory.limits.Examples.IsoCommaLimits. Require Import UniMath.CategoryTheory.limits.Examples.EilenbergMooreLimits. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.StructuredCategories. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits. Require Import UniMath.Bicategories.Limits.Examples.DispConstructionsLimits. Require Import UniMath.Bicategories.Limits.Examples.SubbicatLimits. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. (** 1. Limits of categories with a terminal objects *) Definition disp_bifinal_univ_cat_with_terminal_obj : disp_bifinal_obj disp_bicat_terminal_obj bifinal_cats. Proof. use subbicat_disp_final. - exact terminal_unit_category. - intros C. apply functor_to_unit_preserves_terminal. Defined. Definition bifinal_obj_univ_cat_with_terminal_obj : bifinal_obj univ_cat_with_terminal_obj. Proof. use subbicat_final. - exact bifinal_cats. - exact terminal_unit_category. - intros C. apply functor_to_unit_preserves_terminal. Defined. Definition disp_has_binprod_univ_cat_with_terminal_obj : disp_has_binprod disp_bicat_terminal_obj has_binprod_bicat_of_univ_cats. Proof. use subbicat_disp_binprod. - exact (λ C₁ C₂, terminal_category_binproduct (pr12 C₁) (pr12 C₂)). - intros C₁ C₂. apply pr1_preserves_terminal. - intros C₁ C₂. apply pr2_preserves_terminal. - intros C₁ C₂ q. apply preserves_terminal_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition has_binprod_univ_cat_with_terminal_obj : has_binprod univ_cat_with_terminal_obj. Proof. use subbicat_binprod. - exact has_binprod_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ C₁ C₂, terminal_category_binproduct (pr12 C₁) (pr12 C₂)). - intros C₁ C₂. apply pr1_preserves_terminal. - intros C₁ C₂. apply pr2_preserves_terminal. - intros C₁ C₂ q. apply preserves_terminal_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition disp_has_pb_univ_cat_with_terminal_obj : disp_has_pb disp_bicat_terminal_obj has_pb_bicat_of_univ_cats. Proof. use subbicat_disp_has_pb. - exact (λ C₁ C₂ C₃ F G, terminal_category_iso_comma _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G, iso_comma_pr1_preserves_terminal _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G, iso_comma_pr2_preserves_terminal _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G q, iso_comma_ump1_preserves_terminal _ _ (pr22 G) _ (pr22 (pb_cone_pr1 q)) _ (pr22 (pb_cone_pr2 q)) _). Defined. Definition has_pb_univ_cat_with_terminal_obj : has_pb univ_cat_with_terminal_obj. Proof. use subbicat_has_pb. - exact has_pb_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ C₁ C₂ C₃ F G, terminal_category_iso_comma _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G, iso_comma_pr1_preserves_terminal _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G, iso_comma_pr2_preserves_terminal _ _ (pr22 F) (pr22 G) (pr12 C₁) (pr12 C₂)). - exact (λ C₁ C₂ C₃ F G q, iso_comma_ump1_preserves_terminal _ _ (pr22 G) _ (pr22 (pb_cone_pr1 q)) _ (pr22 (pb_cone_pr2 q)) _). Defined. Definition has_em_univ_cat_with_terminal_obj : bicat_has_em univ_cat_with_terminal_obj. Proof. use subbicat_has_em. - exact has_em_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ m, terminal_eilenberg_moore_cat _ (pr12 (ob_of_mnd m))). - exact (λ m, eilenberg_moore_pr_preserves_terminal _ (pr12 (ob_of_mnd m))). - intros m q. use functor_to_eilenberg_moore_cat_preserves_terminal. exact (pr22 (mor_of_mnd_mor (mor_of_em_cone m q))). Defined. (** 2. Limits of categories with products *) Definition disp_bifinal_obj_univ_cat_with_binprod : disp_bifinal_obj disp_bicat_binprod bifinal_cats. Proof. use subbicat_disp_final. - exact binproduct_unit_category. - intro. apply functor_to_unit_preserves_binproduct. Defined. Definition bifinal_obj_univ_cat_with_binprod : bifinal_obj univ_cat_with_binprod. Proof. use subbicat_final. - exact bifinal_cats. - exact binproduct_unit_category. - intro. apply functor_to_unit_preserves_binproduct. Defined. Definition disp_has_binprod_univ_cat_with_binprod : disp_has_binprod disp_bicat_binprod has_binprod_bicat_of_univ_cats. Proof. use subbicat_disp_binprod. - intros C₁ C₂. apply binproducts_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_binproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_binproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_binproduct_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition has_binprod_univ_cat_with_binprod : has_binprod univ_cat_with_binprod. Proof. use subbicat_binprod. - exact has_binprod_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂. apply binproducts_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_binproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_binproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_binproduct_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition disp_has_pb_univ_cat_with_binprod : disp_has_pb disp_bicat_binprod has_pb_bicat_of_univ_cats. Proof. use subbicat_disp_has_pb. - intros C₁ C₂ C₃ F G. apply binproducts_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_binproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_binproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_binproduct. + exact (pr22 G). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_pb_univ_cat_with_binprod : has_pb univ_cat_with_binprod. Proof. use subbicat_has_pb. - exact has_pb_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂ C₃ F G. apply binproducts_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_binproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_binproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_binproduct. + exact (pr22 G). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_em_univ_cat_with_binprod : bicat_has_em univ_cat_with_binprod. Proof. use subbicat_has_em. - exact has_em_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ m, BinProducts_eilenberg_moore_cat _ (pr12 (ob_of_mnd m))). - exact (λ m, eilenberg_moore_pr_preserves_binproduct _ (pr12 (ob_of_mnd m))). - intros m q. use functor_to_eilenberg_moore_cat_preserves_binproduct. exact (pr22 (mor_of_mnd_mor (mor_of_em_cone m q))). Defined. (** 3. Limits of categories with pullbacks *) Definition disp_bifinal_obj_univ_cat_with_pb : disp_bifinal_obj disp_bicat_pullback bifinal_cats. Proof. use subbicat_disp_final. - exact pullbacks_unit_category. - intro. apply functor_to_unit_preserves_pullback. Defined. Definition bifinal_obj_univ_cat_with_pb : bifinal_obj univ_cat_with_pb. Proof. use subbicat_final. - exact bifinal_cats. - exact pullbacks_unit_category. - intro. apply functor_to_unit_preserves_pullback. Defined. Definition disp_has_binprod_univ_cat_with_pb : disp_has_binprod disp_bicat_pullback has_binprod_bicat_of_univ_cats. Proof. use subbicat_disp_binprod. - intros C₁ C₂. apply pullbacks_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_pullback. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_pullback. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_pullback_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition has_binprod_univ_cat_with_pb : has_binprod univ_cat_with_pb. Proof. use subbicat_binprod. - exact has_binprod_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂. apply pullbacks_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_pullback. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_pullback. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_pullback_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition disp_has_pb_univ_cat_with_pb : disp_has_pb disp_bicat_pullback has_pb_bicat_of_univ_cats. Proof. use subbicat_disp_has_pb. - intros C₁ C₂ C₃ F G. apply pullbacks_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_pullback. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_pullback. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_pullback. + exact (pr22 G). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_pb_univ_cat_with_pb : has_pb univ_cat_with_pb. Proof. use subbicat_has_pb. - exact has_pb_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂ C₃ F G. apply pullbacks_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_pullback. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_pullback. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_pullback. + exact (pr22 G). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_em_univ_cat_with_pb : bicat_has_em univ_cat_with_pb. Proof. use subbicat_has_em. - exact has_em_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ m, Pullbacks_eilenberg_moore _ (pr12 (ob_of_mnd m))). - exact (λ m, eilenberg_moore_pr_preserves_pullback _ (pr12 (ob_of_mnd m))). - intros m q. use functor_to_eilenberg_moore_cat_preserves_pullback. exact (pr22 (mor_of_mnd_mor (mor_of_em_cone m q))). Defined. (** 4. Limits of categories with finite limits *) Definition disp_bifinal_obj_univ_cat_with_finlim : disp_bifinal_obj disp_bicat_finlim bifinal_cats. Proof. use disp_dirprod_bifinal. - exact disp_bifinal_univ_cat_with_terminal_obj. - exact disp_bifinal_obj_univ_cat_with_pb. Defined. Definition bifinal_obj_univ_cat_with_finlim : bifinal_obj univ_cat_with_finlim. Proof. use total_bicat_final. - use disp_2cells_isaprop_prod. + apply disp_2cells_isaprop_subbicat. + apply disp_2cells_isaprop_subbicat. - intros. exact ((tt ,, tt) ,, (tt ,, tt)). - exact bifinal_cats. - exact disp_bifinal_obj_univ_cat_with_finlim. Defined. Definition disp_has_binprod_univ_cat_with_finlim : disp_has_binprod disp_bicat_finlim has_binprod_bicat_of_univ_cats. Proof. use disp_dirprod_binprod. - exact disp_has_binprod_univ_cat_with_terminal_obj. - exact disp_has_binprod_univ_cat_with_pb. Defined. Definition has_binprod_univ_cat_with_finlim : has_binprod univ_cat_with_finlim. Proof. use total_bicat_prod. - use disp_2cells_isaprop_prod. + apply disp_2cells_isaprop_subbicat. + apply disp_2cells_isaprop_subbicat. - intros. exact ((tt ,, tt) ,, (tt ,, tt)). - apply disp_locally_groupoid_prod. + apply disp_locally_groupoid_subbicat. apply univalent_cat_is_univalent_2. + apply disp_locally_groupoid_subbicat. apply univalent_cat_is_univalent_2. - exact has_binprod_bicat_of_univ_cats. - exact disp_has_binprod_univ_cat_with_finlim. Defined. Definition disp_has_pb_univ_cat_with_finlim : disp_has_pb disp_bicat_finlim has_pb_bicat_of_univ_cats. Proof. use disp_dirprod_pb. - exact disp_has_pb_univ_cat_with_terminal_obj. - exact disp_has_pb_univ_cat_with_pb. Defined. Definition has_pb_univ_cat_with_finlim : has_pb univ_cat_with_finlim. Proof. use total_bicat_has_pb. - use disp_2cells_isaprop_prod. + apply disp_2cells_isaprop_subbicat. + apply disp_2cells_isaprop_subbicat. - intros. exact ((tt ,, tt) ,, (tt ,, tt)). - apply disp_locally_groupoid_prod. + apply disp_locally_groupoid_subbicat. apply univalent_cat_is_univalent_2. + apply disp_locally_groupoid_subbicat. apply univalent_cat_is_univalent_2. - exact has_pb_bicat_of_univ_cats. - exact disp_has_pb_univ_cat_with_finlim. Defined. (** 5. Limits of categories with initial objects *) Definition disp_bifinal_obj_univ_cat_with_initial : disp_bifinal_obj disp_bicat_initial_obj bifinal_cats. Proof. use subbicat_disp_final. - exact initial_unit_category. - intro C. apply functor_to_unit_preserves_initial. Defined. Definition bifinal_obj_univ_cat_with_initial : bifinal_obj univ_cat_with_initial. Proof. use subbicat_final. - exact bifinal_cats. - exact initial_unit_category. - intro C. apply functor_to_unit_preserves_initial. Defined. Definition disp_has_binprod_univ_cat_with_initial : disp_has_binprod disp_bicat_initial_obj has_binprod_bicat_of_univ_cats. Proof. use subbicat_disp_binprod. - exact (λ C₁ C₂, initial_category_binproduct (pr12 C₁) (pr12 C₂)). - intros C₁ C₂. apply pr1_preserves_initial. - intros C₁ C₂. apply pr2_preserves_initial. - intros C₁ C₂ q. apply preserves_initial_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition has_binprod_univ_cat_with_initial : has_binprod univ_cat_with_initial. Proof. use subbicat_binprod. - exact has_binprod_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - exact (λ C₁ C₂, initial_category_binproduct (pr12 C₁) (pr12 C₂)). - intros C₁ C₂. apply pr1_preserves_initial. - intros C₁ C₂. apply pr2_preserves_initial. - intros C₁ C₂ q. apply preserves_initial_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition disp_has_pb_univ_cat_with_initial : disp_has_pb disp_bicat_initial_obj has_pb_bicat_of_univ_cats. Proof. use subbicat_disp_has_pb. - intros C₁ C₂ C₃ F G. apply initial_category_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_initial. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_initial. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_initial. + exact (pr22 F). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_pb_univ_cat_with_initial : has_pb univ_cat_with_initial. Proof. use subbicat_has_pb. - exact has_pb_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂ C₃ F G. apply initial_category_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_initial. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_initial. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_initial. + exact (pr22 F). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_em_univ_cat_with_initial : bicat_has_em univ_cat_with_initial. Proof. use subbicat_has_em. - exact has_em_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - refine (λ m, initial_eilenberg_moore_cat _ (pr12 (ob_of_mnd m)) _). exact (pr22 (endo_of_mnd m)). - refine (λ m, eilenberg_moore_pr_preserves_initial _ (pr12 (ob_of_mnd m)) _). exact (pr22 (endo_of_mnd m)). - intros m q. use functor_to_eilenberg_moore_cat_preserves_initial. + exact (pr22 (endo_of_mnd m)). + exact (pr22 (mor_of_mnd_mor (mor_of_em_cone m q))). Defined. (** 6. Limits of categories with coproducts *) Definition disp_bifinal_obj_univ_cat_with_bincoprod : disp_bifinal_obj disp_bicat_bincoprod bifinal_cats. Proof. use subbicat_disp_final. - exact bincoproduct_unit_category. - intro C. apply functor_to_unit_preserves_bincoproduct. Defined. Definition bifinal_obj_univ_cat_with_bincoprod : bifinal_obj univ_cat_with_bincoprod. Proof. use subbicat_final. - exact bifinal_cats. - exact bincoproduct_unit_category. - intro C. apply functor_to_unit_preserves_bincoproduct. Defined. Definition disp_has_binprod_univ_cat_with_bincoprod : disp_has_binprod disp_bicat_bincoprod has_binprod_bicat_of_univ_cats. Proof. use subbicat_disp_binprod. - intros C₁ C₂. apply bincoproducts_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_bincoproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_bincoproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_bincoproduct_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition has_binprod_univ_cat_with_bincoprod : has_binprod univ_cat_with_bincoprod. Proof. use subbicat_binprod. - exact has_binprod_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂. apply bincoproducts_in_product_category. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr1_preserves_bincoproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂. apply pr2_preserves_bincoproduct. + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ q. apply preserves_bincoproduct_bindelta_pair_functor. + exact (pr22 (binprod_cone_pr1 q)). + exact (pr22 (binprod_cone_pr2 q)). Defined. Definition disp_has_pb_univ_cat_with_bincoprod : disp_has_pb disp_bicat_bincoprod has_pb_bicat_of_univ_cats. Proof. use subbicat_disp_has_pb. - intros C₁ C₂ C₃ F G. apply bincoproducts_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_pb_univ_cat_with_bincoprod : has_pb univ_cat_with_bincoprod. Proof. use subbicat_has_pb. - exact has_pb_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - intros C₁ C₂ C₃ F G. apply bincoproducts_in_iso_comma. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr1_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G. apply iso_comma_pr2_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 G). + exact (pr12 C₁). + exact (pr12 C₂). - intros C₁ C₂ C₃ F G q. apply iso_comma_ump1_preserves_bincoproduct. + exact (pr22 F). + exact (pr22 (pb_cone_pr1 q)). + exact (pr22 (pb_cone_pr2 q)). Defined. Definition has_em_univ_cat_with_bincoprod : bicat_has_em univ_cat_with_bincoprod. Proof. use subbicat_has_em. - exact has_em_bicat_of_univ_cats. - exact univalent_cat_is_univalent_2. - refine (λ m, bincoproducts_eilenberg_moore _ (pr12 (ob_of_mnd m)) _). exact (pr22 (endo_of_mnd m)). - refine (λ m, eilenberg_moore_pr_preserves_bincoproduct _ (pr12 (ob_of_mnd m)) _). exact (pr22 (endo_of_mnd m)). - intros m q. use functor_to_eilenberg_moore_cat_preserves_bincoproduct. + exact (pr22 (endo_of_mnd m)). + exact (pr22 (mor_of_mnd_mor (mor_of_em_cone m q))). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/OneTypesLimits.v000066400000000000000000000337141451125700300254220ustar00rootroot00000000000000(********************************************************************************* Limits of 1-types Contents: 1. Final object 2. Products 3. Pullbacks 4. Inserters 5. Equifiers *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Local Open Scope cat. (** 1. Final object *) (** MOVE????*) Definition isofhlevel_unit n : isofhlevel n unit := isofhlevelcontr n iscontrunit. Definition unit_one_type : one_types := (unit,, isofhlevel_unit 3). Definition bifinal_one_types : is_bifinal unit_one_type. Proof. use make_is_bifinal. - exact (λ _ _, tt). - exact (λ _ _ _ _, pr1 (isapropunit _ _)). - intros Y f g α β. cbn in *. apply funextsec ; intro z. unfold homotsec in α,β. apply isasetunit. Defined. (** 2. Products of 1-types *) Definition one_types_binprod_cone (X Y : one_types) : binprod_cone X Y. Proof. use make_binprod_cone. - use make_one_type. + exact (pr1 X × pr1 Y). + apply isofhleveldirprod. * exact (pr2 X). * exact (pr2 Y). - exact pr1. - exact pr2. Defined. Section OneTypesBinprodUMP. Context (X Y : one_types). Definition binprod_ump_1_one_types : binprod_ump_1 (one_types_binprod_cone X Y). Proof. intro q. use make_binprod_1cell. - exact (λ x, binprod_cone_pr1 q x ,, binprod_cone_pr2 q x). - use make_invertible_2cell. + intro x ; cbn. apply idpath. + apply one_type_2cell_iso. - use make_invertible_2cell. + intro x ; cbn. apply idpath. + apply one_type_2cell_iso. Defined. Definition binprod_ump_2_cell_one_types : has_binprod_ump_2_cell (one_types_binprod_cone X Y) := λ q f g p₁ p₂ x, pathsdirprod (p₁ x) (p₂ x). Definition binprod_ump_2_cell_pr1_one_types : has_binprod_ump_2_cell_pr1 (one_types_binprod_cone X Y) binprod_ump_2_cell_one_types. Proof. intros q f g p₁ p₂. use funextsec. intro x. apply maponpaths_pr1_pathsdirprod. Qed. Definition binprod_ump_2_cell_pr2_one_types : has_binprod_ump_2_cell_pr2 (one_types_binprod_cone X Y) binprod_ump_2_cell_one_types. Proof. intros q f g p₁ p₂. use funextsec. intro x. apply maponpaths_pr2_pathsdirprod. Qed. Definition binprod_ump_2_cell_unique_one_types : has_binprod_ump_2_cell_unique (one_types_binprod_cone X Y). Proof. intros q f g p₁ p₂ φ₁ φ₂ φ₁pr1 φ₁pr2 φ₂pr1 φ₂pr2. use funextsec. intro x. refine (pathsdirprod_eta _ @ _ @ !(pathsdirprod_eta _)). pose (eqtohomot φ₁pr1 x @ !(eqtohomot φ₂pr1 x)) as r₁. pose (eqtohomot φ₁pr2 x @ !(eqtohomot φ₂pr2 x)) as r₂. cbn in r₁, r₂ ; unfold homotfun in *. etrans. { apply maponpaths. exact r₂. } apply maponpaths_2. exact r₁. Qed. Definition has_binprod_ump_one_types : has_binprod_ump (one_types_binprod_cone X Y). Proof. use make_binprod_ump. - exact binprod_ump_1_one_types. - exact binprod_ump_2_cell_one_types. - exact binprod_ump_2_cell_pr1_one_types. - exact binprod_ump_2_cell_pr2_one_types. - exact binprod_ump_2_cell_unique_one_types. Defined. End OneTypesBinprodUMP. Definition has_binprod_one_types : has_binprod one_types. Proof. intros X Y ; cbn in *. simple refine (_ ,, _). - exact (one_types_binprod_cone X Y). - exact (has_binprod_ump_one_types X Y). Defined. (** 3. Pullbacks *) Definition one_types_pb_cone {X Y Z : one_types} (f : X --> Z) (g : Y --> Z) : pb_cone f g. Proof. use make_pb_cone. - exact (hfp_HLevel 3 f g). - exact (hfpg f g). - exact (hfpg' f g). - use make_invertible_2cell. + exact (λ x, !(commhfp f g x)). + apply one_type_2cell_iso. Defined. Section OneTypesPb. Context {X Y Z : one_types} (f : X --> Z) (g : Y --> Z). Definition one_types_pb_ump_1 : pb_ump_1 (one_types_pb_cone f g). Proof. intro q. use make_pb_1cell. - exact (λ x, (pb_cone_pr1 q x ,, pb_cone_pr2 q x) ,, !(pr1 (pb_cone_cell q) x)). - use make_invertible_2cell. + intro x ; cbn. apply idpath. + apply one_type_2cell_iso. - use make_invertible_2cell. + intro x ; cbn. apply idpath. + apply one_type_2cell_iso. - abstract (use funextsec ; intro x ; cbn ; unfold homotcomp, homotfun, invhomot ; cbn ; rewrite !pathscomp0rid ; apply pathsinv0inv0). Defined. Definition one_types_pb_ump_2 : pb_ump_2 (one_types_pb_cone f g). Proof. intros W φ ψ α β r. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use funextsec ; intro x ; use homot_hfp_one_type ; [ apply Z | exact (eqtohomot (pr12 τ₁) x @ !(eqtohomot (pr12 τ₂) x)) | exact (eqtohomot (pr22 τ₁) x @ !(eqtohomot (pr22 τ₂) x)) ]). - simple refine (_ ,, _). + intro x. use path_hfp. * exact (α x). * exact (β x). * abstract (pose (eqtohomot r x) as p ; cbn in p ; unfold homotcomp, funhomotsec, homotfun in p ; cbn in p ; rewrite !pathscomp0rid in p ; use hornRotation_lr ; rewrite !path_assoc ; refine (_ @ maponpaths (λ z, z @ _) (!p)) ; rewrite <- !path_assoc ; rewrite pathsinv0l ; rewrite pathscomp0rid ; apply idpath). + split. * abstract (use funextsec ; intro x ; apply maponpaths_hfpg_path_hfp). * abstract (use funextsec ; intro x ; apply maponpaths_hfpg'_path_hfp). Defined. End OneTypesPb. Definition one_types_has_pb : has_pb one_types. Proof. intros X Y Z f g. simple refine (_ ,, _ ,, _). - exact (one_types_pb_cone f g). - exact (one_types_pb_ump_1 f g). - exact (one_types_pb_ump_2 f g). Defined. (** 4. Inserters *) Definition inserter_type {X Y : UU} (f g : X → Y) : UU := ∑ (x : X), f x = g x. Definition inserter_type_pr1 {X Y : UU} (f g : X → Y) : inserter_type f g → X := pr1. Definition inserter_type_path {X Y : UU} (f g : X → Y) (x : inserter_type f g) : f (inserter_type_pr1 f g x) = g (inserter_type_pr1 f g x) := pr2 x. Definition isofhlevel_inserter_help {n : nat} {X Y : UU} (HX : isofhlevel n X) (HY : isofhlevel (S n) Y) (f g : X → Y) : isofhlevel n (inserter_type f g). Proof. use isofhleveltotal2. - exact HX. - intro. apply HY. Defined. Definition isofhlevel_inserter {n : nat} {X Y : UU} (HX : isofhlevel n X) (HY : isofhlevel n Y) (f g : X → Y) : isofhlevel n (inserter_type f g). Proof. use isofhlevel_inserter_help. - exact HX. - apply hlevelntosn. exact HY. Defined. Definition inserter_HLevel {n : nat} {X Y : HLevel n} (f g : pr1 X → pr1 Y) : HLevel n. Proof. refine (inserter_type f g ,, _). use isofhlevel_inserter. - exact (pr2 X). - exact (pr2 Y). Defined. Definition one_types_inserter_cone {X Y : one_types} (f g : X --> Y) : inserter_cone f g. Proof. use make_inserter_cone. - exact (inserter_HLevel f g). - exact (inserter_type_pr1 f g). - exact (inserter_type_path f g). Defined. Definition one_types_inserter_ump_1 {X Y : one_types} (f g : X --> Y) : has_inserter_ump_1 (one_types_inserter_cone f g). Proof. intro q. use make_inserter_1cell. - exact (λ x, inserter_cone_pr1 q x ,, inserter_cone_cell q x). - use make_invertible_2cell. + exact (λ x, idpath _). + apply one_type_2cell_iso. - abstract (use funextsec ; intro x ; cbn ; unfold homotcomp, funhomotsec, homotfun ; cbn ; rewrite !pathscomp0rid ; apply idpath). Defined. Definition one_types_inserter_ump_2 {X Y : one_types} (f g : X --> Y) : has_inserter_ump_2 (one_types_inserter_cone f g). Proof. intros W u₁ u₂ p r. simple refine (_ ,, _). - intro x. use total2_paths_f. + exact (p x). + abstract (rewrite transportf_paths_FlFr ; use path_inv_rotate_ll ; pose (eqtohomot r x) as r' ; cbn in r' ; unfold homotcomp, funhomotsec, homotfun in r' ; cbn in r' ; rewrite !pathscomp0rid in r' ; exact r'). - abstract (use funextsec ; intro x ; cbn ; unfold homotfun ; apply base_total2_paths). Defined. Definition one_types_inserter_ump_eq {X Y : one_types} (f g : X --> Y) : has_inserter_ump_eq (one_types_inserter_cone f g). Proof. intros W u₁ u₂ p r φ₁ φ₂ q₁ q₂. use funextsec. intro x. refine (_ @ homotinvweqweq (total2_paths_equiv (λ x, f x = g x) (u₁ x) (u₂ x)) _). refine (!(homotinvweqweq (total2_paths_equiv (λ x, f x = g x) (u₁ x) (u₂ x)) _) @ _). apply maponpaths. use total2_paths_f. - exact (eqtohomot q₁ x @ !(eqtohomot q₂ x)). - apply (pr2 Y). Qed. Definition has_inserters_one_types : has_inserters one_types. Proof. intros X Y f g. simple refine (_ ,, _ ,, _ ,, _). - exact (inserter_HLevel f g). - exact (inserter_type_pr1 f g). - exact (inserter_type_path f g). - simple refine (_ ,, _ ,, _). + exact (one_types_inserter_ump_1 f g). + exact (one_types_inserter_ump_2 f g). + exact (one_types_inserter_ump_eq f g). Defined. (** 5. Equifiers *) Definition equifier_type {X Y : UU} {f g : X → Y} (p₁ p₂ : f ~ g) : UU := ∑ (x : X), p₁ x = p₂ x. Definition isofhlevel_equifier_help {n : nat} {X Y : UU} (HX : isofhlevel n X) (HY : isofhlevel (S(S n)) Y) {f g : X → Y} (p₁ p₂ : f ~ g) : isofhlevel n (equifier_type p₁ p₂). Proof. use isofhleveltotal2. - exact HX. - intro. apply HY. Defined. Definition isofhlevel_equifier {n : nat} {X Y : UU} (HX : isofhlevel n X) (HY : isofhlevel n Y) {f g : X → Y} (p₁ p₂ : f ~ g) : isofhlevel n (equifier_type p₁ p₂). Proof. use isofhlevel_equifier_help. - exact HX. - apply hlevelntosn. apply hlevelntosn. exact HY. Defined. Definition equifier_HLevel {n : nat} {X Y : HLevel n} {f g : pr1 X → pr1 Y} (p₁ p₂ : f ~ g) : HLevel n. Proof. simple refine (_ ,, _). - exact (equifier_type p₁ p₂). - apply isofhlevel_equifier. + exact (pr2 X). + exact (pr2 Y). Defined. Definition one_types_equifier_pr1 {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : one_types ⟦ equifier_HLevel p₁ p₂ , X ⟧ := pr1. Definition one_types_equifier_eq {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : one_types_equifier_pr1 p₁ p₂ ◃ p₁ = one_types_equifier_pr1 p₁ p₂ ◃ p₂. Proof. use funextsec. intro x. exact (pr2 x). Qed. Definition one_types_equifier_cone {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : equifier_cone f g p₁ p₂ := make_equifier_cone (equifier_HLevel p₁ p₂ : one_types) (one_types_equifier_pr1 p₁ p₂) (one_types_equifier_eq p₁ p₂). Definition one_types_equifier_ump_1 {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : has_equifier_ump_1 (one_types_equifier_cone p₁ p₂). Proof. intro q. use make_equifier_1cell. - refine (λ x, equifier_cone_pr1 q x ,, _). abstract (exact (eqtohomot (equifier_cone_eq q) x)). - use make_invertible_2cell. + exact (λ x, idpath _). + apply one_type_2cell_iso. Defined. Definition one_types_equifier_ump_2 {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : has_equifier_ump_2 (one_types_equifier_cone p₁ p₂). Proof. intros W u₁ u₂ α. simple refine (_ ,, _). - intro x. use total2_paths_f. + exact (α x). + apply Y. - abstract (use funextsec ; intro x ; cbn ; apply base_total2_paths). Defined. Definition one_types_equifier_ump_eq {X Y : one_types} {f g : X --> Y} (p₁ p₂ : f ==> g) : has_equifier_ump_eq (one_types_equifier_cone p₁ p₂). Proof. intros W u₁ u₂ α φ₁ φ₂ q₁ q₂. use funextsec. intro x. refine (_ @ homotinvweqweq (total2_paths_equiv (λ x, p₁ x = p₂ x) (u₁ x) (u₂ x)) _). refine (!(homotinvweqweq (total2_paths_equiv (λ x, p₁ x = p₂ x) (u₁ x) (u₂ x)) _) @ _). apply maponpaths. use total2_paths_f. - exact (eqtohomot q₁ x @ !(eqtohomot q₂ x)). - apply isapropifcontr. apply (pr2 Y). Qed. Definition has_equifiers_one_types : has_equifiers one_types. Proof. intros X Y f g p₁ p₂. simple refine (_ ,, _ ,, _ ,, _). - exact (equifier_HLevel p₁ p₂). - exact (one_types_equifier_pr1 p₁ p₂). - exact (one_types_equifier_eq p₁ p₂). - simple refine (_ ,, _ ,, _). + exact (one_types_equifier_ump_1 p₁ p₂). + exact (one_types_equifier_ump_2 p₁ p₂). + exact (one_types_equifier_ump_eq p₁ p₂). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/OpCellBicatLimits.v000066400000000000000000000571551451125700300260020ustar00rootroot00000000000000(*********************************************************************** Limits in op2 bicat Contents: 1. Final object 2. Products 3. Mirroring pullbacks 4. Pullbacks in op2 bicat 5. Comma objects 6. Eilenberg-Moore objects ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.CommaObjects. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Limits.EilenbergMooreComonad. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. (** 1. Final object *) Definition op2_bicat_bifinal {B : bicat} {x : B} (Hx : is_bifinal x) : @is_bifinal (op2_bicat B) x. Proof. use make_is_bifinal. - exact (λ y, is_bifinal_1cell_property Hx y). - exact (λ y f g, is_bifinal_2cell_property Hx y g f). - exact (λ y f g α β, is_bifinal_eq_property Hx y g f α β). Defined. (** 2. Products *) Section ProductOp2. Context {B : bicat} {a x y : B} (p₁ : a --> x) (p₂ : a --> y) (cone := make_binprod_cone a p₁ p₂) (ump : has_binprod_ump cone). Definition op2_binprod_cone : @binprod_cone (op2_bicat B) x y := make_binprod_cone a p₁ p₂. Definition has_binprod_ump_1_op_cell (q : @binprod_cone (op2_bicat B) x y) : binprod_1cell q op2_binprod_cone. Proof. pose (k₁ := binprod_cone_pr1 q). pose (k₂ := binprod_cone_pr2 q). use make_binprod_1cell. - exact (binprod_ump_1cell ump k₁ k₂). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (binprod_ump_1cell_pr1 ump _ k₁ k₂)). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (binprod_ump_1cell_pr2 ump _ k₁ k₂)). Defined. Definition has_binprod_ump_2_op_cell : binprod_ump_2 op2_binprod_cone. Proof. intros q φ ψ α β. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (binprod_ump_2cell_unique_alt ump _ _ (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). - simple refine (_ ,, _ ,, _). + exact (binprod_ump_2cell ump α β). + exact (binprod_ump_2cell_pr1 ump α β). + exact (binprod_ump_2cell_pr2 ump α β). Defined. Definition op2_bicat_has_binprod_ump : has_binprod_ump op2_binprod_cone. Proof. split. - exact has_binprod_ump_1_op_cell. - exact has_binprod_ump_2_op_cell. Defined. End ProductOp2. (** 3. Mirroring pullbacks *) Definition mirror_cone {B : bicat} {x y z : B} {f : x --> z} {g : y --> z} (p : pb_cone f g) : pb_cone g f := make_pb_cone p (pb_cone_pr2 p) (pb_cone_pr1 p) (inv_of_invertible_2cell (pb_cone_cell p)). Section Mirroring. Context {B : bicat} {pb x y z : B} {f : x --> z} {g : y --> z} {p₁ : pb --> x} {p₂ : pb --> y} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (cone := make_pb_cone pb p₁ p₂ γ) (pb_sqr : has_pb_ump cone). Definition mirror_has_pb_ump : has_pb_ump (mirror_cone cone). Proof. split. - intros q. use make_pb_1cell. + exact (pb_ump_mor pb_sqr (mirror_cone q)). + exact (pb_ump_mor_pr2 pb_sqr (mirror_cone q)). + exact (pb_ump_mor_pr1 pb_sqr (mirror_cone q)). + abstract (pose (r := pb_ump_mor_cell pb_sqr (mirror_cone q)) ; cbn in r ; cbn ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; do 2 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn) ; rewrite !vassocl in r ; exact (!r)). - intros w φ ψ α β q. use iscontraprop1. + abstract (use invproofirrelevance ; intros ζ₁ ζ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; refine (pb_ump_eq pb_sqr φ ψ β α _ _ _ (pr22 ζ₁) (pr12 ζ₁) (pr22 ζ₂) (pr12 ζ₂)) ; rewrite !vassocl ; cbn in q ; use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocr ; rewrite q ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_right ; apply idpath). + simple refine (_ ,, _ ,, _). * use (pb_ump_cell pb_sqr φ ψ β α). abstract (rewrite !vassocl ; cbn in q ; use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocr ; rewrite q ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_right ; apply idpath). * exact (pb_ump_cell_pr2 pb_sqr φ ψ β α _). * exact (pb_ump_cell_pr1 pb_sqr φ ψ β α _). Defined. End Mirroring. (** 4. Pullbacks in op2 bicat *) Definition to_op2_pb_cone {B : bicat} {pb x y z : B} {f : x --> z} {g : y --> z} {p₁ : pb --> x} {p₂ : pb --> y} (γ : invertible_2cell (p₁ · f) (p₂ · g)) (cone := make_pb_cone pb p₁ p₂ γ) : @pb_cone (op2_bicat B) _ _ _ f g. Proof. use make_pb_cone. - exact pb. - exact p₁. - exact p₂. - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell γ). Defined. Definition from_op2_pb_cone {B : bicat} {x y z : B} {f : x --> z} {g : y --> z} (cone : @pb_cone (op2_bicat B) _ _ _ f g) : pb_cone f g. Proof. use make_pb_cone. - exact cone. - exact (pb_cone_pr1 cone). - exact (pb_cone_pr2 cone). - exact (inv_of_invertible_2cell (invmap (weq_op2_invertible_2cell _ _) (pb_cone_cell cone))). Defined. Section ToOp2Pullback. Context {B : bicat} {pb x y z : B} {f : x --> z} {g : y --> z} {p₁ : pb --> x} {p₂ : pb --> y} (γ : invertible_2cell (p₁ · f) (p₂ · g)) (cone := make_pb_cone pb p₁ p₂ γ) (H : has_pb_ump cone). Definition to_op2_pb_ump_1 : pb_ump_1 (to_op2_pb_cone γ). Proof. intro q. use make_pb_1cell ; cbn. - exact (pb_ump_mor H (from_op2_pb_cone q)). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (pb_ump_mor_pr1 H (from_op2_pb_cone q))). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (pb_ump_mor_pr2 H (from_op2_pb_cone q))). - abstract (cbn ; pose (pb_ump_mor_cell H (from_op2_pb_cone q)) as p ; cbn in p ; use vcomp_move_L_pM ; [ is_iso | ] ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; use vcomp_move_L_pM ; [ apply from_op2_is_invertible_2cell ; apply property_from_invertible_2cell | ] ; cbn ; use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; refine (_ @ !p) ; rewrite !vassocl ; apply idpath). Defined. Definition to_op2_pb_ump_2 : pb_ump_2 (to_op2_pb_cone γ). Proof. intros w φ ψ α β p ; cbn in p. use iscontraprop1. - abstract (use invproofirrelevance ; intros ζ₁ ζ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use (pb_ump_eq H _ _ α β _ _ _ (pr12 ζ₁) (pr22 ζ₁) (pr12 ζ₂) (pr22 ζ₂)) ; cbn ; cbn in p ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocl ; exact p). - simple refine (_ ,, _). + use (pb_ump_cell H ψ φ α β). abstract (cbn ; cbn in p ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; rewrite !vassocl ; exact p). + split. * apply (pb_ump_cell_pr1 H ψ φ α β). * apply (pb_ump_cell_pr2 H ψ φ α β). Defined. Definition to_op2_has_pb_ump : has_pb_ump (to_op2_pb_cone γ). Proof. split. - exact to_op2_pb_ump_1. - exact to_op2_pb_ump_2. Defined. End ToOp2Pullback. (** 5. Comma objects *) Section Op2Comma. Context {B : bicat} {c x y z : B} {f : x --> z} {g : y --> z} {p₁ : c --> x} {p₂ : c --> y} {γ : p₁ · f ==> p₂ · g} (cone := make_comma_cone c p₁ p₂ γ) (comma_sqr : has_comma_ump cone). Definition op2_comma_cone : @comma_cone (op2_bicat B) _ _ _ g f. Proof. use make_comma_cone. - exact c. - exact p₂. - exact p₁. - exact γ. Defined. Definition op2_comma_has_comma_ump_1 : comma_ump_1 op2_comma_cone. Proof. intro q. pose (q' := make_comma_cone _ (comma_cone_pr2 q : B ⟦ _ , _ ⟧) (comma_cone_pr1 q) (comma_cone_cell q)). use make_comma_1cell ; cbn. - exact (comma_ump_mor comma_sqr q'). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (comma_ump_mor_pr2 comma_sqr q')). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (comma_ump_mor_pr1 comma_sqr q')). - abstract (refine (comma_ump_mor_cell comma_sqr q' @ _) ; cbn ; rewrite !vassocl ; apply idpath). Defined. Definition op2_comma_has_comma_ump_2 : comma_ump_2 op2_comma_cone. Proof. intros q φ ψ α β p. use iscontraprop1. - abstract (use invproofirrelevance ; intros ζ₁ ζ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; refine (comma_ump_eq comma_sqr _ _ β α _ _ _ (pr22 ζ₁) (pr12 ζ₁) (pr22 ζ₂) (pr12 ζ₂)) ; cbn ; cbn in p ; rewrite !vassocl ; exact (!p)). - simple refine (_ ,, _ ,, _). + use (comma_ump_cell comma_sqr _ _ β α). abstract (cbn ; cbn in p ; rewrite !vassocl ; exact (!p)). + abstract (apply (comma_ump_cell_pr2 comma_sqr)). + abstract (apply (comma_ump_cell_pr1 comma_sqr)). Defined. Definition op2_comma_has_comma_ump : has_comma_ump op2_comma_cone. Proof. split. - exact op2_comma_has_comma_ump_1. - exact op2_comma_has_comma_ump_2. Defined. End Op2Comma. (** 6. Eilenberg-Moore objects *) Definition em_comnd_cone_to_op2_em_cone {B : bicat} {m : mnd (op2_bicat B)} (e : em_comnd_cone m) : em_cone m. Proof. use make_em_cone. - exact e. - exact (mor_of_em_comnd_cone _ e). - exact (lunitor _ • cell_of_em_comnd_cone _ e). - abstract (cbn ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; apply maponpaths ; exact (!(em_comnd_cone_counit _ e))). - abstract (cbn ; rewrite !vassocl ; apply maponpaths ; refine (_ @ em_comnd_cone_comult _ e) ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite !vassocr ; rewrite linvunitor_lunitor ; rewrite id2_left ; apply idpath). Defined. Section ComonadEilenbergMoore. Context {B : bicat} {m : mnd (op2_bicat B)} {e : em_comnd_cone m} (He : has_em_comnd_ump m e). Section UMP1. Context (q : em_cone m). Let f : B ⟦ q , ob_of_mnd m ⟧ := mor_of_mnd_mor (mor_of_em_cone _ q). Let γ : id₁ _ · f ==> f · endo_of_mnd m := mnd_mor_endo (mor_of_em_cone _ q). Definition op2_bicat_has_em_ump_1_mor_unit : (linvunitor f • γ) • (f ◃ unit_of_mnd m) = rinvunitor f. Proof. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. refine (!(mnd_mor_unit (mor_of_em_cone _ q)) @ _). refine (_ @ id2_right _). apply maponpaths. apply id2_rwhisker. Qed. Definition op2_bicat_has_em_ump_1_mor_mult : ((linvunitor f • γ) • ((linvunitor f • γ) ▹ endo_of_mnd m)) • rassociator f (endo_of_mnd m) (endo_of_mnd m) = (linvunitor f • γ) • (f ◃ mult_of_mnd m). Proof. rewrite !vassocl. apply maponpaths. assert (γ • (((linvunitor _ • γ) ▹ _) • rassociator _ _ _) = (linvunitor _ ▹ _) • (rassociator _ _ _ • ((_ ◃ γ) • (lassociator _ _ _ • ((γ ▹ _) • rassociator _ _ _))))) as p. { rewrite <- !rwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite linvunitor_assoc. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. apply idpath. } exact (p @ mnd_mor_mu (mor_of_em_cone _ q)). Qed. Definition op2_bicat_has_em_ump_1_mor : q --> em_comnd_cone_to_op2_em_cone e. Proof. use (em_comnd_ump_mor m He). - exact f. - exact (linvunitor _ • γ). - exact op2_bicat_has_em_ump_1_mor_unit. - exact op2_bicat_has_em_ump_1_mor_mult. Defined. Definition op2_bicat_has_em_ump_1_cell_data : mnd_cell_data (# (mnd_incl (op2_bicat B)) op2_bicat_has_em_ump_1_mor · mor_of_em_cone m (em_comnd_cone_to_op2_em_cone e)) (mor_of_em_cone m q) := em_comnd_ump_mor_cell m He f (linvunitor _ • γ) op2_bicat_has_em_ump_1_mor_unit op2_bicat_has_em_ump_1_mor_mult. Let δ : (mor_of_mnd_mor (mor_of_em_cone m q) : B ⟦ _ , _ ⟧) ==> op2_bicat_has_em_ump_1_mor · mor_of_em_comnd_cone m e := op2_bicat_has_em_ump_1_cell_data. Definition op2_bicat_has_em_ump_1_cell_is_mnd_cell : is_mnd_cell op2_bicat_has_em_ump_1_cell_data. Proof. pose (p := em_comnd_ump_mor_cell_endo m He f (linvunitor _ • γ) op2_bicat_has_em_ump_1_mor_unit op2_bicat_has_em_ump_1_mor_mult). use (vcomp_lcancel (linvunitor _)) ; [ is_iso | ]. refine (_ @ vassocl _ _ _). refine (_ @ !p) ; clear p. assert (linvunitor _ • ((_ ◃ δ) • (lassociator _ _ _ • (((lunitor _ • rinvunitor _) ▹ mor_of_em_comnd_cone m e) • (rassociator _ _ _ • ((_ ◃ (lunitor _ • cell_of_em_comnd_cone m e)) • lassociator _ _ _))))) = (δ • (_ ◃ cell_of_em_comnd_cone m e)) • lassociator _ _ _) as p. { rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !vassocr. etrans. { do 5 apply maponpaths_2. apply (@linvunitor_assoc B). } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite (@rassociator_lassociator B). rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite (@rwhisker_vcomp B). rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite rwhisker_hcomp. rewrite <- (@triangle_r_inv B). rewrite <- lwhisker_hcomp. rewrite (@lwhisker_vcomp B). rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. } exact p. Qed. Definition op2_bicat_has_em_ump_1_cell : # (mnd_incl (op2_bicat B)) op2_bicat_has_em_ump_1_mor · mor_of_em_cone m (em_comnd_cone_to_op2_em_cone e) ==> mor_of_em_cone m q. Proof. use make_mnd_cell. - exact op2_bicat_has_em_ump_1_cell_data. - exact op2_bicat_has_em_ump_1_cell_is_mnd_cell. Defined. Definition op2_bicat_has_em_ump_1 : em_cone_mor m q (em_comnd_cone_to_op2_em_cone e). Proof. use make_em_cone_mor. - exact op2_bicat_has_em_ump_1_mor. - use make_invertible_2cell. + exact op2_bicat_has_em_ump_1_cell. + use is_invertible_mnd_2cell. apply to_op2_is_invertible_2cell. apply (em_comnd_ump_mor_cell_is_invertible m He). Defined. End UMP1. Section UMP2. Context {x : op2_bicat B} {g₁ g₂ : x --> em_comnd_cone_to_op2_em_cone e} (α : # (mnd_incl (op2_bicat B)) g₁ · mor_of_em_cone m (em_comnd_cone_to_op2_em_cone e) ==> # (mnd_incl (op2_bicat B)) g₂ · mor_of_em_cone m (em_comnd_cone_to_op2_em_cone e)). Let αcell : (g₂ · mor_of_em_comnd_cone m e : B ⟦ _ , _ ⟧) ==> g₁ · mor_of_em_comnd_cone m e := cell_of_mnd_cell α. Definition op2_bicat_has_em_ump_2_help : αcell • (_ ◃ cell_of_em_comnd_cone m e) • lassociator _ _ _ = (_ ◃ cell_of_em_comnd_cone m e) • lassociator _ _ _ • (αcell ▹ endo_of_mnd m). Proof. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. assert (lunitor _ • ((αcell • (_ ◃ cell_of_em_comnd_cone m e)) • lassociator _ _ _) = (_ ◃ αcell) • (lassociator _ _ _ • (((lunitor _ • rinvunitor _) ▹ mor_of_em_comnd_cone m e) • (rassociator _ _ _ • ((_ ◃ (lunitor _ • cell_of_em_comnd_cone m e)) • lassociator _ _ _))))) as p₁. { refine (!_). etrans. { apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (maponpaths (λ z, _ • z) _). rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. } rewrite !vassocr. do 2 apply maponpaths_2. rewrite vcomp_lunitor. apply idpath. } assert ((lassociator _ _ _ • (((lunitor _ • rinvunitor _) ▹ mor_of_em_comnd_cone m e) • (rassociator _ _ _ • ((_ ◃ (lunitor _ • cell_of_em_comnd_cone m e)) • lassociator _ _ _)))) • (αcell ▹ _) = lunitor _ • (((_ ◃ cell_of_em_comnd_cone m e) • lassociator _ _ _) • (αcell ▹ endo_of_mnd m))) as p₂. { rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 3 apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. apply lwhisker_id2. } exact (p₁ @ mnd_cell_endo α @ p₂). Qed. Definition op2_bicat_has_em_ump_2_unique : isaprop (∑ β : g₁ ==> g₂, ## (mnd_incl (op2_bicat B)) β ▹ _ = α). Proof. use invproofirrelevance. intros β₁ β₂. use subtypePath. { intro. apply cellset_property. } use (em_comnd_ump_eq m He). - exact (pr1 β₁ ▹ mor_of_em_comnd_cone m e). - rewrite vcomp_whisker. rewrite !vassocl. rewrite rwhisker_rwhisker. apply idpath. - apply idpath. - exact (!(maponpaths pr1 (pr2 β₁ @ !(pr2 β₂)))). Qed. Definition op2_bicat_has_em_ump_2_cell : g₁ ==> g₂. Proof. use (em_comnd_ump_cell m He). - exact αcell. - exact op2_bicat_has_em_ump_2_help. Defined. Definition op2_bicat_has_em_ump_2_cell_eq : ## (mnd_incl (op2_bicat B)) op2_bicat_has_em_ump_2_cell ▹ _ = α. Proof. use eq_mnd_cell. apply (em_comnd_ump_cell_eq m He). Qed. End UMP2. Definition op2_bicat_has_em_ump_2 : em_ump_2 m (em_comnd_cone_to_op2_em_cone e). Proof. intros x g₁ g₂ α. use iscontraprop1. - apply op2_bicat_has_em_ump_2_unique. - exact (op2_bicat_has_em_ump_2_cell α ,, op2_bicat_has_em_ump_2_cell_eq α). Defined. Definition op2_bicat_has_em_ump : has_em_ump m (em_comnd_cone_to_op2_em_cone e). Proof. split. - exact op2_bicat_has_em_ump_1. - exact op2_bicat_has_em_ump_2. Defined. End ComonadEilenbergMoore. Definition op2_bicat_has_em {B : bicat} (HB : has_em_comnd B) : bicat_has_em (op2_bicat B) := λ m, let e := HB m in em_comnd_cone_to_op2_em_cone (pr1 e) ,, op2_bicat_has_em_ump (pr2 e). UniMath-20231010/UniMath/Bicategories/Limits/Examples/OpMorBicatLimits.v000066400000000000000000000277451451125700300256620ustar00rootroot00000000000000(**************************************************************************** Eilenberg-Moore objects in the opposite bicategory We show that Eilenberg-Moore objects in the opposite bicategory can be constructed from Kleisli objects in the original bicategory. ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Colimits.KleisliObjects. Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat. Local Open Scope cat. Section EilenbergMooreOpposite. Context {B : bicat}. Section Op1Cone. Context (m : mnd (op1_bicat B)). Let x : B := ob_of_mnd m. Let f : x --> x := endo_of_mnd m. Let η : id₁ x ==> f := unit_of_mnd m. Let μ : f · f ==> f := mult_of_mnd m. Section ToKleisliCocone. Context (e : em_cone m). Let h : B ⟦ ob_of_mnd m , e ⟧ := mor_of_mnd_mor (mor_of_em_cone _ e). Let γ : f · h ==> h · id₁ _ := mnd_mor_endo (mor_of_em_cone _ e). Let p₁ : rinvunitor h • (_ ◃ id₂ _) = linvunitor h • (η ▹ _) • γ := mnd_mor_unit (mor_of_em_cone _ e). Let p₂ : rassociator _ _ _ • (f ◃ γ) • lassociator _ _ _ • (γ ▹ _) • rassociator _ _ _ • (h ◃ runitor _) = (μ ▹ h) • γ := mnd_mor_mu (mor_of_em_cone _ e). Definition from_op1_em_cone : kleisli_cocone m. Proof. use make_kleisli_cocone. - exact e. - exact h. - exact (γ • runitor _). - abstract (cbn ; rewrite lwhisker_id2 in p₁ ; rewrite id2_right in p₁ ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; exact (!p₁)). - abstract (rewrite !vassocr ; refine (_ @ maponpaths (λ z, z • _) p₂) ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite runitor_triangle ; rewrite vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- runitor_triangle ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; apply idpath). Defined. End ToKleisliCocone. Definition to_op1_em_cone (k : kleisli_cocone m) : em_cone m. Proof. use make_em_cone. - exact k. - exact (mor_of_kleisli_cocone _ k). - exact (cell_of_kleisli_cocone _ k • rinvunitor _). - abstract (cbn ; rewrite !vassocr ; refine (!(id2_left _) @ _) ; apply maponpaths_2 ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; rewrite kleisli_cocone_unit ; apply idpath). - abstract (cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite lwhisker_vcomp ; rewrite rinvunitor_runitor ; rewrite lwhisker_id2 ; rewrite id2_left ; rewrite !vassocr ; apply maponpaths_2 ; rewrite kleisli_cocone_mult ; apply idpath). Defined. Section ToEMMore. Context (e : em_cone m) {k : kleisli_cocone m} (g : kleisli_cocone_mor m k (from_op1_em_cone e)). Let h : B ⟦ ob_of_mnd m , e ⟧ := mor_of_mnd_mor (mor_of_em_cone m e). Let γ : f · h ==> h · id₁ _ := mnd_mor_endo (mor_of_em_cone m e). Definition to_op1_em_cone_mor_mnd_cell_eq : lassociator _ _ _ • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ g) • rassociator _ _ _ • (mor_of_kleisli_cocone m k ◃ (lunitor g • rinvunitor g)) • lassociator _ _ _ • (cell_of_kleisli_cocone_mor _ g ▹ _) = (_ ◃ cell_of_kleisli_cocone_mor _ g) • γ. Proof. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite !rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rinvunitor_triangle. rewrite !rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocr. etrans. { apply maponpaths_2. exact (!(kleisli_cocone_mor_endo _ g)). } rewrite !vassocl. etrans. { apply maponpaths. refine (vassocl _ _ _ @ _). apply maponpaths. cbn. apply runitor_rinvunitor. } rewrite id2_right. apply idpath. Qed. Definition to_op1_em_cone_mor_mnd_cell : # (mnd_incl (op1_bicat B)) g · mor_of_em_cone m (to_op1_em_cone k) ==> mor_of_em_cone m e. Proof. use make_mnd_cell. - exact (cell_of_kleisli_cocone_mor _ g). - exact to_op1_em_cone_mor_mnd_cell_eq. Defined. Definition to_op1_em_cone_mor : em_cone_mor _ e (to_op1_em_cone k). Proof. use make_em_cone_mor. - exact g. - use make_invertible_2cell. + exact to_op1_em_cone_mor_mnd_cell. + use is_invertible_mnd_2cell. exact (cell_of_kleisli_cocone_mor_is_invertible _ g). Defined. End ToEMMore. Definition op1_has_em_ump_1 (k : kleisli_cocone m) (Hk : has_kleisli_ump_1 _ k) : em_ump_1 m (to_op1_em_cone k). Proof. intro e. use to_op1_em_cone_mor. exact (Hk (from_op1_em_cone e)). Defined. Section UMP2. Context (k : kleisli_cocone m) (Hk : has_kleisli_ump_2 _ k) {z : B} {g₁ g₂ : k --> z} (α : # (mnd_incl (op1_bicat B)) g₁ · mor_of_em_cone m (to_op1_em_cone k) ==> # (mnd_incl (op1_bicat B)) g₂ · mor_of_em_cone m (to_op1_em_cone k)). Let αcell : mor_of_kleisli_cocone m k · g₁ ==> mor_of_kleisli_cocone m k · g₂ := cell_of_mnd_cell α. Let p : lassociator _ _ _ • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ g₁) • rassociator _ _ _ • (_ ◃ (lunitor _ • rinvunitor _)) • lassociator _ _ _ • (αcell ▹ _) = (_ ◃ αcell) • (lassociator _ _ _ • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ _) • rassociator _ _ _ • (_ ◃ (lunitor _ • rinvunitor _)) • lassociator _ _ _) := mnd_cell_endo α. Local Lemma op1_has_em_ump_2_help_eq : lassociator _ _ _ • (cell_of_kleisli_cocone m k ▹ g₁) • αcell = (_ ◃ αcell) • lassociator _ _ _ • (cell_of_kleisli_cocone m k ▹ g₂). Proof. rewrite <- !lwhisker_vcomp in p. rewrite <- !rwhisker_vcomp in p. rewrite !vassocl in p. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p. rewrite lunitor_lwhisker in p. rewrite !vassocl in p. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) in p. rewrite rwhisker_vcomp in p. rewrite rinvunitor_runitor in p. rewrite id2_rwhisker in p. rewrite id2_left in p. rewrite !vassocl in p. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) in p. rewrite rinvunitor_triangle in p. rewrite !vassocl in p. rewrite !rwhisker_hcomp in p. rewrite <- rinvunitor_natural in p. rewrite <- !rwhisker_hcomp in p. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p. rewrite !rwhisker_hcomp in p. rewrite <- triangle_l_inv in p. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp in p. rewrite !vassocl in p. rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)) in p. rewrite lassociator_rassociator in p. rewrite id2_left in p. rewrite !vassocl in p. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p. rewrite lwhisker_vcomp in p. rewrite linvunitor_lunitor in p. rewrite lwhisker_id2 in p. rewrite id2_left in p. rewrite rinvunitor_triangle in p. use (vcomp_rcancel (rinvunitor _)) ; [ is_iso | ]. rewrite !vassocl. exact p. Qed. Definition op1_has_em_ump_2_unique : isaprop (∑ (β : g₁ ==> g₂), ## (mnd_incl (op1_bicat B)) β ▹ _ = α). Proof. use invproofirrelevance. intros β₁ β₂. use subtypePath ; [ intro ; apply cellset_property | ]. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hk z g₁ g₂ αcell _)) (pr1 β₁ ,, _) (pr1 β₂ ,, _))). - exact op1_has_em_ump_2_help_eq. - exact (maponpaths pr1 (pr2 β₁)). - exact (maponpaths pr1 (pr2 β₂)). Qed. Definition op1_has_em_ump_2_cell : g₁ ==> g₂ := pr11 (Hk z g₁ g₂ αcell op1_has_em_ump_2_help_eq). Definition op1_has_em_ump_2_eq : ## (mnd_incl (op1_bicat B)) op1_has_em_ump_2_cell ▹ _ = α. Proof. use eq_mnd_cell. exact (pr21 (Hk z g₁ g₂ αcell op1_has_em_ump_2_help_eq)). Qed. End UMP2. Definition op1_has_em_ump_2 (k : kleisli_cocone m) (Hk : has_kleisli_ump_2 _ k) : em_ump_2 m (to_op1_em_cone k). Proof. intros z g₁ g₂ α. use iscontraprop1. - exact (op1_has_em_ump_2_unique k Hk α). - simple refine (_ ,, _). + exact (op1_has_em_ump_2_cell k Hk α). + exact (op1_has_em_ump_2_eq k Hk α). Defined. End Op1Cone. Definition op1_has_em (HB : has_kleisli B) : bicat_has_em (op1_bicat B). Proof. intro m. pose (HB m) as q. refine (to_op1_em_cone m (pr1 q) ,, _ ,, _). - apply op1_has_em_ump_1. exact (pr12 q). - apply op1_has_em_ump_2. exact (pr22 q). Defined. End EilenbergMooreOpposite. UniMath-20231010/UniMath/Bicategories/Limits/Examples/SliceBicategoryLimits.v000066400000000000000000001076141451125700300267250ustar00rootroot00000000000000(********************************************************************************* Limits in slice bicategory Contents: 1. Final object 2. Products 3. Inserters 4. Equifiers *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Local Open Scope cat. (** 1. Final object *) Section FinalSlice. Context {B : bicat} (b : B). Let ι : slice_bicat b. Proof. refine (b ,, _). exact (id₁ b). Defined. Definition bifinal_1cell_property_slice : bifinal_1cell_property ι. Proof. intros f. exact (pr2 f ,, rinvunitor_invertible_2cell _). Defined. Definition bifinal_2cell_property_slice_eq {f : slice_bicat b} (α β : f --> ι) : pr12 α • ((((rinvunitor (pr1 α) • (pr22 α) ^-1) • pr12 β) • runitor (pr1 β)) ▹ id₁ b) = pr12 β. Proof. cbn. use vcomp_move_R_pM ; [ apply property_from_invertible_2cell | ]. use (vcomp_lcancel (runitor _)) ; [ is_iso | ]. refine (_ @ vcomp_runitor _ _ _). rewrite <- !rwhisker_vcomp. rewrite !vassocr. etrans. { do 3 apply maponpaths_2. rewrite <- runitor_triangle. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite runitor_lunitor_identity. rewrite !vassocl ; refine (maponpaths (λ z, _ • z) (vassocr _ _ _) @ _). rewrite lwhisker_vcomp. rewrite lunitor_linvunitor. rewrite lwhisker_id2. rewrite id2_left. rewrite rassociator_lassociator. apply idpath. } rewrite id2_left. rewrite !vassocl. do 2 apply maponpaths. rewrite <- runitor_triangle. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite runitor_rwhisker. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition bifinal_2cell_property_slice (f : slice_bicat b) : bifinal_2cell_property ι f. Proof. intros α β. simple refine (_ ,, _). - exact (rinvunitor _ • (pr22 α)^-1 • pr12 β • runitor _). - exact (bifinal_2cell_property_slice_eq α β). Defined. Definition bifinal_eq_property_slice (f : slice_bicat b) : bifinal_eq_property ι f. Proof. intros α β p q. use subtypePath. { intro. apply cellset_property. } use (vcomp_lcancel (runitor _)) ; [ is_iso | ]. rewrite <- !vcomp_runitor. apply maponpaths_2. apply (vcomp_lcancel (pr12 α) (pr22 α)). exact (pr2 p @ !(pr2 q)). Qed. Definition is_bifinal_slice : is_bifinal ι. Proof. refine (_ ,, _). - exact bifinal_1cell_property_slice. - intro f. split. + exact (bifinal_2cell_property_slice f). + exact (bifinal_eq_property_slice f). Defined. Definition final_in_slice : bifinal_obj (slice_bicat b) := ι ,, is_bifinal_slice. End FinalSlice. (** 2. Products *) Section ProductSlice. Context {B : bicat} {pb x y b : B} (f : x --> b) (g : y --> b) (π₁ : pb --> x) (π₂ : pb --> y) (γ : invertible_2cell (π₁ · f) (π₂ · g)) (cone : pb_cone f g := make_pb_cone _ π₁ π₂ γ) (Hpb : has_pb_ump cone). Definition binprod_cone_in_slice : @binprod_cone (slice_bicat b) (x ,, f) (y ,, g). Proof. use make_binprod_cone. - exact (pb ,, π₁ · f). - exact (π₁ ,, id2_invertible_2cell (π₁ · f)). - exact (π₂ ,, γ). Defined. Section BinProdUmp1. Context (q : @binprod_cone (slice_bicat b) (x,, f) (y,, g)). Let other_cone : pb_cone f g := make_pb_cone (pr1 (binprod_cone_obj q)) (pr1 (binprod_cone_pr1 q)) (pr1 (binprod_cone_pr2 q)) (comp_of_invertible_2cell (inv_of_invertible_2cell (pr2 (binprod_cone_pr1 q))) (pr2 (binprod_cone_pr2 q))). Let φ : invertible_2cell (pr21 q) (pb_ump_mor Hpb other_cone · (π₁ · f)) := comp_of_invertible_2cell (comp_of_invertible_2cell (pr2 (binprod_cone_pr1 q)) (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (pb_ump_mor_pr1 Hpb other_cone)))) (rassociator_invertible_2cell _ _ _). Definition binprod_1_ump_in_slice_cell_eq : pr12 (binprod_cone_pr1 q) • ((pb_ump_mor_pr1 Hpb other_cone)^-1 ▹ f) • rassociator _ _ _ • ((pb_ump_mor Hpb other_cone ◃ γ) • lassociator _ _ _) • (pb_ump_mor_pr2 Hpb other_cone ▹ g) = pr12 (binprod_cone_pr2 q). Proof. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. exact (pb_ump_mor_cell Hpb other_cone). } cbn. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rassociator_lassociator. rewrite id2_left. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition binprod_1_ump_in_slice_cell : binprod_1cell q binprod_cone_in_slice. Proof. use make_binprod_1cell. - simple refine (_ ,, _). + exact (pb_ump_mor Hpb other_cone). + exact φ. - use make_invertible_2cell. + simple refine (_ ,, _). * exact (pb_ump_mor_pr1 Hpb other_cone). * abstract (cbn ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; apply id2_right). + use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. - use make_invertible_2cell. + simple refine (_ ,, _). * exact (pb_ump_mor_pr2 Hpb other_cone). * exact binprod_1_ump_in_slice_cell_eq. + use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. Defined. End BinProdUmp1. Definition binprod_1_ump_in_slice : binprod_ump_1 binprod_cone_in_slice := λ q, binprod_1_ump_in_slice_cell q. Section BinProdUmp2. Context {h : slice_bicat b} {φ ψ : h --> binprod_cone_in_slice} (α : φ · binprod_cone_pr1 binprod_cone_in_slice ==> ψ · binprod_cone_pr1 binprod_cone_in_slice) (β : φ · binprod_cone_pr2 binprod_cone_in_slice ==> ψ · binprod_cone_pr2 binprod_cone_in_slice). Definition binprod_2_ump_in_slice_cell_unique : isaprop (∑ χ, χ ▹ binprod_cone_pr1 binprod_cone_in_slice = α × χ ▹ binprod_cone_pr2 binprod_cone_in_slice = β). Proof. use invproofirrelevance. intros χ₁ χ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use eq_2cell_slice. use (pb_ump_eq Hpb). - exact (pr1 α). - exact (pr1 β). - cbn. pose (r₁ := pr2 α). pose (r₂ := pr2 β). cbn in r₁, r₂. rewrite !lwhisker_id2, !id2_left in r₁. use (vcomp_lcancel (pr12 φ)). { apply property_from_invertible_2cell. } rewrite !vassocr. rewrite !vassocr in r₂. refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂. refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁. rewrite !vassocl. apply maponpaths. rewrite lassociator_rassociator, id2_right. rewrite !vassocr. rewrite lassociator_rassociator, id2_left. apply idpath. - exact (maponpaths pr1 (pr12 χ₁)). - exact (maponpaths pr1 (pr22 χ₁)). - exact (maponpaths pr1 (pr12 χ₂)). - exact (maponpaths pr1 (pr22 χ₂)). Qed. Definition binprod_2_ump_in_slice_cell : φ ==> ψ. Proof. simple refine (_ ,, _). - use (pb_ump_cell Hpb _ _ (pr1 α) (pr1 β)) ; cbn. abstract (pose (r₁ := pr2 α) ; pose (r₂ := pr2 β) ; cbn in r₁, r₂ ; rewrite !lwhisker_id2, !id2_left in r₁ ; use (vcomp_lcancel (pr12 φ)) ; [ apply property_from_invertible_2cell | ] ; rewrite !vassocr ; rewrite !vassocr in r₂ ; refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂ ; refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁ ; rewrite !vassocl ; apply maponpaths ; rewrite lassociator_rassociator, id2_right ; rewrite !vassocr ; rewrite lassociator_rassociator, id2_left ; apply idpath). - abstract (cbn ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite (pb_ump_cell_pr1 Hpb) ; pose (pr2 α) as r ; cbn in r ; rewrite !lwhisker_id2, !id2_left in r ; rewrite !vassocr ; exact r). Defined. Definition binprod_2_ump_in_slice_cell_pr1 : binprod_2_ump_in_slice_cell ▹ binprod_cone_pr1 binprod_cone_in_slice = α. Proof. unfold binprod_2_ump_in_slice_cell. use eq_2cell_slice. cbn. apply (pb_ump_cell_pr1 Hpb). Qed. Definition binprod_2_ump_in_slice_cell_pr2 : binprod_2_ump_in_slice_cell ▹ binprod_cone_pr2 binprod_cone_in_slice = β. Proof. unfold binprod_2_ump_in_slice_cell. use eq_2cell_slice. cbn. apply (pb_ump_cell_pr2 Hpb). Qed. End BinProdUmp2. Definition binprod_2_ump_in_slice : binprod_ump_2 binprod_cone_in_slice. Proof. intros h φ ψ α β. use iscontraprop1. - exact (binprod_2_ump_in_slice_cell_unique α β). - refine (binprod_2_ump_in_slice_cell α β ,, _ ,, _). + exact (binprod_2_ump_in_slice_cell_pr1 α β). + exact (binprod_2_ump_in_slice_cell_pr2 α β). Defined. Definition binprod_ump_in_slice : has_binprod_ump binprod_cone_in_slice. Proof. split. - exact binprod_1_ump_in_slice. - exact binprod_2_ump_in_slice. Defined. End ProductSlice. Definition products_in_slice_bicat {B : bicat} (pb_B : has_pb B) (b : B) : has_binprod (slice_bicat b). Proof. intros f₁ f₂. exact (_ ,, binprod_ump_in_slice _ _ _ _ _ (pr2 (pb_B _ _ _ (pr2 f₁) (pr2 f₂)))). Defined. (** 3. Inserters We construct inserters in the slice bicategory by using both inserters and equifiers in the base. We need to take an equifier to guarantee that the obtained 2-cell, satisfies a coherency. *) Section InsertersSlice. Context {B : bicat} (ins_B : has_inserters B) (eq_B : has_equifiers B) {b : B} {h₁ h₂ : slice_bicat b} (α β : h₁ --> h₂). Let I : B := pr1 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)). Let p : I --> pr1 h₁ := pr12 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)). Let γ : p · pr1 α ==> p · pr1 β := pr122 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)). Let I_cone : inserter_cone (pr1 α) (pr1 β) := make_inserter_cone I p γ. Let HI : has_inserter_ump I_cone := pr222 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)). Let E : B := pr1 (eq_B I _ (p · pr2 h₁) (p · pr1 β · pr2 h₂) (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂)) ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))). Let p' : E --> I := pr12 (eq_B I _ (p · pr2 h₁) (p · pr1 β · pr2 h₂) (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂)) ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))). Let path : p' ◃ _ = p' ◃ _ := pr122 (eq_B I _ (p · pr2 h₁) (p · pr1 β · pr2 h₂) (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂)) ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))). Let E_cone : equifier_cone _ _ _ _ := make_equifier_cone E p' path. Let HE : has_equifier_ump E_cone := pr222 (eq_B I _ (p · pr2 h₁) (p · pr1 β · pr2 h₂) (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂)) ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))). Definition inserter_slice : slice_bicat b. Proof. use make_ob_slice. - exact E. - exact (p' · p · pr2 h₁). Defined. Definition inserter_slice_pr1 : inserter_slice --> h₁. Proof. use make_1cell_slice. - exact (p'· p). - apply id2_invertible_2cell. Defined. Definition inserter_slice_cell_cell : p' · p · pr1 α ==> p' · p · pr1 β := rassociator _ _ _ • (p' ◃ γ) • lassociator _ _ _. Definition inserter_slice_cell_homot : cell_slice_homot (inserter_slice_pr1 · α) (inserter_slice_pr1 · β) inserter_slice_cell_cell. Proof. unfold cell_slice_homot, inserter_slice_cell_cell ; cbn. rewrite !id2_left. rewrite <- !rwhisker_vcomp. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- !lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths_2. rewrite !vassocr. apply path. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply lassociator_lassociator. Qed. Definition inserter_slice_cell : inserter_slice_pr1 · α ==> inserter_slice_pr1 · β. Proof. use make_2cell_slice. - exact inserter_slice_cell_cell. - exact inserter_slice_cell_homot. Defined. Let cone : inserter_cone α β := make_inserter_cone inserter_slice inserter_slice_pr1 inserter_slice_cell. Section InserterSliceUMP1. Context (q : inserter_cone α β). Definition inserter_ump_1_slice_mor_to_ins : pr11 q --> I. Proof. use (inserter_ump_mor HI). - exact (pr1 (inserter_cone_pr1 q)). - exact (pr1 (inserter_cone_cell q)). Defined. Definition inserter_ump_1_slice_mor_path : inserter_ump_1_slice_mor_to_ins ◃ (((p ◃ pr12 α) • lassociator _ _ _) • (γ ▹ pr2 h₂)) = inserter_ump_1_slice_mor_to_ins ◃ ((p ◃ pr12 β) • lassociator _ _ _). Proof. rewrite <- !lwhisker_vcomp. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite !lwhisker_lwhisker_rassociator. rewrite !vassocl. use (vcomp_lcancel ((inserter_ump_mor_pr1 HI _ _)^-1 ▹ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite !vcomp_whisker. rewrite !vassocl. use (vcomp_lcancel (pr12 (inserter_cone_pr1 q))). { apply property_from_invertible_2cell. } pose (pr2 (inserter_cone_cell q)) as m. cbn in m. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. etrans. { do 3 apply maponpaths_2. rewrite !vassocl. exact (!m). } rewrite !vassocl. do 3 apply maponpaths. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. apply maponpaths. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. apply (inserter_ump_mor_cell HI). } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. Qed. Definition inserter_ump_1_slice_mor_to_eq : pr11 q --> E. Proof. use (equifier_ump_mor HE). - exact inserter_ump_1_slice_mor_to_ins. - exact inserter_ump_1_slice_mor_path. Defined. Definition inserter_ump_1_slice_mor_inv2cell : invertible_2cell (pr21 q) (inserter_ump_1_slice_mor_to_eq · (p' · p · pr2 h₁)). Proof. use make_invertible_2cell. - exact (pr12 (inserter_cone_pr1 q) • ((inserter_ump_mor_pr1 HI _ _)^-1 ▹ _) • ((equifier_ump_mor_pr1 HE _ _)^-1 ▹ _ ▹ _) • (rassociator _ _ _ ▹ _) • rassociator _ _ _). - is_iso. apply property_from_invertible_2cell. Defined. Definition inserter_ump_1_slice_mor : q --> cone. Proof. use make_1cell_slice. - exact inserter_ump_1_slice_mor_to_eq. - exact inserter_ump_1_slice_mor_inv2cell. Defined. Definition inserter_ump_1_slice_pr1_cell_cell : inserter_ump_1_slice_mor_to_eq · (p' · p) ==> pr1 (inserter_cone_pr1 q) := lassociator _ _ _ • (equifier_ump_mor_pr1 HE _ _ ▹ _) • inserter_ump_mor_pr1 HI _ _. Definition inserter_ump_1_slice_pr1_cell_homot : cell_slice_homot (inserter_ump_1_slice_mor · inserter_slice_pr1) (inserter_cone_pr1 q) inserter_ump_1_slice_pr1_cell_cell. Proof. unfold cell_slice_homot, inserter_ump_1_slice_pr1_cell_cell ; cbn. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. rewrite lwhisker_id2. rewrite id2_left. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite rwhisker_vcomp. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } apply vcomp_linv. Qed. Definition inserter_ump_1_slice_pr1_cell : inserter_ump_1_slice_mor · inserter_slice_pr1 ==> inserter_cone_pr1 q. Proof. use make_2cell_slice. - exact inserter_ump_1_slice_pr1_cell_cell. - exact inserter_ump_1_slice_pr1_cell_homot. Defined. Definition inserter_ump_1_slice_pr1 : invertible_2cell (inserter_ump_1_slice_mor · inserter_slice_pr1) (inserter_cone_pr1 q). Proof. use make_invertible_2cell. - exact inserter_ump_1_slice_pr1_cell. - use is_invertible_2cell_in_slice_bicat ; cbn. unfold inserter_ump_1_slice_pr1_cell_cell. is_iso ; apply property_from_invertible_2cell. Defined. Definition inserter_ump_1_slice_cell : (_ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (inserter_ump_1_slice_pr1 ▹ β) = lassociator _ _ _ • (inserter_ump_1_slice_pr1 ▹ α) • inserter_cone_cell q. Proof. use eq_2cell_slice. cbn ; unfold inserter_ump_1_slice_pr1_cell_cell, inserter_slice_cell_cell ; cbn. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lassociator_lassociator. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite <- vcomp_whisker. rewrite !vassocl. do 2 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { rewrite !vassocr. apply (inserter_ump_mor_cell HI). } rewrite !vassocl. apply idpath. Qed. End InserterSliceUMP1. Definition inserter_ump_1_slice : has_inserter_ump_1 cone. Proof. intro q. use make_inserter_1cell. - exact (inserter_ump_1_slice_mor q). - exact (inserter_ump_1_slice_pr1 q). - exact (inserter_ump_1_slice_cell q). Defined. Local Lemma inserter_ump_path_help {h : slice_bicat b} {u₁ u₂ : h --> cone} (ζ : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (r : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (ζ ▹ β) = (ζ ▹ α) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) : rassociator _ _ _ • (_ ◃ inserter_cone_cell I_cone) • lassociator _ _ _ • ((rassociator _ _ _ • pr1 ζ • lassociator _ _ _) ▹ pr1 β) = (rassociator _ _ _ • pr1 ζ • lassociator _ _ _ ▹ pr1 α) • rassociator _ _ _ • (_ ◃ inserter_cone_cell I_cone) • lassociator _ _ _. Proof. cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. pose (r' := maponpaths pr1 r). cbn in r'. refine (!_). etrans. { do 2 apply maponpaths. rewrite rwhisker_hcomp. rewrite !vassocr. rewrite inverse_pentagon_2. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. apply idpath. } etrans. { apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite <- lassociator_lassociator. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. exact (!r'). } rewrite !vassocr. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite inverse_pentagon_6. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_right. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. apply maponpaths. unfold inserter_slice_cell_cell. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Section InserterUMP2Slice. Context {h : slice_bicat b} {u₁ u₂ : h --> cone} (ζ : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (r : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (ζ ▹ β) = (ζ ▹ α) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _). Definition inserter_ump_2_slice_cell_cell : pr1 u₁ ==> pr1 u₂. Proof. use (equifier_ump_cell HE). use (inserter_ump_cell HI). - exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _). - exact (inserter_ump_path_help ζ r). Defined. Definition inserter_ump_2_slice_cell_homot : cell_slice_homot u₁ u₂ inserter_ump_2_slice_cell_cell. Proof. unfold cell_slice_homot, inserter_ump_2_slice_cell_cell ; cbn. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- rwhisker_rwhisker. use (vcomp_rcancel (lassociator _ _ _ ▹ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite <- rwhisker_rwhisker. rewrite (equifier_ump_cell_pr1 HE). rewrite (inserter_ump_cell_pr1 HI). rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. pose (pr2 ζ) as q. cbn in q. rewrite !lwhisker_id2, !id2_left in q. exact q. Qed. Definition inserter_ump_2_slice_cell : u₁ ==> u₂. Proof. use make_2cell_slice. - exact inserter_ump_2_slice_cell_cell. - exact inserter_ump_2_slice_cell_homot. Defined. Definition inserter_ump_2_slice_pr1 : inserter_ump_2_slice_cell ▹ inserter_slice_pr1 = ζ. Proof. use eq_2cell_slice ; cbn. unfold inserter_ump_2_slice_cell_cell. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- rwhisker_rwhisker. rewrite (equifier_ump_cell_pr1 HE). rewrite (inserter_ump_cell_pr1 HI). rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. End InserterUMP2Slice. Definition inserter_ump_2_slice : has_inserter_ump_2 cone. Proof. intros h u₁ u₂ ζ r. simple refine (_ ,, _). - exact (inserter_ump_2_slice_cell ζ r). - exact (inserter_ump_2_slice_pr1 ζ r). Defined. Definition inserter_ump_eq_slice : has_inserter_ump_eq cone. Proof. intros h u₁ u₂ ζ r φ₁ φ₂ s₁ s₂. use eq_2cell_slice. use (equifier_ump_eq HE). - use (inserter_ump_cell HI). + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _). + exact (inserter_ump_path_help ζ r). - use (inserter_ump_eq HI). + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _). + exact (inserter_ump_path_help ζ r). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply maponpaths_2. exact (maponpaths pr1 s₁). + apply (inserter_ump_cell_pr1 HI). - use (inserter_ump_eq HI). + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _). + exact (inserter_ump_path_help ζ r). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply maponpaths_2. exact (maponpaths pr1 s₂). + apply (inserter_ump_cell_pr1 HI). Qed. Definition inserter_ump_slice : has_inserter_ump cone := inserter_ump_1_slice ,, inserter_ump_2_slice ,, inserter_ump_eq_slice. End InsertersSlice. Definition inserters_in_slice_bicat {B : bicat} (ins_B : has_inserters B) (eq_B : has_equifiers B) (b : B) : has_inserters (slice_bicat b). Proof. intros h₁ h₂ α β. simple refine (_ ,, _ ,, _ ,, _). - exact (inserter_slice ins_B eq_B α β). - exact (inserter_slice_pr1 ins_B eq_B α β). - exact (inserter_slice_cell ins_B eq_B α β). - exact (inserter_ump_slice ins_B eq_B α β). Defined. (** 4. Equifiers *) Section EquifierSlice. Context {B : bicat} (b : B) {eq h₁ h₂ : slice_bicat b} {f₁ f₂ : h₁ --> h₂} (α β : f₁ ==> f₂) (e : eq --> h₁) (p : e ◃ α = e ◃ β) (cone := make_equifier_cone (pr1 eq) (pr1 e) (maponpaths pr1 p)) (H : has_equifier_ump cone). Section EquifierUMP1. Context (q : equifier_cone f₁ f₂ α β). Definition equifier_ump_1_slice_mor_mor : pr11 q --> pr1 eq := equifier_ump_mor H (pr1 (equifier_cone_pr1 q)) (maponpaths pr1 (equifier_cone_eq q)). Definition equifier_ump_1_slice_mor_inv2cell : invertible_2cell (pr21 q) (equifier_ump_1_slice_mor_mor · pr2 eq) := comp_of_invertible_2cell (pr2 (equifier_cone_pr1 q)) (inv_of_invertible_2cell (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (pr2 e)) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (rwhisker_of_invertible_2cell _ (equifier_ump_mor_pr1 H _ _))))). Definition equifier_ump_1_slice_mor : q --> eq. Proof. use make_1cell_slice. - exact equifier_ump_1_slice_mor_mor. - exact equifier_ump_1_slice_mor_inv2cell. Defined. Definition equifier_ump_1_slice_pr1_cell_cell : equifier_ump_1_slice_mor_mor · pr1 e ==> pr1 (equifier_cone_pr1 q) := equifier_ump_mor_pr1 H _ _. Definition equifier_ump_1_slice_pr1_cell_homot : cell_slice_homot (equifier_ump_1_slice_mor · e) (equifier_cone_pr1 q) equifier_ump_1_slice_pr1_cell_cell. Proof. unfold cell_slice_homot ; cbn. rewrite !vassocl. etrans. { do 3 apply maponpaths. refine (vassocr _ _ _ @ _). rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. refine (vassocr _ _ _ @ _). rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition equifier_ump_1_slice_pr1_cell : equifier_ump_1_slice_mor · e ==> equifier_cone_pr1 q. Proof. use make_2cell_slice. - exact equifier_ump_1_slice_pr1_cell_cell. - exact equifier_ump_1_slice_pr1_cell_homot. Defined. Definition equifier_ump_1_slice_pr1 : invertible_2cell (equifier_ump_1_slice_mor · e) (equifier_cone_pr1 q). Proof. use make_invertible_2cell. - exact equifier_ump_1_slice_pr1_cell. - use is_invertible_2cell_in_slice_bicat. apply property_from_invertible_2cell. Defined. End EquifierUMP1. Definition equifier_ump_1_in_slice : has_equifier_ump_1 (make_equifier_cone eq e p). Proof. intro q. use make_equifier_1cell. - exact (equifier_ump_1_slice_mor q). - exact (equifier_ump_1_slice_pr1 q). Defined. Section EquifierUMP2. Context {g : slice_bicat b} (u₁ u₂ : g --> eq) (γ : u₁ · e ==> u₂ · e). Definition equifier_ump_2_in_slice_cell_cell : pr1 u₁ ==> pr1 u₂ := equifier_ump_cell H (pr1 γ). Definition equifier_ump_2_in_slice_cell_path : cell_slice_homot u₁ u₂ equifier_ump_2_in_slice_cell_cell. Proof. unfold cell_slice_homot. unfold equifier_ump_2_in_slice_cell_cell. use (vcomp_rcancel ((_ ◃ pr12 e) • lassociator _ _ _)). { is_iso. apply property_from_invertible_2cell. } refine (_ @ pr2 γ) ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_rwhisker. do 2 apply maponpaths. apply (equifier_ump_cell_pr1 H). Qed. Definition equifier_ump_2_in_slice_cell : u₁ ==> u₂. Proof. use make_2cell_slice. - exact equifier_ump_2_in_slice_cell_cell. - exact equifier_ump_2_in_slice_cell_path. Defined. Definition equifier_ump_2_in_slice_pr1 : equifier_ump_2_in_slice_cell ▹ e = γ. Proof. use eq_2cell_slice ; cbn. apply (equifier_ump_cell_pr1 H). Qed. End EquifierUMP2. Definition equifier_ump_2_in_slice : has_equifier_ump_2 (make_equifier_cone eq e p) := λ g u₁ u₂ γ, equifier_ump_2_in_slice_cell u₁ u₂ γ ,, equifier_ump_2_in_slice_pr1 u₁ u₂ γ. Definition equifier_ump_eq_in_slice : has_equifier_ump_eq (make_equifier_cone eq e p). Proof. intros g u₁ u₂ γ φ₁ φ₂ q₁ q₂. use eq_2cell_slice. use (equifier_ump_eq H). - exact (pr1 γ). - exact (maponpaths pr1 q₁). - exact (maponpaths pr1 q₂). Qed. Definition equifier_ump_in_slice : has_equifier_ump (make_equifier_cone eq e p) := equifier_ump_1_in_slice ,, equifier_ump_2_in_slice ,, equifier_ump_eq_in_slice. End EquifierSlice. Definition equifiers_in_slice_bicat {B : bicat} (ins_B : has_equifiers B) (b : B) : has_equifiers (slice_bicat b). Proof. intros h₁ h₂ f₁ f₂ α β. pose (e := ins_B (pr1 h₁) (pr1 h₂) (pr1 f₁) (pr1 f₂) (pr1 α) (pr1 β)). simple refine (make_ob_slice (pr12 e · pr2 h₁) ,, make_1cell_slice _ _ ,, _ ,, _). - exact (pr12 e). - apply id2_invertible_2cell. - abstract (use eq_2cell_slice ; cbn ; exact (pr122 e)). - apply equifier_ump_in_slice. exact (pr222 e). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Examples/SubbicatLimits.v000066400000000000000000000307411451125700300254050ustar00rootroot00000000000000(********************************************************************************** Limits in subbicategories We look at limits in subbicategories where 0-cells and 1-cells are selected. These can be constructed from limits in the original bicategory if some conditions are satisfied. 1. Final objects 2. Products 3. Pullbacks 4. Eilenberg-Moore categories **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. Section LimitsSubbicat. Context {B : bicat} (P₀ : B → UU) (P₁ : ∏ (x y : B), P₀ x → P₀ y → x --> y → UU) (Pid : ∏ (x : B) (Px : P₀ x), P₁ x x Px Px (id₁ x)) (Pcomp : ∏ (x y z : B) (Px : P₀ x) (Py : P₀ y) (Pz : P₀ z) (f : x --> y) (g : y --> z), P₁ x y Px Py f → P₁ y z Py Pz g → P₁ x z Px Pz (f · g)). Definition subbicat_disp_2cell_over {x y : B} {f g : x --> y} (α : f ==> g) {xx : disp_subbicat P₀ P₁ Pid Pcomp x} {yy : disp_subbicat P₀ P₁ Pid Pcomp y} {ff : xx -->[ f ] yy} {gg : xx -->[ g] yy} : ff ==>[ α ] gg := tt ,, tt. (** 1. Final objects *) Definition subbicat_disp_final (HB : bifinal_obj B) (P_final : P₀ (pr1 HB)) (P_mor : ∏ (x : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (pr12 x) P_final (is_bifinal_1cell_property (pr2 HB) (pr1 x))) : disp_bifinal_obj (disp_subbicat P₀ P₁ Pid Pcomp) HB. Proof. simple refine (_ ,, _). - exact (P_final ,, tt). - exact (λ x xx, tt ,, P_mor (x ,, xx)). Defined. Definition subbicat_final (HB : bifinal_obj B) (P_final : P₀ (pr1 HB)) (P_mor : ∏ (x : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (pr12 x) P_final (is_bifinal_1cell_property (pr2 HB) (pr1 x))) : bifinal_obj (subbicat P₀ P₁ Pid Pcomp). Proof. use total_bicat_final. - apply disp_2cells_isaprop_subbicat. - intros. apply subbicat_disp_2cell_over. - exact HB. - exact (subbicat_disp_final HB P_final P_mor). Defined. (** 2. Products *) Definition subbicat_disp_binprod (HB : has_binprod B) (Hcone : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₀ (pr1 (HB (pr1 x) (pr1 y)))) (Hπ₁ : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (Hcone x y) (pr12 x) (binprod_cone_pr1 (pr1 (HB (pr1 x) (pr1 y))))) (Hπ₂ : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (Hcone x y) (pr12 y) (binprod_cone_pr2 (pr1 (HB (pr1 x) (pr1 y))))) (Hpair : ∏ (x y : subbicat P₀ P₁ Pid Pcomp) (q : binprod_cone x y), P₁ _ _ (pr121 q) (Hcone x y) (binprod_ump_1cell (pr2 (HB (pr1 x) (pr1 y))) (pr1 (binprod_cone_pr1 q)) (pr1 (binprod_cone_pr2 q)))) : disp_has_binprod (disp_subbicat P₀ P₁ Pid Pcomp) HB. Proof. intros x y. simple refine (_ ,, _ ,, _ ,, _). - exact (Hcone x y ,, tt). - exact (tt ,, Hπ₁ x y). - exact (tt ,, Hπ₂ x y). - exact (λ z f g, tt ,, Hpair x y (make_binprod_cone z f g)). Defined. Definition subbicat_binprod (HB : has_binprod B) (HB' : is_univalent_2 B) (Hcone : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₀ (pr1 (HB (pr1 x) (pr1 y)))) (Hπ₁ : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (Hcone x y) (pr12 x) (binprod_cone_pr1 (pr1 (HB (pr1 x) (pr1 y))))) (Hπ₂ : ∏ (x y : subbicat P₀ P₁ Pid Pcomp), P₁ _ _ (Hcone x y) (pr12 y) (binprod_cone_pr2 (pr1 (HB (pr1 x) (pr1 y))))) (Hpair : ∏ (x y : subbicat P₀ P₁ Pid Pcomp) (q : binprod_cone x y), P₁ _ _ (pr121 q) (Hcone x y) (binprod_ump_1cell (pr2 (HB (pr1 x) (pr1 y))) (pr1 (binprod_cone_pr1 q)) (pr1 (binprod_cone_pr2 q)))) : has_binprod (subbicat P₀ P₁ Pid Pcomp). Proof. use total_bicat_prod. - apply disp_2cells_isaprop_subbicat. - intros. apply subbicat_disp_2cell_over. - use disp_locally_groupoid_subbicat. exact HB'. - exact HB. - use (subbicat_disp_binprod HB Hcone). + exact Hπ₁. + exact Hπ₂. + exact Hpair. Defined. (** 3. Pullbacks *) Definition subbicat_disp_has_pb (HB : has_pb B) (Hcone : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₀ (pr1 (HB _ _ _ (pr1 f) (pr1 g)))) (Hπ₁ : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₁ _ _ (Hcone x y z f g) (pr12 x) (pb_cone_pr1 (pr1 (HB _ _ _ (pr1 f) (pr1 g))))) (Hπ₂ : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₁ _ _ (Hcone x y z f g) (pr12 y) (pb_cone_pr2 (pr1 (HB _ _ _ (pr1 f) (pr1 g))))) (H_ump_mor : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z) (q : pb_cone f g), P₁ _ _ (pr121 q) (Hcone x y z f g) (pb_ump_mor (pr2 (HB (pr1 x) (pr1 y) (pr1 z) (pr1 f) (pr1 g))) (total_pb_cone_help_cone _ q))) : disp_has_pb (disp_subbicat P₀ P₁ Pid Pcomp) HB. Proof. intros x y z f g. simple refine (_ ,, _ ,, _ ,, _). - exact (Hcone x y z f g ,, tt). - exact (tt ,, Hπ₁ x y z f g). - exact (tt ,, Hπ₂ x y z f g). - exact (λ q, tt ,, H_ump_mor x y z f g q). Defined. Definition subbicat_has_pb (HB : has_pb B) (HB' : is_univalent_2 B) (Hcone : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₀ (pr1 (HB _ _ _ (pr1 f) (pr1 g)))) (Hπ₁ : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₁ _ _ (Hcone x y z f g) (pr12 x) (pb_cone_pr1 (pr1 (HB _ _ _ (pr1 f) (pr1 g))))) (Hπ₂ : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z), P₁ _ _ (Hcone x y z f g) (pr12 y) (pb_cone_pr2 (pr1 (HB _ _ _ (pr1 f) (pr1 g))))) (H_ump_mor : ∏ (x y z : subbicat P₀ P₁ Pid Pcomp) (f : x --> z) (g : y --> z) (q : pb_cone f g), P₁ _ _ (pr121 q) (Hcone x y z f g) (pb_ump_mor (pr2 (HB (pr1 x) (pr1 y) (pr1 z) (pr1 f) (pr1 g))) (total_pb_cone_help_cone _ q))) : has_pb (subbicat P₀ P₁ Pid Pcomp). Proof. use total_bicat_has_pb. - apply disp_2cells_isaprop_subbicat. - intros. apply subbicat_disp_2cell_over. - use disp_locally_groupoid_subbicat. exact HB'. - exact HB. - apply (subbicat_disp_has_pb HB Hcone). + exact Hπ₁. + exact Hπ₂. + exact H_ump_mor. Defined. (** 4. Eilenberg-Moore objects *) Definition subbicat_disp_has_em (HB : bicat_has_em B) (Hcone : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))), P₀ (pr11 (HB (pr1_of_mnd_total_bicat m)))) (Hmor : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))), P₁ _ _ (Hcone m) (pr121 m) (mor_of_mnd_mor (mor_of_em_cone _ (pr1 (HB (pr1_of_mnd_total_bicat m)))))) (Hump : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))) (q : em_cone m), P₁ _ _ (pr121 q) (Hcone m) (em_ump_1_mor (pr1_of_mnd_total_bicat m) (pr2 (HB (pr1_of_mnd_total_bicat m))) (pr1_of_em_cone (disp_subbicat P₀ P₁ Pid Pcomp) m q))) : disp_has_em (disp_subbicat P₀ P₁ Pid Pcomp) HB. Proof. intro m. simple refine (_ ,, _ ,, _ ,, _). - exact (Hcone m ,, tt). - exact (tt ,, Hmor m). - exact (tt ,, tt). - exact (λ q, tt ,, Hump m q). Defined. Definition subbicat_has_em (HB : bicat_has_em B) (HB' : is_univalent_2 B) (Hcone : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))), P₀ (pr11 (HB (pr1_of_mnd_total_bicat m)))) (Hmor : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))), P₁ _ _ (Hcone m) (pr121 m) (mor_of_mnd_mor (mor_of_em_cone _ (pr1 (HB (pr1_of_mnd_total_bicat m)))))) (Hump : ∏ (m : mnd (total_bicat (disp_subbicat P₀ P₁ Pid Pcomp))) (q : em_cone m), P₁ _ _ (pr121 q) (Hcone m) (em_ump_1_mor (pr1_of_mnd_total_bicat m) (pr2 (HB (pr1_of_mnd_total_bicat m))) (pr1_of_em_cone (disp_subbicat P₀ P₁ Pid Pcomp) m q))) : bicat_has_em (subbicat P₀ P₁ Pid Pcomp). Proof. use total_bicat_has_em. - apply disp_2cells_isaprop_subbicat. - intros. apply subbicat_disp_2cell_over. - use disp_locally_groupoid_subbicat. exact HB'. - exact HB. - apply (subbicat_disp_has_em HB Hcone). + exact Hmor. + exact Hump. Defined. End LimitsSubbicat. UniMath-20231010/UniMath/Bicategories/Limits/Examples/TotalBicategoryLimits.v000066400000000000000000000503101451125700300267370ustar00rootroot00000000000000(***************************************************************************** Limits in the total bicategory We consider one way to construct limits in the total bicategory. For this construction, we assume that all displayed 2-cells are invertible and that the types of displayed invertible 2-cells over some 2-cell is contractible. Contents 1. Final objects 2. Products 3. Pullbacks 4. Eilenberg-Moore objects *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. Section LimitsTotalBicat. Context {B : bicat} (D : disp_bicat B) (HD₁ : disp_2cells_isaprop D) (HD₂ : ∏ (x y : B) (f g : x --> y) (α : f ==> g) (xx : D x) (yy : D y) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy), ff ==>[ α ] gg) (HD₃ : disp_locally_groupoid D). Definition is_invertible_in_total {x y : total_bicat D} {f g : x --> y} {α : f ==> g} (Hα : is_invertible_2cell (pr1 α)) : is_invertible_2cell α. Proof. use is_invertible_disp_to_total. refine (Hα ,, _). exact (HD₃ (pr1 x) (pr1 y) (pr1 f) (pr1 g) (pr1 α ,, Hα) (pr2 x) (pr2 y) (pr2 f) (pr2 g) (pr2 α)). Defined. Definition invertible_in_total {x y : total_bicat D} {f g : x --> y} (α : invertible_2cell (pr1 f) (pr1 g)) : invertible_2cell f g. Proof. use make_invertible_2cell. - refine (pr1 α ,, _). apply HD₂. - use is_invertible_in_total. apply property_from_invertible_2cell. Defined. (** 1. Final objects *) Definition disp_bifinal_obj (HB : bifinal_obj B) : UU := ∑ (i : D (pr1 HB)), ∏ (x : B) (xx : D x), xx -->[ is_bifinal_1cell_property (pr2 HB) x ] i. Definition total_bicat_final (HB : bifinal_obj B) (HD₄ : disp_bifinal_obj HB) : bifinal_obj (total_bicat D). Proof. simple refine (_ ,, _). - exact (pr1 HB ,, pr1 HD₄). - use make_is_bifinal. + exact (λ x, is_bifinal_1cell_property (pr2 HB) (pr1 x) ,, pr2 HD₄ (pr1 x) (pr2 x)). + refine (λ x f g, is_bifinal_2cell_property (pr2 HB) _ (pr1 f) (pr1 g) ,, _). apply HD₂. + abstract (intros x f g α β ; use subtypePath ; [ intro ; apply HD₁ | ] ; apply (is_bifinal_eq_property (pr2 HB))). Defined. Definition disp_bifinal_obj_stronger (HB : bifinal_obj B) : UU := ∑ (i : D (pr1 HB)) (j : ∏ (x : B) (xx : D x), xx -->[ is_bifinal_1cell_property (pr2 HB) x ] i), ∏ (x : B)(xx : D x)(f g : x --> pr1 HB)(ff : xx -->[f] i)(gg : xx -->[g] i), ff ==>[ is_bifinal_2cell_property (pr2 HB) x f g] gg. Definition total_bicat_final_stronger (HB : bifinal_obj B) (HD₄ : disp_bifinal_obj_stronger HB) : bifinal_obj (total_bicat D). Proof. simple refine (_ ,, _). - exact (pr1 HB ,, pr1 HD₄). - use make_is_bifinal. + exact (λ x, is_bifinal_1cell_property (pr2 HB) (pr1 x) ,, pr12 HD₄ (pr1 x) (pr2 x)). + refine (λ x f g, is_bifinal_2cell_property (pr2 HB) _ (pr1 f) (pr1 g) ,, _). apply (pr22 HD₄). + abstract (intros x f g α β ; use subtypePath ; [ intro ; apply HD₁ | ] ; apply (is_bifinal_eq_property (pr2 HB))). Defined. (** 2. Products *) Definition disp_has_binprod (HB : has_binprod B) : UU := ∏ (x y : total_bicat D), let p_cone : binprod_cone (pr1 x) (pr1 y) := pr1 (HB (pr1 x) (pr1 y)) in let Hp_cone : has_binprod_ump p_cone := pr2 (HB (pr1 x) (pr1 y)) in ∑ (prod : D (binprod_cone_obj p_cone)), prod -->[ binprod_cone_pr1 p_cone ] pr2 x × prod -->[ binprod_cone_pr2 p_cone ] pr2 y × ∏ (z : total_bicat D) (f : z --> x) (g : z --> y), pr2 z -->[ binprod_ump_1cell Hp_cone (pr1 f) (pr1 g) ] prod. Section TotalBicatProd. Context (HB : has_binprod B) (x y : total_bicat D) (HD₄ : disp_has_binprod HB). Let p_cone : binprod_cone (pr1 x) (pr1 y) := pr1 (HB (pr1 x) (pr1 y)). Let Hp_cone : has_binprod_ump p_cone := pr2 (HB (pr1 x) (pr1 y)). Definition total_bicat_prod_cone : binprod_cone x y. Proof. use make_binprod_cone. - exact (binprod_cone_obj p_cone ,, pr1 (HD₄ x y)). - exact (binprod_cone_pr1 p_cone ,, pr12 (HD₄ x y)). - exact (binprod_cone_pr2 p_cone ,, pr122 (HD₄ x y)). Defined. Definition total_bicat_binprod_ump_1 : binprod_ump_1 total_bicat_prod_cone. Proof. intro q. use make_binprod_1cell. - simple refine (_ ,, _). + exact (binprod_ump_1cell Hp_cone (pr1 (binprod_cone_pr1 q)) (pr1 (binprod_cone_pr2 q))). + exact (pr222 (HD₄ x y) _ (binprod_cone_pr1 q) (binprod_cone_pr2 q)). - use invertible_in_total. apply binprod_ump_1cell_pr1. - use invertible_in_total. apply binprod_ump_1cell_pr2. Defined. Definition total_bicat_binprod_ump_2 : has_binprod_ump_2_cell total_bicat_prod_cone. Proof. intros z φ ψ α β. simple refine (_ ,, _). - exact (binprod_ump_2cell Hp_cone (pr1 α) (pr1 β)). - apply HD₂. Defined. End TotalBicatProd. Definition total_bicat_prod (HB : has_binprod B) (HD₄ : disp_has_binprod HB) : has_binprod (total_bicat D). Proof. intros x y. simple refine (_ ,, _). - exact (total_bicat_prod_cone HB x y HD₄). - use make_binprod_ump. + exact (total_bicat_binprod_ump_1 HB x y HD₄). + exact (total_bicat_binprod_ump_2 HB x y HD₄). + abstract (intros z φ ψ α β ; use subtypePath ; [ intro ; apply HD₁ | ] ; apply binprod_ump_2cell_pr1). + abstract (intros z φ ψ α β ; use subtypePath ; [ intro ; apply HD₁ | ] ; apply binprod_ump_2cell_pr2). + abstract (intros z φ ψ α β γ δ p₁ p₂ q₁ q₂ ; use subtypePath ; [ intro ; apply HD₁ | ] ; exact (binprod_ump_2cell_unique (pr2 (HB (pr1 x) (pr1 y))) (pr1 α) (pr1 β) _ _ (maponpaths pr1 p₁) (maponpaths pr1 p₂) (maponpaths pr1 q₁) (maponpaths pr1 q₂))). Defined. (** 3. Pullbacks *) Definition total_pb_cone_help_cone {x y z : total_bicat D} {f : x --> z} {g : y --> z} (q : pb_cone f g) : pb_cone (pr1 f) (pr1 g) := make_pb_cone _ (pr1 (pb_cone_pr1 q)) (pr1 (pb_cone_pr2 q)) (make_invertible_2cell (pr1_invertible_2cell_total _ (pb_cone_cell q))). Definition disp_has_pb (HB : has_pb B) : UU := ∏ (x y z : total_bicat D) (f : x --> z) (g : y --> z), let p_cone : pb_cone (pr1 f) (pr1 g) := pr1 (HB _ _ _ (pr1 f) (pr1 g)) in let Hp_cone : has_pb_ump p_cone := pr2 (HB _ _ _ (pr1 f) (pr1 g)) in ∑ (pb : D (pb_cone_obj p_cone)), pb -->[ pb_cone_pr1 p_cone ] pr2 x × pb -->[ pb_cone_pr2 p_cone ] pr2 y × ∏ (q : pb_cone f g), pr21 q -->[ pb_ump_mor Hp_cone (total_pb_cone_help_cone q) ] pb. Section TotalBicatPullback. Context (HB : has_pb B) (HD₄ : disp_has_pb HB) {x y z : total_bicat D} (f : x --> z) (g : y --> z). Let p_cone : pb_cone (pr1 f) (pr1 g) := pr1 (HB _ _ _ (pr1 f) (pr1 g)). Let Hp_cone : has_pb_ump p_cone := pr2 (HB _ _ _ (pr1 f) (pr1 g)). Definition total_pb_cone : pb_cone f g. Proof. use make_pb_cone. - exact (pb_cone_obj p_cone ,, pr1 (HD₄ x y z f g)). - exact (pb_cone_pr1 p_cone ,, pr12 (HD₄ x y z f g)). - exact (pb_cone_pr2 p_cone ,, pr122 (HD₄ x y z f g)). - apply invertible_in_total. exact (pb_cone_cell p_cone). Defined. Section UMP1. Context (q : pb_cone f g). Definition total_pb_cone_ump1 : pb_1cell q total_pb_cone. Proof. use make_pb_1cell. - exact (pb_ump_mor Hp_cone (total_pb_cone_help_cone q) ,, pr222 (HD₄ x y z f g) q). - use invertible_in_total. exact (pb_ump_mor_pr1 Hp_cone (total_pb_cone_help_cone q)). - use invertible_in_total. exact (pb_ump_mor_pr2 Hp_cone (total_pb_cone_help_cone q)). - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; exact (pb_ump_mor_cell Hp_cone (total_pb_cone_help_cone q))). Defined. End UMP1. Section UMP2. Context {w : total_bicat D} (φ ψ : w --> total_pb_cone) (α : φ · pb_cone_pr1 total_pb_cone ==> ψ · pb_cone_pr1 total_pb_cone) (β : φ · pb_cone_pr2 total_pb_cone ==> ψ · pb_cone_pr2 total_pb_cone) (p : (φ ◃ pb_cone_cell total_pb_cone) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ pb_cone_cell total_pb_cone)). Definition total_pb_cone_unique : isaprop (∑ (γ : φ ==> ψ), γ ▹ pb_cone_pr1 total_pb_cone = α × γ ▹ pb_cone_pr2 total_pb_cone = β). Proof. use invproofirrelevance. intros γ₁ γ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use subtypePath. { intro. apply HD₁. } exact (pb_ump_eq Hp_cone (pr1 φ) (pr1 ψ) (pr1 α) (pr1 β) (maponpaths pr1 p) _ _ (maponpaths pr1 (pr12 γ₁)) (maponpaths pr1 (pr22 γ₁)) (maponpaths pr1 (pr12 γ₂)) (maponpaths pr1 (pr22 γ₂))). Qed. Definition total_pb_cone_ump2 : ∑ (γ : φ ==> ψ), γ ▹ pb_cone_pr1 total_pb_cone = α × γ ▹ pb_cone_pr2 total_pb_cone = β. Proof. simple refine (_ ,, _ ,, _). - simple refine (_ ,, _). + exact (pb_ump_cell Hp_cone (pr1 φ) (pr1 ψ) (pr1 α) (pr1 β) (maponpaths pr1 p)). + apply HD₂. - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; apply pb_ump_cell_pr1). - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; apply pb_ump_cell_pr2). Defined. Definition total_pb_cone_ump2_unique : ∃! (γ : φ ==> ψ), γ ▹ pb_cone_pr1 total_pb_cone = α × γ ▹ pb_cone_pr2 total_pb_cone = β. Proof. use iscontraprop1. - exact total_pb_cone_unique. - exact total_pb_cone_ump2. Defined. End UMP2. End TotalBicatPullback. Definition total_bicat_has_pb (HB : has_pb B) (HD₄ : disp_has_pb HB) : has_pb (total_bicat D). Proof. intros x y z f g. simple refine (_ ,, _). - exact (total_pb_cone HB HD₄ f g). - simple refine (_ ,, _). + intro q. apply total_pb_cone_ump1. + simpl. intros w φ ψ α β p. apply total_pb_cone_ump2_unique. exact p. Defined. (** 4. Eilenberg-Moore objects *) Definition pr1_of_em_cone (m : mnd (total_bicat D)) (q : em_cone m) : em_cone (pr1_of_mnd_total_bicat m). Proof. use make_em_cone. - exact (pr11 q). - exact (pr1 (mor_of_mnd_mor (mor_of_em_cone _ q))). - exact (pr1 (mnd_mor_endo (mor_of_em_cone _ q))). - abstract (refine (_ @ maponpaths pr1 (mnd_mor_unit (mor_of_em_cone _ q))) ; cbn ; rewrite id2_rwhisker, id2_right ; apply idpath). - abstract (refine (_ @ maponpaths pr1 (mnd_mor_mu (mor_of_em_cone _ q))) ; cbn ; rewrite !vassocl ; do 2 apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lunitor_triangle ; rewrite <- vcomp_lunitor ; rewrite !vassocl ; rewrite lunitor_triangle ; apply idpath). Defined. Definition disp_has_em (HB : bicat_has_em B) : UU := ∏ (m : mnd (total_bicat D)), let cone := pr1 (HB (pr1_of_mnd_total_bicat m)) in let ump := pr2 (HB (pr1_of_mnd_total_bicat m)) in ∑ (dob : D (pr1 cone)) (dmor : dob -->[ mor_of_mnd_mor (mor_of_em_cone (pr1_of_mnd_total_bicat m) cone) ] pr2 (ob_of_mnd m)) (dcell : dmor ;; pr2 (endo_of_mnd m) ==>[ mnd_mor_endo (mor_of_em_cone (pr1_of_mnd_total_bicat m) cone) ] id_disp _ ;; dmor), ∏ (q : em_cone m), pr21 q -->[ em_ump_1_mor _ ump (pr1_of_em_cone _ q) ] dob. Section TotalBicatEilenbergMoore. Context (HB : bicat_has_em B) (m : mnd (total_bicat D)) (HD : disp_has_em HB). Let cone : em_cone (pr1_of_mnd_total_bicat m) := pr1 (HB (pr1_of_mnd_total_bicat m)). Let ump : has_em_ump _ cone := pr2 (HB (pr1_of_mnd_total_bicat m)). Definition total_em_cone : em_cone m. Proof. use make_em_cone. - exact (pr1 cone ,, pr1 (HD m)). - exact (mor_of_mnd_mor (mor_of_em_cone _ cone) ,, pr12 (HD m)). - refine (mnd_mor_endo (mor_of_em_cone _ cone) ,, _). cbn. apply (pr2 (HD m)). - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; refine (_ @ mnd_mor_unit (mor_of_em_cone _ cone)) ; cbn ; rewrite id2_rwhisker ; rewrite id2_right ; apply idpath). - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; refine (_ @ mnd_mor_mu (mor_of_em_cone _ cone)) ; cbn ; rewrite !vassocl ; do 2 apply maponpaths ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite lunitor_triangle ; rewrite <- vcomp_lunitor ; rewrite !vassocl ; rewrite lunitor_triangle ; apply idpath). Defined. Section UMP1. Context (q : em_cone m). Definition total_has_em_ump_1_mor : q --> total_em_cone := em_ump_1_mor _ ump (pr1_of_em_cone _ q) ,, pr222 (HD m) q. Definition total_has_em_ump_1_mor_cell : # (mnd_incl (total_bicat D)) total_has_em_ump_1_mor · mor_of_em_cone m total_em_cone ==> mor_of_em_cone m q. Proof. use make_mnd_cell. - simple refine (_ ,, _). + exact (pr11 (em_ump_1_inv2cell _ ump (pr1_of_em_cone _ q))). + apply HD₂. - abstract (use subtypePath ; [ intro ; apply HD₁ | ] ; apply (mnd_cell_endo (pr1 (em_ump_1_inv2cell _ ump (pr1_of_em_cone _ q))))). Defined. Definition total_has_em_ump_1_mor_is_invertible : is_invertible_2cell total_has_em_ump_1_mor_cell. Proof. use is_invertible_mnd_2cell. use is_invertible_in_total. exact (from_invertible_mnd_2cell (em_ump_1_inv2cell (pr1_of_mnd_total_bicat m) ump (pr1_of_em_cone m q))). Defined. End UMP1. Definition total_has_em_ump_1 : em_ump_1 m total_em_cone. Proof. intro q. use make_em_cone_mor. - exact (total_has_em_ump_1_mor q). - use make_invertible_2cell. + exact (total_has_em_ump_1_mor_cell q). + exact (total_has_em_ump_1_mor_is_invertible q). Defined. Section UMP2. Context {x : total_bicat D} {g₁ g₂ : x --> total_em_cone} (α : # (mnd_incl (total_bicat D)) g₁ · mor_of_em_cone m total_em_cone ==> # (mnd_incl (total_bicat D)) g₂ · mor_of_em_cone m total_em_cone). Local Definition total_has_em_ump_2_cell : # (mnd_incl B) (pr1 g₁) · mor_of_em_cone (pr1_of_mnd_total_bicat m) cone ==> # (mnd_incl B) (pr1 g₂) · mor_of_em_cone (pr1_of_mnd_total_bicat m) cone. Proof. use make_mnd_cell. - exact (pr1 (cell_of_mnd_cell α)). - exact (maponpaths pr1 (mnd_cell_endo α)). Defined. Definition total_has_em_ump_unique : isaprop (∑ (β : g₁ ==> g₂), ## (mnd_incl (total_bicat D)) β ▹ mor_of_em_cone m total_em_cone = α). Proof. use invproofirrelevance. intros β₁ β₂. use subtypePath ; [ intro ; apply cellset_property | ]. use subtypePath ; [ intro ; apply HD₁ | ]. use (em_ump_eq _ ump). - exact total_has_em_ump_2_cell. - use eq_mnd_cell. exact (maponpaths (λ z, pr11 z) (pr2 β₁)). - use eq_mnd_cell. exact (maponpaths (λ z, pr11 z) (pr2 β₂)). Qed. End UMP2. Definition total_has_em_ump_2 : em_ump_2 m total_em_cone. Proof. intros x g₁ g₂ α. use iscontraprop1. - exact (total_has_em_ump_unique α). - simple refine ((_ ,, _) ,, _). + use (em_ump_2_cell _ ump). exact (total_has_em_ump_2_cell α). + apply HD₂. + abstract (use eq_mnd_cell ; use subtypePath ; [ intro ; apply HD₁ | ] ; exact (maponpaths pr1 (em_ump_2_eq _ ump (total_has_em_ump_2_cell α)))). Defined. Definition total_has_em_ump : has_em_ump m total_em_cone. Proof. split. - exact total_has_em_ump_1. - exact total_has_em_ump_2. Defined. End TotalBicatEilenbergMoore. Definition total_bicat_has_em (HB : bicat_has_em B) (HD : disp_has_em HB) : bicat_has_em (total_bicat D). Proof. intros m. refine (total_em_cone HB m HD ,, _). apply total_has_em_ump. Defined. End LimitsTotalBicat. UniMath-20231010/UniMath/Bicategories/Limits/Examples/UnivGroupoidsLimits.v000066400000000000000000000122171451125700300264640ustar00rootroot00000000000000(********************************************************************* Limits of univalent groupoids 1. Pullbacks *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.Groupoids. Require Import UniMath.Bicategories.Limits.Pullbacks. Open Scope cat. (** 1. Pullbacks *) Definition grpds_iso_comma_pb_cone {C₁ C₂ C₃ : grpds} (F : C₁ --> C₃) (G : C₂ --> C₃) : pb_cone F G. Proof. use make_pb_cone. - exact (univalent_iso_comma (pr1 F) (pr1 G) ,, is_pregroupoid_iso_comma _ _ (pr2 C₁) (pr2 C₂)). - refine (_ ,, tt). apply iso_comma_pr1. - refine (_ ,, tt). apply iso_comma_pr2. - use make_invertible_2cell. + refine (_ ,, tt). apply iso_comma_commute. + apply locally_groupoid_grpds. Defined. Section IsoCommaUMP. Context {C₁ C₂ C₃ : grpds} (F : C₁ --> C₃) (G : C₂ --> C₃). Definition pb_ump_1_grpds_iso_comma : pb_ump_1 (grpds_iso_comma_pb_cone F G). Proof. intro q. use make_pb_1cell. - refine (_ ,, tt). use iso_comma_ump1. + exact (pr1 (pb_cone_pr1 q)). + exact (pr1 (pb_cone_pr2 q)). + exact (grpds_2cell_to_nat_z_iso (pr1 (pb_cone_cell q))). - use make_invertible_2cell. + refine (_ ,, tt). apply iso_comma_ump1_pr1. + apply locally_groupoid_grpds. - use make_invertible_2cell. + refine (_ ,, tt). apply iso_comma_ump1_pr2. + apply locally_groupoid_grpds. - abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; unfold pb_cone_cell ; rewrite (functor_on_inv_from_z_iso (pr1 G)) ; rewrite (functor_id (pr1 F)) ; rewrite !id_left, id_right ; refine (!(id_right _) @ _) ; apply maponpaths ; use inv_z_iso_unique' ; unfold precomp_with ; cbn ; rewrite id_right ; apply functor_id). Defined. Section CellUMP. Let p := grpds_iso_comma_pb_cone F G. Context {q : grpds} (φ ψ : q --> p) (α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p) (β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p) (r : (φ ◃ pb_cone_cell p) • lassociator _ _ _ • (β ▹ G) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ F) • rassociator _ _ _ • (ψ ◃ pb_cone_cell p)). Definition pb_ump_2_grpds_nat_trans : φ ==> ψ. Proof. refine (_ ,, tt). use (iso_comma_ump2 _ _ _ _ (pr1 α) (pr1 β)). abstract (intros x ; pose (nat_trans_eq_pointwise (maponpaths pr1 r) x) as z ; cbn in z ; unfold iso_comma_commute_nat_trans_data in z ; rewrite !id_left, !id_right in z ; exact z). Defined. Definition pb_ump_2_grpds_nat_trans_pr1 : pb_ump_2_grpds_nat_trans ▹ pb_cone_pr1 _ = α. Proof. use subtypePath ; [ intro ; apply isapropunit | ]. apply iso_comma_ump2_pr1. Qed. Definition pb_ump_2_grpds_nat_trans_pr2 : pb_ump_2_grpds_nat_trans ▹ _ = β. Proof. use subtypePath ; [ intro ; apply isapropunit | ]. apply iso_comma_ump2_pr2. Qed. End CellUMP. Definition pb_ump_2_grpds_iso_comma : pb_ump_2 (grpds_iso_comma_pb_cone F G). Proof. intros C φ ψ α β r. use iscontraprop1. - abstract (use invproofirrelevance ; intros τ₁ τ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use subtypePath ; [ intro ; apply isapropunit | ] ; exact (iso_comma_ump_eq _ _ _ _ _ _ (maponpaths pr1 (pr12 τ₁)) (maponpaths pr1 (pr22 τ₁)) (maponpaths pr1 (pr12 τ₂)) (maponpaths pr1 (pr22 τ₂)))). - simple refine (_ ,, _). + exact (pb_ump_2_grpds_nat_trans φ ψ α β r). + split. * exact (pb_ump_2_grpds_nat_trans_pr1 φ ψ α β r). * exact (pb_ump_2_grpds_nat_trans_pr2 φ ψ α β r). Defined. Definition grpds_iso_comma_has_pb_ump : has_pb_ump (grpds_iso_comma_pb_cone F G). Proof. split. - exact pb_ump_1_grpds_iso_comma. - exact pb_ump_2_grpds_iso_comma. Defined. End IsoCommaUMP. Definition has_pb_grpds : has_pb grpds. Proof. intros C₁ C₂ C₃ F G. simple refine (_ ,, _). - exact (grpds_iso_comma_pb_cone F G). - exact (grpds_iso_comma_has_pb_ump F G). Defined. UniMath-20231010/UniMath/Bicategories/Limits/Final.v000066400000000000000000000335351451125700300217460ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bifinal object in a bicategory Niccolò Veltri, Niels van der Weide April 2019 Marco Maggesi, July 2019 Contents: 1. Definition of bifinal objects 2. Representable definition of bifinal objects 3. Equivalence between the two definitions 4. Bicategories with bifinal objects 5. Bifinal objects are unique 6. Being bifinal is preserved under equivalence ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope bicategory_scope. Local Open Scope cat. Section Final. Context {B : bicat}. (** 1. Definition of bifinal objects *) Definition bifinal_1cell_property (X : B) : UU := ∏ (Y : B), Y --> X. Definition bifinal_2cell_property (X Y : B) : UU := ∏ (f g : Y --> X), f ==> g. Definition bifinal_eq_property (X Y : B) : UU := ∏ (f g : Y --> X) (α β : f ==> g), α = β. Definition is_bifinal (X : B) := bifinal_1cell_property X × ∏ (Y : B), bifinal_2cell_property X Y × bifinal_eq_property X Y. Definition is_bifinal_1cell_property {X : B} (HX : is_bifinal X) : bifinal_1cell_property X := pr1 HX. Definition is_bifinal_2cell_property {X : B} (HX : is_bifinal X) (Y : B) : bifinal_2cell_property X Y := pr1 (pr2 HX Y). Definition is_bifinal_eq_property {X : B} (HX : is_bifinal X) (Y : B) : bifinal_eq_property X Y := pr2 (pr2 HX Y). Definition is_bifinal_invertible_2cell_property {X : B} (HX : is_bifinal X) {Y : B} (f g : Y --> X) : invertible_2cell f g. Proof. use make_invertible_2cell. - apply (is_bifinal_2cell_property HX Y). - use make_is_invertible_2cell. + apply (is_bifinal_2cell_property HX Y). + apply (is_bifinal_eq_property HX Y). + apply (is_bifinal_eq_property HX Y). Defined. Definition make_is_bifinal (X : B) (H1 : bifinal_1cell_property X) (H2 : ∏ (Y : B), bifinal_2cell_property X Y) (H3 : ∏ (Y : B), bifinal_eq_property X Y) : is_bifinal X. Proof. refine (H1,, _). intro Y. exact (H2 Y,, H3 Y). Defined. Definition isaprop_bifinal_2cell_property {X Y : B} (H : bifinal_eq_property X Y) : isaprop (bifinal_2cell_property X Y). Proof. apply impred ; intro f. apply impred ; intro g. use invproofirrelevance. intros α β. apply H. Qed. Definition isaprop_bifinal_eq_property (X Y : B) : isaprop (bifinal_eq_property X Y). Proof. repeat (apply impred ; intro). apply cellset_property. Qed. Definition isaprop_is_bifinal (H : is_univalent_2_1 B) (X : B) : isaprop (is_bifinal X). Proof. apply invproofirrelevance. intros x y. induction x as [f Hf]. induction y as [g Hg]. use subtypePath. - intro ; simpl. apply impred ; intro Y. apply isapropdirprod. + apply isaprop_bifinal_2cell_property. apply Hf. + apply isaprop_bifinal_eq_property. - simpl. apply funextsec ; intro Y. apply (isotoid_2_1 H). apply (is_bifinal_invertible_2cell_property (f ,, Hf)). Qed. (** 2. Representable definition of bifinal objects *) Definition is_bifinal_repr (X : B) : UU := ∏ (Y : B), adj_equivalence_of_cats (functor_to_unit (hom Y X)). Definition isaprop_is_bifinal_repr (H : is_univalent_2_1 B) (X : B) : isaprop (is_bifinal_repr X). Proof. use impred. intros Y. use (isofhlevelweqf _ (adj_equiv_is_equiv_cat (functor_to_unit (univ_hom H Y X)))). apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. (** 3. Equivalence between the two definitions *) Definition bifinal_repr_1cell {X : B} (HX : is_bifinal_repr X) : bifinal_1cell_property X := λ Y, right_adjoint (HX Y) tt. Definition bifinal_repr_2cell {X : B} (HX : is_bifinal_repr X) {Y : B} : bifinal_2cell_property X Y. Proof. intros f g. pose (L := functor_to_unit (hom Y X)). pose (R := right_adjoint (HX Y)). pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)). pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)). pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)). exact (comp_of_invertible_2cell θ₁ (inv_of_invertible_2cell θ₂)). Defined. Definition bifinal_repr_eq {X : B} (HX : is_bifinal_repr X) {Y : B} : bifinal_eq_property X Y. Proof. intros f g α β. pose (L := functor_to_unit (hom Y X)). pose (R := right_adjoint (HX Y)). pose (η := unit_nat_z_iso_from_adj_equivalence_of_cats (HX Y)). pose (θ₁ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η f)). pose (θ₂ := z_iso_to_inv2cell (nat_z_iso_pointwise_z_iso η g)). use (invmaponpathsincl _ (isinclweq _ _ _ (fully_faithful_from_equivalence _ _ _ (HX Y) _ _))). apply idpath. Qed. Definition is_bifinal_repr_to_is_bifinal {X : B} (HX : is_bifinal_repr X) : is_bifinal X. Proof. repeat split. - exact (bifinal_repr_1cell HX). - exact (bifinal_repr_2cell HX). - exact (bifinal_repr_eq HX). Defined. Definition bifinal_inv_data {X : B} (HX : is_bifinal X) (Y : B) : functor_data unit_category (hom Y X). Proof. use make_functor_data. - exact (λ _, is_bifinal_1cell_property HX Y). - exact (λ _ _ _, id₂ _). Defined. Definition bifinal_inv_is_functor {X : B} (HX : is_bifinal X) (Y : B) : is_functor (bifinal_inv_data HX Y). Proof. split. - intro ; intros. apply idpath. - intro ; intros. cbn. rewrite id2_left. apply idpath. Qed. Definition bifinal_inv {X : B} (HX : is_bifinal X) (Y : B) : unit_category ⟶ hom Y X. Proof. use make_functor. - exact (bifinal_inv_data HX Y). - exact (bifinal_inv_is_functor HX Y). Defined. Definition bifinal_inv_unit_data {X : B} (HX : is_bifinal X) (Y : B) : nat_trans_data (functor_identity (hom Y X)) (functor_composite (functor_to_unit (hom Y X)) (bifinal_inv HX Y)) := λ f, is_bifinal_2cell_property HX Y f (is_bifinal_1cell_property HX Y). Definition bifinal_inv_unit_is_nat_trans {X : B} (HX : is_bifinal X) (Y : B) : is_nat_trans _ _ (bifinal_inv_unit_data HX Y). Proof. intros f g α. simpl in * ; cbn. rewrite id2_right. apply (is_bifinal_eq_property HX Y). Qed. Definition bifinal_inv_unit {X : B} (HX : is_bifinal X) (Y : B) : functor_identity (hom Y X) ⟹ functor_composite (functor_to_unit (hom Y X)) (bifinal_inv HX Y). Proof. use make_nat_trans. - exact (bifinal_inv_unit_data HX Y). - exact (bifinal_inv_unit_is_nat_trans HX Y). Defined. Definition bifinal_inv_counit_data {X : B} (HX : is_bifinal X) (Y : B) : nat_trans_data (functor_composite (bifinal_inv HX Y) (functor_to_unit (hom Y X))) (functor_identity _). Proof. intros f. apply isapropunit. Defined. Definition bifinal_inv_counit_is_nat_trans {X : B} (HX : is_bifinal X) (Y : B) : is_nat_trans _ _ (bifinal_inv_counit_data HX Y). Proof. intros f g α. apply isasetunit. Qed. Definition bifinal_inv_counit {X : B} (HX : is_bifinal X) (Y : B) : functor_composite (bifinal_inv HX Y) (functor_to_unit (hom Y X)) ⟹ functor_identity _. Proof. use make_nat_trans. - exact (bifinal_inv_counit_data HX Y). - exact (bifinal_inv_counit_is_nat_trans HX Y). Defined. Definition is_bifinal_to_is_bifinal_repr_help {X : B} (HX : is_bifinal X) (Y : B) : equivalence_of_cats (hom Y X) unit_category. Proof. simple refine ((_ ,, (_ ,, (_ ,, _))) ,, (_ ,, _)). - exact (functor_to_unit _). - exact (bifinal_inv HX Y). - exact (bifinal_inv_unit HX Y). - exact (bifinal_inv_counit HX Y). - intros f. cbn ; unfold bifinal_inv_unit_data. apply is_inv2cell_to_is_z_iso. apply is_bifinal_invertible_2cell_property. - intro g. cbn. apply path_univalent_groupoid. Defined. Definition is_bifinal_to_is_bifinal_repr {X : B} (HX : is_bifinal X) : is_bifinal_repr X. Proof. intros Y. exact (adjointification (is_bifinal_to_is_bifinal_repr_help HX Y)). Defined. Definition is_bifinal_weq_is_bifinal_repr (H : is_univalent_2_1 B) (X : B) : is_bifinal X ≃ is_bifinal_repr X. Proof. use weqimplimpl. - exact is_bifinal_to_is_bifinal_repr. - exact is_bifinal_repr_to_is_bifinal. - exact (isaprop_is_bifinal H X). - exact (isaprop_is_bifinal_repr H X). Defined. End Final. (** 4. Bicategories with bifinal objects *) Definition bifinal_obj (B : bicat) : UU := ∑ (X : B), is_bifinal X. Definition has_bifinal (B : bicat) : UU := ∥ bifinal_obj B ∥. (** 5. Bifinal objects are unique *) Section Uniqueness. Context {B : bicat} (HB : is_univalent_2 B) {X : B} (HX : is_bifinal X) {Y : B} (HY : is_bifinal Y). Let HC0 : is_univalent_2_0 B := pr1 HB. Let HC1 : is_univalent_2_1 B := pr2 HB. Definition bifinal_unique_adj_unit : id₁ X ==> is_bifinal_1cell_property HY X · is_bifinal_1cell_property HX Y := is_bifinal_2cell_property HX _ _ _. Definition bifinal_unique_adj_counit : is_bifinal_1cell_property HX Y · is_bifinal_1cell_property HY X ==> id₁ Y := is_bifinal_2cell_property HY _ _ _. Definition bifinal_unique_adj_data : left_adjoint_data (is_bifinal_1cell_property HY X) := is_bifinal_1cell_property HX Y ,, bifinal_unique_adj_unit ,, bifinal_unique_adj_counit. Lemma bifinal_unique_left_eqv : left_equivalence_axioms bifinal_unique_adj_data. Proof. split. - apply is_bifinal_invertible_2cell_property. - apply is_bifinal_invertible_2cell_property. Qed. Definition bifinal_unique_adj_eqv : left_adjoint_equivalence (is_bifinal_1cell_property HY X). Proof. apply equiv_to_isadjequiv. unfold left_equivalence. exact (bifinal_unique_adj_data ,, bifinal_unique_left_eqv). Defined. Definition bifinal_unique : X = Y := isotoid_2_0 HC0 (_ ,, bifinal_unique_adj_eqv). End Uniqueness. (** 6. Being bifinal is preserved under equivalence *) Section FinalEquivalence. Context {B : bicat} {x y : B} (l : x --> y) (Hl : left_adjoint_equivalence l) (Hx : is_bifinal x). Let r : y --> x := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso Hl. Definition is_bifinal_1cell_left_adjoint_equivalence : bifinal_1cell_property y := λ z, is_bifinal_1cell_property Hx z · l. Definition is_bifinal_2cell_left_adjoint_equivalence (z : B) : bifinal_2cell_property y z := λ f g, rinvunitor _ • (_ ◃ ε^-1) • lassociator _ _ _ • (is_bifinal_2cell_property Hx z (f · r) (g · r) ▹ l) • rassociator _ _ _ • (_ ◃ ε) • runitor _. Definition is_bifinal_eq_left_adjoint_equivalence (z : B) : bifinal_eq_property y z. Proof. intros f g α β. enough (α ▹ r = β ▹ r) as H. { use (faithful_1cell_eq_cell (pr1 (adj_equiv_fully_faithful (inv_adjequiv (_ ,, Hl))))). exact H. } exact (is_bifinal_eq_property Hx z (f · r) (g · r) (α ▹ r) (β ▹ r)). Qed. Definition is_bifinal_left_adjoint_equivalence : is_bifinal y. Proof. use make_is_bifinal. - exact is_bifinal_1cell_left_adjoint_equivalence. - exact is_bifinal_2cell_left_adjoint_equivalence. - exact is_bifinal_eq_left_adjoint_equivalence. Defined. End FinalEquivalence. UniMath-20231010/UniMath/Bicategories/Limits/InserterEquivalences.v000066400000000000000000001031111451125700300250410ustar00rootroot00000000000000(************************************************************************ Equivalences for inserters ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Limits.Inserters. Local Open Scope cat. (** Suppose, we have a diagram as follows ---- f₁ ----> p₁ ---- i₁ ----> x₁ y₁ ---- g₁ ----> | | | | | | l₃ ≃ l₁ ≃ l₂ | | | | | | V V V ---- f₂ ----> p₂ ---- i₂ ----> x₁ y₂ ---- g₂ ----> where the columns are adjoint equivalences and both rows are inserters cones. If the top row is an inserter, then so is the bottom row. *) Section InserterEquivalence. Context {B : bicat} {p₁ x₁ y₁ p₂ x₂ y₂ : B} {i₁ : p₁ --> x₁} {f₁ g₁ : x₁ --> y₁} {α₁ : i₁ · f₁ ==> i₁ · g₁} (cone₁ := make_inserter_cone p₁ i₁ α₁) {i₂ : p₂ --> x₂} {f₂ g₂ : x₂ --> y₂} {α₂ : i₂ · f₂ ==> i₂ · g₂} (cone₂ := make_inserter_cone p₂ i₂ α₂) (lx : x₁ --> x₂) (ly : y₁ --> y₂) (lp : p₁ --> p₂) (Hlx : left_adjoint_equivalence lx) (Hly : left_adjoint_equivalence ly) (Hlp : left_adjoint_equivalence lp) (γ₁ : invertible_2cell (lp · i₂) (i₁ · lx)) (γ₂ : invertible_2cell (lx · f₂) (f₁ · ly)) (γ₃ : invertible_2cell (lx · g₂) (g₁ · ly)) (H : has_inserter_ump cone₁) (pα : (_ ◃ α₂) • lassociator _ _ _ • (γ₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₃) • lassociator _ _ _ = lassociator _ _ _ • (γ₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₂) • lassociator _ _ _ • (α₁ ▹ _)). Let rx : x₂ --> x₁ := left_adjoint_right_adjoint Hlx. Let ηx : invertible_2cell (id₁ _) (lx · rx) := left_equivalence_unit_iso Hlx. Let εx : invertible_2cell (rx · lx) (id₁ _) := left_equivalence_counit_iso Hlx. Let ry : y₂ --> y₁ := left_adjoint_right_adjoint Hly. Let ηy : invertible_2cell (id₁ _) (ly · ry) := left_equivalence_unit_iso Hly. Let εy : invertible_2cell (ry · ly) (id₁ _) := left_equivalence_counit_iso Hly. Let rp : p₂ --> p₁ := left_adjoint_right_adjoint Hlp. Let ηp : invertible_2cell (id₁ _) (lp · rp) := left_equivalence_unit_iso Hlp. Let εp : invertible_2cell (rp · lp) (id₁ _) := left_equivalence_counit_iso Hlp. Let γ₁' : invertible_2cell (rp · i₁) (i₂ · rx) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ηx) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₁))) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ εp)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)))))))). Let γ₂' : invertible_2cell (rx · f₁) (f₂ · ry) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ηy) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₂))) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ εx)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)))))))). Let γ₃' : invertible_2cell (rx · g₁) (g₂ · ry) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ηy) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₃))) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ εx)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _)))))))). Section UMP1. Context (q : inserter_cone f₂ g₂). Let cell : inserter_cone_pr1 q · rx · f₁ ==> inserter_cone_pr1 q · rx · g₁ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hly) (rassociator _ _ _ • (_ ◃ γ₂ ^-1) • lassociator _ _ _ • (rassociator _ _ _ ▹ _) • (_ ◃ εx ▹ _) • (runitor _ ▹ _) • inserter_cone_cell q • (rinvunitor _ ▹ _) • ((_ ◃ εx^-1) ▹ _) • (lassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ γ₃) • lassociator _ _ _). Let ι : q --> p₁ := inserter_ump_mor H (inserter_cone_pr1 q · rx) cell. Definition has_inserter_ump_1_left_adjoint_equivalence_mor : q --> p₂ := ι · lp. Definition has_inserter_ump_1_left_adjoint_equivalence_pr1 : invertible_2cell (has_inserter_ump_1_left_adjoint_equivalence_mor · inserter_cone_pr1 cone₂) (inserter_cone_pr1 q) := comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ γ₁) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inserter_ump_mor_pr1 H _ _)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ εx) (runitor_invertible_2cell _)))))). Definition has_inserter_ump_1_left_adjoint_equivalence_cell : (_ ◃ inserter_cone_cell cone₂) • lassociator _ _ _ • (has_inserter_ump_1_left_adjoint_equivalence_pr1 ▹ _) = lassociator _ _ _ • (has_inserter_ump_1_left_adjoint_equivalence_pr1 ▹ _) • inserter_cone_cell q. Proof. unfold has_inserter_ump_1_left_adjoint_equivalence_mor. cbn -[cell]. rewrite <- !rwhisker_vcomp. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- lwhisker_lwhisker. assert (lp ◃ α₂ = lassociator _ _ _ • (γ₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₂) • lassociator _ _ _ • (α₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₃^-1) • lassociator _ _ _ • (γ₁^-1 ▹ _) • rassociator _ _ _) as H'. { do 5 (use vcomp_move_L_Mp ; [ is_iso | ]). exact pα. } rewrite H' ; clear H'. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 (use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ]). cbn -[cell]. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. assert (ι ◃ α₁ = lassociator _ _ _ • (inserter_ump_mor_pr1 H (inserter_cone_pr1 q · rx) cell ▹ _) • cell • ((inserter_ump_mor_pr1 H (inserter_cone_pr1 q · rx) cell)^-1 ▹ _) • rassociator _ _ _) as H'. { do 2 (use vcomp_move_L_Mp ; [ is_iso | ]). exact (inserter_ump_mor_cell H _ cell). } rewrite H' ; clear H'. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 10 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. apply idpath. } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[cell]. refine (!_). etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. do 5 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } use vcomp_move_R_Mp. { is_iso. apply εx. } cbn -[cell]. rewrite !vassocr. apply fully_faithful_1cell_inv_map_eq. Qed. End UMP1. Definition has_inserter_ump_1_left_adjoint_equivalence : has_inserter_ump_1 cone₂. Proof. intro q. use make_inserter_1cell. - exact (has_inserter_ump_1_left_adjoint_equivalence_mor q). - exact (has_inserter_ump_1_left_adjoint_equivalence_pr1 q). - exact (has_inserter_ump_1_left_adjoint_equivalence_cell q). Defined. Section UMP2. Context {c : B} {u₁ u₂ : c --> p₂} (ζ : u₁ · i₂ ==> u₂ · i₂) (p : rassociator _ _ _ • (u₁ ◃ α₂) • lassociator _ _ _ • (ζ ▹ g₂) = (ζ ▹ _) • rassociator _ _ _ • (_ ◃ α₂) • lassociator _ _ _). Let cell : u₁ · rp · inserter_cone_pr1 cone₁ ==> u₂ · rp · inserter_cone_pr1 cone₁ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hlx) (rassociator _ _ _ • (_ ◃ γ₁^-1) • lassociator _ _ _ • (rassociator _ _ _ ▹ _) • ((_ ◃ εp) ▹ _) • (runitor _ ▹ _) • ζ • (rinvunitor _ ▹ _) • ((_ ◃ εp ^-1) ▹ _) • (lassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ γ₁) • lassociator _ _ _). Lemma has_inserter_ump_2_left_adjoint_equivalence_cell_path : rassociator _ _ _ • (_ ◃ inserter_cone_cell cone₁) • lassociator _ _ _ • (cell ▹ _) = (cell ▹ _) • rassociator _ _ _ • (_ ◃ inserter_cone_cell cone₁) • lassociator _ _ _. Proof. rewrite !vassocl. use (adj_equiv_faithful Hly). rewrite <- !rwhisker_vcomp. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. use (vcomp_rcancel (_ ◃ γ₃^-1)) ; [ is_iso | ]. rewrite !vassocl. rewrite vcomp_whisker. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- rwhisker_rwhisker. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ γ₂)). { is_iso. apply property_from_invertible_2cell. } rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. cbn -[cell]. cbn in p. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite inverse_pentagon_7. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. apply idpath. } etrans. { do 5 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite pentagon_6. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. rewrite !rwhisker_vcomp. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. apply maponpaths_2. apply maponpaths. assert (rassociator _ _ _ • (_ ◃ γ₂) • lassociator _ _ _ • (α₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₃^-1) • lassociator _ _ _ = (γ₁^-1 ▹ _) • rassociator _ _ _ • (_ ◃ α₂) • lassociator _ _ _ • (γ₁ ▹ g₂)) as H'. { do 3 (use vcomp_move_R_Mp ; [ is_iso | ]). rewrite !vassocl. do 2 (use vcomp_move_L_pM ; [ is_iso | ]). cbn. rewrite !vassocr. exact (!pα). } rewrite !vassocr. rewrite H'. rewrite !vassocl. apply idpath. } etrans. { rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite !rwhisker_vcomp. apply idpath. } rewrite !vassocr. etrans. { apply maponpaths_2. rewrite lwhisker_hcomp. rewrite pentagon_2. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite rwhisker_vcomp. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite inverse_pentagon_5. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite !vassocl. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite inverse_pentagon_7. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. do 2 apply maponpaths. etrans. { do 4 apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite !vassocl. rewrite <- inverse_pentagon_5. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. rewrite <- lassociator_lassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. do 2 apply maponpaths_2. apply maponpaths. assert (rassociator _ _ _ • (_ ◃ γ₂) • lassociator _ _ _ • (α₁ ▹ _) • rassociator _ _ _ • (_ ◃ γ₃^-1) • lassociator _ _ _ = (γ₁^-1 ▹ _) • rassociator _ _ _ • (_ ◃ α₂) • lassociator _ _ _ • (γ₁ ▹ _)) as H'. { do 3 (use vcomp_move_R_Mp ; [ is_iso | ]). rewrite !vassocl. do 2 (use vcomp_move_L_pM ; [ is_iso | ]). cbn. rewrite !vassocr. exact (!pα). } exact H'. } etrans. { rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite <- !lwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite rwhisker_vcomp. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. rewrite lwhisker_hcomp. rewrite pentagon_2. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite rwhisker_vcomp. apply idpath. } etrans. { apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. do 3 apply maponpaths_2. rewrite !vassocl. rewrite <- inverse_pentagon_2. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths_2. apply fully_faithful_1cell_inv_map_eq. } rewrite !vassocl. etrans. { do 12 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { do 11 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. } rewrite rassociator_lassociator. rewrite id2_right. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 apply maponpaths. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite !rwhisker_vcomp. apply maponpaths. etrans. { apply maponpaths. apply fully_faithful_1cell_inv_map_eq. } rewrite !vassocl. etrans. { do 2 apply maponpaths. refine (vassocr _ _ _ @ _). rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } refine (vassocr _ _ _ @ _). rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocr. do 3 apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[εp]. refine (!_). etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } do 3 apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[εp]. refine (!_). etrans. { rewrite !vassocr. rewrite p. rewrite !vassocl. apply idpath. } apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite vcomp_whisker. rewrite !vassocl. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply idpath. } apply maponpaths. refine (!_). etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. apply idpath. Qed. Definition has_inserter_ump_2_left_adjoint_equivalence_cell : u₁ ==> u₂. Proof. refine (rinvunitor _ • (_ ◃ εp^-1) • lassociator _ _ _ • (inserter_ump_cell H cell _ ▹ _) • rassociator _ _ _ • (_ ◃ εp) • runitor _). exact has_inserter_ump_2_left_adjoint_equivalence_cell_path. Defined. Definition has_inserter_ump_2_left_adjoint_equivalence_pr1 : has_inserter_ump_2_left_adjoint_equivalence_cell ▹ i₂ = ζ. Proof. unfold has_inserter_ump_2_left_adjoint_equivalence_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn -[εp cell]. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ γ₁^-1)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. exact (inserter_ump_cell_pr1 H cell _). } use vcomp_move_R_Mp. { is_iso. apply property_from_invertible_2cell. } cbn -[εp cell]. rewrite !vassocr. apply fully_faithful_1cell_inv_map_eq. Qed. End UMP2. Definition has_inserter_ump_2_left_adjoint_equivalence : has_inserter_ump_2 cone₂. Proof. intros c u₁ u₂ ζ p. simple refine (_ ,, _). - exact (has_inserter_ump_2_left_adjoint_equivalence_cell ζ p). - exact (has_inserter_ump_2_left_adjoint_equivalence_pr1 ζ p). Defined. Definition has_inserter_ump_eq_left_adjoint_equivalence : has_inserter_ump_eq cone₂. Proof. intros c u₁ u₂ ζ p φ₁ φ₂ q₁ q₂. enough (φ₁ ▹ rp = φ₂ ▹ rp) as H'. { use (adj_equiv_faithful (inv_adjequiv (_ ,, Hlp))). exact H'. } use (inserter_ump_eq_alt H) ; cbn. - rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. apply idpath. - cbn in q₁, q₂. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !rwhisker_rwhisker. apply maponpaths_2. use (vcomp_lcancel (_ ◃ (γ₁')^-1)) ; [ is_iso | ]. rewrite <- !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite <- !rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (q₁ @ !q₂). Qed. Definition has_inserter_ump_left_adjoint_equivalence : has_inserter_ump cone₂. Proof. refine (_ ,, _ ,, _). - exact has_inserter_ump_1_left_adjoint_equivalence. - exact has_inserter_ump_2_left_adjoint_equivalence. - exact has_inserter_ump_eq_left_adjoint_equivalence. Defined. End InserterEquivalence. UniMath-20231010/UniMath/Bicategories/Limits/Inserters.v000066400000000000000000000725641451125700300227000ustar00rootroot00000000000000(**************************************************************************** Inserters in bicategories Contents 1. Cones 2. The universal mapping property 3. The universal property gives an equivalence of categories 4. Bicategories with inserters 5. Inserters are faithful 6. Inserters are conservative ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Local Open Scope cat. Section Inserters. Context {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂}. (** 1. Cones *) Definition inserter_cone : UU := ∑ (i : B) (m : i --> b₁), m · f ==> m · g. Definition make_inserter_cone (i : B) (m : i --> b₁) (α : m · f ==> m · g) : inserter_cone := i ,, m ,, α. Coercion inserter_cone_ob (cone : inserter_cone) : B := pr1 cone. Definition inserter_cone_pr1 (cone : inserter_cone) : cone --> b₁ := pr12 cone. Definition inserter_cone_cell (cone : inserter_cone) : inserter_cone_pr1 cone · f ==> inserter_cone_pr1 cone · g := pr22 cone. Definition inserter_1cell (cone₁ cone₂ : inserter_cone) : UU := ∑ (k : cone₁ --> cone₂) (α : invertible_2cell (k · inserter_cone_pr1 cone₂) (inserter_cone_pr1 cone₁)), (k ◃ inserter_cone_cell cone₂) • lassociator _ _ _ • (α ▹ g) = lassociator _ _ _ • (α ▹ f) • inserter_cone_cell cone₁. Definition make_inserter_1cell {cone₁ cone₂ : inserter_cone} (k : cone₁ --> cone₂) (α : invertible_2cell (k · inserter_cone_pr1 cone₂) (inserter_cone_pr1 cone₁)) (p : (k ◃ inserter_cone_cell cone₂) • lassociator _ _ _ • (α ▹ g) = lassociator _ _ _ • (α ▹ f) • inserter_cone_cell cone₁) : inserter_1cell cone₁ cone₂ := k ,, α ,, p. Coercion inserter_1cell_mor {cone₁ cone₂ : inserter_cone} (u : inserter_1cell cone₁ cone₂) : cone₁ --> cone₂ := pr1 u. Definition inserter_1cell_pr1 {cone₁ cone₂ : inserter_cone} (u : inserter_1cell cone₁ cone₂) : invertible_2cell (u · inserter_cone_pr1 cone₂) (inserter_cone_pr1 cone₁) := pr12 u. Definition inserter_1cell_cell {cone₁ cone₂ : inserter_cone} (u : inserter_1cell cone₁ cone₂) : (_ ◃ inserter_cone_cell cone₂) • lassociator _ _ _ • (inserter_1cell_pr1 u ▹ g) = lassociator _ _ _ • (inserter_1cell_pr1 u ▹ f) • inserter_cone_cell cone₁ := pr22 u. Definition path_inserter_1cell {cone₁ cone₂ : inserter_cone} (φ ψ : inserter_1cell cone₁ cone₂) (p₁ : pr1 φ = pr1 ψ) (p₂ : pr112 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr112 ψ) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ φ₃ ]]. induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]]. cbn in *. induction p₁. apply maponpaths. use subtypePath. { intro. apply cellset_property. } cbn. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn in p₂. rewrite id2_rwhisker, id2_left in p₂. exact p₂. Qed. (** 2. The universal mapping property *) Section UniversalMappingProperty. Context (cone : inserter_cone). Definition has_inserter_ump_1 : UU := ∏ (other_cone : inserter_cone), inserter_1cell other_cone cone. Definition has_inserter_ump_2 : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _), ∑ (ζ : u₁ ==> u₂), ζ ▹ inserter_cone_pr1 cone = α. Definition has_inserter_ump_eq : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ inserter_cone_pr1 cone = α) (q₂ : φ₂ ▹ inserter_cone_pr1 cone = α), φ₁ = φ₂. Definition has_inserter_ump : UU := has_inserter_ump_1 × has_inserter_ump_2 × has_inserter_ump_eq. End UniversalMappingProperty. Section Projections. Context {cone : inserter_cone} (H : has_inserter_ump cone). Definition inserter_ump_mor {i : B} (m : i --> b₁) (α : m · f ==> m · g) : i --> cone := pr1 H (make_inserter_cone i m α). Definition inserter_ump_mor_pr1 {i : B} (m : i --> b₁) (α : m · f ==> m · g) : invertible_2cell (inserter_ump_mor m α · inserter_cone_pr1 cone) m := inserter_1cell_pr1 (pr1 H (make_inserter_cone i m α)). Definition inserter_ump_mor_cell {i : B} (m : i --> b₁) (α : m · f ==> m · g) : (_ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (inserter_ump_mor_pr1 m α ▹ g) = lassociator _ _ _ • (inserter_ump_mor_pr1 m α ▹ f) • α := inserter_1cell_cell (pr1 H (make_inserter_cone i m α)). Definition inserter_ump_cell {x : B} {u₁ u₂ : x --> cone} (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) : u₁ ==> u₂ := pr1 (pr12 H x u₁ u₂ α p). Definition inserter_ump_cell_pr1 {x : B} {u₁ u₂ : x --> cone} (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) : inserter_ump_cell α p ▹ inserter_cone_pr1 cone = α := pr2 (pr12 H x u₁ u₂ α p). Definition inserter_ump_eq {x : B} {u₁ u₂ : x --> cone} (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ inserter_cone_pr1 cone = α) (q₂ : φ₂ ▹ inserter_cone_pr1 cone = α) : φ₁ = φ₂ := pr22 H x u₁ u₂ α p φ₁ φ₂ q₁ q₂. Definition inserter_ump_eq_alt {x : B} {u₁ u₂ : x --> cone} (φ₁ φ₂ : u₁ ==> u₂) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (φ₁ ▹ inserter_cone_pr1 cone ▹ g) = (φ₁ ▹ inserter_cone_pr1 cone ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) (q : φ₁ ▹ inserter_cone_pr1 cone = φ₂ ▹ inserter_cone_pr1 cone) : φ₁ = φ₂. Proof. use inserter_ump_eq. - exact (φ₁ ▹ inserter_cone_pr1 cone). - exact p. - apply idpath. - exact (!q). Qed. End Projections. Section Invertible2CellInserterUMP. Context {cone : inserter_cone} (H : has_inserter_ump cone) {x : B} {u₁ u₂ : x --> cone} (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _) (Hα : is_invertible_2cell α). Local Lemma is_invertible_2cell_inserter_ump_cell_inv_path : rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (Hα ^-1 ▹ g) = (Hα ^-1 ▹ f) • rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _. Proof. use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. exact (!p). Qed. Let inv : u₂ ==> u₁ := inserter_ump_cell H (Hα^-1) is_invertible_2cell_inserter_ump_cell_inv_path. Local Lemma is_invertible_2cell_inserter_ump_cell_inv_right : inserter_ump_cell H α p • inv = id₂ _. Proof. use (inserter_ump_eq_alt H). - rewrite <- !rwhisker_vcomp. rewrite !vassocr. unfold inv. rewrite !inserter_ump_cell_pr1. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite !vcomp_rinv. rewrite !id2_rwhisker. rewrite id2_left, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inv. rewrite !inserter_ump_cell_pr1. rewrite id2_rwhisker. apply vcomp_rinv. Qed. Local Lemma is_invertible_2cell_inserter_ump_cell_inv_left : inv • inserter_ump_cell H α p = id₂ _. Proof. use (inserter_ump_eq_alt H). - rewrite <- !rwhisker_vcomp. rewrite !vassocr. unfold inv. rewrite !inserter_ump_cell_pr1. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite !vcomp_linv. rewrite !id2_rwhisker. rewrite id2_left, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inv. rewrite !inserter_ump_cell_pr1. rewrite id2_rwhisker. apply vcomp_linv. Qed. Definition is_invertible_2cell_inserter_ump_cell : is_invertible_2cell (inserter_ump_cell H α p). Proof. use make_is_invertible_2cell. - exact inv. - exact is_invertible_2cell_inserter_ump_cell_inv_right. - exact is_invertible_2cell_inserter_ump_cell_inv_left. Defined. End Invertible2CellInserterUMP. Definition isaprop_has_inserter_ump (HB_2_1 : is_univalent_2_1 B) (cone : inserter_cone) : isaprop (has_inserter_ump cone). Proof. use invproofirrelevance. intros χ₁ χ₂. use pathsdirprod. - use funextsec. intro q. use path_inserter_1cell. + apply (isotoid_2_1 HB_2_1). use make_invertible_2cell. * use (inserter_ump_cell χ₁). ** exact (inserter_1cell_pr1 (pr1 χ₁ q) • (inserter_1cell_pr1 (pr1 χ₂ q))^-1). ** rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. exact (inserter_1cell_cell (pr1 χ₁ q)). } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply maponpaths. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. exact (inserter_1cell_cell (pr1 χ₂ q)). } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. * use is_invertible_2cell_inserter_ump_cell. is_iso. apply property_from_invertible_2cell. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite inserter_ump_cell_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - use pathsdirprod. + use funextsec ; intro x. use funextsec ; intro u₁. use funextsec ; intro u₂. use funextsec ; intro φ. use funextsec ; intro p. use subtypePath. { intro. apply cellset_property. } use (inserter_ump_eq χ₁). * exact φ. * exact p. * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ p)). * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ p)). + do 9 (use funextsec ; intro). apply cellset_property. Qed. (** 3. The universal property gives an equivalence of categories *) Definition inserter_cone_functor_data (cone : inserter_cone) (x : B) : functor_data (hom x cone) (dialgebra (post_comp x f) (post_comp x g)). Proof. use make_functor_data. - exact (λ h, h · inserter_cone_pr1 cone ,, rassociator _ _ _ • (h ◃ inserter_cone_cell cone) • lassociator _ _ _). - refine (λ x y g, g ▹ _ ,, _) ; cbn. abstract (rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_whisker ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_rwhisker ; apply idpath). Defined. Definition inserter_cone_functor_is_functor (cone : inserter_cone) (x : B) : is_functor (inserter_cone_functor_data cone x). Proof. split. - intro h. use eq_dialgebra ; cbn. rewrite id2_rwhisker. apply idpath. - intros z₁ z₂ z₃ h₁ h₂. use eq_dialgebra ; cbn. rewrite rwhisker_vcomp. apply idpath. Qed. Definition inserter_cone_functor (cone : inserter_cone) (x : B) : hom x cone ⟶ dialgebra (post_comp x f) (post_comp x g). Proof. use make_functor. - exact (inserter_cone_functor_data cone x). - exact (inserter_cone_functor_is_functor cone x). Defined. Definition is_universal_inserter_cone (cone : inserter_cone) : UU := ∏ (x : B), adj_equivalence_of_cats (inserter_cone_functor cone x). Section MakeUniversalInserterCone. Context (HB_2_1 : is_univalent_2_1 B) (cone : inserter_cone) (H : has_inserter_ump cone) (x : B). Definition make_is_universal_inserter_cone_full : full (inserter_cone_functor cone x). Proof. intros u₁ u₂ α. pose (p := pr2 α). cbn in p. rewrite !vassocr in p. apply hinhpr. simple refine (_ ,, _). - use (inserter_ump_cell H). + exact (pr1 α). + exact p. - use eq_dialgebra ; cbn in *. apply inserter_ump_cell_pr1. Defined. Definition make_is_universal_inserter_cone_faithful : faithful (inserter_cone_functor cone x). Proof. intros u₁ u₂ α. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (inserter_ump_eq_alt H). - pose (pr2 α) as p. cbn in p. rewrite !vassocr in p. refine (_ @ p @ _). + do 2 apply maponpaths. exact (maponpaths pr1 (pr2 φ₁)). + do 3 apply maponpaths_2. apply maponpaths. exact (!(maponpaths pr1 (pr2 φ₁))). - exact (maponpaths pr1 (pr2 φ₁) @ !(maponpaths pr1 (pr2 φ₂))). Qed. Definition make_is_universal_inserter_cone_essentially_surjective : essentially_surjective (inserter_cone_functor cone x). Proof. intros h. use hinhpr. simple refine (_ ,, _). - exact (inserter_ump_mor H (pr1 h) (pr2 h)). - use z_iso_dialgebra. + simple refine (_ ,, _) ; cbn. * apply inserter_ump_mor_pr1. * abstract (cbn ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; apply inserter_ump_mor_cell). + use is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. Defined. End MakeUniversalInserterCone. Definition make_is_universal_inserter_cone (HB_2_1 : is_univalent_2_1 B) (cone : inserter_cone) (H : has_inserter_ump cone) : is_universal_inserter_cone cone. Proof. intro x. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + apply make_is_universal_inserter_cone_full. apply H. + apply make_is_universal_inserter_cone_faithful. apply H. - apply make_is_universal_inserter_cone_essentially_surjective. apply H. Defined. Definition isaprop_is_universal_inserter_cone (HB_2_1 : is_univalent_2_1 B) (cone : inserter_cone) : isaprop (is_universal_inserter_cone cone). Proof. use impred ; intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 x cone) (@univalent_dialgebra (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _) (post_comp x f) (post_comp x g)) (inserter_cone_functor cone x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 x cone) (@univalent_dialgebra (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _) (post_comp x f) (post_comp x g)) (inserter_cone_functor cone x)). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Defined. Section UniversalConeHasUMP. Context {cone : inserter_cone} (H : is_universal_inserter_cone cone). Section UMP1. Context (q : inserter_cone). Let alg : dialgebra (post_comp q f) (post_comp q g) := inserter_cone_pr1 q ,, inserter_cone_cell q. Definition universal_inserter_cone_has_ump_1_mor : q --> cone := right_adjoint (H q) alg. Definition universal_inserter_cone_has_ump_1_pr1 : invertible_2cell (universal_inserter_cone_has_ump_1_mor · inserter_cone_pr1 cone) (inserter_cone_pr1 q). Proof. use z_iso_to_inv2cell. exact (from_z_iso_dialgebra (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (H q)) alg)). Defined. Definition universal_inserter_cone_has_ump_1_cell : (_ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (universal_inserter_cone_has_ump_1_pr1 ▹ g) = lassociator _ _ _ • (universal_inserter_cone_has_ump_1_pr1 ▹ f) • inserter_cone_cell q. Proof. cbn. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. exact (!(pr2 (counit_from_left_adjoint (pr1 (H q)) alg))). } cbn. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. End UMP1. Definition universal_inserter_cone_has_ump_1 : has_inserter_ump_1 cone. Proof. intro q. use make_inserter_1cell. - exact (universal_inserter_cone_has_ump_1_mor q). - exact (universal_inserter_cone_has_ump_1_pr1 q). - exact (universal_inserter_cone_has_ump_1_cell q). Defined. Section UMP2. Context {x : B} {u₁ u₂ : x --> cone} (α : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ inserter_cone_cell cone) • lassociator _ _ _). Definition universal_inserter_cone_has_ump_2_cell : u₁ ==> u₂. Proof. apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))). simple refine (_ ,, _). - exact α. - abstract (cbn ; rewrite !vassocr ; exact p). Defined. Definition universal_inserter_cone_has_ump_2_pr1 : universal_inserter_cone_has_ump_2_cell ▹ inserter_cone_pr1 cone = α. Proof. exact (maponpaths pr1 (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂)) _)). Qed. End UMP2. Definition universal_inserter_cone_has_ump_2 : has_inserter_ump_2 cone. Proof. intros x u₁ u₂ α p. simple refine (_ ,, _). - exact (universal_inserter_cone_has_ump_2_cell α p). - exact (universal_inserter_cone_has_ump_2_pr1 α p). Defined. Definition universal_inserter_cone_has_ump_eq : has_inserter_ump_eq cone. Proof. intros x u₁ u₂ α p φ₁ φ₂ q₁ q₂. use (invmaponpathsweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn. use subtypePath. { intro. apply cellset_property. } cbn. exact (q₁ @ !q₂). Qed. Definition universal_inserter_cone_has_ump : has_inserter_ump cone. Proof. simple refine (_ ,, _ ,, _). - exact universal_inserter_cone_has_ump_1. - exact universal_inserter_cone_has_ump_2. - exact universal_inserter_cone_has_ump_eq. Defined. End UniversalConeHasUMP. Definition inserter_ump_weq_universal (HB_2_1 : is_univalent_2_1 B) (cone : inserter_cone) : has_inserter_ump cone ≃ is_universal_inserter_cone cone. Proof. use weqimplimpl. - exact (make_is_universal_inserter_cone HB_2_1 cone). - exact universal_inserter_cone_has_ump. - exact (isaprop_has_inserter_ump HB_2_1 cone). - exact (isaprop_is_universal_inserter_cone HB_2_1 cone). Defined. End Inserters. Arguments inserter_cone {_ _ _} _ _. (** 4. Bicategories with inserters *) Definition has_inserters (B : bicat) : UU := ∏ (b₁ b₂ : B) (f g : b₁ --> b₂), ∑ (i : B) (m : i --> b₁) (α : m · f ==> m · g), has_inserter_ump (make_inserter_cone i m α). (** 5. Inserters are faithful *) Definition inserter_faithful {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : m · f ==> m · g) (H : has_inserter_ump (make_inserter_cone i m α)) : faithful_1cell m. Proof. intros x g₁ g₂ β₁ β₂ p. use (inserter_ump_eq_alt H) ; cbn. - abstract (rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_rwhisker ; rewrite !vassocr ; apply maponpaths_2 ; refine (!_) ; apply vcomp_whisker). - exact p. Defined. (** 6. Inserters are conservative *) Section InserterConservative. Context {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : m · f ==> m · g) (H : has_inserter_ump (make_inserter_cone i m α)) {x : B} {g₁ g₂ : x --> i} (β : g₁ ==> g₂) (Hβ : is_invertible_2cell (β ▹ m)). Definition inserter_conservative_inv : g₂ ==> g₁. Proof. use (inserter_ump_cell H). - exact (Hβ^-1). - abstract (cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). Defined. Definition inserter_conservative_rinv : β • inserter_conservative_inv = id₂ _. Proof. use (inserter_ump_eq_alt H) ; cbn. - rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inserter_conservative_inv. rewrite (inserter_ump_cell_pr1 H). rewrite id2_rwhisker. apply vcomp_rinv. Qed. Definition inserter_conservative_linv : inserter_conservative_inv • β = id₂ _. Proof. use (inserter_ump_eq_alt H) ; cbn. - rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inserter_conservative_inv. rewrite (inserter_ump_cell_pr1 H). rewrite id2_rwhisker. apply vcomp_linv. Qed. End InserterConservative. Definition inserter_conservative {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : m · f ==> m · g) (H : has_inserter_ump (make_inserter_cone i m α)) : conservative_1cell m. Proof. intros x g₁ g₂ β Hβ. use make_is_invertible_2cell. - exact (inserter_conservative_inv m α H β Hβ). - exact (inserter_conservative_rinv m α H β Hβ). - exact (inserter_conservative_linv m α H β Hβ). Defined. Definition inserter_discrete {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : m · f ==> m · g) (H : has_inserter_ump (make_inserter_cone i m α)) : discrete_1cell m. Proof. split. - exact (inserter_faithful m α H). - exact (inserter_conservative m α H). Defined. UniMath-20231010/UniMath/Bicategories/Limits/IsoInserters.v000066400000000000000000000755551451125700300233560ustar00rootroot00000000000000(**************************************************************************** Iso-inserters in bicategories Contents 1. Cones 2. The universal mapping property 3. The universal property gives an equivalence of categories 4. Bicategories with iso-inserters 5. Inserters are faithful 6. Inserters are conservative ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.categories.CatIsoInserter. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Local Open Scope cat. Section IsoInserters. Context {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂}. (** 1. Cones *) Definition iso_inserter_cone : UU := ∑ (i : B) (m : i --> b₁), invertible_2cell (m · f) (m · g). Definition make_iso_inserter_cone (i : B) (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) : iso_inserter_cone := i ,, m ,, α. Coercion iso_inserter_cone_ob (cone : iso_inserter_cone) : B := pr1 cone. Definition iso_inserter_cone_pr1 (cone : iso_inserter_cone) : cone --> b₁ := pr12 cone. Definition iso_inserter_cone_cell (cone : iso_inserter_cone) : invertible_2cell (iso_inserter_cone_pr1 cone · f) (iso_inserter_cone_pr1 cone · g) := pr22 cone. Definition iso_inserter_1cell (cone₁ cone₂ : iso_inserter_cone) : UU := ∑ (k : cone₁ --> cone₂) (α : invertible_2cell (k · iso_inserter_cone_pr1 cone₂) (iso_inserter_cone_pr1 cone₁)), (k ◃ iso_inserter_cone_cell cone₂) • lassociator _ _ _ • (α ▹ g) = lassociator _ _ _ • (α ▹ f) • iso_inserter_cone_cell cone₁. Definition make_iso_inserter_1cell {cone₁ cone₂ : iso_inserter_cone} (k : cone₁ --> cone₂) (α : invertible_2cell (k · iso_inserter_cone_pr1 cone₂) (iso_inserter_cone_pr1 cone₁)) (p : (k ◃ iso_inserter_cone_cell cone₂) • lassociator _ _ _ • (α ▹ g) = lassociator _ _ _ • (α ▹ f) • iso_inserter_cone_cell cone₁) : iso_inserter_1cell cone₁ cone₂ := k ,, α ,, p. Coercion iso_inserter_1cell_mor {cone₁ cone₂ : iso_inserter_cone} (u : iso_inserter_1cell cone₁ cone₂) : cone₁ --> cone₂ := pr1 u. Definition iso_inserter_1cell_pr1 {cone₁ cone₂ : iso_inserter_cone} (u : iso_inserter_1cell cone₁ cone₂) : invertible_2cell (u · iso_inserter_cone_pr1 cone₂) (iso_inserter_cone_pr1 cone₁) := pr12 u. Definition iso_inserter_1cell_cell {cone₁ cone₂ : iso_inserter_cone} (u : iso_inserter_1cell cone₁ cone₂) : (_ ◃ iso_inserter_cone_cell cone₂) • lassociator _ _ _ • (iso_inserter_1cell_pr1 u ▹ g) = lassociator _ _ _ • (iso_inserter_1cell_pr1 u ▹ f) • iso_inserter_cone_cell cone₁ := pr22 u. Definition path_iso_inserter_1cell {cone₁ cone₂ : iso_inserter_cone} (φ ψ : iso_inserter_1cell cone₁ cone₂) (p₁ : pr1 φ = pr1 ψ) (p₂ : pr112 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr112 ψ) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ φ₃ ]]. induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]]. cbn in *. induction p₁. apply maponpaths. use subtypePath. { intro. apply cellset_property. } cbn. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn in p₂. rewrite id2_rwhisker, id2_left in p₂. exact p₂. Qed. (** 2. The universal mapping property *) Section UniversalMappingProperty. Context (cone : iso_inserter_cone). Definition has_iso_inserter_ump_1 : UU := ∏ (other_cone : iso_inserter_cone), iso_inserter_1cell other_cone cone. Definition has_iso_inserter_ump_2 : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _), ∑ (ζ : u₁ ==> u₂), ζ ▹ iso_inserter_cone_pr1 cone = α. Definition has_iso_inserter_ump_eq : UU := ∏ (x : B) (u₁ u₂ : x --> cone) (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ iso_inserter_cone_pr1 cone = α) (q₂ : φ₂ ▹ iso_inserter_cone_pr1 cone = α), φ₁ = φ₂. Definition has_iso_inserter_ump : UU := has_iso_inserter_ump_1 × has_iso_inserter_ump_2 × has_iso_inserter_ump_eq. End UniversalMappingProperty. Section Projections. Context {cone : iso_inserter_cone} (H : has_iso_inserter_ump cone). Definition iso_inserter_ump_mor {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) : i --> cone := pr1 H (make_iso_inserter_cone i m α). Definition iso_inserter_ump_mor_pr1 {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) : invertible_2cell (iso_inserter_ump_mor m α · iso_inserter_cone_pr1 cone) m := iso_inserter_1cell_pr1 (pr1 H (make_iso_inserter_cone i m α)). Definition iso_inserter_ump_mor_cell {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) : (_ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (iso_inserter_ump_mor_pr1 m α ▹ g) = lassociator _ _ _ • (iso_inserter_ump_mor_pr1 m α ▹ f) • α := iso_inserter_1cell_cell (pr1 H (make_iso_inserter_cone i m α)). Definition iso_inserter_ump_cell {x : B} {u₁ u₂ : x --> cone} (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) : u₁ ==> u₂ := pr1 (pr12 H x u₁ u₂ α p). Definition iso_inserter_ump_cell_pr1 {x : B} {u₁ u₂ : x --> cone} (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) : iso_inserter_ump_cell α p ▹ iso_inserter_cone_pr1 cone = α := pr2 (pr12 H x u₁ u₂ α p). Definition iso_inserter_ump_eq {x : B} {u₁ u₂ : x --> cone} (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) (φ₁ φ₂ : u₁ ==> u₂) (q₁ : φ₁ ▹ iso_inserter_cone_pr1 cone = α) (q₂ : φ₂ ▹ iso_inserter_cone_pr1 cone = α) : φ₁ = φ₂ := pr22 H x u₁ u₂ α p φ₁ φ₂ q₁ q₂. Definition iso_inserter_ump_eq_alt {x : B} {u₁ u₂ : x --> cone} (φ₁ φ₂ : u₁ ==> u₂) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (φ₁ ▹ iso_inserter_cone_pr1 cone ▹ g) = (φ₁ ▹ iso_inserter_cone_pr1 cone ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) (q : φ₁ ▹ iso_inserter_cone_pr1 cone = φ₂ ▹ iso_inserter_cone_pr1 cone) : φ₁ = φ₂. Proof. use iso_inserter_ump_eq. - exact (φ₁ ▹ iso_inserter_cone_pr1 cone). - exact p. - apply idpath. - exact (!q). Qed. End Projections. Section Invertible2CellIso_inserterUMP. Context {cone : iso_inserter_cone} (H : has_iso_inserter_ump cone) {x : B} {u₁ u₂ : x --> cone} (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _) (Hα : is_invertible_2cell α). Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_path : rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (Hα ^-1 ▹ g) = (Hα ^-1 ▹ f) • rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _. Proof. use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. exact (!p). Qed. Let inv : u₂ ==> u₁ := iso_inserter_ump_cell H (Hα^-1) is_invertible_2cell_iso_inserter_ump_cell_inv_path. Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_right : iso_inserter_ump_cell H α p • inv = id₂ _. Proof. use (iso_inserter_ump_eq_alt H). - rewrite <- !rwhisker_vcomp. rewrite !vassocr. unfold inv. rewrite !iso_inserter_ump_cell_pr1. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite !vcomp_rinv. rewrite !id2_rwhisker. rewrite id2_left, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inv. rewrite !iso_inserter_ump_cell_pr1. rewrite id2_rwhisker. apply vcomp_rinv. Qed. Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_left : inv • iso_inserter_ump_cell H α p = id₂ _. Proof. use (iso_inserter_ump_eq_alt H). - rewrite <- !rwhisker_vcomp. rewrite !vassocr. unfold inv. rewrite !iso_inserter_ump_cell_pr1. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite !vcomp_linv. rewrite !id2_rwhisker. rewrite id2_left, id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. unfold inv. rewrite !iso_inserter_ump_cell_pr1. rewrite id2_rwhisker. apply vcomp_linv. Qed. Definition is_invertible_2cell_iso_inserter_ump_cell : is_invertible_2cell (iso_inserter_ump_cell H α p). Proof. use make_is_invertible_2cell. - exact inv. - exact is_invertible_2cell_iso_inserter_ump_cell_inv_right. - exact is_invertible_2cell_iso_inserter_ump_cell_inv_left. Defined. End Invertible2CellIso_inserterUMP. Definition isaprop_has_iso_inserter_ump (HB_2_1 : is_univalent_2_1 B) (cone : iso_inserter_cone) : isaprop (has_iso_inserter_ump cone). Proof. use invproofirrelevance. intros χ₁ χ₂. use pathsdirprod. - use funextsec. intro q. use path_iso_inserter_1cell. + apply (isotoid_2_1 HB_2_1). use make_invertible_2cell. * use (iso_inserter_ump_cell χ₁). ** exact (iso_inserter_1cell_pr1 (pr1 χ₁ q) • (iso_inserter_1cell_pr1 (pr1 χ₂ q))^-1). ** rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. exact (iso_inserter_1cell_cell (pr1 χ₁ q)). } rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply maponpaths. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. exact (iso_inserter_1cell_cell (pr1 χ₂ q)). } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. * use is_invertible_2cell_iso_inserter_ump_cell. is_iso. apply property_from_invertible_2cell. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite iso_inserter_ump_cell_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - use pathsdirprod. + use funextsec ; intro x. use funextsec ; intro u₁. use funextsec ; intro u₂. use funextsec ; intro φ. use funextsec ; intro p. use subtypePath. { intro. apply cellset_property. } use (iso_inserter_ump_eq χ₁). * exact φ. * exact p. * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ p)). * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ p)). + do 9 (use funextsec ; intro). apply cellset_property. Qed. (** 3. The universal property gives an equivalence of categories *) Definition iso_inserter_cone_functor_data (cone : iso_inserter_cone) (x : B) : functor_data (hom x cone) (cat_iso_inserter (post_comp x f) (post_comp x g)). Proof. use make_functor_data. - refine (λ h, h · iso_inserter_cone_pr1 cone ,, _). use inv2cell_to_z_iso. use make_invertible_2cell. + exact (rassociator _ _ _ • (h ◃ iso_inserter_cone_cell cone) • lassociator _ _ _). + is_iso. apply property_from_invertible_2cell. - refine (λ x y g, g ▹ _ ,, _) ; cbn. abstract (rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_whisker ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_rwhisker ; apply idpath). Defined. Definition iso_inserter_cone_functor_is_functor (cone : iso_inserter_cone) (x : B) : is_functor (iso_inserter_cone_functor_data cone x). Proof. split. - intro h. use eq_cat_iso_inserter ; cbn. rewrite id2_rwhisker. apply idpath. - intros z₁ z₂ z₃ h₁ h₂. use eq_cat_iso_inserter ; cbn. rewrite rwhisker_vcomp. apply idpath. Qed. Definition iso_inserter_cone_functor (cone : iso_inserter_cone) (x : B) : hom x cone ⟶ cat_iso_inserter (post_comp x f) (post_comp x g). Proof. use make_functor. - exact (iso_inserter_cone_functor_data cone x). - exact (iso_inserter_cone_functor_is_functor cone x). Defined. Definition is_universal_iso_inserter_cone (cone : iso_inserter_cone) : UU := ∏ (x : B), adj_equivalence_of_cats (iso_inserter_cone_functor cone x). Section MakeUniversalIso_inserterCone. Context (HB_2_1 : is_univalent_2_1 B) (cone : iso_inserter_cone) (H : has_iso_inserter_ump cone) (x : B). Definition make_is_universal_iso_inserter_cone_full : full (iso_inserter_cone_functor cone x). Proof. intros u₁ u₂ α. pose (p := pr2 α). cbn in p. rewrite !vassocr in p. apply hinhpr. simple refine (_ ,, _). - use (iso_inserter_ump_cell H). + exact (pr1 α). + exact p. - use eq_cat_iso_inserter ; cbn in *. apply iso_inserter_ump_cell_pr1. Defined. Definition make_is_universal_iso_inserter_cone_faithful : faithful (iso_inserter_cone_functor cone x). Proof. intros u₁ u₂ α. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (iso_inserter_ump_eq_alt H). - pose (pr2 α) as p. cbn in p. rewrite !vassocr in p. refine (_ @ p @ _). + do 2 apply maponpaths. exact (maponpaths pr1 (pr2 φ₁)). + do 3 apply maponpaths_2. apply maponpaths. exact (!(maponpaths pr1 (pr2 φ₁))). - exact (maponpaths pr1 (pr2 φ₁) @ !(maponpaths pr1 (pr2 φ₂))). Qed. Definition make_is_universal_iso_inserter_cone_essentially_surjective : essentially_surjective (iso_inserter_cone_functor cone x). Proof. intros h. use hinhpr. simple refine (_ ,, _). - exact (iso_inserter_ump_mor H (pr1 h) (pr2 h)). - use z_iso_cat_iso_inserter. + simple refine (_ ,, _) ; cbn. * apply iso_inserter_ump_mor_pr1. * abstract (cbn ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; apply iso_inserter_ump_mor_cell). + use is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. Defined. End MakeUniversalIso_inserterCone. Definition make_is_universal_iso_inserter_cone (HB_2_1 : is_univalent_2_1 B) (cone : iso_inserter_cone) (H : has_iso_inserter_ump cone) : is_universal_iso_inserter_cone cone. Proof. intro x. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + apply make_is_universal_iso_inserter_cone_full. apply H. + apply make_is_universal_iso_inserter_cone_faithful. apply H. - apply make_is_universal_iso_inserter_cone_essentially_surjective. apply H. Defined. Definition isaprop_is_universal_iso_inserter_cone (HB_2_1 : is_univalent_2_1 B) (cone : iso_inserter_cone) : isaprop (is_universal_iso_inserter_cone cone). Proof. use impred ; intro x. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 x cone) (@univalent_cat_iso_inserter (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _) (post_comp x f) (post_comp x g)) (iso_inserter_cone_functor cone x)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 x cone) (@univalent_cat_iso_inserter (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _) (post_comp x f) (post_comp x g)) (iso_inserter_cone_functor cone x)). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Defined. Section UniversalConeHasUMP. Context {cone : iso_inserter_cone} (H : is_universal_iso_inserter_cone cone). Section UMP1. Context (q : iso_inserter_cone). Let alg : cat_iso_inserter (post_comp q f) (post_comp q g) := iso_inserter_cone_pr1 q ,, iso_inserter_cone_cell q. Definition universal_iso_inserter_cone_has_ump_1_mor : q --> cone := right_adjoint (H q) alg. Definition universal_iso_inserter_cone_has_ump_1_pr1 : invertible_2cell (universal_iso_inserter_cone_has_ump_1_mor · iso_inserter_cone_pr1 cone) (iso_inserter_cone_pr1 q). Proof. use z_iso_to_inv2cell. exact (from_z_iso_cat_iso_inserter (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (H q)) alg)). Defined. Definition universal_iso_inserter_cone_has_ump_1_cell : (_ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (universal_iso_inserter_cone_has_ump_1_pr1 ▹ g) = lassociator _ _ _ • (universal_iso_inserter_cone_has_ump_1_pr1 ▹ f) • iso_inserter_cone_cell q. Proof. cbn. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. exact (!(pr2 (counit_from_left_adjoint (pr1 (H q)) alg))). } cbn. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. End UMP1. Definition universal_iso_inserter_cone_has_ump_1 : has_iso_inserter_ump_1 cone. Proof. intro q. use make_iso_inserter_1cell. - exact (universal_iso_inserter_cone_has_ump_1_mor q). - exact (universal_iso_inserter_cone_has_ump_1_pr1 q). - exact (universal_iso_inserter_cone_has_ump_1_cell q). Defined. Section UMP2. Context {x : B} {u₁ u₂ : x --> cone} (α : u₁ · iso_inserter_cone_pr1 cone ==> u₂ · iso_inserter_cone_pr1 cone) (p : rassociator _ _ _ • (u₁ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _ • (α ▹ g) = (α ▹ f) • rassociator _ _ _ • (u₂ ◃ iso_inserter_cone_cell cone) • lassociator _ _ _). Definition universal_iso_inserter_cone_has_ump_2_cell : u₁ ==> u₂. Proof. apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))). simple refine (_ ,, _). - exact α. - abstract (cbn ; rewrite !vassocr ; exact p). Defined. Definition universal_iso_inserter_cone_has_ump_2_pr1 : universal_iso_inserter_cone_has_ump_2_cell ▹ iso_inserter_cone_pr1 cone = α. Proof. exact (maponpaths pr1 (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂)) _)). Qed. End UMP2. Definition universal_iso_inserter_cone_has_ump_2 : has_iso_inserter_ump_2 cone. Proof. intros x u₁ u₂ α p. simple refine (_ ,, _). - exact (universal_iso_inserter_cone_has_ump_2_cell α p). - exact (universal_iso_inserter_cone_has_ump_2_pr1 α p). Defined. Definition universal_iso_inserter_cone_has_ump_eq : has_iso_inserter_ump_eq cone. Proof. intros x u₁ u₂ α p φ₁ φ₂ q₁ q₂. use (invmaponpathsweq (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn. use subtypePath. { intro. apply cellset_property. } cbn. exact (q₁ @ !q₂). Qed. Definition universal_iso_inserter_cone_has_ump : has_iso_inserter_ump cone. Proof. simple refine (_ ,, _ ,, _). - exact universal_iso_inserter_cone_has_ump_1. - exact universal_iso_inserter_cone_has_ump_2. - exact universal_iso_inserter_cone_has_ump_eq. Defined. End UniversalConeHasUMP. Definition iso_inserter_ump_weq_universal (HB_2_1 : is_univalent_2_1 B) (cone : iso_inserter_cone) : has_iso_inserter_ump cone ≃ is_universal_iso_inserter_cone cone. Proof. use weqimplimpl. - exact (make_is_universal_iso_inserter_cone HB_2_1 cone). - exact universal_iso_inserter_cone_has_ump. - exact (isaprop_has_iso_inserter_ump HB_2_1 cone). - exact (isaprop_is_universal_iso_inserter_cone HB_2_1 cone). Defined. End IsoInserters. Arguments iso_inserter_cone {_ _ _} _ _. (** 4. Bicategories with iso_inserters *) Definition has_iso_inserters (B : bicat) : UU := ∏ (b₁ b₂ : B) (f g : b₁ --> b₂), ∑ (i : B) (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)), has_iso_inserter_ump (make_iso_inserter_cone i m α). (** 5. Iso_inserters are faithful *) Definition iso_inserter_faithful {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) (H : has_iso_inserter_ump (make_iso_inserter_cone i m α)) : faithful_1cell m. Proof. intros x g₁ g₂ β₁ β₂ p. use (iso_inserter_ump_eq_alt H) ; cbn. - abstract (rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite rwhisker_rwhisker ; rewrite !vassocr ; apply maponpaths_2 ; refine (!_) ; apply vcomp_whisker). - exact p. Defined. (** 6. Iso_inserters are conservative *) Section Iso_inserterConservative. Context {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) (H : has_iso_inserter_ump (make_iso_inserter_cone i m α)) {x : B} {g₁ g₂ : x --> i} (β : g₁ ==> g₂) (Hβ : is_invertible_2cell (β ▹ m)). Definition iso_inserter_conservative_inv : g₂ ==> g₁. Proof. use (iso_inserter_ump_cell H). - exact (Hβ^-1). - abstract (cbn ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). Defined. Definition iso_inserter_conservative_rinv : β • iso_inserter_conservative_inv = id₂ _. Proof. use (iso_inserter_ump_eq_alt H) ; cbn. - rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. unfold iso_inserter_conservative_inv. rewrite (iso_inserter_ump_cell_pr1 H). rewrite id2_rwhisker. apply vcomp_rinv. Qed. Definition iso_inserter_conservative_linv : iso_inserter_conservative_inv • β = id₂ _. Proof. use (iso_inserter_ump_eq_alt H) ; cbn. - rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. unfold iso_inserter_conservative_inv. rewrite (iso_inserter_ump_cell_pr1 H). rewrite id2_rwhisker. apply vcomp_linv. Qed. End Iso_inserterConservative. Definition iso_inserter_conservative {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) (H : has_iso_inserter_ump (make_iso_inserter_cone i m α)) : conservative_1cell m. Proof. intros x g₁ g₂ β Hβ. use make_is_invertible_2cell. - exact (iso_inserter_conservative_inv m α H β Hβ). - exact (iso_inserter_conservative_rinv m α H β Hβ). - exact (iso_inserter_conservative_linv m α H β Hβ). Defined. Definition iso_inserter_discrete {B : bicat} {b₁ b₂ : B} {f g : b₁ --> b₂} {i : B} (m : i --> b₁) (α : invertible_2cell (m · f) (m · g)) (H : has_iso_inserter_ump (make_iso_inserter_cone i m α)) : discrete_1cell m. Proof. split. - exact (iso_inserter_faithful m α H). - exact (iso_inserter_conservative m α H). Defined. UniMath-20231010/UniMath/Bicategories/Limits/ProductEquivalences.v000066400000000000000000000350021451125700300246710ustar00rootroot00000000000000(************************************************************************ Equivalences for products ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Limits.Products. Local Open Scope cat. (** Suppose, we have a diagram as follows π₁ π₂ x₁ <------ p ------> x₂ | | | l₁ ≃ l₃ ≃ l₂ | γ₁ | γ₂ | V V V y₁ <------ q ------> y₂ ρ₁ ρ₂ where l₁, l₂, and l₃ are adjoint equivalences. If the top row is a product cone, then so is the bottom row *) Section ProductEquivalence. Context {B : bicat} {x₁ x₂ p y₁ y₂ q : B} (π₁ : p --> x₁) (π₂ : p --> x₂) (cone₁ := make_binprod_cone p π₁ π₂) (Hp : has_binprod_ump cone₁) (ρ₁ : q --> y₁) (ρ₂ : q --> y₂) (cone₂ := make_binprod_cone q ρ₁ ρ₂) (l₁ : x₁ --> y₁) (l₂ : x₂ --> y₂) (l₃ : p --> q) (Hl₁ : left_adjoint_equivalence l₁) (Hl₂ : left_adjoint_equivalence l₂) (Hl₃ : left_adjoint_equivalence l₃) (γ₁ : invertible_2cell (l₃ · ρ₁) (π₁ · l₁)) (γ₂ : invertible_2cell (l₃ · ρ₂) (π₂ · l₂)). Let r₁ : y₁ --> x₁ := left_adjoint_right_adjoint Hl₁. Let η₁ : invertible_2cell (id₁ _) (l₁ · r₁) := left_equivalence_unit_iso Hl₁. Let ε₁ : invertible_2cell (r₁ · l₁) (id₁ _) := left_equivalence_counit_iso Hl₁. Let r₂ : y₂ --> x₂ := left_adjoint_right_adjoint Hl₂. Let η₂ : invertible_2cell (id₁ _) (l₂ · r₂) := left_equivalence_unit_iso Hl₂. Let ε₂ : invertible_2cell (r₂ · l₂) (id₁ _) := left_equivalence_counit_iso Hl₂. Let r₃ : q --> p := left_adjoint_right_adjoint Hl₃. Let η₃ : invertible_2cell (id₁ _) (l₃ · r₃) := left_equivalence_unit_iso Hl₃. Let ε₃ : invertible_2cell (r₃ · l₃) (id₁ _) := left_equivalence_counit_iso Hl₃. Definition has_binprod_ump_1_left_adjoint_equivalence : binprod_ump_1 cone₂. Proof. intros c. use make_binprod_1cell. - refine (_ · l₃). exact (binprod_ump_1cell Hp (binprod_cone_pr1 c · r₁) (binprod_cone_pr2 c · r₂)). - exact (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ γ₁) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (binprod_ump_1cell_pr1 Hp _ (binprod_cone_pr1 c · r₁) (binprod_cone_pr2 c · r₂))) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ε₁) (runitor_invertible_2cell _))))))). - exact (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ γ₂) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (binprod_ump_1cell_pr2 Hp _ (binprod_cone_pr1 c · r₁) (binprod_cone_pr2 c · r₂))) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ ε₂) (runitor_invertible_2cell _))))))). Defined. Section UMP2. Context {c : B} {φ ψ : c --> q} (α : φ · ρ₁ ==> ψ · ρ₁) (β : φ · ρ₂ ==> ψ · ρ₂). Let γ₁' : invertible_2cell (r₃ · π₁) (ρ₁ · r₁) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ η₁) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₁))) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ ε₃)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _))))))))). Let γ₂' : invertible_2cell (r₃ · π₂) (ρ₂ · r₂) := comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ η₂) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell γ₂))) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (lassociator_invertible_2cell _ _ _)) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (rwhisker_of_invertible_2cell _ ε₃)) (rwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _))))))))). Definition has_binprod_ump_2_left_adjoint_equivalence_unique : isaprop (∑ (ζ : φ ==> ψ), ζ ▹ binprod_cone_pr1 cone₂ = α × ζ ▹ binprod_cone_pr2 cone₂ = β). Proof. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } enough (pr1 ζ₁ ▹ r₃ = pr1 ζ₂ ▹ r₃) as H. { use (faithful_1cell_eq_cell (pr1 (adj_equiv_fully_faithful (inv_adjequiv (_ ,, Hl₃))))). exact H. } use (binprod_ump_2cell_unique_alt Hp) ; cbn. - use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !rwhisker_rwhisker. apply maponpaths_2. use (vcomp_lcancel (_ ◃ γ₁'^-1)). { is_iso. } rewrite <- !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite <- !rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (pr12 ζ₁ @ !(pr12 ζ₂)). - use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !rwhisker_rwhisker. apply maponpaths_2. use (vcomp_lcancel (_ ◃ γ₂'^-1)). { is_iso. } rewrite <- !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite <- !rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (pr22 ζ₁ @ !(pr22 ζ₂)). Qed. Let α' : φ · r₃ · π₁ ==> ψ · r₃ · π₁ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hl₁) (rassociator _ _ _ • (_ ◃ γ₁ ^-1) • lassociator _ _ _ • (rassociator _ _ _ ▹ _) • ((_ ◃ ε₃) ▹ _) • (runitor _ ▹ _) • α • (rinvunitor _ ▹ _) • ((_ ◃ ε₃^-1) ▹ _) • (lassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ γ₁) • lassociator _ _ _). Let β' : φ · r₃ · π₂ ==> ψ · r₃ · π₂ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hl₂) (rassociator _ _ _ • (_ ◃ γ₂^-1) • lassociator _ _ _ • (rassociator _ _ _ ▹ _) • ((_ ◃ ε₃) ▹ _) • (runitor _ ▹ _) • β • (rinvunitor _ ▹ _) • ((_ ◃ ε₃^-1) ▹ _) • (lassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ γ₂) • lassociator _ _ _). Definition has_binprod_ump_2_left_adjoint_equivalence_cell : φ ==> ψ := rinvunitor _ • (_ ◃ ε₃^-1) • lassociator _ _ _ • (binprod_ump_2cell Hp α' β' ▹ l₃) • rassociator _ _ _ • (_ ◃ ε₃) • runitor _. Definition has_binprod_ump_2_left_adjoint_equivalence_pr1 : has_binprod_ump_2_left_adjoint_equivalence_cell ▹ ρ₁ = α. Proof. unfold has_binprod_ump_2_left_adjoint_equivalence_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn - [ε₃]. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ γ₁^-1)). { is_iso. } rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply( binprod_ump_2cell_pr1 Hp). } use vcomp_move_R_Mp. { is_iso. apply ε₃. } cbn -[ε₃]. rewrite !vassocl. apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hl₁)). Qed. Definition has_binprod_ump_2_left_adjoint_equivalence_pr2 : has_binprod_ump_2_left_adjoint_equivalence_cell ▹ ρ₂ = β. Proof. unfold has_binprod_ump_2_left_adjoint_equivalence_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]). cbn - [ε₃]. use (vcomp_lcancel (lassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ γ₂^-1)). { is_iso. } rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply( binprod_ump_2cell_pr2 Hp). } use vcomp_move_R_Mp. { is_iso. apply ε₃. } cbn -[ε₃]. rewrite !vassocl. apply (fully_faithful_1cell_inv_map_eq (adj_equiv_fully_faithful Hl₂)). Qed. End UMP2. Definition has_binprod_ump_2_left_adjoint_equivalence : binprod_ump_2 cone₂. Proof. intros c φ ψ α β. use iscontraprop1. - exact (has_binprod_ump_2_left_adjoint_equivalence_unique α β). - simple refine (_ ,, _ ,, _). + exact (has_binprod_ump_2_left_adjoint_equivalence_cell α β). + exact (has_binprod_ump_2_left_adjoint_equivalence_pr1 α β). + exact (has_binprod_ump_2_left_adjoint_equivalence_pr2 α β). Defined. Definition has_binprod_ump_left_adjoint_equivalence : has_binprod_ump cone₂. Proof. simple refine (_ ,, _). - exact has_binprod_ump_1_left_adjoint_equivalence. - exact has_binprod_ump_2_left_adjoint_equivalence. Defined. End ProductEquivalence. UniMath-20231010/UniMath/Bicategories/Limits/Products.v000066400000000000000000001720271451125700300225200ustar00rootroot00000000000000(**************************************************************** Products in bicategories In this file we define the notion of product diagram in arbitrary bicategories. For this definition, there are 2 possibilities. One could either write universal properties, which expresses the existence of a morphism up to a unique 2-cell. Alternatively, one could define the universal property via the hom-categories. Here, we choose the first approach. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section Product. Context {B : bicat} {b₁ b₂ : B}. (** Cones on the diagram *) Definition binprod_cone : UU := ∑ (p : B), p --> b₁ × p --> b₂. Coercion binprod_cone_obj (p : binprod_cone) : B := pr1 p. Definition binprod_cone_pr1 (p : binprod_cone) : p --> b₁ := pr12 p. Definition binprod_cone_pr2 (p : binprod_cone) : p --> b₂ := pr22 p. Definition make_binprod_cone (p : B) (π₁ : p --> b₁) (π₂ : p --> b₂) : binprod_cone := (p ,, π₁ ,, π₂). (** 1-cells between cones *) Definition binprod_1cell (p q : binprod_cone) : UU := ∑ (φ : p --> q), invertible_2cell (φ · binprod_cone_pr1 q) (binprod_cone_pr1 p) × invertible_2cell (φ · binprod_cone_pr2 q) (binprod_cone_pr2 p). Coercion binprod_1cell_1cell {p q : binprod_cone} (φ : binprod_1cell p q) : p --> q := pr1 φ. Definition binprod_1cell_pr1 {p q : binprod_cone} (φ : binprod_1cell p q) : invertible_2cell (φ · binprod_cone_pr1 q) (binprod_cone_pr1 p) := pr12 φ. Definition binprod_1cell_pr2 {p q : binprod_cone} (φ : binprod_1cell p q) : invertible_2cell (φ · binprod_cone_pr2 q) (binprod_cone_pr2 p) := pr22 φ. Definition make_binprod_1cell {p q : binprod_cone} (φ : p --> q) (τ : invertible_2cell (φ · binprod_cone_pr1 q) (binprod_cone_pr1 p)) (θ : invertible_2cell (φ · binprod_cone_pr2 q) (binprod_cone_pr2 p)) : binprod_1cell p q := (φ ,, τ ,, θ). Definition eq_binprod_1cell {p q : binprod_cone} (φ ψ : binprod_1cell p q) (r₁ : pr1 φ = pr1 ψ) (r₂ : pr1 (binprod_1cell_pr1 φ) = (idtoiso_2_1 _ _ r₁ ▹ binprod_cone_pr1 q) • pr1 (binprod_1cell_pr1 ψ)) (r₃ : pr1 (binprod_1cell_pr2 φ) = (idtoiso_2_1 _ _ r₁ ▹ binprod_cone_pr2 q) • pr1 (binprod_1cell_pr2 ψ)) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ [ φ₃ φ₄ ]]]. induction ψ as [ ψ₁ [ ψ₂ [ ψ₃ ψ₄ ]]]. cbn in r₁. induction r₁ ; cbn in r₂. apply maponpaths. assert (φ₂ = ψ₂) as r'. { use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite id2_rwhisker, id2_left in r₂. exact r₂. } induction r'. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. cbn in r₃. rewrite id2_rwhisker, id2_left in r₃. exact r₃. Qed. (** Statements of universal mapping properties of products *) Section UniversalMappingPropertyStatements. Variable (p : binprod_cone). Definition binprod_ump_1 : UU := ∏ (q : binprod_cone), binprod_1cell q p. Definition binprod_ump_2 : UU := ∏ (a : B) (φ ψ : a --> p) (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p), ∃! (γ : φ ==> ψ), (γ ▹ binprod_cone_pr1 p = α) × (γ ▹ binprod_cone_pr2 p = β). Definition has_binprod_ump : UU := binprod_ump_1 × binprod_ump_2. Definition has_binprod_ump_1 (H : has_binprod_ump) : binprod_ump_1 := pr1 H. Definition has_binprod_ump_2 (H : has_binprod_ump) : binprod_ump_2 := pr2 H. Definition has_binprod_ump_2_cell : UU := ∏ (a : B) (φ ψ : a --> p) (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p), φ ==> ψ. Definition has_binprod_ump_2_cell_pr1 (υ : has_binprod_ump_2_cell) := ∏ (a : B) (φ ψ : a --> p) (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p), υ a φ ψ α β ▹ binprod_cone_pr1 p = α. Definition has_binprod_ump_2_cell_pr2 (υ : has_binprod_ump_2_cell) := ∏ (a : B) (φ ψ : a --> p) (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p), υ a φ ψ α β ▹ binprod_cone_pr2 p = β. Definition has_binprod_ump_2_cell_unique : UU := ∏ (a : B) (φ ψ : a --> p) (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p) (γ δ : φ ==> ψ) (γpr1 : γ ▹ binprod_cone_pr1 p = α) (γpr2 : γ ▹ binprod_cone_pr2 p = β) (δpr1 : δ ▹ binprod_cone_pr1 p = α) (δpr2 : δ ▹ binprod_cone_pr2 p = β), γ = δ. Definition make_binprod_ump (υ₁ : binprod_ump_1) (υ₂ : has_binprod_ump_2_cell) (υ₂pr1 : has_binprod_ump_2_cell_pr1 υ₂) (υ₂pr2 : has_binprod_ump_2_cell_pr2 υ₂) (υ₃ : has_binprod_ump_2_cell_unique) : has_binprod_ump. Proof. split. - exact υ₁. - intros q f₁ f₂ α β. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (υ₃ q f₁ f₂ α β (pr1 φ₁) (pr1 φ₂) (pr12 φ₁) (pr22 φ₁) (pr12 φ₂) (pr22 φ₂))). + simple refine (_ ,, _ ,, _). * exact (υ₂ q f₁ f₂ α β). * abstract (apply υ₂pr1). * abstract (apply υ₂pr2). Defined. End UniversalMappingPropertyStatements. Section Projections. Context {p : binprod_cone} (H : has_binprod_ump p). Definition binprod_ump_1cell {a : B} (apr1 : a --> b₁) (apr2 : a --> b₂) : a --> p := has_binprod_ump_1 _ H (make_binprod_cone a apr1 apr2). Definition binprod_ump_1cell_pr1 (a : B) (apr1 : a --> b₁) (apr2 : a --> b₂) : invertible_2cell (binprod_ump_1cell apr1 apr2 · binprod_cone_pr1 p) apr1 := binprod_1cell_pr1 (has_binprod_ump_1 _ H (make_binprod_cone a apr1 apr2)). Definition binprod_ump_1cell_pr2 (a : B) (apr1 : a --> b₁) (apr2 : a --> b₂) : invertible_2cell (binprod_ump_1cell apr1 apr2 · binprod_cone_pr2 p) apr2 := binprod_1cell_pr2 (has_binprod_ump_1 _ H (make_binprod_cone a apr1 apr2)). Definition binprod_ump_2cell {a : B} {φ ψ : a --> p} (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p) : φ ==> ψ := pr11 (has_binprod_ump_2 _ H a φ ψ α β). Definition binprod_ump_2cell_pr1 {a : B} {φ ψ : a --> p} (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p) : binprod_ump_2cell α β ▹ binprod_cone_pr1 p = α := pr121 (has_binprod_ump_2 _ H a φ ψ α β). Definition binprod_ump_2cell_pr2 {a : B} {φ ψ : a --> p} (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p) : binprod_ump_2cell α β ▹ binprod_cone_pr2 p = β := pr221 (has_binprod_ump_2 _ H a φ ψ α β). Definition binprod_ump_2cell_unique {a : B} {φ ψ : a --> p} (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p) (γ δ : φ ==> ψ) (γpr1 : γ ▹ binprod_cone_pr1 p = α) (γpr2 : γ ▹ binprod_cone_pr2 p = β) (δpr1 : δ ▹ binprod_cone_pr1 p = α) (δpr2 : δ ▹ binprod_cone_pr2 p = β) : γ = δ. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (has_binprod_ump_2 _ H a φ ψ α β)) (γ ,, (γpr1 ,, γpr2)) (δ ,, (δpr1 ,, δpr2)))). Qed. Definition binprod_ump_2cell_unique_alt {a : B} {φ ψ : a --> p} (γ δ : φ ==> ψ) (ppr1 : γ ▹ binprod_cone_pr1 p = δ ▹ binprod_cone_pr1 p) (ppr2 : γ ▹ binprod_cone_pr2 p = δ ▹ binprod_cone_pr2 p) : γ = δ. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (has_binprod_ump_2 _ H a φ ψ (γ ▹ binprod_cone_pr1 p) (γ ▹ binprod_cone_pr2 p))) (γ ,, (idpath _ ,, idpath _)) (δ ,, (!ppr1 ,, !ppr2)))). Qed. Definition binprod_ump_2cell_invertible {a : B} {φ ψ : a --> p} {α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p} {β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p} (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β) : is_invertible_2cell (binprod_ump_2cell α β). Proof. use make_is_invertible_2cell. - exact (binprod_ump_2cell (Hα^-1) (Hβ^-1)). - use (binprod_ump_2cell_unique (id2 _) (id2 _)). + abstract (rewrite <- !rwhisker_vcomp ; rewrite !binprod_ump_2cell_pr1 ; rewrite vcomp_rinv ; apply idpath). + abstract (rewrite <- !rwhisker_vcomp ; rewrite !binprod_ump_2cell_pr2 ; rewrite vcomp_rinv ; apply idpath). + abstract (apply id2_rwhisker). + abstract (apply id2_rwhisker). - use (binprod_ump_2cell_unique (id2 _) (id2 _)). + abstract (rewrite <- !rwhisker_vcomp ; rewrite !binprod_ump_2cell_pr1 ; rewrite vcomp_linv ; apply idpath). + abstract (rewrite <- !rwhisker_vcomp ; rewrite !binprod_ump_2cell_pr2 ; rewrite vcomp_linv ; apply idpath). + abstract (apply id2_rwhisker). + abstract (apply id2_rwhisker). Defined. End Projections. Definition isaprop_has_binprod_ump (p : binprod_cone) (HB_2_1 : is_univalent_2_1 B) : isaprop (has_binprod_ump p). Proof. use invproofirrelevance. intros χ₁ χ₂. use pathsdirprod. - use funextsec ; intro q. use eq_binprod_1cell. + use (isotoid_2_1 HB_2_1). use make_invertible_2cell. * use (binprod_ump_2cell χ₂). ** exact (comp_of_invertible_2cell (binprod_1cell_pr1 (pr1 χ₁ q)) (inv_of_invertible_2cell (binprod_1cell_pr1 (pr1 χ₂ q)))). ** exact (comp_of_invertible_2cell (binprod_1cell_pr2 (pr1 χ₁ q)) (inv_of_invertible_2cell (binprod_1cell_pr2 (pr1 χ₂ q)))). * use binprod_ump_2cell_invertible. ** apply property_from_invertible_2cell. ** apply property_from_invertible_2cell. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite binprod_ump_2cell_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. + rewrite idtoiso_2_1_isotoid_2_1. cbn. rewrite binprod_ump_2cell_pr2. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - repeat (use funextsec ; intro). apply isapropiscontr. Qed. Definition postcomp_binprod_cone (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) (x : B) : univ_hom HB_2_1 x p ⟶ univalent_category_binproduct (univ_hom HB_2_1 x b₁) (univ_hom HB_2_1 x b₂). Proof. use bindelta_pair_functor. - exact (post_comp x (binprod_cone_pr1 p)). - exact (post_comp x (binprod_cone_pr2 p)). Defined. Definition binprod_cat_ump (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) : UU := ∏ (x : B), @left_adjoint_equivalence bicat_of_univ_cats _ _ (postcomp_binprod_cone HB_2_1 p x). Definition isaprop_binprod_cat_ump (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) : isaprop (binprod_cat_ump HB_2_1 p). Proof. use impred ; intro x. apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Defined. Definition has_binprod_ump_binprod_cat_ump (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) (H : has_binprod_ump p) : binprod_cat_ump HB_2_1 p. Proof. intro x. use equiv_cat_to_adj_equiv. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + intros f g α. use hinhpr. simple refine (_ ,, _). * exact (binprod_ump_2cell H (pr1 α) (pr2 α)). * use pathsdirprod. ** apply binprod_ump_2cell_pr1. ** apply binprod_ump_2cell_pr2. + unfold faithful. intros f g α. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro ; apply homset_property. } use (binprod_ump_2cell_unique H). * exact (pr1 α). * exact (pr2 α). * exact (maponpaths pr1 (pr2 φ₁)). * exact (maponpaths dirprod_pr2 (pr2 φ₁)). * exact (maponpaths pr1 (pr2 φ₂)). * exact (maponpaths dirprod_pr2 (pr2 φ₂)). - intros f g. use hinhpr. simple refine (binprod_ump_1cell H (pr1 f) (pr2 f) ,, _). use make_z_iso'. + exact (pr1 (binprod_ump_1cell_pr1 H _ (pr1 f) (pr2 f)) ,, pr1 (binprod_ump_1cell_pr2 H _ (pr1 f) (pr2 f))). + use is_z_iso_binprod_z_iso. * apply is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. * apply is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. Defined. Section BinProdUMPCatUMP1. Context (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) (H : binprod_cat_ump HB_2_1 p) (q : binprod_cone). Definition has_binprod_cat_ump_binprod_ump_1_mor : q --> p. Proof. apply (left_adjoint_right_adjoint (H (pr1 q))). simple refine (_ ,, _). - exact (binprod_cone_pr1 q). - exact (binprod_cone_pr2 q). Defined. Definition has_binprod_cat_ump_binprod_ump_1_pr1 : invertible_2cell (has_binprod_cat_ump_binprod_ump_1_mor · binprod_cone_pr1 p) (binprod_cone_pr1 q). Proof. apply z_iso_to_inv2cell. exact (pr1 (category_binproduct_z_iso_inv _ _ (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (left_equivalence_counit_iso (H (pr1 q)))) (binprod_cone_pr1 q ,, binprod_cone_pr2 q)))). Defined. Definition has_binprod_cat_ump_binprod_ump_1_pr2 : invertible_2cell (has_binprod_cat_ump_binprod_ump_1_mor · binprod_cone_pr2 p) (binprod_cone_pr2 q). Proof. apply z_iso_to_inv2cell. exact (pr2 (category_binproduct_z_iso_inv _ _ (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (left_equivalence_counit_iso (H (pr1 q)))) (binprod_cone_pr1 q ,, binprod_cone_pr2 q)))). Defined. End BinProdUMPCatUMP1. Section BinProdUMPCatUMP2. Context (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) (H : binprod_cat_ump HB_2_1 p) {x : B} {φ ψ : x --> p} (α : φ · binprod_cone_pr1 p ==> ψ · binprod_cone_pr1 p) (β : φ · binprod_cone_pr2 p ==> ψ · binprod_cone_pr2 p). Definition has_binprod_cat_ump_binprod_ump_2_unique : isaprop (∑ (γ : φ ==> ψ), γ ▹ binprod_cone_pr1 p = α × γ ▹ binprod_cone_pr2 p = β). Proof. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } pose (pr2 (fully_faithful_implies_full_and_faithful _ _ _ (fully_faithful_from_equivalence _ _ _ (adj_equiv_to_equiv_cat _ (H x)))) φ ψ (α ,, β)) as Hf. refine (maponpaths pr1 (proofirrelevance _ Hf (pr1 ζ₁ ,, _) (pr1 ζ₂ ,, _))). - use pathsdirprod ; cbn. + exact (pr12 ζ₁). + exact (pr22 ζ₁). - use pathsdirprod ; cbn. + exact (pr12 ζ₂). + exact (pr22 ζ₂). Qed. Definition has_binprod_cat_ump_binprod_ump_2_iscontr : iscontr (∑ (γ : φ ==> ψ), γ ▹ binprod_cone_pr1 p = α × γ ▹ binprod_cone_pr2 p = β). Proof. pose (pr1 (fully_faithful_implies_full_and_faithful _ _ _ (fully_faithful_from_equivalence _ _ _ (adj_equiv_to_equiv_cat _ (H x)))) φ ψ (α ,, β)) as m. use (factor_through_squash _ _ m). - apply isapropiscontr. - intro fib. use iscontraprop1. + apply has_binprod_cat_ump_binprod_ump_2_unique. + refine (pr1 fib ,, _ ,, _). * exact (maponpaths pr1 (pr2 fib)). * exact (maponpaths dirprod_pr2 (pr2 fib)). Defined. End BinProdUMPCatUMP2. Definition has_binprod_cat_ump_binprod_ump (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) (H : binprod_cat_ump HB_2_1 p) : has_binprod_ump p. Proof. split. - intro q. use make_binprod_1cell. + exact (has_binprod_cat_ump_binprod_ump_1_mor HB_2_1 p H q). + exact (has_binprod_cat_ump_binprod_ump_1_pr1 HB_2_1 p H q). + exact (has_binprod_cat_ump_binprod_ump_1_pr2 HB_2_1 p H q). - intros x φ ψ α β. exact (has_binprod_cat_ump_binprod_ump_2_iscontr HB_2_1 p H α β). Defined. Definition has_binprod_ump_weq_binprod_cat_ump (HB_2_1 : is_univalent_2_1 B) (p : binprod_cone) : has_binprod_ump p ≃ binprod_cat_ump HB_2_1 p. Proof. use weqimplimpl. - exact (has_binprod_ump_binprod_cat_ump HB_2_1 p). - exact (has_binprod_cat_ump_binprod_ump HB_2_1 p). - apply isaprop_has_binprod_ump. exact HB_2_1. - apply isaprop_binprod_cat_ump. Defined. End Product. Arguments binprod_cone {_} _ _. Definition has_binprod (B : bicat) : UU := ∏ (b₁ b₂ : B), ∑ (p : binprod_cone b₁ b₂), has_binprod_ump p. Definition bicat_with_binprod : UU := ∑ (B : bicat), has_binprod B. Coercion bicat_with_binprod_to_bicat (B : bicat_with_binprod) : bicat := pr1 B. Definition binprod_of (B : bicat_with_binprod) : has_binprod B := pr2 B. Section StandardFunctions. Context (B : bicat_with_binprod). Definition binprod (b₁ b₂ : B) : B := pr1 (binprod_of B b₁ b₂). Local Notation "b₁ ⊗ b₂" := (binprod b₁ b₂). Definition binprod_pr1 (b₁ b₂ : B) : b₁ ⊗ b₂ --> b₁ := binprod_cone_pr1 (pr1 (binprod_of B b₁ b₂)). Definition binprod_pr2 (b₁ b₂ : B) : b₁ ⊗ b₂ --> b₂ := binprod_cone_pr2 (pr1 (binprod_of B b₁ b₂)). Local Notation "'π₁'" := (binprod_pr1 _ _). Local Notation "'π₂'" := (binprod_pr2 _ _). Definition prod_1cell {a b₁ b₂ : B} (f : a --> b₁) (g : a --> b₂) : a --> b₁ ⊗ b₂ := binprod_ump_1cell (pr2 (binprod_of B b₁ b₂)) f g. Local Notation "⟨ f , g ⟩" := (prod_1cell f g). Definition prod_1cell_pr1 {a b₁ b₂ : B} (f : a --> b₁) (g : a --> b₂) : invertible_2cell (⟨ f , g ⟩ · π₁) f := binprod_ump_1cell_pr1 (pr2 (binprod_of B b₁ b₂)) _ f g. Definition prod_1cell_pr2 {a b₁ b₂ : B} (f : a --> b₁) (g : a --> b₂) : invertible_2cell (⟨ f , g ⟩ · π₂) g := binprod_ump_1cell_pr2 (pr2 (binprod_of B b₁ b₂)) _ f g. Definition pair_1cell {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : a₁ ⊗ a₂ --> b₁ ⊗ b₂ := ⟨ π₁ · f , π₂ · g ⟩. Local Notation "f '⊗₁' g" := (pair_1cell f g). Definition pair_1cell_pr1 {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : invertible_2cell (f ⊗₁ g · π₁) (π₁ · f) := prod_1cell_pr1 (π₁ · f) (π₂ · g). Definition pair_1cell_pr2 {a₁ a₂ b₁ b₂ : B} (f : a₁ --> b₁) (g : a₂ --> b₂) : invertible_2cell (f ⊗₁ g · π₂) (π₂ · g) := prod_1cell_pr2 (π₁ · f) (π₂ · g). Definition prod_2cell {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ⟨ f₁ , g₁ ⟩ ==> ⟨ f₂ , g₂ ⟩. Proof. use (binprod_ump_2cell (pr2 (binprod_of B b₁ b₂))). - exact (prod_1cell_pr1 f₁ g₁ • α • (prod_1cell_pr1 f₂ g₂)^-1). - exact (prod_1cell_pr2 f₁ g₁ • β • (prod_1cell_pr2 f₂ g₂)^-1). Defined. Local Notation "⟪ α , β ⟫" := (prod_2cell α β). Definition prod_2cell_is_invertible {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} {α : f₁ ==> f₂} {β : g₁ ==> g₂} (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β) : is_invertible_2cell ⟪ α , β ⟫. Proof. use binprod_ump_2cell_invertible. - is_iso. apply property_from_invertible_2cell. - is_iso. apply property_from_invertible_2cell. Defined. Definition prod_2cell_pr1 {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ⟪ α , β ⟫ ▹ π₁ = prod_1cell_pr1 f₁ g₁ • α • (prod_1cell_pr1 f₂ g₂)^-1 := binprod_ump_2cell_pr1 _ _ _. Definition prod_2cell_pr2 {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ⟪ α , β ⟫ ▹ π₂ = prod_1cell_pr2 f₁ g₁ • β • (prod_1cell_pr2 f₂ g₂)^-1 := binprod_ump_2cell_pr2 _ _ _. Definition prod_2cell_pr1_alt {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ⟪ α , β ⟫ ▹ π₁ • prod_1cell_pr1 f₂ g₂ = prod_1cell_pr1 f₁ g₁ • α. Proof. use vcomp_move_R_Mp. { apply property_from_invertible_2cell. } apply prod_2cell_pr1. Qed. Definition prod_2cell_pr2_alt {a b₁ b₂ : B} {f₁ f₂ : a --> b₁} {g₁ g₂ : a --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : ⟪ α , β ⟫ ▹ π₂ • prod_1cell_pr2 f₂ g₂ = prod_1cell_pr2 f₁ g₁ • β. Proof. use vcomp_move_R_Mp. { apply property_from_invertible_2cell. } apply prod_2cell_pr2. Qed. Definition pair_2cell {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : f₁ ⊗₁ g₁ ==> f₂ ⊗₁ g₂ := prod_2cell (π₁ ◃ α) (π₂ ◃ β). Local Notation "α '⊗₂' β" := (pair_2cell α β). Definition pair_2cell_pr1 {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : (α ⊗₂ β) ▹ π₁ = prod_1cell_pr1 (π₁ · f₁) (π₂ · g₁) • (π₁ ◃ α) • (prod_1cell_pr1 (π₁ · f₂) (π₂ · g₂))^-1 := prod_2cell_pr1 (π₁ ◃ α) (π₂ ◃ β). Definition pair_2cell_pr2 {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : (α ⊗₂ β) ▹ π₂ = prod_1cell_pr2 (π₁ · f₁) (π₂ · g₁) • (π₂ ◃ β) • (prod_1cell_pr2 (π₁ · f₂) (π₂ · g₂))^-1 := prod_2cell_pr2 (π₁ ◃ α) (π₂ ◃ β). Definition pair_2cell_pr1_alt {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : (α ⊗₂ β) ▹ π₁ • prod_1cell_pr1 (π₁ · f₂) (π₂ · g₂) = prod_1cell_pr1 (π₁ · f₁) (π₂ · g₁) • (π₁ ◃ α) := prod_2cell_pr1_alt (π₁ ◃ α) (π₂ ◃ β). Definition pair_2cell_pr2_alt {a₁ a₂ b₁ b₂ : B} {f₁ f₂ : a₁ --> b₁} {g₁ g₂ : a₂ --> b₂} (α : f₁ ==> f₂) (β : g₁ ==> g₂) : (α ⊗₂ β) ▹ π₂ • prod_1cell_pr2 (π₁ · f₂) (π₂ · g₂) = prod_1cell_pr2 (π₁ · f₁) (π₂ · g₁) • (π₂ ◃ β) := prod_2cell_pr2_alt (π₁ ◃ α) (π₂ ◃ β). (** Laws for product of 1-cells *) Definition precomp_prod_1cell {a b c₁ c₂ : B} (f : a --> b) (g₁ : b --> c₁) (g₂ : b --> c₂) : f · ⟨ g₁ , g₂ ⟩ ==> ⟨ f · g₁ , f · g₂ ⟩. Proof. use (binprod_ump_2cell (pr2 (binprod_of B _ _))). - exact (rassociator _ _ _ • (f ◃ prod_1cell_pr1 _ _) • (prod_1cell_pr1 _ _)^-1). - exact (rassociator _ _ _ • (f ◃ prod_1cell_pr2 _ _) • (prod_1cell_pr2 _ _)^-1). Defined. Definition precomp_prod_1cell_invertible {a b c₁ c₂ : B} (f : a --> b) (g₁ : b --> c₁) (g₂ : b --> c₂) : invertible_2cell (f · ⟨ g₁ , g₂ ⟩) ⟨ f · g₁ , f · g₂ ⟩. Proof. use make_invertible_2cell. - exact (precomp_prod_1cell f g₁ g₂). - use binprod_ump_2cell_invertible. + is_iso. apply property_from_invertible_2cell. + is_iso. apply property_from_invertible_2cell. Defined. (** Pseudofunctoriality of pairing 1-cells *) Definition pair_1cell_id_id (a b : B) : id₁ a ⊗₁ id₁ b ==> id₁ (a ⊗ b). Proof. use (binprod_ump_2cell (pr2 (binprod_of B a b))). - exact (pair_1cell_pr1 _ _ • runitor _ • linvunitor _). - exact (pair_1cell_pr2 _ _ • runitor _ • linvunitor _). Defined. Definition pair_1cell_id_id_invertible (a b : B) : invertible_2cell (id₁ a ⊗₁ id₁ b) (id₁ (a ⊗ b)). Proof. use make_invertible_2cell. - exact (pair_1cell_id_id a b). - apply binprod_ump_2cell_invertible. + is_iso. apply property_from_invertible_2cell. + is_iso. apply property_from_invertible_2cell. Defined. Definition pair_1cell_comp {a₁ a₂ a₃ b₁ b₂ b₃ : B} (f₁ : a₁ --> a₂) (f₂ : a₂ --> a₃) (g₁ : b₁ --> b₂) (g₂ : b₂ --> b₃) : (f₁ ⊗₁ g₁) · (f₂ ⊗₁ g₂) ==> (f₁ · f₂) ⊗₁ (g₁ · g₂). Proof. use (binprod_ump_2cell (pr2 (binprod_of B _ _))). - exact (rassociator _ _ _ • (_ ◃ pair_1cell_pr1 _ _) • lassociator _ _ _ • (pair_1cell_pr1 _ _ ▹ _) • rassociator _ _ _ • (pair_1cell_pr1 _ _)^-1). - exact (rassociator _ _ _ • (_ ◃ pair_1cell_pr2 _ _) • lassociator _ _ _ • (pair_1cell_pr2 _ _ ▹ _) • rassociator _ _ _ • (pair_1cell_pr2 _ _)^-1). Defined. Definition pair_1cell_comp_invertible {a₁ a₂ a₃ b₁ b₂ b₃ : B} (f₁ : a₁ --> a₂) (f₂ : a₂ --> a₃) (g₁ : b₁ --> b₂) (g₂ : b₂ --> b₃) : invertible_2cell ((f₁ ⊗₁ g₁) · (f₂ ⊗₁ g₂)) ((f₁ · f₂) ⊗₁ (g₁ · g₂)). Proof. use make_invertible_2cell. - exact (pair_1cell_comp f₁ f₂ g₁ g₂). - apply binprod_ump_2cell_invertible. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. Defined. (** Functoriality of pairing 2-cells *) Definition pair_2cell_id_id {a₁ a₂ b₁ b₂ : B} {f : a₁ --> b₁} {g : a₂ --> b₂} : id₂ f ⊗₂ id₂ g = id₂ (f ⊗₁ g). Proof. use binprod_ump_2cell_unique. - exact (pr2 (binprod_of B b₁ b₂)). - apply id₂. - apply id₂. - refine (pair_2cell_pr1 _ _ @ _). rewrite lwhisker_id2. rewrite id2_right. rewrite vcomp_rinv. apply idpath. - refine (pair_2cell_pr2 _ _ @ _). rewrite lwhisker_id2. rewrite id2_right. rewrite vcomp_rinv. apply idpath. - rewrite id2_rwhisker. apply idpath. - rewrite id2_rwhisker. apply idpath. Qed. Definition pair_2cell_comp {a₁ a₂ b₁ b₂ : B} {f₁ f₂ f₃ : a₁ --> b₁} {g₁ g₂ g₃ : a₂ --> b₂} (α₁ : f₁ ==> f₂) (β₁ : g₁ ==> g₂) (α₂ : f₂ ==> f₃) (β₂ : g₂ ==> g₃) : (α₁ • α₂) ⊗₂ (β₁ • β₂) = (α₁ ⊗₂ β₁) • (α₂ ⊗₂ β₂). Proof. use binprod_ump_2cell_unique. - exact (pr2 (binprod_of B b₁ b₂)). - exact (prod_1cell_pr1 _ _ • (π₁ ◃ (α₁ • α₂)) • (prod_1cell_pr1 _ _)^-1). - exact (prod_1cell_pr2 _ _ • (π₂ ◃ (β₁ • β₂)) • (prod_1cell_pr2 _ _)^-1). - exact (pair_2cell_pr1 _ _). - exact (pair_2cell_pr2 _ _). - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr1. } etrans. { apply maponpaths_2. apply pair_2cell_pr1. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr2. } etrans. { apply maponpaths_2. apply pair_2cell_pr2. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. (** Eta for binary products *) Definition prod_1cell_eta_map {a b₁ b₂ : B} (g : a --> b₁ ⊗ b₂) : ⟨ g · π₁ , g · π₂ ⟩ ==> g. Proof. use binprod_ump_2cell. - apply (pr2 B). - exact (prod_1cell_pr1 _ _). - exact (prod_1cell_pr2 _ _). Defined. Definition prod_1cell_eta_inv {a b₁ b₂ : B} (g : a --> b₁ ⊗ b₂) : g ==> ⟨ g · π₁ , g · π₂ ⟩. Proof. use binprod_ump_2cell. - apply (pr2 B). - exact ((prod_1cell_pr1 _ _)^-1). - exact ((prod_1cell_pr2 _ _)^-1). Defined. Definition prod_1cell_eta_map_inv {a b₁ b₂ : B} (g : a --> b₁ ⊗ b₂) : prod_1cell_eta_map g • prod_1cell_eta_inv g = id₂ _. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- rwhisker_vcomp. unfold prod_1cell_eta_map, prod_1cell_eta_inv. rewrite !binprod_ump_2cell_pr1. rewrite vcomp_rinv. rewrite id2_rwhisker. apply idpath. - rewrite <- rwhisker_vcomp. unfold prod_1cell_eta_map, prod_1cell_eta_inv. rewrite !binprod_ump_2cell_pr2. rewrite vcomp_rinv. rewrite id2_rwhisker. apply idpath. Qed. Definition prod_1cell_eta_inv_map {a b₁ b₂ : B} (g : a --> b₁ ⊗ b₂) : prod_1cell_eta_inv g • prod_1cell_eta_map g = id₂ _. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- rwhisker_vcomp. unfold prod_1cell_eta_map, prod_1cell_eta_inv. rewrite !binprod_ump_2cell_pr1. rewrite vcomp_linv. rewrite id2_rwhisker. apply idpath. - rewrite <- rwhisker_vcomp. unfold prod_1cell_eta_map, prod_1cell_eta_inv. rewrite !binprod_ump_2cell_pr2. rewrite vcomp_linv. rewrite id2_rwhisker. apply idpath. Qed. Definition prod_1cell_eta {a b₁ b₂ : B} (g : a --> b₁ ⊗ b₂) : invertible_2cell ⟨ g · π₁ , g · π₂ ⟩ g. Proof. use make_invertible_2cell. - exact (prod_1cell_eta_map g). - use make_is_invertible_2cell. + exact (prod_1cell_eta_inv g). + exact (prod_1cell_eta_map_inv g). + exact (prod_1cell_eta_inv_map g). Defined. (** Standard lemmas *) Lemma binprod_lunitor {a₁ a₂ b₁ b₂ : B} (f : a₁ --> a₂) (g : b₁ --> b₂) : lunitor (f ⊗₁ g) = ((pair_1cell_id_id_invertible _ _)^-1 ▹ f ⊗₁ g) • pair_1cell_comp (id₁ _) f (id₁ _) g • lunitor f ⊗₂ lunitor g. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. apply pair_2cell_pr1. } etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } cbn. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply id2_left. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. } rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. - rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. apply pair_2cell_pr2. } etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } cbn. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply id2_left. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. } rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. Lemma binprod_runitor {a₁ a₂ b₁ b₂ : B} (f : a₁ --> a₂) (g : b₁ --> b₂) : runitor (f ⊗₁ g) = (f ⊗₁ g ◃ (pair_1cell_id_id_invertible _ _)^-1) • pair_1cell_comp f (id₁ _) g (id₁ _) • runitor f ⊗₂ runitor g. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. apply pair_2cell_pr1. } apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } cbn. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l. rewrite <- rwhisker_hcomp. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. rewrite <- vcomp_runitor. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_left. } rewrite <- runitor_triangle. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite rinvunitor_runitor. apply lwhisker_id2. - rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. apply pair_2cell_pr2. } apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } cbn. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l. rewrite <- rwhisker_hcomp. rewrite !vassocl. refine (_ @ id2_right _). apply maponpaths. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. rewrite <- vcomp_runitor. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_left. } rewrite <- runitor_triangle. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite rinvunitor_runitor. apply lwhisker_id2. Qed. Lemma binprod_lassociator {a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : B} (f₁ : a₁ --> a₂) (g₁ : b₁ --> b₂) (f₂ : a₂ --> a₃) (g₂ : b₂ --> b₃) (f₃ : a₃ --> a₄) (g₃ : b₃ --> b₄) : f₁ ⊗₁ g₁ ◃ pair_1cell_comp f₂ f₃ g₂ g₃ • pair_1cell_comp f₁ (f₂ · f₃) g₁ (g₂ · g₃) • lassociator f₁ f₂ f₃ ⊗₂ lassociator g₁ g₂ g₃ = lassociator (f₁ ⊗₁ g₁) (f₂ ⊗₁ g₂) (f₃ ⊗₁ g₃) • (pair_1cell_comp f₁ f₂ g₁ g₂ ▹ f₃ ⊗₁ g₃) • pair_1cell_comp (f₁ · f₂) f₃ (g₁ · g₂) g₃. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. apply pair_2cell_pr1. } apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } refine (!_). etrans. { apply maponpaths. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. refine (!_). apply rassociator_rassociator. - rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. etrans. { apply maponpaths. apply pair_2cell_pr2. } apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } refine (!_). etrans. { apply maponpaths. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. refine (!_). apply rassociator_rassociator. Qed. Lemma binprod_lwhisker {a₁ a₂ a₃ b₁ b₂ b₃ : B} (f₁ : a₁ --> a₂) (f₂ : b₁ --> b₂) {g₁ h₁ : a₂ --> a₃} {g₂ h₂ : b₂ --> b₃} (τ₁ : g₁ ==> h₁) (τ₂ : g₂ ==> h₂) : pair_1cell_comp f₁ g₁ f₂ g₂ • ((f₁ ◃ τ₁) ⊗₂ (f₂ ◃ τ₂)) = ((f₁ ⊗₁ f₂) ◃ (τ₁ ⊗₂ τ₂)) • pair_1cell_comp f₁ h₁ f₂ h₂. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr1. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths_2. etrans. { apply maponpaths. apply pair_2cell_pr1. } rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocl. apply maponpaths. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. apply binprod_ump_2cell_pr1. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_lwhisker_rassociator. apply idpath. - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr2. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths_2. etrans. { apply maponpaths. apply pair_2cell_pr2. } rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocl. apply maponpaths. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. apply binprod_ump_2cell_pr2. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_lwhisker_rassociator. apply idpath. Qed. Lemma binprod_rwhisker {a₁ a₂ a₃ b₁ b₂ b₃ : B} (f₁ g₁ : a₁ --> a₂) (f₂ g₂ : b₁ --> b₂) {h₁ : a₂ --> a₃} {h₂ : b₂ --> b₃} (τ₁ : f₁ ==> g₁) (τ₂ : f₂ ==> g₂) : pair_1cell_comp f₁ h₁ f₂ h₂ • ((τ₁ ▹ h₁) ⊗₂ (τ₂ ▹ h₂)) = ((τ₁ ⊗₂ τ₂) ▹ (h₁ ⊗₁ h₂)) • pair_1cell_comp g₁ h₁ g₂ h₂. Proof. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr1. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. refine (!_). etrans. { apply maponpaths. apply binprod_ump_2cell_pr1. } etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. - rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. apply pair_2cell_pr2. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. refine (!_). etrans. { apply maponpaths. apply binprod_ump_2cell_pr2. } etrans. { rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. End StandardFunctions. Module Notations. Notation "b₁ ⊗ b₂" := (binprod _ b₁ b₂). Notation "'π₁'" := (binprod_pr1 _ _ _). Notation "'π₂'" := (binprod_pr2 _ _ _). Notation "⟨ f , g ⟩" := (prod_1cell _ f g). Notation "f '⊗₁' g" := (pair_1cell _ f g). Notation "⟪ α , β ⟫" := (prod_2cell _ α β). Notation "α '⊗₂' β" := (pair_2cell _ α β). End Notations. UniMath-20231010/UniMath/Bicategories/Limits/PullbackEquivalences.v000066400000000000000000000556221451125700300250200ustar00rootroot00000000000000(**************************************************************************** Pullbacks and equivalences Content: 1. Any two pullbacks are equivalent 2. Objects equivalent to pullbacks are pullbacks themselves ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. (** 1. Any two pullbacks are equivalent *) Section UmpMorEquiv. Context {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (cone₁ cone₂ : pb_cone f g) (H₁ : has_pb_ump cone₁) (H₂ : has_pb_ump cone₂). Definition pb_ump_mor_left_adjoint_equivalence_unit_pr1 : id₁ cone₂ · pb_cone_pr1 cone₂ ==> pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁ · pb_cone_pr1 cone₂ := lunitor _ • (pb_ump_mor_pr1 H₁ cone₂)^-1 • (_ ◃ (pb_ump_mor_pr1 H₂ cone₁)^-1) • lassociator _ _ _. Definition pb_ump_mor_left_adjoint_equivalence_unit_pr2 : id₁ cone₂ · pb_cone_pr2 cone₂ ==> pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁ · pb_cone_pr2 cone₂ := lunitor _ • (pb_ump_mor_pr2 H₁ cone₂)^-1 • (_ ◃ (pb_ump_mor_pr2 H₂ cone₁)^-1) • lassociator _ _ _. Definition pb_ump_mor_left_adjoint_equivalence_unit_cell : (_ ◃ pb_cone_cell cone₂) • lassociator _ _ _ • (pb_ump_mor_left_adjoint_equivalence_unit_pr2 ▹ _) • rassociator _ _ _ = lassociator _ _ _ • (pb_ump_mor_left_adjoint_equivalence_unit_pr1 ▹ _) • rassociator _ _ _ • (_ ◃ pb_cone_cell cone₂). Proof. unfold pb_ump_mor_left_adjoint_equivalence_unit_pr1. unfold pb_ump_mor_left_adjoint_equivalence_unit_pr2. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply idpath. } apply maponpaths. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. rewrite <- rassociator_rassociator. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite (pb_ump_mor_cell H₂). rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp, rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker, lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. apply maponpaths_2. exact (pb_ump_mor_cell H₁ cone₂). } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. rewrite rwhisker_lwhisker_rassociator. apply idpath. Qed. Definition pb_ump_mor_left_adjoint_equivalence_unit : id₁ cone₂ ==> pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁. Proof. use (pb_ump_cell H₂) ; cbn. - exact pb_ump_mor_left_adjoint_equivalence_unit_pr1. - exact pb_ump_mor_left_adjoint_equivalence_unit_pr2. - exact pb_ump_mor_left_adjoint_equivalence_unit_cell. Defined. Definition pb_ump_mor_left_adjoint_equivalence_unit_inv2cell : is_invertible_2cell pb_ump_mor_left_adjoint_equivalence_unit. Proof. use is_invertible_2cell_pb_ump_cell. - unfold pb_ump_mor_left_adjoint_equivalence_unit_pr1. is_iso. - unfold pb_ump_mor_left_adjoint_equivalence_unit_pr2. is_iso. Defined. End UmpMorEquiv. Definition pb_ump_mor_left_adjoint_equivalence {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (cone₁ cone₂ : pb_cone f g) (H₁ : has_pb_ump cone₁) (H₂ : has_pb_ump cone₂) : left_adjoint_equivalence (pb_ump_mor H₁ cone₂). Proof. use equiv_to_adjequiv. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (pb_ump_mor H₂ cone₁). - exact (pb_ump_mor_left_adjoint_equivalence_unit cone₁ cone₂ H₁ H₂). - exact ((pb_ump_mor_left_adjoint_equivalence_unit_inv2cell cone₂ cone₁ H₂ H₁)^-1). - apply pb_ump_mor_left_adjoint_equivalence_unit_inv2cell. - apply is_invertible_2cell_inv. Defined. (** 2. Objects equivalent to pullbacks are pullbacks themselves *) Section IdEquivalenceToPB. Context {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {q : B} {qpr1 qpr1' : q --> b₁} {qpr2 qpr2' : q --> b₂} (qγ : invertible_2cell (qpr1 · f) (qpr2 · g)) (qγ' : invertible_2cell (qpr1' · f) (qpr2' · g)) (H₂ : has_pb_ump (make_pb_cone q qpr1' qpr2' qγ')) (lpr1 : invertible_2cell qpr1 qpr1') (lpr2 : invertible_2cell qpr2 qpr2') (lc : qγ • (lpr2 ▹ g) = (lpr1 ▹ f) • qγ'). Definition id_left_adjoint_equivalence_to_pb_ump_1 : pb_ump_1 (make_pb_cone q qpr1 qpr2 qγ). Proof. intro qc. use make_pb_1cell. - exact (pb_ump_mor H₂ qc). - exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ lpr1) (pb_ump_mor_pr1 H₂ qc)). - exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ lpr2) (pb_ump_mor_pr2 H₂ qc)). - abstract (cbn ; use (vcomp_rcancel (_ ◃ (lpr2 ▹ g))) ; [ is_iso ; apply property_from_invertible_2cell | ] ; rewrite lwhisker_vcomp ; rewrite lc ; rewrite <- lwhisker_vcomp ; refine (maponpaths (λ z, _ • z) (pb_ump_mor_cell H₂ qc) @ _) ; cbn ; rewrite !vassocr ; rewrite rwhisker_lwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite <- rwhisker_vcomp ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite rwhisker_lwhisker_rassociator ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_vcomp ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_right ; apply idpath). Defined. Section UMP2. Context {qc : B} {φ ψ : qc --> q} (α : φ · qpr1 ==> ψ · qpr1) (β : φ · qpr2 ==> ψ · qpr2) (p : (φ ◃ qγ) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ qγ)). Lemma id_left_adjoint_equivalence_to_pb_ump_2_cell_eq : (φ ◃ qγ') • lassociator _ _ _ • (((φ ◃ lpr2 ^-1) • β • (ψ ◃ lpr2)) ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (((φ ◃ lpr1 ^-1) • α • (ψ ◃ lpr1)) ▹ f) • rassociator ψ qpr1' f • (ψ ◃ qγ'). Proof. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- lc. rewrite <- lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite p. rewrite !vassocl. do 2 apply maponpaths. rewrite lwhisker_vcomp. rewrite lc. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_lwhisker_rassociator. apply idpath. Qed. Definition id_left_adjoint_equivalence_to_pb_ump_2_cell : φ ==> ψ. Proof. use (pb_ump_cell H₂). - exact ((_ ◃ lpr1^-1) • α • (_ ◃ lpr1)). - exact ((_ ◃ lpr2^-1) • β • (_ ◃ lpr2)). - exact id_left_adjoint_equivalence_to_pb_ump_2_cell_eq. Defined. Definition id_left_adjoint_equivalence_to_pb_ump_2_cell_pr1 : id_left_adjoint_equivalence_to_pb_ump_2_cell ▹ qpr1 = α. Proof. unfold id_left_adjoint_equivalence_to_pb_ump_2_cell. use (vcomp_lcancel (φ ◃ lpr1 ^-1)). { is_iso. } use (vcomp_rcancel (ψ ◃ lpr1)). { is_iso. apply property_from_invertible_2cell. } rewrite <- vcomp_whisker. etrans. { do 2 apply maponpaths_2. apply (pb_ump_cell_pr1 H₂). } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_right. apply idpath. Qed. Definition id_left_adjoint_equivalence_to_pb_ump_2_cell_pr2 : id_left_adjoint_equivalence_to_pb_ump_2_cell ▹ qpr2 = β. Proof. unfold id_left_adjoint_equivalence_to_pb_ump_2_cell. use (vcomp_lcancel (φ ◃ lpr2 ^-1)). { is_iso. } use (vcomp_rcancel (ψ ◃ lpr2)). { is_iso. apply property_from_invertible_2cell. } rewrite <- vcomp_whisker. etrans. { do 2 apply maponpaths_2. apply (pb_ump_cell_pr2 H₂). } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_right. apply idpath. Qed. Definition id_left_adjoint_equivalence_to_pb_ump_2_unique : isaprop (∑ (γ : φ ==> ψ), γ ▹ qpr1 = α × γ ▹ qpr2 = β). Proof. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use (pb_ump_eq H₂) ; cbn. - exact ((_ ◃ lpr1^-1) • α • (_ ◃ lpr1)). - exact ((_ ◃ lpr2^-1) • β • (_ ◃ lpr2)). - exact id_left_adjoint_equivalence_to_pb_ump_2_cell_eq. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- vcomp_whisker. apply maponpaths_2. exact (pr12 ζ₁). - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- vcomp_whisker. apply maponpaths_2. exact (pr22 ζ₁). - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- vcomp_whisker. apply maponpaths_2. exact (pr12 ζ₂). - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- vcomp_whisker. apply maponpaths_2. exact (pr22 ζ₂). Qed. End UMP2. Definition id_left_adjoint_equivalence_to_pb_ump_2 : pb_ump_2 (make_pb_cone q qpr1 qpr2 qγ). Proof. intros qc φ ψ α β p. use iscontraprop1. - exact (id_left_adjoint_equivalence_to_pb_ump_2_unique _ _ p). - simple refine (_ ,, _ ,, _). + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell _ _ p). + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell_pr1 _ _ p). + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell_pr2 _ _ p). Defined. Definition id_left_adjoint_equivalence_to_pb : has_pb_ump (make_pb_cone q qpr1 qpr2 qγ). Proof. split. - exact id_left_adjoint_equivalence_to_pb_ump_1. - exact id_left_adjoint_equivalence_to_pb_ump_2. Defined. End IdEquivalenceToPB. Definition left_adjoint_equivalence_eq_to_pb {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (cone₁ cone₂ : pb_cone f g) (H₂ : has_pb_ump cone₂) (p : pr1 cone₁ = pr1 cone₂) (qp1 : invertible_2cell (idtoiso_2_0 _ _ (!p) · pb_cone_pr1 cone₁) (pb_cone_pr1 cone₂)) (qp2 : invertible_2cell (idtoiso_2_0 _ _ (!p) · pb_cone_pr2 cone₁) (pb_cone_pr2 cone₂)) (path : (qp1^-1 ▹ f) • rassociator _ _ _ • (_ ◃ pb_cone_cell cone₁) • lassociator _ _ _ • (qp2 ▹ g) = pr1 (pb_cone_cell cone₂)) : has_pb_ump cone₁. Proof. induction cone₁ as [ q cone ]. induction cone as [ qp₁ cone ]. induction cone as [ qp₂ γ ]. induction cone₂ as [ q' cone ]. induction cone as [ qp₁' cone ]. induction cone as [ qp₂' γ' ]. cbn in *. induction p ; cbn in *. use (id_left_adjoint_equivalence_to_pb _ _ H₂). - exact (comp_of_invertible_2cell (linvunitor_invertible_2cell _) qp1). - exact (comp_of_invertible_2cell (linvunitor_invertible_2cell _) qp2). - abstract (cbn ; use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ; refine (_ @ path) ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; apply maponpaths_2 ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite lunitor_triangle ; rewrite vcomp_lunitor ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- lunitor_triangle ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; apply idpath). Defined. Section EquivalenceToPBHelp. Context {B : bicat} (HB_2_0 : is_univalent_2_0 B) {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (cone₁ cone₂ : pb_cone f g) (H₂ : has_pb_ump cone₂) (l : cone₁ --> cone₂) (Hl : left_adjoint_equivalence l) (r := left_adjoint_right_adjoint Hl) (rpr1 : invertible_2cell (r · pb_cone_pr1 cone₁) (pb_cone_pr1 cone₂)) (rpr2 : invertible_2cell (r · pb_cone_pr2 cone₁) (pb_cone_pr2 cone₂)) (path : (r ◃ pb_cone_cell cone₁) • lassociator _ _ _ • (rpr2 ▹ g) = lassociator _ _ _ • (rpr1 ▹ f) • pr1 (pb_cone_cell cone₂)). Local Definition help_inv2cell : invertible_2cell (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl))) r. Proof. apply idtoiso_2_1. cbn. rewrite idtoiso_2_0_inv. rewrite idtoiso_2_0_isotoid_2_0. apply idpath. Qed. Definition left_adjoint_equivalence_to_pb_help_pr1 : invertible_2cell (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl)) · pb_cone_pr1 cone₁) (pb_cone_pr1 cone₂) := comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ help_inv2cell) rpr1. Definition left_adjoint_equivalence_to_pb_help_pr2 : invertible_2cell (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl)) · pb_cone_pr2 cone₁) (pb_cone_pr2 cone₂) := comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ help_inv2cell) rpr2. Definition left_adjoint_equivalence_to_pb_help_path : (left_adjoint_equivalence_to_pb_help_pr1^-1 ▹ f) • rassociator _ _ _ • (_ ◃ pb_cone_cell cone₁) • lassociator _ _ _ • (left_adjoint_equivalence_to_pb_help_pr2 ▹ g) = pr1 (pb_cone_cell cone₂). Proof. cbn. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ]. rewrite !vassocr. exact path. Qed. Definition left_adjoint_equivalence_to_pb_help : has_pb_ump cone₁. Proof. use (left_adjoint_equivalence_eq_to_pb _ _ H₂). - exact (isotoid_2_0 HB_2_0 (l ,, Hl)). - exact left_adjoint_equivalence_to_pb_help_pr1. - exact left_adjoint_equivalence_to_pb_help_pr2. - exact left_adjoint_equivalence_to_pb_help_path. Defined. End EquivalenceToPBHelp. Section LeftAdjointEquivalenceToPB. Context {B : bicat} (HB_2_0 : is_univalent_2_0 B) {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (cone₁ cone₂ : pb_cone f g) (H₂ : has_pb_ump cone₂) (l : cone₁ --> cone₂) (Hl : left_adjoint_equivalence l) (lpr1 : invertible_2cell (l · pb_cone_pr1 cone₂) (pb_cone_pr1 cone₁)) (lpr2 : invertible_2cell (l · pb_cone_pr2 cone₂) (pb_cone_pr2 cone₁)) (path : (_ ◃ pb_cone_cell cone₂) • lassociator _ _ _ • (lpr2 ▹ g) = lassociator _ _ _ • (lpr1 ▹ f) • pb_cone_cell cone₁). Let r : cone₂ --> cone₁ := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso Hl. Definition left_adjoint_equivalence_to_pb_pr1 : invertible_2cell (r · pb_cone_pr1 cone₁) (pb_cone_pr1 cone₂) := comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell lpr1)) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ ε) (lunitor_invertible_2cell _))). Definition left_adjoint_equivalence_to_pb_pr2 : invertible_2cell (r · pb_cone_pr2 cone₁) (pb_cone_pr2 cone₂) := comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell lpr2)) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ ε) (lunitor_invertible_2cell _))). Definition left_adjoint_equivalence_to_pb_eq : (r ◃ pb_cone_cell cone₁) • lassociator _ _ _ • (left_adjoint_equivalence_to_pb_pr2 ▹ g) = lassociator _ _ _ • (left_adjoint_equivalence_to_pb_pr1 ▹ f) • pr1 (pb_cone_cell cone₂). Proof. cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. use (vcomp_lcancel (r ◃ lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !lwhisker_vcomp. rewrite <- path. rewrite <- !lwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. apply idpath. } etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. Qed. Definition left_adjoint_equivalence_to_pb : has_pb_ump cone₁. Proof. use (left_adjoint_equivalence_to_pb_help HB_2_0 _ _ H₂ l Hl). - exact left_adjoint_equivalence_to_pb_pr1. - exact left_adjoint_equivalence_to_pb_pr2. - exact left_adjoint_equivalence_to_pb_eq. Defined. End LeftAdjointEquivalenceToPB. UniMath-20231010/UniMath/Bicategories/Limits/PullbackFunctions.v000066400000000000000000001315001451125700300243320ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. Section Functions. Context {B : bicat_with_pb}. Definition pb_obj {b₁ b₂ b₃ : B} (f : b₁ --> b₃) (g : b₂ --> b₃) : B := pr1 (pr2 B _ _ _ f g). Local Notation "f '/≃' g" := (pb_obj f g) (at level 40). Definition pb_pr1 {b₁ b₂ b₃ : B} (f : b₁ --> b₃) (g : b₂ --> b₃) : f /≃ g --> b₁ := pb_cone_pr1 (pr1 (pr2 B _ _ _ f g)). Local Notation "'π₁'" := (pb_pr1 _ _). Definition pb_pr2 {b₁ b₂ b₃ : B} (f : b₁ --> b₃) (g : b₂ --> b₃) : f /≃ g --> b₂ := pb_cone_pr2 (pr1 (pr2 B _ _ _ f g)). Local Notation "'π₂'" := (pb_pr2 _ _). Definition pb_cell {b₁ b₂ b₃ : B} (f : b₁ --> b₃) (g : b₂ --> b₃) : invertible_2cell (π₁ · f) (π₂ · g) := pb_cone_cell (pr1 (pr2 B _ _ _ f g)). Definition pb_obj_has_pb_ump {b₁ b₂ b₃ : B} (f : b₁ --> b₃) (g : b₂ --> b₃) : has_pb_ump (make_pb_cone (f /≃ g) π₁ π₂ (pb_cell f g)) := pr2 (pr2 B _ _ _ f g). Definition mor_to_pb_obj {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (h₁ : a --> b₁) (h₂ : a --> b₂) (γ : invertible_2cell (h₁ · f) (h₂ · g)) : a --> f /≃ g. Proof. pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g). exact (pb_ump_mor (pr2 (pr2 B _ _ _ f g)) q). Defined. Local Notation "h₁ ⊗[ γ ] h₂" := (mor_to_pb_obj h₁ h₂ γ) (at level 10). Definition mor_to_pb_obj_pr1 {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (h₁ : a --> b₁) (h₂ : a --> b₂) (γ : invertible_2cell (h₁ · f) (h₂ · g)) : invertible_2cell (h₁ ⊗[ γ ] h₂ · π₁) h₁. Proof. pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g). exact (pb_ump_mor_pr1 (pr2 (pr2 B _ _ _ f g)) q). Defined. Definition mor_to_pb_obj_pr2 {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (h₁ : a --> b₁) (h₂ : a --> b₂) (γ : invertible_2cell (h₁ · f) (h₂ · g)) : invertible_2cell (h₁ ⊗[ γ ] h₂ · π₂) h₂. Proof. pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g). exact (pb_ump_mor_pr2 (pr2 (pr2 B _ _ _ f g)) q). Defined. Definition mor_to_pb_obj_cell {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} (h₁ : a --> b₁) (h₂ : a --> b₂) (γ : invertible_2cell (h₁ · f) (h₂ · g)) : (h₁ ⊗[ γ ] h₂) ◃ pb_cell f g = lassociator _ _ _ • (mor_to_pb_obj_pr1 h₁ h₂ γ ▹ f) • γ • ((mor_to_pb_obj_pr2 h₁ h₂ γ)^-1 ▹ g) • rassociator _ _ _. Proof. pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g). exact (pb_ump_mor_cell (pr2 (pr2 B _ _ _ f g)) q). Defined. Definition cell_to_pb_obj_homot {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {h₁ h₂ : a --> f /≃ g} (α : h₁ · π₁ ==> h₂ · π₁) (β : h₁ · π₂ ==> h₂ · π₂) : UU := (h₁ ◃ pb_cell f g) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (h₂ ◃ pb_cell f g). Definition cell_to_pb_obj {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {h₁ h₂ : a --> f /≃ g} (α : h₁ · π₁ ==> h₂ · π₁) (β : h₁ · π₂ ==> h₂ · π₂) (p : cell_to_pb_obj_homot α β) : h₁ ==> h₂ := pb_ump_cell (pr2 (pr2 B _ _ _ f g)) h₁ h₂ α β p. Definition cell_to_pb_obj_pr1 {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {h₁ h₂ : a --> f /≃ g} (α : h₁ · π₁ ==> h₂ · π₁) (β : h₁ · π₂ ==> h₂ · π₂) (p : cell_to_pb_obj_homot α β) : cell_to_pb_obj α β p ▹ π₁ = α. Proof. exact (pb_ump_cell_pr1 (pr2 (pr2 B _ _ _ f g)) h₁ h₂ α β p). Qed. Definition cell_to_pb_obj_pr2 {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {h₁ h₂ : a --> f /≃ g} (α : h₁ · π₁ ==> h₂ · π₁) (β : h₁ · π₂ ==> h₂ · π₂) (p : cell_to_pb_obj_homot α β) : cell_to_pb_obj α β p ▹ π₂ = β. Proof. exact (pb_ump_cell_pr2 (pr2 (pr2 B _ _ _ f g)) h₁ h₂ α β p). Qed. Definition eq_to_pb_obj {a b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃} {h₁ h₂ : a --> f /≃ g} {φ ψ : h₁ ==> h₂} {p : cell_to_pb_obj_homot (φ ▹ π₁) (φ ▹ π₂)} (φψpr1 : φ ▹ π₁ = ψ ▹ π₁) (φψpr2 : φ ▹ π₂ = ψ ▹ π₂) : φ = ψ := pb_ump_eq (pr2 (pr2 B _ _ _ f g)) h₁ h₂ (φ ▹ π₁) (φ ▹ π₂) p φ ψ (idpath _) (idpath _) (!φψpr1) (!φψpr2). Definition help_pb_on_1cell {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h : b₂ --> c₂} (β : invertible_2cell g₁ (h · g₂)) : invertible_2cell (π₁ · f) (π₂ · h · g₂) := comp_of_invertible_2cell (pb_cell f g₁) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ β) (lassociator_invertible_2cell _ _ _)). Definition pb_on_1cell {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h : b₂ --> c₂} (β : invertible_2cell g₁ (h · g₂)) : f /≃ g₁ --> f /≃ g₂. Proof. simple refine (_ ⊗[ _ ] _). - exact π₁. - exact (π₂ · h). - exact (help_pb_on_1cell f β). Defined. Local Notation "f /≃₁ β" := (pb_on_1cell f β) (at level 40). Definition pb_on_1cell_pr1 {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h : b₂ --> c₂} (β : invertible_2cell g₁ (h · g₂)) : invertible_2cell (f /≃₁ β · π₁) π₁. Proof. apply mor_to_pb_obj_pr1. Defined. Definition pb_on_1cell_pr2 {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h : b₂ --> c₂} (β : invertible_2cell g₁ (h · g₂)) : invertible_2cell (f /≃₁ β · π₂) (π₂ · h). Proof. apply mor_to_pb_obj_pr2. Defined. Definition pb_on_1cell_cell {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h : b₂ --> c₂} (β : invertible_2cell g₁ (h · g₂)) : f /≃₁ β ◃ pb_cell f g₂ = lassociator _ _ _ • (pb_on_1cell_pr1 f β ▹ f) • pb_cell f g₁ • (π₂ ◃ β) • lassociator _ _ _ • ((pb_on_1cell_pr2 f β)^-1 ▹ g₂) • rassociator _ _ _. Proof. pose (mor_to_pb_obj_cell π₁ (π₂ · h) (comp_of_invertible_2cell (pb_cell f g₁) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ β) (lassociator_invertible_2cell _ _ _)))). cbn in p. refine (p @ _). rewrite !vassocl. apply idpath. Qed. Section PBOn2Cell. Context {b₁ b₂ c₂ b₃ : B} (f : b₁ --> b₃) {g₁ : b₂ --> b₃} {g₂ : c₂ --> b₃} {h₁ h₂ : b₂ --> c₂} {β₁ : invertible_2cell g₁ (h₁ · g₂)} {β₂ : invertible_2cell g₁ (h₂ · g₂)} {α : h₁ ==> h₂} (p : β₁ • (α ▹ g₂) = β₂). Let k₁ : f /≃₁ β₁ · π₁ ==> f /≃₁ β₂ · π₁ := pb_on_1cell_pr1 _ _ • (pb_on_1cell_pr1 _ _)^-1. Let k₂ : f /≃₁ β₁ · π₂ ==> f /≃₁ β₂ · π₂ := pb_on_1cell_pr2 _ _ • (π₂ ◃ α) • (pb_on_1cell_pr2 _ _)^-1. Lemma pb_on_2cell_homot : cell_to_pb_obj_homot k₁ k₂. Proof. unfold cell_to_pb_obj_homot, k₁, k₂. rewrite pb_on_1cell_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. etrans. { do 3 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. rewrite pb_on_1cell_cell. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. exact (!p). Qed. Definition pb_on_2cell : f /≃₁ β₁ ==> f /≃₁ β₂. Proof. use cell_to_pb_obj. - exact k₁. - exact k₂. - exact pb_on_2cell_homot. Defined. Definition pb_on_2cell_pr1 : pb_on_2cell ▹ π₁ = k₁. Proof. apply cell_to_pb_obj_pr1. Qed. Definition pb_on_2cell_pr2 : pb_on_2cell ▹ π₂ = k₂. Proof. apply cell_to_pb_obj_pr2. Qed. End PBOn2Cell. Local Notation "f /≃₂ p" := (pb_on_2cell f p) (at level 40). Section PBOnId. Context {a b₁ b₂ : B} (f : b₁ --> b₂) (g : a --> b₂). Let k₁ : id₁ (f /≃ g) · π₁ ==> f /≃₁ linvunitor_invertible_2cell g · π₁ := lunitor _ • (pb_on_1cell_pr1 _ _)^-1. Let k₂ : id₁ (f /≃ g) · π₂ ==> f /≃₁ linvunitor_invertible_2cell g · π₂ := lunitor _ • rinvunitor _ • (pb_on_1cell_pr2 _ _)^-1. Lemma pb_1cell_on_id_homot : cell_to_pb_obj_homot k₁ k₂. Proof. unfold cell_to_pb_obj_homot, k₁, k₂. rewrite <- !rwhisker_vcomp. rewrite !vassocl. pose (pb_on_1cell_cell f (linvunitor_invertible_2cell g)) as p. cbn in p. rewrite p. rewrite !vassocl. refine (!_). etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lunitor_triangle. rewrite <- vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite <- lunitor_triangle. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. apply idpath. Qed. Definition pb_1cell_on_id : id₁ (f /≃ g) ==> f /≃₁ linvunitor_invertible_2cell g. Proof. use cell_to_pb_obj. - exact k₁. - exact k₂. - exact pb_1cell_on_id_homot. Defined. Definition pb_1cell_on_id_pr1 : pb_1cell_on_id ▹ π₁ = k₁. Proof. apply cell_to_pb_obj_pr1. Qed. Definition pb_1cell_on_id_pr2 : pb_1cell_on_id ▹ π₂ = k₂. Proof. apply cell_to_pb_obj_pr2. Qed. End PBOnId. Section PBOnComp. Context {a₁ a₂ a₃ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {g₃ : a₃ --> b₂} {h₁ : a₁ --> a₂} {h₂ : a₂ --> a₃} (α : invertible_2cell g₁ (h₁ · g₂)) (β : invertible_2cell g₂ (h₂ · g₃)). Let γ : invertible_2cell g₁ (h₁ · h₂ · g₃) := comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ β) (lassociator_invertible_2cell _ _ _)). Let k₁ : f /≃₁ α · (f /≃₁ β) · π₁ ==> f /≃₁ γ · π₁ := rassociator _ _ _ • (_ ◃ pb_on_1cell_pr1 _ _) • pb_on_1cell_pr1 _ _ • (pb_on_1cell_pr1 _ _)^-1. Let k₂ : f /≃₁ α · (f /≃₁ β) · π₂ ==> f /≃₁ γ · π₂ := rassociator _ _ _ • (_ ◃ pb_on_1cell_pr2 _ _) • lassociator _ _ _ • (pb_on_1cell_pr2 _ _ ▹ _) • rassociator _ _ _ • (pb_on_1cell_pr2 _ _)^-1. Lemma pb_1cell_on_comp_homot : cell_to_pb_obj_homot k₁ k₂. Proof. unfold cell_to_pb_obj_homot, k₁, k₂. rewrite <- !rwhisker_vcomp. rewrite (pb_on_1cell_cell f γ). rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite <- lassociator_lassociator. rewrite (pb_on_1cell_cell f β). rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } refine (!_). etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. do 4 apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_right. apply idpath. } etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. cbn. rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn). rewrite !vassocl. refine (!_). etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite (pb_on_1cell_cell f α). rewrite !vassocl. do 3 apply maponpaths. refine (_ @ id2_right _). apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } apply lassociator_rassociator. Qed. Definition pb_1cell_on_comp : f /≃₁ α · (f /≃₁ β) ==> f /≃₁ γ. Proof. use cell_to_pb_obj. - exact k₁. - exact k₂. - exact pb_1cell_on_comp_homot. Defined. Definition pb_1cell_on_comp_pr1 : pb_1cell_on_comp ▹ π₁ = k₁. Proof. apply cell_to_pb_obj_pr1. Qed. Definition pb_1cell_on_comp_pr2 : pb_1cell_on_comp ▹ π₂ = k₂. Proof. apply cell_to_pb_obj_pr2. Qed. End PBOnComp. Definition pb_2cell_on_id {a₁ a₂ b₁ b₂ : B} {f : b₁ --> b₂} {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {h : a₁ --> a₂} (α : invertible_2cell g₁ (h · g₂)) (p : α • (id₂ h ▹ g₂) = α) : f /≃₂ p = id₂ _. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite rwhisker_rwhisker. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite vcomp_whisker. apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - rewrite pb_on_2cell_pr1, id2_rwhisker. apply vcomp_rinv. - rewrite pb_on_2cell_pr2, id2_rwhisker, lwhisker_id2. rewrite id2_right. apply vcomp_rinv. Qed. Definition pb_on_2cell_coh {a₁ a₂ b₁ b₂ : B} {f : b₁ --> b₂} {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {h₁ h₂ : a₁ --> a₂} (α : invertible_2cell g₁ (h₁ · g₂)) (β : invertible_2cell g₁ (h₂ · g₂)) (γ : h₁ ==> h₂) (p : α • (γ ▹ _) = β) : (pb_on_1cell_pr1 f α)^-1 • (f /≃₂ p ▹ π₁) = (pb_on_1cell_pr1 f β)^-1. Proof. cbn. rewrite pb_on_2cell_pr1. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. Definition pb_1cell_on_id_coh {a b₁ b₂ : B} (f : b₁ --> b₂) (g : a --> b₂) : linvunitor π₁ • (pb_1cell_on_id f g ▹ π₁) = (pb_on_1cell_pr1 f (linvunitor_invertible_2cell g))^-1. Proof. cbn. rewrite pb_1cell_on_id_pr1. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. Qed. Definition pb_1cell_on_comp_coh {a₁ a₂ a₃ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {g₃ : a₃ --> b₂} {h₁ : a₁ --> a₂} {h₂ : a₂ --> a₃} (α : invertible_2cell g₁ (h₁ · g₂)) (β : invertible_2cell g₂ (h₂ · g₃)) : (pb_on_1cell_pr1 f α)^-1 • ((f /≃₁ α ◃ (pb_on_1cell_pr1 f β)^-1) • lassociator (f /≃₁ α) (f /≃₁ β) π₁) • (pb_1cell_on_comp f α β ▹ π₁) = (pb_on_1cell_pr1 f (comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ β) (lassociator_invertible_2cell _ _ _)))) ^-1. Proof. rewrite pb_1cell_on_comp_pr1. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite vcomp_linv. apply id2_left. Qed. Definition pb_2cell_on_comp {a₁ a₂ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {h₁ h₂ h₃ : a₁ --> a₂} {α : invertible_2cell g₁ (h₁ · g₂)} {β : invertible_2cell g₁ (h₂ · g₂)} {γ : invertible_2cell g₁ (h₃ · g₂)} (δ₁ : h₁ ==> h₂) (p : α • (δ₁ ▹ g₂) = β) (δ₂ : h₂ ==> h₃) (q : β • (δ₂ ▹ g₂) = γ) (r : α • ((δ₁ • δ₂) ▹ g₂) = γ) : f /≃₂ r = f /≃₂ p • f /≃₂ q. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite rwhisker_rwhisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } rewrite lassociator_rassociator. rewrite id2_right. rewrite <- vcomp_whisker. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - rewrite <- rwhisker_vcomp. rewrite !pb_on_2cell_pr1. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. - rewrite <- rwhisker_vcomp. rewrite !pb_on_2cell_pr2. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. Definition pb_2cell_on_lunitor {a₁ a₂ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {h : a₁ --> a₂} (α : invertible_2cell g₁ (h · g₂)) (p : comp_of_invertible_2cell (linvunitor_invertible_2cell g₁) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell (id₁ a₁) α) (lassociator_invertible_2cell (id₁ a₁) h g₂)) • (lunitor h ▹ g₂) = α) : lunitor (f /≃₁ α) = (pb_1cell_on_id f g₁ ▹ f /≃₁ α) • pb_1cell_on_comp f (linvunitor_invertible_2cell g₁) α • f /≃₂ p. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite rwhisker_rwhisker. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite vcomp_whisker. apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite pb_on_2cell_pr1, pb_1cell_on_comp_pr1. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite pb_1cell_on_id_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite vcomp_lunitor. rewrite !vassocr. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite pb_on_2cell_pr2, pb_1cell_on_comp_pr2. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. do 2 (use vcomp_move_L_Mp ; [ is_iso | ] ; cbn). rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } rewrite pb_1cell_on_id_pr2. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. Definition pb_2cell_on_runitor {a₁ a₂ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {h : a₁ --> a₂} (α : invertible_2cell g₁ (h · g₂)) (p : comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h (linvunitor_invertible_2cell g₂)) (lassociator_invertible_2cell h (id₁ a₂) g₂)) • (runitor h ▹ g₂) = α) : runitor (f /≃₁ α) = (f /≃₁ α ◃ pb_1cell_on_id f g₂) • pb_1cell_on_comp f α (linvunitor_invertible_2cell g₂) • f /≃₂ p. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } rewrite vcomp_whisker. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr1, pb_1cell_on_comp_pr1. rewrite !vassocl. refine (!_). etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } rewrite vcomp_rinv. rewrite id2_right. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite pb_1cell_on_id_pr1. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite lunitor_lwhisker. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr2, pb_1cell_on_comp_pr2. rewrite !vassocl. refine (!_). etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. rewrite <- vcomp_runitor. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_left. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite pb_1cell_on_id_pr2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite <- runitor_triangle. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_lwhisker. apply idpath. Qed. Definition pb_2cell_on_lassociator {a₁ a₂ a₃ a₄ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {g₃ : a₃ --> b₂} {g₄ : a₄ --> b₂} {h₁ : a₁ --> a₂} {h₂ : a₂ --> a₃} {h₃ : a₃ --> a₄} (α : invertible_2cell g₁ (h₁ · g₂)) (β : invertible_2cell g₂ (h₂ · g₃)) (γ : invertible_2cell g₃ (h₃ · g₄)) (p : comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ (comp_of_invertible_2cell β (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₂ γ) (lassociator_invertible_2cell h₂ h₃ g₄)))) (lassociator_invertible_2cell h₁ (h₂ · h₃) g₄)) • (lassociator h₁ h₂ h₃ ▹ g₄) = comp_of_invertible_2cell (comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ β) (lassociator_invertible_2cell h₁ h₂ g₃))) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell (h₁ · h₂) γ) (lassociator_invertible_2cell (h₁ · h₂) h₃ g₄))) : (f /≃₁ α ◃ pb_1cell_on_comp f β γ) • pb_1cell_on_comp f α _ • f /≃₂ p = lassociator _ _ _ • (pb_1cell_on_comp f α β ▹ _) • pb_1cell_on_comp f _ γ. Proof. cbn in p. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite !vassocl. etrans. { apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } refine (!_). etrans. { rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. apply id2_right. } rewrite vcomp_whisker. rewrite !vassocl. apply idpath. - rewrite <- !rwhisker_vcomp. etrans. { rewrite !pb_1cell_on_comp_pr1, !pb_on_2cell_pr1. rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite pb_1cell_on_comp_pr1. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } apply idpath. } rewrite pb_1cell_on_comp_pr1. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite pb_1cell_on_comp_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite pb_1cell_on_comp_pr2. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite pb_1cell_on_comp_pr2. rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn). rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_right. apply idpath. Qed. Definition pb_2cell_on_lwhisker {a₁ a₂ a₃ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {g₃ : a₃ --> b₂} {h₁ : a₁ --> a₂} {h₂ h₃ : a₂ --> a₃} (α : invertible_2cell g₁ (h₁ · g₂)) {β₁ : invertible_2cell g₂ (h₂ · g₃)} {β₂ : invertible_2cell g₂ (h₃ · g₃)} {γ : h₂ ==> h₃} (p : β₁ • (γ ▹ g₃) = β₂) (q : comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ β₁) (lassociator_invertible_2cell h₁ h₂ g₃)) • ((h₁ ◃ γ) ▹ g₃) = comp_of_invertible_2cell α (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ β₂) (lassociator_invertible_2cell h₁ h₃ g₃))) : pb_1cell_on_comp f α β₁ • f /≃₂ q = (f /≃₁ α ◃ f /≃₂ p) • pb_1cell_on_comp f α β₂. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. apply id2_right. } rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr1, !pb_1cell_on_comp_pr1. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite pb_on_2cell_pr1. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite pb_on_2cell_pr2. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_lwhisker_rassociator. apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. Qed. Definition pb_2cell_on_rwhisker {a₁ a₂ a₃ b₁ b₂ : B} (f : b₁ --> b₂) {g₁ : a₁ --> b₂} {g₂ : a₂ --> b₂} {g₃ : a₃ --> b₂} {h₁ h₂ : a₁ --> a₂} {h₃ : a₂ --> a₃} {α₁ : invertible_2cell g₁ (h₁ · g₂)} {α₂ : invertible_2cell g₁ (h₂ · g₂)} (β : invertible_2cell g₂ (h₃ · g₃)) {γ : h₁ ==> h₂} (p : α₁ • (γ ▹ g₂) = α₂) (q : comp_of_invertible_2cell α₁ (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₁ β) (lassociator_invertible_2cell h₁ h₃ g₃)) • ((γ ▹ h₃) ▹ g₃) = comp_of_invertible_2cell α₂ (comp_of_invertible_2cell (lwhisker_of_invertible_2cell h₂ β) (lassociator_invertible_2cell h₂ h₃ g₃))) : pb_1cell_on_comp f α₁ β • f /≃₂ q = (f /≃₂ p ▹ f /≃₁ β) • pb_1cell_on_comp f α₂ β. Proof. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot. rewrite !vassocl. etrans. { apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } refine (!_). etrans. { rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. apply id2_right. } rewrite vcomp_whisker. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr1, !pb_1cell_on_comp_pr1. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite vcomp_linv. rewrite id2_right. rewrite !vassocr. rewrite vcomp_whisker. rewrite pb_on_2cell_pr1. rewrite !vassocl. apply maponpaths. rewrite vcomp_linv. rewrite id2_right. apply idpath. - rewrite <- !rwhisker_vcomp. rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !rwhisker_vcomp. apply maponpaths. rewrite pb_on_2cell_pr2. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. Qed. End Functions. Module Notations. Notation "f '/≃' g" := (pb_obj f g) (at level 40). Notation "'π₁'" := (pb_pr1 _ _). Notation "'π₂'" := (pb_pr2 _ _). Notation "h₁ ⊗[ γ ] h₂" := (mor_to_pb_obj h₁ h₂ γ) (at level 10). Notation "f /≃₁ β" := (pb_on_1cell f β) (at level 40). Notation "f /≃₂ p" := (pb_on_2cell f p) (at level 40). End Notations. UniMath-20231010/UniMath/Bicategories/Limits/Pullbacks.v000066400000000000000000000473071451125700300226370ustar00rootroot00000000000000(**************************************************************** Pullbacks in bicategories In this file we define the notion of pullback square in arbitrary bicategories. This definition is expressed using universal properties. Content 1. Cones 2. 1-cells and 2-cells of cones 3. Statements of universal mapping properties of pullbacks 4. Being a pullback is a property (requires local univalence) 5. Bicategories with pullbacks *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Section Pullback. Context {B : bicat} {b₁ b₂ b₃ : B} {f : b₁ --> b₃} {g : b₂ --> b₃}. (** 1. Cones *) Definition pb_cone : UU := ∑ (p : B) (π₁ : p --> b₁) (π₂ : p --> b₂), invertible_2cell (π₁ · f) (π₂ · g). Coercion pb_cone_obj (p : pb_cone) : B := pr1 p. Definition pb_cone_pr1 (p : pb_cone) : p --> b₁ := pr12 p. Definition pb_cone_pr2 (p : pb_cone) : p --> b₂ := pr122 p. Definition pb_cone_cell (p : pb_cone) : invertible_2cell (pb_cone_pr1 p · f) (pb_cone_pr2 p · g) := pr222 p. Definition make_pb_cone (p : B) (π₁ : p --> b₁) (π₂ : p --> b₂) (η : invertible_2cell (π₁ · f) (π₂ · g)) : pb_cone := (p ,, π₁ ,, π₂ ,, η). (** 2. 1-cells and 2-cells of cones *) Definition pb_1cell (p q : pb_cone) : UU := ∑ (φ : p --> q) (τ : invertible_2cell (φ · pb_cone_pr1 q) (pb_cone_pr1 p)) (θ : invertible_2cell (φ · pb_cone_pr2 q) (pb_cone_pr2 p)), φ ◃ pb_cone_cell q = lassociator _ _ _ • (τ ▹ f) • pb_cone_cell p • (θ^-1 ▹ g) • rassociator _ _ _. Coercion pb_1cell_1cell {p q : pb_cone} (φ : pb_1cell p q) : p --> q := pr1 φ. Definition pb_1cell_pr1 {p q : pb_cone} (φ : pb_1cell p q) : invertible_2cell (φ · pb_cone_pr1 q) (pb_cone_pr1 p) := pr12 φ. Definition pb_1cell_pr2 {p q : pb_cone} (φ : pb_1cell p q) : invertible_2cell (φ · pb_cone_pr2 q) (pb_cone_pr2 p) := pr122 φ. Definition pb_1cell_eq {p q : pb_cone} (φ : pb_1cell p q) : φ ◃ pb_cone_cell q = lassociator _ _ _ • (pb_1cell_pr1 φ ▹ f) • pb_cone_cell p • ((pb_1cell_pr2 φ)^-1 ▹ g) • rassociator _ _ _ := pr222 φ. Definition make_pb_1cell {p q : pb_cone} (φ : p --> q) (τ : invertible_2cell (φ · pb_cone_pr1 q) (pb_cone_pr1 p)) (θ : invertible_2cell (φ · pb_cone_pr2 q) (pb_cone_pr2 p)) (H : φ ◃ pb_cone_cell q = lassociator _ _ _ • (τ ▹ f) • pb_cone_cell p • (θ^-1 ▹ g) • rassociator _ _ _) : pb_1cell p q := (φ ,, τ ,, θ ,, H). Definition eq_pb_1cell {p q : pb_cone} (φ ψ : pb_1cell p q) (r₁ : pr1 φ = pr1 ψ) (r₂ : pr1 (pb_1cell_pr1 φ) = (idtoiso_2_1 _ _ r₁ ▹ pb_cone_pr1 q) • pr1 (pb_1cell_pr1 ψ)) (r₃ : pr1 (pb_1cell_pr2 φ) = (idtoiso_2_1 _ _ r₁ ▹ pb_cone_pr2 q) • pr1 (pb_1cell_pr2 ψ)) : φ = ψ. Proof. induction φ as [ φ₁ [ φ₂ [ φ₃ φ₄ ]]]. induction ψ as [ ψ₁ [ ψ₂ [ ψ₃ ψ₄ ]]]. cbn in r₁. induction r₁ ; cbn in r₂. apply maponpaths. assert (φ₂ = ψ₂) as r'. { use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } rewrite id2_rwhisker, id2_left in r₂. exact r₂. } induction r'. apply maponpaths. use subtypePath. { intro ; apply cellset_property. } cbn. cbn in r₃. rewrite id2_rwhisker, id2_left in r₃. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact r₃. Qed. Definition pb_2cell {p q : pb_cone} (φ ψ : pb_1cell p q) : UU := ∑ (η : φ ==> ψ), ((η ▹ pb_cone_pr1 q) • pb_1cell_pr1 ψ = pb_1cell_pr1 φ) × ((η ▹ pb_cone_pr2 q) • pb_1cell_pr2 ψ = pb_1cell_pr2 φ). Coercion pb_2cell_2cell {p q : pb_cone} {φ ψ : pb_1cell p q} (η : pb_2cell φ ψ) : φ ==> ψ := pr1 η. Definition pb_2cell_pr1 {p q : pb_cone} {φ ψ : pb_1cell p q} (η : pb_2cell φ ψ) : (η ▹ pb_cone_pr1 q) • pb_1cell_pr1 ψ = pb_1cell_pr1 φ := pr12 η. Definition pb_2cell_pr2 {p q : pb_cone} {φ ψ : pb_1cell p q} (η : pb_2cell φ ψ) : (η ▹ pb_cone_pr2 q) • pb_1cell_pr2 ψ = pb_1cell_pr2 φ := pr22 η. Definition make_pb_2cell {p q : pb_cone} {φ ψ : pb_1cell p q} (η : φ ==> ψ) (H₁ : (η ▹ pb_cone_pr1 q) • pb_1cell_pr1 ψ = pb_1cell_pr1 φ) (H₂ : (η ▹ pb_cone_pr2 q) • pb_1cell_pr2 ψ = pb_1cell_pr2 φ) : pb_2cell φ ψ := (η ,, H₁ ,, H₂). Definition isaset_pb_2cell {p q : pb_cone} (φ ψ : pb_1cell p q) : isaset (pb_2cell φ ψ). Proof. use isaset_total2. - apply cellset_property. - intro. apply isasetdirprod ; apply isasetaprop ; apply cellset_property. Qed. Definition id2_pb_2cell {p q : pb_cone} (φ : pb_1cell p q) : pb_2cell φ φ. Proof. use make_pb_2cell. - exact (id2 φ). - abstract (rewrite id2_rwhisker, id2_left ; apply idpath). - abstract (rewrite id2_rwhisker, id2_left ; apply idpath). Defined. Definition comp_pb_2cell {p q : pb_cone} {φ ψ χ : pb_1cell p q} (η₁ : pb_2cell φ ψ) (η₂ : pb_2cell ψ χ) : pb_2cell φ χ. Proof. use make_pb_2cell. - exact (η₁ • η₂). - abstract (rewrite <- rwhisker_vcomp ; rewrite vassocl ; rewrite !pb_2cell_pr1 ; apply idpath). - abstract (rewrite <- rwhisker_vcomp ; rewrite vassocl ; rewrite !pb_2cell_pr2 ; apply idpath). Defined. (** 3. Statements of universal mapping properties of pullbacks *) Section UniversalMappingPropertyStatements. Variable (p : pb_cone). Definition pb_ump_1 : UU := ∏ (q : pb_cone), pb_1cell q p. Definition pb_ump_2 : UU := ∏ (q : B) (φ ψ : q --> p) (α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p) (β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p) (r : (φ ◃ pb_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ pb_cone_cell p)), ∃! (γ : φ ==> ψ), (γ ▹ pb_cone_pr1 p = α) × (γ ▹ pb_cone_pr2 p = β). Definition has_pb_ump : UU := pb_ump_1 × pb_ump_2. End UniversalMappingPropertyStatements. Definition has_pb_ump_1 {p : pb_cone} (H : has_pb_ump p) : pb_ump_1 p := pr1 H. Definition has_pb_ump_2 {p : pb_cone} (H : has_pb_ump p) : pb_ump_2 p := pr2 H. Section Projections. Context {p : pb_cone} (Hp : has_pb_ump p). Definition pb_ump_mor (q : pb_cone) : q --> p := pr1 Hp q. Definition pb_ump_mor_pr1 (q : pb_cone) : invertible_2cell (pb_ump_mor q · pb_cone_pr1 p) (pb_cone_pr1 q) := pb_1cell_pr1 (pr1 Hp q). Definition pb_ump_mor_pr2 (q : pb_cone) : invertible_2cell (pb_ump_mor q · pb_cone_pr2 p) (pb_cone_pr2 q) := pb_1cell_pr2 (pr1 Hp q). Definition pb_ump_mor_cell (q : pb_cone) : pr1 Hp q ◃ pb_cone_cell p = lassociator (pr1 Hp q) (pb_cone_pr1 p) f • (pb_1cell_pr1 (pr1 Hp q) ▹ f) • pb_cone_cell q • ((pb_1cell_pr2 (pr1 Hp q)) ^-1 ▹ g) • rassociator (pr1 Hp q) (pb_cone_pr2 p) g := pb_1cell_eq (pr1 Hp q). Section CellProperty. Context {q : B} (φ ψ : q --> p) (α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p) (β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p) (r : (φ ◃ pb_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ pb_cone_cell p)). Definition pb_ump_cell : φ ==> ψ := pr11 (pr2 Hp q φ ψ α β r). Definition pb_ump_cell_pr1 : pb_ump_cell ▹ pb_cone_pr1 p = α := pr121 (pr2 Hp q φ ψ α β r). Definition pb_ump_cell_pr2 : pb_ump_cell ▹ pb_cone_pr2 p = β := pr221 (pr2 Hp q φ ψ α β r). Definition pb_ump_eq (τ₁ τ₂ : φ ==> ψ) (τ₁_pr1 : τ₁ ▹ pb_cone_pr1 p = α) (τ₁_pr2 : τ₁ ▹ pb_cone_pr2 p = β) (τ₂_pr1 : τ₂ ▹ pb_cone_pr1 p = α) (τ₂_pr2 : τ₂ ▹ pb_cone_pr2 p = β) : τ₁ = τ₂ := maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr2 Hp q φ ψ α β r)) (τ₁ ,, τ₁_pr1 ,, τ₁_pr2) (τ₂ ,, τ₂_pr1 ,, τ₂_pr2)). End CellProperty. End Projections. Section InvertiblePBUmpCell. Context {p : pb_cone} (Hp : has_pb_ump p) {q : B} {φ ψ : q --> p} {α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p} {β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p} (r : (φ ◃ pb_cone_cell p) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _ = lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ pb_cone_cell p)) (Hα : is_invertible_2cell α) (Hβ : is_invertible_2cell β). Definition is_invertible_2cell_pb_ump_cell_inv : ψ ==> φ. Proof. use (pb_ump_cell Hp _ _ (Hα^-1) (Hβ^-1)). abstract (do 3 (use vcomp_move_R_Mp ; [ is_iso | ]) ; rewrite !vassocl ; do 3 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn ; rewrite !vassocr ; exact (!r)). Defined. Lemma is_invertible_2cell_pb_ump_cell_left : pb_ump_cell Hp φ ψ α β r • is_invertible_2cell_pb_ump_cell_inv = id₂ φ. Proof. use (pb_ump_eq Hp). - apply id2. - apply id2. - rewrite !id2_rwhisker, !id2_right. rewrite lassociator_rassociator, id2_left. rewrite vassocl. rewrite lassociator_rassociator. apply id2_right. - unfold is_invertible_2cell_pb_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !pb_ump_cell_pr1. apply vcomp_rinv. - unfold is_invertible_2cell_pb_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !pb_ump_cell_pr2. apply vcomp_rinv. - apply id2_rwhisker. - apply id2_rwhisker. Qed. Lemma is_invertible_2cell_pb_ump_cell_right : is_invertible_2cell_pb_ump_cell_inv • pb_ump_cell Hp φ ψ α β r = id₂ _. Proof. use (pb_ump_eq Hp). - apply id2. - apply id2. - rewrite !id2_rwhisker, !id2_right. rewrite lassociator_rassociator, id2_left. rewrite vassocl. rewrite lassociator_rassociator. apply id2_right. - unfold is_invertible_2cell_pb_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !pb_ump_cell_pr1. apply vcomp_linv. - unfold is_invertible_2cell_pb_ump_cell_inv. rewrite <- rwhisker_vcomp. rewrite !pb_ump_cell_pr2. apply vcomp_linv. - apply id2_rwhisker. - apply id2_rwhisker. Qed. Definition is_invertible_2cell_pb_ump_cell : is_invertible_2cell (pb_ump_cell Hp φ ψ α β r). Proof. use make_is_invertible_2cell. - exact is_invertible_2cell_pb_ump_cell_inv. - exact is_invertible_2cell_pb_ump_cell_left. - exact is_invertible_2cell_pb_ump_cell_right. Defined. End InvertiblePBUmpCell. (** 4. Being a pullback is a property (requires local univalence) *) Definition isaprop_has_pb_ump (HB_2_1 : is_univalent_2_1 B) (p : pb_cone) : isaprop (has_pb_ump p). Proof. use invproofirrelevance. intros χ₁ χ₂. use subtypePath. { intro. do 6 (use impred ; intro). apply isapropiscontr. } use funextsec ; intro q. use eq_pb_1cell ; cbn. - use (isotoid_2_1 HB_2_1). use make_invertible_2cell. + use (pb_ump_cell χ₁). * exact (pb_ump_mor_pr1 χ₁ q • (pb_ump_mor_pr1 χ₂ q)^-1). * exact (pb_ump_mor_pr2 χ₁ q • (pb_ump_mor_pr2 χ₂ q)^-1). * abstract (refine (!_) ; refine (maponpaths (λ z, _ • z) (pb_ump_mor_cell χ₂ q) @ _) ; rewrite !vassocl ; refine (!_) ; refine (maponpaths (λ z, z • _) (pb_ump_mor_cell χ₁ q) @ _) ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath). + use make_is_invertible_2cell. * use (pb_ump_cell χ₁). ** exact (pb_ump_mor_pr1 χ₂ q • (pb_ump_mor_pr1 χ₁ q)^-1). ** exact (pb_ump_mor_pr2 χ₂ q • (pb_ump_mor_pr2 χ₁ q)^-1). ** abstract (refine (!_) ; refine (maponpaths (λ z, _ • z) (pb_ump_mor_cell χ₁ q) @ _) ; rewrite !vassocl ; refine (!_) ; refine (maponpaths (λ z, z • _) (pb_ump_mor_cell χ₂ q) @ _) ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_right ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath). * use (pb_ump_eq χ₁ _ _ (id₂ _) (id₂ _)). ** abstract (rewrite !id2_rwhisker ; rewrite !id2_right ; rewrite lassociator_rassociator ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_left, id2_right ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !pb_ump_cell_pr1 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !pb_ump_cell_pr2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** apply id2_rwhisker. ** apply id2_rwhisker. * use (pb_ump_eq χ₁ _ _ (id₂ _) (id₂ _)). ** abstract (rewrite !id2_rwhisker ; rewrite !id2_right ; rewrite lassociator_rassociator ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_left, id2_right ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !pb_ump_cell_pr1 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** abstract (rewrite <- rwhisker_vcomp ; rewrite !pb_ump_cell_pr2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite vcomp_linv ; rewrite id2_left ; rewrite vcomp_rinv ; apply idpath). ** apply id2_rwhisker. ** apply id2_rwhisker. - abstract (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; refine (!_) ; rewrite pb_ump_cell_pr1 ; rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). - abstract (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ; refine (!_) ; rewrite pb_ump_cell_pr2 ; rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). Qed. End Pullback. Arguments pb_cone {_ _ _ _} _ _. (** 5. Bicategories with pullbacks *) Definition has_pb (B : bicat) : UU := ∏ (b₁ b₂ b₃ : B) (f : b₁ --> b₃) (g : b₂ --> b₃), ∑ (p : pb_cone f g), has_pb_ump p. Definition bicat_with_pb : UU := ∑ (B : bicat), has_pb B. Coercion bicat_with_pb_to_bicat (B : bicat_with_pb) : bicat := pr1 B. UniMath-20231010/UniMath/Bicategories/Logic/000077500000000000000000000000001451125700300203115ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Logic/ComprehensionBicat.v000066400000000000000000000065041451125700300242610ustar00rootroot00000000000000(******************************************************************* Comprehension bicategories In this file we define comprehension bicategories and properties of comprehension bicategories. 1. Comprehension bicategories 2. Variances of comprehension bicategories *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Local Open Scope cat. (** 1. Comprehension bicategories *) Definition comprehension_bicat_structure (B : bicat) : UU := ∑ (D : disp_bicat B) (χ : disp_psfunctor D (cod_disp_bicat B) (id_psfunctor B)), global_cleaving D × global_cartesian_disp_psfunctor χ. Definition make_comprehension_bicat_structure (B : bicat) (D : disp_bicat B) (χ : disp_psfunctor D (cod_disp_bicat B) (id_psfunctor B)) (HD : global_cleaving D) (Hχ : global_cartesian_disp_psfunctor χ) : comprehension_bicat_structure B := D ,, χ ,, HD ,, Hχ. (** Projections of a comprehension bicategory *) Definition ty_of {B : bicat} (comp_B : comprehension_bicat_structure B) : disp_bicat B := pr1 comp_B. Definition comp_of {B : bicat} (comp_B : comprehension_bicat_structure B) : disp_psfunctor (ty_of comp_B) (cod_disp_bicat B) (id_psfunctor B) := pr12 comp_B. Definition ty_of_global_cleaving {B : bicat} (comp_B : comprehension_bicat_structure B) : global_cleaving (ty_of comp_B) := pr122 comp_B. Definition comp_of_global_cartesian {B : bicat} (comp_B : comprehension_bicat_structure B) : global_cartesian_disp_psfunctor (comp_of comp_B) := pr222 comp_B. (** 2. Variances of comprehension bicategories *) Definition is_covariant {B : bicat} (comp_B : comprehension_bicat_structure B) : UU := let D := ty_of comp_B in let χ := comp_of comp_B in local_opcleaving D × lwhisker_opcartesian D × rwhisker_opcartesian D × local_opcartesian_disp_psfunctor χ. Definition is_contravariant {B : bicat} (comp_B : comprehension_bicat_structure B) : UU := let D := ty_of comp_B in let χ := comp_of comp_B in local_cleaving D × lwhisker_cartesian D × rwhisker_cartesian D × local_cartesian_disp_psfunctor χ. Definition comprehension_bicat : UU := ∑ (B : bicat) (comp_B : comprehension_bicat_structure B), is_covariant comp_B. Definition contravariant_comprehension_bicat : UU := ∑ (B : bicat) (comp_B : comprehension_bicat_structure B), is_contravariant comp_B. UniMath-20231010/UniMath/Bicategories/Logic/DisplayMapBicat.v000066400000000000000000001330141451125700300235100ustar00rootroot00000000000000(***************************************************************************** Display map bicategories Contents 1. Subbicategories of the arrow bicategory 2. Examples of subbicategories of the arrow bicategory 3. Display map bicategories 4. Examples of display map bicategories 5. Closure conditions for display map bicategories 6. Examples 6.1 Bifinal 6.2 Biinitial 6.3 Composition 6.4 Product morphism *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.Morphisms.Properties.Composition. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderPullback. Require Import UniMath.Bicategories.Morphisms.Properties.FromInitial. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. (** 1. Subbicategories of the arrow bicategory *) Section Subbicat. Context {B : bicat} (pred_mor : ∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), UU). Let P₁ {e₁ e₂ b₁ b₂ : B} (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : UU := pred_mor _ _ _ _ p₁ p₂ fe. Definition contains_id : UU := ∏ (e b : B) (p : e --> b), P₁ p p (id₁ _). Definition closed_under_comp : UU := ∏ (e₁ e₂ e₃ b₁ b₂ b₃ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (p₃ : e₃ --> b₃) (fe : e₁ --> e₂) (ge : e₂ --> e₃), P₁ p₁ p₂ fe → P₁ p₂ p₃ ge → P₁ p₁ p₃ (fe · ge). Definition contains_equiv_over_id : UU := ∏ (e₁ e₂ b : B) (p₁ : e₁ --> b) (p₂ : e₂ --> b) (fe : e₁ --> e₂), left_adjoint_equivalence fe → invertible_2cell p₁ (fe · p₂) → P₁ p₁ p₂ fe. Definition closed_under_invertible_2cell : UU := ∏ (e₁ e₂ b₁ b₂ : B) (p₁ p₁' : e₁ --> b₁) (p₂ p₂' : e₂ --> b₂) (fe fe' : e₁ --> e₂) (α : invertible_2cell p₁ p₁') (β : invertible_2cell p₂ p₂') (γ : invertible_2cell fe fe') (H : P₁ p₁ p₂ fe), P₁ p₁' p₂' fe'. End Subbicat. Definition arrow_subbicat (B : bicat) : UU := ∑ (P₀ : ∏ (x y : B), x --> y → UU) (P₁ : ∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), UU), contains_id P₁ × closed_under_comp P₁ × closed_under_invertible_2cell P₁. Section Projections. Context {B : bicat} (D : arrow_subbicat B). Definition pred_ob {x y : B} (f : x --> y) : UU := pr1 D x y f. Definition pred_mor {e₁ e₂ b₁ b₂ : B} (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : UU := pr12 D e₁ e₂ b₁ b₂ p₁ p₂ fe. Definition id_pred_mor {e b : B} (p : e --> b) : pred_mor p p (id₁ e) := pr122 D e b p. Definition comp_pred_mor {e₁ e₂ e₃ b₁ b₂ b₃ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {p₃ : e₃ --> b₃} {fe : e₁ --> e₂} {ge : e₂ --> e₃} (Hfe : pred_mor p₁ p₂ fe) (Hge : pred_mor p₂ p₃ ge) : pred_mor p₁ p₃ (fe · ge) := pr1 (pr222 D) _ _ _ _ _ _ _ _ _ _ _ Hfe Hge. Definition invertible_pred_mor {e₁ e₂ b₁ b₂ : B} {p₁ p₁' : e₁ --> b₁} {p₂ p₂' : e₂ --> b₂} {fe fe' : e₁ --> e₂} (α : invertible_2cell p₁ p₁') (β : invertible_2cell p₂ p₂') (γ : invertible_2cell fe fe') (H : pred_mor p₁ p₂ fe) : pred_mor p₁' p₂' fe' := pr2 (pr222 D) _ _ _ _ _ _ _ _ _ _ α β γ H. Definition invertible_pred_mor_1 {e₁ e₂ b₁ b₂ : B} {p₁ p₁' : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} (α : invertible_2cell p₁ p₁') (H : pred_mor p₁ p₂ fe) : pred_mor p₁' p₂ fe := invertible_pred_mor α (id2_invertible_2cell _) (id2_invertible_2cell _) H. Definition invertible_pred_mor_2 {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ p₂' : e₂ --> b₂} {fe : e₁ --> e₂} (β : invertible_2cell p₂ p₂') (H : pred_mor p₁ p₂ fe) : pred_mor p₁ p₂' fe := invertible_pred_mor (id2_invertible_2cell _) β (id2_invertible_2cell _) H. Definition invertible_pred_mor_3 {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe fe' : e₁ --> e₂} (γ : invertible_2cell fe fe') (H : pred_mor p₁ p₂ fe) : pred_mor p₁ p₂ fe' := invertible_pred_mor (id2_invertible_2cell _) (id2_invertible_2cell _) γ H. End Projections. Definition make_arrow_subbicat {B : bicat} (P₀ : ∏ (x y : B), x --> y → UU) (P₁ : ∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), UU) (Hid : contains_id P₁) (Hcomp : closed_under_comp P₁) (Hinv : closed_under_invertible_2cell P₁) : arrow_subbicat B := (P₀ ,, P₁ ,, Hid ,, Hcomp ,, Hinv). Definition arrow_subbicat_contains_equiv_over_id {B : bicat} (HB : is_univalent_2 B) (D : arrow_subbicat B) : contains_equiv_over_id (λ e₁ e₂ b₁ b₂ p₁ p₂ fe, pred_mor D p₁ p₂ fe). Proof. intros e₁ e₂ b p₁ p₂ fe Hfe γ. refine (J_2_0 (pr1 HB) (λ (x₁ x₂ : B) (L : adjoint_equivalence x₁ x₂), ∏ (p₁ : x₁ --> b) (p₂ : x₂ --> b) (γ : invertible_2cell p₁ (pr1 L · p₂)), pred_mor D p₁ p₂ (pr1 L)) _ (fe ,, Hfe) p₁ p₂ γ). cbn. clear e₁ e₂ p₁ p₂ fe Hfe γ. intros e p₁ p₂ γ. pose (c := comp_of_invertible_2cell γ (lunitor_invertible_2cell _)). use (J_2_1 (pr2 HB) (λ (x₁ x₂ : B) (f g : x₁ --> x₂) (γ : invertible_2cell f g), pred_mor D f g (id₁ _)) _ c). cbn ; intros. apply (id_pred_mor D). Defined. Definition arrow_subbicat_props {B : bicat} (D : arrow_subbicat B) : UU := (∏ (x y : B) (f : x --> y), isaprop (pred_ob D f)) × (∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), isaprop (pred_mor D p₁ p₂ fe)). (** 2. Examples of subbicategories of the arrow bicategory *) Definition full_arrow_subbicat {B : bicat} (P₀ : ∏ (x y : B), x --> y → UU) : arrow_subbicat B. Proof. use make_arrow_subbicat. - exact P₀. - exact (λ _ _ _ _ _ _ _, unit). - exact (λ _ _ _, tt). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _, tt). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt). Defined. Definition full_arrow_subbicat_props {B : bicat} (P₀ : ∏ (x y : B), x --> y → UU) (isaprop_P₀ : ∏ (x y : B) (f : x --> y), isaprop (P₀ _ _ f)) : arrow_subbicat_props (full_arrow_subbicat P₀). Proof. split. - intros. apply isaprop_P₀. - intros. apply isapropunit. Defined. Definition intersection_arrow_subbicat {B : bicat} (D₁ D₂ : arrow_subbicat B) : arrow_subbicat B. Proof. use make_arrow_subbicat. - exact (λ x y f, pred_ob D₁ f × pred_ob D₂ f). - exact (λ _ _ _ _ p₁ p₂ fe, pred_mor D₁ p₁ p₂ fe × pred_mor D₂ p₁ p₂ fe). - intro ; intros. split ; apply id_pred_mor. - intros ? ? ? ? ? ? ? ? ? ? ? H₁ H₂. split. + exact (comp_pred_mor D₁ (pr1 H₁) (pr1 H₂)). + exact (comp_pred_mor D₂ (pr2 H₁) (pr2 H₂)). - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H. split. + exact (invertible_pred_mor D₁ α β γ (pr1 H)). + exact (invertible_pred_mor D₂ α β γ (pr2 H)). Defined. Definition intersection_arrow_subbicat_props {B : bicat} {D₁ D₂ : arrow_subbicat B} (HD₁ : arrow_subbicat_props D₁) (HD₂ : arrow_subbicat_props D₂) : arrow_subbicat_props (intersection_arrow_subbicat D₁ D₂). Proof. split. - intros x y f. apply isapropdirprod. + exact (pr1 HD₁ _ _ f). + exact (pr1 HD₂ _ _ f). - intros e₁ e₂ b₁ b₂ p₁ p₂ fe. apply isapropdirprod. + exact (pr2 HD₁ _ _ _ _ p₁ p₂ fe). + exact (pr2 HD₂ _ _ _ _ p₁ p₂ fe). Defined. Definition faithful_subbicat (B : bicat) : arrow_subbicat B := full_arrow_subbicat (λ _ _ f, faithful_1cell f). Definition faithful_subbicat_props (B : bicat) : arrow_subbicat_props (faithful_subbicat B). Proof. use full_arrow_subbicat_props. intros. apply isaprop_faithful_1cell. Defined. Definition fully_faithful_subbicat (B : bicat) : arrow_subbicat B := full_arrow_subbicat (λ _ _ f, fully_faithful_1cell f). Definition fully_faithful_subbicat_props (B : bicat) : arrow_subbicat_props (fully_faithful_subbicat B). Proof. use full_arrow_subbicat_props. intros. apply isaprop_fully_faithful_1cell. Defined. Definition pseudomonic_subbicat (B : bicat) : arrow_subbicat B := full_arrow_subbicat (λ _ _ f, pseudomonic_1cell f). Definition pseudomonic_subbicat_props (B : bicat) : arrow_subbicat_props (pseudomonic_subbicat B). Proof. use full_arrow_subbicat_props. intros. apply isaprop_pseudomonic_1cell. Defined. Definition conservative_subbicat (B : bicat) : arrow_subbicat B := full_arrow_subbicat (λ _ _ f, conservative_1cell f). Definition conservative_subbicat_props (B : bicat) : arrow_subbicat_props (conservative_subbicat B). Proof. use full_arrow_subbicat_props. intros. apply isaprop_conservative_1cell. Defined. Definition discrete_subbicat (B : bicat) : arrow_subbicat B := full_arrow_subbicat (λ _ _ f, discrete_1cell f). Definition discrete_subbicat_props (B : bicat) : arrow_subbicat_props (discrete_subbicat B). Proof. use full_arrow_subbicat_props. intros. apply isaprop_discrete_1cell. Defined. Definition sfib_subbicat (B : bicat) : arrow_subbicat B. Proof. use make_arrow_subbicat. - exact (λ _ _ f, internal_sfib f). - exact (λ _ _ _ _ p₁ p₂ fe, mor_preserves_cartesian p₁ p₂ fe). - intro ; intros. apply id_mor_preserves_cartesian. - intros e₁ e₂ e₃ b₁ b₂ b₃ p₁ p₂ p₃ fe ge Hf Hg. exact (comp_preserves_cartesian Hf Hg). - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H. exact (invertible_2cell_between_preserves_cartesian α β γ H). Defined. Definition sfib_subbicat_props (B : bicat) (HB_2_1 : is_univalent_2_1 B) : arrow_subbicat_props (sfib_subbicat B). Proof. split. - intros ; simpl. apply isaprop_internal_sfib. exact HB_2_1. - intros ; simpl. apply isaprop_mor_preserves_cartesian. Defined. Definition sopfib_subbicat (B : bicat) : arrow_subbicat B. Proof. use make_arrow_subbicat. - exact (λ _ _ f, internal_sopfib f). - exact (λ _ _ _ _ p₁ p₂ fe, mor_preserves_opcartesian p₁ p₂ fe). - intro ; intros. apply id_mor_preserves_opcartesian. - intros e₁ e₂ e₃ b₁ b₂ b₃ p₁ p₂ p₃ fe ge Hf Hg. exact (comp_preserves_opcartesian Hf Hg). - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H. exact (invertible_2cell_between_preserves_opcartesian α β γ H). Defined. Definition sopfib_subbicat_props (B : bicat) (HB_2_1 : is_univalent_2_1 B) : arrow_subbicat_props (sopfib_subbicat B). Proof. split. - intros ; simpl. apply isaprop_internal_sopfib. exact HB_2_1. - intros ; simpl. apply isaprop_mor_preserves_opcartesian. Defined. Definition discrete_sfib_subbicat (B : bicat) : arrow_subbicat B := intersection_arrow_subbicat (sfib_subbicat B) (discrete_subbicat B). Definition discrete_sfib_subbicat_props (B : bicat) (HB_2_1 : is_univalent_2_1 B) : arrow_subbicat_props (discrete_sfib_subbicat B). Proof. use intersection_arrow_subbicat_props. - exact (sfib_subbicat_props _ HB_2_1). - exact (discrete_subbicat_props B). Defined. Definition discrete_sopfib_subbicat (B : bicat) : arrow_subbicat B := intersection_arrow_subbicat (sopfib_subbicat B) (discrete_subbicat B). Definition discrete_sopfib_subbicat_props (B : bicat) (HB_2_1 : is_univalent_2_1 B) : arrow_subbicat_props (discrete_sopfib_subbicat B). Proof. use intersection_arrow_subbicat_props. - exact (sopfib_subbicat_props _ HB_2_1). - exact (discrete_subbicat_props B). Defined. (** 3. Display map bicategories *) Section DispMapBicat. Context {B : bicat} (D : arrow_subbicat B). Definition closed_under_pb : UU := ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)), pred_ob D f → has_pb_ump (make_pb_cone pb p₁ p₂ γ) → pred_ob D p₂ × pred_mor D p₂ f p₁. Definition contains_pb : UU := ∏ (x y z : B) (f : x --> z) (g : y --> z), pred_ob D f → ∑ (pb : B) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)), has_pb_ump (make_pb_cone pb p₁ p₂ γ). Definition closed_under_pb_ump_mor : UU := ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)) (H : has_pb_ump (make_pb_cone pb p₁ p₂ γ)) (cc c : B) (cp₁ : cc --> x) (cp₂ : cc --> c) (h : c --> y) (δ : invertible_2cell (cp₁ · f) ((cp₂ · h) · g)) (cone := make_pb_cone cc cp₁ (cp₂ · h) δ), pred_ob D f → pred_mor D p₂ f p₁ → pred_mor D cp₂ f cp₁ → pred_mor D cp₂ p₂ (pb_ump_mor H cone). Definition contained_in_sfib : UU := ∏ (x y : B) (f : x --> y), pred_ob D f → internal_sfib f. Definition contained_in_sopfib : UU := ∏ (x y : B) (f : x --> y), pred_ob D f → internal_sopfib f. Definition contained_in_faithful : UU := ∏ (x y : B) (f : x --> y), pred_ob D f → faithful_1cell f. Definition contained_in_conservative : UU := ∏ (x y : B) (f : x --> y), pred_ob D f → conservative_1cell f. Definition contained_in_discrete : UU := ∏ (x y : B) (f : x --> y), pred_ob D f → discrete_1cell f. Definition discrete_contained_in_faithful (H : contained_in_discrete) : contained_in_faithful. Proof. intros x y f Hf. exact (pr1 (H x y f Hf)). Defined. Definition discrete_contained_in_conservative (H : contained_in_discrete) : contained_in_conservative. Proof. intros x y f Hf. exact (pr2 (H x y f Hf)). Defined. Definition pred_mor_is_mor_preserves_cartesian : UU := ∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), (pred_mor D p₁ p₂ fe → mor_preserves_cartesian p₁ p₂ fe) × (mor_preserves_cartesian p₁ p₂ fe → pred_mor D p₁ p₂ fe). Definition pred_mor_is_mor_preserves_opcartesian : UU := ∏ (e₁ e₂ b₁ b₂ : B) (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂), (pred_mor D p₁ p₂ fe → mor_preserves_opcartesian p₁ p₂ fe) × (mor_preserves_opcartesian p₁ p₂ fe → pred_mor D p₁ p₂ fe). End DispMapBicat. Definition disp_map_bicat (B : bicat) : UU := ∑ (D : arrow_subbicat B), closed_under_pb D × contains_pb D × closed_under_pb_ump_mor D. Coercion disp_map_bicat_to_arrow_subbicat {B : bicat} (D : disp_map_bicat B) : arrow_subbicat B := pr1 D. Section Projections. Context {B : bicat} (D : disp_map_bicat B). Definition pb_preserves_pred_ob {pb x y z : B} {f : x --> z} {g : y --> z} {p₁ : pb --> x} {p₂ : pb --> y} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (Hf : pred_ob D f) (pb_sqr : has_pb_ump (make_pb_cone pb p₁ p₂ γ)) : pred_ob D p₂ := pr1 (pr12 D pb x y z f g p₁ p₂ γ Hf pb_sqr). Definition mor_of_pb_preserves_pred_ob {pb x y z : B} {f : x --> z} {g : y --> z} {p₁ : pb --> x} {p₂ : pb --> y} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (Hf : pred_ob D f) (pb_sqr : has_pb_ump (make_pb_cone pb p₁ p₂ γ)) : pred_mor (pr1 D) p₂ f p₁ := pr2 (pr12 D pb x y z f g p₁ p₂ γ Hf pb_sqr). Definition pb_ob_of_pred_ob {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : B := pr1 (pr122 D x y z f g Hf). Definition pb_pr1_of_pred_ob {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : pb_ob_of_pred_ob f g Hf --> x := pr12 (pr122 D x y z f g Hf). Definition pb_pr2_of_pred_ob {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : pb_ob_of_pred_ob f g Hf --> y := pr122 (pr122 D x y z f g Hf). Definition pb_cell_of_pred_ob {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : invertible_2cell (pb_pr1_of_pred_ob f g Hf · f) (pb_pr2_of_pred_ob f g Hf · g) := pr1 (pr222 (pr122 D x y z f g Hf)). Definition pb_cone_of_pred_ob {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : pb_cone f g := make_pb_cone (pb_ob_of_pred_ob f g Hf) (pb_pr1_of_pred_ob f g Hf) (pb_pr2_of_pred_ob f g Hf) (pb_cell_of_pred_ob f g Hf). Definition pb_of_pred_ob_has_pb_ump {x y z : B} (f : x --> z) (g : y --> z) (Hf : pred_ob D f) : has_pb_ump (pb_cone_of_pred_ob f g Hf) := pr2 (pr222 (pr122 D x y z f g Hf)). Definition pred_mor_closed_under_pb_ump_mor : closed_under_pb_ump_mor D := pr222 D. End Projections. Definition make_disp_map_bicat {B : bicat} (D : arrow_subbicat B) (closed_pb : closed_under_pb D) (contains_pb : contains_pb D) (closed_pb_mor : closed_under_pb_ump_mor D) : disp_map_bicat B := (D ,, closed_pb ,, contains_pb ,, closed_pb_mor). Definition make_disp_map_bicat_with_pb (B : bicat_with_pb) (D : arrow_subbicat B) (closed_pb : closed_under_pb D) (closed_pb_mor : closed_under_pb_ump_mor D) : disp_map_bicat B. Proof. refine (make_disp_map_bicat D closed_pb _ closed_pb_mor). intros x y z f g p. pose (cone := pr1 (pr2 B x y z f g)). pose (pb_ump := pr2 (pr2 B x y z f g)). simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact cone. - exact (pb_cone_pr1 cone). - exact (pb_cone_pr2 cone). - exact (pb_cone_cell cone). - exact pb_ump. Defined. (** 4. Examples of display map bicategories *) Definition full_disp_map_bicat {B : bicat_with_pb} (P₀ : ∏ (x y : B), x --> y → UU) (closed_pb : ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)), P₀ x z f → has_pb_ump (make_pb_cone pb p₁ p₂ γ) → P₀ pb y p₂) : disp_map_bicat B. Proof. use make_disp_map_bicat_with_pb. - exact (full_arrow_subbicat P₀). - exact (λ pb x y z f g p₁ p₂ γ H₁ H₂, closed_pb pb x y z f g p₁ p₂ γ H₁ H₂ ,, tt). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt). Defined. Definition intersection_disp_map_bicat {B : bicat} (D₁ D₂ : disp_map_bicat B) : disp_map_bicat B. Proof. use make_disp_map_bicat. - exact (intersection_arrow_subbicat D₁ D₂). - intros ? ? ? ? ? ? ? ? ? Hf pb_sqr. split ; split. + exact (pb_preserves_pred_ob D₁ (pr1 Hf) pb_sqr). + exact (pb_preserves_pred_ob D₂ (pr2 Hf) pb_sqr). + exact (mor_of_pb_preserves_pred_ob D₁ (pr1 Hf) pb_sqr). + exact (mor_of_pb_preserves_pred_ob D₂ (pr2 Hf) pb_sqr). - intros x y z f g H. exact (pr122 D₁ _ _ _ _ _ (pr1 H)). - intros ? ? ? ? ? ? ? ? ? pb_sqr ? ? ? ? ? ? ? Hf Hp₁ Hcp₁. split. + exact (pred_mor_closed_under_pb_ump_mor D₁ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (pr1 Hf) (pr1 Hp₁) (pr1 Hcp₁)). + exact (pred_mor_closed_under_pb_ump_mor D₂ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (pr2 Hf) (pr2 Hp₁) (pr2 Hcp₁)). Defined. Definition faithful_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use full_disp_map_bicat. - exact (λ _ _ f, faithful_1cell f). - intros pb x y z f g p₁ p₂ γ Hf Hpb. exact (pb_of_faithful_1cell Hpb Hf). Defined. Definition fully_faithful_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use full_disp_map_bicat. - exact (λ _ _ f, fully_faithful_1cell f). - intros pb x y z f g p₁ p₂ γ Hf Hpb. exact (pb_of_fully_faithful_1cell Hpb Hf). Defined. Definition pseudomonic_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use full_disp_map_bicat. - exact (λ _ _ f, pseudomonic_1cell f). - intros pb x y z f g p₁ p₂ γ Hf Hpb. exact (pb_of_pseudomonic_1cell Hpb Hf). Defined. Definition conservative_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use full_disp_map_bicat. - exact (λ _ _ f, conservative_1cell f). - intros pb x y z f g p₁ p₂ γ Hf Hpb. exact (pb_of_conservative_1cell Hpb Hf). Defined. Definition discrete_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use full_disp_map_bicat. - exact (λ _ _ f, discrete_1cell f). - intros pb x y z f g p₁ p₂ γ Hf Hpb. exact (pb_of_discrete_1cell Hpb Hf). Defined. Definition sfib_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use make_disp_map_bicat_with_pb. - exact (sfib_subbicat B). - intros pb x y z f g p₁ p₂ γ q Hpb. split. + exact (pb_of_sfib Hpb q). + exact (mor_preserves_cartesian_pb_pr1 Hpb q). - intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? H₁ H₂ H₃. apply mor_preserves_cartesian_pb_ump_mor. exact H₃. Defined. Definition sopfib_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B. Proof. use make_disp_map_bicat_with_pb. - exact (sopfib_subbicat B). - intros pb x y z f g p₁ p₂ γ q Hpb. split. + exact (pb_of_sopfib Hpb q). + exact (mor_preserves_opcartesian_pb_pr1 Hpb q). - intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? H₁ H₂ H₃. apply mor_preserves_opcartesian_pb_ump_mor. exact H₃. Defined. Definition discrete_sfib_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B := intersection_disp_map_bicat (sfib_disp_map_bicat B) (discrete_disp_map_bicat B). Definition discrete_sfib_disp_map_bicat_in_discrete (B : bicat) : contained_in_discrete (discrete_sfib_subbicat B). Proof. intros x y f Hf. exact (pr2 Hf). Defined. Definition discrete_sopfib_disp_map_bicat (B : bicat_with_pb) : disp_map_bicat B := intersection_disp_map_bicat (sopfib_disp_map_bicat B) (discrete_disp_map_bicat B). Definition discrete_sopfib_disp_map_bicat_in_discrete (B : bicat) : contained_in_discrete (discrete_sopfib_subbicat B). Proof. intros x y f Hf. exact (pr2 Hf). Defined. (** 5. Properties of display map bicategories *) Definition is_covariant_disp_map_bicat {B : bicat} (D : disp_map_bicat B) : UU := contained_in_sopfib D × pred_mor_is_mor_preserves_opcartesian D. Definition is_contravariant_disp_map_bicat {B : bicat} (D : disp_map_bicat B) : UU := contained_in_sfib D × pred_mor_is_mor_preserves_cartesian D. Definition intersection_is_covariant {B : bicat} {D₁ D₂ : disp_map_bicat B} (HD₁ : is_covariant_disp_map_bicat D₁) (HD₂ : is_covariant_disp_map_bicat D₂) : is_covariant_disp_map_bicat (intersection_disp_map_bicat D₁ D₂). Proof. split. - intros x y f Hf. apply HD₁. apply Hf. - intros e₁ e₂ b₁ b₂ p₁ p₂ fe. split. + intro H. apply HD₁. apply H. + intro H. split. * apply HD₁. apply H. * apply HD₂. apply H. Defined. Definition intersection_with_full_is_covariant {B : bicat_with_pb} (P₀ : ∏ (x y : B), x --> y → UU) (closed_pb : ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)), P₀ x z f → has_pb_ump (make_pb_cone pb p₁ p₂ γ) → P₀ pb y p₂) {D : disp_map_bicat B} (HD : is_covariant_disp_map_bicat D) : is_covariant_disp_map_bicat (intersection_disp_map_bicat D (full_disp_map_bicat P₀ closed_pb)). Proof. split. - intros x y f Hf. apply HD. apply Hf. - intros e₁ e₂ b₁ b₂ p₁ p₂ fe. split. + intro H. apply HD. apply H. + intro H. split. * apply HD. apply H. * exact tt. Defined. Definition intersection_is_contravariant {B : bicat} {D₁ D₂ : disp_map_bicat B} (HD₁ : is_contravariant_disp_map_bicat D₁) (HD₂ : is_contravariant_disp_map_bicat D₂) : is_contravariant_disp_map_bicat (intersection_disp_map_bicat D₁ D₂). Proof. split. - intros x y f Hf. apply HD₁. apply Hf. - intros e₁ e₂ b₁ b₂ p₁ p₂ fe. split. + intro H. apply HD₁. apply H. + intro H. split. * apply HD₁. apply H. * apply HD₂. apply H. Defined. Definition intersection_with_full_is_contravariant {B : bicat_with_pb} (P₀ : ∏ (x y : B), x --> y → UU) (closed_pb : ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)), P₀ x z f → has_pb_ump (make_pb_cone pb p₁ p₂ γ) → P₀ pb y p₂) {D : disp_map_bicat B} (HD : is_contravariant_disp_map_bicat D) : is_contravariant_disp_map_bicat (intersection_disp_map_bicat D (full_disp_map_bicat P₀ closed_pb)). Proof. split. - intros x y f Hf. apply HD. apply Hf. - intros e₁ e₂ b₁ b₂ p₁ p₂ fe. split. + intro H. apply HD. apply H. + intro H. split. * apply HD. apply H. * exact tt. Defined. Definition sopfib_disp_map_bicat_is_covariant (B : bicat_with_pb) : is_covariant_disp_map_bicat (sopfib_disp_map_bicat B). Proof. split. - intros ? ? ? H. exact H. - intros ? ? ? ? ? ? ?. split. + exact (λ H, H). + exact (λ H, H). Defined. Definition sfib_disp_map_bicat_is_contravariant (B : bicat_with_pb) : is_contravariant_disp_map_bicat (sfib_disp_map_bicat B). Proof. split. - intros ? ? ? H. exact H. - intros ? ? ? ? ? ? ?. split. + exact (λ H, H). + exact (λ H, H). Defined. Definition discrete_sopfib_disp_map_bicat_is_covariant (B : bicat_with_pb) : is_covariant_disp_map_bicat (discrete_sopfib_disp_map_bicat B). Proof. use intersection_with_full_is_covariant. split. - intros ? ? ? H. exact H. - intros ? ? ? ? ? ? ?. split. + exact (λ H, H). + exact (λ H, H). Defined. Definition discrete_sfib_disp_map_bicat_is_covariant (B : bicat_with_pb) : is_contravariant_disp_map_bicat (discrete_sfib_disp_map_bicat B). Proof. use intersection_with_full_is_contravariant. split. - intros ? ? ? H. exact H. - intros ? ? ? ? ? ? ?. split. + exact (λ H, H). + exact (λ H, H). Defined. (** 5. Closure conditions for display map bicategories *) Definition arrow_subbicat_bifinal {B : bicat} (D : arrow_subbicat B) : UU := (∏ (b : B), pred_ob D (id₁ b)) × (∏ (e b : B) (h : e --> b), pred_mor D h (id₁ b) h). Definition arrow_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (D : arrow_subbicat B) : UU := (∏ (b : B), pred_ob D (is_biinitial_1cell_property (pr2 I) b)) × (∏ (e b : B) (h : e --> b), pred_mor D (is_biinitial_1cell_property (pr2 I) b) h (is_biinitial_1cell_property (pr2 I) e)). Definition arrow_subbicat_closed_composition {B : bicat} (D : arrow_subbicat B) : UU := (∏ (x y z : B) (f : x --> y) (g : y --> z), pred_ob D f → pred_ob D g → pred_ob D (f · g)) × (∏ (x y z : B) (f : x --> y) (g : y --> z), pred_ob D f → pred_ob D g → pred_mor D (f · g) g f). Definition arrow_subbicat_closed_prod_mor {B : bicat} (D : arrow_subbicat B) : UU := ∏ (pb x y z : B) (f : x --> z) (g : y --> z) (p₁ : pb --> x) (p₂ : pb --> y) (γ : invertible_2cell (p₁ · f) (p₂ · g)) (H : has_pb_ump (make_pb_cone pb p₁ p₂ γ)) (c : B) (cp : c --> x) (h : c --> y) (δ : invertible_2cell (cp · f) (h · g)) (cone := make_pb_cone c cp h δ), pred_ob D f → pred_mor D (cp · f) f cp → pred_mor D (cp · f) g h → pred_mor D (cp · f) (p₁ · f) (pb_ump_mor H cone). (** 6. Examples *) (** 6.1 Bifinal *) Definition full_arrow_subbicat_bifinal {B : bicat} (P : ∏ (x y : B), x --> y → UU) (Pid : ∏ (x : B), P x x (id₁ x)) : arrow_subbicat_bifinal (full_arrow_subbicat P). Proof. split. - exact Pid. - exact (λ _ _ _, tt). Defined. Definition intersection_arrow_subbicat_bifinal {B : bicat} (D₁ D₂ : arrow_subbicat B) (HD₁ : arrow_subbicat_bifinal D₁) (HD₂ : arrow_subbicat_bifinal D₂) : arrow_subbicat_bifinal (intersection_arrow_subbicat D₁ D₂). Proof. split. - intro b. split. + apply HD₁. + apply HD₂. - intros e b h. split. + apply HD₁. + apply HD₂. Defined. Definition faithful_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (faithful_subbicat B). Proof. use full_arrow_subbicat_bifinal. intros ; cbn. apply id1_faithful. Defined. Definition fully_faithful_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (fully_faithful_subbicat B). Proof. use full_arrow_subbicat_bifinal. intros ; cbn. apply id1_fully_faithful. Defined. Definition pseudomonic_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (pseudomonic_subbicat B). Proof. use full_arrow_subbicat_bifinal. intros ; cbn. apply id1_pseudomonic. Defined. Definition conservative_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (conservative_subbicat B). Proof. use full_arrow_subbicat_bifinal. intros ; cbn. apply id1_conservative. Defined. Definition discrete_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (discrete_subbicat B). Proof. use full_arrow_subbicat_bifinal. intros ; cbn. apply id1_discrete. Defined. Definition sfib_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (sfib_subbicat B). Proof. split. - exact identity_internal_sfib. - intros. apply mor_to_id_preserves_cartesian. Defined. Definition sopfib_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (sopfib_subbicat B). Proof. split. - exact identity_internal_sopfib. - intros. apply mor_to_id_preserves_opcartesian. Defined. Definition discrete_sfib_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (discrete_sfib_subbicat B). Proof. use intersection_arrow_subbicat_bifinal. - exact (sfib_subbicat_bifinal B). - exact (discrete_subbicat_bifinal B). Defined. Definition discrete_sopfib_subbicat_bifinal (B : bicat) : arrow_subbicat_bifinal (discrete_sopfib_subbicat B). Proof. use intersection_arrow_subbicat_bifinal. - exact (sopfib_subbicat_bifinal B). - exact (discrete_subbicat_bifinal B). Defined. (** 6.2 Biinitial *) Definition full_arrow_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (P : ∏ (x y : B), x --> y → UU) (PI : ∏ (x : B), P (pr1 I) x (is_biinitial_1cell_property (pr2 I) x)) : arrow_subbicat_biinitial I (full_arrow_subbicat P). Proof. split. - exact PI. - exact (λ _ _ _, tt). Defined. Definition intersection_arrow_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (D₁ D₂ : arrow_subbicat B) (HD₁ : arrow_subbicat_biinitial I D₁) (HD₂ : arrow_subbicat_biinitial I D₂) : arrow_subbicat_biinitial I (intersection_arrow_subbicat D₁ D₂). Proof. split. - intro b. split. + apply HD₁. + apply HD₂. - intros e b h. split. + apply HD₁. + apply HD₂. Defined. Definition faithful_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (faithful_subbicat B). Proof. use full_arrow_subbicat_biinitial. intros ; cbn. exact (from_biinitial_faithful_1cell (pr2 I) HI _). Defined. Definition fully_faithful_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (fully_faithful_subbicat B). Proof. use full_arrow_subbicat_biinitial. intros ; cbn. exact (from_biinitial_fully_faithful_1cell (pr2 I) HI _). Defined. Definition pseudomonic_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (pseudomonic_subbicat B). Proof. use full_arrow_subbicat_biinitial. intros ; cbn. exact (from_biinitial_pseudomonic_1cell (pr2 I) HI _). Defined. Definition conservative_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (conservative_subbicat B). Proof. use full_arrow_subbicat_biinitial. intros ; cbn. exact (from_biinitial_conservative_1cell (pr2 I) HI _). Defined. Definition discrete_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (discrete_subbicat B). Proof. use full_arrow_subbicat_biinitial. intros ; cbn. exact (from_biinitial_discrete_1cell (pr2 I) HI _). Defined. Definition sfib_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (sfib_subbicat B). Proof. split. - exact (λ _, from_biinitial_internal_sfib (pr2 I) HI _). - intros. apply from_biinitial_mor_preserves_cartesian. exact HI. Defined. Definition sopfib_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (sopfib_subbicat B). Proof. split. - exact (λ _, from_biinitial_internal_sopfib (pr2 I) HI _). - intros. apply from_biinitial_mor_preserves_opcartesian. exact HI. Defined. Definition discrete_sfib_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (discrete_sfib_subbicat B). Proof. use intersection_arrow_subbicat_biinitial. - exact (sfib_subbicat_biinitial I HI). - exact (discrete_subbicat_biinitial I HI). Defined. Definition discrete_sopfib_subbicat_biinitial {B : bicat} (I : biinitial_obj B) (HI : biinitial_is_strict_biinitial_obj (pr2 I)) : arrow_subbicat_biinitial I (discrete_sopfib_subbicat B). Proof. use intersection_arrow_subbicat_biinitial. - exact (sopfib_subbicat_biinitial I HI). - exact (discrete_subbicat_biinitial I HI). Defined. (** 6.3 Composition *) Definition full_arrow_subbicat_composition {B : bicat} (P : ∏ (x y : B), x --> y → UU) (Pcomp : ∏ (x y z : B) (f : x --> y) (g : y --> z), P x y f → P y z g → P x z (f · g)) : arrow_subbicat_closed_composition (full_arrow_subbicat P). Proof. split. - exact Pcomp. - intros. apply tt. Defined. Definition intersection_arrow_subbicat_composition {B : bicat} (D₁ D₂ : arrow_subbicat B) (HD₁ : arrow_subbicat_closed_composition D₁) (HD₂ : arrow_subbicat_closed_composition D₂) : arrow_subbicat_closed_composition (intersection_arrow_subbicat D₁ D₂). Proof. split. - intros x y z f g Hf Hg. split. + apply HD₁. * exact (pr1 Hf). * exact (pr1 Hg). + apply HD₂. * exact (pr2 Hf). * exact (pr2 Hg). - intros x y z f g Hf Hg. split. + apply HD₁. * exact (pr1 Hf). * exact (pr1 Hg). + apply HD₂. * exact (pr2 Hf). * exact (pr2 Hg). Defined. Definition faithful_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (faithful_subbicat B). Proof. use full_arrow_subbicat_composition. intros x y z f g Hf Hg. exact (comp_faithful Hf Hg). Defined. Definition fully_faithful_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (fully_faithful_subbicat B). Proof. use full_arrow_subbicat_composition. intros x y z f g Hf Hg. exact (comp_fully_faithful Hf Hg). Defined. Definition pseudomonic_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (pseudomonic_subbicat B). Proof. use full_arrow_subbicat_composition. intros x y z f g Hf Hg. exact (comp_pseudomonic Hf Hg). Defined. Definition conservative_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (conservative_subbicat B). Proof. use full_arrow_subbicat_composition. intros x y z f g Hf Hg. exact (comp_conservative Hf Hg). Defined. Definition discrete_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (discrete_subbicat B). Proof. use full_arrow_subbicat_composition. intros x y z f g Hf Hg. exact (comp_discrete Hf Hg). Defined. Definition sfib_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (sfib_subbicat B). Proof. split. - intros x y z f g Hf Hg. exact (comp_sfib Hf Hg). - intros x y z f g Hf Hg ; cbn. apply comp_mor_preserves_cartesian. + exact Hf. + exact Hg. Defined. Definition sopfib_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (sopfib_subbicat B). Proof. split. - intros x y z f g Hf Hg. exact (comp_sopfib Hf Hg). - intros x y z f g Hf Hg ; cbn. apply comp_mor_preserves_opcartesian. + exact Hf. + exact Hg. Defined. Definition discrete_sfib_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (discrete_sfib_subbicat B). Proof. use intersection_arrow_subbicat_composition. - exact (sfib_subbicat_closed_composition B). - exact (discrete_subbicat_closed_composition B). Defined. Definition discrete_sopfib_subbicat_closed_composition (B : bicat) : arrow_subbicat_closed_composition (discrete_sopfib_subbicat B). Proof. use intersection_arrow_subbicat_composition. - exact (sopfib_subbicat_closed_composition B). - exact (discrete_subbicat_closed_composition B). Defined. (** 6.4 Product morphism *) Definition full_arrow_subbicat_closed_prod_mor {B : bicat} (P : ∏ (x y : B), x --> y → UU) : arrow_subbicat_closed_prod_mor (full_arrow_subbicat P). Proof. intro ; intros. exact tt. Defined. Definition intersection_arrow_subbicat_closed_prod_mor {B : bicat} (D₁ D₂ : arrow_subbicat B) (HD₁ : arrow_subbicat_closed_prod_mor D₁) (HD₂ : arrow_subbicat_closed_prod_mor D₂) : arrow_subbicat_closed_prod_mor (intersection_arrow_subbicat D₁ D₂). Proof. intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap. split. - apply HD₁. + exact (pr1 Hf). + exact (pr1 Hfmap). + exact (pr1 Hgmap). - apply HD₂. + exact (pr2 Hf). + exact (pr2 Hfmap). + exact (pr2 Hgmap). Defined. Definition faithful_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (faithful_subbicat B). Proof. apply full_arrow_subbicat_closed_prod_mor. Defined. Definition fully_faithful_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (fully_faithful_subbicat B). Proof. apply full_arrow_subbicat_closed_prod_mor. Defined. Definition pseudomonic_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (pseudomonic_subbicat B). Proof. apply full_arrow_subbicat_closed_prod_mor. Defined. Definition conservative_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (conservative_subbicat B). Proof. apply full_arrow_subbicat_closed_prod_mor. Defined. Definition discrete_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (discrete_subbicat B). Proof. apply full_arrow_subbicat_closed_prod_mor. Defined. Definition sfib_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (sfib_subbicat B). Proof. intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap. exact (mor_preserves_cartesian_pb_ump_mor_comp H Hf δ Hfmap Hgmap). Defined. Definition sopfib_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (sopfib_subbicat B). Proof. intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap. exact (mor_preserves_opcartesian_pb_ump_mor_comp H Hf δ Hfmap Hgmap). Defined. Definition discrete_sfib_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (discrete_sfib_subbicat B). Proof. use intersection_arrow_subbicat_closed_prod_mor. - exact (sfib_subbicat_closed_prod_mor B). - exact (discrete_subbicat_closed_prod_mor B). Defined. Definition discrete_sopfib_subbicat_closed_prod_mor (B : bicat) : arrow_subbicat_closed_prod_mor (discrete_sopfib_subbicat B). Proof. use intersection_arrow_subbicat_closed_prod_mor. - exact (sopfib_subbicat_closed_prod_mor B). - exact (discrete_subbicat_closed_prod_mor B). Defined. UniMath-20231010/UniMath/Bicategories/Logic/Examples/000077500000000000000000000000001451125700300220675ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Logic/Examples/DisplayMapComprehensionBicat.v000066400000000000000000000220721451125700300300210ustar00rootroot00000000000000(******************************************************************* The comprehension bicategory of a display map bicategory Contents 1. The comprehension pseudofunctor 2. Preservation of cartesian 1-cells 3. Preservation of (op)cartesian 2-cells 4. The comprehension bicategory 5. Internal Street fibrations and opfibrations *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatToDispBicat. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.DisplayMapBicatCleaving. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. Section DispMapBicatToCompBicat. Context {B : bicat} (D : disp_map_bicat B) (HB : is_univalent_2 B). Let DD : disp_bicat B := disp_map_bicat_to_disp_bicat D. (** 1. The comprehension pseudofunctor *) Definition disp_map_bicat_comprehension_data : disp_psfunctor_data DD (cod_disp_bicat B) (id_psfunctor B). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x hx, pr1 hx ,, pr12 hx). - exact (λ x y f hx hy hf, pr1 hf ,, pr22 hf). - exact (λ x y f g α hx hy hf hg hα, hα). - simple refine (λ x hx, _ ,, _). + use make_disp_2cell_cod. * exact (id₂ _). * abstract (unfold coherent_homot ; cbn ; rewrite id2_rwhisker, id2_right ; rewrite lwhisker_id2, id2_left ; apply idpath). + use is_disp_invertible_2cell_cod ; simpl. is_iso. - simple refine (λ x y z f g hx hy hz hf hg, _ ,, _). + use make_disp_2cell_cod. * exact (id₂ _). * abstract (unfold coherent_homot ; cbn ; rewrite id2_rwhisker, id2_right ; rewrite lwhisker_id2, id2_left ; rewrite !vassocl ; apply idpath). + use is_disp_invertible_2cell_cod ; simpl. is_iso. Defined. Definition disp_map_bicat_comprehension_is_disp_psfunctor : is_disp_psfunctor _ _ _ disp_map_bicat_comprehension_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply cellset_property | ]). - refine (_ @ !(transportb_cell_of_cod_over _ _)) ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over _ _)) ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)) ; cbn. rewrite id2_rwhisker, !id2_left. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)) ; cbn. rewrite lwhisker_id2, !id2_left. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)) ; cbn. rewrite id2_rwhisker, lwhisker_id2. rewrite !id2_left, !id2_right. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)) ; cbn. rewrite !id2_left, id2_right. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)) ; cbn. rewrite !id2_left, id2_right. apply idpath. Qed. Definition disp_map_bicat_comprehension : disp_psfunctor DD (cod_disp_bicat B) (id_psfunctor B) := disp_map_bicat_comprehension_data ,, disp_map_bicat_comprehension_is_disp_psfunctor. (** 2. Preservation of cartesian 1-cells *) Definition global_cartesian_disp_map_bicat_comprehension : global_cartesian_disp_psfunctor disp_map_bicat_comprehension. Proof. use preserves_global_lifts_to_cartesian. - exact HB. - exact (cod_disp_univalent_2 _ HB). - exact (global_cleaving_of_disp_map_bicat D). - intros x y f hy. use is_pb_to_cartesian_1cell. exact (mirror_has_pb_ump (pb_of_pred_ob_has_pb_ump D (pr12 hy) f (pr22 hy))). Defined. (** 3. Preservation of (op)cartesian 2-cells *) Definition disp_map_bicat_to_comp_bicat_local_opcartesian (HD : is_covariant_disp_map_bicat D) : local_opcartesian_disp_psfunctor disp_map_bicat_comprehension. Proof. intros ? ? ? ? ? ? ? ? ? ? H. apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. cbn. apply (disp_map_is_opcartesian_2cell_to_is_opcartesian_2cell_sopfib _ HD). exact H. Defined. Definition disp_map_bicat_to_comp_bicat_local_cartesian (HD : is_contravariant_disp_map_bicat D) : local_cartesian_disp_psfunctor disp_map_bicat_comprehension. Proof. intros ? ? ? ? ? ? ? ? ? ? H. apply is_cartesian_2cell_sfib_to_is_cartesian_2cell. cbn. apply (disp_map_is_cartesian_2cell_to_is_cartesian_2cell_sfib _ HD). exact H. Defined. (** 4. The comprehension bicategory *) Definition disp_map_bicat_to_comp_bicat : comprehension_bicat_structure B. Proof. use make_comprehension_bicat_structure. - exact DD. - exact disp_map_bicat_comprehension. - exact (global_cleaving_of_disp_map_bicat D). - exact global_cartesian_disp_map_bicat_comprehension. Defined. Definition is_covariant_disp_map_bicat_to_comp_bicat (HD : is_covariant_disp_map_bicat D) : is_covariant disp_map_bicat_to_comp_bicat. Proof. repeat split. - exact (local_opcleaving_of_disp_map_bicat _ HD). - exact (lwhisker_opcartesian_disp_map_bicat _ HD). - exact (rwhisker_opcartesian_disp_map_bicat _ HD). - exact (disp_map_bicat_to_comp_bicat_local_opcartesian HD). Defined. Definition is_contravariant_disp_map_bicat_to_comp_bicat (HD : is_contravariant_disp_map_bicat D) : is_contravariant disp_map_bicat_to_comp_bicat. Proof. repeat split. - exact (local_cleaving_of_disp_map_bicat _ HD). - exact (lwhisker_cartesian_disp_map_bicat _ HD). - exact (rwhisker_cartesian_disp_map_bicat _ HD). - exact (disp_map_bicat_to_comp_bicat_local_cartesian HD). Defined. Definition disp_map_bicat_comprehension_bicat (HD : is_covariant_disp_map_bicat D) : comprehension_bicat := _ ,, _ ,, is_covariant_disp_map_bicat_to_comp_bicat HD. Definition disp_map_bicat_contravariant_comprehension_bicat (HD : is_contravariant_disp_map_bicat D) : contravariant_comprehension_bicat := _ ,, _ ,, is_contravariant_disp_map_bicat_to_comp_bicat HD. End DispMapBicatToCompBicat. (** 5. Internal Street fibrations and opfibrations *) Definition internal_sfib_comprehension_bicat_structure (B : bicat_with_pb) (HB : is_univalent_2 B) : comprehension_bicat_structure B := disp_map_bicat_to_comp_bicat (sfib_disp_map_bicat B) HB. Definition is_contravariant_internal_sfib_comprehension_bicat_structure (B : bicat_with_pb) (HB : is_univalent_2 B) : is_contravariant (internal_sfib_comprehension_bicat_structure B HB). Proof. use is_contravariant_disp_map_bicat_to_comp_bicat. apply sfib_disp_map_bicat_is_contravariant. Defined. Definition internal_sfib_contravariant_comprehension_bicat (B : bicat_with_pb) (HB : is_univalent_2 B) : contravariant_comprehension_bicat := _ ,, _ ,, is_contravariant_internal_sfib_comprehension_bicat_structure B HB. Definition internal_sopfib_comprehension_bicat_structure (B : bicat_with_pb) (HB : is_univalent_2 B) : comprehension_bicat_structure B := disp_map_bicat_to_comp_bicat (sopfib_disp_map_bicat B) HB. Definition is_covariant_internal_sopfib_comprehension_bicat_structure (B : bicat_with_pb) (HB : is_univalent_2 B) : is_covariant (internal_sopfib_comprehension_bicat_structure B HB). Proof. use is_covariant_disp_map_bicat_to_comp_bicat. apply sopfib_disp_map_bicat_is_covariant. Defined. Definition internal_sopfib_comprehension_bicat (B : bicat_with_pb) (HB : is_univalent_2 B) : comprehension_bicat := _ ,, _ ,, is_covariant_internal_sopfib_comprehension_bicat_structure B HB. UniMath-20231010/UniMath/Bicategories/Logic/Examples/FibrationsComprehensionBicat.v000066400000000000000000000337571451125700300300720ustar00rootroot00000000000000(******************************************************************* The comprehension bicategory of fibrations Contents 1. The comprehension pseudofunctor 2. Preservation of cartesian 1-cells 3. Preservation of cartesian 2-cells 4. The comprehension bicategory *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.FibrationCleaving. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. (** 1. The comprehension pseudofunctor *) Definition cleaving_comprehension_data : disp_psfunctor_data disp_bicat_of_cleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ C D, total_univalent_category (pr1 D) ,, pr1_category _). - intros C₁ C₂ F D₁ D₂ FF. use make_disp_1cell_cod. + exact (total_functor (pr1 FF)). + use nat_z_iso_to_invertible_2cell. exact (total_functor_commute_z_iso (pr1 FF)). - intros C₁ C₂ F G α D₁ D₂ FF GG αα. use make_disp_2cell_cod. + exact (total_nat_trans (pr1 αα)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left, id_right ; apply idpath). - intros C D. simple refine (_ ,, _). + use make_disp_2cell_cod. * exact (total_functor_identity (pr11 D)). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; rewrite !id_left ; apply idpath). + use is_disp_invertible_2cell_cod. use is_nat_z_iso_to_is_invertible_2cell. intro x. apply identity_is_z_iso. - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG. simple refine (_ ,, _). + use make_disp_2cell_cod. * exact (total_functor_comp (pr1 FF) (pr1 GG)). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; rewrite !id_left, !id_right ; apply functor_id). + use is_disp_invertible_2cell_cod. use is_nat_z_iso_to_is_invertible_2cell. intro x. apply identity_is_z_iso. Defined. Definition cleaving_comprehension_is_disp_psfunctor : is_disp_psfunctor disp_bicat_of_cleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) cleaving_comprehension_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply cellset_property | ]). - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite functor_id, !id_right ; apply idpath). + rewrite !id_right_disp. rewrite disp_functor_id. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right ; apply idpath). + rewrite !id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite functor_id, !id_right ; apply idpath). + rewrite !id_right_disp, !id_left_disp. rewrite disp_functor_id. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right, !id_left ; apply idpath). + rewrite !id_right_disp, !id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right, !id_left ; apply idpath). + rewrite !id_right_disp, !id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition cleaving_comprehension : disp_psfunctor disp_bicat_of_cleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats). Proof. simple refine (_ ,, _). - exact cleaving_comprehension_data. - exact cleaving_comprehension_is_disp_psfunctor. Defined. (** 2. Preservation of cartesian 1-cells *) Definition global_cartesian_cleaving_comprehension : global_cartesian_disp_psfunctor cleaving_comprehension. Proof. use preserves_global_lifts_to_cartesian. - exact univalent_cat_is_univalent_2. - exact (cod_disp_univalent_2 _ univalent_cat_is_univalent_2). - exact cleaving_of_cleaving_global_cleaving. - intros C₁ C₂ F D₁. use is_pb_to_cartesian_1cell. apply reindexing_has_pb_ump. apply is_isofibration_from_is_fibration. exact (pr2 D₁). Defined. (** 3. Preservation of cartesian 2-cells *) Section LocalCartesianFibration. Context {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} (α : F₁ ==> F₂) {D₁ : disp_bicat_of_cleaving C₁} {D₂ : disp_bicat_of_cleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : disp_2cells α FF₁ FF₂) (Hαα : ∏ (x : C₁ : univalent_category) (xx : (pr1 D₁ : disp_univalent_category _) x), is_cartesian ((pr11 αα) x xx)) (G : bicat_of_univ_cats ⟦ total_univalent_category (pr1 D₁) , total_univalent_category (pr1 D₂) ⟧) (γ : G ==> total_functor (pr1 FF₂)) (δp : (G ∙ pr1_category (pr11 D₂) : bicat_of_univ_cats ⟦ _ , _ ⟧) ==> total_functor (pr1 FF₁) ∙ pr1_category (pr11 D₂)) (q : post_whisker γ (pr1_category (pr11 D₂)) = nat_trans_comp _ _ _ δp (post_whisker (total_nat_trans (pr1 αα)) (pr1_category _))). Definition local_cartesian_cleaving_lift_data : nat_trans_data (pr1 G) (total_functor (pr1 FF₁)). Proof. refine (λ x, pr1 δp x ,, _) ; cbn. refine (cartesian_factorisation (Hαα (pr1 x) (pr2 x)) _ _). exact (transportf (λ z, _ -->[ z ] _) (nat_trans_eq_pointwise q x) (pr2 (pr1 γ x))). Defined. Definition local_cartesian_cleaving_lift_is_nat_trans : is_nat_trans _ _ local_cartesian_cleaving_lift_data. Proof. intros x y f ; cbn. use total2_paths_f. - exact (nat_trans_ax δp x y f). - use (cartesian_factorisation_unique (Hαα (pr1 y) (pr2 y))). cbn. rewrite assoc_disp_var. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. refine (!_). etrans. { apply maponpaths. apply maponpaths. apply disp_nat_trans_ax. } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. refine (!_). exact (fiber_paths (nat_trans_ax γ _ _ f)). } rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition local_cartesian_cleaving_lift : G ==> total_functor (pr1 FF₁). Proof. use make_nat_trans. - exact local_cartesian_cleaving_lift_data. - exact local_cartesian_cleaving_lift_is_nat_trans. Defined. Definition local_cartesian_cleaving_lift_over : local_cartesian_cleaving_lift ▹ _ = δp. Proof. use nat_trans_eq ; [ apply homset_property | ]. intro x. apply idpath. Qed. Definition local_cartesian_cleaving_lift_comm : local_cartesian_cleaving_lift • total_nat_trans (pr1 αα) = γ. Proof. use nat_trans_eq ; [ apply homset_property | ]. intro x. cbn. use total2_paths_f. - exact (!(nat_trans_eq_pointwise q x)). - cbn. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Definition local_cartesian_cleaving_lift_unique : isaprop (∑ δ, δ ▹ _ = δp × δ • total_nat_trans (pr1 αα) = γ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro x. use total2_paths_f. - exact (nat_trans_eq_pointwise (pr12 φ₁) x @ !(nat_trans_eq_pointwise (pr12 φ₂) x)). - use (cartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))). rewrite mor_disp_transportf_postwhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (nat_trans_eq_pointwise (pr22 φ₁) x))). } refine (!_). etrans. { exact (transportb_transpose_right (fiber_paths (nat_trans_eq_pointwise (pr22 φ₂) x))). } unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. End LocalCartesianFibration. Definition local_cartesian_cleaving_comprehension : local_cartesian_disp_psfunctor cleaving_comprehension. Proof. intros C₁ C₂ F₁ F₂ α D₁ D₂ FF₁ FF₂ αα Hαα. apply is_cartesian_2cell_sfib_to_is_cartesian_2cell ; cbn. pose (cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian _ Hαα) as p. intros G γ δp q. use iscontraprop1. - exact (local_cartesian_cleaving_lift_unique α αα p G γ δp). - simple refine (_ ,, _ ,, _). + exact (local_cartesian_cleaving_lift α αα p G γ δp q). + exact (local_cartesian_cleaving_lift_over α αα p G γ δp q). + exact (local_cartesian_cleaving_lift_comm α αα p G γ δp q). Defined. (** 4. The comprehension bicategory *) Definition cleaving_comprehension_bicat_structure : comprehension_bicat_structure bicat_of_univ_cats. Proof. use make_comprehension_bicat_structure. - exact disp_bicat_of_cleaving. - exact cleaving_comprehension. - exact cleaving_of_cleaving_global_cleaving. - exact global_cartesian_cleaving_comprehension. Defined. Definition cleaving_comprehension_is_contravariant : is_contravariant cleaving_comprehension_bicat_structure. Proof. repeat split. - exact cleaving_of_cleaving_local_cleaving. - exact cleaving_of_cleaving_lwhisker_cartesian. - exact cleaving_of_cleaving_rwhisker_cartesian. - exact local_cartesian_cleaving_comprehension. Defined. Definition cleaving_contravariant_comprehension_bicat : contravariant_comprehension_bicat := _ ,, _ ,, cleaving_comprehension_is_contravariant. UniMath-20231010/UniMath/Bicategories/Logic/Examples/FunctorsIntoCatComprehensionBicat.v000066400000000000000000000527361451125700300310550ustar00rootroot00000000000000(******************************************************************* The comprehension bicategory of functors into the category of strict categories Contents 1. The comprehension pseudofunctor 2. Preservation of cartesian cells 3. The comprehension bicategory *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory. Require Import UniMath.CategoryTheory.GrothendieckConstruction.IsosInTotal. Require Import UniMath.CategoryTheory.GrothendieckConstruction.IsOpfibration. Require Import UniMath.CategoryTheory.GrothendieckConstruction.IsPullback. Require Import UniMath.CategoryTheory.GrothendieckConstruction.Projection. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.Examples.FibrationsInStrictCats. Require Import UniMath.Bicategories.Core.Examples.StrictCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FunctorsIntoCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatToDispBicat. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.FunctorsIntoCatCleaving. Require Import UniMath.Bicategories.Limits.Products. Import Products.Notations. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. (** 1. The comprehension pseudofunctor *) Definition functors_into_cat_comprehension_data : disp_psfunctor_data disp_bicat_of_functors_into_cat (cod_disp_bicat bicat_of_strict_cats) (id_psfunctor bicat_of_strict_cats). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ C F, total_setcategory_of_set_functor F ,, pr1_total_category_of_set_functor F). - refine (λ C₁ C₂ F G₁ G₂ α, functor_total_category_of_set_functor F α ,, _). use make_invertible_2cell. + exact (functor_total_category_of_set_functor_comm F α). + apply is_invertible_2cell_bicat_of_strict_cat. exact (is_nat_z_iso_functor_total_category_of_set_functor_comm F α). - refine (λ C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂ p, nat_trans_total_category_of_set_functor α β₁ β₂ p ,, _). abstract (use nat_trans_eq ; [ apply C₂ | ] ; intro x ; cbn ; rewrite id_left, id_right ; apply idpath). - intros C F. simple refine (_ ,, _). + simple refine (_ ,, _). * exact (functor_total_category_of_set_functor_on_id F). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left ; apply idpath). + use is_disp_invertible_2cell_cod. use is_invertible_2cell_bicat_of_strict_cat. exact (is_nat_z_iso_functor_total_category_of_set_functor_on_id F). - intros C₁ C₂ C₃ F₁ F₂ G₁ G₂ G₃ α β. simple refine (_ ,, _). + simple refine (_ ,, _). * exact (functor_total_category_of_set_functor_on_comp α β). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left ; rewrite (functor_id F₂) ; rewrite !id_right ; apply idpath). + use is_disp_invertible_2cell_cod. use is_invertible_2cell_bicat_of_strict_cat. exact (is_nat_z_iso_functor_total_category_of_set_functor_on_comp α β). Defined. Definition is_disp_psfunctor_functors_into_cat_comprehension : is_disp_psfunctor _ _ _ functors_into_cat_comprehension_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply cellset_property | ]). - refine (_ @ !(transportb_cell_of_cod_over _ _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + apply idpath. + cbn. refine (_ @ !(id_left _)). apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over _ _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + apply idpath. + cbn. refine (_ @ !(id_left _)). refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 bb) (pr1 φ (pr1 x)))). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb (pr1 η (pr1 x)) (pr1 φ (pr1 x))) (pr1 (pr1 ff (pr1 x)) (pr2 x)))). } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb (pr1 η (pr1 x)) (pr1 φ (pr1 x))) (pr1 (pr1 ff (pr1 x)) (pr2 x)) @ _)). } apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + abstract (cbn ; rewrite !id_right ; rewrite functor_id ; apply idpath). + cbn. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (pr1 ff (pr1 x))). } refine (!_). apply (pr1_idtoiso_concat (functor_total_category_of_set_functor_eq f ff (id₁ (pr1 x) ,, _))). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 bb) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id bb _) _)). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 bb) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _ @ _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat _ ((eq_in_set_fiber (functor_comp bb _ _) _ @ _) @ _)). } apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + abstract (cbn ; rewrite !id_right ; apply idpath). + cbn. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 bb) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id bb _) _)). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 bb) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp bb _ _) _ @ _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat _ ((eq_in_set_fiber (functor_comp bb _ _) _ @ _) @ _)). } apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + abstract (cbn ; rewrite functor_id ; apply idpath). + cbn. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 dd) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _)). } refine (!_). exact (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id dd _) _)). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 dd) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _ @ _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (pr1 hh _)). } refine (!_). apply (pr1_idtoiso_concat _ (maponpaths (pr11 (pr1 hh _)) (eq_in_set_fiber (functor_id cc _) _))). } etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 dd) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _ @ _)). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 dd) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp dd _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id dd _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat _ (_ @ eq_in_set_fiber (functor_id dd _) _)). } apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + abstract (cbn ; rewrite id_left, id_right ; apply idpath). + cbn. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 cc) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _ @ _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 cc) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id cc _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat _ (_ @ eq_in_set_fiber (functor_id cc _) _)). } apply setcategory_eq_idtoiso. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)). use nat_trans_eq ; [ apply homset_property | ]. intro x. use eq_mor_category_of_set_functor. + abstract (cbn ; rewrite id_left, id_right ; apply idpath). + cbn. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 cc) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _ @ _)). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (pr1 gg _)). } refine (!_). apply (pr1_idtoiso_concat (functor_total_category_of_set_functor_eq g gg (nat_trans_total_category_of_set_functor_data η ff₁ ff₂ ηη x))). } refine (!_). apply (pr1_maponpaths_idtoiso (# (pr1 cc) _)). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp cc _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id cc _) _)). } etrans. { refine (!_). apply (pr1_idtoiso_concat _ (_ @ eq_in_set_fiber (functor_id cc _) _)). } apply setcategory_eq_idtoiso. Qed. Definition functors_into_cat_comprehension : disp_psfunctor disp_bicat_of_functors_into_cat (cod_disp_bicat bicat_of_strict_cats) (id_psfunctor bicat_of_strict_cats) := functors_into_cat_comprehension_data ,, is_disp_psfunctor_functors_into_cat_comprehension. (** 2. Preservation of cartesian cells *) Definition total_set_category_has_pb_ump {C₁ C₂ : setcategory} {F : C₁ ⟶ C₂} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} (α : G₁ ⟹ F ∙ G₂) (Hα : is_nat_z_iso α) : has_pb_ump (@make_pb_cone bicat_of_strict_cats C₁ (total_setcategory_of_set_functor G₂) C₂ F (pr1_total_category_of_set_functor G₂) (total_setcategory_of_set_functor G₁) (pr1_total_category_of_set_functor G₁) (functor_total_category_of_set_functor F α) (make_invertible_2cell (is_invertible_2cell_bicat_of_strict_cat (functor_total_category_of_set_functor_comm F α) (is_nat_z_iso_functor_total_category_of_set_functor_comm F α)))). Proof. split. - intro x. use make_pb_1cell. + apply (@total_set_category_pb_ump_1_mor _ _ _ _ _ _ Hα _ (pb_cone_pr1 x) (pb_cone_pr2 x) (pr1 (pb_cone_cell x))). apply from_is_invertible_2cell_bicat_of_strict_cat. apply property_from_invertible_2cell. + use make_invertible_2cell. * apply (@total_set_category_pb_ump_1_mor_pr1 _ _ _ _ _ _ Hα _ (pb_cone_pr1 x) (pb_cone_pr2 x) (pr1 (pb_cone_cell x))). * apply is_invertible_2cell_bicat_of_strict_cat. apply total_set_category_pb_ump_1_mor_pr1_is_nat_z_iso. + use make_invertible_2cell. * apply (@total_set_category_pb_ump_1_mor_pr2 _ _ _ _ _ _ Hα _ (pb_cone_pr1 x) (pb_cone_pr2 x) (pr1 (pb_cone_cell x))). * apply is_invertible_2cell_bicat_of_strict_cat. apply total_set_category_pb_ump_1_mor_pr2_is_nat_z_iso. + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro z ; cbn ; rewrite (functor_id F) ; rewrite !id_left, id_right ; exact (!(nat_trans_eq_pointwise (vcomp_rinv (pb_cone_cell x)) z))). - intros C₀ φ₁ φ₂ δ₁ δ₂ p. assert (∏ (x : pr1 C₀), pr1 (pr1 δ₂ x) = # F (pr1 δ₁ x)) as q. { abstract (intro x ; pose (nat_trans_eq_pointwise p x) as q ; cbn in q ; rewrite !id_left, !id_right in q ; exact q). } use iscontraprop1. + apply total_set_category_pb_ump_2_unique. apply Hα. + simple refine (_ ,, _ ,, _). * exact (total_set_category_pb_ump_2_cell _ Hα δ₁ δ₂ q). * apply total_set_category_pb_ump_2_pr1. * apply total_set_category_pb_ump_2_pr2. Defined. Definition local_opcartesian_functors_into_cat_comprehension : local_opcartesian_disp_psfunctor functors_into_cat_comprehension. Proof. intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂ p Hp. use is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell. use strict_pointwise_opcartesian_is_opcartesian. cbn. intro x. apply is_opcartesian_total_setcategory_of_set_functor. cbn. apply z_iso_is_z_isomorphism. Qed. Definition global_cartesian_functors_into_cat_comprehension : global_cartesian_disp_psfunctor functors_into_cat_comprehension. Proof. intros C₁ C₂ F G₁ G₂ α Hα. use is_pb_to_cartesian_1cell. apply total_set_category_has_pb_ump. exact (functors_into_cat_cartesian_1cell_is_nat_iso _ Hα). Defined. (** 3. The comprehension bicategory *) Definition functors_into_cat_comprehension_bicat_structure : comprehension_bicat_structure bicat_of_strict_cats := disp_bicat_of_functors_into_cat ,, functors_into_cat_comprehension ,, functors_into_cat_global_cleaving ,, global_cartesian_functors_into_cat_comprehension. Definition is_covariant_functors_into_cat_comprehension_bicat : is_covariant functors_into_cat_comprehension_bicat_structure. Proof. repeat split. - exact functors_into_cat_local_opcleaving. - intro ; intros. apply functors_into_cat_is_opcartesian_2cell. - intro ; intros. apply functors_into_cat_is_opcartesian_2cell. - exact local_opcartesian_functors_into_cat_comprehension. Defined. Definition functors_into_cat_comprehension_bicat : comprehension_bicat := _ ,, functors_into_cat_comprehension_bicat_structure ,, is_covariant_functors_into_cat_comprehension_bicat. UniMath-20231010/UniMath/Bicategories/Logic/Examples/OpfibrationsComprehensionBicat.v000066400000000000000000000350421451125700300304160ustar00rootroot00000000000000(******************************************************************* The comprehension bicategory of opfibrations Contents 1. The comprehension pseudofunctor 2. Preservation of cartesian 1-cells 3. Preservation of opcartesian 2-cells 4. The comprehension bicategory *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.OpFibrationCleaving. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. (** 1. The comprehension pseudofunctor *) Definition opcleaving_comprehension_data : disp_psfunctor_data disp_bicat_of_opcleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ C D, total_univalent_category (pr1 D) ,, pr1_category _). - intros C₁ C₂ F D₁ D₂ FF. use make_disp_1cell_cod. + exact (total_functor (pr1 FF)). + use nat_z_iso_to_invertible_2cell. exact (total_functor_commute_z_iso (pr1 FF)). - intros C₁ C₂ F G α D₁ D₂ FF GG αα. use make_disp_2cell_cod. + exact (total_nat_trans (pr1 αα)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left, id_right ; apply idpath). - intros C D. simple refine (_ ,, _). + use make_disp_2cell_cod. * exact (total_functor_identity (pr11 D)). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; rewrite !id_left ; apply idpath). + use is_disp_invertible_2cell_cod. use is_nat_z_iso_to_is_invertible_2cell. intro x. apply identity_is_z_iso. - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG. simple refine (_ ,, _). + use make_disp_2cell_cod. * exact (total_functor_comp (pr1 FF) (pr1 GG)). * abstract (use nat_trans_eq ; [ apply homset_property | ] ; intros x ; cbn ; rewrite !id_left, !id_right ; apply functor_id). + use is_disp_invertible_2cell_cod. use is_nat_z_iso_to_is_invertible_2cell. intro x. apply identity_is_z_iso. Defined. Definition opcleaving_comprehension_is_disp_psfunctor : is_disp_psfunctor disp_bicat_of_opcleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats) opcleaving_comprehension_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply cellset_property | ]). - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. apply idpath. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite functor_id, !id_right ; apply idpath). + rewrite !id_right_disp. rewrite disp_functor_id. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right ; apply idpath). + rewrite !id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite functor_id, !id_right ; apply idpath). + rewrite !id_right_disp, !id_left_disp. rewrite disp_functor_id. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right, !id_left ; apply idpath). + rewrite !id_right_disp, !id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)). apply nat_trans_eq ; [ intro ; apply homset_property | ]. intro x ; cbn. use total2_paths_f ; cbn. + abstract (rewrite !id_right, !id_left ; apply idpath). + rewrite !id_right_disp, !id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition opcleaving_comprehension : disp_psfunctor disp_bicat_of_opcleaving (cod_disp_bicat bicat_of_univ_cats) (id_psfunctor bicat_of_univ_cats). Proof. simple refine (_ ,, _). - exact opcleaving_comprehension_data. - exact opcleaving_comprehension_is_disp_psfunctor. Defined. (** 2. Preservation of cartesian 1-cells *) Definition global_cartesian_opcleaving_comprehension : global_cartesian_disp_psfunctor opcleaving_comprehension. Proof. use preserves_global_lifts_to_cartesian. - exact univalent_cat_is_univalent_2. - exact (cod_disp_univalent_2 _ univalent_cat_is_univalent_2). - exact opcleaving_global_cleaving. - intros C₁ C₂ F D₁. use is_pb_to_cartesian_1cell. apply reindexing_has_pb_ump. apply iso_cleaving_from_opcleaving. exact (pr2 D₁). Defined. (** 3. Preservation of opcartesian 2-cells *) Section LocalOpCartesianOpFibration. Context {C₁ C₂ : bicat_of_univ_cats} {F₁ F₂ : C₁ --> C₂} (α : F₁ ==> F₂) {D₁ : disp_bicat_of_opcleaving C₁} {D₂ : disp_bicat_of_opcleaving C₂} {FF₁ : D₁ -->[ F₁ ] D₂} {FF₂ : D₁ -->[ F₂ ] D₂} (αα : disp_2cells α FF₁ FF₂) (Hαα : ∏ (x : C₁ : univalent_category) (xx : (pr1 D₁ : disp_univalent_category _) x), is_opcartesian ((pr11 αα) x xx)) (G : bicat_of_univ_cats ⟦ total_univalent_category (pr1 D₁) , total_univalent_category (pr1 D₂) ⟧) (tot_FF₁ := (total_functor (pr1 FF₁) : bicat_of_univ_cats ⟦ total_univalent_category (pr1 D₁) , total_univalent_category (pr1 D₂) ⟧)) (tot_FF₂ := (total_functor (pr1 FF₂) : bicat_of_univ_cats ⟦ total_univalent_category (pr1 D₁) , total_univalent_category (pr1 D₂) ⟧)) (tot_αα := total_nat_trans (pr1 αα) : tot_FF₁ ==> tot_FF₂) (γ : tot_FF₁ ==> G) (δp : tot_FF₂ · pr1_category _ ==> G · pr1_category _) (q : post_whisker γ (pr1_category (pr11 D₂)) = nat_trans_comp _ _ _ (post_whisker (total_nat_trans (pr1 αα)) (pr1_category _)) δp). Definition local_opcartesian_opcleaving_lift_data : nat_trans_data (pr1 tot_FF₂) (pr1 G). Proof. refine (λ x, pr1 δp x ,, _) ; cbn. refine (opcartesian_factorisation (Hαα (pr1 x) (pr2 x)) _ _). exact (transportf (λ z, _ -->[ z ] _) (nat_trans_eq_pointwise q x) (pr2 (pr1 γ x))). Defined. Definition local_opcartesian_opcleaving_lift_is_nat_trans : is_nat_trans _ _ local_opcartesian_opcleaving_lift_data. Proof. intros x y f ; cbn. use total2_paths_f. - exact (nat_trans_ax δp x y f). - use (opcartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))). cbn. rewrite assoc_disp. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite opcartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. refine (!_). exact (transportf_transpose_left (disp_nat_trans_ax (pr1 αα) (pr2 f))). } rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite opcartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (nat_trans_ax γ _ _ f))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition local_opcartesian_opcleaving_lift : tot_FF₂ ==> G. Proof. use make_nat_trans. - exact local_opcartesian_opcleaving_lift_data. - exact local_opcartesian_opcleaving_lift_is_nat_trans. Defined. Definition local_opcartesian_opcleaving_lift_over : local_opcartesian_opcleaving_lift ▹ _ = δp. Proof. use nat_trans_eq ; [ apply homset_property | ]. intro x. apply idpath. Qed. Definition local_opcartesian_opcleaving_lift_comm : tot_αα • local_opcartesian_opcleaving_lift = γ. Proof. use nat_trans_eq ; [ apply homset_property | ]. intro x. cbn. use total2_paths_f. - exact (!(nat_trans_eq_pointwise q x)). - cbn. rewrite opcartesian_factorisation_commutes. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Definition local_opcartesian_opcleaving_lift_unique : isaprop (∑ δ, δ ▹ _ = δp × tot_αα • δ = γ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro x. use total2_paths_f. - exact (nat_trans_eq_pointwise (pr12 φ₁) x @ !(nat_trans_eq_pointwise (pr12 φ₂) x)). - use (opcartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))). rewrite mor_disp_transportf_prewhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (nat_trans_eq_pointwise (pr22 φ₁) x))). } refine (!_). etrans. { exact (transportb_transpose_right (fiber_paths (nat_trans_eq_pointwise (pr22 φ₂) x))). } unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. End LocalOpCartesianOpFibration. Definition local_opcartesian_opcleaving_comprehension : local_opcartesian_disp_psfunctor opcleaving_comprehension. Proof. intros C₁ C₂ F₁ F₂ α D₁ D₂ FF₁ FF₂ αα Hαα. apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell ; cbn. pose (opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian _ Hαα) as p. intros G γ δp q. use iscontraprop1. - exact (local_opcartesian_opcleaving_lift_unique α αα p G γ δp). - simple refine (_ ,, _ ,, _). + exact (local_opcartesian_opcleaving_lift α αα p G γ δp q). + exact (local_opcartesian_opcleaving_lift_over α αα p G γ δp q). + exact (local_opcartesian_opcleaving_lift_comm α αα p G γ δp q). Defined. (** 4. The comprehension bicategory *) Definition opcleaving_comprehension_bicat_structure : comprehension_bicat_structure bicat_of_univ_cats. Proof. use make_comprehension_bicat_structure. - exact disp_bicat_of_opcleaving. - exact opcleaving_comprehension. - exact opcleaving_global_cleaving. - exact global_cartesian_opcleaving_comprehension. Defined. Definition opcleaving_comprehension_is_covariant : is_covariant opcleaving_comprehension_bicat_structure. Proof. repeat split. - exact cleaving_of_opcleaving_local_opcleaving. - exact cleaving_of_opcleaving_lwhisker_opcartesian. - exact cleaving_of_opcleaving_rwhisker_opcartesian. - exact local_opcartesian_opcleaving_comprehension. Defined. Definition opcleaving_comprehension_bicat : comprehension_bicat := _ ,, _ ,, opcleaving_comprehension_is_covariant. UniMath-20231010/UniMath/Bicategories/Logic/Examples/PullbackComprehensionBicat.v000066400000000000000000000053101451125700300275070ustar00rootroot00000000000000(******************************************************************* Every locally groupoidal bicategory with pullback gives rise to a comprehension bicategory *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. Section PullbackComprehension. Context (B : bicat) (B_pb : has_pb B). Definition pb_comprehension : comprehension_bicat_structure B. Proof. use make_comprehension_bicat_structure. - exact (cod_disp_bicat B). - exact (disp_pseudo_id (cod_disp_bicat B)). - exact (cod_global_cleaving B B_pb). - exact (global_cartesian_id_psfunctor (cod_disp_bicat B)). Defined. Context (HB : locally_groupoid B). Definition locally_grpd_pb_comprehension_is_covariant : is_covariant pb_comprehension. Proof. repeat split. - exact (cod_local_opcleaving _ HB). - exact (cod_cleaving_lwhisker_opcartesian _ HB). - exact (cod_cleaving_rwhisker_opcartesian _ HB). - exact (local_opcartesian_id_psfunctor (cod_disp_bicat B)). Defined. Definition locally_grpd_pb_comprehension_is_contravariant : is_contravariant pb_comprehension. Proof. repeat split. - exact (cod_local_cleaving _ HB). - exact (cod_cleaving_lwhisker_cartesian _ HB). - exact (cod_cleaving_rwhisker_cartesian _ HB). - exact (local_cartesian_id_psfunctor (cod_disp_bicat B)). Defined. Definition locally_grpd_comprehension_bicat : comprehension_bicat := _ ,, _ ,, locally_grpd_pb_comprehension_is_covariant. Definition locally_grpd_contravariant_comprehension_bicat : contravariant_comprehension_bicat := _ ,, _ ,, locally_grpd_pb_comprehension_is_contravariant. End PullbackComprehension. UniMath-20231010/UniMath/Bicategories/Logic/Examples/TrivialComprehensionBicat.v000066400000000000000000000502771451125700300274000ustar00rootroot00000000000000(******************************************************************* The trivial comprehension bicategory If we have a bicategory with products, then we obtain a comprehension bicategory. The fibration comes from the trivial displayed bicategory and for the comprehension pseudofunctor, we use that the bicategory has products. Contents 1. The comprehension pseudofunctor 2. Preservation of cartesian 1-cells 3. Preservation of (op)cartesian 2-cells 4. The comprehension bicategory *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Morphisms.Properties.Projections. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat. Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.TrivialCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving. Require Import UniMath.Bicategories.Limits.Products. Import Products.Notations. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Logic.ComprehensionBicat. Local Open Scope cat. Section TrivialCompBicat. Context (B : bicat_with_binprod). (** 1. The comprehension pseudofunctor *) Definition trivial_comprehension_data : disp_psfunctor_data (trivial_displayed_bicat B B) (cod_disp_bicat B) (id_psfunctor B). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - intros x y. use make_ar. + exact (x ⊗ y). + exact π₁. - intros x₁ x₂ f y₁ y₂ g. use make_disp_1cell_cod. + exact (f ⊗₁ g). + apply inv_of_invertible_2cell. apply pair_1cell_pr1. - intros x₁ x₂ f₁ f₂ α y₁ y₂ g₁ g₂ β. use make_disp_2cell_cod. + exact (α ⊗₂ β). + abstract (unfold coherent_homot ; cbn ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ; apply prod_2cell_pr1_alt). - intro ; intros ; simpl. simple refine (_ ,, _). + use make_disp_2cell_cod. * exact ((pair_1cell_id_id_invertible _ _ _)^-1). * abstract (unfold coherent_homot ; cbn ; refine (maponpaths _ (binprod_ump_2cell_pr1 _ _ _) @ _) ; rewrite !vassocr ; apply maponpaths_2 ; rewrite lwhisker_id2 ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite linvunitor_lunitor ; rewrite id2_left ; apply runitor_rinvunitor). + use is_disp_invertible_2cell_cod. cbn. apply binprod_ump_2cell_invertible ; is_iso. - intro ; intros ; simpl. simple refine (_ ,, _). + use make_disp_2cell_cod. * apply pair_1cell_comp. * abstract (unfold coherent_homot ; cbn ; rewrite !vassocl ; etrans ; [ do 5 apply maponpaths ; apply binprod_ump_2cell_pr1 | ] ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; etrans ; [ do 4 apply maponpaths ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; apply idpath | ] ; etrans ; [ do 3 apply maponpaths ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath | ] ; etrans ; [ do 2 apply maponpaths ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; apply idpath | ] ; etrans ; [ apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath | ] ; rewrite lassociator_rassociator ; rewrite lwhisker_id2 ; apply idpath). + use is_disp_invertible_2cell_cod. cbn. apply pair_1cell_comp_invertible. Defined. Definition trivial_comprehension_is_disp_psfunctor : is_disp_psfunctor (trivial_displayed_bicat B B) (cod_disp_bicat B) (id_psfunctor B) trivial_comprehension_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply cellset_property | ]). - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply pair_2cell_id_id. - refine (_ @ !(transportb_cell_of_cod_over _ _)). apply pair_2cell_comp. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)). apply binprod_lunitor. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)). apply binprod_runitor. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)). apply binprod_lassociator. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)). apply binprod_lwhisker. - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)). apply binprod_rwhisker. Qed. Definition trivial_comprehension : disp_psfunctor (trivial_displayed_bicat B B) (cod_disp_bicat B) (id_psfunctor B). Proof. simple refine (_ ,, _). - exact trivial_comprehension_data. - exact trivial_comprehension_is_disp_psfunctor. Defined. (** 2. Preservation of cartesian 1-cells *) Section GlobalCartesian. Context {b₁ b₂ : B} (f : b₁ --> b₂) {c₁ c₂ : B} (l : c₁ --> c₂) (Hl : left_adjoint_equivalence l). Let cone : pb_cone f π₁ := make_pb_cone (b₁ ⊗ c₁) π₁ (f ⊗₁ l) (inv_of_invertible_2cell (pair_1cell_pr1 B f l)). Let r : c₂ --> c₁ := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ c₁) (l · left_adjoint_right_adjoint Hl) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (left_adjoint_right_adjoint Hl · l) (id₁ c₂) := left_equivalence_counit_iso Hl. Section AdjEquivToUMP1. Context (q : pb_cone f (π₁ : b₂ ⊗ c₂ --> b₂)). Local Definition adj_equiv_to_pb_ump_1_pb_1cell_map : q --> b₁ ⊗ c₁ := ⟨ pb_cone_pr1 q , pb_cone_pr2 q · π₂ · r ⟩. Local Notation "'φ'" := adj_equiv_to_pb_ump_1_pb_1cell_map. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_π₁ : invertible_2cell (φ · π₁) (pb_cone_pr1 q) := prod_1cell_pr1 _ _ _. Local Notation "'φπ₁'" := adj_equiv_to_pb_ump_1_pb_1cell_π₁. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁ : φ · (f ⊗₁ l) · π₁ ==> pb_cone_pr2 q · π₁ := rassociator _ _ _ • (_ ◃ pair_1cell_pr1 _ _ _) • lassociator _ _ _ • (prod_1cell_pr1 _ _ _ ▹ _) • pb_cone_cell _. Local Notation "'φπ₂_cell_π₁'" := adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂ : φ · (f ⊗₁ l) · π₂ ==> pb_cone_pr2 q · π₂ := rassociator _ _ _ • (_ ◃ pair_1cell_pr2 _ _ _) • lassociator _ _ _ • (prod_1cell_pr2 _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ ε) • runitor _. Local Notation "'φπ₂_cell_π₂'" := adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell : φ · (f ⊗₁ l) ==> pb_cone_pr2 q. Proof. use binprod_ump_2cell. - exact (pr2 (binprod_of B b₂ c₂)). - exact φπ₂_cell_π₁. - exact φπ₂_cell_π₂. Defined. Local Notation "'φπ₂_cell'" := adj_equiv_to_pb_ump_1_pb_1cell_cell. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_invcell : invertible_2cell (φ · (f ⊗₁ l)) (pb_cone_pr2 q). Proof. use make_invertible_2cell. - exact φπ₂_cell. - use binprod_ump_2cell_invertible ; unfold adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁ ; unfold adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂. + is_iso. * apply pair_1cell_pr1. * apply prod_1cell_pr1. * apply pb_cone_cell. + is_iso. * apply pair_1cell_pr2. * apply prod_1cell_pr2. * apply ε. Defined. Local Notation "'φπ₂'" := adj_equiv_to_pb_ump_1_pb_1cell_invcell. Local Definition adj_equiv_to_pb_ump_1_pb_1cell_eq : φ ◃ pb_cone_cell cone = lassociator φ (pb_cone_pr1 cone) f • (φπ₁ ▹ f) • pb_cone_cell q • (φπ₂ ^-1 ▹ π₁) • rassociator φ (pb_cone_pr2 cone) π₁. Proof. cbn. rewrite !vassocl. refine (!_). etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Definition adj_equiv_to_pb_ump_1_pb_1cell : pb_1cell q cone. Proof. use make_pb_1cell. - exact φ. - exact φπ₁. - exact φπ₂. - exact adj_equiv_to_pb_ump_1_pb_1cell_eq. Defined. End AdjEquivToUMP1. Definition adj_equiv_to_pb_ump_1 : pb_ump_1 cone. Proof. intro q. exact (adj_equiv_to_pb_ump_1_pb_1cell q). Defined. Section AdjEquivToUMP2. Context {q : B} {φ ψ : q --> cone} (α : φ · pb_cone_pr1 cone ==> ψ · pb_cone_pr1 cone) (β : φ · pb_cone_pr2 cone ==> ψ · pb_cone_pr2 cone) (p : (φ ◃ pb_cone_cell cone) • lassociator φ (pb_cone_pr2 cone) π₁ • (β ▹ π₁) • rassociator ψ (pb_cone_pr2 cone) π₁ = lassociator φ (pb_cone_pr1 cone) f • (α ▹ f) • rassociator ψ (pb_cone_pr1 cone) f • (ψ ◃ pb_cone_cell cone)). Let φπ₂ : φ · π₂ ==> ψ · π₂ := fully_faithful_1cell_inv_map (adj_equiv_fully_faithful Hl) (rassociator φ π₂ l • (φ ◃ (pair_1cell_pr2 B f l) ^-1) • lassociator φ (f ⊗₁ l) π₂ • (β ▹ π₂) • rassociator ψ (f ⊗₁ l) π₂ • (ψ ◃ pair_1cell_pr2 B f l) • lassociator ψ π₂ l). Definition adj_equiv_to_pb_ump_2_unique : isaprop (∑ (γ : φ ==> ψ), γ ▹ pb_cone_pr1 cone = α × γ ▹ pb_cone_pr2 cone = β). Proof. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use binprod_ump_2cell_unique. - exact (pr2 (binprod_of B b₁ c₁)). - exact α. - exact φπ₂. - exact (pr12 ζ₁). - use (fully_faithful_1cell_eq (adj_equiv_fully_faithful Hl)). refine (!_). etrans. { apply fully_faithful_1cell_inv_map_eq. } cbn -[η]. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (!(pr22 ζ₁)). - exact (pr12 ζ₂). - use (fully_faithful_1cell_eq (adj_equiv_fully_faithful Hl)). refine (!_). etrans. { apply fully_faithful_1cell_inv_map_eq. } cbn -[η]. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (!(pr22 ζ₂)). Qed. Definition adj_equiv_to_pb_ump_2_cell : φ ==> ψ. Proof. use binprod_ump_2cell. - exact (pr2 (binprod_of B b₁ c₁)). - exact α. - exact φπ₂. Defined. Definition adj_equiv_to_pb_ump_2_cell_pr1 : adj_equiv_to_pb_ump_2_cell ▹ pb_cone_pr1 cone = α. Proof. apply binprod_ump_2cell_pr1. Qed. Definition adj_equiv_to_pb_ump_2_cell_pr2 : adj_equiv_to_pb_ump_2_cell ▹ pb_cone_pr2 cone = β. Proof. use binprod_ump_2cell_unique. - exact (pr2 (binprod_of B b₂ c₂)). - exact (rassociator _ _ _ • (_ ◃ pair_1cell_pr1 _ _ _) • lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (_ ◃ (pair_1cell_pr1 _ _ _)^-1) • lassociator _ _ _). - exact (β ▹ _). - cbn ; cbn in p. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite <- rwhisker_rwhisker. do 2 apply maponpaths. apply binprod_ump_2cell_pr1. - cbn. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite rwhisker_rwhisker. use (vcomp_lcancel (_ ◃ (pair_1cell_pr2 B f l)^-1)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- vcomp_whisker. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. etrans. { do 3 apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } do 3 (use vcomp_move_R_Mp ; [ is_iso | ]). apply fully_faithful_1cell_inv_map_eq. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. use vcomp_move_L_pM ; [ is_iso ; apply pair_1cell_pr1 | ]. cbn. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. exact p. - apply idpath. Qed. End AdjEquivToUMP2. Definition adj_equiv_to_pb_ump_2 : pb_ump_2 cone. Proof. intros q φ ψ α β p. use iscontraprop1. - exact (adj_equiv_to_pb_ump_2_unique α β). - exact (adj_equiv_to_pb_ump_2_cell α β ,, adj_equiv_to_pb_ump_2_cell_pr1 α β ,, adj_equiv_to_pb_ump_2_cell_pr2 α β p). Defined. Definition adj_equiv_to_pb : has_pb_ump cone. Proof. split. - exact adj_equiv_to_pb_ump_1. - exact adj_equiv_to_pb_ump_2. Defined. End GlobalCartesian. Definition global_cartesian_trivial_comprehension : global_cartesian_disp_psfunctor trivial_comprehension. Proof. intros b₁ b₂ f c₁ c₂ g Hg ; cbn in *. apply is_pb_to_cartesian_1cell. pose (g_equiv := trivial_cartesian_1cell_is_adj_equiv _ _ _ _ Hg). apply (adj_equiv_to_pb f g g_equiv). Defined. (** 3. Preservation of (op)cartesian 2-cells *) Definition local_cartesian_trivial_comprehension : local_cartesian_disp_psfunctor trivial_comprehension. Proof. intros b₁ b₂ f₁ f₂ α c₁ c₂ g₁ g₂ β Hβ ; cbn in *. apply is_cartesian_2cell_sfib_to_is_cartesian_2cell ; cbn. apply invertible_to_cartesian. refine (transportb is_invertible_2cell (pair_2cell_pr2 _ _ _) _). is_iso. - apply prod_1cell_pr2. - exact (trivial_cartesian_2cell_is_invertible _ _ _ _ Hβ). Defined. Definition local_opcartesian_trivial_comprehension : local_opcartesian_disp_psfunctor trivial_comprehension. Proof. intros b₁ b₂ f₁ f₂ α c₁ c₂ g₁ g₂ β Hβ ; cbn in *. apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell ; cbn. apply invertible_to_opcartesian. refine (transportb is_invertible_2cell (pair_2cell_pr2 _ _ _) _). is_iso. - apply prod_1cell_pr2. - exact (trivial_opcartesian_2cell_is_invertible _ _ _ _ Hβ). Defined. (** 4. The comprehension bicategory *) Definition trivial_comprehension_bicat_structure : comprehension_bicat_structure B. Proof. use make_comprehension_bicat_structure. - exact (trivial_displayed_bicat B B). - exact trivial_comprehension. - exact (trivial_global_cleaving B B). - exact global_cartesian_trivial_comprehension. Defined. Definition trivial_comprehension_is_covariant : is_covariant trivial_comprehension_bicat_structure. Proof. repeat split. - exact (trivial_local_opcleaving B B). - exact (trivial_lwhisker_opcartesian B B). - exact (trivial_rwhisker_opcartesian B B). - exact local_opcartesian_trivial_comprehension. Defined. Definition trivial_comprehension_is_contravariant : is_contravariant trivial_comprehension_bicat_structure. Proof. repeat split. - exact (trivial_local_cleaving B B). - exact (trivial_lwhisker_cartesian B B). - exact (trivial_rwhisker_cartesian B B). - exact local_cartesian_trivial_comprehension. Defined. Definition trivial_comprehension_bicat : comprehension_bicat := _ ,, _ ,, trivial_comprehension_is_covariant. Definition trivial_contravariant_comprehension_bicat : contravariant_comprehension_bicat := _ ,, _ ,, trivial_comprehension_is_contravariant. End TrivialCompBicat. UniMath-20231010/UniMath/Bicategories/Modifications/000077500000000000000000000000001451125700300220445ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Modifications/Examples/000077500000000000000000000000001451125700300236225ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Modifications/Examples/ApModification.v000066400000000000000000000043221451125700300267000ustar00rootroot00000000000000(** A homotopy between homotopy gives rise to a modification *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Core.Examples.TwoType. Require Import UniMath.Bicategories.PseudoFunctors.Examples.ApFunctor. Require Import UniMath.Bicategories.Transformations.Examples.ApTransformation. Local Open Scope cat. Definition homothomotsec_natural {X Y : UU} {f g : X → Y} {e₁ e₂ : f ~ g} (h : e₁ ~ e₂) {x y : X} (p : x = y) : homotsec_natural e₁ p @ maponpaths (λ s : f y = g y, maponpaths f p @ s) (h y) = maponpaths (λ s : f x = g x, s @ maponpaths g p) (h x) @ homotsec_natural e₂ p. Proof. induction p ; cbn. induction (h x). apply pathscomp0rid. Defined. Section ApModification. Context {X Y : UU} (HX : isofhlevel 4 X) (HY : isofhlevel 4 Y) {f g : X → Y} {e₁ e₂ : f ~ g} (h : e₁ ~ e₂). Definition ap_modification_data : modification_data (ap_pstrans HX HY e₁) (ap_pstrans HX HY e₂) := h. Definition ap_modification_is_modification : is_modification ap_modification_data. Proof. intros x y p. exact (homothomotsec_natural h p). Qed. Definition ap_modification : modification (ap_pstrans HX HY e₁) (ap_pstrans HX HY e₂). Proof. use make_modification. - exact ap_modification_data. - exact ap_modification_is_modification. Defined. End ApModification. UniMath-20231010/UniMath/Bicategories/Modifications/Examples/Associativity.v000066400000000000000000000112421451125700300266440ustar00rootroot00000000000000(* ******************************************************************************* *) (** Associativity laws are inverses ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope cat. Section Associativity. Context {B₁ B₂ B₃ B₄: bicat}. Variable (F₁ : psfunctor B₁ B₂) (F₂ : psfunctor B₂ B₃) (F₃ : psfunctor B₃ B₄). Definition lassociator_rassociator_pstrans_data : invertible_modification_data (comp_pstrans (lassociator_pstrans F₁ F₂ F₃) (rassociator_pstrans F₁ F₂ F₃)) (id_pstrans _). Proof. intros X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition lassociator_rassociator_pstrans_modification : is_modification lassociator_rassociator_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition lassociator_rassociator_pstrans : invertible_modification (comp_pstrans (lassociator_pstrans F₁ F₂ F₃) (rassociator_pstrans F₁ F₂ F₃)) (id_pstrans _). Proof. use make_invertible_modification. - exact lassociator_rassociator_pstrans_data. - exact lassociator_rassociator_pstrans_modification. Defined. Definition rassociator_lassociator_pstrans_data : invertible_modification_data (comp_pstrans (rassociator_pstrans F₁ F₂ F₃) (lassociator_pstrans F₁ F₂ F₃)) (id_pstrans _). Proof. intros X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition rassociator_lassociator_pstrans_is_modification : is_modification rassociator_lassociator_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition rassociator_lassociator_pstrans : invertible_modification (comp_pstrans (rassociator_pstrans F₁ F₂ F₃) (lassociator_pstrans F₁ F₂ F₃)) (id_pstrans _). Proof. use make_invertible_modification. - exact rassociator_lassociator_pstrans_data. - exact rassociator_lassociator_pstrans_is_modification. Defined. End Associativity. UniMath-20231010/UniMath/Bicategories/Modifications/Examples/ModificationIntoCat.v000066400000000000000000000057141451125700300277070ustar00rootroot00000000000000(*********************************************************************************** Modification and indexed transformations In this file, we relate modifications and indexed transformations. We can directly construct maps back and forth due to the similarity of their definitions. Contents 1. Indexed transformations to modifications 2. Modifications to indexed transformations ***********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.PseudoTransformationIntoCat. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope cat. (** 1. Indexed transformations to modifications *) Definition indexed_nat_trans_to_modification {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans τ θ) : modification (indexed_functor_to_pstrans τ) (indexed_functor_to_pstrans θ). Proof. use make_modification. - exact (λ x, m x). - abstract (intros x y f ; cbn in x, y, f ; use nat_trans_eq ; [ apply homset_property | ] ; intro xx ; exact (indexed_nat_trans_natural m f xx)). Defined. (** 2. Modifications to indexed transformations *) Definition modification_to_indexed_nat_trans {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} {τ θ : pstrans F G} (m : modification τ θ) : indexed_nat_trans (pstrans_to_indexed_functor τ) (pstrans_to_indexed_functor θ). Proof. use make_indexed_nat_trans. - exact (λ x, m x). - abstract (intros x y f xx ; exact (nat_trans_eq_pointwise (modnaturality_of m x y f) xx)). Defined. UniMath-20231010/UniMath/Bicategories/Modifications/Examples/Unitality.v000066400000000000000000000160521451125700300257770ustar00rootroot00000000000000(* ******************************************************************************* *) (** Unitality laws are inverses ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope cat. Section LeftUnitality. Context {B₁ B₂ : bicat}. Variable (F : psfunctor B₁ B₂). Definition lunitor_linvunitor_pstrans_data : invertible_modification_data (comp_pstrans (lunitor_pstrans F) (linvunitor_pstrans F)) (id_pstrans _). Proof. intro X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition lunitor_linvunitor_pstrans_is_modification : is_modification lunitor_linvunitor_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition lunitor_linvunitor_pstrans : invertible_modification (comp_pstrans (lunitor_pstrans F) (linvunitor_pstrans F)) (id_pstrans _). Proof. use make_invertible_modification. - exact lunitor_linvunitor_pstrans_data. - exact lunitor_linvunitor_pstrans_is_modification. Defined. Definition linvunitor_lunitor_pstrans_data : invertible_modification_data (comp_pstrans (linvunitor_pstrans F) (lunitor_pstrans F)) (id_pstrans _). Proof. intro X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition linvunitor_lunitor_pstrans_is_modification : is_modification linvunitor_lunitor_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition linvunitor_lunitor_pstrans : invertible_modification (comp_pstrans (linvunitor_pstrans F) (lunitor_pstrans F)) (id_pstrans _). Proof. use make_invertible_modification. - exact linvunitor_lunitor_pstrans_data. - exact linvunitor_lunitor_pstrans_is_modification. Defined. End LeftUnitality. Section RightUnitality. Context {B₁ B₂ : bicat}. Variable (F : psfunctor B₁ B₂). Definition runitor_rinvunitor_pstrans_data : invertible_modification_data (comp_pstrans (runitor_pstrans F) (rinvunitor_pstrans F)) (id_pstrans _). Proof. intro X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition runitor_rinvunitor_pstrans_is_modification : is_modification runitor_rinvunitor_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition runitor_rinvunitor_pstrans : invertible_modification (comp_pstrans (runitor_pstrans F) (rinvunitor_pstrans F)) (id_pstrans _). Proof. use make_invertible_modification. - exact runitor_rinvunitor_pstrans_data. - exact runitor_rinvunitor_pstrans_is_modification. Defined. Definition rinvunitor_runitor_pstrans_data : invertible_modification_data (comp_pstrans (rinvunitor_pstrans F) (runitor_pstrans F)) (id_pstrans _). Proof. intro X. use make_invertible_2cell. - exact (lunitor _). - is_iso. Defined. Definition rinvunitor_runitor_pstrans_is_modification : is_modification rinvunitor_runitor_pstrans_data. Proof. intros X Y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition rinvunitor_runitor_pstrans : invertible_modification (comp_pstrans (rinvunitor_pstrans F) (runitor_pstrans F)) (id_pstrans _). Proof. use make_invertible_modification. - exact rinvunitor_runitor_pstrans_data. - exact rinvunitor_runitor_pstrans_is_modification. Defined. End RightUnitality. UniMath-20231010/UniMath/Bicategories/Modifications/Modification.v000066400000000000000000000205531451125700300246450ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Modifications between pseudo transformations Niccolò Veltri, Niels van der Weide April 2019 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Local Open Scope cat. Definition modification {B B' : bicat} {F G : psfunctor B B'} (σ τ : pstrans F G) : UU := prebicat_cells (psfunctor_bicat B B') σ τ. Definition modification_data {B B' : bicat} {F G : psfunctor B B'} (σ τ : pstrans F G) : UU := ∏ (X : B), σ X ==> τ X. Definition is_modification {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification_data σ τ) : UU := ∏ (X Y : B) (f : X --> Y), psnaturality_of σ f • (m Y ▻ #F f) = #G f ◅ m X • psnaturality_of τ f. Definition modcomponent_of {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) : ∏ (X : B), σ X ==> τ X := pr111 m. Coercion modcomponent_of : modification >-> Funclass. Definition modnaturality_of {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) : is_modification m := pr211 m. Definition mod_inv_naturality_of {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) : ∏ (X Y : B) (f : X --> Y), (m Y ▻ #F f) • (psnaturality_of τ f)^-1 = (psnaturality_of σ f)^-1 • (#G f ◅ m X). Proof. intros X Y f. use vcomp_move_L_pM. { is_iso. } rewrite vassocr. use vcomp_move_R_Mp. { is_iso. } exact (modnaturality_of m X Y f). Qed. Definition make_modification {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification_data σ τ) (Hm : is_modification m) : modification σ τ := (((m ,, Hm) ,, (tt ,, tt ,, tt)),, tt). Definition modification_eq {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} {m m' : modification σ τ} (p : ∏ (X : B), m X = m' X) : m = m'. Proof. use subtypePath. { intro. simpl. exact isapropunit. } use subtypePath. { intro. simpl. repeat (apply isapropdirprod) ; apply isapropunit. } use subtypePath. { intro. simpl. repeat (apply impred ; intro). apply B'. } use funextsec. exact p. Qed. Definition isaset_modification {B B' : bicat} {F G : psfunctor B B'} (σ τ : pstrans F G) : isaset (modification σ τ). Proof. repeat (apply isaset_total2). - apply impred_isaset ; intro. apply B'. - intro. repeat (apply impred_isaset ; intro). apply isasetaprop. apply B'. - intro ; simpl. repeat (apply isaset_dirprod) ; apply isasetunit. - intro ; apply isasetunit. Qed. Definition is_invertible_modification {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) : UU := @is_invertible_2cell (psfunctor_bicat B B') _ _ _ _ m. Definition invertible_modification {B B' : bicat} {F G : psfunctor B B'} (σ τ : pstrans F G) : UU := @invertible_2cell (psfunctor_bicat B B') _ _ σ τ. Definition modcomponent_eq {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} {m m' : modification σ τ} (p : m = m') : ∏ (X : B), m X = m' X. Proof. intro X. induction p. apply idpath. Qed. Definition invertible_modification_data {B B' : bicat} {F G : psfunctor B B'} (σ τ : pstrans F G) : UU := ∏ (X : B), invertible_2cell (σ X) (τ X). Coercion invertible_modification_data_to_modification_data {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : invertible_modification_data σ τ) : modification_data σ τ. Proof. intro X. exact (m X). Defined. Definition is_invertible_modcomponent_of {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) (Hm : is_invertible_modification m) : ∏ (X : B), is_invertible_2cell (m X). Proof. intro X. use make_is_invertible_2cell. - exact ((Hm^-1 : modification _ _) X). - exact (modcomponent_eq (vcomp_rinv Hm) X). - exact (modcomponent_eq (vcomp_linv Hm) X). Defined. Definition make_is_invertible_modification {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : modification σ τ) (Hm : ∏ (X : B), is_invertible_2cell (m X)) : is_invertible_modification m. Proof. use make_is_invertible_2cell. - use make_modification. + exact (λ X, (Hm X)^-1). + intros X Y f. simpl. use vcomp_move_R_Mp. { is_iso. } simpl. rewrite <- vassocr. use vcomp_move_L_pM. { is_iso. } symmetry. simpl. apply (modnaturality_of m). - use modification_eq. intro X. cbn. exact (vcomp_rinv (Hm X)). - use modification_eq. intro X. cbn. exact (vcomp_linv (Hm X)). Defined. Definition invertible_modcomponent_of {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : invertible_modification σ τ) : ∏ (X : B), invertible_2cell (σ X) (τ X). Proof. intro X. use make_invertible_2cell. - exact ((cell_from_invertible_2cell m : modification _ _) X). - apply is_invertible_modcomponent_of. exact (property_from_invertible_2cell m). Defined. Definition make_invertible_modification {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : invertible_modification_data σ τ) (Hm : is_modification m) : invertible_modification σ τ. Proof. use make_invertible_2cell. - use make_modification. + unfold modification_data. apply m. + exact Hm. - apply make_is_invertible_modification. intro. apply m. Defined. (** Only on data *) Definition invertible_modification_data_on_data {B B' : bicat} {F G : psfunctor_data B B'} (σ τ : pstrans_on_data F G) : UU := ∏ (X : B), invertible_2cell (pr11 σ X) (pr11 τ X). Definition invertible_modification_on_data_is_modification {B B' : bicat} {F G : psfunctor_data B B'} {σ τ : pstrans_on_data F G} (m : invertible_modification_data_on_data σ τ) : UU := ∏ (X Y : B) (f : X --> Y), pr21 σ _ _ f • (_ ◃ m Y) = (m X ▹ _) • pr21 τ _ _ f. Definition invertible_modification_on_data {B B' : bicat} {F G : psfunctor_data B B'} (σ τ : pstrans_on_data F G) : UU := ∑ (m : invertible_modification_data_on_data σ τ), invertible_modification_on_data_is_modification m. Definition make_invertible_modification_on_data {B B' : bicat} {F G : psfunctor B B'} {σ τ : pstrans F G} (m : invertible_modification_on_data (pr1 σ) (pr1 τ)) : invertible_modification σ τ. Proof. use make_invertible_modification. - exact (pr1 m). - exact (pr2 m). Defined. UniMath-20231010/UniMath/Bicategories/Monads/000077500000000000000000000000001451125700300204755ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Monads/ConstructionOfAlgebras.v000066400000000000000000000246451451125700300253170ustar00rootroot00000000000000(**************************************************************************************** Construction of algebras In the 'Formal Theory of Monads' by Street, the core definition is when a 2-category has the construction of algebras, which says that the inclusion of that 2-category into the monads has a right adjoint. We take a slightly different approach: instead, we define this notion using limits. More specifically, we look at Eilenberg-Moore objects. In this file, we show that these two notions are indeed equivalent. Contents 1. Definition of having the construction of algebras 2. Having the construction of algebras is equivalent to having Eilenberg-Moore objects ****************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. (** 1. Definition of having the construction of algebras *) Definition has_construction_of_algs (B : bicat) : UU := right_universal_arrow (mnd_incl B). (** 2. Having the construction of algebras is equivalent to having Eilenberg-Moore objects *) Section ConstructionOfAlgsToEM. Context {B : bicat} (HB : has_construction_of_algs B). Definition has_construction_of_algs_cone (m : mnd B) : em_cone m := pr1 HB m ,, pr12 HB m. Definition has_construction_of_algs_to_em_mnd_cell_data {x : B} {m : mnd B} (f : x --> pr1 HB m) : mnd_cell_data (# (mnd_incl B) f · (pr12 HB) m) (em_hom_functor m (has_construction_of_algs_cone m) x f) := id2 _. Definition has_construction_of_algs_to_em_is_mnd_cell {x : B} {m : mnd B} (f : x --> pr1 HB m) : is_mnd_cell (has_construction_of_algs_to_em_mnd_cell_data f). Proof. unfold is_mnd_cell ; cbn. unfold has_construction_of_algs_to_em_mnd_cell_data. rewrite id2_rwhisker, lwhisker_id2. rewrite id2_left, id2_right. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite runitor_rwhisker. rewrite !vassocl. rewrite linvunitor_assoc. apply idpath. Qed. Definition has_construction_of_algs_to_em_mnd_cell {x : B} {m : mnd B} (f : x --> pr1 HB m) : # (mnd_incl B) f · pr12 HB m ==> em_hom_functor m (has_construction_of_algs_cone m) x f. Proof. use make_mnd_cell. - exact (has_construction_of_algs_to_em_mnd_cell_data f). - exact (has_construction_of_algs_to_em_is_mnd_cell f). Defined. Definition has_construction_of_algs_to_em_is_nat_trans (x : B) (m : mnd B) : is_nat_trans (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB)) (em_hom_functor m (pr1 HB m,, (pr12 HB) m) x) has_construction_of_algs_to_em_mnd_cell. Proof. intros f₁ f₂ α. use eq_mnd_cell ; cbn. exact (id2_right _ @ !(id2_left _)). Qed. Definition has_construction_of_algs_to_em_nat_trans (x : B) (m : mnd B) : right_universal_arrow_functor (mnd_incl B) x m (pr12 HB) ⟹ em_hom_functor m (pr1 HB m,, (pr12 HB) m) x. Proof. use make_nat_trans. - exact has_construction_of_algs_to_em_mnd_cell. - exact (has_construction_of_algs_to_em_is_nat_trans x m). Defined. Definition has_construction_of_algs_to_em : bicat_has_em B. Proof. intro m. simple refine (_ ,, _). - exact (has_construction_of_algs_cone m). - apply is_universal_has_em_ump. intros x. use (nat_iso_adj_equivalence_of_cats _ _ (pr22 HB x m)). + exact (has_construction_of_algs_to_em_nat_trans x m). + intro f. use is_inv2cell_to_is_z_iso. use is_invertible_mnd_2cell. cbn ; unfold has_construction_of_algs_to_em_mnd_cell_data. is_iso. Defined. End ConstructionOfAlgsToEM. Section EMToConstructionOfAlgs. Context {B : bicat} (HB : bicat_has_em B). Definition em_to_has_construction_of_algs_nat_mnd_cell_data {m : mnd B} {x : B} (f : x --> pr1 (HB m)) : mnd_cell_data (em_hom_functor m (pr1 (HB m)) x f) (right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)) f) := id2 _. Definition em_to_has_construction_of_algs_nat_is_mnd_cell {m : mnd B} {x : B} (f : x --> pr1 (HB m)) : is_mnd_cell (em_to_has_construction_of_algs_nat_mnd_cell_data f). Proof. unfold is_mnd_cell. unfold em_to_has_construction_of_algs_nat_mnd_cell_data. etrans. { apply maponpaths. apply lwhisker_id2. } refine (id2_right _ @ _). refine (!_). etrans. { apply maponpaths_2. apply id2_rwhisker. } refine (id2_left _ @ _). refine (!_). do 2 refine (vassocl _ _ _ @ _). cbn. do 3 refine (_ @ vassocr _ _ _). do 2 apply maponpaths. refine (!_). refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply rwhisker_vcomp. } refine (vassocr _ _ _ @ _). apply maponpaths_2. apply runitor_rwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). apply linvunitor_assoc. Qed. Definition em_to_has_construction_of_algs_nat_mnd_cell {m : mnd B} {x : B} (f : x --> pr1 (HB m)) : em_hom_functor m (pr1 (HB m)) x f ==> right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)) f. Proof. use make_mnd_cell. - exact (em_to_has_construction_of_algs_nat_mnd_cell_data f). - exact (em_to_has_construction_of_algs_nat_is_mnd_cell f). Defined. Definition em_to_has_construction_of_algs_is_nat_trans (m : mnd B) (x : B) : is_nat_trans (em_hom_functor m (pr1 (HB m)) x) (right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0))) em_to_has_construction_of_algs_nat_mnd_cell. Proof. intros f₁ f₂ α. use eq_mnd_cell. exact (id2_right _ @ !(id2_left _)). Qed. Definition em_to_has_construction_of_algs_nat_trans (m : mnd B) (x : B) : em_hom_functor m (pr1 (HB m)) x ⟹ right_universal_arrow_functor (mnd_incl B) x m (λ m0 : mnd B, pr21 (HB m0)). Proof. use make_nat_trans. - exact em_to_has_construction_of_algs_nat_mnd_cell. - exact (em_to_has_construction_of_algs_is_nat_trans m x). Defined. Definition em_to_has_construction_of_algs : has_construction_of_algs B. Proof. simple refine (_ ,, _ ,, _). - exact (λ m, pr1 (HB m)). - exact (λ m, pr21 (HB m)). - intros x m. use (nat_iso_adj_equivalence_of_cats _ _ (has_em_ump_is_universal m (pr2 (HB m)) x)). + exact (em_to_has_construction_of_algs_nat_trans m x). + intro f. use is_inv2cell_to_is_z_iso. use is_invertible_mnd_2cell. cbn ; unfold em_to_has_construction_of_algs_nat_mnd_cell_data. is_iso. Defined. End EMToConstructionOfAlgs. Definition has_construction_of_algs_weq_has_em_inv₁ {B : bicat} (HB₁ : is_univalent_2_1 B) (HB₂ : has_construction_of_algs B) : em_to_has_construction_of_algs (has_construction_of_algs_to_em HB₂) = HB₂. Proof. refine (maponpaths (λ z, _ ,, _ ,, z) _). use funextsec ; intro x. use funextsec ; intro m. enough (isaprop (adj_equivalence_of_cats (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB₂)))) as X. { apply X. } use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB₁ x (pr1 HB₂ m)) (univ_hom (is_univalent_2_1_mnd _ HB₁) (mnd_incl B x) m) (right_universal_arrow_functor (mnd_incl B) x m (pr12 HB₂))). - exact (@adj_equiv_is_equiv_cat (univ_hom _ _ _) _ _). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. Definition has_construction_of_algs_weq_has_em_inv₂ {B : bicat} (HB₁ : is_univalent_2_1 B) (HB₂ : bicat_has_em B) : has_construction_of_algs_to_em (em_to_has_construction_of_algs HB₂) = HB₂. Proof. use funextsec ; intro m. refine (maponpaths (λ z, _ ,, z) _). apply isaprop_has_em_ump. exact HB₁. Qed. Definition has_construction_of_algs_weq_has_em (B : bicat) (HB : is_univalent_2_1 B) : has_construction_of_algs B ≃ bicat_has_em B. Proof. use make_weq. - exact has_construction_of_algs_to_em. - use isweq_iso. + exact em_to_has_construction_of_algs. + apply has_construction_of_algs_weq_has_em_inv₁. exact HB. + apply has_construction_of_algs_weq_has_em_inv₂. exact HB. Defined. UniMath-20231010/UniMath/Bicategories/Monads/DistributiveLaws.v000066400000000000000000000175541451125700300242040ustar00rootroot00000000000000(****************************************************************************** Distributive law In this file, we define distributive laws in bicategories. We give two definitions: one that makes use of monad functors and the other makes use of monad opfunctors. We also show that the two definitions are equivalen.t Contents 1. First definition 2. Second definition 3. The equivalence ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat. Local Open Scope cat. Section DistributiveLaw. Context {B : bicat} {x : B} {dm₁ dm₂ : disp_mnd B x}. Let m₁ : mnd B := x ,, dm₁. Let m₂ : mnd B := x ,, dm₂. Let f : x --> x := endo_of_mnd m₁. Let g : x --> x := endo_of_mnd m₂. Let η₁ : id₁ _ ==> f := unit_of_mnd m₁. Let η₂ : id₁ _ ==> g := unit_of_mnd m₂. Let μ₁ : f · f ==> f := mult_of_mnd m₁. Let μ₂ : g · g ==> g := mult_of_mnd m₂. (** 1. First definition *) Section Laws. Context (α : g · f ==> f · g). Definition distr_law_unit_law_1 : UU := linvunitor g • (η₁ ▹ g) = (rinvunitor g • (g ◃ η₁)) • α. Definition distr_law_mu_law_1 : UU := lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (f ◃ α) • lassociator _ _ _ • (μ₁ ▹ g) = (g ◃ μ₁) • α. Definition distr_law_unit_law_2 : UU := lunitor _ • rinvunitor _ • (f ◃ η₂) = (η₂ ▹ f) • α. Definition distr_law_mu_law_2 : UU := rassociator _ _ _ • (g ◃ α) • lassociator _ _ _ • (α ▹ g) • rassociator _ _ _ • (f ◃ μ₂) = (μ₂ ▹ f) • α. End Laws. Definition is_distr_law (α : g · f ==> f · g) : UU := distr_law_unit_law_1 α × distr_law_mu_law_1 α × distr_law_unit_law_2 α × distr_law_mu_law_2 α. Definition isaprop_is_distr_law (α : g · f ==> f · g) : isaprop (is_distr_law α). Proof. repeat (use isapropdirprod) ; apply cellset_property. Qed. Definition distr_law : UU := ∑ (α : g · f ==> f · g), is_distr_law α. Coercion cell_from_distr_law (α : distr_law) : g · f ==> f · g := pr1 α. Section Projections. Context (α : distr_law). Definition unit_law_1_from_distr_law : linvunitor g • (η₁ ▹ g) = (rinvunitor g • (g ◃ η₁)) • α := pr12 α. Definition mu_law_1_from_distr_law : lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (f ◃ α) • lassociator _ _ _ • (μ₁ ▹ g) = (g ◃ μ₁) • α := pr122 α. Definition unit_law_2_from_distr_law : lunitor _ • rinvunitor _ • (f ◃ η₂) = (η₂ ▹ f) • α := pr1 (pr222 α). Definition mu_law_2_from_distr_law : rassociator _ _ _ • (g ◃ α) • lassociator _ _ _ • (α ▹ g) • rassociator _ _ _ • (f ◃ μ₂) = (μ₂ ▹ f) • α := pr2 (pr222 α). Definition mnd_mor_from_distr_law : m₁ --> m₁. Proof. use make_mnd_mor. - use make_mnd_mor_data. + exact g. + exact (pr1 α). - split. + exact unit_law_1_from_distr_law. + exact mu_law_1_from_distr_law. Defined. Definition mnd_unit_cell_from_distr_law : id₁ _ ==> mnd_mor_from_distr_law. Proof. use make_mnd_cell. - exact η₂. - exact unit_law_2_from_distr_law. Defined. Definition mnd_mu_cell_from_distr_law : mnd_mor_from_distr_law · mnd_mor_from_distr_law ==> mnd_mor_from_distr_law. Proof. use make_mnd_cell. - exact μ₂. - exact mu_law_2_from_distr_law. Defined. End Projections. (** 2. Second definition *) Definition is_distr_law_op (α : g · f ==> f · g) : UU := (rinvunitor f • (f ◃ unit_of_mnd m₂) = linvunitor f • (unit_of_mnd m₂ ▹ f) • α) × (rassociator _ _ _ • (_ ◃ α) • lassociator _ _ _ • (α ▹ _) • rassociator _ _ _ • (f ◃ μ₂) = (μ₂ ▹ f) • α) × (runitor g • linvunitor g • (η₁ ▹ endo_of_mnd m₂) = (g ◃ η₁) • α) × (lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (f ◃ α) • lassociator _ _ _ • (μ₁ ▹ g) = (g ◃ μ₁) • α). Definition isaprop_is_distr_law_op (α : g · f ==> f · g) : isaprop (is_distr_law_op α). Proof. repeat (use isapropdirprod) ; apply cellset_property. Qed. Section FunctorsFromDistrLawOp. Context (α : g · f ==> f · g) (Hα : is_distr_law_op α). Definition mnd_opfunctor_from_distr_law_op : mnd_opmor m₂ m₂. Proof. use make_mnd_opmor. - use make_mnd_opmor_data. + exact f. + exact α. - split. + apply Hα. + apply Hα. Defined. Definition mnd_unit_cell_from_distr_law_op : mnd_opcell (mnd_id_opmor _) mnd_opfunctor_from_distr_law_op. Proof. use make_mnd_opcell. - exact η₁. - apply Hα. Defined. Definition mnd_mu_cell_from_distr_law_op : mnd_opcell (mnd_opmor_comp mnd_opfunctor_from_distr_law_op mnd_opfunctor_from_distr_law_op) mnd_opfunctor_from_distr_law_op. Proof. use make_mnd_opcell. - exact μ₁. - apply Hα. Defined. End FunctorsFromDistrLawOp. (** 3. The equivalence *) Definition is_distr_law_to_is_distr_law_op (α : g · f ==> f · g) (Hα : is_distr_law α) : is_distr_law_op α. Proof. repeat split. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (pr122 Hα). - exact (pr222 Hα). - rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (pr1 Hα). - exact (pr12 Hα). Qed. Definition is_distr_law_op_to_is_distr_law (α : g · f ==> f · g) (Hα : is_distr_law_op α) : is_distr_law α. Proof. repeat split ; red. - rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (pr122 Hα). - exact (pr222 Hα). - rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (pr1 Hα). - exact (pr12 Hα). Qed. Definition is_distr_law_weq_is_distr_law_op (α : g · f ==> f · g) : is_distr_law α ≃ is_distr_law_op α. Proof. use weqimplimpl. - exact (is_distr_law_to_is_distr_law_op α). - exact (is_distr_law_op_to_is_distr_law α). - apply isaprop_is_distr_law. - apply isaprop_is_distr_law_op. Defined. End DistributiveLaw. Arguments distr_law {_ _} _ _. UniMath-20231010/UniMath/Bicategories/Monads/Examples/000077500000000000000000000000001451125700300222535ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Monads/Examples/AdjunctionToMonad.v000066400000000000000000000210611451125700300260220ustar00rootroot00000000000000(************************************************************************* Every adjunction gives rise to a monad In arbitrary bicategories, every adjunction gives rise to a monad *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. Section MonadFromAdjunction. Context {B : bicat} {x y : B} (l : adjunction x y). Let r : y --> x := left_adjoint_right_adjoint l. Let η : id₁ _ ==> l · r := left_adjoint_unit l. Let ε : r · l ==> id₁ _ := left_adjoint_counit l. Let f : x --> x := l · r. Let monad_η : id₁ _ ==> f := η. Let monad_μ : f · f ==> f := rassociator _ _ _ • (_ ◃ lassociator _ _ _) • (_ ◃ (ε ▹ _)) • (_ ◃ lunitor _). Local Lemma mnd_from_adjunction_η_left : (linvunitor f • (monad_η ▹ f)) • monad_μ = id₂ _. Proof. pose (p₁ := internal_triangle1 l). unfold monad_η, monad_μ, f. cbn -[η ε] ; cbn -[η ε] in p₁. rewrite !vassocl. rewrite !vassocl in p₁. refine (_ @ id2_rwhisker _ _). rewrite <- p₁. rewrite <- !rwhisker_vcomp. rewrite linvunitor_assoc. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lunitor_lwhisker. apply idpath. Qed. Local Lemma mnd_from_adjunction_η_right : (rinvunitor f • (f ◃ monad_η)) • monad_μ = id₂ _. Proof. pose (p₁ := internal_triangle1 l). pose (p₂ := internal_triangle2 l). unfold monad_η, monad_μ, f. cbn -[η ε] ; cbn -[η ε] in p₁, p₂. rewrite !vassocl. rewrite !vassocl in p₂. refine (_ @ lwhisker_id2 _ _). refine (!_). etrans. { apply maponpaths. exact (!p₂). } rewrite <- !lwhisker_vcomp. rewrite <- rinvunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Local Lemma mnd_from_adjunction_assoc : (rassociator f f f • (f ◃ monad_μ)) • monad_μ = (monad_μ ▹ f) • monad_μ. Proof. unfold monad_μ. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. rewrite !vassocl. etrans. { do 5 apply maponpaths. etrans. { rewrite !vassocr. do 2 apply maponpaths_2. rewrite lwhisker_hcomp. etrans. { apply inverse_pentagon_4. } rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } etrans. { do 3 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. do 4 apply maponpaths_2. apply lwhisker_lwhisker. } rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } etrans. { do 5 apply maponpaths. rewrite !vassocl. do 2 apply maponpaths. etrans. { apply maponpaths. apply lwhisker_vcomp. } rewrite vcomp_lunitor. refine (lwhisker_vcomp _ _ _ @ _). apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. refine (!_). apply rwhisker_lwhisker_rassociator. } rewrite !vassocr. do 2 apply maponpaths_2. refine (!_). apply rwhisker_lwhisker_rassociator. } rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite <- rwhisker_rwhisker. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !lunitor_assoc. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp, <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. refine (!_). rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite <- rwhisker_rwhisker. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite pentagon_6. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. etrans. { do 3 apply maponpaths_2. apply inverse_pentagon_7. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite <- rwhisker_lwhisker_rassociator. etrans. { do 4 apply maponpaths. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. rewrite <- lassociator_lassociator. rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. refine (_ @ !(rassociator_rassociator _ _ _ _)). rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } rewrite !vassocl. apply maponpaths. apply lwhisker_lwhisker_rassociator. } rewrite !vassocr. refine (_ @ id2_left _). apply maponpaths_2. rewrite !lwhisker_vcomp. rewrite <- lwhisker_id2. apply maponpaths. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite lassociator_rassociator. rewrite lwhisker_id2. apply id2_left. } apply rassociator_lassociator. Qed. Definition mnd_from_adjunction : mnd B. Proof. use make_mnd. - use make_mnd_data. + exact x. + exact f. + exact monad_η. + exact monad_μ. - refine (_ ,, _ ,, _). + exact mnd_from_adjunction_η_left. + exact mnd_from_adjunction_η_right. + exact mnd_from_adjunction_assoc. Defined. End MonadFromAdjunction. UniMath-20231010/UniMath/Bicategories/Monads/Examples/Composition.v000066400000000000000000000561501451125700300247540ustar00rootroot00000000000000(*********************************************************************************** Monads can be composed if we have a distributive law between them This results holds for monads in arbitrary bicategories. For monads of categories, this was already proved in Monads.Derivative.v (`monad_comp`) ***********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.DistributiveLaws. Local Open Scope cat. Section ComposeMonad. Context {B : bicat} {x : B} (dm₁ dm₂ : disp_mnd B x) (α : distr_law dm₁ dm₂). Let m₁ : mnd B := x ,, dm₁. Let m₂ : mnd B := x ,, dm₂. Let f : x --> x := endo_of_mnd m₁. Let g : x --> x := endo_of_mnd m₂. Let η₁ : id₁ _ ==> f := unit_of_mnd m₁. Let η₂ : id₁ _ ==> g := unit_of_mnd m₂. Let μ₁ : f · f ==> f := mult_of_mnd m₁. Let μ₂ : g · g ==> g := mult_of_mnd m₂. Let ηc : id₁ x ==> f · g := linvunitor _ • (η₁ ▹ _) • (_ ◃ η₂). Let μc : f · g · (f · g) ==> f · g := rassociator _ _ _ • (f ◃ lassociator _ _ _) • (f ◃ (α ▹ g)) • (f ◃ rassociator _ _ _) • lassociator _ _ _ • (μ₁ ▹ _) • (_ ◃ μ₂). Definition compose_mnd_unit_left : (linvunitor (f · g) • (ηc ▹ f · g)) • μc = id₂ (f · g). Proof. unfold ηc, μc. clear ηc μc. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. rewrite !vassocr. apply maponpaths. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite lunitor_V_id_is_left_unit_V_id. rewrite <- rinvunitor_natural. apply idpath. } rewrite linvunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite !rwhisker_vcomp. do 5 apply maponpaths_2. apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- inverse_pentagon_2. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. do 2 apply maponpaths_2. apply maponpaths. exact (!(unit_law_2_from_distr_law α)). } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. do 2 apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. apply idpath. } etrans. { apply maponpaths_2. apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. exact (pr12 dm₁). } rewrite id2_left. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite vassocr. rewrite rwhisker_hcomp. rewrite !vassocr. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite !lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. exact (pr12 dm₂). Qed. Definition compose_mnd_unit_right : (rinvunitor (f · g) • (f · g ◃ ηc)) • μc = id₂ (f · g). Proof. unfold ηc, μc. clear ηc μc. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. rewrite !vassocr. apply maponpaths. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite lunitor_V_id_is_left_unit_V_id. rewrite <- rinvunitor_natural. apply idpath. } rewrite <- rinvunitor_triangle. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_whisker. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths_2. do 4 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. apply idpath. } etrans. { apply maponpaths_2. do 3 apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- left_unit_inv_assoc. rewrite lwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocr. apply (pr122 dm₂). } apply lwhisker_id2. } rewrite id2_right. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. apply maponpaths. exact (!(unit_law_1_from_distr_law α)). } rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite rwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite vassocr. apply (pr122 dm₁). Qed. Definition compose_mnd_assoc : (rassociator (f · g) (f · g) (f · g) • (f · g ◃ μc)) • μc = (μc ▹ f · g) • μc. Proof. unfold μc. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. clear ηc μc. rewrite !vassocl. etrans. { do 7 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite lwhisker_lwhisker. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- vcomp_whisker. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- lwhisker_lwhisker_rassociator. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite lwhisker_vcomp. do 2 apply maponpaths. pose (maponpaths (λ z, lassociator _ _ _ • z) (pr222 dm₂) : lassociator _ _ _ • (rassociator _ _ _ • (g ◃ μ₂) • μ₂) = lassociator _ _ _ • ((μ₂ ▹ g) • μ₂)) as p. cbn in p. rewrite !vassocr in p. rewrite lassociator_rassociator, id2_left in p. exact p. } etrans. { do 12 apply maponpaths. rewrite vcomp_whisker. apply idpath. } refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_whisker. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. pose (pr222 dm₁ : rassociator _ _ _ • (f ◃ μ₁) • μ₁ = (μ₁ ▹ f) • μ₁) as p. cbn in p. etrans. { apply maponpaths_2. apply maponpaths. exact (!p). } clear p. rewrite vcomp_whisker. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 11 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. do 4 apply maponpaths_2. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. rewrite rwhisker_vcomp. etrans. { do 3 apply maponpaths. exact (!(mu_law_2_from_distr_law α)). } rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocl. etrans. { do 12 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- rwhisker_lwhisker_rassociator. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_lwhisker. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. etrans. { do 3 apply maponpaths_2. do 2 apply maponpaths. exact (!(mu_law_1_from_distr_law α)). } rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_rwhisker_alt. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. do 4 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn. rewrite !vassocl. refine (!_). etrans. { do 11 apply maponpaths. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. rewrite rwhisker_lwhisker_rassociator. apply maponpaths. rewrite !vassocr. rewrite !rwhisker_vcomp. rewrite rassociator_rassociator. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite rassociator_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. apply idpath. } etrans. { do 10 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_rwhisker_alt. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- lwhisker_lwhisker_rassociator. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite <- lwhisker_lwhisker_rassociator. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite lassociator_lassociator. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_rwhisker. apply idpath. } etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite lwhisker_lwhisker. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite lwhisker_lwhisker. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- vcomp_whisker. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. apply idpath. } do 2 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn. etrans. { rewrite !vassocr. do 5 apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite rassociator_rassociator. rewrite !vassocl. rewrite lwhisker_lwhisker. do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. do 5 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn. etrans. { rewrite !vassocr. do 4 apply maponpaths_2. rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite inverse_pentagon_6. rewrite <- lwhisker_hcomp. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !lwhisker_vcomp. do 2 apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite pentagon_6. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. rewrite <- !lwhisker_vcomp. rewrite <- lwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !lwhisker_vcomp. rewrite rassociator_lassociator. rewrite !lwhisker_id2. apply idpath. } apply id2_right. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite <- lwhisker_lwhisker. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite rwhisker_lwhisker_rassociator. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. refine (!_). rewrite rwhisker_hcomp. rewrite inverse_pentagon_2. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. apply id2_left. } rewrite lassociator_rassociator. rewrite id2_right. rewrite !lwhisker_vcomp. apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_lwhisker. apply idpath. Qed. Definition compose_mnd : mnd B. Proof. use make_mnd. - use make_mnd_data. + exact x. + exact (f · g). + exact ηc. + exact μc. - repeat split. + exact compose_mnd_unit_left. + exact compose_mnd_unit_right. + exact compose_mnd_assoc. Defined. End ComposeMonad. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInBicatOfCats.v000066400000000000000000000076641451125700300262320ustar00rootroot00000000000000(*********************************************************************** Monads in the bicategory of categories In this file, we relate the concept of monad internal to a bicategory to the concept of monad given in category theory Contents 1. Monads internal to `bicat_of_cats` to monads 2. The inverse 3. The equivalence this is a copy from the respective code for the bicategory of univalent categories ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. (** 1. Monads internal to `bicat_of_cats` to monads *) Definition mnd_bicat_of_cats_to_Monad (m : mnd bicat_of_cats) : Monad (ob_of_mnd m). Proof. simple refine (_,,((_ ,, _) ,, _)). - exact (endo_of_mnd m). - exact (mult_of_mnd m). - exact (unit_of_mnd m). - repeat split. + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_unit_right m) x) as p ; cbn in p ; rewrite id_left in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_unit_left m) x) as p ; cbn in p ; rewrite id_left in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_mult_assoc m) x) as p ; cbn in p ; rewrite id_left in p ; exact (!p)). Defined. (** 2. The inverse *) Definition Monad_to_mnd_bicat_of_cats {C : category} (m : Monad C) : mnd bicat_of_cats. Proof. use make_mnd. - use make_mnd_data. + exact C. + cbn. exact m. + exact (η m). + exact (μ m). - repeat split. + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; apply (Monad_law2(T:=m) x)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; apply (Monad_law1(T:=m) x)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; refine (!_) ; apply (Monad_law3(T:=m) x)). Defined. (** 3. The equivalence *) Definition mnd_bicat_of_cats_weq_Monad_inv₁ (m : mnd bicat_of_cats) : Monad_to_mnd_bicat_of_cats (mnd_bicat_of_cats_to_Monad m) = m. Proof. use total2_paths_f. - apply idpath. - cbn. use subtypePath. { intro. apply isaprop_is_mnd. } apply idpath. Qed. Definition mnd_bicat_of_cats_weq_Monad_inv₂ {C : category} (m : Monad C) : mnd_bicat_of_cats_to_Monad (Monad_to_mnd_bicat_of_cats m) = m. Proof. use total2_paths_f. { apply idpath. } apply monads_category_disp_eq. apply idpath. Qed. Definition mnd_bicat_of_cats_weq_Monad : mnd bicat_of_cats ≃ ∑ (C : category), Monad C. Proof. use make_weq. - exact (λ m, ob_of_mnd m ,, mnd_bicat_of_cats_to_Monad m). - use isweq_iso. + exact (λ m, Monad_to_mnd_bicat_of_cats (pr2 m)). + exact mnd_bicat_of_cats_weq_Monad_inv₁. + abstract (intro m ; refine (maponpaths (λ z, pr1 m ,, z) _) ; exact (mnd_bicat_of_cats_weq_Monad_inv₂ (pr2 m))). Defined. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInBicatOfEnrichedCats.v000066400000000000000000000124501451125700300276610ustar00rootroot00000000000000(********************************************************************** Monads in the bicategory of enriched categories We give some useful statements when using monads internal to the bicategory of enriched categories. **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Local Open Scope cat. Section EnrichmentMonads. Context (V : monoidal_cat). Definition make_mnd_enriched_cats {C : univalent_category} (E : enrichment C V) (M : Monad C) (EM : monad_enrichment E M) : mnd (bicat_of_enriched_cats V). Proof. use make_mnd_total_bicat. - apply disp_2cell_isapprop_enriched_cats. - exact (Monad_to_mnd_bicat_of_univ_cats M). - use make_disp_mnd ; cbn. + exact E. + exact EM. + exact (unit_of_monad_enrichment EM). + exact (mu_of_monad_enrichment EM). Defined. Definition Monad_from_mnd_enriched_cats (M : mnd (bicat_of_enriched_cats V)) : Monad (pr11 (ob_of_mnd M)) := mnd_bicat_of_univ_cats_to_Monad (pr1_of_mnd_total_bicat M). Definition Monad_enrichment_from_mnd_enriched_cats (M : mnd (bicat_of_enriched_cats V)) : monad_enrichment (pr2 (ob_of_mnd M)) (Monad_from_mnd_enriched_cats M). Proof. simple refine (_ ,, _ ,, _). - exact (pr2 (endo_of_mnd M)). - exact (pr2 (unit_of_mnd M)). - exact (pr2 (mult_of_mnd M)). Defined. Section MonadMorProjections. Context {m₁ m₂ : mnd (bicat_of_enriched_cats V)} (f : m₁ --> m₂). Let C₁ : univalent_category := pr1 (ob_of_mnd m₁). Let C₂ : univalent_category := pr1 (ob_of_mnd m₂). Let M₁ : Monad C₁ := Monad_from_mnd_enriched_cats m₁. Let M₂ : Monad C₂ := Monad_from_mnd_enriched_cats m₂. Let η₁ : functor_identity _ ⟹ M₁ := pr1 (unit_of_mnd m₁). Let η₂ : functor_identity _ ⟹ M₂ := pr1 (unit_of_mnd m₂). Let μ₁ : M₁ ∙ M₁ ⟹ M₁ := pr1 (mult_of_mnd m₁). Let μ₂ : M₂ ∙ M₂ ⟹ M₂ := pr1 (mult_of_mnd m₂). Let F : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f). Let Fm : F ∙ M₂ ⟹ M₁ ∙ F := pr1 (mnd_mor_endo f). Definition mnd_mor_unit_enriched (x : C₁) : #F (η₁ x) = η₂ (F x) · Fm x. Proof. pose (maponpaths (λ z, pr11 z x) (mnd_mor_unit f)) as p. cbn in p. rewrite !id_left in p. exact p. Qed. Definition mnd_mor_mu_enriched (x : C₁) : #M₂ (Fm x) · Fm (M₁ x) · #F (μ₁ x) = μ₂ (F x) · Fm x. Proof. pose (maponpaths (λ z, pr11 z x) (mnd_mor_mu f)) as p. cbn in p. rewrite !id_left in p. rewrite !id_right in p. exact p. Qed. End MonadMorProjections. Section MonadCellProjections. Context {m₁ m₂ : mnd (bicat_of_enriched_cats V)} {f₁ f₂ : m₁ --> m₂} (τ : f₁ ==> f₂). Let C₁ : univalent_category := pr1 (ob_of_mnd m₁). Let C₂ : univalent_category := pr1 (ob_of_mnd m₂). Let M₁ : Monad C₁ := Monad_from_mnd_enriched_cats m₁. Let M₂ : Monad C₂ := Monad_from_mnd_enriched_cats m₂. Let η₁ : functor_identity _ ⟹ M₁ := pr1 (unit_of_mnd m₁). Let η₂ : functor_identity _ ⟹ M₂ := pr1 (unit_of_mnd m₂). Let μ₁ : M₁ ∙ M₁ ⟹ M₁ := pr1 (mult_of_mnd m₁). Let μ₂ : M₂ ∙ M₂ ⟹ M₂ := pr1 (mult_of_mnd m₂). Let F₁ : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f₁). Let Fm₁ : F₁ ∙ M₂ ⟹ M₁ ∙ F₁ := pr1 (mnd_mor_endo f₁). Let F₂ : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f₂). Let Fm₂ : F₂ ∙ M₂ ⟹ M₁ ∙ F₂ := pr1 (mnd_mor_endo f₂). Let τc : F₁ ⟹ F₂ := pr1 (cell_of_mnd_cell τ). Definition mnd_cell_endo_enriched (x : C₁) : Fm₁ x · τc (M₁ x) = #M₂ (τc x) · Fm₂ x. Proof. pose (maponpaths (λ z, pr11 z x) (mnd_cell_endo τ)) as p. exact p. Qed. End MonadCellProjections. End EnrichmentMonads. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInBicatOfUnivCats.v000066400000000000000000000077601451125700300270710ustar00rootroot00000000000000(*********************************************************************** Monads in the bicategory of univalent categories In this file, we relate the concept of monad internal to a bicategory to the concept of monad given in category theory Contents 1. Monads internal to `bicat_of_univ_cats` to monads 2. The inverse 3. The equivalence ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. (** 1. Monads internal to `bicat_of_univ_cats` to monads *) Definition mnd_bicat_of_univ_cats_to_Monad (m : mnd bicat_of_univ_cats) : Monad (pr1(ob_of_mnd m)). Proof. simple refine (_,,((_ ,, _) ,, _)). - exact (endo_of_mnd m). - exact (mult_of_mnd m). - exact (unit_of_mnd m). - repeat split. + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_unit_right m) x) as p ; cbn in p ; rewrite id_left in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_unit_left m) x) as p ; cbn in p ; rewrite id_left in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (mnd_mult_assoc m) x) as p ; cbn in p ; rewrite id_left in p ; exact (!p)). Defined. (** 2. The inverse *) Definition Monad_to_mnd_bicat_of_univ_cats {C : univalent_category} (m : Monad C) : mnd bicat_of_univ_cats. Proof. use make_mnd. - use make_mnd_data. + exact C. + cbn. exact m. + exact (η m). + exact (μ m). - repeat split. + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; apply (Monad_law2(T:=m) x)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; apply (Monad_law1(T:=m) x)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id_left ; refine (!_) ; apply (Monad_law3(T:=m) x)). Defined. (** 3. The equivalence *) Definition mnd_bicat_of_univ_cats_weq_Monad_inv₁ (m : mnd bicat_of_univ_cats) : Monad_to_mnd_bicat_of_univ_cats (mnd_bicat_of_univ_cats_to_Monad m) = m. Proof. use total2_paths_f. - apply idpath. - cbn. use subtypePath. { intro. apply isaprop_is_mnd. } apply idpath. Qed. Definition mnd_bicat_of_univ_cats_weq_Monad_inv₂ {C : univalent_category} (m : Monad C) : mnd_bicat_of_univ_cats_to_Monad (Monad_to_mnd_bicat_of_univ_cats m) = m. Proof. use total2_paths_f. { apply idpath. } apply monads_category_disp_eq. apply idpath. Qed. Definition mnd_bicat_of_univ_cats_weq_Monad : mnd bicat_of_univ_cats ≃ ∑ (C : univalent_category), Monad C. Proof. use make_weq. - exact (λ m, ob_of_mnd m ,, mnd_bicat_of_univ_cats_to_Monad m). - use isweq_iso. + exact (λ m, Monad_to_mnd_bicat_of_univ_cats (pr2 m)). + exact mnd_bicat_of_univ_cats_weq_Monad_inv₁. + abstract (intro m ; refine (maponpaths (λ z, pr1 m ,, z) _) ; exact (mnd_bicat_of_univ_cats_weq_Monad_inv₂ (pr2 m))). Defined. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInMonads.v000066400000000000000000000110601451125700300253120ustar00rootroot00000000000000(***************************************************************************** Monads in the bicategory of monads Monads in the bicategory of monads in `B` are the same as distributive laws in `B`. Contents 1. From monads to distributive laws 2. From distributive laws to monads *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.DistributiveLaws. Local Open Scope cat. (** 1. From monads to distributive laws *) Section ToMonadsInMonads. Context {B : bicat} (m : mnd (mnd B)). Let m₁ : mnd B := ob_of_mnd m. Let x : B := ob_of_mnd m₁. Let dm₁ : disp_mnd B x := pr2 m₁. Let fm : m₁ --> m₁ := endo_of_mnd m. Let ηm : id₁ _ ==> fm := unit_of_mnd m. Let μm : fm · fm ==> fm := mult_of_mnd m. Definition other_mnd_data : disp_mnd_data B x. Proof. simple refine (_ ,, _ ,, _). - exact (mor_of_mnd_mor fm). - exact (cell_of_mnd_cell ηm). - exact (cell_of_mnd_cell μm). Defined. Definition other_mnd_is_mnd : is_mnd B (x ,, other_mnd_data). Proof. repeat split. - exact (maponpaths pr1 (mnd_unit_left m)). - exact (maponpaths pr1 (mnd_unit_right m)). - exact (maponpaths pr1 (mnd_mult_assoc m)). Qed. Definition other_mnd : disp_mnd B x := other_mnd_data ,, other_mnd_is_mnd. Let dm₂ : disp_mnd B x := other_mnd. Definition mnd_mnd_to_is_distr_law : @is_distr_law _ _ dm₁ dm₂ (mnd_mor_endo fm). Proof. repeat split ; red ; cbn. - exact (mnd_mor_unit fm). - exact (mnd_mor_mu fm). - exact (mnd_cell_endo ηm). - exact (mnd_cell_endo μm). Defined. Definition mnd_mnd_to_distr_law : distr_law dm₁ dm₂ := mnd_mor_endo fm ,, mnd_mnd_to_is_distr_law. End ToMonadsInMonads. (** 2. From distributive laws to monads *) Section FromMonadsInMonads. Context {B : bicat} {x : B} {dm₁ dm₂ : disp_mnd B x} (l : distr_law dm₁ dm₂). Definition distr_law_to_mnd_mnd_ob : mnd B := x ,, dm₁. Definition distr_law_to_mnd_mnd_endo_data : mnd_mor_data distr_law_to_mnd_mnd_ob distr_law_to_mnd_mnd_ob. Proof. use make_mnd_mor_data. - exact (pr11 dm₂). - exact (cell_from_distr_law l). Defined. Definition distr_law_to_mnd_mnd_endo_laws : mnd_mor_laws distr_law_to_mnd_mnd_endo_data. Proof. split. - exact (unit_law_1_from_distr_law l). - exact (mu_law_1_from_distr_law l). Defined. Definition distr_law_to_mnd_mnd_endo : distr_law_to_mnd_mnd_ob --> distr_law_to_mnd_mnd_ob. Proof. use make_mnd_mor. - exact distr_law_to_mnd_mnd_endo_data. - exact distr_law_to_mnd_mnd_endo_laws. Defined. Definition distr_law_to_mnd_mnd_unit : id₁ distr_law_to_mnd_mnd_ob ==> distr_law_to_mnd_mnd_endo. Proof. use make_mnd_cell. - exact (pr121 dm₂). - exact (unit_law_2_from_distr_law l). Defined. Definition distr_law_to_mnd_mnd_mult : distr_law_to_mnd_mnd_endo · distr_law_to_mnd_mnd_endo ==> distr_law_to_mnd_mnd_endo. Proof. use make_mnd_cell. - exact (pr221 dm₂). - exact (mu_law_2_from_distr_law l). Defined. Definition distr_law_to_mnd_mnd_data : mnd_data (mnd B). Proof. use make_mnd_data. - exact distr_law_to_mnd_mnd_ob. - exact distr_law_to_mnd_mnd_endo. - exact distr_law_to_mnd_mnd_unit. - exact distr_law_to_mnd_mnd_mult. Defined. Definition distr_law_to_mnd_mnd_is_mnd : is_mnd (mnd B) distr_law_to_mnd_mnd_data. Proof. refine (_ ,, _ ,, _) ; use eq_mnd_cell ; cbn. - apply dm₂. - apply dm₂. - apply dm₂. Qed. Definition distr_law_to_mnd_mnd : mnd (mnd B). Proof. use make_mnd. - exact distr_law_to_mnd_mnd_data. - exact distr_law_to_mnd_mnd_is_mnd. Defined. End FromMonadsInMonads. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInOp1Bicat.v000066400000000000000000000321741451125700300255040ustar00rootroot00000000000000(************************************************************************* Monads in the opposite bicategory If we look at monads in the opposite bicategory, then the only thing that changes, is the 1-cells and the 2-cells. Instead of being the usual monad functors, the 2-cell goes in the other direction. Contents 1. Monad opfunctor 2. Monad optransformation 3. Monads in the opposite bicat 4. Monad morphisms in the opposite bicat 5. Monad cells in the opposite bicat 6. Constructors for monad opfunctors *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. (** 1. Monad opfunctor *) Section MonadOpMor. Context {B : bicat} {m₁ m₂ : mnd B}. Definition mnd_opmor_data : UU := ∑ (f : ob_of_mnd m₁ --> ob_of_mnd m₂), endo_of_mnd m₁ · f ==> f · endo_of_mnd m₂. Definition make_mnd_opmor_data (f : ob_of_mnd m₁ --> ob_of_mnd m₂) (α : endo_of_mnd m₁ · f ==> f · endo_of_mnd m₂) : mnd_opmor_data := f ,, α. Coercion mor_of_mnd_opmor_data (f : mnd_opmor_data) : ob_of_mnd m₁ --> ob_of_mnd m₂ := pr1 f. Definition mnd_opmor_endo (f : mnd_opmor_data) : endo_of_mnd m₁ · f ==> f · endo_of_mnd m₂ := pr2 f. Section MonadOpmorLaws. Context (f : mnd_opmor_data). Definition mnd_opmor_unit_law : UU := rinvunitor _ • (f ◃ unit_of_mnd m₂) = linvunitor _ • (unit_of_mnd m₁ ▹ _) • mnd_opmor_endo f. Definition mnd_opmor_mu_law : UU := rassociator _ _ _ • (_ ◃ mnd_opmor_endo f) • lassociator _ _ _ • (mnd_opmor_endo f ▹ _) • rassociator _ _ _ • (_ ◃ mult_of_mnd m₂) = (mult_of_mnd m₁ ▹ _) • mnd_opmor_endo f. End MonadOpmorLaws. Definition mnd_opmor_laws (f : mnd_opmor_data) : UU := mnd_opmor_unit_law f × mnd_opmor_mu_law f. Definition mnd_opmor : UU := ∑ (f : mnd_opmor_data), mnd_opmor_laws f. Definition make_mnd_opmor (f : mnd_opmor_data) (Hf : mnd_opmor_laws f) : mnd_opmor := f ,, Hf. Coercion mnd_opmor_to_mnd_opmor_data (f : mnd_opmor) : mnd_opmor_data := pr1 f. Section LawProjections. Context (f : mnd_opmor). Definition mnd_opmor_unit : rinvunitor _ • (f ◃ unit_of_mnd m₂) = linvunitor _ • (unit_of_mnd m₁ ▹ _) • mnd_opmor_endo f := pr12 f. Definition mnd_opmor_mu : rassociator _ _ _ • (_ ◃ mnd_opmor_endo f) • lassociator _ _ _ • (mnd_opmor_endo f ▹ _) • rassociator _ _ _ • (_ ◃ mult_of_mnd m₂) = (mult_of_mnd m₁ ▹ _) • mnd_opmor_endo f := pr22 f. End LawProjections. End MonadOpMor. Arguments mnd_opmor_data {_} _ _. Arguments mnd_opmor {_} _ _. (** 2. Monad optransformation *) Definition is_mnd_opcell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : mnd_opmor m₁ m₂} (α : f₁ ==> f₂) : UU := mnd_opmor_endo f₁ • (α ▹ endo_of_mnd m₂) = (endo_of_mnd m₁ ◃ α) • mnd_opmor_endo f₂. Definition mnd_opcell {B : bicat} {m₁ m₂ : mnd B} (f₁ f₂ : mnd_opmor m₁ m₂) : UU := ∑ (α : f₁ ==> f₂), is_mnd_opcell α. Coercion mnd_opcell_to_cell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : mnd_opmor m₁ m₂} (α : mnd_opcell f₁ f₂) : f₁ ==> f₂ := pr1 α. Definition make_mnd_opcell {B : bicat} {m₁ m₂ : mnd B} {f₁ f₂ : mnd_opmor m₁ m₂} (α : f₁ ==> f₂) (Hα : is_mnd_opcell α) : mnd_opcell f₁ f₂ := α ,, Hα. (** 3. Monads in the opposite bicat *) Section MonadsInOpBicat. Context {B : bicat}. Definition mnd_op1_to_mnd_data (m : mnd (op1_bicat B)) : mnd_data B. Proof. use make_mnd_data. - exact (ob_of_mnd m). - exact (endo_of_mnd m). - exact (unit_of_mnd m). - exact (mult_of_mnd m). Defined. Definition mnd_op1_to_is_mnd (m : mnd (op1_bicat B)) : is_mnd B (mnd_op1_to_mnd_data m). Proof. refine (_ ,, _ ,, _). - exact (mnd_unit_right m). - exact (mnd_unit_left m). - exact (!(mnd_mult_assoc' m)). Qed. Definition mnd_op1_to_mnd (m : mnd (op1_bicat B)) : mnd B. Proof. use make_mnd. - exact (mnd_op1_to_mnd_data m). - exact (mnd_op1_to_is_mnd m). Defined. End MonadsInOpBicat. Section MonadsInOpBicat. Context {B : bicat}. Definition op1_mnd_to_mnd_data (m : op1_bicat (mnd (op1_bicat B))) : mnd_data B. Proof. use make_mnd_data. - exact (ob_of_mnd m). - exact (endo_of_mnd m). - exact (unit_of_mnd m). - exact (mult_of_mnd m). Defined. Definition op1_mnd_to_mnd_is_mnd (m : op1_bicat (mnd (op1_bicat B))) : is_mnd B (op1_mnd_to_mnd_data m). Proof. refine (_ ,, _ ,, _). - exact (mnd_unit_right m). - exact (mnd_unit_left m). - exact (!(mnd_mult_assoc' m)). Qed. Definition op1_mnd_to_mnd (m : op1_bicat (mnd (op1_bicat B))) : mnd B. Proof. use make_mnd. - exact (op1_mnd_to_mnd_data m). - exact (op1_mnd_to_mnd_is_mnd m). Defined. Definition mnd_to_op1_mnd (m : mnd B) : op1_bicat (mnd (op1_bicat B)). Proof. use make_mnd. - use make_mnd_data. + exact (ob_of_mnd m). + exact (endo_of_mnd m). + exact (unit_of_mnd m). + exact (mult_of_mnd m). - refine (_ ,, _ ,, _). + exact (mnd_unit_right m). + exact (mnd_unit_left m). + exact (!(mnd_mult_assoc' m)). Defined. Definition op1_mnd_weq_mnd_inv₁ (m : op1_bicat (mnd (op1_bicat B))) : mnd_to_op1_mnd (op1_mnd_to_mnd m) = m. Proof. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro ; apply isaprop_is_mnd. } apply idpath. Qed. Definition op1_mnd_weq_mnd_inv₂ (m : mnd B) : op1_mnd_to_mnd (mnd_to_op1_mnd m) = m. Proof. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro ; apply isaprop_is_mnd. } apply idpath. Qed. End MonadsInOpBicat. Definition op1_mnd_weq_mnd (B : bicat) : op1_bicat (mnd (op1_bicat B)) ≃ mnd B. Proof. use make_weq. - exact op1_mnd_to_mnd. - use isweq_iso. + exact mnd_to_op1_mnd. + exact op1_mnd_weq_mnd_inv₁. + exact op1_mnd_weq_mnd_inv₂. Defined. (** 4. Monad morphisms in the opposite bicat *) Section MonadMorInOpBicat. Context {B : bicat} {m₁ m₂ : op1_bicat (mnd (op1_bicat B))}. Definition op1_mnd_mor_to_mnd_opmor (f : m₁ --> m₂) : mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂). Proof. use make_mnd_opmor. - use make_mnd_opmor_data. + exact (mor_of_mnd_mor f). + exact (mnd_mor_endo f). - split. + exact (mnd_mor_unit f). + exact (mnd_mor_mu f). Defined. Definition mnd_opmor_to_op1_mnd_mor_data (f : mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂)) : mnd_mor_data m₂ m₁. Proof. use make_mnd_mor_data. - exact f. - exact (mnd_opmor_endo f). Defined. Definition mnd_opmor_to_op1_mnd_mor_is_mnd (f : mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂)) : mnd_mor_laws (mnd_opmor_to_op1_mnd_mor_data f). Proof. use make_mnd_mor_laws. - exact (mnd_opmor_unit f). - exact (mnd_opmor_mu f). Qed. Definition mnd_opmor_to_op1_mnd_mor (f : mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂)) : m₁ --> m₂. Proof. use make_mnd_mor. - exact (mnd_opmor_to_op1_mnd_mor_data f). - exact (mnd_opmor_to_op1_mnd_mor_is_mnd f). Defined. Definition op1_mnd_mor_weq_mnd_opmor_inv₁ (f : m₁ --> m₂) : mnd_opmor_to_op1_mnd_mor (op1_mnd_mor_to_mnd_opmor f) = f. Proof. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro. apply isapropunit. } use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } apply idpath. Qed. Definition op1_mnd_mor_weq_mnd_opmor_inv₂ (f : mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂)) : op1_mnd_mor_to_mnd_opmor (mnd_opmor_to_op1_mnd_mor f) = f. Proof. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } apply idpath. Qed. End MonadMorInOpBicat. Definition op1_mnd_mor_weq_mnd_opmor {B : bicat} (m₁ m₂ : op1_bicat (mnd (op1_bicat B))) : m₁ --> m₂ ≃ mnd_opmor (op1_mnd_to_mnd m₁) (op1_mnd_to_mnd m₂). Proof. use make_weq. - exact op1_mnd_mor_to_mnd_opmor. - use isweq_iso. + exact mnd_opmor_to_op1_mnd_mor. + exact op1_mnd_mor_weq_mnd_opmor_inv₁. + exact op1_mnd_mor_weq_mnd_opmor_inv₂. Defined. (** 5. Monad cells in the opposite bicat *) Section MonadCellInOpBicat. Context {B : bicat} {m₁ m₂ : op1_bicat (mnd (op1_bicat B))} {f₁ f₂ : m₁ --> m₂}. Definition op1_mnd_cell_to_mnd_opcell (α : f₁ ==> f₂) : mnd_opcell (op1_mnd_mor_to_mnd_opmor f₁) (op1_mnd_mor_to_mnd_opmor f₂). Proof. use make_mnd_opcell. - exact (pr1 α). - exact (mnd_cell_endo α). Defined. Definition mnd_opcell_to_op1_mnd_cell (α : mnd_opcell (op1_mnd_mor_to_mnd_opmor f₁) (op1_mnd_mor_to_mnd_opmor f₂)) : f₁ ==> f₂. Proof. use make_mnd_cell. - unfold mnd_cell_data. exact α. - exact (pr2 α). Defined. End MonadCellInOpBicat. Definition op1_mnd_cell_weq_mnd_opcell {B : bicat} {m₁ m₂ : op1_bicat (mnd (op1_bicat B))} (f₁ f₂ : m₁ --> m₂) : f₁ ==> f₂ ≃ mnd_opcell (op1_mnd_mor_to_mnd_opmor f₁) (op1_mnd_mor_to_mnd_opmor f₂). Proof. use make_weq. - exact op1_mnd_cell_to_mnd_opcell. - use isweq_iso. + exact mnd_opcell_to_op1_mnd_cell. + abstract (intro α ; use eq_mnd_cell ; apply idpath). + abstract (intro α ; use subtypePath ; [ intro ; apply cellset_property | ] ; apply idpath). Defined. (** 6. Constructors for monad opfunctors *) Definition mnd_mor_to_mor_opmor_data {B : bicat} {m₁ m₂ : mnd B} (f : mnd_to_op1_mnd m₁ --> mnd_to_op1_mnd m₂) : mnd_opmor_data m₁ m₂. Proof. use make_mnd_opmor_data. - exact (mor_of_mnd_mor f). - exact (mnd_mor_endo f). Defined. Definition mnd_mor_to_mor_opmor_laws {B : bicat} {m₁ m₂ : mnd B} (f : mnd_to_op1_mnd m₁ --> mnd_to_op1_mnd m₂) : mnd_opmor_laws (mnd_mor_to_mor_opmor_data f). Proof. split. - exact (mnd_mor_unit f). - exact (mnd_mor_mu f). Qed. Definition mnd_mor_to_mor_opmor {B : bicat} {m₁ m₂ : mnd B} (f : mnd_to_op1_mnd m₁ --> mnd_to_op1_mnd m₂) : mnd_opmor m₁ m₂. Proof. use make_mnd_opmor. - exact (mnd_mor_to_mor_opmor_data f). - exact (mnd_mor_to_mor_opmor_laws f). Defined. Definition mor_opmor_to_mnd_mor_data {B : bicat} {m₁ m₂ : mnd B} (f : mnd_opmor m₁ m₂) : mnd_mor_data (mnd_to_op1_mnd m₂) (mnd_to_op1_mnd m₁). Proof. use make_mnd_mor_data. - exact f. - exact (mnd_opmor_endo f). Defined. Definition mor_opmor_to_mnd_mor_laws {B : bicat} {m₁ m₂ : mnd B} (f : mnd_opmor m₁ m₂) : mnd_mor_laws (mor_opmor_to_mnd_mor_data f). Proof. use make_mnd_mor_laws. - exact (mnd_opmor_unit f). - exact (mnd_opmor_mu f). Qed. Definition mor_opmor_to_mnd_mor {B : bicat} {m₁ m₂ : mnd B} (f : mnd_opmor m₁ m₂) : mnd_to_op1_mnd m₁ --> mnd_to_op1_mnd m₂. Proof. use make_mnd_mor. - exact (mor_opmor_to_mnd_mor_data f). - exact (mor_opmor_to_mnd_mor_laws f). Defined. Definition mnd_id_opmor {B : bicat} (m : mnd B) : mnd_opmor m m := mnd_mor_to_mor_opmor (id₁ _). Definition mnd_opmor_comp {B : bicat} {m₁ m₂ m₃ : mnd B} (f₁ : mnd_opmor m₁ m₂) (f₂ : mnd_opmor m₂ m₃) : mnd_opmor m₁ m₃ := mnd_mor_to_mor_opmor (mor_opmor_to_mnd_mor f₁ · mor_opmor_to_mnd_mor f₂). UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInOp2Bicat.v000066400000000000000000000310311451125700300254740ustar00rootroot00000000000000(************************************************************************* Monads in `op2 B` Comnads can be defined as monads internal to a bicategory. More specifically, comonads in `B` are the same as moands in `op2 B`. Contents 1. Comonads 2. Comonad morphisms 3. Comonad cells 4. Monads in `op2 B` 5. Monad morphisms in `op2 B` 6. Monad cells in `op2 B` *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. (** 1. Comonads *) Section Comonads. Context {B : bicat}. Definition comnd_data : UU := ∑ (x : B) (f : x --> x), f ==> id₁ _ × f ==> f · f. Definition make_comnd_data (x : B) (f : x --> x) (ex : f ==> id₁ _) (dup : f ==> f · f) : comnd_data := x ,, f ,, ex ,, dup. Section Projections. Context (C : comnd_data). Definition ob_of_comnd : B := pr1 C. Definition endo_of_comnd : ob_of_comnd --> ob_of_comnd := pr12 C. Definition counit_of_comnd : endo_of_comnd ==> id₁ _ := pr122 C. Definition comult_of_comnd : endo_of_comnd ==> endo_of_comnd · endo_of_comnd := pr222 C. End Projections. Section ComonadLaws. Context (C : comnd_data). Definition comnd_counit_left_law : UU := comult_of_comnd C • (counit_of_comnd C ▹ _) • lunitor _ = id₂ _. Definition comnd_counit_right_law : UU := comult_of_comnd C • (_ ◃ counit_of_comnd C) • runitor _ = id₂ _. Definition comnd_comult_assoc_law : UU := comult_of_comnd C • (_ ◃ comult_of_comnd C) • lassociator _ _ _ = comult_of_comnd C • (comult_of_comnd C ▹ _). End ComonadLaws. Definition comnd_laws (C : comnd_data) : UU := comnd_counit_left_law C × comnd_counit_right_law C × comnd_comult_assoc_law C. Definition isaprop_comnd_laws (C : comnd_data) : isaprop (comnd_laws C). Proof. repeat (use isapropdirprod) ; apply cellset_property. Qed. Definition comnd : UU := ∑ (C : comnd_data), comnd_laws C. Coercion comnd_to_comnd_data (C : comnd) : comnd_data := pr1 C. Section LawsProjections. Context (C : comnd). Definition comnd_counit_left : comult_of_comnd C • (counit_of_comnd C ▹ _) • lunitor _ = id₂ _ := pr12 C. Definition comnd_counit_right : comult_of_comnd C • (_ ◃ counit_of_comnd C) • runitor _ = id₂ _ := pr122 C. Definition comnd_comult_assoc : comult_of_comnd C • (_ ◃ comult_of_comnd C) • lassociator _ _ _ = comult_of_comnd C • (comult_of_comnd C ▹ _) := pr222 C. End LawsProjections. Definition make_comnd (C : comnd_data) (HC : comnd_laws C) : comnd := C ,, HC. End Comonads. Arguments comnd_data : clear implicits. Arguments comnd : clear implicits. (** 2. Comonad morphisms *) Section ComonadMorphism. Context {B : bicat} {C₁ C₂ : comnd B}. Definition comnd_mor_data : UU := ∑ (f : ob_of_comnd C₁ --> ob_of_comnd C₂), endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂. Definition make_comnd_mor_data (f : ob_of_comnd C₁ --> ob_of_comnd C₂) (fe : endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂) : comnd_mor_data := f ,, fe. Coercion mor_of_comnd_mor (f : comnd_mor_data) : ob_of_comnd C₁ --> ob_of_comnd C₂ := pr1 f. Definition comnd_mor_endo (f : comnd_mor_data) : endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂ := pr2 f. Section ComonadMorphismLaws. Context (f : comnd_mor_data). Definition comnd_mor_counit_law : UU := (counit_of_comnd C₁ ▹ _) • lunitor _ = comnd_mor_endo f • (_ ◃ counit_of_comnd C₂) • runitor _. Definition comnd_mor_comult_law : UU := (comult_of_comnd C₁ ▹ _) • rassociator _ _ _ • (_ ◃ comnd_mor_endo f) • lassociator _ _ _ • (comnd_mor_endo f ▹ _) • rassociator _ _ _ = comnd_mor_endo f • (_ ◃ comult_of_comnd C₂). End ComonadMorphismLaws. Definition comnd_mor_laws (f : comnd_mor_data) : UU := comnd_mor_counit_law f × comnd_mor_comult_law f. Definition comnd_mor : UU := ∑ (f : comnd_mor_data), comnd_mor_laws f. Coercion comnd_mor_to_comnd_mor_data (f : comnd_mor) : comnd_mor_data := pr1 f. Definition make_comnd_mor (f : comnd_mor_data) (Hf : comnd_mor_laws f) : comnd_mor := f ,, Hf. Section LawProjections. Context (f : comnd_mor). Definition comnd_mor_counit : (counit_of_comnd C₁ ▹ _) • lunitor _ = comnd_mor_endo f • (_ ◃ counit_of_comnd C₂) • runitor _ := pr12 f. Definition comnd_mor_comult : (comult_of_comnd C₁ ▹ _) • rassociator _ _ _ • (_ ◃ comnd_mor_endo f) • lassociator _ _ _ • (comnd_mor_endo f ▹ _) • rassociator _ _ _ = comnd_mor_endo f • (_ ◃ comult_of_comnd C₂) := pr22 f. End LawProjections. End ComonadMorphism. Arguments comnd_mor_data {_} _ _. Arguments comnd_mor {_} _ _. (** 3. Comonad cells *) Definition is_comnd_cell {B : bicat} {C₁ C₂ : comnd B} {f₁ f₂ : comnd_mor C₁ C₂} (α : f₂ ==> f₁) : UU := (_ ◃ α) • comnd_mor_endo f₁ = comnd_mor_endo f₂ • (α ▹ _). Definition comnd_cell {B : bicat} {C₁ C₂ : comnd B} (f₁ f₂ : comnd_mor C₁ C₂) : UU := ∑ (α : f₂ ==> f₁), is_comnd_cell α. Coercion comnd_cell_to_cell {B : bicat} {C₁ C₂ : comnd B} {f₁ f₂ : comnd_mor C₁ C₂} (α : comnd_cell f₁ f₂) : f₂ ==> f₁ := pr1 α. Definition make_comnd_cell {B : bicat} {C₁ C₂ : comnd B} {f₁ f₂ : comnd_mor C₁ C₂} (α : f₂ ==> f₁) (Hα : is_comnd_cell α) : comnd_cell f₁ f₂ := α ,, Hα. (** 4. Monads in `op2 B` *) Section MonadsInOp2Bicat. Context {B : bicat}. Definition op2_mnd_to_comnd (m : mnd (op2_bicat B)) : comnd B. Proof. use make_comnd. - use make_comnd_data. + exact (ob_of_mnd m). + exact (endo_of_mnd m). + exact (unit_of_mnd m). + exact (mult_of_mnd m). - repeat split. + abstract (unfold comnd_counit_left_law ; rewrite !vassocl ; exact (mnd_unit_left m)). + abstract (unfold comnd_counit_right_law ; rewrite !vassocl ; exact (mnd_unit_right m)). + abstract (unfold comnd_comult_assoc_law ; rewrite !vassocl ; exact (mnd_mult_assoc m)). Defined. Definition comnd_to_op2_mnd (C : comnd B) : mnd (op2_bicat B). Proof. use make_mnd. - use make_mnd_data. + exact (ob_of_comnd C). + exact (endo_of_comnd C). + exact (counit_of_comnd C). + exact (comult_of_comnd C). - repeat split. + abstract (cbn ; rewrite !vassocr ; exact (comnd_counit_left C)). + abstract (cbn ; rewrite !vassocr ; exact (comnd_counit_right C)). + abstract (cbn ; rewrite !vassocr ; exact (comnd_comult_assoc C)). Defined. Definition op2_mnd_weq_comnd_inv₁ (m : mnd (op2_bicat B)) : comnd_to_op2_mnd (op2_mnd_to_comnd m) = m. Proof. refine (maponpaths (λ z, ob_of_mnd m ,, z) _). use subtypePath. { intro. apply isaprop_is_mnd. } apply idpath. Qed. Definition op2_mnd_weq_comnd_inv₂ (C : comnd B) : op2_mnd_to_comnd (comnd_to_op2_mnd C) = C. Proof. use subtypePath. { intro. apply isaprop_comnd_laws. } apply idpath. Qed. End MonadsInOp2Bicat. Definition op2_mnd_weq_comnd (B : bicat) : mnd (op2_bicat B) ≃ comnd B. Proof. use make_weq. - exact op2_mnd_to_comnd. - use isweq_iso. + exact comnd_to_op2_mnd. + exact op2_mnd_weq_comnd_inv₁. + exact op2_mnd_weq_comnd_inv₂. Defined. (** 5. Monad morphisms in `op2 B` *) Section MonadMorInOp2Bicat. Context {B : bicat} {m₁ m₂ : mnd (op2_bicat B)}. Definition op2_mnd_mor_to_comnd_mor (f : m₁ --> m₂) : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂). Proof. use make_comnd_mor. - use make_comnd_mor_data. + exact (mor_of_mnd_mor f). + exact (mnd_mor_endo f). - split. + abstract (unfold comnd_mor_counit_law ; cbn ; rewrite !vassocl ; exact (mnd_mor_unit f)). + abstract (unfold comnd_mor_comult_law ; cbn ; rewrite !vassocl ; exact (mnd_mor_mu f)). Defined. Definition comnd_mor_to_op2_mnd_mor (f : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂)) : m₁ --> m₂. Proof. use make_mnd_mor. - use make_mnd_mor_data. + exact f. + exact (comnd_mor_endo f). - split. + abstract (cbn ; rewrite !vassocr ; exact (comnd_mor_counit f)). + abstract (cbn ; rewrite !vassocr ; exact (comnd_mor_comult f)). Defined. Definition op2_mnd_mor_weq_comnd_mor_inv₁ (f : m₁ --> m₂) : comnd_mor_to_op2_mnd_mor (op2_mnd_mor_to_comnd_mor f) = f. Proof. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro ; apply isapropunit. } use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } apply idpath. Qed. Definition op2_mnd_mor_weq_comnd_mor_inv₂ (f : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂)) : op2_mnd_mor_to_comnd_mor (comnd_mor_to_op2_mnd_mor f) = f. Proof. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } apply idpath. Qed. End MonadMorInOp2Bicat. Definition op2_mnd_mor_weq_comnd_mor {B : bicat} (m₁ m₂ : mnd (op2_bicat B)) : m₁ --> m₂ ≃ comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂). Proof. use make_weq. - exact op2_mnd_mor_to_comnd_mor. - use isweq_iso. + exact comnd_mor_to_op2_mnd_mor. + exact op2_mnd_mor_weq_comnd_mor_inv₁. + exact op2_mnd_mor_weq_comnd_mor_inv₂. Defined. (** 6. Monad cells in `op2 B` *) Section MonadMorInOp2Bicat. Context {B : bicat} {m₁ m₂ : mnd (op2_bicat B)} {f₁ f₂ : m₁ --> m₂}. Definition op2_mnd_cell_to_comnd_cell (α : f₁ ==> f₂) : comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂). Proof. use make_comnd_cell. - exact (cell_of_mnd_cell α). - exact (mnd_cell_endo α). Defined. Definition comnd_cell_to_op2_mnd_cell (α : comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂)) : f₁ ==> f₂. Proof. use make_mnd_cell. - exact (pr1 α). - exact (pr2 α). Defined. End MonadMorInOp2Bicat. Definition op2_mnd_cell_weq_comnd_cell {B : bicat} {m₁ m₂ : mnd (op2_bicat B)} (f₁ f₂ : m₁ --> m₂) : f₁ ==> f₂ ≃ comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂). Proof. use make_weq. - exact op2_mnd_cell_to_comnd_cell. - use isweq_iso. + exact comnd_cell_to_op2_mnd_cell. + abstract (intro ; use eq_mnd_cell ; apply idpath). + abstract (intro ; use subtypePath ; [ intro ; apply cellset_property | ] ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInStructuredCategories.v000066400000000000000000000141771451125700300302570ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.StructuredCategories. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfCats. Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories. (** 1. Monads in the bicategory of categories with a terminal object *) Definition make_mnd_univ_cat_with_terminal_obj (C : univalent_category) (M : Monad C) (TC : Terminal C) (MT : preserves_terminal M) : mnd univ_cat_with_terminal_obj. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact (TC ,, tt). + exact (tt ,, MT). + exact (tt ,, tt). + exact (tt ,, tt). Defined. (** 2. Monads in the bicategory of categories with binary products *) Definition make_mnd_univ_cat_with_binprod (C : univalent_category) (M : Monad C) (BC : BinProducts C) (MB : preserves_binproduct M) : mnd univ_cat_with_binprod. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact (BC ,, tt). + exact (tt ,, MB). + exact (tt ,, tt). + exact (tt ,, tt). Defined. (** 3. Monads in the bicategory of categories with pullbacks *) Definition make_mnd_univ_cat_with_pb (C : univalent_category) (M : Monad C) (PC : Pullbacks C) (MP : preserves_pullback M) : mnd univ_cat_with_pb. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact (PC ,, tt). + exact (tt ,, MP). + exact (tt ,, tt). + exact (tt ,, tt). Defined. (** 4. Monads in the bicategory of categories with finite limits *) Definition make_mnd_univ_cat_with_finlim (C : univalent_category) (M : Monad C) (TC : Terminal C) (PC : Pullbacks C) (MT : preserves_terminal M) (MP : preserves_pullback M) : mnd univ_cat_with_finlim. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact ((TC ,, tt) ,, (PC ,, tt)). + exact ((tt ,, MT) ,, (tt ,, MP)). + cbn. exact ((tt ,, tt) ,, (tt ,, tt)). + cbn. exact ((tt ,, tt) ,, (tt ,, tt)). Defined. (** 5. Monads in the bicategory of categories with an initial object *) Definition make_mnd_univ_cat_with_initial (C : univalent_category) (M : Monad C) (IC : Initial C) (MI : preserves_initial M) : mnd univ_cat_with_initial. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact (IC ,, tt). + exact (tt ,, MI). + exact (tt ,, tt). + exact (tt ,, tt). Defined. (** 6. Monads in the bicategory of categories with binary coproducts *) Definition make_mnd_univ_cat_with_bincoprod (C : univalent_category) (M : Monad C) (SC : BinCoproducts C) (MS : preserves_bincoproduct M) : mnd univ_cat_with_bincoprod. Proof. use make_mnd_total_bicat. - apply disp_2cells_isaprop_subbicat. - use Monad_to_mnd_bicat_of_univ_cats. + exact C. + exact M. - use make_disp_mnd. + exact (SC ,, tt). + exact (tt ,, MS). + exact (tt ,, tt). + exact (tt ,, tt). Defined. (** 7. Monads in the bicategory of actegories *) Definition make_mnd_actegory (V : category) (Mon_V : monoidal V) (C : category) (M : Monad C) (Act : actegory Mon_V C) (Ml : lineator_lax Mon_V Act Act M) (ηlinear : is_linear_nat_trans (identity_lineator_lax Mon_V Act) Ml (η M)) (μlinear : is_linear_nat_trans (comp_lineator_lax Mon_V Ml Ml) Ml (μ M)) : mnd (actbicat Mon_V). Proof. use make_mnd_total_bicat. - apply actbicat_disp_2cells_isaprop. - use Monad_to_mnd_bicat_of_cats. + exact C. + exact M. - use make_disp_mnd. + exact Act. + exact Ml. + exact ηlinear. + exact μlinear. Defined. UniMath-20231010/UniMath/Bicategories/Monads/Examples/MonadsInTotalBicat.v000066400000000000000000000212131451125700300261200ustar00rootroot00000000000000(********************************************************************* Monads in total bicategories We show how to construct monads in total bicategories. Many interesting examples of bicategories can be constructed as total bicategories, such as monoidal categories, categories with an action, and categories with certain (co)limits. By showing how to construct monads, monad morphisms and monad cells in total bicategories, we are also able to construct those in the previously mentioned bicategories. Note: the formalization is currently restricted to the case in which all displayed 2-cells are equal. This is because this restriction makes all involved definitions simpler, because the laws do not have to be mentioned. Contents 1. Monads 2. Monad morphisms 3. Monad cells 4. Projections of monad in total bicategory *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. Section MonadInTotalBicat. Context {B : bicat} {D : disp_bicat B} (HD : disp_2cells_isaprop D). Let E : bicat := total_bicat D. (** 1. Monads *) Definition disp_mnd (m : mnd B) : UU := ∑ (Hob : D (ob_of_mnd m)) (Hendo : Hob -->[ endo_of_mnd m ] Hob), (id_disp Hob ==>[ unit_of_mnd m ] Hendo) × (Hendo ;; Hendo ==>[ mult_of_mnd m ] Hendo). Definition ob_of_disp_mnd {m : mnd B} (d : disp_mnd m) : D (ob_of_mnd m) := pr1 d. Section Projections. Context {m : mnd B} (dm : disp_mnd m). Definition endo_of_disp_mnd : ob_of_disp_mnd dm -->[ endo_of_mnd m ] ob_of_disp_mnd dm := pr12 dm. Definition unit_of_disp_mnd : id_disp _ ==>[ unit_of_mnd m ] endo_of_disp_mnd := pr122 dm. Definition mult_of_disp_mnd : endo_of_disp_mnd ;; endo_of_disp_mnd ==>[ mult_of_mnd m ] endo_of_disp_mnd := pr222 dm. End Projections. Definition make_disp_mnd {m : mnd B} (Hob : D (ob_of_mnd m)) (Hendo : Hob -->[ endo_of_mnd m ] Hob) (Hunit : id_disp Hob ==>[ unit_of_mnd m ] Hendo) (Hmult : Hendo ;; Hendo ==>[ mult_of_mnd m ] Hendo) : disp_mnd m := Hob ,, Hendo ,, Hunit ,, Hmult. Section MakeMonad. Context {m : mnd B} (dm : disp_mnd m). Definition make_mnd_data_total_bicat : mnd_data E. Proof. use make_mnd_data. - exact (ob_of_mnd m ,, ob_of_disp_mnd dm). - exact (endo_of_mnd m ,, endo_of_disp_mnd dm). - exact (unit_of_mnd m ,, unit_of_disp_mnd dm). - exact (mult_of_mnd m ,, mult_of_disp_mnd dm). Defined. Definition make_is_mnd_total_bicat : is_mnd E make_mnd_data_total_bicat. Proof. repeat split ; (use subtypePath ; [ intro ; apply HD | ]) ; cbn. - exact (mnd_unit_left m). - exact (mnd_unit_right m). - exact (mnd_mult_assoc m). Qed. Definition make_mnd_total_bicat : mnd E. Proof. use make_mnd. - exact make_mnd_data_total_bicat. - exact make_is_mnd_total_bicat. Defined. End MakeMonad. (** 2. Monad morphisms *) Definition disp_mnd_mor {m₁ m₂ : mnd B} (f : m₁ --> m₂) (dm₁ : disp_mnd m₁) (dm₂ : disp_mnd m₂) : UU := ∑ (ff : ob_of_disp_mnd dm₁ -->[ mor_of_mnd_mor f] ob_of_disp_mnd dm₂), ff ;; endo_of_disp_mnd dm₂ ==>[ mnd_mor_endo f] endo_of_disp_mnd dm₁ ;; ff. Section Projections. Context {m₁ m₂ : mnd B} {f : m₁ --> m₂} {dm₁ : disp_mnd m₁} {dm₂ : disp_mnd m₂} (ff : disp_mnd_mor f dm₁ dm₂). Definition mor_of_disp_mnd_mor : ob_of_disp_mnd dm₁ -->[ mor_of_mnd_mor f] ob_of_disp_mnd dm₂ := pr1 ff. Definition disp_mnd_mor_endo : mor_of_disp_mnd_mor ;; endo_of_disp_mnd dm₂ ==>[ mnd_mor_endo f ] endo_of_disp_mnd dm₁ ;; mor_of_disp_mnd_mor := pr2 ff. End Projections. Definition make_disp_mnd_mor {m₁ m₂ : mnd B} {f : m₁ --> m₂} {dm₁ : disp_mnd m₁} {dm₂ : disp_mnd m₂} (ff : ob_of_disp_mnd dm₁ -->[ mor_of_mnd_mor f] ob_of_disp_mnd dm₂) (Hff : ff ;; endo_of_disp_mnd dm₂ ==>[ mnd_mor_endo f] endo_of_disp_mnd dm₁ ;; ff) : disp_mnd_mor f dm₁ dm₂ := ff ,, Hff. Section MakeMonadMor. Context {m₁ m₂ : mnd B} {f : m₁ --> m₂} {dm₁ : disp_mnd m₁} {dm₂ : disp_mnd m₂} (ff : disp_mnd_mor f dm₁ dm₂). Definition make_mnd_mor_data_total_bicat : mnd_mor_data (make_mnd_total_bicat dm₁) (make_mnd_total_bicat dm₂). Proof. use make_mnd_mor_data. - exact (mor_of_mnd_mor f ,, mor_of_disp_mnd_mor ff). - exact (mnd_mor_endo f ,, disp_mnd_mor_endo ff). Defined. Definition make_mnd_mor_laws_total_bicat : mnd_mor_laws make_mnd_mor_data_total_bicat. Proof. repeat split ; (use subtypePath ; [ intro ; apply HD | ]) ; cbn. - exact (mnd_mor_unit f). - exact (mnd_mor_mu f). Qed. Definition make_mnd_mor_total_bicat : make_mnd_total_bicat dm₁ --> make_mnd_total_bicat dm₂. Proof. use make_mnd_mor. - exact make_mnd_mor_data_total_bicat. - exact make_mnd_mor_laws_total_bicat. Defined. End MakeMonadMor. (** 3. Monad cells *) Definition disp_mnd_cell {m₁ m₂ : mnd B} {f g : m₁ --> m₂} (α : f ==> g) {dm₁ : disp_mnd m₁} {dm₂ : disp_mnd m₂} (ff : disp_mnd_mor f dm₁ dm₂) (gg : disp_mnd_mor g dm₁ dm₂) : UU := mor_of_disp_mnd_mor ff ==>[ cell_of_mnd_cell α] mor_of_disp_mnd_mor gg. Section MakeMonadCell. Context {m₁ m₂ : mnd B} {f g : m₁ --> m₂} {α : f ==> g} {dm₁ : disp_mnd m₁} {dm₂ : disp_mnd m₂} {ff : disp_mnd_mor f dm₁ dm₂} {gg : disp_mnd_mor g dm₁ dm₂} (αα : disp_mnd_cell α ff gg). Definition make_mnd_cell_data_total_bicat : mnd_cell_data (make_mnd_mor_total_bicat ff) (make_mnd_mor_total_bicat gg) := cell_of_mnd_cell α ,, αα. Definition make_is_mnd_cell_total_bicat : is_mnd_cell make_mnd_cell_data_total_bicat. Proof. use subtypePath ; [ intro ; apply HD | ]. exact (mnd_cell_endo α). Qed. Definition make_mnd_cell_total_bicat : make_mnd_mor_total_bicat ff ==> make_mnd_mor_total_bicat gg. Proof. use make_mnd_cell. - exact make_mnd_cell_data_total_bicat. - exact make_is_mnd_cell_total_bicat. Defined. End MakeMonadCell. (** 4. Projections of monad in total bicategory *) Definition pr1_of_mnd_total_bicat_data (m : mnd E) : mnd_data B. Proof. use make_mnd_data. - exact (pr1 (ob_of_mnd m)). - exact (pr1 (endo_of_mnd m)). - exact (pr1 (unit_of_mnd m)). - exact (pr1 (mult_of_mnd m)). Defined. Definition pr1_of_mnd_total_bicat_is_mnd (m : mnd E) : is_mnd B (pr1_of_mnd_total_bicat_data m). Proof. repeat split. - exact (maponpaths pr1 (mnd_unit_left m)). - exact (maponpaths pr1 (mnd_unit_right m)). - exact (maponpaths pr1 (mnd_mult_assoc m)). Qed. Definition pr1_of_mnd_total_bicat (m : mnd E) : mnd B. Proof. use make_mnd. - exact (pr1_of_mnd_total_bicat_data m). - exact (pr1_of_mnd_total_bicat_is_mnd m). Defined. Definition disp_mnd_of_mnd_total_bicat (m : mnd E) : disp_mnd (pr1_of_mnd_total_bicat m). Proof. use make_disp_mnd. - exact (pr2 (ob_of_mnd m)). - exact (pr2 (endo_of_mnd m)). - exact (pr2 (unit_of_mnd m)). - exact (pr2 (mult_of_mnd m)). Defined. End MonadInTotalBicat. UniMath-20231010/UniMath/Bicategories/Monads/Examples/PsfunctorOnMonad.v000066400000000000000000000304351451125700300257060ustar00rootroot00000000000000(******************************************************************* Lifting pseudofunctors to monads If we have a pseudofunctor from `B₁` to `B₂`, then we can lift it to a pseudofunctor from `mnd B₁` to `mnd B₂`. Contents 1. Action on monads 2. Action on monad morphisms 3. Action on monad cells 4. The identitor 5. The compositor 6. The pseudofunctor *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. (** 1. Action on monads *) Section PsfunctorOnMonad. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) (m : mnd B₁). Let Fm : B₂ := F (ob_of_mnd m). Let Fe : Fm --> Fm := #F (endo_of_mnd m). Let Fη : id₁ Fm ==> Fe := psfunctor_id F _ • ##F (unit_of_mnd m). Let Fμ : Fe · Fe ==> Fe := psfunctor_comp F _ _ • ##F (mult_of_mnd m). Definition psfunctor_on_mnd_left_unit : (linvunitor Fe • (Fη ▹ Fe)) • Fμ = id₂ Fe. Proof. unfold Fη, Fμ, Fe. refine (_ @ psfunctor_id2 F _). rewrite <- (mnd_unit_left m). rewrite !psfunctor_vcomp. rewrite psfunctor_linvunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite psfunctor_rwhisker. apply idpath. Qed. Definition psfunctor_on_mnd_right_unit : (rinvunitor Fe • (Fe ◃ Fη)) • Fμ = id₂ Fe. Proof. unfold Fη, Fμ, Fe. refine (_ @ psfunctor_id2 F _). rewrite <- (mnd_unit_right m). rewrite !psfunctor_vcomp. rewrite psfunctor_rinvunitor. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite psfunctor_lwhisker. apply idpath. Qed. Definition psfunctor_on_mnd_mult_assoc : (rassociator Fe Fe Fe • (Fe ◃ Fμ)) • Fμ = (Fμ ▹ Fe) • Fμ. Proof. unfold Fμ, Fe. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. pose (maponpaths (λ z, ##F z) (mnd_mult_assoc m)) as p. cbn in p. rewrite !psfunctor_vcomp in p. etrans. { rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. refine (!_). apply psfunctor_lwhisker. } rewrite !vassocr. apply maponpaths_2. refine (!_). apply psfunctor_rassociator. } rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. apply p. } rewrite !vassocr. apply maponpaths_2. apply psfunctor_rwhisker. Qed. Definition psfunctor_on_mnd : mnd B₂. Proof. use make_mnd. - use make_mnd_data. + exact Fm. + exact Fe. + exact Fη. + exact Fμ. - repeat split. + exact psfunctor_on_mnd_left_unit. + exact psfunctor_on_mnd_right_unit. + exact psfunctor_on_mnd_mult_assoc. Defined. End PsfunctorOnMonad. (** 2. Action on monad morphisms *) Section PsfunctorOnMonadMor. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) {m₁ m₂ : mnd B₁} (f : m₁ --> m₂). Let Ff : F (ob_of_mnd m₁) --> F (ob_of_mnd m₂) := #F (mor_of_mnd_mor f). Let Fe : Ff · # F (endo_of_mnd m₂) ==> # F (endo_of_mnd m₁) · Ff := psfunctor_comp F _ _ • ##F (mnd_mor_endo f) • (psfunctor_comp F _ _)^-1. Definition psfunctor_on_mnd_mor_unit : linvunitor Ff • (unit_of_mnd (psfunctor_on_mnd F m₁) ▹ Ff) = (rinvunitor Ff • (Ff ◃ unit_of_mnd (psfunctor_on_mnd F m₂))) • Fe. Proof. unfold Ff, Fe. pose (maponpaths (λ z, ##F z) (mnd_mor_unit f)) as p. cbn in p. rewrite !psfunctor_vcomp in p. rewrite psfunctor_linvunitor in p. rewrite psfunctor_rinvunitor in p. rewrite !vassocl in p. rewrite psfunctor_rwhisker in p. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn -[psfunctor_comp psfunctor_id]. rewrite !vassocl. refine (_ @ p @ _). - apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. apply idpath. - apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite psfunctor_lwhisker. apply idpath. Qed. Definition psfunctor_on_mnd_mor_mu : lassociator _ _ _ • (Fe ▹ _) • rassociator _ _ _ • (_ ◃ Fe) • lassociator _ _ _ • (mult_of_mnd (psfunctor_on_mnd F m₁) ▹ Ff) = (Ff ◃ mult_of_mnd (psfunctor_on_mnd F m₂)) • Fe. Proof. unfold Fe, Ff. cbn -[psfunctor_id psfunctor_comp]. pose (maponpaths (λ z, ##F z) (mnd_mor_mu f)). cbn in p. rewrite !psfunctor_vcomp in p. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocr. refine (!_). etrans. { do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- psfunctor_lwhisker. apply idpath. } etrans. { rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- p. apply idpath. } etrans. { rewrite !vassocr. rewrite psfunctor_lassociator. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite psfunctor_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ]. cbn -[psfunctor_id psfunctor_comp]. etrans. { rewrite !vassocr. rewrite psfunctor_rassociator. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite psfunctor_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ]. cbn -[psfunctor_id psfunctor_comp]. etrans. { rewrite !vassocr. rewrite psfunctor_lassociator. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. rewrite !vassocr. rewrite psfunctor_rwhisker. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. Qed. Definition psfunctor_on_mnd_mor : psfunctor_on_mnd F m₁ --> psfunctor_on_mnd F m₂. Proof. use make_mnd_mor. - use make_mnd_mor_data. + exact Ff. + exact Fe. - split. + exact psfunctor_on_mnd_mor_unit. + exact psfunctor_on_mnd_mor_mu. Defined. End PsfunctorOnMonadMor. (** 3. Action on monad cells *) Definition psfunctor_on_mnd_cell {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) {m₁ m₂ : mnd B₁} {f g : m₁ --> m₂} (τ : f ==> g) : psfunctor_on_mnd_mor F f ==> psfunctor_on_mnd_mor F g. Proof. use make_mnd_cell. - exact (##F (cell_of_mnd_cell τ)). - abstract (unfold is_mnd_cell ; cbn -[psfunctor_comp psfunctor_id] ; rewrite !vassocr ; rewrite <- psfunctor_rwhisker ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite <- psfunctor_vcomp ; rewrite <- (mnd_cell_endo τ) ; rewrite !psfunctor_vcomp ; rewrite !vassocl ; apply maponpaths ; use vcomp_move_R_pM ; [ is_iso | ] ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp psfunctor_id] ; rewrite psfunctor_lwhisker ; apply idpath). Defined. (** 4. The identitor *) Definition psfunctor_on_mnd_id_mor {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) (m : mnd B₁) : id₁ _ ==> psfunctor_on_mnd_mor F (id₁ m). Proof. use make_mnd_cell. - unfold mnd_cell_data. exact (psfunctor_id F _). - abstract (unfold is_mnd_cell ; cbn -[psfunctor_id psfunctor_comp] ; rewrite !vassocl ; rewrite !psfunctor_vcomp ; rewrite psfunctor_lunitor ; rewrite !vassocl ; do 3 apply maponpaths ; rewrite psfunctor_rinvunitor ; rewrite !vassocl ; rewrite vcomp_rinv ; rewrite id2_right ; apply idpath). Defined. (** 5. The compositor *) Section PsfunctorOnMonadComposition. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) {m₁ m₂ m₃ : mnd B₁} (f : m₁ --> m₂) (g : m₂ --> m₃). Definition psfunctor_on_mnd_comp_mor_endo : mnd_mor_endo (psfunctor_on_mnd_mor F f · psfunctor_on_mnd_mor F g) • (_ ◃ psfunctor_comp F _ _) = (psfunctor_comp F _ _ ▹ _) • mnd_mor_endo (psfunctor_on_mnd_mor F (f · g)). Proof. cbn -[psfunctor_id psfunctor_comp]. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !psfunctor_vcomp. rewrite !vassocr. rewrite psfunctor_rassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn -[psfunctor_id psfunctor_comp]. rewrite !vassocl. etrans. { do 6 apply maponpaths. rewrite !vassocr. refine (!_). apply psfunctor_rassociator. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } rewrite <- psfunctor_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. refine (!_). apply psfunctor_lassociator. } rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite psfunctor_lwhisker. apply idpath. Qed. Definition psfunctor_on_mnd_comp_mor : psfunctor_on_mnd_mor F f · psfunctor_on_mnd_mor F g ==> psfunctor_on_mnd_mor F (f · g). Proof. use make_mnd_cell. - unfold mnd_cell_data. exact (psfunctor_comp F _ _). - unfold is_mnd_cell. exact psfunctor_on_mnd_comp_mor_endo. Defined. End PsfunctorOnMonadComposition. (* 6. The pseudofunctor *) Section LiftPsfunctorToMonad. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂). Definition lift_mnd_psfunctor_data : psfunctor_data (mnd B₁) (mnd B₂). Proof. use make_psfunctor_data. - exact (psfunctor_on_mnd F). - exact (λ _ _ f, psfunctor_on_mnd_mor F f). - exact (λ _ _ _ _ τ, psfunctor_on_mnd_cell F τ). - exact (psfunctor_on_mnd_id_mor F). - exact (λ _ _ _ f g, psfunctor_on_mnd_comp_mor F f g). Defined. Definition lift_mnd_psfunctor_laws : psfunctor_laws lift_mnd_psfunctor_data. Proof. repeat split ; intro ; intros ; use eq_mnd_cell ; cbn. - apply psfunctor_id2. - apply psfunctor_vcomp. - apply psfunctor_lunitor. - apply psfunctor_runitor. - apply psfunctor_lassociator. - apply psfunctor_lwhisker. - apply psfunctor_rwhisker. Qed. Definition lift_mnd_psfunctor_invertible_cells : invertible_cells lift_mnd_psfunctor_data. Proof. split ; intros ; use is_invertible_mnd_2cell ; cbn -[psfunctor_id psfunctor_comp]. - apply property_from_invertible_2cell. - apply property_from_invertible_2cell. Defined. Definition lift_mnd_psfunctor : psfunctor (mnd B₁) (mnd B₂). Proof. use make_psfunctor. - exact lift_mnd_psfunctor_data. - exact lift_mnd_psfunctor_laws. - exact lift_mnd_psfunctor_invertible_cells. Defined. End LiftPsfunctorToMonad. UniMath-20231010/UniMath/Bicategories/Monads/Examples/ToMonadInCat.v000066400000000000000000000110311451125700300247160ustar00rootroot00000000000000(********************************************************************** Every monad induces a monad on the hom-categories Given a bicategory `B`, a monad `m` in `B`, and an object `x`, then we get a monad on `hom x (pr1 m)`. **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Local Open Scope cat. Section MonadToCatMonad. Context {B : bicat} (m : mnd B) (x : B). Definition mnd_to_functor : hom x (pr1 m) ⟶ hom x (pr1 m) := post_comp x (endo_of_mnd m). Definition mnd_to_cat_mu : mnd_to_functor ∙ mnd_to_functor ⟹ mnd_to_functor. Proof. use make_nat_trans. - exact (λ f, rassociator _ _ _ • (f ◃ mult_of_mnd m)). - abstract (intros f g α ; cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. Definition mnd_to_cat_unit : functor_identity _ ⟹ mnd_to_functor. Proof. use make_nat_trans. - exact (λ f, rinvunitor _ • (f ◃ unit_of_mnd m)). - abstract (intros f g α ; cbn ; rewrite !vassocr ; rewrite rinvunitor_natural ; rewrite <- rwhisker_hcomp ; rewrite !vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. Definition mnd_to_cat_Monad_data : disp_Monad_data(C:=hom x (pr1 m)) mnd_to_functor := mnd_to_cat_mu,, mnd_to_cat_unit. Definition mnd_to_cat_Monad_laws : disp_Monad_laws mnd_to_cat_Monad_data. Proof. repeat split ; intro f ; cbn. - rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite <- rinvunitor_triangle. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. rewrite !vassocr. exact (mnd_unit_right m). - rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. rewrite !vassocr. exact (mnd_unit_left m). - rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. apply idpath. } use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite inverse_pentagon_7. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite <- lwhisker_lwhisker. refine (!_). rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite !lwhisker_vcomp. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (mnd_mult_assoc m). Qed. Definition mnd_to_cat_Monad : Monad (hom x (pr1 m)). Proof. simple refine (_,,(_ ,, _)). - exact mnd_to_functor. - exact mnd_to_cat_Monad_data. - exact mnd_to_cat_Monad_laws. Defined. End MonadToCatMonad. UniMath-20231010/UniMath/Bicategories/Monads/MixedDistributiveLaws.v000066400000000000000000000124441451125700300251640ustar00rootroot00000000000000(****************************************************************************** Mixed distributive laws distributive laws in bicategories Monads in the bicategory of comonads are the same as mixed distributive laws ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp2Bicat. Local Open Scope cat. Section MixedDistributiveLaw. Context {B : bicat} (m₁ : comnd B) (m₂ : disp_mnd B (ob_of_comnd m₁)). Let x : B := ob_of_comnd m₁. Let e : x --> x := endo_of_comnd m₁. Let ε : e ==> id₁ _ := counit_of_comnd m₁. Let δ : e ==> e · e := comult_of_comnd m₁. Let f : x --> x := pr11 m₂. Let η : id₁ _ ==> f := pr121 m₂. Let μ : f · f ==> f := pr221 m₂. Definition mixed_distr_law_data : UU := e · f ==> f · e. Definition mixed_distr_law_laws (τ : mixed_distr_law_data) : UU := ((ε ▹ f) • lunitor f = τ • (f ◃ ε) • runitor f) × ((δ ▹ f) • rassociator e e f • (e ◃ τ) • lassociator e f e • (τ ▹ e) • rassociator f e e = τ • (f ◃ δ)) × ((e ◃ η) • τ = runitor e • linvunitor e • (η ▹ e)) × ((e ◃ μ) • τ = lassociator e f f • (τ ▹ f) • rassociator f e f • (f ◃ τ) • lassociator f f e • (μ ▹ e)). Definition mixed_distr_law : UU := ∑ (τ : mixed_distr_law_data), mixed_distr_law_laws τ. Definition make_mixed_distr_law (τ : mixed_distr_law_data) (Hτ : mixed_distr_law_laws τ) : mixed_distr_law := τ ,, Hτ. Coercion mixed_distr_law_to_cell (τ : mixed_distr_law) : e · f ==> f · e := pr1 τ. End MixedDistributiveLaw. Section FromBicatToMixedDistrLaw. Context {B : bicat} (m : mnd (op2_bicat (mnd (op2_bicat B)))). Let x : B := pr1 (ob_of_mnd m). Let e : x --> x := pr112 (ob_of_mnd m). Let ε : e ==> id₁ _ := pr1 (pr212 (ob_of_mnd m)). Let δ : e ==> e · e := pr2 (pr212 (ob_of_mnd m)). Let f : x --> x := pr1 (endo_of_mnd m). Let η : id₁ _ ==> f := pr1 (unit_of_mnd m). Let μ : f · f ==> f := pr1 (mult_of_mnd m). Definition to_comnd_data_of_mixed_distr_law : comnd_data B. Proof. use make_comnd_data. - exact x. - exact e. - exact ε. - exact δ. Defined. Definition to_comnd_laws_of_mixed_distr_law : comnd_laws to_comnd_data_of_mixed_distr_law. Proof. repeat split. - unfold comnd_counit_left_law. rewrite !vassocl. exact (pr122 (ob_of_mnd m)). - unfold comnd_counit_right_law. rewrite !vassocl. exact (pr1 (pr222 (ob_of_mnd m))). - unfold comnd_comult_assoc_law. rewrite !vassocl. exact (pr2 (pr222 (ob_of_mnd m))). Qed. Definition to_comnd_of_mixed_distr_law : comnd B. Proof. use make_comnd. - exact to_comnd_data_of_mixed_distr_law. - exact to_comnd_laws_of_mixed_distr_law. Defined. Definition to_mnd_data_of_mixed_distr_law : mnd_data B. Proof. use make_mnd_data. - exact x. - exact f. - exact η. - exact μ. Defined. Definition to_is_mnd_of_mixed_distr_law : is_mnd B to_mnd_data_of_mixed_distr_law. Proof. repeat split. - exact (maponpaths pr1 (mnd_unit_left m)). - exact (maponpaths pr1 (mnd_unit_right m)). - exact (maponpaths pr1 (mnd_mult_assoc m)). Qed. Definition to_mnd_of_mixed_distr_law : mnd B. Proof. use make_mnd. - exact to_mnd_data_of_mixed_distr_law. - exact to_is_mnd_of_mixed_distr_law. Defined. Definition to_cell_of_mixed_distr_law : mixed_distr_law_data to_comnd_of_mixed_distr_law (pr2 to_mnd_of_mixed_distr_law) := pr112 (endo_of_mnd m). Definition to_laws_of_mixed_distr_law : mixed_distr_law_laws _ _ to_cell_of_mixed_distr_law. Proof. repeat split. - cbn. rewrite !vassocl. exact (pr1 (pr212 (endo_of_mnd m))). - cbn. rewrite !vassocl. exact (pr2 (pr212 (endo_of_mnd m))). - exact (pr112 (unit_of_mnd m)). - refine (pr112 (mult_of_mnd m) @ _). cbn. rewrite !vassocl. apply idpath. Qed. Definition to_mixed_distr_law : mixed_distr_law to_comnd_of_mixed_distr_law (pr2 to_mnd_of_mixed_distr_law). Proof. use make_mixed_distr_law. - exact to_cell_of_mixed_distr_law. - exact to_laws_of_mixed_distr_law. Defined. End FromBicatToMixedDistrLaw. UniMath-20231010/UniMath/Bicategories/Monads/MonadToAdjunction.v000066400000000000000000000465541451125700300242620ustar00rootroot00000000000000(********************************************************************************* Every monad gives rise to an adjunction If a bicategory has Eilenberg-Moore objects, then every monad arises from an adjunction. This is the so-called free-algebra adjunction. This generalizes the construction in Monads.MonadAlgebras.v. Note: since we can instantiate this construction for Kleisli objects as well, the construction also generalizes the construction in Monads.KleisliCategory.v Contents 1. Adjunction from monad 2. The monad from the adjunction from a monad is equivalent to the original monad *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.AdjunctionToMonad. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Local Open Scope cat. Section MonadToAdjunction. Context {B : bicat} (HB : bicat_has_em B) (m : mnd B). Let x : B := ob_of_mnd m. Let f : x --> x := endo_of_mnd m. Let η : id₁ _ ==> f := unit_of_mnd m. Let μ : f · f ==> f := mult_of_mnd m. Let e : em_cone m := pr1 (HB m). Let He : has_em_ump _ e := pr2 (HB m). Let l : e --> x := mor_of_mnd_mor (mor_of_em_cone _ e). Let lf : l · f ==> l := mnd_mor_endo (mor_of_em_cone _ e) • lunitor _. (** 1. Adjunction from monad *) Definition free_alg_1cell_cone : em_cone m. Proof. use make_em_cone. - exact x. - exact f. - exact (μ • linvunitor _). - abstract (refine (!(id2_left _) @ _) ; rewrite !vassocr ; apply maponpaths_2 ; refine (!_) ; exact (mnd_unit_right m)). - abstract (rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite !vassocr ; exact (!(mnd_mult_assoc m))). Defined. Definition free_alg_1cell : x --> e := em_ump_1_mor _ He free_alg_1cell_cone. Definition mnd_to_unit : id₁ x ==> free_alg_1cell · l := η • cell_of_mnd_cell ((em_ump_1_inv2cell _ He free_alg_1cell_cone)^-1). Definition mnd_to_counit_cell_data : mnd_cell_data (# (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e) (# (mnd_incl B) (id₁ e) · mor_of_em_cone m e) := rassociator _ _ _ • (_ ◃ cell_of_mnd_cell (em_ump_1_inv2cell _ He free_alg_1cell_cone)) • mnd_mor_endo (mor_of_em_cone m e). Local Definition em_ump_mnd_cell_endo_help : (_ ◃ mnd_mor_endo (mor_of_em_cone m e)) • lassociator _ _ _ • (runitor _ ▹ _) • cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone) = lassociator _ _ _ • (cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone) ▹ endo_of_mnd m) • μ. Proof. refine (_ @ vassocr _ _ _). use vcomp_move_L_pM ; [ is_iso | ]. use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ]. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite linvunitor_assoc. rewrite !vassocr. rewrite rwhisker_vcomp. apply idpath. } refine (_ @ mnd_cell_endo (em_ump_1_inv2cell m He free_alg_1cell_cone)). rewrite !vassocr. apply idpath. Qed. Definition mnd_to_counit_is_mnd_cell : is_mnd_cell mnd_to_counit_cell_data. Proof. unfold is_mnd_cell ; cbn. unfold mnd_to_counit_cell_data. rewrite runitor_lunitor_identity. rewrite lunitor_linvunitor. rewrite id2_rwhisker. rewrite id2_right. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite !vassocr. rewrite <- !lwhisker_vcomp. rewrite !vassocr. etrans. { apply maponpaths_2. rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_hcomp. rewrite <- inverse_pentagon_3. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_lwhisker_rassociator. etrans. { do 3 apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite rwhisker_vcomp. apply maponpaths. rewrite linvunitor_assoc. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. rewrite <- runitor_triangle. apply idpath. } rewrite !vassocl. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. rewrite vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. do 4 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite !vassocl. rewrite <- inverse_pentagon_4. rewrite <- lwhisker_hcomp. apply idpath. } apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite !vassocr. apply em_ump_mnd_cell_endo_help. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ]. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. refine (!_). refine (_ @ mnd_mor_mu (mor_of_em_cone m e)). rewrite !vassocl. do 4 apply maponpaths. refine (!_). apply lunitor_triangle. Qed. Definition mnd_to_counit_mnd_cell : # (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e ==> # (mnd_incl B) (id₁ e) · mor_of_em_cone m e. Proof. use make_mnd_cell. - exact mnd_to_counit_cell_data. - exact mnd_to_counit_is_mnd_cell. Defined. Definition mnd_to_counit : l · free_alg_1cell ==> id₁ e := em_ump_2_cell _ He mnd_to_counit_mnd_cell. Definition mnd_to_left_adjoint_data : left_adjoint_data free_alg_1cell := l ,, (mnd_to_unit ,, mnd_to_counit). Local Definition em_ump_mnd_cell_endo_inv_help : (cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) ▹ endo_of_mnd m) • rassociator _ _ _ • (_ ◃ mnd_mor_endo (mor_of_em_cone m e)) = μ • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) • (_ ◃ linvunitor _). Proof. use (vcomp_rcancel (lassociator _ _ _ • ((runitor _) ▹ _) • linvunitor _)) ; [ is_iso | ]. refine (!_). etrans. { rewrite !vassocl. do 2 apply maponpaths. rewrite lwhisker_hcomp. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. apply triangle_l_inv. } rewrite <- rwhisker_hcomp. apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). rewrite rinvunitor_runitor. apply id2_rwhisker. } rewrite id2_left. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. refine (vassocr _ _ _ @ _). refine (mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) @ _). rewrite !vassocl. apply maponpaths. cbn. rewrite !vassocl. do 3 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite linvunitor_assoc. apply idpath. Qed. Definition mnd_to_left_adjoint_axioms : left_adjoint_axioms mnd_to_left_adjoint_data. Proof. split. - use (em_ump_eq _ He). + apply id₂. + use eq_mnd_cell ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !rwhisker_hcomp. rewrite <- triangle_l. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply maponpaths_2. do 2 apply maponpaths. exact (maponpaths cell_of_mnd_cell (em_ump_2_eq _ He mnd_to_counit_mnd_cell)). } cbn ; unfold mnd_to_counit_cell_data. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } unfold mnd_to_unit. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. apply maponpaths_2. apply em_ump_mnd_cell_endo_inv_help. } etrans. { rewrite !vassocr. etrans. { do 5 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. apply mnd_unit_left. } rewrite id2_left. rewrite !vassocr. apply maponpaths_2. etrans. { apply maponpaths_2. exact (maponpaths cell_of_mnd_cell (vcomp_rinv (em_ump_1_inv2cell m He free_alg_1cell_cone))). } apply id2_left. } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. apply lwhisker_id2. + rewrite psfunctor_id2. apply id2_rwhisker. - cbn. rewrite !vassocl. unfold mnd_to_unit. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. apply maponpaths_2. exact (maponpaths cell_of_mnd_cell (em_ump_2_eq _ He mnd_to_counit_mnd_cell)). } simpl. unfold mnd_to_counit_cell_data. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. do 2 apply maponpaths_2. apply maponpaths. exact (maponpaths cell_of_mnd_cell (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))). } cbn. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. refine (!(mnd_mor_unit (mor_of_em_cone m e)) @ _). cbn. rewrite id2_rwhisker. rewrite id2_left, id2_right. apply idpath. Qed. Definition mnd_to_left_adjoint : left_adjoint free_alg_1cell := mnd_to_left_adjoint_data ,, mnd_to_left_adjoint_axioms. Definition mnd_to_adjunction : adjunction x e := free_alg_1cell ,, mnd_to_left_adjoint. (** 2. The monad from the adjunction from a monad is equivalent to the original monad *) Definition mnd_to_adjunction_to_mnd_data : mnd_mor_data (mnd_from_adjunction mnd_to_adjunction) m. Proof. use make_mnd_mor_data. - exact (id₁ _). - exact (lunitor _ • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone)^-1) • rinvunitor _). Defined. Definition mnd_to_adjunction_to_mnd_law₁ : linvunitor (id₁ x) • (mnd_to_unit ▹ id₁ x) = rinvunitor (id₁ x) • (id₁ x ◃ unit_of_mnd m) • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)) • rinvunitor _). Proof. rewrite lunitor_V_id_is_left_unit_V_id. rewrite !vassocl. apply maponpaths. unfold mnd_to_unit. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. rewrite id2_left. apply idpath. Qed. Definition mnd_to_adjunction_to_mnd_law₂ : lassociator (id₁ _) f f • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))) ▹ endo_of_mnd m) • rassociator (free_alg_1cell · l) (id₁ x) f • (free_alg_1cell · l ◃ (lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e)))) • lassociator (free_alg_1cell · l) (free_alg_1cell · l) (id₁ x) • ((((rassociator free_alg_1cell l (free_alg_1cell · l) • (free_alg_1cell ◃ lassociator l free_alg_1cell l)) • (free_alg_1cell ◃ (mnd_to_counit ▹ l))) • (free_alg_1cell ◃ lunitor l)) ▹ id₁ x) = (id₁ x ◃ μ) • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)) • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))). Proof. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. do 7 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. apply idpath. } rewrite id2_left. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite !vassocl. rewrite !rwhisker_vcomp. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply idpath. } etrans. { do 4 apply maponpaths. apply maponpaths_2. apply maponpaths. pose (p := maponpaths cell_of_mnd_cell (em_ump_2_eq m He mnd_to_counit_mnd_cell)). cbn in p. exact p. } unfold mnd_to_counit_cell_data. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_vcomp. etrans. { apply maponpaths. exact (maponpaths cell_of_mnd_cell (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))). } apply lwhisker_id2. } rewrite id2_left. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ]. pose (p := mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)). rewrite !vassocl. refine (!_). etrans. { rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocr. exact p. } apply maponpaths. cbn. rewrite !vassocl. apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite <- linvunitor_assoc. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- !lwhisker_vcomp. rewrite runitor_rwhisker. apply idpath. Qed. Definition mnd_to_adjunction_to_mnd_laws : mnd_mor_laws mnd_to_adjunction_to_mnd_data. Proof. split. - exact mnd_to_adjunction_to_mnd_law₁. - exact mnd_to_adjunction_to_mnd_law₂. Qed. Definition mnd_to_adjunction_to_mnd : mnd_from_adjunction mnd_to_adjunction --> m. Proof. use make_mnd_mor. - exact mnd_to_adjunction_to_mnd_data. - exact mnd_to_adjunction_to_mnd_laws. Defined. Definition mnd_to_adjunction_to_mnd_adj_equivalence (HB_2_0 : is_univalent_2_0 B) : left_adjoint_equivalence mnd_to_adjunction_to_mnd. Proof. use to_equivalence_mnd. - exact HB_2_0. - apply internal_adjoint_equivalence_identity. - cbn. is_iso. apply (from_invertible_mnd_2cell (inv_of_invertible_2cell (em_ump_1_inv2cell m He free_alg_1cell_cone))). Defined. End MonadToAdjunction. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/000077500000000000000000000000001451125700300230245ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionBasedStrength.v000066400000000000000000001162741451125700300271210ustar00rootroot00000000000000(** Definition of tensorial strength between actions over monoidal categories, as introduced under the name C-categories and C-functors (for C a monoidal category) by Bodo Pareigis (1977). The concrete definition is close to the paper "Second-Order and Dependently-Sorted Abstract Syntax" by Marcelo Fiore (2008). Notably, the strength itself is not required to be an isomorphism. To distinguish this from less general approaches, we will speak of action-based strength. Added by Ralph Matthes in 2021: relative strength of Ahrens and Matthes defined and shown to be an instance of action-based strength, another general definition in the spirit of Janelidze and Kelly **) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Import MonoidalNotations. Local Open Scope cat. Section A. Context (Mon_V : MonoidalCategoriesTensored.monoidal_cat). Local Definition I := monoidal_cat_unit Mon_V. Local Definition tensor := monoidal_cat_tensor Mon_V. Notation "X ⊗ Y" := (tensor (X ,, Y)). Section ActionBasedStrengths_Definition. Context {A A': category}. Context (actn : action Mon_V A)(actn' : action Mon_V A'). Local Definition ϱ := act_ϱ actn. Local Definition χ := act_χ actn. Local Definition ϱ' := act_ϱ actn'. Local Definition χ' := act_χ actn'. Section ActionBasedStrengths_Natural_Transformation. Context (F : A ⟶ A'). Notation "X ⊙ Y" := (act_odot actn (X , Y)) (at level 31). Notation "f #⊙ g" := (#(act_odot actn) (f #, g)) (at level 31). Notation "X ⊙' Y" := (act_odot actn' (X , Y)) (at level 31). Notation "f #⊙' g" := (#(act_odot actn') (f #, g)) (at level 31). Definition actionbased_strength_dom : A ⊠ Mon_V ⟶ A' := functor_composite (pair_functor F (functor_identity _)) (act_odot actn'). Lemma actionbased_strength_dom_ok: functor_on_objects actionbased_strength_dom = λ ax, F (ob1 ax) ⊙' (ob2 ax). Proof. apply idpath. Qed. Definition actionbased_strength_codom : A ⊠ Mon_V ⟶ A' := functor_composite (act_odot actn) F. Lemma actionbased_strength_codom_ok: functor_on_objects actionbased_strength_codom = λ ax, F (ob1 ax ⊙ ob2 ax). Proof. apply idpath. Qed. Definition actionbased_strength_nat : UU := nat_trans actionbased_strength_dom actionbased_strength_codom. Definition actionbased_strength_nat_funclass (ϛ : actionbased_strength_nat): ∏ x : ob (A ⊠ Mon_V), actionbased_strength_dom x --> actionbased_strength_codom x := pr1 ϛ. Coercion actionbased_strength_nat_funclass : actionbased_strength_nat >-> Funclass. Definition actionbased_strength_triangle_eq (ϛ : actionbased_strength_nat) := ∏ (a : A), (ϛ (a, I)) · (#F (ϱ a)) = ϱ' (F a). Definition actionbased_strength_pentagon_eq (ϛ : actionbased_strength_nat): UU := ∏ (a : A), ∏ (v w : Mon_V), (χ' ((F a, v), w)) · ϛ (a, v ⊗ w) = (ϛ (a, v)) #⊙' (id w) · (ϛ (a ⊙ v, w)) · (#F (χ ((a, v), w))). (** the notion in Fiore's LICS'08 paper *) Definition actionbased_strength_pentagon_eq_variant1 (ϛ : actionbased_strength_nat): UU := ∏ (a : A), ∏ (v w : Mon_V), ϛ (a, v ⊗ w) = (nat_z_iso_to_trans_inv χ' ((F a, v), w)) · (ϛ (a, v)) #⊙' (id w) · (ϛ (a ⊙ v, w)) · (#F (χ ((a, v), w))). (** the notion that fits with the definition of relative strength in the TYPES'15 post-proceedings paper by Ahrens and Matthes *) Definition actionbased_strength_pentagon_eq_variant2 (ϛ : actionbased_strength_nat): UU := ∏ (a : A), ∏ (v w : Mon_V), ϛ (a, v ⊗ w) · (#F (nat_z_iso_to_trans_inv χ ((a, v), w))) = (nat_z_iso_to_trans_inv χ' ((F a, v), w)) · (ϛ (a, v)) #⊙' (id w) · (ϛ (a ⊙ v, w)). (** as expected, the notions are logically equivalent *) Lemma actionbased_strength_pentagon_eq_tovariant1 (ϛ : actionbased_strength_nat): actionbased_strength_pentagon_eq ϛ -> actionbased_strength_pentagon_eq_variant1 ϛ. Proof. intros Heq a v w. red in Heq. apply pathsinv0. unfold nat_z_iso_to_trans_inv; cbn. unfold is_z_isomorphism_mor. do 2 rewrite <- assoc. apply (z_iso_inv_on_right _ _ _ (make_z_iso _ _ (pr2 χ' ((F a, v), w)))). apply pathsinv0. rewrite assoc. cbn. apply Heq. Qed. Lemma actionbased_strength_pentagon_eq_fromvariant1 (ϛ : actionbased_strength_nat): actionbased_strength_pentagon_eq_variant1 ϛ -> actionbased_strength_pentagon_eq ϛ. Proof. intros Heq a v w. red in Heq. unfold nat_z_iso_to_trans_inv in Heq; cbn in Heq. unfold is_z_isomorphism_mor in Heq. apply pathsinv0. apply (z_iso_inv_to_left _ _ _ (make_z_iso _ _ (pr2 χ' ((F a, v), w)))). cbn. apply pathsinv0. do 2 rewrite assoc. apply Heq. Qed. Lemma actionbased_strength_pentagon_eq_variant1variant2 (ϛ : actionbased_strength_nat): actionbased_strength_pentagon_eq_variant1 ϛ -> actionbased_strength_pentagon_eq_variant2 ϛ. Proof. intros Heq a v w. red in Heq. etrans. { unfold nat_z_iso_to_trans_inv. cbn. apply maponpaths. apply pathsinv0. apply functor_on_inv_from_z_iso'. } apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ (make_z_iso (# F (χ ((a, v), w))) (is_z_isomorphism_mor (functor_on_is_z_isomorphism F (pr2 χ ((a, v), w)))) (functor_on_is_z_isomorphism F (pr2 χ ((a, v), w))))). apply Heq. Qed. Lemma actionbased_strength_pentagon_eq_variant2variant1 (ϛ : actionbased_strength_nat): actionbased_strength_pentagon_eq_variant2 ϛ -> actionbased_strength_pentagon_eq_variant1 ϛ. Proof. intros Heq a v w. red in Heq. apply pathsinv0. apply (z_iso_inv_to_right _ _ _ _ (make_z_iso (# F (χ ((a, v), w))) (is_z_isomorphism_mor (functor_on_is_z_isomorphism F (pr2 χ ((a, v), w)))) (functor_on_is_z_isomorphism F (pr2 χ ((a, v), w))))). etrans. { apply pathsinv0. apply Heq. } clear Heq. apply maponpaths. apply pathsinv0. apply (functor_on_inv_from_z_iso' _ (pr2 χ ((a, v), w))). Qed. Lemma isaprop_actionbased_strength_triangle_eq (ϛ : actionbased_strength_nat) : isaprop (actionbased_strength_triangle_eq ϛ). Proof. apply impred; intros a. apply homset_property. Qed. Lemma isaprop_actionbased_strength_pentagon_eq (ϛ : actionbased_strength_nat) : isaprop (actionbased_strength_pentagon_eq ϛ). Proof. apply impred; intros a. apply impred; intros v. apply impred; intros w. apply homset_property. Qed. End ActionBasedStrengths_Natural_Transformation. Definition actionbased_strength (F : A ⟶ A') : UU := ∑ (ϛ : actionbased_strength_nat F), (actionbased_strength_triangle_eq F ϛ) × (actionbased_strength_pentagon_eq F ϛ). Lemma actionbased_strength_eq {F : A ⟶ A'} (sη sη': actionbased_strength F) : pr1 sη = pr1 sη' -> sη = sη'. Proof. intro Heq. apply subtypePath; trivial. intro ϛ. apply isapropdirprod. + apply isaprop_actionbased_strength_triangle_eq. + apply isaprop_actionbased_strength_pentagon_eq. Qed. Definition actionbased_strength_to_nat {F : A ⟶ A'} (FF : actionbased_strength F) : actionbased_strength_nat F := pr1 FF. Coercion actionbased_strength_to_nat : actionbased_strength >-> actionbased_strength_nat. (* Definition actionbased_strength_to_nat_trans {F : A ⟶ A'} (FF : actionbased_strength F) : nat_trans (actionbased_strength_dom F) (actionbased_strength_codom F) := pr1 FF. Coercion actionbased_strength_to_nat_trans : actionbased_strength >-> nat_trans. *) Identity Coercion actionbased_strength_nat_to_nat_trans : actionbased_strength_nat >-> nat_trans. Definition ab_strength_triangle {F : A ⟶ A'} (FF : actionbased_strength F) : actionbased_strength_triangle_eq F FF := pr1 (pr2 FF). Definition ab_strength_pentagon {F : A ⟶ A'} (FF : actionbased_strength F) : actionbased_strength_pentagon_eq F FF := pr2 (pr2 FF). End ActionBasedStrengths_Definition. Definition ab_strength_identity_functor {A : category} (actn : action Mon_V A) : actionbased_strength actn actn (functor_identity A). Proof. use tpair. - use make_nat_trans. + intro av. apply identity. + intros av av' fg. cbn. rewrite id_left. apply id_right. - split. + intro a. cbn. apply id_left. + intros a v w. cbn. rewrite binprod_id. do 2 rewrite id_right. etrans. 2: {apply cancel_postcomposition. apply pathsinv0, functor_id. } apply pathsinv0, id_left. Defined. Definition ab_strength_composition {A1 A2 A3 : category} {actn1 : action Mon_V A1} {actn2 : action Mon_V A2} {actn3 : action Mon_V A3} {F : A1 ⟶ A2} {F' : A2 ⟶ A3} : actionbased_strength actn1 actn2 F -> actionbased_strength actn2 actn3 F' -> actionbased_strength actn1 actn3 (F ∙ F'). Proof. intros ζ ζ'. use tpair. - use make_nat_trans. + intro av. induction av as [a v]. exact (ζ' (F a,, v) · # F' (ζ (a,, v))). + intros av av' fg. induction av as [a v]. induction av' as [a' v']. induction fg as [f g]. cbn. assert (ζisnatinst := nat_trans_ax ζ (a,, v) (a',, v') (f,, g)). assert (ζ'isnatinst := nat_trans_ax ζ' (F a,, v) (F a',, v') (# F f,, g)). rewrite assoc. etrans. { apply cancel_postcomposition. apply ζ'isnatinst. } do 2 rewrite <- assoc. apply maponpaths. cbn. do 2 rewrite <- functor_comp. apply maponpaths. apply ζisnatinst. - split. + intro a. cbn. assert (ζtriangleeqinst := ab_strength_triangle _ _ ζ a). assert (ζ'triangleeqinst := ab_strength_triangle _ _ ζ' (F a)). rewrite <- assoc. rewrite <- functor_comp. etrans. { do 2 apply maponpaths. exact ζtriangleeqinst. } exact ζ'triangleeqinst. + intros a v w. cbn. assert (ζpentagoneqinst := ab_strength_pentagon _ _ ζ a v w). assert (ζ'pentagoneqinst := ab_strength_pentagon _ _ ζ' (F a) v w). etrans. { rewrite assoc. apply cancel_postcomposition. exact ζ'pentagoneqinst. } clear ζ'pentagoneqinst. etrans. 2: { rewrite <- (id_right (id w)). rewrite binprod_comp. do 2 apply cancel_postcomposition. apply pathsinv0, functor_comp. } repeat rewrite <- assoc. apply maponpaths. etrans. { apply maponpaths. apply pathsinv0. apply (functor_comp F' (χ actn2 ((F a, v), w)) (ζ (a,, v ⊗ w))). } etrans. { do 2 apply maponpaths. apply ζpentagoneqinst. } clear ζpentagoneqinst. etrans. { do 2 rewrite functor_comp. repeat rewrite assoc. apply idpath. } repeat rewrite assoc. do 2 apply cancel_postcomposition. assert (ζ'natinst := nat_trans_ax ζ' (act_odot actn2 (F a, v),, w) (F(act_odot actn1 (a, v)),, w) (ζ (a,, v),, id w)). cbn in ζ'natinst. etrans. 2 : { apply pathsinv0, ζ'natinst. } apply idpath. Defined. Definition actionbased_strong_functor {A A' : category} (actn : action Mon_V A)(actn' : action Mon_V A') : UU := ∑ (F : A ⟶ A'), actionbased_strength actn actn' F. Definition actionbased_strong_functor_to_functor (A A' : category) (actn : action Mon_V A)(actn' : action Mon_V A') (FF : actionbased_strong_functor actn actn') : A ⟶ A' := pr1 FF. Coercion actionbased_strong_functor_to_functor : actionbased_strong_functor >-> functor. Definition ab_strong_functor_strength {A A' : category} (actn : action Mon_V A)(actn' : action Mon_V A') (FF : actionbased_strong_functor actn actn') : actionbased_strength_nat actn actn' FF := pr1 (pr2 FF). (* The standard tensorial strength: F(A) ⊗ B --> F(A ⊗ B) *) Definition tensorial_strength : Mon_V ⟶ Mon_V → UU := actionbased_strength (tensorial_action Mon_V) (tensorial_action Mon_V). Section Alternative_Definition. (** we continue in the spirit of the definition of actions given by Janelidze and Kelly, however we are not aware of this definition in the literature *) Context (A A' : category). Let Mon_EndA : monoidal_cat := monoidal_cat_of_endofunctors A. Let Mon_EndA' : monoidal_cat := monoidal_cat_of_endofunctors A'. Context (FA: strong_monoidal_functor Mon_V Mon_EndA). Context (FA': strong_monoidal_functor Mon_V Mon_EndA'). Section Param_Distr. Context (F : [A, A']). Local Definition precompF := pre_composition_functor _ A' A' F. Local Definition postcompF {C: category} := post_composition_functor C A A' F. (** a parameterized form of distributivity as strength *) Definition param_distributivity_dom : functor Mon_V [A, A'] := functor_compose (pr11 FA') precompF. Goal ∏ v, param_distributivity_dom v = functor_compose F (FA' v). Proof. intro v. apply idpath. Qed. Definition param_distributivity_codom : functor Mon_V [A, A'] := functor_compose (pr11 FA) postcompF. Goal ∏ v, param_distributivity_codom v = functor_compose (FA v) F. Proof. intro v. apply idpath. Qed. Definition parameterized_distributivity_nat : UU := param_distributivity_dom ⟹ param_distributivity_codom. Definition parameterized_distributivity_nat_funclass (δ : parameterized_distributivity_nat): ∏ v : ob (Mon_V), param_distributivity_dom v --> param_distributivity_codom v := pr1 δ. Coercion parameterized_distributivity_nat_funclass : parameterized_distributivity_nat >-> Funclass. Section The_Laws. Context (δ : parameterized_distributivity_nat). Definition param_distr_triangle_eq : UU := # precompF (lax_monoidal_functor_ϵ FA') · (δ I) = # postcompF (lax_monoidal_functor_ϵ FA). (** the type of the following def. is the same as that of [δ I], as seen from the definition that comes directly afterwards *) Definition param_distr_triangle_eq_variant0_RHS : [A, A'] ⟦ precompF (FA' (MonoidalFunctorsTensored.I_C Mon_V)), postcompF (FA (MonoidalFunctorsTensored.I_C Mon_V)) ⟧ := # precompF (strong_monoidal_functor_ϵ_inv FA') · # postcompF (lax_monoidal_functor_ϵ FA). Definition param_distr_triangle_eq_variant0 : UU := δ I = param_distr_triangle_eq_variant0_RHS. Definition param_distr_triangle_eq_variant : UU := (δ I) · (# postcompF (strong_monoidal_functor_ϵ_inv FA)) = # precompF (strong_monoidal_functor_ϵ_inv FA'). Definition postwhisker_with_ϵ_inv_z_iso : z_iso (postcompF (FA (MonoidalFunctorsTensored.I_C Mon_V))) (postcompF (MonoidalFunctorsTensored.I_D Mon_EndA)). Proof. apply functor_on_z_iso. use tpair. - exact (strong_monoidal_functor_ϵ_inv FA). - cbn beta in |- *. apply is_z_isomorphism_inv. Defined. Definition prewhisker_with_ϵ_inv_z_iso : z_iso (precompF (FA' (MonoidalFunctorsTensored.I_C Mon_V))) (precompF (MonoidalFunctorsTensored.I_D Mon_EndA')). Proof. apply functor_on_z_iso. use tpair. - exact (strong_monoidal_functor_ϵ_inv FA'). - cbn beta in |- *. apply is_z_isomorphism_inv. Defined. Lemma param_distr_triangle_eq_variant0_follows : param_distr_triangle_eq -> param_distr_triangle_eq_variant0. Proof. intro Hyp. red. unfold param_distr_triangle_eq_variant0_RHS. apply pathsinv0 in Hyp. apply (z_iso_inv_to_left _ _ _ prewhisker_with_ϵ_inv_z_iso). apply pathsinv0. exact Hyp. Qed. Lemma param_distr_triangle_eq_variant0_implies : param_distr_triangle_eq_variant0 -> param_distr_triangle_eq. Proof. intro Hyp. red in Hyp. unfold param_distr_triangle_eq_variant0_RHS in Hyp. apply (z_iso_inv_on_right _ _ _ prewhisker_with_ϵ_inv_z_iso) in Hyp. red. exact Hyp. Qed. Lemma param_distr_triangle_eq_variant_follows : param_distr_triangle_eq -> param_distr_triangle_eq_variant. Proof. intro Hyp. red. apply (z_iso_inv_to_right _ _ _ _ postwhisker_with_ϵ_inv_z_iso). apply (z_iso_inv_to_left _ _ _ prewhisker_with_ϵ_inv_z_iso). exact Hyp. Qed. Lemma param_distr_triangle_eq_variant_implies : param_distr_triangle_eq_variant -> param_distr_triangle_eq. Proof. intro Hyp. red in Hyp. apply pathsinv0 in Hyp. apply (z_iso_inv_on_left _ _ _ _ postwhisker_with_ϵ_inv_z_iso) in Hyp. apply (z_iso_inv_on_right _ _ _ prewhisker_with_ϵ_inv_z_iso) in Hyp. exact Hyp. Qed. (** we also abstract over the constituent distributivities *) Definition param_distr_pentagon_eq_body_RHS (v w : Mon_V) (dv: [A, A'] ⟦ param_distributivity_dom v, param_distributivity_codom v ⟧) (dw: [A, A'] ⟦ param_distributivity_dom w, param_distributivity_codom w ⟧) : [A, A'] ⟦ precompF (monoidal_functor_map_dom Mon_V Mon_EndA' FA' (v,, w)), postcompF (monoidal_functor_map_codom Mon_V Mon_EndA FA (v,, w))⟧. Proof. set (aux1 := # (post_comp_functor (FA' w)) dv). set (aux2 := # (pre_comp_functor (FA v)) dw). set (aux3 := # postcompF (lax_monoidal_functor_μ FA (v,,w))). set (auxr := aux1 · aux2). exact (auxr · aux3). Defined. Definition param_distr_pentagon_eq_body (v w : Mon_V) : UU. Proof. set (aux := # precompF (lax_monoidal_functor_μ FA' (v,,w))). exact (aux · δ (v ⊗ w) = param_distr_pentagon_eq_body_RHS v w (δ v) (δ w)). Defined. Definition param_distr_pentagon_eq : UU := ∏ (v w : Mon_V), param_distr_pentagon_eq_body v w. Definition param_distr_pentagon_eq_body_variant_RHS (v w : Mon_V) (dv: [A, A'] ⟦ param_distributivity_dom v, param_distributivity_codom v ⟧) (dw: [A, A'] ⟦ param_distributivity_dom w, param_distributivity_codom w ⟧) : [A, A'] ⟦ param_distributivity_dom (v ⊗ w), param_distributivity_codom (v ⊗ w) ⟧. Proof. set (aux1inv := # precompF (strong_monoidal_functor_μ_inv FA' (v,,w))). exact (aux1inv · (param_distr_pentagon_eq_body_RHS v w dv dw)). Defined. Definition param_distr_pentagon_eq_body_variant (v w : Mon_V): UU := δ (v ⊗ w) = param_distr_pentagon_eq_body_variant_RHS v w (δ v) (δ w). Definition prewhisker_with_μ_inv_z_iso (v w : Mon_V): z_iso (precompF (monoidal_functor_map_codom Mon_V Mon_EndA' FA' (v,, w))) (precompF (monoidal_functor_map_dom Mon_V Mon_EndA' FA' (v,, w))). Proof. use tpair. - exact (# precompF (strong_monoidal_functor_μ_inv FA' (v,,w))). - cbn beta in |- *. apply functor_on_is_z_isomorphism. apply is_z_isomorphism_inv. Defined. Lemma param_distr_pentagon_eq_body_variant_follows (v w : Mon_V): param_distr_pentagon_eq_body v w -> param_distr_pentagon_eq_body_variant v w. Proof. intro Hyp. red. unfold param_distr_pentagon_eq_body_variant_RHS. apply (z_iso_inv_to_left _ _ _ (prewhisker_with_μ_inv_z_iso v w)). exact Hyp. Qed. Lemma param_distr_pentagon_eq_body_variant_implies (v w : Mon_V): param_distr_pentagon_eq_body_variant v w -> param_distr_pentagon_eq_body v w. Proof. intro Hyp. red in Hyp. unfold param_distr_pentagon_eq_body_variant_RHS in Hyp. apply (z_iso_inv_on_right _ _ _ (prewhisker_with_μ_inv_z_iso v w)) in Hyp. exact Hyp. Qed. Lemma isaprop_param_distr_triangle_eq : isaprop param_distr_triangle_eq. Proof. apply homset_property. Qed. Lemma isaprop_param_distr_pentagon_eq : isaprop param_distr_pentagon_eq. Proof. red. apply impred; intros v. apply impred; intros w. apply isaset_nat_trans, homset_property. Qed. End The_Laws. Definition parameterized_distributivity : UU := ∑ (δ : parameterized_distributivity_nat), (param_distr_triangle_eq δ) × (param_distr_pentagon_eq δ). Lemma parameterized_distributivity_eq (sδ sδ': parameterized_distributivity) : pr1 sδ = pr1 sδ' -> sδ = sδ'. Proof. intro Heq. apply subtypePath; trivial. intro δ. apply isapropdirprod. - apply isaprop_param_distr_triangle_eq. - apply isaprop_param_distr_pentagon_eq. Qed. Definition parameterized_distributivity_to_nat (sδ : parameterized_distributivity) : parameterized_distributivity_nat := pr1 sδ. Coercion parameterized_distributivity_to_nat : parameterized_distributivity >-> parameterized_distributivity_nat. Identity Coercion parameterized_distributivity_nat_to_nat_trans : parameterized_distributivity_nat >-> nat_trans. Context (sδ : parameterized_distributivity). Let δ_triangle_eq : param_distr_triangle_eq (pr1 sδ) := pr1 (pr2 sδ). Let δ_pentagon_eq : param_distr_pentagon_eq (pr1 sδ) := pr2 (pr2 sδ). Let actionA : action Mon_V A := action_from_alt Mon_V A FA. Let actionA' : action Mon_V A':= action_from_alt Mon_V A' FA'. Definition strength_nat_from_alt_aux_dom : actionbased_strength_dom actionA' F ⟹ uncurry_functor _ _ _ param_distributivity_dom. Proof. use make_nat_trans. - intro av. apply identity. - intros av av' fg. cbn. rewrite id_left, id_right. apply idpath. Defined. Definition strength_nat_from_alt_aux_codom : uncurry_functor _ _ _ param_distributivity_codom ⟹ actionbased_strength_codom actionA F. Proof. use make_nat_trans. - intro av. apply identity. - intros av av' fg. cbn. rewrite id_left, id_right. apply pathsinv0. apply functor_comp. Defined. Definition strength_nat_from_alt : actionbased_strength_nat actionA actionA' F. Proof. red. refine (nat_trans_comp _ _ _ strength_nat_from_alt_aux_dom _). refine (nat_trans_comp _ _ _ _ strength_nat_from_alt_aux_codom). exact (uncurry_nattrans _ _ _ sδ). Defined. Lemma triangle_eq_from_alt : actionbased_strength_triangle_eq actionA actionA' F strength_nat_from_alt. Proof. red. intro a. apply param_distr_triangle_eq_variant_follows in δ_triangle_eq. red in δ_triangle_eq. apply (maponpaths pr1) in δ_triangle_eq. apply toforallpaths in δ_triangle_eq. assert (δ_triangle_eq_inst := δ_triangle_eq a). clear δ_triangle_eq δ_pentagon_eq. cbn in δ_triangle_eq_inst. unfold strength_nat_from_alt, actionA, actionA'. cbn. do 3 rewrite id_left. rewrite id_right. exact δ_triangle_eq_inst. Qed. Lemma pentagon_eq_from_alt : actionbased_strength_pentagon_eq actionA actionA' F strength_nat_from_alt. Proof. red. intros a v w. clear δ_triangle_eq. assert (Hyp := δ_pentagon_eq v w). red in Hyp. apply (maponpaths pr1) in Hyp. apply toforallpaths in Hyp. assert (Hypinst := Hyp a). clear Hyp. cbn in Hypinst. unfold strength_nat_from_alt, actionA, actionA'. cbn. do 5 rewrite id_left. do 5 rewrite id_right. assert (aux := functor_id FA' w). apply (maponpaths pr1) in aux. apply toforallpaths in aux. rewrite aux. rewrite id_right. exact Hypinst. Qed. Definition actionbased_strong_functor_from_alt : actionbased_strong_functor actionA actionA'. Proof. exists F. exists strength_nat_from_alt. split. - exact triangle_eq_from_alt. - exact pentagon_eq_from_alt. Defined. End Param_Distr. End Alternative_Definition. End A. Section Alternative_Definition_Whiskered. Import BifunctorNotations. Import MonoidalNotations. Context {V : category}. Context (Mon_V : monoidal V). Notation "X ⊗ Y" := (X ⊗_{ Mon_V } Y). Context (A A' : category). Let Mon_EndA : monoidal (cat_of_endofunctors A) := monoidal_of_endofunctors A. Let Mon_EndA' : monoidal (cat_of_endofunctors A') := monoidal_of_endofunctors A'. Context {FA: functor V (cat_of_endofunctors A)}. Context {FA': functor V (cat_of_endofunctors A')}. Context (FAm: fmonoidal Mon_V Mon_EndA FA). Context (FA'm: fmonoidal Mon_V Mon_EndA' FA'). Section Param_Distr. Context (F : [A, A']). (** the expected definitions: Local Definition precomp'F := pre_composition_functor _ A' A' F. Local Definition postcomp'F {C: category} := post_composition_functor C A A' F. *) (** the definitions that are more compatible with the bicategorical scenario Local Definition precomp'F := functor_fix_fst_arg _ _ _ (functorial_composition _ _ A') F. Local Definition postcomp'F {C: category} := functor_fix_snd_arg _ _ _ (functorial_composition C _ A') F. *) (** the definitions that force full compatibility with the bicategorical scenario *) Local Definition precomp'F := UniMath.Bicategories.Core.Bicat.lwhisker_functor(C:=UniMath.Bicategories.Core.Examples.BicatOfCats.bicat_of_cats)(c:=A') F. Local Definition postcomp'F {C: category} := UniMath.Bicategories.Core.Bicat.rwhisker_functor(C:=UniMath.Bicategories.Core.Examples.BicatOfCats.bicat_of_cats)(a:=C)(c:=A') F. (** a parameterized form of distributivity as strength *) Definition param_distributivity'_dom : functor V [A, A'] := functor_compose FA' precomp'F. Goal ∏ v, param_distributivity'_dom v = functor_compose F (FA' v). Proof. intro v. apply idpath. Qed. Definition param_distributivity'_codom : functor V [A, A'] := functor_compose FA postcomp'F. Goal ∏ v, param_distributivity'_codom v = functor_compose (FA v) F. Proof. intro v. apply idpath. Qed. Definition parameterized_distributivity'_nat : UU := param_distributivity'_dom ⟹ param_distributivity'_codom. Definition parameterized_distributivity'_nat_funclass (δ : parameterized_distributivity'_nat): ∏ v : V, param_distributivity'_dom v --> param_distributivity'_codom v := pr1 δ. Coercion parameterized_distributivity'_nat_funclass : parameterized_distributivity'_nat >-> Funclass. Section The_Laws. Context (δ : parameterized_distributivity'_nat). Definition param_distr'_triangle_eq : UU := # precomp'F (fmonoidal_preservesunit FA'm) · (δ I_{Mon_V}) = # postcomp'F (fmonoidal_preservesunit FAm). (** the type of the following def. is the same as that of [δ I_{Mon_V}], as seen from the definition that comes directly afterwards *) Definition param_distr'_triangle_eq_variant0_RHS : [A, A'] ⟦ precomp'F (FA' I_{ Mon_V}), postcomp'F (FA I_{ Mon_V}) ⟧ := # precomp'F (pr1 (fmonoidal_preservesunitstrongly FA'm)) · # postcomp'F (fmonoidal_preservesunit FAm). Definition param_distr'_triangle_eq_variant0 : UU := δ I_{Mon_V} = param_distr'_triangle_eq_variant0_RHS. Definition prewhisker_with_ϵ_inv_z_iso' : z_iso (precomp'F (FA' I_{Mon_V})) (precomp'F (I_{Mon_EndA'})). Proof. apply functor_on_z_iso. use tpair. - exact (pr1 (fmonoidal_preservesunitstrongly FA'm)). - cbn beta in |- *. apply is_z_isomorphism_inv. Defined. Lemma param_distr'_triangle_eq_variant0_follows : param_distr'_triangle_eq -> param_distr'_triangle_eq_variant0. Proof. intro Hyp. red. unfold param_distr'_triangle_eq_variant0_RHS. apply pathsinv0 in Hyp. apply (z_iso_inv_to_left _ _ _ prewhisker_with_ϵ_inv_z_iso'). apply pathsinv0. exact Hyp. Qed. Lemma param_distr'_triangle_eq_variant0_implies : param_distr'_triangle_eq_variant0 -> param_distr'_triangle_eq. Proof. intro Hyp. red in Hyp. unfold param_distr'_triangle_eq_variant0_RHS in Hyp. apply (z_iso_inv_on_right _ _ _ prewhisker_with_ϵ_inv_z_iso') in Hyp. red. exact Hyp. Qed. (** we also abstract over the constituent distributivities *) Definition param_distr'_pentagon_eq_body_RHS (v w : V) (dv: [A, A'] ⟦ param_distributivity'_dom v, param_distributivity'_codom v ⟧) (dw: [A, A'] ⟦ param_distributivity'_dom w, param_distributivity'_codom w ⟧) : [A, A'] ⟦ precomp'F ((FA' v) ⊗_{Mon_EndA'} (FA' w)), postcomp'F (FA (v ⊗_{Mon_V} w))⟧. Proof. set (aux1 := # (post_comp_functor (FA' w)) dv). set (aux2 := # (pre_comp_functor (FA v)) dw). set (aux3 := # postcomp'F (fmonoidal_preservestensordata FAm v w)). set (auxr := aux1 · aux2). exact (auxr · aux3). Defined. Definition param_distr'_pentagon_eq_body (v w : V) : UU. Proof. set (aux := # precomp'F (fmonoidal_preservestensordata FA'm v w)). exact (aux · δ (v ⊗ w) = param_distr'_pentagon_eq_body_RHS v w (δ v) (δ w)). Defined. Definition param_distr'_pentagon_eq : UU := ∏ (v w : V), param_distr'_pentagon_eq_body v w. Definition param_distr'_pentagon_eq_body_variant_RHS (v w : V) (dv: [A, A'] ⟦ param_distributivity'_dom v, param_distributivity'_codom v ⟧) (dw: [A, A'] ⟦ param_distributivity'_dom w, param_distributivity'_codom w ⟧) : [A, A'] ⟦ param_distributivity'_dom (v ⊗ w), param_distributivity'_codom (v ⊗ w) ⟧. Proof. set (aux1inv := # precomp'F (pr1 (fmonoidal_preservestensorstrongly FA'm v w))). exact (aux1inv · (param_distr'_pentagon_eq_body_RHS v w dv dw)). Defined. Definition param_distr'_pentagon_eq_body_variant (v w : V): UU := δ (v ⊗ w) = param_distr'_pentagon_eq_body_variant_RHS v w (δ v) (δ w). Definition param_distr'_pentagon_eq_variant: UU := ∏ (v w : V), param_distr'_pentagon_eq_body_variant v w. Definition prewhisker_with_μ_inv_z_iso' (v w : V): z_iso (precomp'F (FA' (v ⊗ w))) (precomp'F ((FA' v) ⊗_{Mon_EndA'} (FA' w))). Proof. use tpair. - exact (# precomp'F (pr1 (fmonoidal_preservestensorstrongly FA'm v w))). - cbn beta in |- *. apply functor_on_is_z_isomorphism. apply is_z_isomorphism_inv. Defined. Lemma param_distr'_pentagon_eq_body_variant_follows (v w : V): param_distr'_pentagon_eq_body v w -> param_distr'_pentagon_eq_body_variant v w. Proof. intro Hyp. red. unfold param_distr'_pentagon_eq_body_variant_RHS. apply (z_iso_inv_to_left _ _ _ (prewhisker_with_μ_inv_z_iso' v w)). exact Hyp. Qed. Lemma param_distr'_pentagon_eq_body_variant_implies (v w : V): param_distr'_pentagon_eq_body_variant v w -> param_distr'_pentagon_eq_body v w. Proof. intro Hyp. red in Hyp. unfold param_distr'_pentagon_eq_body_variant_RHS in Hyp. apply (z_iso_inv_on_right _ _ _ (prewhisker_with_μ_inv_z_iso' v w)) in Hyp. exact Hyp. Qed. Lemma isaprop_param_distr'_triangle_eq : isaprop param_distr'_triangle_eq. Proof. apply homset_property. Qed. Lemma isaprop_param_distr'_pentagon_eq : isaprop param_distr'_pentagon_eq. Proof. red. apply impred; intros v. apply impred; intros w. apply isaset_nat_trans, homset_property. Qed. End The_Laws. Definition parameterized_distributivity' : UU := ∑ (δ : parameterized_distributivity'_nat), (param_distr'_triangle_eq δ) × (param_distr'_pentagon_eq δ). Lemma parameterized_distributivity'_eq (sδ sδ': parameterized_distributivity') : pr1 sδ = pr1 sδ' -> sδ = sδ'. Proof. intro Heq. apply subtypePath; trivial. intro δ. apply isapropdirprod. - apply isaprop_param_distr'_triangle_eq. - apply isaprop_param_distr'_pentagon_eq. Qed. Definition parameterized_distributivity'_to_nat (sδ : parameterized_distributivity') : parameterized_distributivity'_nat := pr1 sδ. Coercion parameterized_distributivity'_to_nat : parameterized_distributivity' >-> parameterized_distributivity'_nat. Identity Coercion parameterized_distributivity'_nat_to_nat_trans : parameterized_distributivity'_nat >-> nat_trans. End Param_Distr. End Alternative_Definition_Whiskered. Section B. (** following the TYPES'15 post-proceedings paper by Ahrens and Matthes - will be identified as an instance of the previous *) Context {Mon_W Mon_V : monoidal_cat}. Local Definition timesV := monoidal_cat_tensor Mon_V. Local Definition lambda := monoidal_cat_left_unitor Mon_V. Local Definition alpha := monoidal_cat_associator Mon_V. Local Definition timesW := monoidal_cat_tensor Mon_W. Context (U : strong_monoidal_functor Mon_W Mon_V). Section RelativeStrengths_Natural_Transformation. Context (F: Mon_V ⟶ Mon_V). Notation "X ⊗V Y" := (timesV (X , Y)) (at level 31). Notation "X •W Y" := (timesW (X , Y)) (at level 31). Notation "f #⊗V g" := (#timesV (f #, g)) (at level 31). Notation "f #•W g" := (#timesW (f #, g)) (at level 31). Definition rel_strength_dom : Mon_W ⊠ Mon_V ⟶ Mon_V := functor_composite (pair_functor U F) timesV. Lemma rel_strength_dom_ok: functor_on_objects rel_strength_dom = λ ax, U (ob1 ax) ⊗V F (ob2 ax). Proof. apply idpath. Qed. Definition rel_strength_codom : Mon_W ⊠ Mon_V ⟶ Mon_V := functor_composite (functor_composite (pair_functor U (functor_identity _)) timesV) F. Lemma rel_strength_codom_ok: functor_on_objects rel_strength_codom = λ ax, F (U (ob1 ax) ⊗V ob2 ax). Proof. apply idpath. Qed. Definition rel_strength_nat : UU := nat_trans rel_strength_dom rel_strength_codom. Definition rel_strength_nat_funclass (ϛ : rel_strength_nat): ∏ x : ob (Mon_W ⊠ Mon_V), rel_strength_dom x --> rel_strength_codom x := pr1 ϛ. Coercion rel_strength_nat_funclass : rel_strength_nat >-> Funclass. (** the following looks like a pentagon but is of the nature of a triangle equation *) Definition rel_strength_pentagon_eq (ϛ : rel_strength_nat) := ∏ (v : Mon_V), ϛ (monoidal_cat_unit Mon_W, v) · #F (strong_monoidal_functor_ϵ_inv U #⊗V identity v) · #F (lambda v) = strong_monoidal_functor_ϵ_inv U #⊗V identity (F v) · lambda (F v). (** the following looks like a rectangle in the paper but is of the nature of a pentagon equation *) Definition rel_strength_rectangle_eq (ϛ : rel_strength_nat): UU := ∏ (w w' : Mon_W), ∏ (v : Mon_V), ϛ (w •W w', v) · #F (strong_monoidal_functor_μ_inv U (w, w') #⊗V identity v) · #F (alpha ((U w, U w'), v)) = strong_monoidal_functor_μ_inv U (w, w') #⊗V identity (F v) · alpha ((U w, U w'), F v) · identity (U w) #⊗V ϛ (w', v) · ϛ (w, U w' ⊗V v). End RelativeStrengths_Natural_Transformation. Definition rel_strength (F : Mon_V ⟶ Mon_V): UU := ∑ (ϛ : rel_strength_nat F), (rel_strength_pentagon_eq F ϛ) × (rel_strength_rectangle_eq F ϛ). Definition rel_strength_to_rel_strength_nat {F : Mon_V ⟶ Mon_V} (str : rel_strength F) : rel_strength_nat F := pr1 str. Coercion rel_strength_to_rel_strength_nat : rel_strength >-> rel_strength_nat. (* Definition rel_strength_to_nat_trans {F : Mon_V ⟶ Mon_V} (str : rel_strength F) : nat_trans (rel_strength_dom F) (rel_strength_codom F) := pr1 str. Coercion rel_strength_to_nat_trans : rel_strength >-> nat_trans. *) Identity Coercion rel_strength_nat_to_nat_trans : rel_strength_nat >-> nat_trans. Definition rel_strength_pentagon {F : Mon_V ⟶ Mon_V} (str : rel_strength F) : rel_strength_pentagon_eq F str := pr1 (pr2 str). Definition rel_strength_rectangle {F : Mon_V ⟶ Mon_V} (str : rel_strength F) : rel_strength_rectangle_eq F str := pr2 (pr2 str). Section RelativeStrength_Is_An_ActionBasedStrength. Context (F: Mon_V ⟶ Mon_V) (str: rel_strength F). Local Definition pentagon := rel_strength_pentagon str. Local Definition rectangle := rel_strength_rectangle str. Local Definition Mon_W' := swapping_of_monoidal_cat Mon_W. Local Definition timesW' := monoidal_cat_tensor Mon_W'. Local Definition Mon_V' := swapping_of_monoidal_cat Mon_V. Local Definition timesV' := monoidal_cat_tensor Mon_V'. Local Definition U' := swapping_of_strong_monoidal_functor U: strong_monoidal_functor Mon_W' Mon_V'. Local Definition phiinv' := pre_whisker binswap_pair_functor (strong_monoidal_functor_μ_inv U). Local Definition UAct := U_action Mon_W' U': action Mon_W' Mon_V'. Local Definition ϛ' := pre_whisker binswap_pair_functor str. Definition actionbased_strength_from_relative_strength: actionbased_strength Mon_W' UAct UAct F. Proof. exists ϛ'. split. - red. cbn. intro v. change (str (monoidal_cat_unit Mon_W, v) · # F (# timesV (strong_monoidal_functor_ϵ_inv U #, id v) · lambda v) = # timesV (strong_monoidal_functor_ϵ_inv U #, id F v) · lambda (F v)). rewrite <- pentagon. rewrite assoc'. rewrite functor_comp. apply idpath. - cbn. apply actionbased_strength_pentagon_eq_fromvariant1. apply actionbased_strength_pentagon_eq_variant2variant1. red. intros v w' w. unfold ϛ', Mon_W', Mon_V', U'. cbn. unfold is_z_isomorphism_mor, pre_whisker_on_nat_z_iso. cbn. assert (Hyp := rectangle w w' v). fold timesV. fold timesW. fold alpha. change (str (timesW (w, w'), v) · # F (# timesV (strong_monoidal_functor_μ_inv U (w, w') #, id v) · alpha ((U w, U w'), v)) = # timesV (strong_monoidal_functor_μ_inv U (w, w') #, id F v) · alpha ((U w, U w'), F v) · # timesV (# U (id w) #, str (w', v)) · str (w, timesV (U w', v))). rewrite functor_id. rewrite functor_comp. rewrite assoc. exact Hyp. Defined. End RelativeStrength_Is_An_ActionBasedStrength. Section ActionBasedStrength_Instantiates_To_RelativeStrength. Context (F: Mon_V ⟶ Mon_V) (ab_str: actionbased_strength Mon_W' UAct UAct F). Local Definition θ' : rel_strength_nat F := pre_whisker binswap_pair_functor ab_str. Lemma relative_strength_from_actionbased_strength_laws : rel_strength_pentagon_eq F θ' × rel_strength_rectangle_eq F θ'. Proof. split. - red. cbn. intro v. assert (Hyp := ab_strength_triangle _ _ _ ab_str v). cbn in Hyp. fold timesV in Hyp. etrans. 2: exact Hyp. clear Hyp. rewrite <- assoc. apply maponpaths. apply pathsinv0. apply functor_comp. - red. cbn. intros w w' v. assert (Hyp := actionbased_strength_pentagon_eq_variant1variant2 _ _ _ _ ab_str (actionbased_strength_pentagon_eq_tovariant1 _ _ _ _ ab_str (ab_strength_pentagon _ _ _ ab_str)) v w' w). cbn in Hyp. unfold is_z_isomorphism_mor, pre_whisker_on_nat_z_iso in Hyp. cbn in Hyp. unfold is_z_isomorphism_mor. rewrite functor_id in Hyp. rewrite functor_comp in Hyp. rewrite assoc in Hyp. exact Hyp. Qed. Definition relative_strength_from_actionbased_strength: rel_strength F. Proof. exists θ'. exact relative_strength_from_actionbased_strength_laws. Defined. End ActionBasedStrength_Instantiates_To_RelativeStrength. End B. Arguments ab_strength_triangle {_ _ _ _ _} _. Arguments ab_strength_pentagon {_ _ _ _ _} _. Arguments ab_strong_functor_strength {_ _ _ _} _. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionBasedStrongFunctorCategory.v000066400000000000000000000171611451125700300316310ustar00rootroot00000000000000(** organizes the (action-based) strong functors between two fixed categories into a category Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Local Open Scope cat. Section Strong_Functor_Category. Context (Mon_V : monoidal_cat). Context {A A': category}. Context (actn : action Mon_V A)(actn' : action Mon_V A'). Local Definition odot := pr1 actn. Local Definition odot' := pr1 actn'. Notation "X ⊙ Y" := (odot (X , Y)) (at level 31). Notation "f #⊙ g" := (#odot (f #, g)) (at level 31). Notation "X ⊙' Y" := (odot' (X , Y)) (at level 31). Notation "f #⊙' g" := (#odot' (f #, g)) (at level 31). Local Definition ζ (FF : actionbased_strong_functor Mon_V actn actn') := pr12 FF. Section Strong_Functor_Category_mor. Context (FF GG : actionbased_strong_functor Mon_V actn actn'). Context (η : FF ⟹ GG). Definition Strong_Functor_Category_mor_diagram (a: A) (v: Mon_V) : UU := ζ FF (a,v) · η (a ⊙ v) = η a #⊙' id v · ζ GG (a,v). Definition quantified_strong_functor_category_mor_diagram : UU := ∏ (a: A) (v: Mon_V), Strong_Functor_Category_mor_diagram a v. End Strong_Functor_Category_mor. Local Lemma Strong_Functor_Category_Mor_id_subproof (FF : actionbased_strong_functor Mon_V actn actn') a v : Strong_Functor_Category_mor_diagram FF FF (nat_trans_id FF) a v. Proof. red. change (ζ FF (a, v) · nat_trans_id FF (a ⊙ v) = # odot' (id (FF a, v)) · ζ FF (a, v)). rewrite functor_id. now rewrite id_left, id_right. Qed. Local Lemma Strong_Functor_Category_Mor_comp_subproof (FF GG HH : actionbased_strong_functor Mon_V actn actn') (η : FF ⟹ GG) (η': GG ⟹ HH): quantified_strong_functor_category_mor_diagram FF GG η -> quantified_strong_functor_category_mor_diagram GG HH η' -> quantified_strong_functor_category_mor_diagram FF HH (nat_trans_comp _ _ _ η η'). Proof. intros ηisstrong η'isstrong. red. intros a v. red. rewrite <- (id_left (id v)). change (ζ FF (a, v) · (η (a ⊙ v) · η' (a ⊙ v)) = # odot' ((η a #, id v) · (η' a #, id v)) · ζ HH (a, v)). rewrite functor_comp. etrans. { rewrite assoc. apply cancel_postcomposition. apply ηisstrong. } do 2 rewrite <- assoc. apply maponpaths. apply η'isstrong. Qed. Section AsDisplayedCategory. Definition Strong_Functor_category_displayed : disp_cat (functor_category A A'). Proof. use disp_cat_from_SIP_data. - intro F. exact (actionbased_strength Mon_V actn actn' F). - intros F1 F2 FF1 FF2 η. exact (∏ a v, Strong_Functor_Category_mor_diagram (F1,,FF1) (F2,,FF2) η a v). - intros F1 F2 FF1 FF2 η. do 2 (apply impred; intro). apply homset_property. - intros F FF a v. apply Strong_Functor_Category_Mor_id_subproof. - intros F G H FF GG HH η η' ηmor η'mor a v. simpl in ηmor, η'mor. exact (Strong_Functor_Category_Mor_comp_subproof (F,,FF) (G,,GG) (H,,HH) η η' ηmor η'mor a v). Defined. Definition Strong_Functor_category : category := total_category Strong_Functor_category_displayed. Lemma Strong_Functor_category_ob_ok : ob Strong_Functor_category = actionbased_strong_functor Mon_V actn actn'. Proof. apply idpath. Qed. Definition Strong_Functor_Category_Mor : actionbased_strong_functor Mon_V actn actn' -> actionbased_strong_functor Mon_V actn actn' -> UU. Proof. exact (pr2 (precategory_ob_mor_from_precategory_data Strong_Functor_category)). Defined. Lemma Strong_Functor_Category_Mor_ok (FF GG: actionbased_strong_functor Mon_V actn actn') : Strong_Functor_Category_Mor FF GG = total2 (quantified_strong_functor_category_mor_diagram FF GG). Proof. apply idpath. Qed. Definition Strong_Functor_Category_Mor_to_nat_trans (FF GG: actionbased_strong_functor Mon_V actn actn') : Strong_Functor_Category_Mor FF GG -> FF ⟹ GG. Proof. intro sη. exact (pr1 sη). Defined. Coercion Strong_Functor_Category_Mor_to_nat_trans : Strong_Functor_Category_Mor >-> nat_trans. Lemma Strong_Functor_Category_Mor_eq (FF GG : actionbased_strong_functor Mon_V actn actn') (sη sη' : Strong_Functor_Category_Mor FF GG) : pr1 sη = pr1 sη' -> sη = sη'. Proof. intros H. apply subtypePath; trivial. now intros α; repeat (apply impred; intro); apply homset_property. Qed. Definition Strong_FunctorForgetfulFunctor: functor Strong_Functor_category (functor_category A A'). Proof. use tpair. - use tpair. + intros FF; apply FF. + intros FF GG η; apply η. - abstract (now split). Defined. Lemma Strong_FunctorForgetfulFunctorFaithful: faithful Strong_FunctorForgetfulFunctor. Proof. intros FF GG. apply isinclbetweensets. + apply Strong_Functor_category. + apply functor_category_has_homsets. + apply Strong_Functor_Category_Mor_eq. Qed. (** towards univalence *) Lemma Strong_Functor_category_Pisset (F : [A, A']) : isaset (actionbased_strength Mon_V actn actn' F). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. - use (functor_category_has_homsets (A ⊠ Mon_V)). apply homset_property. - intro ϛ. apply isasetaprop. apply isapropdirprod. + apply isaprop_actionbased_strength_triangle_eq. + apply isaprop_actionbased_strength_pentagon_eq. Qed. Lemma Strong_Functor_category_Hstandard (F : [A, A']) (sη sη' : actionbased_strength Mon_V actn actn' F) : (∏ (a : A) (v : Mon_V), Strong_Functor_Category_mor_diagram (F,,sη) (F,,sη') (id F) a v) → (∏ (a : A) (v : Mon_V), Strong_Functor_Category_mor_diagram (F,,sη') (F,,sη) (id F) a v) → sη = sη'. Proof. intros leq geq. apply actionbased_strength_eq. apply nat_trans_eq_alt. intro av. assert (leqinst := leq (pr1 av) (pr2 av)). (* assert (geqinst := geq (pr1 av) (pr2 av)). *) clear leq geq. etrans. { apply pathsinv0. apply id_right. } etrans. { exact leqinst. } clear leqinst. etrans. 2: { apply id_left. } apply cancel_postcomposition. show_id_type. change (# odot' (id (pr1 F (pr1 av), pr2 av)) = id actionbased_strength_dom Mon_V actn' F av). rewrite functor_id. apply idpath. Qed. Definition is_univalent_Strong_Functor_category_displayed : is_univalent_disp Strong_Functor_category_displayed. Proof. use is_univalent_disp_from_SIP_data. - exact Strong_Functor_category_Pisset. - exact Strong_Functor_category_Hstandard. Defined. End AsDisplayedCategory. End Strong_Functor_Category. Definition is_univalent_Strong_Functor_category (Mon_V : monoidal_cat) (A : category) (A' : univalent_category) (actn : action Mon_V A) (actn' : action Mon_V A') : is_univalent (Strong_Functor_category Mon_V actn actn'). Proof. apply SIP. - exact (is_univalent_functor_category A _ (pr2 A')). - apply Strong_Functor_category_Pisset. - apply Strong_Functor_category_Hstandard. Defined. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionBasedStrongFunctorsMonoidal.v000066400000000000000000002705141451125700300320040ustar00rootroot00000000000000(** shows that action-based strong functors can be perceived as strong monoidal functors from the monoidal category that is acting on the underlying categories to a suitable monoidal category This means that the requirement on strength is that it behaves as a ``homomorphism'' w.r.t. the monoidal structures. Work in progress: the characterization in the monoidal case will need a full development of displayed monoidal categories and their sections, which is why there is now only a construction of a strong monoidal functor from a parameterized distributivity and no construction in the other direction Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.DisplayedMonoidalTensored. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Import Bicat.Notations. Local Open Scope cat. Section Upstream. (** this section has nothing to do with monoidal categories but is dictated by the aims of this file *) Context {C A A' : category}. Context (H H' : C ⟶ [A, A']). Definition trafotarget_disp_cat_ob_mor: disp_cat_ob_mor C. Proof. use make_disp_cat_ob_mor. - intro c. exact ([A, A']⟦(H c : A ⟶ A'), (H' c : A ⟶ A')⟧). - intros c c' α β f. exact (α · (# H' f) = (# H f) · β). Defined. Lemma trafotarget_disp_cat_id_comp: disp_cat_id_comp C trafotarget_disp_cat_ob_mor. Proof. split. - intros c α. red. unfold trafotarget_disp_cat_ob_mor, make_disp_cat_ob_mor. hnf. do 2 rewrite functor_id. rewrite id_left. apply id_right. - intros c1 c2 c3 f g α1 α2 α3 Hypf Hypg. red. red in Hypf, Hypg. unfold trafotarget_disp_cat_ob_mor, make_disp_cat_ob_mor in Hypf, Hypg |- *. hnf in Hypf, Hypg |- *. do 2 rewrite functor_comp. rewrite assoc. rewrite Hypf. rewrite <- assoc. rewrite Hypg. apply assoc. Qed. Definition trafotarget_disp_cat_data: disp_cat_data C := trafotarget_disp_cat_ob_mor ,, trafotarget_disp_cat_id_comp. Lemma trafotarget_disp_cells_isaprop (x y : C) (f : C ⟦ x, y ⟧) (xx : trafotarget_disp_cat_data x) (yy : trafotarget_disp_cat_data y): isaprop (xx -->[ f] yy). Proof. intros Hyp Hyp'. apply (functor_category_has_homsets _ _). Qed. Lemma trafotarget_disp_cat_axioms: disp_cat_axioms C trafotarget_disp_cat_data. Proof. repeat split; intros; try apply trafotarget_disp_cells_isaprop. apply isasetaprop. apply trafotarget_disp_cells_isaprop. Qed. Definition trafotarget_disp: disp_cat C := trafotarget_disp_cat_data ,, trafotarget_disp_cat_axioms. Definition trafotarget_cat: category := total_category trafotarget_disp. Definition forget_from_trafotarget: trafotarget_cat ⟶ C := pr1_category trafotarget_disp. Section TheEquivalence. (** a naive specification of the target of the bijection - we need to limit the equality to [functor_data] for the elementary definition *) Definition trafotarget_with_eq: UU := ∑ N: C ⟶ trafotarget_cat, functor_data_from_functor _ _ (functor_composite N forget_from_trafotarget) = functor_data_from_functor _ _ (functor_identity C). (** a "pedestrian" definition *) Definition nat_trafo_to_functor (η: H ⟹ H'): C ⟶ trafotarget_cat. Proof. use make_functor. - use make_functor_data. + intro c. exact (c ,, η c). + intros c c' f. exists f. red. unfold trafotarget_disp. hnf. apply pathsinv0, nat_trans_ax. - split; red. + intro c. use total2_paths_f. * cbn. apply idpath. * apply (functor_category_has_homsets _ _). + intros c1 c2 c3 f f'. use total2_paths_f. * cbn. apply idpath. * apply (functor_category_has_homsets _ _). Defined. (** an immediate consequence *) Definition nat_trafo_to_functor_with_eq (η: H ⟹ H'): trafotarget_with_eq. Proof. exists (nat_trafo_to_functor η). apply idpath. Defined. (** we can also use the infrastructure of displayed categories *) Definition nat_trafo_to_section (η: H ⟹ H'): @section_disp C trafotarget_disp. Proof. use tpair. - use tpair. + intro c. exact (η c). + intros c c' f. red. unfold trafotarget_disp. hnf. apply pathsinv0, nat_trans_ax. - split. + intro c. apply (functor_category_has_homsets _ _). + intros c1 c2 c3 f f'. apply (functor_category_has_homsets _ _). Defined. Definition nat_trafo_to_functor_through_section (η: H ⟹ H'): C ⟶ trafotarget_cat := @section_functor C trafotarget_disp (nat_trafo_to_section η). Definition nat_trafo_to_functor_through_section_cor (η: H ⟹ H'): functor_composite (nat_trafo_to_functor_through_section η) forget_from_trafotarget = functor_identity C. Proof. apply from_section_functor. Defined. (** the immediate consequence needs to weaken this strong information *) Definition nat_trafo_to_functor_through_section_with_eq (η: H ⟹ H'): trafotarget_with_eq. Proof. exists (nat_trafo_to_functor_through_section η). (* show_id_type. *) apply (maponpaths pr1 (nat_trafo_to_functor_through_section_cor η)). Defined. (** the backwards direction essentially uses the sections - already for the statements *) Definition section_to_nat_trafo: @section_disp C trafotarget_disp -> H ⟹ H'. Proof. intro sd. induction sd as [[sdob sdmor] [sdid sdcomp]]. use make_nat_trans. - intro c. exact (sdob c). - intros c c' f. assert (aux := sdmor c c' f). apply pathsinv0. exact aux. Defined. Local Lemma roundtrip1_with_sections (η: H ⟹ H'): section_to_nat_trafo (nat_trafo_to_section η) = η. Proof. apply nat_trans_eq; [ apply (functor_category_has_homsets _ _) |]. intro c. apply idpath. Qed. Local Lemma roundtrip2_with_sections (sd: @section_disp C trafotarget_disp): nat_trafo_to_section (section_to_nat_trafo sd) = sd. Proof. induction sd as [[sdob sdmor] [sdid sdcomp]]. unfold nat_trafo_to_section, section_to_nat_trafo. cbn. use total2_paths_f; simpl. - use total2_paths_f; simpl. + apply idpath. + (* a bit of an overkill: a real proof of equality *) cbn. do 3 (apply funextsec; intro). (* show_id_type. *) apply pathsinv0inv0. - match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + apply impred. intro c. (* assert (aux := sdmor c c (id c)). cbn in aux. match goal with [H: @paths ?ID _ _ |- _ ] => set (auxtype := ID); simpl in auxtype end. *) apply hlevelntosn. apply (functor_category_has_homsets _ _). + do 5 (apply impred; intro). apply hlevelntosn. apply (functor_category_has_homsets _ _). Qed. End TheEquivalence. End Upstream. (** the previous development can be generalized to a bicategory for the items in the target this paves the way for an efficient treatment of the construction of a monoidal target category *) Section UpstreamInBicat. Context {C0 : category}. (** an "ordinary" category for the source *) Context {C : bicat}. Context (a a' : ob C). Context (H H' : C0 ⟶ hom a a'). Definition trafotargetbicat_disp_cat_ob_mor: disp_cat_ob_mor C0. Proof. use make_disp_cat_ob_mor. - intro c. exact (H c ==> H' c). - intros c c' α β f. exact (α · (# H' f) = (# H f) · β). Defined. Lemma trafotargetbicat_disp_cat_id_comp: disp_cat_id_comp C0 trafotargetbicat_disp_cat_ob_mor. Proof. split. - intros c α. red. unfold trafotargetbicat_disp_cat_ob_mor, make_disp_cat_ob_mor. hnf. do 2 rewrite functor_id. rewrite id_left. apply id_right. - intros c1 c2 c3 f g α1 α2 α3 Hypf Hypg. red. red in Hypf, Hypg. unfold trafotargetbicat_disp_cat_ob_mor, make_disp_cat_ob_mor in Hypf, Hypg |- *. hnf in Hypf, Hypg |- *. do 2 rewrite functor_comp. rewrite assoc. rewrite Hypf. rewrite <- assoc. rewrite Hypg. apply assoc. Qed. Definition trafotargetbicat_disp_cat_data: disp_cat_data C0 := trafotargetbicat_disp_cat_ob_mor ,, trafotargetbicat_disp_cat_id_comp. Lemma trafotargetbicat_disp_cells_isaprop (x y : C0) (f : C0 ⟦ x, y ⟧) (xx : trafotargetbicat_disp_cat_data x) (yy : trafotargetbicat_disp_cat_data y): isaprop (xx -->[ f] yy). Proof. intros Hyp Hyp'. apply (hom a a'). Qed. Lemma trafotargetbicat_disp_cat_axioms: disp_cat_axioms C0 trafotargetbicat_disp_cat_data. Proof. repeat split; intros; try apply trafotargetbicat_disp_cells_isaprop. apply isasetaprop. apply trafotargetbicat_disp_cells_isaprop. Qed. Definition trafotargetbicat_disp: disp_cat C0 := trafotargetbicat_disp_cat_data ,, trafotargetbicat_disp_cat_axioms. Definition trafotargetbicat_cat: category := total_category trafotargetbicat_disp. Definition forget_from_trafotargetbicat: trafotargetbicat_cat ⟶ C0 := pr1_category trafotargetbicat_disp. Section EquivalenceInBicat. (** a "pedestrian" definition *) Definition nat_trafo_to_functor_bicat_elementary (η: H ⟹ H'): C0 ⟶ trafotargetbicat_cat. Proof. use make_functor. - use make_functor_data. + intro c. exact (c ,, η c). + intros c c' f. exists f. red. unfold trafotargetbicat_disp. hnf. apply pathsinv0, nat_trans_ax. - split; red. + intro c. use total2_paths_f. * cbn. apply idpath. * apply trafotargetbicat_disp_cells_isaprop. + intros c1 c2 c3 f f'. use total2_paths_f. * cbn. apply idpath. * apply trafotargetbicat_disp_cells_isaprop. Defined. (** using sections *) Definition nat_trafo_to_section_bicat (η: H ⟹ H'): @section_disp C0 trafotargetbicat_disp. Proof. use tpair. - use tpair. + intro c. exact (η c). + intros c c' f. red. unfold trafotargetbicat_disp. hnf. apply pathsinv0, nat_trans_ax. - split. + intro c. apply trafotargetbicat_disp_cells_isaprop. + intros c1 c2 c3 f f'. apply trafotargetbicat_disp_cells_isaprop. Defined. Definition nat_trafo_to_functor_bicat (η: H ⟹ H'): C0 ⟶ trafotargetbicat_cat := @section_functor C0 trafotargetbicat_disp (nat_trafo_to_section_bicat η). Definition nat_trafo_to_functor_bicat_cor (η: H ⟹ H'): functor_composite (nat_trafo_to_functor_bicat η) forget_from_trafotargetbicat = functor_identity C0. Proof. apply from_section_functor. Defined. (** the other direction, essentially dependent on sections *) Definition section_to_nat_trafo_bicat: @section_disp C0 trafotargetbicat_disp -> H ⟹ H'. Proof. intro sd. induction sd as [[sdob sdmor] [sdid sdcomp]]. use make_nat_trans. - intro c. exact (sdob c). - intros c c' f. assert (aux := sdmor c c' f). apply pathsinv0. exact aux. Defined. Local Lemma roundtrip1_with_sections_bicat (η: H ⟹ H'): section_to_nat_trafo_bicat (nat_trafo_to_section_bicat η) = η. Proof. apply nat_trans_eq; [ apply (hom a a') |]. intro c. apply idpath. Qed. Local Lemma roundtrip2_with_sections_bicat (sd: @section_disp C0 trafotargetbicat_disp): nat_trafo_to_section_bicat (section_to_nat_trafo_bicat sd) = sd. Proof. induction sd as [[sdob sdmor] [sdid sdcomp]]. unfold nat_trafo_to_section_bicat, section_to_nat_trafo_bicat. cbn. use total2_paths_f; simpl. - use total2_paths_f; simpl. + apply idpath. + (* a bit of an overkill: a real proof of equality *) cbn. do 3 (apply funextsec; intro). (* show_id_type. *) apply pathsinv0inv0. - match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + apply impred. intro c. (* assert (aux := sdmor c c (id c)). cbn in aux. match goal with [H: @paths ?ID _ _ |- _ ] => set (auxtype := ID); simpl in auxtype end. *) apply hlevelntosn. apply (hom a a'). + do 5 (apply impred; intro). apply hlevelntosn. apply (hom a a'). Qed. End EquivalenceInBicat. End UpstreamInBicat. Section Main. Context (Mon_V : monoidal_cat). Local Definition I := monoidal_cat_unit Mon_V. Local Definition tensor := monoidal_cat_tensor Mon_V. Notation "X ⊗ Y" := (tensor (X , Y)). Section ActionViaBicat. Context {C : bicat}. Context (a0 : ob C). Context (FA: strong_monoidal_functor Mon_V (monoidal_cat_from_bicat_and_ob a0)). (** currently no developement on the abstract level *) End ActionViaBicat. Section FunctorViaBicat. Context {C : bicat}. Context {a0 a0' : ob C}. Context (FA: strong_monoidal_functor Mon_V (monoidal_cat_from_bicat_and_ob a0)). Context (FA': strong_monoidal_functor Mon_V (monoidal_cat_from_bicat_and_ob a0')). Context (G : hom a0 a0'). Definition H : functor Mon_V (hom a0 a0') := functor_compose (pr11 FA') (functor_fix_fst_arg _ _ _ hcomp_functor G). Definition H' : functor Mon_V (hom a0 a0') := functor_compose (pr11 FA) (functor_fix_snd_arg _ _ _ hcomp_functor G). Lemma Hok (v: Mon_V) : H v = G · (pr11 FA') v. Proof. apply idpath. Defined. Lemma Hmorok (v v': Mon_V) (f: v --> v'): # H f = G ◃ # (pr11 FA') f. Proof. cbn. apply hcomp_identity_left. Qed. Lemma H'ok (v: Mon_V) : H' v = (pr11 FA) v · G. Proof. apply idpath. Defined. Lemma H'morok (v v': Mon_V) (f: v --> v'): # H' f = # (pr11 FA) f ▹ G. Proof. cbn. apply hcomp_identity_right. Qed. Definition montrafotargetbicat_disp: disp_cat Mon_V := trafotargetbicat_disp a0 a0' H H'. Definition montrafotargetbicat_cat: category := trafotargetbicat_cat a0 a0' H H'. Definition param_distr_bicat_triangle_eq_variant0_RHS : trafotargetbicat_disp a0 a0' H H' I. Proof. set (t1 := lwhisker G (strong_monoidal_functor_ϵ_inv FA')). set (t2 := rwhisker G (lax_monoidal_functor_ϵ FA)). refine (vcomp2 t1 _). refine (vcomp2 _ t2). apply (vcomp2(g:=G)). - apply runitor. - apply linvunitor. Defined. Definition montrafotargetbicat_disp_unit: montrafotargetbicat_disp I := param_distr_bicat_triangle_eq_variant0_RHS. Definition montrafotargetbicat_unit: montrafotargetbicat_cat := I,, montrafotargetbicat_disp_unit. Definition param_distr_bicat_pentagon_eq_body_RHS (v w : Mon_V) (dv: montrafotargetbicat_disp v) (dw: montrafotargetbicat_disp w) : H v · FA' w ==> FA (v ⊗ w) · G. Proof. set (aux1 := rwhisker (FA' w) dv). set (aux2 := lwhisker (FA v) dw). transparent assert (auxr : (H v · FA' w ==> FA v · H' w)). { refine (vcomp2 aux1 _). refine (vcomp2 _ aux2). cbn. apply rassociator. } set (aux3 := rwhisker G (lax_monoidal_functor_μ FA (v,,w))). refine (vcomp2 auxr _). refine (vcomp2 _ aux3). cbn. apply lassociator. Defined. Definition param_distr_bicat_pentagon_eq_body_variant_RHS (v w : Mon_V) (dv: montrafotargetbicat_disp v) (dw: montrafotargetbicat_disp w) : montrafotargetbicat_disp (v ⊗ w). Proof. set (aux1inv := lwhisker G (strong_monoidal_functor_μ_inv FA' (v,,w))). refine (vcomp2 aux1inv _). refine (vcomp2 _ (param_distr_bicat_pentagon_eq_body_RHS v w dv dw)). cbn. apply lassociator. Defined. (** a number of auxiliary isomorphisms to ease the lemmas on arrow reversion *) Definition lwhisker_with_μ_inv_inv2cell (v w : Mon_V): invertible_2cell (G · FA' (v ⊗ w)) (G · (FA' v · FA' w)). Proof. use make_invertible_2cell. - exact (lwhisker G (strong_monoidal_functor_μ_inv FA' (v,,w))). - apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v,, w))). (* is this change really needed? *) apply is_z_isomorphism_inv. Defined. Definition rwhisker_lwhisker_with_μ_inv_inv2cell (v1 v2 v3 : Mon_V): invertible_2cell (G · (FA' (v1 ⊗ v2) · FA' v3)) (G · (FA' v1 · FA' v2 · FA' v3)). Proof. use make_invertible_2cell. - exact (G ◃ (strong_monoidal_functor_μ_inv FA' (v1,, v2) ▹ FA' v3)). - apply is_invertible_2cell_lwhisker. apply is_invertible_2cell_rwhisker. change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v1,, v2))). apply is_z_isomorphism_inv. Defined. Definition lwhisker_rwhisker_with_ϵ_inv_inv2cell (v : Mon_V): invertible_2cell (G · FA' I · FA' v) (G · id₁ a0' · FA' v). Proof. use make_invertible_2cell. - exact ((G ◃ strong_monoidal_functor_ϵ_inv FA') ▹ FA' v). - apply is_invertible_2cell_rwhisker. apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (strong_monoidal_functor_ϵ_inv FA')). apply is_z_isomorphism_inv. Defined. Definition rwhisker_with_linvunitor_inv2cell (v : Mon_V): invertible_2cell (G · FA' v) (id₁ a0 · G · FA' v). Proof. use make_invertible_2cell. - exact (linvunitor G ▹ FA' v). - apply is_invertible_2cell_rwhisker. apply is_invertible_2cell_linvunitor. Defined. Definition lwhisker_with_linvunitor_inv2cell (v : Mon_V): invertible_2cell (FA v · G) (FA v · (id₁ a0 · G)). Proof. use make_invertible_2cell. - exact (FA v ◃ linvunitor G). - apply is_invertible_2cell_lwhisker. apply is_invertible_2cell_linvunitor. Defined. Definition lwhisker_with_invlunitor_inv2cell (v : Mon_V): invertible_2cell (G · (pr11 FA') v) (G · (pr11 FA') (tensor (I,, v))). Proof. use make_invertible_2cell. - exact (G ◃ # (pr11 FA') (pr1 (pr2 (monoidal_cat_left_unitor Mon_V) v))). - apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (# (pr11 FA') (pr1 (pr2 (monoidal_cat_left_unitor Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_left_unitor Mon_V) v)). Defined. Definition rwhisker_with_invlunitor_inv2cell (v : Mon_V): invertible_2cell ((pr11 FA) v · G) ((pr11 FA) (tensor (I,, v)) · G). Proof. use make_invertible_2cell. - exact (# (pr11 FA) (pr1 (pr2 (monoidal_cat_left_unitor Mon_V) v)) ▹ G). - apply is_invertible_2cell_rwhisker. change (is_z_isomorphism (# (pr11 FA) (pr1 (pr2 (monoidal_cat_left_unitor Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_left_unitor Mon_V) v)). Defined. Definition lwhisker_with_invrunitor_inv2cell (v : Mon_V): invertible_2cell (G · (pr11 FA') v) (G · (pr11 FA') (tensor (v,, I))). Proof. use make_invertible_2cell. - exact (G ◃ # (pr11 FA') (pr1 (pr2 (monoidal_cat_right_unitor Mon_V) v))). - apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (# (pr11 FA') (pr1 (pr2 (monoidal_cat_right_unitor Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_right_unitor Mon_V) v)). Defined. Definition rwhisker_with_invrunitor_inv2cell (v : Mon_V): invertible_2cell ((pr11 FA) v · G) ((pr11 FA) (tensor (v,, I)) · G). Proof. use make_invertible_2cell. - exact (# (pr11 FA) (pr1 (pr2 (monoidal_cat_right_unitor Mon_V) v)) ▹ G). - apply is_invertible_2cell_rwhisker. change (is_z_isomorphism (# (pr11 FA) (pr1 (pr2 (monoidal_cat_right_unitor Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_right_unitor Mon_V) v)). Defined. Definition lwhisker_with_ϵ_inv2cell (v : Mon_V): invertible_2cell (FA' v · id₁ a0') (FA' v · FA' (MonoidalFunctorsTensored.I_C Mon_V)). Proof. use make_invertible_2cell. - exact (FA' v ◃ lax_monoidal_functor_ϵ FA'). - apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (lax_monoidal_functor_ϵ FA')). apply (pr2 (strong_monoidal_functor_ϵ FA')). Defined. Definition rwhisker_with_invassociator_inv2cell (v1 v2 v3 : Mon_V): invertible_2cell ( (pr11 FA) (v1 ⊗ (v2 ⊗ v3)) · G) ((pr11 FA) ((v1 ⊗ v2) ⊗ v3) · G). Proof. use make_invertible_2cell. - exact (# (pr11 FA) (pr1 (pr2 (monoidal_cat_associator Mon_V) ((v1,, v2),, v3))) ▹ G). - apply is_invertible_2cell_rwhisker. change (is_z_isomorphism (# (pr11 FA) (pr1 (pr2 (monoidal_cat_associator Mon_V) ((v1,, v2),, v3))))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator Mon_V) ((v1,, v2),, v3))). Defined. (** end of auxiliary definitions of isomorphisms *) (** the main lemma for the construction of the tensor *) Lemma montrafotargetbicat_tensor_comp_aux (v w v' w': Mon_V) (f: Mon_V⟦v,v'⟧) (g: Mon_V⟦w,w'⟧) (η : montrafotargetbicat_disp v) (π : montrafotargetbicat_disp w) (η' : montrafotargetbicat_disp v') (π' : montrafotargetbicat_disp w') (Hyp: η -->[ f] η') (Hyp': π -->[ g] π'): param_distr_bicat_pentagon_eq_body_variant_RHS v w η π -->[# tensor (f,, g: pr1 Mon_V ⊠ pr1 Mon_V ⟦ v,, w, v',, w' ⟧)] param_distr_bicat_pentagon_eq_body_variant_RHS v' w' η' π'. Proof. unfold mor_disp in Hyp, Hyp' |- *. hnf in Hyp, Hyp' |- *. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. match goal with | [ |- (?Hαinv • (?Hassoc1 • ((?Hγ • (?Hassoc2 • ?Hδ)) • (?Hassoc3 • ?Hβ)))) · ?Hε = _ ] => set (αinv := Hαinv); set (γ := Hγ); set (δ:= Hδ); set (β := Hβ); set (ε1 := Hε) end. cbn in αinv, β. match goal with | [ |- _ = ?Hε · (?Hαinv • (?Hassoc4 • ((?Hγ • (?Hassoc5 • ?Hδ) • (?Hassoc6 • ?Hβ))))) ] => set (αinv' := Hαinv); set (γ' := Hγ); set (δ':= Hδ); set (β' := Hβ); set (ε2 := Hε) end. cbn in αinv', β'. (* cbn. shows that the cdot expands to bullet *) change ((αinv • (lassociator G ((pr11 FA') v) (FA' w) • ((γ • (rassociator (FA v) G ((pr11 FA') w) • δ)) • (lassociator (FA v) (FA w) G • β)))) • ε1 = ε2 • (αinv' • (lassociator G ((pr11 FA') v') (FA' w') • ((γ' • (rassociator (FA v') G ((pr11 FA') w') • δ')) • (lassociator (FA v') (FA w') G • β'))))). set (αinviso := lwhisker_with_μ_inv_inv2cell v w). cbn in αinviso. etrans. { apply pathsinv0. apply vassocr. } apply (lhs_left_invert_cell _ _ _ αinviso). apply pathsinv0. unfold inv_cell. set (α := lwhisker G (lax_monoidal_functor_μ FA' (v,, w))). cbn in α. match goal with | [ |- ?Hαcand • _ = _ ] => set (αcand := Hαcand) end. change αcand with α. clear αcand. set (fg := (f #, g)). assert (μFA'natinst := nat_trans_ax (lax_monoidal_functor_μ FA') _ _ fg). simpl in μFA'natinst. assert (μFAnatinst := nat_trans_ax (lax_monoidal_functor_μ FA) _ _ fg). simpl in μFAnatinst. set (ε2better := lwhisker G (# (functor_composite tensor FA') fg)). transparent assert (ε2betterok : (ε2 = ε2better)). { cbn. apply hcomp_identity_left. } rewrite ε2betterok. etrans. { apply vassocr. } apply (maponpaths (lwhisker G)) in μFA'natinst. apply pathsinv0 in μFA'natinst. etrans. { apply maponpaths_2. apply lwhisker_vcomp. } etrans. { apply maponpaths_2. exact μFA'natinst. } clear ε2 μFA'natinst ε2better ε2betterok. etrans. { apply maponpaths_2. apply pathsinv0. apply lwhisker_vcomp. } etrans. { apply pathsinv0. apply vassocr. } etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. unfold αinv'. apply lwhisker_vcomp. } etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. set (μFA'pointwise := nat_z_iso_pointwise_z_iso (strong_monoidal_functor_μ FA') (v',, w')). apply (z_iso_inv_after_z_iso μFA'pointwise). } clear αinv αinv' αinviso α. set (ε1better := rwhisker G (# (functor_composite tensor FA) fg)). transparent assert (ε1betterok : (ε1 = ε1better)). { cbn. apply hcomp_identity_right. } rewrite ε1betterok. cbn. rewrite lwhisker_id2. rewrite id2_left. match goal with | [ |- ?Hσ • _ = _ ] => set (σ' := Hσ) end. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply (maponpaths (rwhisker G)) in μFAnatinst. etrans. 2: { do 5 apply maponpaths. apply pathsinv0. apply rwhisker_vcomp. } etrans. 2: { do 5 apply maponpaths. exact μFAnatinst. } clear β μFAnatinst ε1 ε1better ε1betterok. etrans. 2: { do 5 apply maponpaths. apply rwhisker_vcomp. } match goal with | [ |- _ = _ • (_ • (_ • (_ • (_ • (_ • ?Hβ'twin))))) ] => set (β'twin := Hβ'twin) end. change β'twin with β'. clear β'twin. repeat rewrite vassocr. apply maponpaths_2. clear β'. unfold σ'. rewrite hcomp_hcomp'. unfold hcomp'. clear σ'. rewrite <- lwhisker_vcomp. match goal with | [ |- (((((?Hσ'1 • ?Hσ'2) • _) • _) • _) • _) • _ = _ • ?Hσ ] => set (σ'1 := Hσ'1); set (σ'2 := Hσ'2); set (σ := Hσ) end. change (η • # H' f = # H f • η') in Hyp. apply (maponpaths (rwhisker (FA' w'))) in Hyp. do 2 rewrite <- rwhisker_vcomp in Hyp. apply pathsinv0 in Hyp. assert (Hypvariant: σ'2 • lassociator G ((pr11 FA') v') (FA' w') • γ' = lassociator G ((pr11 FA') v) (FA' w') • (rwhisker (FA' w') η • rwhisker (FA' w') (# H' f))). { apply (maponpaths (vcomp2 (lassociator G ((pr11 FA') v) (FA' w')))) in Hyp. etrans. 2: { exact Hyp. } rewrite vassocr. apply maponpaths_2. rewrite Hmorok. apply rwhisker_lwhisker. } clear Hyp. intermediate_path (σ'1 • ((σ'2 • lassociator G ((pr11 FA') v') (FA' w')) • γ') • rassociator (FA v') G ((pr11 FA') w') • δ' • lassociator (FA v') (FA w') G). { repeat rewrite <- vassocr. apply idpath. } rewrite Hypvariant. clear σ'2 γ' Hypvariant. (* until here in parallel with earlier proof in CAT *) assert (σ'1ok : σ'1 • lassociator G ((pr11 FA') v) (FA' w') = lassociator G ((pr11 FA') v) (FA' w) • (H v ◃ # FA' g)). (* associators needed in addition to devel. in CAT *) { apply lwhisker_lwhisker. } etrans. { repeat rewrite vassocr. rewrite σ'1ok. apply idpath. } clear σ'1 σ'1ok. repeat rewrite <- vassocr. apply maponpaths. etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. apply pathsinv0. apply hcomp_hcomp'. } unfold hcomp. repeat rewrite <- vassocr. apply maponpaths. clear γ. change (π • # H' g = # H g • π') in Hyp'. apply (maponpaths (lwhisker (FA v))) in Hyp'. do 2 rewrite <- lwhisker_vcomp in Hyp'. rewrite H'morok in Hyp'. assert (Hyp'variant: δ • lassociator (FA v) ((pr11 FA) w) G • ((FA v ◃ # (pr11 FA) g) ▹ G) = ((FA v ◃ # H g) • (FA v ◃ π')) • lassociator (FA v) ((pr11 FA) w') G). (* close to what was called Hypvariant in the devel. in CAT *) { apply (maponpaths (fun x => x • lassociator (FA v) ((pr11 FA) w') G)) in Hyp'. etrans. { rewrite <- vassocr. apply maponpaths. apply pathsinv0. apply rwhisker_lwhisker. } rewrite vassocr. exact Hyp'. } clear Hyp'. set (σbetter := hcomp' (# FA f) (# FA g) ▹ G). assert (σbetterok : σ = σbetter). { apply maponpaths. apply hcomp_hcomp'. } rewrite σbetterok. clear σ σbetterok. unfold hcomp' in σbetter. set (σbetter' := ((FA v ◃ # FA g) ▹ G ) • ((# FA f ▹ FA w') ▹ G)). assert (σbetter'ok : σbetter = σbetter'). { apply pathsinv0, rwhisker_vcomp. } rewrite σbetter'ok. clear σbetter σbetter'ok. etrans. 2: { apply maponpaths. unfold σbetter'. repeat rewrite vassocr. apply maponpaths_2. apply pathsinv0. exact Hyp'variant. } clear Hyp'variant σbetter' δ. (* now very close to the situation in the CAT development where δ was cleared *) etrans. 2: { repeat rewrite vassocr. apply idpath. } match goal with | [ |- _ = (((_ • ?Hν'variant) • ?Hδ'π') • _) • _] => set (ν'variant := Hν'variant); set (δ'π' := Hδ'π') end. assert (ν'variantok: ν'variant • lassociator (FA v) G ((pr11 FA') w') = lassociator ((pr11 FA) v) G (FA' w) • (H' v ◃ # FA' g)). { unfold ν'variant. rewrite Hmorok. apply lwhisker_lwhisker. } etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply pathsinv0. use lhs_left_invert_cell. { apply is_invertible_2cell_rassociator. } etrans. 2: { repeat rewrite vassocr. do 4 apply maponpaths_2. exact ν'variantok. } repeat rewrite <- vassocr. apply maponpaths. clear ν'variant ν'variantok. etrans. { apply maponpaths. apply rwhisker_rwhisker. } repeat rewrite vassocr. apply maponpaths_2. rewrite H'morok. etrans. { apply pathsinv0. apply hcomp_hcomp'. } clear δ'π'. unfold hcomp. apply maponpaths_2. clear δ'. cbn. rewrite rwhisker_rwhisker. rewrite <- vassocr. etrans. { apply pathsinv0, id2_right. } apply maponpaths. apply pathsinv0. apply (vcomp_rinv (is_invertible_2cell_lassociator _ _ _)). Qed. Definition montrafotargetbicat_disp_tensor: displayed_tensor tensor montrafotargetbicat_disp. Proof. use tpair. - use tpair. + intros [v w] [η π]. exact (param_distr_bicat_pentagon_eq_body_variant_RHS v w η π). + intros [v w] [v' w'] [η π] [η' π'] [f g] [Hyp Hyp']. apply montrafotargetbicat_tensor_comp_aux; [exact Hyp | exact Hyp']. - cbv beta in |- *. split; intros; apply trafotargetbicat_disp_cells_isaprop. Defined. Definition montrafotargetbicat_tensor: montrafotargetbicat_cat ⊠ montrafotargetbicat_cat ⟶ montrafotargetbicat_cat := total_tensor tensor montrafotargetbicat_disp_tensor. Lemma montrafotargetbicat_left_unitor_aux1 (vη : montrafotargetbicat_cat): pr2 (I_pretensor montrafotargetbicat_tensor montrafotargetbicat_unit vη) -->[monoidal_cat_left_unitor Mon_V (pr1 vη)] pr2 (functor_identity montrafotargetbicat_cat vη). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vη as [v η]. etrans. 2: { apply maponpaths. cbn. apply idpath. } cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 3 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • ?Hl6))))))))) = ?Hr1 • _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r1 := Hr1) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_μ_inv_inv2cell I v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. set (l2iso := lwhisker_rwhisker_with_ϵ_inv_inv2cell v). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. etrans. 2: { repeat rewrite vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. unfold r1. do 2 rewrite lwhisker_vcomp. apply maponpaths. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := pr1 (lax_monoidal_functor_unital FA' v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_right in lax_monoidal_functor_unital_inst. exact lax_monoidal_functor_unital_inst. } clear l1 l2 l1iso l2iso r1. etrans. { do 2 apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_rwhisker_alt. } clear l3. cbn. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l4. unfold hcomp'. etrans. { repeat rewrite <- vassocr. do 4 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. repeat rewrite <- vassocr. apply maponpaths. unfold l5, l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. apply pathsinv0. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := pr1 (lax_monoidal_functor_unital FA v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_right in lax_monoidal_functor_unital_inst. exact lax_monoidal_functor_unital_inst. } clear l5 l6. (* now only admin tasks in bicategory *) rewrite lunitor_lwhisker. apply maponpaths. apply (lhs_left_invert_cell _ _ _ (rwhisker_with_linvunitor_inv2cell v)). cbn. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)). cbn. apply pathsinv0, lunitor_triangle. Qed. Lemma montrafotargetbicat_left_unitor_aux2 (vη : montrafotargetbicat_cat): pr2 (functor_identity montrafotargetbicat_cat vη) -->[pr1 (pr2 (monoidal_cat_left_unitor Mon_V) (pr1 vη))] pr2 (I_pretensor montrafotargetbicat_tensor montrafotargetbicat_unit vη). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vη as [v η]. etrans. { apply maponpaths_2. cbn. apply idpath. } cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 3 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. apply pathsinv0. match goal with | [ |- ?Hl1 • (?Hl2 • (_ • (?Hl3 • (_ • (_ • (?Hl4 • (_ • (?Hl5 • (_ • ?Hl6))))))))) = _ • ?Hr2] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r2 := Hr2) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_invlunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. set (l2iso := lwhisker_with_μ_inv_inv2cell I v). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. set (l3iso := lwhisker_rwhisker_with_ϵ_inv_inv2cell v). apply (lhs_left_invert_cell _ _ _ l3iso). cbn. match goal with | [ |- _ = ?Hl3inv • (_ • (?Hl2inv • (?Hl1inv • _)))] => set (l1inv := Hl1inv); set (l2inv := Hl2inv); set (l3inv := Hl3inv) end. clear l1 l2 l3 l1iso l2iso l3iso. etrans. 2: { repeat rewrite vassocr. do 4 apply maponpaths_2. unfold l3inv. apply rwhisker_lwhisker_rassociator. } etrans. 2: { do 2 apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. unfold l2inv, l1inv. do 2 rewrite lwhisker_vcomp. apply maponpaths. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := pr1 (lax_monoidal_functor_unital FA' v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_right in lax_monoidal_functor_unital_inst. exact lax_monoidal_functor_unital_inst. } clear l1inv l2inv l3inv. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. apply rwhisker_rwhisker_alt. } cbn. etrans. { do 2 apply maponpaths. do 2 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l4 l5. unfold hcomp'. set (r2iso := rwhisker_with_invlunitor_inv2cell v). apply pathsinv0. apply (lhs_right_invert_cell _ _ _ r2iso). apply pathsinv0. cbn. clear r2 r2iso. etrans. { repeat rewrite <- vassocr. do 4 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. repeat rewrite <- vassocr. apply maponpaths. unfold l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. apply pathsinv0. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := pr1 (lax_monoidal_functor_unital FA v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_right in lax_monoidal_functor_unital_inst. exact lax_monoidal_functor_unital_inst. } clear l6. (* now only admin tasks in bicategory: the goal is the same as at that position in [montrafotargetbicat_left_unitor_aux1] *) rewrite lunitor_lwhisker. apply maponpaths. apply (lhs_left_invert_cell _ _ _ (rwhisker_with_linvunitor_inv2cell v)). cbn. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)). cbn. apply pathsinv0, lunitor_triangle. Qed. Definition montrafotargetbicat_left_unitor: left_unitor montrafotargetbicat_tensor montrafotargetbicat_unit. Proof. use make_nat_z_iso. + use make_nat_trans. * intro vη. exists (monoidal_cat_left_unitor Mon_V (pr1 vη)). apply montrafotargetbicat_left_unitor_aux1. * intros vη vη' fg. use total2_paths_f. -- cbn. do 3 rewrite id_left. rewrite id_right. apply (nat_trans_ax (monoidal_cat_left_unitor Mon_V)). -- apply trafotargetbicat_disp_cells_isaprop. + intro vη. use make_is_z_isomorphism. * exists (pr1 (pr2 (monoidal_cat_left_unitor Mon_V) (pr1 vη))). apply montrafotargetbicat_left_unitor_aux2. * split. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_left_unitor Mon_V) (pr1 vη))). ++ apply trafotargetbicat_disp_cells_isaprop. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_left_unitor Mon_V) (pr1 vη))). ++ apply trafotargetbicat_disp_cells_isaprop. Defined. Lemma montrafotargetbicat_right_unitor_aux1 (vη : montrafotargetbicat_cat): pr2 (I_posttensor montrafotargetbicat_tensor montrafotargetbicat_unit vη) -->[monoidal_cat_right_unitor Mon_V (pr1 vη)] pr2 (functor_identity montrafotargetbicat_cat vη). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vη as [v η]. etrans. 2: { apply maponpaths. cbn. apply idpath. } cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 3 rewrite <- lwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (_ • (?Hl4 • (_ • (?Hl5 • ?Hl6))))))))) = ?Hr1 • _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r1 := Hr1) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_μ_inv_inv2cell v I). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. unfold r1. rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := pr2 (lax_monoidal_functor_unital FA' v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_left in lax_monoidal_functor_unital_inst. set (aux1iso := lwhisker_with_ϵ_inv2cell v). rewrite <- vassocr in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. apply (rhs_left_inv_cell _ _ _ aux1iso) in lax_monoidal_functor_unital_inst. unfold inv_cell in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } cbn. clear r1. etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply lwhisker_lwhisker_rassociator. } etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply pathsinv0, runitor_triangle. } rewrite <- vcomp_runitor. etrans. 2: { rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear l2. etrans. { repeat rewrite vassocr. do 6 apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } repeat rewrite <- vassocr. apply maponpaths. clear l3. cbn. etrans. { repeat rewrite vassocr. do 5 apply maponpaths_2. apply runitor_triangle. } etrans. 2: { apply id2_right. } repeat rewrite <- vassocr. apply maponpaths. etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker. } cbn. clear l4. etrans. { apply maponpaths. rewrite <- vassocr. apply maponpaths. unfold l5, l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := pr2 (lax_monoidal_functor_unital FA v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_left in lax_monoidal_functor_unital_inst. rewrite vassocr. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l5 l6. (* now only pure bicategory reasoning *) set (auxiso := lwhisker_with_linvunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ auxiso). cbn. rewrite id2_right. clear auxiso. apply runitor_rwhisker. Qed. Lemma montrafotargetbicat_right_unitor_aux2 (vη : montrafotargetbicat_cat): pr2 (functor_identity montrafotargetbicat_cat vη) -->[pr1 (pr2 (monoidal_cat_right_unitor Mon_V) (pr1 vη))] pr2 (I_posttensor montrafotargetbicat_tensor montrafotargetbicat_unit vη). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vη as [v η]. etrans. { apply maponpaths_2. cbn. apply idpath. } apply pathsinv0. cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 3 rewrite <- lwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (_ • (?Hl5 • (_ • ?Hl6))))))))) = _ • ?Hr2] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r2 := Hr2) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_invrunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. set (l2iso := lwhisker_with_μ_inv_inv2cell v I). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. clear l2 l2iso. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := pr2 (lax_monoidal_functor_unital FA' v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_left in lax_monoidal_functor_unital_inst. set (aux1iso := lwhisker_with_ϵ_inv2cell v). rewrite <- vassocr in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. apply (rhs_left_inv_cell _ _ _ aux1iso) in lax_monoidal_functor_unital_inst. unfold inv_cell in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } cbn. (* same goal as in [montrafotargetbicat_right_unitor_aux1], except l_i -> l_{i+1} for i=2,3,4,5, and l6 becomes r2 on the other side *) etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply lwhisker_lwhisker_rassociator. } etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply pathsinv0, runitor_triangle. } etrans. 2: { apply maponpaths. rewrite vassocr. rewrite <- vcomp_runitor. apply idpath. } etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear l3. etrans. { repeat rewrite vassocr. do 5 apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } repeat rewrite <- vassocr. apply maponpaths. clear l4. cbn. etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. apply runitor_triangle. } (* now we put an end to the diversion from the goal in [montrafotargetbicat_right_unitor_aux1] *) set (r2iso := rwhisker_with_invrunitor_inv2cell v). apply pathsinv0, (lhs_right_invert_cell _ _ _ r2iso), pathsinv0. cbn. clear r2 r2iso. (* resume analogous proof *) etrans. 2: { apply id2_right. } repeat rewrite <- vassocr. apply maponpaths. etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker. } cbn. clear l5. etrans. { apply maponpaths. rewrite <- vassocr. apply maponpaths. unfold l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := pr2 (lax_monoidal_functor_unital FA v)). cbn in lax_monoidal_functor_unital_inst. rewrite hcomp_identity_left in lax_monoidal_functor_unital_inst. rewrite vassocr. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l6. (* now only pure bicategory reasoning *) set (auxiso := lwhisker_with_linvunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ auxiso). cbn. rewrite id2_right. clear auxiso. apply runitor_rwhisker. Qed. Definition montrafotargetbicat_right_unitor: right_unitor montrafotargetbicat_tensor montrafotargetbicat_unit. Proof. use make_nat_z_iso. + use make_nat_trans. * intro vη. exists (monoidal_cat_right_unitor Mon_V (pr1 vη)). apply montrafotargetbicat_right_unitor_aux1. * intros vη vη' fg. use total2_paths_f. -- cbn. do 3 rewrite id_left. rewrite id_right. apply (nat_trans_ax (monoidal_cat_right_unitor Mon_V)). -- apply trafotargetbicat_disp_cells_isaprop. + intro vη. use make_is_z_isomorphism. * exists (pr1 (pr2 (monoidal_cat_right_unitor Mon_V) (pr1 vη))). apply montrafotargetbicat_right_unitor_aux2. * split. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_right_unitor Mon_V) (pr1 vη))). ++ apply trafotargetbicat_disp_cells_isaprop. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_right_unitor Mon_V) (pr1 vη))). ++ apply trafotargetbicat_disp_cells_isaprop. Defined. Lemma montrafotargetbicat_associator_aux1 (vηs : (montrafotargetbicat_cat ⊠ montrafotargetbicat_cat) ⊠ montrafotargetbicat_cat): pr2 (assoc_left montrafotargetbicat_tensor vηs) -->[monoidal_cat_associator Mon_V ((pr111 vηs,, pr121 vηs),, pr12 vηs)] pr2 (assoc_right montrafotargetbicat_tensor vηs). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vηs as [[[v1 η1] [v2 η2]] [v3 η3]]. cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 6 rewrite <- lwhisker_vcomp. do 6 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • (_ • (?Hl6 • (_ • (?Hl7 • ?Hl8)))))))))))) = _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (l7 := Hl7); set (l8 := Hl8) end. match goal with | [ |- _ = ?Hr1 • (?Hr2 • (_ • (?Hr3 • (_ • (?Hr4 • (_ • (?Hr5 • (_ • (?Hr6 • (_ • (?Hr7 • (_ • ?Hr8))))))))))))] => set (r1 := Hr1); set (r2 := Hr2); set (r3 := Hr3); set (r4 := Hr4); set (r5 := Hr5); set (r6 := Hr6); set (r7 := Hr7); set (r8 := Hr8) end. change (H v1 ==> H' v1) in η1; change (H v2 ==> H' v2) in η2; change (H v3 ==> H' v3) in η3. set (l1iso := lwhisker_with_μ_inv_inv2cell (v1 ⊗ v2) v3). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. match goal with | [ |- _ = ?Hl1inv • _] => set (l1inv := Hl1inv) end. etrans. { rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply rwhisker_lwhisker. } clear l2. etrans. { repeat rewrite <- vassocr. apply idpath. } match goal with | [ |- ?Hl2' • _ = _] => set (l2' := Hl2') end. cbn in l2'. set (l2'iso := rwhisker_lwhisker_with_μ_inv_inv2cell v1 v2 v3). apply (lhs_left_invert_cell _ _ _ l2'iso). cbn. clear l2' l2'iso. etrans. 2: { repeat rewrite vassocr. do 13 apply maponpaths_2. unfold l1inv, r1. do 2 rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := lax_monoidal_functor_assoc FA' v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. rewrite hcomp_identity_left, hcomp_identity_right in lax_monoidal_functor_assoc_inst. apply pathsinv0. unfold rassociator_fun' in lax_monoidal_functor_assoc_inst. cbn in lax_monoidal_functor_assoc_inst. exact lax_monoidal_functor_assoc_inst. } clear l1inv r1. etrans. 2: { do 13 apply maponpaths_2. do 2 rewrite <- lwhisker_vcomp. apply idpath. } etrans. 2: { do 12 apply maponpaths_2. repeat rewrite <- vassocr. do 2 apply maponpaths. unfold r2. rewrite lwhisker_vcomp. apply maponpaths. set (μFA'pointwise := nat_z_iso_pointwise_z_iso (strong_monoidal_functor_μ FA') (v1,, v2 ⊗ v3)). apply pathsinv0, (z_iso_inv_after_z_iso μFA'pointwise). } cbn. clear r2. rewrite lwhisker_id2. rewrite id2_right. etrans. 2: { do 10 apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. rewrite lwhisker_lwhisker. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } unfold hcomp. clear r3. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } match goal with | [ |- _ = _ • (_ • (?Hr1'' • (?Hr3' • _)))] => set (r1'' := Hr1''); set (r3' := Hr3') end. cbn in l5. (* lassociator (FA v1) (FA v2) G ▹ FA' v3 starts with FA v1 · (FA v2 · G) · FA' v3 l5 starts with FA v1 · FA v2 · G · FA' v3 FA v1 ◃ rassociator (FA v2) G ((pr11 FA') v3) starts with FA v1 · (FA v2 · G · (pr11 FA') v3) r6 starts with FA v1 · (FA v2 · H v3) *) match goal with | [ |- _ • ( _ • ( _ • ( _ • ( _ • ?Hltail)))) = _ • ( _ • ( _ • ( _ • ( _ • ( _ • ( _ • ( _ • ?Hrtail)))))))] => set (ltail := Hltail); set (rtail := Hrtail) end. assert (tailseq: lassociator (FA v1) (FA v2 · G) (FA' v3) • ltail = rtail). 2: { rewrite <- tailseq. repeat rewrite vassocr. apply maponpaths_2. clear l5 l6 l7 l8 r6 r7 r8 ltail rtail tailseq η3. (* l3 is close to r1'', l4 is close to r5, and r3' is close to the inverse of r4 - we first treat the latter *) etrans. 2: { repeat rewrite <- vassocr. do 3 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. rewrite <- vassocr. unfold r4. rewrite lwhisker_lwhisker_rassociator. rewrite vassocr. apply maponpaths_2. unfold r3'. rewrite lwhisker_vcomp. apply maponpaths. set (μFA'pointwise := nat_z_iso_pointwise_z_iso (strong_monoidal_functor_μ FA') (v2 ,, v3)). apply pathsinv0, (z_iso_inv_after_z_iso μFA'pointwise). } cbn. clear r3' r4. rewrite lwhisker_id2. rewrite id2_left. (* now plain reasoning in one bicategory *) etrans. 2: { repeat rewrite <- vassocr. do 5 apply maponpaths. apply pathsinv0, rwhisker_lwhisker. } clear r5. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. clear l4. assert (l3ok := rwhisker_rwhisker (FA' v2) (FA' v3) η1). apply (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in l3ok. cbn in l3ok. assert (l3okbetter: l3 = rassociator (G · (pr11 FA') v1) (FA' v2) (FA' v3) • (r1'' • lassociator ((pr11 FA) v1 · G) (FA' v2) (FA' v3))). { apply l3ok. } rewrite l3okbetter. clear l3 l3ok l3okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear r1'' ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply pathsinv0. assert (pentagon_inst := inverse_pentagon_5 (FA' v3) (FA' v2) ((pr11 FA') v1) G). (* now strangely complicated proof necessary *) cbn in pentagon_inst. etrans. { exact pentagon_inst. } repeat rewrite vassocr. do 2 apply maponpaths_2. induction FA' as [[F bla] laws]. apply idpath. (* to find the right pentagon law - there are: associativity_pentagon, pentagon, pentagon_2, inverse_pentagon, inverse_pentagon_2, inverse_pentagon_3, inverse_pentagon_4, inverse_pentagon_5, inverse_pentagon_6 *) } unfold ltail2, rtail2. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. clear ltail2 rtail2 η1 η2 r1''. assert (pentagon_inst := inverse_pentagon_4 (FA' v3) ((pr11 FA') v2) G ((pr11 FA) v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. exact pentagon_inst. } (* now the second half of the proof - however with no need for inversion of "monoidal" arrows *) clear l3 l4 r4 r5 r1'' r3' η1 η2. unfold ltail; clear ltail. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. unfold l5. rewrite rwhisker_rwhisker_alt. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l5 l6. unfold hcomp'. etrans. { do 2 apply maponpaths. repeat rewrite <- vassocr. do 2 apply maponpaths. repeat rewrite vassocr. do 2 apply maponpaths_2. apply pathsinv0, rwhisker_rwhisker. } etrans. { repeat rewrite <- vassocr. do 5 apply maponpaths. unfold l7, l8. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := lax_monoidal_functor_assoc FA v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. rewrite hcomp_identity_left, hcomp_identity_right in lax_monoidal_functor_assoc_inst. apply pathsinv0. unfold rassociator_fun' in lax_monoidal_functor_assoc_inst. cbn in lax_monoidal_functor_assoc_inst. rewrite <- vassocr in lax_monoidal_functor_assoc_inst. apply pathsinv0. exact lax_monoidal_functor_assoc_inst. } clear l7 l8. unfold rtail; clear rtail. do 2 rewrite <- rwhisker_vcomp. repeat rewrite vassocr. apply maponpaths_2. clear r8. etrans. 2: { repeat rewrite <- vassocr. do 3 apply maponpaths. apply pathsinv0, rwhisker_lwhisker. } clear r7. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. cbn. (* now plain reasoning in one bicategory *) assert (r6ok := lwhisker_lwhisker (FA v1) (FA v2) η3). apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in r6ok. cbn in r6ok. assert (r6okbetter: r6 = (lassociator (FA v1) (FA v2) (G · (pr11 FA') v3) • (FA v1 · FA v2 ◃ η3)) • rassociator (FA v1) (FA v2) ((pr11 FA) v3 · G)). { apply r6ok. } rewrite r6okbetter. clear r6 r6ok r6okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply pathsinv0. assert (pentagon_inst := inverse_pentagon_5 ((pr11 FA') v3) G (FA v2) (FA v1)). (* now strangely complicated proof necessary *) cbn in pentagon_inst. etrans. { exact pentagon_inst. } repeat rewrite vassocr. do 2 apply maponpaths_2. induction FA' as [[F bla] laws]. apply idpath. } unfold ltail2, rtail2. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. clear ltail2 rtail2 η3. assert (pentagon_inst := inverse_pentagon_4 G (FA v3) (FA v2) (FA v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. exact pentagon_inst. Qed. Lemma montrafotargetbicat_associator_aux2 (vηs : (montrafotargetbicat_cat ⊠ montrafotargetbicat_cat) ⊠ montrafotargetbicat_cat): pr2 (assoc_right montrafotargetbicat_tensor vηs) -->[pr1 (pr2 (monoidal_cat_associator Mon_V) ((pr111 vηs,, pr121 vηs),, pr12 vηs))] pr2 (assoc_left montrafotargetbicat_tensor vηs). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. induction vηs as [[[v1 η1] [v2 η2]] [v3 η3]]. cbn. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. rewrite hcomp_identity_left. rewrite hcomp_identity_right. do 6 rewrite <- lwhisker_vcomp. do 6 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • (_ • (?Hl6 • (_ • (?Hl7 • ?Hl8)))))))))))) = _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (l7 := Hl7); set (l8 := Hl8) end. match goal with | [ |- _ = ?Hr1 • (?Hr2 • (_ • (?Hr3 • (_ • (?Hr4 • (_ • (?Hr5 • (_ • (?Hr6 • (_ • (?Hr7 • (_ • ?Hr8))))))))))))] => set (r1 := Hr1); set (r2 := Hr2); set (r3 := Hr3); set (r4 := Hr4); set (r5 := Hr5); set (r6 := Hr6); set (r7 := Hr7); set (r8 := Hr8) end. change (H v1 ==> H' v1) in η1; change (H v2 ==> H' v2) in η2; change (H v3 ==> H' v3) in η3. (* cbn in * |- *. *) set (l8iso := rwhisker_with_invassociator_inv2cell v1 v2 v3). etrans. { repeat rewrite vassocr. apply idpath. } apply (lhs_right_invert_cell _ _ _ l8iso). cbn. match goal with | [ |- _ = _ • ?Hl8inv ] => set (l8inv := Hl8inv) end. clear l8 l8iso. etrans. 2: { repeat rewrite vassocr. do 3 apply maponpaths_2. repeat rewrite <- vassocr. do 9 apply maponpaths. rewrite vassocr. etrans. 2: { apply maponpaths_2. apply pathsinv0, rwhisker_rwhisker_alt. } cbn. repeat rewrite <- vassocr. apply maponpaths. apply pathsinv0, hcomp_hcomp'. } unfold hcomp'. clear r6 r7. etrans. 2: { repeat rewrite <- vassocr. do 11 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. rewrite <- vassocr. apply maponpaths. unfold r8, l8inv. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := lax_monoidal_functor_assoc FA v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. rewrite hcomp_identity_left, hcomp_identity_right in lax_monoidal_functor_assoc_inst. apply pathsinv0. unfold rassociator_fun' in lax_monoidal_functor_assoc_inst. cbn in lax_monoidal_functor_assoc_inst. rewrite <- vassocr in lax_monoidal_functor_assoc_inst. exact lax_monoidal_functor_assoc_inst. } clear r8 l8inv. do 2 rewrite <- rwhisker_vcomp. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. clear l7. etrans. { rewrite <- vassocr. apply maponpaths. apply rwhisker_lwhisker. } clear l6. repeat rewrite vassocr. apply maponpaths_2. cbn. match goal with | [ |- ((((?Hlhead • _) • _) • _) • _) • _ = (((((?Hrhead • _) • _) • _) • _) • _) • _ ] => set (lhead := Hlhead); set (rhead := Hrhead) end. assert (headsok: lhead = rhead • rassociator (FA v1) (G · (pr11 FA') v2) (FA' v3)). 2: { (* first deal with the reasoning confined to the bicategory *) rewrite headsok. repeat rewrite <- vassocr. apply maponpaths. clear η1 l1 l2 l3 r1 r2 r3 r4 lhead rhead headsok. etrans. { rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } etrans. { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear η2 l4 r5. (* now as for r6 in the proof of [montrafotargetbicat_associator_aux1] *) assert (l5ok := lwhisker_lwhisker (FA v1) (FA v2) η3). apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in l5ok. cbn in l5ok. assert (l5okbetter: l5 = (lassociator (FA v1) (FA v2) (G · (pr11 FA') v3) • (FA v1 · FA v2 ◃ η3)) • rassociator (FA v1) (FA v2) ((pr11 FA) v3 · G)). { apply l5ok. } rewrite l5okbetter. clear l5 l5ok l5okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. assert (pentagon_inst := inverse_pentagon_5 ((pr11 FA') v3) G (FA v2) (FA v1)). apply pathsinv0, (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in pentagon_inst. apply pathsinv0 in pentagon_inst. cbn in pentagon_inst. rewrite vassocr in pentagon_inst. exact pentagon_inst. } unfold ltail2, rtail2. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. clear ltail2 rtail2 η3. assert (pentagon_inst := inverse_pentagon_4 G (FA v3) (FA v2) (FA v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. apply pathsinv0 in pentagon_inst. exact pentagon_inst. } clear η2 η3 l4 l5 r5. (* now the second half of the proof - however with even more need for inversion of "monoidal" arrows *) unfold lhead. clear lhead. etrans. { apply maponpaths_2. repeat rewrite <- vassocr. do 2 apply maponpaths. unfold l3. rewrite lwhisker_lwhisker_rassociator. rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp'. clear l2 l3. cbn. unfold rhead. clear rhead. (* now as for l5 *) assert (r4ok := rwhisker_rwhisker (FA' v2) (FA' v3) η1). apply (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in r4ok. cbn in r4ok. assert (r4okbetter: r4 = rassociator (G · (pr11 FA') v1) (FA' v2) (FA' v3) • ((η1 ▹ FA' v2 · FA' v3) • lassociator ((pr11 FA) v1 · G) (FA' v2) (FA' v3))). { apply r4ok. } rewrite r4okbetter. clear r4 r4ok r4okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail3))) = _ • ( _ • ( _ • ( _ • (_ • ( _ • ( _ • ?Hrtail3))))))] => set (ltail3 := Hltail3); set (rtail3 := Hrtail3) end. assert (tails3eq: ltail3 = rtail3). { (* first deal with the reasoning confined to the bicategory *) unfold ltail3, rtail3. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply inverse_pentagon_4. } rewrite tails3eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear η1 ltail3 rtail3 tails3eq. etrans. 2: { do 2 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply rwhisker_lwhisker. } clear r3. etrans. { rewrite <- vassocr. apply maponpaths. apply pathsinv0, lwhisker_lwhisker. } repeat rewrite vassocr. unfold l1, r1, r2. do 3 rewrite lwhisker_vcomp. clear l1 r1 r2. match goal with | [ |- ?Hlhead2 • _ = ((?Hrhead2 • _) • _) • _ ] => set (lhead2 := Hlhead2); set (rhead2 := Hrhead2) end. assert (heads2ok: lhead2 = rhead2 • (G ◃ rassociator ((pr11 FA') v1) (FA' v2) (FA' v3))). 2: { (* first deal with the reasoning confined to the bicategory *) rewrite heads2ok. repeat rewrite <- vassocr. apply maponpaths. clear lhead2 rhead2 heads2ok. cbn. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply inverse_pentagon_5. } unfold rhead2. rewrite lwhisker_vcomp. apply maponpaths. clear lhead2 rhead2. assert (lax_monoidal_functor_assoc_inst := lax_monoidal_functor_assoc FA' v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. rewrite hcomp_identity_left, hcomp_identity_right in lax_monoidal_functor_assoc_inst. unfold rassociator_fun' in lax_monoidal_functor_assoc_inst. cbn in lax_monoidal_functor_assoc_inst. transparent assert (aux1iso : (invertible_2cell (FA' (v1 ⊗ (v2 ⊗ v3))) (FA' v1 · FA' (v2 ⊗ v3)))). { use make_invertible_2cell. - exact (strong_monoidal_functor_μ_inv FA' (v1,, tensor (v2,, v3))). - change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v1,, tensor (v2,, v3)))). apply is_z_isomorphism_inv. } apply (lhs_left_invert_cell _ _ _ aux1iso). cbn. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply pathsinv0, lassociator_to_rassociator_post. transparent assert (aux2iso : (invertible_2cell (FA' (v1 ⊗ v2) · FA' v3) ((FA' v1 · FA' v2) · FA' v3))). { use make_invertible_2cell. - exact ((strong_monoidal_functor_μ_inv FA' (v1,,v2)) ▹ FA' v3). - apply is_invertible_2cell_rwhisker. change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v1,, v2))). apply is_z_isomorphism_inv. } apply (lhs_right_invert_cell _ _ _ aux2iso). cbn. transparent assert (aux3iso : (invertible_2cell (FA' ((v1 ⊗ v2) ⊗ v3)) (FA' (v1 ⊗ v2) · FA' v3))). { use make_invertible_2cell. - exact (strong_monoidal_functor_μ_inv FA' (v1 ⊗ v2,, v3)). - change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v1 ⊗ v2,, v3))). apply is_z_isomorphism_inv. } apply (lhs_right_invert_cell _ _ _ aux3iso). cbn. transparent assert (aux4iso : (invertible_2cell ((pr11 FA') (v1 ⊗ (v2 ⊗ v3))) ((pr11 FA') ((v1 ⊗ v2) ⊗ v3)))). { use make_invertible_2cell. - exact (# (pr11 FA') (pr1 (pr2 (monoidal_cat_associator Mon_V) ((v1,, v2),, v3)))). - change (is_z_isomorphism (# (pr11 FA') (pr1 (pr2 (monoidal_cat_associator Mon_V) ((v1,, v2),, v3))))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator Mon_V) ((v1,, v2),, v3))). } apply (lhs_right_invert_cell _ _ _ aux4iso). cbn. repeat rewrite <- vassocr. transparent assert (aux5iso : (invertible_2cell ((pr11 FA') v1 · FA' (v2 ⊗ v3)) ((pr11 FA') v1 · (FA' v2 · FA' v3)))). { use make_invertible_2cell. - exact ((pr11 FA') v1 ◃ (strong_monoidal_functor_μ_inv FA' (v2,,v3))). - apply is_invertible_2cell_lwhisker. change (is_z_isomorphism (strong_monoidal_functor_μ_inv FA' (v2,, v3))). apply is_z_isomorphism_inv. } apply pathsinv0, (lhs_left_invert_cell _ _ _ aux5iso). cbn. clear aux1iso aux2iso aux3iso aux4iso aux5iso. apply pathsinv0, rassociator_to_lassociator_pre. apply pathsinv0. repeat rewrite vassocr. exact lax_monoidal_functor_assoc_inst. Qed. Definition montrafotargetbicat_associator: associator montrafotargetbicat_tensor. Proof. use make_nat_z_iso. + use make_nat_trans. * intro vηs. exists (monoidal_cat_associator Mon_V ((pr111 vηs,,pr121 vηs),,pr12 vηs)). apply montrafotargetbicat_associator_aux1. * intros vηs vηs' fgs. use total2_paths_f. -- cbn. repeat rewrite id_left. repeat rewrite id_right. exact (pr21 (monoidal_cat_associator Mon_V) ((pr111 vηs,, pr121 vηs),, pr12 vηs) ((pr111 vηs',, pr121 vηs'),, pr12 vηs') ((pr111 fgs,, pr121 fgs),, pr12 fgs)). -- apply trafotargetbicat_disp_cells_isaprop. + intro vηs. use make_is_z_isomorphism. * exists (pr1 (pr2 (monoidal_cat_associator Mon_V) ((pr111 vηs,, pr121 vηs),, pr12 vηs))). apply montrafotargetbicat_associator_aux2. * split. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_associator Mon_V) ((pr111 vηs,, pr121 vηs),, pr12 vηs))). ++ apply trafotargetbicat_disp_cells_isaprop. -- use total2_paths_f. ++ cbn. apply (pr2 (pr2 (monoidal_cat_associator Mon_V) ((pr111 vηs,, pr121 vηs),, pr12 vηs))). ++ apply trafotargetbicat_disp_cells_isaprop. Defined. Lemma montrafotargetbicat_triangle_eq: triangle_eq montrafotargetbicat_tensor montrafotargetbicat_unit montrafotargetbicat_left_unitor montrafotargetbicat_right_unitor montrafotargetbicat_associator. Proof. intros vη wη'. use total2_paths_f. + cbn. repeat rewrite id_left. repeat rewrite id_right. assert (triangleinst := monoidal_cat_triangle_eq Mon_V (pr1 vη) (pr1 wη')). exact triangleinst. + apply trafotargetbicat_disp_cells_isaprop. Qed. Lemma montrafotargetbicat_pentagon_eq: pentagon_eq montrafotargetbicat_tensor montrafotargetbicat_associator. Proof. intros vη1 vη2 vη3 vη4. use total2_paths_f. + cbn. repeat rewrite id_left. repeat rewrite id_right. assert (pentagoninst := monoidal_cat_pentagon_eq Mon_V (pr1 vη1) (pr1 vη2) (pr1 vη3) (pr1 vη4)). exact pentagoninst. + apply trafotargetbicat_disp_cells_isaprop. Qed. Definition montrafotargetbicat_moncat: monoidal_cat := make_monoidal_cat montrafotargetbicat_cat montrafotargetbicat_tensor montrafotargetbicat_unit montrafotargetbicat_left_unitor montrafotargetbicat_right_unitor montrafotargetbicat_associator montrafotargetbicat_triangle_eq montrafotargetbicat_pentagon_eq. Section IntoMonoidalFunctorBicat. Definition parameterized_distributivity_bicat_nat : UU := H ⟹ H'. Definition parameterized_distributivity_bicat_nat_funclass (δ : parameterized_distributivity_bicat_nat): ∏ v : ob (Mon_V), H v --> H' v := pr1 δ. Coercion parameterized_distributivity_bicat_nat_funclass : parameterized_distributivity_bicat_nat >-> Funclass. Context (δ: parameterized_distributivity_bicat_nat). Definition param_distr_bicat_triangle_eq_variant0: UU := δ I = param_distr_bicat_triangle_eq_variant0_RHS. Definition param_distr_bicat_pentagon_eq_variant: UU := ∏ (v w : Mon_V), δ (v ⊗ w) = param_distr_bicat_pentagon_eq_body_variant_RHS v w (δ v) (δ w). Context (δtr_eq: param_distr_bicat_triangle_eq_variant0) (δpe_eq: param_distr_bicat_pentagon_eq_variant). Definition lmf_from_param_distr_bicat_functor: Mon_V ⟶ montrafotargetbicat_moncat. Proof. apply (nat_trafo_to_functor_bicat _ _ H H' δ). Defined. (** we come to an important element of the whole construction - the triangle law enters here *) Lemma lmf_from_param_distr_bicat_ε_aux: pr2 (MonoidalFunctorsTensored.I_D montrafotargetbicat_moncat) -->[ id pr1 (MonoidalFunctorsTensored.I_D montrafotargetbicat_moncat)] pr2 (lmf_from_param_distr_bicat_functor (MonoidalFunctorsTensored.I_C Mon_V)). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. do 2 rewrite functor_id. rewrite id_right. rewrite id_left. apply pathsinv0. exact δtr_eq. Qed. Definition lmf_from_param_distr_bicat_ε: pr1 montrafotargetbicat_moncat ⟦ MonoidalFunctorsTensored.I_D montrafotargetbicat_moncat, lmf_from_param_distr_bicat_functor (MonoidalFunctorsTensored.I_C Mon_V) ⟧ := (identity _),, lmf_from_param_distr_bicat_ε_aux. (** we come to the crucial element of the whole construction - the pentagon law enters here *) Lemma lmf_from_param_distr_bicat_μ_aux (vw : Mon_V ⊠ Mon_V): pr2 (monoidal_functor_map_dom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor vw) -->[id pr1 (monoidal_functor_map_dom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor vw)] pr2 (monoidal_functor_map_codom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor vw). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. red in δpe_eq. do 2 rewrite functor_id. rewrite id_left, id_right. assert (δpe_eqinst := δpe_eq (pr1 vw) (pr2 vw)). apply pathsinv0. exact δpe_eqinst. Qed. Definition lmf_from_param_distr_bicat_μ_data: nat_trans_data (monoidal_functor_map_dom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor) (monoidal_functor_map_codom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor). Proof. intro vw. exists (identity _). apply lmf_from_param_distr_bicat_μ_aux. Defined. Lemma lmf_from_param_distr_bicat_μ_data_is_nat: is_nat_trans _ _ lmf_from_param_distr_bicat_μ_data. Proof. intros vw vw' fg. use total2_paths_f. - cbn. repeat rewrite id_left. repeat rewrite id_right. apply idpath. - apply trafotargetbicat_disp_cells_isaprop. Qed. Definition lmf_from_param_distr_bicat_μ: monoidal_functor_map Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor := lmf_from_param_distr_bicat_μ_data ,, lmf_from_param_distr_bicat_μ_data_is_nat. Lemma lmf_from_param_distr_bicat_assoc: monoidal_functor_associativity Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor lmf_from_param_distr_bicat_μ. Proof. intros u v w. use total2_paths_f. * cbn. repeat rewrite id_right. etrans. { apply cancel_postcomposition. apply maponpaths. exact (binprod_id (u ⊗ v) w). } rewrite (functor_id tensor). etrans. 2: { do 2 apply maponpaths. apply pathsinv0, binprod_id. } rewrite (functor_id tensor). rewrite id_right. apply id_left. * apply trafotargetbicat_disp_cells_isaprop. Qed. Lemma lmf_from_param_distr_bicat_unital: monoidal_functor_unitality Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat_functor lmf_from_param_distr_bicat_ε lmf_from_param_distr_bicat_μ. Proof. intro v. split. - use total2_paths_f. + cbn. repeat rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0, binprod_id. } rewrite (functor_id tensor). apply pathsinv0, id_left. + apply trafotargetbicat_disp_cells_isaprop. - use total2_paths_f. + cbn. repeat rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0, binprod_id. } rewrite (functor_id tensor). apply pathsinv0, id_left. + apply trafotargetbicat_disp_cells_isaprop. Qed. Definition lmf_from_param_distr_bicat: lax_monoidal_functor Mon_V montrafotargetbicat_moncat := make_lax_monoidal_functor _ _ lmf_from_param_distr_bicat_functor lmf_from_param_distr_bicat_ε lmf_from_param_distr_bicat_μ lmf_from_param_distr_bicat_assoc lmf_from_param_distr_bicat_unital. (* now similar but not identical code to above for triangle *) Lemma smf_from_param_distr_bicat_is_strong1_aux: pr2 (lmf_from_param_distr_bicat (MonoidalFunctorsTensored.I_C Mon_V)) -->[id I] pr2 (MonoidalFunctorsTensored.I_D montrafotargetbicat_moncat). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. do 2 rewrite functor_id. rewrite id_right. rewrite id_left. exact δtr_eq. Qed. Definition smf_from_param_distr_bicat_is_strong1_inv: pr1 montrafotargetbicat_moncat ⟦ lmf_from_param_distr_bicat (MonoidalFunctorsTensored.I_C Mon_V), MonoidalFunctorsTensored.I_D montrafotargetbicat_moncat ⟧. Proof. exists (identity I). apply smf_from_param_distr_bicat_is_strong1_aux. Defined. Lemma smf_from_param_distr_bicat_is_strong1_inv_ok: is_inverse_in_precat (lax_monoidal_functor_ϵ lmf_from_param_distr_bicat) smf_from_param_distr_bicat_is_strong1_inv. Proof. split. - use total2_paths_f. + cbn. apply id_right. + apply trafotargetbicat_disp_cells_isaprop. - use total2_paths_f. + cbn. apply id_right. + apply trafotargetbicat_disp_cells_isaprop. Qed. Definition smf_from_param_distr_bicat_is_strong1: is_z_isomorphism (lax_monoidal_functor_ϵ lmf_from_param_distr_bicat) := smf_from_param_distr_bicat_is_strong1_inv ,, smf_from_param_distr_bicat_is_strong1_inv_ok. (* now similar but not identical code to above for pentagon *) Lemma smf_from_param_distr_bicat_is_strong2_aux (vw : Mon_V ⊠ Mon_V): pr2 (monoidal_functor_map_codom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat vw) -->[id pr1 (monoidal_functor_map_codom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat vw)] pr2 (monoidal_functor_map_dom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat vw). Proof. unfold mor_disp. unfold trafotargetbicat_disp. hnf. red in δpe_eq. do 2 rewrite functor_id. rewrite id_left, id_right. cbn. assert (δpe_eqinst := δpe_eq (pr1 vw) (pr2 vw)). exact δpe_eqinst. Qed. Definition smf_from_param_distr_bicat_is_strong2_inv (vw : Mon_V ⊠ Mon_V): montrafotargetbicat_moncat ⟦ monoidal_functor_map_codom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat vw, monoidal_functor_map_dom Mon_V montrafotargetbicat_moncat lmf_from_param_distr_bicat vw ⟧. Proof. exists (identity _). apply smf_from_param_distr_bicat_is_strong2_aux. Defined. Lemma smf_from_param_distr_bicat_is_strong2_inv_ok (vw : Mon_V ⊠ Mon_V): is_inverse_in_precat (lax_monoidal_functor_μ lmf_from_param_distr_bicat vw) (smf_from_param_distr_bicat_is_strong2_inv vw). Proof. split. - use total2_paths_f. + cbn. apply id_right. + apply trafotargetbicat_disp_cells_isaprop. - use total2_paths_f. + cbn. apply id_right. + apply trafotargetbicat_disp_cells_isaprop. Qed. Definition smf_from_param_distr_bicat_is_strong2: is_nat_z_iso (lax_monoidal_functor_μ lmf_from_param_distr_bicat) := fun vw => (smf_from_param_distr_bicat_is_strong2_inv vw ,, smf_from_param_distr_bicat_is_strong2_inv_ok vw). Definition smf_from_param_distr_bicat_parts: strong_monoidal_functor Mon_V montrafotargetbicat_moncat := lmf_from_param_distr_bicat,, (smf_from_param_distr_bicat_is_strong1 ,, smf_from_param_distr_bicat_is_strong2). End IntoMonoidalFunctorBicat. (* parameterized_distributivity_bicat not yet defined (taking into account the variants!) Definition smf_from_param_distr_bicat: parameterized_distributivity_bicat -> strong_monoidal_functor Mon_V montrafotargetbicat_moncat. Proof. intro δs. induction δs as [δ [δtr_eq δpe_eq]]. exact (smf_from_param_distr_parts_bicat δ δtr_eq δpe_eq). Defined. *) End FunctorViaBicat. Section Functor. Context {A A': category}. Context (FA: strong_monoidal_functor Mon_V (monoidal_cat_of_endofunctors A)). Context (FA': strong_monoidal_functor Mon_V (monoidal_cat_of_endofunctors A')). Context (G : A ⟶ A'). Local Definition precompG : [A', A'] ⟶ [A, A'] := pre_composition_functor _ A' A' G. Local Definition postcompG {C: category} : [C, A] ⟶ [C, A'] := post_composition_functor C A A' G. Let H : Mon_V ⟶ [A, A'] := param_distributivity_dom Mon_V _ _ FA' G. Let H': Mon_V ⟶ [A, A'] := param_distributivity_codom Mon_V _ _ FA G. Definition montrafotarget_disp: disp_cat Mon_V := trafotargetbicat_disp(C0:=Mon_V)(C:=bicat_of_cats) A A' H H'. Definition montrafotarget_cat: category := trafotargetbicat_cat(C0:=Mon_V)(C:=bicat_of_cats) A A' H H'. Definition montrafotarget_moncat: monoidal_cat := montrafotargetbicat_moncat(C:=bicat_of_cats)(a0:=A)(a0':=A') FA FA' G. Definition parameterized_distributivity_nat_as_instance (δtr: parameterized_distributivity_nat Mon_V A A' FA FA' G): parameterized_distributivity_bicat_nat FA FA' G. Proof. red. red in δtr. unfold Main.H, Main.H'. unfold param_distributivity_dom, param_distributivity_codom in δtr. use make_nat_trans. - exact (pr1 δtr). - intros v w f. cbn. set (δtr_nat_inst := pr2 δtr v w f). cbn in δtr_nat_inst. unfold pre_whisker_in_funcat, post_whisker_in_funcat in δtr_nat_inst. rewrite post_whisker_identity. rewrite pre_whisker_identity. rewrite (nat_trans_comp_id_left A' (functor_composite G ((pr11 FA') v)) (functor_composite G ((pr11 FA') w))). rewrite (nat_trans_comp_id_right A' (functor_composite ((pr11 FA) v) G) (functor_composite ((pr11 FA) w) G)). exact δtr_nat_inst. Defined. Definition smf_from_param_distr: parameterized_distributivity Mon_V A A' FA FA' G -> strong_monoidal_functor Mon_V montrafotarget_moncat. Proof. intro δs. induction δs as [δ [δtr_eq δpe_eq]]. use smf_from_param_distr_bicat_parts. - exact (parameterized_distributivity_nat_as_instance δ). - apply param_distr_triangle_eq_variant0_follows in δtr_eq. red in δtr_eq |- *. unfold param_distr_triangle_eq_variant0_RHS in δtr_eq. unfold param_distr_bicat_triangle_eq_variant0_RHS. cbn in δtr_eq |- *. unfold pre_whisker_in_funcat, post_whisker_in_funcat in δtr_eq. etrans. { exact δtr_eq. } apply maponpaths. rewrite (nat_trans_comp_id_right A' (functor_composite G (functor_identity A')) G). show_id_type. apply (nat_trans_eq A'). intro a. cbn. apply pathsinv0, id_left. - intros v w. set (δpe_eq_inst := δpe_eq v w). apply param_distr_pentagon_eq_body_variant_follows in δpe_eq_inst. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. unfold param_distr_pentagon_eq_body_variant, param_distr_pentagon_eq_body_variant_RHS in δpe_eq_inst. cbn in δpe_eq_inst |- *. etrans. { exact δpe_eq_inst. } clear δpe_eq_inst. apply maponpaths. apply (nat_trans_eq A'). intro a. cbn. do 3 rewrite id_left. apply idpath. Defined. End Functor. End Main. ActionBasedStrongFunctorsWhiskeredMonoidal.v000066400000000000000000002425351451125700300335750ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories(** shows that action-based strong functors can be perceived as strong monoidal functors from the monoidal category that is acting on the underlying categories to a suitable monoidal category This means that the requirement on strength is that it behaves as a ``homomorphism'' w.r.t. the monoidal structures. More precisely, we construct transformations in both directions between parameterized distributivity (in a slightly massaged form to accommodate reasoning through bicategories) and displayed sections that are a formalization-friendly form of strong monoidal functors that are right inverses of the projection from the target displayed category. The result makes use of displayed monoidal categories. The non-monoidal basic situation is now presented in [UniMath.CategoryTheory.categories.Dialgebras]. Author: Ralph Matthes 2021, 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalSections. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Import Bicat.Notations. Import BifunctorNotations. Import DisplayedBifunctorNotations. Import MonoidalNotations. Local Open Scope cat. Section UpstreamInBicat. Context {C0 : category}. (** an "ordinary" category for the source *) Context {C : bicat}. Context (a a' : ob C). Context (H H' : C0 ⟶ hom a a'). Definition trafotargetbicat_disp: disp_cat C0 := dialgebra_disp_cat H H'. Lemma trafotargetbicat_disp_cells_isaprop (x y : C0) (f : C0 ⟦ x, y ⟧) (xx : trafotargetbicat_disp x) (yy : trafotargetbicat_disp y): isaprop (xx -->[ f] yy). Proof. intros Hyp Hyp'. apply (hom a a'). Qed. Definition trafotargetbicat_cat: category := total_category trafotargetbicat_disp. Definition forget_from_trafotargetbicat: trafotargetbicat_cat ⟶ C0 := pr1_category trafotargetbicat_disp. Definition nat_trans_to_section_bicat (η: H ⟹ H'): @section_disp C0 trafotargetbicat_disp := nat_trans_to_section H H' η. Definition section_to_nat_trans_bicat: @section_disp C0 trafotargetbicat_disp -> H ⟹ H' := section_to_nat_trans H H'. End UpstreamInBicat. Section Main. Context {V : category}. Context (Mon_V : monoidal V). Notation "X ⊗ Y" := (X ⊗_{ Mon_V } Y). Section ActionViaBicat. Context {C : bicat}. Context (a0 : ob C). Context {FA: functor V (category_from_bicat_and_ob a0)}. Context (FAm: fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA). (** currently no development on the abstract level *) End ActionViaBicat. Section FunctorViaBicat. Context {C : bicat}. Context {a0 a0' : ob C}. Context {FA: functor V (category_from_bicat_and_ob a0)}. Context {FA': functor V (category_from_bicat_and_ob a0')}. Context (FAm: fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA). Context (FA'm: fmonoidal Mon_V (monoidal_from_bicat_and_ob a0') FA'). Context (G : hom a0 a0'). Definition H : functor V (hom a0 a0') := functor_compose FA' (lwhisker_functor G). Definition H' : functor V (hom a0 a0') := functor_compose FA (rwhisker_functor G). Lemma Hok (v: V) : H v = G · FA' v. Proof. apply idpath. Defined. Lemma Hmorok (v v': V) (f: v --> v'): # H f = G ◃ # FA' f. Proof. apply idpath. Qed. Lemma H'ok (v: V) : H' v = FA v · G. Proof. apply idpath. Defined. Lemma H'morok (v v': V) (f: v --> v'): # H' f = # FA f ▹ G. Proof. apply idpath. Qed. Definition montrafotargetbicat_disp: disp_cat V := trafotargetbicat_disp a0 a0' H H'. Definition montrafotargetbicat_cat: category := trafotargetbicat_cat a0 a0' H H'. Definition param_distr_bicat_triangle_eq_variant0_RHS : trafotargetbicat_disp a0 a0' H H' I_{Mon_V} := G ◃ (pr1 (fmonoidal_preservesunitstrongly FA'm)) • (((runitor G : G · I_{ monoidal_from_bicat_and_ob a0'} ==> G) • (linvunitor G : G ==> I_{ monoidal_from_bicat_and_ob a0} · G)) • ((fmonoidal_preservesunit FAm) ▹ G)). (* Proof. set (t1 := lwhisker G (pr1 (fmonoidal_preservesunitstrongly FA'm))). set (t2 := rwhisker G (fmonoidal_preservesunit FAm)). refine (vcomp2 t1 _). refine (vcomp2 _ t2). apply (vcomp2(g:=G)). - cbn. apply runitor. - cbn. apply linvunitor. Defined. *) Definition montrafotargetbicat_disp_unit: montrafotargetbicat_disp I_{Mon_V} := param_distr_bicat_triangle_eq_variant0_RHS. Definition montrafotargetbicat_unit: montrafotargetbicat_cat := I_{Mon_V},, montrafotargetbicat_disp_unit. Definition param_distr_bicat_pentagon_eq_body_RHS (v w : V) (dv: montrafotargetbicat_disp v) (dw: montrafotargetbicat_disp w) : H v · FA' w ==> FA (v ⊗ w) · G := ((dv ▹ FA' w) • ((rassociator (FA v) G (FA' w) : H' v · FA' w ==> FA v · H w) • (FA v ◃ dw))) • ((lassociator (FA v) (FA w) G : FA v · H' w ==> FA v ⊗_{ monoidal_from_bicat_and_ob a0} FA w · G) • (fmonoidal_preservestensordata FAm v w ▹ G)). (* Proof. set (aux1 := rwhisker (FA' w) dv). set (aux2 := lwhisker (FA v) dw). transparent assert (auxr : (H v · FA' w ==> FA v · H' w)). { refine (vcomp2 aux1 _). refine (vcomp2 _ aux2). cbn. apply rassociator. } set (aux3 := rwhisker G (fmonoidal_preservestensordata FAm v w)). refine (vcomp2 auxr _). refine (vcomp2 _ aux3). cbn. apply lassociator. Defined. *) Definition param_distr_bicat_pentagon_eq_body_variant_RHS (v w : V) (dv: montrafotargetbicat_disp v) (dw: montrafotargetbicat_disp w) : montrafotargetbicat_disp (v ⊗ w) := (G ◃ pr1 (fmonoidal_preservestensorstrongly FA'm v w)) • ((lassociator G (FA' v) (FA' w) : G · FA' v ⊗_{ monoidal_from_bicat_and_ob a0'} FA' w ==> H v · FA' w) • param_distr_bicat_pentagon_eq_body_RHS v w dv dw). (* Proof. set (aux1inv := lwhisker G (pr1 (fmonoidal_preservestensorstrongly FA'm v w))). refine (vcomp2 aux1inv _). refine (vcomp2 _ (param_distr_bicat_pentagon_eq_body_RHS v w dv dw)). cbn. apply lassociator. Defined. *) (** a number of auxiliary isomorphisms to ease the lemmas on arrow reversion *) Definition lwhisker_with_μ_inv_inv2cell (v w : V): invertible_2cell (G · FA' (v ⊗ w)) (G · (FA' v · FA' w)). Proof. use make_invertible_2cell. - exact (lwhisker G (pr1 (fmonoidal_preservestensorstrongly FA'm v w))). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm v w))). apply is_z_isomorphism_inv. Defined. Definition rwhisker_lwhisker_with_μ_inv_inv2cell (v1 v2 v3 : V): invertible_2cell (G · (FA' (v1 ⊗ v2) · FA' v3)) (G · (FA' v1 · FA' v2 · FA' v3)). Proof. use make_invertible_2cell. - exact (G ◃ (pr1 (fmonoidal_preservestensorstrongly FA'm v1 v2) ▹ FA' v3)). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm v1 v2))). apply is_z_isomorphism_inv. Defined. Definition lwhisker_rwhisker_with_ϵ_inv_inv2cell (v : V): invertible_2cell (G · FA' I_{Mon_V} · FA' v) (G · id₁ a0' · FA' v). Proof. use make_invertible_2cell. - exact ((G ◃ pr1 (fmonoidal_preservesunitstrongly FA'm)) ▹ FA' v). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservesunitstrongly FA'm))). apply is_z_isomorphism_inv. Defined. Definition rwhisker_with_linvunitor_inv2cell (v : V): invertible_2cell (G · FA' v) (id₁ a0 · G · FA' v). Proof. use make_invertible_2cell. - exact (linvunitor G ▹ FA' v). - is_iso. Defined. Definition lwhisker_with_linvunitor_inv2cell (v : V): invertible_2cell (FA v · G) (FA v · (id₁ a0 · G)). Proof. use make_invertible_2cell. - exact (FA v ◃ linvunitor G). - is_iso. Defined. Definition lwhisker_with_invlunitor_inv2cell (v : V): invertible_2cell (G · (pr11 FA') v) (G · (pr11 FA') (I_{Mon_V} ⊗ v)). Proof. use make_invertible_2cell. - exact (G ◃ # FA' (pr1 (pr2 (leftunitor_nat_z_iso Mon_V) v))). - is_iso. change (is_z_isomorphism (# FA' (pr1 (pr2 (leftunitor_nat_z_iso Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (leftunitor_nat_z_iso Mon_V) v)). Defined. Definition rwhisker_with_invlunitor_inv2cell (v : V): invertible_2cell (FA v · G) (FA (I_{Mon_V} ⊗ v) · G). Proof. use make_invertible_2cell. - exact (# FA (pr1 (pr2 (leftunitor_nat_z_iso Mon_V) v)) ▹ G). - is_iso. change (is_z_isomorphism (# FA (pr1 (pr2 (leftunitor_nat_z_iso Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (leftunitor_nat_z_iso Mon_V) v)). Defined. Definition lwhisker_with_invrunitor_inv2cell (v : V): invertible_2cell (G · FA' v) (G · FA'(v ⊗ I_{Mon_V})). Proof. use make_invertible_2cell. - exact (G ◃ # FA' (pr1 (pr2 (rightunitor_nat_z_iso Mon_V) v))). - is_iso. change (is_z_isomorphism (# FA' (pr1 (pr2 (rightunitor_nat_z_iso Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (rightunitor_nat_z_iso Mon_V) v)). Defined. Definition rwhisker_with_invrunitor_inv2cell (v : V): invertible_2cell (FA v · G) (FA (v ⊗ I_{Mon_V}) · G). Proof. use make_invertible_2cell. - exact (# FA (pr1 (pr2 (rightunitor_nat_z_iso Mon_V) v)) ▹ G). - is_iso. change (is_z_isomorphism (# FA (pr1 (pr2 (rightunitor_nat_z_iso Mon_V) v)))). apply functor_on_is_z_isomorphism. apply (is_z_iso_inv_from_z_iso (nat_z_iso_pointwise_z_iso (rightunitor_nat_z_iso Mon_V) v)). Defined. Definition lwhisker_with_ϵ_inv2cell (v : V): invertible_2cell (FA' v · id₁ a0') (FA' v · FA' I_{Mon_V}). Proof. use make_invertible_2cell. - exact (FA' v ◃ fmonoidal_preservesunit FA'm). - is_iso. change (is_z_isomorphism (fmonoidal_preservesunit FA'm)). apply fmonoidal_preservesunitstrongly. Defined. Definition lwhisker_with_ϵ_inv2cell_bis: invertible_2cell (G · FA' I_{ Mon_V}) (G · I_{ monoidal_from_bicat_and_ob a0'}). Proof. use make_invertible_2cell. - exact (G ◃ pr1 (fmonoidal_preservesunitstrongly FA'm)). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservesunitstrongly FA'm))). apply is_z_isomorphism_inv. Defined. Definition rwhisker_with_invassociator_inv2cell (v1 v2 v3 : V): invertible_2cell (FA (v1 ⊗ (v2 ⊗ v3)) · G) (FA ((v1 ⊗ v2) ⊗ v3) · G). Proof. use make_invertible_2cell. - exact (# FA (αinv_{Mon_V} v1 v2 v3) ▹ G). - is_iso. change (is_z_isomorphism (# FA (αinv_{Mon_V} v1 v2 v3))). apply functor_on_is_z_isomorphism. exists (α_{Mon_V} v1 v2 v3). destruct (monoidal_associatorisolaw Mon_V v1 v2 v3). split; assumption. Defined. (** end of auxiliary definitions of isomorphisms *) (** the main lemma for the construction of the tensor - for reasons of exploiting legacy code, this is the general lemma and not its two instances that come right afterwards *) Lemma montrafotargetbicat_tensor_comp_aux (v w v' w': V) (f: V⟦v,v'⟧) (g: V⟦w,w'⟧) (η : montrafotargetbicat_disp v) (π : montrafotargetbicat_disp w) (η' : montrafotargetbicat_disp v') (π' : montrafotargetbicat_disp w') (Hyp: η -->[ f] η') (Hyp': π -->[ g] π'): param_distr_bicat_pentagon_eq_body_variant_RHS v w η π -->[ f ⊗^{Mon_V} g] param_distr_bicat_pentagon_eq_body_variant_RHS v' w' η' π'. Proof. hnf in Hyp, Hyp' |- *. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. match goal with | [ |- (?Hαinv • (?Hassoc1 • ((?Hγ • (?Hassoc2 • ?Hδ)) • (?Hassoc3 • ?Hβ)))) · ?Hε = _ ] => set (αinv := Hαinv); set (γ := Hγ); set (δ:= Hδ); set (β := Hβ); set (ε1 := Hε) end. cbn in αinv, β. match goal with | [ |- _ = ?Hε · (?Hαinv • (?Hassoc4 • ((?Hγ • (?Hassoc5 • ?Hδ) • (?Hassoc6 • ?Hβ))))) ] => set (αinv' := Hαinv); set (γ' := Hγ); set (δ':= Hδ); set (β' := Hβ); set (ε2 := Hε) end. cbn in αinv', β'. set (αinviso := lwhisker_with_μ_inv_inv2cell v w). cbn in αinviso. etrans. { apply pathsinv0. apply vassocr. } apply (lhs_left_invert_cell _ _ _ αinviso). apply pathsinv0. unfold inv_cell. set (α := lwhisker G (fmonoidal_preservestensordata FA'm v w)). cbn in α. match goal with | [ |- ?Hαcand • _ = _ ] => set (αcand := Hαcand) end. change αcand with α. clear αcand. assert (μFA'natinst := full_naturality_condition (pr2 (preservestensor_is_nattrans (fmonoidal_preservestensornatleft FA'm) (fmonoidal_preservestensornatright FA'm))) f g). cbn in μFA'natinst. unfold make_binat_trans_data in μFA'natinst. assert (μFAnatinst := full_naturality_condition (pr2 (preservestensor_is_nattrans (fmonoidal_preservestensornatleft FAm) (fmonoidal_preservestensornatright FAm))) f g). cbn in μFAnatinst. unfold make_binat_trans_data in μFAnatinst. unfold H in ε2. cbn in ε2. etrans. { apply vassocr. } apply (maponpaths (lwhisker G)) in μFA'natinst. apply pathsinv0 in μFA'natinst. etrans. { apply maponpaths_2. apply lwhisker_vcomp. } etrans. { apply maponpaths_2. unfold functoronmorphisms1. rewrite (functor_comp FA'). exact μFA'natinst. } clear ε2 μFA'natinst. etrans. { apply maponpaths_2. apply pathsinv0. apply lwhisker_vcomp. } etrans. { apply pathsinv0. apply vassocr. } etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. unfold αinv'. apply lwhisker_vcomp. } etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply (pr12 (fmonoidal_preservestensorstrongly FA'm v' w')). } clear αinv αinv' αinviso α. unfold H' in ε1. cbn in ε1. cbn. rewrite lwhisker_id2. rewrite id2_left. match goal with | [ |- ?Hσ • _ = _ ] => set (σ' := Hσ) end. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply (maponpaths (rwhisker G)) in μFAnatinst. etrans. 2: { do 5 apply maponpaths. apply pathsinv0. apply rwhisker_vcomp. } etrans. 2: { do 5 apply maponpaths. unfold functoronmorphisms1. rewrite (functor_comp FA). exact μFAnatinst. } clear β μFAnatinst ε1. etrans. 2: { do 5 apply maponpaths. apply rwhisker_vcomp. } match goal with | [ |- _ = _ • (_ • (_ • (_ • (_ • (_ • ?Hβ'twin))))) ] => set (β'twin := Hβ'twin) end. change β'twin with β'. clear β'twin. repeat rewrite vassocr. apply maponpaths_2. clear β'. unfold σ'. assert (hcomp_aux:= hcomp_hcomp' (# FA' f) (# FA' g)). unfold hcomp, hcomp' in hcomp_aux. etrans. { do 5 apply maponpaths_2. apply maponpaths. apply hcomp_aux. } clear hcomp_aux σ'. rewrite <- lwhisker_vcomp. match goal with | [ |- (((((?Hσ'1 • ?Hσ'2) • _) • _) • _) • _) • _ = _ • ?Hσ ] => set (σ'1 := Hσ'1); set (σ'2 := Hσ'2); set (σ := Hσ) end. change (η • # H' f = # H f • η') in Hyp. apply (maponpaths (rwhisker (FA' w'))) in Hyp. do 2 rewrite <- rwhisker_vcomp in Hyp. apply pathsinv0 in Hyp. assert (Hypvariant: σ'2 • lassociator G (FA' v') (FA' w') • γ' = lassociator G (FA' v) (FA' w') • (rwhisker (FA' w') η • rwhisker (FA' w') (# H' f))). { apply (maponpaths (vcomp2 (lassociator G (FA' v) (FA' w')))) in Hyp. etrans. 2: { exact Hyp. } rewrite vassocr. apply maponpaths_2. rewrite Hmorok. apply rwhisker_lwhisker. } clear Hyp. intermediate_path (σ'1 • ((σ'2 • lassociator G (FA' v') (FA' w')) • γ') • rassociator (FA v') G (FA' w') • δ' • lassociator (FA v') (FA w') G). { repeat rewrite <- vassocr. apply idpath. } rewrite Hypvariant. clear σ'2 γ' Hypvariant. (* until here mostly in parallel with earlier proof in CAT *) assert (σ'1ok : σ'1 • lassociator G (FA' v) (FA' w') = lassociator G (FA' v) (FA' w) • (H v ◃ # FA' g)). (* associators needed in addition to devel. in CAT *) { apply lwhisker_lwhisker. } etrans. { repeat rewrite vassocr. rewrite σ'1ok. apply idpath. } clear σ'1 σ'1ok. repeat rewrite <- vassocr. apply maponpaths. etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. apply pathsinv0. apply hcomp_hcomp'. } unfold hcomp. repeat rewrite <- vassocr. apply maponpaths. clear γ. change (π • # H' g = # H g • π') in Hyp'. apply (maponpaths (lwhisker (FA v))) in Hyp'. do 2 rewrite <- lwhisker_vcomp in Hyp'. rewrite H'morok in Hyp'. assert (Hyp'variant: δ • lassociator (FA v) (FA w) G • ((FA v ◃ # FA g) ▹ G) = ((FA v ◃ # H g) • (FA v ◃ π')) • lassociator (FA v) (FA w') G). (* close to what was called Hypvariant in the devel. in CAT *) { apply (maponpaths (fun x => x • lassociator (FA v) (FA w') G)) in Hyp'. etrans. { rewrite <- vassocr. apply maponpaths. apply pathsinv0. apply rwhisker_lwhisker. } rewrite vassocr. exact Hyp'. } clear Hyp'. set (σbetter := hcomp' (# FA f) (# FA g) ▹ G). assert (σbetterok : σ = σbetter). { apply maponpaths. apply hcomp_hcomp'. } rewrite σbetterok. clear σ σbetterok. unfold hcomp' in σbetter. set (σbetter' := ((FA v ◃ # FA g) ▹ G ) • ((# FA f ▹ FA w') ▹ G)). assert (σbetter'ok : σbetter = σbetter'). { apply pathsinv0, rwhisker_vcomp. } rewrite σbetter'ok. clear σbetter σbetter'ok. etrans. 2: { apply maponpaths. unfold σbetter'. repeat rewrite vassocr. apply maponpaths_2. apply pathsinv0. exact Hyp'variant. } clear Hyp'variant σbetter' δ. (* now very close to the situation in the CAT development where δ was cleared *) etrans. 2: { repeat rewrite vassocr. apply idpath. } match goal with | [ |- _ = (((_ • ?Hν'variant) • ?Hδ'π') • _) • _] => set (ν'variant := Hν'variant); set (δ'π' := Hδ'π') end. assert (ν'variantok: ν'variant • lassociator (FA v) G (FA' w') = lassociator (FA v) G (FA' w) • (H' v ◃ # FA' g)). { unfold ν'variant. rewrite Hmorok. apply lwhisker_lwhisker. } etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply pathsinv0. use lhs_left_invert_cell. { apply is_invertible_2cell_rassociator. } etrans. 2: { repeat rewrite vassocr. do 4 apply maponpaths_2. exact ν'variantok. } repeat rewrite <- vassocr. apply maponpaths. clear ν'variant ν'variantok. etrans. { apply maponpaths. apply rwhisker_rwhisker. } repeat rewrite vassocr. apply maponpaths_2. rewrite H'morok. etrans. { apply pathsinv0. apply hcomp_hcomp'. } clear δ'π'. unfold hcomp. apply maponpaths_2. clear δ'. cbn. rewrite rwhisker_rwhisker. rewrite <- vassocr. etrans. { apply pathsinv0, id2_right. } apply maponpaths. apply pathsinv0. apply (vcomp_rinv (is_invertible_2cell_lassociator _ _ _)). Qed. (** the first dependently-typed ingredient of the displayed bifunctor for the tensor construction *) Lemma montrafotargetbicat_tensor_comp_aux_inst1 (v w w' : V) (g : V ⟦ w, w' ⟧) (η : G · FA' v ==> FA v · G) (π : G · FA' w ==> FA w · G) (π' : G · FA' w' ==> FA w' · G): π • (# FA g ▹ G) = (G ◃ # FA' g) • π' → param_distr_bicat_pentagon_eq_body_variant_RHS v w η π • (# FA (v ⊗^{ Mon_V}_{l} g) ▹ G) = (G ◃ # FA' (v ⊗^{ Mon_V}_{l} g)) • param_distr_bicat_pentagon_eq_body_variant_RHS v w' η π'. Proof. intro Hyp'. rewrite <- (when_bifunctor_becomes_leftwhiskering Mon_V). change (montrafotargetbicat_disp v) in η. exact (montrafotargetbicat_tensor_comp_aux v w v w' (identity v) g η π η π' (id_disp η) Hyp'). Qed. (** the second dependently-typed ingredient of the displayed bifunctor for the tensor construction *) Lemma montrafotargetbicat_tensor_comp_aux_inst2 (v v' w : V) (f : V ⟦ v, v' ⟧) (η : G · FA' v ==> FA v · G) (η' : G · FA' v' ==> FA v' · G) (π : G · FA' w ==> FA w · G): η • (# FA f ▹ G) = (G ◃ # FA' f) • η' → param_distr_bicat_pentagon_eq_body_variant_RHS v w η π • (# FA (f ⊗^{ Mon_V}_{r} w) ▹ G) = (G ◃ # FA' (f ⊗^{ Mon_V}_{r} w)) • param_distr_bicat_pentagon_eq_body_variant_RHS v' w η' π. Proof. intro Hyp. rewrite <- (when_bifunctor_becomes_rightwhiskering Mon_V). change (montrafotargetbicat_disp w) in π. exact (montrafotargetbicat_tensor_comp_aux v w v' w f (identity w) η π η' π Hyp (id_disp π)). Qed. Definition montrafotargetbicat_disp_tensor: disp_tensor montrafotargetbicat_disp Mon_V. Proof. use make_disp_bifunctor_locally_prop. - intro; intros; apply trafotargetbicat_disp_cells_isaprop. - use make_disp_bifunctor_data. + intros v w η π. exact (param_distr_bicat_pentagon_eq_body_variant_RHS v w η π). + cbn. intros v w w' g η π π' Hyp'. apply montrafotargetbicat_tensor_comp_aux_inst1; assumption. + cbn. intros v v' w f η η' π Hyp. apply montrafotargetbicat_tensor_comp_aux_inst2; assumption. Defined. (** the following are called data elements, but they have no computational content *) Lemma montrafotargetbicat_disp_leftunitor_data: disp_leftunitor_data montrafotargetbicat_disp_tensor montrafotargetbicat_disp_unit. Proof. hnf. intros v η. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_left_unitor_aux1] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 3 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • ?Hl6))))))))) = ?Hr1 • _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r1 := Hr1) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_μ_inv_inv2cell I_{Mon_V} v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. set (l2iso := lwhisker_rwhisker_with_ϵ_inv_inv2cell v). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. etrans. 2: { repeat rewrite vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. unfold r1. do 2 rewrite lwhisker_vcomp. apply maponpaths. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesleftunitality FA'm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l1 l2 l1iso l2iso r1. etrans. { do 2 apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_rwhisker_alt. } clear l3. cbn. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l4. unfold hcomp'. etrans. { repeat rewrite <- vassocr. do 4 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. repeat rewrite <- vassocr. apply maponpaths. unfold l5, l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. apply pathsinv0. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesleftunitality FAm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l5 l6. (* now only admin tasks in bicategory *) rewrite lunitor_lwhisker. apply maponpaths. apply (lhs_left_invert_cell _ _ _ (rwhisker_with_linvunitor_inv2cell v)). cbn. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)). cbn. apply pathsinv0, lunitor_triangle. Qed. Lemma montrafotargetbicat_disp_rightunitor_data: disp_rightunitor_data montrafotargetbicat_disp_tensor montrafotargetbicat_disp_unit. Proof. hnf. intros v η. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_right_unitor_aux1] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 3 rewrite <- lwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (_ • (?Hl4 • (_ • (?Hl5 • ?Hl6))))))))) = ?Hr1 • _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r1 := Hr1) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_μ_inv_inv2cell v I_{Mon_V}). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. etrans. 2: { apply maponpaths. rewrite vassocr. apply maponpaths_2. unfold r1. rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesrightunitality FA'm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. set (aux1iso := lwhisker_with_ϵ_inv2cell v). rewrite <- vassocr in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. apply (rhs_left_inv_cell _ _ _ aux1iso) in lax_monoidal_functor_unital_inst. unfold inv_cell in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } cbn. clear r1. etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply lwhisker_lwhisker_rassociator. } etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply pathsinv0, runitor_triangle. } rewrite <- vcomp_runitor. etrans. 2: { rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear l2. etrans. { repeat rewrite vassocr. do 6 apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } repeat rewrite <- vassocr. apply maponpaths. clear l3. cbn. etrans. { repeat rewrite vassocr. do 5 apply maponpaths_2. apply runitor_triangle. } etrans. 2: { apply id2_right. } repeat rewrite <- vassocr. apply maponpaths. etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker. } cbn. clear l4. etrans. { apply maponpaths. rewrite <- vassocr. apply maponpaths. unfold l5, l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesrightunitality FAm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0. rewrite vassocr. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l5 l6. (* now only pure bicategory reasoning *) set (auxiso := lwhisker_with_linvunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ auxiso). cbn. rewrite id2_right. clear auxiso. apply runitor_rwhisker. Qed. Definition montrafotargetbicat_disp_associator_data: disp_associator_data montrafotargetbicat_disp_tensor. Proof. intros v1 v2 v3 η1 η2 η3. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_associator_aux1] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 6 rewrite <- lwhisker_vcomp. do 6 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • (_ • (?Hl6 • (_ • (?Hl7 • ?Hl8)))))))))))) = _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (l7 := Hl7); set (l8 := Hl8) end. match goal with | [ |- _ = ?Hr1 • (?Hr2 • (_ • (?Hr3 • (_ • (?Hr4 • (_ • (?Hr5 • (_ • (?Hr6 • (_ • (?Hr7 • (_ • ?Hr8))))))))))))] => set (r1 := Hr1); set (r2 := Hr2); set (r3 := Hr3); set (r4 := Hr4); set (r5 := Hr5); set (r6 := Hr6); set (r7 := Hr7); set (r8 := Hr8) end. change (H v1 ==> H' v1) in η1; change (H v2 ==> H' v2) in η2; change (H v3 ==> H' v3) in η3. set (l1iso := lwhisker_with_μ_inv_inv2cell (v1 ⊗ v2) v3). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. match goal with | [ |- _ = ?Hl1inv • _] => set (l1inv := Hl1inv) end. etrans. { rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply rwhisker_lwhisker. } clear l2. etrans. { repeat rewrite <- vassocr. apply idpath. } match goal with | [ |- ?Hl2' • _ = _] => set (l2' := Hl2') end. cbn in l2'. set (l2'iso := rwhisker_lwhisker_with_μ_inv_inv2cell v1 v2 v3). apply (lhs_left_invert_cell _ _ _ l2'iso). cbn. clear l2' l2'iso. etrans. 2: { repeat rewrite vassocr. do 13 apply maponpaths_2. unfold l1inv, r1. do 2 rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := fmonoidal_preservesassociativity FA'm v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. apply pathsinv0. exact lax_monoidal_functor_assoc_inst. } clear l1inv r1. etrans. 2: { do 13 apply maponpaths_2. do 2 rewrite <- lwhisker_vcomp. apply idpath. } etrans. 2: { do 12 apply maponpaths_2. repeat rewrite <- vassocr. do 2 apply maponpaths. unfold r2. rewrite lwhisker_vcomp. apply maponpaths. set (auxbeinginverse := pr12 (fmonoidal_preservestensorstrongly FA'm v1 (v2 ⊗_{ Mon_V} v3))). cbn in auxbeinginverse. apply pathsinv0, auxbeinginverse. } cbn. clear r2. rewrite lwhisker_id2. rewrite id2_right. etrans. 2: { do 10 apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. rewrite lwhisker_lwhisker. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } unfold hcomp. clear r3. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } match goal with | [ |- _ = _ • (_ • (?Hr1'' • (?Hr3' • _)))] => set (r1'' := Hr1''); set (r3' := Hr3') end. cbn in l5. (* lassociator (FA v1) (FA v2) G ▹ FA' v3 starts with FA v1 · (FA v2 · G) · FA' v3 l5 starts with FA v1 · FA v2 · G · FA' v3 FA v1 ◃ rassociator (FA v2) G (FA' v3) starts with FA v1 · (FA v2 · G · FA' v3) r6 starts with FA v1 · (FA v2 · H v3) *) match goal with | [ |- _ • ( _ • ( _ • ( _ • ( _ • ?Hltail)))) = _ • ( _ • ( _ • ( _ • ( _ • ( _ • ( _ • ( _ • ?Hrtail)))))))] => set (ltail := Hltail); set (rtail := Hrtail) end. assert (tailseq: lassociator (FA v1) (FA v2 · G) (FA' v3) • ltail = rtail). 2: { rewrite <- tailseq. repeat rewrite vassocr. apply maponpaths_2. clear l5 l6 l7 l8 r6 r7 r8 ltail rtail tailseq η3. (* l3 is close to r1'', l4 is close to r5, and r3' is close to the inverse of r4 - we first treat the latter *) etrans. 2: { repeat rewrite <- vassocr. do 3 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. rewrite <- vassocr. unfold r4. rewrite lwhisker_lwhisker_rassociator. rewrite vassocr. apply maponpaths_2. unfold r3'. rewrite lwhisker_vcomp. apply maponpaths. set (auxbeinginverse := pr12 (fmonoidal_preservestensorstrongly FA'm v2 v3)). cbn in auxbeinginverse. apply pathsinv0, auxbeinginverse. } cbn. clear r3' r4. rewrite lwhisker_id2. rewrite id2_left. (* now plain reasoning in one bicategory *) etrans. 2: { repeat rewrite <- vassocr. do 5 apply maponpaths. apply pathsinv0, rwhisker_lwhisker. } clear r5. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. clear l4. assert (l3ok := rwhisker_rwhisker (FA' v2) (FA' v3) η1). apply (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in l3ok. cbn in l3ok. assert (l3okbetter: l3 = rassociator (G · FA' v1) (FA' v2) (FA' v3) • (r1'' • lassociator (FA v1 · G) (FA' v2) (FA' v3))). { apply l3ok. } rewrite l3okbetter. clear l3 l3ok l3okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear r1'' ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply pathsinv0. assert (pentagon_inst := inverse_pentagon_5 (FA' v3) (FA' v2) (FA' v1) G). cbn in pentagon_inst. etrans. { exact pentagon_inst. } repeat rewrite vassocr. apply idpath. (* to find the right pentagon law - there are: associativity_pentagon, pentagon, pentagon_2, inverse_pentagon, inverse_pentagon_2, inverse_pentagon_3, inverse_pentagon_4, inverse_pentagon_5, inverse_pentagon_6 *) } unfold ltail2, rtail2. clear ltail2 rtail2 η1 η2 r1''. assert (pentagon_inst := inverse_pentagon_4 (FA' v3) (FA' v2) G (FA v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. rewrite hcomp_identity_left in pentagon_inst. rewrite hcomp_identity_right in pentagon_inst. exact pentagon_inst. } (* now the second half of the proof - however with no need for inversion of "monoidal" arrows *) clear l3 l4 r4 r5 r1'' r3' η1 η2. unfold ltail; clear ltail. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. unfold l5. rewrite rwhisker_rwhisker_alt. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l5 l6. unfold hcomp'. etrans. { do 2 apply maponpaths. repeat rewrite <- vassocr. do 2 apply maponpaths. repeat rewrite vassocr. do 2 apply maponpaths_2. apply pathsinv0, rwhisker_rwhisker. } etrans. { repeat rewrite <- vassocr. do 5 apply maponpaths. unfold l7, l8. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := fmonoidal_preservesassociativity FAm v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. apply pathsinv0. rewrite <- vassocr in lax_monoidal_functor_assoc_inst. apply pathsinv0. exact lax_monoidal_functor_assoc_inst. } clear l7 l8. unfold rtail; clear rtail. do 2 rewrite <- rwhisker_vcomp. repeat rewrite vassocr. apply maponpaths_2. clear r8. etrans. 2: { repeat rewrite <- vassocr. do 3 apply maponpaths. apply pathsinv0, rwhisker_lwhisker. } clear r7. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. cbn. (* now plain reasoning in one bicategory *) assert (r6ok := lwhisker_lwhisker (FA v1) (FA v2) η3). apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in r6ok. cbn in r6ok. assert (r6okbetter: r6 = (lassociator (FA v1) (FA v2) (G · FA' v3) • (FA v1 · FA v2 ◃ η3)) • rassociator (FA v1) (FA v2) (FA v3 · G)). { apply r6ok. } rewrite r6okbetter. clear r6 r6ok r6okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply pathsinv0. assert (pentagon_inst := inverse_pentagon_5 (FA' v3) G (FA v2) (FA v1)). etrans. { exact pentagon_inst. } repeat rewrite vassocr. apply idpath. } unfold ltail2, rtail2. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. clear ltail2 rtail2 η3. assert (pentagon_inst := inverse_pentagon_4 G (FA v3) (FA v2) (FA v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. exact pentagon_inst. Qed. Lemma montrafotargetbicat_disp_associatorinv_data: disp_associatorinv_data montrafotargetbicat_disp_tensor. Proof. intros v1 v2 v3 η1 η2 η3. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_associator_aux2] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 6 rewrite <- lwhisker_vcomp. do 6 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (_ • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (?Hl5 • (_ • (?Hl6 • (_ • (?Hl7 • ?Hl8)))))))))))) = _] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (l7 := Hl7); set (l8 := Hl8) end. match goal with | [ |- _ = ?Hr1 • (?Hr2 • (_ • (?Hr3 • (_ • (?Hr4 • (_ • (?Hr5 • (_ • (?Hr6 • (_ • (?Hr7 • (_ • ?Hr8))))))))))))] => set (r1 := Hr1); set (r2 := Hr2); set (r3 := Hr3); set (r4 := Hr4); set (r5 := Hr5); set (r6 := Hr6); set (r7 := Hr7); set (r8 := Hr8) end. change (H v1 ==> H' v1) in η1; change (H v2 ==> H' v2) in η2; change (H v3 ==> H' v3) in η3. (* cbn in * |- *. *) set (l8iso := rwhisker_with_invassociator_inv2cell v1 v2 v3). etrans. { repeat rewrite vassocr. apply idpath. } apply (lhs_right_invert_cell _ _ _ l8iso). cbn. match goal with | [ |- _ = _ • ?Hl8inv ] => set (l8inv := Hl8inv) end. clear l8 l8iso. etrans. 2: { repeat rewrite vassocr. do 3 apply maponpaths_2. repeat rewrite <- vassocr. do 9 apply maponpaths. rewrite vassocr. etrans. 2: { apply maponpaths_2. apply pathsinv0, rwhisker_rwhisker_alt. } cbn. repeat rewrite <- vassocr. apply maponpaths. apply pathsinv0, hcomp_hcomp'. } unfold hcomp'. clear r6 r7. etrans. 2: { repeat rewrite <- vassocr. do 11 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. rewrite <- vassocr. apply maponpaths. unfold r8, l8inv. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_assoc_inst := fmonoidal_preservesassociativity FAm v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. apply pathsinv0. rewrite <- vassocr in lax_monoidal_functor_assoc_inst. exact lax_monoidal_functor_assoc_inst. } clear r8 l8inv. do 2 rewrite <- rwhisker_vcomp. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply maponpaths_2. clear l7. etrans. { rewrite <- vassocr. apply maponpaths. apply rwhisker_lwhisker. } clear l6. repeat rewrite vassocr. apply maponpaths_2. cbn. match goal with | [ |- ((((?Hlhead • _) • _) • _) • _) • _ = (((((?Hrhead • _) • _) • _) • _) • _) • _ ] => set (lhead := Hlhead); set (rhead := Hrhead) end. assert (headsok: lhead = rhead • rassociator (FA v1) (G · FA' v2) (FA' v3)). 2: { (* first deal with the reasoning confined to the bicategory *) rewrite headsok. repeat rewrite <- vassocr. apply maponpaths. clear η1 l1 l2 l3 r1 r2 r3 r4 lhead rhead headsok. etrans. { rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } etrans. { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear η2 l4 r5. (* now as for r6 in the proof of [montrafotargetbicat_associator_aux1] *) assert (l5ok := lwhisker_lwhisker (FA v1) (FA v2) η3). apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in l5ok. cbn in l5ok. assert (l5okbetter: l5 = (lassociator (FA v1) (FA v2) (G · FA' v3) • (FA v1 · FA v2 ◃ η3)) • rassociator (FA v1) (FA v2) (FA v3 · G)). { apply l5ok. } rewrite l5okbetter. clear l5 l5ok l5okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail2))) = _ • ( _ • ( _ • ?Hrtail2))] => set (ltail2 := Hltail2); set (rtail2 := Hrtail2) end. assert (tails2eq: ltail2 = rtail2). 2: { rewrite tails2eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear ltail2 rtail2 tails2eq. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. assert (pentagon_inst := inverse_pentagon_5 (FA' v3) G (FA v2) (FA v1)). apply pathsinv0, (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in pentagon_inst. apply pathsinv0 in pentagon_inst. cbn in pentagon_inst. rewrite vassocr in pentagon_inst. exact pentagon_inst. } unfold ltail2, rtail2. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. clear ltail2 rtail2 η3. assert (pentagon_inst := inverse_pentagon_4 G (FA v3) (FA v2) (FA v1)). apply pathsinv0 in pentagon_inst. rewrite vassocr in pentagon_inst. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)) in pentagon_inst. cbn in pentagon_inst. rewrite <- vassocr in pentagon_inst. apply pathsinv0 in pentagon_inst. exact pentagon_inst. } clear η2 η3 l4 l5 r5. (* now the second half of the proof - however with even more need for inversion of "monoidal" arrows *) unfold lhead. clear lhead. etrans. { apply maponpaths_2. repeat rewrite <- vassocr. do 2 apply maponpaths. unfold l3. rewrite lwhisker_lwhisker_rassociator. rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp'. clear l2 l3. cbn. unfold rhead. clear rhead. (* now as for l5 *) assert (r4ok := rwhisker_rwhisker (FA' v2) (FA' v3) η1). apply (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)) in r4ok. cbn in r4ok. assert (r4okbetter: r4 = rassociator (G · FA' v1) (FA' v2) (FA' v3) • ((η1 ▹ FA' v2 · FA' v3) • lassociator (FA v1 · G) (FA' v2) (FA' v3))). { apply r4ok. } rewrite r4okbetter. clear r4 r4ok r4okbetter. repeat rewrite <- vassocr. match goal with | [ |- _ • ( _ • ( _ • ( _ • ?Hltail3))) = _ • ( _ • ( _ • ( _ • (_ • ( _ • ( _ • ?Hrtail3))))))] => set (ltail3 := Hltail3); set (rtail3 := Hrtail3) end. assert (tails3eq: ltail3 = rtail3). { (* first deal with the reasoning confined to the bicategory *) unfold ltail3, rtail3. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply inverse_pentagon_4. } rewrite tails3eq. repeat rewrite vassocr. do 2 apply maponpaths_2. clear η1 ltail3 rtail3 tails3eq. etrans. 2: { do 2 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply rwhisker_lwhisker. } clear r3. etrans. { rewrite <- vassocr. apply maponpaths. apply pathsinv0, lwhisker_lwhisker. } repeat rewrite vassocr. unfold l1, r1, r2. do 3 rewrite lwhisker_vcomp. clear l1 r1 r2. match goal with | [ |- ?Hlhead2 • _ = ((?Hrhead2 • _) • _) • _ ] => set (lhead2 := Hlhead2); set (rhead2 := Hrhead2) end. assert (heads2ok: lhead2 = rhead2 • (G ◃ rassociator (FA' v1) (FA' v2) (FA' v3))). 2: { (* first deal with the reasoning confined to the bicategory *) rewrite heads2ok. repeat rewrite <- vassocr. apply maponpaths. clear lhead2 rhead2 heads2ok. cbn. rewrite <- hcomp_identity_left. rewrite <- hcomp_identity_right. apply inverse_pentagon_5. } unfold rhead2. rewrite lwhisker_vcomp. apply maponpaths. clear lhead2 rhead2. assert (lax_monoidal_functor_assoc_inst := fmonoidal_preservesassociativity FA'm v1 v2 v3). cbn in lax_monoidal_functor_assoc_inst. transparent assert (aux1iso : (invertible_2cell (FA' (v1 ⊗ (v2 ⊗ v3))) (FA' v1 · FA' (v2 ⊗ v3)))). { use make_invertible_2cell. - exact (pr1 (fmonoidal_preservestensorstrongly FA'm v1 (v2 ⊗ v3))). - change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm v1 (v2 ⊗ v3)))). apply is_z_isomorphism_inv. } apply (lhs_left_invert_cell _ _ _ aux1iso). cbn. etrans. 2: { repeat rewrite vassocr. apply idpath. } apply pathsinv0, lassociator_to_rassociator_post. transparent assert (aux2iso : (invertible_2cell (FA' (v1 ⊗ v2) · FA' v3) ((FA' v1 · FA' v2) · FA' v3))). { use make_invertible_2cell. - exact ((pr1 (fmonoidal_preservestensorstrongly FA'm v1 v2)) ▹ FA' v3). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm v1 v2))). apply is_z_isomorphism_inv. } apply (lhs_right_invert_cell _ _ _ aux2iso). cbn. transparent assert (aux3iso : (invertible_2cell (FA' ((v1 ⊗ v2) ⊗ v3)) (FA' (v1 ⊗ v2) · FA' v3))). { use make_invertible_2cell. - exact (pr1 (fmonoidal_preservestensorstrongly FA'm (v1 ⊗ v2) v3)). - change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm (v1 ⊗_{ Mon_V} v2) v3))). apply is_z_isomorphism_inv. } apply (lhs_right_invert_cell _ _ _ aux3iso). cbn. transparent assert (aux4iso : (invertible_2cell (FA' (v1 ⊗ (v2 ⊗ v3))) (FA' ((v1 ⊗ v2) ⊗ v3)))). { use make_invertible_2cell. - exact (# FA' (αinv_{ Mon_V} v1 v2 v3)). - change (is_z_isomorphism (# FA' (αinv_{ Mon_V} v1 v2 v3))). apply functor_on_is_z_isomorphism. exists (α_{ Mon_V} v1 v2 v3). destruct (monoidal_associatorisolaw Mon_V v1 v2 v3); split; assumption. } apply (lhs_right_invert_cell _ _ _ aux4iso). cbn. repeat rewrite <- vassocr. transparent assert (aux5iso : (invertible_2cell (FA' v1 · FA' (v2 ⊗ v3)) (FA' v1 · (FA' v2 · FA' v3)))). { use make_invertible_2cell. - exact (FA' v1 ◃ (pr1 (fmonoidal_preservestensorstrongly FA'm v2 v3))). - is_iso. change (is_z_isomorphism (pr1 (fmonoidal_preservestensorstrongly FA'm v2 v3))). apply is_z_isomorphism_inv. } apply pathsinv0, (lhs_left_invert_cell _ _ _ aux5iso). cbn. clear aux1iso aux2iso aux3iso aux4iso aux5iso. apply pathsinv0, rassociator_to_lassociator_pre. apply pathsinv0. repeat rewrite vassocr. exact lax_monoidal_functor_assoc_inst. Qed. Lemma montrafotargetbicat_disp_leftunitorinv_data: disp_leftunitorinv_data montrafotargetbicat_disp_tensor montrafotargetbicat_disp_unit. Proof. intros v η. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_left_unitor_aux2] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 3 rewrite <- rwhisker_vcomp. repeat rewrite <- vassocr. apply pathsinv0. match goal with | [ |- ?Hl1 • (?Hl2 • (_ • (?Hl3 • (_ • (_ • (?Hl4 • (_ • (?Hl5 • (_ • ?Hl6))))))))) = _ • ?Hr2] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r2 := Hr2) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_invlunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. set (l2iso := lwhisker_with_μ_inv_inv2cell I_{Mon_V} v). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. set (l3iso := lwhisker_rwhisker_with_ϵ_inv_inv2cell v). apply (lhs_left_invert_cell _ _ _ l3iso). cbn. match goal with | [ |- _ = ?Hl3inv • (_ • (?Hl2inv • (?Hl1inv • _)))] => set (l1inv := Hl1inv); set (l2inv := Hl2inv); set (l3inv := Hl3inv) end. clear l1 l2 l3 l1iso l2iso l3iso. etrans. 2: { repeat rewrite vassocr. do 4 apply maponpaths_2. unfold l3inv. apply rwhisker_lwhisker_rassociator. } etrans. 2: { do 2 apply maponpaths_2. repeat rewrite <- vassocr. apply maponpaths. unfold l2inv, l1inv. do 2 rewrite lwhisker_vcomp. apply maponpaths. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesleftunitality FA'm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l1inv l2inv l3inv. etrans. { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. apply rwhisker_rwhisker_alt. } cbn. etrans. { do 2 apply maponpaths. do 2 apply maponpaths_2. rewrite <- vassocr. apply maponpaths. apply hcomp_hcomp'. } clear l4 l5. unfold hcomp'. set (r2iso := rwhisker_with_invlunitor_inv2cell v). apply pathsinv0. apply (lhs_right_invert_cell _ _ _ r2iso). apply pathsinv0. cbn. clear r2 r2iso. etrans. { repeat rewrite <- vassocr. do 4 apply maponpaths. rewrite vassocr. rewrite <- rwhisker_rwhisker. repeat rewrite <- vassocr. apply maponpaths. unfold l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. apply pathsinv0. rewrite vassocr. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesleftunitality FAm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l6. (* now only admin tasks in bicategory: the goal is the same as at that position in [montrafotargetbicat_left_unitor_aux1] *) rewrite lunitor_lwhisker. apply maponpaths. apply (lhs_left_invert_cell _ _ _ (rwhisker_with_linvunitor_inv2cell v)). cbn. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)). cbn. apply pathsinv0, lunitor_triangle. Qed. Lemma montrafotargetbicat_disp_rightunitorinv_data: disp_rightunitorinv_data montrafotargetbicat_disp_tensor montrafotargetbicat_disp_unit. Proof. intros v η. apply pathsinv0. cbn. (** now comes an adaptation of the code of [montrafotargetbicat_right_unitor_aux2] from the former approach to monoidal categories *) unfold param_distr_bicat_pentagon_eq_body_variant_RHS, montrafotargetbicat_disp_unit, param_distr_bicat_triangle_eq_variant0_RHS, param_distr_bicat_pentagon_eq_body_RHS. do 3 rewrite <- lwhisker_vcomp. repeat rewrite <- vassocr. match goal with | [ |- ?Hl1 • (?Hl2 • (_ • (?Hl3 • (_ • (?Hl4 • (_ • (_ • (?Hl5 • (_ • ?Hl6))))))))) = _ • ?Hr2] => set (l1 := Hl1); set (l2 := Hl2); set (l3 := Hl3); set (l4 := Hl4); set (l5 := Hl5); set (l6 := Hl6); set (r2 := Hr2) end. change (H v ==> H' v) in η. set (l1iso := lwhisker_with_invrunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ l1iso). cbn. clear l1 l1iso. set (l2iso := lwhisker_with_μ_inv_inv2cell v I_{Mon_V}). apply (lhs_left_invert_cell _ _ _ l2iso). cbn. clear l2 l2iso. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). cbn. etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesrightunitality FA'm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. set (aux1iso := lwhisker_with_ϵ_inv2cell v). rewrite <- vassocr in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. apply (rhs_left_inv_cell _ _ _ aux1iso) in lax_monoidal_functor_unital_inst. unfold inv_cell in lax_monoidal_functor_unital_inst. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } cbn. (* same goal as in [montrafotargetbicat_right_unitor_aux1], except l_i -> l_{i+1} for i=2,3,4,5, and l6 becomes r2 on the other side *) etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite <- lwhisker_vcomp. rewrite vassocr. apply maponpaths_2. apply pathsinv0. apply lwhisker_lwhisker_rassociator. } etrans. 2: { repeat rewrite <- vassocr. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply pathsinv0, runitor_triangle. } etrans. 2: { apply maponpaths. rewrite vassocr. rewrite <- vcomp_runitor. apply idpath. } etrans. 2: { rewrite vassocr. apply maponpaths_2. rewrite vassocr. apply maponpaths_2. apply hcomp_hcomp'. } unfold hcomp. etrans. 2: { repeat rewrite <- vassocr. apply idpath. } apply maponpaths. clear l3. etrans. { repeat rewrite vassocr. do 5 apply maponpaths_2. apply lwhisker_lwhisker_rassociator. } repeat rewrite <- vassocr. apply maponpaths. clear l4. cbn. etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. apply runitor_triangle. } (* now we put an end to the diversion from the goal in [montrafotargetbicat_right_unitor_aux1] *) set (r2iso := rwhisker_with_invrunitor_inv2cell v). apply pathsinv0, (lhs_right_invert_cell _ _ _ r2iso), pathsinv0. cbn. clear r2 r2iso. (* resume analogous proof *) etrans. 2: { apply id2_right. } repeat rewrite <- vassocr. apply maponpaths. etrans. { apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rwhisker_lwhisker. } cbn. clear l5. etrans. { apply maponpaths. rewrite <- vassocr. apply maponpaths. unfold l6. do 2 rewrite rwhisker_vcomp. apply maponpaths. assert (lax_monoidal_functor_unital_inst := fmonoidal_preservesrightunitality FAm v). cbn in lax_monoidal_functor_unital_inst. apply pathsinv0 in lax_monoidal_functor_unital_inst. rewrite vassocr. apply pathsinv0. exact lax_monoidal_functor_unital_inst. } clear l6. (* now only pure bicategory reasoning *) set (auxiso := lwhisker_with_linvunitor_inv2cell v). apply (lhs_left_invert_cell _ _ _ auxiso). cbn. rewrite id2_right. clear auxiso. apply runitor_rwhisker. Qed. Definition montrafotargetbicat_disp_monoidal_data: disp_monoidal_data montrafotargetbicat_disp Mon_V. Proof. exists montrafotargetbicat_disp_tensor. exists montrafotargetbicat_disp_unit. exists montrafotargetbicat_disp_leftunitor_data. exists montrafotargetbicat_disp_leftunitorinv_data. exists montrafotargetbicat_disp_rightunitor_data. exists montrafotargetbicat_disp_rightunitorinv_data. exists montrafotargetbicat_disp_associator_data. exact montrafotargetbicat_disp_associatorinv_data. Defined. Definition montrafotargetbicat_disp_monoidal: disp_monoidal montrafotargetbicat_disp Mon_V. Proof. use make_disp_monoidal_locally_prop. - intro; intros; apply trafotargetbicat_disp_cells_isaprop. - exact montrafotargetbicat_disp_monoidal_data. Defined. Definition parameterized_distributivity_bicat_nat : UU := H ⟹ H'. Definition parameterized_distributivity_bicat_nat_funclass (δ : parameterized_distributivity_bicat_nat): ∏ v : V, H v --> H' v := pr1 δ. Coercion parameterized_distributivity_bicat_nat_funclass : parameterized_distributivity_bicat_nat >-> Funclass. Definition param_distr_bicat_triangle_eq_variant0 (δ : parameterized_distributivity_bicat_nat): UU := δ I_{Mon_V} = param_distr_bicat_triangle_eq_variant0_RHS. Definition param_distr_bicat_triangle_eq (δ : parameterized_distributivity_bicat_nat): UU := (G ◃ fmonoidal_preservesunit FA'm) • δ I_{Mon_V} = ((runitor G : G · I_{ monoidal_from_bicat_and_ob a0'} ==> G) • (linvunitor G : G ==> I_{ monoidal_from_bicat_and_ob a0} · G)) • (fmonoidal_preservesunit FAm ▹ G). Lemma param_distr_bicat_triangle_eq_variant0_follows (δ : parameterized_distributivity_bicat_nat): param_distr_bicat_triangle_eq δ -> param_distr_bicat_triangle_eq_variant0 δ. Proof. intro Hyp. red. unfold param_distr_bicat_triangle_eq_variant0_RHS. apply pathsinv0, (lhs_left_invert_cell _ _ _ lwhisker_with_ϵ_inv2cell_bis). apply pathsinv0. exact Hyp. Qed. Lemma param_distr_bicat_triangle_eq_variant0_implies (δ : parameterized_distributivity_bicat_nat): param_distr_bicat_triangle_eq_variant0 δ -> param_distr_bicat_triangle_eq δ. Proof. intro Hyp. red in Hyp. unfold param_distr_bicat_triangle_eq_variant0_RHS in Hyp. apply pathsinv0, (rhs_left_inv_cell _ _ _ lwhisker_with_ϵ_inv2cell_bis), pathsinv0 in Hyp. exact Hyp. Qed. Definition param_distr_bicat_pentagon_eq_body_variant (δ : parameterized_distributivity_bicat_nat) (v w : V): UU := δ (v ⊗ w) = param_distr_bicat_pentagon_eq_body_variant_RHS v w (δ v) (δ w). Definition param_distr_bicat_pentagon_eq_variant (δ : parameterized_distributivity_bicat_nat): UU := ∏ (v w : V), param_distr_bicat_pentagon_eq_body_variant δ v w. Definition param_distr_bicat_pentagon_eq_body (δ : parameterized_distributivity_bicat_nat) (v w : V): UU := ((rassociator G (FA' v) (FA' w) : H v · FA' w ==> G · FA' v ⊗_{ monoidal_from_bicat_and_ob a0'} FA' w) • (G ◃ (fmonoidal_preservestensordata FA'm v w))) • δ (v ⊗ w) = param_distr_bicat_pentagon_eq_body_RHS v w (δ v) (δ w). Definition param_distr_bicat_pentagon_eq (δ : parameterized_distributivity_bicat_nat): UU := ∏ (v w : V), param_distr_bicat_pentagon_eq_body δ v w. Lemma param_distr_bicat_pentagon_eq_body_variant_follows (δ : parameterized_distributivity_bicat_nat) (v w : V): param_distr_bicat_pentagon_eq_body δ v w -> param_distr_bicat_pentagon_eq_body_variant δ v w. Proof. intro Hyp. red. unfold param_distr_bicat_pentagon_eq_body_variant_RHS. apply pathsinv0, (lhs_left_invert_cell _ _ _ (lwhisker_with_μ_inv_inv2cell v w)). apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). apply pathsinv0. etrans. 2: { exact Hyp. } apply vassocr. Qed. Lemma param_distr_bicat_pentagon_eq_body_variant_implies (δ : parameterized_distributivity_bicat_nat) (v w : V): param_distr_bicat_pentagon_eq_body_variant δ v w -> param_distr_bicat_pentagon_eq_body δ v w. Proof. intro Hyp. red in Hyp. unfold param_distr_bicat_pentagon_eq_body_variant_RHS in Hyp. apply pathsinv0, (rhs_left_inv_cell _ _ _ (lwhisker_with_μ_inv_inv2cell v w)) in Hyp. apply (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)), pathsinv0 in Hyp. etrans. 2: { exact Hyp. } apply vassocl. Qed. Lemma isaprop_param_distr_bicat_triangle_eq (δ : parameterized_distributivity_bicat_nat): isaprop (param_distr_bicat_triangle_eq δ). Proof. apply C. Qed. Lemma isaprop_param_distr_bicat_pentagon_eq (δ : parameterized_distributivity_bicat_nat): isaprop (param_distr_bicat_pentagon_eq δ). Proof. red. apply impred; intros v. apply impred; intros w. apply cellset_property. Qed. Section IntoMonoidalSectionBicat. Context (δ: parameterized_distributivity_bicat_nat). Context (δtr_eq: param_distr_bicat_triangle_eq_variant0 δ) (δpe_eq: param_distr_bicat_pentagon_eq_variant δ). (** using sections already for this direction *) Lemma param_distr_bicat_to_monoidal_section_data: smonoidal_data Mon_V montrafotargetbicat_disp_monoidal (nat_trans_to_section_bicat a0 a0' H H' δ). Proof. split. - intros v w. cbn. rewrite (functor_id FA), (functor_id FA'). cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. apply pathsinv0, δpe_eq. - cbn. rewrite (functor_id FA), (functor_id FA'). cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. apply pathsinv0, δtr_eq. Qed. (** the two equations were thus exactly the ingredients for the data of a monoidal section *) Lemma param_distr_bicat_to_monoidal_section_laws: smonoidal_laxlaws Mon_V montrafotargetbicat_disp_monoidal param_distr_bicat_to_monoidal_section_data. Proof. repeat split; red; intros; apply trafotargetbicat_disp_cells_isaprop. Qed. Lemma param_distr_bicat_to_monoidal_section_strongtensor: smonoidal_strongtensor Mon_V montrafotargetbicat_disp_monoidal (smonoidal_preserves_tensor Mon_V montrafotargetbicat_disp_monoidal param_distr_bicat_to_monoidal_section_data). Proof. intros v w. use tpair. - cbn. (** now as for [param_distr_bicat_to_monoidal_section_data] *) rewrite (functor_id FA), (functor_id FA'). cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. apply δpe_eq. - split; apply trafotargetbicat_disp_cells_isaprop. Qed. Lemma param_distr_bicat_to_monoidal_section_strongunit: smonoidal_strongunit Mon_V montrafotargetbicat_disp_monoidal (smonoidal_preserves_unit Mon_V montrafotargetbicat_disp_monoidal param_distr_bicat_to_monoidal_section_data). Proof. use tpair. - cbn. rewrite (functor_id FA), (functor_id FA'). cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. apply δtr_eq. - split; apply trafotargetbicat_disp_cells_isaprop. Qed. Definition param_distr_bicat_to_monoidal_section: smonoidal Mon_V montrafotargetbicat_disp_monoidal (nat_trans_to_section_bicat a0 a0' H H' δ). Proof. use tpair. - exact (param_distr_bicat_to_monoidal_section_data,,param_distr_bicat_to_monoidal_section_laws). - split. + exact param_distr_bicat_to_monoidal_section_strongtensor. + exact param_distr_bicat_to_monoidal_section_strongunit. Defined. End IntoMonoidalSectionBicat. (* not migrated, and also parameterized_distributivity_bicat not yet defined (taking into account the variants!) Definition smf_from_param_distr_bicat: parameterized_distributivity_bicat -> strong_monoidal_functor Mon_V montrafotargetbicat_moncat. Proof. intro δs. induction δs as [δ [δtr_eq δpe_eq]]. exact (smf_from_param_distr_parts_bicat δ δtr_eq δpe_eq). Defined. *) (** the other direction, essentially dependent on sections *) Section FromMonoidalSectionBicat. Context (sd: section_disp montrafotargetbicat_disp). Context (ms: smonoidal_data Mon_V montrafotargetbicat_disp_monoidal sd). (** since the laws were anyway trivial to establish, we do not need more than [smonoidal_data] *) Definition δ_from_ms: H ⟹ H' := section_to_nat_trans_bicat _ _ _ _ sd. Lemma δtr_eq_from_ms: param_distr_bicat_triangle_eq_variant0 δ_from_ms. Proof. red. assert (aux := smonoidal_preserves_unit _ _ ms). cbn in aux. rewrite (functor_id FA), (functor_id FA') in aux. cbn in aux. rewrite lwhisker_id2, id2_rwhisker in aux. rewrite id2_left, id2_right in aux. apply pathsinv0. exact aux. Qed. Lemma δpe_eq_from_ms: param_distr_bicat_pentagon_eq_variant δ_from_ms. Proof. intros v w. assert (aux := smonoidal_preserves_tensor _ _ ms v w). cbn in aux. rewrite (functor_id FA), (functor_id FA') in aux. cbn in aux. rewrite lwhisker_id2, id2_rwhisker in aux. rewrite id2_left, id2_right in aux. apply pathsinv0. exact aux. Qed. End FromMonoidalSectionBicat. Section RoundtripForSDData. Local Definition source_type: UU := ∑ δ: parameterized_distributivity_bicat_nat, param_distr_bicat_triangle_eq_variant0 δ × param_distr_bicat_pentagon_eq_variant δ. Local Definition target_type: UU := ∑ sd: section_disp montrafotargetbicat_disp, smonoidal_data Mon_V montrafotargetbicat_disp_monoidal sd. Local Definition source_to_target : source_type -> target_type. Proof. intro ass. destruct ass as [δ [δtr_eq δpe_eq]]. exists (nat_trans_to_section_bicat a0 a0' H H' δ). apply param_distr_bicat_to_monoidal_section_data; [exact δtr_eq | exact δpe_eq]. Defined. Local Definition target_to_source : target_type -> source_type. Proof. intro ass. destruct ass as [sd ms]. exists (δ_from_ms sd). split; [apply δtr_eq_from_ms | apply δpe_eq_from_ms]; exact ms. Defined. Local Lemma roundtrip1 (ass: source_type): target_to_source (source_to_target ass) = ass. Proof. destruct ass as [δ [δtr_eq δpe_eq]]. use total2_paths_f. - cbn. unfold δ_from_ms. apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip1_with_sections. - cbn. match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + unfold param_distr_bicat_triangle_eq_variant0. apply C. + unfold param_distr_bicat_pentagon_eq_variant. apply impred. intro v. apply impred. intro w. apply C. Qed. Local Lemma roundtrip2 (ass: target_type): source_to_target (target_to_source ass) = ass. Proof. destruct ass as [sd ms]. use total2_paths_f. - cbn. unfold δ_from_ms. apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip2_with_sections. - cbn. match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + unfold section_preserves_tensor_data. apply impred. intro v. apply impred. intro w. apply trafotargetbicat_disp_cells_isaprop. + unfold section_preserves_unit. apply trafotargetbicat_disp_cells_isaprop. Qed. End RoundtripForSDData. End FunctorViaBicat. Section Functor. Context {A A': category}. Context {FA: functor V (cat_of_endofunctors A)}. Context {FA': functor V (cat_of_endofunctors A')}. Context (FAm: fmonoidal Mon_V (monoidal_of_endofunctors A) FA). Context (FA'm: fmonoidal Mon_V (monoidal_of_endofunctors A') FA'). Context (G : A ⟶ A'). Let H : V ⟶ [A, A'] := param_distributivity'_dom(FA':=FA') A A' G. Let H' : V ⟶ [A, A'] := param_distributivity'_codom(FA:=FA) A A' G. Goal H = Main.H(C:=bicat_of_cats)(FA':=FA') G. Proof. apply idpath. Qed. Goal H' = Main.H'(C:=bicat_of_cats)(FA:=FA) G. Proof. apply idpath. Qed. Definition parameterized_distributivity'_nat_as_instance (δtr: parameterized_distributivity'_nat(FA:=FA)(FA':=FA') A A' G): parameterized_distributivity_bicat_nat(FA:=FA)(FA':=FA') G := δtr. Definition montrafotarget_disp: disp_cat V := montrafotargetbicat_disp(C:=bicat_of_cats)(FA:=FA)(FA':=FA') G. Definition montrafotarget_totalcat: category := total_category montrafotarget_disp. Goal montrafotarget_disp = trafotargetbicat_disp(C:=bicat_of_cats) A A' H H'. Proof. apply idpath. Qed. Definition montrafotarget_disp_monoidal: disp_monoidal montrafotarget_disp Mon_V := montrafotargetbicat_disp_monoidal(C:=bicat_of_cats)(a0:=A)(a0':=A') FAm FA'm G. Definition montrafotarget_monoidal: monoidal montrafotarget_totalcat := total_monoidal montrafotarget_disp_monoidal. Section IntoMonoidalSection. Context (δs : parameterized_distributivity' Mon_V A A' FAm FA'm G). Let δ : parameterized_distributivity'_nat A A' G := pr1 δs. Let δtr_eq : param_distr'_triangle_eq Mon_V A A' FAm FA'm G (pr1 δs) := pr12 δs. Let δpe_eq : param_distr'_pentagon_eq Mon_V A A' FAm FA'm G (pr1 δs) := pr22 δs. Definition montrafotarget_section_disp : section_disp montrafotarget_disp := nat_trans_to_section_bicat(C0:=V)(C:=bicat_of_cats) A A' H H' δ. Lemma δtr_eq': param_distr_bicat_triangle_eq_variant0 FAm FA'm G δ. Proof. apply param_distr'_triangle_eq_variant0_follows in δtr_eq. red in δtr_eq |- *. unfold param_distr'_triangle_eq_variant0_RHS in δtr_eq. unfold param_distr_bicat_triangle_eq_variant0_RHS. cbn in δtr_eq |- *. etrans. { exact δtr_eq. } rewrite (nat_trans_comp_id_right A' (functor_composite G (functor_identity A')) G). (* show_id_type. *) apply (nat_trans_eq A'). intro a. cbn. apply maponpaths, pathsinv0, id_left. Qed. Lemma δpe_eq': param_distr_bicat_pentagon_eq_variant FAm FA'm G δ. Proof. intros v w. set (δpe_eq_inst := δpe_eq v w). apply param_distr'_pentagon_eq_body_variant_follows in δpe_eq_inst. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. unfold param_distr'_pentagon_eq_body_variant, param_distr'_pentagon_eq_body_variant_RHS in δpe_eq_inst. cbn in δpe_eq_inst |- *. etrans. { exact δpe_eq_inst. } clear δpe_eq_inst. apply (nat_trans_eq A'). intro a. cbn. apply maponpaths. do 3 rewrite id_left. apply idpath. Qed. Definition param_distr'_to_monoidal_section_data: smonoidal_data Mon_V montrafotarget_disp_monoidal montrafotarget_section_disp := param_distr_bicat_to_monoidal_section_data(C:=bicat_of_cats) FAm FA'm G (parameterized_distributivity'_nat_as_instance δ) δtr_eq' δpe_eq'. Definition param_distr'_to_monoidal_section_laws: smonoidal_laxlaws Mon_V montrafotarget_disp_monoidal param_distr'_to_monoidal_section_data := param_distr_bicat_to_monoidal_section_laws FAm FA'm G δ δtr_eq' δpe_eq'. Definition param_distr'_to_monoidal_section_strongtensor: smonoidal_strongtensor Mon_V montrafotarget_disp_monoidal (smonoidal_preserves_tensor Mon_V montrafotarget_disp_monoidal param_distr'_to_monoidal_section_data) := param_distr_bicat_to_monoidal_section_strongtensor FAm FA'm G δ δtr_eq' δpe_eq'. Definition param_distr'_to_monoidal_section_strongunit: smonoidal_strongunit Mon_V montrafotarget_disp_monoidal (smonoidal_preserves_unit Mon_V montrafotarget_disp_monoidal param_distr'_to_monoidal_section_data) := param_distr_bicat_to_monoidal_section_strongunit FAm FA'm G δ δtr_eq' δpe_eq'. Definition param_distr'_to_functor: V ⟶ montrafotarget_totalcat := section_functor montrafotarget_section_disp. Definition param_distr'_to_smf: fmonoidal Mon_V montrafotarget_monoidal param_distr'_to_functor. Proof. apply sectionfunctor_fmonoidal. use tpair. - use tpair. + apply param_distr'_to_monoidal_section_data. + apply param_distr'_to_monoidal_section_laws. - split. + apply param_distr'_to_monoidal_section_strongtensor. + apply param_distr'_to_monoidal_section_strongunit. Defined. End IntoMonoidalSection. Section FromMonoidalSection. Context {sd: section_disp montrafotarget_disp}. Context (ms: smonoidal_data Mon_V montrafotarget_disp_monoidal sd). (** since the laws were anyway trivial to establish, we do not need more than [smonoidal_data] *) Definition δ'_from_ms: H ⟹ H' := section_to_nat_trans_bicat _ _ _ _ sd. Lemma δtr'_eq_from_ms: param_distr'_triangle_eq Mon_V A A' FAm FA'm G δ'_from_ms. Proof. apply param_distr'_triangle_eq_variant0_implies. assert (aux := δtr_eq_from_ms(C:=bicat_of_cats) FAm FA'm G sd ms). unfold param_distr'_triangle_eq_variant0. unfold param_distr'_triangle_eq_variant0_RHS. red in aux. unfold param_distr_bicat_triangle_eq_variant0_RHS in aux. etrans. { exact aux. } cbn. rewrite (nat_trans_comp_id_right A' (functor_composite G (functor_identity A')) G). apply (nat_trans_eq A'). intro a. cbn. apply maponpaths, id_left. Qed. Lemma δpe'_eq_from_ms: param_distr'_pentagon_eq Mon_V A A' FAm FA'm G δ'_from_ms. Proof. intros v w. apply param_distr'_pentagon_eq_body_variant_implies. assert (aux := δpe_eq_from_ms(C:=bicat_of_cats) FAm FA'm G sd ms v w). red. etrans. { exact aux. } clear aux. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. unfold param_distr'_pentagon_eq_body_variant_RHS. apply (nat_trans_eq A'). intro a. cbn. apply maponpaths. do 3 rewrite id_left. apply idpath. Qed. End FromMonoidalSection. End Functor. End Main. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionOfEndomorphismsInBicat.v000066400000000000000000000107761451125700300307320ustar00rootroot00000000000000(** Constructs the action of the endomorphisms by precomposition on a fixed hom-category of a bicategory Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Import Bicat.Notations. Local Open Scope cat. Section Action_From_Precomposition. Context {C : bicat}. Context (c0 d0: ob C). (* swapping is needed in the following due to the unconventional argument order of the action functor in the def. of actions *) Local Definition Mon_endo: monoidal_cat := swapping_of_monoidal_cat (monoidal_cat_from_bicat_and_ob c0). Local Definition homcat : category := hom c0 d0. Definition precomp_odot : homcat ⊠ Mon_endo ⟶ homcat := functor_composite binswap_pair_functor hcomp_functor. Definition precomp_right_unitor_nat_trans : odot_I_functor Mon_endo homcat precomp_odot ⟹ functor_identity homcat := lunitor_transf c0 d0. Definition precomp_right_unitor : action_right_unitor Mon_endo homcat precomp_odot. Proof. exists precomp_right_unitor_nat_trans. intro f. apply is_z_iso_lunitor. Defined. (* I would like to know how to use the library results better, but there are problems with the order of arguments *) Definition precomp_convertor_nat_trans_data : nat_trans_data (odot_x_odot_y_functor Mon_endo homcat precomp_odot) (odot_x_otimes_y_functor Mon_endo homcat precomp_odot). Proof. intro x. induction x as [x12 x3]. induction x12 as [x1 x2]. apply lassociator. Defined. Lemma precomp_convertor_data_is_nat_trans : is_nat_trans _ _ precomp_convertor_nat_trans_data. Proof. red. intros x x' f. unfold odot_x_odot_y_functor, odot_x_otimes_y_functor, precomp_odot. cbn. apply hcomp_lassoc. Qed. Definition precomp_convertor_nat_trans : odot_x_odot_y_functor Mon_endo homcat precomp_odot ⟹ odot_x_otimes_y_functor Mon_endo homcat precomp_odot := (precomp_convertor_nat_trans_data,,precomp_convertor_data_is_nat_trans). Definition precomp_convertor : action_convertor Mon_endo homcat precomp_odot. Proof. exists precomp_convertor_nat_trans. intro x. apply is_z_iso_lassociator. Defined. Lemma action_from_precomp_laws : action_triangle_eq Mon_endo homcat precomp_odot precomp_right_unitor precomp_convertor × action_pentagon_eq Mon_endo homcat precomp_odot precomp_convertor. Proof. split. - red. cbn. intros a x. rewrite hcomp_identity_right. rewrite hcomp_identity_left. apply pathsinv0. apply runitor_rwhisker. - red. cbn. intros a x y z. rewrite hcomp_identity_left. rewrite hcomp_identity_right. apply pathsinv0. apply lassociator_lassociator. Qed. Definition action_from_precomp : action Mon_endo homcat. Proof. exists precomp_odot. exists precomp_right_unitor. exists precomp_convertor. exact action_from_precomp_laws. Defined. End Action_From_Precomposition. Section Instantiation_To_Bicategory_Of_Categories. Context (C D : category). Local Definition actfromprecomp : action (Mon_endo(C:=bicat_of_cats) C) (homcat(C:=bicat_of_cats) C D) := action_from_precomp(C:=bicat_of_cats) C D. (* the following is not possible since the notions for functor the functor are not precise instances of the bicategorical ones: Lemma actfromprecomp_odot_ok : pr1 actfromprecomp = binswap_pair_functor ∙ (functorial_composition C C D hs hsD). Proof. UniMath.MoreFoundations.Tactics.show_id_type. cbn. unfold precomp_odot. apply idpath. *) Lemma actfromprecomp_odot_pointwise_ok (g : functor C D) (f: functor C C) : pr1 actfromprecomp (g,,f) = (binswap_pair_functor ∙ (functorial_composition _ _ _)) (g,,f). Proof. cbn. apply idpath. Qed. End Instantiation_To_Bicategory_Of_Categories. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionOfEndomorphismsInBicatWhiskered.v000066400000000000000000000306231451125700300325710ustar00rootroot00000000000000(** Constructs the actegory with the action of the endomorphisms by precomposition on a fixed hom-category of a bicategory Author: Ralph Matthes 2022, extended in 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Import Bicat.Notations. Import BifunctorNotations. Local Open Scope cat. Section Action_From_Precomposition. Context {C : bicat}. Context (c0 d0 : ob C). Local Definition endocat : category := hom c0 c0. Local Definition Mon_endo: monoidal endocat := monoidal_from_bicat_and_ob c0. Local Definition homcat : category := hom c0 d0. Definition action_from_precomp_data : bifunctor_data endocat homcat homcat. Proof. use make_bifunctor_data. - intros v f. exact (v · f). - intros v f1 f2 β. exact (v ◃ β). - intros f v1 v2 α. exact (α ▹ f). Defined. (* (** we explicitly do not opacify the following definition: *) *) Definition action_from_precomp_laws : is_bifunctor action_from_precomp_data. Proof. split5. - intros v f. apply lwhisker_id2. - intros f v. apply id2_rwhisker. - intros v f1 f2 f3 β1 β2. apply pathsinv0, lwhisker_vcomp. - intros f v1 v2 v3 α1 α2. apply pathsinv0, rwhisker_vcomp. - intros v1 v2 f1 f2 α β. apply vcomp_whisker. Qed. (* Defined. *) Definition action_from_precomp : bifunctor endocat homcat homcat := make_bifunctor action_from_precomp_data action_from_precomp_laws. Definition actegory_from_precomp_data : actegory_data Mon_endo homcat. Proof. exists (pr1 action_from_precomp). split4. - intro f. apply lunitor. - intro f. apply linvunitor. - intros v w f. apply rassociator. - intros v w f. apply lassociator. Defined. Lemma actegory_from_precomp_laws : actegory_laws Mon_endo actegory_from_precomp_data. Proof. split5. - exact action_from_precomp_laws. - split. + intros f g β. cbn. apply vcomp_lunitor. + split. * cbn. apply lunitor_linvunitor. * cbn. apply linvunitor_lunitor. - split4. + intros v w f f' β. cbn. apply lwhisker_lwhisker_rassociator. + intros v v' w f α. cbn. apply pathsinv0, rwhisker_rwhisker_alt. + intros v w w' f α. cbn. apply rwhisker_lwhisker_rassociator. + split. * cbn. apply rassociator_lassociator. * cbn. apply lassociator_rassociator. - intros v f. cbn. apply lunitor_lwhisker. - intros w v v' f. cbn. apply rassociator_rassociator. Qed. Definition actegory_from_precomp : actegory Mon_endo homcat := actegory_from_precomp_data,,actegory_from_precomp_laws. End Action_From_Precomposition. Section LineatorForPostcomposition. Context {C : bicat}. Context (c0 d0 e0 : ob C) (g : hom d0 e0). Definition lax_lineator_postcomp_actegories_from_precomp_data : lineator_data (Mon_endo c0) (actegory_from_precomp c0 d0) (actegory_from_precomp c0 e0) (post_comp c0 g). Proof. intros f k. apply lassociator. Defined. Lemma lax_lineator_postcomp_actegories_from_precomp_laws : lineator_laxlaws (Mon_endo c0) (actegory_from_precomp c0 d0) (actegory_from_precomp c0 e0) (post_comp c0 g) lax_lineator_postcomp_actegories_from_precomp_data. Proof. split4; intro; intros; cbn; unfold lax_lineator_postcomp_actegories_from_precomp_data. - apply rwhisker_lwhisker. - apply pathsinv0, rwhisker_rwhisker. - apply inverse_pentagon_7. - apply lunitor_triangle. Qed. Definition lax_lineator_postcomp_actegories_from_precomp : lineator_lax (Mon_endo c0) (actegory_from_precomp c0 d0) (actegory_from_precomp c0 e0) (post_comp c0 g) := _,,lax_lineator_postcomp_actegories_from_precomp_laws. End LineatorForPostcomposition. Section TheHomogeneousCase. Context {C : bicat}. Context (c0 : ob C). (** requires [action_from_precomp] with known proofs of the laws to hold with convertibility *) Definition action_in_actegory_from_precomp_as_self_action : actegory_action (Mon_endo c0) (actegory_from_precomp c0 c0) = actegory_action (Mon_endo c0) (actegory_with_canonical_self_action (Mon_endo c0)). Proof. use subtypePath. { intro ; apply isaprop_is_bifunctor. } apply idpath. Defined. (* Lemma actegory_from_precomp_as_self_action : actegory_from_precomp c0 c0 = actegory_with_canonical_self_action (Mon_endo c0). Proof. use total2_paths_f. 2: { apply isaprop_actegory_laws. } use total2_paths_f. { apply action_in_actegory_from_precomp_as_self_action. } use total2_paths_f. { apply idpath. } use total2_paths_f. { apply idpath. } apply idpath. Qed. (* slow *) (** we should no longer need the proofs of the laws after this result - is the following command effective? *) (* Opaque action_from_precomp_laws. *) *) (** on the way to what we really need is the following convertibility: *) Lemma lax_lineators_for_actegory_from_precomp_and_self_action_agree (F : functor (endocat c0) (endocat c0)) : lineator_lax (Mon_endo c0) (actegory_from_precomp c0 c0) (actegory_from_precomp c0 c0) F = lineator_lax (Mon_endo c0) (actegory_with_canonical_self_action (Mon_endo c0)) (actegory_with_canonical_self_action (Mon_endo c0)) F. Proof. assert (actegory_with_canonical_self_action (Mon_endo c0) = actegory_from_precomp c0 c0). { use subtypePath. { intro ; apply isaprop_actegory_laws. } apply idpath. } rewrite X. apply idpath. Qed. (* 44s on a modern Intel machine *) (** in fact, we need this with reindexed actegories everywhere *) End TheHomogeneousCase. Section Instantiation_To_Bicategory_Of_Categories. Context (C D : category). Definition actegoryfromprecomp : actegory (Mon_endo(C:=bicat_of_cats) C) (homcat(C:=bicat_of_cats) C D) := actegory_from_precomp(C:=bicat_of_cats) C D. Lemma actegoryfromprecomp_action_pointwise_ok (v : functor C C) (f : functor C D) : v ⊗_{actegoryfromprecomp} f = functor_compose v f. Proof. apply idpath. Qed. (* Transparent action_from_precomp_CAT_laws. *) Definition actegoryfromprecomp_actions_equal_statement : UU := actegory_action (monendocat_monoidal C) (actegory_from_precomp_CAT C D) = actegory_action _ actegoryfromprecomp. Lemma actegoryfromprecomp_actions_equal : actegoryfromprecomp_actions_equal_statement. Proof. apply subtypePath. { intro. apply isaprop_is_bifunctor. } apply idpath. Qed. (* (** on the way to what we really need is the following convertibility: *) Definition lax_lineators_for_actegoryfromprecomp_and_CAT_version_agree_statement (F : functor [C, D] [C, D]) : UU := lineator_lax (monendocat_monoidal C) actegoryfromprecomp actegoryfromprecomp F = lineator_lax (monendocat_monoidal C) (actegory_from_precomp_CAT C D) (actegory_from_precomp_CAT C D) F. (* type-checking not seen to terminate!! *) Lemma lax_lineators_for_actegoryfromprecomp_and_CAT_version_agree (F : functor [C, D] [C, D]) : lax_lineators_for_actegoryfromprecomp_and_CAT_version_agree_statement F. Proof. Time (apply idpath). (* very slow: __ on a modern Intel machine *) Time Qed. (* __ on a modern Intel machine *) (** in fact, we need this with reindexed actegories everywhere *) *) Section DistributionOfCoproducts. Section BinaryCoproduct. Context (BCP : BinCoproducts D). Definition BCP_homcat_CAT : BinCoproducts (homcat(C:=bicat_of_cats) C D). Proof. apply BinCoproducts_functor_precat. exact BCP. Defined. (* Definition actfromprecomp_bincoprod_distributor_data : actegory_bincoprod_distributor_data (Mon_endo(C:=bicat_of_cats) C) BCP_homcat_CAT actegoryfromprecomp. Proof. intro F. apply precomp_bincoprod_distributor_data. (* slow *) Defined. Lemma actfromprecomp_bincoprod_distributor_law : actegory_bincoprod_distributor_iso_law _ _ _ actfromprecomp_bincoprod_distributor_data. Proof. intro F. apply precomp_bincoprod_distributor_law. (* very slow *) Qed. Because type checking is so slow, we redo the construction and proof: *) Definition actfromprecomp_bincoprod_distributor_data : actegory_bincoprod_distributor_data (Mon_endo(C:=bicat_of_cats) C) BCP_homcat_CAT actegoryfromprecomp. Proof. intros F G1 G2. use make_nat_trans. - intro c. apply identity. - abstract (intros c c' f; rewrite id_left; apply id_right). Defined. Definition actfromprecomp_bincoprod_distributor_data_is_instance_up_to_eq : actfromprecomp_bincoprod_distributor_data = fun F => precomp_bincoprod_distributor_data BCP F. Proof. apply funextsec; intro F. apply funextsec; intro G1. apply funextsec; intro G2. apply nat_trans_eq; [ apply D |]. intro x. apply idpath. Qed. Lemma actfromprecomp_bincoprod_distributor_law : actegory_bincoprod_distributor_iso_law _ _ _ actfromprecomp_bincoprod_distributor_data. Proof. intros F G. split. - apply nat_trans_eq; [apply D |]. intro c. cbn. rewrite id_left. apply pathsinv0, BinCoproduct_endo_is_identity. + apply BinCoproductIn1Commutes. + apply BinCoproductIn2Commutes. - etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, BinCoproductArrowEta. } apply maponpaths_12; (rewrite id_right; apply nat_trans_eq; [apply D |]; intro c; apply id_right). Qed. Definition actfromprecomp_bincoprod_distributor : actegory_bincoprod_distributor (Mon_endo(C:=bicat_of_cats) C) BCP_homcat_CAT actegoryfromprecomp := _,,actfromprecomp_bincoprod_distributor_law. End BinaryCoproduct. Section Coproduct. Context {I : UU} (CP : Coproducts I D). Definition CP_homcat_CAT : Coproducts I (homcat(C:=bicat_of_cats) C D). Proof. apply Coproducts_functor_precat. exact CP. Defined. Definition actfromprecomp_coprod_distributor_data : actegory_coprod_distributor_data (Mon_endo(C:=bicat_of_cats) C) CP_homcat_CAT actegoryfromprecomp. Proof. intros F Gs. cbn. use make_nat_trans. - intro c. apply identity. - abstract (intros c c' f; rewrite id_left; apply id_right). Defined. Definition actfromprecomp_coprod_distributor_data_is_instance_up_to_eq : actfromprecomp_coprod_distributor_data = fun F => precomp_coprod_distributor_data CP F. Proof. apply funextsec; intro F. apply funextsec; intro Gs. apply nat_trans_eq; [ apply D |]. intro x. apply idpath. Qed. Lemma actfromprecomp_coprod_distributor_law : actegory_coprod_distributor_iso_law _ _ _ actfromprecomp_coprod_distributor_data. Proof. intros F Gs. split. - apply nat_trans_eq; [apply D |]. intro c. cbn. rewrite id_left. apply pathsinv0, Coproduct_endo_is_identity. intro i. unfold coproduct_nat_trans_data. cbn in Gs. apply (CoproductInCommutes I D (λ i0 : I, Gs i0 (pr1 F c)) (CP _) _ (λ i0 : I, coproduct_nat_trans_in_data I C D CP Gs i0 (pr1 F c)) i). - etrans. { apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, CoproductArrowEta. } apply maponpaths, funextsec; intro i; (rewrite id_right; apply nat_trans_eq; [apply D |]; intro c; apply id_right). Qed. Definition actfromprecomp_coprod_distributor : actegory_coprod_distributor (Mon_endo(C:=bicat_of_cats) C) CP_homcat_CAT actegoryfromprecomp := _,,actfromprecomp_coprod_distributor_law. End Coproduct. End DistributionOfCoproducts. End Instantiation_To_Bicategory_Of_Categories. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/Actions.v000066400000000000000000000531461451125700300246240ustar00rootroot00000000000000(** Generalisation of the concept of actions, over monoidal categories. Originally introduced under the name C-categories (for C a monoidal category) by Bodo Pareigis (1977). This notion is found in G. Janelidze and G.M. Kelly: A Note on Actions of a Monoidal Category, Theory and Applications of Categories, Vol. 9, 2001, No. 4, pp 61-91, who remark that one triangle equation of Pareigis is redundant. The presentation is close to the definitions in the paper "Second-Order and Dependently-Sorted Abstract Syntax" by Marcelo Fiore (2008). The order of the arguments of the action functor has been chosen differently from Janelidze & Kelly, but as in Pareigis. Author of nearly all of the proof lines: Ralph Matthes 2021 **) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsMonoidal. Local Open Scope cat. Section A. Context (Mon_V : monoidal_cat). Local Definition I : Mon_V := monoidal_cat_unit Mon_V. Local Definition tensor : Mon_V ⊠ Mon_V ⟶ Mon_V := monoidal_cat_tensor Mon_V. Notation "X ⊗ Y" := (tensor (X , Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Local Definition α' : associator tensor := monoidal_cat_associator Mon_V. Local Definition λ' : left_unitor tensor I := monoidal_cat_left_unitor Mon_V. Local Definition ρ' : right_unitor tensor I := monoidal_cat_right_unitor Mon_V. Section Actions_Definition. Context (A : category). Section Actions_Natural_Transformations. (* A ⊙ I --> A *) Context (odot : functor (category_binproduct A Mon_V) A). Notation "X ⊙ Y" := (odot (X , Y)) (at level 31). Notation "f #⊙ g" := (# odot (f #, g)) (at level 31). Definition is_z_iso_odot_z_iso {X Y : A} { X' Y' : Mon_V} {f : X --> Y} {g : X' --> Y'} (f_is_z_iso : is_z_isomorphism f) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (f #⊙ g). Proof. exact (functor_on_is_z_isomorphism _ (is_z_iso_binprod_z_iso f_is_z_iso g_is_z_iso)). Defined. Definition odot_I_functor : functor A A := functor_fix_snd_arg _ _ _ odot I. Lemma odot_I_functor_ok: functor_on_objects odot_I_functor = λ a, a ⊙ I. Proof. apply idpath. Qed. Definition action_right_unitor : UU := nat_z_iso odot_I_functor (functor_identity A). Definition action_right_unitor_funclass (μ : action_right_unitor): ∏ x : ob A, odot_I_functor x --> x := pr1 (nat_z_iso_to_trans μ). Coercion action_right_unitor_funclass : action_right_unitor >-> Funclass. Definition action_right_unitor_to_nat_trans (μ : action_right_unitor) : nat_trans odot_I_functor (functor_identity A) := nat_z_iso_to_trans μ. Coercion action_right_unitor_to_nat_trans: action_right_unitor >-> nat_trans. Definition odot_x_odot_y_functor : (A ⊠ Mon_V) ⊠ Mon_V ⟶ A := functor_composite (pair_functor odot (functor_identity _)) odot. Lemma odot_x_odot_y_functor_ok: functor_on_objects odot_x_odot_y_functor = λ a, (ob1 (ob1 a) ⊙ ob2 (ob1 a)) ⊙ ob2 a. Proof. apply idpath. Qed. Definition odot_x_otimes_y_functor : (A ⊠ Mon_V) ⊠ Mon_V ⟶ A := functor_composite (precategory_binproduct_unassoc _ _ _) (functor_composite (pair_functor (functor_identity _) tensor) odot). Lemma odot_x_otimes_y_functor_ok: functor_on_objects odot_x_otimes_y_functor = λ a, ob1 (ob1 a) ⊙ (ob2 (ob1 a) ⊗ ob2 a). Proof. apply idpath. Qed. Definition action_convertor : UU := nat_z_iso odot_x_odot_y_functor odot_x_otimes_y_functor. Definition action_convertor_funclass (χ : action_convertor): ∏ x : ob ((A ⊠ Mon_V) ⊠ Mon_V), odot_x_odot_y_functor x --> odot_x_otimes_y_functor x := pr1 (nat_z_iso_to_trans χ). Coercion action_convertor_funclass : action_convertor >-> Funclass. Definition action_convertor_to_nat_trans (χ : action_convertor) : nat_trans odot_x_odot_y_functor odot_x_otimes_y_functor := nat_z_iso_to_trans χ. Coercion action_convertor_to_nat_trans: action_convertor >-> nat_trans. Definition action_triangle_eq (ϱ : action_right_unitor) (χ : action_convertor) := ∏ (a : A), ∏ (v : Mon_V), (ϱ a) #⊙ (id v) = (χ ((a, I), v)) · (id a) #⊙ (λ' v). (** the original definition by Pareigis has a second triangle equation that is redundant in the context of [action_triangle_eq] and [action_pentagon_eq] (see Janelidze and Kelly 2001 for this claim) *) Definition action_second_triangle_eq (ϱ : action_right_unitor) (χ : action_convertor) := ∏ (a : A), ∏ (v : Mon_V), ϱ (a ⊙ v) = (χ ((a, v), I)) · (id a) #⊙ (ρ' v). Definition action_pentagon_eq (χ : action_convertor) := ∏ (a : A), ∏ (u v w : Mon_V), (χ ((a ⊙ u, v), w)) · (χ ((a, u), v ⊗ w)) = (χ ((a, u), v)) #⊙ (id w) · (χ ((a, u ⊗ v), w)) · (id a) #⊙ (α' ((u, v), w)). End Actions_Natural_Transformations. (* Action over a monoidal category. *) Definition action : UU := ∑ (odot : A ⊠ Mon_V ⟶ A), ∑ (ϱ : action_right_unitor odot), ∑ (χ : action_convertor odot), (action_triangle_eq odot ϱ χ) × (action_pentagon_eq odot χ). Section Projections. Context (actn : action). Definition act_odot : A ⊠ Mon_V ⟶ A := pr1 actn. Definition act_ϱ : action_right_unitor act_odot := pr1 (pr2 actn). Definition act_χ : action_convertor act_odot := pr1 (pr2 (pr2 actn)). Definition act_triangle : action_triangle_eq act_odot act_ϱ act_χ := pr1 (pr2 (pr2 (pr2 actn))). Definition act_pentagon : action_pentagon_eq act_odot act_χ := pr2 (pr2 (pr2 (pr2 actn))). End Projections. Section Alternative_Definition. (** we are following the introductory pages of Janelidze and Kelly, A note on actions of a monoidal category, Theory and Applications of Categories, Vol. 9, No. 4, 2001, pp. 61–91. *) Let Mon_EndA : monoidal_cat := monoidal_cat_of_endofunctors A. Context (FF: strong_monoidal_functor Mon_V Mon_EndA). (* Let FF0 := lax_monoidal_functor_functor _ _ FF. *) Let ϵ : functor_identity A ⟹ (FF I: functor A A) := lax_monoidal_functor_ϵ FF. Let ϵ_inv : (FF I: functor A A) ⟹ functor_identity A := strong_monoidal_functor_ϵ_inv FF. Let μ : monoidal_functor_map Mon_V Mon_EndA FF := lax_monoidal_functor_μ FF. Let ϵ_is_z_iso : is_z_isomorphism (lax_monoidal_functor_ϵ FF) := strong_monoidal_functor_ϵ_is_z_iso FF. Let μ_is_nat_z_iso : is_nat_z_iso (lax_monoidal_functor_μ FF) := strong_monoidal_functor_μ_is_nat_z_iso FF. Let FFunital : monoidal_functor_unitality Mon_V Mon_EndA FF (lax_monoidal_functor_ϵ FF) (lax_monoidal_functor_μ FF) := lax_monoidal_functor_unital FF. Let FFassoc : monoidal_functor_associativity Mon_V Mon_EndA FF (lax_monoidal_functor_μ FF) := lax_monoidal_functor_assoc FF. Local Definition odot : functor (category_binproduct A Mon_V) A := uncurry_functor _ _ _ FF. Local Definition auxρ : nat_z_iso (odot_I_functor odot) (FF I: functor A A). Proof. use make_nat_z_iso. - use tpair. + intro F. apply identity. + cbn. intros F F' α. unfold functor_fix_snd_arg_data. cbn. rewrite id_left, id_right. assert (H := functor_id FF I). apply (maponpaths (fun f => pr1 f F')) in H. etrans. { apply maponpaths. exact H. } apply id_right. - intro F. use make_is_z_isomorphism. + apply identity. + split; apply id_left. Defined. Local Definition ϱ : action_right_unitor odot. Proof. eapply nat_z_iso_comp. - exact auxρ. - use make_nat_z_iso. + exact ϵ_inv. + use nat_trafo_pointwise_z_iso_if_z_iso; [apply A |]. apply is_z_isomorphism_inv. Defined. Local Definition auxχ_dom : nat_z_iso (odot_x_odot_y_functor odot) (functor_composite (precategory_binproduct_unassoc A Mon_V Mon_V) (uncurry_functor _ _ _ (monoidal_functor_map_dom Mon_V Mon_EndA FF))). Proof. use make_nat_z_iso. - use make_nat_trans. + intro auv. apply identity. + intros auv auv' fgg'. rewrite id_left, id_right. cbn. rewrite functor_comp. rewrite <- assoc. apply idpath. - intro auv. use make_is_z_isomorphism. + apply identity. + split; apply id_left. Defined. Local Definition auxχ_codom : nat_z_iso (functor_composite (precategory_binproduct_unassoc A Mon_V Mon_V) (uncurry_functor _ _ _ (monoidal_functor_map_codom Mon_V Mon_EndA FF))) (odot_x_otimes_y_functor odot). Proof. use make_nat_z_iso. - use make_nat_trans. + intro auv. apply identity. + intros auv auv' fgg'. rewrite id_left, id_right. apply idpath. - intro auv. use make_is_z_isomorphism. + apply identity. + split; apply id_left. Defined. Local Definition χ : action_convertor odot. Proof. refine (nat_z_iso_comp auxχ_dom _). refine (nat_z_iso_comp _ auxχ_codom). use make_nat_z_iso. - exact (pre_whisker (precategory_binproduct_unassoc _ _ _) (uncurry_nattrans _ _ _ μ)). - intro auv. induction auv as [[a u] v]. unfold pre_whisker. cbn. exact (nat_trafo_pointwise_z_iso_if_z_iso A _ (μ_is_nat_z_iso (u,,v)) a). Defined. Lemma action_triangle_eq_from_alt: action_triangle_eq odot ϱ χ. Proof. intros a v. cbn. unfold functor_fix_fst_arg_ob. rewrite id_left. rewrite functor_id. do 2 rewrite id_left. rewrite id_right. assert (Hunital1 := pr1 (FFunital v)). apply (maponpaths pr1) in Hunital1. apply toforallpaths in Hunital1. assert (Hunital1inst := Hunital1 a). cbn in Hunital1inst. rewrite id_right in Hunital1inst. apply pathsinv0. transparent assert (aux: (is_z_isomorphism (# (FF v: functor A A) (ϵ_inv a)))). { apply functor_on_is_z_isomorphism. transparent assert (aux1: (is_nat_z_iso ϵ_inv)). { use nat_trafo_pointwise_z_iso_if_z_iso; [apply A |]. apply is_z_iso_inv_from_z_iso. } apply aux1. } apply (z_iso_inv_to_left(C:=A) _ _ _ (# (FF v: functor A A) (ϵ_inv a),,aux)). unfold inv_from_z_iso. cbn. rewrite assoc. apply pathsinv0. etrans. 2: { exact Hunital1inst. } assert (aux2 := functor_id FF v). apply (maponpaths pr1) in aux2. apply toforallpaths in aux2. exact (aux2 a). Qed. Lemma action_pentagon_eq_from_alt: action_pentagon_eq odot χ. Proof. intros a x y z. cbn. rewrite functor_id. do 5 rewrite id_left. do 4 rewrite id_right. assert (aux := functor_id FF z). apply (maponpaths pr1) in aux. apply toforallpaths in aux. rewrite aux. cbn. rewrite id_right. assert (Hassoc := FFassoc x y z). apply (maponpaths pr1) in Hassoc. apply toforallpaths in Hassoc. assert (Hassocinst := Hassoc a). clear Hassoc. cbn in Hassocinst. rewrite id_right, id_left in Hassocinst. do 2 rewrite functor_id in Hassocinst. rewrite id_left in Hassocinst. apply pathsinv0. exact Hassocinst. Qed. Definition action_from_alt: action. Proof. exists odot. exists ϱ. exists χ. exact (action_triangle_eq_from_alt ,, action_pentagon_eq_from_alt). Defined. (** one might also consider the other direction: that an action gives rise to a strong monoidal functor from [Mon_V] to [Mon_EndA], showing that the "concrete" action definition adhered to in the further development is also complete w.r.t. that "generic" definition *) End Alternative_Definition. End Actions_Definition. (* The canonical tensorial action on a monoidal category. *) Definition tensorial_action : action Mon_V. Proof. exists tensor. exists ρ'. exists α'. exact (monoidal_cat_triangle_eq Mon_V,, monoidal_cat_pentagon_eq Mon_V). Defined. (* The action induced by a strong monoidal functor U. *) Section Strong_Monoidal_Functor_Action. Context {Mon_A : monoidal_cat}. Local Definition I_A : Mon_A := monoidal_cat_unit Mon_A. Local Definition tensor_A : Mon_A ⊠ Mon_A ⟶ Mon_A := monoidal_cat_tensor Mon_A. Notation "X ⊗_A Y" := (tensor_A (X , Y)) (at level 31). Notation "f #⊗_A g" := (#tensor_A (f #, g)) (at level 31). Local Definition α_A : associator tensor_A := monoidal_cat_associator Mon_A. Local Definition λ_A : left_unitor tensor_A I_A := monoidal_cat_left_unitor Mon_A. Local Definition ρ_A : right_unitor tensor_A I_A := monoidal_cat_right_unitor Mon_A. Local Definition triangle_eq_A : triangle_eq tensor_A I_A λ_A ρ_A α_A := monoidal_cat_triangle_eq Mon_A. Local Definition pentagon_eq_A : pentagon_eq tensor_A α_A := monoidal_cat_pentagon_eq Mon_A. Context (U : strong_monoidal_functor Mon_V Mon_A). Definition otimes_U_functor : Mon_A ⊠ Mon_V ⟶ Mon_A := functor_composite (pair_functor (functor_identity _) U) tensor_A. Lemma otimes_U_functor_ok: functor_on_objects otimes_U_functor = λ av, ob1 av ⊗_A U (ob2 av). Proof. apply idpath. Qed. Definition U_action_ρ_nat_trans : odot_I_functor Mon_A otimes_U_functor ⟹ functor_identity Mon_A. refine (nat_trans_comp _ _ _ _ ρ_A). unfold odot_I_functor. set (aux := nat_trans_from_functor_fix_snd_morphism_arg _ _ _ tensor_A _ _ (strong_monoidal_functor_ϵ_inv U)). (* aux is "morally" the result, but types do not fully agree, hence we argue more extensionally *) use tpair. - intro a. apply (aux a). - cbn; red. intros a a' f. cbn. rewrite functor_id. exact (pr2 aux a a' f). Defined. Lemma U_action_ρ_nat_trans_ok: nat_trans_data_from_nat_trans U_action_ρ_nat_trans = λ x, id x #⊗_A (strong_monoidal_functor_ϵ_inv U) · ρ_A x. Proof. apply idpath. Qed. Definition U_action_ρ_is_nat_z_iso : is_nat_z_iso U_action_ρ_nat_trans. Proof. intro. cbn. use is_z_iso_comp_of_is_z_isos. - use is_z_iso_tensor_z_iso. + exact (identity_is_z_iso _ ). + apply (is_z_iso_inv_from_z_iso (make_z_iso _ _ (strong_monoidal_functor_ϵ_is_z_iso U))). - exact (pr2 ρ_A c). Defined. Definition U_action_ρ : action_right_unitor Mon_A otimes_U_functor := make_nat_z_iso _ _ U_action_ρ_nat_trans U_action_ρ_is_nat_z_iso. Definition U_action_χ_nat_trans : odot_x_odot_y_functor Mon_A otimes_U_functor ⟹ odot_x_otimes_y_functor Mon_A otimes_U_functor. Proof. apply (nat_trans_comp _ _ _ (pre_whisker (pair_functor (pair_functor (functor_identity _) U) U) α_A)). exact (pre_whisker (precategory_binproduct_unassoc _ _ _) (post_whisker_fst_param (lax_monoidal_functor_μ U) tensor_A)). Defined. Lemma U_action_χ_nat_trans_ok: nat_trans_data_from_nat_trans U_action_χ_nat_trans = λ x, let k := ob1 (ob1 x) in let k' := ob2 (ob1 x) in let k'' := ob2 x in α_A ((k, U k'), U k'') · id k #⊗_A (lax_monoidal_functor_μ U (k', k'')). Proof. apply idpath. Qed. Lemma U_action_χ_is_nat_z_iso : is_nat_z_iso U_action_χ_nat_trans. Proof. intro x. pose (k := ob1 (ob1 x)); pose (k' := ob2 (ob1 x)); pose (k'' := ob2 x). use is_z_iso_comp_of_is_z_isos. - exact (pr2 α_A ((k, U k'), U k'')). - use is_z_iso_tensor_z_iso. + use identity_is_z_iso. + exact (strong_monoidal_functor_μ_is_nat_z_iso U (k', k'')). Defined. Definition U_action_χ : action_convertor Mon_A otimes_U_functor := make_nat_z_iso _ _ U_action_χ_nat_trans U_action_χ_is_nat_z_iso. (* Definition U_action_struct : action_struct. Proof. exists Mon_A. exists otimes_U_functor. (* K ⊗ U I_C -- (1_K ⊗ ϵ^{-1} · λ_D K) --> K *) exists U_action_ρ. exists U_action_χ. exact tt. Defined. *) Lemma U_action_tlaw : action_triangle_eq Mon_A otimes_U_functor U_action_ρ U_action_χ. Proof. red. intros a x. cbn. unfold nat_trans_from_functor_fix_snd_morphism_arg_data. unfold nat_trans_data_post_whisker_fst_param. cbn. unfold make_dirprod. rewrite functor_id. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply pathsinv0. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 2. simpl. unfold make_dirprod. rewrite id_left. rewrite <- (id_left (id U x)). apply pathsinv0. intermediate_path (# tensor_A ((# tensor_A (id a #, strong_monoidal_functor_ϵ_inv U)) #, id U x) · # tensor_A (ρ_A a #, id U x)). { rewrite <- functor_comp. apply idpath. } pose (f := # tensor_A (# tensor_A (id a #, lax_monoidal_functor_ϵ U) #, id U x)). apply (pre_comp_with_z_iso_is_inj'(f:=f)). { use is_z_iso_tensor_z_iso. - use is_z_iso_tensor_z_iso. + exact (identity_is_z_iso _). + exact (strong_monoidal_functor_ϵ_is_z_iso U). - exact (identity_is_z_iso _ ). } rewrite assoc. intermediate_path (# tensor_A (ρ_A a #, id U x)). { apply pathsinv0. etrans. - apply (!(id_left _)). - apply cancel_postcomposition. unfold f. rewrite <- functor_comp. apply pathsinv0. apply functor_id_id. apply pathsdirprod; simpl. + etrans. * apply pathsinv0. apply functor_comp. * apply functor_id_id. apply pathsdirprod; simpl. -- apply id_left. -- apply pathsinv0. apply z_iso_inv_on_left. rewrite id_left. apply idpath. + apply id_left. } (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) rewrite assoc. apply pathsinv0. etrans. { apply cancel_postcomposition. apply (nat_trans_ax α_A ((a, I_A), U x) ((a, U I), U x) ((id a ,, lax_monoidal_functor_ϵ U) ,, id U x)). } simpl. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 2. simpl. unfold make_dirprod. rewrite id_left. (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) rewrite assoc. etrans. - apply maponpaths. eapply (maponpaths (fun u: Mon_A ⟦I_A ⊗_A (U x), U x⟧ => # tensor_A (id a #, u))). apply pathsinv0. apply (lax_monoidal_functor_unital U x). - fold λ_A. (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) apply pathsinv0. apply triangle_eq_A. Qed. Lemma U_action_plaw : action_pentagon_eq Mon_A otimes_U_functor U_action_χ. Proof. red. intros a x y z. cbn. unfold nat_trans_data_post_whisker_fst_param. unfold ob1, ob2. cbn. rewrite functor_id. apply pathsinv0. etrans. { repeat rewrite assoc'. apply maponpaths. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 4. cbn. unfold make_dirprod. rewrite id_left. etrans. { rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. rewrite <- (id_left (id U z)). intermediate_path (# tensor_A ((α_A ((a, U x), U y) #, id U z) · (# tensor_A (id a #, lax_monoidal_functor_μ U (x, y)) #, id U z))). - apply idpath. - apply functor_comp. } etrans. { apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply (nat_trans_ax α_A ((a, U x ⊗_A U y), U z) ((a, U (x ⊗ y)), U z) ((id a ,, lax_monoidal_functor_μ U (x, y)) ,, id U z)). } etrans. { unfold assoc_right. cbn. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 3. cbn. unfold make_dirprod. rewrite id_left. etrans. { do 2 apply maponpaths. rewrite assoc. (* UniMath.MoreFoundations.Tactics.show_id_type. *) eapply (maponpaths (fun u: Mon_A ⟦(U x ⊗_A U y) ⊗_A U z, U (x ⊗ (y ⊗ z))⟧ => id a #⊗_A u)). apply (lax_monoidal_functor_assoc U). } fold α_A. fold tensor_A. fold tensor. etrans. { rewrite assoc. apply maponpaths. rewrite assoc'. rewrite <- (id_left (id a)). intermediate_path (# tensor_A ((id a #, α_A ((U x, U y), U z)) · (id a #, # tensor_A (id U x #, lax_monoidal_functor_μ U (y, z)) · lax_monoidal_functor_μ U (x, y ⊗ z)))). 2: { apply functor_comp. } apply idpath. } etrans. { do 2 apply maponpaths. rewrite <- (id_left (id a)). intermediate_path (# tensor_A ((id a #, # tensor_A (id U x #, lax_monoidal_functor_μ U (y, z))) · (id a #, lax_monoidal_functor_μ U (x, y ⊗ z)))). 2: { apply functor_comp. } apply idpath. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { apply cancel_postcomposition. apply pathsinv0. apply pentagon_eq_A. } (* change (α_A ((tensor_A (a, U x), U y), U z) · α_A ((a, U x), tensor_A (U y, U z)) · # tensor_A (id a #, # tensor_A (id U x #, lax_monoidal_functor_μ U (y, z))) = α_A ((a ⊗_A U x, U y), U z) · # tensor_A (id (a ⊗_A U x) #, lax_monoidal_functor_μ U (y, z)) · α_A ((a, U x), U (y ⊗ z))). *) repeat rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0. apply (nat_trans_ax α_A ((a, U x), U y ⊗_A U z) ((a, U x), U (y ⊗ z)) ((id a ,, id U x) ,, lax_monoidal_functor_μ U (y, z))). } cbn. unfold make_dirprod. apply cancel_postcomposition. (* present the identity in the binary product of categories *) change (# tensor_A (# tensor_A (id (a, U x)) #, lax_monoidal_functor_μ U (y, z)) = # tensor_A (id (a ⊗_A U x) #, lax_monoidal_functor_μ U (y, z))). rewrite functor_id. apply idpath. Qed. Definition U_action : action Mon_A. exists otimes_U_functor. exists U_action_ρ. exists U_action_χ. split. - exact U_action_tlaw. - exact U_action_plaw. Defined. End Strong_Monoidal_Functor_Action. End A. Arguments act_odot {_ _} _. Arguments act_ϱ {_ _} _. Arguments act_χ {_ _} _. Arguments act_triangle {_ _} _. Arguments act_pentagon {_ _} _. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ActionsFormBicategory.v000066400000000000000000000211031451125700300274450ustar00rootroot00000000000000(** Constructs the bicategory of actions, strong action-based functors and their natural transformations The construction goes through a displayed bicategory over the bicategoy of (small) categories. Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorCategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Import Bicat.Notations. Local Open Scope cat. Section FixAMonoidalCategory. Context (Mon_V : monoidal_cat). Local Definition I : Mon_V := monoidal_cat_unit Mon_V. Local Definition tensor : Mon_V ⊠ Mon_V ⟶ Mon_V := monoidal_cat_tensor Mon_V. Notation "X ⊗ Y" := (tensor (X , Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Local Definition α' : associator tensor := monoidal_cat_associator Mon_V. Local Definition λ' : left_unitor tensor I := monoidal_cat_left_unitor Mon_V. Local Definition ρ' : right_unitor tensor I := monoidal_cat_right_unitor Mon_V. Let CAT : bicat := bicat_of_cats. Definition actions_disp_cat_ob_mor : disp_cat_ob_mor CAT. Proof. exists (fun A => action Mon_V A). intros A A' actn actn' F. exact (ob_disp (Strong_Functor_category_displayed Mon_V actn actn') F). Defined. Goal ∏ A A' actn actn' F, pr2 actions_disp_cat_ob_mor A A' actn actn' F = actionbased_strength Mon_V actn actn' F. Proof. intros. apply idpath. Qed. Definition actions_disp_cat_id_comp : disp_cat_id_comp CAT actions_disp_cat_ob_mor. Proof. split. - intros A actn. apply ab_strength_identity_functor. - intros A1 A2 A3 F F' actn1 actn2 actn3 ζ ζ'. apply (ab_strength_composition Mon_V ζ ζ'). Defined. Definition actions_disp_cat_data : disp_cat_data CAT := actions_disp_cat_ob_mor ,, actions_disp_cat_id_comp. Definition actions_disp_2cell_struct : disp_2cell_struct actions_disp_cat_data. Proof. red. intros A A' F F' η actn actn' ζ ζ'. exact (mor_disp(D:=Strong_Functor_category_displayed Mon_V actn actn') ζ ζ' η). Defined. Goal ∏ A A' F F' η actn actn' ζ ζ', actions_disp_2cell_struct A A' F F' η actn actn' ζ ζ' = quantified_strong_functor_category_mor_diagram Mon_V actn actn' (F,, ζ) (F',, ζ') η. Proof. intros. apply idpath. Qed. Definition actions_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells CAT := actions_disp_cat_data ,, actions_disp_2cell_struct. Lemma actions_disp_2cells_isaprop : disp_2cells_isaprop actions_disp_prebicat_1_id_comp_cells. Proof. red. intros A A'. intros. apply impred; intros a; apply impred; intros v. apply (homset_property A'). Qed. Lemma actions_disp_prebicat_ops : disp_prebicat_ops actions_disp_prebicat_1_id_comp_cells. Proof. repeat split. - intros A A' F actn actn' ζ a v. red. cbn. rewrite binprod_id. rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, functor_id. } apply pathsinv0, id_left. - intros A A' F actn actn' ζ a v. red. cbn. rewrite id_right. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } rewrite id_left. rewrite functor_id. apply id_right. - intros A A' F actn actn' ζ a v. red. cbn. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } do 2 rewrite id_left. apply id_right. - intros A A' F actn actn' ζ a v. red. cbn. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } rewrite functor_id. rewrite id_left. apply idpath. - intros A A' F actn actn' ζ a v. red. cbn. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } do 2 rewrite id_left. apply id_right. - intros A1 A2 A3 A4 F1 F2 F3 actn1 actn2 actn3 actn4 ζ1 ζ2 ζ3 a v. red. cbn. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } rewrite id_right, id_left. rewrite <- assoc. apply maponpaths. apply functor_comp. - intros A1 A2 A3 A4 F1 F2 F3 actn1 actn2 actn3 actn4 ζ1 ζ2 ζ3 a v. red. cbn. rewrite binprod_id. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_id. } rewrite id_right, id_left. rewrite <- assoc. apply maponpaths. apply pathsinv0, functor_comp. - intros A A' F1 F2 F3 η η' actn actn' ζ1 ζ2 ζ3 Hypη Hypη' a v. red. cbn. rewrite <- (id_left (id v)). rewrite binprod_comp. etrans. 2: { apply cancel_postcomposition, pathsinv0, functor_comp. } assert (Hypηinst := Hypη a v). assert (Hypη'inst := Hypη' a v). red in Hypηinst, Hypη'inst. etrans. { rewrite assoc. apply cancel_postcomposition. exact Hypηinst. } etrans. { rewrite <- assoc. apply maponpaths. exact Hypη'inst. } apply assoc. - intros A1 A2 A3 F G1 G2 η actn1 actn2 actn3 ζ ζ1 ζ2 Hypη a v. red. cbn. assert (Hypηinst := Hypη (pr1 F a) v). red in Hypηinst. unfold ActionBasedStrongFunctorCategory.ζ in Hypηinst. cbn in Hypηinst. etrans. 2: { rewrite assoc. apply cancel_postcomposition. exact Hypηinst. } do 2 rewrite <- assoc. apply maponpaths. apply nat_trans_ax. - intros A1 A2 A3 F1 F2 G η actn1 actn2 actn3 ζ1 ζ2 ζ Hypη a v. red. cbn. assert (Hypηinst := Hypη a v). red in Hypηinst. unfold ActionBasedStrongFunctorCategory.ζ in Hypηinst. cbn in Hypηinst. etrans. { rewrite <- assoc. apply maponpaths. apply pathsinv0, functor_comp. } etrans. { do 2 apply maponpaths. exact Hypηinst. } clear Hypηinst. rewrite functor_comp. do 2 rewrite assoc. apply cancel_postcomposition. assert (ζnatinst := nat_trans_ax (pr1 ζ) (pr1 F1 a,, v) (pr1 F2 a,, v) (pr1 η a,, id₁ v)). apply pathsinv0, ζnatinst. Qed. Definition actions_disp_prebicat_data : disp_prebicat_data CAT := actions_disp_prebicat_1_id_comp_cells ,, actions_disp_prebicat_ops. (** the laws are all trivial since the 2-cells do not come with data on top of the natural transformations of the base bicategory [CAT] - this shows the benefits of the displayed approach *) Lemma actions_disp_prebicat_laws : disp_prebicat_laws actions_disp_prebicat_data. Proof. repeat split; red; intros; apply actions_disp_2cells_isaprop. Qed. Definition actions_disp_prebicat : disp_prebicat CAT := actions_disp_prebicat_data ,, actions_disp_prebicat_laws. Lemma actions_has_disp_cellset : has_disp_cellset actions_disp_prebicat. Proof. red. intros A A'. intros. cbn. apply isasetaprop. apply actions_disp_2cells_isaprop. Qed. Definition actions_disp_bicat : disp_bicat CAT := actions_disp_prebicat ,, actions_has_disp_cellset. Definition actions_disp_locally_groupoid : disp_locally_groupoid actions_disp_bicat. Proof. red. intros A A' F F' invertibleη actn actn' ζ ζ' Hypη. use tpair. - intros a v. red. assert (Hypηinst := Hypη a v). red in Hypηinst. apply pathsinv0. set (η_nat_z_iso := nat_z_iso_from_z_iso (homset_property A') invertibleη). set (η_nat_z_iso_inst1 := nat_z_iso_pointwise_z_iso η_nat_z_iso (ActionBasedStrongFunctorCategory.odot Mon_V actn (a, v))). apply (z_iso_inv_on_left _ _ _ _ η_nat_z_iso_inst1). rewrite <- assoc. set (η_nat_z_iso_inst2 := nat_z_iso_pointwise_z_iso η_nat_z_iso a). set (aux1_z_iso := precatbinprod_z_iso η_nat_z_iso_inst2 (identity_z_iso v)). set (aux2_z_iso := functor_on_z_iso (ActionBasedStrongFunctorCategory.odot' Mon_V actn') aux1_z_iso). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ aux2_z_iso). exact Hypηinst. - split; apply actions_disp_2cells_isaprop. Defined. Definition actions_bicat : bicat := total_bicat actions_disp_bicat. End FixAMonoidalCategory. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfActegories.v000066400000000000000000000201601451125700300265270ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022 *) (** ********************************************************** constructs the bicategory of (elementarily defined) actegories with lax morphisms as 1-cells ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Section A. Context {V : category} (Mon_V : monoidal V). Section TheConstruction. Definition disp_actbicat_disp_ob_mor : disp_cat_ob_mor bicat_of_cats. Proof. exists (actegory Mon_V). exact (λ C D ActC ActD F, lineator_lax Mon_V ActC ActD F). Defined. Definition disp_actbicat_disp_id_comp : disp_cat_id_comp bicat_of_cats disp_actbicat_disp_ob_mor. Proof. split. - intros C F. apply identity_lineator_lax. - intros C D E ActC ActD ActE N O. apply comp_lineator_lax. Defined. Definition disp_actbicat_disp_catdata : disp_cat_data bicat_of_cats := (disp_actbicat_disp_ob_mor,,disp_actbicat_disp_id_comp). Definition bidisp_actbicat_disp_2cell_struct : disp_2cell_struct disp_actbicat_disp_ob_mor. Proof. intros C D F G ξ ActC ActD. exact (λ Fl Gl, is_linear_nat_trans (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G) ξ). Defined. Lemma isaprop_bidisp_actbicat_disp_2cell_struct {C D : bicat_of_cats} {F G : bicat_of_cats ⟦C,D⟧ } {ξ : prebicat_cells bicat_of_cats F G} {ActC : disp_actbicat_disp_catdata C} {ActD : disp_actbicat_disp_catdata D} (Fl : ActC -->[F] ActD) (Gl : ActC -->[G] ActD) : isaprop (bidisp_actbicat_disp_2cell_struct C D F G ξ ActC ActD Fl Gl). Proof. apply isaprop_is_linear_nat_trans. Qed. Definition bidisp_actbicat_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_cats := (disp_actbicat_disp_catdata,, bidisp_actbicat_disp_2cell_struct). Lemma bidisp_actbicat_disp_prebicat_ops : disp_prebicat_ops bidisp_actbicat_disp_prebicat_1_id_comp_cells. Proof. repeat split; cbn; unfold bidisp_actbicat_disp_2cell_struct, comp_lineator, identity_lineator. (** first 5 quantified equations for identity, then 5 quantified equations for composition *) - intros. apply is_linear_nat_trans_identity. - intros C D F ActC ActD lin v c. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold identity_lineator_data. rewrite functor_id. do 2 rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). } apply pathsinv0, id_left. - intros C D F ActC ActD lin v c. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold identity_lineator_data. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). } apply id_right. - intros C D F ActC ActD lin v c. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold identity_lineator_data. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). } rewrite functor_id. apply pathsinv0, id_left. - intros C D F ActC ActD lin v c. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold identity_lineator_data. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). } do 2 rewrite id_left. apply id_right. (** now towards composition *) - intros C1 C2 C3 C4 F G H ActC1 ActC2 ActC3 ActC4 Fl Gl Hl v x. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold comp_lineator_data. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActC4). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply functor_comp. - intros C1 C2 C3 C4 F G H ActC1 ActC2 ActC3 ActC4 Fl Gl Hl v x. cbn. unfold comp_lineator_data, identity_lineator_lax. cbn. unfold comp_lineator_data. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActC4). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. - intros C D F G H α β ActC ActD Fl Gl Hl linα linβ v x. cbn. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftcomp ActD). } rewrite assoc. etrans. { apply cancel_postcomposition. apply (linα v x). } repeat rewrite assoc'. apply maponpaths. apply linβ. - intros C D E F G1 G2 β ActC ActD ActE Fl G1l G2l linβ v x. cbn. unfold comp_lineator_data. assert (aux := linβ v (F x)). etrans. 2: { rewrite assoc. apply cancel_postcomposition. exact aux. } clear aux. repeat rewrite assoc'. apply maponpaths. apply nat_trans_ax. - intros C D E F1 F2 G α ActC ActD ActE F1l F2l Gl linα v x. cbn. unfold comp_lineator_data. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. } etrans. { do 2 apply maponpaths. apply linα. } rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, lineator_linnatleft. Qed. Definition bidisp_actbicat_disp_prebicat_data : disp_prebicat_data bicat_of_cats := (bidisp_actbicat_disp_prebicat_1_id_comp_cells,, bidisp_actbicat_disp_prebicat_ops). Definition bidisp_actbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_actbicat_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_actbicat_disp_2cell_struct. Qed. Definition bidisp_actbicat_disp_prebicat : disp_prebicat bicat_of_cats := (bidisp_actbicat_disp_prebicat_data,,bidisp_actbicat_disp_prebicat_laws). Definition bidisp_actbicat_disp_bicat : disp_bicat bicat_of_cats. Proof. refine (bidisp_actbicat_disp_prebicat,, _). red; intros ? ? ? ? ? ? ? ? ?. apply isasetaprop. apply isaprop_bidisp_actbicat_disp_2cell_struct. Defined. Lemma actbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_actbicat_disp_bicat. Proof. red. intros. apply isaprop_bidisp_actbicat_disp_2cell_struct. Qed. Definition actbicat : bicat := total_bicat bidisp_actbicat_disp_bicat. End TheConstruction. Definition actbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_actbicat_disp_bicat. Proof. red. intros C D F G αiso ActC ActD Fl Gl islin. use tpair. - transparent assert (isnziα : (is_nat_z_iso (pr11 αiso))). { apply (nat_trafo_pointwise_z_iso_if_z_iso (pr2 D)). exact (pr2 αiso). } exact (is_linear_nat_trans_pointwise_inverse (Fl : lineator_lax _ _ _ _) (Gl : lineator_lax _ _ _ _) (pr1 αiso) isnziα islin). - split; apply isaprop_bidisp_actbicat_disp_2cell_struct. Defined. End A. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfActegoriesFinalObject.v000066400000000000000000000064421451125700300306370ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022 *) (** ********************************************************** constructs the final object of the bicategory of (elementarily defined) actegories in a separate file to reduce dependencies of the base file ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Examples.BicatOfCatsLimits. Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Section A. Context {V : category} (Mon_V : monoidal V). Definition unit_actegory : actegory Mon_V (pr1 unit_category). Proof. use tpair. - use tpair. + use make_bifunctor_data. * exact (fun _ _ => tt). * intros. apply idpath. * intros. apply idpath. + cbn. repeat split; intro x; induction x; apply isapropunit. - cbn. split. + repeat split; intro x; induction x; apply isapropunit. + cbn. abstract (split; [| split; [| split]]; [red; split; red; intros; [apply isasetunit | split; apply isasetunit] | red; do 3 (split; [red; intros; apply isasetunit |]); split; apply isasetunit | red; intros; apply isasetunit | red; intros; apply isasetunit]). Defined. Definition unit_actegory_disp_bifinal_obj : disp_bifinal_obj_stronger (bidisp_actbicat_disp_bicat Mon_V) (_,,bifinal_cats). Proof. exists unit_actegory. use tpair. - intros C ActC. cbn. use tpair. + split; red; intros; apply idpath. + abstract (repeat split). - intros x xx f g ff gg. red; cbn; red; cbn. red; intros; apply isasetunit. Defined. Definition bifinal_actegories : bifinal_obj (actbicat Mon_V). Proof. use total_bicat_final_stronger. - exact (actbicat_disp_2cells_isaprop Mon_V). - exact (_,,bifinal_cats). - exact unit_actegory_disp_bifinal_obj. Defined. End A. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfActionsInBicat.v000066400000000000000000000747431451125700300273140ustar00rootroot00000000000000(** introduces monoidal actions in a bicategorical setting This lifts to bicategories the view on actions as put forward in G. Janelidze and G.M. Kelly: A Note on Actions of a Monoidal Category, Theory and Applications of Categories, Vol. 9, 2001, No. 4, pp 61-91. The strength notion for the morphisms between actions is taken from B. Ahrens, R. Matthes and A. Mörtberg: Implementing a category-theoretic framework for typed abstract syntax, Proceedings CPP'22. Authors: Ralph Matthes and Kobe Wullaert 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Import Bicat.Notations. Import BifunctorNotations. Import DisplayedBifunctorNotations. Local Open Scope cat. Section FixMoncatAndBicat. Context {V : category}. Context (Mon_V : monoidal V). Notation "X ⊗ Y" := (X ⊗_{ Mon_V } Y). Context (B : bicat). Definition disp_actionbicat_disp_mor {a0 a0' : B} {FA : V ⟶ category_from_bicat_and_ob a0} (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA) {FA' : V ⟶ category_from_bicat_and_ob a0'} (FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0') FA') (G : B ⟦ a0, a0' ⟧): UU := ∑ δ : parameterized_distributivity_bicat_nat G, param_distr_bicat_triangle_eq Mon_V FAm FA'm G δ × param_distr_bicat_pentagon_eq Mon_V FAm FA'm G δ. Lemma disp_actionbicat_disp_mor_eq {a0 a0' : B} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a0'} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0') FA'} {G : B ⟦ a0, a0' ⟧} (pm1 pm2: disp_actionbicat_disp_mor FAm FA'm G): pr1 pm1 = pr1 pm2 -> pm1 = pm2. Proof. intro Hyp. apply subtypePath. - intro δ. apply isapropdirprod. + apply isaprop_param_distr_bicat_triangle_eq. + apply isaprop_param_distr_bicat_pentagon_eq. - exact Hyp. Qed. Definition disp_actionbicat_disp_ob_mor : disp_cat_ob_mor B. Proof. use tpair. - intro a0. exact (∑ FA: functor V (category_from_bicat_and_ob a0), fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA). - intros a0 a0' [FA FAm] [FA' FA'm] G. exact (disp_actionbicat_disp_mor FAm FA'm G). Defined. Definition disp_actionbicat_disp_id_nat_trans {a : B} {FA : V ⟶ category_from_bicat_and_ob a} (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA): H(V:=V)(FA':=FA) (id₁ a) ⟹ H'(FA:=FA) (id₁ a). Proof. use make_nat_trans. * intro v. cbn. exact (lunitor _ • rinvunitor _). * abstract ( intros v w f; cbn; rewrite vassocr; rewrite vcomp_lunitor; do 2 rewrite vassocl; apply maponpaths; apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _)); rewrite vassocl; rewrite vcomp_runitor; rewrite vassocr; rewrite rinvunitor_runitor; apply id2_left ). Defined. Lemma disp_actionbicat_disp_id_triangle {a : B} {FA : V ⟶ category_from_bicat_and_ob a} (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA): param_distr_bicat_triangle_eq Mon_V FAm FAm (id₁ a) (disp_actionbicat_disp_id_nat_trans FAm). Proof. red; cbn. rewrite vassocr. rewrite vcomp_lunitor. do 2 rewrite vassocl. rewrite lunitor_id_is_left_unit_id. apply maponpaths. apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _)). rewrite vassocl. apply pathsinv0, (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lunitor _)). rewrite vcomp_runitor. rewrite lunitor_id_is_left_unit_id. apply idpath. Qed. Lemma disp_actionbicat_disp_id_pentagon {a : B} {FA : V ⟶ category_from_bicat_and_ob a} (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA): param_distr_bicat_pentagon_eq Mon_V FAm FAm (id₁ a) (disp_actionbicat_disp_id_nat_trans FAm). Proof. red; cbn. intros v w. unfold param_distr_bicat_pentagon_eq_body, param_distr_bicat_pentagon_eq_body_RHS. cbn. etrans. { rewrite vassocl. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply vcomp_lunitor. } etrans. { repeat rewrite vassocr. apply idpath. } apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _)). etrans. { rewrite !vassocl. (* instead of repeat rewrite vassocl - hint by Niels van der Weide *) apply idpath. } rewrite vcomp_runitor. repeat rewrite vassocr. apply maponpaths_2. (* now pure bicategorical reasoning *) rewrite <- rwhisker_vcomp. rewrite <- lwhisker_vcomp. rewrite <- runitor_triangle. rewrite <- lunitor_triangle. etrans. 2: { rewrite vassocr. rewrite rassociator_lassociator. apply pathsinv0, id2_left. } etrans. { repeat rewrite vassocr. apply maponpaths_2. repeat rewrite vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. } repeat rewrite vassocl. etrans. { do 4 apply maponpaths. rewrite lwhisker_vcomp. rewrite rinvunitor_runitor. apply lwhisker_id2. } rewrite id2_right. etrans. 2: { apply id2_right. } apply maponpaths. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. apply id2_rwhisker. Qed. Definition disp_actionbicat_disp_comp_nat_trans_data {a0 a1 a2 : B} {g1 : B ⟦ a0, a1 ⟧} {g2 : B ⟦ a1, a2 ⟧} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a1} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'} {FA'' : V ⟶ category_from_bicat_and_ob a2} {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''} (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1) (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2): nat_trans_data (H(V:=V)(FA':=FA'') (g1 · g2)) (H'(FA:=FA) (g1 · g2)). Proof. intro v. cbn. exact (rassociator g1 g2 (FA'' v) • ((g1 ◃ (pr1 Hyp2 v)) • ((lassociator g1 (FA' v) g2 • ((pr1 Hyp1 v) ▹ g2) : g1 · H' g2 v ==> FA v · g1 · g2) • rassociator (FA v) g1 g2))). (* refine (vcomp2 _ _). { apply rassociator. } refine (vcomp2 _ _). { apply lwhisker. apply Hyp2. } refine (vcomp2 _ _). 2: { apply rassociator. } cbn. refine (vcomp2 _ _). { apply lassociator. } apply rwhisker. apply Hyp1. *) Defined. Lemma disp_actionbicat_disp_comp_is_nat_trans {a0 a1 a2 : B} {g1 : B ⟦ a0, a1 ⟧} {g2 : B ⟦ a1, a2 ⟧} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a1} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'} {FA'' : V ⟶ category_from_bicat_and_ob a2} {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''} (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1) (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2): is_nat_trans _ _ (disp_actionbicat_disp_comp_nat_trans_data Hyp1 Hyp2). Proof. intros v w f. unfold disp_actionbicat_disp_comp_nat_trans_data. cbn; rewrite vassocr. rewrite (! lwhisker_lwhisker_rassociator _ _ _ _ _ _ _ _ _). rewrite vassocr. etrans. { apply maponpaths_2. rewrite vassocl. apply maponpaths. exact (lwhisker_vcomp g1 (g2 ◃ # FA'' f) (pr1 Hyp2 w)). } etrans. 2: { rewrite !vassocr. rewrite vassocl. apply maponpaths. apply rwhisker_rwhisker_alt. } rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths_2. apply maponpaths. exact (pr21 Hyp2 v w f). } etrans. 2: { rewrite vassocl. apply maponpaths. rewrite rwhisker_vcomp. apply maponpaths. exact (pr21 Hyp1 v w f). } cbn. rewrite (! lwhisker_vcomp _ _ _). do 3 rewrite vassocl. apply maponpaths. rewrite vassocr. etrans. 2: { rewrite (! rwhisker_vcomp _ _ _). rewrite vassocr. apply idpath. } apply maponpaths_2. apply rwhisker_lwhisker. Qed. Definition disp_actionbicat_disp_comp_nat_trans {a0 a1 a2 : B} {g1 : B ⟦ a0, a1 ⟧} {g2 : B ⟦ a1, a2 ⟧} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a1} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'} {FA'' : V ⟶ category_from_bicat_and_ob a2} {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''} (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1) (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2): parameterized_distributivity_bicat_nat(V:=V)(FA:=FA)(FA':=FA'') (g1 · g2) := _,, disp_actionbicat_disp_comp_is_nat_trans Hyp1 Hyp2. Lemma disp_actionbicat_disp_comp_triangle {a0 a1 a2 : B} {g1 : B ⟦ a0, a1 ⟧} {g2 : B ⟦ a1, a2 ⟧} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a1} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'} {FA'' : V ⟶ category_from_bicat_and_ob a2} {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''} (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1) (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2): param_distr_bicat_triangle_eq Mon_V FAm FA''m (g1 · g2) (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2). Proof. red; cbn. unfold disp_actionbicat_disp_comp_nat_trans_data. assert (aux1 := pr12 Hyp1). assert (aux2 := pr12 Hyp2). apply param_distr_bicat_triangle_eq_variant0_follows in aux1. apply param_distr_bicat_triangle_eq_variant0_follows in aux2. red in aux1, aux2; cbn in aux1, aux2. rewrite aux1, aux2. clear Hyp1 Hyp2 aux1 aux2. unfold param_distr_bicat_triangle_eq_variant0_RHS. repeat rewrite <- lwhisker_vcomp. repeat rewrite <- rwhisker_vcomp. etrans. { repeat rewrite lassocr. apply maponpaths. repeat rewrite vassocr. rewrite lwhisker_lwhisker_rassociator. apply idpath. } etrans. { repeat rewrite vassocr. do 10 apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservesunitstrongly FA''m)). } cbn. rewrite lwhisker_id2. rewrite id2_left. etrans. { repeat rewrite vassocl. do 3 apply maponpaths. repeat rewrite vassocr. do 5 apply maponpaths_2. apply rwhisker_lwhisker. } etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. repeat rewrite vassocl. do 4 apply maponpaths. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. do 2 apply maponpaths. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservesunitstrongly FA'm)). } cbn. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_right. etrans. { repeat rewrite vassocl. rewrite rwhisker_rwhisker_alt. apply idpath. } repeat rewrite vassocr. apply maponpaths_2. (* now pure bicategorical reasoning *) rewrite <- runitor_triangle. apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lunitor _)). rewrite <- lunitor_triangle. repeat rewrite vassocr. etrans. { apply maponpaths_2. repeat rewrite vassocl. rewrite rassociator_lassociator. rewrite id2_right. apply idpath. } etrans. { repeat rewrite vassocl. rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. rewrite id2_rwhisker. rewrite id2_right. apply idpath. } etrans. 2: { apply id2_right. } repeat rewrite vassocl. do 2 apply maponpaths. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. apply lwhisker_id2. Qed. Lemma disp_actionbicat_disp_comp_pentagon {a0 a1 a2 : B} {g1 : B ⟦ a0, a1 ⟧} {g2 : B ⟦ a1, a2 ⟧} {FA : V ⟶ category_from_bicat_and_ob a0} {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA} {FA' : V ⟶ category_from_bicat_and_ob a1} {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'} {FA'' : V ⟶ category_from_bicat_and_ob a2} {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''} (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1) (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2): param_distr_bicat_pentagon_eq Mon_V FAm FA''m (g1 · g2) (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2). Proof. intros v w. red; cbn. unfold param_distr_bicat_pentagon_eq_body_RHS, disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data. set (aux1 := pr22 Hyp1 v w). set (aux2 := pr22 Hyp2 v w). apply param_distr_bicat_pentagon_eq_body_variant_follows in aux1. apply param_distr_bicat_pentagon_eq_body_variant_follows in aux2. red in aux1, aux2; cbn in aux1, aux2. rewrite aux1, aux2. clear aux1 aux2. unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS. induction Hyp1 as [δ1 [trieq1 pentaeq1]]. induction Hyp2 as [δ2 [trieq2 pentaeq2]]. cbn. clear trieq1 trieq2 pentaeq1 pentaeq2. repeat rewrite rwhisker_vcomp. repeat rewrite <- lwhisker_vcomp. etrans. { repeat rewrite vassocl. apply maponpaths. repeat rewrite vassocr. do 10 apply maponpaths_2. apply pathsinv0, lwhisker_lwhisker_rassociator. } etrans. { repeat rewrite vassocl. do 2 apply maponpaths. repeat rewrite vassocr. do 9 apply maponpaths_2. etrans. { rewrite lwhisker_vcomp. apply maponpaths. rewrite lwhisker_vcomp. apply maponpaths. apply (pr2 (fmonoidal_preservestensorstrongly FA''m v w)). } cbn. rewrite lwhisker_id2. apply lwhisker_id2. } rewrite id2_left. etrans. { repeat rewrite vassocr. apply idpath. } apply pathsinv0. apply (vcomp_move_L_Vp _ _ _ (is_invertible_2cell_lassociator _ _ _)). etrans. { repeat rewrite vassocl. do 8 apply maponpaths. apply pathsinv0, rwhisker_rwhisker. } repeat rewrite <- rwhisker_vcomp. repeat rewrite vassocr. apply maponpaths_2. etrans. 2: { do 5 apply maponpaths_2. repeat rewrite vassocl. do 7 apply maponpaths. etrans. 2: { rewrite vassocr. apply maponpaths_2. apply pathsinv0, rwhisker_lwhisker. } rewrite vassocl. apply maponpaths. rewrite rwhisker_vcomp. apply maponpaths. rewrite lwhisker_vcomp. apply maponpaths. apply pathsinv0, (pr2 (fmonoidal_preservestensorstrongly FA'm v w)). } cbn. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_right. (* the equation is now free from the preservation of the tensor by the given strong monoidal functors; both sides of the equation are chains of 13 two-cells *) etrans. 2: { repeat rewrite vassocl. do 6 apply maponpaths. repeat rewrite vassocr. do 4 apply maponpaths_2. apply pathsinv0, lassociator_lassociator. } etrans. { repeat rewrite vassocl. do 4 apply maponpaths. repeat rewrite vassocr. do 6 apply maponpaths_2. apply rassociator_rassociator. } (* both sides of the equation are chains of 12 two-cells *) etrans. 2: { repeat rewrite vassocr. do 10 apply maponpaths_2. apply rassociator_rassociator. } repeat rewrite vassocl. apply maponpaths. etrans. 2: { repeat rewrite vassocr. do 8 apply maponpaths_2. etrans. 2: { apply maponpaths_2. rewrite vassocl. etrans. 2: { apply maponpaths. rewrite lwhisker_vcomp. apply maponpaths. apply pathsinv0, rassociator_lassociator. } rewrite lwhisker_id2. apply pathsinv0, id2_right. } apply pathsinv0, rwhisker_lwhisker_rassociator. } repeat rewrite vassocl. apply maponpaths. (* two occurrences of [δ2] vanished *) etrans. { apply maponpaths. repeat rewrite vassocr. do 5 apply maponpaths_2. rewrite rwhisker_rwhisker_alt. rewrite vassocl. rewrite lwhisker_lwhisker_rassociator. rewrite vassocl. apply maponpaths. rewrite vassocr. apply maponpaths_2. apply vcomp_whisker. } etrans. 2: { do 2 apply maponpaths. repeat rewrite vassocr. do 3 apply maponpaths_2. rewrite lwhisker_lwhisker. rewrite vassocl. rewrite rwhisker_rwhisker. apply idpath. } assert (Haux: (lassociator g1 (FA' v) g2 ▹ FA'' w) • rassociator (g1 · FA' v) g2 (FA'' w) = rassociator g1 (FA' v · g2) (FA'' w) • (g1 ◃ rassociator (FA' v) g2 (FA'' w)) • lassociator g1 (FA' v) (g2 · FA'' w)). { etrans. 2: { rewrite vassocl. apply inverse_pentagon_2. } apply maponpaths_2. apply pathsinv0, hcomp_identity_right. } etrans. { repeat rewrite vassocr. do 8 apply maponpaths_2. apply Haux. } clear Haux. repeat rewrite vassocl. do 5 apply maponpaths. (* two occurrences of [δ1] and [δ2] vanished ten two-cells remain, one occurrence of [δ1] on both sides *) assert (Haux2: rassociator (FA v) g1 (FA' w · g2) • (FA v ◃ lassociator g1 (FA' w) g2) = lassociator (FA v · g1) (FA' w) g2 • ((rassociator (FA v) g1 (FA' w) ▹ g2) • rassociator (FA v) (g1 · FA' w) g2)). { rewrite <- hcomp_identity_right. etrans. 2: { apply inverse_pentagon_4. } rewrite hcomp_identity_left. apply idpath. } etrans. { repeat rewrite vassocr. do 4 apply maponpaths_2. exact Haux2. } clear Haux2. repeat rewrite vassocl. do 2 apply maponpaths. etrans. { repeat rewrite vassocr. do 3 apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } repeat rewrite vassocl. apply maponpaths. (* no more [δ1] nor [δ2] *) etrans. { repeat rewrite vassocr. apply maponpaths_2. rewrite vassocl. apply pathsinv0, inverse_pentagon_2. } rewrite vassocl. rewrite rassociator_lassociator. rewrite hcomp_identity_right. apply id2_right. Qed. Definition disp_actionbicat_disp_id_comp : disp_cat_id_comp B disp_actionbicat_disp_ob_mor. Proof. split. - intros a [FA FAm]. use tpair. + exact (disp_actionbicat_disp_id_nat_trans FAm). + split; [apply disp_actionbicat_disp_id_triangle | apply disp_actionbicat_disp_id_pentagon]; assumption. - intros a0 a1 a2 g1 g2 [FA FAm] [FA' FA'm] [FA'' FA''m] Hyp1 Hyp2. cbn in Hyp1, Hyp2. exists (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2). + split; [apply disp_actionbicat_disp_comp_triangle | apply disp_actionbicat_disp_comp_pentagon]; assumption. Defined. Definition disp_actionbicat_disp_catdata : disp_cat_data B := (disp_actionbicat_disp_ob_mor,,disp_actionbicat_disp_id_comp). Definition bidisp_actionbicat_disp_2cell_eq_body {a a' : B} {f1 f2 : B ⟦ a, a' ⟧} (η : f1 ==> f2) (FA : V ⟶ category_from_bicat_and_ob a) (FA' : V ⟶ category_from_bicat_and_ob a') (δ1 : parameterized_distributivity_bicat_nat f1) (δ2 : parameterized_distributivity_bicat_nat f2) (v : V): UU := δ1 v • (FA v ◃ η) = (η ▹ FA' v) • δ2 v. Lemma isaprop_bidisp_actionbicat_disp_2cell_eq_body {a a' : B} {f1 f2 : B ⟦ a, a' ⟧} (η : f1 ==> f2) (FA : V ⟶ category_from_bicat_and_ob a) (FA' : V ⟶ category_from_bicat_and_ob a') (δ1 : parameterized_distributivity_bicat_nat f1) (δ2 : parameterized_distributivity_bicat_nat f2) (v : V): isaprop (bidisp_actionbicat_disp_2cell_eq_body η FA FA' δ1 δ2 v). Proof. apply B. Qed. Definition bidisp_actionbicat_disp_2cell_struct : disp_2cell_struct disp_actionbicat_disp_ob_mor. Proof. intros a a' f1 f2 η [FA FAm] [FA' FA'm] [δ1 [tria1 penta1]] [δ2 [tria2 penta2]]. exact (∏ v: V, bidisp_actionbicat_disp_2cell_eq_body η FA FA' δ1 δ2 v). Defined. Lemma isaprop_bidisp_actionbicat_disp_2cell_struct {a a' : B} {f1 f2 : B ⟦ a, a' ⟧} (η : f1 ==> f2) {M : disp_actionbicat_disp_catdata a} {M' : disp_actionbicat_disp_catdata a'} (FM1 : M -->[ f1] M') (FM2 : M -->[ f2] M'): isaprop (bidisp_actionbicat_disp_2cell_struct a a' f1 f2 η M M' FM1 FM2). Proof. apply impred. intro v. apply isaprop_bidisp_actionbicat_disp_2cell_eq_body. Qed. Definition bidisp_actionbicat_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells B := (disp_actionbicat_disp_catdata,, bidisp_actionbicat_disp_2cell_struct). Ltac aux_bidisp_actionbicat_disp_prebicat_ops := intros; red; cbn; unfold bidisp_actionbicat_disp_2cell_struct, bidisp_actionbicat_disp_2cell_eq_body; intro v; unfold disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data; cbn; show_id_type. Definition actionbicat_ax2 : UU := (∏ (a b c d : B) (f : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (h : B ⟦ c, d ⟧) (w : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a) (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells d) (ff : w -->[ f] x) (gg : x -->[ g] y) (hh : y -->[ h] z), disp_2cells (rassociator f g h) (ff ;; gg ;; hh) (ff ;; (gg ;; hh))) × (∏ (a b c d : B) (f : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (h : B ⟦ c, d ⟧) (w : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a) (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells d) (ff : w -->[ f] x) (gg : x -->[ g] y) (hh : y -->[ h] z), disp_2cells (lassociator f g h) (ff ;; (gg ;; hh)) (ff ;; gg ;; hh)) × (∏ (a b : B) (f g h : B ⟦ a, b ⟧) (r : f ==> g) (s : g ==> h) (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a) (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (ff : x -->[ f] y) (gg : x -->[ g] y) (hh : x -->[ h] y), disp_2cells r ff gg → disp_2cells s gg hh → disp_2cells (r • s) ff hh) × (∏ (a b c : B) (f : B ⟦ a, b ⟧) (g1 g2 : B ⟦ b, c ⟧) (r : g1 ==> g2) (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a) (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (ff : x -->[ f] y) (gg1 : y -->[ g1] z) (gg2 : y -->[ g2] z), disp_2cells r gg1 gg2 → disp_2cells (f ◃ r) (ff ;; gg1) (ff ;; gg2)) × (∏ (a b c : B) (f1 f2 : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (r : f1 ==> f2) (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a) (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (ff1 : x -->[ f1] y) (ff2 : x -->[ f2] y) (gg : y -->[ g] z), disp_2cells r ff1 ff2 → disp_2cells (r ▹ g) (ff1 ;; gg) (ff2 ;; gg)). Context (ax2 : actionbicat_ax2). Lemma bidisp_actionbicat_disp_prebicat_ops : disp_prebicat_ops bidisp_actionbicat_disp_prebicat_1_id_comp_cells. Proof. split; [| split; [| split ; [| split ; [| split]]]]. (*repeat split; intros; red ; cbn; unfold bidisp_actionbicat_disp_2cell_struct, bidisp_actionbicat_disp_2cell_eq_body; intro v; unfold disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data; cbn; show_id_type. *) - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite lwhisker_id2. rewrite id2_right. rewrite id2_rwhisker. apply pathsinv0, id2_left. - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- rwhisker_vcomp. etrans. { repeat rewrite vassocl. do 5 apply maponpaths. apply lunitor_lwhisker. } rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite vassocr. apply maponpaths_2. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)). cbn. apply pathsinv0, lunitor_triangle. - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- lwhisker_vcomp. etrans. { repeat rewrite vassocl. do 5 apply maponpaths. apply runitor_triangle. } etrans. { do 2 apply maponpaths. rewrite vassocr. apply maponpaths_2. apply rinvunitor_triangle. } rewrite vcomp_runitor. etrans. { do 2 apply maponpaths. rewrite vassocr. rewrite rinvunitor_runitor. apply id2_left. } rewrite vassocr. apply maponpaths_2. apply lunitor_lwhisker. - aux_bidisp_actionbicat_disp_prebicat_ops. etrans. 2: { do 3 apply maponpaths. apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite vassocr. apply maponpaths_2. apply (! lunitor_triangle _ _ _ _ _ _). } etrans. 2: { do 2 apply maponpaths. rewrite vassocr. apply maponpaths_2. rewrite vassocr. apply maponpaths_2. apply (! vcomp_lunitor _ _ _). } rewrite vassocr. rewrite <- linvunitor_assoc. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite vassocl. apply maponpaths. rewrite (! hcomp_identity_right _ _ _ _). rewrite (! hcomp_identity_left _ _ _ _). apply triangle_r_inv. - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- lwhisker_vcomp. etrans. 2: { apply maponpaths. rewrite vassocr. apply maponpaths_2. rewrite vassocr. apply maponpaths_2. apply (! lunitor_lwhisker _ _). } (* Search (lassociator _ _ (id₁ _)). *) etrans. 2: { apply maponpaths. rewrite vassocl. apply maponpaths. rewrite vassocr. apply maponpaths_2. rewrite vassocr. apply maponpaths_2. apply (! rinvunitor_triangle _ _ _ _ _ _). } rewrite vassocr. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_left. rewrite left_unit_inv_assoc. rewrite vassocr. apply maponpaths_2. rewrite rinvunitor_natural. apply maponpaths. apply hcomp_identity_right. - exact ax2. (* probably not useful for 10th goal after splitting: induction x as [FA FAm]. induction y as [FA' FA'm]. induction f' as [δ [tria penta]]. cbn. red in tria, penta. unfold param_distr_bicat_pentagon_eq_body in penta. (* assert (δnat := pr2 δ). red in δnat. unfold H, H' in δnat. cbn in δnat. rewrite hcomp_identity_left in δnat; rewrite hcomp_identity_right in δnat. *) *) Qed. Definition bidisp_actionbicat_disp_prebicat_data : disp_prebicat_data B := (bidisp_actionbicat_disp_prebicat_1_id_comp_cells,, bidisp_actionbicat_disp_prebicat_ops). Definition bidisp_actionbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_actionbicat_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_actionbicat_disp_2cell_struct. Qed. Definition bidisp_actionbicat_disp_prebicat : disp_prebicat B := (bidisp_actionbicat_disp_prebicat_data,,bidisp_actionbicat_disp_prebicat_laws). Definition bidisp_actionbicat_disp_bicat : disp_bicat B. Proof. refine (bidisp_actionbicat_disp_prebicat,, _). intros a a' f1 f2 η M M' FM1 FM2. apply isasetaprop. apply isaprop_bidisp_actionbicat_disp_2cell_struct. Defined. Lemma actionbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_actionbicat_disp_bicat. Proof. red. intros. apply isaprop_bidisp_actionbicat_disp_2cell_struct. Qed. Definition bicatactionbicat : bicat := total_bicat bidisp_actionbicat_disp_bicat. Lemma actionbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_actionbicat_disp_bicat. Proof. red. intros a a' f1 f2 ηinvertible [FA FAm] [FA' FA'm] [δ1 [tria1 penta1]] [δ2 [tria2 penta2]] is2cell. use tpair. - red. cbn. red. intro v. red. transparent assert (invertible1 : (invertible_2cell (FA v · f2) (FA v · f1))). { use make_invertible_2cell. - exact (FA v ◃ ηinvertible ^-1). - is_iso. } transparent assert (invertible2 : (invertible_2cell (f2 · FA' v) (f1 · FA' v))). { use make_invertible_2cell. - exact (ηinvertible ^-1 ▹ FA' v). - is_iso. } apply (lhs_right_invert_cell _ _ _ invertible1). rewrite vassocl. apply pathsinv0, (lhs_left_invert_cell _ _ _ invertible2). exact (is2cell v). - split; apply isaprop_bidisp_actionbicat_disp_2cell_struct. Qed. End FixMoncatAndBicat. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfWhiskeredMonCats.v000066400000000000000000000162301451125700300276570ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022 *) (** ********************************************************** constructs the bicategory of whiskered monoidal categories ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Section TheConstruction. Definition disp_monbicat_disp_ob_mor : disp_cat_ob_mor bicat_of_cats. Proof. exists monoidal. exact (λ C D M N F, fmonoidal M N F). Defined. Definition disp_monbicat_disp_id_comp : disp_cat_id_comp bicat_of_cats disp_monbicat_disp_ob_mor. Proof. split. - intros C F. apply identity_fmonoidal. - intros C D E F G M N O. apply comp_fmonoidal. Defined. Definition disp_monbicat_disp_catdata : disp_cat_data bicat_of_cats := (disp_monbicat_disp_ob_mor,,disp_monbicat_disp_id_comp). Definition bidisp_monbicat_disp_2cell_struct : disp_2cell_struct disp_monbicat_disp_ob_mor. Proof. intros C D F G α M N. exact (λ Fm Gm, is_mon_nat_trans (Fm : fmonoidal M N F) (Gm : fmonoidal M N G) α). Defined. Lemma isaprop_bidisp_monbicat_disp_2cell_struct {C D : bicat_of_cats} {F G : bicat_of_cats ⟦C,D⟧ } {α : prebicat_cells bicat_of_cats F G} {M : disp_monbicat_disp_catdata C} {N : disp_monbicat_disp_catdata D} (Fm : M -->[ F] N) (Gm : M -->[ G] N) : isaprop (bidisp_monbicat_disp_2cell_struct C D F G α M N Fm Gm). Proof. apply isaprop_is_mon_nat_trans. Qed. Definition bidisp_monbicat_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_cats := (disp_monbicat_disp_catdata,, bidisp_monbicat_disp_2cell_struct). Lemma bidisp_monbicat_disp_prebicat_ops : disp_prebicat_ops bidisp_monbicat_disp_prebicat_1_id_comp_cells. Proof. split. { intros; apply is_mon_nat_trans_identity. } repeat split; try red; cbn; unfold fmonoidal_preservestensordata, fmonoidal_preservesunit; intros; show_id_type. - rewrite functor_id. do 2 rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } apply pathsinv0, id_left. - rewrite functor_id. rewrite id_right. apply id_right. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } apply id_right. - rewrite id_right. apply id_left. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } rewrite functor_id. apply pathsinv0, id_left. - rewrite functor_id. apply idpath. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } do 2 rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid z). - cbn in *. apply (bifunctor_rightid z). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply functor_comp. - rewrite id_right. rewrite assoc'. apply maponpaths. apply functor_comp. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid z). - cbn in *. apply (bifunctor_rightid z). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. - rewrite id_right. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. - apply (pr1 (is_mon_nat_trans_comp _ _ _ _ _ X X0)). - apply (pr2 (is_mon_nat_trans_comp _ _ _ _ _ X X0)). - apply (pr1 (is_mon_nat_trans_prewhisker _ X)). - apply (pr2 (is_mon_nat_trans_prewhisker _ X)). - apply (pr1 (is_mon_nat_trans_postwhisker X _)). - apply (pr2 (is_mon_nat_trans_postwhisker X _)). Qed. Definition bidisp_monbicat_disp_prebicat_data : disp_prebicat_data bicat_of_cats := (bidisp_monbicat_disp_prebicat_1_id_comp_cells,, bidisp_monbicat_disp_prebicat_ops). Definition bidisp_monbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_monbicat_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_monbicat_disp_2cell_struct. Qed. Definition bidisp_monbicat_disp_prebicat : disp_prebicat bicat_of_cats := (bidisp_monbicat_disp_prebicat_data,,bidisp_monbicat_disp_prebicat_laws). Definition bidisp_monbicat_disp_bicat : disp_bicat bicat_of_cats. Proof. refine (bidisp_monbicat_disp_prebicat,, _). intros C D F G α M N Fm Gm. apply isasetaprop. apply isaprop_bidisp_monbicat_disp_2cell_struct. Defined. Lemma monbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_monbicat_disp_bicat. Proof. red. intros. apply isaprop_bidisp_monbicat_disp_2cell_struct. Qed. Definition monbicat : bicat := total_bicat bidisp_monbicat_disp_bicat. End TheConstruction. Definition monbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_monbicat_disp_bicat. Proof. red. intros C D F G αiso M N Fm Gm ismnt. use tpair. - transparent assert (isnziα : (is_nat_z_iso (pr11 αiso))). { apply (nat_trafo_pointwise_z_iso_if_z_iso (pr2 D)). exact (pr2 αiso). } exact (is_mon_nat_trans_pointwise_inverse (Fm : fmonoidal _ _ _) (Gm : fmonoidal _ _ _) (pr1 αiso) isnziα ismnt). - split; apply isaprop_bidisp_monbicat_disp_2cell_struct. Defined. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfWhiskeredMonCatsFinalObject.v000066400000000000000000000046051451125700300317630ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022 *) (** ********************************************************** constructs the final object of the bicategory of whiskered monoidal categories this resides in a separate file because of the heavy dependencies ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Examples.BicatOfCatsLimits. Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfWhiskeredMonCats. Local Open Scope cat. Definition unit_monoidal : monoidal (pr1 unit_category). Proof. use tpair. - use tpair. + use make_bifunctor_data. * exact (fun _ _ => tt). * intros. apply idpath. * intros. apply idpath. + exists tt. repeat split; intro x; induction x; apply isapropunit. - split. + abstract (repeat split). + abstract ( do 2 (split; [split; red; intros; [apply isasetunit | split; apply isasetunit] |]); split; [ do 3 (split; [red; intros; apply isasetunit |]); split; apply isasetunit | split; red; intros; apply isasetunit]). Defined. Definition unit_monoidal_disp_bifinal_obj : disp_bifinal_obj_stronger bidisp_monbicat_disp_bicat (_,,bifinal_cats). Proof. exists unit_monoidal. use tpair. - intros C M. cbn. use tpair. + use tpair. * split; red; intros; apply idpath. * abstract (repeat split). + split; red; intros; exists (idpath tt); abstract (split; apply isasetunit). - intros x xx f g ff gg. red; cbn; red; cbn. split; red; intros; apply isasetunit. Defined. Definition bifinal_moncats : bifinal_obj monbicat. Proof. use total_bicat_final_stronger. - exact monbicat_disp_2cells_isaprop. - exact (_,,bifinal_cats). - exact unit_monoidal_disp_bifinal_obj. Defined. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/BicatOfWhiskeredMonCatsLax.v000066400000000000000000000204661451125700300303320ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2023 *) (** ********************************************************** constructs the bicategory of whiskered monoidal categories with lax monoidal functors as 1-cells this is mostly a copy of [BicatOfWhiskeredMonCats] ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Section TheConstruction. Definition disp_monlaxbicat_disp_ob_mor : disp_cat_ob_mor bicat_of_cats. Proof. exists monoidal. exact (λ C D M N F, fmonoidal_lax M N F). Defined. Definition disp_monlaxbicat_disp_id_comp : disp_cat_id_comp bicat_of_cats disp_monlaxbicat_disp_ob_mor. Proof. split. - intros C F. apply identity_fmonoidal. - intros C D E F G M N O. apply comp_fmonoidal_lax. Defined. Definition disp_monlaxbicat_disp_catdata : disp_cat_data bicat_of_cats := (disp_monlaxbicat_disp_ob_mor,,disp_monlaxbicat_disp_id_comp). Definition bidisp_monlaxbicat_disp_2cell_struct : disp_2cell_struct disp_monlaxbicat_disp_ob_mor. Proof. intros C D F G α M N. exact (λ Fm Gm, is_mon_nat_trans (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G) α). Defined. Lemma isaprop_bidisp_monlaxbicat_disp_2cell_struct {C D : bicat_of_cats} {F G : bicat_of_cats ⟦C,D⟧ } {α : prebicat_cells bicat_of_cats F G} {M : disp_monlaxbicat_disp_catdata C} {N : disp_monlaxbicat_disp_catdata D} (Fm : M -->[ F] N) (Gm : M -->[ G] N) : isaprop (bidisp_monlaxbicat_disp_2cell_struct C D F G α M N Fm Gm). Proof. apply isaprop_is_mon_nat_trans. Qed. Definition bidisp_monlaxbicat_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_cats := (disp_monlaxbicat_disp_catdata,, bidisp_monlaxbicat_disp_2cell_struct). Lemma bidisp_monlaxbicat_disp_prebicat_ops : disp_prebicat_ops bidisp_monlaxbicat_disp_prebicat_1_id_comp_cells. Proof. split. { intros; apply is_mon_nat_trans_identity. } repeat split; try red; cbn; unfold fmonoidal_preservestensordata, fmonoidal_preservesunit; intros; show_id_type. - rewrite functor_id. do 2 rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } apply pathsinv0, id_left. - rewrite functor_id. rewrite id_right. apply id_right. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } apply id_right. - rewrite id_right. apply id_left. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } rewrite functor_id. apply pathsinv0, id_left. - rewrite functor_id. apply idpath. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid y). - cbn in *. apply (bifunctor_rightid y). } do 2 rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid z). - cbn in *. apply (bifunctor_rightid z). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply functor_comp. - rewrite id_right. rewrite assoc'. apply maponpaths. apply functor_comp. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid z). - cbn in *. apply (bifunctor_rightid z). } rewrite id_right. rewrite id_left. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. - rewrite id_right. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. - apply (pr1 (is_mon_nat_trans_comp _ _ _ _ _ X X0)). - apply (pr2 (is_mon_nat_trans_comp _ _ _ _ _ X X0)). - assert (aux := pr1 X (pr1 f a0) (pr1 f a')). unfold fmonoidal_preservestensordata in aux. etrans. 2: { rewrite assoc. apply cancel_postcomposition. exact aux. } clear aux. repeat rewrite assoc'. apply maponpaths. apply nat_trans_ax. - assert (aux := pr2 X). red in aux. unfold fmonoidal_preservesunit in aux. rewrite <- aux. repeat rewrite assoc'. apply maponpaths. apply nat_trans_ax. - etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. } etrans. { do 2 apply maponpaths. apply (pr1 X). } unfold fmonoidal_preservestensordata. rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, preservestensor_is_nattrans_full. + apply (fmonoidal_preservestensornatleft (gg : fmonoidal_lax _ _ g)). + apply (fmonoidal_preservestensornatright (gg : fmonoidal_lax _ _ g)). - rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. apply (pr2 X). Qed. Definition bidisp_monlaxbicat_disp_prebicat_data : disp_prebicat_data bicat_of_cats := (bidisp_monlaxbicat_disp_prebicat_1_id_comp_cells,, bidisp_monlaxbicat_disp_prebicat_ops). Definition bidisp_monlaxbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_monlaxbicat_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_monlaxbicat_disp_2cell_struct. Qed. Definition bidisp_monlaxbicat_disp_prebicat : disp_prebicat bicat_of_cats := (bidisp_monlaxbicat_disp_prebicat_data,,bidisp_monlaxbicat_disp_prebicat_laws). Definition bidisp_monlaxbicat_disp_bicat : disp_bicat bicat_of_cats. Proof. refine (bidisp_monlaxbicat_disp_prebicat,, _). intros C D F G α M N Fm Gm. apply isasetaprop. apply isaprop_bidisp_monlaxbicat_disp_2cell_struct. Defined. Lemma monlaxbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_monlaxbicat_disp_bicat. Proof. red. intros. apply isaprop_bidisp_monlaxbicat_disp_2cell_struct. Qed. Definition monlaxbicat : bicat := total_bicat bidisp_monlaxbicat_disp_bicat. End TheConstruction. Definition monlaxbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_monlaxbicat_disp_bicat. Proof. red. intros C D F G αiso M N Fm Gm ismnt. use tpair. - transparent assert (isnziα : (is_nat_z_iso (pr11 αiso))). { apply (nat_trafo_pointwise_z_iso_if_z_iso (pr2 D)). exact (pr2 αiso). } exact (is_mon_nat_trans_pointwise_inverse (Fm : fmonoidal_lax _ _ _) (Gm : fmonoidal_lax _ _ _) (pr1 αiso) isnziα ismnt). - split; apply isaprop_bidisp_monlaxbicat_disp_2cell_struct. Defined. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/ConstructionOfActions.v000066400000000000000000000266411451125700300275240ustar00rootroot00000000000000(** Construction of actions, over monoidal categories: - the monoidal category acting on itself - reindexing an action from the target of a strong monoidal functor to its source These modularize the construction of the action induced by a strong monoidal functor U, see [U_action]. Author: Ralph Matthes 2021. However, the code is to a good extent copied from the construction of [U_action]. **) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Local Open Scope cat. Section A. Context (Mon_V : monoidal_cat). Local Definition V := monoidal_cat_cat Mon_V. Local Definition I := monoidal_cat_unit Mon_V. Local Definition tensor := monoidal_cat_tensor Mon_V. Notation "X ⊗ Y" := (tensor (X , Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Local Definition α' := monoidal_cat_associator Mon_V. Local Definition λ' := monoidal_cat_left_unitor Mon_V. Local Definition ρ' := monoidal_cat_right_unitor Mon_V. Definition action_on_itself: action Mon_V V. Proof. exists tensor. exists ρ'. exists α'. split; [apply monoidal_cat_triangle_eq | apply monoidal_cat_pentagon_eq]. Defined. Section Action_Reindexing_Through_Strong_Monoidal_Functor. Context {Mon_A : monoidal_cat}. Local Definition A := monoidal_cat_cat Mon_A. Local Definition I_A := monoidal_cat_unit Mon_A. Local Definition tensor_A := monoidal_cat_tensor Mon_A. Notation "X ⊗_A Y" := (tensor_A (X , Y)) (at level 31). Notation "f #⊗_A g" := (#tensor_A (f #, g)) (at level 31). Local Definition α_A := monoidal_cat_associator Mon_A. Local Definition λ_A := monoidal_cat_left_unitor Mon_A. Local Definition ρ_A := monoidal_cat_right_unitor Mon_A. Local Definition triangle_eq_A := monoidal_cat_triangle_eq Mon_A. Local Definition pentagon_eq_A := monoidal_cat_pentagon_eq Mon_A. Context (U : strong_monoidal_functor Mon_V Mon_A). Context {C : category} (actA : action Mon_A C). Local Definition odotA := act_odot actA. Definition reindexed_odot : C ⊠ V ⟶ C := functor_composite (pair_functor (functor_identity _) U) odotA. Definition reindexed_action_right_unitor_nat_trans: odot_I_functor Mon_V C reindexed_odot ⟹ functor_identity C. Proof. cbn. refine (nat_trans_comp _ _ _ _ (act_ϱ actA)). set (aux := nat_trans_from_functor_fix_snd_morphism_arg _ _ _ odotA _ _ (strong_monoidal_functor_ϵ_inv U)). use tpair. - intro a. apply (aux a). - cbn; red. intros a a' f. cbn. rewrite functor_id. exact (pr2 aux a a' f). Defined. Definition reindexed_action_right_unitor: action_right_unitor Mon_V C reindexed_odot. Proof. exists reindexed_action_right_unitor_nat_trans. intro. cbn. use is_z_iso_comp_of_is_z_isos. 2: { exact (pr2 (act_ϱ actA) c). } - use is_z_iso_odot_z_iso. + exact (identity_is_z_iso _ ). + apply (is_z_iso_inv_from_z_iso (strong_monoidal_functor_ϵ U)). Defined. Definition reindexed_action_convertor_nat_trans : odot_x_odot_y_functor _ C reindexed_odot ⟹ odot_x_otimes_y_functor _ C reindexed_odot. Proof. apply (nat_trans_comp _ _ _ (pre_whisker (pair_functor (pair_functor (functor_identity _) U) U) (act_χ actA))). exact (pre_whisker (precategory_binproduct_unassoc _ _ _) (post_whisker_fst_param (lax_monoidal_functor_μ U) odotA)). Defined. Definition reindexed_action_convertor : action_convertor Mon_V C reindexed_odot. Proof. exists reindexed_action_convertor_nat_trans. intro x. pose (k := ob1 (ob1 x)); pose (k' := ob2 (ob1 x)); pose (k'' := ob2 x). use is_z_iso_comp_of_is_z_isos. - exact (pr2 (act_χ actA) ((k, U k'), U k'')). - use is_z_iso_odot_z_iso. + use identity_is_z_iso. + exact (strong_monoidal_functor_μ_is_nat_z_iso U (k', k'')). Defined. Lemma reindexed_action_tlaw : action_triangle_eq Mon_V C reindexed_odot reindexed_action_right_unitor reindexed_action_convertor. Proof. red. intros a x. cbn. unfold nat_trans_from_functor_fix_snd_morphism_arg_data. unfold nat_trans_data_post_whisker_fst_param. simpl. unfold make_dirprod. rewrite functor_id. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply pathsinv0. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 2. simpl. unfold make_dirprod. rewrite id_left. rewrite <- (id_left (id U x)). apply pathsinv0. intermediate_path (# odotA ((# odotA (id a #, strong_monoidal_functor_ϵ_inv U)) #, id U x) · # odotA (act_ϱ actA a #, id U x)). { rewrite <- functor_comp. apply idpath. } pose (f := # odotA (# odotA (id a #, lax_monoidal_functor_ϵ U) #, id U x)). apply (pre_comp_with_z_iso_is_inj'(f:=f)). { use is_z_iso_odot_z_iso. - use is_z_iso_odot_z_iso. + exact (identity_is_z_iso _). + exact (strong_monoidal_functor_ϵ_is_z_iso U). - exact (identity_is_z_iso _ ). } rewrite assoc. intermediate_path (# odotA (act_ϱ actA a #, id U x)). { apply pathsinv0. etrans. - apply (!(id_left _)). - apply cancel_postcomposition. unfold f. rewrite <- functor_comp. apply pathsinv0. apply functor_id_id. apply pathsdirprod; simpl. + etrans. * apply pathsinv0. apply functor_comp. * apply functor_id_id. apply pathsdirprod; simpl. -- apply id_left. -- apply pathsinv0. apply z_iso_inv_on_left. rewrite id_left. apply idpath. + apply id_left. } (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) rewrite assoc. apply pathsinv0. etrans. { apply cancel_postcomposition. apply (nat_trans_ax (act_χ actA) ((a, I_A), U x) ((a, U I), U x) ((id a ,, lax_monoidal_functor_ϵ U) ,, id U x)). } simpl. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 2. simpl. unfold make_dirprod. rewrite id_left. (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) rewrite assoc. etrans. - apply maponpaths. eapply (maponpaths (fun u: Mon_A ⟦I_A ⊗_A (U x), U x⟧ => # odotA (id a #, u))). apply pathsinv0. apply (lax_monoidal_functor_unital U x). - fold λ_A. (* UniMath.MoreFoundations.Tactics.show_id_type. unfold functor_fix_snd_arg_ob in TYPE. *) apply pathsinv0. apply (act_triangle actA). Qed. Lemma reindexed_action_plaw : action_pentagon_eq Mon_V C reindexed_odot reindexed_action_convertor. Proof. red. intros a x y z. cbn. unfold nat_trans_data_post_whisker_fst_param. unfold ob1, ob2. cbn. rewrite functor_id. apply pathsinv0. etrans. { repeat rewrite assoc'. apply maponpaths. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 4. cbn. unfold make_dirprod. rewrite id_left. etrans. { rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. rewrite <- (id_left (id U z)). intermediate_path (# odotA ((act_χ actA ((a, U x), U y) #, id U z) · (# odotA (id a #, lax_monoidal_functor_μ U (x, y)) #, id U z))). - apply idpath. - apply functor_comp. } etrans. { apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply (nat_trans_ax (act_χ actA) ((a, U x ⊗_A U y), U z) ((a, U (x ⊗ y)), U z) ((id a ,, lax_monoidal_functor_μ U (x, y)) ,, id U z)). } etrans. { unfold assoc_right. cbn. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. apply pathsinv0. apply functor_comp. } unfold compose at 3. cbn. unfold make_dirprod. rewrite id_left. etrans. { do 2 apply maponpaths. rewrite assoc. (* UniMath.MoreFoundations.Tactics.show_id_type. *) eapply (maponpaths (fun u: A ⟦(U x ⊗_A U y) ⊗_A U z, U (x ⊗ (y ⊗ z))⟧ => # odotA (id a #, u))). apply (lax_monoidal_functor_assoc U). } etrans. { rewrite assoc. apply maponpaths. rewrite assoc'. rewrite <- (id_left (id a)). intermediate_path (# odotA ((id a #, α_A ((U x, U y), U z)) · (id a #, # tensor_A (id U x #, lax_monoidal_functor_μ U (y, z)) · lax_monoidal_functor_μ U (x, y ⊗ z)))). 2: { apply functor_comp. } apply idpath. } etrans. { do 2 apply maponpaths. rewrite <- (id_left (id a)). intermediate_path (# odotA ((id a #, # tensor_A (id pr1 (pr1 U) x #, lax_monoidal_functor_μ U (y, z))) · (id a #, lax_monoidal_functor_μ U (x, y ⊗ z)))). 2: { apply functor_comp. } apply idpath. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { apply cancel_postcomposition. apply pathsinv0. apply (act_pentagon actA). } fold odotA. change (act_χ actA ((odotA (a, U x), U y), U z) · act_χ actA ((a, U x), tensor_A (U y, U z)) · # odotA (id a #, # tensor_A (id U x #, lax_monoidal_functor_μ U (y, z))) = act_χ actA ((odotA (a , U x), U y), U z) · # odotA (id (odotA (a , U x)) #, lax_monoidal_functor_μ U (y, z)) · act_χ actA ((a, U x), U (y ⊗ z))). repeat rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0. apply (nat_trans_ax (act_χ actA) ((a, U x), U y ⊗_A U z) ((a, U x), U (y ⊗ z)) ((id a ,, id U x) ,, lax_monoidal_functor_μ U (y, z))). } cbn. apply cancel_postcomposition. (* present the identity in the binary product of categories *) change (# odotA (# odotA (id (a, U x)) #, (lax_monoidal_functor_μ U) (y, z)) = # odotA (id (odotA (a, U x)) #, lax_monoidal_functor_μ U (y, z))). rewrite functor_id. apply idpath. Qed. Definition reindexed_action: action Mon_V C. Proof. exists reindexed_odot. exists reindexed_action_right_unitor. exists reindexed_action_convertor. split. - exact reindexed_action_tlaw. - exact reindexed_action_plaw. Defined. End Action_Reindexing_Through_Strong_Monoidal_Functor. End A. Section Strong_Monoidal_Functor_Action_Reloaded. Context {Mon_V Mon_A : monoidal_cat}. Context (U : strong_monoidal_functor Mon_V Mon_A). Context (C : precategory). Definition U_action_alt : action Mon_V (monoidal_cat_cat Mon_A) := reindexed_action Mon_V U (action_on_itself Mon_A). (* the two actions would even be convertible - if one would ask for definedness of the proofs of the equations [reindexed_action_tlaw] and [reindexed_action_plaw] and also [U_action_tlaw] and [U_action_plaw] Lemma U_action_alt_ok: U_action_alt = U_action _ U. Proof. apply idpath. Qed. *) (* the following lemmas work even when the equational proofs are opaque *) Lemma U_action_alt_ok1: pr1 U_action_alt = pr1(U_action _ U). Proof. apply idpath. Qed. Lemma U_action_alt_ok2: pr1(pr2 U_action_alt) = pr1(pr2(U_action _ U)). Proof. apply idpath. Qed. Lemma U_action_alt_ok3: pr1(pr22 U_action_alt) = pr1(pr22(U_action _ U)). Proof. apply idpath. Qed. (* this last lemma would again require definedness of the equational laws Lemma U_action_alt_ok4: pr1(pr222 U_action_alt) = pr1(pr222(U_action _ U)). Proof. apply idpath. Qed. *) End Strong_Monoidal_Functor_Action_Reloaded. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/EndofunctorsMonoidal.v000066400000000000000000000077701451125700300273620ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2019, change to [z_iso] as base notion in 2021 *) (** ********************************************************** Contents : - build monoidal category for the endofunctors ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. (* Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.HorizontalComposition. *) Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Local Open Scope cat. Section Endofunctors_as_monoidal_category. Context (C : category). (* (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Local Lemma is_nat_trans_left_unitor_data: is_nat_trans (I_pretensor (functorial_composition _ _ _) (functor_identity C)) (functor_identity [C, C]) (@λ_functors C C). Proof. intros F F' m. apply nat_trans_eq_alt. intro c. cbn. rewrite (functor_id F). do 2 rewrite id_left. apply id_right. Qed. Definition left_unitor_of_endofunctors: left_unitor (functorial_composition _ _ _) (functor_identity C). Proof. use make_nat_z_iso. + use make_nat_trans. * intro F. apply λ_functors. * apply is_nat_trans_left_unitor_data. + red. intro F. cbn. use nat_trafo_z_iso_if_pointwise_z_iso. intro c. use tpair. * exact (identity (pr1 F c)). * abstract ( apply Isos.is_inverse_in_precat_identity ). Defined. Local Lemma is_nat_trans_right_unitor_data: is_nat_trans (I_posttensor (functorial_composition _ _ _) (functor_identity C)) (functor_identity [C, C]) (@ρ_functors C C). Proof. intros F F' m. apply nat_trans_eq_alt. intro c. cbn. rewrite id_left. rewrite id_right. apply id_right. Qed. Definition right_unitor_of_endofunctors: right_unitor (functorial_composition _ _ _) (functor_identity C). Proof. use make_nat_z_iso. + use make_nat_trans. * intro F. apply ρ_functors. * apply is_nat_trans_right_unitor_data. + red. intro F. cbn. use nat_trafo_z_iso_if_pointwise_z_iso. intro c. use tpair. * exact (identity (pr1 F c)). * abstract ( apply Isos.is_inverse_in_precat_identity ). Defined. Definition associator_of_endofunctors: associator (functorial_composition _ _ _) := associativity_as_nat_z_iso C C C C. Lemma triangle_eq_of_endofunctors: triangle_eq (functorial_composition _ _ _) (functor_identity C) left_unitor_of_endofunctors right_unitor_of_endofunctors associator_of_endofunctors. Proof. intros F G. apply nat_trans_eq_alt. intro c. cbn. rewrite functor_id. do 3 rewrite id_right. apply functor_id. Qed. Lemma pentagon_eq_of_endofunctors: pentagon_eq (functorial_composition _ _ _) associator_of_endofunctors. Proof. intros F G H I. apply nat_trans_eq_alt. intro c. cbn. do 4 rewrite id_right. do 3 rewrite functor_id. rewrite id_right. apply pathsinv0, functor_id. Qed. Definition monoidal_cat_of_endofunctors: monoidal_cat. Proof. use make_monoidal_cat. - exact EndC. - apply functorial_composition. - apply functor_identity. - exact left_unitor_of_endofunctors. - exact right_unitor_of_endofunctors. - exact associator_of_endofunctors. - exact triangle_eq_of_endofunctors. - exact pentagon_eq_of_endofunctors. Defined. *) Definition monoidal_cat_of_endofunctors: monoidal_cat := monoidal_cat_from_bicat_and_ob(C:=bicat_of_cats) C. (** we need this high-level view in order to be able to instantiate [montrafotargetbicat_moncat] in [ActionBasedStrongFunctorsMonoidal] *) End Endofunctors_as_monoidal_category. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/EndofunctorsWhiskeredMonoidal.v000066400000000000000000000022341451125700300312160ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2022, after the model of EndofunctorsMonoidal *) (** ********************************************************** Contents : - build monoidal category for the endofunctors ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Local Open Scope cat. Section Endofunctors_as_monoidal_category. Context (C : category). Definition cat_of_endofunctors: category := category_from_bicat_and_ob(C:=bicat_of_cats) C. Definition monoidal_of_endofunctors: monoidal cat_of_endofunctors:= monoidal_from_bicat_and_ob(C:=bicat_of_cats) C. (** we need this high-level view in order to be able to instantiate [montrafotargetbicat_disp_monoidal] in [ActionBasedStrongFunctorsWhiskeredMonoidal] *) End Endofunctors_as_monoidal_category. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/EquivalenceActegoriesAndActions.v000066400000000000000000001402101451125700300314240ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActionsInBicat. Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Import BifunctorNotations. Local Opaque bifunctor_data_from_functorintoendofunctorcat_is_bifunctor. Section ActegoryToObject. Context {V : category} (Mon_V : monoidal V). Context {C : category}. Definition fmonoidal_data_to_object (act : actegory Mon_V C) : fmonoidal_data (monoidal_swapped Mon_V) (monoidal_from_bicat_and_ob (C : bicat_of_cats)) (bifunctor_to_functorintoendofunctorcat act). Proof. split. - intros v w. exists (λ c, actegory_actorinvdata act w v c). abstract (intros v1 w1 f; apply actorinv_nat_leftwhisker). - exists (λ v, actegory_unitorinvdata act v). abstract (intros v w f; exact (! actegory_unitorinvnat Mon_V act v w f)). Defined. Definition fmonoidal_laxlaws_to_object (act : actegory Mon_V C) : fmonoidal_laxlaws (fmonoidal_data_to_object act). Proof. repeat split ; (intro ; intros ; apply nat_trans_eq ; [apply homset_property | intro ; cbn ]). - apply actorinv_nat_rightwhisker. - apply actorinv_nat_leftrightwhisker. - rewrite id_left. apply pentagon_identity_actorinv. - rewrite (! actegory_triangleidentity Mon_V act x x0). rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. exact (pr2 (actegory_actorisolaw Mon_V act x (monoidal_unit Mon_V) x0)). } rewrite id_right. rewrite (! bifunctor_leftcomp act _ _ _ _ _ _). etrans. { apply maponpaths. apply actegory_unitorisolaw. } apply (bifunctor_leftid act). - set (tri := actegory_triangleidentity' Mon_V act x x0). rewrite (! tri). rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. exact (pr2 (actegory_actorisolaw Mon_V act (monoidal_unit Mon_V) x x0)). } rewrite id_right. apply actegory_unitorisolaw. Qed. Definition fmonoidal_lax_to_object (act : actegory Mon_V C) : fmonoidal_lax (monoidal_swapped Mon_V) (monoidal_from_bicat_and_ob (C : bicat_of_cats)) (bifunctor_to_functorintoendofunctorcat act) := fmonoidal_data_to_object act ,, fmonoidal_laxlaws_to_object act. Definition fmonoidal_stronglaws_to_object (Act : actegory Mon_V C) : fmonoidal_stronglaws (pr1 (fmonoidal_data_to_object Act)) (pr2 (fmonoidal_data_to_object Act)). Proof. repeat (use tpair). - intros v w. use tpair. + exists (λ c, actegory_actordata Act w v c). abstract (intros c1 c2 f; cbn; apply (! actegory_actornatleft _ _ _ _ _ _ _ )). + use tpair; [ apply nat_trans_eq; [ apply homset_property | intro; apply actegory_actorisolaw] | apply nat_trans_eq; [ apply homset_property | intro; apply (pr1 (actegory_actorisolaw Mon_V Act w v x))] ]. - exact (λ c, actegory_unitordata Act c). - abstract (intros c1 c2 f; cbn; apply actegory_unitornat). - abstract (use nat_trans_eq; [ apply homset_property | intro; cbn; apply actegory_unitorisolaw]). - abstract (use nat_trans_eq; [ apply homset_property | intro; cbn; apply actegory_unitorisolaw]). Defined. Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats). Definition actegory_to_object (Act : actegory Mon_V C) : bicatactionbicat (monoidal_swapped Mon_V) bicat_of_cats ax2. Proof. exists C. exists (bifunctor_to_functorintoendofunctorcat Act). exists (fmonoidal_lax_to_object Act). exact (fmonoidal_stronglaws_to_object Act). Defined. End ActegoryToObject. Section ActegoryFromObject. Context {V : category}. Context (Mon_V : monoidal V). Context (ax2 : actionbicat_ax2 Mon_V bicat_of_cats). Context (C : bicatactionbicat Mon_V bicat_of_cats ax2). Local Definition action_C := pr12 C. Local Definition action_fmon_lax := pr122 C. Local Definition action_fmon_strong := pr222 C. Definition unitor_from_object : action_unitor_data Mon_V (bifunctor_from_functorintoendofunctorcat action_C). Proof. intro ; apply (pr12 action_fmon_strong). Defined. Definition unitorinv_from_object : action_unitorinv_data Mon_V (bifunctor_from_functorintoendofunctorcat action_C). Proof. intro ; apply (fmonoidal_preservesunit action_fmon_lax). Defined. Definition actor_from_object : actor_data (monoidal_swapped Mon_V) (bifunctor_from_functorintoendofunctorcat action_C) := λ v w c, pr11 (pr1 action_fmon_strong w v) c. Definition actorinv_from_object : actorinv_data (monoidal_swapped Mon_V) (bifunctor_from_functorintoendofunctorcat action_C) := λ v w c, pr1 (fmonoidal_preservestensordata (pr122 C) w v) c. Definition actegory_data_from_object : actegory_data (monoidal_swapped Mon_V) (pr1 C). Proof. exists (bifunctor_from_functorintoendofunctorcat action_C). exists unitor_from_object. exists unitorinv_from_object. exists actor_from_object. exact actorinv_from_object. Defined. Lemma actegory_laws_from_object : actegory_laws (monoidal_swapped Mon_V) actegory_data_from_object. Proof. split5. - apply bifunctor_data_from_functorintoendofunctorcat_is_bifunctor. - repeat split. + intro ; intros. (* That the monoidal unit is strongly preserved, means that we have a morphism in the category of endofunctors on C, i.e. a natural transformation, hence, we use this naturality *) apply (pr212 action_fmon_strong). + (* Here we use that the unit is strongly preserved, that is, we use that the equation that expresses that the unit preserving morphism is invertible *) apply (eqtohomot (base_paths _ _ (pr222 action_fmon_strong))). + (* Idem as previous bullet point *) apply (eqtohomot (base_paths _ _ (pr122 action_fmon_strong))). - repeat split. + intro ; intros. (* That the monoidal unit is strongly preserved, means that we have a morphism in the category of endofunctors on C, i.e. a natural transformation, hence, we use this naturality *) exact (! pr21 (pr1 action_fmon_strong w v) z z' h). + intros v1 v2 w c f. set (fmon_strong_preserves_tensor_inv := preservestensor_inv_is_nattrans (pr12 action_fmon_lax) (pr122 action_fmon_lax) (pr1 action_fmon_strong)). exact (! (eqtohomot (base_paths _ _ (pr12 fmon_strong_preserves_tensor_inv w _ _ f)) c)). + intros w v1 v2 c f. exact (eqtohomot (base_paths _ _ (preserves_tensorinv_nat_right (pr1 action_fmon_strong) (pr122 action_fmon_lax) v1 v2 w f)) c). + apply (eqtohomot (base_paths _ _ (pr22 (pr1 action_fmon_strong w v)))). + apply (eqtohomot (base_paths _ _ (pr12 (pr1 action_fmon_strong w v)))). - intros v c. cbn. assert (plu := preserves_leftunitality'' (_,,pr222 C) v). assert (pluc := eqtohomot (base_paths _ _ plu) c). refine (_ @ pluc). clear pluc ; clear plu. cbn. rewrite ! id_right. apply idpath. - intro ; intros. cbn. unfold actor_from_object. assert (t := ! eqtohomot (base_paths _ _ (preserves_associativity_of_inverse_preserves_tensor (pr1 (pr222 action_fmon_lax)) (pr1 action_fmon_strong) v' v w)) z). cbn in t. rewrite id_right in t. set (αisov'vw := z_iso_inv (z_iso_from_associator_iso Mon_V v' v w)). rewrite assoc' in t. assert (pf: (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v' (v ⊗_{ Mon_V} w))) z · pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v w)) (pr1 ((pr12 C) v') z)) = pr1 (# (pr12 C) (monoidal_associatorinvdata Mon_V v' v w)) z · (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong (v' ⊗_{ Mon_V} v) w)) z · # (pr1 ((pr12 C) w)) (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v' v)) z))). { etrans. 2: { apply maponpaths. exact t. } rewrite ! assoc. apply maponpaths_2. etrans. 2: { apply maponpaths_2. assert (bla := eqtohomot (base_paths _ _ (maponpaths (# (pr12 C)) (pr2 (monoidal_associatorisolaw Mon_V v' v w)))) z). rewrite functor_comp in bla. exact (! bla). } rewrite functor_id. apply (! id_left _). } refine (_ @ ! pf). apply assoc'. Qed. Definition actegory_from_object : actegory (monoidal_swapped Mon_V) (pr1 C) := actegory_data_from_object ,, actegory_laws_from_object. End ActegoryFromObject. Context {V : category} (Mon_V : monoidal V). Local Definition ACAT : bicat := actbicat Mon_V. Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats). Local Definition ACTI : bicat := bicatactionbicat (monoidal_swapped Mon_V) bicat_of_cats ax2. Section EqualityLemmaHelpers. Definition equality_of_2cells_in_ACAT {a b : ACAT} {f g : ACAT⟦a,b⟧} (α β : prebicat_cells _ f g) : (∏ x : (pr11 a), pr11 α x = pr11 β x) -> α = β. Proof. intro p. use total2_paths_f. { use nat_trans_eq. { apply homset_property. } exact (λ x, p x). } apply proofirrelevance. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Definition equality_of_2cells_in_ACTI {a b : ACTI} {f g : ACTI⟦a,b⟧} (α β : prebicat_cells _ f g) : (∏ x : (pr11 a), pr11 α x = pr11 β x) -> α = β. Proof. intro p. use total2_paths_f. { use nat_trans_eq. { apply homset_property. } intro x. exact (p x). } apply proofirrelevance. apply impred_isaprop ; intro. apply cellset_property. Qed. Lemma equality_of_ACTI_endofunctors {a b : psfunctor_bicat ACTI ACTI} {f g : (psfunctor_bicat ACTI ACTI)⟦a,b⟧} (α β : prebicat_cells (psfunctor_bicat ACTI ACTI) f g) : (∏ x : ACTI, ∏ x0 : pr11 ((pr111 a) x), (pr11 ((pr111 α) x)) x0 = (pr11 ((pr111 β) x)) x0) -> α = β. Proof. intro p. use total2_paths_f. 2: { apply proofirrelevance ; apply isapropunit. } use total2_paths_f. 2: { use total2_paths_f ; (apply proofirrelevance ; try (apply isapropdirprod) ; apply isapropunit). } use total2_paths_f. 2: { apply proofirrelevance ; repeat (apply impred_isaprop ; intro) ; apply cellset_property. } apply funextsec ; intro. use equality_of_2cells_in_ACTI. intro. apply p. Qed. Lemma equality_of_ACAT_endofunctors {a b : psfunctor_bicat ACAT ACAT} {f g : (psfunctor_bicat ACAT ACAT)⟦a,b⟧} (α β : prebicat_cells (psfunctor_bicat ACAT ACAT) f g) : (∏ x : ACAT, ∏ x0 : pr11 ((pr111 a) x), (pr11 ((pr111 α) x)) x0 = (pr11 ((pr111 β) x)) x0) -> α = β. Proof. intro p. use total2_paths_f. 2: { apply proofirrelevance ; apply isapropunit. } use total2_paths_f. 2: { use total2_paths_f ; (apply proofirrelevance ; try (apply isapropdirprod) ; apply isapropunit). } use total2_paths_f. 2: { apply proofirrelevance ; repeat (apply impred_isaprop ; intro) ; apply cellset_property. } apply funextsec ; intro. use equality_of_2cells_in_ACAT. intro. apply p. Qed. End EqualityLemmaHelpers. Section FromActegoriesToActionsInCat. Import MonoidalNotations. Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats). Definition acat_to_acti_on_ob : ob ACAT -> ob ACTI := λ act, actegory_to_object Mon_V ax2 (pr2 act). Lemma actegory_hom_preserves_unitor_inv {a1 a2 : ACAT} (f : ACAT ⟦ a1, a2 ⟧) (c : pr11 (actegory_to_object Mon_V ax2 (pr2 a1))) : actegory_unitorinvdata (pr2 a2 : actegory _ _) (pr1 (pr1 f) c) · (pr12 f) I_{ Mon_V} c = # (pr11 f) (actegory_unitorinvdata (pr2 a1 : actegory _ _) c). Proof. set (t := (pr222 (pr22 f)) c). (* preserves_unitor *) apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_unitorisolaw Mon_V (pr2 a2) (pr1 (pr1 f) c))). cbn. etrans. 2: { apply maponpaths_2 ; apply t. } rewrite assoc'. rewrite <- functor_comp. rewrite (pr1 (actegory_unitorisolaw Mon_V (pr2 a1) c)). rewrite functor_id. apply (! id_right _). Qed. Definition acat_to_acti_on_mor_data_data {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : nat_trans_data (ActionBasedStrongFunctorsWhiskeredMonoidal.H(V:=V)(FA':=pr12(actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f)) (ActionBasedStrongFunctorsWhiskeredMonoidal.H'(FA:=pr12(actegory_to_object Mon_V ax2 (pr2 a1))) (pr1 f)). Proof. intro v. exists (λ c, pr1 (pr2 f) v c). abstract (exact (λ c1 c2 g, pr1 (pr22 f) v c1 c2 g)). Defined. Definition acat_to_acti_on_mor_data_data_is_nat_trans {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : is_nat_trans _ _ (acat_to_acti_on_mor_data_data f). Proof. intros v w g. use nat_trans_eq. { apply homset_property. } intro c. cbn. exact (pr12 (pr22 f) v w c g). Qed. Definition acat_to_acti_on_mor_data {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat(V:=V) (FA:=pr12(actegory_to_object Mon_V ax2 (pr2 a1)))(FA':=pr12(actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f) := _,,acat_to_acti_on_mor_data_data_is_nat_trans f. Lemma acat_to_acti_on_mor_laws {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : ActionBasedStrongFunctorsWhiskeredMonoidal.param_distr_bicat_triangle_eq (monoidal_swapped Mon_V) (pr22 (actegory_to_object Mon_V ax2 (pr2 a1))) (pr22 (actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f) (acat_to_acti_on_mor_data f) × ActionBasedStrongFunctorsWhiskeredMonoidal.param_distr_bicat_pentagon_eq (monoidal_swapped Mon_V) (pr22 (actegory_to_object Mon_V ax2 (pr2 a1))) (pr22 (actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f) (acat_to_acti_on_mor_data f). Proof. split. - use nat_trans_eq. { apply homset_property. } intro c ; cbn ; rewrite ! id_left ; apply actegory_hom_preserves_unitor_inv. - intros v w. use nat_trans_eq. { apply homset_property. } intro c ; cbn ; rewrite ! id_left ; assert (t := pr122 (pr22 f) w v c) ; apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_actorisolaw Mon_V (pr2 a2) _ _ _)) ; rewrite assoc ; set (i := (_,,_,,actegory_actorisolaw Mon_V (pr2 a1) w v c) : z_iso _ _) ; apply (z_iso_inv_on_left _ _ _ _ (functor_on_z_iso (pr1 f) i)) ; cbn ; rewrite assoc ; rewrite t ; apply idpath. Qed. Definition acat_to_acti_on_mor {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : ACTI⟦actegory_to_object Mon_V ax2 (pr2 a1), actegory_to_object Mon_V ax2 (pr2 a2)⟧. Proof. exists (pr1 f). exists (acat_to_acti_on_mor_data f). apply acat_to_acti_on_mor_laws. Defined. Definition acat_to_acti_data : psfunctor_data ACAT ACTI. Proof. use make_psfunctor_data. - exact acat_to_acti_on_ob. - exact (λ a1 a2 f, acat_to_acti_on_mor f). - intros a1 a2 f g α. exists (pr1 α). abstract (intro v; use nat_trans_eq; [apply homset_property | exact (λ c, pr2 α v c)]). - intro a. use tpair. + apply nat_trans_id. + abstract (intro v; use nat_trans_eq; [apply homset_property | ] ; intro c; cbn ; unfold identity_lineator_data ; rewrite ! id_left ; rewrite id_right ; apply (! bifunctor_leftid (_ ,, pr122 a) _ _)). - intros a1 a2 a3 f g. use tpair. { simpl. apply nat_trans_id. } abstract (intro v; use nat_trans_eq; [apply homset_property | intro c; cbn; rewrite (bifunctor_leftid (_ ,, pr122 a3)); rewrite ! id_left; rewrite ! id_right; apply idpath]). Defined. Definition acat_to_acti_laws : psfunctor_laws acat_to_acti_data. Proof. repeat split ; (intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; try (apply idpath) ; cbn). - rewrite ! id_right ; apply (! functor_id _ _). - rewrite ! id_right ; apply idpath. - rewrite ! id_right ; rewrite (! functor_id _ _) ; rewrite id_left ; apply idpath. - rewrite id_left ; apply (! id_right _). - rewrite id_left ; apply (! id_right _). Qed. Definition acat_to_acti_invertible_cells : invertible_cells acat_to_acti_data. Proof. use tpair. - intro. use tpair. + use tpair. * apply nat_trans_id. * intro. use nat_trans_eq. { apply homset_property. } intro. cbn. rewrite ! id_right. apply (! bifunctor_leftid (_ ,, pr122 a) _ _). + use tpair ; use equality_of_2cells_in_ACTI ; intro ; apply id_right. - intro ; intros. use tpair. + use tpair. * apply nat_trans_id. * intro. use nat_trans_eq. { apply homset_property. } intro. simpl. rewrite ! id_right. rewrite ! id_left. rewrite (bifunctor_leftid (_ ,, pr122 c)). apply (! id_left _). + use tpair ; use equality_of_2cells_in_ACTI ; intro ; apply id_right. Qed. Definition acat_to_acti : psfunctor ACAT ACTI. Proof. use make_psfunctor. - exact acat_to_acti_data. - exact acat_to_acti_laws. - exact acat_to_acti_invertible_cells. Defined. End FromActegoriesToActionsInCat. Section FromActionInCatToActegories. Definition acti_to_acat_on_ob : (ob ACTI) -> (ob ACAT) := λ act, _ ,, actegory_from_object _ ax2 act. Definition acti_to_acat_on_mor_lineator_data {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧) : lineator_data Mon_V (actegory_from_object (monoidal_swapped Mon_V) ax2 a1) (actegory_from_object (monoidal_swapped Mon_V) ax2 a2) (pr1 f) := λ v c, pr1 (pr112 f v) c. Definition acti_to_acat_on_mor_lineator_lax_laws {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧) : lineator_laxlaws Mon_V (actegory_from_object (monoidal_swapped Mon_V) ax2 a1) (actegory_from_object (monoidal_swapped Mon_V) ax2 a2) (pr1 f) (acti_to_acat_on_mor_lineator_data f). Proof. repeat split. - intros v c1 c2 g. exact (pr2 (pr112 f v) c1 c2 g). - intros v w c g. exact (eqtohomot (base_paths _ _ (pr212 f v w g)) c). - intros v w c. induction f as [f [δ [tri pent]]]. assert (tt := eqtohomot (base_paths _ _ (pent w v)) c). cbn in tt. rewrite ! id_left in tt. transparent assert (z_iso_ptwvFc : (is_z_isomorphism ( pr1 (fmonoidal_preservestensordata (pr22 a2) w v) (pr1 f c))) ). { exists (pr11 (fmonoidal_preservestensorstrongly (pr22 a2) w v) (pr1 f c)). exists (eqtohomot (base_paths _ _ (pr12 (fmonoidal_preservestensorstrongly (pr22 a2) w v))) (pr1 f c)). exact (eqtohomot (base_paths _ _ (pr22 (fmonoidal_preservestensorstrongly (pr22 a2) w v))) (pr1 f c)). } assert (tt' := ! z_iso_inv_on_right _ _ _ (_,,z_iso_ptwvFc) _ _ (! tt)). etrans. { apply maponpaths_2. exact tt'. } cbn. clear tt'. etrans. 2: { apply assoc. } etrans. { apply assoc'. } apply maponpaths. etrans. { apply assoc'. } etrans. { apply assoc'. } apply maponpaths. etrans. { apply maponpaths. rewrite (! functor_comp f _ _). apply maponpaths. exact (eqtohomot (base_paths _ _ (pr12 (pr1 (pr222 a1) w v))) c). } simpl. rewrite functor_id. apply id_right. - (* preserves_unitor *) intro c. induction f as [F [δ [tri pent]]]. assert (tric := eqtohomot (base_paths _ _ tri) c). cbn in tric. rewrite ! id_left in tric. transparent assert (z_iso_puFc : (is_z_isomorphism ( pr1 (fmonoidal_preservesunit (pr22 a2)) (pr1 F c)))). { exists (pr11 (fmonoidal_preservesunitstrongly (pr22 a2))(pr1 F c)). exists (eqtohomot (base_paths _ _ (pr122 (pr222 a2))) (pr1 F c)). exact (eqtohomot (base_paths _ _ (pr222 (pr222 a2))) (pr1 F c)). } assert (tric' := ! z_iso_inv_on_right _ _ _ (_,,z_iso_puFc) _ _ (! tric)). etrans. { apply maponpaths_2 ; exact tric'. } clear tric'. clear tric. rewrite assoc'. etrans. { apply maponpaths. exact (! functor_comp F (pr1 (fmonoidal_preservesunit (pr22 a1)) c) _). } etrans. { do 2 apply maponpaths. exact (eqtohomot (base_paths _ _ (pr122 (pr222 a1))) c). } rewrite (functor_id F _). apply id_right. Qed. Definition acti_to_acat_on_mor_lineator_lax {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧) : lineator_lax Mon_V (actegory_from_object (monoidal_swapped Mon_V) ax2 a1) (actegory_from_object (monoidal_swapped Mon_V) ax2 a2) (pr1 f). Proof. exists (acti_to_acat_on_mor_lineator_data f). exact (acti_to_acat_on_mor_lineator_lax_laws f). Defined. Definition acti_to_acat_on_mor {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧) : ACAT ⟦ acti_to_acat_on_ob a1, acti_to_acat_on_ob a2⟧. Proof. exists (pr1 f). exact (acti_to_acat_on_mor_lineator_lax f). Defined. Definition acti_to_acat_data : psfunctor_data ACTI ACAT. Proof. use make_psfunctor_data. - exact acti_to_acat_on_ob. - exact (λ a1 a2 f, acti_to_acat_on_mor f). - intros a1 a2 f g α. exists (pr1 α). intros v a. exact (eqtohomot (base_paths _ _ (pr2 α v)) a). - intro a. use tpair. + exists (λ c, identity c). intro ; intros ; exact (id_right _ @ ! id_left _). + intros v c. cbn. rewrite ! id_right. unfold identity_lineator_data. cbn. apply (! functor_id _ _). - intros a1 a2 a3 f g. use tpair. + exists (λ c, identity _). intro ; intros ; exact (id_right _ @ ! id_left _). + intros v c. cbn. unfold comp_lineator_data. cbn. rewrite ! id_right. rewrite ! id_left. cbn. rewrite (functor_id ((pr12 a3) v)). rewrite id_left. apply idpath. Defined. Definition acti_to_acat_laws : psfunctor_laws acti_to_acat_data. Proof. repeat split ; (intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; try (apply idpath) ; cbn). - rewrite ! id_right ; apply (! functor_id _ _). - rewrite ! id_right ; apply idpath. - rewrite ! id_right ; rewrite (! functor_id _ _) ; rewrite id_left ; apply idpath. - rewrite id_left ; apply (! id_right _). - rewrite id_left ; apply (! id_right _). Qed. Definition acti_to_acat_invertible_cells : invertible_cells acti_to_acat_data. Proof. use tpair. - intro. use tpair. + use tpair. * apply nat_trans_id. * intro ; intro. cbn. rewrite ! id_right. apply (! functor_id _ _). + use tpair ; use equality_of_2cells_in_ACAT ; intro ; apply id_right. - intro ; intros. use tpair. + use tpair. * apply nat_trans_id. * intro ; intro. rewrite ! id_right. etrans. 2: { apply cancel_postcomposition. cbn. apply pathsinv0, functor_id. } rewrite id_left. cbn. unfold ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat_funclass. unfold comp_lineator_data. cbn. rewrite ! id_right. rewrite ! id_left. apply idpath. + use tpair ; use equality_of_2cells_in_ACAT ; intro ; apply id_right. Qed. Definition acti_to_acat : psfunctor ACTI ACAT. Proof. use make_psfunctor. - exact acti_to_acat_data. - exact acti_to_acat_laws. - exact acti_to_acat_invertible_cells. Defined. End FromActionInCatToActegories. Section ActionInCatEquivActegories. Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats). Definition acti_to_acat_unit_data_on_ob (a : ACTI) : ACTI ⟦Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat a, Identity.id_psfunctor ACTI a⟧. Proof. exists (identity _). use tpair. + use make_nat_trans. * intro v. exists (λ c, identity _). intros c1 c2 f. abstract ( simpl ; rewrite id_left ; apply id_right). * intros v w f. use nat_trans_eq. { apply homset_property. } abstract ( intro c; cbn; rewrite id_left; apply id_right ). + use tpair. * use nat_trans_eq. { apply homset_property. } intro c. abstract ( cbn ; rewrite id_right ; rewrite ! id_left ; apply idpath). * intro ; intro. use nat_trans_eq. { apply homset_property. } intro c. abstract ( cbn ; rewrite ! id_left ; rewrite ! id_right ; rewrite (functor_id ((pr12 a) w)) ; apply (! id_left _)). Defined. Definition acti_to_acat_unit_data : pstrans_data (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) (Identity.id_psfunctor ACTI). Proof. use make_pstrans_data. - exact (λ a, acti_to_acat_unit_data_on_ob a). - intros a1 a2 f. use tpair. + use tpair. * exists (λ c, identity _). intros c1 c2 g. abstract ( simpl ; rewrite id_left ; apply id_right ). * intro. use nat_trans_eq. { apply homset_property. } intro. abstract ( cbn ; rewrite ! id_left ; rewrite ! id_right ; unfold ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat_funclass ; rewrite (functor_id (pr1 f)) ; rewrite (functor_id ((pr12 a2) v)) ; rewrite id_left ; apply id_right ). + use tpair. * use tpair. -- exists (λ c, identity _). intros c1 c2 g. simpl. rewrite id_left. apply id_right. -- intro. use nat_trans_eq. { apply homset_property. } intro. abstract ( simpl ; rewrite ! id_left ; rewrite ! id_right ; rewrite (functor_id ((pr12 a2) v)) ; rewrite (functor_id (pr1 f)) ; rewrite id_left ; apply (! id_right _) ). * use tpair ; use equality_of_2cells_in_ACTI ; intro ; simpl ; apply id_right. Defined. Lemma acti_to_acat_unit_is_pstrans : is_pstrans acti_to_acat_unit_data. Proof. repeat split ; intros ; intros ; use equality_of_2cells_in_ACTI ; intro ; intros ; simpl. - rewrite id_left ; apply id_right. - rewrite id_left ; apply (! id_left _). - rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id _ _). Qed. Definition acti_to_acat_unit : pstrans (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) (Identity.id_psfunctor ACTI). Proof. use make_pstrans. - exact acti_to_acat_unit_data. - exact acti_to_acat_unit_is_pstrans. Defined. Definition acti_to_acat_counit_data_on_ob (a : ACAT) : ACAT ⟦Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2) a, Identity.id_psfunctor ACAT a⟧. Proof. exists (identity _). exists (λ _ _, identity _). abstract ( simpl ; repeat split ; (intro ; intros ; try (rewrite id_right ; rewrite id_left ; apply idpath)) ; [ rewrite id_left ; rewrite id_right ; rewrite (bifunctor_leftid (_ ,, pr122 a)) ; apply (! id_right _) | rewrite id_left ; apply idpath ]). Defined. Definition acti_to_acat_counit_data : pstrans_data (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) (Identity.id_psfunctor ACAT). Proof. use make_pstrans_data. - exact (λ a, acti_to_acat_counit_data_on_ob a). - intros a1 a2 f. use tpair. + use tpair. * exists (λ c, identity _). intros c1 c2 g. abstract ( simpl ; rewrite id_left ; apply id_right ). * abstract ( intro ; intro ; simpl ; unfold comp_lineator_data ; simpl ; rewrite functor_id ; rewrite ! id_right ; rewrite (bifunctor_leftid (_ ,, pr122 a2)); rewrite ! id_left ; apply idpath ). + use tpair. * use tpair. -- exists (λ c, identity _). abstract ( intros c1 c2 g ; simpl ; rewrite id_left ; apply id_right ). -- abstract ( intro ; intro ; simpl ; unfold comp_lineator_data ; simpl ; rewrite functor_id ; rewrite ! id_right ; rewrite (bifunctor_leftid (_ ,, pr122 a2)) ; rewrite ! id_left ; apply idpath ). * use tpair ; use equality_of_2cells_in_ACAT ; intro ; simpl ; apply id_right. Defined. Lemma acti_to_acat_counit_is_pstrans : is_pstrans acti_to_acat_counit_data. Proof. repeat split ; intros ; intros ; use equality_of_2cells_in_ACAT ; intro ; intros ; simpl. - rewrite id_left ; apply id_right. - rewrite id_left ; apply (! id_left _). - rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id _ _). Qed. Definition acti_to_acat_counit : pstrans (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) (Identity.id_psfunctor ACAT). Proof. use make_pstrans. - exact acti_to_acat_counit_data. - exact acti_to_acat_counit_is_pstrans. Defined. Definition acti_biequiv_unit_counit_acat : is_biequivalence_unit_counit acti_to_acat (acat_to_acti ax2). Proof. exists acti_to_acat_unit. exact acti_to_acat_counit. Defined. Definition ps_base_ACTI : Base.ps_base ACTI ACTI ⟦ pr111 (Identity.id_psfunctor ACTI), pr111 (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) ⟧. Proof. intro. exists (functor_identity _). use tpair. + use make_nat_trans. * intro. exists (λ _, identity _). abstract ( intro ; intros ; rewrite id_left ; apply id_right ). * intro ; intros ; use nat_trans_eq. { apply homset_property. } intro ; cbn; rewrite id_left; apply id_right. + use tpair. * use nat_trans_eq. { apply homset_property. } abstract ( intro ; cbn ; rewrite ! id_left ; apply id_right ). * intro ; intro. use nat_trans_eq. { apply homset_property. } abstract ( intro ; cbn ; rewrite ! id_left ; rewrite ! id_right ; rewrite (functor_id ((pr12 x) w)) ; apply (! id_left _) ). Defined. Definition ps_base_ACAT : Base.ps_base ACAT ACAT ⟦ pr111 (Identity.id_psfunctor ACAT), pr111 (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) ⟧. Proof. intro. exists (functor_identity _). repeat (use tpair). - exact (λ _ _, identity _). - abstract ( intro ; intros ; rewrite id_left ; apply id_right ). - abstract ( intro ; intros ; rewrite id_left ; apply id_right ). - abstract ( intro ; intros ; cbn ; rewrite (bifunctor_leftid (_ ,, pr122 x)) ; rewrite ! id_left ; rewrite ! id_right ; apply idpath ). - abstract (intro ; apply id_left). Defined. Definition ACAT_invertible_2cell {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) : invertible_2cell (ps_base_ACAT a1 · acti_to_acat_on_mor (acat_to_acti_on_mor ax2 f)) (f · ps_base_ACAT a2). Proof. repeat (use tpair). - exact (λ _, identity _). - abstract ( intro ; intros ; cbn ; rewrite id_left ; apply id_right ). - abstract ( intro ; intro ; cbn ; unfold comp_lineator_data ; simpl ; rewrite (bifunctor_leftid (_ ,, pr122 a2)) ; rewrite ! id_left ; rewrite functor_id ; rewrite id_right ; apply id_right ). - exact (λ _, identity _). - abstract ( intro ; intros ; cbn ; rewrite id_left ; apply id_right ). - abstract ( intro ; intro ; cbn ; unfold comp_lineator_data ; simpl ; rewrite (bifunctor_leftid (_ ,, pr122 a2)) ; rewrite ! id_left ; rewrite functor_id ; apply idpath ). - abstract (use equality_of_2cells_in_ACAT; intro; cbn; apply id_right). - abstract (use equality_of_2cells_in_ACAT; intro; cbn; apply id_right). Defined. Definition ACTI_invertible_2cell {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧) : invertible_2cell (ps_base_ACTI a1 · acat_to_acti_on_mor ax2 (acti_to_acat_on_mor f)) (f · ps_base_ACTI a2). Proof. use tpair. - use tpair. + exists (λ _, identity _). abstract ( intro ; intros ; cbn ; rewrite id_left ; apply id_right ). + intro. use nat_trans_eq. { apply homset_property. } abstract ( intro ; cbn ; rewrite (functor_id (pr1 f)) ; rewrite ! id_left ; rewrite ! id_right ; rewrite (functor_id ((pr12 a2) v)) ; apply (! id_left _) ). - use tpair. + use tpair. * exists (λ _, identity _). abstract ( intro ; intros ; rewrite id_left ; apply id_right ). * intro. use nat_trans_eq. { apply homset_property. } abstract ( intro ; cbn ; rewrite (functor_id (pr1 f)) ; rewrite ! id_left ; rewrite ! id_right ; rewrite (functor_id ((pr12 a2) v)) ; apply (! id_left _) ). + abstract ( use tpair ; use equality_of_2cells_in_ACTI ; intro ; simpl ; apply id_left). Defined. Definition ps_functor_ACTI : psfunctor_bicat ACTI ACTI ⟦ Identity.id_psfunctor ACTI, Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat ⟧. Proof. refine (_ ,, tt). use tpair. - exists ps_base_ACTI. exact (λ a1 a2 f, ACTI_invertible_2cell f). - repeat (use tpair) ; (intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; simpl). + abstract (rewrite id_left ; apply id_right). + abstract (apply idpath). + abstract (rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id (pr1 g) _) ). Defined. Definition ps_functor_ACAT : psfunctor_bicat ACAT ACAT ⟦ Identity.id_psfunctor ACAT, Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2) ⟧. Proof. refine (_ ,, tt). use tpair. - exists ps_base_ACAT. exact (λ a1 a2 f, ACAT_invertible_2cell f). - repeat (use tpair) ; (intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; simpl). + abstract (rewrite id_left ; apply id_right). + abstract (apply idpath). + abstract (rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id (pr1 g) _) ). Defined. Definition unit_left_adjoint_data : Adjunctions.left_adjoint_data acti_to_acat_unit. Proof. exists ps_functor_ACTI. use tpair ; refine (_ ,, tt). - use tpair. + use tpair. * intro. use tpair. -- exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; rewrite id_right ; apply idpath ). -- intro ; intros. use nat_trans_eq. { apply homset_property. } abstract ( intro ; cbn ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). * abstract ( intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; simpl ; rewrite ! id_right ; apply (! functor_id (pr1 f) _) ). + exact (tt,,(tt,,tt)). - use tpair. + use tpair. * intro. use tpair. -- exists (λ _, identity _). abstract ( intro ; intros ; rewrite id_left ; apply id_right ). -- intro ; intros. use nat_trans_eq. { apply homset_property. } abstract ( intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). * abstract ( intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; simpl ; rewrite (functor_id (pr1 f) _) ; rewrite ! id_right ; apply idpath ). + exact (tt,, (tt,,tt)). Defined. Definition counit_left_adjoint_data : Adjunctions.left_adjoint_data acti_to_acat_counit. Proof. exists ps_functor_ACAT. use tpair ; refine (_ ,, tt). - use tpair. + use tpair. * intro. use tpair. -- exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; rewrite id_right ; apply idpath ). -- abstract ( intro ; intros ; cbn ; rewrite (bifunctor_leftid (_ ,, pr122 x)) ; rewrite ! id_left ; apply (! id_right _) ). * abstract ( intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; cbn ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). + exact (tt,,(tt,,tt)). - use tpair. + use tpair. * intro. use tpair. -- exists (λ _, identity _). abstract ( intro ; intros ; rewrite id_left ; apply id_right ). -- abstract ( intro ; intros ; simpl ; rewrite (bifunctor_leftid (_ ,, pr122 x)) ; apply id_right ). * abstract ( intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; cbn ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _)). + exact (tt,,(tt,,tt)). Defined. Lemma unit_left_adjoints_axioms : Adjunctions.left_adjoint_axioms unit_left_adjoint_data. Proof. use tpair ; apply equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; rewrite ! id_right ; apply idpath. Qed. Definition invertible_2cell_unit_data (a : ACTI) : prebicat_cells ACTI ((pr111 (acti_to_acat_unit · Adjunctions.left_adjoint_right_adjoint unit_left_adjoint_data)) a) ((pr111 (identity (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat))) a). Proof. use tpair. + exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; apply id_right ). + intro ; intros. use nat_trans_eq. { apply homset_property. } abstract ( intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). Defined. Lemma is_invertible_2cell_unit : is_invertible_2cell (Adjunctions.left_adjoint_unit unit_left_adjoint_data). Proof. use make_is_invertible_2cell. - use tpair. + use tpair. * exists (λ a, invertible_2cell_unit_data a). do 3 intro ; use equality_of_2cells_in_ACTI. abstract ( intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). * repeat (use tpair) ; try (exact tt). + exact tt. - abstract ( use equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; apply id_right ). - abstract (use equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; apply id_right). Qed. Lemma is_invertible_2cell_counit : is_invertible_2cell (Adjunctions.left_adjoint_counit unit_left_adjoint_data). Proof. repeat (use tpair) ; try (exact tt). - intro. use tpair. + exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; apply id_right ). + intro ; intros. use nat_trans_eq. { apply homset_property. } abstract ( intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). - abstract ( intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). - abstract ( use equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; apply id_right ). - abstract ( use equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; apply id_right ). Qed. Definition prebicat_cells_ACAT (a : ACAT) : prebicat_cells ACAT ((pr111 (identity (Identity.id_psfunctor ACAT))) a) ((pr111 (Adjunctions.left_adjoint_right_adjoint counit_left_adjoint_data · acti_to_acat_counit)) a). Proof. use tpair. + exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; apply id_right ). + abstract ( intro ; intros ; simpl ; rewrite (bifunctor_leftid (_ ,, pr122 a)) ; apply (! id_left _) ). Defined. Lemma is_invertible_2cell_counit' : is_invertible_2cell (Adjunctions.left_adjoint_counit counit_left_adjoint_data). Proof. repeat (use tpair) ; try (exact tt). - exact (λ _, prebicat_cells_ACAT _). - abstract ( intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). - abstract ( use equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; apply id_right ). - abstract ( use equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; apply id_right ). Qed. Lemma counit_left_adjoints_axioms : Adjunctions.left_adjoint_axioms counit_left_adjoint_data. Proof. use tpair ; apply equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; rewrite ! id_right ; apply idpath. Qed. Lemma is_invertible_2cell_unit' : is_invertible_2cell (Adjunctions.left_adjoint_unit counit_left_adjoint_data). Proof. repeat (use tpair) ; try (exact tt). - intro. use tpair. + exists (λ _, identity _). abstract ( intro ; intros ; simpl ; rewrite id_left ; apply id_right ). + abstract ( intro ; intros ; simpl ; unfold comp_lineator_data ; unfold identity_lineator_data ; cbn ; rewrite (bifunctor_leftid (_ ,, pr122 x)) ; apply id_right ). - abstract ( intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; simpl ; rewrite ! id_left ; rewrite id_right ; apply (! functor_id _ _) ). - abstract ( use equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; apply id_right ). - abstract (use equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; apply id_right). Qed. Lemma unit_left_adjoint_equiv_axiom : Adjunctions.left_equivalence_axioms unit_left_adjoint_data. Proof. exists is_invertible_2cell_unit. exact is_invertible_2cell_counit. Qed. Lemma counit_left_adjoint_equiv_axiom : Adjunctions.left_equivalence_axioms counit_left_adjoint_data. Proof. exists is_invertible_2cell_unit'. exact is_invertible_2cell_counit'. Qed. Definition unit_left_adjoint_equivalence : Adjunctions.left_adjoint_equivalence (unit_of_is_biequivalence acti_biequiv_unit_counit_acat). Proof. exists unit_left_adjoint_data. exists unit_left_adjoints_axioms. exact unit_left_adjoint_equiv_axiom. Defined. Definition counit_left_adjoint_equivalence : Adjunctions.left_adjoint_equivalence (counit_of_is_biequivalence acti_biequiv_unit_counit_acat). Proof. exists counit_left_adjoint_data. exists counit_left_adjoints_axioms. exact counit_left_adjoint_equiv_axiom. Defined. Definition acti_biequiv_adj_acat : is_biequivalence_adjoints acti_biequiv_unit_counit_acat. Proof. exists unit_left_adjoint_equivalence. exact counit_left_adjoint_equivalence. Defined. Definition acti_is_biequiv_acat : is_biequivalence acti_to_acat. Proof. exists (acat_to_acti ax2). exists acti_biequiv_unit_counit_acat. exact acti_biequiv_adj_acat. Defined. Definition acti_biequiv_acat : biequivalence ACTI ACAT. Proof. exists (acti_to_acat). exact acti_is_biequiv_acat. Defined. End ActionInCatEquivActegories. IdempotencePointedFunctorsWhiskeredMonoidal.v000066400000000000000000000221111451125700300337650ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories(* In this file we show that for any category C, the monoidal category of pointed functors of C is equivalent to the monoidal category of monoidal-pointed objects in the monoidal category of pointed functors of C. By equivalence, we mean that these two monoidal categories are (internally) equivalent as objects in the bicategory of monoidal categories *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.Bicategories.Core.Bicat. (* The monoidal categories of endofunctors that we compare are defined in the following files: *) Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. (* The notion of internal adjoint equivalences in a bicategory is defined in: *) Require Import UniMath.Bicategories.Morphisms.Adjunctions. (* The necessary bicategories *) Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfWhiskeredMonCats. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Local Open Scope cat. Section PointedFunctorsIdempotentGeneralMonoidalCats. Context {V : category} (Mon_V : monoidal V). Definition adj_equivalence_ptdfunctor_in_cat : adjoint_equivalence (B := bicat_of_cats) (coslice_cat_total V (monoidal_unit Mon_V)) (coslice_cat_total (coslice_cat_total V (monoidal_unit Mon_V)) (monoidal_unit (monoidal_pointed_objects Mon_V))). Proof. use make_adjoint_equivalence. - exact (ptdob_to_ptdptdob Mon_V). - exact (ptdptdob_to_ptdob Mon_V). - exact (unit_ptdob Mon_V). - exact (counit_ptdob Mon_V). - use nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } use total2_paths_f. 2: { apply homset_property. } simpl. rewrite ! id_right. apply idpath. - use nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } simpl. rewrite ! id_right. apply idpath. - repeat (use tpair). + intro. exists (identity _). apply id_right. + intro ; intros. use total2_paths_f. 2: { apply homset_property. } etrans. { apply id_right. } apply (! id_left _). + apply nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } apply id_right. + apply nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } apply id_right. - repeat (use tpair). + intro. exists (identity _). use total2_paths_f. 2: { apply homset_property. } simpl. rewrite (! pr22 x). rewrite id_left. apply id_right. + intro ; intros. use total2_paths_f. 2: { apply homset_property. } etrans. { apply id_right. } apply (! id_left _). + apply nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } apply id_right. + apply nat_trans_eq. { apply homset_property. } intro. use total2_paths_f. 2: { apply homset_property. } apply id_right. Defined. Definition disp_left_adjoint_data_ptdfunctor_in_moncat : disp_left_adjoint_data (D := bidisp_monbicat_disp_prebicat) adj_equivalence_ptdfunctor_in_cat (ptdob_to_ptdptdob_fmonoidal Mon_V). Proof. exists (ptdptdob_to_ptdob_fmonoidal Mon_V). split. + use tpair. * intro ; intros. abstract ( use total2_paths_f ; [ simpl ; rewrite (bifunctor_leftid Mon_V) ; rewrite (bifunctor_rightid Mon_V) ; rewrite ! id_right ; apply idpath | apply homset_property ] ). * abstract (use total2_paths_f ; [apply idpath | apply homset_property ]). + use tpair. * intro ; intros. abstract ( use total2_paths_f ; [ use total2_paths_f ; [ simpl ; rewrite (bifunctor_leftid Mon_V) ; rewrite (bifunctor_rightid Mon_V) ; rewrite ! id_right ; apply idpath | apply homset_property ] | apply homset_property ] ). * abstract ( use total2_paths_f ; [ use total2_paths_f ; [ simpl ; rewrite ! id_right ; apply idpath | apply homset_property ] | apply homset_property ] ). Defined. Lemma disp_left_adjoint_axioms_ptdfunctor_in_moncat : disp_left_adjoint_axioms adj_equivalence_ptdfunctor_in_cat disp_left_adjoint_data_ptdfunctor_in_moncat. Proof. split. * use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. * use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. Qed. Lemma disp_left_equivalence_axioms_ptdfunctor_in_moncat : disp_left_equivalence_axioms adj_equivalence_ptdfunctor_in_cat disp_left_adjoint_data_ptdfunctor_in_moncat. Proof. repeat (use tpair). - intro ; intro. use total2_paths_f. 2: { apply homset_property. } simpl. rewrite (bifunctor_rightid Mon_V). rewrite (bifunctor_leftid Mon_V). apply idpath. - use total2_paths_f. 2: { apply homset_property. } simpl. rewrite ! id_right. apply idpath. - use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. - use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. - intro ; intro. use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). use total2_paths_f. 2: { apply homset_property. } simpl. rewrite (bifunctor_rightid Mon_V). rewrite (bifunctor_leftid Mon_V). rewrite ! id_right. apply idpath. - use total2_paths_f. 2: { apply homset_property. } use total2_paths_f. 2: { apply homset_property. } simpl. apply idpath. - use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. - use total2_paths_f. 2: { apply homset_property. } repeat (apply funextsec ; intro). apply homset_property. Qed. Definition disp_adj_equivalence_ptdfunctor_in_moncat : disp_left_adjoint_equivalence (D := bidisp_monbicat_disp_prebicat) adj_equivalence_ptdfunctor_in_cat (ptdob_to_ptdptdob_fmonoidal Mon_V). Proof. exists disp_left_adjoint_data_ptdfunctor_in_moncat. exists disp_left_adjoint_axioms_ptdfunctor_in_moncat. exact disp_left_equivalence_axioms_ptdfunctor_in_moncat. Defined. Definition adj_equivalence_ptdfunctor_in_moncat : adjoint_equivalence (B := monbicat) (_ ,, monoidal_pointed_objects Mon_V) (_ ,, monoidal_pointed_objects (monoidal_pointed_objects Mon_V)). Proof. use (invmap (adjoint_equivalence_total_disp_weq _ _) _). exists adj_equivalence_ptdfunctor_in_cat. exists (ptdob_to_ptdptdob_fmonoidal Mon_V). exact disp_adj_equivalence_ptdfunctor_in_moncat. Defined. End PointedFunctorsIdempotentGeneralMonoidalCats. Definition adj_equivalence_ptdfunctor (C : category) : adjoint_equivalence (B := monbicat) (_ ,, pointedfunctors_moncat C) (_ ,, monoidal_pointed_objects (pointedfunctors_moncat C)) := adj_equivalence_ptdfunctor_in_moncat (monoidal_of_endofunctors C). UniMath-20231010/UniMath/Bicategories/MonoidalCategories/MonadsAsMonoidsWhiskered.v000066400000000000000000000104641451125700300301240ustar00rootroot00000000000000(** In this file, we show that the monoids in the monoidal category of endofunctors correspond to the monads. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Section FixTheContext. Context {C : category}. Let ENDO : category := cat_of_endofunctors C. Let M_ENDO : monoidal ENDO := monoidal_of_endofunctors C. Let MON : category := category_of_monoids_in_monoidal_cat M_ENDO. Section MonoidToMonadOb. Context (M : MON). Let x : ENDO := monoid_carrier _ M. Let η : ENDO ⟦ monoidal_unit M_ENDO, x ⟧ := monoid_unit _ M. Let μ : ENDO ⟦ x ⊗_{M_ENDO} x, x⟧ := monoid_multiplication _ M. Definition monoid_to_disp_Monad_data : disp_Monad_data x := μ,, η. Lemma monoid_to_disp_Monad_laws : disp_Monad_laws monoid_to_disp_Monad_data. Proof. repeat split. - intro c. set (t := monoid_right_unit_law _ M). exact (eqtohomot (base_paths _ _ t) c). - intro c. set (t := monoid_left_unit_law _ M). exact (eqtohomot (base_paths _ _ t) c). - intro c. set (t := monoid_assoc_law _ M). refine (! (eqtohomot (base_paths _ _ t) c) @ _). etrans. 1: apply assoc'. apply id_left. Qed. Definition monoid_to_monad : Monad C := _ ,, _ ,, monoid_to_disp_Monad_laws. End MonoidToMonadOb. Section MonadToMonoidOb. Context (M : Monad C). Let x : ENDO := M : functor _ _. Let η : ENDO ⟦ monoidal_unit M_ENDO, x ⟧ := η M. Let μ : ENDO ⟦ x ⊗_{M_ENDO} x, x⟧ := μ M. Definition monad_to_monoid_data : monoid_data M_ENDO x := μ ,, η. Lemma monad_to_monoid_laws : monoid_laws M_ENDO monad_to_monoid_data. Proof. repeat split; apply (nat_trans_eq C); intro c; cbn. - apply Monad_law2. - apply Monad_law1. - rewrite id_left. apply pathsinv0, Monad_law3. Qed. Definition monad_to_monoid : MON := x ,, monad_to_monoid_data ,, monad_to_monoid_laws. End MonadToMonoidOb. Definition monoid_equiv_monoid : MON ≃ Monad C. Proof. use weq_iso. - apply monoid_to_monad. - apply monad_to_monoid. - abstract (intro M; use total2_paths_f; [apply idpath | use total2_paths_f; [apply idpath | apply isaprop_monoid_laws]]). - abstract (intro M; use total2_paths_f; [apply idpath | use total2_paths_f; [apply idpath | apply isaprop_disp_Monad_laws]]). Defined. Section MonoidToMonadMor. Context (M N : MON) (f : M --> N). Lemma monoid_to_monad_mor_laws : Monad_Mor_laws (pr1 f : monoid_to_monad M ⟹ monoid_to_monad N). Proof. split. - intro c. set (t := pr12 f). apply pathsinv0. etrans. 2: { exact (eqtohomot (base_paths _ _ t) c). } rewrite (bifunctor_equalwhiskers M_ENDO). apply idpath. - intro c. set (t := pr22 f). exact (eqtohomot (base_paths _ _ t) c). Qed. Definition monoid_to_monad_mor : category_Monad C ⟦monoid_to_monad M, monoid_to_monad N⟧ := pr1 f ,, monoid_to_monad_mor_laws. End MonoidToMonadMor. Section MonadToMonoidMor. Context (M N : Monad C) (f : category_Monad C ⟦M, N⟧). Lemma monad_to_monoid_mor_laws : pr2 (monad_to_monoid M) -->[ pr1 f] pr2 (monad_to_monoid N). Proof. split. - red. rewrite (bifunctor_equalwhiskers M_ENDO). apply (nat_trans_eq C); intro c. apply pathsinv0, Monad_Mor_μ. - apply (nat_trans_eq C); intro c. apply Monad_Mor_η. Qed. Definition monad_to_monoid_mor : monad_to_monoid M --> monad_to_monoid N := pr1 f ,, monad_to_monoid_mor_laws. End MonadToMonoidMor. End FixTheContext. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/MonoidalDialgebrasInserters.v000066400000000000000000000222541451125700300306370ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022, simplified by Kobe Wullaert in December 2022 *) (** ********************************************************** Contents : - identifies monoidal dialgebras as inserters in the bicategory of whiskered monoidal categories ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalFunctorLifting. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfWhiskeredMonCats. Require Import UniMath.Bicategories.Limits.Examples.BicatOfCatsLimits. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Import MonoidalNotations. Local Lemma equality_2cells_monbicat {Mon_V Mon_W : monbicat} {Fm Gm : monbicat ⟦ Mon_V, Mon_W ⟧} (αm βm : (hom Mon_V Mon_W)⟦Fm, Gm⟧) : (∏ x : pr11 Mon_V, pr11 αm x = pr11 βm x) -> αm = βm. Proof. intro p. apply subtypePath. { intro; apply isaprop_is_mon_nat_trans. } apply subtypePath. { intro; apply isaprop_is_nat_trans. apply homset_property. } apply funextsec ; intro ; apply p. Qed. Section FixTwoMonoidalFunctors. Context {Mon_V Mon_W : monbicat} (Fm Gm : monbicat⟦ Mon_V, Mon_W ⟧). Definition monbicat_inserter_cone : inserter_cone Fm Gm. Proof. cbn in Fm, Gm. use make_inserter_cone. - exact (dialgebra (pr1 Fm) (pr1 Gm) ,, dialgebra_monoidal (pr2 Fm) (pr2 Gm)). - exists (dialgebra_pr1 (pr1 Fm) (pr1 Gm)). apply dialgebra_monoidal_pr1. - exists (dialgebra_nat_trans (pr1 Fm) (pr1 Gm)). apply dialgebra_nat_trans_is_mon_nat_trans. Defined. Local Definition underlying_inserter_cone (q : inserter_cone Fm Gm) : inserter_cone (pr1 Fm) (pr1 Gm). Proof. use make_inserter_cone. - exact (pr11 q). - exact (pr1 (inserter_cone_pr1 q)). - exact (pr1 (inserter_cone_cell q)). Defined. Local Definition underlying_inserter_1cell (q : inserter_cone Fm Gm) : inserter_1cell (underlying_inserter_cone q) (dialgebra_inserter_cone (pr1 Fm) (pr1 Gm)) := dialgebra_inserter_ump_1 (pr1 Fm) (pr1 Gm) (underlying_inserter_cone q). (** now comes the very efficient use of monoidal functor lifting *) Local Definition fmonoidal_underlying_inserter_1cell (q : inserter_cone Fm Gm) : fmonoidal (pr21 q) (dialgebra_monoidal (pr2 Fm) ((pr12 Gm): fmonoidal_lax (pr2 Mon_V) (pr2 Mon_W) _)) (pr1 (underlying_inserter_1cell q)). Proof. use functorlifting_fmonoidal. 3: { use monoidal_nat_trans_to_dialgebra_lifting_strong. + use tpair. * apply (pr12 q). * apply (pr212 q). + apply (pr22 q). } Defined. Lemma is_mon_nat_trans_underlying_inserter_1cell_pr1 (q : inserter_cone Fm Gm) : is_mon_nat_trans (comp_fmonoidal (fmonoidal_underlying_inserter_1cell q) (dialgebra_monoidal_pr1 (pr2 Fm) (pr12 Gm))) (pr12 (inserter_cone_pr1 q)) (pr1 (inserter_1cell_pr1 (underlying_inserter_1cell q))). Proof. split. - intros x y. cbn. unfold projection_preserves_tensordata, fmonoidal_preservestensordata. rewrite id_left. rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, tensor_id_id. } apply pathsinv0, id_left. - red. cbn. unfold projection_preserves_unit, fmonoidal_preservesunit. rewrite id_left. apply id_right. Qed. Definition monbicat_inserter_ump_1_inv_2cell (q : inserter_cone Fm Gm) : invertible_2cell ((_,, fmonoidal_underlying_inserter_1cell q : monbicat ⟦q, monbicat_inserter_cone⟧) · inserter_cone_pr1 monbicat_inserter_cone) (inserter_cone_pr1 q). Proof. use tpair. - exists (pr112 (underlying_inserter_1cell q)). apply (is_mon_nat_trans_underlying_inserter_1cell_pr1 q). - use tpair. + use tpair. * exact (pr12 (inserter_1cell_pr1 (underlying_inserter_1cell q))). * apply is_mon_nat_trans_pointwise_inverse. apply (is_mon_nat_trans_underlying_inserter_1cell_pr1 q). + abstract (split ; use equality_2cells_monbicat ; intro ; apply id_left). Defined. Definition monbicat_inserter_ump_1 : has_inserter_ump_1 monbicat_inserter_cone. Proof. intro q. use make_inserter_1cell. - exists (underlying_inserter_1cell q). exact (fmonoidal_underlying_inserter_1cell q). - exact (monbicat_inserter_ump_1_inv_2cell q). - abstract ( use equality_2cells_monbicat ; intro ; cbn ; rewrite id_right, id_left ; etrans ; [ apply maponpaths ; apply functor_id | rewrite id_right] ; refine (! id_left _ @ _) ; apply maponpaths_2, pathsinv0, functor_id). Defined. Section UMP2Prep. Context {Mon_U : monbicat} {Hm H'm : monbicat ⟦Mon_U, monbicat_inserter_cone⟧} (α : prebicat_cells monbicat (Hm · inserter_cone_pr1 monbicat_inserter_cone) (H'm · inserter_cone_pr1 monbicat_inserter_cone)) (Hyp : vcomp2 (vcomp2 (vcomp2 (rassociator Hm (inserter_cone_pr1 monbicat_inserter_cone) Fm) (lwhisker Hm (inserter_cone_cell monbicat_inserter_cone))) (lassociator Hm (inserter_cone_pr1 monbicat_inserter_cone) Gm)) (rwhisker Gm α) = vcomp2 (vcomp2 (vcomp2 (rwhisker Fm α) (rassociator H'm (inserter_cone_pr1 monbicat_inserter_cone) Fm)) (lwhisker H'm (inserter_cone_cell monbicat_inserter_cone))) (lassociator H'm (inserter_cone_pr1 monbicat_inserter_cone) Gm)). Local Definition underlying_inserter_ump_2 : ∑ ζ : prebicat_cells bicat_of_cats (pr1 Hm) (pr1 H'm), rwhisker (inserter_cone_pr1 (dialgebra_inserter_cone (pr1 Fm) (pr1 Gm))) ζ = pr1 α := dialgebra_inserter_ump_2 (pr1 Fm) (pr1 Gm) (pr1 Mon_U) (pr1 Hm) (pr1 H'm) (pr1 α) (maponpaths pr1 Hyp). Local Definition underlying_inserter_ump_cell : prebicat_cells bicat_of_cats (pr1 Hm) (pr1 H'm) := pr1 underlying_inserter_ump_2. Local Lemma is_mon_nat_trans_underlying_inserter_ump_cell : is_mon_nat_trans (pr2 Hm : fmonoidal (pr2 Mon_U) _ _) (pr2 H'm : fmonoidal (pr2 Mon_U) _ _) underlying_inserter_ump_cell. Proof. split. - intros x y. use total2_paths_f; [cbn | apply (pr1 Mon_W)]. assert (aux := pr12 α x y). cbn in aux. unfold projection_preserves_tensordata in aux. do 2 rewrite id_left in aux. exact aux. - use total2_paths_f; [cbn | apply (pr1 Mon_W)]. assert (aux := pr22 α). red in aux; cbn in aux. unfold projection_preserves_unit in aux. do 2 rewrite id_left in aux. exact aux. Qed. End UMP2Prep. Definition monbicat_inserter_ump_2 : has_inserter_ump_2 monbicat_inserter_cone. Proof. intros Mon_U Hm H'm α Hyp. exists (underlying_inserter_ump_cell α Hyp,, is_mon_nat_trans_underlying_inserter_ump_cell α Hyp). abstract (use equality_2cells_monbicat ; intro ; apply idpath). Defined. Definition monbicat_inserter_ump_eq : has_inserter_ump_eq monbicat_inserter_cone. Proof. intros Mon_U Hm H'm α Hyp ϕ1 ϕ2 eqϕ1 eqϕ2. use total2_paths_f; [cbn | apply isaprop_is_mon_nat_trans]. use (dialgebra_inserter_ump_eq (pr1 Fm) (pr1 Gm) (pr1 Mon_U) (pr1 Hm) (pr1 H'm) (pr1 α) (maponpaths pr1 Hyp)). - exact (maponpaths pr1 eqϕ1). - exact (maponpaths pr1 eqϕ2). Qed. End FixTwoMonoidalFunctors. Definition has_inserters_monbicat : has_inserters monbicat. Proof. intros Mon_V Mon_W Fm Gm. cbn in Fm, Gm. exists (dialgebra (pr1 Fm) (pr1 Gm) ,, dialgebra_monoidal (pr2 Fm) (pr2 Gm)). simple refine (_ ,, _ ,, _). - cbn. exists (dialgebra_pr1 (pr1 Fm) (pr1 Gm)). apply dialgebra_monoidal_pr1. - cbn. exists (dialgebra_nat_trans (pr1 Fm) (pr1 Gm)). apply dialgebra_nat_trans_is_mon_nat_trans. - simple refine (_ ,, _ ,, _). + exact (monbicat_inserter_ump_1 Fm Gm). + exact (monbicat_inserter_ump_2 Fm Gm). + exact (monbicat_inserter_ump_eq Fm Gm). Defined. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/MonoidalFromBicategory.v000066400000000000000000000102541451125700300276140ustar00rootroot00000000000000(** *** Going into the opposite direction of [UniMath.Bicategories.Core.Examples.BicategoryFromMonoidal] *) (** We fix a bicategory and an object of it and construct the monoidal category of endomorphisms. Written by Ralph Matthes in 2019. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Local Open Scope cat. Section Monoidal_Cat_From_Bicat. Local Open Scope bicategory_scope. Import Bicat.Notations. Context {C : bicat}. Context (c0: ob C). Definition precategory_data_from_bicat_and_ob: precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact (C⟦c0,c0⟧). + apply prebicat_cells. - intro c; apply id2. - intros a b c; apply vcomp2. Defined. Lemma is_precategory_data_from_prebicat_and_ob: is_precategory precategory_data_from_bicat_and_ob. Proof. use make_is_precategory. - intros a b f; apply id2_left. - intros a b f; apply id2_right. - intros a b c d f g h; apply vassocr. - intros a b c d f g h; apply pathsinv0; apply vassocr. Qed. Definition precategory_from_bicat_and_ob: precategory := _,, is_precategory_data_from_prebicat_and_ob. Lemma has_homsets_precategory_from_bicat_and_ob: has_homsets precategory_from_bicat_and_ob. Proof. red. intros. apply (cellset_property(C:=C)). Qed. Definition category_from_bicat_and_ob: category := precategory_from_bicat_and_ob ,, has_homsets_precategory_from_bicat_and_ob. Local Notation EndC := category_from_bicat_and_ob. Definition tensor_from_bicat_and_ob: category_from_bicat_and_ob ⊠ category_from_bicat_and_ob ⟶ category_from_bicat_and_ob. Proof. use make_functor. - use make_functor_data. + intro ab. exact (pr1 ab · pr2 ab). + intros ab1 ab2 f. exact (hcomp (pr1 f) (pr2 f)). - abstract ( split; [ intro c; apply hcomp_identity | intros a b c f g; apply hcomp_vcomp ] ). Defined. Local Notation tensor := tensor_from_bicat_and_ob. Local Definition build_left_unitor: left_unitor tensor (id c0). Proof. use make_nat_z_iso. + use make_nat_trans. * intro c. apply lunitor. * abstract ( intros a b f; apply lunitor_natural ). + intro c; apply is_z_iso_lunitor. Defined. Local Definition build_right_unitor: right_unitor tensor (id c0). Proof. use make_nat_z_iso. + use make_nat_trans. * intro c. apply runitor. * abstract ( intros a b f; apply runitor_natural ). + intro c; apply is_z_iso_runitor. Defined. Definition nat_trans_associator: assoc_left tensor ⟹ assoc_right tensor. Proof. (* very slow with library elements: set (aux := rassociator_transf(C := C) c0 c0 c0 c0). set (aux' := pre_whisker (precategory_binproduct_unassoc _ _ _) aux). use make_nat_trans. - intro c. exact (pr1 aux' c). - apply (pr2 aux'). *) (* still very slow with new additions to library: set (aux := rassociator_transf'(C := C) c0 c0 c0 c0). use make_nat_trans. - intro c. exact (pr1 aux c). - abstract ( apply (pr2 aux) ). *) (* now def. by Anders Mörtberg: *) exists rassociator_fun'. abstract (intros f g x; apply hcomp_rassoc). Defined. Local Definition build_associator: associator tensor. Proof. use make_nat_z_iso. - exact nat_trans_associator. - intro c; apply is_z_iso_rassociator. Defined. Definition monoidal_cat_from_bicat_and_ob: monoidal_cat. Proof. use (make_monoidal_cat category_from_bicat_and_ob tensor_from_bicat_and_ob (id c0) build_left_unitor build_right_unitor build_associator). - abstract ( intros a b; apply pathsinv0; apply unit_triangle ). - abstract ( intros a b c d; apply pathsinv0; apply associativity_pentagon ). Defined. End Monoidal_Cat_From_Bicat. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/PointedFunctorsMonoidal.v000066400000000000000000000227261451125700300300350ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2021 *) (** ********************************************************** Contents : - build monoidal category for the pointed endofunctors ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsMonoidal. Local Open Scope cat. Section PointedFunctors_as_monoidal_category. Context (C : category). Local Notation "'Ptd'" := (category_Ptd C). Definition tensor_pointedfunctor_data: functor_data (Ptd ⊠ Ptd) Ptd. Proof. use make_functor_data. - intros PF1PF2. exact (ptd_compose C (pr1 PF1PF2) (pr2 PF1PF2)). - intros PF1PF2 PF1PF2' α1α2. induction α1α2 as [α1 α2]. induction PF1PF2 as [PF1 PF2]. induction PF1PF2' as [PF1' PF2']. cbn in α1, α2 |- *. set (α1' := pr1 α1). set (α2' := pr1 α2). exists (# (functorial_composition _ _ _) (α1',,α2': [C, C] ⊠ [C, C]⟦(pr1 PF1,,pr1 PF2),(pr1 PF1',,pr1 PF2')⟧)). abstract ( intro c; assert (α1commutes := ptd_mor_commutes _ α1); assert (α2commutes := ptd_mor_commutes _ α2); cbn; etrans; [ apply maponpaths; apply nat_trans_ax | rewrite <- α1commutes; repeat rewrite <- assoc; apply maponpaths; rewrite assoc; unfold α2'; etrans; [apply cancel_postcomposition; apply α2commutes | etrans; [assert (η2'nat := nat_trans_ax (pr2 PF2')); apply pathsinv0, η2'nat | apply idpath]]] ). Defined. Definition tensor_pointedfunctor_is_functor: is_functor tensor_pointedfunctor_data. Proof. split. - intro PF1PF2. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply eq_ptd_mor. unfold tensor_pointedfunctor_data. simpl. unfold post_whisker_in_funcat, pre_whisker_in_funcat. rewrite pre_whisker_identity. rewrite post_whisker_identity. apply nat_trans_eq; [apply homset_property | intro c]. cbn. apply id_right. - intros PF1PF2 PF1'PF2' PF1''PF2'' α1α2 α1'α2'. apply eq_ptd_mor. unfold tensor_pointedfunctor_data. simpl. unfold post_whisker_in_funcat, pre_whisker_in_funcat. rewrite (post_whisker_composition _ _ _). rewrite (pre_whisker_composition _ _ _). cbn. apply nat_trans_eq; [apply homset_property | intro c]. cbn. repeat rewrite <- assoc. apply maponpaths. do 2 rewrite assoc. apply cancel_postcomposition. apply nat_trans_ax. Qed. Definition tensor_pointedfunctors: category_Ptd C ⊠ category_Ptd C ⟶ category_Ptd C. Proof. use make_functor. - exact tensor_pointedfunctor_data. - exact tensor_pointedfunctor_is_functor. Defined. (** a preparation for the lemma afterwards *) Lemma ptd_mor_z_iso_from_underlying_mor {F G : Ptd} (α : ptd_mor C F G): is_nat_z_iso (pr1 α) -> is_z_isomorphism(C:=Ptd) α. Proof. intro Hyp. use tpair. - use tpair. apply nat_z_iso_to_trans_inv. + exact (pr1 α ,, Hyp). + abstract (cbn; red; intro c; cbn; apply pathsinv0; apply (z_iso_inv_on_left _ _ _ _ (make_z_iso _ _ (Hyp c))); cbn; apply pathsinv0; apply ptd_mor_commutes). - abstract (red; split; apply eq_ptd_mor; apply (nat_trans_eq (homset_property C)); intro c; cbn ; [ apply (z_iso_inv_after_z_iso (make_z_iso _ _ (Hyp c))) | apply (z_iso_after_z_iso_inv (make_z_iso _ _ (Hyp c))) ]). Defined. Definition left_unitor_of_pointedfunctors: left_unitor tensor_pointedfunctors (id_Ptd C). Proof. use make_nat_z_iso. + use make_nat_trans. * intro PF. exists (λ_functors (pr1 PF)). abstract ( intro c; cbn; rewrite id_right; apply id_left ). * abstract ( intros PF PF' α; apply eq_ptd_mor; apply (nat_trans_eq (homset_property C)); intro c; cbn; rewrite id_left; rewrite id_right; etrans; [apply cancel_postcomposition, functor_id | apply id_left] ). + intro PF. cbn. apply ptd_mor_z_iso_from_underlying_mor. intro c. cbn. apply identity_is_z_iso. Defined. Definition right_unitor_of_pointedfunctors: right_unitor tensor_pointedfunctors (id_Ptd C). Proof. use make_nat_z_iso. + use make_nat_trans. * intro PF. exists (ρ_functors (pr1 PF)). abstract ( intro c; cbn; rewrite id_right; apply id_right ). * abstract ( intros PF PF' α; apply eq_ptd_mor; apply (nat_trans_eq (homset_property C)); intro c; cbn; rewrite id_left; rewrite id_right; apply id_right ). + intro PF. cbn. apply ptd_mor_z_iso_from_underlying_mor. intro c. cbn. apply identity_is_z_iso. Defined. Definition associator_of_pointedfunctors : associator tensor_pointedfunctors. Proof. use make_nat_z_iso. + use make_nat_trans. * intro PFtriple. induction PFtriple as [[PF1 PF2] PF3]. exists (α_functors (pr1 PF1) (pr1 PF2) (pr1 PF3)). abstract ( intro c; cbn; rewrite id_right; apply pathsinv0, assoc ). * abstract ( intros PFtriple PFtriple' αtriple; apply eq_ptd_mor; apply (nat_trans_eq (homset_property C)); intro c; cbn; rewrite id_right; rewrite id_left; rewrite assoc; apply cancel_postcomposition; apply functor_comp ). + intro PFtriple. cbn. apply ptd_mor_z_iso_from_underlying_mor. intro c. cbn. apply identity_is_z_iso. Defined. Lemma triangle_eq_of_pointedfunctors : triangle_eq tensor_pointedfunctors (id_Ptd C) left_unitor_of_pointedfunctors right_unitor_of_pointedfunctors associator_of_pointedfunctors. Proof. intros PF1 PF2. apply eq_ptd_mor. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (nat_trans_eq (homset_property C)). intro c. cbn. do 2 rewrite id_right. apply pathsinv0, id_left. Qed. Lemma pentagon_eq_of_pointedfunctors : pentagon_eq tensor_pointedfunctors associator_of_pointedfunctors. Proof. intros PF1 PF2 PF3 PF4. apply eq_ptd_mor. apply nat_trans_eq_alt. intro c. cbn. do 3 rewrite functor_id. do 5 rewrite id_right. apply pathsinv0, functor_id. Qed. Definition monoidal_cat_of_pointedfunctors : monoidal_cat. Proof. use make_monoidal_cat. - exact Ptd. - apply tensor_pointedfunctors. - apply id_Ptd. - exact left_unitor_of_pointedfunctors. - exact right_unitor_of_pointedfunctors. - exact associator_of_pointedfunctors. - exact triangle_eq_of_pointedfunctors. - exact pentagon_eq_of_pointedfunctors. Defined. Definition forgetful_functor_from_ptd_as_strong_monoidal_functor : strong_monoidal_functor monoidal_cat_of_pointedfunctors (monoidal_cat_of_endofunctors C). Proof. use tpair. - apply (make_lax_monoidal_functor monoidal_cat_of_pointedfunctors (monoidal_cat_of_endofunctors C) (functor_ptd_forget C) (nat_trans_id _) (nat_trans_id _)). + abstract ( intros PF1 PF2 PF3; apply nat_trans_eq_alt; intro c; cbn; do 2 rewrite functor_id; repeat rewrite id_right; apply functor_id ). + abstract ( intro PF; split; apply nat_trans_eq_alt; intro c; cbn; do 3 rewrite id_right; [ apply pathsinv0, functor_id | apply idpath ] ). - split; [ apply (nat_trafo_z_iso_if_pointwise_z_iso C); apply is_nat_z_iso_nat_trans_id | apply (is_nat_z_iso_nat_trans_id ((functor_composite (PrecategoryBinProduct.pair_functor (functor_ptd_forget C) (functor_ptd_forget C)) (functorial_composition _ _ _))))]. Defined. End PointedFunctors_as_monoidal_category. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/PointedFunctorsWhiskeredMonoidal.v000066400000000000000000000123271451125700300316770ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2022 *) (** ********************************************************** Contents : - build monoidal category in whiskered form for the pointed endofunctors through a displayed monoidal category ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require UniMath.CategoryTheory.PointedFunctors. Require UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal. Require Import UniMath.CategoryTheory.coslicecat. Import MonoidalNotations. Local Open Scope cat. Section A. Context (C : category). (* Definition pointedfunctors_disp_cat : disp_cat (cat_of_endofunctors C). Proof. use disp_struct. - intro F. exact (functor_identity C ⟹ pr1 F). - intros F G ptF ptG α. exact (∏ c : C, ptF c · pr1 α c = ptG c). - intros F G ptF ptG α. apply impred; intro c. apply C. - intros F ptF c. apply id_right. - abstract (intros F G H α β; cbn; intros ptF ptG ptH Hα Hβ c; rewrite assoc, Hα, Hβ; apply idpath ). Defined. Definition pointedfunctors_cat : category := total_category pointedfunctors_disp_cat. (** compare this with [UniMath.CategoryTheory.PointedFunctors.category_Ptd] *) Definition pointedfunctors_disp_tensor_data : disp_bifunctor_data (monoidal_of_endofunctors C) pointedfunctors_disp_cat pointedfunctors_disp_cat pointedfunctors_disp_cat. Proof. use tpair. - intros F G ptF ptG. exact (# (post_comp_functor (functor_identity C)) ptF · # (pre_comp_functor F) ptG). (** compare this with [UniMath.CategoryTheory.PointedFunctorsComposition.ptd_compose] *) - split. + intros F G1 G2 β ptF ptG1 ptG2 Hβ. cbn. intro c. rewrite <- Hβ. apply assoc'. + intros F1 F2 G α ptF1 ptF2 ptG Hα. cbn. intro c. rewrite <- Hα. do 2 rewrite <- assoc. apply maponpaths. etrans. { apply pathsinv0, (nat_trans_ax ptG). } apply idpath. Defined. Lemma pointedfunctors_disp_tensor_laws : is_disp_bifunctor pointedfunctors_disp_tensor_data. Proof. repeat split; red; intros; apply funextsec; intro; apply C. Qed. Definition pointedfunctors_disp_tensor : disp_tensor pointedfunctors_disp_cat (monoidal_of_endofunctors C) := pointedfunctors_disp_tensor_data ,, pointedfunctors_disp_tensor_laws. Definition pointedfunctors_disp_unit : pointedfunctors_disp_cat I_{ monoidal_of_endofunctors C} := nat_trans_id (functor_identity C). Definition pointedfunctors_disp_moncat_data : disp_monoidal_data pointedfunctors_disp_cat (monoidal_of_endofunctors C). Proof. exists pointedfunctors_disp_tensor. exists pointedfunctors_disp_unit. repeat split. - intros F ptF c. cbn. rewrite id_left; apply id_right. - intros F ptF c. cbn. rewrite id_left; apply id_right. - intros F ptF c. cbn. rewrite id_right; apply id_right. (* no goal left for inverse of right unitor *) - intros F G H ptF ptG ptH c. cbn. rewrite id_right. apply assoc'. - intros F G H ptF ptG ptH c. cbn. rewrite id_right. apply assoc. Defined. Lemma pointedfunctors_disp_moncat_laws : disp_monoidal_laws pointedfunctors_disp_moncat_data. Proof. repeat split; try red; try (intros; apply funextsec; intro; apply C). Qed. Definition pointedfunctors_disp_moncat : disp_monoidal pointedfunctors_disp_cat (monoidal_of_endofunctors C) := pointedfunctors_disp_moncat_data ,, pointedfunctors_disp_moncat_laws. Definition pointedfunctors_moncat : monoidal pointedfunctors_cat := total_monoidal pointedfunctors_disp_moncat. *) Definition pointedfunctors_disp_cat : disp_cat (cat_of_endofunctors C) := coslice_cat_disp (cat_of_endofunctors C) I_{monoidal_of_endofunctors C}. Definition pointedfunctors_cat : category := total_category pointedfunctors_disp_cat. Definition pointedfunctors_disp_moncat : disp_monoidal pointedfunctors_disp_cat (monoidal_of_endofunctors C) := monoidal_pointed_objects_disp (monoidal_of_endofunctors C). Definition pointedfunctors_moncat : monoidal pointedfunctors_cat := total_monoidal pointedfunctors_disp_moncat. End A. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/000077500000000000000000000000001451125700300262175ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/AssociatorUnitorsLayer.v000066400000000000000000000401331451125700300330770ustar00rootroot00000000000000(* The second displayed layer we lay over the bicategory of univalent categories has the purppose of adding the unitors and the associator. In this file we construct the displayed bicategory which adds all the data of the unitors and the associator. For example: The total category corresponding to the displayed layer of the associator is the univalent bicategory defined as followed: - The objects are categories (already equipped with a tensor and unit) together with the data (and naturality) of the associator. - The morphisms express a preservation condition of the associator. - The 2-cells are trivial. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.UnitLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorUnitLayer. Local Open Scope cat. Local Open Scope mor_disp_scope. Section LeftUnitorLayer. Definition disp_lu_disp_ob_mor : disp_cat_ob_mor tu_cat. Proof. use tpair. - exact (λ C, lunitor (tu C)). - exact (λ C D luC luD F, preserves_lunitor (ftu F) luC luD). Defined. Definition disp_lu_disp_id_comp : disp_cat_id_comp tu_cat disp_lu_disp_ob_mor. Proof. use tpair. - intros C lu. apply id_preserves_lunitor. - intros C D E F G luC luD luE pluF pluG x. apply (comp_preserves_lunitor pluF pluG). Defined. Definition disp_lu_disp_cat_data : disp_cat_data tu_cat := (disp_lu_disp_ob_mor,, disp_lu_disp_id_comp). Definition bidisp_lu_disp_bicat : disp_bicat tu_cat := disp_cell_unit_bicat disp_lu_disp_cat_data. Lemma bidisp_lu_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_lu_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intro ; intros. apply isaprop_preserves_lunitor. Qed. Lemma isaset_lunitor (C : tu_cat) : isaset (lunitor (pr2 C)). Proof. apply isaset_total2. { apply impred_isaset ; intro. apply homset_property. } intro. repeat (apply impred_isaset ; intro). apply isasetaprop. apply homset_property. Qed. Lemma isaprop_lunitor_nat (C : tu_cat) (lu : lunitor (pr2 C)) : isaprop (lunitor_nat (pr1 lu)). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Lemma bidisp_lu_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_lu_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_0. - apply bidisp_tensorunit_is_univalent_2. - intro ; intros. apply isaprop_preserves_lunitor. - intro ; apply isaset_lunitor. - intros C lu1 lu2 plu. use total2_paths_f. + apply funextsec ; intro. refine (_ @ (pr1 plu x)). refine (! id_left _ @ _). apply cancel_postcomposition. refine (_ @ ! id_right _). apply (! tensor_id _ _ _). + apply isaprop_lunitor_nat. Qed. Lemma bidisp_lu_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_lu_disp_bicat. Proof. apply make_disp_univalent_2. - apply bidisp_lu_disp_prebicat_is_globally_univalent. - apply bidisp_lu_disp_prebicat_is_locally_univalent. Defined. End LeftUnitorLayer. Section RightUnitorLayer. Definition disp_ru_disp_ob_mor : disp_cat_ob_mor tu_cat. Proof. use tpair. - exact (λ C, runitor (tu C)). - exact (λ C D ruC ruD F, preserves_runitor (ftu F) ruC ruD). Defined. Definition disp_ru_disp_id_comp : disp_cat_id_comp tu_cat disp_ru_disp_ob_mor. Proof. use tpair. - intros C ru. apply id_preserves_runitor. - intros C D E F G ruC ruD ruE pruF pruG x. apply (comp_preserves_runitor pruF pruG). Defined. Definition disp_ru_disp_cat_data : disp_cat_data tu_cat := (disp_ru_disp_ob_mor,, disp_ru_disp_id_comp). Definition bidisp_ru_disp_bicat : disp_bicat tu_cat := disp_cell_unit_bicat disp_ru_disp_cat_data. Lemma bidisp_ru_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_ru_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intro ; intros. apply isaprop_preserves_runitor. Qed. Lemma isaset_runitor (C : tu_cat) : isaset (runitor (pr2 C)). Proof. apply isaset_total2. { apply impred_isaset ; intro. apply homset_property. } intro. repeat (apply impred_isaset ; intro). apply isasetaprop. apply homset_property. Qed. Lemma isaprop_runitor_nat {C : tu_cat} (ru : runitor (pr2 C)) : isaprop (runitor_nat (pr1 ru)). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Lemma bidisp_ru_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_ru_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_0. - apply bidisp_tensorunit_is_univalent_2. - intro ; intros. apply isaprop_preserves_runitor. - intro ; apply isaset_runitor. - intros C ru1 ru2 pru. use total2_paths_f. + apply funextsec ; intro. refine (_ @ (pr1 pru x)). refine (! id_left _ @ _). apply cancel_postcomposition. refine (_ @ ! id_right _). apply (! tensor_id _ _ _). + apply isaprop_runitor_nat. Qed. Lemma bidisp_ru_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_ru_disp_bicat. Proof. apply make_disp_univalent_2. - apply bidisp_ru_disp_prebicat_is_globally_univalent. - apply bidisp_ru_disp_prebicat_is_locally_univalent. Defined. End RightUnitorLayer. Section UnitorsLayer. Definition bidisp_unitors_disp_bicat : disp_bicat tu_cat := disp_dirprod_bicat bidisp_lu_disp_bicat bidisp_ru_disp_bicat. End UnitorsLayer. Section AssociatorLayer. Definition disp_ass_disp_ob_mor : disp_cat_ob_mor tu_cat. Proof. use tpair. - exact (λ C, associator (tu C)). - exact (λ C D αC αD F, preserves_associator (ftu F) αC αD). Defined. Definition disp_ass_disp_id_comp : disp_cat_id_comp tu_cat disp_ass_disp_ob_mor. Proof. use tpair. - intros C α. apply id_preserves_associator. - intros C D E F G aC aD aE paF paG x y z. apply (comp_preserves_associator paF paG). Qed. Definition disp_ass_disp_cat_data : disp_cat_data tu_cat := (disp_ass_disp_ob_mor,, disp_ass_disp_id_comp). Definition bidisp_ass_disp_bicat : disp_bicat tu_cat := disp_cell_unit_bicat disp_ass_disp_cat_data. Lemma bidisp_ass_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_ass_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intro ; intros. apply isaprop_preserves_associator. Qed. Lemma isaset_associator (C : tu_cat) : isaset (associator (pr2 C)). Proof. apply isaset_total2. { do 3 (apply impred_isaset ; intro). apply homset_property. } intro. repeat (apply impred_isaset ; intro). apply isasetaprop. apply homset_property. Qed. Lemma isaprop_associator_nat (C : tu_cat) (ass : associator (pr2 C)) : isaprop (associator_nat (pr1 ass)). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Lemma bidisp_ass_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_ass_disp_bicat. Proof. apply disp_cell_unit_bicat_univalent_2_0. - apply bidisp_tensorunit_is_univalent_2. - intro ; intros. apply isaprop_preserves_associator. - intro ; apply isaset_associator. - intros C a1 a2 pa. use total2_paths_f. + apply funextsec ; intro x1 ; apply funextsec ; intro x2 ; apply funextsec ; intro x3. set (p := pr1 pa x1 x2 x3). cbn in p. unfold identityfunctor_preserves_tensor_data in p. rewrite id_right in p. rewrite id_right in p. rewrite tensor_id in p. rewrite id_left in p. rewrite tensor_id in p. rewrite id_right in p. exact p. + apply isaprop_associator_nat. Qed. Lemma bidisp_ass_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_ass_disp_bicat. Proof. apply make_disp_univalent_2. - apply bidisp_ass_disp_prebicat_is_globally_univalent. - apply bidisp_ass_disp_prebicat_is_locally_univalent. Defined. End AssociatorLayer. Section AssociatorUnitorsLayer. Definition bidisp_assunitors_disp_bicat : disp_bicat tu_cat := disp_dirprod_bicat bidisp_unitors_disp_bicat bidisp_ass_disp_bicat. Definition bidisp_assunitors_disp_2cells_isaprop : disp_2cells_isaprop bidisp_assunitors_disp_bicat. Proof. repeat (apply disp_2cells_isaprop_prod) ; apply disp_2cells_isaprop_cell_unit_bicat. Qed. Definition bidisp_assunitors_disp_locally_groupoid : disp_locally_groupoid bidisp_assunitors_disp_bicat. Proof. repeat (apply disp_locally_groupoid_prod) ; apply disp_locally_groupoid_cell_unit_bicat. Qed. Definition bidisp_unitors_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_unitors_disp_bicat. Proof. apply is_univalent_2_dirprod_bicat. - apply bidisp_tensorunit_is_univalent_2. - apply bidisp_lu_disp_prebicat_is_univalent_2. - apply bidisp_ru_disp_prebicat_is_univalent_2. Qed. Definition bidisp_assunitors_is_disp_univalent_2 : disp_univalent_2 bidisp_assunitors_disp_bicat. Proof. apply is_univalent_2_dirprod_bicat. - apply bidisp_tensorunit_is_univalent_2. - apply bidisp_unitors_disp_prebicat_is_univalent_2. - apply bidisp_ass_disp_prebicat_is_univalent_2. Qed. Definition disp_tensor_unit_unitors_associator : disp_bicat bicat_of_univ_cats := sigma_bicat _ _ bidisp_assunitors_disp_bicat. Definition disp_tensor_unit_unitors_associator_is_disp_univalent_2 : disp_univalent_2 disp_tensor_unit_unitors_associator. Proof. apply sigma_disp_univalent_2_with_props. - apply univalent_cat_is_univalent_2. - apply bidisp_tensorunit_disp_2cells_isaprop. - apply bidisp_assunitors_disp_2cells_isaprop. - apply bidisp_tensorunit_is_disp_univalent_2 . - apply bidisp_assunitors_is_disp_univalent_2. - apply bidisp_tensorunit_disp_locally_groupoid. - apply bidisp_assunitors_disp_locally_groupoid. - apply bidisp_tensorunit_is_disp_univalent_2. - apply bidisp_assunitors_is_disp_univalent_2. Qed. Lemma disp_tensor_unit_unitors_associator_disp_2cells_isaprop : disp_2cells_isaprop disp_tensor_unit_unitors_associator. Proof. apply disp_2cells_isaprop_sigma. - apply bidisp_tensorunit_disp_2cells_isaprop. - apply bidisp_assunitors_disp_2cells_isaprop. Qed. Lemma disp_tensor_unit_unitors_associator_disp_locally_groupoid : disp_locally_groupoid disp_tensor_unit_unitors_associator. Proof. intros C D F G α tuuaC tuuaD ptuuaC ptuuaD ptuuac. repeat (use tpair) ; try (exact tt). - apply bidisp_tensor_disp_locally_groupoid. apply ptuuac. - apply bidisp_unit_disp_locally_groupoid. apply ptuuac. - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop. - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop. Qed. Definition bidisp_assunitors_total : bicat := total_bicat disp_tensor_unit_unitors_associator. Definition bidisp_assunitors_is_univalent_2: is_univalent_2 bidisp_assunitors_total. Proof. apply total_is_univalent_2. - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2. - apply univalent_cat_is_univalent_2. Qed. Definition assunitors_tensor (C : bidisp_assunitors_total) : tensor (pr1 C : univalent_category) := pr112 C. Definition assunitors_unit (C : bidisp_assunitors_total) : ob (pr1 C : univalent_category) := pr212 C. Definition assunitors_leftunitor (C : bidisp_assunitors_total) : lunitor_data (pr12 C) := pr11 (pr122 C). Definition assunitors_rightunitor (C : bidisp_assunitors_total) : runitor_data (pr12 C) := pr12 (pr122 C). Definition assunitors_associator (C : bidisp_assunitors_total) : associator_data (pr12 C) := pr1 (pr222 C). (* We now show that the type of displayed objects and 1-cells is as we expect *) Definition assunitors_from_layer (C : bicat_of_univ_cats) : disp_tensor_unit_unitors_associator C -> tensor_unit_unitors_associator (C : univalent_category). Proof. intro tuua. split with (pr1 tuua). repeat split. + apply (pr112 tuua). + apply (pr212 tuua). + apply (pr2 tuua). Defined. Definition assunitors_to_layer (C : bicat_of_univ_cats) : tensor_unit_unitors_associator (C : univalent_category) -> disp_tensor_unit_unitors_associator C. Proof. intro tuua. split with (pr1 tuua). repeat split. + apply (pr12 tuua). + apply (pr122 tuua). + apply (pr222 tuua). Defined. Definition equality_assunitors_with_layer (C : bicat_of_univ_cats) : disp_tensor_unit_unitors_associator C ≃ tensor_unit_unitors_associator (C : univalent_category). Proof. use weq_iso. - apply assunitors_from_layer. - apply assunitors_to_layer. - intro ; apply idpath. - intro ; apply idpath. Defined. Definition functor_assunitors_from_layer (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_tensor_unit_unitors_associator C) (tuuaD : disp_tensor_unit_unitors_associator D) : tuuaC -->[F] tuuaD -> functor_tensor_unit_unitors_associator F (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD). Proof. intro ptuua. split with (pr1 ptuua). repeat split. - apply (pr112 ptuua). - apply (pr212 ptuua). - apply (pr22 ptuua). Defined. Definition functor_assunitors_to_layer (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_tensor_unit_unitors_associator C) (tuuaD : disp_tensor_unit_unitors_associator D) : functor_tensor_unit_unitors_associator F (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD) -> tuuaC -->[F] tuuaD. Proof. intro ptuua. split with (pr1 ptuua). repeat split. - apply (pr12 ptuua). - apply (pr122 ptuua). - apply (pr222 ptuua). Defined. Definition equality_functor_assunitors_with_layer (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_tensor_unit_unitors_associator C) (tuuaD : disp_tensor_unit_unitors_associator D) : tuuaC -->[F] tuuaD ≃ functor_tensor_unit_unitors_associator F (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD). Proof. use weq_iso. - apply functor_assunitors_from_layer. - apply functor_assunitors_to_layer. - apply idpath. - apply idpath. Defined. End AssociatorUnitorsLayer. Module AssociatorUnitorsNotations. Notation "I_{ C }" := (assunitors_unit C). Notation "T_{ C }" := (assunitors_tensor C). Notation "x ⊗_{ C } y" := (tensor_on_ob T_{C} x y) (at level 31). Notation "f ⊗^{ C } g" := (tensor_on_hom T_{C} _ _ _ _ f g) (at level 31). Notation "lu^{ C }" := (assunitors_leftunitor C). Notation "ru^{ C }" := (assunitors_rightunitor C). Notation "ass^{ C }" := (assunitors_associator C). End AssociatorUnitorsNotations. CurriedMonoidalCategories.v000066400000000000000000001124061451125700300334210ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCatRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Section Tensor. Definition tensor_data (C : category) : UU := ∑ T : C -> C -> C, ∏ (x1 x2 y1 y2 : C), C⟦x1,x2⟧ -> C⟦y1,y2⟧ -> C⟦T x1 y1, T x2 y2⟧. Definition make_tensor_data {C : category} (T : C -> C -> C) (h : ∏ (x1 x2 y1 y2 : C), C⟦x1,x2⟧ -> C⟦y1,y2⟧ -> C⟦T x1 y1, T x2 y2⟧) : tensor_data C := (T,,h). Definition tensor_on_ob {C : category} (T : tensor_data C) : C -> C -> C := pr1 T. Notation "x ⊗_{ T } y" := (tensor_on_ob T x y) (at level 31). Definition tensor_on_hom {C : category} (T : tensor_data C) : ∏ (x1 x2 y1 y2 : C), C⟦x1,x2⟧ -> C⟦y1,y2⟧ -> C⟦x1 ⊗_{T} y1, x2 ⊗_{T} y2⟧ := pr2 T. Notation "f ⊗^{ T } g" := (tensor_on_hom T _ _ _ _ f g) (at level 31). Definition tensor_idax {C : category} (T : tensor_data C) := ∏ (x y : C), (identity x) ⊗^{T} (identity y) = identity (x ⊗_{T} y). Definition tensor_compax {C : category} (T : tensor_data C) := ∏ (x1 x2 x3 y1 y2 y3 : C) (f1 : C⟦x1,x2⟧) (f2 : C⟦x2,x3⟧) (g1 : C⟦y1,y2⟧) (g2 : C⟦y2,y3⟧), (f1 · f2) ⊗^{T} (g1 · g2) = (f1 ⊗^{T} g1) · (f2 ⊗^{T} g2). Definition tensor_ax {C : category} (T : tensor_data C) : UU := tensor_idax T × tensor_compax T. Definition tensor (C : category) : UU := ∑ T : tensor_data C, tensor_ax T. Definition tensor_to_data {C : category} (T : tensor C) : tensor_data C := pr1 T. Coercion tensor_to_data : tensor >-> tensor_data. Definition tensor_to_ax {C : category} (T : tensor C) : tensor_ax T := pr2 T. Definition tensor_id {C : category} (T : tensor C) : tensor_idax T := pr1 (tensor_to_ax T). Definition tensor_comp {C : category} (T : tensor C) : tensor_compax T := pr2 (tensor_to_ax T). Definition preserves_tensor_data {C D : category} (TC : tensor_data C) (TD : tensor_data D) (F : functor C D) : UU := ∏ (x y : C), D ⟦ F x ⊗_{TD} F y, F (x ⊗_{TC} y) ⟧. Definition preserves_tensor_nat {C D : category} {TC : tensor C} {TD : tensor D} {F : functor C D} (ptF : preserves_tensor_data TC TD F) : UU := ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), (ptF x1 y1) · (functor_on_morphisms F (f ⊗^{TC} g)) = ((functor_on_morphisms F f) ⊗^{TD} (functor_on_morphisms F g)) · ptF x2 y2. Definition preserves_tensor {C D : category} (TC : tensor C) (TD : tensor D) (F : functor C D) : UU := ∑ (ptF : preserves_tensor_data TC TD F), preserves_tensor_nat ptF. Definition preservestensor_into_preservestensordata {C D : category} {TC : tensor C} {TD : tensor D} {F : functor C D} (pt : preserves_tensor TC TD F) : preserves_tensor_data TC TD F := pr1 pt. Coercion preservestensor_into_preservestensordata : preserves_tensor >-> preserves_tensor_data. Lemma identityfunctor_preserves_tensor_data {C : category} (T : tensor C) : preserves_tensor_data T T (functor_identity C). Proof. intros x y. apply identity. Defined. Lemma identityfunctor_preserves_tensor_nat {C : category} (T : tensor C) : preserves_tensor_nat (identityfunctor_preserves_tensor_data T). Proof. intros x1 x2 y1 y2 f g. rewrite id_left. rewrite id_right. apply idpath. Qed. Definition identityfunctor_preserves_tensor {C : category} (T : tensor C) : preserves_tensor T T (functor_identity C) := (identityfunctor_preserves_tensor_data T,, identityfunctor_preserves_tensor_nat T). Lemma compositions_preserves_tensor_data {C D E : category} {TC : tensor C} {TD : tensor D} {TE : tensor E} {F : functor C D} {G : functor D E} (ptF : preserves_tensor_data TC TD F) (ptG : preserves_tensor_data TD TE G) : preserves_tensor_data TC TE (functor_composite F G). Proof. intros x y. exact ((ptG (F x) (F y)) · (functor_on_morphisms G) (ptF x y)). Defined. Lemma compositions_preserves_tensor_nat {C D E : category} {TC : tensor C} {TD : tensor D} {TE : tensor E} {F : functor C D} {G : functor D E} (ptF : preserves_tensor TC TD F) (ptG : preserves_tensor TD TE G) : preserves_tensor_nat (compositions_preserves_tensor_data ptF ptG). Proof. intros x1 x2 y1 y2 f g. unfold compositions_preserves_tensor_data. simpl. rewrite assoc'. etrans. { apply cancel_precomposition. apply (pathsinv0 (functor_comp G _ _)). } rewrite (pr2 ptF). rewrite assoc. rewrite functor_comp. rewrite assoc. rewrite (pr2 ptG). apply idpath. Qed. Definition compositions_preserves_tensor {C D E : category} {TC : tensor C} {TD : tensor D} {TE : tensor E} {F : functor C D} {G : functor D E} (ptF : preserves_tensor TC TD F) (ptG : preserves_tensor TD TE G) : preserves_tensor TC TE (functor_composite F G) := (compositions_preserves_tensor_data ptF ptG,, compositions_preserves_tensor_nat ptF ptG). Definition preservestensor_commutes {C D : category} {TC : tensor C} {TD : tensor D} {F G : functor C D} (ptF : preserves_tensor_data TC TD F) (ptG : preserves_tensor_data TC TD G) (α : nat_trans F G) : UU := ∏ (x y : C), (ptF x y) · α (x ⊗_{TC} y) = (α x) ⊗^{TD} (α y) · (ptG x y). Definition identitynattrans_preservestensor_commutes {C D : category} {TC : tensor C} {TD : tensor D} {F : functor C D} (ptF : preserves_tensor_data TC TD F) : preservestensor_commutes ptF ptF (nat_trans_id F). Proof. intros x y. simpl. rewrite id_right. rewrite tensor_id. rewrite id_left. apply idpath. Qed. Definition isaprop_preservestensor_commutes {C D : category} {TC : tensor C} {TD : tensor D} {F G : functor C D} (ptF : preserves_tensor_data TC TD F) (ptG : preserves_tensor_data TC TD G) (α : nat_trans F G) : isaprop (preservestensor_commutes ptF ptG α). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. End Tensor. Module TensorNotation. Notation "x ⊗_{ T } y" := (tensor_on_ob T x y) (at level 31). Notation "f ⊗^{ T } g" := (tensor_on_hom T _ _ _ _ f g) (at level 31). End TensorNotation. Section Unit. Definition preserves_unit {C D : category} (IC : C) (ID : D) (F : functor C D) : UU := D⟦ID, (pr1 F) IC⟧. Definition identityfunctor_preserves_unit {C : category} (IC : C) : preserves_unit IC IC (functor_identity C) := identity IC. Definition composition_preserves_unit {C D E : category} {IC : C} {ID : D} {IE : E} {F : functor C D} {G : functor D E} (puF : preserves_unit IC ID F) (puG : preserves_unit ID IE G) : preserves_unit IC IE (functor_composite F G) := puG · (functor_on_morphisms (pr1 G) puF). Definition preservesunit_commutes {C D : category} {IC : C} {ID : D} {F G : functor C D} (puF : preserves_unit IC ID F) (puG : preserves_unit IC ID G) (α : nat_trans F G) : UU := puF · (α IC) = puG. Definition identitynattrans_preservesunit_commutes {C D : category} {IC : C} {ID : D} {F : functor C D} (puF : preserves_unit IC ID F) : preservesunit_commutes puF puF (nat_trans_id F). Proof. apply id_right. Qed. Lemma isaprop_preservesunit_commutes {C D : category} {IC : C} {ID : D} {F G : functor C D} (puF : preserves_unit IC ID F) (puG : preserves_unit IC ID G) (α : nat_trans F G) : isaprop (preservesunit_commutes puF puG α). Proof. apply homset_property. Qed. End Unit. Section TensorUnit. Definition tensor_unit (C : category) : UU := tensor C × C. Definition tensor_unit_to_tensor {C : category} (tu : tensor_unit C) : tensor C := pr1 tu. Coercion tensor_unit_to_tensor : tensor_unit >-> tensor. Definition tensor_unit_to_unit {C : category} (tu : tensor_unit C) : ob C := pr2 tu. Coercion tensor_unit_to_unit : tensor_unit >-> ob. Definition functor_tensor_unit {C D : category} (tuC : tensor_unit C) (tuD : tensor_unit D) (F : functor C D) : UU := preserves_tensor tuC tuD F × preserves_unit tuC tuD F. Definition functor_tensor_unit_to_preserves_tensor {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {F : functor C D} (ptu : functor_tensor_unit tuC tuD F) : preserves_tensor tuC tuD F := pr1 ptu. Coercion functor_tensor_unit_to_preserves_tensor : functor_tensor_unit >-> preserves_tensor. Definition functor_tensor_unit_to_preserves_unit {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {F : functor C D} (ptu : functor_tensor_unit tuC tuD F) : preserves_unit tuC tuD F := pr2 ptu. Coercion functor_tensor_unit_to_preserves_unit : functor_tensor_unit >-> preserves_unit. Definition identity_functor_tensor_unit {C : category} (tu : tensor_unit C) : functor_tensor_unit tu tu (functor_identity C). Proof. use tpair. - apply identityfunctor_preserves_tensor. - apply identityfunctor_preserves_unit. Defined. Definition composite_functor_tensor_unit {C D E : category} {F : functor C D} {G : functor D E} {tuC : tensor_unit C} {tuD : tensor_unit D} {tuE : tensor_unit E} (ptuF : functor_tensor_unit tuC tuD F) (ptuG : functor_tensor_unit tuD tuE G) : functor_tensor_unit tuC tuE (functor_composite F G). Proof. use tpair. - apply (compositions_preserves_tensor ptuF ptuG). - apply (composition_preserves_unit ptuF ptuG). Defined. Definition nattrans_tensor_unit {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {F G : functor C D} (ptuF : functor_tensor_unit tuC tuD F) (ptuG : functor_tensor_unit tuC tuD G) (α : nat_trans F G) : UU := preservestensor_commutes ptuF ptuG α × preservesunit_commutes ptuF ptuG α. Lemma isaprop_nattrans_tensor_unit {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {F G : functor C D} (ptuF : functor_tensor_unit tuC tuD F) (ptuG : functor_tensor_unit tuC tuD G) (α : nat_trans F G) : isaprop (nattrans_tensor_unit ptuF ptuG α). Proof. apply isapropdirprod. - apply isaprop_preservestensor_commutes. - apply isaprop_preservesunit_commutes. Qed. End TensorUnit. Module TensorUnitNotation. Notation "T_{ tu }" := (tensor_unit_to_tensor tu). Notation "I_{ tu }" := (tensor_unit_to_unit tu). Notation "pt_{ ptu }" := (functor_tensor_unit_to_preserves_tensor ptu). Notation "pu_{ ptu }" := (functor_tensor_unit_to_preserves_unit ptu). End TensorUnitNotation. Section LeftUnitor. Import TensorNotation. Import TensorUnitNotation. Definition lunitor_data {C : category} (tu : tensor_unit C) : UU := ∏ x : C, C⟦I_{tu} ⊗_{tu} x, x⟧. Definition lunitor_nat {C : category} {tu : tensor_unit C} (lu : lunitor_data tu) : UU := ∏ (x y : C) (f : C⟦x,y⟧), ((identity I_{tu}) ⊗^{tu} f) · (lu y) = (lu x) · f. Definition lunitor {C : category} (tu : tensor_unit C) : UU := ∑ lu : lunitor_data tu, lunitor_nat lu. (* For some reason I can't just do pt_{ptuF} _ _, but I really have to project on the first component, however there are coercions.. *) Definition preserves_lunitor {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (luC : lunitor tuC) (luD : lunitor tuD) : UU := ∏ x : C, (pu_{ptuF} ⊗^{tuD} (identity (F x))) · (pr1 pt_{ptuF} I_{tuC} x) · (functor_on_morphisms F (pr1 luC x)) = pr1 luD (F x). Definition id_preserves_lunitor {C : category} {tu : tensor_unit C} (lu : lunitor tu) : preserves_lunitor (identity_functor_tensor_unit tu) lu lu. Proof. intro x. etrans. { apply cancel_postcomposition. apply id_right. } etrans. { apply cancel_postcomposition. apply tensor_id. } apply id_left. Qed. Definition comp_preserves_lunitor {C D E : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {tuE : tensor_unit E} {F : functor C D} {G : functor D E} {ptuF : functor_tensor_unit tuC tuD F} {ptuG : functor_tensor_unit tuD tuE G} {luC : lunitor tuC} {luD : lunitor tuD} {luE : lunitor tuE} (pluF : preserves_lunitor ptuF luC luD) (pluG : preserves_lunitor ptuG luD luE) : preserves_lunitor (composite_functor_tensor_unit ptuF ptuG) luC luE. Proof. intro x. use pathscomp0. 3: exact (pluG (F x)). etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply maponpaths. apply (! id_right _). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply tensor_comp. } rewrite assoc'. rewrite assoc'. use pathscomp0. 3: { apply assoc. } apply cancel_precomposition. unfold compositions_preserves_tensor_data. use pathscomp0. 3: { apply cancel_precomposition. apply maponpaths. exact (pluF x). } (* cbn. *) unfold composite_functor_tensor_unit. unfold compositions_preserves_tensor. unfold compositions_preserves_tensor_data. use pathscomp0. 3: { apply cancel_precomposition. apply (! functor_comp _ _ _). } rewrite assoc. rewrite assoc. cbn. rewrite assoc. apply cancel_postcomposition. use pathscomp0. 3: { apply cancel_precomposition. apply (! functor_comp _ _ _). } use pathscomp0. 3: { apply assoc'. } apply cancel_postcomposition. use pathscomp0. 3: { apply (! pr21 ptuG _ _ _ _ _ _). } apply cancel_postcomposition. apply maponpaths. apply (! functor_id _ _). Qed. Definition isaprop_preserves_lunitor {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (luC : lunitor tuC) (luD : lunitor tuD) : isaprop (preserves_lunitor ptuF luC luD). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. End LeftUnitor. Section RightUnitor. Import TensorNotation. Import TensorUnitNotation. Definition runitor_data {C : category} (tu : tensor_unit C) : UU := ∏ x : C, C⟦x ⊗_{tu} I_{tu}, x⟧. Definition runitor_nat {C : category} {tu : tensor_unit C} (ru : runitor_data tu) : UU := ∏ (x y : C) (f : C⟦x,y⟧), (f ⊗^{tu} (identity I_{tu})) · (ru y) = (ru x) · f. Definition runitor {C : category} (tu : tensor_unit C) : UU := ∑ ru : runitor_data tu, runitor_nat ru. (* For some reason I can't just do pt_{ptuF} _ _, but I really have to project on the first component, however there are coercions.. *) Definition preserves_runitor {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (ruC : runitor tuC) (ruD : runitor tuD) : UU := ∏ x : C, ((identity (F x)) ⊗^{tuD} pu_{ptuF}) · (pr1 pt_{ptuF} x I_{tuC}) · (functor_on_morphisms F (pr1 ruC x)) = pr1 ruD (F x). Definition id_preserves_runitor {C : category} {tu : tensor_unit C} (ru : runitor tu) : preserves_runitor (identity_functor_tensor_unit tu) ru ru. Proof. intro x. etrans. { apply cancel_postcomposition. apply id_right. } etrans. { apply cancel_postcomposition. apply tensor_id. } apply id_left. Qed. Definition comp_preserves_runitor {C D E : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {tuE : tensor_unit E} {F : functor C D} {G : functor D E} {ptuF : functor_tensor_unit tuC tuD F} {ptuG : functor_tensor_unit tuD tuE G} {ruC : runitor tuC} {ruD : runitor tuD} {ruE : runitor tuE} (pruF : preserves_runitor ptuF ruC ruD) (pruG : preserves_runitor ptuG ruD ruE) : preserves_runitor (composite_functor_tensor_unit ptuF ptuG) ruC ruE. Proof. intro x. use pathscomp0. 3: exact (pruG (F x)). etrans. { apply cancel_postcomposition. apply cancel_postcomposition. assert (pf : (identity (G (F x))) = (identity (G (F x)))· (identity (G (F x)))). { apply (! id_right _). } simpl. rewrite pf. apply tensor_comp. } rewrite assoc'. rewrite assoc'. use pathscomp0. 3: { apply assoc. } apply cancel_precomposition. unfold compositions_preserves_tensor_data. use pathscomp0. 3: { apply cancel_precomposition. apply maponpaths. exact (pruF x). } cbn in *. unfold compositions_preserves_tensor_data. use pathscomp0. 3: { apply cancel_precomposition. apply (! functor_comp _ _ _). } rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. use pathscomp0. 3: { apply cancel_precomposition. apply (! functor_comp _ _ _). } use pathscomp0. 3: { apply assoc'. } apply cancel_postcomposition. use pathscomp0. 3: { apply (! pr21 ptuG _ _ _ _ _ _). } apply cancel_postcomposition. rewrite (! functor_id _ _). apply idpath. Qed. Definition isaprop_preserves_runitor {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (ruC : runitor tuC) (ruD : runitor tuD) : isaprop (preserves_runitor ptuF ruC ruD). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. End RightUnitor. Section Associator. Import TensorNotation. Import TensorUnitNotation. Definition associator_data {C : category} (tu : tensor_unit C) : UU := ∏ x y z : C, C⟦(x ⊗_{tu} y) ⊗_{tu} z, x ⊗_{tu} (y ⊗_{tu} z)⟧. Definition associator_nat {C : category} {tu : tensor_unit C} (α : associator_data tu) : UU := ∏ (x x' y y' z z' : C), ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧), (α x y z)· (f ⊗^{tu} (g ⊗^{tu} h)) = ((f ⊗^{tu} g) ⊗^{tu} h) · (α x' y' z'). Definition isaprop_associator_nat {C : category} {tu : tensor_unit C} (α : associator_data tu) : isaprop (associator_nat α). Proof. repeat (apply impred_isaprop ; intro) ; apply homset_property. Qed. Definition associator {C : category} (tu : tensor_unit C) : UU := ∑ α : associator_data tu, associator_nat α. Definition preserves_associator {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (αC : associator tuC) (αD : associator tuD) : UU := ∏ (x y z : C), ((pr1 pt_{ptuF} x y) ⊗^{tuD} (identity (F z))) · (pr1 pt_{ptuF} (x ⊗_{tuC} y) z) · (functor_on_morphisms F (pr1 αC x y z)) = (pr1 αD (F x) (F y) (F z)) · ((identity (F x)) ⊗^{tuD} (pr1 pt_{ptuF} y z)) · (pr1 pt_{ptuF} x (y ⊗_{tuC} z)). Definition id_preserves_associator {C : category} {tu : tensor_unit C} (α : associator tu) : preserves_associator (identity_functor_tensor_unit tu) α α. Proof. intros x y z. etrans. { apply cancel_postcomposition. apply id_right. } etrans. { apply cancel_postcomposition. apply tensor_id. } etrans. { apply id_left. } apply pathsinv0. etrans. { apply cancel_postcomposition. apply cancel_precomposition. apply tensor_id. } etrans. { apply cancel_postcomposition. apply id_right. } apply id_right. Qed. Definition comp_preserves_associator {C D E : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {tuE : tensor_unit E} {F : functor C D} {G : functor D E} {ptuF : functor_tensor_unit tuC tuD F} {ptuG : functor_tensor_unit tuD tuE G} {assC : associator tuC} {assD : associator tuD} {assE : associator tuE} (paF : preserves_associator ptuF assC assD) (paG : preserves_associator ptuG assD assE) : preserves_associator (composite_functor_tensor_unit ptuF ptuG) assC assE. Proof. intros x y z. cbn in *. unfold compositions_preserves_tensor_data. etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply maponpaths. apply (! id_right _). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply tensor_comp. } etrans. { rewrite assoc'. rewrite assoc'. apply cancel_precomposition. rewrite assoc. apply cancel_postcomposition. rewrite assoc. apply cancel_postcomposition. rewrite (! functor_id _ _). apply (! pr21 ptuG _ _ _ _ _ _ ). } etrans. { apply cancel_precomposition. rewrite assoc'. rewrite (! functor_comp _ _ _). rewrite assoc'. rewrite (! functor_comp _ _ _). apply cancel_precomposition. apply maponpaths. rewrite assoc. apply (paF x y z). } simpl. rewrite functor_comp. etrans. { rewrite assoc. rewrite assoc. apply cancel_postcomposition. rewrite assoc'. rewrite functor_comp. rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply paG. } rewrite assoc'. rewrite assoc'. rewrite assoc'. rewrite assoc'. apply cancel_precomposition. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. assert (pf : (identity (G (F x))) = (identity (G (F x)))· (identity (G (F x)))). { apply (! id_right _). } use pathscomp0. 3: { rewrite pf. rewrite tensor_comp. apply assoc. } rewrite assoc'. apply cancel_precomposition. etrans. { apply (pr21 ptuG). } rewrite (functor_id _ _). apply idpath. Qed. Definition isaprop_preserves_associator {C D : category} {F : functor C D} {tuC : tensor_unit C} {tuD : tensor_unit D} (ptuF : functor_tensor_unit tuC tuD F) (assC : associator tuC) (assD : associator tuD) : isaprop (preserves_associator ptuF assC assD). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. End Associator. Section UnitorsAssociator. Definition unitors_associator {C : category} (tu : tensor_unit C) : UU := lunitor tu × runitor tu × associator tu. Definition unitors_associator_to_lunitor {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : lunitor tu := pr1 ua. (* Coercion unitors_associator_to_lunitor : unitors_associator >-> lunitor. *) Definition unitors_associator_to_runitor {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : runitor tu := pr12 ua. (* Coercion unitors_associator_to_runitor : unitors_associator >-> runitor. *) Definition unitors_associator_to_associator {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : associator tu := pr22 ua. (* Coercion unitors_associator_to_associator : unitors_associator >-> associator. *) Definition functor_unitors_associator {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} (uaC : unitors_associator tuC) (uaD : unitors_associator tuD) {F : functor C D} (ptuF : functor_tensor_unit tuC tuD F) : UU := preserves_lunitor ptuF (pr1 uaC) (pr1 uaD) × preserves_runitor ptuF (pr12 uaC) (pr12 uaD) × preserves_associator ptuF (pr22 uaC) (pr22 uaD). (* := preserves_lunitor ptuF uaC uaD × preserves_runitor ptuF uaC uaD × preserves_associator ptuF uaC uaD. *) Definition functor_unitors_associator_to_preserves_lunitor {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {F : functor C D} {ptuF : functor_tensor_unit tuC tuD F} (puaF : functor_unitors_associator uaC uaD ptuF) : preserves_lunitor ptuF (pr1 uaC) (pr1 uaD) := pr1 puaF. (* : preserves_lunitor ptuF (pr1 uaC) uaD := pr1 puaF. *) Coercion functor_unitors_associator_to_preserves_lunitor : functor_unitors_associator >-> preserves_lunitor. Definition functor_unitors_associator_to_preserves_runitor {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {F : functor C D} {ptuF : functor_tensor_unit tuC tuD F} (puaF : functor_unitors_associator uaC uaD ptuF) : preserves_runitor ptuF (pr12 uaC) (pr12 uaD) := pr12 puaF. Coercion functor_unitors_associator_to_preserves_runitor : functor_unitors_associator >-> preserves_runitor. Definition functor_unitors_associator_to_preserves_associator {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {F : functor C D} {ptuF : functor_tensor_unit tuC tuD F} (puaF : functor_unitors_associator uaC uaD ptuF) : preserves_associator ptuF (pr22 uaC) (pr22 uaD) := pr22 puaF. Coercion functor_unitors_associator_to_preserves_associator : functor_unitors_associator >-> preserves_associator. Definition identity_functor_unitors_associator {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : functor_unitors_associator ua ua (identity_functor_tensor_unit tu). Proof. repeat split. - apply id_preserves_lunitor. - apply id_preserves_runitor. - apply id_preserves_associator. Defined. Definition comp_functor_unitors_associator {C D E : category} {F : functor C D} {G : functor D E} {tuC : tensor_unit C} {tuD : tensor_unit D} {tuE : tensor_unit E} {ptuF : functor_tensor_unit tuC tuD F} {ptuG : functor_tensor_unit tuD tuE G} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {uaE : unitors_associator tuE} (puaF : functor_unitors_associator uaC uaD ptuF) (puaG : functor_unitors_associator uaD uaE ptuG) : functor_unitors_associator uaC uaE (composite_functor_tensor_unit ptuF ptuG). Proof. repeat split. - apply (comp_preserves_lunitor puaF puaG). - apply (comp_preserves_runitor puaF puaG). - apply (comp_preserves_associator puaF puaG). Defined. Lemma isaprop_functor_unitors_associator {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} (uaC : unitors_associator tuC) (uaD : unitors_associator tuD) {F : functor C D} (ptuF : functor_tensor_unit tuC tuD F) : isaprop (functor_unitors_associator uaC uaD ptuF). Proof. repeat (apply isapropdirprod). - apply isaprop_preserves_lunitor. - apply isaprop_preserves_runitor. - apply isaprop_preserves_associator. Qed. End UnitorsAssociator. Module UnitorsAssociatorNotation. Notation "lu^{ ua }" := (unitors_associator_to_lunitor ua). Notation "ru^{ ua }" := (unitors_associator_to_runitor ua). Notation "ass^{ ua }" := (unitors_associator_to_associator ua). End UnitorsAssociatorNotation. Section PentagonTriangle. Import TensorNotation. Import TensorUnitNotation. Import UnitorsAssociatorNotation. Definition triangle {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := ∏ (x y : C), (pr1 ass^{ua} x I_{tu} y) · ((identity x) ⊗^{tu} (pr1 lu^{ua} y)) = (pr1 ru^{ua} x) ⊗^{tu} (identity y). Definition pentagon {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := ∏ (w x y z : C), ((pr1 ass^{ua} w x y) ⊗^{tu} (identity z)) · (pr1 ass^{ua} w (x⊗_{tu} y) z) · ((identity w) ⊗^{tu} (pr1 ass^{ua} x y z)) = (pr1 ass^{ua} (w ⊗_{tu} x) y z) · (pr1 ass^{ua} w x (y ⊗_{tu} z)). Definition triangle_pentagon {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := triangle ua × pentagon ua. Lemma isaprop_triangle {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (triangle ua). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Lemma isaprop_pentagon {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (pentagon ua). Proof. repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Lemma isaprop_triangle_pentagon {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (triangle_pentagon ua). Proof. apply isapropdirprod. - apply isaprop_triangle. - apply isaprop_pentagon. Qed. End PentagonTriangle. Section CurriedLaxMonoidalCategories. Import TensorNotation. Import TensorUnitNotation. Import UnitorsAssociatorNotation. Definition lunitor_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := ∏ (x : C), is_z_isomorphism (pr1 lu^{ua} x). Definition runitor_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := ∏ (x : C), is_z_isomorphism (pr1 ru^{ua} x). Definition associator_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := ∏ (x y z : C), is_z_isomorphism (pr1 ass^{ua} x y z). Definition unitors_associator_are_z_isos {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : UU := lunitor_invertible ua × runitor_invertible ua × associator_invertible ua. Definition isaprop_lunitor_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (lunitor_invertible ua). Proof. repeat (apply impred_isaprop ; intro). apply isaprop_is_z_isomorphism. Qed. Definition isaprop_runitor_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (runitor_invertible ua). Proof. repeat (apply impred_isaprop ; intro). apply isaprop_is_z_isomorphism. Qed. Definition isaprop_associator_invertible {C : category} {tu : tensor_unit C} (ua : unitors_associator tu) : isaprop (associator_invertible ua). Proof. repeat (apply impred_isaprop ; intro). apply isaprop_is_z_isomorphism. Qed. Definition isaprop_invertible_data {C : category} {tu : tensor_unit C} {ua : unitors_associator tu} : isaprop (unitors_associator_are_z_isos ua). Proof. repeat (apply isapropdirprod). - apply isaprop_lunitor_invertible. - apply isaprop_runitor_invertible. - apply isaprop_associator_invertible. Qed. End CurriedLaxMonoidalCategories. Section StrongMonoidalFunctors. Definition functor_strong {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {F : functor C D} {ptuF : functor_tensor_unit tuC tuD F} (puaF : functor_unitors_associator uaC uaD ptuF) : UU := is_z_isomorphism (pr2 ptuF) × ∏ x y : C, is_z_isomorphism (pr11 ptuF x y). Definition isaprop_functor_strong {C D : category} {tuC : tensor_unit C} {tuD : tensor_unit D} {uaC : unitors_associator tuC} {uaD : unitors_associator tuD} {F : functor C D} {ptuF : functor_tensor_unit tuC tuD F} (puaF : functor_unitors_associator uaC uaD ptuF) : isaprop (functor_strong puaF). Proof. apply isapropdirprod. - apply isaprop_is_z_isomorphism. - repeat (apply impred_isaprop ; intro). apply isaprop_is_z_isomorphism. Qed. End StrongMonoidalFunctors. Section MonoidalSigmaStructure. Definition tensor_unit_unitors_associator (C : category) : UU := ∑ tu : tensor_unit C, unitors_associator tu. Definition tensor_unit_unitors_associator_to_tensor_unit {C : category} (tuua : tensor_unit_unitors_associator C) : tensor_unit C := pr1 tuua. Coercion tensor_unit_unitors_associator_to_tensor_unit : tensor_unit_unitors_associator >-> tensor_unit. Definition tensor_unit_unitors_associator_to_unitors_associator {C : category} (tuua : tensor_unit_unitors_associator C) : unitors_associator (tensor_unit_unitors_associator_to_tensor_unit tuua) := pr2 tuua. Coercion tensor_unit_unitors_associator_to_unitors_associator : tensor_unit_unitors_associator >-> unitors_associator. Definition mon_structure (C : category) : UU := ∑ tuua : tensor_unit_unitors_associator C, triangle_pentagon tuua × unitors_associator_are_z_isos tuua. Definition mon_structure_to_tensor_unit_unitors_associator {C : category} (lm : mon_structure C) : tensor_unit_unitors_associator C := pr1 lm. Coercion mon_structure_to_tensor_unit_unitors_associator : mon_structure >-> tensor_unit_unitors_associator. Definition mon_structure_triangle_pentagon {C : category} (lm : mon_structure C) : triangle_pentagon lm × unitors_associator_are_z_isos lm := pr2 lm. End MonoidalSigmaStructure. Section MonoidalFunctorSigmaStructure. Definition functor_tensor_unit_unitors_associator {C D : category} (F : functor C D) (tuuaC : tensor_unit_unitors_associator C) (tuuaD : tensor_unit_unitors_associator D) : UU := ∑ ftu : functor_tensor_unit tuuaC tuuaD F, functor_unitors_associator tuuaC tuuaD ftu. Definition functor_tensor_unit_unitors_associator_to_tensor_unit {C D : category} {F : functor C D} {tuuaC : tensor_unit_unitors_associator C} {tuuaD : tensor_unit_unitors_associator D} (ftuua : functor_tensor_unit_unitors_associator F tuuaC tuuaD) : functor_tensor_unit tuuaC tuuaD F := pr1 ftuua. Coercion functor_tensor_unit_unitors_associator_to_tensor_unit : functor_tensor_unit_unitors_associator >-> functor_tensor_unit. Definition functor_tensor_unit_unitors_associator_to_unitors_associator {C D : category} {F : functor C D} {tuuaC : tensor_unit_unitors_associator C} {tuuaD : tensor_unit_unitors_associator D} (ftuua : functor_tensor_unit_unitors_associator F tuuaC tuuaD) : functor_unitors_associator tuuaC tuuaD (functor_tensor_unit_unitors_associator_to_tensor_unit ftuua) := pr2 ftuua. Coercion functor_tensor_unit_unitors_associator_to_unitors_associator : functor_tensor_unit_unitors_associator >-> functor_unitors_associator. Definition functor_lax_monoidal {C D : category} (F : functor C D) (tuuaC : tensor_unit_unitors_associator C) (tuuaD : tensor_unit_unitors_associator D) : UU := functor_tensor_unit_unitors_associator F tuuaC tuuaD. Identity Coercion functor_lax_monoidal_tensorunitunitorsassociator : functor_lax_monoidal >-> functor_tensor_unit_unitors_associator. Definition functor_strong_monoidal {C D : category} (F : functor C D) (tuuaC : tensor_unit_unitors_associator C) (tuuaD : tensor_unit_unitors_associator D) : UU := ∑ ftuua : functor_lax_monoidal F tuuaC tuuaD, functor_strong ftuua. Definition functor_strong_monoidal_to_lax_monoidal {C D : category} {F : functor C D} {tuuaC : tensor_unit_unitors_associator C} {tuuaD : tensor_unit_unitors_associator D} (ftuuas : functor_strong_monoidal F tuuaC tuuaD) : functor_lax_monoidal F tuuaC tuuaD := pr1 ftuuas. End MonoidalFunctorSigmaStructure. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatCurried.v000066400000000000000000000212751451125700300332760ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.FinalLayer. Local Open Scope cat. Local Open Scope mor_disp_scope. Section EquivalenceWithCurriedMonStruct. Definition ucat (C : bicat_of_univ_cats) : category := (C : univalent_category). Definition tensor_unit_unitors_associator_equiv_layer (C : bicat_of_univ_cats) : disp_tensor_unit_unitors_associator C ≃ tensor_unit_unitors_associator (ucat C). Proof. apply weqfibtototal. intro tu. apply weqdirprodasstor. Defined. Definition cmon_structure_equiv_layer (C : bicat_of_univ_cats) : disp_univmon C ≃ CurriedMonoidalCategories.mon_structure (ucat C). Proof. use weqtotal2. { apply tensor_unit_unitors_associator_equiv_layer. } intro tuua. simpl. apply weqimplimpl. - intro tpi. repeat split ; apply tpi. - intro tpi. repeat split ; apply tpi. - apply isaprop_P_prop. - apply isapropdirprod. + apply isaprop_triangle_pentagon. + apply isaprop_invertible_data. Defined. Definition cmon_structure_from_layer {C : bicat_of_univ_cats} (M : disp_univmon C) : mon_structure (ucat C) := pr1 (cmon_structure_equiv_layer C) M. Definition cmon_structure_to_layer {C : bicat_of_univ_cats} (M : mon_structure (ucat C)) : disp_univmon C := invmap (cmon_structure_equiv_layer C) M. Definition equivalence_cmon_structure_oblayer : ob UMONCAT ≃ ∑ C : bicat_of_univ_cats, mon_structure (ucat C). Proof. apply weqfibtototal. intro ; apply cmon_structure_equiv_layer. Defined. Definition UMONCAT_to_cmon_category (M : ob UMONCAT) : ∑ C : bicat_of_univ_cats, mon_structure (ucat C) := (equivalence_cmon_structure_oblayer) M. Definition cmon_category_to_UMONCAT (M : ∑ C : bicat_of_univ_cats, mon_structure (ucat C)) : ob UMONCAT := invmap (equivalence_cmon_structure_oblayer) M. Lemma sigma_with_unit (A : UU) : (∑ _ : A, unit) ≃ A. Proof. use weq_iso. - intro x ; exact (pr1 x). - intro a ; apply (a ,, tt). - intro. use total2_paths_f. { apply idpath. } apply isapropunit. - intro. apply idpath. Defined. Definition cmonstrongfunctor_structure_equiv_layer (C : bicat_of_univ_cats) : disp_univstrongfunctor C ≃ CurriedMonoidalCategories.mon_structure (ucat C). Proof. refine (sigma_with_unit _ ∘ _)%weq. use weqtotal2. { apply cmon_structure_equiv_layer. } intro ; apply idweq. Defined. End EquivalenceWithCurriedMonStruct. Section EquivalenceWithCurriedLaxMonFunctors. Definition functor_laxmon_from_layer {C D : bicat_of_univ_cats} (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_univmon C) (tuuaD : disp_univmon D) : tuuaC -->[F] tuuaD -> functor_lax_monoidal F (cmon_structure_from_layer tuuaC) (cmon_structure_from_layer tuuaD). Proof. intro ptuua. use tpair. - apply equality_functor_assunitors_with_layer. apply (pr1 ptuua). - repeat split. + apply (pr121 ptuua). + apply (pr2 (pr121 ptuua)). + apply (pr221 ptuua). Defined. Definition functor_laxmon_to_layer {C D : bicat_of_univ_cats} {F : bicat_of_univ_cats⟦C,D⟧} (tuuaC : disp_univmon C) (tuuaD : disp_univmon D) : functor_lax_monoidal F (cmon_structure_from_layer tuuaC) (cmon_structure_from_layer tuuaD) -> tuuaC -->[F] tuuaD. Proof. intro ptuua. use tpair. - apply equality_functor_assunitors_with_layer. apply ptuua. - exact tt. Defined. Definition functor_laxmon_equiv_layer {C D : bicat_of_univ_cats} (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_univmon C) (tuuaD : disp_univmon D) : functor_lax_monoidal F (cmon_structure_from_layer tuuaC) (cmon_structure_from_layer tuuaD) ≃ tuuaC -->[F] tuuaD. Proof. use weq_iso. - apply functor_laxmon_to_layer. - apply functor_laxmon_from_layer. - intro ; apply idpath. - intro. use total2_paths_f. + apply idpath. + apply isapropunit. Defined. (* Definition univstrongfunctor_to_univmon_on_ob (C : bicat_of_univ_cats) : disp_univstrongfunctor C -> disp_univmon C := pr1. *) Definition functor_strongmon_equiv_layer {C D : bicat_of_univ_cats} (F : bicat_of_univ_cats⟦C,D⟧) (tuuaC : disp_univstrongfunctor C) (tuuaD : disp_univstrongfunctor D) : functor_strong_monoidal F (cmon_structure_from_layer (pr1 tuuaC)) (cmon_structure_from_layer (pr1 tuuaD)) ≃ tuuaC -->[F] tuuaD. Proof. use weqtotal2. { apply functor_laxmon_equiv_layer. } intro flm. use weqimplimpl. - intro flms. split ; apply flms. - intro flms. split ; apply flms. - apply isaprop_functor_strong. - simpl. apply isaprop_P_strong_preserving. Defined. End EquivalenceWithCurriedLaxMonFunctors. Section EquivalenceWithCurriedNatTrans. Import Notations. Definition nattrans_laxmon_from_layer {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats⟦C,D⟧} (α : F ==> G) {tuuaC : disp_univmon C} {tuuaD : disp_univmon D} (ptuuaF : tuuaC -->[F] tuuaD) (ptuuaG : tuuaC -->[G] tuuaD) : ptuuaF ==>[α] ptuuaG -> nattrans_tensor_unit (functor_laxmon_from_layer F tuuaC tuuaD ptuuaF) (functor_laxmon_from_layer _ _ _ ptuuaG) α. Proof. intro ntu. apply ntu. Defined. Definition nattrans_laxmon_to_layer {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats⟦C,D⟧} (α : F ==> G) {tuuaC : disp_univmon C} {tuuaD : disp_univmon D} (ptuuaF : tuuaC -->[F] tuuaD) (ptuuaG : tuuaC -->[G] tuuaD) : nattrans_tensor_unit (functor_laxmon_from_layer _ _ _ ptuuaF) (functor_laxmon_from_layer _ _ _ ptuuaG) α -> ptuuaF ==>[α] ptuuaG. Proof. intro ntu. repeat (use tpair) ; try (exact tt) ; try (apply ntu). Defined. Definition nattrans_laxmon_equiv_layer {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats⟦C,D⟧} (α : F ==> G) {tuuaC : disp_univmon C} {tuuaD : disp_univmon D} (ptuuaF : tuuaC -->[F] tuuaD) (ptuuaG : tuuaC -->[G] tuuaD) : nattrans_tensor_unit (functor_laxmon_from_layer _ _ _ ptuuaF) (functor_laxmon_from_layer _ _ _ ptuuaG) α ≃ ptuuaF ==>[α] ptuuaG. Proof. use weq_iso. - apply nattrans_laxmon_to_layer. - apply nattrans_laxmon_from_layer. - intro ; apply idpath. - intro. repeat (use total2_paths_f) ; try (apply idpath) ; try (apply isapropunit). Defined. Definition nattrans_strongmon_equiv_layer {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats⟦C,D⟧} (α : F ==> G) {tuuaC : disp_univstrongfunctor C} {tuuaD : disp_univstrongfunctor D} (ptuuaF : tuuaC -->[F] tuuaD) (ptuuaG : tuuaC -->[G] tuuaD) : nattrans_tensor_unit (functor_laxmon_from_layer _ _ _ (pr1 ptuuaF)) (functor_laxmon_from_layer _ _ _ (pr1 ptuuaG)) α ≃ ptuuaF ==>[α] ptuuaG. Proof. use weqimplimpl. - intro ptc. simpl. repeat split ; apply ptc. - intro ptc. simpl. repeat split ; apply ptc. - apply isaprop_nattrans_tensor_unit. - apply isaproptotal2 ; try (intro ; apply isapropunit). do 4 intro. use total2_paths_f. -- use total2_paths_f. { use total2_paths_f. - apply isaprop_preservestensor_commutes. - apply isaprop_preservesunit_commutes. } simpl. repeat (apply isapropdirprod) ; apply isapropunit. -- apply isapropunit. Defined. End EquivalenceWithCurriedNatTrans. EquivalenceMonCatNonCurried.v000066400000000000000000000437641451125700300337010ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCatRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.EquivalenceWhiskeredNonCurriedMonoidalCategories. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesReordered. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.FinalLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.FinalLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.EquivalenceMonCatCurried. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.EquivalenceWhiskeredCurried. Local Open Scope cat. Local Open Scope mor_disp_scope. (* Definition TODO {A : UU} : A. Admitted. Section EquivalenceMonCatNonCurried. Definition cmonoidal_to_noncurriedmonoidal : ob UMONCAT ≃ ∑ C : monoidal_cat, is_univalent (monoidal_cat_cat C). Proof. refine (_ ∘ equivalence_cmon_structure_oblayer)%weq. refine (_ ∘ _)%weq. { use weqfibtototal. 2: exact (λ C, cmon_equiv_wmon (pr1 C)). } refine (_ ∘ _)%weq. 1: apply weqtotal2comm12. use weq_subtypes'. - refine (moncats0_equiv_uncurried ∘ moncats_equiv_moncats0 ∘ _)%weq. use weqfibtototal. intro C. exact (invweq (monoidal_struct_equiv_monoidal C)). - intro ; apply isaprop_is_univalent. - intro ; apply isaprop_is_univalent. - intro ; apply isrefl_logeq. Defined. End EquivalenceMonCatNonCurried. Section EquivalenceMonCatNonCurriedLaxFunctors. Lemma UMONCAT_2cell_equality {M N : ob UMONCAT} {F G : hom M N} (α β : (hom M N)⟦F,G⟧) : (∏ x : pr11 M, (pr11 α) x = (pr11 β) x) -> α = β. Proof. intro p. repeat (use total2_paths_f). - apply funextsec ; intro x. exact (p x). - apply isaprop_is_nat_trans. apply homset_property. - repeat (apply funextsec ; intro) ; apply homset_property. - apply homset_property. - apply isapropunit. - apply isapropunit. - apply isapropunit. - apply isapropunit. Qed. Lemma LaxMonoidalFunctor_mor_equality {M N : monoidal_cat} {F G : LaxMonoidalFunctorCat M N} (α β : (LaxMonoidalFunctorCat M N)⟦F,G⟧) : (∏ x : pr11 M, (pr111 α) x = (pr111 β) x) -> α = β. Proof. intro p. repeat (use total2_paths_f). - apply funextsec ; intro x. exact (p x). - apply isaprop_is_nat_trans. apply homset_property. - repeat (apply funextsec ; intro) ; apply homset_property. - apply homset_property. - apply isapropunit. - apply isapropunit. - apply isapropunit. Qed. Lemma tensor_on_hom_eq (M : ob UMONCAT) {x1 x2 y1 y2 : pr11 M} (f : (pr11 M)⟦x1,x2⟧) (g : (pr11 M)⟦y1,y2⟧) : tensor_on_hom (pr11 (pr112 M)) x1 x2 y1 y2 f g = # (pr121 (cmonoidal_to_noncurriedmonoidal M)) (f #, g). Proof. etrans. 2: { apply (tensor_comp (pr1 (pr112 M)) _ _ _ _ _ _ _ _ _ _). } rewrite id_right. now rewrite id_left. Qed. Definition cmonoidal_to_noncurried_functor_pt_data (M N : ob UMONCAT) {F : functor (pr11 M) (pr11 N)} (ptF : functor_tensor_disp_cat (pr121 (cmonoidal_to_noncurriedmonoidal M)) (pr121 (cmonoidal_to_noncurriedmonoidal N)) F ) : preserves_tensor_data (pr1 (pr111 (pr2 M))) (pr1 (pr111 (pr2 N))) F := λ x y, pr1 ptF (x,y). Lemma cmonoidal_to_noncurried_functor_pt_nat (M N : ob UMONCAT) {F : functor (pr11 M) (pr11 N)} (ptF : functor_tensor_disp_cat (pr121 (cmonoidal_to_noncurriedmonoidal M)) (pr121 (cmonoidal_to_noncurriedmonoidal N)) F ) : preserves_tensor_nat (cmonoidal_to_noncurried_functor_pt_data M N ptF). Proof. intros x1 x2 y1 y2 f g. refine (_ @ ! pr2 ptF _ _ (f #, g) @ _). - apply maponpaths. apply (maponpaths (#F)). apply tensor_on_hom_eq. - apply maponpaths_2. exact (! tensor_on_hom_eq N (#F f) (#F g)). Qed. Definition cmonoidal_to_noncurried_functor_pt (M N : ob UMONCAT) {F : functor (pr11 M) (pr11 N)} (ptF : functor_tensor_disp_cat (pr121 (cmonoidal_to_noncurriedmonoidal M)) (pr121 (cmonoidal_to_noncurriedmonoidal N)) F ) : preserves_tensor (pr111 (pr2 M)) (pr111 (pr2 N)) F := _ ,, cmonoidal_to_noncurried_functor_pt_nat M N ptF. Lemma cmonoidal_to_noncurrier_preserves_lunitor (M N : ob UMONCAT) (F : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) : preserves_lunitor (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F) (pr112 (pr12 M)) (pr112 (pr12 N)). Proof. intro x. refine (_ @ ! (pr112 F x)). do 2 apply maponpaths_2. apply tensor_on_hom_eq. Qed. Lemma cmonoidal_to_noncurrier_preserves_runitor (M N : ob UMONCAT) (F : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) : preserves_runitor (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F) (pr212 (pr12 M)) (pr212 (pr12 N)). Proof. intro x. refine (_ @ ! (pr212 F x)). do 2 apply maponpaths_2. apply tensor_on_hom_eq. Qed. Lemma cmonoidal_to_noncurrier_preserves_associator (M N : ob UMONCAT) (F : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) : preserves_associator (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F) (pr221 (pr2 M)) (pr221 (pr2 N)). Proof. intros x y z. etrans. { do 2 apply maponpaths_2. apply tensor_on_hom_eq. } refine (pr22 F x y z @ _). apply maponpaths_2. rewrite <- (tensor_on_hom_eq N). apply idpath. Admitted. Definition cmonoidal_to_noncurried_functor (M N : ob UMONCAT) : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)) → UMONCAT ⟦ M, N ⟧. Proof. intro F. use tpair. { exact (pr11 F). } use tpair. - use tpair. + split. * apply cmonoidal_to_noncurried_functor_pt. apply (pr121 F). * exact (pr221 F). + repeat split. * apply cmonoidal_to_noncurrier_preserves_lunitor. * apply cmonoidal_to_noncurrier_preserves_runitor. * apply cmonoidal_to_noncurrier_preserves_associator. - exact tt. Defined. Definition cmonoidal_from_noncurried_functor (M N : ob UMONCAT) : UMONCAT ⟦ M, N ⟧ → LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)). Proof. intro F. use tpair. - exists (pr1 F). split. + use tpair. * intro ; apply (pr1 (pr112 F)). * intros [x1 x2] [y1 y2] [f g]. etrans. { apply maponpaths_2, (! tensor_on_hom_eq N _ _). } refine (! pr21 (pr112 F) x1 y1 x2 y2 f g @ _). simpl. do 2 apply maponpaths. apply tensor_on_hom_eq. + apply (pr2 (pr112 F)). - repeat split. + abstract ( intro x ; refine (! (pr11 (pr212 F) x) @ _) ; do 2 apply maponpaths_2 ; apply (tensor_on_hom_eq N)). + abstract ( intro x ; refine (! (pr21 (pr212 F) x) @ _) ; do 2 apply maponpaths_2 ; apply (tensor_on_hom_eq N)). + intros x y z. (* etrans. { do 2 apply maponpaths_2. apply (! tensor_on_hom_eq N _ _). } refine ((pr2 (pr212 F) x y z) @ _). apply maponpaths_2. apply maponpaths. apply (tensor_on_hom_eq N). *) apply TODO. Defined. Definition cmonoidal_from_noncurried_nattrans (M N : ob UMONCAT) { F G : hom M N } (α : hom M N ⟦ F, G ⟧) : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)) ⟦ (λ F0 : hom M N, cmonoidal_from_noncurried_functor M N F0) F, (λ F0 : hom M N, cmonoidal_from_noncurried_functor M N F0) G ⟧. Proof. use tpair. - exists (pr1 α). split. + intros x y. etrans. { apply maponpaths_2. apply (! tensor_on_hom_eq N _ _). } exact (! pr1 (pr112 α) x y). + exact (pr2 (pr112 α)). - repeat split. Defined. Definition cmonoidal_to_noncurried_nattrans (M N : UMONCAT) {F G : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))} (α : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)) ⟦ F, G ⟧) : (hom M N)⟦ (λ F0 : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)), cmonoidal_to_noncurried_functor M N F0) F, (λ F0 : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)), cmonoidal_to_noncurried_functor M N F0) G ⟧. Proof. exists (pr11 α). use tpair. - use tpair. + split. * intros x y. etrans. 2: { apply maponpaths_2. apply (! tensor_on_hom_eq N _ _). } exact (! pr121 α x y). * exact (pr221 α). + repeat split ; exact tt. - repeat split. Defined. Definition cmonoidal_to_noncurried_hom_data (M N : ob UMONCAT) : functor_data (hom M N) (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))). Proof. use make_functor_data. - intro F. exact (cmonoidal_from_noncurried_functor M N F). - intros F G α. exact (cmonoidal_from_noncurried_nattrans M N α). Defined. Definition cmonoidal_from_noncurried_hom_data (M N : ob UMONCAT) : functor_data (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) (hom M N). Proof. use make_functor_data. - intro F. exact (cmonoidal_to_noncurried_functor M N F). - intros F G α. exact (cmonoidal_to_noncurried_nattrans M N α). Defined. Lemma cmonoidal_to_noncurried_hom_is_functor (M N : ob UMONCAT) : is_functor (cmonoidal_to_noncurried_hom_data M N). Proof. split. - intro. apply LaxMonoidalFunctor_mor_equality. intro ; apply idpath. - intro ; intros. apply LaxMonoidalFunctor_mor_equality. intro ; apply idpath. Qed. Lemma cmonoidal_from_noncurried_hom_is_functor (M N : ob UMONCAT) : is_functor (cmonoidal_from_noncurried_hom_data M N). Proof. split. - intro. apply UMONCAT_2cell_equality. intro ; apply idpath. - intro ; intros. apply UMONCAT_2cell_equality. intro ; apply idpath. Qed. Definition cmonoidal_to_noncurried_hom (M N : ob UMONCAT) : functor (hom M N) (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) := _ ,, cmonoidal_to_noncurried_hom_is_functor M N. Definition cmonoidal_from_noncurried_hom (M N : ob UMONCAT) : functor (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N))) (hom M N) := _ ,, cmonoidal_from_noncurried_hom_is_functor M N. Definition cmonoidal_unit_noncurried_hom_data (M N : ob UMONCAT) : nat_trans_data (functor_identity (hom M N)) (cmonoidal_to_noncurried_hom M N ∙ cmonoidal_from_noncurried_hom M N). Proof. intro F. exists (nat_trans_id _). use tpair. - use tpair. + use tpair. * intros x y. rewrite id_right. refine (! id_left _ @ _). apply maponpaths_2. etrans. 2: { apply (! tensor_on_hom_eq N _ _). } exact (! functor_id (pr121 (cmonoidal_to_noncurriedmonoidal N)) (pr11 F x , pr11 F y)). * apply id_right. + repeat split. - exact tt. Defined. Definition cmonoidal_unit_noncurried_hom_is_nat_trans (M N : ob UMONCAT) : is_nat_trans _ _ (cmonoidal_unit_noncurried_hom_data M N). Proof. intro ; intros. use UMONCAT_2cell_equality. intro. exact (id_right _ @ ! id_left _). Qed. Definition cmonoidal_unit_noncurried_hom (M N : ob UMONCAT) : nat_trans (functor_identity (hom M N)) (cmonoidal_to_noncurried_hom M N ∙ cmonoidal_from_noncurried_hom M N) := _ ,, cmonoidal_unit_noncurried_hom_is_nat_trans M N. Definition cmonoidal_counit_noncurried_hom_data (M N : ob UMONCAT) : nat_trans_data (cmonoidal_from_noncurried_hom M N ∙ cmonoidal_to_noncurried_hom M N) (functor_identity (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)))). Proof. intro F. use tpair. - exists (nat_trans_id _). split. + intros x y. simpl ; rewrite id_right ; cbn. etrans. { apply maponpaths_2. etrans. { apply (! tensor_on_hom_eq N _ _). } apply tensor_id. } apply id_left. + apply id_right. - repeat (use tpair) ; exact tt. Defined. Definition cmonoidal_counit_noncurried_hom_is_nat_trans (M N : ob UMONCAT) : is_nat_trans _ _ (cmonoidal_counit_noncurried_hom_data M N). Proof. intro ; intros. use LaxMonoidalFunctor_mor_equality. intro. exact (id_right _ @ ! id_left _). Qed. Definition cmonoidal_counit_noncurried_hom (M N : ob UMONCAT) : nat_trans (cmonoidal_from_noncurried_hom M N ∙ cmonoidal_to_noncurried_hom M N) (functor_identity (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M)) (pr1 (cmonoidal_to_noncurriedmonoidal N)))) := _ ,, cmonoidal_counit_noncurried_hom_is_nat_trans M N. Definition cmonoidal_formadjunction_noncurried (M N : ob UMONCAT) : form_adjunction _ _ (cmonoidal_unit_noncurried_hom M N) (cmonoidal_counit_noncurried_hom M N). Proof. split. - intro ; intros. apply LaxMonoidalFunctor_mor_equality ; intro ; apply id_left. - intro ; intros. apply UMONCAT_2cell_equality ; intro ; apply id_left. Qed. Definition cmonoidal_formequivalence_noncurried (M N : ob UMONCAT) : forms_equivalence (cmonoidal_to_noncurried_hom M N ,, cmonoidal_from_noncurried_hom M N,, cmonoidal_unit_noncurried_hom M N,, cmonoidal_counit_noncurried_hom M N). Proof. split ; intro. - use tpair. + repeat (use tpair). * apply nat_trans_id. * apply nat_trans_id. * intros x y. simpl. rewrite id_right. etrans. 2: { apply maponpaths_2. apply (! tensor_id _ _ _). } apply (! id_left _). * apply id_right. * exact tt. * exact tt. * exact tt. * exact tt. + split ; apply UMONCAT_2cell_equality ; intro ; apply id_right. - use tpair. + repeat (use tpair). * apply nat_trans_id. * apply nat_trans_id. * intros x y. simpl. rewrite id_right. etrans. { apply maponpaths_2. apply (! tensor_on_hom_eq N _ _). } etrans. { apply maponpaths_2. apply (tensor_id _ _ _). } apply id_left. * apply id_right. * exact tt. * exact tt. * exact tt. + split. * apply LaxMonoidalFunctor_mor_equality. intro ; apply id_right. * apply LaxMonoidalFunctor_mor_equality. intro ; apply id_right. Defined. Definition cmonoidal_adjequiv_noncurried_hom (M N : ob UMONCAT) : adj_equivalence_of_cats (cmonoidal_to_noncurried_hom M N). Proof. use make_adj_equivalence_of_cats. - exact (cmonoidal_from_noncurried_hom M N). - exact (cmonoidal_unit_noncurried_hom M N). - exact (cmonoidal_counit_noncurried_hom M N). - exact (cmonoidal_formadjunction_noncurried M N). - exact (cmonoidal_formequivalence_noncurried M N). Defined. End EquivalenceMonCatNonCurriedLaxFunctors. *) EquivalenceWhiskeredCurried.v000066400000000000000000000431441451125700300337620ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCatRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesReordered. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Import BifunctorNotations. Section TensorEquivalence. Local Definition ctensor (C : category) := CurriedMonoidalCategories.tensor C. Identity Coercion ctensor_to_tensor: ctensor >-> CurriedMonoidalCategories.tensor. Local Definition wtensor (C : category) := bifunctor C C C. Identity Coercion wtensor_to_tensor: wtensor >-> bifunctor. Context {C : category}. Definition wtensor_to_ctensor (T : wtensor C) : ctensor C. Proof. repeat (use tpair). - apply T. - intros x1 x2 y1 y2 f g. exact (f ⊗^{T} g). - intros x y. apply (bifunctor_distributes_over_id (C := C) (bifunctor_leftid T) (bifunctor_rightid T) ). - intros x1 x2 x3 y1 y2 y3 f1 f2 g1 g2. apply (bifunctor_distributes_over_comp (C := C) (bifunctor_leftcomp T) (bifunctor_rightcomp T) (bifunctor_equalwhiskers T) ). Defined. Definition ctensor_to_wtensor (T : ctensor C) : wtensor C. Proof. repeat (use tpair). - apply T. - intros x ? ? g. exact ((tensor_on_hom (pr1 T)) _ _ _ _ (identity x) g). - intros y ? ? f. exact ((tensor_on_hom (pr1 T)) _ _ _ _ f (identity y)). - intro ; intro. apply tensor_id. - intro ; intro. apply tensor_id. - intro ; intros. use pathscomp0. 3: apply tensor_comp. rewrite id_right. apply idpath. - intro ; intros. use pathscomp0. 3: apply tensor_comp. rewrite id_right. apply idpath. - intros ? ? ? ? f g. use pathscomp0. 3: apply tensor_comp. rewrite id_right. rewrite id_left. etrans. { apply (! tensor_comp _ _ _ _ _ _ _ _ _ _ _). } rewrite id_right. apply maponpaths. apply id_left. Defined. (* Lemma transport_of_right_partial_bifunctor_map_is_pointwise {F0 G0 : ob C -> ob C -> ob C} (F1 : ∏ y x1 x2 : ob C, C⟦x1,x2⟧ -> C⟦F0 x1 y, F0 x2 y⟧) (gamma : F0 = G0) {x1 x2 : ob C} (y : C) (f : C⟦x1,x2⟧) : transportf (fun T : C -> C -> C => ∏ b a1 a2 : C, C⟦a1,a2⟧ -> C⟦T a1 b, T a2 b⟧) gamma F1 y x1 x2 f = double_transport (toforallpaths (λ _ : ob C, C) (F0 x1) (G0 x1) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x1) y) (toforallpaths (λ _ : ob C, C) (F0 x2) (G0 x2) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x2) y) (F1 _ _ _ f). Proof. induction gamma. apply idpath. Qed. Lemma transport_of_left_partial_bifunctor_map_is_pointwise {F0 G0 : ob C -> ob C -> ob C} (F1 : ∏ x y1 y2 : ob C, C⟦y1,y2⟧ -> C⟦F0 x y1, F0 x y2⟧) (gamma : F0 = G0) {y1 y2 : ob C} (x : C) (g : C⟦y1,y2⟧) : transportf (fun T : C -> C -> C => ∏ a b1 b2 : C, C⟦b1,b2⟧ -> C⟦T a b1, T a b2⟧) gamma F1 x y1 y2 g = double_transport (toforallpaths (λ _ : ob C, C) (F0 x) (G0 x) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x) y1) (toforallpaths (λ _ : ob C, C) (F0 x) (G0 x) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x) y2) (F1 x y1 y2 g). Proof. induction gamma. apply idpath. Qed. *) Definition w_c_wtensor (T : wtensor C) : ctensor_to_wtensor (wtensor_to_ctensor T) = T. Proof. repeat (use total2_paths_f) ; try (repeat (apply impred_isaprop ; intro) ; apply homset_property). - apply idpath. - abstract (rewrite idpath_transportf ; repeat (apply funextsec ; intro) ; simpl ; unfold functoronmorphisms1 ; rewrite bifunctor_rightid ; apply id_left). - rewrite pr2_transportf. rewrite (idpath_transportf ((λ a : C → C → C, ∏ b a1 a2 : C, C ⟦ a1, a2 ⟧ → C ⟦ a a1 b, a a2 b ⟧))). repeat (apply funextsec ; intro). rewrite transportf_const. simpl. unfold functoronmorphisms1. rewrite bifunctor_leftid. apply id_right. Qed. Definition c_w_ctensor (T : ctensor C) : wtensor_to_ctensor (ctensor_to_wtensor T) = T. Proof. repeat (use total2_paths_f). - apply idpath. - rewrite idpath_transportf. repeat (apply funextsec ; intro). refine ((! pr22 T _ _ _ _ _ _ _ _ _ _) @ _). rewrite id_right. apply maponpaths. apply id_left. - repeat (apply impred_isaprop ; intro). apply homset_property. - repeat (apply impred_isaprop ; intro). apply homset_property. Qed. Definition tensor_equivalence : ctensor C ≃ wtensor C. Proof. use weq_iso. - apply ctensor_to_wtensor. - apply wtensor_to_ctensor. - intro. apply c_w_ctensor. - intro. apply w_c_wtensor. Defined. End TensorEquivalence. Section MonoidalCategoryEquivalence. Definition tensor_unit_equivalence (C : category) : CurriedMonoidalCategories.tensor_unit C ≃ MonoidalCategoriesReordered.tensor_unit C. Proof. apply weqtotal2. - apply tensor_equivalence. - intro. apply idweq. Defined. Definition tensor_unit_unitors_associator_equivalence (C : category) : CurriedMonoidalCategories.tensor_unit_unitors_associator C ≃ MonoidalCategoriesReordered.tensor_unit_unitors_associator C. Proof. use weqtotal2. { exact (tensor_unit_equivalence C). } intro tu. repeat (use weqdirprodf) ; apply idweq. use weqtotal2. { apply idweq. } intro α. apply weqimplimpl. - intro αnat. repeat split. + intros x y z1 z2 h. refine (αnat x x y y z1 z2 (identity x) (identity y) h @ _). apply cancel_postcomposition. rewrite tensor_id. apply idpath. + intros x1 x2 y z f. refine (_ @ αnat x1 x2 y y z z f (identity y) (identity z)). apply cancel_precomposition. rewrite tensor_id. apply idpath. + intros x y1 y2 z g. apply (αnat x x y1 y2 z z (identity x) g (identity z)). - intro αnat. intro ; intros. etrans. { apply maponpaths. etrans. { etrans. { apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. exact (!(id_right _)). } apply tensor_comp. } apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths_2. exact (!(id_left _)). } etrans. { apply maponpaths. exact (!(id_right _)). } apply tensor_comp. } etrans. { apply maponpaths_2. exact (!(id_left _)). } apply tensor_comp. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. exact (pr1 αnat x y z z' h). } cbn. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply (pr22 αnat x y y' z' g). } cbn. rewrite !assoc'. apply maponpaths. apply (pr12 αnat x x' y' z' f). } cbn. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp. } etrans. { refine (!_). apply tensor_comp. } rewrite !id_left, !id_right. apply maponpaths_2. etrans. { refine (!_). apply tensor_comp. } rewrite id_left, id_right. apply idpath. - repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply homset_property. - repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply homset_property. Defined. Lemma isaprop_lax_monoidal_leftunitor_inverse {C : category} (luua : MonoidalCategoriesReordered.tensor_unit_unitors_associator C) : isaprop (lax_monoidal_leftunitor_inverse luua). Proof. apply isaproptotal2. { intro. apply impred_isaprop ; intro. apply Isos.isaprop_is_inverse_in_precat. } intros lui0 lui1 l0 l1. apply funextsec ; intro. use Isos.inverse_unique_precat. - apply luua. - apply l0. - apply l1. Defined. Lemma isaprop_lax_monoidal_rightunitor_inverse {C : category} (luua : MonoidalCategoriesReordered.tensor_unit_unitors_associator C) : isaprop (lax_monoidal_rightunitor_inverse luua). Proof. apply isaproptotal2. { intro. apply impred_isaprop ; intro. apply Isos.isaprop_is_inverse_in_precat. } intros lui0 lui1 l0 l1. apply funextsec ; intro. use Isos.inverse_unique_precat. - apply luua. - apply l0. - apply l1. Defined. Lemma isaprop_lax_monoidal_associator_inverse {C : category} (luua : MonoidalCategoriesReordered.tensor_unit_unitors_associator C) : isaprop (lax_monoidal_associator_inverse luua). Proof. apply isaproptotal2. { intro. repeat (apply impred_isaprop ; intro). apply Isos.isaprop_is_inverse_in_precat. } intros lui0 lui1 l0 l1. repeat (apply funextsec ; intro). use Isos.inverse_unique_precat. - apply luua. - apply l0. - apply l1. Defined. Definition cmon_equiv_monreordered (C : category) : CurriedMonoidalCategories.mon_structure C ≃ MonoidalCategoriesReordered.monoidal_struct C. Proof. use weqtotal2. { apply tensor_unit_unitors_associator_equivalence. } intro. repeat (apply weqdirprodf). - apply weqimplimpl ; try (intro ; assumption) ; (try apply isaprop_triangle). - apply weqimplimpl ; try (intro ; assumption) ; (try apply isaprop_pentagon). - use weq_iso. + intro lui. exists (λ c, pr1 (lui c)). intro ; apply lui. + intro lui. intro c. exists ((pr1 lui) c). apply ((pr2 lui) c). + intro ; apply isaprop_lunitor_invertible. + intro ; apply isaprop_lax_monoidal_leftunitor_inverse. - use weq_iso. + intro rui. exists (λ c, pr1 (rui c)). intro ; apply rui. + intro rui. intro c. exists ((pr1 rui) c). apply ((pr2 rui) c). + intro ; apply isaprop_runitor_invertible. + intro ; apply isaprop_lax_monoidal_rightunitor_inverse. - use weq_iso. + intro ai. exists (λ c1 c2 c3, pr1 (ai c1 c2 c3)). intro ; apply ai. + intro ai. intros c1 c2 c3. exists ((pr1 ai) c1 c2 c3). apply ((pr2 ai) c1 c2 c3). + intro ; apply isaprop_associator_invertible. + intro ; apply isaprop_lax_monoidal_associator_inverse. Defined. Definition cmonoidal_to_cmonoidalreordered {C : category} (M : CurriedMonoidalCategories.mon_structure C) : MonoidalCategoriesReordered.monoidal_struct C := cmon_equiv_monreordered C M. Definition cmonoidal_to_cmonoidalReordered {C : category} (M : MonoidalCategoriesReordered.monoidal_struct C) : CurriedMonoidalCategories.mon_structure C := invmap (cmon_equiv_monreordered C) M. Definition cmon_equiv_wmon (C : category) : CurriedMonoidalCategories.mon_structure C ≃ monoidal C := (monoidal_struct_equiv_monoidal C ∘ cmon_equiv_monreordered C)%weq. Definition cmonoidal_to_wmonoidal {C : category} (M : CurriedMonoidalCategories.mon_structure C) : monoidal C := cmon_equiv_wmon C M. Definition wmonoidal_to_cmonoidal {C : category} (M : monoidal C) : CurriedMonoidalCategories.mon_structure C := invmap (cmon_equiv_wmon C) M. End MonoidalCategoryEquivalence. Section MonoidalFunctorEquivalence. Context {C D : category} (F : functor C D) (MC : CurriedMonoidalCategories.mon_structure C) (MD : CurriedMonoidalCategories.mon_structure D). Definition cmonfunctor : UU := CurriedMonoidalCategories.functor_lax_monoidal F MC MD. Definition wmonfunctordata : UU := fmonoidal_data (cmonoidal_to_wmonoidal MC) (cmonoidal_to_wmonoidal MD) F. Definition wmonfunctorlaws (MF : wmonfunctordata) := fmonoidal_laxlaws MF. Definition wmonfunctor : UU := fmonoidal_lax (cmonoidal_to_wmonoidal MC) (cmonoidal_to_wmonoidal MD) F. Definition cmonfunctor_to_wmonfunctordata : cmonfunctor -> wmonfunctordata. Proof. intro cmf. split; red; intros; apply cmf. Defined. Definition cmonfunctor_to_wmonfunctorlaws (cmf : cmonfunctor) : wmonfunctorlaws (cmonfunctor_to_wmonfunctordata cmf). Proof. split. - intros x y1 y2 g. etrans. 2: { apply pathsinv0. exact ((pr211 cmf) x x y1 y2 (identity x) g). } unfold leftwhiskering_on_morphisms. cbn. do 2 apply maponpaths_2. apply (! functor_id F x). - split. + intros x1 x2 y f. etrans. 2: { apply pathsinv0. exact (pr211 cmf x1 x2 y y f (identity y)). } unfold rightwhiskering_on_morphisms. cbn. apply maponpaths_2. apply maponpaths. apply (! functor_id F y). + repeat split; red; intros; apply (pr2 cmf). Qed. Definition cmonfunctor_to_wmonfunctor : cmonfunctor -> wmonfunctor := (λ cmf, cmonfunctor_to_wmonfunctordata cmf ,, cmonfunctor_to_wmonfunctorlaws cmf). Definition wmonfunctor_to_cmontensorunitfunctor : wmonfunctor -> functor_tensor_unit MC MD F. Proof. intro wmf. split. - exists (pr11 wmf). intros x1 x2 y1 y2 f g. assert (p0 : #F (tensor_on_hom MC _ _ _ _ f g) = #F (tensor_on_hom MC _ _ _ _ f (identity y1)) · #F (tensor_on_hom MC _ _ _ _ (identity x2) g)). { etrans. 2: { apply functor_comp. } apply maponpaths. refine (_ @ tensor_comp _ _ _ _ _ _ _ f (identity x2) (identity y1) g). etrans. 2: { apply maponpaths_2 ; apply (! id_right _). } apply maponpaths ; apply (! id_left _). } etrans. { apply maponpaths ; apply p0. } etrans. { apply assoc. } etrans. { apply maponpaths_2 ; apply (! pr122 wmf x1 x2 y1 f). } etrans. { apply assoc'. } etrans. { apply maponpaths ; apply (! pr12 wmf x2 y1 y2 g). } etrans. { apply assoc. } apply maponpaths_2. etrans. 2: { do 2 apply maponpaths. apply id_left. } etrans. 2: { apply maponpaths_2. apply maponpaths. apply id_right. } etrans. 2: { apply maponpaths. apply (! functor_comp _ _ _). } etrans. 2: { apply maponpaths_2. apply (! functor_comp _ _ _). } refine (_ @ ! tensor_comp _ _ _ _ _ _ _ _ _ _ _). etrans. 2: { apply maponpaths. apply maponpaths_2. apply (! functor_id _ _). } apply maponpaths_2. etrans. 2: { apply maponpaths. apply (! functor_id _ _). } apply idpath. - exact (pr21 wmf). Defined. Definition wmonfunctor_to_cmonfunctor : wmonfunctor -> cmonfunctor. Proof. intro wmf. exists (wmonfunctor_to_cmontensorunitfunctor wmf). repeat split ; apply (pr2 wmf). Defined. Lemma cwcmf (cmf : cmonfunctor) : wmonfunctor_to_cmonfunctor (cmonfunctor_to_wmonfunctor cmf) = cmf. Proof. repeat (use total2_paths_f) ; try (apply idpath) ; try (repeat (apply funextsec ; intro) ; apply homset_property). rewrite transportf_const. apply idpath. Qed. Lemma wcwmf (cmf : wmonfunctor) : cmonfunctor_to_wmonfunctor (wmonfunctor_to_cmonfunctor cmf) = cmf. Proof. repeat (use total2_paths_f) ; try (apply idpath) ; try (repeat (apply funextsec ; intro) ; apply homset_property). Qed. Definition cmonfunctor_equiv_wmonfunctor : cmonfunctor ≃ wmonfunctor. Proof. use weq_iso. - apply cmonfunctor_to_wmonfunctor. - apply wmonfunctor_to_cmonfunctor. - intro ; apply cwcmf. - intro ; apply wcwmf. Defined. End MonoidalFunctorEquivalence. Section StrongMonoidalFunctorEquivalence. Context {C D : category} (F : functor C D) (MC : CurriedMonoidalCategories.mon_structure C) (MD : CurriedMonoidalCategories.mon_structure D). Definition csmonfunctor : UU := CurriedMonoidalCategories.functor_strong_monoidal F MC MD. Definition wsmonfunctor : UU := fmonoidal (cmonoidal_to_wmonoidal MC) (cmonoidal_to_wmonoidal MD) F. Definition csmonfunctor_equiv_wsmonfunctor : csmonfunctor ≃ wsmonfunctor. Proof. unfold csmonfunctor ; unfold wsmonfunctor. unfold functor_strong_monoidal ; unfold fmonoidal. use weqtotal2. { apply cmonfunctor_equiv_wmonfunctor. } intro cmf. apply weqimplimpl. - intro csmf. split. + do 2 intro. apply (pr2 csmf). + apply (pr1 csmf). - intro csmf. split. + apply (pr2 csmf). + do 2 intro ; apply (pr1 csmf). - apply isaprop_functor_strong. - apply isapropdirprod ; repeat (apply impred_isaprop ; intro) ; apply Isos.isaprop_is_z_isomorphism. Defined. End StrongMonoidalFunctorEquivalence. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/FinalLayer.v000066400000000000000000000310371451125700300304400ustar00rootroot00000000000000(* This is the last file which concludes that the bicategory of univalent monoidal categories is again univalent. In this file we conclude that both the bicategory of univalent monoidal categories with lax monoidal functors, denoted by UMONCAT, is univalent and that the result still holds when we replace lax by strong monoidal functors, we denote this bicategory by UMONCAT_strong. *) Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.UnitLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorUnitLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Import Bicat.Notations. Import AssociatorUnitorsNotations. Local Definition bicat_univlaxmon_noprop : bicat := total_bicat disp_tensor_unit_unitors_associator. Section MonoidalCategoryLayer. Definition P_triangle_pentagon : bicat_univlaxmon_noprop -> UU := λ C, triangle_pentagon (pr2 (assunitors_from_layer (uc (pr1 C,, pr12 C)) (pr2 C))). Definition P_assinv : bicat_univlaxmon_noprop -> UU := λ C, associator_invertible (pr2 (assunitors_from_layer (pr1 C) (pr2 C))). Definition P_luinv : bicat_univlaxmon_noprop -> UU := λ C, lunitor_invertible (pr2 (assunitors_from_layer (pr1 C) (pr2 C))). Definition P_ruinv : bicat_univlaxmon_noprop -> UU := λ C, runitor_invertible (pr2 (assunitors_from_layer (pr1 C) (pr2 C))). Definition P_inv : bicat_univlaxmon_noprop -> UU := λ C, P_assinv C × P_luinv C × P_ruinv C. Definition P_prop : bicat_univlaxmon_noprop -> UU := λ C, P_triangle_pentagon C × P_inv C. Lemma isaprop_P_prop (C : bicat_univlaxmon_noprop) : isaprop (P_prop C). Proof. repeat (apply isapropdirprod). - apply isaprop_triangle. - apply isaprop_pentagon. - apply isaprop_associator_invertible. - apply isaprop_lunitor_invertible. - apply isaprop_runitor_invertible. Qed. Definition disp_bicat_univmon : disp_bicat bicat_univlaxmon_noprop := disp_fullsubbicat bicat_univlaxmon_noprop P_prop. Lemma disp_bicat_tripent_is_univalent_2 : disp_univalent_2 disp_bicat_univmon. Proof. split. - apply disp_univalent_2_0_fullsubbicat. + apply bidisp_assunitors_is_univalent_2. + intro ; apply isaprop_P_prop. - apply disp_fullsubbicat_univalent_2_1. Qed. Definition disp_univmon : disp_bicat bicat_of_univ_cats := sigma_bicat _ _ disp_bicat_univmon. Definition disp_univmon_is_univalent_2 : disp_univalent_2 disp_univmon. Proof. apply sigma_disp_univalent_2_with_props. - apply univalent_cat_is_univalent_2. - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2. - apply disp_fullsubbicat_univalent_2_1. - apply disp_tensor_unit_unitors_associator_disp_locally_groupoid. - apply disp_locally_groupoid_fullsubbicat. - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2. - apply disp_bicat_tripent_is_univalent_2. Qed. Lemma disp_univmon_disp_2cells_isaprop : disp_2cells_isaprop disp_univmon. Proof. apply disp_2cells_isaprop_sigma. + apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop. + apply disp_2cells_isaprop_fullsubbicat. Qed. Lemma disp_univmon_disp_locally_groupoid : disp_locally_groupoid disp_univmon. Proof. apply disp_locally_groupoid_sigma. - apply univalent_cat_is_univalent_2. - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop. - apply disp_2cells_isaprop_fullsubbicat. - apply disp_tensor_unit_unitors_associator_disp_locally_groupoid. - apply disp_locally_groupoid_fullsubbicat. Qed. (* UMONCAT is the bicategory defined as follows: - Objects: Monoidal categories (over univalent categories). - Morphisms: Lax monoidal functors. - 2-cells: Monoidal natural transformations. This bicategory is constructed precisely such that we are able to carry out a modular proof of univalence, as seen in UMONCAT_is_univalent_2. *) Definition UMONCAT : bicat := total_bicat disp_univmon. Definition UMONCAT_is_univalent_2 : is_univalent_2 UMONCAT. Proof. apply total_is_univalent_2. - apply disp_univmon_is_univalent_2. - apply univalent_cat_is_univalent_2. Qed. Definition UMONCAT_category (C : UMONCAT) : univalent_category := pr1 C. Definition UMONCAT_tensorunit (C : UMONCAT) : tensor_unit (UMONCAT_category C) := (pr112 C). Definition UMONCAT_tensor (C : UMONCAT) : tensor (UMONCAT_category C) := pr1 (UMONCAT_tensorunit C). Definition UMONCAT_unit (C : UMONCAT) : UMONCAT_category C := pr2 (UMONCAT_tensorunit C). Definition UMONCAT_lunitor (C : UMONCAT) : CurriedMonoidalCategories.lunitor (UMONCAT_tensorunit C) := pr11 (pr212 C). Definition UMONCAT_runitor (C : UMONCAT) : CurriedMonoidalCategories.runitor (UMONCAT_tensorunit C) := (pr21 (pr212 C)). Definition UMONCAT_associator (C : UMONCAT) : CurriedMonoidalCategories.associator (UMONCAT_tensorunit C) := (pr2 (pr212 C)). Definition UMONCAT_unitorsassociator (C : UMONCAT) : unitors_associator (UMONCAT_tensorunit C) := UMONCAT_lunitor C ,, UMONCAT_runitor C ,, UMONCAT_associator C. Definition UMONCAT_functor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : functor (UMONCAT_category C) (UMONCAT_category D) := pr1 F. Definition UMONCAT_functortensorunit {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : functor_tensor_unit (UMONCAT_tensorunit C) (UMONCAT_tensorunit D) (UMONCAT_functor F) := (pr112 F). Definition UMONCAT_functortensor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : preserves_tensor (UMONCAT_tensor C) (UMONCAT_tensor D) (UMONCAT_functor F) := pr1 (UMONCAT_functortensorunit F). Definition UMONCAT_functorunit {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : preserves_unit (UMONCAT_unit C) (UMONCAT_unit D) (UMONCAT_functor F) := pr2 (UMONCAT_functortensorunit F). Definition UMONCAT_functorlunitor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : preserves_lunitor (UMONCAT_functortensorunit F) (UMONCAT_lunitor C) (UMONCAT_lunitor D) := pr11 (pr212 F). Definition UMONCAT_functorrunitor {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : preserves_runitor (UMONCAT_functortensorunit F) (UMONCAT_runitor C) (UMONCAT_runitor D) := pr21 (pr212 F). Definition UMONCAT_functorassociator {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : preserves_associator (UMONCAT_functortensorunit F) (UMONCAT_associator C) (UMONCAT_associator D) := pr2 (pr212 F). Definition UMONCAT_functorunitorsassociator {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : functor_unitors_associator (UMONCAT_unitorsassociator C) (UMONCAT_unitorsassociator D) (UMONCAT_functortensorunit F) := UMONCAT_functorlunitor F ,, UMONCAT_functorrunitor F ,, UMONCAT_functorassociator F. End MonoidalCategoryLayer. Module UMONCAT_Notations. Notation "cat( C )" := (UMONCAT_category C). Notation "tensor( C )" := (UMONCAT_tensor C). Notation "unit( C )" := (UMONCAT_unit C). Notation "lunitor( C )" := (UMONCAT_lunitor C). Notation "runitor( C )" := (UMONCAT_runitor C). Notation "associator( C )" := (UMONCAT_associator C). Notation "functor( F )" := (UMONCAT_functor F). Notation "functortensorunit( F )" := (UMONCAT_functortensorunit F). Notation "functortensor( F )" := (UMONCAT_functortensor F). Notation "functorunit( F )" := (UMONCAT_functorunit F). Notation "functorunitorsassociator( F )" := (UMONCAT_functorunitorsassociator F). Notation "functorlunitor( F )" := (UMONCAT_functorlunitor F). Notation "functorrunitor( F )" := (UMONCAT_functorrunitor F). Notation "functorassociator( F )" := (UMONCAT_functorassociator F). End UMONCAT_Notations. Section StrongLayer. Import UMONCAT_Notations. Import Bicat.Notations. Definition P_strong_preserving : ∏ (C D : UMONCAT), UMONCAT⟦C,D⟧ -> UU := λ _ _ F, functor_strong functorunitorsassociator(F). Lemma isaprop_P_strong_preserving {C D : UMONCAT} (F : UMONCAT⟦C,D⟧) : isaprop (P_strong_preserving C D F). Proof. apply isapropdirprod. - apply isaprop_is_z_isomorphism. - repeat (apply impred_isaprop ; intro). apply isaprop_is_z_isomorphism. Qed. Definition Pid_strong_preserving : ∏ (C : UMONCAT), P_strong_preserving _ _ (id₁ C). Proof. intro C. use tpair. - apply identity_is_z_iso. - intro ; intro. apply identity_is_z_iso. Defined. Definition Pcomp_strong_preserving : ∏ (C D E : UMONCAT) (F : UMONCAT⟦C,D⟧) (G : UMONCAT⟦D,E⟧), P_strong_preserving _ _ F → P_strong_preserving _ _ G -> P_strong_preserving _ _ (F·G). Proof. intros C D E F G sF sG. use tpair. - apply is_z_isomorphism_comp. + apply sG. + apply functor_on_is_z_isomorphism. apply sF. - intro ; intro. apply is_z_isomorphism_comp. + apply sG. + simpl. apply functor_on_is_z_isomorphism. apply sF. Defined. Definition disp_bicat_univstrongfunctor : disp_bicat UMONCAT := disp_sub1cell_bicat UMONCAT P_strong_preserving Pid_strong_preserving Pcomp_strong_preserving. Definition disp_bicat_univstrongfunctor_is_univalent_2 : disp_univalent_2 disp_bicat_univstrongfunctor. Proof. apply disp_sub1cell_univalent_2. - apply UMONCAT_is_univalent_2. - intro ; intros. apply isaprop_P_strong_preserving. Qed. Definition disp_univstrongfunctor : disp_bicat bicat_of_univ_cats := sigma_bicat _ _ disp_bicat_univstrongfunctor. Lemma disp_univstrongfunctor_disp_2cells_isaprop : disp_2cells_isaprop disp_bicat_univstrongfunctor. Proof. apply disp_2cells_isaprop_sub1cell_bicat. Qed. Lemma disp_univstrongfunctor_disp_locally_groupoid : disp_locally_groupoid disp_bicat_univstrongfunctor. Proof. apply disp_locally_groupoid_sub1cell_bicat. Qed. Definition disp_univstrongfunctor_is_univalent_2 : disp_univalent_2 disp_univstrongfunctor. Proof. apply sigma_disp_univalent_2_with_props ; try (apply disp_univmon_is_univalent_2). - apply univalent_cat_is_univalent_2. - apply disp_univmon_disp_2cells_isaprop. - apply disp_univstrongfunctor_disp_2cells_isaprop. - apply disp_sub1cell_univalent_2. + apply UMONCAT_is_univalent_2. + intro ; intros ; apply isaprop_P_strong_preserving. - apply disp_univmon_disp_locally_groupoid. - apply disp_univstrongfunctor_disp_locally_groupoid. - apply disp_bicat_univstrongfunctor_is_univalent_2. Qed. (* UMONCAT_strong is the bicategory defined as follows: - Objects: Monoidal categories (over univalent categories). - Morphisms: Strong monoidal functors (not requiring any functorial strength). - 2-cells: Monoidal natural transformations. This bicategory is constructed precisely such that we are able to carry out a modular proof of univalence, as seen in UMONCAT_strong_is_univalent_2. *) Definition UMONCAT_strong : bicat := total_bicat disp_univstrongfunctor. Definition UMONCAT_strong_is_univalent_2 : is_univalent_2 UMONCAT_strong. Proof. apply total_is_univalent_2. - apply disp_univstrongfunctor_is_univalent_2. - apply univalent_cat_is_univalent_2. Qed. End StrongLayer. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/TensorLayer.v000066400000000000000000001065421451125700300306650ustar00rootroot00000000000000(* This is the second of a sequence of files with the purpose of showing that the bicategory of univalent monoidal categories is again univalent. In this file we construct one side of the first displayed layer above the bicategory of univalent categories, more precisely: The total category corresponding to this displayed layer is the univalent bicategory defined as follows: - The objects are categories together with a binary operation (which will be the tensor product for the monoidal structure). - The morphisms are functors which preserve the tensor in a lax/weak sense (i.e. a non-necessarily isomorphic morphism). - The 2-cells are natural transformations which (at tensor products) commute the tensor-preserving morphisms. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Local Open Scope cat. Local Open Scope mor_disp_scope. Import TensorNotation. Section TensorLayer. Import TensorNotation. Definition disp_tensor_disp_ob_mor : disp_cat_ob_mor bicat_of_univ_cats. Proof. exists (λ C, tensor (C : univalent_category)). exact (λ C D TC TD F, preserves_tensor TC TD F). Defined. Definition disp_tensor_disp_id_comp : disp_cat_id_comp bicat_of_univ_cats disp_tensor_disp_ob_mor. Proof. split. - intros C TC. apply identityfunctor_preserves_tensor. - intros C D E F G TC TD TE. apply compositions_preserves_tensor. Defined. Definition disp_tensor_disp_catdata : disp_cat_data bicat_of_univ_cats := (disp_tensor_disp_ob_mor,,disp_tensor_disp_id_comp). Definition bidisp_tensor_disp_2cell_struct : disp_2cell_struct disp_tensor_disp_ob_mor. Proof. intros C D F G α TC TD. exact (λ ptF ptG, preservestensor_commutes (pr1 ptF) (pr1 ptG) α). Defined. Lemma isaprop_bidisp_tensor_disp_2cell_struct {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats ⟦C,D⟧ } {α : prebicat_cells bicat_of_univ_cats F G} {TC : disp_tensor_disp_catdata C} {TD : disp_tensor_disp_catdata D} (ptF : TC -->[ F] TD) (ptG : TC -->[ G] TD) : isaprop (bidisp_tensor_disp_2cell_struct C D F G α TC TD ptF ptG). Proof. apply isaprop_preservestensor_commutes. Qed. Definition bidisp_tensor_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats := (disp_tensor_disp_catdata,, bidisp_tensor_disp_2cell_struct). Definition bidisp_tensor_disp_prebicat_ops : disp_prebicat_ops bidisp_tensor_disp_prebicat_1_id_comp_cells. Proof. repeat split. - intros C D F TC TD ptF. apply identitynattrans_preservestensor_commutes. - intros C D F TC TD ptF. intros x y. rewrite id_right. simpl. rewrite tensor_id. rewrite id_left. unfold identityfunctor_preserves_tensor_data. unfold compositions_preserves_tensor_data. rewrite functor_id. apply id_right. - intros C D F TC TD ptF. intros x y. rewrite id_right. cbn. unfold compositions_preserves_tensor_data. unfold identityfunctor_preserves_tensor_data. rewrite id_left. simpl. rewrite tensor_id. rewrite id_left. apply idpath. - intros C D F TC TD ptF. intros x y. rewrite id_right. simpl. rewrite tensor_id. rewrite id_left. cbn. unfold compositions_preserves_tensor_data. cbn. unfold identityfunctor_preserves_tensor_data. rewrite functor_id. rewrite id_right. apply idpath. - intros C D F TC TD ptF. intros x y. rewrite id_right. cbn. rewrite tensor_id. unfold compositions_preserves_tensor_data. unfold identityfunctor_preserves_tensor_data. simpl. rewrite id_left. rewrite id_left. apply idpath. - intros C D E W F G H TC TD TE TW ptF ptG ptH. intros x y. simpl. rewrite id_right. rewrite tensor_id. rewrite id_left. cbn. unfold compositions_preserves_tensor_data. cbn. rewrite assoc'. rewrite functor_comp. apply idpath. - intros C D E W F G H TC TD TE TW ptF ptG ptH. intros x y. simpl. rewrite id_right. rewrite tensor_id. rewrite id_left. cbn. unfold compositions_preserves_tensor_data. cbn. rewrite assoc'. rewrite functor_comp. apply idpath. - intros C D F G H α β TC TD ptF ptG ptH ptcα ptcβ. intros x y. simpl. rewrite assoc. rewrite ptcα. rewrite assoc'. rewrite ptcβ. rewrite assoc. rewrite tensor_comp. apply idpath. - intros C D E F G H α TC TD TE ptF ptG ptH ptcα. intros x y. cbn. unfold compositions_preserves_tensor_data. rewrite assoc'. rewrite (pr2 α). rewrite assoc. rewrite ptcα. rewrite assoc. apply idpath. - intros C D E F G H α TC TD TE ptF ptG ptH ptcα. intros x y. cbn. unfold compositions_preserves_tensor_data. rewrite assoc'. etrans. { apply maponpaths. apply (pathsinv0 (functor_comp _ _ _)). } etrans. { do 2 apply maponpaths. apply ptcα. } rewrite assoc. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. etrans. { apply (pr2 ptH). } apply maponpaths. apply idpath. Defined. Definition bidisp_tensor_disp_prebicat_data : disp_prebicat_data bicat_of_univ_cats := (bidisp_tensor_disp_prebicat_1_id_comp_cells,, bidisp_tensor_disp_prebicat_ops). Definition bidisp_tensor_disp_prebicat_laws : disp_prebicat_laws bidisp_tensor_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_tensor_disp_2cell_struct. Qed. Definition bidisp_tensor_disp_prebicat : disp_prebicat bicat_of_univ_cats := (bidisp_tensor_disp_prebicat_data,,bidisp_tensor_disp_prebicat_laws). Definition bidisp_tensor_disp_bicat : disp_bicat bicat_of_univ_cats. Proof. refine (bidisp_tensor_disp_prebicat,, _). intros C D F G α TC TD ptF ptG. apply isasetaprop. unfold disp_2cells. unfold bidisp_tensor_disp_prebicat. simpl. unfold bidisp_tensor_disp_2cell_struct. unfold preservestensor_commutes. repeat (apply impred_isaprop ; intro). apply univalent_category_has_homsets. Defined. (** We now show that this displayed bicategory is locally univalent *) Definition disp_inv_to_eq1 {C D : bicat_of_univ_cats} {F : bicat_of_univ_cats⟦C,D⟧} {TC : bidisp_tensor_disp_bicat C} {TD : bidisp_tensor_disp_bicat D} (ptF ptG : TC -->[F] TD) : disp_invertible_2cell (id2_invertible_2cell F) ptF ptG -> pr1 ptF = pr1 ptG. Proof. intro i. apply funextsec ; intro ; apply funextsec ; intro. set (ix := (pr1 i) x x0). cbn in ix. rewrite id_right in ix. rewrite tensor_id in ix. rewrite id_left in ix. exact ix. Defined. Definition disp_inv_to_eq {C D : bicat_of_univ_cats} {F : bicat_of_univ_cats⟦C,D⟧} {TC : bidisp_tensor_disp_bicat C} {TD : bidisp_tensor_disp_bicat D} (ptF ptG : TC -->[F] TD) : disp_invertible_2cell (id2_invertible_2cell F) ptF ptG -> ptF = ptG. Proof. intro i. use total2_paths_b. - apply (disp_inv_to_eq1 ptF ptG i). - apply funextsec ; intro ; apply funextsec ; intro. repeat (apply impred_isaprop ; intro). apply univalent_category_has_homsets. Defined. Theorem bidisp_tensor_disp_bicat_is_locally_univalent : disp_univalent_2_1 bidisp_tensor_disp_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros C D F TC TD ptF1 ptF2. use isweqimplimpl. - apply disp_inv_to_eq. - cbn in ptF1 ; cbn in ptF2. rewrite idpath_transportf. unfold preserves_tensor in ptF1 ; unfold preserves_tensor in ptF2. assert (pf : isaset (preserves_tensor TC TD F)). { apply isaset_total2. - repeat (apply impred_isaset ; intro). apply univalent_category_has_homsets. - intro pt. apply isasetaprop. repeat (apply impred_isaprop ; intro). apply univalent_category_has_homsets. } apply pf. - apply isaproptotal2. + intro. apply isaprop_is_disp_invertible_2cell. + intros. apply isaprop_bidisp_tensor_disp_2cell_struct. Defined. (** We now show that this displayed bicategory is globally univalent **) Definition tensor_iso {C : univalent_category} (TC TD : tensor C) : UU := ∑ α : ∏ x y : C, z_iso (x ⊗_{TD} y) (x ⊗_{TC} y), ∏ (a1 a2 b1 b2 : C) (f : C⟦a1,a2⟧) (g : C⟦b1,b2⟧), (pr1 (α a1 b1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (pr1 (α a2 b2)). Definition tensor_eq {C : univalent_category} (TC TD : tensor C) : UU := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)), ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2)). Definition tensor_eq' {C : univalent_category} (TC TD : tensor C) : UU := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)), ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g) = (transportf _ (α x2 y2) (f ⊗^{TD} g)). Lemma idtomor_to_transport {C : univalent_category} (TC TD : tensor C) (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)) (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) : (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2)) -> transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g) = (transportf _ (α x2 y2) (f ⊗^{TD} g)). Proof. intro q. rewrite (! eq_idtoiso_idtomor _ _ _) in q. rewrite (! eq_idtoiso_idtomor _ _ _) in q. etrans. { apply (! idtoiso_precompose _ _ _ _ _ _). } etrans. { apply cancel_postcomposition. do 2 apply maponpaths. apply pathsinv0inv0. } etrans. { exact q. } apply idtoiso_postcompose. Qed. Lemma transport_to_idtomor {C : univalent_category} (TC TD : tensor C) (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)) (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) : transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g) = (transportf _ (α x2 y2) (f ⊗^{TD} g)) -> (idtomor _ _ (α x1 y1)) · (f ⊗^{TC} g) = (f ⊗^{TD} g) · (idtomor _ _ (α x2 y2)). Proof. intro q. etrans. { apply cancel_postcomposition. apply (! eq_idtoiso_idtomor _ _ _). } rewrite (! idtoiso_precompose _ _ _ _ _ _) in q. rewrite (! idtoiso_postcompose _ _ _ _ _ _) in q. rewrite pathsinv0inv0 in q. etrans. { apply q. } apply maponpaths. apply eq_idtoiso_idtomor. Qed. Lemma tensor_eq_equiv_tensor_eq' {C : univalent_category} (TC TD : tensor C) : tensor_eq' TC TD ≃ tensor_eq TC TD. Proof. apply weq_subtypes_iff. - intro. repeat (apply impred_isaprop ; intro). apply homset_property. - intro. repeat (apply impred_isaprop ; intro). apply homset_property. - intro pob. split. + intros q ? ? ? ? f g. apply transport_to_idtomor. exact (q _ _ _ _ f g). + intros q ? ? ? ? f g. apply idtomor_to_transport. exact (q _ _ _ _ f g). Defined. Definition tensor_eq'' {C : univalent_category} (TC TD : tensor C) : UU := ∑ (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)), ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), f ⊗^{TC} g = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g)). Lemma transport_to_transport_f_f {C : univalent_category} (TC TD : tensor C) (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)) (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) : transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g) = transportf _ (α x2 y2) (f ⊗^{TD} g) -> f ⊗^{TC} g = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g)). Proof. intro q. apply (transportf_transpose_right (P := λ x : C, C ⟦ x, x2 ⊗_{ TC} y2 ⟧)). exact q. Qed. Lemma transport_f_f_to_transport {C : univalent_category} (TC TD : tensor C) (α : ∏ x y : C, (x ⊗_{TD} y) = (x ⊗_{TC} y)) (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) : f ⊗^{TC} g = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (α x1 y1) (transportf _ (α x2 y2) (f ⊗^{TD} g)) -> transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (f ⊗^{TC} g) = (transportf _ (α x2 y2) (f ⊗^{TD} g)). Proof. intro q. apply (transportf_transpose_left (P := (λ x : C, C ⟦ x, x2 ⊗_{ TC} y2 ⟧))). unfold transportb. rewrite pathsinv0inv0. apply q. Qed. Lemma tensor_eq'_equiv_tensor_eq'' {C : univalent_category} (TC TD : tensor C) : tensor_eq'' TC TD ≃ tensor_eq' TC TD. Proof. apply weq_subtypes_iff. - intro. repeat (apply impred_isaprop ; intro). apply homset_property. - intro. repeat (apply impred_isaprop ; intro). apply homset_property. - intro pob. split. + intros q ? ? ? ? f g. apply transport_f_f_to_transport. exact (q _ _ _ _ f g). + intros q ? ? ? ? f g. apply transport_to_transport_f_f. exact (q _ _ _ _ f g). Defined. Lemma tensor_iso_equiv_tensor_eq {C : univalent_category} (TC TD : tensor C) : tensor_eq TC TD ≃ tensor_iso TC TD. Proof. use weqtotal2. - apply weqonsecfibers ; intro x ; apply weqonsecfibers ; intro y. use weq_iso. + apply idtoiso. + apply isotoid. apply univalent_category_is_univalent. + intro. apply isotoid_idtoiso. + intro. apply idtoiso_isotoid. - intro iso_tob. repeat (apply weqonsecfibers ; intro). use weq_iso. + intro p. cbn in p. rewrite (! eq_idtoiso_idtomor _ _ _) in p. rewrite (! eq_idtoiso_idtomor _ _ _) in p. apply p. + intro p. etrans. { apply cancel_postcomposition. apply (! eq_idtoiso_idtomor _ _ _). } etrans. { apply p. } apply cancel_precomposition. apply eq_idtoiso_idtomor. + intro ; apply homset_property. + intro ; apply homset_property. Defined. Lemma disp_eq_to_tensoriso {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C) : disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD -> tensor_iso TC TD. Proof. intro dae. induction dae as [[ptd ptnat] [data [ax equiv]]]. induction data as [ptdinv [ptunit ptcounit]]. cbn in *. use tpair. - intros x y. use make_z_iso. + exact (ptd x y). + exact (pr1 ptdinv x y). + split. * set (t := ptcounit x y). cbn in t. unfold identityfunctor_preserves_tensor_data in t. rewrite id_right in t. rewrite tensor_id in t. rewrite id_right in t. unfold compositions_preserves_tensor_data in t. unfold functor_identity in t. exact t. * set (t := ! ptunit x y). cbn in t. unfold identityfunctor_preserves_tensor_data in t. rewrite id_left in t. rewrite tensor_id in t. rewrite id_left in t. unfold compositions_preserves_tensor_data in t. exact t. - intros x1 x2 y1 y2 f g. exact (ptnat x1 x2 y1 y2 f g). Defined. Lemma swap_along_zisos {C : category} {x1 x2 y1 y2 : C} (p1 : z_iso x1 y1) (p2 : z_iso x2 y2) : ∏ (f: C⟦x1,x2⟧) (g : C⟦y1,y2⟧), (pr1 p1) · g = f · (pr1 p2) -> (inv_from_z_iso p1) · f = g · (inv_from_z_iso p2) . Proof. intros f g p. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply p. Qed. Definition tensoriso_to_disp_eq {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C) : tensor_iso TC TD -> disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD. Proof. intro ti. use tpair. - use tpair. + intros x y. apply ti. + intros x1 x2 y1 y2 f g. exact ((pr2 ti) x1 x2 y1 y2 f g). (* disp_left_adjoint_equivalence *) - use tpair. + (* data *) repeat (use tpair). * intros x y. apply ti. * intros x1 x2 y1 y2 f g. induction ti as [n i]. apply (swap_along_zisos (n x1 y1) (n x2 y2) (f ⊗^{pr1 TD} g) (f ⊗^{pr1 TC} g)). exact (i x1 x2 y1 y2 f g). * intros x y. cbn. unfold identityfunctor_preserves_tensor_data. unfold compositions_preserves_tensor_data. rewrite id_left. rewrite tensor_id. rewrite id_left. apply (! z_iso_after_z_iso_inv ((pr1 ti x y))). * intros x y. cbn. unfold compositions_preserves_tensor_data. unfold identityfunctor_preserves_tensor_data. rewrite id_right. rewrite tensor_id. rewrite id_left. cbn. apply (z_iso_inv_after_z_iso ((pr1 ti x y))). + (* axioms *) split. * split. -- abstract (repeat (apply funextsec ; intro) ; apply univalent_category_has_homsets). -- apply funextsec ; intro ; apply funextsec ; intro. apply univalent_category_has_homsets. * split. -- use tpair. ++ intros x y. cbn. unfold compositions_preserves_tensor_data. unfold identityfunctor_preserves_tensor_data. cbn. rewrite id_right. rewrite id_right. rewrite tensor_id. apply (z_iso_after_z_iso_inv ((pr1 ti x y))). ++ split. ** abstract (repeat (apply funextsec ; intro) ; apply univalent_category_has_homsets). ** abstract (repeat (apply funextsec ; intro) ; apply univalent_category_has_homsets). -- use tpair. ++ intros x y. cbn. unfold compositions_preserves_tensor_data. unfold identityfunctor_preserves_tensor_data. cbn. rewrite id_right. rewrite tensor_id. rewrite id_left. apply (! z_iso_inv_after_z_iso ((pr1 ti x y))). ++ split. ** abstract (repeat (apply funextsec ; intro) ; apply univalent_category_has_homsets). ** abstract (repeat (apply funextsec ; intro) ; apply univalent_category_has_homsets). Defined. Lemma tensor_iso_disp_eq_equiv {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C) : tensor_iso TC TD ≃ disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) TC TD. Proof. use weq_iso. - intro ti. apply (tensoriso_to_disp_eq TC TD ti). - intro dae. exact (disp_eq_to_tensoriso TC TD dae). - intro i. induction i. use subtypePath. + intro f. repeat (apply impred_isaprop ; intro). apply univalent_category_has_homsets. + repeat (apply funextsec ; intro). use subtypePath. * intro f. apply isaprop_is_z_isomorphism. * repeat (apply funextsec ; intro). apply idpath. - intro dae. use subtypePath. + intro f. apply isaprop_disp_left_adjoint_equivalence. * apply univalent_cat_is_univalent_2_1. * apply bidisp_tensor_disp_bicat_is_locally_univalent. + apply idpath. Defined. Definition tensor_eqi'' {C : univalent_category} (TC TD : tensor C) : UU := ∑ (α : ∏ x y : C, (x ⊗_{TC} y) = (x ⊗_{TD} y)), ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), f ⊗^{TC} g = transportf (λ x : C, C⟦x , x2 ⊗_{TC} y2⟧) (! α x1 y1) (transportf _ (! α x2 y2) (f ⊗^{TD} g)). Lemma tensor_eq''_equiv_tensor_eqi'' {C : univalent_category} (TC TD : tensor C) : tensor_eqi'' TC TD ≃ tensor_eq'' TC TD. Proof. use weq_iso. - intro tei. use tpair. + intros x y. exact (! pr1 tei x y). + intros x1 x2 y1 y2 f g. exact (pr2 tei _ _ _ _ f g). - intro te. use tpair. + intros x y. exact (! pr1 te x y). + intros x1 x2 y1 y2 f g. rewrite pathsinv0inv0. rewrite pathsinv0inv0. apply (pr2 te). - intro te. use total2_paths_b. + repeat (apply funextsec ; intro). apply pathsinv0inv0. + repeat (apply funextsec ; intro). apply homset_property. - intro tei. use total2_paths_b. + repeat (apply funextsec ; intro). apply pathsinv0inv0. + repeat (apply funextsec ; intro). apply homset_property. Defined. Definition tensor_eqi''' {C : univalent_category} (TC TD : tensor C) : UU := ∑ (α : ∏ x y : C, (x ⊗_{TC} y) = (x ⊗_{TD} y)), ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), transportf (λ x : C, C⟦x , x2 ⊗_{TD} y2⟧) (α x1 y1) (transportf (λ x : C, C⟦x1 ⊗_{TC} y1 , x⟧) (α x2 y2) (f ⊗^{TC} g)) = (f ⊗^{TD} g). Lemma independent_transportation_commutes {C : univalent_category} {F G : C -> C -> C} {x1 x2 y1 y2 : C} (p1 : F x1 y1 = G x1 y1) (p2 : F x2 y2 = G x2 y2) (f : C⟦F x1 y1, F x2 y2⟧) : transportf (λ c : C, C ⟦ G x1 y1, c ⟧) p2 (transportf (λ c : C, C ⟦ c, F x2 y2 ⟧) p1 f) = transportf (λ c : C, C ⟦ c, G x2 y2 ⟧) p1 (transportf (λ c : C, C ⟦ F x1 y1, c ⟧) p2 f). Proof. induction p1 ; induction p2. apply idpath. Qed. Lemma tensor_eqi''_equiv_tensor_eqi''' {C : univalent_category} (TC TD : tensor C) : tensor_eqi''' TC TD ≃ tensor_eqi'' TC TD. Proof. apply weqfibtototal. intro. repeat (apply weqonsecfibers ; intro). use weq_iso. - intro q. apply pathsinv0. etrans. { apply maponpaths. apply maponpaths. exact (! q). } rewrite (! independent_transportation_commutes _ _ _). rewrite transport_f_f. rewrite pathsinv0r. rewrite idpath_transportf. rewrite transport_f_f. rewrite pathsinv0r. apply idpath_transportf. - intro q. etrans. { apply maponpaths. apply maponpaths. exact q. } rewrite (! independent_transportation_commutes _ _ _). rewrite transport_f_f. rewrite pathsinv0l. rewrite idpath_transportf. rewrite transport_f_f. rewrite pathsinv0l. apply idpath_transportf. - intro q. apply homset_property. - intro q. apply homset_property. Defined. Lemma transport_of_bifunctor_map_is_pointwise {C : univalent_category} {F0 G0 : ob C -> ob C -> ob C} (F1 : ∏ x1 x2 y1 y2 : ob C, C⟦x1,x2⟧ -> C⟦y1,y2⟧ -> C⟦F0 x1 y1, F0 x2 y2⟧) (gamma : F0 = G0) {x1 x2 y1 y2 : ob C} (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) : transportf (fun T : C -> C -> C => ∏ a1 a2 b1 b2 : C, C⟦a1,a2⟧ -> C⟦b1,b2⟧ -> C⟦T a1 b1, T a2 b2⟧) gamma F1 x1 x2 y1 y2 f g = double_transport (toforallpaths (λ _ : ob C, C) (F0 x1) (G0 x1) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x1) y1) (toforallpaths (λ _ : ob C, C) (F0 x2) (G0 x2) (toforallpaths (λ _ : ob C, C -> C) F0 G0 gamma x2) y2) (F1 _ _ _ _ f g). Proof. induction gamma. apply idpath. Qed. Definition tensor_eqi'''_to_eq1 {C : univalent_category} (TC TD : tensor C) : tensor_eqi''' TC TD -> pr11 TC = pr11 TD. Proof. intro te. apply funextsec ; intro ; apply funextsec ; intro ; apply (pr1 te). Defined. Definition tensor_eqi'''_to_eq {C : univalent_category} (TC TD : tensor C) : tensor_eqi''' TC TD -> TC = TD. Proof. intro te. use total2_paths_f. - use total2_paths_f. + (* apply funextsec ; intro ; apply funextsec ; intro ; apply (pr1 te). *) exact (tensor_eqi'''_to_eq1 TC TD te). + repeat (apply funextsec ; intro). etrans. 2: apply (pr2 te). etrans. { apply transport_of_bifunctor_map_is_pointwise. } unfold double_transport. unfold tensor_eqi'''_to_eq1. rewrite toforallpaths_funextsec. rewrite toforallpaths_funextsec. rewrite toforallpaths_funextsec. apply independent_transportation_commutes. - use total2_paths_f. + abstract (repeat (apply impred_isaprop ; intro) ; apply homset_property). + abstract (repeat (apply impred_isaprop ; intro) ; apply homset_property). Defined. Lemma id_tensor_eqi'''_2 {C : univalent_category} (TC TD : tensor C) : pr11 TC = pr11 TD -> ∏ x y : C, x ⊗_{ TC} y = x ⊗_{ TD} y. Proof. intros p x y. exact (toforallpaths _ _ _ (toforallpaths _ _ _ p x) y). Defined. Lemma id_tensor_eqi'''_1 {C : univalent_category} (TC TD : tensor C) : TC = TD -> ∏ x y : C, x ⊗_{ TC} y = x ⊗_{ TD} y. Proof. intros p. set (eqonob := base_paths _ _ (base_paths _ _ p)). (* exact (toforallpaths _ _ _ (toforallpaths _ _ _ eqonob x) y). *) exact (id_tensor_eqi'''_2 TC TD eqonob). Defined. Lemma id_tensor_eqi''' {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C) : TC = TD -> tensor_eqi''' TC TD. Proof. intro p. (* induction p. *) use tpair. - exact (id_tensor_eqi'''_1 TC TD p). (* induction p. apply idpath. *) - intros ? ? ? ? f g. induction p. etrans. { apply (! idpath_transportf _ _). } apply idpath_transportf. Defined. Lemma total2_paths_idpath {A : UU} {B : A -> UU} (x : ∑ y : A, B y) : total2_paths_f (idpath (pr1 x)) (idpath_transportf B (pr2 x)) = idpath x. Proof. apply idpath. Qed. Lemma maponpaths_total {A : UU} {B : A -> UU} (x : ∑ y : A, B y) (p0 : pr1 x = pr1 x) (p1 : transportf B p0 (pr2 x) = pr2 x) (q0 : pr1 x = pr1 x) (q1 : transportf B q0 (pr2 x) = pr2 x) : p0=q0 -> (∏ a : A, isaset (B a)) -> total2_paths_f p0 p1 = total2_paths_f q0 q1. Proof. intro k0. induction k0. intro pfset. apply maponpaths. apply pfset. Qed. Lemma cancellation_lemma {A B : UU} (a : A) (b : B) (f : A -> B) (g : B -> A) : (∏ b0 : B, f (g b0) = b0) -> g (f a) = g(b) -> f a = b. Proof. intros i e. set (k0 := ! i (f a)). rewrite e in k0. exact (k0 @ i b). Qed. Lemma funextsec_id'' {C : univalent_category} (T : C -> C -> C) : ∏ x : C, toforallpaths (λ _ : C,C) _ _ (funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0))) = toforallpaths (λ _ : C, C) _ _ (toforallpaths (λ _ : C, C → C) T T (idpath T) x). Proof. intro x. etrans. { apply toforallpaths_funextsec. } apply funextsec ; intro y. apply idpath. Qed. Lemma funextsec_id' {C : univalent_category} (T : C -> C -> C) : toforallpaths (λ _ : C, C → C) T T ( (funextsec (λ _ : C, C → C) T T (λ x : C, funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0))))) = toforallpaths (λ _ : C, C → C) T T (idpath T). Proof. etrans. { apply toforallpaths_funextsec. } apply funextsec ; intro x. apply (cancellation_lemma _ _ _ (toforallpaths (λ _: C,C) (T x) (T x))). - intro q. apply funextsec_toforallpaths. - apply funextsec_id''. Qed. Lemma funextsec_id {C : univalent_category} {T : C -> C -> C} : funextsec (λ _ : C, C → C) T T (λ x : C, funextsec (λ _ : C, C) (T x) (T x) (λ x0 : C, idpath (T x x0))) = idpath T. Proof. apply (cancellation_lemma _ _ _ (toforallpaths (λ _ : C, C -> C) T T)). - intro q. apply funextsec_toforallpaths. - apply funextsec_id'. Qed. Lemma id_to_teqi'''_to_id {C : bicat_of_univ_cats} {TC TD : bidisp_tensor_disp_bicat C} (p : TC = TD) : tensor_eqi'''_to_eq TC TD (id_tensor_eqi''' TC TD p) = p. Proof. unfold tensor_eqi'''_to_eq. unfold id_tensor_eqi'''. induction p. use pathscomp0. 3: apply total2_paths_idpath. apply maponpaths_total. - use pathscomp0. 3: apply total2_paths_idpath. apply maponpaths_total. + apply funextsec_id. + intro T. repeat (apply impred_isaset ; intro). apply homset_property. - intro T. apply isaset_dirprod; repeat (apply impred_isaset ; intro) ; apply isasetaprop ; apply homset_property. Qed. Lemma pr_id_tensor_eqi'''_funextsec {C : univalent_category} {TC TD : tensor C} (p : TC = TD) (x y : C) : pr1 (id_tensor_eqi''' TC TD p) x y = id_tensor_eqi'''_1 TC TD p x y. Proof. apply idpath. Qed. Lemma distributer {C : univalent_category} {TC TD : tensor C} (p : tensor_eqi''' TC TD) : id_tensor_eqi'''_1 TC TD (tensor_eqi'''_to_eq TC TD p) = id_tensor_eqi'''_2 TC TD (tensor_eqi'''_to_eq1 TC TD p). Proof. unfold id_tensor_eqi'''_1. apply maponpaths. etrans. { apply maponpaths. apply base_total2_paths. } apply base_total2_paths. Qed. Lemma distributer_funext {C : univalent_category} {TC TD : tensor C} (p : tensor_eqi''' TC TD) (x y : C) : id_tensor_eqi'''_1 TC TD (tensor_eqi'''_to_eq TC TD p) x y = id_tensor_eqi'''_2 TC TD (tensor_eqi'''_to_eq1 TC TD p) x y. Proof. rewrite distributer. apply idpath. Qed. Lemma teqi'''_to_id_to_teqi''' {C : bicat_of_univ_cats} {TC TD : bidisp_tensor_disp_bicat C} (p : tensor_eqi''' TC TD) : id_tensor_eqi''' TC TD (tensor_eqi'''_to_eq TC TD p) = p. Proof. use total2_paths_f. - apply funextsec ; intro x ; apply funextsec ; intro y. etrans. { apply pr_id_tensor_eqi'''_funextsec. } etrans. { apply distributer_funext. } unfold id_tensor_eqi'''_2. unfold tensor_eqi'''_to_eq1. rewrite toforallpaths_funextsec. rewrite toforallpaths_funextsec. apply idpath. - repeat (apply funextsec ; intro). apply homset_property. Qed. Definition tensor_eqi'''_equiv_eq {C : bicat_of_univ_cats} (TC TD : bidisp_tensor_disp_bicat C) : TC = TD ≃ tensor_eqi''' TC TD. Proof. use weq_iso. - intro eq. exact (id_tensor_eqi''' TC TD eq). - intro teq. exact (tensor_eqi'''_to_eq _ _ teq). - intro eq. apply id_to_teqi'''_to_id. - intro teq. apply teqi'''_to_id_to_teqi'''. Defined. Lemma bicatcattensor_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_tensor_disp_bicat. Proof. intros C D equalcats TC TD. induction equalcats. use weqhomot. - set (i1 := tensor_iso_disp_eq_equiv TC TD). set (i2 := tensor_iso_equiv_tensor_eq TC TD). set (i3 := tensor_eq_equiv_tensor_eq' TC TD). set (i4 := tensor_eq'_equiv_tensor_eq'' TC TD). set (i5 := tensor_eq''_equiv_tensor_eqi'' TC TD). set (i6 := tensor_eqi''_equiv_tensor_eqi''' TC TD). set (i7 := tensor_eqi'''_equiv_eq TC TD). exact ((i1 ∘ i2 ∘ i3 ∘ i4 ∘ i5 ∘ i6 ∘ i7)%weq). - intro p. induction p. use subtypePath. + intro. apply (@isaprop_disp_left_adjoint_equivalence bicat_of_univ_cats bidisp_tensor_disp_bicat). * exact univalent_cat_is_univalent_2_1. * exact bidisp_tensor_disp_bicat_is_locally_univalent. + use total2_paths_b. * repeat (apply funextsec ; intro). apply idpath. * repeat (apply funextsec ; intro). apply homset_property. Qed. Lemma bidisp_tensor_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_tensor_disp_bicat. Proof. apply make_disp_univalent_2. - apply bicatcattensor_disp_prebicat_is_globally_univalent. - apply bidisp_tensor_disp_bicat_is_locally_univalent. Defined. Definition bidisp_tensor_disp_2cells_isaprop : disp_2cells_isaprop bidisp_tensor_disp_bicat. Proof. intros C D F G α TC TD ptC ptD. apply isaprop_bidisp_tensor_disp_2cell_struct. Qed. Definition bidisp_tensor_disp_locally_groupoid : disp_locally_groupoid bidisp_tensor_disp_bicat. Proof. unfold disp_locally_groupoid. intros C D F G α TC TD ptC ptD ptc. unfold is_disp_invertible_2cell. use tpair. - intros x y. set (α_natiso := (invertible_2cell_to_nat_z_iso F G α)). set (α_natisox := nat_z_iso_pointwise_z_iso α_natiso x : z_iso (pr1 F x) (pr1 G x)). set (α_natisoy := nat_z_iso_pointwise_z_iso α_natiso y : z_iso (pr1 F y) (pr1 G y)). set (α_natisoxty := nat_z_iso_pointwise_z_iso α_natiso (x ⊗_{ TC: tensor (C : univalent_category)} y) : z_iso (pr1 F (x ⊗_{ TC: tensor (C : univalent_category)} y)) (pr1 G (x ⊗_{ TC: tensor (C : univalent_category)} y)) ). transparent assert (α_natisotxmym : (z_iso (pr1 G x ⊗_{ TD: tensor (D : univalent_category)} pr1 G y) (pr1 F x ⊗_{ TD: tensor (D : univalent_category)} pr1 F y) ) ). { exists (pr1 (α ^-1)%bicategory x ⊗^{ TD: tensor (D : univalent_category)} pr1 (α ^-1)%bicategory y). exists (pr11 α%bicategory x ⊗^{ TD: tensor (D : univalent_category)} pr11 α%bicategory y). split. - rewrite <- tensor_comp. etrans. { apply (maponpaths (t2:=identity (pr1 G x)) (fun l => l ⊗^{ TD: tensor (D : univalent_category)} (pr1 (α ^-1)%bicategory y · (pr11 α) y))). apply (pr222 α_natisox). } etrans. { apply maponpaths. apply (pr222 α_natisoy). } apply tensor_id. - rewrite <- tensor_comp. etrans. { apply (maponpaths (t2:=identity (pr1 F x)) (fun l => l ⊗^{ TD: tensor (D : univalent_category)} ((pr11 α) y · pr1 (α ^-1)%bicategory y))). apply (pr122 α_natisox). } etrans. { apply maponpaths. apply (pr122 α_natisoy). } apply tensor_id. } apply (z_iso_inv_to_left _ _ _ α_natisotxmym). rewrite assoc. apply pathsinv0, (z_iso_inv_on_left _ _ _ _ α_natisoxty). cbn. cbn in ptc. unfold bidisp_tensor_disp_2cell_struct in ptc. red in ptc. apply pathsinv0, ptc. - split ; apply isaprop_bidisp_tensor_disp_2cell_struct. Qed. End TensorLayer. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/TensorUnitLayer.v000066400000000000000000000117461451125700300315260ustar00rootroot00000000000000(* This is the third of a sequence of files with the purpose of showing that the bicategory of univalent monoidal categories is again univalent. In this file we construct the total category of the (direct) product of the unit and tensor layer. This finishes the first layer. *) Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorLayer. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.UnitLayer. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Section TensorUnitLayer. Definition bidisp_tensor_unit : disp_bicat _ := disp_dirprod_bicat bidisp_tensor_disp_bicat bidisp_unit_disp_bicat. Definition bidisp_tensorunit_is_disp_univalent_2 : disp_univalent_2 bidisp_tensor_unit. Proof. apply is_univalent_2_dirprod_bicat. - apply univalent_cat_is_univalent_2. - apply bidisp_tensor_disp_prebicat_is_univalent_2. - apply bidisp_unit_disp_prebicat_is_univalent_2. Defined. Definition bidisp_tensor_unit_total : bicat := total_bicat bidisp_tensor_unit. Definition bidisp_tensorunit_is_univalent_2: is_univalent_2 bidisp_tensor_unit_total. Proof. apply is_univalent_2_total_dirprod. - apply univalent_cat_is_univalent_2. - apply bidisp_tensor_disp_prebicat_is_univalent_2. - apply bidisp_unit_disp_prebicat_is_univalent_2. Defined. Definition disp_tensorunit_univalentcat (C : bidisp_tensor_unit_total) : univalent_category := pr1 C. Definition tensorunit_unit (C : bidisp_tensor_unit_total) : (pr1 C : univalent_category) := pr22 C. Definition tensorunit_tensor (C : bidisp_tensor_unit_total) : tensor (pr1 C : univalent_category) := pr12 C. Definition tensorunit_preserves_unit {C D : bidisp_tensor_unit_total} (F : bidisp_tensor_unit_total⟦C, D⟧) : (pr1 D : univalent_category)⟦ tensorunit_unit D, (pr1 F : functor (pr1 C : univalent_category) (pr1 D : univalent_category)) (tensorunit_unit C) ⟧ := pr22 F. Definition tensorunit_preserves_tensor_data {C D : bidisp_tensor_unit_total} (F : bidisp_tensor_unit_total⟦C, D⟧) : preserves_tensor_data _ _ (pr1 F : functor _ _) := pr112 F. Definition equality_tensor_unit_with_layer (C : bicat_of_univ_cats) : bidisp_tensor_unit C = tensor_unit (C : univalent_category). Proof. apply idpath. Defined. Definition equality_functor_tensor_unit_with_layer (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧) (tuC : bidisp_tensor_unit C) (tuD : bidisp_tensor_unit D) : tuC -->[F] tuD = functor_tensor_unit tuC tuD F. Proof. apply idpath. Defined. Definition tu_cat := bidisp_tensor_unit_total. Definition uc (C : tu_cat) : univalent_category := pr1 C. Definition tu (C : tu_cat) : tensor_unit (uc C) := pr2 C. Definition fuc {C D : tu_cat} (F : tu_cat⟦C,D⟧) : functor (uc C) (uc D) := pr1 F. Definition ftu {C D : tu_cat} (F : tu_cat⟦C,D⟧) : functor_tensor_unit (tu C) (tu D) (fuc F) := pr2 F. Definition bidisp_tensorunit_disp_2cells_isaprop : disp_2cells_isaprop bidisp_tensor_unit. Proof. apply disp_2cells_isaprop_prod. - apply bidisp_tensor_disp_2cells_isaprop. - apply bidisp_unit_disp_2cells_isaprop. Qed. Definition bidisp_tensorunit_disp_locally_groupoid : disp_locally_groupoid bidisp_tensor_unit. Proof. apply disp_locally_groupoid_prod. - apply bidisp_tensor_disp_locally_groupoid. - apply bidisp_unit_disp_locally_groupoid. Qed. End TensorUnitLayer. Module TensorUnitNotations. Notation "I_{ C }" := (tensorunit_unit C). Notation "T_{ C }" := (tensorunit_tensor C). Notation "pu_{ F }" := (tensorunit_preserves_unit F). Notation "pt_{ F }" := (tensorunit_preserves_tensor_data F). Notation "x ⊗_{ C } y" := (tensor_on_ob T_{C} x y) (at level 31). Notation "f ⊗^{ C } g" := (tensor_on_hom T_{C} _ _ _ _ f g) (at level 31). End TensorUnitNotations. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/UnivalenceMonCat/UnitLayer.v000066400000000000000000000241441451125700300303270ustar00rootroot00000000000000(* This is the first of a sequence of files with the purpose of showing that the bicategory of univalent monoidal categories is again univalent. In this file we construct one side of the first displayed layer above the bicategory of univalent categories, more precisely: The total category corresponding to this displayed layer is the univalent bicategory defined as followed: - The objects are categories together with a fixed object (which will be the unit for the monoidal structure). - The morphisms are functors which preserve the unit in a lax/weak sense (i.e. a non-necessarily isomorphic morphism). - The 2-cells are natural transformations which (at the unit) preserve the morphisms for source and target functor. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories. Local Open Scope cat. Local Open Scope mor_disp_scope. Section UnitLayer. Definition disp_unit_disp_ob_mor : disp_cat_ob_mor bicat_of_univ_cats. Proof. exists (λ C, ob (C : univalent_category)). exact (λ C D IC ID F, (D : univalent_category)⟦ID, (pr1 F) IC⟧). Defined. Definition disp_unit_disp_cat_data : disp_cat_data bicat_of_univ_cats. Proof. exists disp_unit_disp_ob_mor. use tpair. - intros C I. apply identityfunctor_preserves_unit. - intros C D E F G IC ID IE puF puG. apply (composition_preserves_unit puF puG). Defined. Definition bidisp_unit_disp_2cell_struct : disp_2cell_struct disp_unit_disp_cat_data. Proof. intros C D F G α IC ID puF puG. apply (preservesunit_commutes puF puG α). Defined. Lemma isaprop_bidisp_unit_disp_2cell_struct {C D : bicat_of_univ_cats} {F G : bicat_of_univ_cats ⟦C,D⟧ } {α : prebicat_cells bicat_of_univ_cats F G} {IC : disp_unit_disp_cat_data C} {ID : disp_unit_disp_cat_data D} (puF : IC -->[ F] ID) (puG : IC -->[ G] ID) : isaprop (bidisp_unit_disp_2cell_struct C D F G α IC ID puF puG). Proof. apply isaprop_preservesunit_commutes. Qed. Definition bidisp_unit_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats := (disp_unit_disp_cat_data,, bidisp_unit_disp_2cell_struct). Definition bidisp_unit_disp_prebicat_ops : disp_prebicat_ops bidisp_unit_disp_prebicat_1_id_comp_cells. Proof. repeat split; cbn; unfold bidisp_unit_disp_2cell_struct. - intros C D F IC ID puF. apply identitynattrans_preservesunit_commutes. - intros C D F IC ID puF. etrans. { apply id_right. } etrans. { unfold composition_preserves_unit. apply maponpaths. apply functor_id. } apply id_right. - intros C D F IC ID puF. etrans. { apply id_right. } apply id_left. - intros C D F IC ID puF. apply cancel_precomposition. apply pathsinv0. apply functor_id. - intros C D F IC ID puF. etrans. { apply id_right. } apply pathsinv0. apply id_left. - intros C D E W F G H IC ID IE IW puF puG puH. cbn. unfold bidisp_unit_disp_2cell_struct. cbn. etrans. { apply id_right. } etrans. { apply cancel_precomposition. apply functor_comp. } etrans. { apply assoc. } apply idpath. - intros C D E W F G H IC ID IE IW puF puG puH. cbn. unfold bidisp_unit_disp_2cell_struct. cbn. etrans. { apply id_right. } etrans. { apply assoc'. } apply cancel_precomposition. apply pathsinv0. apply functor_comp. - intros C D F G H α β IC ID puF puG puH pucα pucβ. etrans. { apply assoc. } etrans. { apply cancel_postcomposition. apply pucα. } apply pucβ. - intros C D E F G H α IC ID IE puF puG puH pucα. etrans. { apply assoc'. } etrans. { apply cancel_precomposition. apply (pr2 α). } etrans. { apply assoc. } apply cancel_postcomposition. apply pucα. - cbn in *. intros C D E F G H α IC ID IE puF puG puH pucα. etrans. { apply assoc'. } etrans. { apply cancel_precomposition. simpl. apply (pathsinv0 (functor_comp _ _ _)). } unfold composition_preserves_unit. unfold preservesunit_commutes in pucα. do 2 apply maponpaths. apply pucα. Qed. Definition bidisp_unit_disp_prebicat_data : disp_prebicat_data bicat_of_univ_cats := (bidisp_unit_disp_prebicat_1_id_comp_cells,, bidisp_unit_disp_prebicat_ops). Definition bidisp_unit_disp_prebicat_laws : disp_prebicat_laws bidisp_unit_disp_prebicat_data. Proof. repeat split; intro; intros; apply isaprop_bidisp_unit_disp_2cell_struct. Qed. Definition bidisp_unit_disp_prebicat : disp_prebicat bicat_of_univ_cats := (bidisp_unit_disp_prebicat_data,,bidisp_unit_disp_prebicat_laws). Definition bidisp_unit_disp_bicat : disp_bicat bicat_of_univ_cats. Proof. refine (bidisp_unit_disp_prebicat,, _). intros C D F G α IC ID puF puG. apply isasetaprop. apply univalent_category_has_homsets. Defined. Lemma bidisp_unit_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_unit_disp_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros C D F IC ID puF puG. apply isweqimplimpl. - cbn. intros α. pose (pr1 α) as d. cbn in *. unfold bidisp_unit_disp_2cell_struct in *. unfold preservesunit_commutes in d. rewrite id_right in d. exact d. - apply univalent_category_has_homsets. - apply invproofirrelevance. intro ; intro. use subtypePath. + intro x0. apply isaprop_is_disp_invertible_2cell. + apply univalent_category_has_homsets. Qed. Lemma dispadjequiv_to_iso (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) : disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID -> z_iso IC ID. Proof. intro equalunits. induction equalunits as [f adj]. induction adj as [data [ladj_ax weq_ax]]. induction data as [finv [dunit dcounit]]. cbn in *. unfold functor_identity in dunit. unfold nat_trans_id in dunit. cbn in dunit. exists finv. exists f. split. - etrans. { apply (pathsinv0 dunit). } apply id_left. - apply pathsinv0. etrans. { apply (pathsinv0 dcounit). } apply id_right. Defined. Lemma iso_to_dispadjequiv (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) : z_iso IC ID -> disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID. Proof. intro i. induction i as [finv [f [li ri]]]. split with f. unfold disp_left_adjoint_equivalence. repeat (use tpair); try apply univalent_category_has_homsets. - exact finv. - etrans. { apply id_left. } exact (! li). - etrans. { apply cancel_postcomposition. apply ri. } apply id_right. - etrans. { apply cancel_postcomposition. apply li. } apply id_left. - etrans. { apply id_left. } exact (! ri). Defined. Lemma iso_dispadjequiv_equivalence (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) : z_iso IC ID ≃ disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID. Proof. use make_weq. - apply iso_to_dispadjequiv. - use isweq_iso. + apply dispadjequiv_to_iso. + intro i. induction i. use subtypePath. * intro f. apply isaprop_is_z_isomorphism. * apply idpath. + intro adjequiv. induction adjequiv. use subtypePath. * intro f. apply isaprop_disp_left_adjoint_equivalence. -- apply univalent_cat_is_univalent_2_1. -- apply bidisp_unit_disp_prebicat_is_locally_univalent. * apply idpath. Defined. Lemma bidisp_unit_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_unit_disp_bicat. Proof. intros C D equalcats IC ID. induction equalcats. use weqhomot. - set (i1 := iso_dispadjequiv_equivalence C IC ID). set (i3 := (_ ,, (pr2 C) IC ID)). exact (i1 ∘ i3)%weq. - intro p. induction p; cbn. use subtypePath. + intro; simpl. apply (@isaprop_disp_left_adjoint_equivalence bicat_of_univ_cats bidisp_unit_disp_bicat). * exact univalent_cat_is_univalent_2_1. * exact bidisp_unit_disp_prebicat_is_locally_univalent. + apply idpath. Defined. Lemma bidisp_unit_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_unit_disp_bicat. Proof. apply make_disp_univalent_2. - apply bidisp_unit_disp_prebicat_is_globally_univalent. - apply bidisp_unit_disp_prebicat_is_locally_univalent. Defined. Definition bidisp_unit_disp_2cells_isaprop : disp_2cells_isaprop bidisp_unit_disp_bicat. Proof. intros C D F G α IC ID puC puD. apply isaprop_bidisp_unit_disp_2cell_struct. Qed. Definition bidisp_unit_disp_locally_groupoid : disp_locally_groupoid bidisp_unit_disp_bicat. Proof. intros C D F G α IC ID puC puD puc. use tpair. - set (α_natiso := invertible_2cell_to_nat_z_iso F G α). set (α_natisoIC := nat_z_iso_pointwise_z_iso α_natiso IC : z_iso (pr1 F IC) (pr1 G IC)). cbn. unfold bidisp_unit_disp_2cell_struct. red. apply pathsinv0, (z_iso_inv_on_left _ _ _ _ α_natisoIC). exact (! puc). - split; apply isaprop_bidisp_unit_disp_2cell_struct. Qed. End UnitLayer. UniMath-20231010/UniMath/Bicategories/MonoidalCategories/WhiskeredMonoidalFromBicategory.v000066400000000000000000000122611451125700300314620ustar00rootroot00000000000000(** *** Going into the opposite direction of [UniMath.Bicategories.Core.Examples.BicategoryFromWhiskeredMonoidal] *) (** We fix a bicategory and an object of it and construct the (whiskered) monoidal category of endomorphisms. Written by Ralph Matthes in 2019, adapted in 2022. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Unitors. Local Open Scope cat. Section Monoidal_Cat_From_Bicat. Local Open Scope bicategory_scope. Import Bicat.Notations. Import MonoidalNotations. Context {C : bicat}. Context (c0: ob C). Definition precategory_data_from_bicat_and_ob: precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact (C⟦c0,c0⟧). + apply prebicat_cells. - intro c; apply id2. - intros a b c; apply vcomp2. Defined. Lemma is_precategory_data_from_prebicat_and_ob: is_precategory precategory_data_from_bicat_and_ob. Proof. use make_is_precategory. - intros a b f; apply id2_left. - intros a b f; apply id2_right. - intros a b c d f g h; apply vassocr. - intros a b c d f g h; apply pathsinv0; apply vassocr. Qed. Definition precategory_from_bicat_and_ob: precategory := _,, is_precategory_data_from_prebicat_and_ob. Lemma has_homsets_precategory_from_bicat_and_ob: has_homsets precategory_from_bicat_and_ob. Proof. red. intros. apply (cellset_property(C:=C)). Qed. Definition category_from_bicat_and_ob: category := precategory_from_bicat_and_ob ,, has_homsets_precategory_from_bicat_and_ob. Local Notation EndC := category_from_bicat_and_ob. Definition tensor_data_from_bicat_and_ob: bifunctor_data category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob. Proof. use make_bifunctor_data. - intros a b. exact (a · b). - intros a b1 b2 β. exact (lwhisker _ β). - intros b a1 a2 α. exact (rwhisker _ α). Defined. (** we explicitly do not opacify the following definition: *) Definition tensor_laws_from_bicat_and_ob: is_bifunctor tensor_data_from_bicat_and_ob. Proof. red; repeat split; red; cbn. - apply lwhisker_id2. - intros; apply id2_rwhisker. - intros; apply pathsinv0, lwhisker_vcomp. - intros; apply pathsinv0, rwhisker_vcomp. - intros; apply vcomp_whisker. Defined. Definition tensor_from_bicat_and_ob : bifunctor category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob := make_bifunctor tensor_data_from_bicat_and_ob tensor_laws_from_bicat_and_ob. Definition monoidal_data_from_bicat_and_ob: monoidal_data category_from_bicat_and_ob. Proof. use make_monoidal_data. - exact tensor_data_from_bicat_and_ob. - exact (id₁ c0). - red; intros; apply lunitor. - red; intros; apply linvunitor. - red; intros; apply runitor. - red; intros; apply rinvunitor. - red; intros; apply rassociator. - red; intros; apply lassociator. Defined. Local Definition MD := monoidal_data_from_bicat_and_ob. Local Lemma leftunitor_law_from_bicat_and_ob: leftunitor_law lu_{MD} luinv_{MD}. Proof. split; red; cbn. - apply vcomp_lunitor. - apply is_invertible_2cell_lunitor. Qed. Local Lemma rightunitor_law_from_bicat_and_ob: rightunitor_law ru_{MD} ruinv_{MD}. Proof. split; red; cbn. - apply vcomp_runitor. - apply is_invertible_2cell_runitor. Qed. Local Lemma associator_law_from_bicat_and_ob: associator_law α_{MD} αinv_{MD}. Proof. repeat split; try red; cbn. - apply lwhisker_lwhisker_rassociator. - intros; apply pathsinv0, rwhisker_rwhisker_alt. - apply rwhisker_lwhisker_rassociator. - apply is_invertible_2cell_rassociator. - apply is_invertible_2cell_rassociator. Qed. Local Lemma triangle_identity_from_bicat_and_ob: triangle_identity lu_{MD} ru_{MD} α_{MD}. Proof. red; cbn. apply lunitor_lwhisker. Qed. (** the next two lemmas only for illustration that the extra triangle laws are already available in bicategories *) Local Lemma triangle_identity'_from_bicat_and_ob: triangle_identity' lu_{MD} α_{MD}. Proof. red; intros x y; cbn. rewrite <- lunitor_triangle. rewrite vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. Local Lemma triangle_identity''_from_bicat_and_ob: triangle_identity'' ru_{MD} α_{MD}. Proof. red; intros x y; cbn. apply runitor_triangle. Qed. Local Lemma pentagon_identity_from_bicat_and_ob: pentagon_identity α_{MD}. Proof. red; cbn. apply rassociator_rassociator. Qed. Definition monoidal_from_bicat_and_ob: monoidal category_from_bicat_and_ob. Proof. exists monoidal_data_from_bicat_and_ob. exists (pr2 (tensor_from_bicat_and_ob)). exists leftunitor_law_from_bicat_and_ob. exists rightunitor_law_from_bicat_and_ob. exists associator_law_from_bicat_and_ob. exists triangle_identity_from_bicat_and_ob. exact pentagon_identity_from_bicat_and_ob. Defined. End Monoidal_Cat_From_Bicat. UniMath-20231010/UniMath/Bicategories/Morphisms/000077500000000000000000000000001451125700300212355ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Morphisms/Adjunctions.v000066400000000000000000000213561451125700300237140ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Internal adjunctions and adjoint equivalences ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Local Open Scope bicategory_scope. Local Open Scope cat. Section Internal_Adjunction. Context {B : bicat}. (** ** Definitions of internal adjunctions *) (** *** Data & laws for left adjoints *) Definition left_adjoint_data {a b : B} (f : a --> b) : UU := ∑ (g : b --> a), identity a ==> f · g × g · f ==> identity b. Definition left_adjoint_right_adjoint {a b : B} {f : a --> b} (αd : left_adjoint_data f) : b --> a := pr1 αd. Definition left_adjoint_unit {a b : B} {f : a --> b} (αd : left_adjoint_data f) : identity a ==> f · left_adjoint_right_adjoint αd := pr12 αd. Definition left_adjoint_counit {a b : B} {f : a --> b} (αd : left_adjoint_data f) : left_adjoint_right_adjoint αd · f ==> identity b := pr22 αd. Definition left_adjoint_axioms {a b : B} {f : a --> b} (αd : left_adjoint_data f) : UU := let g := left_adjoint_right_adjoint αd in let η := left_adjoint_unit αd in let ε := left_adjoint_counit αd in linvunitor f • (η ▹ f) • rassociator _ _ _ • (f ◃ ε) • runitor f = id2 f × rinvunitor g • (g ◃ η) • lassociator _ _ _ • (ε ▹ g) • lunitor g = id2 g. Definition left_adjoint {a b : B} (f : a --> b) : UU := ∑ (αd : left_adjoint_data f), left_adjoint_axioms αd. Coercion data_of_left_adjoint {a b : B} {f : a --> b} (α : left_adjoint f) : left_adjoint_data f := pr1 α. Coercion axioms_of_left_adjoint {a b : B} {f : a --> b} (α : left_adjoint f) : left_adjoint_axioms α := pr2 α. (** Data and laws for right adjoints *) Definition internal_right_adj_data {a b : B} (g : b --> a) : UU := ∑ (f : a --> b), identity a ==> f · g × g · f ==> identity b. Definition internal_right_adj_left_adjoint {a b : B} {g : b --> a} (αd : internal_right_adj_data g) : a --> b := pr1 αd. Definition internal_right_adj_unit {a b : B} {g : b --> a} (αd : internal_right_adj_data g) : identity a ==> internal_right_adj_left_adjoint αd · g := pr12 αd. Definition internal_right_adj_counit {a b : B} {g : b --> a} (αd : internal_right_adj_data g) : g · internal_right_adj_left_adjoint αd ==> identity b := pr22 αd. Definition internal_right_adj_axioms {a b : B} {g : b --> a} (αd : internal_right_adj_data g) : UU := let f := internal_right_adj_left_adjoint αd in let η := internal_right_adj_unit αd in let ε := internal_right_adj_counit αd in linvunitor f • (η ▹ f) • rassociator _ _ _ • (f ◃ ε) • runitor f = id2 f × rinvunitor g • (g ◃ η) • lassociator _ _ _ • (ε ▹ g) • lunitor g = id2 g. Definition internal_right_adj {a b : B} (g : b --> a) : UU := ∑ (αd : internal_right_adj_data g), internal_right_adj_axioms αd. Coercion data_of_internal_right_adj {a b : B} {g : b --> a} (α : internal_right_adj g) : internal_right_adj_data g := pr1 α. Coercion axioms_of_internal_right_adj {a b : B} {g : b --> a} (α : internal_right_adj g) : internal_right_adj_axioms α := pr2 α. (** *** Laws for equivalences *) Definition left_equivalence_axioms {a b : B} {f : a --> b} (αd : left_adjoint_data f) : UU := is_invertible_2cell (left_adjoint_unit αd) × is_invertible_2cell (left_adjoint_counit αd). Definition left_equivalence {a b : B} (f : a --> b) :UU := ∑ (αd : left_adjoint_data f), left_equivalence_axioms αd. Coercion data_of_left_equivalence {a b : B} {f : a --> b} (αe : left_equivalence f) : left_adjoint_data f := pr1 αe. Coercion axioms_of_left_equivalence {a b : B} {f : a --> b} (αe : left_equivalence f) : left_equivalence_axioms αe := pr2 αe. Definition left_adjoint_equivalence {a b : B} (f : a --> b) : UU := ∑ (αd : left_adjoint_data f), left_adjoint_axioms αd × left_equivalence_axioms αd. (* the coercion to the axioms will be induced *) Coercion left_adjoint_of_left_adjoint_equivalence {a b : B} {f : a --> b} (αe : left_adjoint_equivalence f) : left_adjoint f := (pr1 αe,, pr12 αe). Coercion left_equivalence_of_left_adjoint_equivalence {a b : B} {f : a --> b} (αe : left_adjoint_equivalence f) : left_equivalence f := (pr1 αe,, pr22 αe). Definition left_equivalence_unit_iso {a b : B} {f : a --> b} (αe : left_equivalence f) : invertible_2cell (identity a) (f · left_adjoint_right_adjoint αe). Proof. refine (left_adjoint_unit αe,, _). apply αe. Defined. Definition left_equivalence_counit_iso {a b : B} {f : a --> b} (αe : left_equivalence f) : invertible_2cell (left_adjoint_right_adjoint αe · f) (identity b). Proof. refine (left_adjoint_counit αe,, _). apply αe. Defined. (** *** Packaged *) Definition adjunction (a b : B) : UU := ∑ (f : a --> b), left_adjoint f. Coercion arrow_of_adjunction {a b : B} (f : adjunction a b) : a --> b := pr1 f. Coercion left_adjoint_of_adjunction {a b : B} (f : adjunction a b) : left_adjoint f := pr2 f. Definition adjoint_equivalence (a b : B) : UU := ∑ (f : a --> b), left_adjoint_equivalence f. Coercion adjunction_of_adjoint_equivalence {a b : B} (f : adjoint_equivalence a b) : adjunction a b := (pr1 f,,left_adjoint_of_left_adjoint_equivalence (pr2 f)). Coercion left_adjoint_equivalence_of_adjoint_equivalence {a b : B} (f : adjoint_equivalence a b) : left_adjoint_equivalence f := pr2 f. Definition internal_right_adjoint {a b : B} (f : adjunction a b) : b --> a := left_adjoint_right_adjoint f. Definition internal_triangle1 {a b : B} {f : a --> b} {adj : left_adjoint_data f} (L : left_adjoint_axioms adj) : linvunitor f • (left_adjoint_unit adj ▹ f) • rassociator _ _ _ • (f ◃ left_adjoint_counit adj) • runitor f = id2 f := pr1 L. Definition internal_triangle2 {a b : B} {f : a --> b} {adj : left_adjoint_data f} (L : left_adjoint_axioms adj) (g := left_adjoint_right_adjoint adj) : rinvunitor g • (g ◃ left_adjoint_unit adj) • lassociator _ _ _ • (left_adjoint_counit adj ▹ g) • lunitor g = id2 g := pr2 L. Definition make_adjoint_equivalence {a b : B} (f : a --> b) (g : b --> a) (η : identity _ ==> g ∘ f) (ε : f ∘ g ==> identity _) (triangle1 : linvunitor f • (η ▹ f) • rassociator _ _ _ • (f ◃ ε) • runitor f = id2 f) (triangle2 : rinvunitor g • (g ◃ η) • lassociator _ _ _ • (ε ▹ g) • lunitor g = id2 g) (η_iso : is_invertible_2cell η) (ε_iso : is_invertible_2cell ε) : adjoint_equivalence a b := f ,, ((g ,, (η ,, ε)) ,, ((triangle1 ,, triangle2) ,, (η_iso ,, ε_iso))). End Internal_Adjunction. UniMath-20231010/UniMath/Bicategories/Morphisms/DiscreteMorphisms.v000066400000000000000000000130731451125700300250740ustar00rootroot00000000000000(** Discrete morphisms in bicategories Contents: 1. Conservative 1-cells 2. Characterization of conservative 1-cells 3. Pseudomonic 1-cells and fully faithful 1-cells are conservative 4. Discrete 1-cells 5. Pseudomonic and fully faithful 1-cells are discrete 6. Conservative 1-cells in locally groupoidal bicategories *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Local Open Scope cat. (** 1. Conservative 1-cells *) Definition conservative_1cell {B : bicat} {a b : B} (f : a --> b) : UU := ∏ (x : B) (g₁ g₂ : x --> a) (α : g₁ ==> g₂), is_invertible_2cell (α ▹ f) → is_invertible_2cell α. Definition conservative_1cell_reflect_iso {B : bicat} {a b : B} {f : a --> b} (Hf : conservative_1cell f) {x : B} {g₁ g₂ : x --> a} (α : g₁ ==> g₂) (Hα : is_invertible_2cell (α ▹ f)) : is_invertible_2cell α := Hf x g₁ g₂ α Hα. Definition isaprop_conservative_1cell {B : bicat} {a b : B} (f : a --> b) : isaprop (conservative_1cell f). Proof. do 5 (use impred ; intro). apply isaprop_is_invertible_2cell. Qed. (** 2. Characterization of conservative 1-cells *) Definition conservative_1cell_to_conservative {B : bicat} {a b : B} {f : a --> b} (Hf : conservative_1cell f) (x : B) : conservative (post_comp x f). Proof. intros g₁ g₂ α Hα. apply is_inv2cell_to_is_z_iso. apply Hf. exact (z_iso_to_inv2cell (make_z_iso' _ Hα)). Defined. Definition conservative_to_conservative_1cell {B : bicat} {a b : B} {f : a --> b} (Hf : ∏ (x : B), conservative (post_comp x f)) : conservative_1cell f. Proof. intros x g₁ g₂ α Hα. apply is_z_iso_to_is_inv2cell. apply Hf. apply is_inv2cell_to_is_z_iso. exact Hα. Defined. Definition conservative_1cell_weq_conservative {B : bicat} {a b : B} (f : a --> b) : conservative_1cell f ≃ ∏ (x : B), conservative (post_comp x f). Proof. use weqimplimpl. - exact conservative_1cell_to_conservative. - exact conservative_to_conservative_1cell. - exact (isaprop_conservative_1cell f). - use impred ; intro. apply isaprop_conservative. Defined. (** 3. Pseudomonic and fully faithful 1-cells are conservative *) Definition pseudomonic_is_conservative {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) : conservative_1cell f. Proof. intros x g₁ g₂ α Hα. pose (H := is_invertible_2cell_pseudomonic_1cell_inv_map Hf (α ▹ f) Hα). use make_is_invertible_2cell. - exact (H^-1). - abstract (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite id2_left ; apply (pseudomonic_1cell_faithful Hf) ; exact (!(pseudomonic_1cell_inv_map_eq Hf (α ▹ f) Hα))). - abstract (use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite id2_right ; apply (pseudomonic_1cell_faithful Hf) ; exact (!(pseudomonic_1cell_inv_map_eq Hf (α ▹ f) Hα))). Defined. Definition fully_faithful_to_conservative {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) : conservative_1cell f. Proof. apply pseudomonic_is_conservative. apply fully_faithful_is_pseudomonic. exact Hf. Defined. (** 4. Discrete 1-cells *) Definition discrete_1cell {B : bicat} {a b : B} (f : a --> b) : UU := faithful_1cell f × conservative_1cell f. Definition isaprop_discrete_1cell {B : bicat} {a b : B} (f : a --> b) : isaprop (discrete_1cell f). Proof. use isapropdirprod. - apply isaprop_faithful_1cell. - apply isaprop_conservative_1cell. Qed. (** 5. Pseudomonic 1-cells and fully faithful 1-cells are discrete *) Definition pseudomonic_is_discrete {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) : discrete_1cell f. Proof. split. - exact (pseudomonic_1cell_faithful Hf). - exact (pseudomonic_is_conservative Hf). Defined. Definition fully_faithful_is_discrete {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) : discrete_1cell f. Proof. split. - exact (fully_faithful_1cell_faithful Hf). - exact (fully_faithful_to_conservative Hf). Defined. (** 6. Conservative 1-cells in locally groupoidal bicategories *) Definition conservative_1cell_locally_groupoid {B : bicat} (HB : locally_groupoid B) {a b : B} (f : a --> b) : conservative_1cell f. Proof. intros x g₁ g₂ α Hα. apply HB. Defined. Definition discrete_1cell_weq_faithful_locally_groupoid {B : bicat} (HB : locally_groupoid B) {a b : B} (f : a --> b) : discrete_1cell f ≃ faithful_1cell f. Proof. use weqimplimpl. - exact (λ Hf, pr1 Hf). - intro Hf. split. + exact Hf. + exact (conservative_1cell_locally_groupoid HB f). - apply isaprop_discrete_1cell. - apply isaprop_faithful_1cell. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Eso.v000066400000000000000000000613471451125700300221650ustar00rootroot00000000000000(***************************************************************************** Eso 1-cells One way to define epimorphisms in categories, is via 'strong epimorphisms. A strong epimorphism is a morphism that has a lifting property with respect to monomorphisms. We can generalize this definition to bicategories since fully faithful 1-cells generalize monomorphisms. This gives rise to the notion of eso 1-cells. Usually, eso 1-cells are defined as follows: a 1-cell `f : b₁ --> b₂` is eso if for all fully faithful `m : c₁ --> c₂` the follow square is a weak pullback of categories B(b₁, c₁) -------------> B(b₁, c₂) | | | | V V B(b₂, c₁) -------------> B(b₂, c₂) We also consider an alternative definition in which we say that the canonical map from `B(b₁, c₁)` to the iso-comma category is an equivalence. We can then construct esos by using that fully faithful and essentially surjective functors are equivalences if the involved categories are univalent. From this formulation, we can also deduce a universal mapping property. In this file, we consider both definitions, and we show that they are indeed equivalent. Contents 1. Esos 2. Constructing esos 3. Projections for esos 4. Esos via pullbacks 5. Equivalence of the definitions 6. (eso, ff)-factorization 7. Closure under pullbacks *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Import PullbackFunctions.Notations. Require Import UniMath.Bicategories.Limits.PullbackEquivalences. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Local Open Scope cat. Section EsoMorphisms. Context {B : bicat} {b₁ b₂ : B} (f : b₁ --> b₂). (** 1. Esos *) Definition pre_comp_post_comp_commute {c₁ c₂ : B} (m : c₁ --> c₂) : pre_comp c₁ f ∙ post_comp b₁ m ⟹ post_comp b₂ m ∙ pre_comp c₂ f. Proof. use make_nat_trans. - exact (λ _, rassociator _ _ _). - abstract (intros h₁ h₂ α ; cbn ; rewrite rwhisker_lwhisker_rassociator ; apply idpath). Defined. Definition pre_comp_post_comp_commute_z_iso {c₁ c₂ : B} (m : c₁ --> c₂) : nat_z_iso (pre_comp c₁ f ∙ post_comp b₁ m) (post_comp b₂ m ∙ pre_comp c₂ f). Proof. use make_nat_z_iso. - exact (pre_comp_post_comp_commute m). - intro. use is_inv2cell_to_is_z_iso ; cbn. is_iso. Defined. Definition is_eso_functor {c₁ c₂ : B} (m : c₁ --> c₂) : hom b₂ c₁ ⟶ iso_comma (post_comp b₁ m) (pre_comp c₂ f). Proof. use iso_comma_ump1. - exact (pre_comp c₁ f). - exact (post_comp b₂ m). - exact (pre_comp_post_comp_commute_z_iso m). Defined. Definition is_eso : UU := ∏ (c₁ c₂ : B) (m : c₁ --> c₂) (Hm : fully_faithful_1cell m), adj_equivalence_of_cats (is_eso_functor m). Definition isaprop_is_eso (HB_2_1 : is_univalent_2_1 B) : isaprop is_eso. Proof. use impred ; intro c₁. use impred ; intro c₂. use impred ; intro m. use impred ; intro H. use (isofhlevelweqf 1 (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 b₂ c₁) (@univalent_iso_comma (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) (is_eso_functor m))). apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Defined. (** 2. Constructing esos *) (** To construct an eso, one should do 3 things. First of all, one needs to construct a lift for diagrams of the following shape g₁ b₁ -------> c₁ | | f | | m | | V V b₂ -------> c₂ g₂ where m is a fully faithful 1-cell. This diagram commutes up to an invertible 2-cell. The resulting triangles should commute up to an invertible 2-cell and the obvious coherency must be satisfied up to equality. This expresses that the relevant functor is essentially surjective. *) Definition is_eso_essentially_surjective : UU := ∏ (c₁ c₂ : B) (m : c₁ --> c₂) (Hm : fully_faithful_1cell m) (g₁ : b₁ --> c₁) (g₂ : b₂ --> c₂) (α : invertible_2cell (g₁ · m) (f · g₂)), ∑ (l : b₂ --> c₁) (ζ₁ : invertible_2cell (f · l) g₁) (ζ₂ : invertible_2cell (l · m) g₂), (ζ₁ ▹ m) • α = rassociator _ _ _ • (f ◃ ζ₂). (** The second thing allows us to construct 2-cells between lifts. This expresses that the relevant functor is full. *) Definition is_eso_full : UU := ∏ (c₁ c₂ : B) (m : c₁ --> c₂) (Hm : fully_faithful_1cell m) (l₁ l₂ : b₂ --> c₁) (k₁ : f · l₁ ==> f · l₂) (k₂ : l₁ · m ==> l₂ · m) (p : (k₁ ▹ m) • rassociator _ _ _ = rassociator _ _ _ • (f ◃ k₂)), ∑ (ξ : l₁ ==> l₂), f ◃ ξ = k₁ × ξ ▹ m = k₂. (** The last thing allows us to prove that 2-cells between lifts are equal. This expresses that the relevant functor is faithful. *) Definition is_eso_faithful : UU := ∏ (c₁ c₂ : B) (m : c₁ --> c₂) (Hm : fully_faithful_1cell m) (l₁ l₂ : b₂ --> c₁) (ζ₁ ζ₂ : l₁ ==> l₂), f ◃ ζ₁ = f ◃ ζ₂ → ζ₁ ▹ m = ζ₂ ▹ m → ζ₁ = ζ₂. (** Now we can give a constructor for eso morphisms if the bicategory is locally univalent. Note that local univalence is needed so that we can get an equivalence from functors that are essentially surjective and fully faithful. *) Section MakeEso. Context (HB_2_1 : is_univalent_2_1 B) (H₁ : is_eso_full) (H₂ : is_eso_faithful) (H₃ : is_eso_essentially_surjective). Section MakeEsoHelp. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m). Definition make_is_eso_full : full (is_eso_functor m). Proof. intros l₁ l₂. intro k. apply hinhpr. simple refine (_ ,, _) ; cbn. - exact (pr1 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k))). - abstract (use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ; exact (pathsdirprod (pr12 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k))) (pr22 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k))))). Defined. Definition make_is_eso_faithful : faithful (is_eso_functor m). Proof. intros l₁ l₂. intro im. use invproofirrelevance. intros ζ₁ ζ₂. use subtypePath. { intro. apply homset_property. } use (H₂ c₁ c₂ m Hm l₁ l₂ (pr1 ζ₁) (pr1 ζ₂)). - exact (maponpaths (λ z, pr11 z) (pr2 ζ₁) @ !(maponpaths (λ z, pr11 z) (pr2 ζ₂))). - exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr2 ζ₁) @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr2 ζ₂))). Qed. Definition make_is_eso_fully_faithful : fully_faithful (is_eso_functor m). Proof. use full_and_faithful_implies_fully_faithful. split. - exact make_is_eso_full. - exact make_is_eso_faithful. Defined. Definition make_is_eso_essentially_surjective : essentially_surjective (is_eso_functor m). Proof. intros h. pose (ℓ := H₃ c₁ c₂ m Hm (pr11 h) (pr21 h) (z_iso_to_inv2cell (pr2 h))). apply hinhpr. simple refine (_ ,, _). - exact (pr1 ℓ). - use make_z_iso'. + simple refine ((_ ,, _) ,, _) ; cbn. * exact (pr12 ℓ). * exact (pr122 ℓ). * exact (pr222 ℓ). + use is_z_iso_iso_comma. * use is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. * use is_inv2cell_to_is_z_iso. apply property_from_invertible_2cell. Defined. End MakeEsoHelp. Definition make_is_eso : is_eso. Proof. intros c₁ c₂ m Hm. use rad_equivalence_of_cats. - use is_univ_hom. exact HB_2_1. - exact (make_is_eso_fully_faithful Hm). - exact (make_is_eso_essentially_surjective Hm). Defined. End MakeEso. (** 3. Projections for esos *) Section Projections. Context (H : is_eso). (** Lifting property for for 1-cells *) Section LiftOne. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) (g₁ : b₁ --> c₁) (g₂ : b₂ --> c₂) (α : invertible_2cell (g₁ · m) (f · g₂)). Definition is_eso_lift_1 : b₂ --> c₁ := right_adjoint (H c₁ c₂ m Hm) ((g₁ ,, g₂) ,, inv2cell_to_z_iso α). Definition is_eso_lift_1_comm_left : invertible_2cell (f · is_eso_lift_1) g₁. Proof. apply z_iso_to_inv2cell. exact (functor_on_z_iso (iso_comma_pr1 _ _) (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ((g₁ ,, g₂) ,, inv2cell_to_z_iso α))). Defined. Definition is_eso_lift_1_comm_right : invertible_2cell (is_eso_lift_1 · m) g₂. Proof. apply z_iso_to_inv2cell. exact (functor_on_z_iso (iso_comma_pr2 _ _) (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ((g₁ ,, g₂) ,, inv2cell_to_z_iso α))). Defined. Definition is_eso_lift_1_eq : (is_eso_lift_1_comm_left ▹ m) • α = rassociator _ _ _ • (f ◃ is_eso_lift_1_comm_right) := pr2 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) ((g₁ ,, g₂) ,, inv2cell_to_z_iso α)). End LiftOne. (** Lifting property for for 2-cells *) Section LiftTwo. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) (l₁ l₂ : b₂ --> c₁) (k₁ : f · l₁ ==> f · l₂) (k₂ : l₁ · m ==> l₂ · m) (p : (k₁ ▹ m) • rassociator _ _ _ = rassociator _ _ _ • (f ◃ k₂)). Let R : iso_comma (post_comp b₁ m) (pre_comp c₂ f) ⟶ hom b₂ c₁ := right_adjoint (H c₁ c₂ m Hm). Let φ : iso_comma (post_comp b₁ m) (pre_comp c₂ f) := (f · l₁ ,, l₁ · m) ,, inv2cell_to_z_iso (rassociator_invertible_2cell _ _ _). Let ψ : iso_comma (post_comp b₁ m) (pre_comp c₂ f) := (f · l₂ ,, l₂ · m) ,, inv2cell_to_z_iso (rassociator_invertible_2cell _ _ _). Let μ : φ --> ψ := (k₁ ,, k₂) ,, p. Let η₁ : l₁ ==> R φ := unit_from_left_adjoint (H c₁ c₂ m Hm) l₁. Let η₂ : R ψ ==> l₂ := z_iso_to_inv2cell (unit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) l₂)^-1. Let ε₁ : f · R φ ==> f · l₁ := pr11 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) φ). Let ε₂ : f · R ψ ==> f · l₂ := pr11 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) ψ). Let ε₁' : R φ · m ==> l₁ · m := pr21 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) φ). Let ε₂' : R ψ · m ==> l₂ · m := pr21 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) ψ). Definition is_eso_lift_2 : l₁ ==> l₂ := η₁ • #R μ • η₂. Local Lemma is_eso_lift_2_counit_invertible : is_invertible_2cell ε₂. Proof. exact (property_from_invertible_2cell (z_iso_to_inv2cell (functor_on_z_iso (iso_comma_pr1 _ _) (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ψ)))). Qed. Local Lemma is_eso_lift_2_left_path_1 : (f ◃ #R μ) • ε₂ = ε₁ • k₁. Proof. exact (maponpaths (λ z, pr11 z) (nat_trans_ax (counit_from_left_adjoint (H c₁ c₂ m Hm)) _ _ μ)). Qed. Local Lemma is_eso_lift_2_left_path_2 : (f ◃ η₁) • ε₁ = id2 _. Proof. exact (maponpaths (λ z, pr11 z) (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₁)). Qed. Definition is_eso_lift_2_left : f ◃ is_eso_lift_2 = k₁. Proof. unfold is_eso_lift_2. rewrite <- !lwhisker_vcomp. use vcomp_move_R_Mp. { unfold η₂. is_iso. } use (vcomp_rcancel ε₂). { exact is_eso_lift_2_counit_invertible. } rewrite !vassocl. etrans. { apply maponpaths. exact is_eso_lift_2_left_path_1. } cbn. rewrite !vassocr. etrans. { apply maponpaths_2. exact is_eso_lift_2_left_path_2. } rewrite id2_left. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. exact (maponpaths (λ z, pr11 z) (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₂)). } cbn. rewrite id2_right. apply idpath. Qed. Local Lemma is_eso_lift_2_counit_invertible' : is_invertible_2cell ε₂'. Proof. exact (property_from_invertible_2cell (z_iso_to_inv2cell (functor_on_z_iso (iso_comma_pr2 _ _) (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ψ)))). Qed. Local Lemma is_eso_lift_2_right_path_1 : (#R μ ▹ m) • ε₂' = ε₁' • k₂. Proof. exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (nat_trans_ax (counit_from_left_adjoint (H c₁ c₂ m Hm)) _ _ μ)). Qed. Local Lemma is_eso_lift_2_right_path_2 : (η₁ ▹ m) • ε₁' = id2 _. Proof. exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₁)). Qed. Definition is_eso_lift_2_right : is_eso_lift_2 ▹ m = k₂. Proof. unfold is_eso_lift_2. rewrite <- !rwhisker_vcomp. use vcomp_move_R_Mp. { unfold η₂. is_iso. } cbn. use (vcomp_rcancel ε₂'). { exact is_eso_lift_2_counit_invertible'. } rewrite !vassocl. etrans. { apply maponpaths. exact is_eso_lift_2_right_path_1. } rewrite !vassocr. etrans. { apply maponpaths_2. exact is_eso_lift_2_right_path_2. } rewrite id2_left. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₂)). } apply id2_right. Qed. End LiftTwo. (** Lifting property for for equalities *) Definition is_eso_lift_eq {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) {l₁ l₂ : b₂ --> c₁} (ζ₁ ζ₂ : l₁ ==> l₂) (p₁ : f ◃ ζ₁ = f ◃ ζ₂) (p₂ : ζ₁ ▹ m = ζ₂ ▹ m) : ζ₁ = ζ₂. Proof. pose (pr2 (fully_faithful_implies_full_and_faithful _ _ _ (fully_faithful_from_equivalence _ _ _ (H c₁ c₂ m Hm))) l₁ l₂) as Heq. assert (((f ◃ ζ₁) ▹ m) • rassociator f l₂ m = rassociator f l₁ m • (f ◃ (ζ₁ ▹ m))) as r₁. { refine (!_). apply rwhisker_lwhisker_rassociator. } assert (((f ◃ ζ₂) ▹ m) • rassociator f l₂ m = rassociator f l₁ m • (f ◃ (ζ₂ ▹ m))) as r₂. { refine (!_). apply rwhisker_lwhisker_rassociator. } pose (proofirrelevance _ (Heq ((f ◃ ζ₁ ,, ζ₁ ▹ m) ,, r₁))) as Hprop. refine (maponpaths pr1 (Hprop (_ ,, _) (_ ,, _))). - use subtypePath. { intro. apply cellset_property. } cbn. apply idpath. - use subtypePath. { intro. apply cellset_property. } cbn. use pathsdirprod. + exact (!p₁). + exact (!p₂). Qed. End Projections. (** 4. Esos via pullbacks *) Definition is_eso_via_pb_cone (HB_2_1 : is_univalent_2_1 B) {c₁ c₂ : B} (m : c₁ --> c₂) (Hm : fully_faithful_1cell m) : @pb_cone bicat_of_univ_cats (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f). Proof. use make_pb_cone. - exact (univ_hom HB_2_1 b₂ c₁). - exact (pre_comp c₁ f). - exact (post_comp b₂ m). - use nat_z_iso_to_invertible_2cell. exact (pre_comp_post_comp_commute_z_iso m). Defined. Definition is_eso_via_pb (HB_2_1 : is_univalent_2_1 B) : UU := ∏ (c₁ c₂ : B) (m : c₁ --> c₂) (Hm : fully_faithful_1cell m), has_pb_ump (is_eso_via_pb_cone HB_2_1 m Hm). Definition isaprop_is_eso_via_pb (HB_2_1 : is_univalent_2_1 B) : isaprop (is_eso_via_pb HB_2_1). Proof. use impred ; intro c₁. use impred ; intro c₂. use impred ; intro m. use impred ; intro Hm. use isaprop_has_pb_ump. exact univalent_cat_is_univalent_2_1. Defined. (** 5. Equivalence of the definitions *) Definition is_eso_to_is_eso_via_pb (HB_2_1 : is_univalent_2_1 B) (Hf : is_eso) : is_eso_via_pb HB_2_1. Proof. intros c₁ c₂ m Hm. specialize (Hf c₁ c₂ m Hm). use (left_adjoint_equivalence_to_pb _ _ _ (@iso_comma_has_pb_ump (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) _ _). - exact univalent_cat_is_univalent_2_0. - exact (is_eso_functor m). - exact (@equiv_cat_to_adj_equiv (univ_hom HB_2_1 b₂ c₁) (@univalent_iso_comma (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) (is_eso_functor m) Hf). - use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + use make_nat_trans. * exact (λ _, id2 _). * abstract (intros h₁ h₂ α ; cbn ; rewrite id2_left, id2_right ; apply idpath). + intro. use is_inv2cell_to_is_z_iso ; cbn. is_iso. - use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + use make_nat_trans. * exact (λ _, id2 _). * abstract (intros h₁ h₂ α ; cbn ; rewrite id2_left, id2_right ; apply idpath). + intro. use is_inv2cell_to_is_z_iso ; cbn. is_iso. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite id2_rwhisker, lwhisker_id2 ; rewrite !id2_left, !id2_right ; apply idpath). Defined. Definition is_eso_via_pb_to_is_eso_nat_trans (HB_2_1 : is_univalent_2_1 B) {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) : is_eso_functor m ⟹ pr1 (pb_ump_mor (@iso_comma_has_pb_ump (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) (is_eso_via_pb_cone HB_2_1 m Hm)). Proof. use make_nat_trans. - intro h. simple refine ((id2 _ ,, id2 _) ,, _). abstract (cbn ; rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right ; apply idpath). - abstract (intros h₁ h₂ γ ; use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ; rewrite !id2_left, !id2_right ; apply idpath). Defined. Definition is_eso_via_pb_to_is_eso (HB_2_1 : is_univalent_2_1 B) (Hf : is_eso_via_pb HB_2_1) : is_eso. Proof. intros c₁ c₂ m Hm. specialize (Hf c₁ c₂ m Hm). apply (@adj_equiv_to_equiv_cat (univ_hom HB_2_1 b₂ c₁) (@univalent_iso_comma (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) (is_eso_functor m)). pose (pb_ump_mor_left_adjoint_equivalence _ _ (@iso_comma_has_pb_ump (univ_hom HB_2_1 b₁ c₁) (univ_hom HB_2_1 b₂ c₂) (univ_hom HB_2_1 b₁ c₂) (post_comp b₁ m) (pre_comp c₂ f)) Hf) as p. use (left_adjoint_equivalence_invertible p). - exact (is_eso_via_pb_to_is_eso_nat_trans HB_2_1 Hm). - use is_nat_z_iso_to_is_invertible_2cell. intro. use is_z_iso_iso_comma. + use is_inv2cell_to_is_z_iso ; cbn. is_iso. + use is_inv2cell_to_is_z_iso ; cbn. is_iso. Defined. Definition is_eso_weq_is_eso_via_pb (HB_2_1 : is_univalent_2_1 B) : is_eso ≃ is_eso_via_pb HB_2_1. Proof. use weqimplimpl. - exact (is_eso_to_is_eso_via_pb HB_2_1). - exact (is_eso_via_pb_to_is_eso HB_2_1). - exact (isaprop_is_eso HB_2_1). - exact (isaprop_is_eso_via_pb HB_2_1). Defined. End EsoMorphisms. (** 6. (eso, ff)-factorization *) Definition eso_ff_factorization (B : bicat) : UU := ∏ (b₁ b₂ : B) (f : b₁ --> b₂), ∑ (im : B) (m : im --> b₂) (f' : b₁ --> im), fully_faithful_1cell m × is_eso f' × invertible_2cell (f' · m) f. (** 7. Closure under pullbacks *) Definition is_eso_closed_under_pb (B : bicat_with_pb) : UU := ∏ (x y z : B) (f : x --> z) (Hf : is_eso f) (g : y --> z), is_eso (π₂ : f /≃ g --> y). UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/000077500000000000000000000000001451125700300230135ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/EsosInBicatOfUnivCats.v000066400000000000000000000515241451125700300273160ustar00rootroot00000000000000(** Morphisms in the bicat of univalent categories Contents: 1. Esos 2. (eso, ff)-factorization 3. Esos are closed under pullback *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Eso. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Local Open Scope cat. Definition transportf_z_iso_functors {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ : C₁} (y : C₂) (p : x₁ = x₂) (i : z_iso (F x₁) y) : pr1 (transportf (λ (x : C₁), z_iso (F x) y) p i) = #F (inv_from_z_iso (idtoiso p)) · i. Proof. induction p ; cbn. rewrite functor_id. rewrite id_left. apply idpath. Qed. (** 1. Esos *) Section EsoIsEssentiallySurjective. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : is_eso F). Let im : bicat_of_univ_cats := univalent_image F. Let fim : C₁ --> im := functor_full_img F. Let π : im --> C₂ := sub_precategory_inclusion _ _. Definition eso_is_essentially_surjective_inv2cell : invertible_2cell (fim · π) (F · id₁ C₂). Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - use make_nat_trans. + exact (λ _, identity _). + abstract (intro ; intros ; cbn ; rewrite id_left, id_right ; apply idpath). - intro. apply identity_is_z_iso. Defined. Definition eso_is_essentially_surjective_lift : C₂ --> im := is_eso_lift_1 _ HF (cat_fully_faithful_is_fully_faithful_1cell π (fully_faithful_sub_precategory_inclusion _ _)) fim (id₁ _) eso_is_essentially_surjective_inv2cell. Let φ := eso_is_essentially_surjective_lift. Definition eso_is_essentially_surjective : essentially_surjective F. Proof. intro x. use (factor_through_squash _ _ (pr2 (pr1 φ x))). { apply ishinh. } intros q. use hinhpr. simple refine (_ ,, _). - exact (pr1 q). - simpl. refine (z_iso_comp (pr2 q) _). exact (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (is_eso_lift_1_comm_right _ HF (cat_fully_faithful_is_fully_faithful_1cell π (fully_faithful_sub_precategory_inclusion _ _)) fim (id₁ _) eso_is_essentially_surjective_inv2cell)) x). Defined. End EsoIsEssentiallySurjective. Section EssentiallySurjectiveIsEso. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : essentially_surjective F). Section EssentiallySurjectiveEsoFull. Context {D₁ D₂ : bicat_of_univ_cats} {G : D₁ --> D₂} (HG : fully_faithful_1cell G) {H₁ H₂ : C₂ --> D₁} (n₁ : F · H₁ ==> F · H₂) (n₂ : H₁ · G ==> H₂ · G) (p : (n₁ ▹ G) • rassociator F H₂ G = rassociator F H₁ G • (F ◃ n₂)). Definition essentially_surjective_is_eso_lift_2_data : nat_trans_data (pr1 H₁) (pr1 H₂) := λ x, invmap (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ x) (pr1 H₂ x))) (pr1 n₂ x). Definition essentially_surjective_is_eso_lift_2_is_nat_trans : is_nat_trans _ _ essentially_surjective_is_eso_lift_2_data. Proof. intros x y f. unfold essentially_surjective_is_eso_lift_2_data. pose (H := homotinvweqweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ x) (pr1 H₂ y)))). refine (!(H _) @ _ @ H _) ; clear H. apply maponpaths. cbn. rewrite !functor_comp. etrans. { apply maponpaths. apply (homotweqinvweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ y) (pr1 H₂ y)))). } refine (!_). etrans. { apply maponpaths_2. apply (homotweqinvweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ x) (pr1 H₂ x)))). } exact (!(nat_trans_ax n₂ _ _ f)). Qed. Definition essentially_surjective_is_eso_lift_2 : H₁ ==> H₂. Proof. use make_nat_trans. - exact essentially_surjective_is_eso_lift_2_data. - exact essentially_surjective_is_eso_lift_2_is_nat_trans. Defined. Definition essentially_surjective_is_eso_lift_2_left : F ◃ essentially_surjective_is_eso_lift_2 = n₁. Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. unfold essentially_surjective_is_eso_lift_2_data. pose (H := homotinvweqweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ (pr1 F x)) (pr1 H₂ (pr1 F x))))). refine (!(H _) @ _ @ H _) ; clear H. apply maponpaths. cbn. etrans. { apply (homotweqinvweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG (pr1 H₁ (pr1 F x)) (pr1 H₂ (pr1 F x))))). } refine (_ @ !(nat_trans_eq_pointwise p x) @ _) ; cbn. - rewrite id_left. apply idpath. - rewrite id_right. apply idpath. Qed. Definition essentially_surjective_is_eso_lift_2_right : essentially_surjective_is_eso_lift_2 ▹ G = n₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. unfold essentially_surjective_is_eso_lift_2_data. apply (homotweqinvweq (make_weq _ (cat_fully_faithful_1cell_is_fully_faithful _ HG _ _))). Qed. End EssentiallySurjectiveEsoFull. Definition essentially_surjective_is_eso_full : is_eso_full F. Proof. intros D₁ D₂ G HG H₁ H₂ n₁ n₂ p. simple refine (_ ,, _ ,, _). - exact (essentially_surjective_is_eso_lift_2 HG n₂). - exact (essentially_surjective_is_eso_lift_2_left HG _ _ p). - apply essentially_surjective_is_eso_lift_2_right. Defined. Definition essentially_surjective_is_eso_faithful : is_eso_faithful F. Proof. intros D₁ D₂ G HG H₁ H₂ n₁ n₂ p₁ p₂. use nat_trans_eq. { apply homset_property. } intro y. use (factor_through_squash _ _ (HF y)). - apply homset_property. - intro xx. induction xx as [ x i ]. use (cancel_precomposition_z_iso (functor_on_z_iso H₁ i)). cbn. rewrite !nat_trans_ax. apply maponpaths_2. exact (nat_trans_eq_pointwise p₁ x). Qed. Section EssentiallySurjectiveLift. Context {D₁ D₂ : bicat_of_univ_cats} {G : D₁ --> D₂} (HG : fully_faithful_1cell G) (H₁ : C₁ --> D₁) (H₂ : C₂ --> D₂) (α : invertible_2cell (H₁ · G) (F · H₂)). Let HG' : fully_faithful G := cat_fully_faithful_1cell_is_fully_faithful _ HG. Let α' : nat_z_iso (H₁ ∙ G) (F ∙ H₂) := invertible_2cell_to_nat_z_iso _ _ α. Local Definition isaprop_ob_fiber (y : pr1 C₂) : isaprop (∑ (x : pr1 D₁), z_iso (pr1 G x) (pr1 H₂ y)). Proof. use invproofirrelevance. intros φ₁ φ₂. use total2_paths_f. - apply (isotoid _ (pr2 D₁)). exact (make_z_iso' _ (fully_faithful_reflects_iso_proof _ _ _ HG' _ _ (z_iso_comp (pr2 φ₁) (z_iso_inv_from_z_iso (pr2 φ₂))))). - use subtypePath. { intro. apply isaprop_is_z_isomorphism. } etrans. { apply transportf_z_iso_functors. } rewrite functor_on_inv_from_z_iso. use z_iso_inv_on_right. refine (!_). etrans. { apply maponpaths_2. cbn. rewrite idtoiso_isotoid. apply (homotweqinvweq (make_weq _ (HG' _ _)) _). } rewrite !assoc'. rewrite z_iso_after_z_iso_inv. apply id_right. Qed. Local Definition iscontr_ob_fiber (y : pr1 C₂) : iscontr (∑ (x : pr1 D₁), z_iso (pr1 G x) (pr1 H₂ y)). Proof. use (factor_through_squash _ _ (HF y)). - apply isapropiscontr. - intros z. use iscontraprop1. + exact (isaprop_ob_fiber y). + refine (pr1 H₁ (pr1 z) ,, _). exact (z_iso_comp (nat_z_iso_pointwise_z_iso α' (pr1 z)) (functor_on_z_iso H₂ (pr2 z))). Defined. (* upstream *) Local Lemma cancel_postcomposition_z_iso : ∏ {C : precategory} {a b c : C} (h : z_iso b c) (f g : C ⟦ a, b ⟧), f · h = g · h → f = g. Proof. intros. use post_comp_with_z_iso_is_inj. - exact c. - exact (pr1 h). - exact (pr1 (pr2 h)). - exact (pr2 (pr2 h)). - assumption. Qed. Local Definition isaprop_mor_fiber {y₁ y₂ : pr1 C₂} (g : y₁ --> y₂) {x₁ x₂ : pr1 D₁} (i₁ : z_iso (pr1 G x₁) (pr1 H₂ y₁)) (i₂ : z_iso (pr1 G x₂) (pr1 H₂ y₂)) : isaprop (∑ (f : x₁ --> x₂), i₁ · # (pr1 H₂) g = # (pr1 G) f · i₂). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (invmaponpathsweq (make_weq _ (HG' x₁ x₂))) ; cbn. use (cancel_postcomposition_z_iso i₂). exact (!(pr2 φ₁) @ pr2 φ₂). Qed. Local Definition iscontr_mor_fiber {y₁ y₂ : pr1 C₂} (g : y₁ --> y₂) {x₁ x₂ : pr1 D₁} (i₁ : z_iso (pr1 G x₁) (pr1 H₂ y₁)) (i₂ : z_iso (pr1 G x₂) (pr1 H₂ y₂)) : iscontr (∑ (f : x₁ --> x₂), i₁ · # (pr1 H₂) g = # (pr1 G) f · i₂). Proof. pose (HG'' := pr1 (fully_faithful_implies_full_and_faithful _ _ _ HG') x₁ x₂ (i₁ · #(pr1 H₂) g · inv_from_z_iso i₂)). use (factor_through_squash _ _ HG''). - apply isapropiscontr. - intro f. apply iscontraprop1. + exact (isaprop_mor_fiber g i₁ i₂). + refine (pr1 f ,, _). abstract (pose (p := pr2 f) ; cbn in p ; refine (!_) ; refine (maponpaths (λ z, z · _) p @ _) ; rewrite !assoc' ; rewrite z_iso_after_z_iso_inv ; rewrite id_right ; apply idpath). Defined. Local Definition mor_fiber_eq {y₁ y₂ : pr1 C₂} (g : y₁ --> y₂) {x₁ x₂ : pr1 D₁} (i₁ : z_iso (pr1 G x₁) (pr1 H₂ y₁)) (i₂ : z_iso (pr1 G x₂) (pr1 H₂ y₂)) (h : x₁ --> x₂) (p : i₁ · # (pr1 H₂) g = # (pr1 G) h · i₂) : pr11 (iscontr_mor_fiber g i₁ i₂) = h. Proof. refine (!_). exact (maponpaths pr1 (pr2 (iscontr_mor_fiber g i₁ i₂) (h ,, p))). Qed. Local Definition essentially_surjective_is_eso_lift_data : functor_data (pr1 C₂) (pr1 D₁). Proof. use make_functor_data. - exact (λ y, pr11 (iscontr_ob_fiber y)). - intros y₁ y₂ g. exact (pr11 (iscontr_mor_fiber g (pr21 (iscontr_ob_fiber y₁)) (pr21 (iscontr_ob_fiber y₂)))). Defined. Local Definition essentially_surjective_is_eso_lift_is_functor : is_functor essentially_surjective_is_eso_lift_data. Proof. split. - intro y ; cbn. use mor_fiber_eq. rewrite (functor_id H₂), (functor_id G). rewrite id_left, id_right. apply idpath. - intros y₁ y₂ y₃ g₁ g₂ ; cbn. use mor_fiber_eq. rewrite (functor_comp H₂). rewrite !assoc. etrans. { apply maponpaths_2. exact (pr21 (iscontr_mor_fiber g₁ (pr21 (iscontr_ob_fiber y₁)) (pr21 (iscontr_ob_fiber y₂)))). } rewrite (functor_comp G). rewrite !assoc'. apply maponpaths. exact (pr21 (iscontr_mor_fiber g₂ (pr21 (iscontr_ob_fiber y₂)) (pr21 (iscontr_ob_fiber y₃)))). Qed. Definition essentially_surjective_is_eso_lift : C₂ --> D₁. Proof. use make_functor. - exact essentially_surjective_is_eso_lift_data. - exact essentially_surjective_is_eso_lift_is_functor. Defined. Local Definition essentially_surjective_is_eso_lift_left_nat_trans_data : nat_trans_data (F ∙ essentially_surjective_is_eso_lift) (pr1 H₁) := λ x, fully_faithful_inv_hom HG' _ _ (pr21 (iscontr_ob_fiber (pr1 F x)) · inv_from_z_iso (nat_z_iso_pointwise_z_iso α' x)). Local Definition essentially_surjective_is_eso_lift_left_is_nat_trans : is_nat_trans _ _ essentially_surjective_is_eso_lift_left_nat_trans_data. Proof. intros x y f ; cbn. use (invmaponpathsweq (make_weq _ (HG' _ _))). cbn. refine (functor_comp _ _ _@ _ @ !(functor_comp _ _ _)). etrans. { apply maponpaths. apply (homotweqinvweq (make_weq _ (HG' _ _))). } refine (!_). etrans. { apply maponpaths_2. apply (homotweqinvweq (make_weq _ (HG' _ _))). } refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. exact (!(pr21 (iscontr_mor_fiber (#(pr1 F) f) (pr21 (iscontr_ob_fiber (pr1 F x))) (pr21 (iscontr_ob_fiber (pr1 F y)))))). } rewrite !assoc'. apply maponpaths. apply (nat_trans_ax (α^-1)). Qed. Definition essentially_surjective_is_eso_lift_left_nat_trans : F ∙ essentially_surjective_is_eso_lift ⟹ pr1 H₁. Proof. use make_nat_trans. - exact essentially_surjective_is_eso_lift_left_nat_trans_data. - exact essentially_surjective_is_eso_lift_left_is_nat_trans. Defined. Definition essentially_surjective_is_eso_lift_left : invertible_2cell (F · essentially_surjective_is_eso_lift) H₁. Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact essentially_surjective_is_eso_lift_left_nat_trans. - intro. use (fully_faithful_reflects_iso_proof _ _ _ HG' _ _ (make_z_iso' _ _)). use is_z_iso_comp_of_is_z_isos. + apply z_iso_is_z_isomorphism. + apply is_z_iso_inv_from_z_iso. Defined. Definition essentially_surjective_is_eso_lift_right_nat_trans : essentially_surjective_is_eso_lift ∙ G ⟹ pr1 H₂. Proof. use make_nat_trans. - exact (λ y, pr21 (iscontr_ob_fiber y)). - abstract (intros y₁ y₂ f ; cbn ; exact (!(pr21 (iscontr_mor_fiber f (pr21 (iscontr_ob_fiber y₁)) (pr21 (iscontr_ob_fiber y₂)))))). Defined. Definition essentially_surjective_is_eso_lift_right : invertible_2cell (essentially_surjective_is_eso_lift · G) H₂. Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact essentially_surjective_is_eso_lift_right_nat_trans. - intro. apply z_iso_is_z_isomorphism. Defined. Definition essentially_surjective_is_eso_lift_eq : (essentially_surjective_is_eso_lift_left ▹ G) • α = rassociator _ _ _ • (F ◃ essentially_surjective_is_eso_lift_right). Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. refine (_ @ !(id_left _)). etrans. { apply maponpaths_2. exact (homotweqinvweq (make_weq _ (HG' _ _)) _). } rewrite assoc'. refine (_ @ id_right _). apply maponpaths. exact (nat_trans_eq_pointwise (vcomp_linv α) x). Qed. End EssentiallySurjectiveLift. Definition essentially_surjective_is_eso_essentially_surjective : is_eso_essentially_surjective F. Proof. intros D₁ D₂ G HG H₁ H₂ α. simple refine (_ ,, _ ,, _ ,, _). - exact (essentially_surjective_is_eso_lift HG H₁ H₂ α). - exact (essentially_surjective_is_eso_lift_left HG H₁ H₂ α). - exact (essentially_surjective_is_eso_lift_right HG H₁ H₂ α). - exact (essentially_surjective_is_eso_lift_eq HG H₁ H₂ α). Defined. Definition essentially_surjective_is_eso : is_eso F. Proof. use make_is_eso. - exact univalent_cat_is_univalent_2_1. - exact essentially_surjective_is_eso_full. - exact essentially_surjective_is_eso_faithful. - exact essentially_surjective_is_eso_essentially_surjective. Defined. End EssentiallySurjectiveIsEso. Definition eso_weq_essentially_surjective {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : is_eso F ≃ essentially_surjective F. Proof. use weqimplimpl. - exact eso_is_essentially_surjective. - exact essentially_surjective_is_eso. - apply isaprop_is_eso. exact univalent_cat_is_univalent_2_1. - apply isaprop_essentially_surjective. Defined. (** 2. (eso, ff)-factorization *) Definition eso_ff_factorization_bicat_of_univ_cats : eso_ff_factorization bicat_of_univ_cats. Proof. intros C₁ C₂ F. refine (univalent_image F ,, sub_precategory_inclusion _ _ ,, functor_full_img _ ,, _). simple refine (_ ,, _ ,, _). - use cat_fully_faithful_is_fully_faithful_1cell. apply fully_faithful_sub_precategory_inclusion. - use essentially_surjective_is_eso. apply functor_full_img_essentially_surjective. - use nat_z_iso_to_invertible_2cell. exact (full_image_inclusion_commute_nat_iso F). Defined. (** 3. Esos are closed under pullback *) Definition is_eso_closed_under_pb_bicat_of_univ_cats : is_eso_closed_under_pb (_ ,, has_pb_bicat_of_univ_cats). Proof. intros C₁ C₂ C₃ F HF G. cbn. apply essentially_surjective_is_eso. apply iso_comma_essentially_surjective. apply eso_is_essentially_surjective. exact HF. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/FibrationsInBicatOfUnivCats.v000066400000000000000000001602251451125700300305040ustar00rootroot00000000000000(** Fibrations in the bicat of univalent categories Contents: 1. Internal Street Fibrations 2. Internal Street Opfibrations *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Local Open Scope cat. (** 1. Internal Street Fibrations *) Section InternalSFibToStreetFib. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : internal_sfib F). Section InternalSFibToStreetFibFactor. Context {G₁ G₂ : (unit_category : bicat_of_univ_cats) --> C₁} {α : G₁ ==> G₂} (Hα : is_cartesian_2cell_sfib F α) {z : pr1 C₁} {g : z --> pr1 G₂ tt} {h : pr1 F z --> pr1 F (pr1 G₁ tt)} (q : # (pr1 F) g = h · # (pr1 F) (pr1 α tt)). Let Φ : unit_category ⟶ pr1 C₁ := functor_from_unit z. Local Definition internal_sfib_is_cartesian_sfib_factor_nat_trans_1 : Φ ⟹ pr1 G₂. Proof. use make_nat_trans. - intro x ; induction x. exact g. - abstract (intros x y f ; cbn ; induction x ; induction y ; cbn ; assert (p : f = identity _) ; [ apply isapropunit | ] ; rewrite p ; refine (id_left _ @ !(id_right _) @ _) ; apply maponpaths ; refine (!_) ; apply functor_id). Defined. Let ζ := internal_sfib_is_cartesian_sfib_factor_nat_trans_1. Local Definition internal_sfib_is_cartesian_sfib_factor_nat_trans_2 : Φ ∙ F ⟹ G₁ ∙ F. Proof. use make_nat_trans. - intros x ; induction x. exact h. - abstract (intros x y f ; cbn ; induction x ; induction y ; cbn ; assert (p : f = identity _) ; [ apply isapropunit | ] ; rewrite p ; rewrite (functor_id G₁) ; rewrite !(functor_id F) ; rewrite id_left, id_right ; apply idpath). Defined. Let ξ := internal_sfib_is_cartesian_sfib_factor_nat_trans_2. Local Lemma internal_sfib_is_cartesian_sfib_factor_eq : post_whisker ζ F = nat_trans_comp _ _ _ ξ (post_whisker α F). Proof. use nat_trans_eq. { apply homset_property. } intro x ; induction x. exact q. Qed. Let p := internal_sfib_is_cartesian_sfib_factor_eq. Definition internal_sfib_is_cartesian_sfib_factor : z --> pr1 G₁ tt := pr1 (is_cartesian_2cell_sfib_factor _ Hα ζ ξ p) tt. Definition internal_sfib_is_cartesian_sfib_factor_over : # (pr1 F) internal_sfib_is_cartesian_sfib_factor = h. Proof. exact (nat_trans_eq_pointwise (is_cartesian_2cell_sfib_factor_over _ Hα p) tt). Qed. Definition internal_sfib_is_cartesian_sfib_factor_comm : internal_sfib_is_cartesian_sfib_factor · pr1 α tt = g. Proof. exact (nat_trans_eq_pointwise (is_cartesian_2cell_sfib_factor_comm _ Hα p) tt). Qed. Local Definition internal_sfib_is_cartesian_sfib_factor_unique_help (k : z --> pr1 G₁ tt) : Φ ⟹ pr1 G₁. Proof. use make_nat_trans. - intro x ; induction x. exact k. - abstract (intros x y f ; induction x ; induction y ; cbn ; assert (r : f = identity _) ; [ apply isapropunit | ] ; rewrite r ; rewrite !(functor_id G₁) ; rewrite id_left, id_right ; apply idpath). Defined. Definition internal_sfib_is_cartesian_sfib_factor_unique : isaprop (∑ φ, # (pr1 F) φ = h × φ · pr1 α tt = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } refine (nat_trans_eq_pointwise (is_cartesian_2cell_sfib_factor_unique _ Hα Φ ζ ξ p (internal_sfib_is_cartesian_sfib_factor_unique_help (pr1 φ₁)) (internal_sfib_is_cartesian_sfib_factor_unique_help (pr1 φ₂)) _ _ _ _) tt) ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro x ; induction x ; cbn. - exact (pr12 φ₁). - exact (pr12 φ₂). - exact (pr22 φ₁). - exact (pr22 φ₂). Qed. End InternalSFibToStreetFibFactor. Definition internal_sfib_is_cartesian_sfib {G₁ G₂ : (unit_category : bicat_of_univ_cats) --> C₁} {α : G₁ ==> G₂} (Hα : is_cartesian_2cell_sfib F α) : is_cartesian_sfib F (pr1 α tt). Proof. intros z g h q. use iscontraprop1. - exact (internal_sfib_is_cartesian_sfib_factor_unique Hα q). - simple refine (_ ,, _ ,, _). + exact (internal_sfib_is_cartesian_sfib_factor Hα q). + exact (internal_sfib_is_cartesian_sfib_factor_over Hα q). + exact (internal_sfib_is_cartesian_sfib_factor_comm Hα q). Defined. Section Cleaving. Context {e : pr1 C₁} {b : pr1 C₂} (f : b --> pr1 F e). Definition internal_sfib_is_street_fib_nat_trans : functor_from_unit b ⟹ functor_from_unit e ∙ F. Proof. use make_nat_trans. - exact (λ _, f). - abstract (intros z₁ z₂ g ; cbn ; rewrite id_left, functor_id, id_right ; apply idpath). Defined. Let ℓ := pr1 HF _ _ _ internal_sfib_is_street_fib_nat_trans. Definition internal_sfib_is_street_fib_lift_ob : pr1 C₁ := pr1 (pr1 ℓ) tt. Definition internal_sfib_is_street_fib_lift_mor : internal_sfib_is_street_fib_lift_ob --> e := pr1 (pr12 ℓ) tt. Definition internal_sfib_is_street_fib_lift_z_iso : z_iso (pr1 F internal_sfib_is_street_fib_lift_ob) b := nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (pr122 ℓ)) tt. Definition internal_sfib_is_street_fib_lift_over : # (pr1 F) internal_sfib_is_street_fib_lift_mor = internal_sfib_is_street_fib_lift_z_iso · f := nat_trans_eq_pointwise (pr2 (pr222 ℓ)) tt. Definition internal_sfib_is_street_fib_lift_cartesian : is_cartesian_sfib F internal_sfib_is_street_fib_lift_mor := internal_sfib_is_cartesian_sfib (pr1 (pr222 ℓ)). End Cleaving. Definition internal_sfib_is_street_fib : street_fib F. Proof. intros e b f. simple refine (_ ,, (_ ,, _) ,, _ ,, _) ; cbn. - exact (internal_sfib_is_street_fib_lift_ob f). - exact (internal_sfib_is_street_fib_lift_mor f). - exact (internal_sfib_is_street_fib_lift_z_iso f). - exact (internal_sfib_is_street_fib_lift_over f). - exact (internal_sfib_is_street_fib_lift_cartesian f). Defined. End InternalSFibToStreetFib. Section StreetFibToInternalSFib. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : street_fib F). Section IsCartesian. Context {C₀ : bicat_of_univ_cats} {G₁ G₂ : C₀ --> C₁} (α : G₁ ==> G₂) (Hα : ∏ (x : pr1 C₀), is_cartesian_sfib F (pr1 α x)). Section Factorization. Context {H : C₀ --> C₁} {β : H ==> G₂} {δp : H · F ==> G₁ · F} (q : β ▹ F = δp • (α ▹ F)). Definition pointwise_cartesian_is_cartesian_factor_data : nat_trans_data (pr1 H) (pr1 G₁) := λ x, cartesian_factorization_sfib _ (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x). Definition pointwise_cartesian_is_cartesian_factor_laws : is_nat_trans _ _ pointwise_cartesian_is_cartesian_factor_data. Proof. intros x y f ; unfold pointwise_cartesian_is_cartesian_factor_data ; cbn. pose (cartesian_factorization_sfib_commute F (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x)) as p. pose (cartesian_factorization_sfib_commute F (Hα y) (pr1 β y) (pr1 δp y) (nat_trans_eq_pointwise q y)) as p'. use (cartesian_factorization_sfib_unique _ (Hα y) (pr1 β x · # (pr1 G₂) f) (pr1 δp x · # (pr1 F) (# (pr1 G₁) f))). - rewrite functor_comp. pose (r := nat_trans_eq_pointwise q x) ; cbn in r. etrans. { apply maponpaths_2. exact r. } clear r. rewrite !assoc'. apply maponpaths. refine (!(functor_comp _ _ _) @ _ @ functor_comp _ _ _). apply maponpaths. exact (!(nat_trans_ax α _ _ f)). - rewrite functor_comp. rewrite cartesian_factorization_sfib_over. exact (nat_trans_ax δp _ _ f). - rewrite !functor_comp. rewrite cartesian_factorization_sfib_over. apply idpath. - rewrite !assoc'. etrans. { apply maponpaths. exact p'. } exact (nat_trans_ax β _ _ f). - rewrite !assoc'. etrans. { apply maponpaths. exact (nat_trans_ax α _ _ f). } rewrite assoc. apply maponpaths_2. exact p. Qed. Definition pointwise_cartesian_is_cartesian_factor : H ==> G₁. Proof. use make_nat_trans. - exact pointwise_cartesian_is_cartesian_factor_data. - exact pointwise_cartesian_is_cartesian_factor_laws. Defined. Definition pointwise_cartesian_is_cartesian_over : pointwise_cartesian_is_cartesian_factor ▹ F = δp. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply cartesian_factorization_sfib_over. Qed. Definition pointwise_cartesian_is_cartesian_comm : pointwise_cartesian_is_cartesian_factor • α = β. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply cartesian_factorization_sfib_commute. Qed. Definition pointwise_cartesian_is_cartesian_unique : isaprop (∑ (δ : H ==> G₁), δ ▹ F = δp × δ • α = β). Proof. use invproofirrelevance. intros δ₁ δ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro x. use (cartesian_factorization_sfib_unique _ (Hα x) (pr1 β x) (pr1 δp x)). - exact (nat_trans_eq_pointwise q x). - exact (nat_trans_eq_pointwise (pr12 δ₁) x). - exact (nat_trans_eq_pointwise (pr12 δ₂) x). - exact (nat_trans_eq_pointwise (pr22 δ₁) x). - exact (nat_trans_eq_pointwise (pr22 δ₂) x). Qed. End Factorization. Definition pointwise_cartesian_is_cartesian : is_cartesian_2cell_sfib F α. Proof. intros H β δp q. use iscontraprop1. - exact (pointwise_cartesian_is_cartesian_unique q). - simple refine (_ ,, _ ,, _). + exact (pointwise_cartesian_is_cartesian_factor q). + exact (pointwise_cartesian_is_cartesian_over q). + exact (pointwise_cartesian_is_cartesian_comm q). Defined. End IsCartesian. Section Cleaving. Context {C₀ : bicat_of_univ_cats} {G₁ : C₀ --> C₂} {G₂ : C₀ --> C₁} (α : G₁ ==> G₂ · F). Definition street_fib_is_internal_sfib_cleaving_lift_data : functor_data (pr1 C₀) (pr1 C₁). Proof. use make_functor_data. - exact (λ x, pr1 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x))). - intros x y f ; cbn. use (cartesian_factorization_sfib _ (pr222 (HF (pr1 G₂ y) (pr1 G₁ y) (pr1 α y)))). + exact (pr112 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)) · # (pr1 G₂) f). + exact (pr212 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)) · # (pr1 G₁) f · inv_from_z_iso (pr212 (HF (pr1 G₂ y) (pr1 G₁ y) (pr1 α y)))). + abstract (rewrite functor_comp ; rewrite (pr122 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x))) ; rewrite !assoc' ; apply maponpaths ; refine (!(nat_trans_ax α _ _ f) @ _) ; apply maponpaths ; refine (!_) ; use z_iso_inv_on_right ; rewrite (pr122 (HF (pr1 G₂ y) (pr1 G₁ y) (pr1 α y))) ; apply idpath). Defined. Definition street_fib_is_internal_sfib_cleaving_lift_is_functor : is_functor street_fib_is_internal_sfib_cleaving_lift_data. Proof. split. - intro x ; cbn. use (cartesian_factorization_sfib_unique _ (pr222 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)))). + exact (pr112 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x))). + apply identity. + rewrite id_left. apply idpath. + rewrite cartesian_factorization_sfib_over. refine (!_). use z_iso_inv_on_left. rewrite id_left. rewrite (functor_id G₁). rewrite id_right. apply idpath. + apply functor_id. + rewrite cartesian_factorization_sfib_commute. rewrite (functor_id G₂). apply id_right. + apply id_left. - intros x y z f g ; cbn. use (cartesian_factorization_sfib_unique _ (pr222 (HF (pr1 G₂ z) (pr1 G₁ z) (pr1 α z)))). + exact (pr112 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)) · # (pr1 G₂) (f · g)). + exact (pr212 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)) · # (pr1 G₁) (f · g) · inv_from_z_iso (pr212 (HF (pr1 G₂ z) (pr1 G₁ z) (pr1 α z)))). + rewrite functor_comp. etrans. { apply maponpaths_2. exact (pr122 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x))). } rewrite !assoc'. apply maponpaths. refine (!(nat_trans_ax α _ _ (f · g)) @ _). apply maponpaths. refine (!_). use z_iso_inv_on_right. exact (pr122 (HF (pr1 G₂ z) (pr1 G₁ z) (pr1 α z))). + apply cartesian_factorization_sfib_over. + rewrite functor_comp. rewrite !cartesian_factorization_sfib_over. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite (functor_comp G₁). rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite z_iso_after_z_iso_inv. apply id_left. + apply cartesian_factorization_sfib_commute. + rewrite !assoc'. rewrite cartesian_factorization_sfib_commute. rewrite !assoc. rewrite cartesian_factorization_sfib_commute. rewrite !assoc'. rewrite (functor_comp G₂). apply idpath. Qed. Definition street_fib_is_internal_sfib_cleaving_lift : C₀ --> C₁. Proof. use make_functor. - exact street_fib_is_internal_sfib_cleaving_lift_data. - exact street_fib_is_internal_sfib_cleaving_lift_is_functor. Defined. Definition street_fib_is_internal_sfib_cleaving_lift_mor_data : nat_trans_data street_fib_is_internal_sfib_cleaving_lift_data (pr1 G₂) := λ x, pr112 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)). Definition street_fib_is_internal_sfib_cleaving_lift_mor_is_nat_trans : is_nat_trans _ _ street_fib_is_internal_sfib_cleaving_lift_mor_data. Proof. intros x y f ; cbn. apply cartesian_factorization_sfib_commute. Qed. Definition street_fib_is_internal_sfib_cleaving_lift_mor : street_fib_is_internal_sfib_cleaving_lift ==> G₂. Proof. use make_nat_trans. - exact street_fib_is_internal_sfib_cleaving_lift_mor_data. - exact street_fib_is_internal_sfib_cleaving_lift_mor_is_nat_trans. Defined. Definition street_fib_is_internal_sfib_cleaving_lift_over_nat_trans_data : nat_trans_data (street_fib_is_internal_sfib_cleaving_lift ∙ F) (pr1 G₁) := λ x, pr212 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)). Definition street_fib_is_internal_sfib_cleaving_lift_over_is_nat_trans : is_nat_trans _ _ street_fib_is_internal_sfib_cleaving_lift_over_nat_trans_data. Proof. intros x y f ; cbn. unfold street_fib_is_internal_sfib_cleaving_lift_over_nat_trans_data. rewrite cartesian_factorization_sfib_over. rewrite !assoc'. rewrite z_iso_after_z_iso_inv. rewrite id_right. apply idpath. Qed. Definition street_fib_is_internal_sfib_cleaving_lift_over_nat_trans : street_fib_is_internal_sfib_cleaving_lift ∙ F ⟹ pr1 G₁. Proof. use make_nat_trans. - exact street_fib_is_internal_sfib_cleaving_lift_over_nat_trans_data. - exact street_fib_is_internal_sfib_cleaving_lift_over_is_nat_trans. Defined. Definition street_fib_is_internal_sfib_cleaving_lift_cartesian : is_cartesian_2cell_sfib F street_fib_is_internal_sfib_cleaving_lift_mor. Proof. use pointwise_cartesian_is_cartesian. intro x. exact (pr222 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x))). Defined. Definition street_fib_is_internal_sfib_cleaving_lift_over : invertible_2cell (street_fib_is_internal_sfib_cleaving_lift · F) G₁. Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact street_fib_is_internal_sfib_cleaving_lift_over_nat_trans. - intro x. apply z_iso_is_z_isomorphism. Defined. End Cleaving. Definition street_fib_is_internal_sfib_cleaving : internal_sfib_cleaving F. Proof. intros C₀ G₁ G₂ α. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (street_fib_is_internal_sfib_cleaving_lift α). - exact (street_fib_is_internal_sfib_cleaving_lift_mor α). - exact (street_fib_is_internal_sfib_cleaving_lift_over α). - exact (street_fib_is_internal_sfib_cleaving_lift_cartesian α). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; exact (pr122 (HF (pr1 G₂ x) (pr1 G₁ x) (pr1 α x)))). Defined. Section IsCartesian. Context {C₀ : bicat_of_univ_cats} {G₁ G₂ : C₀ --> C₁} (α : G₁ ==> G₂) (Hα : is_cartesian_2cell_sfib F α). Definition pointwise_lift_functor_data : functor_data (pr1 C₀) (pr1 C₁). Proof. use make_functor_data. - exact (λ x, pr1 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). - intros x y f ; cbn. use (cartesian_factorization_sfib _ (pr222 (HF (pr1 G₂ y) (pr1 F (pr1 G₁ y)) (# (pr1 F) (pr1 α y))))). + exact (pr112 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))) · # (pr1 G₂) f). + exact (pr212 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))) · # (pr1 F) (# (pr1 G₁) f) · inv_from_z_iso (pr212 (HF (pr1 G₂ y) (pr1 F (pr1 G₁ y)) (# (pr1 F) (pr1 α y))))). + abstract (rewrite functor_comp ; rewrite (pr122 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))) ; rewrite !assoc' ; apply maponpaths ; rewrite <- (functor_comp F) ; etrans ; [ apply maponpaths ; exact (!(nat_trans_ax α _ _ f)) | ] ; rewrite functor_comp ; apply maponpaths ; refine (!_) ; use z_iso_inv_on_right ; rewrite (pr122 (HF (pr1 G₂ y) (pr1 F (pr1 G₁ y)) (# (pr1 F) (pr1 α y)))) ; apply idpath). Defined. Definition pointwise_lift_functor_is_functor : is_functor pointwise_lift_functor_data. Proof. split. - intro x ; cbn. use (cartesian_factorization_sfib_unique _ (pr222 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))))). + exact (pr112 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). + apply identity. + rewrite id_left. apply idpath. + rewrite cartesian_factorization_sfib_over. refine (!_). use z_iso_inv_on_left. rewrite id_left. rewrite (functor_id G₁). rewrite (functor_id F). apply id_right. + apply functor_id. + rewrite cartesian_factorization_sfib_commute. rewrite (functor_id G₂). apply id_right. + apply id_left. - intros x y z f g ; cbn. use (cartesian_factorization_sfib_unique _ (pr222 (HF (pr1 G₂ z) (pr1 F (pr1 G₁ z)) (# (pr1 F) (pr1 α z))))). + exact (pr112 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))) · # (pr1 G₂) (f · g)). + exact (pr212 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))) · # (pr1 F) (# (pr1 G₁) (f · g)) · inv_from_z_iso (pr212 (HF (pr1 G₂ z) (pr1 F (pr1 G₁ z)) (# (pr1 F) (pr1 α z))))). + rewrite functor_comp. rewrite (pr122 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). rewrite !assoc'. apply maponpaths. rewrite <- (functor_comp F). etrans. { apply maponpaths. exact (!(nat_trans_ax α _ _ (f · g))). } rewrite functor_comp. apply maponpaths. refine (!_). use z_iso_inv_on_right. rewrite (pr122 (HF (pr1 G₂ z) (pr1 F (pr1 G₁ z)) (# (pr1 F) (pr1 α z)))). apply idpath. + apply cartesian_factorization_sfib_over. + rewrite functor_comp. rewrite !cartesian_factorization_sfib_over. rewrite (functor_comp G₁). rewrite (functor_comp F). rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. use z_iso_inv_on_right. apply idpath. + apply cartesian_factorization_sfib_commute. + rewrite !assoc'. rewrite cartesian_factorization_sfib_commute. rewrite !assoc. rewrite cartesian_factorization_sfib_commute. rewrite !assoc'. rewrite (functor_comp G₂). apply idpath. Qed. Definition pointwise_lift_functor : C₀ --> C₁. Proof. use make_functor. - exact pointwise_lift_functor_data. - exact pointwise_lift_functor_is_functor. Defined. Definition pointwise_lift_nat_trans_data : nat_trans_data pointwise_lift_functor_data (pr1 G₂) := λ x, pr112 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x))). Definition pointwise_lift_is_nat_trans : is_nat_trans _ _ pointwise_lift_nat_trans_data. Proof. intros x y f ; cbn. unfold pointwise_lift_nat_trans_data. apply cartesian_factorization_sfib_commute. Qed. Definition pointwise_lift_nat_trans : pointwise_lift_functor ==> G₂. Proof. use make_nat_trans. - exact pointwise_lift_nat_trans_data. - exact pointwise_lift_is_nat_trans. Defined. Definition pointwise_lift_nat_trans_is_cartesian_2cell : is_cartesian_2cell_sfib F pointwise_lift_nat_trans. Proof. use pointwise_cartesian_is_cartesian. intro x. exact (pr222 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). Defined. Definition is_cartesian_2cell_sfib_pointwise_cartesian_over_data : nat_trans_data (G₁ ∙ F) (pointwise_lift_functor ∙ F). Proof. intro x. pose (i := pr212 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). exact (z_iso_inv_from_z_iso i). Defined. Definition is_cartesian_2cell_sfib_pointwise_cartesian_over_laws : is_nat_trans _ _ is_cartesian_2cell_sfib_pointwise_cartesian_over_data. Proof. intros x y f ; cbn. refine (!_). use z_iso_inv_on_right. rewrite !assoc. use z_iso_inv_on_left. rewrite cartesian_factorization_sfib_over. rewrite !assoc'. apply maponpaths. rewrite z_iso_after_z_iso_inv. rewrite id_right. apply idpath. Qed. Definition is_cartesian_2cell_sfib_pointwise_cartesian_over : G₁ ∙ F ⟹ pointwise_lift_functor ∙ F. Proof. use make_nat_trans. - exact is_cartesian_2cell_sfib_pointwise_cartesian_over_data. - exact is_cartesian_2cell_sfib_pointwise_cartesian_over_laws. Defined. Definition is_cartesian_2cell_sfib_pointwise_cartesian_inv2cell : invertible_2cell (G₁ · F) (pointwise_lift_functor · F). Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact is_cartesian_2cell_sfib_pointwise_cartesian_over. - intro. apply z_iso_is_z_isomorphism. Defined. Definition is_cartesian_2cell_sfib_pointwise_cartesian_eq : α ▹ F = is_cartesian_2cell_sfib_pointwise_cartesian_inv2cell • (pointwise_lift_nat_trans ▹ F). Proof. use nat_trans_eq. { apply homset_property. } intro x. simpl. unfold pointwise_lift_nat_trans_data. refine (!_). etrans. { apply maponpaths. exact (pr122 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). } rewrite !assoc. etrans. { apply maponpaths_2. apply z_iso_after_z_iso_inv. } apply id_left. Qed. Definition is_cartesian_2cell_sfib_pointwise_cartesian (x : pr1 C₀) : is_cartesian_sfib F (pr1 α x). Proof. pose (i := invertible_between_cartesians Hα pointwise_lift_nat_trans_is_cartesian_2cell is_cartesian_2cell_sfib_pointwise_cartesian_inv2cell is_cartesian_2cell_sfib_pointwise_cartesian_eq). use is_cartesian_sfib_eq. - exact (nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ i) x · pr1 pointwise_lift_nat_trans x). - exact (cartesian_factorization_sfib_commute _ _ _ _ _). - use comp_is_cartesian_sfib. + apply z_iso_is_cartesian_sfib. apply z_iso_is_z_isomorphism. + exact (pr222 (HF (pr1 G₂ x) (pr1 F (pr1 G₁ x)) (# (pr1 F) (pr1 α x)))). Defined. End IsCartesian. Definition street_fib_is_internal_sfib_lwhisker_is_cartesian : lwhisker_is_cartesian F. Proof. intros C₀ C₀' G H₁ H₂ α Hα. use pointwise_cartesian_is_cartesian. intro x ; cbn. apply is_cartesian_2cell_sfib_pointwise_cartesian. exact Hα. Defined. Definition street_fib_is_internal_sfib : internal_sfib F. Proof. split. - exact street_fib_is_internal_sfib_cleaving. - exact street_fib_is_internal_sfib_lwhisker_is_cartesian. Defined. End StreetFibToInternalSFib. Definition internal_sfib_weq_street_fib {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : internal_sfib F ≃ street_fib F. Proof. use weqimplimpl. - exact internal_sfib_is_street_fib. - exact street_fib_is_internal_sfib. - apply isaprop_internal_sfib. exact univalent_cat_is_univalent_2_1. - apply isaprop_street_fib. apply C₁. Defined. (** 2. Internal Street Opfibrations *) Section InternalSOpFibToStreetOpFib. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : internal_sopfib F). Section InternalSOpFibToStreetOpFibFactor. Context {G₁ G₂ : (unit_category : bicat_of_univ_cats) --> C₁} {α : G₁ ==> G₂} (Hα : is_opcartesian_2cell_sopfib F α) {z : pr1 C₁} {g : pr1 G₁ tt --> z} {h : pr1 F (pr1 G₂ tt) --> pr1 F z} (q : # (pr1 F) g = # (pr1 F) (pr1 α tt) · h). Let Φ : unit_category ⟶ pr1 C₁ := functor_from_unit z. Local Definition internal_sopfib_is_opcartesian_sopfib_factor_nat_trans_1 : pr1 G₁ ⟹ Φ. Proof. use make_nat_trans. - intro x ; induction x. exact g. - abstract (intros x y f ; cbn ; induction x ; induction y ; cbn ; assert (p : f = identity _) ; [ apply isapropunit | ] ; rewrite p ; rewrite (functor_id G₁) ; rewrite id_left, id_right ; apply idpath). Defined. Let ζ := internal_sopfib_is_opcartesian_sopfib_factor_nat_trans_1. Local Definition internal_sopfib_is_opcartesian_sopfib_factor_nat_trans_2 : G₂ · F ==> Φ ∙ F. Proof. use make_nat_trans. - intros x ; induction x. exact h. - abstract (intros x y f ; cbn ; induction x ; induction y ; cbn ; assert (p : f = identity _) ; [ apply isapropunit | ] ; rewrite p ; rewrite (functor_id G₂) ; rewrite !(functor_id F) ; rewrite id_left, id_right ; apply idpath). Defined. Let ξ := internal_sopfib_is_opcartesian_sopfib_factor_nat_trans_2. Local Lemma internal_sopfib_is_opcartesian_sopfib_factor_eq : post_whisker ζ F = nat_trans_comp _ _ _ (post_whisker α F) ξ. Proof. use nat_trans_eq. { apply homset_property. } intro x ; induction x. exact q. Qed. Let p := internal_sopfib_is_opcartesian_sopfib_factor_eq. Definition internal_sopfib_is_opcartesian_sopfib_factor : pr1 G₂ tt --> z := pr1 (is_opcartesian_2cell_sopfib_factor _ Hα ζ ξ p) tt. Definition internal_sopfib_is_opcartesian_sopfib_factor_over : # (pr1 F) internal_sopfib_is_opcartesian_sopfib_factor = h. Proof. exact (nat_trans_eq_pointwise (is_opcartesian_2cell_sopfib_factor_over _ Hα _ _ p) tt). Qed. Definition internal_sopfib_is_opcartesian_sopfib_factor_comm : pr1 α tt · internal_sopfib_is_opcartesian_sopfib_factor = g. Proof. exact (nat_trans_eq_pointwise (is_opcartesian_2cell_sopfib_factor_comm _ Hα _ _ p) tt). Qed. Local Definition internal_sopfib_is_opcartesian_sopfib_factor_unique_help (k : pr1 G₂ tt --> z) : pr1 G₂ ⟹ Φ. Proof. use make_nat_trans. - intro x ; induction x. exact k. - abstract (intros x y f ; induction x ; induction y ; cbn ; assert (r : f = identity _) ; [ apply isapropunit | ] ; rewrite r ; rewrite !(functor_id G₂) ; rewrite id_left, id_right ; apply idpath). Defined. Definition internal_sopfib_is_opcartesian_sopfib_factor_unique : isaprop (∑ φ, # (pr1 F) φ = h × pr1 α tt · φ = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } refine (nat_trans_eq_pointwise (is_opcartesian_2cell_sopfib_factor_unique _ Hα Φ ζ ξ p (internal_sopfib_is_opcartesian_sopfib_factor_unique_help (pr1 φ₁)) (internal_sopfib_is_opcartesian_sopfib_factor_unique_help (pr1 φ₂)) _ _ _ _) tt) ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro x ; induction x ; cbn. - exact (pr12 φ₁). - exact (pr12 φ₂). - exact (pr22 φ₁). - exact (pr22 φ₂). Qed. End InternalSOpFibToStreetOpFibFactor. Definition internal_sopfib_is_opcartesian_sopfib {G₁ G₂ : (unit_category : bicat_of_univ_cats) --> C₁} {α : G₁ ==> G₂} (Hα : is_opcartesian_2cell_sopfib F α) : is_opcartesian_sopfib F (pr1 α tt). Proof. intros z g h q. use iscontraprop1. - exact (internal_sopfib_is_opcartesian_sopfib_factor_unique Hα q). - simple refine (_ ,, _ ,, _). + exact (internal_sopfib_is_opcartesian_sopfib_factor Hα q). + exact (internal_sopfib_is_opcartesian_sopfib_factor_over Hα q). + exact (internal_sopfib_is_opcartesian_sopfib_factor_comm Hα q). Defined. Section OpCleaving. Context {e : pr1 C₁} {b : pr1 C₂} (f : pr1 F e --> b). Definition internal_sopfib_is_street_opfib_nat_trans : functor_from_unit e ∙ F ⟹ functor_from_unit b. Proof. use make_nat_trans. - exact (λ _, f). - abstract (intros z₁ z₂ g ; cbn ; rewrite functor_id, id_left, id_right ; apply idpath). Defined. Let ℓ := pr1 HF _ _ _ internal_sopfib_is_street_opfib_nat_trans. Definition internal_sopfib_is_street_opfib_lift_ob : pr1 C₁ := pr1 (pr1 ℓ) tt. Definition internal_sopfib_is_street_opfib_lift_mor : e --> internal_sopfib_is_street_opfib_lift_ob := pr1 (pr12 ℓ) tt. Definition internal_sopfib_is_street_opfib_lift_z_iso : z_iso b (pr1 F internal_sopfib_is_street_opfib_lift_ob) := nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ (pr122 ℓ)) tt. Definition internal_sopfib_is_street_opfib_lift_over : # (pr1 F) internal_sopfib_is_street_opfib_lift_mor = f · internal_sopfib_is_street_opfib_lift_z_iso := nat_trans_eq_pointwise (pr2 (pr222 ℓ)) tt. Definition internal_sopfib_is_street_opfib_lift_cartesian : is_opcartesian_sopfib F internal_sopfib_is_street_opfib_lift_mor := internal_sopfib_is_opcartesian_sopfib (pr1 (pr222 ℓ)). End OpCleaving. Definition internal_sopfib_is_street_opfib : street_opfib F. Proof. intros e b f. simple refine (_ ,, (_ ,, _) ,, _ ,, _) ; cbn. - exact (internal_sopfib_is_street_opfib_lift_ob f). - exact (internal_sopfib_is_street_opfib_lift_mor f). - exact (internal_sopfib_is_street_opfib_lift_z_iso f). - exact (internal_sopfib_is_street_opfib_lift_over f). - exact (internal_sopfib_is_street_opfib_lift_cartesian f). Defined. End InternalSOpFibToStreetOpFib. Section StreetOpFibToInternalSOpFib. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : street_opfib F). Section IsOpCartesian. Context {C₀ : bicat_of_univ_cats} {G₁ G₂ : C₀ --> C₁} (α : G₁ ==> G₂) (Hα : ∏ (x : pr1 C₀), is_opcartesian_sopfib F (pr1 α x)). Section Factorization. Context {H : C₀ --> C₁} {β : G₁ ==> H} {δp : G₂ · F ==> H · F} (q : β ▹ F = (α ▹ F) • δp). Definition pointwise_opcartesian_is_opcartesian_factor_data : nat_trans_data (pr1 G₂) (pr1 H) := λ x, opcartesian_factorization_sopfib _ (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x). Definition pointwise_opcartesian_is_opcartesian_factor_laws : is_nat_trans _ _ pointwise_opcartesian_is_opcartesian_factor_data. Proof. intros x y f ; unfold pointwise_opcartesian_is_opcartesian_factor_data ; cbn. pose (opcartesian_factorization_sopfib_commute F (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x)) as p. pose (opcartesian_factorization_sopfib_commute F (Hα y) (pr1 β y) (pr1 δp y) (nat_trans_eq_pointwise q y)) as p'. use (opcartesian_factorization_sopfib_unique _ (Hα x) (pr1 β x · # (pr1 H) f) (pr1 δp x · # (pr1 F) (# (pr1 H) f))). - rewrite functor_comp. pose (r := nat_trans_eq_pointwise q x) ; cbn in r. etrans. { apply maponpaths_2. exact r. } clear r. rewrite !assoc'. apply idpath. - rewrite functor_comp. rewrite opcartesian_factorization_sopfib_over. exact (nat_trans_ax δp _ _ f). - rewrite !functor_comp. rewrite opcartesian_factorization_sopfib_over. apply idpath. - rewrite !assoc. etrans. { apply maponpaths_2. exact (!(nat_trans_ax α _ _ f)). } rewrite !assoc'. etrans. { apply maponpaths. exact p'. } exact (nat_trans_ax β _ _ f). - rewrite !assoc. apply maponpaths_2. exact p. Qed. Definition pointwise_opcartesian_is_opcartesian_factor : G₂ ==> H. Proof. use make_nat_trans. - exact pointwise_opcartesian_is_opcartesian_factor_data. - exact pointwise_opcartesian_is_opcartesian_factor_laws. Defined. Definition pointwise_opcartesian_is_opcartesian_over : pointwise_opcartesian_is_opcartesian_factor ▹ F = δp. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply opcartesian_factorization_sopfib_over. Qed. Definition pointwise_opcartesian_is_opcartesian_comm : α • pointwise_opcartesian_is_opcartesian_factor = β. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply opcartesian_factorization_sopfib_commute. Qed. Definition pointwise_opcartesian_is_opcartesian_unique : isaprop (∑ (δ : G₂ ==> H), δ ▹ F = δp × α • δ = β). Proof. use invproofirrelevance. intros δ₁ δ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro x. use (opcartesian_factorization_sopfib_unique _ (Hα x) (pr1 β x) (pr1 δp x)). - exact (nat_trans_eq_pointwise q x). - exact (nat_trans_eq_pointwise (pr12 δ₁) x). - exact (nat_trans_eq_pointwise (pr12 δ₂) x). - exact (nat_trans_eq_pointwise (pr22 δ₁) x). - exact (nat_trans_eq_pointwise (pr22 δ₂) x). Qed. End Factorization. Definition pointwise_opcartesian_is_opcartesian : is_opcartesian_2cell_sopfib F α. Proof. intros H β δp q. use iscontraprop1. - exact (pointwise_opcartesian_is_opcartesian_unique q). - simple refine (_ ,, _ ,, _). + exact (pointwise_opcartesian_is_opcartesian_factor q). + exact (pointwise_opcartesian_is_opcartesian_over q). + exact (pointwise_opcartesian_is_opcartesian_comm q). Defined. End IsOpCartesian. Section OpCleaving. Context {C₀ : bicat_of_univ_cats} {G₁ : C₀ --> C₁} {G₂ : C₀ --> C₂} (α : G₁ · F ==> G₂). Definition street_opfib_is_internal_sopfib_opcleaving_lift_data : functor_data (pr1 C₀) (pr1 C₁). Proof. use make_functor_data. - exact (λ x, pr1 (HF _ _ (pr1 α x))). - intros x y f ; cbn. use (opcartesian_factorization_sopfib _ (pr222 (HF _ _ (pr1 α x)))). + exact (# (pr1 G₁) f · pr112 (HF _ _ (pr1 α y))). + exact (inv_from_z_iso (pr212 (HF _ _ (pr1 α x))) · # (pr1 G₂) f · pr212 (HF _ _ (pr1 α y))). + abstract (rewrite functor_comp ; rewrite (pr122 (HF _ _ (pr1 α x))) ; refine (maponpaths (λ z, _ · z) (pr122 (HF _ _ (pr1 α y))) @ _) ; rewrite !assoc ; apply maponpaths_2 ; refine (nat_trans_ax α _ _ f @ _) ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite z_iso_inv_after_z_iso ; rewrite id_left ; apply idpath). Defined. Definition street_opfib_is_internal_sopfib_opcleaving_lift_is_functor : is_functor street_opfib_is_internal_sopfib_opcleaving_lift_data. Proof. split. - intro x ; cbn. use (opcartesian_factorization_sopfib_unique _ (pr222 (HF _ _ (pr1 α x)))). + exact (pr112 (HF _ _ (pr1 α x))). + apply identity. + rewrite id_right. apply idpath. + rewrite opcartesian_factorization_sopfib_over. refine (!_). rewrite (functor_id G₂). rewrite id_right. rewrite z_iso_after_z_iso_inv. apply idpath. + apply functor_id. + rewrite opcartesian_factorization_sopfib_commute. rewrite (functor_id G₁). apply id_left. + apply id_right. - intros x y z f g ; cbn. use (opcartesian_factorization_sopfib_unique _ (pr222 (HF _ _ (pr1 α x)))). + exact (# (pr1 G₁) (f · g) · pr112 (HF _ _ (pr1 α z))). + exact (inv_from_z_iso (pr212 (HF _ _ (pr1 α x))) · # (pr1 G₂) (f · g) · pr212 (HF _ _ (pr1 α z))). + rewrite functor_comp. etrans. { apply maponpaths. exact (pr122 (HF _ _ (pr1 α z))). } rewrite !assoc. apply maponpaths_2. refine (nat_trans_ax α _ _ (f · g) @ _). apply maponpaths_2. use z_iso_inv_on_left. exact (pr122 (HF _ _ (pr1 α x))). + apply opcartesian_factorization_sopfib_over. + rewrite functor_comp. rewrite !opcartesian_factorization_sopfib_over. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite (functor_comp G₂). rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite z_iso_inv_after_z_iso. apply id_left. + apply opcartesian_factorization_sopfib_commute. + rewrite !assoc. rewrite opcartesian_factorization_sopfib_commute. rewrite !assoc'. rewrite opcartesian_factorization_sopfib_commute. rewrite !assoc. rewrite (functor_comp G₁). apply idpath. Qed. Definition street_opfib_is_internal_sopfib_opcleaving_lift : C₀ --> C₁. Proof. use make_functor. - exact street_opfib_is_internal_sopfib_opcleaving_lift_data. - exact street_opfib_is_internal_sopfib_opcleaving_lift_is_functor. Defined. Definition street_opfib_is_internal_sopfib_opcleaving_lift_mor_data : nat_trans_data (pr1 G₁) street_opfib_is_internal_sopfib_opcleaving_lift_data := λ x, pr112 (HF _ _ (pr1 α x)). Definition street_opfib_is_internal_sopfib_opcleaving_lift_mor_is_nat_trans : is_nat_trans _ _ street_opfib_is_internal_sopfib_opcleaving_lift_mor_data. Proof. intros x y f ; cbn. refine (!_). apply opcartesian_factorization_sopfib_commute. Qed. Definition street_opfib_is_internal_sopfib_opcleaving_lift_mor : G₁ ==> street_opfib_is_internal_sopfib_opcleaving_lift. Proof. use make_nat_trans. - exact street_opfib_is_internal_sopfib_opcleaving_lift_mor_data. - exact street_opfib_is_internal_sopfib_opcleaving_lift_mor_is_nat_trans. Defined. Definition street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans_data : nat_trans_data (pr1 G₂) (street_opfib_is_internal_sopfib_opcleaving_lift ∙ F) := λ x, pr212 (HF _ _ (pr1 α x)). Definition street_opfib_is_internal_sopfib_opcleaving_lift_over_is_nat_trans : is_nat_trans _ _ street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans_data. Proof. intros x y f ; cbn. unfold street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans_data. rewrite opcartesian_factorization_sopfib_over. rewrite !assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left. apply idpath. Qed. Definition street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans : pr1 G₂ ⟹ street_opfib_is_internal_sopfib_opcleaving_lift ∙ F. Proof. use make_nat_trans. - exact street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans_data. - exact street_opfib_is_internal_sopfib_opcleaving_lift_over_is_nat_trans. Defined. Definition street_opfib_is_internal_sopfib_opcleaving_lift_opcartesian : is_opcartesian_2cell_sopfib F street_opfib_is_internal_sopfib_opcleaving_lift_mor. Proof. use pointwise_opcartesian_is_opcartesian. intro x. exact (pr222 (HF _ _ (pr1 α x))). Defined. Definition street_opfib_is_internal_sopfib_opcleaving_lift_over : invertible_2cell G₂ (street_opfib_is_internal_sopfib_opcleaving_lift · F). Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact street_opfib_is_internal_sopfib_opcleaving_lift_over_nat_trans. - intro x. apply z_iso_is_z_isomorphism. Defined. End OpCleaving. Definition street_opfib_is_internal_sopfib_opcleaving : internal_sopfib_opcleaving F. Proof. intros C₀ G₁ G₂ α. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (street_opfib_is_internal_sopfib_opcleaving_lift α). - exact (street_opfib_is_internal_sopfib_opcleaving_lift_mor α). - exact (street_opfib_is_internal_sopfib_opcleaving_lift_over α). - exact (street_opfib_is_internal_sopfib_opcleaving_lift_opcartesian α). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; exact (pr122 (HF _ _ (pr1 α x)))). Defined. Section IsOpCartesian. Context {C₀ : bicat_of_univ_cats} {G₁ G₂ : C₀ --> C₁} (α : G₁ ==> G₂) (Hα : is_opcartesian_2cell_sopfib F α). Definition pointwise_oplift_functor_data : functor_data (pr1 C₀) (pr1 C₁). Proof. use make_functor_data. - exact (λ x, pr1 (HF _ _ (# (pr1 F) (pr1 α x)))). - intros x y f ; cbn. use (opcartesian_factorization_sopfib _ (pr222 (HF _ _ (# (pr1 F) (pr1 α x))))). + exact (# (pr1 G₁) f · pr112 (HF _ _ (# (pr1 F) (pr1 α y)))). + exact (inv_from_z_iso (pr212 (HF _ _ (# (pr1 F) (pr1 α x)))) · # (pr1 F) (# (pr1 G₂) f) · pr212 (HF _ _ (# (pr1 F) (pr1 α y)))). + abstract (rewrite functor_comp ; rewrite (pr122 (HF _ _ (# (pr1 F) (pr1 α x)))) ; rewrite !assoc ; etrans ; [ apply maponpaths ; exact (pr122 (HF _ _ (# (pr1 F) (pr1 α y)))) | ] ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- !functor_comp ; etrans ; [ apply maponpaths ; exact (nat_trans_ax α _ _ f) | ] ; rewrite functor_comp ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite z_iso_inv_after_z_iso ; rewrite id_left ; apply idpath). Defined. Definition pointwise_oplift_functor_is_functor : is_functor pointwise_oplift_functor_data. Proof. split. - intro x ; cbn. use (opcartesian_factorization_sopfib_unique _ (pr222 (HF _ _ (# (pr1 F) (pr1 α x))))). + exact (pr112 (HF _ _ (# (pr1 F) (pr1 α x)))). + apply identity. + rewrite id_right. apply idpath. + rewrite opcartesian_factorization_sopfib_over. rewrite !assoc'. use z_iso_inv_on_right. rewrite id_right. rewrite (functor_id G₂). rewrite (functor_id F). apply id_left. + apply functor_id. + rewrite opcartesian_factorization_sopfib_commute. rewrite (functor_id G₁). apply id_left. + apply id_right. - intros x y z f g ; cbn. use (opcartesian_factorization_sopfib_unique _ (pr222 (HF _ _ (# (pr1 F) (pr1 α x))))). + exact (# (pr1 G₁) (f · g) · pr112 (HF _ _ (# (pr1 F) (pr1 α z)))). + exact (inv_from_z_iso (pr212 (HF _ _ (# (pr1 F) (pr1 α x)))) · # (pr1 F) (# (pr1 G₂) (f · g)) · pr212 (HF _ _ (# (pr1 F) (pr1 α z)))). + rewrite functor_comp. rewrite (pr122 (HF _ _ (# (pr1 F) (pr1 α x)))). etrans. { apply maponpaths. exact (pr122 (HF _ _ (# (pr1 F) (pr1 α z)))). } rewrite !assoc. rewrite <- (functor_comp F). etrans. { apply maponpaths_2. apply maponpaths. exact (nat_trans_ax α _ _ (f · g)). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite z_iso_inv_after_z_iso. rewrite id_left. apply idpath. + apply opcartesian_factorization_sopfib_over. + rewrite functor_comp. rewrite !opcartesian_factorization_sopfib_over. rewrite (functor_comp G₂). rewrite (functor_comp F). rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite z_iso_inv_after_z_iso. apply id_left. + apply opcartesian_factorization_sopfib_commute. + rewrite !assoc. rewrite opcartesian_factorization_sopfib_commute. rewrite !assoc'. rewrite opcartesian_factorization_sopfib_commute. rewrite !assoc. rewrite (functor_comp G₁). apply idpath. Qed. Definition pointwise_oplift_functor : C₀ --> C₁. Proof. use make_functor. - exact pointwise_oplift_functor_data. - exact pointwise_oplift_functor_is_functor. Defined. Definition pointwise_oplift_nat_trans_data : nat_trans_data (pr1 G₁) pointwise_oplift_functor_data := λ x, pr112 (HF _ _ (# (pr1 F) (pr1 α x))). Definition pointwise_oplift_is_nat_trans : is_nat_trans _ _ pointwise_oplift_nat_trans_data. Proof. intros x y f ; cbn. unfold pointwise_oplift_nat_trans_data. refine (!_). apply opcartesian_factorization_sopfib_commute. Qed. Definition pointwise_oplift_nat_trans : G₁ ==> pointwise_oplift_functor. Proof. use make_nat_trans. - exact pointwise_oplift_nat_trans_data. - exact pointwise_oplift_is_nat_trans. Defined. Definition pointwise_oplift_nat_trans_is_opcartesian_2cell : is_opcartesian_2cell_sopfib F pointwise_oplift_nat_trans. Proof. use pointwise_opcartesian_is_opcartesian. intro x. exact (pr222 (HF _ _ (# (pr1 F) (pr1 α x)))). Defined. Definition is_opcartesian_2cell_sopfib_pointwise_opcartesian_over_data : nat_trans_data (pointwise_oplift_functor ∙ F) (G₂ ∙ F). Proof. intro x. pose (i := pr212 (HF _ _ (# (pr1 F) (pr1 α x)))). exact (z_iso_inv_from_z_iso i). Defined. Definition is_opcartesian_2cell_sopfib_pointwise_opcartesian_over_laws : is_nat_trans _ _ is_opcartesian_2cell_sopfib_pointwise_opcartesian_over_data. Proof. intros x y f ; cbn. refine (!_). use z_iso_inv_on_right. rewrite !assoc. use z_iso_inv_on_left. rewrite opcartesian_factorization_sopfib_over. rewrite !assoc. apply maponpaths_2. rewrite z_iso_inv_after_z_iso. rewrite id_left. apply idpath. Qed. Definition is_opcartesian_2cell_sopfib_pointwise_opcartesian_over : pointwise_oplift_functor ∙ F ⟹ G₂ ∙ F. Proof. use make_nat_trans. - exact is_opcartesian_2cell_sopfib_pointwise_opcartesian_over_data. - exact is_opcartesian_2cell_sopfib_pointwise_opcartesian_over_laws. Defined. Definition is_opcartesian_2cell_sopfib_pointwise_opcartesian_inv2cell : invertible_2cell (pointwise_oplift_functor · F) (G₂ · F). Proof. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. - exact is_opcartesian_2cell_sopfib_pointwise_opcartesian_over. - intro. apply z_iso_is_z_isomorphism. Defined. Definition is_opcartesian_2cell_sopfib_pointwise_opcartesian_eq : α ▹ F = (pointwise_oplift_nat_trans ▹ F) • is_opcartesian_2cell_sopfib_pointwise_opcartesian_inv2cell. Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. unfold pointwise_oplift_nat_trans_data. refine (!_). etrans. { apply maponpaths_2. exact (pr122 (HF _ _ (# (pr1 F) (pr1 α x)))). } rewrite !assoc'. etrans. { apply maponpaths. apply z_iso_inv_after_z_iso. } apply id_right. Qed. Definition is_opcartesian_2cell_sfib_pointwise_opcartesian (x : pr1 C₀) : is_opcartesian_sopfib F (pr1 α x). Proof. pose (i := invertible_between_opcartesians Hα pointwise_oplift_nat_trans_is_opcartesian_2cell is_opcartesian_2cell_sopfib_pointwise_opcartesian_inv2cell is_opcartesian_2cell_sopfib_pointwise_opcartesian_eq). use is_opcartesian_sopfib_eq. - exact (pr1 pointwise_oplift_nat_trans x · nat_z_iso_pointwise_z_iso (invertible_2cell_to_nat_z_iso _ _ i) x). - exact (opcartesian_factorization_sopfib_commute _ _ _ _ _). - use comp_is_opcartesian_sopfib. + exact (pr222 (HF _ _ (# (pr1 F) (pr1 α x)))). + apply iso_is_opcartesian_sopfib. apply z_iso_is_z_isomorphism. Qed. End IsOpCartesian. Definition street_opfib_is_internal_sopfib_lwhisker_is_opcartesian : lwhisker_is_opcartesian F. Proof. intros C₀ C₀' G H₁ H₂ α Hα. use pointwise_opcartesian_is_opcartesian. intro x ; cbn. apply is_opcartesian_2cell_sfib_pointwise_opcartesian. exact Hα. Defined. Definition street_opfib_is_internal_sopfib : internal_sopfib F. Proof. split. - exact street_opfib_is_internal_sopfib_opcleaving. - exact street_opfib_is_internal_sopfib_lwhisker_is_opcartesian. Defined. End StreetOpFibToInternalSOpFib. Definition internal_sopfib_weq_street_opfib {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : internal_sopfib F ≃ street_opfib F. Proof. use weqimplimpl. - exact internal_sopfib_is_street_opfib. - exact street_opfib_is_internal_sopfib. - apply isaprop_internal_sopfib. exact univalent_cat_is_univalent_2_1. - apply isaprop_street_opfib. apply C₁. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/FibrationsInStrictCats.v000066400000000000000000000137521451125700300276050ustar00rootroot00000000000000(****************************************************************************************** Fibrations of strict categories In this file, we classify the internal Street fibrations of strict categories. These are just the same Street fibrations. ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.StrictCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Local Open Scope cat. Section IsOpCartesian. Context {C₁ C₂ : bicat_of_strict_cats} {F : C₁ --> C₂} (HF : street_opfib F) {C₀ : bicat_of_strict_cats} {G₁ G₂ : C₀ --> C₁} (α : G₁ ==> G₂) (Hα : ∏ (x : pr1 C₀), is_opcartesian_sopfib F (pr1 α x)). Section Factorization. Context {H : C₀ --> C₁} {β : G₁ ==> H} {δp : G₂ · F ==> H · F} (q : β ▹ F = (α ▹ F) • δp). Definition strict_pointwise_opcartesian_is_opcartesian_factor_data : nat_trans_data (pr1 G₂) (pr1 H) := λ x, opcartesian_factorization_sopfib _ (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x). Definition strict_pointwise_opcartesian_is_opcartesian_factor_laws : is_nat_trans _ _ strict_pointwise_opcartesian_is_opcartesian_factor_data. Proof. intros x y f ; unfold strict_pointwise_opcartesian_is_opcartesian_factor_data ; cbn. pose (opcartesian_factorization_sopfib_commute F (Hα x) (pr1 β x) (pr1 δp x) (nat_trans_eq_pointwise q x)) as p. pose (opcartesian_factorization_sopfib_commute F (Hα y) (pr1 β y) (pr1 δp y) (nat_trans_eq_pointwise q y)) as p'. use (opcartesian_factorization_sopfib_unique _ (Hα x) (pr1 β x · # (pr1 H) f) (pr1 δp x · # (pr1 F) (# (pr1 H) f))). - rewrite functor_comp. pose (r := nat_trans_eq_pointwise q x) ; cbn in r. etrans. { apply maponpaths_2. exact r. } clear r. rewrite !assoc'. apply idpath. - rewrite functor_comp. rewrite opcartesian_factorization_sopfib_over. exact (nat_trans_ax δp _ _ f). - rewrite !functor_comp. rewrite opcartesian_factorization_sopfib_over. apply idpath. - rewrite !assoc. etrans. { apply maponpaths_2. exact (!(nat_trans_ax α _ _ f)). } rewrite !assoc'. etrans. { apply maponpaths. exact p'. } exact (nat_trans_ax β _ _ f). - rewrite !assoc. apply maponpaths_2. exact p. Qed. Definition strict_pointwise_opcartesian_is_opcartesian_factor : G₂ ==> H. Proof. use make_nat_trans. - exact strict_pointwise_opcartesian_is_opcartesian_factor_data. - exact strict_pointwise_opcartesian_is_opcartesian_factor_laws. Defined. Definition strict_pointwise_opcartesian_is_opcartesian_over : strict_pointwise_opcartesian_is_opcartesian_factor ▹ F = δp. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply (opcartesian_factorization_sopfib_over F). Qed. Definition strict_pointwise_opcartesian_is_opcartesian_comm : α • strict_pointwise_opcartesian_is_opcartesian_factor = β. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply (opcartesian_factorization_sopfib_commute F). Qed. Definition strict_pointwise_opcartesian_is_opcartesian_unique : isaprop (∑ (δ : G₂ ==> H), δ ▹ F = δp × α • δ = β). Proof. use invproofirrelevance. intros δ₁ δ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use nat_trans_eq. { apply homset_property. } intro x. use (opcartesian_factorization_sopfib_unique _ (Hα x) (pr1 β x) (pr1 δp x)). - exact (nat_trans_eq_pointwise q x). - exact (nat_trans_eq_pointwise (pr12 δ₁) x). - exact (nat_trans_eq_pointwise (pr12 δ₂) x). - exact (nat_trans_eq_pointwise (pr22 δ₁) x). - exact (nat_trans_eq_pointwise (pr22 δ₂) x). Qed. End Factorization. Definition strict_pointwise_opcartesian_is_opcartesian : is_opcartesian_2cell_sopfib F α. Proof. intros H β δp q. use iscontraprop1. - exact (strict_pointwise_opcartesian_is_opcartesian_unique q). - simple refine (_ ,, _ ,, _). + exact (strict_pointwise_opcartesian_is_opcartesian_factor q). + exact (strict_pointwise_opcartesian_is_opcartesian_over q). + exact (strict_pointwise_opcartesian_is_opcartesian_comm q). Defined. End IsOpCartesian. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInBicatOfEnrichedCats.v000066400000000000000000000341301451125700300311600ustar00rootroot00000000000000(** Morphisms in the bicat of enriched categories We characterize several classes of 1-cells in the bicategory of enriched categories. One thing to note here, is that the 'correct' notion of fully faithful enriched functor is stronger than the notion of fully faithful 1-cell in the bicategory of enriched categories. As such, we don't provide a full characterization. Contents: 1. Faithful 1-cells 2. Fully faithful 1-cells 3. Conservative 1-cells 4. Discrete 1-cells *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentAdjunction. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.UnitEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Faithful 1-cells *) Section MorphismsEnrichedCats. Context (V : monoidal_cat). Definition enriched_cat_faithful_is_faithful_1cell {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) (HF : faithful (pr1 F)) : faithful_1cell F. Proof. intros E₃ G₁ G₂ α₁ α₂ p. cbn in *. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. use (invmaponpathsincl _ (HF (pr1 G₁ x) (pr1 G₂ x))). exact (maponpaths (λ z, pr11 z x) p). Qed. Definition enriched_cat_faithful_1cell_is_faithful (HV : isTerminal V (I_{V})) {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) (HF : faithful_1cell F) : faithful (pr1 F). Proof. intros x y ; cbn in *. use isinclweqonpaths. intros f g. use isweqimplimpl. - intro p. refine (maponpaths (λ z, pr11 z tt) (@faithful_1cell_eq_cell _ _ _ _ HF (unit_category ,, unit_enrichment V HV) (constant_functor unit_category (pr1 E₁) x ,, constant_functor_enrichment V HV (pr11 E₁ ,, pr2 E₁) x) (constant_functor unit_category (pr1 E₁) y ,, constant_functor_enrichment V HV (pr11 E₁ ,, pr2 E₁) y) (constant_nat_trans _ f ,, constant_nat_trans_enrichment _ _ _ _) (constant_nat_trans _ g ,, constant_nat_trans_enrichment _ _ _ _) _)). use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro z. exact p. - apply homset_property. - apply homset_property. Qed. Definition enriched_cat_faithful_weq_faithful_1cell (HV : isTerminal V (I_{V})) {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) : faithful (pr1 F) ≃ faithful_1cell F. Proof. use weqimplimpl. - exact (enriched_cat_faithful_is_faithful_1cell F). - exact (enriched_cat_faithful_1cell_is_faithful HV F). - apply isaprop_faithful. - apply isaprop_faithful_1cell. Qed. (** 2. Fully faithful 1-cells *) Section ToFullyFaithfulCell. Context {E₁ E₂ : bicat_of_enriched_cats V} {F : E₁ --> E₂} (HF : fully_faithful_enriched_functor (pr2 F)) {E₀ : bicat_of_enriched_cats V} {G₁ G₂ : E₀ --> E₁} (β : G₁ · F ==> G₂ · F). Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data : nat_trans_data (pr11 G₁) (pr11 G₂) := λ x, enriched_to_arr (pr12 E₁) (enriched_from_arr (pr12 E₂) (pr11 β x) · pr1 (HF (pr11 G₁ x) (pr11 G₂ x))). Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_enrichment : nat_trans_enrichment enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data (pr2 G₁) (pr2 G₂). Proof. intros x y. cbn. unfold enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data. rewrite !enriched_from_to_arr. pose (pr2 β x y) as p. cbn in p. etrans. { apply maponpaths_2. apply maponpaths. apply tensor_comp_l_id_r. } assert (pr12 F (pr11 G₂ x) (pr11 G₂ y) #⊗ identity _ · enriched_comp (pr12 E₂) (pr11 F (pr11 G₁ x)) (pr11 F (pr11 G₂ x)) (pr11 F (pr11 G₂ y)) · pr1 (HF _ _) = id₁ _ #⊗ pr1 (HF ((pr11 G₁) x) ((pr11 G₂) x)) · enriched_comp (pr12 E₁) (pr11 G₁ x) (pr11 G₂ x) (pr11 G₂ y)) as X. { refine (!_). use (z_iso_inv_on_left _ _ _ _ (_ ,, _)). rewrite !assoc'. rewrite (functor_enrichment_comp (pr2 F)). rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite !id_left. apply maponpaths. refine (!_). apply (z_iso_after_z_iso_inv (_ ,, _)). } rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (!X). } clear X. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. apply idpath. } rewrite !assoc. etrans. { apply maponpaths_2. exact p. } clear p. rewrite !assoc'. apply maponpaths. rewrite tensor_comp_l_id_r. refine (!_). etrans. { apply maponpaths_2. apply tensor_comp_r_id_r. } rewrite !assoc'. apply maponpaths. rewrite !assoc. use (z_iso_inv_on_left _ _ _ _ (_ ,, _)). cbn. rewrite !assoc'. rewrite (functor_enrichment_comp (pr2 F)). rewrite !assoc. apply maponpaths_2. refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left. apply maponpaths_2. refine (!_). apply (z_iso_after_z_iso_inv (_ ,, _)). Qed. Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_laws : is_nat_trans _ _ enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data. Proof. exact (is_nat_trans_from_enrichment enriched_cat_fully_faithful_to_fully_faithful_1cell_enrichment). Qed. Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans : pr11 G₁ ⟹ pr11 G₂. Proof. use make_nat_trans. - exact enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data. - exact enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_laws. Defined. Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_cell : G₁ ==> G₂. Proof. simple refine (_ ,, _). - exact enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans. - exact enriched_cat_fully_faithful_to_fully_faithful_1cell_enrichment. Defined. Definition enriched_cat_fully_faithful_to_fully_faithful_1cell_eq : enriched_cat_fully_faithful_to_fully_faithful_1cell_cell ▹ F = β. Proof. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq. { apply homset_property. } intro x. cbn. unfold enriched_cat_fully_faithful_to_fully_faithful_1cell_nat_trans_data. use (invmaponpathsweq (_ ,, isweq_enriched_from_arr (pr2 E₂) _ _)). cbn. rewrite (functor_enrichment_from_arr (pr2 F)). rewrite enriched_from_to_arr. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply (z_iso_after_z_iso_inv (_ ,, _)). Qed. End ToFullyFaithfulCell. Definition enriched_cat_fully_faithful_to_fully_faithful_1cell {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) (HF : fully_faithful_enriched_functor (pr2 F)) : fully_faithful_1cell F. Proof. use make_fully_faithful. - apply enriched_cat_faithful_is_faithful_1cell. exact (fully_faithful_enriched_functor_to_faithful _ HF). - intros E₀ G₁ G₂ β. simple refine (_ ,, _). + exact (enriched_cat_fully_faithful_to_fully_faithful_1cell_cell HF β). + exact (enriched_cat_fully_faithful_to_fully_faithful_1cell_eq HF β). Defined. (** 3. Conservative 1-cells *) Definition enriched_cat_conservative_to_conservative_1cell (HV : faithful_moncat V) {E₁ E₂ : bicat_of_enriched_cats V} {F : E₁ --> E₂} (HF : conservative (pr1 F)) : conservative_1cell F. Proof. intros E₀ G₁ G₂ τ Hτ. use (make_is_invertible_2cell_enriched _ HV). intro x. apply HF. apply (from_is_invertible_2cell_enriched _ (_ ,, Hτ)). Defined. Definition enriched_cat_conservative_1cell_to_conservative (HV : isTerminal V (I_{V})) (HV' : faithful_moncat V) {E₁ E₂ : bicat_of_enriched_cats V} {F : E₁ --> E₂} (HF : conservative_1cell F) : conservative (pr1 F). Proof. intros x y f Hf. pose (unit_category ,, unit_enrichment V HV : bicat_of_enriched_cats V) as unit_enriched. pose (constant_functor unit_category (pr11 E₁) x ,, constant_functor_enrichment V HV (pr11 E₁ ,, pr2 E₁) x : unit_enriched --> E₁) as G₁. pose (constant_functor unit_category (pr11 E₁) y ,, constant_functor_enrichment V HV (pr11 E₁ ,, pr2 E₁) y : unit_enriched --> E₁) as G₂. pose (constant_nat_trans _ f ,, constant_nat_trans_enrichment _ _ _ _ : G₁ ==> G₂) as τ. assert (is_invertible_2cell (τ ▹ F)) as H. { use (make_is_invertible_2cell_enriched _ HV'). intro. exact Hf. } pose (nat_z_iso_pointwise_z_iso (from_is_invertible_2cell_enriched _ (_ ,, HF _ _ _ _ H)) tt) as p. exact (pr2 p). Qed. Definition enriched_cat_conservative_weq_conservative_1cell (HV : isTerminal V (I_{V})) (HV' : faithful_moncat V) {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) : conservative (pr1 F) ≃ conservative_1cell F. Proof. use weqimplimpl. - exact (enriched_cat_conservative_to_conservative_1cell HV'). - exact (enriched_cat_conservative_1cell_to_conservative HV HV'). - apply isaprop_conservative. - apply isaprop_conservative_1cell. Qed. (** 4. Discrete 1-cells *) Definition enriched_cat_discretee_weq_discrete_1cell (HV : isTerminal V (I_{V})) (HV' : faithful_moncat V) {E₁ E₂ : bicat_of_enriched_cats V} (F : E₁ --> E₂) : faithful (pr1 F) × conservative (pr1 F) ≃ discrete_1cell F. Proof. use weqdirprodf. - exact (enriched_cat_faithful_weq_faithful_1cell HV F). - exact (enriched_cat_conservative_weq_conservative_1cell HV HV' F). Qed. End MorphismsEnrichedCats. (** *) Definition adjunction_enrichment_weq {V : monoidal_cat} (E₁ E₂ : bicat_of_enriched_cats V) (L : adjunction (pr1 E₁) (pr1 E₂)) : disp_adjunction L (pr2 E₁) (pr2 E₂) ≃ adjunction_enrichment (adjunction_weq_adjunction_univ_cats (pr1 E₁) (pr1 E₂) L) (pr2 E₁) (pr2 E₂). Proof. use weq_iso. - exact (λ LL, pr1 LL ,, pr112 LL ,, pr1 (pr212 LL) ,, pr2 (pr212 LL)). - refine (λ LL, left_adjoint_enrichment LL ,, (right_adjoint_enrichment LL ,, (adjoint_unit_enrichment LL ,, adjoint_counit_enrichment LL)) ,, _). abstract (split ; apply disp_2cell_isapprop_enriched_cats). - abstract (intro LL ; refine (maponpaths (λ z, _ ,, z) _) ; use subtypePath ; [ intro ; apply isapropdirprod ; apply disp_cellset_property | ] ; apply idpath). - abstract (intro LL ; apply idpath). Defined. Definition adjunction_enriched_cats_weq_enriched_adjunction {V : monoidal_cat} (E₁ E₂ : bicat_of_enriched_cats V) : adjunction E₁ E₂ ≃ enriched_adjunction (pr2 E₁) (pr2 E₂) := (weqtotal2 (adjunction_weq_adjunction_univ_cats (pr1 E₁) (pr1 E₂)) (adjunction_enrichment_weq _ _) ∘ adjunction_total_disp_weq _ _)%weq. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInBicatOfUnivCats.v000066400000000000000000000422611451125700300303640ustar00rootroot00000000000000(** Morphisms in the bicat of univalent categories Contents: 1. Faithful 1-cells 2. Fully faithful 1-cells 3. Conservative 1-cells 4. Pseudomonic 1-cells 5. Adjoints *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Local Open Scope cat. (** 1. Faithful 1-cells *) Definition cat_faithful_is_faithful_1cell {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) (HF : faithful F) : faithful_1cell F. Proof. intros C₃ G₁ G₂ α₁ α₂ p. cbn in *. use nat_trans_eq. { apply homset_property. } intro x. use (invmaponpathsincl _ (HF (G₁ x) (G₂ x))). exact (nat_trans_eq_pointwise p x). Qed. Definition cat_faithful_1cell_is_faithful {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) (HF : faithful_1cell F) : faithful F. Proof. intros x y ; cbn in *. use isinclweqonpaths. intros f g. use isweqimplimpl. - intro p. assert (post_whisker (constant_nat_trans C₁ f) F = post_whisker (constant_nat_trans C₁ g) F) as X. { use nat_trans_eq ; [ apply homset_property | ]. intro. exact p. } use (nat_trans_eq_pointwise (faithful_1cell_eq_cell HF X) x). - apply homset_property. - apply homset_property. Qed. Definition cat_faithful_weq_faithful_1cell {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : faithful F ≃ faithful_1cell F. Proof. use weqimplimpl. - exact (cat_faithful_is_faithful_1cell F). - exact (cat_faithful_1cell_is_faithful F). - apply isaprop_faithful. - apply isaprop_faithful_1cell. Qed. (** 2. Fully faithful 1-cells *) Definition fully_faithful_inv_nat_trans_data {C₁ C₂ C₃ : category} {F : C₂ ⟶ C₃} (HF : fully_faithful F) {G₁ G₂ : C₁ ⟶ C₂} (α : G₁ ∙ F ⟹ G₂ ∙ F) : nat_trans_data G₁ G₂ := λ x, invmap (make_weq _ (HF (G₁ x) (G₂ x))) (α x). Definition fully_faithful_inv_is_nat_trans {C₁ C₂ C₃ : category} {F : C₂ ⟶ C₃} (HF : fully_faithful F) {G₁ G₂ : C₁ ⟶ C₂} (α : G₁ ∙ F ⟹ G₂ ∙ F) : is_nat_trans _ _ (fully_faithful_inv_nat_trans_data HF α). Proof. intros x y f ; cbn ; unfold fully_faithful_inv_nat_trans_data. unfold fully_faithful in HF. pose (w := make_weq _ (HF (G₁ x) (G₂ y))). refine (!(homotinvweqweq w _) @ _ @ homotinvweqweq w _). apply maponpaths. cbn. rewrite !functor_comp. etrans. { apply maponpaths. apply (homotweqinvweq (make_weq _ (HF (G₁ _) (G₂ _)))). } refine (!_). etrans. { apply maponpaths_2. apply (homotweqinvweq (make_weq _ (HF (G₁ _) (G₂ _)))). } refine (!_). exact (nat_trans_ax α _ _ f). Qed. Definition fully_faithful_inv_nat_trans {C₁ C₂ C₃ : category} {F : C₂ ⟶ C₃} (HF : fully_faithful F) {G₁ G₂ : C₁ ⟶ C₂} (α : G₁ ∙ F ⟹ G₂ ∙ F) : G₁ ⟹ G₂. Proof. use make_nat_trans. - exact (fully_faithful_inv_nat_trans_data HF α). - exact (fully_faithful_inv_is_nat_trans HF α). Defined. Definition cat_fully_faithful_is_fully_faithful_1cell {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) (HF : fully_faithful F) : fully_faithful_1cell F. Proof. use make_fully_faithful. - apply cat_faithful_is_faithful_1cell. apply fully_faithful_implies_full_and_faithful. exact HF. - intros C₃ G₁ G₂ αF ; cbn in *. simple refine (_ ,, _). + exact (fully_faithful_inv_nat_trans HF αF). + use nat_trans_eq ; [ apply homset_property | ]. intro x. cbn ; unfold fully_faithful_inv_nat_trans_data. apply (homotweqinvweq (make_weq # F (HF (G₁ x) (G₂ x)))). Qed. Definition cat_fully_faithful_1cell_is_fully_faithful {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) (HF : fully_faithful_1cell F) : fully_faithful F. Proof. use full_and_faithful_implies_fully_faithful. cbn in *. split. - intros x y f. apply hinhpr. assert (is_nat_trans (constant_functor C₁ C₁ x ∙ F) (constant_functor C₁ C₁ y ∙ F) (λ _, f)) as n_is_nat_trans. { intro ; intros. cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. } pose (make_nat_trans (constant_functor C₁ C₁ x ∙ F) (constant_functor C₁ C₁ y ∙ F) (λ _, f) n_is_nat_trans) as n. pose (pr2 HF C₁ (constant_functor _ _ x) (constant_functor _ _ y) n) as inv. cbn in inv. simple refine (_ ,, _) ; cbn. + exact (pr1 inv x). + exact (nat_trans_eq_pointwise (pr2 inv) x). - apply cat_faithful_1cell_is_faithful. apply fully_faithful_1cell_faithful. exact HF. Qed. Definition cat_fully_faithful_weq_fully_faithful_1cell {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : fully_faithful F ≃ fully_faithful_1cell F. Proof. use weqimplimpl. - exact (cat_fully_faithful_is_fully_faithful_1cell F). - exact (cat_fully_faithful_1cell_is_fully_faithful F). - apply isaprop_fully_faithful. - apply isaprop_fully_faithful_1cell. Qed. (** 3. Conservative 1-cells *) Definition cat_conservative_1cell_is_conservative {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : conservative_1cell F) : conservative F. Proof. intros x y f Hf. refine (is_invertible_2cell_to_is_nat_z_iso _ (HF unit_category _ _ (nat_trans_from_unit f) _) tt). use is_nat_z_iso_to_is_invertible_2cell. intro. cbn. apply Hf. Defined. Definition cat_conservative_is_conservative_1cell {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : conservative F) : conservative_1cell F. Proof. intros C₀ G₁ G₂ α Hα. use is_nat_z_iso_to_is_invertible_2cell. intro x. apply HF. exact (is_invertible_2cell_to_is_nat_z_iso _ Hα x). Defined. Definition cat_conservative_weq_conservative {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : conservative F ≃ conservative_1cell F. Proof. use weqimplimpl. - exact cat_conservative_is_conservative_1cell. - exact cat_conservative_1cell_is_conservative. - apply isaprop_conservative. - apply isaprop_conservative_1cell. Defined. (** 4. Pseudomonic 1-cells *) Section Pseudomonic1CellToPseudomonic. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : pseudomonic_1cell F). Section OnIso. Context {x y : pr1 C₁} (f : z_iso (pr1 F x) (pr1 F y)). Local Definition cat_pseudmonic_1cell_is_pseudomonic_on_iso_nat_trans : functor_from_unit x ∙ F ⟹ functor_from_unit y ∙ F. Proof. use make_nat_trans. - exact (λ _, f). - abstract (intros ? ? ? ; cbn ; rewrite !functor_id ; rewrite id_left, id_right ; apply idpath). Defined. Let τ := cat_pseudmonic_1cell_is_pseudomonic_on_iso_nat_trans. Definition cat_pseudmonic_1cell_is_pseudomonic_on_z_iso : z_iso x y. Proof. use make_z_iso'. - refine (pr1 (pseudomonic_1cell_inv_map HF τ _) tt). use is_nat_z_iso_to_is_invertible_2cell. intro. apply z_iso_is_z_isomorphism. - apply (is_invertible_2cell_to_is_nat_z_iso _ (is_invertible_2cell_pseudomonic_1cell_inv_map HF τ _)). Defined. Definition cat_pseudmonic_1cell_is_pseudomonic_on_z_iso_eq : functor_on_z_iso F cat_pseudmonic_1cell_is_pseudomonic_on_z_iso = f. Proof. use z_iso_eq. exact (nat_trans_eq_pointwise (pseudomonic_1cell_inv_map_eq HF τ _) tt). Qed. End OnIso. Definition cat_pseudmonic_1cell_is_pseudomonic : pseudomonic F. Proof. split. - apply cat_faithful_1cell_is_faithful. exact (pr1 HF). - intros x y f. apply hinhpr. simple refine (_ ,, _). + exact (cat_pseudmonic_1cell_is_pseudomonic_on_z_iso f). + exact (cat_pseudmonic_1cell_is_pseudomonic_on_z_iso_eq f). Defined. End Pseudomonic1CellToPseudomonic. Section PseudomonicToPseudomonic1Cell. Context {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : pseudomonic F) {C₀ : bicat_of_univ_cats} {G₁ G₂ : C₀ --> C₁} (n : G₁ · F ==> G₂ · F) (Hn : is_invertible_2cell n). Definition cat_pseudmonic_is_pseudomonic_1cell_inv_data : nat_trans_data (pr1 G₁) (pr1 G₂). Proof. intro x. use (invmap (make_weq _ (isweq_functor_on_iso_pseudomonic HF (pr1 G₁ x) (pr1 G₂ x)))). use make_z_iso'. - exact (pr1 n x). - apply (is_invertible_2cell_to_is_nat_z_iso _ Hn). Defined. Definition cat_pseudmonic_is_pseudomonic_1cell_inv_is_nat_trans : is_nat_trans _ _ cat_pseudmonic_is_pseudomonic_1cell_inv_data. Proof. intros x y f ; cbn. unfold cat_pseudmonic_is_pseudomonic_1cell_inv_data. use (invmaponpathsincl _ (pr1 HF (pr1 G₁ x) (pr1 G₂ y))). cbn. rewrite !functor_comp. etrans. { apply maponpaths. apply (maponpaths pr1 (homotweqinvweq (make_weq _ (isweq_functor_on_iso_pseudomonic HF (pr1 G₁ y) (pr1 G₂ y))) _)). } cbn. etrans. { exact (nat_trans_ax n _ _ f). } apply maponpaths_2. refine (!_). etrans. { apply (maponpaths pr1 (homotweqinvweq (make_weq _ (isweq_functor_on_iso_pseudomonic HF (pr1 G₁ x) (pr1 G₂ x))) _)). } apply idpath. Qed. Definition cat_pseudmonic_is_pseudomonic_1cell_inv : G₁ ==> G₂. Proof. use make_nat_trans. - exact cat_pseudmonic_is_pseudomonic_1cell_inv_data. - exact cat_pseudmonic_is_pseudomonic_1cell_inv_is_nat_trans. Defined. Definition is_invertible_cat_pseudmonic_is_pseudomonic_1cell_inv : is_invertible_2cell (cat_pseudmonic_is_pseudomonic_1cell_inv). Proof. use is_nat_z_iso_to_is_invertible_2cell. intro. apply z_iso_is_z_isomorphism. Defined. Definition cat_pseudmonic_is_pseudomonic_1cell_inv_eq : cat_pseudmonic_is_pseudomonic_1cell_inv ▹ F = n. Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. etrans. { apply (maponpaths pr1 (homotweqinvweq (make_weq _ (isweq_functor_on_iso_pseudomonic HF (pr1 G₁ x) (pr1 G₂ x))) _)). } cbn. apply idpath. Qed. End PseudomonicToPseudomonic1Cell. Definition cat_pseudmonic_is_pseudomonic_1cell {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : pseudomonic F) : pseudomonic_1cell F. Proof. use make_pseudomonic. - apply cat_faithful_is_faithful_1cell. exact (pr1 HF). - intros C₀ G₁ G₂ n Hn. refine (cat_pseudmonic_is_pseudomonic_1cell_inv HF n Hn ,, _ ,, _). + exact (is_invertible_cat_pseudmonic_is_pseudomonic_1cell_inv HF n Hn). + exact (cat_pseudmonic_is_pseudomonic_1cell_inv_eq HF n Hn). Defined. Definition cat_pseudomonic_weq_pseudomonic {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : pseudomonic F ≃ pseudomonic_1cell F. Proof. use weqimplimpl. - exact cat_pseudmonic_is_pseudomonic_1cell. - exact cat_pseudmonic_1cell_is_pseudomonic. - apply isaprop_pseudomonic. - apply isaprop_pseudomonic_1cell. Defined. (** 5. Adjoints *) Definition left_adjoint_to_is_left_adjoint {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : left_adjoint F) : is_left_adjoint F. Proof. refine (left_adjoint_right_adjoint HF ,, _). use make_are_adjoints. - exact (left_adjoint_unit HF). - exact (left_adjoint_counit HF). - split. + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle1 HF) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). + abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (internal_triangle2 HF) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). Defined. Definition is_left_adjoint_to_left_adjoint {C₁ C₂ : bicat_of_univ_cats} {F : C₁ --> C₂} (HF : is_left_adjoint F) : left_adjoint F. Proof. simple refine ((right_adjoint HF ,, _ ,, _) ,, (_ ,, _)). - exact (adjunit HF). - exact (adjcounit HF). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; exact (pr122 HF x)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; exact (pr222 HF x)). Defined. Definition left_adjoint_weq_is_left_adjoint {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂) : left_adjoint F ≃ is_left_adjoint F. Proof. use make_weq. - exact left_adjoint_to_is_left_adjoint. - use isweq_iso. + exact is_left_adjoint_to_left_adjoint. + abstract (intro HF ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply idpath). + abstract (intro HF ; refine (maponpaths (λ z, _ ,, z) _) ; use subtypePath ; [ intro ; apply isaprop_form_adjunction | ] ; apply idpath). Defined. Definition adjunction_from_adjunction_univ_cats {C₁ C₂ : bicat_of_univ_cats} : Bicategories.Morphisms.Adjunctions.adjunction C₁ C₂ → CategoryTheory.Adjunctions.Core.adjunction (pr1 C₁) (pr1 C₂). Proof. intros L. simple refine ((_ ,, (_ ,, (_ ,, _))) ,, (_ ,, _)). - exact (arrow_of_adjunction L). - exact (internal_right_adjoint L). - exact (left_adjoint_unit (left_adjoint_of_adjunction L)). - exact (left_adjoint_counit (left_adjoint_of_adjunction L)). - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (pr122 L) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). - abstract (intro x ; cbn ; pose (nat_trans_eq_pointwise (pr222 L) x) as p ; cbn in p ; rewrite !id_left, !id_right in p ; exact p). Defined. Definition adjunction_to_adjunction_univ_cats {C₁ C₂ : bicat_of_univ_cats} : CategoryTheory.Adjunctions.Core.adjunction (pr1 C₁) (pr1 C₂) → Bicategories.Morphisms.Adjunctions.adjunction C₁ C₂. Proof. intros L. simple refine (_ ,, ((_ ,, (_ ,, _)) ,, (_ ,, _))). - exact (pr11 L). - exact (pr121 L). - exact (pr1 (pr221 L)). - exact (pr2 (pr221 L)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; exact (pr12 L x)). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; exact (pr22 L x)). Defined. Definition adjunction_weq_adjunction_univ_cats (C₁ C₂ : bicat_of_univ_cats) : Bicategories.Morphisms.Adjunctions.adjunction C₁ C₂ ≃ CategoryTheory.Adjunctions.Core.adjunction (pr1 C₁) (pr1 C₂). Proof. use weq_iso. - exact adjunction_from_adjunction_univ_cats. - exact adjunction_to_adjunction_univ_cats. - abstract (intro L ; use subtypePath ; [ use isaprop_left_adjoint ; exact univalent_cat_is_univalent_2_1 | ] ; apply idpath). - abstract (intro L ; use subtypePath ; [ intro ; apply isaprop_form_adjunction | ] ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInOneTypes.v000066400000000000000000000326631451125700300271530ustar00rootroot00000000000000(** Morphisms in the bicat of univalent categories Contents: 1. Faithful 1-cells 2. Fully faithful 1-cells 3. Esos in 1-types 4. (eso, ff)-factorization 5. Esos are closed under pullback *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Eso. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits. Local Open Scope cat. Definition pr1_image {X Y : UU} (f : X → Y) : image f → Y := pr1. Definition isInjective_pr1_image {X Y : UU} (f : X → Y) : isInjective (pr1_image f). Proof. intros y₁ y₂. refine (pr2 (path_sigma_hprop (λ (y : Y), ∥ hfiber f y ∥) y₁ y₂ _)). apply ishinh. Qed. Definition isofhlevel_image {X Y : UU} (f : X → Y) {n : nat} (HY : isofhlevel (S n) Y) : isofhlevel (S n) (image f). Proof. unfold image. use isofhleveltotal2. - exact HY. - intro y. apply isofhlevelsnprop. apply ishinh. Defined. Definition HLevel_image {n : nat} {X : UU} {Y : HLevel (S n)} (f : X → pr1 Y) : HLevel (S n). Proof. refine (image f ,, _). apply isofhlevel_image. exact (pr2 Y). Defined. Section ImageMap. Context {X I₁ I₂ Y : UU} {f₁ : X → I₁} (Hf₁ : issurjective f₁) (f₂ : X → I₂) (m₁ : I₁ → Y) {m₂ : I₂ → Y} (Hm₂ : isInjective m₂) (p : ∏ (x : X), m₂(f₂ x) = m₁(f₁ x)). Definition image_function_help (i : I₁) : ∃! (x : I₂), m₂ x = m₁ i. Proof. use (factor_through_squash _ _ (Hf₁ i)). { apply isapropiscontr. } intros x. use iscontraprop1. - apply (isinclweqonpaths _ Hm₂). - simple refine (f₂ (pr1 x) ,, _). exact (p (pr1 x) @ maponpaths m₁ (pr2 x)). Defined. Definition image_function : I₁ → I₂ := λ i, pr11 (image_function_help i). End ImageMap. (** 1. Faithful 1-cells *) Definition one_types_is_incl_faithful_1cell {X Y : one_types} (f : X --> Y) (Hf : ∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y)) : faithful_1cell f. Proof. intros z g₁ g₂ α₁ α₂ p. use funextsec. intro x. cbn in * ; unfold homotfun in *. pose (Hf (g₁ x) (g₂ x) (maponpaths f (α₂ x))) as i. pose (proofirrelevance _ i (α₁ x ,, eqtohomot p x) (α₂ x ,, idpath _)) as k. exact (maponpaths pr1 k). Qed. Definition one_types_faithful_1cell_is_incl {X Y : one_types} (f : X --> Y) (Hf : faithful_1cell f) : ∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y). Proof. intros x y ; cbn in *. use isinclweqonpaths. intros p q. use isweqimplimpl. - intros α. pose (eqtohomot (Hf X (λ _, x) (λ _, y) (λ _, p) (λ _, q) (funextsec _ _ _ (λ _, α))) x) as fp. exact fp. - use invproofirrelevance. intros ? ?. apply X. - use invproofirrelevance. intros ? ?. apply Y. Qed. Definition one_types_is_incl_weq_faithful_1cell {X Y : one_types} (f : X --> Y) : (∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y)) ≃ faithful_1cell f. Proof. use weqimplimpl. - exact (one_types_is_incl_faithful_1cell f). - exact (one_types_faithful_1cell_is_incl f). - do 2 (use impred ; intro). apply isapropisincl. - apply isaprop_faithful_1cell. Qed. (** 2. Fully faithful 1-cells *) Definition one_types_isInjective_fully_faithful_1cell {X Y : one_types} (f : X --> Y) (Hf : isInjective f) : fully_faithful_1cell f. Proof. use make_fully_faithful. - apply one_types_is_incl_faithful_1cell. intros x y. apply isinclweq. apply Hf. - intros Z g₁ g₂ αf ; cbn in * ; unfold homotfun in *. simple refine (_ ,, _). + intro x. apply (invmap (make_weq _ (Hf (g₁ x) (g₂ x)))). exact (αf x). + use funextsec. intro x. apply (homotweqinvweq (make_weq _ (Hf (g₁ x) (g₂ x)))). Qed. Definition one_types_fully_faithful_isInjective {X Y : one_types} (f : X --> Y) (Hf : fully_faithful_1cell f) : isInjective f. Proof. intros x y ; cbn in *. use isweq_iso. - intro p. exact (pr1 (pr2 Hf X (λ _, x) (λ _, y) (λ _, p)) x). - intro p ; simpl. pose (pr1 Hf _ _ _ (pr1 (pr2 Hf X (λ _ : X, x) (λ _ : X, y) (λ _ : X, maponpaths f p))) (λ _, p)) as q. cbn in q. refine (eqtohomot (q _) x). unfold homotfun. use funextsec. intro ; cbn. exact (eqtohomot (pr2 (pr2 Hf X (λ _, x) (λ _, y) (λ _, maponpaths f p))) _). - intros p. exact (eqtohomot (pr2 (pr2 Hf X (λ _, x) (λ _, y) (λ _, p))) x). Qed. Definition one_types_isInjective_weq_fully_faithful {X Y : one_types} (f : X --> Y) : isInjective f ≃ fully_faithful_1cell f. Proof. use weqimplimpl. - exact (one_types_isInjective_fully_faithful_1cell f). - exact (one_types_fully_faithful_isInjective f). - apply isaprop_isInjective. - apply isaprop_fully_faithful_1cell. Qed. (** 3. Esos in 1-types *) Section IsSurjectiveEsoFull. Context {X Y : one_types} {f : X --> Y} (Hf : issurjective f) {W₁ W₂ : one_types} {m : W₁ --> W₂} (Hm : fully_faithful_1cell m) {g₁ g₂ : Y --> W₁} (p₁ : f · g₁ ==> f · g₂) (p₂ : g₁ · m ==> g₂ · m) (q : (p₁ ▹ m) • rassociator f g₂ m = rassociator f g₁ m • (f ◃ p₂)). Definition issurjective_is_eso_full_lift_2 : g₁ ==> g₂. Proof. intro x. apply (invmap (make_weq _ (one_types_fully_faithful_isInjective _ Hm (g₁ x) (g₂ x)))). exact (p₂ x). Defined. Definition issurjective_is_eso_full_lift_2_left : f ◃ issurjective_is_eso_full_lift_2 = p₁. Proof. use funextsec. intro x. pose (H := homotinvweqweq (make_weq _ (one_types_fully_faithful_isInjective _ Hm (g₁(f x)) (g₂(f x))))). refine (!(H _) @ _ @ H _). apply maponpaths. etrans. { apply homotweqinvweq. } refine (!(eqtohomot q x) @ _). apply pathscomp0rid. Qed. Definition issurjective_is_eso_full_lift_2_right : issurjective_is_eso_full_lift_2 ▹ m = p₂. Proof. use funextsec. intro x. apply (homotweqinvweq (make_weq _ (one_types_fully_faithful_isInjective _ Hm (g₁ x) (g₂ x)))). Qed. End IsSurjectiveEsoFull. Definition issurjective_is_eso_full {X Y : one_types} {f : X --> Y} (Hf : issurjective f) : is_eso_full f. Proof. intros W₁ W₂ m Hm g₁ g₂ p₁ p₂ q. simple refine (_ ,, _ ,, _). - exact (issurjective_is_eso_full_lift_2 Hm p₂). - exact (issurjective_is_eso_full_lift_2_left Hm _ _ q). - apply issurjective_is_eso_full_lift_2_right. Qed. Definition issurjective_is_eso_faithful {X Y : one_types} {f : X --> Y} (Hf : issurjective f) : is_eso_faithful f. Proof. intros W₁ W₂ m Hm g₁ g₂ p₁ p₂ q₁ q₂. use funextsec. intro x. use (invmaponpathsincl _ (one_types_faithful_1cell_is_incl m (pr1 Hm) (g₁ x) (g₂ x))). exact (eqtohomot q₂ x). Qed. Section IsSurjectiveIsEsoEssentiallySurjective. Context {X₁ X₂ Y₁ Y₂ : one_types} {f : X₁ --> X₂} (Hf : issurjective f) {m : Y₁ --> Y₂} (Hm : isInjective m) {g₁ : X₁ --> Y₁} {g₂ : X₂ --> Y₂} (p : invertible_2cell (g₁ · m) (f · g₂)). Let I₁ : UU := image g₁. Let I₂ : UU := image g₂. Definition issurjective_is_eso_lift_1 : X₂ --> Y₁ := image_function Hf g₁ g₂ Hm (pr1 p). Definition issurjective_is_eso_lift_1_right : issurjective_is_eso_lift_1 · m ==> g₂. Proof. intro x. exact (pr21 (image_function_help Hf g₁ g₂ Hm (pr1 p) x)). Defined. (** The equation of this one is derived from `issurjective_is_eso_lift_1_eq` *) Definition issurjective_is_eso_lift_1_left : f · issurjective_is_eso_lift_1 ==> g₁. Proof. intro x. exact (invmap (make_weq _ (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x))) (issurjective_is_eso_lift_1_right (f x) @ ! pr1 p x)). Defined. Definition issurjective_is_eso_lift_1_eq : (issurjective_is_eso_lift_1_left ▹ m) • p = rassociator _ _ _ • (f ◃ issurjective_is_eso_lift_1_right). Proof. use funextsec. intro x. cbn ; unfold homotcomp, homotfun, funhomotsec. use hornRotation_rr. use (invmaponpathsweq (invweq (make_weq _ (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x))))). apply (homotinvweqweq (make_weq _ (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x)))). Qed. End IsSurjectiveIsEsoEssentiallySurjective. Definition issurjective_is_eso_essentially_surjective {X₁ X₂ : one_types} {f : X₁ --> X₂} (Hf : issurjective f) : is_eso_essentially_surjective f. Proof. intros Y₁ Y₂ m Hm' g₁ g₂ p. pose (Hm := one_types_fully_faithful_isInjective _ Hm'). simple refine (_ ,, _ ,, _ ,, _). - exact (issurjective_is_eso_lift_1 Hf Hm p). - use make_invertible_2cell. + exact (issurjective_is_eso_lift_1_left Hf Hm p). + apply one_type_2cell_iso. - use make_invertible_2cell. + exact (issurjective_is_eso_lift_1_right Hf Hm p). + apply one_type_2cell_iso. - exact (issurjective_is_eso_lift_1_eq Hf Hm p). Defined. Definition issurjective_is_eso {X Y : one_types} {f : X --> Y} (Hf : issurjective f) : is_eso f. Proof. use make_is_eso. - exact one_types_is_univalent_2_1. - exact (issurjective_is_eso_full Hf). - exact (issurjective_is_eso_faithful Hf). - exact (issurjective_is_eso_essentially_surjective Hf). Defined. Section IsEsoIsSurjective. Context {X Y : one_types} {f : X --> Y} (Hf : is_eso f). Let im : one_types := HLevel_image f. Let fim : X --> im := prtoimage f. Let π : im --> Y := pr1_image f. Definition is_eso_issurjective_inv2cell : invertible_2cell (fim · π) (f · id₁ Y). Proof. use make_invertible_2cell. - exact (λ _, idpath _). - apply one_type_2cell_iso. Defined. Local Definition is_eso_issurjective_help_map : Y --> im := is_eso_lift_1 _ Hf (one_types_isInjective_fully_faithful_1cell π (isInjective_pr1_image f)) (prtoimage f) (id₁ _) is_eso_issurjective_inv2cell. Let φ := is_eso_issurjective_help_map. Definition is_eso_issurjective : issurjective f. Proof. intro y. use (factor_through_squash _ _ (pr2 (φ y))). { apply ishinh. } intros x. apply hinhpr. refine (pr1 x ,, _). refine (pr2 x @ _). exact (pr1 (is_eso_lift_1_comm_right _ Hf (one_types_isInjective_fully_faithful_1cell π (isInjective_pr1_image f)) (prtoimage f) (id₁ _) is_eso_issurjective_inv2cell) y). Qed. End IsEsoIsSurjective. Definition issurjective_weq_is_eso {X Y : one_types} (f : X --> Y) : issurjective f ≃ is_eso f. Proof. use weqimplimpl. - exact issurjective_is_eso. - exact is_eso_issurjective. - apply isapropissurjective. - apply isaprop_is_eso. exact one_types_is_univalent_2_1. Defined. (** 4. (eso, ff)-factorization *) Definition eso_ff_factorization_one_types : eso_ff_factorization one_types. Proof. intros X Y f. refine (HLevel_image f ,, _). refine (pr1_image f ,, prtoimage f ,, _ ,, _ ,, _). - apply one_types_isInjective_fully_faithful_1cell. apply isInjective_pr1_image. - apply issurjective_is_eso. apply issurjprtoimage. - use make_invertible_2cell. + intro x. apply idpath. + apply one_type_2cell_iso. Defined. (** 5. Esos are closed under pullback *) Definition is_eso_closed_under_pb_one_types : is_eso_closed_under_pb (_ ,, one_types_has_pb). Proof. intros X Y Z f Hf' g ; cbn in *. use issurjective_is_eso. pose (Hf := is_eso_issurjective Hf'). intros y. use (factor_through_squash _ _ (Hf (g y))). { apply ishinh. } intros x. apply hinhpr. exact (((pr1 x ,, y) ,, !(pr2 x)) ,, idpath _). Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInOp1Bicat.v000066400000000000000000000032631451125700300270010ustar00rootroot00000000000000(** Morphisms in op1 bicat Contents 1. Adjunctions *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Local Open Scope cat. (** 1. Adjunctions *) Definition op1_left_adjoint_to_right_adjoint {B : bicat} {x y : B} {f : x --> y} (Hf : @left_adjoint (op1_bicat B) _ _ f) : @internal_right_adj B _ _ f. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (left_adjoint_right_adjoint Hf). - exact (left_adjoint_unit Hf). - exact (left_adjoint_counit Hf). - exact (internal_triangle2 Hf). - exact (internal_triangle1 Hf). Defined. Definition right_adjoint_to_op1_left_adjoint {B : bicat} {x y : B} {f : x --> y} (Hf : @internal_right_adj B _ _ f) : @left_adjoint (op1_bicat B) _ _ f. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (internal_right_adj_left_adjoint Hf). - exact (internal_right_adj_unit Hf). - exact (internal_right_adj_counit Hf). - exact (pr22 Hf). - exact (pr12 Hf). Defined. Definition op1_left_adjoint_weq_right_adjoint {B : bicat} {x y : B} {f : x --> y} : @left_adjoint (op1_bicat B) _ _ f ≃ @internal_right_adj B _ _ f. Proof. use make_weq. - exact op1_left_adjoint_to_right_adjoint. - use isweq_iso. + exact right_adjoint_to_op1_left_adjoint. + intro. apply idpath. + intro. apply idpath. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInOp2Bicat.v000066400000000000000000000110661451125700300270020ustar00rootroot00000000000000(** Morphisms in op2 bicat Contents 1. Faithful 1-cells 2. Fully faithful 1-cells 3. Conservative 1-cells 4. Discrete 1-cells 5. Adjunctions *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Local Open Scope cat. (** 1. Faithful 1-cells *) Definition faithful_op2_bicat {B : bicat} {x y : B} {f : x --> y} (Hf : faithful_1cell f) : @faithful_1cell (op2_bicat B) _ _ f. Proof. intros z g₁ g₂ α β p. apply Hf. exact p. Defined. (** 2. Fully faithful 1-cells *) Definition fully_faithful_op2_bicat {B : bicat} {x y : B} {f : x --> y} (Hf : fully_faithful_1cell f) : @fully_faithful_1cell (op2_bicat B) _ _ f. Proof. use make_fully_faithful. - apply faithful_op2_bicat. apply fully_faithful_1cell_faithful. exact Hf. - intros z g₁ g₂ αf. simple refine (_ ,, _). + exact (fully_faithful_1cell_inv_map Hf αf). + cbn. apply fully_faithful_1cell_inv_map_eq. Defined. (** 3. Conservative 1-cells *) Definition conservative_op2_bicat {B : bicat} {x y : B} {f : x --> y} (Hf : conservative_1cell f) : @conservative_1cell (op2_bicat B) _ _ f. Proof. intros z g₁ g₂ α Hα. apply to_op2_is_invertible_2cell. apply Hf. apply from_op2_is_invertible_2cell. exact Hα. Defined. (** 4. Discrete 1-cells *) Definition discrete_op2_bicat {B : bicat} {x y : B} {f : x --> y} (Hf : discrete_1cell f) : @discrete_1cell (op2_bicat B) _ _ f. Proof. split. - apply faithful_op2_bicat. apply Hf. - apply conservative_op2_bicat. apply Hf. Defined. (** 5. Adjunctions *) Definition op2_left_adjoint_right_adjoint_is_left_adjoint {B : bicat} {x y : B} {f : x --> y} (Hf : @left_adjoint (op2_bicat B) _ _ f) : @left_adjoint B _ _ (left_adjoint_right_adjoint Hf). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact f. - exact (left_adjoint_counit Hf). - exact (left_adjoint_unit Hf). - abstract (cbn ; rewrite !vassocl ; exact (internal_triangle2 Hf)). - abstract (cbn ; rewrite !vassocl ; exact (internal_triangle1 Hf)). Defined. Definition op2_left_adjoint_to_right_adjoint {B : bicat} {x y : B} {f : x --> y} (Hf : @left_adjoint (op2_bicat B) _ _ f) : @internal_right_adj B _ _ f. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (left_adjoint_right_adjoint Hf). - exact (left_adjoint_counit Hf). - exact (left_adjoint_unit Hf). - abstract (cbn ; rewrite !vassocl ; exact (internal_triangle2 Hf)). - abstract (cbn ; rewrite !vassocl ; exact (internal_triangle1 Hf)). Defined. Definition right_adjoint_to_op2_left_adjoint {B : bicat} {x y : B} {f : x --> y} (Hf : @internal_right_adj B _ _ f) : @left_adjoint (op2_bicat B) _ _ f. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (internal_right_adj_left_adjoint Hf). - exact (internal_right_adj_counit Hf). - exact (internal_right_adj_unit Hf). - abstract (cbn ; rewrite !vassocr ; exact (pr22 Hf)). - abstract (cbn ; rewrite !vassocr ; exact (pr12 Hf)). Defined. Definition op2_left_adjoint_weq_right_adjoint {B : bicat} {x y : B} (f : x --> y) : @left_adjoint (op2_bicat B) _ _ f ≃ @internal_right_adj B _ _ f. Proof. use make_weq. - exact op2_left_adjoint_to_right_adjoint. - use isweq_iso. + exact right_adjoint_to_op2_left_adjoint. + abstract (intro Hf ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply idpath). + abstract (intro Hf ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply idpath). Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInSliceBicat.v000066400000000000000000000461011451125700300273770ustar00rootroot00000000000000(************************************************************************ Morphisms in the slice bicategory We give characterizations for properties of morphisms in the slice bictegory. These characterizations only hold when the bicategory is locally groupoidal. If the bicategory is not locally groupoidal, there still are conditions for proving these properties. Note that for esos, we assume that the bicategory is locally groupoidal, so that the fully faithful 1-cells are characterized correctly. Contents: 1. Proving properties of morphisms in the slice bicategory 1.1 Faithful 1-cells 1.2 Fully faithful 1-cells 1.3 Conservative 1-cells 1.4 Discrete 1-cells 1.5 Pseudomonic 1-cells 2. Characterizations 2.1 Faithful 1-cells 2.2 Fully faithful 1-cells 3. Constructing esos in slice bicategory ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Eso. Local Open Scope cat. (** 1. Proving properties of morphisms in the slice bicategory *) Section ToMorphismInSlice. Context {B : bicat} {b : B} {f₁ f₂ : slice_bicat b} (α : f₁ --> f₂). (** 1.1 Faithful 1-cells *) Definition to_faithful_slice (Hα : faithful_1cell (pr1 α)) : faithful_1cell α. Proof. intros g β₁ β₂ p₁ p₂ q. use eq_2cell_slice. apply Hα. exact (maponpaths pr1 q). Qed. (** 1.2 Fully faithful 1-cells *) Definition to_fully_faithful_slice (Hα : fully_faithful_1cell (pr1 α)) : fully_faithful_1cell α. Proof. use make_fully_faithful. - apply to_faithful_slice. exact (pr1 Hα). - intros g β₁ β₂ pf. simple refine ((_ ,, _) ,, _). + exact (fully_faithful_1cell_inv_map Hα (pr1 pf)). + abstract (cbn ; use (vcomp_rcancel (_ ◃ pr12 α)) ; [ is_iso ; apply property_from_invertible_2cell | ] ; rewrite !vassocl ; rewrite vcomp_whisker ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite (fully_faithful_1cell_inv_map_eq Hα (pr1 pf)) ; refine (_ @ pr2 pf) ; cbn ; rewrite !vassocl ; apply idpath). + abstract (use eq_2cell_slice ; cbn ; apply (fully_faithful_1cell_inv_map_eq Hα (pr1 pf))). Defined. (** 1.3 Conservative 1-cells *) Definition to_conservative_slice (Hα : conservative_1cell (pr1 α)) : conservative_1cell α. Proof. intros g β₁ β₂ p Hp. apply is_invertible_2cell_in_slice_bicat. apply Hα. apply (from_is_invertible_2cell_in_slice_bicat Hp). Defined. (** 1.4 Discrete 1-cells *) Definition to_discrete_slice (Hα : discrete_1cell (pr1 α)) : discrete_1cell α. Proof. split. - apply to_faithful_slice. exact (pr1 Hα). - apply to_conservative_slice. exact (pr2 Hα). Defined. (** 1.5 Pseudomonic 1-cells *) Definition to_pseudomonic_slice (Hα : pseudomonic_1cell (pr1 α)) : pseudomonic_1cell α. Proof. use make_pseudomonic. - apply to_faithful_slice. exact (pr1 Hα). - intros g β₁ β₂ pf Hpf. simple refine ((_ ,, _) ,, _ ,, _). + refine (pseudomonic_1cell_inv_map Hα (pr1 pf) _). exact (from_is_invertible_2cell_in_slice_bicat Hpf). + abstract (cbn ; use (vcomp_rcancel (_ ◃ pr12 α)) ; [ is_iso ; apply property_from_invertible_2cell | ] ; rewrite !vassocl ; rewrite vcomp_whisker ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite (pseudomonic_1cell_inv_map_eq Hα (pr1 pf)) ; refine (_ @ pr2 pf) ; cbn ; rewrite !vassocl ; apply idpath). + use is_invertible_2cell_in_slice_bicat. cbn. apply is_invertible_2cell_pseudomonic_1cell_inv_map. + abstract (use eq_2cell_slice ; cbn ; apply (pseudomonic_1cell_inv_map_eq Hα (pr1 pf))). Defined. End ToMorphismInSlice. (** 2. Characterizations *) Section FromMorphismInSlice. Context {B : bicat} (inv_B : locally_groupoid B) {b : B} {f₁ f₂ : slice_bicat b} (α : f₁ --> f₂). (** 2.1. Faithful 1-cells *) Definition from_faithful_slice (Hα : faithful_1cell α) : faithful_1cell (pr1 α). Proof. intros x g₁ g₂ α₁ α₂ p. pose (f₀ := make_ob_slice (g₁ · pr2 f₁)). pose (β₁ := @make_1cell_slice _ _ f₀ f₁ g₁ (id2_invertible_2cell _)). pose (β₂ := @make_1cell_slice _ _ f₀ f₁ g₂ (@make_invertible_2cell _ _ _ _ _ (α₁ ▹ _) (inv_B _ _ _ _ _))). assert (r₁ : cell_slice_homot β₁ β₂ α₁). { unfold cell_slice_homot. cbn. rewrite id2_left. apply idpath. } pose (p₁ := @make_2cell_slice _ _ _ _ β₁ β₂ α₁ r₁). assert (r₂ : cell_slice_homot β₁ β₂ α₂). { unfold cell_slice_homot. cbn. rewrite id2_left. use (vcomp_rcancel (_ ◃ pr12 α)) ; [ is_iso ; apply property_from_invertible_2cell | ]. rewrite !vcomp_whisker. apply maponpaths. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !rwhisker_rwhisker. do 2 apply maponpaths. exact (!p). } pose (p₂ := @make_2cell_slice _ _ _ _ β₁ β₂ α₂ r₂). assert (r : p₁ ▹ α = p₂ ▹ α). { use eq_2cell_slice ; cbn. exact p. } exact (maponpaths pr1 (Hα f₀ β₁ β₂ p₁ p₂ r)). Qed. Definition faithful_weq_slice : faithful_1cell (pr1 α) ≃ faithful_1cell α. Proof. use weqimplimpl. - apply to_faithful_slice. - apply from_faithful_slice. - apply isaprop_faithful_1cell. - apply isaprop_faithful_1cell. Qed. (** 2.2 Fully faithful 1-cells *) Section FromFullyFaithfulSlice. Context (Hα : fully_faithful_1cell α) {x : B} {g₁ g₂ : x --> pr1 f₁} (βf : g₁ · pr1 α ==> g₂ · pr1 α). Let h : slice_bicat b := make_ob_slice (g₁ · pr2 f₁). Let β₁ : h --> f₁ := @make_1cell_slice _ _ h f₁ g₁ (id2_invertible_2cell _). Let γ : invertible_2cell (g₁ · pr2 f₁) (g₂ · pr2 f₁). Proof. use make_invertible_2cell. - exact ((_ ◃ pr12 α) • lassociator _ _ _ • (βf ▹ _) • rassociator _ _ _ • (_ ◃ (pr22 α)^-1)). - apply inv_B. Defined. Let β₂ : h --> f₁ := @make_1cell_slice _ _ h f₁ g₂ γ. Local Lemma from_fully_faithful_slice_cell_homot : cell_slice_homot (β₁ · α) (β₂ · α) βf. Proof. unfold cell_slice_homot ; cbn. rewrite id2_left. rewrite !vassocl. do 2 apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_left. } rewrite rassociator_lassociator. apply id2_right. Qed. Let p : β₁ · α ==> β₂ · α := @make_2cell_slice _ _ _ _ (β₁ · α) (β₂ · α) βf from_fully_faithful_slice_cell_homot. Definition from_fully_faithful_slice_cell : g₁ ==> g₂ := pr1 (@fully_faithful_1cell_inv_map _ _ _ _ Hα h β₁ β₂ p). Definition from_fully_faithful_slice_cell_eq : from_fully_faithful_slice_cell ▹ pr1 α = βf := maponpaths pr1 (@fully_faithful_1cell_inv_map_eq _ _ _ _ Hα h β₁ β₂ p). End FromFullyFaithfulSlice. Definition from_fully_faithful_slice (Hα : fully_faithful_1cell α) : fully_faithful_1cell (pr1 α). Proof. use make_fully_faithful. - apply from_faithful_slice. exact (pr1 Hα). - intros x g₁ g₂ βf. simple refine (_ ,, _). + exact (from_fully_faithful_slice_cell Hα βf). + exact (from_fully_faithful_slice_cell_eq Hα βf). Defined. Definition fully_faithful_weq_slice : fully_faithful_1cell (pr1 α) ≃ fully_faithful_1cell α. Proof. use weqimplimpl. - apply to_fully_faithful_slice. - apply from_fully_faithful_slice. - apply isaprop_fully_faithful_1cell. - apply isaprop_fully_faithful_1cell. Qed. End FromMorphismInSlice. Section EsoSlice. Context {B : bicat} (HB : is_univalent_2_1 B) (inv_B : locally_groupoid B) {b : B} {f₁ f₂ : slice_bicat b} (α : f₁ --> f₂). (** 3. Constructing esos in slice bicategory *) Section ToSliceEsoFull. Context (Hα : is_eso (pr1 α)) {h₁ h₂ : slice_bicat b} {μ : h₁ --> h₂} (Hμ : fully_faithful_1cell μ) {β₁ β₂ : f₂ --> h₁} (p₁ : α · β₁ ==> α · β₂) (p₂ : β₁ · μ ==> β₂ · μ) (r : (p₁ ▹ μ) • rassociator α β₂ μ = rassociator α β₁ μ • (α ◃ p₂)). Definition to_eso_slice_lift_2_eq : cell_slice_homot β₁ β₂ (is_eso_lift_2 (pr1 α) Hα (from_fully_faithful_slice inv_B μ Hμ) (pr1 β₁) (pr1 β₂) (pr1 p₁) (pr1 p₂) (maponpaths pr1 r)). Proof. unfold cell_slice_homot. use (vcomp_rcancel (_ ◃ pr12 μ)). { is_iso. apply property_from_invertible_2cell. } rewrite !vassocl. rewrite vcomp_whisker. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- rwhisker_rwhisker. etrans. { do 4 apply maponpaths. apply is_eso_lift_2_right. } pose (r' := pr2 p₂). cbn in r'. rewrite !vassocl in r'. exact r'. Qed. Definition to_eso_slice_lift_2 : β₁ ==> β₂. Proof. use make_2cell_slice. - exact (is_eso_lift_2 _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) (pr1 p₁) (pr1 p₂) (maponpaths pr1 r)). - exact to_eso_slice_lift_2_eq. Defined. Definition to_eso_slice_lift_2_left : α ◃ to_eso_slice_lift_2 = p₁. Proof. use eq_2cell_slice. apply is_eso_lift_2_left. Qed. Definition to_eso_slice_lift_2_right : to_eso_slice_lift_2 ▹ μ = p₂. Proof. use eq_2cell_slice. apply is_eso_lift_2_right. Qed. End ToSliceEsoFull. Definition to_eso_full_slice (Hα : is_eso (pr1 α)) : is_eso_full α := λ h₁ h₂ μ Hμ β₁ β₂ p₁ p₂ r, to_eso_slice_lift_2 Hα Hμ p₁ p₂ r ,, to_eso_slice_lift_2_left Hα Hμ p₁ p₂ r ,, to_eso_slice_lift_2_right Hα Hμ p₁ p₂ r. Definition to_eso_faithful_slice (Hα : is_eso (pr1 α)) : is_eso_faithful α. Proof. intros h₁ h₂ μ Hμ β₁ β₂ p₁ p₂ r₁ r₂. use eq_2cell_slice. use (is_eso_lift_eq _ Hα (from_fully_faithful_slice inv_B _ Hμ)). - exact (maponpaths pr1 r₁). - exact (maponpaths pr1 r₂). Qed. Section ToSliceEsoEssentiallySurjective. Context (Hα : is_eso (pr1 α)) {g₁ g₂ : slice_bicat b} {μ : g₁ --> g₂} (Hμ : fully_faithful_1cell μ) {β₁ : f₁ --> g₁} {β₂ : f₂ --> g₂} (p : invertible_2cell (β₁ · μ) (α · β₂)). Let γ : invertible_2cell (pr1 β₁ · pr1 μ) (pr1 α · pr1 β₂). Proof. use make_invertible_2cell. - exact (pr11 p). - apply inv_B. Defined. Definition to_eso_slice_lift_1 : f₂ --> g₁. Proof. simple refine (_ ,, _). - exact (is_eso_lift_1 _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) γ). - pose (is_eso_lift_1_comm_right _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) γ) as i. use make_invertible_2cell. + exact (pr12 β₂ • (i^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (pr22 μ)^-1)). + apply inv_B. Defined. Definition to_eso_slice_lift_1_left_eq : cell_slice_homot (α · to_eso_slice_lift_1) β₁ (is_eso_lift_1_comm_left (pr1 α) Hα (from_fully_faithful_slice inv_B μ Hμ) (pr1 β₁) (pr1 β₂) γ). Proof. unfold cell_slice_homot. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite !vassocl. pose (is_eso_lift_1_eq _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) γ) as H. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left] in H. use vcomp_move_R_pM ; [ apply property_from_invertible_2cell | ]. use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ]. use vcomp_move_R_pM ; [ is_iso | ]. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite !vassocr. etrans. { apply maponpaths_2. rewrite lwhisker_hcomp. rewrite inverse_pentagon_5. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ]. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ]. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- H. rewrite !vassocl. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. apply maponpaths. clear H. pose (pr21 p) as H. cbn in H. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]. use vcomp_move_L_Mp ; [ apply property_from_invertible_2cell | ]. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite !vassocr. refine (!_). etrans. { do 2 apply maponpaths_2. rewrite !vassocl. rewrite !vassocl in H. exact H. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_right. Qed. Definition to_eso_slice_lift_1_left : invertible_2cell (α · to_eso_slice_lift_1) β₁. Proof. use make_invertible_2cell. - use make_2cell_slice. + exact (is_eso_lift_1_comm_left _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) γ). + exact to_eso_slice_lift_1_left_eq. - apply is_invertible_2cell_in_slice_bicat. apply inv_B. Defined. Definition to_eso_slice_lift_1_right_eq : cell_slice_homot (to_eso_slice_lift_1 · μ) β₂ (is_eso_lift_1_comm_right (pr1 α) Hα (from_fully_faithful_slice inv_B μ Hμ) (pr1 β₁) (pr1 β₂) γ). Proof. unfold cell_slice_homot. cbn -[is_eso_lift_1_comm_right is_eso_lift_1_comm_left]. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_right. Qed. Definition to_eso_slice_lift_1_right : invertible_2cell (to_eso_slice_lift_1 · μ) β₂. Proof. use make_invertible_2cell. - use make_2cell_slice. + exact (is_eso_lift_1_comm_right _ Hα (from_fully_faithful_slice inv_B _ Hμ) (pr1 β₁) (pr1 β₂) γ). + exact to_eso_slice_lift_1_right_eq. - apply is_invertible_2cell_in_slice_bicat. apply inv_B. Defined. Definition to_eso_slice_lift_1_eq : (to_eso_slice_lift_1_left ▹ μ) • p = rassociator _ _ _ • (α ◃ to_eso_slice_lift_1_right). Proof. use eq_2cell_slice. apply is_eso_lift_1_eq. Qed. End ToSliceEsoEssentiallySurjective. Definition to_eso_essentially_surjective_slice (Hα : is_eso (pr1 α)) : is_eso_essentially_surjective α := λ g₁ g₂ μ Hμ β₁ β₂ p, to_eso_slice_lift_1 Hα Hμ p ,, to_eso_slice_lift_1_left Hα Hμ p ,, to_eso_slice_lift_1_right Hα Hμ p ,, to_eso_slice_lift_1_eq Hα Hμ p. Definition to_eso_slice (Hα : is_eso (pr1 α)) : is_eso α. Proof. use make_is_eso. - use is_univalent_2_1_slice_bicat. exact HB. - exact (to_eso_full_slice Hα). - exact (to_eso_faithful_slice Hα). - exact (to_eso_essentially_surjective_slice Hα). Defined. End EsoSlice. UniMath-20231010/UniMath/Bicategories/Morphisms/Examples/MorphismsInStructuredCat.v000066400000000000000000000352401451125700300301730ustar00rootroot00000000000000(****************************************************************** Morphisms in structured categories Contents 1. Adjunctions of categories with a terminal object 2. Adjunctions of categories with binary products 3. Adjunctions of categories with pullbacks 4. Adjunctions of categories with an initial object 5. Adjunctions of categories with binary coproducts ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.StructuredCategories. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell. Local Open Scope cat. (** 1. Adjunctions of categories with a terminal object *) Section DispAdjunctionTerminalObj. Context {C₁ C₂ : bicat_of_univ_cats} (a : adjunction C₁ C₂) (CC₁ : disp_bicat_terminal_obj C₁) (CC₂ : disp_bicat_terminal_obj C₂). Definition isaprop_disp_adjunction_univ_cat_with_terminal_obj : isaprop (disp_adjunction a CC₁ CC₂). Proof. use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; simpl. - apply isapropdirprod. + apply isapropunit. + apply isaprop_preserves_terminal. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). * simpl. apply isapropdirprod. ** apply isapropunit. ** apply isaprop_preserves_terminal. * apply isapropdirprod. ** simpl ; apply isapropdirprod ; apply isapropunit. ** simpl ; apply isapropdirprod ; apply isapropunit. + apply isapropdirprod ; apply disp_bicat_terminal_obj. Qed. Section MakeDispAdj. Context (H : preserves_terminal (pr1 a)). Let F : CC₁ -->[ a ] CC₂ := tt ,, H. Local Definition disp_left_adjoint_data_univ_cat_with_terminal_obj : disp_left_adjoint_data a F. Proof. refine ((tt ,, _) ,, ((tt ,, tt) ,, (tt ,, tt))). exact (right_adjoint_preserves_terminal _ (left_adjoint_to_is_left_adjoint a)). Defined. Local Definition disp_left_adjoint_axioms_univ_cat_with_terminal_obj : disp_left_adjoint_axioms a disp_left_adjoint_data_univ_cat_with_terminal_obj. Proof. split ; apply disp_2cells_isaprop_subbicat. Qed. Local Definition disp_left_adjoint_univ_cat_with_terminal_obj : disp_left_adjoint a F. Proof. simple refine (_ ,, _). - exact disp_left_adjoint_data_univ_cat_with_terminal_obj. - exact disp_left_adjoint_axioms_univ_cat_with_terminal_obj. Defined. Definition disp_adjunction_univ_cat_with_terminal_obj : disp_adjunction a CC₁ CC₂. Proof. simple refine (_ ,, _). - exact F. - exact disp_left_adjoint_univ_cat_with_terminal_obj. Defined. End MakeDispAdj. Definition disp_adj_weq_preserves_terminal : disp_adjunction a CC₁ CC₂ ≃ preserves_terminal (pr1 a). Proof. use weqimplimpl. - intro aa. apply aa. - exact disp_adjunction_univ_cat_with_terminal_obj. - apply isaprop_disp_adjunction_univ_cat_with_terminal_obj. - apply isaprop_preserves_terminal. Defined. End DispAdjunctionTerminalObj. (** 2. Adjunctions of categories with binary products *) Section DispAdjunctionBinproduct. Context {C₁ C₂ : bicat_of_univ_cats} (a : adjunction C₁ C₂) (CC₁ : disp_bicat_binprod C₁) (CC₂ : disp_bicat_binprod C₂). Definition isaprop_disp_adjunction_univ_cat_with_binprod : isaprop (disp_adjunction a CC₁ CC₂). Proof. use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; simpl. - apply isapropdirprod. + apply isapropunit. + apply isaprop_preserves_binproduct. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). * simpl. apply isapropdirprod. ** apply isapropunit. ** apply isaprop_preserves_binproduct. * apply isapropdirprod. ** simpl ; apply isapropdirprod ; apply isapropunit. ** simpl ; apply isapropdirprod ; apply isapropunit. + apply isapropdirprod ; apply disp_bicat_binprod. Qed. Section MakeDispAdj. Context (H : preserves_binproduct (pr1 a)). Let F : CC₁ -->[ a ] CC₂ := tt ,, H. Local Definition disp_left_adjoint_data_univ_cat_with_binprod : disp_left_adjoint_data a F. Proof. refine ((tt ,, _) ,, ((tt ,, tt) ,, (tt ,, tt))). exact (right_adjoint_preserves_binproduct _ (left_adjoint_to_is_left_adjoint a)). Defined. Local Definition disp_left_adjoint_axioms_univ_cat_with_binprod : disp_left_adjoint_axioms a disp_left_adjoint_data_univ_cat_with_binprod. Proof. split ; apply disp_2cells_isaprop_subbicat. Qed. Local Definition disp_left_adjoint_univ_cat_with_binprod : disp_left_adjoint a F. Proof. simple refine (_ ,, _). - exact disp_left_adjoint_data_univ_cat_with_binprod. - exact disp_left_adjoint_axioms_univ_cat_with_binprod. Defined. Definition disp_adjunction_univ_cat_with_binprod : disp_adjunction a CC₁ CC₂. Proof. simple refine (_ ,, _). - exact F. - exact disp_left_adjoint_univ_cat_with_binprod. Defined. End MakeDispAdj. Definition disp_adj_weq_preserves_binprod : disp_adjunction a CC₁ CC₂ ≃ preserves_binproduct (pr1 a). Proof. use weqimplimpl. - intro aa. apply aa. - exact disp_adjunction_univ_cat_with_binprod. - apply isaprop_disp_adjunction_univ_cat_with_binprod. - apply isaprop_preserves_binproduct. Defined. End DispAdjunctionBinproduct. (** 3. Adjunctions of categories with pullbacks *) Section DispAdjunctionPullback. Context {C₁ C₂ : bicat_of_univ_cats} (a : adjunction C₁ C₂) (CC₁ : disp_bicat_pullback C₁) (CC₂ : disp_bicat_pullback C₂). Definition isaprop_disp_adjunction_univ_cat_with_pb : isaprop (disp_adjunction a CC₁ CC₂). Proof. use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; simpl. - apply isapropdirprod. + apply isapropunit. + apply isaprop_preserves_pullback. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). * simpl. apply isapropdirprod. ** apply isapropunit. ** apply isaprop_preserves_pullback. * apply isapropdirprod. ** simpl ; apply isapropdirprod ; apply isapropunit. ** simpl ; apply isapropdirprod ; apply isapropunit. + apply isapropdirprod ; apply disp_bicat_pullback. Qed. Section MakeDispAdj. Context (H : preserves_pullback (pr1 a)). Let F : CC₁ -->[ a ] CC₂ := tt ,, H. Local Definition disp_left_adjoint_data_univ_cat_with_pb : disp_left_adjoint_data a F. Proof. refine ((tt ,, _) ,, ((tt ,, tt) ,, (tt ,, tt))). exact (right_adjoint_preserves_pullback _ (left_adjoint_to_is_left_adjoint a)). Defined. Local Definition disp_left_adjoint_axioms_univ_cat_with_pb : disp_left_adjoint_axioms a disp_left_adjoint_data_univ_cat_with_pb. Proof. split ; apply disp_2cells_isaprop_subbicat. Qed. Local Definition disp_left_adjoint_univ_cat_with_pb : disp_left_adjoint a F. Proof. simple refine (_ ,, _). - exact disp_left_adjoint_data_univ_cat_with_pb. - exact disp_left_adjoint_axioms_univ_cat_with_pb. Defined. Definition disp_adjunction_univ_cat_with_pb : disp_adjunction a CC₁ CC₂. Proof. simple refine (_ ,, _). - exact F. - exact disp_left_adjoint_univ_cat_with_pb. Defined. End MakeDispAdj. Definition disp_adj_weq_preserves_pb : disp_adjunction a CC₁ CC₂ ≃ preserves_pullback (pr1 a). Proof. use weqimplimpl. - intro aa. apply aa. - exact disp_adjunction_univ_cat_with_pb. - apply isaprop_disp_adjunction_univ_cat_with_pb. - apply isaprop_preserves_pullback. Defined. End DispAdjunctionPullback. (** 4. Adjunctions of categories with an initial object *) Section DispAdjunctionInitial. Context {C₁ C₂ : bicat_of_univ_cats} (a : adjunction C₁ C₂) (CC₁ : disp_bicat_initial_obj C₁) (CC₂ : disp_bicat_initial_obj C₂). Definition isaprop_disp_adjunction_univ_cat_with_initial : isaprop (disp_adjunction a CC₁ CC₂). Proof. use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; simpl. - apply isapropdirprod. + apply isapropunit. + apply isaprop_preserves_initial. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). * simpl. apply isapropdirprod. ** apply isapropunit. ** apply isaprop_preserves_initial. * apply isapropdirprod. ** simpl ; apply isapropdirprod ; apply isapropunit. ** simpl ; apply isapropdirprod ; apply isapropunit. + apply isapropdirprod ; apply disp_bicat_initial_obj. Qed. Section MakeDispAdj. Context (H : preserves_initial (pr112 a)). Local Definition disp_left_adjoint_univ_cat_with_initial_1cell : CC₁ -->[ a ] CC₂. Proof. refine (tt ,, _). exact (left_adjoint_preserves_initial _ (left_adjoint_to_is_left_adjoint a)). Defined. Let F := disp_left_adjoint_univ_cat_with_initial_1cell. Local Definition disp_left_adjoint_data_univ_cat_with_initial : disp_left_adjoint_data a F. Proof. refine ((tt ,, H) ,, ((tt ,, tt) ,, (tt ,, tt))). Defined. Local Definition disp_left_adjoint_axioms_univ_cat_with_initial : disp_left_adjoint_axioms a disp_left_adjoint_data_univ_cat_with_initial. Proof. split ; apply disp_2cells_isaprop_subbicat. Qed. Local Definition disp_left_adjoint_univ_cat_with_initial : disp_left_adjoint a F. Proof. simple refine (_ ,, _). - exact disp_left_adjoint_data_univ_cat_with_initial. - exact disp_left_adjoint_axioms_univ_cat_with_initial. Defined. Definition disp_adjunction_univ_cat_with_initial : disp_adjunction a CC₁ CC₂. Proof. simple refine (_ ,, _). - exact F. - exact disp_left_adjoint_univ_cat_with_initial. Defined. End MakeDispAdj. Definition disp_adj_weq_preserves_initial : disp_adjunction a CC₁ CC₂ ≃ preserves_initial (pr112 a). Proof. use weqimplimpl. - intro aa. apply aa. - exact disp_adjunction_univ_cat_with_initial. - apply isaprop_disp_adjunction_univ_cat_with_initial. - apply isaprop_preserves_initial. Defined. End DispAdjunctionInitial. (** 5. Adjunctions of categories with binary coproducts *) Section DispAdjunctionCoprod. Context {C₁ C₂ : bicat_of_univ_cats} (a : adjunction C₁ C₂) (CC₁ : disp_bicat_bincoprod C₁) (CC₂ : disp_bicat_bincoprod C₂). Definition isaprop_disp_adjunction_univ_cat_with_bincoprod : isaprop (disp_adjunction a CC₁ CC₂). Proof. use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; simpl. - apply isapropdirprod. + apply isapropunit. + apply isaprop_preserves_bincoproduct. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). * simpl. apply isapropdirprod. ** apply isapropunit. ** apply isaprop_preserves_bincoproduct. * apply isapropdirprod. ** simpl ; apply isapropdirprod ; apply isapropunit. ** simpl ; apply isapropdirprod ; apply isapropunit. + apply isapropdirprod ; apply disp_bicat_bincoprod. Qed. Section MakeDispAdj. Context (H : preserves_bincoproduct (pr112 a)). Local Definition disp_left_adjoint_univ_cat_with_bincoprod_1cell : CC₁ -->[ a ] CC₂. Proof. refine (tt ,, _). exact (left_adjoint_preserves_bincoproduct _ (left_adjoint_to_is_left_adjoint a)). Defined. Let F := disp_left_adjoint_univ_cat_with_bincoprod_1cell. Local Definition disp_left_adjoint_data_univ_cat_with_bincoprod : disp_left_adjoint_data a F. Proof. refine ((tt ,, H) ,, ((tt ,, tt) ,, (tt ,, tt))). Defined. Local Definition disp_left_adjoint_axioms_univ_cat_with_bincoprod : disp_left_adjoint_axioms a disp_left_adjoint_data_univ_cat_with_bincoprod. Proof. split ; apply disp_2cells_isaprop_subbicat. Qed. Local Definition disp_left_adjoint_univ_cat_with_bincoprod : disp_left_adjoint a F. Proof. simple refine (_ ,, _). - exact disp_left_adjoint_data_univ_cat_with_bincoprod. - exact disp_left_adjoint_axioms_univ_cat_with_bincoprod. Defined. Definition disp_adjunction_univ_cat_with_bincoprod : disp_adjunction a CC₁ CC₂. Proof. simple refine (_ ,, _). - exact F. - exact disp_left_adjoint_univ_cat_with_bincoprod. Defined. End MakeDispAdj. Definition disp_adj_weq_preserves_bincoprod : disp_adjunction a CC₁ CC₂ ≃ preserves_bincoproduct (pr112 a). Proof. use weqimplimpl. - intro aa. apply aa. - exact disp_adjunction_univ_cat_with_bincoprod. - apply isaprop_disp_adjunction_univ_cat_with_bincoprod. - apply isaprop_preserves_bincoproduct. Defined. End DispAdjunctionCoprod. UniMath-20231010/UniMath/Bicategories/Morphisms/ExtensionsAndLiftings.v000066400000000000000000000477361451125700300257270ustar00rootroot00000000000000(**************************************************************************** Extensions and liftings in bicategories A fundamental notion in category theory is that of a Kan extension. These come in various flavors, among which are global Kan extensions and absolute Kan extensions. In this file, we define various notions of Kan extensions internal to arbitrary bicategories. One nice aspect of this approach is that there is one unifying definition for all variations. By instantiating the notion of left Kan extensions to various bicategories, we can recover other variations of extensions. This is summarized in the following table: Notion of Kan extension/lifting | Corresponding bicategory ----------------------------------------------------------- Left Kan extension | B Left lifting | B^op Right Kan extension | B^co Right lifting | B^coop Concretely, left Kan extensions in `B^op` are the same as left liftings in `B`, and the same for the other rows. We also define when 1-cells preserve left Kan extensions, and using that, we define the notion of absolute Kan extensions. An overview of these definitions can be found in: Yoneda structures from 2-toposes by Mark Weber Contents: 1. Left extensions 2. Left liftings 3. Left liftings as left extensions in the opposite bicategory 4. Right extensions 5. Right extension as left extensions 6. Right liftings 7. Right liftings as left extensions ****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Local Open Scope cat. (** 1. Left extensions *) Section LeftExtension. Context {B : bicat} {x y z : B} (f : x --> z) (g : x --> y). Definition is_left_extension {h : y --> z} (τ : f ==> g · h) : UU := ∏ (k : y --> z), isweq (λ (θ : h ==> k), τ • (g ◃ θ)). Section Projections. Context {h : y --> z} {τ : f ==> g · h} (Hτ : is_left_extension τ). Definition is_left_extension_extend {k : y --> z} (θ : f ==> g · k) : h ==> k := invmap (make_weq _ (Hτ k)) θ. Proposition is_left_extension_extend_left {k : y --> z} (θ : h ==> k) : is_left_extension_extend (τ • (g ◃ θ)) = θ. Proof. exact (homotinvweqweq (make_weq _ (Hτ k)) θ). Qed. Proposition is_left_extension_extend_right {k : y --> z} (θ : f ==> g · k) : τ • (g ◃ is_left_extension_extend θ) = θ. Proof. exact (homotweqinvweq (make_weq _ (Hτ k)) θ). Qed. End Projections. Proposition make_is_left_extension {h : y --> z} (τ : f ==> g · h) (F : ∏ (k : y --> z) (θ : f ==> g · k), h ==> k) (HF₁ : ∏ (k : y --> z) (θ : h ==> k), F k (τ • (g ◃ θ)) = θ) (HF₂ : ∏ (k : y --> z) (θ : f ==> g · k), τ • (g ◃ F k θ) = θ) : is_left_extension τ. Proof. intros k. use isweq_iso. - exact (F k). - exact (HF₁ k). - exact (HF₂ k). Defined. Proposition isaprop_is_left_extension {h : y --> z} (τ : f ==> g · h) : isaprop (is_left_extension τ). Proof. use impred ; intro. apply isapropisweq. Qed. Definition left_extension : UU := ∑ (h : y --> z) (τ : f ==> g · h), is_left_extension τ. Coercion mor_of_left_extension (h : left_extension) : y --> z := pr1 h. Definition cell_of_left_extension (h : left_extension) : f ==> g · h := pr12 h. Coercion left_extension_is_left_extension (h : left_extension) : is_left_extension (cell_of_left_extension h) := pr22 h. End LeftExtension. Definition preserves_is_left_extension {B : bicat} {x y z a : B} {f : x --> z} {g : x --> y} (k : z --> a) {h : y --> z} {τ : f ==> g · h} (Hτ : is_left_extension f g τ) : UU := is_left_extension (f · k) g ((τ ▹ k) • rassociator _ _ _). Proposition isaprop_preserves_is_left_extension {B : bicat} {x y z a : B} {f : x --> z} {g : x --> y} (k : z --> a) {h : y --> z} {τ : f ==> g · h} (Hτ : is_left_extension f g τ) : isaprop (preserves_is_left_extension k Hτ). Proof. apply isaprop_is_left_extension. Qed. Definition is_absolute_left_extension {B : bicat} {x y z : B} {f : x --> z} {g : x --> y} {h : y --> z} {τ : f ==> g · h} (Hτ : is_left_extension f g τ) : UU := ∏ (a : B) (k : z --> a), preserves_is_left_extension k Hτ. Proposition isaprop_is_absolute_left_extension {B : bicat} {x y z : B} {f : x --> z} {g : x --> y} {h : y --> z} {τ : f ==> g · h} (Hτ : is_left_extension f g τ) : isaprop (is_absolute_left_extension Hτ). Proof. do 2 (use impred ; intro). apply isaprop_preserves_is_left_extension. Qed. (** 2. Left liftings *) Section LeftLifting. Context {B : bicat} {x y z : B} (f : z --> x) (g : y --> x). Definition is_left_lifting {h : z --> y} (τ : f ==> h · g) : UU := ∏ (k : z --> y), isweq (λ (θ : h ==> k), τ • (θ ▹ g)). Section Projections. Context {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting τ). Definition is_left_lifting_lift {k : z --> y} (θ : f ==> k · g) : h ==> k := invmap (make_weq _ (Hτ k)) θ. Proposition is_left_lifting_lift_left {k : z --> y} (θ : h ==> k) : is_left_lifting_lift (τ • (θ ▹ g)) = θ. Proof. exact (homotinvweqweq (make_weq _ (Hτ k)) θ). Qed. Proposition is_left_lifting_lift_right {k : z --> y} (θ : f ==> k · g) : τ • (is_left_lifting_lift θ ▹ g) = θ. Proof. exact (homotweqinvweq (make_weq _ (Hτ k)) θ). Qed. End Projections. Proposition make_is_left_lifting {h : z --> y} (τ : f ==> h · g) (F : ∏ (k : z --> y) (θ : f ==> k · g), h ==> k) (HF₁ : ∏ (k : z --> y) (θ : h ==> k), F k (τ • (θ ▹ g)) = θ) (HF₂ : ∏ (k : z --> y) (θ : f ==> k · g), τ • (F k θ ▹ g) = θ) : is_left_lifting τ. Proof. intros k. use isweq_iso. - exact (F k). - exact (HF₁ k). - exact (HF₂ k). Defined. Proposition isaprop_is_left_lifting {h : z --> y} (τ : f ==> h · g) : isaprop (is_left_lifting τ). Proof. use impred ; intro. apply isapropisweq. Qed. Definition left_lifting : UU := ∑ (h : z --> y) (τ : f ==> h · g), is_left_lifting τ. Coercion mor_of_left_lifting (h : left_lifting) : z --> y := pr1 h. Definition cell_of_left_lifting (h : left_lifting) : f ==> h · g := pr12 h. Coercion left_lifting_is_left_lifting (h : left_lifting) : is_left_lifting (cell_of_left_lifting h) := pr22 h. End LeftLifting. Definition preserves_is_left_lifting {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : UU := is_left_lifting (k · f) g ((k ◃ τ) • lassociator _ _ _). Proposition isaprop_preserves_is_left_lifting {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : isaprop (preserves_is_left_lifting k Hτ). Proof. apply isaprop_is_left_lifting. Qed. Definition is_absolute_left_lifting {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : UU := ∏ (a : B) (k : a --> z), preserves_is_left_lifting k Hτ. Proposition isaprop_is_absolute_left_lifting {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : isaprop (is_absolute_left_lifting Hτ). Proof. do 2 (use impred ; intro). apply isaprop_preserves_is_left_lifting. Qed. (** 3. Left liftings as left extensions in the opposite bicategory *) Definition is_left_extension_weq_is_left_lifting_op {B : bicat} {x y z : B} (f : z --> x) (g : y --> x) {h : z --> y} (τ : f ==> h · g) : is_left_lifting _ _ τ ≃ @is_left_extension (op1_bicat B) x y z f g h τ. Proof. exact (idweq _). Defined. Definition preserves_is_left_extension_weq_preserves_is_left_lifting_op {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : preserves_is_left_lifting k Hτ ≃ @preserves_is_left_extension (op1_bicat B) _ _ _ _ _ _ k _ _ Hτ. Proof. exact (idweq _). Defined. Definition is_absolute_left_extension_weq_is_absolute_left_lifting_op {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : f ==> h · g} (Hτ : is_left_lifting f g τ) : is_absolute_left_lifting Hτ ≃ @is_absolute_left_extension (op1_bicat B) _ _ _ _ _ _ _ Hτ. Proof. exact (idweq _). Defined. (** 4. Right extensions *) Section RightExtension. Context {B : bicat} {x y z : B} (f : x --> z) (g : x --> y). Definition is_right_extension {h : y --> z} (τ : g · h ==> f) : UU := ∏ (k : y --> z), isweq (λ (θ : k ==> h), (g ◃ θ) • τ). Section Projections. Context {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension τ). Definition is_right_extension_extend {k : y --> z} (θ : g · k ==> f) : k ==> h := invmap (make_weq _ (Hτ k)) θ. Proposition is_right_extension_extend_left {k : y --> z} (θ : k ==> h) : is_right_extension_extend ((g ◃ θ) • τ) = θ. Proof. exact (homotinvweqweq (make_weq _ (Hτ k)) θ). Qed. Proposition is_right_extension_extend_right {k : y --> z} (θ : g · k ==> f) : (g ◃ is_right_extension_extend θ) • τ = θ. Proof. exact (homotweqinvweq (make_weq _ (Hτ k)) θ). Qed. End Projections. Proposition make_is_right_extension {h : y --> z} (τ : g · h ==> f) (F : ∏ (k : y --> z) (θ : g · k ==> f), k ==> h) (HF₁ : ∏ (k : y --> z) (θ : k ==> h), F k ((g ◃ θ) • τ) = θ) (HF₂ : ∏ (k : y --> z) (θ : g · k ==> f), (g ◃ F k θ) • τ = θ) : is_right_extension τ. Proof. intros k. use isweq_iso. - exact (F k). - exact (HF₁ k). - exact (HF₂ k). Defined. Proposition isaprop_is_right_extension {h : y --> z} (τ : g · h ==> f) : isaprop (is_right_extension τ). Proof. use impred ; intro. apply isapropisweq. Qed. Definition right_extension : UU := ∑ (h : y --> z) (τ : g · h ==> f), is_right_extension τ. Coercion mor_of_right_extension (h : right_extension) : y --> z := pr1 h. Definition cell_of_right_extension (h : right_extension) : g · h ==> f := pr12 h. Coercion right_extension_is_right_extension (h : right_extension) : is_right_extension (cell_of_right_extension h) := pr22 h. End RightExtension. Definition preserves_is_right_extension {B : bicat} {x y z a : B} {f : x --> z} {g : x --> y} (k : z --> a) {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : UU := is_right_extension (f · k) g (lassociator _ _ _ • (τ ▹ k)). Proposition isaprop_preserves_is_right_extension {B : bicat} {x y z a : B} {f : x --> z} {g : x --> y} (k : z --> a) {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : isaprop (preserves_is_right_extension k Hτ). Proof. apply isaprop_is_right_extension. Qed. Definition is_absolute_right_extension {B : bicat} {x y z : B} {f : x --> z} {g : x --> y} {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : UU := ∏ (a : B) (k : z --> a), preserves_is_right_extension k Hτ. Proposition isaprop_is_absolute_right_extension {B : bicat} {x y z : B} {f : x --> z} {g : x --> y} {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : isaprop (is_absolute_right_extension Hτ). Proof. do 2 (use impred ; intro). apply isaprop_preserves_is_right_extension. Qed. (** 5. Right extension as left extensions *) Definition is_left_extension_weq_is_right_extension_co {B : bicat} {x y z : B} (f : x --> z) (g : x --> y) {h : y --> z} (τ : g · h ==> f) : is_right_extension f g τ ≃ @is_left_extension (op2_bicat B) x y z f g h τ. Proof. exact (idweq _). Defined. Definition preserves_is_left_extension_weq_preserves_is_right_extension_co {B : bicat} {x y z a : B} {f : x --> z} {g : x --> y} (k : z --> a) {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : preserves_is_right_extension k Hτ ≃ @preserves_is_left_extension (op2_bicat B) _ _ _ _ _ _ k _ _ Hτ. Proof. exact (idweq _). Defined. Definition is_absolute_left_extension_weq_is_absolute_right_extension_op {B : bicat} {x y z : B} {f : x --> z} {g : x --> y} {h : y --> z} {τ : g · h ==> f} (Hτ : is_right_extension f g τ) : is_absolute_right_extension Hτ ≃ @is_absolute_left_extension (op2_bicat B) _ _ _ _ _ _ _ Hτ. Proof. exact (idweq _). Defined. (** 6. Right liftings *) Section RightLifting. Context {B : bicat} {x y z : B} (f : z --> x) (g : y --> x). Definition is_right_lifting {h : z --> y} (τ : h · g ==> f) : UU := ∏ (k : z --> y), isweq (λ (θ : k ==> h), (θ ▹ g) • τ). Section Projections. Context {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting τ). Definition is_right_lifting_lift {k : z --> y} (θ : k · g ==> f) : k ==> h := invmap (make_weq _ (Hτ k)) θ. Proposition is_right_lifting_lift_left {k : z --> y} (θ : k ==> h) : is_right_lifting_lift ((θ ▹ g) • τ) = θ. Proof. exact (homotinvweqweq (make_weq _ (Hτ k)) θ). Qed. Proposition is_right_lifting_lift_right {k : z --> y} (θ : k · g ==> f) : (is_right_lifting_lift θ ▹ g) • τ = θ. Proof. exact (homotweqinvweq (make_weq _ (Hτ k)) θ). Qed. End Projections. Proposition make_is_right_lifting {h : z --> y} (τ : h · g ==> f) (F : ∏ (k : z --> y) (θ : k · g ==> f), k ==> h) (HF₁ : ∏ (k : z --> y) (θ : k ==> h), F k ((θ ▹ g) • τ) = θ) (HF₂ : ∏ (k : z --> y) (θ : k · g ==> f), (F k θ ▹ g) • τ = θ) : is_right_lifting τ. Proof. intros k. use isweq_iso. - exact (F k). - exact (HF₁ k). - exact (HF₂ k). Defined. Proposition isaprop_is_right_lifting {h : z --> y} (τ : h · g ==> f) : isaprop (is_right_lifting τ). Proof. use impred ; intro. apply isapropisweq. Qed. Definition right_lifting : UU := ∑ (h : z --> y) (τ : h · g ==> f), is_right_lifting τ. Coercion mor_of_right_lifting (h : right_lifting) : z --> y := pr1 h. Definition cell_of_right_lifting (h : right_lifting) : h · g ==> f := pr12 h. Coercion right_lifting_is_left_lifting (h : right_lifting) : is_right_lifting (cell_of_right_lifting h) := pr22 h. End RightLifting. Definition preserves_is_right_lifting {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : UU := is_right_lifting (k · f) g (rassociator _ _ _ • (k ◃ τ)). Proposition isaprop_preserves_is_right_lifting {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : isaprop (preserves_is_right_lifting k Hτ). Proof. apply isaprop_is_right_lifting. Qed. Definition is_absolute_right_lifting {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : UU := ∏ (a : B) (k : a --> z), preserves_is_right_lifting k Hτ. Proposition isaprop_is_absolute_right_lifting {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : isaprop (is_absolute_right_lifting Hτ). Proof. do 2 (use impred ; intro). apply isaprop_preserves_is_right_lifting. Qed. (** 7. Right liftings as left extensions *) Definition is_left_extension_weq_is_right_lifting_coop {B : bicat} {x y z : B} (f : z --> x) (g : y --> x) {h : z --> y} (τ : h · g ==> f) : is_right_lifting f g τ ≃ @is_left_extension (op2_bicat (op1_bicat B)) x y z f g h τ. Proof. exact (idweq _). Defined. Definition preserves_is_left_extension_weq_preserves_is_right_lifting_coop {B : bicat} {x y z a : B} {f : z --> x} {g : y --> x} (k : a --> z) {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : preserves_is_right_lifting k Hτ ≃ @preserves_is_left_extension (op2_bicat (op1_bicat B)) _ _ _ _ _ _ k _ _ Hτ. Proof. exact (idweq _). Defined. Definition is_absolute_left_extension_weq_is_absolute_right_lifting_coop {B : bicat} {x y z : B} {f : z --> x} {g : y --> x} {h : z --> y} {τ : h · g ==> f} (Hτ : is_right_lifting f g τ) : is_absolute_right_lifting Hτ ≃ @is_absolute_left_extension (op2_bicat (op1_bicat B)) _ _ _ _ _ _ _ Hτ. Proof. exact (idweq _). Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/FullyFaithful.v000066400000000000000000000335671451125700300242200ustar00rootroot00000000000000(** Faithful and fully faithful 1-cells in bicategories Contents: 1. Definition of faithful 1-cells 2. Characterization of faithful 1-cells 3. Fully faithful 1-cells 4. Characterization of fully faithful 1-cells 5. Pseudomonic 1-cells 6. Characterization of pseudomonic 1-cells 7. Pseudomonic 1-cells in locally groupoidal bicategories *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Local Open Scope cat. (** 1. Definition of faithful 1-cells *) Definition faithful_1cell {B : bicat} {a b : B} (f : a --> b) : UU := ∏ (z : B) (g₁ g₂ : z --> a) (α₁ α₂ : g₁ ==> g₂), α₁ ▹ f = α₂ ▹ f → α₁ = α₂. Definition faithful_1cell_eq_cell {B : bicat} {a b : B} {f : a --> b} (Hf : faithful_1cell f) {z : B} {g₁ g₂ : z --> a} {α₁ α₂ : g₁ ==> g₂} (p : α₁ ▹ f = α₂ ▹ f) : α₁ = α₂ := Hf _ _ _ _ _ p. Definition isaprop_faithful_1cell {B : bicat} {a b : B} (f : a --> b) : isaprop (faithful_1cell f). Proof. repeat (use impred ; intro). apply cellset_property. Qed. (** 2. Characterization of faithful 1-cells *) Definition faithful_1cell_to_faithful {B : bicat} {a b : B} (f : a --> b) : faithful_1cell f → ∏ (z : B), faithful (post_comp z f). Proof. intros Hf z g₁ g₂ α ; cbn in *. use invproofirrelevance. intros φ₁ φ₂ ; cbn in *. use subtypePath. { intro ; apply cellset_property. } apply (faithful_1cell_eq_cell Hf). exact (pr2 φ₁ @ !(pr2 φ₂)). Qed. Definition faithful_to_faithful_1cell {B : bicat} {a b : B} (f : a --> b) : (∏ (z : B), faithful (post_comp z f)) → faithful_1cell f. Proof. intros Hf z g₁ g₂ α₁ α₂ p. pose (proofirrelevance _ (Hf z g₁ g₂ (α₂ ▹ f)) (α₁ ,, p) (α₂ ,, idpath _)) as q. exact (maponpaths pr1 q). Qed. Definition faithful_1cell_weq_faithful {B : bicat} {a b : B} (f : a --> b) : (faithful_1cell f) ≃ (∏ (z : B), faithful (post_comp z f)). Proof. use weqimplimpl. - exact (faithful_1cell_to_faithful f). - exact (faithful_to_faithful_1cell f). - exact (isaprop_faithful_1cell f). - use impred ; intro. apply isaprop_faithful. Defined. (** 3. Fully faithful 1-cells *) Definition fully_faithful_1cell {B : bicat} {a b : B} (f : a --> b) : UU := (∏ (z : B) (g₁ g₂ : z --> a) (α₁ α₂ : g₁ ==> g₂), α₁ ▹ f = α₂ ▹ f → α₁ = α₂) × (∏ (z : B) (g₁ g₂ : z --> a) (αf : g₁ · f ==> g₂ · f), ∑ (α : g₁ ==> g₂), α ▹ f = αf). Definition fully_faithful_1cell_faithful {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) : faithful_1cell f := pr1 Hf. Definition fully_faithful_1cell_eq {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) {z : B} {g₁ g₂ : z --> a} {α₁ α₂ : g₁ ==> g₂} (p : α₁ ▹ f = α₂ ▹ f) : α₁ = α₂ := pr1 Hf _ _ _ _ _ p. Definition fully_faithful_1cell_inv_map {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) {z : B} {g₁ g₂ : z --> a} (αf : g₁ · f ==> g₂ · f) : g₁ ==> g₂ := pr1 (pr2 Hf _ _ _ αf). Definition fully_faithful_1cell_inv_map_eq {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) {z : B} {g₁ g₂ : z --> a} (αf : g₁ · f ==> g₂ · f) : fully_faithful_1cell_inv_map Hf αf ▹ f = αf := pr2 (pr2 Hf _ _ _ αf). Definition make_fully_faithful {B : bicat} {a b : B} {f : a --> b} (Hf₁ : faithful_1cell f) (Hf₂ : ∏ (z : B) (g₁ g₂ : z --> a) (αf : g₁ · f ==> g₂ · f), ∑ (α : g₁ ==> g₂), α ▹ f = αf) : fully_faithful_1cell f := (Hf₁ ,, Hf₂). Definition isaprop_fully_faithful_1cell {B : bicat} {a b : B} (f : a --> b) : isaprop (fully_faithful_1cell f). Proof. use invproofirrelevance. intros φ₁ φ₂. use pathsdirprod. - apply isaprop_faithful_1cell. - use funextsec ; intro z. use funextsec ; intro g₁. use funextsec ; intro g₂. use funextsec ; intro αf. use subtypePath. { intro ; apply cellset_property. } pose (ψ₁ := pr2 φ₁ z g₁ g₂ αf). pose (ψ₂ := pr2 φ₂ z g₁ g₂ αf). enough (pr1 ψ₁ = pr1 ψ₂) as X. { exact X. } use (fully_faithful_1cell_eq φ₁). exact (pr2 ψ₁ @ !(pr2 ψ₂)). Qed. (** 4. Characterizations of fully faithful 1-cells *) Definition fully_faithful_1cell_to_fully_faithful {B : bicat} {a b : B} (f : a --> b) : fully_faithful_1cell f → ∏ (z : B), fully_faithful (post_comp z f). Proof. intros Hf z g₁ g₂ α ; cbn in *. use iscontraprop1. - use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply cellset_property | ]. cbn in *. apply (pr1 Hf). exact (pr2 φ₁ @ !(pr2 φ₂)). - exact (pr2 Hf z _ _ α). Qed. Definition fully_faithful_to_fully_faithful_1cell {B : bicat} {a b : B} (f : a --> b) : (∏ (z : B), fully_faithful (post_comp z f)) → fully_faithful_1cell f. Proof. intros Hf. use make_fully_faithful. - use faithful_to_faithful_1cell. intro z. apply fully_faithful_implies_full_and_faithful. apply Hf. - intros z g₁ g₂ αf. simple refine (_ ,, _). + exact (invmap (make_weq _ (Hf z g₁ g₂)) αf). + apply (homotweqinvweq (make_weq _ (Hf z g₁ g₂))). Qed. Definition fully_faithful_1cell_weq_fully_faithful {B : bicat} {a b : B} (f : a --> b) : (fully_faithful_1cell f) ≃ (∏ (z : B), fully_faithful (post_comp z f)). Proof. use weqimplimpl. - exact (fully_faithful_1cell_to_fully_faithful f). - exact (fully_faithful_to_fully_faithful_1cell f). - exact (isaprop_fully_faithful_1cell f). - use impred ; intro. apply isaprop_fully_faithful. Defined. (** 5. Pseudomonic 1-cells *) Definition pseudomonic_1cell {B : bicat} {a b : B} (f : a --> b) : UU := (∏ (z : B) (g₁ g₂ : z --> a) (α₁ α₂ : g₁ ==> g₂), α₁ ▹ f = α₂ ▹ f → α₁ = α₂) × (∏ (z : B) (g₁ g₂ : z --> a) (αf : g₁ · f ==> g₂ · f) (Hαf : is_invertible_2cell αf), ∑ (α : g₁ ==> g₂), is_invertible_2cell α × α ▹ f = αf). Definition pseudomonic_1cell_faithful {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) : faithful_1cell f := pr1 Hf. Definition pseudomonic_1cell_eq {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) {z : B} {g₁ g₂ : z --> a} {α₁ α₂ : g₁ ==> g₂} (p : α₁ ▹ f = α₂ ▹ f) : α₁ = α₂ := pr1 Hf _ _ _ _ _ p. Definition pseudomonic_1cell_inv_map {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) {z : B} {g₁ g₂ : z --> a} (αf : g₁ · f ==> g₂ · f) (Hαf : is_invertible_2cell αf) : g₁ ==> g₂ := pr1 (pr2 Hf _ _ _ αf Hαf). Definition is_invertible_2cell_pseudomonic_1cell_inv_map {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) {z : B} {g₁ g₂ : z --> a} (αf : g₁ · f ==> g₂ · f) (Hαf : is_invertible_2cell αf) : is_invertible_2cell (pseudomonic_1cell_inv_map Hf αf Hαf) := pr12 (pr2 Hf _ _ _ αf Hαf). Definition pseudomonic_1cell_inv_map_eq {B : bicat} {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) {z : B} {g₁ g₂ : z --> a} (αf : g₁ · f ==> g₂ · f) (Hαf : is_invertible_2cell αf) : pseudomonic_1cell_inv_map Hf αf Hαf ▹ f = αf := pr22 (pr2 Hf _ _ _ αf Hαf). Definition make_pseudomonic {B : bicat} {a b : B} {f : a --> b} (Hf₁ : faithful_1cell f) (Hf₂ : ∏ (z : B) (g₁ g₂ : z --> a) (αf : g₁ · f ==> g₂ · f) (Hαf : is_invertible_2cell αf), ∑ (α : g₁ ==> g₂), is_invertible_2cell α × α ▹ f = αf) : pseudomonic_1cell f := (Hf₁ ,, Hf₂). Definition isaprop_pseudomonic_1cell {B : bicat} {a b : B} (f : a --> b) : isaprop (pseudomonic_1cell f). Proof. use invproofirrelevance. intros φ₁ φ₂. use pathsdirprod. - apply isaprop_faithful_1cell. - use funextsec ; intro z. use funextsec ; intro g₁. use funextsec ; intro g₂. use funextsec ; intro αf. use funextsec ; intro Hαf. use subtypePath. { intro. apply isapropdirprod. + apply isaprop_is_invertible_2cell. + apply cellset_property. } pose (ψ₁ := pr2 φ₁ z g₁ g₂ αf Hαf). pose (ψ₂ := pr2 φ₂ z g₁ g₂ αf Hαf). enough (pr1 ψ₁ = pr1 ψ₂) as X. { exact X. } use (pseudomonic_1cell_eq φ₁). exact (pr22 ψ₁ @ !(pr22 ψ₂)). Qed. (** 6. Characterization of pseudomonic 1-cells *) Definition pseudomonic_1cell_to_pseudomonic {B : bicat} {a b : B} (f : a --> b) : pseudomonic_1cell f → ∏ (z : B), pseudomonic (post_comp z f). Proof. intros Hf z. split. - apply faithful_1cell_to_faithful. exact (pr1 Hf). - intros g₁ g₂ α. apply hinhpr. simple refine (_ ,, _) ; cbn. + apply inv2cell_to_z_iso. use make_invertible_2cell. * use (pseudomonic_1cell_inv_map Hf (z_iso_to_inv2cell α)). apply property_from_invertible_2cell. * apply is_invertible_2cell_pseudomonic_1cell_inv_map. + use subtypePath ; [ intro ; apply (isaprop_is_z_isomorphism(C:=hom z b)) | ]. cbn. apply pseudomonic_1cell_inv_map_eq. Qed. Definition pseudomonic_to_pseudomonic_1cell {B : bicat} {a b : B} (f : a --> b) : (∏ (z : B), pseudomonic (post_comp z f)) → pseudomonic_1cell f. Proof. intro H. use make_pseudomonic. - apply faithful_to_faithful_1cell. intro z. apply H. - intros z g₁ g₂ αf Hαf. pose (w := make_weq _ (isweq_functor_on_iso_pseudomonic (H z) g₁ g₂)). simple refine (_ ,, _ ,, _). + apply (invweq w). use inv2cell_to_z_iso. exact (αf ,, Hαf). + cbn. apply is_z_iso_to_is_inv2cell. apply (pr2 (invmap w (inv2cell_to_z_iso (αf,, Hαf)))). + exact (maponpaths pr1 (homotweqinvweq w (inv2cell_to_z_iso (αf,, Hαf)))). Qed. Definition pseudomonic_1cell_weq_pseudomonic {B : bicat} {a b : B} (f : a --> b) : (pseudomonic_1cell f) ≃ (∏ (z : B), pseudomonic (post_comp z f)). Proof. use weqimplimpl. - exact (pseudomonic_1cell_to_pseudomonic f). - exact (pseudomonic_to_pseudomonic_1cell f). - exact (isaprop_pseudomonic_1cell f). - use impred ; intro. apply isaprop_pseudomonic. Defined. (** 7. Pseudomonic 1-cells in locally groupoidal bicategories *) Definition fully_faithful_is_pseudomonic {B : bicat} {a b : B} {f : a --> b} (Hf : fully_faithful_1cell f) : pseudomonic_1cell f. Proof. use make_pseudomonic. - exact (fully_faithful_1cell_faithful Hf). - intros z g₁ g₂ αf ?. refine (fully_faithful_1cell_inv_map Hf αf ,, _ ,, _). + use make_is_invertible_2cell. * exact (fully_faithful_1cell_inv_map Hf (Hαf^-1)). * abstract (use (fully_faithful_1cell_faithful Hf) ; rewrite <- rwhisker_vcomp ; rewrite !fully_faithful_1cell_inv_map_eq ; rewrite id2_rwhisker ; apply vcomp_rinv). * abstract (use (fully_faithful_1cell_faithful Hf) ; rewrite <- rwhisker_vcomp ; rewrite !fully_faithful_1cell_inv_map_eq ; rewrite id2_rwhisker ; apply vcomp_linv). + exact (fully_faithful_1cell_inv_map_eq Hf αf). Defined. Definition pseudomonic_is_fully_faithful_locally_grpd {B : bicat} (inv_B : locally_groupoid B) {a b : B} {f : a --> b} (Hf : pseudomonic_1cell f) : fully_faithful_1cell f. Proof. use make_fully_faithful. - exact (pr1 Hf). - intros z g₁ g₂ αf. simple refine (_ ,, _). + use (pseudomonic_1cell_inv_map Hf αf). apply inv_B. + apply (pseudomonic_1cell_inv_map_eq Hf). Defined. Definition pseudomonic_weq_fully_faithful_locally_grpd {B : bicat} (inv_B : locally_groupoid B) {a b : B} (f : a --> b) : pseudomonic_1cell f ≃ fully_faithful_1cell f. Proof. use weqimplimpl. - exact (pseudomonic_is_fully_faithful_locally_grpd inv_B). - exact fully_faithful_is_pseudomonic. - apply isaprop_pseudomonic_1cell. - apply isaprop_fully_faithful_1cell. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/InternalStreetFibration.v000066400000000000000000001057101451125700300262310ustar00rootroot00000000000000(******************************************************** Internal Street fibrations In this file, we define the notion of Street fibration internal to a bicategory. 1. Definition of an internal Street fibration 2. Lemmas on cartesians 3. Street fibrations in locally groupoidal bicategories 4. Morphisms of internal Street fibrations 5. Cells of internal Street fibrations ********************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Local Open Scope cat. (** 1. Definition of an internal Street fibration We define internal Street fibrations using an unfolded definition. We also show that it is equivalent to the usual definition of internal Street fibrations, which is formulated using hom-categories. *) Section InternalStreetFibration. Context {B : bicat} {e b : B} (p : e --> b). Definition is_cartesian_2cell_sfib {x : B} {f g : x --> e} (γ : f ==> g) : UU := ∏ (h : x --> e) (α : h ==> g) (δp : h · p ==> f · p) (q : α ▹ p = δp • (γ ▹ p)), ∃! (δ : h ==> f), δ ▹ p = δp × δ • γ = α. Definition is_cartesian_2cell_sfib_factor {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_cartesian_2cell_sfib γ) {h : x --> e} (α : h ==> g) (δp : h · p ==> f · p) (q : α ▹ p = δp • (γ ▹ p)) : h ==> f := pr11 (Hγ h α δp q). Definition is_cartesian_2cell_sfib_factor_over {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_cartesian_2cell_sfib γ) {h : x --> e} {α : h ==> g} {δp : h · p ==> f · p} (q : α ▹ p = δp • (γ ▹ p)) : (is_cartesian_2cell_sfib_factor Hγ _ _ q) ▹ p = δp := pr121 (Hγ h α δp q). Definition is_cartesian_2cell_sfib_factor_comm {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_cartesian_2cell_sfib γ) {h : x --> e} {α : h ==> g} {δp : h · p ==> f · p} (q : α ▹ p = δp • (γ ▹ p)) : is_cartesian_2cell_sfib_factor Hγ _ _ q • γ = α := pr221 (Hγ h α δp q). Definition is_cartesian_2cell_sfib_factor_unique {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_cartesian_2cell_sfib γ) (h : x --> e) (α : h ==> g) (δp : h · p ==> f · p) (q : α ▹ p = δp • (γ ▹ p)) (δ₁ δ₂ : h ==> f) (pδ₁ : δ₁ ▹ p = δp) (pδ₂ : δ₂ ▹ p = δp) (δγ₁ : δ₁ • γ = α) (δγ₂ : δ₂ • γ = α) : δ₁ = δ₂. Proof. pose (proofirrelevance _ (isapropifcontr (Hγ h α δp q)) (δ₁ ,, pδ₁ ,, δγ₁) (δ₂ ,, pδ₂ ,, δγ₂)) as H. exact (maponpaths pr1 H). Qed. Definition isaprop_is_cartesian_2cell_sfib {x : B} {f : x --> e} {g : x --> e} (γ : f ==> g) : isaprop (is_cartesian_2cell_sfib γ). Proof. do 4 (use impred ; intro). apply isapropiscontr. Qed. Definition internal_sfib_cleaving : UU := ∏ (x : B) (f : x --> b) (g : x --> e) (α : f ==> g · p), ∑ (h : x --> e) (γ : h ==> g) (β : invertible_2cell (h · p) f), is_cartesian_2cell_sfib γ × γ ▹ p = β • α. Definition internal_sfib_cleaving_lift_mor (H : internal_sfib_cleaving) {x : B} {f : x --> b} {g : x --> e} (α : f ==> g · p) : x --> e := pr1 (H _ _ _ α). Definition internal_sfib_cleaving_lift_cell (H : internal_sfib_cleaving) {x : B} {f : x --> b} {g : x --> e} (α : f ==> g · p) : internal_sfib_cleaving_lift_mor H α ==> g := pr12 (H _ _ _ α). Definition internal_sfib_cleaving_com (H : internal_sfib_cleaving) {x : B} {f : x --> b} {g : x --> e} (α : f ==> g · p) : invertible_2cell (internal_sfib_cleaving_lift_mor H α · p) f := pr122 (H _ _ _ α). Definition internal_sfib_cleaving_is_cartesian (H : internal_sfib_cleaving) {x : B} {f : x --> b} {g : x --> e} (α : f ==> g · p) : is_cartesian_2cell_sfib (internal_sfib_cleaving_lift_cell H α) := pr1 (pr222 (H _ _ _ α)). Definition internal_sfib_cleaving_over (H : internal_sfib_cleaving) {x : B} {f : x --> b} {g : x --> e} (α : f ==> g · p) : internal_sfib_cleaving_lift_cell H α ▹ p = internal_sfib_cleaving_com H α • α := pr2 (pr222 (H _ _ _ α)). Definition lwhisker_is_cartesian : UU := ∏ (x y : B) (h : y --> x) (f g : x --> e) (γ : f ==> g) (Hγ : is_cartesian_2cell_sfib γ), is_cartesian_2cell_sfib (h ◃ γ). Definition internal_sfib : UU := internal_sfib_cleaving × lwhisker_is_cartesian. Coercion internal_sfib_to_cleaving (H : internal_sfib) : internal_sfib_cleaving := pr1 H. Definition rep_internal_sfib : UU := (∏ (x : B), street_fib (post_comp x p)) × (∏ (x y : B) (h : y --> x), preserves_cartesian (post_comp x p) (post_comp y p) (pre_comp e h)). Definition rep_internal_sfib_to_internal_sfib (H : rep_internal_sfib) : internal_sfib. Proof. split. - intros x f g α. pose (lift := pr1 H x g f α). exact (pr1 lift ,, pr112 lift ,, z_iso_to_inv2cell (pr212 lift) ,, pr222 lift ,, pr122 lift). - exact (pr2 H). Defined. Definition internal_sfib_to_rep_internal_sfib (H : internal_sfib) : rep_internal_sfib. Proof. split. - intros x f g α. pose (lift := pr1 H x g f α). exact (pr1 lift ,, (pr12 lift ,, inv2cell_to_z_iso (pr122 lift)) ,, pr2 (pr222 lift) ,, pr1 (pr222 lift)). - exact (pr2 H). Defined. Definition internal_sfib_to_rep_to_sfib (H : rep_internal_sfib) : internal_sfib_to_rep_internal_sfib (rep_internal_sfib_to_internal_sfib H) = H. Proof. use pathsdirprod ; [ | apply idpath ]. use funextsec ; intro x. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro α. simpl. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro. use isapropdirprod. - apply cellset_property. - apply isaprop_is_cartesian_2cell_sfib. } simpl. refine (maponpaths (λ z, _ ,, z) _). use subtypePath. { intro. apply (isaprop_is_z_isomorphism(C:=hom x b)). } cbn. apply idpath. Qed. Definition rep_sfib_to_internal_to_rep (H : internal_sfib) : rep_internal_sfib_to_internal_sfib (internal_sfib_to_rep_internal_sfib H) = H. Proof. use pathsdirprod ; [ | apply idpath ]. use funextsec ; intro x. use funextsec ; intro f. use funextsec ; intro g. use funextsec ; intro α. simpl. refine (maponpaths (λ z, _ ,, _ ,, z) _). use subtypePath. { intro. apply isapropdirprod. - apply isaprop_is_cartesian_2cell_sfib. - apply cellset_property. } use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. apply idpath. Qed. Definition rep_internal_sfib_weq_internal_sfib : rep_internal_sfib ≃ internal_sfib. Proof. use make_weq. - exact rep_internal_sfib_to_internal_sfib. - use isweq_iso. + exact internal_sfib_to_rep_internal_sfib. + exact internal_sfib_to_rep_to_sfib. + exact rep_sfib_to_internal_to_rep. Defined. Definition isaprop_rep_internal_sfib (HB_2_1 : is_univalent_2_1 B) : isaprop rep_internal_sfib. Proof. use isapropdirprod. - use impred ; intro. apply isaprop_street_fib. apply is_univ_hom. exact HB_2_1. - do 7 (use impred ; intro). apply isaprop_is_cartesian_sfib. Qed. Definition isaprop_internal_sfib (HB_2_1 : is_univalent_2_1 B) : isaprop internal_sfib. Proof. use (isofhlevelweqf _ rep_internal_sfib_weq_internal_sfib). exact (isaprop_rep_internal_sfib HB_2_1). Qed. End InternalStreetFibration. (** 2. Lemmas on cartesians *) Definition id_is_cartesian_2cell_sfib {B : bicat} {e b : B} (p : e --> b) {x : B} (f : x --> e) : is_cartesian_2cell_sfib p (id2 f). Proof. intros g α δp q. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (!(id2_right _) @ pr22 φ₁ @ !(pr22 φ₂) @ id2_right _)). - refine (α ,, _ ,, _). + abstract (rewrite q ; rewrite id2_rwhisker ; apply id2_right). + abstract (apply id2_right). Defined. Section VcompIsCartesian. Context {B : bicat} {e b : B} (p : e --> b) {x : B} {f g h : x --> e} {α : f ==> g} {β : g ==> h} (Hα : is_cartesian_2cell_sfib p α) (Hβ : is_cartesian_2cell_sfib p β). Definition vcomp_is_cartesian_2cell_sfib_unique {k : x --> e} {ζ : k ==> h} {δp : k · p ==> f · p} (q : ζ ▹ p = δp • ((α • β) ▹ p)) : isaprop (∑ δ : k ==> f, δ ▹ p = δp × δ • (α • β) = ζ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. rewrite <- rwhisker_vcomp in q. rewrite !vassocr in q. use (is_cartesian_2cell_sfib_factor_unique _ Hα _ (is_cartesian_2cell_sfib_factor _ Hβ ζ (δp • (α ▹ _)) q) δp (is_cartesian_2cell_sfib_factor_over _ _ _) _ _ (pr12 φ₁) (pr12 φ₂)) ; use (is_cartesian_2cell_sfib_factor_unique _ Hβ _ ζ (δp • (α ▹ _)) q _ _ _ (is_cartesian_2cell_sfib_factor_over _ _ _) _ (is_cartesian_2cell_sfib_factor_comm _ _ _)). - rewrite <- rwhisker_vcomp. rewrite (pr12 φ₁). apply idpath. - rewrite !vassocl. apply (pr22 φ₁). - rewrite <- rwhisker_vcomp. rewrite (pr12 φ₂). apply idpath. - rewrite !vassocl. apply (pr22 φ₂). Qed. Definition vcomp_is_cartesian_2cell_sfib : is_cartesian_2cell_sfib p (α • β). Proof. intros k ζ δp q. use iscontraprop1. - apply vcomp_is_cartesian_2cell_sfib_unique. exact q. - simple refine (_ ,, _ ,, _). + simple refine (is_cartesian_2cell_sfib_factor _ Hα _ δp _). * simple refine (is_cartesian_2cell_sfib_factor _ Hβ ζ (δp • (α ▹ p)) _). abstract (rewrite !vassocl ; rewrite q ; rewrite <- rwhisker_vcomp ; apply idpath). * apply is_cartesian_2cell_sfib_factor_over. + apply is_cartesian_2cell_sfib_factor_over. + abstract (simpl ; rewrite !vassocr ; rewrite !is_cartesian_2cell_sfib_factor_comm ; apply idpath). Defined. End VcompIsCartesian. Definition invertible_is_cartesian_2cell_sfib {B : bicat} {e b : B} (p : e --> b) {x : B} {f g : x --> e} (α : f ==> g) (Hα : is_invertible_2cell α) : is_cartesian_2cell_sfib p α. Proof. intros h ζ δp q. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; refine (!(id2_right _) @ _ @ id2_right _) ; rewrite <- (vcomp_rinv Hα) ; rewrite !vassocr ; rewrite (pr22 φ₁), (pr22 φ₂) ; apply idpath). - refine (ζ • Hα^-1 ,, _ ,, _). + abstract (rewrite <- rwhisker_vcomp ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; exact q). + abstract (rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). Defined. Section PostComposition. Context {B : bicat} {e b : B} (p : e --> b) {x : B} {f g h : x --> e} (α : f ==> g) {β : g ==> h} {γ : f ==> h} (Hβ : is_cartesian_2cell_sfib p β) (Hγ : is_cartesian_2cell_sfib p γ) (q : α • β = γ). Section PostCompositionFactor. Context {k : x --> e} {δ : k ==> g} (δp : k · p ==> f · p) (r : δ ▹ p = δp • (α ▹ p)). Definition is_cartesian_2cell_sfib_postcomp_factor : k ==> f. Proof. use (is_cartesian_2cell_sfib_factor _ Hγ (δ • β) δp). abstract (rewrite <- rwhisker_vcomp ; rewrite r ; rewrite !vassocl ; rewrite rwhisker_vcomp ; rewrite q ; apply idpath). Defined. Definition is_cartesian_2cell_sfib_postcomp_comm : is_cartesian_2cell_sfib_postcomp_factor • α = δ. Proof. use (is_cartesian_2cell_sfib_factor_unique _ Hβ k (δ • β) (δ ▹ p)). - rewrite rwhisker_vcomp. apply idpath. - rewrite <- rwhisker_vcomp. etrans. { apply maponpaths_2. apply is_cartesian_2cell_sfib_factor_over. } rewrite r. apply idpath. - apply idpath. - rewrite !vassocl. etrans. { apply maponpaths. exact q. } apply is_cartesian_2cell_sfib_factor_comm. - apply idpath. Qed. Definition is_cartesian_2cell_sfib_postcomp_unique : isaprop (∑ φ, φ ▹ p = δp × φ • α = δ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use (is_cartesian_2cell_sfib_factor_unique _ Hγ _ (δ • β) δp). - rewrite <- rwhisker_vcomp. rewrite r. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite q. apply idpath. - exact (pr12 φ₁). - exact (pr12 φ₂). - rewrite <- q. rewrite !vassocr. apply maponpaths_2. exact (pr22 φ₁). - rewrite <- q. rewrite !vassocr. apply maponpaths_2. exact (pr22 φ₂). Qed. End PostCompositionFactor. Definition is_cartesian_2cell_sfib_postcomp : is_cartesian_2cell_sfib p α. Proof. intros k δ δp r. use iscontraprop1. - exact (is_cartesian_2cell_sfib_postcomp_unique δp r). - simple refine (_ ,, _ ,, _). + exact (is_cartesian_2cell_sfib_postcomp_factor δp r). + apply is_cartesian_2cell_sfib_factor_over. + exact (is_cartesian_2cell_sfib_postcomp_comm δp r). Defined. End PostComposition. Definition is_cartesian_eq {B : bicat} {e b : B} {p : e --> b} {x : B} {f g : x --> e} (α : f ==> g) {β : f ==> g} (q : α = β) (Hα : is_cartesian_2cell_sfib p α) : is_cartesian_2cell_sfib p β. Proof. intros h ζ δp r. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; induction q ; exact (is_cartesian_2cell_sfib_factor_unique _ Hα h ζ δp r _ _ (pr12 φ₁) (pr12 φ₂) (pr22 φ₁) (pr22 φ₂))). - simple refine (_ ,, _). + refine (is_cartesian_2cell_sfib_factor _ Hα ζ δp _). abstract (rewrite q, r ; apply idpath). + split. * apply is_cartesian_2cell_sfib_factor_over. * abstract (refine (maponpaths (λ z, _ • z) (!q) @ _) ; apply is_cartesian_2cell_sfib_factor_comm). Defined. Definition is_cartesian_from_factor {B : bicat} {e b : B} {p : e --> b} {x : B} {f₁ f₂ g : x --> e} (α : f₁ ==> f₂) (Hα : is_invertible_2cell α) (β : f₁ ==> g) (γ : f₂ ==> g) (Hγ : is_cartesian_2cell_sfib p γ) (q : β = α • γ) : is_cartesian_2cell_sfib p β. Proof. use (is_cartesian_eq _ (!q)). use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. exact Hα. - exact Hγ. Defined. Definition map_between_cartesians {B : bicat} {x e b : B} {p : e --> b} {g₀ g₁ g₂ : x --> e} {α : g₀ ==> g₂} (Hα : is_cartesian_2cell_sfib p α) {β : g₁ ==> g₂} (Hβ : is_cartesian_2cell_sfib p β) (δ : invertible_2cell (g₀ · p) (g₁ · p)) (r : α ▹ p = δ • (β ▹ p)) : g₀ ==> g₁ := is_cartesian_2cell_sfib_factor _ Hβ α δ r. Section InvertibleBetweenCartesians. Context {B : bicat} {x e b : B} {p : e --> b} {g₀ g₁ g₂ : x --> e} {α : g₀ ==> g₂} (Hα : is_cartesian_2cell_sfib p α) {β : g₁ ==> g₂} (Hβ : is_cartesian_2cell_sfib p β) (δ : invertible_2cell (g₀ · p) (g₁ · p)) (r : α ▹ p = δ • (β ▹ p)). Let φ : g₀ ==> g₁ := map_between_cartesians Hα Hβ δ r. Local Lemma invertible_between_cartesians_help : β ▹ p = δ^-1 • (α ▹ p). Proof. cbn. use vcomp_move_L_pM ; is_iso ; cbn. exact (!r). Qed. Let ψ : g₁ ==> g₀ := map_between_cartesians Hβ Hα (inv_of_invertible_2cell δ) invertible_between_cartesians_help. Local Lemma invertible_between_cartesians_inv₁ : φ • ψ = id₂ _. Proof. use (is_cartesian_2cell_sfib_factor_unique _ Hα _ α (id2 _)). - rewrite id2_left. apply idpath. - unfold φ, ψ, map_between_cartesians. rewrite <- rwhisker_vcomp. rewrite !is_cartesian_2cell_sfib_factor_over. apply (vcomp_rinv δ). - apply id2_rwhisker. - unfold φ, ψ, map_between_cartesians. rewrite !vassocl. rewrite !is_cartesian_2cell_sfib_factor_comm. apply idpath. - apply id2_left. Qed. Local Lemma invertible_between_cartesians_inv₂ : ψ • φ = id₂ _. Proof. use (is_cartesian_2cell_sfib_factor_unique _ Hβ _ β (id2 _)). - rewrite id2_left. apply idpath. - unfold φ, ψ, map_between_cartesians. rewrite <- rwhisker_vcomp. rewrite !is_cartesian_2cell_sfib_factor_over. apply (vcomp_linv δ). - apply id2_rwhisker. - unfold φ, ψ, map_between_cartesians. rewrite !vassocl. rewrite !is_cartesian_2cell_sfib_factor_comm. apply idpath. - apply id2_left. Qed. Definition invertible_between_cartesians : invertible_2cell g₀ g₁. Proof. use make_invertible_2cell. - exact φ. - use make_is_invertible_2cell. + exact ψ. + exact invertible_between_cartesians_inv₁. + exact invertible_between_cartesians_inv₂. Defined. End InvertibleBetweenCartesians. (** 3. Street fibrations in locally groupoidal bicategories *) Definition locally_grpd_cartesian {B : bicat} (HB : locally_groupoid B) {e b : B} (p : e --> b) {x : B} {f g : x --> e} (γ : f ==> g) : is_cartesian_2cell_sfib p γ. Proof. intros h α δp q. pose (α_iso := make_invertible_2cell (HB _ _ _ _ α)). pose (γ_iso := make_invertible_2cell (HB _ _ _ _ γ)). use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use (vcomp_rcancel _ γ_iso) ; cbn ; exact (pr22 φ₁ @ !(pr22 φ₂))). - refine (α • γ_iso^-1 ,, _ ,, _). + abstract (rewrite <- rwhisker_vcomp ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite q ; apply idpath). + abstract (rewrite !vassocl ; rewrite vcomp_linv ; apply id2_right). Defined. Definition locally_grpd_internal_sfib {B : bicat} (HB : locally_groupoid B) {e b : B} (p : e --> b) : internal_sfib p. Proof. split. - intros x f g α. refine (g ,, id2 _ ,, inv_of_invertible_2cell (make_invertible_2cell (HB _ _ _ _ α)) ,, locally_grpd_cartesian HB _ _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite vcomp_linv ; apply idpath). - intro ; intros. apply (locally_grpd_cartesian HB). Defined. (** 4. Morphisms of internal Street fibrations *) Definition mor_preserves_cartesian {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : UU := ∏ (x : B) (f g : x --> e₁) (γ : f ==> g) (Hγ : is_cartesian_2cell_sfib p₁ γ), is_cartesian_2cell_sfib p₂ (γ ▹ fe). Definition id_mor_preserves_cartesian {B : bicat} {e b : B} (p : e --> b) : mor_preserves_cartesian p p (id₁ e). Proof. intros ? ? ? ? H. assert (γ ▹ id₁ e = runitor _ • γ • rinvunitor _) as q. { use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite !vcomp_runitor. apply idpath. } rewrite q. use vcomp_is_cartesian_2cell_sfib. - use vcomp_is_cartesian_2cell_sfib. + use invertible_is_cartesian_2cell_sfib. is_iso. + exact H. - use invertible_is_cartesian_2cell_sfib. is_iso. Qed. Definition comp_preserves_cartesian {B : bicat} {e₁ b₁ e₂ b₂ e₃ b₃ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {p₃ : e₃ --> b₃} {fe₁ : e₁ --> e₂} {fe₂ : e₂ --> e₃} (H₁ : mor_preserves_cartesian p₁ p₂ fe₁) (H₂ : mor_preserves_cartesian p₂ p₃ fe₂) : mor_preserves_cartesian p₁ p₃ (fe₁ · fe₂). Proof. intros x f g γ Hγ. specialize (H₁ x _ _ γ Hγ). specialize (H₂ x _ _ _ H₁). assert (γ ▹ fe₁ · fe₂ = lassociator _ _ _ • ((γ ▹ fe₁) ▹ fe₂) • rassociator _ _ _) as q. { use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply idpath. } rewrite q. use vcomp_is_cartesian_2cell_sfib. - use vcomp_is_cartesian_2cell_sfib. + use invertible_is_cartesian_2cell_sfib. is_iso. + exact H₂. - use invertible_is_cartesian_2cell_sfib. is_iso. Qed. Section Invertible2CellCartesian. Context {B : bicat} {x e b : B} {p p' : e --> b} (α : invertible_2cell p p') {f g : x --> e} {β : f ==> g} (Hβ : is_cartesian_2cell_sfib p β) {k : x --> e} {ζ : k ==> g} (δp : k · p' ==> f · p') (q : ζ ▹ p' = δp • (β ▹ p')). Let δp' : k · p ==> f · p := ((k ◃ α) • δp • (f ◃ α^-1)). Lemma help_eq : ζ ▹ p = (((k ◃ α) • δp) • (f ◃ α ^-1)) • (β ▹ p). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. apply property_from_invertible_2cell. } cbn. rewrite <- vcomp_whisker. rewrite q. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. Qed. Definition is_cartesian_2cell_sfib_factor_inv2cell_unique : isaprop (∑ (δ : k ==> f), δ ▹ p' = δp × δ • β = ζ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use (is_cartesian_2cell_sfib_factor_unique _ Hβ k ζ ((k ◃ α) • δp • (f ◃ α^-1)) help_eq). - use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite vcomp_whisker. apply maponpaths. exact (pr12 φ₁). - use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite vcomp_whisker. apply maponpaths. exact (pr12 φ₂). - exact (pr22 φ₁). - exact (pr22 φ₂). Qed. Definition is_cartesian_2cell_sfib_factor_inv2cell : k ==> f := is_cartesian_2cell_sfib_factor _ Hβ ζ ((k ◃ α) • δp • (f ◃ α^-1)) help_eq. Definition is_cartesian_2cell_sfib_factor_inv2cell_over : is_cartesian_2cell_sfib_factor_inv2cell ▹ p' = δp. Proof. use (vcomp_lcancel (_ ◃ α)). { is_iso. apply property_from_invertible_2cell. } rewrite <- vcomp_whisker. unfold is_cartesian_2cell_sfib_factor_inv2cell. rewrite is_cartesian_2cell_sfib_factor_over. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_right. apply idpath. Qed. End Invertible2CellCartesian. Definition is_cartesian_2cell_sfib_inv2cell {B : bicat} {x e b : B} {p p' : e --> b} (α : invertible_2cell p p') {f g : x --> e} {β : f ==> g} (Hβ : is_cartesian_2cell_sfib p β) : is_cartesian_2cell_sfib p' β. Proof. intros k ζ δp q. use iscontraprop1. - exact (is_cartesian_2cell_sfib_factor_inv2cell_unique α Hβ δp q). - simple refine (_ ,, _ ,, _). + exact (is_cartesian_2cell_sfib_factor_inv2cell α Hβ δp q). + exact (is_cartesian_2cell_sfib_factor_inv2cell_over α Hβ δp q). + apply is_cartesian_2cell_sfib_factor_comm. Defined. Definition invertible_2cell_mor_between_preserves_cartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe fe' : e₁ --> e₂} (α : invertible_2cell fe fe') (H : mor_preserves_cartesian p₁ p₂ fe) : mor_preserves_cartesian p₁ p₂ fe'. Proof. intros x f g γ Hγ. assert (γ ▹ fe' • (_ ◃ α^-1) = (f ◃ α^-1) • (γ ▹ fe)) as p. { rewrite vcomp_whisker. apply idpath. } use (is_cartesian_2cell_sfib_postcomp _ _ _ _ p). - use invertible_is_cartesian_2cell_sfib. is_iso. - use vcomp_is_cartesian_2cell_sfib. + use invertible_is_cartesian_2cell_sfib. is_iso. + exact (H x f g γ Hγ). Defined. Definition invertible_2cell_between_preserves_cartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ p₁' : e₁ --> b₁} {p₂ p₂' : e₂ --> b₂} {fe fe' : e₁ --> e₂} (α : invertible_2cell p₁ p₁') (β : invertible_2cell p₂ p₂') (γ : invertible_2cell fe fe') (H : mor_preserves_cartesian p₁ p₂ fe) : mor_preserves_cartesian p₁' p₂' fe'. Proof. intros w h₁ h₂ ζ Hζ. use (is_cartesian_2cell_sfib_inv2cell β). use (invertible_2cell_mor_between_preserves_cartesian γ H). use (is_cartesian_2cell_sfib_inv2cell (inv_of_invertible_2cell α)). exact Hζ. Defined. Definition locally_grpd_preserves_cartesian {B : bicat} (HB : locally_groupoid B) {e₁ b₁ e₂ b₂ : B} (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : mor_preserves_cartesian p₁ p₂ fe. Proof. intro ; intros. apply (locally_grpd_cartesian HB). Defined. Definition isaprop_mor_preserves_cartesian {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : isaprop (mor_preserves_cartesian p₁ p₂ fe). Proof. do 5 (use impred ; intro). exact (isaprop_is_cartesian_2cell_sfib _ _). Qed. Definition mor_of_internal_sfib_over {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fb : b₁ --> b₂) : UU := ∑ (fe : e₁ --> e₂), mor_preserves_cartesian p₁ p₂ fe × invertible_2cell (p₁ · fb) (fe · p₂). Definition make_mor_of_internal_sfib_over {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : e₁ --> e₂) (fc : mor_preserves_cartesian p₁ p₂ fe) (f_com : invertible_2cell (p₁ · fb) (fe · p₂)) : mor_of_internal_sfib_over p₁ p₂ fb := (fe ,, fc ,, f_com). Coercion mor_of_internal_sfib_over_to_mor {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sfib_over p₁ p₂ fb) : e₁ --> e₂ := pr1 fe. Definition mor_of_internal_sfib_over_preserves {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sfib_over p₁ p₂ fb) : mor_preserves_cartesian p₁ p₂ fe := pr12 fe. Definition mor_of_internal_sfib_over_com {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sfib_over p₁ p₂ fb) : invertible_2cell (p₁ · fb) (fe · p₂) := pr22 fe. Definition id_mor_of_internal_sfib_over {B : bicat} {e b : B} (p : e --> b) : mor_of_internal_sfib_over p p (id₁ _). Proof. use make_mor_of_internal_sfib_over. - exact (id₁ e). - apply id_mor_preserves_cartesian. - use make_invertible_2cell. + refine (runitor _ • linvunitor _). + is_iso. Defined. Definition comp_mor_of_internal_sfib_over {B : bicat} {e₁ e₂ e₃ b₁ b₂ b₃ : B} {fb₁ : b₁ --> b₂} {fb₂ : b₂ --> b₃} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {p₃ : e₃ --> b₃} (fe₁ : mor_of_internal_sfib_over p₁ p₂ fb₁) (fe₂ : mor_of_internal_sfib_over p₂ p₃ fb₂) : mor_of_internal_sfib_over p₁ p₃ (fb₁ · fb₂). Proof. use make_mor_of_internal_sfib_over. - exact (fe₁ · fe₂). - exact (comp_preserves_cartesian (mor_of_internal_sfib_over_preserves fe₁) (mor_of_internal_sfib_over_preserves fe₂)). - use make_invertible_2cell. + exact (lassociator _ _ _ • (mor_of_internal_sfib_over_com fe₁ ▹ _) • rassociator _ _ _ • (_ ◃ mor_of_internal_sfib_over_com fe₂) • lassociator _ _ _). + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. Defined. (** 5. Cells of internal Street fibrations *) Definition cell_of_internal_sfib_over_homot {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} (γ : fb ==> gb) {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sfib_over p₁ p₂ fb} {ge : mor_of_internal_sfib_over p₁ p₂ gb} (γe : fe ==> ge) : UU := mor_of_internal_sfib_over_com fe • (γe ▹ _) = (_ ◃ γ) • mor_of_internal_sfib_over_com ge. Definition cell_of_internal_sfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} (γ : fb ==> gb) {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} (fe : mor_of_internal_sfib_over p₁ p₂ fb) (ge : mor_of_internal_sfib_over p₁ p₂ gb) : UU := ∑ (γe : fe ==> ge), cell_of_internal_sfib_over_homot γ γe. Definition make_cell_of_internal_sfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sfib_over p₁ p₂ fb} {ge : mor_of_internal_sfib_over p₁ p₂ gb} (γe : fe ==> ge) (p : cell_of_internal_sfib_over_homot γ γe) : cell_of_internal_sfib_over γ fe ge := (γe ,, p). Coercion cell_of_cell_of_internal_sfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sfib_over p₁ p₂ fb} {ge : mor_of_internal_sfib_over p₁ p₂ gb} (γe : cell_of_internal_sfib_over γ fe ge) : fe ==> ge := pr1 γe. Definition cell_of_internal_sfib_over_eq {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sfib_over p₁ p₂ fb} {ge : mor_of_internal_sfib_over p₁ p₂ gb} (γe : cell_of_internal_sfib_over γ fe ge) : mor_of_internal_sfib_over_com fe • (γe ▹ _) = (_ ◃ γ) • mor_of_internal_sfib_over_com ge := pr2 γe. Definition eq_cell_of_internal_sfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sfib_over p₁ p₂ fb} {ge : mor_of_internal_sfib_over p₁ p₂ gb} (γe₁ γe₂ : cell_of_internal_sfib_over γ fe ge) (p : pr1 γe₁ = γe₂) : γe₁ = γe₂. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. UniMath-20231010/UniMath/Bicategories/Morphisms/InternalStreetOpFibration.v000066400000000000000000000700651451125700300265340ustar00rootroot00000000000000(******************************************************** Internal Street opfibrations In this file, we define the notion of Street opfibration internal to a bicategory. 1. Definition of an internal Street opfibration 2. Street opfibrations in [B] are the same as Street fibrations in [op2_bicat B] 3. Properties of opcartesian cells 4. Morphisms of internal Street opfibrations 5. Cells of internal Street opfibrations 6. Equivalences preserve cartesian cells 7. Pullbacks of Street opfibrations ********************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.UnivalenceOp. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Local Open Scope cat. (** 1. Definition of an internal Street opfibration *) Section InternalStreetOpFibration. Context {B : bicat} {e b : B} (p : e --> b). Definition is_opcartesian_2cell_sopfib {x : B} {f g : x --> e} (γ : f ==> g) : UU := ∏ (h : x --> e) (α : f ==> h) (δp : g · p ==> h · p) (q : α ▹ p = (γ ▹ p) • δp), ∃! (δ : g ==> h), δ ▹ p = δp × γ • δ = α. Definition is_opcartesian_2cell_sopfib_factor {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_opcartesian_2cell_sopfib γ) {h : x --> e} (α : f ==> h) (δp : g · p ==> h · p) (q : α ▹ p = (γ ▹ p) • δp) : g ==> h := pr11 (Hγ h α δp q). Definition is_opcartesian_2cell_sopfib_factor_over {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_opcartesian_2cell_sopfib γ) {h : x --> e} (α : f ==> h) (δp : g · p ==> h · p) (q : α ▹ p = (γ ▹ p) • δp) : (is_opcartesian_2cell_sopfib_factor Hγ _ _ q) ▹ p = δp := pr121 (Hγ h α δp q). Definition is_opcartesian_2cell_sopfib_factor_comm {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_opcartesian_2cell_sopfib γ) {h : x --> e} (α : f ==> h) (δp : g · p ==> h · p) (q : α ▹ p = (γ ▹ p) • δp) : γ • is_opcartesian_2cell_sopfib_factor Hγ _ _ q = α := pr221 (Hγ h α δp q). Definition is_opcartesian_2cell_sopfib_factor_unique {x : B} {f g : x --> e} {γ : f ==> g} (Hγ : is_opcartesian_2cell_sopfib γ) (h : x --> e) (α : f ==> h) (δp : g · p ==> h · p) (q : α ▹ p = (γ ▹ p) • δp) (δ₁ δ₂ : g ==> h) (pδ₁ : δ₁ ▹ p = δp) (pδ₂ : δ₂ ▹ p = δp) (δγ₁ : γ • δ₁ = α) (δγ₂ : γ • δ₂ = α) : δ₁ = δ₂. Proof. pose (proofirrelevance _ (isapropifcontr (Hγ h α δp q)) (δ₁ ,, pδ₁ ,, δγ₁) (δ₂ ,, pδ₂ ,, δγ₂)) as H. exact (maponpaths pr1 H). Qed. Definition isaprop_is_opcartesian_2cell_sopfib {x : B} {f : x --> e} {g : x --> e} (γ : f ==> g) : isaprop (is_opcartesian_2cell_sopfib γ). Proof. do 4 (use impred ; intro). apply isapropiscontr. Qed. Definition internal_sopfib_opcleaving : UU := ∏ (x : B) (f : x --> e) (g : x --> b) (α : f · p ==> g), ∑ (h : x --> e) (γ : f ==> h) (β : invertible_2cell g (h · p)), is_opcartesian_2cell_sopfib γ × γ ▹ p = α • β. Definition internal_sopfib_opcleaving_lift_mor (H : internal_sopfib_opcleaving) {x : B} {f : x --> e} {g : x --> b} (α : f · p ==> g) : x --> e := pr1 (H _ _ _ α). Definition internal_sopfib_opcleaving_lift_cell (H : internal_sopfib_opcleaving) {x : B} {f : x --> e} {g : x --> b} (α : f · p ==> g) : f ==> internal_sopfib_opcleaving_lift_mor H α := pr12 (H _ _ _ α). Definition internal_sopfib_opcleaving_com (H : internal_sopfib_opcleaving) {x : B} {f : x --> e} {g : x --> b} (α : f · p ==> g) : invertible_2cell g (internal_sopfib_opcleaving_lift_mor H α · p) := pr122 (H _ _ _ α). Definition internal_sopfib_opcleaving_is_opcartesian (H : internal_sopfib_opcleaving) {x : B} {f : x --> e} {g : x --> b} (α : f · p ==> g) : is_opcartesian_2cell_sopfib (internal_sopfib_opcleaving_lift_cell H α) := pr1 (pr222 (H _ _ _ α)). Definition internal_sopfib_opcleaving_over (H : internal_sopfib_opcleaving) {x : B} {f : x --> e} {g : x --> b} (α : f · p ==> g) : internal_sopfib_opcleaving_lift_cell H α ▹ p = α • internal_sopfib_opcleaving_com H α := pr2 (pr222 (H _ _ _ α)). Definition lwhisker_is_opcartesian : UU := ∏ (x y : B) (h : y --> x) (f g : x --> e) (γ : f ==> g) (Hγ : is_opcartesian_2cell_sopfib γ), is_opcartesian_2cell_sopfib (h ◃ γ). Definition internal_sopfib : UU := internal_sopfib_opcleaving × lwhisker_is_opcartesian. Coercion internal_sopfib_to_opcleaving (H : internal_sopfib) : internal_sopfib_opcleaving := pr1 H. End InternalStreetOpFibration. (** 2. Street opfibrations in [B] are the same as Street fibrations in [op2_bicat B] *) Definition is_cartesian_to_is_opcartesian_sfib {B : bicat} {e b : B} {p : e --> b} {x : B} {f g : x --> e} {α : f ==> g} (Hα : @is_cartesian_2cell_sfib (op2_bicat B) e b p x g f α) : is_opcartesian_2cell_sopfib p α. Proof. intros h γ δp q. use iscontraprop1. - abstract (use invproofirrelevance ; intros δ₁ δ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (is_cartesian_2cell_sfib_factor_unique _ Hα _ γ δp q _ _ (pr12 δ₁) (pr12 δ₂) (pr22 δ₁) (pr22 δ₂))). - exact (is_cartesian_2cell_sfib_factor _ Hα γ δp q ,, is_cartesian_2cell_sfib_factor_over _ Hα q ,, is_cartesian_2cell_sfib_factor_comm _ Hα q). Defined. Definition is_opcartesian_to_is_cartesian_sfib {B : bicat} {e b : B} {p : e --> b} {x : B} {f g : x --> e} {α : f ==> g} (Hα : is_opcartesian_2cell_sopfib p α) : @is_cartesian_2cell_sfib (op2_bicat B) e b p x g f α. Proof. intros h γ δp q. use iscontraprop1. - abstract (use invproofirrelevance ; intros δ₁ δ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; exact (is_opcartesian_2cell_sopfib_factor_unique _ Hα _ γ δp q _ _ (pr12 δ₁) (pr12 δ₂) (pr22 δ₁) (pr22 δ₂))). - exact (is_opcartesian_2cell_sopfib_factor _ Hα γ δp q ,, is_opcartesian_2cell_sopfib_factor_over _ Hα _ _ q ,, is_opcartesian_2cell_sopfib_factor_comm _ Hα _ _ q). Defined. Definition is_cartesian_weq_is_opcartesian_sfib {B : bicat} {e b : B} {p : e --> b} {x : B} {f g : x --> e} (α : f ==> g) : @is_cartesian_2cell_sfib (op2_bicat B) e b p x g f α ≃ is_opcartesian_2cell_sopfib p α. Proof. use weqimplimpl. - exact is_cartesian_to_is_opcartesian_sfib. - exact is_opcartesian_to_is_cartesian_sfib. - apply isaprop_is_cartesian_2cell_sfib. - apply isaprop_is_opcartesian_2cell_sopfib. Defined. Definition internal_sfib_is_internal_sopfib {B : bicat} {e b : B} {p : e --> b} (Hp : @internal_sfib (op2_bicat B) e b p) : internal_sopfib p. Proof. split. - intros x f g α. refine (internal_sfib_cleaving_lift_mor _ Hp α ,, internal_sfib_cleaving_lift_cell _ Hp α ,, weq_op2_invertible_2cell _ _ (internal_sfib_cleaving_com _ Hp α) ,, _ ,, internal_sfib_cleaving_over _ Hp α). apply is_cartesian_to_is_opcartesian_sfib. exact (internal_sfib_cleaving_is_cartesian _ Hp α). - intros x y h f g γ Hγ. apply is_cartesian_to_is_opcartesian_sfib. apply (pr2 Hp). apply is_opcartesian_to_is_cartesian_sfib. exact Hγ. Defined. Definition internal_sopfib_is_internal_sfib {B : bicat} {e b : B} {p : e --> b} (Hp : internal_sopfib p) : @internal_sfib (op2_bicat B) e b p. Proof. split. - intros x f g α. refine (internal_sopfib_opcleaving_lift_mor _ Hp α ,, internal_sopfib_opcleaving_lift_cell _ Hp α ,, weq_op2_invertible_2cell _ _ (internal_sopfib_opcleaving_com _ Hp α) ,, _ ,, internal_sopfib_opcleaving_over _ Hp α). apply is_opcartesian_to_is_cartesian_sfib. exact (internal_sopfib_opcleaving_is_opcartesian _ Hp α). - intros x y h f g γ Hγ. apply is_opcartesian_to_is_cartesian_sfib. apply (pr2 Hp). apply is_cartesian_to_is_opcartesian_sfib. exact Hγ. Defined. Definition internal_sopfib_weq_internal_sfib_inv_left {B : bicat} {e b : B} {p : e --> b} (Hp : @internal_sfib (op2_bicat B) e b p) : internal_sopfib_is_internal_sfib (internal_sfib_is_internal_sopfib Hp) = Hp. Proof. use pathsdirprod ; repeat (use funextsec ; intro) ; repeat (refine (maponpaths (λ z, _ ,, z) _)). - use pathsdirprod. + apply isaprop_is_cartesian_2cell_sfib. + apply idpath. - apply isapropiscontr. Qed. Definition internal_sopfib_weq_internal_sfib_inv_right {B : bicat} {e b : B} {p : e --> b} (Hp : internal_sopfib p) : internal_sfib_is_internal_sopfib (internal_sopfib_is_internal_sfib Hp) = Hp. Proof. use pathsdirprod ; repeat (use funextsec ; intro) ; repeat (refine (maponpaths (λ z, _ ,, z) _)). - use pathsdirprod. + apply isaprop_is_opcartesian_2cell_sopfib. + apply idpath. - apply isapropiscontr. Qed. Definition internal_sopfib_weq_internal_sfib {B : bicat} {e b : B} (p : e --> b) : @internal_sfib (op2_bicat B) e b p ≃ internal_sopfib p. Proof. use make_weq. - exact internal_sfib_is_internal_sopfib. - use isweq_iso. + exact internal_sopfib_is_internal_sfib. + exact internal_sopfib_weq_internal_sfib_inv_left. + exact internal_sopfib_weq_internal_sfib_inv_right. Defined. Definition isaprop_internal_sopfib {B : bicat} (HB_2_1 : is_univalent_2_1 B) {e b : B} (p : e --> b) : isaprop (internal_sopfib p). Proof. use (isofhlevelweqf _ (internal_sopfib_weq_internal_sfib p)). apply isaprop_internal_sfib. apply op2_bicat_is_univalent_2_1. exact HB_2_1. Qed. (** 3. Properties of opcartesian cells *) Definition id_is_opcartesian_2cell_sopfib {B : bicat} {e b : B} (p : e --> b) {x : B} (f : x --> e) : is_opcartesian_2cell_sopfib p (id2 f). Proof. apply is_cartesian_to_is_opcartesian_sfib. apply (@id_is_cartesian_2cell_sfib (op2_bicat B)). Defined. Definition vcomp_is_opcartesian_2cell_sopfib {B : bicat} {e b : B} (p : e --> b) {x : B} {f g h : x --> e} {α : f ==> g} {β : g ==> h} (Hα : is_opcartesian_2cell_sopfib p α) (Hβ : is_opcartesian_2cell_sopfib p β) : is_opcartesian_2cell_sopfib p (α • β). Proof. apply is_cartesian_to_is_opcartesian_sfib. use vcomp_is_cartesian_2cell_sfib. - apply is_opcartesian_to_is_cartesian_sfib. exact Hβ. - apply is_opcartesian_to_is_cartesian_sfib. exact Hα. Defined. Definition invertible_is_opcartesian_2cell_sopfib {B : bicat} {e b : B} (p : e --> b) {x : B} {f g : x --> e} (α : f ==> g) (Hα : is_invertible_2cell α) : is_opcartesian_2cell_sopfib p α. Proof. apply is_cartesian_to_is_opcartesian_sfib. apply invertible_is_cartesian_2cell_sfib. apply to_op2_is_invertible_2cell. exact Hα. Defined. Definition locally_grpd_opcartesian {B : bicat} (HB : locally_groupoid B) {e b : B} (p : e --> b) {x : B} {f g : x --> e} (γ : f ==> g) : is_opcartesian_2cell_sopfib p γ. Proof. apply invertible_is_opcartesian_2cell_sopfib. apply HB. Defined. Definition is_opcartesian_2cell_sopfib_precomp {B : bicat} {e b : B} (p : e --> b) {x : B} {f g h : x --> e} (α : f ==> g) {β : g ==> h} {γ : f ==> h} (Hα : is_opcartesian_2cell_sopfib p α) (Hγ : is_opcartesian_2cell_sopfib p γ) (q : α • β = γ) : is_opcartesian_2cell_sopfib p β. Proof. apply is_cartesian_to_is_opcartesian_sfib. refine (@is_cartesian_2cell_sfib_postcomp (op2_bicat B) _ _ _ _ _ _ _ β α γ _ _ _). - apply is_opcartesian_to_is_cartesian_sfib. exact Hα. - apply is_opcartesian_to_is_cartesian_sfib. exact Hγ. - exact q. Defined. Definition invertible_between_opcartesians {B : bicat} {x e b : B} {p : e --> b} {g₀ g₁ g₂ : x --> e} {α : g₀ ==> g₁} (Hα : is_opcartesian_2cell_sopfib p α) {β : g₀ ==> g₂} (Hβ : is_opcartesian_2cell_sopfib p β) (δ : invertible_2cell (g₂ · p) (g₁ · p)) (q : α ▹ p = (β ▹ p) • pr1 δ) : invertible_2cell g₂ g₁. Proof. use (make_invertible_2cell (weq_op2_invertible_2cell _ _ (@invertible_between_cartesians (op2_bicat B) x e b p _ _ _ α (is_opcartesian_to_is_cartesian_sfib Hα) β (is_opcartesian_to_is_cartesian_sfib Hβ) _ _))). - exact (weq_op2_invertible_2cell _ _ δ). - exact q. Defined. Definition locally_grpd_internal_sopfib {B : bicat} (HB : locally_groupoid B) {e b : B} (p : e --> b) : internal_sopfib p. Proof. split. - intros x f g α. refine (f ,, id2 _ ,, inv_of_invertible_2cell (make_invertible_2cell (HB _ _ _ _ α)) ,, locally_grpd_opcartesian HB _ _ ,, _). abstract (cbn ; rewrite id2_rwhisker ; rewrite vcomp_rinv ; apply idpath). - intro ; intros. apply (locally_grpd_opcartesian HB). Defined. (** 4. Morphisms of internal Street opfibrations *) Definition mor_preserves_opcartesian {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : UU := ∏ (x : B) (f g : x --> e₁) (γ : f ==> g) (Hγ : is_opcartesian_2cell_sopfib p₁ γ), is_opcartesian_2cell_sopfib p₂ (γ ▹ fe). Definition mor_preserves_cartesian_to_mor_preserves_opcartesian {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} (H : @mor_preserves_cartesian (op2_bicat B) e₁ b₁ p₁ e₂ b₂ p₂ fe) : mor_preserves_opcartesian p₁ p₂ fe. Proof. intros x f g γ Hγ. apply is_cartesian_to_is_opcartesian_sfib. apply H. apply is_opcartesian_to_is_cartesian_sfib. exact Hγ. Defined. Definition mor_preserves_opcartesian_to_mor_preserves_cartesian {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} (H : mor_preserves_opcartesian p₁ p₂ fe) : @mor_preserves_cartesian (op2_bicat B) e₁ b₁ p₁ e₂ b₂ p₂ fe. Proof. intros x f g γ Hγ. apply is_opcartesian_to_is_cartesian_sfib. apply H. apply is_cartesian_to_is_opcartesian_sfib. exact Hγ. Defined. Definition id_mor_preserves_opcartesian {B : bicat} {e b : B} (p : e --> b) : mor_preserves_opcartesian p p (id₁ e). Proof. intros ? ? ? ? H. assert (γ ▹ id₁ e = runitor _ • γ • rinvunitor _) as q. { use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite !vcomp_runitor. apply idpath. } rewrite q. use vcomp_is_opcartesian_2cell_sopfib. - use vcomp_is_opcartesian_2cell_sopfib. + use invertible_is_opcartesian_2cell_sopfib. is_iso. + exact H. - use invertible_is_opcartesian_2cell_sopfib. is_iso. Qed. Definition comp_preserves_opcartesian {B : bicat} {e₁ b₁ e₂ b₂ e₃ b₃ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {p₃ : e₃ --> b₃} {fe₁ : e₁ --> e₂} {fe₂ : e₂ --> e₃} (H₁ : mor_preserves_opcartesian p₁ p₂ fe₁) (H₂ : mor_preserves_opcartesian p₂ p₃ fe₂) : mor_preserves_opcartesian p₁ p₃ (fe₁ · fe₂). Proof. intros x f g γ Hγ. specialize (H₁ x _ _ γ Hγ). specialize (H₂ x _ _ _ H₁). assert (γ ▹ fe₁ · fe₂ = lassociator _ _ _ • ((γ ▹ fe₁) ▹ fe₂) • rassociator _ _ _) as q. { use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply idpath. } rewrite q. use vcomp_is_opcartesian_2cell_sopfib. - use vcomp_is_opcartesian_2cell_sopfib. + use invertible_is_opcartesian_2cell_sopfib. is_iso. + exact H₂. - use invertible_is_opcartesian_2cell_sopfib. is_iso. Qed. Definition is_opcartesian_2cell_sopfib_inv2cell {B : bicat} {x e b : B} {p p' : e --> b} (α : invertible_2cell p p') {f g : x --> e} {β : f ==> g} (Hβ : is_opcartesian_2cell_sopfib p β) : is_opcartesian_2cell_sopfib p' β. Proof. apply is_cartesian_to_is_opcartesian_sfib. use (is_cartesian_2cell_sfib_inv2cell (inv_of_invertible_2cell (weq_op2_invertible_2cell _ _ α))). apply is_opcartesian_to_is_cartesian_sfib. exact Hβ. Defined. Definition invertible_2cell_mor_between_preserves_opcartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe₁ fe₂ : e₁ --> e₂} (α : invertible_2cell fe₁ fe₂) (H : mor_preserves_opcartesian p₁ p₂ fe₁) : mor_preserves_opcartesian p₁ p₂ fe₂. Proof. intros x f g γ Hγ. assert ((_ ◃ α) • (γ ▹ fe₂) = (γ ▹ fe₁) • (_ ◃ α)) as p. { rewrite vcomp_whisker. apply idpath. } use (is_opcartesian_2cell_sopfib_precomp _ _ _ _ p). - use invertible_is_opcartesian_2cell_sopfib. is_iso. apply property_from_invertible_2cell. - use vcomp_is_opcartesian_2cell_sopfib. + exact (H x f g γ Hγ). + use invertible_is_opcartesian_2cell_sopfib. is_iso. apply property_from_invertible_2cell. Defined. Definition invertible_2cell_between_preserves_opcartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ p₁' : e₁ --> b₁} {p₂ p₂' : e₂ --> b₂} {fe fe' : e₁ --> e₂} (α : invertible_2cell p₁ p₁') (β : invertible_2cell p₂ p₂') (γ : invertible_2cell fe fe') (H : mor_preserves_opcartesian p₁ p₂ fe) : mor_preserves_opcartesian p₁' p₂' fe'. Proof. intros w h₁ h₂ ζ Hζ. use (is_opcartesian_2cell_sopfib_inv2cell β). use (invertible_2cell_mor_between_preserves_opcartesian γ H). use (is_opcartesian_2cell_sopfib_inv2cell (inv_of_invertible_2cell α)). exact Hζ. Defined. Definition locally_grpd_preserves_opcartesian {B : bicat} (HB : locally_groupoid B) {e₁ b₁ e₂ b₂ : B} (p₁ : e₁ --> b₁) (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : mor_preserves_opcartesian p₁ p₂ fe. Proof. intro ; intros. apply (locally_grpd_opcartesian HB). Defined. Definition isaprop_mor_preserves_opcartesian {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fe : e₁ --> e₂) : isaprop (mor_preserves_opcartesian p₁ p₂ fe). Proof. do 5 (use impred ; intro). exact (isaprop_is_opcartesian_2cell_sopfib _ _). Qed. Definition mor_of_internal_sopfib_over {B : bicat} {e₁ b₁ : B} (p₁ : e₁ --> b₁) {e₂ b₂ : B} (p₂ : e₂ --> b₂) (fb : b₁ --> b₂) : UU := ∑ (fe : e₁ --> e₂), mor_preserves_opcartesian p₁ p₂ fe × invertible_2cell (p₁ · fb) (fe · p₂). Definition make_mor_of_internal_sopfib_over {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : e₁ --> e₂) (fc : mor_preserves_opcartesian p₁ p₂ fe) (f_com : invertible_2cell (p₁ · fb) (fe · p₂)) : mor_of_internal_sopfib_over p₁ p₂ fb := (fe ,, fc ,, f_com). Coercion mor_of_internal_sopfib_over_to_mor {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sopfib_over p₁ p₂ fb) : e₁ --> e₂ := pr1 fe. Definition mor_of_internal_sopfib_over_preserves {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sopfib_over p₁ p₂ fb) : mor_preserves_opcartesian p₁ p₂ fe := pr12 fe. Definition mor_of_internal_sopfib_over_com {B : bicat} {e₁ b₁ : B} {p₁ : e₁ --> b₁} {e₂ b₂ : B} {p₂ : e₂ --> b₂} {fb : b₁ --> b₂} (fe : mor_of_internal_sopfib_over p₁ p₂ fb) : invertible_2cell (p₁ · fb) (fe · p₂) := pr22 fe. Definition id_mor_of_internal_sopfib_over {B : bicat} {e b : B} (p : e --> b) : mor_of_internal_sopfib_over p p (id₁ _). Proof. use make_mor_of_internal_sopfib_over. - exact (id₁ e). - apply id_mor_preserves_opcartesian. - use make_invertible_2cell. + refine (runitor _ • linvunitor _). + is_iso. Defined. Definition comp_mor_of_internal_sopfib_over {B : bicat} {e₁ e₂ e₃ b₁ b₂ b₃ : B} {fb₁ : b₁ --> b₂} {fb₂ : b₂ --> b₃} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {p₃ : e₃ --> b₃} (fe₁ : mor_of_internal_sopfib_over p₁ p₂ fb₁) (fe₂ : mor_of_internal_sopfib_over p₂ p₃ fb₂) : mor_of_internal_sopfib_over p₁ p₃ (fb₁ · fb₂). Proof. use make_mor_of_internal_sopfib_over. - exact (fe₁ · fe₂). - exact (comp_preserves_opcartesian (mor_of_internal_sopfib_over_preserves fe₁) (mor_of_internal_sopfib_over_preserves fe₂)). - use make_invertible_2cell. + exact (lassociator _ _ _ • (mor_of_internal_sopfib_over_com fe₁ ▹ _) • rassociator _ _ _ • (_ ◃ mor_of_internal_sopfib_over_com fe₂) • lassociator _ _ _). + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. Defined. (** 5. Cells of internal Street opfibrations *) Definition cell_of_internal_sopfib_over_homot {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} (γ : fb ==> gb) {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sopfib_over p₁ p₂ fb} {ge : mor_of_internal_sopfib_over p₁ p₂ gb} (γe : fe ==> ge) : UU := mor_of_internal_sopfib_over_com fe • (γe ▹ _) = (_ ◃ γ) • mor_of_internal_sopfib_over_com ge. Definition cell_of_internal_sopfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} (γ : fb ==> gb) {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} (fe : mor_of_internal_sopfib_over p₁ p₂ fb) (ge : mor_of_internal_sopfib_over p₁ p₂ gb) : UU := ∑ (γe : fe ==> ge), cell_of_internal_sopfib_over_homot γ γe. Definition make_cell_of_internal_sopfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sopfib_over p₁ p₂ fb} {ge : mor_of_internal_sopfib_over p₁ p₂ gb} (γe : fe ==> ge) (p : cell_of_internal_sopfib_over_homot γ γe) : cell_of_internal_sopfib_over γ fe ge := (γe ,, p). Coercion cell_of_cell_of_internal_sopfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sopfib_over p₁ p₂ fb} {ge : mor_of_internal_sopfib_over p₁ p₂ gb} (γe : cell_of_internal_sopfib_over γ fe ge) : fe ==> ge := pr1 γe. Definition cell_of_internal_sopfib_over_eq {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sopfib_over p₁ p₂ fb} {ge : mor_of_internal_sopfib_over p₁ p₂ gb} (γe : cell_of_internal_sopfib_over γ fe ge) : mor_of_internal_sopfib_over_com fe • (γe ▹ _) = (_ ◃ γ) • mor_of_internal_sopfib_over_com ge := pr2 γe. Definition eq_cell_of_internal_sopfib_over {B : bicat} {b₁ b₂ e₁ e₂ : B} {fb gb : b₁ --> b₂} {γ : fb ==> gb} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : mor_of_internal_sopfib_over p₁ p₂ fb} {ge : mor_of_internal_sopfib_over p₁ p₂ gb} (γe₁ γe₂ : cell_of_internal_sopfib_over γ fe ge) (p : pr1 γe₁ = γe₂) : γe₁ = γe₂. Proof. use subtypePath. { intro. apply cellset_property. } exact p. Qed. UniMath-20231010/UniMath/Bicategories/Morphisms/Monadic.v000066400000000000000000000600021451125700300227740ustar00rootroot00000000000000(********************************************************************************* Monadic 1-cells In this file, we define monadic adjunctions in arbitrary bicategories. Suppose, that we have an adjunction in some bicategory with Eilenberg-Moore objects. This adjunction gives rise to a monad, and we can take the Eilenberg-Moore object of this particular monad. To define monadic adjunctions, we take a similar approach as in category theory. So, we first define the comparison 1-cell whose target is the Eilenberg-Moore object of the monad generated by the adjunction in consideration. After that, we say that the adjunction is monadic if the comparison 1-cell is an adjoint equivalence. Note that we only define the representable definition of monadic 1-cells for locally univalent bicategories. That is because then we can reuse the fact that the bicategory of univalent categories has Eilenberg-Moore objects. In addition, in the representable definition, we do not assume that the involved bicategory has Eilenberg-Moore objects, while we need to do so for the other definition. Contents: 1. Comparison cell 2. Monadic adjunctions 3. Representable definition of monadic 1-cells *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties.AdjunctionsRepresentable. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.Monads.Examples.AdjunctionToMonad. Require Import UniMath.Bicategories.Monads.Examples.ToMonadInCat. Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats. Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Local Open Scope cat. Section Monadic. Context {B : bicat} (HB : bicat_has_em B) {x y : B} (l : adjunction x y). Let r : y --> x := left_adjoint_right_adjoint l. Let η : id₁ _ ==> l · r := left_adjoint_unit l. Let ε : r · l ==> id₁ _ := left_adjoint_counit l. Let m : mnd B := mnd_from_adjunction l. Let e : em_cone m := pr1 (HB m). Let He : has_em_ump _ e := pr2 (HB m). (** 1. Comparison cell *) Local Definition comparison_mor_cone_mult : lassociator r (l · r) (l · r) • (lassociator r l r ▹ l · r) • ((ε ▹ r) ▹ l · r) • (lunitor r ▹ l · r) • lassociator r l r • (ε ▹ r) = (r ◃ rassociator l r (l · r)) • (r ◃ (l ◃ lassociator r l r)) • (r ◃ (l ◃ (ε ▹ r))) • (r ◃ (l ◃ lunitor r)) • lassociator r l r • (ε ▹ r). Proof. refine (!_). etrans. { rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite lwhisker_lwhisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. rewrite lunitor_linvunitor. rewrite id2_right. apply idpath. Qed. Definition comparison_mor_cone : em_cone m. Proof. use make_em_cone. - exact y. - exact r. - exact (lassociator _ _ _ • (ε ▹ r)). - abstract (refine (!(id2_left _) @ _) ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocr ; exact (!(internal_triangle2 l))). - abstract (cbn ; rewrite <- !rwhisker_vcomp, <- !lwhisker_vcomp ; rewrite !vassocr ; exact comparison_mor_cone_mult). Defined. Definition comparison_mor : y --> e := em_ump_1_mor _ He comparison_mor_cone. Definition comparison_mor_cell : em_ump_1_mor m He comparison_mor_cone · mor_of_mnd_mor (mor_of_em_cone m e) ==> r := cell_of_mnd_cell (em_ump_1_inv2cell _ He comparison_mor_cone). Definition comparison_mor_inv2cell : invertible_2cell (em_ump_1_mor m He comparison_mor_cone · mor_of_mnd_mor (mor_of_em_cone m e)) r. Proof. use make_invertible_2cell. - exact comparison_mor_cell. - exact (from_invertible_mnd_2cell (em_ump_1_inv2cell _ He comparison_mor_cone)). Defined. Definition comparison_mor_eq_help : rassociator _ _ _ • (_ ◃ mnd_mor_endo (mor_of_em_cone m e)) • lassociator _ _ _ • (runitor _ • linvunitor _ ▹ _) • rassociator _ _ _ • (_ ◃ comparison_mor_cell) = (comparison_mor_cell ▹ _) • lassociator r l r • (ε ▹ r). Proof. pose (mnd_cell_endo (em_ump_1_inv2cell _ He comparison_mor_cone)). rewrite !vassocl. refine (_ @ p). do 4 refine (_ @ vassocr _ _ _). apply idpath. Qed. Definition comparison_mor_eq : (_ ◃ mnd_mor_endo (mor_of_em_cone m e)) • (_ ◃ lunitor _) • comparison_mor_cell = lassociator _ _ _ • lassociator _ _ _ • ((comparison_mor_cell ▹ l) ▹ r) • (ε ▹ r) • lunitor r. Proof. use vcomp_move_L_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite rwhisker_rwhisker. refine (_ @ comparison_mor_eq_help). rewrite !vassocl. do 2 apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite !vassocr. refine (!_). etrans. { do 3 apply maponpaths_2. apply runitor_rwhisker. } rewrite !vassocl. apply maponpaths. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocr. apply maponpaths_2. refine (!_). apply linvunitor_assoc. Qed. (** 2. Monadic adjunctions *) Definition is_monadic : UU := left_adjoint_equivalence comparison_mor. Definition isaprop_is_monadic (HB_2_1 : is_univalent_2_1 B) : isaprop is_monadic. Proof. apply isaprop_left_adjoint_equivalence. exact HB_2_1. Qed. End Monadic. (** 3. Representable definition of monadic 1-cells *) Definition is_monadic_repr {B : bicat} (HB_2_1 : is_univalent_2_1 B) {x y : B} (l : adjunction x y) : UU := ∏ (w : B), is_monadic has_em_bicat_of_univ_cats (left_adjoint_to_adjunction_cat _ l w HB_2_1). Definition isaprop_is_monadic_repr {B : bicat} (HB_2_1 : is_univalent_2_1 B) {x y : B} (l : adjunction x y) : isaprop (is_monadic_repr HB_2_1 l). Proof. use impred ; intro. apply isaprop_is_monadic. exact univalent_cat_is_univalent_2_1. Defined. Section MonadicReprWeqMonadic. Context {B : bicat} (HB_2_1 : is_univalent_2_1 B) (HB : bicat_has_em B) {x y : B} (l : adjunction x y). Section DiagramOfMonadicRepr. Context (w : B). Let M : Monad (hom w x) := mnd_bicat_of_univ_cats_to_Monad (mnd_from_adjunction (left_adjoint_to_adjunction_cat l l w HB_2_1)). Let M' : Monad (hom w x) := mnd_to_cat_Monad (mnd_from_adjunction l) w. Let F : hom w y ⟶ eilenberg_moore_cat _ := comparison_mor has_em_bicat_of_univ_cats (left_adjoint_to_adjunction_cat l l w HB_2_1). Let G : hom w y ⟶ hom w (pr1 (HB (mnd_from_adjunction l))) := post_comp w (comparison_mor HB l). Let H : hom w (pr1 (HB (mnd_from_adjunction l))) ⟶ eilenberg_moore_cat M' := is_em_universal_em_cone_functor _ (pr1 (HB (mnd_from_adjunction l))) w. Definition is_monadic_connecting_functor_ob (z : eilenberg_moore_cat M') : eilenberg_moore_cat M. Proof. use make_ob_eilenberg_moore. - exact (ob_of_eilenberg_moore_ob z). - cbn. exact (rassociator _ _ _ • mor_of_eilenberg_moore_ob z). - abstract (refine (_ @ eilenberg_moore_ob_unit z) ; cbn ; rewrite !vassocl ; do 2 apply maponpaths ; rewrite !vassocr ; rewrite lassociator_rassociator ; apply id2_left). - abstract (cbn ; rewrite !id2_left, id2_right ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; pose (eilenberg_moore_ob_mult z) as p ; cbn in p ; rewrite <- p ; clear p ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- !lwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite rassociator_rassociator ; rewrite !vassocl ; rewrite !lwhisker_vcomp ; rewrite lwhisker_lwhisker_rassociator ; rewrite !vassocr ; apply maponpaths_2 ; rewrite <- rassociator_rassociator ; rewrite !vassocl ; apply maponpaths ; rewrite !lwhisker_vcomp ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite rwhisker_lwhisker_rassociator ; rewrite !vassocl ; apply maponpaths ; rewrite lunitor_lwhisker ; apply idpath). Defined. Definition is_monadic_connecting_functor_mor {z₁ z₂ : eilenberg_moore_cat M'} (f : z₁ --> z₂) : is_monadic_connecting_functor_ob z₁ --> is_monadic_connecting_functor_ob z₂. Proof. use make_mor_eilenberg_moore. - exact (mor_of_eilenberg_moore_mor f). - abstract (cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; exact (eq_of_eilenberg_moore_mor f)). Defined. Definition is_monadic_connecting_functor_data : functor_data (eilenberg_moore_cat M') (eilenberg_moore_cat M). Proof. use make_functor_data. - exact is_monadic_connecting_functor_ob. - exact @is_monadic_connecting_functor_mor. Defined. Definition is_monadic_connecting_is_functor : is_functor is_monadic_connecting_functor_data. Proof. split. - intro z. use eq_mor_eilenberg_moore ; cbn. apply idpath. - intros z₁ z₂ z₃ f g. use eq_mor_eilenberg_moore ; cbn. apply idpath. Qed. Definition is_monadic_connecting_functor : eilenberg_moore_cat M' ⟶ eilenberg_moore_cat M. Proof. use make_functor. - exact is_monadic_connecting_functor_data. - exact is_monadic_connecting_is_functor. Defined. Section IsMonadicEso. Context (z : eilenberg_moore_cat M). Definition is_monadic_connecting_functor_fiber : eilenberg_moore_cat M'. Proof. use make_ob_eilenberg_moore. - exact (ob_of_eilenberg_moore_ob z). - cbn. exact (lassociator _ _ _ • mor_of_eilenberg_moore_ob z). - abstract (refine (_ @ eilenberg_moore_ob_unit z) ; cbn ; rewrite !vassocl ; apply idpath). - abstract (cbn ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite <- rwhisker_rwhisker ; rewrite !vassocl ; pose (eilenberg_moore_ob_mult z) as p ; cbn in p ; rewrite !id2_left, !id2_right in p ; rewrite <- p ; rewrite !vassocr ; apply maponpaths_2 ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite rassociator_rassociator ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite !lwhisker_vcomp ; rewrite !vassocl ; rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ; rewrite lwhisker_lwhisker_rassociator ; rewrite !vassocl ; rewrite rassociator_lassociator ; rewrite id2_right ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite !vassocr ; rewrite <- rassociator_rassociator ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; rewrite <- !lwhisker_vcomp ; rewrite !vassocr ; rewrite rwhisker_lwhisker_rassociator ; rewrite !vassocl ; apply maponpaths ; rewrite lunitor_lwhisker ; apply idpath). Defined. Definition is_monadic_connecting_functor_fiber_mor : is_monadic_connecting_functor_ob is_monadic_connecting_functor_fiber --> z. Proof. use make_mor_eilenberg_moore. - apply identity. - abstract (cbn ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite !id2_rwhisker ; rewrite !id2_left, id2_right ; apply idpath). Defined. Definition is_monadic_connecting_functor_z_iso : z_iso (is_monadic_connecting_functor_ob is_monadic_connecting_functor_fiber) z. Proof. refine (is_monadic_connecting_functor_fiber_mor ,, _). use is_z_iso_eilenberg_moore. apply is_z_isomorphism_identity. Defined. End IsMonadicEso. Definition is_monadic_connecting_functor_is_eso : Functors.essentially_surjective is_monadic_connecting_functor. Proof. intros z. apply hinhpr. simple refine (_ ,, _). - exact (is_monadic_connecting_functor_fiber z). - exact (is_monadic_connecting_functor_z_iso z). Defined. Section IsMonadicFull. Context {z₁ z₂ : eilenberg_moore_cat M'} (f : is_monadic_connecting_functor z₁ --> is_monadic_connecting_functor z₂). Definition is_monadic_connecting_functor_fiber_of_mor : z₁ --> z₂. Proof. use make_mor_eilenberg_moore. - exact (mor_of_eilenberg_moore_mor f). - abstract (cbn ; use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocr ; refine (eq_of_eilenberg_moore_mor f @ _) ; cbn ; rewrite <- rwhisker_rwhisker_alt ; rewrite !vassocl ; apply idpath). Defined. End IsMonadicFull. Definition is_monadic_connecting_functor_is_full : full is_monadic_connecting_functor. Proof. intros z₁ z₂ f. apply hinhpr. refine (is_monadic_connecting_functor_fiber_of_mor f ,, _). use eq_mor_eilenberg_moore. apply idpath. Defined. Definition is_monadic_connecting_functor_is_faithful : faithful is_monadic_connecting_functor. Proof. intros z₁ z₂ g. use invproofirrelevance. intros f₁ f₂. use subtypePath. { intro. apply homset_property. } use eq_mor_eilenberg_moore. exact (maponpaths (λ z, pr11 z) (pr2 f₁ @ !(pr2 f₂))). Qed. Definition is_monadic_connecting_functor_is_equiv : adj_equivalence_of_cats is_monadic_connecting_functor. Proof. use rad_equivalence_of_cats. - use is_univalent_eilenberg_moore_cat. apply is_univ_hom. exact HB_2_1. - use full_and_faithful_implies_fully_faithful. split. + exact is_monadic_connecting_functor_is_full. + exact is_monadic_connecting_functor_is_faithful. - exact is_monadic_connecting_functor_is_eso. Defined. Section CommuteData. Context (f : w --> y). Definition is_monadic_commute_cell : f · comparison_mor HB l · mor_of_mnd_mor (mor_of_em_cone (mnd_from_adjunction l) (pr1 (HB (mnd_from_adjunction l)))) ==> f · left_adjoint_right_adjoint l := rassociator _ _ _ • (f ◃ comparison_mor_inv2cell HB l). Definition is_monadic_commute_eq : (rassociator _ _ _ • (rassociator _ _ _ • (_ ◃ (mnd_mor_endo (mor_of_em_cone (mnd_from_adjunction l) (pr1 (HB (mnd_from_adjunction l)))) • lunitor _)))) • is_monadic_commute_cell = ((is_monadic_commute_cell ▹ l) ▹ left_adjoint_right_adjoint l) • (id₂ _ • (((rassociator _ _ _ • (f ◃ left_adjoint_counit l)) • runitor f) ▹ left_adjoint_right_adjoint l)). Proof. unfold is_monadic_commute_cell. rewrite id2_left. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_vcomp. apply maponpaths. rewrite <- !lwhisker_vcomp. exact (comparison_mor_eq HB l). } rewrite <- !lwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite <- !rwhisker_vcomp. rewrite <- lunitor_lwhisker. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. do 2 apply maponpaths_2. refine (!_). etrans. { rewrite !vassocl. do 4 apply maponpaths. rewrite lwhisker_vcomp. rewrite rwhisker_rwhisker. rewrite <- lwhisker_vcomp. apply idpath. } rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. apply rassociator_rassociator. } etrans. { rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_right. apply idpath. } rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. Qed. End CommuteData. Definition is_monadic_commute_data : nat_trans_data (G ∙ (H ∙ is_monadic_connecting_functor)) F. Proof. intro f. use make_mor_eilenberg_moore. - exact (is_monadic_commute_cell f). - exact (is_monadic_commute_eq f). Defined. Definition is_monadic_commute_is_nat_trans : is_nat_trans _ _ is_monadic_commute_data. Proof. intros f₁ f₂ τ. use eq_mor_eilenberg_moore. cbn ; unfold is_monadic_commute_cell. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker_alt. apply idpath. Qed. Definition is_monadic_commute : G ∙ (H ∙ is_monadic_connecting_functor) ⟹ F. Proof. use make_nat_trans. - exact is_monadic_commute_data. - exact is_monadic_commute_is_nat_trans. Defined. Definition is_monadic_commute_nat_z_iso : nat_z_iso (G ∙ (H ∙ is_monadic_connecting_functor)) F. Proof. use make_nat_z_iso. - exact is_monadic_commute. - intro f. use is_z_iso_eilenberg_moore. use is_inv2cell_to_is_z_iso. cbn ; unfold is_monadic_commute_cell. is_iso. exact (pr2 (comparison_mor_inv2cell HB l)). Defined. Definition comp_connecting_functor_equiv : adj_equivalence_of_cats (H ∙ is_monadic_connecting_functor). Proof. use comp_adj_equivalence_of_cats. - apply is_universal_em_cone_weq_is_em_universal_em_cone. + exact HB_2_1. + apply has_em_ump_is_universal. exact (pr2 (HB (mnd_from_adjunction l))). - exact is_monadic_connecting_functor_is_equiv. Defined. Definition monadic_repr_triangle_1 (HG : adj_equivalence_of_cats G) : adj_equivalence_of_cats F. Proof. use (two_out_of_three_comp _ _ _ is_monadic_commute_nat_z_iso). - exact HG. - exact comp_connecting_functor_equiv. Defined. Definition monadic_repr_triangle_2 (HF : adj_equivalence_of_cats F) : adj_equivalence_of_cats G. Proof. use (two_out_of_three_first _ _ _ is_monadic_commute_nat_z_iso). - exact comp_connecting_functor_equiv. - exact HF. Defined. End DiagramOfMonadicRepr. Definition is_monadic_to_is_monadic_repr (Hl : is_monadic HB l) : is_monadic_repr HB_2_1 l. Proof. intro w. apply equiv_cat_to_adj_equiv. apply monadic_repr_triangle_1. apply left_adjequiv_to_left_adjequiv_repr. exact Hl. Defined. Definition is_monadic_repr_to_is_monadic (Hl : is_monadic_repr HB_2_1 l) : is_monadic HB l. Proof. use left_adjoint_repr_to_left_adjoint_equivalence. intro w. apply monadic_repr_triangle_2. exact (adj_equiv_to_equiv_cat _ (Hl w)). Defined. Definition is_monadic_repr_weq_is_monadic : is_monadic_repr HB_2_1 l ≃ is_monadic HB l. Proof. use weqimplimpl. - exact is_monadic_repr_to_is_monadic. - exact is_monadic_to_is_monadic_repr. - apply isaprop_is_monadic_repr. - apply isaprop_is_monadic. exact HB_2_1. Defined. End MonadicReprWeqMonadic. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties.v000066400000000000000000000003421451125700300235570ustar00rootroot00000000000000Require Export UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Export UniMath.Bicategories.Morphisms.Properties.Composition. Require Export UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/000077500000000000000000000000001451125700300233715ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/AdjunctionsRepresentable.v000066400000000000000000000274221451125700300305640ustar00rootroot00000000000000(******************************************************************************* Representable definitions of adjunctions/adjoint equivalence We look at representable versions of adjunctions and adjoint equivalences. The first thing we notice, is that every adjunction in a bicategory gives rise to an adjunction on the hom-categories. However, note that in general, we do not get an adjunction from an adjunction on the hom-categories. For adjoint equivalences, the situation is different: for those, the two definitions are actually equivalent. Contents 1. Every adjunction gives rise to an adjunction on the hom-categories 2. Representable definition of adjoint equivalences 3. Adjoint equivalence to homwise adjoint equivalence 4. Homwise adjoint equivalence to adjoint equivalence 5. The two definitions are equivalent *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Local Open Scope cat. Definition left_adjoint_repr {B : bicat} {x y : B} (l : x --> y) : UU := ∏ (w : B), is_left_adjoint (post_comp w l). Section LeftAdjointToLeftAdjointRepr. Context {B : bicat} {x y : B} (l : x --> y) (Hl : left_adjoint l). Let r : y --> x := left_adjoint_right_adjoint Hl. Let η : id₁ _ ==> l · r := left_adjoint_unit Hl. Let ε : r · l ==> id₁ _ := left_adjoint_counit Hl. Section AdjointRepr. Context (w : B). Definition left_adjoint_to_repr_unit : functor_identity _ ⟹ post_comp w l ∙ post_comp w r. Proof. use make_nat_trans. - exact (λ f, rinvunitor _ • (f ◃ η) • lassociator _ _ _). - abstract (intros f₁ f₂ τ ; cbn ; rewrite !vassocl ; rewrite rwhisker_rwhisker ; rewrite !vassocr ; rewrite rinvunitor_natural ; rewrite <- rwhisker_hcomp ; apply maponpaths_2 ; rewrite !vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. Definition left_adjoint_to_repr_counit : post_comp w r ∙ post_comp w l ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ f, rassociator _ _ _ • (f ◃ ε) • runitor _). - abstract (intros f₁ f₂ τ ; cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; rewrite <- vcomp_runitor ; apply maponpaths ; rewrite !vassocr ; rewrite vcomp_whisker ; apply idpath). Defined. End AdjointRepr. Definition left_adjoint_to_left_adjoint_repr_form_adjunction (w : B) : form_adjunction (post_comp w l) (post_comp w r) (left_adjoint_to_repr_unit w) (left_adjoint_to_repr_counit w). Proof. split. - intro f ; cbn. rewrite !vassocl. refine (_ @ lwhisker_id2 _ _). refine (!_). etrans. { apply maponpaths. exact (!(internal_triangle1 Hl)). } rewrite <- runitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp, lwhisker_hcomp. rewrite triangle_r_inv. apply idpath. - intro f ; cbn. rewrite !vassocl. refine (_ @ lwhisker_id2 _ _). refine (!_). etrans. { apply maponpaths. exact (!(internal_triangle2 Hl)). } rewrite <- rinvunitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !rwhisker_vcomp. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. refine (!_). apply runitor_rwhisker. Qed. Definition left_adjoint_to_left_adjoint_repr_are_adjoints (w : B) : are_adjoints (post_comp w l) (post_comp w r). Proof. use make_are_adjoints. - exact (left_adjoint_to_repr_unit w). - exact (left_adjoint_to_repr_counit w). - exact (left_adjoint_to_left_adjoint_repr_form_adjunction w). Defined. Definition left_adjoint_to_left_adjoint_repr : left_adjoint_repr l := λ w, post_comp w r ,, left_adjoint_to_left_adjoint_repr_are_adjoints w. Definition left_adjoint_to_adjunction_cat (w : B) (HB_2_1 : is_univalent_2_1 B) : @adjunction bicat_of_univ_cats (univ_hom HB_2_1 w x) (univ_hom HB_2_1 w y). Proof. refine (post_comp w l ,, ((post_comp w r ,, (left_adjoint_to_repr_unit w ,, left_adjoint_to_repr_counit w)) ,, (_ ,, _))). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro ; rewrite !id2_right, id2_left ; apply left_adjoint_to_left_adjoint_repr_form_adjunction). - abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro ; rewrite !id2_right, id2_left ; apply left_adjoint_to_left_adjoint_repr_form_adjunction). Defined. End LeftAdjointToLeftAdjointRepr. (** 2. Representable definition of adjoint equivalences *) Definition left_adjoint_equivalence_repr {B : bicat} {x y : B} (l : x --> y) : UU := ∏ (w : B), adj_equivalence_of_cats (post_comp w l). Definition isaprop_left_adjoint_equivalence_repr {B : bicat} (HB_2_1 : is_univalent_2_1 B) {x y : B} (l : x --> y) : isaprop (left_adjoint_equivalence_repr l). Proof. use impred ; intro w. use isofhlevelweqf. - exact (@left_adjoint_equivalence bicat_of_univ_cats (univ_hom HB_2_1 _ _) (univ_hom HB_2_1 _ _) (post_comp w l)). - exact (@adj_equiv_is_equiv_cat (univ_hom HB_2_1 _ _) _ _). - apply isaprop_left_adjoint_equivalence. exact univalent_cat_is_univalent_2_1. Qed. (** 3. Adjoint equivalence to homwise adjoint equivalence *) Section LeftAdjointToLeftAdjointRepr. Context {B : bicat} {x y : B} (l : x --> y) (Hl : left_adjoint_equivalence l). Let r : y --> x := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso Hl. Section ToEquivalence. Context (w : B). Let L : hom w x ⟶ hom w y := post_comp w l. Let R : hom w y ⟶ hom w x := post_comp w r. Definition left_adjequiv_to_left_adjequiv_repr_equiv : equivalence_of_cats (hom w x) (hom w y). Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact L. + exact R. + apply left_adjoint_to_repr_unit. + apply left_adjoint_to_repr_counit. - split. + intro f. apply is_inv2cell_to_is_z_iso ; cbn. is_iso. exact (pr2 (left_equivalence_unit_iso Hl)). + intro f. apply is_inv2cell_to_is_z_iso ; cbn. is_iso. exact (pr2 (left_equivalence_counit_iso Hl)). Defined. End ToEquivalence. Definition left_adjequiv_to_left_adjequiv_repr : left_adjoint_equivalence_repr l := λ w, adjointification (left_adjequiv_to_left_adjequiv_repr_equiv w). End LeftAdjointToLeftAdjointRepr. (** 4. Homwise adjoint equivalence to adjoint equivalence *) Section LeftAdjointReprToLeftAdjoint. Context {B : bicat} {x y : B} (l : x --> y) (Hl : left_adjoint_equivalence_repr l). Let r : y --> x := right_adjoint (Hl y) (id₁ y). Let η : invertible_2cell (r · l) (id₁ y) := nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats (Hl y)) (id₁ y). Definition left_adjoint_repr_to_left_adjoint_counit : invertible_2cell (l · r) (id₁ x). Proof. apply z_iso_to_inv2cell. refine (z_iso_comp (nat_z_iso_pointwise_z_iso (unit_nat_z_iso_from_adj_equivalence_of_cats (Hl x)) (l · r)) (z_iso_comp (functor_on_z_iso (right_adjoint (Hl x)) _) (z_iso_inv (nat_z_iso_pointwise_z_iso (unit_nat_z_iso_from_adj_equivalence_of_cats (Hl x)) (id₁ x))))). cbn. apply inv2cell_to_z_iso. exact (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ η) (comp_of_invertible_2cell (runitor_invertible_2cell _) (linvunitor_invertible_2cell _)))). Defined. Definition left_adjoint_repr_to_left_adjoint_data : left_adjoint_data l := r ,, (left_adjoint_repr_to_left_adjoint_counit^-1 ,, pr1 η). Definition left_adjoint_repr_to_left_adjoint_axioms : left_equivalence_axioms left_adjoint_repr_to_left_adjoint_data. Proof. simple refine (_ ,, _). - apply is_invertible_2cell_inv. - exact (pr2 η). Defined. Definition left_adjoint_repr_to_left_adjoint_equivalence : left_adjoint_equivalence l := equiv_to_adjequiv _ (left_adjoint_repr_to_left_adjoint_data ,, left_adjoint_repr_to_left_adjoint_axioms). End LeftAdjointReprToLeftAdjoint. (** 5. The two definitions are equivalent *) Definition left_adjoint_equivalence_weq_left_adjoint_equivalence_repr {B : bicat} (HB : is_univalent_2_1 B) {x y : B} (l : x --> y) : left_adjoint_equivalence_repr l ≃ left_adjoint_equivalence l. Proof. use weqimplimpl. - exact (left_adjoint_repr_to_left_adjoint_equivalence l). - exact (left_adjequiv_to_left_adjequiv_repr l). - apply isaprop_left_adjoint_equivalence_repr. exact HB. - apply isaprop_left_adjoint_equivalence. exact HB. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/ClosedUnderInvertibles.v000066400000000000000000000320501451125700300301760ustar00rootroot00000000000000(** Properties of morphisms are closed under invertible 2-cells Contents: 1. Equivalences are closed under invertible 2-cells 2. Adjoint quivalences are closed under invertible 2-cells 3. Faithful 1-cells are closed under invertible 2-cells 4. Fully faithful 1-cells are closed under invertible 2-cells 5. Conservative 1-cells are closed under invertible 2-cells 6. Discrete 1-cells are closed under invertible 2-cells 7. Pseudomonic 1-cells are closed under invertible 2-cells 8. Internal Street fibrations are closed under invertible 2-cells 9. Adjunctions are closed under invertible 2-cells *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Local Open Scope cat. (** 1. Equivalences are closed under invertible 2-cells *) Definition left_equivalence_invertible {B : bicat} {a b : B} {f g : a --> b} (g_equiv : left_equivalence g) {α : f ==> g} (Hα : is_invertible_2cell α) : left_equivalence f. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (left_adjoint_right_adjoint g_equiv). - exact ((left_adjoint_unit g_equiv) • ((Hα^-1) ▹ left_adjoint_right_adjoint g_equiv)). - exact ((left_adjoint_right_adjoint g_equiv ◃ α) • (left_adjoint_counit g_equiv)). - cbn. is_iso. apply g_equiv. - cbn. is_iso. apply g_equiv. Defined. (** 2. Adjoint quivalences are closed under invertible 2-cells *) Definition left_adjoint_equivalence_invertible {B : bicat} {a b : B} {f g : a --> b} (g_equiv : left_adjoint_equivalence g) {α : f ==> g} (Hα : is_invertible_2cell α) : left_adjoint_equivalence f. Proof. use equiv_to_adjequiv. exact (left_equivalence_invertible g_equiv Hα). Defined. (** 3. Faithful 1-cells are closed under invertible 2-cells *) Definition faithful_invertible {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) : faithful_1cell f₁ → faithful_1cell f₂. Proof. intros Hf₁ z g₁ g₂ α₁ α₂ p. apply (faithful_1cell_eq_cell Hf₁). use (vcomp_rcancel (_ ◃ β)). { is_iso. } rewrite !vcomp_whisker. rewrite p. apply idpath. Qed. (** 4. Fully faithful 1-cells are closed under invertible 2-cells *) Definition fully_faithful_invertible {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) (Hf₁ : fully_faithful_1cell f₁) : fully_faithful_1cell f₂. Proof. use make_fully_faithful. - exact (faithful_invertible β Hβ (fully_faithful_1cell_faithful Hf₁)). - intros z g₁ g₂ αf. simple refine (_ ,, _). + apply (fully_faithful_1cell_inv_map Hf₁). exact ((g₁ ◃ β) • αf • (g₂ ◃ Hβ^-1)). + abstract (cbn ; use (vcomp_rcancel (_ ◃ Hβ^-1)) ; [ is_iso | ] ; rewrite vcomp_whisker ; rewrite fully_faithful_1cell_inv_map_eq ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). Qed. (** 5. Conservative 1-cells are closed under invertible 2-cells *) Definition conservative_invertible {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) (Hf₁ : conservative_1cell f₁) : conservative_1cell f₂. Proof. intros x g₁ g₂ α Hα. apply Hf₁. use eq_is_invertible_2cell. - exact ((g₁ ◃ β) • (α ▹ f₂) • (g₂ ◃ Hβ^-1)). - abstract (rewrite <- vcomp_whisker ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_rinv ; rewrite lwhisker_id2 ; apply id2_right). - use is_invertible_2cell_vcomp. + use is_invertible_2cell_vcomp. * is_iso. * exact Hα. + is_iso. Defined. (** 6. Discrete 1-cells are closed under invertible 2-cells *) Definition discrete_invertible {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) (Hf₁ : discrete_1cell f₁) : discrete_1cell f₂. Proof. split. - exact (faithful_invertible β Hβ (pr1 Hf₁)). - exact (conservative_invertible β Hβ (pr2 Hf₁)). Defined. (** 7. Pseudomonic 1-cells are closed under invertible 2-cells *) Definition pseudomonic_invertible {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) (Hf₁ : pseudomonic_1cell f₁) : pseudomonic_1cell f₂. Proof. use make_pseudomonic. - apply (faithful_invertible β Hβ). apply pseudomonic_1cell_faithful. exact Hf₁. - intros z g₁ g₂ αf Hαf. simple refine (_ ,, _ ,, _). + refine (pseudomonic_1cell_inv_map Hf₁ ((_ ◃ β) • αf • (_ ◃ Hβ^-1)) _). is_iso. + apply is_invertible_2cell_pseudomonic_1cell_inv_map. + abstract (simpl ; use (vcomp_lcancel (_ ◃ β)) ; [ is_iso | ] ; rewrite <- vcomp_whisker ; rewrite pseudomonic_1cell_inv_map_eq ; rewrite !vassocl ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_right ; apply idpath). Defined. (** 8. Internal Street fibrations are closed under invertible 2-cells *) Section Cartesian2CellInvertible. Context {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) {x : B} {g₁ g₂ : x --> a} {α : g₁ ==> g₂} (Hα : is_cartesian_2cell_sfib f₁ α). Definition is_cartesian_2cell_invertible_unique {h : x --> a} {γ : h ==> g₂} {δp : h · f₂ ==> g₁ · f₂} (q : γ ▹ f₂ = δp • (α ▹ f₂)) : isaprop (∑ (δ : h ==> g₁), δ ▹ f₂ = δp × δ • α = γ). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use (is_cartesian_2cell_sfib_factor_unique _ Hα _ γ ((h ◃ β) • δp • (_ ◃ Hβ^-1))). - rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. rewrite vcomp_whisker. apply maponpaths. exact q. - use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite vcomp_whisker. rewrite (pr12 φ₁). apply idpath. - use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite vcomp_whisker. rewrite (pr12 φ₂). apply idpath. - apply (pr22 φ₁). - apply (pr22 φ₂). Qed. Definition is_cartesian_2cell_invertible : is_cartesian_2cell_sfib f₂ α. Proof. intros h γ δp q. use iscontraprop1. - exact (is_cartesian_2cell_invertible_unique q). - simple refine (_ ,, _ ,, _). + refine (is_cartesian_2cell_sfib_factor _ Hα γ ((h ◃ β) • δp • (_ ◃ Hβ^-1)) _). abstract (rewrite !vassocl ; rewrite <- vcomp_whisker ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite vcomp_whisker ; apply maponpaths ; exact q). + abstract (use (vcomp_rcancel (_ ◃ Hβ^-1)) ; [ is_iso | ] ; rewrite vcomp_whisker ; rewrite is_cartesian_2cell_sfib_factor_over ; rewrite !vassocr ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; rewrite id2_left ; apply idpath). + abstract (cbn ; apply is_cartesian_2cell_sfib_factor_comm). Defined. End Cartesian2CellInvertible. Section InvertibleFromInternalSFib. Context {B : bicat} {a b : B} {f₁ f₂ : a --> b} (β : f₁ ==> f₂) (Hβ : is_invertible_2cell β) (Hf₁ : internal_sfib f₁). Definition internal_sfib_cleaving_invertible : internal_sfib_cleaving f₂. Proof. intros x g₁ g₂ α. pose (ℓ := pr1 Hf₁ x g₁ g₂ (α • (g₂ ◃ Hβ^-1))). simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (pr1 ℓ). - exact (pr12 ℓ). - exact (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (β ,, Hβ))) (pr122 ℓ)). - apply (is_cartesian_2cell_invertible β Hβ). exact (pr1 (pr222 ℓ)). - abstract (simpl ; rewrite !vassocl ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite <- vcomp_whisker ; use vcomp_move_R_Mp ; [ is_iso ; apply Hβ | ] ; cbn ; rewrite !vassocl ; exact (pr2 (pr222 ℓ))). Defined. Definition lwhisker_is_cartesian_invertible : lwhisker_is_cartesian f₂. Proof. intros x y h g₁ g₂ γ Hγ. apply (is_cartesian_2cell_invertible β Hβ). apply (pr2 Hf₁). apply (is_cartesian_2cell_invertible _ (is_invertible_2cell_inv Hβ)). exact Hγ. Defined. Definition internal_sfib_invertible : internal_sfib f₂. Proof. split. - exact internal_sfib_cleaving_invertible. - exact lwhisker_is_cartesian_invertible. Defined. End InvertibleFromInternalSFib. (** 9. Adjunctions are closed under invertible 2-cells *) Section AdjunctionInvertible. Context {B : bicat} {x y : B} {l l' : x --> y} (α : invertible_2cell l l') (Hl : left_adjoint l). Let r : y --> x := left_adjoint_right_adjoint Hl. Let η : id₁ x ==> l · r := left_adjoint_unit Hl. Let ε : r · l ==> id₁ y := left_adjoint_counit Hl. Let trl : linvunitor _ • (η ▹ _) • rassociator _ _ _ • (_ ◃ ε) • runitor _ = id₂ _ := pr12 Hl. Let trr : rinvunitor _ • (_ ◃ η) • lassociator _ _ _ • (ε ▹ _) • lunitor _ = id₂ _ := pr22 Hl. Definition left_adjoint_data_invertible : left_adjoint_data l' := r ,, (η • (α ▹ r) ,, (_ ◃ α^-1) • ε). Definition left_adjoint_axioms_invertible : left_adjoint_axioms left_adjoint_data_invertible. Proof. split ; cbn. - rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. rewrite vcomp_runitor. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. exact trl. - rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. exact trr. Qed. Definition left_adjoint_invertible : left_adjoint l' := left_adjoint_data_invertible ,, left_adjoint_axioms_invertible. End AdjunctionInvertible. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/ClosedUnderPullback.v000066400000000000000000001220541451125700300274510ustar00rootroot00000000000000(** Preservation of morphisms by pullbacks Contents: 1. Pullbacks of faithful 1-cells 2. Pullbacks of fully faithful 1-cells 3. Pullbacks of conservative 1-cells 4. Pullbacks of discrete 1-cells 5. Pullbacks of pseudomonic 1-cells 6. Pullbacks of Street fibrations 7. Pullbacks of Street opfibrations *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.Properties.Composition. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Local Open Scope cat. (** 1. Pullbacks of faithful 1-cells *) Definition pb_of_faithful_1cell {B : bicat} {x₁ x₂ y₁ y₂ : B} {p₁ : x₁ --> y₁} {p₂ : x₁ --> x₂} {f : y₁ --> y₂} {g : x₂ --> y₂} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (pb := make_pb_cone x₁ p₁ p₂ γ) (H : has_pb_ump pb) (Hf : faithful_1cell f) : faithful_1cell p₂. Proof. intros z h₁ h₂ α β p. use (pb_ump_eq H h₁ h₂ (α ▹ _) (α ▹ _)). - rewrite !vassocl. rewrite rwhisker_rwhisker_alt. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. - apply idpath. - apply idpath. - cbn. use (faithful_1cell_eq_cell Hf). use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !rwhisker_rwhisker. apply maponpaths_2. use (vcomp_rcancel (_ ◃ γ)) ; [ is_iso ; apply property_from_invertible_2cell | ]. rewrite !vcomp_whisker. apply maponpaths. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !rwhisker_rwhisker. do 2 apply maponpaths. exact (!p). - exact (!p). Qed. (** 2. Pullbacks of fully faithful 1-cells *) Section PbOfFullyFaithful. Context {B : bicat} {x₁ x₂ y₁ y₂ : B} {p₁ : x₁ --> y₁} {p₂ : x₁ --> x₂} {f : y₁ --> y₂} {g : x₂ --> y₂} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (pb := make_pb_cone x₁ p₁ p₂ γ) (H : has_pb_ump pb) (Hf : fully_faithful_1cell f). Section Fullness. Context {z : B} {h₁ h₂ : z --> x₁} (αf : h₁ · p₂ ==> h₂ · p₂). Let ψ : h₁ · p₁ · f ==> h₂ · p₁ · f := rassociator _ _ _ • (_ ◃ γ) • lassociator _ _ _ • (αf ▹ _) • rassociator _ _ _ • (_ ◃ γ^-1) • lassociator _ _ _. Let ζ : h₁ · p₁ ==> h₂ · p₁ := fully_faithful_1cell_inv_map Hf ψ. Local Lemma pb_of_fully_faithful_1cell_2cell_help_eq : (h₁ ◃ γ) • lassociator h₁ p₂ g • (αf ▹ g) • rassociator h₂ p₂ g = lassociator h₁ p₁ f • (ζ ▹ f) • rassociator h₂ p₁ f • (h₂ ◃ γ). Proof. unfold ζ. rewrite fully_faithful_1cell_inv_map_eq. unfold ψ. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. do 3 apply maponpaths. refine (!(id2_right _) @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply idpath. Qed. Definition pb_of_fully_faithful_1cell_2cell : h₁ ==> h₂. Proof. use (pb_ump_cell H h₁ h₂ _ αf). - exact ζ. - exact pb_of_fully_faithful_1cell_2cell_help_eq. Defined. Definition pb_of_fully_faithful_1cell_2cell_eq : pb_of_fully_faithful_1cell_2cell ▹ p₂ = αf. Proof. unfold pb_of_fully_faithful_1cell_2cell. apply (pb_ump_cell_pr2 H). Qed. End Fullness. Definition pb_of_fully_faithful_1cell : fully_faithful_1cell p₂. Proof. use make_fully_faithful. - exact (pb_of_faithful_1cell H (pr1 Hf)). - intros z h₁ h₂ αf. exact (pb_of_fully_faithful_1cell_2cell αf ,, pb_of_fully_faithful_1cell_2cell_eq αf). Defined. End PbOfFullyFaithful. (** 3. Pullbacks of conservative 1-cells *) Section PbOfConservative. Context {B : bicat} {x₁ x₂ y₁ y₂ : B} {p₁ : x₁ --> y₁} {p₂ : x₁ --> x₂} {f : y₁ --> y₂} {g : x₂ --> y₂} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (pb := make_pb_cone x₁ p₁ p₂ γ) (H : has_pb_ump pb) (Hf : conservative_1cell f). Section ReflectIso. Context {z : B} {h₁ h₂ : z --> x₁} {α : h₁ ==> h₂} (Hα : is_invertible_2cell (α ▹ p₂)). Definition pb_reflect_iso_help : is_invertible_2cell (α ▹ p₁). Proof. apply (Hf z (h₁ · p₁) (h₂ · p₁) (α ▹ p₁)). use eq_is_invertible_2cell. - exact (rassociator _ _ _ • (_ ◃ γ) • lassociator _ _ _ • ((α ▹ p₂) ▹ g) • rassociator _ _ _ • (_ ◃ γ^-1) • lassociator _ _ _). - abstract (rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite rwhisker_rwhisker ; rewrite !vassocr ; apply maponpaths_2 ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite vcomp_whisker ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_rwhisker ; rewrite !vassocl ; rewrite lassociator_rassociator ; apply id2_right). - use is_invertible_2cell_vcomp ; [ | is_iso ]. use is_invertible_2cell_vcomp ; [ | is_iso ; apply property_from_invertible_2cell ]. use is_invertible_2cell_vcomp ; [ | is_iso ]. use is_invertible_2cell_vcomp. + is_iso. apply property_from_invertible_2cell . + apply is_invertible_2cell_rwhisker. exact Hα. Defined. Local Lemma pb_reflect_iso_eq : (h₁ ◃ γ) • lassociator h₁ p₂ g • ((α ▹ p₂) ▹ g) • rassociator h₂ p₂ g = lassociator h₁ p₁ f • ((α ▹ p₁) ▹ f) • rassociator h₂ p₁ f • (h₂ ◃ γ). Proof. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. apply id2_right. } rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. Qed. Definition pb_reflect_iso : is_invertible_2cell α. Proof. simple refine (eq_is_invertible_2cell _ (is_invertible_2cell_pb_ump_cell H pb_reflect_iso_eq pb_reflect_iso_help Hα)). use (pb_ump_eq H h₁ h₂ (α ▹ p₁) (α ▹ p₂)). - apply pb_reflect_iso_eq. - apply pb_ump_cell_pr1. - apply pb_ump_cell_pr2. - apply idpath. - apply idpath. Defined. End ReflectIso. Definition pb_of_conservative_1cell : conservative_1cell p₂. Proof. intros z h₁ h₂ α Hα. exact (pb_reflect_iso Hα). Defined. End PbOfConservative. (** 4. Pullbacks of discrete 1-cells *) Definition pb_of_discrete_1cell {B : bicat} {x₁ x₂ y₁ y₂ : B} {p₁ : x₁ --> y₁} {p₂ : x₁ --> x₂} {f : y₁ --> y₂} {g : x₂ --> y₂} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (pb := make_pb_cone x₁ p₁ p₂ γ) (H : has_pb_ump pb) (Hf : discrete_1cell f) : discrete_1cell p₂. Proof. split. - exact (pb_of_faithful_1cell H (pr1 Hf)). - exact (pb_of_conservative_1cell H (pr2 Hf)). Defined. (** 5. Pullbacks of pseudomonic 1-cells *) Section PullbackOfPseudomonic. Context {B : bicat} {x₁ x₂ y₁ y₂ : B} {p₁ : x₁ --> y₁} {p₂ : x₁ --> x₂} {f : y₁ --> y₂} {g : x₂ --> y₂} {γ : invertible_2cell (p₁ · f) (p₂ · g)} (pb := make_pb_cone x₁ p₁ p₂ γ) (H : has_pb_ump pb) (Hf : pseudomonic_1cell f). Section Invmap. Context {z : B} {g₁ g₂ : z --> x₁} (αf : g₁ · p₂ ==> g₂ · p₂) (Hαf : is_invertible_2cell αf). Local Definition pb_of_pseudomonic_1cell_invmap_help_cell : g₁ · p₁ · f ==> g₂ · p₁ · f := rassociator _ _ _ • (_ ◃ γ) • lassociator _ _ _ • (αf ▹ _) • rassociator _ _ _ • (_ ◃ γ^-1) • lassociator _ _ _. Local Notation "'ψ'" := pb_of_pseudomonic_1cell_invmap_help_cell. Local Lemma pb_of_pseudomonic_1cell_invmap_help_cell_invertible : is_invertible_2cell ψ. Proof. unfold pb_of_pseudomonic_1cell_invmap_help_cell. is_iso. apply property_from_invertible_2cell. Qed. Local Notation "'Hψ'" := pb_of_pseudomonic_1cell_invmap_help_cell_invertible. Let ζ : g₁ · p₁ ==> g₂ · p₁ := pseudomonic_1cell_inv_map Hf ψ Hψ. Local Lemma pb_of_pseudomonic_1cell_invmap_eq_help : (g₁ ◃ γ) • lassociator g₁ p₂ g • (αf ▹ g) • rassociator g₂ p₂ g = lassociator g₁ p₁ f • (ζ ▹ f) • rassociator g₂ p₁ f • (g₂ ◃ γ). Proof. unfold ζ. rewrite pseudomonic_1cell_inv_map_eq. unfold pb_of_pseudomonic_1cell_invmap_help_cell. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. do 3 apply maponpaths. refine (!(id2_right _) @ _). apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite id2_right. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Definition pb_of_pseudomonic_1cell_invmap : g₁ ==> g₂. Proof. use (pb_ump_cell H _ _ _ αf) ; cbn. - exact ζ. - exact pb_of_pseudomonic_1cell_invmap_eq_help. Defined. Definition pb_of_pseudomonic_1cell_invmap_is_invertible : is_invertible_2cell pb_of_pseudomonic_1cell_invmap. Proof. apply (is_invertible_2cell_pb_ump_cell H). - apply is_invertible_2cell_pseudomonic_1cell_inv_map. - exact Hαf. Defined. Definition pb_of_pseudomonic_1cell_invmap_eq : pb_of_pseudomonic_1cell_invmap ▹ p₂ = αf. Proof. apply (pb_ump_cell_pr2 H). Qed. End Invmap. Definition pb_of_pseudomonic_1cell : pseudomonic_1cell p₂. Proof. use make_pseudomonic. - apply (pb_of_faithful_1cell H). apply pseudomonic_1cell_faithful. exact Hf. - intros z g₁ g₂ αf Hαf. simple refine (_ ,, (_ ,, _)). + exact (pb_of_pseudomonic_1cell_invmap αf Hαf). + exact (pb_of_pseudomonic_1cell_invmap_is_invertible αf Hαf). + exact (pb_of_pseudomonic_1cell_invmap_eq αf Hαf). Defined. End PullbackOfPseudomonic. (** 6. Pullbacks of Street fibrations *) Section PullbackOfSFib. Context {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) (Hf : internal_sfib p₂). Section ToPBCartesian. Context {x : B} {g₁ g₂ : x --> e₁} (α : g₁ ==> g₂) (Hα : is_cartesian_2cell_sfib p₂ (α ▹ fe)) {h : x --> e₁} {β : h ==> g₂} {δp : h · p₁ ==> g₁ · p₁} (q : β ▹ p₁ = δp • (α ▹ p₁)). Definition to_pb_cartesian_unique : isaprop (∑ δ, δ ▹ p₁ = δp × δ • α = β). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use (pb_ump_eq H). - exact (pr1 φ₁ ▹ fe). - exact δp. - cbn. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite <- rwhisker_rwhisker. apply maponpaths. rewrite (pr12 φ₁). apply idpath. - apply idpath. - exact (pr12 φ₁). - cbn. use (is_cartesian_2cell_sfib_factor_unique _ Hα). + exact (β ▹ fe). + exact (rassociator _ _ _ • (h ◃ γ) • lassociator _ _ _ • (δp ▹ _) • rassociator _ _ _ • (g₁ ◃ γ^-1) • lassociator _ _ _). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. rewrite q. apply idpath. + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (pr12 φ₂). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. exact (pr12 φ₁). + rewrite rwhisker_vcomp. rewrite (pr22 φ₂). apply idpath. + rewrite rwhisker_vcomp. rewrite (pr22 φ₁). apply idpath. - exact (pr12 φ₂). Qed. Let φ : h · fe · p₂ ==> g₁ · fe · p₂ := rassociator _ _ _ • (h ◃ γ) • lassociator _ _ _ • (δp ▹ fb) • rassociator _ _ _ • (g₁ ◃ γ^-1) • lassociator _ _ _. Local Proposition φ_eq : (β ▹ fe) ▹ p₂ = φ • ((α ▹ fe) ▹ p₂). Proof. unfold φ ; clear φ. rewrite !vassocl. rewrite rwhisker_rwhisker. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite rwhisker_rwhisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- vcomp_whisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- rwhisker_rwhisker_alt. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_vcomp. apply maponpaths. exact q. Qed. Let to_pb_cartesian_cell_on_pr1 : h · fe ==> g₁ · fe := is_cartesian_2cell_sfib_factor _ Hα _ _ φ_eq. Local Definition to_pb_cartesian_cell_eq : (h ◃ γ) • lassociator h p₁ fb • (δp ▹ fb) • rassociator g₁ p₁ fb = lassociator h fe p₂ • (to_pb_cartesian_cell_on_pr1 ▹ p₂) • rassociator g₁ fe p₂ • (g₁ ◃ γ). Proof. unfold to_pb_cartesian_cell_on_pr1, φ. rewrite is_cartesian_2cell_sfib_factor_over. rewrite !vassocr. rewrite lassociator_rassociator, id2_left. rewrite !vassocl. do 3 apply maponpaths. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite lassociator_rassociator, id2_left. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_right. apply idpath. Qed. Definition to_pb_cartesian_cell : h ==> g₁. Proof. use (pb_ump_cell H). - exact to_pb_cartesian_cell_on_pr1. - exact δp. - exact to_pb_cartesian_cell_eq. Defined. Definition to_pb_cartesian_comm : to_pb_cartesian_cell • α = β. Proof. unfold to_pb_cartesian_cell. use (pb_ump_eq H). - exact (to_pb_cartesian_cell_on_pr1 • (α ▹ fe)). - exact (δp • (α ▹ p₁)). - cbn ; unfold to_pb_cartesian_cell_on_pr1. rewrite <- q. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite is_cartesian_2cell_sfib_factor_over. rewrite rwhisker_rwhisker_alt. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lassociator_rassociator, id2_left. rewrite <- vcomp_whisker. rewrite !vassocr. apply maponpaths_2. unfold φ. rewrite !vassocr. rewrite lassociator_rassociator, id2_left. rewrite !vassocl. refine (!_). etrans. { do 5 apply maponpaths. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite <- vcomp_whisker. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- q. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. rewrite vcomp_whisker. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. - cbn ; unfold to_pb_cartesian_cell_on_pr1. rewrite <- rwhisker_vcomp. apply maponpaths_2. apply (pb_ump_cell_pr1 H). - cbn ; unfold to_pb_cartesian_cell_on_pr1. rewrite <- rwhisker_vcomp. apply maponpaths_2. apply (pb_ump_cell_pr2 H). - cbn ; unfold to_pb_cartesian_cell_on_pr1. refine (!_). apply is_cartesian_2cell_sfib_factor_comm. - exact q. Qed. End ToPBCartesian. Definition to_pb_cartesian {x : B} {g₁ g₂ : x --> e₁} (α : g₁ ==> g₂) (Hα : is_cartesian_2cell_sfib p₂ (α ▹ fe)) : is_cartesian_2cell_sfib p₁ α. Proof. intros h β δp q. use iscontraprop1. - exact (to_pb_cartesian_unique α Hα q). - simple refine (_ ,, _ ,, _). + exact (to_pb_cartesian_cell α Hα q). + apply (pb_ump_cell_pr2 H). + exact (to_pb_cartesian_comm α Hα q). Defined. Section Cleaving. Context {x : B} {h₁ : x --> b₁} {h₂ : x --> e₁} (α : h₁ ==> h₂ · p₁). Let x_to_e₂ : x --> e₂. Proof. use (internal_sfib_cleaving_lift_mor _ Hf). - exact (h₁ · fb). - exact (h₂ · fe). - exact ((α ▹ _) • rassociator _ _ _ • (h₂ ◃ γ^-1) • lassociator _ _ _). Defined. Definition pb_of_sfib_cleaving_cone : pb_cone p₂ fb. Proof. use make_pb_cone. - exact x. - exact x_to_e₂. - exact h₁. - apply internal_sfib_cleaving_com. Defined. Definition pb_of_sfib_cleaving_mor : x --> e₁ := pb_ump_mor H pb_of_sfib_cleaving_cone. Definition pb_of_sfib_cleaving_cell : pb_of_sfib_cleaving_mor ==> h₂. Proof. use (pb_ump_cell H). - exact (pb_ump_mor_pr1 H pb_of_sfib_cleaving_cone • internal_sfib_cleaving_lift_cell _ _ _). - exact (pb_ump_mor_pr2 H pb_of_sfib_cleaving_cone • α). - abstract (simpl ; rewrite !vassocl ; etrans ; [ apply maponpaths_2 ; exact (pb_ump_mor_cell H pb_of_sfib_cleaving_cone) | ] ; rewrite !vassocl ; apply maponpaths ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; apply maponpaths ; cbn ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite rassociator_lassociator ; rewrite id2_left ; etrans ; [ apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; apply idpath | ] ; refine (!_) ; etrans ; [ apply maponpaths_2 ; apply internal_sfib_cleaving_over | ] ; rewrite !vassocl ; apply maponpaths ; rewrite !vassocl ; apply maponpaths ; rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite lwhisker_vcomp ; rewrite vcomp_linv ; rewrite lwhisker_id2 ; apply id2_right). Defined. Definition pb_of_sfib_cleaving_over : invertible_2cell (pb_of_sfib_cleaving_mor · p₁) h₁ := pb_ump_mor_pr2 H pb_of_sfib_cleaving_cone. Definition pb_of_sfib_cleaving_commute : pb_of_sfib_cleaving_cell ▹ p₁ = pb_of_sfib_cleaving_over • α. Proof. apply (pb_ump_cell_pr2 H). Defined. Definition pb_of_sfib_cleaving_cell_is_cartesian_2cell_sfib : is_cartesian_2cell_sfib p₁ pb_of_sfib_cleaving_cell. Proof. apply to_pb_cartesian. refine (is_cartesian_eq _ (!(pb_ump_cell_pr1 H _ _ _ _ _)) _). use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. apply property_from_invertible_2cell. - apply internal_sfib_cleaving_is_cartesian. Defined. End Cleaving. Definition pb_of_sfib_cleaving : internal_sfib_cleaving p₁ := λ x h₁ h₂ α, pb_of_sfib_cleaving_mor α ,, pb_of_sfib_cleaving_cell α ,, pb_of_sfib_cleaving_over α ,, pb_of_sfib_cleaving_cell_is_cartesian_2cell_sfib α ,, pb_of_sfib_cleaving_commute α. Section FromPBCartesian. Context {x : B} {g₁ g₂ : x --> e₁} (α : g₁ ==> g₂) (Hα : is_cartesian_2cell_sfib p₁ α). Let g₀ : x --> e₁ := pb_of_sfib_cleaving_mor (α ▹ p₁). Let β : g₀ ==> g₂ := pb_of_sfib_cleaving_cell (α ▹ p₁). Let Hβ : is_cartesian_2cell_sfib p₁ β. Proof. apply pb_of_sfib_cleaving_cell_is_cartesian_2cell_sfib. Defined. Local Lemma path_for_invertible_between_cartesians : α ▹ p₁ = (pb_of_sfib_cleaving_over (α ▹ p₁))^-1 • (β ▹ p₁). Proof. unfold β. refine (!_). etrans. { apply maponpaths. apply pb_of_sfib_cleaving_commute. } rewrite !vassocr. rewrite vcomp_linv. apply id2_left. Qed. Let δ : invertible_2cell g₁ g₀ := invertible_between_cartesians Hα Hβ (inv_of_invertible_2cell (pb_of_sfib_cleaving_over (α ▹ p₁))) path_for_invertible_between_cartesians. Definition from_pb_cartesian : is_cartesian_2cell_sfib p₂ (α ▹ fe). Proof. assert (p : δ • β = α). { apply is_cartesian_2cell_sfib_factor_comm. } use (is_cartesian_eq _ (maponpaths (λ z, z ▹ fe) p)). use (is_cartesian_eq _ (rwhisker_vcomp _ _ _)). use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. - unfold β, pb_of_sfib_cleaving_cell. rewrite (pb_ump_cell_pr1 H). use vcomp_is_cartesian_2cell_sfib. + apply invertible_is_cartesian_2cell_sfib. apply property_from_invertible_2cell. + apply internal_sfib_cleaving_is_cartesian. Defined. End FromPBCartesian. Definition pb_lwhisker_is_cartesian : lwhisker_is_cartesian p₁. Proof. intros x y h f g α Hα. apply to_pb_cartesian. use is_cartesian_eq. - exact (rassociator _ _ _ • (h ◃ (α ▹ fe)) • lassociator _ _ _). - abstract (rewrite rwhisker_lwhisker_rassociator ; rewrite !vassocl ; rewrite rassociator_lassociator ; apply id2_right). - use vcomp_is_cartesian_2cell_sfib. + use vcomp_is_cartesian_2cell_sfib. * apply invertible_is_cartesian_2cell_sfib. is_iso. * apply (pr2 Hf). apply from_pb_cartesian. exact Hα. + apply invertible_is_cartesian_2cell_sfib. is_iso. Defined. Definition pb_of_sfib : internal_sfib p₁. Proof. split. - exact pb_of_sfib_cleaving. - exact pb_lwhisker_is_cartesian. Defined. Definition mor_preserves_cartesian_pb_pr1 : mor_preserves_cartesian p₁ p₂ fe. Proof. intros x f g δ Hδ. apply from_pb_cartesian. exact Hδ. Defined. Definition mor_preserves_cartesian_pb_ump_mor {e₀ b₀ : B} (p₀ : e₀ --> b₀) (h₁ : e₀ --> e₂) (h₂ : b₀ --> b₁) (δ : invertible_2cell (h₁ · p₂) (p₀ · h₂ · fb)) (cone := make_pb_cone e₀ h₁ (p₀ · h₂) δ) (Hh₁ : mor_preserves_cartesian p₀ p₂ h₁) : mor_preserves_cartesian p₀ p₁ (pb_ump_mor H cone). Proof. intros x f g ζ Hζ. apply to_pb_cartesian. assert (H₁ : is_cartesian_2cell_sfib p₂ (rassociator g (pb_ump_mor H cone) fe)) . { apply invertible_is_cartesian_2cell_sfib. is_iso. } assert (H₂ : is_cartesian_2cell_sfib p₂ ((g ◃ pb_ump_mor_pr1 H cone))). { apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. } assert (H₃ : is_cartesian_2cell_sfib p₂ (rassociator f (pb_ump_mor H cone) fe • ((f ◃ pb_ump_mor_pr1 H cone) • (ζ ▹ pb_cone_pr1 cone)))). { use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. is_iso. - use vcomp_is_cartesian_2cell_sfib. + apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. + apply Hh₁. exact Hζ. } use (is_cartesian_2cell_sfib_postcomp p₂ _ (vcomp_is_cartesian_2cell_sfib _ H₁ H₂) H₃). abstract (rewrite vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. Definition mor_preserves_cartesian_pb_ump_mor_alt {e₀ : B} (p₀ : e₀ --> b₁) (h₁ : e₀ --> e₂) (δ : invertible_2cell (h₁ · p₂) (p₀ · fb)) (cone := make_pb_cone e₀ h₁ p₀ δ) (Hh₁ : mor_preserves_cartesian p₀ p₂ h₁) : mor_preserves_cartesian p₀ p₁ (pb_ump_mor H cone). Proof. intros x f g ζ Hζ. apply to_pb_cartesian. assert (H₁ : is_cartesian_2cell_sfib p₂ (rassociator g (pb_ump_mor H cone) fe)) . { apply invertible_is_cartesian_2cell_sfib. is_iso. } assert (H₂ : is_cartesian_2cell_sfib p₂ ((g ◃ pb_ump_mor_pr1 H cone))). { apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. } assert (H₃ : is_cartesian_2cell_sfib p₂ (rassociator f (pb_ump_mor H cone) fe • ((f ◃ pb_ump_mor_pr1 H cone) • (ζ ▹ pb_cone_pr1 cone)))). { use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. is_iso. - use vcomp_is_cartesian_2cell_sfib. + apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. + apply Hh₁. exact Hζ. } use (is_cartesian_2cell_sfib_postcomp p₂ _ (vcomp_is_cartesian_2cell_sfib _ H₁ H₂) H₃). abstract (rewrite vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. End PullbackOfSFib. Definition mor_preserves_cartesian_pb_ump_mor_comp {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) (Hf : internal_sfib p₂) {c : B} {cp : c --> e₂} {h : c --> b₁} (δ : invertible_2cell (cp · p₂) (h · fb)) (cone := make_pb_cone c cp h δ : pb_cone p₂ fb) (Hfmap : mor_preserves_cartesian (cp · p₂) p₂ cp) (Hgmap : mor_preserves_cartesian (cp · p₂) fb h) : mor_preserves_cartesian (cp · p₂) (fe · p₂) (pb_ump_mor H cone). Proof. intros w h₁ h₂ ζ Hζ. apply to_is_cartesian_2cell_comp. - use (to_pb_cartesian (mirror_has_pb_ump H)) ; cbn. assert (H₁ : is_cartesian_2cell_sfib fb (rassociator h₂ (pb_ump_mor H cone) _ • (_ ◃ pb_ump_mor_pr2 H cone))). { apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. } assert (H₂ : is_cartesian_2cell_sfib fb (rassociator _ _ _ • (_ ◃ pb_ump_mor_pr2 H cone) • (ζ ▹ h))). { cbn. use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. - apply Hgmap. exact Hζ. } use (is_cartesian_2cell_sfib_postcomp fb _ H₁ H₂). abstract (cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). - assert (H₁ : is_cartesian_2cell_sfib p₂ (rassociator h₂ (pb_ump_mor H cone) _ • (_ ◃ pb_ump_mor_pr1 H cone))). { apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. } assert (H₂ : is_cartesian_2cell_sfib p₂ (rassociator _ _ _ • (_ ◃ pb_ump_mor_pr1 H cone) • (ζ ▹ cp))). { use vcomp_is_cartesian_2cell_sfib. - apply invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. - apply Hfmap. exact Hζ. } use (is_cartesian_2cell_sfib_postcomp p₂ _ H₁ H₂). abstract (cbn ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; apply maponpaths ; rewrite vcomp_whisker ; apply idpath). Defined. (** 7. Pullbacks of Street fibrations *) Definition pb_of_sopfib {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) (Hf : internal_sopfib p₂) : internal_sopfib p₁. Proof. apply internal_sfib_is_internal_sopfib. use (@pb_of_sfib (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell γ). - apply to_op2_has_pb_ump. exact H. - apply internal_sopfib_is_internal_sfib. exact Hf. Defined. Definition mor_preserves_opcartesian_pb_pr1 {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) (Hf : internal_sopfib p₂) : mor_preserves_opcartesian p₁ p₂ fe. Proof. apply mor_preserves_cartesian_to_mor_preserves_opcartesian. use (@mor_preserves_cartesian_pb_pr1 (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell γ). - apply to_op2_has_pb_ump. exact H. - apply internal_sopfib_is_internal_sfib. exact Hf. Defined. Definition mor_preserves_opcartesian_pb_ump_mor {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) {e₀ b₀ : B} (p₀ : e₀ --> b₀) (h₁ : e₀ --> e₂) (h₂ : b₀ --> b₁) (δ : invertible_2cell (h₁ · p₂) (p₀ · h₂ · fb)) (cone := make_pb_cone e₀ h₁ (p₀ · h₂) δ) (Hh₁ : mor_preserves_opcartesian p₀ p₂ h₁) : mor_preserves_opcartesian p₀ p₁ (pb_ump_mor H cone). Proof. apply mor_preserves_cartesian_to_mor_preserves_opcartesian. exact (@mor_preserves_cartesian_pb_ump_mor (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb _ (to_op2_has_pb_ump _ H) e₀ b₀ p₀ h₁ h₂ (inv_of_invertible_2cell (weq_op2_invertible_2cell _ _ δ)) (mor_preserves_opcartesian_to_mor_preserves_cartesian Hh₁)). Defined. Definition from_pb_opcartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (H : has_pb_ump (make_pb_cone e₁ fe p₁ γ)) (Hp₂ : internal_sopfib p₂) {x : B} {g₁ g₂ : x --> e₁} (α : g₁ ==> g₂) (Hα : is_opcartesian_2cell_sopfib p₁ α) : is_opcartesian_2cell_sopfib p₂ (α ▹ fe). Proof. apply is_cartesian_to_is_opcartesian_sfib. use (@from_pb_cartesian (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell γ). - apply to_op2_has_pb_ump. exact H. - apply internal_sopfib_is_internal_sfib. exact Hp₂. - apply is_opcartesian_to_is_cartesian_sfib. exact Hα. Defined. Definition to_pb_opcartesian {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (H : has_pb_ump (make_pb_cone e₁ fe p₁ γ)) {x : B} {g₁ g₂ : x --> e₁} (α : g₁ ==> g₂) (Hα : is_opcartesian_2cell_sopfib p₂ (α ▹ fe)) : is_opcartesian_2cell_sopfib p₁ α. Proof. apply is_cartesian_to_is_opcartesian_sfib. use (@to_pb_cartesian (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb). - apply weq_op2_invertible_2cell. exact (inv_of_invertible_2cell γ). - apply to_op2_has_pb_ump. exact H. - apply is_opcartesian_to_is_cartesian_sfib. exact Hα. Defined. Definition mor_preserves_opcartesian_pb_ump_mor_alt {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) {e₀ : B} (p₀ : e₀ --> b₁) (h₁ : e₀ --> e₂) (δ : invertible_2cell (h₁ · p₂) (p₀ · fb)) (cone := make_pb_cone e₀ h₁ p₀ δ) (Hh₁ : mor_preserves_opcartesian p₀ p₂ h₁) : mor_preserves_opcartesian p₀ p₁ (pb_ump_mor H cone). Proof. apply mor_preserves_cartesian_to_mor_preserves_opcartesian. exact (@mor_preserves_cartesian_pb_ump_mor_alt (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb _ (to_op2_has_pb_ump _ H) e₀ p₀ h₁ (inv_of_invertible_2cell (weq_op2_invertible_2cell _ _ δ)) (mor_preserves_opcartesian_to_mor_preserves_cartesian Hh₁)). Defined. Definition mor_preserves_opcartesian_pb_ump_mor_comp {B : bicat} {e₁ e₂ b₁ b₂ : B} {p₁ : e₁ --> b₁} {p₂ : e₂ --> b₂} {fe : e₁ --> e₂} {fb : b₁ --> b₂} {γ : invertible_2cell (fe · p₂) (p₁ · fb)} (pb := make_pb_cone e₁ fe p₁ γ) (H : has_pb_ump pb) (Hf : internal_sopfib p₂) {c : B} {cp : c --> e₂} {h : c --> b₁} (δ : invertible_2cell (cp · p₂) (h · fb)) (cone := make_pb_cone c cp h δ : pb_cone p₂ fb) (Hfmap : mor_preserves_opcartesian (cp · p₂) p₂ cp) (Hgmap : mor_preserves_opcartesian (cp · p₂) fb h) : mor_preserves_opcartesian (cp · p₂) (fe · p₂) (pb_ump_mor H cone). Proof. apply mor_preserves_cartesian_to_mor_preserves_opcartesian. exact (@mor_preserves_cartesian_pb_ump_mor_comp (op2_bicat B) e₁ e₂ b₁ b₂ p₁ p₂ fe fb _ (to_op2_has_pb_ump _ H) (internal_sopfib_is_internal_sfib Hf) c cp h (inv_of_invertible_2cell (weq_op2_invertible_2cell _ _ δ)) (mor_preserves_opcartesian_to_mor_preserves_cartesian Hfmap) (mor_preserves_opcartesian_to_mor_preserves_cartesian Hgmap)). Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/Composition.v000066400000000000000000001011151451125700300260620ustar00rootroot00000000000000(** Properties of composition Contents: 1. Composition of equivalences 2. Composition of adjoint equivalences 3. Composition of faithful 1-cells 4. Composition of fully faithful 1-cells 5. Composition of discrete 1-cells 6. Composition of pseudomonic 1-cells 7. Composition of Street fibrations 8. Composition of Street opfibrations 9. Composition of adjunctions *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Local Open Scope cat. (** 1. Composition of equivalences *) Section CompositionEquivalence. Context {B : bicat} {a b c : B} (l₁ : a --> b) (l₂ : b --> c) (Hl₁ : left_equivalence l₁) (Hl₂ : left_equivalence l₂). Let r₁ : b --> a := left_adjoint_right_adjoint Hl₁. Let r₂ : c --> b := left_adjoint_right_adjoint Hl₂. Let η₁ : invertible_2cell (id₁ a) (l₁ · r₁) := left_equivalence_unit_iso Hl₁. Let η₂ : invertible_2cell (id₁ b) (l₂ · r₂) := left_equivalence_unit_iso Hl₂. Let ε₁ : invertible_2cell (r₁ · l₁) (id₁ b) := left_equivalence_counit_iso Hl₁. Let ε₂ : invertible_2cell (r₂ · l₂) (id₁ c) := left_equivalence_counit_iso Hl₂. Let ηc : id₁ a ==> l₁ · l₂ · (r₂ · r₁) := η₁ • (rinvunitor _ • (l₁ ◃ η₂) • lassociator _ _ _ ▹ r₁) • rassociator _ _ _. Let εc : r₂ · r₁ · (l₁ · l₂) ==> id₁ c := rassociator _ _ _ • (r₂ ◃ (lassociator _ _ _ • (ε₁ ▹ l₂) • lunitor _)) • ε₂. Definition comp_equiv : left_equivalence (l₁ · l₂). Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (r₂ · r₁). - exact ηc. - exact εc. - cbn ; unfold ηc. is_iso. + apply property_from_invertible_2cell. + apply property_from_invertible_2cell. - cbn ; unfold εc. is_iso. + apply property_from_invertible_2cell. + apply property_from_invertible_2cell. Defined. End CompositionEquivalence. (** 2. Composition of adjoint equivalences *) Definition comp_adjequiv {B : bicat} {a b c : B} (l₁ : adjoint_equivalence a b) (l₂ : adjoint_equivalence b c) : adjoint_equivalence a c. Proof. use (equiv_to_adjequiv (l₁ · l₂)). use comp_equiv. - exact l₁. - exact l₂. Defined. Definition comp_left_adjoint_equivalence {B : bicat} {a b c : B} {l₁ : a --> b} (Hl₁ : left_adjoint_equivalence l₁) {l₂ : b --> c} (Hl₂ : left_adjoint_equivalence l₂) : left_adjoint_equivalence (l₁ · l₂). Proof. exact (comp_adjequiv (l₁ ,, Hl₁) (l₂ ,, Hl₂)). Defined. Lemma unique_adjoint_equivalence_comp {B : bicat} (HB : is_univalent_2 B) {a b c : B} : ∏ (f : adjoint_equivalence a b) (g : adjoint_equivalence b c), comp_adjequiv f g = comp_adjoint_equivalence (pr1 HB) a b c f g. Proof. use (J_2_0 (pr1 HB) (λ a b f, _)). intros x g; simpl. unfold comp_adjoint_equivalence. rewrite J_2_0_comp. use subtypePath. { intro. exact (isaprop_left_adjoint_equivalence _ (pr2 HB)). } cbn. apply (isotoid_2_1 (pr2 HB)). use make_invertible_2cell. - exact (lunitor (pr1 g)). - is_iso. Qed. (** 3. Composition of faithful 1-cells *) Definition comp_faithful {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : faithful_1cell f) (Hg : faithful_1cell g) : faithful_1cell (f · g). Proof. intros z g₁ g₂ α₁ α₂ p. apply (faithful_1cell_eq_cell Hf). apply (faithful_1cell_eq_cell Hg). use (vcomp_rcancel (rassociator _ _ _)). { is_iso. } rewrite !rwhisker_rwhisker_alt. rewrite p. apply idpath. Qed. (** 4. Composition of fully faithful 1-cells *) Definition comp_fully_faithful {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : fully_faithful_1cell f) (Hg : fully_faithful_1cell g) : fully_faithful_1cell (f · g). Proof. use make_fully_faithful. - exact (comp_faithful (fully_faithful_1cell_faithful Hf) (fully_faithful_1cell_faithful Hg)). - intros z g₁ g₂ αf. simple refine (_ ,, _). + apply (fully_faithful_1cell_inv_map Hf). apply (fully_faithful_1cell_inv_map Hg). exact (rassociator _ _ _ • αf • lassociator _ _ _). + abstract (cbn ; use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite !fully_faithful_1cell_inv_map_eq ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; apply idpath). Defined. (** 5. Composition of conservative 1-cells *) Definition comp_conservative {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : conservative_1cell f) (Hg : conservative_1cell g) : conservative_1cell (f · g). Proof. intros x g₁ g₂ α Hα. apply Hf. apply Hg. use eq_is_invertible_2cell. - exact (rassociator _ _ _ • (α ▹ f · g) • lassociator _ _ _). - abstract (rewrite !vassocl ; rewrite <- rwhisker_rwhisker ; rewrite !vassocr ; rewrite rassociator_lassociator ; apply id2_left). - use is_invertible_2cell_vcomp. + use is_invertible_2cell_vcomp. * is_iso. * exact Hα. + is_iso. Defined. (** 5. Composition of discrete 1-cells *) Definition comp_discrete {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : discrete_1cell f) (Hg : discrete_1cell g) : discrete_1cell (f · g). Proof. split. - apply comp_faithful. + exact (pr1 Hf). + exact (pr1 Hg). - apply comp_conservative. + exact (pr2 Hf). + exact (pr2 Hg). Defined. (** 6. Composition of pseudomonic 1-cells *) Definition comp_pseudomonic {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : pseudomonic_1cell f) (Hg : pseudomonic_1cell g) : pseudomonic_1cell (f · g). Proof. use make_pseudomonic. - apply comp_faithful. + apply pseudomonic_1cell_faithful. exact Hf. + apply pseudomonic_1cell_faithful. exact Hg. - intros z g₁ g₂ αf Hαf. simple refine (_ ,, _). + simple refine (pseudomonic_1cell_inv_map Hf _ _). * apply (pseudomonic_1cell_inv_map Hg (rassociator _ _ _ • αf • lassociator _ _ _)). is_iso. * apply is_invertible_2cell_pseudomonic_1cell_inv_map. + split. * apply is_invertible_2cell_pseudomonic_1cell_inv_map. * abstract (use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ] ; rewrite <- rwhisker_rwhisker_alt ; rewrite !pseudomonic_1cell_inv_map_eq ; rewrite !vassocl ; rewrite lassociator_rassociator ; rewrite id2_right ; apply idpath). Defined. (** 7. Composition of Street fibrations *) Section CompositionOfSFib. Context {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : internal_sfib f) (Hg : internal_sfib g). Section CompCartesian. Context {z : B} {h₁ h₂ : z --> a} (α : h₁ ==> h₂) (Hα₁ : is_cartesian_2cell_sfib f α) (Hα₂ : is_cartesian_2cell_sfib g (α ▹ f)). Section ToCartesianComp. Context {k : z --> a} {β : k ==> h₂} {δp : k · (f · g) ==> h₁ · (f · g)} (q : β ▹ f · g = δp • (α ▹ f · g)). Local Lemma to_is_cartesian_2cell_comp_factor_help : (β ▹ f) ▹ g = rassociator k f g • δp • lassociator h₁ f g • ((α ▹ f) ▹ g). Proof. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. rewrite q. rewrite !vassocl. rewrite rwhisker_rwhisker. apply idpath. Qed. Let ζ : k · f ==> h₁ · f := is_cartesian_2cell_sfib_factor _ Hα₂ (β ▹ f) (rassociator _ _ _ • δp • lassociator _ _ _) to_is_cartesian_2cell_comp_factor_help. Definition to_is_cartesian_2cell_comp_factor : k ==> h₁. Proof. simple refine (is_cartesian_2cell_sfib_factor _ Hα₁ β ζ _). abstract (unfold ζ ; rewrite is_cartesian_2cell_sfib_factor_comm ; apply idpath). Defined. Definition to_is_cartesian_2cell_comp_over : to_is_cartesian_2cell_comp_factor ▹ f · g = δp. Proof. unfold to_is_cartesian_2cell_comp_factor, ζ. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite <- rwhisker_rwhisker_alt. rewrite !is_cartesian_2cell_sfib_factor_over. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. Qed. Definition to_is_cartesian_2cell_comp_comm : to_is_cartesian_2cell_comp_factor • α = β. Proof. unfold to_is_cartesian_2cell_comp_factor. rewrite is_cartesian_2cell_sfib_factor_comm. apply idpath. Qed. Definition to_is_cartesian_2cell_comp_unique : isaprop (∑ (δ : k ==> h₁), δ ▹ f · g = δp × δ • α = β). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } use (is_cartesian_2cell_sfib_factor_unique _ Hα₁ _ β ζ). - unfold ζ. rewrite is_cartesian_2cell_sfib_factor_comm. apply idpath. - use (is_cartesian_2cell_sfib_factor_unique _ Hα₂ _ (β ▹ f) (rassociator _ _ _ • δp • lassociator _ _ _) to_is_cartesian_2cell_comp_factor_help). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply maponpaths_2. exact (pr12 φ₁). + apply is_cartesian_2cell_sfib_factor_over. + rewrite !rwhisker_vcomp. rewrite (pr22 φ₁). apply idpath. + apply is_cartesian_2cell_sfib_factor_comm. - use (is_cartesian_2cell_sfib_factor_unique _ Hα₂ _ (β ▹ f) (rassociator _ _ _ • δp • lassociator _ _ _) to_is_cartesian_2cell_comp_factor_help). + rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite rwhisker_rwhisker. apply maponpaths_2. exact (pr12 φ₂). + apply is_cartesian_2cell_sfib_factor_over. + rewrite !rwhisker_vcomp. rewrite (pr22 φ₂). apply idpath. + apply is_cartesian_2cell_sfib_factor_comm. - exact (pr22 φ₁). - exact (pr22 φ₂). Qed. End ToCartesianComp. Definition to_is_cartesian_2cell_comp : is_cartesian_2cell_sfib (f · g) α. Proof. intros k β δp q. use iscontraprop1. - exact (to_is_cartesian_2cell_comp_unique q). - exact (to_is_cartesian_2cell_comp_factor q ,, to_is_cartesian_2cell_comp_over q ,, to_is_cartesian_2cell_comp_comm q). Defined. End CompCartesian. Section CompCleaving. Context {z : B} {h₁ : z --> c} {h₂ : z --> a} (α : h₁ ==> h₂ · (f · g)). Let ℓ₁ : z --> b := pr1 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)). Let γ₁ : ℓ₁ ==> h₂ · f := pr12 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)). Let β₁ : invertible_2cell (ℓ₁ · g) h₁ := pr122 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)). Let Hγ₁ : is_cartesian_2cell_sfib g γ₁ := pr1 (pr222 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _))). Let p₁ : γ₁ ▹ g = β₁ • (α • lassociator h₂ f g) := pr2 (pr222 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _))). Let ℓ₂ : z --> a := pr1 (pr1 Hf z ℓ₁ h₂ γ₁). Let γ₂ : ℓ₂ ==> h₂ := pr12 (pr1 Hf z ℓ₁ h₂ γ₁). Let β₂ : invertible_2cell (ℓ₂ · f) ℓ₁ := pr122 (pr1 Hf z ℓ₁ h₂ γ₁). Let Hγ₂ : is_cartesian_2cell_sfib f γ₂ := pr1 (pr222 (pr1 Hf z ℓ₁ h₂ γ₁)). Let p₂ : γ₂ ▹ f = β₂ • γ₁ := pr2 (pr222 (pr1 Hf z ℓ₁ h₂ γ₁)). Definition comp_sfib_cleaving_lift : z --> a := ℓ₂. Definition comp_sfib_cleaving_cell : comp_sfib_cleaving_lift ==> h₂ := γ₂. Definition comp_sfib_cleaving_cell_over_f : comp_sfib_cleaving_cell ▹ f = β₂ • γ₁ := p₂. Definition comp_sfib_cleaving_cell_g_cartesian : is_cartesian_2cell_sfib g γ₁ := Hγ₁. Definition comp_sfib_cleaving_cell_f_cartesian : is_cartesian_2cell_sfib f comp_sfib_cleaving_cell := Hγ₂. Definition comp_sfib_cleaving_over : invertible_2cell (comp_sfib_cleaving_lift · (f · g)) h₁ := comp_of_invertible_2cell (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (rwhisker_of_invertible_2cell _ β₂)) β₁. Definition comp_sfib_cleaving_is_cartesian_2cell : is_cartesian_2cell_sfib (f · g) comp_sfib_cleaving_cell. Proof. use to_is_cartesian_2cell_comp. - exact Hγ₂. - unfold comp_sfib_cleaving_cell. use (is_cartesian_eq _ (!p₂)). use vcomp_is_cartesian_2cell_sfib. + apply invertible_is_cartesian_2cell_sfib. apply property_from_invertible_2cell. + exact Hγ₁. Defined. Definition comp_sfib_cleaving_comm : comp_sfib_cleaving_cell ▹ f · g = comp_sfib_cleaving_over • α. Proof. unfold comp_sfib_cleaving_cell, comp_sfib_cleaving_over ; cbn. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite <- rwhisker_rwhisker_alt. etrans. { apply maponpaths_2. apply maponpaths. exact p₂. } rewrite <- rwhisker_vcomp. rewrite p₁. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. Qed. End CompCleaving. Definition comp_sfib_cleaving : internal_sfib_cleaving (f · g) := λ z h₁ h₂ α, comp_sfib_cleaving_lift α ,, comp_sfib_cleaving_cell α ,, comp_sfib_cleaving_over α ,, comp_sfib_cleaving_is_cartesian_2cell α ,, comp_sfib_cleaving_comm α. Section FromCompCartesian. Context {z : B} {h₁ h₂ : z --> a} (α : h₁ ==> h₂) (Hα : is_cartesian_2cell_sfib (f · g) α). Local Lemma from_is_cartesian_2cell_eq : α ▹ f · g = (comp_sfib_cleaving_over (α ▹ f · g))^-1 • (comp_sfib_cleaving_cell (α ▹ f · g) ▹ f · g). Proof. use vcomp_move_L_pM ; [ is_iso | ]. rewrite comp_sfib_cleaving_comm. apply idpath. Qed. Let ζ : invertible_2cell h₁ (comp_sfib_cleaving_lift (α ▹ f · g)) := invertible_between_cartesians Hα (comp_sfib_cleaving_is_cartesian_2cell (α ▹ (f · g))) (inv_of_invertible_2cell (comp_sfib_cleaving_over (α ▹ f · g))) from_is_cartesian_2cell_eq. Local Lemma from_is_cartesian_2cell_comp_eq : ζ • comp_sfib_cleaving_cell (α ▹ (f · g)) = α. Proof. apply is_cartesian_2cell_sfib_factor_comm. Qed. Definition from_is_cartesian_2cell_comp : is_cartesian_2cell_sfib f α. Proof. use (is_cartesian_eq _ from_is_cartesian_2cell_comp_eq). use vcomp_is_cartesian_2cell_sfib. - use invertible_is_cartesian_2cell_sfib. apply property_from_invertible_2cell. - apply comp_sfib_cleaving_cell_f_cartesian. Defined. Local Lemma from_is_cartesian_2cell_comp_rwhisker_eq : ((ζ ▹ f) • (comp_sfib_cleaving_cell (α ▹ f · g) ▹ f)) = α ▹ f. Proof. rewrite rwhisker_vcomp. rewrite from_is_cartesian_2cell_comp_eq. apply idpath. Qed. Definition from_is_cartesian_2cell_comp_rwhisker : is_cartesian_2cell_sfib g (α ▹ f). Proof. use (is_cartesian_eq _ from_is_cartesian_2cell_comp_rwhisker_eq). use vcomp_is_cartesian_2cell_sfib. - use invertible_is_cartesian_2cell_sfib. is_iso. apply property_from_invertible_2cell. - rewrite comp_sfib_cleaving_cell_over_f. use vcomp_is_cartesian_2cell_sfib. + use invertible_is_cartesian_2cell_sfib. apply property_from_invertible_2cell. + apply comp_sfib_cleaving_cell_g_cartesian. Defined. End FromCompCartesian. Definition comp_lwhisker_is_cartesian : lwhisker_is_cartesian (f · g). Proof. intros x y h k₁ k₂ γ Hγ. use to_is_cartesian_2cell_comp. - apply (pr2 Hf). exact (from_is_cartesian_2cell_comp _ Hγ). - assert (((h ◃ γ) ▹ f) • rassociator _ _ _ = rassociator _ _ _ • (h ◃ (γ ▹ f))) as r. { abstract (rewrite rwhisker_lwhisker_rassociator ; apply idpath). } refine (is_cartesian_2cell_sfib_postcomp _ ((h ◃ γ) ▹ f) _ _ r). + apply invertible_is_cartesian_2cell_sfib. is_iso. + use vcomp_is_cartesian_2cell_sfib. * apply invertible_is_cartesian_2cell_sfib. is_iso. * apply Hg. apply from_is_cartesian_2cell_comp_rwhisker. exact Hγ. Defined. Definition comp_sfib : internal_sfib (f · g). Proof. split. - exact comp_sfib_cleaving. - exact comp_lwhisker_is_cartesian. Defined. End CompositionOfSFib. Definition comp_mor_preserves_cartesian {B : bicat} {x y z : B} {f : x --> y} (Hf : internal_sfib f) {g : y --> z} (Hg : internal_sfib g) : mor_preserves_cartesian (f · g) g f. Proof. intros w h₁ h₂ γ Hγ. apply from_is_cartesian_2cell_comp_rwhisker. - exact Hf. - exact Hg. - exact Hγ. Defined. (** 8. Composition of Street opfibrations *) Definition from_is_opcartesian_2cell_comp_rwhisker {B : bicat} {a b c : B} {f : a --> b} (Hf : internal_sopfib f) {g : b --> c} (Hg : internal_sopfib g) {z : B} {h₁ h₂ : z --> a} {α : h₁ ==> h₂} (Hα : is_opcartesian_2cell_sopfib (f · g) α) : is_opcartesian_2cell_sopfib g (α ▹ f). Proof. use is_cartesian_to_is_opcartesian_sfib. use from_is_cartesian_2cell_comp_rwhisker. - apply internal_sopfib_is_internal_sfib. exact Hf. - apply internal_sopfib_is_internal_sfib. exact Hg. - use is_opcartesian_to_is_cartesian_sfib. exact Hα. Defined. Definition comp_sopfib {B : bicat} {a b c : B} {f : a --> b} {g : b --> c} (Hf : internal_sopfib f) (Hg : internal_sopfib g) : internal_sopfib (f · g). Proof. apply internal_sfib_is_internal_sopfib. use comp_sfib. - apply internal_sopfib_is_internal_sfib. exact Hf. - apply internal_sopfib_is_internal_sfib. exact Hg. Defined. Definition comp_mor_preserves_opcartesian {B : bicat} {x y z : B} {f : x --> y} (Hf : internal_sopfib f) {g : y --> z} (Hg : internal_sopfib g) : mor_preserves_opcartesian (f · g) g f. Proof. intros w h₁ h₂ γ Hγ. apply from_is_opcartesian_2cell_comp_rwhisker. - exact Hf. - exact Hg. - exact Hγ. Defined. (** 9. Composition of adjunctions *) Section CompositionAdjunction. Context {B : bicat} {x y z : B} (l₁ : x --> y) (l₂ : y --> z) (Hl₁ : left_adjoint l₁) (Hl₂ : left_adjoint l₂). Let r₁ : y --> x := left_adjoint_right_adjoint Hl₁. Let η₁ : id₁ x ==> l₁ · r₁ := left_adjoint_unit Hl₁. Let ε₁ : r₁ · l₁ ==> id₁ y := left_adjoint_counit Hl₁. Let r₂ : z --> y := left_adjoint_right_adjoint Hl₂. Let η₂ : id₁ y ==> l₂ · r₂ := left_adjoint_unit Hl₂. Let ε₂ : r₂ · l₂ ==> id₁ z := left_adjoint_counit Hl₂. Let ηη : id₁ x ==> l₁ · l₂ · (r₂ · r₁) := η₁ • (_ ◃ (linvunitor _ • (η₂ ▹ _) • rassociator _ _ _)) • lassociator _ _ _. Let εε : r₂ · r₁ · (l₁ · l₂) ==> id₁ z := rassociator _ _ _ • (_ ◃ (lassociator _ _ _ • (ε₁ ▹ _) • lunitor _)) • ε₂. Let trl₁ : linvunitor _ • (η₁ ▹ _) • rassociator _ _ _ • (_ ◃ ε₁) • runitor _ = id₂ _ := pr12 Hl₁. Let trl₂ : linvunitor _ • (η₂ ▹ _) • rassociator _ _ _ • (_ ◃ ε₂) • runitor _ = id₂ _ := pr12 Hl₂. Let trr₁ : rinvunitor _ • (_ ◃ η₁) • lassociator _ _ _ • (ε₁ ▹ _) • lunitor _ = id₂ _ := pr22 Hl₁. Let trr₂ : rinvunitor _ • (_ ◃ η₂) • lassociator _ _ _ • (ε₂ ▹ _) • lunitor _ = id₂ _ := pr22 Hl₂. Definition comp_left_adjoint_data : left_adjoint_data (l₁ · l₂) := r₂ · r₁ ,, (ηη ,, εε). Proposition comp_left_adjoint_axioms : left_adjoint_axioms comp_left_adjoint_data. Proof. split ; cbn. - unfold ηη, εε. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite linvunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } refine (_ @ id2_rwhisker _ _). rewrite <- trl₁. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. refine (_ @ id2_right _). rewrite <- lwhisker_id2. rewrite <- trl₂. rewrite <- !lwhisker_vcomp. rewrite <- runitor_triangle. etrans. { do 10 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } etrans. { do 9 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } etrans. { do 8 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. etrans. { do 6 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. apply idpath. } rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite <- !lwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. rewrite lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- rwhisker_lwhisker_rassociator. rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite <- rassociator_rassociator. rewrite !vassocl. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. rewrite <- !lwhisker_vcomp. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_vcomp. rewrite <- linvunitor_assoc. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. etrans. { apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite !lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite !lwhisker_id2. apply idpath. } rewrite id2_right. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite lunitor_lwhisker. apply idpath. - unfold εε, ηη. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite <- rinvunitor_triangle. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } refine (_ @ lwhisker_id2 _ _). rewrite <- trr₁. rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. refine (_ @ id2_right _). rewrite <- id2_rwhisker. rewrite <- trr₂. rewrite <- !rwhisker_vcomp. rewrite <- lunitor_triangle. rewrite !vassocl. etrans. { do 9 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_rwhisker. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. rewrite <- lassociator_lassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !lwhisker_vcomp. apply maponpaths. etrans. { rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lunitor_linvunitor. apply id2_left. } refine (!_). rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. rewrite !vassocr. rewrite lunitor_linvunitor. apply id2_left. Qed. Definition comp_left_adjoint : left_adjoint (l₁ · l₂) := comp_left_adjoint_data ,, comp_left_adjoint_axioms. End CompositionAdjunction. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/ContainsAdjEquiv.v000066400000000000000000000415341451125700300267760ustar00rootroot00000000000000(** Properties of adjoint equivalences In this file, we look at properties of adjoint equivalences Contents: 1. Identity is faithful 2. Identity is fully faithful 3. Identity is conservative 4. Identity is discrete 5. The identity Street fibration 6. The identity Street opfibration 7. Adjoint equivalences are faithful 8. Adjoint equivalences are fully faithful 9. Adjoint equivalences are conservative 10. Adjoint equivalences are discrete 11. Adjoint equivalences are pseudomonic 12. Adjoint equivalences preserve cartesian cells 13. Adjoint equivalences preserve cartesian cells 14. Morphism to identity preserves (op)cartesians *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Local Open Scope cat. (** 1. Identity is faithful *) Definition id1_faithful {B : bicat} (a : B) : faithful_1cell (id₁ a). Proof. intros z g₁ g₂ α₁ α₂ p. use (vcomp_lcancel (runitor _)). { is_iso. } rewrite <- !vcomp_runitor. rewrite p. apply idpath. Qed. (** 2. Identity is fully faithful *) Definition id1_fully_faithful {B : bicat} (a : B) : fully_faithful_1cell (id₁ a). Proof. use make_fully_faithful. - apply id1_faithful. - intros z g₁ g₂ αf. simple refine (_ ,, _). + exact (rinvunitor _ • αf • runitor _). + abstract (cbn ; use (vcomp_rcancel (runitor _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite vcomp_runitor ; rewrite !vassocr ; rewrite runitor_rinvunitor ; rewrite id2_left ; apply idpath). Defined. Definition id1_pseudomonic {B : bicat} (a : B) : pseudomonic_1cell (id₁ a). Proof. use make_pseudomonic. - apply id1_faithful. - intros z g₁ g₂ αf Hαf. simple refine (_ ,, (_ ,, _)). + exact (rinvunitor _ • αf • runitor _). + is_iso. + abstract (cbn ; use (vcomp_rcancel (runitor _)) ; [ is_iso | ] ; rewrite !vassocl ; rewrite vcomp_runitor ; rewrite !vassocr ; rewrite runitor_rinvunitor ; rewrite id2_left ; apply idpath). Defined. (** 3. Identity is conservative *) Definition id1_conservative {B : bicat} (a : B) : conservative_1cell (id₁ a). Proof. intros x g₁ g₂ α Hα. pose ((α ▹ id₁ a) • runitor _). use eq_is_invertible_2cell. - exact (rinvunitor _ • (α ▹ id₁ _) • runitor _). - rewrite !vassocl. rewrite vcomp_runitor. rewrite !vassocr. rewrite !rinvunitor_runitor. apply id2_left. - use is_invertible_2cell_vcomp. + use is_invertible_2cell_vcomp. * apply is_invertible_2cell_rinvunitor. * exact Hα. + apply is_invertible_2cell_runitor. Defined. (** 4. Identity is discrete *) Definition id1_discrete {B : bicat} (a : B) : discrete_1cell (id₁ a). Proof. split. - exact (id1_faithful a). - exact (id1_conservative a). Defined. (** 5. The identity Street fibration *) Section IdentityInternalSFib. Context {B : bicat} (b : B). Local Lemma identity_help {x : B} {f h : x --> b} (δp : h · id₁ b ==> f · id₁ b) : ((rinvunitor h • δp) • runitor f) ▹ id₁ b = δp. Proof. rewrite !vassocl. rewrite <- rwhisker_vcomp. use vcomp_move_R_pM ; [ is_iso | ]. cbn. use (vcomp_rcancel (runitor _)) ; [ is_iso | ]. rewrite !vassocl. rewrite !vcomp_runitor. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- runitor_triangle. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite runitor_rwhisker. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition identity_is_cartesian_2cell_sfib {x : B} {f g : x --> b} (α : f ==> g) : is_cartesian_2cell_sfib (id₁ b) α. Proof. intros h β δp r. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use id1_faithful ; exact (pr12 φ₁ @ !(pr12 φ₂))). - refine (rinvunitor _ • δp • runitor _ ,, _ ,, _). + apply identity_help. + abstract (rewrite !vassocl ; rewrite <- vcomp_runitor ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; rewrite <- vcomp_runitor ; rewrite !vassocr ; apply maponpaths_2 ; exact (!r)). Defined. Definition identity_internal_cleaving : internal_sfib_cleaving (id₁ b). Proof. intros x f g α. refine (f ,, α • runitor _ ,, runitor_invertible_2cell _ ,, _ ,, _) ; cbn. - apply identity_is_cartesian_2cell_sfib. - abstract (rewrite <- vcomp_runitor ; rewrite <- rwhisker_vcomp ; apply maponpaths ; rewrite <- runitor_triangle ; use vcomp_move_L_pM ; [ is_iso | ] ; cbn ; rewrite runitor_rwhisker ; rewrite lunitor_runitor_identity ; apply idpath). Defined. Definition identity_lwhisker_cartesian : lwhisker_is_cartesian (id₁ b). Proof. intros x y h f g γ Hγ. apply identity_is_cartesian_2cell_sfib. Defined. Definition identity_internal_sfib : internal_sfib (id₁ b). Proof. split. - exact identity_internal_cleaving. - exact identity_lwhisker_cartesian. Defined. End IdentityInternalSFib. (** 6. The identity Street opfibration *) Definition identity_is_opcartesian_2cell_sopfib {B : bicat} {b x : B} {f g : x --> b} (α : f ==> g) : is_opcartesian_2cell_sopfib (id₁ b) α. Proof. apply is_cartesian_to_is_opcartesian_sfib. exact (@identity_is_cartesian_2cell_sfib (op2_bicat B) b x g f α). Defined. Definition identity_internal_sopfib {B : bicat} (b : B) : internal_sopfib (id₁ b). Proof. apply internal_sfib_is_internal_sopfib. exact (@identity_internal_sfib (op2_bicat B) b). Defined. (** 7. Adjoint equivalences are faithful *) Definition adj_equiv_faithful {B : bicat} {a b : B} {l : a --> b} (Hl : left_adjoint_equivalence l) : faithful_1cell l. Proof. intros z g₁ g₂ α₁ α₂ p. pose (η := left_adjoint_unit Hl). apply id1_faithful. use (vcomp_rcancel (_ ◃ η)). { is_iso. apply (left_equivalence_unit_iso Hl). } rewrite !vcomp_whisker. apply maponpaths. use (vcomp_lcancel (rassociator _ _ _)). { is_iso. } rewrite <- !rwhisker_rwhisker_alt. rewrite p. apply idpath. Qed. (** 8. Adjoint equivalences are fully faithful *) Section AdjEquivFullyFaithful. Context {B : bicat} {a b : B} {l : a --> b} (Hl : left_adjoint_equivalence l) (r := left_adjoint_right_adjoint Hl) (η := left_equivalence_unit_iso Hl : invertible_2cell _ (l · r)) (ε := left_equivalence_counit_iso Hl : invertible_2cell (r · l) _). Definition adj_equiv_fully_faithful_inv_cell {z : B} {g₁ g₂ : z --> a} (αf : g₁ · l ==> g₂ · l) : g₁ ==> g₂ := rinvunitor _ • (g₁ ◃ η) • lassociator g₁ l r • (αf ▹ r) • rassociator g₂ l r • (g₂ ◃ η^-1) • runitor _. Definition adj_equiv_fully_faithful_inv_cell_is_inv_cell {z : B} {g₁ g₂ : z --> a} (αf : g₁ · l ==> g₂ · l) : adj_equiv_fully_faithful_inv_cell αf ▹ l = αf. Proof. unfold adj_equiv_fully_faithful_inv_cell. cbn -[η r]. rewrite <- !rwhisker_vcomp. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. cbn -[η r]. rewrite !vassocl. rewrite !rwhisker_vcomp. rewrite !vassocr. refine (!(rwhisker_vcomp _ _ _) @ _). use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. cbn. rewrite !vassocl. assert ((rinvunitor g₂ • (g₂ ◃ η) • lassociator g₂ l r) ▹ l • rassociator _ _ _ • rassociator _ _ _ = g₂ ◃ (rinvunitor _ • (l ◃ ε^-1))) as H. { refine (_ @ id2_left _). use vcomp_move_L_Mp ; [ is_iso | ]. cbn -[η r ε]. refine (_ @ lwhisker_id2 _ _). pose (pr112 Hl : linvunitor l • (η ▹ l) • rassociator l r l • (l ◃ ε) • runitor l = id₂ _). cbn -[η ε r] in p. rewrite <- p ; clear p. rewrite <- !lwhisker_vcomp. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. apply id2_left. } rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp, lwhisker_hcomp. rewrite triangle_r_inv. apply idpath. } rewrite !vassocl in H. refine (!_). etrans. { apply maponpaths. exact H. } clear H. assert ((rinvunitor g₁ • (g₁ ◃ η • lassociator g₁ l r)) ▹ l • rassociator (g₁ · l) r l = rinvunitor _ • (_ ◃ ε^-1)) as H. { use vcomp_move_L_Mp ; [ is_iso | ]. refine (_ @ id2_left _). use vcomp_move_L_Mp ; [ is_iso | ]. cbn -[η r ε]. refine (_ @ lwhisker_id2 _ _). pose (pr112 Hl : linvunitor l • (η ▹ l) • rassociator l r l • (l ◃ ε) • runitor _ = id₂ _) as p. cbn -[η ε r] in p. rewrite <- p ; clear p. rewrite <- runitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. } apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp, lwhisker_hcomp. rewrite triangle_r_inv. apply idpath. } refine (!_). etrans. { rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocr in H. exact H. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite left_unit_inv_assoc. apply idpath. Qed. Definition adj_equiv_fully_faithful : fully_faithful_1cell l. Proof. use make_fully_faithful. - exact (adj_equiv_faithful Hl). - intros z g₁ g₂ αf. simple refine (_ ,, _). + exact (adj_equiv_fully_faithful_inv_cell αf). + exact (adj_equiv_fully_faithful_inv_cell_is_inv_cell αf). Defined. End AdjEquivFullyFaithful. (** 9. Adjoint equivalences are conservative *) Definition adj_equiv_conservative {B : bicat} {a b : B} {l : a --> b} (Hl : left_adjoint_equivalence l) : conservative_1cell l. Proof. apply fully_faithful_to_conservative. apply adj_equiv_fully_faithful. exact Hl. Defined. (** 10. Adjoint equivalences are discrete *) Definition adj_equiv_discrete {B : bicat} {a b : B} {l : a --> b} (Hl : left_adjoint_equivalence l) : discrete_1cell l. Proof. apply fully_faithful_is_discrete. apply adj_equiv_fully_faithful. exact Hl. Defined. (** 11. Adjoint equivalences are pseudomonic *) Definition adj_equiv_pseudomonic {B : bicat} {a b : B} {l : a --> b} (Hl : left_adjoint_equivalence l) : pseudomonic_1cell l. Proof. apply fully_faithful_is_pseudomonic. apply adj_equiv_fully_faithful. exact Hl. Defined. (** 12. Adjoint equivalences preserve cartesian cells *) Definition equivalence_preserves_cartesian {B : bicat} {b e₁ e₂ : B} (p₁ : e₁ --> b) (p₂ : e₂ --> b) (L : e₁ --> e₂) (com : invertible_2cell p₁ (L · p₂)) (HL : left_adjoint_equivalence L) (HB_2_0 : is_univalent_2_0 B) (HB_2_1 : is_univalent_2_1 B) : mor_preserves_cartesian p₁ p₂ L. Proof. refine (J_2_0 HB_2_0 (λ (x₁ x₂ : B) (L : adjoint_equivalence x₁ x₂), ∏ (p₁ : x₁ --> b) (p₂ : x₂ --> b) (c : invertible_2cell p₁ (L · p₂)), mor_preserves_cartesian p₁ p₂ L) _ (L ,, HL) p₁ p₂ com). clear e₁ e₂ L HL p₁ p₂ com HB_2_0. cbn ; intros e p₁ p₂ com. pose (c := comp_of_invertible_2cell com (lunitor_invertible_2cell _)). refine (J_2_1 HB_2_1 (λ (x₁ x₂ : B) (f g : x₁ --> x₂) _, mor_preserves_cartesian f g (id₁ _)) _ c). intros. apply id_mor_preserves_cartesian. Defined. (** 13. Adjoint equivalences preserve cartesian cells *) Definition equivalence_preserves_opcartesian {B : bicat} {b e₁ e₂ : B} (p₁ : e₁ --> b) (p₂ : e₂ --> b) (L : e₁ --> e₂) (com : invertible_2cell p₁ (L · p₂)) (HL : left_adjoint_equivalence L) (HB_2_0 : is_univalent_2_0 B) (HB_2_1 : is_univalent_2_1 B) : mor_preserves_opcartesian p₁ p₂ L. Proof. refine (J_2_0 HB_2_0 (λ (x₁ x₂ : B) (L : adjoint_equivalence x₁ x₂), ∏ (p₁ : x₁ --> b) (p₂ : x₂ --> b) (c : invertible_2cell p₁ (L · p₂)), mor_preserves_opcartesian p₁ p₂ L) _ (L ,, HL) p₁ p₂ com). clear e₁ e₂ L HL p₁ p₂ com HB_2_0. cbn ; intros e p₁ p₂ com. pose (c := comp_of_invertible_2cell com (lunitor_invertible_2cell _)). refine (J_2_1 HB_2_1 (λ (x₁ x₂ : B) (f g : x₁ --> x₂) _, mor_preserves_opcartesian f g (id₁ _)) _ c). intros. apply id_mor_preserves_opcartesian. Defined. (** 14. Morphism to identity preserves (op)cartesians *) Definition mor_to_id_preserves_cartesian {B : bicat} {e b : B} (h : e --> b) : mor_preserves_cartesian h (id₁ b) h. Proof. intros x f g γ Hγ. apply identity_is_cartesian_2cell_sfib. Defined. Definition mor_to_id_preserves_opcartesian {B : bicat} {e b : B} (h : e --> b) : mor_preserves_opcartesian h (id₁ b) h. Proof. intros x f g γ Hγ. apply identity_is_opcartesian_2cell_sopfib. Defined. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/EsoProperties.v000066400000000000000000000750221451125700300263710ustar00rootroot00000000000000(***************************************************************************** Properties of eso 1-cells Esos are defined as 1-cells that satisfy a certain lifting property with respect to fully faithful 1-cells. From this definition, we can deduce numerous properties about eso 1-cells. Note: these statements hold not only for esos, but for all classes of 1-cells defined via suitable lifting properties. Contents 1. Identity is eso 2. Adjoint equivalences are eso 3. Esos are closed under invertible 2-cells 4. Esos are closed under composition 5. Eso+ff implies adjoint equivalence 6. Factoring esos via ffs *****************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Eso. Require Import UniMath.Bicategories.Limits.Pullbacks. Local Open Scope cat. (** 1. Identity is eso *) Section IdEso. Context {B : bicat} (HB_2_1 : is_univalent_2_1 B) (b : B). Definition id_is_eso_full_eq_1 {c₁ : B} {l₁ l₂ : b --> c₁} (k₁ : id₁ b · l₁ ==> id₁ b · l₂) : id₁ b ◃ ((linvunitor l₁ • k₁) • lunitor l₂) = k₁. Proof. rewrite <- !lwhisker_vcomp. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. refine (!_). etrans. { rewrite <- vcomp_lunitor. rewrite <- lunitor_triangle. rewrite lunitor_runitor_identity. rewrite rwhisker_hcomp. rewrite <- triangle_r. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. refine (!(id2_left _) @ _). apply maponpaths_2. rewrite <- lunitor_triangle. rewrite lunitor_runitor_identity. rewrite rwhisker_hcomp. rewrite <- triangle_r. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite lunitor_linvunitor. rewrite lwhisker_id2. apply idpath. Qed. Definition id_is_eso_full_eq_2 {c₁ c₂ : B} (m : c₁ --> c₂) {l₁ l₂ : b --> c₁} (k₁ : id₁ b · l₁ ==> id₁ b · l₂) (k₂ : l₁ · m ==> l₂ · m) (p : (k₁ ▹ m) • rassociator (id₁ b) l₂ m = rassociator (id₁ b) l₁ m • (id₁ b ◃ k₂)) : (linvunitor l₁ • k₁ • lunitor l₂) ▹ m = k₂. Proof. rewrite <- !rwhisker_vcomp. assert ((k₁ ▹ m) = rassociator _ _ _ • (id₁ b ◃ k₂) • lassociator _ _ _) as H. { use vcomp_move_L_Mp ; [ is_iso | ]. exact p. } rewrite H. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. rewrite <- lunitor_triangle. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. apply id2_rwhisker. Qed. Definition id_is_eso_full : is_eso_full (id₁ b). Proof. intros c₁ c₂ m Hm l₁ l₂ k₁ k₂ p. simple refine (_ ,, _ ,, _). - exact (linvunitor _ • k₁ • lunitor _). - apply id_is_eso_full_eq_1. - apply id_is_eso_full_eq_2. exact p. Defined. Definition id_is_eso_faithful : is_eso_faithful (id₁ b). Proof. intros c₁ c₂ m Hm l₁ l₂ ζ₁ ζ₂ p₁ p₂. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. rewrite <- !vcomp_lunitor. rewrite p₁. apply idpath. Qed. Definition id_is_eso_essentially_surjective_eq {c₁ c₂ : B} {m : c₁ --> c₂} (g₁ : b --> c₁) (g₂ : b --> c₂) (α : invertible_2cell (g₁ · m) (id₁ b · g₂)) : (lunitor g₁ ▹ m) • α = rassociator (id₁ b) g₁ m • (id₁ b ◃ (α • lunitor g₂)). Proof. rewrite <- !lwhisker_vcomp. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite lunitor_triangle. rewrite <- vcomp_lunitor. apply maponpaths. rewrite <- lunitor_triangle. rewrite lunitor_runitor_identity. rewrite rwhisker_hcomp. rewrite <- triangle_r. rewrite <- lwhisker_hcomp. apply idpath. Qed. Definition id_is_eso_essentially_surjective : is_eso_essentially_surjective (id₁ b). Proof. intros c₁ c₂ m Hm g₁ g₂ α. simple refine (_ ,, _ ,, _ ,, _). - exact g₁. - exact (lunitor_invertible_2cell _). - exact (comp_of_invertible_2cell α (lunitor_invertible_2cell _)). - apply id_is_eso_essentially_surjective_eq. Defined. Definition id_is_eso : is_eso (id₁ b). Proof. use make_is_eso. - exact HB_2_1. - exact id_is_eso_full. - exact id_is_eso_faithful. - exact id_is_eso_essentially_surjective. Defined. End IdEso. (** 2. Adjoint equivalences are eso *) Section AdjequivEso. Context {B : bicat} (HB_2_1 : is_univalent_2_1 B) {b₁ b₂ : B} {l : b₁ --> b₂} (Hl : left_adjoint_equivalence l). Let r : b₂ --> b₁ := left_adjoint_right_adjoint Hl. Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso Hl. Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso Hl. Section AdjEquivEsoFull. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) {f₁ f₂ : b₂ --> c₁} (k₁ : l · f₁ ==> l · f₂) (k₂ : f₁ · m ==> f₂ · m) (p : (k₁ ▹ m) • rassociator l f₂ m = rassociator l f₁ m • (l ◃ k₂)). Definition adj_equiv_is_eso_lift_2 : f₁ ==> f₂ := linvunitor _ • (ε^-1 ▹ _) • rassociator _ _ _ • (_ ◃ k₁) • lassociator _ _ _ • (ε ▹ _) • lunitor _. Definition adj_equiv_is_eso_lift_2_left : l ◃ adj_equiv_is_eso_lift_2 = k₁. Proof. unfold adj_equiv_is_eso_lift_2. rewrite <- !lwhisker_vcomp. rewrite !vassocl. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ] ; cbn -[ε]. refine (!_). rewrite <- vcomp_lunitor. use (vcomp_lcancel (η^-1 ▹ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. assert (lassociator _ _ _ • (η ^-1 ▹ _) • lunitor _ • (_ ◃ linvunitor f₁) • (_ ◃ (ε ^-1 ▹ _)) • (_ ◃ rassociator _ _ _) = id2 _) as p'. { rewrite !vassocl. do 2 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn -[η ε]. rewrite !vassocr. do 2 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn -[η ε]. rewrite id2_right. rewrite <- lunitor_triangle. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. apply id2_left. } rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !rwhisker_vcomp. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[η ε]. refine (!(id2_left _) @ _). use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocr. exact (!(internal_triangle1 Hl)). } rewrite !vassocr. rewrite p'. rewrite id2_left. rewrite !vassocl. apply maponpaths. rewrite <- lunitor_triangle. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite !rwhisker_vcomp. apply maponpaths. do 2 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn -[η ε]. refine (!(id2_right _) @ _). use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocr. refine (!_). exact (internal_triangle1 Hl). Qed. Definition adj_equiv_is_eso_lift_2_right : adj_equiv_is_eso_lift_2 ▹ m = k₂. Proof. unfold adj_equiv_is_eso_lift_2. rewrite <- !rwhisker_vcomp. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn -[ε]. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_lwhisker. assert (k₁ ▹ m = rassociator _ _ _ • (_ ◃ k₂) • lassociator _ _ _) as p'. { use vcomp_move_L_Mp ; [ is_iso | ]. exact p. } rewrite p' ; clear p'. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lunitor_triangle. apply idpath. } do 2 (use vcomp_move_L_pM ; [ is_iso | ]). cbn -[ε]. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite vcomp_lunitor. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. End AdjEquivEsoFull. Definition adj_equiv_is_eso_full : is_eso_full l. Proof. intros c₁ c₂ m Hm f₁ f₂ k₁ k₂ p. simple refine (_ ,, _ ,, _). - apply adj_equiv_is_eso_lift_2. exact k₁. - exact (adj_equiv_is_eso_lift_2_left k₁). - apply adj_equiv_is_eso_lift_2_right. exact p. Defined. Definition adj_equiv_is_eso_faithful : is_eso_faithful l. Proof. intros c₁ c₂ m Hm f₁ f₂ ζ₁ ζ₂ p₁ p₂. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. rewrite <- !vcomp_lunitor. use (vcomp_lcancel (ε ▹ _)). { is_iso. apply property_from_invertible_2cell. } rewrite !vassocr. apply maponpaths_2. rewrite !vcomp_whisker. apply maponpaths_2. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !lwhisker_lwhisker. apply maponpaths_2. rewrite p₁. apply idpath. Qed. Section AdjEquivEssentiallySurjective. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) (g₁ : b₁ --> c₁) (g₂ : b₂ --> c₂) (α : invertible_2cell (g₁ · m) (l · g₂)). Definition adj_equiv_is_eso_essentially_surjective_lift_1 : b₂ --> c₁ := r · g₁. Definition adj_equiv_is_eso_essentially_surjective_lift_1_left : invertible_2cell (l · adj_equiv_is_eso_essentially_surjective_lift_1) g₁ := comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell η)) (lunitor_invertible_2cell _)). Definition adj_equiv_is_eso_essentially_surjective_lift_1_right : invertible_2cell (adj_equiv_is_eso_essentially_surjective_lift_1 · m) g₂ := comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ α) (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ ε) (lunitor_invertible_2cell _)))). Definition adj_equiv_is_eso_essentially_surjective_eq : (adj_equiv_is_eso_essentially_surjective_lift_1_left ▹ m) • α = rassociator _ _ _ • (l ◃ adj_equiv_is_eso_essentially_surjective_lift_1_right). Proof. cbn -[ε η]. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[ε η]. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. apply rassociator_rassociator. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn -[ε η]. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite rwhisker_rwhisker. refine (!_). etrans. { rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. rewrite <- vcomp_lunitor. apply idpath. } rewrite !vassocl. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { rewrite !vassocr. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_hcomp. rewrite triangle_l. rewrite <- rwhisker_hcomp. apply idpath. } rewrite <- lunitor_triangle. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !rwhisker_vcomp. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[η ε]. refine (_ @ id2_right _). use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[η ε]. rewrite !vassocr. exact (internal_triangle1 Hl). Qed. End AdjEquivEssentiallySurjective. Definition adj_equiv_is_eso_essentially_surjective : is_eso_essentially_surjective l. Proof. intros c₁ c₂ m Hm g₁ g₂ α. simple refine (_ ,, _ ,, _ ,, _). - exact (adj_equiv_is_eso_essentially_surjective_lift_1 g₁). - exact (adj_equiv_is_eso_essentially_surjective_lift_1_left g₁). - exact (adj_equiv_is_eso_essentially_surjective_lift_1_right _ _ α). - exact (adj_equiv_is_eso_essentially_surjective_eq _ _ α). Defined. Definition adj_equiv_is_eso : is_eso l. Proof. use make_is_eso. - exact HB_2_1. - exact adj_equiv_is_eso_full. - exact adj_equiv_is_eso_faithful. - exact adj_equiv_is_eso_essentially_surjective. Defined. End AdjequivEso. (** 3. Esos are closed under invertible 2-cells *) Section EsoClosedUnderInvertible. Context {B : bicat} (HB_2_1 : is_univalent_2_1 B) {b₁ b₂ : B} {e₁ e₂ : b₁ --> b₂} (He : is_eso e₁) (α : e₁ ==> e₂) (Hα : is_invertible_2cell α). Definition invertible_is_eso_full : is_eso_full e₂. Proof. intros c₁ c₂ m Hm l₁ l₂ k₁ k₂ p. simple refine (_ ,, _ ,, _). - simple refine (is_eso_lift_2 _ He Hm l₁ l₂ _ k₂ _). + exact ((α ▹ l₁) • k₁ • (Hα^-1 ▹ l₂)). + abstract (rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite !vassocl ; rewrite p ; rewrite <- vcomp_whisker ; rewrite !vassocr ; apply maponpaths_2 ; rewrite rwhisker_rwhisker_alt ; apply idpath). - abstract (cbn ; use (vcomp_lcancel (α ▹ _)) ; [ is_iso | ] ; rewrite vcomp_whisker ; rewrite is_eso_lift_2_left ; rewrite !vassocl ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_right ; apply idpath). - apply is_eso_lift_2_right. Defined. Definition invertible_is_eso_faithful : is_eso_faithful e₂. Proof. intros c₁ c₂ m Hm l₁ l₂ ζ₁ ζ₂ p₁ p₂. refine (is_eso_lift_eq _ He Hm _ _ _ p₂). use (vcomp_rcancel (α ▹ _)) ; [ is_iso | ]. rewrite <- !vcomp_whisker. rewrite p₁. apply idpath. Qed. Definition invertible_is_eso_essentially_surjective : is_eso_essentially_surjective e₂. Proof. intros c₁ c₂ m Hm g₁ g₂ γ. pose (αinv := make_invertible_2cell Hα). pose (γhelp := comp_of_invertible_2cell γ (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell αinv))). simple refine (_ ,, _ ,, _ ,, _). - exact (is_eso_lift_1 _ He Hm g₁ g₂ γhelp). - exact (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell αinv)) (is_eso_lift_1_comm_left _ He Hm g₁ g₂ γhelp)). - exact (is_eso_lift_1_comm_right _ He Hm g₁ g₂ γhelp). - abstract (cbn -[is_eso_lift_1_comm_left is_eso_lift_1_comm_right] ; pose (is_eso_lift_1_eq _ He Hm g₁ g₂ γhelp) as p ; cbn -[is_eso_lift_1_comm_left is_eso_lift_1_comm_right] in p ; use (vcomp_rcancel (Hα^-1 ▹ _)) ; [ is_iso | ] ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; rewrite p ; rewrite !vassocr ; rewrite rwhisker_rwhisker_alt ; rewrite !vassocl ; rewrite vcomp_whisker ; apply idpath). Defined. Definition invertible_is_eso : is_eso e₂. Proof. use make_is_eso. - exact HB_2_1. - exact invertible_is_eso_full. - exact invertible_is_eso_faithful. - exact invertible_is_eso_essentially_surjective. Defined. End EsoClosedUnderInvertible. (** 4. Esos are closed under composition *) Section EsoClosedUnderComposition. Context {B : bicat} (HB_2_1 : is_univalent_2_1 B) {b₁ b₂ b₃ : B} {e₁ : b₁ --> b₂} (He₁ : is_eso e₁) {e₂ : b₂ --> b₃} (He₂ : is_eso e₂). Section CompositionFull. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) (l₁ l₂ : b₃ --> c₁) (k₁ : e₁ · e₂ · l₁ ==> e₁ · e₂ · l₂) (k₂ : l₁ · m ==> l₂ · m) (p : (k₁ ▹ m) • rassociator (e₁ · e₂) l₂ m = rassociator (e₁ · e₂) l₁ m • (e₁ · e₂ ◃ k₂)). Local Lemma composition_is_eso_full_lift_path_1 : ((lassociator _ _ _ • k₁ • rassociator _ _ _) ▹ m) • rassociator _ _ _ = rassociator _ _ _ • (e₁ ◃ (rassociator _ _ _ • (e₂ ◃ k₂) • lassociator _ _ _)). Proof. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite p. rewrite !vassocl. apply idpath. } rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. Qed. Definition composition_is_eso_full_lift_1 : e₂ · l₁ ==> e₂ · l₂ := is_eso_lift_2 _ He₁ Hm (e₂ · l₁) (e₂ · l₂) (lassociator _ _ _ • k₁ • rassociator _ _ _) (rassociator _ _ _ • (e₂ ◃ k₂) • lassociator _ _ _) composition_is_eso_full_lift_path_1. Let ℓ := composition_is_eso_full_lift_1. Local Lemma composition_is_eso_full_lift_path_2 : (ℓ ▹ m) • rassociator _ _ _ = rassociator _ _ _ • (e₂ ◃ k₂). Proof. unfold ℓ, composition_is_eso_full_lift_1. rewrite is_eso_lift_2_right. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. apply idpath. Qed. Definition composition_is_eso_full_lift : l₁ ==> l₂ := is_eso_lift_2 _ He₂ Hm l₁ l₂ ℓ k₂ composition_is_eso_full_lift_path_2. Definition composition_is_eso_full_lift_left : e₁ · e₂ ◃ composition_is_eso_full_lift = k₁. Proof. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- lwhisker_lwhisker. etrans. { apply maponpaths_2. apply maponpaths. apply is_eso_lift_2_left. } etrans. { apply maponpaths_2. apply is_eso_lift_2_left. } rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. apply idpath. Qed. Definition composition_is_eso_full_lift_right : composition_is_eso_full_lift ▹ m = k₂. Proof. apply is_eso_lift_2_right. Qed. End CompositionFull. Definition composition_is_eso_full : is_eso_full (e₁ · e₂). Proof. intros c₁ c₂ m Hm l₁ l₂ k₁ k₂ p. simple refine (_ ,, _ ,, _). - exact (composition_is_eso_full_lift Hm _ _ _ _ p). - exact (composition_is_eso_full_lift_left Hm _ _ _ _ p). - exact (composition_is_eso_full_lift_right Hm _ _ _ _ p). Defined. Definition composition_is_eso_faithful : is_eso_faithful (e₁ · e₂). Proof. intros c₁ c₂ m Hm l₁ l₂ ζ₁ ζ₂ p₁ p₂. use (is_eso_lift_eq _ He₂ Hm _ _ _ p₂). use (is_eso_lift_eq _ He₁ Hm _ _ _). - use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !lwhisker_lwhisker. rewrite p₁. apply idpath. - use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !rwhisker_lwhisker. rewrite p₂. apply idpath. Qed. Section CompositionEssentiallySurjective. Context {c₁ c₂ : B} {m : c₁ --> c₂} (Hm : fully_faithful_1cell m) (g₁ : b₁ --> c₁) (g₂ : b₃ --> c₂) (α : invertible_2cell (g₁ · m) (e₁ · e₂ · g₂)). Let γ : invertible_2cell (g₁ · m) (e₁ · (e₂ · g₂)) := comp_of_invertible_2cell α (rassociator_invertible_2cell _ _ _). Let ℓ : b₂ --> c₁ := is_eso_lift_1 _ He₁ Hm g₁ (e₂ · g₂) γ. Let γ' : invertible_2cell (ℓ · m) (e₂ · g₂) := is_eso_lift_1_comm_right _ He₁ Hm g₁ (e₂ · g₂) γ. Definition composition_is_eso_lift_1 : b₃ --> c₁ := is_eso_lift_1 _ He₂ Hm ℓ g₂ γ'. Definition composition_is_eso_lift_1_left : invertible_2cell (e₁ · e₂ · composition_is_eso_lift_1) g₁ := comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (is_eso_lift_1_comm_left _ _ _ _ _ _)) (is_eso_lift_1_comm_left _ _ _ _ _ _)). Definition composition_is_eso_lift_1_right : invertible_2cell (composition_is_eso_lift_1 · m) g₂ := is_eso_lift_1_comm_right _ _ _ _ _ _. Definition composition_is_eso_lift_1_eq : (composition_is_eso_lift_1_left ▹ m) • α = rassociator _ _ _ • (e₁ · e₂ ◃ composition_is_eso_lift_1_right). Proof. cbn -[is_eso_lift_1_comm_left is_eso_lift_1_comm_right]. pose (is_eso_lift_1_eq _ He₂ Hm ℓ g₂ γ') as p1. pose (is_eso_lift_1_eq _ He₁ Hm g₁ (e₂ · g₂) γ) as p2. cbn -[is_eso_lift_1_comm_left is_eso_lift_1_comm_right] in p1, p2. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. assert (e₂ ◃ is_eso_lift_1_comm_right e₂ He₂ Hm ℓ g₂ γ' = lassociator _ _ _ • (is_eso_lift_1_comm_left e₂ He₂ Hm ℓ g₂ γ' ▹ m) • γ') as p1'. { rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (!p1). } refine (!_). etrans. { do 3 apply maponpaths. exact p1'. } clear p1 p1'. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite <- rassociator_rassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } refine (!_). etrans. { apply maponpaths. exact p2. } clear p2. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. apply idpath. Qed. End CompositionEssentiallySurjective. Definition composition_is_eso_essentially_surjective : is_eso_essentially_surjective (e₁ · e₂). Proof. intros c₁ c₂ m Hm g₁ g₂ α. simple refine (_ ,, _ ,, _ ,, _). - exact (composition_is_eso_lift_1 Hm _ _ α). - exact (composition_is_eso_lift_1_left Hm _ _ α). - exact (composition_is_eso_lift_1_right Hm _ _ α). - exact (composition_is_eso_lift_1_eq Hm _ _ α). Defined. Definition composition_is_eso : is_eso (e₁ · e₂). Proof. use make_is_eso. - exact HB_2_1. - exact composition_is_eso_full. - exact composition_is_eso_faithful. - exact composition_is_eso_essentially_surjective. Defined. End EsoClosedUnderComposition. (** 5. Eso+ff implies adjoint equivalence *) Section EsoAndFF. Context {B : bicat} {b₁ b₂ : B} {e : b₁ --> b₂} (He₁ : is_eso e) (He₂ : fully_faithful_1cell e). Let α : invertible_2cell (id₁ b₁ · e) (e · id₁ b₂) := comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _). Definition eso_ff_is_equiv : left_equivalence e. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (is_eso_lift_1 _ He₁ He₂ (id₁ _) (id₁ _) α). - exact (inv_of_invertible_2cell (is_eso_lift_1_comm_left _ He₁ He₂ (id₁ _) (id₁ _) α)). - exact ((is_eso_lift_1_comm_right _ He₁ He₂ (id₁ _) (id₁ _) α)). - apply property_from_invertible_2cell. - apply property_from_invertible_2cell. Defined. Definition eso_ff_is_adj_equiv : left_adjoint_equivalence e. Proof. use equiv_to_adjequiv. exact eso_ff_is_equiv. Defined. End EsoAndFF. (** 6. Factoring esos via ffs *) (** If we can factor an eso e x₁ -----------> x₂ as x₁ ---> x₂ ---> x₃ f m where m is ff, then m is an equivalence Note: this property only holds for esos and it doesn't generalize to arbitrary classes of morphisms defined via lifting properties. *) Section FactorEso. Context {B : bicat} {x₁ x₂ x₃ : B} {e : x₁ --> x₃} (He : is_eso e) {f : x₁ --> x₂} {m : x₂ --> x₃} (Hm: fully_faithful_1cell m) (γ : invertible_2cell (f · m) e). Let γ' : invertible_2cell (f · m) (e · id₁ x₃) := comp_of_invertible_2cell γ (rinvunitor_invertible_2cell _). Let inv : x₃ --> x₂ := is_eso_lift_1 _ He Hm f (id₁ _) γ'. Let ε : invertible_2cell (inv · m) (id₁ x₃) := is_eso_lift_1_comm_right _ He Hm f (id₁ _) γ'. Definition factor_eso_ff_equiv : left_equivalence m. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact inv. - use (fully_faithful_1cell_inv_map Hm). exact (lunitor _ • rinvunitor _ • (m ◃ ε^-1) • lassociator _ _ _). - exact ε. - apply (fully_faithful_to_conservative Hm). use (eq_is_invertible_2cell (!(fully_faithful_1cell_inv_map_eq Hm _))). cbn -[ε]. is_iso. - apply property_from_invertible_2cell. Defined. Definition factor_eso_ff_adj_equiv : left_adjoint_equivalence m. Proof. use equiv_to_adjequiv. exact factor_eso_ff_equiv. Defined. End FactorEso. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/FromInitial.v000066400000000000000000000212121451125700300257730ustar00rootroot00000000000000(****************************************************************** Morphism from biinitial objects If a bicategory has a strict biinitial object, then we can deduce a number of intersting properties of 1-cells from the biinitial object to any other object. Contents 1. Faithfulness 2. Fully faithfulness 3. Pseudomonic 4. Conservativity 4. Discreteness 5. It's an internal Street fibration 6. Preservation of cartesian cells 7. It's an internal Street opfibration 8. Preservation of opcartesian cells ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Colimits.Initial. Local Open Scope cat. Section FromInitial. Context {B : bicat} {x y : B} (Hx : is_biinitial x) (Sx : biinitial_is_strict_biinitial_obj Hx) (f : x --> y). (** 1. Faithfulness *) Definition from_biinitial_faithful_1cell : faithful_1cell f. Proof. intros z g₁ g₂ α₁ α₂ p. enough (Hz : is_biinitial z). { apply (is_biinitial_eq_property Hz). } exact (equiv_to_biinitial Hx (Sx z g₁)). Defined. (** 2. Fully faithfulness *) Definition from_biinitial_fully_faithful_1cell : fully_faithful_1cell f. Proof. use make_fully_faithful. - exact from_biinitial_faithful_1cell. - intros z g₁ g₂ αf. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g₁)). } simple refine (_ ,, _). + apply (is_biinitial_2cell_property Hz). + apply (is_biinitial_eq_property Hz). Defined. (** 3. Pseudomonic *) Definition from_biinitial_pseudomonic_1cell : pseudomonic_1cell f. Proof. use make_pseudomonic. - exact from_biinitial_faithful_1cell. - intros z g₁ g₂ αf Hαf. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g₁)). } simple refine (_ ,, _ ,, _). + apply (is_biinitial_2cell_property Hz). + use make_is_invertible_2cell. * apply (is_biinitial_2cell_property Hz). * apply (is_biinitial_eq_property Hz). * apply (is_biinitial_eq_property Hz). + apply (is_biinitial_eq_property Hz). Defined. (** 4. Conservativity *) Definition from_biinitial_conservative_1cell : conservative_1cell f. Proof. intros z g₁ g₂ α Hα. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g₁)). } use make_is_invertible_2cell. - apply (is_biinitial_2cell_property Hz). - apply (is_biinitial_eq_property Hz). - apply (is_biinitial_eq_property Hz). Defined. (** 5. Discreteness *) Definition from_biinitial_discrete_1cell : discrete_1cell f. Proof. split. - exact from_biinitial_faithful_1cell. - exact from_biinitial_conservative_1cell. Defined. (** 6. It's an internal Street fibration *) Definition from_biinitial_is_cartesian_2cell_sfib {z : B} {g₁ g₂ : z --> x} (α : g₁ ==> g₂) : is_cartesian_2cell_sfib f α. Proof. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g₁)). } intros w γ δp p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply (is_biinitial_eq_property Hz)). - simple refine (_ ,, _ ,, _). + apply (is_biinitial_2cell_property Hz). + apply (is_biinitial_eq_property Hz). + apply (is_biinitial_eq_property Hz). Defined. Definition from_biinitial_internal_sfib_cleaving : internal_sfib_cleaving f. Proof. intros z g h α. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z h)). } simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact h. - apply id2. - use make_invertible_2cell. + apply (is_biinitial_2cell_property Hz). + use make_is_invertible_2cell. * apply (is_biinitial_2cell_property Hz). * apply (is_biinitial_eq_property Hz). * apply (is_biinitial_eq_property Hz). - apply id_is_cartesian_2cell_sfib. - apply (is_biinitial_eq_property Hz). Defined. Definition from_biinitial_lwhisker_is_cartesian : lwhisker_is_cartesian f. Proof. intro ; intros. apply from_biinitial_is_cartesian_2cell_sfib. Defined. Definition from_biinitial_internal_sfib : internal_sfib f. Proof. split. - exact from_biinitial_internal_sfib_cleaving. - exact from_biinitial_lwhisker_is_cartesian. Defined. (** 7. Preservation of cartesian cells *) Definition from_biinitial_mor_preserves_cartesian {x' y' : B} (f' : x' --> y') : mor_preserves_cartesian f f' (is_biinitial_1cell_property Hx x'). Proof. intros z h₁ h₂ γ Hγ. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z h₁)). } intros w ζ δp p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply (is_biinitial_eq_property Hz)). - simple refine (_ ,, _ ,, _). + apply (is_biinitial_2cell_property Hz). + apply (is_biinitial_eq_property Hz). + apply (is_biinitial_eq_property Hz). Defined. (** 8. It's an internal Street opfibration *) Definition from_biinitial_is_opcartesian_2cell_sopfib {z : B} {g₁ g₂ : z --> x} (α : g₁ ==> g₂) : is_opcartesian_2cell_sopfib f α. Proof. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g₁)). } intros w γ δp p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply (is_biinitial_eq_property Hz)). - simple refine (_ ,, _ ,, _). + apply (is_biinitial_2cell_property Hz). + apply (is_biinitial_eq_property Hz). + apply (is_biinitial_eq_property Hz). Defined. Definition from_biinitial_internal_sopfib_cleaving : internal_sopfib_opcleaving f. Proof. intros z g h α. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z g)). } simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact g. - apply id2. - use make_invertible_2cell. + apply (is_biinitial_2cell_property Hz). + use make_is_invertible_2cell. * apply (is_biinitial_2cell_property Hz). * apply (is_biinitial_eq_property Hz). * apply (is_biinitial_eq_property Hz). - apply id_is_opcartesian_2cell_sopfib. - apply (is_biinitial_eq_property Hz). Defined. Definition from_biinitial_lwhisker_is_opcartesian : lwhisker_is_opcartesian f. Proof. intro ; intros. apply from_biinitial_is_opcartesian_2cell_sopfib. Defined. Definition from_biinitial_internal_sopfib : internal_sopfib f. Proof. split. - exact from_biinitial_internal_sopfib_cleaving. - exact from_biinitial_lwhisker_is_opcartesian. Defined. (** 9. Preservation of opcartesian cells *) Definition from_biinitial_mor_preserves_opcartesian {x' y' : B} (f' : x' --> y') : mor_preserves_opcartesian f f' (is_biinitial_1cell_property Hx x'). Proof. intros z h₁ h₂ γ Hγ. assert(Hz : is_biinitial z). { exact (equiv_to_biinitial Hx (Sx z h₁)). } intros w ζ δp p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; apply (is_biinitial_eq_property Hz)). - simple refine (_ ,, _ ,, _). + apply (is_biinitial_2cell_property Hz). + apply (is_biinitial_eq_property Hz). + apply (is_biinitial_eq_property Hz). Defined. End FromInitial. UniMath-20231010/UniMath/Bicategories/Morphisms/Properties/Projections.v000066400000000000000000000356451451125700300260740ustar00rootroot00000000000000(** Properties of projection functions Contents: 1. First projection is a Street fibration 2. First projection is a Street opfibration *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Limits.Products. Import Products.Notations. Local Open Scope cat. (** 1. First projection is a Street fibration *) Section ProjectionSFib. Context {B : bicat_with_binprod} (b₁ b₂ : B). Section InvertibleToCartesian. Context {a : B} {f g : a --> b₁ ⊗ b₂} (α : f ==> g) (Hα : is_invertible_2cell (α ▹ π₂)). Definition invertible_to_cartesian_unique (h : a --> b₁ ⊗ b₂) (β : h ==> g) (δp : h · π₁ ==> f · π₁) (q : β ▹ π₁ = δp • (α ▹ π₁)) : isaprop (∑ (δ : h ==> f), δ ▹ π₁ = δp × δ • α = β). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - exact (pr12 φ₁ @ !(pr12 φ₂)). - use (vcomp_rcancel _ Hα). rewrite !rwhisker_vcomp. apply maponpaths. exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Definition invertible_to_cartesian : is_cartesian_2cell_sfib π₁ α. Proof. intros h β δp q. use iscontraprop1. - exact (invertible_to_cartesian_unique h β δp q). - simple refine (_ ,, _ ,, _). + use binprod_ump_2cell. * apply (pr2 B). * exact δp. * exact (β ▹ _ • Hα^-1). + apply binprod_ump_2cell_pr1. + use binprod_ump_2cell_unique_alt. * apply (pr2 B). * abstract (rewrite <- !rwhisker_vcomp ; rewrite binprod_ump_2cell_pr1 ; exact (!q)). * abstract (rewrite <- !rwhisker_vcomp ; rewrite binprod_ump_2cell_pr2 ; rewrite !vassocl ; refine (_ @ id2_right _) ; rewrite vcomp_linv ; apply idpath). Defined. End InvertibleToCartesian. Section CartesianToInvertible. Context {a : B} {f g : a --> b₁ ⊗ b₂} (α : f ==> g) (Hα : is_cartesian_2cell_sfib π₁ α). Let h : a --> b₁ ⊗ b₂ := ⟨ f · π₁, g · π₂ ⟩. Let δ : h ==> g := binprod_ump_2cell (pr2 (pr2 B _ _)) (binprod_ump_1cell_pr1 _ _ _ _ • (α ▹ _)) (binprod_ump_1cell_pr2 _ _ _ _). Let hπ₁ : h · π₁ ==> f · π₁ := binprod_ump_1cell_pr1 _ _ _ _. Local Lemma cartesian_to_invertible_eq : δ ▹ π₁ = hπ₁ • (α ▹ π₁). Proof. apply binprod_ump_2cell_pr1. Qed. Let lift : ∃! δ0 : h ==> f, δ0 ▹ π₁ = hπ₁ × δ0 • α = δ := Hα h δ hπ₁ cartesian_to_invertible_eq. Let lift_map : h ==> f := pr11 lift. Let inv : g · π₂ ==> f · π₂ := (binprod_ump_1cell_pr2 _ _ _ _)^-1 • (lift_map ▹ π₂). Let ζ : f ==> f := binprod_ump_2cell (pr2 (pr2 B _ _)) (id2 _) ((α ▹ π₂) • inv). Local Lemma cartesian_to_invertible_map_inv_help : ζ = id₂ f. Proof. refine (maponpaths (λ z, pr1 z) (proofirrelevance _ (isapropifcontr (Hα f α (id2 _) (!(id2_left _)))) (ζ ,, _ ,, _) (id₂ _ ,, _ ,, _))). - apply binprod_ump_2cell_pr1. - use binprod_ump_2cell_unique_alt. + apply (pr2 B). + rewrite <- rwhisker_vcomp. unfold ζ. rewrite binprod_ump_2cell_pr1. apply id2_left. + unfold ζ, inv. rewrite <- rwhisker_vcomp. rewrite binprod_ump_2cell_pr2. rewrite !vassocl. rewrite rwhisker_vcomp. etrans. { do 3 apply maponpaths. apply (pr221 lift). } unfold δ. rewrite binprod_ump_2cell_pr2. rewrite vcomp_linv. apply id2_right. - apply id2_rwhisker. - apply id2_left. Qed. Local Lemma cartesian_to_invertible_map_inv : (α ▹ π₂) • inv = id₂ (f · π₂). Proof. refine (_ @ maponpaths (λ z, z ▹ π₂) cartesian_to_invertible_map_inv_help @ _). - unfold ζ. refine (!_). apply binprod_ump_2cell_pr2. - apply id2_rwhisker. Qed. Local Lemma cartesian_to_invertible_inv_map : inv • (α ▹ π₂) = id₂ (g · π₂). Proof. unfold inv. rewrite !vassocl. rewrite rwhisker_vcomp. etrans. { do 2 apply maponpaths. exact (pr221 lift). } unfold δ. etrans. { apply maponpaths. apply binprod_ump_2cell_pr2. } apply vcomp_linv. Qed. Definition cartesian_to_invertible : is_invertible_2cell (α ▹ π₂). Proof. unfold is_cartesian_2cell_sfib in Hα. use make_is_invertible_2cell. - exact inv. - exact cartesian_to_invertible_map_inv. - exact cartesian_to_invertible_inv_map. Defined. End CartesianToInvertible. Definition pr1_internal_cleaving : internal_sfib_cleaving (π₁ : b₁ ⊗ b₂ --> b₁). Proof. intros a f g α. simple refine (⟨ f , g · π₂ ⟩ ,, ⟪ α , id2 _ ⟫ • prod_1cell_eta _ g ,, prod_1cell_pr1 _ f _ ,, _ ,, _) ; simpl. - apply invertible_to_cartesian. rewrite <- rwhisker_vcomp. use is_invertible_2cell_vcomp. + rewrite prod_2cell_pr2. is_iso. apply prod_1cell_pr2. + is_iso. apply prod_1cell_eta. - abstract (unfold prod_1cell_eta_map ; rewrite <- !rwhisker_vcomp ; etrans ; [ apply maponpaths ; apply binprod_ump_2cell_pr1 | ] ; rewrite prod_2cell_pr1 ; rewrite !vassocl ; rewrite vcomp_linv ; rewrite id2_right ; apply idpath). Defined. Definition pr1_lwhisker_is_cartesian : lwhisker_is_cartesian (π₁ : b₁ ⊗ b₂ --> b₁). Proof. intros x y h f g γ Hγ. apply invertible_to_cartesian. pose (cartesian_to_invertible _ Hγ) as i. use make_is_invertible_2cell. - exact (rassociator _ _ _ • (h ◃ i^-1) • lassociator _ _ _). - rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. refine (_ @ rassociator_lassociator _ _ _). rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. - rewrite !vassocl. rewrite <- rwhisker_lwhisker. rewrite !vassocr. refine (_ @ rassociator_lassociator _ _ _). apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. Qed. Definition pr1_internal_sfib : internal_sfib (π₁ : b₁ ⊗ b₂ --> b₁). Proof. split. - exact pr1_internal_cleaving. - exact pr1_lwhisker_is_cartesian. Defined. End ProjectionSFib. (** 2. First projection is a Street opfibration *) Section ProjectionSOpFib. Context {B : bicat_with_binprod} (b₁ b₂ : B). Section InvertibleToOpCartesian. Context {a : B} {f g : a --> b₁ ⊗ b₂} (α : f ==> g) (Hα : is_invertible_2cell (α ▹ π₂)). Definition invertible_to_opcartesian_unique (h : a --> b₁ ⊗ b₂) (β : f ==> h) (δp : g · π₁ ==> h · π₁) (q : β ▹ π₁ = (α ▹ π₁) • δp) : isaprop (∑ (δ : g ==> h), δ ▹ π₁ = δp × α • δ = β). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ]. use binprod_ump_2cell_unique_alt. - apply (pr2 B). - exact (pr12 φ₁ @ !(pr12 φ₂)). - use (vcomp_lcancel _ Hα). rewrite !rwhisker_vcomp. apply maponpaths. exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Definition invertible_to_opcartesian : is_opcartesian_2cell_sopfib π₁ α. Proof. intros h β δp q. use iscontraprop1. - exact (invertible_to_opcartesian_unique h β δp q). - simple refine (_ ,, _ ,, _). + use binprod_ump_2cell. * apply (pr2 B). * exact δp. * exact (Hα^-1 • (β ▹ _)). + apply binprod_ump_2cell_pr1. + use binprod_ump_2cell_unique_alt. * apply (pr2 B). * abstract (rewrite <- !rwhisker_vcomp ; rewrite binprod_ump_2cell_pr1 ; exact (!q)). * abstract (rewrite <- !rwhisker_vcomp ; rewrite binprod_ump_2cell_pr2 ; rewrite !vassocr ; refine (_ @ id2_left _) ; rewrite vcomp_rinv ; apply idpath). Defined. End InvertibleToOpCartesian. Section OpCartesianToInvertible. Context {a : B} {f g : a --> b₁ ⊗ b₂} (α : f ==> g) (Hα : is_opcartesian_2cell_sopfib π₁ α). Let h : a --> b₁ ⊗ b₂ := ⟨ g · π₁, f · π₂ ⟩. Let δ : f ==> h := binprod_ump_2cell (pr2 (pr2 B _ _)) (α ▹ _ • (binprod_ump_1cell_pr1 _ _ (g · π₁) (f · π₂))^-1) ((binprod_ump_1cell_pr2 _ _ (g · π₁) (f · π₂))^-1). Let hπ₁ : g · π₁ ==> h · π₁ := (binprod_ump_1cell_pr1 _ _ (g · π₁) (f · π₂))^-1. Local Lemma opcartesian_to_invertible_eq : δ ▹ π₁ = (α ▹ π₁) • hπ₁. Proof. apply binprod_ump_2cell_pr1. Qed. Let lift : ∃! (δ0 : g ==> h), δ0 ▹ π₁ = hπ₁ × α • δ0 = δ := Hα h δ hπ₁ opcartesian_to_invertible_eq. Let lift_map : g ==> h := pr11 lift. Let inv : g · π₂ ==> f · π₂ := lift_map ▹ π₂ • binprod_ump_1cell_pr2 _ _ _ _. Let ζ : g ==> g := binprod_ump_2cell (pr2 (pr2 B _ _)) (id2 _) (inv • (α ▹ π₂)). Local Lemma opcartesian_to_invertible_map_inv_help : ζ = id₂ g. Proof. refine (maponpaths (λ z, pr1 z) (proofirrelevance _ (isapropifcontr (Hα g α (id2 _) (!(id2_right _)))) (ζ ,, _ ,, _) (id₂ _ ,, _ ,, _))). - apply binprod_ump_2cell_pr1. - use binprod_ump_2cell_unique_alt. + apply (pr2 B). + rewrite <- rwhisker_vcomp. unfold ζ. rewrite binprod_ump_2cell_pr1. apply id2_right. + unfold ζ, inv. rewrite <- rwhisker_vcomp. rewrite binprod_ump_2cell_pr2. rewrite !vassocr. rewrite rwhisker_vcomp. etrans. { do 2 apply maponpaths_2. apply maponpaths. exact (pr221 lift). } unfold δ. etrans. { do 2 apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite vcomp_linv. apply id2_left. - apply id2_rwhisker. - apply id2_right. Qed. Local Lemma opcartesian_to_invertible_map_inv : (α ▹ π₂) • inv = id₂ (f · π₂). Proof. unfold inv. rewrite !vassocr. rewrite rwhisker_vcomp. etrans. { apply maponpaths_2. apply maponpaths. exact (pr221 lift). } unfold δ. etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } apply vcomp_linv. Qed. Local Lemma opcartesian_to_invertible_inv_map : inv • (α ▹ π₂) = id₂ (g · π₂). Proof. refine (_ @ maponpaths (λ z, z ▹ π₂) opcartesian_to_invertible_map_inv_help @ _). - unfold ζ. refine (!_). apply binprod_ump_2cell_pr2. - apply id2_rwhisker. Qed. Definition opcartesian_to_invertible : is_invertible_2cell (α ▹ π₂). Proof. unfold is_cartesian_2cell_sfib in Hα. use make_is_invertible_2cell. - exact inv. - exact opcartesian_to_invertible_map_inv. - exact opcartesian_to_invertible_inv_map. Defined. End OpCartesianToInvertible. Definition pr1_internal_opcleaving : internal_sopfib_opcleaving (π₁ : b₁ ⊗ b₂ --> b₁). Proof. intros a f g α. refine (⟨ g , f · π₂ ⟩ ,, (prod_1cell_eta _ f)^-1 • ⟪ α , id2 _ ⟫ ,, inv_of_invertible_2cell (prod_1cell_pr1 _ g _) ,, _ ,, _). - apply invertible_to_opcartesian. rewrite <- rwhisker_vcomp. use is_invertible_2cell_vcomp. + is_iso. + rewrite prod_2cell_pr2. is_iso. apply prod_1cell_pr2. - abstract (unfold prod_1cell_eta_map ; rewrite <- !rwhisker_vcomp ; rewrite prod_2cell_pr1 ; cbn ; etrans ; [ apply maponpaths_2 ; apply binprod_ump_2cell_pr1 | ] ; rewrite !vassocr ; rewrite vcomp_linv ; rewrite id2_left ; apply idpath). Defined. Definition pr1_lwhisker_is_opcartesian : lwhisker_is_opcartesian (π₁ : b₁ ⊗ b₂ --> b₁). Proof. intros x y h f g γ Hγ. apply invertible_to_opcartesian. pose (opcartesian_to_invertible _ Hγ) as i. use make_is_invertible_2cell. - exact (rassociator _ _ _ • (h ◃ i^-1) • lassociator _ _ _). - rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. refine (_ @ rassociator_lassociator _ _ _). rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_left. - rewrite !vassocl. rewrite <- rwhisker_lwhisker. rewrite !vassocr. refine (_ @ rassociator_lassociator _ _ _). apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. Qed. Definition pr1_internal_sopfib : internal_sopfib (π₁ : b₁ ⊗ b₂ --> b₁). Proof. split. - exact pr1_internal_opcleaving. - exact pr1_lwhisker_is_opcartesian. Defined. End ProjectionSOpFib. UniMath-20231010/UniMath/Bicategories/Objects/000077500000000000000000000000001451125700300206455ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Objects/CartesianObject.v000066400000000000000000001227241451125700300241040ustar00rootroot00000000000000(******************************************************************************* Cartesian objects We define the notions of cartesian objects internal to arbitrary bicategories. To define this notion, we use two steps. We first define objects 'with terminal objects' and objects 'with products'. Each of these concepts can be defined in 2 ways. We can use a representable variation or we use adjunctions. This is similar for categories: we can define whether a category has limits/colimits by saying that a certain functor has a right or a left adjoint. Contents 1. The representable definition of cartesian objects 2. Being cartesian is a proposition 3. The definitions of cartesian objects via adjunctions 4. Equivalence of the two definitions of cartesian object *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.UnivalenceOp. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Local Open Scope cat. (** 1. The representable definition of cartesian objects *) Definition cartesian_terminal {B : bicat} (b : B) : UU := (∏ (x : B), Terminal (hom x b)) × (∏ (x y : B) (f : x --> y), preserves_terminal (pre_comp b f)). Definition cartesian_prod {B : bicat} (b : B) : UU := (∏ (x : B), BinProducts (hom x b)) × (∏ (x y : B) (f : x --> y), preserves_binproduct (pre_comp b f)). Definition cartesian_ob {B : bicat} (b : B) : UU := cartesian_terminal b × cartesian_prod b. (** 2. Being cartesian is a proposition *) Definition isaprop_cartesian_terminal {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cartesian_terminal b). Proof. use isapropdirprod. - use impred ; intro. apply isaprop_Terminal. apply is_univ_hom. exact HB. - do 3 (use impred ; intro). apply isaprop_preserves_terminal. Qed. Definition isaprop_cartesian_prod {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cartesian_prod b). Proof. use isapropdirprod. - do 3 (use impred ; intro). apply isaprop_BinProduct. apply is_univ_hom. exact HB. - do 3 (use impred ; intro). apply isaprop_preserves_binproduct. Qed. Definition isaprop_cartesian_ob {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cartesian_ob b). Proof. use isapropdirprod. - apply isaprop_cartesian_terminal. exact HB. - apply isaprop_cartesian_prod. exact HB. Qed. (** 3. The definitions of cartesian objects via adjunctions *) Section CartesianViaAdjunction. Context {B : bicat} (b : B). Section Terminal. Context (T : bifinal_obj B). Let f : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Definition cartesian_terminal_via_adj : UU := left_adjoint f. Definition isaprop_cartesian_terminal_via_adj (HB : is_univalent_2_1 B) : isaprop cartesian_terminal_via_adj. Proof. apply isaprop_left_adjoint. exact HB. Qed. End Terminal. Section Prod. Context (prod : has_binprod B). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Definition cartesian_prod_via_adj : UU := left_adjoint δ. Definition isaprop_cartesian_prod_via_adj (HB : is_univalent_2_1 B) : isaprop cartesian_prod_via_adj. Proof. apply isaprop_left_adjoint. exact HB. Qed. End Prod. Section Cartesian. Context (T : bifinal_obj B) (prod : has_binprod B). Definition cartesian_ob_via_adj : UU := cartesian_terminal_via_adj T × cartesian_prod_via_adj prod. Definition isaprop_cartesian_ob_via_adj (HB : is_univalent_2_1 B) : isaprop cartesian_ob_via_adj. Proof. apply isapropdirprod. - apply isaprop_cartesian_terminal_via_adj. exact HB. - apply isaprop_cartesian_prod_via_adj. exact HB. Qed. End Cartesian. End CartesianViaAdjunction. (** 4. Equivalence of the two definitions of cartesian object *) Section EquivalenceCartesian. Context {B : bicat} (T : bifinal_obj B) (prod : has_binprod B) (b : B). Section ToAdj. Context (Hb : cartesian_terminal b). Let term : Terminal (hom (pr1 T) b) := pr1 Hb (pr1 T). Let l : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Let r : pr1 T --> b := pr1 term. Local Definition cartesian_terminal_to_cartesian_terminal_via_adj_unit : id₁ b ==> l · r := TerminalArrow (_ ,, pr2 Hb _ _ l _ (pr2 term)) (id₁ b). Let η : id₁ b ==> l · r := cartesian_terminal_to_cartesian_terminal_via_adj_unit. Local Definition cartesian_terminal_to_cartesian_terminal_via_adj_counit : r · l ==> id₁ (pr1 T) := is_bifinal_2cell_property (pr2 T) (pr1 T) (r · l) (id₁ (pr1 T)). Let ε : r · l ==> id₁ (pr1 T) := cartesian_terminal_to_cartesian_terminal_via_adj_counit. Definition cartesian_terminal_to_cartesian_terminal_via_adj : cartesian_terminal_via_adj b T. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact r. - exact η. - exact ε. - apply (is_bifinal_eq_property (pr2 T)). - apply (@TerminalArrowEq _ term). Defined. End ToAdj. Section FromAdj. Context (Hb : cartesian_terminal_via_adj b T). Let l : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Let r : pr1 T --> b := left_adjoint_right_adjoint (pr1 Hb). Let η : id₁ b ==> l · r := left_adjoint_unit (pr1 Hb). Let ε : r · l ==> id₁ (pr1 T) := left_adjoint_counit (pr1 Hb). Let p : rinvunitor r • (r ◃ η) • lassociator r l r • (ε ▹ r) • lunitor r = id₂ r := internal_triangle2 (pr2 Hb). Definition cartesian_terminal_via_adj_to_cartesian_terminal_1cell (x : B) : x --> b := is_bifinal_1cell_property (pr2 T) x · r. Definition cartesian_terminal_via_adj_to_cartesian_terminal_2cell (x : B) (f : x --> b) : f ==> cartesian_terminal_via_adj_to_cartesian_terminal_1cell x := rinvunitor _ • (_ ◃ η) • lassociator _ _ _ • (is_bifinal_2cell_property (pr2 T) _ _ _ ▹ r). Definition cartesian_terminal_via_adj_to_cartesian_terminal_eq (x : B) (f : x --> b) : isaprop (f ==> cartesian_terminal_via_adj_to_cartesian_terminal_1cell x). Proof. use invproofirrelevance. intros α β. refine (!(id2_right _) @ _ @ id2_right _). unfold cartesian_terminal_via_adj_to_cartesian_terminal_1cell. rewrite <- lwhisker_id2. rewrite <- p. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite !left_unit_inv_assoc. rewrite !vassocr. rewrite !rinvunitor_natural. rewrite <- !rwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite !lwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite !vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite !lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !vassocr. rewrite <- !rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. do 4 apply maponpaths_2. apply maponpaths. apply (is_bifinal_eq_property (pr2 T)). Qed. Definition cartesian_terminal_via_adj_to_cartesian_terminal_obj (x : B) : Terminal (hom x b). Proof. use make_Terminal. - exact (cartesian_terminal_via_adj_to_cartesian_terminal_1cell x). - intro f. use iscontraprop1. + exact (cartesian_terminal_via_adj_to_cartesian_terminal_eq x f). + exact (cartesian_terminal_via_adj_to_cartesian_terminal_2cell x f). Defined. Definition cartesian_terminal_via_adj_to_cartesian_terminal_preserves {x y : B} (f : x --> y) : preserves_terminal (pre_comp b f). Proof. use preserves_terminal_if_preserves_chosen. - apply cartesian_terminal_via_adj_to_cartesian_terminal_obj. - use (iso_to_Terminal (cartesian_terminal_via_adj_to_cartesian_terminal_obj x)). use inv2cell_to_z_iso. refine (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ _) (rassociator_invertible_2cell _ _ _)). apply (is_bifinal_invertible_2cell_property (pr2 T)). Defined. Definition cartesian_terminal_via_adj_to_cartesian_terminal : cartesian_terminal b. Proof. split. - exact cartesian_terminal_via_adj_to_cartesian_terminal_obj. - exact @cartesian_terminal_via_adj_to_cartesian_terminal_preserves. Defined. End FromAdj. Definition cartesian_terminal_weq_cartesian_terminal_via_adj (HB : is_univalent_2_1 B) : cartesian_terminal b ≃ cartesian_terminal_via_adj b T. Proof. use weqimplimpl. - exact cartesian_terminal_to_cartesian_terminal_via_adj. - exact cartesian_terminal_via_adj_to_cartesian_terminal. - apply isaprop_cartesian_terminal. exact HB. - apply isaprop_cartesian_terminal_via_adj. exact HB. Defined. Section ToAdj. Context (Hb : cartesian_prod b). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Let product : BinProduct (hom (pr1 (prod b b)) b) (binprod_cone_pr1 (pr1 (prod b b))) (binprod_cone_pr2 (pr1 (prod b b))) := pr1 Hb (pr1 (prod b b)) (binprod_cone_pr1 (pr1 (prod b b))) (binprod_cone_pr2 (pr1 (prod b b))). Let r : pr1 (prod b b) --> b := BinProductObject _ product. Local Definition cartesian_prod_to_cartesian_prod_via_adj_unit : id₁ b ==> δ · r. Proof. use (BinProductArrow _ (make_BinProduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))). - exact ((binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1). - exact ((binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1). Defined. Let η : id₁ b ==> δ · r := cartesian_prod_to_cartesian_prod_via_adj_unit. Local Definition cartesian_prod_to_cartesian_prod_via_adj_counit : r · δ ==> id₁ _. Proof. use (binprod_ump_2cell (pr2 (prod b b))). - exact (rassociator _ _ _ • (r ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b)) • runitor _ • BinProductPr1 _ product • linvunitor _). - exact (rassociator _ _ _ • (r ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b)) • runitor _ • BinProductPr2 _ product • linvunitor _). Defined. Let ε : r · δ ==> id₁ _ := cartesian_prod_to_cartesian_prod_via_adj_counit. Local Lemma cartesian_prod_to_cartesian_prod_via_adj_triangle1 : linvunitor δ • (η ▹ δ) • rassociator δ r δ • (δ ◃ ε) • runitor δ = id₂ δ. Proof. use (binprod_ump_2cell_unique_alt (pr2 (prod b b))). - rewrite id2_rwhisker. rewrite <- !rwhisker_vcomp. rewrite <- lunitor_lwhisker. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. do 2 apply maponpaths. etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. rewrite linvunitor_lunitor. rewrite id2_right. apply idpath. } rewrite <- !lwhisker_vcomp. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. apply (BinProductPr1Commutes _ _ _ (make_BinProduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))). } etrans. { rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_lunitor_identity. rewrite linvunitor_lunitor. apply id2_left. } apply vcomp_rinv. } apply idpath. - rewrite id2_rwhisker. rewrite <- !rwhisker_vcomp. rewrite <- lunitor_lwhisker. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lwhisker_vcomp. do 2 apply maponpaths. etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. rewrite linvunitor_lunitor. rewrite id2_right. apply idpath. } rewrite <- !lwhisker_vcomp. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. apply (BinProductPr2Commutes _ _ _ (make_BinProduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))). } etrans. { rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite runitor_lunitor_identity. rewrite linvunitor_lunitor. apply id2_left. } apply vcomp_rinv. } apply idpath. Qed. Local Lemma cartesian_prod_to_cartesian_prod_via_adj_triangle2 : rinvunitor r • (r ◃ η) • lassociator r δ r • (ε ▹ r) • lunitor r = id₂ r. Proof. use (BinProductArrowsEq _ _ _ (product)) ; cbn. - rewrite !vassocl. rewrite id2_left. rewrite <- vcomp_lunitor. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. apply (BinProductPr1Commutes _ _ _ (make_BinProduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))). } rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. rewrite !vassocl. rewrite linvunitor_lunitor. apply id2_right. - rewrite !vassocl. rewrite id2_left. rewrite <- vcomp_lunitor. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. apply (BinProductPr2Commutes _ _ _ (make_BinProduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))). } rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. rewrite !vassocl. rewrite linvunitor_lunitor. apply id2_right. Qed. Definition cartesian_prod_to_cartesian_prod_via_adj : cartesian_prod_via_adj b prod. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact r. - exact η. - exact ε. - exact cartesian_prod_to_cartesian_prod_via_adj_triangle1. - exact cartesian_prod_to_cartesian_prod_via_adj_triangle2. Defined. End ToAdj. Section FromAdj. Context (Hb : cartesian_prod_via_adj b prod). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Let r : pr1 (prod b b) --> b := left_adjoint_right_adjoint (pr1 Hb). Let η : id₁ b ==> δ · r := left_adjoint_unit (pr1 Hb). Let ε : r · δ ==> id₁ _ := left_adjoint_counit (pr1 Hb). Let p : rinvunitor r • (r ◃ η) • lassociator r δ r • (ε ▹ r) • lunitor r = id₂ r := internal_triangle2 (pr2 Hb). Local Definition cartesian_prod_via_adj_to_cartesian_prod_1cell {x : B} (f g : x --> b) : x --> b := binprod_ump_1cell (pr2 (prod b b)) f g · r. Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr1_help : r ==> binprod_cone_pr1 (pr1 (prod b b)) := rinvunitor _ • (r ◃ (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1) • lassociator _ _ _ • (ε ▹ _) • lunitor _. Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr1 {x : B} (f g : x --> b) : cartesian_prod_via_adj_to_cartesian_prod_1cell f g ==> f := (_ ◃ cartesian_prod_via_adj_to_cartesian_prod_pr1_help) • binprod_ump_1cell_pr1 (pr2 (prod b b)) _ f g. Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr2_help : r ==> binprod_cone_pr2 (pr1 (prod b b)) := rinvunitor _ • (r ◃ (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1) • lassociator _ _ _ • (ε ▹ _) • lunitor _. Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr2 {x : B} (f g : x --> b) : cartesian_prod_via_adj_to_cartesian_prod_1cell f g ==> g := (_ ◃ cartesian_prod_via_adj_to_cartesian_prod_pr2_help) • binprod_ump_1cell_pr2 (pr2 (prod b b)) _ f g. Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell {x : B} {f g k : x --> b} (α : k ==> f) (β : k ==> g) : k ==> cartesian_prod_via_adj_to_cartesian_prod_1cell f g. Proof. refine (rinvunitor _ • (_ ◃ η) • lassociator _ _ _ • (binprod_ump_2cell (pr2 (prod b b)) _ _ ▹ r)). - exact (rassociator _ _ _ • (k ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _) • runitor _ • α • (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1). - exact (rassociator _ _ _ • (k ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _) • runitor _ • β • (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1). Defined. Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1 {x : B} {f g k : x --> b} (α : k ==> f) (β : k ==> g) : cartesian_prod_via_adj_to_cartesian_prod_2cell α β • cartesian_prod_via_adj_to_cartesian_prod_pr1 f g = α. Proof. unfold cartesian_prod_via_adj_to_cartesian_prod_2cell. unfold cartesian_prod_via_adj_to_cartesian_prod_pr1. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. apply maponpaths_2. refine (vcomp_whisker _ _ @ _). apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. unfold cartesian_prod_via_adj_to_cartesian_prod_pr1_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite left_unit_inv_assoc. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite <- lunitor_V_id_is_left_unit_V_id. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite linvunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite !vassocr. exact (pr12 Hb). Qed. Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2 {x : B} {f g k : x --> b} (α : k ==> f) (β : k ==> g) : cartesian_prod_via_adj_to_cartesian_prod_2cell α β • cartesian_prod_via_adj_to_cartesian_prod_pr2 f g = β. Proof. unfold cartesian_prod_via_adj_to_cartesian_prod_2cell. unfold cartesian_prod_via_adj_to_cartesian_prod_pr2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. apply maponpaths_2. refine (vcomp_whisker _ _ @ _). apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. unfold cartesian_prod_via_adj_to_cartesian_prod_pr2_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite left_unit_inv_assoc. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. apply idpath. } rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite <- lunitor_V_id_is_left_unit_V_id. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. rewrite linvunitor_assoc. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite !vassocr. exact (pr12 Hb). Qed. Local Definition cartesian_prod_via_adj_to_cartesian_prod_eq {x : B} {f g k : x --> b} (α : k ==> f) (β : k ==> g) (φ : ∑ (fg : k ==> cartesian_prod_via_adj_to_cartesian_prod_1cell f g), fg • cartesian_prod_via_adj_to_cartesian_prod_pr1 f g = α × fg • cartesian_prod_via_adj_to_cartesian_prod_pr2 f g = β) : φ = cartesian_prod_via_adj_to_cartesian_prod_2cell α β ,, cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1 α β ,, cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2 α β. Proof. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } cbn. refine (!(id2_right _) @ _). unfold cartesian_prod_via_adj_to_cartesian_prod_1cell. rewrite <- lwhisker_id2. rewrite <- p. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite !left_unit_inv_assoc. rewrite !vassocr. rewrite !rinvunitor_natural. rewrite <- !rwhisker_hcomp. unfold cartesian_prod_via_adj_to_cartesian_prod_2cell. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite !lwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite !vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite !lwhisker_hcomp. rewrite inverse_pentagon_4. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !vassocr. rewrite <- !rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite !rwhisker_vcomp. apply maponpaths. use (binprod_ump_2cell_unique_alt (pr2 (prod b b))). - rewrite binprod_ump_2cell_pr1. rewrite <- !rwhisker_vcomp. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. refine (_ @ pr12 φ). unfold cartesian_prod_via_adj_to_cartesian_prod_pr1 ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. unfold cartesian_prod_via_adj_to_cartesian_prod_pr1_help. rewrite !vassocl. rewrite <- rinvunitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. apply runitor_rwhisker. - rewrite binprod_ump_2cell_pr2. rewrite <- !rwhisker_vcomp. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. refine (_ @ pr22 φ). unfold cartesian_prod_via_adj_to_cartesian_prod_pr2 ; cbn. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. unfold cartesian_prod_via_adj_to_cartesian_prod_pr2_help. rewrite !vassocl. rewrite <- rinvunitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. apply runitor_rwhisker. Qed. Local Definition cartesian_prod_via_adj_to_cartesian_prod_obj (x : B) : BinProducts (hom x b). Proof. intros f g. use make_BinProduct. - exact (cartesian_prod_via_adj_to_cartesian_prod_1cell f g). - exact (cartesian_prod_via_adj_to_cartesian_prod_pr1 f g). - exact (cartesian_prod_via_adj_to_cartesian_prod_pr2 f g). - intros k α β. use make_iscontr. + simple refine (_ ,, (_ ,, _)). * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell α β). * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1 α β). * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2 α β). + apply cartesian_prod_via_adj_to_cartesian_prod_eq. Defined. Local Definition help_inv2cell {x y : B} (f : x --> y) (h₁ h₂ : y --> b) : invertible_2cell (f · BinProductObject (hom y b) (cartesian_prod_via_adj_to_cartesian_prod_obj y h₁ h₂)) (BinProductObject (hom x b) (cartesian_prod_via_adj_to_cartesian_prod_obj x (f · h₁) (f · h₂))). Proof. refine (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (rwhisker_of_invertible_2cell _ _)). use make_invertible_2cell. - use (binprod_ump_2cell (pr2 (prod b b))). + exact (rassociator _ _ _ • (_ ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ h₁ h₂) • (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1). + exact (rassociator _ _ _ • (_ ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ h₁ h₂) • (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1). - use binprod_ump_2cell_invertible. + is_iso. apply property_from_invertible_2cell. + is_iso. apply property_from_invertible_2cell. Defined. Definition cartesian_prod_via_adj_to_cartesian_prod_preserves {x y : B} (f : x --> y) : preserves_binproduct (pre_comp b f). Proof. use preserves_binproduct_if_preserves_chosen. - apply cartesian_prod_via_adj_to_cartesian_prod_obj. - intros h₁ h₂. use (isBinProduct_eq_arrow _ _ (pr2 (iso_to_BinProduct _ (cartesian_prod_via_adj_to_cartesian_prod_obj x (f · h₁) (f · h₂)) (z_iso_to_iso (inv2cell_to_z_iso (help_inv2cell f h₁ h₂)))))). + cbn. unfold cartesian_prod_via_adj_to_cartesian_prod_pr1. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. apply vcomp_whisker. } rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite !vassocr. etrans. { do 2 apply maponpaths_2. refine (!_). apply lwhisker_lwhisker. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } apply lwhisker_vcomp. + cbn. unfold cartesian_prod_via_adj_to_cartesian_prod_pr2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. apply vcomp_whisker. } rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite !vassocr. etrans. { do 2 apply maponpaths_2. refine (!_). apply lwhisker_lwhisker. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } apply lwhisker_vcomp. Qed. Definition cartesian_prod_via_adj_to_cartesian_prod : cartesian_prod b. Proof. split. - exact cartesian_prod_via_adj_to_cartesian_prod_obj. - exact @cartesian_prod_via_adj_to_cartesian_prod_preserves. Defined. End FromAdj. Definition cartesian_prod_weq_cartesian_prod_via_adj (HB : is_univalent_2_1 B) : cartesian_prod b ≃ cartesian_prod_via_adj b prod. Proof. use weqimplimpl. - exact cartesian_prod_to_cartesian_prod_via_adj. - exact cartesian_prod_via_adj_to_cartesian_prod. - apply isaprop_cartesian_prod. exact HB. - apply isaprop_cartesian_prod_via_adj. exact HB. Defined. Definition cartesian_weq_cartesian_via_adj (HB : is_univalent_2_1 B) : cartesian_ob b ≃ cartesian_ob_via_adj b T prod. Proof. use weqdirprodf. - exact (cartesian_terminal_weq_cartesian_terminal_via_adj HB). - exact (cartesian_prod_weq_cartesian_prod_via_adj HB). Defined. End EquivalenceCartesian. UniMath-20231010/UniMath/Bicategories/Objects/CocartesianObject.v000066400000000000000000001267561451125700300244370ustar00rootroot00000000000000(******************************************************************************* Cocartesian objects We define the notions of cocartesian objects internal to arbitrary bicategories. This notion is defined dually to the notion of cartesian objects. For the representable definition, we work with initial objects and coproducts, and for the definition using adjunctions, we use left adjoints instead of right adjoints. Contents 1. The representable definition of cocartesian objects 2. Being cocartesian is a proposition 3. The definitions of cocartesian objects via adjunctions 4. Equivalence of the two definitions *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.UnivalenceOp. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Local Open Scope cat. (** 1. The representable definition of cocartesian objects *) Definition cocartesian_initial {B : bicat} (b : B) : UU := (∏ (x : B), Initial (hom x b)) × (∏ (x y : B) (f : x --> y), preserves_initial (pre_comp b f)). Definition cocartesian_coprod {B : bicat} (b : B) : UU := (∏ (x : B), BinCoproducts (hom x b)) × (∏ (x y : B) (f : x --> y), preserves_bincoproduct (pre_comp b f)). Definition cocartesian_ob {B : bicat} (b : B) : UU := cocartesian_initial b × cocartesian_coprod b. (** 2. Being cocartesian is a proposition *) Definition isaprop_cocartesian_initial {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cocartesian_initial b). Proof. use isapropdirprod. - use impred ; intro. apply isaprop_Initial. apply is_univ_hom. exact HB. - do 3 (use impred ; intro). apply isaprop_preserves_initial. Qed. Definition isaprop_cocartesian_coprod {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cocartesian_coprod b). Proof. use isapropdirprod. - do 3 (use impred ; intro). apply isaprop_BinCoproduct. apply is_univ_hom. exact HB. - do 3 (use impred ; intro). apply isaprop_preserves_bincoproduct. Qed. Definition isaprop_cocartesian_ob {B : bicat} (HB : is_univalent_2_1 B) (b : B) : isaprop (cocartesian_ob b). Proof. use isapropdirprod. - apply isaprop_cocartesian_initial. exact HB. - apply isaprop_cocartesian_coprod. exact HB. Qed. (** 3. The definitions of cocartesian objects via adjunctions *) Section CocartesianViaAdjunction. Context {B : bicat} (b : B). Section TerminalAndInitial. Context (T : bifinal_obj B). Let f : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Definition cocartesian_initial_via_adj : UU := internal_right_adj f. Definition isaprop_cocartesian_initial_via_adj (HB : is_univalent_2_1 B) : isaprop cocartesian_initial_via_adj. Proof. apply isaprop_internal_right_adj. exact HB. Qed. End TerminalAndInitial. Section ProdAndCoprod. Context (prod : has_binprod B). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Definition cocartesian_coprod_via_adj : UU := internal_right_adj δ. Definition isaprop_cocartesian_coprod_via_adj (HB : is_univalent_2_1 B) : isaprop cocartesian_coprod_via_adj. Proof. apply isaprop_internal_right_adj. exact HB. Qed. End ProdAndCoprod. Section Cocartesian. Context (T : bifinal_obj B) (prod : has_binprod B). Definition cocartesian_ob_via_adj : UU := cocartesian_initial_via_adj T × cocartesian_coprod_via_adj prod. Definition isaprop_cocartesian_ob_via_adj (HB : is_univalent_2_1 B) : isaprop cocartesian_ob_via_adj. Proof. apply isapropdirprod. - apply isaprop_cocartesian_initial_via_adj. exact HB. - apply isaprop_cocartesian_coprod_via_adj. exact HB. Qed. End Cocartesian. End CocartesianViaAdjunction. (** 4. Equivalence of the two definitions *) Section EquivalenceCocartesian. Context {B : bicat} (T : bifinal_obj B) (prod : has_binprod B) (b : B). Section ToAdj. Context (Hb : cocartesian_initial b). Let init : Initial (hom (pr1 T) b) := pr1 Hb (pr1 T). Let l : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Let r : pr1 T --> b := pr1 init. Local Definition cocartesian_initial_to_cocartesian_initial_via_adj_unit : id₁ (pr1 T) ==> r · l := is_bifinal_2cell_property (pr2 T) _ (id₁ _) (r · l). Let η : id₁ (pr1 T) ==> r · l := cocartesian_initial_to_cocartesian_initial_via_adj_unit. Local Definition cocartesian_initial_to_cocartesian_initial_via_adj_counit : l · r ==> id₁ b := InitialArrow (make_Initial _ (pr2 Hb _ _ l _ (pr2 init))) (id₁ b). Let ε : l · r ==> id₁ b := cocartesian_initial_to_cocartesian_initial_via_adj_counit. Definition cocartesian_initial_to_cocartesian_initial_via_adj : cocartesian_initial_via_adj b T. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact r. - exact η. - exact ε. - apply (@InitialArrowEq _ init). - apply (is_bifinal_eq_property (pr2 T)). Defined. End ToAdj. Section FromAdj. Context (Hb : cocartesian_initial_via_adj b T). Let r : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b. Let l : pr1 T --> b := pr11 Hb. Let η : id₁ (pr1 T) ==> l · r := pr121 Hb. Let ε : r · l ==> id₁ b := pr221 Hb. Let p : linvunitor l • (η ▹ l) • rassociator l r l • (l ◃ ε) • runitor l = id₂ l := pr12 Hb. Definition cocartesian_initial_via_adj_to_cocartesian_initial_1cell (x : B) : x --> b := is_bifinal_1cell_property (pr2 T) x · l. Definition cocartesian_initial_via_adj_to_cocartesian_initial_2cell (x : B) (f : x --> b) : cocartesian_initial_via_adj_to_cocartesian_initial_1cell x ==> f := (is_bifinal_2cell_property (pr2 T) _ _ _ ▹ l) • rassociator _ _ _ • (_ ◃ ε) • runitor _. Definition cocartesian_initial_via_adj_to_cocartesian_initial_eq (x : B) (f : x --> b) : isaprop (cocartesian_initial_via_adj_to_cocartesian_initial_1cell x ==> f). Proof. use invproofirrelevance. intros α β. refine (!(id2_left _) @ _ @ id2_left _). unfold cocartesian_initial_via_adj_to_cocartesian_initial_1cell. rewrite <- lwhisker_id2. rewrite <- p. rewrite <- !lwhisker_vcomp. rewrite !vassocl. assert (is_bifinal_1cell_property (pr2 T) x ◃ runitor l = lassociator _ _ _ • runitor (_ · _)) as q. { use vcomp_move_L_pM ; [ is_iso | ]. apply runitor_triangle. } rewrite !q. rewrite !vassocl. rewrite <- !vcomp_runitor. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite !lwhisker_lwhisker. rewrite !vassocl. rewrite <- !vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite !lwhisker_hcomp. rewrite !inverse_pentagon_5. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !vassocl. rewrite <- !rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. do 2 apply maponpaths. apply (is_bifinal_eq_property (pr2 T)). Qed. Definition cocartesian_initial_via_adj_to_cocartesian_initial_obj (x : B) : Initial (hom x b). Proof. use make_Initial. - exact (cocartesian_initial_via_adj_to_cocartesian_initial_1cell x). - intro f. use iscontraprop1. + exact (cocartesian_initial_via_adj_to_cocartesian_initial_eq x f). + exact (cocartesian_initial_via_adj_to_cocartesian_initial_2cell x f). Defined. Definition cocartesian_initial_via_adj_to_cocartesian_initial_preserves {x y : B} (f : x --> y) : preserves_initial (pre_comp b f). Proof. use preserves_initial_if_preserves_chosen. - apply cocartesian_initial_via_adj_to_cocartesian_initial_obj. - use (iso_to_Initial (cocartesian_initial_via_adj_to_cocartesian_initial_obj x)). use inv2cell_to_z_iso. refine (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ _) (rassociator_invertible_2cell _ _ _)). apply (is_bifinal_invertible_2cell_property (pr2 T)). Defined. Definition cocartesian_initial_via_adj_to_cocartesian_initial : cocartesian_initial b. Proof. split. - exact cocartesian_initial_via_adj_to_cocartesian_initial_obj. - exact @cocartesian_initial_via_adj_to_cocartesian_initial_preserves. Defined. End FromAdj. Definition cocartesian_initial_weq_cocartesian_initial_via_adj (HB : is_univalent_2_1 B) : cocartesian_initial b ≃ cocartesian_initial_via_adj b T. Proof. use weqimplimpl. - exact cocartesian_initial_to_cocartesian_initial_via_adj. - exact cocartesian_initial_via_adj_to_cocartesian_initial. - apply isaprop_cocartesian_initial. exact HB. - apply isaprop_cocartesian_initial_via_adj. exact HB. Defined. Section ToAdj. Context (Hb : cocartesian_coprod b). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Let coproduct : @BinCoproduct (hom (pr1 (prod b b)) b) (binprod_cone_pr1 (pr1 (prod b b))) (binprod_cone_pr2 (pr1 (prod b b))) := pr1 Hb (pr1 (prod b b)) (binprod_cone_pr1 (pr1 (prod b b))) (binprod_cone_pr2 (pr1 (prod b b))). Let r : pr1 (prod b b) --> b := BinCoproductObject coproduct. Local Definition cocartesian_coprod_to_cocartesian_coprod_via_adj_unit : id₁ _ ==> r · δ. Proof. use (binprod_ump_2cell (pr2 (prod b b))). - exact (lunitor _ • BinCoproductIn1 coproduct • rinvunitor _ • (r ◃ (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1) • lassociator _ _ _). - exact (lunitor _ • BinCoproductIn2 coproduct • rinvunitor _ • (r ◃ (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1) • lassociator _ _ _). Defined. Let η : id₁ _ ==> r · δ := cocartesian_coprod_to_cocartesian_coprod_via_adj_unit. Local Definition cartesian_prod_to_cartesian_prod_via_adj_counit : δ · r ==> id₁ b. Proof. use (BinCoproductArrow (make_BinCoproduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 coproduct)))) ; cbn. - exact (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b)). - exact (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b)). Defined. Let ε : δ · r ==> id₁ _ := cartesian_prod_to_cartesian_prod_via_adj_counit. Local Lemma cocartesian_coprod_to_cocartesian_coprod_via_adj_triangle_1 : linvunitor r • (η ▹ r) • rassociator r δ r • (r ◃ ε) • runitor r = id₂ r. Proof. use (BinCoproductArrowsEq _ _ _ (coproduct)) ; cbn. - rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- vcomp_whisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 coproduct)))). } etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_left. } apply rinvunitor_runitor. - rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- vcomp_whisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 coproduct)))). } etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_left. } apply rinvunitor_runitor. Qed. Local Lemma cocartesian_coprod_to_cocartesian_coprod_via_adj_triangle_2 : rinvunitor δ • (δ ◃ η) • lassociator δ r δ • (ε ▹ δ) • lunitor δ = id₂ δ. Proof. use (binprod_ump_2cell_unique_alt (pr2 (prod b b))). - rewrite id2_rwhisker. rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. refine (_ @ maponpaths (λ z, rassociator _ _ _ • z) (!(lunitor_assoc (binprod_cone_pr1 (pr1 (prod b b))) δ))). rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite !rwhisker_hcomp. rewrite inverse_pentagon_2. rewrite <- !rwhisker_hcomp. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite !rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- !rwhisker_hcomp, <- !lwhisker_hcomp. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite vcomp_lunitor. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite rinvunitor_runitor. apply id2_left. } rewrite !vassocr. etrans. { apply maponpaths_2. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 coproduct)))). } apply vcomp_rinv. - rewrite id2_rwhisker. rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. refine (_ @ maponpaths (λ z, rassociator _ _ _ • z) (!(lunitor_assoc (binprod_cone_pr2 (pr1 (prod b b))) δ))). rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite !rwhisker_hcomp. rewrite inverse_pentagon_2. rewrite <- !rwhisker_hcomp. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite !rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- !rwhisker_hcomp, <- !lwhisker_hcomp. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite vcomp_lunitor. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite rinvunitor_runitor. apply id2_left. } rewrite !vassocr. etrans. { apply maponpaths_2. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (pr2 Hb _ _ δ _ _ _ _ _ (pr2 coproduct)))). } apply vcomp_rinv. Qed. Definition cocartesian_coprod_to_cocartesian_coprod_via_adj : cocartesian_coprod_via_adj b prod. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact r. - exact η. - exact ε. - exact cocartesian_coprod_to_cocartesian_coprod_via_adj_triangle_1. - exact cocartesian_coprod_to_cocartesian_coprod_via_adj_triangle_2. Defined. End ToAdj. Section FromAdj. Context (Hb : cocartesian_coprod_via_adj b prod). Let δ : b --> pr1 (prod b b) := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b). Let r : pr1 (prod b b) --> b := pr11 Hb. Let η : id₁ _ ==> r · δ := pr121 Hb. Let ε : δ · r ==> id₁ _ := pr221 Hb. Let p : linvunitor r • (η ▹ r) • rassociator r δ r • (r ◃ ε) • runitor r = id2 r := pr12 Hb. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell {x : B} (f g : x --> b) : x --> b := binprod_ump_1cell (pr2 (prod b b)) f g · r. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_in1_help : binprod_cone_pr1 (pr1 (prod b b)) ==> r := linvunitor _ • (η ▹ _) • rassociator _ _ _ • (r ◃ (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))) • runitor _. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_in1 {x : B} (f g : x --> b) : f ==> cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell f g := (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ f g)^-1 • (_ ◃ cocartesian_coprod_via_adj_to_cocartesian_coprod_in1_help). Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_in2_help : binprod_cone_pr2 (pr1 (prod b b)) ==> r := linvunitor _ • (η ▹ _) • rassociator _ _ _ • (r ◃ (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))) • runitor _. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_in2 {x : B} (f g : x --> b) : g ==> cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell f g := (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ f g)^-1 • (_ ◃ cocartesian_coprod_via_adj_to_cocartesian_coprod_in2_help). Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell {x : B} {f g k : x --> b} (α : f ==> k) (β : g ==> k) : cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell f g ==> k. Proof. refine ((binprod_ump_2cell (pr2 (prod b b)) _ _ ▹ r) • rassociator _ _ _ • (_ ◃ ε) • runitor _). - exact (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _ • α • rinvunitor _ • (_ ◃ (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1) • lassociator _ _ _). - exact (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _ • β • rinvunitor _ • (_ ◃ (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1) • lassociator _ _ _). Defined. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in1 {x : B} {f g k : x --> b} (α : f ==> k) (β : g ==> k) : cocartesian_coprod_via_adj_to_cocartesian_coprod_in1 f g • cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell α β = α. Proof. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in1. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. refine (!(vcomp_whisker _ _) @ _). apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. refine (_ @ id2_right _). rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in1_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. rewrite lwhisker_hcomp. apply triangle_r_inv. } rewrite <- rwhisker_hcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_hcomp. rewrite <- inverse_pentagon_3. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } rewrite <- vcomp_runitor. rewrite !vassocr. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite runitor_lunitor_identity. rewrite vcomp_lunitor. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. rewrite <- lunitor_triangle. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite !rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite !vassocr. exact (pr22 Hb). Qed. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in2 {x : B} {f g k : x --> b} (α : f ==> k) (β : g ==> k) : cocartesian_coprod_via_adj_to_cocartesian_coprod_in2 f g • cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell α β = β. Proof. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. do 3 apply maponpaths_2. refine (!(vcomp_whisker _ _) @ _). apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. refine (_ @ id2_right _). rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !lwhisker_vcomp. refine (_ @ lwhisker_id2 _ _). apply maponpaths. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in2_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. apply maponpaths_2. rewrite lwhisker_hcomp. apply triangle_r_inv. } rewrite <- rwhisker_hcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite !lwhisker_hcomp. rewrite <- inverse_pentagon_3. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. apply idpath. } rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } rewrite <- vcomp_runitor. rewrite !vassocr. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply idpath. } rewrite runitor_lunitor_identity. rewrite vcomp_lunitor. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. refine (_ @ id2_left _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. rewrite <- lunitor_triangle. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. } rewrite !rwhisker_vcomp. refine (_ @ id2_rwhisker _ _). apply maponpaths. rewrite !vassocr. exact (pr22 Hb). Qed. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_eq {x : B} {f g k : x --> b} (α : f ==> k) (β : g ==> k) (φ : ∑ (fg : cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell f g ==> k), cocartesian_coprod_via_adj_to_cocartesian_coprod_in1 f g • fg = α × cocartesian_coprod_via_adj_to_cocartesian_coprod_in2 f g • fg = β) : φ = cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell α β ,, cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in1 α β ,, cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in2 α β. Proof. use subtypePath. { intro. apply isapropdirprod ; apply cellset_property. } cbn. refine (!(id2_left _) @ _). unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell. rewrite <- lwhisker_id2. rewrite <- p. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. apply maponpaths_2. refine (_ @ maponpaths (λ z, lassociator _ _ _ • z) (runitor_triangle (binprod_ump_1cell (pr2 (prod b b)) f g) r)). rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocl. rewrite <- vcomp_runitor. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell. rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite inverse_pentagon_5. rewrite <- rwhisker_hcomp. rewrite !vassocl. rewrite <- rwhisker_rwhisker_alt. apply idpath. } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. apply idpath. } rewrite !vassocr. rewrite !lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp. rewrite !rwhisker_vcomp. apply idpath. } apply maponpaths. use (binprod_ump_2cell_unique_alt (pr2 (prod b b))). - rewrite binprod_ump_2cell_pr1. rewrite <- !rwhisker_vcomp. rewrite <- (pr12 φ). rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in1. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in1_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite <- runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite runitor_rinvunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. refine (lassociator_lassociator _ _ _ _ @ _). apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. refine (!(lwhisker_lwhisker _ _ _) @ _). rewrite !vassocl. apply maponpaths. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell. rewrite <- rinvunitor_triangle. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite runitor_rinvunitor. rewrite lwhisker_id2. rewrite id2_left. apply idpath. - rewrite binprod_ump_2cell_pr2. rewrite <- !rwhisker_vcomp. rewrite <- (pr22 φ). rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in2. rewrite !vassocr. rewrite vcomp_rinv. rewrite id2_left. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in2_help. rewrite <- !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite <- runitor_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite runitor_rinvunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. refine (lassociator_lassociator _ _ _ _ @ _). apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. refine (!(lwhisker_lwhisker _ _ _) @ _). rewrite !vassocl. apply maponpaths. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell. rewrite <- rinvunitor_triangle. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite runitor_rinvunitor. rewrite lwhisker_id2. rewrite id2_left. apply idpath. Qed. Local Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_obj (x : B) : BinCoproducts (hom x b). Proof. intros f g. use make_BinCoproduct. - exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell f g). - exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_in1 f g). - exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_in2 f g). - intros k α β. use make_iscontr. + simple refine (_ ,, (_ ,, _)). * exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell α β). * exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in1 α β). * exact (cocartesian_coprod_via_adj_to_cocartesian_coprod_2cell_in2 α β). + apply cocartesian_coprod_via_adj_to_cocartesian_coprod_eq. Defined. Local Definition help_inv2cell {x y : B} (f : x --> y) (h₁ h₂ : y --> b) : invertible_2cell (f · cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell h₁ h₂) (cocartesian_coprod_via_adj_to_cocartesian_coprod_1cell (f · h₁) (f · h₂)). Proof. refine (comp_of_invertible_2cell (lassociator_invertible_2cell _ _ _) (rwhisker_of_invertible_2cell _ _)). use make_invertible_2cell. - use (binprod_ump_2cell (pr2 (prod b b))). + exact (rassociator _ _ _ • (_ ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ h₁ h₂) • (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1). + exact (rassociator _ _ _ • (_ ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ h₁ h₂) • (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1). - use binprod_ump_2cell_invertible. + is_iso. apply property_from_invertible_2cell. + is_iso. apply property_from_invertible_2cell. Defined. Definition cocartesian_coprod_via_adj_to_cocartesian_coprod_preserves {x y : B} (f : x --> y) : preserves_bincoproduct (pre_comp b f). Proof. use preserves_bincoproduct_if_preserves_chosen. - apply cocartesian_coprod_via_adj_to_cocartesian_coprod_obj. - intros h₁ h₂. use (isBinCoproduct_eq_arrow _ _ (z_iso_to_isBinCoproduct _ (cocartesian_coprod_via_adj_to_cocartesian_coprod_obj x (f · h₁) (f · h₂)) (inv2cell_to_z_iso (help_inv2cell f h₁ h₂)))). + cbn. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in1. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. refine (!_). apply vcomp_whisker. } rewrite !vassocl. rewrite binprod_ump_2cell_pr1. etrans. { apply maponpaths. refine (!_). apply lwhisker_lwhisker_rassociator. } rewrite !vassocl. apply maponpaths. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. rewrite !lwhisker_vcomp. apply idpath. + cbn. unfold cocartesian_coprod_via_adj_to_cocartesian_coprod_in2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. refine (!_). apply vcomp_whisker. } rewrite !vassocl. rewrite binprod_ump_2cell_pr2. etrans. { apply maponpaths. refine (!_). apply lwhisker_lwhisker_rassociator. } rewrite !vassocl. apply maponpaths. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. rewrite !lwhisker_vcomp. apply idpath. Qed. Definition cocartesian_coprod_via_adj_to_cocartesian_coprod : cocartesian_coprod b. Proof. split. - exact cocartesian_coprod_via_adj_to_cocartesian_coprod_obj. - exact @cocartesian_coprod_via_adj_to_cocartesian_coprod_preserves. Defined. End FromAdj. Definition cocartesian_coprod_weq_cocartesian_coprod_via_adj (HB : is_univalent_2_1 B) : cocartesian_coprod b ≃ cocartesian_coprod_via_adj b prod. Proof. use weqimplimpl. - exact cocartesian_coprod_to_cocartesian_coprod_via_adj. - exact cocartesian_coprod_via_adj_to_cocartesian_coprod. - apply isaprop_cocartesian_coprod. exact HB. - apply isaprop_cocartesian_coprod_via_adj. exact HB. Defined. Definition cocartesian_weq_cocartesian_via_adj (HB : is_univalent_2_1 B) : cocartesian_ob b ≃ cocartesian_ob_via_adj b T prod. Proof. use weqdirprodf. - exact (cocartesian_initial_weq_cocartesian_initial_via_adj HB). - exact (cocartesian_coprod_weq_cocartesian_coprod_via_adj HB). Defined. End EquivalenceCocartesian. UniMath-20231010/UniMath/Bicategories/Objects/Examples/000077500000000000000000000000001451125700300224235ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Objects/Examples/BicatOfUnivCatsObjects.v000066400000000000000000000734131451125700300271200ustar00rootroot00000000000000(****************************************************************** Characterizations of (co)cartesian univalent categories In this file we characterize cartesian and cocartesian objects in the bicategory of univalent categories. Note: we already gave a characterization of such objects via adjoints. More specifically, for cartesian objects both the diagonal and the unique map to the terminal object should have right adjoints whereas for cocartesian objects, these two 1-cells should have left adjoints. This characterization via adjoints gives a direct connection to limits and colimits. A category has products if and only if the diagonal functor has a right adjoint and dually for coproducts. Contents 1. Characterization of cartesian objects 1.1. Categories with a terminal object 1.2. Categories with binary products 2. Characterization of cocartesian objects 2.1. Categories with an initial object 2.2. Categories with binary coproducts ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Require Import UniMath.Bicategories.Core.UnivalenceOp. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.Objects.CartesianObject. Require Import UniMath.Bicategories.Objects.CocartesianObject. Local Open Scope cat. (** 1. Characterization of cartesian objects *) (** 1.1. Categories with a terminal object *) Section TerminalToAdj. Context (C : bicat_of_univ_cats) (T : Terminal (pr1 C)). Definition terminal_to_right_adj : unit_category ⟶ pr1 C := constant_functor _ _ T. Definition terminal_to_unit : functor_identity _ ⟹ functor_to_unit _ ∙ terminal_to_right_adj. Proof. use make_nat_trans. - exact (λ x, TerminalArrow _ _). - abstract (intros x y f ; apply TerminalArrowEq). Defined. Definition terminal_to_counit : terminal_to_right_adj ∙ functor_to_unit _ ⟹ functor_identity _. Proof. use make_nat_trans. - intro. apply isapropunit. - abstract (intros x y f ; apply isasetunit). Defined. Definition terminal_to_cartesian_terminal_via_adj_data : left_adjoint_data (is_bifinal_1cell_property (pr2 bifinal_cats) C). Proof. simple refine (_ ,, (_ ,, _)). - exact terminal_to_right_adj. - exact terminal_to_unit. - exact terminal_to_counit. Defined. Definition terminal_to_cartesian_terminal_via_adj_axioms : left_adjoint_axioms terminal_to_cartesian_terminal_via_adj_data. Proof. split. - use nat_trans_eq ; [ apply homset_property | ]. intro. apply idpath. - use nat_trans_eq ; [ apply homset_property | ]. intro. apply TerminalArrowEq. Qed. Definition terminal_to_cartesian_terminal_via_adj : cartesian_terminal_via_adj C bifinal_cats. Proof. simple refine (_ ,, _). - exact terminal_to_cartesian_terminal_via_adj_data. - exact terminal_to_cartesian_terminal_via_adj_axioms. Defined. End TerminalToAdj. Section AdjToTerminal. Context (C : bicat_of_univ_cats) (HC : cartesian_terminal_via_adj C bifinal_cats). Let R : unit_category ⟶ pr1 C := pr11 HC. Let η : functor_identity _ ⟹ functor_to_unit _ ∙ R := pr121 HC. Let ε : R ∙ functor_to_unit _ ⟹ functor_identity _ := pr221 HC. Definition cartesian_terminal_via_adj_to_terminal_unique (x : pr1 C) : isaprop (x --> R tt). Proof. use invproofirrelevance. intros φ₁ φ₂. pose (nat_trans_eq_pointwise (pr22 HC) tt) as p. cbn in p. rewrite !id_left, !id_right in p. refine (!(id_right _) @ _ @ id_right _). etrans. { apply maponpaths. exact (!p). } rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η). } refine (!_). etrans. { apply maponpaths. exact (!p). } rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η). } rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. apply isasetunit. Qed. Definition cartesian_terminal_via_adj_to_terminal : Terminal (pr1 C). Proof. use make_Terminal. - exact (R tt). - intro x. use iscontraprop1. + exact (cartesian_terminal_via_adj_to_terminal_unique x). + exact (pr1 η x). Defined. End AdjToTerminal. Definition terminal_weq_cartesian_terminal_via_adj (C : bicat_of_univ_cats) : Terminal (pr1 C) ≃ cartesian_terminal_via_adj C bifinal_cats. Proof. use weqimplimpl. - exact (terminal_to_cartesian_terminal_via_adj C). - exact (cartesian_terminal_via_adj_to_terminal C). - apply isaprop_Terminal. exact (pr2 C). - apply isaprop_cartesian_terminal_via_adj. exact univalent_cat_is_univalent_2_1. Defined. Definition terminal_weq_cartesian_terminal (C : bicat_of_univ_cats) : Terminal (pr1 C) ≃ cartesian_terminal C := (invweq (cartesian_terminal_weq_cartesian_terminal_via_adj bifinal_cats C univalent_cat_is_univalent_2_1) ∘ terminal_weq_cartesian_terminal_via_adj C)%weq. (** 1.2. Categories with binary products *) Section AdjFromProducts. Context (C : bicat_of_univ_cats) (prodC : BinProducts (pr1 C)). Definition binproducts_to_cartesian_prod_via_adj_right_adj_data : functor_data (category_binproduct (pr1 C) (pr1 C)) (pr1 C). Proof. use make_functor_data. - exact (λ x, BinProductObject _ (prodC (pr1 x) (pr2 x))). - exact (λ x y f, BinProductOfArrows _ _ _ (pr1 f) (pr2 f)). Defined. Definition binproducts_to_cartesian_prod_via_adj_right_adj_is_functor : is_functor binproducts_to_cartesian_prod_via_adj_right_adj_data. Proof. split. - intro x ; cbn. use BinProductArrowsEq. + rewrite BinProductOfArrowsPr1. rewrite id_left, id_right. apply idpath. + rewrite BinProductOfArrowsPr2. rewrite id_left, id_right. apply idpath. - intros x y z f g ; cbn. rewrite BinProductOfArrows_comp. apply idpath. Qed. Definition binproducts_to_cartesian_prod_via_adj_right_adj : category_binproduct (pr1 C) (pr1 C) ⟶ pr1 C. Proof. use make_functor. - exact binproducts_to_cartesian_prod_via_adj_right_adj_data. - exact binproducts_to_cartesian_prod_via_adj_right_adj_is_functor. Defined. Definition binproducts_to_cartesian_prod_via_adj_unit : functor_identity (pr1 C) ⟹ bindelta_pair_functor (functor_identity _) (functor_identity _) ∙ binproducts_to_cartesian_prod_via_adj_right_adj. Proof. use make_nat_trans. - exact (λ x, BinProductArrow _ _ (identity x) (identity x)). - abstract (intros x y f ; cbn ; use BinProductArrowsEq ; [ rewrite !assoc' ; rewrite BinProductOfArrowsPr1 ; rewrite BinProductPr1Commutes ; rewrite !assoc ; rewrite BinProductPr1Commutes ; rewrite id_left, id_right ; apply idpath | rewrite !assoc' ; rewrite BinProductOfArrowsPr2 ; rewrite BinProductPr2Commutes ; rewrite !assoc ; rewrite BinProductPr2Commutes ; rewrite id_left, id_right ; apply idpath ]). Defined. Definition binproducts_to_cartesian_prod_via_adj_counit : binproducts_to_cartesian_prod_via_adj_right_adj ∙ bindelta_pair_functor (functor_identity _) (functor_identity _) ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ x, BinProductPr1 _ _ ,, BinProductPr2 _ _). - abstract (intros x y f ; use pathsdirprod ; cbn ; [ apply BinProductOfArrowsPr1 | apply BinProductOfArrowsPr2 ]). Defined. Definition binproducts_to_cartesian_prod_via_adj_data : left_adjoint_data (binprod_ump_1cell (pr2 (has_binprod_bicat_of_univ_cats C C)) (id₁ C) (id₁ C)). Proof. simple refine (_ ,, (_ ,, _)). - exact binproducts_to_cartesian_prod_via_adj_right_adj. - exact binproducts_to_cartesian_prod_via_adj_unit. - exact binproducts_to_cartesian_prod_via_adj_counit. Defined. Definition binproducts_to_cartesian_prod_via_adj_axioms : left_adjoint_axioms binproducts_to_cartesian_prod_via_adj_data. Proof. split. - use nat_trans_eq ; [ apply homset_property | ]. intro x. use pathsdirprod ; cbn. + rewrite !id_left, !id_right. apply BinProductPr1Commutes. + rewrite !id_left, !id_right. apply BinProductPr2Commutes. - use nat_trans_eq ; [ apply homset_property | ]. intro x ; cbn. rewrite !id_left, !id_right. use BinProductArrowsEq. + rewrite !id_left. rewrite !assoc'. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductPr1Commutes. apply id_left. + rewrite !id_left. rewrite !assoc'. rewrite BinProductOfArrowsPr2. rewrite !assoc. rewrite BinProductPr2Commutes. apply id_left. Qed. Definition binproducts_to_cartesian_prod_via_adj : cartesian_prod_via_adj C has_binprod_bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact binproducts_to_cartesian_prod_via_adj_data. - exact binproducts_to_cartesian_prod_via_adj_axioms. Defined. End AdjFromProducts. Section ProductsFromAdj. Context (C : bicat_of_univ_cats) (RC : cartesian_prod_via_adj C has_binprod_bicat_of_univ_cats). Let R : category_binproduct (pr1 C) (pr1 C) ⟶ pr1 C := pr11 RC. Let η : functor_identity _ ⟹ bindelta_pair_functor (functor_identity _) (functor_identity _) ∙ R := pr121 RC. Let ε : R ∙ bindelta_pair_functor (functor_identity _) (functor_identity _) ⟹ functor_identity _ := pr221 RC. Section Products. Context (x y : pr1 C). Local Definition cartesian_prod_via_adj_to_binproduct_obj : pr1 C := R (x ,, y). Local Definition cartesian_prod_via_adj_to_binproduct_pr1 : cartesian_prod_via_adj_to_binproduct_obj --> x := pr1 (ε (x ,, y)). Local Definition cartesian_prod_via_adj_to_binproduct_pr2 : cartesian_prod_via_adj_to_binproduct_obj --> y := pr2 (ε (x ,, y)). Context (w : pr1 C) (f : w --> x) (g : w --> y). Local Definition cartesian_prod_via_adj_to_binproduct_pair_unique : isaprop (∑ (fg : w --> cartesian_prod_via_adj_to_binproduct_obj), fg · cartesian_prod_via_adj_to_binproduct_pr1 = f × fg · cartesian_prod_via_adj_to_binproduct_pr2 = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } pose (p := nat_trans_eq_pointwise (pr22 RC) (x ,, y)). cbn in p. rewrite !id_left, !id_right in p. refine (!(id_right _) @ _ @ id_right _). refine (maponpaths (λ z, _ · z) (!p) @ _ @ maponpaths (λ z, _ · z) p). rewrite !assoc. refine (maponpaths (λ z, z · _) (nat_trans_ax η _ _ _) @ _). refine (_ @ maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ _))). rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. apply pathsdirprod ; cbn. - exact (pr12 φ₁ @ !(pr12 φ₂)). - exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Local Definition cartesian_prod_via_adj_to_binproduct_pair : w --> cartesian_prod_via_adj_to_binproduct_obj := η w · @functor_on_morphisms _ _ R (w ,, w) (x ,, y) (f ,, g). Local Definition cartesian_prod_via_adj_to_binproduct_pair_pr1 : cartesian_prod_via_adj_to_binproduct_pair · cartesian_prod_via_adj_to_binproduct_pr1 = f. Proof. unfold cartesian_prod_via_adj_to_binproduct_pair. unfold cartesian_prod_via_adj_to_binproduct_pr1. pose (p := maponpaths pr1 (nat_trans_eq_pointwise (pr12 RC) w)). cbn in p. rewrite !id_left, !id_right in p. rewrite !assoc'. etrans. { apply maponpaths. exact (maponpaths pr1 (nat_trans_ax ε (w ,, w) (x ,,y) (f ,, g))). } cbn. rewrite !assoc. etrans. { apply maponpaths_2. exact p. } apply id_left. Qed. Local Definition cartesian_prod_via_adj_to_binproduct_pair_pr2 : cartesian_prod_via_adj_to_binproduct_pair · cartesian_prod_via_adj_to_binproduct_pr2 = g. Proof. unfold cartesian_prod_via_adj_to_binproduct_pair. unfold cartesian_prod_via_adj_to_binproduct_pr2. pose (p := maponpaths dirprod_pr2 (nat_trans_eq_pointwise (pr12 RC) w)). cbn in p. rewrite !id_left, !id_right in p. rewrite !assoc'. etrans. { apply maponpaths. exact (maponpaths dirprod_pr2 (nat_trans_ax ε (w ,, w) (x ,,y) (f ,, g))). } cbn. rewrite !assoc. etrans. { apply maponpaths_2. exact p. } apply id_left. Qed. End Products. Definition cartesian_prod_via_adj_to_binproduct : BinProducts (pr1 C). Proof. intros x y. use make_BinProduct. - exact (cartesian_prod_via_adj_to_binproduct_obj x y). - exact (cartesian_prod_via_adj_to_binproduct_pr1 x y). - exact (cartesian_prod_via_adj_to_binproduct_pr2 x y). - intros w f g. use iscontraprop1. + exact (cartesian_prod_via_adj_to_binproduct_pair_unique x y w f g). + simple refine (_ ,, (_ ,, _)). * exact (cartesian_prod_via_adj_to_binproduct_pair x y w f g). * exact (cartesian_prod_via_adj_to_binproduct_pair_pr1 x y w f g). * exact (cartesian_prod_via_adj_to_binproduct_pair_pr2 x y w f g). Defined. End ProductsFromAdj. Definition binproducts_weq_cartesian_prod_via_adj (C : bicat_of_univ_cats) : BinProducts (pr1 C) ≃ cartesian_prod_via_adj C has_binprod_bicat_of_univ_cats. Proof. use weqimplimpl. - exact (binproducts_to_cartesian_prod_via_adj C). - exact (cartesian_prod_via_adj_to_binproduct C). - use impred ; intro x. use impred ; intro y. apply isaprop_BinProduct. exact (pr2 C). - apply isaprop_cartesian_prod_via_adj. exact univalent_cat_is_univalent_2_1. Defined. Definition prods_weq_cartesian_prod (C : bicat_of_univ_cats) : BinProducts (pr1 C) ≃ cartesian_prod C := (invweq (cartesian_prod_weq_cartesian_prod_via_adj has_binprod_bicat_of_univ_cats C univalent_cat_is_univalent_2_1) ∘ binproducts_weq_cartesian_prod_via_adj C)%weq. Definition terminal_prods_weq_cartesian_ob (C : bicat_of_univ_cats) : Terminal (pr1 C) × BinProducts (pr1 C) ≃ cartesian_ob C. Proof. use weqdirprodf. - exact (terminal_weq_cartesian_terminal C). - exact (prods_weq_cartesian_prod C). Defined. (** 2. Characterization of cocartesian objects *) (** 2.1. Categories with an initial object *) Section InitialToAdj. Context (C : bicat_of_univ_cats) (I : Initial (pr1 C)). Definition initial_to_left_adj : unit_category ⟶ pr1 C := constant_functor _ _ I. Definition initial_to_unit : functor_identity _ ⟹ initial_to_left_adj ∙ functor_to_unit _. Proof. use make_nat_trans. - intro. apply isapropunit. - abstract (intros x y f ; apply isasetunit). Defined. Definition initial_to_counit : functor_to_unit _ ∙ initial_to_left_adj ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ _, InitialArrow _ _). - abstract (intros x y f ; apply InitialArrowEq). Defined. Definition initial_to_cocartesian_initial_via_adj_data : internal_right_adj_data (is_bifinal_1cell_property (pr2 bifinal_cats) C). Proof. simple refine (_ ,, (_ ,, _)). - exact initial_to_left_adj. - exact initial_to_unit. - exact initial_to_counit. Defined. Definition initial_to_cocartesian_initial_via_adj_axioms : internal_right_adj_axioms initial_to_cocartesian_initial_via_adj_data. Proof. split. - use nat_trans_eq ; [ apply homset_property | ]. intro. apply InitialArrowEq. - use nat_trans_eq ; [ apply homset_property | ]. intro. apply idpath. Qed. Definition initial_to_cocartesian_initial_via_adj : cocartesian_initial_via_adj C bifinal_cats. Proof. simple refine (_ ,, _). - exact initial_to_cocartesian_initial_via_adj_data. - exact initial_to_cocartesian_initial_via_adj_axioms. Defined. End InitialToAdj. Section AdjToInitial. Context (C : bicat_of_univ_cats) (HC : cocartesian_initial_via_adj C bifinal_cats). Let L : unit_category ⟶ pr1 C := pr11 HC. Let η : functor_identity _ ⟹ L ∙ functor_to_unit _ := pr121 HC. Let ε : functor_to_unit _ ∙ L ⟹ functor_identity _ := pr221 HC. Definition cocartesian_initial_via_adj_to_initial_unique (x : pr1 C) : isaprop (L tt --> x). Proof. use invproofirrelevance. intros φ₁ φ₂. pose (nat_trans_eq_pointwise (pr12 HC) tt) as p. cbn in p. rewrite !id_left, !id_right in p. refine (!(id_left _) @ _ @ id_left _). etrans. { apply maponpaths_2. exact (!p). } rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } refine (!_). etrans. { apply maponpaths_2. exact (!p). } rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } apply maponpaths_2. apply maponpaths. apply isasetunit. Qed. Definition cocartesian_initial_via_adj_to_initial : Initial (pr1 C). Proof. use make_Initial. - exact (L tt). - intro x. use iscontraprop1. + exact (cocartesian_initial_via_adj_to_initial_unique x). + exact (pr1 ε x). Defined. End AdjToInitial. Definition initial_weq_cocartesian_initial_via_adj (C : bicat_of_univ_cats) : Initial (pr1 C) ≃ cocartesian_initial_via_adj C bifinal_cats. Proof. use weqimplimpl. - exact (initial_to_cocartesian_initial_via_adj C). - exact (cocartesian_initial_via_adj_to_initial C). - apply isaprop_Initial. exact (pr2 C). - apply isaprop_cocartesian_initial_via_adj. exact univalent_cat_is_univalent_2_1. Defined. Definition initial_weq_cocartesian_initial (C : bicat_of_univ_cats) : Initial (pr1 C) ≃ cocartesian_initial C := (invweq (cocartesian_initial_weq_cocartesian_initial_via_adj bifinal_cats C univalent_cat_is_univalent_2_1) ∘ initial_weq_cocartesian_initial_via_adj C)%weq. (** 2.2. Categories with binary coproducts *) Section AdjToCoprod. Context (C : bicat_of_univ_cats) (coprodC : BinCoproducts (pr1 C)). Definition coprods_to_cocartesian_coprod_via_adj_adj_data : functor_data (category_binproduct (pr1 C) (pr1 C)) (pr1 C). Proof. use make_functor_data. - exact (λ x, coprodC (pr1 x) (pr2 x)). - exact (λ x y f, BinCoproductOfArrows _ _ _ (pr1 f) (pr2 f)). Defined. Definition coprods_to_cocartesian_coprod_via_adj_adj_is_functor : is_functor coprods_to_cocartesian_coprod_via_adj_adj_data. Proof. split. - intros x ; cbn. use BinCoproductArrowsEq. + rewrite BinCoproductOfArrowsIn1. rewrite id_left, id_right. apply idpath. + rewrite BinCoproductOfArrowsIn2. rewrite id_left, id_right. apply idpath. - intros x y z f g ; cbn. refine (!_). apply BinCoproductOfArrows_comp. Qed. Definition coprods_to_cocartesian_coprod_via_adj_adj : category_binproduct (pr1 C) (pr1 C) ⟶ pr1 C. Proof. use make_functor. - exact coprods_to_cocartesian_coprod_via_adj_adj_data. - exact coprods_to_cocartesian_coprod_via_adj_adj_is_functor. Defined. Definition coprods_to_cocartesian_coprod_via_adj_unit : functor_identity _ ⟹ coprods_to_cocartesian_coprod_via_adj_adj ∙ bindelta_pair_functor (functor_identity _) (functor_identity _). Proof. use make_nat_trans. - exact (λ x, BinCoproductIn1 _ ,, BinCoproductIn2 _). - abstract (intros x y f ; use pathsdirprod ; cbn ; refine (!_) ; [ apply BinCoproductOfArrowsIn1 | apply BinCoproductOfArrowsIn2 ]). Defined. Definition coprods_to_cocartesian_coprod_via_adj_counit : bindelta_pair_functor (functor_identity _) (functor_identity _) ∙ coprods_to_cocartesian_coprod_via_adj_adj ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ x, BinCoproductArrow _ (identity x) (identity x)). - abstract (intros x y f ; cbn ; use BinCoproductArrowsEq ; [ rewrite !assoc ; rewrite BinCoproductOfArrowsIn1 ; rewrite BinCoproductIn1Commutes ; rewrite !assoc' ; rewrite BinCoproductIn1Commutes ; rewrite id_left, id_right ; apply idpath | rewrite !assoc ; rewrite BinCoproductOfArrowsIn2 ; rewrite BinCoproductIn2Commutes ; rewrite !assoc' ; rewrite BinCoproductIn2Commutes ; rewrite id_left, id_right ; apply idpath ]). Defined. Definition coprods_to_cocartesian_coprod_via_adj_data : internal_right_adj_data (binprod_ump_1cell (pr2 (has_binprod_bicat_of_univ_cats C C)) (id₁ C) (id₁ C)). Proof. simple refine (_ ,, (_ ,, _)). - exact coprods_to_cocartesian_coprod_via_adj_adj. - exact coprods_to_cocartesian_coprod_via_adj_unit. - exact coprods_to_cocartesian_coprod_via_adj_counit. Defined. Definition coprods_to_cocartesian_coprod_via_adj_axioms : internal_right_adj_axioms coprods_to_cocartesian_coprod_via_adj_data. Proof. split. - use nat_trans_eq ; [ apply homset_property | ]. intro x ; cbn. rewrite !id_left, !id_right. use BinCoproductArrowsEq. + rewrite !assoc. rewrite BinCoproductOfArrowsIn1. rewrite !assoc'. rewrite BinCoproductIn1Commutes. apply idpath. + rewrite !assoc. rewrite BinCoproductOfArrowsIn2. rewrite !assoc'. rewrite BinCoproductIn2Commutes. apply idpath. - use nat_trans_eq ; [ apply homset_property | ]. intro x. use pathsdirprod ; cbn. + rewrite !id_left, !id_right. apply BinCoproductIn1Commutes. + rewrite !id_left, !id_right. apply BinCoproductIn2Commutes. Qed. Definition coprods_to_cocartesian_coprod_via_adj : cocartesian_coprod_via_adj C has_binprod_bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact coprods_to_cocartesian_coprod_via_adj_data. - exact coprods_to_cocartesian_coprod_via_adj_axioms. Defined. End AdjToCoprod. Section CoprodToAdj. Context (C : bicat_of_univ_cats) (LC : cocartesian_coprod_via_adj C has_binprod_bicat_of_univ_cats). Let L : category_binproduct (pr1 C) (pr1 C) ⟶ pr1 C := pr11 LC. Let η : functor_identity _ ⟹ L ∙ bindelta_pair_functor (functor_identity _) (functor_identity _) := pr121 LC. Let ε : bindelta_pair_functor (functor_identity _) (functor_identity _) ∙ L ⟹ functor_identity _ := pr221 LC. Section Coproducts. Context (x y : pr1 C). Definition cocartesian_coprod_via_adj_to_coprods_obj : pr1 C := L (x ,, y). Definition cocartesian_coprod_via_adj_to_coprods_in1 : x --> cocartesian_coprod_via_adj_to_coprods_obj := pr1 (η (x ,, y)). Definition cocartesian_coprod_via_adj_to_coprods_in2 : y --> cocartesian_coprod_via_adj_to_coprods_obj := pr2 (η (x ,, y)). Context (z : pr1 C) (f : x --> z) (g : y --> z). Definition cocartesian_coprod_via_adj_to_coprods_unique : isaprop (∑ (fg : cocartesian_coprod_via_adj_to_coprods_obj --> z), cocartesian_coprod_via_adj_to_coprods_in1 · fg = f × cocartesian_coprod_via_adj_to_coprods_in2 · fg = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } pose (p := nat_trans_eq_pointwise (pr12 LC) (x ,, y)). cbn in p. rewrite !id_left, !id_right in p. refine (!(id_left _) @ _ @ id_left _). refine (maponpaths (λ z, z · _) (!p) @ _ @ maponpaths (λ z, z · _) p). rewrite !assoc'. refine (maponpaths (λ z, _ · z) (!(nat_trans_ax ε _ _ _)) @ _). refine (_ @ maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ _)). rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. use pathsdirprod ; cbn. - exact (pr12 φ₁ @ !(pr12 φ₂)). - exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Definition cocartesian_coprod_via_adj_to_coprods_sum : cocartesian_coprod_via_adj_to_coprods_obj --> z := @functor_on_morphisms _ _ L (x ,, y) (z ,, z) (f ,, g) · ε z. Definition cocartesian_coprod_via_adj_to_coprods_sum_in1 : cocartesian_coprod_via_adj_to_coprods_in1 · cocartesian_coprod_via_adj_to_coprods_sum = f. Proof. unfold cocartesian_coprod_via_adj_to_coprods_in1. unfold cocartesian_coprod_via_adj_to_coprods_sum. rewrite !assoc. etrans. { apply maponpaths_2. exact (maponpaths pr1 (!(nat_trans_ax η (x ,, y) (z ,, z) (f ,, g)))). } cbn. rewrite !assoc'. pose (p := maponpaths pr1 (nat_trans_eq_pointwise (pr22 LC) z)). cbn in p. rewrite !id_left, !id_right in p. refine (_ @ id_right _). apply maponpaths. exact p. Qed. Definition cocartesian_coprod_via_adj_to_coprods_sum_in2 : cocartesian_coprod_via_adj_to_coprods_in2 · cocartesian_coprod_via_adj_to_coprods_sum = g. Proof. unfold cocartesian_coprod_via_adj_to_coprods_in2. unfold cocartesian_coprod_via_adj_to_coprods_sum. rewrite !assoc. etrans. { apply maponpaths_2. exact (maponpaths dirprod_pr2 (!(nat_trans_ax η (x ,, y) (z ,, z) (f ,, g)))). } cbn. rewrite !assoc'. pose (p := maponpaths dirprod_pr2 (nat_trans_eq_pointwise (pr22 LC) z)). cbn in p. rewrite !id_left, !id_right in p. refine (_ @ id_right _). apply maponpaths. exact p. Qed. End Coproducts. Definition cocartesian_coprod_via_adj_to_coprods : BinCoproducts (pr1 C). Proof. intros x y. use make_BinCoproduct. - exact (cocartesian_coprod_via_adj_to_coprods_obj x y). - exact (cocartesian_coprod_via_adj_to_coprods_in1 x y). - exact (cocartesian_coprod_via_adj_to_coprods_in2 x y). - intros z f g. use iscontraprop1. + exact (cocartesian_coprod_via_adj_to_coprods_unique x y z f g). + simple refine (_ ,, _ ,, _). * exact (cocartesian_coprod_via_adj_to_coprods_sum x y z f g). * exact (cocartesian_coprod_via_adj_to_coprods_sum_in1 x y z f g). * exact (cocartesian_coprod_via_adj_to_coprods_sum_in2 x y z f g). Defined. End CoprodToAdj. Definition coprods_weq_cocartesian_coprod_via_adj (C : bicat_of_univ_cats) : BinCoproducts (pr1 C) ≃ cocartesian_coprod_via_adj C has_binprod_bicat_of_univ_cats. Proof. use weqimplimpl. - exact (coprods_to_cocartesian_coprod_via_adj C). - exact (cocartesian_coprod_via_adj_to_coprods C). - use impred ; intro x. use impred ; intro y. apply isaprop_BinCoproduct. exact (pr2 C). - apply isaprop_cocartesian_coprod_via_adj. exact univalent_cat_is_univalent_2_1. Defined. Definition coprods_weq_cocartesian_coprod (C : bicat_of_univ_cats) : BinCoproducts (pr1 C) ≃ cocartesian_coprod C := (invweq (cocartesian_coprod_weq_cocartesian_coprod_via_adj has_binprod_bicat_of_univ_cats C univalent_cat_is_univalent_2_1) ∘ coprods_weq_cocartesian_coprod_via_adj C)%weq. Definition initial_coprods_weq_cocartesian_ob (C : bicat_of_univ_cats) : Initial (pr1 C) × BinCoproducts (pr1 C) ≃ cocartesian_ob C. Proof. use weqdirprodf. - exact (initial_weq_cocartesian_initial C). - exact (coprods_weq_cocartesian_coprod C). Defined. UniMath-20231010/UniMath/Bicategories/OtherStructure/000077500000000000000000000000001451125700300222565ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/OtherStructure/ClassifyingDiscreteOpfib.v000066400000000000000000000251711451125700300273710ustar00rootroot00000000000000(*********************************************************** Classifying discrete opfibrations Contents: 1. Help definitions 2. Definition of classifying discrete opfibrations 3. Help functions ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.TransportLaws. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderPullback. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Import PullbackFunctions.Notations. Local Open Scope cat. Definition disc_sopfib {B : bicat} {e s : B} (p : e --> s) : UU := internal_sopfib p × discrete_1cell p. Section ClassifyingDiscreteOpfibration. Context {B : bicat} (HB : is_univalent_2_1 B) {e s : B} (p : e --> s) (Hp : disc_sopfib p). (** 1. Help definitions *) Definition disc_sopfib_of {x : B} (f : x --> s) : UU := ∑ (z : B) (pf : z --> x), disc_sopfib pf. Definition ob_of_disc_sopfib_of {x : B} {f : x --> s} (pf : disc_sopfib_of f) : B := pr1 pf. Coercion mor_of_disc_sopfib_of {x : B} {f : x --> s} (pf : disc_sopfib_of f) : ob_of_disc_sopfib_of pf --> x := pr12 pf. Definition mor_of_disc_sopfib_of_is_disc_sopfib {x : B} {f : x --> s} (pf : disc_sopfib_of f) : disc_sopfib pf := pr22 pf. Definition disc_sopfib_of_is_pb {x : B} {f : x --> s} (pf : disc_sopfib_of f) : UU := ∑ (ze : ob_of_disc_sopfib_of pf --> e) (γ : invertible_2cell (ze · p) (pf · f)), has_pb_ump (make_pb_cone _ ze pf γ). Definition map_to_disp_sopfib : UU := ∏ (x : B) (f : x --> s), ∑ (pf : disc_sopfib_of f), disc_sopfib_of_is_pb pf. Context (pb : map_to_disp_sopfib). Section ClassifyingDiscreteOpfibrationMor. Context {x : B} {f g : hom x s} (α : f --> g). Let φ_ob : B := pr11 (pb x f). Let χ_ob : B := pr11 (pb x g). Let φ : φ_ob --> x := pr121 (pb x f). Let χ : χ_ob --> x := pr121 (pb x g). Let φe : φ_ob --> e := pr12 (pb x f). Let φγ : invertible_2cell (φe · p) (φ · f) := pr122 (pb x f). Let Hφ : has_pb_ump (make_pb_cone φ_ob φe φ φγ) := pr222 (pb x f). Let χe : χ_ob --> e := pr12 (pb x g). Let χγ : invertible_2cell (χe · p) (χ · g) := pr122 (pb x g). Let Hχ : has_pb_ump (make_pb_cone χ_ob χe χ χγ) := pr222 (pb x g). Let ℓ : φ_ob --> e := pr1 (pr11 Hp φ_ob φe (φ · g) (φγ • (_ ◃ α))). Let ζ : φe ==> ℓ := pr12 (pr11 Hp φ_ob φe (φ · g) (φγ • (_ ◃ α))). Let γ : invertible_2cell (φ · g) (ℓ · p) := pr122 (pr11 Hp φ_ob φe (φ · g) (φγ • (_ ◃ α))). Let Hζ : is_opcartesian_2cell_sopfib p ζ := pr1 (pr222 (pr11 Hp φ_ob φe (φ · g) (φγ • (_ ◃ α)))). Definition mor_of_pb_disc_sopfib_mor_cone : pb_cone p g := make_pb_cone φ_ob ℓ φ (inv_of_invertible_2cell γ). Definition mor_of_pb_disc_sopfib_mor : φ_ob --> χ_ob := pb_ump_mor Hχ mor_of_pb_disc_sopfib_mor_cone. Definition pb_disc_sopfib_mor_preserves_opcartesian : mor_preserves_opcartesian φ χ mor_of_pb_disc_sopfib_mor. Proof. use mor_preserves_opcartesian_pb_ump_mor_alt. intros z h₁ h₂ β Hβ. use (is_opcartesian_2cell_sopfib_precomp _ (_ ◃ ζ)). - exact ((β ▹ _) • (_ ◃ ζ)). - apply Hp. exact Hζ. - use vcomp_is_opcartesian_2cell_sopfib. + exact (from_pb_opcartesian Hφ (pr1 Hp) _ Hβ). + apply Hp. exact Hζ. - abstract (rewrite vcomp_whisker ; apply idpath). Defined. Definition cell_of_pb_disc_sopfib_mor : invertible_2cell φ (mor_of_pb_disc_sopfib_mor · χ) := inv_of_invertible_2cell (pb_ump_mor_pr2 Hχ mor_of_pb_disc_sopfib_mor_cone). End ClassifyingDiscreteOpfibrationMor. Definition pb_disc_sopfib_mor {x : B} {f g : hom x s} (α : f --> g) : disc_sopfib_slice HB x ⟦ pr1 (pb _ f) , pr1 (pb _ g) ⟧. Proof. simple refine (_ ,, (_ ,, tt) ,, _) ; cbn. - exact (mor_of_pb_disc_sopfib_mor α). - exact (pb_disc_sopfib_mor_preserves_opcartesian α). - exact (cell_of_pb_disc_sopfib_mor α). Defined. (** 2. Definition of classifying discrete opfibrations *) Definition is_classifying_full : UU := ∏ (x : B) (f g : x --> s) (β : disc_sopfib_slice HB x ⟦ pr1 (pb _ f) , pr1 (pb _ g) ⟧), ∑ (α : f ==> g), pb_disc_sopfib_mor α = β. (** 3. Help functions *) Definition is_classifying_full_help : UU := ∏ (x : B) (f g : x --> s) (β : disc_sopfib_slice HB x ⟦ pr1 (pb _ f) , pr1 (pb _ g) ⟧), ∑ (α : f ==> g) (γ : mor_of_pb_disc_sopfib_mor α ==> pr1 β) (Hγ : is_invertible_2cell γ), γ ▹ pr121 (pb x g) = pb_ump_mor_pr2 (pr222 (pb x g)) (mor_of_pb_disc_sopfib_mor_cone α) • pr122 β. Definition make_is_classifying_full (H : is_classifying_full_help) : is_classifying_full. Proof. intros x f g β. specialize (H x f g β). refine (pr1 H ,, _). use (isotoid_2_1 (pr1 (is_discrete_disp_map_slice HB (discrete_sopfib_subbicat_props B HB) (discrete_sopfib_disp_map_bicat_in_discrete B) x))). use make_invertible_2cell. - refine (pr12 H ,, _). abstract (cbn ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; exact (pr222 H)). - apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn. exact (pr122 H). Defined. Definition is_classifying_faithful : UU := ∏ (x : B) (f g : x --> s) (α β : f ==> g), pb_disc_sopfib_mor α = pb_disc_sopfib_mor β → α = β. Definition is_classifying : UU := is_classifying_full × is_classifying_faithful. Definition eq_disc_slice_mor {x : B} {g₁ g₂ : disc_sopfib_slice HB x} {α β : g₁ --> g₂} (γ : invertible_2cell (pr1 α) (pr1 β)) (r : pr22 α • (γ ▹ _) = pr22 β) : α = β. Proof. use total2_paths_f. - exact (isotoid_2_1 HB γ). - use dirprod_paths. + use pathsdirprod ; [ apply isaprop_mor_preserves_opcartesian | apply isapropunit ]. + cbn. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } etrans. { refine (maponpaths (λ z, pr1 z) _). exact (pr2_transportf _ _). } cbn. refine (pr1_transportf (isotoid_2_1 HB γ) _ @ _). rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function. cbn. rewrite id2_left. rewrite isotoid_2_1_rwhisker. rewrite idtoiso_2_1_isotoid_2_1. cbn. exact r. Qed. Definition eq_slice_to_inv2cell {x : B} {g₁ g₂ : disc_sopfib_slice HB x} {α β : g₁ --> g₂} (q : α = β) : invertible_2cell (pr1 α) (pr1 β) := idtoiso_2_1 _ _ (maponpaths pr1 q). Definition eq_slice_to_coh {x : B} {g₁ g₂ : disc_sopfib_slice HB x} {α β : g₁ --> g₂} (q : α = β) : pr122 α • (eq_slice_to_inv2cell q ▹ _) = pr122 β. Proof. pose (maponpaths pr1 (maponpaths dirprod_pr2 (fiber_paths q))) as r. cbn in r. refine (_ @ r). refine (!_). etrans. { apply maponpaths. apply (@pr2_transportf (pr1 g₁ --> pr1 g₂) (λ z, mor_preserves_opcartesian (pr12 g₁) (pr12 g₂) z × unit) (λ z, invertible_2cell (pr12 g₁) (z · pr12 g₂))). } etrans. { apply (@pr1_transportf (pr1 g₁ --> pr1 g₂) (λ z, pr12 g₁ ==> z · pr12 g₂)). } rewrite transport_two_cell_FlFr. rewrite maponpaths_for_constant_function. cbn. rewrite id2_left. apply maponpaths. rewrite <- idtoiso_2_1_rwhisker. apply idpath. Qed. Definition is_classifying_faithful_help : UU := ∏ (x : B) (f g : x --> s) (α β : f ==> g) (γ : invertible_2cell (mor_of_pb_disc_sopfib_mor α) (mor_of_pb_disc_sopfib_mor β)) (q : (γ ▹ pr121 (pb x g)) • pb_ump_mor_pr2 (pr222 (pb x g)) (mor_of_pb_disc_sopfib_mor_cone β) = (pb_ump_mor_pr2 (pr222 (pb x g)) (mor_of_pb_disc_sopfib_mor_cone α))), α = β. Definition make_is_classifying_faithful (H : is_classifying_faithful_help) : is_classifying_faithful. Proof. intros x f g α β q. simple refine (H x f g α β _ _). - exact (eq_slice_to_inv2cell q). - use vcomp_move_R_Mp ; [ apply property_from_invertible_2cell | ]. use vcomp_move_L_pM ; [ apply property_from_invertible_2cell | ]. exact (eq_slice_to_coh q). Qed. Definition make_is_classifying (H₁ : is_classifying_full_help) (H₂ : is_classifying_faithful_help) : is_classifying. Proof. split. - use make_is_classifying_full. exact H₁. - use make_is_classifying_faithful. exact H₂. Defined. End ClassifyingDiscreteOpfibration. UniMath-20231010/UniMath/Bicategories/OtherStructure/Cores.v000066400000000000000000000104361451125700300235240ustar00rootroot00000000000000(********************************************************************* Cores in a bicategory The core of a category is the subgroupoid consisting of only the isomorphisms. This construction can be specified in arbitrary bicategories. The definition we use here, is inspired by https://ncatlab.org/nlab/show/core+in+a+2-category Contents 1. Groupoidal objects 2. Pseudofunctor from groupoids 3. Having cores *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Eso. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.DisplayedBicats.Examples.BicatOfInvertibles. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Local Open Scope cat. (** 1. Groupoidal objects *) Definition groupoidal {B : bicat} (x : B) : UU := ∏ (w : B) (f g : w --> x) (α : f ==> g), is_invertible_2cell α. Definition isaprop_groupoidal {B : bicat} (x : B) : isaprop (groupoidal x). Proof. do 4 (use impred ; intro). apply isaprop_is_invertible_2cell. Qed. Definition bicat_of_groupoidal (B : bicat) : bicat := fullsubbicat B groupoidal. Definition is_univalent_2_1_bicat_of_groupoidal {B : bicat} (HB_2_1 : is_univalent_2_1 B) : is_univalent_2_1 (bicat_of_groupoidal B). Proof. apply is_univalent_2_1_fullsubbicat. exact HB_2_1. Defined. Definition is_univalent_2_0_bicat_of_groupoidal {B : bicat} (HB_2 : is_univalent_2 B) : is_univalent_2_0 (bicat_of_groupoidal B). Proof. apply is_univalent_2_0_fullsubbicat. - exact HB_2. - exact isaprop_groupoidal. Defined. Definition is_univalent_2_bicat_of_groupoidal {B : bicat} (HB_2 : is_univalent_2 B) : is_univalent_2 (bicat_of_groupoidal B). Proof. apply is_univalent_2_fullsubbicat. - exact HB_2. - exact isaprop_groupoidal. Defined. (** 2. Pseudofunctor from groupoids *) Definition groupoidal_to_inv2cells_data (B : bicat) : psfunctor_data (bicat_of_groupoidal B) (bicat_of_inv2cells B). Proof. use make_psfunctor_data. - exact (λ x, pr1 x ,, tt). - exact (λ _ _ f, f). - simple refine (λ x y f g α, pr1 α ,, _). exact (pr2 y (pr1 x) (pr1 f) (pr1 g) (pr1 α)). - refine (λ x, id2 _ ,, _) ; cbn. is_iso. - refine (λ _ _ _ f g, id2 _ ,, _) ; cbn. is_iso. Defined. Definition groupoidal_to_inv2cells_laws (B : bicat) : psfunctor_laws (groupoidal_to_inv2cells_data B). Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ]) ; cbn in *. - apply idpath. - apply idpath. - rewrite id2_rwhisker. rewrite !id2_left. apply idpath. - rewrite lwhisker_id2. rewrite !id2_left. apply idpath. - rewrite id2_rwhisker, lwhisker_id2. rewrite !id2_left, !id2_right. apply idpath. - rewrite id2_left, id2_right. apply idpath. - rewrite id2_left, id2_right. apply idpath. Qed. Definition groupoidal_to_inv2cells (B : bicat) : psfunctor (bicat_of_groupoidal B) (bicat_of_inv2cells B). Proof. use make_psfunctor. - exact (groupoidal_to_inv2cells_data B). - exact (groupoidal_to_inv2cells_laws B). - split ; intros ; apply is_invertible_2cell_bicat_of_inv2cells. Defined. (** 3. Having cores *) Definition has_cores (B : bicat) : UU := ∑ (R : right_universal_arrow (groupoidal_to_inv2cells B)), ∏ (x : B), let ε := pr1 (pr12 R (x ,, tt)) in is_eso ε × pseudomonic_1cell ε. UniMath-20231010/UniMath/Bicategories/OtherStructure/DualityInvolution.v000066400000000000000000000362551451125700300261620ustar00rootroot00000000000000(** Duality involutions of bicategories Contents: 1. Data of duality involutions 2. Counit of duality involution 3. Laws of duality involutions 4. Duality involutions 5. Accessors for duality involutions *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Op2OfPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.OpFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Transformations.Examples.Whiskering. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Local Open Scope cat. (** 1. Data of duality involutions *) Section DualityInvolutionData. Context {B : bicat} (L : psfunctor (op2_bicat B) B). Let R : psfunctor B (op2_bicat B) := op2_psfunctor L. Definition duality_involution_data : UU := ∑ (η : pstrans (id_psfunctor B) (comp_psfunctor L R)) (ηinv : pstrans (comp_psfunctor L R) (id_psfunctor B)), (invertible_modification (id₁ _) (η · ηinv)) × (invertible_modification (ηinv · η) (id₁ _)) × (∏ (x : op2_bicat B), invertible_2cell (η (L x)) (#L (η x))). Definition make_duality_involution_data (η : pstrans (id_psfunctor B) (comp_psfunctor L R)) (ηinv : pstrans (comp_psfunctor L R) (id_psfunctor B)) (m₁ : invertible_modification (id₁ _) (η · ηinv)) (m₂ : invertible_modification (ηinv · η) (id₁ _)) (t : ∏ (x : op2_bicat B), invertible_2cell (η (L x)) (#L (η x))) : duality_involution_data := η ,, ηinv ,, m₁ ,, m₂ ,, t. End DualityInvolutionData. Section Projections. Context {B : bicat} {L : psfunctor (op2_bicat B) B} (d : duality_involution_data L). Let R : psfunctor B (op2_bicat B) := op2_psfunctor L. Definition unit_of_duality : pstrans (id_psfunctor B) (comp_psfunctor L R) := pr1 d. Let η := unit_of_duality. Definition unit_inv_of_duality : pstrans (comp_psfunctor L R) (id_psfunctor B) := pr12 d. Let ηinv := unit_inv_of_duality. Definition unit_unit_inv_of_duality : invertible_modification (id₁ _) (η · ηinv) := pr122 d. Definition unit_inv_unit_of_duality : invertible_modification (ηinv · η) (id₁ _) := pr1 (pr222 d). Definition triangle_data_of_duality (x : op2_bicat B) : invertible_2cell (η (L x)) (#L (η x)) := pr2 (pr222 d) x. End Projections. (** 2. Counit of duality involution *) Section CounitFromDualityInvolution. Context {B : bicat} {L : psfunctor (op2_bicat B) B} (d : duality_involution_data L). Let R : psfunctor B (op2_bicat B) := op2_psfunctor L. Let η := unit_of_duality d. Let ηinv := unit_inv_of_duality d. Let ηηinv := unit_unit_inv_of_duality d. Let ηinvη := unit_inv_unit_of_duality d. Let t := triangle_data_of_duality d. Definition left_adjoint_equivalance_duality_unit : left_adjoint_equivalence η. Proof. use equiv_to_adjequiv. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact ηinv. - exact (pr1 ηηinv). - exact (pr1 ηinvη). - apply property_from_invertible_2cell. - apply property_from_invertible_2cell. Defined. Definition duality_counit_data : pstrans_data (comp_psfunctor R L) (id_psfunctor (op2_bicat B)). Proof. use make_pstrans_data. - refine (λ x, _). exact (ηinv x : L(L x) --> x). - intros x y f ; cbn. use weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (psnaturality_of ηinv f)). Defined. Definition duality_counit_is_pstrans : is_pstrans duality_counit_data. Proof. repeat split. - intros x y f g α ; cbn. use vcomp_move_R_pM ; [ is_iso | ]. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. exact (psnaturality_natural ηinv _ _ _ _ α). - intro x ; cbn. rewrite lwhisker_id2, id2_right. pose (pstrans_id ηinv x) as p. cbn in p. rewrite lwhisker_id2 in p. rewrite id2_left in p. use vcomp_move_L_pM. { is_iso. exact (psfunctor_is_iso L (weq_op2_invertible_2cell _ _ (psfunctor_id L x))). } use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. exact (!p). - intros x y z f g ; cbn. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite lwhisker_id2. pose (p := pstrans_comp ηinv f g). cbn in p. rewrite lwhisker_id2, id2_left in p. use vcomp_move_L_Mp ; [ is_iso | ]. { exact (psfunctor_is_iso L (weq_op2_invertible_2cell _ _ (psfunctor_comp L f g))). } refine (id2_left _ @ _). exact (!p). Qed. Definition duality_counit : pstrans (comp_psfunctor R L) (id_psfunctor (op2_bicat B)). Proof. use make_pstrans. - exact duality_counit_data. - exact duality_counit_is_pstrans. Defined. Let ε : pstrans (comp_psfunctor R L) (id_psfunctor (op2_bicat B)) := duality_counit. Definition duality_counit_inv_data : pstrans_data (id_psfunctor (op2_bicat B)) (comp_psfunctor R L). Proof. use make_pstrans_data. - refine (λ x, _). exact (η x : x --> L(L x)). - intros x y f ; cbn. use weq_op2_invertible_2cell. exact (inv_of_invertible_2cell (psnaturality_of η f)). Defined. Definition duality_counit_inv_is_pstrans : is_pstrans duality_counit_inv_data. Proof. repeat split. - intros x y f g α ; cbn. use vcomp_move_R_pM ; [ is_iso | ]. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ]. cbn. exact (psnaturality_natural η _ _ _ _ α). - intro x ; cbn. rewrite id2_rwhisker, id2_left. pose (pstrans_id η x) as p. cbn in p. rewrite id2_rwhisker in p. rewrite id2_right in p. use vcomp_move_R_Mp. { is_iso. exact (psfunctor_is_iso L (weq_op2_invertible_2cell _ _ (psfunctor_id L x))). } use vcomp_move_L_pM ; [ is_iso | ] ; cbn. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. exact (!p). - intros x y z f g ; cbn. rewrite id2_rwhisker, id2_left. pose (p := pstrans_comp η f g). cbn in p. rewrite id2_rwhisker, id2_right in p. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. use vcomp_move_R_pM. { is_iso. exact (psfunctor_is_iso L (weq_op2_invertible_2cell _ _ (psfunctor_comp L f g))). } exact (!p). Qed. Definition duality_counit_inv : pstrans (id_psfunctor (op2_bicat B)) (comp_psfunctor R L). Proof. use make_pstrans. - exact duality_counit_inv_data. - exact duality_counit_inv_is_pstrans. Defined. Let εinv : pstrans (id_psfunctor (op2_bicat B)) (comp_psfunctor R L) := duality_counit_inv. Definition duality_counit_counit_inv_data : invertible_modification_data (id₁ _) (ε · εinv). Proof. intro x ; cbn. use weq_op2_invertible_2cell. exact (invertible_modcomponent_of ηinvη x). Defined. Definition duality_counit_counit_inv_is_modif : is_modification duality_counit_counit_inv_data. Proof. intros x y f. use vcomp_move_R_pM. { apply property_from_invertible_2cell. } refine (_ @ vassocl _ _ _). use vcomp_move_L_Mp. { is_iso. apply property_from_invertible_2cell. } exact (modnaturality_of (pr1 ηinvη) _ _ f). Qed. Definition duality_counit_counit_inv : invertible_modification (id₁ _) (ε · εinv). Proof. use make_invertible_modification. - exact duality_counit_counit_inv_data. - exact duality_counit_counit_inv_is_modif. Defined. Definition duality_counit_inv_counit_data : invertible_modification_data (εinv · ε) (id₁ _). Proof. intro x ; cbn. use weq_op2_invertible_2cell. exact (invertible_modcomponent_of ηηinv x). Defined. Opaque comp_psfunctor. Definition duality_counit_inv_counit_is_modif : is_modification duality_counit_inv_counit_data. Proof. intros x y f. use vcomp_move_R_pM. { apply property_from_invertible_2cell. } refine (_ @ vassocl _ _ _). use vcomp_move_L_Mp. { is_iso. apply property_from_invertible_2cell. } etrans. { apply maponpaths. cbn. apply idpath. } refine (!_). etrans. { apply maponpaths_2. cbn. apply idpath. } pose (p := modnaturality_of (pr1 ηηinv) _ _ f). cbn in p. exact (!p). Qed. Transparent comp_psfunctor. Definition duality_counit_inv_counit : invertible_modification (εinv · ε) (id₁ _). Proof. use make_invertible_modification. - exact duality_counit_inv_counit_data. - exact duality_counit_inv_counit_is_modif. Defined. Definition left_equivalance_duality_counit : left_equivalence ε. Proof. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact εinv. - exact (pr1 duality_counit_counit_inv). - exact (pr1 duality_counit_inv_counit). - exact (pr2 duality_counit_counit_inv). - exact (pr2 duality_counit_inv_counit). Defined. Definition left_adjoint_equivalance_duality_counit : left_adjoint_equivalence ε := equiv_to_adjequiv ε left_equivalance_duality_counit. End CounitFromDualityInvolution. (** 3. Laws of duality involutions *) Section LawsDualityInvolution. Context {B : bicat} {L : psfunctor (op2_bicat B) B} (d : duality_involution_data L). Let R : psfunctor B (op2_bicat B) := op2_psfunctor L. Let η := unit_of_duality d. Let ηinv := unit_inv_of_duality d. Let ηηinv := unit_unit_inv_of_duality d. Let ηinvη := unit_inv_unit_of_duality d. Let t := triangle_data_of_duality d. Definition duality_coherency_lhs (x : B) : η x · # L (# L (η x)) ==> η x · # L (η (L x)) := psnaturality_of η (η x) • (η x ◃ t (L x)). Definition duality_coherency_rhs (x : B) : η x · # L (# L (η x)) ==> η x · # L (η (L x)) := η x ◃ ##L (t x). Definition duality_coherency := ∏ (x : B), duality_coherency_lhs x = duality_coherency_rhs x. Let εinv := duality_counit_inv d. Definition duality_modification_data : invertible_modification_data (linvunitor_pstrans _ · right_whisker L η) (rinvunitor_pstrans _ · left_whisker L εinv · lassociator_pstrans _ _ _). Proof. intros x ; cbn. exact (comp_of_invertible_2cell (lunitor_invertible_2cell _) (comp_of_invertible_2cell (t x) (comp_of_invertible_2cell (linvunitor_invertible_2cell _) (rinvunitor_invertible_2cell _)))). Defined. Definition duality_involution_laws : UU := duality_coherency × is_modification duality_modification_data. End LawsDualityInvolution. (** 4. Duality involutions *) Definition duality_involution {B : bicat} (L : psfunctor (op2_bicat B) B) : UU := ∑ (d : duality_involution_data L), duality_involution_laws d. Coercion duality_involution_to_data {B : bicat} {L : psfunctor (op2_bicat B) B} (d : duality_involution L) : duality_involution_data L := pr1 d. Definition duality_involution_to_laws {B : bicat} {L : psfunctor (op2_bicat B) B} (d : duality_involution L) : duality_involution_laws (duality_involution_to_data d) := pr2 d. (** 5. Accessors for duality involutions *) Section DualityInvolutionAccessors. Context {B : bicat} (L : psfunctor (op2_bicat B) B) (HL : duality_involution L). Let R : psfunctor B (op2_bicat B) := op2_psfunctor L. Let ε : pstrans (comp_psfunctor R L) (id_psfunctor _) := duality_counit HL. Definition duality_transpose {x y : B} (f : x --> L y) : L x --> y := #L f · ε y. Definition duality_transpose_cell {x y : B} {f₁ f₂ : x --> L y} (τ : f₂ ==> f₁) : duality_transpose f₁ ==> duality_transpose f₂ := ##L τ ▹ ε y. Definition duality_transpose_functor_data (x y : B) : functor_data (@hom (op2_bicat B) x (L y)) (hom (L x) y). Proof. use make_functor_data. - exact duality_transpose. - exact (λ _ _ τ, duality_transpose_cell τ). Defined. Definition duality_transpose_is_functor (x y : B) : is_functor (duality_transpose_functor_data x y). Proof. split. - intro f ; cbn. refine (_ @ id2_rwhisker _ _). apply maponpaths. apply (psfunctor_id2 L). - intros f₁ f₂ f₃ τ₁ τ₂ ; cbn. refine (_ @ !(rwhisker_vcomp _ _ _)). apply maponpaths. apply (psfunctor_vcomp L). Qed. Definition duality_transpose_functor (x y : B) : @hom (op2_bicat B) x (L y) ⟶ hom (L x) y. Proof. use make_functor. - exact (duality_transpose_functor_data x y). - exact (duality_transpose_is_functor x y). Defined. End DualityInvolutionAccessors. UniMath-20231010/UniMath/Bicategories/OtherStructure/Examples/000077500000000000000000000000001451125700300240345ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/OtherStructure/Examples/StructureBicatOfEnrichedCats.v000066400000000000000000000257331451125700300317420ustar00rootroot00000000000000(***************************************************************** Structure on the bicategory of enriched category In this file, we construct a duality involution of the bicategory of enriched categories. Contents 1. Duality involution on enriched categories *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Op2OfPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.OpFunctorEnriched. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.OtherStructure.DualityInvolution. Local Open Scope cat. (** 1. Duality involution on enriched categories *) Section DualityInvolutionEnriched. Context (V : sym_monoidal_cat). Definition bicat_of_enriched_cat_duality_unit_data : pstrans_data (id_psfunctor (bicat_of_enriched_cats V)) (comp_psfunctor (op_enriched_psfunctor V) (op2_psfunctor (op_enriched_psfunctor V))). Proof. use make_pstrans_data. - cbn. exact (λ E, functor_identity _ ,, op_enriched_unit V (pr2 E)). - intros E₁ E₂ F. use make_invertible_2cell. + exact (op_unit_nat_trans (pr1 F) ,, op_enriched_unit_naturality V (pr2 F)). + use make_is_invertible_2cell. * exact (nat_z_iso_to_trans_inv (op_unit_nat_z_iso (pr1 F)) ,, op_enriched_unit_naturality_inv V (pr2 F)). * abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). * abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). Defined. Proposition bicat_of_enriched_cat_duality_unit_is_pstrans : is_pstrans bicat_of_enriched_cat_duality_unit_data. Proof. repeat split. - intros E₁ E₂ F G α. use eq_2cell_enriched. intro x ; cbn. rewrite id_left, id_right. apply idpath. - intros E. use eq_2cell_enriched. intros x ; cbn. apply idpath. - intros E₁ E₂ E₃ F G. use eq_2cell_enriched. intros x ; cbn. rewrite functor_id. rewrite !id_left. apply idpath. Qed. Definition bicat_of_enriched_cat_duality_unit : pstrans (id_psfunctor (bicat_of_enriched_cats V)) (comp_psfunctor (op_enriched_psfunctor V) (op2_psfunctor (op_enriched_psfunctor V))). Proof. use make_pstrans. - exact bicat_of_enriched_cat_duality_unit_data. - exact bicat_of_enriched_cat_duality_unit_is_pstrans. Defined. Definition bicat_of_enriched_cat_duality_unit_inv_data : pstrans_data (comp_psfunctor (op_enriched_psfunctor V) (op2_psfunctor (op_enriched_psfunctor V))) (id_psfunctor (bicat_of_enriched_cats V)). Proof. use make_pstrans_data. - cbn. exact (λ E, functor_identity _ ,, op_enriched_unit_inv V (pr2 E)). - intros E₁ E₂ F. use make_invertible_2cell. + exact (op_unit_inv_nat_trans (pr1 F) ,, op_enriched_unit_inv_naturality V (pr2 F)). + use make_is_invertible_2cell. * exact (nat_z_iso_to_trans_inv (op_unit_inv_nat_z_iso (pr1 F)) ,, op_enriched_unit_inv_naturality_inv V (pr2 F)). * abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). * abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). Defined. Proposition bicat_of_enriched_cat_duality_unit_inv_is_pstrans : is_pstrans bicat_of_enriched_cat_duality_unit_inv_data. Proof. simple refine (_ ,, _ ,, _). - intros E₁ E₂ F G α ; simpl. use eq_2cell_enriched. intro x ; cbn. rewrite id_left, id_right. apply idpath. - intros E. Opaque comp_psfunctor. use eq_2cell_enriched. Transparent comp_psfunctor. intros x ; cbn. rewrite !id_left. apply idpath. - intros E₁ E₂ E₃ F G. Opaque comp_psfunctor. use eq_2cell_enriched. Transparent comp_psfunctor. intros x ; cbn. rewrite !id_left, !id_right. exact (!(functor_id _ _)). Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition bicat_of_enriched_cat_duality_unit_inv : pstrans (comp_psfunctor (op_enriched_psfunctor V) (op2_psfunctor (op_enriched_psfunctor V))) (id_psfunctor (bicat_of_enriched_cats V)). Proof. use make_pstrans. - exact bicat_of_enriched_cat_duality_unit_inv_data. - exact bicat_of_enriched_cat_duality_unit_inv_is_pstrans. Defined. Definition bicat_of_enriched_cat_duality_unit_unit_inv_data : invertible_modification_data (id₁ (id_psfunctor (bicat_of_enriched_cats V))) (bicat_of_enriched_cat_duality_unit · bicat_of_enriched_cat_duality_unit_inv). Proof. intros E. use make_invertible_2cell. - exact (op_unit_unit_inv_nat_trans _ ,, op_enriched_unit_unit_inv V (pr2 E)). - use make_is_invertible_2cell. + exact (nat_z_iso_to_trans_inv (op_unit_unit_inv_nat_z_iso _) ,, op_enriched_unit_unit_inv_inv V (pr2 E)). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). Defined. Proposition bicat_of_enriched_cat_duality_unit_unit_inv_laws : is_modification bicat_of_enriched_cat_duality_unit_unit_inv_data. Proof. intros E₁ E₂ F. use eq_2cell_enriched. intros x ; cbn. rewrite (functor_id (pr1 F)), !id_left. apply idpath. Qed. Definition bicat_of_enriched_cat_duality_unit_unit_inv : invertible_modification (id₁ (id_psfunctor (bicat_of_enriched_cats V))) (bicat_of_enriched_cat_duality_unit · bicat_of_enriched_cat_duality_unit_inv). Proof. use make_invertible_modification. - exact bicat_of_enriched_cat_duality_unit_unit_inv_data. - exact bicat_of_enriched_cat_duality_unit_unit_inv_laws. Defined. Definition bicat_of_enriched_cat_duality_unit_inv_unit_data : invertible_modification_data (bicat_of_enriched_cat_duality_unit_inv · bicat_of_enriched_cat_duality_unit) (id₁ _). Proof. intros E. use make_invertible_2cell. - exact (op_unit_inv_unit_nat_trans _ ,, op_enriched_unit_inv_unit V (pr2 E)). - use make_is_invertible_2cell. + exact (nat_z_iso_to_trans_inv (op_unit_inv_unit_nat_z_iso _) ,, op_enriched_unit_inv_unit_inv V (pr2 E)). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). Defined. Proposition bicat_of_enriched_cat_duality_unit_inv_unit_laws : is_modification bicat_of_enriched_cat_duality_unit_inv_unit_data. Proof. intros E₁ E₂ F. use eq_2cell_enriched. intro x ; cbn. rewrite (functor_id (pr1 F)), !id_left. apply idpath. Qed. Definition bicat_of_enriched_cat_duality_unit_inv_unit : invertible_modification (bicat_of_enriched_cat_duality_unit_inv · bicat_of_enriched_cat_duality_unit) (id₁ _). Proof. use make_invertible_modification. - exact bicat_of_enriched_cat_duality_unit_inv_unit_data. - exact bicat_of_enriched_cat_duality_unit_inv_unit_laws. Defined. Definition bicat_of_enriched_cat_duality_triangle (E : op2_bicat (bicat_of_enriched_cats V)) : invertible_2cell (bicat_of_enriched_cat_duality_unit (op_enriched_psfunctor V E)) (# (op_enriched_psfunctor V) (bicat_of_enriched_cat_duality_unit E)). Proof. use make_invertible_2cell. - exact (op_triangle_nat_trans _ ,, op_enriched_triangle V (pr2 E)). - use make_is_invertible_2cell. + exact (nat_z_iso_to_trans_inv (op_triangle_nat_z_iso _) ,, op_enriched_triangle_inv V (pr2 E)). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). + abstract (use eq_2cell_enriched ; intros x ; cbn ; apply id_left). Defined. Definition bicat_of_enriched_cat_duality_data : duality_involution_data (op_enriched_psfunctor V). Proof. use make_duality_involution_data. - exact bicat_of_enriched_cat_duality_unit. - exact bicat_of_enriched_cat_duality_unit_inv. - exact bicat_of_enriched_cat_duality_unit_unit_inv. - exact bicat_of_enriched_cat_duality_unit_inv_unit. - exact bicat_of_enriched_cat_duality_triangle. Defined. Definition bicat_of_enriched_cat_duality_laws : duality_involution_laws bicat_of_enriched_cat_duality_data. Proof. split. - intro E. use eq_2cell_enriched. intro x ; cbn. apply id_left. - intros E₁ E₂ F. use eq_2cell_enriched. intro x ; cbn. rewrite !id_left. exact (!(functor_id _ _)). Qed. Definition bicat_of_enriched_cat_duality : duality_involution (op_enriched_psfunctor V) := bicat_of_enriched_cat_duality_data ,, bicat_of_enriched_cat_duality_laws. End DualityInvolutionEnriched. UniMath-20231010/UniMath/Bicategories/OtherStructure/Examples/StructureBicatOfUnivCats.v000066400000000000000000000556671451125700300311530ustar00rootroot00000000000000(** Duality involutions of bicategories Contents: 1. Duality involution on categories 2. Classifying discrete opfibration 3. Cartesian closed 4. Cores 4.1 Groupoidal objects 4.2 The coreflection *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Elements. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.Core. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.CategoryTheory.DisplayedCats.Examples. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Require Import UniMath.Bicategories.DisplayedBicats.Examples.BicatOfInvertibles. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Eso. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms. Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Examples.FibrationsInBicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Examples.EsosInBicatOfUnivCats. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Op2OfPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.OpFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.ConstProduct. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.OtherStructure.ClassifyingDiscreteOpfib. Require Import UniMath.Bicategories.OtherStructure.DualityInvolution. Require Import UniMath.Bicategories.OtherStructure.Exponentials. Require Import UniMath.Bicategories.OtherStructure.Cores. Local Open Scope cat. (** 1. Duality involution on categories *) Definition op_unit_data : pstrans_data (id_psfunctor _) (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)). Proof. use make_pstrans_data. - exact (λ C, functor_identity _). - intros C₁ C₂ F. use nat_z_iso_to_invertible_2cell. exact (op_unit_nat_z_iso F). Defined. Definition op_unit_is_pstrans : is_pstrans op_unit_data. Proof. repeat split ; intro ; intros ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; cbn ; rewrite ?id_left, ?id_right. - apply idpath. - apply idpath. - exact (!(functor_id _ _)). Qed. Definition op_unit : pstrans (id_psfunctor _) (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)). Proof. use make_pstrans. - exact op_unit_data. - exact op_unit_is_pstrans. Defined. Definition op_unit_inv_data : pstrans_data (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)) (id_psfunctor _). Proof. use make_pstrans_data. - exact (λ C, functor_identity _). - intros C₁ C₂ F. use nat_z_iso_to_invertible_2cell. exact (op_unit_inv_nat_z_iso F). Defined. Definition op_unit_inv_is_pstrans : is_pstrans op_unit_inv_data. Proof. repeat split ; intro ; intros ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; cbn ; rewrite ?id_left, ?id_right. - apply idpath. - apply idpath. - exact (!(functor_id _ _)). Qed. Definition op_unit_inv : pstrans (comp_psfunctor op_psfunctor (op2_psfunctor op_psfunctor)) (id_psfunctor _). Proof. use make_pstrans. - exact op_unit_inv_data. - exact op_unit_inv_is_pstrans. Defined. Definition op_triangle (C : op2_bicat bicat_of_univ_cats) : invertible_2cell (op_unit (op_psfunctor C)) (# op_psfunctor (op_unit C)). Proof. use nat_z_iso_to_invertible_2cell. exact (op_triangle_nat_z_iso _). Defined. Definition op_unit_unit_inv_data : invertible_modification_data (id₁ _) (op_unit · op_unit_inv). Proof. intro C. use nat_z_iso_to_invertible_2cell. exact (op_unit_unit_inv_nat_z_iso _). Defined. Definition op_unit_unit_inv_is_modif : is_modification op_unit_unit_inv_data. Proof. intros C₁ C₂ F. use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite !id_left, !id_right. exact (!(functor_id _ _)). Qed. Definition op_unit_unit_inv : invertible_modification (id₁ _) (op_unit · op_unit_inv). Proof. use make_invertible_modification. - exact op_unit_unit_inv_data. - exact op_unit_unit_inv_is_modif. Defined. Definition op_unit_inv_unit_data : invertible_modification_data (op_unit_inv · op_unit) (id₁ _). Proof. intro C. use nat_z_iso_to_invertible_2cell. exact (op_unit_inv_unit_nat_z_iso _). Defined. Definition op_unit_inv_unit_is_modif : is_modification op_unit_inv_unit_data. Proof. intros C₁ C₂ F. use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite !id_left, !id_right. exact (!(functor_id _ _)). Qed. Definition op_unit_inv_unit : invertible_modification (op_unit_inv · op_unit) (id₁ _). Proof. use make_invertible_modification. - exact op_unit_inv_unit_data. - exact op_unit_inv_unit_is_modif. Defined. Definition bicat_of_univ_cat_duality_involution_data : duality_involution_data op_psfunctor. Proof. use make_duality_involution_data. - exact op_unit. - exact op_unit_inv. - exact op_unit_unit_inv. - exact op_unit_inv_unit. - exact op_triangle. Defined. Definition bicat_of_univ_cat_duality_laws : duality_involution_laws bicat_of_univ_cat_duality_involution_data. Proof. split. - intro C. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply id_left. - intros C₁ C₂ F. use nat_trans_eq ; [ apply homset_property | ]. intro ; cbn. rewrite !id_left. exact (!(functor_id _ _)). Qed. Definition bicat_of_univ_cat_duality : duality_involution op_psfunctor := bicat_of_univ_cat_duality_involution_data ,, bicat_of_univ_cat_duality_laws. (** 2. Classifying discrete opfibration *) Definition disc_sopfib_cat_of_elems_forgetful {C : univalent_category} (P : C ⟶ HSET) : @disc_sopfib bicat_of_univ_cats (univalent_cat_of_elems P) C (cat_of_elems_forgetful P). Proof. split. - apply street_opfib_is_internal_sopfib. apply opfibration_is_street_opfib. apply disp_cat_of_elems_opcleaving. - split. + apply cat_faithful_is_faithful_1cell. apply pr1_category_faithful. intro ; intros. apply disp_mor_elems_isaprop. + apply cat_conservative_is_conservative_1cell. apply groupoidal_disp_cat_to_conservative. intro ; intros. apply is_z_iso_disp_cat_of_elems. Defined. Section CategoryOfElementsHasPbUMP. Context {C : bicat_of_univ_cats} (P : C --> HSET_univalent_category). Let F₁ : bicat_of_univ_cats ⟦ univalent_cat_of_elems P , pointed_sets_univalent ⟧ := cat_of_elems_to_pointed P. Let F₂ : bicat_of_univ_cats ⟦ univalent_cat_of_elems P, C ⟧ := cat_of_elems_forgetful P. Definition cat_of_elems_inv2cell : invertible_2cell (F₁ · set_of_pointed_set) (F₂ · P). Proof. use invertible_2cell_is_nat_z_iso. exact (cat_of_elems_commute_z_iso P). Defined. Let cone : @pb_cone bicat_of_univ_cats _ _ _ set_of_pointed_set P := make_pb_cone _ _ _ cat_of_elems_inv2cell. Definition cat_of_elems_pb_ump_1 : pb_ump_1 cone. Proof. intro q. use make_pb_1cell. - cbn. apply (functor_to_cat_of_elems _ (pb_cone_pr1 q) (pb_cone_pr2 q)). apply invertible_2cell_to_nat_z_iso. apply (pb_cone_cell q). - apply nat_z_iso_to_invertible_2cell. apply functor_to_cat_of_elems_pointed. - apply nat_z_iso_to_invertible_2cell. apply functor_to_cat_of_elems_forgetful. - abstract (use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; use funextsec ; intro z ; cbn ; cbn in * ; refine (_ @ !(eqtohomot (functor_id P (pr1 (pb_cone_pr2 q) x)) _)) ; exact (!(eqtohomot (nat_trans_eq_pointwise (vcomp_linv (pb_cone_cell q)) x) z))). Defined. Definition cat_of_elems_pb_ump_2 : pb_ump_2 cone. Proof. intros C' G₁ G₂ τ₁ τ₂ p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; use subtypePath ; [ intro ; apply disp_mor_elems_isaprop | ] ; exact (nat_trans_eq_pointwise (pr22 φ₁) x @ !(nat_trans_eq_pointwise (pr22 φ₂) x))). - simple refine (_ ,, _ ,, _). + refine (nat_trans_to_cat_of_elems P τ₁ τ₂ _). abstract (intro x ; pose (q := eqtohomot (nat_trans_eq_pointwise p x)) ; cbn in q ; apply q). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro ; use subtypePath ; [ intro ; apply (pr1 P _) | ] ; exact (nat_trans_eq_pointwise p x)). + abstract (use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro ; apply idpath). Defined. Definition cat_of_elems_has_pb_ump : has_pb_ump cone. Proof. split. - exact cat_of_elems_pb_ump_1. - exact cat_of_elems_pb_ump_2. Defined. End CategoryOfElementsHasPbUMP. Definition pb_via_cat_of_elems : @map_to_disp_sopfib bicat_of_univ_cats _ _ set_of_pointed_set. Proof. intros C P. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, (_ ,, _))). - exact (univalent_cat_of_elems P). - exact (cat_of_elems_forgetful P). - exact (disc_sopfib_cat_of_elems_forgetful P). - exact (cat_of_elems_to_pointed P). - exact (cat_of_elems_inv2cell P). - exact (cat_of_elems_has_pb_ump P). Defined. Definition disc_sopfib_set_of_pointed_set : @disc_sopfib bicat_of_univ_cats _ _ set_of_pointed_set. Proof. split. - apply street_opfib_is_internal_sopfib. apply opfibration_is_street_opfib. apply opcleaving_elements_universal. - split. + apply cat_faithful_is_faithful_1cell. apply pr1_category_faithful. intros X Y f x y. apply Y. + apply cat_conservative_is_conservative_1cell. apply groupoidal_disp_cat_to_conservative. intros X Y f Hf x y ff. apply is_z_iso_disp_elements_universal. Defined. Section IsClassifyingFull. Context {C : univalent_category} {F G : C ⟶ HSET_univalent_category} (n : disc_sopfib_slice univalent_cat_is_univalent_2_1 C ⟦ pr1 (pb_via_cat_of_elems C F) , pr1 (pb_via_cat_of_elems C G) ⟧). Definition is_classifying_nat_trans_data : nat_trans_data F G. Proof. intros x z. exact (cat_of_elems_iso_lift G (pr2 C) (pr1 (pr122 n) (x ,, z)) (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (make_nat_z_iso _ _ _ (is_invertible_2cell_to_is_nat_z_iso _ (pr222 n))) (x ,, z))) (pr2 (pr1 (pr1 n) (x ,, z)))). Defined. Definition is_classifying_nat_trans_is_nat_trans : is_nat_trans _ _ is_classifying_nat_trans_data. Proof. intros x y f ; cbn. use funextsec. intro z. unfold is_classifying_nat_trans_data ; cbn. unfold cat_of_elems_iso_lift ; cbn. pose (p := pr212 (pr2 n) (x ,, z) (y,, # F f z) (f ,, idpath _)). refine (cat_of_elems_z_iso_natural _ _ _ _ _ _ _ _ _ _ p (!_)) ; cbn. exact (pr2 (@functor_on_morphisms _ _ (pr11 n) (x ,, z) (y,, # F f z) (f ,, idpath _))). Qed. Definition is_classifying_nat_trans : F ⟹ G. Proof. use make_nat_trans. - exact is_classifying_nat_trans_data. - exact is_classifying_nat_trans_is_nat_trans. Defined. Definition is_classifying_bicat_of_univ_cats_eq_nat_trans_data : nat_trans_data (mor_of_pb_disc_sopfib_mor _ disc_sopfib_set_of_pointed_set pb_via_cat_of_elems (is_classifying_nat_trans) : _ ⟶ _) (pr1 n : _ ⟶ _). Proof. intro x. simple refine (pr1 (pr122 n) x ,, _). apply cat_of_elems_iso_path. Defined. Definition is_classifying_bicat_of_univ_cats_eq_is_nat_trans : is_nat_trans _ _ is_classifying_bicat_of_univ_cats_eq_nat_trans_data. Proof. intros x y f. use subtypePath. { intro. apply disp_mor_elems_isaprop. } cbn. exact (nat_trans_ax (pr122 n) _ _ f). Qed. Definition is_classifying_bicat_of_univ_cats_nat_trans : mor_of_pb_disc_sopfib_mor _ disc_sopfib_set_of_pointed_set pb_via_cat_of_elems (is_classifying_nat_trans) ==> pr1 n. Proof. use make_nat_trans. - exact is_classifying_bicat_of_univ_cats_eq_nat_trans_data. - exact is_classifying_bicat_of_univ_cats_eq_is_nat_trans. Defined. Definition invertible_is_classifying_bicat_of_univ_cats_nat_trans : is_invertible_2cell is_classifying_bicat_of_univ_cats_nat_trans. Proof. use is_nat_z_iso_to_is_invertible_2cell. intros x. use is_z_iso_cat_of_elems. cbn. exact (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (make_nat_z_iso _ _ _ (is_invertible_2cell_to_is_nat_z_iso _ (pr222 n))) x)). Defined. Definition is_classifying_bicat_of_univ_cats_nat_trans_coh : is_classifying_bicat_of_univ_cats_nat_trans ▹ _ = pb_ump_mor_pr2 (cat_of_elems_has_pb_ump G) (mor_of_pb_disc_sopfib_mor_cone _ disc_sopfib_set_of_pointed_set pb_via_cat_of_elems (is_classifying_nat_trans)) • pr122 n. Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. rewrite id_left. apply idpath. Qed. End IsClassifyingFull. Definition is_classifying_full_help_in_bicat_of_univ_cats : is_classifying_full_help univalent_cat_is_univalent_2_1 set_of_pointed_set disc_sopfib_set_of_pointed_set pb_via_cat_of_elems. Proof. intros C F G n. simple refine (_ ,, _ ,, (_ ,, _)). - exact (is_classifying_nat_trans n). - exact (is_classifying_bicat_of_univ_cats_nat_trans n). - exact (invertible_is_classifying_bicat_of_univ_cats_nat_trans n). - exact (is_classifying_bicat_of_univ_cats_nat_trans_coh n). Defined. Definition is_classifying_faithful_help_in_bicat_of_univ_cats : is_classifying_faithful_help _ disc_sopfib_set_of_pointed_set pb_via_cat_of_elems. Proof. intros C F G n₁ n₂ γ p. use nat_trans_eq. { apply homset_property. } intro x. use funextsec. intro z. pose (pr11 γ (x ,, z)) as q. cbn in q. refine (_ @ pr2 q). unfold q ; clear q. pose (nat_trans_eq_pointwise p (x ,, z)) as q. cbn in q. refine (!_). etrans. { apply maponpaths_2. refine (!(id_right _) @ _). exact q. } apply (eqtohomot (functor_id G x)). Qed. Definition is_classifying_in_bicat_of_univ_cats : is_classifying univalent_cat_is_univalent_2_1 set_of_pointed_set disc_sopfib_set_of_pointed_set pb_via_cat_of_elems. Proof. use make_is_classifying. - exact is_classifying_full_help_in_bicat_of_univ_cats. - exact is_classifying_faithful_help_in_bicat_of_univ_cats. Defined. (** 3. Cartesian closed *) Definition bicat_of_univ_cats_is_cartesian_closed : is_cartesian_closed_bicat (_ ,, has_binprod_bicat_of_univ_cats). Proof. intros C. use make_right_universal_arrow'. - exact univalent_cat_is_univalent_2_1. - exact (λ D, univalent_functor_category C D). - exact (λ D, evaluation_functor). - intros D₁ D₂ F G α. simple refine (_ ,, _). + exact (evaluation_nat_trans F G α). + abstract (cbn in F, G, α ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; rewrite !id_left, !id_right ; rewrite (functor_id (F _)) ; rewrite id_left ; apply idpath). - abstract (intros D₁ D₂ F G α β₁ β₂ p₁ p₂ ; use nat_trans_eq ; [ apply homset_property | ] ; intro ; use nat_trans_eq ; [ apply homset_property | ] ; intro y ; pose (q := nat_trans_eq_pointwise p₁ (x ,, y) @ !(nat_trans_eq_pointwise p₂ (x ,, y))) ; cbn in q ; rewrite !id_right, !id_left in q ; unfold bindelta_pair_pr2_data in q ; cbn in q ; rewrite !(functor_id (pr1 F _)) in q ; rewrite !id_left in q ; exact q). - intros D₁ D₂ F. simple refine (_ ,, _). + exact (curry_functor' F). + use nat_z_iso_to_invertible_2cell. exact (evaluate_curry_functor'_nat_z_iso F). Defined. (** 4. Cores *) (** 4.1 Groupoidal objects *) Definition groupoid_is_groupoidal_obj (C : bicat_of_univ_cats) (HC : is_pregroupoid (pr1 C)) : groupoidal C. Proof. intros C' F₁ F₂ n. use is_nat_z_iso_to_is_invertible_2cell. intro. apply HC. Defined. Definition groupoidal_obj_is_groupoid (C : bicat_of_univ_cats) (HC : groupoidal C) : is_pregroupoid (pr1 C). Proof. intros x y f. exact (is_invertible_2cell_to_is_nat_z_iso _ (HC unit_category (functor_from_unit x) (functor_from_unit y) (nat_trans_from_unit f)) tt). Defined. Definition groupoid_weq_groupoidal_obj (C : bicat_of_univ_cats) : is_pregroupoid (pr1 C) ≃ groupoidal C. Proof. use weqimplimpl. - exact (groupoid_is_groupoidal_obj C). - exact (groupoidal_obj_is_groupoid C). - apply isaprop_is_pregroupoid. - apply isaprop_groupoidal. Defined. (** 4.2 The coreflection *) Definition bicat_of_univ_cats_has_cores_map (C : bicat_of_inv2cells bicat_of_univ_cats) : bicat_of_groupoidal bicat_of_univ_cats. Proof. refine (univalent_core (pr1 C) ,, _). apply groupoid_is_groupoidal_obj. apply is_pregroupoid_core. Defined. Definition bicat_of_univ_cats_has_cores_counit (C : bicat_of_inv2cells bicat_of_univ_cats) : groupoidal_to_inv2cells bicat_of_univ_cats (bicat_of_univ_cats_has_cores_map C) --> C := functor_core _ ,, tt. Definition bicat_of_univ_cats_has_cores_nat_trans {C₀ : bicat_of_groupoidal bicat_of_univ_cats} {C₀' : bicat_of_inv2cells bicat_of_univ_cats} (F₁ F₂ : C₀ --> bicat_of_univ_cats_has_cores_map C₀') (α : # (groupoidal_to_inv2cells bicat_of_univ_cats) F₁ · bicat_of_univ_cats_has_cores_counit C₀' ==> # (groupoidal_to_inv2cells bicat_of_univ_cats) F₂ · bicat_of_univ_cats_has_cores_counit C₀') : pr11 F₁ ⟹ pr11 F₂. Proof. use (@nat_trans_to_core (pr11 C₀') (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀))). use make_nat_z_iso. - exact (pr1 α). - apply is_invertible_2cell_to_is_nat_z_iso. exact (pr2 α). Defined. Definition bicat_of_univ_cats_has_cores_coreflection : right_universal_arrow (groupoidal_to_inv2cells bicat_of_univ_cats). Proof. use make_right_universal_arrow'. - apply is_univalent_2_1_bicat_of_groupoidal. exact univalent_cat_is_univalent_2_1. - exact bicat_of_univ_cats_has_cores_map. - exact bicat_of_univ_cats_has_cores_counit. - intros C₀ C₀' F₁ F₂ α. simple refine ((_ ,, tt) ,, _). + exact (bicat_of_univ_cats_has_cores_nat_trans _ _ α). + abstract (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro ; apply idpath). - abstract (intros C₀ C₀' F₁ F₂ α β₁ β₂ p q ; use subtypePath ; [ intro ; apply isapropunit | ] ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; refine (nat_trans_eq_pointwise (maponpaths pr1 p) x @ !_) ; exact (nat_trans_eq_pointwise (maponpaths pr1 q) x)). - intros C₀ C₀' F. simple refine ((_ ,, tt) ,, _). + exact (@factor_through_core (pr11 C₀') (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀)) (pr1 F)). + cbn. use make_invertible_2cell. * simple refine (_ ,, _) ; cbn. ** exact (@factor_through_core_commute (pr11 C₀') (pr11 C₀ ,, groupoidal_obj_is_groupoid _ (pr2 C₀)) (pr1 F)). ** apply is_nat_z_iso_to_is_invertible_2cell. intro x. apply identity_is_z_iso. * apply is_invertible_2cell_bicat_of_inv2cells. Defined. Definition bicat_of_univ_cats_has_cores : has_cores bicat_of_univ_cats. Proof. simple refine (_ ,, _). - exact bicat_of_univ_cats_has_cores_coreflection. - intro C. split ; cbn. + apply essentially_surjective_is_eso. apply functor_core_eso. + apply cat_pseudmonic_is_pseudomonic_1cell. apply functor_core_pseudomonic. Defined. UniMath-20231010/UniMath/Bicategories/OtherStructure/Examples/StructureOneTypes.v000066400000000000000000000471341451125700300277230ustar00rootroot00000000000000(** Duality involutions of bicategories Contents: 1. Duality involution on locally groupoidal bicategory 2. 1-Types are cartesian closed *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Op2OfPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.ConstProduct. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.OtherStructure.DualityInvolution. Require Import UniMath.Bicategories.OtherStructure.Exponentials. Local Open Scope cat. (** 1. Duality involution on locally groupoidal bicategory *) Section DualityInvolutionLocallyGroupoidal. Context (B : bicat) (inv_B : locally_groupoid B). Definition op_locally_groupoid_data : psfunctor_data (op2_bicat B) B. Proof. use make_psfunctor_data. - exact (λ z, z). - exact (λ _ _ f, f). - exact (λ _ _ _ _ α, (inv_B _ _ _ _ α)^-1). - exact (λ _, id2 _). - exact (λ _ _ _ _ _, id2 _). Defined. Definition op_locally_groupoid_laws : psfunctor_laws op_locally_groupoid_data. Proof. repeat split ; intro ; intros ; cbn. - refine (!(id2_right _) @ _). use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite id2_right. apply idpath. - use vcomp_move_L_pM ; [ is_iso | ] ; cbn. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. apply idpath. - use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite lunitor_linvunitor. rewrite id2_rwhisker, !id2_left. apply idpath. - use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite runitor_rinvunitor. rewrite lwhisker_id2, !id2_left. apply idpath. - rewrite lwhisker_id2, id2_rwhisker. rewrite !id2_left, !id2_right. refine (!(id2_right _) @ _). use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite rassociator_lassociator. apply idpath. - use vcomp_move_L_pM ; [ is_iso | ] ; cbn. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite id2_left, id2_right. apply idpath. - use vcomp_move_L_pM ; [ is_iso | ] ; cbn. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite id2_left, id2_right. apply idpath. Qed. Definition op_locally_groupoid_invertible_cells : invertible_cells op_locally_groupoid_data. Proof. split ; intro ; intros ; cbn ; is_iso. Defined. Definition op_locally_groupoid : psfunctor (op2_bicat B) B. Proof. use make_psfunctor. - exact op_locally_groupoid_data. - exact op_locally_groupoid_laws. - exact op_locally_groupoid_invertible_cells. Defined. Definition locally_groupoid_duality_involution_unit_data : pstrans_data (id_psfunctor B) (comp_psfunctor op_locally_groupoid (op2_psfunctor op_locally_groupoid)). Proof. use make_pstrans_data. - exact (λ x, id₁ _). - exact (λ _ _ f, comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _)). Defined. Definition locally_groupoid_duality_involution_unit_is_pstrans : is_pstrans locally_groupoid_duality_involution_unit_data. Proof. repeat split. - intros x y f g α ; cbn. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_right. apply idpath. - intro x ; cbn. rewrite !id2_left. rewrite id2_rwhisker, id2_right. use vcomp_move_R_pM ; [ is_iso | ]. cbn. rewrite lwhisker_id2, id2_left. rewrite runitor_lunitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros x y z f g ; cbn. rewrite id2_left. rewrite id2_rwhisker, id2_right. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite lwhisker_id2, id2_left. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition locally_groupoid_duality_involution_unit : pstrans (id_psfunctor B) (comp_psfunctor op_locally_groupoid (op2_psfunctor op_locally_groupoid)). Proof. use make_pstrans. - exact locally_groupoid_duality_involution_unit_data. - exact locally_groupoid_duality_involution_unit_is_pstrans. Defined. Definition locally_groupoid_duality_involution_unit_inv_data : pstrans_data (comp_psfunctor op_locally_groupoid (op2_psfunctor op_locally_groupoid)) (id_psfunctor B). Proof. use make_pstrans_data. - exact (λ _, id₁ _). - exact (λ _ _ f, comp_of_invertible_2cell (lunitor_invertible_2cell _) (rinvunitor_invertible_2cell _)). Defined. Definition locally_groupoid_duality_involution_unit_inv_is_pstrans : is_pstrans locally_groupoid_duality_involution_unit_inv_data. Proof. repeat split. - intros x y f g α ; cbn. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_lunitor. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. - intro x ; cbn. rewrite lwhisker_id2, id2_left. rewrite id2_left. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite id2_rwhisker. rewrite id2_right. rewrite runitor_lunitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros x y z f g ; cbn. rewrite lwhisker_id2, !id2_left. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite id2_rwhisker. rewrite id2_right. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. apply idpath. Opaque comp_psfunctor. Qed. Transparent comp_psfunctor. Definition locally_groupoid_duality_involution_unit_inv : pstrans (comp_psfunctor op_locally_groupoid (op2_psfunctor op_locally_groupoid)) (id_psfunctor B). Proof. use make_pstrans. - exact locally_groupoid_duality_involution_unit_inv_data. - exact locally_groupoid_duality_involution_unit_inv_is_pstrans. Defined. Definition locally_groupoid_duality_involution_unit_unit_inv_data : invertible_modification_data (id₁ (id_psfunctor B)) (locally_groupoid_duality_involution_unit · locally_groupoid_duality_involution_unit_inv). Proof. intro x ; cbn. exact (linvunitor_invertible_2cell _). Defined. Definition locally_groupoid_duality_involution_unit_unit_inv_is_modif : is_modification locally_groupoid_duality_involution_unit_unit_inv_data. Proof. intros x y f ; cbn. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite (rwhisker_hcomp _ (rinvunitor f)). rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite !vassocr. apply maponpaths_2. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. rewrite <- triangle_l_inv. rewrite <- lwhisker_hcomp. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. rewrite lunitor_triangle. rewrite vcomp_lunitor. apply idpath. Qed. Definition locally_groupoid_duality_involution_unit_unit_inv : invertible_modification (id₁ (id_psfunctor B)) (locally_groupoid_duality_involution_unit · locally_groupoid_duality_involution_unit_inv). Proof. use make_invertible_modification. - exact locally_groupoid_duality_involution_unit_unit_inv_data. - exact locally_groupoid_duality_involution_unit_unit_inv_is_modif. Defined. Definition locally_groupoid_duality_involution_unit_inv_unit_data : invertible_modification_data (locally_groupoid_duality_involution_unit_inv · locally_groupoid_duality_involution_unit) (id₁ _). Proof. intro x ; cbn. exact (lunitor_invertible_2cell _). Defined. Definition locally_groupoid_duality_involution_unit_inv_unit_is_modif : is_modification locally_groupoid_duality_involution_unit_inv_unit_data. Proof. intros x y f ; cbn. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite !vassocl. rewrite runitor_lunitor_identity. apply maponpaths. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor. rewrite id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. apply idpath. Qed. Definition locally_groupoid_duality_involution_unit_inv_unit : invertible_modification (locally_groupoid_duality_involution_unit_inv · locally_groupoid_duality_involution_unit) (id₁ _). Proof. use make_invertible_modification. - exact locally_groupoid_duality_involution_unit_inv_unit_data. - exact locally_groupoid_duality_involution_unit_inv_unit_is_modif. Defined. Definition locally_groupoid_duality_involution_triangle (x : B) : invertible_2cell (id₁ x) (id₁ x) := id2_invertible_2cell _. Definition locally_groupoid_duality_involution_data : duality_involution_data op_locally_groupoid := make_duality_involution_data op_locally_groupoid locally_groupoid_duality_involution_unit locally_groupoid_duality_involution_unit_inv locally_groupoid_duality_involution_unit_unit_inv locally_groupoid_duality_involution_unit_inv_unit locally_groupoid_duality_involution_triangle. Definition locally_groupoid_duality_involution_laws_coh (x : B) : lunitor (id₁ x) • rinvunitor (id₁ x) • (id₁ x ◃ id₂ (id₁ x)) = id₁ x ◃ (inv_B x x (id₁ x) (id₁ x) (id₂ (id₁ x)))^-1. Proof. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor. rewrite lwhisker_id2. rewrite !id2_left. refine (_ @ id2_right _). use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite lwhisker_id2. apply id2_left. Qed. Definition locally_groupoid_duality_involution_laws : duality_involution_laws locally_groupoid_duality_involution_data. Proof. split. - exact locally_groupoid_duality_involution_laws_coh. - intros x y f ; cbn. rewrite !id2_left, !id2_right. rewrite !vassocr. rewrite !lunitor_linvunitor. rewrite !id2_left. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite runitor_rwhisker. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite <- rinvunitor_triangle. rewrite <- !lwhisker_vcomp. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. rewrite lwhisker_lwhisker_rassociator. refine (!_). etrans. { do 6 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. do 3 (use vcomp_move_R_pM ; [ is_iso | ]) ; cbn. rewrite rwhisker_rwhisker_alt. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_lwhisker. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_l. rewrite <- lwhisker_hcomp. rewrite !vassocl. apply idpath. } rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite <- lunitor_triangle. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite linvunitor_lunitor. rewrite id2_right. refine (_ @ id2_right _). use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. rewrite runitor_rwhisker. rewrite lunitor_runitor_identity. rewrite lwhisker_vcomp. rewrite runitor_rinvunitor. rewrite lwhisker_id2. apply idpath. Qed. Definition locally_groupoid_duality_involution : duality_involution op_locally_groupoid := locally_groupoid_duality_involution_data ,, locally_groupoid_duality_involution_laws. End DualityInvolutionLocallyGroupoidal. (** 2. 1-Types are cartesian closed *) Definition one_types_pair_2cell {X₁ X₂ Y₁ Y₂ : one_type} {f₁ f₂ : X₁ → Y₁} {g₁ g₂ : X₂ → Y₂} (p : f₁ ~ f₂) (q : g₁ ~ g₂) (x₁ : X₁) (x₂ : X₂) : @pair_2cell (_ ,, has_binprod_one_types) X₁ X₂ Y₁ Y₂ f₁ f₂ g₁ g₂ p q (x₁ ,, x₂) = pathsdirprod (p x₁) (q x₂). Proof. refine (pathsdirprod_eta _ @ _). use paths_pathsdirprod. - pose (@pair_2cell_pr1 (_ ,, has_binprod_one_types) X₁ X₂ Y₁ Y₂ f₁ f₂ g₁ g₂ p q) as r. etrans. { apply (eqtohomot r (x₁ ,, x₂)). } apply pathscomp0rid. - pose (@pair_2cell_pr2 (_ ,, has_binprod_one_types) X₁ X₂ Y₁ Y₂ f₁ f₂ g₁ g₂ p q) as r. etrans. { apply (eqtohomot r (x₁ ,, x₂)). } apply pathscomp0rid. Qed. Definition is_cartesian_closed_one_types : is_cartesian_closed_bicat (_ ,, has_binprod_one_types). Proof. use make_is_cartesian_closed_bicat. - exact one_types_is_univalent_2_1. - intros X Y. exact (HLevel_fun X Y). - exact (λ X Y fx, app_fun fx). - exact (λ X Y₁ Y₂ f g p, app_homot p). - abstract (simpl ; intros X Y₁ Y₂ f g p ; cbn in p ; unfold homotsec in p ; cbn -[pair_2cell] ; unfold homotfun ; use funextsec ; intro yx ; etrans ; [ apply maponpaths ; exact (@one_types_pair_2cell Y₁ X (HLevel_fun X Y₂) X f g (idfun X) (idfun X) (app_homot p) (homotrefl _) (pr1 yx) (pr2 yx)) | ] ; rewrite maponpaths_app_fun ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_pr2_pathsdirprod | ] ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply maponpaths_pr1_pathsdirprod | ] ; cbn ; rewrite pathscomp0rid ; apply maponpaths_app_homot). - abstract (simpl ; intros X Y₁ Y₂ f g p q₁ q₂ r₁ r₂ ; simpl in r₁ ; use funextsec ; intro y ; use path_path_fun ; intro x ; refine (_ @ eqtohomot r₁ (y ,, x) @ !(eqtohomot r₂ (y ,, x)) @ _) ; [ cbn -[pair_2cell] ; unfold homotfun, homotrefl ; rewrite one_types_pair_2cell ; rewrite maponpaths_app_fun ; refine (!_) ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_pr2_pathsdirprod | ] ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply maponpaths_pr1_pathsdirprod | ] ; apply pathscomp0rid | cbn -[pair_2cell] ; unfold homotfun, homotrefl ; rewrite one_types_pair_2cell ; rewrite maponpaths_app_fun ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_pr2_pathsdirprod | ] ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply maponpaths_pr1_pathsdirprod | ] ; cbn ; apply pathscomp0rid ]). - exact (λ X Y₁ Y₂ f y x, f (y ,, x)). - simpl ; intros X Y₁ Y₂ f. use make_invertible_2cell. + apply homotrefl. + apply one_type_2cell_iso. Defined. UniMath-20231010/UniMath/Bicategories/OtherStructure/Exponentials.v000066400000000000000000000075701451125700300251270ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration. Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Require Import UniMath.Bicategories.PseudoFunctors.Examples.ConstProduct. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor. Import Products.Notations. Local Open Scope cat. Definition is_cartesian_closed_bicat (B : bicat_with_binprod) : UU := ∏ (x : B), right_universal_arrow (const_prod_psfunctor B x). Definition make_is_cartesian_closed_bicat (B : bicat_with_binprod) (HB : is_univalent_2_1 B) (exp : B -> B → B) (app : ∏ (x y : B), exp x y ⊗ x --> y) (app2 : ∏ (x y₁ y₂ : B) (f g : y₁ --> exp x y₂) (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂), f ==> g) (app2_eq : ∏ (x y₁ y₂ : B) (f g : y₁ --> exp x y₂) (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂), app2 x y₁ y₂ f g α ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α) (H : ∏ (x y₁ y₂ : B) (f g : y₁ --> exp x y₂) (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂) (β₁ β₂ : f ==> g) (p₁ : β₁ ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α) (p₂ : β₂ ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α), β₁ = β₂) (lam : ∏ (x y₁ y₂ : B) (f : y₁ ⊗ x --> y₂), y₁ --> exp x y₂) (app_lam : ∏ (x y₁ y₂ : B) (f : y₁ ⊗ x --> y₂), invertible_2cell (lam x y₁ y₂ f ⊗₁ id₁ x · app x y₂) f) : is_cartesian_closed_bicat B. Proof. intro x. use make_right_universal_arrow'. - exact HB. - exact (exp x). - exact (app x). - intros y₁ y₂ f g α. simple refine (_ ,, _). + exact (app2 x y₁ y₂ f g α). + exact (app2_eq x y₁ y₂ f g α). - exact (H x). - intros y₁ y₂ f. simple refine (_ ,, _). + exact (lam x y₁ y₂ f). + exact (app_lam x y₁ y₂ f). Defined. Definition exponentiable_morphism (B : bicat_with_pb) {b₁ b₂ : B} (f : b₁ --> b₂) : UU := right_universal_arrow (pb_psfunctor B f). Definition locally_cartesian_closed_bicat (B : bicat_with_pb) : UU := ∏ (b₁ b₂ : B) (f : b₁ --> b₂), exponentiable_morphism B f. Definition bicat_has_exponentials (B : bicat_with_pb) : UU := ∏ (b₁ b₂ : B) (f : b₁ --> b₂), (internal_sfib f → exponentiable_morphism B f) × (internal_sopfib f → exponentiable_morphism B f). UniMath-20231010/UniMath/Bicategories/PseudoFunctors/000077500000000000000000000000001451125700300222375ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Biadjunction.v000066400000000000000000000276631451125700300250550ustar00rootroot00000000000000(********************************************************************************* Biadjunctions of bicategories We define the notion of biadjunction. To do so, we use the formulation with units and counits. We don't require the biadjunctions to be coherent: the swallowtail equations do not have to be satisfied. Contents 1. Definition 2. Equivalence on hom-categories *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Whiskering. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope cat. (** 1. Definition *) Definition left_biadj_unit_counit {B₁ B₂ : bicat} (L : psfunctor B₁ B₂) := ∑ (R : psfunctor B₂ B₁), (pstrans (id_psfunctor B₁) (comp_psfunctor R L)) × (pstrans (comp_psfunctor L R) (id_psfunctor B₂)). Section BiadjunctionProjections. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_unit_counit L). Definition biadj_right_adjoint : psfunctor B₂ B₁ := pr1 R. Definition biadj_unit : pstrans (id_psfunctor B₁) (comp_psfunctor biadj_right_adjoint L) := pr12 R. Definition biadj_counit : pstrans (comp_psfunctor L biadj_right_adjoint) (id_psfunctor B₂) := pr22 R. End BiadjunctionProjections. Coercion biadj_right_adjoint : left_biadj_unit_counit >-> psfunctor. Section BiadjunctionTriangleLaws. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_unit_counit L). Let η : pstrans (id_psfunctor B₁) (comp_psfunctor R L) := biadj_unit R. Let ε : pstrans (comp_psfunctor L R) (id_psfunctor B₂) := biadj_counit R. Definition biadj_triangle_l_lhs : pstrans L L := comp_pstrans (rinvunitor_pstrans L) (comp_pstrans (L ◅ η) (comp_pstrans (lassociator_pstrans L R L) (comp_pstrans (ε ▻ L) (lunitor_pstrans L)))). Definition biadj_triangle_l_law : UU := invertible_modification biadj_triangle_l_lhs (id_pstrans L). Definition biadj_triangle_r_lhs : pstrans R R := comp_pstrans (linvunitor_pstrans R) (comp_pstrans (η ▻ R) (comp_pstrans (rassociator_pstrans R L R) (comp_pstrans (R ◅ ε) (runitor_pstrans R)))). Definition biadj_triangle_r_law : UU := invertible_modification biadj_triangle_r_lhs (id_pstrans R). End BiadjunctionTriangleLaws. Definition left_biadj_data {B₁ B₂ : bicat} (L : psfunctor B₁ B₂) : UU := ∑ (R : left_biadj_unit_counit L), biadj_triangle_l_law R × biadj_triangle_r_law R. Section BiadjunctionDataProjections. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Definition left_biadj_data_to_left_biadj_unit_counit : left_biadj_unit_counit L := pr1 R. Definition biadj_triangle_l : invertible_modification (biadj_triangle_l_lhs (pr1 R)) (id_pstrans L) := pr12 R. Definition biadj_triangle_r : invertible_modification (biadj_triangle_r_lhs (pr1 R)) (id_pstrans (pr1 R)) := pr22 R. End BiadjunctionDataProjections. Coercion left_biadj_data_to_left_biadj_unit_counit : left_biadj_data >-> left_biadj_unit_counit. Definition make_biadj_unit_counit {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : psfunctor B₂ B₁) (η : pstrans (id_psfunctor B₁) (comp_psfunctor R L)) (ε : pstrans (comp_psfunctor L R) (id_psfunctor B₂)) : left_biadj_unit_counit L := R ,, η ,, ε. Definition make_biadj_data {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_unit_counit L) (tl : biadj_triangle_l_law R) (tr : biadj_triangle_r_law R) : left_biadj_data L := R ,, tl ,, tr. (** 2. Equivalence on hom-categories *) Section BiadjunctionHom. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L) (X : B₁) (Y : B₂). Let η : pstrans (id_psfunctor B₁) (comp_psfunctor R L) := biadj_unit R. Let ε : pstrans (comp_psfunctor L R) (id_psfunctor B₂) := biadj_counit R. Local Definition biadj_left_hom_data : functor_data (hom X (R Y)) (hom (L X) Y). Proof. use make_functor_data. - exact (λ f, #L f · ε Y). - exact (λ f g α, (##L α) ▹ ε Y). Defined. Local Definition biadj_left_hom_is_functor : is_functor biadj_left_hom_data. Proof. split. - intros f. cbn in f ; cbn. rewrite psfunctor_id2, id2_rwhisker. apply idpath. - intros f g h α β. cbn in f, g, h, α, β ; cbn. rewrite rwhisker_vcomp, psfunctor_vcomp. apply idpath. Qed. Definition biadj_left_hom : hom X (R Y) ⟶ hom (L X) Y. Proof. use make_functor. - exact biadj_left_hom_data. - exact biadj_left_hom_is_functor. Defined. Definition biadj_right_hom_data : functor_data (hom (L X) Y) (hom X (R Y)). Proof. use make_functor_data. - exact (λ f, η X · #R f). - exact (λ f g α, η X ◃ ##R α). Defined. Definition biadj_right_hom_is_functor : is_functor biadj_right_hom_data. Proof. split. - intros f. cbn in f ; cbn. rewrite psfunctor_id2, lwhisker_id2. apply idpath. - intros f g h α β. cbn in f, g, h, α, β ; cbn. rewrite psfunctor_vcomp, lwhisker_vcomp. apply idpath. Qed. Definition biadj_right_hom : hom (L X) Y ⟶ hom X (R Y). Proof. use make_functor. - exact biadj_right_hom_data. - exact biadj_right_hom_is_functor. Defined. Definition biadj_hom_left_right_data : nat_trans_data (functor_identity (hom X (R Y))) (biadj_left_hom ∙ biadj_right_hom). Proof. intros f. exact ((rinvunitor f) • (f ◃ (((invertible_modcomponent_of (biadj_triangle_r R) Y)^-1) • lunitor _ • (_ ◃ (lunitor _ • runitor _)))) • lassociator _ _ _ • ((psnaturality_of η f)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ psfunctor_comp R (#L f) (ε Y))). Defined. Definition biadj_hom_left_right_is_nat_trans : is_nat_trans _ _ biadj_hom_left_right_data. Proof. intros f g α. cbn in f, g, α ; cbn. unfold biadj_hom_left_right_data ; simpl. etrans. { rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite lwhisker_vcomp. rewrite psfunctor_rwhisker. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_pM. { is_iso. } simpl. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } simpl. rewrite !rwhisker_vcomp. apply maponpaths. exact (!(psnaturality_natural η _ _ f g α)). Qed. Definition biadj_hom_left_right : (functor_identity (hom X (R Y))) ⟹ biadj_left_hom ∙ biadj_right_hom. Proof. use make_nat_trans. - exact biadj_hom_left_right_data. - exact biadj_hom_left_right_is_nat_trans. Defined. Definition biadj_hom_right_left_data : nat_trans_data (biadj_right_hom ∙ biadj_left_hom) (functor_identity (hom (L X) Y)). Proof. intros f. exact (((psfunctor_comp L (η X) (#R f))^-1 ▹ (ε Y)) • rassociator _ _ _ • (#L (η X) ◃ (psnaturality_of ε f)^-1) • lassociator _ _ _ • (((_ ◃ (rinvunitor _ • linvunitor _)) • linvunitor _ • (invertible_modcomponent_of (biadj_triangle_l R) X)) ▹ f) • lunitor f). Defined. Definition biadj_hom_right_left_is_nat_trans : is_nat_trans _ _ biadj_hom_right_left_data. Proof. intros f g α. cbn in f, g, α ; cbn. unfold biadj_hom_right_left_data. simpl. refine (!_). etrans. { rewrite !vassocl. do 4 apply maponpaths. etrans. { apply maponpaths. refine (!(vcomp_lunitor f _ α)). } rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_lwhisker. rewrite !vassocr. apply maponpaths_2. use vcomp_move_L_Mp. { is_iso. } simpl. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } simpl. rewrite !lwhisker_vcomp. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. exact (psnaturality_natural ε _ _ _ _ α). } rewrite !vassocr. rewrite vcomp_linv, id2_left. apply idpath. } rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !rwhisker_vcomp. apply maponpaths. refine (!_). rewrite psfunctor_lwhisker. rewrite !vassocl. rewrite vcomp_rinv, id2_right. apply idpath. Qed. Definition biadj_hom_right_left : (biadj_right_hom ∙ biadj_left_hom) ⟹ (functor_identity (hom (L X) Y)). Proof. use make_nat_trans. - exact biadj_hom_right_left_data. - exact biadj_hom_right_left_is_nat_trans. Defined. Definition biadj_hom_equivalence : equivalence_of_cats (hom X (R Y)) (hom (L X) Y). Proof. use tpair. - use tpair. + exact biadj_left_hom. + use tpair. * exact biadj_right_hom. * split. ** exact biadj_hom_left_right. ** exact biadj_hom_right_left. - split ; simpl. + intro a. apply is_inv2cell_to_is_z_iso. unfold biadj_hom_left_right_data. is_iso. apply property_from_invertible_2cell. + intro a. apply is_inv2cell_to_is_z_iso. unfold biadj_hom_right_left_data. is_iso. apply property_from_invertible_2cell. Defined. Definition biadj_hom_equiv : adj_equivalence_of_cats biadj_left_hom. Proof. exact (adjointification biadj_hom_equivalence). Defined. End BiadjunctionHom. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Biequivalence.v000066400000000000000000000314701451125700300252070ustar00rootroot00000000000000(* ************************************************************************* *) (** * Biequivalence Marco Maggesi, Niels van der Weide July 2019 *) (* ************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Morphisms.Properties.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Modifications.Examples.Unitality. Import PseudoFunctor.Notations. Local Open Scope cat. Local Open Scope bicategory_scope. Section Biequivalence. Definition is_biequivalence_unit_counit {C D : bicat} (F : psfunctor C D) (G : psfunctor D C) : UU := pstrans (comp_psfunctor G F) (id_psfunctor C) × pstrans (comp_psfunctor F G) (id_psfunctor D). Definition unit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} (e : is_biequivalence_unit_counit F G) : pstrans (comp_psfunctor G F) (id_psfunctor C) := pr1 e. Definition counit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} (e : is_biequivalence_unit_counit F G) : pstrans (comp_psfunctor F G) (id_psfunctor D) := pr2 e. Definition is_biequivalence_adjoints {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} (e : is_biequivalence_unit_counit F G) : UU := left_adjoint_equivalence (unit_of_is_biequivalence e) × left_adjoint_equivalence (counit_of_is_biequivalence e). Definition is_biequivalence_adjoint_unit {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : left_adjoint_equivalence (unit_of_is_biequivalence e) := pr1 a. Definition is_biequivalence_adjoint_counit {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : left_adjoint_equivalence (counit_of_is_biequivalence e) := pr2 a. Definition invunit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : pstrans (id_psfunctor C) (comp_psfunctor G F) := left_adjoint_right_adjoint (is_biequivalence_adjoint_unit a). Definition invcounit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : pstrans (id_psfunctor D) (comp_psfunctor F G) := left_adjoint_right_adjoint (is_biequivalence_adjoint_counit a). Definition unitcounit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : invertible_modification (comp_pstrans (invunit_of_is_biequivalence a) (unit_of_is_biequivalence e)) (id_pstrans _). Proof. refine (left_adjoint_counit (is_biequivalence_adjoint_unit a) ,, _). exact (left_equivalence_counit_iso (is_biequivalence_adjoint_unit a)). Defined. Definition unitunit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : invertible_modification (comp_pstrans (unit_of_is_biequivalence e) (invunit_of_is_biequivalence a)) (id_pstrans _). Proof. refine (inv_of_invertible_2cell _). refine (left_adjoint_unit (is_biequivalence_adjoint_unit a) ,, _). exact (left_equivalence_unit_iso (is_biequivalence_adjoint_unit a)). Defined. Definition counitunit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : invertible_modification (comp_pstrans (counit_of_is_biequivalence e) (invcounit_of_is_biequivalence a)) (id_pstrans _). Proof. refine (inv_of_invertible_2cell _). refine (left_adjoint_unit (is_biequivalence_adjoint_counit a) ,, _). exact (left_equivalence_unit_iso (is_biequivalence_adjoint_counit a)). Defined. Definition counitcounit_of_is_biequivalence {C D : bicat} {F : psfunctor C D} {G : psfunctor D C} {e : is_biequivalence_unit_counit F G} (a : is_biequivalence_adjoints e) : invertible_modification (comp_pstrans (invcounit_of_is_biequivalence a) (counit_of_is_biequivalence e)) (id_pstrans _). Proof. refine (left_adjoint_counit (is_biequivalence_adjoint_counit a) ,, _). exact (left_equivalence_counit_iso (is_biequivalence_adjoint_counit a)). Defined. Definition is_biequivalence {C D : bicat} (F : psfunctor C D) : UU := ∑ (G : psfunctor D C) (e : is_biequivalence_unit_counit F G), is_biequivalence_adjoints e. Definition inv_psfunctor_of_is_biequivalence {C D : bicat} {F : psfunctor C D} (e : is_biequivalence F) : psfunctor D C := pr1 e. Coercion unit_counit_from_is_biequivalence {C D : bicat} {F : psfunctor C D} (e : is_biequivalence F) : is_biequivalence_unit_counit F (inv_psfunctor_of_is_biequivalence e) := pr12 e. Coercion adjoints_from_is_biequivalence {C D : bicat} {F : psfunctor C D} (e : is_biequivalence F) : is_biequivalence_adjoints e := pr22 e. Definition biequivalence (C D : bicat) : UU := ∑ F : psfunctor C D, is_biequivalence F. Coercion psfunctor_of_biequivalence {C D : bicat} (e : biequivalence C D) : psfunctor C D := pr1 e. Coercion is_biequivalence_of_biequivalence {C D : bicat} (e : biequivalence C D) : is_biequivalence (psfunctor_of_biequivalence e) := pr2 e. End Biequivalence. Section Builder. Context {C D : bicat} (F : psfunctor C D) (G : psfunctor D C) (η : pstrans (id_psfunctor C) (comp_psfunctor G F)) (ηinv : pstrans (comp_psfunctor G F) (id_psfunctor C)) (ε : pstrans (comp_psfunctor F G) (id_psfunctor D)) (εinv : pstrans (id_psfunctor D) (comp_psfunctor F G)) (pη : invertible_modification (id_pstrans (comp_psfunctor G F)) (comp_pstrans ηinv η)) (qη : invertible_modification (comp_pstrans η ηinv) (id_pstrans (id_psfunctor C))) (pε : invertible_modification (id_pstrans (comp_psfunctor F G)) (comp_pstrans ε εinv)) (qε : invertible_modification (comp_pstrans εinv ε) (id_pstrans (id_psfunctor D))). Definition make_is_biequivalence : is_biequivalence F. Proof. refine (G,, _). refine ((ηinv,, ε),, _). split. - apply equiv_to_isadjequiv. + use tpair. * use tpair. ** exact η. ** split. *** exact (pr1 pη). *** exact (pr1 qη). * split. ** apply pη. ** apply qη. - apply equiv_to_isadjequiv. + use tpair. * use tpair. ** exact εinv. ** split. *** exact (pr1 pε). *** exact (pr1 qε). * split. ** apply pε. ** apply qε. Defined. End Builder. Section Builder_From_Unit_Counit. Context {C D : bicat} (F : psfunctor C D) (G : psfunctor D C) (a : is_biequivalence_unit_counit F G) (η : pstrans (id_psfunctor C) (comp_psfunctor G F)) (εinv : pstrans (id_psfunctor D) (comp_psfunctor F G)). Local Notation "'ηinv'" := (unit_of_is_biequivalence a). Local Notation "'ε'" := (counit_of_is_biequivalence a). Context (pη : invertible_modification (comp_pstrans ηinv η) (id_pstrans (comp_psfunctor G F))) (qη : invertible_modification (comp_pstrans η ηinv) (id_pstrans (id_psfunctor C))) (pε : invertible_modification (comp_pstrans ε εinv) (id_pstrans (comp_psfunctor F G))) (qε : invertible_modification (comp_pstrans εinv ε) (id_pstrans (id_psfunctor D))). Definition make_is_biequivalence_from_unit_counit : is_biequivalence F. Proof. use make_is_biequivalence. - exact G. - exact η. - exact ηinv. - exact ε. - exact εinv. - exact (inv_of_invertible_2cell pη). - exact qη. - exact (inv_of_invertible_2cell pε). - exact qε. Defined. End Builder_From_Unit_Counit. Section Pointwise. Context {C D : bicat} (HC : is_univalent_2 C) (HD : is_univalent_2 D) (e : biequivalence C D). Definition biequivalence_to_object_equivalence : ob C ≃ ob D. Proof. pose (F := psfunctor_of_biequivalence e). pose (G := inv_psfunctor_of_is_biequivalence e). pose (η := is_biequivalence_adjoint_unit (pr2 e)). pose (ε := is_biequivalence_adjoint_counit (pr2 e)). use make_weq. - exact (λ x, F x). - use isweq_iso. + exact (λ x, G x). + intro x. cbn. apply (isotoid_2_0 (pr1 HC)). use tpair. * exact (unit_of_is_biequivalence (pr2 e) x). * cbn. apply (pointwise_adjequiv (unit_of_is_biequivalence (pr2 e))). apply η. + intro y. cbn. apply (isotoid_2_0 (pr1 HD)). use tpair. * exact (counit_of_is_biequivalence (pr2 e) y). * cbn. apply (pointwise_adjequiv (counit_of_is_biequivalence (pr2 e))). apply ε. Defined. End Pointwise. Definition id_is_biequivalence (B : bicat) : is_biequivalence (id_psfunctor B). Proof. use make_is_biequivalence_from_unit_counit. - exact (id_psfunctor B). - use tpair. + apply lunitor_pstrans. + apply lunitor_pstrans. - apply linvunitor_pstrans. - apply linvunitor_pstrans. - apply lunitor_linvunitor_pstrans. - apply linvunitor_lunitor_pstrans. - apply lunitor_linvunitor_pstrans. - apply linvunitor_lunitor_pstrans. Defined. (** Biequivalences reflect adjoint equivalences *) Section BiequivReflectAdjequiv. Context {B₁ B₂ : bicat} (L : biequivalence B₁ B₂). Let R : psfunctor B₂ B₁ := inv_psfunctor_of_is_biequivalence L. Let η : pstrans (comp_psfunctor R L) (id_psfunctor B₁) := unit_of_is_biequivalence L. Let Hη : left_adjoint_equivalence η := is_biequivalence_adjoint_unit L. Context {x y : B₁} {f : x --> y} (Hf : left_adjoint_equivalence (#L f)). Let f' : x --> y := left_adjoint_right_adjoint (pointwise_adjequiv _ Hη x) · #R(#L f) · η y. Definition biequiv_reflect_adjequiv_cell : invertible_2cell f f' := comp_of_invertible_2cell (linvunitor_invertible_2cell _) (comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (left_equivalence_counit_iso (pointwise_adjequiv _ Hη x)))) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (psnaturality_of η f)) (lassociator_invertible_2cell _ _ _)))). Definition biequiv_reflect_adjequiv : left_adjoint_equivalence f. Proof. use left_adjoint_equivalence_invertible. - exact f'. - use comp_left_adjoint_equivalence. + use comp_left_adjoint_equivalence. * apply inv_left_adjoint_equivalence. * use (psfunctor_preserves_adjequiv' R). exact Hf. + exact (pointwise_adjequiv _ Hη y). - exact biequiv_reflect_adjequiv_cell. - apply property_from_invertible_2cell. Defined. End BiequivReflectAdjequiv. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/000077500000000000000000000000001451125700300236445ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/Base.v000066400000000000000000000242121451125700300247060ustar00rootroot00000000000000(** We construct the bicategory of pseudofunctors as a displayed bicategory. This is the first layer and it just consists of plain functions mapping objects to objects. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.AdjointUnique. Local Open Scope cat. Section BasePseudoFunctor. Variable (C D : bicat). Definition ps_base_data : prebicat_data. Proof. use build_prebicat_data. - exact (ob C → ob D). - exact (λ f g, ∏ (x : C), f x --> g x). - exact (λ f g α β, ∏ (x : C), α x ==> β x). - exact (λ f x, id₁ (f x)). - exact (λ f g h α β x, α x · β x). - exact (λ f g α x, id₂ (α x)). - exact (λ f g α β γ m₁ m₂ x, m₁ x • m₂ x). - exact (λ f g h α β γ m x, α x ◃ m x). - exact (λ f g h α β γ m x, m x ▹ γ x). - exact (λ f g α x, lunitor (α x)). - exact (λ f g α x, linvunitor (α x)). - exact (λ f g α x, runitor (α x)). - exact (λ f g α x, rinvunitor (α x)). - exact (λ f₁ f₂ f₃ f₄ α β γ x, lassociator (α x) (β x) (γ x)). - exact (λ f₁ f₂ f₃ f₄ α β γ x, rassociator (α x) (β x) (γ x)). Defined. Definition ps_base_laws : prebicat_laws ps_base_data. Proof. repeat split ; intros ; apply funextsec ; intro. - apply id2_left. - apply id2_right. - apply vassocr. - apply lwhisker_id2. - apply id2_rwhisker. - apply lwhisker_vcomp. - apply rwhisker_vcomp. - apply vcomp_lunitor. - apply vcomp_runitor. - apply lwhisker_lwhisker. - apply rwhisker_lwhisker. - apply rwhisker_rwhisker. - apply vcomp_whisker. - apply lunitor_linvunitor. - apply linvunitor_lunitor. - apply runitor_rinvunitor. - apply rinvunitor_runitor. - apply lassociator_rassociator. - apply rassociator_lassociator. - apply runitor_rwhisker. - apply lassociator_lassociator. Qed. Definition ps_base : bicat. Proof. use build_bicategory. - exact ps_base_data. - exact ps_base_laws. - intros ? ? ? ?. use impred_isaset ; intro. apply D. Defined. Definition all_is_invertible_to_is_invertible_2cell {F G : ps_base} {η ε : F --> G} (α : η ==> ε) : (∏ (X : C), is_invertible_2cell (α X)) → is_invertible_2cell α. Proof. intros Hα. use tpair ; cbn in *. - exact (λ x, (Hα x)^-1). - split ; apply funextsec ; intro X ; cbn. + apply vcomp_rinv. + apply vcomp_linv. Defined. Definition is_invertible_2cell_to_all_is_invertible {F G : ps_base} {η ε : F --> G} (α : η ==> ε) : is_invertible_2cell α → (∏ (X : C), is_invertible_2cell (α X)). Proof. intros Hα X. use tpair. - exact (Hα^-1 X). - split ; cbn. + exact (maponpaths (λ φ, φ X) (vcomp_rinv Hα)). + exact (maponpaths (λ φ, φ X) (vcomp_linv Hα)). Defined. Definition all_is_invertible_is_is_invertible_2cell {F G : ps_base} {η ε : F --> G} (α : η ==> ε) : (∏ (X : C), is_invertible_2cell (α X)) ≃ is_invertible_2cell α. Proof. use weqimplimpl. - exact (all_is_invertible_to_is_invertible_2cell α). - exact (is_invertible_2cell_to_all_is_invertible α). - apply impred ; intro. apply isaprop_is_invertible_2cell. - apply isaprop_is_invertible_2cell. Defined. Definition invertible_2cell_ps_base {F G : ps_base} (η ε : F --> G) : (∏ (X : C), invertible_2cell (η X) (ε X)) → invertible_2cell η ε. Proof. intros α. use tpair. - intros X. exact (α X). - apply all_is_invertible_is_is_invertible_2cell. apply α. Defined. Definition invertible_2cell_ps_base_inv {F G : ps_base} (η ε : F --> G) : invertible_2cell η ε → (∏ (X : C), invertible_2cell (η X) (ε X)). Proof. intros α X. use tpair. - exact (cell_from_invertible_2cell α X). - apply is_invertible_2cell_to_all_is_invertible. apply α. Defined. Definition invertible_2cell_ps_base_weq {F G : ps_base} (η ε : F --> G) : (∏ (X : C), invertible_2cell (η X) (ε X)) ≃ invertible_2cell η ε. Proof. refine (make_weq (invertible_2cell_ps_base η ε) _). use isweq_iso. - exact (invertible_2cell_ps_base_inv η ε). - intros α. apply funextsec ; intro X. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } reflexivity. - intros α. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } apply funextsec ; intro X. reflexivity. Defined. Definition ps_base_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 ps_base. Proof. intros F G η ε. use weqhomot. - simple refine (invertible_2cell_ps_base_weq η ε ∘ _)%weq. simple refine (_ ∘ make_weq _ (isweqtoforallpaths _ _ _))%weq. simple refine (weqonsecfibers _ _ _). intro X ; cbn. exact (make_weq (idtoiso_2_1 (η X) (ε X)) (HD_2_1 _ _ _ _)). - intros p. induction p. use subtypePath. { intro ; apply isaprop_is_invertible_2cell. } reflexivity. Defined. Definition all_is_adjequiv_to_is_adjequiv {F G : ps_base} (η : F --> G) : (∏ (X : C), left_adjoint_equivalence (η X)) → left_adjoint_equivalence η. Proof. intros Hη. use tpair. - use tpair. + intros X. exact (pr11 (Hη X)). + split ; intros X ; cbn. * exact (pr121 (Hη X)). * exact (pr221 (Hη X)). - split ; split ; cbn. + apply funextsec ; intro X. exact (pr112 (Hη X)). + apply funextsec ; intro X. exact (pr212 (Hη X)). + apply all_is_invertible_is_is_invertible_2cell. exact (λ X, pr122 (Hη X)). + apply all_is_invertible_is_is_invertible_2cell. exact (λ X, pr222 (Hη X)). Defined. Definition is_adjequiv_to_all_is_adjequiv {F G : ps_base} (η : F --> G) : left_adjoint_equivalence η → (∏ (X : C), left_adjoint_equivalence (η X)). Proof. intros Hη X. use tpair. - use tpair. + exact (pr11 Hη X). + split ; cbn. * exact (pr121 Hη X). * exact (pr221 Hη X). - split ; split ; cbn. + exact (maponpaths (λ φ, φ X) (pr112 Hη)). + exact (maponpaths (λ φ, φ X) (pr212 Hη)). + exact (is_invertible_2cell_to_all_is_invertible (pr121 Hη) (pr122 Hη) X). + exact (is_invertible_2cell_to_all_is_invertible (pr221 Hη) (pr222 Hη) X). Defined. Definition all_is_adjequiv_is_is_adjequiv {F G : ps_base} (η : F --> G) : (∏ (X : C), left_adjoint_equivalence (η X)) ≃ left_adjoint_equivalence η. Proof. refine (make_weq (all_is_adjequiv_to_is_adjequiv η) _). use isweq_iso. - exact (is_adjequiv_to_all_is_adjequiv η). - intros Hη. apply funextsec ; intro X. use subtypePath. { intro. do 2 apply isapropdirprod ; try (apply D) ; apply isaprop_is_invertible_2cell. } reflexivity. - intros Hη. use subtypePath. { intro. do 2 apply isapropdirprod ; try (apply ps_base) ; apply isaprop_is_invertible_2cell. } reflexivity. Defined. Definition adjequiv_ps_base (F G : ps_base) : (∏ (X : C), adjoint_equivalence (F X) (G X)) → adjoint_equivalence F G. Proof. intros η. use tpair. - intros X. exact (η X). - apply all_is_adjequiv_is_is_adjequiv. apply η. Defined. Definition adjequiv_ps_base_inv (F G : ps_base) : adjoint_equivalence F G → (∏ (X : C), adjoint_equivalence (F X) (G X)). Proof. intros η X. use tpair. - exact (pr1 η X). - apply is_adjequiv_to_all_is_adjequiv. apply η. Defined. Definition adjequiv_ps_base_weq (F G : ps_base) : (∏ (X : C), adjoint_equivalence (F X) (G X)) ≃ adjoint_equivalence F G. Proof. refine (make_weq (adjequiv_ps_base F G) _). use isweq_iso. - exact (adjequiv_ps_base_inv F G). - intros η. apply funextsec ; intro X. use total2_paths_b. + reflexivity. + cbn. use subtypePath. { intro. do 2 apply isapropdirprod ; try (apply D) ; apply isaprop_is_invertible_2cell. } reflexivity. - intros η. use total2_paths_b. + reflexivity. + cbn. use subtypePath. { intro. do 2 apply isapropdirprod ; try (apply ps_base) ; apply isaprop_is_invertible_2cell. } reflexivity. Defined. Definition ps_base_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 ps_base. Proof. intros F G. use weqhomot. - simple refine (adjequiv_ps_base_weq F G ∘ _)%weq. simple refine (_ ∘ make_weq _ (isweqtoforallpaths _ _ _))%weq. simple refine (weqonsecfibers _ _ _). intro X ; cbn. exact (make_weq (idtoiso_2_0 (F X) (G X)) (pr1 HD _ _)). - intros p. induction p. use subtypePath. { intro. apply isaprop_left_adjoint_equivalence. exact (ps_base_is_univalent_2_1 (pr2 HD)). } reflexivity. Defined. Definition ps_base_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 ps_base. Proof. split. - apply ps_base_is_univalent_2_0; assumption. - apply ps_base_is_univalent_2_1. exact (pr2 HD). Defined. End BasePseudoFunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/Compositor.v000066400000000000000000000266251451125700300262040ustar00rootroot00000000000000(** The second layer of the construction of the bicategory of pseudofunctors consists of three parts. Third part: we add a 2-cell witnessing preservation of composition. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section Compositor. Variable (C D : bicat). Definition compositor_disp_cat_data : disp_cat_ob_mor (map1cells C D). Proof. use tpair. - exact (λ F, ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), Fmor F f · Fmor F g ==> Fmor F (f · g)). - exact (λ F G Fcomp Gcomp η, ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), (ηobj η X ◃ Gcomp X Y Z f g) • ηmor η (f · g) = (lassociator (ηobj η X) (Fmor G f) (Fmor G g)) • (ηmor η f ▹ (Fmor G g)) • rassociator (Fmor F f) (ηobj η Y) (Fmor G g) • (Fmor F f ◃ ηmor η g) • lassociator (Fmor F f) (Fmor F g) (ηobj η Z) • (Fcomp X Y Z f g ▹ ηobj η Z)). Defined. Definition compositor_disp_cat_id_comp : disp_cat_id_comp (map1cells C D) compositor_disp_cat_data. Proof. split. - intros F Fcomp X Y Z f g ; cbn in *. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_hcomp. rewrite triangle_l. rewrite <- rwhisker_hcomp. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. reflexivity. - intros F₁ F₂ F₃ η ε Fcomp₁ Fcomp₂ Fcomp₃ ηcomp εcomp X Y Z f g ; cbn in *. specialize (ηcomp X Y Z f g). specialize (εcomp X Y Z f g). rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. apply maponpaths. do 3 apply maponpaths_2. apply maponpaths. apply εcomp. } clear εcomp. use vcomp_move_R_pM. { is_iso. } cbn. etrans. { rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 (apply maponpaths). rewrite !vassocr. rewrite rwhisker_lwhisker. apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. apply maponpaths. apply ηcomp. } clear ηcomp. rewrite !vassocl. symmetry. etrans. { rewrite !vassocr. do 12 (apply maponpaths_2). rewrite rwhisker_hcomp. rewrite !vassocl, <- pentagon_2. rewrite <- lwhisker_hcomp. reflexivity. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. do 11 (apply maponpaths_2). symmetry. apply rwhisker_lwhisker. } rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 10 (apply maponpaths_2). rewrite !vassocl. rewrite lwhisker_hcomp, rwhisker_hcomp. symmetry. apply pentagon. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. symmetry. etrans. { apply maponpaths. rewrite !vassocr. do 6 apply (maponpaths_2). rewrite vassocl. symmetry. rewrite lwhisker_hcomp, rwhisker_hcomp. apply pentagon. } etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. reflexivity. } apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. do 5 (apply maponpaths_2). rewrite rwhisker_rwhisker. reflexivity. } rewrite !vassocl. symmetry. etrans. { rewrite !vassocr. do 9 (apply maponpaths_2). apply rwhisker_rwhisker. } etrans. { do 7 (apply maponpaths_2). rewrite !vassocl. apply maponpaths. rewrite rwhisker_hcomp. rewrite <- inverse_pentagon_4. rewrite <- lwhisker_hcomp. reflexivity. } etrans. { do 6 (apply maponpaths_2). rewrite !vassocl. rewrite lwhisker_vcomp. rewrite lassociator_rassociator, lwhisker_id2, id2_right. reflexivity. } symmetry. etrans. { rewrite !vassocr. rewrite <- vcomp_whisker. reflexivity. } rewrite !vassocl. apply maponpaths. symmetry. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. reflexivity. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 4 (apply maponpaths_2). rewrite inverse_pentagon. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite rassociator_lassociator, lwhisker_id2, id2_right. reflexivity. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. symmetry. apply inverse_pentagon_2. } rewrite !vassocl, <- rwhisker_hcomp. do 2 apply maponpaths. symmetry. apply rwhisker_rwhisker_alt. Qed. Definition compositor_disp_cat : disp_bicat (map1cells C D). Proof. use disp_cell_unit_bicat. use tpair. - exact compositor_disp_cat_data. - exact compositor_disp_cat_id_comp. Defined. Definition compositor_is_disp_univalent_2_1 : disp_univalent_2_1 compositor_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η Fcomp Gcomp ; simpl in *. repeat (apply impred ; intro). apply D. Defined. Definition compositor_is_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 compositor_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply map1cells_is_univalent_2_1. exact HD_2_1. - intros ; simpl. repeat (apply impred ; intro). apply D. - intro ; cbn. repeat (apply impred_isaset ; intro). apply D. - intros F F₂ F₂' η ; cbn in *. induction η as [η₁ η₂]. apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro Z. apply funextsec ; intro f. apply funextsec ; intro g. specialize (η₁ X Y Z f g). specialize (η₂ X Y Z f g). rewrite !vassocr in η₁. rewrite vcomp_lunitor in η₁. rewrite !vassocl in η₁. rewrite rinvunitor_natural in η₁. rewrite <- rwhisker_hcomp in η₁. rewrite !vassocr in η₁. apply rwhisker_id_inj. use (vcomp_lcancel (lunitor _ • rinvunitor _)). { is_iso. } refine (_ @ !η₁). rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- !lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. reflexivity. Defined. Definition compositor_is_disp_univalent_2 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2 compositor_disp_cat. Proof. split. - apply compositor_is_disp_univalent_2_0; assumption. - exact compositor_is_disp_univalent_2_1. Defined. Definition compositor_disp_left_adjequiv_over_id {F : map1cells C D} {Fc Gc : compositor_disp_cat F} (ηc : Fc -->[ internal_adjoint_equivalence_identity _ ] Gc) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity _) ηc. Proof. apply disp_cell_unit_bicat_left_adjoint_equivalence_weq. intros x y z f g. cbn. pose (ηc x y z f g) as p. cbn in p. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite <- lunitor_triangle. rewrite <- rinvunitor_triangle. rewrite !vassocl. rewrite !vassocl in p. refine (_ @ !p @ _). - apply maponpaths. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocr. refine (!(id2_left _) @ _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. - rewrite !vassocr. rewrite vcomp_lunitor. rewrite <- lunitor_triangle. rewrite <- rwhisker_vcomp. rewrite !vassocl. do 2 apply maponpaths. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite <- rinvunitor_triangle. rewrite !vassocr. do 2 apply maponpaths_2. rewrite <- !lwhisker_vcomp. refine (!(id2_left _) @ _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Qed. Definition compositor_disp_left_adjequiv {HD : is_univalent_2 D} {F G : map1cells C D} (η : adjoint_equivalence F G) {F₂ : compositor_disp_cat F} {G₂ : compositor_disp_cat G} (η₂ : F₂ -->[ η ] G₂) : disp_left_adjoint_equivalence η η₂. Proof. revert F G η F₂ G₂ η₂. use J_2_0. - apply map1cells_is_univalent_2_0. exact HD. - intros F F₂ G₂ η₂. apply compositor_disp_left_adjequiv_over_id. Defined. End Compositor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/Identitor.v000066400000000000000000000142521451125700300260000ustar00rootroot00000000000000(** The second layer of the construction of the bicategory of pseudofunctors consists of three parts. Second part: we add a 2-cell witnessing preservation of the identity. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section Identitor. Variable (C D : bicat). Definition identitor_disp_cat_data : disp_cat_ob_mor (map1cells C D). Proof. use tpair. - exact (λ F, ∏ (X : C), id₁ (Fobj F X) ==> Fmor F (id₁ X)). - exact (λ F G Fid Gid η, ∏ (X : C), (ηobj η X ◃ Gid X) • ηmor η (id₁ X) = (runitor (ηobj η X)) • linvunitor (ηobj η X) • (Fid X ▹ ηobj η X)). Defined. Definition identitor_disp_id_comp : disp_cat_id_comp (map1cells C D) identitor_disp_cat_data. Proof. split. - intros F Fid X ; cbn in *. rewrite !vassocr. rewrite runitor_lunitor_identity. rewrite lunitor_linvunitor, id2_left. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor, id2_left. rewrite rwhisker_hcomp. reflexivity. - intros F G H Fid Gid Hid η ε ηid εid X ; cbn in *. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite εid. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite runitor_triangle. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite ηid. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker, id2_left. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite linvunitor_assoc. reflexivity. Qed. Definition identitor_disp_cat : disp_bicat (map1cells C D). Proof. use disp_cell_unit_bicat. use tpair. - exact identitor_disp_cat_data. - exact identitor_disp_id_comp. Defined. Definition identitor_is_disp_univalent_2_1 : disp_univalent_2_1 identitor_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η Fid Gid ; simpl in *. apply impred ; intro. apply D. Defined. Definition identitor_is_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 identitor_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply map1cells_is_univalent_2_1. exact HD_2_1. - intros ; simpl. apply impred ; intro. apply D. - intro ; cbn. apply impred_isaset ; intro. apply D. - intros F Fid Fid' η ; cbn in *. apply funextsec ; intro X. induction η as [η₁ η₂]. specialize (η₁ X). specialize (η₂ X). rewrite !vassocr in η₁. rewrite vcomp_lunitor in η₁. rewrite !vassocl in η₁. rewrite rinvunitor_natural in η₁. rewrite <- rwhisker_hcomp in η₁. rewrite lunitor_runitor_identity, lunitor_V_id_is_left_unit_V_id in η₁. rewrite !vassocr in η₁. rewrite !runitor_rinvunitor, !id2_left in η₁. apply rwhisker_id_inj. exact (!η₁). Defined. Definition identitor_is_disp_univalent_2 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2 identitor_disp_cat. Proof. split. - apply identitor_is_disp_univalent_2_0; assumption. - exact identitor_is_disp_univalent_2_1. Defined. Definition identitor_disp_left_adjequiv_over_id {F : map1cells C D} {Fid Gid : identitor_disp_cat F} (ηid : Fid -->[ internal_adjoint_equivalence_identity _ ] Gid) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity _) ηid. Proof. apply disp_cell_unit_bicat_left_adjoint_equivalence_weq. intro x. cbn. pose (ηid x) as p. cbn in p. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite lunitor_runitor_identity. rewrite <- lunitor_V_id_is_left_unit_V_id. rewrite !vassocr. refine (!p @ _). rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite lunitor_runitor_identity. rewrite <- lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition identitor_disp_left_adjequiv {HD : is_univalent_2 D} {F G : map1cells C D} (η : adjoint_equivalence F G) {F₂ : identitor_disp_cat F} {G₂ : identitor_disp_cat G} (η₂ : F₂ -->[ η ] G₂) : disp_left_adjoint_equivalence η η₂. Proof. revert F G η F₂ G₂ η₂. use J_2_0. - apply map1cells_is_univalent_2_0. exact HD. - intros F F₂ G₂ η₂. apply identitor_disp_left_adjequiv_over_id. Defined. End Identitor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/Map1Cells.v000066400000000000000000000567671451125700300256410ustar00rootroot00000000000000(** This is the first layer of the construction of the bicategory of pseudofunctors. To a function of objects, we add an action of 1-cells. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section Map1Cells. Variable (C D : bicat). Definition map1cells_disp_cat : disp_cat_ob_mor (ps_base C D). Proof. use tpair. - exact (λ F₀, ∏ (X Y : C), X --> Y → F₀ X --> F₀ Y). - exact (λ F₀ G₀ F₁ G₁ η, ∏ (X Y : C) (f : X --> Y), invertible_2cell (η X · G₁ X Y f) (F₁ X Y f · η Y)). Defined. Definition map1cells_disp_cat_id_comp : disp_cat_id_comp (ps_base C D) map1cells_disp_cat. Proof. use tpair. - cbn. refine (λ F₀ F₁ X Y f, (lunitor (F₁ X Y f) • rinvunitor (F₁ X Y f) ,, _)). is_iso. - cbn. refine (λ F₀ G₀ H₀ η₁ ε₁ F₁ G₁ H₁ η₂ ε₂ X Y f, (rassociator (η₁ X) (ε₁ X) (H₁ X Y f)) • (η₁ X ◃ ε₂ X Y f) • lassociator (η₁ X) (G₁ X Y f) (ε₁ Y) • (η₂ X Y f ▹ ε₁ Y) • rassociator (F₁ X Y f) (η₁ Y) (ε₁ Y) ,, _). is_iso. + apply ε₂. + apply η₂. Defined. Definition map1cells_disp_cat_2cell : disp_2cell_struct map1cells_disp_cat := λ F₀ G₀ η₁ ε₁ m F₁ G₁ η₂ ε₂, ∏ (X Y : C) (f : X --> Y), η₂ X Y f • (F₁ X Y f ◃ m Y) = (m X ▹ G₁ X Y f) • ε₂ X Y f. Definition map1cells_prebicat_1 : disp_prebicat_1_id_comp_cells (ps_base C D). Proof. use tpair. - use tpair. + exact map1cells_disp_cat. + exact map1cells_disp_cat_id_comp. - exact (λ F₀ G₀ η₁ ε₁ m F₁ G₁ η₂ ε₂, ∏ (X Y : C) (f : X --> Y), η₂ X Y f • (F₁ X Y f ◃ m Y) = (m X ▹ G₁ X Y f) • ε₂ X Y f). Defined. Definition map1cells_ops : disp_prebicat_ops map1cells_prebicat_1. Proof. repeat split. - intros F₀ G₀ η₁ F₁ G₁ η₂ X Y f ; cbn in *. rewrite lwhisker_id2, id2_right. rewrite id2_rwhisker, id2_left. reflexivity. - intros F₀ G₀ η₁ F₁ G₁ η₂ X Y f ; cbn in *. rewrite !vassocl. rewrite (lwhisker_hcomp _ (lunitor _)). rewrite triangle_l. rewrite <- !rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor, id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. use vcomp_move_R_pM. { is_iso. } cbn. rewrite !vassocr. rewrite <- lunitor_assoc. reflexivity. - intros F₀ G₀ η₁ F₁ G₁ η₂ X Y f ; cbn in *. rewrite !vassocl. use vcomp_move_R_pM. { is_iso. } cbn. refine (_ @ vassocl _ _ _). rewrite !runitor_triangle. rewrite (rwhisker_hcomp _ (runitor _)). rewrite <- triangle_r. rewrite vcomp_runitor. rewrite <- lwhisker_vcomp, <- lwhisker_hcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rinvunitor_triangle. rewrite rinvunitor_runitor, id2_left. reflexivity. - intros F₀ G₀ η₁ F₁ G₁ η₂ X Y f ; cbn in *. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. refine (vassocl _ _ _ @ _). rewrite <- linvunitor_assoc. rewrite lwhisker_hcomp. rewrite triangle_l_inv, <- rwhisker_hcomp. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite lunitor_triangle. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite vcomp_lunitor. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. reflexivity. - intros F₀ G₀ η₁ F₁ G₁ η₂ X Y f ; cbn in *. rewrite !vassocr. use vcomp_move_L_Mp. { is_iso. } cbn. refine (vassocl _ _ _ @ _). rewrite rinvunitor_triangle. rewrite (rwhisker_hcomp _ (rinvunitor _)). rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. reflexivity. - intros F₀ G₀ H₀ K₀ α₁ η₁ ε₁ F₁ G₁ H₁ K₁ α₂ η₂ ε₂ X Y f ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. refine (!(_ @ _)). { rewrite !vassocr. do 7 apply maponpaths_2. symmetry. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite vassocl. apply inverse_pentagon. } rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 5 apply maponpaths_2. rewrite lwhisker_hcomp. rewrite vassocl, <- inverse_pentagon_6. rewrite <- rwhisker_hcomp. reflexivity. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. reflexivity. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 3 apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_hcomp, rwhisker_hcomp. symmetry. apply inverse_pentagon. } rewrite (lwhisker_hcomp _ (rassociator _ _ _)), (rwhisker_hcomp _ (rassociator _ _ _)). rewrite <- inverse_pentagon. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_rwhisker_alt. apply maponpaths_2. rewrite !vassocl. rewrite rassociator_lassociator, id2_right. reflexivity. - intros F₀ G₀ H₀ K₀ α₁ η₁ ε₁ F₁ G₁ H₁ K₁ α₂ η₂ ε₂ X Y f ; cbn in *. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 8 apply maponpaths_2. rewrite lwhisker_hcomp, rwhisker_hcomp. symmetry. rewrite !vassocl. apply inverse_pentagon. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. reflexivity. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. rewrite inverse_pentagon. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2, id2_left. rewrite !vassocl. reflexivity. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. reflexivity. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 4 apply maponpaths_2. rewrite vassocl, lwhisker_hcomp, rwhisker_hcomp. symmetry. apply inverse_pentagon. } rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rassociator_lassociator, id2_left. rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. symmetry. rewrite lwhisker_hcomp, rwhisker_hcomp. apply inverse_pentagon_6. - intros F₀ G₀ α₁ η₁ ε₁ m₂ n₂ F₁ G₁ α₂ η₂ ε₂ m₃ n₃ X Y f ; cbn in *. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite m₃. rewrite !vassocl. rewrite n₃. rewrite !vassocr. rewrite rwhisker_vcomp. reflexivity. - intros F₀ G₀ H₀ α₁ η₁ ε₁ m₂ F₁ G₁ H₁ α₂ η₂ ε₂ m₃ X Y f ; cbn in *. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. rewrite <- m₃. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite vcomp_whisker. rewrite !vassocr. rewrite lwhisker_lwhisker. reflexivity. - intros F₀ G₀ H₀ α₁ η₁ ε₁ m₂ F₁ G₁ H₁ α₂ η₂ ε₂ m₃ X Y f ; cbn in *. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. rewrite m₃. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite <- rwhisker_rwhisker. reflexivity. Qed. Definition map1cells_ops_laws : disp_prebicat_laws (_ ,, map1cells_ops). Proof. repeat split ; intro ; intros ; do 3 (apply funextsec ; intro) ; apply D. Qed. Definition map1cells_disp_prebicat : disp_prebicat (ps_base C D) := (_ ,, map1cells_ops_laws). Definition map1cells_disp_bicat : disp_bicat (ps_base C D). Proof. refine (map1cells_disp_prebicat ,, _). intros X Y f g α hX hY hf hg hα hβ. apply isasetaprop. do 3 (apply impred ; intro). apply D. Defined. Definition map1cells_disp_univalent_2_1 : disp_univalent_2_1 map1cells_disp_bicat. Proof. apply fiberwise_local_univalent_is_univalent_2_1. intros F G η F₁ G₁ η₁ η₁'. use isweqimplimpl. - intro m ; cbn in *. apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro f. pose (pr1 m X Y f) as n. cbn in n. rewrite id2_rwhisker, lwhisker_id2 in n. rewrite id2_left, id2_right in n. apply subtypePath. + intro. apply isaprop_is_invertible_2cell. + apply n. - repeat (apply impred_isaset ; intro). use isaset_total2. + apply D. + intro. apply isasetaprop. apply isaprop_is_invertible_2cell. - apply isaproptotal2. + intro. apply (@isaprop_is_disp_invertible_2cell (ps_base C D)). + intros. repeat (apply funextsec ; intro). apply D. Defined. Definition all_invertible_map1cells_inv {F G : ps_base C D} {η ε : F --> G} (m : invertible_2cell η ε) {F₁ : map1cells_disp_bicat F} {G₁ : map1cells_disp_bicat G} {η₁ : F₁ -->[ η ] G₁} {ε₁ : F₁ -->[ ε ] G₁} (m₁ : η₁ ==>[ m ] ε₁) : ε₁ ==>[ m^-1 ] η₁. Proof. intros X Y f. use vcomp_move_R_Mp. { is_iso. apply is_invertible_2cell_to_all_is_invertible. is_iso. } rewrite !vassocl. use vcomp_move_L_pM. { is_iso. apply is_invertible_2cell_to_all_is_invertible. is_iso. } exact (!(m₁ X Y f)). Qed. Definition all_invertible_map1cells {F G : ps_base C D} {η ε : F --> G} (m : invertible_2cell η ε) {F₁ : map1cells_disp_bicat F} {G₁ : map1cells_disp_bicat G} {η₁ : F₁ -->[ η ] G₁} {ε₁ : F₁ -->[ ε ] G₁} (m₁ : η₁ ==>[ m ] ε₁) : is_disp_invertible_2cell m m₁. Proof. use tpair. - exact (all_invertible_map1cells_inv m m₁). - split ; repeat (apply funextsec ; intro) ; apply D. Qed. Section AllInvertible2CellToDispAdjEquiv. Variable (F₀ : ps_base C D) (F₁ F₁' : map1cells_disp_bicat F₀) (η : (∏ (X Y : C) (f : X --> Y), invertible_2cell (F₁ X Y f) (F₁' X Y f))). Local Definition all_invertible_left_adj : F₁ -->[ internal_adjoint_equivalence_identity F₀] F₁'. Proof. intros X Y f ; cbn. use tpair. - exact (lunitor _ • (η X Y f)^-1 • rinvunitor _). - cbn. is_iso. Defined. Local Definition all_invertible_right_adj : F₁' -->[ left_adjoint_right_adjoint (internal_adjoint_equivalence_identity F₀)] F₁. Proof. intros X Y f. use tpair. - exact (lunitor _ • η X Y f • rinvunitor _). - cbn. is_iso. apply η. Defined. Local Definition all_invertible_unit : id_disp F₁ ==>[ left_adjoint_unit (internal_adjoint_equivalence_identity F₀)] all_invertible_left_adj;;all_invertible_right_adj. Proof. intros X Y f ; cbn. rewrite !vassocr. rewrite <- linvunitor_assoc. rewrite !lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite vassocr. rewrite rinvunitor_natural. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite linvunitor_assoc. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rassociator_lassociator, id2_left. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite <- rwhisker_hcomp, rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_rinv, id2_left. rewrite triangle_r_inv. rewrite rwhisker_hcomp. reflexivity. Qed. Local Definition all_invertible_counit : (all_invertible_right_adj;; all_invertible_left_adj) ==>[left_adjoint_counit (internal_adjoint_equivalence_identity F₀)] id_disp F₁'. Proof. intros X Y f ; cbn. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)). rewrite <- (vcomp_lunitor (F₁ X Y f)). rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite vcomp_linv, lwhisker_id2, id2_left. rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite runitor_triangle. rewrite rinvunitor_runitor, id2_right. rewrite !vassocr. do 2 (apply maponpaths_2). use vcomp_move_R_pM. { is_iso. } cbn. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite triangle_r. rewrite lunitor_runitor_identity. reflexivity. Qed. Definition all_invertible_2cell_to_disp_adjoint_equivalence : disp_adjoint_equivalence (internal_adjoint_equivalence_identity F₀) F₁ F₁'. Proof. use tpair. - exact all_invertible_left_adj. - use tpair. + use tpair. * exact all_invertible_right_adj. * split. ** exact all_invertible_unit. ** exact all_invertible_counit. + split ; split. * repeat (apply funextsec ; intro). apply D. * repeat (apply funextsec ; intro). apply D. * apply all_invertible_map1cells. * apply all_invertible_map1cells. Defined. End AllInvertible2CellToDispAdjEquiv. Definition disp_adjoint_equivalence_to_all_invertible_2cell (F₀ : ps_base C D) (F₁ F₁' : map1cells_disp_bicat F₀) : disp_adjoint_equivalence (internal_adjoint_equivalence_identity F₀) F₁ F₁' → (∏ (X Y : C) (f : X --> Y), invertible_2cell (F₁ X Y f) (F₁' X Y f)). Proof. intros m X Y f. use tpair. - refine (rinvunitor _ • _ • lunitor _). exact ((pr1 m X Y f)^-1). - cbn ; is_iso. Defined. Definition all_invertible_2cell_is_disp_adjoint_equivalence (HD_2_1 : is_univalent_2_1 D) (F₀ : ps_base C D) (F₁ F₁' : map1cells_disp_bicat F₀) : (∏ (X Y : C) (f : X --> Y), invertible_2cell (F₁ X Y f) (F₁' X Y f)) ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity F₀) F₁ F₁'. Proof. refine (make_weq (all_invertible_2cell_to_disp_adjoint_equivalence F₀ F₁ F₁') _). use isweq_iso. - exact (disp_adjoint_equivalence_to_all_invertible_2cell F₀ F₁ F₁'). - intro m. apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro f. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite !vassocr. rewrite rinvunitor_runitor, id2_left. rewrite !vassocl. rewrite linvunitor_lunitor, id2_right. reflexivity. - intro m. use subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. + exact (ps_base_is_univalent_2_1 _ _ HD_2_1). + apply map1cells_disp_univalent_2_1. } apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro f. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite !vassocr. rewrite lunitor_linvunitor, id2_left. rewrite !vassocl. rewrite runitor_rinvunitor, id2_right. reflexivity. Defined. Definition map1cells_disp_left_adjoint_equivalence_help (HD : is_univalent_2 D) {F₀ G₀ : ps_base C D} (η₀ : adjoint_equivalence F₀ G₀) (F₁ : map1cells_disp_bicat F₀) (G₁ : map1cells_disp_bicat G₀) (η₁ : F₁ -->[ η₀ ] G₁) : disp_left_adjoint_equivalence η₀ η₁. Proof. revert F₀ G₀ η₀ F₁ G₁ η₁. use J_2_0. - use ps_base_is_univalent_2_0. exact HD. - intros F₀ F₁ F₁' η₁. cbn in η₁. pose (pr2 (all_invertible_2cell_to_disp_adjoint_equivalence F₀ F₁ F₁' (λ x y f, comp_of_invertible_2cell (rinvunitor_invertible_2cell _) (comp_of_invertible_2cell (inv_of_invertible_2cell (η₁ x y f)) (lunitor_invertible_2cell _))))) as H. refine (transportf (disp_left_adjoint_equivalence _) _ H). use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ]. cbn. rewrite !vassocr. rewrite lunitor_linvunitor. rewrite id2_left. rewrite !vassocl. rewrite runitor_rinvunitor. rewrite id2_right. apply idpath. Qed. Definition map1cells_disp_left_adjoint_equivalence (HD : is_univalent_2 D) {F₀ G₀ : ps_base C D} {η₀ : F₀ --> G₀} (Hη₀ : left_adjoint_equivalence η₀) (F₁ : map1cells_disp_bicat F₀) (G₁ : map1cells_disp_bicat G₀) (η₁ : F₁ -->[ η₀ ] G₁) : disp_left_adjoint_equivalence Hη₀ η₁ := map1cells_disp_left_adjoint_equivalence_help HD (η₀ ,, Hη₀) F₁ G₁ η₁. Definition map1cells_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 map1cells_disp_bicat. Proof. apply fiberwise_univalent_2_0_to_disp_univalent_2_0. intros F₀ F₁ F₁'. use weqhomot. - simple refine (_ ∘ make_weq _ (isweqtoforallpaths _ _ _))%weq. simple refine (_ ∘ weqonsecfibers _ _ _)%weq. + exact (λ X, ∏ (Y : C) (f : X --> Y), F₁ X Y f = F₁' X Y f). + intro X ; cbn. simple refine (_ ∘ make_weq _ (isweqtoforallpaths _ _ _))%weq. simple refine (weqonsecfibers _ _ _)%weq. intro Y ; cbn. simple refine (_ ∘ make_weq _ (isweqtoforallpaths _ _ _))%weq. apply idweq. + refine (_ ∘ weqonsecfibers _ _ _)%weq. * intro X ; cbn. refine (weqonsecfibers _ _ _). intro Y ; cbn. simple refine (weqonsecfibers _ _ _). -- exact (λ f, invertible_2cell (F₁ X Y f) (F₁' X Y f)). -- intro f ; cbn. exact (make_weq (idtoiso_2_1 (F₁ X Y f) (F₁' X Y f)) (HD_2_1 _ _ _ _)). * exact (all_invertible_2cell_is_disp_adjoint_equivalence HD_2_1 F₀ F₁ F₁'). - intro p. induction p. apply subtypePath. { intro. apply isaprop_disp_left_adjoint_equivalence. + exact (ps_base_is_univalent_2_1 _ _ HD_2_1). + apply map1cells_disp_univalent_2_1. } apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro f. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } cbn. rewrite id2_right. reflexivity. Defined. Definition map1cells := total_bicat map1cells_disp_bicat. Definition map1cells_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 map1cells. Proof. apply total_is_univalent_2_1. - apply ps_base_is_univalent_2_1. exact HD_2_1. - exact map1cells_disp_univalent_2_1. Defined. Definition map1cells_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 map1cells. Proof. apply total_is_univalent_2_0. - apply ps_base_is_univalent_2. exact HD. - exact (map1cells_disp_univalent_2_0 (pr2 HD)). Defined. Definition map1cells_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 map1cells. Proof. split. - apply map1cells_is_univalent_2_0; assumption. - apply map1cells_is_univalent_2_1. exact (pr2 HD). Defined. End Map1Cells. Definition Fobj {C D : bicat} (F : map1cells C D) : C → D := pr1 F. Definition Fmor {C D : bicat} (F : map1cells C D) : ∏ {X Y : C}, X --> Y → Fobj F X --> Fobj F Y := pr2 F. Definition ηobj {C D : bicat} {F G : map1cells C D} (η : F --> G) : ∏ (X : C), Fobj F X --> Fobj G X := pr1 η. Definition ηmor {C D : bicat} {F G : map1cells C D} (η : F --> G) : ∏ {X Y : C} (f : X --> Y), ηobj η X · Fmor G f ==> Fmor F f · ηobj η Y := pr2 η. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/Map2Cells.v000066400000000000000000000130721451125700300256200ustar00rootroot00000000000000(** The second layer of the construction of the bicategory of pseudofunctors consists of three parts. First part: we add an action of 1-cells. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section Map2Cells. Variable (C D : bicat). Definition map2cells_disp_cat_data : disp_cat_ob_mor (map1cells C D). Proof. use tpair. - exact (λ F, ∏ (X Y : C) (f g : X --> Y), f ==> g → Fmor F f ==> Fmor F g). - exact (λ F G F₂ G₂ η, ∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (ηobj η X ◃ G₂ X Y f g α) • ηmor η g = ηmor η f • (F₂ X Y f g α ▹ ηobj η Y)) ; cbn in *. Defined. Definition map2cells_disp_cat_id_comp : disp_cat_id_comp (map1cells C D) map2cells_disp_cat_data. Proof. split. - intros F F₂ X Y f g α ; cbn in *. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. reflexivity. - intros F G H η ε F₂ G₂ H₂ η₂ ε₂ X Y f g α ; cbn in *. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite ε₂. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite η₂. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. reflexivity. Qed. Definition map2cells_disp_cat : disp_bicat (map1cells C D). Proof. use disp_cell_unit_bicat. use tpair. - exact map2cells_disp_cat_data. - exact map2cells_disp_cat_id_comp. Defined. Definition map2cells_is_disp_univalent_2_1 : disp_univalent_2_1 map2cells_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η F₂ G₂ ; simpl in *. repeat (apply impred ; intro). apply D. Defined. Definition map2cells_is_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 map2cells_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply map1cells_is_univalent_2_1. exact HD_2_1. - intros ; simpl. repeat (apply impred ; intro). apply D. - intro ; cbn. repeat (apply impred_isaset ; intro). apply D. - intros F F₂ F₂' η ; cbn in *. induction η as [η₁ η₂]. apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro f. apply funextsec ; intro g. apply funextsec ; intro α. specialize (η₁ X Y f g α). specialize (η₂ X Y f g α). rewrite !vassocr in η₁. rewrite vcomp_lunitor in η₁. rewrite !vassocl in η₁. rewrite rinvunitor_natural in η₁. rewrite <- rwhisker_hcomp in η₁. rewrite !vassocr in η₁. apply rwhisker_id_inj. use (vcomp_lcancel (lunitor _ • rinvunitor _)). { is_iso. } exact (!η₁). Defined. Definition map2cells_is_disp_univalent_2 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2 map2cells_disp_cat. Proof. split. - apply map2cells_is_disp_univalent_2_0; assumption. - exact map2cells_is_disp_univalent_2_1. Defined. Definition map2cells_disp_left_adjequiv_over_id {F : map1cells C D} {F₂ G₂ : map2cells_disp_cat F} (η₂ : F₂ -->[ internal_adjoint_equivalence_identity _ ] G₂) : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity _) η₂. Proof. apply disp_cell_unit_bicat_left_adjoint_equivalence_weq. intros x y f g α. cbn. pose (η₂ x y f g α) as p. cbn in p. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. rewrite !vassocr. refine (!p @ _). rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. Qed. Definition map2cells_disp_left_adjequiv {HD : is_univalent_2 D} {F G : map1cells C D} (η : adjoint_equivalence F G) {F₂ : map2cells_disp_cat F} {G₂ : map2cells_disp_cat G} (η₂ : F₂ -->[ η ] G₂) : disp_left_adjoint_equivalence η η₂. Proof. revert F G η F₂ G₂ η₂. use J_2_0. - apply map1cells_is_univalent_2_0. exact HD. - intros F F₂ G₂ η₂. apply map2cells_disp_left_adjequiv_over_id. Defined. End Map2Cells. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/PseudoFunctorBicat.v000066400000000000000000000203011451125700300275720ustar00rootroot00000000000000(** This is the third and final layer of the construction of the bicategory of pseudofunctors. Here we add the laws. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Local Open Scope cat. Section PseudoFunctorData. Variable (C D : bicat). Definition psfunctor_data_disp : disp_bicat (map1cells C D) := disp_dirprod_bicat (map2cells_disp_cat C D) (disp_dirprod_bicat (identitor_disp_cat C D) (compositor_disp_cat C D)). Definition psfunctor_data_bicat : bicat := total_bicat psfunctor_data_disp. Definition psfunctor_data : UU := psfunctor_data_bicat. Definition psfunctor_data_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 psfunctor_data_bicat. Proof. apply is_univalent_2_1_total_dirprod. - apply map1cells_is_univalent_2_1. exact HD_2_1. - apply map2cells_is_disp_univalent_2_1. - apply is_univalent_2_1_dirprod_bicat. + apply identitor_is_disp_univalent_2_1. + apply compositor_is_disp_univalent_2_1. Defined. Definition psfunctor_data_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 psfunctor_data_bicat. Proof. pose (HD_2_1 := pr2 HD). apply is_univalent_2_0_total_dirprod. - apply map1cells_is_univalent_2; assumption. - apply map2cells_is_disp_univalent_2; assumption. - apply is_univalent_2_dirprod_bicat. + apply map1cells_is_univalent_2_1; assumption. + apply identitor_is_disp_univalent_2; assumption. + apply compositor_is_disp_univalent_2; assumption. Defined. Definition psfunctor_data_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 psfunctor_data_bicat. Proof. split. - apply psfunctor_data_is_univalent_2_0; assumption. - apply psfunctor_data_is_univalent_2_1. exact (pr2 HD). Defined. End PseudoFunctorData. Coercion functor_data_from_bifunctor_ob_mor_cell {C D : bicat} (F: psfunctor_data C D) : functor_data C D := pr1 F. Definition psfunctor_on_cells {C D : bicat} (F : psfunctor_data C D) {a b : C} {f g : a --> b} (x : f ==> g) : #F f ==> #F g := pr12 F a b f g x. Local Notation "'##'" := (psfunctor_on_cells). Definition psfunctor_id {C D : bicat} (F : psfunctor_data C D) (a : C) : identity (F a) ==> #F (identity a) := pr122 F a. Definition psfunctor_comp {C D : bicat} (F : psfunctor_data C D) {a b c : C} (f : a --> b) (g : b --> c) : #F f · #F g ==> #F (f · g) := pr222 F a b c f g. Section FunctorLaws. Context {C D : bicat}. Variable (F : psfunctor_data C D). Definition psfunctor_id2_law : UU := ∏ (a b : C) (f : a --> b), ##F (id2 f) = id2 _. Definition psfunctor_vcomp2_law : UU := ∏ (a b : C) (f g h: C⟦a, b⟧) (η : f ==> g) (φ : g ==> h), ##F (η • φ) = ##F η • ##F φ. Definition psfunctor_lunitor_law : UU := ∏ (a b : C) (f : C⟦a, b⟧), lunitor (#F f) = (psfunctor_id F a ▹ #F f) • psfunctor_comp F (identity a) f • ##F (lunitor f). Definition psfunctor_runitor_law : UU := ∏ (a b : C) (f : C⟦a, b⟧), runitor (#F f) = (#F f ◃ psfunctor_id F b) • psfunctor_comp F f (identity b) • ##F (runitor f). Definition psfunctor_lassociator_law : UU := ∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧), (#F f ◃ psfunctor_comp F g h) • psfunctor_comp F f (g · h) • ##F (lassociator f g h) = (lassociator (#F f) (#F g) (#F h)) • (psfunctor_comp F f g ▹ #F h) • psfunctor_comp F (f · g) h. Definition psfunctor_lwhisker_law : UU := ∏ (a b c : C) (f : C⟦a, b⟧) (g₁ g₂ : C⟦b, c⟧) (η : g₁ ==> g₂), psfunctor_comp F f g₁ • ##F (f ◃ η) = #F f ◃ ##F η • psfunctor_comp F f g₂. Definition psfunctor_rwhisker_law : UU := ∏ (a b c : C) (f₁ f₂ : C⟦a, b⟧) (g : C⟦b, c⟧) (η : f₁ ==> f₂), psfunctor_comp F f₁ g • ##F (η ▹ g) = ##F η ▹ #F g • psfunctor_comp F f₂ g. Definition psfunctor_laws : UU := psfunctor_id2_law × psfunctor_vcomp2_law × psfunctor_lunitor_law × psfunctor_runitor_law × psfunctor_lassociator_law × psfunctor_lwhisker_law × psfunctor_rwhisker_law. Definition invertible_cells : UU := (∏ (a : C), is_invertible_2cell (psfunctor_id F a)) × (∏ (a b c : C) (f : a --> b) (g : b --> c), is_invertible_2cell (psfunctor_comp F f g)). Definition is_psfunctor : UU := psfunctor_laws × invertible_cells. Definition is_psfunctor_isaprop : isaprop is_psfunctor. Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; try (apply D) ; try (apply isaprop_is_invertible_2cell). Qed. End FunctorLaws. Section LaxFunctorBicat. Variable (C D : bicat). Definition laxfunctor_bicat : bicat := fullsubbicat (psfunctor_data_bicat C D) psfunctor_laws. Definition laxfunctor_bicat_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 laxfunctor_bicat. Proof. apply is_univalent_2_1_fullsubbicat. apply psfunctor_data_is_univalent_2_1. exact HD_2_1. Defined. Definition laxfunctor_bicat_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 laxfunctor_bicat. Proof. apply is_univalent_2_0_fullsubbicat. - apply psfunctor_data_is_univalent_2; assumption. - intro. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; try (apply D). Defined. Definition laxfunctor_bicat_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 laxfunctor_bicat. Proof. split. - apply laxfunctor_bicat_is_univalent_2_0; assumption. - apply laxfunctor_bicat_is_univalent_2_1. exact (pr2 HD). Defined. End LaxFunctorBicat. Section PseudoFunctorBicat. Variable (C D : bicat). Definition psfunctor_bicat : bicat := fullsubbicat (psfunctor_data_bicat C D) is_psfunctor. Definition psfunctor_bicat_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 psfunctor_bicat. Proof. apply is_univalent_2_1_fullsubbicat. apply psfunctor_data_is_univalent_2_1. exact HD_2_1. Defined. Definition psfunctor_bicat_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 psfunctor_bicat. Proof. apply is_univalent_2_0_fullsubbicat. - apply psfunctor_data_is_univalent_2; assumption. - intro. apply is_psfunctor_isaprop. Defined. Definition psfunctor_bicat_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 psfunctor_bicat. Proof. split. - apply psfunctor_bicat_is_univalent_2_0; assumption. - apply psfunctor_bicat_is_univalent_2_1. exact (pr2 HD). Defined. End PseudoFunctorBicat. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/StrictCompositor.v000066400000000000000000000240721451125700300273670ustar00rootroot00000000000000(** The second layer of the construction of the bicategory of strict pseudofunctors consists of three parts. Third part: we add a 2-cell witnessing the strict preservation of composition. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section StrictCompositor. Variable (C D : bicat). Definition strict_compositor_disp_cat_data : disp_cat_ob_mor (map1cells C D). Proof. use tpair. - exact (λ F, ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), Fmor F f · Fmor F g = Fmor F (f · g)). - exact (λ F G Fcomp Gcomp η, ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), (ηobj η X ◃ idtoiso_2_1 _ _ (Gcomp X Y Z f g)) • ηmor η (f · g) = (lassociator (ηobj η X) (Fmor G f) (Fmor G g)) • (ηmor η f ▹ (Fmor G g)) • rassociator (Fmor F f) (ηobj η Y) (Fmor G g) • (Fmor F f ◃ ηmor η g) • lassociator (Fmor F f) (Fmor F g) (ηobj η Z) • (idtoiso_2_1 _ _ (Fcomp X Y Z f g) ▹ ηobj η Z)). Defined. Definition strict_compositor_disp_cat_id_comp : disp_cat_id_comp (map1cells C D) strict_compositor_disp_cat_data. Proof. split. - intros F Fcomp X Y Z f g ; cbn in *. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_hcomp. rewrite triangle_l. rewrite <- rwhisker_hcomp. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. reflexivity. - intros F₁ F₂ F₃ η ε Fcomp₁ Fcomp₂ Fcomp₃ ηcomp εcomp X Y Z f g ; cbn in *. specialize (ηcomp X Y Z f g). specialize (εcomp X Y Z f g). rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. apply maponpaths. do 3 apply maponpaths_2. apply maponpaths. apply εcomp. } clear εcomp. use vcomp_move_R_pM. { is_iso. } cbn. etrans. { rewrite <- !lwhisker_vcomp. rewrite !vassocl. do 5 (apply maponpaths). rewrite !vassocr. rewrite rwhisker_lwhisker. apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite rwhisker_vcomp. apply maponpaths. apply ηcomp. } clear ηcomp. rewrite !vassocl. symmetry. etrans. { rewrite !vassocr. do 12 (apply maponpaths_2). rewrite rwhisker_hcomp. rewrite !vassocl, <- pentagon_2. rewrite <- lwhisker_hcomp. reflexivity. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. do 11 (apply maponpaths_2). symmetry. apply rwhisker_lwhisker. } rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 10 (apply maponpaths_2). rewrite !vassocl. rewrite lwhisker_hcomp, rwhisker_hcomp. symmetry. apply pentagon. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. symmetry. etrans. { apply maponpaths. rewrite !vassocr. do 6 apply (maponpaths_2). rewrite vassocl. symmetry. rewrite lwhisker_hcomp, rwhisker_hcomp. apply pentagon. } etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. reflexivity. } apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. do 5 (apply maponpaths_2). rewrite rwhisker_rwhisker. reflexivity. } rewrite !vassocl. symmetry. etrans. { rewrite !vassocr. do 9 (apply maponpaths_2). apply rwhisker_rwhisker. } etrans. { do 7 (apply maponpaths_2). rewrite !vassocl. apply maponpaths. rewrite rwhisker_hcomp. rewrite <- inverse_pentagon_4. rewrite <- lwhisker_hcomp. reflexivity. } etrans. { do 6 (apply maponpaths_2). rewrite !vassocl. rewrite lwhisker_vcomp. rewrite lassociator_rassociator, lwhisker_id2, id2_right. reflexivity. } symmetry. etrans. { rewrite !vassocr. rewrite <- vcomp_whisker. reflexivity. } rewrite !vassocl. apply maponpaths. symmetry. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. reflexivity. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. etrans. { rewrite !vassocr. do 4 (apply maponpaths_2). rewrite inverse_pentagon. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite rassociator_lassociator, lwhisker_id2, id2_right. reflexivity. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. symmetry. apply inverse_pentagon_2. } rewrite !vassocl, <- rwhisker_hcomp. do 2 apply maponpaths. symmetry. apply rwhisker_rwhisker_alt. Qed. Definition strict_compositor_disp_cat : disp_bicat (map1cells C D). Proof. use disp_cell_unit_bicat. use tpair. - exact strict_compositor_disp_cat_data. - exact strict_compositor_disp_cat_id_comp. Defined. Definition strict_compositor_is_disp_univalent_2_1 : disp_univalent_2_1 strict_compositor_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η Fcomp Gcomp ; simpl in *. repeat (apply impred ; intro). apply D. Defined. Definition strict_compositor_is_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 strict_compositor_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply map1cells_is_univalent_2_1. exact HD_2_1. - intros ; simpl. repeat (apply impred ; intro). apply D. - intro ; cbn. repeat (apply impred_isaset ; intro). exact (univalent_bicategory_1_cell_hlevel_3 D HD_2_1 _ _ _ _). - intros F F₂ F₂' η ; cbn in *. induction η as [η₁ η₂]. apply funextsec ; intro X. apply funextsec ; intro Y. apply funextsec ; intro Z. apply funextsec ; intro f. apply funextsec ; intro g. specialize (η₁ X Y Z f g). specialize (η₂ X Y Z f g). rewrite !vassocr in η₁. rewrite vcomp_lunitor in η₁. rewrite !vassocl in η₁. rewrite rinvunitor_natural in η₁. rewrite <- rwhisker_hcomp in η₁. rewrite !vassocr in η₁. assert (pr1 (idtoiso_2_1 _ _ (F₂ X Y Z f g)) = pr1 (idtoiso_2_1 _ _ (F₂' X Y Z f g))) as H. { apply rwhisker_id_inj. use (vcomp_lcancel (lunitor _ • rinvunitor _)). { is_iso. } refine (_ @ !η₁). rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. apply maponpaths_2. rewrite !vassocl. apply maponpaths. rewrite <- rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lwhisker_hcomp, rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- !lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. reflexivity. } assert (isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (F₂ X Y Z f g)) = isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (F₂' X Y Z f g))) as H'. { apply maponpaths. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact H. } refine (!_ @ H' @ _). + apply (homotinvweqweq (make_weq (idtoiso_2_1 _ _) (HD_2_1 _ _ _ _))). + apply (homotinvweqweq (make_weq (idtoiso_2_1 _ _) (HD_2_1 _ _ _ _))). Defined. Definition strict_compositor_is_disp_univalent_2 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2 strict_compositor_disp_cat. Proof. split. - apply strict_compositor_is_disp_univalent_2_0; assumption. - exact strict_compositor_is_disp_univalent_2_1. Defined. End StrictCompositor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/StrictIdentitor.v000066400000000000000000000132341451125700300271700ustar00rootroot00000000000000(** The second layer of the construction of the bicategory of strict pseudofunctors consists of three parts. Second part: we add a 2-cell witnessing the strict preservation of the identity. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Local Open Scope cat. Section StrictIdentitor. Variable (C D : bicat). Definition strict_identitor_disp_cat_data : disp_cat_ob_mor (map1cells C D). Proof. use tpair. - exact (λ F, ∏ (X : C), id₁ (Fobj F X) = Fmor F (id₁ X)). - exact (λ F G Fid Gid η, ∏ (X : C), (ηobj η X ◃ idtoiso_2_1 _ _ (Gid X)) • ηmor η (id₁ X) = (runitor (ηobj η X)) • linvunitor (ηobj η X) • (idtoiso_2_1 _ _ (Fid X) ▹ ηobj η X)). Defined. Definition strict_identitor_disp_id_comp : disp_cat_id_comp (map1cells C D) strict_identitor_disp_cat_data. Proof. split. - intros F Fid X ; cbn in *. rewrite !vassocr. rewrite runitor_lunitor_identity. rewrite lunitor_linvunitor, id2_left. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite !vassocr. rewrite lunitor_runitor_identity. rewrite runitor_rinvunitor, id2_left. rewrite rwhisker_hcomp. reflexivity. - intros F G H Fid Gid Hid η ε ηid εid X ; cbn in *. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite lwhisker_vcomp. rewrite εid. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite runitor_triangle. rewrite !vassocl. apply maponpaths. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite rwhisker_lwhisker. rewrite !vassocl. rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)). rewrite rwhisker_vcomp. rewrite ηid. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker, id2_left. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. rewrite linvunitor_assoc. reflexivity. Qed. Definition strict_identitor_disp_cat : disp_bicat (map1cells C D). Proof. use disp_cell_unit_bicat. use tpair. - exact strict_identitor_disp_cat_data. - exact strict_identitor_disp_id_comp. Defined. Definition strict_identitor_is_disp_univalent_2_1 : disp_univalent_2_1 strict_identitor_disp_cat. Proof. apply disp_cell_unit_bicat_univalent_2_1. intros F G η Fid Gid ; simpl in *. apply impred ; intro. apply D. Defined. Definition strict_identitor_is_disp_univalent_2_0 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2_0 strict_identitor_disp_cat. Proof. use disp_cell_unit_bicat_univalent_2_0. - apply map1cells_is_univalent_2_1. exact HD_2_1. - intros ; simpl. apply impred ; intro. apply D. - intros a b f ; cbn. apply impred_isaset ; intro x. exact (univalent_bicategory_1_cell_hlevel_3 D HD_2_1 _ _ _ _). - intros F Fid Fid' η ; cbn in *. apply funextsec ; intro X. induction η as [η₁ η₂]. specialize (η₁ X). specialize (η₂ X). rewrite !vassocr in η₁. rewrite vcomp_lunitor in η₁. rewrite !vassocl in η₁. rewrite rinvunitor_natural in η₁. rewrite <- rwhisker_hcomp in η₁. rewrite lunitor_runitor_identity, lunitor_V_id_is_left_unit_V_id in η₁. rewrite !vassocr in η₁. rewrite !runitor_rinvunitor, !id2_left in η₁. assert (pr1 (idtoiso_2_1 _ _ (Fid X)) = pr1 (idtoiso_2_1 _ _ (Fid' X))) as H. { apply rwhisker_id_inj. exact (!η₁). } assert (isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (Fid X)) = isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (Fid' X))) as H'. { apply maponpaths. apply subtypePath. { intro ; apply isaprop_is_invertible_2cell. } exact H. } refine (!_ @ H' @ _). + apply (homotinvweqweq (make_weq (idtoiso_2_1 (id₁ (Fobj F X)) (Fmor F(id₁ X))) (HD_2_1 _ _ _ _))). + apply (homotinvweqweq (make_weq (idtoiso_2_1 (id₁ (Fobj F X)) (Fmor F(id₁ X))) (HD_2_1 _ _ _ _))). Defined. Definition strict_identitor_is_disp_univalent_2 (HD_2_1 : is_univalent_2_1 D) : disp_univalent_2 strict_identitor_disp_cat. Proof. split. - apply strict_identitor_is_disp_univalent_2_0; assumption. - exact strict_identitor_is_disp_univalent_2_1. Defined. End StrictIdentitor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Display/StrictPseudoFunctorBicat.v000066400000000000000000000176161451125700300310020ustar00rootroot00000000000000(** This is the third and final layer of the construction of the bicategory of strict pseudofunctors. Here we add the laws. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Local Open Scope cat. Section StrictPseudoFunctorData. Variable (C D : bicat). Definition strict_psfunctor_data_disp : disp_bicat (map1cells C D) := disp_dirprod_bicat (map2cells_disp_cat C D) (disp_dirprod_bicat (strict_identitor_disp_cat C D) (strict_compositor_disp_cat C D)). Definition strict_psfunctor_data_bicat : bicat := total_bicat strict_psfunctor_data_disp. Definition strict_psfunctor_data : UU := strict_psfunctor_data_bicat. Definition strict_psfunctor_data_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 strict_psfunctor_data_bicat. Proof. apply is_univalent_2_1_total_dirprod. - apply map1cells_is_univalent_2_1. exact HD_2_1. - apply map2cells_is_disp_univalent_2_1. - apply is_univalent_2_1_dirprod_bicat. + apply strict_identitor_is_disp_univalent_2_1. + apply strict_compositor_is_disp_univalent_2_1. Defined. Definition strict_psfunctor_data_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 strict_psfunctor_data_bicat. Proof. pose (HD_2_1 := pr2 HD). apply is_univalent_2_0_total_dirprod. - apply map1cells_is_univalent_2; assumption. - apply map2cells_is_disp_univalent_2; assumption. - apply is_univalent_2_dirprod_bicat. + apply map1cells_is_univalent_2_1; assumption. + apply strict_identitor_is_disp_univalent_2; assumption. + apply strict_compositor_is_disp_univalent_2; assumption. Defined. Definition strict_psfunctor_data_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 strict_psfunctor_data_bicat. Proof. split. - apply strict_psfunctor_data_is_univalent_2_0; assumption. - apply strict_psfunctor_data_is_univalent_2_1. exact (pr2 HD). Defined. End StrictPseudoFunctorData. Coercion functor_data_from_bifunctor_ob_mor_cell {C D : bicat} (F: strict_psfunctor_data C D) : functor_data C D := pr1 F. Definition strict_psfunctor_on_cells {C D : bicat} (F : strict_psfunctor_data C D) {a b : C} {f g : a --> b} (x : f ==> g) : #F f ==> #F g := pr12 F a b f g x. Local Notation "'##'" := (strict_psfunctor_on_cells). Definition strict_psfunctor_id {C D : bicat} (F : strict_psfunctor_data C D) (a : C) : identity (F a) = #F (identity a) := pr122 F a. Definition strict_psfunctor_comp {C D : bicat} (F : strict_psfunctor_data C D) {a b c : C} (f : a --> b) (g : b --> c) : #F f · #F g = #F (f · g) := pr222 F a b c f g. Definition strict_psfunctor_id_cell {C D : bicat} (F : strict_psfunctor_data C D) (a : C) : invertible_2cell (id₁ (F a)) (# F (id₁ a)) := idtoiso_2_1 _ _ (strict_psfunctor_id F a). Definition strict_psfunctor_comp_cell {C D : bicat} (F : strict_psfunctor_data C D) {a b c : C} (f : a --> b) (g : b --> c) : invertible_2cell (# F f · # F g) (# F (f · g)) := idtoiso_2_1 _ _ (strict_psfunctor_comp F f g). Section FunctorLaws. Context {C D : bicat}. Variable (F : strict_psfunctor_data C D). Definition strict_psfunctor_id2_law : UU := ∏ (a b : C) (f : a --> b), ##F (id2 f) = id2 _. Definition strict_psfunctor_vcomp2_law : UU := ∏ (a b : C) (f g h: C⟦a, b⟧) (η : f ==> g) (φ : g ==> h), ##F (η • φ) = ##F η • ##F φ. Definition strict_psfunctor_lunitor_law : UU := ∏ (a b : C) (f : C⟦a, b⟧), lunitor (#F f) = (strict_psfunctor_id_cell F a ▹ #F f) • strict_psfunctor_comp_cell F (identity a) f • ##F (lunitor f). Definition strict_psfunctor_runitor_law : UU := ∏ (a b : C) (f : C⟦a, b⟧), runitor (#F f) = (#F f ◃ strict_psfunctor_id_cell F b) • strict_psfunctor_comp_cell F f (identity b) • ##F (runitor f). Definition strict_psfunctor_lassociator_law : UU := ∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧), (#F f ◃ strict_psfunctor_comp_cell F g h) • strict_psfunctor_comp_cell F f (g · h) • ##F (lassociator f g h) = (lassociator (#F f) (#F g) (#F h)) • (strict_psfunctor_comp_cell F f g ▹ #F h) • strict_psfunctor_comp_cell F (f · g) h. Definition strict_psfunctor_lwhisker_law : UU := ∏ (a b c : C) (f : C⟦a, b⟧) (g₁ g₂ : C⟦b, c⟧) (η : g₁ ==> g₂), strict_psfunctor_comp_cell F f g₁ • ##F (f ◃ η) = #F f ◃ ##F η • strict_psfunctor_comp_cell F f g₂. Definition strict_psfunctor_rwhisker_law : UU := ∏ (a b c : C) (f₁ f₂ : C⟦a, b⟧) (g : C⟦b, c⟧) (η : f₁ ==> f₂), strict_psfunctor_comp_cell F f₁ g • ##F (η ▹ g) = ##F η ▹ #F g • strict_psfunctor_comp_cell F f₂ g. Definition is_strict_psfunctor : UU := strict_psfunctor_id2_law × strict_psfunctor_vcomp2_law × strict_psfunctor_lunitor_law × strict_psfunctor_runitor_law × strict_psfunctor_lassociator_law × strict_psfunctor_lwhisker_law × strict_psfunctor_rwhisker_law. Definition is_strict_psfunctor_isaprop : isaprop is_strict_psfunctor. Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; apply D. Qed. End FunctorLaws. Section StrictPseudoFunctorBicat. Variable (C D : bicat). Definition strict_psfunctor_bicat : bicat := fullsubbicat (strict_psfunctor_data_bicat C D) is_strict_psfunctor. Definition strict_psfunctor_bicat_is_univalent_2_1 (HD_2_1 : is_univalent_2_1 D) : is_univalent_2_1 strict_psfunctor_bicat. Proof. apply is_univalent_2_1_fullsubbicat. apply strict_psfunctor_data_is_univalent_2_1. exact HD_2_1. Defined. Definition strict_psfunctor_bicat_is_univalent_2_0 (HD : is_univalent_2 D) : is_univalent_2_0 strict_psfunctor_bicat. Proof. apply is_univalent_2_0_fullsubbicat. - apply strict_psfunctor_data_is_univalent_2; assumption. - intro. apply is_strict_psfunctor_isaprop. Defined. Definition strict_psfunctor_bicat_is_univalent_2 (HD : is_univalent_2 D) : is_univalent_2 strict_psfunctor_bicat. Proof. split. - apply strict_psfunctor_bicat_is_univalent_2_0; assumption. - apply strict_psfunctor_bicat_is_univalent_2_1. exact (pr2 HD). Defined. End StrictPseudoFunctorBicat. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/000077500000000000000000000000001451125700300240155ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/ApFunctor.v000066400000000000000000000046321451125700300261120ustar00rootroot00000000000000(** Given a map between two functors, we get a pseudofunctor between their fundamental bigroupoids. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Core.Examples.TwoType. Section ApFunctor. Context {X Y : UU} (HX : isofhlevel 4 X) (HY : isofhlevel 4 Y). Variable (f : X → Y). Definition ap_functor_data : psfunctor_data (fundamental_bigroupoid X HX) (fundamental_bigroupoid Y HY). Proof. use make_psfunctor_data. - exact f. - exact (λ _ _, maponpaths f). - exact (λ _ _ _ _ s, maponpaths (maponpaths f) s). - exact (λ x, idpath (idpath (f x))). - exact (λ _ _ _ p q, !(maponpathscomp0 f p q)). Defined. Definition ap_functor_laws : psfunctor_laws ap_functor_data. Proof. repeat split. - intros x y p₁ p₂ p₃ s₁ s₂ ; cbn in *. exact (maponpathscomp0 (maponpaths f) s₁ s₂). - intros x y p ; cbn in *. induction p ; cbn. reflexivity. - intros x y p ; cbn in *. induction p ; cbn. reflexivity. - intros w x y z p q r ; cbn in *. induction p, q, r ; cbn. reflexivity. - intros x y z p q₁ q₂ s ; cbn in *. induction s ; cbn. exact (pathscomp0rid _). - intros x y z p₁ p₂ q s ; cbn in *. induction s ; cbn. exact (pathscomp0rid _). Qed. Definition ap_psfunctor : psfunctor (fundamental_bigroupoid X HX) (fundamental_bigroupoid Y HY). Proof. use make_psfunctor. - exact ap_functor_data. - exact ap_functor_laws. - split. + intros a. exact (fundamental_groupoid_2cell_iso Y HY (idpath(idpath (f a)))). + intros a b c p q. exact (fundamental_groupoid_2cell_iso Y HY (!(maponpathscomp0 f p q))). Defined. End ApFunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/BicatOfCatToUnivCat.v000066400000000000000000000043211451125700300277400ustar00rootroot00000000000000(*********************************************************************** Inclusion of univalent categories into categories In this file, we define the inclusion pseudofunctor from the bicategory of univalent categories to the bicategory of categories. The relevant definition is [univ_cats_to_cats]. ***********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Local Open Scope cat. Definition univ_cats_to_cats_data : psfunctor_data bicat_of_univ_cats bicat_of_cats. Proof. use make_psfunctor_data. - exact (λ C, pr1 C). - exact (λ _ _ F, F). - exact (λ _ _ _ _ n, n). - exact (λ _, nat_trans_id _). - exact (λ _ _ _ _ _, nat_trans_id _). Defined. Definition univ_cats_to_cats_laws : psfunctor_laws univ_cats_to_cats_data. Proof. repeat split ; intro ; intros ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; cbn ; rewrite ?id_left, ?id_right. - exact (!(functor_id _ _)). - apply idpath. - exact (!(functor_id _ _)). - apply idpath. - apply idpath. Qed. Definition univ_cats_to_cats_invertible_cells : invertible_cells univ_cats_to_cats_data. Proof. split. - exact (λ C, @is_invertible_2cell_id₂ bicat_of_univ_cats C C (functor_identity _)). - exact (λ C₁ C₂ C₃ F G, @is_invertible_2cell_id₂ bicat_of_univ_cats _ _ (F ∙ G)). Defined. Definition univ_cats_to_cats : psfunctor bicat_of_univ_cats bicat_of_cats. Proof. use make_psfunctor. - exact univ_cats_to_cats_data. - exact univ_cats_to_cats_laws. - exact univ_cats_to_cats_invertible_cells. Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/CatDiag.v000066400000000000000000000045541451125700300255100ustar00rootroot00000000000000(******************************************************************************* The diagonal pseudofunctor on univalent categories In this file, we define the diagonal pseudofunctor on the bicategory of univalent categories. It sends every category `C` to `C × C`. *******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Definition diag_univ_cat_data : psfunctor_data bicat_of_univ_cats bicat_of_univ_cats. Proof. use make_psfunctor_data. - exact (λ C, univalent_category_binproduct C C). - exact (λ C D F, pair_functor F F). - exact (λ C₁ C₂ F G τ, pair_nat_trans τ τ). - exact (λ C, nat_trans_id _). - exact (λ C₁ C₂ C₃ F G, nat_trans_id _). Defined. Proposition diag_univ_cat_laws : psfunctor_laws diag_univ_cat_data. Proof. repeat split ; intro ; intros ; (use nat_trans_eq ; [ apply homset_property | ]) ; intro ; use pathsdirprod ; cbn ; try (apply idpath) ; rewrite ?id_left, ?id_right ; try (apply idpath) ; refine (!_) ; apply functor_id. Qed. Definition diag_univ_cat_invertibles : invertible_cells diag_univ_cat_data. Proof. split. - intro C ; cbn. use is_nat_z_iso_to_is_invertible_2cell. exact (pr2 (nat_z_iso_id _)). - intros C₁ C₂ C₃ F G ; cbn. use is_nat_z_iso_to_is_invertible_2cell. exact (pr2 (nat_z_iso_id _)). Defined. Definition diag_univ_cat : psfunctor bicat_of_univ_cats bicat_of_univ_cats. Proof. use make_psfunctor. - exact diag_univ_cat_data. - exact diag_univ_cat_laws. - exact diag_univ_cat_invertibles. Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/ChangeOfBaseEnriched.v000066400000000000000000000072541451125700300301230ustar00rootroot00000000000000(***************************************************************** The change of base pseudofunctor If we have a fully faithful strong monoidal functor between two monoidal categories, then we get a pseudofunctor between the two bicategories of enriched categories over them. Note that for the definition, we use displayed machinery. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.ChangeOfBase. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Section ChangeOfBase. Context {V₁ V₂ : monoidal_cat} (F : strong_monoidal_functor V₁ V₂) (HF : preserve_underlying F). Definition change_of_base_disp_psfunctor_data : disp_psfunctor_data (disp_bicat_of_enriched_cats V₁) (disp_bicat_of_enriched_cats V₂) (id_psfunctor bicat_of_univ_cats). Proof. use make_disp_psfunctor_data. - exact (λ C E, change_of_base_enrichment F HF E). - exact (λ C₁ C₂ G E₁ E₂ EG, change_of_base_functor_enrichment F HF EG). - exact (λ C₁ C₂ G₁ G₂ τ E₁ E₂ EG₁ EG₂ Eτ, change_of_base_nat_trans_enrichment F HF Eτ). - refine (λ C E, _). simple refine (_ ,, _ ,, _ ,, _). + exact (change_of_base_enrichment_identity F HF E). + exact (change_of_base_enrichment_identity_inv F HF E). + apply disp_2cell_isapprop_enriched_cats. + apply disp_2cell_isapprop_enriched_cats. - refine (λ C₁ C₂ C₃ G₁ G₂ E₁ E₂ E₃ EG₁ EG₂, _). simple refine (_ ,, _ ,, _ ,, _). + exact (change_of_base_enrichment_comp F HF EG₁ EG₂). + exact (change_of_base_enrichment_comp_inv F HF EG₁ EG₂). + apply disp_2cell_isapprop_enriched_cats. + apply disp_2cell_isapprop_enriched_cats. Defined. Definition change_of_base_disp_psfunctor_laws : is_disp_psfunctor (disp_bicat_of_enriched_cats V₁) (disp_bicat_of_enriched_cats V₂) (id_psfunctor bicat_of_univ_cats) change_of_base_disp_psfunctor_data. Proof. repeat split ; intro ; intros ; apply disp_2cell_isapprop_enriched_cats. Qed. Definition change_of_base_disp_psfunctor : disp_psfunctor (disp_bicat_of_enriched_cats V₁) (disp_bicat_of_enriched_cats V₂) (id_psfunctor _) := change_of_base_disp_psfunctor_data ,, change_of_base_disp_psfunctor_laws. End ChangeOfBase. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Composition.v000066400000000000000000000110011451125700300265000ustar00rootroot00000000000000(** Composition of lax functors and pseudo functors. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Local Open Scope bicategory_scope. Section FunctorComposition. Context {C D E : bicat}. Variable (G : psfunctor D E) (F : psfunctor C D). Definition comp_psfunctor_data : psfunctor_data C E. Proof. use make_psfunctor_data. - exact (λ X, G(F X)). - exact (λ _ _ f, #G(#F f)). - exact (λ _ _ _ _ α, ##G(##F α)). - exact (λ a, psfunctor_id G (F a) • ##G (psfunctor_id F a)). - exact (λ _ _ _ f g, psfunctor_comp G (#F f) (#F g) • ##G (psfunctor_comp F f g)). Defined. Definition comp_is_ps : psfunctor_laws comp_psfunctor_data. Proof. repeat split. - intros a b f ; cbn in *. rewrite !psfunctor_id2. reflexivity. - intros a b f g h α β ; cbn in *. rewrite !psfunctor_vcomp. reflexivity. - intros a b f ; cbn in *. rewrite !psfunctor_lunitor. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite !psfunctor_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- psfunctor_rwhisker. reflexivity. - intros a b f ; cbn. rewrite !psfunctor_runitor. rewrite <- lwhisker_vcomp. rewrite !psfunctor_vcomp. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- psfunctor_lwhisker. reflexivity. - intros a b c d f g h ; cbn. rewrite <- !lwhisker_vcomp. rewrite !vassocl. rewrite <- psfunctor_vcomp. rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)). rewrite <- psfunctor_lwhisker. rewrite !vassocl. rewrite <- !psfunctor_vcomp. rewrite !vassocr. pose @psfunctor_lassociator as p. cbn in p. rewrite p ; clear p. rewrite !psfunctor_vcomp. rewrite !vassocl. rewrite !vassocr. apply (maponpaths (λ z, z • _)). rewrite psfunctor_lassociator. rewrite !vassocl. apply (maponpaths (λ z, _ • z)). rewrite psfunctor_rwhisker. rewrite <- !rwhisker_vcomp. rewrite !vassocr. reflexivity. - intros a b c f g₁ g₂ α ; cbn. rewrite !vassocl. rewrite <- psfunctor_vcomp. rewrite !psfunctor_lwhisker. rewrite !vassocr. pose (@psfunctor_lwhisker _ _ G) as p. cbn in p ; rewrite <- p ; clear p. rewrite psfunctor_vcomp. rewrite !vassocr. reflexivity. - intros a b c f g₁ g₂ α ; cbn. rewrite !vassocl. rewrite <- psfunctor_vcomp. rewrite !psfunctor_rwhisker. rewrite !vassocr. pose (@psfunctor_rwhisker _ _ G) as p. cbn in p ; rewrite <- p ; clear p. rewrite psfunctor_vcomp. rewrite !vassocr. reflexivity. Qed. Definition comp_psfunctor : psfunctor C E. Proof. use make_psfunctor. - exact comp_psfunctor_data. - exact comp_is_ps. - split. + intros a ; cbn. is_iso. * exact (psfunctor_id G (F a)). * exact (psfunctor_is_iso G (psfunctor_id F a)). + intros a b c f g ; cbn. is_iso. * exact (psfunctor_comp G (#F f) (#F g)). * exact (psfunctor_is_iso G (psfunctor_comp F f g)). Defined. Definition comp_psfunctor_cell {X Y : C} {f g : X --> Y} (α : f ==> g) : ## comp_psfunctor α = ## G (## F α). Proof. apply idpath. Qed. Definition comp_psfunctor_psfunctor_id (X : C) : pr1 (psfunctor_id comp_psfunctor X) = psfunctor_id G (F X) • ##G (psfunctor_id F X). Proof. apply idpath. Qed. Definition comp_psfunctor_psfunctor_comp {X Y Z : C} (f : X --> Y) (g : Y --> Z) : pr1 (psfunctor_comp comp_psfunctor f g) = psfunctor_comp G (#F f) (#F g) • ##G (psfunctor_comp F f g). Proof. apply idpath. Qed. End FunctorComposition. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/CompositionPseudoFunctor.v000066400000000000000000000662361451125700300312450ustar00rootroot00000000000000(************************************************************** Composition We show that the pullback functor has a left biadjoint using universal arrows. The left biadjoint is given on objects by composition. Contents 1. Action on objects 2. The unit 3. Fullness 4. Faithfulness 5. Essentially surjective 6. Universal arrow **************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Import PullbackFunctions.Notations. Local Open Scope cat. Section Composition. Context {B : bicat_with_pb} (HB : is_univalent_2_1 B) {b₁ b₂ : B} (f : b₁ --> b₂). (** 1. Action on objects *) Definition comp_ob : slice_bicat b₁ → slice_bicat b₂ := λ h, make_ob_slice (pr2 h · f). (** 2. The unit *) Definition comp_unit_mor {x : B} (h : x --> b₁) : x --> f /≃ (h · f) := h ⊗[ linvunitor_invertible_2cell (h · f) ] (id₁ x). Definition comp_unit_inv2cell {x : B} (h : x --> b₁) : invertible_2cell h (comp_unit_mor h · pr2 (pb_psfunctor B f (comp_ob (make_ob_slice h)))) := inv_of_invertible_2cell (mor_to_pb_obj_pr1 h (id₁ x) (linvunitor_invertible_2cell (h · f))). Definition comp_unit (h : slice_bicat b₁) : h --> pb_psfunctor B f (comp_ob h). Proof. use make_1cell_slice. - exact (comp_unit_mor (pr2 h)). - exact (comp_unit_inv2cell (pr2 h)). Defined. (** 3. Fullness *) Definition comp_full_cell {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α β : comp_ob h₁ --> h₂) (p : comp_unit h₁ · # (pb_psfunctor B f) α ==> comp_unit h₁ · # (pb_psfunctor B f) β) : pr1 α ==> pr1 β := linvunitor _ • ((mor_to_pb_obj_pr2 _ _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (pb_on_1cell_pr2 f (pr2 α))^-1) • lassociator _ _ _ • (pr1 p ▹ π₂) • rassociator _ _ _ • (_ ◃ pb_on_1cell_pr2 _ _) • lassociator _ _ _ • (mor_to_pb_obj_pr2 _ _ _ ▹ _) • lunitor _. Definition comp_full_homot {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α β : comp_ob h₁ --> h₂) (p : comp_unit h₁ · # (pb_psfunctor B f) α ==> comp_unit h₁ · # (pb_psfunctor B f) β) : cell_slice_homot α β (comp_full_cell α β p). Proof. unfold cell_slice_homot. unfold comp_full_cell. rewrite <- !rwhisker_vcomp. rewrite !vassocr. do 5 (use vcomp_move_R_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]). cbn. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. use (vcomp_rcancel (_ ◃ (pb_cell _ _)^-1)) ; [ is_iso | ]. rewrite !vassocl. rewrite vcomp_whisker. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite <- rwhisker_rwhisker. assert (pr1 p ▹ π₁ = rassociator _ _ _ • (_ ◃ pb_on_1cell_pr1 f (pr2 α)) • (_ ◃ (pb_on_1cell_pr1 f (pr2 β))^-1) • lassociator _ _ _) as H. { pose (pr2 p) as d. cbn in d. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ]. cbn. use (vcomp_lcancel ((mor_to_pb_obj_pr1 _ _ _) ^-1)) ; [ is_iso | ]. rewrite !vassocl in d. exact d. } etrans. { do 10 apply maponpaths. exact H. } clear H. refine (!_). etrans. { do 5 apply maponpaths. rewrite !vassocr. etrans. { do 2 apply maponpaths_2. rewrite rwhisker_hcomp. rewrite inverse_pentagon_2. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. rewrite <- lassociator_lassociator. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. do 3 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn. rewrite !vassocl. refine (!_). etrans. { do 15 apply maponpaths. exact (pb_on_1cell_cell f (pr2 β)). } rewrite !vassocr. use vcomp_move_R_Mp. { is_iso ; apply property_from_invertible_2cell. } cbn. rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. etrans. { do 8 apply maponpaths. rewrite !vassocr. apply maponpaths_2. rewrite rwhisker_hcomp. rewrite !vassocl. rewrite <- inverse_pentagon_4. rewrite <- lwhisker_hcomp. apply idpath. } etrans. { do 5 apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. do 3 apply maponpaths_2. rewrite !vassocl. rewrite <- rassociator_rassociator. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lassociator_rassociator. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. refine (!_). etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { do 3 apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. rewrite !vassocl. refine (!_). etrans. { do 10 apply maponpaths. apply mor_to_pb_obj_cell. } rewrite !vassocl. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. do 7 (use vcomp_move_R_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]). cbn. rewrite !vassocl. refine (!_). etrans. { do 12 apply maponpaths. apply pb_on_1cell_cell. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 9 apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. rewrite vassocl. apply idpath. } rewrite <- lunitor_triangle. etrans. { do 4 apply maponpaths. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ]. cbn. refine (!_). etrans. { rewrite !vassocl. do 3 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. apply idpath. } use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- !vcomp_lunitor. rewrite <- !lunitor_triangle. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lunitor_linvunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite <- lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lunitor_linvunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. etrans. { do 5 apply maponpaths. apply mor_to_pb_obj_cell. } rewrite !vassocl. etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. cbn. apply idpath. } rewrite linvunitor_assoc. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite lunitor_linvunitor. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_left. } rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. Qed. Definition comp_full {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α β : comp_ob h₁ --> h₂) (p : comp_unit h₁ · # (pb_psfunctor B f) α ==> comp_unit h₁ · # (pb_psfunctor B f) β) : α ==> β. Proof. use make_2cell_slice. - exact (comp_full_cell α β p). - exact (comp_full_homot α β p). Defined. Definition comp_full_eq {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α β : comp_ob h₁ --> h₂) (p : comp_unit h₁ · # (pb_psfunctor B f) α ==> comp_unit h₁ · # (pb_psfunctor B f) β) : comp_unit h₁ ◃ ## (pb_psfunctor B f) (comp_full α β p) = p. Proof. use eq_2cell_slice. use eq_to_pb_obj. - unfold cell_to_pb_obj_homot ; cbn. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. rewrite lassociator_rassociator. apply id2_right. } rewrite <- vcomp_whisker. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. - cbn. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- rwhisker_lwhisker. etrans. { apply maponpaths_2. apply maponpaths. apply pb_on_2cell_pr1. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ]. cbn. use (vcomp_lcancel (mor_to_pb_obj_pr1 (pr2 h₁) (id₁ _) (linvunitor_invertible_2cell _)^-1)). { is_iso. } rewrite !vassocr. refine (!_). pose (pr2 p) as p'. cbn in p'. rewrite !vassocr in p'. exact p'. - cbn. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- rwhisker_lwhisker. etrans. { apply maponpaths_2. apply maponpaths. apply pb_on_2cell_pr2. } rewrite <- !lwhisker_vcomp. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ]. cbn. rewrite !vassocl. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ]. use (vcomp_lcancel ((mor_to_pb_obj_pr2 _ _ _)^-1 ▹ _)) ; [ is_iso | ]. use (vcomp_rcancel (mor_to_pb_obj_pr2 _ _ _ ▹ _)). { is_iso. apply property_from_invertible_2cell. } use (vcomp_lcancel (linvunitor _)) ; [ is_iso | ]. use (vcomp_rcancel (lunitor _)) ; [ is_iso | ]. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } rewrite vcomp_lunitor. etrans. { rewrite !vassocr. rewrite linvunitor_lunitor. apply id2_left. } rewrite !vassocr. apply idpath. Qed. (** 4. Faithfulness *) Definition comp_faithful {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} {α β : comp_ob h₁ --> h₂} (p : comp_unit h₁ · # (pb_psfunctor B f) α ==> comp_unit h₁ · # (pb_psfunctor B f) β) (q₁ q₂ : α ==> β) (r₁ : comp_unit h₁ ◃ ## (pb_psfunctor B f) q₁ = p) (r₂ : comp_unit h₁ ◃ ## (pb_psfunctor B f) q₂ = p) : q₁ = q₂. Proof. use eq_2cell_slice. assert (comp_unit_mor (pr2 h₁) ◃ (π₂ ◃ pr1 q₁) = comp_unit_mor (pr2 h₁) ◃ (π₂ ◃ pr1 q₂)) as H₁. { pose (H := maponpaths (λ z, lassociator _ _ _ • (z ▹ π₂)) (maponpaths pr1 r₁ @ !(maponpaths pr1 r₂))). cbn in H. rewrite <- !rwhisker_lwhisker in H. rewrite !pb_on_2cell_pr2 in H. rewrite <- !lwhisker_vcomp in H. rewrite !vassocl in H. use (vcomp_lcancel (comp_unit_mor (pr2 h₁) ◃ pb_on_1cell_pr2 f (pr2 α))). { is_iso. apply property_from_invertible_2cell. } use (vcomp_rcancel (comp_unit_mor (pr2 h₁) ◃ (pb_on_1cell_pr2 f (pr2 β)) ^-1)). { is_iso. } use (vcomp_rcancel (lassociator _ _ _)). { is_iso. } rewrite !vassocl. exact H. } pose (maponpaths (λ z, rassociator _ _ _ • z • lassociator _ _ _) H₁) as H₂. cbn in H₂. rewrite !vassocl in H₂. rewrite !lwhisker_lwhisker in H₂. rewrite !vassocr in H₂. rewrite !rassociator_lassociator in H₂. rewrite !id2_left in H₂. unfold comp_unit_mor in H₂. pose (maponpaths (λ z, z • (mor_to_pb_obj_pr2 _ _ _ ▹ _)) H₂) as H₃. cbn in H₃. rewrite <- !vcomp_whisker in H₃. use (vcomp_lcancel (lunitor _)) ; [ is_iso | ]. rewrite <- !vcomp_lunitor. apply maponpaths_2. use (vcomp_lcancel (mor_to_pb_obj_pr2 _ _ (linvunitor_invertible_2cell (pr2 h₁ · f)) ▹ _)). { is_iso. apply property_from_invertible_2cell. } exact H₃. Qed. (** 5. Essentially surjective *) Definition comp_essentially_surj_mor {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : pr1 h₁ --> pr1 h₂ := pr1 α · π₂. Definition comp_essentially_surj_mor_inv2cell {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : invertible_2cell (pr2 h₁ · f) (comp_essentially_surj_mor α · pr2 h₂) := comp_of_invertible_2cell (rwhisker_of_invertible_2cell _ (pr2 α)) (comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (pb_cell _ _)) (lassociator_invertible_2cell _ _ _))). Definition comp_essentially_surj {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : comp_ob h₁ --> h₂. Proof. use make_1cell_slice. - exact (comp_essentially_surj_mor α). - exact (comp_essentially_surj_mor_inv2cell α). Defined. Section EssentiallySurjective. Context {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂). Local Arguments lassociator {_ _ _ _ _ _ _ _}. Local Arguments rassociator {_ _ _ _ _ _ _ _}. Definition comp_essentially_surj_cell_pr1 : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α) · π₁ ==> pr1 α · π₁ := rassociator • (_ ◃ pb_on_1cell_pr1 _ _) • mor_to_pb_obj_pr1 _ _ _ • pr12 α. Definition comp_essentially_surj_cell_pr2 : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α) · π₂ ==> pr1 α · π₂ := rassociator • (_ ◃ pb_on_1cell_pr2 _ _) • lassociator • (mor_to_pb_obj_pr2 _ _ _ ▹ _) • lunitor _. Definition comp_essentially_surj_cell_eq : (_ ◃ pb_cone_cell _) • lassociator • (comp_essentially_surj_cell_pr2 ▹ _) • rassociator = lassociator • (comp_essentially_surj_cell_pr1 ▹ _) • rassociator • (pr1 α ◃ pb_cone_cell _). Proof. use (vcomp_lcancel lassociator) ; [ is_iso | ]. etrans. { rewrite !vassocr. rewrite <- lwhisker_lwhisker. rewrite !vassocl. apply maponpaths_2. apply maponpaths. apply pb_on_1cell_cell. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. apply maponpaths_2. unfold comp_unit_mor. apply mor_to_pb_obj_cell. } cbn. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. apply maponpaths. etrans. { do 9 apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- lassociator_lassociator. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rassociator_lassociator. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { do 11 apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. unfold comp_essentially_surj_cell_pr2 . rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } rewrite <- !rwhisker_vcomp. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } etrans. { do 10 apply maponpaths. rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker. rewrite !vassocl. apply idpath. } etrans. { do 5 apply maponpaths. rewrite !vassocr. do 4 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite !lwhisker_vcomp. rewrite lwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocl. rewrite rassociator_lassociator. apply id2_right. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_lunitor. apply idpath. } etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite linvunitor_lunitor. rewrite id2_left. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite rwhisker_lwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite lassociator_rassociator. rewrite id2_right. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !rwhisker_vcomp. apply maponpaths. rewrite !vassocl. unfold comp_essentially_surj_cell_pr1. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Definition comp_essentially_surj_cell : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α) ==> pr1 α. Proof. use pb_ump_cell. - apply (pr2 B b₁ (pr1 h₂) b₂ f (pr2 h₂)). - exact comp_essentially_surj_cell_pr1. - exact comp_essentially_surj_cell_pr2. - exact comp_essentially_surj_cell_eq. Defined. End EssentiallySurjective. Definition comp_essentially_surj_cell_homot {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : cell_slice_homot (comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α)) α (comp_essentially_surj_cell α). Proof. unfold cell_slice_homot. cbn. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply pb_ump_cell_pr1. } unfold comp_essentially_surj_cell_pr1. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite vcomp_linv. apply id2_left. Qed. Definition comp_essentially_surj_cell_slice {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α) ==> α. Proof. use make_2cell_slice. - exact (comp_essentially_surj_cell α). - exact (comp_essentially_surj_cell_homot α). Defined. Definition comp_essentially_surj_is_inv2cell {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : is_invertible_2cell (comp_essentially_surj_cell_slice α). Proof. use is_invertible_2cell_in_slice_bicat. cbn. use is_invertible_2cell_pb_ump_cell. - unfold comp_essentially_surj_cell_pr1. is_iso. + apply property_from_invertible_2cell. + apply property_from_invertible_2cell. + apply property_from_invertible_2cell. - unfold comp_essentially_surj_cell_pr2. is_iso. + apply property_from_invertible_2cell. + apply property_from_invertible_2cell. Defined. Definition comp_essentially_surj_inv2cell {h₁ : slice_bicat b₁} {h₂ : slice_bicat b₂} (α : h₁ --> pb_psfunctor B f h₂) : invertible_2cell (comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α)) α. Proof. use make_invertible_2cell. - exact (comp_essentially_surj_cell_slice α). - exact (comp_essentially_surj_is_inv2cell α). Defined. (** 6. Universal arrow *) Definition pb_left_universal_arrow : left_universal_arrow (pb_psfunctor B f). Proof. use make_left_universal_arrow'. - use is_univalent_2_1_slice_bicat. exact HB. - exact comp_ob. - exact comp_unit. - exact (λ h₁ h₂ α β p, comp_full _ _ p ,, comp_full_eq _ _ p). - exact @comp_faithful. - exact (λ h₁ h₂ α, comp_essentially_surj α ,, comp_essentially_surj_inv2cell α). Defined. End Composition. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/ConstProduct.v000066400000000000000000000371571451125700300266500ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Limits.Products. Import Products.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Section ConstProdPsfunctor. Context (B : bicat_with_binprod) (x : B). Definition const_prod_psfunctor_data : psfunctor_data B B. Proof. use make_psfunctor_data. - exact (λ y, y ⊗ x). - exact (λ y₁ y₂ f, f ⊗₁ id₁ x). - exact (λ y₁ y₂ f g α, α ⊗₂ id₂ _). - exact (λ y, (pair_1cell_id_id_invertible B _ _)^-1). - exact (λ y₁ y₂ y₃ f g, pair_1cell_comp_invertible B f g (id₁ x) (id₁ x) • (id₂ _ ⊗₂ lunitor _)). Defined. Definition const_prod_psfunctor_laws : psfunctor_laws const_prod_psfunctor_data. Proof. repeat split. - intro ; intros ; cbn. apply pair_2cell_id_id. - intro ; intros ; cbn. refine (_ @ pair_2cell_comp _ _ _ _ _). rewrite id2_left. apply idpath. - intro ; intros ; cbn. refine (binprod_lunitor _ _ _ @ _). rewrite !vassocl. do 2 apply maponpaths. rewrite <- pair_2cell_comp. rewrite id2_left, id2_right. apply idpath. - intro ; intros ; cbn. refine (binprod_runitor _ _ _ @ _). rewrite !vassocl. do 2 apply maponpaths. rewrite <- pair_2cell_comp. rewrite id2_left, id2_right. rewrite runitor_lunitor_identity. apply idpath. - intro ; intros ; cbn. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. rewrite !vassocl. use binprod_ump_2cell_unique_alt. + apply (pr2 B). + rewrite <- !rwhisker_vcomp. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply pair_2cell_pr1. } rewrite !vassocl. rewrite lwhisker_id2. rewrite id2_left. apply maponpaths. apply maponpaths. etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } apply maponpaths. etrans. { apply maponpaths_2. apply pair_2cell_pr1. } rewrite lwhisker_id2, id2_right. apply maponpaths. apply pair_2cell_pr1. } etrans. { rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. do 6 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. unfold pair_1cell_pr1. rewrite vcomp_linv, id2_right. rewrite vcomp_linv, id2_right. do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite <- lwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite !vassocr. rewrite lassociator_lassociator. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. apply maponpaths. apply pair_2cell_pr1. } rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_id2, id2_right. rewrite !vassocl. etrans. { do 4 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } unfold pair_1cell_pr1. rewrite !vassocl. rewrite vcomp_linv, id2_right. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply pair_2cell_pr1. } rewrite lwhisker_id2, id2_right. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. etrans. { do 9 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_rwhisker_alt. rewrite !vassocr. apply maponpaths_2. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite <- lassociator_lassociator. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite rassociator_lassociator. rewrite id2_right. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite <- !lwhisker_vcomp. apply maponpaths_2. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite rassociator_rassociator. apply idpath. } etrans. { do 4 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocr. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. apply id2_left. } apply lassociator_rassociator. + rewrite <- !rwhisker_vcomp. etrans. { do 4 apply maponpaths. apply pair_2cell_pr2. } refine (!_). etrans. { do 4 apply maponpaths. apply pair_2cell_pr2. } rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_id2. rewrite id2_right. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. refine (!_). etrans. { do 3 apply maponpaths. apply maponpaths_2. apply pair_2cell_pr2. } rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { do 2 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } etrans. { rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. apply maponpaths_2. apply maponpaths. apply pair_2cell_pr2. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). rewrite <- lwhisker_vcomp. etrans. { rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. rewrite <- lwhisker_vcomp. etrans. { rewrite !vassocr. rewrite lwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite <- lassociator_lassociator. rewrite !vassocl. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. apply idpath. } use vcomp_move_R_pM ; [ is_iso | ] ; cbn. refine (!_). etrans. { rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. etrans. { rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite rassociator_rassociator. rewrite !vassocl. apply idpath. } unfold pair_1cell_pr2. rewrite !vcomp_linv, id2_right. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. rewrite id2_right. refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_vcomp. rewrite vcomp_linv. rewrite id2_rwhisker. apply id2_left. } refine (!_). etrans. { do 3 apply maponpaths. apply maponpaths_2. apply maponpaths. apply pair_2cell_pr2. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite !lwhisker_vcomp. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite rassociator_lassociator. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite <- rwhisker_rwhisker_alt. rewrite !vassocl. apply maponpaths. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. apply maponpaths. rewrite lunitor_runitor_identity. rewrite runitor_triangle. apply idpath. - intro ; intros ; cbn. rewrite !vassocl. rewrite <- pair_2cell_comp. rewrite id2_left, id2_right. rewrite !vassocr. rewrite <- binprod_lwhisker. rewrite !vassocl. apply maponpaths. rewrite <- pair_2cell_comp. rewrite lwhisker_id2, id2_left, id2_right. apply idpath. - intro ; intros ; cbn. rewrite !vassocl. rewrite <- pair_2cell_comp. rewrite id2_left, id2_right. rewrite !vassocr. rewrite <- binprod_rwhisker. rewrite !vassocl. apply maponpaths. rewrite <- pair_2cell_comp. rewrite id2_rwhisker, id2_left, id2_right. apply idpath. Qed. Definition const_prod_psfunctor_invertible_cells : invertible_cells const_prod_psfunctor_data. Proof. split. - intro y. apply is_invertible_2cell_inv. - intros y₁ y₂ y₃ f g ; cbn. is_iso. + apply binprod_ump_2cell_invertible. * is_iso. ** apply property_from_invertible_2cell. ** apply property_from_invertible_2cell. * is_iso. ** apply property_from_invertible_2cell. ** apply property_from_invertible_2cell. + apply binprod_ump_2cell_invertible. * is_iso. apply property_from_invertible_2cell. * is_iso. apply property_from_invertible_2cell. Defined. Definition const_prod_psfunctor : psfunctor B B. Proof. use make_psfunctor. - exact const_prod_psfunctor_data. - exact const_prod_psfunctor_laws. - exact const_prod_psfunctor_invertible_cells. Defined. End ConstProdPsfunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Constant.v000066400000000000000000000047121451125700300260010ustar00rootroot00000000000000(** Constant pseudofunctor *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.Notations. Local Open Scope cat. Section Constant. Context (B₁ : bicat) {B₂ : bicat} (Y : B₂). Definition constant_data : psfunctor_data B₁ B₂. Proof. use make_psfunctor_data. - exact (λ _, Y). - exact (λ _ _ _, id₁ Y). - exact (λ _ _ _ _ _, id₂ (id₁ Y)). - exact (λ _, id₂ (id₁ Y)). - exact (λ _ _ _ _ _, lunitor (id₁ Y)). Defined. Definition constant_laws : psfunctor_laws constant_data. Proof. repeat split. - intros a b f g h α β ; cbn. rewrite id2_left. apply idpath. - intros a b f ; cbn. rewrite id2_rwhisker, id2_left, id2_right. apply idpath. - intros a b f ; cbn. rewrite lwhisker_id2, id2_left, id2_right, runitor_lunitor_identity. apply idpath. - intros a b c d f g h ; cbn. rewrite id2_right. rewrite lunitor_triangle. rewrite lunitor_is_lunitor_lwhisker. apply idpath. - intros a b c f g h α ; cbn. rewrite lwhisker_id2, id2_left, id2_right. apply idpath. - intros a b c f g h α ; cbn. rewrite id2_rwhisker, id2_left, id2_right. apply idpath. Qed. Definition constant_invertible_cells : invertible_cells constant_data. Proof. split. - intro a ; cbn. is_iso. - intros a b c f g ; cbn. is_iso. Defined. Definition constant : psfunctor B₁ B₂. Proof. use make_psfunctor. - exact constant_data. - exact constant_laws. - exact constant_invertible_cells. Defined. End Constant. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/CorestrictImage.v000066400000000000000000000143611451125700300272750ustar00rootroot00000000000000(** Restrict pseudofunctor to its full image. We also give conditions when it gives rise to a weak equivalence. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Examples.Image. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Section CorestrictImage. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂). Definition corestrict_full_image_data : psfunctor_data B₁ (full_image F). Proof. use make_psfunctor_data. - exact (λ x, F x ,, hinhpr (x ,, idpath (F x))). - exact (λ _ _ f, #F f ,, tt). - exact (λ _ _ _ _ α, ##F α ,, tt). - exact (λ x, pr1 (psfunctor_id F x) ,, tt). - exact (λ _ _ _ f g, pr1 (psfunctor_comp F f g) ,, tt). Defined. Definition corestrict_full_image_laws : psfunctor_laws corestrict_full_image_data. Proof. repeat split ; intro ; intros ; (use subtypePath ; [ intro ; apply isapropunit | apply F ]). Qed. Definition corestrict_full_image_invertibles : invertible_cells corestrict_full_image_data. Proof. split ; intro ; intros ; apply bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell ; apply F. Defined. Definition corestrict_full_image : psfunctor B₁ (full_image F). Proof. use make_psfunctor. - exact corestrict_full_image_data. - exact corestrict_full_image_laws. - exact corestrict_full_image_invertibles. Defined. Definition corestrict_full_image_essentially_surjective : essentially_surjective corestrict_full_image. Proof. intros x. induction x as [x₁ x₂]. simpl in x₂. revert x₂. use squash_rec. intro x. simpl. apply hinhpr. refine (pr1 x ,, _). apply bicat_adjoint_equivalence_is_fullsub_adjoint_equivalence. exact (idtoiso_2_0 _ _ (pr2 x)). Defined. Section CorestrictFullImageLocalEquivalence. Variable (B₁_is_univalent_2_1 : is_univalent_2_1 B₁) (B₂_is_univalent_2_1 : is_univalent_2_1 B₂) (FI_is_univalent_2_1 : is_univalent_2_1 (full_image F)) (F_local_equiv : local_equivalence B₁_is_univalent_2_1 B₂_is_univalent_2_1 F). Definition corestrict_full_image_local_equivalence_right_adj (x y : B₁) : bicat_of_univ_cats ⟦ univ_hom FI_is_univalent_2_1 (corestrict_full_image x) (corestrict_full_image y), univ_hom B₁_is_univalent_2_1 x y ⟧. Proof. pose (G := F_local_equiv x y). use make_functor. - use make_functor_data. + exact (λ z, pr1 (left_adjoint_right_adjoint G) (pr1 z)). + exact (λ _ _ f, # (pr1 (left_adjoint_right_adjoint G)) (pr1 f)). - split. + abstract (intro a ; exact (functor_id (left_adjoint_right_adjoint G) (pr1 a))). + abstract (intros ? ? ? f g ; exact (functor_comp (left_adjoint_right_adjoint G) (pr1 f) (pr1 g))). Defined. Definition corestrict_full_image_local_equivalence : local_equivalence B₁_is_univalent_2_1 FI_is_univalent_2_1 corestrict_full_image. Proof. intros x y. use equiv_to_isadjequiv. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (corestrict_full_image_local_equivalence_right_adj x y). - use make_nat_trans. + exact (λ z, pr1 (left_adjoint_unit (F_local_equiv x y)) z). + abstract (intros a b g ; exact (pr2 (left_adjoint_unit (F_local_equiv x y)) _ _ g)). - use make_nat_trans. + exact (λ z, pr1 (left_adjoint_counit (F_local_equiv x y)) (pr1 z) ,, tt). + abstract (intros a b g ; use subtypePath ; [ intro ; apply isapropunit | ] ; exact (pr2 (left_adjoint_counit (F_local_equiv x y)) _ _ (pr1 g))). - apply is_nat_z_iso_to_is_invertible_2cell. intro z. exact (is_invertible_2cell_to_is_nat_z_iso _ (left_equivalence_unit_iso (F_local_equiv x y)) z). - apply is_nat_z_iso_to_is_invertible_2cell. intro z. apply is_inv2cell_to_is_z_iso. apply bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell. apply (z_iso_to_inv2cell (_ ,, is_invertible_2cell_to_is_nat_z_iso _ (left_equivalence_counit_iso (F_local_equiv x y)) (pr1 z))). Defined. End CorestrictFullImageLocalEquivalence. Definition corestrict_full_image_weak_equivalence (B₁_is_univalent_2_1 : is_univalent_2_1 B₁) (B₂_is_univalent_2_1 : is_univalent_2_1 B₂) (FI_is_univalent_2_1 : is_univalent_2_1 (full_image F)) (F_local_equiv : local_equivalence B₁_is_univalent_2_1 B₂_is_univalent_2_1 F) : weak_equivalence B₁_is_univalent_2_1 FI_is_univalent_2_1 corestrict_full_image. Proof. split. - exact (corestrict_full_image_local_equivalence _ _ _ F_local_equiv). - apply corestrict_full_image_essentially_surjective. Defined. End CorestrictImage. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/CurryingInBicatOfCats.v000066400000000000000000000363371451125700300303540ustar00rootroot00000000000000(** exploring the isomorphism between [A × B --> C] and [[B, [A,C]]] for categories A, B, C Authors: Ralph Matthes 2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.Modifications.Modification. Import Bicat.Notations. Local Open Scope cat. Local Definition CAT : bicat := bicat_of_cats. Section ThePseudoFunctors. Section ProductWithFixedSecondArgument. Context (B0 : ob CAT). Local Definition productwithfixedelement (A: ob CAT) : ob CAT := category_binproduct A B0. Definition binproductleft_map_data: psfunctor_data CAT CAT. Proof. use make_psfunctor_data. - exact productwithfixedelement. - intros A A' F. exact (pair_functor F (functor_identity (pr1 B0))). - intros A A' F G α. cbn. use make_nat_trans. + intro ab. induction ab as [a b]. cbn. exact (pr1 α a ,, identity b). + intros ab ab' fg. induction ab as [a b]. induction ab' as [a' b']. induction fg as [f g]. cbn. apply pathsdirprod. * apply nat_trans_ax. * rewrite id_left. apply id_right. - intro A. cbn. use make_nat_trans. + intro ab. exact (identity ab). + intros ab ab' fg. cbn. apply pathsdirprod; rewrite id_left; apply id_right. - intros A1 A2 A3 F G. cbn. use make_nat_trans. + intro a1b. apply identity. + intros a1b a1b' fg. cbn. apply pathsdirprod; rewrite id_left; apply id_right. Defined. Definition binproductleft_map_laws: psfunctor_laws binproductleft_map_data. Proof. repeat split; red; cbn. - intros A A' F. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro ab. cbn. apply idpath. - intros A A' F1 F2 F3 α β. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro ab. cbn. apply pathsdirprod. * apply idpath. * apply pathsinv0, id_left. - intros A B F. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro ab. cbn. apply pathsdirprod. * do 2 rewrite id_right. apply pathsinv0, functor_id. * do 2 rewrite id_right. apply idpath. - intros A B F. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro ab. cbn. apply pathsdirprod; do 2 rewrite id_right; apply idpath. - intros A1 A2 A3 A4 F G H. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro a1b. cbn. apply pathsdirprod. * do 3 rewrite id_left. rewrite id_right. apply pathsinv0, functor_id. * apply idpath. - intros A1 A2 A3 F G1 G2 β. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro a1b. cbn. apply pathsdirprod. * rewrite id_left, id_right. apply idpath. * apply idpath. - intros A1 A2 A3 F1 F2 G α. apply (nat_trans_eq (homset_property (productwithfixedelement _))). intro a1b. cbn. apply pathsdirprod. * rewrite id_left, id_right. apply idpath. * apply idpath. Defined. Definition binproductleft_psfunctor: psfunctor CAT CAT. Proof. use make_psfunctor. - exact binproductleft_map_data. - exact binproductleft_map_laws. - split; red; cbn. + intro A. use tpair. * use make_nat_trans. -- intro ab. apply identity. -- intros ab ab' fg. cbn. apply pathsdirprod; rewrite id_left; apply id_right. * split; apply (nat_trans_eq (homset_property (productwithfixedelement _))); intro ab; cbn; apply pathsdirprod; apply id_left. + intros A1 A2 A3 F G. use tpair. * use make_nat_trans. -- intro a1b. apply identity. -- intros a1b a1b' fg. cbn. apply pathsdirprod; rewrite id_left; apply id_right. * split; apply (nat_trans_eq (homset_property (productwithfixedelement _))); intro a1b; cbn; apply pathsdirprod; apply id_left. Defined. End ProductWithFixedSecondArgument. Section FunctorCategoryWithFixedSource. Context (A0 : ob CAT). Definition functorcategoryright_map_data: psfunctor_data CAT CAT. Proof. use make_psfunctor_data. - exact (fun B => functor_category (pr1 A0) B). - intros B B' F. cbn. exact (post_composition_functor A0 B B' F). - intros B1 B2 F F' β. use make_nat_trans. + intro G. cbn. exact (pre_whisker (pr1 G) β). + intros G G' α. cbn. etrans. 2: { apply horcomp_pre_post. } apply pathsinv0. apply horcomp_post_pre. - intro B. use make_nat_trans. + intro G. cbn. apply ρ_functors_inv. + intros G G' α. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_left; apply id_right. - intros B1 B2 B3 H F. cbn. use make_nat_trans. + intro G. cbn. apply α_functors. + intros G G' α. cbn. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_left; apply id_right. Defined. Definition functorcategoryright_map_laws: psfunctor_laws functorcategoryright_map_data. Proof. repeat split; red; cbn. - intros B B' F. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. apply idpath. - intros B B' F1 F2 F3 β1 β2. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. apply idpath. - intros B B' F. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. cbn. do 2 rewrite id_right; apply pathsinv0, functor_id. - intros B B' F. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. cbn. do 2 rewrite id_right; apply idpath. - intros B1 B2 B3 B4 F1 F2 F3. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. cbn. do 3 rewrite id_left. rewrite id_right. apply pathsinv0, functor_id. - intros B C D F H1 H2 γ. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_right; apply id_left. - intros B C D F1 F2 H β. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_right; apply id_left. Defined. Definition functorcategoryright_psfunctor: psfunctor CAT CAT. Proof. use make_psfunctor. - exact functorcategoryright_map_data. - exact functorcategoryright_map_laws. - split; red; cbn. + intro B. use tpair. * use make_nat_trans. -- intro G. cbn. apply ρ_functors. -- intros G G' α. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_left; apply id_right. * split; apply (nat_trans_eq (homset_property (functor_category _ _))); intro G; cbn; apply (nat_trans_eq (homset_property _)); intro a; apply id_left. + intros B1 B2 B3 F H. use tpair. * use make_nat_trans. -- intro G. cbn. apply α_functors_inv. -- intros G G' α. apply (nat_trans_eq (homset_property _)). intro a. cbn. rewrite id_left; apply id_right. * split; apply (nat_trans_eq (homset_property (functor_category _ _))); intro G; cbn; apply (nat_trans_eq (homset_property _)); intro a; apply id_left. Defined. End FunctorCategoryWithFixedSource. End ThePseudoFunctors. Section Currying. Context (B0 : ob CAT). Let L := binproductleft_psfunctor B0. Let R := functorcategoryright_psfunctor B0. (* to observe the type of the goal: match goal with | |- ?f => set (goal := f) end. *) Definition coevaluation_pstrans_data: pstrans_data (id_psfunctor CAT) (comp_psfunctor R L). Proof. use make_pstrans_data. + intro A. apply coevaluation_functor. + intros A A' F. apply nat_z_iso_to_invertible_2cell. use make_nat_z_iso. * use make_nat_trans. -- intro a. cbn in a. cbn. ++ use make_nat_trans. ** intro b. apply identity. ** intros b b' f. cbn. apply pathsdirprod. --- do 2 rewrite id_right. apply functor_id. --- rewrite id_left. apply id_right. -- intros a a' g. cbn. apply (nat_trans_eq (homset_property (productwithfixedelement _ _))). cbn. intro b. apply pathsdirprod. ++ rewrite id_left. apply id_right. ++ apply idpath. * intro a. apply nat_trafo_z_iso_if_pointwise_z_iso. intro b. cbn. cbn in F, a. set (aux := identity(C:=pr1(productwithfixedelement _ _)) (make_dirprod (F a) b)). change (is_z_isomorphism aux). apply identity_is_z_iso. Defined. Lemma coevaluation_is_pstrans: is_pstrans coevaluation_pstrans_data. Proof. repeat split. - intros A A' F F' α. apply (nat_trans_eq (homset_property (functor_category _ _))). intro a. apply (nat_trans_eq (homset_property (productwithfixedelement _ _))). intro b. cbn. apply pathsdirprod. + rewrite id_left. apply id_right. + apply idpath. - intro A. apply (nat_trans_eq (homset_property (functor_category _ _))). intro a. apply (nat_trans_eq (homset_property (productwithfixedelement _ _))). intro b. cbn. apply idpath. - intros A1 A2 A3 F G. apply (nat_trans_eq (homset_property (functor_category _ _))). intro a. apply (nat_trans_eq (homset_property (productwithfixedelement _ _))). intro b. cbn. apply pathsdirprod. + do 6 rewrite id_right. rewrite id_left. apply pathsinv0, functor_id. + etrans. 2: { do 3 rewrite id_right. apply idpath. } apply idpath. Qed. Definition coevaluation_pstrans: pstrans (id_psfunctor CAT) (comp_psfunctor R L). Proof. use make_pstrans. - exact coevaluation_pstrans_data. - exact coevaluation_is_pstrans. Defined. Definition evaluation_pstrans_data: pstrans_data (comp_psfunctor L R) (id_psfunctor CAT). Proof. use make_pstrans_data. - intro A. apply evaluation_functor. - intros A A' F. apply nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + use make_nat_trans. * intro Gb. apply identity. * intros Gb Gb' βg. induction Gb as [G b]. induction Gb' as [G' b']. induction βg as [β g]. simpl in *. rewrite id_left, id_right. apply functor_comp. + intro a. cbn. apply identity_is_z_iso. Defined. Lemma evaluation_is_pstrans: is_pstrans evaluation_pstrans_data. Proof. repeat split. - intros A A' F F' α. apply (nat_trans_eq (homset_property _)). intro Gb. induction Gb as [G b]. cbn. do 2 rewrite functor_id. do 2 rewrite id_left. apply id_right. - intro A. apply (nat_trans_eq (homset_property _)). intro Gb. induction Gb as [G b]. cbn. do 5 rewrite id_left. rewrite id_right. apply pathsinv0, functor_id. - intros A1 A2 A3 F H. apply (nat_trans_eq (homset_property _)). intro Gb. induction Gb as [G b]. cbn. do 7 rewrite id_right. do 3 rewrite functor_id. rewrite id_left, id_right. apply pathsinv0, functor_id. Qed. Definition evaluation_pstrans: pstrans (comp_psfunctor L R) (id_psfunctor CAT). Proof. use make_pstrans. - exact evaluation_pstrans_data. - exact evaluation_is_pstrans. Defined. Definition currying_biajd_unit_counit: left_biadj_unit_counit L. Proof. use (make_biadj_unit_counit R). - exact coevaluation_pstrans. - exact evaluation_pstrans. Defined. Definition currying_biajd_triangle_l_law: biadj_triangle_l_law currying_biajd_unit_counit. Proof. red. use make_invertible_modification. - intro A. apply nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + use make_nat_trans. * intro ab. apply identity. * intros ab ab' fg. cbn. apply pathsdirprod. -- rewrite id_right. apply idpath. -- rewrite id_left. rewrite id_right. apply id_right. + intro ab. cbn. set (aux := identity(C:=pr1(productwithfixedelement _ _)) ab). change (is_z_isomorphism aux). apply identity_is_z_iso. - intros A A' F. apply (nat_trans_eq (homset_property (productwithfixedelement _ _))). intro ab. cbn. apply pathsdirprod. + rewrite functor_id. repeat rewrite id_left. apply idpath. + repeat rewrite id_left. apply idpath. Defined. Definition currying_biajd_triangle_r_law: biadj_triangle_r_law currying_biajd_unit_counit. Proof. red. use make_invertible_modification. - intro A. apply nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + use make_nat_trans. * intro G. cbn in G. use make_nat_trans. -- intro b. apply identity. -- intros b b' g. cbn. rewrite id_left, id_right. apply id_right. * intros G G' β. apply (nat_trans_eq (homset_property _)). intro b. cbn. rewrite id_right. apply cancel_postcomposition. apply functor_id. + intro G. apply nat_trafo_z_iso_if_pointwise_z_iso. intro b. cbn. apply identity_is_z_iso. - intros A A' F. apply (nat_trans_eq (homset_property (functor_category _ _))). intro G. cbn. apply (nat_trans_eq (homset_property _)). intro b. cbn. repeat rewrite id_left. repeat rewrite functor_id. repeat rewrite id_left. rewrite id_right. apply pathsinv0, functor_id. Defined. Definition currying_biajd: left_biadj_data L. Proof. use make_biadj_data. - exact currying_biajd_unit_counit. - exact currying_biajd_triangle_l_law. - exact currying_biajd_triangle_r_law. Defined. Definition currying_hom_equivalence (C E : category) : equivalence_of_cats [C, [B0:category,E]] [category_binproduct C B0, E]. Proof. apply (biadj_hom_equivalence currying_biajd). Defined. End Currying. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Identity.v000066400000000000000000000035351451125700300260030ustar00rootroot00000000000000(** The identity pseudo functor on a bicategory. Authors: Dan Frumin, Niels van der Weide Ported from: https://github.com/nmvdw/groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Section IdentityFunctor. Variable (C : bicat). Definition id_functor_d : psfunctor_data C C. Proof. use make_psfunctor_data. - exact (λ x, x). - exact (λ _ _ x, x). - exact (λ _ _ _ _ x, x). - exact (λ x, id2 _). - exact (λ _ _ _ _ _, id2 _). Defined. Definition id_functor_laws : psfunctor_laws id_functor_d. Proof. repeat split. - intros a b f ; cbn in *. rewrite id2_rwhisker. rewrite !id2_left. reflexivity. - intros a b f ; cbn in *. rewrite lwhisker_id2. rewrite !id2_left. reflexivity. - intros a b c d f g h ; cbn in *. rewrite lwhisker_id2, id2_rwhisker. rewrite !id2_left, !id2_right. reflexivity. - intros a b c f g h α ; cbn in *. rewrite !id2_left, !id2_right. reflexivity. - intros a b c f g h α ; cbn in *. rewrite !id2_left, !id2_right. reflexivity. Qed. Definition id_psfunctor : psfunctor C C. Proof. use make_psfunctor. - exact id_functor_d. - exact id_functor_laws. - split ; cbn ; intros ; is_iso. Defined. End IdentityFunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/LiftingActegories.v000066400000000000000000000061051451125700300276100ustar00rootroot00000000000000(** construction of a (displayed) pseudofunctor from the operation [reindexed_actegory] on actegories author: Ralph Matthes 2023 Notice that lifting was renamed into reindexing in July 2023, but the file name stayed the same although [ReindexingActegories.v] would be more appropriate. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders. Local Open Scope cat. Section PseudofunctorFromReindexing. Context {V : category} (Mon_V : monoidal V) {W : category} (Mon_W : monoidal W) {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F). Let dBV : disp_bicat bicat_of_cats := bidisp_actbicat_disp_bicat Mon_V. Let dBW : disp_bicat bicat_of_cats := bidisp_actbicat_disp_bicat Mon_W. Definition reindexing_actegories_disp_psfunctor : disp_psfunctor dBV dBW (id_psfunctor _). Proof. use make_disp_psfunctor. - apply actbicat_disp_2cells_isaprop. - apply actbicat_disp_locally_groupoid. - intros C Act. exact (reindexed_actegory Mon_V Act Mon_W U). - intros C D H ActC ActD ll. exact (reindexed_lax_lineator Mon_V Mon_W U ActC ActD ll). - intros C D H K ξ ActC ActD Hl Kl islntξ. apply preserves_linearity_reindexed_lax_lineator. exact islntξ. - abstract (intros C ActC w c; cbn; rewrite (bifunctor_leftid (actegory_action _ ActC)); do 2 rewrite id_left; apply idpath). - abstract (intros C D E H K ActC ActD ActE Hl Kl w c; cbn; rewrite (bifunctor_leftid (actegory_action _ ActE)) ; rewrite id_left, id_right; apply idpath). Defined. Definition reindexing_actegories_psfunctor : psfunctor (actbicat Mon_V) (actbicat Mon_W) := total_psfunctor dBV dBW (id_psfunctor _) reindexing_actegories_disp_psfunctor. End PseudofunctorFromReindexing. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/MonadInclusion.v000066400000000000000000000313701451125700300271320ustar00rootroot00000000000000(************************************************************************* Inclusion into the monad bicategory We show that we have a pseudofunctor from `B` to `mnd B`. Each object is sent to the identity monad on that object Contents 1. The identity monad 2. Section of bicategory of monads 3. Left biadjoint to the inclusion *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicatSection. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap. Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Local Open Scope cat. (** 1. The identity monad *) Section IdMonad. Context {B : bicat} (x : B). Definition id_monad_data : disp_mnd_data B x := id₁ x ,, id₂ _ ,, lunitor _. Definition is_mnd_id_monad_data : is_mnd B (x,, id_monad_data). Proof. repeat split ; cbn. - rewrite id2_rwhisker. rewrite id2_right. apply linvunitor_lunitor. - rewrite lwhisker_id2. rewrite id2_right. rewrite lunitor_runitor_identity. apply rinvunitor_runitor. - apply maponpaths_2. rewrite lunitor_lwhisker. rewrite runitor_lunitor_identity. apply idpath. Qed. Definition id_monad : disp_mnd B x := id_monad_data ,, is_mnd_id_monad_data. End IdMonad. (** 2. Section of bicategory of monads *) Definition id_monad_mor {B : bicat} {x y : B} (f : x --> y) : id_monad x -->[ f ] id_monad y. Proof. simple refine ((runitor _ • linvunitor _ ,, _) ,, tt) ; cbn. repeat split. - abstract (cbn ; rewrite id2_rwhisker, lwhisker_id2 ; rewrite !id2_right ; rewrite !vassocr ; rewrite rinvunitor_runitor ; rewrite id2_left ; apply idpath). - abstract (cbn ; rewrite !vassocl ; rewrite lunitor_runitor_identity ; rewrite <- lunitor_lwhisker ; rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)) ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite lwhisker_vcomp ; rewrite !vassocl ; rewrite linvunitor_lunitor ; rewrite id2_right ; rewrite runitor_triangle ; rewrite vcomp_runitor ; rewrite !vassocr ; do 2 apply maponpaths_2 ; rewrite <- runitor_triangle ; rewrite !vassocr ; rewrite lassociator_rassociator ; rewrite id2_left ; rewrite runitor_lunitor_identity ; apply idpath). Defined. Definition id_monad_cell {B : bicat} {x y : B} {f g : x --> y} (τ : f ==> g) : id_monad_mor f ==>[ τ ] id_monad_mor g. Proof. simple refine ((_ ,, (tt ,, tt)) ,, tt) ; cbn. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. rewrite linvunitor_natural. rewrite lwhisker_hcomp. apply idpath. Qed. Definition id_monad_id {B : bicat} (x : B) : id_disp _ ==>[ id2 _ ] id_monad_mor (id₁ x). Proof. simple refine ((_ ,, (tt ,, tt)) ,, tt) ; cbn. rewrite lwhisker_id2, id2_rwhisker. rewrite id2_left, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition id_monad_comp {B : bicat} {x y z : B} (f : x --> y) (g : y --> z) : id_monad_mor f ;; id_monad_mor g ==>[ id2 _ ] id_monad_mor (f · g). Proof. simple refine ((_ ,, (tt ,, tt)) ,, tt) ; cbn. rewrite id2_rwhisker, id2_left. rewrite lwhisker_id2, id2_right. rewrite <- runitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite linvunitor_assoc. rewrite !vassocr. apply maponpaths_2. rewrite lwhisker_hcomp. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. apply idpath. Qed. Definition mnd_section_disp_bicat (B : bicat) : section_disp_bicat (disp_mnd B). Proof. use make_section_disp_bicat. - apply disp_2cells_isaprop_disp_mnd. - apply disp_locally_groupoid_disp_mnd. - exact (λ x, id_monad x). - exact (λ _ _ f, id_monad_mor f). - exact (λ _ _ _ _ τ, id_monad_cell τ). - exact (λ x, id_monad_id x). - exact (λ _ _ _ f g, id_monad_comp f g). Defined. Definition mnd_incl (B : bicat) : psfunctor B (mnd B) := section_to_psfunctor (mnd_section_disp_bicat B). (** 3. Left biadjoint to the inclusion *) Definition mnd_to_mnd_incl_data {B : bicat} (m : mnd B) : mnd_mor_data m (mnd_incl B (ob_of_mnd m)). Proof. use make_mnd_mor_data. - exact (id₁ _). - exact (runitor _ • unit_of_mnd m • rinvunitor _). Defined. Definition mnd_to_mnd_incl_laws {B : bicat} (m : mnd B) : mnd_mor_laws (mnd_to_mnd_incl_data m). Proof. split. - cbn. rewrite lwhisker_id2. rewrite id2_right. rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite lunitor_runitor_identity. rewrite !vassocr. rewrite <- vcomp_runitor. rewrite !vassocl. rewrite runitor_rinvunitor. rewrite id2_right. apply idpath. - cbn. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite rwhisker_hcomp. rewrite !vassocr. rewrite <- triangle_r. rewrite <- lwhisker_hcomp. rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite rwhisker_hcomp. rewrite !vassocr. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite runitor_lunitor_identity. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. rewrite lwhisker_id2. rewrite id2_left. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite <- vcomp_runitor. rewrite !vassocl. rewrite runitor_rinvunitor. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. apply idpath. } rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite id2_left. refine (_ @ id2_right _). use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. exact (pr1 (pr222 m)). Qed. Definition mnd_to_mnd_incl {B : bicat} (m : mnd B) : m --> mnd_incl B (ob_of_mnd m). Proof. use make_mnd_mor. - exact (mnd_to_mnd_incl_data m). - exact (mnd_to_mnd_incl_laws m). Defined. Definition mnd_incl_hom_functor_data {B : bicat} (m : mnd B) (x : B) : functor_data (hom m (mnd_incl B x)) (hom (ob_of_mnd m) x). Proof. use make_functor_data. - exact (λ f, pr1 f). - exact (λ f₁ f₂ τ, pr1 τ). Defined. Definition mnd_incl_hom_functor_is_functor {B : bicat} (m : mnd B) (x : B) : is_functor (mnd_incl_hom_functor_data m x). Proof. split. - intro ; cbn. apply idpath. - intro ; intros ; cbn. apply idpath. Qed. Definition mnd_incl_hom_functor {B : bicat} (m : mnd B) (x : B) : hom m (mnd_incl B x) ⟶ hom (ob_of_mnd m) x. Proof. use make_functor. - exact (mnd_incl_hom_functor_data m x). - exact (mnd_incl_hom_functor_is_functor m x). Defined. Definition mnd_incl_unit_data {B : bicat} (m : mnd B) (x : B) : nat_trans_data (functor_identity _) (left_universal_arrow_functor (mnd_incl B) m x mnd_to_mnd_incl ∙ mnd_incl_hom_functor m x) := λ f, linvunitor f. Definition mnd_incl_unit_is_nat_trans {B : bicat} (m : mnd B) (x : B) : is_nat_trans _ _ (mnd_incl_unit_data m x). Proof. intros f₁ f₂ τ ; unfold mnd_incl_unit_data ; cbn. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. apply idpath. Qed. Definition mnd_incl_unit {B : bicat} (m : mnd B) (x : B) : functor_identity _ ⟹ left_universal_arrow_functor (mnd_incl B) m x mnd_to_mnd_incl ∙ mnd_incl_hom_functor m x. Proof. use make_nat_trans. - exact (mnd_incl_unit_data m x). - exact (mnd_incl_unit_is_nat_trans m x). Defined. Definition mnd_incl_counit_mnd_cell_data {B : bicat} (m : mnd B) (x : B) (f : m --> mnd_incl B x) : mnd_cell_data ((mnd_incl_hom_functor m x ∙ left_universal_arrow_functor (mnd_incl B) m x mnd_to_mnd_incl) f) (functor_identity (hom_data m (mnd_incl B x)) f) := lunitor _. Definition mnd_incl_counit_is_mnd_cell {B : bicat} (m : mnd B) (x : B) (f : m --> mnd_incl B x) : is_mnd_cell (mnd_incl_counit_mnd_cell_data m x f). Proof. unfold is_mnd_cell, mnd_incl_counit_mnd_cell_data ; cbn. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. etrans. { apply maponpaths. rewrite lwhisker_hcomp. rewrite !vassocr. rewrite triangle_l_inv. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. rewrite id2_left. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply id2_right. } use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. rewrite lwhisker_hcomp. rewrite <- linvunitor_natural. rewrite !vassocl. etrans. { apply maponpaths. apply (pr1 (pr212 f)). } cbn. rewrite !vassocr. rewrite runitor_rinvunitor. rewrite lwhisker_id2. rewrite !id2_left. apply idpath. Qed. Definition mnd_incl_counit_data {B : bicat} (m : mnd B) (x : B) : nat_trans_data (mnd_incl_hom_functor m x ∙ left_universal_arrow_functor (mnd_incl B) m x mnd_to_mnd_incl) (functor_identity _). Proof. intro f. use make_mnd_cell. - exact (mnd_incl_counit_mnd_cell_data m x f). - exact (mnd_incl_counit_is_mnd_cell m x f). Defined. Definition mnd_incl_counit_is_nat_trans {B : bicat} (m : mnd B) (x : B) : is_nat_trans _ _ (mnd_incl_counit_data m x). Proof. intros f₁ f₂ τ. use eq_mnd_cell ; cbn. unfold mnd_incl_counit_mnd_cell_data ; cbn. rewrite vcomp_lunitor. apply idpath. Qed. Definition mnd_incl_counit {B : bicat} (m : mnd B) (x : B) : mnd_incl_hom_functor m x ∙ left_universal_arrow_functor (mnd_incl B) m x mnd_to_mnd_incl ⟹ functor_identity _. Proof. use make_nat_trans. - exact (mnd_incl_counit_data m x). - exact (mnd_incl_counit_is_nat_trans m x). Defined. Definition is_z_isomorphism_mnd_incl_unit {B : bicat} {m : mnd B} {x : B} (f : ob_of_mnd m --> x) : is_z_isomorphism (mnd_incl_unit_data m x f). Proof. use is_inv2cell_to_is_z_iso. unfold mnd_incl_unit_data. is_iso. Defined. Definition is_z_isomorphism_mnd_incl_counit {B : bicat} {m : mnd B} {x : B} (f : m --> mnd_incl B x) : is_z_isomorphism (mnd_incl_counit_data m x f). Proof. use is_inv2cell_to_is_z_iso. use is_invertible_mnd_2cell. unfold mnd_incl_counit_data, mnd_incl_counit_mnd_cell_data ; cbn. is_iso. Defined. Definition mnd_incl_left_universal_arrow (B : bicat) : left_universal_arrow (mnd_incl B). Proof. use make_left_universal_arrow. - exact (λ m, ob_of_mnd m). - exact (λ m, mnd_to_mnd_incl m). - exact (λ m x, mnd_incl_hom_functor m x). - exact (λ m x, mnd_incl_unit m x). - exact (λ m x, mnd_incl_counit m x). - exact (λ m x f, is_z_isomorphism_mnd_incl_unit f). - exact (λ m x f, is_z_isomorphism_mnd_incl_counit f). Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Op2OfPseudoFunctor.v000066400000000000000000000075161451125700300276630ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Section Op2PseudoFunctor. Context {B : bicat} (F : psfunctor (op2_bicat B) B). Definition op2_psfunctor_data : psfunctor_data B (op2_bicat B). Proof. use make_psfunctor_data. - exact (λ b, F b). - exact (λ _ _ f, #F f). - exact (λ _ _ _ _ α, ##F α). - exact (λ b, (psfunctor_id F b)^-1). - exact (λ _ _ _ f g, (psfunctor_comp F f g)^-1). Defined. Definition op2_psfunctor_laws : psfunctor_laws op2_psfunctor_data. Proof. repeat split. - intros ? ? f ; cbn. exact (psfunctor_id2 F f). - intros ? ? ? ? ? α β ; cbn. exact (psfunctor_vcomp F β α). - intros ? ? f ; cbn -[psfunctor_id psfunctor_comp]. pose (psfunctor_linvunitor F f) as p. cbn -[psfunctor_id psfunctor_comp] in p. rewrite p. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite vassocr. rewrite vcomp_rinv. apply id2_left. } rewrite rwhisker_vcomp. rewrite vcomp_rinv. rewrite id2_rwhisker. apply id2_right. - intros ? ? f ; cbn -[psfunctor_id psfunctor_comp]. pose (psfunctor_rinvunitor F f) as p. cbn -[psfunctor_id psfunctor_comp] in p. rewrite p. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite vassocr. rewrite vcomp_rinv. apply id2_left. } rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_right. - intros ? ? ? ? f g h ; cbn -[psfunctor_comp]. pose (psfunctor_rassociator F f g h) as p. cbn -[psfunctor_id psfunctor_comp] in p. use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[psfunctor_comp]. use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[psfunctor_comp]. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp]. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp]. exact p. - intros ? ? ? f ? ? α ; cbn -[psfunctor_comp]. pose (psfunctor_lwhisker F f α) as p. cbn -[psfunctor_comp] in p. use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[psfunctor_comp]. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp]. exact p. - intros ? ? ? ? ? g α ; cbn -[psfunctor_comp]. pose (psfunctor_rwhisker F g α) as p. cbn -[psfunctor_comp] in p. use vcomp_move_L_pM ; [ is_iso | ] ; cbn -[psfunctor_comp]. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp]. exact p. Qed. Definition op2_psfunctor_invertible_cells : invertible_cells op2_psfunctor_data. Proof. split. - intros. apply to_op2_is_invertible_2cell. cbn - [psfunctor_id]. is_iso. - intros. apply to_op2_is_invertible_2cell. cbn - [psfunctor_id]. is_iso. Defined. Definition op2_psfunctor : psfunctor B (op2_bicat B). Proof. use make_psfunctor. - exact op2_psfunctor_data. - exact op2_psfunctor_laws. - exact op2_psfunctor_invertible_cells. Defined. End Op2PseudoFunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/OpFunctor.v000066400000000000000000000061531451125700300261300ustar00rootroot00000000000000(* ******************************************************************************* *) (** The opposite of a category as a pseudofunctor ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Local Open Scope cat. Local Notation "∁" := bicat_of_univ_cats. Definition op_psfunctor_data : psfunctor_data (op2_bicat ∁) ∁. Proof. use make_psfunctor_data. - exact (λ C, op_unicat C). - exact (λ _ _ f, functor_opp f). - exact (λ _ _ _ _ x, op_nt x). - exact (λ C, functor_identity_op _). - exact (λ _ _ _ F G, functor_comp_op F G). Defined. Definition op_psfunctor_laws : psfunctor_laws op_psfunctor_data. Proof. repeat split. - intros C D F. cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat D) )|]. intro. apply idpath. - intros C D F G H α β ; cbn in *. apply nat_trans_eq ; [apply (homset_property (op_cat D) )|]. intro x ; cbn in *. apply idpath. - intros C D F. cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat D) )|]. intro. cbn. apply pathsinv0. rewrite !id_left. apply functor_id. - intros C D F. cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat D) )|]. intro. cbn. apply pathsinv0. rewrite id_left. rewrite id_right. apply idpath. - intros C1 C2 C3 C4 F G H. cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat C4) )|]. intro. cbn. apply pathsinv0. rewrite id_left. rewrite !id_right. rewrite functor_id. apply idpath. - intros C1 C2 C3 F G H alpha. cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat C3) )|]. intro. cbn. apply pathsinv0. rewrite id_left. rewrite id_right. apply idpath. - intros C1 C2 C3 F1 F2 F3 α ; cbn in *. apply nat_trans_eq; [apply (homset_property (op_cat C3) )|]. intros x ; cbn. rewrite id_left, id_right. apply idpath. Qed. Definition op_psfunctor_invertible_cells : invertible_cells op_psfunctor_data. Proof. split. - intro C. use is_nat_z_iso_to_is_invertible_2cell. apply is_nat_z_iso_functor_identity_op. - intros C₁ C₂ C₃ F G. use is_nat_z_iso_to_is_invertible_2cell. apply is_nat_z_iso_functor_comp_op. Defined. Definition op_psfunctor : psfunctor (op2_bicat ∁) ∁. Proof. use make_psfunctor. - exact op_psfunctor_data. - exact op_psfunctor_laws. - exact op_psfunctor_invertible_cells. Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/OpFunctorEnriched.v000066400000000000000000000105201451125700300275630ustar00rootroot00000000000000(***************************************************************** The opposite pseudofunctor for enriched categories If we have a symmetric monoidal category, then taking the opposite of enriched categories is pseudofunctorial. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.OpCellBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Local Open Scope cat. Section OppositePseudofunctor. Context (V : sym_monoidal_cat). Definition op_enriched_psfunctor_data : psfunctor_data (op2_bicat (bicat_of_enriched_cats V)) (bicat_of_enriched_cats V). Proof. use make_psfunctor_data. - exact (λ E, op_unicat (pr1 E) ,, op_enrichment V (pr2 E)). - exact (λ E₁ E₂ F, functor_opp (pr1 F) ,, functor_op_enrichment V (pr2 F)). - exact (λ E₁ E₂ F₁ F₂ τ, op_nt (pr1 τ) ,, nat_trans_op_enrichment V _ (pr2 τ)). - exact (λ E, functor_identity_op _ ,, functor_identity_op_enrichment V (pr2 E)). - exact (λ E₁ E₂ E₃ F G, functor_comp_op _ _ ,, functor_comp_op_enrichment V (pr2 F) (pr2 G)). Defined. Proposition op_enriched_psfunctor_laws : psfunctor_laws op_enriched_psfunctor_data. Proof. repeat split ; intro ; intros ; use eq_2cell_enriched ; intro ; cbn. - apply idpath. - apply idpath. - rewrite !id_left. rewrite functor_id. apply idpath. - rewrite !id_left. apply idpath. - rewrite !id_left, !id_right. rewrite functor_id. apply idpath. - rewrite id_left, id_right. apply idpath. - rewrite id_left, id_right. apply idpath. Qed. Definition op_enriched_psfunctor_inv2cells : invertible_cells op_enriched_psfunctor_data. Proof. split. - intro E. use make_is_invertible_2cell. + exact (nat_z_iso_to_trans_inv (functor_identity_op_nat_z_iso _) ,, functor_identity_op_inv_enrichment V (pr2 E)). + abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). + abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). - intros E₁ E₂ E₃ F G. use make_is_invertible_2cell. + exact (nat_z_iso_to_trans_inv (functor_comp_op_nat_z_iso _ _) ,, functor_comp_op_inv_enrichment V (pr2 F) (pr2 G)). + abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). + abstract (use eq_2cell_enriched ; intro x ; cbn ; apply id_left). Defined. Definition op_enriched_psfunctor : psfunctor (op2_bicat (bicat_of_enriched_cats V)) (bicat_of_enriched_cats V). Proof. use make_psfunctor. - exact op_enriched_psfunctor_data. - exact op_enriched_psfunctor_laws. - exact op_enriched_psfunctor_inv2cells. Defined. End OppositePseudofunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/PathGroupoid.v000066400000000000000000000610561451125700300266210ustar00rootroot00000000000000(** Bequivalence between 1-types and univalent groupoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Transformations.Examples.Whiskering. Require Import UniMath.Bicategories.Transformations.Examples.Unitality. Require Import UniMath.Bicategories.Transformations.Examples.Associativity. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Core.Examples.OneTypes. Require Import UniMath.Bicategories.Core.Examples.Groupoids. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Local Open Scope cat. Definition one_type_to_groupoid (X : one_type) : univalent_groupoid := path_univalent_groupoid (pr2 X). (** Action on morphisms *) Definition function_to_functor_data {X Y : one_type} (f : X → Y) : functor_data (one_type_to_groupoid X) (one_type_to_groupoid Y). Proof. use make_functor_data. - exact f. - exact (λ _ _ p, maponpaths f p). Defined. Definition function_to_functor_laws {X Y : one_type} (f : X → Y) : is_functor (function_to_functor_data f). Proof. split. - intros x ; cbn. apply idpath. - intros x y z p q ; cbn. apply maponpathscomp0. Qed. Definition function_to_functor {X Y : one_type} (f : X → Y) : one_type_to_groupoid X ⟶ one_type_to_groupoid Y. Proof. use make_functor. - exact (function_to_functor_data f). - exact (function_to_functor_laws f). Defined. (** Action on cells *) Definition path_to_nattrans {X Y : one_type} {f g : X → Y} (p : homotsec f g) : function_to_functor f ⟹ function_to_functor g. Proof. use make_nat_trans. - exact p. - abstract (intros x y q ; cbn in * ; induction q ; simpl ; refine (!_) ; apply pathscomp0rid). Defined. (** Identitor *) Definition path_groupoid_identitor (X : one_type) : functor_identity _ ⟹ function_to_functor (λ (x : X), x). Proof. use make_nat_trans. - exact idpath. - abstract (intros x y p ; cbn in * ; induction p ; cbn ; apply idpath). Defined. (** Compositor *) Definition path_groupoid_compositor {X Y Z : one_type} (f : X → Y) (g : Y → Z) : (function_to_functor f ∙ function_to_functor g) ⟹ function_to_functor (λ x, g(f x)). Proof. use make_nat_trans. - exact (λ x, idpath (g(f x))). - abstract (intros x y p ; cbn in * ; induction p ; cbn ; apply idpath). Defined. (** Data of path groupoid pseudofunctor *) Definition path_groupoid_data : psfunctor_data one_types grpds. Proof. use make_psfunctor_data. - exact one_type_to_groupoid. - exact (λ _ _ f, function_to_functor f ,, tt). - exact (λ _ _ _ _ p, path_to_nattrans p ,, tt). - exact (λ X, path_groupoid_identitor X ,, tt). - exact (λ _ _ _ f g, path_groupoid_compositor f g ,, tt). Defined. (** Laws *) Definition path_groupoid_laws : psfunctor_laws path_groupoid_data. Proof. repeat split. - intros X Y f. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intro x ; cbn. apply idpath. - intros X Y f g h p q. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. apply idpath. - intros X Y f. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. apply idpath. - intros X Y f. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. apply idpath. - intros W X Y Z f g h. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. apply idpath. - intros X Y Z f g₁ g₂ p. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. cbn. refine (!_). apply pathscomp0rid. - intros X Y Z f₁ f₂ g p. use subtypePath. { intro ; apply isapropunit. } apply nat_trans_eq. { apply homset_property. } intros x ; cbn. cbn. refine (!_). apply pathscomp0rid. Qed. (** The identitor and compositor are invertible *) Definition path_groupoid_invertible_cells : invertible_cells path_groupoid_data. Proof. split ; intros ; apply locally_groupoid_grpds. Defined. (** The pseudofunctor *) Definition path_groupoid : psfunctor one_types grpds. Proof. use make_psfunctor. - exact path_groupoid_data. - exact path_groupoid_laws. - exact path_groupoid_invertible_cells. Defined. (** The adjoint *) Definition objects_of_grpd_data : psfunctor_data grpds one_types. Proof. use make_psfunctor_data. - refine (λ G, make_one_type _ (univalent_category_has_groupoid_ob _)). apply G. - exact (λ _ _ F x, (pr1 F : _ ⟶ _) x). - intros G₁ G₂ F₁ F₂ α ; simpl. intro x. apply isotoid. { apply (pr1 G₂). } use make_z_iso'. + exact ((pr1 α : _ ⟹ _) x). + exact (pr2 G₂ _ _ ((pr1 α : _ ⟹ _) x)). - exact (λ _ _, idpath _). - exact (λ _ _ _ _ _ _, idpath _). Defined. Definition objects_of_grpd_is_psfunctor : psfunctor_laws objects_of_grpd_data. Proof. repeat split. - intros G₁ G₂ F ; cbn. use funextsec. intro x. refine (_ @ isotoid_identity_iso _ _ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ F₁ F₂ F₃ α₁ α₂ ; cbn. use funextsec. intro x ; unfold homotcomp. rewrite <- isotoid_comp. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ F ; cbn. use funextsec. intro x ; unfold homotcomp, homotfun ; cbn. refine (!_). refine (_ @ isotoid_identity_iso _ _ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ F ; cbn. use funextsec. intro x ; unfold homotcomp, homotfun ; cbn. refine (!_). refine (_ @ isotoid_identity_iso _ _ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ G₃ G₄ F₁ F₂ F₃ ; cbn. use funextsec. intro x ; unfold homotcomp, homotfun ; cbn. refine (_ @ isotoid_identity_iso _ _ _). apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ G₃ F₁ F₂ F₃ α ; cbn. use funextsec. intro x ; unfold homotcomp, homotfun, funhomotsec ; cbn. rewrite pathscomp0rid. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ G₃ F₁ F₂ F₃ α ; cbn. use funextsec. intro x ; unfold homotcomp, homotfun, funhomotsec ; cbn. rewrite pathscomp0rid. refine (!_). etrans. { apply maponpaths_isotoid. } apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Qed. Definition objects_of_grpd : psfunctor grpds one_types. Proof. use make_psfunctor. - exact objects_of_grpd_data. - exact objects_of_grpd_is_psfunctor. - split ; intros ; apply one_type_2cell_iso. Defined. (** The biadjunction *) Definition path_groupoid_unit_data : pstrans_data (id_psfunctor one_types) (comp_psfunctor objects_of_grpd path_groupoid). Proof. use make_pstrans_data. - exact (λ _ x, x). - exact (λ _ _ _, id2_invertible_2cell _). Defined. Lemma eq_isotoid {C : univalent_category} {X Y : C} (f : z_iso X Y) (p : X = Y) : f = idtoiso p → isotoid C (pr2 C) f = p. Proof. intro H. rewrite H. apply isotoid_idtoiso. Qed. Definition path_groupoid_inv_is_pstrans : is_pstrans path_groupoid_unit_data. Proof. repeat split. - intros X Y f g p. use funextsec ; intro x. refine (pathscomp0rid _ @ _ @ !(maponpathsidfun _)). cbn ; unfold funhomotsec. apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } cbn. induction (p x). apply idpath. - intros X ; cbn. use funextsec ; intro x. unfold homotcomp, funhomotsec, homotfun, homotrefl ; cbn. rewrite pathscomp0rid ; cbn in *. apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } cbn. apply idpath. - intros X Y Z f g ; cbn. use funextsec ; intro x. unfold homotcomp, funhomotsec, homotfun, homotrefl ; cbn. rewrite pathscomp0rid ; cbn in *. apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } cbn. apply idpath. Qed. Definition path_groupoid_unit : pstrans (id_psfunctor one_types) (comp_psfunctor objects_of_grpd path_groupoid). Proof. use make_pstrans. - exact path_groupoid_unit_data. - exact path_groupoid_inv_is_pstrans. Defined. Definition path_groupoid_counit_data_functor_data (G : univalent_groupoid) : functor_data (path_groupoid (objects_of_grpd G) : univalent_groupoid) G. Proof. use make_functor_data. - exact (λ x, x). - exact (λ _ _ p, idtoiso p). Defined. Definition path_groupoid_counit_data_functor_is_functor (G : univalent_groupoid) : is_functor (path_groupoid_counit_data_functor_data G). Proof. split. - intros x ; apply idpath. - intros x y z f g ; cbn. exact (maponpaths pr1 (idtoiso_concat _ _ _ _ f g)). Qed. Definition path_groupoid_counit_data_functor (G : univalent_groupoid) : (path_groupoid (objects_of_grpd G) : univalent_groupoid) ⟶ G. Proof. use make_functor. - exact (path_groupoid_counit_data_functor_data G). - exact (path_groupoid_counit_data_functor_is_functor G). Defined. Definition path_groupoid_counit_data_nat_trans_data (G₁ G₂ : grpds) (F : G₁ --> G₂) : nat_trans_data (path_groupoid_counit_data_functor G₁ ∙ pr1 F) ((function_to_functor (# objects_of_grpd F)) ∙ path_groupoid_counit_data_functor G₂) := λ _, id₁ _. Definition path_groupoid_counit_data_nat_trans_is_nat_trans (G₁ G₂ : grpds) (F : G₁ --> G₂) : is_nat_trans _ _ (path_groupoid_counit_data_nat_trans_data G₁ G₂ F). Proof. intros x y f ; cbn. rewrite id_left, id_right. refine (!_). exact (maponpaths pr1 (maponpaths_idtoiso _ _ _ _ _ _)). Qed. Definition path_groupoid_counit_data_nat_trans (G₁ G₂ : grpds) (F : G₁ --> G₂) : (path_groupoid_counit_data_functor G₁ ∙ pr1 F) ⟹ function_to_functor (#objects_of_grpd F) ∙ path_groupoid_counit_data_functor G₂. Proof. use make_nat_trans. - exact (path_groupoid_counit_data_nat_trans_data G₁ G₂ F). - exact (path_groupoid_counit_data_nat_trans_is_nat_trans G₁ G₂ F). Defined. Definition path_groupoid_counit_data : pstrans_data (comp_psfunctor path_groupoid objects_of_grpd) (id_psfunctor grpds). Proof. use make_pstrans_data. - exact (λ G, path_groupoid_counit_data_functor G ,, tt). - intros G₁ G₂ F. use make_invertible_2cell. + exact (path_groupoid_counit_data_nat_trans G₁ G₂ F ,, tt). + apply locally_groupoid_grpds. Defined. Definition path_groupoid_counit_is_pstrans : is_pstrans path_groupoid_counit_data. Proof. repeat split. - intros G₁ G₂ F₁ F₂ α. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite id_left, id_right. rewrite idtoiso_isotoid. apply idpath. - intros G. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite id_left, !id_right. apply idpath. - intros G₁ G₂ G₃ F₁ F₂. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite !id_left, !id_right. rewrite (functor_id (pr1 F₂)). apply idpath. Qed. Definition path_groupoid_counit : pstrans (comp_psfunctor path_groupoid objects_of_grpd) (id_psfunctor grpds). Proof. use make_pstrans. - exact path_groupoid_counit_data. - exact path_groupoid_counit_is_pstrans. Defined. Definition path_groupoid_biadj_unit_counit : left_biadj_unit_counit path_groupoid. Proof. use make_biadj_unit_counit. - exact objects_of_grpd. - exact path_groupoid_unit. - exact path_groupoid_counit. Defined. Definition path_groupoid_biadj_triangle_l_data : invertible_modification_data (biadj_triangle_l_lhs path_groupoid_biadj_unit_counit) (id_pstrans path_groupoid). Proof. intros X. use make_invertible_2cell. - refine (_ ,, tt). use make_nat_trans. + exact idpath. + abstract (intros x y p ; cbn in * ; induction p ; simpl ; apply idpath). - apply locally_groupoid_grpds. Defined. Definition path_groupoid_biadj_triangle_l_is_modification : is_modification path_groupoid_biadj_triangle_l_data. Proof. intros X Y f. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x. apply idpath. Qed. Definition path_groupoid_biadj_triangle_l : biadj_triangle_l_law path_groupoid_biadj_unit_counit. Proof. use make_invertible_modification. - exact path_groupoid_biadj_triangle_l_data. - exact path_groupoid_biadj_triangle_l_is_modification. Defined. Definition path_groupoid_biadj_triangle_r_data : invertible_modification_data (biadj_triangle_r_lhs path_groupoid_biadj_unit_counit) (id_pstrans path_groupoid_biadj_unit_counit). Proof. intro G. use make_invertible_2cell. - exact idpath. - apply one_type_2cell_iso. Defined. Definition path_groupoid_biadj_triangle_r_is_modification : is_modification path_groupoid_biadj_triangle_r_data. Proof. intros G₁ G₂ F. use funextsec. intro x. repeat (refine (pathscomp0rid _ @ _)). refine (maponpathsidfun _ @ _). refine (pathscomp0rid _ @ _). cbn ; unfold path_groupoid_counit_data_nat_trans_data. use eq_isotoid. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Qed. Definition path_groupoid_biadj_triangle_r : biadj_triangle_r_law path_groupoid_biadj_unit_counit. Proof. use make_invertible_modification. - exact path_groupoid_biadj_triangle_r_data. - exact path_groupoid_biadj_triangle_r_is_modification. Defined. Definition path_groupoid_biadj_data : left_biadj_data path_groupoid. Proof. use make_biadj_data. - exact path_groupoid_biadj_unit_counit. - exact path_groupoid_biadj_triangle_l. - exact path_groupoid_biadj_triangle_r. Defined. (** Inverse of unit *) Definition path_groupoid_unit_inv_data : pstrans_data (comp_psfunctor objects_of_grpd path_groupoid) (id_psfunctor one_types). Proof. use make_pstrans_data. - exact (λ _ x, x). - exact (λ _ _ _, id2_invertible_2cell _). Defined. Definition path_groupoid_unit_inv_is_pstrans : is_pstrans path_groupoid_unit_inv_data. Proof. repeat split. - intros X Y f g p. use funextsec ; intro x. refine (pathscomp0rid _ @ _ @ !(maponpathsidfun _)). cbn ; unfold funhomotsec. refine (!_). apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } cbn. induction (p x). apply idpath. - intros X ; cbn. use funextsec ; intro x. unfold homotcomp, funhomotsec, homotfun, homotrefl ; cbn. refine (!_). rewrite maponpathsidfun. apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros X Y Z f g ; cbn. use funextsec ; intro x. unfold homotcomp, funhomotsec, homotfun, homotrefl ; cbn. refine (!_). rewrite maponpathsidfun. apply (@eq_isotoid (path_univalent_groupoid _)). use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Qed. Definition path_groupoid_unit_inv : pstrans (comp_psfunctor objects_of_grpd path_groupoid) (id_psfunctor one_types). Proof. use make_pstrans. - exact path_groupoid_unit_inv_data. - exact path_groupoid_unit_inv_is_pstrans. Defined. Definition path_groupoid_unit_unit_inv : invertible_modification (comp_pstrans path_groupoid_unit path_groupoid_unit_inv) (id_pstrans _). Proof. use make_invertible_modification. - intro. apply id2_invertible_2cell. - abstract (intros X Y f ; use funextsec ; intro ; apply idpath). Defined. Definition path_groupoid_unit_inv_unit : invertible_modification (comp_pstrans path_groupoid_unit_inv path_groupoid_unit) (id_pstrans _). Proof. use make_invertible_modification. - intro. apply id2_invertible_2cell. - abstract (intros X Y f ; use funextsec ; intro x ; apply idpath). Defined. (** Inverse of counit *) Definition path_groupoid_counit_inv_data_functor_data (G : univalent_groupoid) : functor_data G (path_groupoid (objects_of_grpd G) : univalent_groupoid). Proof. use make_functor_data. - exact (λ x, x). - exact (λ _ _ p, isotoid G (pr21 G) (p ,, pr2 G _ _ p)). Defined. Definition path_groupoid_counit_inv_data_functor_is_functor (G : univalent_groupoid) : is_functor (path_groupoid_counit_inv_data_functor_data G). Proof. split. - intro x ; cbn. apply eq_isotoid. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros x y z f g ; cbn. apply eq_isotoid. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } rewrite idtoiso_concat. rewrite !idtoiso_isotoid. apply idpath. Qed. Definition path_groupoid_counit_inv_data_functor (G : univalent_groupoid) : G ⟶ (path_groupoid (objects_of_grpd G) : univalent_groupoid). Proof. use make_functor. - exact (path_groupoid_counit_inv_data_functor_data G). - exact (path_groupoid_counit_inv_data_functor_is_functor G). Defined. Definition path_groupoid_counit_inv_data_nat_trans_data (G₁ G₂ : grpds) (F : G₁ --> G₂) : nat_trans_data ((path_groupoid_counit_inv_data_functor G₁) ∙ function_to_functor (# objects_of_grpd F)) (pr1 F ∙ path_groupoid_counit_inv_data_functor G₂) := λ _, id₁ _. Definition path_groupoid_counit_inv_data_nat_trans_is_nat_trans (G₁ G₂ : grpds) (F : G₁ --> G₂) : is_nat_trans _ _ (path_groupoid_counit_inv_data_nat_trans_data G₁ G₂ F). Proof. intros x y f ; cbn. rewrite pathscomp0rid. rewrite (maponpaths_isotoid _ _ (pr1 F) _ (pr21 G₂)). apply maponpaths. apply subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Qed. Definition path_groupoid_counit_inv_data_nat_trans (G₁ G₂ : grpds) (F : G₁ --> G₂) : ((path_groupoid_counit_inv_data_functor G₁) ∙ function_to_functor (#objects_of_grpd F)) ⟹ (pr1 F∙ path_groupoid_counit_inv_data_functor G₂). Proof. use make_nat_trans. - exact (path_groupoid_counit_inv_data_nat_trans_data G₁ G₂ F). - exact (path_groupoid_counit_inv_data_nat_trans_is_nat_trans G₁ G₂ F). Defined. Definition path_groupoid_counit_inv_data : pstrans_data (id_psfunctor grpds) (comp_psfunctor path_groupoid objects_of_grpd). Proof. use make_pstrans_data. - exact (λ G, path_groupoid_counit_inv_data_functor G ,, tt). - intros G₁ G₂ F. use make_invertible_2cell. + exact (path_groupoid_counit_inv_data_nat_trans G₁ G₂ F ,, tt). + apply locally_groupoid_grpds. Defined. Definition path_groupoid_counit_inv_is_pstrans : is_pstrans path_groupoid_counit_inv_data. Proof. repeat split. - intros G₁ G₂ F₁ F₂ α. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. rewrite pathscomp0rid. apply maponpaths. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. refine (!_). apply eq_isotoid. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. - intros G₁ G₂ G₃ F₁ F₂. use subtypePath. { intro ; apply isapropunit. } use nat_trans_eq. { apply homset_property. } intro x ; cbn. refine (!_). apply eq_isotoid. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Qed. Definition path_groupoid_counit_inv : pstrans (id_psfunctor grpds) (comp_psfunctor path_groupoid objects_of_grpd). Proof. use make_pstrans. - exact path_groupoid_counit_inv_data. - exact path_groupoid_counit_inv_is_pstrans. Defined. Definition path_groupoid_counit_counit_inv : invertible_modification (comp_pstrans path_groupoid_counit path_groupoid_counit_inv) (id_pstrans _). Proof. use make_invertible_modification. - intro. use make_invertible_2cell. + refine (_ ,, tt). use make_nat_trans. * exact idpath. * abstract (intros x y p ; cbn ; rewrite pathscomp0rid ; apply eq_isotoid ; use subtypePath ; try (intro ; apply isaprop_is_z_isomorphism) ; apply idpath). + apply locally_groupoid_grpds. - abstract (intros G₁ G₂ F ; use subtypePath ; try (intro ; apply isapropunit) ; use nat_trans_eq ; try (apply homset_property) ; intro ; cbn ; rewrite !pathscomp0rid ; apply eq_isotoid ; use subtypePath ; try (intro ; apply isaprop_is_z_isomorphism) ; apply idpath). Defined. Definition path_groupoid_counit_inv_counit : invertible_modification (comp_pstrans path_groupoid_counit_inv path_groupoid_counit) (id_pstrans _). Proof. use make_invertible_modification. - intro. use make_invertible_2cell. + refine (_ ,, tt). use make_nat_trans. * exact identity. * abstract (intros x y p ; cbn ; rewrite id_right, id_left, idtoiso_isotoid ; apply idpath). + apply locally_groupoid_grpds. - abstract (intros G₁ G₂ F ; use subtypePath ; try (intro ; apply isapropunit) ; use nat_trans_eq ; try (apply homset_property) ; intro ; cbn ; rewrite !id_left, id_right ; rewrite (functor_id (pr1 F)) ; apply idpath). Defined. Definition is_biequiv_path_groupoid : is_biequivalence path_groupoid. Proof. use make_is_biequivalence. - exact objects_of_grpd. - exact path_groupoid_unit. - exact path_groupoid_unit_inv. - exact path_groupoid_counit. - exact path_groupoid_counit_inv. - exact (inv_of_invertible_2cell path_groupoid_unit_inv_unit). - exact path_groupoid_unit_unit_inv. - exact (inv_of_invertible_2cell path_groupoid_counit_counit_inv). - exact path_groupoid_counit_inv_counit. Defined. Definition biequiv_path_groupoid : biequivalence one_types grpds := path_groupoid ,, is_biequiv_path_groupoid. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Projection.v000066400000000000000000000046371451125700300263320ustar00rootroot00000000000000(* ******************************************************************************* *) (** The projection of the total bicategory of some displayed category to the base ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Local Open Scope cat. Local Open Scope mor_disp_scope. Section Projection. Context {C : bicat}. Variable (D : disp_bicat C). Definition strict_pr1_psfunctor_data : strict_psfunctor_data (total_bicat D) C. Proof. use make_strict_psfunctor_data. - exact pr1. - exact (λ _ _, pr1). - exact (λ _ _ _ _, pr1). - exact (λ a, idpath _). - exact (λ _ _ _ f g, idpath _). Defined. Definition strict_pr1_psfunctor_laws : is_strict_psfunctor strict_pr1_psfunctor_data. Proof. repeat split; intro a; intros; cbn. - rewrite id2_rwhisker. rewrite id2_left. rewrite id2_left. apply idpath. - rewrite lwhisker_id2. rewrite id2_left. rewrite id2_left. apply idpath. - rewrite !lwhisker_id2, !id2_rwhisker. rewrite !id2_left, !id2_right. apply idpath. - rewrite id2_right. rewrite id2_left. apply idpath. - rewrite id2_left. rewrite id2_right. apply idpath. Qed. Definition strict_pr1_psfunctor : strict_psfunctor (total_bicat D) C. Proof. use make_strict_psfunctor. - exact strict_pr1_psfunctor_data. - exact strict_pr1_psfunctor_laws. Defined. Definition pr1_psfunctor : psfunctor (total_bicat D) C := strict_psfunctor_to_psfunctor_map _ _ strict_pr1_psfunctor. End Projection. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/PseudoFunctorsIntoCat.v000066400000000000000000000266171451125700300304650ustar00rootroot00000000000000(****************************************************************************** Pseudofunctors into categories from a discrete bicategory In this file, we compare pseudofunctors from a discrete bicategory into the bicategory of univalent categories with indexed categories. For that, we first provide a constructor to build pseudofunctors into any bicategory starting in a discrete bicategory. Contents 1. Pseudofunctors from a discrete bicategory 2. Every indexed category gives rise to a pseudofunctor 3. Pseudofunctor into categories give an indexed category 4. Transport on pseudofunctors into categories ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. (** 1. Pseudofunctors from a discrete bicategory *) Section PseudoFunctorFromCat. Context {C : category} {B : bicat} (F₀ : C → B) (F₁ : ∏ (x y : C), x --> y → F₀ x --> F₀ y) (Fid : ∏ (a : C), invertible_2cell (id₁ (F₀ a)) (F₁ a a (id₁ a))) (Fc : ∏ (a b c : C) (f : a --> b) (g : b --> c), invertible_2cell (F₁ a b f · F₁ b c g) (F₁ a c (f · g))) (Flun : ∏ (x y : C) (f : x --> y), lunitor _ = (Fid x ▹ F₁ x y f) • Fc x x y (id₁ x) f • idtoiso_2_1 _ _ (maponpaths (F₁ x y) (id_left _))) (Frun : ∏ (x y : C) (f : x --> y), runitor _ = (F₁ x y f ◃ Fid y) • Fc x y y f (id₁ y) • idtoiso_2_1 _ _ (maponpaths (F₁ x y) (id_right _))) (Fassoc : ∏ (w x y z : C) (f : w --> x) (g : x --> y) (h : y --> z), (F₁ w x f ◃ Fc x y z g h) • Fc w x z f (g · h) • idtoiso_2_1 _ _ (maponpaths (F₁ w z) (assoc f g h)) = lassociator _ _ _ • (Fc w x y f g ▹ F₁ y z h) • Fc w y z (f · g) h). Definition make_psfunctor_from_cat_data : psfunctor_data (cat_to_bicat C) B. Proof. use make_psfunctor_data. - exact F₀. - exact F₁. - exact (λ x y f g p, idtoiso_2_1 _ _ (maponpaths (F₁ x y) p)). - exact Fid. - exact Fc. Defined. Proposition make_psfunctor_from_cat_laws : psfunctor_laws make_psfunctor_from_cat_data. Proof. repeat split. - unfold psfunctor_id2_law ; cbn ; intros x y f. assert (@id2 (cat_to_bicat C) _ _ f = idpath _) as p. { apply homset_property. } etrans. { do 3 apply maponpaths. exact p. } cbn. apply idpath. - unfold psfunctor_vcomp2_law ; cbn ; intros x y f g h p q. induction p, q ; cbn. assert (@id2 (cat_to_bicat C) _ _ f = idpath _) as p. { apply homset_property. } rewrite <- !p. etrans. { do 3 apply maponpaths. refine (@id2_left (cat_to_bicat C) _ _ _ _ _ @ _). exact p. } cbn. rewrite id2_right. apply idpath. - unfold psfunctor_lunitor_law ; cbn ; intros x y f. refine (Flun x y f @ _). do 4 apply maponpaths. apply homset_property. - unfold psfunctor_runitor_law ; cbn ; intros x y f. refine (Frun x y f @ _). do 4 apply maponpaths. apply homset_property. - unfold psfunctor_lassociator_law ; cbn ; intros w x y z f g h. refine (_ @ Fassoc w x y z f g h). do 4 apply maponpaths. apply homset_property. - unfold psfunctor_lwhisker_law ; cbn ; intros x y z f g₁ g₂ p. induction p. cbn. rewrite lwhisker_id2. rewrite id2_left. assert (@id2 (cat_to_bicat C) _ _ g₁ = idpath _) as p. { apply homset_property. } assert (@id2 (cat_to_bicat C) _ _ (f · g₁) = idpath _) as q. { apply homset_property. } rewrite <- p. etrans. { do 4 apply maponpaths. refine (@lwhisker_id2 (cat_to_bicat C) _ _ _ _ _ @ _). exact q. } cbn. apply id2_right. - unfold psfunctor_rwhisker_law ; cbn ; intros x y z f₁ f₂ g p. induction p. cbn. rewrite id2_rwhisker. rewrite id2_left. assert (@id2 (cat_to_bicat C) _ _ f₁ = idpath _) as p. { apply homset_property. } assert (@id2 (cat_to_bicat C) _ _ (f₁ · g) = idpath _) as q. { apply homset_property. } rewrite <- p. etrans. { do 4 apply maponpaths. refine (@id2_rwhisker (cat_to_bicat C) _ _ _ _ _ @ _). exact q. } cbn. apply id2_right. Qed. Definition make_psfunctor_from_cat : psfunctor (cat_to_bicat C) B. Proof. use make_psfunctor. - exact make_psfunctor_from_cat_data. - exact make_psfunctor_from_cat_laws. - split ; intros ; apply property_from_invertible_2cell. Defined. End PseudoFunctorFromCat. (** 2. Every indexed category gives rise to a pseudofunctor *) Definition indexed_cat_to_psfunctor {C : category} (Φ : indexed_cat C) : psfunctor (cat_to_bicat C) bicat_of_univ_cats. Proof. use make_psfunctor_from_cat. - exact Φ. - exact (λ _ _ f, Φ $ f). - intro x. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + exact (indexed_cat_id Φ x). + intro xx. exact (is_z_isomorphism_indexed_cat_id Φ xx). - intros x y z f g. use nat_z_iso_to_invertible_2cell. use make_nat_z_iso. + exact (indexed_cat_comp Φ f g). + intro xx. exact (is_z_isomorphism_indexed_cat_comp Φ f g xx). - abstract (intros x y f ; use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro xx ; refine (indexed_cat_lunitor Φ f xx @ _) ; apply maponpaths ; refine (!_) ; refine (idtoiso_2_1_in_bicat_of_univ_cats (maponpaths (λ h, Φ $ h) (id_left f)) xx @ _) ; do 2 apply maponpaths ; exact (maponpathscomp (λ h, Φ $ h) (λ H, pr11 H xx) (id_left f))). - abstract (intros x y f ; use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro xx ; refine (indexed_cat_runitor Φ f xx @ _) ; apply maponpaths ; refine (!_) ; refine (idtoiso_2_1_in_bicat_of_univ_cats (maponpaths (λ h, Φ $ h) (id_right f)) xx @ _) ; do 2 apply maponpaths ; exact (maponpathscomp (λ h, Φ $ h) (λ H, pr11 H xx) (id_right f))). - abstract (intros w x y z f g h ; use nat_trans_eq ; [ apply homset_property | ] ; cbn ; intro ww ; rewrite id_left ; refine (_ @ indexed_cat_lassociator Φ f g h ww) ; apply maponpaths ; refine (idtoiso_2_1_in_bicat_of_univ_cats (maponpaths (λ h, Φ $ h) (assoc f g h)) ww @ _) ; do 2 apply maponpaths ; exact (maponpathscomp (λ h, Φ $ h) (λ H, pr11 H ww) (assoc f g h))). Defined. (** 3. Pseudofunctor into categories give an indexed category *) Section PseudofunctorToIndexedCat. Context {C : category} (F : psfunctor (cat_to_bicat C) bicat_of_univ_cats). Definition psfunctor_to_indexed_cat_data : indexed_cat_data C. Proof. use make_indexed_cat_data. - exact (λ x, F x). - exact (λ x y f, #F f). - exact (λ x, pr1 (psfunctor_id F x)). - exact (λ x y z f g, pr1 (psfunctor_comp F f g)). Defined. Definition psfunctor_to_indexed_cat_isos : indexed_cat_isos psfunctor_to_indexed_cat_data. Proof. split. - intros x xx. exact (pr2 (invertible_2cell_to_nat_z_iso _ _ (psfunctor_id F x)) xx). - intros x y z f g xx. exact (pr2 (invertible_2cell_to_nat_z_iso _ _ (psfunctor_comp F f g)) xx). Defined. Lemma psfunctor_idtoiso {x y : C} {f g : x --> y} (p : f = g) (xx : pr1 (F x)) : pr1 (##F p) xx = idtoiso (maponpaths (λ h, pr1 (#F h) xx) p). Proof. induction p ; cbn. refine (_ @ nat_trans_eq_pointwise (psfunctor_id2 F _) xx). refine (maponpaths (λ h, h xx) _). do 2 apply maponpaths. apply homset_property. Qed. Proposition psfunctor_to_indexed_cat_laws : indexed_cat_laws psfunctor_to_indexed_cat_data. Proof. repeat split. - intros x y f xx. pose (p := nat_trans_eq_pointwise (psfunctor_lunitor F f) xx). cbn in p ; cbn. refine (p @ _) ; clear p. rewrite !assoc'. do 2 apply maponpaths. refine (psfunctor_idtoiso _ _ @ _). do 3 apply maponpaths. apply homset_property. - intros x y f xx. pose (p := nat_trans_eq_pointwise (psfunctor_runitor F f) xx). cbn in p ; cbn. refine (p @ _) ; clear p. rewrite !assoc'. do 2 apply maponpaths. refine (psfunctor_idtoiso _ _ @ _). do 3 apply maponpaths. apply homset_property. - intros w x y z f g h ww. pose (p := nat_trans_eq_pointwise (psfunctor_lassociator F f g h) ww). cbn in p ; cbn. rewrite id_left in p. refine (_ @ p) ; clear p. apply maponpaths. refine (!_). refine (psfunctor_idtoiso _ _ @ _). do 3 apply maponpaths. apply homset_property. Qed. Definition psfunctor_to_indexed_cat : indexed_cat C. Proof. use make_indexed_cat. - exact psfunctor_to_indexed_cat_data. - exact psfunctor_to_indexed_cat_isos. - exact psfunctor_to_indexed_cat_laws. Defined. End PseudofunctorToIndexedCat. (** 4. Transport on pseudofunctors into categories *) Proposition transportf_psfunctor_into_cat {C : category} {F : psfunctor (cat_to_bicat C^op) bicat_of_univ_cats} {x y : C} (f : x --> y) (yy : pr1 (F y)) {g h : x --> y} (p : g = h) (ff : pr1 (# F f) yy --> pr1 (# F g) yy) : transportf (λ z, pr1 (#F f) yy --> pr1 (#F z) yy) p ff = ff · pr1 (##F p) yy. Proof. induction p ; cbn. refine (!(id_right _) @ _). apply maponpaths. refine (!(nat_trans_eq_pointwise (psfunctor_id2 F _) _) @ _). refine (maponpaths (λ z, pr1 (##F z) yy) _). apply homset_property. Qed. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/PseudofunctorFromMonoidal.v000066400000000000000000000165051451125700300313620ustar00rootroot00000000000000(** - Construction of a pseudofunctor from a strong monoidal functor - between the bicategories (trivially) generated from the monoidal categories. - And the opposite direction: We fix two bicategories and a pseudofunctor between them and an object in the domain bicategory. This gives rise to a strong monoidal functor between the associated monoidal categories of endomorphisms for the fixed object and its image. Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicategoryFromMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Section monoidal_functor_to_psfunctor. Context (M N : monoidal_cat). Local Definition M_as_bicat := bicat_from_monoidal M. Local Definition N_as_bicat := bicat_from_monoidal N. Context (smF : strong_monoidal_functor M N). Definition monoidal_functor_to_psfunctor_map_data: psfunctor_data M_as_bicat N_as_bicat. Proof. use make_psfunctor_data. - cbn. exact (fun x => x). - intros a b. cbn. exact (functor_on_objects smF). - intros a b f g. cbn. exact (functor_on_morphisms smF). - intros a. cbn. exact (lax_monoidal_functor_ϵ smF). - intros a b c f g. cbn. apply (lax_monoidal_functor_μ smF (f,g)). Defined. Definition monoidal_functor_to_psfunctor_map_laws: psfunctor_laws monoidal_functor_to_psfunctor_map_data. Proof. repeat split; red; cbn. - intros H0 H1 a. apply functor_id. - intros H0 H1 a b c f g. apply functor_comp. - intros H0 H1 a. apply lax_monoidal_functor_unital. - intros H0 H1 a. apply (lax_monoidal_functor_unital smF a). - intros H0 H1 H2 H3 a b c. do 2 rewrite <- assoc. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (nat_z_iso_pointwise_z_iso (monoidal_cat_associator N) ((smF a, smF b), smF c))). do 2 rewrite assoc. etrans. 2: { apply maponpaths. apply functor_on_inv_from_z_iso'. } apply z_iso_inv_on_left. cbn. apply pathsinv0. apply lax_monoidal_functor_assoc. - intros H0 H1 H2 a b1 b2 g. red in g. apply pathsinv0. assert (Heq := nat_trans_ax (lax_monoidal_functor_μ smF) (a,,b1) (a,,b2) (id a,,g)). cbn in Heq. rewrite functor_id in Heq. exact Heq. - intros H0 H1 H2 a1 a2 b f. apply pathsinv0. assert (Heq := nat_trans_ax (lax_monoidal_functor_μ smF) (a1,,b) (a2,,b) (f,,id b)). cbn in Heq. rewrite functor_id in Heq. exact Heq. Qed. Definition monoidal_functor_to_psfunctor: psfunctor M_as_bicat N_as_bicat. Proof. use make_psfunctor. - exact (monoidal_functor_to_psfunctor_map_data). - exact (monoidal_functor_to_psfunctor_map_laws). - split ; red; cbn. + intros H0. unfold two_cells_from_monoidal. exists (strong_monoidal_functor_ϵ_inv smF). exact (pr2 (strong_monoidal_functor_ϵ_is_z_iso smF)). + intros H0 H1 H2 a b. unfold two_cells_from_monoidal. exists (strong_monoidal_functor_μ_inv smF (a,,b)). exact (pr2 (strong_monoidal_functor_μ_is_nat_z_iso smF (a,,b))). Defined. End monoidal_functor_to_psfunctor. (** *** Going into the opposite direction *) (** see the description in the file header *) Section psfunctor_to_monoidal_functor. Local Open Scope bicategory_scope. Import Bicat.Notations. Context {C : bicat}. Context (c0: ob C). Context {D : bicat}. Context (psF: psfunctor C D). Local Definition d0 : D := psF c0. Local Definition M : monoidal_cat := monoidal_cat_from_bicat_and_ob c0. Local Definition N : monoidal_cat := monoidal_cat_from_bicat_and_ob d0. Definition psfunctor_to_lax_monoidal_functor_data: functor_data M N. Proof. use make_functor_data. - cbn. intro f. exact (# psF f). - intros a b f. red in f. cbn in f. cbn. exact (##psF f). Defined. Lemma psfunctor_to_lax_monoidal_functor_data_is_functor : is_functor psfunctor_to_lax_monoidal_functor_data. Proof. split; red; cbn. - intros a. apply psF. - intros a b c f g. apply psF. Qed. Definition psfunctor_to_lax_monoidal_functor_functor : M ⟶ N. Proof. use make_functor. - exact psfunctor_to_lax_monoidal_functor_data. - exact psfunctor_to_lax_monoidal_functor_data_is_functor. Defined. Local Definition auxμ : nat_trans_data (monoidal_functor_map_dom M N psfunctor_to_lax_monoidal_functor_functor) (monoidal_functor_map_codom M N psfunctor_to_lax_monoidal_functor_functor). Proof. red. cbn. intro fg. exact (psfunctor_comp psF (pr1 fg) (pr2 fg)). Defined. Local Lemma auxμ_is_nat_trans: is_nat_trans _ _ auxμ. Proof. red. cbn. intros gh gh' αβ. red in αβ. cbn in αβ. change (## psF (pr2 αβ) ⋆⋆ ## psF (pr1 αβ) • psfunctor_comp psF (pr1 gh') (pr2 gh') = psfunctor_comp psF (pr1 gh) (pr2 gh) • ## psF (pr2 αβ ⋆⋆ pr1 αβ)). apply pathsinv0. apply (psfunctor_comp_natural psF). Qed. Local Definition μ : monoidal_functor_map M N psfunctor_to_lax_monoidal_functor_functor := (auxμ,, auxμ_is_nat_trans). Lemma psfunctor_to_lax_monoidal_functor_laws : monoidal_functor_associativity M N psfunctor_to_lax_monoidal_functor_functor μ × monoidal_functor_unitality M N psfunctor_to_lax_monoidal_functor_functor (pr1(psfunctor_id psF c0)) μ. Proof. split. * red. cbn. intros x y z. unfold rassociator_fun'. cbn. assert (Hyp := psfunctor_rassociator psF x y z). change ((id₂ (# psF z) ⋆⋆ psfunctor_comp psF x y • psfunctor_comp psF (x · y) z) • ## psF (rassociator x y z) = (rassociator (# psF x) (# psF y) (# psF z) • psfunctor_comp psF y z ⋆⋆ id₂ (# psF x)) • psfunctor_comp psF x (y · z)). rewrite hcomp_identity_right. rewrite hcomp_identity_left. exact Hyp. * red. cbn. intro x. split. -- change (lunitor (# psF x) = (id₂ (# psF x) ⋆⋆ psfunctor_id psF c0 • psfunctor_comp psF (id₁ c0) x) • ## psF (lunitor x)). rewrite hcomp_identity_right. apply psfunctor_lunitor. -- change (runitor (# psF x) = (psfunctor_id psF c0 ⋆⋆ id₂ (# psF x) • psfunctor_comp psF x (id₁ c0)) • ## psF (runitor x)). rewrite hcomp_identity_left. apply psfunctor_runitor. Qed. Definition psfunctor_to_lax_monoidal_functor: lax_monoidal_functor M N. Proof. exists psfunctor_to_lax_monoidal_functor_functor. cbn. exists (psfunctor_id psF c0). exists μ. exact psfunctor_to_lax_monoidal_functor_laws. Defined. Definition psfunctor_to_monoidal_functor: strong_monoidal_functor M N. Proof. exists psfunctor_to_lax_monoidal_functor. split. - exact (pr2 (psfunctor_id psF c0)). - intro c. exact (pr2 (psfunctor_comp psF (pr1 c) (pr2 c))). Defined. End psfunctor_to_monoidal_functor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/PullbackFunctor.v000066400000000000000000000332011451125700300273010ustar00rootroot00000000000000(************************************************************* Pullback functors In this file, we look at the change of base functors arising from pullbacks. We look at two version: 1. Change of base for slice bicategories 2. Change of base for slices of display map bicategories 3. Change of base in the discrete case *************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits. Import PullbackFunctions.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.Logic.DisplayMapBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice. Local Open Scope cat. (** 1. Change of base for slice bicategories *) Section PullbackFunctor. Context (B : bicat_with_pb) {b₁ b₂ : B} (f : b₁ --> b₂). Definition pb_psfunctor_data : psfunctor_data (slice_bicat b₂) (slice_bicat b₁). Proof. use make_psfunctor_data. - exact (λ g, pb_obj f (pr2 g) ,, pb_pr1 f (pr2 g)). - simple refine (λ g₁ g₂ α, _ ,, _). + exact (f /≃₁ pr2 α). + exact (inv_of_invertible_2cell (pb_on_1cell_pr1 f (pr2 α))). - intros g₁ g₂ α β p. simple refine (_ ,, _). + exact (f /≃₂ pr2 p). + exact (pb_on_2cell_coh (pr2 α) (pr2 β) (pr1 p) (pr2 p)). - intro g. simple refine (_ ,, _). + exact (pb_1cell_on_id f (pr2 g)). + exact (pb_1cell_on_id_coh f (pr2 g)). - intros g₁ g₂ g₃ α β ; cbn. simple refine (_ ,, _). + exact (pb_1cell_on_comp f (pr2 α) (pr2 β)). + exact (pb_1cell_on_comp_coh f (pr2 α) (pr2 β)). Defined. Definition pb_psfunctor_laws : psfunctor_laws pb_psfunctor_data. Proof. repeat split. - intros g₁ g₂ α. use eq_2cell_slice ; cbn. apply pb_2cell_on_id. - intros g₁ g₂ α β γ p q. use eq_2cell_slice ; cbn. apply pb_2cell_on_comp. - intros g₁ g₂ α. use eq_2cell_slice ; cbn. apply pb_2cell_on_lunitor. - intros g₁ g₂ α. use eq_2cell_slice ; cbn. apply pb_2cell_on_runitor. - intros g₁ g₂ g₃ g₄ α β γ. use eq_2cell_slice ; cbn. apply pb_2cell_on_lassociator. - intros g₁ g₂ g₃ α β₁ β₂ p. use eq_2cell_slice ; cbn. apply pb_2cell_on_lwhisker. - intros g₁ g₂ g₃ α₁ α₂ β p. use eq_2cell_slice ; cbn. apply pb_2cell_on_rwhisker. Qed. Definition pb_psfunctor_invertible_cells : invertible_cells pb_psfunctor_data. Proof. split. - intro. apply is_invertible_2cell_in_slice_bicat ; cbn. use is_invertible_2cell_pb_ump_cell. + is_iso. + is_iso. - intros. apply is_invertible_2cell_in_slice_bicat ; cbn. use is_invertible_2cell_pb_ump_cell. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. Defined. Definition pb_psfunctor : psfunctor (slice_bicat b₂) (slice_bicat b₁). Proof. use make_psfunctor. - exact pb_psfunctor_data. - exact pb_psfunctor_laws. - exact pb_psfunctor_invertible_cells. Defined. End PullbackFunctor. (** 2. Change of base for slices of display map bicategories *) Section DispMapPullbackFunctor. Context (B : bicat_with_pb) (D : disp_map_bicat B) {b₁ b₂ : B} (f : b₁ --> b₂). Section PredMor_for_PB_Mor. Context {g₁ g₂ : disp_map_slice_bicat D b₂} (α : g₁ --> g₂). Let γ : invertible_2cell ((π₂ : f /≃ pr12 g₁ --> pr1 g₁) · pr1 α · pr12 g₂) (π₁ · id₁ b₁ · f) := comp_of_invertible_2cell (rassociator_invertible_2cell _ _ _) (comp_of_invertible_2cell (lwhisker_of_invertible_2cell _ (inv_of_invertible_2cell (pr22 α))) (comp_of_invertible_2cell (inv_of_invertible_2cell (pb_cell f (pr12 g₁))) (rwhisker_of_invertible_2cell _ (rinvunitor_invertible_2cell _)))). Definition help_pred_mor_pb_on_1cell : pb_ump_mor (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂))) (make_pb_cone (f /≃ pr12 g₁) ((π₂ : B ⟦ f /≃ pr12 g₁, pr1 g₁ ⟧) · pr1 α) (π₁ · id₁ b₁) γ) ==> f /≃₁ pr22 α. Proof. use pb_ump_cell. - apply (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂))). - exact (pb_ump_mor_pr2 (pb_obj_has_pb_ump f (pr12 g₂)) (mirror_cone (make_pb_cone (f /≃ pr12 g₁) (π₂ · pr1 α) (π₁ · id₁ b₁) γ)) • (pb_on_1cell_pr2 _ _)^-1). - exact (pb_ump_mor_pr1 (pb_obj_has_pb_ump f (pr12 g₂)) (mirror_cone (make_pb_cone (f /≃ pr12 g₁) (π₂ · pr1 α) (π₁ · id₁ b₁) γ)) • runitor _ • (pb_on_1cell_pr1 _ _)^-1). - abstract (cbn ; rewrite <- !rwhisker_vcomp ; rewrite !vassocl ; use vcomp_move_R_pM ; [ is_iso | ] ; cbn ; refine (!_) ; etrans ; [ apply maponpaths_2 ; exact (pb_ump_mor_cell (pb_obj_has_pb_ump f (pr12 g₂)) (mirror_cone (make_pb_cone (f /≃ pr12 g₁) (π₂ · pr1 α) (π₁ · id₁ b₁) γ))) | ] ; rewrite !vassocl ; apply maponpaths ; etrans ; [ do 3 apply maponpaths ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocl ; apply idpath | ] ; etrans ; [ do 2 apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocl ; apply idpath | ] ; rewrite !vassocr ; use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ; rewrite pb_on_1cell_cell ; rewrite !vassocl ; refine (!_) ; etrans ; [ do 3 apply maponpaths ; rewrite !vassocr ; rewrite rassociator_lassociator ; rewrite id2_left ; rewrite !vassocl ; apply idpath | ] ; etrans ; [ do 2 apply maponpaths ; rewrite !vassocr ; rewrite rwhisker_vcomp ; rewrite vcomp_linv ; rewrite id2_rwhisker ; rewrite id2_left ; rewrite !vassocl ; apply idpath | ]; apply idpath). Defined. Definition pred_mor_pb_on_1cell : pred_mor D π₁ π₁ (f /≃₁ pr22 α). Proof. pose (pred_mor_closed_under_pb_ump_mor D _ _ _ _ _ _ _ _ _ (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂))) _ _ _ _ (id₁ _) γ (pr22 g₂) (mor_of_pb_preserves_pred_ob D (pr22 g₂) (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂)))) (comp_pred_mor D (mor_of_pb_preserves_pred_ob D (pr22 g₁) (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₁)))) (pr12 α))) as c. use (invertible_pred_mor_3 _ _ c). use make_invertible_2cell. - apply help_pred_mor_pb_on_1cell. - use is_invertible_2cell_pb_ump_cell. + is_iso. apply property_from_invertible_2cell. + is_iso. apply property_from_invertible_2cell. Qed. End PredMor_for_PB_Mor. Definition disp_map_pb_psfunctor_data : psfunctor_data (disp_map_slice_bicat D b₂) (disp_map_slice_bicat D b₁). Proof. use make_psfunctor_data. - exact (λ g, pb_obj f (pr12 g) ,, pb_pr1 f (pr12 g) ,, pb_preserves_pred_ob D (pr22 g) (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g)))). - simple refine (λ g₁ g₂ α, _ ,, _ ,, _). + exact (f /≃₁ pr22 α). + apply pred_mor_pb_on_1cell. + exact (inv_of_invertible_2cell (pb_on_1cell_pr1 f (pr22 α))). - intros g₁ g₂ α β p. simple refine (_ ,, _). + exact (f /≃₂ pr2 p). + exact (pb_on_2cell_coh (pr22 α) (pr22 β) (pr1 p) (pr2 p)). - intro g. simple refine (_ ,, _). + exact (pb_1cell_on_id f (pr12 g)). + exact (pb_1cell_on_id_coh f (pr12 g)). - intros g₁ g₂ g₃ α β ; cbn. simple refine (_ ,, _). + exact (pb_1cell_on_comp f (pr22 α) (pr22 β)). + exact (pb_1cell_on_comp_coh f (pr22 α) (pr22 β)). Defined. Definition disp_map_pb_psfunctor_laws : psfunctor_laws disp_map_pb_psfunctor_data. Proof. repeat split. - intros g₁ g₂ α. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_id. - intros g₁ g₂ α β γ p q. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_comp. - intros g₁ g₂ α. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_lunitor. - intros g₁ g₂ α. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_runitor. - intros g₁ g₂ g₃ g₄ α β γ. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_lassociator. - intros g₁ g₂ g₃ α β₁ β₂ p. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_lwhisker. - intros g₁ g₂ g₃ α₁ α₂ β p. use eq_2cell_disp_map_slice ; cbn. apply pb_2cell_on_rwhisker. Qed. Definition disp_map_pb_psfunctor_invertible_cells : invertible_cells disp_map_pb_psfunctor_data. Proof. split. - intro. apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn. use is_invertible_2cell_pb_ump_cell. + is_iso. + is_iso. - intros. apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn. use is_invertible_2cell_pb_ump_cell. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. + is_iso. * apply property_from_invertible_2cell. * apply property_from_invertible_2cell. Defined. Definition disp_map_pb_psfunctor : psfunctor (disp_map_slice_bicat D b₂) (disp_map_slice_bicat D b₁). Proof. use make_psfunctor. - exact disp_map_pb_psfunctor_data. - exact disp_map_pb_psfunctor_laws. - exact disp_map_pb_psfunctor_invertible_cells. Defined. End DispMapPullbackFunctor. (** 3. Change of base in the discrete case *) Section DiscreteDispMapPullbackFunctor. Context (B : bicat_with_pb) (HB : is_univalent_2_1 B) (D : disp_map_bicat B) (HD₁ : arrow_subbicat_props D) (HD₂ : contained_in_discrete D) {b₁ b₂ : B} (f : b₁ --> b₂). Definition discrete_disp_map_pb_functor_data : functor_data (discrete_disp_map_slice HB HD₁ HD₂ b₂) (discrete_disp_map_slice HB HD₁ HD₂ b₁). Proof. use make_functor_data. - exact (λ g, disp_map_pb_psfunctor B D f g). - exact (λ g₁ g₂ α, #(disp_map_pb_psfunctor B D f) α). Defined. Definition discrete_disp_map_pb_is_functor : is_functor discrete_disp_map_pb_functor_data. Proof. split. - intro g. refine (!_). apply isotoid_2_1. + apply is_univalent_2_1_disp_map_slice. * exact HB. * exact HD₁. + exact (psfunctor_id (disp_map_pb_psfunctor B D f) g). - intros g₁ g₂ g₃ α β. refine (!_). apply isotoid_2_1. + apply is_univalent_2_1_disp_map_slice. * exact HB. * exact HD₁. + exact (psfunctor_comp (disp_map_pb_psfunctor B D f) α β). Qed. Definition discrete_disp_map_pb_functor : discrete_disp_map_slice HB HD₁ HD₂ b₂ ⟶ discrete_disp_map_slice HB HD₁ HD₂ b₁. Proof. use make_functor. - exact discrete_disp_map_pb_functor_data. - exact discrete_disp_map_pb_is_functor. Defined. End DiscreteDispMapPullbackFunctor. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Reindexing.v000066400000000000000000000306571451125700300263130ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.FibSlice. Require Import UniMath.Bicategories.Core.Examples.OpFibSlice. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.FibrationCleaving. Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.OpFibrationCleaving. Local Open Scope cat. Section ReindexFib. Context {C₁ C₂ : univalent_category} (F : C₁ ⟶ C₂). Definition reindex_fib_psfunctor_data : psfunctor_data (fib_slice_bicat C₂) (fib_slice_bicat C₁). Proof. use make_psfunctor_data. - exact (λ D, cleaving_of_cleaving_lift_obj D F). - exact (λ D₁ D₂ G, reindex_of_cartesian_disp_functor F G (pr2 D₁)). - exact (λ D₁ D₂ G₁ G₂ α, reindex_of_disp_nat_trans F α). - exact (λ D, reindex_of_disp_functor_identity F (pr1 D)). - exact (λ D₁ D₂ D₃ G₁ G₂, reindex_of_disp_functor_composite F (pr1 G₁) (pr1 G₂)). Defined. Definition reindex_fib_psfunctor_laws : psfunctor_laws reindex_fib_psfunctor_data. Proof. repeat split. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. apply idpath. - intros D₁ D₂ G₁ G₂ G₃ α β. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !id_right_disp. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply (disp_functor_transportf _ (pr1 G)). } rewrite transport_f_f. rewrite disp_functor_id. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !id_right_disp. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ D₄ G₁ G₂ G₃. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. etrans. { apply transportf_reindex. } rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_right_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite transport_f_f. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. rewrite id_left_disp. etrans. { do 4 apply maponpaths. apply (disp_functor_transportf _ (pr1 G₃)). } rewrite disp_functor_id. unfold transportb. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ G H₁ H₂ α. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. etrans. { apply transportf_reindex. } refine (!_). etrans. { apply transportf_reindex. } rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ G₁ G₂ H α. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. etrans. { apply transportf_reindex. } refine (!_). etrans. { apply transportf_reindex. } rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply (disp_functor_transportf _ (pr1 H)). } rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_fib_psfunctor_invertible_cells : invertible_cells reindex_fib_psfunctor_data. Proof. repeat split. - intro D. use is_invertible_2cell_fib_slice. intros x xx. apply (@id_is_z_iso_disp _ (reindex_disp_cat F (pr1 D))). - intros D₁ D₂ D₃ G₁ G₂. use is_invertible_2cell_fib_slice. intros x xx. apply (@id_is_z_iso_disp _ (reindex_disp_cat F (pr1 D₃))). Defined. Definition reindex_fib_psfunctor : psfunctor (fib_slice_bicat C₂) (fib_slice_bicat C₁). Proof. use make_psfunctor. - exact reindex_fib_psfunctor_data. - exact reindex_fib_psfunctor_laws. - exact reindex_fib_psfunctor_invertible_cells. Defined. End ReindexFib. Section ReindexOpFib. Context {C₁ C₂ : bicat_of_univ_cats} (F : C₁ --> C₂). Definition reindex_opfib_psfunctor_data : psfunctor_data (opfib_slice_bicat C₂) (opfib_slice_bicat C₁). Proof. use make_psfunctor_data. - exact (λ D, cleaving_of_opcleaving_lift_obj D F). - exact (λ D₁ D₂ G, reindex_of_opcartesian_disp_functor F G (pr2 D₁)). - exact (λ D₁ D₂ G₁ G₂ α, reindex_of_disp_nat_trans F α). - exact (λ D, reindex_of_disp_functor_identity F (pr1 D)). - exact (λ D₁ D₂ D₃ G₁ G₂, reindex_of_disp_functor_composite F (pr1 G₁) (pr1 G₂)). Defined. Definition reindex_opfib_psfunctor_laws : psfunctor_laws reindex_opfib_psfunctor_data. Proof. repeat split. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. apply idpath. - intros D₁ D₂ G₁ G₂ G₃ α β. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !id_right_disp. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply (disp_functor_transportf _ (pr1 G)). } rewrite transport_f_f. rewrite disp_functor_id. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ G. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !id_right_disp. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ D₄ G₁ G₂ G₃. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. etrans. { apply transportf_reindex. } rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !id_right_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply transportf_reindex. } rewrite transport_f_f. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. rewrite id_left_disp. etrans. { do 4 apply maponpaths. apply (disp_functor_transportf _ (pr1 G₃)). } rewrite disp_functor_id. unfold transportb. etrans. { apply maponpaths. apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ G H₁ H₂ α. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. etrans. { apply transportf_reindex. } refine (!_). etrans. { apply transportf_reindex. } rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros D₁ D₂ D₃ G₁ G₂ H α. use disp_nat_trans_eq. intros x xx ; cbn. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite !mor_disp_transportf_postwhisker. etrans. { apply transportf_reindex. } refine (!_). etrans. { apply transportf_reindex. } rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. etrans. { apply maponpaths. apply (disp_functor_transportf _ (pr1 H)). } rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_opfib_psfunctor_invertible_cells : invertible_cells reindex_opfib_psfunctor_data. Proof. repeat split. - intro D. use is_invertible_2cell_opfib_slice. intros x xx. apply (@id_is_z_iso_disp _ (reindex_disp_cat F (pr1 D))). - intros D₁ D₂ D₃ G₁ G₂. use is_invertible_2cell_opfib_slice. intros x xx. apply (@id_is_z_iso_disp _ (reindex_disp_cat F (pr1 D₃))). Defined. Definition reindex_opfib_psfunctor : psfunctor (opfib_slice_bicat C₂) (opfib_slice_bicat C₁). Proof. use make_psfunctor. - exact reindex_opfib_psfunctor_data. - exact reindex_opfib_psfunctor_laws. - exact reindex_opfib_psfunctor_invertible_cells. Defined. End ReindexOpFib. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/StrictToPseudo.v000066400000000000000000000153541451125700300271470ustar00rootroot00000000000000(* ******************************************************************************* *) (** The inclusion of strict pseudofunctors into pseudofunctors ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Import PseudoFunctor.Notations. Import StrictPseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope cat. Section Inclusion. Variable (B₁ B₂ : bicat). Definition strict_psfunctor_to_psfunctor_map_data : strict_psfunctor B₁ B₂ → psfunctor_data B₁ B₂. Proof. intro F. use make_psfunctor_data. - exact (λ X, F X). - exact (λ _ _ f, #F f). - exact (λ _ _ _ _ α, ##F α). - exact (strict_psfunctor_id_cell F). - exact (λ _ _ _ f g, strict_psfunctor_comp_cell F f g). Defined. Definition strict_psfunctor_to_psfunctor_map_laws (F : strict_psfunctor B₁ B₂) : psfunctor_laws (strict_psfunctor_to_psfunctor_map_data F). Proof. repeat split ; apply F. Qed. Definition strict_psfunctor_to_psfunctor_map : strict_psfunctor B₁ B₂ → psfunctor B₁ B₂. Proof. intros F. use make_psfunctor. - exact (strict_psfunctor_to_psfunctor_map_data F). - exact (strict_psfunctor_to_psfunctor_map_laws F). - split ; cbn. + intro a. apply (strict_psfunctor_id_cell F a). + intros a b c f g. apply (strict_psfunctor_comp_cell F f g). Defined. Definition strict_psfunctor_mor_to_pstrans_data (F G : strict_psfunctor_bicat B₁ B₂) : F --> G → pstrans_data (strict_psfunctor_to_psfunctor_map F) (strict_psfunctor_to_psfunctor_map G). Proof. intro η. use make_pstrans_data. - exact (λ X, pr111 η X). - exact (pr211 η). Defined. Definition strict_psfunctor_mor_to_pstrans_is_pstrans (F G : strict_psfunctor_bicat B₁ B₂) (η : F --> G) : is_pstrans (strict_psfunctor_mor_to_pstrans_data F G η). Proof. repeat split. - intros X Y f g α ; cbn. exact (pr121 η X Y f g α). - intros X ; cbn. exact (pr1 (pr221 η) X). - intros X Y Z f g ; cbn. exact (pr2 (pr221 η) X Y Z f g). Qed. Definition strict_psfunctor_mor_to_pstrans (F G : strict_psfunctor_bicat B₁ B₂) : F --> G → pstrans (strict_psfunctor_to_psfunctor_map F) (strict_psfunctor_to_psfunctor_map G). Proof. intros η. use make_pstrans. - exact (strict_psfunctor_mor_to_pstrans_data F G η). - exact (strict_psfunctor_mor_to_pstrans_is_pstrans F G η). Defined. Definition strict_psfunctor_cell_to_modification (F G : strict_psfunctor_bicat B₁ B₂) (η₁ η₂ : F --> G) : η₁ ==> η₂ → modification (strict_psfunctor_mor_to_pstrans _ _ η₁) (strict_psfunctor_mor_to_pstrans _ _ η₂). Proof. intro m. use make_modification. - intros X. exact (pr111 m X). - abstract (intros X Y f ; exact (pr211 m X Y f)). Defined. Definition strict_psfunctor_to_psfunctor_identitor (F : strict_psfunctor B₁ B₂) : (id₁ (strict_psfunctor_to_psfunctor_map F)) ==> strict_psfunctor_mor_to_pstrans F F (id₁ F). Proof. use make_modification. - exact (λ X, id₂ _). - abstract (intros X Y f ; cbn ; rewrite lwhisker_id2, id2_rwhisker, id2_left, id2_right ; reflexivity). Defined. Definition strict_psfunctor_to_psfunctor_compositor (F₁ F₂ F₃ : strict_psfunctor_bicat B₁ B₂) (η₁ : F₁ --> F₂) (η₂ : F₂ --> F₃) : (strict_psfunctor_mor_to_pstrans _ _ η₁) · strict_psfunctor_mor_to_pstrans _ _ η₂ ==> strict_psfunctor_mor_to_pstrans _ _ (η₁ · η₂). Proof. use make_modification. - exact (λ X, id₂ _). - abstract (intros X Y f ; cbn ; rewrite lwhisker_id2, id2_rwhisker, id2_left, id2_right ; reflexivity). Defined. Definition strict_psfunctor_to_psfunctor_data : psfunctor_data (strict_psfunctor_bicat B₁ B₂) (psfunctor_bicat B₁ B₂). Proof. use make_psfunctor_data. - exact strict_psfunctor_to_psfunctor_map. - exact strict_psfunctor_mor_to_pstrans. - exact strict_psfunctor_cell_to_modification. - exact strict_psfunctor_to_psfunctor_identitor. - exact strict_psfunctor_to_psfunctor_compositor. Defined. Definition strict_psfunctor_to_psfunctor_laws : psfunctor_laws strict_psfunctor_to_psfunctor_data. Proof. refine (_ ,, (_ ,, (_ ,, (_ ,, (_ ,, (_ ,, _)))))) ; intro ; intros ; use modification_eq ; intro ; cbn. - exact (idpath _). - exact (idpath _). - rewrite id2_rwhisker, !id2_left. exact (idpath _). - rewrite lwhisker_id2, !id2_left. exact (idpath _). - rewrite id2_rwhisker, lwhisker_id2, !id2_right, id2_left. exact (idpath _). - rewrite id2_left, id2_right. exact (idpath _). - rewrite id2_left, id2_right. exact (idpath _). Qed. Definition strict_psfunctor_to_psfunctor : psfunctor (strict_psfunctor_bicat B₁ B₂) (psfunctor_bicat B₁ B₂). Proof. use make_psfunctor. - exact strict_psfunctor_to_psfunctor_data. - exact strict_psfunctor_to_psfunctor_laws. - split ; intros ; apply make_is_invertible_modification ; intros ; cbn ; is_iso. Defined. End Inclusion. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Examples/Strictify.v000066400000000000000000001251271451125700300261740ustar00rootroot00000000000000(* ******************************************************************************* *) (** The inclusion of pseudofunctors into strict pseudofunctors for locally univalent bicategories ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor. Import PseudoFunctor.Notations. Import StrictPseudoFunctor.Notations. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Local Open Scope cat. Opaque psfunctor pstrans. Opaque strict_psfunctor. Section Strictify. Variable (B₁ B₂ : bicat) (HB₂_2_1 : is_univalent_2_1 B₂). Local Arguments idtoiso_2_1 {_} {_} {_} {_} {_} _. Local Arguments isotoid_2_1 {_} _ {_} {_} {_} {_} _. Definition strictify_ob_data : psfunctor B₁ B₂ → strict_psfunctor_data B₁ B₂. Proof. intros F. use make_strict_psfunctor_data. - exact (λ X, F X). - exact (λ _ _ f, #F f). - intros a b f g α ; cbn. exact (psfunctor_on_cells F α). - intro a ; cbn. exact (isotoid_2_1 HB₂_2_1 (psfunctor_id F a)). - intros a b c f g; cbn. exact (isotoid_2_1 HB₂_2_1 (psfunctor_comp F f g)). Defined. Definition strictify_ob_is_strict_psfunctor (F : psfunctor B₁ B₂) : is_strict_psfunctor (strictify_ob_data F). Proof. repeat split ; try (apply F) ; intro ; intros ; cbn ; unfold StrictPseudoFunctorBicat.strict_psfunctor_id_cell, StrictPseudoFunctorBicat.strict_psfunctor_comp_cell ; cbn ; rewrite !idtoiso_2_1_isotoid_2_1 ; apply F. Qed. Definition strictify_ob : psfunctor B₁ B₂ → strict_psfunctor_bicat B₁ B₂. Proof. intros F. use make_strict_psfunctor. - exact (strictify_ob_data F). - exact (strictify_ob_is_strict_psfunctor F). Defined. Definition strictify_mor_data (F G : psfunctor_bicat B₁ B₂) (η : pstrans F G) : strict_pstrans_data (strictify_ob F) (strictify_ob G). Proof. use tpair ; cbn. - exact (λ X, η X). - exact (λ X Y f, psnaturality_of η f). Defined. Definition strictify_mor_is_strict_pstrans (F G : psfunctor_bicat B₁ B₂) (η : pstrans F G) : is_strict_pstrans (strictify_mor_data F G η). Proof. repeat split. - intro ; intros ; cbn. apply (psnaturality_natural η). - intro ; intros ; cbn ; unfold strict_psfunctor_id_cell, strict_psfunctor_comp_cell ; cbn. rewrite !idtoiso_2_1_isotoid_2_1. apply (pstrans_id η). - intro ; intros ; cbn ; unfold strict_psfunctor_id_cell, strict_psfunctor_comp_cell ; cbn. rewrite !idtoiso_2_1_isotoid_2_1. apply (pstrans_comp η). Qed. Definition strictify_mor (F G : psfunctor_bicat B₁ B₂) : pstrans F G → strictify_ob F --> strictify_ob G. Proof. intros η. use make_strict_pstrans. - exact (strictify_mor_data F G η). - exact (strictify_mor_is_strict_pstrans F G η). Defined. Definition strictify_cell (F G : psfunctor_bicat B₁ B₂) (η₁ η₂ : pstrans F G) : modification η₁ η₂ → (strictify_mor _ _ η₁ ==> strictify_mor _ _ η₂). Proof. intros m. use make_strict_modification. - exact (λ X, m X). - abstract (intros X Y f ; exact (modnaturality_of m _ _ f)). Defined. Definition strictify_identitor_help (F : psfunctor B₁ B₂) : is_strict_modification (λ X : B₁, id₂ ((pr111 (id₁ (strictify_ob F))) X)). Proof. intros X Y f. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left, id2_right. reflexivity. Qed. Definition strictify_identitor (F : psfunctor B₁ B₂) : (id₁ (strictify_ob F)) ==> strictify_mor F F (id₁ F). Proof. use make_strict_modification. - exact (λ X, id₂ _). - exact (strictify_identitor_help F). Defined. Definition strictify_compositor_help (F₁ F₂ F₃ : psfunctor B₁ B₂) (η₁ : F₁ --> F₂) (η₂ : F₂ --> F₃) : is_strict_modification (λ X : B₁, id₂ ((pr111 (strictify_mor F₁ F₂ η₁ · strictify_mor F₂ F₃ η₂)) X)). Proof. intros X Y f. rewrite lwhisker_id2. rewrite id2_rwhisker. rewrite id2_left, id2_right. reflexivity. Qed. Definition strictify_compositor (F₁ F₂ F₃ : psfunctor B₁ B₂) (η₁ : F₁ --> F₂) (η₂ : F₂ --> F₃) : (strictify_mor _ _ η₁) · strictify_mor _ _ η₂ ==> strictify_mor _ _ (η₁ · η₂). Proof. use make_strict_modification. - exact (λ X, id₂ _). - exact (strictify_compositor_help F₁ F₂ F₃ η₁ η₂). Defined. Definition strictify_data : psfunctor_data (psfunctor_bicat B₁ B₂) (strict_psfunctor_bicat B₁ B₂). Proof. use make_psfunctor_data. - exact strictify_ob. - exact strictify_mor. - exact strictify_cell. - exact strictify_identitor. - exact strictify_compositor. Defined. Definition strictify_laws : psfunctor_laws strictify_data. Proof. refine (_ ,, (_ ,, (_ ,, (_ ,, (_ ,, (_ ,, _)))))) ; intro ; intros ; use strict_modification_eq ; intro ; cbn. - exact (idpath _). - exact (idpath _). - rewrite id2_rwhisker, !id2_left. exact (idpath _). - rewrite lwhisker_id2, !id2_left. exact (idpath _). - rewrite id2_rwhisker, lwhisker_id2, !id2_right, id2_left. exact (idpath _). - rewrite id2_left, id2_right. exact (idpath _). - rewrite id2_left, id2_right. exact (idpath _). Qed. Definition strictify_invertible_2cells : invertible_cells strictify_data. Proof. split ; intros ; apply make_is_invertible_strict_modification ; intros ; cbn ; is_iso. Qed. Definition strictify : psfunctor (psfunctor_bicat B₁ B₂) (strict_psfunctor_bicat B₁ B₂). Proof. use make_psfunctor. - exact strictify_data. - exact strictify_laws. - exact strictify_invertible_2cells. Defined. Definition strictify_counit_comp_comp (F : psfunctor B₁ B₂) : pstrans_data (strict_psfunctor_to_psfunctor_map B₁ B₂ (strictify_ob F)) F. Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - simple refine (λ X Y f, make_invertible_2cell _) ; cbn. + exact (lunitor (# F f) • rinvunitor (# F f)). + is_iso. Defined. Definition strictify_counit_comp_is_pstrans (F : psfunctor B₁ B₂) : is_pstrans (strictify_counit_comp_comp F). Proof. repeat split. - intros X Y f g α ; simpl. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. apply idpath. - intros X ; simpl. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. do 2 apply maponpaths. unfold strict_psfunctor_id_cell, strict_psfunctor_id. cbn. rewrite idtoiso_2_1_isotoid_2_1. apply idpath. - intros X Y Z f g ; simpl. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. do 2 apply maponpaths_2. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. apply idpath. } rewrite rinvunitor_triangle. apply maponpaths. unfold strict_psfunctor_comp_cell, strict_psfunctor_comp. cbn. rewrite idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Definition strictify_counit_comp (F : psfunctor B₁ B₂) : pstrans (strict_psfunctor_to_psfunctor_map B₁ B₂ (strictify_ob F)) F. Proof. use make_pstrans. - exact (strictify_counit_comp_comp F). - exact (strictify_counit_comp_is_pstrans F). Defined. Definition strict_counit_data_help (F G : psfunctor B₁ B₂) (α : pstrans F G) (X Y : B₁) (f : X --> Y) : (rassociator (id₁ (F X)) ((pr111 α) X) (#G f)) • (id₁ (F X) ◃ (psnaturality_of α f)) • (lassociator (id₁ (F X)) (#F f) (α Y)) • (((lunitor (# F f) • rinvunitor (# F f)) ▹ α Y)) • (rassociator (# F f) (id₁ (F Y)) (α Y)) • (# F f ◃ (lunitor (α Y) • rinvunitor (α Y))) = ((lunitor ((pr111 α) X) • rinvunitor (α X)) ▹ # G f) • (rassociator (α X) (id₁ (G X)) (# G f)) • ((α X ◃ (lunitor (# G f) • rinvunitor (# G f)))) • (lassociator (α X) (# G f) (id₁ (G Y))) • ((psnaturality_of α f ▹ id₁ (G Y))) • rassociator (# F f) (α Y) (id₁ (G Y)). Proof. refine (!_). etrans. { do 4 apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite !rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- rwhisker_hcomp, <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite rinvunitor_triangle. rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite vassocl. rewrite <- left_unit_inv_assoc. apply idpath. } rewrite <- lwhisker_vcomp. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite rwhisker_hcomp. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. apply idpath. } rewrite vcomp_lunitor. rewrite !vassocr. apply maponpaths_2. rewrite <- lunitor_triangle. rewrite !vassocr. rewrite rassociator_lassociator. apply id2_left. Qed. Definition strictify_counit_data : pstrans_data (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) (id_psfunctor (psfunctor_bicat B₁ B₂)). Proof. use make_pstrans_data. - exact strictify_counit_comp. - intros F G α. use make_invertible_modification. + intros Z ; cbn. use make_invertible_2cell. * exact (lunitor _ • rinvunitor _). * is_iso. + abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply strict_counit_data_help). Defined. Definition strictify_counit_is_pstrans_help₁ (F₁ F₂ : psfunctor B₁ B₂) (α β : pstrans F₁ F₂) (m : modification α β) (X : B₁) : (id₁ (F₁ X) ◃ (pr111 m) X) • (lunitor ((pr111 β) X) • rinvunitor ((pr111 β) X)) = (lunitor ((pr111 α) X) • rinvunitor ((pr111 α) X)) • (m X ▹ id₁ (F₂ X)). Proof. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. reflexivity. Qed. Definition strictify_counit_is_pstrans_help₂ (F : psfunctor B₁ B₂) (X : B₁) : (id₁ (F X) ◃ id₂ (id₁ ((pr111 F) X))) • (lunitor (id₁ ((pr111 F) X)) • rinvunitor (id₁ ((pr111 F) X))) = (runitor (id₁ (F X)) • linvunitor (id₁ (F X))) • ((pr111 (pr1 (psfunctor_id (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) F)) X) ▹ id₁ (F X)). Proof. rewrite !vassocr. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. rewrite !vassocl. apply maponpaths. rewrite id2_left. refine (!(id2_right _) @ _). rewrite lunitor_V_id_is_left_unit_V_id. apply maponpaths. rewrite <- id2_rwhisker. apply maponpaths. cbn. rewrite id2_left. apply idpath. Qed. Definition strictify_counit_is_pstrans_help₃ (F₁ F₂ F₃ : psfunctor B₁ B₂) (α : pstrans F₁ F₂) (β : pstrans F₂ F₃) (X : B₁) : (id₁ (F₁ X) ◃ id₂ ((pr111 α) X · (pr111 β) X)) • (lunitor ((pr111 α) X · (pr111 β) X) • rinvunitor ((pr111 α) X · (pr111 β) X)) = ((((lassociator (id₁ (F₁ X)) ((pr111 α) X) ((pr111 β) X) • ((lunitor ((pr111 α) X) • rinvunitor ((pr111 α) X)) ▹ (pr111 β) X)) • rassociator ((pr111 (# (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) α)) X) (id₁ (F₂ X)) ((pr111 β) X)) • ((pr111 (# (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) α)) X ◃ (lunitor ((pr111 β) X) • rinvunitor ((pr111 β) X)))) • lassociator ((pr111 (# (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) α)) X) ((pr111 (# (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) β)) X) (id₁ (F₃ X))) • ((pr111 ((pr222 (pr1 (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify))) F₁ F₂ F₃ α β)) X ▹ id₁ (F₃ X)). Proof. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_triangle. rewrite !vassocr. refine (!(id2_left _) @ _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker. apply idpath. Qed. Opaque comp_psfunctor. Definition strictify_counit_is_pstrans : is_pstrans strictify_counit_data. Proof. refine (_ ,, _ ,, _). - intros F₁ F₂ α β m. rewrite (comp_psfunctor_cell (strict_psfunctor_to_psfunctor B₁ B₂) strictify m). assert (psfunctor_on_cells (strict_psfunctor_to_psfunctor B₁ B₂) (psfunctor_on_cells strictify m) = strict_psfunctor_cell_to_modification _ _ _ _ _ _ (strictify_cell _ _ _ _ m)) as p. { apply idpath. } rewrite p. use modification_eq. exact (strictify_counit_is_pstrans_help₁ F₁ F₂ α β m). - intros F. use modification_eq. exact (strictify_counit_is_pstrans_help₂ F). - intros F₁ F₂ F₃ α β. use modification_eq. exact (strictify_counit_is_pstrans_help₃ F₁ F₂ F₃ α β). Qed. Transparent comp_psfunctor. Definition strictify_counit : pstrans (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify) (id_psfunctor _). Proof. use make_pstrans. - exact strictify_counit_data. - exact strictify_counit_is_pstrans. Defined. Definition strictify_counit_inv_data_comp (F : psfunctor B₁ B₂) : pstrans_data F (strict_psfunctor_to_psfunctor_map B₁ B₂ (strictify_ob F)). Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - simple refine (λ X Y f, make_invertible_2cell _) ; cbn. + exact (lunitor (# F f) • rinvunitor (# F f)). + is_iso. Defined. Definition strictify_counit_inv_data_is_pstrans (F : psfunctor B₁ B₂) : is_pstrans (strictify_counit_inv_data_comp F). Proof. repeat split. - intros X Y f g α ; cbn. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite vassocl. apply idpath. - intros X ; cbn. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } rewrite vassocl. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. do 2 apply maponpaths. unfold strict_psfunctor_id_cell, strict_psfunctor_id. cbn. rewrite idtoiso_2_1_isotoid_2_1. apply idpath. - intros X Y Z f g ; simpl. etrans. { rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. apply idpath. } rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. do 2 apply maponpaths_2. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. apply idpath. } rewrite rinvunitor_triangle. apply maponpaths. unfold strict_psfunctor_comp_cell, strict_psfunctor_comp. cbn. rewrite idtoiso_2_1_isotoid_2_1. apply idpath. Qed. Definition strictify_counit_inv_data : pstrans_data (id_psfunctor (psfunctor_bicat B₁ B₂)) (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify). Proof. use make_pstrans_data. - intro F. use make_pstrans. + exact (strictify_counit_inv_data_comp F). + exact (strictify_counit_inv_data_is_pstrans F). - intros F₁ F₂ α. use make_invertible_modification. + intros X. use make_invertible_2cell ; cbn. * exact (lunitor _ • rinvunitor _). * is_iso. + abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply strict_counit_data_help). Defined. Definition strictify_counit_inv_is_pstrans : is_pstrans strictify_counit_inv_data. Proof. refine (_ ,, _ ,, _). - intros F₁ F₂ α β m. use modification_eq. intro X ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros F. use modification_eq. intros X ; cbn. rewrite id2_left, lwhisker_id2, id2_left. rewrite id2_rwhisker, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros F₁ F₂ F₃ α β. use modification_eq. intros X ; cbn. rewrite id2_left, lwhisker_id2, id2_left. rewrite id2_rwhisker, id2_right. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_triangle. refine (!(id2_left _) @ _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Qed. Definition strictify_counit_inv : pstrans (id_psfunctor _) (comp_psfunctor (strict_psfunctor_to_psfunctor B₁ B₂) strictify). Proof. use make_pstrans. - exact strictify_counit_inv_data. - exact strictify_counit_inv_is_pstrans. Defined. Local Definition modifications_help (F : functor_data B₁ B₂) (X Y : B₁) (f : X --> Y) : (rassociator (id₁ (F X)) (id₁ (F X)) (#F f)) • (id₁ (F X) ◃ (lunitor (# F f) • rinvunitor (# F f))) • lassociator (id₁ (F X)) (# F f) (id₁ (F Y)) • ((lunitor (# F f) • rinvunitor (# F f)) ▹ id₁ (F Y)) • rassociator (#F f) (id₁ (F Y)) (id₁ (F Y)) • (# F f ◃ lunitor (id₁ (F Y))) = (lunitor (id₁ (F X)) ▹ # F f) • lunitor (#F f) • rinvunitor (#F f). Proof. rewrite <- lwhisker_vcomp. rewrite !vassocr. rewrite lunitor_lwhisker. rewrite !vassocl. rewrite runitor_lunitor_identity. apply maponpaths. rewrite !vassocr. rewrite rinvunitor_triangle. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor, id2_right. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition modification_help_alt (F₁ F₂ : functor_data B₁ B₂) (α : nat_trans_data F₁ F₂) (X : B₁) : (rassociator (id₁ (F₁ X)) (id₁ (F₁ X)) (α X)) • (id₁ (F₁ X) ◃ (lunitor (α X) • rinvunitor (α X))) • lassociator (id₁ (F₁ X)) (α X) (id₁ (F₂ X)) • ((lunitor (α X) • rinvunitor (α X)) ▹ id₁ (F₂ X)) • rassociator (α X) (id₁ (F₂ X)) (id₁ (F₂ X)) • (α X ◃ lunitor (id₁ (F₂ X))) = (lunitor (id₁ (F₁ X)) ▹ α X) • lunitor (α X) • rinvunitor (α X). Proof. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor, id2_right. refine (!_). etrans. { rewrite rinvunitor_natural, <- rwhisker_hcomp. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_triangle. rewrite !vassocr. apply maponpaths_2. rewrite lunitor_lwhisker. rewrite runitor_lunitor_identity. apply idpath. Qed. Local Definition psfunctor_to_functor_data (F : psfunctor B₁ B₂) : functor_data B₁ B₂. Proof. use make_functor_data. - exact (λ X, F X). - exact (λ _ _ f, #F f). Defined. Local Definition strict_psfunctor_to_functor_data (F : strict_psfunctor B₁ B₂) : functor_data B₁ B₂. Proof. use make_functor_data. - exact (λ X, F X). - exact (λ _ _ f, #F f). Defined. Local Definition pstrans_to_nattrans_data {F₁ F₂ : psfunctor B₁ B₂} (α : pstrans F₁ F₂) : nat_trans_data (psfunctor_to_functor_data F₁) (psfunctor_to_functor_data F₂) := λ X, α X. Local Definition strict_pstrans_to_nattrans_data {F₁ F₂ : strict_psfunctor_bicat B₁ B₂} (α : F₁ --> F₂) : nat_trans_data (strict_psfunctor_to_functor_data F₁) (strict_psfunctor_to_functor_data F₂) := λ X, pr111 α X. Definition strictify_counit_inv_strictify_counit : invertible_modification (comp_pstrans strictify_counit_inv strictify_counit) (id_pstrans _). Proof. use make_invertible_modification. - intros F. use make_invertible_modification. + intro X ; cbn. use make_invertible_2cell. * exact (lunitor (id₁ _)). * is_iso. + abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply (modifications_help (psfunctor_to_functor_data F) X Y f)). - abstract (intros F₁ F₂ α ; apply modification_eq ; intros X ; cbn ; rewrite !vassocr ; apply (modification_help_alt (psfunctor_to_functor_data F₁) (psfunctor_to_functor_data F₂) (pstrans_to_nattrans_data α))). Defined. Definition strictify_counit_strictify_counit_inv : invertible_modification (comp_pstrans strictify_counit strictify_counit_inv) (id_pstrans _). Proof. use make_invertible_modification. - intros F. use make_invertible_modification. + intro X ; cbn. use make_invertible_2cell. * exact (lunitor (id₁ _)). * is_iso. + abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply (modifications_help (psfunctor_to_functor_data F) X Y f)). - abstract (intros F₁ F₂ α ; apply modification_eq ; intros X ; cbn ; rewrite !vassocr ; apply (modification_help_alt (psfunctor_to_functor_data F₁) (psfunctor_to_functor_data F₂) (pstrans_to_nattrans_data α))). Defined. Definition strictify_unit_data_help1 (F : strict_psfunctor B₁ B₂) (X Y : B₁) (f g : B₁ ⟦ X, Y ⟧) (α : f ==> g) : (id₁ (F X) ◃ ## F α) • lunitor (# F g) • rinvunitor (# F g) = (lunitor (# F f) • rinvunitor (# F f)) • (##F α ▹ id₁ ((pr111 F) Y)). Proof. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition strictify_unit_data_help2 (F : strict_psfunctor B₁ B₂) (X : B₁) : (id₁ (F X) ◃ psfunctor_id (strict_psfunctor_to_psfunctor_map B₁ B₂ F) X) • lunitor (# F (id₁ X)) • rinvunitor (# F (id₁ X)) = (runitor (id₁ (F X)) • linvunitor (id₁ (F X))) • (idtoiso_2_1 (strict_psfunctor_id F X) ▹ id₁ (F X)). Proof. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. Qed. Definition strictify_unit_data_help3 (F : strict_psfunctor B₁ B₂) (X Y Z : B₁) (f : X --> Y) (g : Y --> Z) : ((id₁ ((pr111 F) X) ◃ psfunctor_comp (strict_psfunctor_to_psfunctor_map B₁ B₂ F) f g) • lunitor (# F (f · g))) • rinvunitor (# F (f · g)) = (lassociator (id₁ ((pr111 F) X)) (# F f) (# F g)) • ((lunitor (# F f) • rinvunitor (# F f)) ▹ # F g) • rassociator (#F f) (id₁ (F Y)) (# F g) • (# F f ◃ (lunitor (# F g) • rinvunitor (# F g))) • lassociator (#F f) (#F g) (id₁ ((pr111 F) Z)) • (idtoiso_2_1 ((pr222 (pr1 F)) X Y Z f g) ▹ id₁ ((pr111 F) Z)). Proof. rewrite vcomp_lunitor. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. rewrite lwhisker_vcomp. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition strictify_unit_data_help4 (F₁ F₂ : strict_psfunctor B₁ B₂) (α : strict_psfunctor_bicat B₁ B₂ ⟦ F₁ , F₂ ⟧) (X Y : B₁) (f : X --> Y) : (rassociator (id₁ ((pr111 F₁) X)) ((pr111 α) X) (# F₂ f)) • (id₁ ((pr111 F₁) X) ◃ (pr211 α) X Y f) • lassociator (id₁ (F₁ X)) (# F₁ f) ((pr111 α) Y) • ((lunitor (# F₁ f) • rinvunitor (# F₁ f)) ▹ (pr111 α) Y) • rassociator (#F₁ f) (id₁ (F₁ Y)) ((pr111 α) Y) • (# F₁ f ◃ (lunitor ((pr111 α) Y) • rinvunitor ((pr111 α) Y))) = ((lunitor ((pr111 α) X) • rinvunitor ((pr111 α) X)) ▹ # F₂ f) • rassociator ((pr111 α) X) (id₁ (F₂ X)) (# F₂ f) • ((pr111 α) X ◃ (lunitor (# F₂ f) • rinvunitor (# F₂ f))) • lassociator ((pr111 α) X) ((pr211 F₂) X Y f) (id₁ (F₂ Y)) • ((pr211 α) X Y f ▹ id₁ ((pr111 F₂) Y)) • rassociator (#F₁ f) ((pr111 α) Y) (id₁ (F₂ Y)). Proof. refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. rewrite <- rwhisker_vcomp. rewrite !vassocl. rewrite !rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- rwhisker_hcomp, <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. apply maponpaths. rewrite !vassocr. rewrite linvunitor_lunitor, id2_left. apply idpath. } rewrite !vassocl. rewrite rinvunitor_triangle. apply idpath. } rewrite !vassocl. rewrite !rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite <- rwhisker_hcomp. apply idpath. } etrans. { rewrite !vassocl. rewrite <- left_unit_inv_assoc. apply idpath. } refine (!_). etrans. { rewrite !vassocl. rewrite <- lwhisker_vcomp. rewrite !vassocr. apply idpath. } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_runitor, id2_right. rewrite lunitor_triangle. rewrite vcomp_lunitor. rewrite !vassocr. apply idpath. } apply maponpaths_2. use vcomp_move_R_pM. { is_iso. } rewrite lunitor_triangle. apply idpath. Qed. Definition strictify_unit_data : pstrans_data (id_psfunctor (strict_psfunctor_bicat B₁ B₂)) (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)). Proof. use make_pstrans_data. - intros F. simple refine (((_ ,, _) ,, (_ ,, _ ,, _)) ,, tt). + exact (λ X, id₁ (pr111 F X)). + intros X Y f ; cbn. use make_invertible_2cell. * exact (lunitor _ • rinvunitor _). * is_iso. + abstract (intros X Y f g α ; cbn ; rewrite !vassocr ; apply strictify_unit_data_help1). + abstract (intros X ; cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; rewrite !vassocr ; apply strictify_unit_data_help2). + abstract (intros X Y Z f g ; cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; rewrite !vassocr ; apply strictify_unit_data_help3). - intros F₁ F₂ α. use make_invertible_2cell. + use make_strict_modification. * intros Z ; cbn. exact (lunitor _ • rinvunitor _). * abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply strictify_unit_data_help4). + use make_is_invertible_strict_modification. intros X ; cbn. is_iso. Defined. Definition strictify_unit_is_pstrans : is_pstrans strictify_unit_data. Proof. repeat split. - intros F₁ F₂ α β m. use strict_modification_eq. intros X ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros F. use strict_modification_eq. intros X ; cbn. rewrite id2_left, lwhisker_id2, id2_left. rewrite id2_rwhisker, id2_right. rewrite lunitor_runitor_identity. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros F₁ F₂ F₃ α β. use strict_modification_eq. intros X ; cbn. rewrite id2_left, lwhisker_id2, id2_left. rewrite id2_rwhisker, id2_right. rewrite <- rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_triangle. refine (!(id2_left _) @ _). rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_rwhisker. apply idpath. Qed. Definition strictify_unit : pstrans (id_psfunctor _) (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)). Proof. use make_pstrans. - exact strictify_unit_data. - exact strictify_unit_is_pstrans. Defined. Definition strictify_unit_inv_data : pstrans_data (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) (id_psfunctor _). Proof. use make_pstrans_data. - intros F. simple refine (((_ ,, _) ,, (_ ,, _ ,, _)) ,, tt). + exact (λ X, id₁ (pr111 F X)). + intros X Y f ; cbn. use make_invertible_2cell. * exact (lunitor _ • rinvunitor _). * is_iso. + abstract (intros X Y f g α ; cbn ; rewrite !vassocr ; apply strictify_unit_data_help1). + abstract (intros X ; cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; rewrite !vassocr ; apply strictify_unit_data_help2). + abstract (intros X Y Z f g ; cbn ; rewrite idtoiso_2_1_isotoid_2_1 ; rewrite !vassocr ; apply strictify_unit_data_help3). - intros F₁ F₂ α. use make_invertible_2cell. + use make_strict_modification. * intros Z ; cbn. exact (lunitor _ • rinvunitor _). * abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply strictify_unit_data_help4). + use make_is_invertible_strict_modification. intros X ; cbn. is_iso. Defined. Definition strictify_unit_is_pstrans_help₁ (F₁ F₂ : strict_psfunctor_bicat B₁ B₂) (α β : F₁ --> F₂) (m : α ==> β) (X : B₁) : (id₁ (pr111 F₁ X) ◃ (pr111 m) X) • (lunitor ((pr111 β) X) • rinvunitor ((pr111 β) X)) = (lunitor ((pr111 α) X) • rinvunitor ((pr111 α) X)) • (pr111 m X ▹ id₁ (pr111 F₂ X)). Proof. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. reflexivity. Qed. Definition strictify_unit_is_pstrans_help₂ (F : strict_psfunctor B₁ B₂) (X : B₁) : (id₁ ((pr111 F) X) ◃ id₂ (id₁ ((pr111 F) X))) • (lunitor (id₁ ((pr111 F) X)) • rinvunitor (id₁ ((pr111 F) X))) = (runitor (id₁ ((pr111 F) X)) • linvunitor (id₁ ((pr111 F) X))) • ((pr111 ((pr122 (pr1 (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)))) F)) X ▹ id₁ ((pr111 F) X)). Proof. rewrite !vassocr. rewrite vcomp_lunitor. rewrite runitor_lunitor_identity. rewrite !vassocl. apply maponpaths. rewrite id2_left. refine (!(id2_right _) @ _). rewrite lunitor_V_id_is_left_unit_V_id. apply maponpaths. rewrite <- id2_rwhisker. apply maponpaths. cbn. rewrite id2_left. apply idpath. Qed. Definition strictify_unit_is_pstrans_help₃ (F₁ F₂ F₃ : strict_psfunctor_bicat B₁ B₂) (α : F₁ --> F₂) (β : F₂ --> F₃) (X : B₁) : (id₁ ((pr111 F₁) X) ◃ id₂ ((pr111 α) X · (pr111 β) X)) • (lunitor ((pr111 α) X · (pr111 β) X) • rinvunitor ((pr111 α) X · (pr111 β) X)) = ((((lassociator (id₁ ((pr111 F₁) X)) ((pr111 α) X) ((pr111 β) X) • ((lunitor ((pr111 α) X) • rinvunitor ((pr111 α) X)) ▹ (pr111 β) X)) • rassociator ((pr111 (# (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) α)) X) (id₁ ((pr111 F₂) X)) ((pr111 β) X)) • ((pr111 (# (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) α)) X ◃ (lunitor ((pr111 β) X) • rinvunitor ((pr111 β) X)))) • lassociator ((pr111 (# (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) α)) X) ((pr111 (# (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) β)) X) (id₁ ((pr111 F₃) X))) • ((pr111 ((pr222 (pr1 (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)))) F₁ F₂ F₃ α β)) X ▹ id₁ ((pr111 F₃) X)). Proof. cbn. rewrite lwhisker_id2, !id2_left. rewrite id2_rwhisker, id2_right. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite rinvunitor_triangle. rewrite !vassocr. refine (!(id2_left _) @ _). apply maponpaths_2. rewrite !vassocl. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor, id2_rwhisker. apply idpath. Qed. Opaque comp_psfunctor. Definition strictify_unit_inv_is_pstrans : is_pstrans strictify_unit_inv_data. Proof. refine (_ ,, _ ,, _). - intros F₁ F₂ α β m. use strict_modification_eq. exact (strictify_unit_is_pstrans_help₁ F₁ F₂ α β m). - intros F. use strict_modification_eq. exact (strictify_unit_is_pstrans_help₂ F). - intros F₁ F₂ F₃ α β. use strict_modification_eq. exact (strictify_unit_is_pstrans_help₃ F₁ F₂ F₃ α β). Qed. Transparent comp_psfunctor. Definition strictify_unit_inv : pstrans (comp_psfunctor strictify (strict_psfunctor_to_psfunctor B₁ B₂)) (id_psfunctor _). Proof. use make_pstrans. - exact strictify_unit_inv_data. - exact strictify_unit_inv_is_pstrans. Defined. Definition strictify_unit_strictify_unit_inv : invertible_modification (comp_pstrans strictify_unit strictify_unit_inv) (id_pstrans _). Proof. use make_invertible_modification. - intros F. use make_invertible_2cell. + use make_strict_modification. * intro X ; cbn. exact (lunitor (id₁ _)). * abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply (modifications_help (strict_psfunctor_to_functor_data F) X Y f)). + use make_is_invertible_strict_modification. intro X ; cbn. is_iso. - abstract (intros F₁ F₂ α ; apply strict_modification_eq ; intros X ; cbn ; rewrite !vassocr ; apply (modification_help_alt (strict_psfunctor_to_functor_data F₁) (strict_psfunctor_to_functor_data F₂) (strict_pstrans_to_nattrans_data α))). Defined. Definition strictify_unit_inv_strictify_unit : invertible_modification (comp_pstrans strictify_unit_inv strictify_unit) (id_pstrans _). Proof. use make_invertible_modification. - intros F. use make_invertible_2cell. + use make_strict_modification. * intro X ; cbn. exact (lunitor (id₁ _)). * abstract (intros X Y f ; cbn ; rewrite !vassocr ; apply (modifications_help (strict_psfunctor_to_functor_data F) X Y f)). + use make_is_invertible_strict_modification. intro X ; cbn. is_iso. - abstract (intros F₁ F₂ α ; apply strict_modification_eq ; intros X ; cbn ; rewrite !vassocr ; apply (modification_help_alt (strict_psfunctor_to_functor_data F₁) (strict_psfunctor_to_functor_data F₂) (strict_pstrans_to_nattrans_data α))). Defined. End Strictify. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/000077500000000000000000000000001451125700300247205ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/BiadjunctionPreservation.v000066400000000000000000000054551451125700300321330ustar00rootroot00000000000000(****************************************************************** Preservation of biinitial and bifinal objects by biadjoints ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Limits.Final. Local Open Scope cat. Section BiadjunctionPreservation. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Definition left_biadj_preserves_biinitial : preserves_biinitial L. Proof. intros x Hx. use is_biinitial_repr_to_is_biinitial. intro y. use nat_iso_adj_equivalence_of_cats. - exact (biadj_right_hom R x y ∙ functor_to_unit _). - use make_nat_trans. + exact (λ _, idpath _). + abstract (intros f g α ; apply isapropunit). - intros f. use tpair; cbn. + apply idpath. + abstract (split ; apply idpath). - use comp_adj_equivalence_of_cats. + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y)). + exact (is_biinitial_to_is_biinitial_repr Hx (R y)). Defined. (** 2. Preservation of bifinal objects *) Definition right_biadj_preserves_bifinal : preserves_bifinal R. Proof. intros y Hy. use is_bifinal_repr_to_is_bifinal. intro x. use nat_iso_adj_equivalence_of_cats. - exact (biadj_left_hom R x y ∙ functor_to_unit _). - use make_nat_trans. + exact (λ _, idpath _). + abstract (intros f g α ; apply isapropunit). - intros f. use tpair; cbn. + apply idpath. + abstract (split ; apply idpath). - use comp_adj_equivalence_of_cats. + exact (biadj_hom_equiv R x y). + exact (is_bifinal_to_is_bifinal_repr Hy (L x)). Defined. End BiadjunctionPreservation. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveCoproducts.v000066400000000000000000000456121451125700300333120ustar00rootroot00000000000000(****************************************************************** Preservation of coproducts by left biadjoints ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Colimits.Coproducts. Local Open Scope cat. Section BiadjunctionPreservation. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Definition left_biadj_preserves_binprods_1cell (x : B₂) {y₁ y₂ : B₁} (p : bincoprod_cocone y₁ y₂) : hom (psfunctor_bincoprod_cocone L p) x ⟶ category_binproduct (hom (L y₁) x) (hom (L y₂) x) := biadj_right_hom R p x ∙ universal_coprod_functor p (R x) ∙ pair_functor (biadj_left_hom R y₁ x) (biadj_left_hom R y₂ x). Definition left_biadj_preserves_binprods_1cell_adj_equiv (HB₁ : is_univalent_2_1 B₁) (x : B₂) {y₁ y₂ : B₁} (p : bincoprod_cocone y₁ y₂) (Hp : has_bincoprod_ump p) : adj_equivalence_of_cats (left_biadj_preserves_binprods_1cell x p). Proof. use comp_adj_equivalence_of_cats. - use comp_adj_equivalence_of_cats. + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R p x)). + apply (make_is_universal_coprod_cocone HB₁ _ Hp). - use pair_adj_equivalence_of_cats. + exact (biadj_hom_equiv R y₁ x). + exact (biadj_hom_equiv R y₂ x). Defined. Section PreserveCoproducts. Context {y₁ y₂ : B₁} (p : bincoprod_cocone y₁ y₂) (x : B₂). Definition left_biadj_preserves_bincoprod_nat_trans_data : nat_trans_data (left_biadj_preserves_binprods_1cell x p) (universal_coprod_functor (psfunctor_bincoprod_cocone L p) x). Proof. intro f. simple refine (_ ,, _) ; cbn ; cbn in f. - refine (((psfunctor_comp L _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (((psfunctor_comp L _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ psnaturality_of (biadj_counit R) f^-1) • lassociator _ _ _ • ((linvunitor _ • _) ▹ _) • lunitor _))). exact ((_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _)))) • invertible_modcomponent_of (biadj_triangle_l R) p). - refine (((psfunctor_comp L _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ (((psfunctor_comp L _ _)^-1 ▹ _) • rassociator _ _ _ • (_ ◃ psnaturality_of (biadj_counit R) f^-1) • lassociator _ _ _ • ((linvunitor _ • _) ▹ _) • lunitor _))). exact ((_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _)))) • invertible_modcomponent_of (biadj_triangle_l R) p). Defined. Opaque psfunctor_comp. Definition left_biadj_preserves_bincoprod_is_nat_trans : is_nat_trans _ _ left_biadj_preserves_bincoprod_nat_trans_data. Proof. intros f₁ f₂ α. use pathsdirprod. - simpl. refine (vassocr _ _ _ @ _ @ vassocr _ _ _). rewrite !vassocl. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite rwhisker_vcomp. etrans. { apply maponpaths. pose (maponpaths (λ z, (psfunctor_comp L _ _)^-1 • z • (psfunctor_comp L _ _)^-1) (psfunctor_lwhisker L (bincoprod_cocone_inl p) (biadj_unit R p ◃ ## R α))) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact q. } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply rwhisker_lwhisker_rassociator. } apply vassocl. } apply maponpaths. etrans. { apply maponpaths. refine (!_). apply lwhisker_vcomp. } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. pose (maponpaths (λ z, (psfunctor_comp _ _ _)^-1 • z • (psfunctor_comp _ _ _)^-1) (psfunctor_lwhisker L (biadj_unit R p) (##R α))) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact q. } exact (!(rwhisker_vcomp _ _ _)). } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (!_). apply rwhisker_lwhisker_rassociator. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. pose (maponpaths (λ z, (psnaturality_of (biadj_counit R) _)^-1 • z • (psnaturality_of (biadj_counit R) _)^-1) (psnaturality_natural (biadj_counit R) _ _ _ _ α)) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact (!q). } exact (!(lwhisker_vcomp _ _ _)). } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply lwhisker_lwhisker. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. rewrite lwhisker_vcomp. etrans. { apply maponpaths. refine (!_). apply vcomp_whisker. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _ @ !(lwhisker_vcomp _ _ _)). apply maponpaths. refine (!_). apply vcomp_lunitor. - simpl. refine (vassocr _ _ _ @ _ @ vassocr _ _ _). rewrite !vassocl. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite rwhisker_vcomp. etrans. { apply maponpaths. pose (maponpaths (λ z, (psfunctor_comp L _ _)^-1 • z • (psfunctor_comp L _ _)^-1) (psfunctor_lwhisker L (bincoprod_cocone_inr p) (biadj_unit R p ◃ ## R α))) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact q. } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply rwhisker_lwhisker_rassociator. } apply vassocl. } apply maponpaths. etrans. { apply maponpaths. refine (!_). apply lwhisker_vcomp. } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. pose (maponpaths (λ z, (psfunctor_comp _ _ _)^-1 • z • (psfunctor_comp _ _ _)^-1) (psfunctor_lwhisker L (biadj_unit R p) (##R α))) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact q. } exact (!(rwhisker_vcomp _ _ _)). } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (!_). apply rwhisker_lwhisker_rassociator. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. pose (maponpaths (λ z, (psnaturality_of (biadj_counit R) _)^-1 • z • (psnaturality_of (biadj_counit R) _)^-1) (psnaturality_natural (biadj_counit R) _ _ _ _ α)) as q. cbn in q. rewrite !vassocl in q. rewrite vcomp_rinv in q. rewrite id2_right in q. rewrite !vassocr in q. rewrite vcomp_linv in q. rewrite id2_left in q. exact (!q). } exact (!(lwhisker_vcomp _ _ _)). } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply lwhisker_lwhisker. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } etrans. { refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. rewrite lwhisker_vcomp. etrans. { apply maponpaths. refine (!_). apply vcomp_whisker. } exact (!(lwhisker_vcomp _ _ _)). } apply vassocl. } refine (!_). etrans. { apply maponpaths_2. exact (!(lwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _ @ !(lwhisker_vcomp _ _ _)). apply maponpaths. refine (!_). apply vcomp_lunitor. Qed. Transparent psfunctor_comp. Definition left_biadj_preserves_bincoprod_nat_trans : left_biadj_preserves_binprods_1cell x p ⟹ universal_coprod_functor (psfunctor_bincoprod_cocone L p) x. Proof. use make_nat_trans. - exact left_biadj_preserves_bincoprod_nat_trans_data. - exact left_biadj_preserves_bincoprod_is_nat_trans. Defined. Definition left_biadj_preserves_bincoprod_is_nat_z_iso : is_nat_z_iso left_biadj_preserves_bincoprod_nat_trans. Proof. intro. use is_z_iso_binprod_z_iso. + use is_inv2cell_to_is_z_iso. is_iso ; apply property_from_invertible_2cell. + use is_inv2cell_to_is_z_iso. is_iso ; apply property_from_invertible_2cell. Defined. Definition left_biadj_preserves_bincoprod_nat_z_iso : nat_z_iso (left_biadj_preserves_binprods_1cell x p) (universal_coprod_functor (psfunctor_bincoprod_cocone L p) x). Proof. use make_nat_z_iso. - exact left_biadj_preserves_bincoprod_nat_trans. - exact left_biadj_preserves_bincoprod_is_nat_z_iso. Defined. End PreserveCoproducts. Definition left_biadj_preserves_binprods (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂) : preserves_bincoprods L. Proof. intros y₁ y₂ p Hp. use universal_coprod_cocone_has_ump. intro x. use nat_iso_adj_equivalence_of_cats. - exact (left_biadj_preserves_binprods_1cell x p). - exact (left_biadj_preserves_bincoprod_nat_trans p x). - exact (left_biadj_preserves_bincoprod_is_nat_z_iso p x). - exact (left_biadj_preserves_binprods_1cell_adj_equiv HB₁ x p Hp). Defined. End BiadjunctionPreservation. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveEquifiers.v000066400000000000000000000320471451125700300331170ustar00rootroot00000000000000(****************************************************************** Preservation of equifiers by right biadjoints ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Subcategory.FullEquivalences. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Limits.Equifiers. Local Open Scope cat. Section BiadjunctionPreservation. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Section PreserveEquifiers. Context {y₁ y₂ : B₂} {f g : y₁ --> y₂} {α β : f ==> g} {e : equifier_cone f g α β} (He : has_equifier_ump e). Definition preserve_equifiers_R_path {x : B₁} (h : L x --> y₁) (p : h ◃ α = h ◃ β) : biadj_unit R x · # R h ◃ ## R α = biadj_unit R x · # R h ◃ ## R β. Proof. pose (maponpaths (λ z, psfunctor_comp _ _ _ • ##R z) p) as q. cbn -[psfunctor_comp] in q. rewrite !psfunctor_lwhisker in q. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !lwhisker_lwhisker. apply maponpaths_2. apply maponpaths. use (vcomp_rcancel (psfunctor_comp R h g)). { apply property_from_invertible_2cell. } exact q. Qed. Definition right_biadj_preserves_equifiers_nat_trans_cell {x : B₁} (h : x --> R e) : biadj_unit R x · # R (# L h · biadj_counit R e · equifier_cone_pr1 e) ==> h · # R (equifier_cone_pr1 e) := (_ ◃ ((psfunctor_comp R _ _)^-1 • ((psfunctor_comp R _ _)^-1 ▹ _))) • lassociator _ _ _ • (lassociator _ _ _ ▹ _) • (((psnaturality_of (biadj_unit R) h) ▹ _) ▹ _) • rassociator _ _ _ • rassociator _ _ _ • (_ ◃ (lassociator _ _ _ • ((linvunitor _ • (_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _)))) • invertible_modcomponent_of (biadj_triangle_r R) e) ▹ _) • lunitor _)). Definition right_biadj_preserves_equifiers_commute_data (x : B₁) : nat_trans_data (biadj_left_hom R x e ∙ to_universal_equifier_cat e (L x) ∙ full_sub_category_functor (λ (h : hom (L x) y₁), make_hProp (h ◃ α = h ◃ β) (cellset_property _ _ _ _)) (λ (h : hom x (R y₁)), make_hProp (h ◃ ## R α = h ◃ ## R β) (cellset_property _ _ _ _)) (biadj_right_hom R x y₁) preserve_equifiers_R_path) (to_universal_equifier_cat (psfunctor_equifier_cone R e) x) := λ h, right_biadj_preserves_equifiers_nat_trans_cell h ,, tt. Definition right_biadj_preserves_equifiers_commute_is_nat_trans (x : B₁) : is_nat_trans _ _ (right_biadj_preserves_equifiers_commute_data x). Proof. intros h₁ h₂ ζ. use subtypePath. { intro. apply isapropunit. } cbn. unfold right_biadj_preserves_equifiers_nat_trans_cell. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite lwhisker_vcomp. etrans. { apply maponpaths. assert (## R ((## L ζ ▹ biadj_counit R e) ▹ equifier_cone_pr1 e) • (psfunctor_comp R _ _)^-1 = (psfunctor_comp R _ _)^-1 • (## R (## L ζ ▹ biadj_counit R e) ▹ # R (equifier_cone_pr1 e))) as H. { use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (psfunctor_rwhisker R (equifier_cone_pr1 e) (## L ζ ▹ biadj_counit R e)). } exact H. } rewrite <- lwhisker_vcomp. apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. etrans. { do 2 apply maponpaths. assert (## R (## L ζ ▹ biadj_counit R e) • ( psfunctor_comp R _ _)^-1 = (psfunctor_comp R _ _)^-1 • (## R (## L ζ) ▹ # R (biadj_counit R e))) as H. { use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (psfunctor_rwhisker R (biadj_counit R e) (##L ζ)). } exact H. } rewrite <- rwhisker_vcomp. rewrite <- lwhisker_vcomp. apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_lwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply rwhisker_lwhisker. } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. exact (psnaturality_natural (biadj_unit R) _ _ _ _ ζ). } cbn. exact (!(rwhisker_vcomp _ _ _)). } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_rwhisker_alt. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_rwhisker_alt. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. apply vcomp_whisker. Qed. Definition right_biadj_preserves_equifiers_commute (x : B₁) : biadj_left_hom R x e ∙ to_universal_equifier_cat e (L x) ∙ full_sub_category_functor (λ (h : hom (L x) y₁), make_hProp (h ◃ α = h ◃ β) (cellset_property _ _ _ _)) (λ (h : hom x (R y₁)), make_hProp (h ◃ ## R α = h ◃ ## R β) (cellset_property _ _ _ _)) (biadj_right_hom R x y₁) preserve_equifiers_R_path ⟹ to_universal_equifier_cat (psfunctor_equifier_cone R e) x. Proof. use make_nat_trans. - exact (right_biadj_preserves_equifiers_commute_data x). - exact (right_biadj_preserves_equifiers_commute_is_nat_trans x). Defined. Definition right_biadj_preserves_equifiers_commute_is_nat_z_iso (x : B₁) : is_nat_z_iso (right_biadj_preserves_equifiers_commute x). Proof. intro h. use is_iso_full_sub. use is_inv2cell_to_is_z_iso. cbn. unfold right_biadj_preserves_equifiers_nat_trans_cell. is_iso. - apply property_from_invertible_2cell. - apply property_from_invertible_2cell. Defined. Definition preserve_equifiers_L_path {x : B₁} (h : x --> R y₁) (p : h ◃ ## R α = h ◃ ## R β) : # L h · biadj_counit R y₁ ◃ α = # L h · biadj_counit R y₁ ◃ β. Proof. pose (maponpaths (λ z, psfunctor_comp _ _ _ • ##L z • (psfunctor_comp _ _ _)^-1) p) as q. cbn -[psfunctor_comp] in q. rewrite !psfunctor_lwhisker in q. rewrite !vassocl in q. rewrite !vcomp_rinv in q. rewrite !id2_right in q. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite <- !lwhisker_lwhisker. apply maponpaths_2. use (vcomp_rcancel (_ ◃ psnaturality_of (biadj_counit R) g)). { is_iso. apply property_from_invertible_2cell. } rewrite !lwhisker_vcomp. etrans. { apply maponpaths. exact (psnaturality_natural (biadj_counit R) _ _ _ _ α). } refine (!_). etrans. { apply maponpaths. exact (psnaturality_natural (biadj_counit R) _ _ _ _ β). } refine (!_). cbn. rewrite <- !lwhisker_vcomp. apply maponpaths. use (vcomp_rcancel (lassociator _ _ _)). { is_iso. } rewrite !rwhisker_lwhisker. do 2 apply maponpaths. exact q. Qed. End PreserveEquifiers. Definition right_biadj_preserves_equifiers (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂) : preserves_equifiers R. Proof. intros y₁ y₂ f g α β e He. use universal_equifier_cone_has_ump. intro x. use nat_iso_adj_equivalence_of_cats. - exact (biadj_left_hom R x e ∙ to_universal_equifier_cat e (L x) ∙ full_sub_category_functor (λ (h : hom (L x) y₁), make_hProp (h ◃ α = h ◃ β) (cellset_property _ _ _ _)) (λ (h : hom x (R y₁)), make_hProp (h ◃ ## R α = h ◃ ## R β) (cellset_property _ _ _ _)) (biadj_right_hom R x y₁) preserve_equifiers_R_path). - exact (right_biadj_preserves_equifiers_commute x). - exact (right_biadj_preserves_equifiers_commute_is_nat_z_iso x). - use comp_adj_equivalence_of_cats. + use comp_adj_equivalence_of_cats. * exact (biadj_hom_equiv R x e). * apply (make_is_universal_equifier_cone HB₂ _ He). + use full_sub_category_adj_equivalence. * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)). * exact preserve_equifiers_L_path. Defined. End BiadjunctionPreservation. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveInserters.v000066400000000000000000001157721451125700300331500ustar00rootroot00000000000000(****************************************************************** Preservation of inserters by right biadjoints ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Limits.Inserters. Local Open Scope cat. Section BiadjunctionPreservation. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Section PreserveInsertersCommute. Context {y₁ y₂ : B₂} (f : y₁ --> y₂) (x : B₁). Definition inserter_commute_nat_trans_data : nat_trans_data (biadj_right_hom R x y₁ ∙ post_comp x (# R f)) (post_comp (L x) f ∙ biadj_right_hom R x y₂) := λ h, rassociator _ _ _ • (_ ◃ psfunctor_comp R _ _). Definition inserter_commute_is_nat_trans : is_nat_trans _ _ inserter_commute_nat_trans_data. Proof. intros h₁ h₂ α ; cbn. unfold inserter_commute_nat_trans_data. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. refine (!_). apply psfunctor_rwhisker. Qed. Definition inserter_commute_nat_trans : biadj_right_hom R x y₁ ∙ post_comp x (# R f) ⟹ post_comp (L x) f ∙ biadj_right_hom R x y₂. Proof. use make_nat_trans. - exact inserter_commute_nat_trans_data. - exact inserter_commute_is_nat_trans. Defined. Definition inserter_commute_nat_z_iso : nat_z_iso (biadj_right_hom R x y₁ ∙ post_comp x (# R f)) (post_comp (L x) f ∙ biadj_right_hom R x y₂). Proof. use make_nat_z_iso. - exact inserter_commute_nat_trans. - intro h. apply is_inv2cell_to_is_z_iso. cbn ; unfold inserter_commute_nat_trans_data. is_iso. apply property_from_invertible_2cell. Defined. End PreserveInsertersCommute. Section PreserveInserterNatIso. Context {y₁ y₂ : B₂} {f g : y₁ --> y₂} (i : inserter_cone f g) (x : B₁). Definition right_biadj_preserves_inserters_nat_trans_cell (h : x --> R i) : biadj_unit R x · # R (# L h · biadj_counit R i · inserter_cone_pr1 i) ==> h · # R (inserter_cone_pr1 i) := (_ ◃ ((psfunctor_comp R _ _)^-1 • ((psfunctor_comp R _ _)^-1 ▹ _))) • lassociator _ _ _ • (lassociator _ _ _ ▹ _) • (((psnaturality_of (biadj_unit R) h) ▹ _) ▹ _) • rassociator _ _ _ • rassociator _ _ _ • (_ ◃ (lassociator _ _ _ • ((linvunitor _ • (_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _)))) • invertible_modcomponent_of (biadj_triangle_r R) i) ▹ _) • lunitor _)). Opaque psfunctor_comp. Local Notation "'lα'" := (lassociator _ _ _). Local Notation "'rα'" := (rassociator _ _ _). Local Notation "'lu'" := (lunitor _). Local Notation "'lui'" := (linvunitor _). Local Notation "'ru'" := (runitor _). Local Notation "'rui'" := (rinvunitor _). Definition right_biadj_preserves_inserters_nat_trans_path (h : x --> R i) : @dialgebra_mor_path _ _ _ _ ((biadj_left_hom R x i ∙ inserter_cone_functor i (L x) ∙ dialgebra_equivalence_of_cats_functor (inserter_commute_nat_z_iso f x) (inserter_commute_nat_z_iso g x)) h) (inserter_cone_functor (psfunctor_inserter_cone R i) x h) (right_biadj_preserves_inserters_nat_trans_cell h). Proof. unfold dialgebra_mor_path. cbn. unfold inserter_commute_nat_trans_data. unfold right_biadj_preserves_inserters_nat_trans_cell. rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. do 3 refine (vassocl _ _ _ @ _). etrans. { do 3 apply maponpaths. refine (vassocl _ _ _ @ _). do 2 apply maponpaths. do 6 refine (vassocl _ _ _ @ _). do 7 apply maponpaths. refine (vassocl _ _ _ @ _). apply maponpaths. apply maponpaths_2. do 2 apply maponpaths. refine (vassocl _ _ _ @ _). apply maponpaths. apply vassocl. } etrans. { do 2 apply maponpaths. apply maponpaths_2. do 2 apply maponpaths. apply vassocl. } do 7 refine (_ @ vassocr _ _ _). refine (!_). etrans. { do 7 apply maponpaths. do 2 refine (vassocl _ _ _ @ _). do 3 apply maponpaths. refine (vassocl _ _ _ @ _). apply maponpaths. do 2 refine (vassocl _ _ _ @ _). apply idpath. } etrans. { do 8 apply maponpaths. apply maponpaths_2. do 2 apply maponpaths. refine (vassocl _ _ _ @ _) ; apply maponpaths. apply vassocl. } refine (!_). use vcomp_move_R_pM ; [ is_iso | ]. refine (!_). etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (!_). apply rwhisker_lwhisker. } refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (!_). apply rwhisker_lwhisker. } etrans. { apply maponpaths. apply vassocl. } use vcomp_move_R_pM ; [ is_iso | ]. use vcomp_move_R_pM ; [ is_iso | ]. refine (!_). etrans. { apply maponpaths_2. cbn. apply idpath. } etrans. { apply maponpaths ; apply maponpaths_2. cbn. apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. refine (vassocr _ _ _ @ _). apply maponpaths_2. etrans. { apply rwhisker_vcomp. } etrans. { apply maponpaths. apply rwhisker_rwhisker_alt. } exact (!(rwhisker_vcomp _ _ _)). } etrans. { do 3 apply maponpaths. refine (vassocl _ _ _ @ _). apply idpath. } refine (!_). etrans. { do 3 apply maponpaths. apply maponpaths_2. etrans. { apply maponpaths. apply psfunctor_vcomp. } exact (!(lwhisker_vcomp _ _ _)). } etrans. { do 3 refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocr _ _ _ @ _). apply maponpaths_2. etrans. { do 2 refine (vassocl _ _ _ @ _). apply maponpaths. refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _). refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). apply (psfunctor_rassociator R). } apply idpath. } refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_rwhisker_alt. } refine (vassocl _ _ _ @ _). apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. apply vassocl. } do 3 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths). apply idpath. } do 2 refine (vassocl _ _ _ @ _). use vcomp_move_R_pM ; [ is_iso | ]. refine (!_). etrans. { apply maponpaths_2. cbn. apply idpath. } etrans. { do 4 refine (vassocr _ _ _ @ _). apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply lassociator_lassociator. } do 2 refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_rwhisker. } refine (vassocl _ _ _ @ _). apply idpath. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply psfunctor_vcomp. } etrans. { do 3 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply rwhisker_lwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply rwhisker_lwhisker. } apply vassocl. } etrans. { do 5 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply pentagon_6. } do 2 refine (vassocl _ _ _ @ _). do 2 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_rwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_rwhisker. } refine (vassocl _ _ _ @ _). apply idpath. } etrans. { apply maponpaths. etrans. { do 4 refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (maponpaths (λ z, ((z • _) • _) • _) (lwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (lwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _). refine (lwhisker_vcomp _ _ _ @ _). apply maponpaths. do 4 refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 3 apply maponpaths. apply rwhisker_rwhisker_alt. } do 3 refine (vassocr _ _ _ @ _). apply maponpaths_2. apply psfunctor_lassociator_alt'. } apply maponpaths_2. do 2 apply maponpaths. apply vassocl. } etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (maponpaths (λ z, (_ • z) • _) (lwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _). refine (lwhisker_vcomp _ _ _ @ _). apply maponpaths. refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _). etrans. { do 2 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply psfunctor_lwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply vcomp_rinv. } apply id2_left. } etrans. { refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _). refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (rwhisker_vcomp _ _ _ @ _). refine (maponpaths (λ z, z ▹ _) (vcomp_rinv _) @ _). apply id2_rwhisker. } apply id2_right. } refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _). apply lwhisker_vcomp. } etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lwhisker_lwhisker. } refine (vassocl _ _ _ @ _ @ vassocr _ _ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. exact (!(vcomp_whisker _ _)). } refine (vassocl _ _ _ @ _). refine (_ @ vassocr _ _ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (!_). apply vcomp_whisker. } refine (vassocl _ _ _ @ _). refine (!_). etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, _ • (z ▹ _)) (!(rwhisker_rwhisker_alt _ _ _)) @ _). refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _). refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). apply vassocl. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. apply inverse_pentagon_7. } do 2 refine (vassocl _ _ _ @ _). use vcomp_move_R_pM ; [ is_iso | ]. refine (!_). etrans. { apply maponpaths_2. cbn. apply idpath. } etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. exact (!(lwhisker_lwhisker _ _ _)). } refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. exact (!(lassociator_lassociator _ _ _ _)). } do 2 refine (vassocl _ _ _ @ _). do 2 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). refine (maponpaths (λ z, z ▹ _) (lassociator_rassociator _ _ _) @ _). apply id2_rwhisker. } apply id2_left. } etrans. { do 3 apply maponpaths. refine (maponpaths (λ z, _ • (_ • z)) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). refine (rwhisker_vcomp _ _ _ @ _). etrans. { do 3 apply maponpaths. apply maponpaths_2. apply maponpaths. refine (maponpaths (λ z, _ • (_ • z)) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). apply rwhisker_vcomp. } do 2 apply maponpaths. refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _). apply lwhisker_vcomp. } refine (!_). etrans. { do 3 apply maponpaths. do 3 refine (vassocr _ _ _ @ _). etrans. { do 2 apply maponpaths_2. refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _). apply rwhisker_vcomp. } etrans. { do 2 apply maponpaths_2. apply maponpaths. refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _). apply lwhisker_vcomp. } etrans. { apply maponpaths_2. exact (!(rwhisker_lwhisker_rassociator _ _ _ _ _ _ _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. do 3 refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (maponpaths (λ z, (z • _) • _) (lwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _). apply lwhisker_vcomp. } apply maponpaths_2. apply maponpaths. do 2 refine (vassocl _ _ _ @ _). etrans. { apply maponpaths_2. refine (!(rwhisker_vcomp _ _ _) @ maponpaths (λ z, z • _) _). do 3 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(rwhisker_vcomp _ _ _)). } do 2 refine (vassocl _ _ _ @ _) ; apply maponpaths. do 2 (refine (vassocl _ _ _ @ _) ; apply maponpaths). apply vassocl. } refine (!_). etrans. { apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (maponpaths (λ z, z • _) (lwhisker_hcomp _ _) @ _). apply pentagon_2. } etrans. { apply maponpaths_2. do 2 apply maponpaths. exact (!(rwhisker_hcomp _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocl _ _ _ @ _). apply maponpaths. apply rwhisker_vcomp. } etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply lwhisker_lwhisker. } refine (vassocl _ _ _ @ _). use vcomp_move_R_pM ; [ is_iso | ]. refine (!_). etrans. { apply maponpaths_2. cbn. apply idpath. } do 2 refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. exact (!(inverse_pentagon_7 _ _ _ _)). } refine (vassocl _ _ _ @ _). refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths). etrans. { apply maponpaths. refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths. exact (!(rwhisker_vcomp _ _ _)). } etrans. { do 4 apply maponpaths. apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(rwhisker_vcomp _ _ _)). } do 2 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(lwhisker_vcomp _ _ _)). } do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(rwhisker_vcomp _ _ _)). } do 4 refine (vassocr _ _ _ @ _). apply maponpaths_2. do 3 refine (vassocr _ _ _ @ _). do 5 apply maponpaths_2. refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, _ • (z ▹ _)) (!(rassociator_rassociator _ _ _ _)) @ _). etrans. { apply maponpaths. refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths_2. exact (!(rwhisker_vcomp _ _ _)). } refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (vassocr _ _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (rwhisker_rwhisker _ _ _) @ _). refine (vassocl _ _ _ @ _). cbn. apply idpath. } etrans. { etrans. { apply maponpaths. do 7 refine (vassocl _ _ _ @ _) ; do 2 apply maponpaths. apply vassocl. } refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. exact (!(vcomp_whisker _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). do 2 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply rassociator_lassociator. } apply lwhisker_id2. } apply id2_rwhisker. } apply id2_left. } etrans. { apply maponpaths. refine (vassocl _ _ _ @ _) ; do 2 apply maponpaths. refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). apply maponpaths. cbn. apply rwhisker_lwhisker_rassociator. } etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. apply maponpaths_2. exact (!(rwhisker_vcomp _ _ _)). } refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _). refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_rwhisker. } etrans. { apply maponpaths. refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _). refine (vassocr _ _ _ @ _). apply maponpaths_2. exact (!(vcomp_whisker _ _)). } refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _). etrans. { do 4 apply maponpaths. do 3 refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, ((z • _) • _) • _) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, (z • _) • _) (rwhisker_vcomp _ _ _) @ _). refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _). refine (rwhisker_vcomp _ _ _ @ _). apply maponpaths. etrans. { do 3 apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } do 3 refine (vassocl _ _ _ @ _). apply maponpaths. do 2 refine (vassocr _ _ _ @ _). etrans. { do 2 apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } do 2 refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } apply vassocl. } etrans. { do 3 apply maponpaths. etrans. { apply maponpaths. do 3 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(rwhisker_vcomp _ _ _)). } refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). apply vassocl. } etrans. { do 2 apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { do 3 apply maponpaths. refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). do 2 apply maponpaths. apply lunitor_lwhisker. } do 3 apply maponpaths. apply rwhisker_rwhisker. } do 6 refine (vassocr _ _ _ @ _). do 4 refine (_ @ vassocl _ _ _). apply maponpaths_2. do 5 refine (vassocl _ _ _ @ _). etrans. { do 3 apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _). refine (vassocl _ _ _ @ _). exact (maponpaths (λ z, _ • z) (!(vcomp_whisker _ _))). } refine (!_). etrans. { apply maponpaths. do 5 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths). exact (!(lwhisker_vcomp _ _ _)). } do 5 refine (_ @ vassocl _ _ _). do 6 refine (vassocr _ _ _ @ _). apply maponpaths_2. do 8 refine (vassocl _ _ _ @ _). do 4 refine (_ @ vassocr _ _ _). refine (!_). etrans. { do 4 apply maponpaths. apply rwhisker_vcomp. } refine (!_). etrans. { do 8 apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _). apply maponpaths. apply rwhisker_vcomp. } etrans. { do 3 apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply rwhisker_lwhisker_rassociator. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { apply rwhisker_lwhisker_rassociator. } etrans. { apply maponpaths_2. etrans. { apply maponpaths. exact (!(lwhisker_vcomp _ _ _)). } exact (!(rwhisker_vcomp _ _ _)). } apply vassocl. } do 8 refine (vassocr _ _ _ @ _). use vcomp_move_R_Mp ; [ is_iso | ]. do 7 refine (vassocl _ _ _ @ _). refine (!_). refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. do 2 (refine (vassocl _ _ _ @ _) ; apply maponpaths). apply vassocl. } etrans. { do 5 apply maponpaths. cbn. apply idpath. } etrans. { do 4 apply maponpaths. refine (maponpaths (λ z, z • _) (!(rwhisker_vcomp _ _ _)) @ _). refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (!(rwhisker_rwhisker _ _ _)) @ _). pose (maponpaths (λ z, rassociator _ _ _ • z) (runitor_rwhisker h (# R (inserter_cone_pr1 i)))) as p. cbn in p. rewrite !vassocr in p. rewrite rassociator_lassociator, id2_left in p. etrans. { do 3 apply maponpaths. exact p. } refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (!(rwhisker_rwhisker _ _ _)) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _). refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _). etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply rwhisker_lwhisker_rassociator. } exact (maponpaths (λ z, z • _) (!(rwhisker_vcomp _ _ _))). } do 5 refine (vassocr _ _ _ @ _). do 7 refine (_ @ vassocl _ _ _). apply maponpaths_2. refine (vassocr _ _ _ @ _). apply maponpaths_2. do 4 refine (vassocl _ _ _ @ _). do 5 refine (_ @ vassocr _ _ _). cbn. refine (!_). etrans. { apply maponpaths. do 2 refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _). refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (maponpaths (λ z, z • _) (!(rassociator_rassociator _ _ _ _)) @ _). refine (vassocl _ _ _ @ _). etrans. { apply maponpaths. refine (lwhisker_vcomp _ _ _ @ _). refine (maponpaths (λ z, _ ◃ z) (rassociator_lassociator _ _ _) @ _). apply lwhisker_id2. } apply id2_right. } exact (!(rwhisker_vcomp _ _ _)). } etrans. { refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _). refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). refine (vassocl _ _ _ @ _). apply idpath. } apply maponpaths. etrans. { do 2 refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). etrans. { do 2 apply maponpaths. apply rwhisker_lwhisker_rassociator. } refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _). refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). apply vassocl. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (vassocl _ _ _ @ _). etrans. { do 2 refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (vassocl _ _ _ @ _). refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _). etrans. { do 2 apply maponpaths. apply rwhisker_lwhisker_rassociator. } refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _). refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _). apply vassocl. } refine (vassocl _ _ _ @ _). apply maponpaths. refine (!_). etrans. { refine (vassocr _ _ _ @ _). refine (maponpaths (λ z, z • _) (!(rwhisker_rwhisker _ _ _)) @ _). refine (vassocl _ _ _ @ _). apply maponpaths. refine (rwhisker_vcomp _ _ _ @ !_). apply maponpaths. apply rwhisker_lwhisker_rassociator. } refine (_ @ vassocr _ _ _). apply maponpaths. refine (!_). apply rwhisker_vcomp. Qed. Transparent psfunctor_comp. Definition right_biadj_preserves_inserters_nat_trans_data : nat_trans_data (biadj_left_hom R x i ∙ inserter_cone_functor i (L x) ∙ dialgebra_equivalence_of_cats_functor (inserter_commute_nat_z_iso f x) (inserter_commute_nat_z_iso g x)) (inserter_cone_functor (psfunctor_inserter_cone R i) x). Proof. intro h. use make_dialgebra_mor. - exact (right_biadj_preserves_inserters_nat_trans_cell h). - exact (right_biadj_preserves_inserters_nat_trans_path h). Defined. Definition right_biadj_preserves_inserters_is_nat_trans : is_nat_trans _ _ right_biadj_preserves_inserters_nat_trans_data. Proof. intros h₁ h₂ α. use eq_dialgebra. cbn. unfold right_biadj_preserves_inserters_nat_trans_cell. rewrite <- !rwhisker_vcomp. rewrite <- !lwhisker_vcomp. rewrite !vassocl. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite lwhisker_vcomp. etrans. { apply maponpaths. assert (## R ((## L α ▹ biadj_counit R i) ▹ inserter_cone_pr1 i) • (psfunctor_comp R _ _)^-1 = (psfunctor_comp R _ _)^-1 • (## R (## L α ▹ biadj_counit R i) ▹ # R (inserter_cone_pr1 i))) as H. { use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (psfunctor_rwhisker R (inserter_cone_pr1 i) (## L α ▹ biadj_counit R i)). } exact H. } rewrite <- lwhisker_vcomp. apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite lwhisker_vcomp. rewrite rwhisker_vcomp. etrans. { do 2 apply maponpaths. assert (## R (## L α ▹ biadj_counit R i) • ( psfunctor_comp R _ _)^-1 = (psfunctor_comp R _ _)^-1 • (## R (## L α) ▹ # R (biadj_counit R i))) as H. { use vcomp_move_R_Mp ; [ is_iso | ]. rewrite !vassocl. use vcomp_move_L_pM ; [ is_iso | ]. exact (psfunctor_rwhisker R (biadj_counit R i) (##L α)). } exact H. } rewrite <- rwhisker_vcomp. rewrite <- lwhisker_vcomp. apply idpath. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_lwhisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. apply rwhisker_lwhisker. } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. refine (rwhisker_vcomp _ _ _ @ _). etrans. { apply maponpaths. exact (psnaturality_natural (biadj_unit R) _ _ _ _ α). } cbn. exact (!(rwhisker_vcomp _ _ _)). } exact (!(rwhisker_vcomp _ _ _)). } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_rwhisker_alt. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply rwhisker_rwhisker_alt. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. apply vcomp_whisker. } refine (vassocl _ _ _ @ _). apply maponpaths. apply vcomp_whisker. Qed. Definition right_biadj_preserves_inserters_nat_trans : biadj_left_hom R x i ∙ inserter_cone_functor i (L x) ∙ dialgebra_equivalence_of_cats_functor (inserter_commute_nat_z_iso f x) (inserter_commute_nat_z_iso g x) ⟹ inserter_cone_functor (psfunctor_inserter_cone R i) x. Proof. use make_nat_trans. - exact right_biadj_preserves_inserters_nat_trans_data. - exact right_biadj_preserves_inserters_is_nat_trans. Defined. Definition right_biadj_preserves_inserters_is_nat_z_iso : is_nat_z_iso right_biadj_preserves_inserters_nat_trans. Proof. intro h. use is_z_iso_dialgebra. use is_inv2cell_to_is_z_iso. cbn ; unfold right_biadj_preserves_inserters_nat_trans_cell. is_iso. - apply property_from_invertible_2cell. - apply property_from_invertible_2cell. Defined. End PreserveInserterNatIso. Definition right_biadj_preserves_inserters (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂) : preserves_inserters R. Proof. intros y₁ y₂ f g i Hi. use universal_inserter_cone_has_ump. intro x. use nat_iso_adj_equivalence_of_cats. - refine (biadj_left_hom R x i ∙ inserter_cone_functor i (L x) ∙ _). use dialgebra_equivalence_of_cats_functor. + exact (biadj_right_hom R x y₁). + exact (biadj_right_hom R x y₂). + exact (inserter_commute_nat_z_iso f x). + exact (inserter_commute_nat_z_iso g x). - exact (right_biadj_preserves_inserters_nat_trans i x). - exact (right_biadj_preserves_inserters_is_nat_z_iso i x). - use comp_adj_equivalence_of_cats. + use comp_adj_equivalence_of_cats. * exact (biadj_hom_equiv R x i). * apply (make_is_universal_inserter_cone HB₂ _ Hi). + use dialgebra_adj_equivalence_of_cats. * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)). * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₂)). Defined. End BiadjunctionPreservation. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveProducts.v000066400000000000000000000272511451125700300327670ustar00rootroot00000000000000(****************************************************************** Preservation of products by right biadjoints ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.Properties. Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Limits.Products. Local Open Scope cat. Section BiadjunctionPreservation. Context {B₁ B₂ : bicat} {L : psfunctor B₁ B₂} (R : left_biadj_data L). Section PreserveProducts. Context (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂) {y₁ y₂ : B₂} (p : binprod_cone y₁ y₂) (Hp : has_binprod_ump p) (x : B₁). Definition right_biadj_preserves_binprod_1cell : bicat_of_univ_cats ⟦ univ_hom HB₁ x (psfunctor_binprod_cone R p) , univalent_category_binproduct (univ_hom HB₁ x (R y₁)) (univ_hom HB₁ x (R y₂)) ⟧ := biadj_left_hom R x p ∙ postcomp_binprod_cone HB₂ p (L x) ∙ pair_functor (biadj_right_hom R x y₁) (biadj_right_hom R x y₂). Definition left_adj_equiv_right_biadj_preserves_binprod_1cell : left_adjoint_equivalence right_biadj_preserves_binprod_1cell. Proof. use comp_left_adjoint_equivalence. - use (@comp_left_adjoint_equivalence bicat_of_univ_cats (univ_hom _ _ _) (univ_hom _ _ _) (univalent_category_binproduct (univ_hom _ _ _) (univ_hom _ _ _))). + apply equiv_cat_to_adj_equiv. exact (biadj_hom_equiv R x p). + apply (has_binprod_ump_binprod_cat_ump _ _ Hp). - use equiv_cat_to_adj_equiv. use pair_adj_equivalence_of_cats. + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)). + exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₂)). Defined. Definition right_biadj_preserves_binprod_nat_trans_data : nat_trans_data (postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x) (pr1 right_biadj_preserves_binprod_1cell). Proof. intro f. simple refine (_ ,, _) ; cbn ; cbn in f. - refine ((_ ◃ (linvunitor _ • (_ ▹ _) • rassociator _ _ _)) • lassociator _ _ _ • lassociator _ _ _ • (((psnaturality_of (biadj_unit R) f)^-1 ▹ _) ▹ _) • (rassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ (psfunctor_comp R _ _ ▹ _)) • (_ ◃ psfunctor_comp R _ _)). exact ((invertible_modcomponent_of (biadj_triangle_r R) p)^-1 • lunitor _ • (_ ◃ (lunitor _ • runitor _))). - refine ((_ ◃ (linvunitor _ • (_ ▹ _) • rassociator _ _ _)) • lassociator _ _ _ • lassociator _ _ _ • (((psnaturality_of (biadj_unit R) f)^-1 ▹ _) ▹ _) • (rassociator _ _ _ ▹ _) • rassociator _ _ _ • (_ ◃ (psfunctor_comp R _ _ ▹ _)) • (_ ◃ psfunctor_comp R _ _)). exact ((invertible_modcomponent_of (biadj_triangle_r R) p)^-1 • lunitor _ • (_ ◃ (lunitor _ • runitor _))). Defined. Opaque psfunctor_comp. Definition right_biadj_preserves_binprod_is_nat_trans : is_nat_trans _ _ right_biadj_preserves_binprod_nat_trans_data. Proof. intros f₁ f₂ α. use pathsdirprod. - simpl. refine (vassocr _ _ _ @ _ @ vassocr _ _ _). etrans. { rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. etrans. { do 2 apply maponpaths_2. apply maponpaths. do 2 apply maponpaths_2. apply maponpaths. refine (!_). exact (psnaturality_inv_natural (biadj_unit R) _ _ _ _ α). } rewrite <- !rwhisker_vcomp. rewrite !vassocl. cbn. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- rwhisker_lwhisker_rassociator. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite <- !rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite !vassocr. rewrite !rwhisker_vcomp. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply psfunctor_rwhisker. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. refine (!_). apply psfunctor_rwhisker. - simpl. refine (vassocr _ _ _ @ _ @ vassocr _ _ _). etrans. { rewrite !vassocr. rewrite vcomp_whisker. apply idpath. } rewrite !vassocl. apply maponpaths. etrans. { rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_rwhisker. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply idpath. } refine (!_). etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. apply idpath. } refine (!_). etrans. { rewrite !vassocr. rewrite !rwhisker_vcomp. etrans. { do 2 apply maponpaths_2. apply maponpaths. do 2 apply maponpaths_2. apply maponpaths. refine (!_). exact (psnaturality_inv_natural (biadj_unit R) _ _ _ _ α). } rewrite <- !rwhisker_vcomp. rewrite !vassocl. cbn. apply idpath. } apply maponpaths. etrans. { rewrite !vassocr. rewrite rwhisker_vcomp. rewrite <- rwhisker_lwhisker_rassociator. rewrite <- rwhisker_vcomp. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. apply idpath. } rewrite !vassocr. rewrite <- !rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !lwhisker_vcomp. apply maponpaths. rewrite !vassocr. rewrite !rwhisker_vcomp. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply psfunctor_rwhisker. } rewrite <- !rwhisker_vcomp. rewrite !vassocl. apply maponpaths. refine (!_). apply psfunctor_rwhisker. Qed. Transparent psfunctor_comp. Definition right_biadj_preserves_binprod_nat_trans : postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x ⟹ pr1 right_biadj_preserves_binprod_1cell. Proof. use make_nat_trans. - exact right_biadj_preserves_binprod_nat_trans_data. - exact right_biadj_preserves_binprod_is_nat_trans. Defined. Definition right_biadj_preserves_binprod_is_nat_z_iso : is_nat_z_iso right_biadj_preserves_binprod_nat_trans. Proof. intro. use is_z_iso_binprod_z_iso. + use is_inv2cell_to_is_z_iso. is_iso ; apply property_from_invertible_2cell. + use is_inv2cell_to_is_z_iso. is_iso ; apply property_from_invertible_2cell. Defined. Definition right_biadj_preserves_binprod_nat_z_iso : nat_z_iso (postcomp_binprod_cone HB₁ (psfunctor_binprod_cone R p) x) right_biadj_preserves_binprod_1cell. Proof. use make_nat_z_iso. - exact right_biadj_preserves_binprod_nat_trans. - exact right_biadj_preserves_binprod_is_nat_z_iso. Defined. End PreserveProducts. Definition right_biadj_preserves_binprods (HB₁ : is_univalent_2_1 B₁) (HB₂ : is_univalent_2_1 B₂) : preserves_binprods R. Proof. intros y₁ y₂ p Hp. use (has_binprod_cat_ump_binprod_ump HB₁). intro x. use left_adjoint_equivalence_invertible. - exact (right_biadj_preserves_binprod_1cell HB₁ HB₂ p x). - apply left_adj_equiv_right_biadj_preserves_binprod_1cell. exact Hp. - apply right_biadj_preserves_binprod_nat_trans. - use is_nat_z_iso_to_is_invertible_2cell. apply right_biadj_preserves_binprod_is_nat_z_iso. Defined. End BiadjunctionPreservation. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/ClosedUnderEquivalence.v000066400000000000000000000123471451125700300315070ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.ProductEquivalences. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.InserterEquivalences. Require Import UniMath.Bicategories.Limits.Equifiers. Require Import UniMath.Bicategories.Limits.EquifierEquivalences. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Require Import UniMath.Bicategories.Colimits.CoproductEquivalences. Local Open Scope cat. Section PreservationClosedUnderEquivalence. Context {B₁ B₂ : bicat} {F G : psfunctor B₁ B₂} (η : pstrans F G) (Hη : ∏ (x : B₁), left_adjoint_equivalence (η x)). Definition preserves_bifinal_left_adjoint_equivalence (HF : preserves_bifinal F) : preserves_bifinal G. Proof. intros x Hx. exact (is_bifinal_left_adjoint_equivalence _ (Hη x) (HF _ Hx)). Defined. Definition preserves_biinitial_left_adjoint_equivalence (HF : preserves_biinitial F) : preserves_biinitial G. Proof. intros x Hx. exact (equiv_from_biinitial (HF _ Hx) (Hη x)). Defined. Definition preserves_binprods_left_adjoint_equivalence (HF : preserves_binprods F) : preserves_binprods G. Proof. intros x y p Hp. exact (has_binprod_ump_left_adjoint_equivalence _ _ (HF _ _ _ Hp) _ _ _ _ _ (Hη x) (Hη y) (Hη p) (psnaturality_of η (binprod_cone_pr1 p)) (psnaturality_of η (binprod_cone_pr2 p))). Defined. Definition preserves_bincoprods_left_adjoint_equivalence (HF : preserves_bincoprods F) : preserves_bincoprods G. Proof. intros x y p Hp. exact (has_bincoprod_ump_left_adjoint_equivalence _ _ (HF _ _ _ Hp) _ _ _ _ _ (Hη x) (Hη y) (Hη p) (psnaturality_of η (bincoprod_cocone_inl p)) (psnaturality_of η (bincoprod_cocone_inr p))). Defined. Definition preserves_inserters_left_adjoint_equivalence (HF : preserves_inserters F) : preserves_inserters G. Proof. intros x y f g p Hp. use (has_inserter_ump_left_adjoint_equivalence _ _ _ (Hη x) (Hη y) (Hη p) (psnaturality_of η (inserter_cone_pr1 p)) (psnaturality_of η f) (psnaturality_of η g) (HF _ _ _ _ _ Hp)). abstract (pose (psnaturality_natural η _ _ _ _ (inserter_cone_cell p)) as q ; cbn in q ; rewrite (pstrans_comp_alt η (inserter_cone_pr1 p) g) in q ; rewrite (pstrans_comp_alt η (inserter_cone_pr1 p) f) in q ; rewrite !vassocl in q ; rewrite <- !lwhisker_vcomp ; rewrite <- !rwhisker_vcomp ; rewrite !vassocr ; use vcomp_move_L_Mp ; [ is_iso | ] ; cbn -[psfunctor_comp] ; rewrite !vassocl ; rewrite q ; rewrite !vassocr ; do 6 apply maponpaths_2 ; rewrite !lwhisker_vcomp ; rewrite vcomp_rinv ; rewrite lwhisker_id2 ; apply id2_left). Defined. Definition preserves_equifiers_left_adjoint_equivalence (HF : preserves_equifiers F) : preserves_equifiers G. Proof. intros x y f g α β p Hp. exact (has_equifier_ump_left_adjoint_equivalence _ _ _ _ _ (Hη x) (Hη y) (Hη p) (psnaturality_of η (equifier_cone_pr1 p)) (psnaturality_of η f) (psnaturality_of η g) (HF _ _ _ _ _ _ _ Hp) (psnaturality_natural η _ _ _ _ α) (psnaturality_natural η _ _ _ _ β)). Defined. End PreservationClosedUnderEquivalence. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/Preservation.v000066400000000000000000000160351451125700300275750ustar00rootroot00000000000000(*********************************************************************** Preservation of limits and colimits In this file, we look at the preservation of some limits and colimits. Our main focus is on final and initial objects and on products and coproducts. Contents: 1. Basic definitions 2. The identity pseudofunctor preserves (co)limits 3. Preservation of the composition 4. Preservation of chosen (co)limits ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Require Import UniMath.Bicategories.Limits.Inserters. Require Import UniMath.Bicategories.Limits.Equifiers. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Coproducts. Local Open Scope cat. (** 1. Basic definitions *) Section Preserves. Context {B₁ B₂ : bicat} (F : psfunctor B₁ B₂). Definition preserves_bifinal : UU := ∏ (x : B₁), is_bifinal x → is_bifinal (F x). Definition preserves_biinitial : UU := ∏ (x : B₁), is_biinitial x → is_biinitial (F x). Definition psfunctor_binprod_cone {x y : B₁} (p : binprod_cone x y) : binprod_cone (F x) (F y) := make_binprod_cone (F p) (#F (binprod_cone_pr1 p)) (#F (binprod_cone_pr2 p)). Definition preserves_binprods : UU := ∏ (x y : B₁) (p : binprod_cone x y), has_binprod_ump p → has_binprod_ump (psfunctor_binprod_cone p). Definition psfunctor_bincoprod_cocone {x y : B₁} (p : bincoprod_cocone x y) : bincoprod_cocone (F x) (F y) := make_bincoprod_cocone (F p) (#F (bincoprod_cocone_inl p)) (#F (bincoprod_cocone_inr p)). Definition preserves_bincoprods : UU := ∏ (x y : B₁) (p : bincoprod_cocone x y), has_bincoprod_ump p → has_bincoprod_ump (psfunctor_bincoprod_cocone p). Definition psfunctor_inserter_cone {x y : B₁} {f g : x --> y} (p : inserter_cone f g) : inserter_cone (#F f) (#F g) := make_inserter_cone (F p) (#F (inserter_cone_pr1 p)) (psfunctor_comp F (inserter_cone_pr1 p) f • ##F (inserter_cone_cell p) • (psfunctor_comp F (inserter_cone_pr1 p) g)^-1). Definition preserves_inserters : UU := ∏ (x y : B₁) (f g : x --> y) (p : inserter_cone f g), has_inserter_ump p → has_inserter_ump (psfunctor_inserter_cone p). Definition psfunctor_equifier_cone {x y : B₁} {f g : x --> y} {α β : f ==> g} (p : equifier_cone f g α β) : equifier_cone (#F f) (#F g) (##F α) (##F β). Proof. refine (make_equifier_cone (F p) (#F (equifier_cone_pr1 p)) _). abstract (pose (maponpaths (λ z, psfunctor_comp F (equifier_cone_pr1 p) f • ##F z • (psfunctor_comp F (equifier_cone_pr1 p) g)^-1) (equifier_cone_eq p)) as q ; cbn -[psfunctor_comp] in q ; rewrite !psfunctor_lwhisker in q ; rewrite !vassocl in q ; rewrite !vcomp_rinv in q ; rewrite !id2_right in q ; exact q). Defined. Definition preserves_equifiers : UU := ∏ (x y : B₁) (f g : x --> y) (α β : f ==> g) (p : equifier_cone f g α β), has_equifier_ump p → has_equifier_ump (psfunctor_equifier_cone p). End Preserves. (** 2. The identity pseudofunctor preserves (co)limits *) Definition identity_preserves_bifinal (B : bicat) : preserves_bifinal (id_psfunctor B) := λ x Hx, Hx. Definition identity_preserves_biinitial (B : bicat) : preserves_biinitial (id_psfunctor B) := λ x Hx, Hx. Definition identity_preserves_binprods (B : bicat) : preserves_binprods (id_psfunctor B) := λ x y p Hp, Hp. Definition identity_preserves_bincoprods (B : bicat) : preserves_bincoprods (id_psfunctor B) := λ x y p Hp, Hp. (** 3. Preservation of the composition *) Definition comp_psfunctor_preserves_bifinal {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} (HF : preserves_bifinal F) (HG : preserves_bifinal G) : preserves_bifinal (comp_psfunctor G F) := λ x Hx, HG _ (HF _ Hx). Definition comp_psfunctor_preserves_biinitial {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} (HF : preserves_biinitial F) (HG : preserves_biinitial G) : preserves_biinitial (comp_psfunctor G F) := λ x Hx, HG _ (HF _ Hx). Definition comp_psfunctor_preserves_binprods {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} (HF : preserves_binprods F) (HG : preserves_binprods G) : preserves_binprods (comp_psfunctor G F) := λ x y p Hp, HG _ _ _ (HF _ _ _ Hp). Definition comp_psfunctor_preserves_bincoprods {B₁ B₂ B₃ : bicat} {F : psfunctor B₁ B₂} {G : psfunctor B₂ B₃} (HF : preserves_bincoprods F) (HG : preserves_bincoprods G) : preserves_bincoprods (comp_psfunctor G F) := λ x y p Hp, HG _ _ _ (HF _ _ _ Hp). (** 4. Preservation of chosen (co)limits *) Definition preserves_chosen_biinitial (B₁ : bicat_with_biinitial) {B₂ : bicat} (F : psfunctor B₁ B₂) : UU := is_biinitial (F (pr1 (biinitial_of B₁))). Definition preserves_chosen_biinitial_to_preserve_biinitial (B₁ : bicat_with_biinitial) {B₂ : bicat} (F : psfunctor B₁ B₂) (HF : preserves_chosen_biinitial B₁ F) : preserves_biinitial F. Proof. intros x Hx. refine (equiv_from_biinitial _ (psfunctor_preserves_adjequiv' F (biinitial_unique_adj_eqv Hx (pr2 (biinitial_of B₁))))). apply HF. Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Preservation/PullbackPreservation.v000066400000000000000000000065261451125700300312570ustar00rootroot00000000000000(************************************************************************** Preservation of certain colimits by pullbacks The pullback functor always has a left biadjoint, which is given by composition. For that reason, pullbacks always preserve limits such as terminal objects, products, inserters, and equifiers. However, in general, the pullback functor does not have a right adjoint (this is even not the case in the bicategory of categories), and this pseudofunctor does not even preserve all colimits. If we have some additional assumptions, then we can show that certain colimits are preserved. If the bicategory has a strict biinitial (i.e., all maps into that object are equivalents), then the pullback pseudofunctor preserves biinitial objects. Contents 1. Pullbacks preserve strict biinitial objects **************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Colimits.Extensive. Require Import UniMath.Bicategories.Colimits.Examples.SliceBicategoryColimits. Require Import UniMath.Bicategories.Limits.Pullbacks. Require Import UniMath.Bicategories.Limits.PullbackFunctions. Local Open Scope cat. (** 1. Pullbacks preserve strict biinitial objects *) Definition pullback_preserves_biinitial (B : bicat_with_pb) (HI : strict_biinitial_obj B) {b₁ b₂ : B} (f : b₁ --> b₂) : preserves_biinitial (pb_psfunctor B f). Proof. pose (H := map_to_strict_biinitial_is_biinitial (pr2 HI) (pb_pr2 f (is_biinitial_1cell_property (pr12 HI) b₂))). use (preserves_chosen_biinitial_to_preserve_biinitial (_ ,, _) (pb_psfunctor B f)). - apply biinitial_in_slice. exact (pr1 HI ,, pr12 HI). - use (equiv_from_biinitial (is_biinitial_slice (pb_obj f (is_biinitial_1cell_property (pr12 HI) b₂) ,, H) b₁)). + use make_1cell_slice. * apply id₁. * cbn. use is_biinitial_invertible_2cell_property. exact H. + use left_adjoint_equivalence_in_slice_bicat. cbn. apply internal_adjoint_equivalence_identity. Defined. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/PseudoFunctor.v000066400000000000000000000371421451125700300252350ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Pseudofunctors on bicategories Benedikt Ahrens, Marco Maggesi February 2018 Modified by: Dan Frumin, Niels van der Weide Based on https://github.com/nmvdw/groupoids ********************************************************************************* *) (** * Pseudo functors. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.EquivToAdjequiv. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Local Open Scope bicategory_scope. Local Open Scope cat. (* ----------------------------------------------------------------------------------- *) (** ** Pseudo-functors *) (* ----------------------------------------------------------------------------------- *) Definition psfunctor (C D : bicat) : UU := psfunctor_bicat C D. Definition make_psfunctor_data {C D : bicat} (F₀ : C → D) (F₁ : ∏ {a b : C}, C⟦a,b⟧ → D⟦F₀ a, F₀ b⟧) (F₂ : ∏ {a b : C} {f g : C⟦a,b⟧}, f ==> g → F₁ f ==> F₁ g) (Fid : ∏ (a : C), identity (F₀ a) ==> F₁ (identity a)) (Fcomp : (∏ (a b c : C) (f : a --> b) (g : b --> c), F₁ f · F₁ g ==> F₁ (f · g))) : psfunctor_data C D. Proof. exact ((F₀ ,, F₁) ,, (F₂ ,, Fid ,, Fcomp)). Defined. Definition make_psfunctor {C D : bicat} (F : psfunctor_data C D) (HF : psfunctor_laws F) (Fcells : invertible_cells F) : psfunctor C D := (F ,, (HF ,, Fcells)). Coercion psfunctor_to_psfunctor_data {C D : bicat} (F : psfunctor C D) : psfunctor_data C D := pr1 F. Definition psfunctor_on_cells {C D : bicat} (F : psfunctor C D) {a b : C} {f g : a --> b} (x : f ==> g) : #F f ==> #F g := pr12 (pr1 F) a b f g x. Definition psfunctor_id {C D : bicat} (F : psfunctor C D) (a : C) : invertible_2cell (identity (F a)) (#F (identity a)). Proof. refine (pr122 (pr1 F) a ,, _). apply F. Defined. Definition psfunctor_comp {C D : bicat} (F : psfunctor C D) {a b c : C} (f : a --> b) (g : b --> c) : invertible_2cell (#F f · #F g) (#F (f · g)). Proof. refine (pr222 (pr1 F) a b c f g ,, _). apply F. Defined. Local Notation "'##'" := (psfunctor_on_cells). Section Projection. Context {C D : bicat}. Variable (F : psfunctor C D). Definition psfunctor_id2 : ∏ {a b : C} (f : a --> b), ##F (id2 f) = id2 (#F f) := pr1(pr12 F). Definition psfunctor_vcomp : ∏ {a b : C} {f g h : C⟦a, b⟧} (η : f ==> g) (φ : g ==> h), ##F (η • φ) = ##F η • ##F φ := pr12(pr12 F). Definition psfunctor_lunitor : ∏ {a b : C} (f : C⟦a, b⟧), lunitor (#F f) = (psfunctor_id F a ▹ #F f) • psfunctor_comp F (identity a) f • ##F (lunitor f) := pr122(pr12 F). Definition psfunctor_runitor : ∏ {a b : C} (f : C⟦a, b⟧), runitor (#F f) = (#F f ◃ psfunctor_id F b) • psfunctor_comp F f (identity b) • ##F (runitor f) := pr1(pr222(pr12 F)). Definition psfunctor_lassociator : ∏ {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) , (#F f ◃ psfunctor_comp F g h) • psfunctor_comp F f (g · h) • ##F (lassociator f g h) = (lassociator (#F f) (#F g) (#F h)) • (psfunctor_comp F f g ▹ #F h) • psfunctor_comp F (f · g) h := pr12(pr222(pr12 F)). Definition psfunctor_lwhisker : ∏ {a b c : C} (f : C⟦a, b⟧) {g₁ g₂ : C⟦b, c⟧} (η : g₁ ==> g₂), psfunctor_comp F f g₁ • ##F (f ◃ η) = #F f ◃ ##F η • psfunctor_comp F f g₂ := pr122(pr222(pr12 F)). Definition psfunctor_rwhisker : ∏ {a b c : C} {f₁ f₂ : C⟦a, b⟧} (g : C⟦b, c⟧) (η : f₁ ==> f₂), psfunctor_comp F f₁ g • ##F (η ▹ g) = ##F η ▹ #F g • psfunctor_comp F f₂ g := pr222(pr222(pr12 F)). End Projection. (** Isos are preserved *) Definition psfunctor_is_iso {C D : bicat} (F : psfunctor C D) {a b : C} {f g : C⟦a,b⟧} (α : invertible_2cell f g) : is_invertible_2cell (##F α). Proof. use tpair. - exact (##F (α^-1)). - split ; cbn ; rewrite <- psfunctor_vcomp, <- psfunctor_id2 ; apply maponpaths. + apply vcomp_rinv. + apply vcomp_linv. Defined. Section PseudoFunctorDerivedLaws. Context {C D : bicat}. Variable (F : psfunctor C D). Definition psfunctor_linvunitor {a b : C} (f : C⟦a, b⟧) : ##F (linvunitor f) = (linvunitor (#F f)) • ((psfunctor_id F a) ▹ #F f) • (psfunctor_comp F _ _). Proof. rewrite !vassocl. cbn. use vcomp_move_L_pM. { is_iso. } cbn. use vcomp_move_R_Mp. { refine (psfunctor_is_iso F (linvunitor f ,, _)). is_iso. } cbn. rewrite psfunctor_lunitor ; cbn. rewrite <- !vassocr. reflexivity. Qed. Definition psfunctor_rinvunitor {a b : C} (f : C⟦a, b⟧) : ##F (rinvunitor f) = (rinvunitor (#F f)) • (#F f ◃ psfunctor_id F b) • psfunctor_comp F _ _. Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. use vcomp_move_R_Mp. { refine (psfunctor_is_iso F (rinvunitor f ,, _)). is_iso. } cbn. rewrite psfunctor_runitor ; cbn. rewrite <- !vassocr. reflexivity. Qed. Definition psfunctor_rassociator {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : (psfunctor_comp F f g ▹ #F h) • psfunctor_comp F (f · g) h • ##F (rassociator f g h) = (rassociator (#F f) (#F g) (#F h)) • (#F f ◃ psfunctor_comp F g h) • psfunctor_comp F f (g · h). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. use vcomp_move_R_Mp. { refine (psfunctor_is_iso F (rassociator f g h ,, _)). is_iso. } cbn. symmetry. exact (psfunctor_lassociator F f g h). Qed. Definition psfunctor_comp_natural {a b c : C} {g₁ g₂ : C⟦b,c⟧} {f₁ f₂ : C⟦a,b⟧} (ηg : g₁ ==> g₂) (ηf : f₁ ==> f₂) : psfunctor_comp F f₁ g₁ • ##F (ηf ⋆ ηg) = (##F ηf) ⋆ (##F ηg) • psfunctor_comp F f₂ g₂. Proof. unfold hcomp. rewrite !psfunctor_vcomp. rewrite !vassocr. rewrite !psfunctor_rwhisker. rewrite !vassocl. rewrite psfunctor_lwhisker. reflexivity. Qed. Definition psfunctor_F_lunitor {a b : C} (f : C⟦a, b⟧) : ##F (lunitor f) = ((psfunctor_comp F (identity a) f)^-1) • ((psfunctor_id F a)^-1 ▹ #F f) • lunitor (#F f). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (!(psfunctor_lunitor F f)). Qed. Definition psfunctor_F_runitor {a b : C} (f : C⟦a,b⟧) : ##F (runitor f) = ((psfunctor_comp F f (identity b))^-1) • (#F f ◃ (psfunctor_id F b)^-1) • runitor (#F f). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (!(psfunctor_runitor F f)). Qed. Definition psfunctor_lassociator_alt {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : (psfunctor_comp F f (g · h)) • ##F (lassociator _ _ _) • (psfunctor_comp F (f · g) h)^-1 • ((psfunctor_comp F f g)^-1 ▹ #F h) • rassociator _ _ _ = #F f ◃ (psfunctor_comp F g h)^-1. Proof. use vcomp_move_R_Mp. { is_iso. } use vcomp_move_R_Mp. { is_iso. } use vcomp_move_R_Mp. { is_iso. } rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. apply (psfunctor_lassociator F f g h). Qed. End PseudoFunctorDerivedLaws. Definition psfunctor_lassociator_alt' {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) {a b c d : B₁} (f : a --> b) (g : b --> c) (h : c --> d) : ##F (lassociator f g h) • (psfunctor_comp F _ _)^-1 • ((psfunctor_comp F _ _)^-1 ▹ #F h) • rassociator _ _ _ = (psfunctor_comp F _ _)^-1 • (_ ◃ (psfunctor_comp F _ _)^-1). Proof. use vcomp_move_L_pM ; [ is_iso | ]. cbn. rewrite !vassocr. apply psfunctor_lassociator_alt. Qed. Section PseudoFunctorLocalFunctor. Context {B C : bicat}. Variable (F : psfunctor B C) (X Y : B). Definition Fmor_data : functor_data (hom X Y) (hom (F X) (F Y)). Proof. use make_functor_data. - exact (λ f, #F f). - exact (λ _ _ α, ##F α). Defined. Definition Fmor_is_functor : is_functor Fmor_data. Proof. split. - intros f. exact (psfunctor_id2 F f). - intros f g h α β. exact (psfunctor_vcomp F α β). Defined. Definition Fmor : hom X Y ⟶ hom (F X) (F Y). Proof. use make_functor. - exact Fmor_data. - exact Fmor_is_functor. Defined. Definition Fmor_univ (B_is_univalent_2_1 : is_univalent_2_1 B) (C_is_univalent_2_1 : is_univalent_2_1 C) : (univ_hom B_is_univalent_2_1 X Y) ⟶ univ_hom C_is_univalent_2_1 (F X) (F Y). Proof. exact Fmor. Defined. End PseudoFunctorLocalFunctor. Section ExtendPseudoFunctor. Context {C D : bicat} (HD : is_univalent_2 D) (F : psfunctor C D) (G : ob C → ob D) (η : ∏ (a : C), adjoint_equivalence (F a) (G a)). Definition extend_psfunctor : psfunctor C D. Proof. cbn. pose (adjequiv_base_adjequiv_tot (ps_base_is_univalent_2_0 C D HD) (adjequiv_ps_base C D F G η) (pr211 F)) as m. induction m as [m1 m2]. pose (adjequiv_base_adjequiv_tot (map1cells_is_univalent_2_0 C D HD) m2 (pr21 F)) as n. induction n as [n1 n2]. pose (adjequiv_base_adjequiv_tot (psfunctor_data_is_univalent_2_0 C D HD) n2 (pr2 F)) as p. exact (_ ,, pr1 p). Defined. End ExtendPseudoFunctor. Definition psfunctor_preserves_adjequiv {C D : bicat} (HC : is_univalent_2_0 C) (HD : is_univalent_2_1 D) (F : psfunctor C D) (a b : C) (f : adjoint_equivalence a b) : left_adjoint_equivalence (#F f) := J_2_0 HC (λ a b f, left_adjoint_equivalence (#F (pr1 f))) (λ a0, left_adjequiv_invertible_2cell HD _ _ (psfunctor_id F a0) (pr2 (internal_adjoint_equivalence_identity (F a0)))) f. Definition psfunctor_preserves_adjequiv' {C D : bicat} (F : psfunctor C D) {a b : C} {f : a --> b} (Hf : left_adjoint_equivalence f) : left_adjoint_equivalence (#F f). Proof. use equiv_to_adjequiv. simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)). - exact (#F (left_adjoint_right_adjoint Hf)). - exact (psfunctor_id F _ • ##F (left_equivalence_unit_iso Hf) • (psfunctor_comp F _ _)^-1). - exact (psfunctor_comp F _ _ • ##F (left_adjoint_counit Hf) • (psfunctor_id F _)^-1). - cbn. is_iso. + apply psfunctor_id. + exact (psfunctor_is_iso F (left_equivalence_unit_iso Hf)). - cbn. is_iso. + apply psfunctor_comp. + exact (psfunctor_is_iso F (left_equivalence_counit_iso Hf)). Defined. Lemma psfunctor_preserve_adj_equiv {C D : bicat} (F : psfunctor C D) (x y : C) : adjoint_equivalence x y -> adjoint_equivalence (pr111 F x) (pr111 F y). Proof. intro a. exists (pr211 F _ _ (pr1 a)). use psfunctor_preserves_adjequiv'. exact (pr2 a). Defined. Definition local_equivalence {B₁ B₂ : bicat} (B₁_is_univalent_2_1 : is_univalent_2_1 B₁) (B₂_is_univalent_2_1 : is_univalent_2_1 B₂) (F : psfunctor B₁ B₂) : UU := ∏ (x y : B₁), @left_adjoint_equivalence bicat_of_univ_cats _ _ (Fmor_univ F x y B₁_is_univalent_2_1 B₂_is_univalent_2_1). Definition local_weak_equivalence {B1 B2 : bicat} (F : psfunctor B1 B2) : UU := ∏ (x y : B1), Functors.essentially_surjective (Fmor F x y) × fully_faithful (Fmor F x y). Definition essentially_surjective {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) : hProp := ∀ (y : B₂), ∃ (x : B₁), adjoint_equivalence (F x) y. Definition weak_equivalence {B₁ B₂ : bicat} (B₁_is_univalent_2_1 : is_univalent_2_1 B₁) (B₂_is_univalent_2_1 : is_univalent_2_1 B₂) (F : psfunctor B₁ B₂) : UU := local_equivalence B₁_is_univalent_2_1 B₂_is_univalent_2_1 F × essentially_surjective F. Definition weak_biequivalence {B1 B2 : bicat} (F : psfunctor B1 B2) : UU := essentially_surjective F × local_weak_equivalence F. Lemma weak_equivalence_to_is_weak_biequivalence {B1 B2 : bicat} {u1 : is_univalent_2_1 B1} {u2 : is_univalent_2_1 B2} (F : psfunctor B1 B2) : weak_equivalence u1 u2 F -> weak_biequivalence F. Proof. intro w. exists (pr2 w). intros x y. set (a := pr1 w x y). split ; [apply functor_from_equivalence_is_essentially_surjective | apply fully_faithful_from_equivalence ] ; apply (adj_equiv_to_equiv_cat (Fmor_univ F x y u1 u2)) ; exact (pr1 w x y). Defined. (** `idtoiso_2_1` for pseudofunctors *) Definition idtoiso_2_1_psfunctor {B₁ B₂ : bicat} (F : psfunctor B₁ B₂) {x y : B₁} {f g : x --> y} (p : f = g) : idtoiso_2_1 _ _ (maponpaths #F p) = ##F (idtoiso_2_1 _ _ p) ,, psfunctor_is_iso _ _. Proof. induction p ; cbn. use subtypePath. { intro. apply isaprop_is_invertible_2cell. } cbn. rewrite psfunctor_id2. apply idpath. Qed. Module Notations. Notation "'##'" := (psfunctor_on_cells). End Notations. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/PseudoFunctorLimits.v000066400000000000000000001172071451125700300264200ustar00rootroot00000000000000(*************************************************************************** Properties of the bicat of pseudofunctors In this file, we study some properties of the bicategory of pseudofunctors. We look at the following properties: 1. Being locally groupoidal 2. Terminal objects 3. Initial objects ***************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Morphisms.FullyFaithful. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Constant. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Colimits.Initial. Require Import UniMath.Bicategories.Limits.Final. Require Import UniMath.Bicategories.Limits.Products. Import Products.Notations. Local Open Scope cat. (** 1. Locally groupoidal *) Section FixALocallyGrpd. Context (B₁ : bicat) {B₂ : bicat} (HB₂ : locally_groupoid B₂). Definition locally_groupoid_psfunctor_bicat : locally_groupoid (psfunctor_bicat B₁ B₂). Proof. intros F G α β m. use make_is_invertible_modification. intro x. apply HB₂. Defined. End FixALocallyGrpd. (** 2. Final objects *) Section FixAFinal. Context (B₁ : bicat) (B₂ : bicat) (f : bifinal_obj B₂). Definition final_psfunctor : psfunctor_bicat B₁ B₂ := constant _ (pr1 f). Definition final_psfunctor_1cell_data (F : psfunctor B₁ B₂) : pstrans_data F final_psfunctor. Proof. use make_pstrans_data. - exact (λ x, is_bifinal_1cell_property (pr2 f) (F x)). - intros x y g. apply (is_bifinal_invertible_2cell_property (pr2 f)). Defined. Definition final_psfunctor_1cell_is_pstrans (F : psfunctor B₁ B₂) : is_pstrans (final_psfunctor_1cell_data F). Proof. repeat split ; intros ; apply (is_bifinal_eq_property (pr2 f)). Qed. Definition final_psfunctor_1cell (F : psfunctor B₁ B₂) : pstrans F final_psfunctor. Proof. use make_pstrans. - exact (final_psfunctor_1cell_data F). - exact (final_psfunctor_1cell_is_pstrans F). Defined. Definition final_psfunctor_2cell_data {F : psfunctor B₁ B₂} (α β : pstrans F final_psfunctor) : modification_data α β := λ x, is_bifinal_2cell_property (pr2 f) _ (α x) (β x). Definition final_psfunctor_2cell_is_modification {F : psfunctor B₁ B₂} (α β : pstrans F final_psfunctor) : is_modification (final_psfunctor_2cell_data α β). Proof. intros x y g. apply (is_bifinal_eq_property (pr2 f)). Qed. Definition final_psfunctor_2cell {F : psfunctor B₁ B₂} (α β : pstrans F final_psfunctor) : modification α β. Proof. use make_modification. - exact (final_psfunctor_2cell_data α β). - exact (final_psfunctor_2cell_is_modification α β). Defined. Definition final_psfunctor_eq {F : psfunctor B₁ B₂} {α β : pstrans F final_psfunctor} (m₁ m₂ : modification α β) : m₁ = m₂. Proof. use modification_eq. intro. apply (is_bifinal_eq_property (pr2 f)). Qed. Definition psfunctor_bifinal : bifinal_obj (psfunctor_bicat B₁ B₂). Proof. simple refine (_ ,, _). - exact final_psfunctor. - use make_is_bifinal. + exact final_psfunctor_1cell. + exact @final_psfunctor_2cell. + exact @final_psfunctor_eq. Defined. End FixAFinal. (** 3. Initial objects *) Section FixAnInitial. Context (B₁ : bicat) (B₂ : bicat) (i : biinitial_obj B₂). Definition initial_psfunctor : psfunctor_bicat B₁ B₂ := constant _ (pr1 i). Definition initial_psfunctor_1cell_data (F : psfunctor B₁ B₂) : pstrans_data initial_psfunctor F. Proof. use make_pstrans_data. - exact (λ x, is_biinitial_1cell_property (pr2 i) (F x)). - intros x y g. apply (is_biinitial_invertible_2cell_property (pr2 i)). Defined. Definition initial_psfunctor_1cell_is_pstrans (F : psfunctor B₁ B₂) : is_pstrans (initial_psfunctor_1cell_data F). Proof. repeat split ; intros ; apply (is_biinitial_eq_property (pr2 i)). Qed. Definition initial_psfunctor_1cell (F : psfunctor B₁ B₂) : pstrans initial_psfunctor F. Proof. use make_pstrans. - exact (initial_psfunctor_1cell_data F). - exact (initial_psfunctor_1cell_is_pstrans F). Defined. Definition initial_psfunctor_2cell_data {F : psfunctor B₁ B₂} (α β : pstrans initial_psfunctor F) : modification_data α β := λ x, is_biinitial_2cell_property (pr2 i) _ (α x) (β x). Definition initial_psfunctor_2cell_is_modification {F : psfunctor B₁ B₂} (α β : pstrans initial_psfunctor F) : is_modification (initial_psfunctor_2cell_data α β). Proof. intros x y g. apply (is_biinitial_eq_property (pr2 i)). Qed. Definition initial_psfunctor_2cell {F : psfunctor B₁ B₂} (α β : pstrans initial_psfunctor F) : modification α β. Proof. use make_modification. - exact (initial_psfunctor_2cell_data α β). - exact (initial_psfunctor_2cell_is_modification α β). Defined. Definition initial_psfunctor_eq {F : psfunctor B₁ B₂} {α β : pstrans initial_psfunctor F} (m₁ m₂ : modification α β) : m₁ = m₂. Proof. use modification_eq. intro. apply (is_biinitial_eq_property (pr2 i)). Qed. Definition psfunctor_biinitial : biinitial_obj (psfunctor_bicat B₁ B₂). Proof. simple refine (_ ,, _). - exact initial_psfunctor. - use make_is_biinitial. + exact initial_psfunctor_1cell. + exact @initial_psfunctor_2cell. + exact @initial_psfunctor_eq. Defined. End FixAnInitial. (* This is WIP. It is commented out, because it needs refactoring Section FixProducts. Context (B₁ : bicat) (B₂ : bicat_with_binprod). Section BinprodPSFunctor. Context (F G : psfunctor B₁ B₂). Definition binprod_psfunctor_data : psfunctor_data B₁ B₂. Proof. use make_psfunctor_data. - exact (λ z, F z ⊗ G z). - exact (λ x y f, #F f ⊗₁ #G f). - exact (λ x y f g α, ##F α ⊗₂ ##G α). - exact (λ b, (pair_1cell_id_id_invertible B₂ (F b) (G b))^-1 • psfunctor_id F b ⊗₂ psfunctor_id G b). - exact (λ b₁ b₂ b₃ f g, pair_1cell_comp _ (#F f) (#F g) (#G f) (#G g) • psfunctor_comp F f g ⊗₂ psfunctor_comp G f g). Defined. Definition binprod_psfunctor_laws : psfunctor_laws binprod_psfunctor_data. Proof. repeat split. - intros b₁ b₂ f ; cbn. rewrite !psfunctor_id2. rewrite pair_2cell_id_id. apply idpath. - intros b₁ b₂ f g h α β ; cbn. rewrite !psfunctor_vcomp. rewrite !pair_2cell_comp. apply idpath. - intros b₁ b₂ f ; cbn. use binprod_ump_2cell_unique_alt. + apply (pr2 B₂). + pose (psfunctor_lunitor F f) as Fid. pose (psfunctor_lunitor G f) as Gid. apply TODO. + apply TODO. - intros b₁ b₂ f ; cbn. use binprod_ump_2cell_unique_alt. + apply (pr2 B₂). + rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply binprod_ump_2cell_pr1. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. apply idpath. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } apply idpath. } etrans. { rewrite !vassocr. do 6 apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. apply binprod_ump_2cell_pr1. } etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite lwhisker_vcomp. apply maponpaths. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. etrans. { apply maponpaths_2. rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. apply maponpaths_2. apply maponpaths. rewrite !vassocr. exact (!(psfunctor_runitor F f)). } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_runitor. apply idpath. } rewrite !vassocr. rewrite <- runitor_triangle. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. } rewrite !lwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_right. apply lunitor_lwhisker. + rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply binprod_ump_2cell_pr2. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. apply idpath. } etrans. { apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } apply idpath. } etrans. { rewrite !vassocr. do 6 apply maponpaths_2. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocr. rewrite <- rwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. apply binprod_ump_2cell_pr2. } etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. } rewrite lwhisker_vcomp. apply maponpaths. rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. etrans. { apply maponpaths_2. rewrite <- !lwhisker_vcomp. apply idpath. } rewrite !vassocl. do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_whisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- lwhisker_lwhisker_rassociator. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. apply maponpaths_2. apply maponpaths. rewrite !vassocr. exact (!(psfunctor_runitor G f)). } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite runitor_triangle. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_runitor. apply idpath. } rewrite !vassocr. rewrite <- runitor_triangle. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. rewrite vcomp_rinv. apply id2_right. } rewrite !lwhisker_vcomp. rewrite rinvunitor_runitor. rewrite id2_right. apply lunitor_lwhisker. - intros b₁ b₂ b₃ b₄ f g h ; cbn. apply TODO. - intros b₁ b₂ b₃ f g₁ g₂ α ; cbn. apply TODO. - intros b₁ b₂ b₃ f g₁ g₂ α ; cbn. apply TODO. Qed. Definition binprod_psfunctor_invertible_2cells : invertible_cells binprod_psfunctor_data. Proof. split ; cbn. - intros b. is_iso. + use binprod_ump_2cell_invertible. * is_iso. * is_iso. + use binprod_ump_2cell_invertible. * is_iso. ** apply property_from_invertible_2cell. ** apply psfunctor_id. * is_iso. ** apply property_from_invertible_2cell. ** apply psfunctor_id. - intros b₁ b₂ b₃ f g. is_iso. + apply pair_1cell_comp_invertible. + use binprod_ump_2cell_invertible. * is_iso. ** apply property_from_invertible_2cell. ** apply psfunctor_comp. * is_iso. ** apply property_from_invertible_2cell. ** apply psfunctor_comp. Defined. Definition binprod_psfunctor : psfunctor B₁ B₂. Proof. use make_psfunctor. - exact binprod_psfunctor_data. - exact binprod_psfunctor_laws. - exact binprod_psfunctor_invertible_2cells. Defined. Definition binprod_psfunctor_pr1_data : pstrans_data binprod_psfunctor F. Proof. use make_pstrans_data. - exact (λ x, π₁). - cbn. simple refine (λ x y f, _). use inv_of_invertible_2cell. apply pair_1cell_pr1. Defined. Definition binprod_psfunctor_pr1_is_pstrans : is_pstrans binprod_psfunctor_pr1_data. Proof. repeat split. - intros b₁ b₂ f g α ; cbn. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite pair_2cell_pr1. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - intros b ; cbn. rewrite <- rwhisker_vcomp. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite linvunitor_lunitor. apply id2_right. } apply runitor_rinvunitor. } rewrite id2_left. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite pair_2cell_pr1. rewrite !vassocl. apply maponpaths. rewrite vcomp_linv. rewrite id2_right. apply idpath. - intros b₁ b₂ b₃ f g ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 6 apply maponpaths. apply pair_2cell_pr1. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. do 4 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn). etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite lassociator_rassociator, id2_left. rewrite !vassocl. do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. Qed. Definition binprod_psfunctor_pr1 : pstrans binprod_psfunctor F. Proof. use make_pstrans. - exact binprod_psfunctor_pr1_data. - exact binprod_psfunctor_pr1_is_pstrans. Defined. Definition binprod_psfunctor_pr2_data : pstrans_data binprod_psfunctor G. Proof. use make_pstrans_data. - exact (λ x, π₂). - cbn. simple refine (λ x y f, _). use inv_of_invertible_2cell. apply pair_1cell_pr2. Defined. Definition binprod_psfunctor_pr2_is_pstrans : is_pstrans binprod_psfunctor_pr2_data. Proof. repeat split. - intros b₁ b₂ f g α ; cbn. use vcomp_move_L_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_R_Mp ; [ is_iso | ] ; cbn. rewrite pair_2cell_pr2. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. apply idpath. - intros b ; cbn. rewrite <- rwhisker_vcomp. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocr. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite linvunitor_lunitor. apply id2_right. } apply runitor_rinvunitor. } rewrite id2_left. use vcomp_move_R_pM ; [ is_iso | ] ; cbn. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso | ] ; cbn. rewrite pair_2cell_pr2. rewrite !vassocl. apply maponpaths. rewrite vcomp_linv. rewrite id2_right. apply idpath. - intros b₁ b₂ b₃ f g ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocl. refine (!_). etrans. { do 6 apply maponpaths. apply pair_2cell_pr2. } rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. do 4 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn). etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocr. rewrite lassociator_rassociator, id2_left. rewrite !vassocl. do 4 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. Qed. Definition binprod_psfunctor_pr2 : pstrans binprod_psfunctor G. Proof. use make_pstrans. - exact binprod_psfunctor_pr2_data. - exact binprod_psfunctor_pr2_is_pstrans. Defined. Definition psfunctor_binprod_cone : binprod_cone F G. Proof. use make_binprod_cone. - exact binprod_psfunctor. - exact binprod_psfunctor_pr1. - exact binprod_psfunctor_pr2. Defined. Definition pstrans_pair_data {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : pstrans_data H binprod_psfunctor. Proof. use make_pstrans_data. - exact (λ x, ⟨ α x , β x ⟩). - intros x y f ; simpl. use make_invertible_2cell. + exact (precomp_prod_1cell _ _ _ _ • ⟪ lassociator _ _ _ • (prod_1cell_pr1 _ _ _ ▹ _) • psnaturality_of α f , lassociator _ _ _ • (prod_1cell_pr2 _ _ _ ▹ _) • psnaturality_of β f ⟫ • (precomp_prod_1cell_invertible _ _ _ _)^-1). + is_iso. * apply precomp_prod_1cell_invertible. * use binprod_ump_2cell_invertible. ** is_iso ; apply property_from_invertible_2cell. ** is_iso ; apply property_from_invertible_2cell. Defined. Definition pstrans_pair_is_pstrans {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : is_pstrans (pstrans_pair_data α β). Proof. repeat split. - intros b₁ b₂ f g τ ; cbn. use binprod_ump_2cell_unique_alt. + apply (pr2 B₂). + apply TODO. + apply TODO. - intros b ; cbn. use binprod_ump_2cell_unique_alt. + apply (pr2 B₂). + rewrite <- !lwhisker_vcomp. rewrite <- !rwhisker_vcomp. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite runitor_rwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite <- !lwhisker_vcomp. rewrite !vassocl. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite <- rwhisker_lwhisker. rewrite !vassocl. etrans. { apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. } rewrite !vassocl. apply maponpaths. etrans. { apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. rewrite !vassocl. rewrite binprod_ump_2cell_pr1. etrans. { do 2 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. rewrite !vassocl. etrans. { do 3 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. rewrite id2_left. apply idpath. } rewrite pstrans_id_alt. rewrite !vassocl. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. rewrite vcomp_linv. rewrite id2_right. rewrite <- lwhisker_vcomp. etrans. { refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_lwhisker. apply idpath. } rewrite !vassocl. etrans. { do 2 apply maponpaths. do 2 refine (vassocr _ _ _ @ _). apply maponpaths_2. rewrite <- vcomp_whisker. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_right. } apply idpath. } do 3 refine (vassocr _ _ _ @ _). etrans. { do 2 apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. } rewrite rinvunitor_triangle. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocl. rewrite lassociator_rassociator. rewrite id2_right. rewrite rwhisker_rwhisker_alt. rewrite vcomp_whisker. rewrite !vassocr. apply maponpaths_2. rewrite !vassocl. etrans. { apply maponpaths. rewrite !vassocr. rewrite vcomp_runitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite linvunitor_natural. rewrite <- lwhisker_hcomp. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite vcomp_rinv. rewrite lwhisker_id2. apply id2_right. } rewrite !vassocr. rewrite rinvunitor_runitor. rewrite id2_left. rewrite linvunitor_assoc. apply idpath. + apply TODO. - intros b₁ b₂ f g τ ; cbn. use binprod_ump_2cell_unique_alt. + apply (pr2 B₂). + apply TODO. + apply TODO. Time Qed. Definition pstrans_pair {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : pstrans H binprod_psfunctor. Proof. use make_pstrans. - exact (pstrans_pair_data α β). - exact (pstrans_pair_is_pstrans α β). Defined. Definition pstrans_pair_pr1_data {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : invertible_modification_data (comp_pstrans (pstrans_pair α β) binprod_psfunctor_pr1) α := λ x, prod_1cell_pr1 _ (α x) (β x). Definition pstrans_pair_pr1_is_modification {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : is_modification (pstrans_pair_pr1_data α β). Proof. intros x y f. simpl. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. etrans. { apply maponpaths_2. apply prod_2cell_pr1. } apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 11 apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. apply lassociator_rassociator. } apply id2_left. } etrans. { do 9 apply maponpaths. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. } rewrite vcomp_linv. rewrite id2_right. rewrite !vassocr. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr1. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_left. } apply rassociator_lassociator. Qed. Definition pstrans_pair_pr1 {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : invertible_modification (comp_pstrans (pstrans_pair α β) binprod_psfunctor_pr1) α. Proof. use make_invertible_modification. - exact (pstrans_pair_pr1_data α β). - exact (pstrans_pair_pr1_is_modification α β). Defined. Definition pstrans_pair_pr2_data {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : invertible_modification_data (comp_pstrans (pstrans_pair α β) binprod_psfunctor_pr2) β := λ x, prod_1cell_pr2 _ (α x) (β x). Definition pstrans_pair_pr2_is_modification {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : is_modification (pstrans_pair_pr2_data α β). Proof. intros x y f. simpl. rewrite <- !rwhisker_vcomp. rewrite !vassocl. etrans. { do 4 apply maponpaths. etrans. { apply maponpaths_2. apply prod_2cell_pr2. } apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 11 apply maponpaths. rewrite !vassocr. etrans. { apply maponpaths_2. apply lassociator_rassociator. } apply id2_left. } etrans. { do 9 apply maponpaths. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_right. } rewrite vcomp_linv. rewrite id2_right. rewrite !vassocr. apply maponpaths_2. refine (_ @ id2_left _). apply maponpaths_2. rewrite !vassocl. etrans. { do 3 apply maponpaths. apply maponpaths_2. apply binprod_ump_2cell_pr2. } rewrite !vassocl. etrans. { do 5 apply maponpaths. rewrite !vassocr. rewrite vcomp_linv. apply id2_left. } etrans. { do 2 apply maponpaths. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. } etrans. { apply maponpaths. rewrite !vassocr. rewrite lwhisker_vcomp. rewrite vcomp_linv. rewrite lwhisker_id2. apply id2_left. } apply rassociator_lassociator. Qed. Definition pstrans_pair_pr2 {H : psfunctor B₁ B₂} (α : pstrans H F) (β : pstrans H G) : invertible_modification (comp_pstrans (pstrans_pair α β) binprod_psfunctor_pr2) β. Proof. use make_invertible_modification. - exact (pstrans_pair_pr2_data α β). - exact (pstrans_pair_pr2_is_modification α β). Defined. Definition prod_modification_data {H : psfunctor B₁ B₂} {α β : pstrans H binprod_psfunctor} (m : modification (α · binprod_cone_pr1 psfunctor_binprod_cone) (β · binprod_cone_pr1 psfunctor_binprod_cone)) (n : modification (α · binprod_cone_pr2 psfunctor_binprod_cone) (β · binprod_cone_pr2 psfunctor_binprod_cone)) : modification_data α β. Proof. intro x. use binprod_ump_2cell. - apply (pr2 B₂). - exact (m x). - exact (n x). Defined. Definition prod_modification_is_modification {H : psfunctor B₁ B₂} {α β : pstrans H binprod_psfunctor} (m : modification (α · binprod_cone_pr1 psfunctor_binprod_cone) (β · binprod_cone_pr1 psfunctor_binprod_cone)) (n : modification (α · binprod_cone_pr2 psfunctor_binprod_cone) (β · binprod_cone_pr2 psfunctor_binprod_cone)) : is_modification (prod_modification_data m n). Proof. intros x y f. use binprod_ump_2cell_unique_alt. - apply (pr2 B₂). - unfold prod_modification_data. rewrite <- !rwhisker_vcomp. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. simpl. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. etrans. { do 3 apply maponpaths. apply binprod_ump_2cell_pr1. } pose (q := modnaturality_of m _ _ f). simpl in q. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. use (vcomp_lcancel (_ ◃ (pair_1cell_pr1 B₂ (# F f) (# G f)) ^-1)) ; [ is_iso | ]. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. refine (q @ _) ; clear q. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr1. - unfold prod_modification_data. rewrite <- !rwhisker_vcomp. use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ]. simpl. rewrite !vassocl. rewrite <- rwhisker_lwhisker_rassociator. etrans. { do 3 apply maponpaths. apply binprod_ump_2cell_pr2. } pose (q := modnaturality_of n _ _ f). simpl in q. use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ]. use (vcomp_lcancel (_ ◃ (pair_1cell_pr2 B₂ (# F f) (# G f)) ^-1)) ; [ is_iso | ]. use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ]. rewrite !vassocr. refine (q @ _) ; clear q. rewrite !vassocr. do 2 apply maponpaths_2. rewrite !vassocl. refine (!_). etrans. { do 2 apply maponpaths. rewrite rwhisker_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. etrans. { rewrite !vassocl. rewrite <- vcomp_whisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. rewrite <- rwhisker_rwhisker_alt. apply maponpaths_2. apply maponpaths. apply binprod_ump_2cell_pr2. Qed. Definition prod_modification {H : psfunctor B₁ B₂} {α β : pstrans H binprod_psfunctor} (m : modification (α · binprod_cone_pr1 psfunctor_binprod_cone) (β · binprod_cone_pr1 psfunctor_binprod_cone)) (n : modification (α · binprod_cone_pr2 psfunctor_binprod_cone) (β · binprod_cone_pr2 psfunctor_binprod_cone)) : modification α β. Proof. use make_modification. - exact (prod_modification_data m n). - exact (prod_modification_is_modification m n). Defined. Definition psfunctor_binprod_ump : has_binprod_ump psfunctor_binprod_cone. Proof. use make_binprod_ump. - intro q. use make_binprod_1cell. + exact (pstrans_pair (binprod_cone_pr1 q) (binprod_cone_pr2 q)). + exact (pstrans_pair_pr1 (binprod_cone_pr1 q) (binprod_cone_pr2 q)). + exact (pstrans_pair_pr2 (binprod_cone_pr1 q) (binprod_cone_pr2 q)). - intros q α β m n. exact (prod_modification m n). - abstract (intros H α β m n ; use modification_eq ; intros x ; apply binprod_ump_2cell_pr1). - abstract (intros H α β m n ; use modification_eq ; intros x ; apply binprod_ump_2cell_pr2). - abstract (intro ; intros ; use modification_eq ; intros x ; pose (modcomponent_eq γpr1 x) as p₁ ; pose (modcomponent_eq γpr2 x) as p₂ ; pose (modcomponent_eq δpr1 x) as p₃ ; pose (modcomponent_eq δpr2 x) as p₄ ; use (binprod_ump_2cell_unique _ (pr111 α x) (pr111 β x) _ _ p₁ p₂ p₃ p₄) ; apply (pr2 B₂)). Defined. End BinprodPSFunctor. Definition psfunctor_has_binprod : has_binprod (psfunctor_bicat B₁ B₂). Proof. intros F G. simple refine (_ ,, _). - exact (psfunctor_binprod_cone F G). - exact (psfunctor_binprod_ump F G). Defined. End FixProducts. *) UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Representable.v000066400000000000000000000204521451125700300252240ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Representable pseudofunctor, pseudotransformation, and modifications Niccolò Veltri, Niels van der Weide April 2019 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope bicategory_scope. Local Open Scope cat. Section RepresentableFunctor. Context {C : bicat}. Variable (C_is_univalent_2_1 : is_univalent_2_1 C). Definition pspsh := psfunctor (op1_bicat C) bicat_of_univ_cats. Definition representable_data_cat (X Y : C) : univalent_category := univ_hom C_is_univalent_2_1 Y X. Definition representable_data_fun (X Y Z : C) (f : op1_bicat C ⟦ Y, Z ⟧) : bicat_of_univ_cats ⟦ representable_data_cat X Y, representable_data_cat X Z ⟧. Proof. simpl in f. use make_functor. - use make_functor_data. + intro g. exact (f · g). + intros g h. exact (lwhisker f). - split. + exact (lwhisker_id2 f). + intros g h k η φ. exact (! (lwhisker_vcomp f η φ)). Defined. Definition representable_data_nat (X Y Z : C) (f g : op1_bicat C ⟦ Y, Z ⟧) : f ==> g → representable_data_fun X Y Z f ==> representable_data_fun X Y Z g. Proof. intro η. use make_nat_trans. - intro h. exact (rwhisker h η). - intros h k φ. exact (! (@vcomp_whisker C Z Y X f g h k η φ)). Defined. Definition representable_data (X : C) : psfunctor_data (op1_bicat C) bicat_of_univ_cats. Proof. use make_psfunctor_data. - exact (representable_data_cat X). - exact (representable_data_fun X). - exact (representable_data_nat X). - intro Y. use make_nat_trans. + exact linvunitor. + abstract (intros f g η ; simpl in * ; rewrite lwhisker_hcomp ; apply linvunitor_natural). - intros Y Z W f g. use make_nat_trans. + intro h. simpl. cbn in *. apply lassociator. + intros h k η. simpl. apply lwhisker_lwhisker. Defined. Definition representable_laws (X : C) : psfunctor_laws (representable_data X). Proof. repeat split; cbn. - intros Y Z f. use nat_trans_eq. + exact (pr2 C Z X). + intro g. cbn. apply id2_rwhisker. - intros Y Z f g h η φ. use nat_trans_eq. + exact (pr2 C Z X). + intro k. cbn. symmetry. apply rwhisker_vcomp. - intros Y Z f. use nat_trans_eq. + exact (pr2 C Z X). + intro g. cbn. rewrite <- vassocr. rewrite runitor_rwhisker. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor. symmetry. apply lwhisker_id2. - intros Y Z f. use nat_trans_eq. + exact (pr2 C Z X). + intro g. cbn. rewrite linvunitor_assoc. refine (!(_@ _)). { apply maponpaths_2. rewrite <- vassocr. rewrite rassociator_lassociator. apply id2_right. } rewrite rwhisker_vcomp. rewrite linvunitor_lunitor. apply id2_rwhisker. - intros Y Z W V f g h. use nat_trans_eq. + exact (pr2 C V X). + intro k. cbn in *. rewrite id2_left. pose (pentagon_2 k f g h) as p. rewrite lwhisker_hcomp,rwhisker_hcomp. rewrite <- vassocr. exact (! p). - intros Y Z W f g h η. use nat_trans_eq. + exact (pr2 C W X). + intro k. cbn in *. apply rwhisker_rwhisker. - intros Y Z W f g h η. use nat_trans_eq. + exact (pr2 C W X). + intro k. cbn in *. symmetry. apply rwhisker_lwhisker. Qed. Definition representable_invertible_cells (X : C) : invertible_cells (representable_data X). Proof. split. - intro Y. use is_nat_z_iso_to_is_invertible_2cell. intro f. simpl. apply is_inv2cell_to_is_z_iso. is_iso. - intros Y Z W f g. use is_nat_z_iso_to_is_invertible_2cell. intro h. simpl. apply is_inv2cell_to_is_z_iso. is_iso. Defined. Definition representable (X : C) : pspsh. Proof. use make_psfunctor. - exact (representable_data X). - exact (representable_laws X). - exact (representable_invertible_cells X). Defined. End RepresentableFunctor. Section RepresentableTransformation. Context {C : bicat}{X Y : C}. Variable (C_is_univalent_2_1 : is_univalent_2_1 C) (f : X --> Y). Definition representable1_data : pstrans_data (representable C_is_univalent_2_1 X) (representable C_is_univalent_2_1 Y). Proof. use make_pstrans_data. - intro Z. cbn. use make_functor. + use make_functor_data. -- intro g. exact (g · f). -- intros g h η. exact (rwhisker f η). + split. -- intro g. apply id2_rwhisker. -- intros g h k η φ. symmetry. apply rwhisker_vcomp. - intros Z W h. cbn. use make_invertible_2cell. + use make_nat_trans. -- intro k. apply lassociator. -- intros k l η. cbn in *. apply rwhisker_lwhisker. + use is_nat_z_iso_to_is_invertible_2cell. intro g. apply is_inv2cell_to_is_z_iso. simpl. is_iso. Defined. Definition representable1_is_pstrans : is_pstrans representable1_data. Proof. repeat (apply tpair). - intros Z W g h η. use nat_trans_eq. { exact (pr2 C W Y). } intro k. simpl. symmetry. apply rwhisker_rwhisker. - intro Z. use nat_trans_eq. { exact (pr2 C Z Y). } intro h. cbn in *. rewrite !id2_left. rewrite linvunitor_assoc. rewrite <- vassocr. rewrite rassociator_lassociator. apply id2_right. - intros Z W V g h. use nat_trans_eq. { exact (pr2 C V Y). } intro k. cbn in *. rewrite id2_left , ! id2_right. symmetry. apply lassociator_lassociator. Qed. Definition representable1 : pstrans (representable C_is_univalent_2_1 X) (representable C_is_univalent_2_1 Y). Proof. use make_pstrans. - exact representable1_data. - exact representable1_is_pstrans. Defined. End RepresentableTransformation. Section RepresentableModification. Context {C : bicat}{X Y : C}{f g : X --> Y}. Variable (C_is_univalent_2_1 : is_univalent_2_1 C) (η : f ==> g). Definition representable2_data : modification_data (representable1 C_is_univalent_2_1 f) (representable1 C_is_univalent_2_1 g). Proof. intro Z. use make_nat_trans. - intro h. simpl. exact (h ◃ η). - intros h k φ. simpl. apply vcomp_whisker. Defined. Definition representable2_is_modification : is_modification (σ := representable1 C_is_univalent_2_1 f) representable2_data. Proof. intros Z W h. use nat_trans_eq. { exact (pr2 C W Y). } intro k. cbn in *. symmetry. apply lwhisker_lwhisker. Qed. Definition representable2 : modification (representable1 C_is_univalent_2_1 f) (representable1 C_is_univalent_2_1 g). Proof. use make_modification. - apply representable2_data. - apply representable2_is_modification. Defined. End RepresentableModification. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/StrictPseudoFunctor.v000066400000000000000000000343561451125700300264320ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Strict pseudofunctors on bicategories ********************************************************************************* *) (** * Strict pseudo functors. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat. Local Open Scope bicategory_scope. Local Open Scope cat. (* ----------------------------------------------------------------------------------- *) (** ** Strict pseudo-functors *) (* ----------------------------------------------------------------------------------- *) Definition strict_psfunctor (C D : bicat) : UU := strict_psfunctor_bicat C D. Definition make_strict_psfunctor_data {C D : bicat} (F₀ : C → D) (F₁ : ∏ {a b : C}, C⟦a,b⟧ → D⟦F₀ a, F₀ b⟧) (F₂ : ∏ {a b : C} {f g : C⟦a,b⟧}, f ==> g → F₁ f ==> F₁ g) (Fid : ∏ (a : C), identity (F₀ a) = F₁ (identity a)) (Fcomp : (∏ (a b c : C) (f : a --> b) (g : b --> c), F₁ f · F₁ g = F₁ (f · g))) : strict_psfunctor_data C D. Proof. exact ((F₀ ,, F₁) ,, (F₂ ,, Fid ,, Fcomp)). Defined. Definition make_strict_psfunctor {C D : bicat} (F : strict_psfunctor_data C D) (HF : is_strict_psfunctor F) : strict_psfunctor C D := (F ,, HF). Coercion strict_psfunctor_to_strict_psfunctor_data {C D : bicat} (F : strict_psfunctor C D) : strict_psfunctor_data C D := pr1 F. Definition strict_psfunctor_on_cells {C D : bicat} (F : strict_psfunctor C D) {a b : C} {f g : a --> b} (x : f ==> g) : #F f ==> #F g := pr12 (pr1 F) a b f g x. Definition strict_psfunctor_id {C D : bicat} (F : strict_psfunctor C D) (a : C) : identity (F a) = #F (identity a) := pr1 (pr221 F) a. Definition strict_psfunctor_comp {C D : bicat} (F : strict_psfunctor C D) {a b c : C} (f : a --> b) (g : b --> c) : #F f · #F g = #F (f · g) := pr2 (pr221 F) _ _ _ f g. Definition strict_psfunctor_id_cell {C D : bicat} (F : strict_psfunctor C D) (a : C) : invertible_2cell (identity (F a)) (#F (identity a)) := idtoiso_2_1 _ _ (strict_psfunctor_id F a). Definition strict_psfunctor_comp_cell {C D : bicat} (F : strict_psfunctor C D) {a b c : C} (f : a --> b) (g : b --> c) : invertible_2cell (#F f · #F g) (#F (f · g)) := idtoiso_2_1 _ _ (strict_psfunctor_comp F f g). Local Notation "'##'" := (strict_psfunctor_on_cells). Section StrictProjection. Context {C D : bicat}. Variable (F : strict_psfunctor C D). Definition strict_psfunctor_id2 : ∏ {a b : C} (f : a --> b), ##F (id2 f) = id2 (#F f) := pr1(pr2 F). Definition strict_psfunctor_vcomp : ∏ {a b : C} {f g h : C⟦a, b⟧} (η : f ==> g) (φ : g ==> h), ##F (η • φ) = ##F η • ##F φ := pr12(pr2 F). Definition strict_psfunctor_lunitor : ∏ {a b : C} (f : C⟦a, b⟧), lunitor (#F f) = (strict_psfunctor_id_cell F a ▹ #F f) • strict_psfunctor_comp_cell F (identity a) f • ##F (lunitor f) := pr122(pr2 F). Definition strict_psfunctor_runitor : ∏ {a b : C} (f : C⟦a, b⟧), runitor (#F f) = (#F f ◃ strict_psfunctor_id_cell F b) • strict_psfunctor_comp_cell F f (identity b) • ##F (runitor f) := pr1(pr222(pr2 F)). Definition strict_psfunctor_lassociator : ∏ {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) , (#F f ◃ strict_psfunctor_comp_cell F g h) • strict_psfunctor_comp_cell F f (g · h) • ##F (lassociator f g h) = (lassociator (#F f) (#F g) (#F h)) • (strict_psfunctor_comp_cell F f g ▹ #F h) • strict_psfunctor_comp_cell F (f · g) h := pr12(pr222(pr2 F)). Definition strict_psfunctor_lwhisker : ∏ {a b c : C} (f : C⟦a, b⟧) {g₁ g₂ : C⟦b, c⟧} (η : g₁ ==> g₂), strict_psfunctor_comp_cell F f g₁ • ##F (f ◃ η) = #F f ◃ ##F η • strict_psfunctor_comp_cell F f g₂ := pr122(pr222(pr2 F)). Definition strict_psfunctor_rwhisker : ∏ {a b c : C} {f₁ f₂ : C⟦a, b⟧} (g : C⟦b, c⟧) (η : f₁ ==> f₂), strict_psfunctor_comp_cell F f₁ g • ##F (η ▹ g) = ##F η ▹ #F g • strict_psfunctor_comp_cell F f₂ g := pr222(pr222(pr2 F)). End StrictProjection. (** Isos are preserved *) Definition strict_psfunctor_is_iso {C D : bicat} (F : strict_psfunctor C D) {a b : C} {f g : C⟦a,b⟧} (α : invertible_2cell f g) : is_invertible_2cell (##F α). Proof. use tpair. - exact (##F (α^-1)). - split ; cbn ; rewrite <- strict_psfunctor_vcomp, <- strict_psfunctor_id2 ; apply maponpaths. + apply vcomp_rinv. + apply vcomp_linv. Defined. Section StrictPseudoFunctorDerivedLaws. Context {C D : bicat}. Variable (F : strict_psfunctor C D). Definition strict_psfunctor_linvunitor {a b : C} (f : C⟦a, b⟧) : ##F (linvunitor f) = (linvunitor (#F f)) • ((strict_psfunctor_id_cell F a) ▹ #F f) • (strict_psfunctor_comp_cell F _ _). Proof. rewrite !vassocl. cbn. use vcomp_move_L_pM. { is_iso. } cbn. use vcomp_move_R_Mp. { refine (strict_psfunctor_is_iso F (linvunitor f ,, _)). is_iso. } cbn. rewrite strict_psfunctor_lunitor ; cbn. rewrite <- !vassocr. reflexivity. Qed. Definition strict_psfunctor_rinvunitor {a b : C} (f : C⟦a, b⟧) : ##F (rinvunitor f) = (rinvunitor (#F f)) • (#F f ◃ strict_psfunctor_id_cell F b) • strict_psfunctor_comp_cell F _ _. Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. use vcomp_move_R_Mp. { refine (strict_psfunctor_is_iso F (rinvunitor f ,, _)). is_iso. } cbn. rewrite strict_psfunctor_runitor ; cbn. rewrite <- !vassocr. reflexivity. Qed. Definition strict_psfunctor_rassociator {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) : (strict_psfunctor_comp_cell F f g ▹ #F h) • strict_psfunctor_comp_cell F (f · g) h • ##F (rassociator f g h) = (rassociator (#F f) (#F g) (#F h)) • (#F f ◃ strict_psfunctor_comp_cell F g h) • strict_psfunctor_comp_cell F f (g · h). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. use vcomp_move_R_Mp. { refine (strict_psfunctor_is_iso F (rassociator f g h ,, _)). is_iso. } cbn. symmetry. exact (strict_psfunctor_lassociator F f g h). Qed. Definition strict_psfunctor_comp_natural {a b c : C} {g₁ g₂ : C⟦b,c⟧} {f₁ f₂ : C⟦a,b⟧} (ηg : g₁ ==> g₂) (ηf : f₁ ==> f₂) : strict_psfunctor_comp_cell F f₁ g₁ • ##F (ηf ⋆ ηg) = (##F ηf) ⋆ (##F ηg) • strict_psfunctor_comp_cell F f₂ g₂. Proof. unfold hcomp. rewrite !strict_psfunctor_vcomp. rewrite !vassocr. rewrite !strict_psfunctor_rwhisker. rewrite !vassocl. rewrite strict_psfunctor_lwhisker. reflexivity. Qed. Definition strict_psfunctor_F_lunitor {a b : C} (f : C⟦a, b⟧) : ##F (lunitor f) = ((strict_psfunctor_comp_cell F (identity a) f)^-1) • ((strict_psfunctor_id_cell F a)^-1 ▹ #F f) • lunitor (#F f). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (!(strict_psfunctor_lunitor F f)). Qed. Definition strict_psfunctor_F_runitor {a b : C} (f : C⟦a,b⟧) : ##F (runitor f) = ((strict_psfunctor_comp_cell F f (identity b))^-1) • (#F f ◃ (strict_psfunctor_id_cell F b)^-1) • runitor (#F f). Proof. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (!(strict_psfunctor_runitor F f)). Qed. End StrictPseudoFunctorDerivedLaws. Definition strict_pstrans_data {C D : bicat} (F G : strict_psfunctor C D) : UU. Proof. refine (map1cells C D⟦_,_⟧). - apply F. - apply G. Defined. Definition is_strict_pstrans {C D : bicat} {F G : strict_psfunctor C D} (η : strict_pstrans_data F G) : UU := (∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (pr1 η X ◃ ##G α) • pr2 η _ _ g = (pr2 η _ _ f) • (##F α ▹ pr1 η Y)) × (∏ (X : C), (pr1 η X ◃ strict_psfunctor_id_cell G X) • pr2 η _ _ (id₁ X) = (runitor (pr1 η X)) • linvunitor (pr1 η X) • (strict_psfunctor_id_cell F X ▹ pr1 η X)) × (∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), (pr1 η X ◃ strict_psfunctor_comp_cell G f g) • pr2 η _ _ (f · g) = (lassociator (pr1 η X) (#G f) (#G g)) • (pr2 η _ _ f ▹ (#G g)) • rassociator (#F f) (pr1 η Y) (#G g) • (#F f ◃ pr2 η _ _ g) • lassociator (#F f) (#F g) (pr1 η Z) • (strict_psfunctor_comp_cell F f g ▹ pr1 η Z)). Definition make_strict_pstrans {C D : bicat} {F G : strict_psfunctor C D} (η : strict_pstrans_data F G) (Hη : is_strict_pstrans η) : F --> G. Proof. refine ((η ,, _) ,, tt). repeat split ; cbn ; intros ; apply Hη. Defined. Definition strict_modification_eq {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} {m m' : σ ==> τ} (p : ∏ (X : B), pr111 m X = pr111 m' X) : m = m'. Proof. use subtypePath. { intro. simpl. exact isapropunit. } use subtypePath. { intro. simpl. repeat (apply isapropdirprod) ; apply isapropunit. } use subtypePath. { intro. simpl. repeat (apply impred ; intro). apply B'. } use funextsec. exact p. Qed. Definition is_strict_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : ∏ (X : B), pr111 σ X ==> pr111 τ X) : UU := ∏ (X Y : B) (f : X --> Y), pr211 σ _ _ f • (m Y ▻ #F f) = #G f ◅ m X • pr211 τ _ _ f. Definition make_strict_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : ∏ (X : B), pr111 σ X ==> pr111 τ X) (Hm : is_strict_modification m) : σ ==> τ := (((m ,, Hm) ,, (tt ,, tt ,, tt)),, tt). Definition make_is_invertible_strict_modification_inv_is_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : σ ==> τ) (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X)) : ∏ (X Y : B) (f : B ⟦ X, Y ⟧), (pr211 τ) X Y f • (# F f ◃ (Hm Y) ^-1) = ((Hm X) ^-1 ▹ # G f) • (pr211 σ) X Y f. Proof. intros X Y f. simpl. use vcomp_move_R_Mp. { is_iso. } simpl. rewrite <- vassocr. use vcomp_move_L_pM. { is_iso. } symmetry. simpl. exact (pr211 m X Y f). Qed. Definition inv_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : σ ==> τ) (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X)) : τ ==> σ. Proof. use make_strict_modification. - exact (λ X, (Hm X)^-1). - exact (make_is_invertible_strict_modification_inv_is_modification m Hm). Defined. Definition modification_inv_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : σ ==> τ) (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X)) : m • inv_modification m Hm = id₂ σ. Proof. use strict_modification_eq. intro X. cbn. exact (vcomp_rinv (Hm X)). Qed. Definition inv_modification_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : σ ==> τ) (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X)) : inv_modification m Hm • m = id₂ τ. Proof. use strict_modification_eq. intro X. cbn. exact (vcomp_linv (Hm X)). Qed. Definition make_is_invertible_strict_modification {B B' : bicat} {F G : strict_psfunctor B B'} {σ τ : F --> G} (m : σ ==> τ) (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X)) : is_invertible_2cell m. Proof. use make_is_invertible_2cell. - exact (inv_modification m Hm). - exact (modification_inv_modification m Hm). - exact (inv_modification_modification m Hm). Defined. Module Notations. Notation "'##'" := (strict_psfunctor_on_cells). End Notations. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/UniversalArrow.v000066400000000000000000000261141451125700300254150ustar00rootroot00000000000000(************************************************************** Universal arrows One way to construct biadjunctions, is via universal arrows. These come in two flavors: one to give left biadjoints and one to give right biadjoints. Contents 1. Right universal arrows 2. Left universal arrows **************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. (** 1. Right universal arrows *) Section RightUniversalArrow. Context {B₁ B₂ : bicat} (L : psfunctor B₁ B₂). Definition right_universal_arrow_functor_data (x : B₁) (y : B₂) {R : B₂ → B₁} (ε : ∏ (x : B₂), L(R x) --> x) : functor_data (hom x (R y)) (hom (L x) y). Proof. use make_functor_data. - exact (λ f, #L f · ε y). - exact (λ f g α, ##L α ▹ ε y). Defined. Definition right_universal_arrow_functor_is_functor (x : B₁) (y : B₂) {R : B₂ → B₁} (ε : ∏ (x : B₂), L(R x) --> x) : is_functor (right_universal_arrow_functor_data x y ε). Proof. split. - intro f ; cbn. rewrite psfunctor_id2. rewrite id2_rwhisker. apply idpath. - intros f g h α β ; cbn. rewrite psfunctor_vcomp. rewrite rwhisker_vcomp. apply idpath. Qed. Definition right_universal_arrow_functor (x : B₁) (y : B₂) {R : B₂ → B₁} (ε : ∏ (x : B₂), L(R x) --> x) : hom x (R y) ⟶ hom (L x) y. Proof. use make_functor. - exact (right_universal_arrow_functor_data x y ε). - exact (right_universal_arrow_functor_is_functor x y ε). Defined. Definition right_universal_arrow : UU := ∑ (R : B₂ → B₁) (ε : ∏ (x : B₂), L(R x) --> x), ∏ (x : B₁) (y : B₂), adj_equivalence_of_cats (right_universal_arrow_functor x y ε). Section Constructor. Context (R : B₂ → B₁) (ε : ∏ (x : B₂), L(R x) --> x) (inv : ∏ (x : B₁) (y : B₂), hom (L x) y ⟶ hom x (R y)) (unit_adj : ∏ (x : B₁) (y : B₂), functor_identity _ ⟹ right_universal_arrow_functor x y ε ∙ inv x y) (counit_adj : ∏ (x : B₁) (y : B₂), inv x y ∙ right_universal_arrow_functor x y ε ⟹ functor_identity _) (unit_iso : ∏ (x : B₁) (y : B₂) (f : x --> R y), is_z_isomorphism (unit_adj x y f)) (counit_iso : ∏ (x : B₁) (y : B₂) (f : L x --> y), is_z_isomorphism (counit_adj x y f)). Definition make_right_universal_arrow_equivalence (x : B₁) (y : B₂) : equivalence_of_cats (hom x (R y)) (hom (L x) y). Proof. simple refine ((_ ,, (_ ,, (_ ,, _))) ,, _ ,, _) ; cbn. - exact (right_universal_arrow_functor x y ε). - exact (inv x y). - exact (unit_adj x y). - exact (counit_adj x y). - exact (unit_iso x y). - exact (counit_iso x y). Defined. Definition make_right_universal_arrow : right_universal_arrow. Proof. simple refine (R ,, ε ,, _) ; cbn. intros x y. exact (adjointification (make_right_universal_arrow_equivalence x y)). Defined. End Constructor. Section Constructor. Context (HB₁ : is_univalent_2_1 B₁) (R : B₂ → B₁) (ε : ∏ (x : B₂), L(R x) --> x) (H₁ : ∏ (x : B₁) (y : B₂) (f g : x --> R y) (α : # L f · ε y ==> # L g · ε y), ∑ (β : f ==> g), ##L β ▹ ε y = α) (H₂ : ∏ (x : B₁) (y : B₂) (f g : x --> R y) (α : # L f · ε y ==> # L g · ε y) (β₁ β₂ : f ==> g) (p₁ : ##L β₁ ▹ ε y = α) (p₂ : ##L β₂ ▹ ε y = α), β₁ = β₂) (H₃ : ∏ (x : B₁) (y : B₂) (f : L x --> y), ∑ (g : x --> R y), invertible_2cell (# L g · ε y) f). Definition make_right_universal_arrow' : right_universal_arrow. Proof. simple refine (R ,, ε ,, _) ; cbn. intros x y. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB₁. - use full_and_faithful_implies_fully_faithful. split. + intros f g α. apply hinhpr. apply H₁. + intros f g α. use invproofirrelevance. intros β₁ β₂ ; cbn in *. use subtypePath ; [ intro ; apply cellset_property | ]. exact (H₂ x y f g α (pr1 β₁) (pr1 β₂) (pr2 β₁) (pr2 β₂)). - intros f. apply hinhpr. simple refine (_ ,, _). + exact (pr1 (H₃ x y f)). + simpl. apply inv2cell_to_z_iso. exact (pr2 (H₃ x y f)). Defined. End Constructor. End RightUniversalArrow. (** 2. Left universal arrows *) Section LeftUniversalArrow. Context {B₁ B₂ : bicat} (R : psfunctor B₂ B₁). Definition left_universal_arrow_functor_data (x : B₁) (y : B₂) {L : B₁ → B₂} (η : ∏ (x : B₁), x --> R(L x)) : functor_data (hom (L x) y) (hom x (R y)). Proof. use make_functor_data. - exact (λ f, η x · #R f). - exact (λ f g α, η x ◃ ##R α). Defined. Definition left_universal_arrow_functor_is_functor (x : B₁) (y : B₂) {L : B₁ → B₂} (η : ∏ (x : B₁), x --> R(L x)) : is_functor (left_universal_arrow_functor_data x y η). Proof. split. - intro f ; cbn. rewrite psfunctor_id2. rewrite lwhisker_id2. apply idpath. - intros f g h α β ; cbn. rewrite psfunctor_vcomp. rewrite lwhisker_vcomp. apply idpath. Qed. Definition left_universal_arrow_functor (x : B₁) (y : B₂) {L : B₁ → B₂} (η : ∏ (x : B₁), x --> R(L x)) : hom (L x) y ⟶ hom x (R y). Proof. use make_functor. - exact (left_universal_arrow_functor_data x y η). - exact (left_universal_arrow_functor_is_functor x y η). Defined. Definition left_universal_arrow : UU := ∑ (L : B₁ → B₂) (η : ∏ (x : B₁), x --> R(L x)), ∏ (x : B₁) (y : B₂), adj_equivalence_of_cats (left_universal_arrow_functor x y η). Section Constructor. Context (L : B₁ → B₂) (η : ∏ (x : B₁), x --> R(L x)) (inv : ∏ (x : B₁) (y : B₂), hom x (R y) ⟶ hom (L x) y) (unit_adj : ∏ (x : B₁) (y : B₂), functor_identity _ ⟹ left_universal_arrow_functor x y η ∙ inv x y) (counit_adj : ∏ (x : B₁) (y : B₂), inv x y ∙ left_universal_arrow_functor x y η ⟹ functor_identity _) (unit_iso : ∏ (x : B₁) (y : B₂) (f : L x --> y), is_z_isomorphism (unit_adj x y f)) (counit_iso : ∏ (x : B₁) (y : B₂) (f : x --> R y), is_z_isomorphism (counit_adj x y f)). Definition make_left_universal_arrow_equivalence (x : B₁) (y : B₂) : equivalence_of_cats (hom (L x) y) (hom x (R y)). Proof. simple refine ((_ ,, (_ ,, (_ ,, _))) ,, _ ,, _) ; cbn. - exact (left_universal_arrow_functor x y η). - exact (inv x y). - exact (unit_adj x y). - exact (counit_adj x y). - exact (unit_iso x y). - exact (counit_iso x y). Defined. Definition make_left_universal_arrow : left_universal_arrow. Proof. simple refine (L ,, η ,, _) ; cbn. intros x y. exact (adjointification (make_left_universal_arrow_equivalence x y)). Defined. End Constructor. Section Constructor. Context (HB₂ : is_univalent_2_1 B₂) (L : B₁ → B₂) (η : ∏ (x : B₁), x --> R(L x)) (H₁ : ∏ (x : B₁) (y : B₂) (f g : L x --> y) (α : η x · # R f ==> η x · # R g), ∑ (β : f ==> g), η x ◃ ## R β = α) (H₂ : ∏ (x : B₁) (y : B₂) (f g : L x --> y) (α : η x · # R f ==> η x · # R g) (β₁ β₂ : f ==> g) (p₁ : η x ◃ ##R β₁ = α) (p₂ : η x ◃ ##R β₂ = α), β₁ = β₂) (H₃ : ∏ (x : B₁) (y : B₂) (f : x --> R y), ∑ (g : L x --> y), invertible_2cell (η x · # R g) f). Definition make_left_universal_arrow' : left_universal_arrow. Proof. simple refine (L ,, η ,, _) ; cbn. intros x y. use rad_equivalence_of_cats. - apply is_univ_hom. exact HB₂. - use full_and_faithful_implies_fully_faithful. split. + intros f g α. apply hinhpr. apply H₁. + intros f g α. use invproofirrelevance. intros β₁ β₂ ; cbn in *. use subtypePath ; [ intro ; apply cellset_property | ]. exact (H₂ x y f g α (pr1 β₁) (pr1 β₂) (pr2 β₁) (pr2 β₂)). - intros f. apply hinhpr. simple refine (_ ,, _). + exact (pr1 (H₃ x y f)). + simpl. apply inv2cell_to_z_iso. exact (pr2 (H₃ x y f)). Defined. End Constructor. End LeftUniversalArrow. UniMath-20231010/UniMath/Bicategories/PseudoFunctors/Yoneda.v000066400000000000000000000171601451125700300236520ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Yoneda embedding Niccolò Veltri, Niels van der Weide April 2019 ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.Core.Examples.OpMorBicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Representable. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.Modifications.Modification. Local Open Scope bicategory_scope. Local Open Scope cat. Section Yoneda. Context {C : bicat}. Variable (C_is_univalent_2_1 : is_univalent_2_1 C). Definition representable_id_inv2cell (X : C) : invertible_modification_data (id_pstrans (representable C_is_univalent_2_1 X)) (representable1 C_is_univalent_2_1 (id₁ X)). Proof. intro Y. use make_invertible_2cell. - use make_nat_trans. * intro f. cbn in *. apply rinvunitor. * abstract (intros f g η ; cbn in * ; rewrite rwhisker_hcomp ; apply rinvunitor_natural). - use make_is_invertible_2cell. + use make_nat_trans. * intro f. cbn in *. apply runitor. * abstract (intros f g η ; cbn ; apply vcomp_runitor). + use nat_trans_eq. { exact (pr2 C Y X). } abstract (intro f ; cbn in * ; apply rinvunitor_runitor). + use nat_trans_eq. { exact (pr2 C Y X). } abstract (intro f ; cbn in * ; apply runitor_rinvunitor). Defined. Definition representable_id_is_mod (X : C) : is_modification (representable_id_inv2cell X). Proof. intros Y Z f. use nat_trans_eq. { exact (pr2 C Z X). } intro g. cbn in *. repeat (rewrite id2_left). symmetry. apply rinvunitor_triangle. Qed. Definition representable_id_invmod (X : C) : invertible_modification (id_pstrans _) (representable1 C_is_univalent_2_1 (id₁ X)). Proof. use make_invertible_modification. - exact (representable_id_inv2cell X). - exact (representable_id_is_mod X). Defined. Definition representable_comp_inv2cell {X Y Z: C} (f : X --> Y) (g : Y --> Z) : invertible_modification_data (comp_pstrans (representable1 C_is_univalent_2_1 f) (representable1 C_is_univalent_2_1 g)) (representable1 C_is_univalent_2_1 (f · g)). Proof. intro W. use make_invertible_2cell. - use make_nat_trans. + intro h. cbn in *. apply rassociator. + abstract (intros V U h; cbn in *; apply rwhisker_rwhisker_alt). - use make_is_invertible_2cell. + use make_nat_trans. * intro h. cbn in *. apply lassociator. * abstract (intros h k η; cbn in *; symmetry; apply rwhisker_rwhisker). + use nat_trans_eq. { exact (pr2 C W Z). } abstract (intro h; cbn in *; apply rassociator_lassociator). + use nat_trans_eq. { exact (pr2 C W Z). } abstract (intro h; cbn in *; apply lassociator_rassociator). Defined. Definition representable_comp_is_mod {X Y Z: C} (f : X --> Y) (g : Y --> Z) : is_modification (representable_comp_inv2cell f g). Proof. intros W V h. use nat_trans_eq. { exact (pr2 C V Z). } intros k. cbn in *. repeat (rewrite id2_left). repeat (rewrite id2_right). rewrite rwhisker_hcomp. rewrite <- vassocr. symmetry. rewrite lwhisker_hcomp. apply inverse_pentagon_5. Qed. Definition representable_comp_invmod {X Y Z: C} (f : X --> Y) (g : Y --> Z) : invertible_modification (comp_pstrans (representable1 C_is_univalent_2_1 f) (representable1 C_is_univalent_2_1 g)) (representable1 C_is_univalent_2_1 (f · g)). Proof. use make_invertible_modification. - exact (representable_comp_inv2cell f g). - exact (representable_comp_is_mod f g). Defined. Definition y_data : psfunctor_data C (psfunctor_bicat (op1_bicat C) bicat_of_univ_cats). Proof. use make_psfunctor_data. - exact (representable C_is_univalent_2_1). - intros X Y. exact (representable1 C_is_univalent_2_1). - intros X Y f g. exact (representable2 C_is_univalent_2_1). - intro X. apply (representable_id_invmod X). - intros X Y Z f g. apply (representable_comp_invmod f g). Defined. Definition y_laws : psfunctor_laws y_data. Proof. repeat split; cbn. - intros X Y f. use modification_eq. intro Z. use nat_trans_eq. { exact (pr2 C Z Y). } intro g. cbn in *. apply lwhisker_id2. - intros X Y f g h η φ. use modification_eq. intro Z. use nat_trans_eq. { exact (pr2 C Z Y). } intro k. cbn in *. symmetry. apply lwhisker_vcomp. - intros X Y f. use modification_eq. intro Z. use nat_trans_eq. { exact (pr2 C Z Y). } intro g. cbn in *. symmetry. rewrite <- vassocr. rewrite lunitor_lwhisker. rewrite rwhisker_vcomp. rewrite rinvunitor_runitor. apply id2_rwhisker. - intros X Y f. use modification_eq. intro Z. use nat_trans_eq. { exact (pr2 C Z Y). } intro g. cbn in *. symmetry. rewrite <- vassocr. rewrite runitor_triangle. apply rinvunitor_runitor. - intros X Y Z W f g h. use modification_eq. intro V. use nat_trans_eq. { exact (pr2 C V W). } intro k. cbn in *. rewrite id2_left. symmetry. rewrite rwhisker_hcomp. rewrite inverse_pentagon_6. rewrite lwhisker_hcomp. apply vassocr. - intros X Y Z f g h η. use modification_eq. intro W. use nat_trans_eq. { exact (pr2 C W Z). } intro k. cbn in *. apply lwhisker_lwhisker_rassociator. - intros X Y Z f g h η. use modification_eq. intro W. use nat_trans_eq. { exact (pr2 C W Z). } intro k. cbn in *. apply rwhisker_lwhisker_rassociator. Qed. Definition y_invertible_cells : invertible_cells y_data. Proof. split. - intro X. apply (representable_id_invmod X). - intros X Y Z f g. apply (representable_comp_invmod f g). Defined. Definition y : psfunctor C (psfunctor_bicat (op1_bicat C) bicat_of_univ_cats). Proof. use make_psfunctor. - exact y_data. - exact y_laws. - exact y_invertible_cells. Defined. End Yoneda. UniMath-20231010/UniMath/Bicategories/README.md000066400000000000000000000011061451125700300205310ustar00rootroot00000000000000Bicategories ============ The contribution in this directory is illustrated and discussed in > Bicategories in Univalent Foundations > Benedikt Ahrens, Dan Frumin, Marco Maggesi, Niccolò Veltri, Niels van der Weide > Formal Structures for Computation and Deduction (FSCD) 2019, LIPIcs Vol. 131, pp. 5:1-5:17 > DOI: [10.4230/LIPIcs.FSCD.2019.5](https://doi.org/10.4230/LIPIcs.FSCD.2019.5) A revised and extended version of the same article will appear on Mathematical Structures in Computer Science. Preprint versions: [arXiv:1903.01152](https://arxiv.org/abs/1903.01152) UniMath-20231010/UniMath/Bicategories/RezkCompletions/000077500000000000000000000000001451125700300224045ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/RezkCompletions/BicatToLocalUnivalentBicat.v000066400000000000000000002516721451125700300277410ustar00rootroot00000000000000(* In this file, it is shown how any bicategory is weakly biequivalent to a locally univalent bicategory. From any bicategory B, we construct a locally univalent bicategory LRB "local Rezk completion of B", which is defined by the following data: ob LRB := ob B. hom x y := RC(hom x y), where RC is the Rezk completion for categories. Since each hom-category of LRB is univalent, it is indeed locally univalent . There is a pseudofunctor from B to LRB which is the identity on objects and its action on morphisms is induced by the unit of the rezk completion of RC(hom _ _). Most work lies in showing how LRB is indeed a bicategory. In essence, this follows since all pieces of data (at level 1 and 2) of a bicategory correspond with a functor between some hom-categories. Those pieces of data can then be constructed using the universal property of the Rezk completion. As a consequence, we can conclude that any bicategory admits a Rezk completion (this is formulated in Bicategories/RezkCompletions/RezkCompletion.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.PrecompEquivalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.RezkCompletion. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.YonedaLemma. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Local Open Scope cat. Section FunctorCompositionWeakBiequivalences. Lemma comp_local_weak_equivalence {B1 B2 B3 : bicat} {F : psfunctor B1 B2} {G : psfunctor B2 B3} (Feso : local_weak_equivalence F) (Geso : local_weak_equivalence G) : local_weak_equivalence (comp_psfunctor G F). Proof. intros x y. split. - use (comp_essentially_surjective (Fmor F x y) _ (Fmor G _ _)). + exact (pr1 (Feso x y)). + apply (pr1 (Geso _ _)). - use (comp_ff_is_ff _ _ _ (Fmor F x y) _ (Fmor G _ _)). + exact (pr2 (Feso x y)). + apply (pr2 (Geso _ _)). Defined. Lemma comp_essentially_surjective {B1 B2 B3 : bicat} {F : psfunctor B1 B2} {G : psfunctor B2 B3} (Feso : essentially_surjective F) (Geso : essentially_surjective G) : essentially_surjective (comp_psfunctor G F). Proof. intro z. use (factor_through_squash_hProp _ _ (Geso z)). intros [y yp]. use (factor_through_squash_hProp _ _ (Feso y)). intros [x xp]. apply hinhpr. exists x. use (Composition.comp_adjequiv _ yp). use (psfunctor_preserve_adj_equiv G). exact xp. Qed. Lemma comp_weak_biequivalence {B1 B2 B3 : bicat} {F : psfunctor B1 B2} {G : psfunctor B2 B3} (Fw : weak_biequivalence F) (Gw : weak_biequivalence G) : weak_biequivalence (comp_psfunctor G F). Proof. split. - apply (comp_essentially_surjective (pr1 Fw) (pr1 Gw)). - apply (comp_local_weak_equivalence (pr2 Fw) (pr2 Gw)). Defined. End FunctorCompositionWeakBiequivalences. Section LocalUnivalenceRezk. Context (RC : RezkCat). Let R : category -> univalent_category := λ C, pr1 (RC C). Let η : ∏ C : category, functor C (R C) := λ C, pr12 (RC C). Let eso : ∏ C : category, Functors.essentially_surjective (η C) := λ C, pr122 (RC C). Let ff : ∏ C : category, Functors.fully_faithful (η C) := λ C, pr222 (RC C). Notation "η_{ x , y }" := (η (hom x y)). Notation "eso_{ x , y }" := (eso (hom x y)). Notation "ff_{ x , y }" := (ff (hom x y)). Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Notation "( c , d )" := (make_catbinprod c d). Notation "( f #, g )" := (catbinprodmor f g). Context (B : bicat). Definition LRB_precat_ob_mor : precategory_ob_mor. Proof. exists (ob B). exact (λ x y, ob (R (hom x y))). Defined. Definition LRB_composition (x y z : B) : functor (R (hom x y) ⊠ R (hom y z)) (R (hom x z)). Proof. use lift_functor_along. - exact (hom x y ⊠ hom y z). - exact (pair_functor (η_{x,y}) (η_{y,z})). - apply pair_functor_eso ; apply eso. - apply pair_functor_ff ; apply ff. - exact (functor_composite hcomp_functor (η (hom x z))). Defined. Definition LRB_composition_comm (x y z : B) : nat_z_iso (functor_composite (pair_functor (η (hom _ _)) (η (hom _ _))) (LRB_composition x y z)) (functor_composite hcomp_functor (η (hom x z))) := lift_functor_along_comm _ _ _ _ _. Definition LRB_composition_curry1 (x y z : B) : functor (R (hom x y)) (FunctorCategory.functor_category (R (hom y z)) (R (hom x z))) := curry_functor' (LRB_composition x y z). Definition LRB_composition_curry2 (x y z : B) : functor (R (hom y z)) (FunctorCategory.functor_category (R (hom x y)) (R (hom x z))) := curry_functor _ _ _ (LRB_composition x y z). Definition LRB_precat_data : precategory_data. Proof. use make_precategory_data. - exact LRB_precat_ob_mor. - exact (λ x, η (hom x x) (identity x)). - exact (λ x y z f g, LRB_composition x y z (f , g)). Defined. Definition LRB_prebicat_2cell_struct : prebicat_2cell_struct LRB_precat_data := λ x y f g, (R (hom x y))⟦f,g⟧. Definition LRB_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells. Proof. exists LRB_precat_data. exact LRB_prebicat_2cell_struct. Defined. Local Definition LRB_functor_lcomp_id (x y : B) : functor (R (hom x y)) (R (hom x y)). Proof. use (lift_functor_along (R (hom x y)) _ (eso (hom x y)) (ff_{x,y})). use (functor_composite _ (η_{x,y})). use functor_composite. - exact (hom x x ⊠ hom x y). - use bindelta_pair_functor. + apply constant_functor. exact (identity x). + apply functor_identity. - apply hcomp_functor. Defined. Definition LRB_lunitor_nat_z_iso_pre (x y : B) : nat_z_iso (η_{x,y} ∙ (bindelta_pair_functor (constant_functor (R (hom x y)) (R (hom x x)) (η (hom x x) (id₁ x))) (functor_identity (R (hom x y))) ∙ LRB_composition x x y)) (η_{x,y} ∙ functor_identity (R (hom x y))). Proof. transparent assert (p : (nat_z_iso (η_{x,y} ∙ (bindelta_pair_functor (constant_functor (R (hom x y)) (R (hom x x)) (η (hom x x) (id₁ x))) (functor_identity (R (hom x y))) )) (bindelta_pair_functor (constant_functor (hom x y) (hom x x) (id₁ x)) (functor_identity (hom x y)) ∙ (pair_functor (η (hom x x)) (η_{x,y})))) ). { use make_nat_z_iso. - use make_nat_trans. + intro ; apply identity. + intro ; intros. cbn. do 3 rewrite id_left. rewrite id_right. apply maponpaths_2. apply (! functor_id (η (hom x x)) _). - intro ; apply (identity_is_z_iso (C := _ ⊠ _)). } use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use (nat_z_iso_comp (post_whisker_nat_z_iso p _) _). use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). use (nat_z_iso_comp (pre_whisker_nat_z_iso _ _) _). 2: apply lift_functor_along_comm. use (nat_z_iso_comp _ (nat_z_iso_inv (functor_commutes_with_id _))). use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use post_whisker_nat_z_iso. use make_nat_z_iso. - apply lunitor_transf. - intro ; apply is_z_iso_lunitor. Defined. Definition LRB_runitor_nat_z_iso_pre (x y : B) : nat_z_iso (η_{x,y} ∙ (bindelta_pair_functor (functor_identity (R (hom x y))) (constant_functor (R (hom x y)) (R (hom y y)) (η (hom y y) (id₁ y))) ∙ LRB_composition x y y)) (η_{x,y} ∙ functor_identity (R (hom x y))). Proof. transparent assert (p : (nat_z_iso (η_{x,y} ∙ (bindelta_pair_functor (functor_identity (R (hom x y))) (constant_functor (R (hom x y)) (R (hom y y)) (η (hom y y) (id₁ y))) )) (bindelta_pair_functor (functor_identity (hom x y)) (constant_functor (hom x y) (hom y y) (id₁ y)) ∙ (pair_functor (η_{x,y}) (η (hom y y))))) ). { use make_nat_z_iso. - use make_nat_trans. + intro ; apply identity. + intro ; intros. cbn. do 3 rewrite id_left. rewrite id_right. apply maponpaths. apply (! functor_id (η (hom y y)) _). - intro ; apply (identity_is_z_iso (C := _ ⊠ _)). } use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use (nat_z_iso_comp (post_whisker_nat_z_iso p _) _). use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). use (nat_z_iso_comp (pre_whisker_nat_z_iso _ _) _). 2: apply lift_functor_along_comm. use (nat_z_iso_comp _ (nat_z_iso_inv (functor_commutes_with_id _))). use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use post_whisker_nat_z_iso. use make_nat_z_iso. - apply runitor_transf. - intro ; apply is_z_iso_runitor. Defined. Definition LRB_lunitor_nat_z_iso (x y : B) : nat_z_iso (functor_composite (bindelta_pair_functor (constant_functor _ _ (η (hom x x) (identity x))) (functor_identity _)) (LRB_composition x x y) ) (functor_identity (R (hom x y))). Proof. apply (lift_nat_z_iso_along (R (hom x y)) _ (eso (hom x y)) (ff_{x,y})). apply LRB_lunitor_nat_z_iso_pre. Defined. Definition LRB_lunitor {x y : B} (f : R (hom x y)) : z_iso (LRB_composition x x y (η (hom x x) (identity x) , f)) f. Proof. use make_z_iso ; try (apply (LRB_lunitor_nat_z_iso x y)). split ; apply (pr2 (LRB_lunitor_nat_z_iso x y)). Defined. Definition LRB_runitor_nat_z_iso (x y : B) : nat_z_iso (functor_composite (bindelta_pair_functor (functor_identity _) (constant_functor _ _ (η (hom y y) (identity y))) ) (LRB_composition x y y) ) (functor_identity (R (hom x y))). Proof. apply (lift_nat_z_iso_along (R (hom x y)) _ (eso (hom x y)) (ff_{x,y})). apply LRB_runitor_nat_z_iso_pre. Defined. Definition LRB_runitor {x y : B} (f : R (hom x y)) : z_iso (LRB_composition x y y (f, η (hom y y) (identity y))) f. Proof. use make_z_iso ; try (apply (LRB_runitor_nat_z_iso x y)). split ; apply (pr2 (LRB_runitor_nat_z_iso x y)). Defined. Let LRB_lunitor_comm := λ x y : B, lift_nat_trans_along_comm (R (hom x y)) _ (eso (hom x y)) (ff_{x,y}) (LRB_lunitor_nat_z_iso_pre x y). Let LRB_runitor_comm := λ x y : B, lift_nat_trans_along_comm (R (hom x y)) _ (eso (hom x y)) (ff_{x,y}) (LRB_runitor_nat_z_iso_pre x y). Definition LRB_lwhisker {x y z : B} (f : R (hom x y)) {g1 g2 : R (hom y z)} (α : R (hom y z) ⟦ g1, g2 ⟧) : R (hom x z) ⟦LRB_composition _ _ _ (f, g1), LRB_composition _ _ _ (f, g2)⟧ := #(LRB_composition_curry1 x y z f : functor _ _) α. Definition LRB_rwhisker {x y z : B} {f1 f2 : R (hom x y)} (α : R (hom x y) ⟦ f1, f2 ⟧) (g: R (hom y z)) : R (hom x z) ⟦LRB_composition _ _ _ (f1, g), LRB_composition _ _ _ (f2, g)⟧ := #(LRB_composition_curry2 x y z g : functor _ _) α. Definition LRB_associator_nat_z_iso_pre (x y z w : B) : nat_z_iso (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ (((precategory_binproduct_assoc (R (hom x y)) (R (hom y z)) (R (hom z w))) ∙ pair_functor (LRB_composition x y z) (functor_identity (R (hom z w)))) ∙ LRB_composition x z w) ) (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ (pair_functor (functor_identity (R (hom x y))) (LRB_composition y z w) ∙ LRB_composition x y w)). Proof. use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). transparent assert (p : (nat_z_iso (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ precategory_binproduct_assoc (R (hom x y)) (R (hom y z)) (R (hom z w))) (precategory_binproduct_assoc (hom x y) (hom y z) (hom z w) ∙ (pair_functor (pair_functor (η_{x,y}) (η_{y,z})) (η (hom z w)))))). { use make_nat_z_iso. - use make_nat_trans. + intro ; apply identity. + intro ; intros. cbn. do 3 rewrite id_left. now do 3 rewrite id_right. - intro ; apply (identity_is_z_iso (C := _ ⊠ _)). } transparent assert (q : (nat_z_iso (pair_functor (pair_functor (η_{x,y}) (η_{y,z})) (η (hom z w)) ∙ pair_functor (LRB_composition x y z) (functor_identity (R (hom z w)))) (pair_functor hcomp_functor (functor_identity (hom z w)) ∙ (pair_functor (η _) (η _))) ) ). { use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_pair _ _ _ _))). use (nat_z_iso_comp _ (nat_z_iso_pair _ _ _ _)). use nat_z_iso_between_pair. - apply LRB_composition_comm. - apply functor_commutes_with_id. } transparent assert ( q' : (nat_z_iso ((pair_functor (functor_identity (hom x y)) hcomp_functor) ∙ pair_functor (η (hom _ _)) (η (hom _ _))) (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ pair_functor (functor_identity (R (hom x y))) (LRB_composition y z w)))). { use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_pair _ _ _ _))). use (nat_z_iso_comp _ (nat_z_iso_pair _ _ _ _)). use nat_z_iso_between_pair. - apply functor_commutes_with_id. - apply nat_z_iso_inv, LRB_composition_comm. } use (nat_z_iso_comp (post_whisker_nat_z_iso _ _) _). 2: { use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use (nat_z_iso_comp (post_whisker_nat_z_iso p _) _). use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). apply (pre_whisker_nat_z_iso _ q). } use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). use (nat_z_iso_comp (pre_whisker_nat_z_iso _ _) _). 2: { use (nat_z_iso_comp (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). use (pre_whisker_nat_z_iso _ _). 2: apply LRB_composition_comm. } use (nat_z_iso_comp (pre_whisker_nat_z_iso _ _) _). 2: apply (nat_z_iso_functor_comp_assoc _ _ _). use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use (nat_z_iso_comp (post_whisker_nat_z_iso _ _) _). 2: { use (nat_z_iso_comp (nat_z_iso_functor_comp_assoc _ _ _)). use tpair. - exact (rassociator_transf x y z w). - intro ; apply is_z_iso_rassociator. } use (nat_z_iso_comp _ (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _))). use (nat_z_iso_comp _ (post_whisker_nat_z_iso q' _)). use (nat_z_iso_comp _ (nat_z_iso_functor_comp_assoc _ _ _)). use (nat_z_iso_comp _ (pre_whisker_nat_z_iso _ _)). 3: apply nat_z_iso_inv, LRB_composition_comm. apply nat_z_iso_inv, nat_z_iso_functor_comp_assoc. Defined. Lemma LRB_lunitor_pre_simpl {x y : B} (f : B⟦x,y⟧) : pr1 (LRB_lunitor_nat_z_iso_pre x y) f = (pr1 (LRB_composition_comm x x y) (id₁ x : hom _ _, f : hom _ _) · #(η_{x,y}) (lunitor f)). Proof. cbn. rewrite ! id_left. etrans. { apply maponpaths_2, maponpaths, binprod_id. } etrans. { apply maponpaths_2, functor_id. } refine (id_left _ @ _). now rewrite id_right. Qed. Lemma LRB_runitor_pre_simpl {x y : B} (f : B⟦x,y⟧) : pr1 (LRB_runitor_nat_z_iso_pre x y) f = (pr1 (LRB_composition_comm x y y) (_,_)) · #(η_{x,y}) (runitor f). Proof. cbn. rewrite ! id_left. etrans. { apply maponpaths_2, maponpaths, binprod_id. } etrans. { apply maponpaths_2, functor_id. } refine (id_left _ @ _). now rewrite id_right. Qed. Definition LRB_associator_nat_z_iso (x y z w : B) : nat_z_iso (functor_composite (functor_composite (precategory_binproduct_assoc (R (hom (C := B) x y)) (R (hom (C := B) y z)) (R (hom (C := B) z w)) ) (pair_functor (LRB_composition x y z) (functor_identity (R (hom z w))) ) ) (LRB_composition x z w) ) (functor_composite (pair_functor (functor_identity (R (hom (C := B) x y))) (LRB_composition y z w)) (LRB_composition x y w)). Proof. use lift_nat_z_iso_along. - exact ((hom x y) ⊠ ((hom y z) ⊠ (hom z w))). - repeat (apply pair_functor) ; apply (η (hom _ _)). - repeat (apply pair_functor_eso) ; apply eso. - repeat (apply pair_functor_ff) ; apply ff. - exact (LRB_associator_nat_z_iso_pre x y z w). Defined. Let eso3 := λ C1 C2 C3 : category, pair_functor_eso _ _ (eso C1) (pair_functor_eso _ _ (eso C2) (eso C3)). Let ff3 := λ C1 C2 C3 : category, pair_functor_ff _ _ (ff C1) (pair_functor_ff _ _ (ff C2) (ff C3)). Lemma LRB_associator_comm (x y z w : B) : pre_whisker (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w)))) (lift_nat_trans_along (R (hom x w)) (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w)))) (eso3 _ _ _) (ff3 _ _ _) (LRB_associator_nat_z_iso_pre x y z w) ) = LRB_associator_nat_z_iso_pre x y z w. Proof. apply (lift_nat_trans_along_comm _ _ _ _ (LRB_associator_nat_z_iso_pre x y z w)). Defined. Definition LRB_associator_pre_simpl_mor {x y z w : B} (f : B⟦x,y⟧) (g : B⟦y,z⟧) (h : B⟦z,w⟧) : R (hom x w) ⟦ (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ ((precategory_binproduct_assoc (R (hom x y)) (R (hom y z)) (R (hom z w)) ∙ pair_functor (LRB_composition x y z) (functor_identity (R (hom z w)))) ∙ LRB_composition x z w)) (f : hom x y, (g : hom y z, h : hom z w)), (pair_functor (η_{x,y}) (pair_functor (η_{y,z}) (η (hom z w))) ∙ (pair_functor (functor_identity (R (hom x y))) (LRB_composition y z w) ∙ LRB_composition x y w)) (f : hom x y, (g : hom y z, h : hom z w)) ⟧. Proof. refine (#(LRB_composition x z w) (pr1 (LRB_composition_comm x y z) (f : hom _ _ , g : hom _ _) #, identity _) · _). refine (_ · #( LRB_composition x y w) (identity _ #, pr1 (nat_z_iso_inv (LRB_composition_comm y z w)) (g : hom _ _ , h : hom _ _))). cbn. refine (pr1 (LRB_composition_comm x z w) (f · g : hom _ _ , h : hom _ _) · _). refine (_ · pr1 (nat_z_iso_inv (LRB_composition_comm x y w)) (f : hom _ _ , g · h : hom _ _)). apply (#(η (hom x w))). exact (rassociator f g h). Defined. Lemma LRB_associator_pre_simpl {x y z w : B} (f : B⟦x,y⟧) (g : B⟦y,z⟧) (h : B⟦z,w⟧) : pr1 (LRB_associator_nat_z_iso_pre x y z w) (f : hom _ _, (g : hom _ _, h : hom _ _)) = LRB_associator_pre_simpl_mor f g h. Proof. cbn. unfold LRB_associator_pre_simpl_mor. rewrite ! id_left. rewrite ! id_right. rewrite ! assoc. rewrite id2_left. do 4 (apply maponpaths_2). apply maponpaths. cbn. use total2_paths_f. - cbn ; refine (_ @ id_left _). apply maponpaths_2. etrans. { apply maponpaths, binprod_id. } apply functor_id. - now rewrite transportf_const. Qed. Definition LRB_associator {x y z w : B} (f : R (hom x y)) (g : R (hom y z)) (h : R (hom z w)) : z_iso (C := R (hom x w)) (LRB_composition _ _ _ (LRB_composition _ _ _ (f,g), h)) (LRB_composition _ _ _ (f, LRB_composition _ _ _ (g,h))). Proof. exists (pr1 (LRB_associator_nat_z_iso x y z w) (f,(g,h))). exists (pr1 (pr2 (LRB_associator_nat_z_iso x y z w) (f,(g,h)))). split ; apply (pr2 (LRB_associator_nat_z_iso x y z w) (f,(g,h))). Defined. Definition LRB_prebicat_2_id_comp_struct : prebicat_2_id_comp_struct LRB_prebicat_1_id_comp_cells. Proof. repeat split. - exact (λ x y f, identity f). - exact (λ x y f, pr1 (LRB_lunitor f)). - exact (λ x y f, pr1 (LRB_runitor f)). - intro ; intros ; apply LRB_lunitor. - intro ; intros ; apply LRB_runitor. - intro ; intros ; apply LRB_associator. - intro ; intros ; apply LRB_associator. - exact (λ x y f g h α β, α · β). - exact (λ x y z f g1 g2 α, LRB_lwhisker f α). - exact (λ x y z f1 f2 g α, LRB_rwhisker α g). Defined. Definition LRB_data : prebicat_data. Proof. use make_prebicat_data. - exact LRB_prebicat_1_id_comp_cells. - exact LRB_prebicat_2_id_comp_struct. Defined. Lemma prewhisker_LRB_lunitor {x y : B} (f : B⟦x,y⟧) : pr1 (LRB_lunitor (η_{x,y} f)) = LRB_rwhisker (id₁ (η (hom x x) (id₁ x))) (η_{x,y} f) · pr1 (LRB_composition_comm x x y) (make_catbinprod (C := hom x x) (D := hom x y) (id₁ x) f) · # (η_{x,y}) (lunitor f). Proof. refine (toforallpaths _ _ _ (base_paths _ _ (LRB_lunitor_comm x y)) f @ _). etrans. 2: { do 2 apply maponpaths_2. apply (! functor_id (LRB_composition_curry2 x x y (η_{x,y} f)) _). } rewrite id_left. unfold LRB_lunitor_nat_z_iso_pre. cbn. rewrite ! id_left. etrans. { apply maponpaths_2. etrans. { apply maponpaths, binprod_id. } apply functor_id. } now rewrite id_left, id_right. Qed. Lemma prewhisker_LRB_runitor {x y : B} (f : B⟦x,y⟧) : pr1 (LRB_runitor (η_{x,y} f)) = LRB_lwhisker (η_{x,y} f) (id₁ (η (hom y y) (id₁ y))) · pr1 (LRB_composition_comm x y y) (make_catbinprod (C := hom x y) (D := hom y y) f (id₁ y)) · # (η_{x,y}) (runitor f). Proof. refine (toforallpaths _ _ _ (base_paths _ _ (LRB_runitor_comm x y)) f @ _). etrans. 2: { do 2 apply maponpaths_2. apply (! functor_id (LRB_composition_curry1 x y y (η_{x,y} f)) _). } rewrite id_left. unfold LRB_runitor_nat_z_iso_pre. cbn. rewrite ! id_left. etrans. { apply maponpaths_2. etrans. { apply maponpaths, binprod_id. } apply functor_id. } now rewrite id_left, id_right. Qed. Lemma prewhisker_LRB_associator' {x y z w : B} (f : B ⟦ x, y ⟧) (g : B ⟦ y, z ⟧) (h : B ⟦ z, w ⟧) : pr1 (LRB_associator (η_{x,y} f) (η_{y,z} g) (η (hom z w) h)) = LRB_associator_pre_simpl_mor f g h. Proof. refine ((toforallpaths _ _ _ (base_paths _ _ (LRB_associator_comm x y z w)) (f : hom _ _, (g : hom _ _, h : hom _ _))) @ _). apply (LRB_associator_pre_simpl f g h). Qed. Lemma prewhisker_LRB_associator {x y z w : B} (f : B ⟦ x, y ⟧) (g : B ⟦ y, z ⟧) (h : B ⟦ z, w ⟧) : # (LRB_composition x y w) (id₁ (η_{x,y} f) #, pr1 (LRB_composition_comm y z w) (g : hom _ _, h : hom _ _)) · pr1 (LRB_composition_comm x y w) (f : hom _ _, g · h : hom _ _) · # (η (hom x w)) (lassociator f g h) = pr1 (pr2 (LRB_associator_nat_z_iso x y z w) (η_{x,y} f, (η_{y,z} g, η (hom z w) h))) · # (LRB_composition x z w) (make_dirprod (pr1 (LRB_composition_comm x y z) (f : hom _ _, g : hom _ _)) (id₁ (η (hom z w) h)) : R (hom x z) ⊠ R (hom z w) ⟦((pair_functor (η_{x,y}) (η_{y,z}) ∙ LRB_composition x y z) (f : hom _ _, g : hom _ _) , η (hom z w) h), ((hcomp_functor ∙ η (hom x z)) (f : hom _ _, g : hom _ _), η (hom z w) h) ⟧ ) · pr1 (LRB_composition_comm x z w) (f · g : hom _ _, h : hom _ _). Proof. etrans. 2: apply assoc. use (z_iso_inv_to_left _ _ _ (z_iso_inv (_ ,, pr2 (LRB_associator_nat_z_iso x y z w) (η_{x,y} f, (η_{y,z} g, η (hom z w) h)) : z_iso _ _))). etrans. { apply maponpaths_2. apply (toforallpaths _ _ _ (base_paths _ _ (LRB_associator_comm x y z w)) (f : hom _ _, (g : hom _ _ , h : hom _ _))). } cbn. rewrite ! id_left, ! id_right. etrans. { do 2 apply maponpaths_2. apply maponpaths. do 2 apply maponpaths_2. etrans. { apply maponpaths, binprod_id. } apply functor_id. } rewrite id_left, id2_left, ! assoc'. apply maponpaths. refine (_ @ id_right _). apply maponpaths. etrans. { do 2 apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0, (functor_comp (LRB_composition x y w)). } etrans. { do 2 apply maponpaths. apply maponpaths_2. cbn. etrans. { do 2 apply maponpaths. apply (pr2 (pr2 (LRB_composition_comm y z w) (g : hom _ _, h : hom _ _))). } rewrite id_left. apply (functor_id (LRB_composition x y w)). } rewrite id_left. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. apply (pr2 (LRB_composition_comm x y w) (f : hom _ _, g · h : hom _ _)). } rewrite id_left. etrans. { apply pathsinv0, (functor_comp (η (hom x w))). } etrans. { apply maponpaths, rassociator_lassociator. } apply (functor_id (η (hom x w))). Qed. Lemma prewhisker_LRB_associator_co {x y z w : B} (f : B ⟦ x, y ⟧) (g : B ⟦ y, z ⟧) (h : B ⟦ z, w ⟧) : # (LRB_composition x z w) (pr1 (LRB_composition_comm x y z) (f : hom _ _, g : hom _ _) #, id₁ (η (hom z w) h) ) · pr1 (LRB_composition_comm x z w) (f · g : hom _ _, h : hom _ _) · # (η (hom x w)) (rassociator f g h) = ((LRB_associator_nat_z_iso x y z w) (η_{x,y} f, (η_{y,z} g, η (hom z w) h))) · # (LRB_composition x y w) (make_dirprod (id₁ (η_{x,y} f)) (pr1 (LRB_composition_comm y z w) (g : hom _ _, h : hom _ _)) : R (hom x y) ⊠ R (hom y w)⟦(_,_),(_,_)⟧ ) · pr1 (LRB_composition_comm x y w) (f : hom _ _, g · h: hom _ _). Proof. set (l := prewhisker_LRB_associator f g h). transparent assert (l1 : (is_z_isomorphism (#η_{ x, w} (rassociator f g h)))). { use functor_on_is_z_isomorphism. apply is_z_iso_rassociator. } apply pathsinv0. use (z_iso_inv_on_left _ _ _ _ (z_iso_inv (_,,l1))). transparent assert (l2 : (is_z_isomorphism (LRB_associator_nat_z_iso x y z w (η_{ x, y} f, (η_{ y, z} g, η_{ z, w} h))))). { apply LRB_associator_nat_z_iso. } rewrite ! assoc'. apply pathsinv0, (z_iso_inv_on_right _ _ _ (z_iso_inv (_,,l2))). rewrite ! assoc' in l. exact l. Qed. Lemma LRB_vcomp_lunitor {x y : B} {f g : R (hom x y)} (α : R(hom x y)⟦f,g⟧) : LRB_lwhisker (η (hom x x) (identity x)) α · LRB_lunitor g = pr1 (LRB_lunitor f) · α. Proof. use (factor_through_squash _ _ (eso (hom x y) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom x y) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom x y))) pg). clear pf pg. etrans. { apply maponpaths. exact (toforallpaths _ _ _ (base_paths _ _ (LRB_lunitor_comm _ _)) g0). } assert (α' : ∑ α0 : (hom x y)⟦f0,g0⟧, #(η_{x,y}) α0 = α). { apply (ff_{x,y} f0 g0). } induction α' as [α0 αp]. induction αp. etrans. 2: apply maponpaths_2, (! prewhisker_LRB_lunitor f0). etrans. 2: { rewrite assoc'. apply maponpaths. apply (functor_comp (η_{x,y})). } etrans. 2: { do 2 apply maponpaths. apply (vcomp_lunitor f0 g0 α0). } etrans. { apply maponpaths, (LRB_lunitor_pre_simpl g0). } etrans. 2: apply maponpaths, pathsinv0, (functor_comp (η_{x,y})). rewrite ! assoc. apply maponpaths_2. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, (functor_id (LRB_composition_curry2 x x y (η_{x,y} f0))). } rewrite id_left. refine (_ @ pr21 (LRB_composition_comm x x y) _ _ (id2 (id₁ x) : (hom _ _)⟦_,_⟧ #, α0) @ _) ; cbn. - apply maponpaths_2, maponpaths, maponpaths_2, pathsinv0, (functor_id (η (hom x x))). - do 2 apply maponpaths. apply pathsinv0, lwhisker_hcomp. Qed. Lemma LRB_vcomp_runitor {x y : B} {f g : R (hom x y)} (α : R(hom x y)⟦f,g⟧) : LRB_rwhisker α (η (hom y y) (identity y)) · LRB_runitor g = pr1 (LRB_runitor f) · α. Proof. use (factor_through_squash _ _ (eso (hom x y) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom x y) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom x y))) pg). clear pf pg. etrans. { apply maponpaths. exact (toforallpaths _ _ _ (base_paths _ _ (LRB_runitor_comm _ _)) g0). } assert (α' : ∑ α0 : (hom x y)⟦f0,g0⟧, #(η_{x,y}) α0 = α). { apply (ff_{x,y} f0 g0). } induction α' as [α0 αp]. induction αp. etrans. 2: apply maponpaths_2, (! prewhisker_LRB_runitor f0). etrans. 2: { rewrite assoc'. apply maponpaths. apply (functor_comp (η_{x,y})). } etrans. 2: { do 2 apply maponpaths. apply (vcomp_runitor f0 g0 α0). } etrans. { apply maponpaths, (LRB_runitor_pre_simpl g0). } etrans. 2: apply maponpaths, pathsinv0, (functor_comp (η_{x,y})). rewrite ! assoc. apply maponpaths_2. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, (functor_id (LRB_composition_curry1 x y y (η_{x,y} f0))). } rewrite id_left. refine (_ @ pr21 (LRB_composition_comm x y y) _ _ (α0 #, id2 (id₁ y) : (hom _ _)⟦_,_⟧ ) @ _) ; cbn. - unfold functor_fix_snd_arg_mor. apply maponpaths_2, maponpaths, maponpaths, pathsinv0, (functor_id (η (hom y y))). - do 2 apply maponpaths. apply pathsinv0, rwhisker_hcomp. Qed. Lemma LRB_lwhisker_lwhisker {x y z w : B} (f : R (hom x y)) (g : R (hom y z)) {h i : R (hom z w)} (α : R (hom z w)⟦h,i⟧) : LRB_lwhisker f (LRB_lwhisker g α) · inv_from_z_iso (LRB_associator f g i) = inv_from_z_iso (LRB_associator f g h) · LRB_lwhisker (LRB_composition _ _ _ (f,g)) α. Proof. apply pathsinv0, z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. use (factor_through_squash _ _ (eso (hom x y) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom _ _) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom _ _))) pg). use (factor_through_squash _ _ (eso (hom _ _) h)). { apply homset_property. } intros [h0 ph]. induction (isotoid _ (pr2 (R (hom _ _))) ph). use (factor_through_squash _ _ (eso (hom _ _) i)). { apply homset_property. } intros [i0 pi]. induction (isotoid _ (pr2 (R (hom _ _))) pi). clear pf pg ph pi. assert (α' : ∑ α0 : (hom _ _)⟦h0,i0⟧, #(η (hom _ _)) α0 = α). { apply (ff (hom _ _) h0 i0). } induction α' as [α0 αp]. induction αp. set (t := λ x y z w f g h, toforallpaths _ _ _ (base_paths _ _ (LRB_associator_comm x y z w)) (f , (g, h))). etrans. { apply maponpaths_2, t. } etrans. 2: { apply maponpaths, pathsinv0, t. } etrans. { apply maponpaths_2, (LRB_associator_pre_simpl f0 g0 h0). } etrans. 2: { apply maponpaths, (! LRB_associator_pre_simpl f0 g0 i0). } assert (p : (LRB_lwhisker (η_{y,z} g0) (# (η (hom z w)) α0)) = (LRB_composition_comm y z w (g0 , h0)) · #(η (hom _ _)) (lwhisker g0 α0) · (nat_z_iso_inv (LRB_composition_comm y z w)) (g0 , i0)). { cbn. etrans. 2: { apply maponpaths_2. refine (pr21 (LRB_composition_comm y z w) _ _ (id2 g0 : (hom _ _)⟦_,_⟧ #, α0) @ _) ; cbn. do 2 apply maponpaths. apply hcomp_identity_left. } cbn. rewrite assoc'. etrans. 2: { apply maponpaths. apply pathsinv0, (pr2 (LRB_composition_comm y z w) (g0, i0)). } rewrite (functor_id (η_{y,z})). apply (! id_right _). } etrans. { apply maponpaths. unfold LRB_lwhisker. apply maponpaths. apply p. } unfold LRB_associator_pre_simpl_mor. cbn. etrans. { do 3 apply maponpaths. rewrite assoc'. apply maponpaths. refine (_ @ pr21 (nat_z_iso_inv (LRB_composition_comm y z w)) _ _ (identity g0 #, α0)). cbn. apply maponpaths_2, maponpaths, lwhisker_hcomp. } do 2 rewrite assoc. etrans. { do 3 apply maponpaths. rewrite assoc. apply maponpaths_2. apply (pr2 ((pr2 (LRB_composition_comm y z w)) (g0, h0))). } rewrite id_left. cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: { apply functor_comp. } cbn. now rewrite id_left, id_right. } etrans. { rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } cbn. rewrite id_right. do 2 apply maponpaths. exact (! pr21 (nat_z_iso_inv (LRB_composition_comm y z w)) _ _ ( (id₂ g0) #, α0)). } simpl. etrans. { apply maponpaths. etrans. { apply maponpaths, maponpaths_2, (! id_left _). } etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition x y w)). } rewrite ! assoc. apply maponpaths_2. etrans. { rewrite assoc'. apply maponpaths. refine (_ @ ! pr21 (nat_z_iso_inv (LRB_composition_comm x y w)) _ _ (id₁ f0 #, (α0 ⋆⋆ id₂ g0) : (hom _ _)⟦_,_⟧)). cbn. do 2 apply maponpaths. apply maponpaths_2. apply pathsinv0, (functor_id (η_{x,y})). } rewrite ! assoc. apply maponpaths_2. cbn. do 2 rewrite hcomp_identity_left. etrans. { rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. apply lwhisker_lwhisker_rassociator. } etrans. { apply maponpaths, (functor_comp (η (hom _ _))). } rewrite ! assoc. apply maponpaths_2. etrans. { rewrite assoc'. apply maponpaths. refine (_ @ ! pr21 (LRB_composition_comm x z w) _ _ (id2 (f0 · g0) : (hom _ _)⟦_,_⟧ #, α0)). cbn. do 2 apply maponpaths. apply pathsinv0, hcomp_identity_left. } cbn. rewrite assoc. apply maponpaths_2. etrans. { apply pathsinv0, functor_comp. } cbn. apply maponpaths. use total2_paths_f. - cbn. rewrite (functor_id (η (hom x z))). apply id_right. - rewrite transportf_const. cbn. apply id_left. Qed. Lemma LRB_rwhisker_lwhisker {x y z w : B} (f : R (hom x y)) {g h : R (hom y z)} (α : R (hom y z)⟦g,h⟧) (i : R (hom z w)) : LRB_lwhisker f (LRB_rwhisker α i) · inv_from_z_iso (LRB_associator f h i) = inv_from_z_iso (LRB_associator f g i) · (LRB_rwhisker (LRB_lwhisker f α) i). Proof. apply pathsinv0, z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. use (factor_through_squash _ _ (eso (hom x y) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom _ _) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom _ _))) pg). use (factor_through_squash _ _ (eso (hom _ _) h)). { apply homset_property. } intros [h0 ph]. induction (isotoid _ (pr2 (R (hom _ _))) ph). use (factor_through_squash _ _ (eso (hom _ _) i)). { apply homset_property. } intros [i0 pi]. induction (isotoid _ (pr2 (R (hom _ _))) pi). clear pf pg ph pi. assert (α' : ∑ α0 : (hom _ _)⟦g0,h0⟧, #(η (hom _ _)) α0 = α). { apply (ff (hom _ _) g0 h0). } induction α' as [α0 αp]. induction αp. set (t := λ x y z w f g h, toforallpaths _ _ _ (base_paths _ _ (LRB_associator_comm x y z w)) (f , (g, h))). etrans. { apply maponpaths_2, t. } etrans. 2: { apply maponpaths, pathsinv0, t. } etrans. { apply maponpaths_2, (LRB_associator_pre_simpl f0 g0 i0). } etrans. 2: { apply maponpaths, (! LRB_associator_pre_simpl f0 h0 i0). } unfold LRB_associator_pre_simpl_mor ; cbn. unfold functor_fix_snd_arg_mor. etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: { apply functor_comp. } cbn. apply maponpaths. rewrite id_right. etrans. 2: { do 2 apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply (functor_id (η_{x,y})). } etrans. 2: { apply maponpaths. apply (functor_id (η (hom z w))). } apply maponpaths_2. exact (! pr21 (LRB_composition_comm x y z) _ _ ((id₁ f0) #, α0)). } etrans. 2: { apply maponpaths_2. etrans. 2: { do 2 apply maponpaths. apply id_left. } etrans. 2: { apply maponpaths, pathsinv0, binprod_comp. } cbn. apply pathsinv0. set (t1 := pr11 (LRB_composition_comm x y z) (f0, g0)). set (t2 := # (η (hom z w)) (id₂ i0)). set (s1 := # (η (hom x z)) (α0 ⋆⋆ id₂ f0)). set (s2 := id₁ (η (hom z w) i0)). set (t3 := (t1 #, s2)). set (s3 := (s1 #, t2)). exact (functor_comp (LRB_composition x z w) t3 s3). } rewrite ! assoc'. apply maponpaths. etrans. 2: { rewrite assoc. apply maponpaths_2. exact (! pr21 (LRB_composition_comm x z w) _ _ ( (α0 ⋆⋆ id₂ f0) : (hom _ _)⟦_,_⟧ #, id2 i0)). } rewrite assoc'. apply maponpaths. cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: { apply functor_comp. } apply maponpaths. refine (rwhisker_lwhisker_rassociator _ _ _ _ _ _ _ _ _ @ _). apply maponpaths_2. rewrite hcomp_identity_right. now rewrite hcomp_identity_left. } etrans. 2: { apply maponpaths_2. apply pathsinv0, (functor_comp (η (hom x w))). } rewrite ! assoc'. apply maponpaths. etrans. { apply maponpaths. etrans. { apply pathsinv0, functor_comp. } cbn. rewrite id_right. do 2 apply maponpaths. refine (_ @ ! pr21 (nat_z_iso_inv (LRB_composition_comm y z w)) _ _ (α0 #, id2 i0)). cbn. do 3 apply maponpaths. apply pathsinv0, (functor_id (η (hom z w))). } cbn. etrans. { do 2 apply maponpaths. apply maponpaths_2, pathsinv0, id_right. } etrans. { apply maponpaths. refine (_ @ functor_comp (LRB_composition x y w) (id₁ (η_{x,y} f0) #, # (η (hom y w)) (id₂ i0 ⋆⋆ α0)) (_ #, is_z_isomorphism_mor (pr2 (LRB_composition_comm y z w) (h0, i0)))). apply maponpaths. rewrite id_right. cbn. apply maponpaths_2. apply pathsinv0, id_right. } rewrite ! assoc. apply maponpaths_2. etrans. { refine (_ @ ! pr21 (nat_z_iso_inv (LRB_composition_comm x y w)) _ _ (id2 f0 #, (id₂ i0 ⋆⋆ α0) : (hom _ _)⟦_,_⟧)). cbn. do 2 apply maponpaths. apply maponpaths_2. apply pathsinv0, (functor_id (η_{x,y})). } apply maponpaths_2. cbn. apply maponpaths. rewrite hcomp_identity_right. now rewrite hcomp_identity_left. Qed. Lemma LRB_rwhisker_rwhisker {x y z w : B} {f g : R (hom x y)} (α : R (hom x y)⟦f,g⟧) (h : R (hom y z)) (i : R (hom z w)) : inv_from_z_iso (LRB_associator f h i) · LRB_rwhisker (LRB_rwhisker α h) i = LRB_rwhisker α (LRB_composition _ _ _ (h, i)) · inv_from_z_iso (LRB_associator g h i). Proof. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. use (factor_through_squash _ _ (eso (hom _ _) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom _ _) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom _ _))) pg). use (factor_through_squash _ _ (eso (hom _ _) h)). { apply homset_property. } intros [h0 ph]. induction (isotoid _ (pr2 (R (hom _ _))) ph). use (factor_through_squash _ _ (eso (hom _ _) i)). { apply homset_property. } intros [i0 pi]. induction (isotoid _ (pr2 (R (hom _ _))) pi). clear pf pg ph pi. assert (α' : ∑ α0 : (hom _ _)⟦f0,g0⟧, #(η (hom _ _)) α0 = α). { apply (ff (hom _ _) f0 g0). } induction α' as [α0 αp]. induction αp. set (t := λ x y z w f g h, toforallpaths _ _ _ (base_paths _ _ (LRB_associator_comm x y z w)) (f , (g, h))). etrans. { apply maponpaths_2, t. } etrans. 2: { apply maponpaths, pathsinv0, t. } etrans. { apply maponpaths_2, (LRB_associator_pre_simpl f0 h0 i0). } etrans. 2: { apply maponpaths, (! LRB_associator_pre_simpl g0 h0 i0). } unfold LRB_associator_pre_simpl_mor ; cbn. unfold functor_fix_snd_arg_mor. etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: { apply functor_comp. } cbn. apply maponpaths. rewrite id_right. etrans. 2: { do 2 apply maponpaths_2. do 2 apply maponpaths. apply (functor_id (η_{y,z})). } etrans. 2: { apply maponpaths. apply (functor_id (η (hom z w))). } apply maponpaths_2. exact (! pr21 (LRB_composition_comm x y z) _ _ (α0 #, (id₁ h0))). } etrans. 2: { apply maponpaths_2. etrans. 2: { do 2 apply maponpaths. apply id_left. } etrans. 2: { apply maponpaths, pathsinv0, binprod_comp. } cbn. apply pathsinv0. set (t1 := pr11 (LRB_composition_comm x y z) (f0, h0)). set (t2 := # (η (hom z w)) (id₂ i0)). set (s1 := # (η (hom x z)) (id₂ h0 ⋆⋆ α0)). set (s2 := id₁ (η (hom z w) i0)). set (t3 := (t1 #, s2)). set (s3 := (s1 #, t2)). exact (functor_comp (LRB_composition x z w) t3 s3). } rewrite ! assoc'. apply maponpaths. etrans. 2: { rewrite assoc. apply maponpaths_2. exact (! pr21 (LRB_composition_comm x z w) _ _ ( (id₂ h0 ⋆⋆ α0) : (hom _ _)⟦_,_⟧ #, id2 i0)). } rewrite assoc'. apply maponpaths. cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: { apply functor_comp. } apply maponpaths. refine (! rwhisker_rwhisker_alt _ _ _ @ _). apply maponpaths_2. now do 2 rewrite hcomp_identity_right. } etrans. 2: { apply maponpaths_2. apply pathsinv0, (functor_comp (η (hom x w))). } rewrite ! assoc'. apply maponpaths. etrans. { apply maponpaths. etrans. { apply pathsinv0, functor_comp. } cbn. now rewrite id_right. } rewrite id_left. etrans. 2: { rewrite assoc. apply maponpaths_2. refine (! pr21 (nat_z_iso_inv (LRB_composition_comm x y w)) _ _ (α0 #, id2 (h0 · i0) : (hom _ _)⟦_,_⟧) @ _). cbn. apply maponpaths_2, maponpaths. now rewrite hcomp_identity_right. } cbn. rewrite ! assoc'. apply maponpaths. etrans. 2: { apply functor_comp. } apply maponpaths. cbn. rewrite id_right. rewrite (functor_id (η (hom y w))). now rewrite id_left. Qed. Lemma LRB_runitor_rwhisker {x y z : B} (f : R (hom x y)) (g : R (hom y z)) : inv_from_z_iso (LRB_associator f (η (hom y y) (identity y)) g) · (LRB_rwhisker (LRB_runitor f) g) = LRB_lwhisker f (LRB_lunitor g). Proof. use z_iso_inv_on_right. use (factor_through_squash _ _ (eso (hom _ _) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom x y))) pf). use (factor_through_squash _ _ (eso (hom _ _) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom _ _))) pg). clear pf pg. etrans. { unfold LRB_rwhisker. apply maponpaths. apply prewhisker_LRB_runitor. } etrans. 2: { unfold LRB_lwhisker. do 2 apply maponpaths. apply pathsinv0, prewhisker_LRB_lunitor. } etrans. 2: apply maponpaths_2, pathsinv0, prewhisker_LRB_associator'. cbn. unfold functor_fix_snd_arg_mor. unfold LRB_associator_pre_simpl_mor. cbn. etrans. 2: { do 3 apply maponpaths. do 2 apply maponpaths_2. etrans. 2: { apply maponpaths, binprod_id. } apply pathsinv0, (functor_id (LRB_composition y y z)). } rewrite id_left. etrans. 2: { rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition x y z)). apply maponpaths. cbn. apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm y y z) (id₁ y : hom _ _, g0))). } do 2 rewrite id_left. etrans. 2: { apply maponpaths. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. rewrite (! functor_id (η_{x,y}) _). apply (pr21 (nat_z_iso_inv (LRB_composition_comm x y z)) _ _ (_ #, lunitor g0 : (hom _ _)⟦_,_⟧)). } simpl. etrans. 2: { do 2 apply maponpaths. rewrite assoc. apply maponpaths_2. etrans. 2: apply functor_comp. apply maponpaths. refine (! lunitor_lwhisker _ _ @ _). apply maponpaths. apply pathsinv0, hcomp_identity_left. } etrans. { apply maponpaths. do 3 apply maponpaths_2. apply (functor_id (LRB_composition x y y)). } rewrite id_left. etrans. { do 2 apply maponpaths. apply (! id_right _). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition x y z)). } apply maponpaths. etrans. 2: { apply maponpaths. rewrite <- hcomp_identity_right. exact (! pr21 (nat_z_iso_inv (LRB_composition_comm x y z)) _ _ (runitor f0 : (hom _ _)⟦_,_⟧ #, id2 g0)). } cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm x y z) (f0 · id₁ y : hom _ _, g0))). } rewrite id_left. do 2 apply maponpaths. apply pathsinv0, (functor_id (η_{y,z})). Qed. Definition LRB_associator_comp_l {a b c d e : B} (f : hom a b) (g : hom b c) (h : hom c d) (i : hom d e) : R (hom a e) ⟦ LRB_composition a d e (LRB_composition a c d (LRB_composition a b c (η (hom a b) f, η (hom b c) g), η (hom c d) h), η (hom d e) i), η (hom a e) ((f · g) · h · i) ⟧. Proof. use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: { use (#(LRB_composition a c d)). 2: { use catbinprodmor. 4: apply identity. 2: exact (pr1 (LRB_composition_comm a b c) (f,g)). } } } } use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact (pr1 (LRB_composition_comm a c d) (f·g : hom _ _,h)). } } exact (pr1 (LRB_composition_comm a d e) (f·g·h : hom _ _,i)). Defined. Definition LRB_associator_comp_l' {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ η (hom a e) (f0 · g0 · (h0 · i0)), LRB_composition a c e (LRB_composition a b c (η (hom a b) f0, η (hom b c) g0), LRB_composition c d e (η (hom c d) h0, η (hom d e) i0)) ⟧. Proof. use (_ · _). 3: { use (#(LRB_composition a c e)). 2: { use catbinprodmor. 3: exact (pr1 (nat_z_iso_inv (LRB_composition_comm a b c)) (f0,g0)). 2: exact (pr1 (nat_z_iso_inv (LRB_composition_comm c d e)) (h0,i0)). } } exact (pr1 (nat_z_iso_inv (LRB_composition_comm a c e)) (f0·g0 : hom _ _, h0·i0 : hom _ _)). Defined. Definition LRB_associator_comp_l_on {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : pr1 (LRB_associator (LRB_composition a b c (η (hom a b) f0, η (hom b c) g0)) (η (hom c d) h0) (η (hom d e) i0)) = LRB_associator_comp_l f0 g0 h0 i0 · #(η (hom a e)) (pr1 (rassociator_transf _ _ _ _) ((f0 · g0 : hom _ _),(h0,i0))) · LRB_associator_comp_l' f0 g0 h0 i0. Proof. unfold LRB_associator_comp_l, LRB_associator_comp_l'. set (n2 := LRB_composition_comm a b c). set (n1 := LRB_associator_comm a c d e). set (q := toforallpaths _ _ _ (base_paths _ _ n1) (f0 · g0 : hom _ _, (h0, i0))). etrans. 2: { apply maponpaths_2. unfold n2. rewrite assoc'. apply maponpaths. exact (! prewhisker_LRB_associator_co (f0 · g0) h0 i0). } rewrite assoc. etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm a c e) (f0 · g0 : hom _ _, h0 · i0 : hom _ _))). } rewrite id_right. unfold n2. etrans. 2: { rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a c e)). apply maponpaths. cbn. rewrite id_left. apply maponpaths, pathsinv0, (pr2 (LRB_composition_comm c d e) (h0, i0)). } etrans. 2: { apply maponpaths, maponpaths_2. exact (! prewhisker_LRB_associator' (f0 · g0) h0 i0). } unfold LRB_associator_pre_simpl_mor. etrans. 2: { apply maponpaths. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply functor_comp. cbn. rewrite id_left. now rewrite id_right. } etrans. 2: { rewrite assoc. apply maponpaths_2. etrans. 2: apply functor_comp. apply maponpaths. cbn. now rewrite id_right. } etrans. 2: { rewrite assoc'. apply maponpaths_2. do 2 apply maponpaths. exact (id_left (id₁ (η (hom d e) i0))). } etrans. 2: { apply maponpaths_2. etrans. 2: { apply maponpaths. apply pathsinv0, binprod_comp. } apply pathsinv0, (functor_comp (LRB_composition a d e)). } etrans. 2: { rewrite ! assoc'. apply maponpaths. rewrite ! assoc. do 2 apply maponpaths_2. exact (! prewhisker_LRB_associator_co (f0 · g0) h0 i0). } etrans. 2: { apply maponpaths. apply maponpaths_2. rewrite assoc'. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm a c e) (f0 · g0 : hom _ _, h0 · i0 : hom _ _))). } rewrite id_right. etrans. 2: { apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a c e)). apply maponpaths. etrans. 2: apply binprod_comp. rewrite id_left. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm c d e) (h0, i0))). } transparent assert (i1 : (is_z_isomorphism (# (LRB_composition a c e) (is_z_isomorphism_mor (pr2 (LRB_composition_comm a b c) (f0, g0)) #, id₁ ((pair_functor (η (hom c d)) (η (hom d e)) ∙ LRB_composition c d e) (h0, i0)))))). { apply functor_on_is_z_isomorphism. apply is_z_iso_binprod_z_iso. - apply (pr2 (z_iso_inv (_ ,, pr2 (LRB_composition_comm a b c) (f0, g0)))). - apply identity_is_z_iso. } rewrite assoc. use (z_iso_inv_on_left _ _ _ _ (z_iso_inv (_ ,, i1))). etrans. 2: { apply maponpaths. simpl. cbn. apply idpath. } set (t := pr21 (LRB_associator_nat_z_iso a c d e)). unfold is_nat_trans in t. set (tt := t _ _ (pr1 (LRB_composition_comm a b c) (f0, g0) #, (id₁ (η_{ c, d} h0) #, id₁ (η_{ d, e} i0)))). refine (tt @ _). apply maponpaths. (* Opaque LRB_composition. *) cbn. do 2 apply maponpaths. apply (functor_id (LRB_composition c d e)). Qed. Definition LRB_associator_comp_m {a b c d e : B} (f : hom a b) (g : hom b c) (h : hom c d) (i : hom d e) : R (hom a e) ⟦LRB_composition a d e (LRB_composition a b d (η (hom a b) f, LRB_composition b c d (η (hom b c) g, η (hom c d) h)), η (hom d e) i), η (hom a e) (f · (g · h) · i) ⟧. Proof. use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: { use (#(LRB_composition a b d)). 2: { use catbinprodmor. 3: apply identity. 2: exact (pr1 (LRB_composition_comm b c d) (g,h)). } } } } use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact (pr1 (LRB_composition_comm a b d) (f,g·h : hom _ _)). } } exact (pr1 (LRB_composition_comm a d e) ( (f · (g · h)) : hom _ _ , i)). Defined. Definition LRB_associator_comp_m' {a b c d e : B} (f : hom a b) (g : hom b c) (h : hom c d) (i : hom d e) : R (hom a e) ⟦ η (hom a e) (f · (g · h · i)), LRB_composition a b e (η (hom a b) f, LRB_composition b d e (LRB_composition b c d (η (hom b c) g, η (hom c d) h), η (hom d e) i)) ⟧. Proof. use (_ · _). 3: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: { use (#(LRB_composition b d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact (pr1 (nat_z_iso_inv (LRB_composition_comm b c d)) (g,h)). } } } } use (_ · _). 3: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: exact (pr1 (nat_z_iso_inv (LRB_composition_comm b d e)) (g · h : hom _ _ , i)). } } exact (pr1 (nat_z_iso_inv (LRB_composition_comm a b e)) (f , (g · h · i) : hom _ _)). Defined. Lemma LRB_associator_comp_m_on {a b c d e : B} (f : hom a b) (g : hom b c) (h : hom c d) (i : hom d e) : pr1 (LRB_associator (η (hom a b) f) (LRB_composition b c d (η (hom b c) g, η (hom c d) h)) (η (hom d e) i)) = LRB_associator_comp_m f g h i · #(η (hom a e)) (pr1 (rassociator_transf _ _ _ _) (f , ((g · h : hom _ _),i))) · LRB_associator_comp_m' f g h i. Proof. unfold LRB_associator_comp_m, LRB_associator_comp_m'. set (n2 := LRB_composition_comm a d e ). set (n1 := LRB_associator_comm a b d e). set (q := toforallpaths _ _ _ (base_paths _ _ n1) (f, (g·h : hom _ _, i))). etrans. 2: { apply maponpaths_2. unfold n2. rewrite assoc'. apply maponpaths. exact (! prewhisker_LRB_associator_co _ _ _). } rewrite assoc. etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. simpl. rewrite assoc. apply maponpaths_2. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm a b e) (f, g · h · i : hom _ _))). } rewrite id_left. etrans. 2: { apply maponpaths_2. apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a b e)). apply maponpaths. etrans. 2: apply binprod_comp. rewrite id_left. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm b d e) (g · h : hom _ _, i))). } etrans. 2: { apply maponpaths_2. do 2 apply maponpaths. apply pathsinv0, (functor_id (LRB_composition a b e)). } rewrite id_right. set (t := pr21 (LRB_associator_nat_z_iso a b d e)). unfold is_nat_trans in t. etrans. 2: { apply maponpaths_2. exact (! (t _ _ (id₁ (η_{ a, b} f) #, (pr1 (LRB_composition_comm b c d) (g, h) #, id₁ (η_{ d, e} i))))). } Opaque LRB_composition. Opaque LRB_composition_comm. Opaque LRB_associator_nat_z_iso. cbn. etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a b e)). etrans. 2: apply maponpaths, binprod_comp. rewrite id_left. etrans. 2: { do 2 apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition b d e)). apply maponpaths. etrans. 2: apply binprod_comp. rewrite id_left. apply maponpaths_2. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm b c d) (g, h))). } rewrite binprod_id. rewrite (functor_id (LRB_composition b d e)). now rewrite (functor_id (LRB_composition a b e)). } apply pathsinv0, id_right. Qed. Definition LRB_associator_comp_r {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e)⟦ LRB_composition a c e (LRB_composition a b c (η (hom a b) f0, η (hom b c) g0), LRB_composition c d e (η (hom c d) h0, η (hom d e) i0)), η (hom a e) (f0 · g0 · (h0 · i0)) ⟧. Proof. use (_ · _). 2: { use (#(LRB_composition a c e)). 2: { use catbinprodmor. 4: exact (pr1 (LRB_composition_comm c d e) (h0,i0)). 2: exact (pr1 (LRB_composition_comm a b c) (f0,g0)). } } exact (pr1 (LRB_composition_comm a c e) (f0 · g0 : hom _ _ ,h0 · i0 : hom _ _)). Defined. Definition LRB_associator_comp_r' {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ η (hom a e) (f0 · (g0 · (h0 · i0))), LRB_composition a b e (η (hom a b) f0, LRB_composition b c e (η (hom b c) g0, LRB_composition c d e (η (hom c d) h0, η (hom d e) i0)))⟧. Proof. use (_ · _). 3: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: { use (#(LRB_composition b c e)). 2: { use catbinprodmor. 3: apply identity. 2: exact (pr1 (nat_z_iso_inv (LRB_composition_comm c d e)) (h0,i0)). } } } } use (_ · _). 3: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: exact (pr1 (nat_z_iso_inv (LRB_composition_comm b c e)) (g0,h0 · i0 : hom _ _)). } } exact (pr1 (nat_z_iso_inv (LRB_composition_comm a b e)) (f0, g0 · (h0 · i0) : hom _ _)). Defined. Definition LRB_associator_comp_r_on {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : pr1 (LRB_associator (η (hom a b) f0) (η (hom b c) g0) (LRB_composition c d e (η (hom c d) h0, η (hom d e) i0))) = LRB_associator_comp_r f0 g0 h0 i0 · #(η (hom a e)) (pr1 (rassociator_transf _ _ _ _) (f0 , (g0, (h0 · i0 : hom _ _)))) · LRB_associator_comp_r' f0 g0 h0 i0. Proof. unfold LRB_associator_comp_r, LRB_associator_comp_r'. etrans. 2: { apply maponpaths. rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a b e)). etrans. 2: apply maponpaths, binprod_comp. now rewrite id_left. } etrans. 2: { do 3 apply maponpaths_2. etrans. 2: { do 2 apply maponpaths. apply id_right. } etrans. 2: { apply maponpaths. apply maponpaths_2. apply id_left. } etrans. 2: apply maponpaths, pathsinv0, binprod_comp. apply pathsinv0, (functor_comp (LRB_composition a c e)). } etrans. 2: { apply maponpaths_2. rewrite assoc'. rewrite assoc'. apply maponpaths. rewrite assoc. exact (! prewhisker_LRB_associator_co f0 g0 (h0 · i0)). } etrans. 2: { rewrite ! assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm a b e) (f0, g0 · (h0 · i0) : hom _ _))). } rewrite id_right. etrans. 2: { rewrite ! assoc'. do 2 apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a b e)). etrans. 2: apply maponpaths, binprod_comp. simpl. rewrite id_left. etrans. 2: { do 2 apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm b c e) (g0, h0 · i0 : hom _ _))). } now rewrite id_left. } set (t := pr21 (LRB_associator_nat_z_iso a b c e)). set (tt := ((t _ _ (id₁ (η_{ a, b} f0) #, (id₁ (η_{ b, c} g0) #, (pr1 (LRB_composition_comm _ _ _) (h0, i0))))))). cbn in tt. etrans. 2: { rewrite assoc. apply maponpaths_2. refine (! tt @ _). apply maponpaths_2, maponpaths. apply maponpaths_2. apply (functor_id (LRB_composition a b c)). } etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition a b e)). etrans. 2: apply maponpaths, binprod_comp. rewrite id_left. etrans. 2: { do 2 apply maponpaths. etrans. 2: apply (functor_comp (LRB_composition b c e)). apply maponpaths. etrans. 2: apply binprod_comp. rewrite id_left. apply maponpaths. apply pathsinv0, (pr2 (pr2 (LRB_composition_comm c d e) (h0, i0))). } rewrite binprod_id. rewrite (functor_id (LRB_composition b c e)). now rewrite (functor_id (LRB_composition a b e)). } apply pathsinv0, id_right. Qed. Definition LRB_lassociator_rwhisker {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ LRB_composition a d e (LRB_composition a c d (LRB_composition a b c (η (hom a b) f0, η (hom b c) g0), η (hom c d) h0), η (hom d e) i0), η (hom a e) (f0 · g0 · h0 · i0) ⟧. Proof. use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: { use (#(LRB_composition a c d)). 2: { use catbinprodmor. 4: apply identity. 2: exact ((LRB_composition_comm a b c) (f0,g0)). } } } } simpl. use (_ · _). 2: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact ((LRB_composition_comm a c d) (f0 · g0 : hom _ _, h0)). } } exact ((LRB_composition_comm a d e) (f0 · g0 · h0 : hom _ _, i0)). Defined. Definition LRB_lassociator_rwhisker' {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ η (hom a e) (f0 · (g0 · h0) · i0), LRB_composition a d e (LRB_composition a b d (η (hom a b) f0, LRB_composition b c d (η (hom b c) g0, η (hom c d) h0)), η (hom d e) i0) ⟧. Proof. use (_ · _). 3: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: { use (#(LRB_composition a b d)). 2: { use catbinprodmor. 3: apply identity. 2: exact (nat_z_iso_inv (LRB_composition_comm b c d) (g0,h0)). } } } } simpl. use (_ · _). 3: { use (#(LRB_composition a d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact (nat_z_iso_inv (LRB_composition_comm a b d) (f0,g0 · h0 : hom _ _)). } } exact (nat_z_iso_inv (LRB_composition_comm a d e) (f0 · (g0 · h0) : hom _ _, i0)). Defined. Lemma LRB_lassociator_rwhisker_on {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : LRB_rwhisker (LRB_associator (η (hom a b) f0) (η (hom b c) g0) (η (hom c d) h0)) (η (hom d e) i0) = LRB_lassociator_rwhisker f0 g0 h0 i0 · #(η (hom a e)) (rassociator f0 g0 h0 ▹ i0) · LRB_lassociator_rwhisker' f0 g0 h0 i0. Proof. etrans. { unfold LRB_rwhisker. apply maponpaths. exact (prewhisker_LRB_associator' f0 g0 h0). } unfold LRB_associator_pre_simpl_mor. simpl. unfold functor_fix_snd_arg_mor. unfold LRB_lassociator_rwhisker, LRB_lassociator_rwhisker'. simpl. etrans. { do 2 apply maponpaths. exact (! id_left (id₁ (η (hom d e) i0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a d e)). } rewrite ! assoc'. apply maponpaths. etrans. { do 2 apply maponpaths. exact (! id_left (id₁ (η (hom d e) i0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a d e)). } apply maponpaths. etrans. { do 2 apply maponpaths. exact (! id_left (id₁ (η (hom d e) i0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a d e)). } rewrite ! assoc. etrans. { do 3 apply maponpaths. exact (! id_left (id₁ (η (hom d e) i0))). } etrans. { apply maponpaths. etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a d e)). } rewrite ! assoc. apply maponpaths_2. etrans. 2: { do 2 apply maponpaths_2. refine (pr21 (LRB_composition_comm a d e) _ _ ((rassociator f0 g0 h0 : (hom _ _)⟦_,_⟧) #, id₁ i0) @ _). apply maponpaths. cbn. apply maponpaths. apply hcomp_identity_right. } apply maponpaths_2. etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0. apply (pr2 (pr2 (LRB_composition_comm a d e) (f0 · (g0 · h0) : hom _ _, i0))). } rewrite id_right. cbn. do 2 apply maponpaths. apply pathsinv0, (functor_id (η (hom d e))). Qed. Definition LRB_lassociator_lwhisker {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ LRB_composition a b e (η (hom a b) f0, LRB_composition b d e (LRB_composition b c d (η (hom b c) g0, η (hom c d) h0), η (hom d e) i0)), η (hom a e) (f0 · (g0 · h0 · i0)) ⟧. Proof. use (_ · _). 2: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: { use (#(LRB_composition b d e)). 2: { use catbinprodmor. 4: apply identity. 2: exact (pr1 (LRB_composition_comm b c d) (g0,h0)). } } } } use (_ · _). 2: { use (#(LRB_composition a b e)). 2: { use catbinprodmor. 3: apply identity. 2: exact (pr1 (LRB_composition_comm b d e) (g0·h0 : hom _ _ , i0)). } } exact (pr1 (LRB_composition_comm a b e) (f0, (g0 · h0 · i0) : hom _ _ )). Defined. Definition LRB_lassociator_lwhisker' {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : R (hom a e) ⟦ η (hom a e) (f0 · (g0 · (h0 · i0))), LRB_composition a b e (η (hom a b) f0, LRB_composition b c e (η (hom b c) g0, LRB_composition c d e (η (hom c d) h0, η (hom d e) i0)))⟧. Proof. exact (LRB_associator_comp_r' f0 g0 h0 i0). Defined. Lemma LRB_lassociator_lwhisker_on {a b c d e : B} (f0 : hom a b) (g0 : hom b c) (h0 : hom c d) (i0 : hom d e) : LRB_lwhisker (η (hom a b) f0) (LRB_associator (η (hom b c) g0) (η (hom c d) h0) (η (hom d e) i0)) = LRB_lassociator_lwhisker f0 g0 h0 i0 · #(η (hom _ _)) (f0 ◃ rassociator g0 h0 i0) · LRB_lassociator_lwhisker' f0 g0 h0 i0. Proof. etrans. { unfold LRB_lwhisker. apply maponpaths. exact (prewhisker_LRB_associator' g0 h0 i0). } unfold LRB_associator_pre_simpl_mor. simpl. unfold functor_fix_snd_arg_mor. unfold LRB_lassociator_lwhisker, LRB_lassociator_lwhisker'. simpl. etrans. { apply maponpaths, maponpaths_2. exact (! id_left (id₁ (η (hom a b) f0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a b e)). } rewrite ! assoc'. apply maponpaths. etrans. { apply maponpaths, maponpaths_2. exact (! id_left (id₁ (η (hom a b) f0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a b e)). } apply maponpaths. etrans. { apply maponpaths, maponpaths_2. exact (! id_left (id₁ (η (hom a b) f0))). } etrans. { etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a b e)). } rewrite ! assoc. etrans. { do 2 apply maponpaths. apply maponpaths_2. exact (! id_left (id₁ (η (hom a b) f0))). } etrans. { apply maponpaths. etrans. { apply maponpaths, binprod_comp. } apply (functor_comp (LRB_composition a b e)). } rewrite ! assoc. etrans. 2: { apply maponpaths_2. refine (pr21 (LRB_composition_comm a b e) _ _ (id₁ f0 #, (rassociator g0 h0 i0 : (hom _ _)⟦_,_⟧)) @ _). apply maponpaths. cbn. apply maponpaths. apply hcomp_identity_left. } cbn. etrans. { do 2 apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply pathsinv0, (functor_id (η (hom _ _))). } rewrite ! assoc'. apply maponpaths. unfold LRB_associator_comp_r'. cbn. rewrite ! assoc. apply maponpaths_2. etrans. 2: { apply maponpaths_2. apply pathsinv0. apply (pr2 (pr2 (LRB_composition_comm a b e) (f0, g0 · (h0 · i0) : hom _ _))). } now rewrite id_left. Qed. Lemma LRB_lassociator_lassociator {a b c d e : B} (f : R (hom a b)) (g : R (hom b c)) (h : R (hom c d)) (i : R (hom d e)) : LRB_lwhisker f (inv_from_z_iso (LRB_associator g h i)) · (inv_from_z_iso (LRB_associator f (LRB_composition _ _ _ (g, h)) i)) · (LRB_rwhisker (inv_from_z_iso (LRB_associator f g h)) i) = inv_from_z_iso (LRB_associator f g (LRB_composition _ _ _ (h,i))) · inv_from_z_iso (LRB_associator (LRB_composition _ _ _ (f,g)) h i). Proof. use z_iso_inv_on_left. transparent assert (f_lw_a : (is_z_isomorphism (LRB_lwhisker f (inv_from_z_iso (LRB_associator g h i))))). { use functor_on_is_z_isomorphism. use is_z_iso_binprod_z_iso. - apply identity_is_z_iso. - apply is_z_iso_inv_from_z_iso. } transparent assert (r_a_i : (is_z_isomorphism (LRB_rwhisker (inv_from_z_iso (LRB_associator f g h)) i))). { use functor_on_is_z_isomorphism. use is_z_iso_binprod_z_iso. - apply is_z_iso_inv_from_z_iso. - apply identity_is_z_iso. } rewrite ! assoc'. use (z_iso_inv_to_left _ _ _ (_ ,, f_lw_a)). apply pathsinv0, z_iso_inv_on_left. rewrite ! assoc'. apply pathsinv0. use z_iso_inv_on_right. apply pathsinv0, (z_iso_inv_to_left _ _ _ (_ ,, r_a_i)). assert (p : inv_from_z_iso (LRB_rwhisker (inv_from_z_iso (LRB_associator f g h)) i,, r_a_i) = LRB_rwhisker (LRB_associator f g h) i). { apply idpath. } rewrite p. clear p. assert (p : inv_from_z_iso (LRB_lwhisker f (inv_from_z_iso (LRB_associator g h i)),, f_lw_a) = LRB_lwhisker f (LRB_associator g h i)). { apply idpath. } rewrite p. clear p. use (factor_through_squash _ _ (eso (hom _ _) f)). { apply homset_property. } intros [f0 pf]. induction (isotoid _ (pr2 (R (hom _ _))) pf). use (factor_through_squash _ _ (eso (hom _ _) g)). { apply homset_property. } intros [g0 pg]. induction (isotoid _ (pr2 (R (hom _ _))) pg). use (factor_through_squash _ _ (eso (hom _ _) h)). { apply homset_property. } intros [h0 ph]. induction (isotoid _ (pr2 (R (hom _ _))) ph). use (factor_through_squash _ _ (eso (hom _ _) i)). { apply homset_property. } intros [i0 pi]. induction (isotoid _ (pr2 (R (hom _ _))) pi). clear pf pg ph pi. clear f_lw_a r_a_i. etrans. { apply maponpaths, maponpaths_2. exact (LRB_associator_comp_m_on f0 g0 h0 i0). } etrans. 2: { apply maponpaths. exact (! LRB_associator_comp_r_on f0 g0 h0 i0). } etrans. 2: { apply maponpaths_2. exact (! LRB_associator_comp_l_on f0 g0 h0 i0). } etrans. 2: { rewrite assoc. apply maponpaths_2. rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths, pathsinv0. unfold LRB_associator_comp_l', LRB_associator_comp_r. simpl. rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply pathsinv0, (functor_comp (LRB_composition a c e)). } etrans. { apply maponpaths_2. do 2 apply maponpaths. simpl. cbn. etrans. { apply maponpaths. apply (pr2 (pr2 (LRB_composition_comm c d e) (h0, i0))). } apply maponpaths_2. apply (pr2 (pr2 (LRB_composition_comm a b c) (f0, g0))). } etrans. { apply maponpaths_2, maponpaths. apply (functor_id (LRB_composition a c e)). } rewrite id_right. apply (pr2 (LRB_composition_comm a c e) (f0 · g0 : hom _ _, h0 · i0 : hom _ _)). } rewrite id_right. etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply (functor_comp (η (hom a e))). } unfold LRB_associator_comp_l. etrans. { apply maponpaths_2. exact (LRB_lassociator_rwhisker_on f0 g0 h0 i0). } etrans. { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite assoc. apply maponpaths_2. unfold LRB_lassociator_rwhisker', LRB_associator_comp_m. rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, (functor_comp (LRB_composition a d e)). } cbn. rewrite id_right. apply maponpaths, maponpaths_2. etrans. { apply pathsinv0, (functor_comp (LRB_composition a b d)). } rewrite <- binprod_comp. rewrite id_right. etrans. { do 2 apply maponpaths. apply (pr2 (pr2 (LRB_composition_comm b c d) (g0, h0))). } apply (functor_id (LRB_composition a b d)). } etrans. { apply maponpaths. exact (LRB_lassociator_lwhisker_on f0 g0 h0 i0). } etrans. 2: { apply maponpaths_2, maponpaths, maponpaths. exact (rassociator_rassociator f0 g0 h0 i0). } etrans. 2: { apply maponpaths_2, maponpaths. etrans. 2: apply pathsinv0, (functor_comp (η (hom _ _))). apply maponpaths_2. apply pathsinv0, (functor_comp (η (hom _ _))). } rewrite ! assoc. do 2 apply maponpaths_2. assert (q : # (η (hom a e)) (pr1 (rassociator_transf a b d e) (f0, (g0 · h0 : hom _ _, i0))) · LRB_associator_comp_m' f0 g0 h0 i0 · LRB_lassociator_lwhisker f0 g0 h0 i0 = # (η (hom a e)) (rassociator f0 (g0 · h0) i0)). { refine (_ @ id_right _). rewrite assoc'. apply maponpaths. unfold LRB_associator_comp_m'. unfold LRB_lassociator_lwhisker. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } etrans. { apply maponpaths, pathsinv0, binprod_comp. } now rewrite id_right. } etrans. { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } etrans. { apply maponpaths, pathsinv0, binprod_comp. } rewrite id_right. do 2 apply maponpaths. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } etrans. { apply maponpaths, pathsinv0, binprod_comp. } rewrite id_right. etrans. { apply maponpaths, maponpaths_2. apply (pr2 (LRB_composition_comm b c d)). } apply (functor_id (LRB_composition b d e)). } rewrite id_right. etrans. { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } etrans. { apply maponpaths, pathsinv0, binprod_comp. } rewrite id_right. do 2 apply maponpaths. apply (pr2 (LRB_composition_comm b d e)). } rewrite (functor_id (LRB_composition a b e)). rewrite id_right. apply (pr2 (LRB_composition_comm a b e)). } rewrite <- q. rewrite ! assoc. do 3 apply maponpaths_2. unfold LRB_lassociator_rwhisker. rewrite ! assoc'. do 3 apply maponpaths. refine (_ @ id_right _). apply maponpaths. rewrite (functor_id (LRB_composition a d e)). rewrite id_left. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite <- (functor_comp (LRB_composition a d e)). etrans. { apply maponpaths. rewrite <- binprod_comp. apply maponpaths_2. apply (pr2 (pr2 (LRB_composition_comm a b d) (f0 , g0 · h0 : hom _ _))). } rewrite id_right. apply (functor_id (LRB_composition a d e)). } rewrite id_left. apply (pr2 (pr2 (LRB_composition_comm a d e) (f0 · (g0 · h0) : hom _ _ , i0))). Qed. Lemma LRB_laws : prebicat_laws LRB_data. Proof. repeat split ; intro ; intros. - apply id_left. - apply id_right. - apply assoc. - exact (functor_id (LRB_composition_curry1 a b c f) g). - exact (functor_id (LRB_composition_curry2 a b c g) f). - exact (! functor_comp (LRB_composition_curry1 _ _ _ _) _ _). - exact (! functor_comp (LRB_composition_curry2 _ _ _ _) _ _). - apply LRB_vcomp_lunitor. - apply LRB_vcomp_runitor. - apply LRB_lwhisker_lwhisker. - apply LRB_rwhisker_lwhisker. - apply LRB_rwhisker_rwhisker. - refine (! functor_comp (LRB_composition a b c) (x #, id2 h) (id2 g #, y) @ _). refine (_ @ functor_comp (LRB_composition a b c) (id2 f #, y) (x #, id2 i)). do 2 rewrite <- binprod_comp. now rewrite ! id_left, ! id_right. - apply (pr22 (LRB_lunitor f)). - apply (pr22 (LRB_lunitor f)). - apply (pr22 (LRB_runitor f)). - apply (pr22 (LRB_runitor f)). - apply (pr22 (LRB_associator f g h)). - apply (pr22 (LRB_associator f g h)). - apply LRB_runitor_rwhisker. - apply LRB_lassociator_lassociator. Qed. Definition LRB_pre : prebicat := LRB_data ,, LRB_laws. Definition LRB : bicat. Proof. exists LRB_pre. abstract (intro ; intros ; apply homset_property). Defined. Lemma locally_univalent_lemma (x y : B) : is_univalent (R (hom (C := B) x y)) -> is_univalent (hom (C := LRB) x y). Proof. intro u. intros f g. assert (p : (λ p : f = g, @idtoiso (R (@hom B x y)) f g p) = (λ p : f = g, @idtoiso (@hom LRB x y) f g p)). { apply funextsec ; intro p. induction p. use total2_paths_f. 2: apply isaprop_is_z_isomorphism. apply idpath. } induction p. apply u. Qed. Lemma LRB_is_locally_univalent : is_univalent_2_1 LRB. Proof. apply is_univalent_2_1_if_hom_is_univ. intros x y f g. assert (p : (λ p : f = g, @idtoiso (R (@hom B x y)) f g p) = (λ p : f = g, @idtoiso (@hom LRB x y) f g p)). { apply funextsec ; intro p. induction p. use total2_paths_f. 2: apply isaprop_is_z_isomorphism. apply idpath. } induction p. apply R. Qed. Definition psfunctor_B_to_LRB_data : psfunctor_data B LRB. Proof. use make_psfunctor_data. - exact (idfun B). - exact (λ x y, η_{x,y}). - exact (λ x y f g α, #(η_{x,y}) α). - intro ; apply identity. - exact (λ x y z f g, pr1 (LRB_composition_comm x y z) (make_catbinprod (C := hom x y) (D := hom y z) f g)). Defined. Lemma psfunctor_B_to_LRB_laws : psfunctor_laws psfunctor_B_to_LRB_data. Proof. repeat split. - exact (λ x y f, functor_id (η_{x,y}) f). - intros x y f g h α β. apply (functor_comp (η_{x,y})). - exact (λ x y f, prewhisker_LRB_lunitor f). - exact (λ x y f, prewhisker_LRB_runitor f). - exact (λ x y z w f g h, prewhisker_LRB_associator f g h). - intro ; intros. set (t := λ fg, ! pr21 (LRB_composition_comm a b c) (make_catbinprod (C:=hom _ _) (D:=hom _ _) f g₁) (make_catbinprod (C:=hom _ _) (D:=hom _ _) f g₂) fg). cbn in t. refine (_ @ t (catbinprodmor (C:=hom _ _) (D:=hom _ _) (id2 f) η0) @ _). + do 2 apply maponpaths. apply lwhisker_hcomp. + now rewrite (functor_id (η (hom a b))). - intro ; intros. unfold psfunctor_B_to_LRB_data. set (t := λ fg, ! pr21 (LRB_composition_comm a b c) (make_catbinprod (C:=hom _ _) (D:=hom _ _) f₁ g) (make_catbinprod (C:=hom _ _) (D:=hom _ _) f₂ g) fg). cbn in t. refine (_ @ t (catbinprodmor (C:=hom _ _) (D:=hom _ _) η0 (id2 g)) @ _). + do 2 apply maponpaths. apply rwhisker_hcomp. + now rewrite (functor_id (η (hom b c))). Qed. Definition psfunctor_B_to_LRB_invertible_cells : invertible_cells psfunctor_B_to_LRB_data. Proof. split. - exact (λ x, is_invertible_2cell_id₂ (C := LRB) (η (hom x x) (id₁ x))). - exact (λ x y z f g, pr2 (lift_functor_along_comm (R (hom x z)) (pair_functor (η_{x,y}) (η_{y,z})) (pair_functor_eso (η_{x,y}) (η_{y,z}) (eso (hom x y)) (eso_{y,z})) (pair_functor_ff (η_{x,y}) (η_{y,z}) (ff_{x,y}) (ff_{y,z})) (hcomp_functor ∙ η_{x,z})) (make_catbinprod (C := hom x y) (D := hom y z) f g)). Defined. Definition psfunctor_B_to_LRB : psfunctor B LRB. Proof. use make_psfunctor. - exact psfunctor_B_to_LRB_data. - exact psfunctor_B_to_LRB_laws. - exact psfunctor_B_to_LRB_invertible_cells. Defined. Definition psfunctor_B_to_LRB_is_weak_biequivalence : weak_biequivalence psfunctor_B_to_LRB. Proof. split. - intro x. apply hinhpr. exists x. apply internal_adjoint_equivalence_identity. - intros x y. exists eso_{x,y}. exact ff_{x,y}. Defined. End LocalUnivalenceRezk. UniMath-20231010/UniMath/Bicategories/RezkCompletions/RezkCompletionOfBicategory.v000066400000000000000000000044151451125700300300420ustar00rootroot00000000000000(* In this file, we combine the results that any bicategory is weak biequivalent to a locally univalent bicategory and that any locally univalent bicategory is weak biequivalent to a global univalent bicategory. This shows how any bicategory admits a Rezk completion. We also instantiate the result with the construction of the Rezk completion of categories using representable presheaves in order to do the "local Rezk completion". *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.YonedaLemma. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.RezkCompletions.BicatToLocalUnivalentBicat. Require Import UniMath.CategoryTheory.rezk_completion. Require Import UniMath.CategoryTheory.RezkCompletion. Local Open Scope cat. Section RezkCompletionBicategory. Definition rezk_completion_2_1 (R : RezkCat) (B : bicat) : ∑ RB : bicat, ∑ HB : psfunctor B RB, is_univalent_2_1 RB × weak_biequivalence HB. Proof. exists (LRB R B). exists (psfunctor_B_to_LRB R B). exists (LRB_is_locally_univalent R B). exact (psfunctor_B_to_LRB_is_weak_biequivalence R B). Defined. Definition rezk_completion_2 (R : RezkCat) (B : bicat) : ∑ RB : bicat, ∑ HB : psfunctor B RB, is_univalent_2 RB × weak_biequivalence HB. Proof. set (r := rezk_completion_2_0 (LRB R B) (LRB_is_locally_univalent R B)). exists (pr1 r). exists (comp_psfunctor (pr12 r) (psfunctor_B_to_LRB R B)). exists (pr122 r). use comp_weak_biequivalence. - apply psfunctor_B_to_LRB_is_weak_biequivalence. - exact (weak_equivalence_to_is_weak_biequivalence _ (pr222 r)). Defined. End RezkCompletionBicategory. Definition rezk_completion_2_presheaves (B : bicat) : ∑ RB : bicat, ∑ HB : psfunctor B RB, is_univalent_2 RB × weak_biequivalence HB. Proof. use rezk_completion_2. exact (λ C, _ ,, _ ,, Rezk_eta_essentially_surjective C ,, Rezk_eta_fully_faithful C). Defined. UniMath-20231010/UniMath/Bicategories/RezkCompletions/StructuredCats/000077500000000000000000000000001451125700300253635ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/RezkCompletions/StructuredCats/TerminalObject.v000066400000000000000000000157431451125700300304660ustar00rootroot00000000000000(* In this file, we show how the Rezk completion of a categories has a suitable terminal object (in terms of preservation) if the original category has a terminal object. Hence, categories with terminal objects admit a Rezk completion. Contents: 1. BicatOfCategoriesWithTerminalHasRezkCompletion: A construction of the Rezk completion of categories equipped with a terminal object (up to propositional truncation). 2. BicatOfCategoriesWithChosenTerminalHasRezkCompletion: A construction of the Rezk completion of categories equipped with a chosen terminal object. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.TotalAdjunction. Require Import UniMath.CategoryTheory.WeakEquivalences. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.Bicategories.Modifications.Modification. Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction. Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles. Import DispBicat.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.BicatOfCatToUnivCat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOnCatToUniv. Require Import UniMath.Bicategories.DisplayedBicats.Examples.CategoriesWithStructure. Require Import UniMath.Bicategories.DisplayedBicats.DisplayedUniversalArrow. Require Import UniMath.Bicategories.DisplayedBicats.DisplayedUniversalArrowOnCat. Local Open Scope cat. Section BicatOfCategoriesWithTerminalHasRezkCompletion. Let UnivCat := bicat_of_univ_cats. Let Cat := bicat_of_cats. Let R := univ_cats_to_cats. Context (LUR : left_universal_arrow R). Let η := (pr12 LUR). Context (η_weak_equiv : ∏ C : category, is_weak_equiv (η C)). Let D := disp_bicat_have_terminal_obj. Let RR := (disp_psfunctor_on_cat_to_univ_cat D (disp_2cells_isaprop_from_disp_2cells_iscontr _ disp_2cells_is_contr_have_terminal_obj)). Definition cat_with_terminal_obj_has_RezkCompletion : disp_left_universal_arrow LUR RR. Proof. use make_disp_left_universal_arrow_if_contr_CAT_from_weak_equiv. - exact η_weak_equiv. - intros C1 C2 C2_univ F Fw C1_term. refine (_ ,, tt). use (factor_through_squash _ _ (pr1 C1_term)). { apply isapropishinh. } clear C1_term. intro C1_term. apply hinhpr. set (t := weak_equiv_preserves_chosen_terminal _ Fw C1_term). exact (F C1_term ,, t). - intros C C1_term. refine (tt ,, _). use (factor_through_squash _ _ (pr1 C1_term)). { apply isaprop_preserves_terminal. } intro C1_term'. use weak_equiv_preserves_terminal. apply η_weak_equiv. - intros C1 C2 C3 F G H α C1_term C2_term C3_term Gw. intros [t Fpterm]. exists tt. intros x2 x2_is_term. use (factor_through_squash _ _ (eso_from_weak_equiv _ Gw x2)). { apply isaprop_isTerminal. } intros [x1 i] y3. use (iscontrweqb' (Y := (pr1 C3⟦y3, H(G x1)⟧))). + use (iscontrweqb' (Y := (pr1 C3⟦y3, F x1⟧))). * use (Fpterm _ _). use (weak_equiv_reflects_terminal _ Gw). exact (iso_to_Terminal (_,, x2_is_term) _ (z_iso_inv i)). * apply z_iso_comp_left_weq. exact (_ ,, pr2 α x1). + apply z_iso_comp_left_weq. apply functor_on_z_iso. exact (z_iso_inv i). Defined. End BicatOfCategoriesWithTerminalHasRezkCompletion. Section BicatOfCategoriesWithChosenTerminalHasRezkCompletion. Let UnivCat := bicat_of_univ_cats. Let Cat := bicat_of_cats. Let R := univ_cats_to_cats. Context (LUR : left_universal_arrow R). Let η := (pr12 LUR). Context (η_weak_equiv : ∏ C : category, is_weak_equiv (η C)). Let D := disp_bicat_chosen_terminal_obj. Let RR := (disp_psfunctor_on_cat_to_univ_cat D (disp_2cells_isaprop_from_disp_2cells_iscontr _ disp_2cells_is_contr_chosen_terminal_obj)). Definition cat_with_chosen_terminal_obj_has_RezkCompletion : disp_left_universal_arrow LUR RR. Proof. use make_disp_left_universal_arrow_if_contr_CAT_from_weak_equiv. - exact η_weak_equiv. - intros C1 C2 C2_univ F Fw C1_term. refine (_ ,, tt). set (t := weak_equiv_preserves_chosen_terminal _ Fw (pr1 C1_term)). exact (F (pr11 C1_term) ,, t). - intros C C1_term. refine (tt ,, _). apply hinhpr. apply idpath. - intros C1 C2 C3 F G H α C1_term C2_term C3_term Gw. intros [t Fpterm]. exists tt. use (factor_through_squash _ _ Fpterm). { apply isapropishinh. } intro p. set (Gpterm := weak_equiv_preserves_chosen_terminal_eq _ Gw (pr2 C2) (pr1 C1_term) (pr1 C2_term)). use (factor_through_squash _ _ Gpterm). { apply isapropishinh. } intro q. apply hinhpr. refine (_ @ p). etrans. { apply maponpaths, (! q). } apply C3. simpl in C1_term ; exact (_ ,, pr2 α (pr1 C1_term)). Defined. End BicatOfCategoriesWithChosenTerminalHasRezkCompletion. UniMath-20231010/UniMath/Bicategories/Transformations/000077500000000000000000000000001451125700300224455ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Transformations/Examples/000077500000000000000000000000001451125700300242235ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/Transformations/Examples/AlgebraMap.v000066400000000000000000000063711451125700300264140ustar00rootroot00000000000000(* ******************************************************************************* *) (** Algebra map as pseudotransformation ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras. Definition var {C : bicat} (F S : psfunctor C C) : pstrans (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C S (pr1_psfunctor (disp_alg_bicat F))) (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C S (pr1_psfunctor (disp_alg_bicat F))) := id₁ _. Definition alg_map_data {C : bicat} (F : psfunctor C C) : pstrans_data (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C F (pr1_psfunctor (disp_alg_bicat F))) (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C (id_psfunctor C) (pr1_psfunctor (disp_alg_bicat F))). Proof. use make_pstrans_data. - intros X ; cbn in *. exact (pr2 X). - intros X Y f ; cbn in *. exact (pr2 f). Defined. Definition alg_map_data_is_pstrans {C : bicat} (F : psfunctor C C) : is_pstrans (alg_map_data F). Proof. repeat split ; cbn. - intros X Y f g α. apply α. - intros. rewrite !id2_left, lwhisker_id2, psfunctor_id2. rewrite !id2_left, !id2_right. reflexivity. - intros. rewrite !id2_left, lwhisker_id2, psfunctor_id2. rewrite !id2_left, !id2_right. reflexivity. Qed. Definition alg_map {C : bicat} (F : psfunctor C C) : pstrans (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C F (pr1_psfunctor (disp_alg_bicat F))) (@comp_psfunctor (total_bicat (disp_alg_bicat F)) C C (id_psfunctor C) (pr1_psfunctor (disp_alg_bicat F))). Proof. use make_pstrans. - exact (alg_map_data F). - exact (alg_map_data_is_pstrans F). Defined. UniMath-20231010/UniMath/Bicategories/Transformations/Examples/ApTransformation.v000066400000000000000000000051711451125700300277050ustar00rootroot00000000000000(** Each homotopy between functions give rise to a pseudotransformation *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.Core.Examples.TwoType. Require Import UniMath.Bicategories.PseudoFunctors.Examples.ApFunctor. Local Open Scope cat. Definition homotsec_natural {X Y : UU} {f g : X → Y} (e : f ~ g) {x y : X} (p : x = y) : e x @ maponpaths g p = maponpaths f p @ e y. Proof. induction p. apply pathscomp0rid. Defined. Definition homotsec_natural_natural {X Y : UU} {f g : X → Y} (e : f ~ g) {x y : X} {p q : x = y} (h : p = q) : maponpaths (λ s : g x = g y, e x @ s) (maponpaths (maponpaths g) h) @ homotsec_natural e q = homotsec_natural e p @ maponpaths (λ s : f x = f y, s @ e y) (maponpaths (maponpaths f) h). Proof. induction h. exact (!(pathscomp0rid _)). Defined. Section ApTrans. Context {X Y : UU} (HX : isofhlevel 4 X) (HY : isofhlevel 4 Y) {f g : X → Y} (e : f ~ g). Definition ap_pstrans_data : pstrans_data (ap_psfunctor HX HY f) (ap_psfunctor HX HY g). Proof. use make_pstrans_data. - exact e. - intros x y p. use make_invertible_2cell. + exact (homotsec_natural e p). + apply fundamental_groupoid_2cell_iso. Defined. Definition ap_pstrans_laws : is_pstrans ap_pstrans_data. Proof. repeat split. - simpl ; intros x y p q h ; cbn. exact (homotsec_natural_natural e h). - simpl ; intro x ; cbn. exact (!(pathscomp0rid _ @ pathscomp0rid _)). - simpl ; intros x y z p q ; cbn. induction p, q. cbn. induction (e x). apply idpath. Qed. Definition ap_pstrans : pstrans (ap_psfunctor HX HY f) (ap_psfunctor HX HY g). Proof. use make_pstrans. - exact ap_pstrans_data. - exact ap_pstrans_laws. Defined. End ApTrans. UniMath-20231010/UniMath/Bicategories/Transformations/Examples/Associativity.v000066400000000000000000000172671451125700300272620ustar00rootroot00000000000000(* ******************************************************************************* *) (** Associativity laws ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Local Open Scope cat. Section Associativity. Context {B₁ B₂ B₃ B₄: bicat}. Variable (F₁ : psfunctor B₁ B₂) (F₂ : psfunctor B₂ B₃) (F₃ : psfunctor B₃ B₄). Definition lassociator_pstrans_data : pstrans_data (comp_psfunctor F₃ (comp_psfunctor F₂ F₁)) (comp_psfunctor (comp_psfunctor F₃ F₂) F₁). Proof. use make_pstrans_data. - exact (λ X, id₁ _). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition lassociator_pstrans_is_pstrans : is_pstrans lassociator_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. apply maponpaths. rewrite rinvunitor_natural. etrans. { etrans. { apply maponpaths. rewrite !vassocr. rewrite rinvunitor_natural. rewrite <- !rwhisker_hcomp. rewrite !vassocl. rewrite !rwhisker_vcomp. apply idpath. } rewrite !vassocr. rewrite rinvunitor_natural. rewrite !vassocl. rewrite <- rwhisker_hcomp. rewrite rwhisker_vcomp. apply idpath. } rewrite psfunctor_vcomp. rewrite rwhisker_vcomp. rewrite lunitor_V_id_is_left_unit_V_id. apply idpath. - intros X Y Z f g ; cbn. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. refine (!_). etrans. { rewrite !vassocr. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. rewrite lunitor_triangle. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. apply idpath. } rewrite !vassocl. rewrite rinvunitor_triangle. apply idpath. } rewrite !vassocl. rewrite rwhisker_vcomp. etrans. { rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. apply idpath. } apply maponpaths. refine (!_). etrans. { rewrite !vassocr. rewrite lwhisker_vcomp. rewrite !vassocl. apply idpath. } rewrite psfunctor_vcomp. apply idpath. Qed. Definition lassociator_pstrans : pstrans (comp_psfunctor F₃ (comp_psfunctor F₂ F₁)) (comp_psfunctor (comp_psfunctor F₃ F₂) F₁). Proof. use make_pstrans. - exact lassociator_pstrans_data. - exact lassociator_pstrans_is_pstrans. Defined. Definition rassociator_pstrans_data : pstrans_data (comp_psfunctor (comp_psfunctor F₃ F₂) F₁) (comp_psfunctor F₃ (comp_psfunctor F₂ F₁)). Proof. use make_pstrans_data. - exact (λ X, id₁ _). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition rassociator_pstrans_is_pstrans : is_pstrans rassociator_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite <- !rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. apply maponpaths. rewrite rinvunitor_natural. etrans. { rewrite !vassocr. rewrite rinvunitor_natural. apply idpath. } rewrite !vassocl. rewrite lunitor_V_id_is_left_unit_V_id. apply maponpaths. rewrite <- !rwhisker_hcomp. rewrite !rwhisker_vcomp. rewrite psfunctor_vcomp. apply idpath. - intros X Y Z f g ; cbn. rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. refine (!_). etrans. { rewrite !vassocr. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. rewrite lunitor_triangle. rewrite !vassocl. rewrite rwhisker_hcomp. rewrite <- triangle_r_inv. rewrite <- lwhisker_hcomp. apply idpath. } apply maponpaths_2. rewrite !vassocl. rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_right. apply idpath. } apply maponpaths_2. rewrite !vassocl. rewrite rinvunitor_triangle. apply idpath. } rewrite !vassocl. rewrite !rwhisker_vcomp. etrans. { rewrite rwhisker_hcomp. rewrite <- rinvunitor_natural. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. apply idpath. } apply maponpaths. etrans. { apply maponpaths. rewrite !vassocr. rewrite <- vcomp_lunitor. rewrite !vassocl. apply idpath. } rewrite !vassocr. rewrite lwhisker_vcomp. rewrite psfunctor_vcomp. apply idpath. Qed. Definition rassociator_pstrans : pstrans (comp_psfunctor (comp_psfunctor F₃ F₂) F₁) (comp_psfunctor F₃ (comp_psfunctor F₂ F₁)). Proof. use make_pstrans. - exact rassociator_pstrans_data. - exact rassociator_pstrans_is_pstrans. Defined. End Associativity. UniMath-20231010/UniMath/Bicategories/Transformations/Examples/PseudoTransformationIntoCat.v000066400000000000000000000222021451125700300320600ustar00rootroot00000000000000(******************************************************************************** Pseudotransformations and indexed functors In this file, we relate indexed functors and pseudotransformations. We first give constructors for pseudotransformations between pseudofunctors whose source is a discrete bicategory, and in the case that the target is the bicategory of univalent categories. After that, we show that every indexed functor gives rise to a pseudotransformation and vice versa. Contents 1. Pseudotransformations between pseudofunctors from discrete bicategories 2. Pseudotransformations between pseudofunctors to categories 3. Indexed functors to pseudotransformations 4. Pseudotransformations to indexed functors ********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Discreteness. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.Univalence. Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats. Require Import UniMath.Bicategories.Core.Examples.DiscreteBicat. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.PseudoFunctorsIntoCat. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Local Open Scope cat. (** 1. Pseudotransformations between pseudofunctors from discrete bicategories *) Section PseudoTransFromCat. Context {C : category} {B : bicat} {F G : psfunctor (cat_to_bicat C) B} (τ₀ : ∏ (x : C), F x --> G x) (τ₁ : ∏ (x y : C) (f : x --> y), invertible_2cell (τ₀ x · # G f) (# F f · τ₀ y)) (τid : ∏ (x : C), (τ₀ x ◃ psfunctor_id G x) • τ₁ x x (identity x) = runitor (τ₀ x) • linvunitor (τ₀ x) • (psfunctor_id F x ▹ τ₀ x)) (τc : ∏ (x y z : C) (f : x --> y) (g : y --> z), (τ₀ x ◃ psfunctor_comp G f g) • τ₁ x z (f · g) = lassociator (τ₀ x) (# G f) (# G g) • (τ₁ x y f ▹ # G g) • rassociator (# F f) (τ₀ y) (# G g) • (# F f ◃ τ₁ y z g) • lassociator (# F f) (# F g) (τ₀ z) • (psfunctor_comp F f g ▹ τ₀ z)). Definition make_pstrans_from_cat_data : pstrans_data F G. Proof. use make_pstrans_data. - exact τ₀. - exact τ₁. Defined. Proposition make_pstrans_from_cat_laws : is_pstrans make_pstrans_from_cat_data. Proof. repeat split. - cbn ; intros x y f g p. induction p. etrans. { apply maponpaths_2. apply maponpaths. refine (_ @ psfunctor_id2 G f). apply maponpaths. apply homset_property. } rewrite lwhisker_id2. rewrite id2_left. refine (!_). etrans. { do 2 apply maponpaths. refine (_ @ psfunctor_id2 F f). apply maponpaths. apply homset_property. } rewrite id2_rwhisker. rewrite id2_right. apply idpath. - exact τid. - exact τc. Qed. Definition make_pstrans_from_cat : pstrans F G. Proof. use make_pstrans. - exact make_pstrans_from_cat_data. - exact make_pstrans_from_cat_laws. Defined. End PseudoTransFromCat. (** 2. Pseudotransformations between pseudofunctors to categories *) Definition pstrans_from_cat_into_cat_data {C : category} (F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats) : UU := ∑ (τ₀ : ∏ (x : C), F x --> G x), ∏ (x y : C) (f : x --> y), nat_z_iso (τ₀ x · # G f) (# F f · τ₀ y). Definition make_pstrans_from_cat_into_cat_data {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ₀ : ∏ (x : C), F x --> G x) (τ₁ : ∏ (x y : C) (f : x --> y), nat_z_iso (τ₀ x · # G f) (# F f · τ₀ y)) : pstrans_from_cat_into_cat_data F G := τ₀ ,, τ₁. Definition pstrans_from_cat_into_cat_data_to_ob {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ : pstrans_from_cat_into_cat_data F G) (x : C) : F x --> G x := pr1 τ x. Coercion pstrans_from_cat_into_cat_data_to_ob : pstrans_from_cat_into_cat_data >-> Funclass. Definition pstrans_from_cat_into_cat_data_nat {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ : pstrans_from_cat_into_cat_data F G) {x y : C} (f : x --> y) : nat_z_iso (τ x · # G f) (# F f · τ y) := pr2 τ x y f. Definition pstrans_from_cat_into_cat_laws {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ : pstrans_from_cat_into_cat_data F G) : UU := (∏ (x : C) (xx : pr1 (F x)), pr11 (psfunctor_id G x) (pr1 (τ x) xx) · pr1 (pstrans_from_cat_into_cat_data_nat τ (id₁ x)) xx = # (pr1 (τ x)) (pr11 (psfunctor_id F x) xx)) × (∏ (x y z : C) (f : x --> y) (g : y --> z) (xx : pr1 (F x)), pr11 (psfunctor_comp G f g) (pr1 (τ x) xx) · pr1 (pstrans_from_cat_into_cat_data_nat τ (f · g)) xx = # (pr1 (# G g)) ((pr11 (pstrans_from_cat_into_cat_data_nat τ f)) xx) · (pr11 (pstrans_from_cat_into_cat_data_nat τ g)) (pr1 (# F f) xx) · # (pr1 (τ z)) (pr11 (psfunctor_comp F f g) xx)). Section PseudoTransIntoCat. Context {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ : pstrans_from_cat_into_cat_data F G) (Hτ : pstrans_from_cat_into_cat_laws τ). Definition pstrans_from_cat_into_cat : pstrans F G. Proof. use make_pstrans_from_cat. - exact τ. - intros x y f. use nat_z_iso_to_invertible_2cell. exact (pstrans_from_cat_into_cat_data_nat τ f). - abstract (intros x ; use nat_trans_eq ; [ apply homset_property | ] ; intro xx ; cbn -[psfunctor_id] ; rewrite !id_left ; exact (pr1 Hτ x xx)). - abstract (intros x y z f g ; use nat_trans_eq ; [ apply homset_property | ] ; intro xx ; cbn -[psfunctor_comp] ; rewrite !id_left ; rewrite !id_right ; exact (pr2 Hτ x y z f g xx)). Defined. End PseudoTransIntoCat. (** 3. Indexed functors to pseudotransformations *) Definition indexed_functor_to_pstrans {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor Φ Ψ) : pstrans (indexed_cat_to_psfunctor Φ) (indexed_cat_to_psfunctor Ψ). Proof. use pstrans_from_cat_into_cat. - use make_pstrans_from_cat_into_cat_data. + exact τ. + exact (λ x y f, indexed_functor_natural τ f). - split. + exact (λ x xx, indexed_functor_id τ xx). + exact (λ x y z f g xx, indexed_functor_comp τ f g xx). Defined. (** 4. Pseudotransformations to indexed functors *) Section PseudoTransformationToIndexedFunctor. Context {C : category} {F G : psfunctor (cat_to_bicat C) bicat_of_univ_cats} (τ : pstrans F G). Definition pstrans_to_indexed_functor_data : indexed_functor_data (psfunctor_to_indexed_cat F) (psfunctor_to_indexed_cat G). Proof. use make_indexed_functor_data. - exact (λ x, τ x). - exact (λ x y f, invertible_2cell_to_nat_z_iso _ _ (psnaturality_of τ f)). Defined. Proposition pstrans_to_indexed_functor_laws : indexed_functor_laws pstrans_to_indexed_functor_data. Proof. repeat split. - intros x xx. refine (nat_trans_eq_pointwise (pstrans_id τ x) xx @ _) ; cbn. rewrite !id_left. apply idpath. - intros x y z f g xx. refine (nat_trans_eq_pointwise (pstrans_comp τ f g) xx @ _) ; cbn. rewrite !id_left, !id_right. apply idpath. Qed. Definition pstrans_to_indexed_functor : indexed_functor (psfunctor_to_indexed_cat F) (psfunctor_to_indexed_cat G). Proof. use make_indexed_functor. - exact pstrans_to_indexed_functor_data. - exact pstrans_to_indexed_functor_laws. Defined. End PseudoTransformationToIndexedFunctor. UniMath-20231010/UniMath/Bicategories/Transformations/Examples/Unitality.v000066400000000000000000000212411451125700300263740ustar00rootroot00000000000000(* ******************************************************************************* *) (** Unitality laws ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.Core.Unitors. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Local Open Scope cat. Section LeftUnitality. Context {B₁ B₂ : bicat}. Variable (F : psfunctor B₁ B₂). Definition lunitor_pstrans_data : pstrans_data (comp_psfunctor (id_psfunctor B₂) F) F. Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition lunitor_pstrans_is_pstrans : is_pstrans lunitor_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite id2_left. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite rinvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. apply idpath. - intros X Y Z f g ; cbn. rewrite id2_left. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. pose (triangle_r_inv (#F g) (#F f)) as p. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp in p. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. exact (!p). } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition lunitor_pstrans : pstrans (comp_psfunctor (id_psfunctor B₂) F) F. Proof. use make_pstrans. - exact lunitor_pstrans_data. - exact lunitor_pstrans_is_pstrans. Defined. Definition linvunitor_pstrans_data : pstrans_data F (comp_psfunctor (id_psfunctor B₂) F). Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition linvunitor_pstrans_is_pstrans : is_pstrans linvunitor_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite id2_left. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite rinvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. apply idpath. - intros X Y Z f g ; cbn. rewrite id2_left. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. pose (triangle_r_inv (#F g) (#F f)) as p. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp in p. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. exact (!p). } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition linvunitor_pstrans : pstrans F (comp_psfunctor (id_psfunctor B₂) F). Proof. use make_pstrans. - exact linvunitor_pstrans_data. - exact linvunitor_pstrans_is_pstrans. Defined. End LeftUnitality. Section RightUnitality. Context {B₁ B₂ : bicat}. Variable (F : psfunctor B₁ B₂). Definition runitor_pstrans_data : pstrans_data (comp_psfunctor F (id_psfunctor B₁)) F. Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition runitor_pstrans_is_pstrans : is_pstrans runitor_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite psfunctor_id2, id2_right. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite rinvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. apply idpath. - intros X Y Z f g ; cbn. rewrite psfunctor_id2, id2_right. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. pose (triangle_r_inv (#F g) (#F f)) as p. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp in p. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. exact (!p). } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition runitor_pstrans : pstrans (comp_psfunctor F (id_psfunctor B₁)) F. Proof. use make_pstrans. - exact runitor_pstrans_data. - exact runitor_pstrans_is_pstrans. Defined. Definition rinvunitor_pstrans_data : pstrans_data F (comp_psfunctor F (id_psfunctor B₁)). Proof. use make_pstrans_data. - exact (λ X, id₁ (F X)). - intros X Y f ; cbn. use make_invertible_2cell. + exact (lunitor _ • rinvunitor _). + is_iso. Defined. Definition rinvunitor_pstrans_is_pstrans : is_pstrans rinvunitor_pstrans_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. - intros X ; cbn. rewrite psfunctor_id2, id2_right. rewrite !vassocr. rewrite vcomp_lunitor. rewrite !vassocl. rewrite lunitor_runitor_identity. rewrite rinvunitor_natural. rewrite lunitor_V_id_is_left_unit_V_id. rewrite rwhisker_hcomp. apply idpath. - intros X Y Z f g ; cbn. rewrite psfunctor_id2, id2_right. rewrite <- lwhisker_vcomp, <- rwhisker_vcomp. rewrite !vassocr. rewrite vcomp_lunitor. rewrite lunitor_triangle. rewrite !vassocl. apply maponpaths. pose (triangle_r_inv (#F g) (#F f)) as p. rewrite <- lwhisker_hcomp, <- rwhisker_hcomp in p. rewrite !vassocr. refine (!_). etrans. { do 4 apply maponpaths_2. exact (!p). } rewrite lwhisker_vcomp. rewrite linvunitor_lunitor, lwhisker_id2, id2_left. rewrite rinvunitor_triangle. rewrite rinvunitor_natural. rewrite rwhisker_hcomp. apply idpath. Qed. Definition rinvunitor_pstrans : pstrans F (comp_psfunctor F (id_psfunctor B₁)). Proof. use make_pstrans. - exact rinvunitor_pstrans_data. - exact rinvunitor_pstrans_is_pstrans. Defined. End RightUnitality. UniMath-20231010/UniMath/Bicategories/Transformations/Examples/Whiskering.v000066400000000000000000000162131451125700300265270ustar00rootroot00000000000000(* ******************************************************************************* *) (** Left whiskering ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition. Require Import UniMath.Bicategories.Transformations.PseudoTransformation. Local Open Scope cat. Section LeftWhisker. Context {B₁ B₂ B₃ : bicat} {F₁ F₂ : psfunctor B₁ B₂}. Variable (G : psfunctor B₂ B₃) (η : pstrans F₁ F₂). Definition left_whisker_data : pstrans_data (comp_psfunctor G F₁) (comp_psfunctor G F₂). Proof. use make_pstrans_data. - exact (λ X, #G (η X)). - intros X Y f ; cbn. use make_invertible_2cell. + exact ((psfunctor_comp G (η X) (#F₂ f)) • ##G (psnaturality_of η f) • (psfunctor_comp G (#F₁ f) (η Y))^-1). + is_iso. * apply psfunctor_comp. * apply psfunctor_is_iso. Defined. Definition left_whisker_is_pstrans : is_pstrans left_whisker_data. Proof. repeat split. - intros X Y f g α ; cbn. rewrite !vassocr. rewrite <- psfunctor_lwhisker. rewrite !vassocl. apply maponpaths. rewrite !vassocr. rewrite <- psfunctor_vcomp. rewrite psnaturality_natural. rewrite psfunctor_vcomp. rewrite !vassocl. apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite psfunctor_rwhisker. apply idpath. - intros X ; cbn. rewrite psfunctor_runitor. rewrite <- lwhisker_vcomp. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } cbn. rewrite !vassocl. apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. rewrite <- rwhisker_vcomp. rewrite !vassocl. etrans. { do 2 apply maponpaths. rewrite <- psfunctor_rwhisker. apply idpath. } rewrite !vassocr. apply maponpaths_2. exact (!(psfunctor_linvunitor G (η X))). } rewrite <- !psfunctor_vcomp. etrans. { do 2 apply maponpaths. rewrite !vassocr. exact (!(pstrans_id η X)). } refine (!_). etrans. { rewrite !vassocr. rewrite <- psfunctor_lwhisker. rewrite !vassocl. apply idpath. } rewrite psfunctor_vcomp. apply idpath. - intros X Y Z f g. cbn -[psfunctor_comp]. etrans. { apply maponpaths_2. apply maponpaths. apply comp_psfunctor_psfunctor_comp. } refine (!_). etrans. { apply maponpaths. apply maponpaths. apply comp_psfunctor_psfunctor_comp. } rewrite !vassocl. refine (!_). rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp. etrans. { rewrite !vassocr. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !vassocl. rewrite <- psfunctor_lwhisker. apply idpath. } rewrite !vassocl. rewrite <- psfunctor_vcomp. rewrite pstrans_comp. rewrite !psfunctor_vcomp. rewrite !vassocr. do 5 apply maponpaths_2. apply psfunctor_lassociator. } rewrite !vassocl. do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite psfunctor_rwhisker. rewrite !vassocl. apply idpath. } apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp]. etrans. { rewrite !vassocr. rewrite psfunctor_rassociator. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. etrans. { rewrite !vassocr. rewrite psfunctor_lwhisker. rewrite !vassocl. apply idpath. }apply maponpaths. use vcomp_move_L_pM. { is_iso. } cbn -[psfunctor_comp]. etrans. { rewrite !vassocr. rewrite psfunctor_lassociator. rewrite !vassocl. apply idpath. } do 2 apply maponpaths. rewrite !vassocr. use vcomp_move_R_Mp. { is_iso. } cbn -[psfunctor_comp]. rewrite psfunctor_rwhisker. apply idpath. Qed. Definition left_whisker : pstrans (comp_psfunctor G F₁) (comp_psfunctor G F₂). Proof. use make_pstrans. - exact left_whisker_data. - exact left_whisker_is_pstrans. Defined. End LeftWhisker. Section RightWhisker. Context {B₁ B₂ B₃ : bicat} {G₁ G₂ : psfunctor B₂ B₃}. Variable (F : psfunctor B₁ B₂) (η : pstrans G₁ G₂). Definition right_whisker_data : pstrans_data (comp_psfunctor G₁ F) (comp_psfunctor G₂ F). Proof. use make_pstrans_data. - exact (λ X, η (F X)). - exact (λ X Y f, psnaturality_of η (#F f)). Defined. Definition right_whisker_is_pstrans : is_pstrans right_whisker_data. Proof. repeat split. - intros X Y f g α ; cbn. exact (psnaturality_natural η _ _ _ _ (##F α)). - intros X ; cbn. rewrite <- rwhisker_vcomp. rewrite !vassocr. refine (!_). etrans. { apply maponpaths_2. exact (!(pstrans_id η (F X))). } cbn. rewrite <- lwhisker_vcomp. rewrite !vassocl. apply maponpaths. rewrite psnaturality_natural. apply idpath. - intros X Y Z f g ; cbn. etrans. { rewrite <- lwhisker_vcomp. rewrite !vassocl. rewrite psnaturality_natural. rewrite !vassocr. apply maponpaths_2. exact (pstrans_comp η (#F f) (#F g)). } rewrite !vassocl. do 5 apply maponpaths. rewrite rwhisker_vcomp. apply idpath. Qed. Definition right_whisker : pstrans (comp_psfunctor G₁ F) (comp_psfunctor G₂ F). Proof. use make_pstrans. - exact right_whisker_data. - exact right_whisker_is_pstrans. Defined. End RightWhisker. Notation "G ◅ η" := (left_whisker G η). Notation "η ▻ F" := (right_whisker F η). UniMath-20231010/UniMath/Bicategories/Transformations/PseudoTransformation.v000066400000000000000000000330121451125700300270210ustar00rootroot00000000000000(** Pseudo transformations and pseudo transformations between pseudofunctors. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Morphisms.Adjunctions. Require Import UniMath.Bicategories.Core.Invertible_2cells. Require Import UniMath.Bicategories.Core.BicategoryLaws. Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence. Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod. Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub. Require Import UniMath.Bicategories.PseudoFunctors.Display.Base. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells. Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor. Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor. Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat. Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor. Import PseudoFunctor.Notations. Local Open Scope cat. Definition pstrans_data {C D : bicat} (F G : psfunctor C D) : UU. Proof. refine (map1cells C D⟦_,_⟧). - apply F. - apply G. Defined. Definition make_pstrans_data {C D : bicat} {F G : psfunctor C D} (η₁ : ∏ (X : C), F X --> G X) (η₂ : ∏ (X Y : C) (f : X --> Y), invertible_2cell (η₁ X · #G f) (#F f · η₁ Y)) : pstrans_data F G := (η₁ ,, η₂). Definition pstrans {C D : bicat} (F G : psfunctor C D) : UU := psfunctor_bicat C D ⟦F,G⟧. Definition pscomponent_of {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ (X : C), F X --> G X := pr111 η. Coercion pscomponent_of : pstrans >-> Funclass. Definition psnaturality_of {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ {X Y : C} (f : X --> Y), invertible_2cell (η X · #G f) (#F f · η Y) := pr211 η. Definition is_pstrans {C D : bicat} {F G : psfunctor C D} (η : pstrans_data F G) : UU := (∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (pr1 η X ◃ ##G α) • pr2 η _ _ g = (pr2 η _ _ f) • (##F α ▹ pr1 η Y)) × (∏ (X : C), (pr1 η X ◃ psfunctor_id G X) • pr2 η _ _ (id₁ X) = (runitor (pr1 η X)) • linvunitor (pr1 η X) • (psfunctor_id F X ▹ pr1 η X)) × (∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), (pr1 η X ◃ psfunctor_comp G f g) • pr2 η _ _ (f · g) = (lassociator (pr1 η X) (#G f) (#G g)) • (pr2 η _ _ f ▹ (#G g)) • rassociator (#F f) (pr1 η Y) (#G g) • (#F f ◃ pr2 η _ _ g) • lassociator (#F f) (#F g) (pr1 η Z) • (psfunctor_comp F f g ▹ pr1 η Z)). Definition make_pstrans {C D : bicat} {F G : psfunctor C D} (η : pstrans_data F G) (Hη : is_pstrans η) : pstrans F G. Proof. refine ((η ,, _) ,, tt). repeat split ; cbn ; intros ; apply Hη. Defined. Definition psnaturality_natural {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (η X ◃ ##G α) • psnaturality_of η g = (psnaturality_of η f) • (##F α ▹ η Y) := pr121 η. Definition psnaturality_inv_natural {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (psnaturality_of η f)^-1 • (η X ◃ ##G α) = (##F α ▹ η Y) • (psnaturality_of η g)^-1. Proof. intros X Y f g α. use vcomp_move_L_Mp. { is_iso. } etrans. { apply vassocl. } use vcomp_move_R_pM. { is_iso. } cbn. exact (psnaturality_natural η X Y f g α). Qed. Definition pstrans_id {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ (X : C), (η X ◃ psfunctor_id G X) • psnaturality_of η (id₁ X) = (runitor (η X)) • linvunitor (η X) • (psfunctor_id F X ▹ η X) := pr122(pr1 η). Definition pstrans_comp {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ {X Y Z : C} (f : X --> Y) (g : Y --> Z), (η X ◃ psfunctor_comp G f g) • psnaturality_of η (f · g) = (lassociator (η X) (#G f) (#G g)) • (psnaturality_of η f ▹ (#G g)) • rassociator (#F f) (η Y) (#G g) • (#F f ◃ psnaturality_of η g) • lassociator (#F f) (#F g) (η Z) • (psfunctor_comp F f g ▹ η Z) := pr222(pr1 η). Definition pstrans_id_alt {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ (X : C), cell_from_invertible_2cell (psnaturality_of η (id₁ X)) = (η X ◃ (psfunctor_id G X)^-1) • runitor (η X) • linvunitor (η X) • (psfunctor_id F X ▹ η X). Proof. intros X. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (pstrans_id η X). Qed. Proposition pstrans_id_inv {B₁ B₂ : bicat} {F G : psfunctor B₁ B₂} (τ : pstrans F G) (x : B₁) : (psnaturality_of τ (id₁ x))^-1 • (τ x ◃ (psfunctor_id G x)^-1) = ((psfunctor_id F x)^-1 ▹ τ x) • lunitor _ • rinvunitor _. Proof. use vcomp_move_L_pM ; [ is_iso | ]. use vcomp_move_R_Mp ; [ is_iso | ]. use vcomp_move_L_pM; [ is_iso | ]. cbn -[psfunctor_id]. rewrite !vassocr. exact (!(pstrans_id τ x)). Qed. Proposition pstrans_id_inv_alt {B₁ B₂ : bicat} {F G : psfunctor B₁ B₂} (τ : pstrans F G) (x : B₁) : (psfunctor_id F x ▹ τ x) • (psnaturality_of τ (id₁ x))^-1 = lunitor _ • rinvunitor _ • (τ x ◃ psfunctor_id G x). Proof. use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ]. rewrite !vassocr. use vcomp_move_L_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]. cbn -[psfunctor_id]. apply pstrans_id_inv. Qed. Definition pstrans_comp_alt {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ {X Y Z : C} (f : X --> Y) (g : Y --> Z), cell_from_invertible_2cell (psnaturality_of η (f · g)) = (η X ◃ (psfunctor_comp G f g)^-1) • lassociator (η X) (#G f) (#G g) • (psnaturality_of η f ▹ (#G g)) • rassociator (#F f) (η Y) (#G g) • (#F f ◃ psnaturality_of η g) • lassociator (#F f) (#F g) (η Z) • (psfunctor_comp F f g ▹ η Z). Proof. intros X Y Z f g. rewrite !vassocl. use vcomp_move_L_pM. { is_iso. } cbn. rewrite !vassocr. exact (pstrans_comp η f g). Qed. Definition pstrans_inv_comp_alt {C D : bicat} {F G : psfunctor C D} (η : pstrans F G) : ∏ {X Y Z : C} (f : X --> Y) (g : Y --> Z), (psnaturality_of η (f · g))^-1 = ((psfunctor_comp F f g)^-1 ▹ η Z) • rassociator (#F f) (#F g) (η Z) • (#F f ◃ ((psnaturality_of η g)^-1)) • lassociator (#F f) (η Y) (#G g) • ((psnaturality_of η f)^-1 ▹ (#G g)) • (rassociator (η X) (#G f) (#G g)) • (η X ◃ (psfunctor_comp G f g)). Proof. intros X Y Z f g. use vcomp_move_L_pM. { is_iso. } use vcomp_move_R_Mp. { is_iso. } use vcomp_move_L_pM. { is_iso. apply (psfunctor_comp G). } simpl. rewrite pstrans_comp_alt. rewrite !vassocl. reflexivity. Qed. Definition id_pstrans {C D : bicat} (F : psfunctor C D) : pstrans F F := id₁ F. Definition comp_pstrans {C D : bicat} {F₁ F₂ F₃ : psfunctor C D} (σ₁ : pstrans F₁ F₂) (σ₂ : pstrans F₂ F₃) : pstrans F₁ F₃ := σ₁ · σ₂. (** Pseudo adjoint equivalence is pointwise adjoint equivalence *) Definition pointwise_adjequiv {B₁ B₂ : bicat} {F₁ F₂ : psfunctor B₁ B₂} (σ : pstrans F₁ F₂) (Hf : left_adjoint_equivalence σ) : ∏ (X : B₁), left_adjoint_equivalence (σ X). Proof. intro X. pose (pr1 (left_adjoint_equivalence_total_disp_weq _ _ Hf)) as t₁. pose (pr1 (left_adjoint_equivalence_total_disp_weq _ _ t₁)) as t₂. pose (pr1 (left_adjoint_equivalence_total_disp_weq _ _ t₂)) as t₃. exact (is_adjequiv_to_all_is_adjequiv _ _ _ t₃ X). Defined. Definition pstrans_to_pstrans_data {B₁ B₂ : bicat} {F₁ F₂ : psfunctor B₁ B₂} (α : pstrans F₁ F₂) : pstrans_data F₁ F₂ := pr11 α. Definition pstrans_to_is_pstrans {B₁ B₂ : bicat} {F₁ F₂ : psfunctor B₁ B₂} (α : pstrans F₁ F₂) : is_pstrans (pstrans_to_pstrans_data α) := pr21 α. (** A pointwise adjoint equivalence is an adjoint equivalence *) Section PointwiseAdjequivIsAdjequiv. Context {B₁ B₂ : bicat} (HB₂ : is_univalent_2 B₂) {F₁ F₂ : psfunctor B₁ B₂} (σ : pstrans F₁ F₂) (Hf : ∏ (x : B₁), left_adjoint_equivalence (σ x)). Definition pointwise_adjequiv_to_adjequiv_base : left_adjoint_equivalence (pr111 σ). Proof. apply all_is_adjequiv_to_is_adjequiv. exact Hf. Defined. Definition pointwise_adjequiv_to_adjequiv_1cell : left_adjoint_equivalence (pr11 σ). Proof. use (invmap (left_adjoint_equivalence_total_disp_weq _ _)). simple refine (_ ,, _). - exact pointwise_adjequiv_to_adjequiv_base. - apply map1cells_disp_left_adjoint_equivalence. exact HB₂. Qed. Definition pointwise_adjequiv_to_adjequiv_data : left_adjoint_equivalence (pr1 σ). Proof. use (invmap (left_adjoint_equivalence_total_disp_weq _ _)). simple refine (_ ,, _). - exact pointwise_adjequiv_to_adjequiv_1cell. - use (pair_left_adjoint_equivalence (map2cells_disp_cat B₁ B₂) (disp_dirprod_bicat (identitor_disp_cat B₁ B₂) (compositor_disp_cat B₁ B₂)) (_ ,, pointwise_adjequiv_to_adjequiv_1cell)). simple refine (_ ,, _). + apply map2cells_disp_left_adjequiv. exact HB₂. + use (pair_left_adjoint_equivalence (identitor_disp_cat B₁ B₂) (compositor_disp_cat B₁ B₂)). simple refine (_ ,, _). * apply identitor_disp_left_adjequiv. exact HB₂. * apply compositor_disp_left_adjequiv. exact HB₂. Defined. Definition pointwise_adjequiv_to_adjequiv : left_adjoint_equivalence σ. Proof. use (invmap (left_adjoint_equivalence_total_disp_weq _ _)). simple refine (_ ,, _). - exact pointwise_adjequiv_to_adjequiv_data. - apply disp_left_adjoint_equivalence_fullsubbicat. Qed. End PointwiseAdjequivIsAdjequiv. (** Pseudotansformations between psfunctor data *) Definition pstrans_data_on_data {C D : bicat} (F G : psfunctor_data C D) : UU. Proof. refine (map1cells C D⟦_,_⟧). - apply F. - apply G. Defined. Definition make_pstrans_data_on_data {C D : bicat} {F G : psfunctor_data C D} (η₁ : ∏ (X : C), F X --> G X) (η₂ : ∏ (X Y : C) (f : X --> Y), invertible_2cell (η₁ X · #G f) (#F f · η₁ Y)) : pstrans_data_on_data F G := (η₁ ,, η₂). Definition psfunctor_data_on_cells {C D : bicat} (F : psfunctor_data C D) {a b : C} {f g : a --> b} (x : f ==> g) : #F f ==> #F g := pr12 F a b f g x. Section LocalNotation. Local Notation "'##'" := (PseudoFunctorBicat.psfunctor_on_cells). Definition is_pstrans_on_data {C D : bicat} {F G : psfunctor_data C D} (η : pstrans_data_on_data F G) : UU := (∏ (X Y : C) (f g : X --> Y) (α : f ==> g), (pr1 η X ◃ ##G α) • pr2 η _ _ g = (pr2 η _ _ f) • (##F α ▹ pr1 η Y)) × (∏ (X : C), (pr1 η X ◃ PseudoFunctorBicat.psfunctor_id G X) • pr2 η _ _ (id₁ X) = (runitor (pr1 η X)) • linvunitor (pr1 η X) • (PseudoFunctorBicat.psfunctor_id F X ▹ pr1 η X)) × (∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z), (pr1 η X ◃ PseudoFunctorBicat.psfunctor_comp G f g) • pr2 η _ _ (f · g) = (lassociator (pr1 η X) (#G f) (#G g)) • (pr2 η _ _ f ▹ (#G g)) • rassociator (#F f) (pr1 η Y) (#G g) • (#F f ◃ pr2 η _ _ g) • lassociator (#F f) (#F g) (pr1 η Z) • (PseudoFunctorBicat.psfunctor_comp F f g ▹ pr1 η Z)). Definition pstrans_on_data {C D : bicat} (F G : psfunctor_data C D) : UU := ∑ (η : pstrans_data_on_data F G), is_pstrans_on_data η. Definition pstrans_on_data_to_pstrans {C D : bicat} {F G : psfunctor C D} (η : pstrans_on_data (pr1 F) (pr1 G)) : pstrans F G := η ,, tt. End LocalNotation. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/000077500000000000000000000000001451125700300223025ustar00rootroot00000000000000UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/CHANGES.txt000066400000000000000000000016741451125700300241230ustar00rootroot00000000000000Simplify definition of left and right unitors (natural transformation). Shorten names: - prebicategory_ob_1mor_2mor -> prebicategory_ob_hom - identity_1mor -> identity1 - identity_2mor -> identity2 - composition_1mor -> composition1 - compose_2mor_horizontal -> compose2h - compose_2mor_iso_horizontal -> compose2h_iso Remove superfluous definition identity_2mor (just use identity) Remove unused code idto1mor Add explict type annotations in statemes. Notations - new scope "bicategories" (thus remove Local Notations); - open cat scope (and use it extensively); - make notations '-2->' and ':v;' specific for bicategories (otherwise they would overlap with the already available notations for categories); - remove notation '-2->' (duplicate of '-->'); - fix spaces in notations; Formatting - extensive use of (unicode) notations; - indentation, trim spaces; - superfluous parenthesis; - etc, etc. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/Cat.v000066400000000000000000000272511451125700300232070ustar00rootroot00000000000000(** ********************************************************** Mitchell Riley June 2016 I am very grateful to Peter LeFanu Lumsdaine, whose unreleased bicategories code strongly influenced the proofs in this file. ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.categories.StandardCategories. (* unit *) Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. (******************************************************************************) (* Lemmas for use in PreCat and Cat *) Definition Catlike_associator ( a b c d : category ) : nat_trans (functor_composite (pair_functor (functor_identity (functor_category a b)) (functorial_composition b c d )) (functorial_composition a b d )) (functor_composite (precategory_binproduct_assoc (functor_category a b ) (functor_category b c) (functor_category c d )) (functor_composite (pair_functor (functorial_composition a b c ) (functor_identity (functor_category c d))) (functorial_composition a c d ))). Proof. use tpair. - (* Step 1: Give the components of the natural transformation *) (* I.e., for every triple of functors F : a -> b G : b -> c H : c -> d, a natural transformation F (G H) -> (F G) H *) intros x. simpl. (* The component at x is just the identity, because composition of functions is associative for free. *) exists (λ x, identity _). (* Which is natural. *) intros oba oba' f. use (id_right _ @ !(id_left _)). - (* Step 2: Show the above is natural, so given f : F -> F', g : G -> G', h : H -> H', *) intros [F [G H]]. intros [F' [G' H']]. intros [f [g h]]. (* Verify that (f, (g, h)) ∘ (assoc F' G' H') = (assoc F G H) ∘ ((f, g), h)) as natural transformations. *) (* To show two natural transformations are equal, suffices to check components *) apply (nat_trans_eq_alt). intros oba. simpl. do 2 (unfold horcomp_data; simpl). (* Now assoc is just identity *) rewrite id_right. rewrite id_left. (* And the order we do f, g, h doesn't matter *) rewrite (functor_comp H). rewrite assoc. apply idpath. Defined. Definition Catlike_associator_is_iso ( a b c d : category ) : ∏ f g h, is_iso (Catlike_associator a b c d (make_catbinprod f (make_catbinprod g h))). Proof. intros f g h. (* The components are all the identity, so this is easy *) apply functor_iso_if_pointwise_iso. intros oba. apply (identity_is_iso d). Defined. Definition Catlike_left_unitor (a b : category) : nat_trans (functor_composite (bindelta_pair_functor (functor_composite (functor_to_unit (functor_category a b)) (constant_functor unit_category (functor_category a a) (functor_identity a))) (functor_identity (functor_category a b))) (functorial_composition a a b)) (functor_identity (functor_category a b)). Proof. use tpair. - (* Step 1: Give components. Again identity works, as function composition is unital for free *) intros x. exists (λ x, identity _). intros oba oba' f. exact (id_right _ @ !(id_left _)). - (* Step 2: Show the above is natural, so given f : F -> F' *) intros F F' f. (* Verify that (f, id) ∘ (left_unitor F') = (left_unitor F) ∘ f as natural transformations. *) (* Again just check components *) apply (nat_trans_eq_alt). intros oba. simpl. unfold horcomp_data; simpl. rewrite id_right. rewrite id_left. rewrite (functor_id F). apply id_left. Defined. Definition Catlike_left_unitor_is_iso (a b : category) : ∏ f, is_iso (Catlike_left_unitor a b f). Proof. intros f. apply functor_iso_if_pointwise_iso. intros oba. apply (identity_is_iso b). Defined. Definition Catlike_right_unitor (a b : category) : nat_trans (functor_composite (bindelta_pair_functor (functor_identity (functor_category a b)) (functor_composite (functor_to_unit (functor_category a b)) (constant_functor unit_category (functor_category b b) (functor_identity b)))) (functorial_composition a b b)) (functor_identity (functor_category a b)). Proof. use tpair. (* Same as above *) - intros x. exists (λ x, identity _). intros oba oba' f. exact (id_right _ @ !(id_left _)). - intros F F' f. apply (nat_trans_eq_alt). intros oba. simpl. unfold horcomp_data; simpl. rewrite (id_right _). rewrite (id_left _). apply id_right. Defined. Definition Catlike_right_unitor_is_iso (a b : category) : ∏ f, is_iso (Catlike_right_unitor a b f). Proof. intros f. apply functor_iso_if_pointwise_iso. intros oba. apply (identity_is_iso b). Defined. (* What a mess! *) Definition Catlike_pentagon ( a b c d e : category ) (hsB : has_homsets b) (hsC : has_homsets c) (hsD : has_homsets d) (hsE : has_homsets e) : ∏ k h g f, (Catlike_associator a b c e ) (make_catbinprod k (make_catbinprod h ((functorial_composition c d e ) (make_dirprod g f)))) · (Catlike_associator a c d e ) (make_catbinprod ((functorial_composition_legacy a b c) (make_dirprod k h)) (make_catbinprod g f)) = (functor_on_morphisms (functorial_composition_legacy a b e) (catbinprodmor (identity k) ((Catlike_associator b c d e) (make_catbinprod h (make_catbinprod g f)))) · (Catlike_associator a b d e ) (make_catbinprod k (make_catbinprod ((functorial_composition_legacy b c d ) (make_dirprod h g)) f))) · functor_on_morphisms (functorial_composition_legacy a d e ) (catbinprodmor ((Catlike_associator a b c d ) (make_catbinprod k (make_catbinprod h g))) (identity f)). Proof. intros k h g f. apply (nat_trans_eq hsE). intros oba. simpl. unfold horcomp_data; simpl. (* Everything boils down to the identity *) repeat rewrite functor_id. repeat rewrite (id_left _). apply idpath. Defined. Definition Catlike_triangle ( a b c : category ) : ∏ f g, functor_on_morphisms (functorial_composition_legacy a b c) (catbinprodmor (identity f) (Catlike_left_unitor b c g)) = (Catlike_associator a b b c (make_catbinprod f (make_catbinprod (functor_identity b : [ _, _] ) g))) · functor_on_morphisms (functorial_composition_legacy a b c) (catbinprodmor (Catlike_right_unitor a b f) (identity g)). Proof. intros f g. apply (nat_trans_eq c). intros oba. simpl. unfold horcomp_data; simpl. repeat rewrite functor_id. repeat rewrite (id_left _). apply idpath. Defined. (******************************************************************************) (* The prebicategory of precategories *) Definition PreCat_1mor_2mor : prebicategory_ob_hom. Proof. exists category. intros a b. exact (functor_category a b). Defined. Definition PreCat_id_comp : prebicategory_id_comp. Proof. exists PreCat_1mor_2mor. split. - simpl. exact functor_identity. - simpl. intros a b c. exact (functorial_composition_legacy a b c). Defined. (* Definition PreCat_data : prebicategory_data. Proof. unfold prebicategory_data. exists PreCat_id_comp. repeat split. - intros. simpl in a,b,c,d. exact (Catlike_associator a b c d ). - intros. simpl in a, b. exact (Catlike_left_unitor a b (homset_property a) (homset_property b)). - intros. simpl in a, b. exact (Catlike_right_unitor a b (homset_property b)). Defined. Definition PreCat_has_2mor_set : has_2mor_sets PreCat_data. Proof. unfold has_2mor_sets. intros a b f g. apply isaset_nat_trans. exact (homset_property b). Defined. Definition PreCat_associator_and_unitors_are_iso : associator_and_unitors_are_iso PreCat_data. Proof. repeat split. - intros a b c d. apply Catlike_associator_is_iso. - intros a b. apply Catlike_left_unitor_is_iso. - intros a b. apply Catlike_right_unitor_is_iso. Defined. Definition PreCat_coherence : prebicategory_coherence PreCat_data. Proof. unfold prebicategory_coherence. split. - intros a b c d e. apply Catlike_pentagon. - intros a b c. apply Catlike_triangle. Defined. Definition PreCat : prebicategory. Proof. use tpair. exact PreCat_data. split. exact PreCat_has_2mor_set. split. exact PreCat_associator_and_unitors_are_iso. exact PreCat_coherence. Defined. (******************************************************************************) (* The bicategory of categories *) Definition Cat_1mor_2mor : prebicategory_ob_hom. Proof. exists univalent_category. intros a b. exact (functor_precategory a b (univalent_category_has_homsets b)). Defined. Definition Cat_id_comp : prebicategory_id_comp. Proof. exists Cat_1mor_2mor. split. - simpl. exact functor_identity. - simpl. intros a b c. exact (functorial_composition_legacy a b c (univalent_category_has_homsets b) (univalent_category_has_homsets c)). Defined. Definition Cat_data : prebicategory_data. Proof. unfold prebicategory_data. exists Cat_id_comp. repeat split. - intros. simpl in a,b,c,d. exact (Catlike_associator a b c d (univalent_category_has_homsets b) (univalent_category_has_homsets c) (univalent_category_has_homsets d)). - intros. simpl in a, b. exact (Catlike_left_unitor a b (univalent_category_has_homsets a) (univalent_category_has_homsets b)). - intros. simpl in a, b. exact (Catlike_right_unitor a b (univalent_category_has_homsets b)). Defined. Definition Cat_has_2mor_set : has_2mor_sets Cat_data. Proof. unfold has_2mor_sets. intros a b f g. apply isaset_nat_trans. exact (univalent_category_has_homsets b). Defined. Definition Cat_associator_and_unitors_are_iso : associator_and_unitors_are_iso Cat_data. Proof. repeat split. - intros a b c d. apply Catlike_associator_is_iso. - intros a b. apply Catlike_left_unitor_is_iso. - intros a b. apply Catlike_right_unitor_is_iso. Defined. Definition Cat_coherence : prebicategory_coherence Cat_data. Proof. split. - intros a b c d e. apply Catlike_pentagon. - intros a b c. apply Catlike_triangle. Defined. Definition Cat_prebicategory : prebicategory. Proof. use tpair. exact Cat_data. unfold is_prebicategory. split. exact Cat_has_2mor_set. split. exact Cat_associator_and_unitors_are_iso. exact Cat_coherence. Defined. Definition Cat_has_homcats : has_homcats Cat_prebicategory. Proof. unfold has_homcats. intros a b. apply is_univalent_functor_category. apply b. Defined. (* TODO: "Should be easy" *) (* Definition Cat_is_lt2saturated (a b : Cat_prebicategory) *) (* : isweq (id_to_internal_equivalence a b). *) (* Proof. *) (* Definition Cat : bicategory. *) (* Proof. *) (* exists Cat_prebicategory. *) (* split. *) (* - exact Cat_has_homcats. *) (* - exact Cat_is_lt2saturated. *) (* Defined. *) *) UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/Notations.v000066400000000000000000000020271451125700300244500ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Export UniMath.Bicategories.WkCatEnrichment.prebicategory. (* Local Notation "C 'c×' D" := (precategory_binproduct C D) (at level 75, right associativity). *) Notation "a '-1->' b" := (homcat a b) (at level 50, left associativity). Notation "f '-2->' g" := (@precategory_morphisms (_ -1->_) f g) (at level 50, left associativity). Notation "alpha ';v;' beta" := (@compose (_ -1-> _) _ _ _ alpha beta) (at level 50, left associativity). Notation "f ';1;' g" := (compose1 f g) (at level 50, left associativity). Notation "alpha ';h;' beta" := (compose2h alpha beta) (at level 50, left associativity). Notation "alpha ';hi;' beta" := (compose2h_iso alpha beta) (at level 50, left associativity). UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/bicategory.v000066400000000000000000000022551451125700300246250ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.WkCatEnrichment.internal_equivalence. Require Import UniMath.Bicategories.WkCatEnrichment.Notations. (******************************************************************************) (* Definition of bicategory *) Definition is_bicategory (C : prebicategory) : UU := (has_homcats C) × (∏ (a b : C), isweq (path_to_adj_int_equivalence a b)). Definition bicategory : UU := ∑ C : prebicategory, is_bicategory C. (******************************************************************************) (* Being a bicategory is a prop *) Definition isaprop_has_homcats { C : prebicategory } : isaprop (has_homcats C). Proof. apply impred. intro a. apply impred. intro b. apply isaprop_is_univalent. Qed. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/hcomp_bicat.v000066400000000000000000000557561451125700300247630ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations. Require Import UniMath.Bicategories.Core.BicategoryLaws. Local Open Scope cat. Definition hcomp_bicat_data : UU := ∑ (ob : UU) (mor : ob → ob → UU) (cell : ∏ (x y : ob), mor x y → mor x y → UU) (id1 : ∏ (x : ob), mor x x) (comp1 : ∏ (x y z : ob), mor x y → mor y z → mor x z), (∏ (x y : ob) (f : mor x y), cell _ _ f f) × (∏ (x y : ob) (f g h : mor x y), cell _ _ f g → cell _ _ g h → cell _ _ f h) × (∏ (x y : ob) (f : mor x y), cell _ _ (comp1 _ _ _ f (id1 y)) f) × (∏ (x y : ob) (f : mor x y), cell _ _ f (comp1 _ _ _ f (id1 y))) × (∏ (x y : ob) (f : mor x y), cell _ _ (comp1 _ _ _ (id1 x) f) f) × (∏ (x y : ob) (f : mor x y), cell _ _ f (comp1 _ _ _ (id1 x) f)) × (∏ (w x y z : ob) (f : mor w x) (g : mor x y) (h : mor y z), cell _ _ (comp1 _ _ _ (comp1 _ _ _ f g) h) (comp1 _ _ _ f (comp1 _ _ _ g h))) × (∏ (w x y z : ob) (f : mor w x) (g : mor x y) (h : mor y z), cell _ _ (comp1 _ _ _ f (comp1 _ _ _ g h)) (comp1 _ _ _ (comp1 _ _ _ f g) h)) × (∏ (x y z : ob) (f₁ f₂ : mor x y) (g₁ g₂ : mor y z), cell _ _ f₁ f₂ → cell _ _ g₁ g₂ → cell _ _ (comp1 _ _ _ f₁ g₁) (comp1 _ _ _ f₂ g₂)). Coercion hcomp_bicat_ob (B : hcomp_bicat_data) : UU := pr1 B. Definition hb_mor {B : hcomp_bicat_data} (b₁ b₂ : B) : UU := pr12 B b₁ b₂. Definition hb_cell {B : hcomp_bicat_data} {b₁ b₂ : B} (f g : hb_mor b₁ b₂) : UU := pr122 B _ _ f g. Definition hb_id1 {B : hcomp_bicat_data} (b : B) : hb_mor b b := pr1 (pr222 B) b . Definition hb_comp1 {B : hcomp_bicat_data} {b₁ b₂ b₃ : B} (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃) : hb_mor b₁ b₃ := pr12 (pr222 B) _ _ _ f g. Definition hb_id2 {B : hcomp_bicat_data} {b₁ b₂ : B} (f : hb_mor b₁ b₂) : hb_cell f f := pr122 (pr222 B) _ _ f. Definition hb_vcomp {B : hcomp_bicat_data} {b₁ b₂ : B} {f g h : hb_mor b₁ b₂} (α : hb_cell f g) (β : hb_cell g h) : hb_cell f h := pr1 (pr222 (pr222 B)) _ _ _ _ _ α β. Definition hb_runit {B : hcomp_bicat_data} {b₁ b₂ : B} (f : hb_mor b₁ b₂) : hb_cell (hb_comp1 f (hb_id1 b₂)) f := pr12 (pr222 (pr222 B)) _ _ f. Definition hb_rinvunit {B : hcomp_bicat_data} {b₁ b₂ : B} (f : hb_mor b₁ b₂) : hb_cell f (hb_comp1 f (hb_id1 b₂)) := pr122 (pr222 (pr222 B)) _ _ f. Definition hb_lunit {B : hcomp_bicat_data} {b₁ b₂ : B} (f : hb_mor b₁ b₂) : hb_cell (hb_comp1 (hb_id1 b₁) f) f := pr1 (pr222 (pr222 (pr222 B))) _ _ f. Definition hb_linvunit {B : hcomp_bicat_data} {b₁ b₂ : B} (f : hb_mor b₁ b₂) : hb_cell f (hb_comp1 (hb_id1 b₁) f) := pr12 (pr222 (pr222 (pr222 B))) _ _ f. Definition hb_lassoc {B : hcomp_bicat_data} {b₁ b₂ b₃ b₄ : B} (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃) (h : hb_mor b₃ b₄) : hb_cell (hb_comp1 (hb_comp1 f g) h) (hb_comp1 f (hb_comp1 g h)) := pr122 (pr222 (pr222 (pr222 B))) _ _ _ _ f g h. Definition hb_rassoc {B : hcomp_bicat_data} {b₁ b₂ b₃ b₄ : B} (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃) (h : hb_mor b₃ b₄) : hb_cell (hb_comp1 f (hb_comp1 g h)) (hb_comp1 (hb_comp1 f g) h) := pr1 (pr222 (pr222 (pr222 (pr222 B)))) _ _ _ _ f g h. Definition hb_hcomp {B : hcomp_bicat_data} {b₁ b₂ b₃ : B} {f₁ f₂ : hb_mor b₁ b₂} {g₁ g₂ : hb_mor b₂ b₃} (α : hb_cell f₁ f₂) (β : hb_cell g₁ g₂) : hb_cell (hb_comp1 f₁ g₁) (hb_comp1 f₂ g₂) := pr2 (pr222 (pr222 (pr222 (pr222 B)))) _ _ _ _ _ _ _ α β. Definition hcomp_bicat_laws (B : hcomp_bicat_data) : UU := (∏ (b₁ b₂ : B) (f g : hb_mor b₁ b₂) (α : hb_cell f g), hb_vcomp (hb_id2 _) α = α) × (∏ (b₁ b₂ : B) (f g : hb_mor b₁ b₂) (α : hb_cell f g), hb_vcomp α (hb_id2 _) = α) × (∏ (b₁ b₂ : B) (f₁ f₂ f₃ f₄ : hb_mor b₁ b₂) (α : hb_cell f₁ f₂) (β : hb_cell f₂ f₃) (γ : hb_cell f₃ f₄), hb_vcomp α (hb_vcomp β γ) = hb_vcomp (hb_vcomp α β) γ) × (∏ (b₁ b₂ : B) (f₁ f₂ f₃ f₄ : hb_mor b₁ b₂) (α : hb_cell f₁ f₂) (β : hb_cell f₂ f₃) (γ : hb_cell f₃ f₄), hb_vcomp (hb_vcomp α β) γ = hb_vcomp α (hb_vcomp β γ)) × (∏ (b₁ b₂ : B) (f g : hb_mor b₁ b₂), isaset (hb_cell f g)) × (∏ (b₁ b₂ b₃ : B) (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃), hb_hcomp (hb_id2 f) (hb_id2 g) = hb_id2 (hb_comp1 f g)) × (∏ (b₁ b₂ b₃ : B) (f₁ g₁ h₁ : hb_mor b₁ b₂) (f₂ g₂ h₂ : hb_mor b₂ b₃) (α₁ : hb_cell f₁ g₁) (α₂ : hb_cell f₂ g₂) (β₁ : hb_cell g₁ h₁) (β₂ : hb_cell g₂ h₂), hb_hcomp (hb_vcomp α₁ β₁) (hb_vcomp α₂ β₂) = hb_vcomp (hb_hcomp α₁ α₂) (hb_hcomp β₁ β₂)) × (∏ (a b c d : B) (f₁ f₂ : hb_mor a b) (g₁ g₂ : hb_mor b c) (h₁ h₂ : hb_mor c d) (α₁ : hb_cell f₁ f₂) (α₂ : hb_cell g₁ g₂) (α₃ : hb_cell h₁ h₂), hb_vcomp (hb_hcomp α₁ (hb_hcomp α₂ α₃)) (hb_rassoc _ _ _) = hb_vcomp (hb_rassoc _ _ _) (hb_hcomp (hb_hcomp α₁ α₂) α₃)) × (∏ (a b : B) (f₁ f₂ : hb_mor a b) (α : hb_cell f₁ f₂), hb_vcomp (hb_hcomp (hb_id2 (hb_id1 a)) α) (hb_lunit f₂) = hb_vcomp (hb_lunit f₁) α) × (∏ (a b : B) (f₁ f₂ : hb_mor a b) (α : hb_cell f₁ f₂), hb_vcomp (hb_hcomp α (hb_id2 (hb_id1 b))) (hb_runit f₂) = hb_vcomp (hb_runit f₁) α) × (∏ (b₁ b₂ b₃ b₄ : B) (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃) (h : hb_mor b₃ b₄), hb_vcomp (hb_rassoc f g h) (hb_lassoc f g h) = hb_id2 _) × (∏ (b₁ b₂ b₃ b₄ : B) (f : hb_mor b₁ b₂) (g : hb_mor b₂ b₃) (h : hb_mor b₃ b₄), hb_vcomp (hb_lassoc f g h) (hb_rassoc f g h) = hb_id2 _) × (∏ (b₁ b₂ : B) (f : hb_mor b₁ b₂), hb_vcomp (hb_lunit f) (hb_linvunit f) = hb_id2 _) × (∏ (b₁ b₂ : B) (f : hb_mor b₁ b₂), hb_vcomp (hb_linvunit f) (hb_lunit f) = hb_id2 _) × (∏ (b₁ b₂ : B) (f : hb_mor b₁ b₂), hb_vcomp (hb_runit f) (hb_rinvunit f) = hb_id2 _) × (∏ (b₁ b₂ : B) (f : hb_mor b₁ b₂), hb_vcomp (hb_rinvunit f) (hb_runit f) = hb_id2 _) × (∏ (a b c d e : B) (k : hb_mor a b) (h : hb_mor b c) (g : hb_mor c d) (f : hb_mor d e), hb_vcomp (hb_rassoc k h (hb_comp1 g f)) (hb_rassoc (hb_comp1 k h) g f) = hb_vcomp (hb_vcomp (hb_hcomp (hb_id2 k) (hb_rassoc h g f)) (hb_rassoc k (hb_comp1 h g) f)) (hb_hcomp (hb_rassoc k h g) (hb_id2 f))) × (∏ (a b c : B) (f : hb_mor a b) (g : hb_mor b c), hb_hcomp (hb_id2 f) (hb_lunit g) = hb_vcomp (hb_rassoc f (hb_id1 b) g) (hb_hcomp (hb_runit f) (hb_id2 g))). Lemma isaprop_hcomp_prebicat_laws (B : hcomp_bicat_data) (H : ∏ (a b : B) (f g : hb_mor a b), isaset (hb_cell f g)) : isaprop (hcomp_bicat_laws B). Proof. repeat (apply isapropdirprod) ; try (repeat (apply impred ; intro) ; apply H). do 4 (apply impred ; intro). apply isapropisaset. Qed. Definition hcomp_bicat : UU := ∑ (B : hcomp_bicat_data), hcomp_bicat_laws B. Coercion hcomp_bicat_to_data (B : hcomp_bicat) : hcomp_bicat_data := pr1 B. Definition hcomp_bicat_hom_cat (B : hcomp_bicat) (b₁ b₂ : B) : category. Proof. use make_category. - use make_precategory. + use make_precategory_data. * use make_precategory_ob_mor. ** exact (hb_mor b₁ b₂). ** exact (λ f g, hb_cell f g). * exact (λ f, hb_id2 f). * exact (λ _ _ _ f g, hb_vcomp f g). + repeat split ; simpl ; cbn. * exact (pr12 B b₁ b₂). * exact (pr122 B b₁ b₂). * exact (pr1 (pr222 B) b₁ b₂). * exact (pr12 (pr222 B) b₁ b₂). - exact (pr122 (pr222 B) b₁ b₂). Defined. Definition hcomp_bicat_hcomp (B : hcomp_bicat) (b₁ b₂ b₃ : pr11 B) : precategory_binproduct_data (hcomp_bicat_hom_cat B b₁ b₂) (hcomp_bicat_hom_cat B b₂ b₃) ⟶ hcomp_bicat_hom_cat B b₁ b₃. Proof. use make_functor. - use make_functor_data. + exact (λ fg, hb_comp1 (pr1 fg) (pr2 fg)). + exact (λ fg fg' α, hb_hcomp (pr1 α) (pr2 α)). - split. + intros f ; cbn in *. exact (pr1 (pr222 (pr222 B)) b₁ b₂ b₃ (pr1 f) (pr2 f)). + intros f g h α β ; cbn in *. exact (pr12 (pr222 (pr222 B)) b₁ b₂ b₃ _ _ _ _ _ _ (pr1 α) (pr2 α) (pr1 β) (pr2 β)). Defined. Definition hcomp_bicat_to_prebicategory_ob_hom (B : hcomp_bicat) : prebicategory_ob_hom. Proof. simple refine (_ ,, _). - exact B. - exact (hcomp_bicat_hom_cat B). Defined. Definition hcomp_bicat_to_prebicategory_id_comp (B : hcomp_bicat) : prebicategory_id_comp. Proof. simple refine (_ ,, _ ,, _). - exact (hcomp_bicat_to_prebicategory_ob_hom B). - exact (λ a, hb_id1 a). - exact (hcomp_bicat_hcomp B). Defined. Definition hcomp_bicat_associator (B : hcomp_bicat) (a b c d : hcomp_bicat_to_prebicategory_id_comp B) : associator_trans_type a b c d. Proof. use make_nat_trans. - exact (λ f, hb_rassoc (pr1 f) (pr12 f) (pr22 f)). - intros f₁ f₂ α. apply (pr122 (pr222 (pr222 B))). Defined. Definition hcomp_bicat_lunitor (B : hcomp_bicat) (a b : hcomp_bicat_to_prebicategory_id_comp B) : left_unitor_trans_type a b. Proof. use make_nat_trans. - exact (λ f, hb_lunit f). - intros f₁ f₂ α. apply (pr1 (pr222 (pr222 (pr222 B)))). Defined. Definition hcomp_bicat_runitor (B : hcomp_bicat) (a b : hcomp_bicat_to_prebicategory_id_comp B) : right_unitor_trans_type a b. Proof. use make_nat_trans. - exact (λ f, hb_runit f). - intros f₁ f₂ α. apply (pr2 (pr222 (pr222 (pr222 B)))). Defined. Definition hcomp_bicat_to_prebicategory_data (B : hcomp_bicat) : prebicategory_data. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (hcomp_bicat_to_prebicategory_id_comp B). - exact (hcomp_bicat_associator B). - exact (hcomp_bicat_lunitor B). - exact (hcomp_bicat_runitor B). Defined. Definition hcomp_bicat_is_prebicategory (B : hcomp_bicat) : is_prebicategory (hcomp_bicat_to_prebicategory_data B). Proof. repeat split. - intros b₁ b₂ b₃ b₄ f g h ; cbn in *. use make_is_z_isomorphism. + exact (hb_lassoc f g h). + split ; apply (pr2 B). - intros b₁ b₂ f ; cbn in *. use make_is_z_isomorphism. + exact (hb_linvunit f). + split ; apply (pr2 B). - intros b₁ b₂ f ; cbn in *. use make_is_z_isomorphism. + exact (hb_rinvunit f). + split ; apply (pr2 B). - apply (pr2 B). - apply (pr2 B). Defined. Definition hcomp_bicat_to_prebicategory (B : hcomp_bicat) : prebicategory. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_prebicategory_data B). - exact (hcomp_bicat_is_prebicategory B). Defined. Definition prebicategory_to_hcomp_bicat_data (B : prebicategory) : hcomp_bicat_data. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _). - exact (pr1 (pr111 B)). - intros b₁ b₂. exact (pr2 (pr111 B) b₁ b₂). - intros b₁ b₂ f g. exact (f --> g). - exact (pr1 (pr211 B)). - intros b₁ b₂ b₃ f g. exact (pr2 (pr211 B) b₁ b₂ b₃ (f ,, g)). - intros ; simpl. apply identity. - exact (λ _ _ _ _ _ α β, α · β). - cbn in *. intros b₁ b₂ f. exact (pr1 (pr2 (pr221 B) b₁ b₂) f). - intros a b f. apply (pr2 (pr212 B) _ _ f). - cbn in *. intros b₁ b₂ f. exact (pr1 (pr1 (pr221 B) b₁ b₂) f). - intros a b f. apply (pr1 (pr212 B) _ _ f). - intros b₁ b₂ b₃ b₄ f g h ; cbn in *. apply ((pr112 B) _ _ _ _ f g h). - intros b₁ b₂ b₃ b₄ f g h ; cbn in *. exact (pr1 ((pr121 B) _ _ _ _) (f ,, g ,, h)). - intros b₁ b₂ b₃ f₁ f₂ g₁ g₂ α β ; simpl in *. apply (#(pr2 (pr211 B) b₁ b₂ b₃)). exact (α ,, β). Defined. Definition prebicategory_to_hcomp_bicat (B : prebicategory) : hcomp_bicat. Proof. simple refine (_ ,, _). - exact (prebicategory_to_hcomp_bicat_data B). - repeat split ; cbn ; intros. + apply id_left. + apply id_right. + apply assoc. + apply assoc'. + apply homset_property. + apply (functor_id ((pr221 (pr1 B)) b₁ b₂ b₃)). + apply (@functor_comp _ _ ((pr221 (pr1 B)) b₁ b₂ b₃) (_ ,, _) (_ ,, _) (_ ,, _) (_ ,, _) (_ ,, _)). + apply (@nat_trans_ax _ _ _ _ ((pr121 B) a b c d) (_ ,, (_ ,, _)) (_ ,, (_ ,, _)) (_ ,, (_ ,, _))). + apply (nat_trans_ax ((pr122 (pr1 B)) a b)). + apply (nat_trans_ax ((pr222 (pr1 B)) a b)). + apply (z_iso_inv_after_z_iso (make_z_iso _ _ ((pr112 B) b₁ b₂ b₃ b₄ f g h))). + apply (z_iso_after_z_iso_inv (make_z_iso _ _ ((pr112 B) b₁ b₂ b₃ b₄ f g h))). + apply (z_iso_inv_after_z_iso (make_z_iso _ _ ((pr121 (pr2 B)) b₁ b₂ f))). + apply (z_iso_after_z_iso_inv (make_z_iso _ _ ((pr121 (pr2 B)) b₁ b₂ f))). + apply (z_iso_inv_after_z_iso (make_z_iso _ _ ((pr221 (pr2 B)) b₁ b₂ f))). + apply (z_iso_after_z_iso_inv (make_z_iso _ _ ((pr221 (pr2 B)) b₁ b₂ f))). + apply B. + apply B. Defined. Definition hcomp_bicat_weq_prebicategory : hcomp_bicat ≃ prebicategory. Proof. use make_weq. - exact hcomp_bicat_to_prebicategory. - use isweq_iso. + exact prebicategory_to_hcomp_bicat. + intros b. apply idpath. + intros b. apply idpath. Defined. Definition hcomp_bicat_to_precategory_ob_mor (B : hcomp_bicat) : precategory_ob_mor. Proof. simple refine (_ ,, _). - exact B. - exact (λ b₁ b₂, hb_mor b₁ b₂). Defined. Definition hcomp_bicat_to_precategory_id_comp (B : hcomp_bicat) : precategory_id_comp (hcomp_bicat_to_precategory_ob_mor B). Proof. simple refine (_ ,, _). - exact (λ x, hb_id1 _). - exact (λ _ _ _ f g, hb_comp1 f g). Defined. Definition hcomp_bicat_to_precategory_data (B : hcomp_bicat) : precategory_data. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_precategory_ob_mor B). - exact (hcomp_bicat_to_precategory_id_comp B). Defined. Definition hcomp_bicat_to_prebicat_1_id_comp_cells (B : hcomp_bicat) : prebicat_1_id_comp_cells. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_precategory_data B). - exact (λ x y f g, hb_cell f g). Defined. Definition hcomp_bicat_to_prebicat_2_id_comp_struct (B : hcomp_bicat) : prebicat_2_id_comp_struct (hcomp_bicat_to_prebicat_1_id_comp_cells B). Proof. repeat split ; cbn. - intros. apply hb_id2. - intros. apply hb_lunit. - intros. apply hb_runit. - intros. apply hb_linvunit. - intros. apply hb_rinvunit. - intros. apply hb_lassoc. - intros. apply hb_rassoc. - intros ? ? ? ? ? α β. exact (hb_vcomp α β). - intros ? ? ? f ? ? α. exact (hb_hcomp (hb_id2 _) α). - intros ? ? ? f ? ? α. exact (hb_hcomp α (hb_id2 _)). Defined. Definition hcomp_bicat_to_prebicat_data (B : hcomp_bicat) : prebicat_data. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_prebicat_1_id_comp_cells B). - exact (hcomp_bicat_to_prebicat_2_id_comp_struct B). Defined. Definition hcomp_bicat_to_prebicat_laws (B : hcomp_bicat) : prebicat_laws (hcomp_bicat_to_prebicat_data B). Proof. repeat split ; try (intros ; apply (pr2 B)). - intros ; cbn. etrans. { refine (!_). apply (pr12 (pr222 (pr222 B))). } apply maponpaths_2. apply B. - intros ; cbn. etrans. { refine (!_). apply (pr12 (pr222 (pr222 B))). } apply maponpaths. apply B. - intros ; cbn. etrans. { apply (pr122 (pr222 ((pr222 B)))). } apply maponpaths. apply maponpaths_2. apply B. - intros a b c d f₁ f₂ g h α ; cbn. pose (pr122 (pr222 ((pr222 B))) a b c d f₁ f₂ g g h h α (hb_id2 _) (hb_id2 _)) as p. cbn in p. etrans. { exact (!p). } apply maponpaths_2. apply maponpaths. apply B. - intros a b c f₁ f₂ g h α β ; cbn. etrans. { refine (!_). apply (pr12 (pr222 (pr222 B))). } refine (!_). etrans. { refine (!_). apply (pr12 (pr222 (pr222 B))). } etrans. { apply maponpaths. apply B. } etrans. { apply maponpaths_2. apply B. } refine (!_). etrans. { apply maponpaths. apply B. } apply maponpaths_2. apply B. - intros ; cbn. refine (!_). apply B. - intros ; cbn. refine (!_). apply B. Qed. Definition hcomp_bicat_to_prebicat (B : hcomp_bicat) : prebicat. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_prebicat_data B). - exact (hcomp_bicat_to_prebicat_laws B). Defined. Definition hcomp_bicat_to_bicat (B : hcomp_bicat) : bicat. Proof. simple refine (_ ,, _). - exact (hcomp_bicat_to_prebicat B). - simpl. intro ; intros. apply (pr122 (pr222 B)). Defined. Definition bicat_to_hcomp_bicat_data (B : bicat) : hcomp_bicat_data. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _). - exact B. - exact (λ x y, x --> y). - exact (λ _ _ f g, f ==> g). - exact (λ x, id₁ _). - exact (λ _ _ _ f g, f · g). - exact (λ _ _ f, id2 f). - exact (λ _ _ _ _ _ α β, α • β). - exact (λ _ _ f, runitor f). - exact (λ _ _ f, rinvunitor f). - exact (λ _ _ f, lunitor f). - exact (λ _ _ f, linvunitor f). - exact (λ _ _ _ _ f g h, rassociator f g h). - exact (λ _ _ _ _ f g h, lassociator f g h). - exact (λ _ _ _ _ _ _ _ α β, β ⋆⋆ α). Defined. Definition bicat_to_hcomp_bicat_laws (B : bicat) : hcomp_bicat_laws (bicat_to_hcomp_bicat_data B). Proof. repeat split ; cbn ; intros. - apply id2_left. - apply id2_right. - apply vassocr. - apply vassocl. - apply cellset_property. - apply hcomp_identity. - apply interchange. - apply hcomp_lassoc. - apply lunitor_natural. - apply runitor_natural. - apply lassociator_rassociator. - apply rassociator_lassociator. - apply lunitor_linvunitor. - apply linvunitor_lunitor. - apply runitor_rinvunitor. - apply rinvunitor_runitor. - rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. refine (!_). apply lassociator_lassociator. - rewrite <- lwhisker_hcomp, <- rwhisker_hcomp. rewrite <- lunitor_lwhisker. rewrite !vassocr. rewrite lassociator_rassociator. rewrite id2_left. apply idpath. Qed. Definition bicat_to_hcomp_bicat (B : bicat) : hcomp_bicat. Proof. simple refine (_ ,, _). - exact (bicat_to_hcomp_bicat_data B). - exact (bicat_to_hcomp_bicat_laws B). Defined. Definition hcomp_bicat_to_bicat_to_hcomp_bicat (B : hcomp_bicat) : bicat_to_hcomp_bicat (hcomp_bicat_to_bicat B) = B. Proof. use total2_paths_f. - do 13 (use total2_paths_f ; [ apply idpath | ] ; cbn). use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. use funextsec ; intro f₁. use funextsec ; intro f₂. use funextsec ; intro g₁. use funextsec ; intro g₂. use funextsec ; intro α. use funextsec ; intro β. cbn. etrans. { refine (!_). apply (pr12 (pr222 (pr222 B))). } etrans. { apply maponpaths. apply (pr12 B). } etrans. { apply maponpaths_2. apply (pr122 B). } apply idpath. - apply isaprop_hcomp_prebicat_laws. apply B. Qed. Definition bicat_to_hcomp_bicat_to_bicat (B : bicat) : hcomp_bicat_to_bicat (bicat_to_hcomp_bicat B) = B. Proof. use subtypePath. { intro. do 4 (use impred ; intro). apply isapropisaset. } use total2_paths_f. - use total2_paths_f. + apply idpath. + repeat (use pathsdirprod) ; cbn. * apply idpath. * apply idpath. * apply idpath. * apply idpath. * apply idpath. * apply idpath. * apply idpath. * apply idpath. * repeat (use funextsec ; intro). rewrite <- lwhisker_hcomp. apply idpath. * repeat (use funextsec ; intro). rewrite <- rwhisker_hcomp. apply idpath. - apply isaprop_prebicat_laws. intros. apply cellset_property. Qed. Definition hcomp_bicat_weq_bicat : hcomp_bicat ≃ bicat. Proof. use make_weq. - exact hcomp_bicat_to_bicat. - use isweq_iso. + exact bicat_to_hcomp_bicat. + exact hcomp_bicat_to_bicat_to_hcomp_bicat. + exact bicat_to_hcomp_bicat_to_bicat. Defined. Definition weq_bicat_prebicategory : bicat ≃ prebicategory. Proof. eapply weqcomp. - apply (invweq hcomp_bicat_weq_bicat). - apply hcomp_bicat_weq_prebicategory. Defined. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/internal_equivalence.v000066400000000000000000000114451451125700300266730ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.WkCatEnrichment.whiskering. Require Import UniMath.Bicategories.WkCatEnrichment.Notations. Definition inv {C:precategory} {a b : C} (f : z_iso a b) := z_iso_inv_from_z_iso f. (******************************************************************************) (* Internal Equivalence *) Definition is_int_equivalence {C : prebicategory} {a b : C} (f : a -1-> b) : UU := ∑ g : b -1-> a, (z_iso (identity1 a) (f ;1; g)) × (z_iso (g ;1; f) (identity1 b)). Definition int_equivalence {C : prebicategory} (a b : C) : UU := ∑ f : a -1-> b, is_int_equivalence f. Definition identity_int_equivalence {C : prebicategory} (a : C) : int_equivalence a a. Proof. exists (identity1 a). exists (identity1 a). split. - exact (inv (left_unitor (identity1 a))). - exact (left_unitor (identity1 a)). Defined. Definition id_to_int_equivalence {C : prebicategory} (a b : C) : (a = b) -> int_equivalence a b. Proof. intros p. induction p. exact (identity_int_equivalence a). Defined. (******************************************************************************) (* Internal Adjoint Equivalence *) Definition is_adj_int_equivalence {C : prebicategory} { a b : C } (f : a -1-> b) := ∑ (g : b -1-> a) (etaeps : (z_iso (identity1 a) (f ;1; g)) × (z_iso (g ;1; f) (identity1 b))), let eta := pr1 etaeps in let eps := pr2 etaeps in ( (inv (left_unitor f)) ;v; (whisker_right eta f) ;v; (inv (associator _ _ _)) ;v; (whisker_left f eps) ;v; (right_unitor _) = (identity f) ) × ( (inv (right_unitor g)) ;v; (whisker_left g eta) ;v; (associator _ _ _) ;v; (whisker_right eps g) ;v; (left_unitor _) = (identity g) ). Definition adj_int_equivalence {C : prebicategory} (a b : C) : UU := ∑ f : a -1-> b, is_adj_int_equivalence f. Local Definition identity_triangle1 {C : prebicategory} (a : C) : (inv (left_unitor (identity1 a))) ;v; (whisker_right (inv (left_unitor (identity1 a))) (identity1 a)) ;v; (inv (associator _ _ _)) ;v; (whisker_left (identity1 a) (right_unitor (identity1 a))) ;v; (right_unitor _) = identity (identity1 a). Proof. apply z_iso_inv_to_right. rewrite id_left. rewrite <- !assoc. apply z_iso_inv_on_right. intermediate_path (identity (identity1 a ;1; identity1 a)). { unfold inv ; cbn. rewrite whisker_right_inv. apply z_iso_inv_on_right. apply z_iso_inv_on_right. rewrite id_right. simpl. unfold whisker_left. unfold whisker_right. rewrite <- left_unitor_id_is_right_unitor_id. rewrite (triangle_axiom (identity1 a) (identity1 a)). rewrite <- left_unitor_id_is_right_unitor_id. reflexivity. } simpl. apply pathsinv0. rewrite left_unitor_id_is_right_unitor_id. apply (z_iso_inv_after_z_iso (right_unitor _)). Defined. Local Definition identity_triangle2 {C : prebicategory} (a : C) : (inv (right_unitor (identity1 a))) ;v; (whisker_left (identity1 a) (inv (left_unitor (identity1 a)))) ;v; (associator _ _ _) ;v; (whisker_right (right_unitor (identity1 a)) (identity1 a)) ;v; (left_unitor _) = (identity (identity1 a)). Proof. rewrite <- (assoc _ _ (whisker_right _ _)). unfold whisker_right at 1. simpl. rewrite <- triangle_axiom. fold (whisker_left (identity1 a) (left_unitor_2mor (identity1 a))). rewrite <- (assoc _ _ (whisker_left _ _)). rewrite <- whisker_left_on_comp. set (W := z_iso_after_z_iso_inv (left_unitor (identity1 a))). simpl in W. rewrite W. clear W. fold (identity (identity1 a)). rewrite whisker_left_id_2mor. rewrite id_right. rewrite left_unitor_id_is_right_unitor_id. set (W := z_iso_after_z_iso_inv (right_unitor (identity1 a))). simpl in W. rewrite W. reflexivity. Defined. Definition identity_adj_int_equivalence {C : prebicategory} (a : C) : adj_int_equivalence a a. Proof. exists (identity1 a). exists (identity1 a). use tpair. - exists (inv (left_unitor (identity1 a))). exact (right_unitor (identity1 a)). - split. + apply identity_triangle1. + apply identity_triangle2. Defined. Definition path_to_adj_int_equivalence {C : prebicategory} (a b : C) : a = b -> adj_int_equivalence a b. Proof. intros p. induction p. exact (identity_adj_int_equivalence a). Defined. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/prebicategory.v000066400000000000000000000304241451125700300253330ustar00rootroot00000000000000(** ********************************************************** Mitchell Riley June 2016 I am very grateful to Peter LeFanu Lumsdaine, whose unreleased bicategories code strongly influenced the definitions in this file. ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.categories.StandardCategories. (* unit *) Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Local Open Scope cat. (******************************************************************************) (* Definition of a prebicategory *) (* This is done in a few pieces. Instead of specifying all the data and the conditions afterwards, we interleave them, i.e., we have a precategory of morphisms immediately, instead of a type that is later said to be a precategory. This (possibly) makes the definition easier to work with. *) (* The pieces are: prebicategory_ob_hom: A type C, and for each a,b : C, a precategory (a -1-> b) prebicategory_id_comp: For each a : C, an object of (a -1-> a), For each a b c : C, a functor (a -1-> b) × (b -1-> c) to (a -1-> c) prebicategory_data: For each a b c d : C, an associator natural transformation For each a b : C, left and right unitor natural transformations prebicategory: Proofs that: Every precategory (a -1-> b)'s homs are sets The natural transformations above are isos The pentagon and triangle axioms hold *) (* An alternative structure would be to define a prebicategory as a precategory such that each hom type itself has the structure of a precategory, together with appropriate axioms. *) Local Notation "C 'c×' D" := (category_binproduct C D) (at level 75, right associativity). Definition prebicategory_ob_hom : UU := ∑ C : UU, ∏ a b : C, category. Coercion bicat_ob (C : prebicategory_ob_hom) : UU := pr1 C. Definition homcat {C : prebicategory_ob_hom} (a b : C) : category := pr2 C a b. Local Notation "a '-1->' b" := (homcat a b) (at level 50, left associativity). Local Notation "f '-2->' g" := (@precategory_morphisms (_ -1->_) f g) (at level 50, left associativity). Local Notation "alpha ';v;' beta" := (@compose (_ -1-> _) _ _ _ alpha beta) (at level 50, left associativity). Definition prebicategory_id_comp := ∑ C : prebicategory_ob_hom, (∏ a : C, a -1-> a) × (∏ a b c : C, ((a -1-> b) c× (b -1-> c)) ⟶ (a -1-> c)). Coercion prebicategory_ob_hom_from_prebicategory_id_comp (C : prebicategory_id_comp) : prebicategory_ob_hom := pr1 C. Definition identity1 {C : prebicategory_id_comp} (a : C) : a -1-> a := pr1 (pr2 C) a. Definition compose_functor {C : prebicategory_id_comp} (a b c : C) : ((a -1-> b) c× (b -1-> c)) ⟶ (a -1-> c) := pr2 (pr2 C) a b c. Definition compose1 {C : prebicategory_id_comp} {a b c : C} (f : a -1-> b) (g : b -1-> c) := functor_on_objects (compose_functor a b c) (make_dirprod f g). Local Notation "f ';1;' g" := (compose1 f g) (at level 50, left associativity). Definition compose2h {C : prebicategory_id_comp} {a b c : C} {f f' : a -1-> b} {g g' : b -1-> c} (alpha : f -2-> f') (beta : g -2-> g') : (f ;1; g) -2-> (f' ;1; g'). Proof. apply functor_on_morphisms. exact (catbinprodmor alpha beta). Defined. Local Notation "alpha ';h;' beta" := (compose2h alpha beta) (at level 50, left associativity). Definition compose2h_iso {C : prebicategory_id_comp} {a b c : C} {f f' : a -1-> b} {g g' : b -1-> c} (alpha : z_iso f f') (beta : z_iso g g') : z_iso (f ;1; g) (f' ;1; g'). Proof. apply functor_on_z_iso. apply precatbinprod_z_iso. - exact alpha. - exact beta. Defined. Local Notation "alpha ';hi;' beta" := (compose2h_iso alpha beta) (at level 50, left associativity). Definition associator_trans_type {C : prebicategory_id_comp} (a b c d : C) : UU := pair_functor (functor_identity (a -1-> b)) (compose_functor b c d) ∙ compose_functor a b d ⟹ precategory_binproduct_assoc (a -1-> b) (b -1-> c) (c -1-> d) ∙ (pair_functor (compose_functor a b c) (functor_identity (c -1-> d)) ∙ compose_functor a c d). Definition left_unitor_trans_type {C : prebicategory_id_comp} (a b : C) : UU := bindelta_pair_functor (constant_functor (a -1-> b) (a -1-> a) (identity1 a)) (functor_identity (a -1-> b)) ∙ compose_functor a a b ⟹ functor_identity (a -1-> b). Definition right_unitor_trans_type {C : prebicategory_id_comp} (a b : C) : UU := bindelta_pair_functor (functor_identity (a -1-> b)) (constant_functor (a -1-> b) (b -1-> b) (identity1 b)) ∙ compose_functor a b b ⟹ functor_identity (a -1-> b). Definition prebicategory_data : UU := ∑ C : prebicategory_id_comp, (∏ a b c d : C, associator_trans_type a b c d) × (∏ a b : C, left_unitor_trans_type a b) × (∏ a b : C, right_unitor_trans_type a b). (* Right *) Coercion prebicategory_id_comp_from_prebicategory_data (C : prebicategory_data) : prebicategory_id_comp := pr1 C. Definition associator_trans {C : prebicategory_data} (a b c d : C) : pair_functor (functor_identity (a -1-> b)) (compose_functor b c d) ∙ compose_functor a b d ⟹ precategory_binproduct_assoc (a -1-> b) (b -1-> c) (c -1-> d) ∙ (pair_functor (compose_functor a b c) (functor_identity (c -1-> d)) ∙ compose_functor a c d) := pr1 (pr2 C) a b c d. Definition associator_2mor {C : prebicategory_data} {a b c d : C} (f : a -1-> b) (g : b -1-> c) (h : c -1-> d) : (f ;1; (g ;1; h)) -2-> ((f ;1; g) ;1; h) := associator_trans a b c d (make_catbinprod f (make_catbinprod g h)). Definition left_unitor_trans {C : prebicategory_data} (a b : C) : bindelta_pair_functor (constant_functor (a -1-> b) (a -1-> a) (identity1 a)) (functor_identity (a -1-> b)) ∙ compose_functor a a b ⟹ functor_identity (a -1-> b) := pr1 (pr2 (pr2 C)) a b. Definition left_unitor_2mor {C : prebicategory_data} {a b : C} (f : a -1-> b) : identity1 a ;1; f -2-> f := left_unitor_trans a b f. Definition right_unitor_trans {C : prebicategory_data} (a b : C) : bindelta_pair_functor (functor_identity (a -1-> b)) (constant_functor (a -1-> b) (b -1-> b) (identity1 b)) ∙ compose_functor a b b ⟹ functor_identity (a -1-> b) := pr2 (pr2 (pr2 C)) a b. Definition right_unitor_2mor {C : prebicategory_data} {a b : C} (f : a -1-> b) : f ;1; (identity1 b) -2-> f := right_unitor_trans a b f. Definition associator_and_unitors_are_iso (C : prebicategory_data) : UU := (∏ (a b c d : C) (f : a -1-> b) (g : b -1-> c) (h : c -1-> d), is_z_isomorphism (associator_2mor f g h)) × (∏ (a b : C) (f : a -1-> b), is_z_isomorphism (left_unitor_2mor f)) × (∏ (a b : C) (g : a -1-> b), is_z_isomorphism (right_unitor_2mor g)). (* It suffices to check the pentagon/triangle axioms pointwise *) Definition pentagon_axiom_type {C : prebicategory_data} {a b c d e : C} (k : a -1-> b) (h : b -1-> c) (g : c -1-> d) (f : d -1-> e) : UU := (* Anticlockwise *) associator_2mor k h (g ;1; f) ;v; associator_2mor (k ;1; h) g f = (* Clockwise *) (identity k ;h; associator_2mor h g f) ;v; associator_2mor k (h ;1; g) f ;v; (associator_2mor k h g ;h; identity f). Definition triangle_axiom_type {C : prebicategory_data} {a b c : C} (f : a -1-> b) (g : b -1-> c) : UU := identity f ;h; left_unitor_2mor g = associator_2mor f (identity1 b) g ;v; (right_unitor_2mor f ;h; identity g). Definition prebicategory_coherence (C : prebicategory_data) : UU := (∏ (a b c d e : C) (k : a -1-> b) (h : b -1-> c) (g : c -1-> d) (f : d -1-> e), pentagon_axiom_type k h g f) × (∏ (a b c : C) (f : a -1-> b) (g : b -1-> c), triangle_axiom_type f g). Definition is_prebicategory (C : prebicategory_data) : UU := associator_and_unitors_are_iso C × prebicategory_coherence C. (* *********************************************************************************** *) (** ** Final packing and projections. *) Definition prebicategory : UU := total2 is_prebicategory. Coercion prebicategory_data_from_prebicategory (C : prebicategory) : prebicategory_data := pr1 C. Definition has_homcats (C : prebicategory) : UU := ∏ a b : C, is_univalent (homcat a b). Definition associator {C : prebicategory} {a b c d : C} (f : a -1-> b) (g : b -1-> c) (h : c -1-> d) : z_iso (f ;1; (g ;1; h)) ((f ;1; g) ;1; h). Proof. use tpair. - exact (associator_2mor _ _ _). - exact ((pr1 (pr1 (pr2 C))) a b c d f g h). Defined. Definition left_unitor {C : prebicategory} {a b : C} (f : a -1-> b) : z_iso ((identity1 a) ;1; f) f. Proof. use tpair. - exact (left_unitor_2mor f). - exact ((pr1 (pr2 (pr1 (pr2 C)))) a b f). Defined. Definition right_unitor {C : prebicategory} {a b : C} (f : a -1-> b) : z_iso (f ;1; (identity1 b)) f. Proof. use tpair. - exact (right_unitor_2mor f). - exact ((pr2 (pr2 (pr1 (pr2 C)))) a b f). Defined. Definition pentagon_axiom {C : prebicategory} {a b c d e: C} (k : a -1-> b) (h : b -1-> c) (g : c -1-> d) (f : d -1-> e) : pentagon_axiom_type k h g f := pr1 (pr2 (pr2 C)) a b c d e k h g f. Definition triangle_axiom {C : prebicategory} {a b c : C} (f : a -1-> b) (g : b -1-> c) : triangle_axiom_type f g := pr2 (pr2 (pr2 C)) a b c f g. (******************************************************************************) (** ** Basics on identities and inverses *) Lemma id_2mor_left {C : prebicategory} {b c : C} {g g' : b -1-> c} (β : g -2-> g') : identity (identity1 b) ;h; β = left_unitor g ;v; β ;v; inv_from_z_iso (left_unitor g'). Proof. apply z_iso_inv_on_left. apply pathsinv0. apply (nat_trans_ax (left_unitor_trans b c)). Defined. Lemma id_2mor_right {C : prebicategory} {a b : C} {f f' : a -1-> b} (alpha : f -2-> f') : alpha ;h; identity (identity1 b) = right_unitor f ;v; alpha ;v; inv_from_z_iso (right_unitor f'). Proof. apply z_iso_inv_on_left. apply pathsinv0. apply (nat_trans_ax (right_unitor_trans a b)). Defined. Lemma horizontal_comp_id {C : prebicategory_id_comp} {a b c : C} {f : a -1-> b} {g : b -1-> c} : identity f ;h; identity g = identity (f ;1; g). Proof. unfold compose2h. intermediate_path (functor_on_morphisms (compose_functor a b c) (identity (make_catbinprod f g))). reflexivity. apply functor_id. Defined. Lemma inv_horizontal_comp {C : prebicategory_id_comp} {a b c : C} {f f' : a -1-> b} {g g' : b -1-> c} (alpha : z_iso f f') (beta : z_iso g g') : (z_iso_inv_from_z_iso alpha) ;hi; (z_iso_inv_from_z_iso beta) = z_iso_inv_from_z_iso (alpha ;hi; beta). Proof. unfold compose2h_iso. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } apply idpath. Defined. (******************************************************************************) (* Interchange Law *) Lemma interchange {C : prebicategory} {a b c : C} {f1 f2 f3 : a -1-> b} {g1 g2 g3 : b -1-> c} (a1 : f1 -2-> f2) (a2 : f2 -2-> f3) (b1 : g1 -2-> g2) (b2 : g2 -2-> g3) : (a1 ;v; a2) ;h; (b1 ;v; b2) = (a1 ;h; b1) ;v; (a2 ;h; b2). Proof. unfold compose2h. assert (X : catbinprodmor a1 b1 · catbinprodmor a2 b2 = catbinprodmor (a1 ;v; a2) (b1 ;v; b2)) by reflexivity. rewrite <- X. apply functor_comp. Qed. (******************************************************************************) (* ** Further results. *) (** *** The othoter triangle identity. *) Lemma triangle_identity' {C : prebicategory} {a b c : C} (f : a -1-> b) (g : b -1-> c) : right_unitor_2mor f ;h; identity g = inv_from_z_iso (associator f (identity1 b) g) ;v; (identity _ ;h; left_unitor_2mor _). Proof. refine (!_). use z_iso_inv_on_right. apply triangle_axiom. Qed. UniMath-20231010/UniMath/Bicategories/WkCatEnrichment/whiskering.v000066400000000000000000000327431451125700300246540ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.categories.StandardCategories. (* unit *) Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory. Require Import UniMath.Bicategories.WkCatEnrichment.Notations. (******************************************************************************) (* Whiskering *) Definition whisker_left {C : prebicategory} {a b c : C} (f : a -1-> b) {g h : b -1-> c} (alpha : g -2-> h) : (f ;1; g) -2-> (f ;1; h) := identity f ;h; alpha. Lemma whisker_left_id_1mor {C : prebicategory} {b c : C} {g h : b -1-> c} (alpha : g -2-> h) : whisker_left (identity1 _) alpha = left_unitor _ ;v; alpha ;v; inv_from_z_iso (left_unitor _). Proof. unfold whisker_left. apply id_2mor_left. Defined. Lemma whisker_left_id_2mor {C : prebicategory} {a b c : C} (f : a -1-> b) (g : b -1-> c) : whisker_left f (identity g) = identity (f ;1; g). Proof. intermediate_path (functor_on_morphisms (compose_functor a b c) (identity (make_catbinprod f g))). reflexivity. apply functor_id. Defined. Lemma cancel_whisker_left {C : prebicategory} {a b c : C} (f : a -1-> b) {g h : b -1-> c} {alpha alpha': g -2-> h} (p : alpha = alpha') : whisker_left f alpha = whisker_left f alpha'. Proof. induction p. reflexivity. Defined. Definition whisker_left_iso {C : prebicategory} {a b c : C} (f : a -1-> b) {g h : b -1-> c} (alpha : z_iso g h) : z_iso (f ;1; g) (f ;1; h). Proof. exists (whisker_left f alpha). apply functor_on_is_z_isomorphism. apply is_z_iso_binprod_z_iso. - apply identity_is_z_iso. - apply alpha. Defined. Lemma whisker_left_inv {C : prebicategory} {a b c : C} (f : a -1-> b) {g h : b -1-> c} (alpha : z_iso g h) : whisker_left f (z_iso_inv_from_z_iso alpha) = inv_from_z_iso (whisker_left_iso f alpha). Proof. unfold whisker_left. intermediate_path (inv_from_z_iso (identity_z_iso f);h;inv_from_z_iso alpha). set (W := maponpaths pr1 (iso_inv_of_iso_id f)). simpl in W. rewrite <- W. reflexivity. apply (maponpaths pr1 (inv_horizontal_comp (identity_z_iso f) alpha)). Defined. Lemma whisker_left_id_inj {C : prebicategory} {b c : C} {g h : b -1-> c} (alpha alpha' : g -2-> h) : whisker_left (identity1 _) alpha = whisker_left (identity1 _) alpha' -> alpha = alpha'. Proof. intros w. intermediate_path (inv_from_z_iso (left_unitor _) ;v; whisker_left (identity1 _) alpha ;v; left_unitor _ ). apply pathsinv0. apply z_iso_inv_to_right. apply z_iso_inv_on_right. rewrite assoc. apply whisker_left_id_1mor. intermediate_path (inv_from_z_iso (left_unitor _) ;v; whisker_left (identity1 _) alpha' ;v; left_unitor _ ). apply cancel_postcomposition. apply cancel_precomposition. assumption. apply z_iso_inv_to_right. apply z_iso_inv_on_right. rewrite assoc. apply whisker_left_id_1mor. Defined. Lemma whisker_left_on_comp {C : prebicategory} {a b c : C} (f : a -1-> b) {g h i : b -1-> c} (alpha : g -2-> h) (alpha' : h -2-> i) : whisker_left f (alpha ;v; alpha') = whisker_left f alpha ;v; whisker_left f alpha'. Proof. unfold whisker_left. intermediate_path ((identity f;v; identity f);h;(alpha;v;alpha')). rewrite id_left. reflexivity. now apply interchange. Defined. Definition whisker_right {C : prebicategory} {a b c : C} {f g : a -1-> b} (alpha : f -2-> g) (h : b -1-> c) : (f ;1; h) -2-> (g ;1; h) := alpha ;h; identity h. Lemma whisker_right_id_1mor {C : prebicategory} {a b : C} {f g : a -1-> b} (alpha : f -2-> g) : whisker_right alpha (identity1 _) = right_unitor _ ;v; alpha ;v; inv_from_z_iso (right_unitor _). Proof. unfold whisker_right. apply id_2mor_right. Defined. Lemma whisker_right_id_2mor {C : prebicategory} {a b c : C} (f : a -1-> b) (g : b -1-> c) : whisker_right (identity f) g = identity (f ;1; g). Proof. intermediate_path (functor_on_morphisms (compose_functor a b c) (identity (make_catbinprod f g))). reflexivity. apply functor_id. Defined. Definition cancel_whisker_right {C : prebicategory} {a b c : C} {f g : a -1-> b} {alpha alpha' : f -2-> g} (p : alpha = alpha') (h : b -1-> c) : whisker_right alpha h = whisker_right alpha' h. Proof. induction p. reflexivity. Defined. Definition whisker_right_iso {C : prebicategory} {a b c : C} {f g : a -1-> b} (alpha : z_iso f g) (h : b -1-> c) : z_iso (f ;1; h) (g ;1; h). Proof. exists (whisker_right alpha h). apply functor_on_is_z_isomorphism. apply is_z_iso_binprod_z_iso. - apply alpha. - apply identity_is_z_iso. Defined. Lemma whisker_right_inv {C : prebicategory} {a b c : C} {f g : a -1-> b} (alpha : z_iso f g) (h : b -1-> c) : whisker_right (inv_from_z_iso alpha) h = inv_from_z_iso (whisker_right_iso alpha h). Proof. unfold whisker_right. intermediate_path (inv_from_z_iso alpha ;h; inv_from_iso (identity_iso h)). set (W := maponpaths pr1 (iso_inv_of_iso_id h)). simpl in W. rewrite <- W. reflexivity. apply (maponpaths pr1 (inv_horizontal_comp alpha (identity_z_iso h))). Defined. Lemma whisker_right_id_inj {C : prebicategory} {a b : C} {f g : a -1-> b} (alpha alpha' : f -2-> g) : whisker_right alpha (identity1 _) = whisker_right alpha' (identity1 _) -> alpha = alpha'. Proof. intros w. intermediate_path (inv_from_z_iso (right_unitor _) ;v; whisker_right alpha (identity1 _) ;v; right_unitor _ ). apply pathsinv0. apply z_iso_inv_to_right. apply z_iso_inv_on_right. rewrite assoc. apply whisker_right_id_1mor. intermediate_path (inv_from_z_iso (right_unitor _) ;v; whisker_right alpha' (identity1 _) ;v; right_unitor _ ). apply cancel_postcomposition. apply cancel_precomposition. assumption. apply z_iso_inv_to_right. apply z_iso_inv_on_right. rewrite assoc. apply whisker_right_id_1mor. Defined. Lemma whisker_right_on_comp {C : prebicategory} {a b c : C} {f g h : a -1-> b} (alpha : f -2-> g) (alpha' : g -2-> h) (i : b -1-> c) : whisker_right (alpha ;v; alpha') i = whisker_right alpha i ;v; whisker_right alpha' i. Proof. unfold whisker_right. intermediate_path ((alpha;v;alpha');h;(identity i;v; identity i)). rewrite id_left. reflexivity. now apply interchange. Defined. Lemma left_unitor_naturality {C : prebicategory} {a b : C} (f g : a -1-> b) (alpha : f -2-> g) : whisker_left (identity1 _) alpha ;v; left_unitor g = left_unitor f ;v; alpha. Proof. intermediate_path ((functor_on_morphisms (functor_composite (bindelta_pair_functor (functor_composite (functor_to_unit _) (constant_functor unit_category _ (identity1 a))) (functor_identity _)) (compose_functor a a b)) alpha) ;v;(left_unitor g)). reflexivity. intermediate_path (left_unitor f ;v; functor_on_morphisms (functor_identity _) alpha). apply (nat_trans_ax (left_unitor_trans a b)). reflexivity. Defined. Lemma right_unitor_naturality {C : prebicategory} {a b : C} (f g : a -1-> b) (alpha : f -2-> g) : whisker_right alpha (identity1 _) ;v; right_unitor g = right_unitor f ;v; alpha. Proof. intermediate_path ((functor_on_morphisms (functor_composite (bindelta_pair_functor (functor_identity _) (functor_composite (functor_to_unit _) (constant_functor unit_category _ (identity1 b)))) (compose_functor a b b)) alpha) ;v;(right_unitor _)). reflexivity. intermediate_path (right_unitor f ;v; functor_on_morphisms (functor_identity _) alpha). apply (nat_trans_ax (right_unitor_trans a b)). reflexivity. Defined. Lemma associator_naturality {C : prebicategory} { a b c d : C } {f f' : a -1-> b} (alpha : f -2-> f') {g g' : b -1-> c} (beta : g -2-> g') {h h' : c -1-> d} (gamma : h -2-> h') : (alpha ;h; (beta ;h; gamma)) ;v; associator f' g' h' = associator f g h ;v; ((alpha ;h; beta) ;h; gamma). Proof. intermediate_path ((functor_on_morphisms (functor_composite (pair_functor (functor_identity _) (compose_functor b c d)) (compose_functor a b d)) (catbinprodmor alpha (catbinprodmor beta gamma))) ;v; associator f' g' h' ). reflexivity. intermediate_path (associator f g h ;v; (functor_on_morphisms (functor_composite (precategory_binproduct_assoc _ _ _) (functor_composite (pair_functor (compose_functor a b c) (functor_identity _)) (compose_functor a c d))) (catbinprodmor alpha (catbinprodmor beta gamma)))). apply (nat_trans_ax (associator_trans a b c d) _ _ (catbinprodmor alpha (catbinprodmor beta gamma))). reflexivity. Defined. Lemma twomor_naturality {C : prebicategory} {a b c : C} {f g : a -1-> b} {h k : b -1-> c} (gamma : f -2-> g) (delta : h -2-> k) : (whisker_right gamma h) ;v; (whisker_left g delta) = (whisker_left f delta) ;v; (whisker_right gamma k). Proof. unfold whisker_left, whisker_right. intermediate_path ((gamma ;v; identity g);h;(identity h ;v; delta)). apply pathsinv0. apply interchange. intermediate_path ((identity f ;v; gamma);h;(delta ;v; identity k)). rewrite !id_left, !id_right. reflexivity. apply interchange. Defined. (******************************************************************************) (* Kelly's Condition 5 *) (* i.e., the two ways of going I(bc) -> bc are equal *) Section kelly_left_pieces. Variable C : prebicategory. Variables a b c d : C. Variable f : a -1-> b. Variable g : b -1-> c. Variable h : c -1-> d. Local Lemma kelly_left_region_1235 : associator f (identity1 _) (g ;1; h) ;v; associator (f ;1; (identity1 _)) g h ;v; whisker_right (whisker_right (right_unitor f) g) h = whisker_left f (associator (identity1 b) g h) ;v; associator f (identity1 _ ;1; g) h ;v; whisker_right (whisker_left f (left_unitor g)) h. Proof. simpl. unfold whisker_left at 2. rewrite (cancel_whisker_right (triangle_axiom f g) h). rewrite whisker_right_on_comp. rewrite assoc. apply cancel_postcomposition. apply (pentagon_axiom f (identity1 b) g h). Defined. Local Lemma kelly_left_region_123 : associator f (identity1 _) (g ;1; h) ;v; associator (f ;1; (identity1 _)) g h ;v; whisker_right (whisker_right (right_unitor f) g) h = whisker_left f (associator (identity1 b) g h) ;v; whisker_left f (whisker_right (left_unitor g) h) ;v; associator f g h. Proof. rewrite <- (assoc _ _ (associator f g h)). unfold whisker_left at 2. unfold whisker_right at 3. rewrite associator_naturality. fold (whisker_left f (left_unitor g)). fold (whisker_right (whisker_left f (left_unitor g)) h). rewrite assoc. apply kelly_left_region_1235. Defined. Local Lemma kelly_left_region_12 : associator f (identity1 _) (g ;1; h) ;v; whisker_right (right_unitor f) (g ;1; h) = whisker_left f (associator (identity1 b) g h) ;v; whisker_left f (whisker_right (left_unitor g) h). Proof. use (post_comp_with_z_iso_is_inj (associator f g h)). unfold whisker_right at 1. rewrite <- horizontal_comp_id. rewrite <- assoc. rewrite associator_naturality. rewrite assoc. apply kelly_left_region_123. Defined. Local Lemma kelly_left_region_1 : whisker_left f (left_unitor_2mor (g ;1; h)) = whisker_left f (associator (identity1 b) g h) ;v; whisker_left f (whisker_right (left_unitor g) h). Proof. unfold whisker_left at 1. rewrite triangle_axiom. apply kelly_left_region_12. Defined. End kelly_left_pieces. Lemma kelly_left {C : prebicategory} {b c d : C} {g : b -1-> c} {h : c -1-> d} : left_unitor_2mor (g ;1; h) = associator (identity1 b) g h ;v; whisker_right (left_unitor g) h. Proof. apply whisker_left_id_inj. rewrite whisker_left_on_comp. apply kelly_left_region_1. Defined. (* TODO: same for right *) (******************************************************************************) (* Kelly's Condition 4 *) (* i.e., the two ways of going II -> I are equal *) Lemma left_unitor_on_id {C : prebicategory} {a : C} : whisker_left (identity1 a) (left_unitor (identity1 a)) = left_unitor (identity1 a ;1; identity1 a). Proof. use (post_comp_with_z_iso_is_inj (left_unitor (identity1 a))). apply left_unitor_naturality. Defined. Lemma left_unitor_id_is_right_unitor_id {C : prebicategory} {a : C} : left_unitor_2mor (identity1 a) = right_unitor_2mor (identity1 a). Proof. apply whisker_right_id_inj. use (pre_comp_with_z_iso_is_inj (associator _ _ _)). intermediate_path (left_unitor_2mor ((identity1 a) ;1; (identity1 a))). apply pathsinv0. apply kelly_left. intermediate_path (whisker_left (identity1 a) (left_unitor (identity1 a))). apply pathsinv0. apply left_unitor_on_id. apply (triangle_axiom (identity1 a) (identity1 a)). Defined. UniMath-20231010/UniMath/CONTENTS.md000066400000000000000000002705621451125700300164470ustar00rootroot00000000000000# Contents of the UniMath library The packages and files are listed here in logical order: each file depends only on files occurring earlier. ## Package [Foundations](Foundations/README) - [Init.v](Foundations/Init.v) - [Preamble.v](Foundations/Preamble.v) - [PartA.v](Foundations/PartA.v) - [PartB.v](Foundations/PartB.v) - [UnivalenceAxiom.v](Foundations/UnivalenceAxiom.v) - [PartC.v](Foundations/PartC.v) - [PartD.v](Foundations/PartD.v) - [UnivalenceAxiom2.v](Foundations/UnivalenceAxiom2.v) - [Propositions.v](Foundations/Propositions.v) - [Sets.v](Foundations/Sets.v) - [NaturalNumbers.v](Foundations/NaturalNumbers.v) - [Tests.v](Foundations/Tests.v) - [HLevels.v](Foundations/HLevels.v) - [All.v](Foundations/All.v) ## Package [MoreFoundations](MoreFoundations/README.md) - [Bool.v](MoreFoundations/Bool.v) - [Test.v](MoreFoundations/Test.v) - [WeakEquivalences.v](MoreFoundations/WeakEquivalences.v) - [Tactics.v](MoreFoundations/Tactics.v) - [PartA.v](MoreFoundations/PartA.v) - [PathsOver.v](MoreFoundations/PathsOver.v) - [Nat.v](MoreFoundations/Nat.v) - [Notations.v](MoreFoundations/Notations.v) - [AlternativeProofs.v](MoreFoundations/AlternativeProofs.v) - [Subposets.v](MoreFoundations/Subposets.v) - [DoubleNegation.v](MoreFoundations/DoubleNegation.v) - [DecidablePropositions.v](MoreFoundations/DecidablePropositions.v) - [Propositions.v](MoreFoundations/Propositions.v) - [NullHomotopies.v](MoreFoundations/NullHomotopies.v) - [Interval.v](MoreFoundations/Interval.v) - [NegativePropositions.v](MoreFoundations/NegativePropositions.v) - [Sets.v](MoreFoundations/Sets.v) - [Orders.v](MoreFoundations/Orders.v) - [Equivalences.v](MoreFoundations/Equivalences.v) - [MoreEquivalences.v](MoreFoundations/MoreEquivalences.v) - [QuotientSet.v](MoreFoundations/QuotientSet.v) - [Subtypes.v](MoreFoundations/Subtypes.v) - [AxiomOfChoice.v](MoreFoundations/AxiomOfChoice.v) - [StructureIdentity.v](MoreFoundations/StructureIdentity.v) - [Univalence.v](MoreFoundations/Univalence.v) - [NoInjectivePairing.v](MoreFoundations/NoInjectivePairing.v) - [PartD.v](MoreFoundations/PartD.v) - [All.v](MoreFoundations/All.v) ## Package [Combinatorics](Combinatorics/README.md) - [StandardFiniteSets.v](Combinatorics/StandardFiniteSets.v) - [Vectors.v](Combinatorics/Vectors.v) - [VectorsTests.v](Combinatorics/VectorsTests.v) - [Lists.v](Combinatorics/Lists.v) - [FiniteSets.v](Combinatorics/FiniteSets.v) - [KFiniteTypes.v](Combinatorics/KFiniteTypes.v) - [KFiniteSubtypes.v](Combinatorics/KFiniteSubtypes.v) - [Graph.v](Combinatorics/Graph.v) - [CGraph.v](Combinatorics/CGraph.v) - [GraphPaths.v](Combinatorics/GraphPaths.v) - [Equivalence_Relations.v](Combinatorics/Equivalence_Relations.v) - [OrderedSets.v](Combinatorics/OrderedSets.v) - [WellFoundedRelations.v](Combinatorics/WellFoundedRelations.v) - [WellOrderedSets.v](Combinatorics/WellOrderedSets.v) - [ZFstructures.v](Combinatorics/ZFstructures.v) - [FiniteSequences.v](Combinatorics/FiniteSequences.v) - [BoundedSearch.v](Combinatorics/BoundedSearch.v) - [MetricTree.v](Combinatorics/MetricTree.v) - [Tests.v](Combinatorics/Tests.v) - [DecSet.v](Combinatorics/DecSet.v) - [Maybe.v](Combinatorics/Maybe.v) - [MoreLists.v](Combinatorics/MoreLists.v) - [All.v](Combinatorics/All.v) ## Package [Algebra](Algebra/README.md) - [BinaryOperations.v](Algebra/BinaryOperations.v) - [Monoids.v](Algebra/Monoids.v) - [Groups.v](Algebra/Groups.v) - [GroupAction.v](Algebra/GroupAction.v) - [RigsAndRings.v](Algebra/RigsAndRings.v) - [RigsAndRings/Ideals.v](Algebra/RigsAndRings/Ideals.v) - [Domains_and_Fields.v](Algebra/Domains_and_Fields.v) - [DivisionRig.v](Algebra/DivisionRig.v) - [Apartness.v](Algebra/Apartness.v) - [ConstructiveStructures.v](Algebra/ConstructiveStructures.v) - [Archimedean.v](Algebra/Archimedean.v) - [IteratedBinaryOperations.v](Algebra/IteratedBinaryOperations.v) - [Free_Monoids_and_Groups.v](Algebra/Free_Monoids_and_Groups.v) - [Tests.v](Algebra/Tests.v) - [Modules/Core.v](Algebra/Modules/Core.v) - [Modules/Submodule.v](Algebra/Modules/Submodule.v) - [Modules/Multimodules.v](Algebra/Modules/Multimodules.v) - [Modules/Examples.v](Algebra/Modules/Examples.v) - [Modules/Quotient.v](Algebra/Modules/Quotient.v) - [Modules.v](Algebra/Modules.v) - [Matrix.v](Algebra/Matrix.v) - [Universal/HVectors.v](Algebra/Universal/HVectors.v) - [Universal/SortedTypes.v](Algebra/Universal/SortedTypes.v) - [Universal/Signatures.v](Algebra/Universal/Signatures.v) - [Universal/Algebras.v](Algebra/Universal/Algebras.v) - [Universal/Terms.v](Algebra/Universal/Terms.v) - [Universal/TermAlgebras.v](Algebra/Universal/TermAlgebras.v) - [Universal/VTerms.v](Algebra/Universal/VTerms.v) - [Universal/FreeAlgebras.v](Algebra/Universal/FreeAlgebras.v) - [Universal/Equations.v](Algebra/Universal/Equations.v) - [Universal/EqAlgebras.v](Algebra/Universal/EqAlgebras.v) - [Universal/Examples/Nat.v](Algebra/Universal/Examples/Nat.v) - [Universal/Examples/Bool.v](Algebra/Universal/Examples/Bool.v) - [Universal/Examples/Monoid.v](Algebra/Universal/Examples/Monoid.v) - [Universal/Examples/Group.v](Algebra/Universal/Examples/Group.v) - [Universal/Examples/ListDataType.v](Algebra/Universal/Examples/ListDataType.v) - [Universal/Examples/Tests.v](Algebra/Universal/Examples/Tests.v) - [Universal.v](Algebra/Universal.v) - [GaussianElimination/Auxiliary.v](Algebra/GaussianElimination/Auxiliary.v) - [GaussianElimination/Vectors.v](Algebra/GaussianElimination/Vectors.v) - [GaussianElimination/Matrices.v](Algebra/GaussianElimination/Matrices.v) - [GaussianElimination/RowOps.v](Algebra/GaussianElimination/RowOps.v) - [GaussianElimination/Elimination.v](Algebra/GaussianElimination/Elimination.v) - [GaussianElimination/Corollaries.v](Algebra/GaussianElimination/Corollaries.v) - [GaussianElimination/Tests.v](Algebra/GaussianElimination/Tests.v) - [All.v](Algebra/All.v) ## Package Tactics - [EnsureStructuredProofs.v](Tactics/EnsureStructuredProofs.v) - [Utilities.v](Tactics/Utilities.v) - [Monoids_Tactics.v](Tactics/Monoids_Tactics.v) - [Abmonoids_Tactics.v](Tactics/Abmonoids_Tactics.v) - [Groups_Tactics.v](Tactics/Groups_Tactics.v) - [Nat_Tactics.v](Tactics/Nat_Tactics.v) - [All.v](Tactics/All.v) ## Package NumberSystems - [NaturalNumbersAlgebra.v](NumberSystems/NaturalNumbersAlgebra.v) - [NaturalNumbers_le_Inductive.v](NumberSystems/NaturalNumbers_le_Inductive.v) - [Integers.v](NumberSystems/Integers.v) - [RationalNumbers.v](NumberSystems/RationalNumbers.v) - [Tests.v](NumberSystems/Tests.v) - [All.v](NumberSystems/All.v) ## Package [SyntheticHomotopyTheory](SyntheticHomotopyTheory/README.md) - [Coproduct.v](SyntheticHomotopyTheory/Coproduct.v) - [Halfline.v](SyntheticHomotopyTheory/Halfline.v) - [AffineLine.v](SyntheticHomotopyTheory/AffineLine.v) - [Circle.v](SyntheticHomotopyTheory/Circle.v) - [Circle2.v](SyntheticHomotopyTheory/Circle2.v) - [Test.v](SyntheticHomotopyTheory/Test.v) - [All.v](SyntheticHomotopyTheory/All.v) ## Package [PAdics](PAdics/README.md) - [lemmas.v](PAdics/lemmas.v) - [fps.v](PAdics/fps.v) - [frac.v](PAdics/frac.v) - [z_mod_p.v](PAdics/z_mod_p.v) - [padics.v](PAdics/padics.v) - [All.v](PAdics/All.v) ## Package OrderTheory - [Posets/Basics.v](OrderTheory/Posets/Basics.v) - [Posets/MonotoneFunctions.v](OrderTheory/Posets/MonotoneFunctions.v) - [Posets/PosetSum.v](OrderTheory/Posets/PosetSum.v) - [Posets/PointedPosets.v](OrderTheory/Posets/PointedPosets.v) - [Posets/LiftPoset.v](OrderTheory/Posets/LiftPoset.v) - [Posets/QuotientPoset.v](OrderTheory/Posets/QuotientPoset.v) - [Posets.v](OrderTheory/Posets.v) - [Lattice/Lattice.v](OrderTheory/Lattice/Lattice.v) - [Lattice/Bounded.v](OrderTheory/Lattice/Bounded.v) - [Lattice/Complement.v](OrderTheory/Lattice/Complement.v) - [Lattice/Distributive.v](OrderTheory/Lattice/Distributive.v) - [Lattice/Heyting.v](OrderTheory/Lattice/Heyting.v) - [Lattice/Boolean.v](OrderTheory/Lattice/Boolean.v) - [Lattice/Examples/Bool.v](OrderTheory/Lattice/Examples/Bool.v) - [Lattice/Examples/Subsets.v](OrderTheory/Lattice/Examples/Subsets.v) - [DCPOs/Core/DirectedSets.v](OrderTheory/DCPOs/Core/DirectedSets.v) - [DCPOs/Core/Basics.v](OrderTheory/DCPOs/Core/Basics.v) - [DCPOs/Core/WayBelow.v](OrderTheory/DCPOs/Core/WayBelow.v) - [DCPOs/Basis/Continuous.v](OrderTheory/DCPOs/Basis/Continuous.v) - [DCPOs/Basis/Algebraic.v](OrderTheory/DCPOs/Basis/Algebraic.v) - [DCPOs/Core/ScottTopology.v](OrderTheory/DCPOs/Core/ScottTopology.v) - [DCPOs/Core/IntrinsicApartness.v](OrderTheory/DCPOs/Core/IntrinsicApartness.v) - [DCPOs/Core/ScottContinuous.v](OrderTheory/DCPOs/Core/ScottContinuous.v) - [DCPOs/Basis/Basis.v](OrderTheory/DCPOs/Basis/Basis.v) - [DCPOs/Basis/CompactBasis.v](OrderTheory/DCPOs/Basis/CompactBasis.v) - [DCPOs/Elements/Sharp.v](OrderTheory/DCPOs/Elements/Sharp.v) - [DCPOs/Elements/Maximal.v](OrderTheory/DCPOs/Elements/Maximal.v) - [DCPOs/Examples/Unit.v](OrderTheory/DCPOs/Examples/Unit.v) - [DCPOs/Examples/Propositions.v](OrderTheory/DCPOs/Examples/Propositions.v) - [DCPOs/Examples/Discrete.v](OrderTheory/DCPOs/Examples/Discrete.v) - [DCPOs/Examples/SubDCPO.v](OrderTheory/DCPOs/Examples/SubDCPO.v) - [DCPOs/Examples/Fixpoints.v](OrderTheory/DCPOs/Examples/Fixpoints.v) - [DCPOs/Examples/Equalizers.v](OrderTheory/DCPOs/Examples/Equalizers.v) - [DCPOs/Examples/BinaryProducts.v](OrderTheory/DCPOs/Examples/BinaryProducts.v) - [DCPOs/Examples/Products.v](OrderTheory/DCPOs/Examples/Products.v) - [DCPOs/Examples/BinarySums.v](OrderTheory/DCPOs/Examples/BinarySums.v) - [DCPOs/Examples/Sums.v](OrderTheory/DCPOs/Examples/Sums.v) - [DCPOs/Examples/IdealCompletion.v](OrderTheory/DCPOs/Examples/IdealCompletion.v) - [DCPOs/Core/FubiniTheorem.v](OrderTheory/DCPOs/Core/FubiniTheorem.v) - [DCPOs/Core/CoordinateContinuity.v](OrderTheory/DCPOs/Core/CoordinateContinuity.v) - [DCPOs/Examples/Exponentials.v](OrderTheory/DCPOs/Examples/Exponentials.v) - [DCPOs/FixpointTheorems/LeastFixpoint.v](OrderTheory/DCPOs/FixpointTheorems/LeastFixpoint.v) - [DCPOs/FixpointTheorems/Pataraia.v](OrderTheory/DCPOs/FixpointTheorems/Pataraia.v) - [DCPOs/AlternativeDefinitions/Dcpo.v](OrderTheory/DCPOs/AlternativeDefinitions/Dcpo.v) - [DCPOs/AlternativeDefinitions/FixedPointTheorems.v](OrderTheory/DCPOs/AlternativeDefinitions/FixedPointTheorems.v) - [DCPOs.v](OrderTheory/DCPOs.v) - [All.v](OrderTheory/All.v) ## Package [CategoryTheory](CategoryTheory/README.md) - [Core/Categories.v](CategoryTheory/Core/Categories.v) - [Core/TwoCategories.v](CategoryTheory/Core/TwoCategories.v) - [Core/Isos.v](CategoryTheory/Core/Isos.v) - [Core/Univalence.v](CategoryTheory/Core/Univalence.v) - [Core/TransportMorphisms.v](CategoryTheory/Core/TransportMorphisms.v) - [Core/Functors.v](CategoryTheory/Core/Functors.v) - [Core/NaturalTransformations.v](CategoryTheory/Core/NaturalTransformations.v) - [Core/Setcategories.v](CategoryTheory/Core/Setcategories.v) - [Core/EssentiallyAlgebraic.v](CategoryTheory/Core/EssentiallyAlgebraic.v) - [Core/Prelude.v](CategoryTheory/Core/Prelude.v) - [FunctorCategory.v](CategoryTheory/FunctorCategory.v) - [whiskering.v](CategoryTheory/whiskering.v) - [BicatOfCatsElementary.v](CategoryTheory/BicatOfCatsElementary.v) - [DisplayedCats/Core.v](CategoryTheory/DisplayedCats/Core.v) - [DisplayedCats/Isos.v](CategoryTheory/DisplayedCats/Isos.v) - [DisplayedCats/Functors.v](CategoryTheory/DisplayedCats/Functors.v) - [DisplayedCats/NaturalTransformations.v](CategoryTheory/DisplayedCats/NaturalTransformations.v) - [DisplayedCats/Univalence.v](CategoryTheory/DisplayedCats/Univalence.v) - [DisplayedCats/DisplayedFunctorEq.v](CategoryTheory/DisplayedCats/DisplayedFunctorEq.v) - [DisplayedCats/Total.v](CategoryTheory/DisplayedCats/Total.v) - [DisplayedCats/Fiber.v](CategoryTheory/DisplayedCats/Fiber.v) - [categories/CategoryOfSetCategories.v](CategoryTheory/categories/CategoryOfSetCategories.v) - [opp_precat.v](CategoryTheory/opp_precat.v) - [OppositeCategory/Core.v](CategoryTheory/OppositeCategory/Core.v) - [Groupoids.v](CategoryTheory/Groupoids.v) - [ZigZag.v](CategoryTheory/ZigZag.v) - [ProductCategory.v](CategoryTheory/ProductCategory.v) - [PrecategoryBinProduct.v](CategoryTheory/PrecategoryBinProduct.v) - [categories/HSET/Core.v](CategoryTheory/categories/HSET/Core.v) - [CategorySum.v](CategoryTheory/CategorySum.v) - [Subcategory/Core.v](CategoryTheory/Subcategory/Core.v) - [Subcategory/Full.v](CategoryTheory/Subcategory/Full.v) - [Monics.v](CategoryTheory/Monics.v) - [Epis.v](CategoryTheory/Epis.v) - [SplitMonicsAndEpis.v](CategoryTheory/SplitMonicsAndEpis.v) - [HomotopicalCategory.v](CategoryTheory/HomotopicalCategory.v) - [Adjunctions/Core.v](CategoryTheory/Adjunctions/Core.v) - [Monads/RelativeMonads.v](CategoryTheory/Monads/RelativeMonads.v) - [Monads/RelMonads_Coreflection.v](CategoryTheory/Monads/RelMonads_Coreflection.v) - [Monads/RelativeModules.v](CategoryTheory/Monads/RelativeModules.v) - [Equivalences/Core.v](CategoryTheory/Equivalences/Core.v) - [Equivalences/CompositesAndInverses.v](CategoryTheory/Equivalences/CompositesAndInverses.v) - [Equivalences/FullyFaithful.v](CategoryTheory/Equivalences/FullyFaithful.v) - [Subcategory/FullEquivalences.v](CategoryTheory/Subcategory/FullEquivalences.v) - [categories/HSET/MonoEpiIso.v](CategoryTheory/categories/HSET/MonoEpiIso.v) - [categories/HSET/Univalence.v](CategoryTheory/categories/HSET/Univalence.v) - [Profunctors/Core.v](CategoryTheory/Profunctors/Core.v) - [CategoriesWithBinOps.v](CategoryTheory/CategoriesWithBinOps.v) - [PrecategoriesWithAbgrops.v](CategoryTheory/PrecategoriesWithAbgrops.v) - [covyoneda.v](CategoryTheory/covyoneda.v) - [limits/cones.v](CategoryTheory/limits/cones.v) - [limits/equalizers.v](CategoryTheory/limits/equalizers.v) - [limits/graphs/colimits.v](CategoryTheory/limits/graphs/colimits.v) - [limits/graphs/limits.v](CategoryTheory/limits/graphs/limits.v) - [limits/graphs/eqdiag.v](CategoryTheory/limits/graphs/eqdiag.v) - [limits/coproducts.v](CategoryTheory/limits/coproducts.v) - [limits/products.v](CategoryTheory/limits/products.v) - [limits/initial.v](CategoryTheory/limits/initial.v) - [limits/terminal.v](CategoryTheory/limits/terminal.v) - [limits/zero.v](CategoryTheory/limits/zero.v) - [limits/bincoproducts.v](CategoryTheory/limits/bincoproducts.v) - [limits/binproducts.v](CategoryTheory/limits/binproducts.v) - [limits/graphs/bincoproducts.v](CategoryTheory/limits/graphs/bincoproducts.v) - [limits/graphs/binproducts.v](CategoryTheory/limits/graphs/binproducts.v) - [limits/pullbacks.v](CategoryTheory/limits/pullbacks.v) - [limits/graphs/initial.v](CategoryTheory/limits/graphs/initial.v) - [limits/graphs/terminal.v](CategoryTheory/limits/graphs/terminal.v) - [limits/graphs/zero.v](CategoryTheory/limits/graphs/zero.v) - [limits/graphs/pullbacks.v](CategoryTheory/limits/graphs/pullbacks.v) - [limits/coequalizers.v](CategoryTheory/limits/coequalizers.v) - [limits/kernels.v](CategoryTheory/limits/kernels.v) - [limits/cokernels.v](CategoryTheory/limits/cokernels.v) - [PreAdditive.v](CategoryTheory/PreAdditive.v) - [limits/pushouts.v](CategoryTheory/limits/pushouts.v) - [limits/graphs/pushouts.v](CategoryTheory/limits/graphs/pushouts.v) - [limits/graphs/equalizers.v](CategoryTheory/limits/graphs/equalizers.v) - [limits/graphs/coequalizers.v](CategoryTheory/limits/graphs/coequalizers.v) - [limits/graphs/kernels.v](CategoryTheory/limits/graphs/kernels.v) - [limits/graphs/cokernels.v](CategoryTheory/limits/graphs/cokernels.v) - [limits/cats/limits.v](CategoryTheory/limits/cats/limits.v) - [limits/BinDirectSums.v](CategoryTheory/limits/BinDirectSums.v) - [limits/FinOrdProducts.v](CategoryTheory/limits/FinOrdProducts.v) - [limits/FinOrdCoproducts.v](CategoryTheory/limits/FinOrdCoproducts.v) - [limits/Opp.v](CategoryTheory/limits/Opp.v) - [limits/Preservation.v](CategoryTheory/limits/Preservation.v) - [limits/Ends.v](CategoryTheory/limits/Ends.v) - [DisplayedCats/Binproducts.v](CategoryTheory/DisplayedCats/Binproducts.v) - [limits/Examples/CategoryProductLimits.v](CategoryTheory/limits/Examples/CategoryProductLimits.v) - [limits/Examples/CategoryOfSetcategoriesLimits.v](CategoryTheory/limits/Examples/CategoryOfSetcategoriesLimits.v) - [limits/StandardDiagrams.v](CategoryTheory/limits/StandardDiagrams.v) - [limits/Filtered.v](CategoryTheory/limits/Filtered.v) - [IsoCommaCategory.v](CategoryTheory/IsoCommaCategory.v) - [limits/Examples/IsoCommaLimits.v](CategoryTheory/limits/Examples/IsoCommaLimits.v) - [CommaCategories.v](CategoryTheory/CommaCategories.v) - [NNO.v](CategoryTheory/NNO.v) - [Subcategory/Limits.v](CategoryTheory/Subcategory/Limits.v) - [EpiFacts.v](CategoryTheory/EpiFacts.v) - [categories/Type/Core.v](CategoryTheory/categories/Type/Core.v) - [categories/Type/MonoEpiIso.v](CategoryTheory/categories/Type/MonoEpiIso.v) - [SimplicialSets.v](CategoryTheory/SimplicialSets.v) - [yoneda.v](CategoryTheory/yoneda.v) - [FunctorCoalgebras.v](CategoryTheory/FunctorCoalgebras.v) - [precomp_fully_faithful.v](CategoryTheory/precomp_fully_faithful.v) - [precomp_ess_surj.v](CategoryTheory/precomp_ess_surj.v) - [PrecompEquivalence.v](CategoryTheory/PrecompEquivalence.v) - [UnitorsAndAssociatorsForEndofunctors.v](CategoryTheory/UnitorsAndAssociatorsForEndofunctors.v) - [PointedFunctors.v](CategoryTheory/PointedFunctors.v) - [HorizontalComposition.v](CategoryTheory/HorizontalComposition.v) - [PointedFunctorsComposition.v](CategoryTheory/PointedFunctorsComposition.v) - [ArrowCategory.v](CategoryTheory/ArrowCategory.v) - [RightKanExtension.v](CategoryTheory/RightKanExtension.v) - [coslicecat.v](CategoryTheory/coslicecat.v) - [catiso.v](CategoryTheory/catiso.v) - [DisplayedCats/CatIsoDisplayed.v](CategoryTheory/DisplayedCats/CatIsoDisplayed.v) - [CategoryEquality.v](CategoryTheory/CategoryEquality.v) - [WeakEquivalences.v](CategoryTheory/WeakEquivalences.v) - [rezk_completion.v](CategoryTheory/rezk_completion.v) - [RezkCompletion.v](CategoryTheory/RezkCompletion.v) - [exponentials.v](CategoryTheory/exponentials.v) - [slicecat.v](CategoryTheory/slicecat.v) - [limits/pullbacks_slice_products_equiv.v](CategoryTheory/limits/pullbacks_slice_products_equiv.v) - [Additive.v](CategoryTheory/Additive.v) - [Abelian.v](CategoryTheory/Abelian.v) - [category_binops.v](CategoryTheory/category_binops.v) - [AbelianToAdditive.v](CategoryTheory/AbelianToAdditive.v) - [Morphisms.v](CategoryTheory/Morphisms.v) - [ExactCategories/ExactCategories.v](CategoryTheory/ExactCategories/ExactCategories.v) - [ExactCategories/Tests.v](CategoryTheory/ExactCategories/Tests.v) - [ShortExactSequences.v](CategoryTheory/ShortExactSequences.v) - [AdditiveFunctors.v](CategoryTheory/AdditiveFunctors.v) - [LocalizingClass.v](CategoryTheory/LocalizingClass.v) - [UnderCategories.v](CategoryTheory/UnderCategories.v) - [Subobjects.v](CategoryTheory/Subobjects.v) - [SubobjectClassifier.v](CategoryTheory/SubobjectClassifier.v) - [Quotobjects.v](CategoryTheory/Quotobjects.v) - [AbelianPushoutPullback.v](CategoryTheory/AbelianPushoutPullback.v) - [PseudoElements.v](CategoryTheory/PseudoElements.v) - [FiveLemma.v](CategoryTheory/FiveLemma.v) - [LatticeObject.v](CategoryTheory/LatticeObject.v) - [Actions.v](CategoryTheory/Actions.v) - [PowerObject.v](CategoryTheory/PowerObject.v) - [ElementaryTopos.v](CategoryTheory/ElementaryTopos.v) - [Adjunctions/Restriction.v](CategoryTheory/Adjunctions/Restriction.v) - [Adjunctions/Examples.v](CategoryTheory/Adjunctions/Examples.v) - [Subcategory/Reflective.v](CategoryTheory/Subcategory/Reflective.v) - [categories/setwith2binops.v](CategoryTheory/categories/setwith2binops.v) - [categories/monoids.v](CategoryTheory/categories/monoids.v) - [categories/abmonoids.v](CategoryTheory/categories/abmonoids.v) - [categories/grs.v](CategoryTheory/categories/grs.v) - [categories/abgrs.v](CategoryTheory/categories/abgrs.v) - [categories/rigs.v](CategoryTheory/categories/rigs.v) - [categories/commrigs.v](CategoryTheory/categories/commrigs.v) - [categories/rings.v](CategoryTheory/categories/rings.v) - [categories/commrings.v](CategoryTheory/categories/commrings.v) - [categories/intdoms.v](CategoryTheory/categories/intdoms.v) - [categories/flds.v](CategoryTheory/categories/flds.v) - [categories/modules.v](CategoryTheory/categories/modules.v) - [categories/StandardCategories.v](CategoryTheory/categories/StandardCategories.v) - [categories/preorder_categories.v](CategoryTheory/categories/preorder_categories.v) - [limits/Examples/UnitCategoryLimits.v](CategoryTheory/limits/Examples/UnitCategoryLimits.v) - [categories/Type/Colimits.v](CategoryTheory/categories/Type/Colimits.v) - [categories/Type/Limits.v](CategoryTheory/categories/Type/Limits.v) - [categories/Type/Structures.v](CategoryTheory/categories/Type/Structures.v) - [categories/Type/Univalence.v](CategoryTheory/categories/Type/Univalence.v) - [categories/HSET/Limits.v](CategoryTheory/categories/HSET/Limits.v) - [categories/HSET/Colimits.v](CategoryTheory/categories/HSET/Colimits.v) - [categories/HSET/FilteredColimits.v](CategoryTheory/categories/HSET/FilteredColimits.v) - [categories/HSET/Slice.v](CategoryTheory/categories/HSET/Slice.v) - [categories/HSET/Structures.v](CategoryTheory/categories/HSET/Structures.v) - [categories/HSET/SliceFamEquiv.v](CategoryTheory/categories/HSET/SliceFamEquiv.v) - [categories/HSET/All.v](CategoryTheory/categories/HSET/All.v) - [SetValuedFunctors.v](CategoryTheory/SetValuedFunctors.v) - [categories/FinSet.v](CategoryTheory/categories/FinSet.v) - [categories/wosets.v](CategoryTheory/categories/wosets.v) - [categories/Graph.v](CategoryTheory/categories/Graph.v) - [categories/CGraph.v](CategoryTheory/categories/CGraph.v) - [GrothendieckTopos.v](CategoryTheory/GrothendieckTopos.v) - [Presheaf.v](CategoryTheory/Presheaf.v) - [ElementsOp.v](CategoryTheory/ElementsOp.v) - [elems_slice_equiv.v](CategoryTheory/elems_slice_equiv.v) - [YonedaBinproducts.v](CategoryTheory/YonedaBinproducts.v) - [ExponentiationLeftAdjoint.v](CategoryTheory/ExponentiationLeftAdjoint.v) - [Connected.v](CategoryTheory/Connected.v) - [LeftKanExtension.v](CategoryTheory/LeftKanExtension.v) - [categories/CartesianCubicalSets.v](CategoryTheory/categories/CartesianCubicalSets.v) - [OppositeCategory/OppositeAdjunction.v](CategoryTheory/OppositeCategory/OppositeAdjunction.v) - [OppositeCategory/OppositeOfFunctorCategory.v](CategoryTheory/OppositeCategory/OppositeOfFunctorCategory.v) - [Chains/Chains.v](CategoryTheory/Chains/Chains.v) - [Chains/Cochains.v](CategoryTheory/Chains/Cochains.v) - [DisplayedCats/Examples/Opposite.v](CategoryTheory/DisplayedCats/Examples/Opposite.v) - [DisplayedCats/Fibrations.v](CategoryTheory/DisplayedCats/Fibrations.v) - [DisplayedCats/Examples/Reindexing.v](CategoryTheory/DisplayedCats/Examples/Reindexing.v) - [DisplayedCats/Constructions.v](CategoryTheory/DisplayedCats/Constructions.v) - [DisplayedCats/Examples/Sigma.v](CategoryTheory/DisplayedCats/Examples/Sigma.v) - [FunctorAlgebras.v](CategoryTheory/FunctorAlgebras.v) - [CompletelyIterativeAlgebras.v](CategoryTheory/CompletelyIterativeAlgebras.v) - [Chains/Adamek.v](CategoryTheory/Chains/Adamek.v) - [Chains/CoAdamek.v](CategoryTheory/Chains/CoAdamek.v) - [Chains/OmegaCocontFunctors.v](CategoryTheory/Chains/OmegaCocontFunctors.v) - [OppositeCategory/LimitsAsColimits.v](CategoryTheory/OppositeCategory/LimitsAsColimits.v) - [Chains/OmegaContFunctors.v](CategoryTheory/Chains/OmegaContFunctors.v) - [Chains/All.v](CategoryTheory/Chains/All.v) - [Inductives/Lists.v](CategoryTheory/Inductives/Lists.v) - [Inductives/Trees.v](CategoryTheory/Inductives/Trees.v) - [Inductives/LambdaCalculus.v](CategoryTheory/Inductives/LambdaCalculus.v) - [Inductives/PropositionalLogic.v](CategoryTheory/Inductives/PropositionalLogic.v) - [CategoricalRecursionSchemes.v](CategoryTheory/CategoricalRecursionSchemes.v) - [DisplayedCats/Equivalences.v](CategoryTheory/DisplayedCats/Equivalences.v) - [DisplayedCats/EquivalenceOverId.v](CategoryTheory/DisplayedCats/EquivalenceOverId.v) - [DisplayedCats/DisplayedCatEq.v](CategoryTheory/DisplayedCats/DisplayedCatEq.v) - [DisplayedCats/Codomain.v](CategoryTheory/DisplayedCats/Codomain.v) - [DisplayedCats/Projection.v](CategoryTheory/DisplayedCats/Projection.v) - [DisplayedCats/SIP.v](CategoryTheory/DisplayedCats/SIP.v) - [Monads/Monads.v](CategoryTheory/Monads/Monads.v) - [Monads/LModules.v](CategoryTheory/Monads/LModules.v) - [Monads/Derivative.v](CategoryTheory/Monads/Derivative.v) - [Monads/MonadAlgebras.v](CategoryTheory/Monads/MonadAlgebras.v) - [Monads/Comonads.v](CategoryTheory/Monads/Comonads.v) - [DisplayedCats/Limits.v](CategoryTheory/DisplayedCats/Limits.v) - [DisplayedCats/Examples.v](CategoryTheory/DisplayedCats/Examples.v) - [DisplayedCats/Examples/UnitalBinop.v](CategoryTheory/DisplayedCats/Examples/UnitalBinop.v) - [DisplayedCats/Examples/CategoryOfPosets.v](CategoryTheory/DisplayedCats/Examples/CategoryOfPosets.v) - [DisplayedCats/Structures/CartesianStructure.v](CategoryTheory/DisplayedCats/Structures/CartesianStructure.v) - [DisplayedCats/Structures/StructureLimitsAndColimits.v](CategoryTheory/DisplayedCats/Structures/StructureLimitsAndColimits.v) - [DisplayedCats/Structures/StructuresSmashProduct.v](CategoryTheory/DisplayedCats/Structures/StructuresSmashProduct.v) - [DisplayedCats/Examples/AlgebraStructures.v](CategoryTheory/DisplayedCats/Examples/AlgebraStructures.v) - [DisplayedCats/Examples/DCPOStructures.v](CategoryTheory/DisplayedCats/Examples/DCPOStructures.v) - [DisplayedCats/Examples/PointedDCPOStructures.v](CategoryTheory/DisplayedCats/Examples/PointedDCPOStructures.v) - [DisplayedCats/Examples/PointedDCPOStrict.v](CategoryTheory/DisplayedCats/Examples/PointedDCPOStrict.v) - [DisplayedCats/Examples/PointedPosetStrict.v](CategoryTheory/DisplayedCats/Examples/PointedPosetStrict.v) - [DisplayedCats/Examples/PointedPosetStructures.v](CategoryTheory/DisplayedCats/Examples/PointedPosetStructures.v) - [DisplayedCats/Examples/PointedSetStructures.v](CategoryTheory/DisplayedCats/Examples/PointedSetStructures.v) - [DisplayedCats/Examples/PosetStructures.v](CategoryTheory/DisplayedCats/Examples/PosetStructures.v) - [DisplayedCats/Examples/SetStructures.v](CategoryTheory/DisplayedCats/Examples/SetStructures.v) - [DisplayedCats/FunctorCategory.v](CategoryTheory/DisplayedCats/FunctorCategory.v) - [DisplayedCats/Adjunctions.v](CategoryTheory/DisplayedCats/Adjunctions.v) - [DisplayedCats/ComprehensionC.v](CategoryTheory/DisplayedCats/ComprehensionC.v) - [DisplayedCats/StreetFibration.v](CategoryTheory/DisplayedCats/StreetFibration.v) - [DisplayedCats/StreetOpFibration.v](CategoryTheory/DisplayedCats/StreetOpFibration.v) - [DisplayedCats/ReindexingForward.v](CategoryTheory/DisplayedCats/ReindexingForward.v) - [DisplayedCats/TotalCategoryFacts.v](CategoryTheory/DisplayedCats/TotalCategoryFacts.v) - [DisplayedCats/TotalAdjunction.v](CategoryTheory/DisplayedCats/TotalAdjunction.v) - [Monads/KleisliCategory.v](CategoryTheory/Monads/KleisliCategory.v) - [Monads/KTriples.v](CategoryTheory/Monads/KTriples.v) - [Monads/Kleisli.v](CategoryTheory/Monads/Kleisli.v) - [Monads/KTriplesEquiv.v](CategoryTheory/Monads/KTriplesEquiv.v) - [limits/Examples/AlgebraStructuresColimits.v](CategoryTheory/limits/Examples/AlgebraStructuresColimits.v) - [categories/Dialgebras.v](CategoryTheory/categories/Dialgebras.v) - [categories/CatIsoInserter.v](CategoryTheory/categories/CatIsoInserter.v) - [categories/EilenbergMoore.v](CategoryTheory/categories/EilenbergMoore.v) - [categories/CoEilenbergMoore.v](CategoryTheory/categories/CoEilenbergMoore.v) - [categories/KleisliCategory.v](CategoryTheory/categories/KleisliCategory.v) - [limits/Examples/EilenbergMooreLimits.v](CategoryTheory/limits/Examples/EilenbergMooreLimits.v) - [Elements.v](CategoryTheory/Elements.v) - [Core.v](CategoryTheory/Core.v) - [categories/Universal_Algebra/Algebras.v](CategoryTheory/categories/Universal_Algebra/Algebras.v) - [categories/Universal_Algebra/EqAlgebras.v](CategoryTheory/categories/Universal_Algebra/EqAlgebras.v) - [categories/Relations.v](CategoryTheory/categories/Relations.v) - [Monoidal/WhiskeredBifunctors.v](CategoryTheory/Monoidal/WhiskeredBifunctors.v) - [Monoidal/Categories.v](CategoryTheory/Monoidal/Categories.v) - [Monoidal/StrongMonad.v](CategoryTheory/Monoidal/StrongMonad.v) - [Monoidal/Structure/Symmetric.v](CategoryTheory/Monoidal/Structure/Symmetric.v) - [Monoidal/Structure/SymmetricDiagonal.v](CategoryTheory/Monoidal/Structure/SymmetricDiagonal.v) - [Monoidal/Structure/Closed.v](CategoryTheory/Monoidal/Structure/Closed.v) - [Monoidal/Structure/Cartesian.v](CategoryTheory/Monoidal/Structure/Cartesian.v) - [Monoidal/Functors.v](CategoryTheory/Monoidal/Functors.v) - [Monoidal/FunctorCategories.v](CategoryTheory/Monoidal/FunctorCategories.v) - [Monoidal/Adjunctions.v](CategoryTheory/Monoidal/Adjunctions.v) - [Monoidal/CategoriesOfMonoids.v](CategoryTheory/Monoidal/CategoriesOfMonoids.v) - [Monoidal/Displayed/WhiskeredDisplayedBifunctors.v](CategoryTheory/Monoidal/Displayed/WhiskeredDisplayedBifunctors.v) - [Monoidal/Displayed/Monoidal.v](CategoryTheory/Monoidal/Displayed/Monoidal.v) - [Monoidal/Displayed/TotalMonoidal.v](CategoryTheory/Monoidal/Displayed/TotalMonoidal.v) - [Monoidal/Displayed/MonoidalSections.v](CategoryTheory/Monoidal/Displayed/MonoidalSections.v) - [Monoidal/Displayed/TransportLemmas.v](CategoryTheory/Monoidal/Displayed/TransportLemmas.v) - [Monoidal/Displayed/Symmetric.v](CategoryTheory/Monoidal/Displayed/Symmetric.v) - [Monoidal/Displayed/SymmetricMonoidalBuilder.v](CategoryTheory/Monoidal/Displayed/SymmetricMonoidalBuilder.v) - [Monoidal/Examples/SetCartesianMonoidal.v](CategoryTheory/Monoidal/Examples/SetCartesianMonoidal.v) - [Monoidal/Examples/CartesianMonoidal.v](CategoryTheory/Monoidal/Examples/CartesianMonoidal.v) - [Monoidal/Examples/DisplayedCartesianMonoidal.v](CategoryTheory/Monoidal/Examples/DisplayedCartesianMonoidal.v) - [Monoidal/Examples/StructuresMonoidal.v](CategoryTheory/Monoidal/Examples/StructuresMonoidal.v) - [Monoidal/Examples/EndofunctorsMonoidalElementary.v](CategoryTheory/Monoidal/Examples/EndofunctorsMonoidalElementary.v) - [Monoidal/Examples/MonadsAsMonoidsElementary.v](CategoryTheory/Monoidal/Examples/MonadsAsMonoidsElementary.v) - [Monoidal/Examples/MonoidalPointedObjects.v](CategoryTheory/Monoidal/Examples/MonoidalPointedObjects.v) - [Monoidal/Displayed/MonoidalFunctorLifting.v](CategoryTheory/Monoidal/Displayed/MonoidalFunctorLifting.v) - [Monoidal/Examples/MonoidalDialgebras.v](CategoryTheory/Monoidal/Examples/MonoidalDialgebras.v) - [Monoidal/Examples/SymmetricMonoidalDialgebras.v](CategoryTheory/Monoidal/Examples/SymmetricMonoidalDialgebras.v) - [Monoidal/Examples/PointedSetCartesianMonoidal.v](CategoryTheory/Monoidal/Examples/PointedSetCartesianMonoidal.v) - [Monoidal/Examples/BinopCartesianMonoidal.v](CategoryTheory/Monoidal/Examples/BinopCartesianMonoidal.v) - [Monoidal/Examples/SetWithSubset.v](CategoryTheory/Monoidal/Examples/SetWithSubset.v) - [Monoidal/Examples/SmashProductMonoidal.v](CategoryTheory/Monoidal/Examples/SmashProductMonoidal.v) - [Monoidal/Examples/PosetsMonoidal.v](CategoryTheory/Monoidal/Examples/PosetsMonoidal.v) - [Monoidal/Examples/Fullsub.v](CategoryTheory/Monoidal/Examples/Fullsub.v) - [Monoidal/Examples/Relations.v](CategoryTheory/Monoidal/Examples/Relations.v) - [Monoidal/Examples/Sigma.v](CategoryTheory/Monoidal/Examples/Sigma.v) - [Monoidal/Examples/DiagonalFunctor.v](CategoryTheory/Monoidal/Examples/DiagonalFunctor.v) - [Monoidal/Examples/ConstantFunctor.v](CategoryTheory/Monoidal/Examples/ConstantFunctor.v) - [Monoidal/Comonoids/Category.v](CategoryTheory/Monoidal/Comonoids/Category.v) - [Monoidal/Comonoids/Tensor.v](CategoryTheory/Monoidal/Comonoids/Tensor.v) - [Monoidal/Comonoids/Monoidal.v](CategoryTheory/Monoidal/Comonoids/Monoidal.v) - [Monoidal/Comonoids/Symmetric.v](CategoryTheory/Monoidal/Comonoids/Symmetric.v) - [Monoidal/Comonoids/MonoidalCartesianBuilder.v](CategoryTheory/Monoidal/Comonoids/MonoidalCartesianBuilder.v) - [Monoidal/Comonoids/CommComonoidsCartesian.v](CategoryTheory/Monoidal/Comonoids/CommComonoidsCartesian.v) - [Monoidal/Comonoids/CartesianAsComonoids.v](CategoryTheory/Monoidal/Comonoids/CartesianAsComonoids.v) - [Monoidal/Comonoids/TransportComonoidAlongRetraction.v](CategoryTheory/Monoidal/Comonoids/TransportComonoidAlongRetraction.v) - [Monoidal/Examples/LiftPoset.v](CategoryTheory/Monoidal/Examples/LiftPoset.v) - [Monoidal/Examples/SymmetricMonoidalCoEilenbergMoore.v](CategoryTheory/Monoidal/Examples/SymmetricMonoidalCoEilenbergMoore.v) - [Monoidal/AlternativeDefinitions/MonoidalCategoriesReordered.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalCategoriesReordered.v) - [Monoidal/AlternativeDefinitions/MonoidalCategoriesTensored.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalCategoriesTensored.v) - [Monoidal/AlternativeDefinitions/EquivalenceWhiskeredNonCurriedMonoidalCategories.v](CategoryTheory/Monoidal/AlternativeDefinitions/EquivalenceWhiskeredNonCurriedMonoidalCategories.v) - [Monoidal/AlternativeDefinitions/MonoidalCategoriesCurried.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalCategoriesCurried.v) - [Monoidal/AlternativeDefinitions/MonoidalFunctorsTensored.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorsTensored.v) - [Monoidal/AlternativeDefinitions/MonoidalFunctorsCurried.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorsCurried.v) - [Monoidal/AlternativeDefinitions/AugmentedSimplexCategory.v](CategoryTheory/Monoidal/AlternativeDefinitions/AugmentedSimplexCategory.v) - [Monoidal/AlternativeDefinitions/DisplayedMonoidalTensored.v](CategoryTheory/Monoidal/AlternativeDefinitions/DisplayedMonoidalTensored.v) - [Monoidal/AlternativeDefinitions/DisplayedMonoidalCurried.v](CategoryTheory/Monoidal/AlternativeDefinitions/DisplayedMonoidalCurried.v) - [Monoidal/AlternativeDefinitions/CategoriesOfMonoids.v](CategoryTheory/Monoidal/AlternativeDefinitions/CategoriesOfMonoids.v) - [Monoidal/AlternativeDefinitions/BraidedMonoidalCategories.v](CategoryTheory/Monoidal/AlternativeDefinitions/BraidedMonoidalCategories.v) - [Monoidal/AlternativeDefinitions/TotalDisplayedMonoidalCurried.v](CategoryTheory/Monoidal/AlternativeDefinitions/TotalDisplayedMonoidalCurried.v) - [Monoidal/AlternativeDefinitions/MonoidalFunctorCategory.v](CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorCategory.v) - [Actegories/Actegories.v](CategoryTheory/Actegories/Actegories.v) - [Actegories/ConstructionOfActegories.v](CategoryTheory/Actegories/ConstructionOfActegories.v) - [Actegories/MorphismsOfActegories.v](CategoryTheory/Actegories/MorphismsOfActegories.v) - [Actegories/ProductActegory.v](CategoryTheory/Actegories/ProductActegory.v) - [Actegories/ProductsInActegories.v](CategoryTheory/Actegories/ProductsInActegories.v) - [Actegories/CoproductsInActegories.v](CategoryTheory/Actegories/CoproductsInActegories.v) - [Actegories/Examples/ActionOfEndomorphismsInCATElementary.v](CategoryTheory/Actegories/Examples/ActionOfEndomorphismsInCATElementary.v) - [Actegories/Examples/SelfActionInCATElementary.v](CategoryTheory/Actegories/Examples/SelfActionInCATElementary.v) - [Actegories/ConstructionOfActegoryMorphisms.v](CategoryTheory/Actegories/ConstructionOfActegoryMorphisms.v) - [Actegories/ActionBasedStrongMonads.v](CategoryTheory/Actegories/ActionBasedStrongMonads.v) - [DisplayedCats/MoreFibrations/Prefibrations.v](CategoryTheory/DisplayedCats/MoreFibrations/Prefibrations.v) - [DisplayedCats/MoreFibrations/CartesiannessOfComposites.v](CategoryTheory/DisplayedCats/MoreFibrations/CartesiannessOfComposites.v) - [DisplayedCats/MoreFibrations/FibrationsCharacterisation.v](CategoryTheory/DisplayedCats/MoreFibrations/FibrationsCharacterisation.v) - [DisplayedCats/MoreFibrations/DispCatsEquivFunctors.v](CategoryTheory/DisplayedCats/MoreFibrations/DispCatsEquivFunctors.v) - [DisplayedCats/MoreFibrations/DisplayedDisplayedCats.v](CategoryTheory/DisplayedCats/MoreFibrations/DisplayedDisplayedCats.v) - [SkewMonoidal/SkewMonoidalCategories.v](CategoryTheory/SkewMonoidal/SkewMonoidalCategories.v) - [SkewMonoidal/CategoriesOfMonoids.v](CategoryTheory/SkewMonoidal/CategoriesOfMonoids.v) - [EnrichedCats/Enrichment.v](CategoryTheory/EnrichedCats/Enrichment.v) - [EnrichedCats/EnrichmentFunctor.v](CategoryTheory/EnrichedCats/EnrichmentFunctor.v) - [EnrichedCats/EnrichmentTransformation.v](CategoryTheory/EnrichedCats/EnrichmentTransformation.v) - [EnrichedCats/FullyFaithful.v](CategoryTheory/EnrichedCats/FullyFaithful.v) - [EnrichedCats/EnrichmentAdjunction.v](CategoryTheory/EnrichedCats/EnrichmentAdjunction.v) - [EnrichedCats/EnrichmentMonad.v](CategoryTheory/EnrichedCats/EnrichmentMonad.v) - [EnrichedCats/Enriched/Enriched.v](CategoryTheory/EnrichedCats/Enriched/Enriched.v) - [EnrichedCats/Enriched/ChangeOfBase.v](CategoryTheory/EnrichedCats/Enriched/ChangeOfBase.v) - [EnrichedCats/Enriched/Opposite.v](CategoryTheory/EnrichedCats/Enriched/Opposite.v) - [EnrichedCats/Enriched/UnderlyingCategory.v](CategoryTheory/EnrichedCats/Enriched/UnderlyingCategory.v) - [EnrichedCats/Enriched/EnrichmentEquiv.v](CategoryTheory/EnrichedCats/Enriched/EnrichmentEquiv.v) - [EnrichedCats/Examples/SelfEnriched.v](CategoryTheory/EnrichedCats/Examples/SelfEnriched.v) - [EnrichedCats/Limits/EnrichedTerminal.v](CategoryTheory/EnrichedCats/Limits/EnrichedTerminal.v) - [EnrichedCats/Limits/EnrichedBinaryProducts.v](CategoryTheory/EnrichedCats/Limits/EnrichedBinaryProducts.v) - [EnrichedCats/Limits/EnrichedProducts.v](CategoryTheory/EnrichedCats/Limits/EnrichedProducts.v) - [EnrichedCats/Limits/EnrichedEqualizers.v](CategoryTheory/EnrichedCats/Limits/EnrichedEqualizers.v) - [EnrichedCats/Limits/EnrichedConicalLimits.v](CategoryTheory/EnrichedCats/Limits/EnrichedConicalLimits.v) - [EnrichedCats/Limits/EnrichedPowers.v](CategoryTheory/EnrichedCats/Limits/EnrichedPowers.v) - [EnrichedCats/Limits/EnrichedLimits.v](CategoryTheory/EnrichedCats/Limits/EnrichedLimits.v) - [EnrichedCats/Colimits/EnrichedInitial.v](CategoryTheory/EnrichedCats/Colimits/EnrichedInitial.v) - [EnrichedCats/Colimits/EnrichedBinaryCoproducts.v](CategoryTheory/EnrichedCats/Colimits/EnrichedBinaryCoproducts.v) - [EnrichedCats/Colimits/EnrichedCoproducts.v](CategoryTheory/EnrichedCats/Colimits/EnrichedCoproducts.v) - [EnrichedCats/Colimits/EnrichedCoequalizers.v](CategoryTheory/EnrichedCats/Colimits/EnrichedCoequalizers.v) - [EnrichedCats/Colimits/EnrichedConicalColimits.v](CategoryTheory/EnrichedCats/Colimits/EnrichedConicalColimits.v) - [EnrichedCats/Colimits/EnrichedCopowers.v](CategoryTheory/EnrichedCats/Colimits/EnrichedCopowers.v) - [EnrichedCats/Colimits/EnrichedColimits.v](CategoryTheory/EnrichedCats/Colimits/EnrichedColimits.v) - [EnrichedCats/Colimits/CopowerFunctor.v](CategoryTheory/EnrichedCats/Colimits/CopowerFunctor.v) - [EnrichedCats/Examples/SetEnriched.v](CategoryTheory/EnrichedCats/Examples/SetEnriched.v) - [EnrichedCats/Examples/PosetEnriched.v](CategoryTheory/EnrichedCats/Examples/PosetEnriched.v) - [EnrichedCats/Examples/StructureEnriched.v](CategoryTheory/EnrichedCats/Examples/StructureEnriched.v) - [EnrichedCats/Examples/SmashStructureEnriched.v](CategoryTheory/EnrichedCats/Examples/SmashStructureEnriched.v) - [EnrichedCats/Examples/HomFunctor.v](CategoryTheory/EnrichedCats/Examples/HomFunctor.v) - [EnrichedCats/Examples/OppositeEnriched.v](CategoryTheory/EnrichedCats/Examples/OppositeEnriched.v) - [EnrichedCats/Examples/FunctorCategory.v](CategoryTheory/EnrichedCats/Examples/FunctorCategory.v) - [EnrichedCats/Examples/Yoneda.v](CategoryTheory/EnrichedCats/Examples/Yoneda.v) - [EnrichedCats/YonedaLemma.v](CategoryTheory/EnrichedCats/YonedaLemma.v) - [EnrichedCats/Examples/EmptyEnriched.v](CategoryTheory/EnrichedCats/Examples/EmptyEnriched.v) - [EnrichedCats/Examples/UnitEnriched.v](CategoryTheory/EnrichedCats/Examples/UnitEnriched.v) - [EnrichedCats/Examples/FullSubEnriched.v](CategoryTheory/EnrichedCats/Examples/FullSubEnriched.v) - [EnrichedCats/Examples/ImageEnriched.v](CategoryTheory/EnrichedCats/Examples/ImageEnriched.v) - [EnrichedCats/Examples/DialgebraEnriched.v](CategoryTheory/EnrichedCats/Examples/DialgebraEnriched.v) - [EnrichedCats/Examples/SliceEnriched.v](CategoryTheory/EnrichedCats/Examples/SliceEnriched.v) - [EnrichedCats/Examples/EilenbergMooreEnriched.v](CategoryTheory/EnrichedCats/Examples/EilenbergMooreEnriched.v) - [EnrichedCats/Examples/ProductEnriched.v](CategoryTheory/EnrichedCats/Examples/ProductEnriched.v) - [EnrichedCats/Examples/ChangeOfBase.v](CategoryTheory/EnrichedCats/Examples/ChangeOfBase.v) - [EnrichedCats/EnrichedRezkCompletion.v](CategoryTheory/EnrichedCats/EnrichedRezkCompletion.v) - [EnrichedCats/Examples/KleisliEnriched.v](CategoryTheory/EnrichedCats/Examples/KleisliEnriched.v) - [EnrichedCats/Examples/UnivalentKleisliEnriched.v](CategoryTheory/EnrichedCats/Examples/UnivalentKleisliEnriched.v) - [EnrichedCats/Limits/Examples/OppositeEnrichedLimits.v](CategoryTheory/EnrichedCats/Limits/Examples/OppositeEnrichedLimits.v) - [EnrichedCats/Limits/Examples/PosetEnrichedLimits.v](CategoryTheory/EnrichedCats/Limits/Examples/PosetEnrichedLimits.v) - [EnrichedCats/Limits/Examples/StructureEnrichedLimits.v](CategoryTheory/EnrichedCats/Limits/Examples/StructureEnrichedLimits.v) - [EnrichedCats/Limits/Examples/SelfEnrichedLimits.v](CategoryTheory/EnrichedCats/Limits/Examples/SelfEnrichedLimits.v) - [EnrichedCats/Colimits/Examples/OppositeEnrichedColimits.v](CategoryTheory/EnrichedCats/Colimits/Examples/OppositeEnrichedColimits.v) - [EnrichedCats/Colimits/Examples/PosetEnrichedColimits.v](CategoryTheory/EnrichedCats/Colimits/Examples/PosetEnrichedColimits.v) - [EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v](CategoryTheory/EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v) - [EnrichedCats/Colimits/Examples/SelfEnrichedColimits.v](CategoryTheory/EnrichedCats/Colimits/Examples/SelfEnrichedColimits.v) - [GrothendieckConstruction/TotalCategory.v](CategoryTheory/GrothendieckConstruction/TotalCategory.v) - [GrothendieckConstruction/IsosInTotal.v](CategoryTheory/GrothendieckConstruction/IsosInTotal.v) - [GrothendieckConstruction/Projection.v](CategoryTheory/GrothendieckConstruction/Projection.v) - [GrothendieckConstruction/IsOpfibration.v](CategoryTheory/GrothendieckConstruction/IsOpfibration.v) - [GrothendieckConstruction/IsPullback.v](CategoryTheory/GrothendieckConstruction/IsPullback.v) - [TwoSidedDisplayedCats/TwoSidedDispCat.v](CategoryTheory/TwoSidedDisplayedCats/TwoSidedDispCat.v) - [TwoSidedDisplayedCats/Isos.v](CategoryTheory/TwoSidedDisplayedCats/Isos.v) - [TwoSidedDisplayedCats/Univalence.v](CategoryTheory/TwoSidedDisplayedCats/Univalence.v) - [TwoSidedDisplayedCats/Discrete.v](CategoryTheory/TwoSidedDisplayedCats/Discrete.v) - [TwoSidedDisplayedCats/Total.v](CategoryTheory/TwoSidedDisplayedCats/Total.v) - [TwoSidedDisplayedCats/TwoSidedFibration.v](CategoryTheory/TwoSidedDisplayedCats/TwoSidedFibration.v) - [TwoSidedDisplayedCats/Fiber.v](CategoryTheory/TwoSidedDisplayedCats/Fiber.v) - [TwoSidedDisplayedCats/DisplayedFunctor.v](CategoryTheory/TwoSidedDisplayedCats/DisplayedFunctor.v) - [TwoSidedDisplayedCats/DisplayedNatTrans.v](CategoryTheory/TwoSidedDisplayedCats/DisplayedNatTrans.v) - [TwoSidedDisplayedCats/Examples/Constant.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Constant.v) - [TwoSidedDisplayedCats/Examples/DispCatOnTwoSidedDispCat.v](CategoryTheory/TwoSidedDisplayedCats/Examples/DispCatOnTwoSidedDispCat.v) - [TwoSidedDisplayedCats/Examples/FiberwiseProduct.v](CategoryTheory/TwoSidedDisplayedCats/Examples/FiberwiseProduct.v) - [TwoSidedDisplayedCats/Examples/Arrow.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Arrow.v) - [TwoSidedDisplayedCats/Examples/Bimodules.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Bimodules.v) - [TwoSidedDisplayedCats/Examples/Comma.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Comma.v) - [TwoSidedDisplayedCats/Examples/IsoComma.v](CategoryTheory/TwoSidedDisplayedCats/Examples/IsoComma.v) - [TwoSidedDisplayedCats/Examples/Lenses.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Lenses.v) - [TwoSidedDisplayedCats/Examples/Product.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Product.v) - [TwoSidedDisplayedCats/Examples/ProdOfTwosidedDispCat.v](CategoryTheory/TwoSidedDisplayedCats/Examples/ProdOfTwosidedDispCat.v) - [TwoSidedDisplayedCats/Examples/Profunctor.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Profunctor.v) - [TwoSidedDisplayedCats/Examples/Reindex.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Reindex.v) - [TwoSidedDisplayedCats/Examples/Relations.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Relations.v) - [TwoSidedDisplayedCats/Examples/Spans.v](CategoryTheory/TwoSidedDisplayedCats/Examples/Spans.v) - [TwoSidedDisplayedCats/Examples/StructuredCospans.v](CategoryTheory/TwoSidedDisplayedCats/Examples/StructuredCospans.v) - [IndexedCategories/IndexedCategory.v](CategoryTheory/IndexedCategories/IndexedCategory.v) - [IndexedCategories/IndexedFunctor.v](CategoryTheory/IndexedCategories/IndexedFunctor.v) - [IndexedCategories/IndexedTransformation.v](CategoryTheory/IndexedCategories/IndexedTransformation.v) - [IndexedCategories/FibrationToIndexedCategory.v](CategoryTheory/IndexedCategories/FibrationToIndexedCategory.v) - [IndexedCategories/CartesianToIndexedFunctor.v](CategoryTheory/IndexedCategories/CartesianToIndexedFunctor.v) - [IndexedCategories/NatTransToIndexed.v](CategoryTheory/IndexedCategories/NatTransToIndexed.v) - [IndexedCategories/IndexedCategoryToFibration.v](CategoryTheory/IndexedCategories/IndexedCategoryToFibration.v) - [IndexedCategories/IndexedFunctorToCartesian.v](CategoryTheory/IndexedCategories/IndexedFunctorToCartesian.v) - [IndexedCategories/IndexedTransformationToTransformation.v](CategoryTheory/IndexedCategories/IndexedTransformationToTransformation.v) - [IndexedCategories/OpIndexedCategory.v](CategoryTheory/IndexedCategories/OpIndexedCategory.v) - [IndexedCategories/CoreIndexedCategory.v](CategoryTheory/IndexedCategories/CoreIndexedCategory.v) - [RepresentableFunctors/Precategories.v](CategoryTheory/RepresentableFunctors/Precategories.v) - [RepresentableFunctors/Bifunctor.v](CategoryTheory/RepresentableFunctors/Bifunctor.v) - [RepresentableFunctors/Representation.v](CategoryTheory/RepresentableFunctors/Representation.v) - [RepresentableFunctors/RawMatrix.v](CategoryTheory/RepresentableFunctors/RawMatrix.v) - [RepresentableFunctors/DirectSum.v](CategoryTheory/RepresentableFunctors/DirectSum.v) - [RepresentableFunctors/Test.v](CategoryTheory/RepresentableFunctors/Test.v) - [Monoidal/RezkCompletion/LiftedTensor.v](CategoryTheory/Monoidal/RezkCompletion/LiftedTensor.v) - [Monoidal/RezkCompletion/LiftedTensorUnit.v](CategoryTheory/Monoidal/RezkCompletion/LiftedTensorUnit.v) - [Monoidal/RezkCompletion/LiftedUnitors.v](CategoryTheory/Monoidal/RezkCompletion/LiftedUnitors.v) - [Monoidal/RezkCompletion/LiftedAssociator.v](CategoryTheory/Monoidal/RezkCompletion/LiftedAssociator.v) - [Monoidal/RezkCompletion/LiftedMonoidal.v](CategoryTheory/Monoidal/RezkCompletion/LiftedMonoidal.v) - [Monoidal/RezkCompletion/MonoidalRezkCompletion.v](CategoryTheory/Monoidal/RezkCompletion/MonoidalRezkCompletion.v) - [DaggerCategories/Categories.v](CategoryTheory/DaggerCategories/Categories.v) - [DaggerCategories/Unitary.v](CategoryTheory/DaggerCategories/Unitary.v) - [DaggerCategories/Univalence.v](CategoryTheory/DaggerCategories/Univalence.v) - [DaggerCategories/Functors.v](CategoryTheory/DaggerCategories/Functors.v) - [DaggerCategories/Transformations.v](CategoryTheory/DaggerCategories/Transformations.v) - [DaggerCategories/FunctorCategory.v](CategoryTheory/DaggerCategories/FunctorCategory.v) - [DaggerCategories/Examples/Groupoids.v](CategoryTheory/DaggerCategories/Examples/Groupoids.v) - [DaggerCategories/Examples/Relations.v](CategoryTheory/DaggerCategories/Examples/Relations.v) - [DaggerCategories/Examples/Fullsub.v](CategoryTheory/DaggerCategories/Examples/Fullsub.v) - [DaggerCategories/Functors/WeakEquivalences.v](CategoryTheory/DaggerCategories/Functors/WeakEquivalences.v) - [DaggerCategories/Functors/FullyFaithful.v](CategoryTheory/DaggerCategories/Functors/FullyFaithful.v) - [DaggerCategories/Functors/Factorization.v](CategoryTheory/DaggerCategories/Functors/Factorization.v) - [DaggerCategories/Functors/Precomp.v](CategoryTheory/DaggerCategories/Functors/Precomp.v) - [DaggerCategories/CatIso.v](CategoryTheory/DaggerCategories/CatIso.v) - [All.v](CategoryTheory/All.v) ## Package [Bicategories](Bicategories/README.md) - [Core/Bicat.v](Bicategories/Core/Bicat.v) - [Core/Invertible_2cells.v](Bicategories/Core/Invertible_2cells.v) - [Morphisms/Adjunctions.v](Bicategories/Morphisms/Adjunctions.v) - [Morphisms/FullyFaithful.v](Bicategories/Morphisms/FullyFaithful.v) - [Morphisms/DiscreteMorphisms.v](Bicategories/Morphisms/DiscreteMorphisms.v) - [Core/Examples/OpMorBicat.v](Bicategories/Core/Examples/OpMorBicat.v) - [Morphisms/Examples/MorphismsInOp1Bicat.v](Bicategories/Morphisms/Examples/MorphismsInOp1Bicat.v) - [Core/Examples/OpCellBicat.v](Bicategories/Core/Examples/OpCellBicat.v) - [Core/Unitors.v](Bicategories/Core/Unitors.v) - [Core/BicategoryLaws.v](Bicategories/Core/BicategoryLaws.v) - [Core/Univalence.v](Bicategories/Core/Univalence.v) - [Core/TransportLaws.v](Bicategories/Core/TransportLaws.v) - [Core/EquivToAdjequiv.v](Bicategories/Core/EquivToAdjequiv.v) - [Core/AdjointUnique.v](Bicategories/Core/AdjointUnique.v) - [Core/UnivalenceOp.v](Bicategories/Core/UnivalenceOp.v) - [Core/Discreteness.v](Bicategories/Core/Discreteness.v) - [Morphisms/ExtensionsAndLiftings.v](Bicategories/Morphisms/ExtensionsAndLiftings.v) - [Morphisms/InternalStreetFibration.v](Bicategories/Morphisms/InternalStreetFibration.v) - [Morphisms/InternalStreetOpFibration.v](Bicategories/Morphisms/InternalStreetOpFibration.v) - [Morphisms/Properties/ContainsAdjEquiv.v](Bicategories/Morphisms/Properties/ContainsAdjEquiv.v) - [Morphisms/Properties/Composition.v](Bicategories/Morphisms/Properties/Composition.v) - [Morphisms/Properties/ClosedUnderInvertibles.v](Bicategories/Morphisms/Properties/ClosedUnderInvertibles.v) - [Morphisms/Properties.v](Bicategories/Morphisms/Properties.v) - [Core/Examples/DiscreteBicat.v](Bicategories/Core/Examples/DiscreteBicat.v) - [Core/Examples/OneTypes.v](Bicategories/Core/Examples/OneTypes.v) - [Core/Examples/PointedOneTypesBicat.v](Bicategories/Core/Examples/PointedOneTypesBicat.v) - [Core/Examples/TwoType.v](Bicategories/Core/Examples/TwoType.v) - [Core/Examples/BicatOfUnivCats.v](Bicategories/Core/Examples/BicatOfUnivCats.v) - [Core/Examples/BicatOfCats.v](Bicategories/Core/Examples/BicatOfCats.v) - [Core/Strictness.v](Bicategories/Core/Strictness.v) - [Core/Examples/StrictCats.v](Bicategories/Core/Examples/StrictCats.v) - [Core/Examples/Initial.v](Bicategories/Core/Examples/Initial.v) - [Core/Examples/Final.v](Bicategories/Core/Examples/Final.v) - [Core/Examples/BicategoryFromMonoidal.v](Bicategories/Core/Examples/BicategoryFromMonoidal.v) - [Core/Examples/BicategoryFromWhiskeredMonoidal.v](Bicategories/Core/Examples/BicategoryFromWhiskeredMonoidal.v) - [Core/Examples/FibSlice.v](Bicategories/Core/Examples/FibSlice.v) - [Core/Examples/OpFibSlice.v](Bicategories/Core/Examples/OpFibSlice.v) - [Morphisms/Properties/AdjunctionsRepresentable.v](Bicategories/Morphisms/Properties/AdjunctionsRepresentable.v) - [Morphisms/Examples/MorphismsInBicatOfUnivCats.v](Bicategories/Morphisms/Examples/MorphismsInBicatOfUnivCats.v) - [Morphisms/Examples/FibrationsInBicatOfUnivCats.v](Bicategories/Morphisms/Examples/FibrationsInBicatOfUnivCats.v) - [Morphisms/Examples/FibrationsInStrictCats.v](Bicategories/Morphisms/Examples/FibrationsInStrictCats.v) - [Morphisms/Examples/MorphismsInOp2Bicat.v](Bicategories/Morphisms/Examples/MorphismsInOp2Bicat.v) - [DisplayedBicats/DispBicat.v](Bicategories/DisplayedBicats/DispBicat.v) - [DisplayedBicats/DispInvertibles.v](Bicategories/DisplayedBicats/DispInvertibles.v) - [DisplayedBicats/DispAdjunctions.v](Bicategories/DisplayedBicats/DispAdjunctions.v) - [DisplayedBicats/DispUnivalence.v](Bicategories/DisplayedBicats/DispUnivalence.v) - [DisplayedBicats/CleavingOfBicat.v](Bicategories/DisplayedBicats/CleavingOfBicat.v) - [DisplayedBicats/FiberCategory.v](Bicategories/DisplayedBicats/FiberCategory.v) - [DisplayedBicats/FiberBicategory/FiberBicategory1.v](Bicategories/DisplayedBicats/FiberBicategory/FiberBicategory1.v) - [DisplayedBicats/FiberBicategory/FiberBicategory2.v](Bicategories/DisplayedBicats/FiberBicategory/FiberBicategory2.v) - [DisplayedBicats/FiberBicategory.v](Bicategories/DisplayedBicats/FiberBicategory.v) - [DisplayedBicats/Examples/Sigma.v](Bicategories/DisplayedBicats/Examples/Sigma.v) - [DisplayedBicats/Examples/DisplayedCatToBicat.v](Bicategories/DisplayedBicats/Examples/DisplayedCatToBicat.v) - [DisplayedBicats/Examples/FullSub.v](Bicategories/DisplayedBicats/Examples/FullSub.v) - [DisplayedBicats/Examples/Slice.v](Bicategories/DisplayedBicats/Examples/Slice.v) - [DisplayedBicats/Examples/Sub1Cell.v](Bicategories/DisplayedBicats/Examples/Sub1Cell.v) - [DisplayedBicats/Examples/DispBicatOfDispCats.v](Bicategories/DisplayedBicats/Examples/DispBicatOfDispCats.v) - [DisplayedBicats/Examples/Prod.v](Bicategories/DisplayedBicats/Examples/Prod.v) - [DisplayedBicats/Examples/DispDepProd.v](Bicategories/DisplayedBicats/Examples/DispDepProd.v) - [DisplayedBicats/Examples/Trivial.v](Bicategories/DisplayedBicats/Examples/Trivial.v) - [DisplayedBicats/Examples/BicatOfInvertibles.v](Bicategories/DisplayedBicats/Examples/BicatOfInvertibles.v) - [DisplayedBicats/Examples/EndoMap.v](Bicategories/DisplayedBicats/Examples/EndoMap.v) - [Core/Examples/StructuredCategories.v](Bicategories/Core/Examples/StructuredCategories.v) - [DisplayedBicats/Examples/CategoriesWithStructure.v](Bicategories/DisplayedBicats/Examples/CategoriesWithStructure.v) - [MonoidalCategories/MonoidalFromBicategory.v](Bicategories/MonoidalCategories/MonoidalFromBicategory.v) - [MonoidalCategories/EndofunctorsMonoidal.v](Bicategories/MonoidalCategories/EndofunctorsMonoidal.v) - [MonoidalCategories/PointedFunctorsMonoidal.v](Bicategories/MonoidalCategories/PointedFunctorsMonoidal.v) - [MonoidalCategories/Actions.v](Bicategories/MonoidalCategories/Actions.v) - [MonoidalCategories/ConstructionOfActions.v](Bicategories/MonoidalCategories/ConstructionOfActions.v) - [MonoidalCategories/WhiskeredMonoidalFromBicategory.v](Bicategories/MonoidalCategories/WhiskeredMonoidalFromBicategory.v) - [MonoidalCategories/ActionOfEndomorphismsInBicatWhiskered.v](Bicategories/MonoidalCategories/ActionOfEndomorphismsInBicatWhiskered.v) - [MonoidalCategories/BicatOfWhiskeredMonCatsLax.v](Bicategories/MonoidalCategories/BicatOfWhiskeredMonCatsLax.v) - [MonoidalCategories/BicatOfWhiskeredMonCats.v](Bicategories/MonoidalCategories/BicatOfWhiskeredMonCats.v) - [MonoidalCategories/EndofunctorsWhiskeredMonoidal.v](Bicategories/MonoidalCategories/EndofunctorsWhiskeredMonoidal.v) - [MonoidalCategories/PointedFunctorsWhiskeredMonoidal.v](Bicategories/MonoidalCategories/PointedFunctorsWhiskeredMonoidal.v) - [MonoidalCategories/IdempotencePointedFunctorsWhiskeredMonoidal.v](Bicategories/MonoidalCategories/IdempotencePointedFunctorsWhiskeredMonoidal.v) - [MonoidalCategories/ActionBasedStrength.v](Bicategories/MonoidalCategories/ActionBasedStrength.v) - [MonoidalCategories/ActionBasedStrongFunctorsMonoidal.v](Bicategories/MonoidalCategories/ActionBasedStrongFunctorsMonoidal.v) - [MonoidalCategories/ActionOfEndomorphismsInBicat.v](Bicategories/MonoidalCategories/ActionOfEndomorphismsInBicat.v) - [MonoidalCategories/ActionBasedStrongFunctorCategory.v](Bicategories/MonoidalCategories/ActionBasedStrongFunctorCategory.v) - [MonoidalCategories/ActionsFormBicategory.v](Bicategories/MonoidalCategories/ActionsFormBicategory.v) - [MonoidalCategories/ActionBasedStrongFunctorsWhiskeredMonoidal.v](Bicategories/MonoidalCategories/ActionBasedStrongFunctorsWhiskeredMonoidal.v) - [MonoidalCategories/BicatOfActegories.v](Bicategories/MonoidalCategories/BicatOfActegories.v) - [MonoidalCategories/BicatOfActionsInBicat.v](Bicategories/MonoidalCategories/BicatOfActionsInBicat.v) - [MonoidalCategories/UnivalenceMonCat/CurriedMonoidalCategories.v](Bicategories/MonoidalCategories/UnivalenceMonCat/CurriedMonoidalCategories.v) - [MonoidalCategories/UnivalenceMonCat/EquivalenceWhiskeredCurried.v](Bicategories/MonoidalCategories/UnivalenceMonCat/EquivalenceWhiskeredCurried.v) - [MonoidalCategories/UnivalenceMonCat/UnitLayer.v](Bicategories/MonoidalCategories/UnivalenceMonCat/UnitLayer.v) - [MonoidalCategories/UnivalenceMonCat/TensorLayer.v](Bicategories/MonoidalCategories/UnivalenceMonCat/TensorLayer.v) - [MonoidalCategories/UnivalenceMonCat/TensorUnitLayer.v](Bicategories/MonoidalCategories/UnivalenceMonCat/TensorUnitLayer.v) - [MonoidalCategories/UnivalenceMonCat/AssociatorUnitorsLayer.v](Bicategories/MonoidalCategories/UnivalenceMonCat/AssociatorUnitorsLayer.v) - [MonoidalCategories/UnivalenceMonCat/FinalLayer.v](Bicategories/MonoidalCategories/UnivalenceMonCat/FinalLayer.v) - [MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatCurried.v](Bicategories/MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatCurried.v) - [MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatNonCurried.v](Bicategories/MonoidalCategories/UnivalenceMonCat/EquivalenceMonCatNonCurried.v) - [Core/Examples/Groupoids.v](Bicategories/Core/Examples/Groupoids.v) - [PseudoFunctors/Display/Base.v](Bicategories/PseudoFunctors/Display/Base.v) - [PseudoFunctors/Display/Map1Cells.v](Bicategories/PseudoFunctors/Display/Map1Cells.v) - [PseudoFunctors/Display/Map2Cells.v](Bicategories/PseudoFunctors/Display/Map2Cells.v) - [PseudoFunctors/Display/Identitor.v](Bicategories/PseudoFunctors/Display/Identitor.v) - [PseudoFunctors/Display/Compositor.v](Bicategories/PseudoFunctors/Display/Compositor.v) - [PseudoFunctors/Display/PseudoFunctorBicat.v](Bicategories/PseudoFunctors/Display/PseudoFunctorBicat.v) - [PseudoFunctors/Display/StrictIdentitor.v](Bicategories/PseudoFunctors/Display/StrictIdentitor.v) - [PseudoFunctors/Display/StrictCompositor.v](Bicategories/PseudoFunctors/Display/StrictCompositor.v) - [PseudoFunctors/Display/StrictPseudoFunctorBicat.v](Bicategories/PseudoFunctors/Display/StrictPseudoFunctorBicat.v) - [PseudoFunctors/PseudoFunctor.v](Bicategories/PseudoFunctors/PseudoFunctor.v) - [PseudoFunctors/StrictPseudoFunctor.v](Bicategories/PseudoFunctors/StrictPseudoFunctor.v) - [PseudoFunctors/Examples/Identity.v](Bicategories/PseudoFunctors/Examples/Identity.v) - [PseudoFunctors/Examples/Composition.v](Bicategories/PseudoFunctors/Examples/Composition.v) - [PseudoFunctors/Examples/Constant.v](Bicategories/PseudoFunctors/Examples/Constant.v) - [PseudoFunctors/Examples/ApFunctor.v](Bicategories/PseudoFunctors/Examples/ApFunctor.v) - [PseudoFunctors/Examples/OpFunctor.v](Bicategories/PseudoFunctors/Examples/OpFunctor.v) - [PseudoFunctors/Examples/CatDiag.v](Bicategories/PseudoFunctors/Examples/CatDiag.v) - [PseudoFunctors/Examples/PseudofunctorFromMonoidal.v](Bicategories/PseudoFunctors/Examples/PseudofunctorFromMonoidal.v) - [PseudoFunctors/Examples/Op2OfPseudoFunctor.v](Bicategories/PseudoFunctors/Examples/Op2OfPseudoFunctor.v) - [PseudoFunctors/Examples/BicatOfCatToUnivCat.v](Bicategories/PseudoFunctors/Examples/BicatOfCatToUnivCat.v) - [PseudoFunctors/Examples/PseudoFunctorsIntoCat.v](Bicategories/PseudoFunctors/Examples/PseudoFunctorsIntoCat.v) - [Transformations/PseudoTransformation.v](Bicategories/Transformations/PseudoTransformation.v) - [Transformations/Examples/Whiskering.v](Bicategories/Transformations/Examples/Whiskering.v) - [Transformations/Examples/Unitality.v](Bicategories/Transformations/Examples/Unitality.v) - [Transformations/Examples/Associativity.v](Bicategories/Transformations/Examples/Associativity.v) - [Transformations/Examples/ApTransformation.v](Bicategories/Transformations/Examples/ApTransformation.v) - [Transformations/Examples/PseudoTransformationIntoCat.v](Bicategories/Transformations/Examples/PseudoTransformationIntoCat.v) - [Modifications/Modification.v](Bicategories/Modifications/Modification.v) - [Modifications/Examples/ApModification.v](Bicategories/Modifications/Examples/ApModification.v) - [Modifications/Examples/Unitality.v](Bicategories/Modifications/Examples/Unitality.v) - [Modifications/Examples/Associativity.v](Bicategories/Modifications/Examples/Associativity.v) - [Modifications/Examples/ModificationIntoCat.v](Bicategories/Modifications/Examples/ModificationIntoCat.v) - [PseudoFunctors/Representable.v](Bicategories/PseudoFunctors/Representable.v) - [PseudoFunctors/Yoneda.v](Bicategories/PseudoFunctors/Yoneda.v) - [PseudoFunctors/Biequivalence.v](Bicategories/PseudoFunctors/Biequivalence.v) - [PseudoFunctors/Examples/StrictToPseudo.v](Bicategories/PseudoFunctors/Examples/StrictToPseudo.v) - [PseudoFunctors/Examples/Projection.v](Bicategories/PseudoFunctors/Examples/Projection.v) - [MonoidalCategories/EquivalenceActegoriesAndActions.v](Bicategories/MonoidalCategories/EquivalenceActegoriesAndActions.v) - [PseudoFunctors/Biadjunction.v](Bicategories/PseudoFunctors/Biadjunction.v) - [PseudoFunctors/UniversalArrow.v](Bicategories/PseudoFunctors/UniversalArrow.v) - [DisplayedBicats/DispBicatSection.v](Bicategories/DisplayedBicats/DispBicatSection.v) - [DisplayedBicats/Examples/PointedOneTypes.v](Bicategories/DisplayedBicats/Examples/PointedOneTypes.v) - [DisplayedBicats/Examples/DisplayedInserter.v](Bicategories/DisplayedBicats/Examples/DisplayedInserter.v) - [DisplayedBicats/Examples/Displayed2Inserter.v](Bicategories/DisplayedBicats/Examples/Displayed2Inserter.v) - [DisplayedBicats/Examples/Algebras.v](Bicategories/DisplayedBicats/Examples/Algebras.v) - [DisplayedBicats/Examples/Add2Cell.v](Bicategories/DisplayedBicats/Examples/Add2Cell.v) - [DisplayedBicats/Examples/ContravariantFunctor.v](Bicategories/DisplayedBicats/Examples/ContravariantFunctor.v) - [DisplayedBicats/Examples/Cofunctormap.v](Bicategories/DisplayedBicats/Examples/Cofunctormap.v) - [DisplayedBicats/Examples/CwF.v](Bicategories/DisplayedBicats/Examples/CwF.v) - [DisplayedBicats/Examples/LaxSlice.v](Bicategories/DisplayedBicats/Examples/LaxSlice.v) - [DisplayedBicats/Examples/FunctorsIntoCat.v](Bicategories/DisplayedBicats/Examples/FunctorsIntoCat.v) - [DisplayedBicats/Examples/Codomain.v](Bicategories/DisplayedBicats/Examples/Codomain.v) - [DisplayedBicats/DispPseudofunctor.v](Bicategories/DisplayedBicats/DispPseudofunctor.v) - [DisplayedBicats/DispTransportLaws.v](Bicategories/DisplayedBicats/DispTransportLaws.v) - [DisplayedBicats/UnivalenceTechniques.v](Bicategories/DisplayedBicats/UnivalenceTechniques.v) - [Transformations/Examples/AlgebraMap.v](Bicategories/Transformations/Examples/AlgebraMap.v) - [DisplayedBicats/Examples/Monads.v](Bicategories/DisplayedBicats/Examples/Monads.v) - [DisplayedBicats/Examples/KleisliTriple.v](Bicategories/DisplayedBicats/Examples/KleisliTriple.v) - [DisplayedBicats/Examples/EnrichedCats.v](Bicategories/DisplayedBicats/Examples/EnrichedCats.v) - [DisplayedBicats/Examples/DispBicatOfTwoSidedDispCat.v](Bicategories/DisplayedBicats/Examples/DispBicatOfTwoSidedDispCat.v) - [DisplayedBicats/DispTransformation.v](Bicategories/DisplayedBicats/DispTransformation.v) - [DisplayedBicats/DispModification.v](Bicategories/DisplayedBicats/DispModification.v) - [DisplayedBicats/DispBiequivalence.v](Bicategories/DisplayedBicats/DispBiequivalence.v) - [DoubleCategories/DoubleCategoryBasics.v](Bicategories/DoubleCategories/DoubleCategoryBasics.v) - [DoubleCategories/DoubleFunctor/Basics.v](Bicategories/DoubleCategories/DoubleFunctor/Basics.v) - [DoubleCategories/DoubleFunctor/LeftUnitor.v](Bicategories/DoubleCategories/DoubleFunctor/LeftUnitor.v) - [DoubleCategories/DoubleFunctor/RightUnitor.v](Bicategories/DoubleCategories/DoubleFunctor/RightUnitor.v) - [DoubleCategories/DoubleFunctor/Associator.v](Bicategories/DoubleCategories/DoubleFunctor/Associator.v) - [DoubleCategories/DoubleFunctor.v](Bicategories/DoubleCategories/DoubleFunctor.v) - [DoubleCategories/DoubleTransformation.v](Bicategories/DoubleCategories/DoubleTransformation.v) - [DoubleCategories/BicatOfDoubleCats.v](Bicategories/DoubleCategories/BicatOfDoubleCats.v) - [DoubleCategories/DoubleCats.v](Bicategories/DoubleCategories/DoubleCats.v) - [DoubleCategories/InvertiblesAndEquivalences.v](Bicategories/DoubleCategories/InvertiblesAndEquivalences.v) - [DoubleCategories/Examples/UnitDoubleCat.v](Bicategories/DoubleCategories/Examples/UnitDoubleCat.v) - [DoubleCategories/Examples/ProductDoubleCat.v](Bicategories/DoubleCategories/Examples/ProductDoubleCat.v) - [DoubleCategories/Examples/SquareDoubleCat.v](Bicategories/DoubleCategories/Examples/SquareDoubleCat.v) - [DoubleCategories/Examples/LensesDoubleCat.v](Bicategories/DoubleCategories/Examples/LensesDoubleCat.v) - [DoubleCategories/Examples/SpansDoubleCat.v](Bicategories/DoubleCategories/Examples/SpansDoubleCat.v) - [DoubleCategories/Examples/KleisliDoubleCat.v](Bicategories/DoubleCategories/Examples/KleisliDoubleCat.v) - [DoubleCategories/Examples/StructuredCospansDoubleCat.v](Bicategories/DoubleCategories/Examples/StructuredCospansDoubleCat.v) - [DoubleCategories/Examples/StructuredCospansDoubleFunctor.v](Bicategories/DoubleCategories/Examples/StructuredCospansDoubleFunctor.v) - [DoubleCategories/DoubleCatsUnfolded.v](Bicategories/DoubleCategories/DoubleCatsUnfolded.v) - [DoubleCategories/DoubleCatsEquivalentDefinitions.v](Bicategories/DoubleCategories/DoubleCatsEquivalentDefinitions.v) - [PseudoFunctors/Examples/ChangeOfBaseEnriched.v](Bicategories/PseudoFunctors/Examples/ChangeOfBaseEnriched.v) - [DisplayedBicats/Examples/MonadsLax.v](Bicategories/DisplayedBicats/Examples/MonadsLax.v) - [DisplayedBicats/Examples/DispBicatOnCatToUniv.v](Bicategories/DisplayedBicats/Examples/DispBicatOnCatToUniv.v) - [PseudoFunctors/Examples/MonadInclusion.v](Bicategories/PseudoFunctors/Examples/MonadInclusion.v) - [PseudoFunctors/Examples/OpFunctorEnriched.v](Bicategories/PseudoFunctors/Examples/OpFunctorEnriched.v) - [Monads/Examples/AdjunctionToMonad.v](Bicategories/Monads/Examples/AdjunctionToMonad.v) - [Monads/Examples/ToMonadInCat.v](Bicategories/Monads/Examples/ToMonadInCat.v) - [Monads/Examples/MonadsInBicatOfUnivCats.v](Bicategories/Monads/Examples/MonadsInBicatOfUnivCats.v) - [Monads/Examples/MonadsInBicatOfCats.v](Bicategories/Monads/Examples/MonadsInBicatOfCats.v) - [Monads/Examples/MonadsInOp1Bicat.v](Bicategories/Monads/Examples/MonadsInOp1Bicat.v) - [Monads/Examples/MonadsInOp2Bicat.v](Bicategories/Monads/Examples/MonadsInOp2Bicat.v) - [Monads/Examples/MonadsInTotalBicat.v](Bicategories/Monads/Examples/MonadsInTotalBicat.v) - [Monads/Examples/MonadsInBicatOfEnrichedCats.v](Bicategories/Monads/Examples/MonadsInBicatOfEnrichedCats.v) - [Monads/DistributiveLaws.v](Bicategories/Monads/DistributiveLaws.v) - [Monads/MixedDistributiveLaws.v](Bicategories/Monads/MixedDistributiveLaws.v) - [Monads/Examples/MonadsInMonads.v](Bicategories/Monads/Examples/MonadsInMonads.v) - [Monads/Examples/Composition.v](Bicategories/Monads/Examples/Composition.v) - [Monads/Examples/PsfunctorOnMonad.v](Bicategories/Monads/Examples/PsfunctorOnMonad.v) - [Core/Examples/Image.v](Bicategories/Core/Examples/Image.v) - [PseudoFunctors/Examples/CorestrictImage.v](Bicategories/PseudoFunctors/Examples/CorestrictImage.v) - [Core/YonedaLemma.v](Bicategories/Core/YonedaLemma.v) - [Limits/Final.v](Bicategories/Limits/Final.v) - [Limits/Products.v](Bicategories/Limits/Products.v) - [Limits/Pullbacks.v](Bicategories/Limits/Pullbacks.v) - [Limits/CommaObjects.v](Bicategories/Limits/CommaObjects.v) - [Limits/Inserters.v](Bicategories/Limits/Inserters.v) - [Limits/IsoInserters.v](Bicategories/Limits/IsoInserters.v) - [Limits/Equifiers.v](Bicategories/Limits/Equifiers.v) - [Limits/EilenbergMooreObjects.v](Bicategories/Limits/EilenbergMooreObjects.v) - [Limits/EilenbergMooreComonad.v](Bicategories/Limits/EilenbergMooreComonad.v) - [Monads/ConstructionOfAlgebras.v](Bicategories/Monads/ConstructionOfAlgebras.v) - [Monads/MonadToAdjunction.v](Bicategories/Monads/MonadToAdjunction.v) - [Limits/Examples/OneTypesLimits.v](Bicategories/Limits/Examples/OneTypesLimits.v) - [Limits/Examples/BicatOfCatsLimits.v](Bicategories/Limits/Examples/BicatOfCatsLimits.v) - [Limits/Examples/BicatOfUnivCatsLimits.v](Bicategories/Limits/Examples/BicatOfUnivCatsLimits.v) - [Limits/Examples/BicatOfEnrichedCatsLimits.v](Bicategories/Limits/Examples/BicatOfEnrichedCatsLimits.v) - [Limits/Examples/OpCellBicatLimits.v](Bicategories/Limits/Examples/OpCellBicatLimits.v) - [Limits/Examples/UnivGroupoidsLimits.v](Bicategories/Limits/Examples/UnivGroupoidsLimits.v) - [Limits/Examples/SliceBicategoryLimits.v](Bicategories/Limits/Examples/SliceBicategoryLimits.v) - [Limits/Examples/TotalBicategoryLimits.v](Bicategories/Limits/Examples/TotalBicategoryLimits.v) - [Limits/Examples/DispConstructionsLimits.v](Bicategories/Limits/Examples/DispConstructionsLimits.v) - [Limits/Examples/SubbicatLimits.v](Bicategories/Limits/Examples/SubbicatLimits.v) - [Limits/Examples/LimitsStructuredCategories.v](Bicategories/Limits/Examples/LimitsStructuredCategories.v) - [MonoidalCategories/BicatOfWhiskeredMonCatsFinalObject.v](Bicategories/MonoidalCategories/BicatOfWhiskeredMonCatsFinalObject.v) - [Morphisms/Monadic.v](Bicategories/Morphisms/Monadic.v) - [MonoidalCategories/MonoidalDialgebrasInserters.v](Bicategories/MonoidalCategories/MonoidalDialgebrasInserters.v) - [MonoidalCategories/BicatOfActegoriesFinalObject.v](Bicategories/MonoidalCategories/BicatOfActegoriesFinalObject.v) - [MonoidalCategories/MonadsAsMonoidsWhiskered.v](Bicategories/MonoidalCategories/MonadsAsMonoidsWhiskered.v) - [Monads/Examples/MonadsInStructuredCategories.v](Bicategories/Monads/Examples/MonadsInStructuredCategories.v) - [Limits/ProductEquivalences.v](Bicategories/Limits/ProductEquivalences.v) - [Limits/PullbackFunctions.v](Bicategories/Limits/PullbackFunctions.v) - [Limits/PullbackEquivalences.v](Bicategories/Limits/PullbackEquivalences.v) - [Limits/InserterEquivalences.v](Bicategories/Limits/InserterEquivalences.v) - [Limits/EquifierEquivalences.v](Bicategories/Limits/EquifierEquivalences.v) - [Morphisms/Eso.v](Bicategories/Morphisms/Eso.v) - [Morphisms/Properties/Projections.v](Bicategories/Morphisms/Properties/Projections.v) - [Morphisms/Properties/ClosedUnderPullback.v](Bicategories/Morphisms/Properties/ClosedUnderPullback.v) - [Morphisms/Properties/EsoProperties.v](Bicategories/Morphisms/Properties/EsoProperties.v) - [Morphisms/Examples/MorphismsInOneTypes.v](Bicategories/Morphisms/Examples/MorphismsInOneTypes.v) - [Morphisms/Examples/EsosInBicatOfUnivCats.v](Bicategories/Morphisms/Examples/EsosInBicatOfUnivCats.v) - [Morphisms/Examples/MorphismsInSliceBicat.v](Bicategories/Morphisms/Examples/MorphismsInSliceBicat.v) - [Morphisms/Examples/MorphismsInStructuredCat.v](Bicategories/Morphisms/Examples/MorphismsInStructuredCat.v) - [Morphisms/Examples/MorphismsInBicatOfEnrichedCats.v](Bicategories/Morphisms/Examples/MorphismsInBicatOfEnrichedCats.v) - [Colimits/Initial.v](Bicategories/Colimits/Initial.v) - [Colimits/Coproducts.v](Bicategories/Colimits/Coproducts.v) - [Colimits/Extensive.v](Bicategories/Colimits/Extensive.v) - [Colimits/KleisliObjects.v](Bicategories/Colimits/KleisliObjects.v) - [Limits/Examples/OpMorBicatLimits.v](Bicategories/Limits/Examples/OpMorBicatLimits.v) - [Colimits/Examples/OpCellBicatColimits.v](Bicategories/Colimits/Examples/OpCellBicatColimits.v) - [Colimits/Examples/OneTypesColimits.v](Bicategories/Colimits/Examples/OneTypesColimits.v) - [Colimits/Examples/BicatOfCatsColimits.v](Bicategories/Colimits/Examples/BicatOfCatsColimits.v) - [Colimits/Examples/BicatOfUnivCatsColimits.v](Bicategories/Colimits/Examples/BicatOfUnivCatsColimits.v) - [Colimits/Examples/SliceBicategoryColimits.v](Bicategories/Colimits/Examples/SliceBicategoryColimits.v) - [Colimits/CoproductEquivalences.v](Bicategories/Colimits/CoproductEquivalences.v) - [Morphisms/Properties/FromInitial.v](Bicategories/Morphisms/Properties/FromInitial.v) - [Objects/CartesianObject.v](Bicategories/Objects/CartesianObject.v) - [Objects/CocartesianObject.v](Bicategories/Objects/CocartesianObject.v) - [Objects/Examples/BicatOfUnivCatsObjects.v](Bicategories/Objects/Examples/BicatOfUnivCatsObjects.v) - [PseudoFunctors/Examples/ConstProduct.v](Bicategories/PseudoFunctors/Examples/ConstProduct.v) - [PseudoFunctors/Examples/CurryingInBicatOfCats.v](Bicategories/PseudoFunctors/Examples/CurryingInBicatOfCats.v) - [PseudoFunctors/PseudoFunctorLimits.v](Bicategories/PseudoFunctors/PseudoFunctorLimits.v) - [DisplayedBicats/DispBiadjunction.v](Bicategories/DisplayedBicats/DispBiadjunction.v) - [PseudoFunctors/Examples/PathGroupoid.v](Bicategories/PseudoFunctors/Examples/PathGroupoid.v) - [DisplayedBicats/DispToFiberEquivalence.v](Bicategories/DisplayedBicats/DispToFiberEquivalence.v) - [DisplayedBicats/DispBuilders.v](Bicategories/DisplayedBicats/DispBuilders.v) - [DisplayedBicats/Examples/MonadKtripleBiequiv.v](Bicategories/DisplayedBicats/Examples/MonadKtripleBiequiv.v) - [DisplayedBicats/Examples/PointedGroupoid.v](Bicategories/DisplayedBicats/Examples/PointedGroupoid.v) - [PseudoFunctors/Examples/LiftingActegories.v](Bicategories/PseudoFunctors/Examples/LiftingActegories.v) - [WkCatEnrichment/prebicategory.v](Bicategories/WkCatEnrichment/prebicategory.v) - [WkCatEnrichment/Notations.v](Bicategories/WkCatEnrichment/Notations.v) - [WkCatEnrichment/whiskering.v](Bicategories/WkCatEnrichment/whiskering.v) - [WkCatEnrichment/Cat.v](Bicategories/WkCatEnrichment/Cat.v) - [WkCatEnrichment/internal_equivalence.v](Bicategories/WkCatEnrichment/internal_equivalence.v) - [WkCatEnrichment/bicategory.v](Bicategories/WkCatEnrichment/bicategory.v) - [WkCatEnrichment/hcomp_bicat.v](Bicategories/WkCatEnrichment/hcomp_bicat.v) - [PseudoFunctors/Examples/Strictify.v](Bicategories/PseudoFunctors/Examples/Strictify.v) - [PseudoFunctors/Preservation/Preservation.v](Bicategories/PseudoFunctors/Preservation/Preservation.v) - [PseudoFunctors/Preservation/BiadjunctionPreservation.v](Bicategories/PseudoFunctors/Preservation/BiadjunctionPreservation.v) - [PseudoFunctors/Preservation/BiadjunctionPreserveProducts.v](Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveProducts.v) - [PseudoFunctors/Preservation/BiadjunctionPreserveInserters.v](Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveInserters.v) - [PseudoFunctors/Preservation/BiadjunctionPreserveEquifiers.v](Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveEquifiers.v) - [PseudoFunctors/Preservation/BiadjunctionPreserveCoproducts.v](Bicategories/PseudoFunctors/Preservation/BiadjunctionPreserveCoproducts.v) - [PseudoFunctors/Preservation/ClosedUnderEquivalence.v](Bicategories/PseudoFunctors/Preservation/ClosedUnderEquivalence.v) - [BicategoryOfBicat.v](Bicategories/BicategoryOfBicat.v) - [BicatOfBicategory.v](Bicategories/BicatOfBicategory.v) - [DisplayedBicats/Cartesians.v](Bicategories/DisplayedBicats/Cartesians.v) - [DisplayedBicats/EquivalenceBetweenCartesians.v](Bicategories/DisplayedBicats/EquivalenceBetweenCartesians.v) - [DisplayedBicats/CleavingOfBicatIsAProp.v](Bicategories/DisplayedBicats/CleavingOfBicatIsAProp.v) - [DisplayedBicats/CartesianPseudoFunctor.v](Bicategories/DisplayedBicats/CartesianPseudoFunctor.v) - [DisplayedBicats/ExamplesOfCleavings/TrivialCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/TrivialCleaving.v) - [DisplayedBicats/ExamplesOfCleavings/SliceCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/SliceCleaving.v) - [DisplayedBicats/ExamplesOfCleavings/FunctorsIntoCatCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/FunctorsIntoCatCleaving.v) - [DisplayedBicats/ExamplesOfCleavings/CodomainCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/CodomainCleaving.v) - [DisplayedBicats/ExamplesOfCleavings/FibrationCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/FibrationCleaving.v) - [DisplayedBicats/ExamplesOfCleavings/OpFibrationCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/OpFibrationCleaving.v) - [DisplayedBicats/FiberBicategory/FunctorFromCleaving.v](Bicategories/DisplayedBicats/FiberBicategory/FunctorFromCleaving.v) - [PseudoFunctors/Examples/Reindexing.v](Bicategories/PseudoFunctors/Examples/Reindexing.v) - [Logic/DisplayMapBicat.v](Bicategories/Logic/DisplayMapBicat.v) - [DisplayedBicats/Examples/DisplayMapBicatToDispBicat.v](Bicategories/DisplayedBicats/Examples/DisplayMapBicatToDispBicat.v) - [DisplayedBicats/Examples/DisplayMapBicatSlice.v](Bicategories/DisplayedBicats/Examples/DisplayMapBicatSlice.v) - [DisplayedBicats/ExamplesOfCleavings/DisplayMapBicatCleaving.v](Bicategories/DisplayedBicats/ExamplesOfCleavings/DisplayMapBicatCleaving.v) - [PseudoFunctors/Examples/PullbackFunctor.v](Bicategories/PseudoFunctors/Examples/PullbackFunctor.v) - [PseudoFunctors/Examples/CompositionPseudoFunctor.v](Bicategories/PseudoFunctors/Examples/CompositionPseudoFunctor.v) - [PseudoFunctors/Preservation/PullbackPreservation.v](Bicategories/PseudoFunctors/Preservation/PullbackPreservation.v) - [Limits/Examples/DisplayMapSliceLimits.v](Bicategories/Limits/Examples/DisplayMapSliceLimits.v) - [Colimits/Examples/DisplayMapSliceColimits.v](Bicategories/Colimits/Examples/DisplayMapSliceColimits.v) - [DisplayedBicats/FiberBicategory/TrivialFiber.v](Bicategories/DisplayedBicats/FiberBicategory/TrivialFiber.v) - [DisplayedBicats/FiberBicategory/CodomainFiber.v](Bicategories/DisplayedBicats/FiberBicategory/CodomainFiber.v) - [DisplayedBicats/FiberBicategory/SliceFiber.v](Bicategories/DisplayedBicats/FiberBicategory/SliceFiber.v) - [DisplayedBicats/FiberBicategory/DisplayMapFiber.v](Bicategories/DisplayedBicats/FiberBicategory/DisplayMapFiber.v) - [Grothendieck/FibrationToPseudoFunctor.v](Bicategories/Grothendieck/FibrationToPseudoFunctor.v) - [Grothendieck/PseudoFunctorToFibration.v](Bicategories/Grothendieck/PseudoFunctorToFibration.v) - [Grothendieck/Unit.v](Bicategories/Grothendieck/Unit.v) - [Grothendieck/Counit.v](Bicategories/Grothendieck/Counit.v) - [Grothendieck/Biequivalence.v](Bicategories/Grothendieck/Biequivalence.v) - [Grothendieck/FiberwiseEquiv.v](Bicategories/Grothendieck/FiberwiseEquiv.v) - [Logic/ComprehensionBicat.v](Bicategories/Logic/ComprehensionBicat.v) - [Logic/Examples/TrivialComprehensionBicat.v](Bicategories/Logic/Examples/TrivialComprehensionBicat.v) - [Logic/Examples/PullbackComprehensionBicat.v](Bicategories/Logic/Examples/PullbackComprehensionBicat.v) - [Logic/Examples/FibrationsComprehensionBicat.v](Bicategories/Logic/Examples/FibrationsComprehensionBicat.v) - [Logic/Examples/OpfibrationsComprehensionBicat.v](Bicategories/Logic/Examples/OpfibrationsComprehensionBicat.v) - [Logic/Examples/DisplayMapComprehensionBicat.v](Bicategories/Logic/Examples/DisplayMapComprehensionBicat.v) - [Logic/Examples/FunctorsIntoCatComprehensionBicat.v](Bicategories/Logic/Examples/FunctorsIntoCatComprehensionBicat.v) - [OtherStructure/DualityInvolution.v](Bicategories/OtherStructure/DualityInvolution.v) - [OtherStructure/ClassifyingDiscreteOpfib.v](Bicategories/OtherStructure/ClassifyingDiscreteOpfib.v) - [OtherStructure/Exponentials.v](Bicategories/OtherStructure/Exponentials.v) - [OtherStructure/Cores.v](Bicategories/OtherStructure/Cores.v) - [OtherStructure/Examples/StructureBicatOfUnivCats.v](Bicategories/OtherStructure/Examples/StructureBicatOfUnivCats.v) - [OtherStructure/Examples/StructureOneTypes.v](Bicategories/OtherStructure/Examples/StructureOneTypes.v) - [OtherStructure/Examples/StructureBicatOfEnrichedCats.v](Bicategories/OtherStructure/Examples/StructureBicatOfEnrichedCats.v) - [DisplayedBicats/DisplayedUniversalArrow.v](Bicategories/DisplayedBicats/DisplayedUniversalArrow.v) - [DisplayedBicats/DisplayedUniversalArrowOnCat.v](Bicategories/DisplayedBicats/DisplayedUniversalArrowOnCat.v) - [RezkCompletions/BicatToLocalUnivalentBicat.v](Bicategories/RezkCompletions/BicatToLocalUnivalentBicat.v) - [RezkCompletions/RezkCompletionOfBicategory.v](Bicategories/RezkCompletions/RezkCompletionOfBicategory.v) - [RezkCompletions/StructuredCats/TerminalObject.v](Bicategories/RezkCompletions/StructuredCats/TerminalObject.v) - [DaggerCategories/BicatOfDaggerCats.v](Bicategories/DaggerCategories/BicatOfDaggerCats.v) - [All.v](Bicategories/All.v) ## Package [Ktheory](Ktheory/README.md) - [GrothendieckGroup.v](Ktheory/GrothendieckGroup.v) - [All.v](Ktheory/All.v) ## Package Topology - [Prelim.v](Topology/Prelim.v) - [Filters.v](Topology/Filters.v) - [Topology.v](Topology/Topology.v) - [CategoryTop.v](Topology/CategoryTop.v) - [All.v](Topology/All.v) ## Package [RealNumbers](RealNumbers/README.md) - [Prelim.v](RealNumbers/Prelim.v) - [Fields.v](RealNumbers/Fields.v) - [Sets.v](RealNumbers/Sets.v) - [NonnegativeRationals.v](RealNumbers/NonnegativeRationals.v) - [NonnegativeReals.v](RealNumbers/NonnegativeReals.v) - [Reals.v](RealNumbers/Reals.v) - [DedekindCuts.v](RealNumbers/DedekindCuts.v) - [DecidableDedekindCuts.v](RealNumbers/DecidableDedekindCuts.v) - [All.v](RealNumbers/All.v) ## Package [SubstitutionSystems](SubstitutionSystems/README.md) - [Notation.v](SubstitutionSystems/Notation.v) - [Signatures.v](SubstitutionSystems/Signatures.v) - [BinSumOfSignatures.v](SubstitutionSystems/BinSumOfSignatures.v) - [SumOfSignatures.v](SubstitutionSystems/SumOfSignatures.v) - [BinProductOfSignatures.v](SubstitutionSystems/BinProductOfSignatures.v) - [SubstitutionSystems.v](SubstitutionSystems/SubstitutionSystems.v) - [SimplifiedHSS/SubstitutionSystems.v](SubstitutionSystems/SimplifiedHSS/SubstitutionSystems.v) - [SignaturesEquivRelativeStrength.v](SubstitutionSystems/SignaturesEquivRelativeStrength.v) - [GeneralizedSubstitutionSystems.v](SubstitutionSystems/GeneralizedSubstitutionSystems.v) - [MonadsFromSubstitutionSystems.v](SubstitutionSystems/MonadsFromSubstitutionSystems.v) - [SimplifiedHSS/MonadsFromSubstitutionSystems.v](SubstitutionSystems/SimplifiedHSS/MonadsFromSubstitutionSystems.v) - [GenMendlerIteration.v](SubstitutionSystems/GenMendlerIteration.v) - [GenMendlerIteration_alt.v](SubstitutionSystems/GenMendlerIteration_alt.v) - [ActionScenarioForGenMendlerIteration_alt.v](SubstitutionSystems/ActionScenarioForGenMendlerIteration_alt.v) - [ApplicationsGenMendlerIteration_alt.v](SubstitutionSystems/ApplicationsGenMendlerIteration_alt.v) - [LiftingInitial.v](SubstitutionSystems/LiftingInitial.v) - [SimplifiedHSS/LiftingInitial.v](SubstitutionSystems/SimplifiedHSS/LiftingInitial.v) - [LiftingInitial_alt.v](SubstitutionSystems/LiftingInitial_alt.v) - [SimplifiedHSS/LiftingInitial_alt.v](SubstitutionSystems/SimplifiedHSS/LiftingInitial_alt.v) - [ModulesFromSignatures.v](SubstitutionSystems/ModulesFromSignatures.v) - [SimplifiedHSS/ModulesFromSignatures.v](SubstitutionSystems/SimplifiedHSS/ModulesFromSignatures.v) - [LamSignature.v](SubstitutionSystems/LamSignature.v) - [Lam.v](SubstitutionSystems/Lam.v) - [SimplifiedHSS/Lam.v](SubstitutionSystems/SimplifiedHSS/Lam.v) - [SignatureExamples.v](SubstitutionSystems/SignatureExamples.v) - [SignatureCategory.v](SubstitutionSystems/SignatureCategory.v) - [SubstitutionSystems_Summary.v](SubstitutionSystems/SubstitutionSystems_Summary.v) - [SimplifiedHSS/SubstitutionSystems_Summary.v](SubstitutionSystems/SimplifiedHSS/SubstitutionSystems_Summary.v) - [LamHSET.v](SubstitutionSystems/LamHSET.v) - [SimplifiedHSS/LamHSET.v](SubstitutionSystems/SimplifiedHSS/LamHSET.v) - [BindingSigToMonad.v](SubstitutionSystems/BindingSigToMonad.v) - [SimplifiedHSS/BindingSigToMonad.v](SubstitutionSystems/SimplifiedHSS/BindingSigToMonad.v) - [LamFromBindingSig.v](SubstitutionSystems/LamFromBindingSig.v) - [SimplifiedHSS/LamFromBindingSig.v](SubstitutionSystems/SimplifiedHSS/LamFromBindingSig.v) - [MLTT79.v](SubstitutionSystems/MLTT79.v) - [SimplifiedHSS/MLTT79.v](SubstitutionSystems/SimplifiedHSS/MLTT79.v) - [FromBindingSigsToMonads_Summary.v](SubstitutionSystems/FromBindingSigsToMonads_Summary.v) - [SimplifiedHSS/FromBindingSigsToMonads_Summary.v](SubstitutionSystems/SimplifiedHSS/FromBindingSigsToMonads_Summary.v) - [MonadsMultiSorted.v](SubstitutionSystems/MonadsMultiSorted.v) - [MonadsMultiSorted_alt.v](SubstitutionSystems/MonadsMultiSorted_alt.v) - [MultiSorted.v](SubstitutionSystems/MultiSorted.v) - [MultiSortedMonadConstruction.v](SubstitutionSystems/MultiSortedMonadConstruction.v) - [SimplifiedHSS/MultiSortedMonadConstruction.v](SubstitutionSystems/SimplifiedHSS/MultiSortedMonadConstruction.v) - [MultiSorted_alt.v](SubstitutionSystems/MultiSorted_alt.v) - [MultiSortedMonadConstruction_alt.v](SubstitutionSystems/MultiSortedMonadConstruction_alt.v) - [SimplifiedHSS/MultiSortedMonadConstruction_alt.v](SubstitutionSystems/SimplifiedHSS/MultiSortedMonadConstruction_alt.v) - [MonadicSubstitution_alt.v](SubstitutionSystems/MonadicSubstitution_alt.v) - [SimplifiedHSS/MonadicSubstitution_alt.v](SubstitutionSystems/SimplifiedHSS/MonadicSubstitution_alt.v) - [STLC.v](SubstitutionSystems/STLC.v) - [SimplifiedHSS/STLC.v](SubstitutionSystems/SimplifiedHSS/STLC.v) - [STLC_alt.v](SubstitutionSystems/STLC_alt.v) - [SimplifiedHSS/STLC_alt.v](SubstitutionSystems/SimplifiedHSS/STLC_alt.v) - [CCS.v](SubstitutionSystems/CCS.v) - [SimplifiedHSS/CCS.v](SubstitutionSystems/SimplifiedHSS/CCS.v) - [CCS_alt.v](SubstitutionSystems/CCS_alt.v) - [SimplifiedHSS/CCS_alt.v](SubstitutionSystems/SimplifiedHSS/CCS_alt.v) - [PCF_alt.v](SubstitutionSystems/PCF_alt.v) - [SimplifiedHSS/PCF_alt.v](SubstitutionSystems/SimplifiedHSS/PCF_alt.v) - [ActionBasedStrengthOnHomsInBicat.v](SubstitutionSystems/ActionBasedStrengthOnHomsInBicat.v) - [EquivalenceSignaturesWithActegoryMorphisms.v](SubstitutionSystems/EquivalenceSignaturesWithActegoryMorphisms.v) - [EquivalenceLaxLineatorsHomogeneousCase.v](SubstitutionSystems/EquivalenceLaxLineatorsHomogeneousCase.v) - [SigmaMonoids.v](SubstitutionSystems/SigmaMonoids.v) - [ConstructionOfGHSS.v](SubstitutionSystems/ConstructionOfGHSS.v) - [BindingSigToMonad_actegorical.v](SubstitutionSystems/BindingSigToMonad_actegorical.v) - [ContinuitySignature/GeneralLemmas.v](SubstitutionSystems/ContinuitySignature/GeneralLemmas.v) - [ContinuitySignature/CommutingOfOmegaLimitsAndCoproducts.v](SubstitutionSystems/ContinuitySignature/CommutingOfOmegaLimitsAndCoproducts.v) - [ContinuitySignature/ContinuityOfMultiSortedSigToFunctor.v](SubstitutionSystems/ContinuitySignature/ContinuityOfMultiSortedSigToFunctor.v) - [ContinuitySignature/MultiSortedSignatureFunctorEquivalence.v](SubstitutionSystems/ContinuitySignature/MultiSortedSignatureFunctorEquivalence.v) - [ContinuitySignature/InstantiateHSET.v](SubstitutionSystems/ContinuitySignature/InstantiateHSET.v) - [MultiSorted_actegorical.v](SubstitutionSystems/MultiSorted_actegorical.v) - [MultiSortedMonadConstruction_actegorical.v](SubstitutionSystems/MultiSortedMonadConstruction_actegorical.v) - [MultiSortedMonadConstruction_coind_actegorical.v](SubstitutionSystems/MultiSortedMonadConstruction_coind_actegorical.v) - [MultiSortedEmbeddingIndCoindHSET.v](SubstitutionSystems/MultiSortedEmbeddingIndCoindHSET.v) - [All.v](SubstitutionSystems/All.v) ## Package [Folds](Folds/README.md) - [UnicodeNotations.v](Folds/UnicodeNotations.v) - [folds_precat.v](Folds/folds_precat.v) - [from_precats_to_folds_and_back.v](Folds/from_precats_to_folds_and_back.v) - [folds_isomorphism.v](Folds/folds_isomorphism.v) - [folds_pre_2_cat.v](Folds/folds_pre_2_cat.v) - [All.v](Folds/All.v) ## Package [HomologicalAlgebra](HomologicalAlgebra/README.md) - [Triangulated.v](HomologicalAlgebra/Triangulated.v) - [Complexes.v](HomologicalAlgebra/Complexes.v) - [KA.v](HomologicalAlgebra/KA.v) - [TranslationFunctors.v](HomologicalAlgebra/TranslationFunctors.v) - [MappingCone.v](HomologicalAlgebra/MappingCone.v) - [MappingCylinder.v](HomologicalAlgebra/MappingCylinder.v) - [KAPreTriangulated.v](HomologicalAlgebra/KAPreTriangulated.v) - [KATriangulated.v](HomologicalAlgebra/KATriangulated.v) - [CohomologyComplex.v](HomologicalAlgebra/CohomologyComplex.v) - [All.v](HomologicalAlgebra/All.v) ## Package [AlgebraicGeometry](AlgebraicGeometry/README.md) - [Topology.v](AlgebraicGeometry/Topology.v) - [SheavesOfRings.v](AlgebraicGeometry/SheavesOfRings.v) - [Spec.v](AlgebraicGeometry/Spec.v) - [All.v](AlgebraicGeometry/All.v) ## Package [Paradoxes](Paradoxes/README.md) - [GirardsParadox.v](Paradoxes/GirardsParadox.v) - [All.v](Paradoxes/All.v) ## Package [Induction](Induction/README.md) - [FunctorAlgebras_legacy.v](Induction/FunctorAlgebras_legacy.v) - [FunctorCoalgebras_legacy.v](Induction/FunctorCoalgebras_legacy.v) - [PolynomialFunctors.v](Induction/PolynomialFunctors.v) - [ImpredicativeInductiveSets.v](Induction/ImpredicativeInductiveSets.v) - [M/Core.v](Induction/M/Core.v) - [M/Limits.v](Induction/M/Limits.v) - [M/Uniqueness.v](Induction/M/Uniqueness.v) - [W/Core.v](Induction/W/Core.v) - [W/Fibered.v](Induction/W/Fibered.v) - [W/Naturals.v](Induction/W/Naturals.v) - [W/Uniqueness.v](Induction/W/Uniqueness.v) - [M/Chains.v](Induction/M/Chains.v) - [M/ComputationalM.v](Induction/M/ComputationalM.v) - [All.v](Induction/All.v) ## Package AlgebraicTheories - [FiniteSetSkeleton.v](AlgebraicTheories/FiniteSetSkeleton.v) - [AlgebraicTheories2.v](AlgebraicTheories/AlgebraicTheories2.v) - [AlgebraicTheories.v](AlgebraicTheories/AlgebraicTheories.v) - [AlgebraicTheoryMorphisms2.v](AlgebraicTheories/AlgebraicTheoryMorphisms2.v) - [AlgebraicTheoryMorphisms.v](AlgebraicTheories/AlgebraicTheoryMorphisms.v) - [AlgebraicTheoryCategory.v](AlgebraicTheories/AlgebraicTheoryCategory.v) - [AlgebraicTheoryAlgebras.v](AlgebraicTheories/AlgebraicTheoryAlgebras.v) - [AlgebraicTheoryAlgebraMorphisms.v](AlgebraicTheories/AlgebraicTheoryAlgebraMorphisms.v) - [AlgebraicTheoryAlgebraCategory.v](AlgebraicTheories/AlgebraicTheoryAlgebraCategory.v) - [AlgebraicTheoryAlgebraFibration.v](AlgebraicTheories/AlgebraicTheoryAlgebraFibration.v) - [Examples/OnePointTheory.v](AlgebraicTheories/Examples/OnePointTheory.v) - [Examples/ProjectionsTheory.v](AlgebraicTheories/Examples/ProjectionsTheory.v) - [Examples/EndomorphismTheory.v](AlgebraicTheories/Examples/EndomorphismTheory.v) - [Examples/FreeMonoidTheory.v](AlgebraicTheories/Examples/FreeMonoidTheory.v) - [AlgebraicTheoryAlgebraWeqEndomorphismTheoryMorphism.v](AlgebraicTheories/AlgebraicTheoryAlgebraWeqEndomorphismTheoryMorphism.v) - [All.v](AlgebraicTheories/All.v) ## Package Semantics - [LinearLogic/LinearNonLinear.v](Semantics/LinearLogic/LinearNonLinear.v) - [LinearLogic/LafontCategory.v](Semantics/LinearLogic/LafontCategory.v) - [LinearLogic/LinearCategory.v](Semantics/LinearLogic/LinearCategory.v) - [LinearLogic/LinearCategoryEilenbergMooreAdjunction.v](Semantics/LinearLogic/LinearCategoryEilenbergMooreAdjunction.v) - [LinearLogic/LinearToLinearNonLinear.v](Semantics/LinearLogic/LinearToLinearNonLinear.v) - [LinearLogic/RelationalModel.v](Semantics/LinearLogic/RelationalModel.v) - [LinearLogic/LiftingModel.v](Semantics/LinearLogic/LiftingModel.v) - [EnrichedEffectCalculus/EECModel.v](Semantics/EnrichedEffectCalculus/EECModel.v) - [EnrichedEffectCalculus/ContinuationModel.v](Semantics/EnrichedEffectCalculus/ContinuationModel.v) - [EnrichedEffectCalculus/CopowerModel.v](Semantics/EnrichedEffectCalculus/CopowerModel.v) - [All.v](Semantics/All.v) UniMath-20231010/UniMath/CategoryTheory/000077500000000000000000000000001451125700300176245ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/.package/000077500000000000000000000000001451125700300212755ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/.package/files000066400000000000000000000344131451125700300223270ustar00rootroot00000000000000Core/Categories.v Core/TwoCategories.v Core/Isos.v Core/Univalence.v Core/TransportMorphisms.v Core/Functors.v Core/NaturalTransformations.v Core/Setcategories.v Core/EssentiallyAlgebraic.v Core/Prelude.v FunctorCategory.v whiskering.v BicatOfCatsElementary.v DisplayedCats/Core.v DisplayedCats/Isos.v DisplayedCats/Functors.v DisplayedCats/NaturalTransformations.v DisplayedCats/Univalence.v DisplayedCats/DisplayedFunctorEq.v DisplayedCats/Total.v DisplayedCats/Fiber.v categories/CategoryOfSetCategories.v opp_precat.v OppositeCategory/Core.v Groupoids.v ZigZag.v ProductCategory.v PrecategoryBinProduct.v categories/HSET/Core.v CategorySum.v Subcategory/Core.v Subcategory/Full.v Monics.v Epis.v SplitMonicsAndEpis.v HomotopicalCategory.v Adjunctions/Core.v Monads/RelativeMonads.v Monads/RelMonads_Coreflection.v Monads/RelativeModules.v Equivalences/Core.v Equivalences/CompositesAndInverses.v Equivalences/FullyFaithful.v Subcategory/FullEquivalences.v categories/HSET/MonoEpiIso.v categories/HSET/Univalence.v Profunctors/Core.v CategoriesWithBinOps.v PrecategoriesWithAbgrops.v covyoneda.v limits/cones.v limits/equalizers.v limits/graphs/colimits.v limits/graphs/limits.v limits/graphs/eqdiag.v limits/coproducts.v limits/products.v limits/initial.v limits/terminal.v limits/zero.v limits/bincoproducts.v limits/binproducts.v limits/graphs/bincoproducts.v limits/graphs/binproducts.v limits/pullbacks.v limits/graphs/initial.v limits/graphs/terminal.v limits/graphs/zero.v limits/graphs/pullbacks.v limits/coequalizers.v limits/kernels.v limits/cokernels.v PreAdditive.v limits/pushouts.v limits/graphs/pushouts.v limits/graphs/equalizers.v limits/graphs/coequalizers.v limits/graphs/kernels.v limits/graphs/cokernels.v limits/cats/limits.v limits/BinDirectSums.v limits/FinOrdProducts.v limits/FinOrdCoproducts.v limits/Opp.v limits/Preservation.v limits/Ends.v DisplayedCats/Binproducts.v limits/Examples/CategoryProductLimits.v limits/Examples/CategoryOfSetcategoriesLimits.v limits/StandardDiagrams.v limits/Filtered.v IsoCommaCategory.v limits/Examples/IsoCommaLimits.v CommaCategories.v NNO.v Subcategory/Limits.v EpiFacts.v categories/Type/Core.v categories/Type/MonoEpiIso.v SimplicialSets.v yoneda.v FunctorCoalgebras.v precomp_fully_faithful.v precomp_ess_surj.v PrecompEquivalence.v UnitorsAndAssociatorsForEndofunctors.v PointedFunctors.v HorizontalComposition.v PointedFunctorsComposition.v ArrowCategory.v RightKanExtension.v coslicecat.v catiso.v DisplayedCats/CatIsoDisplayed.v CategoryEquality.v WeakEquivalences.v rezk_completion.v RezkCompletion.v exponentials.v slicecat.v limits/pullbacks_slice_products_equiv.v Additive.v Abelian.v category_binops.v AbelianToAdditive.v Morphisms.v ExactCategories/ExactCategories.v ExactCategories/Tests.v ShortExactSequences.v AdditiveFunctors.v LocalizingClass.v UnderCategories.v Subobjects.v SubobjectClassifier.v Quotobjects.v AbelianPushoutPullback.v PseudoElements.v FiveLemma.v LatticeObject.v Actions.v PowerObject.v ElementaryTopos.v Adjunctions/Restriction.v Adjunctions/Examples.v Subcategory/Reflective.v categories/setwith2binops.v categories/monoids.v categories/abmonoids.v categories/grs.v categories/abgrs.v categories/rigs.v categories/commrigs.v categories/rings.v categories/commrings.v categories/intdoms.v categories/flds.v categories/modules.v categories/StandardCategories.v categories/preorder_categories.v limits/Examples/UnitCategoryLimits.v categories/Type/Colimits.v categories/Type/Limits.v categories/Type/Structures.v categories/Type/Univalence.v categories/HSET/Limits.v categories/HSET/Colimits.v categories/HSET/FilteredColimits.v categories/HSET/Slice.v categories/HSET/Structures.v categories/HSET/SliceFamEquiv.v categories/HSET/All.v SetValuedFunctors.v categories/FinSet.v categories/wosets.v categories/Graph.v categories/CGraph.v GrothendieckTopos.v Presheaf.v ElementsOp.v elems_slice_equiv.v YonedaBinproducts.v ExponentiationLeftAdjoint.v Connected.v LeftKanExtension.v categories/CartesianCubicalSets.v OppositeCategory/OppositeAdjunction.v OppositeCategory/OppositeOfFunctorCategory.v Chains/Chains.v Chains/Cochains.v DisplayedCats/Examples/Opposite.v DisplayedCats/Fibrations.v DisplayedCats/Examples/Reindexing.v DisplayedCats/Constructions.v DisplayedCats/Examples/Sigma.v FunctorAlgebras.v CompletelyIterativeAlgebras.v Chains/Adamek.v Chains/CoAdamek.v Chains/OmegaCocontFunctors.v OppositeCategory/LimitsAsColimits.v Chains/OmegaContFunctors.v Chains/All.v Inductives/Lists.v Inductives/Trees.v Inductives/LambdaCalculus.v Inductives/PropositionalLogic.v CategoricalRecursionSchemes.v DisplayedCats/Equivalences.v DisplayedCats/EquivalenceOverId.v DisplayedCats/DisplayedCatEq.v DisplayedCats/Codomain.v DisplayedCats/Projection.v DisplayedCats/SIP.v Monads/Monads.v Monads/LModules.v Monads/Derivative.v Monads/MonadAlgebras.v Monads/Comonads.v DisplayedCats/Limits.v DisplayedCats/Examples.v DisplayedCats/Examples/UnitalBinop.v DisplayedCats/Examples/CategoryOfPosets.v DisplayedCats/Structures/CartesianStructure.v DisplayedCats/Structures/StructureLimitsAndColimits.v DisplayedCats/Structures/StructuresSmashProduct.v DisplayedCats/Examples/AlgebraStructures.v DisplayedCats/Examples/DCPOStructures.v DisplayedCats/Examples/PointedDCPOStructures.v DisplayedCats/Examples/PointedDCPOStrict.v DisplayedCats/Examples/PointedPosetStrict.v DisplayedCats/Examples/PointedPosetStructures.v DisplayedCats/Examples/PointedSetStructures.v DisplayedCats/Examples/PosetStructures.v DisplayedCats/Examples/SetStructures.v DisplayedCats/FunctorCategory.v DisplayedCats/Adjunctions.v DisplayedCats/ComprehensionC.v DisplayedCats/StreetFibration.v DisplayedCats/StreetOpFibration.v DisplayedCats/ReindexingForward.v DisplayedCats/TotalCategoryFacts.v DisplayedCats/TotalAdjunction.v Monads/KleisliCategory.v Monads/KTriples.v Monads/Kleisli.v Monads/KTriplesEquiv.v limits/Examples/AlgebraStructuresColimits.v categories/Dialgebras.v categories/CatIsoInserter.v categories/EilenbergMoore.v categories/CoEilenbergMoore.v categories/KleisliCategory.v limits/Examples/EilenbergMooreLimits.v Elements.v Core.v categories/Universal_Algebra/Algebras.v categories/Universal_Algebra/EqAlgebras.v categories/Relations.v Monoidal/WhiskeredBifunctors.v Monoidal/Categories.v Monoidal/StrongMonad.v Monoidal/Structure/Symmetric.v Monoidal/Structure/SymmetricDiagonal.v Monoidal/Structure/Closed.v Monoidal/Structure/Cartesian.v Monoidal/Functors.v Monoidal/FunctorCategories.v Monoidal/Adjunctions.v Monoidal/CategoriesOfMonoids.v Monoidal/Displayed/WhiskeredDisplayedBifunctors.v Monoidal/Displayed/Monoidal.v Monoidal/Displayed/TotalMonoidal.v Monoidal/Displayed/MonoidalSections.v Monoidal/Displayed/TransportLemmas.v Monoidal/Displayed/Symmetric.v Monoidal/Displayed/SymmetricMonoidalBuilder.v Monoidal/Examples/SetCartesianMonoidal.v Monoidal/Examples/CartesianMonoidal.v Monoidal/Examples/DisplayedCartesianMonoidal.v Monoidal/Examples/StructuresMonoidal.v Monoidal/Examples/EndofunctorsMonoidalElementary.v Monoidal/Examples/MonadsAsMonoidsElementary.v Monoidal/Examples/MonoidalPointedObjects.v Monoidal/Displayed/MonoidalFunctorLifting.v Monoidal/Examples/MonoidalDialgebras.v Monoidal/Examples/SymmetricMonoidalDialgebras.v Monoidal/Examples/PointedSetCartesianMonoidal.v Monoidal/Examples/BinopCartesianMonoidal.v Monoidal/Examples/SetWithSubset.v Monoidal/Examples/SmashProductMonoidal.v Monoidal/Examples/PosetsMonoidal.v Monoidal/Examples/Fullsub.v Monoidal/Examples/Relations.v Monoidal/Examples/Sigma.v Monoidal/Examples/DiagonalFunctor.v Monoidal/Examples/ConstantFunctor.v Monoidal/Comonoids/Category.v Monoidal/Comonoids/Tensor.v Monoidal/Comonoids/Monoidal.v Monoidal/Comonoids/Symmetric.v Monoidal/Comonoids/MonoidalCartesianBuilder.v Monoidal/Comonoids/CommComonoidsCartesian.v Monoidal/Comonoids/CartesianAsComonoids.v Monoidal/Comonoids/TransportComonoidAlongRetraction.v Monoidal/Examples/LiftPoset.v Monoidal/Examples/SymmetricMonoidalCoEilenbergMoore.v Monoidal/AlternativeDefinitions/MonoidalCategoriesReordered.v Monoidal/AlternativeDefinitions/MonoidalCategoriesTensored.v Monoidal/AlternativeDefinitions/EquivalenceWhiskeredNonCurriedMonoidalCategories.v Monoidal/AlternativeDefinitions/MonoidalCategoriesCurried.v Monoidal/AlternativeDefinitions/MonoidalFunctorsTensored.v Monoidal/AlternativeDefinitions/MonoidalFunctorsCurried.v Monoidal/AlternativeDefinitions/AugmentedSimplexCategory.v Monoidal/AlternativeDefinitions/DisplayedMonoidalTensored.v Monoidal/AlternativeDefinitions/DisplayedMonoidalCurried.v Monoidal/AlternativeDefinitions/CategoriesOfMonoids.v Monoidal/AlternativeDefinitions/BraidedMonoidalCategories.v Monoidal/AlternativeDefinitions/TotalDisplayedMonoidalCurried.v Monoidal/AlternativeDefinitions/MonoidalFunctorCategory.v Actegories/Actegories.v Actegories/ConstructionOfActegories.v Actegories/MorphismsOfActegories.v Actegories/ProductActegory.v Actegories/ProductsInActegories.v Actegories/CoproductsInActegories.v Actegories/Examples/ActionOfEndomorphismsInCATElementary.v Actegories/Examples/SelfActionInCATElementary.v Actegories/ConstructionOfActegoryMorphisms.v Actegories/ActionBasedStrongMonads.v DisplayedCats/MoreFibrations/Prefibrations.v DisplayedCats/MoreFibrations/CartesiannessOfComposites.v DisplayedCats/MoreFibrations/FibrationsCharacterisation.v DisplayedCats/MoreFibrations/DispCatsEquivFunctors.v DisplayedCats/MoreFibrations/DisplayedDisplayedCats.v SkewMonoidal/SkewMonoidalCategories.v SkewMonoidal/CategoriesOfMonoids.v EnrichedCats/Enrichment.v EnrichedCats/EnrichmentFunctor.v EnrichedCats/EnrichmentTransformation.v EnrichedCats/FullyFaithful.v EnrichedCats/EnrichmentAdjunction.v EnrichedCats/EnrichmentMonad.v EnrichedCats/Enriched/Enriched.v EnrichedCats/Enriched/ChangeOfBase.v EnrichedCats/Enriched/Opposite.v EnrichedCats/Enriched/UnderlyingCategory.v EnrichedCats/Enriched/EnrichmentEquiv.v EnrichedCats/Examples/SelfEnriched.v EnrichedCats/Limits/EnrichedTerminal.v EnrichedCats/Limits/EnrichedBinaryProducts.v EnrichedCats/Limits/EnrichedProducts.v EnrichedCats/Limits/EnrichedEqualizers.v EnrichedCats/Limits/EnrichedConicalLimits.v EnrichedCats/Limits/EnrichedPowers.v EnrichedCats/Limits/EnrichedLimits.v EnrichedCats/Colimits/EnrichedInitial.v EnrichedCats/Colimits/EnrichedBinaryCoproducts.v EnrichedCats/Colimits/EnrichedCoproducts.v EnrichedCats/Colimits/EnrichedCoequalizers.v EnrichedCats/Colimits/EnrichedConicalColimits.v EnrichedCats/Colimits/EnrichedCopowers.v EnrichedCats/Colimits/EnrichedColimits.v EnrichedCats/Colimits/CopowerFunctor.v EnrichedCats/Examples/SetEnriched.v EnrichedCats/Examples/PosetEnriched.v EnrichedCats/Examples/StructureEnriched.v EnrichedCats/Examples/SmashStructureEnriched.v EnrichedCats/Examples/HomFunctor.v EnrichedCats/Examples/OppositeEnriched.v EnrichedCats/Examples/FunctorCategory.v EnrichedCats/Examples/Yoneda.v EnrichedCats/YonedaLemma.v EnrichedCats/Examples/EmptyEnriched.v EnrichedCats/Examples/UnitEnriched.v EnrichedCats/Examples/FullSubEnriched.v EnrichedCats/Examples/ImageEnriched.v EnrichedCats/Examples/DialgebraEnriched.v EnrichedCats/Examples/SliceEnriched.v EnrichedCats/Examples/EilenbergMooreEnriched.v EnrichedCats/Examples/ProductEnriched.v EnrichedCats/Examples/ChangeOfBase.v EnrichedCats/EnrichedRezkCompletion.v EnrichedCats/Examples/KleisliEnriched.v EnrichedCats/Examples/UnivalentKleisliEnriched.v EnrichedCats/Limits/Examples/OppositeEnrichedLimits.v EnrichedCats/Limits/Examples/PosetEnrichedLimits.v EnrichedCats/Limits/Examples/StructureEnrichedLimits.v EnrichedCats/Limits/Examples/SelfEnrichedLimits.v EnrichedCats/Colimits/Examples/OppositeEnrichedColimits.v EnrichedCats/Colimits/Examples/PosetEnrichedColimits.v EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v EnrichedCats/Colimits/Examples/SelfEnrichedColimits.v GrothendieckConstruction/TotalCategory.v GrothendieckConstruction/IsosInTotal.v GrothendieckConstruction/Projection.v GrothendieckConstruction/IsOpfibration.v GrothendieckConstruction/IsPullback.v # Twosided displayed categories TwoSidedDisplayedCats/TwoSidedDispCat.v TwoSidedDisplayedCats/Isos.v TwoSidedDisplayedCats/Univalence.v TwoSidedDisplayedCats/Discrete.v TwoSidedDisplayedCats/Total.v TwoSidedDisplayedCats/TwoSidedFibration.v TwoSidedDisplayedCats/Fiber.v TwoSidedDisplayedCats/DisplayedFunctor.v TwoSidedDisplayedCats/DisplayedNatTrans.v TwoSidedDisplayedCats/Examples/Constant.v TwoSidedDisplayedCats/Examples/DispCatOnTwoSidedDispCat.v TwoSidedDisplayedCats/Examples/FiberwiseProduct.v TwoSidedDisplayedCats/Examples/Arrow.v TwoSidedDisplayedCats/Examples/Bimodules.v TwoSidedDisplayedCats/Examples/Comma.v TwoSidedDisplayedCats/Examples/IsoComma.v TwoSidedDisplayedCats/Examples/Lenses.v TwoSidedDisplayedCats/Examples/Product.v TwoSidedDisplayedCats/Examples/ProdOfTwosidedDispCat.v TwoSidedDisplayedCats/Examples/Profunctor.v TwoSidedDisplayedCats/Examples/Reindex.v TwoSidedDisplayedCats/Examples/Relations.v TwoSidedDisplayedCats/Examples/Spans.v TwoSidedDisplayedCats/Examples/StructuredCospans.v # Indexed Categories IndexedCategories/IndexedCategory.v IndexedCategories/IndexedFunctor.v IndexedCategories/IndexedTransformation.v IndexedCategories/FibrationToIndexedCategory.v IndexedCategories/CartesianToIndexedFunctor.v IndexedCategories/NatTransToIndexed.v IndexedCategories/IndexedCategoryToFibration.v IndexedCategories/IndexedFunctorToCartesian.v IndexedCategories/IndexedTransformationToTransformation.v IndexedCategories/OpIndexedCategory.v IndexedCategories/CoreIndexedCategory.v # RepresentableFunctors RepresentableFunctors/Precategories.v RepresentableFunctors/Bifunctor.v RepresentableFunctors/Representation.v RepresentableFunctors/RawMatrix.v RepresentableFunctors/DirectSum.v RepresentableFunctors/Test.v # Monoidal Rezk Completion Monoidal/RezkCompletion/LiftedTensor.v Monoidal/RezkCompletion/LiftedTensorUnit.v Monoidal/RezkCompletion/LiftedUnitors.v Monoidal/RezkCompletion/LiftedAssociator.v Monoidal/RezkCompletion/LiftedMonoidal.v Monoidal/RezkCompletion/MonoidalRezkCompletion.v # Dagger categories DaggerCategories/Categories.v DaggerCategories/Unitary.v DaggerCategories/Univalence.v DaggerCategories/Functors.v DaggerCategories/Transformations.v DaggerCategories/FunctorCategory.v DaggerCategories/Examples/Groupoids.v DaggerCategories/Examples/Relations.v DaggerCategories/Examples/Fullsub.v DaggerCategories/Functors/WeakEquivalences.v DaggerCategories/Functors/FullyFaithful.v DaggerCategories/Functors/Factorization.v DaggerCategories/Functors/Precomp.v DaggerCategories/CatIso.v UniMath-20231010/UniMath/CategoryTheory/Abelian.v000066400000000000000000001656531451125700300213660ustar00rootroot00000000000000(** * Abelian categories *) (** ** Contents - Definition of Abelian categories - isMonic f -> isEpi f -> is_z_isomorphism f - Pushouts of monics and pullbacks of epis - Pushouts of monics - Pullbacks of epis - Equalizers and Coequalizers - Equalizers - Coequalizers - Pullbacks and Pushouts - Results on Monics and Epis - Monic implies Zero kernel - Epi implies Zero cokernel - Zero kernel implies Monic - Zero cokernel implies Epi - Factorization of morphisms - CoIm to Im factorization - Epi ;; Monic factorization - Monic is kernel of any cokernel of it, Epi is cokernel of any kernel of it - A Abelian -> A^op Abelian *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Local Open Scope cat. (** * Definition of Abelian categories Abelian category is a [precategory] which has - A zero object - Binary products and binary coproducts - Kernels and cokernels - Every monic is kernel of its cokernel and every epi is cokernel of its kernel *) Section def_abelian. (** ** Data1 - Zero - Binary direct products - Binary direct coproducts *) Definition Data1 (C : category) : UU := Zero C × (BinProducts C) × (BinCoproducts C). Definition make_Data1 {C : category} (H1 : Zero C) (H2 : BinProducts C) (H3 : BinCoproducts C) : Data1 C := (H1,,(H2,,H3)). Definition to_Zero {C : category} (D : Data1 C) : Zero C := dirprod_pr1 D. Definition to_BinProducts {C : category} (D : Data1 C) : BinProducts C := dirprod_pr1 (dirprod_pr2 D). Definition to_BinCoproducts {C : category} (D : Data1 C) : BinCoproducts C := dirprod_pr2 (dirprod_pr2 D). (** ** Data2 - Kernels - Cokernels *) Definition Data2 (C : category) (D1 : Data1 C) : UU := (Kernels (to_Zero D1)) × (Cokernels (to_Zero D1)). Definition make_Data2 {C : category} (D1 : Data1 C) (H1 : Kernels (to_Zero D1)) (H2 : Cokernels (to_Zero D1)) : Data2 C D1 := make_dirprod H1 H2. Definition to_Kernels {C : category} {D1 : Data1 C} (D2 : Data2 C D1) : Kernels (to_Zero D1) := dirprod_pr1 D2. Definition to_Cokernels {C : category} {D1 : Data1 C} (D2 : Data2 C D1) : Cokernels (to_Zero D1) := dirprod_pr2 D2. (** ** Every monic is kernel of its cokernel *) Definition MonicsAreKernels (C : category) (D1 : Data1 C) (D2 : Data2 C D1) : UU := ∏ (x y : C) (M : Monic C x y), isKernel (pr1 D1) M (CokernelArrow (to_Cokernels D2 x y M)) (CokernelCompZero (to_Zero D1) (to_Cokernels D2 x y M)). Definition make_MonicsAreKernels {C : category} (D1 : Data1 C) (D2 : Data2 C D1) (H : ∏ (x y : C) (M : Monic C x y), isKernel (pr1 D1) M (CokernelArrow (to_Cokernels D2 x y M)) (CokernelCompZero (to_Zero D1) (to_Cokernels D2 x y M))) : MonicsAreKernels C D1 D2 := H. (** ** Every epi is a cokernel of its kernel *) Definition EpisAreCokernels (C : category) (D1 : Data1 C) (D2 : Data2 C D1) : UU := ∏ (x y : C) (E : Epi C x y), isCokernel (pr1 D1) (KernelArrow (to_Kernels D2 x y E)) E (KernelCompZero (to_Zero D1) (to_Kernels D2 x y E)). Definition make_EpisAreCokernels {C : category} (D1 : Data1 C) (D2 : Data2 C D1) (H : ∏ (x y : C) (E : Epi C x y), isCokernel (pr1 D1) (KernelArrow (to_Kernels D2 x y E)) E (KernelCompZero (to_Zero D1) (to_Kernels D2 x y E))) : EpisAreCokernels C D1 D2 := H. (** ** AbelianData - Data2 - MonicsAreKernels - EpisAreCokernels *) Definition AbelianData (C : category) (D1 : Data1 C) : UU := ∑ D2 : Data2 C D1, (MonicsAreKernels C D1 D2) × (EpisAreCokernels C D1 D2). Definition make_AbelianData {C : category} {D1 : Data1 C} (D2 : Data2 C D1) (H1 : MonicsAreKernels C D1 D2) (H2 : EpisAreCokernels C D1 D2) : AbelianData C D1 := tpair _ D2 (make_dirprod H1 H2). (** ** Abelian categories *) Definition AbelianPreCat : UU := ∑ A : (∑ C : category, Data1 C), AbelianData (pr1 A) (pr2 A). Definition precategory_of_AbelianPreCat (A : AbelianPreCat) : category := pr1 (pr1 A). Coercion precategory_of_AbelianPreCat : AbelianPreCat >-> category. Definition make_Abelian (C : category) (AD1 : Data1 C) (AD : AbelianData C AD1) : AbelianPreCat := tpair _ (tpair _ C AD1) AD. Definition to_Data1 (A : AbelianPreCat) : Data1 A := pr2 (pr1 A). Coercion to_Data1 : AbelianPreCat >-> Data1. Definition to_Data2 (A : AbelianPreCat) : Data2 A (to_Data1 A) := pr1 (pr2 A). Coercion to_Data2 : AbelianPreCat >-> Data2. Definition to_MonicsAreKernels (A : AbelianPreCat) : MonicsAreKernels A (to_Data1 A) (to_Data2 A) := dirprod_pr1 (pr2 (pr2 A)). Definition to_EpisAreCokernels (A : AbelianPreCat) : EpisAreCokernels A (to_Data1 A) (to_Data2 A) := dirprod_pr2 (pr2 (pr2 A)). Definition MonicToKernel {A : AbelianPreCat} {x y : A} (M : Monic A x y) : Kernel (to_Zero A) (CokernelArrow (to_Cokernels A x y M)) := make_Kernel (to_Zero A) _ _ _ (to_MonicsAreKernels A x y M). Definition EpiToCokernel {A : AbelianPreCat} {x y : A} (E : Epi A x y) : Cokernel (to_Zero A) (KernelArrow (to_Kernels A x y E)) := make_Cokernel (to_Zero A) _ _ _ (to_EpisAreCokernels A x y E). End def_abelian. Arguments to_Zero [C]. Declare Scope abelian_precat_scope. Bind Scope abelian_precat_scope with precategory. Declare Scope abelian_precat. Notation "0" := Zero : abelian_precat. Delimit Scope abelian_precat_scope with precategory. (** * isMonic f -> isEpi f -> is_z_isomorphism f In abelian categories morphisms which are both monic and epi are isomorphisms [monic_epi_is_iso]. *) Section abelian_monic_epi_iso. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. Local Lemma monic_epi_is_iso_eq {x y : A} {f : x --> y} (iM : isMonic f) (iE : isEpi f) : identity y · (CokernelArrow (to_Cokernels A x y (make_Monic _ _ iM))) = ZeroArrow (to_Zero A) y (to_Cokernels A x y (make_Monic _ _ iM)). Proof. rewrite id_left. apply iE. set (p0 := KernelCompZero _ (MonicToKernel (make_Monic _ _ iM))). rewrite <- (ZeroArrow_comp_right _ _ _ _ _ f) in p0. exact p0. Qed. Lemma monic_epi_is_iso_inverses {x y : A} {f : x --> y} (iM : isMonic f) (iE : isEpi f) : is_inverse_in_precat f (KernelIn (to_Zero A) (MonicToKernel (make_Monic A f iM)) y (identity y) (monic_epi_is_iso_eq iM iE)). Proof. use make_is_inverse_in_precat. - apply iM. cbn. rewrite <- assoc. rewrite (KernelCommutes (to_Zero A) (MonicToKernel (make_Monic A f iM))). rewrite id_right. rewrite id_left. apply idpath. - exact (KernelCommutes (to_Zero A) (MonicToKernel (make_Monic A f iM)) _ _ _). Qed. Lemma monic_epi_is_iso {x y : A} {f : x --> y} : isMonic f -> isEpi f -> is_z_isomorphism f. Proof. intros iM iE. use make_is_z_isomorphism. - exact (KernelIn (to_Zero A) (MonicToKernel (make_Monic _ _ iM)) y (identity y) (monic_epi_is_iso_eq iM iE)). - exact (monic_epi_is_iso_inverses iM iE). Defined. Lemma monic_epi_z_iso {x y : A} {f : x --> y} : isMonic f -> isEpi f -> z_iso x y. Proof. intros iM iE. use make_z_iso. - exact f. - exact (KernelIn (to_Zero A) (MonicToKernel (make_Monic _ _ iM)) y (identity y) (monic_epi_is_iso_eq iM iE)). - exact (monic_epi_is_iso_inverses iM iE). Defined. End abelian_monic_epi_iso. (** * Pullbacks of monics and pushouts of epis In the following section we prove that an abelian category has pullbacks of monics and pushouts of epis. *) Section abelian_monic_pullbacks. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** Pullbacks of monics *) Local Lemma monics_Pullback_eq1 {x y z : A} (M1 : Monic A x z) (M2 : Monic A y z) (BinProd : BinProduct A (to_Cokernels A x z M1) (to_Cokernels A y z M2)) (ker : Kernel (to_Zero A) (BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2)))) : KernelArrow ker · (CokernelArrow (to_Cokernels A x z M1)) = ZeroArrow (to_Zero A) _ _. Proof. set (tmp := BinProductPr1Commutes A _ _ BinProd _ (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). apply (maponpaths (λ h : _, KernelArrow ker · h)) in tmp. apply (pathscomp0 (!tmp)). clear tmp. rewrite assoc. rewrite (KernelCompZero (to_Zero A) ker). apply ZeroArrow_comp_left. Qed. Local Lemma monics_Pullback_eq2 {x y z : A} (M1 : Monic A x z) (M2 : Monic A y z) (BinProd : BinProduct A (to_Cokernels A x z M1) (to_Cokernels A y z M2)) (ker : Kernel (to_Zero A) (BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2)))) : KernelArrow ker · (CokernelArrow (to_Cokernels A y z M2)) = ZeroArrow (to_Zero A) _ _. Proof. set (tmp := BinProductPr2Commutes A _ _ BinProd _ (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). apply (maponpaths (λ h : _, KernelArrow ker · h)) in tmp. apply (pathscomp0 (!tmp)). clear tmp. rewrite assoc. rewrite (KernelCompZero (to_Zero A) ker). apply ZeroArrow_comp_left. Qed. Local Lemma monics_Pullback_eq3 {x y z : A} (M1 : Monic A x z) (M2 : Monic A y z) (BinProd : BinProduct A (to_Cokernels A x z M1) (to_Cokernels A y z M2)) (ker : Kernel (to_Zero A) (BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2)))) : KernelIn (to_Zero A) (MonicToKernel M1) ker (KernelArrow ker) (monics_Pullback_eq1 M1 M2 BinProd ker) · M1 = KernelIn (to_Zero A) (MonicToKernel M2) ker (KernelArrow ker) (monics_Pullback_eq2 M1 M2 BinProd ker) · M2. Proof. rewrite (KernelCommutes (to_Zero A) (MonicToKernel M1) _ (KernelArrow ker)). rewrite (KernelCommutes (to_Zero A) (MonicToKernel M2) _ (KernelArrow ker)). apply idpath. Qed. Local Lemma monics_Pullback_isPullback {x y z : A} (M1 : Monic A x z) (M2 : Monic A y z) (BinProd : BinProduct A (to_Cokernels A x z M1) (to_Cokernels A y z M2)) (ker : Kernel (to_Zero A) (BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2)))) : @isPullback _ _ _ _ _ M1 M2 (KernelIn (to_Zero A) (MonicToKernel M1) ker (KernelArrow ker) (monics_Pullback_eq1 M1 M2 BinProd ker)) (KernelIn (to_Zero A) (MonicToKernel M2) ker (KernelArrow ker) (monics_Pullback_eq2 M1 M2 BinProd ker)) (monics_Pullback_eq3 M1 M2 BinProd ker). Proof. (* variables *) set (ker1 := MonicToKernel M1). set (ker2 := MonicToKernel M2). set (ar := BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). assert (com1 : KernelIn (to_Zero A) ker1 ker (KernelArrow ker) (monics_Pullback_eq1 M1 M2 BinProd ker) · M1 = KernelArrow ker). { apply (KernelCommutes (to_Zero A) ker1 _ (KernelArrow ker)). } assert (com2 : KernelIn (to_Zero A) ker2 ker (KernelArrow ker) (monics_Pullback_eq2 M1 M2 BinProd ker) · M2 = KernelArrow ker). { apply (KernelCommutes (to_Zero A) ker2 _ (KernelArrow ker)). } (* isPullback *) use make_isPullback. intros e h k H. (* First we show that h · M1 · ar = ZeroArrow by uniqueness of the morphism to product. *) assert (e1 : h · (KernelArrow ker1) · (CokernelArrow (to_Cokernels A x z M1)) = ZeroArrow (to_Zero A) _ _). { rewrite <- assoc. set (ee1 := KernelCompZero (to_Zero A) ker1). cbn in ee1. cbn. rewrite ee1. apply ZeroArrow_comp_right. } assert (e2 : k · (KernelArrow ker2) · (CokernelArrow (to_Cokernels A y z M2)) = ZeroArrow (to_Zero A) _ _). { rewrite <- assoc. set (ee2 := KernelCompZero (to_Zero A) ker2). cbn in ee2. cbn. rewrite ee2. apply ZeroArrow_comp_right. } cbn in e1, e2. assert (e'1 : h · M1 · (CokernelArrow (to_Cokernels A y z M2)) = ZeroArrow (to_Zero A) _ _). { rewrite H. apply e2. } assert (e''1 : h · M1 · ar = ZeroArrow (to_Zero A) _ _). { rewrite (BinProductArrowEta A _ _ BinProd e (h · M1 · ar)). use BinProductArrowZero. - rewrite <- assoc. set (tmp1 := BinProductPr1Commutes A _ _ BinProd _ (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). fold ar in tmp1. rewrite tmp1. apply e1. - rewrite <- assoc. set (tmp1 := BinProductPr2Commutes A _ _ BinProd _ (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). fold ar in tmp1. rewrite tmp1. apply e'1. } use unique_exists. (* The arrow *) - use (KernelIn (to_Zero A) ker e (h · M1)). apply e''1. (* commutativity *) - split. + use (KernelInsEq (to_Zero A) ker1). cbn. rewrite <- assoc. set (com'1 := maponpaths (λ f : _, KernelIn (to_Zero A) ker e (h · M1) e''1 · f) com1). cbn in com'1. use (pathscomp0 com'1). use KernelCommutes. + use (KernelInsEq (to_Zero A) ker2). cbn. rewrite <- assoc. set (com'2 := maponpaths (λ f : _, KernelIn (to_Zero A) ker e (h · M1) e''1 · f) com2). cbn in com'2. use (pathscomp0 com'2). rewrite <- H. use KernelCommutes. (* Equality of equalities of morphisms *) - intros y0. apply isapropdirprod. + apply hs. + apply hs. (* Uniqueness *) - intros y0 t. cbn in t. induction t as [t p]. apply (KernelArrowisMonic (to_Zero A) ker). rewrite (KernelCommutes (to_Zero A) ker). rewrite <- (KernelCommutes (to_Zero A) ker1 ker _ (monics_Pullback_eq1 M1 M2 BinProd ker)). rewrite assoc. use (pathscomp0 (maponpaths (λ f : _, f · KernelArrow ker1) t)). apply idpath. Qed. (** Construction of the Pullback of monics. *) Definition monics_Pullback {x y z : A} (M1 : Monic A x z) (M2 : Monic A y z) : Pullback M1 M2. Proof. set (ker1 := MonicToKernel M1). set (ker2 := MonicToKernel M2). set (BinProd := to_BinProducts A (to_Cokernels A x z M1) (to_Cokernels A y z M2)). set (ar := BinProductArrow A BinProd (CokernelArrow (to_Cokernels A x z M1)) (CokernelArrow (to_Cokernels A y z M2))). set (ker := to_Kernels A _ _ ar). use (@make_Pullback _ _ _ _ M1 M2 ker (KernelIn (to_Zero A) ker1 ker (KernelArrow ker) (monics_Pullback_eq1 M1 M2 BinProd ker)) (KernelIn (to_Zero A) ker2 ker (KernelArrow ker) (monics_Pullback_eq2 M1 M2 BinProd ker)) (monics_Pullback_eq3 M1 M2 BinProd ker) (monics_Pullback_isPullback M1 M2 BinProd ker)). Defined. (** ** Pushouts of epis *) Definition epis_Pushout_eq1 {x y z : A} (E1 : Epi A x y) (E2 : Epi A x z) (BinCoprod : BinCoproduct (*A*) (to_Kernels A x y E1) (to_Kernels A x z E2)) (coker : Cokernel (to_Zero A) (BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2)))) : (KernelArrow (to_Kernels A x y E1)) · CokernelArrow coker = ZeroArrow (to_Zero A) (to_Kernels A x y E1) coker. Proof. set (tmp := BinCoproductIn1Commutes A _ _ BinCoprod _ (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). apply (maponpaths (λ h : _, h · CokernelArrow coker)) in tmp. apply (pathscomp0 (!tmp)). rewrite <- assoc. rewrite (CokernelCompZero (to_Zero A) coker). apply ZeroArrow_comp_right. Qed. Definition epis_Pushout_eq2 {x y z : A} (E1 : Epi A x y) (E2 : Epi A x z) (BinCoprod : BinCoproduct (*A*) (to_Kernels A x y E1) (to_Kernels A x z E2)) (coker : Cokernel (to_Zero A) (BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2)))) : (KernelArrow (to_Kernels A x z E2)) · CokernelArrow coker = ZeroArrow (to_Zero A) (to_Kernels A x z E2) coker. Proof. set (tmp := BinCoproductIn2Commutes A _ _ BinCoprod _ (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). apply (maponpaths (λ h : _, h · CokernelArrow coker)) in tmp. apply (pathscomp0 (!tmp)). rewrite <- assoc. rewrite (CokernelCompZero (to_Zero A) coker). apply ZeroArrow_comp_right. Qed. Definition epis_Pushout_eq3 {x y z : A} (E1 : Epi A x y) (E2 : Epi A x z) (BinCoprod : BinCoproduct (*A*) (to_Kernels A x y E1) (to_Kernels A x z E2)) (coker : Cokernel (to_Zero A) (BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2)))) : E1 · (CokernelOut (to_Zero A) (EpiToCokernel E1) coker (CokernelArrow coker) (epis_Pushout_eq1 E1 E2 BinCoprod coker)) = E2 · (CokernelOut (to_Zero A) (EpiToCokernel E2) coker (CokernelArrow coker) (epis_Pushout_eq2 E1 E2 BinCoprod coker)). Proof. rewrite (CokernelCommutes (to_Zero A) (EpiToCokernel E1) _ (CokernelArrow coker)). rewrite (CokernelCommutes (to_Zero A) (EpiToCokernel E2) _ (CokernelArrow coker)). apply idpath. Qed. Definition epis_Pushout_isPushout {x y z : A} (E1 : Epi A x y) (E2 : Epi A x z) (BinCoprod : BinCoproduct (*A*) (to_Kernels A x y E1) (to_Kernels A x z E2)) (coker : Cokernel (to_Zero A) (BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2)))) : isPushout E1 E2 (CokernelOut (to_Zero A) (EpiToCokernel E1) coker (CokernelArrow coker) (epis_Pushout_eq1 E1 E2 BinCoprod coker)) (CokernelOut (to_Zero A) (EpiToCokernel E2) coker (CokernelArrow coker) (epis_Pushout_eq2 E1 E2 BinCoprod coker)) (epis_Pushout_eq3 E1 E2 BinCoprod coker). Proof. set (coker1 := EpiToCokernel E1). set (coker2 := EpiToCokernel E2). set (ar := BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). assert (com1 : E1 · (CokernelOut (to_Zero A) coker1 coker (CokernelArrow coker) (epis_Pushout_eq1 E1 E2 BinCoprod coker)) = CokernelArrow coker). { apply (CokernelCommutes (to_Zero A) coker1 _ (CokernelArrow coker)). } assert (com2 : E2 · (CokernelOut (to_Zero A) coker2 coker (CokernelArrow coker) (epis_Pushout_eq2 E1 E2 BinCoprod coker)) = CokernelArrow coker). { apply (CokernelCommutes (to_Zero A) coker2 _ (CokernelArrow coker)). } (* isPushout *) use make_isPushout. intros e h k H. (* First we show that h · M1 · ar = ZeroArrow by uniqueness of the morphism to product. *) assert (e1 : (KernelArrow (to_Kernels A x y E1)) · (CokernelArrow coker1) · h = ZeroArrow (to_Zero A) _ _). { set (ee1 := CokernelCompZero (to_Zero A) coker1). cbn in ee1. cbn. rewrite ee1. apply ZeroArrow_comp_left. } assert (e2 : (KernelArrow (to_Kernels A x z E2)) · (CokernelArrow coker2) · k = ZeroArrow (to_Zero A) _ _). { set (ee2 := CokernelCompZero (to_Zero A) coker2). cbn in ee2. cbn. rewrite ee2. apply ZeroArrow_comp_left. } cbn in e1, e2. assert (e'1 : (KernelArrow (to_Kernels A x z E2)) · E1 · h = ZeroArrow (to_Zero A) _ _). { rewrite <- assoc. rewrite H. rewrite assoc. apply e2. } assert (e'2 : (KernelArrow (to_Kernels A x y E1)) · E2 · k = ZeroArrow (to_Zero A) _ _). { rewrite <- assoc. rewrite <- H. rewrite assoc. apply e1. } assert (e''1 : ar · (E1 · h) = ZeroArrow (to_Zero A) _ _). { rewrite assoc. rewrite (BinCoproductArrowEta A _ _ BinCoprod e (ar · E1 · h)). use BinCoproductArrowZero. - rewrite assoc. rewrite assoc. set (tmp1 := BinCoproductIn1Commutes A _ _ BinCoprod _ (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). fold ar in tmp1. rewrite tmp1. apply e1. - rewrite assoc. rewrite assoc. set (tmp1 := BinCoproductIn2Commutes A _ _ BinCoprod _ (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). fold ar in tmp1. rewrite tmp1. apply e'1. } use unique_exists. (* The arrow *) - use (CokernelOut (to_Zero A) coker e (E1 · h)). apply e''1. (* Commutativity *) - split. + use (CokernelOutsEq (to_Zero A) coker1). cbn. set (com'1 := maponpaths (λ f : _, f · CokernelOut (to_Zero A) coker e (E1 · h) e''1) com1). cbn in com'1. rewrite assoc. use (pathscomp0 com'1). use CokernelCommutes. + use (CokernelOutsEq (to_Zero A) coker2). cbn. set (com'2 := maponpaths (λ f : _, f · CokernelOut (to_Zero A) coker e (E1 · h) e''1) com2). cbn in com'2. rewrite assoc. use (pathscomp0 com'2). rewrite <- H. use CokernelCommutes. (* Equality on equalities of morphisms *) - intros y0. apply isapropdirprod. + apply hs. + apply hs. (* Uniqueness *) - intros y0 t. cbn in t. induction t as [t p]. apply (CokernelArrowisEpi (to_Zero A) coker). rewrite (CokernelCommutes (to_Zero A) coker). rewrite <- (CokernelCommutes (to_Zero A) coker1 coker _ (epis_Pushout_eq1 E1 E2 BinCoprod coker)). rewrite <- assoc. use (pathscomp0 (maponpaths (λ f : _, CokernelArrow coker1 · f) t)). apply idpath. Qed. Definition epis_Pushout {x y z: A} (E1 : Epi A x y) (E2 : Epi A x z) : Pushout E1 E2. Proof. set (coker1 := EpiToCokernel E1). set (coker2 := EpiToCokernel E2). set (BinCoprod := to_BinCoproducts A (to_Kernels A x y E1) (to_Kernels A x z E2)). set (ar := BinCoproductArrow (*A*) BinCoprod (KernelArrow (to_Kernels A x y E1)) (KernelArrow (to_Kernels A x z E2))). set (coker := to_Cokernels A _ _ ar). use (make_Pushout E1 E2 coker (CokernelOut (to_Zero A) coker1 coker (CokernelArrow coker) (epis_Pushout_eq1 E1 E2 BinCoprod coker)) (CokernelOut (to_Zero A) coker2 coker (CokernelArrow coker) (epis_Pushout_eq2 E1 E2 BinCoprod coker)) (epis_Pushout_eq3 E1 E2 BinCoprod coker) (epis_Pushout_isPushout E1 E2 BinCoprod coker)). Defined. End abelian_monic_pullbacks. (** * Equalizers and Coequalizers In the following section we show that equalizers and coequalizers exist in abelian categories. *) Section abelian_equalizers. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** Equalizers *) Definition Equalizer_isMonic {x y : A} (f : x --> y) : isMonic (BinProductArrow A (to_BinProducts A x y) (identity x) f). Proof. set (BinProd := to_BinProducts A x y). intros z h1 h2 H. apply (maponpaths (λ h : _, h · (BinProductPr1 A BinProd))) in H. rewrite <- assoc in H. rewrite <- assoc in H. set (com1 := BinProductPr1Commutes A _ _ BinProd x (identity x) f). rewrite com1 in H. rewrite (id_right h1) in H. rewrite (id_right h2) in H. exact H. Qed. Definition Equalizer_Pullback {x y : A} (f1 f2 : x --> y) : Pullback (BinProductArrow A (to_BinProducts A x y) (identity x) f1) (BinProductArrow A (to_BinProducts A x y) (identity x) f2) := monics_Pullback A (make_Monic A _ (Equalizer_isMonic f1)) (make_Monic A _ (Equalizer_isMonic f2)). Definition Equalizer_eq1 {x y : A} (f1 f2 : x --> y) : PullbackPr1 (Equalizer_Pullback f1 f2) = PullbackPr2 (Equalizer_Pullback f1 f2). Proof. set (BinProd := to_BinProducts A x y). set (ar1 := BinProductArrow A BinProd (identity x) f1). set (ar2 := BinProductArrow A BinProd (identity x) f2). set (Pb := Equalizer_Pullback f1 f2). assert (H1 : ar1 · (BinProductPr1 A BinProd) = identity x) by apply BinProductPr1Commutes. assert (H2 : ar2 · (BinProductPr1 A BinProd) = identity x) by apply BinProductPr1Commutes. use (pathscomp0 (! (id_right (PullbackPr1 Pb)))). use (pathscomp0 (! (maponpaths (λ h : _, PullbackPr1 Pb · h) H1))). use (pathscomp0 _ ((id_right (PullbackPr2 Pb)))). use (pathscomp0 _ (maponpaths (λ h : _, PullbackPr2 Pb · h) H2)). rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply PullbackSqrCommutes. Qed. Definition Equalizer_eq2 {x y : A} (f1 f2 : x --> y) : PullbackPr1 (Equalizer_Pullback f1 f2) · f1 = PullbackPr1 (Equalizer_Pullback f1 f2) · f2. Proof. set (BinProd := to_BinProducts A x y). set (ar1 := BinProductArrow A BinProd (identity x) f1). set (ar2 := BinProductArrow A BinProd (identity x) f2). set (H := Equalizer_eq1 f1 f2). set (Pb := Equalizer_Pullback f1 f2). assert (H1 : BinProductArrow A BinProd (identity x) f1 · (BinProductPr2 A BinProd) = f1) by apply BinProductPr2Commutes. assert (H2 : BinProductArrow A BinProd (identity x) f2 · (BinProductPr2 A BinProd) = f2) by apply BinProductPr2Commutes. rewrite <- H1. rewrite <- H2. rewrite assoc. rewrite assoc. apply cancel_postcomposition. unfold BinProd. set (X := PullbackSqrCommutes (Equalizer_Pullback f1 f2)). rewrite <- H in X. apply X. Qed. Definition isEqualizer {x y : A} (f1 f2 : x --> y) : isEqualizer f1 f2 (PullbackPr1 (Equalizer_Pullback f1 f2)) (Equalizer_eq2 f1 f2). Proof. set (BinProd := to_BinProducts A x y). set (ar1 := BinProductArrow A BinProd (identity x) f1). set (ar2 := BinProductArrow A BinProd (identity x) f2). set (H := Equalizer_eq1 f1 f2). use make_isEqualizer. intros w h HH. assert (HH' : h · ar1 = BinProductArrow A BinProd h (h · f1)). { apply (BinProductArrowUnique A _ _ BinProd). - rewrite <- assoc. set (com1 := BinProductPr1Commutes A _ _ BinProd x (identity x) f1). fold ar1 in com1. rewrite com1. apply id_right. - rewrite <- assoc. set (com2 := BinProductPr2Commutes A _ _ BinProd x (identity x) f1). fold ar1 in com2. rewrite com2. apply idpath. } assert (HH'' : h · ar2 = BinProductArrow A BinProd h (h · f1)). { apply (BinProductArrowUnique A _ _ BinProd). - rewrite <- assoc. set (com1 := BinProductPr1Commutes A _ _ BinProd x (identity x) f2). fold ar2 in com1. rewrite com1. apply id_right. - rewrite <- assoc. set (com2 := BinProductPr2Commutes A _ _ BinProd x (identity x) f2). fold ar2 in com2. rewrite com2. apply pathsinv0. apply HH. } assert (HH''' : h · ar1 = h · ar2). { rewrite HH'. rewrite HH''. apply idpath. } use unique_exists. (* The arrow *) - exact (PullbackArrow (Equalizer_Pullback f1 f2) w h h HH'''). (* Commutativity *) - apply (PullbackArrow_PullbackPr1 (Equalizer_Pullback f1 f2) w h h HH'''). (* Equality on equalities of morphisms *) - intros y0. apply hs. (* Uniqueness *) - intros y0 t. apply PullbackArrowUnique. + apply t. + rewrite <- H. apply t. Qed. Definition Equalizer {x y : A} (f1 f2 : x --> y) : Equalizer f1 f2 := make_Equalizer f1 f2 (PullbackPr1 (Equalizer_Pullback f1 f2)) (Equalizer_eq2 f1 f2) (isEqualizer f1 f2). Corollary Equalizers : @Equalizers A. Proof. intros X Y f g. apply Equalizer. Defined. (** ** Coequalizers *) Definition Coequalizer_isEpi {x y : A} (f : y --> x) : isEpi (BinCoproductArrow (*A*) (to_BinCoproducts A x y) (identity x) f). Proof. set (BinCoprod := to_BinCoproducts A x y). intros z h1 h2 H. apply (maponpaths (λ f : _, (BinCoproductIn1 (*A*) BinCoprod) · f)) in H. rewrite assoc in H. rewrite assoc in H. set (com1 := BinCoproductIn1Commutes A _ _ BinCoprod x (identity x) f). rewrite com1 in H. clear com1. rewrite (id_left h1) in H. rewrite (id_left h2) in H. exact H. Qed. Definition Coequalizer_Pushout {x y : A} (f1 f2 : y --> x) : Pushout (BinCoproductArrow (*A*) (to_BinCoproducts A x y) (identity x) f1) (BinCoproductArrow (*A*) (to_BinCoproducts A x y) (identity x) f2) := epis_Pushout A (make_Epi A _ (Coequalizer_isEpi f1)) (make_Epi A _ (Coequalizer_isEpi f2)). Definition Coequalizer_eq1 {x y : A} (f1 f2 : y --> x) : PushoutIn1 (Coequalizer_Pushout f1 f2) = PushoutIn2 (Coequalizer_Pushout f1 f2). Proof. set (BinCoprod := to_BinCoproducts A x y). set (ar1 := BinCoproductArrow (*A*) BinCoprod (identity x) f1). set (ar2 := BinCoproductArrow (*A*) BinCoprod (identity x) f2). set (Po := Coequalizer_Pushout f1 f2). assert (H1 : (BinCoproductIn1 (*A*) BinCoprod) · ar1 = identity x) by apply BinCoproductIn1Commutes. assert (H2 : (BinCoproductIn1 (*A*) BinCoprod) · ar2 = identity x) by apply BinCoproductIn1Commutes. use (pathscomp0 (!(id_left (PushoutIn1 Po)))). use (pathscomp0 (!(maponpaths (λ h : _, h · PushoutIn1 Po) H1))). use (pathscomp0 _ ((id_left (PushoutIn2 Po)))). use (pathscomp0 _ (maponpaths (λ h : _, h · PushoutIn2 Po) H2)). rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply PushoutSqrCommutes. Qed. Definition Coequalizer_eq2 {x y : A} (f1 f2 : y --> x) : f1 · PushoutIn1 (Coequalizer_Pushout f1 f2) = f2 · PushoutIn1 (Coequalizer_Pushout f1 f2). Proof. set (BinCoprod := to_BinCoproducts A x y). set (ar1 := BinCoproductArrow (*A*) BinCoprod (identity x) f1). set (ar2 := BinCoproductArrow (*A*) BinCoprod (identity x) f2). set (H := Coequalizer_eq1 f1 f2). set (Pb := Coequalizer_Pushout f1 f2). rewrite <- (BinCoproductIn2Commutes A _ _ BinCoprod _ (identity x) f1). rewrite <- (BinCoproductIn2Commutes A _ _ BinCoprod _ (identity x) f2). repeat rewrite <- assoc. apply cancel_precomposition. set (X := PushoutSqrCommutes (Coequalizer_Pushout f1 f2)). rewrite <- H in X. apply X. Qed. Definition isCoequalizer {x y : A} (f1 f2 : y --> x) : isCoequalizer f1 f2 (PushoutIn1 (Coequalizer_Pushout f1 f2)) (Coequalizer_eq2 f1 f2). Proof. set (BinCoprod := to_BinCoproducts A x y). set (ar1 := BinCoproductArrow (*A*) BinCoprod (identity x) f1). set (ar2 := BinCoproductArrow (*A*) BinCoprod (identity x) f2). set (H := Coequalizer_eq1 f1 f2). use make_isCoequalizer. intros w h HH. assert (HH' : ar1 · h = BinCoproductArrow (*A*) BinCoprod h (f1 · h)). { use (BinCoproductArrowUnique A _ _ BinCoprod). - rewrite assoc. set (com1 := BinCoproductIn1Commutes A _ _ BinCoprod x (identity x) f1). fold ar1 in com1. rewrite com1. apply id_left. - rewrite assoc. set (com2 := BinCoproductIn2Commutes A _ _ BinCoprod x (identity x) f1). fold ar1 in com2. rewrite com2. apply idpath. } assert (HH'' : ar2 · h = BinCoproductArrow BinCoprod h (f1 · h)). { apply (BinCoproductArrowUnique A _ _ BinCoprod). - rewrite assoc. set (com1 := BinCoproductIn1Commutes A _ _ BinCoprod x (identity x) f2). fold ar2 in com1. rewrite com1. apply id_left. - rewrite assoc. set (com2 := BinCoproductIn2Commutes A _ _ BinCoprod x (identity x) f2). fold ar2 in com2. rewrite com2. apply pathsinv0. apply HH. } assert (HH''' : ar1 · h = ar2 · h). { rewrite HH'. rewrite HH''. apply idpath. } use unique_exists. (* The arrow *) - exact (PushoutArrow (Coequalizer_Pushout f1 f2) w h h HH'''). (* commutativity *) - apply (PushoutArrow_PushoutIn1 (Coequalizer_Pushout f1 f2) w h h HH'''). (* Equality of equality of morphisms *) - intros y0. apply hs. (* Uniqueness *) - intros y0 t. apply PushoutArrowUnique. + apply t. + rewrite <- H. apply t. Qed. Definition Coequalizer {x y : A} (f1 f2 : y --> x) : Coequalizer f1 f2 := make_Coequalizer f1 f2 (PushoutIn1 (Coequalizer_Pushout f1 f2)) (Coequalizer_eq2 f1 f2) (isCoequalizer f1 f2). Corollary Coequalizers : @Coequalizers A. Proof. intros X Y f g. apply Coequalizer. Defined. End abelian_equalizers. (** * Pushouts and pullbacks Abelian categories have pullbacks and pushouts. *) Section abelian_pushouts. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. Definition Pullbacks : @Pullbacks A. Proof. apply (@Pullbacks_from_Equalizers_BinProducts A). apply (to_BinProducts A). apply (Equalizers A). Defined. Definition Pushouts : @Pushouts A. Proof. apply (@Pushouts_from_Coequalizers_BinCoproducts A). apply (to_BinCoproducts A). apply (Coequalizers A). Defined. End abelian_pushouts. (** * Monic kernels and Epi cokernels In this section we prove that kernels of monomorphisms are given by the arrows from zero and cokernels of epimorphisms are given by the arrows to zero. *) Section abelian_MonicToKernels. Variable A : AbelianPreCat. (** ** KernelArrow of Monic x --> y = (to_Zero A) --> x *) Definition MonicKernelZero_isKernel {x y : A} (M : Monic A x y) : isKernel (to_Zero A) (ZeroArrowFrom x) M (ArrowsFromZero A (to_Zero A) y (ZeroArrowFrom x · M) (ZeroArrow (to_Zero A) _ _)). Proof. use (make_isKernel). intros w h X. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ M) in X. apply (MonicisMonic _ M) in X. use unique_exists. (* The arrow *) - exact (ZeroArrow (to_Zero A) _ _). (* Commutativity *) - cbn. rewrite X. apply ZeroArrow_comp_left. (* Equality of equalities of morphisms *) - intros y0. apply (homset_property A). (* Uniqueness *) - intros y0 Y. apply ArrowsToZero. Qed. (* A kernel of a monic is the arrow from zero. *) Definition MonicKernelZero {x y : A} (M : Monic A x y) : Kernel (to_Zero A) M := make_Kernel (to_Zero A) (ZeroArrowFrom _) M _ (MonicKernelZero_isKernel M). (** ** CokernelArrow of Epi x --> y = y --> (to_Zero A) *) Definition EpiCokernelZero_isCokernel {y z : A} (E : Epi A y z) : isCokernel (to_Zero A) E (ZeroArrowTo z) (ArrowsToZero A (to_Zero A) y (E · ZeroArrowTo z) (ZeroArrow (to_Zero A) y (to_Zero A))). Proof. use make_isCokernel. intros w h X. rewrite <- (ZeroArrow_comp_right A (to_Zero A) y z w E) in X. apply (EpiisEpi _ E) in X. use unique_exists. (* The arrow *) - exact (ZeroArrow (to_Zero A) _ _). (* Commutativity *) - cbn. rewrite X. apply ZeroArrow_comp_right. (* Equality of equalities of morphisms *) - intros y0. apply (homset_property A). (* Uniqueness *) - intros y0 Y. apply ArrowsFromZero. Qed. (* A cokernel of an epi is the arrow to zero. *) Definition EpiCokernelZero {y z : A} (E : Epi A y z) : Cokernel (to_Zero A) E := make_Cokernel (to_Zero A) E (ZeroArrowTo z) _ (EpiCokernelZero_isCokernel E). (** ** KernelArrow = FromZero ⇒ isMonic *) (** The following Definitions is used in the next Definition. *) Local Definition KernelZeroMonic_cokernel {x y : A} {f1 f2 : x --> y} (e : f1 = f2) (CK : Cokernel (to_Zero A) f1) : Cokernel (to_Zero A) f2. Proof. use make_Cokernel. - exact CK. - exact (CokernelArrow CK). - induction e. apply CokernelCompZero. - induction e. apply (CokernelisCokernel _ CK). Defined. (** The morphism f is monic if its kernel is zero. *) Lemma KernelZeroisMonic {x y z : A} (f : y --> z) (H : ZeroArrow (to_Zero A) x y · f = ZeroArrow (to_Zero A) x z ) (isK : isKernel (to_Zero A) (ZeroArrow (to_Zero A) _ _) f H) : isMonic f. Proof. intros w u v H'. set (Coeq := Coequalizer A u v). set (Coeqar := CoequalizerOut Coeq z f H'). set (Coeqar_epi := CoequalizerArrowEpi Coeq). set (Coeq_coker := EpiToCokernel Coeqar_epi). set (ker := @make_Kernel A (to_Zero A) _ _ _ (ZeroArrow (to_Zero A) x y) f H isK). assert (e0 : CokernelArrow Coeq_coker = CoequalizerArrow Coeq). { apply idpath. } assert (e1 : f = (CokernelArrow Coeq_coker) · Coeqar). { apply pathsinv0. rewrite e0. set (XX := CoequalizerCommutes Coeq z f H'). fold Coeqar in XX. apply XX. } assert (e2 : (KernelArrow (to_Kernels A _ _ Coeqar_epi)) · f = ZeroArrow (to_Zero A) _ _). { rewrite e1. rewrite assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_left. } set (ar := KernelIn (to_Zero A) ker (to_Kernels A _ _ Coeqar_epi) (KernelArrow (to_Kernels A _ _ Coeqar_epi))). set (com1 := KernelCommutes (to_Zero A) ker (to_Kernels A _ _ Coeqar_epi) (KernelArrow (to_Kernels A _ _ Coeqar_epi)) e2). assert (e3 : KernelArrow ker = ZeroArrow (to_Zero A) _ _ ). { apply idpath. } assert (e4 : (KernelArrow (to_Kernels A _ _ Coeqar_epi)) = ZeroArrow (to_Zero A) _ _). { rewrite <- com1. apply ZeroArrow_comp_right. } assert (e5 : is_iso (CoequalizerArrow Coeq)). { set (coker2 := KernelZeroMonic_cokernel e4 Coeq_coker). apply (is_iso_qinv _ _ (CokernelofZeroArrow_is_iso (to_Zero A) coker2)). } set (isoar := make_iso (CoequalizerArrow Coeq) e5). set (coeq_eq := CoequalizerEqAr Coeq). apply (maponpaths (λ f : _, f · inv_from_iso isoar)) in coeq_eq. rewrite <- assoc in coeq_eq. rewrite <- assoc in coeq_eq. assert(areq : CoequalizerArrow Coeq = isoar). apply idpath. rewrite areq in coeq_eq. rewrite (iso_inv_after_iso isoar) in coeq_eq. rewrite <- id_right. rewrite <- coeq_eq. apply pathsinv0. apply id_right. Qed. Definition KernelZeroMonic {x y z : A} (f : y --> z) (H : ZeroArrow (to_Zero A) x y · f = ZeroArrow (to_Zero A) x z ) (isK : isKernel (to_Zero A) (ZeroArrow (to_Zero A) _ _) f H) : Monic A y z. Proof. exact (make_Monic A f (KernelZeroisMonic f H isK)). Defined. (** ** CokernelArrow = ToZero ⇒ isEpi *) (** The following Definition is used in the next Definition. *) Local Definition CokernelZeroEpi_kernel {x y : A} {f1 f2 : x --> y} (e : f1 = f2) (K : Kernel (to_Zero A) f1) : Kernel (to_Zero A) f2. Proof. use make_Kernel. - exact K. - exact (KernelArrow K). - induction e. apply KernelCompZero. - induction e. apply (KernelisKernel (to_Zero A) K). Defined. (** The morphism f is epic if its cokernel is zero. *) Lemma CokernelZeroisEpi {x y z : A} (f : x --> y) (H : f · ZeroArrow (to_Zero A) y z = ZeroArrow (to_Zero A) x z ) (isCK : isCokernel (to_Zero A) f (ZeroArrow (to_Zero A) _ _) H) : isEpi f. Proof. intros w u v H'. set (Eq := Equalizer A u v). set (Eqar := EqualizerIn Eq x f H'). set (Eqar_monic := EqualizerArrowMonic Eq). set (Eq_ker := MonicToKernel Eqar_monic). set (coker := @make_Cokernel A (to_Zero A) _ _ _ f (ZeroArrow (to_Zero A) y z) H isCK). assert (e0 : KernelArrow Eq_ker = EqualizerArrow Eq). { apply idpath. } assert (e1 : f = Eqar · (KernelArrow Eq_ker)). { apply pathsinv0. rewrite e0. set (XX := EqualizerCommutes Eq x f H'). fold Eqar in XX. apply XX. } assert (e2 : f · (CokernelArrow (to_Cokernels A _ _ Eqar_monic)) = ZeroArrow (to_Zero A) _ _). { rewrite e1. rewrite <- assoc. set (tmp := maponpaths (λ f : _, Eqar · f) (KernelCompZero (to_Zero A) Eq_ker)). use (pathscomp0 tmp). apply ZeroArrow_comp_right. } set (ar := CokernelOut (to_Zero A) coker (to_Cokernels A _ _ Eqar_monic) (CokernelArrow (to_Cokernels A _ _ Eqar_monic)) e2). set (com1 := CokernelCommutes (to_Zero A) coker (to_Cokernels A _ _ Eqar_monic) (CokernelArrow (to_Cokernels A _ _ Eqar_monic)) e2). assert (e3 : CokernelArrow coker = ZeroArrow (to_Zero A) _ _ ). { apply idpath. } assert (e4 : (CokernelArrow (to_Cokernels A _ _ Eqar_monic)) = ZeroArrow (to_Zero A) _ _). { rewrite <- com1. apply ZeroArrow_comp_left. } assert (e5 : is_iso (EqualizerArrow Eq)). { set (ker2 := CokernelZeroEpi_kernel e4 Eq_ker). apply (is_iso_qinv _ _ (KernelofZeroArrow_is_iso (to_Zero A) ker2)). } set (isoar := make_iso (EqualizerArrow Eq) e5). set (Eq_eq := EqualizerEqAr Eq). apply (maponpaths (λ f : _, inv_from_iso isoar · f)) in Eq_eq. rewrite assoc in Eq_eq. rewrite assoc in Eq_eq. assert(areq : EqualizerArrow Eq = isoar). apply idpath. rewrite areq in Eq_eq. rewrite (iso_after_iso_inv isoar) in Eq_eq. rewrite <- id_left. rewrite <- Eq_eq. apply pathsinv0. apply id_left. Qed. Definition CokernelZeroEpi {x y z : A} (f : x --> y) (H : f · ZeroArrow (to_Zero A) y z = ZeroArrow (to_Zero A) x z) (isCK : isCokernel (to_Zero A) f (ZeroArrow (to_Zero A) _ _) H) : Epi A x y. Proof. exact (make_Epi A f (CokernelZeroisEpi f H isCK)). Defined. End abelian_MonicToKernels. (** * Factorization of morphisms In this section we prove that every morphism factors as Epi · Monic in 2 canonical ways. To do this we need to prove that the canonical morphism CoIm f --> Im f is an isomorphism. *) Section abelian_factorization. Variable A : AbelianPreCat. (** ** Kernels, Cokernels, CoImage, and Image *) Definition Kernel {x y : A} (f : x --> y) : kernels.Kernel (to_Zero A) f := to_Kernels A x y f. Definition Cokernel {x y : A} (f : x --> y) : Cokernel (to_Zero A) f := to_Cokernels A x y f. Definition CoImage {x y : A} (f : x --> y) : cokernels.Cokernel (to_Zero A) (KernelArrow (Kernel f)) := to_Cokernels A _ _ (KernelArrow (Kernel f)). Definition Image {x y : A} (f : x --> y) : kernels.Kernel (to_Zero A) (CokernelArrow (Cokernel f)) := to_Kernels A _ _ (CokernelArrow (Cokernel f)). (** ** Construction of the morphism CoIm f --> Im f *) Lemma CoIm_ar_eq {x y : A} (f : x --> y) : KernelArrow (Kernel f) · f = ZeroArrow (to_Zero A) _ _. Proof. apply KernelCompZero. Qed. Definition CoIm_ar {x y : A} (f : x --> y) : A⟦CoImage f, y⟧. Proof. apply (CokernelOut (to_Zero A) (CoImage f) y f (CoIm_ar_eq f)). Defined. Definition CoIm_to_Im_eq1 {x y : A} (f : x --> y) : CokernelArrow (CoImage f) · CoIm_ar f · CokernelArrow (Cokernel f) = ZeroArrow (to_Zero A) _ _. Proof. set (tmp := CokernelCommutes (to_Zero A) (CoImage f) y f (CoIm_ar_eq f)). fold (CoIm_ar f) in tmp. rewrite tmp. apply CokernelCompZero. Qed. Definition CoIm_to_Im_eq2 {x y : A} (f : x --> y) : CoIm_ar f · CokernelArrow (Cokernel f) = ZeroArrow (to_Zero A) _ _. Proof. set (isE := CokernelArrowisEpi (to_Zero A) (CoImage f)). set (e1 := CoIm_to_Im_eq1 f). rewrite <- assoc in e1. rewrite <- (ZeroArrow_comp_right A (to_Zero A) _ _ _ (CokernelArrow (CoImage f))) in e1. apply isE in e1. exact e1. Qed. Definition CoIm_to_Im {x y : A} (f : x --> y) : A⟦CoImage f, Image f⟧ := KernelIn (to_Zero A) (Image f) (CoImage f) (CoIm_ar f) (CoIm_to_Im_eq2 f). (** ** f = (x --> CoIm f) · (CoIm f --> Im f) · (Im f --> y) *) Definition CoIm_to_Im_eq {x y : A} (f : x --> y) : f = (CokernelArrow (CoImage f)) · (CoIm_to_Im f) · (KernelArrow (Image f)). Proof. unfold CoIm_to_Im. (* Commutativity of cokernel *) set (com0 := CokernelCommutes (to_Zero A) (CoImage f) y f (CoIm_ar_eq f)). apply pathsinv0 in com0. use (pathscomp0 com0). (* Cancel precomposition *) rewrite <- assoc. apply cancel_precomposition. (* Commutativity of kernel *) set (com1 := KernelCommutes (to_Zero A) (Image f) (CoImage f) (CoIm_ar f) (CoIm_to_Im_eq2 f)). apply pathsinv0 in com1. use (pathscomp0 com1). (* idpath *) apply idpath. Qed. (** ** CoIm f --> Im f is an isomorphism. *) Lemma CoIm_to_Im_is_iso {x y : A} (f : x --> y) : is_z_isomorphism (CoIm_to_Im f). Proof. (* It suffices to show that this morphism is monic and epi. *) use monic_epi_is_iso. (* isMonic *) - use (isMonic_postcomp A _ (KernelArrow (Image f))). intros z g1 g2 H. set (q := Coequalizer A g1 g2). set (ar := CoIm_to_Im f · KernelArrow (Image f)). set (ar1 := CoequalizerOut q _ ar). set (com1 := CoequalizerCommutes q _ _ H). assert (isE : isEpi ((CokernelArrow (CoImage f)) · (CoequalizerArrow q))). { apply isEpi_comp. apply CokernelArrowisEpi. apply CoequalizerArrowisEpi. } set (E := make_Epi A ((CokernelArrow (CoImage f)) · (CoequalizerArrow q)) isE). set (coker := EpiToCokernel E). assert (e0 : (KernelArrow (to_Kernels A _ _ E)) · ((CokernelArrow (CoImage f)) · (CoequalizerArrow q)) = ZeroArrow (to_Zero A) _ (EpiToCokernel E)). { set (tmp := CokernelCompZero (to_Zero A) (EpiToCokernel E)). rewrite <- tmp. apply cancel_precomposition. unfold E. apply idpath. } assert (e : (KernelArrow (to_Kernels A _ _ E)) · f = ZeroArrow (to_Zero A) _ _). { (* Use CoImage Image equation *) set (tmp := CoIm_to_Im_eq f). apply (maponpaths (λ f : _, (KernelArrow (to_Kernels A _ _ E)) · f)) in tmp. use (pathscomp0 tmp). (* rewrite com1 *) rewrite <- assoc. rewrite <- com1. (* cancel postcompostion and use e0 *) rewrite assoc. rewrite assoc. set (tmpar1 := CoIm_to_Im f · KernelArrow (Image f)). set (tmpar2 := CoequalizerOut q y tmpar1 H). rewrite <- (ZeroArrow_comp_left A (to_Zero A) _ _ _ tmpar2). apply cancel_postcomposition. rewrite <- assoc. rewrite e0. apply idpath. } set (l := KernelIn (to_Zero A) (Kernel f) _ _ e). assert (e1 : (KernelArrow (to_Kernels A _ _ E)) · (CokernelArrow (CoImage f)) = ZeroArrow (to_Zero A) _ _). { set (tmp := KernelCommutes (to_Zero A) (Kernel f) _ _ e). rewrite <- tmp. fold l. rewrite <- (ZeroArrow_comp_right A (to_Zero A) _ _ _ l). rewrite <- assoc. apply cancel_precomposition. unfold CoImage. apply CokernelCompZero. } set (ar2 := CokernelOut (to_Zero A) coker _ _ e1). set (com2 := CokernelCommutes (to_Zero A) coker _ _ e1). assert (e2 : CokernelArrow (CoImage f) · (CoequalizerArrow q) · (CokernelOut (to_Zero A) coker _ _ e1) = CokernelArrow (CoImage f)). { apply com2. } assert (e3 : (CoequalizerArrow q) · (CokernelOut (to_Zero A) coker (CoImage f) _ e1) = identity _). { set (isE1 := CokernelArrowisEpi (to_Zero A) (CoImage f)). unfold isEpi in isE1. apply isE1. rewrite assoc. rewrite id_right. apply e2. } assert (e4 : isMonic (CoequalizerArrow q)). { apply (isMonic_postcomp A _ (CokernelOut (to_Zero A) coker (CoImage f) _ e1)). set (tmp := @identity_isMonic A (CoImage f)). rewrite <- e3 in tmp. apply tmp. } set (coeqeq := CoequalizerEqAr q). apply e4 in coeqeq. apply coeqeq. (* isEpi *) - use (isEpi_precomp A (CokernelArrow (CoImage f)) _). intros z g1 g2 H. set (q := Equalizer A g1 g2). set (ar := CokernelArrow (CoImage f) · CoIm_to_Im f). set (ar1 := EqualizerIn q _ ar). set (com1 := EqualizerCommutes q _ _ H). assert (isE : isMonic ((EqualizerArrow q) · (KernelArrow (Image f)))). { apply isMonic_comp. apply EqualizerArrowisMonic. apply KernelArrowisMonic. } set (M := make_Monic A ((EqualizerArrow q) · (KernelArrow (Image f))) isE). set (ker := MonicToKernel M). assert (e0 : (EqualizerArrow q) · (KernelArrow (Image f)) · (CokernelArrow (to_Cokernels A _ _ M)) = ZeroArrow (to_Zero A) (MonicToKernel M) _). { use (pathscomp0 _ (KernelCompZero (to_Zero A) (MonicToKernel M))). apply cancel_precomposition. apply idpath. } assert (e : f · (CokernelArrow (to_Cokernels A _ _ M)) = ZeroArrow (to_Zero A) _ _). { (* Use CoImage Image equation *) set (tmp := CoIm_to_Im_eq f). apply (maponpaths (λ f : _, f · (CokernelArrow (to_Cokernels A _ _ M)))) in tmp. use (pathscomp0 tmp). (* rewrite com1 *) rewrite <- com1. (* cancel precomposition and rewrite e0 *) set (tmpar1 := CokernelArrow (CoImage f) · CoIm_to_Im f). set (tmpar2 := EqualizerIn q x tmpar1 H). rewrite <- (ZeroArrow_comp_right A (to_Zero A) _ _ _ tmpar2). rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. rewrite e0. apply idpath. } set (l := CokernelOut (to_Zero A) (Cokernel f) _ _ e). assert (e1 : (KernelArrow (Image f)) · (CokernelArrow (to_Cokernels A _ _ M)) = ZeroArrow (to_Zero A) _ _). { set (tmp := CokernelCommutes (to_Zero A) (Cokernel f) _ _ e). rewrite <- tmp. fold l. rewrite <- (ZeroArrow_comp_left A (to_Zero A) _ _ _ l). rewrite assoc. apply cancel_postcomposition. unfold Image. apply KernelCompZero. } set (ar2 := KernelIn (to_Zero A) ker _ _ e1). set (com2 := KernelCommutes (to_Zero A) ker _ _ e1). assert (e2 : (KernelIn (to_Zero A) ker _ _ e1) · (EqualizerArrow q) · KernelArrow (Image f) = KernelArrow (Image f)). { rewrite <- com2. rewrite <- assoc. apply cancel_precomposition. unfold ker. apply idpath. } assert (e3 : (KernelIn (to_Zero A) ker (Image f) _ e1) · (EqualizerArrow q) = identity _). { set (isM1 := KernelArrowisMonic (to_Zero A) (Image f)). unfold isMonic in isM1. apply isM1. rewrite id_left. apply e2. } assert (e4 : isEpi (EqualizerArrow q)). { apply (isEpi_precomp A (KernelIn (to_Zero A) ker (Image f) _ e1)). set (tmp := @identity_isEpi A (Image f)). rewrite <- e3 in tmp. apply tmp. } set (eqeq := EqualizerEqAr q). apply e4 in eqeq. apply eqeq. Qed. (** ** f = Epi ((x --> CoIm f) · (CoIm f --> Im f)) · Monic (Im f --> y) *) Lemma factorization1_is_epi {x y : A} (f : x --> y) : isEpi (CokernelArrow (CoImage f) · CoIm_to_Im f). Proof. apply isEpi_comp. apply CokernelArrowisEpi. apply (is_iso_isEpi A _ (CoIm_to_Im_is_iso f)). Qed. Definition factorization1_epi {x y : A} (f : x --> y) : Epi A x (Image f). Proof. use make_Epi. exact (CokernelArrow (CoImage f) · CoIm_to_Im f). apply factorization1_is_epi. Defined. Definition factorization1_monic {x y : A} (f : x --> y) : Monic A (Image f) y. Proof. use make_Monic. exact (KernelArrow (Image f)). apply KernelArrowisMonic. Defined. Lemma factorization1 {x y : A} (f : x --> y) : f = (factorization1_epi f) · (factorization1_monic f). Proof. use (pathscomp0 (CoIm_to_Im_eq f)). apply idpath. Qed. (** ** f = Epi ((x --> CoIm f)) · Monic ((CoIm f --> Im f) · (Im f --> y)) *) Lemma factorization2_is_monic {x y : A} (f : x --> y) : isMonic (CoIm_to_Im f · (KernelArrow (Image f))). Proof. apply isMonic_comp. apply (is_iso_isMonic A _ (CoIm_to_Im_is_iso f)). apply KernelArrowisMonic. Qed. Definition factorization2_monic {x y : A} (f : x --> y) : Monic A (CoImage f) y. Proof. use make_Monic. exact (CoIm_to_Im f · (KernelArrow (Image f))). apply factorization2_is_monic. Defined. Definition factorization2_epi {x y : A} (f : x --> y) : Epi A x (CoImage f). Proof. use make_Epi. exact (CokernelArrow (CoImage f)). apply CokernelArrowisEpi. Defined. Definition factorization2 {x y : A} (f : x --> y) : f = (factorization2_epi f) · (factorization2_monic f). Proof. use (pathscomp0 (CoIm_to_Im_eq f)). rewrite <- assoc. apply idpath. Qed. End abelian_factorization. Arguments factorization1 [A] [x] [y] _. Arguments factorization1_is_epi [A] [x] [y] _ _ _ _ _. Arguments factorization2 [A] [x] [y] _. Arguments factorization2_is_monic [A] [x] [y] _ _ _ _ _. Arguments CoIm_to_Im [A] [x] [y] _. Arguments Kernel [A] [x] [y] _. Arguments Cokernel [A] [x] [y] _. Arguments Image [A] [x] [y] _. Arguments CoImage [A] [x] [y] _. Section abelian_kernel_cokernel. Variable A : AbelianPreCat. Definition MonicToKernel' {x y : A} (M : Monic A x y) (CK : cokernels.Cokernel (to_Zero A) M) : kernels.Kernel (to_Zero A) (CokernelArrow CK) := @Kernel_up_to_iso2 A (to_Zero A) _ _ _ (CokernelArrow (Cokernel M)) (CokernelArrow CK) (iso_from_Cokernel_to_Cokernel (to_Zero A) (Cokernel M) CK) (CokernelCommutes _ _ _ _ _) (MonicToKernel M). Definition EpiToCokernel' {x y : A} (E : Epi A x y) (K : kernels.Kernel (to_Zero A) E) : cokernels.Cokernel (to_Zero A) (KernelArrow K) := Cokernel_up_to_iso2 A (to_Zero A) (KernelArrow (Kernel E)) (KernelArrow K) (iso_from_Kernel_to_Kernel (to_Zero A) K (Kernel E)) (KernelCommutes _ _ _ _ _) (EpiToCokernel E). End abelian_kernel_cokernel. (** * A Abelian -> A^op Abelian, [Abelian_opp] *) Section opp_abelian. Variable C : category. Let hs : has_homsets C := homset_property C. Definition AbelianData1_opp (AD1 : Data1 C) : @Data1 (op_category C). Proof. use make_Data1. - exact (Zero_opp C (pr1 AD1)). - exact (BinCoproducts_opp C (pr2 (pr2 AD1))). - exact (BinProducts_opp C (pr1 (pr2 AD1))). Defined. Definition AbelianData2_opp {AD1 : Data1 C} (AD2 : Data2 C AD1) : @Data2 (op_category C) (AbelianData1_opp AD1). Proof. use make_Data2. - exact (Cokernels_opp C (pr1 AD1) (pr2 AD2)). - exact (Kernels_opp C (pr1 AD1) (pr1 AD2)). Defined. Local Opaque ZeroArrow. Lemma MonicsAreKernels_opp_eq {D1 : Data1 C} {D2 : Data2 C D1} (AMKD : MonicsAreKernels C D1 D2) (y z : C^op) (E : Epi (op_category C) y z) : @compose C _ _ _ E (CokernelArrow ((to_Cokernels D2) z y (opp_Epi C E))) = @ZeroArrow (op_category C) (Zero_opp C (to_Zero D1)) _ _. Proof. rewrite <- ZeroArrow_opp. set (tmp := KernelCompZero (to_Zero D1) (make_Kernel _ _ _ _ (AMKD z y (opp_Epi C E)))). cbn in tmp. cbn. rewrite tmp. clear tmp. apply ZerosArrowEq. Qed. Lemma MonicsAreKernels_opp_isCokernel {D1 : Data1 C} {D2 : Data2 C D1} (AMKD : MonicsAreKernels C D1 D2) (y z : C^op) (E : Epi (op_category C) y z) : isCokernel (Zero_opp C (pr1 D1)) (CokernelArrow (pr2 D2 z y (opp_Epi C E))) E (MonicsAreKernels_opp_eq AMKD y z E). Proof. use (isCokernel_opp _ ). - exact (to_Zero D1). - exact (CokernelCompZero _ (to_Cokernels D2 z y (opp_Epi C E))). - exact (AMKD _ _ (opp_Epi C E)). Qed. Definition MonicsAreKernels_opp {D1 : Data1 C} {D2 : Data2 C D1} (AMKD : MonicsAreKernels C D1 D2) : EpisAreCokernels (op_category C) (AbelianData1_opp D1) (AbelianData2_opp D2). Proof. use make_EpisAreCokernels. intros y z E. exact (MonicsAreKernels_opp_isCokernel AMKD y z E). Defined. Lemma EpisAreCokernels_opp_eq {D1 : Data1 C} {D2 : Data2 C D1} (AECD : EpisAreCokernels C D1 D2) (y z : C^op) (M : Monic (op_category C) y z) : (KernelArrow (pr1 D2 z y (opp_Monic C M))) · M = ZeroArrow (Zero_opp C (to_Zero D1)) y (to_Kernels D2 z y (opp_Monic C M)). Proof. rewrite <- ZeroArrow_opp. apply (KernelCompZero (to_Zero D1) (to_Kernels D2 z y (opp_Monic C M))). Qed. Lemma EpisAreCokernels_opp_isKernel {D1 : Data1 C} {D2 : Data2 C D1} (AECD : EpisAreCokernels C D1 D2) (y z : C^op) (M : Monic (op_category C) y z) : isKernel (Zero_opp C (to_Zero D1)) M (KernelArrow (to_Kernels D2 z y (opp_Monic C M))) (EpisAreCokernels_opp_eq AECD y z M). Proof. use (isKernel_opp _). - exact (to_Zero D1). - exact (KernelCompZero _ (to_Kernels D2 z y (opp_Monic C M))). - exact (AECD _ _ (opp_Monic C M)). Qed. Definition EpisAreCokernels_opp {D1 : Data1 C} {D2 : Data2 C D1} (AECD : EpisAreCokernels C D1 D2) : MonicsAreKernels (op_category C) (AbelianData1_opp D1) (AbelianData2_opp D2). Proof. use make_MonicsAreKernels. intros y z M. exact (EpisAreCokernels_opp_isKernel AECD y z M). Defined. Definition AbelianData_opp {AD1 : Data1 C} (AD : AbelianData C AD1) : AbelianData (op_category C) (AbelianData1_opp AD1). Proof. use make_AbelianData. - exact (AbelianData2_opp (pr1 AD)). - exact (EpisAreCokernels_opp (pr2 (pr2 AD))). - exact (MonicsAreKernels_opp (pr1 (pr2 AD))). Defined. (* Need to remove C from context *) End opp_abelian. Section opp_abelian'. Definition Abelian_opp (A : AbelianPreCat) : AbelianPreCat. Proof. use make_Abelian. - exact (op_category (pr1 (pr1 A))). - exact (AbelianData1_opp _ (pr2 (pr1 A))). - exact (AbelianData_opp _ (pr2 A)). Defined. (* Lemma has_homsets_Abelian_opp {A : AbelianPreCat} (hs : has_homsets A) : has_homsets (Abelian_opp A hs). Proof. exact (has_homsets_opp hs). Qed. *) End opp_abelian'. UniMath-20231010/UniMath/CategoryTheory/AbelianPushoutPullback.v000066400000000000000000000417421451125700300244240ustar00rootroot00000000000000(** * Pushout of a Monic is Monic, Pullback of an Epi is Epi *) (** Contents - Pushout of a Monic is Monic - Pushout of a Monic is Pullback - Pullback of an Epi is Epi - Pullback of an Epi is Pushout *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. (** ** Introduction We show that in abelian categories pushout of a Monic is a Monic and pullback of an Epi is an Epi. Also, in this case the pushout diagram (resp. pullback diagram) is a pullback diagram (resp. pushout diagram). More precisely, let f : x --> y and g : x --> z be morphisms in an abelian category. Consider the following pushout diagram x ----g----> z f | in2 | y ---in1---> w If f is a Monic, then in2 is a Monic, [AbelianPushoutMonic2]. If g is a Monic, then in1 is a Monic, [AbelianPushoutMonic1]. In both of the cases the above diagram is a pullback diagram, [AbelianPushoutMonicisPullback1], [AbelianPushoutMonicisPullback2]. Let f : x --> z and g : y --> z be morphisms in an abelian category. Consider the following pullback diagram w ---pr1---> x pr2 | f | y ----g----> z If f is an Epi, then pr2 is an Epi, [AbelianPushoutEpi2], and if g is an Epi, then pr1 is an Epi, [AbelianPushoutEpi1]. In both of the cases the above diagram is a pushout diagram, [AbelianPullbackEpiisPushout1], [AbelianPullbackEpiisPushout2]. *) Section pushout_monic_pullback_epi. Context {A : AbelianPreCat}. (* Let hs : has_homsets A := homset_property A. *) Local Opaque Abelian.Equalizer. Local Opaque Abelian.Coequalizer. Local Opaque to_BinDirectSums. Local Opaque to_binop to_inv. (** ** Pushout of a Monic is Monic *) Lemma AbelianPushoutMonic2 {x y z : A} (f : Monic A x y) (g : x --> z) (Po : Pushout f g) : Monics.isMonic (PushoutIn2 Po). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) y z). set (Po' := Pushout_from_Coequalizer_BinCoproduct A _ _ _ f g (BinDirectSum_BinCoproduct _ DS) (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS)))). (* Transform the statement to a statement about other pushout *) set (iso := z_iso_from_Pushout_to_Pushout Po Po'). apply (isMonic_postcomp A _ (PushoutArrow Po Po' (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po'))). rewrite (PushoutArrow_PushoutIn2 Po _ (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po')). (* Prove that the arrow isMonic *) set (CE := Coequalizer A (f · to_In1 (A:=AbelianToPreAdditive A) DS) (g · to_In2 (A:=AbelianToPreAdditive A) DS)). set (CK := AdditiveCoequalizerToCokernel (AbelianToAdditive A) _ _ CE). set (M1 := @isMonic_to_binop_BinDirectSum1' (AbelianToAdditive A) x y z f g DS). set (K := MonicToKernel' A (make_Monic _ _ M1) CK). use (@to_isMonic (AbelianToAdditive A)). intros z0 g0 H. cbn in H. rewrite assoc in H. set (φ := KernelIn _ K z0 (g0 · to_In2 (A:=AbelianToPreAdditive A) DS) H). set (KComm := KernelCommutes (to_Zero A) K z0 (g0 · to_In2 (A:=AbelianToPreAdditive A) DS) H). fold φ in KComm. (* The result follows from KComm and the fact that φ = ZeroArrow *) assert (e1 : φ = ZeroArrow (to_Zero A) _ _). { use (MonicisMonic _ f). rewrite ZeroArrow_comp_left. cbn in KComm. assert (e2 : (MonicArrow _ f) = (@to_binop (AbelianToAdditive A) _ _ (f · to_In1 (A:=AbelianToPreAdditive A) DS) (@to_inv (AbelianToAdditive A) _ _ (g · to_In2 (A:=AbelianToPreAdditive A) DS))) · to_Pr1 DS). { rewrite to_postmor_linear'. rewrite <- assoc. rewrite PreAdditive_invlcomp. rewrite <- assoc. set (tmp := to_IdIn1 DS). cbn in tmp. cbn. rewrite tmp. clear tmp. set (tmp := to_Unel2' DS). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_right. rewrite id_right. apply pathsinv0. set (tmp := @to_runax'' (AbelianToAdditive A) (to_Zero A) _ _ f). exact tmp. } rewrite e2. clear e2. rewrite assoc. cbn in KComm. cbn. rewrite KComm. rewrite <- assoc. set (tmp := to_Unel2' DS). cbn in tmp. rewrite tmp. clear tmp. apply ZeroArrow_comp_right. } use (to_In2_isMonic _ DS). cbn in KComm. use (pathscomp0 (! KComm)). rewrite e1. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. Qed. Lemma AbelianPushoutMonic1 {x y z : A} (f : x --> y) (g : Monic A x z) (Po : Pushout f g) : Monics.isMonic (PushoutIn1 Po). Proof. set (Po' := make_Pushout _ _ _ _ _ _ (is_symmetric_isPushout _ (isPushout_Pushout Po))). use (AbelianPushoutMonic2 g f Po'). Qed. (** ** Pushout of Monic is Pullback *) Local Lemma AbelianPushoutMonicisPullback_eq {x y z : A} (f : Monic A x y) (g : x --> z) {e : A} {h : A ⟦ e, y ⟧} {k : A ⟦ e, z ⟧} (Hk : let DS := to_BinDirectSums (AbelianToAdditive A) y z in let Po' := Pushout_from_Coequalizer_BinCoproduct A _ _ _ f g (BinDirectSum_BinCoproduct _ DS) (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS))) in h · PushoutIn1 Po' = k · PushoutIn2 Po') : let DS := to_BinDirectSums (AbelianToAdditive A) y z in let Po' := Pushout_from_Coequalizer_BinCoproduct A _ _ _ f g (BinDirectSum_BinCoproduct _ DS) (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS))) in h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) e (Abelian.Cokernel f). Proof. intros DS Po'. cbn zeta in Hk. fold DS in Hk. fold Po' in Hk. set (CK := Abelian.Cokernel f). assert (e1 : f · CokernelArrow CK = g · ZeroArrow (to_Zero A) z CK). { rewrite CokernelCompZero. rewrite ZeroArrow_comp_right. apply idpath. } rewrite <- (PushoutArrow_PushoutIn1 Po' CK (CokernelArrow CK) (ZeroArrow (to_Zero A) _ _) e1). rewrite assoc. rewrite Hk. clear Hk. rewrite <- assoc. rewrite (PushoutArrow_PushoutIn2 Po' CK (CokernelArrow CK) (ZeroArrow (to_Zero A) _ _) e1). apply ZeroArrow_comp_right. Qed. Lemma AbelianPushoutMonicisPullback1 {x y z : A} (f : Monic A x y) (g : x --> z) (Po : Pushout f g) : isPullback (*(PushoutIn1 Po) (PushoutIn2 Po) f g*) (PushoutSqrCommutes Po). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) y z). set (Po' := Pushout_from_Coequalizer_BinCoproduct A _ _ _ f g (BinDirectSum_BinCoproduct _ DS) (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS)))). set (i := z_iso_from_Pushout_to_Pushout Po Po'). use isPullback_up_to_z_iso. - exact Po'. - exact i. - use isPullback_mor_paths. + exact (PushoutIn1 Po'). + exact (PushoutIn2 Po'). + exact f. + exact g. + apply pathsinv0. exact (PushoutArrow_PushoutIn1 Po Po' (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po')). + apply pathsinv0. exact (PushoutArrow_PushoutIn2 Po Po' (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po')). + apply idpath. + apply idpath. + exact (PushoutSqrCommutes _ ). + set (K := MonicToKernel f). set (CK := Abelian.Cokernel f). fold CK in K. use make_isPullback. intros e h k Hk. use unique_exists. * use (KernelIn (to_Zero A) K). -- exact h. -- exact (AbelianPushoutMonicisPullback_eq f g Hk). * cbn. split. -- use (KernelCommutes (to_Zero A) K). -- assert (Hk' : h · PushoutIn1 Po' = k · PushoutIn2 Po') by apply Hk. set (comm := KernelCommutes (to_Zero A) K _ h (AbelianPushoutMonicisPullback_eq f g Hk)). cbn in comm. rewrite <- comm in Hk'. clear comm. apply (AbelianPushoutMonic2 f g Po'). rewrite <- Hk'. cbn. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. rewrite assoc. apply pathsinv0. use CoequalizerEqAr. * intros y0. apply isapropdirprod; apply (homset_property A). * intros y0 X. cbn in X. use (KernelArrowisMonic (to_Zero A) K). rewrite KernelCommutes. exact (dirprod_pr1 X). Qed. Lemma AbelianPushoutMonicisPullback2 {x y z : A} (f : x --> y) (g : Monic A x z) (Po : Pushout f g) : isPullback (*(PushoutIn1 Po) (PushoutIn2 Po) f g*) (PushoutSqrCommutes Po). Proof. set (Po' := make_Pushout _ _ _ _ _ _ (is_symmetric_isPushout _ (isPushout_Pushout Po))). use is_symmetric_isPullback. - exact (! (PushoutSqrCommutes _ )). - exact (AbelianPushoutMonicisPullback1 g f Po'). Qed. (** ** Pullback of an Epi is Epi *) Lemma AbelianPullbackEpi2 {x y z : A} (f : Epi A x z) (g : y --> z) (Pb : Pullback f g) : Epis.isEpi (PullbackPr2 Pb). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) x y). set (Pb' := Pullback_from_Equalizer_BinProduct A _ _ _ f g (BinDirectSum_BinProduct _ DS) (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g))). (* Transform the statement to a statement about other pullback *) set (iso := z_iso_from_Pullback_to_Pullback Pb Pb'). apply (isEpi_precomp A (PullbackArrow Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb'))). rewrite (PullbackArrow_PullbackPr2 Pb _ (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb')). (* Prove that the arrow isEpi *) set (E := Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)). set (K := AdditiveEqualizerToKernel (AbelianToAdditive A) _ _ E). set (E1 := @isEpi_to_binop_BinDirectSum1' (AbelianToAdditive A) x y z f g DS). set (CK := EpiToCokernel' A (make_Epi _ _ E1) K). use (@to_isEpi (AbelianToAdditive A)). intros z0 g0 H. cbn in H. cbn. rewrite <- assoc in H. set (φ := CokernelOut _ CK z0 (to_Pr2 DS · g0) H). set (CKComm := CokernelCommutes (to_Zero A) CK z0 (to_Pr2 DS · g0) H). fold φ in CKComm. (* The result follows from CKComm and the fact that φ = ZeroArrow *) assert (e1 : φ = ZeroArrow (to_Zero A) _ _). { use (EpiisEpi _ f). rewrite ZeroArrow_comp_right. cbn in CKComm. assert (e2 : (EpiArrow _ f) = (to_In1 DS) · (@to_binop (AbelianToAdditive A) _ _ (to_Pr1 DS · f) (@to_inv (AbelianToAdditive A) _ _ (to_Pr2 DS · g)))). { rewrite to_premor_linear'. rewrite assoc. rewrite PreAdditive_invrcomp. rewrite assoc. set (tmp := to_IdIn1 DS). cbn in tmp. cbn. rewrite tmp. clear tmp. set (tmp := to_Unel1' DS). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_left. rewrite id_left. apply pathsinv0. set (tmp := @to_runax'' (AbelianToAdditive A) (to_Zero A) _ _ f). exact tmp. } rewrite e2. clear e2. rewrite <- assoc. cbn in CKComm. cbn. rewrite CKComm. rewrite assoc. set (tmp := to_Unel1' DS). cbn in tmp. rewrite tmp. clear tmp. apply ZeroArrow_comp_left. } use (to_Pr2_isEpi _ DS). cbn in CKComm. use (pathscomp0 (! CKComm)). rewrite e1. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Qed. Lemma AbelianPullbackEpi1 {x y z : A} (f : x --> z) (g : Epi A y z) (Pb : Pullback f g) : Epis.isEpi (PullbackPr1 Pb). Proof. set (Pb' := make_Pullback _ (is_symmetric_isPullback _ (isPullback_Pullback Pb))). use (AbelianPullbackEpi2 g f Pb'). Qed. (** ** Pullback of Epi is Pushout *) Local Lemma AbelianPullbackEpiisPushout1_eq {x y z : A} (f : Epi A x z) (g : y --> z) {e : A} {h : A ⟦ x, e ⟧} {k : A ⟦ y, e ⟧} (Hk : let DS := to_BinDirectSums (AbelianToAdditive A) x y in let Pb' := Pullback_from_Equalizer_BinProduct A _ _ _ f g (BinDirectSum_BinProduct _ DS) (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)) in PullbackPr1 Pb' · h = PullbackPr2 Pb' · k) : let DS := to_BinDirectSums (AbelianToAdditive A) x y in let Pb' := Pullback_from_Equalizer_BinProduct A _ _ _ f g (BinDirectSum_BinProduct _ DS) (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)) in let K := Abelian.Kernel f in KernelArrow K · h = ZeroArrow (to_Zero A) K e. Proof. intros DS Pb' K. cbn zeta in Hk. fold DS in Hk. fold Pb' in Hk. assert (e1 : KernelArrow K · f = ZeroArrow (to_Zero A) _ _ · g). { rewrite KernelCompZero. rewrite ZeroArrow_comp_left. apply idpath. } rewrite <- (PullbackArrow_PullbackPr1 Pb' K (KernelArrow K) (ZeroArrow (to_Zero A) _ _) e1). rewrite <- assoc. rewrite Hk. clear Hk. rewrite assoc. rewrite (PullbackArrow_PullbackPr2 Pb' K (KernelArrow K) (ZeroArrow (to_Zero A) _ _) e1). apply ZeroArrow_comp_left. Qed. Lemma AbelianPullbackEpiisPushout1 {x y z : A} (f : Epi A x z) (g : y --> z) (Pb : Pullback f g) : isPushout (PullbackPr1 Pb) (PullbackPr2 Pb) f g (PullbackSqrCommutes Pb). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) x y). set (Pb' := Pullback_from_Equalizer_BinProduct A _ _ _ f g (BinDirectSum_BinProduct _ DS) (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g))). set (i := z_iso_from_Pullback_to_Pullback Pb' Pb). use isPushout_up_to_z_iso. - exact Pb'. - exact i. - use isPushout_mor_paths. + exact (PullbackPr1 Pb'). + exact (PullbackPr2 Pb'). + exact f. + exact g. + apply pathsinv0. exact (PullbackArrow_PullbackPr1 Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb')). + apply pathsinv0. exact (PullbackArrow_PullbackPr2 Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb')). + apply idpath. + apply idpath. + exact (PullbackSqrCommutes _ ). + set (CK := EpiToCokernel f). set (K := Abelian.Kernel f). fold K in CK. use make_isPushout. intros e h k Hk. use unique_exists. * use (CokernelOut (to_Zero A) CK). -- exact h. -- exact (AbelianPullbackEpiisPushout1_eq f g Hk). * cbn. split. -- use (CokernelCommutes (to_Zero A) CK). -- assert (Hk' : PullbackPr1 Pb' · h = PullbackPr2 Pb' · k) by apply Hk. set (comm := CokernelCommutes (to_Zero A) CK _ h (AbelianPullbackEpiisPushout1_eq f g Hk)). cbn in comm. rewrite <- comm in Hk'. clear comm. apply (AbelianPullbackEpi2 f g Pb'). rewrite <- Hk'. cbn. rewrite assoc. rewrite assoc. apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply pathsinv0. use EqualizerEqAr. * intros y0. apply isapropdirprod; apply (homset_property A). * intros y0 X. cbn in X. use (CokernelArrowisEpi (to_Zero A) CK). rewrite CokernelCommutes. exact (dirprod_pr1 X). Qed. Lemma AbelianPullbackEpiisPushout2 {x y z : A} (f : x --> z) (g : Epi A y z) (Pb : Pullback f g) : isPushout (PullbackPr1 Pb) (PullbackPr2 Pb) f g (PullbackSqrCommutes Pb). Proof. set (Pb' := make_Pullback _ (is_symmetric_isPullback _ (isPullback_Pullback Pb))). use is_symmetric_isPushout. - exact (! (PullbackSqrCommutes _ )). - exact (AbelianPullbackEpiisPushout1 g f Pb'). Qed. End pushout_monic_pullback_epi. UniMath-20231010/UniMath/CategoryTheory/AbelianToAdditive.v000066400000000000000000001036151451125700300233310ustar00rootroot00000000000000(** * AbelianPreCat is CategoryWithAdditiveStructure *) (** ** Contents - AbelianPreCat is CategoryWithAdditiveStructure - Preliminaries - AbelianPreCat is CategoryWithAdditiveStructure *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Local Open Scope cat. (** * AbelianPreCat is CategoryWithAdditiveStructure. *) Section abelian_is_additive. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** Preliminaries *) (** Some maps we are going to use. *) Definition DiagonalMap {X : A} (BinProd : BinProduct A X X) : A⟦X, (BinProductObject A BinProd)⟧ := BinProductArrow A BinProd (identity X) (identity X). Definition IdZeroMap {X : A} (BinProd : BinProduct A X X) : A⟦X, (BinProductObject A BinProd)⟧ := BinProductArrow A BinProd (identity X) (ZeroArrow (to_Zero A) X X). Definition ZeroIdMap {X : A} (BinProd : BinProduct A X X) : A⟦X, (BinProductObject A BinProd)⟧ := BinProductArrow A BinProd (ZeroArrow (to_Zero A) X X) (identity X). (** Proofs that these maps are monics. *) Lemma DiagonalMap_isMonic {X : A} (BinProd : BinProduct A X X) : isMonic (DiagonalMap BinProd). Proof. intros x u v H. apply (maponpaths (λ f : _, f · (BinProductPr1 A BinProd))) in H. repeat rewrite <- assoc in H. unfold DiagonalMap in H. repeat rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) _) in H. repeat rewrite id_right in H. exact H. Qed. Lemma IdZeroMap_isMonic {X : A} (BinProd : BinProduct A X X) : isMonic (IdZeroMap BinProd). Proof. intros x u v H. apply (maponpaths (λ f : _, f · (BinProductPr1 A BinProd))) in H. repeat rewrite <- assoc in H. unfold IdZeroMap in H. repeat rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) _) in H. repeat rewrite id_right in H. exact H. Qed. Lemma ZeroIdMap_isMonic {X : A} (BinProd : BinProduct A X X) : isMonic (ZeroIdMap BinProd). Proof. intros x u v H. apply (maponpaths (λ f : _, f · (BinProductPr2 A BinProd))) in H. repeat rewrite <- assoc in H. unfold ZeroIdMap in H. repeat rewrite (BinProductPr2Commutes A _ _ BinProd _ _ (identity X)) in H. repeat rewrite id_right in H. exact H. Qed. (** We show that Pr1 and Pr2 of BinProduct are epimorphisms. *) Lemma BinProductPr1_isEpi {X : A} (BinProd : BinProduct A X X) : isEpi (BinProductPr1 A BinProd). Proof. use isEpi_precomp. - exact X. - exact (IdZeroMap BinProd). - unfold IdZeroMap. rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) _). apply identity_isEpi. Qed. Lemma BinProductPr2_isEpi {X : A} (BinProd : BinProduct A X X) : isEpi (BinProductPr2 A BinProd). Proof. use isEpi_precomp. - exact X. - exact (ZeroIdMap BinProd). - unfold ZeroIdMap. rewrite (BinProductPr2Commutes A _ _ BinProd _ _ (identity X)). apply identity_isEpi. Qed. (** We construct kernels of BinProduct Pr1 and Pr2. *) Lemma KernelOfPr1_Eq {X : A} (BinProd : BinProduct A X X) : ZeroIdMap BinProd · BinProductPr1 A BinProd = ZeroArrow (to_Zero A) X X. Proof. unfold ZeroIdMap. exact (BinProductPr1Commutes A _ _ BinProd _ _ (identity X)). Qed. Local Lemma KernelOfPr1_isKernel_comm (X : A) (BinProd : BinProduct A X X) (w : A) (h : A ⟦ w, BinProductObject A BinProd ⟧) (H' : h · BinProductPr1 A BinProd = ZeroArrow (to_Zero A) _ _) : h · (BinProductPr2 A BinProd) · BinProductArrow A BinProd (ZeroArrow (to_Zero A) X X) (identity X) = h. Proof. apply BinProductArrowsEq. - rewrite <- assoc. rewrite (BinProductPr1Commutes A _ _ BinProd _ _ (identity X)). rewrite H'. rewrite ZeroArrow_comp_right. apply idpath. - rewrite <- assoc. rewrite (BinProductPr2Commutes A _ _ BinProd _ _ (identity X)). apply id_right. Qed. Local Lemma KernelOfPr1_isKernel_unique (X : A) (BinProd : BinProduct A X X) (w : A) (h : A ⟦ w, BinProductObject A BinProd ⟧) (H' : h · BinProductPr1 A BinProd = ZeroArrow (to_Zero A) _ _) (y : A ⟦ w, X ⟧) (H : y · BinProductArrow A BinProd (ZeroArrow (to_Zero A) X X) (identity X) = h) : y = h · BinProductPr2 A BinProd. Proof. rewrite <- H. rewrite <- assoc. rewrite (BinProductPr2Commutes A _ _ BinProd _ _ (identity X)). rewrite id_right. apply idpath. Qed. Lemma KernelOfPr1_isKernel {X : A} (BinProd : BinProduct A X X) : isKernel (to_Zero A) (ZeroIdMap BinProd) (BinProductPr1 A BinProd) (KernelOfPr1_Eq BinProd). Proof. use (make_isKernel). intros w h H'. unfold ZeroIdMap. use unique_exists. (* The arrow *) - exact (h · (BinProductPr2 A BinProd)). (* commutativity *) - exact (KernelOfPr1_isKernel_comm X BinProd w h H'). (* equality of equalities of morphisms *) - intros y. apply hs. (* uniqueness *) - exact (KernelOfPr1_isKernel_unique X BinProd w h H'). Qed. Definition KernelOfPr1 {X : A} (BinProd : BinProduct A X X) : kernels.Kernel (to_Zero A) (BinProductPr1 A BinProd). Proof. exact (make_Kernel (to_Zero A) (ZeroIdMap BinProd) _ (KernelOfPr1_Eq BinProd) (KernelOfPr1_isKernel BinProd)). Defined. Lemma KernelOfPr2_Eq {X : A} (BinProd : BinProduct A X X) : IdZeroMap BinProd · BinProductPr2 A BinProd = ZeroArrow (to_Zero A) X X. Proof. unfold IdZeroMap. rewrite (BinProductPr2Commutes A _ _ BinProd _ (identity X) _). apply idpath. Qed. Local Lemma KernelOfPr2_isKernel_comm (X : A) (BinProd : BinProduct A X X) (w : A) (h : A ⟦w, BinProductObject A BinProd⟧) (H' : h · BinProductPr2 A BinProd = ZeroArrow (to_Zero A) _ _) : h · (BinProductPr1 A BinProd) · BinProductArrow A BinProd (identity X) (ZeroArrow (to_Zero A) X X) = h. Proof. apply BinProductArrowsEq. - rewrite <- assoc. rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) _). apply id_right. - rewrite <- assoc. rewrite (BinProductPr2Commutes A _ _ BinProd _ (identity X) _). rewrite H'. rewrite ZeroArrow_comp_right. apply idpath. Qed. Local Lemma KernelOfPr2_isKernel_unique (X : A) (BinProd : BinProduct A X X) (w : A) (h : A ⟦ w, BinProductObject A BinProd ⟧) (H' : h · BinProductPr2 A BinProd = ZeroArrow (to_Zero A) _ _) (y : A ⟦ w, X ⟧) (H : y · BinProductArrow A BinProd (identity X) (ZeroArrow (to_Zero A) X X) = h) : y = h · BinProductPr1 A BinProd. Proof. rewrite <- H. rewrite <- assoc. rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) _). rewrite id_right. apply idpath. Qed. Definition KernelOfPr2_isKernel {X : A} (BinProd : BinProduct A X X) : isKernel (to_Zero A) (IdZeroMap BinProd) (BinProductPr2 A BinProd) (KernelOfPr2_Eq BinProd). Proof. use (make_isKernel). intros w h H'. unfold IdZeroMap. use unique_exists. (* The arrow *) - exact (h · (BinProductPr1 A BinProd)). (* Commutativity *) - exact (KernelOfPr2_isKernel_comm X BinProd w h H'). (* Equality of equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y H. exact (KernelOfPr2_isKernel_unique X BinProd w h H' y H). Qed. Definition KernelOfPr2 {X : A} (BinProd : BinProduct A X X) : kernels.Kernel (to_Zero A) (BinProductPr2 A BinProd). Proof. exact (make_Kernel (to_Zero A) (IdZeroMap BinProd) _ (KernelOfPr2_Eq BinProd) (KernelOfPr2_isKernel BinProd)). Defined. (** From properties of abelian categories, it follows that Pr1 and Pr2 are cokernels of the above kernels since they are epimorphisms. *) Definition CokernelOfKernelOfPr1 {X : A} (BinProd : BinProduct A X X) : cokernels.Cokernel (to_Zero A) (KernelArrow (KernelOfPr1 BinProd)). Proof. exact (EpiToCokernel' A (make_Epi A _ (BinProductPr1_isEpi BinProd)) (KernelOfPr1 BinProd)). Defined. Definition CokernelOfKernelOfPr2 {X : A} (BinProd : BinProduct A X X) : cokernels.Cokernel (to_Zero A) (KernelArrow (KernelOfPr2 BinProd)). Proof. exact (EpiToCokernel' A (make_Epi A _ (BinProductPr2_isEpi BinProd)) (KernelOfPr2 BinProd)). Defined. (** We construct a cokernel of the DiagonalMap. The CokernelOb is the object X.*) Lemma CokernelOfDiagonal_is_iso {X : A} (BinProd : BinProduct A X X) : is_z_isomorphism ((BinProductArrow A BinProd (identity X) (ZeroArrow (to_Zero A) X X)) · (CokernelArrow (Cokernel (DiagonalMap BinProd)))). Proof. set (coker := Cokernel (DiagonalMap BinProd)). set (r := (BinProductArrow A BinProd (identity X) (ZeroArrow (to_Zero A) X X)) · (CokernelArrow coker)). set (M := make_Monic A _ (DiagonalMap_isMonic BinProd)). set (ker := MonicToKernel M). use monic_epi_is_iso. (* isMonic *) - use (@KernelZeroisMonic A (to_Zero A) _ _ _ (ZeroArrow_comp_left _ _ _ _ _ _)). use (make_isKernel). intros w h H'. use unique_exists. (* The arrow *) + exact (ZeroArrow (to_Zero A) w (to_Zero A)). (* Commutativity *) + unfold r in H'. rewrite assoc in H'. set (y := KernelIn _ ker _ _ H'). cbn in y. set (com1 := KernelCommutes _ ker _ _ H'). cbn in com1. fold y in com1. unfold DiagonalMap in com1. assert (H : y = ZeroArrow (to_Zero A) w ker). { rewrite <- (id_right y). set (tmp := BinProductPr2Commutes A _ _ BinProd _ (identity X) (identity X)). rewrite <- tmp. rewrite assoc. rewrite com1. rewrite <- assoc. rewrite (BinProductPr2Commutes A _ _ BinProd _ (identity X) _). apply ZeroArrow_comp_right. } cbn. rewrite ZeroArrow_comp_left. cbn in H. apply pathsinv0 in H. use (pathscomp0 H). rewrite <- id_right. rewrite <- (BinProductPr1Commutes A _ _ BinProd _ (identity X) (ZeroArrow (to_Zero A) _ _)). rewrite assoc. rewrite <- com1. rewrite <- assoc. rewrite (BinProductPr1Commutes A _ _ BinProd _ (identity X) (identity X)). rewrite id_right. apply idpath. (* Equality on equalities of morphisms *) + intros y. apply hs. (* Uniqueness *) + intros y H. apply ArrowsToZero. (* isEpi *) - use (@CokernelZeroisEpi A _ _ (to_Zero A) _ (ZeroArrow_comp_right _ _ _ _ _ _)). use make_isCokernel. intros w h H'. use unique_exists. (* The arrow *) + exact (ZeroArrow (to_Zero A) (to_Zero A) w). (* Commutativity *) + set(coker2 := CokernelOfKernelOfPr2 BinProd). set(coker2ar := CokernelArrow coker2). cbn in coker2ar. unfold r in H'. rewrite <- assoc in H'. set (y := CokernelOut _ coker2 _ _ H'). cbn in y. set (com1 := CokernelCommutes _ coker2 _ _ H'). cbn in com1. fold y in com1. assert (H : y = ZeroArrow (to_Zero A) X w). { rewrite <- (id_left y). set (tmp := BinProductPr2Commutes A _ _ BinProd _ (identity X) (identity X)). rewrite <- tmp. rewrite <- assoc. rewrite com1. rewrite assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_left. } rewrite H in com1. rewrite ZeroArrow_comp_right in com1. rewrite <- (ZeroArrow_comp_right A (to_Zero A) _ _ _ (CokernelArrow coker)) in com1. apply CokernelArrowisEpi in com1. rewrite <- com1. apply ZeroArrow_comp_left. (* Equality on equalities of morphisms. *) + intros y. apply hs. (* Uniqueness *) + intros y H. apply ArrowsFromZero. Qed. Definition CokernelOfDiagonal {X : A} (BinProd : BinProduct A X X) : cokernels.Cokernel (to_Zero A) (DiagonalMap BinProd). Proof. set (X0 := z_iso_inv (make_z_iso _ _ (CokernelOfDiagonal_is_iso BinProd))). exact (Cokernel_up_to_iso A (to_Zero A) _ (CokernelArrow (Cokernel (DiagonalMap BinProd)) · X0) (Cokernel (DiagonalMap BinProd)) X0 (idpath _)). Defined. (** We define the op which makes the homsets of an abelian category to abelian groups. *) Definition Abelian_minus_op {X Y : A} (f g : X --> Y) : A⟦X, Y⟧ := (BinProductArrow A (to_BinProducts A Y Y) f g) · CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y)). Definition Abelian_op (X Y : A) : binop (A⟦X, Y⟧) := (λ f : _, λ g : _, Abelian_minus_op f (Abelian_minus_op (ZeroArrow (to_Zero A) _ _) g)). (** Construction of a precategory with binops from Abelian category. *) Definition AbelianToprecategoryWithBinops : precategoryWithBinOps. Proof. use (make_precategoryWithBinOps A). unfold precategoryWithBinOpsData. intros x y. exact (Abelian_op x y). Defined. (** We need the following lemmas to prove that the homsets of an abelian precategory are abelian groups. *) Lemma Abelian_DiagonalMap_eq {X Y : A} (f : X --> Y) : f · (DiagonalMap (to_BinProducts A Y Y)) = (DiagonalMap (to_BinProducts A X X)) · (BinProductArrow A (to_BinProducts A Y Y) (BinProductPr1 _ (to_BinProducts A X X) · f) (BinProductPr2 _ (to_BinProducts A X X) · f)). Proof. unfold DiagonalMap. use BinProductArrowsEq. - repeat rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite id_left. apply id_right. - repeat rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. rewrite id_left. apply id_right. Qed. Lemma Abelian_op_eq_IdZero (X : A) : IdZeroMap (to_BinProducts A X X) · CokernelArrow (CokernelOfDiagonal (to_BinProducts A X X)) = identity _. Proof. set (ar := (BinProductArrow A (to_BinProducts A X X) (identity X) (ZeroArrow (to_Zero A) X X)) · (CokernelArrow (Cokernel (DiagonalMap (to_BinProducts A X X))))). set (r := make_z_iso ar _ (CokernelOfDiagonal_is_iso (to_BinProducts A X X))). cbn. fold ar. fold r. rewrite assoc. exact (is_inverse_in_precat1 r). Qed. Lemma Abelian_op_eq {X Y : A} (f : X --> Y) : let bp1 := to_BinProducts A X X in let bp2 := to_BinProducts A Y Y in CokernelArrow (CokernelOfDiagonal bp1) · f = (BinProductArrow A bp2 (BinProductPr1 _ bp1 · f) (BinProductPr2 _ bp1 · f)) · (CokernelArrow (CokernelOfDiagonal bp2)). Proof. set (bpX := to_BinProducts A X X). set (bpY := to_BinProducts A Y Y). cbn beta. cbn zeta. (* Cancel precomposition *) set (ar := (BinProductArrow A bpY (BinProductPr1 _ bpX · f) (BinProductPr2 _ bpX · f)) · (CokernelArrow (CokernelOfDiagonal bpY))). assert (H: DiagonalMap bpX · ar = ZeroArrow (to_Zero A) _ _). { unfold ar. rewrite assoc. unfold bpX, bpY. rewrite <- (Abelian_DiagonalMap_eq f). fold bpY. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. } set (g := CokernelOut (to_Zero A) (CokernelOfDiagonal bpX) (CokernelOfDiagonal bpY) ar H). set (com := CokernelCommutes (to_Zero A) (CokernelOfDiagonal bpX) (CokernelOfDiagonal bpY) ar H). rewrite <- com. apply cancel_precomposition. (* rewrite and use com *) set (e1 := Abelian_op_eq_IdZero X). set (e2 := Abelian_op_eq_IdZero Y). set (ar' := BinProductArrow A bpY (BinProductPr1 A bpX · f) (BinProductPr2 A bpX · f)). assert (e3 : IdZeroMap (to_BinProducts A X X) · ar' = f · IdZeroMap (to_BinProducts A Y Y)). { unfold ar', IdZeroMap. apply BinProductArrowsEq. - rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite id_left. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite id_right. apply idpath. - rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite ZeroArrow_comp_right. apply ZeroArrow_comp_left. } rewrite <- (id_right f). rewrite <- e2. rewrite assoc. rewrite <- e3. unfold ar'. rewrite <- assoc. fold ar. rewrite <- id_left. cbn. rewrite <- e1. rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. apply com. Qed. (** Construction of morphisms to BinProducts. *) Definition Abelian_mor_to_BinProd {X Y : A} (f g : X --> Y) : A⟦X, (BinProductObject A (to_BinProducts A Y Y))⟧ := BinProductArrow _ (to_BinProducts A Y Y) f g. Definition Abelian_mor_from_to_BinProd {X Y : A} (f g : X --> Y) : A⟦BinProductObject A (to_BinProducts A X X), BinProductObject A (to_BinProducts A Y Y)⟧ := BinProductArrow _ (to_BinProducts A Y Y) (BinProductPr1 _ (to_BinProducts A X X) · f) (BinProductPr2 _ (to_BinProducts A X X) · g). (** A few equations Abelian_minus_op and Abelian_op. *) Lemma AbelianPreCat_op_eq1 {X Y : A} (a b c d : X --> Y) : Abelian_minus_op (Abelian_mor_to_BinProd a b) (Abelian_mor_to_BinProd c d) = Abelian_mor_to_BinProd (Abelian_minus_op a c) (Abelian_minus_op b d). Proof. set (com1 := Abelian_op_eq (BinProductPr1 A (to_BinProducts A Y Y))). set (com2 := Abelian_op_eq (BinProductPr2 A (to_BinProducts A Y Y))). unfold Abelian_minus_op. unfold Abelian_mor_to_BinProd. use BinProductArrowsEq. - rewrite <- assoc. rewrite com1. rewrite BinProductPr1Commutes. rewrite assoc. apply cancel_postcomposition. use BinProductArrowsEq. + rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr1Commutes. apply idpath. + rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. rewrite BinProductPr1Commutes. apply idpath. - rewrite <- assoc. rewrite com2. rewrite BinProductPr2Commutes. rewrite assoc. apply cancel_postcomposition. use BinProductArrowsEq. + rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. apply idpath. + rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. rewrite BinProductPr2Commutes. apply idpath. Qed. Lemma AbelianPreCat_op_eq2 {X Y : A} (a b c d : X --> Y) : (Abelian_mor_to_BinProd (Abelian_mor_to_BinProd a b) (Abelian_mor_to_BinProd c d)) · (Abelian_mor_from_to_BinProd (CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y))) (CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y)))) = Abelian_mor_to_BinProd ((Abelian_mor_to_BinProd a b) · CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y))) ((Abelian_mor_to_BinProd c d) · CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y))). Proof. unfold Abelian_mor_to_BinProd. unfold Abelian_mor_from_to_BinProd. use BinProductArrowsEq. - rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. - rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. apply idpath. Qed. Lemma AbelianPreCat_op_eq3 {X Y : A} (a b c d : X --> Y) : Abelian_minus_op (Abelian_minus_op a b) (Abelian_minus_op c d) = Abelian_minus_op (Abelian_minus_op a c) (Abelian_minus_op b d). Proof. (* Rewrite Abelian_minus_op_eq1 *) unfold Abelian_minus_op at 1. set (tmp := AbelianPreCat_op_eq1 a c b d). unfold Abelian_mor_to_BinProd in tmp. rewrite <- tmp. (* Rewrite com *) set (com := Abelian_op_eq (CokernelArrow (CokernelOfDiagonal (to_BinProducts A Y Y)))). unfold Abelian_minus_op at 1. rewrite <- assoc. rewrite com. (* Cancel postcompostion *) rewrite assoc. set (tmp1 := AbelianPreCat_op_eq2 a c b d). unfold Abelian_mor_to_BinProd, Abelian_mor_from_to_BinProd in tmp1. rewrite tmp1. apply cancel_postcomposition. (* Use idpath *) unfold Abelian_minus_op. apply idpath. Qed. (** ** AbelianPreCat is CategoryWithAdditiveStructure *) (** The zero element in a homset of A is given by the ZeroArrow. *) Definition AbelianPreCat_homset_zero (X Y : A) : A⟦X, Y⟧ := ZeroArrow (to_Zero A) X Y. (** Some equations involving Abelian_minus_op and Abelian_op. *) Lemma AbelianPreCat_homset_zero_right' {X Y : A} (f : X --> Y) : Abelian_minus_op f (AbelianPreCat_homset_zero X Y) = f. Proof. unfold AbelianPreCat_homset_zero. unfold Abelian_minus_op. set (tmp := Abelian_op_eq_IdZero Y). unfold IdZeroMap in tmp. assert (e : BinProductArrow A (to_BinProducts A Y Y) f (ZeroArrow (to_Zero A) X Y) = f · BinProductArrow A (to_BinProducts A Y Y) (identity _) (ZeroArrow (to_Zero A) Y Y)). { apply BinProductArrowsEq. - rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite id_right. apply idpath. - rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite ZeroArrow_comp_right. apply idpath. } rewrite e. clear e. rewrite <- assoc. rewrite tmp. apply id_right. Qed. Lemma AbelianPreCat_homset_zero_right {X Y : A} (f : X --> Y) : Abelian_op _ _ f (AbelianPreCat_homset_zero X Y) = f. Proof. unfold AbelianPreCat_homset_zero. unfold Abelian_op. unfold Abelian_minus_op at 2. use (pathscomp0 _ (AbelianPreCat_homset_zero_right' f)). set (bpY := to_BinProducts A Y Y). assert (e : (BinProductArrow A bpY (ZeroArrow (to_Zero A) X Y) (ZeroArrow (to_Zero A) X Y)) · CokernelArrow (CokernelOfDiagonal bpY) = ZeroArrow (to_Zero A) _ _ ). { use (pathscomp0 _ (ZeroArrow_comp_left A (to_Zero A) _ _ _ (CokernelArrow (CokernelOfDiagonal bpY)))). apply cancel_postcomposition. use BinProductArrowsEq. - rewrite BinProductPr1Commutes. rewrite ZeroArrow_comp_left. apply idpath. - rewrite BinProductPr2Commutes. rewrite ZeroArrow_comp_left. apply idpath. } rewrite e. apply idpath. Qed. Definition AbelianPreCat_homset_inv {X Y : A} (f : X --> Y) : A⟦X, Y⟧ := Abelian_minus_op (ZeroArrow (to_Zero A) _ _) f. Lemma AbelianPreCat_homset_inv_left' {X Y : A} (f : X --> Y) : Abelian_minus_op f f = (AbelianPreCat_homset_zero X Y). Proof. unfold AbelianPreCat_homset_zero. unfold Abelian_minus_op. set (bpY := to_BinProducts A Y Y). assert (e : BinProductArrow A bpY f f = f · BinProductArrow A bpY (identity _ ) (identity _ )). { use BinProductArrowsEq. - rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite id_right. apply idpath. - rewrite BinProductPr2Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite id_right. apply idpath. } rewrite e. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Lemma AbelianPreCat_homset_inv_left {X Y : A} (f : X --> Y) : Abelian_op _ _ (AbelianPreCat_homset_inv f) f = (AbelianPreCat_homset_zero X Y). Proof. unfold AbelianPreCat_homset_inv. unfold AbelianPreCat_homset_zero. unfold Abelian_op. rewrite AbelianPreCat_op_eq3. rewrite AbelianPreCat_homset_inv_left'. rewrite AbelianPreCat_homset_inv_left'. apply AbelianPreCat_homset_zero_right'. Qed. Lemma AbelianPreCat_homset_zero_left {X Y : A} (f : X --> Y) : Abelian_op _ _ (AbelianPreCat_homset_zero X Y) f = f. Proof. rewrite <- (AbelianPreCat_homset_inv_left' f). set (tmp := AbelianPreCat_homset_zero_right' f). apply (maponpaths (λ g : _, Abelian_op X Y (Abelian_minus_op f f) g)) in tmp. apply pathsinv0 in tmp. use (pathscomp0 tmp). unfold Abelian_op. rewrite AbelianPreCat_op_eq3. rewrite AbelianPreCat_homset_zero_right'. rewrite AbelianPreCat_homset_zero_right'. rewrite AbelianPreCat_homset_inv_left'. rewrite AbelianPreCat_homset_zero_right'. apply idpath. Qed. Lemma Abeliain_precategory_homset_comm' {X Y : A} (f g : X --> Y) : Abelian_minus_op (Abelian_minus_op (AbelianPreCat_homset_zero X Y) f) g = Abelian_minus_op (Abelian_minus_op (AbelianPreCat_homset_zero X Y) g) f. Proof. rewrite <- (AbelianPreCat_homset_zero_right' g). rewrite AbelianPreCat_op_eq3. rewrite (AbelianPreCat_homset_zero_right' f). rewrite (AbelianPreCat_homset_zero_right' g). apply idpath. Qed. Lemma AbelianPreCat_homset_comm {X Y : A} (f g : X --> Y) : Abelian_op _ _ f g = Abelian_op _ _ g f. Proof. (* Use zero left for f *) set (tmp1 := AbelianPreCat_homset_zero_left f). apply (maponpaths (λ h : _, Abelian_op X Y h g)) in tmp1. apply pathsinv0 in tmp1. use (pathscomp0 tmp1). clear tmp1. (* Use zero left for g *) set (tmp2 := AbelianPreCat_homset_zero_left g). apply (maponpaths (λ h : _, Abelian_op X Y h f)) in tmp2. use (pathscomp0 _ tmp2). clear tmp2. (* The goal follows from eq3 and comm' *) unfold Abelian_op. rewrite (AbelianPreCat_op_eq3 _ _ _ g). rewrite (AbelianPreCat_op_eq3 _ _ _ f). rewrite (Abeliain_precategory_homset_comm' _ g). apply idpath. Qed. Lemma AbelianPreCat_homset_inv_minus {X Y : A} (f g : X --> Y) : Abelian_op _ _ f (AbelianPreCat_homset_inv g) = Abelian_minus_op f g. Proof. unfold Abelian_op. unfold AbelianPreCat_homset_inv. set (tmp := AbelianPreCat_homset_zero_left g). unfold Abelian_op in tmp. unfold AbelianPreCat_homset_zero in tmp. rewrite tmp. apply idpath. Qed. Lemma AbelianPreCat_homset_inv_right {X Y : A} (f : X --> Y) : Abelian_op _ _ f (AbelianPreCat_homset_inv f) = AbelianPreCat_homset_zero X Y. Proof. rewrite AbelianPreCat_homset_inv_minus. apply AbelianPreCat_homset_inv_left'. Qed. Lemma AbelianPreCat_homset_assoc_eq1 {X Y : A} (f g : X --> Y) : Abelian_minus_op (AbelianPreCat_homset_zero X Y) (Abelian_minus_op f g) = Abelian_op _ _ (Abelian_minus_op (AbelianPreCat_homset_zero X Y) f) g. Proof. rewrite <- (AbelianPreCat_homset_inv_left' (AbelianPreCat_homset_zero X Y)). unfold Abelian_op. rewrite AbelianPreCat_op_eq3. rewrite (AbelianPreCat_homset_inv_left' (AbelianPreCat_homset_zero X Y)). apply idpath. Qed. Lemma AbelianPreCat_homset_assoc_eq2 {X Y : A} (f g : X --> Y) : Abelian_minus_op (AbelianPreCat_homset_zero X Y) (Abelian_op _ _ f g) = Abelian_minus_op (Abelian_minus_op (AbelianPreCat_homset_zero X Y) f) g. Proof. set (tmp := AbelianPreCat_homset_inv_left' (AbelianPreCat_homset_zero X Y)). apply (maponpaths (λ h : _, Abelian_minus_op h (Abelian_op X Y f g))) in tmp. apply pathsinv0 in tmp. use (pathscomp0 tmp). unfold Abelian_op. rewrite AbelianPreCat_op_eq3. set (tmp2 := AbelianPreCat_homset_zero_left g). unfold Abelian_op in tmp2. rewrite tmp2. apply idpath. Qed. Lemma AbelianPreCat_homset_assoc_eq3 {X Y : A} (f g h : X --> Y) : Abelian_op _ _ (Abelian_minus_op f g) h = Abelian_minus_op f (Abelian_minus_op g h). Proof. unfold Abelian_op. rewrite AbelianPreCat_op_eq3. rewrite AbelianPreCat_homset_zero_right'. apply idpath. Qed. Lemma AbelianPreCat_homset_assoc {X Y : A} (f g h : X --> Y) : Abelian_op _ _ (Abelian_op _ _ f g) h = Abelian_op _ _ f (Abelian_op _ _ g h). Proof. set (tmp := AbelianPreCat_homset_zero_left h). apply (maponpaths (λ k : _, Abelian_op X Y (Abelian_op X Y f g) k)) in tmp. apply pathsinv0 in tmp. use (pathscomp0 tmp). unfold Abelian_op. rewrite AbelianPreCat_op_eq3. rewrite AbelianPreCat_homset_zero_right'. rewrite AbelianPreCat_op_eq3. rewrite AbelianPreCat_homset_zero_right'. apply idpath. Qed. Definition AbelianTocategoryWithAbgropsData : categoryWithAbgropsData AbelianToprecategoryWithBinops. Proof. unfold categoryWithAbgropsData. intros x y. split. - use make_isgrop. + split. * intros f g h. apply AbelianPreCat_homset_assoc. * use make_isunital. -- apply AbelianPreCat_homset_zero. -- split. ++ intros f. apply AbelianPreCat_homset_zero_left. ++ intros f. apply AbelianPreCat_homset_zero_right. + use tpair. * intros f. apply (AbelianPreCat_homset_inv f). * split. -- intros f. apply AbelianPreCat_homset_inv_left. -- intros f. apply AbelianPreCat_homset_inv_right. - intros f g. apply AbelianPreCat_homset_comm. Defined. (** We prove that Abelian_precategories are PrecategoriesWithAbgrops. *) Definition AbelianTocategoryWithAbgrops : categoryWithAbgrops := make_categoryWithAbgrops AbelianToprecategoryWithBinops AbelianTocategoryWithAbgropsData. (** Hide isPreAdditive behind Qed. *) Lemma AbelianToisPreAdditive : isPreAdditive AbelianTocategoryWithAbgrops. Proof. use make_isPreAdditive. (* precomposition ismonoidfun *) - intros x y z f. split. + intros x' x'0. unfold to_premor. cbn. unfold Abelian_op. unfold Abelian_minus_op. cbn in x', x'0. rewrite assoc. apply cancel_postcomposition. set (bpz := to_BinProducts A z z). assert (e : BinProductArrow A bpz (f · x') ((BinProductArrow A bpz (ZeroArrow (to_Zero A) x z) (f · x'0)) · CokernelArrow (CokernelOfDiagonal bpz)) = BinProductArrow A bpz (f · x') ((BinProductArrow A bpz (f · ZeroArrow (to_Zero A) y z) (f · x'0)) · CokernelArrow (CokernelOfDiagonal bpz))). { set (tmp := ZeroArrow_comp_right A (to_Zero A) x y z f). apply (maponpaths (λ h : _, BinProductArrow A bpz (f · x') ((BinProductArrow A bpz h (f · x'0)) · CokernelArrow (CokernelOfDiagonal bpz)))) in tmp. apply pathsinv0 in tmp. apply tmp. } use (pathscomp0 _ (!e)). clear e. rewrite <- precompWithBinProductArrow. rewrite <- assoc. rewrite <- precompWithBinProductArrow. apply idpath. + unfold to_premor. cbn. unfold AbelianPreCat_homset_zero. apply ZeroArrow_comp_right. (* postcomposition is monoidfun *) - intros x y z f. split. + intros x' x'0. unfold to_postmor. cbn. unfold Abelian_op. unfold Abelian_minus_op. cbn in x', x'0. set (bpz := to_BinProducts A z z). assert (e : BinProductArrow A bpz (ZeroArrow (to_Zero A) x z) (x'0 · f) = (BinProductArrow A (to_BinProducts A y y) (ZeroArrow (to_Zero A) x y) x'0) · Abelian_mor_from_to_BinProd f f). { use BinProductArrowsEq. - unfold Abelian_mor_from_to_BinProd. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite ZeroArrow_comp_left. apply idpath. - unfold Abelian_mor_from_to_BinProd. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. apply idpath. } rewrite e. clear e. unfold Abelian_mor_from_to_BinProd. repeat rewrite <- assoc. set (tmp := Abelian_op_eq f). cbn zeta in tmp. unfold bpz. rewrite <- tmp. repeat rewrite assoc. rewrite <- (postcompWithBinProductArrow A _ (to_BinProducts A y y)). repeat rewrite <- assoc. apply cancel_precomposition. unfold BinProductOfArrows. apply tmp. + unfold to_postmor. cbn. unfold AbelianPreCat_homset_zero. apply ZeroArrow_comp_left. Qed. (** We prove that Abelian_precategories are PreAddtitive. *) Definition AbelianToPreAdditive : PreAdditive := make_PreAdditive AbelianTocategoryWithAbgrops AbelianToisPreAdditive. (** Finally, we show that Abelian_precategories are CategoryWithAdditiveStructure. *) Definition AbelianToAdditive : CategoryWithAdditiveStructure. Proof. use make_Additive. - exact AbelianToPreAdditive. - use make_AdditiveStructure. + exact (to_Zero A). + exact (BinDirectSums_from_BinProducts AbelianToPreAdditive (to_Zero A) (to_BinProducts A)). Defined. End abelian_is_additive. UniMath-20231010/UniMath/CategoryTheory/Actegories/000077500000000000000000000000001451125700300217115ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Actegories/Actegories.v000066400000000000000000000527441451125700300242010ustar00rootroot00000000000000(** the concept of left action of a monoidal category on a category written by Ralph Matthes in lockstep with the code in [UniMath.CategoryTheory.MonoidalOld.MonoidalCategoriesWhiskered] naming is inspired from https://ncatlab.org/nlab/show/actegory: the whole structure is an [actegory], the binary operation is the [action], the extra data are the [action_unitor] and the [actor], together with their inverses 2022 *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section A. Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *) (** Data **) Definition action_data (C : category) : UU := bifunctor_data V C C. Identity Coercion actionintobifunctor : action_data >-> bifunctor_data. (** the following widens the concept of left unitor of a monoidal category, a right unitor is not appropriate for actions *) Definition action_unitor_data {C : category} (A : action_data C) : UU := ∏ (x : C), C⟦I_{Mon_V} ⊗_{A} x, x⟧. Definition action_unitorinv_data {C : category} (A : action_data C) : UU := ∏ (x : C), C⟦x, I_{Mon_V} ⊗_{A} x⟧. Definition actor_data {C : category} (A : action_data C) : UU := ∏ (v w : V) (x : C), C ⟦(v ⊗_{Mon_V} w) ⊗_{A} x, v ⊗_{A} (w ⊗_{A} x)⟧. Definition actorinv_data {C : category} (A : action_data C) : UU := ∏ (v w : V) (x : C), C ⟦v ⊗_{A} (w ⊗_{A} x), (v ⊗_{Mon_V} w) ⊗_{A} x⟧. Definition actegory_data (C : category) : UU := ∑ A : action_data C, (action_unitor_data A) × (action_unitorinv_data A) × (actor_data A) × (actorinv_data A). Definition make_actegory_data {C : category} {A : action_data C} (au : action_unitor_data A) (auinv : action_unitorinv_data A) (aα : actor_data A) (aαinv : actorinv_data A) : actegory_data C := (A,,au,,auinv,,aα,,aαinv). Definition actegory_action_data {C : category} (AD : actegory_data C) : action_data C := pr1 AD. Coercion actegory_action_data : actegory_data >-> action_data. Definition actegory_unitordata {C : category} (AD : actegory_data C) : action_unitor_data AD := pr1 (pr2 AD). Notation "au_{ AD }" := (actegory_unitordata AD). Definition actegory_unitorinvdata {C : category} (AD : actegory_data C) : action_unitorinv_data AD := pr12 (pr2 AD). Notation "auinv_{ AD }" := (actegory_unitorinvdata AD). Definition actegory_actordata {C : category} (AD : actegory_data C) : actor_data AD := pr12 (pr2 (pr2 AD)). Notation "aα_{ AD }" := (actegory_actordata AD). Definition actegory_actorinvdata {C : category} (AD : actegory_data C) : actorinv_data AD := pr22 (pr2 (pr2 AD)). Notation "aαinv_{ AD }" := (actegory_actorinvdata AD). (** Axioms **) Definition action_unitor_nat {C : category} {A : action_data C} (au : action_unitor_data A) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), I_{Mon_V} ⊗^{A}_{l} f · au y = au x · f. Definition action_unitorinv_nat {C : category} {A : action_data C} (auinv : action_unitorinv_data A) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), auinv x · I_{Mon_V} ⊗^{A}_{l} f = f · auinv y. Definition action_unitor_iso_law {C : category} {A : action_data C} (au : action_unitor_data A) (auinv : action_unitorinv_data A) : UU := ∏ (x : C), is_inverse_in_precat (au x) (auinv x). Definition action_unitor_law {C : category} {A : action_data C} (au : action_unitor_data A) (auinv : action_unitorinv_data A) : UU := action_unitor_nat au × action_unitor_iso_law au auinv. Definition action_unitorlaw_nat {C : category} {A : action_data C} {au : action_unitor_data A} {auinv : action_unitorinv_data A} (aul : action_unitor_law au auinv) : action_unitor_nat au := pr1 aul. Definition action_unitorlaw_iso_law {C : category} {A : action_data C} {au : action_unitor_data A} {auinv : action_unitorinv_data A} (aul : action_unitor_law au auinv) : action_unitor_iso_law au auinv := pr2 aul. Definition actor_nat_leftwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU := ∏ (v w : V) (z z' : C) (h : C⟦z,z'⟧), (aα v w z) · (v ⊗^{A}_{l} (w ⊗^{A}_{l} h)) = ((v ⊗_{Mon_V} w) ⊗^{A}_{l} h) · (aα v w z'). Definition actor_nat_rightwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU := ∏ (v v' w : V) (z : C) (f : V⟦v,v'⟧), (aα v w z) · (f ⊗^{A}_{r} (w ⊗_{A} z)) = ((f ⊗^{Mon_V}_{r} w) ⊗^{A}_{r} z) · (aα v' w z). Definition actor_nat_leftrightwhisker {C : category} {A : action_data C} (aα : actor_data A) : UU := ∏ (v w w' : V) (z : C) (g : V⟦w,w'⟧), (aα v w z) · (v ⊗^{A}_{l} (g ⊗^{A}_{r} z)) = ((v ⊗^{Mon_V}_{l} g) ⊗^{A}_{r} z) · (aα v w' z). Definition actor_iso_law {C : category} {A : action_data C} (aα : actor_data A) (aαinv : actorinv_data A) : UU := ∏ (v w : V) (z : C), is_inverse_in_precat (aα v w z) (aαinv v w z). Definition actor_law {C : category} {A : action_data C} (aα : actor_data A) (aαinv : actorinv_data A) : UU := (actor_nat_leftwhisker aα) × (actor_nat_rightwhisker aα) × (actor_nat_leftrightwhisker aα) × (actor_iso_law aα aαinv). Definition actorlaw_natleft {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A} (aαl : actor_law aα aαinv) : actor_nat_leftwhisker aα := pr1 aαl. Definition actorlaw_natright {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A} (aαl : actor_law aα aαinv) : actor_nat_rightwhisker aα := pr1 (pr2 aαl). Definition actorlaw_natleftright {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A} (aαl : actor_law aα aαinv) : actor_nat_leftrightwhisker aα := pr1 (pr2 (pr2 aαl)). Definition actorlaw_iso_law {C : category} {A : action_data C} {aα : actor_data A} {aαinv : actorinv_data A} (aαl : actor_law aα aαinv) : actor_iso_law aα aαinv := pr2 (pr2 (pr2 aαl)). Definition actegory_triangle_identity {C : category} {A : action_data C} (au : action_unitor_data A) (aα : actor_data A) := ∏ (v : V) (y : C), (aα v I_{Mon_V} y) · (v ⊗^{A}_{l} (au y)) = (ru_{Mon_V} v) ⊗^{A}_{r} y. Definition actegory_triangle_identity' {C : category} {A : action_data C} (au : action_unitor_data A) (aα : actor_data A) := ∏ (v : V) (y : C), (aα I_{Mon_V} v y) · (au (v ⊗_{A} y)) = (lu_{Mon_V} v) ⊗^{A}_{r} y. Definition actegory_pentagon_identity {C : category} {A : action_data C} (aα : actor_data A) : UU := ∏ (w v v' : V) (z : C), ((α_{Mon_V} w v v') ⊗^{A}_{r} z) · (aα w (v ⊗_{Mon_V} v') z) · (w ⊗^{A}_{l} (aα v v' z)) = (aα (w⊗_{Mon_V} v) v' z) · (aα w v (v' ⊗_{A} z)). Definition actegory_laws {C : category} (AD : actegory_data C) : UU := is_bifunctor AD × (action_unitor_law au_{AD} auinv_{AD}) × (actor_law aα_{AD} aαinv_{AD}) × (actegory_triangle_identity au_{AD} aα_{AD}) × (actegory_pentagon_identity aα_{AD}). Definition actegory (C : category) : UU := ∑ (AD : actegory_data C), (actegory_laws AD). Definition actegory_actdata {C : category} (Act : actegory C) : actegory_data C := pr1 Act. Coercion actegory_actdata : actegory >-> actegory_data. Definition actegory_actlaws {C : category} (Act : actegory C) : actegory_laws Act := pr2 Act. Definition actegory_action_is_bifunctor {C : category} (Act : actegory C) : is_bifunctor Act := pr12 Act. Coercion actegory_action {C : category} (Act : actegory C) : bifunctor V C C := _ ,, actegory_action_is_bifunctor Act. Definition actegory_unitorlaw {C : category} (Act : actegory C) : action_unitor_law au_{Act} auinv_{Act} := pr12 (actegory_actlaws Act). Definition actegory_unitornat {C : category} (Act : actegory C) : action_unitor_nat au_{Act} := action_unitorlaw_nat (actegory_unitorlaw Act). Definition actegory_unitorisolaw {C : category} (Act : actegory C) : action_unitor_iso_law au_{Act} auinv_{Act} := action_unitorlaw_iso_law (actegory_unitorlaw Act). Lemma actegory_unitorinvnat {C : category} (Act : actegory C) : action_unitorinv_nat auinv_{Act}. Proof. intros x y f. apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_unitorisolaw Act x)). cbn. rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,_,,actegory_unitorisolaw Act y)). apply pathsinv0, actegory_unitornat. Qed. Definition actegory_actorlaw {C : category} (Act : actegory C) : actor_law aα_{Act} aαinv_{Act} := pr122 (actegory_actlaws Act). Definition actegory_actornatleft {C : category} (Act : actegory C) : actor_nat_leftwhisker aα_{Act} := actorlaw_natleft (actegory_actorlaw Act). Definition actegory_actornatright {C : category} (Act : actegory C) : actor_nat_rightwhisker aα_{Act} := actorlaw_natright (actegory_actorlaw Act). Definition actegory_actornatleftright {C : category} (Act : actegory C) : actor_nat_leftrightwhisker aα_{Act} := actorlaw_natleftright (actegory_actorlaw Act). Definition actegory_actorisolaw {C : category} (Act : actegory C) : actor_iso_law aα_{Act} aαinv_{Act} := actorlaw_iso_law (actegory_actorlaw Act). Lemma actor_nat1 {C : category} (Act : actegory C) {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) : (actegory_actordata Act v w z) · ((f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (v' ⊗^{Act}_{l} ((g ⊗^{Act}_{r} z) · (w' ⊗^{Act}_{l} h)))) = (((f ⊗^{Mon_V}_{r} w) · (v' ⊗^{Mon_V}_{l} g)) ⊗^{Act}_{r} z) · ((v' ⊗_{Mon_V} w') ⊗^{Act}_{l} h) · (actegory_actordata Act v' w' z'). Proof. rewrite assoc. rewrite (actegory_actornatright Act). rewrite assoc'. etrans. { apply cancel_precomposition. rewrite (bifunctor_leftcomp Act). rewrite assoc. rewrite (actegory_actornatleftright Act). apply idpath. } etrans. { apply cancel_precomposition. rewrite assoc'. apply cancel_precomposition. apply (actegory_actornatleft Act). } rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply pathsinv0. rewrite (bifunctor_rightcomp Act). apply idpath. Qed. Lemma actor_nat2 {C : category} (Act : actegory C) {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) : (actegory_actordata Act v w z) · (f ⊗^{Act} (g ⊗^{Act} h)) = ((f ⊗^{Mon_V} g) ⊗^{Act} h) · (actegory_actordata Act v' w' z'). Proof. intros. unfold functoronmorphisms1. exact (actor_nat1 Act f g h). Qed. Definition actegory_triangleidentity {C : category} (Act : actegory C) : actegory_triangle_identity au_{Act} aα_{Act} := pr1 (pr222 (actegory_actlaws Act)). Definition actegory_pentagonidentity {C : category} (Act : actegory C) : actegory_pentagon_identity aα_{Act} := pr2 (pr222 (actegory_actlaws Act)). Lemma isaprop_actegory_laws {C : category} (AD : actegory_data C) : isaprop (actegory_laws AD). Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; repeat (try apply C) ; repeat (apply isaprop_is_inverse_in_precat). Qed. (** Some additional data and properties which one deduces from actegories **) Lemma action_unitor_nat_z_iso {C : category} (Act : actegory C): nat_z_iso (leftwhiskering_functor Act I_{Mon_V}) (functor_identity C). Proof. use make_nat_z_iso. - use make_nat_trans. + exact (λ x, au_{Act} x). + exact (λ x y f, actegory_unitornat Act x y f). - intro x. exists (auinv_{Act} x). apply (actegory_unitorisolaw Act x). Defined. Definition z_iso_from_actor_iso {C : category} (Act : actegory C) (v w : V) (x : C) : z_iso ((v ⊗_{Mon_V} w) ⊗_{Act} x) (v ⊗_{Act} (w ⊗_{Act} x)) := make_z_iso (aα_{Act} v w x) (aαinv_{Act} v w x) (actegory_actorisolaw Act v w x). Definition actorinv_nat_leftwhisker {C : category} (Act : actegory C) : ∏ (v w : V) (z z' : C) (h : C⟦z,z'⟧), (v ⊗^{Act}_{l} (w ⊗^{Act}_{l} h)) · (aαinv_{Act} v w z') = (aαinv_{Act} v w z) · ((v ⊗_{Mon_V} w) ⊗^{Act}_{l} h) . Proof. intros v w z z' h. apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v w z')). apply actegory_actornatleft. Qed. Definition actorinv_nat_rightwhisker {C : category} (Act : actegory C) : ∏ (v v' w : V) (z: C) (f : V⟦v,v'⟧), (f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (aαinv_{Act} v' w z) = (aαinv_{Act} v w z) · ((f ⊗^{Mon_V}_{r} w) ⊗^{Act}_{r} z). Proof. intros v v' w z f. apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v' w z)). apply actegory_actornatright. Qed. Definition actorinv_nat_leftrightwhisker {C : category} (Act : actegory C) : ∏ (v w w' : V) (z : C) (g : V⟦w,w'⟧), (v ⊗^{Act}_{l} (g ⊗^{Act}_{r} z)) · (aαinv_{Act} v w' z) = (aαinv_{Act} v w z) · ((v ⊗^{Mon_V}_{l} g) ⊗^{Act}_{r} z). Proof. intros v w w' z g. apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v w' z)). apply actegory_actornatleftright. Qed. Definition actorinv_nat1 {C : category} (Act : actegory C) {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) : ((f ⊗^{Act}_{r} (w ⊗_{Act} z)) · (v' ⊗^{Act}_{l} ((g ⊗^{Act}_{r} z) · (w' ⊗^{Act}_{l} h)))) · (aαinv_{Act} v' w' z') = (aαinv_{Act} v w z) · ((((f ⊗^{Mon_V}_{r} w) · (v' ⊗^{Mon_V}_{l} g)) ⊗^{Act}_{r} z) · ((v' ⊗_{Mon_V} w') ⊗^{ Act}_{l} h)). Proof. apply (swap_nat_along_zisos (z_iso_from_actor_iso Act v w z) (z_iso_from_actor_iso Act v' w' z') ). unfold z_iso_from_actor_iso. unfold make_z_iso. unfold make_is_z_isomorphism. unfold pr1. apply actor_nat1. Qed. Lemma actorinv_nat2 {C : category} (Act : actegory C) {v v' w w' : V} {z z' : C} (f : V⟦v,v'⟧) (g : V⟦w,w'⟧) (h : C⟦z,z'⟧) : (f ⊗^{Act} (g ⊗^{Act} h)) · (aαinv_{Act} v' w' z') = (aαinv_{Act} v w z) · ((f ⊗^{Mon_V} g) ⊗^{Act} h). Proof. intros. unfold functoronmorphisms1. apply actorinv_nat1. Qed. Lemma pentagon_identity_actorinv {C : category} (Act : actegory C) (w v u : V) (z : C): w ⊗^{ Act}_{l} (aαinv_{Act} v u z) · aαinv_{Act} w (v ⊗_{Mon_V} u) z · αinv_{Mon_V} w v u ⊗^{Act}_{r} z = aαinv_{Act} w v (u ⊗_{Act} z) · aαinv_{Act} (w ⊗_{Mon_V} v) u z. Proof. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Act _ _ _)). unfold z_iso_from_actor_iso. unfold make_z_iso. unfold make_is_z_isomorphism. etrans. { apply (pathsinv0 (id_right _)). } apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Act _ _ _)). cbn. apply pathsinv0. etrans. { rewrite assoc. apply cancel_postcomposition. apply (pathsinv0 (actegory_pentagonidentity Act w v u z)). } etrans. { rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. rewrite assoc'. apply cancel_precomposition. apply (pathsinv0 (bifunctor_leftcomp Act _ _ _ _ _ _)). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply cancel_precomposition. apply maponpaths. apply (pr2 (z_iso_from_actor_iso Act v u z)). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply cancel_precomposition. apply (bifunctor_leftid Act). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply id_right. } etrans. { apply cancel_postcomposition. rewrite assoc'. apply cancel_precomposition. apply (pr2 (z_iso_from_actor_iso Act w (v⊗_{Mon_V}u) z)). } etrans. { apply cancel_postcomposition. apply id_right. } etrans. { apply (pathsinv0 (bifunctor_rightcomp Act _ _ _ _ _ _)). } etrans. { apply maponpaths. apply (pr2 (pr2 (z_iso_from_associator_iso Mon_V w v u))). } apply (bifunctor_rightid Act). Qed. End A. Arguments actegory_unitordata {_ _ _} _ _. Arguments actegory_unitorinvdata {_ _ _} _ _. Arguments actegory_actordata {_ _ _} _ _ _ _. Arguments actegory_actorinvdata {_ _ _} _ _ _ _. Module ActegoryNotations. Notation "au_{ Act }" := (actegory_unitordata Act). Notation "aα_{ Act }" := (actegory_actordata Act). Notation "au^{ Act }_{ x }" := (actegory_unitordata Act x ). Notation "aα^{ Act }_{ v , w , x }" := (actegory_actordata Act v w x). Notation "auinv^{ Act }_{ x }" := (actegory_unitorinvdata Act x ). Notation "aαinv^{ Act }_{ v , w , x }" := (actegory_actorinvdata Act v w x). End ActegoryNotations. Section EquivalenceFromTensorWithUnit. Import MonoidalNotations. Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C). Definition ladjunction_data_from_action_with_unit : Core.adjunction_data C C. Proof. exists (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}). exists (functor_identity C). use tpair. - apply (nat_z_iso_inv (action_unitor_nat_z_iso _ Act)). - apply (action_unitor_nat_z_iso _ Act). Defined. Definition lequivalence_from_action_with_unit : equivalence_of_cats C C. Proof. exists ladjunction_data_from_action_with_unit. split. - intro ; apply (nat_z_iso_inv (action_unitor_nat_z_iso _ Act)). - intro ; apply (action_unitor_nat_z_iso _ Act). Defined. Lemma leftwhiskering_fullyfaithful_action : fully_faithful (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}). Proof. apply fully_faithful_from_equivalence. exact (adjointification lequivalence_from_action_with_unit). Defined. Lemma leftwhiskering_faithful_action : faithful (leftwhiskering_functor (actegory_action _ Act) I_{Mon_V}). Proof. exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ leftwhiskering_fullyfaithful_action)). Defined. End EquivalenceFromTensorWithUnit. Section SecondTriangleEquality. Import MonoidalNotations. Import ActegoryNotations. Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C). Local Lemma lemma0 (v : V) (x : C) : (α_{Mon_V} I_{Mon_V} I_{Mon_V} v) ⊗^{Act}_{r} x · (I_{ Mon_V} ⊗^{ Mon_V}_{l} lu^{ Mon_V }_{ v}) ⊗^{ Act}_{r} x = (ru^{ Mon_V }_{ I_{ Mon_V}} ⊗^{ Mon_V}_{r} v) ⊗^{ Act}_{r} x. Proof. refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _). apply maponpaths. apply (monoidal_triangleidentity Mon_V I_{Mon_V} v). Qed. Local Lemma lemma2 (v : V) (x : C) : I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) = aαinv^{Act}_{ I_{Mon_V}, (I_{Mon_V} ⊗_{Mon_V} v), x} · (((I_{Mon_V} ⊗^{Mon_V}_{l} lu_{Mon_V} v) ⊗^{Act}_{r} x) · aα_{Act} I_{Mon_V} v x). Proof. set (aαiso := make_z_iso _ _ (actegory_actorisolaw Mon_V Act I_{Mon_V} (I_{Mon_V} ⊗_{Mon_V} v) x)). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ aαiso). apply pathsinv0. apply (actegory_actornatleftright Mon_V Act). Qed. Local Lemma lemma2' (v : V) (x : C) : (I_{ Mon_V} ⊗^{ Mon_V}_{l} lu^{ Mon_V }_{ v}) ⊗^{ Act}_{r} x = αinv^{ Mon_V }_{ I_{ Mon_V}, I_{ Mon_V}, v} ⊗^{ Act}_{r} x · (ru^{ Mon_V }_{ I_{ Mon_V}} ⊗^{ Mon_V}_{r} v) ⊗^{ Act}_{r} x. Proof. apply pathsinv0. set (αiso := make_z_iso _ _ (monoidal_associatorisolaw Mon_V I_{Mon_V} I_{Mon_V} v)). set (αisor := functor_on_z_iso (rightwhiskering_functor Act x) αiso). apply (z_iso_inv_on_right _ _ _ αisor). apply pathsinv0. apply lemma0. Qed. Local Lemma lemma3 (v : V) (x : C) : I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) = aαinv^{Act}_{ I_{Mon_V}, (I_{Mon_V} ⊗_{Mon_V} v), x} · ((((αinv_{Mon_V} I_{Mon_V} I_{Mon_V} v) ⊗^{Act}_{r} x) · (ru_{Mon_V} I_{Mon_V} ⊗^{Mon_V}_{r} v) ⊗^{Act}_{r} x) · aα_{Act} I_{Mon_V} v x). Proof. refine (lemma2 v x @ _). apply maponpaths. apply maponpaths_2. apply lemma2'. Qed. Local Lemma right_whisker_with_action_unitor' (v : V) (x : C) : I_{Mon_V} ⊗^{Act}_{l} (lu_{Mon_V} v ⊗^{Act}_{r} x) = I_{Mon_V} ⊗^{Act}_{l} (aα_{Act} I_{Mon_V} v x · au_{Act} (v ⊗_{Act} x)). Proof. refine (lemma3 v x @ _). set (aαiso := make_z_iso _ _ (actegory_actorisolaw Mon_V Act I_{Mon_V} (I_{Mon_V} ⊗_{Mon_V} v) x)). apply (z_iso_inv_on_right _ _ _ aαiso). set (αiso' := make_z_iso _ _ (monoidal_associatorisolaw Mon_V I_{Mon_V} I_{Mon_V} v)). set (αisor := functor_on_z_iso (rightwhiskering_functor Act x) αiso'). etrans. { apply assoc'. } apply (z_iso_inv_on_right _ _ _ αisor). apply pathsinv0. simpl. etrans. { apply assoc. } etrans. { apply maponpaths. apply (bifunctor_leftcomp Act _ _ _ _ _ _). } etrans. { apply assoc. } etrans. { apply maponpaths_2. apply (actegory_pentagonidentity Mon_V Act I_{Mon_V} I_{Mon_V} v x). } etrans. 2: { apply (actegory_actornatright Mon_V Act). } etrans. { apply assoc'. } apply maponpaths. apply actegory_triangleidentity. Qed. Lemma right_whisker_with_action_unitor : actegory_triangle_identity' Mon_V au_{Act} aα_{Act}. Proof. intros v x. use faithful_reflects_commutative_triangle. 3: { apply (leftwhiskering_faithful_action(V:=V)). } apply pathsinv0. refine (right_whisker_with_action_unitor' _ _ @ _). apply (bifunctor_leftcomp Act). Qed. Definition actegory_triangleidentity' := right_whisker_with_action_unitor. End SecondTriangleEquality. UniMath-20231010/UniMath/CategoryTheory/Actegories/ActionBasedStrongMonads.v000066400000000000000000000071771451125700300266270ustar00rootroot00000000000000(** - the notion of strong monads w.r.t. monoidal actions (a generalization of the notion w.r.t. a monad) - an instantiation to strong monads in monoidal categories see https://ncatlab.org/nlab/show/strong+monad for a general bicategorical formulation and for the one w.r.t. a monad, the present notion is intermediately abstract/general and only sketched on that page author: Ralph Matthes 2022 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section A. Context {V : category} {Mon_V : monoidal V} {C : category} (Act : actegory Mon_V C). Definition ηandμlinear {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) : UU := is_linear_nat_trans (identity_lineator_lax Mon_V Act) Ml (η M) × is_linear_nat_trans (comp_lineator_lax Mon_V Ml Ml) Ml (μ M). Definition ηandμlinearnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) : UU := ∏ (v : V) (x : C), η M (v ⊗_{Act} x) = v ⊗^{Act}_{l} η M x · Ml v x × v ⊗^{Act}_{l} μ M x · Ml v x = Ml v (M x) · #M (Ml v x) · μ M (v ⊗_{Act} x). Lemma ηandμlinearimpliesnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) (ηandμlin : ηandμlinear Ml) : ηandμlinearnicer Ml. Proof. split. - etrans. 2: { apply ηandμlin. } apply pathsinv0, id_left. - apply pathsinv0, ηandμlin. Qed. Lemma ηandμlinearfollowsfromnicer {M: Monad C} (Ml : lineator_lax Mon_V Act Act M) (ηandμlinn : ηandμlinearnicer Ml) : ηandμlinear Ml. Proof. split. - red; intros. etrans. 2: { apply ηandμlinn. } apply id_left. - red; intros. apply pathsinv0, ηandμlinn. Qed. Definition actionbasedstrongmonads_cat_disp : disp_cat (category_Monad C). Proof. use tpair. - use tpair. + use make_disp_cat_ob_mor. * intro M. exact (∑ Ml : lineator_lax Mon_V Act Act (M: Monad C), ηandμlinear Ml). * intros M N [Ml islinM] [Nl islinN] α. exact (is_linear_nat_trans Ml Nl (nat_trans_from_monad_mor _ _ α)). + split. * intros M [Ml [islinMη islimMμ]]. cbn. apply is_linear_nat_trans_identity. * intros M N O α α' Mll Nll Oll islntα islntβ. exact (is_linear_nat_trans_comp (pr1 Mll) (pr1 Nll) (pr1 Oll) islntα islntβ). - repeat split; intros; try apply isaprop_is_linear_nat_trans. apply isasetaprop; apply isaprop_is_linear_nat_trans. Defined. Definition actionbasedstrongmonads_cat_total : category := total_category actionbasedstrongmonads_cat_disp. End A. Section StrongMonads. Context {C : category} (M : monoidal C). Definition strongmonads_cat_disp : disp_cat (category_Monad C) := actionbasedstrongmonads_cat_disp (actegory_with_canonical_self_action M). Definition strongmonads_cat_total : category := total_category strongmonads_cat_disp. End StrongMonads. UniMath-20231010/UniMath/CategoryTheory/Actegories/ConstructionOfActegories.v000066400000000000000000000226721451125700300270760ustar00rootroot00000000000000(** Construction of actegories: - the monoidal category acting on itself - reindexing an action from the target of a strong monoidal functor to its source Reconstructs the results from [UniMath.Bicategories.MonoidalCategories.ConstructionOfActions] in the whiskered setting. authors: Ralph Matthes, Kobe Wullaert 2022 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.Actegories.Actegories. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section A. Context {V : category} (Mon_V : monoidal V). Definition actegory_with_canonical_self_action_data: actegory_data Mon_V V. Proof. use make_actegory_data. - exact (monoidal_tensor_data Mon_V). - exact (lu_{Mon_V}). - exact (luinv_{Mon_V}). - exact (α_{Mon_V}). - exact (αinv_{Mon_V}). Defined. Lemma actegory_with_canonical_self_action_laws: actegory_laws Mon_V actegory_with_canonical_self_action_data. Proof. split5. - apply monoidal_tensor_is_bifunctor. - apply monoidal_leftunitorlaw. - apply monoidal_associatorlaw. - apply monoidal_triangleidentity. - apply monoidal_pentagonidentity. Qed. Definition actegory_with_canonical_self_action: actegory Mon_V V := actegory_with_canonical_self_action_data,,actegory_with_canonical_self_action_laws. Context {C : category} (Act : actegory Mon_V C) {W : category} (Mon_W : monoidal W). Context {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F). Definition reindexed_action_data: bifunctor_data W C C. Proof. use make_bifunctor_data. - intros w x. exact (F w ⊗_{Act} x). - intros w x x' f. exact (F w ⊗^{Act}_{l} f). - intros x w w' g. exact (#F g ⊗^{Act}_{r} x). Defined. Lemma reindexed_action_data_is_bifunctor: is_bifunctor reindexed_action_data. Proof. split5; red; intros; cbn. - apply (bifunctor_leftid Act). - rewrite functor_id. apply (bifunctor_rightid Act). - apply (bifunctor_leftcomp Act). - rewrite functor_comp. apply (bifunctor_rightcomp Act). - apply (bifunctor_equalwhiskers Act). Qed. Definition reindexed_action_unitor_data : action_unitor_data Mon_W reindexed_action_data. Proof. intro x. exact (pr1 (fmonoidal_preservesunitstrongly U) ⊗^{Act}_{r} x · au^{Act}_{x}). Defined. Definition reindexed_action_unitorinv_data : action_unitorinv_data Mon_W reindexed_action_data. Proof. intro x. exact (auinv^{Act}_{x} · fmonoidal_preservesunit U ⊗^{Act}_{r} x). Defined. Definition reindexed_actor_data : actor_data Mon_W reindexed_action_data. Proof. intros v w x. exact (pr1 (fmonoidal_preservestensorstrongly U v w) ⊗^{Act}_{r} x · aα^{Act}_{F v,F w,x}). Defined. Definition reindexed_actorinv_data : actorinv_data Mon_W reindexed_action_data. Proof. intros v w x. exact (aαinv^{Act}_{F v,F w,x} · fmonoidal_preservestensordata U v w ⊗^{Act}_{r} x). Defined. Definition reindexed_actegory_data: actegory_data Mon_W C. Proof. use make_actegory_data. - exact reindexed_action_data. - exact reindexed_action_unitor_data. - exact reindexed_action_unitorinv_data. - exact reindexed_actor_data. - exact reindexed_actorinv_data. Defined. Lemma reindexed_actegory_laws: actegory_laws Mon_W reindexed_actegory_data. Proof. split5. (* splits into the 5 main goals *) - exact reindexed_action_data_is_bifunctor. - split3. + intros x y f. cbn. unfold reindexed_action_unitor_data. etrans. 2: { rewrite assoc'. apply maponpaths. exact (actegory_unitornat Mon_V Act x y f). } do 2 rewrite assoc. apply maponpaths_2. apply (! bifunctor_equalwhiskers Act _ _ _ _ (pr1 (fmonoidal_preservesunitstrongly U)) f). + cbn. unfold reindexed_action_unitor_data. unfold reindexed_action_unitorinv_data. etrans. { rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. exact (pr1 (actegory_unitorisolaw Mon_V Act x)). } rewrite id_left. refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _). etrans. { apply maponpaths. exact (pr22 (fmonoidal_preservesunitstrongly U)). } apply (bifunctor_rightid Act). + cbn. unfold reindexed_action_unitor_data. unfold reindexed_action_unitorinv_data. etrans. { rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _). apply maponpaths. exact (pr12 (fmonoidal_preservesunitstrongly U)). } rewrite bifunctor_rightid. rewrite id_left. exact (pr2 (actegory_unitorisolaw Mon_V Act x)). - split4. + intros v w z z' h. cbn. unfold reindexed_actor_data. rewrite assoc'. rewrite (actegory_actornatleft Mon_V Act (F v) (F w) z z' h). do 2 rewrite assoc. apply maponpaths_2. apply (bifunctor_equalwhiskers Act). + intros v v' w z f. cbn. unfold reindexed_actor_data. rewrite assoc'. rewrite (actegory_actornatright Mon_V Act). do 2 rewrite assoc. apply maponpaths_2. do 2 rewrite (! bifunctor_rightcomp Act _ _ _ _ _ _). apply maponpaths. apply preserves_tensorinv_nat_right. exact (fmonoidal_preservestensornatright U). + intros v w w' z g. cbn. unfold reindexed_actor_data. rewrite assoc'. rewrite (actegory_actornatleftright Mon_V Act). do 2 rewrite assoc. apply maponpaths_2. do 2 rewrite (! bifunctor_rightcomp Act _ _ _ _ _ _). apply maponpaths. apply preserves_tensorinv_nat_left. exact (fmonoidal_preservestensornatleft U). + split. * cbn. unfold reindexed_actor_data. unfold reindexed_actorinv_data. etrans. { rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. exact (pr1 (actegory_actorisolaw Mon_V Act (F v) (F w) z)). } rewrite id_left. refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _). etrans. { apply maponpaths. exact (pr22 (fmonoidal_preservestensorstrongly U v w)). } apply bifunctor_rightid. * cbn. unfold reindexed_actor_data. unfold reindexed_actorinv_data. etrans. { rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. refine (! bifunctor_rightcomp Act _ _ _ _ _ _ @ _). apply maponpaths. exact (pr12 (fmonoidal_preservestensorstrongly U v w)). } rewrite bifunctor_rightid. rewrite id_left. exact (pr2 (actegory_actorisolaw Mon_V Act (F v) (F w) z)). - intros v y. cbn. unfold reindexed_actor_data. unfold reindexed_action_unitor_data. rewrite assoc'. rewrite (bifunctor_leftcomp Act). etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. apply (actegory_actornatleftright Mon_V Act). } rewrite assoc'. etrans. { do 2 apply maponpaths. apply (actegory_triangleidentity Mon_V Act (F v) y). } do 2 rewrite (! bifunctor_rightcomp Act _ _ _ _ _ _). apply maponpaths. rewrite (! fmonoidal_preservesrightunitality U v). etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite assoc. apply maponpaths_2. rewrite (! bifunctor_leftcomp Mon_V _ _ _ _ _ _). apply maponpaths. exact (pr22 (fmonoidal_preservesunitstrongly U)). } rewrite bifunctor_leftid. rewrite id_left. rewrite assoc. rewrite (pr22 (fmonoidal_preservestensorstrongly U v I_{Mon_W})). apply id_left. - intros w v v' z. cbn. unfold reindexed_actor_data. etrans. 2: { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. exact (! actegory_actornatright Mon_V Act _ _ _ _ _). } etrans. 2: { rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. exact (actegory_pentagonidentity Mon_V Act (F w) (F v) (F v') z). } rewrite (bifunctor_leftcomp Act). rewrite assoc'. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. apply (actegory_actornatleftright Mon_V Act). } repeat (rewrite assoc). do 2 apply maponpaths_2. repeat (rewrite (! bifunctor_rightcomp Act _ _ _ _ _ _)). apply maponpaths. set (pα := fmonoidal_preservesassociativity U). apply (! preserves_associativity_of_inverse_preserves_tensor pα _ _ _ _). Qed. Definition reindexed_actegory: actegory Mon_W C := reindexed_actegory_data,,reindexed_actegory_laws. End A. Section B. Context {V : category} (Mon_V : monoidal V). Definition actegory_with_canonical_pointed_action: actegory (monoidal_pointed_objects Mon_V) V := reindexed_actegory Mon_V (actegory_with_canonical_self_action Mon_V) (monoidal_pointed_objects Mon_V) (forget_monoidal_pointed_objects_monoidal Mon_V). End B. UniMath-20231010/UniMath/CategoryTheory/Actegories/ConstructionOfActegoryMorphisms.v000066400000000000000000001234471451125700300304720ustar00rootroot00000000000000(** Construction of actegory morphisms Part Generalization of pointed distributivity laws (a misnomer as it became clear in July 2023) to relative lax commutators in general monoidal categories - definition - construction of actegory morphism from it - composition Part Closure of the notion of actegory morphisms under - the pointwise binary product of functors - the pointwise binary coproduct of functors author: Ralph Matthes 2022 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Actegories.ProductsInActegories. Require Import UniMath.CategoryTheory.Actegories.ProductActegory. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section ReindexedLineatorAndRelativeLaxCommutator. Context {V : category} (Mon_V : monoidal V) {W : category} (Mon_W : monoidal W) {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F). Section ReindexedLaxLineator. Context {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D). Section OnFunctors. Context {H : functor C D} (ll : lineator_lax Mon_V ActC ActD H). Definition reindexed_lax_lineator_data : lineator_data Mon_W (reindexed_actegory Mon_V ActC Mon_W U) (reindexed_actegory Mon_V ActD Mon_W U) H. Proof. intros w c. exact (ll (F w) c). Defined. Lemma reindexed_lax_lineator_laws : lineator_laxlaws Mon_W (reindexed_actegory Mon_V ActC Mon_W U) (reindexed_actegory Mon_V ActD Mon_W U) H reindexed_lax_lineator_data. Proof. split4. - intro; intros. apply (lineator_linnatleft _ _ _ _ ll). - intro; intros. apply (lineator_linnatright _ _ _ _ ll). - intro; intros. cbn. unfold reindexed_lax_lineator_data, reindexed_actor_data. etrans. 2: { repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply (lineator_preservesactor _ _ _ _ ll). } etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, lineator_linnatright. } etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } apply idpath. - intro; intros. cbn. unfold reindexed_lax_lineator_data, reindexed_action_unitor_data. etrans. 2: { apply maponpaths. apply (lineator_preservesunitor _ _ _ _ ll). } etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, lineator_linnatright. } etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } apply idpath. Qed. Definition reindexed_lax_lineator : lineator_lax Mon_W (reindexed_actegory Mon_V ActC Mon_W U) (reindexed_actegory Mon_V ActD Mon_W U) H := _,,reindexed_lax_lineator_laws. End OnFunctors. Section OnNaturalTransformations. Context {H : functor C D} (Hl : lineator_lax Mon_V ActC ActD H) {K : functor C D} (Kl : lineator_lax Mon_V ActC ActD K) {ξ : H ⟹ K} (islntξ : is_linear_nat_trans Hl Kl ξ). Lemma preserves_linearity_reindexed_lax_lineator : is_linear_nat_trans (reindexed_lax_lineator Hl) (reindexed_lax_lineator Kl) ξ. Proof. intros w c. apply islntξ. Qed. End OnNaturalTransformations. End ReindexedLaxLineator. Section RelativeLaxCommutator. Section FixAnObject. Context {v0 : V}. Definition relativelaxcommutator_data: UU := ∏ (w: W), F w ⊗_{Mon_V} v0 --> v0 ⊗_{Mon_V} F w. Identity Coercion relativelaxcommutator_data_funclass: relativelaxcommutator_data >-> Funclass. Section γ_laws. Context (γ : relativelaxcommutator_data). Definition relativelaxcommutator_nat: UU := is_nat_trans (functor_composite F (rightwhiskering_functor Mon_V v0)) (functor_composite F (leftwhiskering_functor Mon_V v0)) γ. Definition relativelaxcommutator_tensor_body (w w' : W): UU := γ (w ⊗_{Mon_W} w') = pr1 (fmonoidal_preservestensorstrongly U w w') ⊗^{Mon_V}_{r} v0 · α_{Mon_V} _ _ _ · F w ⊗^{Mon_V}_{l} γ w' · αinv_{Mon_V} _ _ _ · γ w ⊗^{Mon_V}_{r} F w' · α_{Mon_V} _ _ _ · v0 ⊗^{Mon_V}_{l} fmonoidal_preservestensordata U w w'. Definition relativelaxcommutator_tensor: UU := ∏ (w w' : W), relativelaxcommutator_tensor_body w w'. Definition relativelaxcommutator_unit: UU := γ I_{Mon_W} = pr1 (fmonoidal_preservesunitstrongly U) ⊗^{Mon_V}_{r} v0 · lu_{Mon_V} v0 · ruinv_{Mon_V} v0 · v0 ⊗^{Mon_V}_{l} fmonoidal_preservesunit U. End γ_laws. Definition relativelaxcommutator: UU := ∑ γ : relativelaxcommutator_data, relativelaxcommutator_nat γ × relativelaxcommutator_tensor γ × relativelaxcommutator_unit γ. Definition relativelaxcommutator_lddata (γ : relativelaxcommutator): relativelaxcommutator_data := pr1 γ. Coercion relativelaxcommutator_lddata : relativelaxcommutator >-> relativelaxcommutator_data. Definition relativelaxcommutator_ldnat (γ : relativelaxcommutator): relativelaxcommutator_nat γ := pr12 γ. Definition relativelaxcommutator_ldtensor (γ : relativelaxcommutator): relativelaxcommutator_tensor γ := pr122 γ. Definition relativelaxcommutator_ldunit (γ : relativelaxcommutator): relativelaxcommutator_unit γ := pr222 γ. Section ActegoryMorphismFromRelativeLaxCommutator. Context (γ : relativelaxcommutator) {C : category} (ActV : actegory Mon_V C). Local Definition FF: C ⟶ C := leftwhiskering_functor ActV v0. Local Definition ActW: actegory Mon_W C := reindexed_actegory Mon_V ActV Mon_W U. Definition lineator_data_from_commutator: lineator_data Mon_W ActW ActW FF. Proof. intros w x. unfold FF. cbn. exact (aαinv^{ActV}_{F w, v0, x} · γ w ⊗^{ActV}_{r} x · aα^{ActV}_{v0, F w, x}). Defined. Lemma lineator_laxlaws_from_commutator: lineator_laxlaws Mon_W ActW ActW FF lineator_data_from_commutator. Proof. assert (γ_nat := relativelaxcommutator_ldnat γ). do 2 red in γ_nat. cbn in γ_nat. repeat split; red; intros; unfold lineator_data_from_commutator; try unfold reindexed_actor_data; try unfold reindexed_action_unitor_data; cbn; try unfold reindexed_actor_data; try unfold reindexed_action_unitor_data; cbn. - etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply actorinv_nat_leftwhisker. } etrans. 2: { repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, actegory_actornatleft. } repeat rewrite assoc'. apply maponpaths. repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (bifunctor_equalwhiskers ActV). - etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply actorinv_nat_rightwhisker. } etrans. 2: { repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, actegory_actornatleftright. } repeat rewrite assoc'. apply maponpaths. repeat rewrite assoc. apply cancel_postcomposition. etrans. { apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). } etrans. 2: { apply (functor_comp (rightwhiskering_functor ActV x)). } apply maponpaths. apply γ_nat. - etrans. { apply maponpaths. apply (functor_comp (leftwhiskering_functor ActV v0)). } cbn. etrans. { repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply actegory_actornatleftright. } etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). } cbn. etrans. { do 2 apply cancel_postcomposition. do 2 apply maponpaths. rewrite (relativelaxcommutator_ldtensor γ). repeat rewrite assoc'. do 6 apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v0)). } apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v0)). apply (pr2 (fmonoidal_preservestensorstrongly U v w)). } rewrite id_right. etrans. { do 2 apply cancel_postcomposition. etrans. { apply maponpaths. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, actorinv_nat_rightwhisker. } repeat rewrite assoc'. apply maponpaths. (* the extra effort for having an abstract strong monoidal functor has now been accomplished *) apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Mon_V ActV _ _ _)). etrans. { apply cancel_postcomposition. repeat rewrite assoc. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. etrans. { rewrite assoc'. apply maponpaths. rewrite assoc. apply actegory_pentagonidentity. } repeat rewrite assoc. apply cancel_postcomposition. rewrite <- actegory_pentagonidentity. etrans. { apply cancel_postcomposition. repeat rewrite assoc'. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. etrans. 2: { apply maponpaths. apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor ActV (F v))). } cbn. repeat rewrite assoc. do 3 apply cancel_postcomposition. etrans. 2: { apply (functor_comp (leftwhiskering_functor ActV (F v))). } apply pathsinv0, (functor_id_id _ _ (leftwhiskering_functor ActV (F v))). apply (pr1 (actegory_actorisolaw Mon_V ActV _ _ _)). } rewrite id_left. etrans. 2: { apply maponpaths. rewrite assoc'. apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor ActV (F v))). } cbn. etrans. 2: { repeat rewrite assoc. do 3 apply cancel_postcomposition. apply pathsinv0, actegory_actornatleftright. } etrans. { apply cancel_postcomposition. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. repeat rewrite assoc'. apply maponpaths. etrans. { apply cancel_postcomposition. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0, actegory_actornatright. } repeat rewrite assoc. apply cancel_postcomposition. (* only a variant of the pentagon law with some inverses is missing here *) apply (z_iso_inv_on_left _ _ _ _ (z_iso_from_actor_iso Mon_V ActV _ _ _)). cbn. rewrite assoc'. rewrite <- actegory_pentagonidentity. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. etrans. 2: { apply (functor_comp (rightwhiskering_functor ActV x)). } apply pathsinv0, (functor_id_id _ _ (rightwhiskering_functor ActV x)). apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)). } rewrite id_left. apply idpath. - etrans. { apply maponpaths. apply (functor_comp (leftwhiskering_functor ActV v0)). } cbn. etrans. { repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply actegory_actornatleftright. } etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). } cbn. etrans. { do 2 apply cancel_postcomposition. do 2 apply maponpaths. rewrite (relativelaxcommutator_ldunit γ). repeat rewrite assoc'. do 3 apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v0)). } apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v0)). apply (pr2 (fmonoidal_preservesunitstrongly U)). } rewrite id_right. etrans. { do 2 apply cancel_postcomposition. etrans. { apply maponpaths. apply (functor_comp (rightwhiskering_functor ActV x)). } cbn. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, actorinv_nat_rightwhisker. } repeat rewrite assoc'. apply maponpaths. (* the extra effort for having an abstract strong monoidal functor has now been accomplished *) etrans. { repeat rewrite assoc'. do 2 apply maponpaths. apply actegory_triangleidentity. } etrans. { apply maponpaths. apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). } cbn. rewrite assoc'. rewrite (pr2 (monoidal_rightunitorisolaw Mon_V v0)). rewrite id_right. rewrite <- actegory_triangleidentity'. rewrite assoc. rewrite (pr2 (actegory_actorisolaw Mon_V ActV _ _ _)). apply id_left. Qed. Definition reindexedstrength_from_commutator: reindexedstrength Mon_V Mon_W U ActV ActV FF := lineator_data_from_commutator,,lineator_laxlaws_from_commutator. End ActegoryMorphismFromRelativeLaxCommutator. End FixAnObject. Arguments reindexedstrength_from_commutator _ _ {_} _. Arguments relativelaxcommutator _ : clear implicits. Arguments relativelaxcommutator_data _ : clear implicits. Definition unit_relativelaxcommutator_data: relativelaxcommutator_data I_{Mon_V}. Proof. intro w. exact (ru^{Mon_V}_{F w} · luinv^{Mon_V}_{F w}). Defined. Lemma unit_relativelaxcommutator_nat: relativelaxcommutator_nat unit_relativelaxcommutator_data. Proof. intro; intros. unfold unit_relativelaxcommutator_data. cbn. etrans. { rewrite assoc. apply cancel_postcomposition. apply monoidal_rightunitornat. } repeat rewrite assoc'. apply maponpaths. apply pathsinv0, monoidal_leftunitorinvnat. Qed. Lemma unit_relativelaxcommutator_tensor: relativelaxcommutator_tensor unit_relativelaxcommutator_data. Proof. intro; intros. unfold relativelaxcommutator_tensor_body, unit_relativelaxcommutator_data. etrans. 2: { do 2 apply cancel_postcomposition. etrans. 2: { do 2 apply cancel_postcomposition. rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V _)). } apply maponpaths. apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V _)). } cbn. etrans. 2: { repeat rewrite assoc'. apply maponpaths. repeat rewrite assoc. do 6 apply cancel_postcomposition. apply pathsinv0, left_whisker_with_runitor. } etrans. 2: { repeat rewrite assoc. do 4 apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, monoidal_triangle_identity_inv. } etrans. 2: { repeat rewrite assoc'. do 2 apply maponpaths. repeat rewrite assoc. do 3 apply cancel_postcomposition. etrans. 2: { apply (functor_comp (rightwhiskering_functor Mon_V _)). } apply maponpaths. apply pathsinv0, monoidal_rightunitorisolaw. } rewrite functor_id, id_left. etrans. 2: { do 2 apply maponpaths. apply cancel_postcomposition. rewrite <- monoidal_triangle_identity'_inv. rewrite assoc'. apply maponpaths. apply pathsinv0, monoidal_associatorisolaw. } rewrite id_right. etrans. 2: { repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, monoidal_leftunitorinvnat. } do 2 rewrite assoc. apply cancel_postcomposition. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, monoidal_rightunitornat. } etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, fmonoidal_preservestensorstrongly. } apply pathsinv0, id_right. Qed. Lemma unit_relativelaxcommutator_unit: relativelaxcommutator_unit unit_relativelaxcommutator_data. Proof. unfold relativelaxcommutator_unit, unit_relativelaxcommutator_data. etrans. 2: { do 2 apply cancel_postcomposition. rewrite unitors_coincide_on_unit. apply pathsinv0, monoidal_rightunitornat. } repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. rewrite <- unitorsinv_coincide_on_unit. apply pathsinv0, monoidal_leftunitorinvnat. } rewrite assoc. etrans. 2: {apply cancel_postcomposition. apply pathsinv0, (pr22 (fmonoidal_preservesunitstrongly U)). } apply pathsinv0, id_left. Qed. Definition unit_relativelaxcommutator: relativelaxcommutator I_{Mon_V}. Proof. use tpair. - exact unit_relativelaxcommutator_data. - split3. + exact unit_relativelaxcommutator_nat. + exact unit_relativelaxcommutator_tensor. + exact unit_relativelaxcommutator_unit. Defined. Section CompositionOfRelativeLaxCommutators. Context (v1 v2 : V) (γ1 : relativelaxcommutator v1) (γ2 : relativelaxcommutator v2). Definition composedrelativelaxcommutator_data: relativelaxcommutator_data (v1 ⊗_{Mon_V} v2). Proof. red; intros. exact (αinv_{Mon_V} _ _ _ · γ1 w ⊗^{Mon_V}_{r} v2 · α_{Mon_V} _ _ _ · v1 ⊗^{Mon_V}_{l} γ2 w · αinv_{Mon_V} _ _ _). Defined. Lemma composedrelativelaxcommutator_nat: relativelaxcommutator_nat composedrelativelaxcommutator_data. Proof. do 2 red; intros; unfold composedrelativelaxcommutator_data; cbn. assert (γ1_nat := relativelaxcommutator_ldnat γ1). assert (γ2_nat := relativelaxcommutator_ldnat γ2). do 2 red in γ1_nat, γ2_nat; cbn in γ1_nat, γ2_nat. etrans. { repeat rewrite assoc. do 4 apply cancel_postcomposition. apply monoidal_associatorinvnatright. } repeat rewrite assoc'. apply maponpaths. etrans. { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). } cbn. rewrite γ1_nat. etrans. { rewrite assoc. do 2 apply cancel_postcomposition. apply (functor_comp (rightwhiskering_functor Mon_V v2)). } cbn. repeat rewrite assoc'. apply maponpaths. etrans. 2: { do 2 apply maponpaths. apply monoidal_associatorinvnatleft. } repeat rewrite assoc. apply cancel_postcomposition. etrans. 2: { rewrite assoc'. apply maponpaths. apply (functor_comp (leftwhiskering_functor Mon_V v1)). } cbn. rewrite <- γ2_nat. etrans. 2: { apply maponpaths. apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). } cbn. repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, monoidal_associatornatleftright. Qed. Lemma composedrelativelaxcommutator_tensor: relativelaxcommutator_tensor composedrelativelaxcommutator_data. Proof. do 2 red; intros; unfold composedrelativelaxcommutator_data; cbn. rewrite (relativelaxcommutator_ldtensor γ1). rewrite (relativelaxcommutator_ldtensor γ2). etrans. { do 3 apply cancel_postcomposition. apply maponpaths. etrans. { apply (functor_comp (rightwhiskering_functor Mon_V v2)). } do 5 rewrite functor_comp. cbn. apply idpath. } etrans. { apply cancel_postcomposition. repeat rewrite assoc'. do 9 apply maponpaths. etrans. { apply (functor_comp (leftwhiskering_functor Mon_V v1)). } do 5 rewrite functor_comp. cbn. apply idpath. } etrans. { repeat rewrite assoc. do 15 apply cancel_postcomposition. apply pathsinv0, monoidal_associatorinvnatright. } repeat rewrite assoc'. apply maponpaths. etrans. { do 14 apply maponpaths. apply monoidal_associatorinvnatleft. } repeat rewrite assoc. apply cancel_postcomposition. etrans. 2: { do 3 apply cancel_postcomposition. apply maponpaths. etrans. 2: { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V (F w))). } do 3 rewrite functor_comp. cbn. apply idpath. } etrans. 2: { apply cancel_postcomposition. repeat rewrite assoc'. do 7 apply maponpaths. etrans. 2: { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V (F w'))). } do 3 rewrite functor_comp. cbn. apply idpath. } etrans. { do 6 apply cancel_postcomposition. repeat rewrite assoc'. do 6 apply maponpaths. etrans. { apply maponpaths. apply monoidal_associatornatleftright. } rewrite assoc. apply cancel_postcomposition. etrans. { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). } apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). } apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v1)). apply (pr2 (fmonoidal_preservestensorstrongly U w w')). } rewrite functor_id. rewrite id_left. etrans. { repeat rewrite assoc'. apply idpath. } apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)). cbn. etrans. 2: { repeat rewrite assoc. do 11 apply cancel_postcomposition. etrans. 2: { apply cancel_postcomposition. apply monoidal_pentagonidentity. } repeat rewrite assoc'. do 2 apply maponpaths. etrans. 2: { apply (functor_comp (leftwhiskering_functor Mon_V (F w))). } apply pathsinv0, (functor_id_id _ _ (leftwhiskering_functor Mon_V (F w))). apply (pr1 (monoidal_associatorisolaw Mon_V _ _ _)). } rewrite id_right. repeat rewrite assoc'. apply maponpaths. etrans. 2: { repeat rewrite assoc. do 10 apply cancel_postcomposition. apply pathsinv0, monoidal_associatornatleftright. } repeat rewrite assoc'. apply maponpaths. apply (z_iso_inv_on_right _ _ _ (functor_on_z_iso (rightwhiskering_functor Mon_V v2) (z_iso_from_associator_iso Mon_V _ _ _))). cbn. etrans. 2: { repeat rewrite assoc. do 9 apply cancel_postcomposition. apply pathsinv0, monoidal_pentagonidentity. } etrans. { repeat rewrite assoc. apply idpath. } apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)). cbn. etrans. 2: { repeat rewrite assoc'. do 9 apply maponpaths. etrans. 2: { apply maponpaths. apply monoidal_pentagonidentity. } repeat rewrite assoc. do 2 apply cancel_postcomposition. etrans. 2: { apply (functor_comp (rightwhiskering_functor Mon_V _)). } apply pathsinv0, (functor_id_id _ _ (rightwhiskering_functor Mon_V (F w'))). apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)). } rewrite id_left. repeat rewrite assoc. apply cancel_postcomposition. etrans. { do 3 apply cancel_postcomposition. repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply monoidal_pentagonidentity. } etrans. { repeat rewrite assoc. do 4 apply cancel_postcomposition. apply pathsinv0, monoidal_associatornatright. } repeat rewrite assoc'. apply maponpaths. etrans. { apply maponpaths. repeat rewrite assoc. do 2 apply cancel_postcomposition. apply monoidal_associatornatleft. } etrans. { repeat rewrite assoc. do 3 apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). } unfold functoronmorphisms2. etrans. 2: { repeat rewrite assoc. do 7 apply cancel_postcomposition. apply pathsinv0, monoidal_associatornatleft. } repeat rewrite assoc'. apply maponpaths. etrans. 2: { repeat rewrite assoc. do 4 apply cancel_postcomposition. etrans. 2: { repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply pathsinv0, monoidal_pentagon_identity_inv. } rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (pr1 (monoidal_associatorisolaw Mon_V _ _ _)). } rewrite id_left. etrans. 2: { repeat rewrite assoc'. do 3 apply maponpaths. apply monoidal_associatornatleftright. } repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. apply pathsinv0, (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)). cbn. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, monoidal_associatornatright. } repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Mon_V v1) (z_iso_from_associator_iso Mon_V _ _ _))). cbn. apply pathsinv0, monoidal_pentagonidentity. Qed. Lemma composedrelativelaxcommutator_unit: relativelaxcommutator_unit composedrelativelaxcommutator_data. Proof. red; unfold composedrelativelaxcommutator_data; cbn. rewrite (relativelaxcommutator_ldunit γ1). rewrite (relativelaxcommutator_ldunit γ2). etrans. { do 3 apply cancel_postcomposition. apply maponpaths. etrans. { apply (functor_comp (rightwhiskering_functor Mon_V v2)). } do 2 rewrite functor_comp. cbn. apply idpath. } etrans. { apply cancel_postcomposition. repeat rewrite assoc'. do 6 apply maponpaths. etrans. { apply (functor_comp (leftwhiskering_functor Mon_V v1)). } do 2 rewrite functor_comp. cbn. apply idpath. } etrans. { repeat rewrite assoc. do 9 apply cancel_postcomposition. apply pathsinv0, monoidal_associatorinvnatright. } repeat rewrite assoc'. apply maponpaths. etrans. { repeat rewrite assoc. do 8 apply cancel_postcomposition. rewrite <- monoidal_triangleidentity'. rewrite assoc. apply cancel_postcomposition. apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)). } rewrite id_left. repeat rewrite assoc'. apply maponpaths. etrans. { do 6 apply maponpaths. apply monoidal_associatorinvnatleft. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { do 4 apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply pathsinv0, monoidal_associatornatleftright. } etrans. { do 3 apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). } apply maponpaths. etrans. { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). } apply (functor_id_id _ _ (rightwhiskering_functor Mon_V v2)). apply (pr2 (fmonoidal_preservesunitstrongly U)). } rewrite functor_id. rewrite id_right. etrans. { repeat rewrite assoc'. do 3 apply maponpaths. apply monoidal_triangle_identity''_inv. } etrans. { apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply monoidal_triangleidentity. } rewrite assoc. etrans. { apply cancel_postcomposition. etrans. { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). } apply (functor_id_id _ _ (rightwhiskering_functor Mon_V v2)). apply (monoidal_rightunitorisolaw Mon_V). } apply id_left. Qed. Definition composedrelativelaxcommutator: relativelaxcommutator (v1 ⊗_{Mon_V} v2). Proof. exists composedrelativelaxcommutator_data. exact (composedrelativelaxcommutator_nat,, composedrelativelaxcommutator_tensor,, composedrelativelaxcommutator_unit). Defined. End CompositionOfRelativeLaxCommutators. End RelativeLaxCommutator. End ReindexedLineatorAndRelativeLaxCommutator. Arguments relativelaxcommutator {_} _ {_} _ {_} _ _. Arguments relativelaxcommutator_data {_} _ {_ _} _. Section PointwiseOperationsOnLinearFunctors. Context {V : category} (Mon_V : monoidal V) {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D). Section PointwiseBinaryOperationsOnLinearFunctors. Context {F1 F2 : functor C D} (ll1 : lineator_lax Mon_V ActC ActD F1) (ll2 : lineator_lax Mon_V ActC ActD F2). Section PointwiseBinaryProductOfLinearFunctors. Context (BPD : BinProducts D). Let FF : functor C D := BinProduct_of_functors _ _ BPD F1 F2. Let FF' : functor C D := BinProduct_of_functors_alt BPD F1 F2. Definition lax_lineator_binprod_aux: lineator_lax Mon_V ActC ActD FF'. Proof. use comp_lineator_lax. - apply actegory_binprod; assumption. - apply actegory_binprod_delta_lineator. - use comp_lineator_lax. + apply actegory_binprod; assumption. + apply actegory_pair_functor_lineator; assumption. + apply binprod_functor_lax_lineator. Defined. Definition lax_lineator_binprod_indirect: lineator_lax Mon_V ActC ActD FF. Proof. unfold FF. rewrite <- BinProduct_of_functors_alt_eq_BinProduct_of_functors. apply lax_lineator_binprod_aux. Defined. Lemma lax_lineator_binprod_indirect_data_ok (v : V) (c : C): lax_lineator_binprod_indirect v c = binprod_collector_data Mon_V BPD ActD v (F1 c) (F2 c) · BinProductOfArrows _ (BPD _ _) (BPD _ _) (ll1 v c) (ll2 v c). Proof. unfold lax_lineator_binprod_indirect. Abort. (* how could one use the equality proof? *) (** now an alternative concrete construction *) Definition lineator_data_binprod: lineator_data Mon_V ActC ActD FF. Proof. intros v c. exact (binprod_collector_data Mon_V BPD ActD v (F1 c) (F2 c) · BinProductOfArrows _ (BPD _ _) (BPD _ _) (ll1 v c) (ll2 v c)). Defined. Let cll : lineator_lax Mon_V (actegory_binprod Mon_V ActD ActD) ActD (binproduct_functor BPD) := binprod_functor_lax_lineator Mon_V BPD ActD. Lemma lineator_laxlaws_binprod: lineator_laxlaws Mon_V ActC ActD FF lineator_data_binprod. Proof. repeat split; red; intros; unfold lineator_data_binprod. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatleft _ _ _ _ cll v (_,,_) (_,,_) (_,,_)). } repeat rewrite assoc'. apply maponpaths. etrans. { apply BinProductOfArrows_comp. } etrans. 2: { apply pathsinv0, BinProductOfArrows_comp. } apply maponpaths_12; apply lineator_linnatleft. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatright _ _ _ _ cll v1 v2 (_,,_) f). } repeat rewrite assoc'. apply maponpaths. etrans. { apply BinProductOfArrows_comp. } etrans. 2: { apply pathsinv0, BinProductOfArrows_comp. } apply maponpaths_12; apply lineator_linnatright. - etrans. { rewrite assoc'. apply maponpaths. etrans. { apply BinProductOfArrows_comp. } apply maponpaths_12; apply lineator_preservesactor. } etrans. { apply maponpaths. repeat rewrite assoc'. apply pathsinv0, BinProductOfArrows_comp. } etrans. { rewrite assoc. apply cancel_postcomposition. apply (lineator_preservesactor _ _ _ _ cll v w (_,,_)). } etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). } repeat rewrite assoc'. do 2 apply maponpaths. repeat rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (lineator_linnatleft _ _ _ _ cll v (_,,_) (_,,_) (_,,_)). } rewrite assoc'. apply maponpaths. etrans. 2: { apply pathsinv0, BinProductOfArrows_comp. } apply idpath. - etrans. 2: { apply (lineator_preservesunitor _ _ _ _ cll (_,,_)). } rewrite assoc'. apply maponpaths. etrans. { apply BinProductOfArrows_comp. } cbn. apply maponpaths_12; apply lineator_preservesunitor. Qed. Definition lax_lineator_binprod: lineator_lax Mon_V ActC ActD FF := lineator_data_binprod,,lineator_laxlaws_binprod. End PointwiseBinaryProductOfLinearFunctors. Section PointwiseBinaryCoproductOfLinearFunctors. Context (BCD : BinCoproducts D) (δ : actegory_bincoprod_distributor Mon_V BCD ActD). Let FF : functor C D := BinCoproduct_of_functors _ _ BCD F1 F2. Let FF' : functor C D := BinCoproduct_of_functors_alt2 BCD F1 F2. Definition lax_lineator_bincoprod_aux : lineator_lax Mon_V ActC ActD FF'. Proof. use comp_lineator_lax. - apply actegory_binprod; assumption. - apply actegory_binprod_delta_lineator. - use comp_lineator_lax. + apply actegory_binprod; assumption. + apply actegory_pair_functor_lineator; assumption. + apply (bincoprod_functor_lineator Mon_V BCD ActD δ). Defined. Definition lax_lineator_bincoprod_indirect : lineator_lax Mon_V ActC ActD FF. Proof. unfold FF. rewrite <- BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors. apply lax_lineator_bincoprod_aux. Defined. Lemma lax_lineator_bincoprod_data_ok (v : V) (c : C) : lax_lineator_bincoprod_indirect v c = δ v (F1 c) (F2 c) · (BinCoproductOfArrows _ (BCD _ _) (BCD _ _) (ll1 v c) (ll2 v c)). Proof. unfold lax_lineator_bincoprod_indirect. Abort. (* how could one use the equality proof? *) (** now an alternative concrete construction *) Definition lineator_data_bincoprod: lineator_data Mon_V ActC ActD FF. Proof. intros v c. exact (δ v (F1 c) (F2 c) · (BinCoproductOfArrows _ (BCD _ _) (BCD _ _) (ll1 v c) (ll2 v c))). Defined. Let δll : lineator Mon_V (actegory_binprod Mon_V ActD ActD) ActD (bincoproduct_functor BCD) := bincoprod_functor_lineator Mon_V BCD ActD δ. Lemma lineator_laxlaws_bincoprod : lineator_laxlaws Mon_V ActC ActD FF lineator_data_bincoprod. Proof. repeat split; red; intros; unfold lineator_data_bincoprod. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatleft _ _ _ _ δll v (_,,_) (_,,_) (_,,_)). } repeat rewrite assoc'. apply maponpaths. etrans. { apply BinCoproductOfArrows_comp. } etrans. 2: { apply pathsinv0, BinCoproductOfArrows_comp. } apply maponpaths_12; apply lineator_linnatleft. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatright _ _ _ _ δll v1 v2 (_,,_) f). } repeat rewrite assoc'. apply maponpaths. etrans. { apply BinCoproductOfArrows_comp. } etrans. 2: { apply pathsinv0, BinCoproductOfArrows_comp. } apply maponpaths_12; apply lineator_linnatright. - etrans. { rewrite assoc'. apply maponpaths. etrans. { apply BinCoproductOfArrows_comp. } apply maponpaths_12; apply lineator_preservesactor. } etrans. { apply maponpaths. repeat rewrite assoc'. apply pathsinv0, BinCoproductOfArrows_comp. } etrans. { rewrite assoc. apply cancel_postcomposition. apply (lineator_preservesactor _ _ _ _ δll v w (_,,_)). } etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). } repeat rewrite assoc'. do 2 apply maponpaths. repeat rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (lineator_linnatleft _ _ _ _ δll v (_,,_) (_,,_) (_,,_)). } rewrite assoc'. apply maponpaths. etrans. 2: { apply pathsinv0, BinCoproductOfArrows_comp. } apply idpath. - etrans. 2: { apply (lineator_preservesunitor _ _ _ _ δll (_,,_)). } rewrite assoc'. apply maponpaths. etrans. { apply BinCoproductOfArrows_comp. } cbn. apply maponpaths_12; apply lineator_preservesunitor. Qed. Definition lax_lineator_bincoprod: lineator_lax Mon_V ActC ActD FF := lineator_data_bincoprod,,lineator_laxlaws_bincoprod. End PointwiseBinaryCoproductOfLinearFunctors. End PointwiseBinaryOperationsOnLinearFunctors. Section PointwiseCoproductOfLinearFunctors. Context {I : UU} {F : I -> functor C D} (ll : ∏ (i: I), lineator_lax Mon_V ActC ActD (F i)) (CD : Coproducts I D) (δ : actegory_coprod_distributor Mon_V CD ActD). Let FF : functor C D := coproduct_of_functors _ _ _ CD F. Let FF' : functor C D := coproduct_of_functors_alt_old _ CD F. Definition lax_lineator_coprod_aux : lineator_lax Mon_V ActC ActD FF'. Proof. use comp_lineator_lax. - apply actegory_power; assumption. - apply actegory_prod_delta_lineator. - use comp_lineator_lax. + apply actegory_power; assumption. + apply actegory_family_functor_lineator; assumption. + apply (coprod_functor_lineator Mon_V CD ActD δ). Defined. Definition lax_lineator_coprod_indirect : lineator_lax Mon_V ActC ActD FF. Proof. unfold FF. rewrite <- coproduct_of_functors_alt_old_eq_coproduct_of_functors. apply lax_lineator_coprod_aux. Defined. Lemma lax_lineator_coprod_data_ok (v : V) (c : C) : lax_lineator_coprod_indirect v c = δ v (fun i => F i c) · (CoproductOfArrows I _ (CD _) (CD _) (fun i => ll i v c)). Proof. unfold lax_lineator_coprod_indirect. Abort. (* how could one use the equality proof? *) (** now an alternative concrete construction *) Definition lineator_data_coprod: lineator_data Mon_V ActC ActD FF. Proof. intros v c. exact (δ v (fun i => F i c) · (CoproductOfArrows I _ (CD _) (CD _) (fun i => ll i v c))). Defined. Let δll : lineator Mon_V (actegory_power Mon_V I ActD) ActD (coproduct_functor I CD) := coprod_functor_lineator Mon_V CD ActD δ. Lemma lineator_laxlaws_coprod : lineator_laxlaws Mon_V ActC ActD FF lineator_data_coprod. Proof. repeat split; red; intros; unfold lineator_data_coprod. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatleft _ _ _ _ δll v). } repeat rewrite assoc'. apply maponpaths. etrans. { apply CoproductOfArrows_comp. } etrans. 2: { apply pathsinv0, CoproductOfArrows_comp. } apply maponpaths, funextsec; intro i; apply lineator_linnatleft. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatright _ _ _ _ δll v1 v2 _ f). } repeat rewrite assoc'. apply maponpaths. etrans. { apply CoproductOfArrows_comp. } etrans. 2: { apply pathsinv0, CoproductOfArrows_comp. } apply maponpaths, funextsec; intro i; apply lineator_linnatright. - etrans. { rewrite assoc'. apply maponpaths. etrans. { apply CoproductOfArrows_comp. } cbn. apply maponpaths, funextsec; intro i; apply lineator_preservesactor. } etrans. { apply maponpaths. assert (aux : (fun i => aα^{ ActD }_{ v, w, F i x} · v ⊗^{ ActD}_{l} ll i w x · ll i v (w ⊗_{ ActC} x)) = (fun i => aα^{ ActD }_{ v, w, F i x} · (v ⊗^{ ActD}_{l} ll i w x · ll i v (w ⊗_{ ActC} x)))). { apply funextsec; intro i; apply assoc'. } rewrite aux. apply pathsinv0, CoproductOfArrows_comp. } etrans. { rewrite assoc. apply cancel_postcomposition. apply (lineator_preservesactor _ _ _ _ δll v w). } etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). } repeat rewrite assoc'. do 2 apply maponpaths. repeat rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (lineator_linnatleft _ _ _ _ δll v). } rewrite assoc'. apply maponpaths. etrans. 2: { apply pathsinv0, CoproductOfArrows_comp. } apply idpath. - etrans. 2: { apply (lineator_preservesunitor _ _ _ _ δll). } rewrite assoc'. apply maponpaths. etrans. { apply CoproductOfArrows_comp. } cbn. apply maponpaths, funextsec; intro i; apply lineator_preservesunitor. Qed. Definition lax_lineator_coprod: lineator_lax Mon_V ActC ActD FF := lineator_data_coprod,,lineator_laxlaws_coprod. End PointwiseCoproductOfLinearFunctors. End PointwiseOperationsOnLinearFunctors. UniMath-20231010/UniMath/CategoryTheory/Actegories/CoproductsInActegories.v000066400000000000000000000415701451125700300265310ustar00rootroot00000000000000(** studies coproducts in the categories on which is being acted in actegories author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ProductActegory. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. (* Require Import UniMath.CategoryTheory.coslicecat. *) Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. (* Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. *) Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section FixAMonoidalCategory. Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *) Section BinaryCoproduct. Context {C : category} (BCP : BinCoproducts C) (Act : actegory Mon_V C). Definition actegory_bincoprod_antidistributor : ∏ (a : V) (c c' : C), BCP (leftwhiskering_functor Act a c) (leftwhiskering_functor Act a c') --> leftwhiskering_functor Act a (BCP c c') := bifunctor_bincoprod_antidistributor BCP BCP Act. Lemma actegory_bincoprod_antidistributor_nat_left (v : V) (cd1 cd2 : category_binproduct C C) (g : cd1 --> cd2) : actegory_bincoprod_antidistributor v (pr1 cd1) (pr2 cd1) · v ⊗^{Act}_{l} #(bincoproduct_functor BCP) g = #(bincoproduct_functor BCP) (v ⊗^{actegory_binprod Mon_V Act Act}_{l} g) · actegory_bincoprod_antidistributor v (pr1 cd2) (pr2 cd2). Proof. apply bincoprod_antidistributor_nat_left. Qed. Lemma actegory_bincoprod_antidistributor_nat_right (v1 v2 : V) (cd : category_binproduct C C) (f : v1 --> v2) : actegory_bincoprod_antidistributor v1 (pr1 cd) (pr2 cd) · f ⊗^{ Act}_{r} bincoproduct_functor BCP cd = #(bincoproduct_functor BCP) (f ⊗^{ actegory_binprod Mon_V Act Act}_{r} cd) · actegory_bincoprod_antidistributor v2 (pr1 cd) (pr2 cd). Proof. apply bincoprod_antidistributor_nat_right. Qed. Lemma bincoprod_antidistributor_pentagon_identity (v w : V) (cd : category_binproduct C C) : # (bincoproduct_functor BCP) aα^{actegory_binprod Mon_V Act Act}_{v, w, cd} · actegory_bincoprod_antidistributor v (w ⊗_{Act} pr1 cd) (w ⊗_{ Act} pr2 cd) · v ⊗^{Act}_{l} actegory_bincoprod_antidistributor w (pr1 cd) (pr2 cd) = actegory_bincoprod_antidistributor (v ⊗_{Mon_V} w) (pr1 cd) (pr2 cd) · aα^{Act}_{v, w, bincoproduct_functor BCP cd}. Proof. etrans. { rewrite assoc'. apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, postcompWithBinCoproductArrow. } apply maponpaths_12. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply BinCoproductIn1Commutes. } etrans. 2: { apply actegory_actornatleft. } rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. apply BinCoproductIn1Commutes. - etrans. { repeat rewrite assoc. apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply BinCoproductIn2Commutes. } etrans. 2: { apply actegory_actornatleft. } rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. apply BinCoproductIn2Commutes. Qed. Lemma bincoprod_antidistributor_triangle_identity (cd : category_binproduct C C) : #(bincoproduct_functor BCP) au^{actegory_binprod Mon_V Act Act}_{cd} = actegory_bincoprod_antidistributor I_{Mon_V} (pr1 cd) (pr2 cd) · au^{Act}_{bincoproduct_functor BCP cd}. Proof. etrans. 2: { apply pathsinv0, postcompWithBinCoproductArrow. } cbn. unfold BinCoproductOfArrows. apply maponpaths_12; apply pathsinv0, actegory_unitornat. Qed. Lemma actegory_bincoprod_antidistributor_commutes_with_associativity_of_coproduct (v : V) (c d e : C) : #(bincoproduct_functor BCP) (catbinprodmor (actegory_bincoprod_antidistributor v c d) (identity (v ⊗_{Act} e))) · actegory_bincoprod_antidistributor v (BCP c d) e · v ⊗^{Act}_{l} bincoprod_associator_data BCP c d e = bincoprod_associator_data BCP (v ⊗_{Act} c) (v ⊗_{Act} d) (v ⊗_{Act} e) · #(bincoproduct_functor BCP) (catbinprodmor (identity (v ⊗_{Act} c)) (actegory_bincoprod_antidistributor v d e)) · actegory_bincoprod_antidistributor v c (BCP d e). Proof. apply bincoprod_antidistributor_commutes_with_associativity_of_coproduct. Qed. Definition actegory_bincoprod_distributor_data : UU := bifunctor_bincoprod_distributor_data BCP BCP Act. Identity Coercion actegory_bincoprod_distributor_data_coercion: actegory_bincoprod_distributor_data >-> bifunctor_bincoprod_distributor_data. Definition actegory_bincoprod_distributor_iso_law (δ : actegory_bincoprod_distributor_data) : UU := bifunctor_bincoprod_distributor_iso_law BCP BCP Act δ. Definition actegory_bincoprod_distributor : UU := bifunctor_bincoprod_distributor BCP BCP Act. Definition actegory_bincoprod_distributor_to_data (δ : actegory_bincoprod_distributor) : actegory_bincoprod_distributor_data := pr1 δ. Coercion actegory_bincoprod_distributor_to_data : actegory_bincoprod_distributor >-> actegory_bincoprod_distributor_data. Definition bincoprod_functor_lineator_data (δ : actegory_bincoprod_distributor) : lineator_data Mon_V (actegory_binprod Mon_V Act Act) Act (bincoproduct_functor BCP). Proof. intros v cd. exact (δ v (pr1 cd) (pr2 cd)). Defined. Definition bincoprod_functor_lineator_strongly (δ : actegory_bincoprod_distributor) : lineator_strongly _ _ _ _ (bincoprod_functor_lineator_data δ). Proof. intros v cd. exists (actegory_bincoprod_antidistributor v (pr1 cd) (pr2 cd)). apply (pr2 δ v). Defined. Lemma bincoprod_functor_lineator_laxlaws (δ : actegory_bincoprod_distributor) : lineator_laxlaws _ _ _ _ (bincoprod_functor_lineator_data δ). Proof. red; repeat split. - red. intros v cd1 cd2 g. apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ v _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ v _)). apply (bincoprod_antidistributor_nat_left _ _ Act). - red. intros v1 v2 cd f. apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)). apply (bincoprod_antidistributor_nat_right _ _ Act). - red. intros v w cd. apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)). rewrite assoc. apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Act v) (_,,bincoprod_functor_lineator_strongly δ _ _))). apply pathsinv0, bincoprod_antidistributor_pentagon_identity. - red. intro cd. apply pathsinv0, (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ _ _)). apply pathsinv0, bincoprod_antidistributor_triangle_identity. Qed. Definition bincoprod_functor_lineator (δ : actegory_bincoprod_distributor) : lineator Mon_V (actegory_binprod Mon_V Act Act) Act (bincoproduct_functor BCP). Proof. use tpair. - exists (bincoprod_functor_lineator_data δ). exact (bincoprod_functor_lineator_laxlaws δ). - apply bincoprod_functor_lineator_strongly. Defined. Lemma bincoprod_distributor_commutes_with_associativity_of_coproduct (δ : actegory_bincoprod_distributor) (v : V) (c d e : C) : v ⊗^{Act}_{l} bincoprod_associator_data BCP c d e · δ v c (BCP d e) · #(bincoproduct_functor BCP) (catbinprodmor (identity (v ⊗_{Act} c)) (δ v d e)) = δ v (BCP c d) e · #(bincoproduct_functor BCP) (catbinprodmor (δ v c d) (identity (v ⊗_{Act} e))) · bincoprod_associator_data BCP (v ⊗_{Act} c) (v ⊗_{Act} d) (v ⊗_{Act} e). Proof. repeat rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly δ v (((BCP c d): C),, e))). repeat rewrite assoc. apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (functor_fix_fst_arg _ _ _ (bincoproduct_functor BCP) (v ⊗_{ Act} c)) (_,,bincoprod_functor_lineator_strongly δ v (d,,e)))). apply (z_iso_inv_to_right _ _ _ _ (_,,bincoprod_functor_lineator_strongly δ v (c,,((BCP d e): C)))). repeat rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (functor_on_z_iso (functor_fix_snd_arg _ _ _ (bincoproduct_functor BCP) (v ⊗_{ Act} e)) (_,,bincoprod_functor_lineator_strongly δ v (c,,d)))). repeat rewrite assoc. apply actegory_bincoprod_antidistributor_commutes_with_associativity_of_coproduct. Qed. End BinaryCoproduct. Section Coproduct. Context {I : UU} {C : category} (CP : Coproducts I C) (Act : actegory Mon_V C). Definition actegory_coprod_antidistributor := bifunctor_coprod_antidistributor CP CP Act. Lemma actegory_coprod_antidistributor_nat_left (v : V) (cs1 cs2 : power_category I C) (g : cs1 --> cs2) : actegory_coprod_antidistributor v cs1 · v ⊗^{Act}_{l} #(coproduct_functor I CP) g = #(coproduct_functor I CP) (v ⊗^{actegory_power Mon_V I Act}_{l} g) · actegory_coprod_antidistributor v cs2. Proof. apply coprod_antidistributor_nat_left. Qed. Lemma actegory_coprod_antidistributor_nat_right (v1 v2 : V) (cs : power_category I C) (f : v1 --> v2) : actegory_coprod_antidistributor v1 cs · f ⊗^{Act}_{r} coproduct_functor I CP cs = #(coproduct_functor I CP) (f ⊗^{actegory_power Mon_V I Act}_{r} cs) · actegory_coprod_antidistributor v2 cs. Proof. apply coprod_antidistributor_nat_right. Qed. Lemma coprod_antidistributor_pentagon_identity (v w : V) (cs : power_category I C) : # (coproduct_functor I CP) aα^{actegory_power Mon_V I Act}_{v, w, cs} · actegory_coprod_antidistributor v (fun i => w ⊗_{Act} (cs i)) · v ⊗^{Act}_{l} actegory_coprod_antidistributor w cs = actegory_coprod_antidistributor (v ⊗_{Mon_V} w) cs · aα^{Act}_{v, w, coproduct_functor I CP cs}. Proof. etrans. { rewrite assoc'. apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, postcompWithCoproductArrow. } apply maponpaths; apply funextsec; intro i. etrans. { repeat rewrite assoc. apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply CoproductInCommutes. } etrans. 2: { apply actegory_actornatleft. } rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. apply CoproductInCommutes. Qed. Lemma coprod_antidistributor_triangle_identity (cs : power_category I C) : #(coproduct_functor I CP) au^{actegory_power Mon_V I Act}_{cs} = actegory_coprod_antidistributor I_{Mon_V} cs · au^{Act}_{coproduct_functor I CP cs}. Proof. etrans. 2: { apply pathsinv0, postcompWithCoproductArrow. } cbn. unfold CoproductOfArrows. apply maponpaths, funextsec; intro i; apply pathsinv0, actegory_unitornat. Qed. Definition actegory_coprod_distributor_data : UU := bifunctor_coprod_distributor_data CP CP Act. Identity Coercion actegory_coprod_distributor_data_coercion: actegory_coprod_distributor_data >-> bifunctor_coprod_distributor_data. Definition actegory_coprod_distributor_iso_law (δ : actegory_coprod_distributor_data) : UU := bifunctor_coprod_distributor_iso_law CP CP Act δ. Definition actegory_coprod_distributor : UU := bifunctor_coprod_distributor CP CP Act. Definition actegory_coprod_distributor_to_data (δ : actegory_coprod_distributor) : actegory_coprod_distributor_data := pr1 δ. Coercion actegory_coprod_distributor_to_data : actegory_coprod_distributor >-> actegory_coprod_distributor_data. Definition coprod_functor_lineator_data (δ : actegory_coprod_distributor_data) : lineator_data Mon_V (actegory_power Mon_V I Act) Act (coproduct_functor I CP). Proof. intros v cs. exact (δ v cs). Defined. Definition coprod_functor_lineator_strongly (δ : actegory_coprod_distributor) : lineator_strongly _ _ _ _ (coprod_functor_lineator_data δ). Proof. intros v cs. exists (actegory_coprod_antidistributor v cs). apply (pr2 δ). Defined. Lemma coprod_functor_lineator_laxlaws (δ : actegory_coprod_distributor) : lineator_laxlaws _ _ _ _ (coprod_functor_lineator_data δ). Proof. red; repeat split. - red. intros v cs1 cs2 g. apply (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ v _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ v _)). apply actegory_coprod_antidistributor_nat_left. - red. intros v1 v2 cs f. apply (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)). apply actegory_coprod_antidistributor_nat_right. - red. intros v w cs. apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)). rewrite assoc'. apply (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)). rewrite assoc. apply (z_iso_inv_to_right _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Act v) (_,,coprod_functor_lineator_strongly δ _ _))). apply pathsinv0, coprod_antidistributor_pentagon_identity. - red. intro cs. apply pathsinv0, (z_iso_inv_to_left _ _ _ (_,,coprod_functor_lineator_strongly δ _ _)). apply pathsinv0, coprod_antidistributor_triangle_identity. Qed. Definition coprod_functor_lineator (δ : actegory_coprod_distributor) : lineator Mon_V (actegory_power Mon_V I Act) Act (coproduct_functor I CP). Proof. use tpair. - exists (coprod_functor_lineator_data δ). exact (coprod_functor_lineator_laxlaws δ). - apply coprod_functor_lineator_strongly. Defined. End Coproduct. End FixAMonoidalCategory. Section TwoMonoidalCategories. Context {V : category} (Mon_V : monoidal V) {C : category} (Act : actegory Mon_V C) {W : category} (Mon_W : monoidal W) {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F). Let ActW : actegory Mon_W C := reindexed_actegory Mon_V Act Mon_W U. Section BinaryCase. Context (BCP : BinCoproducts C) (δ : actegory_bincoprod_distributor Mon_V BCP Act). Definition reindexed_bincoprod_distributor_data : actegory_bincoprod_distributor_data Mon_W BCP ActW. Proof. intros w c c'. apply (δ (F w)). Defined. Lemma reindexed_bincoprod_distributor_law : actegory_bincoprod_distributor_iso_law _ _ _ reindexed_bincoprod_distributor_data. Proof. intros w c c'. split; unfold reindexed_bincoprod_distributor_data; apply (pr2 δ (F w)). Qed. Definition reindexed_bincoprod_distributor : actegory_bincoprod_distributor Mon_W BCP ActW := _,,reindexed_bincoprod_distributor_law. End BinaryCase. Section IndexedCase. Context {I : UU} (CP : Coproducts I C) (δ : actegory_coprod_distributor Mon_V CP Act). Definition reindexed_coprod_distributor_data : actegory_coprod_distributor_data Mon_W CP ActW. Proof. intros w cs. apply (δ (F w)). Defined. Lemma reindexed_coprod_distributor_law : actegory_coprod_distributor_iso_law _ _ _ reindexed_coprod_distributor_data. Proof. intros w cs. split; unfold reindexed_coprod_distributor_data; apply (pr2 δ). Qed. Definition reindexed_coprod_distributor : actegory_coprod_distributor Mon_W CP ActW := _,,reindexed_coprod_distributor_law. End IndexedCase. End TwoMonoidalCategories. UniMath-20231010/UniMath/CategoryTheory/Actegories/Examples/000077500000000000000000000000001451125700300234675ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Actegories/Examples/ActionOfEndomorphismsInCATElementary.v000066400000000000000000000225331451125700300330020ustar00rootroot00000000000000(** Constructs the actegory with the action of the endomorphisms on [C] by precomposition on a fixed functor category with source category [C] a general construction is available for bicategories and a fixed object therein author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Local Open Scope cat. Section Action_From_Precomposition. (* Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. *) Context (C D : category). Local Definition Mon_endo: monoidal [C, C] := monendocat_monoidal C. Definition action_from_precomp_CAT_data : bifunctor_data [C, C] [C, D] [C, D]. Proof. use make_bifunctor_data. - intros v f. exact (functor_composite v f). - intros v f1 f2 β. exact (lwhisker_CAT v β). - intros f v1 v2 α. exact (rwhisker_CAT f α). Defined. (* (** we explicitly do not opacify the following definition: *) *) Definition action_from_precomp_CAT_laws : is_bifunctor action_from_precomp_CAT_data. Proof. split5. - intros v f. apply lwhisker_id2_CAT. - intros f v. apply id2_rwhisker_CAT. - intros v f1 f2 f3 β1 β2. apply pathsinv0, lwhisker_vcomp_CAT. - intros f v1 v2 v3 α1 α2. apply pathsinv0, rwhisker_vcomp_CAT. - intros v1 v2 f1 f2 α β. apply vcomp_whisker_CAT. Qed. (* Defined. *) Definition action_from_precomp_CAT : bifunctor [C, C] [C, D] [C, D] := make_bifunctor action_from_precomp_CAT_data action_from_precomp_CAT_laws. Definition actegory_from_precomp_CAT_data : actegory_data Mon_endo [C, D]. Proof. exists action_from_precomp_CAT_data. split4. - intro f. apply lunitor_CAT. - intro f. apply linvunitor_CAT. - intros v w f. apply rassociator_CAT. - intros v w f. apply lassociator_CAT. Defined. Lemma actegory_from_precomp_CAT_laws : actegory_laws Mon_endo actegory_from_precomp_CAT_data. Proof. split5. - exact action_from_precomp_CAT_laws. - split3. + intros f g β. apply vcomp_lunitor_CAT. + apply lunitor_linvunitor_CAT. + apply linvunitor_lunitor_CAT. - split4. + intros v w f f' β. apply lwhisker_lwhisker_rassociator_CAT. + intros v v' w f α. apply pathsinv0, rwhisker_rwhisker_alt_CAT. + intros v w w' f α. apply rwhisker_lwhisker_rassociator_CAT. + split. * apply rassociator_lassociator_CAT. * apply lassociator_rassociator_CAT. - intros v f. apply lunitor_lwhisker_CAT. - intros w v v' f. apply rassociator_rassociator_CAT. Qed. Definition actegory_from_precomp_CAT : actegory Mon_endo [C, D] := actegory_from_precomp_CAT_data,,actegory_from_precomp_CAT_laws. End Action_From_Precomposition. Section TheHomogeneousCase. Context (C : category). (* (** requires [action_from_precomp_CAT] with known proofs of the laws to be even convertibility *) *) Definition action_in_actegory_from_precomp_CAT_as_self_action : actegory_action (Mon_endo C) (actegory_from_precomp_CAT C C) = actegory_action (Mon_endo C) (actegory_with_canonical_self_action (Mon_endo C)). Proof. apply subtypePath. { intro; apply isaprop_is_bifunctor. } apply idpath. Defined. (* (** only possible if the previous is convertibility *) Lemma actegory_from_precomp_CAT_as_self_action : actegory_from_precomp_CAT C C = actegory_with_canonical_self_action (Mon_endo C). Proof. use total2_paths_f. 2: { apply isaprop_actegory_laws. } use total2_paths_f. { apply action_in_actegory_from_precomp_CAT_as_self_action. } use total2_paths_f. { apply idpath. } use total2_paths_f. { apply idpath. } apply idpath. Qed. *) (* (** we should no longer need the proofs of the laws after this result - is the following command effective? *) Opaque action_from_precomp_CAT_laws. *) (** on the way to what we really need is the following convertibility: *) Lemma lax_lineators_for_actegory_from_precomp_CAT_and_self_action_agree (F : functor [C, C] [C, C]) : lineator_lax (Mon_endo C) (actegory_from_precomp_CAT C C) (actegory_from_precomp_CAT C C) F = lineator_lax (Mon_endo C) (actegory_with_canonical_self_action (Mon_endo C)) (actegory_with_canonical_self_action (Mon_endo C)) F. Proof. apply idpath. Qed. (** in fact, we need this with reindexed actegories everywhere *) End TheHomogeneousCase. Section LineatorForPostcomposition. Context (C D E : category) (G : functor D E). Definition lax_lineator_postcomp_actegories_from_precomp_CAT_data : lineator_data (Mon_endo C) (actegory_from_precomp_CAT C D) (actegory_from_precomp_CAT C E) (post_comp_functor G). Proof. intros F K. cbn. apply rassociator_CAT. Defined. Lemma lax_lineator_postcomp_actegories_from_precomp_CAT_laws : lineator_laxlaws (Mon_endo C) (actegory_from_precomp_CAT C D) (actegory_from_precomp_CAT C E) (post_comp_functor G) lax_lineator_postcomp_actegories_from_precomp_CAT_data. Proof. split4. - intro; intros. apply (nat_trans_eq E). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq E). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq E). intro c. cbn. do 3 rewrite id_left. apply functor_id. - intro; intros. apply (nat_trans_eq E). intro c. cbn. rewrite id_left. apply functor_id. Qed. Definition lax_lineator_postcomp_actegories_from_precomp_CAT : lineator_lax (Mon_endo C) (actegory_from_precomp_CAT C D) (actegory_from_precomp_CAT C E) (post_comp_functor G) := _,,lax_lineator_postcomp_actegories_from_precomp_CAT_laws. End LineatorForPostcomposition. Section LineatorForConstConstFunctor. Context {C D E : category} (ActD : actegory (Mon_endo C) D) (e0: E). Definition constconst_functor_lax_lineator_data : lineator_data (Mon_endo C) ActD (actegory_from_precomp_CAT C E) (constant_functor D [C,E] (constant_functor C E e0)). Proof. intros F d. apply nat_trans_id. Defined. Lemma constconst_functor_lax_lineator_laws : lineator_laxlaws _ _ _ _ constconst_functor_lax_lineator_data. Proof. split4. - intro; intros; apply (nat_trans_eq E); intro c; apply idpath. - intro; intros; apply (nat_trans_eq E); intro c; apply idpath. - intro; intros; apply (nat_trans_eq E); intro c. apply pathsinv0, id_right. - intro; intros; apply (nat_trans_eq E); intro c. apply id_right. Qed. Definition constconst_functor_lax_lineator : lineator_lax (Mon_endo C) ActD (actegory_from_precomp_CAT C E) (constant_functor D [C,E] (constant_functor C E e0)) := _,,constconst_functor_lax_lineator_laws. End LineatorForConstConstFunctor. Section DistributionOfCoproducts. Context (C D : category). Section BinaryCoproduct. Context (BCP : BinCoproducts D). Let BCPCD : BinCoproducts [C, D] := BinCoproducts_functor_precat C D BCP. Definition actegory_from_precomp_CAT_bincoprod_distributor_data : actegory_bincoprod_distributor_data (Mon_endo C) BCPCD (actegory_from_precomp_CAT C D). Proof. intro F. apply precomp_bincoprod_distributor_data. Defined. (** a sanity check *) Goal ∏ F G1 G2 c, pr1 (actegory_from_precomp_CAT_bincoprod_distributor_data F G1 G2) c = identity _. Proof. intros. apply idpath. Qed. Lemma actegory_from_precomp_CAT_bincoprod_distributor_law : actegory_bincoprod_distributor_iso_law _ _ _ actegory_from_precomp_CAT_bincoprod_distributor_data. Proof. intro F. apply precomp_bincoprod_distributor_law. Qed. Definition actegory_from_precomp_CAT_bincoprod_distributor : actegory_bincoprod_distributor (Mon_endo C) BCPCD (actegory_from_precomp_CAT C D) := _,,actegory_from_precomp_CAT_bincoprod_distributor_law. End BinaryCoproduct. Section Coproduct. Context {I : UU} (CP : Coproducts I D). Let CPCD : Coproducts I [C, D] := Coproducts_functor_precat I C D CP. Definition actegory_from_precomp_CAT_coprod_distributor_data : actegory_coprod_distributor_data (Mon_endo C) CPCD (actegory_from_precomp_CAT C D). Proof. intros F Gs. apply precomp_coprod_distributor_data. Defined. Lemma actegory_from_precomp_CAT_coprod_distributor_law : actegory_coprod_distributor_iso_law _ _ _ actegory_from_precomp_CAT_coprod_distributor_data. Proof. intros F Gs. apply precomp_coprod_distributor_law. Qed. Definition actegory_from_precomp_CAT_coprod_distributor : actegory_coprod_distributor (Mon_endo C) CPCD (actegory_from_precomp_CAT C D) := _,,actegory_from_precomp_CAT_coprod_distributor_law. End Coproduct. End DistributionOfCoproducts. UniMath-20231010/UniMath/CategoryTheory/Actegories/Examples/SelfActionInCATElementary.v000066400000000000000000000133601451125700300305550ustar00rootroot00000000000000(** Studies the actegory stemming from the self action of the endofunctors on [C] by precomposition author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Local Open Scope cat. Section FixACategory. Context (C : category). Local Definition Mon_endo : monoidal [C, C] := monendocat_monoidal C. Definition SelfActCAT : actegory Mon_endo [C, C] := actegory_with_canonical_self_action Mon_endo. End FixACategory. Section LineatorForPostcomposition. Context (C : category) (G : functor C C). Definition lax_lineator_postcomp_SelfActCAT_data : lineator_data (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G). Proof. intros F K. cbn. apply rassociator_CAT. Defined. Lemma lax_lineator_postcomp_SelfActCAT_laws : lineator_laxlaws (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G) lax_lineator_postcomp_SelfActCAT_data. Proof. split4. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq C). intro c. cbn. do 3 rewrite id_left. apply functor_id. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left. apply functor_id. Qed. (** the following definition may not be usable because of its tight typing *) Definition lax_lineator_postcomp_SelfActCAT : lineator_lax (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G) := _,,lax_lineator_postcomp_SelfActCAT_laws. End LineatorForPostcomposition. Section LineatorForPostcomposition_alt. Context (C D : category) (G : functor D C). Definition lax_lineator_postcomp_SelfActCAT_alt_data : lineator_data (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G). Proof. intros F K. cbn. apply rassociator_CAT. Defined. Lemma lax_lineator_postcomp_SelfActCAT_alt_laws : lineator_laxlaws (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G) lax_lineator_postcomp_SelfActCAT_alt_data. Proof. split4. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left; apply id_right. - intro; intros. apply (nat_trans_eq C). intro c. cbn. do 3 rewrite id_left. apply functor_id. - intro; intros. apply (nat_trans_eq C). intro c. cbn. rewrite id_left. apply functor_id. Qed. (** the following definition is peculiar since it relates different constructions of actegories *) Definition lax_lineator_postcomp_SelfActCAT_alt : lineator_lax (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G) := _,,lax_lineator_postcomp_SelfActCAT_alt_laws. End LineatorForPostcomposition_alt. Section DistributionOfCoproducts. Context (C : category). Section BinaryCoproduct. Context (BCP : BinCoproducts C). Let BCPCD : BinCoproducts [C, C] := BinCoproducts_functor_precat C C BCP. Definition SelfActCAT_bincoprod_distributor_data : actegory_bincoprod_distributor_data (Mon_endo C) BCPCD (SelfActCAT C). Proof. intro F. apply precomp_bincoprod_distributor_data. Defined. Goal ∏ F G1 G2 c, pr1 (SelfActCAT_bincoprod_distributor_data F G1 G2) c = identity _. Proof. intros. apply idpath. Qed. Lemma SelfActCAT_bincoprod_distributor_law : actegory_bincoprod_distributor_iso_law _ _ _ SelfActCAT_bincoprod_distributor_data. Proof. intro F. apply precomp_bincoprod_distributor_law. Qed. Definition SelfActCAT_bincoprod_distributor : actegory_bincoprod_distributor (Mon_endo C) BCPCD (SelfActCAT C) := _,,SelfActCAT_bincoprod_distributor_law. End BinaryCoproduct. Section Coproduct. Context {I : UU} (CP : Coproducts I C). Let CPCD : Coproducts I [C, C] := Coproducts_functor_precat I C C CP. Definition SelfActCAT_coprod_distributor_data : actegory_coprod_distributor_data (Mon_endo C) CPCD (SelfActCAT C). Proof. intros F Gs. apply precomp_coprod_distributor_data. Defined. Lemma SelfActCAT_coprod_distributor_law : actegory_coprod_distributor_iso_law _ _ _ SelfActCAT_coprod_distributor_data. Proof. intros F Gs. apply precomp_coprod_distributor_law. Qed. Definition SelfActCAT_CAT_coprod_distributor : actegory_coprod_distributor (Mon_endo C) CPCD (SelfActCAT C) := _,,SelfActCAT_coprod_distributor_law. End Coproduct. End DistributionOfCoproducts. UniMath-20231010/UniMath/CategoryTheory/Actegories/MorphismsOfActegories.v000066400000000000000000000572141451125700300263650ustar00rootroot00000000000000(** the concept of morphism between actegories that is a functor between the categories acted upon that is compatible with the action structures Written by Ralph Matthes in close correspondence with the code in [UniMath.CategoryTheory.MonoidalOld.MonoidalFunctorsWhiskered] Naming is inspired from Actegories for the Working Amthematician by Matteo Capucci and Bruno Gavranović, available at https://arxiv.org/abs/2203.16351 There are lax and non-lax versions of morphisms: the lax morphisms of V-actegories are called lax V-linear functors, and the non-lax version the V-linear functors, where the difference is that in the latter the crucial natural transformation called the lineator is required to be an isomorphism. The non-lax version is not called strong so as to avoid confusion with the usual denomination of the lineator as the strength of the underlying functor. [lineator_lax] is that notion of strength together with the laws governing it. 2022 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section LinearFunctors. Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *) Section TheDefinitions. Context {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D) (F: functor C D). (** (Weak) Linear functors **) (* Linear functor data *) Definition lineator_data : UU := ∏ (v : V) (x : C), D ⟦ v ⊗_{ActD} F x, F (v ⊗_{ActC} x) ⟧. Identity Coercion lineator_data_funclass : lineator_data >-> Funclass. (** Properties **) Definition lineator_nat_left (ld : lineator_data) := ∏ (v : V) (x1 x2 : C) (g : C⟦x1,x2⟧), v ⊗^{ActD}_{l} # F g · ld v x2 = ld v x1 · # F (v ⊗^{ActC}_{l} g). Definition lineator_nat_right (ld : lineator_data) := ∏ (v1 v2 : V) (x : C) (f : V⟦v1,v2⟧), f ⊗^{ActD}_{r} F x · ld v2 x = ld v1 x · # F (f ⊗^{ActC}_{r} x). Definition preserves_unitor (ld : lineator_data) := ∏ (x : C), ld I_{Mon_V} x · # F au^{ActC}_{x} = au^{ActD}_{F x}. Definition preserves_unitorinv (ld : lineator_data) := ∏ (x : C), auinv^{ActD}_{F x} · ld I_{Mon_V} x = # F auinv^{ActC}_{x}. Definition preserves_actor (ld : lineator_data) : UU := ∏ (v w : V) (x : C), ld (v ⊗_{Mon_V} w) x · #F (aα^{ActC}_{v,w,x}) = aα^{ActD}_{v,w,F x} · v ⊗^{ActD}_{l} (ld w x) · ld v (w ⊗_{ActC} x). Definition preserves_actorinv (ld : lineator_data) : UU := ∏ (v w : V) (x : C), aαinv^{ActD}_{v,w,F x} · ld (v ⊗_{Mon_V} w) x = v ⊗^{ActD}_{l} (ld w x) · ld v (w ⊗_{ActC} x) · #F (aαinv^{ActC}_{v,w,x}). (* the order of the entries follws that of [fmonoidal_laxlaws] *) Definition lineator_laxlaws (ld : lineator_data) : UU := lineator_nat_left ld × lineator_nat_right ld × preserves_actor ld × preserves_unitor ld. Lemma isaprop_lineator_laxlaws (ld : lineator_data) : isaprop (lineator_laxlaws ld). Proof. apply isapropdirprod; [| apply isapropdirprod ; [| apply isapropdirprod]]; repeat (apply impred; intro); apply D. Qed. Definition lineator_lax : UU := ∑ (ld : lineator_data), lineator_laxlaws ld. Definition lineator_lindata (ll : lineator_lax) : lineator_data := pr1 ll. Coercion lineator_lindata : lineator_lax >-> lineator_data. Definition lineator_linlaws (ll : lineator_lax) : lineator_laxlaws ll := pr2 ll. Definition lineator_linnatleft (ll : lineator_lax) : lineator_nat_left ll := pr12 ll. Definition lineator_linnatright (ll : lineator_lax) : lineator_nat_right ll := pr122 ll. Definition lineator_preservesactor (ll : lineator_lax) : preserves_actor ll := pr1 (pr222 ll). Lemma lineator_preservesactorinv (ll : lineator_lax) : preserves_actorinv ll. Proof. intros v w x. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Mon_V ActD _ _ _)). cbn. etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. apply lineator_preservesactor. } repeat rewrite assoc'. etrans. { apply pathsinv0, id_right. } apply maponpaths. etrans. 2: { rewrite <- functor_comp. apply maponpaths. apply pathsinv0, (actegory_actorisolaw Mon_V ActC). } apply pathsinv0, functor_id. Qed. Definition lineator_preservesunitor (ll : lineator_lax) : preserves_unitor ll := pr2 (pr222 ll). Lemma lineator_preservesunitorinv (ll : lineator_lax) : preserves_unitorinv ll. Proof. intro x. apply (z_iso_inv_on_right _ _ _ (_,,_,, actegory_unitorisolaw Mon_V ActD (F x))). cbn. rewrite <- (lineator_preservesunitor ll). repeat rewrite assoc'. etrans. { apply pathsinv0, id_right. } apply maponpaths. etrans. 2: { rewrite <- functor_comp. apply maponpaths. apply pathsinv0, (actegory_unitorisolaw Mon_V ActC x). } apply pathsinv0, functor_id. Qed. Definition lineator_strongly (ld : lineator_data) : UU := ∏ (v : V) (x : C), is_z_isomorphism (ld v x). Definition pointwise_z_iso_from_lineator_strongly {ld : lineator_data} (pas : lineator_strongly ld) (v : V) (x : C) : z_iso (v ⊗_{ActD} F x) (F (v ⊗_{ActC} x)) := ld v x ,, pas v x. Lemma preserves_actor_of_inverse_lineator_strongly {ld : lineator_data} (pα : preserves_actor ld) (ls : lineator_strongly ld) (v w : V) (x : C) : (is_z_isomorphism_mor (ls (v ⊗_{Mon_V} w) x)) · aα^{ActD}_{v, w, F x} = (#F (aα^{ActC}_{v,w,x})) · (is_z_isomorphism_mor (ls v (w ⊗_{ActC} x))) · (v ⊗^{ActD}_{l} (is_z_isomorphism_mor (ls w x))). Proof. set (lsv_wx := pointwise_z_iso_from_lineator_strongly ls v (w ⊗_{ActC} x)). set (lsvw_x := pointwise_z_iso_from_lineator_strongly ls (v ⊗_{Mon_V} w) x). set (lsfv := functor_on_z_iso (leftwhiskering_functor ActD v) (pointwise_z_iso_from_lineator_strongly ls w x)). apply (z_iso_inv_on_left _ _ _ _ lsfv). apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ lsv_wx). rewrite assoc'. rewrite assoc'. etrans. 2: { apply maponpaths. rewrite assoc. exact (pα v w x). } etrans. 2: { rewrite assoc. apply maponpaths_2. exact (! pr222 lsvw_x). } apply (! id_left _). Qed. Lemma lineatorinv_nat_right {ld : lineator_data} (ls : lineator_strongly ld) (lrn : lineator_nat_right ld) (v1 v2 : V) (x : C) (f : V⟦v1,v2⟧) : (is_z_isomorphism_mor (ls v1 x)) · f ⊗^{ActD}_{r} F x = #F (f ⊗^{ActC}_{r} x) · (is_z_isomorphism_mor (ls v2 x)). Proof. set (ldiso := ld v1 x ,, ls v1 x : z_iso _ _). apply (z_iso_inv_on_right _ _ _ ldiso). rewrite assoc. etrans. 2: { apply maponpaths_2. apply lrn. } rewrite assoc'. unfold is_z_isomorphism_mor. rewrite (pr12 (ls v2 x)). apply (! id_right _). Qed. Lemma lineatorinv_nat_left {ld : lineator_data} (ls : lineator_strongly ld) (lln : lineator_nat_left ld) (v : V) (x1 x2 : C) (f : C⟦x1,x2⟧) : (is_z_isomorphism_mor (ls v x1)) · v ⊗^{ActD}_{l} # F f = # F (v ⊗^{ActC}_{l} f) · (is_z_isomorphism_mor (ls v x2)). Proof. set (ldiso := ld v x1 ,, ls v x1 : z_iso _ _). apply (z_iso_inv_on_right _ _ _ ldiso). rewrite assoc. etrans. 2: { apply maponpaths_2. apply lln. } rewrite assoc'. unfold is_z_isomorphism_mor. rewrite (pr12 (ls v x2)). apply (! id_right _). Qed. Definition lineator : UU := ∑ (ll : lineator_lax), lineator_strongly ll. Definition lineator_lineatorlax (lin : lineator) : lineator_lax := pr1 lin. Coercion lineator_lineatorlax : lineator >-> lineator_lax. Definition lineator_linstrongly (lin : lineator) : lineator_strongly lin := pr2 lin. (** We now show that everything behaves as expected **) Definition functor_imageofaction : bifunctor V C D := compose_bifunctor_with_functor ActC F. Definition functor_actionofrightimage : bifunctor V C D := compose_functor_with_bifunctor (functor_identity _) F ActD. Definition lineator_is_nattrans_type : UU := binat_trans functor_actionofrightimage functor_imageofaction. Section LineatorNatural. (* I really don't know how to call the following lemma *) Context {ld : lineator_data} (lnl : lineator_nat_left ld) (lnr : lineator_nat_right ld). Definition lineator_is_nattrans_data : binat_trans_data functor_actionofrightimage functor_imageofaction. Proof. use make_binat_trans_data. intros v x. apply ld. Defined. Lemma lineator_is_nattrans_law : is_binat_trans lineator_is_nattrans_data. Proof. use tpair. - intros v x1 x2 g. apply lnl. - intros v1 v2 x f. apply lnr. Qed. Definition lineator_is_nattrans : lineator_is_nattrans_type := lineator_is_nattrans_data,,lineator_is_nattrans_law. Lemma lineator_is_nattrans_full (v1 v2 : V) (x1 x2 : C) (f : V⟦v1,v2⟧) (g : C⟦x1,x2⟧) : f ⊗^{ActD} # F g · ld v2 x2 = ld v1 x1 · # F (f ⊗^{ActC} g). Proof. intros. etrans. { unfold functoronmorphisms1. rewrite assoc'. rewrite lnl. apply assoc. } rewrite lnr. rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. Qed. End LineatorNatural. Definition lineator_inv_is_nattrans_type : UU := binat_trans functor_imageofaction functor_actionofrightimage. (* name follows [lineator_is_nattrans], for lack of a better proposition *) Definition lineator_inv_is_nattrans {ld : lineator_data} (lnl : lineator_nat_left ld) (lnr : lineator_nat_right ld) (ls : lineator_strongly ld) : lineator_inv_is_nattrans_type := inv_binattrans_from_binatiso(α:=lineator_is_nattrans lnl lnr) ls. (* Strictly linear functors *) Definition lineator_strictly (ld : lineator_data) : UU := ∏ (v : V) (x : C), ∑ (pf : v ⊗_{ActD} (F x) = F (v ⊗_{ActC} x)), ld v x = transportf _ pf (identity (v ⊗_{ActD} (F x))). Lemma lineator_strictly_is_strongly {ld : lineator_data} (lst : lineator_strictly ld) : lineator_strongly ld. Proof. intros v x. use (iso_stable_under_equalitytransportf (pr2 (lst v x)) (is_z_isomorphism_identity (v ⊗_{ActD} F x))). Qed. End TheDefinitions. Arguments lineator_lindata {_ _ _ _ _} _ _ _. Arguments lineator_laxlaws {_ _ _ _ _} _. Arguments lineator_strongly {_ _ _ _ _} _. Arguments lineator_preservesactor {_ _ _ _ _} _ _ _ _. Arguments lineator_preservesunitor {_ _ _ _ _} _ _. Arguments lineator_linstrongly {_ _ _ _ _} _ _ _. (** towards a bicategory of actegories *) Definition identity_lineator_data {C : category} (Act : actegory Mon_V C) : lineator_data Act Act (functor_identity C). Proof. - intros v x. apply identity. Defined. Lemma identity_lineator_laxlaws {C : category} (Act : actegory Mon_V C) : lineator_laxlaws (identity_lineator_data Act). Proof. split4; intros x1; unfold identity_lineator_data; intros. - rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - rewrite id_right. rewrite (bifunctor_leftid Act). rewrite id_right. apply id_left. - apply id_left. Qed. Definition identity_lineator_lax {C : category} (Act : actegory Mon_V C) : lineator_lax Act Act (functor_identity C) := identity_lineator_data Act ,, identity_lineator_laxlaws Act. Definition identity_lineator_strongly {C : category} (Act : actegory Mon_V C) : lineator_strongly (identity_lineator_lax Act). Proof. - intros v x. apply is_z_isomorphism_identity. Defined. Definition identity_lineator {C : category} (Act : actegory Mon_V C) : lineator Act Act (functor_identity C) := identity_lineator_lax Act ,, identity_lineator_strongly Act. Section Composition. Context {C D E : category} {ActC : actegory Mon_V C} {ActD : actegory Mon_V D} {ActE : actegory Mon_V E} {F : C ⟶ D} {G : D ⟶ E}. Section CompositionOfLaxLineators. Context (Fl : lineator_lax ActC ActD F) (Gl : lineator_lax ActD ActE G). Definition comp_lineator_data : lineator_data ActC ActE (F ∙ G). Proof. intros v x. exact (lineator_lindata Gl v (F x) · #G (lineator_lindata Fl v x)). Defined. Lemma comp_lineator_laxlaws : lineator_laxlaws comp_lineator_data. Proof. split4; intro; unfold comp_lineator_data; intros; cbn. - etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply lineator_linnatleft. } rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply lineator_linnatleft. - etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply lineator_linnatright. } rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply lineator_linnatright. - assert (auxF := lineator_preservesactor Fl v w x). assert (auxG := lineator_preservesactor Gl v w (F x)). rewrite (bifunctor_leftcomp ActE). etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, lineator_linnatleft. } etrans. 2: { apply cancel_postcomposition. repeat rewrite assoc. apply cancel_postcomposition. exact auxG. } repeat rewrite assoc'. apply maponpaths. repeat rewrite <- functor_comp. apply maponpaths. etrans; [ exact auxF |]. apply assoc'. - assert (auxF := lineator_preservesunitor Fl x). assert (auxG := lineator_preservesunitor Gl (F x)). etrans; [| exact auxG]. clear auxG. rewrite <- auxF. clear auxF. repeat rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. Qed. Definition comp_lineator_lax : lineator_lax ActC ActE (F ∙ G) := comp_lineator_data,,comp_lineator_laxlaws. End CompositionOfLaxLineators. Section CompositionOfLineators. Context (Fl : lineator ActC ActD F) (Gl : lineator ActD ActE G). Definition comp_lineator_strongly_inverse (v : V) (x : C) : E ⟦ G (F (v ⊗_{ ActC} x)), v ⊗_{ ActE} G (F x) ⟧ := #G (pr1 (lineator_linstrongly Fl v x)) · pr1 (lineator_linstrongly Gl v (F x)). Lemma comp_lineator_strongly_inverse_is_inverse (v : V) (x : C) : is_inverse_in_precat (comp_lineator_lax Fl Gl v x) (comp_lineator_strongly_inverse v x). Proof. split; cbn; unfold comp_lineator_data. - etrans. { repeat rewrite assoc'. apply maponpaths. unfold comp_lineator_strongly_inverse. rewrite assoc. apply cancel_postcomposition. rewrite <- functor_comp. apply maponpaths. apply (pr12 (lineator_linstrongly Fl v x)). } rewrite functor_id. rewrite id_left. apply (pr12 (lineator_linstrongly Gl v (F x))). - unfold comp_lineator_strongly_inverse. etrans. { repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply (pr22 (lineator_linstrongly Gl v (F x))). } rewrite id_left. rewrite <- functor_comp. etrans. { apply maponpaths. apply (pr22 (lineator_linstrongly Fl v x)). } apply functor_id. Qed. Definition comp_lineator_strongly : lineator_strongly (comp_lineator_lax Fl Gl). Proof. intros v x. exact (comp_lineator_strongly_inverse v x,,comp_lineator_strongly_inverse_is_inverse v x). Defined. Definition comp_lineator : lineator ActC ActE (F ∙ G) := comp_lineator_lax Fl Gl ,, comp_lineator_strongly. End CompositionOfLineators. End Composition. End LinearFunctors. Section TransformationsOfActegories. Context {V : category} {Mon_V : monoidal V} {C D : category} {ActC : actegory Mon_V C} {ActD : actegory Mon_V D}. Definition is_linear_nat_trans {F G : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G)(ξ : F ⟹ G) : UU := ∏ (v : V) (x : C), Fl v x · ξ (v ⊗_{ActC} x) = v ⊗^{ActD}_{l} ξ x · Gl v x. Lemma isaprop_is_linear_nat_trans {F G : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G) (ξ : F ⟹ G) : isaprop (is_linear_nat_trans Fl Gl ξ). Proof. apply impred; intro v; apply impred; intro x. apply D. Qed. Lemma is_linear_nat_trans_pointwise_inverse {F G : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G) (ξ : F ⟹ G) (isnziξ : is_nat_z_iso ξ) : is_linear_nat_trans Fl Gl ξ -> is_linear_nat_trans Gl Fl (nat_z_iso_inv (ξ,,isnziξ)). Proof. intros islnt v x. cbn. set (aux := (_,,is_z_iso_leftwhiskering_z_iso (actegory_action Mon_V ActD) v (ξ x) (isnziξ x) : z_iso _ _)). apply pathsinv0, (z_iso_inv_on_right _ _ _ aux). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,isnziξ (v ⊗_{ActC} x))). cbn. apply (!(islnt v x)). Qed. Lemma is_linear_nat_trans_identity {F : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) : is_linear_nat_trans Fl Fl (nat_trans_id F). Proof. intros v c. rewrite id_right. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, (bifunctor_leftid ActD). } apply pathsinv0, id_left. Qed. Lemma is_linear_nat_trans_comp {F G H : functor C D} (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G) (Hl : lineator_lax Mon_V ActC ActD H) {ξ1 : F ⟹ G} {ξ2 : G ⟹ H} (islnt1 : is_linear_nat_trans Fl Gl ξ1) (islnt2 : is_linear_nat_trans Gl Hl ξ2) : is_linear_nat_trans Fl Hl (nat_trans_comp _ _ _ ξ1 ξ2). Proof. intros v x. cbn. rewrite (bifunctor_leftcomp ActD). rewrite assoc. etrans. { apply cancel_postcomposition. apply islnt1. } do 2 rewrite assoc'. apply maponpaths. apply islnt2. Qed. End TransformationsOfActegories. Section StrongFunctors. Definition tensorialstrength {C : category} (M : monoidal C) (F : functor C C) : UU := lineator_lax M (actegory_with_canonical_self_action M) (actegory_with_canonical_self_action M) F. Identity Coercion id_tensorialstrength : tensorialstrength >-> lineator_lax. Lemma tensorialstrength_lineator_nat_left {C : category} (M : monoidal C) {F : functor C C} (ts : tensorialstrength M F) : lineator_nat_left _ _ _ _ ts = ∏ (v x1 x2 : C) (g : C ⟦ x1, x2 ⟧), v ⊗^{ M}_{l} # F g · ts v x2 = ts v x1 · # F (v ⊗^{ M}_{l} g). Proof. apply idpath. Qed. Lemma tensorialstrength_lineator_nat_right {C : category} (M : monoidal C) {F : functor C C} (ts : tensorialstrength M F) : lineator_nat_right _ _ _ _ ts = ∏ (v1 v2 x : C) (f : C ⟦ v1, v2 ⟧), f ⊗^{ M}_{r} F x · ts v2 x = ts v1 x · # F (f ⊗^{ M}_{r} x). Proof. apply idpath. Qed. Lemma tensorialstrength_preserves_unitor {C : category} (M : monoidal C) {F : functor C C} (ts : tensorialstrength M F) : preserves_unitor _ _ _ _ ts = ∏ c : C, ts I_{M} c · # F lu^{M}_{c} = lu^{M}_{F c}. Proof. apply idpath. Qed. Lemma tensorialstrength_preserves_actor {C : category} (M : monoidal C) {F : functor C C} (ts : tensorialstrength M F) : preserves_actor _ _ _ _ ts = ∏ v w x : C, ts (v ⊗_{M} w) x · # F α^{M}_{v, w, x} = α^{M}_{v, w, F x} · v ⊗^{M}_{l} ts w x · ts v (w ⊗_{M} x). Proof. apply idpath. Qed. Section ReindexedStrength. Context {V : category} (Mon_V : monoidal V) {W : category} (Mon_W : monoidal W) {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F) {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D) (FF : C ⟶ D). Definition reindexedstrength : UU := lineator_lax Mon_W (reindexed_actegory Mon_V ActC Mon_W U) (reindexed_actegory Mon_V ActD Mon_W U) FF. Identity Coercion id_reindexedstrength : reindexedstrength >-> lineator_lax. End ReindexedStrength. Definition pointedtensorialstrength {C : category} (M : monoidal C) (F : functor C C) : UU := reindexedstrength M (monoidal_pointed_objects M) (forget_monoidal_pointed_objects_monoidal M) (actegory_with_canonical_self_action M) (actegory_with_canonical_self_action M) F. Goal ∏ (C : category)(M : monoidal C) (F : functor C C), pointedtensorialstrength M F = lineator_lax (monoidal_pointed_objects M) (actegory_with_canonical_pointed_action M) (actegory_with_canonical_pointed_action M) F. Proof. intros. apply idpath. Qed. Identity Coercion id_pointedtensorialstrength : pointedtensorialstrength >-> reindexedstrength. Lemma pointedtensorialstrength_lineator_nat_left {C : category} (M : monoidal C) {F : functor C C} (pts : pointedtensorialstrength M F): lineator_nat_left _ _ _ _ pts = ∏ (v : coslice_cat_total C I_{M}) (x1 x2 : C) (g : C⟦x1,x2⟧), pr1 v ⊗^{ M}_{l} # F g · pts v x2 = pts v x1 · # F (pr1 v ⊗^{ M}_{l} g). Proof. apply idpath. Qed. Lemma pointedtensorialstrength_lineator_nat_right {C : category} (M : monoidal C) {F : functor C C} (pts : pointedtensorialstrength M F): lineator_nat_right _ _ _ _ pts = ∏ (v1 v2 : coslice_cat_total C I_{M}) (x : C) (f : coslice_cat_total C I_{M} ⟦v1,v2⟧), pr1 f ⊗^{ M}_{r} F x · pts v2 x = pts v1 x · # F (pr1 f ⊗^{ M}_{r} x). Proof. apply idpath. Qed. Lemma pointedtensorialstrength_preserves_unitor {C : category} (M : monoidal C) {F : functor C C} (pts : pointedtensorialstrength M F): preserves_unitor _ _ _ _ pts ≃ ∏ c : C, pts I_{ monoidal_pointed_objects M} c · # F lu^{M}_{c} = lu^{M}_{F c}. Proof. use weqimplimpl. - intros H c. assert (Hc := H c). clear H. cbn in Hc. unfold total_unit, reindexed_action_unitor_data in Hc. cbn in Hc. do 2 rewrite (bifunctor_rightid M) in Hc. do 2 rewrite id_left in Hc. exact Hc. - intros H c. cbn. unfold total_unit, reindexed_action_unitor_data. cbn. do 2 rewrite (bifunctor_rightid M). do 2 rewrite id_left. apply H. - apply impred; intro c. apply C. - apply impred; intro c. apply C. Qed. Lemma pointedtensorialstrength_preserves_actor {C : category} (M : monoidal C) {F : functor C C} (pts : pointedtensorialstrength M F) : preserves_actor _ _ _ _ pts ≃ ∏ (v w : coslice_cat_total C I_{M}) (x : C), pts (v ⊗_{monoidal_pointed_objects M} w) x · # F α^{M}_{pr1 v, pr1 w, x} = α^{M}_{pr1 v, pr1 w, F x} · pr1 v ⊗^{M}_{l} pts w x · pts v (pr1 w ⊗_{M} x). Proof. use weqimplimpl. - intros H v w x. assert (Hinst := H v w x). clear H. cbn in Hinst. unfold reindexed_actor_data in Hinst. cbn in Hinst. do 2 rewrite (bifunctor_rightid M) in Hinst. do 2 rewrite id_left in Hinst. exact Hinst. - intros H v w x. cbn. unfold reindexed_actor_data. cbn. do 2 rewrite (bifunctor_rightid M). do 2 rewrite id_left. apply H. - do 3 (apply impred; intro). apply C. - do 3 (apply impred; intro). apply C. Qed. End StrongFunctors. UniMath-20231010/UniMath/CategoryTheory/Actegories/ProductActegory.v000066400000000000000000000335301451125700300252220ustar00rootroot00000000000000(** binary and I-indexed product of actegories w.r.t. the same acting monoidal category author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. (* Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. *) Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Import ActegoryNotations. Section FixAMonoidalCategory. Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *) Section BinaryProduct. Section OneProduct. Context {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D). Let CD : category := category_binproduct C D. Definition actegory_binprod_action_data : bifunctor_data V CD CD. Proof. use make_bifunctor_data. * intros v cd. exact (v ⊗_{ActC} (pr1 cd),, v ⊗_{ActD} (pr2 cd)). * intros v cd1 cd2 fg. exact (v ⊗^{ActC}_{l} (pr1 fg),, v ⊗^{ActD}_{l} (pr2 fg)). * intros cd v1 v2 h. exact (h ⊗^{ActC}_{r} (pr1 cd),, h ⊗^{ActD}_{r} (pr2 cd)). Defined. Lemma actegory_binprod_action_data_is_bifunctor : is_bifunctor actegory_binprod_action_data. Proof. red; repeat split. * intros v cd. apply dirprodeq. - apply (bifunctor_leftid ActC). - apply (bifunctor_leftid ActD). * intros cd v. apply dirprodeq. - apply (bifunctor_rightid ActC). - apply (bifunctor_rightid ActD). * intros v cd1 cd2 cd3 fg1 fg2. apply dirprodeq. - apply (bifunctor_leftcomp ActC). - apply (bifunctor_leftcomp ActD). * intros cd v1 v2 v3 h1 h2. apply dirprodeq. - apply (bifunctor_rightcomp ActC). - apply (bifunctor_rightcomp ActD). * intros v1 v2 cd1 cd2 h fg. apply dirprodeq. - apply (bifunctor_equalwhiskers ActC). - apply (bifunctor_equalwhiskers ActD). Qed. Definition actegory_binprod_data : actegory_data Mon_V CD. Proof. use make_actegory_data. - exact actegory_binprod_action_data. - intros cd. exact (catbinprodmor (au_{ActC} _) (au_{ActD} _)). - intros cd. exact (catbinprodmor (auinv^{ActC}_{_}) (auinv^{ActD}_{_})). - intros v w cd. exact (catbinprodmor (aα^{ActC}_{_,_,_}) (aα^{ActD}_{_,_,_})). - intros v w cd. exact (catbinprodmor (aαinv^{ActC}_{_,_,_}) (aαinv^{ActD}_{_,_,_})). Defined. Lemma actegory_binprod_laws : actegory_laws Mon_V actegory_binprod_data. Proof. split. + exact actegory_binprod_action_data_is_bifunctor. + red; repeat split; try red; intros. - apply dirprodeq; apply actegory_unitornat. - apply dirprodeq; apply actegory_unitorisolaw. - apply dirprodeq; apply actegory_unitorisolaw. - apply dirprodeq; apply actegory_actornatleft. - apply dirprodeq; apply actegory_actornatright. - apply dirprodeq; apply actegory_actornatleftright. - apply dirprodeq; apply actegory_actorisolaw. - apply dirprodeq; apply actegory_actorisolaw. - apply dirprodeq; apply actegory_triangleidentity. - apply dirprodeq; apply actegory_pentagonidentity. Qed. Definition actegory_binprod : actegory Mon_V CD := _,,actegory_binprod_laws. Definition actegory_binprod_pr1_lineator_data : lineator_data Mon_V actegory_binprod ActC (pr1_functor C D). Proof. intros v cd. apply identity. Defined. Lemma actegory_binprod_pr1_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_binprod_pr1_lineator_data. Proof. red; repeat split; red; intros. - rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - cbn. unfold actegory_binprod_pr1_lineator_data. rewrite id_left, id_right. etrans. 2: { apply maponpaths. apply pathsinv0, (functor_id (leftwhiskering_functor ActC v)). } apply pathsinv0, id_right. - apply id_left. Qed. Definition actegory_binprod_pr1_lineator : lineator Mon_V actegory_binprod ActC (pr1_functor C D). Proof. use tpair. - exists actegory_binprod_pr1_lineator_data. exact actegory_binprod_pr1_lineator_lax_laws. - intros v vd. use tpair. + apply identity. + red; split; apply id_left. Defined. Definition actegory_binprod_pr2_lineator_data : lineator_data Mon_V actegory_binprod ActD (pr2_functor C D). Proof. intros v cd. apply identity. Defined. Lemma actegory_binprod_pr2_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_binprod_pr2_lineator_data. Proof. red; repeat split; red; intros. - rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - cbn. unfold actegory_binprod_pr2_lineator_data. rewrite id_left, id_right. etrans. 2: { apply maponpaths. apply pathsinv0, (functor_id (leftwhiskering_functor ActD v)). } apply pathsinv0, id_right. - apply id_left. Qed. Definition actegory_binprod_pr2_lineator : lineator Mon_V actegory_binprod ActD (pr2_functor C D). Proof. use tpair. - exists actegory_binprod_pr2_lineator_data. exact actegory_binprod_pr2_lineator_lax_laws. - intros v cd. use tpair. + apply identity. + red; split; apply id_left. Defined. End OneProduct. Section SelfProduct. Context {C : category} (Act : actegory Mon_V C). Definition actegory_binprod_delta_lineator_data : lineator_data Mon_V Act (actegory_binprod Act Act) (bindelta_functor C). Proof. intros v c. apply identity. Defined. Lemma actegory_binprod_delta_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_binprod_delta_lineator_data. Proof. red; repeat split; red; intros. - cbn. apply maponpaths_12; (rewrite id_left; apply id_right). - cbn. apply maponpaths_12; (rewrite id_left; apply id_right). - cbn. apply maponpaths_12; unfold actegory_binprod_pr2_lineator_data; (rewrite id_left, id_right); (etrans; [| apply maponpaths; apply pathsinv0, (functor_id (leftwhiskering_functor Act v))]; apply pathsinv0, id_right). - cbn. apply maponpaths_12; apply id_left. Qed. Definition actegory_binprod_delta_lineator : lineator Mon_V Act (actegory_binprod Act Act) (bindelta_functor C). Proof. use tpair. - exists actegory_binprod_delta_lineator_data. exact actegory_binprod_delta_lineator_lax_laws. - intros v c. use tpair. + apply identity. + red; split; apply id_left. Defined. End SelfProduct. Section TwoProducts. Context {C1 C2 D1 D2 : category} (ActC1 : actegory Mon_V C1) (ActC2 : actegory Mon_V C2) (ActD1 : actegory Mon_V D1) (ActD2 : actegory Mon_V D2) {F1 : functor C1 D1} {F2 : functor C2 D2 } (Fll1 : lineator_lax Mon_V ActC1 ActD1 F1) (Fll2 : lineator_lax Mon_V ActC2 ActD2 F2). Let ActC12 : actegory Mon_V (category_binproduct C1 C2) := actegory_binprod ActC1 ActC2. Let ActD12 : actegory Mon_V (category_binproduct D1 D2) := actegory_binprod ActD1 ActD2. Definition actegory_pair_functor_lineator_data : lineator_data Mon_V ActC12 ActD12 (pair_functor F1 F2). Proof. intros v c12. cbn. unfold precategory_binproduct_mor. cbn. exact (catbinprodmor (Fll1 v (pr1 c12)) (Fll2 v (pr2 c12))). Defined. Lemma actegory_pair_functor_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_pair_functor_lineator_data. Proof. red; repeat split; red; intros. - cbn. apply maponpaths_12; apply lineator_linnatleft. - cbn. apply maponpaths_12; apply lineator_linnatright. - cbn. apply maponpaths_12; apply lineator_preservesactor. - cbn. apply maponpaths_12; apply lineator_preservesunitor. Qed. Definition actegory_pair_functor_lineator : lineator_lax Mon_V ActC12 ActD12 (pair_functor F1 F2) := _,,actegory_pair_functor_lineator_lax_laws. End TwoProducts. End BinaryProduct. Section Product. Section OneProduct. Context {I: UU} {C : I -> category} (ActC : ∏ i: I, actegory Mon_V (C i)). Let PC : category := product_category C. Definition actegory_prod_action_data : bifunctor_data V PC PC. Proof. use make_bifunctor_data. * intros v cs. exact (fun (i: I) => v ⊗_{ActC i} (cs i)). * intros v cs1 cs2 fs. exact (fun (i: I) => v ⊗^{ActC i}_{l} (fs i)). * intros cs v1 v2 h. exact (fun (i: I) => h ⊗^{ActC i}_{r} (cs i)). Defined. Lemma actegory_prod_action_data_is_bifunctor : is_bifunctor actegory_prod_action_data. Proof. red; repeat split. * intros v cs. apply funextsec; intro i; apply (bifunctor_leftid (ActC i)). * intros cs v. apply funextsec; intro i; apply (bifunctor_rightid (ActC i)). * intros v cs1 cs2 cs3 fs1 fs2. apply funextsec; intro i; apply (bifunctor_leftcomp (ActC i)). * intros cs v1 v2 v3 h1 h2. apply funextsec; intro i; apply (bifunctor_rightcomp (ActC i)). * intros v1 v2 cs1 cs2 h fs. apply funextsec; intro i; apply (bifunctor_equalwhiskers (ActC i)). Qed. Definition actegory_prod_data : actegory_data Mon_V PC. Proof. use make_actegory_data. - exact actegory_prod_action_data. - intros cs. intro i. apply au_{ActC i}. - intros cs. intro i. exact (auinv^{ActC i}_{_}). - intros v w cs. intro i. exact (aα^{ActC i}_{_,_,_}). - intros v w cs. intro i. exact (aαinv^{ActC i}_{_,_,_}). Defined. Lemma actegory_prod_laws : actegory_laws Mon_V actegory_prod_data. Proof. split. + exact actegory_prod_action_data_is_bifunctor. + red; repeat split; try red; intros; apply funextsec; intro i. - apply actegory_unitornat. - apply actegory_unitorisolaw. - apply actegory_unitorisolaw. - apply actegory_actornatleft. - apply actegory_actornatright. - apply actegory_actornatleftright. - apply actegory_actorisolaw. - apply actegory_actorisolaw. - apply actegory_triangleidentity. - apply actegory_pentagonidentity. Qed. Definition actegory_prod : actegory Mon_V PC := _,,actegory_prod_laws. Definition actegory_prod_pr_lineator_data (i : I) : lineator_data Mon_V actegory_prod (ActC i) (pr_functor I C i). Proof. intros v cs. apply identity. Defined. Lemma actegory_prod_pr_lineator_lax_laws (i : I) : lineator_laxlaws _ _ _ _ (actegory_prod_pr_lineator_data i). Proof. red; repeat split; red; intros. - rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - cbn. unfold actegory_prod_pr_lineator_data. rewrite id_left, id_right. etrans. 2: { apply maponpaths. apply pathsinv0, (functor_id (leftwhiskering_functor (ActC i) v)). } apply pathsinv0, id_right. - apply id_left. Qed. Definition actegory_prod_pr_lineator (i : I) : lineator Mon_V actegory_prod (ActC i) (pr_functor I C i). Proof. use tpair. - exists (actegory_prod_pr_lineator_data i). apply actegory_prod_pr_lineator_lax_laws. - intros v cs. use tpair. + apply identity. + red; split; apply id_left. Defined. End OneProduct. Section Power. Context (I : UU) {C : category} (Act : actegory Mon_V C). Definition actegory_power : actegory Mon_V (power_category I C) := actegory_prod (fun _ => Act). Definition actegory_prod_delta_lineator_data : lineator_data Mon_V Act actegory_power (delta_functor I C). Proof. intros v c. apply identity. Defined. Lemma actegory_prod_delta_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_prod_delta_lineator_data. Proof. red; repeat split; red; intros; cbn; apply funextfun; intro i. - rewrite id_left; apply id_right. - rewrite id_left; apply id_right. - rewrite id_left, id_right; (etrans; [| apply maponpaths; apply pathsinv0, (functor_id (leftwhiskering_functor Act v))]; apply pathsinv0, id_right). - apply id_left. Qed. Definition actegory_prod_delta_lineator : lineator Mon_V Act actegory_power (delta_functor I C). Proof. use tpair. - exists actegory_prod_delta_lineator_data. exact actegory_prod_delta_lineator_lax_laws. - intros v c. use tpair. + apply identity. + red; split; apply id_left. Defined. End Power. Section TwoProducts. Context {I: UU} {C : I -> category} (ActC : ∏ i: I, actegory Mon_V (C i)) {D : I -> category} (ActD : ∏ i: I, actegory Mon_V (D i)) {F : ∏ i : I, functor (C i) (D i)} (Fll : ∏ i : I, lineator_lax Mon_V (ActC i) (ActD i) (F i)). Let ActCs : actegory Mon_V (product_category C) := actegory_prod ActC. Let ActDs : actegory Mon_V (product_category D) := actegory_prod ActD. Definition actegory_family_functor_lineator_data : lineator_data Mon_V ActCs ActDs (family_functor I F). Proof. intros v cs. cbn. intro i. exact (Fll i v (cs i)). Defined. Lemma actegory_family_functor_lineator_lax_laws : lineator_laxlaws _ _ _ _ actegory_family_functor_lineator_data. Proof. red; repeat split; red; intros; apply funextsec; intro i; cbn; unfold actegory_family_functor_lineator_data. - apply lineator_linnatleft. - apply lineator_linnatright. - apply lineator_preservesactor. - apply lineator_preservesunitor. Qed. Definition actegory_family_functor_lineator : lineator_lax Mon_V ActCs ActDs (family_functor I F) := _,,actegory_family_functor_lineator_lax_laws. End TwoProducts. End Product. End FixAMonoidalCategory. UniMath-20231010/UniMath/CategoryTheory/Actegories/ProductsInActegories.v000066400000000000000000000102271451125700300262020ustar00rootroot00000000000000(** studies products in the categories on which is being acted in actegories author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ProductActegory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.limits.binproducts. Local Open Scope cat. Import BifunctorNotations. Section FixAMonoidalCategory. Context {V : category} (Mon_V : monoidal V). (** given the monoidal category that acts upon categories *) Section BinaryProduct. Context {C : category} (BP : BinProducts C) (Act : actegory Mon_V C). Definition binprod_collector_data (v : V) (c d : C): v ⊗_{Act} (BP c d) --> BP (v ⊗_{Act} c) (v ⊗_{Act} d). Proof. apply BinProductArrow; apply leftwhiskering_on_morphisms; [apply BinProductPr1 | apply BinProductPr2 ]. Defined. Definition binprod_functor_lineator_data: lineator_data Mon_V (actegory_binprod Mon_V Act Act) Act (binproduct_functor BP). Proof. intros v cd. exact (binprod_collector_data v (pr1 cd) (pr2 cd)). Defined. Lemma binprod_functor_lineator_laxlaws: lineator_laxlaws _ _ _ _ binprod_functor_lineator_data. Proof. red; repeat split. - red. intros v cd1 cd2 g. etrans. { apply precompWithBinProductArrow. } etrans. 2: { apply pathsinv0, postcompWithBinProductArrow. } apply maponpaths_12. + etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } etrans. 2: { cbn. apply (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. etrans. { apply BinProductOfArrowsPr1. } apply idpath. + etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } etrans. 2: { cbn. apply (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. etrans. { apply BinProductOfArrowsPr2. } apply idpath. - red. intros v1 v2 cd f. etrans. { apply precompWithBinProductArrow. } etrans. 2: { apply pathsinv0, postcompWithBinProductArrow. } apply maponpaths_12. + etrans. { apply (bifunctor_equalwhiskers Act). } apply idpath. + etrans. { apply (bifunctor_equalwhiskers Act). } apply idpath. - red. intros v w cd. etrans. { apply postcompWithBinProductArrow. } etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply maponpaths_12. + cbn. etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: { apply (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. apply pathsinv0, BinProductPr1Commutes. } apply pathsinv0, actegory_actornatleft. + cbn. etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: { apply (functor_comp (leftwhiskering_functor Act v)). } apply maponpaths. apply pathsinv0, BinProductPr2Commutes. } apply pathsinv0, actegory_actornatleft. - red. intro cd. etrans. { apply postcompWithBinProductArrow. } cbn. etrans. 2: { apply pathsinv0, BinProductArrowEta. } apply maponpaths_12; apply actegory_unitornat. Qed. Definition binprod_functor_lax_lineator: lineator_lax Mon_V (actegory_binprod Mon_V Act Act) Act (binproduct_functor BP). Proof. exists binprod_functor_lineator_data. exact binprod_functor_lineator_laxlaws. Defined. End BinaryProduct. End FixAMonoidalCategory. UniMath-20231010/UniMath/CategoryTheory/Actions.v000066400000000000000000000364101451125700300214170ustar00rootroot00000000000000(** * Actions Author: Langston Barrett (@siddharthist) *) (** ** Contents - Strutures on morphisms - Endomorphisms and the endomorphism monoid ([endomorphism_monoid]) - Automorphisms and the automorphism group ([automorphism_grp]) - The endomorphism ring in an additive category ([endomorphism_ring]) - Algebraic structures as categories - Lemmas about categories with one object ([contr_cat]) - Monoids - Monoids as categories ([monoid_weq_contr_category]) - Monoid morphisms as functors ([monoid_fun_weq_functor]) - Groups - Groups as groupoids - Group morphisms as functors - Rings - Actions - As homomorphisms - Monoid (group) actions ([monaction_as_morphism]) - Ring actions ([ringaction_as_morphism]) - As functors - Equivariant maps - Monoid (group) actions ([monaction]) - Ring actions - Theory - Translation groupoid ([translation_groupoid]) *) (** TODO: 1. Rephrase definitions, prove equivalences with the originals: - Modules as abelian groups with a ring action - Group actions (Algebra/GroupAction) as sets with a group action 2. Prove equivalence of rings as one-object categories *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.catiso. (* For the endomorphism ring *) Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. (* For the symmetric group *) Require Import UniMath.CategoryTheory.categories.HSET.Core. Local Open Scope cat. (** ** Structures on morphisms *) (** *** Endomorphisms and the endomorphism monoid *) (** Endomorphisms of X are arrows X --> X *) Definition endomorphisms {C : precategory} (X : ob C) : UU := (X --> X). (** When the hom-types of C are sets, we can form the endomorphism monoid *) Definition endomorphism_monoid {C : category} (X : ob C) : monoid. Proof. use make_monoid. - use make_setwithbinop. + use make_hSet. * exact (X --> X). * apply homset_property. + exact (@compose C X X X). - use make_dirprod. + exact (fun x x' x'' => !(@assoc C _ _ _ _ x x' x'')). + refine (identity X,, _). split. * exact (@id_left C X X). * exact (@id_right C X X). Defined. (** The automorphism group is a submonoid of the endomorphism monoid *) (** When the hom-types of C are sets, we can form the automorphism grp *) Definition automorphism_grp {C : category} (X : ob C) : gr := gr_merely_invertible_elements (endomorphism_monoid X). Example symmetric_grp (X : hSet) := @automorphism_grp hset_category X. (** *** The endomorphism ring in an additive category *) Definition endomorphism_ring {C : AdditiveCategory} (_ : ob (PreAdditive_categoryWithAbgrops C)) : ring. Proof. (** The multiplication operation is composition, we reuse the proof from the endomorphism monoid. The addition operation is the addition on homsets, we extract this with to_binop *) pose (end_monoid := @endomorphism_monoid (PreAdditive_categoryWithAbgrops C) X). refine ((pr1 (pr1 end_monoid),, make_dirprod (to_binop X X) (pr2 (pr1 end_monoid))),, _). split; split. (** We know by assumption on C that + is an abgrop.*) - exact (to_isabgrop _ _). (** We already proved this *) - exact (pr2 end_monoid). (** By assumption on C *) - intros f g h; apply (to_premor_monoid C _ _ _ h). - intros f g h; apply (to_postmor_monoid C _ _ _ h). Defined. (** ** Algebraic structures as categories *) (** *** Lemmas about categories with one object *) Definition contr_cat : UU := ∑ C : category, iscontr (ob C). Definition contr_cat_cat : contr_cat -> category := pr1. Coercion contr_cat_cat : contr_cat >-> category. Definition contr_cat_iscontr : ∏ C : contr_cat, iscontr (ob C) := pr2. Definition contr_cat_center (C : contr_cat) : ob C := iscontrpr1 (contr_cat_iscontr C). Section ContrCatLemmas. Context {C : contr_cat}. (** The hom-set between any two objects in a contractible category is equivalent to the hom-set of endomorphisms of the center (b/c both objects are, in fact, equal to the center). *) Lemma contr_cat_hom_weq : ∏ a b : ob C, (a --> b) ≃ (contr_cat_center C --> contr_cat_center C). Proof. intros a b. pose (aeqcenter := iscontr_uniqueness (contr_cat_iscontr C) a). pose (beqcenter := iscontr_uniqueness (contr_cat_iscontr C) b). use weq_iso. (** Construct the arrows using a double transport *) - intros cab. pose (tocenter := transportf (λ x, C ⟦ a, x ⟧) beqcenter cab). exact (transportf (λ x, C ⟦ x, contr_cat_center C ⟧) aeqcenter tocenter). - intros ccc. pose (froma := transportf (λ x, C ⟦ x, contr_cat_center C ⟧) (!aeqcenter) ccc). exact (transportf (λ x, C ⟦ a, x ⟧) (!beqcenter) froma). - intros x; cbn. (* We use abstract to make the rewrite-heavy proof opaque *) abstract (rewrite (transport_f_f _ (aeqcenter) (! aeqcenter)); rewrite pathsinv0r; cbn; unfold idfun; rewrite (transport_f_f _ (beqcenter) (! beqcenter)); rewrite pathsinv0r; cbn; unfold idfun; reflexivity). - intros x; cbn. abstract (rewrite (transport_f_f _ (! beqcenter) (beqcenter)); rewrite pathsinv0l; cbn; unfold idfun; rewrite (transport_f_f _ (! aeqcenter) (aeqcenter)); rewrite pathsinv0l; cbn; unfold idfun; reflexivity). Defined. Context {D : contr_cat}. (** A functor between contractible categories is fully specified by its mapping of the endomorphisms of the center. *) Definition contr_cat_functor_data (f : C ⟦ contr_cat_center C, contr_cat_center C ⟧ -> D ⟦ contr_cat_center D, contr_cat_center D ⟧) : functor_data C D. Proof. use make_functor_data. - apply weqcontrcontr; apply contr_cat_iscontr. - intros a b g. apply f. apply (contr_cat_hom_weq a b); assumption. Defined. (** Any fully faithful functor between contractible categories is an isomorphism. *) Lemma contr_cat_fully_faithful_to_isiso {F : functor C D} (ff : fully_faithful F) : is_catiso F. Proof. use make_dirprod; [assumption|]. apply isweqcontrcontr; apply contr_cat_iscontr. Defined. (** Two contractible categories are equal if there is a fully faithful functor between them. *) Lemma contr_cat_eq {F : functor C D} (ff : fully_faithful F) : C = D. Proof. apply subtypePath. - intro; apply isapropiscontr. - apply catiso_to_category_path. use tpair. + exact F. + apply contr_cat_fully_faithful_to_isiso; assumption. Defined. End ContrCatLemmas. (** *** Monoids *) Local Open Scope multmonoid_scope. (** **** Monoids as categories ([monoid_weq_contr_category]) *) Definition monoid_to_category (Mon : monoid) : contr_cat. Proof. use tpair. - use makecategory. + exact unit. + intros; exact Mon. + intros; apply setproperty. + intros; exact (unel Mon). + intros; exact (f * g). + intros; apply lunax. + intros; apply runax. + intros; cbn; symmetry; apply assocax. + intros; cbn; apply assocax. - apply iscontrunit. Defined. Definition contr_category_to_monoid (C : category) (is : iscontr (ob C)) : monoid. Proof. pose (center := iscontrpr1 is). use make_monoid. - use make_setwithbinop. + use make_hSet. * use (center --> center). * apply homset_property. + exact (@compose _ center center center). - use make_ismonoidop. + unfold isassoc; symmetry; apply assoc. + use make_isunital. * apply identity. * use make_isunit; [ unfold islunit; apply id_left | unfold isrunit; apply id_right ]. Defined. (** The above functions constitute a weak equivalence. *) Lemma monoid_weq_contr_category : monoid ≃ contr_cat. Proof. use weq_iso. - exact monoid_to_category. - exact (uncurry contr_category_to_monoid). - (** By univalence for monoids, it suffices to show that they are isomorphic *) intros Mon; apply monoid_univalence. use tpair. + apply idweq. + use make_dirprod. * intros ? ?; apply idpath. * apply idpath. - intros contrcat. use contr_cat_eq. + use make_functor. * apply contr_cat_functor_data. apply idfun. * use make_dirprod; cbn. { unfold functor_idax. intros a; cbn in *. abstract (induction a; reflexivity). } { unfold functor_compax. intros a b c. abstract (induction a, b, c; reflexivity). } + unfold fully_faithful. intros a b. abstract (induction a, b; exact (idisweq _)). Defined. (** **** Monoid morphisms as functors ([monoid_fun_weq_functor]) *) (** Monoid morphism --> functor *) Definition monoidfun_to_functor {Mon1 Mon2 : monoid} (monfun : monoidfun Mon1 Mon2) : functor (monoid_weq_contr_category Mon1) (monoid_weq_contr_category Mon2). Proof. use make_functor. - apply contr_cat_functor_data. exact monfun. - use make_dirprod. + intros a. abstract (induction a; apply monoidfununel). + intros a b c ? ?. abstract (induction a, b, c; apply monoidfunmul). Defined. (** Throwaway lemma: transport intertwines composition *) Local Lemma transport_compose {C : precategory} {a b : ob C} {p : a = b} (f : a --> a) (g : a --> a) : transportf (λ x, C ⟦ x, b ⟧) p (transportf (λ x, C ⟦ a, x ⟧) p f) · transportf (λ x, C ⟦ x, b ⟧) p (transportf (λ x, C ⟦ a, x ⟧) p g) = transportf (λ x, C ⟦ x, b ⟧) p (transportf (λ x, C ⟦ a, x ⟧) p (f · g)). Proof. induction p; reflexivity. Defined. (** Throwaway lemma: transport intertwines identity *) Local Lemma transport_identity {C : precategory} {a b : ob C} {p : a = b} : transportf (λ x, C ⟦ x, b ⟧) p (transportf (λ x, C ⟦ a, x ⟧) p (identity a)) = identity b. Proof. induction p; reflexivity. Defined. (** Functor --> monoid morphism *) Definition functor_to_monoidfun {CC1 CC2 : contr_cat} (funct : functor CC1 CC2) : monoidfun (invmap monoid_weq_contr_category CC1) (invmap monoid_weq_contr_category CC2). Proof. use monoidfunconstr. - cbn in *. intros endo. apply (contr_cat_hom_weq (funct (iscontrpr1 (pr2 CC1))) (funct (iscontrpr1 (pr2 CC1)))). exact (# funct endo). - use make_ismonoidfun. + intros a b; cbn. abstract (rewrite functor_comp; rewrite <- transport_compose; reflexivity). + abstract (cbn; rewrite functor_id_id; [|reflexivity]; rewrite transport_identity; reflexivity). Defined. (** The above functions constitute a weak equivalence. *) Lemma monoid_fun_weq_functor {Mon1 Mon2 : monoid} : (monoidfun Mon1 Mon2) ≃ functor (monoid_weq_contr_category Mon1) (monoid_weq_contr_category Mon2). Proof. use weq_iso. - exact monoidfun_to_functor. - exact functor_to_monoidfun. - intros mfun. apply monoidfun_paths. reflexivity. - intros funct. apply functor_eq; [apply homset_property|]. use functor_data_eq. + intro. exact (!(pr2 iscontrunit _)). + intros c1 c2 ?. (** Compare to proof of [contr_cat_hom_weq] *) abstract (induction c1, c2; unfold Univalence.double_transport; cbn; do 2 (rewrite (transport_f_f _ (isProofIrrelevantUnit _ _) (! (isProofIrrelevantUnit _ _)) _); rewrite pathsinv0r; cbn; unfold idfun); reflexivity). Defined. (** *** Groups *) (** **** Groups as groupoids *) (** **** Group morphisms as functors *) (** ** Actions *) (** *** As homomorphisms *) (** **** Monoid (group) actions *) Definition monaction_as_morphism {C : category} (Mon : monoid) (X : ob C) : UU := monoidfun Mon (endomorphism_monoid X). Identity Coercion id_monaction : monaction_as_morphism >-> monoidfun. (** Let f and g be actions of M on objects X and Y, respectively. An _equivariant map_ h from f to g is one that intertwines the actions of M, that is, for any m : M, << X -- f m --> X | | h h V V Y -- g m --> Y >> i.e. f m · h = h · g m. *) Definition monaction_equivariant_map {C : category} {M : monoid} {X Y : ob C} (actX : monaction_as_morphism M X) (actY : monaction_as_morphism M Y) : UU := ∑ f : X --> Y, ∏ m, actX m · f = f · actY m. (** **** Ring actions *) Definition ringaction_as_morphism {C : AdditiveCategory } (R : ring) (X : ob C) := ringfun R (endomorphism_ring X). (** *** As functors *) (** **** Equivariant maps (intertwiners) *) Definition contr_cat_action (CC : contr_cat) (C : category) : UU := (CC ⟶ C). Identity Coercion id_contr_cat_action : contr_cat_action >-> functor. Section FunctorActions. Context {CC : contr_cat} {C : category} (actA : contr_cat_action CC C) (actB : contr_cat_action CC C). (** Now we can provide a uniform definition of equivariant maps for monoids, groups, and rings: equivariant map, or intertwiner, is simply a natural transformation. *) Definition equivariant_map : UU := nat_trans (functor_data_from_functor _ _ actA) (functor_data_from_functor _ _ actB). Definition equivariant_map' : UU := ∑ f : actA (contr_cat_center CC) --> actB (contr_cat_center CC), ∏ g : CC ⟦ contr_cat_center CC, contr_cat_center CC ⟧, # actA g · f = f · # actB g. End FunctorActions. (** **** Monoid (group) actions *) (** A monoid action is a functor from the monoid (viewed as a category) to the target category. *) Definition monaction_functor (Mon : monoid) (C : category) := contr_cat_action (monoid_weq_contr_category Mon) C. (** **** Ring actions *) (** ** Theory *) (** *** Translation groupoid ([translation_groupoid]) *) Definition translation_groupoid_precat {CC : contr_cat} (F : contr_cat_action CC hset_category) : precategory. Proof. pose (center := contr_cat_center CC). use make_precategory_one_assoc. - use make_precategory_data. + use make_precategory_ob_mor. * exact (pr1 (F center)). * intros x1 x2; exact (∑ c : CC ⟦center, center⟧, # F c x1 = x2). + intros c; exists (identity center). refine (@eqtohomot _ _ (# F (identity center)) (idfun _) _ c). apply (functor_id F center). + intros a b c f g. cbn in *. exists (pr1 f · pr1 g). refine (maponpaths (λ z, z _) (functor_comp F (pr1 f) (pr1 g)) @ _); cbn. refine (maponpaths _ (pr2 f) @ _). exact (pr2 g). - use make_dirprod. + use make_dirprod; intros ? ? ?; apply subtypePath; try (intro; apply setproperty). * apply id_left. * apply id_right. + cbn. intros a b c d f g h. apply subtypePath; [intro; apply setproperty | ]. apply assoc. Defined. UniMath-20231010/UniMath/CategoryTheory/Additive.v000066400000000000000000000451121451125700300215470ustar00rootroot00000000000000(** * Additive categories. *) (** * Contents - Definition of additive categories - Quotient of an additive category is additive *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Local Open Scope cat. (** * Definition of additive categories *) Section def_additive. (** A preadditive category has an additive structure if it is given a zero object and a binary direct sum operation. *) Definition AdditiveStructure (PA : PreAdditive) : UU := (Zero PA) × (BinDirectSums PA). Definition make_AdditiveStructure (PA : PreAdditive) (H1 : Zero PA) (H2 : BinDirectSums PA) : AdditiveStructure PA. Proof. exact (H1,,H2). Defined. (** Definition of categories with an additive structure *) Definition CategoryWithAdditiveStructure : UU := ∑ PA : PreAdditive, AdditiveStructure PA. Definition Additive_PreAdditive (A : CategoryWithAdditiveStructure) : PreAdditive := pr1 A. Coercion Additive_PreAdditive : CategoryWithAdditiveStructure >-> PreAdditive. Definition make_Additive (PA : PreAdditive) (H : AdditiveStructure PA) : CategoryWithAdditiveStructure. Proof. exact (tpair _ PA H). Defined. (** A preadditive category is additive if it has a zero object and binary direct sums. *) Definition isAdditive (PA : PreAdditive) : hProp := hasZero PA ∧ hasBinDirectSums PA. Definition make_isAdditive (PA : PreAdditive) (H1 : hasZero PA) (H2 : hasBinDirectSums PA) : isAdditive PA := H1,,H2. (** Definition of additive categories *) Definition AdditiveCategory : UU := ∑ PA : PreAdditive, isAdditive PA. Coercion Additive_to_PreAdditive (A : AdditiveCategory) : PreAdditive := pr1 A. (** Accessor functions. *) Definition to_AdditiveStructure (A : CategoryWithAdditiveStructure) : AdditiveStructure A := pr2 A. Definition to_Zero (A : CategoryWithAdditiveStructure) : Zero A := dirprod_pr1 (to_AdditiveStructure A). Definition to_BinDirectSums (A : CategoryWithAdditiveStructure) : BinDirectSums A := dirprod_pr2 (to_AdditiveStructure A). Definition to_BinCoproducts (A : CategoryWithAdditiveStructure) : BinCoproducts A. Proof. intros X Y. exact (BinDirectSum_BinCoproduct A (to_BinDirectSums A X Y)). Defined. Definition to_BinProducts (A : CategoryWithAdditiveStructure) : BinProducts A. Proof. intros X Y. exact (BinDirectSum_BinProduct A (to_BinDirectSums A X Y)). Defined. Lemma to_Unel1' {A : CategoryWithAdditiveStructure} {a b : A} (BS : BinDirectSum a b) : to_In1 BS · to_Pr2 BS = ZeroArrow (to_Zero A) _ _. Proof. rewrite (to_Unel1 BS). apply PreAdditive_unel_zero. Qed. Lemma to_Unel2' {A : CategoryWithAdditiveStructure} {a b : A} (BS : BinDirectSum a b) : to_In2 BS · to_Pr1 BS = ZeroArrow (to_Zero A) _ _. Proof. rewrite (to_Unel2 BS). apply PreAdditive_unel_zero. Qed. Definition to_hasZero (A : AdditiveCategory) : hasZero A := pr1 (pr2 A). Definition to_hasBinDirectSums {A : AdditiveCategory} : hasBinDirectSums A := pr2 (pr2 A). Definition AdditiveZeroArrow {A : CategoryWithAdditiveStructure} (x y : ob A) : A⟦x, y⟧ := ZeroArrow (to_Zero A) x y. Definition oppositeAdditiveCategory : AdditiveCategory -> AdditiveCategory. Proof. intros M. exists (oppositePreAdditive M). split. - use (hinhfun _ (to_hasZero M)). exact (λ Z, pr1 Z,, pr2 (pr2 Z),, pr1 (pr2 Z)). - intros A B. exact (hinhfun oppositeBinDirectSum (to_hasBinDirectSums A B)). Defined. Definition sums_lift (M:AdditiveCategory) {X:Type} (j : X -> ob M) : hProp := zero_lifts M j ∧ ∀ a b (S : BinDirectSum (j a) (j b)), ∃ x, z_iso (j x) (BinDirectSumOb S). Definition opp_sums_lift (M:AdditiveCategory) {X:Type} (j : X -> ob M) : sums_lift M j -> sums_lift (oppositeAdditiveCategory M) j. Proof. intros [hz su]. exists (opp_zero_lifts j hz). intros a b S. generalize (su a b (oppositeBinDirectSum S)). apply hinhfun. intros [s t]. exists s. exact (z_iso_inv (opp_z_iso t)). Defined. Definition induced_Additive (M : AdditiveCategory) {X:Type} (j : X -> ob M) (sum : sums_lift M j) : AdditiveCategory. Proof. exists (induced_PreAdditive M j). induction sum as [hz sum]. split. - use (hinhfun _ hz). intros [z iz]. exists z. split. + intros a. apply iz. + intros b. apply iz. - clear hz. intros a b. apply (squash_to_hProp (to_hasBinDirectSums (j a) (j b))); intros S. use (hinhfun _ (sum a b S)); intros [c t]; clear sum. set (S' := replaceSum S t). use tpair. + exists c. exact (pr21 S'). + cbn. exact (pr2 S'). Defined. Lemma induced_opposite_Additive {M:AdditiveCategory} {X:Type} (j : X -> ob M) (su : sums_lift M j) : oppositeAdditiveCategory (induced_Additive M j su) = induced_Additive (oppositeAdditiveCategory M) j (opp_sums_lift M j su). Proof. intros. apply (total2_paths2_f (induced_opposite_PreAdditive j)). apply propproperty. Defined. End def_additive. (** * Quotient is additive We show that quotient of an additive category by certain subgroups is additive. In particular, this is used to show that the naive homotopy category of the category of chain complexes is an CategoryWithAdditiveStructure precategory. *) Section additive_quot_additive. Variable A : CategoryWithAdditiveStructure. Hypothesis PAS : PreAdditiveSubabgrs A. Hypothesis PAC : PreAdditiveComps A PAS. Definition Quotcategory_Additive : CategoryWithAdditiveStructure. Proof. use make_Additive. - exact (Quotcategory_PreAdditive A PAS PAC). - use make_AdditiveStructure. + exact (Quotcategory_Zero A PAS PAC (to_Zero A)). + exact (Quotcategory_BinDirectSums A (to_BinDirectSums A) PAS PAC). Defined. End additive_quot_additive. (** * Kernels, Equalizers, Cokernels, and Coequalizers in CategoryWithAdditiveStructure categories *) (** ** Introduction Let f g : X --> Y be morphisms in an additive category. In this section we show that a Cokernel of f - g is the Coequalizer of f and g, and vice versa. Similarly for Kernels and equalizers. *) Section additive_kernel_equalizers. Variable A : CategoryWithAdditiveStructure. Lemma AdditiveKernelToEqualizer_eq1 {x y : ob A} (f g : x --> y) (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) : KernelArrow K · f = KernelArrow K · g. Proof. use (to_rcan A (KernelArrow K · (to_inv g))). rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. rewrite KernelCompZero. rewrite (@to_rinvax' A (to_Zero A)). rewrite ZeroArrow_comp_right. apply idpath. Qed. Lemma AdditiveKernelToEqualizer_isEqualizer {x y : ob A} (f g : x --> y) (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) : isEqualizer (*C:= categoryWithAbgrops_category _ *)f g (KernelArrow K) (AdditiveKernelToEqualizer_eq1 f g K). Proof. use make_isEqualizer. intros w h H'. use unique_exists. - use KernelIn. + exact h. + set (X := @to_premor_linear' A). rewrite X. etrans. { apply maponpaths_2. apply H'. } rewrite <- to_premor_linear'. rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_right. - cbn. use KernelCommutes. - intros y0. apply to_has_homsets. - intros y0 X. cbn in X. use (KernelArrowisMonic _ K). etrans. 2 : { apply pathsinv0. apply KernelCommutes. } exact X. Qed. Definition AdditiveKernelToEqualizer {x y : ob A} (f g : x --> y) (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) : Equalizer f g. Proof. use make_Equalizer. - exact K. - use (KernelArrow K). - exact (AdditiveKernelToEqualizer_eq1 f g K). - exact (AdditiveKernelToEqualizer_isEqualizer f g K). Defined. Lemma AdditiveEqualizerToKernel_eq1 {x y : ob A} (f g : x --> y) (E : Equalizer f g) : EqualizerArrow E · to_binop x y f (to_inv g) = ZeroArrow (to_Zero A) E y. Proof. set (X:= @to_premor_linear' A). rewrite X. use (to_rcan A (EqualizerArrow E · g)). rewrite to_assoc. rewrite to_lunax''. rewrite <- to_premor_linear'. rewrite (@to_linvax' A (to_Zero A)). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply (EqualizerEqAr E). Qed. Lemma AdditiveEqualizerToKernel_isKernel {x y : ob A} (f g : x --> y) (E : Equalizer f g) : isKernel (to_Zero A) (EqualizerArrow E) (to_binop x y f (to_inv g)) (AdditiveEqualizerToKernel_eq1 f g E). Proof. use make_isKernel. - intros w h H'. use unique_exists. + use (EqualizerIn E). * exact h. * use (to_rcan A (h · to_inv g)). rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. rewrite (@to_rinvax' A (to_Zero A)). rewrite ZeroArrow_comp_right. exact H'. + cbn. use EqualizerCommutes. + intros y0. apply to_has_homsets. + intros y0 X. cbn in X. use (EqualizerArrowisMonic E). rewrite EqualizerCommutes. exact X. Qed. Definition AdditiveEqualizerToKernel {x y : ob A} (f g : x --> y) (E : Equalizer f g) : Kernel (to_Zero A) (to_binop _ _ f (to_inv g)). Proof. use make_Kernel. - exact E. - use (EqualizerArrow E). - exact (AdditiveEqualizerToKernel_eq1 f g E). - exact (AdditiveEqualizerToKernel_isKernel f g E). Defined. (** ** Correspondence between Cokernels and Coeqalizers *) Lemma AdditiveCokernelToCoequalizer_eq1 {x y : ob A} (f g : x --> y) (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) : f · CokernelArrow CK = g · CokernelArrow CK. Proof. use to_rcan. - exact (to_inv g · CokernelArrow CK). - rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. rewrite (CokernelCompZero (to_Zero A) CK). apply pathsinv0. rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_left. Qed. Lemma AdditiveCokernelToCoequalizer_isCoequalizer {x y : ob A} (f g : x --> y) (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) : isCoequalizer f g (CokernelArrow CK) (AdditiveCokernelToCoequalizer_eq1 f g CK). Proof. use make_isCoequalizer. intros w0 h H'. use unique_exists. - use CokernelOut. + exact h. + use to_rcan. * exact (g · h). * rewrite to_lunax''. rewrite <- to_postmor_linear'. rewrite to_assoc. rewrite (@to_linvax' A (to_Zero A)). rewrite to_runax''. apply H'. - cbn. use CokernelCommutes. - intros y0. apply to_has_homsets. - intros y0 X. cbn in X. cbn. use (CokernelArrowisEpi _ CK). rewrite CokernelCommutes. exact X. Qed. Definition AdditiveCokernelToCoequalizer {x y : ob A} (f g : x --> y) (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) : Coequalizer f g. Proof. use make_Coequalizer. - exact CK. - use (CokernelArrow CK). - exact (AdditiveCokernelToCoequalizer_eq1 f g CK). - exact (AdditiveCokernelToCoequalizer_isCoequalizer f g CK). Defined. Lemma AdditiveCoequalizerToCokernel_eq1 {x y : ob A} (f g : x --> y) (CE : Coequalizer f g) : to_binop x y f (to_inv g) · CoequalizerArrow CE = ZeroArrow (to_Zero A) x CE. Proof. rewrite to_postmor_linear'. rewrite CoequalizerEqAr. rewrite <- to_postmor_linear'. rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_left. Qed. Lemma AdditiveCoequalizerToCokernel_isCokernel {x y : ob A} (f g : x --> y) (CE : Coequalizer f g) : isCokernel (to_Zero A) (to_binop x y f (to_inv g)) (CoequalizerArrow CE) (AdditiveCoequalizerToCokernel_eq1 f g CE). Proof. use make_isCokernel. - intros w h H'. use unique_exists. + use CoequalizerOut. * exact h. * use (to_rcan A (to_inv g · h)). rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. rewrite (@to_rinvax' A (to_Zero A)). rewrite ZeroArrow_comp_left. exact H'. + cbn. use CoequalizerCommutes. + intros y0. apply to_has_homsets. + intros y0 X. cbn in X. use (CoequalizerArrowisEpi CE). rewrite CoequalizerCommutes. exact X. Qed. Definition AdditiveCoequalizerToCokernel {x y : ob A} (f g : x --> y) (CE : Coequalizer f g) : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g)). Proof. use make_Cokernel. - exact CE. - use CoequalizerArrow. - exact (AdditiveCoequalizerToCokernel_eq1 f g CE). - exact (AdditiveCoequalizerToCokernel_isCokernel f g CE). Defined. End additive_kernel_equalizers. (** * Sum and in to BinDirectSum is Monic *) Section additive_minus_monic. Variable A : CategoryWithAdditiveStructure. Lemma isMonic_to_binop_BinDirectSum1 {x y z : A} (f : Monic A x y) (g : x --> z) (DS : BinDirectSum y z) : isMonic (to_binop _ _ (f · to_In1 DS) (g · to_In2 DS)). Proof. use make_isMonic. intros x0 g0 h X. assert (e : g0 · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr1 DS = h · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr1 DS). { etrans. apply maponpaths_2. apply X. apply idpath. } rewrite <- assoc in e. rewrite <- assoc in e. rewrite (@to_postmor_linear' A) in e. rewrite <- assoc in e. rewrite <- assoc in e. rewrite (to_IdIn1 DS) in e. rewrite (to_Unel2' DS) in e. rewrite ZeroArrow_comp_right in e. rewrite id_right in e. use (MonicisMonic A f). rewrite to_runax'' in e. exact e. Qed. (** This version is used in AbelianPushoutPullback *) Lemma isMonic_to_binop_BinDirectSum1' {x y z : A} (f : Monic A x y) (g : x --> z) (DS : BinDirectSum y z) : isMonic (to_binop _ _ (f · to_In1 DS) (to_inv (g · to_In2 DS))). Proof. rewrite PreAdditive_invlcomp. use isMonic_to_binop_BinDirectSum1. Qed. Lemma isMonic_to_binop_BinDirectSum2 {x y z : A} (f : x --> y) (g : Monic A x z) (DS : BinDirectSum y z) : isMonic (to_binop _ _ (f · to_In1 DS) (g · to_In2 DS)). Proof. use make_isMonic. intros x0 g0 h X. assert (e : g0 · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr2 DS = h · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr2 DS). { rewrite X. apply idpath. } rewrite <- assoc in e. rewrite <- assoc in e. rewrite (@to_postmor_linear' A) in e. rewrite <- assoc in e. rewrite <- assoc in e. rewrite (@to_IdIn2 A _ _ _ _ _ _ _ DS) in e. rewrite (to_Unel1' DS) in e. rewrite ZeroArrow_comp_right in e. rewrite id_right in e. use (MonicisMonic A g). rewrite to_lunax'' in e. exact e. Qed. Lemma isEpi_to_binop_BinDirectSum1 {x y z : A} (f : Epi A y x) (g : z --> x) (DS : BinDirectSum y z) : isEpi (to_binop _ _ (to_Pr1 DS · f) (to_Pr2 DS · g)). Proof. use make_isEpi. intros z0 g0 h X. use (EpiisEpi A f). assert (e : to_In1 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · g0 = to_In1 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · h). { rewrite <- assoc. rewrite <- assoc. rewrite X. apply idpath. } rewrite to_premor_linear' in e. rewrite assoc in e. rewrite assoc in e. rewrite to_Unel1' in e. rewrite ZeroArrow_comp_left in e. rewrite to_runax'' in e. rewrite (to_IdIn1 DS) in e. rewrite id_left in e. apply e. Qed. (** This version is used in AbelianPushoutPullback *) Lemma isEpi_to_binop_BinDirectSum1' {x y z : A} (f : Epi A x z) (g : y --> z) (DS : BinDirectSum x y) : isEpi (to_binop _ _ (to_Pr1 DS · f) (to_inv (to_Pr2 DS · g))). Proof. rewrite PreAdditive_invrcomp. use isEpi_to_binop_BinDirectSum1. Qed. Lemma isEpi_to_binop_BinDirectSum2 {x y z : A} (f : y --> x) (g : Epi A z x) (DS : BinDirectSum y z) : isEpi (to_binop _ _ (to_Pr1 DS · f) (to_Pr2 DS · g)). Proof. use make_isEpi. intros z0 g0 h X. use (EpiisEpi A g). assert (e : to_In2 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · g0 = to_In2 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · h). { rewrite <- assoc. rewrite <- assoc. rewrite X. apply idpath. } rewrite to_premor_linear' in e. rewrite assoc in e. rewrite assoc in e. rewrite to_Unel2' in e. rewrite ZeroArrow_comp_left in e. rewrite to_lunax'' in e. rewrite (to_IdIn2 DS) in e. rewrite id_left in e. apply e. Qed. End additive_minus_monic. (** Kernels and cokernels in PreAdditive *) Section monics_and_epis_in_additive. Variable A : CategoryWithAdditiveStructure. Lemma to_isMonic {x y : ob A} (f : x --> y) (H : ∏ (z : ob A) (g : z --> x) (H : g · f = ZeroArrow (to_Zero A) _ _), g = ZeroArrow (to_Zero A) _ _ ) : isMonic f. Proof. use make_isMonic. intros x0 g h X. set (tmp := H x0 (to_binop _ _ g (to_inv h))). use (to_rcan A (to_inv h)). rewrite (@to_rinvax' A (to_Zero A)). apply tmp. clear tmp. rewrite to_postmor_linear'. use (to_rcan A (h · f)). rewrite to_assoc. rewrite <- to_postmor_linear'. rewrite (@to_linvax' A (to_Zero A)). rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_lunax''. exact X. Qed. Lemma to_isEpi {x y : ob A} (f : x --> y) (H : ∏ (z : ob A) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _), g = ZeroArrow (to_Zero A) _ _ ) : isEpi f. Proof. use make_isEpi. intros x0 g h X. set (tmp := H x0 (to_binop _ _ g (to_inv h))). use (to_rcan A (to_inv h)). rewrite (@to_rinvax' A (to_Zero A)). apply tmp. clear tmp. rewrite to_premor_linear'. use (to_rcan A (f · h)). rewrite to_assoc. rewrite <- to_premor_linear'. rewrite (@to_linvax' A (to_Zero A)). rewrite ZeroArrow_comp_right. rewrite to_runax''. rewrite to_lunax''. exact X. Qed. End monics_and_epis_in_additive. UniMath-20231010/UniMath/CategoryTheory/AdditiveFunctors.v000066400000000000000000000671471451125700300233070ustar00rootroot00000000000000(** * Additive functors *) (** ** Contents - Definition of additive functors - Additive functor preserves BinDirectSums - Definition of PreservesBinDirectSums - Additive funtor preserves zero. - Preserves IdIn1, IdIn2, Unit1, Unit2, and Id of BinDirectSum - Preserves BinDirectCoproducts - Preserves BinDirectProducts - Preserves BinDirectSums - If a functor preserves BinDirectSums, then it is additive - Preserves unel - Commutes with BinOp - isAdditiveFunctor - The natural additive functor to quotient - Additive equivalences *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Local Open Scope cat. (** * Definition of additive functor Functor is additive if for any two objects a1 a2 of an additive category A, the map on morphisms A⟦a1, a2⟧ -> B⟦F a1, F a2⟧ is a morphism of abelian groups. *) Section def_additivefunctor. (** ** isAdditiveFunctor *) Definition isAdditiveFunctor {A B : CategoryWithAdditiveStructure} (F : functor A B) : UU := ∏ (a1 a2 : A), @ismonoidfun (to_abgr a1 a2) (to_abgr (F a1) (F a2)) (# F). Definition make_isAdditiveFunctor {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : ∏ (a1 a2 : A), @ismonoidfun (to_abgr a1 a2) (to_abgr (F a1) (F a2)) (# F)) : isAdditiveFunctor F. Proof. intros a1 a2. exact (H a1 a2). Qed. Definition make_isAdditiveFunctor' {A B : CategoryWithAdditiveStructure} (F : functor A B) (H1 : ∏ (a1 a2 : A), (# F (ZeroArrow (to_Zero A) a1 a2)) = ZeroArrow (to_Zero B) (F a1) (F a2)) (H2 : ∏ (a1 a2 : A) (f g : A⟦a1, a2⟧), # F (to_binop _ _ f g) = to_binop _ _ (# F f) (# F g)) : isAdditiveFunctor F. Proof. use make_isAdditiveFunctor. intros a1 a2. split. - intros f g. apply (H2 a1 a2 f g). - set (tmp := PreAdditive_unel_zero A (to_Zero A) a1 a2). unfold to_unel in tmp. rewrite tmp. clear tmp. set (tmp := PreAdditive_unel_zero B (to_Zero B) (F a1) (F a2)). unfold to_unel in tmp. rewrite tmp. clear tmp. apply (H1 a1 a2). Qed. Lemma isaprop_isAdditiveFunctor {A B : CategoryWithAdditiveStructure} (F : functor A B) : isaprop (isAdditiveFunctor F). Proof. apply impred_isaprop. intros t. apply impred_isaprop. intros t0. apply isapropismonoidfun. Qed. (** ** Additive functor *) Definition AdditiveFunctor (A B : CategoryWithAdditiveStructure) : UU := ∑ F : (functor A B), isAdditiveFunctor F. Definition make_AdditiveFunctor {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : isAdditiveFunctor F) : AdditiveFunctor A B := tpair _ F H. (** Accessor functions *) Definition AdditiveFunctor_Functor {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) : functor A B := pr1 F. Coercion AdditiveFunctor_Functor : AdditiveFunctor >-> functor. Definition AdditiveFunctor_isAdditiveFunctor {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) : isAdditiveFunctor (AdditiveFunctor_Functor F) := pr2 F. (** ** Basics of additive functors *) Lemma AdditiveFunctorUnel {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) (a1 a2 : A) : # F (to_unel a1 a2) = to_unel (F a1) (F a2). Proof. unfold to_unel. apply (pr2 (pr2 F a1 a2)). Qed. Lemma AdditiveFunctorZeroArrow {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) (a1 a2 : A) : # F (ZeroArrow (to_Zero A) a1 a2) = ZeroArrow (to_Zero B) (F a1) (F a2). Proof. rewrite <- PreAdditive_unel_zero. rewrite <- PreAdditive_unel_zero. apply AdditiveFunctorUnel. Qed. Lemma AdditiveFunctorLinear {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (f g : a1 --> a2) : # F (to_binop _ _ f g) = to_binop _ _ (# F f) (# F g). Proof. apply (pr1 (pr2 F a1 a2)). Qed. Lemma AdditiveFunctorInv {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (f : a1 --> a2) : # F (to_inv f) = to_inv (# F f). Proof. apply (to_lcan _ (# F f)). rewrite <- AdditiveFunctorLinear. rewrite rinvax. rewrite AdditiveFunctorUnel. rewrite rinvax. apply idpath. Qed. Definition CompositionIsAdditive {A1 A2 A3 : CategoryWithAdditiveStructure} (F1 : AdditiveFunctor A1 A2) (F2 : AdditiveFunctor A2 A3) : isAdditiveFunctor (functor_composite F1 F2). Proof. use make_isAdditiveFunctor'. - intros a1 a2. cbn. rewrite AdditiveFunctorZeroArrow. use AdditiveFunctorZeroArrow. - intros a1 a2 f g. cbn. rewrite AdditiveFunctorLinear. use AdditiveFunctorLinear. Qed. Definition AdditiveComposite {A1 A2 A3 : CategoryWithAdditiveStructure}(F1 : AdditiveFunctor A1 A2) (F2 : AdditiveFunctor A2 A3) : AdditiveFunctor A1 A3 := make_AdditiveFunctor (functor_composite F1 F2) (CompositionIsAdditive F1 F2). End def_additivefunctor. (** * Additive functor preserves BinDirectSums We say that a functor F between additive categories A and B preserves BinDirectSums if for any BinDirectSum (a1 ⊕ a2, in1, in2, pr1, pr2) in A, the data (F(a1 ⊕ a2), F(in1), F(in2), F(pr1), F(pr2)) is a BinDirectSum in B. *) Section additivefunctor_preserves_bindirectsums. Definition PreservesBinDirectSums {A B : CategoryWithAdditiveStructure} (F : functor A B) : hProp := ∀ (a1 a2 : A) (DS : BinDirectSum a1 a2), isBinDirectSum (# F (to_In1 DS)) (# F (to_In2 DS)) (# F (to_Pr1 DS)) (# F (to_Pr2 DS)). (** Additive functor preserves zeros. *) Lemma AdditiveFunctorPreservesBinDirectSums_zero {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) : isZero (F (to_Zero A)). Proof. set (isadd0 := AdditiveFunctor_isAdditiveFunctor F (to_Zero A) (to_Zero A)). set (unel := to_unel (to_Zero A) (to_Zero A)). set (tmp := (pr2 isadd0)). cbn in tmp. set (tmp1 := PreAdditive_unel_zero A (to_Zero A) (to_Zero A) (to_Zero A)). unfold to_unel in tmp1. rewrite tmp1 in tmp. clear tmp1. assert (tmp2 : identity (to_Zero A) = ZeroArrow (to_Zero A) _ _) by apply ArrowsToZero. rewrite <- tmp2 in tmp. clear tmp2. assert (X : # F (identity (to_Zero A)) = identity (F (to_Zero A))) by apply functor_id. set (tmp2 := PreAdditive_unel_zero B (to_Zero B) (F (to_Zero A)) (F (to_Zero A))). unfold to_unel in tmp2. rewrite tmp2 in tmp. clear tmp2. assert (X0 : z_iso (F (to_Zero A)) (to_Zero B)). { exists (ZeroArrowTo (F (to_Zero A))). exists (ZeroArrowFrom (F (to_Zero A))). split. + rewrite <- X. rewrite tmp. apply ZeroArrowEq. + apply ArrowsToZero. } apply (ZIsoToisZero B (to_Zero B) X0). Qed. (** ** F preserves IdIn1, IdIn2, IdUnit1, IdUnit2, and Id of BinDirectSum *) Local Lemma AdditiveFunctorPreservesBinDirectSums_idin1 {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (DS : BinDirectSum a1 a2) : (# F (to_In1 DS)) · (# F (to_Pr1 DS)) = identity _. Proof. rewrite <- functor_comp. rewrite (to_IdIn1 DS). apply functor_id. Qed. Local Lemma AdditiveFunctorPreservesBinDirectSums_idin2 {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (DS : BinDirectSum a1 a2) : (# F (to_In2 DS)) · (# F (to_Pr2 DS)) = identity _. Proof. rewrite <- functor_comp. rewrite (to_IdIn2 DS). apply functor_id. Qed. Local Lemma AdditiveFunctorPreservesBinDirectSums_unit1 {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (DS : BinDirectSum a1 a2) : (# F (to_In1 DS)) · (# F (to_Pr2 DS)) = to_unel (F a1) (F a2). Proof. rewrite <- functor_comp. rewrite (to_Unel1 DS). apply AdditiveFunctorUnel. Qed. Local Lemma AdditiveFunctorPreservesBinDirectSums_unit2 {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (DS : BinDirectSum a1 a2) : (# F (to_In2 DS)) · (# F (to_Pr1 DS)) = to_unel (F a2) (F a1). Proof. rewrite <- functor_comp. rewrite (to_Unel2 DS). apply AdditiveFunctorUnel. Qed. Local Lemma AdditiveFunctorPreservesBinDirectSums_id {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) {a1 a2 : A} (DS : BinDirectSum a1 a2) : to_binop _ _ ((# F (to_Pr1 DS)) · (# F (to_In1 DS))) ((# F (to_Pr2 DS)) · (# F (to_In2 DS))) = identity _. Proof. rewrite <- functor_comp. rewrite <- functor_comp. rewrite <- AdditiveFunctorLinear. rewrite (to_BinOpId DS). apply functor_id. Qed. (** An additive functor preserves BinDirectSums *) Lemma AdditiveFunctorPreservesBinDirectSums {A B : CategoryWithAdditiveStructure} (F : AdditiveFunctor A B) : PreservesBinDirectSums F. Proof. intros a1 a2 DS. use make_isBinDirectSum. - use (AdditiveFunctorPreservesBinDirectSums_idin1 F DS). - use (AdditiveFunctorPreservesBinDirectSums_idin2 F DS). - use (AdditiveFunctorPreservesBinDirectSums_unit1 F DS). - use (AdditiveFunctorPreservesBinDirectSums_unit2 F DS). - use (AdditiveFunctorPreservesBinDirectSums_id F DS). Qed. End additivefunctor_preserves_bindirectsums. (** * Additive criteria In this section we show that a functor between additive categories which preserves BinDirectSums is additive. *) Section additivefunctor_criteria. (** ** Preserves unel *) (** A functor which preserves binary direct sums preserves zero objects. *) Lemma isAdditiveCriteria_isZero {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) : isZero (F (to_Zero A)). Proof. set (DS := to_BinDirectSums A (to_Zero A) (to_Zero A)). set (isBDS := H (to_Zero A) (to_Zero A) DS). assert (e1 : (# F (to_In1 DS)) = (# F (to_In2 DS))). { apply maponpaths. apply ArrowsFromZero. } assert (e2 : (# F (to_Pr1 DS)) = (# F (to_Pr2 DS))). { apply maponpaths. apply ArrowsToZero. } cbn in isBDS. rewrite e1 in isBDS. rewrite e2 in isBDS. clear e1 e2. set (BDS := make_BinDirectSum _ _ _ _ _ _ _ _ isBDS). use make_isZero. - intros b. use tpair. + apply (ZeroArrow (to_Zero B) _ _). + cbn. intros t. use (pathscomp0 (!(BinDirectSumIn1Commutes B BDS _ t (ZeroArrow (to_Zero B) _ _)))). use (pathscomp0 _ (BinDirectSumIn2Commutes B BDS _ t (ZeroArrow (to_Zero B) _ _))). cbn. apply cancel_precomposition. apply idpath. - intros a. use tpair. + apply (ZeroArrow (to_Zero B) _ _). + cbn. intros t. use (pathscomp0 (!(BinDirectSumPr1Commutes B BDS _ t (ZeroArrow (to_Zero B) _ _)))). use (pathscomp0 _ (BinDirectSumPr2Commutes B BDS _ t (ZeroArrow (to_Zero B) _ _))). cbn. apply cancel_postcomposition. apply idpath. Qed. (** F preserves unel *) Local Corollary isAdditiveCriteria_preservesUnel {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) (a1 a2 : A) : (# F (to_unel a1 a2)) = (to_unel (F a1) (F a2)). Proof. set (Z := make_Zero (F (to_Zero A)) (isAdditiveCriteria_isZero F H)). rewrite (PreAdditive_unel_zero A (to_Zero A) a1 a2). rewrite (PreAdditive_unel_zero B Z (F a1) (F a2)). unfold ZeroArrow. rewrite functor_comp. cbn. assert (e1 : # F (ZeroArrowTo a1) = @ZeroArrowTo B Z (F a1)). { apply (ArrowsToZero B Z). } assert (e2 : # F (ZeroArrowFrom a2) = @ZeroArrowFrom B Z (F a2)). { apply (ArrowsFromZero B Z). } rewrite e1. rewrite e2. apply idpath. Qed. (** ** Commutes with binop *) (** F commutes with addition of projections from a1 ⊕ a1 *) Local Lemma isAdditiveCriteria_isBinopFun_Pr {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) {a1 a2 : A} (DS : BinDirectSum a1 a1): # F (to_binop DS a1 (to_Pr1 DS) (to_Pr2 DS)) = to_binop (F DS) (F a1) (# F (to_Pr1 DS)) (# F (to_Pr2 DS)). Proof. set (isBDS := H a1 a1 DS). set (BDS := make_BinDirectSum _ _ _ _ _ _ _ _ isBDS). use (FromBinDirectSumsEq B BDS); cbn. - rewrite <- functor_comp. rewrite to_premor_linear'. rewrite (to_IdIn1 DS). rewrite (to_Unel1 DS). rewrite to_runax'. rewrite functor_id. rewrite to_premor_linear'. rewrite <- functor_comp. rewrite <- functor_comp. rewrite (to_IdIn1 DS). rewrite (to_Unel1 DS). rewrite functor_id. rewrite (isAdditiveCriteria_preservesUnel _ H). rewrite to_runax'. apply idpath. - rewrite <- functor_comp. rewrite to_premor_linear'. rewrite (to_Unel2 DS). rewrite (to_IdIn2 DS). rewrite to_lunax'. rewrite functor_id. rewrite to_premor_linear'. rewrite <- functor_comp. rewrite <- functor_comp. rewrite (to_Unel2 DS). rewrite (to_IdIn2 DS). rewrite (isAdditiveCriteria_preservesUnel _ H). rewrite functor_id. rewrite to_lunax'. apply idpath. Qed. Local Lemma isAdditiveCriteria_BinOp_eq {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) {a1 a2 : A} (f g : A⟦a1, a2⟧) (DS := to_BinDirectSums A a2 a2) : to_binop a1 a2 f g = (to_binop a1 DS (f · (to_In1 DS)) (g · (to_In2 DS))) · (to_binop DS a2 (to_Pr1 DS) (to_Pr2 DS)). Proof. set (isBDS := H a2 a2 DS). set (BDS := make_BinDirectSum _ _ _ _ _ _ _ _ isBDS). (* First term of to_binop *) rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 DS). rewrite (to_Unel2 DS). rewrite id_right. rewrite to_premor_unel'. rewrite to_runax'. (* Second term of to_binop *) rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_Unel1 DS). rewrite (to_IdIn2 DS). rewrite id_right. rewrite to_premor_unel'. rewrite to_lunax'. apply idpath. Qed. (** F commutes with addition of morphisms *) Local Lemma isAdditiveCriteria_BinOp {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) {a1 a2 : A} (f g : A⟦a1, a2⟧) : # F (to_binop a1 a2 f g) = to_binop (F a1) (F a2) (# F f) (# F g). Proof. set (DS := to_BinDirectSums A a2 a2). set (isBDS := H a2 a2 DS). set (BDS := make_BinDirectSum _ _ _ _ _ _ _ _ isBDS). rewrite (isAdditiveCriteria_BinOp_eq F H f g). rewrite functor_comp. rewrite (@isAdditiveCriteria_isBinopFun_Pr A B F H a2 DS). rewrite to_premor_linear'. (* First term of the first to_binop *) rewrite <- functor_comp. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. fold DS. rewrite (to_IdIn1 DS). rewrite (to_Unel2 DS). rewrite id_right. rewrite to_premor_unel'. rewrite to_runax'. (* Second term of the first to_binop *) rewrite <- functor_comp. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn2 DS). rewrite (to_Unel1 DS). rewrite id_right. rewrite to_premor_unel'. rewrite to_lunax'. apply idpath. Qed. Lemma isAdditiveCriteria {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) : isAdditiveFunctor F. Proof. use make_isAdditiveFunctor. intros a1 a2. split. - intros f g. cbn. apply (isAdditiveCriteria_BinOp F H f g). - set (tmp := isAdditiveCriteria_preservesUnel F H a1 a2). unfold to_unel in tmp. apply tmp. Qed. Definition AdditiveFunctorCriteria {A B : CategoryWithAdditiveStructure} (F : functor A B) (H : PreservesBinDirectSums F) : AdditiveFunctor A B. Proof. use make_AdditiveFunctor. - exact F. - exact (isAdditiveCriteria F H). Defined. End additivefunctor_criteria. (** * The functor [QuotcategoryFunctor] is additive *) Section def_additive_quot_functor. Variable A : CategoryWithAdditiveStructure. Variable PAS : PreAdditiveSubabgrs A. Variable PAC : PreAdditiveComps A PAS. Local Lemma QuotcategoryAdditiveFunctor_isAdditiveFunctor : @isAdditiveFunctor A (Quotcategory_Additive A PAS PAC) (QuotcategoryFunctor (Additive_PreAdditive A) PAS PAC). Proof. use make_isAdditiveFunctor. intros X Y. split. - intros f g. apply idpath. - apply idpath. Qed. Definition QuotcategoryAdditiveFunctor : AdditiveFunctor A (Quotcategory_Additive A PAS PAC). Proof. use make_AdditiveFunctor. - exact (QuotcategoryFunctor A PAS PAC). - exact QuotcategoryAdditiveFunctor_isAdditiveFunctor. Defined. End def_additive_quot_functor. (** * Equivalences of additive categories *) Section def_additive_equivalence. Definition AddEquiv (A1 A2 : CategoryWithAdditiveStructure) : UU := ∑ D : (∑ F : (AdditiveFunctor A1 A2 × AdditiveFunctor A2 A1), are_adjoints (dirprod_pr1 F) (dirprod_pr2 F)), (∏ a : A1, is_z_isomorphism (unit_from_left_adjoint (pr2 D) a)) × (∏ b : A2, is_z_isomorphism (counit_from_left_adjoint (pr2 D) b)). Definition make_AddEquiv {A1 A2 : CategoryWithAdditiveStructure} (F : AdditiveFunctor A1 A2) (G : AdditiveFunctor A2 A1) (H : are_adjoints F G) (H1 : ∏ a : A1, is_z_isomorphism (unit_from_left_adjoint H a)) (H2 : ∏ b : A2, is_z_isomorphism (counit_from_left_adjoint H b)) : AddEquiv A1 A2 := (((F,,G),,H),,(H1,,H2)). (** Accessor functions *) Definition AddEquiv1 {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : AdditiveFunctor A1 A2 := dirprod_pr1 (pr1 (pr1 AE)). Definition AddEquiv2 {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : AdditiveFunctor A2 A1 := dirprod_pr2 (pr1 (pr1 AE)). Definition AddEquiv_are_adjoints {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : are_adjoints (AddEquiv1 AE) (AddEquiv2 AE) := pr2 (pr1 AE). Coercion AddEquiv_are_adjoints : AddEquiv >-> are_adjoints. Definition AddEquivUnit {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : nat_trans (functor_identity A1) (functor_composite (AddEquiv1 AE) (AddEquiv2 AE)) := unit_from_left_adjoint AE. Definition AddEquivCounit {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : nat_trans (functor_composite (AddEquiv2 AE) (AddEquiv1 AE)) (functor_identity A2) := counit_from_left_adjoint AE. Definition AddEquivUnitInvMor {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A1) : A1⟦(AddEquiv2 AE (AddEquiv1 AE X)), X⟧ := pr1 ((dirprod_pr1 (pr2 AE)) X). Definition AddEquivUnitInvMor_is_iso_with_inv_data {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A1) : is_z_isomorphism (unit_from_left_adjoint AE X) := ((dirprod_pr1 (pr2 AE)) X). Definition AddEquivUnitInvMor_is_inverse_in_precat {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A1) : is_inverse_in_precat (unit_from_left_adjoint AE X) (AddEquivUnitInvMor AE X) := pr2 ((dirprod_pr1 (pr2 AE)) X). Definition AddEquivCounitInvMor {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A2) : A2⟦X, (AddEquiv1 AE (AddEquiv2 AE X))⟧ := pr1 ((dirprod_pr2 (pr2 AE)) X). Definition AddEquivCounitInvMor_is_iso_with_inv_data {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A2) : is_z_isomorphism (counit_from_left_adjoint AE X) := ((dirprod_pr2 (pr2 AE)) X). Definition AddEquivCounitInvMor_is_inverse_in_precat {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A2) : is_inverse_in_precat (counit_from_left_adjoint AE X) (AddEquivCounitInvMor AE X) := pr2 ((dirprod_pr2 (pr2 AE)) X). Definition AddEquivUnitIso {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A1) : z_iso X (AddEquiv2 AE (AddEquiv1 AE X)). Proof. use make_z_iso. - exact (AddEquivUnit AE X). - exact (AddEquivUnitInvMor AE X). - exact (AddEquivUnitInvMor_is_inverse_in_precat AE X). Defined. Definition AddEquivCounitIso {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (X : A2) : z_iso (AddEquiv1 AE (AddEquiv2 AE X)) X. Proof. use make_z_iso. - exact (AddEquivCounit AE X). - exact (AddEquivCounitInvMor AE X). - exact (AddEquivCounitInvMor_is_inverse_in_precat AE X). Defined. Definition AddEquivLeftTriangle {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : ∏ (a : ob A1), # (AddEquiv1 AE) (AddEquivUnitIso AE a) · AddEquivCounitIso AE (AddEquiv1 AE a) = identity (AddEquiv1 AE a) := triangle_id_left_ad AE. Definition AddEquivRightTriangle {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : ∏ (b : ob A2), (AddEquivUnitIso AE (AddEquiv2 AE b)) · # (AddEquiv2 AE) (AddEquivCounitIso AE b) = identity (AddEquiv2 AE b) := triangle_id_right_ad AE. Definition AddEquivUnitComm {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : ∏ (x x' : ob A1) (f : x --> x'), f · (AddEquivUnitIso AE x') = (AddEquivUnitIso AE x) · # (functor_composite (AddEquiv1 AE) (AddEquiv2 AE)) f := nat_trans_ax (AddEquivUnit AE). Definition AddEquivCounitComm {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) : ∏ (x x' : A2) (f : x --> x'), # (functor_composite (AddEquiv2 AE) (AddEquiv1 AE)) f · (AddEquivCounitIso AE x') = (AddEquivCounitIso AE x) · f := nat_trans_ax (AddEquivCounit AE). Lemma AddEquivUnitMorComm {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x x' : ob A1} (f : x --> x') : f = (AddEquivUnitIso AE x) · (# (functor_composite (AddEquiv1 AE) (AddEquiv2 AE)) f) · (inv_from_z_iso (AddEquivUnitIso AE x')). Proof. use (post_comp_with_z_iso_is_inj (AddEquivUnitIso AE x')). use (pathscomp0 (AddEquivUnitComm AE _ _ f)). rewrite <- assoc. set (tmp := is_inverse_in_precat2 (AddEquivUnitIso AE x')). cbn in tmp. cbn. rewrite tmp. clear tmp. rewrite id_right. apply idpath. Qed. Lemma AddEquivCounitMorComm {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x x' : ob A2} (f : x --> x') : f = (inv_from_z_iso (AddEquivCounitIso AE x)) · (# (functor_composite (AddEquiv2 AE) (AddEquiv1 AE)) f) · (AddEquivCounitIso AE x'). Proof. use (pre_comp_with_z_iso_is_inj (AddEquivCounitIso AE x)). use (pathscomp0 (! AddEquivCounitComm AE _ _ f)). rewrite assoc. rewrite assoc. set (tmp := is_inverse_in_precat1 (AddEquivCounitIso AE x)). rewrite tmp. rewrite id_left. apply idpath. Qed. Definition AddEquivUnitInv {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x x' : ob A1} (f : x --> x') : inv_from_z_iso (AddEquivUnitIso AE x) · f = # (functor_composite (AddEquiv1 AE) (AddEquiv2 AE)) f · inv_from_z_iso (AddEquivUnitIso AE x'). Proof. use (pre_comp_with_z_iso_is_inj (AddEquivUnitIso AE x)). rewrite assoc. rewrite (is_inverse_in_precat1 (AddEquivUnitIso AE x)). rewrite id_left. use (post_comp_with_z_iso_is_inj (AddEquivUnitIso AE x')). rewrite AddEquivUnitComm. rewrite <- assoc. apply cancel_precomposition. cbn. rewrite <- assoc. set (tmp := is_inverse_in_precat2 (AddEquivUnitIso AE x')). cbn in tmp. cbn. rewrite tmp. rewrite id_right. apply idpath. Qed. Definition AddEquivCounitInv {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x x' : ob A2} (f : x --> x') : (inv_from_z_iso (AddEquivCounitIso AE x)) · # (functor_composite (AddEquiv2 AE) (AddEquiv1 AE)) f = f · inv_from_z_iso (AddEquivCounitIso AE x'). Proof. use (pre_comp_with_z_iso_is_inj (AddEquivCounitIso AE x)). rewrite assoc. rewrite (is_inverse_in_precat1 (AddEquivCounitIso AE x)). rewrite id_left. use (post_comp_with_z_iso_is_inj (AddEquivCounitIso AE x')). use (pathscomp0 (AddEquivCounitComm AE _ _ f)). rewrite <- assoc. apply cancel_precomposition. cbn. rewrite <- assoc. set (tmp := is_inverse_in_precat2 (AddEquivCounitIso AE x')). cbn in tmp. cbn. rewrite tmp. rewrite id_right. apply idpath. Qed. Lemma AddEquivCounitUnit {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (x : A1) : inv_from_z_iso (AddEquivCounitIso AE (AddEquiv1 AE x)) = # (AddEquiv1 AE) (AddEquivUnitIso AE x). Proof. use (post_comp_with_z_iso_is_inj (AddEquivCounitIso AE (AddEquiv1 AE x))). apply pathsinv0. rewrite (is_inverse_in_precat2 (AddEquivCounitIso AE ((AddEquiv1 AE) x))). exact (AddEquivLeftTriangle AE x). Qed. Lemma AddEquivCounitUnit' {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (x : A1) : ((AddEquivCounitIso AE (AddEquiv1 AE x)) : A2⟦_, _⟧) = # (AddEquiv1 AE) (inv_from_z_iso (AddEquivUnitIso AE x)). Proof. use (post_comp_with_z_iso_inv_is_inj (AddEquivCounitIso AE (AddEquiv1 AE x))). apply pathsinv0. rewrite (is_inverse_in_precat1 (AddEquivCounitIso AE ((AddEquiv1 AE) x))). rewrite AddEquivCounitUnit. rewrite <- functor_comp. rewrite (is_inverse_in_precat2 (AddEquivUnitIso AE x)). apply functor_id. Qed. Lemma AddEquivUnitCounit {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (x : A2) : inv_from_z_iso (AddEquivUnitIso AE (AddEquiv2 AE x)) = # (AddEquiv2 AE) (AddEquivCounitIso AE x). Proof. use (pre_comp_with_z_iso_is_inj (AddEquivUnitIso AE (AddEquiv2 AE x))). apply pathsinv0. rewrite (is_inverse_in_precat1 (AddEquivUnitIso AE ((AddEquiv2 AE) x))). exact (AddEquivRightTriangle AE x). Qed. Lemma AddEquivUnitCounit' {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) (x : A2) : ((AddEquivUnitIso AE (AddEquiv2 AE x)) : A1⟦_, _⟧) = # (AddEquiv2 AE) (inv_from_z_iso (AddEquivCounitIso AE x)). Proof. use (pre_comp_with_z_iso_inv_is_inj (AddEquivUnitIso AE (AddEquiv2 AE x))). apply pathsinv0. rewrite (is_inverse_in_precat2 (AddEquivUnitIso AE ((AddEquiv2 AE) x))). rewrite AddEquivUnitCounit. rewrite <- functor_comp. rewrite (is_inverse_in_precat1 (AddEquivCounitIso AE x)). apply functor_id. Qed. Lemma AddEquiv1Inj {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x y : A1} (f g : x --> y) (H : # (AddEquiv1 AE) f = # (AddEquiv1 AE) g) : f = g. Proof. apply (maponpaths (# (AddEquiv2 AE))) in H. use (post_comp_with_z_iso_is_inj (AddEquivUnitIso AE y)). use (pathscomp0 (AddEquivUnitComm AE _ _ f)). use (pathscomp0 _ (! (AddEquivUnitComm AE _ _ g))). exact (maponpaths (λ gg : _, (AddEquivUnit AE) x · gg) H). Qed. Lemma AddEquiv2Inj {A1 A2 : CategoryWithAdditiveStructure} (AE : AddEquiv A1 A2) {x y : A2} (f g : x --> y) (H : # (AddEquiv2 AE) f = # (AddEquiv2 AE) g) : f = g. Proof. apply (maponpaths (# (AddEquiv1 AE))) in H. use (pre_comp_with_z_iso_is_inj (AddEquivCounitIso AE x)). use (pathscomp0 (! AddEquivCounitComm AE _ _ f)). use (pathscomp0 _ (AddEquivCounitComm AE _ _ g)). exact (maponpaths (λ gg : _, gg · (AddEquivCounit AE) y) H). Qed. End def_additive_equivalence. UniMath-20231010/UniMath/CategoryTheory/Adjunctions/000077500000000000000000000000001451125700300221055ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Adjunctions/Core.v000066400000000000000000001224731451125700300231750ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 Extended by: Anders Mörtberg, 2016 ************************************************************) (** ********************************************************** Contents : - Definition of adjunction - Construction of an adjunction from some partial data (Theorem 2 (iv) of Chapter IV.1 of MacLane) - Post-composition with a left adjoint is a left adjoint ([is_left_adjoint_post_composition_functor]) - Lemmas about adjunctions ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.SplitMonicsAndEpis. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. (** * Adjunctions *) Section adjunctions. Definition adjunction_data (A B : category) : UU := ∑ (F : functor A B) (G : functor B A), nat_trans (functor_identity A) (F ∙ G) × nat_trans (G ∙ F) (functor_identity B). Definition make_adjunction_data {A B : category} (F : functor A B) (G : functor B A) (η : functor_identity _ ⟹ (F ∙ G)) (ε : (G ∙ F) ⟹ functor_identity _) : adjunction_data A B := (F ,, G ,, (η ,, ε)). Definition left_functor {A B} (X : adjunction_data A B) : functor A B := pr1 X. Definition right_functor {A B} (X : adjunction_data A B) : functor B A := pr1 (pr2 X). Definition adjunit {A B} (X : adjunction_data A B) : nat_trans (functor_identity _) (_ ∙ _) := pr1 (pr2 (pr2 X)). Definition adjcounit {A B} (X : adjunction_data A B) : nat_trans (_ ∙ _ ) (functor_identity _) := pr2 (pr2 (pr2 X)). Definition triangle_1_statement {A B : category} (X : adjunction_data A B) (F := left_functor X) (η := adjunit X) (ε := adjcounit X) : UU := ∏ a : A, # F (η a) · ε (F a) = identity (F a). Definition triangle_2_statement {A B : category} (X : adjunction_data A B) (G := right_functor X) (η := adjunit X) (ε := adjcounit X) : UU := ∏ b : B, η (G b) · # G (ε b) = identity (G b). Definition form_adjunction' {A B} (X : adjunction_data A B) : UU := triangle_1_statement X × triangle_2_statement X. Definition form_adjunction {A B : category} (F : functor A B) (G : functor B A) (eta : nat_trans (functor_identity A) (functor_composite F G)) (eps : nat_trans (functor_composite G F) (functor_identity B)) : UU := form_adjunction' (F,,G,,eta,,eps). Lemma isaprop_form_adjunction {A B : category} (F : functor A B) (G : functor B A) (eta : nat_trans (functor_identity A) (functor_composite F G)) (eps : nat_trans (functor_composite G F) (functor_identity B)) : isaprop (form_adjunction F G eta eps). Proof. apply isapropdirprod; apply impred_isaprop; intro. - apply B. - apply A. Defined. Definition make_form_adjunction {A B : category} {F : functor A B} {G : functor B A} {eta : nat_trans (functor_identity A) (functor_composite F G)} {eps : nat_trans (functor_composite G F) (functor_identity B)} (H1 : ∏ a : A, # F (eta a) · eps (F a) = identity (F a)) (H2 : ∏ b : B, eta (G b) · # G (eps b) = identity (G b)) : form_adjunction F G eta eps := (H1,,H2). Definition are_adjoints {A B : category} (F : functor A B) (G : functor B A) : UU := ∑ (etaeps : (nat_trans (functor_identity A) (functor_composite F G)) × (nat_trans (functor_composite G F) (functor_identity B))), form_adjunction F G (pr1 etaeps) (pr2 etaeps). Definition make_are_adjoints {A B : category} (F : functor A B) (G : functor B A) (eta : nat_trans (functor_identity A) (functor_composite F G)) (eps : nat_trans (functor_composite G F) (functor_identity B)) (HH : form_adjunction F G eta eps) : are_adjoints F G. Proof. exists (eta,,eps). exact HH. Defined. Definition adjunction (A B : category) : UU := ∑ X : adjunction_data A B, form_adjunction' X. Coercion data_from_adjunction {A B} (X : adjunction A B) : adjunction_data _ _ := pr1 X. Definition make_adjunction {A B : category} (adjData : adjunction_data A B) (adjProp : form_adjunction' adjData) : adjunction A B := (adjData ,, adjProp). Definition form_adjunction_from_adjunction {A B : category} (adj : adjunction A B) : form_adjunction' adj := pr2 adj. Definition triangle_1_statement_from_adjunction {A B : category} (adj : adjunction A B) : triangle_1_statement adj := pr1 (pr2 adj). Definition triangle_2_statement_from_adjunction {A B : category} (adj : adjunction A B) : triangle_2_statement adj := pr2 (pr2 adj). Coercion are_adjoints_from_adjunction {A B} (X : adjunction A B) : are_adjoints (left_functor X) (right_functor X). Proof. use make_are_adjoints. - exact(adjunit X). - exact(adjcounit X). - exact(form_adjunction_from_adjunction X). Defined. Definition unit_from_are_adjoints {A B : category} {F : functor A B} {G : functor B A} (H : are_adjoints F G) : nat_trans (functor_identity A) (functor_composite F G) := pr1 (pr1 H). Definition counit_from_are_adjoints {A B : category} {F : functor A B} {G : functor B A} (H : are_adjoints F G) : nat_trans (functor_composite G F) (functor_identity B) := pr2 (pr1 H). Definition is_left_adjoint {A B : category} (F : functor A B) : UU := ∑ (G : functor B A), are_adjoints F G. Coercion adjunction_data_from_is_left_adjoint {A B : category} {F : functor A B} (HF : is_left_adjoint F) : adjunction_data A B := (F,, _ ,,unit_from_are_adjoints (pr2 HF) ,,counit_from_are_adjoints (pr2 HF) ). Definition is_right_adjoint {A B : category} (G : functor B A) : UU := ∑ (F : functor A B), are_adjoints F G. Definition are_adjoints_to_is_left_adjoint {A B : category} (F : functor A B) (G : functor B A) (H : are_adjoints F G) : is_left_adjoint F := (G,,H). Coercion are_adjoints_to_is_left_adjoint : are_adjoints >-> is_left_adjoint. Definition are_adjoints_to_is_right_adjoint {A B : category} (F : functor A B) (G : functor B A) (H : are_adjoints F G) : is_right_adjoint G := (F,,H). Coercion are_adjoints_to_is_right_adjoint : are_adjoints >-> is_right_adjoint. Definition right_adjoint {A B : category} {F : functor A B} (H : is_left_adjoint F) : functor B A := pr1 H. Lemma is_right_adjoint_right_adjoint {A B : category} {F : functor A B} (H : is_left_adjoint F) : is_right_adjoint (right_adjoint H). Proof. exact (F,,pr2 H). Defined. Definition left_adjoint {A B : category} {G : functor B A} (H : is_right_adjoint G) : functor A B := pr1 H. Lemma is_left_adjoint_left_adjoint {A B : category} {G : functor B A} (H : is_right_adjoint G) : is_left_adjoint (left_adjoint H). Proof. exact (G,,pr2 H). Defined. Definition unit_from_left_adjoint {A B : category} {F : functor A B} (H : is_left_adjoint F) : nat_trans (functor_identity A) (functor_composite F (right_adjoint H)) := adjunit H. (* makes use of the coercion above *) Definition unit_from_right_adjoint {A B : category} {G : functor B A} (H : is_right_adjoint G) : nat_trans (functor_identity A) (functor_composite (left_adjoint H) G) := unit_from_are_adjoints (pr2 H). Definition counit_from_left_adjoint {A B : category} {F : functor A B} (H : is_left_adjoint F) : nat_trans (functor_composite (right_adjoint H) F) (functor_identity B) := counit_from_are_adjoints (pr2 H). Definition counit_from_right_adjoint {A B : category} {G : functor B A} (H : is_right_adjoint G) : nat_trans (functor_composite G (left_adjoint H)) (functor_identity B) := counit_from_are_adjoints (pr2 H). Definition triangle_id_left_ad {A B : category} {F : functor A B} {G : functor B A} (H : are_adjoints F G) : ∏ a, # F (unit_from_are_adjoints H a) · counit_from_are_adjoints H (F a) = identity (F a) := pr1 (pr2 H). Definition triangle_id_right_ad {A B : category} {F : functor A B} {G : functor B A} (H : are_adjoints F G) : ∏ b, unit_from_are_adjoints H (G b) · # G (counit_from_are_adjoints H b) = identity (G b) := pr2 (pr2 H). Lemma are_adjoints_functor_composite {A B C : category} {F1 : functor A B} {F2 : functor B C} {G1 : functor B A} {G2 : functor C B} (H1 : are_adjoints F1 G1) (H2 : are_adjoints F2 G2) : are_adjoints (functor_composite F1 F2) (functor_composite G2 G1). Proof. destruct H1 as [[eta1 eps1] [H11 H12]]. destruct H2 as [[eta2 eps2] [H21 H22]]. simpl in *. use make_are_adjoints. - apply (nat_trans_comp _ _ _ eta1). use (nat_trans_comp _ _ _ _ (nat_trans_functor_assoc_inv _ _ _)). apply pre_whisker. apply (nat_trans_comp _ _ _ (nat_trans_functor_id_right_inv _) (post_whisker eta2 G1)). - use (nat_trans_comp _ _ _ _ eps2). apply (nat_trans_comp _ _ _ (nat_trans_functor_assoc _ _ _)). apply pre_whisker. apply (nat_trans_comp _ _ _ (nat_trans_functor_assoc_inv _ _ _)). apply (nat_trans_comp _ _ _ (post_whisker eps1 _) (nat_trans_functor_id_left _)). - split; intros a; simpl. + rewrite !id_left, !id_right, <-functor_id, <- H11, !functor_comp, <-!assoc. apply maponpaths; rewrite assoc. etrans; [eapply cancel_postcomposition, pathsinv0, functor_comp|]. etrans. apply cancel_postcomposition, maponpaths. apply (nat_trans_ax eps1 (F1 a) (G2 (F2 (F1 a))) (eta2 (F1 a))). simpl; rewrite functor_comp, <- assoc. etrans; [eapply maponpaths, H21|]. now apply id_right. + rewrite !id_left, !id_right, <- functor_id, <- H22, !functor_comp, assoc. apply cancel_postcomposition; rewrite <- assoc. etrans; [eapply maponpaths, pathsinv0, functor_comp|]. etrans. eapply maponpaths, maponpaths, pathsinv0. apply (nat_trans_ax eta2 (F1 (G1 (G2 a))) (G2 a) (eps1 _)). simpl; rewrite functor_comp, assoc. etrans; [apply cancel_postcomposition, H12|]. now apply id_left. Defined. Lemma is_left_adjoint_functor_composite {A B C : category} {F1 : functor A B} {F2 : functor B C} (H1 : is_left_adjoint F1) (H2 : is_left_adjoint F2) : is_left_adjoint (functor_composite F1 F2). Proof. use tpair. - apply (functor_composite (pr1 H2) (pr1 H1)). - apply are_adjoints_functor_composite. + apply (pr2 H1). + apply (pr2 H2). Defined. Lemma are_adjoints_closed_under_iso_data {A B : category} (F G : functor A B) (H : functor B A) (αiso : @z_iso [A,B] F G) (HF : are_adjoints F H) : adjunction_data A B. Proof. set (α := pr1 αiso : nat_trans F G). set (αinv := inv_from_z_iso αiso : nat_trans G F). destruct HF as [[α' β'] [HF1 HF2]]. exists G. exists H. split. - apply (nat_trans_comp _ _ _ α' (post_whisker α H)). - apply (nat_trans_comp _ _ _ (pre_whisker H αinv) β'). Defined. Lemma are_adjoints_closed_under_iso_laws {A B : category} (F G : functor A B) (H : functor B A) (αiso : @z_iso [A,B] F G) (HF : are_adjoints F H) : form_adjunction' (are_adjoints_closed_under_iso_data F G H αiso HF). Proof. set (α := pr1 αiso : nat_trans F G). set (αinv := inv_from_z_iso αiso : nat_trans G F). destruct HF as [[α' β'] [HF1 HF2]]; simpl in HF1, HF2. split. - unfold triangle_1_statement. simpl; intro a; rewrite assoc, functor_comp. etrans; [ apply cancel_postcomposition; rewrite <- assoc; apply maponpaths, (nat_trans_ax αinv)|]. etrans; [ rewrite assoc, <- !assoc; apply maponpaths, maponpaths, (nat_trans_ax β')|]. simpl; rewrite assoc. etrans; [ apply cancel_postcomposition, (nat_trans_ax αinv)|]. rewrite assoc. etrans; [ apply cancel_postcomposition; rewrite <- assoc; apply maponpaths, HF1|]. now rewrite id_right; apply (nat_trans_eq_pointwise (z_iso_after_z_iso_inv αiso)). - unfold triangle_2_statement in *. simpl; intro b; rewrite functor_comp, assoc. etrans; [ apply cancel_postcomposition; rewrite <- assoc; eapply maponpaths, pathsinv0, functor_comp|]. etrans; [ apply cancel_postcomposition, maponpaths, maponpaths, (nat_trans_eq_pointwise (z_iso_inv_after_z_iso αiso))|]. cbn. rewrite (functor_id H), id_right. apply (HF2 b). Qed. Lemma are_adjoints_closed_under_iso {A B : category} (F G : functor A B) (H : functor B A) (αiso : @z_iso [A,B] F G) (HF : are_adjoints F H) : are_adjoints G H. Proof. set (adj_data := are_adjoints_closed_under_iso_data F G H αiso HF). use make_are_adjoints. - exact (adjunit adj_data). - exact (adjcounit adj_data). - apply are_adjoints_closed_under_iso_laws. Defined. Corollary is_left_adjoint_closed_under_iso {A B : category} (F G : functor A B) (αiso : @z_iso [A,B] F G) (HF : is_left_adjoint F) : is_left_adjoint G. Proof. destruct HF as [F' Hisadj]. exact (F',,are_adjoints_closed_under_iso F G F' αiso Hisadj). Defined. (** * Identity functor is a left adjoint *) Lemma is_left_adjoint_functor_identity {A : category} : is_left_adjoint (functor_identity A). Proof. use tpair. + exact (functor_identity A). + exists (nat_trans_id _,, nat_trans_id _). abstract (now split; [intros a; apply id_left| intros a; apply id_left]). Defined. (** * Construction of an adjunction from some partial data (Theorem 2 (iv) of Chapter IV.1 of MacLane) *) Section right_adjoint_from_partial. Definition is_universal_arrow_from {D C : category} (S : functor D C) (c : C) (r : D) (v : C⟦S r, c⟧) : UU := ∏ (d : D) (f : C⟦S d,c⟧), ∃! (f' : D⟦d,r⟧), f = # S f' · v. Context {X A : category} (F : functor X A) (G0 : ob A -> ob X) (eps : ∏ a, A⟦F (G0 a),a⟧) (Huniv : ∏ a, is_universal_arrow_from F a (G0 a) (eps a)). Local Definition G_data : functor_data A X. Proof. use tpair. + apply G0. + intros a b f. apply (pr1 (pr1 (Huniv b (G0 a) (eps a · f)))). Defined. Local Definition G_is_functor : is_functor G_data. Proof. split. + intro a; simpl. assert (H : eps a · identity a = # F (identity (G0 a)) · eps a). { now rewrite functor_id, id_left, id_right. } set (H2 := Huniv a (G0 a) (eps a · identity a)). apply (pathsinv0 (maponpaths pr1 (pr2 H2 (_,,H)))). + intros a b c f g; simpl. set (H2 := Huniv c (G0 a) (eps a · (f · g))). destruct H2 as [[fac Hfac] p]; simpl. set (H1 := Huniv b (G0 a) (eps a · f)). destruct H1 as [[fab Hfab] p1]; simpl. set (H0 := Huniv c (G0 b) (eps b · g)). destruct H0 as [[fbc Hfbc] p2]; simpl. assert (H : eps a · (f · g) = # F (fab · fbc) · eps c). { now rewrite assoc, Hfab, <- assoc, Hfbc, assoc, <- functor_comp. } apply (pathsinv0 (maponpaths pr1 (p (_,,H)))). Qed. Local Definition G : functor A X := tpair _ G_data G_is_functor. Local Definition unit : nat_trans (functor_identity X) (functor_composite F G). Proof. use make_nat_trans. * intro x. apply (pr1 (pr1 (Huniv (F x) x (identity _)))). * intros x y f; simpl. destruct (Huniv (F y) y (identity (F y))) as [t p], t as [t p0]; simpl. destruct (Huniv (F x) x (identity (F x))) as [t0 p1], t0 as [t0 p2]; simpl. destruct (Huniv (F y) (G0 (F x)) (eps (F x) · # F f)) as [t1 p3], t1 as [t1 p4]; simpl. assert (H1 : # F f = # F (t0 · t1) · eps (F y)); [now rewrite functor_comp, <- assoc, <- p4, assoc, <- p2, id_left|]; destruct (Huniv (F y) x (# F f)) as [t2 p5]; set (HH := (maponpaths pr1 (p5 (_,,H1)))); simpl in HH; rewrite HH. assert (H2 : # F f = # F (f · t) · eps (F y)); [now rewrite functor_comp, <- assoc, <- p0, id_right|]; set (HHH := (maponpaths pr1 (p5 (_,,H2)))); simpl in HHH; now rewrite HHH. Defined. Local Definition counit : nat_trans (functor_composite G F) (functor_identity A). Proof. use tpair. * red. apply eps. * abstract (intros a b f; simpl; apply (pathsinv0 (pr2 (pr1 (Huniv b (G0 a) (eps a · f)))))). Defined. Local Lemma form_adjunctionFG : form_adjunction F G unit counit. Proof. use tpair; simpl. + unfold triangle_1_statement; cbn. intros x. destruct (Huniv (F x) x (identity (F x))) as [[f hf] H]; simpl. apply (!hf). + intros a; simpl. destruct (Huniv (F (G0 a)) (G0 a) (identity (F (G0 a)))) as [[f hf] H]; simpl. destruct ((Huniv a (G0 (F (G0 a))) (eps (F (G0 a)) · eps a))) as [[g hg] Hg]; simpl. destruct (Huniv _ _ (eps a)) as [t p]. assert (H1 : eps a = # F (identity _) · eps a). now rewrite functor_id, id_left. assert (H2 : eps a = # F (f · g) · eps a). now rewrite functor_comp, <- assoc, <- hg, assoc, <- hf, id_left. set (HH := maponpaths pr1 (p (_,,H1))); simpl in HH. set (HHH := maponpaths pr1 (p (_,,H2))); simpl in HHH. now rewrite HHH, <- HH. Qed. Definition left_adjoint_from_partial : is_left_adjoint F := (G,, (unit,, counit),, form_adjunctionFG). Definition right_adjoint_from_partial : is_right_adjoint G := (F,, (unit,, counit),, form_adjunctionFG). End right_adjoint_from_partial. (** * Construction of an adjunction from some partial data (Theorem 2 (ii) of Chapter IV.1 of MacLane) *) Section left_adjoint_from_partial. Definition is_universal_arrow_to {D C : precategory} (S : functor D C) (c : C) (r : D) (v : C⟦c, S r⟧) : UU := ∏ (d : D) (f : C⟦c, S d⟧), ∃! (f' : D⟦r,d⟧), v · #S f' = f. Context {X A : category} (G : functor A X) (F0 : ob X -> ob A) (eta : ∏ x, X⟦x, G (F0 x)⟧) (Huniv : ∏ x, is_universal_arrow_to G x (F0 x) (eta x)). Local Definition F_data : functor_data X A. Proof. use tpair. + apply F0. + intros a b f. use (pr1 (pr1 (Huniv _ _ _ ))). apply (f · eta _ ). (* apply (pr1 (pr1 (Huniv b (G0 a) (eps a · f)))). *) Defined. Local Definition F_is_functor : is_functor F_data. Proof. split. + intro x; simpl. apply pathsinv0, path_to_ctr. rewrite functor_id, id_left, id_right; apply idpath. + intros a b c f g; simpl. apply pathsinv0, path_to_ctr. rewrite functor_comp, assoc. set (H2 := Huniv _ _ (f · eta _ )). rewrite (pr2 (pr1 H2)). do 2 rewrite <- assoc; apply maponpaths. set (H3 := Huniv _ _ (g · eta _ )). apply (pr2 (pr1 H3)). Defined. Local Definition left_adj_from_partial : functor X A := F_data,, F_is_functor. Local Notation F := left_adj_from_partial. Local Definition counit_left_from_partial : functor_composite G F ⟹ functor_identity A. Proof. use make_nat_trans. - intro a. apply (pr1 (pr1 (Huniv _ _ (identity _)))). - intros a b f; simpl. destruct (Huniv _ _ (identity (G b))) as [t p], t as [t p0]; simpl. destruct (Huniv _ _ (identity (G a))) as [t0 p1], t0 as [t0 p2]; simpl. destruct (Huniv _ _ (#G f · eta _ )) as [t1 p3], t1 as [t1 p4]; simpl. assert (H1 : # G f = eta _ · # G (t1 · t) ). { rewrite functor_comp. rewrite assoc. rewrite p4. rewrite <- assoc. rewrite p0. rewrite id_right; apply idpath. } destruct (Huniv _ _ (# G f)) as [t2 p5]. set (HH := (maponpaths pr1 (p5 (_,,!H1)))); simpl in HH; rewrite HH. assert (H2 : #G f = eta _ · #G (t0 · f)). { rewrite functor_comp. rewrite assoc. rewrite p2. rewrite id_left; apply idpath. } set (HHH := (maponpaths pr1 (p5 (_,,!H2)))); simpl in HHH; now rewrite HHH. Defined. Local Definition unit_left_from_partial : functor_identity X ⟹ functor_composite F G. Proof. use tpair. * red. apply eta. * abstract (intros a b f; simpl; apply (pathsinv0 (pr2 (pr1 (Huniv _ _ (f · eta _ )))))). Defined. Local Lemma form_adjunctionFG_left_from_partial : form_adjunction F G unit_left_from_partial counit_left_from_partial. Proof. use tpair; simpl. + unfold triangle_1_statement; cbn. intros x; simpl. destruct (Huniv _ _ (identity (G (F0 x)))) as [[f hf] H]; simpl. destruct ((Huniv _ _ (*eps (F (G0 a)) · eps a*) (eta _ · eta (G (F0 x))))) as [[g hg] Hg]; simpl. destruct (Huniv _ _ (eta x)) as [t p]. assert (H1 : eta x = eta x · # G (identity _)). { now rewrite functor_id, id_right. } assert (H2 : eta x = eta x · # G (g · f) ). { rewrite functor_comp. rewrite assoc. rewrite hg. rewrite <- assoc. rewrite hf. now rewrite id_right. } set (HH := maponpaths pr1 (p (_,,!H1))); simpl in HH. set (HHH := maponpaths pr1 (p (_,,!H2))); simpl in HHH. now rewrite HHH, <- HH. + unfold triangle_2_statement; cbn. intro a. destruct (Huniv _ _ (identity (G a))) as [[f hf] H]; simpl. apply hf. Defined. Definition right_adjoint_left_from_partial : is_right_adjoint G := (F,, (unit_left_from_partial,, counit_left_from_partial),, form_adjunctionFG_left_from_partial). Definition left_adjoint_left_from_partial : is_left_adjoint F := (G,, (unit_left_from_partial,, _),, form_adjunctionFG_left_from_partial). End left_adjoint_from_partial. (** * Post-composition with a left adjoint is a left adjoint *) Section postcomp. Context {C D E : category} (F : functor D E) (HF : is_left_adjoint F). Let G : functor E D := right_adjoint HF. Let H : are_adjoints F G := pr2 HF. Let η : nat_trans (functor_identity D) (functor_composite F G):= unit_from_left_adjoint H. Let ε : nat_trans (functor_composite G F) (functor_identity E) := counit_from_left_adjoint H. Let H1 : ∏ a : D, # F (η a) · ε (F a) = identity (F a) := triangle_id_left_ad H. Let H2 : ∏ b : E, η (G b) · # G (ε b) = identity (G b) := triangle_id_right_ad H. Lemma is_left_adjoint_post_composition_functor : is_left_adjoint (post_composition_functor C D E F). Proof. exists (post_composition_functor _ _ _ G). use tpair. - split. + use make_nat_trans. * simpl; intros F'. simpl in F'. apply (nat_trans_comp _ _ _ (nat_trans_comp _ _ _ (nat_trans_functor_id_right_inv F') (pre_whisker F' η)) (nat_trans_functor_assoc_inv _ _ _)). * abstract (intros F1 F2 α; apply (nat_trans_eq D); intro c; simpl in *; now rewrite !id_right, !id_left; apply (nat_trans_ax η (F1 c) _ (α c))). + use make_nat_trans. * simpl; intros F'. simpl in F'. apply (nat_trans_comp _ _ _ (nat_trans_functor_assoc _ _ _) (nat_trans_comp _ _ _ (pre_whisker F' ε) (nat_trans_functor_id_left _))). * abstract (intros F1 F2 α; apply (nat_trans_eq E); intro c; simpl in *; now rewrite !id_right, !id_left; apply (nat_trans_ax ε _ _ (α c))). - abstract (split; simpl; intro F'; [ apply (nat_trans_eq E); simpl; intro c; now rewrite !id_left, !id_right; apply H1 | apply (nat_trans_eq D); simpl; intro c; now rewrite !id_left, !id_right; apply H2]). Defined. End postcomp. (** * Post-composition with a right adjoint is a right adjoint *) Section postcomp_right. Context {C D E : category} (F : functor D E) (HF : is_right_adjoint F). Let G : functor E D := left_adjoint HF. Let H : are_adjoints G F := pr2 HF. Let ε : nat_trans (functor_composite F G) (functor_identity D) := counit_from_left_adjoint H. Let η : nat_trans (functor_identity E) (functor_composite G F) := unit_from_left_adjoint H. Let H1 : ∏ d : D, _ = identity (F d) := triangle_id_right_ad H. Let H2 : ∏ e : E, _ = identity (G e) := triangle_id_left_ad H. Lemma is_right_adjoint_post_composition_functor : is_right_adjoint (post_composition_functor C D E F). Proof. exists (post_composition_functor _ _ _ G). use tpair. - split. + use make_nat_trans. * simpl; intros F'. simpl in F'. apply (nat_trans_comp _ _ _ (nat_trans_comp _ _ _ (nat_trans_functor_id_right_inv F') (pre_whisker F' η)) (nat_trans_functor_assoc_inv _ _ _)). * abstract (intros F1 F2 α; apply (nat_trans_eq E); intro c; simpl in *; now rewrite !id_right, !id_left; apply (nat_trans_ax η (F1 c) _ (α c))). + use make_nat_trans. * simpl; intros F'. simpl in F'. apply (nat_trans_comp _ _ _ (nat_trans_functor_assoc _ _ _) (nat_trans_comp _ _ _ (pre_whisker F' ε) (nat_trans_functor_id_left _))). * abstract (intros F1 F2 α; apply (nat_trans_eq D); intro c; simpl in *; now rewrite !id_right, !id_left; apply (nat_trans_ax ε _ _ (α c))). - abstract (split; simpl; intro F'; [ apply (nat_trans_eq D); simpl; intro c; now rewrite !id_right, !id_left; apply H2 | apply (nat_trans_eq E); simpl; intro c; now rewrite !id_left, !id_right; apply H1]). Defined. End postcomp_right. End adjunctions. Section HomSetIso_from_Adjunction. Context {C D : category} {F : functor C D} {G : functor D C} (H : are_adjoints F G). Let η := unit_from_are_adjoints H. Let ε := counit_from_are_adjoints H. (** * Definition of the maps on hom-types *) Definition φ_adj {A : C} {B : D} : F A --> B → A --> G B := λ f : F A --> B, η _ · #G f. Definition φ_adj_inv {A : C} {B : D} : A --> G B → F A --> B := λ g : A --> G B, #F g · ε _ . (** * Proof that those maps are inverse to each other *) Lemma φ_adj_after_φ_adj_inv {A : C} {B : D} (g : A --> G B) : φ_adj (φ_adj_inv g) = g. Proof. unfold φ_adj. unfold φ_adj_inv. assert (X':=triangle_id_right_ad H). rewrite functor_comp. rewrite assoc. assert (X2 := nat_trans_ax η). simpl in X2. rewrite <- X2; clear X2. rewrite <- assoc. intermediate_path (g · identity _). - apply maponpaths. apply X'. - apply id_right. Qed. Lemma φ_adj_inv_after_φ_adj {A : C} {B : D} (f : F A --> B) : φ_adj_inv (φ_adj f) = f. Proof. unfold φ_adj, φ_adj_inv. rewrite functor_comp. assert (X2 := nat_trans_ax ε); simpl in *. rewrite <- assoc. rewrite X2; clear X2. rewrite assoc. intermediate_path (identity _ · f). - apply cancel_postcomposition. apply triangle_id_left_ad. - apply id_left. Qed. Lemma φ_adj_identity (A : C) : φ_adj (identity (F A)) = η _ . Proof. unfold φ_adj. rewrite functor_id. apply id_right. Qed. Lemma φ_adj_inv_unit (A : C) : φ_adj_inv (η A) = identity _ . Proof. apply triangle_id_left_ad. Qed. Definition adjunction_hom_weq (A : C) (B : D) : F A --> B ≃ A --> G B. Proof. exists φ_adj. apply (isweq_iso _ φ_adj_inv). - apply φ_adj_inv_after_φ_adj. - apply φ_adj_after_φ_adj_inv. Defined. (** * Proof of the equations (naturality squares) of the adjunction *) Lemma φ_adj_natural_precomp (A : C) (B : D) (f : F A --> B) (X : C) (h : X --> A) : φ_adj (#F h · f) = h · φ_adj f. Proof. unfold φ_adj. rewrite functor_comp. set (T:=nat_trans_ax η); simpl in T. rewrite assoc. rewrite <- T. apply pathsinv0, assoc. Qed. Lemma φ_adj_natural_postcomp (A : C) (B : D) (f : F A --> B) (Y : D) (k : B --> Y) : φ_adj (f · k) = φ_adj f · #G k. Proof. unfold φ_adj. rewrite <- assoc. apply maponpaths. apply (functor_comp G). Qed. Corollary φ_adj_natural_prepostcomp (A X : C) (B Y : D) (f : F A --> B) (h : X --> A) (k : B --> Y) : φ_adj (#F h · f · k) = h · φ_adj f · #G k. Proof. etrans. rewrite <- assoc. apply φ_adj_natural_precomp. rewrite <- assoc. apply maponpaths. apply φ_adj_natural_postcomp. Qed. Lemma φ_adj_inv_natural_precomp (A : C) (B : D) (g : A --> G B) (X : C) (h : X --> A) : φ_adj_inv (h · g) = #F h · φ_adj_inv g. Proof. unfold φ_adj_inv. rewrite functor_comp. apply pathsinv0, assoc. Qed. Lemma φ_adj_inv_natural_postcomp (A : C) (B : D) (g : A --> G B) (Y : D) (k : B --> Y) : φ_adj_inv (g · #G k) = φ_adj_inv g · k. Proof. unfold φ_adj_inv. rewrite functor_comp. set (T:=nat_trans_ax ε); simpl in T. rewrite <- assoc. rewrite T. apply assoc. Qed. Corollary φ_adj_inv_natural_prepostcomp (A X : C) (B Y : D) (g : A --> G B) (h : X --> A) (k : B --> Y) : φ_adj_inv (h · g · #G k) = #F h · φ_adj_inv g · k. Proof. etrans. apply φ_adj_inv_natural_postcomp. apply cancel_postcomposition. apply φ_adj_inv_natural_precomp. Qed. End HomSetIso_from_Adjunction. (** * Adjunction defined from a natural isomorphism on homsets (F A --> B) ≃ (A --> G B) *) Definition natural_hom_weq {C D : precategory} (F : functor C D) (G : functor D C) : UU := ∑ (hom_weq : ∏ {A : C} {B : D}, F A --> B ≃ A --> G B), (∏ (A : C) (B : D) (f : F A --> B) (X : C) (h : X --> A), hom_weq (#F h · f) = h · hom_weq f) × (∏ (A : C) (B : D) (f : F A --> B) (Y : D) (k : B --> Y), hom_weq (f · k) = hom_weq f · #G k). Definition hom_weq {C D : precategory} {F : functor C D} {G : functor D C} (H : natural_hom_weq F G) : ∏ {A : C} {B : D}, F A --> B ≃ A --> G B := pr1 H. Definition hom_natural_precomp {C D : precategory} {F : functor C D} {G : functor D C} (H : natural_hom_weq F G) : ∏ (A : C) (B : D) (f : F A --> B) (X : C) (h : X --> A), hom_weq H (#F h · f) = h · hom_weq H f := pr1 (pr2 H). Definition hom_natural_postcomp {C D : precategory} {F : functor C D} { G : functor D C} (H : natural_hom_weq F G) : ∏ (A : C) (B : D) (f : F A --> B) (Y : D) (k : B --> Y), hom_weq H (f · k) = hom_weq H f · #G k := pr2 (pr2 H). Section Adjunction_from_HomSetIso. Context {C D : category} {F : functor C D} {G : functor D C} (H : natural_hom_weq F G). Local Definition hom_inv : ∏ {A : C} {B : D}, A --> G B → F A --> B := λ A B, invmap (hom_weq H). Definition inv_natural_precomp {A : C} {B : D} (g : A --> G B) {X : C} (h : X --> A) : hom_inv (h · g) = #F h · hom_inv g. Proof. apply pathsinv0, pathsweq1. rewrite hom_natural_precomp. apply cancel_precomposition. apply homotweqinvweq. Defined. Definition inv_natural_postcomp {A : C} {B : D} (g : A --> G B) {Y : D} (k : B --> Y) : hom_inv (g · #G k) = hom_inv g · k. Proof. apply pathsinv0, pathsweq1. rewrite hom_natural_postcomp. apply cancel_postcomposition. apply homotweqinvweq. Defined. Definition unit_from_hom : nat_trans (functor_identity C) (F ∙ G). Proof. use make_nat_trans. - exact (λ A, (hom_weq H (identity (F A)))). - intros A A' h. cbn. rewrite <- hom_natural_precomp. rewrite <- hom_natural_postcomp. apply maponpaths. rewrite id_left. apply id_right. Defined. Definition counit_from_hom : nat_trans (G ∙ F) (functor_identity D). Proof. use make_nat_trans. - exact (λ B, hom_inv (identity (G B))). - intros B B' k. cbn. rewrite <- inv_natural_postcomp. rewrite <- inv_natural_precomp. apply maponpaths. rewrite id_left. apply id_right. Defined. Definition adj_from_nathomweq : are_adjoints F G. Proof. apply (make_are_adjoints F G unit_from_hom counit_from_hom). apply make_dirprod. - intro a. cbn. rewrite <- inv_natural_precomp. rewrite id_right. apply homotinvweqweq. - intro b. cbn. rewrite <- hom_natural_postcomp. rewrite id_left. apply homotweqinvweq. Defined. End Adjunction_from_HomSetIso. (** * Weak equivalence between adjunctions F -| G and natural weqs of homsets (F A --> B) ≃ (A --> G B) *) Section Adjunction_HomSetIso_weq. Context {C D : category} {F : functor C D} {G : functor D C}. Definition nathomweq_from_adj : (are_adjoints F G) → (natural_hom_weq F G) := λ H, (adjunction_hom_weq H,, (φ_adj_natural_precomp H,, φ_adj_natural_postcomp H)). Lemma adj_after_nathomweq (H : are_adjoints F G) : adj_from_nathomweq (nathomweq_from_adj H) = H. Proof. apply subtypePath. - intro. apply isaprop_form_adjunction. - apply dirprod_paths; cbn. + apply (nat_trans_eq (homset_property C)). intro c. cbn. unfold φ_adj, unit_from_are_adjoints. rewrite functor_id. apply id_right. + apply (nat_trans_eq (homset_property D)). intro d. cbn. unfold φ_adj_inv, counit_from_are_adjoints. rewrite functor_id. apply id_left. Defined. Lemma nathomweq_after_adj (H : natural_hom_weq F G) : nathomweq_from_adj (adj_from_nathomweq H) = H. Proof. apply subtypePath. - intros p. apply isapropdirprod. + do 5 (apply impred_isaprop; intro). apply C. + do 5 (apply impred_isaprop; intro). apply C. - cbn. unfold adjunction_hom_weq. do 2 (apply funextsec; intro). apply subtypePath. + intro. apply isapropisweq. + cbn. unfold φ_adj, adj_from_nathomweq. cbn. apply funextsec. intro f. rewrite <- hom_natural_postcomp. apply maponpaths. apply id_left. Defined. Lemma adjunction_homsetiso_weq : (are_adjoints F G) ≃ (natural_hom_weq F G). Proof. exists nathomweq_from_adj. apply (isweq_iso _ adj_from_nathomweq). - apply adj_after_nathomweq. - apply nathomweq_after_adj. Defined. End Adjunction_HomSetIso_weq. Section RelativeAdjunction_by_natural_hom_weq. (** this definition is according to Altenkirch, Chapman and Uustalu Reference: % \cite{DBLP:journals/corr/AltenkirchCU14} \par % *) Definition are_relative_adjoints {I: precategory_data} {C D: precategory_data} (J: functor_data I C) (L: functor_data I D) (R: functor_data D C) : UU := ∑ (hom_weq : ∏ {X : I} {Y : D}, L X --> Y ≃ J X --> R Y), (∏ (Y : I) (Z : D) (f : L Y --> Z) (X : I) (h : X --> Y), hom_weq (#L h · f) = #J h · hom_weq f) × (∏ (X : I) (Y : D) (f : L X --> Y) (Z : D) (k : Y --> Z), hom_weq (f · k) = hom_weq f · #R k). (** the notion is a proper generalization of one of the criteria for being an adjunction *) Lemma natural_hom_weq_is_are_relative_adjoints {C D: precategory} (L: functor C D) (R: functor D C): are_relative_adjoints (functor_identity C) L R = natural_hom_weq L R. Proof. apply idpath. Qed. End RelativeAdjunction_by_natural_hom_weq. (** ** Lemmas about adjunctions *) Section AdjunctionLemmas. Context {C D : category} {F : functor C D} {G : functor D C}. Context (are : are_adjoints F G). Let η : nat_trans (functor_identity C) (functor_composite F G) := unit_from_left_adjoint are. Let ε : nat_trans (functor_composite G F) (functor_identity D) := counit_from_left_adjoint are. (* Pre- and post- whiskering while treating functors/natural transformations as elements of functor categories. *) Let pre_whisker_functor_cat {a b c : category} {f g : functor b c} (h : functor a b) (n : [b, c]⟦f, g⟧) : [a, c]⟦functor_composite h f, functor_composite h g⟧ := pre_whisker h n. Let post_whisker_functor_cat {a b c : category} {f g : functor a b} (n : [a, b]⟦f, g⟧) (h : functor b c) : [a, c]⟦functor_composite f h, functor_composite g h⟧ := post_whisker n h. Let Fη := post_whisker_functor_cat η F. Let εF := pre_whisker_functor_cat F ε. Let ηG := pre_whisker_functor_cat G η. Let Gε := post_whisker_functor_cat ε G. (* Rephrase in terms of functor category objects/arrows *) Local Lemma triangle_eq_l : Fη · εF = identity (F : ob [C, D]). Proof. apply nat_trans_eq; [apply homset_property|]. intro; apply triangle_id_left_ad. Qed. (* Rephrase in terms of functor category objects/arrows *) Local Lemma triangle_eq_r : ηG · Gε = identity (G : ob [D, C]). Proof. apply nat_trans_eq; [apply homset_property|]. intro; apply triangle_id_right_ad. Qed. (* Rephrase in terms of functor category objects/arrows *) Lemma is_epi_post_whisker_right_adjoint_counit_pointwise : ∏ x, isEpi (nat_trans_data_from_nat_trans Gε x). Proof. intro x. assert (is0 : isEpi (nat_trans_data_from_nat_trans (ηG · Gε) x)). { rewrite (maponpaths nat_trans_data_from_nat_trans triangle_eq_r). apply identity_isEpi. } apply (isEpi_precomp _ _ _ is0). Qed. Corollary is_epi_post_whisker_right_adjoint_counit : isEpi Gε. Proof. apply is_nat_trans_epi_from_pointwise_epis. apply is_epi_post_whisker_right_adjoint_counit_pointwise. Qed. Lemma is_monic_pre_whisker_right_adjoint_unit_pointwise : ∏ x, isMonic (nat_trans_data_from_nat_trans ηG x). Proof. intro x. assert (is0 : isMonic (nat_trans_data_from_nat_trans (ηG · Gε) x)). { rewrite (maponpaths nat_trans_data_from_nat_trans triangle_eq_r). apply identity_isMonic. } apply (isMonic_postcomp _ _ _ is0). Qed. Corollary is_monic_pre_whisker_right_adjoint_unit : isMonic ηG. Proof. apply is_nat_trans_monic_from_pointwise_monics. apply is_monic_pre_whisker_right_adjoint_unit_pointwise. Qed. Lemma is_epi_pre_whisker_left_adjoint_counit_pointwise : ∏ x, isEpi (nat_trans_data_from_nat_trans εF x). Proof. intro x. assert (is0 : isEpi (nat_trans_data_from_nat_trans (Fη · εF) x)). { rewrite (maponpaths nat_trans_data_from_nat_trans triangle_eq_l). apply identity_isEpi. } apply (isEpi_precomp _ _ _ is0). Qed. Corollary is_epi_pre_whisker_left_adjoint_counit : isEpi εF. Proof. apply is_nat_trans_epi_from_pointwise_epis. apply is_epi_pre_whisker_left_adjoint_counit_pointwise. Qed. Lemma is_monic_post_whisker_left_adjoint_unit_pointwise : ∏ x, isMonic (nat_trans_data_from_nat_trans Fη x). Proof. intro x. assert (is0 : isMonic (nat_trans_data_from_nat_trans (Fη · εF) x)). { rewrite (maponpaths nat_trans_data_from_nat_trans triangle_eq_l). apply identity_isMonic. } apply (isMonic_postcomp _ _ _ is0). Qed. Corollary is_monic_post_whisker_left_adjoint_unit : isMonic Fη. Proof. apply is_nat_trans_monic_from_pointwise_monics. apply is_monic_post_whisker_left_adjoint_unit_pointwise. Qed. (** Riehl, "Category Theory in Context", Lemma 4.5.13(i)/Exercise 4.5.vi *) Lemma counit_is_epi_if_right_adjoint_is_faithful : faithful G -> ∏ x, isEpi (ε x). Proof. intros faithfulG. intros x y f g H. apply (Injectivity (# G)). apply incl_injectivity. - apply faithfulG. - apply (is_epi_post_whisker_right_adjoint_counit_pointwise x). apply (maponpaths #G) in H. do 2 rewrite functor_comp in H. assumption. Qed. Local Lemma issurjective_postcomp_with_weq {A B E : UU} (f : A -> B) (w : B ≃ E) : issurjective (w ∘ f)%functions -> issurjective f. Proof. intros iss b. specialize (iss (w b)). apply (squash_to_prop iss); [apply isapropishinh|]. intros a; apply hinhpr. exists (hfiberpr1 _ _ a). apply (make_weq _ (isweqmaponpaths w _ _)). apply (hfiberpr2 _ _ a). Qed. (** Riehl, "Category Theory in Context", Lemma 4.5.13(ii)/Exercise 4.5.vi Proof appears on the nLab (§ Basic properties): http://ncatlab.org/nlab/revision/adjoint%20functor/87 *) Lemma counit_is_split_monic_if_right_adjoint_is_full : full G -> ∏ x, is_merely_split_monic (ε x). Proof. intros fullG x. set (pcw c := (@precomp_with _ _ _ (ε x) c)). cut (∏ c : D, issurjective (pcw c)); [apply is_merely_split_monic_weq_precomp_is_surjection|]. intros c. cut (issurjective (hom_weq (nathomweq_from_adj are) ∘ @precomp_with _ _ _ (ε x) c)%functions); [apply issurjective_postcomp_with_weq|]. assert (E : (hom_weq (nathomweq_from_adj are) ∘ pcw c)%functions = # G). { apply funextfun; intro z; cbn. unfold φ_adj, pcw, precomp_with. rewrite functor_comp, assoc. change ε with (counit_from_are_adjoints are). refine (_ @ id_left _). apply (maponpaths (fun f => f · _)). apply (triangle_id_right_ad are x). } cut (issurjective (@functor_on_morphisms _ _ G x c)). - intros; cbn. unfold pcw in *; cbn in E. rewrite E. assumption. - apply fullG. Qed. Lemma counit_is_z_iso_if_right_adjoint_is_fully_faithful : fully_faithful G -> ∏ x, is_z_isomorphism (ε x). Proof. intros ? ?. apply merely_split_monic_is_epi_to_is_z_iso. - apply counit_is_split_monic_if_right_adjoint_is_full. apply fully_faithful_implies_full_and_faithful; assumption. - apply counit_is_epi_if_right_adjoint_is_faithful. apply fully_faithful_implies_full_and_faithful; assumption. Qed. End AdjunctionLemmas. UniMath-20231010/UniMath/CategoryTheory/Adjunctions/Examples.v000066400000000000000000000244201451125700300240540ustar00rootroot00000000000000(** * Examples of adjunctions - The binary delta_functor is left adjoint to binproduct_functor - The general delta functor is left adjoint to the general product functor - The bincoproduct_functor is left adjoint to the binary delta functor - The general coproduct functor is left adjoint to the general delta functor - Swapping of arguments in functor categories Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. Section bindelta_functor_adjunction. Context {C : category} (PC : BinProducts C). (** The binary delta_functor is left adjoint to binproduct_functor *) Lemma is_left_adjoint_bindelta_functor : is_left_adjoint (bindelta_functor C). Proof. apply (tpair _ (binproduct_functor PC)). use tpair. - split. + use tpair. * simpl; intro x. apply (BinProductArrow _ _ (identity x) (identity x)). * abstract (intros p q f; simpl; now rewrite precompWithBinProductArrow, id_right, postcompWithBinProductArrow, id_left). + use tpair. * simpl; intro x; split; [ apply BinProductPr1 | apply BinProductPr2 ]. * abstract (intros p q f; unfold catbinprodmor, compose; simpl; now rewrite BinProductOfArrowsPr1, BinProductOfArrowsPr2). - abstract (split; simpl; intro x; [ unfold catbinprodmor, compose; simpl; now rewrite BinProductPr1Commutes, BinProductPr2Commutes | cbn; rewrite postcompWithBinProductArrow, !id_left; apply pathsinv0, BinProduct_endo_is_identity; [ apply BinProductPr1Commutes | apply BinProductPr2Commutes ]]). Defined. End bindelta_functor_adjunction. Section delta_functor_adjunction. Context (I : UU) {C : category} (PC : Products I C). (** The general delta functor is left adjoint to the general product functor *) Lemma is_left_adjoint_delta_functor : is_left_adjoint (delta_functor I C). Proof. apply (tpair _ (product_functor _ PC)). use tpair. - split. + use tpair. * simpl; intro x. apply (ProductArrow _ _ _ (λ _, identity x)). * abstract (intros p q f; simpl; now rewrite precompWithProductArrow, id_right, postcompWithProductArrow, id_left). + use tpair. * intros x i; apply ProductPr. * abstract (intros p q f; apply funextsec; intro i; unfold compose; simpl; now rewrite ProductOfArrowsPr). - abstract (split; simpl; intro x; [ apply funextsec; intro i; apply (ProductPrCommutes _ _ (λ _, x)) | cbn; rewrite postcompWithProductArrow; apply pathsinv0, Product_endo_is_identity; intro i; eapply pathscomp0; [|apply (ProductPrCommutes I C _ (PC x))]; apply cancel_postcomposition, maponpaths, funextsec; intro j; apply id_left]). Defined. End delta_functor_adjunction. Section bincoproduct_functor_adjunction. Context {C : category} (PC : BinCoproducts C). (** The bincoproduct_functor left adjoint to delta_functor *) Lemma is_left_adjoint_bincoproduct_functor : is_left_adjoint (bincoproduct_functor PC). Proof. apply (tpair _ (bindelta_functor _)). use tpair. - split. + use tpair. * simpl; intro p; set (x := pr1 p); set (y := pr2 p). split; [ apply (BinCoproductIn1 (PC x y)) | apply (BinCoproductIn2 (PC x y)) ]. * abstract (intros p q f; unfold catbinprodmor, compose; simpl; now rewrite BinCoproductOfArrowsIn1, BinCoproductOfArrowsIn2). + use tpair. * intro x; apply (BinCoproductArrow _ (identity x) (identity x)). * abstract (intros p q f; simpl; now rewrite precompWithBinCoproductArrow, postcompWithBinCoproductArrow, id_right, id_left). - abstract (split; simpl; intro x; [ cbn; rewrite precompWithBinCoproductArrow, !id_right; apply pathsinv0, BinCoproduct_endo_is_identity; [ apply BinCoproductIn1Commutes | apply BinCoproductIn2Commutes ] | unfold catbinprodmor, compose; simpl; now rewrite BinCoproductIn1Commutes, BinCoproductIn2Commutes ]). Defined. End bincoproduct_functor_adjunction. Section coproduct_functor_adjunction. Context (I : UU) {C : category} (PC : Coproducts I C). (** The general coproduct functor left adjoint to the general delta functor *) Lemma is_left_adjoint_coproduct_functor : is_left_adjoint (coproduct_functor I PC). Proof. apply (tpair _ (delta_functor _ _)). use tpair. - split. + use tpair. * intros p i; apply CoproductIn. * abstract (intros p q f; apply funextsec; intro i; unfold compose; simpl; now rewrite CoproductOfArrowsIn). + use tpair. * intro x; apply (CoproductArrow _ _ _ (λ _, identity x)). * abstract (intros p q f; simpl; now rewrite precompWithCoproductArrow, postcompWithCoproductArrow, id_right, id_left). - abstract (split; simpl; intro x; [ cbn; rewrite precompWithCoproductArrow; apply pathsinv0, Coproduct_endo_is_identity; intro i; eapply pathscomp0; [|apply CoproductInCommutes]; apply maponpaths, maponpaths, funextsec; intro j; apply id_right | apply funextsec; intro i; apply (CoproductInCommutes _ _ (λ _, x))]). Defined. End coproduct_functor_adjunction. (** * Swapping of arguments in functor categories *) Section functor_swap. Local Notation "[ C , D ]" := (functor_category C D). Lemma functor_swap {C D : precategory} {E : category} : functor C [D,E] → functor D [C,E]. Proof. intros F. use tpair. - use tpair. + intro d; simpl. { use tpair. - use tpair. + intro c. apply (pr1 (F c) d). + intros a b f; apply (# F f). - abstract (split; [ now intro x; simpl; rewrite (functor_id F) | now intros a b c f g; simpl; rewrite (functor_comp F)]). } + intros a b f; simpl. { use tpair. - intros x; apply (# (pr1 (F x)) f). - abstract (intros c d g; simpl; apply pathsinv0, nat_trans_ax). } - abstract (split; [ intros d; apply (nat_trans_eq (homset_property E)); intro c; simpl; apply functor_id | intros a b c f g; apply (nat_trans_eq (homset_property E)); intro x; simpl; apply functor_comp]). Defined. Lemma functor_cat_swap_nat_trans {C D : precategory} {E : category} (F G : functor C [D, E]) (α : nat_trans F G) : nat_trans (functor_swap F) (functor_swap G). Proof. use tpair. + intros d; simpl. use tpair. * intro c; apply (α c). * abstract (intros a b f; apply (nat_trans_eq_pointwise (nat_trans_ax α _ _ f) d)). + abstract (intros a b f; apply (nat_trans_eq (homset_property E)); intro c; simpl; apply nat_trans_ax). Defined. Lemma functor_cat_swap (C D : precategory) (E : category) : functor [C, [D, E]] [D, [C, E]]. Proof. use tpair. - use tpair. + apply functor_swap. + cbn. apply functor_cat_swap_nat_trans. - abstract (split; [ intro F; apply (nat_trans_eq (functor_category_has_homsets _ _ (homset_property E))); simpl; intro d; now apply (nat_trans_eq (homset_property E)) | intros F G H α β; cbn; apply (nat_trans_eq (functor_category_has_homsets _ _ (homset_property E))); intro d; now apply (nat_trans_eq (homset_property E))]). Defined. Definition id_functor_cat_swap (C D : precategory) (E : category) : nat_trans (functor_identity [C,[D,E]]) (functor_composite (functor_cat_swap C D E) (functor_cat_swap D C E)). Proof. set (hsE := homset_property E). use tpair. + intros F. use tpair. - intro c. use tpair. * now intro f; apply identity. * abstract (now intros a b f; rewrite id_left, id_right). - abstract (now intros a b f; apply (nat_trans_eq hsE); intro d; simpl; rewrite id_left, id_right). + abstract (now intros a b f; apply nat_trans_eq; [apply functor_category_has_homsets|]; intro c; apply (nat_trans_eq hsE); intro d; simpl; rewrite id_left, id_right). Defined. Definition functor_cat_swap_id (C D : precategory) (E : category) : nat_trans (functor_composite (functor_cat_swap D C E) (functor_cat_swap C D E)) (functor_identity [D,[C,E]]). Proof. set (hsE := homset_property E). use tpair. + intros F. use tpair. - intro c. use tpair. * now intro f; apply identity. * abstract (now intros a b f; rewrite id_left, id_right). - abstract (now intros a b f; apply (nat_trans_eq hsE); intro d; simpl; rewrite id_left, id_right). + abstract (now intros a b f; apply nat_trans_eq; [apply functor_category_has_homsets|]; intro c; apply (nat_trans_eq hsE); intro d; simpl; rewrite id_left, id_right). Defined. Lemma form_adjunction_functor_cat_swap (C D : precategory) (E : category) : form_adjunction _ _ (id_functor_cat_swap C D E) (functor_cat_swap_id C D E). Proof. set (hsE := homset_property E). split; intro F. + apply (nat_trans_eq (functor_category_has_homsets _ _ hsE) (pr1 (pr1 (functor_cat_swap C D E) F)) (pr1 (pr1 (functor_cat_swap C D E) F))). now intro d; apply (nat_trans_eq hsE); intro c; apply id_right. + apply (nat_trans_eq (functor_category_has_homsets _ _ hsE) (pr1 (pr1 (functor_cat_swap D C E) F)) (pr1 (pr1 (functor_cat_swap D C E) F))). now intro d; apply (nat_trans_eq hsE); intro c; apply id_left. Qed. (* This Qed is very slow... I don't see how to make it faster *) Lemma are_adjoint_functor_cat_swap (C D : precategory) (E : category) : are_adjoints (@functor_cat_swap C D E) (@functor_cat_swap D C E). Proof. use tpair. - split; [ apply id_functor_cat_swap | apply functor_cat_swap_id ]. - apply form_adjunction_functor_cat_swap. Defined. Lemma is_left_adjoint_functor_cat_swap (C D : precategory) (E : category) : is_left_adjoint (functor_cat_swap C D E). Proof. use tpair. + apply functor_cat_swap. + apply are_adjoint_functor_cat_swap. Defined. End functor_swap. UniMath-20231010/UniMath/CategoryTheory/Adjunctions/Restriction.v000066400000000000000000000170151451125700300246050ustar00rootroot00000000000000(** * Restriction of an adjuction to an equivalence *) (** ** Contents - Restriction of an adjunction to an equivalence *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. (** ** Restriction of an adjunction to an equivalence *) (** Restriction of an adjunction to the subcategories where the unit and counit are isos forms an equivalence *) (** The full subcategory of [C] for which [eta] is an isomorphism *) Definition full_subcat_nat_trans_is_z_iso {C D : category} {F : functor C D} {G : functor C D} (eta : nat_trans F G) : sub_precategories C. Proof. apply full_sub_precategory. intro c; use make_hProp. - exact (is_z_isomorphism (eta c)). - apply isaprop_is_z_isomorphism. Defined. Section Restriction. Context {C D : category} {F : functor C D} {G : functor D C} (are : are_adjoints F G). Let η := adjunit are. Let ε := adjcounit are. Definition restricted_adjunction_left_adjoint : functor (full_subcat_nat_trans_is_z_iso η) (full_subcat_nat_trans_is_z_iso ε). Proof. use make_functor; [use make_functor_data|split]. - (* Left adjoint data on objects *) * intros c'; pose (c := precategory_object_from_sub_precategory_object _ _ c'). use tpair. -- exact (F c). -- cbn. (* need: ε (F c) is an iso *) use make_is_z_isomorphism. ++ exact (post_whisker η F _). ++ assert (HH : (post_whisker η F) c · ε (F c) = identity (F c)). { apply (triangle_id_left_ad are). } (* We know [# F (η x)] is invertible because [η x] is *) assert (inv : ∑ h, is_inverse_in_precat ((post_whisker η F) c) h). { use tpair. - exact (# F (inv_from_z_iso (make_z_iso' _ (pr2 c')))). - cbn. apply (functor_is_inverse_in_precat_inv_from_z_iso F (make_z_iso' _ (pr2 c'))). } split. ** (* Since [# F (η x)] is invertible and [ε (F c)] is its right inverse, [ε (F c)] must be its left inverse. *) pose (eq := right_inverse_of_iso_is_inverse ((post_whisker η F) c) ). specialize (eq (pr1 inv) (pr2 inv) (ε (F c)) HH). refine (maponpaths (fun z => z · _) eq @ _). apply is_inverse_in_precat1. apply is_inverse_in_precat_inv. exact (pr2 inv). ** exact HH. - (* Left adjoint data on morphisms *) intros ? ? f; cbn. use tpair. + exact (# F (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f)). + exact tt. - (* Left adjoint identity axiom *) intro; cbn. apply subtypePath; [intro; apply propproperty|]. apply functor_id. - (* Left adjoint composition axiom *) intros ? ? ? ? ?; cbn. apply subtypePath; [intro; apply propproperty|]. apply functor_comp. Defined. Definition restricted_adjunction_right_adjoint : functor (full_subcat_nat_trans_is_z_iso ε) (full_subcat_nat_trans_is_z_iso η). Proof. use make_functor; [use make_functor_data|split]. - (* The definition of the right adjoint just mirrors that of the left *) (* Right adjoint data on objects *) intros d'; pose (d := precategory_object_from_sub_precategory_object _ _ d'). use tpair. + exact (G d). + cbn. use make_is_z_isomorphism. * exact (post_whisker ε G _). * assert (HH : η (G d) · (post_whisker ε G) d = identity (G d)). { apply (triangle_id_right_ad are). } assert (inv : ∑ h, is_inverse_in_precat (post_whisker ε G d) h). { use tpair. - exact (# G (inv_from_z_iso (make_z_iso' _ (pr2 d')))). - apply (functor_is_inverse_in_precat_inv_from_z_iso G (make_z_iso' _ (pr2 d'))). } split. -- exact HH. -- pose (eq := left_inverse_of_iso_is_inverse ((post_whisker ε G) d)). specialize (eq (pr1 inv) (pr2 inv) (η (G d)) HH). refine (maponpaths (fun z => _ · z) eq @ _). apply is_inverse_in_precat1. exact (pr2 inv). - (* Right adjoint data on morphisms *) * intros ? ? f; cbn. use tpair. -- exact (# G (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f)). -- exact tt. - (* Right adjoint identity axiom *) intro; cbn. apply subtypePath; [intro; apply propproperty|]. apply functor_id. - (* Right adjoint composition axiom *) intros ? ? ? ? ?; cbn. apply subtypePath; [intro; apply propproperty|]. apply functor_comp. Defined. Definition restricted_adjunction_unit : nat_trans (functor_identity (full_subcat_nat_trans_is_z_iso η)) (restricted_adjunction_left_adjoint ∙ restricted_adjunction_right_adjoint). Proof. use make_nat_trans. - intro; cbn. use tpair. + apply η. + exact tt. - (* Unit is natural *) intros ? ? ?. apply subtypePath; [intro; apply propproperty|]. apply (pr2 η). Defined. Definition restricted_adjunction_counit : nat_trans (restricted_adjunction_right_adjoint ∙ restricted_adjunction_left_adjoint) (functor_identity (full_subcat_nat_trans_is_z_iso ε)). Proof. use make_nat_trans. - intro; cbn. use tpair. + apply ε. + exact tt. - (* Counit is natural *) intros ? ? ?. apply subtypePath; [intro; apply propproperty|]. apply (pr2 ε). Defined. Lemma are_adjoints_restricted_adjunction : are_adjoints restricted_adjunction_left_adjoint restricted_adjunction_right_adjoint. Proof. use make_are_adjoints. - exact restricted_adjunction_unit. - exact restricted_adjunction_counit. - use make_form_adjunction. + (* 1st triangle identity *) intro; apply subtypePath; [intro; apply propproperty|]. apply triangle_id_left_ad. + (* 2nd triangle identity *) intro; apply subtypePath; [intro; apply propproperty|]. apply triangle_id_right_ad. Defined. Lemma restricted_adjunction_equivalence : equivalence_of_cats (full_subcat_nat_trans_is_z_iso η) (full_subcat_nat_trans_is_z_iso ε). Proof. exists (adjunction_data_from_is_left_adjoint are_adjoints_restricted_adjunction). split. - intro a. pose (isomor := make_z_iso' _ (pr2 a) : z_iso (pr1 a) (pr1 (right_adjoint are_adjoints_restricted_adjunction (left_adjoint are_adjoints_restricted_adjunction a)))). apply (iso_in_precat_is_iso_in_subcat C _ _ _ isomor). - intro b. cbn. pose (isomor := make_z_iso' _ (pr2 b) : z_iso (pr1 (left_adjoint are_adjoints_restricted_adjunction (right_adjoint are_adjoints_restricted_adjunction b))) (pr1 b)). apply (iso_in_precat_is_iso_in_subcat _ _ _ _ isomor). Defined. End Restriction. UniMath-20231010/UniMath/CategoryTheory/ArrowCategory.v000066400000000000000000000233561451125700300226140ustar00rootroot00000000000000(** * Arrow categories *) (** ** Contents - Definition - As a comma category *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.CommaCategories. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** ** Definition *) Section Defn. Definition arrow_precategory_data (C : precategory) : precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact (∑ (a : ob C × ob C), dirprod_pr1 a --> dirprod_pr2 a). + intros x y. (** The commutative square << pr1 x ---> pr1 y | | | | pr1 pr2 x ---> pr1 pr2 y >> *) exact (∑ fg : dirprod_pr1 (pr1 x) --> dirprod_pr1 (pr1 y) × dirprod_pr2 (pr1 x) --> dirprod_pr2 (pr1 y), pr2 x · dirprod_pr2 fg = dirprod_pr1 fg · pr2 y). - intros x; cbn. exists (make_dirprod (identity _) (identity _)). exact (id_right _ @ !id_left _). - intros x y z f g; cbn in *. exists (make_dirprod (dirprod_pr1 (pr1 f) · dirprod_pr1 (pr1 g)) (dirprod_pr2 (pr1 f) · dirprod_pr2 (pr1 g))). (** Composing commutative squares << pr1 x ---> pr1 y ---> pr1 z | | | | f | g | | | | pr1 pr2 x ---> pr1 pr2 y ---> pr1 pr2 z >> *) cbn. refine (assoc _ _ _ @ _). refine (maponpaths (fun x => x · _) (pr2 f) @ _). refine (_ @ assoc _ _ _). refine (_ @ maponpaths _ (pr2 g)). apply pathsinv0. apply assoc. Defined. Definition arrow_category (C : category) : category. Proof. use make_category. - use make_precategory_one_assoc; [apply (arrow_precategory_data C)|]. unfold is_precategory_one_assoc. split; [split|]. + intros a b f. unfold arrow_precategory_data in *; cbn in *. apply subtypePath. * intro; apply homset_property. * apply pathsdirprod; apply id_left. + intros a b f. unfold arrow_precategory_data in *; cbn in *. apply subtypePath. * intro; apply homset_property. * apply pathsdirprod; apply id_right. + intros a b c d f g h. apply subtypePath; [intro; apply homset_property|]. apply pathsdirprod; apply assoc. - intros a b. apply isaset_total2. + apply isaset_dirprod; apply homset_property. + intro. apply hlevelntosn. apply homset_property. Defined. Section IsIsoArrow. Context {C : category} {x y : arrow_category C} (f : x --> y) (Hf1 : is_z_isomorphism (pr11 f)) (Hf2 : is_z_isomorphism (pr21 f)). Definition inv_arrow : y --> x. Proof. refine ((inv_from_z_iso (_,, Hf1) ,, inv_from_z_iso (_,, Hf2)) ,, _). abstract (cbn ; refine (!_) ; use z_iso_inv_on_left ; rewrite assoc' ; refine (!_) ; use z_iso_inv_on_right ; cbn ; exact (pr2 f)). Defined. Lemma is_z_iso_arrow_left_inv : f · inv_arrow = identity x. Proof. use subtypePath. { intro. apply homset_property. } use pathsdirprod ; cbn. - exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf1)). - exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf2)). Qed. Lemma is_z_iso_arrow_right_inv : inv_arrow · f = identity y. Proof. use subtypePath. { intro. apply homset_property. } use pathsdirprod ; cbn. - exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf1)). - exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf2)). Qed. Definition is_z_iso_arrow : is_z_isomorphism f. Proof. exists inv_arrow. split. - exact is_z_iso_arrow_left_inv. - exact is_z_iso_arrow_right_inv. Defined. End IsIsoArrow. End Defn. (** ** As a comma category *) Section ArrowCategoryEquivCommaCategory. Context (C : category). Definition arrow_category_to_comma_category_data : functor_data (arrow_category C) (comma (functor_identity C) (functor_identity C)). Proof. use make_functor_data. - exact (λ f, f). - cbn. exact (λ f g p, p). Defined. Definition arrow_category_to_comma_category_is_functor : is_functor arrow_category_to_comma_category_data. Proof. split. - intros f. cbn. refine (maponpaths (λ z, _ ,, z) _). apply homset_property. - intros f g h p q. cbn. refine (maponpaths (λ z, _ ,, z) _). apply homset_property. Qed. Definition arrow_category_to_comma_category : arrow_category C ⟶ comma (functor_identity C) (functor_identity C). Proof. use make_functor. - exact arrow_category_to_comma_category_data. - exact arrow_category_to_comma_category_is_functor. Defined. Definition comma_category_to_arrow_category_data : functor_data (comma (functor_identity C) (functor_identity C)) (arrow_category C). Proof. use make_functor_data. - exact (λ f, f). - cbn. exact (λ f g p, p). Defined. Definition comma_category_to_arrow_category_is_functor : is_functor comma_category_to_arrow_category_data. Proof. split. - intros f. cbn. refine (maponpaths (λ z, _ ,, z) _). apply homset_property. - intros f g h p q. cbn. refine (maponpaths (λ z, _ ,, z) _). apply homset_property. Qed. Definition comma_category_to_arrow_category : comma (functor_identity C) (functor_identity C) ⟶ arrow_category C. Proof. use make_functor. - exact comma_category_to_arrow_category_data. - exact comma_category_to_arrow_category_is_functor. Defined. Definition arrow_category_equiv_comma_category_unit_data : nat_trans_data (functor_identity (arrow_category C)) (arrow_category_to_comma_category ∙ comma_category_to_arrow_category). Proof. cbn. refine (λ x, (identity _ ,, identity _) ,, _). abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition arrow_category_equiv_comma_category_unit_is_nat_trans : is_nat_trans _ _ arrow_category_equiv_comma_category_unit_data. Proof. intros f g p. use subtypePath. { intro ; apply homset_property. } cbn. use pathsdirprod. - rewrite id_left, id_right. apply idpath. - rewrite id_left, id_right. apply idpath. Qed. Definition arrow_category_equiv_comma_category_unit : functor_identity _ ⟹ arrow_category_to_comma_category ∙ comma_category_to_arrow_category. Proof. use make_nat_trans. - exact arrow_category_equiv_comma_category_unit_data. - exact arrow_category_equiv_comma_category_unit_is_nat_trans. Defined. Definition arrow_category_equiv_comma_category_counit_data : nat_trans_data (comma_category_to_arrow_category ∙ arrow_category_to_comma_category) (functor_identity (comma (functor_identity C) (functor_identity C))). Proof. cbn. refine (λ x, (identity _ ,, identity _) ,, _). abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition arrow_category_equiv_comma_category_counit_is_nat_trans : is_nat_trans _ _ arrow_category_equiv_comma_category_counit_data. Proof. intros f g p. use subtypePath. { intro ; apply homset_property. } cbn. use pathsdirprod. - rewrite id_left, id_right. apply idpath. - rewrite id_left, id_right. apply idpath. Qed. Definition arrow_category_equiv_comma_category_counit : comma_category_to_arrow_category ∙ arrow_category_to_comma_category ⟹ functor_identity (comma (functor_identity C) (functor_identity C)). Proof. use make_nat_trans. - exact arrow_category_equiv_comma_category_counit_data. - exact arrow_category_equiv_comma_category_counit_is_nat_trans. Defined. Definition arrow_category_comma_category_adjunction : form_adjunction arrow_category_to_comma_category comma_category_to_arrow_category arrow_category_equiv_comma_category_unit arrow_category_equiv_comma_category_counit. Proof. use make_form_adjunction. - intro x. use subtypePath. { intro ; apply homset_property. } cbn. use pathsdirprod. + apply id_right. + apply id_right. - intro x. use subtypePath. { intro ; apply homset_property. } cbn. use pathsdirprod. + apply id_right. + apply id_right. Qed. Definition arrow_category_equiv_comma_category : adj_equivalence_of_cats arrow_category_to_comma_category. Proof. use make_adj_equivalence_of_cats. - exact comma_category_to_arrow_category. - exact arrow_category_equiv_comma_category_unit. - exact arrow_category_equiv_comma_category_counit. - exact arrow_category_comma_category_adjunction. - split. + intro ; cbn. use is_z_iso_arrow. * apply identity_is_z_iso. * apply identity_is_z_iso. + intro ; cbn. use is_z_iso_comma. * apply identity_is_z_iso. * apply identity_is_z_iso. Defined. End ArrowCategoryEquivCommaCategory. UniMath-20231010/UniMath/CategoryTheory/BicatOfCatsElementary.v000066400000000000000000000245331451125700300241720ustar00rootroot00000000000000(** the constituents of the bicategory of categories without using the package [Bicategories]; all is expressed with reference to the functor categories this is useful for developments that are inspired by bicategorical insights but that are spelt out in elementary form, so as to avoid dependency on the package [Bicategories], in particular used in examples of whiskered monoidal categories and actegories and in the package [SubstitutionSystems] author: Ralph Matthes 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Definition id1_CAT (C : category) : [C, C] := functor_identity C. (** the data of a [prebicat_2_id_comp_struct] *) Definition id2_CAT {C D : category} (F : [C, D]) : [C, D]⟦F, F⟧ := nat_trans_id (F : functor _ _). Definition lunitor_CAT {C D : category} (F : [C, D]) : [C, D]⟦functor_compose (id1_CAT C) F, F⟧ := nat_trans_id (F : functor _ _). Definition runitor_CAT {C D : category} (F : [C, D]) : [C, D]⟦functor_compose F (id1_CAT D), F⟧ := nat_trans_id (F : functor _ _). Definition linvunitor_CAT {C D : category} (F : [C, D]) : [C, D]⟦F, functor_compose (id1_CAT C) F⟧ := nat_trans_id (F : functor _ _). Definition rinvunitor_CAT {C D : category} (F : [C, D]) : [C, D]⟦F, functor_compose F (id1_CAT D)⟧ := nat_trans_id (F : functor _ _). Definition lassociator_CAT {C D E F : category} (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : [C, F] ⟦functor_compose X (functor_compose Y Z), functor_compose (functor_compose X Y) Z⟧ := nat_trans_id (functor_composite X (functor_composite Y Z)). Definition rassociator_CAT {C D E F : category} (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : [C, F] ⟦functor_compose (functor_compose X Y) Z, functor_compose X (functor_compose Y Z)⟧ := nat_trans_id (functor_composite (functor_composite X Y) Z). Definition vcomp2_CAT {C D : category} {F G H : [C, D]} : [C,D]⟦F, G⟧ -> [C,D]⟦G, H⟧ -> [C,D]⟦F, H⟧. Proof. intros α β. exact (nat_trans_comp _ _ _ α β). Defined. Definition lwhisker_CAT {C D E : category} (F : [C, D]) {G1 G2 : [D, E]} : [D, E]⟦G1, G2⟧ -> [C, E]⟦functor_compose F G1, functor_compose F G2⟧. Proof. intro α. exact (pre_whisker (F : functor _ _) α). Defined. Definition rwhisker_CAT {C D E : category} {F1 F2 : [C, D]} (G : [D, E]) : [C, D]⟦F1, F2⟧ -> [C, E]⟦functor_compose F1 G, functor_compose F2 G⟧. Proof. intro α. exact (post_whisker α (G : functor _ _)). Defined. (** the proofs required in [prebicat_laws] *) Lemma id2_left_CAT {C D : category} {F G : [C, D]} (α : [C, D]⟦F, G⟧) : id2_CAT F · α = α. Proof. apply id_left. Qed. Lemma id2_right_CAT {C D : category} {F G : [C, D]} (α : [C, D]⟦F, G⟧) : α · id2_CAT G = α. Proof. apply id_right. Qed. Lemma vassocr_CAT {C D : category} {F G H K : [C, D]} (α : [C, D]⟦F, G⟧) (β : [C, D]⟦G, H⟧)(γ : [C, D]⟦H, K⟧) : α · (β · γ) = (α · β) · γ. Proof. apply assoc. Qed. Lemma lwhisker_id2_CAT {C D E : category} (F : [C, D]) (G : [D, E]) : lwhisker_CAT F (id2_CAT G) = id2_CAT _. Proof. apply pre_whisker_identity. Qed. Lemma id2_rwhisker_CAT {C D E : category} (F : [C, D]) (G : [D, E]) : rwhisker_CAT G (id2_CAT F) = id2_CAT _. Proof. apply post_whisker_identity. Qed. Lemma lwhisker_vcomp_CAT {C D E : category} (F : [C, D]) (G H I : [D, E]) (α : [D, E]⟦G, H⟧) (β : [D, E]⟦H, I⟧) : lwhisker_CAT F α · lwhisker_CAT F β = lwhisker_CAT F (α · β). Proof. apply pathsinv0, pre_whisker_composition. Qed. Lemma rwhisker_vcomp_CAT {C D E : category} (F G H : [C, D]) (I : [D, E]) (α : [C, D]⟦F, G⟧) (β : [C, D]⟦G, H⟧) : rwhisker_CAT I α · rwhisker_CAT I β = rwhisker_CAT I (α · β). Proof. apply pathsinv0, post_whisker_composition. Qed. Lemma vcomp_lunitor_CAT {C D : category} {F G : [C, D]} (α : [C, D]⟦F, G⟧) : lwhisker_CAT (id1_CAT C) α · lunitor_CAT G = lunitor_CAT F · α. Proof. apply (nat_trans_eq D); intro c. rewrite id_left; apply id_right. Qed. Lemma vcomp_runitor_CAT {C D : category} {F G : [C, D]} (α : [C, D]⟦F, G⟧) : rwhisker_CAT (id1_CAT D) α · runitor_CAT G = runitor_CAT F · α. Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_left. apply id_right. Qed. Lemma lwhisker_lwhisker_CAT {A B C D : category} {F : [A, B]} {G : [B, C]} {H I : [C, D]} (α : [C, D]⟦H, I⟧) : lwhisker_CAT F (lwhisker_CAT G α) · lassociator_CAT _ _ _ = lassociator_CAT _ _ _ · lwhisker_CAT (functor_compose F G) α. Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_left; apply id_right. Qed. Lemma rwhisker_lwhisker_CAT {A B C D : category} {F : [A, B]} {G H : [B, C]} {I : [C, D]} (α : [B, C]⟦G, H⟧) : lwhisker_CAT F (rwhisker_CAT I α) · lassociator_CAT _ _ _ = lassociator_CAT _ _ _ · rwhisker_CAT I (lwhisker_CAT F α). Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_left; apply id_right. Qed. Lemma rwhisker_rwhisker_CAT {A B C D : category} {F G : [A, B]} {H : [B, C]} {I : [C, D]} (α : [A, B]⟦F, G⟧) : lassociator_CAT _ _ _ · rwhisker_CAT I (rwhisker_CAT H α) = rwhisker_CAT (functor_compose H I) α · lassociator_CAT _ _ _. Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_left, id_right. apply idpath. Qed. Lemma vcomp_whisker_CAT {A B C : category} {F G : [A, B]} {H I : [B, C]} (α : [A, B]⟦F, G⟧) (β : [B, C]⟦H, I⟧) : rwhisker_CAT H α · lwhisker_CAT G β = lwhisker_CAT F β · rwhisker_CAT I α. Proof. apply (nat_trans_eq C); intro c. apply (pr2 β). Qed. Lemma lunitor_linvunitor_CAT {C D : category} (F : [C, D]) : lunitor_CAT F · linvunitor_CAT _ = id2_CAT _. Proof. apply (nat_trans_eq D); intro c. apply id_right. Qed. Lemma linvunitor_lunitor_CAT {C D : category} (F : [C, D]) : linvunitor_CAT F · lunitor_CAT _ = id2_CAT _. Proof. apply (nat_trans_eq D); intro c. apply id_right. Qed. Lemma runitor_rinvunitor_CAT {C D : category} (F : [C, D]) : runitor_CAT F · rinvunitor_CAT _ = id2_CAT _. Proof. apply (nat_trans_eq D); intro c. apply id_right. Qed. Lemma rinvunitor_runitor_CAT {C D : category} (F : [C, D]) : rinvunitor_CAT F · runitor_CAT _ = id2_CAT _. Proof. apply (nat_trans_eq D); intro c. apply id_right. Qed. Lemma lassociator_rassociator_CAT {C D E F : category} (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : lassociator_CAT X Y Z · rassociator_CAT _ _ _ = id2_CAT _. Proof. apply (nat_trans_eq F); intro c. apply id_right. Qed. Lemma rassociator_lassociator_CAT {C D E F : category} (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : rassociator_CAT X Y Z · lassociator_CAT _ _ _ = id2_CAT _. Proof. apply (nat_trans_eq F); intro c. apply id_right. Qed. (* [id1_CAT B] is needed in the following formulation, an underscore is not accepted *) Lemma runitor_rwhisker_CAT {A B C : category} (F : [A, B]) (G : [B, C]) : lassociator_CAT F (id1_CAT B) G · (rwhisker_CAT G (runitor_CAT F)) = lwhisker_CAT F (lunitor_CAT G). Proof. apply (nat_trans_eq C); intro c. cbn. rewrite id_left. apply functor_id. Qed. Lemma lassociator_lassociator_CAT {A B C D E : category} (F : [A, B]) (G : [B, C]) (H : [C, D]) (I : [D, E]) : lwhisker_CAT F (lassociator_CAT G H I) · lassociator_CAT _ (functor_compose G H) _ · (rwhisker_CAT I (lassociator_CAT _ _ _)) = lassociator_CAT F G (functor_compose H I) · lassociator_CAT (functor_compose F G) _ _. Proof. apply (nat_trans_eq E); intro c. cbn. do 3 rewrite id_left. apply functor_id. Qed. (** now for convenience *) Lemma lunitor_CAT_pointwise_is_z_iso {C D : category} (F : [C, D]) : is_z_isomorphism (lunitor_CAT F). Proof. exists (linvunitor_CAT F). split. - apply lunitor_linvunitor_CAT. - apply linvunitor_lunitor_CAT. Defined. Lemma runitor_CAT_pointwise_is_z_iso {C D : category} (F : [C, D]) : is_z_isomorphism (runitor_CAT F). Proof. exists (rinvunitor_CAT F). split. - apply runitor_rinvunitor_CAT. - apply rinvunitor_runitor_CAT. Defined. Definition lassociator_CAT_pointwise_is_z_iso {C D E F : category} (X : functor C D)(Y : functor D E)(Z : functor E F) : is_z_isomorphism (lassociator_CAT X Y Z). Proof. exists (rassociator_CAT X Y Z). split. - apply lassociator_rassociator_CAT. - apply rassociator_lassociator_CAT. Defined. (** laws that are instances of derivable rules in bicategories; here, we just prove them directly *) Lemma lwhisker_lwhisker_rassociator_CAT {A B C D : category} {F : [A, B]} {G : [B, C]} {H I : [C, D]} (α : [C, D]⟦H, I⟧) : rassociator_CAT _ _ _ · lwhisker_CAT F (lwhisker_CAT G α) = lwhisker_CAT (functor_compose F G) α · rassociator_CAT _ _ _ . Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_right; apply id_left. Qed. Lemma rwhisker_lwhisker_rassociator_CAT {A B C D : category} {F : [A, B]} {G H : [B, C]} {I : [C, D]} (α : [B, C]⟦G, H⟧) : rassociator_CAT _ _ _ · lwhisker_CAT F (rwhisker_CAT I α) = rwhisker_CAT I (lwhisker_CAT F α) · rassociator_CAT _ _ _. Proof. apply (nat_trans_eq D); intro c. cbn. rewrite id_right; apply id_left. Qed. Lemma rwhisker_rwhisker_alt_CAT {A B C D : category} {F : [B, A]} {G : [C, B]} {H I : [D, C]} (α : [D, C]⟦H, I⟧) : rwhisker_CAT F (rwhisker_CAT G α) · rassociator_CAT _ _ _ = rassociator_CAT _ _ _ · rwhisker_CAT (functor_compose G F) α. Proof. apply (nat_trans_eq A); intro d. cbn. rewrite id_left; apply id_right. Qed. Lemma lunitor_lwhisker_CAT {A B C : category} (F : [A, B]) (G : [B, C]) : rassociator_CAT F (id1_CAT B) G · (lwhisker_CAT F (lunitor_CAT G)) = rwhisker_CAT G (runitor_CAT F). Proof. apply (nat_trans_eq C); intro c. cbn. rewrite id_left. apply pathsinv0, functor_id. Qed. Lemma rassociator_rassociator_CAT {A B C D E : category} (F : [A, B]) (G : [B, C]) (H : [C, D]) (I : [D, E]) : rwhisker_CAT I (rassociator_CAT F G H) · rassociator_CAT _ (functor_compose G H) _ · (lwhisker_CAT F (rassociator_CAT _ _ _)) = rassociator_CAT (functor_compose F G) H I · rassociator_CAT F G (functor_compose H I). Proof. apply (nat_trans_eq E); intro c. cbn. do 3 rewrite id_right. apply functor_id. Qed. UniMath-20231010/UniMath/CategoryTheory/CategoricalRecursionSchemes.v000066400000000000000000000663101451125700300254400ustar00rootroot00000000000000(** Author : Hichem Saghrouni Internship at IRIT, 2018 Under the supervision of Ralph Matthes Later continued by Ralph Matthes (R.M.), see the end of this comment. Work on the paper HINZE, R. and WU, N., 2016. Unifying structured recursion schemes: An Extended Study. Journal of Functional Programming, vol. 26, https://doi.org/10.1017/S0956796815000258. The purpose of this file is to formalize in UniMath the recursion scheme presented by Hinze and Wu, with their original approach making use of liftings and conjugates. For this, we formalize the notions of - Distributive Laws, which are natural transformations between compositions of functors - Conjugates, which induce a binary relation between distributive laws, defined by certain identities found in this document - Liftings, which constitute a specific type of functors between F-Algebras These constructions finally allow us to follow the proof by Hinze and Wu of their theorem (found under "Theorem 5.2 (Adjoint folds)" in their paper) and thus reprove it formally. Added by R.M.: how canonically defined liftings compose *) Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. Section DefDistrLaw. Context {C C' D D' : precategory} (F : functor C D) (F' : functor C' D') (H : functor C' C) (K : functor D' D). (** the definition of Hinze and Wu - no other laws required for being considered a distributive law *) Definition DistrLaw (*{C C' D D' : precategory} (F : functor C D) (F' : functor C' D') (H : functor C' C) (K : functor D' D)*) : UU := nat_trans (H ∙ F) (F' ∙ K). (** a small help for later type-checking *) Definition DistrLaw_data (*{C C' D D' : precategory} (F : functor C D) (F' : functor C' D') (H : functor C' C) (K : functor D' D)*) : UU := nat_trans_data (H ∙ F) (F' ∙ K). End DefDistrLaw. Section OperationsDistrLaws. Definition comp_distr_laws {C C' C'' D D' D'' : category}{F : functor C D}{F' : functor C' D'} {F'' : functor C'' D''}{H : functor C' C}{H' : functor C'' C'}{K : functor D' D}{K' : functor D'' D'} (lambda : DistrLaw F F' H K) (lambda' : DistrLaw F' F'' H' K') : DistrLaw F F'' (H' ∙ H ) (K' ∙ K). Proof. red. apply (nat_trans_comp _ _ _ (α_functors _ _ _)). use (nat_trans_comp _ _ _ _ (α_functors _ _ _)). apply (nat_trans_comp _ _ _ (pre_whisker H' lambda)). apply (nat_trans_comp _ _ _ (α_functors_inv _ _ _)). exact (post_whisker lambda' K). Defined. Definition id_distr_law {C D : category} (F : functor C D) : DistrLaw F F (functor_identity C) (functor_identity D). Proof. red. apply (nat_trans_comp _ _ _ (λ_functors _)). apply ρ_functors_inv. Defined. Lemma comp_distr_laws_assoc {C C' C'' C''' D D' D'' D''' : category} {F : functor C D} {F' : functor C' D'} {F'' : functor C'' D''} {F''' : functor C''' D'''} {H : functor C' C} {H' : functor C'' C'} {H'' : functor C''' C''} {K : functor D' D} {K' : functor D'' D'} {K'' : functor D''' D''} (lambda : DistrLaw F F' H K) (lambda' : DistrLaw F' F'' H' K') (lambda'' : DistrLaw F'' F''' H'' K'') : comp_distr_laws (comp_distr_laws lambda lambda') lambda'' = comp_distr_laws lambda (comp_distr_laws lambda' lambda''). Proof. apply nat_trans_eq_alt. intro c. simpl. repeat rewrite id_left. repeat rewrite id_right. set (aux1 := nat_trans_ax lambda). (*rewrite <- assoc.*) (*Beginning of variant to : rewrite assoc*) eapply pathscomp0. (*etrans.*) { apply pathsinv0. apply assoc. (*End of variant to rewrite*) } apply cancel_precomposition. apply pathsinv0. etrans. { apply functor_comp. } apply cancel_precomposition. apply idpath. Qed. (*lois unitaires : composition avec l'identité, idF neutre à gauche et à droite*) Definition id_distr_law_left {C D : category} (F : functor C D) : ∏ (C' D' : category) (F' : functor C' D') (H : functor C' C) (K : functor D' D) (lambda : DistrLaw F F' H K), comp_distr_laws (id_distr_law F) lambda = lambda. Proof. intros C' D'. intros F' H K. intro lambda. apply nat_trans_eq_alt. intro c. simpl. repeat rewrite id_left. apply id_right. Qed. (* Locate "·". *) Definition id_distr_law_right {C' D' : category} (F' : functor C' D') : ∏ (C D : category) (F : functor C D) (H : functor C' C) (K : functor D' D) (lambda : DistrLaw F F' H K), comp_distr_laws lambda (id_distr_law F') = lambda. Proof. intros C D. intros F H K. intro lambda. apply nat_trans_eq_alt. intro c. simpl. repeat rewrite id_left. rewrite id_right. etrans. { apply cancel_precomposition. apply functor_id. } apply id_right. Qed. End OperationsDistrLaws. Section Conjugates. Lemma adjuncts_mutually_inverse1 {C D : category} {A : D} {B : C} {L : functor D C} {R : functor C D} (h : are_adjoints L R) (f : L A --> B) (g : A --> R B) : f = φ_adj_inv h g -> φ_adj h f = g. Proof. intro p. set (η := unit_from_are_adjoints h). set (ε := counit_from_are_adjoints h). set (triangle_right := triangle_id_right_ad h). change (unit_from_are_adjoints h) with η in triangle_right. change (counit_from_are_adjoints h) with ε in triangle_right. unfold φ_adj. assert (hyp : f = (φ_adj_inv h g)). - exact p. - rewrite hyp. unfold φ_adj_inv. rewrite functor_comp. change (# R (# L g)) with (# (L ∙ R) g). rewrite assoc. set (Hη := nat_trans_ax η). etrans. { apply cancel_postcomposition. apply pathsinv0. apply Hη. } rewrite <- id_right. rewrite <- assoc. apply cancel_precomposition. exact (triangle_right B). Qed. Lemma adjuncts_mutually_inverse2 {C D : category} {A : D} {B : C} {L : functor D C} {R : functor C D} (h : are_adjoints L R) (f : L A --> B) (g : A --> R B) : φ_adj h f = g -> f = φ_adj_inv h g. Proof. intro p. set (η := unit_from_are_adjoints h). set (ε := counit_from_are_adjoints h). set (triangle_left := triangle_id_left_ad h). unfold φ_adj_inv. assert (hyp : g = (φ_adj h f)). - apply pathsinv0. exact p. - rewrite hyp. unfold φ_adj. rewrite functor_comp. change ( # L (# R f)) with (# (R ∙ L) f). rewrite <- assoc. set (Hε := nat_trans_ax ε). apply pathsinv0. etrans. { apply cancel_precomposition. apply Hε. } rewrite <- id_left. rewrite assoc. apply cancel_postcomposition. exact (triangle_left A). Qed. (* Locate "-->". Print φ_adj. Print Adjunctions.φ_adj. *) (* Condition 3.11a in Hinze & Wu *) Definition are_conjugates {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'}{H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : UU := ∏ (A : D) (B : C) (f : (L A) --> B), φ_adj h' (nat_trans_data_from_nat_trans σ A · #H f) = #K (φ_adj h f) · nat_trans_data_from_nat_trans τ B. (* Condition 3.11b in Hinze & Wu *) Definition are_conjugates' {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : UU := ∏ (A : D) (B : C) (g : A --> R B), nat_trans_data_from_nat_trans σ A · #H (φ_adj_inv h g) = φ_adj_inv h' (#K g · nat_trans_data_from_nat_trans τ B ). (* Locate "×". *) Lemma isaprop_are_conjugates {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : isaprop (are_conjugates h h' σ τ). Proof. apply impred; intro d. apply impred; intro c. apply impred; intro f. apply homset_property. Qed. Lemma isaprop_are_conjugates' {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : isaprop (are_conjugates' h h' σ τ). Proof. apply impred; intro d. apply impred; intro c. apply impred; intro g. apply homset_property. Qed. Lemma are_conjugates_is_are_conjugates' {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) (τ : DistrLaw K H R R') : are_conjugates h h' σ τ = are_conjugates' h h' σ τ. Proof. apply propositionalUnivalenceAxiom. - apply isaprop_are_conjugates. - apply isaprop_are_conjugates'. - (* direction from left to right *) red. intro P. red in P. intros A B g. set (hyp := (P A B (φ_adj_inv h g))). apply adjuncts_mutually_inverse2 in hyp. assert (hyp2 : # K (φ_adj h (φ_adj_inv h g)) = # K g). + apply maponpaths. apply φ_adj_after_φ_adj_inv. + apply pathsinv0 in hyp. eapply pathscomp0 in hyp. 2 : { apply maponpaths. apply cancel_postcomposition. apply pathsinv0. apply hyp2. } apply pathsinv0 in hyp. exact hyp. - (* direction from right to left *) red. intro P. red in P. intros A B f. set (hyp := (P A B (φ_adj h f))). apply (adjuncts_mutually_inverse1 h' (pr1 σ A · # H (φ_adj_inv h (φ_adj h f))) (# K (φ_adj h f) · pr1 τ B)) in hyp. eapply pathscomp0 in hyp. 2 : { apply maponpaths. apply cancel_precomposition. apply maponpaths. apply pathsinv0. apply φ_adj_inv_after_φ_adj. } exact hyp. Qed. Definition σ_data_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (τ : DistrLaw K H R R') : DistrLaw_data L' L K H := λ A : D, φ_adj_inv h' (#K (unit_from_are_adjoints h A) · nat_trans_data_from_nat_trans τ (L A)). Lemma is_nat_trans_σ_data_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (τ : DistrLaw K H R R') : is_nat_trans _ _ (σ_data_from_τ h h' τ). Proof. red. intros d d' f. unfold σ_data_from_τ. etrans. { apply pathsinv0. simpl. apply φ_adj_inv_natural_precomp. } (*simpl.*) apply pathsinv0. etrans. { apply pathsinv0. simpl. apply φ_adj_inv_natural_postcomp. } apply maponpaths. apply pathsinv0. etrans. rewrite assoc. (* Variant: set (Kcompax1 := pr2 K). set (Kcompax2 := pr2 (pr2 K)). unfold is_functor in Kcompax1. unfold functor_compax in Kcompax2. apply Kcompax2. *) rewrite <- functor_comp. 2: { set (Hτ := nat_trans_ax τ). change (# R' (# H (# L f))) with ( # (H ∙ R') (#L f)). (*equals by defintion*) (*Variant : replace (# R' (# H (# L f))) with ( # (H ∙ R') (#L f)). + proof that we can replace, ie find a path between the two*) rewrite <- assoc. apply cancel_precomposition. (*exact (Hτ _ _ _).*) apply Hτ. } rewrite assoc. apply cancel_postcomposition. change (# (R ∙ K) (# L f)) with (# K (# (L ∙ R) f)). etrans. 2 : { use functor_comp. } apply maponpaths. (*apply pathsinv0.*) set (Hη := nat_trans_ax (unit_from_are_adjoints h)). apply Hη. Defined. Definition σ_from_τ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (τ : DistrLaw K H R R') : DistrLaw L' L K H. Proof. apply (make_nat_trans _ _ (σ_data_from_τ h h' τ)). apply is_nat_trans_σ_data_from_τ. Defined. Lemma σ_from_τ_is_conjugate {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (hs : has_homsets C') (τ : DistrLaw K H R R') : are_conjugates' h h' (σ_from_τ h h' τ) τ. Proof. red. intros A B g. unfold σ_from_τ. simpl. unfold σ_data_from_τ. set (η := (unit_from_are_adjoints h)). etrans. { apply pathsinv0. apply φ_adj_inv_natural_postcomp. } apply maponpaths. set (Hτ := nat_trans_ax τ). etrans. { rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. apply Hτ. } rewrite assoc. apply cancel_postcomposition. change (# (R ∙ K) (φ_adj_inv h g)) with (# K (# R (φ_adj_inv h g))). etrans. { apply pathsinv0. use functor_comp. } apply maponpaths. (* Locate "·". *) change (nat_trans_data_from_nat_trans η A · # R (φ_adj_inv h g)) with (φ_adj h (φ_adj_inv h g)). apply φ_adj_after_φ_adj_inv. Qed. Definition τ_data_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) : DistrLaw_data K H R R' := λ B : C, φ_adj h' (nat_trans_data_from_nat_trans σ (R B) · #H (counit_from_are_adjoints h B)). Lemma is_nat_trans_τ_data_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) : is_nat_trans _ _ (τ_data_from_σ h h' σ). Proof. red. intros c c' f. unfold τ_data_from_σ. etrans. { apply pathsinv0. simpl. apply φ_adj_natural_precomp. } apply pathsinv0. etrans. { apply pathsinv0. simpl. apply φ_adj_natural_postcomp. } apply maponpaths. etrans. 2: { set (Hσ := nat_trans_ax σ). change (# L' (# K (# R f))) with ( # (K ∙ L') (#R f)). rewrite assoc. apply cancel_postcomposition. apply pathsinv0. apply Hσ. } rewrite <- assoc. rewrite <- functor_comp. rewrite <- assoc. apply cancel_precomposition. change (# (L ∙ H) (# R f)) with (# H (# (R ∙ L) f)). etrans. 2: { apply (functor_comp H). } apply maponpaths. set (Hη := nat_trans_ax (counit_from_are_adjoints h)). apply pathsinv0. apply Hη. Qed. Definition τ_from_σ {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (σ : DistrLaw L' L K H) : DistrLaw K H R R'. Proof. apply (make_nat_trans _ _ (τ_data_from_σ h h' σ)). apply is_nat_trans_τ_data_from_σ. Defined. Lemma τ_from_σ_is_conjugate {C C' D D' : category} {L : functor D C} {R : functor C D} {L' : functor D' C'} {R' : functor C' D'} {H : functor C C'} {K : functor D D' } (h : are_adjoints L R) (h' : are_adjoints L' R') (hs : has_homsets C') (σ : DistrLaw L' L K H) : are_conjugates h h' σ (τ_from_σ h h' σ). Proof. red. intros A B g. unfold τ_from_σ; simpl. unfold τ_data_from_σ. set (ε := (counit_from_are_adjoints h)). etrans. 2: { apply φ_adj_natural_precomp. } apply maponpaths. etrans. 2: { set (Hσ := nat_trans_ax σ). rewrite assoc. apply cancel_postcomposition. apply pathsinv0. apply Hσ. } rewrite <- assoc. apply cancel_precomposition. change (# (L ∙ H) (φ_adj h g)) with (# H (# L (φ_adj h g))). etrans. 2: { apply (functor_comp H). } apply maponpaths. apply pathsinv0. apply φ_adj_inv_after_φ_adj. Qed. End Conjugates. Section Liftings. Definition is_lifting {C D: category} {F: functor C C} {G: functor D D} (H: functor C D) (HH: functor (FunctorAlg F) (FunctorAlg G)): UU. Proof. set (UF := forget_algebras F). set (UG := forget_algebras G). exact (UF ∙ H = HH ∙ UG). Defined. Definition lifting_from_distr_law_data_on_ob {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): FunctorAlg F → FunctorAlg G. Proof. intro Aa. set (A := alg_carrier _ Aa). set (a := alg_map _ Aa). set (B := H A). set (b := nat_trans_data_from_nat_trans lambda A · (# H a)). use tpair. - exact B. - exact b. Defined. Lemma lifting_from_distr_law_data_aux {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H)(Aa Bb : algebra_ob F)(h : algebra_mor F Aa Bb) : is_algebra_mor G (lifting_from_distr_law_data_on_ob lambda Aa) (lifting_from_distr_law_data_on_ob lambda Bb) (#H h). Proof. unfold is_algebra_mor. simpl. set (ax := nat_trans_ax lambda). apply pathsinv0. etrans. { rewrite assoc. apply cancel_postcomposition. apply ax. } rewrite <- assoc. apply pathsinv0. rewrite <- assoc. apply cancel_precomposition. set (h_commutes := algebra_mor_commutes _ _ _ h). rewrite <- functor_comp. apply pathsinv0. change (# (F ∙ H) h) with (# H (# F h)). etrans. { apply pathsinv0. apply (functor_comp H). } apply maponpaths. apply pathsinv0. apply h_commutes. Qed. Definition lifting_from_distr_law_data {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): functor_data (FunctorAlg F) (FunctorAlg G). Proof. use make_functor_data. - apply (lifting_from_distr_law_data_on_ob lambda). - cbn. intros Aa Bb. intro h. unfold algebra_mor. use tpair. + exact (#H (pr1 h)). + apply lifting_from_distr_law_data_aux. Defined. Lemma is_functor_lifting_from_distr_law_data {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): is_functor (lifting_from_distr_law_data lambda). Proof. split. - intro Aa. unfold lifting_from_distr_law_data. cbn. UniMath.MoreFoundations.Tactics.show_id_type. use total2_paths_f. 2: { apply homset_property. } (*Locate algebra_mor_eq.*) (* + assumption. *) cbn. apply functor_id. - intros Aa Bb Cc f g. unfold lifting_from_distr_law_data. cbn. UniMath.MoreFoundations.Tactics.show_id_type. use total2_paths_f. 2: { apply homset_property. } cbn. apply functor_comp. Qed. Definition lifting_from_distr_law {C D: category} {F: functor C C} {G: functor D D} {H: functor C D} (lambda : DistrLaw G F H H): functor (FunctorAlg F) (FunctorAlg G). Proof. use tpair. - apply (lifting_from_distr_law_data lambda). - apply is_functor_lifting_from_distr_law_data. Defined. Lemma lifting_from_distr_law_is_lifting {C D: category} {F: functor C C} {G: functor D D} (H: functor C D) (lambda : DistrLaw G F H H): is_lifting H (lifting_from_distr_law lambda ). Proof. unfold is_lifting. set (Hλ := lifting_from_distr_law lambda). (*UniMath.MoreFoundations.Tactics.show_id_type.*) (*Locate "⟶".*) apply functor_eq. - apply D. - apply idpath. Qed. (** a simple preparation for the next lemma - strictly speaking, not even needed *) Ltac get_sides_of_eq := match goal with |- @paths _ ?L ?R => set (left := L); set (right := R) end. Arguments idtomor {_ _ _ } _. (** unnamed result by Hinze & Wu, mentioned in their Sect. 3.2.1 *) Lemma liftings_from_distr_laws_compose {C C' C'': category} {F: functor C C} {F': functor C' C'} {F'': functor C'' C''} {H: functor C C'} {H': functor C' C''} (lambda : DistrLaw F' F H H)(lambda' : DistrLaw F'' F' H' H'): lifting_from_distr_law lambda ∙ lifting_from_distr_law lambda' = lifting_from_distr_law (H := H ∙ H') (comp_distr_laws lambda' lambda). Proof. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply functor_eq. { apply homset_property. } simpl. (* UniMath.MoreFoundations.Tactics.show_id_type. *) get_sides_of_eq. (* we have to read the expressions back, so as to get functor_data between precategories: *) set (left' := functor_composite_data (lifting_from_distr_law_data lambda) (lifting_from_distr_law_data lambda')). set (right' := lifting_from_distr_law_data (comp_distr_laws lambda' lambda) : functor_data (FunctorAlg F) (FunctorAlg F'')). transparent assert (okonobs: (functor_on_objects left' ~ functor_on_objects right')). { intro alg. cbn. unfold lifting_from_distr_law_data_on_ob. cbn. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (maponpaths (λ p, tpair _ (H' (H (alg_carrier F alg))) p )). abstract ( repeat rewrite id_left; rewrite id_right; rewrite <- assoc; apply maponpaths; apply functor_comp ). } (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (functor_data_eq_from_nat_trans _ _ _ _ okonobs). red. intros alg1 alg2 m. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply algebra_mor_eq. (* { assumption. } *) simpl. (* UniMath.MoreFoundations.Tactics.show_id_type. *) etrans. { apply cancel_precomposition. UniMath.MoreFoundations.Tactics.show_id_type. apply (idtomor_FunctorAlg_commutes _ _ _ (okonobs alg2)). } etrans. 2: { apply cancel_postcomposition. UniMath.MoreFoundations.Tactics.show_id_type. apply pathsinv0. apply (idtomor_FunctorAlg_commutes _ _ _ (okonobs alg1)). } assert (Hyp: (idtomor (maponpaths (alg_carrier F'') (okonobs alg1)) = identity _) × (idtomor (maponpaths (alg_carrier F'') (okonobs alg2)) = identity _)). { unfold okonobs; split. - etrans. { apply maponpaths. apply (maponpathscomp (λ p : C'' ⟦ F'' (H' (H (alg_carrier F alg1))), H' (H (alg_carrier F alg1)) ⟧, tpair (fun X: C'' => C'' ⟦ F'' X, X ⟧) (H' (H (alg_carrier F alg1))) p) (alg_carrier F'')). } unfold funcomp. simpl. rewrite UniMath.MoreFoundations.PartA.maponpaths_for_constant_function. apply idpath. - etrans. { apply maponpaths. apply (maponpathscomp (λ p : C'' ⟦ F'' (H' (H (alg_carrier F alg2))), H' (H (alg_carrier F alg2)) ⟧, tpair (fun X: C'' => C'' ⟦ F'' X, X ⟧) (H' (H (alg_carrier F alg2))) p) (alg_carrier F'')). } unfold funcomp. simpl. rewrite UniMath.MoreFoundations.PartA.maponpaths_for_constant_function. apply idpath. } induction Hyp as [Hyp1 Hyp2]. rewrite Hyp1. rewrite Hyp2. rewrite id_right. apply pathsinv0. apply id_left. Qed. End Liftings. Section AdjointFolds. (* the conclusion of the following theorem is done after the example of [UniMath.SubstitutionSystems.GenMendlerIteration], and its proof is divided in the same way *) Local Notation "↓ f" := (mor_from_algebra_mor _ f) (at level 3, format "↓ f"). (* in Agda mode \downarrow *) Context {C D: category} {L: functor D C} {R: functor C D} (h : are_adjoints L R) {CC: functor C C} {DD: functor D D} (μDD_Initial : Initial (FunctorAlg DD)) {σ: DistrLaw L L DD CC} {τ: DistrLaw DD CC R R} (hh: are_conjugates h h σ τ) {B: C} (b: CC B --> B). Let AF := FunctorAlg CC. Definition AlgConstr (A : C) (a : CC A --> A) : AF. Proof. exists B. exact b. Defined. Let μDD: D := alg_carrier _ (InitialObject μDD_Initial). (* Locate InitialObject. *) Let inDD: DD(μDD) --> μDD := alg_map _ (InitialObject μDD_Initial). Definition traho_of_Hinze_Wu : L μDD --> B. Proof. set (x := φ_adj_inv h ↓(InitialArrow μDD_Initial (lifting_from_distr_law τ (AlgConstr B b)))). exact x. Defined. Definition φ_adj_traho_of_Hinze_Wu : algebra_mor DD (InitialObject μDD_Initial) ((lifting_from_distr_law τ) (AlgConstr B b)). Proof. use tpair. - exact (φ_adj h traho_of_Hinze_Wu). - red. unfold traho_of_Hinze_Wu. rewrite φ_adj_after_φ_adj_inv. apply (algebra_mor_commutes _ _ _ (InitialArrow μDD_Initial (lifting_from_distr_law_data_on_ob τ (AlgConstr B b)))). Defined. Lemma traho_of_Hinze_Wu_ok : #L inDD · traho_of_Hinze_Wu = nat_trans_data_from_nat_trans σ μDD · # CC traho_of_Hinze_Wu · b. Proof. etrans. apply pathsinv0. use φ_adj_inv_after_φ_adj . exact R. exact h. apply pathsinv0. etrans. apply pathsinv0. use φ_adj_inv_after_φ_adj . exact R. exact h. apply maponpaths. etrans. use φ_adj_natural_postcomp. apply pathsinv0. etrans. use φ_adj_natural_precomp. apply pathsinv0. etrans. apply cancel_postcomposition. use hh . rewrite <- assoc. (* set (n := nat_trans_data_from_nat_trans τ B · # R b). set (m := alg_map DD ((lifting_from_distr_law hsC hsD τ) (AlgConstr' B b))). simpl in m. change (nat_trans_data_from_nat_trans τ B · # R b) with m. *) change (nat_trans_data_from_nat_trans τ B · # R b) with (alg_map DD ((lifting_from_distr_law τ) (AlgConstr B b))). (*Locate InitialArrow.*) apply pathsinv0. apply (algebra_mor_commutes DD _ _ φ_adj_traho_of_Hinze_Wu). Qed. Definition φ_adj_h_x (x : C ⟦ L μDD, B ⟧) (Hyp: # DD (φ_adj h x) · alg_map DD ((lifting_from_distr_law τ)(AlgConstr B b)) = inDD · φ_adj h x): algebra_mor DD (InitialObject μDD_Initial) ((lifting_from_distr_law τ) (AlgConstr B b)). Proof. use tpair. - exact (φ_adj h x). - red. apply pathsinv0. apply Hyp. Defined. Lemma φ_adj_h_x_equals_initial_arrow (x : C ⟦ L μDD, B ⟧) : # DD (φ_adj h x) · alg_map DD((lifting_from_distr_law τ)(AlgConstr B b)) = inDD · φ_adj h x -> φ_adj h x = ↓ (InitialArrow μDD_Initial ((lifting_from_distr_law τ) (AlgConstr B b))). Proof. intro Hyp. set (aux := InitialArrowUnique μDD_Initial _ (φ_adj_h_x x Hyp)). (* UniMath.MoreFoundations.Tactics.show_id_type. *) set (aux' := mor_from_algebra_mor _ (φ_adj_h_x x Hyp)). simpl in aux'. change (φ_adj h x) with (mor_from_algebra_mor _ (φ_adj_h_x x Hyp)). rewrite aux. apply idpath. Qed. (** The following formalizes Theorem 5.2 (Adjoint folds) of Hinze and Wu. *) Theorem TheoremOfHinzeAndWu : iscontr (∑ x : L μDD --> B, #L inDD · x = nat_trans_data_from_nat_trans σ μDD · # CC x · b). Proof. red. exists (traho_of_Hinze_Wu,, traho_of_Hinze_Wu_ok). intro t. induction t as [x hyp]. assert (same: x = traho_of_Hinze_Wu). 2: { apply subtypePath. + intro. simpl. apply C. + simpl. exact same. } etrans. { apply pathsinv0. apply (φ_adj_inv_after_φ_adj h). } etrans. 2: { apply (φ_adj_inv_after_φ_adj h). } apply maponpaths. unfold traho_of_Hinze_Wu. rewrite (φ_adj_after_φ_adj_inv h). apply φ_adj_h_x_equals_initial_arrow. simpl. etrans. { rewrite assoc. apply cancel_postcomposition. apply pathsinv0. apply hh. } etrans. { apply pathsinv0. apply φ_adj_natural_postcomp. } etrans. 2 : { apply φ_adj_natural_precomp. } apply maponpaths. apply pathsinv0. exact hyp. Defined. End AdjointFolds. UniMath-20231010/UniMath/CategoryTheory/CategoriesWithBinOps.v000066400000000000000000000033431451125700300240520ustar00rootroot00000000000000(** ** Precategories such that spaces of morphisms have a binary operation *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Section def_precategory_with_binops. (** Definition of precategories such that homs are binops. *) Definition precategoryWithBinOpsData (C : category) : UU := ∏ (x y : C), binop (C⟦x, y⟧). Definition precategoryWithBinOps : UU := ∑ C : category, precategoryWithBinOpsData C. Definition precategoryWithBinOps_precategory (P : precategoryWithBinOps) : category := pr1 P. Coercion precategoryWithBinOps_precategory : precategoryWithBinOps >-> category. Definition make_precategoryWithBinOps (C : category) (H : precategoryWithBinOpsData C) : precategoryWithBinOps := tpair _ C H. (** Gives the binop of the homs from x to y. *) Definition to_binop {BC : precategoryWithBinOps} (x y : BC) : binop (BC⟦x, y⟧) := (pr2 BC) x y. End def_precategory_with_binops. Definition oppositePrecategoryWithBinOps (M : precategoryWithBinOps) : precategoryWithBinOps := make_precategoryWithBinOps (op_category M) (λ A B f g, @to_binop M (rm_opp_ob B) (rm_opp_ob A) (rm_opp_mor f) (rm_opp_mor g)). Definition induced_precategoryWithBinOps (M : precategoryWithBinOps) {X:Type} (j : X -> ob M) : precategoryWithBinOps. Proof. exists (induced_category M j). intros a b. exact (@to_binop M (j a) (j b)). Defined. UniMath-20231010/UniMath/CategoryTheory/CategoryEquality.v000066400000000000000000000152631451125700300233150ustar00rootroot00000000000000(* ----------------------------------------------------------------------------------- *) (** ** Equality of precategories Goal: two precategories are equal iff we have an isomorphism between them. We use a chain of equivalences. Each step refines the data a bit. *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.catiso. Local Open Scope cat. (** Step 1 *) Definition path_precat (C D : precategory) (HD : has_homsets D) : C = D ≃ precategory_data_from_precategory C = D. Proof. refine (path_sigma_hprop _ _ _ _). apply isaprop_is_precategory. apply HD. Defined. (** Step 2 *) Definition data_cat_eq_1 (C D : precategory_data) (Fo : (ob C) = ob D) : UU := transportf (λ z, z → z → UU) Fo (@precategory_morphisms C) = @precategory_morphisms D. Definition cat_eq_1 (C D : precategory_data) : UU := ∑ (F : ∑ (Fo : ob C = ob D), data_cat_eq_1 C D Fo), (pr1 (transportf (λ x, precategory_id_comp x) (total2_paths_f (pr1 F) (pr2 F)) (pr2 C)) = pr1 (pr2 D)) × pr2 (transportf (λ x, precategory_id_comp x) (total2_paths_f (pr1 F) (pr2 F)) (pr2 C)) = pr2(pr2 D). Definition cat_path_to_cat_eq_1 (C D : precategory_data) : C = D ≃ cat_eq_1 C D. Proof. refine (_ ∘ total2_paths_equiv _ _ _)%weq. use weqbandf. - apply total2_paths_equiv. - intro p ; cbn. induction C as [C HC]. induction D as [D HD]. cbn in *. induction p ; cbn. refine (_ ∘ total2_paths_equiv _ _ _)%weq. use weqfibtototal. intros p. cbn. rewrite transportf_const. exact (idweq _). Defined. (** Step 3 *) Definition data_cat_eq_2 (C D : precategory_data) (Fo : (ob C) = ob D) : UU := ∏ (a b : ob C), C⟦a,b⟧ = D⟦eqweqmap Fo a,eqweqmap Fo b⟧. Definition cat_eq_2 (C D : precategory_data) : UU := ∑ (F : ∑ (Fo : ob C = ob D), data_cat_eq_2 C D Fo), (∏ (a : C), eqweqmap (pr2 F a a) (identity a) = identity (eqweqmap (pr1 F) a)) × (∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧), eqweqmap (pr2 F a c) (f · g) = eqweqmap (pr2 F a b) f · eqweqmap (pr2 F b c) g). Definition data_cat_eq_1_to_2 (C D : precategory_data) (Fo : (ob C) = ob D) : data_cat_eq_1 C D Fo ≃ data_cat_eq_2 C D Fo. Proof. induction C as [C HC]. induction C as [CO CM]. induction D as [D HD]. induction D as [DO DM]. cbn in *. induction Fo. unfold data_cat_eq_1, data_cat_eq_2. cbn. refine (_ ∘ weqtoforallpaths _ _ _)%weq. use weqonsecfibers. intros x. exact (weqtoforallpaths _ _ _)%weq. Defined. Definition cat_eq_1_to_cat_eq_2 (C D : precategory_data) (DS : ∏ (x y : D), isaset (precategory_morphisms x y)) : cat_eq_1 C D ≃ cat_eq_2 C D. Proof. use weqbandf. - use weqfibtototal. intro p. exact (data_cat_eq_1_to_2 C D p). - intros p. induction C as [C HC]. induction C as [CO CM]. induction HC as [CI CC]. induction D as [D HD]. induction D as [DO DM]. induction HD as [DI DC]. induction p as [p1 p2] ; cbn in *. unfold data_cat_eq_1 in p2. induction p1 ; cbn in *. induction p2 ; cbn. use weqdirprodf. + use weqimplimpl. * intros f a. induction f. reflexivity. * intros f. apply funextsec. intro z. apply f. * intro. apply impred_isaset. intro. apply DS. * apply impred. intro. apply DS. + use weqimplimpl. * intros p. induction p. reflexivity. * intros p. apply funextsec ; intro a. apply funextsec ; intro b. apply funextsec ; intro c. apply funextsec ; intro f. apply funextsec ; intro g. specialize (p a b c f g). induction p. reflexivity. * repeat (apply impred_isaset ; intro). apply DS. * repeat (apply impred ; intro). apply DS. Defined. (** Step 4 *) Definition cat_equiv (C D : precategory_data) : UU := ∑ (F : ∑ (Fo : ob C ≃ D), ∏ (a b : ob C), C⟦a,b⟧ ≃ D⟦Fo a,Fo b⟧), (∏ (a : C), (pr2 F) a a (identity a) = identity (pr1 F a)) × (∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧), pr2 F a c (f · g) = pr2 F a b f · pr2 F b c g). Definition weq_cat_eq_cat_equiv (C D : precategory_data) : cat_eq_2 C D ≃ cat_equiv C D. Proof. use weqbandf. - use weqbandf. + apply univalence. + intros p. unfold data_cat_eq_2. use weqonsecfibers. intros x. use weqonsecfibers. intros y. apply univalence. - intros q. apply idweq. Defined. (** Step 5 *) Definition cat_equiv_to_catiso (C D : precategory_data) : cat_equiv C D → catiso C D. Proof. intros F. use tpair. - use tpair. + use tpair. * exact (pr1(pr1 F)). * exact (pr2(pr1 F)). + split. * exact (pr1(pr2 F)). * exact (pr2(pr2 F)). - split. + intros a b. apply (pr2(pr1 F)). + apply (pr1(pr1 F)). Defined. Definition catiso_to_cat_equiv (C D : precategory_data) : catiso C D → cat_equiv C D. Proof. intros F. use tpair. - use tpair. + use make_weq. * exact (functor_on_objects F). * apply F. + intros a b. use make_weq. * exact (functor_on_morphisms F). * apply F. - split. + exact (functor_id F). + exact (@functor_comp _ _ F). Defined. Definition cat_equiv_to_catiso_weq (C D : precategory) : cat_equiv C D ≃ catiso C D. Proof. refine (cat_equiv_to_catiso C D ,, _). use isweq_iso. - exact (catiso_to_cat_equiv C D). - reflexivity. - reflexivity. Defined. (** All in all, we get *) Definition catiso_is_path_precat (C D : precategory) (HD : has_homsets D) : C = D ≃ catiso C D := ((cat_equiv_to_catiso_weq C D) ∘ weq_cat_eq_cat_equiv C D ∘ cat_eq_1_to_cat_eq_2 C D HD ∘ cat_path_to_cat_eq_1 C D ∘ path_precat C D HD)%weq. Definition catiso_is_path_cat (C D : category) : C = D ≃ catiso C D. Proof. refine (catiso_is_path_precat _ _ (homset_property D) ∘ _)%weq. refine (path_sigma_hprop _ _ _ _). apply isaprop_has_homsets. Defined. UniMath-20231010/UniMath/CategoryTheory/CategorySum.v000066400000000000000000000375351451125700300222720ustar00rootroot00000000000000(******************************************************************* Sums of categories We discuss sums of categories and their universal property Contents: 1. Definition of sums of categories 2. Universal property for functors 3. Universal property for natural transformations *******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. (** 1. Definition of sums of categories *) Definition bincoprod_of_precategory_ob_mor (C₁ C₂ : category) : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact (C₁ ⨿ C₂). - intros z₁ z₂. induction z₁ as [ x₁ | y₁ ], z₂ as [ x₂ | y₂ ]. + exact (x₁ --> x₂). + exact ∅. + exact ∅. + exact (y₁ --> y₂). Defined. Definition bincoprod_of_precategory_data (C₁ C₂ : category) : precategory_data. Proof. use make_precategory_data. - exact (bincoprod_of_precategory_ob_mor C₁ C₂). - intro z ; induction z as [ x | y ]. + exact (identity x). + exact (identity y). - intros z₁ z₂ z₃ f g ; induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; induction z₃ as [ x₃ | y₃ ] ; cbn in *. + exact (f · g). + exact (fromempty g). + exact (fromempty g). + exact (fromempty f). + exact (fromempty f). + exact (fromempty f). + exact (fromempty g). + exact (f · g). Defined. Definition bincoprod_of_is_precategory (C₁ C₂ : category) : is_precategory (bincoprod_of_precategory_data C₁ C₂). Proof. use make_is_precategory. - intros z₁ z₂ f. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. + apply id_left. + exact (fromempty f). + exact (fromempty f). + apply id_left. - intros z₁ z₂ f. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. + apply id_right. + exact (fromempty f). + exact (fromempty f). + apply id_right. - intros z₁ z₂ z₃ z₄ f g h ; induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; induction z₃ as [ x₃ | y₃ ] ; induction z₄ as [ x₄ | y₄ ] ; cbn in * ; try (apply (fromempty f)) ; try (apply (fromempty g)) ; try (apply (fromempty h)). + apply assoc. + apply assoc. - intros z₁ z₂ z₃ z₄ f g h ; induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; induction z₃ as [ x₃ | y₃ ] ; induction z₄ as [ x₄ | y₄ ] ; cbn in * ; try (apply (fromempty f)) ; try (apply (fromempty g)) ; try (apply (fromempty h)). + apply assoc'. + apply assoc'. Qed. Definition bincoprod_of_precategory (C₁ C₂ : category) : precategory. Proof. use make_precategory. - exact (bincoprod_of_precategory_data C₁ C₂). - exact (bincoprod_of_is_precategory C₁ C₂). Defined. Definition bincoprod_of_category_has_homsets (C₁ C₂ : category) : has_homsets (bincoprod_of_precategory_ob_mor C₁ C₂). Proof. intros z₁ z₂. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. - apply homset_property. - apply isasetempty. - apply isasetempty. - apply homset_property. Defined. Definition bincoprod_of_category (C₁ C₂ : category) : category. Proof. use make_category. - exact (bincoprod_of_precategory C₁ C₂). - exact (bincoprod_of_category_has_homsets C₁ C₂). Defined. Definition inl_iso_map {C₁ C₂ : category} {x₁ x₂ : C₁} (f : z_iso x₁ x₂) : @z_iso (bincoprod_of_category C₁ C₂) (inl x₁) (inl x₂). Proof. use make_z_iso. - exact f. - exact (inv_from_z_iso f). - split. + exact (z_iso_inv_after_z_iso f). + exact (z_iso_after_z_iso_inv f). Defined. Definition inl_iso_inv {C₁ C₂ : category} {x₁ x₂ : C₁} (f : @z_iso (bincoprod_of_category C₁ C₂) (inl x₁) (inl x₂)) : z_iso x₁ x₂. Proof. use make_z_iso. - exact f. - exact (inv_from_z_iso f). - split. + exact (z_iso_inv_after_z_iso f). + exact (z_iso_after_z_iso_inv f). Defined. Definition inl_iso {C₁ C₂ : category} (x₁ x₂ : C₁) : z_iso x₁ x₂ ≃ @z_iso (bincoprod_of_category C₁ C₂) (inl x₁) (inl x₂). Proof. use make_weq. - exact inl_iso_map. - use isweq_iso. + exact inl_iso_inv. + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. Definition inr_iso_map {C₁ C₂ : category} {x₁ x₂ : C₂} (f : z_iso x₁ x₂) : @z_iso (bincoprod_of_category C₁ C₂) (inr x₁) (inr x₂). Proof. use make_z_iso. - exact f. - exact (inv_from_z_iso f). - split. + exact (z_iso_inv_after_z_iso f). + exact (z_iso_after_z_iso_inv f). Defined. Definition inr_iso_inv {C₁ C₂ : category} {x₁ x₂ : C₂} (f : @z_iso (bincoprod_of_category C₁ C₂) (inr x₁) (inr x₂)) : z_iso x₁ x₂. Proof. use make_z_iso. - exact f. - exact (inv_from_z_iso f). - split. + exact (z_iso_inv_after_z_iso f). + exact (z_iso_after_z_iso_inv f). Defined. Definition inr_iso {C₁ C₂ : category} (x₁ x₂ : C₂) : z_iso x₁ x₂ ≃ @z_iso (bincoprod_of_category C₁ C₂) (inr x₁) (inr x₂). Proof. use make_weq. - exact inr_iso_map. - use isweq_iso. + exact inr_iso_inv. + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. Definition idtoiso_in_bincoprod_inl {C₁ C₂ : category} {x₁ x₂ : C₁} (p : x₁ = x₂) : pr1 (idtoiso p) = pr1 (@idtoiso (bincoprod_of_category C₁ C₂) (inl x₁) (inl x₂) (maponpaths inl p)). Proof. induction p ; cbn. apply idpath. Qed. Definition idtoiso_in_bincoprod_inr {C₁ C₂ : category} {x₁ x₂ : C₂} (p : x₁ = x₂) : pr1 (idtoiso p) = pr1 (@idtoiso (bincoprod_of_category C₁ C₂) (inr x₁) (inr x₂) (maponpaths inr p)). Proof. induction p ; cbn. apply idpath. Qed. Definition is_univalent_bincoprod_of_category {C₁ C₂ : category} (HC₁ : is_univalent C₁) (HC₂ : is_univalent C₂) : is_univalent (bincoprod_of_category C₁ C₂). Proof. intros z₁ z₂. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. - use weqhomot. + exact (inl_iso x₁ x₂ ∘ make_weq _ (HC₁ x₁ x₂) ∘ paths_inl_inl_equiv x₁ x₂)%weq. + abstract (intro p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; cbn -[equality_by_case] ; refine (@idtoiso_in_bincoprod_inl C₁ C₂ _ _ (paths_inl_inl_equiv _ _ _) @ _) ; do 2 apply maponpaths ; apply (homotinvweqweq (paths_inl_inl_equiv _ _))). - use isweq_iso. + exact (λ f, fromempty (pr1 f)). + intro p ; cbn. exact (fromempty (negpathsii1ii2 _ _ p)). + intro p ; cbn. exact (fromempty (pr1 p)). - use isweq_iso. + exact (λ f, fromempty (pr1 f)). + intro p ; cbn. exact (fromempty (negpathsii2ii1 _ _ p)). + intro p ; cbn. exact (fromempty (pr1 p)). - use weqhomot. + exact (inr_iso y₁ y₂ ∘ make_weq _ (HC₂ y₁ y₂) ∘ paths_inr_inr_equiv y₁ y₂)%weq. + abstract (intro p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; cbn -[equality_by_case] ; refine (@idtoiso_in_bincoprod_inr C₁ C₂ _ _ (paths_inr_inr_equiv _ _ _) @ _) ; do 2 apply maponpaths ; apply (homotinvweqweq (paths_inr_inr_equiv _ _))). Defined. Definition bincoprod_of_univalent_category (C₁ C₂ : univalent_category) : univalent_category. Proof. use make_univalent_category. - exact (bincoprod_of_category C₁ C₂). - use is_univalent_bincoprod_of_category. + apply C₁. + apply C₂. Defined. (** 2. Universal property for functors *) Definition inl_functor_data (C₁ C₂ : category) : functor_data C₁ (bincoprod_of_category C₁ C₂). Proof. use make_functor_data. - exact (λ x, inl x). - exact (λ _ _ f, f). Defined. Definition inl_is_functor (C₁ C₂ : category) : is_functor (inl_functor_data C₁ C₂). Proof. split ; intro ; intros ; cbn. - apply idpath. - apply idpath. Qed. Definition inl_functor (C₁ C₂ : category) : C₁ ⟶ bincoprod_of_category C₁ C₂. Proof. use make_functor. - exact (inl_functor_data C₁ C₂). - exact (inl_is_functor C₁ C₂). Defined. Definition fully_faithful_inl_functor (C₁ C₂ : category) : fully_faithful (inl_functor C₁ C₂). Proof. intros x y. apply idisweq. Defined. Definition inr_functor_data (C₁ C₂ : category) : functor_data C₂ (bincoprod_of_category C₁ C₂). Proof. use make_functor_data. - exact (λ x, inr x). - exact (λ _ _ f, f). Defined. Definition inr_is_functor (C₁ C₂ : category) : is_functor (inr_functor_data C₁ C₂). Proof. split ; intro ; intros ; cbn. - apply idpath. - apply idpath. Qed. Definition inr_functor (C₁ C₂ : category) : C₂ ⟶ bincoprod_of_category C₁ C₂. Proof. use make_functor. - exact (inr_functor_data C₁ C₂). - exact (inr_is_functor C₁ C₂). Defined. Definition fully_faithful_inr_functor (C₁ C₂ : category) : fully_faithful (inr_functor C₁ C₂). Proof. intros x y. apply idisweq. Defined. Definition sum_of_functors_data {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : functor_data (bincoprod_of_category C₁ C₂) Q. Proof. use make_functor_data. - intro z. induction z as [ x | y ]. + exact (F x). + exact (G y). - intros z₁ z₂ f. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. + exact (#F f). + exact (fromempty f). + exact (fromempty f). + exact (#G f). Defined. Definition sum_of_functors_is_functor {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : is_functor (sum_of_functors_data F G). Proof. split. - intro z. induction z as [ x | y ] ; cbn. + apply functor_id. + apply functor_id. - intros z₁ z₂ z₃ f g. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; induction z₃ as [ x₃ | y₃ ] ; cbn ; try (apply (fromempty f)) ; try (apply (fromempty g)). + apply functor_comp. + apply functor_comp. Qed. Definition sum_of_functors {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : bincoprod_of_category C₁ C₂ ⟶ Q. Proof. use make_functor. - exact (sum_of_functors_data F G). - exact (sum_of_functors_is_functor F G). Defined. Definition sum_of_functor_inl {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : inl_functor C₁ C₂ ∙ sum_of_functors F G ⟹ F. Proof. use make_nat_trans. - exact (λ z, identity _). - abstract (intros x₁ x₂ f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition sum_of_functor_inl_is_nat_z_iso {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : is_nat_z_iso (sum_of_functor_inl F G). Proof. intro. apply identity_is_z_iso. Defined. Definition sum_of_functor_inl_nat_z_iso {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : nat_z_iso (inl_functor C₁ C₂ ∙ sum_of_functors F G) F. Proof. use make_nat_z_iso. - exact (sum_of_functor_inl F G). - exact (sum_of_functor_inl_is_nat_z_iso F G). Defined. Definition sum_of_functor_inr {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : inr_functor C₁ C₂ ∙ sum_of_functors F G ⟹ G. Proof. use make_nat_trans. - exact (λ z, identity _). - abstract (intros x₁ x₂ f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition sum_of_functor_inr_is_nat_z_iso {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : is_nat_z_iso (sum_of_functor_inr F G). Proof. intro. apply identity_is_z_iso. Defined. Definition sum_of_functor_inr_nat_z_iso {Q C₁ C₂ : category} (F : C₁ ⟶ Q) (G : C₂ ⟶ Q) : nat_z_iso (inr_functor C₁ C₂ ∙ sum_of_functors F G) G. Proof. use make_nat_z_iso. - exact (sum_of_functor_inr F G). - exact (sum_of_functor_inr_is_nat_z_iso F G). Defined. (** 3. Universal property for natural transformations *) Definition sum_of_nat_trans_data {Q C₁ C₂ : category} {F G : bincoprod_of_category C₁ C₂ ⟶ Q} (α : inl_functor C₁ C₂ ∙ F ⟹ inl_functor C₁ C₂ ∙ G) (β : inr_functor C₁ C₂ ∙ F ⟹ inr_functor C₁ C₂ ∙ G) : nat_trans_data F G. Proof. intros z. induction z as [ x | y ]. - exact (α x). - exact (β y). Defined. Definition sum_of_nat_trans_is_nat_trans {Q C₁ C₂ : category} {F G : bincoprod_of_category C₁ C₂ ⟶ Q} (α : inl_functor C₁ C₂ ∙ F ⟹ inl_functor C₁ C₂ ∙ G) (β : inr_functor C₁ C₂ ∙ F ⟹ inr_functor C₁ C₂ ∙ G) : is_nat_trans _ _ (sum_of_nat_trans_data α β). Proof. intros z₁ z₂ f. induction z₁ as [ x₁ | y₁ ] ; induction z₂ as [ x₂ | y₂ ] ; cbn. - exact (nat_trans_ax α _ _ f). - exact (fromempty f). - exact (fromempty f). - exact (nat_trans_ax β _ _ f). Qed. Definition sum_of_nat_trans {Q C₁ C₂ : category} {F G : bincoprod_of_category C₁ C₂ ⟶ Q} (α : inl_functor C₁ C₂ ∙ F ⟹ inl_functor C₁ C₂ ∙ G) (β : inr_functor C₁ C₂ ∙ F ⟹ inr_functor C₁ C₂ ∙ G) : F ⟹ G. Proof. use make_nat_trans. - exact (sum_of_nat_trans_data α β). - exact (sum_of_nat_trans_is_nat_trans α β). Defined. Definition sum_of_nat_trans_inl {Q C₁ C₂ : category} {F G : bincoprod_of_category C₁ C₂ ⟶ Q} (α : inl_functor C₁ C₂ ∙ F ⟹ inl_functor C₁ C₂ ∙ G) (β : inr_functor C₁ C₂ ∙ F ⟹ inr_functor C₁ C₂ ∙ G) : pre_whisker (inl_functor_data _ _) (sum_of_nat_trans α β) = α. Proof. use nat_trans_eq. { apply homset_property. } intro. apply idpath. Qed. Definition sum_of_nat_trans_inr {Q C₁ C₂ : category} {F G : bincoprod_of_category C₁ C₂ ⟶ Q} (α : inl_functor C₁ C₂ ∙ F ⟹ inl_functor C₁ C₂ ∙ G) (β : inr_functor C₁ C₂ ∙ F ⟹ inr_functor C₁ C₂ ∙ G) : pre_whisker (inr_functor_data _ _) (sum_of_nat_trans α β) = β. Proof. use nat_trans_eq. { apply homset_property. } intro. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/Chains/000077500000000000000000000000001451125700300210315ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Chains/Adamek.v000066400000000000000000000147401451125700300224100ustar00rootroot00000000000000(** * Adámek's theorem The main result is Adámek's theorem for constructing initial algebras of omega-cocontinuous functors ([colimAlgIsInitial]) which is used to construct inductive types. Written by: Anders Mörtberg and Benedikt Ahrens, 2015-2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Chains.Chains. Local Open Scope cat. (** * Adámek's theorem for constructing initial algebras of omega-cocontinuous functors *) (** This section proves that (L,α : F L -> L) is the initial algebra where L is the colimit of the initial chain: << ! F ! F^2 ! 0 -----> F 0 ------> F^2 0 --------> F^3 0 ---> ... >> This result is also known as Adámek's theorem % \cite{Adamek1974}: \par % https://ncatlab.org/nlab/show/initial+algebra+of+an+endofunctor#AdameksTheorem Adámek, Jiří. "Free algebras and automata realizations in the language of categories." Commentationes Mathematicae Universitatis Carolinae 015.4 (1974): 589-602. *) Section colim_initial_algebra. Context {C : category} (InitC : Initial C). (* It is important that these are not packaged together as it is sometimes necessary to control how opaque HF is. See [isalghom_pr1foldr] in Lists.v *) Context {F : functor C C} (HF : is_omega_cocont F). Let Fchain : chain C := initChain InitC F. Variable (CC : ColimCocone Fchain). Let L : C := colim CC. Let FFchain : chain C := mapchain F Fchain. Let Fa : cocone FFchain (F L) := mapcocone F _ (colimCocone CC). Let FHC' : isColimCocone FFchain (F L) Fa := HF Fchain L (colimCocone CC) (isColimCocone_from_ColimCocone CC). Let FHC : ColimCocone FFchain := make_ColimCocone _ _ _ FHC'. Local Definition shiftCocone : cocone FFchain L. Proof. use make_cocone. - intro n; apply (coconeIn (colimCocone CC) (S n)). - abstract (intros m n e; destruct e ; apply (coconeInCommutes (colimCocone CC) (S m) _ (idpath _))). Defined. Local Definition unshiftCocone (x : C) (cc : cocone FFchain x) : cocone Fchain x. Proof. use make_cocone. - simpl; intro n. induction n as [|n]; simpl. + apply InitialArrow. + apply (coconeIn cc _). - abstract (simpl; intros m n e; destruct e; destruct m as [|m]; [ apply InitialArrowUnique | apply (coconeInCommutes cc m _ (idpath _))]). Defined. Local Definition shiftIsColimCocone : isColimCocone FFchain L shiftCocone. Proof. intros x cc; simpl. use tpair. + use tpair. * apply colimArrow, (unshiftCocone _ cc). * abstract (intro n; apply (colimArrowCommutes CC x (unshiftCocone x cc) (S n))). + abstract (intros p; apply subtypePath; [ intro f; apply impred; intro; apply homset_property | apply colimArrowUnique; intro n; destruct n as [|n]; [ apply InitialArrowUnique | apply (pr2 p) ]]). Defined. Local Definition shiftColimCocone : ColimCocone FFchain := make_ColimCocone FFchain L shiftCocone shiftIsColimCocone. Definition colim_algebra_mor : C⟦F L,L⟧ := colimArrow FHC L shiftCocone. Local Definition is_z_iso_colim_algebra_mor : is_z_isomorphism colim_algebra_mor := isColim_is_z_iso _ FHC _ _ shiftIsColimCocone. Let α : z_iso (F L) L := make_z_iso' _ is_z_iso_colim_algebra_mor. Let α_inv : z_iso L (F L) := z_iso_inv_from_z_iso α. Let α_alg : algebra_ob F := tpair (λ X : C, C ⟦ F X, X ⟧) L α. Lemma unfold_inv_from_z_iso_α : inv_from_z_iso α = colimArrow shiftColimCocone _ (colimCocone FHC). Proof. apply idpath. Qed. (** Given an algebra: << a F A ------> A >> we now define an algebra morphism ad: << α F L ------> L | | | | ad | | V a V F A ------> A >> *) Section algebra_mor. Variable (Aa : algebra_ob F). Local Notation A := (alg_carrier _ Aa). Local Notation a := (alg_map _ Aa). Local Definition cocone_over_alg (n : nat) : C ⟦ dob Fchain n, A ⟧. Proof. induction n as [|n Fn]; simpl. - now apply InitialArrow. - now apply (# F Fn · a). Defined. (* a_n : F^n 0 -> A *) Local Notation an := cocone_over_alg. (* This makes Coq not unfold dmor during simpl *) Arguments dmor : simpl never. Lemma isCoconeOverAlg n Sn (e : edge n Sn) : dmor Fchain e · an Sn = an n. Proof. destruct e. induction n as [|n IHn]. - now apply InitialArrowUnique. - simpl; rewrite assoc. apply cancel_postcomposition, pathsinv0. eapply pathscomp0; [|simpl; apply functor_comp]. now apply maponpaths, pathsinv0, IHn. Qed. (* ad = a† = a dagger *) Local Definition ad : C⟦L,A⟧. Proof. apply colimArrow. use make_cocone. - apply cocone_over_alg. - red; apply isCoconeOverAlg. Defined. Lemma ad_is_algebra_mor : is_algebra_mor _ α_alg Aa ad. Proof. apply pathsinv0, z_iso_inv_to_left, colimArrowUnique; simpl; intro n. destruct n as [|n]. - now apply InitialArrowUnique. - rewrite assoc, unfold_inv_from_z_iso_α. eapply pathscomp0; [apply cancel_postcomposition, (colimArrowCommutes shiftColimCocone)|]. simpl; rewrite assoc, <- functor_comp. apply cancel_postcomposition, maponpaths, (colimArrowCommutes CC). Qed. Local Definition ad_mor : algebra_mor F α_alg Aa := tpair _ _ ad_is_algebra_mor. End algebra_mor. Lemma colimAlgIsInitial_subproof (Aa : category_FunctorAlg F) (Fa' : algebra_mor F α_alg Aa) : Fa' = ad_mor Aa. Proof. apply algebra_mor_eq; simpl. apply colimArrowUnique; simpl; intro n. destruct Fa' as [f hf]; simpl. unfold is_algebra_mor in hf; simpl in hf. induction n as [|n IHn]; simpl. - now apply InitialArrowUnique. - rewrite <- IHn, functor_comp, <- assoc. eapply pathscomp0; [| eapply maponpaths; apply hf]. rewrite assoc. apply cancel_postcomposition, pathsinv0, (z_iso_inv_to_right _ _ _ _ α). rewrite unfold_inv_from_z_iso_α; apply pathsinv0. now eapply pathscomp0; [apply (colimArrowCommutes shiftColimCocone)|]. Qed. Lemma colimAlgIsInitial : isInitial (category_FunctorAlg F) α_alg. Proof. apply make_isInitial; intros Aa. exists (ad_mor Aa). apply colimAlgIsInitial_subproof. Defined. Definition colimAlgInitial : Initial (category_FunctorAlg F) := make_Initial _ colimAlgIsInitial. End colim_initial_algebra. UniMath-20231010/UniMath/CategoryTheory/Chains/All.v000066400000000000000000000003431451125700300217300ustar00rootroot00000000000000Require Export UniMath.CategoryTheory.Chains.Chains. Require Export UniMath.CategoryTheory.Chains.Cochains. Require Export UniMath.CategoryTheory.Chains.Adamek. Require Export UniMath.CategoryTheory.Chains.OmegaCocontFunctors. UniMath-20231010/UniMath/CategoryTheory/Chains/Chains.v000066400000000000000000000101621451125700300224250ustar00rootroot00000000000000(** * Chains Chains are diagrams of the form X₀ → X₁ → ⋯. Authors: Anders Mörtberg and Benedikt Ahrens, 2015-2016 *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.initial. Local Open Scope cat. (** Define the chain: << 0 --> 1 --> 2 --> 3 --> ... >> with exactly one arrow from n to S n. *) Definition nat_graph : graph := make_graph nat (λ m n, 1 + m = n). Notation "'chain'" := (diagram nat_graph). Definition mapchain {C D : category} (F : functor C D) (c : chain C) : chain D := mapdiagram F c. (** Any i < j gives a morphism in the chain via composition *) Definition chain_mor {C : category} (c : chain C) {i j} : i < j -> C⟦dob c i, dob c j⟧. Proof. induction j as [|j IHj]. - intros Hi0; destruct (negnatlthn0 0 Hi0). - intros Hij. destruct (natlehchoice4 _ _ Hij) as [|H]. + apply (IHj h · dmor c (idpath (S j))). + apply dmor, (maponpaths S H). Defined. (** For any cocone `cc` under the chain, the following diagram commutes: << c i --> c j | | | V +----> cc >> *) Lemma chain_mor_coconeIn {C : category} (c : chain C) (x : C) (cc : cocone c x) i : ∏ j (Hij : i < j), chain_mor c Hij · coconeIn cc j = coconeIn cc i. Proof. induction j as [|j IHj]. - intros Hi0; destruct (negnatlthn0 _ Hi0). - intros Hij; simpl. destruct (natlehchoice4 _ _ Hij). + rewrite <- (IHj h), <- assoc. apply maponpaths, coconeInCommutes. + destruct p. apply coconeInCommutes. Qed. (** One of the hypotheses of this lemma is redundant, however when stated this way the lemma can be used for any two proofs making it easier to apply. *) Lemma chain_mor_right {C : category} {c : chain C} {i j} (Hij : i < j) (HSij : S i < j) : dmor c (idpath (S i)) · chain_mor c HSij = chain_mor c Hij. Proof. induction j as [|j IHj]. - destruct (negnatlthn0 _ Hij). - simpl. destruct (natlehchoice4 _ _ Hij). + destruct (natlehchoice4 _ _ HSij). * now rewrite <- (IHj h h0), assoc. * destruct p; simpl. destruct (natlehchoice4 _ _ h); [destruct (isirreflnatlth _ h0)|]. apply cancel_postcomposition, maponpaths, isasetnat. + destruct p, (isirreflnatlth _ HSij). Qed. (** See comment for [chain_mor_right] about the redundant hypothesis *) Lemma chain_mor_left {C : category} {c : chain C} {i j} (Hij : i < j) (HiSj : i < S j) : chain_mor c Hij · dmor c (idpath (S j)) = chain_mor c HiSj. Proof. destruct j. - destruct (negnatlthn0 _ Hij). - simpl; destruct (natlehchoice4 i (S j) HiSj). + destruct (natlehchoice4 _ _ h). * destruct (natlehchoice4 _ _ Hij); [|destruct p, (isirreflnatlth _ h0)]. apply cancel_postcomposition, cancel_postcomposition, maponpaths, isasetbool. * destruct p; simpl. destruct (natlehchoice4 _ _ Hij); [destruct (isirreflnatlth _ h0)|]. apply cancel_postcomposition, maponpaths, isasetnat. + generalize Hij; rewrite p in Hij. intros H; destruct(isirreflnatlth (S j)). rewrite p in H; exact H. Qed. (** Construct the chain: << ! F! F^2 ! 0 -----> F 0 ------> F^2 0 --------> F^3 0 ---> ... >> *) Definition initChain {C : category} (InitC : Initial C) (F : functor C C) : chain C. Proof. exists (λ n, iter_functor F n InitC). intros m n Hmn. destruct Hmn. simpl. induction m as [|m IHm]; simpl. - exact (InitialArrow InitC _). - exact (# F IHm). Defined. (** ** Definition of (ω-)cocontinuous functors *) Section cocont. Context {C D : category} (F : functor C D). Definition is_cocont : UU := ∏ (g : graph) (d : diagram g C) (L : C) (cc : cocone d L), preserves_colimit F d L cc. Definition is_omega_cocont : UU := ∏ (c : chain C) (L : C) (cc : cocone c L), preserves_colimit F c L cc. End cocont. Definition omega_cocont_functor (C D : category) : UU := ∑ (F : functor C D), is_omega_cocont F. UniMath-20231010/UniMath/CategoryTheory/Chains/CoAdamek.v000066400000000000000000000145601451125700300226720ustar00rootroot00000000000000(** * Adámek's theorem The main result is Adámek's theorem for constructing terminal coalgebras of omega-continuous functors which is used to construct coinductive types. Written by: Kobe Wullaert, 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorCoalgebras. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Cochains. Local Open Scope cat. Section lim_terminal_coalgebra. Context {C : category} (TerminalC : Terminal C). Context {F : functor C C} (HF : is_omega_cont F). Let Fcochain : cochain C := termCochain TerminalC F. Variable (CC : LimCone Fcochain). Let L : C := lim CC. Let FFcochain : cochain C := mapcochain F Fcochain. Let Fa : cone FFcochain (F L) := mapcone F _ (limCone CC). Let FHC' : isLimCone FFcochain (F L) Fa := HF Fcochain L (limCone CC) (isLimCone_LimCone CC). Let FHC : LimCone FFcochain := make_LimCone _ _ _ FHC'. Local Definition shiftCone : cone FFcochain L. Proof. use make_cone. - intro n; apply (coneOut (limCone CC) (S n)). - intros m n e ; destruct e. refine (_ @ coneOutCommutes (limCone CC) _ (S n) (idpath _)). apply maponpaths. simpl. rewrite ! idpath_transportf. rewrite ! id_left. apply idpath. Defined. Local Lemma unshiftCone_forms_cone {x : C} ( cc : cone FFcochain x) : forms_cone Fcochain (λ n : vertex conat_graph, nat_rect (λ n0 : nat, C ⟦ x, dob Fcochain n0 ⟧) (TerminalArrow TerminalC x) (λ (n0 : nat) (_ : C ⟦ x, dob Fcochain n0 ⟧), coneOut cc n0) n). Proof. intros m n e ; destruct e ; destruct n as [|n]. - apply TerminalArrowUnique. - simpl. rewrite idpath_transportf ; rewrite id_left. rewrite (! coneOutCommutes cc _ n (idpath _)). apply maponpaths. simpl. rewrite idpath_transportf, id_left. apply idpath. Qed. Local Definition unshiftCone (x : C) (cc : cone FFcochain x) : cone Fcochain x. Proof. use make_cone. - intro n. induction n as [|n]. + apply TerminalArrow. + apply (coneOut cc _). - apply unshiftCone_forms_cone. Defined. Local Definition shiftIsLimCone : isLimCone FFcochain L shiftCone. Proof. intros x cc; simpl. use tpair. + use tpair. * apply limArrow, (unshiftCone _ cc). * abstract (intro n; apply (limArrowCommutes CC x (unshiftCone x cc) (S n))). + abstract (intros p; apply subtypePath; [ intro f; apply impred; intro; apply homset_property | apply limArrowUnique; intro n; destruct n as [|n]; [ apply TerminalArrowUnique | apply (pr2 p) ]]). Defined. Local Definition shiftLimCone : LimCone FFcochain := make_LimCone FFcochain L shiftCone shiftIsLimCone. Definition lim_algebra_mor : C⟦L,F L⟧ := limArrow FHC L shiftCone. Local Definition is_z_iso_lim_algebra_mor : is_z_isomorphism lim_algebra_mor := isLim_is_z_iso _ FHC _ _ shiftIsLimCone. Let α : z_iso L (F L) := make_z_iso' _ is_z_iso_lim_algebra_mor. Let α_inv : z_iso (F L) L := z_iso_inv_from_z_iso α. Let α_alg : coalgebra_ob F := tpair (λ X : C, C ⟦ X , F X⟧) L α. Lemma unfold_inv_from_z_iso_α : inv_from_z_iso α = limArrow shiftLimCone _ (limCone FHC). Proof. apply idpath. Qed. (** Given a coalgebra: << a A ------> F A >> we now define a coalgebra morphism ad: << a A ------> F A | | | ad | | | V α V L ------> F L >> *) Section coalgebra_mor. Variable (Aa : coalgebra_ob F). Local Notation A := (coalg_carrier _ Aa). Local Notation a := (coalg_map _ Aa). Local Definition cone_over_coalg (n : nat) : C ⟦ A, iter_functor F n TerminalC⟧. Proof. induction n as [|n Fn]; simpl. - apply TerminalArrow. - apply (a · #F Fn). Defined. (* a_n : F^n 0 -> A *) Local Notation an := cone_over_coalg. Lemma isConeOverCoalg {u v : nat} (e : S v = u) : an u · dmor Fcochain e = an v. Proof. destruct e. induction v as [| n IHn]. - apply TerminalArrowUnique. - simpl ; rewrite assoc' ; apply cancel_precomposition. etrans. 2: { apply maponpaths ; exact IHn. } rewrite functor_comp. simpl. do 2 rewrite functor_comp. apply maponpaths. unfold dmor. cbn. rewrite ! id_left. apply idpath. Qed. (* ad = a† = a dagger *) Local Definition ad : C⟦A,L⟧. Proof. apply limArrow. use make_cone. - apply cone_over_coalg. - red ; intro ; intros ; apply isConeOverCoalg. Defined. Lemma ad_is_coalgebra_mor (n : nat) : a · # F ad · inv_from_z_iso α · limOut CC n = an n. Proof. destruct n as [|n]. - now apply TerminalArrowUnique. - rewrite unfold_inv_from_z_iso_α. eapply pathscomp0. { rewrite assoc'. apply maponpaths. apply (limArrowCommutes shiftLimCone). } simpl; rewrite assoc', <- functor_comp. apply cancel_precomposition, maponpaths, (limArrowCommutes CC). Qed. Local Definition ad_mor : coalgebra_mor F Aa α_alg. Proof. exists ad. abstract (apply pathsinv0, z_iso_inv_to_right, pathsinv0, limArrowUnique; simpl; intro n ; apply ad_is_coalgebra_mor). Defined. End coalgebra_mor. Lemma limCoAlgIsTerminal_subproof (Aa : CoAlg_category F) (Fa' : coalgebra_mor F Aa α_alg) : Fa' = ad_mor Aa. Proof. use total2_paths_f. 2: { apply homset_property. } apply limArrowUnique ; intro n. destruct Fa' as [f hf]; simpl. unfold is_coalgebra_mor in hf; simpl in hf. induction n as [|n IHn]; simpl. - apply TerminalArrowUnique. - rewrite <- IHn, functor_comp, assoc. etrans. 2: { apply cancel_postcomposition ; apply (! hf). } rewrite assoc'. apply maponpaths. apply (z_iso_inv_to_left _ _ _ α). apply (limArrowCommutes shiftLimCone). Qed. Lemma limCoAlgIsTerminal : isTerminal (CoAlg_category F) α_alg. Proof. apply make_isTerminal; intros Aa. exists (ad_mor Aa). apply limCoAlgIsTerminal_subproof. Defined. Definition limCoAlgTerminal : Terminal (CoAlg_category F) := make_Terminal _ limCoAlgIsTerminal. End lim_terminal_coalgebra. UniMath-20231010/UniMath/CategoryTheory/Chains/Cochains.v000066400000000000000000000056121451125700300227530ustar00rootroot00000000000000(** * Cochains Cochains are diagrams of the form X₀ ← X₁ ← ⋯. Author: Langston Barrett (@siddharthist), February 2018 *) Require Import UniMath.Foundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. (** Define the cochain: << 0 <-- 1 <-- 2 <-- 3 <-- ... >> with exactly one arrow from S n to n. *) Definition conat_graph : graph := make_graph nat (λ m n, S n = m). Notation "'cochain'" := (diagram conat_graph). (** A diagram for a cochain is what it should be, a collection of objects and arrows arranged so: X₀ ⟵ X₁ ⟵ ⋯. This can be used to easily construct cochains, see e.g. [termCochain]. *) Definition cochain_weq {C : precategory} : (∑ (obs : ∏ n : nat, ob C), (∏ n : nat, obs (S n) --> obs n)) ≃ cochain C. Proof. use weqfibtototal; intro obs; cbn. use weq_iso. - intros ars a b aeqSb. refine (_ · ars b). exact (transportf (λ o, C ⟦ obs o, obs (S b) ⟧) aeqSb (identity _)). - exact (λ ars n, ars (S n) n (idpath _)). - intros ars; cbn. apply funextsec; intro n. apply id_left. - intros ars. cbn. apply funextsec; intro a. apply funextsec; intro b. apply funextsec; intro p. induction p. cbn. apply id_left. Defined. Definition mapcochain {C D : precategory} (F : functor C D) (c : cochain C) : cochain D := mapdiagram F c. (** Any j > i gives a morphism in the cochain via composition *) Definition cochain_mor {C : category} (c : cochain C) {i j} : i < j -> C⟦dob c j, dob c i⟧. Proof. induction j as [|j IHj]. - intros Hi0; destruct (negnatlthn0 0 Hi0). - intros Hij. destruct (natlehchoice4 _ _ Hij) as [|H]. + refine (_ · IHj h). apply (dmor c), (idpath _). + apply (dmor c), (maponpaths S H). Defined. (** Construct the cochain: << ! F! F^2 ! 1 <----- F 1 <------ F^2 1 <-------- F^3 1 <--- ... >> *) Definition termCochain {C : precategory} (TermC : Terminal C) (F : functor C C) : cochain C. Proof. use cochain_weq; use tpair. - exact (λ m, iter_functor F m TermC). - intros n; induction n as [|n IHn]. * exact (TerminalArrow TermC _). * exact (# F IHn). Defined. (** ** Definition of (ω-)continuous functors *) Definition is_cont {C D : category} (F : functor C D) : UU := ∏ (g : graph) (d : diagram g C) (L : C) (cc : cone d L), preserves_limit F d L cc. Definition is_omega_cont {C D : category} (F : functor C D) : UU := ∏ (c : cochain C) (L : C) (cc : cone c L), preserves_limit F c L cc. Definition omega_cont_functor (C D : category) : UU := ∑ (F : functor C D), is_omega_cont F. UniMath-20231010/UniMath/CategoryTheory/Chains/OmegaCocontFunctors.v000066400000000000000000001572511451125700300251550ustar00rootroot00000000000000(** * ω-cocontinuous functors This file contains theory about (omega-) cocontinuous functors, i.e. functors which preserve (sequential-) colimits ([is_omega_cocont] and [is_cocont]). This file contains proofs that the following functors are (omega-)cocontinuous: - Identity functor [is_cocont_functor_identity] [is_omega_cocont_functor_identity] - Constant functor: F_x : C -> D, c |-> x [is_omega_cocont_constant_functor] - Composition of omega-cocontinuous functors [is_cocont_functor_composite] [is_omega_cocont_functor_composite] - Iteration of omega-cocontinuous functors: F^n : C -> C [is_cocont_iter_functor] [is_omega_cocont_iter_functor] - Pairing of (omega-)cocont functors (F,G) : A * B -> C * D, (x,y) |-> (F x,G y) [is_cocont_pair_functor] [is_omega_cocont_pair_functor] - Indexed families of (omega-)cocont functors F^I : A^I -> B^I [is_cocont_family_functor] [is_omega_cocont_family_functor] - Binary delta functor: C -> C^2, x |-> (x,x) [is_cocont_bindelta_functor] [is_omega_cocont_bindelta_functor] - General delta functor: C -> C^I [is_cocont_delta_functor] [is_omega_cocont_delta_functor] - Binary coproduct functor: C^2 -> C, (x,y) |-> x + y [is_cocont_bincoproduct_functor] [is_omega_cocont_bincoproduct_functor] - General coproduct functor: C^I -> C [is_cocont_coproduct_functor] [is_omega_cocont_coproduct_functor] - Binary coproduct of functors: F + G : C -> D, x |-> F x + G x [is_cocont_BinCoproduct_of_functors_alt] [is_omega_cocont_BinCoproduct_of_functors_alt] [is_cocont_BinCoproduct_of_functors_alt2] [is_omega_cocont_BinCoproduct_of_functors_alt2] [is_cocont_BinCoproduct_of_functors] [is_omega_cocont_BinCoproduct_of_functors] - Coproduct of families of functors: + F_i : C -> D (generalization of coproduct of functors) [is_cocont_coproduct_of_functors_alt] [is_cocont_coproduct_of_functors] [is_omega_cocont_coproduct_of_functors_alt] [is_omega_cocont_coproduct_of_functors] - Constant product functors: C -> C, x |-> a * x and x |-> x * a [is_cocont_constprod_functor1] [is_cocont_constprod_functor2] [is_omega_cocont_constprod_functor1] [is_omega_cocont_constprod_functor2] - Binary product functor: C^2 -> C, (x,y) |-> x * y [is_omega_cocont_binproduct_functor] - Product of functors: F * G : C -> D, x |-> (x,x) |-> (F x,G x) |-> F x * G x [is_omega_cocont_BinProduct_of_functors_alt] [is_omega_cocont_BinProduct_of_functors] - Precomposition functor: _ o K : ⟦C,A⟧ -> ⟦M,A⟧ for K : M -> C [preserves_colimit_pre_composition_functor] [is_omega_cocont_pre_composition_functor] - Postcomposition with a left adjoint: [is_cocont_post_composition_functor] [is_omega_cocont_post_composition_functor] - Swapping of functor category arguments: [is_cocont_functor_cat_swap] [is_omega_cocont_functor_cat_swap] - The forgetful functor from Set/X to Set preserves colimits ([preserves_colimit_slicecat_to_cat_HSET]) Written by: Anders Mörtberg and Benedikt Ahrens, 2015-2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Adjunctions.Examples. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Chains.Chains. Local Open Scope cat. (** * Examples of (omega) cocontinuous functors *) Section cocont_functors. (** ** Left adjoints preserve colimits *) Lemma left_adjoint_cocont (C D : category) (F : functor C D) (H : is_left_adjoint F) : is_cocont F. Proof. intros g d L ccL. apply left_adjoint_preserves_colimit. exact H. Defined. (* Print Assumptions left_adjoint_cocont. *) (** Cocontinuity is preserved by isomorphic functors *) Section cocont_iso. (* As this section is proving a proposition, the hypothesis can be weakened from a specified iso to F and G being isomorphic. *) Context {C D : category} {F G : functor C D} (αiso : @z_iso [C, D] F G). Section preserves_colimit_iso. Context {g : graph} (d : diagram g C) (L : C) (cc : cocone d L) (HF : preserves_colimit F d L cc). Let αinv := inv_from_z_iso αiso. Let α := pr1 αiso. Let Hα : is_z_isomorphism α := pr2 αiso. Local Definition ccFy y (ccGy : cocone (mapdiagram G d) y) : cocone (mapdiagram F d) y. Proof. use make_cocone. - intro v; apply (pr1 α (dob d v) · coconeIn ccGy v). - abstract (simpl; intros u v e; rewrite <- (coconeInCommutes ccGy u v e), !assoc; apply cancel_postcomposition, nat_trans_ax). Defined. Lemma αinv_f_commutes y (ccGy : cocone (mapdiagram G d) y) (f : D⟦F L,y⟧) (Hf : is_cocone_mor (mapcocone F d cc) (ccFy y ccGy) f) : ∏ v, # G (coconeIn cc v) · (pr1 αinv L · f) = coconeIn ccGy v. Proof. intro v; rewrite assoc. eapply pathscomp0; [apply cancel_postcomposition, nat_trans_ax|]. rewrite <- assoc; eapply pathscomp0; [apply maponpaths, (Hf v)|]; simpl; rewrite assoc. eapply pathscomp0. apply cancel_postcomposition. apply (nat_trans_eq_pointwise (@z_iso_after_z_iso_inv [C, D] _ _ (make_z_iso' _ Hα))). now rewrite id_left. Qed. Lemma αinv_f_unique y (ccGy : cocone (mapdiagram G d) y) (f : D⟦F L,y⟧) (Hf : is_cocone_mor (mapcocone F d cc) (ccFy y ccGy) f) (HHf : ∏ t : ∑ x, is_cocone_mor (mapcocone F d cc) (ccFy y ccGy) x, t = f,, Hf) f' (Hf' : ∏ v, # G (coconeIn cc v) · f' = coconeIn ccGy v) : f' = pr1 αinv L · f. Proof. transparent assert (HH : (∑ x : D ⟦ F L, y ⟧, is_cocone_mor (mapcocone F d cc) (ccFy y ccGy) x)). { use tpair. - apply (pr1 α L · f'). - unfold is_cocone_mor; cbn. abstract (intro v; rewrite <- Hf', !assoc; apply cancel_postcomposition, nat_trans_ax). } apply pathsinv0. generalize (maponpaths pr1 (HHf HH)); intro Htemp; simpl in *. rewrite <- Htemp; simpl; rewrite assoc. eapply pathscomp0. apply cancel_postcomposition. apply (nat_trans_eq_pointwise (@z_iso_after_z_iso_inv [C, D] _ _ (make_z_iso' _ Hα))). now apply id_left. Qed. Lemma preserves_colimit_z_iso : preserves_colimit G d L cc. Proof. intros HccL y ccGy. set (H := HF HccL y (ccFy y ccGy)). set (f := pr1 (pr1 H)); set (Hf := pr2 (pr1 H)); set (HHf := pr2 H). use unique_exists. - apply (pr1 αinv L · f). - unfold is_cocone_mor; simpl; apply (αinv_f_commutes y ccGy f Hf). - abstract (intro; apply impred; intro; apply homset_property). - abstract (simpl in *; intros f' Hf'; apply (αinv_f_unique y ccGy f Hf); trivial; intro t; rewrite (HHf t); reflexivity). Defined. End preserves_colimit_iso. Lemma is_cocont_z_iso : is_cocont F -> is_cocont G. Proof. now intros H g d c cc; apply (preserves_colimit_z_iso). Defined. Lemma is_omega_cocont_z_iso : is_omega_cocont F -> is_omega_cocont G. Proof. now intros H g d c cc; apply (preserves_colimit_z_iso). Defined. End cocont_iso. (** ** The identity functor is (omega) cocontinuous *) Section functor_identity. Context (C : category). Lemma preserves_colimit_identity {g : graph} (d : diagram g C) (L : C) (cc : cocone d L) : preserves_colimit (functor_identity C) d L cc. Proof. intros HcL y ccy; simpl. set (CC := make_ColimCocone _ _ _ HcL). use tpair. - use tpair. + apply (colimArrow CC), ccy. + abstract (simpl; intro n; apply (colimArrowCommutes CC)). - abstract (simpl; intro t; apply subtypePath; [ simpl; intro v; apply impred; intro; apply homset_property | apply (colimArrowUnique CC); intro n; apply (pr2 t)]). Defined. Lemma is_cocont_functor_identity : is_cocont (functor_identity C). Proof. now intros g; apply preserves_colimit_identity. Defined. Lemma is_omega_cocont_functor_identity : is_omega_cocont (functor_identity C). Proof. now intros c; apply is_cocont_functor_identity. Defined. Definition omega_cocont_functor_identity : omega_cocont_functor C C := tpair _ _ is_omega_cocont_functor_identity. End functor_identity. (** ** The constant functor is omega cocontinuous *) Section constant_functor. Context {C D : category} (x : D). (* Without the conn argument this is is too weak as diagrams are not necessarily categories *) Lemma preserves_colimit_constant_functor {g : graph} (v : vertex g) (conn : ∏ (u : vertex g), edge v u) (d : diagram g C) (L : C) (cc : cocone d L) : preserves_colimit (constant_functor C D x) d L cc. Proof. intros HcL y ccy; simpl. use tpair. - apply (tpair _ (coconeIn ccy v)). abstract (now intro u; generalize (coconeInCommutes ccy _ _ (conn u)); rewrite !id_left; intro H; rewrite H). - abstract (intro p; apply subtypePath; [ intro; apply impred; intro; apply homset_property | now destruct p as [p H]; rewrite <- (H v), id_left ]). Defined. (** The constant functor is omega cocontinuous *) Lemma is_omega_cocont_constant_functor : is_omega_cocont (constant_functor C D x). Proof. intros c L ccL HccL y ccy. use tpair. - apply (tpair _ (coconeIn ccy 0)). abstract (intro n; rewrite id_left; destruct ccy as [f Hf]; simpl; now induction n as [|n IHn]; [apply idpath|]; rewrite IHn, <- (Hf n (S n) (idpath _)), id_left). - abstract (intro p; apply subtypePath; [ intros f; apply impred; intro; apply homset_property | now simpl; destruct p as [p H]; rewrite <- (H 0), id_left]). Defined. Definition omega_cocont_constant_functor : omega_cocont_functor C D := tpair _ _ is_omega_cocont_constant_functor. End constant_functor. (** ** Functor composition preserves omega cocontinuity *) Section functor_composite. Context {C D E : category}. Lemma preserves_colimit_functor_composite (F : functor C D) (G : functor D E) {g : graph} (d : diagram g C) (L : C) (cc : cocone d L) (H1 : preserves_colimit F d L cc) (H2 : preserves_colimit G (mapdiagram F d) (F L) (mapcocone F _ cc)) : preserves_colimit (functor_composite F G) d L cc. Proof. intros HcL y ccy; simpl. set (CC := make_ColimCocone _ _ _ (H2 (H1 HcL))). use tpair. - use tpair. + apply (colimArrow CC), ccy. + abstract (simpl; intro v; apply (colimArrowCommutes CC)). - abstract (simpl; intro t; apply subtypePath; [ intros f; apply impred; intro; apply homset_property | simpl; apply (colimArrowUnique CC), (pr2 t) ]). Defined. Lemma is_cocont_functor_composite (F : functor C D) (G : functor D E) (HF : is_cocont F) (HG : is_cocont G) : is_cocont (functor_composite F G). Proof. intros g d L cc. apply preserves_colimit_functor_composite; [ apply HF | apply HG ]. Defined. Lemma is_omega_cocont_functor_composite (F : functor C D) (G : functor D E) : is_omega_cocont F -> is_omega_cocont G -> is_omega_cocont (functor_composite F G). Proof. intros hF hG c L cc. apply preserves_colimit_functor_composite; [ apply hF | apply hG ]. Defined. Definition omega_cocont_functor_composite (F : omega_cocont_functor C D) (G : omega_cocont_functor D E) : omega_cocont_functor C E := tpair _ _ (is_omega_cocont_functor_composite _ _ (pr2 F) (pr2 G)). End functor_composite. (** ** Functor iteration preserves (omega)-cocontinuity *) Section iter_functor. Lemma is_cocont_iter_functor {C : category} (F : functor C C) (hF : is_cocont F) n : is_cocont (iter_functor F n). Proof. induction n as [|n IH]; simpl. - apply (is_cocont_functor_identity _). - apply (is_cocont_functor_composite _ _ IH hF). Defined. Lemma is_omega_cocont_iter_functor {C : category} (F : functor C C) (hF : is_omega_cocont F) n : is_omega_cocont (iter_functor F n). Proof. induction n as [|n IH]; simpl. - apply (is_omega_cocont_functor_identity _). - apply (is_omega_cocont_functor_composite _ _ IH hF). Defined. Definition omega_cocont_iter_functor {C : category} (F : omega_cocont_functor C C) n : omega_cocont_functor C C := tpair _ _ (is_omega_cocont_iter_functor _ (pr2 F) n). End iter_functor. (** ** A pair of functors (F,G) : A * B -> C * D is omega cocontinuous if F and G are *) Section pair_functor. Context {A B C D : category} (F : functor A C) (G : functor B D). Local Definition cocone_pr1_functor {g : graph} (cAB : diagram g (category_binproduct A B)) (ab : A × B) (ccab : cocone cAB ab) : cocone (mapdiagram (pr1_functor A B) cAB) (ob1 ab). Proof. use make_cocone. - simpl; intro n; apply (mor1 (coconeIn ccab n)). - simpl; intros m n e. set (X:= coconeInCommutes ccab m n e). etrans. 2: { apply maponpaths. apply X. } apply idpath. Defined. Local Lemma isColimCocone_pr1_functor {g : graph} (cAB : diagram g (category_binproduct A B)) (ab : A × B) (ccab : cocone cAB ab) (Hccab : isColimCocone cAB ab ccab) : isColimCocone (mapdiagram (pr1_functor A B) cAB) (ob1 ab) (mapcocone (pr1_functor A B) cAB ccab). Proof. intros x ccx. transparent assert (HHH : (cocone cAB (x,, ob2 ab))). { use make_cocone. - simpl; intro n; split; [ apply (pr1 ccx n) | apply (# (pr2_functor A B) (pr1 ccab n)) ]. - abstract(simpl; intros m n e; apply pathsdirprod; [ apply (pr2 ccx m n e) | apply (maponpaths dirprod_pr2 ((pr2 ccab) m n e)) ]). } destruct (Hccab _ HHH) as [[[x1 x2] p1] p2]. use tpair. - apply (tpair _ x1). abstract (intro n; apply (maponpaths pr1 (p1 n))). - intro t. transparent assert (X : (∑ x0, ∏ v, coconeIn ccab v · x0 = catbinprodmor (pr1 ccx v) (pr2 (pr1 ccab v)))). { use tpair. - split; [ apply (pr1 t) | apply (identity _) ]. - cbn. abstract (intro n; rewrite id_right; apply pathsdirprod; [ apply (pr2 t) | apply idpath ]). } abstract (apply subtypePath; simpl; [ intro f; apply impred; intro; apply homset_property | apply (maponpaths (λ x, pr1 (pr1 x)) (p2 X))]). Defined. Lemma is_cocont_pr1_functor : is_cocont (pr1_functor A B). Proof. now intros c L ccL M H; apply isColimCocone_pr1_functor. Defined. Local Definition cocone_pr2_functor {g : graph} (cAB : diagram g (category_binproduct A B)) (ab : A × B) (ccab : cocone cAB ab) : cocone (mapdiagram (pr2_functor A B) cAB) (pr2 ab). Proof. use make_cocone. - simpl; intro n; apply (pr2 (coconeIn ccab n)). - simpl; intros m n e. etrans. 2: { apply maponpaths. apply (coconeInCommutes ccab m n e). } apply idpath. Defined. Local Lemma isColimCocone_pr2_functor {g : graph} (cAB : diagram g (category_binproduct A B)) (ab : A × B) (ccab : cocone cAB ab) (Hccab : isColimCocone cAB ab ccab) : isColimCocone (mapdiagram (pr2_functor A B) cAB) (pr2 ab) (mapcocone (pr2_functor A B) cAB ccab). Proof. intros x ccx. transparent assert (HHH : (cocone cAB (pr1 ab,, x))). { use make_cocone. - simpl; intro n; split; [ apply (# (pr1_functor A B) (pr1 ccab n)) | apply (pr1 ccx n) ]. - abstract (simpl; intros m n e; apply pathsdirprod; [ apply (maponpaths pr1 (pr2 ccab m n e)) | apply (pr2 ccx m n e) ]). } destruct (Hccab _ HHH) as [[[x1 x2] p1] p2]. use tpair. - apply (tpair _ x2). abstract (intro n; apply (maponpaths dirprod_pr2 (p1 n))). - intro t. transparent assert (X : (∑ x0, ∏ v, coconeIn ccab v · x0 = catbinprodmor (pr1 (pr1 ccab v)) (pr1 ccx v))). { use tpair. - split; [ apply (identity _) | apply (pr1 t) ]. - cbn. abstract (intro n; rewrite id_right; apply pathsdirprod; [ apply idpath | apply (pr2 t) ]). } abstract (apply subtypePath; simpl; [ intro f; apply impred; intro; apply homset_property | apply (maponpaths (λ x, dirprod_pr2 (pr1 x)) (p2 X)) ]). Defined. Lemma is_cocont_pr2_functor : is_cocont (pr2_functor A B). Proof. now intros c L ccL M H; apply isColimCocone_pr2_functor. Defined. Lemma isColimCocone_pair_functor {gr : graph} (HF : ∏ (d : diagram gr A) (c : A) (cc : cocone d c) (h : isColimCocone d c cc), isColimCocone _ _ (mapcocone F d cc)) (HG : ∏ (d : diagram gr B) (c : B) (cc : cocone d c) (h : isColimCocone d c cc), isColimCocone _ _ (mapcocone G d cc)) : ∏ (d : diagram gr (category_binproduct A B)) (cd : A × B) (cc : cocone d cd), isColimCocone _ _ cc -> isColimCocone _ _ (mapcocone (pair_functor F G) d cc). Proof. intros cAB ml ccml Hccml xy ccxy. transparent assert (cFAX : (cocone (mapdiagram F (mapdiagram (pr1_functor A B) cAB)) (pr1 xy))). { use make_cocone. - intro n; apply (pr1 (pr1 ccxy n)). - abstract (intros m n e; apply (maponpaths dirprod_pr1 (pr2 ccxy m n e))). } transparent assert (cGBY : (cocone (mapdiagram G (mapdiagram (pr2_functor A B) cAB)) (pr2 xy))). { use make_cocone. - intro n; apply (pr2 (pr1 ccxy n)). - abstract (intros m n e; apply (maponpaths dirprod_pr2 (pr2 ccxy m n e))). } destruct (HF _ _ _ (isColimCocone_pr1_functor cAB ml ccml Hccml) _ cFAX) as [[f hf1] hf2]. destruct (HG _ _ _ (isColimCocone_pr2_functor cAB ml ccml Hccml) _ cGBY) as [[g hg1] hg2]. unfold is_cocone_mor in *. simpl in *. use tpair. - apply (tpair _ (f,,g)). abstract (intro n; unfold catbinprodmor, compose; simpl; now rewrite hf1, hg1). - abstract (intro t; apply subtypePath; simpl; [ intro x; apply impred; intro; apply isaset_dirprod; apply homset_property | induction t as [[f1 f2] p]; simpl in *; apply pathsdirprod; [ apply (maponpaths pr1 (hf2 (f1,, (λ n, maponpaths pr1 (p n))))) | apply (maponpaths pr1 (hg2 (f2,, (λ n, maponpaths dirprod_pr2 (p n)))))]]). Defined. Lemma is_cocont_pair_functor (HF : is_cocont F) (HG : is_cocont G) : is_cocont (pair_functor F G). Proof. intros gr cAB ml ccml Hccml. now apply isColimCocone_pair_functor; [apply HF|apply HG|]. Defined. Lemma is_omega_cocont_pair_functor (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (pair_functor F G). Proof. now intros cAB ml ccml Hccml; apply isColimCocone_pair_functor. Defined. End pair_functor. (** ** A functor F : A -> product_category I B is (omega-)cocontinuous if each F_i : A -> B_i is *) Section functor_into_product_category. (* NOTE: section below on [power_category] may be easily(?) generalised to [product_category]. *) (* NOTE: binary analogue for this section. *) Context {I : UU} {A : category} {B : I -> category}. (* A cocone in the [product_category] is a colimit cocone if each of its components is. Cf. the converse [isColimCocone_functor_into_power] below (currently only for special case of power, not product), which seems to require some additional assumption (e.g. decidable equality on [I]; perhaps other conditions might also suffice. *) (* NOTE: other lemmas in below on cocones in [power_category] may be able to be simplified using this. *) Lemma isColimCocone_in_product_category {g : graph} (c : diagram g (product_category B)) (b : product_precategory B) (cc : cocone c b) (M : ∏ i, isColimCocone _ _ (mapcocone (pr_functor I B i) _ cc)) : isColimCocone c b cc. Proof. intros b' cc'. apply iscontraprop1. - abstract ( apply invproofirrelevance; intros f1 f2; apply subtypePath; [ intros f; apply impred_isaprop; intros v; apply has_homsets_product_precategory | ]; apply funextsec; intros i; assert (MM := M i _ (mapcocone (pr_functor I B i) _ cc')); assert (H := proofirrelevancecontr MM); use (maponpaths pr1 (H (pr1 f1 i,,_) (pr1 f2 i,,_))); clear MM H; intros v ; [ exact (toforallpaths _ _ _ (pr2 f1 v) i) | exact (toforallpaths _ _ _ (pr2 f2 v) i) ] ) . - use tpair. + intros i. use (pr1 (pr1 (M i _ (mapcocone (pr_functor I B i) _ cc')))). + abstract ( intros v; apply funextsec; intros i; use (pr2 (pr1 (M i _ (mapcocone (pr_functor I B i) _ cc'))) v) ). Defined. Lemma is_cocont_functor_into_product_category {F : functor A (product_category B)} (HF : ∏ (i : I), is_cocont (functor_composite F (pr_functor I B i))) : is_cocont F. Proof. intros gr cA a cc Hcc. apply isColimCocone_in_product_category. intros i. rewrite <- mapcocone_functor_composite. now apply HF, Hcc. Defined. Lemma is_omega_cocont_functor_into_product_category {F : functor A (product_category B)} (HF : ∏ (i : I), is_omega_cocont (functor_composite F (pr_functor I B i))) : is_omega_cocont F. Proof. intros cA a cc Hcc. apply isColimCocone_in_product_category. intros i. rewrite <- mapcocone_functor_composite. now apply HF, Hcc. Defined. End functor_into_product_category. Section tuple_functor. Context {I : UU} {A : category} {B : I -> category}. Lemma is_cocont_tuple_functor {F : ∏ i, functor A (B i)} (HF : ∏ i, is_cocont (F i)) : is_cocont (tuple_functor F). Proof. apply is_cocont_functor_into_product_category. intro i; rewrite pr_tuple_functor; apply HF. Defined. Lemma is_omega_cocont_tuple_functor {F : ∏ i, functor A (B i)} (HF : ∏ i, is_omega_cocont (F i)) : is_omega_cocont (tuple_functor F). Proof. apply is_omega_cocont_functor_into_product_category. intro i; rewrite pr_tuple_functor; apply HF. Defined. End tuple_functor. (** ** A family of functor F^I : A^I -> B^I is omega cocontinuous if each F_i is *) (** TODO: split out section [pr_functor], and then factor results on [family_functor] using that together with [tuple_functor] (maybe after redefining [family_functor] using [tuple_functor]. *) Section family_functor. Context {I : UU} {A B : category}. (* The index set I needs decidable equality for pr_functor to be cocont *) Hypothesis (HI : isdeceq I). Local Definition ifI (i j : I) (a b : A) : A := coprod_rect (λ _, A) (λ _,a) (λ _,b) (HI i j). Local Lemma ifI_eq i x y : ifI i i x y = x. Proof. now unfold ifI; destruct (HI i i) as [p|p]; [|destruct (p (idpath _))]. Defined. Local Lemma isColimCocone_pr_functor {g : graph} (c : diagram g (power_category I A)) (L : power_category I A) (ccL : cocone c L) (M : isColimCocone c L ccL) : ∏ i, isColimCocone _ _ (mapcocone (pr_functor I (λ _, A) i) c ccL). Proof. intros i x ccx; simpl in *. transparent assert (HHH : (cocone c (λ j, ifI i j x (L j)))). { unfold ifI. use make_cocone. - simpl; intros n j. destruct (HI i j) as [p|p]. + apply (transportf (λ i, A ⟦ dob c n i, x ⟧) p (coconeIn ccx n)). + apply (# (pr_functor I (λ _, A) j) (coconeIn ccL n)). - abstract (simpl; intros m n e; apply funextsec; intro j; unfold compose; simpl; destruct (HI i j); [ destruct p; apply (pr2 ccx m n e) | apply (toforallpaths _ _ _ (pr2 ccL m n e) j)]). } destruct (M _ HHH) as [[x1 p1] p2]. use tpair. - apply (tpair _ (transportf _ (ifI_eq _ _ _) (x1 i))). abstract (intro n; rewrite <- idtoiso_postcompose, assoc; eapply pathscomp0; [eapply cancel_postcomposition, (toforallpaths _ _ _ (p1 n) i)|]; unfold ifI, ifI_eq; simpl; destruct (HI i i); [|destruct (n0 (idpath _))]; rewrite idtoiso_postcompose, idpath_transportf; assert (hp : p = idpath i); [apply (isasetifdeceq _ HI)|]; now rewrite hp, idpath_transportf). - intro t. transparent assert (X : (∑ x0, ∏ n, coconeIn ccL n · x0 = coconeIn HHH n)). { use tpair. - simpl; intro j; unfold ifI. destruct (HI i j). + apply (transportf (λ i, A ⟦ L i, x ⟧) p (pr1 t)). + apply identity. - cbn. abstract (intro n; apply funextsec; intro j; unfold ifI; destruct (HI i j); [ now destruct p; rewrite <- (pr2 t), !idpath_transportf | apply id_right ]). } apply subtypePath; simpl; [intro f; apply impred; intro; apply homset_property|]. set (H := toforallpaths _ _ _ (maponpaths pr1 (p2 X)) i); simpl in H. rewrite <- H; clear H; unfold ifI_eq, ifI. destruct (HI i i) as [p|p]; [|destruct (p (idpath _))]. assert (hp : p = idpath i); [apply (isasetifdeceq _ HI)|]. now rewrite hp, idpath_transportf. Defined. Lemma is_cocont_pr_functor (i : I) : is_cocont (pr_functor I (λ _, A) i). Proof. now intros c L ccL M H; apply isColimCocone_pr_functor. Defined. Lemma isColimCocone_family_functor {gr : graph} (F : ∏ (i : I), functor A B) (HF : ∏ i (d : diagram gr A) (c : A) (cc : cocone d c) (h : isColimCocone d c cc), isColimCocone _ _ (mapcocone (F i) d cc)) : ∏ (d : diagram gr (product_category (λ _, A))) (cd : I -> A) (cc : cocone d cd), isColimCocone _ _ cc -> isColimCocone _ _ (mapcocone (family_functor I F) d cc). Proof. intros cAB ml ccml Hccml xy ccxy; simpl in *. transparent assert (cc : (∏ i, cocone (mapdiagram (F i) (mapdiagram (pr_functor I (λ _ : I, A) i) cAB)) (xy i))). { intro i; use make_cocone. - intro n; use (pr1 ccxy n). - abstract (intros m n e; apply (toforallpaths _ _ _ (pr2 ccxy m n e) i)). } set (X i := HF i _ _ _ (isColimCocone_pr_functor _ _ _ Hccml i) (xy i) (cc i)). use tpair. - use tpair. + intro i; apply (pr1 (pr1 (X i))). + abstract (intro n; apply funextsec; intro j; apply (pr2 (pr1 (X j)) n)). - abstract (intro t; apply subtypePath; simpl; [ intro x; apply impred; intro; apply impred_isaset; intro i; apply homset_property | destruct t as [f1 f2]; simpl in *; apply funextsec; intro i; transparent assert (H : (∑ x : B ⟦ (F i) (ml i), xy i ⟧, ∏ n, # (F i) (coconeIn ccml n i) · x = coconeIn ccxy n i)); [apply (tpair _ (f1 i)); intro n; apply (toforallpaths _ _ _ (f2 n) i)|]; apply (maponpaths pr1 (pr2 (X i) H))]). Defined. Lemma is_cocont_family_functor {F : ∏ (i : I), functor A B} (HF : ∏ (i : I), is_cocont (F i)) : is_cocont (family_functor I F). Proof. intros gr cAB ml ccml Hccml. apply isColimCocone_family_functor; trivial; intro i; apply HF. Defined. Lemma is_omega_cocont_family_functor {F : ∏ (i : I), functor A B} (HF : ∏ (i : I), is_omega_cocont (F i)) : is_omega_cocont (family_functor I F). Proof. now intros cAB ml ccml Hccml; apply isColimCocone_family_functor. Defined. End family_functor. (** ** The bindelta functor C -> C^2 mapping x to (x,x) is omega cocontinuous *) Section bindelta_functor. Context {C : category} (PC : BinProducts C). Lemma is_cocont_bindelta_functor : is_cocont (bindelta_functor C). Proof. apply (left_adjoint_cocont _ _ _ (is_left_adjoint_bindelta_functor PC)). Defined. Lemma is_omega_cocont_bindelta_functor : is_omega_cocont (bindelta_functor C). Proof. now intros c L ccL; apply is_cocont_bindelta_functor. Defined. End bindelta_functor. (** ** The generalized delta functor C -> C^I is omega cocontinuous *) Section delta_functor. (* TODO: factor this using [tuple_functor] results above, after redefining [delta_functor] in terms of [tuple_functor]. *) Context {I : UU} {C : category} (PC : Products I C). Lemma is_cocont_delta_functor : is_cocont (delta_functor I C). Proof. apply (left_adjoint_cocont _ _ _ (is_left_adjoint_delta_functor _ PC)). Defined. Lemma is_omega_cocont_delta_functor : is_omega_cocont (delta_functor I C). Proof. now intros c L ccL; apply is_cocont_delta_functor. Defined. End delta_functor. (** ** The functor "+ : C^2 -> C" is cocontinuous *) Section bincoprod_functor. Context {C : category} (PC : BinCoproducts C). Lemma is_cocont_bincoproduct_functor : is_cocont (bincoproduct_functor PC). Proof. apply (left_adjoint_cocont _ _ _ (is_left_adjoint_bincoproduct_functor PC)). Defined. Lemma is_omega_cocont_bincoproduct_functor : is_omega_cocont (bincoproduct_functor PC). Proof. now intros c L ccL; apply is_cocont_bincoproduct_functor. Defined. End bincoprod_functor. (** ** The functor "+ : C^I -> C" is cocontinuous *) Section coprod_functor. Context {I : UU} {C : category} (PC : Coproducts I C). Lemma is_cocont_coproduct_functor : is_cocont (coproduct_functor _ PC). Proof. apply (left_adjoint_cocont _ _ _ (is_left_adjoint_coproduct_functor _ PC)). Defined. Lemma is_omega_cocont_coproduct_functor : is_omega_cocont (coproduct_functor _ PC). Proof. now intros c L ccL; apply is_cocont_coproduct_functor. Defined. End coprod_functor. (** ** Binary coproduct of functors: F + G : C -> D is omega cocontinuous *) Section BinCoproduct_of_functors. Context {C D : category} (HD : BinCoproducts D). Lemma is_cocont_BinCoproduct_of_functors_alt {F G : functor C D} (HF : is_cocont F) (HG : is_cocont G) : is_cocont (BinCoproduct_of_functors_alt HD F G). Proof. apply is_cocont_functor_composite. - apply is_cocont_tuple_functor. induction i; assumption. - apply is_cocont_coproduct_functor. Defined. Lemma is_omega_cocont_BinCoproduct_of_functors_alt {F G : functor C D} (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (BinCoproduct_of_functors_alt HD F G). Proof. apply is_omega_cocont_functor_composite. - apply is_omega_cocont_tuple_functor. induction i; assumption. - apply is_omega_cocont_coproduct_functor. Defined. Definition omega_cocont_BinCoproduct_of_functors_alt (F G : omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_BinCoproduct_of_functors_alt (pr2 F) (pr2 G)). Lemma is_cocont_BinCoproduct_of_functors (F G : functor C D) (HF : is_cocont F) (HG : is_cocont G) : is_cocont (BinCoproduct_of_functors _ _ HD F G). Proof. exact (transportf _ (BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors _ _ _ F G) (is_cocont_BinCoproduct_of_functors_alt HF HG)). Defined. Lemma is_omega_cocont_BinCoproduct_of_functors (F G : functor C D) (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (BinCoproduct_of_functors _ _ HD F G). Proof. exact (transportf _ (BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors _ _ _ F G) (is_omega_cocont_BinCoproduct_of_functors_alt HF HG)). Defined. Definition omega_cocont_BinCoproduct_of_functors (F G : omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_BinCoproduct_of_functors _ _ (pr2 F) (pr2 G)). (* Keep these as they have better computational behavior than the one for _alt above *) Lemma is_cocont_BinCoproduct_of_functors_alt2 (PC : BinProducts C) (F G : functor C D) (HF : is_cocont F) (HG : is_cocont G) : is_cocont (BinCoproduct_of_functors_alt2 HD F G). Proof. apply is_cocont_functor_composite. apply (is_cocont_bindelta_functor PC). apply is_cocont_functor_composite. apply (is_cocont_pair_functor _ _ HF HG). apply is_cocont_bincoproduct_functor. Defined. Lemma is_omega_cocont_BinCoproduct_of_functors_alt2 (PC : BinProducts C) (F G : functor C D) (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (BinCoproduct_of_functors_alt2 HD F G). Proof. apply is_omega_cocont_functor_composite. apply (is_omega_cocont_bindelta_functor PC). apply is_omega_cocont_functor_composite. apply (is_omega_cocont_pair_functor _ _ HF HG). apply is_omega_cocont_bincoproduct_functor. Defined. Definition omega_cocont_BinCoproduct_of_functors_alt2 (PC : BinProducts C) (F G : omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_BinCoproduct_of_functors_alt2 PC _ _ (pr2 F) (pr2 G)). End BinCoproduct_of_functors. (** ** Coproduct of families of functors: + F_i : C -> D is omega cocontinuous *) Section coproduct_of_functors. Context {I : UU} {C D : category} (HD : Coproducts I D). Lemma is_cocont_coproduct_of_functors {F : ∏ (i : I), functor C D} (HF : ∏ i, is_cocont (F i)) : is_cocont (coproduct_of_functors I _ _ HD F). Proof. use (transportf _ (coproduct_of_functors_alt_eq_coproduct_of_functors _ _ _ _ F) _). apply is_cocont_functor_composite. - apply is_cocont_tuple_functor. apply HF. - apply is_cocont_coproduct_functor. Defined. Lemma is_omega_cocont_coproduct_of_functors {F : ∏ (i : I), functor C D} (HF : ∏ i, is_omega_cocont (F i)) : is_omega_cocont (coproduct_of_functors I _ _ HD F). Proof. use (transportf _ (coproduct_of_functors_alt_eq_coproduct_of_functors _ _ _ _ F) _). apply is_omega_cocont_functor_composite. - apply is_omega_cocont_tuple_functor. apply HF. - apply is_omega_cocont_coproduct_functor. Defined. Definition omega_cocont_coproduct_of_functors (F : ∏ i, omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_coproduct_of_functors (λ i, pr2 (F i))). End coproduct_of_functors. (** ** Constant product functors: C -> C, x |-> a * x and x |-> x * a are cocontinuous *) Section constprod_functors. Context {C : category} (PC : BinProducts C) (hE : Exponentials PC). Lemma is_cocont_constprod_functor1 (x : C) : is_cocont (constprod_functor1 PC x). Proof. exact (left_adjoint_cocont _ _ _ (hE _)). Defined. Lemma is_omega_cocont_constprod_functor1 (x : C) : is_omega_cocont (constprod_functor1 PC x). Proof. now intros c L ccL; apply is_cocont_constprod_functor1. Defined. Definition omega_cocont_constprod_functor1 (x : C) : omega_cocont_functor C C := tpair _ _ (is_omega_cocont_constprod_functor1 x). Lemma is_cocont_constprod_functor2 (x : C) : is_cocont (constprod_functor2 PC x). Proof. apply left_adjoint_cocont. apply (is_left_adjoint_constprod_functor2 PC), hE. Defined. Lemma is_omega_cocont_constprod_functor2 (x : C) : is_omega_cocont (constprod_functor2 PC x). Proof. now intros c L ccL; apply is_cocont_constprod_functor2. Defined. Definition omega_cocont_constprod_functor2 (x : C) : omega_cocont_functor C C := tpair _ _ (is_omega_cocont_constprod_functor2 x). End constprod_functors. (** ** The functor "* : C^2 -> C" is omega cocontinuous *) Section binprod_functor. Context {C : category} (PC : BinProducts C). (* This hypothesis follow directly if C has exponentials *) Variable omega_cocont_constprod_functor1 : ∏ x : C, is_omega_cocont (constprod_functor1 PC x). Let omega_cocont_constprod_functor2 : ∏ x : C, is_omega_cocont (constprod_functor2 PC x). Proof. now intro x; apply (is_omega_cocont_z_iso (flip_z_iso PC x)). Defined. Local Definition fun_lt (cAB : chain (category_binproduct C C)) : ∏ i j, i < j -> C ⟦ BinProductObject C (PC (ob1 (dob cAB i)) (ob2 (dob cAB j))), BinProductObject C (PC (ob1 (dob cAB j)) (ob2 (dob cAB j))) ⟧. Proof. intros i j hij. apply (BinProductOfArrows _ _ _ (mor1 (chain_mor cAB hij)) (identity _)). Defined. Local Definition fun_gt (cAB : chain (category_binproduct C C)) : ∏ i j, i > j -> C ⟦ BinProductObject C (PC (ob1 (dob cAB i)) (ob2 (dob cAB j))), BinProductObject C (PC (ob1 (dob cAB i)) (ob2 (dob cAB i))) ⟧. Proof. intros i j hij. apply (BinProductOfArrows _ _ _ (identity _) (mor2 (chain_mor cAB hij))). Defined. (* The map to K from the "grid" *) Local Definition map_to_K (cAB : chain (category_binproduct C C)) (K : C) (ccK : cocone (mapchain (binproduct_functor PC) cAB) K) i j : C⟦BinProductObject C (PC (ob1 (dob cAB i)) (ob2 (dob cAB j))), K⟧. Proof. destruct (natlthorgeh i j). - apply (fun_lt cAB _ _ h · coconeIn ccK j). - destruct (natgehchoice _ _ h) as [H|H]. * apply (fun_gt cAB _ _ H · coconeIn ccK i). * destruct H; apply (coconeIn ccK i). Defined. Local Lemma map_to_K_commutes (cAB : chain (category_binproduct C C)) (K : C) (ccK : cocone (mapchain (binproduct_functor PC) cAB) K) i j k (e : edge j k) : BinProduct_of_functors_mor C C PC (constant_functor C C (pr1 (pr1 cAB i))) (functor_identity C) (pr2 (dob cAB j)) (pr2 (dob cAB k)) (mor2 (dmor cAB e)) · map_to_K cAB K ccK i k = map_to_K cAB K ccK i j. Proof. destruct e; simpl. unfold BinProduct_of_functors_mor, map_to_K. destruct (natlthorgeh i j) as [h|h]. - destruct (natlthorgeh i (S j)) as [h0|h0]. * rewrite assoc, <- (coconeInCommutes ccK j (S j) (idpath _)), assoc; simpl. apply cancel_postcomposition; unfold fun_lt. rewrite BinProductOfArrows_comp, id_left. eapply pathscomp0; [apply BinProductOfArrows_comp|]. rewrite id_right. apply maponpaths_12; try apply idpath; rewrite id_left; simpl. destruct (natlehchoice4 i j h0) as [h1|h1]. + apply cancel_postcomposition, maponpaths, maponpaths, isasetbool. + destruct h1; destruct (isirreflnatlth _ h). * destruct (isirreflnatlth _ (natlthlehtrans _ _ _ (natlthtolths _ _ h) h0)). - destruct (natlthorgeh i (S j)) as [h0|h0]. * destruct (natgehchoice i j h) as [h1|h1]. + destruct (natlthchoice2 _ _ h1) as [h2|h2]. { destruct (isirreflnatlth _ (istransnatlth _ _ _ h0 h2)). } { destruct h2; destruct (isirreflnatlth _ h0). } + destruct h1; simpl. rewrite <- (coconeInCommutes ccK i (S i) (idpath _)), assoc. eapply pathscomp0; [apply cancel_postcomposition, BinProductOfArrows_comp|]. rewrite id_left, id_right. apply cancel_postcomposition, (maponpaths_12 (BinProductOfArrows _ _ _)); try apply idpath. simpl; destruct (natlehchoice4 i i h0) as [h1|h1]; [destruct (isirreflnatlth _ h1)|]. apply maponpaths, maponpaths, isasetnat. * destruct (natgehchoice i j h) as [h1|h1]. + destruct (natgehchoice i (S j) h0) as [h2|h2]. { unfold fun_gt; rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinProductOfArrows_comp|]. rewrite id_right. apply cancel_postcomposition, maponpaths_12; try apply idpath. now rewrite <- (chain_mor_right h1 h2). } { destruct h; unfold fun_gt; simpl. destruct (!h2). assert (eq: h2 = (idpath _)). { apply isasetnat. } rewrite eq. apply cancel_postcomposition. apply maponpaths_12; try apply idpath; simpl. destruct (natlehchoice4 j j h1); [destruct (isirreflnatlth _ h)|]. apply maponpaths, maponpaths, isasetnat. } + destruct h1; destruct (negnatgehnsn _ h0). Qed. (* The cocone over K from the A_i * B chain *) Local Definition ccAiB_K (cAB : chain (category_binproduct C C)) (K : C) (ccK : cocone (mapchain (binproduct_functor PC) cAB) K) i : cocone (mapchain (constprod_functor1 PC (pr1 (pr1 cAB i))) (mapchain (pr2_functor C C) cAB)) K. Proof. use make_cocone. + intro j; apply (map_to_K cAB K ccK i j). + simpl; intros j k e; apply map_to_K_commutes. Defined. Section omega_cocont_binproduct. Context {cAB : chain (category_binproduct C C)} {LM : C × C} {ccLM : cocone cAB LM} (HccLM : isColimCocone cAB LM ccLM) {K : C} (ccK : cocone (mapchain (binproduct_functor PC) cAB) K). Let L := pr1 LM : C. Let M := pr2 LM : (λ _ : C, C) (pr1 LM). Let cA := mapchain (pr1_functor C C) cAB : chain C. Let cB := mapchain (pr2_functor C C) cAB : chain C. Let HA := isColimCocone_pr1_functor _ _ _ HccLM : isColimCocone cA L (cocone_pr1_functor cAB LM ccLM). Let HB := isColimCocone_pr2_functor _ _ _ HccLM : isColimCocone cB M (cocone_pr2_functor cAB LM ccLM). (* Form the colimiting cocones of "A_i * B_0 -> A_i * B_1 -> ..." *) Let HAiB := λ i, omega_cocont_constprod_functor1 (pr1 (pr1 cAB i)) _ _ _ HB. (* Turn HAiB into a ColimCocone: *) Let CCAiB := λ i, make_ColimCocone _ _ _ (HAiB i). (* Define the HAiM ColimCocone: *) Let HAiM := make_ColimCocone _ _ _ (omega_cocont_constprod_functor2 M _ _ _ HA). Let ccAiB_K := λ i, ccAiB_K _ _ ccK i. (* The f which is used in colimOfArrows *) Local Definition f i j : C ⟦ BinProduct_of_functors_ob C C PC (constant_functor C C (pr1 (dob cAB i))) (functor_identity C) (pr2 (dob cAB j)), BinProduct_of_functors_ob C C PC (constant_functor C C (pr1 (dob cAB (S i)))) (functor_identity C) (pr2 (dob cAB j)) ⟧. Proof. apply BinProductOfArrows; [apply (dmor cAB (idpath _)) | apply identity ]. Defined. Local Lemma fNat : ∏ i u v (e : edge u v), dmor (mapchain (constprod_functor1 PC _) cB) e · f i v = f i u · dmor (mapchain (constprod_functor1 PC _) cB) e. Proof. intros i j k e; destruct e; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. eapply pathscomp0; [|eapply pathsinv0; apply BinProductOfArrows_comp]. now rewrite !id_left, !id_right. Qed. (* Define the chain A_i * M *) Local Definition AiM_chain : chain C. Proof. use tpair. - intro i; apply (colim (CCAiB i)). - intros i j e; destruct e. apply (colimOfArrows (CCAiB i) (CCAiB (S i)) (f i) (fNat i)). Defined. Local Lemma AiM_chain_eq : ∏ i, dmor AiM_chain (idpath (S i)) = dmor (mapchain (constprod_functor2 PC M) cA) (idpath _). Proof. intro i; simpl; unfold colimOfArrows, BinProduct_of_functors_mor; simpl. apply pathsinv0, colimArrowUnique. simpl; intro j. unfold colimIn; simpl; unfold BinProduct_of_functors_mor, f; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0. eapply pathscomp0; [apply BinProductOfArrows_comp|]. now rewrite !id_left, !id_right. Qed. (* Define a cocone over K from the A_i * M chain *) Local Lemma ccAiM_K_subproof : forms_cocone (mapdiagram (constprod_functor2 PC M) cA) (fun u => colimArrow (CCAiB u) K (ccAiB_K u)). Proof. intros i j e; destruct e; simpl. generalize (AiM_chain_eq i); simpl; intro H; rewrite <- H; clear H; simpl. eapply pathscomp0. apply (precompWithColimOfArrows _ _ (CCAiB i) (CCAiB (S i)) _ _ K (ccAiB_K (S i))). apply (colimArrowUnique (CCAiB i) K (ccAiB_K i)). simpl; intros j. eapply pathscomp0; [apply (colimArrowCommutes (CCAiB i) K)|]; simpl. unfold map_to_K. destruct (natlthorgeh (S i) j). + destruct (natlthorgeh i j). * rewrite assoc; apply cancel_postcomposition. unfold f, fun_lt; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. now rewrite id_right, <- (chain_mor_right h0 h). * destruct (isasymmnatgth _ _ h h0). + destruct (natgehchoice (S i) j h). * destruct h. { destruct (natlthorgeh i j). - destruct (natlthchoice2 _ _ h) as [h2|h2]. + destruct (isirreflnatlth _ (istransnatlth _ _ _ h0 h2)). + destruct h2; destruct (isirreflnatlth _ h0). - destruct (natgehchoice i j h). + destruct h. rewrite <- (coconeInCommutes ccK i _ (idpath _)); simpl. rewrite !assoc; apply cancel_postcomposition. unfold f, fun_gt. rewrite BinProductOfArrows_comp. eapply pathscomp0; [apply BinProductOfArrows_comp|]. now rewrite !id_left, !id_right, <- (chain_mor_left h1 h0). + destruct p. rewrite <- (coconeInCommutes ccK i _ (idpath _)), assoc. apply cancel_postcomposition. unfold f, fun_gt. eapply pathscomp0; [apply BinProductOfArrows_comp|]. rewrite id_left, id_right. apply (maponpaths_12 (BinProductOfArrows _ _ _)); try apply idpath; simpl. destruct (natlehchoice4 i i h0); [destruct (isirreflnatlth _ h1)|]. apply maponpaths, maponpaths, isasetnat. } * destruct p, h. destruct (natlthorgeh i (S i)); [|destruct (negnatgehnsn _ h)]. apply cancel_postcomposition; unfold f, fun_lt. apply maponpaths_12; try apply idpath; simpl. destruct (natlehchoice4 i i h); [destruct (isirreflnatlth _ h0)|]. assert (H : idpath (S i) = maponpaths S p). apply isasetnat. now rewrite H. Qed. Local Definition ccAiM_K := make_cocone _ ccAiM_K_subproof. Local Lemma is_cocone_morphism : ∏ v : nat, BinProductOfArrows C (PC L M) (PC (pr1 (dob cAB v)) (pr2 (dob cAB v))) (pr1 (coconeIn ccLM v)) (pr2 (coconeIn ccLM v)) · colimArrow HAiM K ccAiM_K = coconeIn ccK v. Proof. intro i. generalize (colimArrowCommutes HAiM K ccAiM_K i). assert (H : coconeIn ccAiM_K i = colimArrow (CCAiB i) K (ccAiB_K i)). { apply idpath. } rewrite H; intros HH. generalize (colimArrowCommutes (CCAiB i) K (ccAiB_K i) i). rewrite <- HH; simpl; unfold map_to_K. destruct (natlthorgeh i i); [destruct (isirreflnatlth _ h)|]. destruct (natgehchoice i i h); [destruct (isirreflnatgth _ h0)|]. simpl; destruct h, p. intros HHH. rewrite <- HHH, assoc. apply cancel_postcomposition. unfold colimIn; simpl; unfold BinProduct_of_functors_mor; simpl. apply pathsinv0. eapply pathscomp0; [apply BinProductOfArrows_comp|]. now rewrite id_left, id_right. Qed. Local Lemma is_unique_cocone_morphism : ∏ t : ∑ x : C ⟦ BinProductObject C (PC L M), K ⟧, ∏ v : nat, BinProductOfArrows C (PC L M) (PC (pr1 (dob cAB v)) (pr2 (dob cAB v))) (pr1 (coconeIn ccLM v)) (pr2 (coconeIn ccLM v)) · x = coconeIn ccK v, t = colimArrow HAiM K ccAiM_K,, is_cocone_morphism. Proof. intro t. apply subtypePath; simpl. + intro; apply impred; intros; apply homset_property. + apply (colimArrowUnique HAiM K ccAiM_K). induction t as [t p]; simpl; intro i. apply (colimArrowUnique (CCAiB i) K (ccAiB_K i)). simpl; intros j; unfold map_to_K. induction (natlthorgeh i j) as [h|h]. * rewrite <- (p j); unfold fun_lt. rewrite !assoc. apply cancel_postcomposition. unfold colimIn; simpl; unfold BinProduct_of_functors_mor; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0. eapply pathscomp0; [apply BinProductOfArrows_comp|]. rewrite !id_left, id_right. apply maponpaths_12; try apply idpath. apply (maponpaths pr1 (chain_mor_coconeIn cAB LM ccLM i j h)). * destruct (natgehchoice i j h). { unfold fun_gt; rewrite <- (p i), !assoc. apply cancel_postcomposition. unfold colimIn; simpl; unfold BinProduct_of_functors_mor; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0. eapply pathscomp0; [apply BinProductOfArrows_comp|]. rewrite !id_left, id_right. set (X := (chain_mor_coconeIn cAB LM ccLM _ _ h0)). apply maponpaths. etrans. 2: { apply maponpaths. apply X. } apply idpath. } { destruct p0. rewrite <- (p i), assoc. apply cancel_postcomposition. unfold colimIn; simpl; unfold BinProduct_of_functors_mor; simpl. eapply pathscomp0; [apply BinProductOfArrows_comp|]. now rewrite id_left, id_right. } Qed. Local Definition isColimProductOfColims : ∃! x : C ⟦ BinProductObject C (PC L M), K ⟧, ∏ v : nat, BinProductOfArrows C (PC L M) (PC (pr1 (dob cAB v)) (pr2 (dob cAB v))) (pr1 (coconeIn ccLM v)) (pr2 (coconeIn ccLM v)) · x = coconeIn ccK v. Proof. use tpair. - use tpair. + apply (colimArrow HAiM K ccAiM_K). + cbn. apply is_cocone_morphism. - cbn. apply is_unique_cocone_morphism. Defined. End omega_cocont_binproduct. Lemma is_omega_cocont_binproduct_functor : is_omega_cocont (binproduct_functor PC). Proof. intros cAB LM ccLM HccLM K ccK; simpl in *. cbn. apply isColimProductOfColims, HccLM. Defined. End binprod_functor. (** ** Binary product of functors: F * G : C -> D is omega cocontinuous *) Section BinProduct_of_functors. Context {C D : category} (PC : BinProducts C) (PD : BinProducts D). Variable omega_cocont_constprod_functor1 : ∏ x : D, is_omega_cocont (constprod_functor1 PD x). Lemma is_omega_cocont_BinProduct_of_functors_alt (F G : functor C D) (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (BinProduct_of_functors_alt PD F G). Proof. apply is_omega_cocont_functor_composite. - apply (is_omega_cocont_bindelta_functor PC). - apply is_omega_cocont_functor_composite. + apply (is_omega_cocont_pair_functor _ _ HF HG). + now apply is_omega_cocont_binproduct_functor. Defined. Definition omega_cocont_BinProduct_of_functors_alt (F G : omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_BinProduct_of_functors_alt _ _ (pr2 F) (pr2 G)). Lemma is_omega_cocont_BinProduct_of_functors (F G : functor C D) (HF : is_omega_cocont F) (HG : is_omega_cocont G) : is_omega_cocont (BinProduct_of_functors _ _ PD F G). Proof. exact (transportf _ (BinProduct_of_functors_alt_eq_BinProduct_of_functors C D PD F G) (is_omega_cocont_BinProduct_of_functors_alt _ _ HF HG)). Defined. Definition omega_cocont_BinProduct_of_functors (F G : omega_cocont_functor C D) : omega_cocont_functor C D := tpair _ _ (is_omega_cocont_BinProduct_of_functors _ _ (pr2 F) (pr2 G)). End BinProduct_of_functors. (** ** Direct proof that the precomposition functor is cocontinuous *) Section pre_composition_functor. Context {A B C : category} (F : functor A B). (* Context (CC : Colims C). *) (* This is too strong *) Lemma preserves_colimit_pre_composition_functor {g : graph} (d : diagram g [B, C]) (G : [B, C]) (ccG : cocone d G) (H : ∏ b, ColimCocone (diagram_pointwise d b)) : preserves_colimit (pre_composition_functor A B C F) d G ccG. Proof. intros HccG. apply pointwise_Colim_is_isColimFunctor; intro a. now apply (isColimFunctor_is_pointwise_Colim _ H _ _ HccG). Defined. (* Lemma is_cocont_pre_composition_functor *) (* (H : ∏ (g : graph) (d : diagram g [B,C,hsC]) (b : B), *) (* ColimCocone (diagram_pointwise hsC d b)) : *) (* is_cocont (pre_composition_functor _ _ _ hsB hsC F). *) (* Proof. *) (* now intros g d G ccG; apply preserves_colimit_pre_composition_functor. *) (* Defined. *) Lemma is_omega_cocont_pre_composition_functor (H : Colims_of_shape nat_graph C) : is_omega_cocont (pre_composition_functor _ _ C F). Proof. now intros c L ccL; apply preserves_colimit_pre_composition_functor. Defined. Definition omega_cocont_pre_composition_functor (H : Colims_of_shape nat_graph C) : omega_cocont_functor [B, C] [A, C] := tpair _ _ (is_omega_cocont_pre_composition_functor H). End pre_composition_functor. (** ** Precomposition functor is cocontinuous using construction of right Kan extensions *) Section pre_composition_functor_kan. Context {A B C : category} (F : functor A B). Context (LC : Lims C). Lemma is_cocont_pre_composition_functor_kan : is_cocont (pre_composition_functor _ _ C F). Proof. apply left_adjoint_cocont; try apply functor_category_has_homsets. apply (RightKanExtension_from_limits _ _ _ _ LC). Qed. Lemma is_omega_cocont_pre_composition_functor_kan : is_omega_cocont (pre_composition_functor _ _ C F). Proof. now intros c L ccL; apply is_cocont_pre_composition_functor_kan. Defined. Definition omega_cocont_pre_composition_functor_kan : omega_cocont_functor [B, C] [A, C] := tpair _ _ is_omega_cocont_pre_composition_functor_kan. End pre_composition_functor_kan. Section post_composition_functor. Context {C D E : category}. Context (F : functor D E) (HF : is_left_adjoint F). Lemma is_cocont_post_composition_functor : is_cocont (post_composition_functor C D E F). Proof. apply left_adjoint_cocont; try apply functor_category_has_homsets. apply (is_left_adjoint_post_composition_functor _ HF). Defined. Lemma is_omega_cocont_post_composition_functor : is_omega_cocont (post_composition_functor C D E F). Proof. now intros c L ccL; apply is_cocont_post_composition_functor. Defined. End post_composition_functor. (** * Swapping of functor category arguments *) Section functor_swap. Lemma is_cocont_functor_cat_swap (C D E : category) : is_cocont (functor_cat_swap C D E). Proof. apply left_adjoint_cocont. apply is_left_adjoint_functor_cat_swap. Defined. Lemma is_omega_cocont_functor_cat_swap (C D E : category) : is_omega_cocont (functor_cat_swap C D E). Proof. intros d L ccL HccL. apply (is_cocont_functor_cat_swap _ _ _ _ d L ccL HccL). Defined. End functor_swap. (** * The forgetful functor from Set/X to Set preserves colimits *) Section cocont_slicecat_to_cat_HSET. Local Notation "HSET / X" := (slice_cat HSET X) (only parsing). Lemma preserves_colimit_slicecat_to_cat_HSET (X : HSET) (g : graph) (d : diagram g (HSET / X)) (L : HSET / X) (ccL : cocone d L) : preserves_colimit (slicecat_to_cat HSET X) d L ccL. Proof. apply left_adjoint_preserves_colimit. - apply is_left_adjoint_slicecat_to_cat_HSET. Defined. Lemma is_cocont_slicecat_to_cat_HSET (X : HSET) : is_cocont (slicecat_to_cat HSET X). Proof. intros g d L cc. now apply preserves_colimit_slicecat_to_cat_HSET. Defined. Lemma is_omega_cocont_slicecat_to_cat (X : HSET) : is_omega_cocont (slicecat_to_cat HSET X). Proof. intros d L cc. now apply preserves_colimit_slicecat_to_cat_HSET. Defined. (** Direct proof that the forgetful functor Set/X to Set preserves colimits *) Lemma preserves_colimit_slicecat_to_cat_HSET_direct (X : HSET) (g : graph) (d : diagram g (HSET / X)) (L : HSET / X) (ccL : cocone d L) : preserves_colimit (slicecat_to_cat HSET X) d L ccL. Proof. intros HccL y ccy. set (CC := make_ColimCocone _ _ _ HccL). transparent assert (c : (HSET / X)). { use tpair. - exists (∑ (x : pr1 X), pr1 y). abstract (apply isaset_total2; intros; apply setproperty). - cbn. apply pr1. } transparent assert (cc : (cocone d c)). { use make_cocone. - intros n. use tpair; simpl. + intros z. use tpair. * exact (pr2 L (pr1 (coconeIn ccL n) z)). * apply (coconeIn ccy n z). + abstract (now apply funextsec; intro z; apply (toforallpaths _ _ _ (pr2 (coconeIn ccL n)) z)). - abstract (intros m n e; apply eq_mor_slicecat, funextsec; intro z; use total2_paths_f; [ apply (maponpaths _ (toforallpaths _ _ _ (maponpaths pr1 (coconeInCommutes ccL m n e)) z))|]; cbn in *; induction (maponpaths pr1 _); simpl; now rewrite idpath_transportf, <- (coconeInCommutes ccy m n e)). } use unique_exists. - intros l; apply (pr2 (pr1 (colimArrow CC c cc) l)). - simpl; intro n. apply funextsec; intro x; cbn. now etrans; [apply maponpaths, (toforallpaths _ _ _ (maponpaths pr1 (colimArrowCommutes CC c cc n)) x)|]. - intro ; apply impred_isaprop. intro ; apply homset_property. - simpl; intros f Hf. apply funextsec; intro l. transparent assert (k : (HSET/X⟦colim CC,c⟧)). { use tpair. - intros l'. exists (pr2 L l'). apply (f l'). - abstract (now apply funextsec). } assert (Hk : (∏ n, colimIn CC n · k = coconeIn cc n)). { intros n. apply subtypePath; [intros x; apply homset_property|]. apply funextsec; intro z. use total2_paths_f; [apply idpath|]. now rewrite idpath_transportf; cbn; rewrite <- (toforallpaths _ _ _ (Hf n) z). } apply (maponpaths dirprod_pr2 (toforallpaths _ _ _ (maponpaths pr1 (colimArrowUnique CC c cc k Hk)) l)). Defined. End cocont_slicecat_to_cat_HSET. End cocont_functors. (** Specialized notations for HSET *) Declare Scope cocont_functor_hset_scope. Delimit Scope cocont_functor_hset_scope with CS. Notation "' x" := (omega_cocont_constant_functor x) (at level 10) : cocont_functor_hset_scope. Notation "'Id'" := (omega_cocont_functor_identity _) : cocont_functor_hset_scope. Notation "F * G" := (omega_cocont_BinProduct_of_functors_alt BinProductsHSET _ (is_omega_cocont_constprod_functor1 _ Exponentials_HSET) F G) : cocont_functor_hset_scope. Notation "F + G" := (omega_cocont_BinCoproduct_of_functors_alt2 BinCoproductsHSET BinProductsHSET F G) : cocont_functor_hset_scope. Notation "1" := (unitHSET) : cocont_functor_hset_scope. Notation "0" := (emptyHSET) : cocont_functor_hset_scope. Section NotationTest. Variable A : HSET. Local Open Scope cocont_functor_hset_scope. (** F(X) = 1 + (A * X) *) Definition L_A : omega_cocont_functor HSET HSET := '1 + 'A * Id. End NotationTest. UniMath-20231010/UniMath/CategoryTheory/Chains/OmegaContFunctors.v000066400000000000000000000341431451125700300246250ustar00rootroot00000000000000(** * ω-cocontinuous functors This file contains theory about (omega-) continuous functors, i.e. functors which preserve (sequential-) limits ([is_omega_cont] and [is_cont]). Written by: Kobe Wullaert: October 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Adjunctions.Examples. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Cochains. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.OppositeCategory.LimitsAsColimits. Require Import UniMath.CategoryTheory.OppositeCategory.OppositeOfFunctorCategory. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Local Open Scope cat. (** ** Right adjoints preserve limits *) Lemma right_adjoint_cont {C D : category} (F : functor C D) (H : is_right_adjoint F) : is_cont F. Proof. intros g d L ccL. apply right_adjoint_preserves_limit. exact H. Defined. (** ** Identity preserves limits *) Lemma is_omega_cont_functor_identity {C : category} : is_omega_cont (functor_identity C). Proof. use (is_omega_cocont_op (F := functor_op (functor_identity C))). apply is_omega_cocont_functor_identity. Defined. (** ** Constant functors *) Lemma is_omega_cont_constant_functor {C D : category} (x : D) : is_omega_cont (constant_functor C D x). Proof. use (is_omega_cocont_op (F := functor_op (constant_functor C D x))). use is_omega_cocont_constant_functor. Defined. (** ** Composition of omega (continuous) functors *) Lemma is_cont_functor_composite {C D E : category} (F : functor C D) (G : functor D E) : is_cont F -> is_cont G -> is_cont (functor_composite F G). Proof. intros hF hG. use (is_cocont_op (F := functor_op (functor_composite F G))). exact (is_cocont_functor_composite (functor_op F) (functor_op G) (is_cont_op hF) (is_cont_op hG)). Defined. Lemma is_omega_cont_functor_composite {C D E : category} (F : functor C D) (G : functor D E) : is_omega_cont F -> is_omega_cont G -> is_omega_cont (functor_composite F G). Proof. intros hF hG. use (is_omega_cocont_op (F := functor_op (functor_composite F G))). exact (is_omega_cocont_functor_composite (functor_op F) (functor_op G) (is_omega_cont_op hF) (is_omega_cont_op hG)). Defined. (** ** Functor iteration preserves (omega)-continuity *) Lemma is_omega_cont_iter_functor {C : category} {F : functor C C} (hF : is_omega_cont F) (n : nat) : is_omega_cont (iter_functor F n). Proof. induction n as [|n IH]; simpl. - exact (is_omega_cont_functor_identity (C := C)). - apply (is_omega_cont_functor_composite _ _ IH hF). Defined. (** ** Binary product of functors: F * G : C -> D is omega continuous *) Lemma is_omega_cont_BinProduct_of_functors {C D : category} (F G : functor C D) (PD : BinProducts D) (HF : is_omega_cont F) (HG : is_omega_cont G) : is_omega_cont (BinProduct_of_functors _ _ PD F G). Proof. use (is_omega_cocont_op (F := functor_op (BinProduct_of_functors C D PD F G))). use (is_omega_cocont_BinCoproduct_of_functors _ (functor_op F) (functor_op G) (is_omega_cont_op HF) (is_omega_cont_op HG) ). Defined. (** Continuity is preserved by isomorphic functors *) Section cont_iso. (* As this section is proving a proposition, the hypothesis can be weakened from a specified iso to F an d G being isomorphic. *) Context {C D : category} {F G : functor C D} (αiso : @z_iso [C, D] F G). Local Definition αiso_op : @z_iso [opp_cat C, opp_cat D] (functor_op F) (functor_op G). Proof. set (αisoop := z_iso_inv αiso). use make_z_iso. - use make_nat_trans. + exact (λ x, pr1 (pr1 αisoop) x). + exact (λ x y f, ! pr2 (pr1 αisoop) y x f). - use make_nat_trans. + exact (λ x, pr1 (pr1 αiso) x). + exact (λ x y f, ! pr2 (pr1 αiso) y x f). - use tpair. + use nat_trans_eq. { apply homset_property. } intro c. exact (toforallpaths _ _ _ (base_paths _ _ (pr1 (pr2 (pr2 αiso)))) c). + use nat_trans_eq. { apply homset_property. } intro c. exact (toforallpaths _ _ _ (base_paths _ _ (pr2 (pr2 (pr2 αiso)))) c). Defined. Lemma is_omega_cont_z_iso : is_omega_cont F -> is_omega_cont G. Proof. intro H. use (is_omega_cocont_op (F := functor_op G)). use is_omega_cocont_z_iso. { exact (functor_op F). } - exact αiso_op. - exact (is_omega_cont_op H). Defined. End cont_iso. (** * If a functor is part of an equivalence of categories, it is both continuous and cocontinuous *) Section equivalence_of_categories. Lemma is_cont_equivalence_of_cats {C D : category} {F : functor C D} (e : adj_equivalence_of_cats F) : is_cont F. Proof. apply right_adjoint_cont. use are_adjoints_to_is_right_adjoint. - exact (pr1 (pr1 e)). - exact (pr2 (pr1 (adj_equivalence_of_cats_inv e))). Defined. Lemma is_cocont_equivalence_of_cats {C D : category} {F : functor C D} (e : adj_equivalence_of_cats F) : is_cocont F. Proof. apply left_adjoint_cocont. exact (pr1 e). Defined. End equivalence_of_categories. (** ** Post composition with a right adjoint is continuous *) Section post_composition_functor. Context {C D E : category}. Context (F : functor D E) (HF : is_right_adjoint F). Lemma is_cont_post_composition_functor : is_cont (post_composition_functor C D E F). Proof. apply right_adjoint_cont. apply (is_right_adjoint_post_composition_functor _ HF). Defined. Lemma is_omega_cont_post_composition_functor : is_omega_cont (post_composition_functor C D E F). Proof. now intros c L ccL; apply is_cont_post_composition_functor. Defined. End post_composition_functor. (** ** Direct proof that the precomposition functor is continuous *) Section pre_composition_functor. Lemma is_omega_cont_pre_composition_functor' {A B C : category} (F : functor A B) (H : Lims_of_shape conat_graph C) : is_omega_cont (pre_composition_functor _ _ C F). Proof. use (is_omega_cocont_op (F := functor_op (pre_composition_functor _ _ C F))). use is_omega_cocont_z_iso. 2: { set (facto := functor_op_of_precomp_functor_factorizes_through_functorcatofopp_nat_z_iso C F). set (t := z_iso_inv (z_iso_from_nat_z_iso (homset_property _) facto)). exact t. } repeat (use is_omega_cocont_functor_composite). 2: { apply is_omega_cocont_pre_composition_functor. intro ch. repeat (use tpair). - exact (pr1 (pr1 (H (chain_op ch)))). - exact (λ v, pr1 (pr2 (pr1 (H (chain_op ch)))) v). - exact (λ u v e, pr2 (pr2 (pr1 (H (chain_op ch)))) v u e). - exact (λ c cc, ((pr2 (H (chain_op ch))) c (cocone_op cc))). } - use is_cocont_equivalence_of_cats. exact (adj_equivalence_of_cats_inv (opfunctorcat_adjequiv_functorcatofoppcats B C)). - use is_cocont_equivalence_of_cats. apply opfunctorcat_adjequiv_functorcatofoppcats. Defined. End pre_composition_functor. (** ** A pair of functors (F,G) : A * B -> C * D is omega continuous if F and G are *) Section pair_functor. Context {A B C D : category} (F : functor A C) (G : functor B D). Lemma is_omega_cont_pair_functor (HF : is_omega_cont F) (HG : is_omega_cont G) : is_omega_cont (pair_functor F G). Proof. use (is_omega_cocont_op (F := functor_op (pair_functor F G))). use (is_omega_cocont_pair_functor _ _ (is_omega_cont_op HF) (is_omega_cont_op HG)). Defined. End pair_functor. (* Should be moved into Categorytheory/limits/graphs/limits.v *) Lemma mapcone_functor_composite {A B C : category} (F : A ⟶ B) (G : B ⟶ C) (g : graph) (D : diagram g A) {a : A} (cc : cone D a) : mapcone (F ∙ G) D cc = mapcone G (mapdiagram F D) (mapcone F D cc). Proof. apply subtypePath. - intros x. repeat (apply impred_isaprop; intro). apply C. - reflexivity. Qed. (** ** A functor F : A -> product_category I B is (omega-)continuous if each F_i : A -> B_i is *) Section functor_into_product_category. Context {I : UU} {A : category} {B : I -> category}. Lemma isLimCone_in_product_category {g : graph} (c : diagram g (product_category B)) (b : product_precategory B) (cc : cone c b) (M : ∏ i, isLimCone _ _ (mapcone (pr_functor I B i) _ cc)) : isLimCone c b cc. Proof. intros b' cc'. apply iscontraprop1. - abstract ( apply invproofirrelevance; intros f1 f2; apply subtypePath; [ intros f; apply impred_isaprop; intros v; apply has_homsets_product_precategory | ]; apply funextsec; intros i; set (MM := M i _ (mapcone (pr_functor I B i) _ cc')); set (H := proofirrelevancecontr MM); use (maponpaths pr1 (H (pr1 f1 i,,_) (pr1 f2 i,,_))); clear MM H; intros v ; [ exact (toforallpaths _ _ _ (pr2 f1 v) i) | exact (toforallpaths _ _ _ (pr2 f2 v) i) ] ) . - use tpair. + intros i. use (pr1 (pr1 (M i _ (mapcone (pr_functor I B i) _ cc')))). + abstract ( intros v; apply funextsec; intros i; use (pr2 (pr1 (M i _ (mapcone (pr_functor I B i) _ cc'))) v) ). Defined. Lemma is_cont_functor_into_product_category {F : functor A (product_category B)} (HF : ∏ (i : I), is_cont (functor_composite F (pr_functor I B i))) : is_cont F. Proof. intros gr cA a cc Hcc. apply isLimCone_in_product_category. intros i. rewrite <- mapcone_functor_composite. now apply HF, Hcc. Defined. Lemma is_omega_cont_functor_into_product_category {F : functor A (product_category B)} (HF : ∏ (i : I), is_omega_cont (functor_composite F (pr_functor I B i))) : is_omega_cont F. Proof. intros cA a cc Hcc. apply isLimCone_in_product_category. intros i. rewrite <- mapcone_functor_composite. now apply HF, Hcc. Defined. End functor_into_product_category. (** * *) Section tuple_functor. Context {I : UU} {A : category} {B : I -> category}. Lemma is_cont_tuple_functor {F : ∏ i, functor A (B i)} (HF : ∏ i, is_cont (F i)) : is_cont (tuple_functor F). Proof. apply is_cont_functor_into_product_category. intro i; rewrite pr_tuple_functor; apply HF. Defined. Lemma is_omega_cont_tuple_functor {F : ∏ i, functor A (B i)} (HF : ∏ i, is_omega_cont (F i)) : is_omega_cont (tuple_functor F). Proof. apply is_omega_cont_functor_into_product_category. intro i; rewrite pr_tuple_functor; apply HF. Defined. End tuple_functor. (** ** The functor "+ : C^I -> C" is continuous is equivalently with saying that coproducts commute with limits *) Section coprod_functor. Definition coproducts_commute_with_limits (C : category) : UU := ∏ I : UU, ∏ PC : Coproducts I C, is_cont (coproduct_functor _ PC). Definition omega_coproducts_commute_with_limits (C : category) : UU := ∏ I : UU, ∏ PC : Coproducts I C, is_omega_cont (coproduct_functor _ PC). End coprod_functor. (** ** Coproduct of families of functors: + F_i : C -> D is omega continuous given coproducts in D distribute over limits *) Section coproduct_of_functors. Context {I : UU} {C D : category} (HD : Coproducts I D). Lemma is_cont_coproduct_of_functors {F : ∏ (i : I), functor C D} (HF : ∏ i, is_cont (F i)) (com : coproducts_commute_with_limits D) : is_cont (coproduct_of_functors I _ _ HD F). Proof. use (transportf _ (coproduct_of_functors_alt_eq_coproduct_of_functors _ _ _ _ F) _). apply is_cont_functor_composite. - use is_cont_tuple_functor. apply HF. - apply com. Defined. Lemma is_omega_cont_coproduct_of_functors {F : ∏ (i : I), functor C D} (HF : ∏ i, is_omega_cont (F i)) (com : omega_coproducts_commute_with_limits D) : is_omega_cont (coproduct_of_functors I _ _ HD F). Proof. use (transportf _ (coproduct_of_functors_alt_eq_coproduct_of_functors _ _ _ _ F) _). apply is_omega_cont_functor_composite. - apply is_omega_cont_tuple_functor. apply HF. - apply com. Defined. End coproduct_of_functors. UniMath-20231010/UniMath/CategoryTheory/Chains/README.md000066400000000000000000000005031451125700300223060ustar00rootroot00000000000000# Chains and ω-(co)continuous functors This directory contains theory about ω-(co)ntinuous functors, i.e. functors which preserve (co)limits of chains, which are diagrams of the form X₀ → X₁ → ⋯ ([is_omega_cont] and [is_cont]). It also defines cochains, which are diagrams of the form X₀ ← X₁ ← ⋯. UniMath-20231010/UniMath/CategoryTheory/CommaCategories.v000066400000000000000000000405601451125700300230620ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens March 2016, Anthony Bordg May 2017 Niels van der Weide February 2022: rebasing of general comma categories on displayed categories ************************************************************) (** ********************************************************** Contents : - special comma categories (c ↓ K), called [cComma] (constant Comma) - forgetful functor [cComma_pr1] - morphism [f : C ⟦c, c'⟧] induces [functor_cComma_mor : functor (c' ↓ K) (c ↓ K)] - general comma categories [comma_category] - projection functors ([comma_pr1], [comma_pr2]) - inserter categories ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Section const_comma_category_definition. Context (M C : category) (K : functor M C) (c : C). Definition ccomma_object : UU := ∑ m, C⟦c, K m⟧. Definition ccomma_morphism (a b : ccomma_object) : UU := ∑ f : _ ⟦pr1 a, pr1 b⟧, pr2 a · #K f = pr2 b. Definition isaset_ccomma_morphism a b : isaset (ccomma_morphism a b). Proof. apply (isofhleveltotal2 2). - apply homset_property. - intro. apply hlevelntosn. apply homset_property. Qed. Definition cComma_mor_eq a b (f f' : ccomma_morphism a b) : pr1 f = pr1 f' -> f = f'. Proof. intro H. apply subtypePath. intro. apply homset_property. exact H. Qed. Definition ccomma_id a : ccomma_morphism a a. Proof. exists (identity _ ). abstract ( intermediate_path (pr2 a · identity _ ); [ apply maponpaths; apply functor_id |]; apply id_right ). Defined. Definition ccomma_comp a b d : ccomma_morphism a b -> ccomma_morphism b d -> ccomma_morphism a d. Proof. intros f g. exists (pr1 f · pr1 g). abstract ( rewrite functor_comp; rewrite assoc; rewrite (pr2 f); apply (pr2 g) ). Defined. Definition ccomma_precategory_ob_mor : precategory_ob_mor. Proof. exists ccomma_object. exact ccomma_morphism. Defined. Definition ccomma_precategory_data : precategory_data. Proof. exists ccomma_precategory_ob_mor. split. - exact ccomma_id. - exact ccomma_comp. Defined. Definition is_precategory_ccomma_precategory_data : is_precategory ccomma_precategory_data. Proof. repeat split. - intros. apply cComma_mor_eq. simpl. apply id_left. - intros. apply cComma_mor_eq. simpl. apply id_right. - intros. apply cComma_mor_eq. simpl. apply assoc. - intros. apply cComma_mor_eq. simpl. apply assoc'. Qed. Definition cComma_precat : precategory. Proof. exists ccomma_precategory_data. exact is_precategory_ccomma_precategory_data. Defined. Lemma has_homsets_cComma_precat: has_homsets cComma_precat. Proof. red. intros a b. apply isaset_total2. - apply homset_property. - intro. apply hlevelntosn. apply homset_property. Qed. Definition cComma : category := cComma_precat ,, has_homsets_cComma_precat. Definition ccomma_pr1_functor_data : functor_data cComma M. Proof. exists pr1. intros a b f. exact (pr1 f). Defined. Lemma is_functor_ccomma_pr1 : is_functor ccomma_pr1_functor_data. Proof. split. - intro a. apply idpath. - intros ? ? ? ? ?. apply idpath. Qed. Definition cComma_pr1 : cComma ⟶ M := tpair _ _ is_functor_ccomma_pr1. End const_comma_category_definition. Section lemmas_on_const_comma_cats. Context (M C : category). Local Notation "c ↓ K" := (cComma _ _ K c) (at level 3). Context (K : functor M C). Context {c c' : C}. Context (h : C ⟦c, c'⟧). Definition cComma_mor_ob : c' ↓ K → c ↓ K. Proof. intro af. exists (pr1 af). exact (h · pr2 af). Defined. Definition cComma_mor_mor (af af' : c' ↓ K) (g : c' ↓ K ⟦af, af'⟧) : c ↓ K ⟦cComma_mor_ob af, cComma_mor_ob af'⟧. Proof. exists (pr1 g). abstract ( simpl; rewrite <- assoc; rewrite (pr2 g); apply idpath ). Defined. Definition cComma_mor_functor_data : functor_data (c' ↓ K) (c ↓ K). Proof. exists cComma_mor_ob. exact cComma_mor_mor. Defined. Lemma is_functor_cComma_mor_functor_data : is_functor cComma_mor_functor_data. Proof. split. - intro. apply cComma_mor_eq. apply idpath. - intros ? ? ? ? ?. apply cComma_mor_eq. apply idpath. Qed. Definition functor_cComma_mor : c' ↓ K ⟶ c ↓ K := tpair _ _ is_functor_cComma_mor_functor_data. End lemmas_on_const_comma_cats. (** General comma categories *) Section CommaCategory. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃). (** Definition of comma categories via displayed categories *) Definition comma_disp_cat_ob_mor : disp_cat_ob_mor (category_binproduct C₁ C₂). Proof. use tpair. - exact (λ x, F (pr1 x) --> G (pr2 x)). - exact (λ x y i₁ i₂ f, i₁ · #G (pr2 f) = #F (pr1 f) · i₂). Defined. Definition comma_disp_cat_id_comp : disp_cat_id_comp _ comma_disp_cat_ob_mor. Proof. use tpair. - intros x i; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - cbn; intros x y z f g i₁ i₂ i₃ p q. apply pathsinv0. rewrite !functor_comp. rewrite !assoc'. rewrite <- q. rewrite !assoc. rewrite p. apply idpath. Qed. Definition comma_disp_cat_data : disp_cat_data (category_binproduct C₁ C₂) := comma_disp_cat_ob_mor,, comma_disp_cat_id_comp. Definition comma_disp_cat_axioms : disp_cat_axioms _ comma_disp_cat_data. Proof. repeat split ; intros ; try (apply homset_property). apply isasetaprop. apply homset_property. Qed. Definition comma_disp_cat : disp_cat (category_binproduct C₁ C₂). Proof. use tpair. - exact comma_disp_cat_data. - exact comma_disp_cat_axioms. Defined. Definition comma : category := total_category comma_disp_cat. (** Univalence of the comma category *) Definition is_univalent_disp_comma_disp_cat (HC₃ : is_univalent C₃) : is_univalent_disp comma_disp_cat. Proof. intros x y p i₁ i₂. induction p. use isweqimplimpl. - intros p. pose (pr1 p) as m. cbn in m. rewrite !functor_id in m. rewrite id_left, id_right in m. assumption. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_comma (HC₁ : is_univalent C₁) (HC₂ : is_univalent C₂) (HC₃ : is_univalent C₃) : is_univalent comma. Proof. use is_univalent_total_category. - apply is_univalent_category_binproduct. + exact HC₁. + exact HC₂. - exact (is_univalent_disp_comma_disp_cat HC₃). Defined. (** Isos in comma *) Section IsIsoComma. Context {x y : comma} (f : x --> y) (Hf1 : is_z_isomorphism (pr11 f)) (Hf2 : is_z_isomorphism (pr21 f)). Definition inv_comma : y --> x. Proof. refine ((inv_from_z_iso (make_z_iso' _ Hf1) ,, inv_from_z_iso (make_z_iso' _ Hf2)) ,, _). abstract (cbn; apply pathsinv0; rewrite !functor_on_inv_from_z_iso; use z_iso_inv_on_left; rewrite assoc'; refine (!_) ; use z_iso_inv_on_right; cbn; exact (pr2 f)). Defined. Lemma is_iso_comma_left_inv : f · inv_comma = identity x. Proof. use subtypePath. { intro. apply homset_property. } use pathsdirprod; cbn. - exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf1)). - exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf2)). Qed. Lemma is_iso_comma_right_inv : inv_comma · f = identity y. Proof. use subtypePath. { intro. apply homset_property. } use pathsdirprod; cbn. - exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf1)). - exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf2)). Qed. Definition is_z_iso_comma : is_z_isomorphism f. Proof. exists inv_comma. split. - exact is_iso_comma_left_inv. - exact is_iso_comma_right_inv. Defined. End IsIsoComma. (** Projection functors *) Definition comma_pr1 : comma ⟶ C₁ := pr1_category comma_disp_cat ∙ pr1_functor C₁ C₂. Definition comma_pr2 : comma ⟶ C₂ := pr1_category comma_disp_cat ∙ pr2_functor C₁ C₂. (** Natural isomorphism witnessing the commutation *) Definition comma_commute_nat_trans_data : nat_trans_data (comma_pr1 ∙ F) (comma_pr2 ∙ G). Proof. intros x; cbn in x. exact (pr2 x). Defined. Definition comma_commute_is_nat_trans : is_nat_trans _ _ comma_commute_nat_trans_data. Proof. intros x y f; unfold comma_commute_nat_trans_data; cbn; cbn in f. exact (!(pr2 f)). Qed. Definition comma_commute : comma_pr1 ∙ F ⟹ comma_pr2 ∙ G. Proof. use make_nat_trans. - exact comma_commute_nat_trans_data. - exact comma_commute_is_nat_trans. Defined. (** Mapping property of comma category We need to check three mapping properties: - The first one gives the existence of a functor - The second one gives the existence of a natural transformation - The third one can be used to show that two natural transformations are equal *) Section UniversalMappingProperty. Context {D : category} (P : D ⟶ C₁) (Q : D ⟶ C₂) (η : P ∙ F ⟹ Q ∙ G). (** The functor witnessing the universal property *) Definition comma_ump1_data : functor_data D comma. Proof. use make_functor_data. - exact (λ d, (P d ,, Q d) ,, η d). - exact (λ d₁ d₂ f, (#P f ,, #Q f) ,, !(nat_trans_ax η _ _ f)). Defined. Definition comma_ump1_is_functor : is_functor comma_ump1_data. Proof. split. - intro x; cbn. use subtypePath. { intro; apply homset_property. } cbn. rewrite !functor_id. apply idpath. - intros x y z f g; cbn. use subtypePath. { intro; apply homset_property. } cbn. rewrite !functor_comp. apply idpath. Qed. Definition comma_ump1 : D ⟶ comma. Proof. use make_functor. - exact comma_ump1_data. - exact comma_ump1_is_functor. Defined. (** The computation rules *) Definition comma_ump1_pr1_nat_trans_data : nat_trans_data (comma_ump1 ∙ comma_pr1) P := λ x, identity _. Definition comma_ump1_pr1_is_nat_trans : is_nat_trans _ _ comma_ump1_pr1_nat_trans_data. Proof. intros x y f; cbn; unfold comma_ump1_pr1_nat_trans_data. rewrite id_left, id_right. apply idpath. Qed. Definition comma_ump1_pr1_nat_trans : comma_ump1 ∙ comma_pr1 ⟹ P. Proof. use make_nat_trans. - exact comma_ump1_pr1_nat_trans_data. - exact comma_ump1_pr1_is_nat_trans. Defined. (** Computation rule for first projection *) Definition comma_ump1_pr1 : nat_z_iso (comma_ump1 ∙ comma_pr1) P. Proof. use make_nat_z_iso. - exact comma_ump1_pr1_nat_trans. - intro. apply identity_is_z_iso. Defined. Definition comma_ump1_pr2_nat_trans_data : nat_trans_data (comma_ump1 ∙ comma_pr2) Q := λ x, identity _. Definition comma_ump1_pr2_is_nat_trans : is_nat_trans _ _ comma_ump1_pr2_nat_trans_data. Proof. intros x y f; cbn; unfold comma_ump1_pr2_nat_trans_data. rewrite id_left, id_right. apply idpath. Qed. Definition comma_ump1_pr2_nat_trans : comma_ump1 ∙ comma_pr2 ⟹ Q. Proof. use make_nat_trans. - exact comma_ump1_pr2_nat_trans_data. - exact comma_ump1_pr2_is_nat_trans. Defined. (** Computation rule for second projection *) Definition comma_ump1_pr2 : nat_z_iso (comma_ump1 ∙ comma_pr2) Q. Proof. use make_nat_z_iso. - exact comma_ump1_pr2_nat_trans. - intro. apply identity_is_z_iso. Defined. (** Computation rule for natural iso *) Definition comma_ump1_commute : pre_whisker comma_ump1 comma_commute = nat_trans_comp _ _ _ (nat_trans_functor_assoc_inv _ _ _) (nat_trans_comp _ _ _ (post_whisker comma_ump1_pr1 F) (nat_trans_comp _ _ _ η (nat_trans_comp _ _ _ (post_whisker (nat_z_iso_inv comma_ump1_pr2) G) (nat_trans_functor_assoc _ _ _)))). Proof. use nat_trans_eq. { apply homset_property. } intro; cbn; unfold comma_ump1_pr1_nat_trans_data. rewrite (functor_id F), (functor_id G). rewrite !id_left. rewrite id_right. apply idpath. Qed. (** Now we look at the second universal mapping property *) Context (Φ₁ Φ₂ : D ⟶ comma) (τ₁ : Φ₁ ∙ comma_pr1 ⟹ Φ₂ ∙ comma_pr1) (τ₂ : Φ₁ ∙ comma_pr2 ⟹ Φ₂ ∙ comma_pr2) (p : ∏ (x : D), pr2 (Φ₁ x) · #G (τ₂ x) = #F (τ₁ x) · pr2 (Φ₂ x)). Definition comma_ump2_nat_trans_data : nat_trans_data Φ₁ Φ₂. Proof. intro x. simple refine ((_ ,, _) ,, _) ; cbn. - exact (τ₁ x). - exact (τ₂ x). - abstract (exact (p x)). Defined. Definition comma_ump2_is_nat_trans : is_nat_trans _ _ comma_ump2_nat_trans_data. Proof. intros x y f. use subtypePath. { intro ; apply homset_property. } use pathsdirprod. - exact (nat_trans_ax τ₁ _ _ f). - exact (nat_trans_ax τ₂ _ _ f). Qed. Definition comma_ump2 : Φ₁ ⟹ Φ₂. Proof. use make_nat_trans. - exact comma_ump2_nat_trans_data. - exact comma_ump2_is_nat_trans. Defined. (** The computation rules *) Definition comma_ump2_pr1 : post_whisker comma_ump2 comma_pr1 = τ₁. Proof. use nat_trans_eq. { intro; apply homset_property. } intro x; cbn. apply idpath. Qed. Definition comma_ump2_pr2 : post_whisker comma_ump2 comma_pr2 = τ₂. Proof. use nat_trans_eq. { intro; apply homset_property. } intro x; cbn. apply idpath. Qed. (** The uniqueness *) Context {n₁ n₂ : Φ₁ ⟹ Φ₂} (n₁_pr1 : post_whisker n₁ comma_pr1 = τ₁) (n₁_pr2 : post_whisker n₁ comma_pr2 = τ₂) (n₂_pr1 : post_whisker n₂ comma_pr1 = τ₁) (n₂_pr2 : post_whisker n₂ comma_pr2 = τ₂). Definition comma_ump_eq_nat_trans : n₁ = n₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. use subtypePath. { intro; apply homset_property. } use pathsdirprod. - pose (nat_trans_eq_pointwise n₁_pr1 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr1 x) as q₂. cbn in q₁, q₂. exact (q₁ @ !q₂). - pose (nat_trans_eq_pointwise n₁_pr2 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr2 x) as q₂. cbn in q₁, q₂. exact (q₁ @ !q₂). Qed. End UniversalMappingProperty. End CommaCategory. Definition univalent_comma {C₁ C₂ C₃ : univalent_category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃) : univalent_category. Proof. use make_univalent_category. - exact (comma F G). - apply is_univalent_comma. + exact (pr2 C₁). + exact (pr2 C₂). + exact (pr2 C₃). Defined. UniMath-20231010/UniMath/CategoryTheory/CompletelyIterativeAlgebras.v000066400000000000000000000121661451125700300254540ustar00rootroot00000000000000(** **************************************************************** Completely iterative algebras according to Stefan Milius, Completely iterative algebras and completely iterative monads, https://doi.org/10.1016/j.ic.2004.05.003 Ralph Matthes, June 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCoalgebras. Local Open Scope cat. Section FixAFunctor. Context {C : category} (CP : BinCoproducts C) (F : functor C C). (** As does Stefan Milius, we use the abbreviation cia for completely iterative algebras. *) Definition cia_characteristic_formula (X : algebra_ob F) {x : C} (e : x --> CP (F x) (alg_carrier _ X)) (h : x --> alg_carrier _ X) : UU := h = e · BinCoproductOfArrows _ (CP _ _) (CP _ _) (#F h) (identity _) · (BinCoproductArrow (CP _ _) (alg_map _ X) (identity _)). (** [e] is called a "flat equation morphism" *) Lemma isaprop_cia_characteristic_formula (X : algebra_ob F) {x : C} (e : x --> CP (F x) (alg_carrier _ X)) (h : x --> alg_carrier _ X) : isaprop (cia_characteristic_formula X e h). Proof. apply C. Qed. Definition cia (X : algebra_ob F) : UU := ∏ (x : C) (e : x --> CP (F x) (alg_carrier _ X)), ∃! h : x --> alg_carrier _ X, cia_characteristic_formula X e h. (** The following is a more modular proof for Example 2.5(iii) in Milius' article since we directly use primitive corecursion. *) Section cia_from_final_coalgebra. Context (X : coalgebra_ob F) (isTerminalX : isTerminal (CoAlg_category F) X). Local Definition Xinv : algebra_ob F. Proof. exists (coalg_carrier _ X). exact (inv_from_z_iso (finalcoalgebra_z_iso _ _ _ isTerminalX)). Defined. Local Definition ϕ_for_cia (x : C) (e : x --> CP (F x) (alg_carrier _ Xinv)) : x --> F(CP x (alg_carrier _ Xinv)). Proof. simple refine (e · _). apply (BinCoproductArrow (CP _ _)). - apply #F. apply BinCoproductIn1. - simple refine ((coalg_map _ X) · _). apply #F. apply BinCoproductIn2. Defined. Lemma ϕ_for_cia_has_equivalent_characteristic_formula (x : C) (e : x --> CP (F x) (alg_carrier _ Xinv)) (h : C ⟦ x, alg_carrier F Xinv ⟧) : primitive_corecursion_characteristic_formula CP (ϕ_for_cia x e) h ≃ cia_characteristic_formula Xinv e h. Proof. apply weqimplimpl. - intro H. red in H; red. apply pathsinv0 in H. apply (z_iso_inv_on_left _ _ _ _ (finalcoalgebra_z_iso _ _ _ isTerminalX)) in H. etrans; [ exact H |]. clear H. unfold ϕ_for_cia. repeat rewrite assoc'. apply maponpaths. cbn. rewrite postcompWithBinCoproductArrow. rewrite precompWithBinCoproductArrow. rewrite id_left. apply maponpaths_12. + rewrite assoc. rewrite <- functor_comp. rewrite BinCoproductIn1Commutes. apply idpath. + etrans. { rewrite assoc. apply cancel_postcomposition. rewrite assoc'. apply maponpaths. rewrite <- functor_comp. rewrite BinCoproductIn2Commutes. apply functor_id. } rewrite id_right. apply αα'_idA. - intro H. red in H; red. etrans. { apply cancel_postcomposition. exact H. } clear H. unfold ϕ_for_cia. repeat rewrite assoc'. apply maponpaths. cbn. do 2 rewrite postcompWithBinCoproductArrow. rewrite precompWithBinCoproductArrow. do 2 rewrite id_left. apply maponpaths_12. + rewrite <- functor_comp. rewrite BinCoproductIn1Commutes. etrans. { apply maponpaths. apply α'α_idFA. } apply id_right. + rewrite assoc'. rewrite <- functor_comp. rewrite BinCoproductIn2Commutes. rewrite functor_id. apply pathsinv0, id_right. - apply C. - apply isaprop_cia_characteristic_formula. Qed. Definition cia_from_final_coalgebra : cia Xinv. Proof. intros x e. simple refine (iscontrretract _ _ _ (primitive_corecursion CP isTerminalX (ϕ_for_cia x e))). - intros [h H]. exists h. apply ϕ_for_cia_has_equivalent_characteristic_formula. assumption. - intros [h H]. exists h. apply ϕ_for_cia_has_equivalent_characteristic_formula. assumption. - intros [h Hyp]. use total2_paths_f. + apply idpath. + apply isaprop_cia_characteristic_formula. Qed. End cia_from_final_coalgebra. End FixAFunctor. UniMath-20231010/UniMath/CategoryTheory/Connected.v000066400000000000000000000113311451125700300217140ustar00rootroot00000000000000(*************************************************************************** Connected categories and groupoids A category is called connected if it is inhabited and for every two objects there is a zig-zag between them. A groupoid is called connected if it is inhabited and if for every two objects there is a morphism between them. Note: these two notions are in general not a proposition. The reason for that is that the choice of the zig-zag or of the morphism is not required to be natural. As such, different choices do not have to be equal up to isomorphism. Contents 1. Definition of connected categories 2. Categories with a (weak) terminal object are connected 3. Categories with a (weak) initial object are connected 4. Connected groupoids and connected categories ***************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.ZigZag. Local Open Scope cat. (** 1. Definition of connected categories *) Definition connected_category (C : category) : UU := ob C × ∏ (x y : C), zig_zag x y. Definition ob_of_connected_category {C : category} (H : connected_category C) : C := pr1 H. Definition zig_zag_of_connected_category {C : category} (H : connected_category C) (x y : C) : zig_zag x y := pr2 H x y. Definition make_connected_category {C : category} (c : C) (zs : ∏ (x y : C), zig_zag x y) : connected_category C := c ,, zs. (** 2. Categories with a (weak) terminal object are connected *) Definition weakly_terminal_to_connected {C : category} (c : C) (fs : ∏ (w : C), w --> c) : connected_category C. Proof. use make_connected_category. - exact c. - exact (λ x y, x -[ fs x ]-> c <-[ fs y ]- y ■). Defined. Definition terminal_to_connected {C : category} (T : Terminal C) : connected_category C. Proof. use weakly_terminal_to_connected. - exact T. - exact (λ x, TerminalArrow T x). Defined. Definition HSET_connected_terminal : connected_category HSET. Proof. use terminal_to_connected. exact TerminalHSET. Defined. (** 3. Categories with a (weak) initial object are connected *) Definition weakly_initial_to_connected {C : category} (c : C) (fs : ∏ (w : C), c --> w) : connected_category C. Proof. use make_connected_category. - exact c. - exact (λ x y, x <-[ fs x ]- c -[ fs y ]-> y ■). Defined. Definition initial_to_connected {C : category} (I : Initial C) : connected_category C. Proof. use weakly_initial_to_connected. - exact I. - exact (λ x, InitialArrow I x). Defined. Definition HSET_connected_initial : connected_category HSET. Proof. use initial_to_connected. exact InitialHSET. Defined. (** 4. Connected groupoids and connected categories *) Definition connected_groupoid (G : groupoid) : UU := ob G × ∏ (x y : G), x --> y. Definition ob_of_connected_groupoid {G : groupoid} (H : connected_groupoid G) : G := pr1 H. Definition mor_of_connected_groupoid {G : groupoid} (H : connected_groupoid G) (x y : G) : x --> y := pr2 H x y. Definition make_connected_groupoid {G : groupoid} (c : G) (zs : ∏ (x y : G), x --> y) : connected_groupoid G := c ,, zs. Definition connected_groupoid_to_connected_category {G : groupoid} (H : connected_groupoid G) : connected_category G. Proof. use make_connected_category. - exact (ob_of_connected_groupoid H). - exact (λ x y, x -[ mor_of_connected_groupoid H x y ]-> y ■). Defined. Definition connected_category_to_connected_groupoid {G : groupoid} (H : connected_category G) : connected_groupoid G. Proof. use make_connected_groupoid. - exact (ob_of_connected_category H). - exact (λ x y, zig_zag_in_grpd_to_mor (zig_zag_of_connected_category H x y)). Defined. Definition unit_connected_category : connected_category unit_category. Proof. apply connected_groupoid_to_connected_category. use make_connected_groupoid. - exact tt. - apply isapropunit. Defined. UniMath-20231010/UniMath/CategoryTheory/Core.v000066400000000000000000000217311451125700300207070ustar00rootroot00000000000000(********************************************************************* Cores of categories In this file we study cores of categories. The core of a category is the subcategory whose morphisms are the isomorphisms in the original category. Contents 1. The core 2. Functor from the core to the category 3. Factoring via the core 4. Functors between cores 5. A diagonal functor on cores 6. The functor from the core to the opposite 7. Idtoiso in the core *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Section Core. Context (C : category). (** 1. The core *) Definition core_precategory_ob_mor : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact C. - exact (λ x y, z_iso x y). Defined. Definition core_precategory_data : precategory_data. Proof. use make_precategory_data. - exact core_precategory_ob_mor. - exact (λ x, identity_z_iso x). - exact (λ x y z i₁ i₂, z_iso_comp i₁ i₂). Defined. Definition core_is_precategory : is_precategory core_precategory_data. Proof. use make_is_precategory_one_assoc ; intros ; use z_iso_eq ; cbn. - apply id_left. - apply id_right. - apply assoc. Qed. Definition core_precategory : precategory. Proof. use make_precategory. - exact core_precategory_data. - exact core_is_precategory. Defined. Definition core : category. Proof. use make_category. - exact core_precategory. - intros x y ; cbn. use isaset_z_iso. Defined. Definition is_z_iso_core {x y : core} (f : x --> y) : is_z_isomorphism f. Proof. exists (z_iso_inv_from_z_iso f). - abstract (split ; use z_iso_eq ; cbn ; [ apply z_iso_inv_after_z_iso | apply z_iso_after_z_iso_inv]). Defined. Definition is_pregroupoid_core : is_pregroupoid core. Proof. exact @is_z_iso_core. Defined. Definition core_z_iso_weq (x y : C) : @z_iso C x y ≃ @z_iso core x y. Proof. use make_weq. - simple refine (λ i, _,,_). + exact i. + apply is_z_iso_core. - use isweq_iso. + exact (λ i, pr1 i). + abstract (intro i ; use z_iso_eq ; apply idpath). + abstract (intro i ; use z_iso_eq ; apply idpath). Defined. Definition is_univalent_core (HC : is_univalent C) : is_univalent core. Proof. intros x y. use weqhomot. - exact (core_z_iso_weq x y ∘ make_weq idtoiso (HC x y))%weq. - abstract (intro p ; induction p ; use z_iso_eq ; cbn ; apply idpath). Defined. (** 2. Functor from the core to the category *) Definition functor_core_data : functor_data core C. Proof. use make_functor_data. - exact (λ x, x). - exact (λ x y i, pr1 i). Defined. Definition functor_core_is_functor : is_functor functor_core_data. Proof. split. - intro x ; cbn. apply idpath. - intros x y z f g ; cbn. apply idpath. Qed. Definition functor_core : core ⟶ C. Proof. use make_functor. - exact functor_core_data. - exact functor_core_is_functor. Defined. Definition functor_core_eso : essentially_surjective functor_core. Proof. intro x. apply hinhpr. refine (x ,, _). apply identity_z_iso. Defined. Definition functor_core_faithful : faithful functor_core. Proof. intros x y f. use invproofirrelevance. intros φ₁ φ₂. use subtypePath ; [ intro ; apply homset_property | ]. use z_iso_eq ; cbn. exact (pr2 φ₁ @ !(pr2 φ₂)). Qed. Definition functor_core_full_on_iso : full_on_iso functor_core. Proof. intros x y f ; cbn in *. apply hinhpr. simple refine (_ ,, _). - refine (f ,, _). apply is_z_iso_core. - abstract (use z_iso_eq ; cbn ; apply idpath). Defined. Definition functor_core_pseudomonic : pseudomonic functor_core. Proof. split. - exact functor_core_faithful. - exact functor_core_full_on_iso. Defined. (** 3. Factoring via the core *) Section FactorCore. Context {G : groupoid} (F : G ⟶ C). Definition factor_through_core_data : functor_data G core. Proof. use make_functor_data. - exact (λ x, F x). - exact (λ x y f, functor_on_z_iso F (_ ,, pr2 G _ _ f)). Defined. Definition factor_through_core_is_functor : is_functor factor_through_core_data. Proof. split ; intro ; intros ; use z_iso_eq ; cbn. - apply functor_id. - apply functor_comp. Qed. Definition factor_through_core : G ⟶ core. Proof. use make_functor. - exact factor_through_core_data. - exact factor_through_core_is_functor. Defined. Definition factor_through_core_commute : factor_through_core ∙ functor_core ⟹ F. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition factor_through_core_commute_z_iso : nat_z_iso (factor_through_core ∙ functor_core) F. Proof. use make_nat_z_iso. - exact factor_through_core_commute. - intro x. apply identity_is_z_iso. Defined. End FactorCore. Section NatIsoToCore. Context {G : groupoid} {F₁ F₂ : G ⟶ core} (α : nat_z_iso (F₁ ∙ functor_core) (F₂ ∙ functor_core)). Definition nat_trans_to_core : F₁ ⟹ F₂. Proof. use make_nat_trans. - exact (λ x, nat_z_iso_pointwise_z_iso α x). - abstract (intros x₁ x₂ f ; cbn ; use z_iso_eq ; cbn ; exact (nat_trans_ax α _ _ f)). Defined. Definition nat_iso_to_core : nat_z_iso F₁ F₂. Proof. use make_nat_z_iso. - exact nat_trans_to_core. - intro x. apply is_z_iso_core. Defined. End NatIsoToCore. End Core. Definition univalent_core (C : univalent_category) : univalent_category. Proof. use make_univalent_category. - exact (core C). - apply is_univalent_core. exact (pr2 C). Defined. (** 4. Functors between cores *) Section CoreFunctor. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂). Definition core_functor_data : functor_data (core C₁) (core C₂). Proof. use make_functor_data. - exact (λ x, F x). - exact (λ x y f, functor_on_z_iso F f). Defined. Definition core_functor_is_functor : is_functor core_functor_data. Proof. split. - intro x. use z_iso_eq ; cbn. apply functor_id. - intros x y z f g. use z_iso_eq ; cbn. apply functor_comp. Qed. Definition core_functor : core C₁ ⟶ core C₂. Proof. use make_functor. - exact core_functor_data. - exact core_functor_is_functor. Defined. End CoreFunctor. (** 5. A diagonal functor on cores *) Definition core_diag_data (C : category) : functor_data (core C) (category_binproduct C^op C). Proof. use make_functor_data. - exact (λ x, x ,, x). - exact (λ x y f, inv_from_z_iso f ,, pr1 f). Defined. Definition core_diag_laws (C : category) : is_functor (core_diag_data C). Proof. split ; intro ; intros ; apply idpath. Qed. Definition core_diag (C : category) : core C ⟶ category_binproduct C^op C. Proof. use make_functor. - exact (core_diag_data C). - exact (core_diag_laws C). Defined. (** 6. The functor from the core to the opposite *) Definition functor_core_op_data (C : category) : functor_data (core C) C^op. Proof. use make_functor_data. - exact (λ x, x). - exact (λ x y f, inv_from_z_iso f). Defined. Definition functor_core_op_laws (C : category) : is_functor (functor_core_op_data C). Proof. split ; intro ; intros ; apply idpath. Qed. Definition functor_core_op (C : category) : core C ⟶ C^op. Proof. use make_functor. - exact (functor_core_op_data C). - exact (functor_core_op_laws C). Defined. (** 7. Idtoiso in the core *) Proposition idtoiso_core {C : category} {x y : C} (p : x = y) : pr11 (@idtoiso (core C) _ _ p) = pr1 (@idtoiso C _ _ p). Proof. induction p ; cbn. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/Core/000077500000000000000000000000001451125700300205145ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Core/Categories.v000066400000000000000000000250161451125700300227740ustar00rootroot00000000000000(** * Categories Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman January 2013 *) (** ** Contents : - precategories: homs are arbitrary types [precategory] - categories: hom-types are sets [category] *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Notations. (** * Definition of a precategory *) Definition precategory_ob_mor : UU := ∑ ob : UU, ob -> ob -> UU. Definition make_precategory_ob_mor (ob : UU)(mor : ob -> ob -> UU) : precategory_ob_mor := tpair _ ob mor. Definition ob (C : precategory_ob_mor) : UU := @pr1 _ _ C. Coercion ob : precategory_ob_mor >-> UU. Definition precategory_morphisms { C : precategory_ob_mor } : C -> C -> UU := pr2 C. (** We introduce notation for morphisms *) (** in order for this notation not to pollute subsequent files, we define this notation within the scope "cat" *) Declare Scope cat. Delimit Scope cat with cat. (* for precategories *) Delimit Scope cat with Cat. (* a slight enhancement for categories *) Local Open Scope cat. Notation "a --> b" := (precategory_morphisms a b) : cat. Notation "b <-- a" := (precategory_morphisms a b) (only parsing) : cat. Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) : cat. (* ⟦ to input: type "\[[" or "\(" with Agda input method ⟧ to input: type "\]]" or "\)" with Agda input method *) (** ** [precategory_data] *) (** data of a precategory : - objects - morphisms - identity morphisms - composition *) Definition precategory_id_comp (C : precategory_ob_mor) : UU := (∏ c : C, c --> c) (* identities *) × (∏ a b c : C, a --> b -> b --> c -> a --> c). (* composition *) Definition precategory_data : UU := ∑ C : precategory_ob_mor, precategory_id_comp C. Definition make_precategory_data (C : precategory_ob_mor) (id : ∏ c : C, c --> c) (comp: ∏ a b c : C, a --> b -> b --> c -> a --> c) : precategory_data := tpair _ C (make_dirprod id comp). Definition precategory_ob_mor_from_precategory_data (C : precategory_data) : precategory_ob_mor := pr1 C. Coercion precategory_ob_mor_from_precategory_data : precategory_data >-> precategory_ob_mor. Definition identity {C : precategory_data} : ∏ c : C, c --> c := pr1 (pr2 C). Definition compose {C : precategory_data} { a b c : C } : a --> b -> b --> c -> a --> c := pr2 (pr2 C) a b c. Notation "f · g" := (compose f g) : cat. (* to input: type "\centerdot" or "\cdot" with Agda input method *) Notation "g ∘ f" := (compose f g) (only parsing) : cat. (* agda input \circ *) Definition postcompose {C : precategory_data} {a b c : C} (g : b --> c) (f : a --> b) : a --> c := compose f g. (** ** Axioms of a precategory *) (** - identity is left and right neutral for composition - composition is associative *) Definition is_precategory (C : precategory_data) : UU := ((∏ (a b : C) (f : a --> b), identity a · f = f) × (∏ (a b : C) (f : a --> b), f · identity b = f)) × ((∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = (f · g) · h) × (∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), (f · g) · h = f · (g · h))). Definition is_precategory_one_assoc (C : precategory_data) : UU := ((∏ (a b : C) (f : a --> b), identity a · f = f) × (∏ (a b : C) (f : a --> b), f · identity b = f)) × (∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = (f · g) · h). Definition is_precategory_one_assoc_to_two (C : precategory_data) : is_precategory_one_assoc C -> is_precategory C := λ i, (pr11 i,,pr21 i),,(pr2 i,,λ a b c d f g h, pathsinv0 (pr2 i a b c d f g h)). Definition make_is_precategory {C : precategory_data} (H1 : ∏ (a b : C) (f : a --> b), identity a · f = f) (H2 : ∏ (a b : C) (f : a --> b), f · identity b = f) (H3 : ∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = (f · g) · h) (H4 : ∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), (f · g) · h = f · (g · h)) : is_precategory C := (H1,,H2),,(H3,,H4). Definition make_is_precategory_one_assoc {C : precategory_data} (H1 : ∏ (a b : C) (f : a --> b), identity a · f = f) (H2 : ∏ (a b : C) (f : a --> b), f · identity b = f) (H3 : ∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = (f · g) · h) : is_precategory C := (H1,,H2),,(H3,,λ a b c d f g h, pathsinv0 (H3 a b c d f g h)). Definition precategory := total2 is_precategory. Definition make_precategory (C : precategory_data) (H : is_precategory C) : precategory := tpair _ C H. Definition make_precategory_one_assoc (C : precategory_data) (H : is_precategory_one_assoc C) : precategory := tpair _ C (is_precategory_one_assoc_to_two C H). Definition precategory_data_from_precategory (C : precategory) : precategory_data := pr1 C. Coercion precategory_data_from_precategory : precategory >-> precategory_data. Definition has_homsets (C : precategory_ob_mor) : UU := ∏ a b : C, isaset (a --> b). Lemma isaprop_has_homsets (C : precategory_ob_mor) : isaprop (has_homsets C). Proof. do 2 (apply impred; intro). apply isapropisaset. Qed. Definition category := ∑ C:precategory, has_homsets C. Definition make_category C h : category := C,,h. Definition category_to_precategory : category -> precategory := pr1. Coercion category_to_precategory : category >-> precategory. Coercion homset_property (C : category) : has_homsets C := pr2 C. Definition homset {C : category} (x y : C) : hSet := x --> y ,, homset_property C x y. Definition makecategory (obj : UU) (mor : obj -> obj -> UU) (homsets : ∏ a b, isaset (mor a b)) (identity : ∏ i, mor i i) (compose : ∏ i j k (f:mor i j) (g:mor j k), mor i k) (right : ∏ i j (f:mor i j), compose _ _ _ (identity i) f = f) (left : ∏ i j (f:mor i j), compose _ _ _ f (identity j) = f) (associativity : ∏ a b c d (f:mor a b) (g:mor b c) (h:mor c d), compose _ _ _ f (compose _ _ _ g h) = compose _ _ _ (compose _ _ _ f g) h) (associativity' : ∏ a b c d (f:mor a b) (g:mor b c) (h:mor c d), compose _ _ _ (compose _ _ _ f g) h = compose _ _ _ f (compose _ _ _ g h)) : category := (make_precategory (make_precategory_data (make_precategory_ob_mor obj (λ i j, mor i j)) identity compose) ((right,,left),,(associativity,,associativity'))),,homsets. Lemma isaprop_is_precategory (C : precategory_data)(hs: has_homsets C) : isaprop (is_precategory C). Proof. apply isofhleveltotal2. { apply isofhleveltotal2. { repeat (apply impred; intro). apply hs. } intros _. repeat (apply impred; intro); apply hs. } intros _. apply isofhleveltotal2. { repeat (apply impred; intro); apply hs. } { intros. repeat (apply impred; intro). apply hs. } Qed. Lemma category_eq (C D : category) : (C:precategory_data) = (D:precategory_data) -> C=D. Proof. intro e. apply subtypePath. intro. apply isaprop_has_homsets. apply subtypePath'. { assumption. } apply isaprop_is_precategory. apply homset_property. Defined. Definition id_left (C : precategory) : ∏ (a b : C) (f : a --> b), identity a · f = f := pr112 C. Definition id_right (C : precategory) : ∏ (a b : C) (f : a --> b), f · identity b = f := pr212 C. Definition assoc (C : precategory) : ∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), f · (g · h) = (f · g) · h := pr122 C. Definition assoc' (C : precategory) : ∏ (a b c d : C) (f : a --> b) (g : b --> c) (h : c --> d), (f · g) · h = f · (g · h) := pr222 C. Arguments id_left [C a b] f. Arguments id_right [C a b] f. Arguments assoc [C a b c d] f g h. Arguments assoc' [C a b c d] f g h. Lemma assoc4 (C : precategory) (a b c d e : C) (f : a --> b) (g : b --> c) (h : c --> d) (i : d --> e) : ((f · g) · h) · i = f · (g · h) · i. Proof. repeat rewrite assoc; apply idpath. Qed. Lemma remove_id_left (C : precategory) (a b : C) (f g : a --> b) (h : a --> a): h = identity _ -> f = g -> h · f = g. Proof. intros H eq. intermediate_path (identity _ · f). - destruct H. apply idpath. - intermediate_path f. + apply id_left. + apply eq. Defined. Lemma remove_id_right (C : precategory) (a b : C) (f g : a --> b) (h : b --> b): h = identity _ -> f = g -> f · h = g. Proof. intros H eq. intermediate_path (f · identity _). - destruct H. apply idpath. - intermediate_path f. + apply id_right. + apply eq. Defined. Lemma id_conjugation {A : precategory} {a b : A} (f : a --> b) (g : b --> a) (x : b --> b) : x = identity _ -> f · g = identity _ -> f · x · g = identity _ . Proof. intros H H'. rewrite H. rewrite id_right. apply H'. Qed. Lemma cancel_postcomposition {C : precategory_data} {a b c: C} (f f' : a --> b) (g : b --> c) : f = f' -> f · g = f' · g. Proof. intro; apply maponpaths_2; assumption. Defined. Lemma cancel_precomposition (C : precategory_data) (a b c: C) (f f' : b --> c) (g : a --> b) : f = f' -> g · f = g · f'. Proof. apply maponpaths. Defined. Lemma maponpaths_compose {C : category} {x y z : C} (f1 f2 : C⟦x,y⟧) (g1 g2 : C⟦y,z⟧) : f1 = f2 -> g1 = g2 -> f1 · g1 = f2 · g2. Proof. exact (λ p q, maponpaths_12 compose p q). Qed. (** Any equality on objects a and b induces a morphism from a to b *) Definition idtomor {C : precategory_data} (a b : C) (H : a = b) : a --> b. Proof. induction H. exact (identity a). Defined. Definition idtomor_inv {C : precategory_data} (a b : C) (H : a = b) : b --> a. Proof. induction H. exact (identity a). Defined. Section SectionsAndRetractions. Context {C : precategory}. Definition is_retraction {A B : ob C} (m : A --> B) (r : B --> A) := m · r = identity A. Lemma isaprop_is_retraction {A B : ob C} (m : A --> B) (r : B --> A) : has_homsets C -> isaprop (is_retraction m r). Proof. intro H; apply H. Qed. (** A retraction of B onto A *) Definition retraction (A B : ob C) := ∑ m r, @is_retraction A B m r. Lemma isaset_retraction (A B : ob C) : has_homsets C -> isaset (retraction A B). Proof. intro. do 2 (apply isaset_total2; [auto|intros]). apply hlevelntosn, isaprop_is_retraction. assumption. Qed. End SectionsAndRetractions. UniMath-20231010/UniMath/CategoryTheory/Core/EssentiallyAlgebraic.v000066400000000000000000000041441451125700300247740ustar00rootroot00000000000000(** ** Precategories in style of essentially algebraic cats *) (** Of course we later want SETS of objects, rather than types, but the construction can already be specified. *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Setcategories. Local Open Scope cat. Definition total_morphisms (C : precategory_ob_mor) := total2 ( fun ab : dirprod (ob C)(ob C) => precategory_morphisms (pr1 ab) (pr2 ab)). Lemma isaset_setcategory_total_morphisms (C : setcategory): isaset (total_morphisms C). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. apply isofhleveldirprod. - exact (pr1 (pr2 C)). - exact (pr1 (pr2 C)). - intro ab; apply ((pr2 (pr2 C)) (dirprod_pr1 ab) (dirprod_pr2 ab)). Qed. Definition setcategory_total_morphisms_set (C : setcategory) : hSet := make_hSet _ (isaset_setcategory_total_morphisms C). Definition precategory_source (C : precategory_ob_mor) : total_morphisms C -> ob C := λ abf, pr1 (pr1 abf). Definition precategory_target (C : precategory_ob_mor) : total_morphisms C -> ob C := λ abf, pr2 (pr1 abf). Definition precategory_total_id (C : precategory_data) : ob C -> total_morphisms C := λ c, tpair _ (make_dirprod c c) (identity c). Definition precategory_total_comp'' (C : precategory_data) : ∏ f g : total_morphisms C, precategory_target C f = precategory_source C g -> total_morphisms C. Proof. intros f g e. destruct f as [[a b] f]. simpl in *. destruct g as [[b' c] g]. simpl in *. unfold precategory_target in e; simpl in e. unfold precategory_source in e; simpl in e. simpl. exists (make_dirprod a c). simpl. exact ((f · idtomor _ _ e) · g). Defined. Definition precategory_total_comp (C : precategory_data) : ∏ f g : total_morphisms C, precategory_target C f = precategory_source C g -> total_morphisms C := λ f g e, tpair _ (make_dirprod (pr1 (pr1 f))(pr2 (pr1 g))) ((pr2 f · idtomor _ _ e) · pr2 g). UniMath-20231010/UniMath/CategoryTheory/Core/Functors.v000066400000000000000000001133661451125700300225200ustar00rootroot00000000000000(** * Functors Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) *) (** ** Contents: - preserve isos, inverses - Conservative functors ([conservative]) - Composition of functors, identity functors - fully faithful functors - preserve isos, inverses, composition backwards - (Split) essentially surjective functors - faithful - full - fully faithful is the same as full and faithful - Image of a functor, full subcat specified by a functor *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Functors : Morphisms of precategories *) Section functors. Definition functor_data (C C' : precategory_ob_mor) : UU := total2 ( fun F : ob C -> ob C' => ∏ a b : ob C, a --> b -> F a --> F b). Definition make_functor_data {C C' : precategory_ob_mor} (F : ob C -> ob C') (H : ∏ a b : ob C, a --> b -> F a --> F b) : functor_data C C' := tpair _ F H. Lemma functor_data_isaset (C C' : precategory_ob_mor) (hs : has_homsets C') (hsC' : isaset C') : isaset (functor_data C C'). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. apply impred; intro. apply hsC'. intro. do 3 (apply impred; intro). apply hs. Qed. Definition functor_data_constr (C C' : precategory_ob_mor) (F : ob C -> ob C') (Fm : ∏ a b : ob C, a --> b -> F a --> F b) : functor_data C C' := tpair _ F Fm . Definition functor_on_objects {C C' : precategory_ob_mor} (F : functor_data C C') : ob C -> ob C' := pr1 F. Coercion functor_on_objects : functor_data >-> Funclass. Definition functor_on_morphisms {C C' : precategory_ob_mor} (F : functor_data C C') { a b : ob C} : a --> b -> F a --> F b := pr2 F a b. Notation "# F" := (functor_on_morphisms F) (at level 3) : cat. Definition functor_idax {C C' : precategory_data} (F : functor_data C C') := ∏ a : ob C, #F (identity a) = identity (F a). Definition functor_compax {C C' : precategory_data} (F : functor_data C C') := ∏ a b c : ob C, ∏ f : a --> b, ∏ g : b --> c, #F (f · g) = #F f · #F g . Definition is_functor {C C' : precategory_data} (F : functor_data C C') := ( functor_idax F ) × ( functor_compax F ) . Lemma isaprop_is_functor (C C' : precategory_data) (hs: has_homsets C') (F : functor_data C C') : isaprop (is_functor F). Proof. apply isofhleveldirprod. apply impred; intro. apply hs. do 5 (apply impred; intro). apply hs. Qed. Definition functor (C C' : precategory_data) : UU := total2 ( λ F : functor_data C C', is_functor F ). Notation "a ⟶ b" := (functor a b) : cat. (* to input: type "\-->" with Agda input method *) Definition make_functor {C C' : precategory_data} (F : functor_data C C') (H : is_functor F) : functor C C'. Proof. exists F. exact H. Defined. Lemma functor_data_eq_prf (C C': precategory_ob_mor) (F F' : functor_data C C') (H : ∏ c, F c = F' c) (H1 : ∏ C1 C2 (f : C1 --> C2), double_transport (H C1) (H C2) (pr2 F C1 C2 f) = pr2 F' C1 C2 f) : transportf (λ x : C → C', ∏ a b : C, C ⟦ a, b ⟧ → C' ⟦ x a, x b ⟧) (funextfun F F' (λ c : C, H c)) (pr2 F) = pr2 F'. Proof. use funextsec. intros C1. use funextsec. intros C2. use funextsec. intros f. assert (e : transportf (λ x, ∏ a b : C, a --> b → x a --> x b) (funextfun F F' (λ c : C, H c)) (pr2 F) C1 C2 f = transportf (λ x, x C1 --> x C2) (funextfun F F' (λ c : C, H c)) (pr2 F C1 C2 f)). { now induction (funextfun F F' (λ c, H c)). } rewrite e, transport_mor_funextfun, transport_source_funextfun, transport_target_funextfun. exact (H1 C1 C2 f). Qed. Lemma functor_data_eq (C C': precategory_ob_mor) (F F' : functor_data C C') (H : F ~ F') (H1 : ∏ C1 C2 (f : C1 --> C2), double_transport (H C1) (H C2) (pr2 F C1 C2 f) = pr2 F' C1 C2 f) : F = F'. Proof. use total2_paths_f. - use funextfun. intros c. exact (H c). - now apply functor_data_eq_prf. Defined. Lemma functor_eq (C C' : precategory_data) (hs: has_homsets C') (F F': functor C C'): pr1 F = pr1 F' -> F = F'. Proof. intro H. apply (total2_paths_f H). apply proofirrelevance. apply isaprop_is_functor. apply hs. Defined. Lemma functor_isaset (C C' : precategory_data) (hs : has_homsets C') (hsC' : isaset C') : isaset (functor C C'). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. apply (functor_data_isaset C C' hs hsC'). intros x. apply isasetaprop. apply (isaprop_is_functor C C' hs). Qed. Definition functor_data_from_functor (C C': precategory_data) (F : functor C C') : functor_data C C' := pr1 F. Coercion functor_data_from_functor : functor >-> functor_data. Definition functor_eq_eq_from_functor_ob_eq (C C' : precategory_data) (hs: has_homsets C') (F G : functor C C') (p q : F = G) (H : base_paths _ _ (base_paths _ _ p) = base_paths _ _ (base_paths _ _ q)) : p = q. Proof. apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl. assert (H' : base_paths _ _ p = base_paths _ _ q). { apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl. apply (two_arg_paths_f H), uip. apply impred_isaset; intro a; apply impred_isaset; intro b; apply impred_isaset; intro f. apply hs. } apply (two_arg_paths_f H'), uip, isasetaprop, isaprop_is_functor, hs. Defined. Definition functor_id {C C' : precategory_data}(F : functor C C'): ∏ a : ob C, #F (identity a) = identity (F a) := pr1 (pr2 F). Definition functor_comp {C C' : precategory_data} (F : functor C C') {a b c : C} (f : a --> b) (g : b --> c) : #F (f · g) = #F f · #F g := pr2 (pr2 F) _ _ _ _ _ . Lemma functor_id_id (A B : precategory) (G : functor A B) (a : A) (f : a --> a) : f = identity _ -> #G f = identity _ . Proof. intro e. intermediate_path (#G (identity a )). - apply maponpaths. apply e. - apply functor_id. Defined. Lemma functor_comp_id (A B : precategory) (G : functor A B) (a a' : A) (f : a --> a') (g : a' --> a) : f · g = identity _ -> #G f · #G g = identity _ . Proof. intro e. intermediate_path (#G (identity a )). - rewrite <- e. apply (! functor_comp _ _ _). - apply functor_id_id. apply idpath. Qed. (** ** Functors preserve isomorphisms *) Lemma is_inverse_functor_image (C C' : precategory) (F : functor C C') (a b : C) (f : iso a b): is_inverse_in_precat (#F f) (#F (inv_from_iso f)). Proof. simpl; split; simpl. rewrite <- functor_comp. rewrite iso_inv_after_iso. apply functor_id. rewrite <- functor_comp. rewrite iso_after_iso_inv. apply functor_id. Qed. Lemma functor_on_is_iso_is_iso {C C' : precategory} (F : functor C C') {a b : ob C} {f : a --> b} (H : is_iso f) : is_iso (#F f). Proof. apply (is_iso_qinv _ (#F (inv_from_iso (make_iso _ H)))). apply (is_inverse_functor_image _ _ _ _ _ (make_iso _ H)). Qed. Lemma functor_on_iso_is_iso (C C' : precategory) (F : functor C C') (a b : ob C) (f : iso a b) : is_iso (#F f). Proof. apply (is_iso_qinv _ (#F (inv_from_iso f))). apply is_inverse_functor_image. Defined. Definition functor_on_iso {C C' : precategory} (F : functor C C') {a b : ob C}(f : iso a b) : iso (F a) (F b). Proof. exists (#F f). apply functor_on_iso_is_iso. Defined. Lemma functor_on_iso_inv (C C' : precategory) (F : functor C C') (a b : ob C) (f : iso a b) : functor_on_iso F (iso_inv_from_iso f) = iso_inv_from_iso (functor_on_iso F f). Proof. apply eq_iso; simpl. apply inv_iso_unique'; simpl. unfold precomp_with. rewrite <- functor_comp. rewrite iso_inv_after_iso. apply functor_id. Defined. Lemma functor_on_inv_from_iso' {C C' : precategory} (F : functor C C') {a b : ob C} {f : a --> b} (H : is_iso f) : inv_from_iso (make_iso _ (functor_on_is_iso_is_iso F H)) = # F (inv_from_iso (make_iso _ H)). Proof. apply pathsinv0. use inv_iso_unique'. cbn. unfold precomp_with. rewrite <- functor_comp. set (tmp := iso_inv_after_iso (make_iso _ H)). cbn in tmp. rewrite tmp. apply functor_id. Qed. Section functors_on_iso_with_inv. Lemma functor_on_is_inverse_in_precat {C C' : precategory} (F : functor C C') {a b : ob C} {f : a --> b} {g : b --> a} (H : is_inverse_in_precat f g) : is_inverse_in_precat (# F f) (# F g). Proof. use make_is_inverse_in_precat. - rewrite <- functor_comp. rewrite (is_inverse_in_precat1 H). apply functor_id. - rewrite <- functor_comp. rewrite (is_inverse_in_precat2 H). apply functor_id. Qed. Definition functor_on_is_z_isomorphism {C C' : precategory} (F : functor C C') {a b : ob C} {f : a --> b} (I : is_z_isomorphism f) : is_z_isomorphism (# F f). Proof. use make_is_z_isomorphism. - exact (# F (is_z_isomorphism_mor I)). - exact (functor_on_is_inverse_in_precat F I). Defined. Lemma functor_is_inverse_in_precat_inv_from_iso {C D : precategory} {c c' : ob C} (F : functor C D) (f : iso c c') : is_inverse_in_precat (# F f) (# F (inv_from_iso f)). Proof. apply functor_on_is_inverse_in_precat. split. + apply is_inverse_in_precat1. split. * apply (iso_inv_after_iso f). * apply (iso_after_iso_inv f). + apply is_inverse_in_precat2. split. * apply (iso_inv_after_iso f). * apply (iso_after_iso_inv f). Qed. Lemma functor_is_inverse_in_precat_inv_from_z_iso {C D : precategory} {c c' : ob C} (F : functor C D) (f : z_iso c c') : is_inverse_in_precat (# F f) (# F (inv_from_z_iso f)). Proof. apply functor_on_is_inverse_in_precat. split. - apply z_iso_inv_after_z_iso. - apply z_iso_after_z_iso_inv. Qed. Definition functor_on_z_iso {C C' : precategory} (F : functor C C') {a b : ob C} (f : z_iso a b) : z_iso (F a) (F b). Proof. use make_z_iso. - exact (# F f). - exact (# F (inv_from_z_iso f)). - exact (functor_on_is_inverse_in_precat F f). Defined. Lemma functor_on_z_iso_inv (C C' : category) (F : functor C C') (a b : ob C) (f : z_iso a b) : functor_on_z_iso F (z_iso_inv_from_z_iso f) = z_iso_inv_from_z_iso (functor_on_z_iso F f). Proof. apply z_iso_eq; simpl. apply idpath. Defined. Lemma functor_on_inv_from_z_iso' {C C' : precategory} (F : functor C C') {a b : ob C} {f : a --> b} (H : is_z_isomorphism f) : inv_from_z_iso (make_z_iso _ _ (functor_on_is_z_isomorphism F H)) = # F (inv_from_z_iso (make_z_iso _ _ H)). Proof. apply idpath. Qed. End functors_on_iso_with_inv. (** ** Functors and [idtoiso] *) Section functors_and_idtoiso. Variables C D : category. Variable F : functor C D. Lemma maponpaths_idtoiso (a b : C) (e : a = b) : idtoiso (maponpaths (functor_on_objects F) e) = functor_on_z_iso F (idtoiso e). Proof. induction e. apply z_iso_eq. apply (! functor_id _ _ ). Qed. Hypothesis HC : is_univalent C. Hypothesis HD : is_univalent D. Lemma maponpaths_isotoid (a b : C) (i : z_iso a b) : maponpaths (functor_on_objects F) (isotoid _ HC i) = isotoid _ HD (functor_on_z_iso F i). Proof. apply (invmaponpathsweq (make_weq (idtoiso) (HD _ _ ))). simpl. rewrite maponpaths_idtoiso. repeat rewrite idtoiso_isotoid. apply idpath. Qed. End functors_and_idtoiso. Definition pr1_maponpaths_idtoiso {C D : category} (F : C ⟶ D) {a b : C} (e : a = b) : pr1 (idtoiso (maponpaths F e)) = #F (pr1 (idtoiso e)). Proof. exact (maponpaths pr1 (maponpaths_idtoiso _ _ F _ _ e)). Qed. Notation "# F" := (functor_on_morphisms F)(at level 3) : cat. (* Notations do not survive the end of sections. *) Lemma idtoiso_functor_precompose {C₁ C₂ : category} (F : C₁ ⟶ C₂) {y : C₂} {x₁ x₂ : C₁} (p : x₁ = x₂) (f : F x₁ --> y) : idtoiso (maponpaths (λ z, F z) (!p)) · f = transportf (λ z, F z --> y) p f. Proof. induction p. cbn. apply id_left. Qed. Lemma idtoiso_functor_precompose' {C₁ C₂ : category} (F : C₁ ⟶ C₂) {y : C₂} {x₁ x₂ : C₁} (p : x₁ = x₂) (f : y --> F x₁) : f · idtoiso (maponpaths (λ z, F z) p) = transportf (λ z, y --> F z) p f. Proof. induction p. cbn. apply id_right. Qed. Definition transportf_functor_isotoid {C₁ C₂ : category} (HC₁ : is_univalent C₁) (F : C₁ ⟶ C₂) {y : C₂} {x₁ x₂ : C₁} (i : z_iso x₁ x₂) (f : F x₁ --> y) : transportf (λ z, F z --> y) (isotoid _ HC₁ i) f = #F (inv_from_z_iso i) · f. Proof. rewrite <- idtoiso_functor_precompose. rewrite maponpaths_idtoiso. rewrite idtoiso_inv. rewrite idtoiso_isotoid. apply idpath. Qed. Lemma transportf_functor_isotoid' {C₁ C₂ : category} (HC₁ : is_univalent C₁) (F : C₁ ⟶ C₂) {y : C₂} {x₁ x₂ : C₁} (i : z_iso x₁ x₂) (f : y --> F x₁) : transportf (λ z, y --> F z) (isotoid _ HC₁ i) f = f · #F i. Proof. rewrite <- idtoiso_functor_precompose'. rewrite maponpaths_idtoiso. rewrite idtoiso_isotoid. apply idpath. Qed. (** ** Functors preserve inverses *) Lemma functor_on_inv_from_z_iso {C C' : precategory} (F : functor C C') {a b : ob C}(f : z_iso a b) : #F (inv_from_z_iso f) = inv_from_z_iso (functor_on_z_iso F f) . Proof. destruct f. apply functor_on_inv_from_z_iso'. Qed. (** ** Conservative functors *) (** The generic property of "reflecting" a property of a morphism. *) Definition reflects_morphism {C D : category} (F : functor C D) (P : ∏ (C : category) (a b : ob C), C⟦a, b⟧ → UU) : UU := ∏ a b f, P D (F a) (F b) (# F f) → P C a b f. (** These are functors that reflect isomorphisms. F : C ⟶ D is conservative if whenever # F f is an iso, so is f. *) Definition conservative {C D : category} (F : functor C D) : UU := reflects_morphism F (@is_z_isomorphism). Definition isaprop_conservative {C D : category} (F : functor C D) : isaprop (conservative F). Proof. do 4 (use impred ; intro). apply isaprop_is_z_isomorphism. Qed. (** ** Composition of functors, identity functors *) (** *** Composition *) Definition functor_composite_data {C C' C'' : precategory_ob_mor } (F : functor_data C C') (F' : functor_data C' C'') : functor_data C C'' := functor_data_constr C C'' (λ a, F' (F a)) (λ (a b : ob C) f, #F' (#F f)) . Lemma is_functor_composite {C C' C'' : precategory_data} (F : functor C C') (F' : functor C' C'') : is_functor ( functor_composite_data F F' ) . Proof. split; simpl. intro a. assert ( e1 := functor_id F a ) . assert ( e2 := functor_id F' ( F a ) ) . apply ( ( maponpaths ( # F' ) e1 ) @ e2 ) . unfold functor_compax . intros . assert ( e1 := functor_comp F f g ) . assert ( e2 := functor_comp F' ( # F f ) ( # F g ) ) . apply ( ( maponpaths ( # F' ) e1 ) @ e2 ) . Defined. Definition functor_composite {C C' C'' : precategory_data} (F : functor C C') (F' : functor C' C'') : functor C C'' := tpair _ _ (is_functor_composite F F'). (** *** Identity functor *) Definition functor_identity_data ( C : precategory_data ) : functor_data C C := functor_data_constr C C (λ a, a) (λ (a b : ob C) f, f) . Lemma is_functor_identity (C : precategory_data) : is_functor ( functor_identity_data C ) . Proof. split; simpl. unfold functor_idax. intros; apply idpath. unfold functor_compax. intros; apply idpath. Defined. Definition functor_identity (C : precategory_data) : functor C C := tpair _ _ ( is_functor_identity C ) . (** *** Constant functor *) Section Constant_Functor. Variables C D : precategory. Variable d : D. Definition constant_functor_data: functor_data C D := functor_data_constr C D (λ _, d) (λ _ _ _ , identity _) . Lemma is_functor_constant: is_functor constant_functor_data. Proof. split; simpl. red; intros; apply idpath. red; intros; simpl. apply pathsinv0. apply id_left. Qed. Definition constant_functor: functor C D := tpair _ _ is_functor_constant. End Constant_Functor. Definition iter_functor {C : precategory} (F : functor C C) (n : nat) : functor C C. Proof. induction n as [ | n IHn]. - apply functor_identity. - apply (functor_composite IHn F). Defined. End functors. (** Notations do not survive the end of sections, so we redeclare them here. *) Notation "a ⟶ b" := (functor a b) : cat. Notation "# F" := (functor_on_morphisms F) (at level 3) : cat. (** ** Fully faithful functors *) Definition fully_faithful {C D : precategory_data} (F : functor C D) := ∏ a b : ob C, isweq (functor_on_morphisms F (a:=a) (b:=b)). Lemma isaprop_fully_faithful (C D : precategory_data) (F : functor C D) : isaprop (fully_faithful F). Proof. apply impred; intro a. apply impred; intro b. apply isapropisweq. Qed. Lemma identity_functor_is_fully_faithful { C : precategory_data } : fully_faithful (functor_identity C). Proof. intros a b. apply idisweq. Defined. Definition weq_from_fully_faithful {C D : precategory_data}{F : functor C D} (FF : fully_faithful F) (a b : ob C) : (a --> b) ≃ (F a --> F b). Proof. exists (functor_on_morphisms F (a:=a) (b:=b)). exact (FF a b). Defined. Definition fully_faithful_inv_hom {C D : precategory_data} {F : functor C D} (FF : fully_faithful F) (a b : ob C) : F a --> F b -> a --> b := invweq (weq_from_fully_faithful FF a b). Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ). (** FF^1 is indeed post-inverse to # F. *) Lemma fully_faithful_inv_hom_is_inv {C D : precategory} {F : functor C D} (FF : fully_faithful F) {a b : ob C} (f : C⟦a, b⟧) : FF^-1 (# F f) = f. Proof. cbn. apply invmap_eq. reflexivity. Defined. Definition functor_on_fully_faithful_inv_hom {C₁ C₂ : category} (F : C₁ ⟶ C₂) (HF : fully_faithful F) {x y : C₁} (f : F x --> F y) : #F (fully_faithful_inv_hom HF x y f) = f. Proof. unfold fully_faithful_inv_hom. exact (homotweqinvweq (weq_from_fully_faithful HF x y) f). Qed. Lemma fully_faithful_inv_identity (C D : precategory_data) (F : functor C D) (FF : fully_faithful F) (a : ob C) : FF^-1 (identity (F a)) = identity _. Proof. apply (invmaponpathsweq (weq_from_fully_faithful FF a a)). unfold fully_faithful_inv_hom. set (HFaa:=homotweqinvweq (weq_from_fully_faithful FF a a)(identity _ )). simpl in *. rewrite HFaa. rewrite functor_id; apply idpath. Qed. Lemma fully_faithful_inv_comp (C D : precategory_data) (F : functor C D) (FF : fully_faithful F) (a b c : ob C) (f : F a --> F b) (g : F b --> F c) : FF^-1 (f · g) = FF^-1 f · FF^-1 g. Proof. apply (invmaponpathsweq (weq_from_fully_faithful FF a c)). set (HFFac := homotweqinvweq (weq_from_fully_faithful FF a c) (f · g)). unfold fully_faithful_inv_hom. simpl in *. rewrite HFFac; clear HFFac. rewrite functor_comp. set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b) f). set (HFFbc := homotweqinvweq (weq_from_fully_faithful FF b c) g). simpl in *. rewrite HFFab; clear HFFab. rewrite HFFbc; clear HFFbc. apply idpath. Qed. (** *** Fully faithful functors reflect isos *) Lemma inv_of_ff_inv_is_inv (C D : precategory) (F : functor C D) (FF : fully_faithful F) (a b : C) (f : z_iso (F a) (F b)) : is_inverse_in_precat ((FF ^-1) f) ((FF ^-1) (inv_from_z_iso f)). Proof. unfold fully_faithful_inv_hom; simpl. split. apply (invmaponpathsweq (weq_from_fully_faithful FF a a)). set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)). set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)). simpl in *. rewrite functor_comp. rewrite HFFab; clear HFFab. rewrite HFFba; clear HFFba. rewrite functor_id. apply z_iso_inv_after_z_iso. apply (invmaponpathsweq (weq_from_fully_faithful FF b b)). set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)). set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)). simpl in *. rewrite functor_comp. rewrite HFFab. rewrite HFFba. rewrite functor_id. apply z_iso_after_z_iso_inv. Qed. Lemma fully_faithful_reflects_iso_proof (C D : precategory)(F : functor C D) (FF : fully_faithful F) (a b : ob C) (f : z_iso (F a) (F b)) : is_z_isomorphism (FF^-1 f). Proof. exists (FF^-1 (inv_from_z_iso f)). apply inv_of_ff_inv_is_inv. Defined. (** A slight restatement of the above: fully faithful functors are conservative. *) Lemma fully_faithful_conservative {C D : category} (F : functor C D) (FF : fully_faithful F) : conservative F. Proof. unfold conservative. intros a b f is_iso_Ff. use transportf. - exact (FF^-1 (# F f)). - apply fully_faithful_inv_hom_is_inv. - apply (fully_faithful_reflects_iso_proof _ _ _ _ _ _ (_,,is_iso_Ff)). Defined. Definition iso_from_fully_faithful_reflection {C D : precategory} {F : functor C D} (HF : fully_faithful F) {a b : ob C} (f : z_iso (F a) (F b)) : z_iso a b. Proof. exists (fully_faithful_inv_hom HF a b f). apply fully_faithful_reflects_iso_proof. Defined. Lemma functor_on_iso_iso_from_fully_faithful_reflection (C : precategory)(D : category) (F : functor C D) (HF : fully_faithful F) (a b : ob C) (f : z_iso (F a) (F b)) : functor_on_z_iso F (iso_from_fully_faithful_reflection HF f) = f. Proof. apply z_iso_eq. simpl; apply (homotweqinvweq (weq_from_fully_faithful HF a b)). Qed. Lemma iso_from_fully_faithful_reflection_functor_on_iso (C : category)(D : precategory) (F : functor C D) (HF : fully_faithful F) (a b : ob C) (f : z_iso a b) : iso_from_fully_faithful_reflection HF (functor_on_z_iso F f) = f. Proof. apply z_iso_eq. simpl; apply (homotinvweqweq (weq_from_fully_faithful HF a b)). Qed. Definition weq_ff_functor_on_z_iso {C D : category}{F : functor C D} (HF : fully_faithful F) (a b : ob C) : z_iso a b ≃ z_iso (F a) (F b). Proof. exists (functor_on_z_iso F). apply (isweq_iso _ (iso_from_fully_faithful_reflection HF (a:=a)(b:=b))). - apply iso_from_fully_faithful_reflection_functor_on_iso. - apply functor_on_iso_iso_from_fully_faithful_reflection. Defined. (** Computation check *) Lemma weq_ff_functor_on_iso_compute {C D : category} (F : functor C D) (HF : fully_faithful F) {a b : C} (f : z_iso a b) : #F f = weq_ff_functor_on_z_iso HF _ _ f. Proof. apply idpath. Qed. Lemma functor_on_iso_iso_from_ff_reflection (C : precategory)(D : category) (F : functor C D) (HF : fully_faithful F) (a b : C) (f : z_iso (F a) (F b)): functor_on_z_iso F (iso_from_fully_faithful_reflection HF f) = f. Proof. apply z_iso_eq. simpl. apply (homotweqinvweq (weq_from_fully_faithful HF a b ) ). Qed. (** Alternative implementation of [weq_ff_functor_on_iso] *) Definition reflects_isos {C D : precategory} (F : C ⟶ D) := ∏ c c' (f : C⟦c,c'⟧), is_z_isomorphism (# F f) → is_z_isomorphism f. Lemma isaprop_reflects_isos {C : category} {D : precategory} (F : C ⟶ D) : isaprop (reflects_isos F). Proof. apply impred; intros c; apply impred; intros c'. apply impred; intros f; apply impred; intros f'. apply isaprop_is_z_isomorphism. Qed. Lemma ff_reflects_is_iso (C D : precategory) (F : functor C D) (HF : fully_faithful F) : reflects_isos F. Proof. intros a b f H. set (X:= fully_faithful_reflects_iso_proof _ _ F HF _ _ (_,,H)). simpl in X. set (T:= homotinvweqweq (weq_from_fully_faithful HF a b ) ). simpl in T. unfold fully_faithful_inv_hom in X. simpl in X. rewrite T in X. apply X. Defined. Definition weq_ff_functor_on_weq_isobandf {C D : category} {F : functor C D} (HF : fully_faithful F) (a b : C) : z_iso a b ≃ z_iso (F a) (F b). Proof. use weqbandf. - apply (make_weq _ (HF a b)). - simpl; intro f. apply weqimplimpl. + intro H. exact (pr2(functor_on_z_iso _ (_,,H))). + apply ff_reflects_is_iso. apply HF. + apply isaprop_is_z_isomorphism. + apply isaprop_is_z_isomorphism. Defined. (** Computation check *) Lemma weq_ff_functor_on_weq_isobandf_compute {C D : category} (F : functor C D) (HF : fully_faithful F) {a b : C} (f : z_iso a b) : #F f = weq_ff_functor_on_weq_isobandf HF _ _ f. Proof. apply idpath. Defined. Lemma ff_is_inclusion_on_objects {C D : category} (HC : is_univalent C) (HD : is_univalent D) (F : functor C D) (HF : fully_faithful F) : isofhlevelf 1 (functor_on_objects F). Proof. intro d. apply invproofirrelevance. intros [c e] [c' e']. use total2_paths_f. - simpl. set (X := idtoiso (e @ ! e')). (* set (X' := invmap (@weq_ff_functor_on_iso _ _ _ HF _ _ ) X). *) (* we cannot use X' because we lack the preceding, commented-out, lemma *) set (X2 := iso_from_fully_faithful_reflection HF X). apply (isotoid _ HC X2). - simpl. set (T:=@functtransportf _ _ (functor_on_objects F)). set (T' := T (λ c, c = d)). simpl in T'. rewrite T'. rewrite (maponpaths_isotoid _ _ _ HC HD). rewrite functor_on_iso_iso_from_ff_reflection. rewrite isotoid_idtoiso. rewrite transportf_id2. rewrite pathscomp_inv. rewrite pathsinv0inv0. rewrite <- path_assoc. rewrite pathsinv0l. apply pathscomp0rid. Qed. (** ** (Split) essentially surjective functors *) (** See [CategoryTheory.equivalences] for more lemmas about (split) essential surjectivity, especially where the domain is a [univalent_category]. *) (** See "Univalent categories and the Rezk completion" (arXiv:1303.0584v2) Definition 6.5. *) Definition split_essentially_surjective {C D : precategory_data} (F : functor C D) := ∏ b, (∑ a : ob C, z_iso (F a) b). (** Split essentially surjective functors have "inverses" on objects, where we map d : ob D to the c : ob C such that F c ≅ d. *) Definition split_essentially_surjective_inv_on_obj {C D : precategory_data} (F : functor C D) (HF : split_essentially_surjective F) : ob D → ob C := λ d, (pr1 (HF d)). Definition essentially_surjective {C D : precategory_data} (F : functor C D) := ∏ b, ishinh (total2 (λ a, z_iso (F a) b)). Lemma isaprop_essentially_surjective {C D : precategory_data} (F : functor C D) : isaprop (essentially_surjective F). Proof. apply impred; intro; apply isapropishinh. Defined. Lemma identity_functor_is_essentially_surjective (C : category) : essentially_surjective (functor_identity C). Proof. intro x. apply hinhpr. exists x. apply identity_z_iso. Qed. (** Composition of essentially surjective functors yields an essentially surjective functor. *) (** Let e : E. Since G is essentially surjective, there is some g such that e ≅ G g. Since F is essentially surjective, there is some f such that G g ≅ F f. Composing these isomorphisms proves the goal. *) Lemma comp_essentially_surjective {C D E : precategory} (F : functor C D) (esF : essentially_surjective F) (G : functor D E) (esG : essentially_surjective G) : essentially_surjective (functor_composite F G). Proof. unfold essentially_surjective. intros e. apply (squash_to_prop (esG e)); [apply isapropishinh|]; intros isoGe. apply (squash_to_prop (esF (pr1 isoGe))); [apply isapropishinh|]; intros isoFGe. apply hinhpr. exists (pr1 isoFGe); unfold functor_composite; cbn. apply (@z_iso_comp E _ (G (pr1 isoGe))). - apply functor_on_z_iso. exact (pr2 isoFGe). - apply (pr2 isoGe). Defined. (** ** Faithful functors *) Definition faithful {C D : precategory_data} (F : functor C D) := ∏ a b : ob C, isincl (fun f : a --> b => #F f). Lemma isaprop_faithful (C D : precategory_data) (F : functor C D) : isaprop (faithful F). Proof. unfold faithful. do 2 (apply impred; intro). apply isapropisincl. Qed. (** Composition of faithful functors yields a faithful functor. *) Lemma comp_faithful_is_faithful (C D E : precategory) (F : functor C D) (faithF : faithful F) (G : functor D E) (faithG : faithful G) : faithful (functor_composite F G). Proof. unfold faithful in *. intros ? ?; apply (isinclcomp (_,, faithF _ _) (_,, faithG _ _)). Qed. (** Faithful functors reflect commutative triangles. If F f · F g = F h, in D, then f · g = h in C. (Really, this is true more generally for any diagram.) *) Lemma faithful_reflects_commutative_triangle {C D : precategory} (F : functor C D) (FF : faithful F) {a b c : ob C} (f : C ⟦a, b⟧) (g : C ⟦b, c⟧) (h : C ⟦a, c⟧) : # F f · # F g = # F h → f · g = h. Proof. intros feq. apply (Injectivity (# F)). - apply isweqonpathsincl, FF. - exact (functor_comp F f g @ feq). Defined. (** a simpler instance of that principle *) Lemma faithful_reflects_morphism_equality {C D : precategory} (F : functor C D) (FF : faithful F) {a b : ob C} (f g : C ⟦a, b⟧) : # F f = # F g → f = g. Proof. intros feq. apply (Injectivity (# F)). - apply isweqonpathsincl, FF. - exact feq. Defined. (** ** Full functors *) Definition full {C D : precategory_data} (F : functor C D) := ∏ a b: C, issurjective (fun f : a --> b => #F f). Lemma isaprop_full (C D : precategory_data) (F : functor C D) : isaprop (full F). Proof. unfold full. do 2 (apply impred; intro). apply isapropissurjective. Qed. (** Composition of full functors yields a full functor *) Lemma comp_full_is_full (C D E : precategory) (F : functor C D) (fullF : full F) (G : functor D E) (fullG : full G) : full (functor_composite F G). Proof. unfold full in *. intros ? ?; apply (issurjcomp _ _ (fullF _ _) (fullG _ _)). Qed. (** ** Fully faithful is the same as full and faithful *) Definition full_and_faithful {C D : precategory_data} (F : functor C D) := (full F) × (faithful F). Lemma fully_faithful_implies_full_and_faithful (C D : precategory_data) (F : functor C D) : fully_faithful F -> full_and_faithful F. Proof. intro H. split; simpl. unfold full. intros a b. apply issurjectiveweq. apply H. intros a b. apply isinclweq. apply H. Qed. Lemma full_and_faithful_implies_fully_faithful (C D : precategory_data) (F : functor C D) : full_and_faithful F -> fully_faithful F. Proof. intros [Hfull Hfaith]. intros a b. simpl in *. apply isweqinclandsurj. - apply Hfaith. - apply Hfull. Defined. Lemma isaprop_full_and_faithful (C D : precategory_data) (F : functor C D) : isaprop (full_and_faithful F). Proof. apply isapropdirprod. - apply isaprop_full. - apply isaprop_faithful. Qed. Definition weq_fully_faithful_full_and_faithful (C D : precategory_data) (F : functor C D) : (fully_faithful F) ≃ (full_and_faithful F) := weqimplimpl (fully_faithful_implies_full_and_faithful _ _ F) (full_and_faithful_implies_fully_faithful _ _ F) (isaprop_fully_faithful _ _ F) (isaprop_full_and_faithful _ _ F). (** Composition of fully faithful functors yields a fully faithful functor. *) Lemma comp_full_and_faithful_is_full_and_faithful (C D E : precategory) (F : functor C D) (f_and_f_F : full_and_faithful F) (G : functor D E) (f_and_f_G : full_and_faithful G) : full_and_faithful (functor_composite F G). Proof. split. - apply comp_full_is_full; [apply (pr1 f_and_f_F)|apply (pr1 f_and_f_G)]. - apply comp_faithful_is_faithful; [apply (pr2 f_and_f_F)|apply (pr2 f_and_f_G)]. Qed. Lemma comp_ff_is_ff (C D E : precategory) (F : functor C D) (ffF : fully_faithful F) (G : functor D E) (ffG : fully_faithful G) : fully_faithful (functor_composite F G). Proof. unfold fully_faithful in *. intros ? ?; apply (pr2 (weqcomp (_,, ffF _ _) (_,, ffG _ _))). Qed. (** Fully faithful functors induce equivalences on commutative triangles Compare to [faithful_reflects_commutative_triangle]. *) Lemma fully_faithful_commutative_triangle_weq {C D : precategory} (F : functor C D) (fff : fully_faithful F) {X Y Z : ob C} (f : X --> Y) (g : Y --> Z) (h : X --> Z) : (f · g = h) ≃ (#F f · #F g = #F h). Proof. apply (@weqcomp _ (# F (f · g) = # F h)). - eapply make_weq. apply (isweqmaponpaths (weq_from_fully_faithful fff _ _) (f · g) h). - use weq_iso; intros p. + refine (_ @ p). apply (!functor_comp _ _ _). + refine (_ @ p). apply (functor_comp _ _ _). + refine (path_assoc _ _ _ @ _). refine (maponpaths (λ pp, pp @ _) (pathsinv0r _) @ _). reflexivity. + cbn. refine (path_assoc _ _ _ @ _). refine (maponpaths (λ pp, pp @ _) (pathsinv0l _) @ _). reflexivity. Qed. (** ** Image on objects of a functor *) (** is used later to define the full image subcategory of a category [D] defined by a functor [F : C -> D] *) Definition is_in_img_functor {C D : precategory_data} (F : functor C D) (d : ob D) := ishinh ( total2 (λ c : ob C, z_iso (F c) d)). Definition sub_img_functor {C D : precategory_data}(F : functor C D) : hsubtype (ob D) := λ d : ob D, is_in_img_functor F d. Section functor_equalities. Lemma functor_identity_left (C D : precategory) (F : functor C D) : functor_composite (functor_identity C) F = F. Proof. destruct F as [ [ Fob Fmor ] is ]. destruct is as [ idax compax ] . apply idpath . Defined. Lemma functor_identity_right (C D : precategory) (F : functor C D) : functor_composite F (functor_identity D) = F. Proof. destruct F as [ [ Fob Fmor ] is ] . apply ( maponpaths ( λ p, tpair is_functor (tpair _ Fob Fmor) p ) ) . destruct is as [ idax compax ] . apply pathsdirprod . simpl . apply funextsec . intro t . unfold functor_identity . unfold functor_id . simpl . rewrite maponpathsidfun . rewrite pathscomp0rid . apply idpath . apply funextsec . intro t . apply funextsec . intro t0 . apply funextsec . intro t1 . apply funextsec . intro f . apply funextsec . intro g . unfold functor_identity . simpl . unfold functor_comp . simpl . rewrite maponpathsidfun . rewrite pathscomp0rid . apply idpath. Defined. Lemma functor_assoc (C0 C1 C2 C3 : precategory) (F0 : functor C0 C1) (F1 : functor C1 C2) (F2 : functor C2 C3) : functor_composite (functor_composite F0 F1) F2 = functor_composite F0 (functor_composite F1 F2). Proof. destruct F0 as [ [ F0ob F0mor ] is0 ] . destruct F1 as [ [ F1ob F1mor ] is1 ] . destruct F2 as [ [ F2ob F2mor ] is2 ] . simpl . unfold functor_composite . simpl . apply ( maponpaths ( λ p, tpair is_functor _ p ) ) . simpl . apply pathsdirprod . apply funextsec . intro t . simpl . unfold functor_comp . simpl . unfold functor_id . simpl . unfold functor_id . simpl . destruct is0 as [ is0id is0comp ] . destruct is1 as [ is1id is1comp ] . destruct is2 as [ is2id is2comp ] . simpl . rewrite path_assoc. apply ( maponpaths ( λ e, pathscomp0 e ( is2id (F1ob (F0ob t)) ) ) ) . rewrite maponpathscomp0 . apply ( maponpaths ( λ e, pathscomp0 e ( maponpaths (F2mor (F1ob (F0ob t)) (F1ob (F0ob t))) (is1id (F0ob t)) ) ) ) . apply maponpathscomp . apply funextsec . intro t . apply funextsec . intro t0 . apply funextsec . intro t1 . apply funextsec . intro f . apply funextsec . intro g . simpl . unfold functor_comp . simpl . unfold functor_comp . simpl . destruct is0 as [ is0id is0comp ] . destruct is1 as [ is1id is1comp ] . destruct is2 as [ is2id is2comp ] . simpl . rewrite path_assoc. apply ( maponpaths ( λ e, pathscomp0 e ( is2comp (F1ob (F0ob t)) (F1ob (F0ob t0)) (F1ob (F0ob t1)) (F1mor (F0ob t) (F0ob t0) (F0mor t t0 f)) (F1mor (F0ob t0) (F0ob t1) (F0mor t0 t1 g)) ) ) ) . rewrite maponpathscomp0 . apply ( maponpaths ( λ e, pathscomp0 e ( maponpaths (F2mor (F1ob (F0ob t)) (F1ob (F0ob t1))) (is1comp (F0ob t) (F0ob t0) (F0ob t1) (F0mor t t0 f) (F0mor t0 t1 g)) ))). apply maponpathscomp . Defined. End functor_equalities. (** Pseudomonic functors *) Definition full_on_iso {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁), issurjective (λ (f : z_iso x y), functor_on_z_iso F f). Definition pseudomonic {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := faithful F × full_on_iso F. Definition isweq_functor_on_iso_pseudomonic {C₁ C₂ : category} {F : C₁ ⟶ C₂} (HF : pseudomonic F) (x y : C₁) : isweq (@functor_on_z_iso _ _ F x y). Proof. intro g. use (factor_through_squash _ _ (pr2 HF x y g)). { apply isapropiscontr. } intro inv. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isaset_z_iso ; apply homset_property | ] ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; use (maponpaths pr1 (proofirrelevance _ (pr1 HF x y g) (_ ,, _) (_ ,, _))) ; [ exact (maponpaths pr1 (pr2 φ₁)) | exact (maponpaths pr1 (pr2 φ₂)) ]). - exact inv. Defined. Definition isaprop_pseudomonic {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (pseudomonic F). Proof. use isapropdirprod. - apply isaprop_faithful. - do 2 (use impred ; intro). apply isapropissurjective. Qed. Notation "F ∙ G" := (functor_composite F G) : cat. (* to input: type "\." with Agda input method *) (* the old notation had the arguments in the opposite order *) (* Notation "G □ F" := (functor_composite F G) (at level 35, only parsing) : cat. *) (* to input: type "\Box" or "\square" or "\sqw" or "\sq" with Agda input method *) UniMath-20231010/UniMath/CategoryTheory/Core/Isos.v000066400000000000000000000763071451125700300216350ustar00rootroot00000000000000(** * Isomorphisms *) (** ** Contents - isomorphisms: [iso], [isiso f := isweq (precomp_with f)] - Equivalence relation identifying isomorphic objects - Isomorphisms in a category [z_iso] - Definition: [is_z_iso f := ∑ g, ...] - Relationship between [z_iso] and [iso] - Properties of 0-isomorphisms - uniqueness of inverse, composition etc. - stability under composition - Analogue to [isweq_iso]: [is_iso_qinv] *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. (** A morphism [f: a --> b] in a precategory is an isomorphism [is_iso(f)], if for any [c: C], precomposition with [f] yields an equivalence (b --> c -> a --> c]. Definition suggested by V. Voevodsky *) Definition precomp_with {C : precategory_data} {a b : C} (f : a --> b) {c : C} (g : b --> c): a --> c := f · g. Definition is_iso {C : precategory_data} {a b : C} (f : a --> b) := ∏ c, isweq (precomp_with f (c:=c)). Lemma isaprop_is_iso {C : precategory_data} (a b : C) (f : a --> b) : isaprop (is_iso f). Proof. apply impred; intro. apply isapropisweq. Qed. Definition iso {C: precategory_data} (a b : C) := ∑ f : a --> b, is_iso f. Definition morphism_from_iso {C : precategory_data} {a b : C} (f : iso a b) : a --> b := pr1 f. Coercion morphism_from_iso : iso >-> precategory_morphisms. Definition iso_is_iso {C : precategory_data} {a b : C} (f : iso a b) : is_iso f := pr2 f. Definition make_iso {C : precategory_data} {a b : C} (f : a --> b) (fiso: is_iso f) : iso a b := (f,,fiso). Definition inv_from_iso {C : precategory_data} {a b : C} (f : iso a b) : b --> a := invmap (make_weq (precomp_with f) (pr2 f a)) (identity _ ). Definition iso_inv_after_iso {C : precategory_data} {a b : C} (f: iso a b) : f · inv_from_iso f = identity _ . Proof. set (T := homotweqinvweq (make_weq (precomp_with f) (pr2 f a ))). simpl in *. apply T. Defined. Definition iso_after_iso_inv {C : precategory} {a b : C} (f : iso a b) : inv_from_iso f · f = identity _ . Proof. set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f b))). apply T; clear T; simpl. unfold precomp_with. intermediate_path ((f · inv_from_iso f) · f). - apply assoc. - apply remove_id_left. + apply iso_inv_after_iso. + apply (!(id_right _ )). Defined. Definition is_iso_inv_from_iso {C : precategory} {a b : C} (f : iso a b) : is_iso (inv_from_iso f). Proof. intro c. apply (isweq_iso _ (precomp_with f)). - intro g. unfold precomp_with. intermediate_path ((f · inv_from_iso f) · g). + apply assoc. + apply remove_id_left. apply iso_inv_after_iso. apply idpath. - intro g. unfold precomp_with. intermediate_path ((inv_from_iso f · f) · g). + apply assoc. + apply remove_id_left. apply iso_after_iso_inv. apply idpath. Defined. Definition iso_inv_from_iso {C : precategory} {a b : C} (f : iso a b) : iso b a := tpair _ _ (is_iso_inv_from_iso f). Lemma eq_iso {C: precategory_data} {a b : C} (f g : iso a b) : pr1 f = pr1 g -> f = g. Proof. intro H. apply subtypePath. - intros t. apply isaprop_is_iso. - apply H. Defined. Lemma isaset_iso {C : precategory_data} (hs : has_homsets C) (a b : ob C) : isaset (iso a b). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. - apply hs. - intro f. apply isasetaprop. apply isaprop_is_iso. Qed. Lemma identity_is_iso (C : precategory) (a : ob C) : is_iso (identity a). Proof. intros c. set (T := @isweqhomot (a --> c) (a --> c) (λ t, t) (precomp_with (identity a))). apply T. - intro g. apply pathsinv0. apply id_left. - apply idisweq. Defined. Definition identity_iso {C : precategory} (a : ob C) : iso a a := tpair _ _ (identity_is_iso C a). Definition iso_inv_from_is_iso {C : precategory} {a b : ob C} (f : a --> b) (H : is_iso f) : iso b a := iso_inv_from_iso (f,,H). Lemma iso_inv_on_right {C : precategory} (a b c : ob C) (f : iso a b) (g : b --> c) (h : a --> c) (H : h = f · g) : inv_from_iso f · h = g. Proof. apply (invmaponpathsweq (make_weq (precomp_with f) (pr2 f c))). unfold precomp_with; simpl. intermediate_path ((f · inv_from_iso f) · h). - apply assoc. - apply remove_id_left. + apply iso_inv_after_iso. + assumption. Defined. Lemma iso_inv_on_left {C : precategory} (a b c : ob C) (f : a --> b) (g : iso b c) (h : a --> c) (H : h = f · g) : f = h · inv_from_iso g. Proof. assert (H2 : h · inv_from_iso g = (f · g) · inv_from_iso g). rewrite H. apply idpath. rewrite <- assoc in H2. rewrite iso_inv_after_iso in H2. rewrite id_right in H2. apply pathsinv0. assumption. Qed. Lemma iso_inv_to_left {C : precategory} (a b c : ob C) (f : iso a b) (g : b --> c) (h : a --> c) : inv_from_iso f · h = g -> h = f · g. Proof. intro H. intermediate_path (f · inv_from_iso f · h). - rewrite iso_inv_after_iso, id_left; apply idpath. - rewrite <- assoc. rewrite H. apply idpath. Qed. Lemma iso_inv_to_right {C : precategory} (a b c : ob C) (f : a --> b) (g : iso b c) (h : a --> c) : f = h · inv_from_iso g -> f · g = h. Proof. intro H. intermediate_path (h · inv_from_iso g · g). - rewrite H. apply idpath. - rewrite <- assoc, iso_after_iso_inv, id_right. apply idpath. Qed. (** ** Properties of isomorphisms *) (** Stability under composition, inverses etc *) Definition isweqhomot' {X Y} (f g : X -> Y) (H : isweq f) (homot : ∏ x, f x = g x) : isweq g. Proof. apply (isweqhomot f g homot H). Defined. Lemma is_iso_comp_of_isos {C : precategory} {a b c : ob C} (f : iso a b) (g : iso b c) : is_iso (f · g). Proof. simpl. intro d. set (T := twooutof3c (precomp_with g) (precomp_with f (c:=d)) (pr2 g d) (pr2 f _)). apply (isweqhomot' _ _ T). intro h. apply assoc. Defined. Lemma is_iso_comp_of_is_isos {C : precategory} {a b c : ob C} (f : a --> b) (g : b --> c) (H1 : is_iso f) (H2 : is_iso g) : is_iso (f · g). Proof. set (i1 := make_iso f H1). set (i2 := make_iso g H2). exact (is_iso_comp_of_isos i1 i2). Qed. Definition iso_comp {C : precategory} {a b c : ob C} (f : iso a b) (g : iso b c) : iso a c. Proof. exists (f · g). apply is_iso_comp_of_isos. Defined. Lemma inv_iso_unique (C : precategory) (a b : C) (f : iso a b) (g : iso b a) : precomp_with f g = identity _ -> g = iso_inv_from_iso f. Proof. intro H. apply eq_iso. simpl. set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f a ))). apply T; simpl. intermediate_path (identity a). + assumption. + apply pathsinv0. apply iso_inv_after_iso. Defined. Lemma inv_iso_unique' (C : precategory) (a b : C) (f : iso a b) (g : b --> a) : precomp_with f g = identity _ -> g = inv_from_iso f. Proof. intro H. set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f a ))). apply T; simpl. intermediate_path (identity a). + assumption. + apply pathsinv0. apply iso_inv_after_iso. Defined. Lemma iso_inv_of_iso_comp (C : precategory) (a b c : ob C) (f : iso a b) (g : iso b c) : iso_inv_from_iso (iso_comp f g) = iso_comp (iso_inv_from_iso g) (iso_inv_from_iso f). Proof. apply pathsinv0. apply inv_iso_unique. simpl. unfold precomp_with. intermediate_path (f · (g · inv_from_iso g) · inv_from_iso f). - repeat rewrite assoc. apply idpath. - rewrite iso_inv_after_iso. rewrite id_right. apply iso_inv_after_iso. Qed. Lemma iso_inv_of_iso_id {C : precategory} (a : ob C) : iso_inv_from_iso (identity_iso a) = identity_iso a. Proof. apply eq_iso. apply idpath. Qed. Lemma iso_inv_iso_inv {C : precategory} (a b : ob C) (f : iso a b) : iso_inv_from_iso (iso_inv_from_iso f) = f. Proof. apply eq_iso. simpl. apply pathsinv0. apply inv_iso_unique'. apply iso_after_iso_inv. Defined. Lemma pre_comp_with_iso_is_inj {C : precategory_data} (a b c : ob C) (f : a --> b) (H : is_iso f) (g h : b --> c) : f · g = f · h -> g = h. Proof. intro X. apply (invmaponpathsweq (make_weq (precomp_with f) (H _ ))). apply X. Qed. Lemma cancel_precomposition_iso {C : precategory_data} {a b c : C} (f : iso a b) (g h : b --> c) : f · g = f · h -> g = h. Proof. apply (pre_comp_with_iso_is_inj _ _ _ (pr1 f) (pr2 f)). Qed. Lemma post_comp_with_iso_is_inj {C : precategory} (b c : ob C) (h : b --> c) (H : is_iso h) (a : ob C) (f g : a --> b) : f · h = g · h -> f = g. Proof. intro HH. set (T := iso_inv_after_iso (h,,H)). simpl in T. intermediate_path (f · (h · inv_from_iso (h,,H))). - rewrite T. clear T. apply pathsinv0, id_right. - rewrite assoc. rewrite HH. rewrite <- assoc. rewrite T. apply id_right. Qed. Lemma cancel_postcomposition_iso {C : precategory} {a b c : C} (h : iso b c) (f g : a --> b) : f · h = g · h -> f = g. Proof. apply (post_comp_with_iso_is_inj _ _ (pr1 h) (pr2 h)). Qed. Lemma iso_comp_right_isweq {C : precategory_data} {a b : ob C} (h : iso a b) (c : C) : isweq (fun f : b --> c => h · f). Proof. apply (pr2 h _ ). Defined. Definition iso_comp_right_weq {C : precategory_data} {a b : C} (h : iso a b) (c : C) : (b --> c) ≃ (a --> c) := make_weq _ (iso_comp_right_isweq h c). Lemma iso_comp_left_isweq {C : precategory} {a b : ob C} (h : iso a b) (c : C) : isweq (fun f : c --> a => f · h). Proof. intros. apply (isweq_iso _ (λ g, g · inv_from_iso h)). - intro x. rewrite <- assoc. apply remove_id_right. apply iso_inv_after_iso. apply idpath. - intro y. rewrite <- assoc. apply remove_id_right. apply iso_after_iso_inv. apply idpath. Defined. Definition postcomp_with {C : precategory_data} {b c : C} (h : b --> c) {a : C} (f : a --> b) : a --> c := f · h. Definition is_iso' {C : precategory} {b c : C} (f : b --> c) := ∏ a, isweq (postcomp_with f (a:=a)). Definition is_inverse_in_precat {C : precategory_data} {a b : C} (f : a --> b) (g : b --> a) := (f · g = identity a) × (g · f = identity b). Definition make_is_inverse_in_precat {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a} (H1 : f · g = identity a) (H2 : g · f = identity b) : is_inverse_in_precat f g := (H1,,H2). Definition is_inverse_in_precat1 {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a} (H : is_inverse_in_precat f g) : f · g = identity a := dirprod_pr1 H. Definition is_inverse_in_precat2 {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a} (H : is_inverse_in_precat f g) : g · f = identity b := dirprod_pr2 H. Definition is_inverse_in_precat_inv {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a} (H : is_inverse_in_precat f g) : is_inverse_in_precat g f := make_dirprod (is_inverse_in_precat2 H) (is_inverse_in_precat1 H). Definition is_inverse_in_precat_comp {C : precategory} {a b c : C} {f1 : a --> b} {f2 : b --> c} {g1 : b --> a} {g2 : c --> b} (H1 : is_inverse_in_precat f1 g1) (H2 : is_inverse_in_precat f2 g2) : is_inverse_in_precat (f1 · f2) (g2 · g1). Proof. use make_is_inverse_in_precat. - rewrite assoc. rewrite <- (assoc _ f2). rewrite (is_inverse_in_precat1 H2). rewrite id_right. rewrite (is_inverse_in_precat1 H1). apply idpath. - rewrite assoc. rewrite <- (assoc _ g1). rewrite (is_inverse_in_precat2 H1). rewrite id_right. rewrite (is_inverse_in_precat2 H2). apply idpath. Qed. Definition is_inverse_in_precat_identity {C : precategory} (c : C) : is_inverse_in_precat (identity c) (identity c). Proof. use make_is_inverse_in_precat. - apply id_left. - apply id_left. Qed. Definition is_iso_qinv {C:precategory} {a b : C} (f : a --> b) (g : b --> a) : is_inverse_in_precat f g -> is_iso f. Proof. intros H c. apply (isweq_iso _ (precomp_with g)). - intro h. unfold precomp_with. rewrite assoc. apply remove_id_left. apply (pr2 H). apply idpath. - intro h. unfold precomp_with. rewrite assoc. apply remove_id_left. apply (pr1 H). apply idpath. Defined. Definition iso_comp_left_weq {C : precategory} {a b : C} (h : iso a b) (c : C) : (c --> a) ≃ (c --> b) := make_weq _ (iso_comp_left_isweq h c). Definition iso_conjug_weq {C : precategory} {a b : C} (h : iso a b) : (a --> a) ≃ (b --> b) := weqcomp (iso_comp_left_weq h _ ) (iso_comp_right_weq (iso_inv_from_iso h) _ ). (** ** Equivalence relation identifying isomorphic objects *) Section are_isomorphic. Context {C : precategory}. (** a and b are related if there merely exists an iso between them *) Definition are_isomorphic : hrel C := λ a b, ∥iso a b∥. Lemma iseqrel_are_isomorphic : iseqrel are_isomorphic. Proof. repeat split. - intros x y z h1. apply hinhuniv; intros h2; generalize h1; clear h1. now apply hinhuniv; intros h1; apply hinhpr, (iso_comp h1 h2). - now intros x; apply hinhpr, identity_iso. - now intros x y; apply hinhuniv; intro h1; apply hinhpr, iso_inv_from_iso. Qed. Definition iso_eqrel : eqrel C := (are_isomorphic,,iseqrel_are_isomorphic). End are_isomorphic. (** ** Isomorphisms in a category [z_iso] *) (** In a precategory with hom-sets, we can give the usual definition of isomorphism, called [z_iso] in the following. *) Lemma isaprop_is_inverse_in_precat {C : category} (a b : ob C) (f : a --> b) (g : b --> a) : isaprop (is_inverse_in_precat f g). Proof. apply isapropdirprod; apply homset_property. Qed. Lemma inverse_unique_precat {C : precategory} (a b : ob C) (f : a --> b) (g g': b --> a) (H : is_inverse_in_precat f g) (H' : is_inverse_in_precat f g') : g = g'. Proof. destruct H as [eta eps]. destruct H' as [eta' eps']. assert (H : g = identity b · g). rewrite id_left; apply idpath. apply (pathscomp0 H). rewrite <- eps'. rewrite <- assoc. rewrite eta. apply id_right. Qed. Definition is_z_isomorphism {C : precategory_data} {a b : ob C} (f : a --> b) := ∑ g, is_inverse_in_precat f g. Definition make_is_z_isomorphism {C : precategory_data} {a b : C} (f : a --> b) (g : b --> a) (H : is_inverse_in_precat f g) : is_z_isomorphism f := (g,,H). Definition is_z_isomorphism_mor {C : precategory_data} {a b : C} {f : a --> b} (I : is_z_isomorphism f) : b --> a := pr1 I. Definition is_z_isomorphism_is_inverse_in_precat {C : precategory_data} {a b : C} {f : a --> b} (I : is_z_isomorphism f) : is_inverse_in_precat f (is_z_isomorphism_mor I) := pr2 I. Coercion is_z_isomorphism_is_inverse_in_precat : is_z_isomorphism >-> is_inverse_in_precat. Definition is_z_isomorphism_inv {C : precategory_data} {a b : C} {f : a --> b} (I : is_z_isomorphism f) : is_z_isomorphism (is_z_isomorphism_mor I). Proof. use make_is_z_isomorphism. - exact f. - exact (is_inverse_in_precat_inv I). Defined. Definition is_z_isomorphism_comp {C : precategory} {a b c : C} {f1 : a --> b} {f2 : b --> c} (H1 : is_z_isomorphism f1) (H2 : is_z_isomorphism f2) : is_z_isomorphism (f1 · f2). Proof. use make_is_z_isomorphism. - exact (is_z_isomorphism_mor H2 · is_z_isomorphism_mor H1). - exact (is_inverse_in_precat_comp H1 H2). Defined. Definition is_z_isomorphism_identity {C : precategory} (c : C) : is_z_isomorphism (identity c). Proof. use make_is_z_isomorphism. - exact (identity c). - exact (is_inverse_in_precat_identity c). Defined. Lemma isaprop_is_z_isomorphism {C : category} {a b : ob C} (f : a --> b) : isaprop (is_z_isomorphism f). Proof. apply invproofirrelevance. intros g g'. set (Hpr1 := inverse_unique_precat _ _ _ _ _ (pr2 g) (pr2 g')). apply (total2_paths_f Hpr1). destruct g as [g [eta eps]]. destruct g' as [g' [eta' eps']]. simpl in *. apply isapropdirprod; apply homset_property. Qed. Lemma is_z_isomorphism_mor_eq {C : precategory} {a b : C} {f g : a --> b} (e : f = g) (I1 : is_z_isomorphism f) (I2 : is_z_isomorphism g) : is_z_isomorphism_mor I1 = is_z_isomorphism_mor I2. Proof. use inverse_unique_precat. - exact f. - exact I1. - rewrite e. exact I2. Qed. Definition z_iso {C : precategory_data} (a b : ob C) := ∑ f : a --> b, is_z_isomorphism f. Definition make_z_iso {C : precategory_data} {a b : C} (f : a --> b) (g : b --> a) (H : is_inverse_in_precat f g) : z_iso a b := (f,,make_is_z_isomorphism f g H). Definition make_z_iso' {C : precategory_data} {a b : C} (f : a --> b) (H : is_z_isomorphism f) : z_iso a b := (f,,H). Definition z_iso_mor {C : precategory_data} {a b : ob C} (f : z_iso a b) : a --> b := pr1 f. Coercion z_iso_mor : z_iso >-> precategory_morphisms. Definition inv_from_z_iso {C : precategory_data} {a b : C} (i : z_iso a b) : b --> a := is_z_isomorphism_mor (pr2 i). Definition z_iso_is_inverse_in_precat {C : precategory_data} {a b : C} (i : z_iso a b) : is_inverse_in_precat i (inv_from_z_iso i) := pr2 i. Coercion z_iso_is_inverse_in_precat : z_iso >-> is_inverse_in_precat. Definition z_iso_inv {C : precategory_data} {a b : C} (I : z_iso a b) : z_iso b a. Proof. use make_z_iso. - exact (inv_from_z_iso I). - exact I. - exact (is_inverse_in_precat_inv I). Defined. Definition z_iso_comp {C : precategory} {a b c : C} (I1 : z_iso a b) (I2 : z_iso b c) : z_iso a c. Proof. use make_z_iso. - exact (I1 · I2). - exact ((inv_from_z_iso I2) · (inv_from_z_iso I1)). - exact (is_inverse_in_precat_comp I1 I2). Defined. Lemma is_z_iso_comp_of_is_z_isos {C : precategory} {a b c : ob C} (f : a --> b) (g : b --> c) (H1 : is_z_isomorphism f) (H2 : is_z_isomorphism g) : is_z_isomorphism (f · g). Proof. set (i1 := make_z_iso f _ H1). set (i2 := make_z_iso g _ H2). exact (pr2 (z_iso_comp i1 i2)). Defined. (* see below [identity_z_iso] Definition z_iso_identity {C : precategory} (c : C) : z_iso c c. Proof. use make_z_iso. - exact (identity c). - exact (identity c). - exact (is_inverse_in_precat_identity c). Defined. *) Definition z_iso_is_z_isomorphism {C : precategory_data} {a b : C} (I : z_iso a b) : is_z_isomorphism I. Proof. use make_is_z_isomorphism. - exact (inv_from_z_iso I). - exact I. Defined. Definition is_z_iso_inv_from_z_iso {C : precategory_data} {a b : C} (I : z_iso a b) : is_z_isomorphism (inv_from_z_iso I). Proof. use make_is_z_isomorphism. - exact I. - exact (is_inverse_in_precat_inv I). Defined. Lemma post_comp_with_z_iso_is_inj {C : precategory} {a' a b : C} {f : a --> b} {g : b --> a} (i : is_inverse_in_precat f g) : ∏ (f' g' : a' --> a), f' · f = g' · f -> f' = g'. Proof. intros f' g' H. apply (maponpaths (postcompose g)) in H. unfold postcompose in H. do 2 rewrite <- assoc in H. rewrite (is_inverse_in_precat1 i) in H. do 2 rewrite id_right in H. exact H. Qed. Lemma post_comp_with_z_iso_inv_is_inj {C : precategory} {a b b' : C} {f : a --> b} {g : b --> a} (i : is_inverse_in_precat f g) : ∏ (f' g' : b' --> b), f' · g = g' · g -> f' = g'. Proof. intros f' g' H. apply (maponpaths (postcompose f)) in H. unfold postcompose in H. do 2 rewrite <- assoc in H. rewrite (is_inverse_in_precat2 i) in H. do 2 rewrite id_right in H. exact H. Qed. Lemma pre_comp_with_z_iso_is_inj {C : precategory} {a b b' : C} {f : a --> b} {g : b --> a} (i : is_inverse_in_precat f g) : ∏ (f' g' : b --> b'), f · f' = f · g' -> f' = g'. Proof. intros f' g' H. apply (maponpaths (compose g)) in H. do 2 rewrite assoc in H. rewrite (is_inverse_in_precat2 i) in H. do 2 rewrite id_left in H. exact H. Qed. Lemma cancel_precomposition_z_iso {C : precategory} {a b c : C} (f : z_iso a b) (g h : b --> c) : f · g = f · h -> g = h. Proof. use pre_comp_with_z_iso_is_inj. - exact (pr1 (pr2 f)). - exact (pr2 (pr2 f)). Qed. Lemma pre_comp_with_z_iso_is_inj' {C : precategory} {a b b' : C} {f : a --> b} (i : is_z_isomorphism f) : ∏ (f' g' : b --> b'), f · f' = f · g' -> f' = g'. Proof. intros f' g' H. apply (pre_comp_with_z_iso_is_inj (pr2 i)). exact H. Qed. Lemma pre_comp_with_z_iso_inv_is_inj {C : precategory} {a' a b : C} {f : a --> b} {g : b --> a} (i : is_inverse_in_precat f g) : ∏ (f' g' : a --> a'), g · f' = g · g' -> f' = g'. Proof. intros f' g' H. apply (maponpaths (compose f)) in H. do 2 rewrite assoc in H. rewrite (is_inverse_in_precat1 i) in H. do 2 rewrite id_left in H. exact H. Qed. Lemma z_iso_eq {C : category} {a b : C} (i i' : z_iso a b) (e : z_iso_mor i = z_iso_mor i') : i = i'. Proof. use total2_paths_f. - exact e. - use proofirrelevance. apply isaprop_is_z_isomorphism. Qed. Lemma z_iso_eq_inv {C : category} {a b : C} (i i' : z_iso a b) (e2 : inv_from_z_iso i = inv_from_z_iso i') : i = i'. Proof. use z_iso_eq. assert (H : is_inverse_in_precat (inv_from_z_iso i) i'). { use make_is_inverse_in_precat. - rewrite e2. exact (is_inverse_in_precat2 i'). - rewrite e2. exact (is_inverse_in_precat1 i'). } exact (inverse_unique_precat _ _ _ _ _ (z_iso_inv i) H). Qed. Definition morphism_from_z_iso {C : precategory_data} (a b : ob C) (f : z_iso a b) : a --> b := pr1 f. Coercion morphism_from_z_iso : z_iso >-> precategory_morphisms. Lemma isaset_z_iso {C : category} (a b : ob C) : isaset (z_iso a b). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. - apply homset_property. - intro f. apply isasetaprop. apply isaprop_is_z_isomorphism. Qed. Lemma identity_is_z_iso {C : precategory} (a : ob C) : is_z_isomorphism (identity a). Proof. exists (identity a). simpl; split; apply id_left. Defined. Definition identity_z_iso {C : precategory} (a : ob C) : z_iso a a := tpair _ _ (identity_is_z_iso a). Definition z_iso_inv_from_z_iso {C : precategory_data} {a b : ob C} (f : z_iso a b) : z_iso b a. Proof. exists (inv_from_z_iso f). apply is_z_iso_inv_from_z_iso. Defined. Definition z_iso_inv_from_is_z_iso {C : precategory_data} {a b : ob C} (f : a --> b) (H : is_z_isomorphism f) : z_iso b a := z_iso_inv_from_z_iso (f,,H). Definition z_iso_inv_after_z_iso {C : precategory_data} {a b : ob C} (f : z_iso a b) : f · inv_from_z_iso f = identity _ := pr1 (pr2 (pr2 f)). Definition z_iso_after_z_iso_inv {C : precategory_data} {a b : ob C} (f : z_iso a b) : inv_from_z_iso f · f = identity _ := pr2 (pr2 (pr2 f)). Lemma z_iso_inv_on_right {C : precategory} (a b c : ob C) (f : z_iso a b) (g : b --> c) (h : a --> c) (H : h = f · g) : inv_from_z_iso f · h = g. Proof. assert (H2 : inv_from_z_iso f · h = inv_from_z_iso f · (f · g)). apply maponpaths; assumption. rewrite assoc in H2. rewrite H2. rewrite z_iso_after_z_iso_inv. apply id_left. Qed. Lemma z_iso_inv_on_left {C : precategory} (a b c : ob C) (f : a --> b) (g : z_iso b c) (h : a --> c) (H : h = f · g) : f = h · inv_from_z_iso g. Proof. assert (H2 : h · inv_from_z_iso g = (f · g) · inv_from_z_iso g). rewrite H. apply idpath. rewrite <- assoc in H2. rewrite z_iso_inv_after_z_iso in H2. rewrite id_right in H2. apply pathsinv0. assumption. Qed. Lemma z_iso_inv_to_left {C : precategory} (a b c : ob C) (f : z_iso a b) (g : b --> c) (h : a --> c) : inv_from_z_iso f · h = g -> h = f · g. Proof. intro H. intermediate_path (f · inv_from_z_iso f · h). - rewrite z_iso_inv_after_z_iso, id_left; apply idpath. - rewrite <- assoc. apply maponpaths. assumption. Qed. Lemma z_iso_inv_to_right {C : precategory} (a b c : ob C) (f : a --> b) (g : z_iso b c) (h : a --> c) : f = h · inv_from_z_iso g -> f · g = h. Proof. intro H. intermediate_path (h · inv_from_z_iso g · g). - rewrite H. apply idpath. - rewrite <- assoc, z_iso_after_z_iso_inv, id_right. apply idpath. Qed. Lemma wrap_inverse {M : precategory} {x y : M} (g : x --> x) (f : z_iso x y) : g = identity x -> z_iso_inv f · g · f = identity y. Proof. intros e. rewrite e. rewrite id_right. apply z_iso_after_z_iso_inv. Defined. Lemma wrap_inverse' {M : precategory} {x y : M} (g : x --> x) (f : z_iso y x) : g = identity x -> f · g · z_iso_inv f = identity y. Proof. intros e. rewrite e. rewrite id_right. apply z_iso_inv_after_z_iso. Defined. Lemma cancel_z_iso {M : precategory} {x y z : M} (f f' : x --> y) (g : z_iso y z) : f · g = f' · g -> f = f'. Proof. intro e. destruct g as [g [g' H]]. apply (post_comp_with_z_iso_is_inj H). assumption. Qed. Lemma cancel_z_iso' {M : precategory} {w x y : M} (g : z_iso w x) (f f' : x --> y) : g · f = g · f' -> f = f'. Proof. intro e. destruct g as [g [g' H]]. apply (pre_comp_with_z_iso_is_inj H). assumption. Qed. Definition are_z_isomorphic {C : precategory_data} : hrel C := λ a b, ∥z_iso a b∥. Lemma iseqrel_are_z_isomorphic {C : precategory} : iseqrel (are_z_isomorphic(C:=C)). Proof. repeat split. - intros x y z h1. apply hinhuniv; intros h2; generalize h1; clear h1. now apply hinhuniv; intros h1; apply hinhpr, (z_iso_comp h1 h2). - now intros x; apply hinhpr, identity_z_iso. - now intros x y; apply hinhuniv; intro h1; apply hinhpr, z_iso_inv_from_z_iso. Qed. Definition z_iso_eqrel {C : precategory} : eqrel C := (are_z_isomorphic,,iseqrel_are_z_isomorphic). (** ** Properties of 0-isomorphisms *) (** Stability under composition, inverses etc *) Lemma are_inverse_comp_of_inverses {C : precategory} (a b c : C) (f : z_iso a b) (g : z_iso b c) : is_inverse_in_precat (f · g) (inv_from_z_iso g · inv_from_z_iso f). Proof. apply is_inverse_in_precat_comp. - apply (pr2 f). - apply (pr2 g). Qed. Lemma inv_z_iso_unique {C : category} (a b : ob C) (f : z_iso a b) (g : z_iso b a) : is_inverse_in_precat f g -> g = z_iso_inv_from_z_iso f. Proof. intro H. apply z_iso_eq. apply (inverse_unique_precat _ _ f). - assumption. - split. + apply z_iso_inv_after_z_iso. + set (h := z_iso_after_z_iso_inv f). apply h. Qed. Lemma inv_z_iso_unique' (C : precategory) (a b : C) (f : z_iso a b) (g : b --> a) : precomp_with f g = identity _ -> g = inv_from_z_iso f. Proof. intro H. apply (cancel_z_iso' f). unfold precomp_with in H. rewrite H. apply pathsinv0. apply z_iso_inv_after_z_iso. Defined. Lemma z_iso_inv_of_z_iso_comp {C : category} (a b c : ob C) (f : z_iso a b) (g : z_iso b c) : z_iso_inv_from_z_iso (z_iso_comp f g) = z_iso_comp (z_iso_inv_from_z_iso g) (z_iso_inv_from_z_iso f). Proof. apply z_iso_eq. apply idpath. Defined. Lemma z_iso_inv_of_z_iso_id {C : category} (a : ob C) : z_iso_inv_from_z_iso (identity_z_iso a) = identity_z_iso a. Proof. apply z_iso_eq. apply idpath. Qed. Lemma z_iso_inv_z_iso_inv {C : category} (a b : ob C) (f : z_iso a b) : z_iso_inv_from_z_iso (z_iso_inv_from_z_iso f) = f. Proof. apply z_iso_eq. apply idpath. Defined. Lemma z_iso_comp_right_isweq {C : precategory} {a b : ob C} (h : z_iso a b) (c : C) : isweq (fun f : b --> c => h · f). Proof. intros. apply (isweq_iso _ (λ g, inv_from_z_iso h · g)). { intros f. use (_ @ maponpaths (λ m, m · f) (pr2 (pr2 (pr2 h))) @ _). { apply assoc. } { apply id_left. } } { intros g. use (_ @ maponpaths (λ m, m · g) (pr1 (pr2 (pr2 h))) @ _). { apply assoc. } { apply id_left. } } Defined. Definition z_iso_comp_right_weq {C : precategory} {a b : C} (h : z_iso a b) (c : C) : (b --> c) ≃ (a --> c) := make_weq _ (z_iso_comp_right_isweq h c). Lemma z_iso_comp_left_isweq {C : precategory} {a b : ob C} (h : z_iso a b) (c : C) : isweq (fun f : c --> a => f · h). Proof. intros. apply (isweq_iso _ (λ g, g · inv_from_z_iso h)). { intros f. use (_ @ maponpaths (λ m, f · m) (pr1 (pr2 (pr2 h))) @ _). { apply pathsinv0. apply assoc. } { apply id_right. } } { intros g. use (_ @ maponpaths (λ m, g · m) (pr2 (pr2 (pr2 h))) @ _). { apply pathsinv0, assoc. } { apply id_right. } } Defined. Definition z_iso_comp_left_weq {C : precategory} {a b : C} (h : z_iso a b) (c : C) : (c --> a) ≃ (c --> b) := make_weq _ (z_iso_comp_left_isweq h c). Definition z_iso_conjug_weq {C : precategory} {a b : C} (h : z_iso a b) : (a --> a) ≃ (b --> b) := weqcomp (z_iso_comp_left_weq h _ ) (z_iso_comp_right_weq (z_iso_inv_from_z_iso h) _ ). Lemma is_iso_from_is_z_iso {C : precategory} {a b : C} (f: a --> b) : is_z_isomorphism f -> is_iso f. Proof. intro H. apply (is_iso_qinv _ (pr1 H)). apply (pr2 H). Defined. Definition z_iso_to_iso {C : precategory} {b c : C} (f : z_iso b c) : iso b c := pr1 f ,, is_iso_from_is_z_iso (pr1 f) (pr2 f). Lemma is_z_iso_from_is_iso {C : precategory} {a b : C} (f : a --> b): is_iso f -> is_z_isomorphism f. Proof. intro H. set (fiso := make_iso f H). exists (inv_from_iso fiso). split. - set (H2 := iso_inv_after_iso fiso). simpl in H2. apply H2. - set (H2 := iso_after_iso_inv fiso). simpl in H2. apply H2. Defined. Lemma is_z_iso_from_is_iso' (C : precategory) {b c : C} (f : b --> c) : is_iso' f -> is_z_isomorphism f. Proof. intros i. assert (Q := i c (identity c)). induction Q as [[g E] _]. unfold postcomp_with in E. exists g. split. 2 : { exact E. } assert (X := id_left _ : postcomp_with f (identity _) = f). assert (Y := ! assoc _ _ _ @ maponpaths (precomp_with f) E @ id_right _ : postcomp_with f (f · g) = f). clear E. set (x := (_,,X) : hfiber (postcomp_with f) f). set (y := (_,,Y) : hfiber (postcomp_with f) f). exact (maponpaths pr1 (proofirrelevancecontr (i b f) y x)). Defined. Definition iso_to_z_iso {C : precategory} {b c : C} : iso b c -> z_iso b c := λ f, pr1 f ,, is_z_iso_from_is_iso (pr1 f) (pr2 f). Lemma roundtrip1_iso_z_iso {C : precategory} {b c : C} (f: iso b c) : z_iso_to_iso (iso_to_z_iso f) = f. Proof. destruct f as [f H]. use total2_paths_f. - apply idpath. - apply isaprop_is_iso. Qed. Lemma roundtrip2_iso_z_iso {C : category} {b c : C} (f: z_iso b c) : iso_to_z_iso (z_iso_to_iso f) = f. Proof. destruct f as [f H]. use total2_paths_f. - apply idpath. - apply isaprop_is_z_isomorphism. Qed. Definition weq_iso_z_iso {C : category} {b c : C} : iso b c ≃ z_iso b c. Proof. exists iso_to_z_iso. use isweq_iso. - apply z_iso_to_iso. - apply roundtrip1_iso_z_iso. - apply roundtrip2_iso_z_iso. Defined. (** The right inverse of an invertible morphism must be equal to the known (two-sided) inverse. *) (** TODO: Did I switch up right and left here vis a vis the conventional use? *) Lemma right_inverse_of_iso_is_inverse {C : precategory} {c c' : C} (f : c --> c') (g : c' --> c) (H : is_inverse_in_precat f g) (h : c' --> c) (HH : f · h = identity _) : h = g. Proof. refine (!id_left _ @ _). refine (maponpaths (fun z => z · h) (!is_inverse_in_precat2 H) @ _). refine (!assoc _ _ _ @ _). refine (maponpaths (fun z => g · z) HH @ _). apply id_right. Qed. Lemma left_inverse_of_iso_is_inverse {C : precategory} {c c' : C} (f : c --> c') (g : c' --> c) (H : is_inverse_in_precat f g) (h : c' --> c) (HH : h · f = identity _) : h = g. Proof. refine (!id_right _ @ _). refine (maponpaths (fun z => h · z) (!is_inverse_in_precat1 H) @ _). refine (assoc _ _ _ @ _). refine (maponpaths (fun z => z · g) HH @ _). apply id_left. Qed. Definition is_z_isomorphism_path {C : category} {x y : C} {f f' : x --> y} (p : f = f') (Hf : is_z_isomorphism f) : is_z_isomorphism f'. Proof. use make_is_z_isomorphism. - exact (inv_from_z_iso (_ ,, Hf)). - split. + abstract (rewrite <- p ; apply (z_iso_inv_after_z_iso (_ ,, Hf))). + abstract (rewrite <- p ; apply (z_iso_after_z_iso_inv (_ ,, Hf))). Defined. UniMath-20231010/UniMath/CategoryTheory/Core/NaturalTransformations.v000066400000000000000000000416001451125700300254240ustar00rootroot00000000000000(** * Natural transformations Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) *) (** ** Contents - Definition of natural transformations - Equality is pointwise equality - Identity natural transformation - Composition of natural transformations - Natural isomorphisms *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section nat_trans. (** ** Definition of natural transformations *) Definition nat_trans_data {C C' : precategory_ob_mor} (F F' : functor_data C C'): UU := ∏ x : ob C, F x --> F' x. Definition is_nat_trans {C C' : precategory_data} (F F' : functor_data C C') (t : nat_trans_data F F') := ∏ (x x' : ob C)(f : x --> x'), # F f · t x' = t x · #F' f. Lemma isaprop_is_nat_trans (C C' : precategory_data) (hs: has_homsets C') (F F' : functor_data C C') (t : nat_trans_data F F'): isaprop (is_nat_trans F F' t). Proof. repeat (apply impred; intro). apply hs. Qed. Definition nat_trans {C C' : precategory_data} (F F' : functor_data C C') : UU := total2 (fun t : nat_trans_data F F' => is_nat_trans F F' t). Notation "F ⟹ G" := (nat_trans F G) (at level 39) : cat. (* to input: type "\==>" with Agda input method *) Definition make_nat_trans {C C' : precategory_data} (F F' : functor_data C C') (t : nat_trans_data F F') (H : is_nat_trans F F' t) : nat_trans F F'. Proof. exists t. exact H. Defined. Lemma isaset_nat_trans {C C' : precategory_data} (hs: has_homsets C') (F F' : functor_data C C') : isaset (nat_trans F F'). Proof. apply (isofhleveltotal2 2). + apply impred; intro t; apply hs. + intro x; apply isasetaprop, isaprop_is_nat_trans, hs. Qed. Definition nat_trans_data_from_nat_trans {C C' : precategory_data} {F F' : functor_data C C'}(a : nat_trans F F') : nat_trans_data F F' := pr1 a. Definition nat_trans_data_from_nat_trans_funclass {C C' : precategory_data} {F F' : functor_data C C'}(a : nat_trans F F') : ∏ x : ob C, F x --> F' x := pr1 a. Coercion nat_trans_data_from_nat_trans_funclass : nat_trans >-> Funclass. Definition nat_trans_ax {C C' : precategory_data} {F F' : functor_data C C'} (a : nat_trans F F') : ∏ (x x' : ob C)(f : x --> x'), #F f · a x' = a x · #F' f := pr2 a. (** Equality between two natural transformations *) Lemma nat_trans_eq {C C' : precategory_data} (hs: has_homsets C') (F F' : functor_data C C')(a a' : nat_trans F F'): (∏ x, a x = a' x) -> a = a'. Proof. intro H. assert (H' : pr1 a = pr1 a'). { now apply funextsec. } apply (total2_paths_f H'), proofirrelevance, isaprop_is_nat_trans, hs. Qed. Lemma nat_trans_eq_alt {C C' : category} (F F' : functor C C') (a a' : nat_trans F F'): (∏ x, a x = a' x) -> a = a'. Proof. apply nat_trans_eq. apply homset_property. Qed. Section nat_trans_eq. Context {C D : precategory}. Variable hsD : has_homsets D. Context {F G : functor C D}. Variables alpha beta : nat_trans F G. Definition nat_trans_eq_weq : (alpha = beta) ≃ (∏ c, alpha c = beta c). Proof. eapply weqcomp. - apply subtypeInjectivity. intro x. apply isaprop_is_nat_trans. apply hsD. - apply weqtoforallpaths. Defined. End nat_trans_eq. (* Can be given as an instance of general equality lemmas, but useful to have specifically defined. *) Definition nat_trans_eq_pointwise {C C' : precategory_data} {F F' : functor_data C C'} {a a' : nat_trans F F'}: a = a' -> ∏ x, a x = a' x. Proof. intro. apply toforallpaths, maponpaths. assumption. Qed. (** a more intuitive variant of [functor_data_eq] *) Lemma functor_data_eq_from_nat_trans (C C': precategory) (F F' : functor_data C C') (H : F ~ F') (H1 : is_nat_trans F F' (fun c:C => idtomor _ _ (H c))) : F = F'. Proof. apply (functor_data_eq _ _ _ _ H). intros c1 c2 f. rewrite double_transport_idtoiso. rewrite <- assoc. apply z_iso_inv_on_right. (* make the coercion visible: *) unfold z_iso_mor. do 2 rewrite eq_idtoiso_idtomor. apply H1. Qed. (** ** Identity natural transformation *) Lemma is_nat_trans_id {C : precategory_data}{C' : precategory} (F : functor_data C C') : is_nat_trans F F (λ c : ob C, identity (F c)). Proof. intros ? ? ? . now rewrite id_left, id_right. Qed. Definition nat_trans_id {C:precategory_data}{C' : precategory} (F : functor_data C C') : nat_trans F F := tpair _ _ (is_nat_trans_id F). (** ** Composition of natural transformations *) Lemma is_nat_trans_comp {C : precategory_data}{C' : precategory} {F G H : functor_data C C'} (a : nat_trans F G) (b : nat_trans G H): is_nat_trans F H (λ x : ob C, a x · b x). Proof. intros ? ? ?. now rewrite assoc, nat_trans_ax, <- assoc, nat_trans_ax, assoc. Qed. Definition nat_trans_comp {C:precategory_data}{C' : precategory} (F G H: functor_data C C') (a : nat_trans F G) (b : nat_trans G H): nat_trans F H := tpair _ _ (is_nat_trans_comp a b). (** Natural transformations for reasoning about various compositions of functors *) Section nat_trans_functor. Context {A B C D : precategory}. Definition nat_trans_functor_id_right (F : functor A B) : nat_trans (functor_composite F (functor_identity B)) F. Proof. apply nat_trans_id. Defined. Definition nat_trans_functor_id_right_inv (F : functor A B) : nat_trans F (functor_composite F (functor_identity B)) := nat_trans_functor_id_right F. Definition nat_trans_functor_id_left (F : functor A B) : nat_trans (functor_composite (functor_identity A) F) F := nat_trans_functor_id_right F. Definition nat_trans_functor_id_left_inv (F : functor A B) : nat_trans F (functor_composite (functor_identity A) F) := nat_trans_functor_id_right F. Definition nat_trans_functor_assoc (F1 : functor A B) (F2 : functor B C) (F3 : functor C D) : nat_trans (functor_composite (functor_composite F1 F2) F3) (functor_composite F1 (functor_composite F2 F3)). Proof. apply nat_trans_id. Defined. Definition nat_trans_functor_assoc_inv (F1 : functor A B) (F2 : functor B C) (F3 : functor C D) : nat_trans (functor_composite F1 (functor_composite F2 F3)) (functor_composite (functor_composite F1 F2) F3) := nat_trans_functor_assoc F1 F2 F3. End nat_trans_functor. (** Reasoning about composition of natural transformations *) Section nat_trans_comp_laws. Context {A B: precategory} (hs: has_homsets B). Definition nat_trans_comp_id_right (F G : functor A B) (α: nat_trans F G): nat_trans_comp _ _ _ α (nat_trans_id G) = α. Proof. apply nat_trans_eq; try exact hs. intro a. simpl. apply id_right. Qed. Definition nat_trans_comp_id_left (F G : functor A B) (α: nat_trans F G): nat_trans_comp _ _ _ (nat_trans_id F) α = α. Proof. apply nat_trans_eq; try exact hs. intro a. simpl. apply id_left. Qed. Definition nat_trans_comp_assoc (F1 F2 F3 F4 : functor A B) (α: nat_trans F1 F2) (β: nat_trans F2 F3) (γ: nat_trans F3 F4): nat_trans_comp _ _ _ α (nat_trans_comp _ _ _ β γ) = nat_trans_comp _ _ _ (nat_trans_comp _ _ _ α β) γ. Proof. apply nat_trans_eq; try exact hs. intro a. simpl. apply assoc. Qed. (** analogously to [assoc'], for convenience *) Definition nat_trans_comp_assoc' (F1 F2 F3 F4 : functor A B) (α: nat_trans F1 F2) (β: nat_trans F2 F3) (γ: nat_trans F3 F4): nat_trans_comp _ _ _ (nat_trans_comp _ _ _ α β) γ = nat_trans_comp _ _ _ α (nat_trans_comp _ _ _ β γ). Proof. apply pathsinv0, nat_trans_comp_assoc. Qed. End nat_trans_comp_laws. (** ** Natural isomorphisms *) Definition is_nat_iso {C D : precategory_data} {F G : functor_data C D} (μ : F ⟹ G) : UU := ∏ (c : C), is_iso (μ c). Definition isaprop_is_nat_iso {C D : category} {F G : C ⟶ D} (α : F ⟹ G) : isaprop (is_nat_iso α). Proof. apply impred. intro. apply isaprop_is_iso. Defined. Definition is_nat_id {C D : precategory} {F : C ⟶ D} (μ : F ⟹ F) : UU := ∏ (c : C), μ c = identity (F c). Definition nat_iso {C D : precategory} (F G : C ⟶ D) : UU := ∑ (μ : F ⟹ G), is_nat_iso μ. Definition make_nat_iso {C D : precategory} (F G : C ⟶ D) (μ : F ⟹ G) (is_iso : is_nat_iso μ) : nat_iso F G. Proof. exists μ. exact is_iso. Defined. Definition nat_iso_pointwise_iso {C D : precategory} {F G : C ⟶ D} (μ : nat_iso F G) (c: C): iso (F c) (G c) := (pr1 μ c,,pr2 μ c). Definition iso_inv_after_iso' {C : precategory} {a b : C} (f : a --> b) (f' : iso a b) (deref : pr1 f' = f) : f · inv_from_iso f' = identity _. Proof. rewrite <- deref. exact (iso_inv_after_iso f'). Defined. Definition iso_after_iso_inv' {C : precategory} {a b : C} (f : a --> b) (f' : iso a b) (deref : pr1 f' = f) : inv_from_iso f' · f = identity _. Proof. rewrite <- deref. exact (iso_after_iso_inv f'). Defined. Definition nat_iso_inv_trans {C D : precategory} {F G : C ⟶ D} (μ : nat_iso F G) : G ⟹ F. Proof. use make_nat_trans. - exact (λ x, inv_from_iso (make_iso _ (pr2 μ x))). - abstract (intros x y f ; cbn ; refine (!_) ; use iso_inv_on_right ; cbn ; rewrite !assoc ; use iso_inv_on_left ; cbn ; exact (!(nat_trans_ax (pr1 μ) _ _ f))). Defined. Definition nat_iso_inv {C D : precategory} {F G : C ⟶ D} (μ : nat_iso F G) : nat_iso G F. Proof. use make_nat_iso. - exact (nat_iso_inv_trans μ). - intro x. apply is_iso_inv_from_iso. Defined. Definition nat_iso_to_trans {C D : precategory} {F G : C ⟶ D} (ν : nat_iso F G) : F ⟹ G := pr1 ν. Coercion nat_iso_to_trans : nat_iso >-> nat_trans. (* ⁻¹ *) Definition nat_iso_to_trans_inv {C D : precategory} {F G : C ⟶ D} (ν : nat_iso F G) : G ⟹ F := pr1 (nat_iso_inv ν). Definition nat_comp_to_endo {C D : precategory} {F G : C ⟶ D} (eq : F = G) {c : C} (f : F c --> G c) : F c --> F c. Proof. rewrite <- eq in f. assumption. Defined. Definition is_nat_iso_id {C D : precategory} {F G : C ⟶ D} (eq : F = G) (ν : nat_iso F G) : UU := ∏ (c : C), nat_comp_to_endo eq (nat_iso_to_trans ν c) = identity (F c). Definition induced_precategory_incl {M : precategory} {X:Type} (j : X -> ob M) : induced_precategory M j ⟶ M. Proof. use make_functor. - use make_functor_data. + exact j. + intros a b f. exact f. - repeat split. Defined. (* ** analogous development for [z_iso] *) Definition is_nat_z_iso {C D : precategory_data} {F G : functor_data C D} (μ : nat_trans_data F G) : UU := ∏ (c : C), is_z_isomorphism (μ c). Definition isaprop_is_nat_z_iso {C D : category} {F G : C ⟶ D} (α : nat_trans_data F G) : isaprop (is_nat_z_iso α). Proof. apply impred. intro. apply isaprop_is_z_isomorphism. Defined. Definition nat_z_iso {C D : precategory_data} (F G : C ⟶ D) : UU := ∑ (μ : F ⟹ G), is_nat_z_iso μ. Definition make_nat_z_iso {C D : precategory_data} (F G : C ⟶ D) (μ : F ⟹ G) (is_z_iso : is_nat_z_iso μ) : nat_z_iso F G. Proof. exists μ. exact is_z_iso. Defined. Lemma nat_z_iso_id {C D:category} (F: C ⟶ D): nat_z_iso F F. Proof. apply (make_nat_z_iso F F (nat_trans_id F)). intro c. exists (identity (F c)). split; apply id_left. Defined. Definition nat_z_iso_to_trans {C D : precategory_data} {F G : C ⟶ D} (μ : nat_z_iso F G) : F ⟹ G := pr1 μ. Coercion nat_z_iso_to_trans : nat_z_iso >-> nat_trans. Definition pr2_nat_z_iso {C D : precategory_data} {F G : C ⟶ D} (μ : nat_z_iso F G) : is_nat_z_iso μ := pr2 μ. Definition nat_z_iso_pointwise_z_iso {C D : precategory_data} {F G : C ⟶ D} (μ : nat_z_iso F G) (c: C): z_iso (F c) (G c) := (pr1 μ c,,pr2 μ c). (* ⁻¹ *) Definition nat_z_iso_to_trans_inv {C : precategory_data} {D : precategory} {F G : C ⟶ D} (μ : nat_z_iso F G) : G ⟹ F. Proof. apply (make_nat_trans G F (fun c => is_z_isomorphism_mor (pr2 μ c))). red. intros c c' f. set (h := μ c,,pr2 μ c : z_iso (F c) (G c)). set (h' := μ c',,pr2 μ c' : z_iso (F c') (G c')). change (# G f · inv_from_z_iso h' = inv_from_z_iso h · # F f). apply pathsinv0. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply pathsinv0. apply (nat_trans_ax μ). Defined. Definition nat_z_iso_inv {C : precategory_data} {D : precategory} {F G : C ⟶ D} (μ : nat_z_iso F G) : nat_z_iso G F. Proof. exists (nat_z_iso_to_trans_inv μ). intro c. red. exists (μ c). red. split. - apply (pr2 (is_z_isomorphism_is_inverse_in_precat (pr2 μ c))). - apply (pr1 (is_z_isomorphism_is_inverse_in_precat (pr2 μ c))). Defined. Lemma nat_z_iso_inv_id {C D : category} {F : C ⟶ D} : nat_z_iso_inv (nat_z_iso_id F) = nat_z_iso_id F. Proof. use total2_paths_f. - use total2_paths_f. * reflexivity. * apply proofirrelevance. apply isaprop_is_nat_trans. apply homset_property. - apply proofirrelevance. apply isaprop_is_nat_z_iso. Qed. Definition is_nat_z_iso_comp {C : precategory_data} {D : precategory} {F G H: C ⟶ D} {μ : F ⟹ G} {ν : G ⟹ H} (isμ: is_nat_z_iso μ) (isν: is_nat_z_iso ν) : is_nat_z_iso (nat_trans_comp F G H μ ν). Proof. intro c. use make_is_z_isomorphism. - exact (is_z_isomorphism_mor (isν c) · is_z_isomorphism_mor (isμ c)). - exact (is_inverse_in_precat_comp (pr2 (isμ c)) (pr2 (isν c))). Defined. Definition nat_z_iso_comp {C : precategory_data} {D : precategory} {F G H: C ⟶ D} (μ: nat_z_iso F G) (ν: nat_z_iso G H) : nat_z_iso F H. Proof. use make_nat_z_iso. - exact (nat_trans_comp F G H μ ν). - exact (is_nat_z_iso_comp (pr2 μ) (pr2 ν)). Defined. Definition is_nat_z_iso_id {C D : precategory} {F G : C ⟶ D} (eq : F = G) (ν : nat_z_iso F G) : UU := ∏ (c : C), nat_comp_to_endo eq (nat_z_iso_to_trans ν c) = identity (F c). Lemma comp_nat_z_iso_id_left {C D:category} {F G:functor C D} (α: nat_z_iso F G) :nat_z_iso_comp (nat_z_iso_id F) α = α. Proof. induction α as (α, α_is_nat_z_iso). use total2_paths_f; cbn. - exact (nat_trans_comp_id_left (pr2 D) F G α). - apply proofirrelevance. apply isaprop_is_nat_z_iso. Qed. Lemma comp_nat_z_iso_id_right {C D:category} {F G:functor C D} (α: nat_z_iso F G) :nat_z_iso_comp α (nat_z_iso_id G) = α. Proof. induction α as (α, α_is_nat_z_iso). use total2_paths_f; cbn. - exact (nat_trans_comp_id_right (pr2 D) F G α). - apply proofirrelevance. apply isaprop_is_nat_z_iso. Qed. Lemma is_nat_z_iso_nat_trans_id {C D : precategory} (F :functor_data C D): is_nat_z_iso (nat_trans_id F). Proof. intro c. exists (identity (F c)). split; apply id_right. Defined. End nat_trans. Definition to_constant_nat_trans {C₁ C₂ : category} (F : C₁ ⟶ C₂) (y : C₂) (fs : ∏ (x : C₁), F x --> y) (ps : ∏ (x₁ x₂ : C₁) (g : x₁ --> x₂), # F g · fs x₂ = fs x₁) : nat_trans F (constant_functor C₁ C₂ y). Proof. use make_nat_trans. - exact (λ x, fs x). - abstract (intros x₁ x₂ g ; cbn ; rewrite id_right ; rewrite ps ; apply idpath). Defined. Definition constant_nat_trans (C₁ : category) {C₂ : category} {x y : C₂} (f : x --> y) : nat_trans (constant_functor C₁ C₂ x) (constant_functor C₁ C₂ y). Proof. use make_nat_trans. - exact (λ _, f). - abstract (intros ? ? ? ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Notation "F ⟹ G" := (nat_trans F G) (at level 39) : cat. (* to input: type "\==>" with Agda input method *) (* Commutativity of functors expressed as natural isomorphisms *) Lemma nat_z_iso_functor_comp_assoc {C1 C2 C3 C4 : category} (F1 : functor C1 C2) (F2 : functor C2 C3) (F3 : functor C3 C4) : nat_z_iso (F1 ∙ (F2 ∙ F3)) ((F1 ∙ F2) ∙ F3). Proof. use make_nat_z_iso. - exists (λ _, identity _). abstract (intro ; intros ; exact (id_right _ @ ! id_left _)). - intro. exists (identity _). abstract (split ; apply id_right). Defined. Lemma functor_commutes_with_id {C D : category} (F : functor C D) : nat_z_iso (F ∙ functor_identity D) (functor_identity C ∙ F). Proof. use make_nat_z_iso. - exists (λ _, identity _). abstract (intro ; intros ; exact (id_right _ @ ! id_left _)). - intro. exists (identity _). abstract (split ; apply id_right). Defined. Lemma nat_z_iso_comp_assoc {C D : category} {F1 F2 F3 F4 : functor C D} (α1 : nat_z_iso F1 F2) (α2 : nat_z_iso F2 F3) (α3 : nat_z_iso F3 F4) : nat_z_iso_comp α1 (nat_z_iso_comp α2 α3) = nat_z_iso_comp (nat_z_iso_comp α1 α2) α3. Proof. use total2_paths_f. 2: { apply isaprop_is_nat_z_iso. } use nat_trans_eq. { apply homset_property. } intro. apply assoc. Qed. UniMath-20231010/UniMath/CategoryTheory/Core/Prelude.v000066400000000000000000000010601451125700300223000ustar00rootroot00000000000000(** * Prelude for category theory *) (** This re-exports modules that are very frequently needed when doing any kind of category theory. This is a matter of taste, but supported empirically by the number of files in this package that import these modules individually. *) Require Export UniMath.CategoryTheory.Core.Categories. Require Export UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.Core.Isos. Require Export UniMath.CategoryTheory.Core.NaturalTransformations. Require Export UniMath.CategoryTheory.Core.Univalence.UniMath-20231010/UniMath/CategoryTheory/Core/Setcategories.v000066400000000000000000000061211451125700300235040ustar00rootroot00000000000000(** * Setcategories: Precategories whose objects and morphisms are sets *) (** ** Contents - Setcategories: objects and morphisms are sets [setcategory] *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Definition object_hlevel (n : nat) (C : precategory) : hProp := make_hProp _ (isapropisofhlevel n (ob C)). (* TODO: someday, [has_homsets] should be rephrased in terms of this *) Definition homtype_hlevel (n : nat) (C : precategory) : hProp := make_hProp (∏ a b : C, isofhlevel n (C ⟦ a, b ⟧)) (impred _ _ (λ _, impred _ _ (λ _, isapropisofhlevel n _))). Definition object_homtype_hlevel (n m : nat) (C : precategory) : hProp := object_hlevel n C ∧ homtype_hlevel m C. Definition is_setcategory : precategory → UU := object_homtype_hlevel 2 2. Definition setcategory := total2 is_setcategory. Definition category_from_setcategory (C : setcategory) : category := (pr1 C,, (dirprod_pr2 (pr2 C))). Coercion category_from_setcategory : setcategory >-> category. Lemma isaprop_is_setcategory (C : precategory) : isaprop (is_setcategory C). Proof. apply isapropdirprod. - apply isapropisaset. - apply isaprop_has_homsets. Defined. Definition setcategory_objects_set (C : setcategory) : hSet := make_hSet (ob C) (pr1 (pr2 C)). Definition isaset_ob (C : setcategory) : isaset C := (dirprod_pr1 (pr2 C)). Definition isaset_mor (C : setcategory) : has_homsets C := homset_property C. Lemma setcategory_eq_morphism_pi (C : setcategory) (a b : ob C) (e e': a = b) : idtomor _ _ e = idtomor _ _ e'. Proof. assert (h : e = e'). apply uip. apply (pr2 C). apply (maponpaths (idtomor _ _ ) h). Qed. Definition setcategory_eq_idtoiso {C : setcategory} {x y : C} (p q : x = y) : pr1 (idtoiso p) = pr1 (idtoiso q). Proof. do 2 apply maponpaths. apply C. Qed. Definition setcategory_refl_idtoiso {C : setcategory} {x : C} (p : x = x) : pr1 (idtoiso p) = identity _. Proof. apply (setcategory_eq_idtoiso p (idpath x)). Qed. Definition setcategory_eq_idtoiso_comp {C : setcategory} {x x' y y' : C} (p p' : x = x') (f : x' --> y) (q q' : y = y') : idtoiso p · f · idtoiso q = idtoiso p' · f · idtoiso q'. Proof. etrans. { apply maponpaths. exact (setcategory_eq_idtoiso q q'). } do 2 apply maponpaths_2. apply setcategory_eq_idtoiso. Qed. Definition from_eq_cat_of_setcategory {C₁ C₂ : setcategory} {F₁ F₂ : C₁ ⟶ C₂} (p : F₁ = F₂) {x₁ x₂ : pr1 C₁} (f : x₁ --> x₂) : # (pr1 F₁) f = idtoiso (maponpaths (λ z, pr11 z x₁) p) · # (pr1 F₂) f · idtoiso (maponpaths (λ z, pr11 z x₂) (!p)). Proof. induction p ; cbn. rewrite id_left, id_right. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/Core/TransportMorphisms.v000066400000000000000000000134611451125700300246060ustar00rootroot00000000000000(** * Lemmas on transport of morphisms *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. (** *** Transport source and target of a morphism *) Lemma transport_target_postcompose {C : precategory} {x y z w : ob C} (f : x --> y) (g : y --> z) (e : z = w) : transportf (precategory_morphisms x) e (f · g) = f · transportf (precategory_morphisms y) e g. Proof. induction e. apply idpath. Qed. Lemma transport_source_precompose {C : precategory} {x y z w : ob C} (f : x --> y) (g : y --> z) (e : x = w) : transportf (λ x' : ob C, precategory_morphisms x' z) e (f · g) = transportf (λ x' : ob C, precategory_morphisms x' y) e f · g. Proof. induction e. apply idpath. Qed. Lemma transport_compose {C : precategory} {x y z w : ob C} (f : x --> y) (g : z --> w) (e : y = z) : transportf (precategory_morphisms x) e f · g = f · transportf (λ x' : ob C, precategory_morphisms x' w) (! e) g. Proof. induction e. apply idpath. Qed. Lemma transport_compose' {C : precategory} {x y z w : ob C} (f : x --> y) (g : y --> z) (e : y = w) : (transportf (precategory_morphisms x) e f) · (transportf (λ x' : ob C, precategory_morphisms x' z) e g) = f · g. Proof. induction e. apply idpath. Qed. Lemma transport_target_path {C : precategory} {x y z : ob C} (f g : x --> y) (e : y = z) : transportf (precategory_morphisms x) e f = transportf (precategory_morphisms x) e g -> f = g. Proof. induction e. intros H. apply H. Qed. Lemma transport_source_path {C : precategory} {x y z : ob C} (f g : y --> z) (e : y = x) : transportf (λ x' : ob C, precategory_morphisms x' z) e f = transportf (λ x' : ob C, precategory_morphisms x' z) e g -> f = g. Proof. induction e. intros H. apply H. Qed. Lemma transport_source_target {X : UU} {C : precategory} {x y : X} (P : ∏ (x' : X), ob C) (P' : ∏ (x' : X), ob C) (f : ∏ (x' : X), (P x') --> (P' x')) (e : x = y) : transportf (λ (x' : X), (P x') --> (P' x')) e (f x) = transportf (λ (x' : X), precategory_morphisms (P x') (P' y)) e (transportf (precategory_morphisms (P x)) (maponpaths P' e) (f x)). Proof. rewrite <- functtransportf. unfold pathsinv0. unfold paths_rect. induction e. apply idpath. Qed. Lemma transport_target_source {X : UU} {C : precategory} {x y : X} (P : ∏ (x' : X), ob C) (P' : ∏ (x' : X), ob C) (f : ∏ (x' : X), (P x') --> (P' x')) (e : x = y) : transportf (λ (x' : X), (P x') --> (P' x')) e (f x) = transportf (precategory_morphisms (P y)) (maponpaths P' e) (transportf (λ (x' : X), precategory_morphisms (P x') (P' x)) e (f x)). Proof. rewrite <- functtransportf. unfold pathsinv0. unfold paths_rect. induction e. apply idpath. Qed. Lemma transport_source_target_comm {C : precategory} {x y x' y' : ob C} (f : x --> y) (e1 : x = x') (e2 : y = y') : transportf (λ (x'' : ob C), precategory_morphisms x'' y') e1 (transportf (precategory_morphisms x) e2 f) = transportf (precategory_morphisms x') e2 (transportf (λ (x'' : ob C), precategory_morphisms x'' y) e1 f). Proof. induction e1. induction e2. apply idpath. Qed. (** *** Transport a morphism using funextfun *) Definition transport_source_funextfun {X : UU} {C : precategory_ob_mor} (F F' : X -> ob C) (H : ∏ (x : X), F x = F' x) {x : X} (c : ob C) (f : F x --> c) : transportf (λ x0 : X → C, x0 x --> c) (funextfun F F' H) f = transportf (λ x0 : C, x0 --> c) (H x) f. Proof. exact (@transportf_funextfun X (ob C) (λ x0 : C, x0 --> c) F F' H x f). Qed. Definition transport_target_funextfun {X : UU} {C : precategory_ob_mor} (F F' : X -> ob C) (H : ∏ (x : X), F x = F' x) {x : X} {c : ob C} (f : c --> F x) : transportf (λ x0 : X → C, c --> x0 x) (funextfun F F' H) f = transportf (λ x0 : C, c --> x0) (H x) f. Proof. use transportf_funextfun. Qed. Lemma transport_mor_funextfun {X : UU} {C : precategory_ob_mor} (F F' : X -> ob C) (H : ∏ (x : X), F x = F' x) {x1 x2 : X} (f : F x1 --> F x2) : transportf (λ x : X → C, x x1 --> x x2) (funextfun F F' H) f = transportf (λ x : X → C, F' x1 --> x x2) (funextfun F F' (λ x : X, H x)) (transportf (λ x : X → C, x x1 --> F x2) ((funextfun F F' (λ x : X, H x))) f). Proof. induction (funextfun F F' (λ x : X, H x)). apply idpath. Qed. (** *** Transport of is_iso *) Lemma transport_target_is_iso {C : precategory} {x y z : ob C} (f : x --> y) (H : is_iso f) (e : y = z) : is_iso (transportf (precategory_morphisms x) e f). Proof. induction e. apply H. Qed. Lemma transport_source_is_iso {C : precategory} {x y z : ob C} (f : x --> y) (H : is_iso f) (e : x = z) : is_iso (transportf (λ x' : ob C, precategory_morphisms x' y) e f). Proof. induction e. apply H. Qed. (** *** Induced precategories *) Definition induced_precategory (M : precategory) {X:Type} (j : X -> ob M) : precategory. Proof. use tpair. - use tpair. + exact (X,, λ a b, precategory_morphisms (j a) (j b)). + split;cbn. * exact (λ c, identity (j c)). * exact (λ a b c, @compose M (j a) (j b) (j c)). - repeat split; cbn. + exact (λ a b, @id_left M (j a) (j b)). + exact (λ a b, @id_right M (j a) (j b)). + exact (λ a b c d, @assoc M (j a) (j b) (j c) (j d)). + exact (λ a b c d, @assoc' M (j a) (j b) (j c) (j d)). Defined. Lemma has_homsets_induced_precategory (M : category) {X:Type} (j : X -> ob M) : has_homsets (induced_precategory M j). Proof. intros a b. apply M. Defined. Definition induced_category (M : category) {X:Type} (j : X -> ob M) : category := make_category _ (has_homsets_induced_precategory M j). UniMath-20231010/UniMath/CategoryTheory/Core/TwoCategories.v000066400000000000000000000275071451125700300234750ustar00rootroot00000000000000(* ******************************************************************************* *) (** * 2-categories ********************************************************************************* *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. (* change the category to data and add the category laws to two_cat_laws (including that the 2-cells are a set) there should be a coercion from 2-category data to category data *) Definition two_cat_data : UU := ∑ (C : precategory_data) (cells_C : ∏ (x y : C), x --> y → x --> y → UU), (∏ (x y : C) (f : x --> y), cells_C _ _ f f) × (∏ (x y : C) (f g h : x --> y), cells_C _ _ f g → cells_C _ _ g h → cells_C _ _ f h) × (∏ (x y z : C) (f : x --> y) (g1 g2 : y --> z), cells_C _ _ g1 g2 → cells_C _ _ (f · g1) (f · g2)) × (∏ (x y z : C) (f1 f2 : x --> y) (g : y --> z), cells_C _ _ f1 f2 → cells_C _ _ (f1 · g) (f2 · g)). Coercion precategory_from_two_cat_data (C : two_cat_data) : precategory_data := pr1 C. Definition two_cat_cells (C : two_cat_data) {a b : C} (f g : C⟦a, b⟧) : UU := pr12 C a b f g. Local Notation "f '==>' g" := (two_cat_cells _ f g) (at level 60). Local Notation "f '<==' g" := (two_cat_cells _ g f) (at level 60, only parsing). (* ----------------------------------------------------------------------------------- *) (** Data projections. *) (* ----------------------------------------------------------------------------------- *) Definition id2 {C : two_cat_data} {a b : C} (f : C⟦a, b⟧) : f ==> f := pr122 C a b f. Definition vcomp2 {C : two_cat_data} {a b : C} {f g h : C⟦a, b⟧} : f ==> g → g ==> h → f ==> h := λ x y, pr1 (pr222 C) _ _ _ _ _ x y. Definition lwhisker {C : two_cat_data} {a b c : C} (f : C⟦a, b⟧) {g1 g2 : C⟦b, c⟧} : g1 ==> g2 → f · g1 ==> f · g2 := λ x, pr12 (pr222 C) _ _ _ _ _ _ x. Definition rwhisker {C : two_cat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} (g : C⟦b, c⟧) : f1 ==> f2 → f1 · g ==> f2 · g := λ x, pr22 (pr222 C) _ _ _ _ _ _ x. Local Notation "x • y" := (vcomp2 x y) (at level 60). Local Notation "f ◃ x" := (lwhisker f x) (at level 60). (* \tw *) Local Notation "y ▹ g" := (rwhisker g y) (at level 60). (* \tw nr 2 *) Definition hcomp {C : two_cat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} {g1 g2 : C⟦b, c⟧} : f1 ==> f2 -> g1 ==> g2 -> f1 · g1 ==> f2 · g2 := λ x y, (x ▹ g1) • (f2 ◃ y). Definition hcomp' {C : two_cat_data} {a b c : C} {f1 f2 : C⟦a, b⟧} {g1 g2 : C⟦b, c⟧} : f1 ==> f2 -> g1 ==> g2 -> f1 · g1 ==> f2 · g2 := λ x y, (f1 ◃ y) • (x ▹ g2). Local Notation "x ⋆ y" := (hcomp x y) (at level 50, left associativity). Definition idto2mor {C : two_cat_data} {x y : C} {f g : x --> y} (p : f = g) : f ==> g. Proof. induction p. apply id2. Defined. (* ----------------------------------------------------------------------------------- *) (** ** Laws *) (* ----------------------------------------------------------------------------------- *) (* ----------------------------------------------------------------------------------- *) (** The numbers in the following laws refer to the list of axioms given in ncatlab (Section "Definition / Details") https://ncatlab.org/nlab/show/bicategory#detailedDefn version of October 7, 2015 10:35:36 *) (* ----------------------------------------------------------------------------------- *) Definition two_cat_category : UU := ∑ (C : two_cat_data), is_precategory C × has_homsets C. Definition category_from_two_cat_data (C : two_cat_category) : category. Proof. use make_category. - use make_precategory. + apply (pr1 C). + exact (pr12 C). - exact (pr22 C). Defined. Coercion category_from_two_cat_data : two_cat_category >-> category. Definition two_cat_laws (C : two_cat_category) : UU := (** 1a id2_left *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), id2 f • x = x) × (** 1b id2_right *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), x • id2 g = x) × (** 2 vassocr *) (∏ (a b : C) (f g h k : C⟦a, b⟧) (x : f ==> g) (y : g ==> h) (z : h ==> k), x • (y • z) = (x • y) • z) × (** 3a lwhisker_id2 *) (∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧), f ◃ id2 g = id2 _) × (** 3b id2_rwhisker *) (∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧), id2 f ▹ g = id2 _) × (** 4 lwhisker_vcomp *) (∏ (a b c : C) (f : C⟦a, b⟧) (g h i : C⟦b, c⟧) (x : g ==> h) (y : h ==> i), (f ◃ x) • (f ◃ y) = f ◃ (x • y)) × (** 5 rwhisker_vcomp *) (∏ (a b c : C) (f g h : C⟦a, b⟧) (i : C⟦b, c⟧) (x : f ==> g) (y : g ==> h), (x ▹ i) • (y ▹ i) = (x • y) ▹ i) × (** 6 vcomp_whisker *) (∏ (a b c : C) (f g : C⟦a, b⟧) (h i : C⟦b, c⟧) (x : f ==> g) (y : h ==> i), (x ▹ h) • (g ◃ y) = (f ◃ y) • (x ▹ i)) × (** 7 naturality of left whiskering *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), (identity a ◃ x) • idto2mor (id_left g) = idto2mor (id_left f) • x) × (** 8 naturality of right whiskering *) (∏ (a b : C) (f g : C⟦a, b⟧) (x : f ==> g), (x ▹ identity b) • idto2mor (id_right g) = idto2mor (id_right f) • x) × (** 9 left whisker of left whisker *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h i : C⟦c, d⟧) (x : h ==> i), (f ◃ (g ◃ x)) • idto2mor (assoc f g i) = idto2mor (assoc f g h) • (f · g ◃ x)) × (** 10 right whisker of left whisker *) (∏ (a b c d : C) (f : C⟦a, b⟧) (g h : C⟦b, c⟧) (i : C⟦c, d⟧) (x : g ==> h), (f ◃ (x ▹ i) • idto2mor (assoc f h i) = idto2mor (assoc f g i) • ((f ◃ x) ▹ i))) × (** 11 right whisker of right whisker *) (∏ (a b c d : C) (f g : C⟦a, b⟧) (h : C⟦b, c⟧) (i : C⟦c, d⟧) (x : f ==> g), idto2mor (assoc f h i) • (x ▹ h ▹ i) = (x ▹ h · i) • idto2mor (assoc g h i)). Definition two_precat : UU := ∑ C : two_cat_category, two_cat_laws C. Coercion two_cat_category_from_two_cat (C : two_precat) : two_cat_category := pr1 C. Coercion two_cat_laws_from_two_cat (C : two_precat) : two_cat_laws C := pr2 C. (* ----------------------------------------------------------------------------------- *) (** Laws projections. *) (* ----------------------------------------------------------------------------------- *) Section two_cat_law_projections. Context {C : two_precat}. (** 1a id2_left *) Definition id2_left {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : id2 f • x = x := pr1 (pr2 C) _ _ _ _ x. (** 1b id2_right *) Definition id2_right {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : x • id2 g = x := pr1 (pr2 (pr2 C)) _ _ _ _ x. (** 2 vassocr *) Definition vassocr {a b : C} {f g h k : C⟦a, b⟧} (x : f ==> g) (y : g ==> h) (z : h ==> k) : x • (y • z) = (x • y) • z := pr1 (pr2 (pr2 (pr2 C))) _ _ _ _ _ _ x y z. (** 3a lwhisker_id2 *) Definition lwhisker_id2 {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : f ◃ id2 g = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 C)))) _ _ _ f g. (** 3b id2_rwhisker *) Definition id2_rwhisker {a b c : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : id2 f ▹ g = id2 _ := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 C))))) _ _ _ f g. (** 4 lwhisker_vcomp *) Definition lwhisker_vcomp {a b c : C} (f : C⟦a, b⟧) {g h i : C⟦b, c⟧} (x : g ==> h) (y : h ==> i) : (f ◃ x) • (f ◃ y) = f ◃ (x • y) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))) _ _ _ f _ _ _ x y. (** 5 rwhisker_vcomp *) Definition rwhisker_vcomp {a b c : C} {f g h : C⟦a, b⟧} (i : C⟦b, c⟧) (x : f ==> g) (y : g ==> h) : (x ▹ i) • (y ▹ i) = (x • y) ▹ i := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))) _ _ _ _ _ _ i x y. (** 6 vcomp_whisker *) Definition vcomp_whisker {a b c : C} {f g : C⟦a, b⟧} {h i : C⟦b, c⟧} (x : f ==> g) (y : h ==> i) : (x ▹ h) • (g ◃ y) = (f ◃ y) • (x ▹ i) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))) _ _ _ _ _ _ i x y. (** 7 vcomp_lunitor *) Definition vcomp_lunitor {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : (identity a ◃ x) • idto2mor (id_left g) = idto2mor (id_left f) • x := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))) _ _ _ _ x. (** 8 vcomp_runitor *) Definition vcomp_runitor {a b : C} {f g : C⟦a, b⟧} (x : f ==> g) : (x ▹ identity b) • idto2mor (id_right g) = idto2mor (id_right f) • x := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))) _ _ _ _ x. (** 9 lwhisker_lwhisker *) Definition lwhisker_lwhisker {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) {h i : C⟦c, d⟧} (x : h ==> i) : (f ◃ (g ◃ x)) • idto2mor (assoc f g i) = idto2mor (assoc f g h) • (f · g ◃ x) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C))))))))))) _ _ _ _ _ _ _ _ x. (** 10 rwhisker_lwhisker *) Definition rwhisker_lwhisker {a b c d : C} (f : C⟦a, b⟧) {g h : C⟦b, c⟧} (i : C⟦c, d⟧) (x : g ==> h) : (f ◃ (x ▹ i) • idto2mor (assoc f h i) = idto2mor (assoc f g i) • ((f ◃ x) ▹ i)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))) _ _ _ _ _ _ _ _ x. (** 11 rwhisker_rwhisker *) Definition rwhisker_rwhisker {a b c d : C} {f g : C⟦a, b⟧} (h : C⟦b, c⟧) (i : C⟦c, d⟧) (x : f ==> g) : idto2mor (assoc f h i) • (x ▹ h ▹ i) = (x ▹ h · i) • idto2mor (assoc g h i) := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))))))))) _ _ _ _ _ _ _ _ x. End two_cat_law_projections. (* ----------------------------------------------------------------------------------- *) (** ** Bicategories *) (* ----------------------------------------------------------------------------------- *) Definition isaset_cells (C : two_precat) : UU := ∏ (a b : C) (f g : a --> b), isaset (f ==> g). Definition two_cat : UU := ∑ C : two_precat, isaset_cells C. Coercion two_cat_to_two_precat (C : two_cat) : two_precat := pr1 C. Definition isaprop_two_cat_laws (C : two_cat) : isaprop (two_cat_laws C). Proof. unfold two_cat_laws. repeat (apply isapropdirprod) ; repeat (use impred ; intro) ; apply C. Qed. (* ----------------------------------------------------------------------------------- *) (** ** Laws for id to 2 mor *) (* ----------------------------------------------------------------------------------- *) Section IdTo2MorLaws. Context {C : two_precat}. Definition idto2mor_comp {x y : C} {f g h : x --> y} (p : f = g) (q : g = h) : idto2mor p • idto2mor q = idto2mor (p @ q). Proof. induction p, q ; cbn. apply id2_left. Qed. Definition idto2mor_lwhisker {x y z : C} (f : x --> y) {g h : y --> z} (p : g = h) : f ◃ idto2mor p = idto2mor (maponpaths (λ q, f · q) p). Proof. induction p ; cbn. apply lwhisker_id2. Qed. Definition idto2mor_rwhisker {x y z : C} {f g : x --> y} (h : y --> z) (p : f = g) : idto2mor p ▹ h = idto2mor (maponpaths (λ q, q · h) p). Proof. induction p ; cbn. apply id2_rwhisker. Qed. End IdTo2MorLaws. UniMath-20231010/UniMath/CategoryTheory/Core/Univalence.v000066400000000000000000000222411451125700300227750ustar00rootroot00000000000000(** * Univalent categories (AKA saturated categories) *) (** ** Contents - Univalent categories: [idtoiso] is an equivalence ([univalent_category]) - Definition of [isotoid] - Properties of [idtoiso] and [isotoid] - Univalent categories have groupoid as objects [univalent_category_has_groupoid_ob] - Many lemmas about [idtoiso], [isotoid], interplay with composition, transport etc. *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. (** ** Univalent categories: [idtoiso] is an equivalence *) Definition idtoiso {C : precategory} {a b : ob C}: a = b -> z_iso a b. Proof. intro H. induction H. exact (identity_z_iso a). Defined. Proposition idtoiso_idpath {C : category} (x : C) : pr1 (idtoiso (idpath x)) = identity x. Proof. apply idpath. Qed. (* use eta expanded version to force printing of object arguments *) Definition is_univalent (C : category) := ∏ (a b : ob C), isweq (fun p : a = b => idtoiso p). (* Definition make_is_univalent {C : precategory} (H1 : ∏ (a b : ob C), isweq (fun p : a = b => idtoiso p)) (H2 : has_homsets C) : is_univalent C := make_dirprod H1 H2. *) Lemma eq_idtoiso_idtomor {C:precategory} (a b:ob C) (e:a = b) : pr1 (idtoiso e) = idtomor _ _ e. Proof. destruct e; reflexivity. Defined. Lemma isaprop_is_univalent (C : category) : isaprop (is_univalent C). Proof. apply impred. intro a. apply impred. intro b. apply isapropisweq. Qed. Definition univalent_category : UU := ∑ C : category, is_univalent C. Definition make_univalent_category (C : category) (H : is_univalent C) : univalent_category := tpair _ C H. Coercion univalent_category_to_category (C : univalent_category) : category := pr1 C. Coercion univalent_category_has_homsets (C : univalent_category) : has_homsets C := pr2 (pr1 C). Definition univalent_category_is_univalent (C : univalent_category) : is_univalent C := pr2 C. Lemma univalent_category_has_groupoid_ob (C : univalent_category): isofhlevel 3 (ob C). Proof. change (isofhlevel 3 C) with (∏ a b : C, isofhlevel 2 (a = b)). intros a b. apply (isofhlevelweqb _ (tpair _ _ (pr2 C a b))). apply isaset_z_iso. Qed. (** ** Definition of [isotoid] *) Definition isotoid (C : category) (H : is_univalent C) {a b : ob C}: z_iso a b -> a = b := invmap (make_weq _ (H a b)). Lemma idtoiso_isotoid (C : category) (H : is_univalent C) (a b : ob C) (f : z_iso a b) : idtoiso (isotoid _ H f) = f. Proof. unfold isotoid. set (Hw := homotweqinvweq (make_weq idtoiso (H a b))). simpl in Hw. apply Hw. Qed. Lemma isotoid_idtoiso (C : category) (H : is_univalent C) (a b : ob C) (p : a = b) : isotoid _ H (idtoiso p) = p. Proof. unfold isotoid. set (Hw := homotinvweqweq (make_weq idtoiso (H a b))). simpl in Hw. apply Hw. Qed. (** ** Properties of [idtoiso] and [isotoid] *) Definition double_transport {C : precategory_ob_mor} {a a' b b' : ob C} (p : a = a') (q : b = b') (f : a --> b) : a' --> b' := transportf (λ c, a' --> c) q (transportf (λ c, c --> b) p f). Lemma double_transport_transpose {C : precategory_ob_mor} {a a' b b' : C} {f : a --> b} {g : a' --> b'} {px : a' = a} {py : b' = b} : double_transport px py g = f -> g = double_transport (!px) (!py) f. Proof. intro H. destruct H. destruct px, py. reflexivity. Qed. Lemma double_transport_transpose' {C : precategory_ob_mor} {a a' b b' : C} {f : a' --> b'} {g : a --> b} {px : a' = a} {py : b' = b} : f = double_transport (!px) (!py) g -> double_transport px py f = g. Proof. intro H. destruct (!H). destruct px, py. reflexivity. Qed. Lemma double_transport_compose {C : precategory} {a a' b b' c c' : C} {f : a --> b} {g : b --> c} {px : a = a'} {py : b = b'} {pz : c = c'} : double_transport px py f · double_transport py pz g = double_transport px pz (f · g). Proof. unfold double_transport. destruct px, py, pz. reflexivity. Qed. Lemma idtoiso_postcompose (C : precategory) (a b b' : ob C) (p : b = b') (f : a --> b) : f · idtoiso p = transportf (λ b, a --> b) p f. Proof. destruct p. apply id_right. Qed. Lemma idtoiso_postcompose_iso (C : category) (a b b' : ob C) (p : b = b') (f : z_iso a b) : z_iso_comp f (idtoiso p) = transportf (λ b, z_iso a b) p f. Proof. destruct p. apply z_iso_eq. apply id_right. Qed. Lemma idtoiso_precompose (C : precategory) (a a' b : ob C) (p : a = a') (f : a --> b) : (idtoiso (!p)) · f = transportf (λ a, a --> b) p f. Proof. destruct p. apply id_left. Qed. Lemma idtoiso_precompose_iso (C : category) (a a' b : ob C) (p : a = a') (f : z_iso a b) : z_iso_comp (idtoiso (!p)) f = transportf (λ a, z_iso a b) p f. Proof. destruct p. apply z_iso_eq. apply id_left. Qed. Lemma double_transport_idtoiso (C : precategory) (a a' b b' : ob C) (p : a = a') (q : b = b') (f : a --> b) : double_transport p q f = inv_from_z_iso (idtoiso p) · f · idtoiso q. Proof. destruct p. destruct q. intermediate_path (identity _ · f). - apply pathsinv0; apply id_left. - apply pathsinv0; apply id_right. Defined. Lemma idtoiso_inv (C : category) (a a' : ob C) (p : a = a') : idtoiso (!p) = z_iso_inv_from_z_iso (idtoiso p). Proof. destruct p. simpl. apply z_iso_eq. apply idpath. Defined. Lemma idtoiso_concat (C : category) (a a' a'' : ob C) (p : a = a') (q : a' = a'') : idtoiso (p @ q) = z_iso_comp (idtoiso p) (idtoiso q). Proof. destruct p. destruct q. apply z_iso_eq. simpl; apply pathsinv0, id_left. Qed. Definition pr1_idtoiso_concat {C : category} {x y z : C} (f : x = y) (g : y = z) : pr1 (idtoiso (f @ g)) = pr1 (idtoiso f) · pr1 (idtoiso g). Proof. exact (maponpaths pr1 (idtoiso_concat _ _ _ _ f g)). Qed. Lemma idtoiso_inj (C : category) (H : is_univalent C) (a a' : ob C) (p p' : a = a') : idtoiso p = idtoiso p' -> p = p'. Proof. apply invmaponpathsincl. apply isinclweq. apply H. Qed. Lemma isotoid_inj (C : category) (H : is_univalent C) (a a' : ob C) (f f' : z_iso a a') : isotoid _ H f = isotoid _ H f' -> f = f'. Proof. apply invmaponpathsincl. apply isinclweq. apply isweqinvmap. Qed. Lemma isotoid_comp (C : category) (H : is_univalent C) (a b c : ob C) (e : z_iso a b) (f : z_iso b c) : isotoid _ H (z_iso_comp e f) = isotoid _ H e @ isotoid _ H f. Proof. apply idtoiso_inj. assumption. rewrite idtoiso_concat. repeat rewrite idtoiso_isotoid. apply idpath. Qed. Lemma isotoid_identity_iso (C : category) (H : is_univalent C) (a : C) : isotoid _ H (identity_z_iso a) = idpath _ . Proof. apply idtoiso_inj; try assumption. rewrite idtoiso_isotoid; apply idpath. Qed. Lemma inv_isotoid (C : category) (H : is_univalent C) (a b : C) (f : z_iso a b) : ! isotoid _ H f = isotoid _ H (z_iso_inv_from_z_iso f). Proof. apply idtoiso_inj; try assumption. rewrite idtoiso_isotoid. rewrite idtoiso_inv. rewrite idtoiso_isotoid. apply idpath. Qed. Lemma transportf_isotoid (C : category) (H : is_univalent C) (a a' b : ob C) (p : z_iso a a') (f : a --> b) : transportf (λ a0 : C, a0 --> b) (isotoid C H p) f = inv_from_z_iso p · f. Proof. rewrite <- idtoiso_precompose. rewrite idtoiso_inv. rewrite idtoiso_isotoid. apply idpath. Qed. Lemma transportf_isotoid' (C : category) (H : is_univalent C) (a b b' : ob C) (p : z_iso b b') (f : a --> b) : transportf (λ a0 : C, a --> a0) (isotoid C H p) f = f · p. Proof. rewrite <- idtoiso_postcompose. apply maponpaths. rewrite idtoiso_isotoid. apply idpath. Qed. Lemma transportb_isotoid (C : category) (H : is_univalent C) (a b b' : ob C) (p : z_iso b b') (f : a --> b') : transportb (λ b0 : C, a --> b0) (isotoid C H p) f = f · inv_from_z_iso p. Proof. apply pathsinv0. apply transportb_transpose_right. change (precategory_morphisms a) with (λ b0 : C, a --> b0). rewrite transportf_isotoid'. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. Qed. Lemma transportf_isotoid_dep (C : precategory) (a a' : C) (p : a = a') (f : ∏ c, a --> c) : transportf (λ x : C, ∏ c, x --> c) p f = λ c, idtoiso (!p) · f c. Proof. destruct p. simpl. apply funextsec. intro. rewrite id_left. apply idpath. Qed. Lemma forall_isotoid (A : category) (a_is : is_univalent A) (a a' : A) (P : z_iso a a' -> UU) : (∏ e, P (idtoiso e)) → ∏ i, P i. Proof. intros H i. rewrite <- (idtoiso_isotoid _ a_is). apply H. Defined. Lemma transportf_isotoid_dep' (J : UU) (C : precategory) (F : J -> C) (a a' : C) (p : a = a') (f : ∏ c, a --> F c) : transportf (λ x : C, ∏ c, x --> F c) p f = λ c, idtoiso (!p) · f c. Proof. now destruct p; apply funextsec; intro x; rewrite id_left. Defined. (* This and the above name is not very good... *) Lemma transportf_isotoid_dep'' (J : UU) (C : precategory) (F : J -> C) (a a' : C) (p : a = a') (f : ∏ c, F c --> a) : transportf (λ x : C, ∏ c, F c --> x) p f = λ c, f c · idtoiso p. Proof. now destruct p; apply funextsec; intro x; rewrite id_right. Defined. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/000077500000000000000000000000001451125700300230235ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/CatIso.v000066400000000000000000000023301451125700300243720ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.CategoryEquality. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Local Open Scope cat. Definition daggercatiso (C D : dagger_category) : UU := ∑ i : catiso C D, is_dagger_functor C D i. Definition daggercatiso_is_path_cat (C D : dagger_category) : C = D ≃ daggercatiso C D. Proof. refine (_ ∘ total2_paths_equiv _ _ _)%weq. apply (weqbandf (catiso_is_path_cat (pr1 C) (pr1 D))). induction C as [C dagC]. induction D as [D dagD]. intro p. use weqimplimpl. - intro q. simpl in p ; induction p. cbn in q ; induction q. intros x y f ; apply idpath. - intro q. simpl in p ; induction p. simpl in q. apply dagger_equality. apply funextsec ; intro x. apply funextsec ; intro y. apply funextsec ; intro f. exact (q x y f). - apply isaset_dagger. - apply isaprop_is_dagger_functor. Defined. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Categories.v000066400000000000000000000103101451125700300252720ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Section DaggerCategories. Definition dagger_structure (C : category) : UU := ∏ x y : C, C⟦x,y⟧ → C⟦y,x⟧. Identity Coercion dagger_structure_to_family_of_morphisms : dagger_structure >-> Funclass. Lemma isaset_dagger_structure (C : category) : isaset (dagger_structure C). Proof. do 2 (apply impred_isaset ; intro). apply funspace_isaset. apply homset_property. Qed. Definition dagger_law_id {C : category} (dag : dagger_structure C) : UU := ∏ x : C, dag x x (identity x) = identity x. Definition dagger_law_comp {C : category} (dag : dagger_structure C) : UU := ∏ (x y z : C) (f: C⟦x,y⟧) (g : C⟦y,z⟧), dag x z (f · g) = dag y z g · dag x y f. Definition dagger_law_idemp {C : category} (dag : dagger_structure C) : UU := ∏ (x y : C) (f : C⟦x,y⟧), dag y x (dag x y f) = f. Definition dagger_laws {C : category} (dag : dagger_structure C) : UU := dagger_law_id dag × dagger_law_comp dag × dagger_law_idemp dag. Lemma isaprop_dagger_laws {C : category} (dag : dagger_structure C) : isaprop (dagger_laws dag). Proof. repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply homset_property. Qed. Definition dagger (C : category) : UU := ∑ d : dagger_structure C, dagger_laws d. Definition dagger_to_struct {C : category} (dag : dagger C) : dagger_structure C := pr1 dag. Coercion dagger_to_struct : dagger >-> dagger_structure. Definition dagger_to_laws {C : category} (dag : dagger C) : dagger_laws dag := pr2 dag. Definition dagger_to_law_id {C : category} (dag : dagger C) : dagger_law_id dag := pr1 (dagger_to_laws dag). Definition dagger_to_law_comp {C : category} (dag : dagger C) : dagger_law_comp dag := pr12 (dagger_to_laws dag). Definition dagger_to_law_idemp {C : category} (dag : dagger C) : dagger_law_idemp dag := pr22 (dagger_to_laws dag). Lemma isaset_dagger (C : category) : isaset (dagger C). Proof. apply isaset_total2. - apply isaset_dagger_structure. - intro ; apply isasetaprop ; apply isaprop_dagger_laws. Qed. Lemma dagger_equality {C : category} (dag1 dag2 : dagger C) : dagger_to_struct dag1 = dagger_to_struct dag2 -> dag1 = dag2. Proof. intro p. apply (total2_paths_f p). apply isaprop_dagger_laws. Qed. Definition dagger_injective {C : category} (dag : dagger C) {x y : C} (f g : C⟦x,y⟧) : dag _ _ f = dag _ _ g -> f = g. Proof. intro p. refine (_ @ maponpaths (dag y x) p @ _). - apply pathsinv0, dagger_to_law_idemp. - apply dagger_to_law_idemp. Qed. Definition make_dagger_laws {C : category} {d : dagger_structure C} (lid : dagger_law_id d) (lcomp : dagger_law_comp d) (lidemp : dagger_law_idemp d) : dagger_laws d := lid ,, lcomp ,, lidemp. Definition dagger_category : UU := ∑ C : category, dagger C. Definition dagger_category_to_cat (C : dagger_category) : category := pr1 C. Coercion dagger_category_to_cat : dagger_category >-> category. Definition dagger_category_to_dagger (C : dagger_category) : dagger C := pr2 C. Coercion dagger_category_to_dagger : dagger_category >-> dagger. Notation "{ f }_ C ^†" := (dagger_category_to_dagger C _ _ f). Lemma dagger_category_equality (C1 C2 : dagger_category) : ∏ p : precategory_data_from_precategory C1 = precategory_data_from_precategory C2, (∏ x y : C2, ∏ f : C2⟦x,y⟧, pr1 (transportf dagger (category_eq C1 C2 p) C1) x y f = {f}_C2^†) -> C1 = C2. Proof. intros p q. use total2_paths_f. - exact (category_eq _ _ p). - use subtypePath. + intro ; apply isaprop_dagger_laws. + do 3 (apply funextsec ; intro). apply q. Defined. Definition make_dagger_category {C : category} {d : dagger_structure C} (dl : dagger_laws d) : dagger_category := C ,, d ,, dl. End DaggerCategories. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Examples/000077500000000000000000000000001451125700300246015ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Examples/Fullsub.v000066400000000000000000000030511451125700300264030ustar00rootroot00000000000000(* A full sub-category of a dagger category is again a dagger category. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Local Open Scope cat. Section Fullsub. Context {C : category} (dag : dagger C) (P : ob C -> hProp). Let CP := full_sub_category C P. Definition full_sub_dagger_structure : dagger_structure CP := λ x y f, dag _ _ (pr1 f) ,, tt. Lemma full_sub_dagger_laws : dagger_laws full_sub_dagger_structure. Proof. repeat split ; (intro ; intros ; use subtypePath ; [intro ; apply isapropunit | ]). - apply dagger_to_law_id. - apply dagger_to_law_comp. - apply dagger_to_law_idemp. Qed. Definition full_sub_dagger : dagger CP := _ ,, full_sub_dagger_laws. Lemma inclusion_is_dagger_functor : is_dagger_functor full_sub_dagger dag (sub_precategory_inclusion C (full_sub_precategory P)). Proof. intro ; intros ; apply idpath. Qed. End Fullsub. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Examples/Groupoids.v000066400000000000000000000074001451125700300267440ustar00rootroot00000000000000(* Any groupoid becomes a †-category by defining f^† := f^-1 Furthermore, a groupoid is dagger univalent if and only if it is univalent. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Local Open Scope cat. Section GroupoidsAsDaggers. Context (C : groupoid). Definition GRP_dagger_structure : dagger_structure C. Proof. intros x y f. exact (pr1 (z_iso_inv (_ ,, groupoid_is_pregroupoid C x y f))). Defined. Lemma GRP_dagger_laws : dagger_laws GRP_dagger_structure. Proof. repeat split ; intro ; intros ; use inverse_unique_precat. - exact (identity x). - apply groupoid_is_pregroupoid. - apply is_inverse_in_precat_identity. - exact (f · g). - apply groupoid_is_pregroupoid. - apply is_inverse_in_precat_comp ; apply groupoid_is_pregroupoid. - apply groupoid_is_pregroupoid ; exact f. - apply groupoid_is_pregroupoid. - apply is_inverse_in_precat_inv ; apply groupoid_is_pregroupoid. Qed. Definition GRP_dagger : dagger C := _ ,, GRP_dagger_laws. End GroupoidsAsDaggers. Section UnivalenceOfGroupoids. Context (C : groupoid). Definition univalence_to_dagger_univalence {x y : C} (f : z_iso x y) : unitary (GRP_dagger C) x y. Proof. exists (morphism_from_z_iso _ _ f). apply groupoid_is_pregroupoid. Defined. Definition dagger_univalence_to_univalence {x y : C} (f : unitary (GRP_dagger C) x y) : z_iso x y := make_z_iso _ _ (pr2 f). Definition z_iso_is_unitary (x y : C) : z_iso x y ≃ unitary (GRP_dagger C) x y. Proof. use weq_iso. - exact (λ p, univalence_to_dagger_univalence p). - exact (λ p, dagger_univalence_to_univalence p). - intro ; apply z_iso_eq, idpath. - intro ; apply unitary_eq, idpath. Defined. Lemma idtodagger_as_idtoiso_pointwise {x y : C} (p : x = y) : idtodaggeriso (GRP_dagger C) x y p = z_iso_is_unitary x y (idtoiso p). Proof. apply (unitary_eq (idtodaggeriso (GRP_dagger C) x y p) (univalence_to_dagger_univalence (idtoiso p))). induction p ; apply idpath. Defined. Lemma idtoiso_as_idtodagger_pointwise {x y : C} (p : x = y) : idtoiso p = dagger_univalence_to_univalence (idtodaggeriso (GRP_dagger C) x y p). Proof. apply (z_iso_eq (idtoiso p) (dagger_univalence_to_univalence (idtodaggeriso (GRP_dagger C) x y p))). induction p ; apply idpath. Defined. Definition groupoid_univalence_equiv_dagger_univalence : is_univalent C ≃ is_univalent_dagger (GRP_dagger C). Proof. use weqimplimpl. - intros u x y. apply (isweqhomot' (λ p, z_iso_is_unitary x y (idtoiso p))). + apply (twooutof3c (idtoiso (a := x) (b := y)) (z_iso_is_unitary x y)). * apply u. * apply z_iso_is_unitary. + apply (λ p, ! idtodagger_as_idtoiso_pointwise p). - intros u x y. apply (isweqhomot' (λ p, invweq (z_iso_is_unitary x y) (idtodaggeriso (GRP_dagger C) _ _ p))). + apply (twooutof3c (idtodaggeriso (GRP_dagger C) x y) (invweq (z_iso_is_unitary x y))). * apply u. * apply (invweq (z_iso_is_unitary _ _)). + apply (λ p, ! idtoiso_as_idtodagger_pointwise p). - apply isaprop_is_univalent. - apply isaprop_is_univalent_dagger. Qed. End UnivalenceOfGroupoids. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Examples/Relations.v000066400000000000000000000075021451125700300267340ustar00rootroot00000000000000(* The category of relations, i.e. the objects are sets and the morphisms are relations of sets, becomes a dagger category by taking the "opposite" relation. Furthermore, we show that it is dagger univalent. In order to do this, we show that the of isomorphisms is equivalent to type of dagger isomorphisms. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.Relations. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Local Open Scope cat. Section RelationsAsDaggers. Definition REL_dagger_structure : dagger_structure REL := λ _ _ f y x, f x y. Lemma REL_dagger_laws : dagger_laws REL_dagger_structure. Proof. repeat split ; intro ; intros ; repeat (apply funextsec ; intro) ; cbn. - use (invweq (weqeqweqhProp _ _)). use weqimplimpl. + exact (λ p, ! p). + exact (λ p, ! p). + apply eqset. + apply eqset. - use (invweq (weqeqweqhProp _ _)). use weqimplimpl. + intro p. use (factor_through_squash_hProp _ _ p). clear p ; intro p. apply hinhpr. exact (pr1 p ,, pr22 p ,, pr12 p). + intro p. use (factor_through_squash_hProp _ _ p). clear p ; intro p. apply hinhpr. exact (pr1 p ,, pr22 p ,, pr12 p). + apply isapropishinh. + apply isapropishinh. Qed. Definition REL_dagger : dagger REL := _ ,, REL_dagger_laws. End RelationsAsDaggers. Section DaggerIsosInREL. Context (X Y : REL). Definition z_iso_REL_equiv_dagger_z_iso : z_iso (C := REL) X Y ≃ unitary REL_dagger_structure X Y. Proof. apply weqfibtototal. intro r. apply weqimplimpl. - intro i. unfold is_unitary. unfold REL_dagger_structure. unfold is_inverse_in_precat. cbn. split ; do 2 (apply funextsec ; intro). + apply unique_image_to_inverse_law_in_REL. * apply is_z_iso_in_REL_to_unique_image. use (pr2 (is_z_iso_in_REL_simplified _)). split. -- exact (pr2 (pr1 (is_z_iso_in_REL_simplified r) i)). -- exact (pr1 (pr1 (is_z_iso_in_REL_simplified r) i)). * exact (is_z_iso_in_REL_to_unique_image _ i). + etrans. 2: { use (unique_image_to_inverse_law_in_REL (r := pr1 i)). - exact (pr2 (pr1 (is_z_iso_in_REL_simplified _) (pr2 (z_iso_inv (r,,i))))). - apply (is_z_iso_in_REL_to_unique_image). exact (pr2 (z_iso_inv (r,,i))). } apply hPropUnivalence. * intro px. use (factor_through_squash_hProp _ _ px). clear px ; intro px. apply hinhpr. refine (pr1 px ,, _ ,, _) ; apply inverse_swap_relation, (pr2 px). * intro px. use (factor_through_squash_hProp _ _ px). clear px ; intro px. apply hinhpr. refine (pr1 px ,, _ ,, _) ; apply (inverse_swap_relation_iff i _ _), (pr2 px). - exact (λ i, _ ,, (i : is_inverse_in_precat _ _)). - apply isaprop_is_z_isomorphism. - apply isaprop_is_unitary. Defined. End DaggerIsosInREL. Section UnivalenceOfRelations. Lemma is_dagger_univalent_REL : is_univalent_dagger REL_dagger. Proof. intros X Y. use weqhomot. - exact (z_iso_REL_equiv_dagger_z_iso X Y ∘ make_weq _ (is_univalent_REL X Y))%weq. - intro p ; induction p. use unitary_eq. do 2 (apply funextsec ; intro). apply idpath. Qed. End UnivalenceOfRelations. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/FunctorCategory.v000066400000000000000000000350561451125700300263410ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Transformations. Local Open Scope cat. Local Lemma equality_on_objects_from_functor_equality {C D : category} (F G : functor_data C D) (p : ∏ c: C, F c = G c) (q : transportf (λ F : C → D, ∏ a b : C, C ⟦ a, b ⟧ → D ⟦ F a, F b ⟧) (funextsec (λ _ : C, D) (pr1 F) (pr1 G) (λ x : C, p x)) (pr2 F) = pr2 G) : ∏ c : C, toforallpaths (λ _ : C, D) F G (base_paths F G (total2_paths_f ((funextsec (λ _ : C, D) (pr1 F) (pr1 G) (λ x : C, p x))) q)) c = p c. Proof. intro c. rewrite base_total2_paths. now rewrite toforallpaths_funextsec. Qed. Local Definition functor_eq_eq_from_functor_ob_eq' (C C': category) (F G : functor C C') (p q : pr1 F = pr1 G) (H : (base_paths _ _ p) = (base_paths _ _ q)) : p = q. Proof. apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl. use total2_paths_f. + exact H. + apply uip. do 2 (apply impred_isaset ; intro). apply funspace_isaset. apply C'. Defined. Section DaggerFunctorCategories. Context {C D : category} (dagC : dagger C) (dagD : dagger D). Definition dagger_functor_disp_cat : disp_cat (functor_category C D) := disp_full_sub [C,D] (λ F, is_dagger_functor dagC dagD F). Definition dagger_functor_cat : category := total_category dagger_functor_disp_cat. Definition make_dagger_functor {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : dagger_functor_cat := F ,, dagF. Definition make_dagger_transformation (F G : dagger_functor_cat) (α : nat_trans (pr1 F : functor _ _) (pr1 G : functor _ _)) : dagger_functor_cat⟦F,G⟧ := α ,, tt. Definition dagger_functor_cat_structure : dagger_structure dagger_functor_cat := λ F G α, make_dagger_transformation _ _ (dagger_adjoint (pr2 F) (pr2 G) (pr1 α)). Lemma dagger_transformation_equality {F G : functor C D} {dagF : is_dagger_functor dagC dagD F} {dagG : is_dagger_functor dagC dagD G} (α β : dagger_functor_cat⟦make_dagger_functor dagF , make_dagger_functor dagG⟧) : (∏ x : C, pr11 α x = pr11 β x) -> α = β. Proof. intro p. use subtypePath. { intro ; apply isapropunit. } apply (nat_trans_eq D). exact p. Qed. Lemma dagger_functor_cat_laws : dagger_laws dagger_functor_cat_structure. Proof. (*use make_dagger_laws*) repeat split ; (intro ; intros ; apply dagger_transformation_equality ; intro). - apply dagger_to_law_id. - apply dagger_to_law_comp. - apply dagger_to_law_idemp. Qed. Definition dagger_on_functor_cat : dagger dagger_functor_cat := _ ,, dagger_functor_cat_laws. End DaggerFunctorCategories. Section Univalence. Context {C D : category} {dagC : dagger C} {dagD : dagger D} {F G : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G). Local Definition unitary_functors_eq : UU := ∑ p : (∏ x : pr11 C, unitary dagD (F x) (G x)), ∏ (x y : C) (f : C⟦x,y⟧), #G f = (dagD _ _ (pr1 (p x))) · #F f · (pr1 (p y)). Local Definition functors_eq_data : UU := ∑ p : (∏ x : C, (pr11 F x) = (pr11 G x)), ∏ (x y : pr11 C) (f : (pr11 C)⟦x,y⟧), #G f = idtodaggermor dagD (! p x) · #F f · idtodaggermor dagD (p y). Definition unitary_functors_equiv_unitary : unitary_functors dagF dagG ≃ unitary (dagger_functor_cat_structure dagC dagD) (F,,dagF) (G,,dagG). Proof. use weq_iso. - intro α. exists (make_dagger_transformation dagC dagD _ _ (pr1 α : nat_trans (pr1 (F,,dagF)) (pr1 (G,,dagG)))). abstract (split ; apply dagger_transformation_equality ; intro c ; apply (pr2 α c)). - intro α. exists (pr11 α). abstract ( intro c ; split ; [ exact (eqtohomot (base_paths _ _ (base_paths _ _ (pr12 α))) c) | exact (eqtohomot (base_paths _ _ (base_paths _ _ (pr22 α))) c) ]). - abstract ( intro α ; use total2_paths_f ; [ use (nat_trans_eq (pr2 D)) ; intro ; apply idpath | use proofirrelevance ; apply impred_isaprop ; intro ; apply Isos.isaprop_is_inverse_in_precat]). - abstract ( intro α ; use total2_paths_f ; [ apply dagger_transformation_equality ; intro ; apply idpath | apply isaprop_is_unitary]). Defined. Lemma unitary_functor_eq_to_unitary_functors_naturality (p : unitary_functors_eq) : is_nat_trans F G (λ c : pr11 C, pr1 (pr1 p c)). Proof. intros c1 c2 f. refine (_ @ maponpaths (compose _) (! pr2 p _ _ _)). refine (_ @ assoc' _ _ _). apply maponpaths_2. refine (_ @ assoc' _ _ _). refine (! id_left _ @ _). apply maponpaths_2, pathsinv0, (pr1 p). Qed. Definition unitary_functors_eq_to_unitary_functors : unitary_functors_eq -> unitary_functors dagF dagG. Proof. intros [p q]. use tpair. - apply (make_nat_trans _ _ (λ c, pr1 (p c))). exact (unitary_functor_eq_to_unitary_functors_naturality (p,,q)). - abstract (intro ; apply p). Defined. Lemma unitary_functors_eq_from_unitary_functors_naturality (α : unitary_functors dagF dagG) : ∏ (x y : C) (f : C ⟦ x, y ⟧), # G f = dagD (F x) (G x) ((pr1 α) x) · # F f · (pr1 α) y. Proof. intros c1 c2 f. apply pathsinv0. refine (assoc' _ _ _ @ _). refine (maponpaths (compose _) (pr21 α _ _ _) @ _). refine (assoc _ _ _ @ _). refine (_ @ id_left _). apply maponpaths_2, (pr2 α). Qed. Definition unitary_functors_eq_from_unitary_functors : unitary_functors dagF dagG -> unitary_functors_eq. Proof. intros [α p]. use tpair. + intro c. exists (α c). apply p. + exact (unitary_functors_eq_from_unitary_functors_naturality (α,,p)). Defined. Lemma unitary_functors_eq_equiv_unitary_functors_inv_law1 : ∏ x : unitary_functors_eq, unitary_functors_eq_from_unitary_functors (unitary_functors_eq_to_unitary_functors x) = x. Proof. intro. use total2_paths_f. - apply funextsec ; intro. apply unitary_eq, idpath. - repeat (apply funextsec ; intro). apply homset_property. Qed. Lemma unitary_functors_eq_equiv_unitary_functors_inv_law2 : ∏ y : unitary_functors dagF dagG, unitary_functors_eq_to_unitary_functors (unitary_functors_eq_from_unitary_functors y) = y. Proof. intro. use total2_paths_f. - use (nat_trans_eq (pr2 D)). intro ; apply idpath. - apply funextsec ; intro. apply Isos.isaprop_is_inverse_in_precat. Qed. Definition unitary_functors_eq_equiv_unitary_functors : unitary_functors_eq ≃ unitary_functors dagF dagG. Proof. use weq_iso. - exact unitary_functors_eq_to_unitary_functors. - exact unitary_functors_eq_from_unitary_functors. - exact unitary_functors_eq_equiv_unitary_functors_inv_law1. - exact unitary_functors_eq_equiv_unitary_functors_inv_law2. Defined. Definition functors_eq_data_to_unitary_functors_eq (u : is_univalent_dagger dagD) : functors_eq_data -> unitary_functors_eq. Proof. intro p. exists (λ c, idtodaggeriso dagD _ _ (pr1 p c)). intros x y f. refine (pr2 p x y f @ _). do 2 apply maponpaths_2. etrans. { apply (idtodaggeriso_is_dagger_of_idtodaggeriso dagD). } do 3 apply maponpaths. apply pathsinv0inv0. Defined. Definition functors_eq_data_from_unitary_functors_eq (u : is_univalent_dagger dagD) : unitary_functors_eq -> functors_eq_data. Proof. intros p. use tpair. - intro c ; apply u ; exact (pr1 p c). - intros x y f. refine (pr2 p x y f @ _). apply maponpaths_compose. + apply maponpaths_2. refine (_ @ ! idtodaggeriso_is_dagger_of_idtodaggeriso dagD _). do 2 apply maponpaths. etrans. * apply pathsinv0, (idtodaggeriso_daggerisotoid u). * apply maponpaths, pathsinv0, pathsinv0inv0. + apply pathsinv0, idtodaggermor_daggerisotoid. Defined. Lemma functors_eq_data_equiv_unitary_functors_eq_inv_law1 (u : is_univalent_dagger dagD) : ∏ x : functors_eq_data, functors_eq_data_from_unitary_functors_eq u (functors_eq_data_to_unitary_functors_eq u x) = x. Proof. intro p. use total2_paths_f. - apply funextsec ; intro. apply daggerisotoid_idtodaggeriso. - repeat (apply funextsec ; intro). apply homset_property. Qed. Lemma functors_eq_data_equiv_unitary_functors_eq_inv_law2 (u : is_univalent_dagger dagD) : ∏ y : unitary_functors_eq, functors_eq_data_to_unitary_functors_eq u (functors_eq_data_from_unitary_functors_eq u y) = y. Proof. intro p. use total2_paths_f. - apply funextsec ; intro. use total2_paths_f. + apply maponpaths, idtodaggeriso_daggerisotoid. + apply isaprop_is_unitary. - repeat (apply funextsec ; intro). apply homset_property. Qed. Definition functors_eq_data_equiv_unitary_functors_eq (u : is_univalent_dagger dagD) : functors_eq_data ≃ unitary_functors_eq. Proof. use weq_iso. - exact (functors_eq_data_to_unitary_functors_eq u). - exact (functors_eq_data_from_unitary_functors_eq u). - exact (functors_eq_data_equiv_unitary_functors_eq_inv_law1 u). - exact (functors_eq_data_equiv_unitary_functors_eq_inv_law2 u). Defined. Lemma transport_of_dagger_functor_map_is_pointwise (F0 G0 : pr11 C -> pr11 D) (F1 : ∏ a b : pr11 C, a --> b -> F0 a --> F0 b) (gamma : F0 = G0 ) (a b : pr11 C) (f : a --> b) : transportf (fun x : pr11 C -> pr11 D => ∏ a0 b0 : pr11 C, a0 --> b0 -> x a0 --> x b0) gamma F1 a b f = Univalence.double_transport (toforallpaths (λ _ : pr11 C, pr11 D) F0 G0 gamma a) (toforallpaths (λ _ : pr11 C, pr11 D) F0 G0 gamma b) (F1 a b f). Proof. induction gamma. apply idpath. Qed. Lemma double_transport_idtodaggeriso (a a' b b' : pr111 D) (p : a = a') (q : b = b') (f : a --> b) : Univalence.double_transport p q f = pr1 (idtodaggeriso dagD _ _ (! p)) · f · pr1 (idtodaggeriso dagD _ _ q). Proof. destruct p. destruct q. intermediate_path (identity _ · f). - apply pathsinv0; apply id_left. - apply pathsinv0; apply id_right. Qed. Definition equality_to_functors_eq_data : pr1 F = pr1 G -> functors_eq_data. Proof. intro p. exists (λ c, eqtohomot (base_paths _ _ p) c). abstract ( intros x y f ; refine (! eqtohomot (eqtohomot (eqtohomot (fiber_paths p) x) y) f @ _) ; etrans ; [ apply transport_of_dagger_functor_map_is_pointwise | apply double_transport_idtodaggeriso] ). Defined. Definition equality_from_functors_eq_data : functors_eq_data → pr1 F = pr1 G. Proof. intros [p q]. use total2_paths_f. - apply funextsec ; intro ; apply p. - abstract( repeat (apply funextsec ; intro) ; rewrite transport_of_dagger_functor_map_is_pointwise ; rewrite double_transport_idtodaggeriso ; rewrite toforallpaths_funextsec ; exact (! q _ _ _) ). Defined. Lemma equality_equiv_functors_eq_data_inv_law1 : ∏ x : pr1 F = pr1 G, equality_from_functors_eq_data (equality_to_functors_eq_data x) = x. Proof. intro. apply functor_eq_eq_from_functor_ob_eq'. refine (base_total2_paths _ @ _). apply (invmaponpathsweq (weqtoforallpaths _ _ _)). simpl. rewrite toforallpaths_funextsec. apply funextsec; intro ; apply idpath. Qed. Lemma equality_equiv_functors_eq_data_inv_law2 : ∏ y : functors_eq_data, equality_to_functors_eq_data (equality_from_functors_eq_data y) = y. Proof. intros [p q]. use total2_paths_f. - apply funextsec ; intro. apply equality_on_objects_from_functor_equality. - apply proofirrelevance. do 3 (apply impred_isaprop ; intro). apply homset_property. Qed. Definition equality_equiv_functors_eq_data : pr1 F = pr1 G ≃ functors_eq_data. Proof. use weq_iso. - exact equality_to_functors_eq_data. - exact equality_from_functors_eq_data. - exact equality_equiv_functors_eq_data_inv_law1. - exact equality_equiv_functors_eq_data_inv_law2. Defined. Local Definition id_pr1_to_pr11_id : F = G ≃ pr1 F = pr1 G. Proof. use subtypeInjectivity. intro. apply isaprop_is_functor. apply (pr2 D). Defined. Local Definition id_to_pr1_id : (F,,dagF) = (G,,dagG) ≃ F = G. Proof. use subtypeInjectivity. intro. apply isaprop_is_dagger_functor. Defined. Local Definition univalence_iso (u : is_univalent_dagger dagD) : (F,,dagF) = (G,,dagG) ≃ unitary (dagger_functor_cat_structure dagC dagD) (F,, dagF) (G,, dagG). Proof. refine (_ ∘ id_to_pr1_id)%weq. refine (_ ∘ id_pr1_to_pr11_id)%weq. refine (_ ∘ equality_equiv_functors_eq_data)%weq. refine (_ ∘ functors_eq_data_equiv_unitary_functors_eq u)%weq. refine (_ ∘ unitary_functors_eq_equiv_unitary_functors)%weq. exact unitary_functors_equiv_unitary. Defined. End Univalence. Lemma dagger_functor_cat_is_dagger_univalent {C D : category} (dagC : dagger C) (dagD : dagger D) (u : is_univalent_dagger dagD) : is_univalent_dagger (dagger_on_functor_cat dagC dagD). Proof. intros F G. use weqhomot. - exact (univalence_iso (pr2 F) (pr2 G) u). - intro p. induction p. use subtypePath. { intro ; apply isaprop_is_unitary. } use subtypePath. { intro ; apply isapropunit. } apply (nat_trans_eq (pr2 D)). intro ; apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors.v000066400000000000000000000052321451125700300250170ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Local Open Scope cat. Section DaggerFunctors. Definition is_dagger_functor {C D : category} (dagC : dagger C) (dagD : dagger D) (F : functor C D) : UU := ∏ (x y : C) (f : C⟦x,y⟧), #F (dagC _ _ f) = dagD _ _ (#F f). Identity Coercion is_dagger_functor_to_family_of_equalities : is_dagger_functor >-> Funclass. Lemma isaprop_is_dagger_functor {C D : category} (dagC : dagger C) (dagD : dagger D) (F : functor C D) : isaprop (is_dagger_functor dagC dagD F). Proof. repeat (apply impred_isaprop ; intro) ; apply homset_property. Qed. Definition dagger_functor_id {C : category} (dag : dagger C) : is_dagger_functor dag dag (functor_identity C). Proof. intro ; intros ; apply idpath. Qed. Definition is_dagger_functor_comp {C D E : category} {dagC : dagger C} {dagD : dagger D} {dagE : dagger E} {F : functor C D} {G : functor D E} (dF : is_dagger_functor dagC dagD F) (dG : is_dagger_functor dagD dagE G) : is_dagger_functor dagC dagE (functor_composite F G). Proof. intros x y f. refine (maponpaths #G (dF _ _ _) @ _). apply dG. Qed. Definition dagger_functor {C D : category} (dagC : dagger C) (dagD : dagger D) : UU := ∑ F : functor C D, is_dagger_functor dagC dagD F. Lemma dagger_functor_equality {C D : category} {dagC : dagger C} {dagD : dagger D} (F G : dagger_functor dagC dagD) : pr11 F = pr11 G -> F = G. Proof. intro p. use subtypePath. { intro ; apply isaprop_is_dagger_functor. } use (functor_eq _ _ (homset_property D)). exact p. Defined. Definition dagger_functor_to_functor {C D : category} {dagC : dagger C} {dagD : dagger D} (F : dagger_functor dagC dagD) : functor C D := pr1 F. Coercion dagger_functor_to_functor : dagger_functor >-> functor. Definition dagger_functor_to_is_dagger_functor {C D : category} {dagC : dagger C} {dagD : dagger D} (F : dagger_functor dagC dagD) : is_dagger_functor dagC dagD F := pr2 F. Definition make_dagger_functor {C D : category} {F : functor C D} {dagC : dagger C} {dagD : dagger D} (dagF : is_dagger_functor dagC dagD F) : dagger_functor dagC dagD := F ,, dagF. End DaggerFunctors. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors/000077500000000000000000000000001451125700300246265ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors/Factorization.v000066400000000000000000000106131451125700300276320ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Functors.WeakEquivalences. Require Import UniMath.CategoryTheory.DaggerCategories.Examples.Fullsub. Local Open Scope cat. Section ImageFactorization. Context {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F). Definition is_in_dagger_img_functor (d : D) : hProp := ∃ c : C, unitary dagD (F c) d. Let P := (λ d : D, is_in_dagger_img_functor d). Definition full_dagger_img : category := full_sub_category D P. (* This definition is currently 'standalone' in this file (or however you say that it doesn't have any impact on the rest of this file. However, this I have already added this for future work when trying to compare multiple (whatever) factorization systems on DAG. *) Definition full_dagger_img_to_full_img : functor (full_sub_category D P) (full_sub_category D (λ d : D, is_in_img_functor F d)). Proof. use full_sub_category_functor. - exact (functor_identity D). - intros d in_dag_im. use (factor_through_squash_hProp _ _ in_dag_im). clear in_dag_im ; intro in_dag_im. apply hinhpr. exists (pr1 in_dag_im). exact (make_z_iso _ _ (pr22 in_dag_im)). Defined. Definition full_img_dagger : dagger full_dagger_img := full_sub_dagger dagD P. Definition full_dagger_img_functor_obj : ob C -> full_dagger_img. Proof. intro c. exists (F c). intros a b. apply b. exists c. apply unitary_id. Defined. Definition full_dagger_img_functor_data : functor_data C full_dagger_img. Proof. exists full_dagger_img_functor_obj. exact (λ a b f, #F f ,, tt). Defined. Lemma is_functor_full_dagger_img : is_functor full_dagger_img_functor_data. Proof. split. - intro ; apply subtypePath. { intro; apply isapropunit. } apply functor_id. - intro ; intros ; apply subtypePath. { intro ; apply isapropunit. } apply functor_comp. Qed. Definition functor_full_dagger_img : functor C full_dagger_img := _ ,, is_functor_full_dagger_img. Definition functor_full_img_is_dagger_functor : is_dagger_functor dagC full_img_dagger functor_full_dagger_img. Proof. intro ; intros ; use subtypePath ; [intro ; apply isapropunit | ]. apply dagF. Qed. Lemma functor_full_img_is_unitarily_eso : is_unitarily_eso functor_full_img_is_dagger_functor. Proof. intro d. use (factor_through_squash_hProp _ _ (pr2 d)). intro c. apply hinhpr. exists (pr1 c). exists (pr12 c ,, tt). split ; (use subtypePath ; [intro ; apply isapropunit |]) ; apply (pr2 c). Qed. Definition factorization_full_dagger_inclusion_equal : functor_full_dagger_img ∙ sub_precategory_inclusion D (full_sub_precategory P) = F. Proof. apply (functor_eq _ _ (pr2 D)). apply idpath. Defined. Definition dagger_functor_dagger_img_factorization : ∑ (I : category) (dagI : dagger I) (F0 : functor C I) (F1 : functor I D) (dagF0 : is_dagger_functor dagC dagI F0) (dagF1 : is_dagger_functor dagI dagD F1), is_unitarily_eso dagF0 × fully_faithful F1 × functor_composite F0 F1 = F. Proof. exists full_dagger_img. exists full_img_dagger. exists functor_full_dagger_img. exists (sub_precategory_inclusion D (full_sub_precategory P)). exists functor_full_img_is_dagger_functor. exists (inclusion_is_dagger_functor _ _). exists functor_full_img_is_unitarily_eso. exists (fully_faithful_sub_precategory_inclusion _ _). apply factorization_full_dagger_inclusion_equal. Defined. End ImageFactorization. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors/FullyFaithful.v000066400000000000000000000117061451125700300276000ustar00rootroot00000000000000(* In this file, we have formalized the result that a fully faithful functor into a dagger category induces a unique dagger on the domain such that the functor is dagger preserving. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Local Open Scope cat. Local Lemma functor_on_fully_faithful_inv_hom {C D : category} {F : functor C D} (ff : fully_faithful F) : ∏ (x y : C) (f : D⟦F x, F y⟧), # F (fully_faithful_inv_hom ff x y f) = f. Proof. intros x y f. set (fandf := fully_faithful_implies_full_and_faithful _ _ _ ff). set (fu := pr1 fandf). set(f_f := fu x y f). transparent assert (pp : hProp). { exists (# F (fully_faithful_inv_hom ff x y f) = f). apply homset_property. } use (factor_through_squash_hProp pp _ f_f). clear f_f ; intro f_f. refine (_ @ pr2 f_f). apply (maponpaths (# F)). refine (_ @ homotinvweqweq (weq_from_fully_faithful ff x y) (pr1 f_f)). apply maponpaths. exact (! (pr2 f_f)). Qed. Lemma fully_faithful_reflects_is_unitary {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) (ff : fully_faithful F) : ∏ c c' : C, ∏ f : C⟦c,c'⟧, is_unitary dagD (#F f) -> is_unitary dagC f. Proof. intros c c' f u. set (i := pr2 (fully_faithful_reflects_iso_proof _ _ _ ff c c' (Isos.make_z_iso _ _ u))). cbn in i. split. - refine (_ @ pr1 i). use maponpaths_compose. + apply pathsinv0, homotinvweqweq. + refine (! homotinvweqweq (weq_from_fully_faithful ff c' c) (dagC _ _ f) @ _). apply maponpaths. apply dagF. - refine (_ @ pr2 i). use maponpaths_compose. + refine (! homotinvweqweq (weq_from_fully_faithful ff c' c) (dagC _ _ f) @ _). apply maponpaths. apply dagF. + apply pathsinv0, homotinvweqweq. Qed. Lemma fully_faithful_reflects_unitary {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) (ff : fully_faithful F) : ∏ c c' : C, unitary dagD (F c) (F c') -> unitary dagC c c'. Proof. intros c c' u. exists (fully_faithful_inv_hom ff c c' (pr1 u)). apply (fully_faithful_reflects_is_unitary dagF ff c c' (fully_faithful_inv_hom ff c c' (pr1 u))). set (p := ! maponpaths (is_unitary dagD) (functor_on_fully_faithful_inv_hom ff _ _ (pr1 u))). exact (path_to_fun p (pr2 u)). Defined. Section FullyFaithful. Definition fully_faithful_reflect_dagger_structure {C D : category} {F : functor C D} (dagD : dagger D) (ff : fully_faithful F) : dagger_structure C. Proof. intros x y f. apply (fully_faithful_inv_hom ff y x). exact (pr1 dagD _ _ (#F f)). Defined. Definition fully_faithful_reflect_dagger_laws {C D : category} {F : functor C D} (dagD : dagger D) (ff : fully_faithful F) : dagger_laws (fully_faithful_reflect_dagger_structure dagD ff). Proof. repeat split ; intro ; intros ; use invmap_eq. - etrans. { apply maponpaths, functor_id. } etrans. { apply dagger_to_law_id. } apply pathsinv0, functor_id. - etrans. { apply maponpaths, functor_comp. } etrans. { apply dagger_to_law_comp. } etrans. { apply maponpaths, pathsinv0, (functor_on_fully_faithful_inv_hom ff). } refine (_ @ ! functor_comp _ _ _). apply maponpaths_2, pathsinv0, functor_on_fully_faithful_inv_hom. - etrans. { apply maponpaths, functor_on_fully_faithful_inv_hom. } apply dagger_to_law_idemp. Qed. Definition fully_faithful_reflect_dagger {C D : category} {F : functor C D} (dagD : dagger D) (ff : fully_faithful F) : dagger C := _ ,, fully_faithful_reflect_dagger_laws dagD ff. Definition fully_faithful_is_dagger_functor {C D : category} {F : functor C D} (dagD : dagger D) (ff : fully_faithful F) : is_dagger_functor (fully_faithful_reflect_dagger dagD ff) dagD F. Proof. intros x y f. apply functor_on_fully_faithful_inv_hom. Qed. Lemma fully_faithful_reflect_dagger_uniquely {C D : category} {F : functor C D} (dagD : dagger D) (ff : fully_faithful F) : ∃! dagC : dagger C, is_dagger_functor dagC dagD F. Proof. exists (fully_faithful_reflect_dagger dagD ff ,, fully_faithful_is_dagger_functor dagD ff). intro dag. use subtypePath. { intro ; apply isaprop_is_dagger_functor. } use subtypePath. { intro ; apply isaprop_dagger_laws. } do 3 (apply funextsec ; intro). apply pathsweq1. apply (pr2 dag). Defined. End FullyFaithful. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors/Precomp.v000066400000000000000000001156761451125700300264420ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Require Import UniMath.CategoryTheory.precomp_fully_faithful. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Transformations. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.FunctorCategory. Require Import UniMath.CategoryTheory.DaggerCategories.Functors.FullyFaithful. Require Import UniMath.CategoryTheory.DaggerCategories.Functors.WeakEquivalences. Local Open Scope cat. Definition dagger_functor_on_unitary {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : ∏ c c' : C, unitary dagC c c' -> unitary dagD (F c) (F c'). Proof. intros c c' u. exists (#F (pr1 u)). split. - refine (_ @ functor_id F _). refine (_ @ maponpaths (#F) (pr12 u)). refine (_ @ ! functor_comp F _ _). apply maponpaths. apply pathsinv0, dagF. - refine (_ @ functor_id F _). refine (_ @ maponpaths (#F) (pr22 u)). refine (_ @ ! functor_comp F _ _). apply maponpaths_2. apply pathsinv0, dagF. Defined. Definition dagger_functor_on_unitary_inv {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : ∏ c c' : C, ∏ u : unitary dagC c c', unitary_inv (dagger_functor_on_unitary dagF c c' u) = dagger_functor_on_unitary dagF _ _ (unitary_inv u). Proof. intro ; intros. unfold unitary_inv. use subtypePath. { intro ; apply isaprop_is_unitary. } apply pathsinv0, dagF. Defined. Definition dagger_functor_on_unitary_inv_on_ob {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : ∏ c c' : C, ∏ u : unitary dagC c c', pr1 (unitary_inv (dagger_functor_on_unitary dagF c c' u)) = #F (dagC _ _ u). Proof. intro ; intros. apply pathsinv0, dagF. Qed. Lemma dagger_of_idtodaggeriso {C : category} (dag : dagger C) {x y : C} (p : x = y) : pr1 dag _ _ (pr1 (idtodaggeriso dag _ _ p)) = pr1 (idtodaggeriso dag _ _ (! p)). Proof. induction p. apply dagger_to_law_id. Qed. Section Precomp_dagger_functor. Context {C D E : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagE : dagger E). Definition disp_dagger_pre_composition_functor_data : disp_functor_data (pre_composition_functor C D E F) (dagger_functor_disp_cat dagD dagE) (dagger_functor_disp_cat dagC dagE). Proof. exists (λ _ dagG, is_dagger_functor_comp dagF dagG). intro ; intros ; exact tt. Defined. Lemma disp_dagger_pre_composition_functor_laws : disp_functor_axioms disp_dagger_pre_composition_functor_data. Proof. repeat split ; intro ; intros ; apply isapropunit. Qed. Definition disp_dagger_pre_composition_functor : disp_functor (pre_composition_functor C D E F) (dagger_functor_disp_cat dagD dagE) (dagger_functor_disp_cat dagC dagE) := _ ,, disp_dagger_pre_composition_functor_laws. Definition dagger_pre_composition_functor : functor (dagger_functor_cat dagD dagE) (dagger_functor_cat dagC dagE) := total_functor (F := pre_composition_functor C D E F) disp_dagger_pre_composition_functor. Lemma dagger_pre_composition_functor_is_dagger_functor : is_dagger_functor (dagger_on_functor_cat dagD dagE) (dagger_on_functor_cat dagC dagE) dagger_pre_composition_functor. Proof. intro ; intros. use subtypePath. { intro ; apply isapropunit. } use (nat_trans_eq (pr2 E)). intro ; apply idpath. Qed. End Precomp_dagger_functor. Section Precomp_with_dagger_weak_equiv. Context {C D E : category} {dagC : dagger C} {dagD : dagger D} {H : functor C D} {dagH : is_dagger_functor dagC dagD H} (dagE : dagger E). Context (wH : is_weak_dagger_equiv dagH). Lemma disp_dagger_pre_composition_functor_ff : disp_functor_ff (disp_dagger_pre_composition_functor dagH dagE). Proof. intro ; intros ; exact (isweqcontrtounit iscontrunit). Qed. Lemma Precomp_is_ff : fully_faithful (dagger_pre_composition_functor dagH dagE). Proof. use (disp_functor_ff_to_total_ff _ disp_dagger_pre_composition_functor_ff). apply pre_composition_with_ess_surj_and_full_is_fully_faithful. - exact (is_unitarily_eso_is_eso _ (pr1 wH)). - exact (pr1 (fully_faithful_implies_full_and_faithful _ _ _ (pr2 wH))). Qed. Section IntermediateProp. Context {F : functor C E} (dagF : is_dagger_functor dagC dagE F). Local Definition X (d : D) : UU := ∑ (ck : ∑ e : E, ∏ c : C, unitary dagD (H c) d -> unitary dagE (F c) e), ∏ t t' : ∑ c : C, unitary dagD (H c) d, ∏ f : pr1 t --> pr1 t', (#H f · pr12 t' = pr12 t -> #F f · pr1 (pr2 ck (pr1 t') (pr2 t')) = pr1 (pr2 ck (pr1 t) (pr2 t))). Local Definition kX (d : D) (t : X d) := (pr2 (pr1 t)). Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ). Let fH := pr2 wH : fully_faithful H. Ltac inv_functor HF x y := let H:=fresh in set (H:= homotweqinvweq (weq_from_fully_faithful HF x y)); simpl in H; unfold fully_faithful_inv_hom; simpl; rewrite H; clear H. Lemma X_aux_type_center_of_contr_proof (b : D) (anot : C) (hnot : unitary dagD (H anot) b) : ∏ (t t' : ∑ a : C, unitary dagD (H a) b) (f : pr1 t --> pr1 t'), #H f· pr12 t' = pr12 t -> #F f· #F (fH^-1 (pr12 t'· dagD _ _ (pr1 hnot))) = #F (fH^-1 (pr12 t· dagD _ _ (pr1 hnot))). Proof. intros t t' f. destruct t as [a h]. destruct t' as [a' h']. simpl in *. intro star. rewrite <- functor_comp. apply maponpaths. apply (invmaponpathsweq (weq_from_fully_faithful fH a anot)). simpl. rewrite functor_comp. inv_functor fH a' anot. rewrite assoc. inv_functor fH a anot. rewrite <- star. apply idpath. Qed. Local Notation "F '^-i'" := (fully_faithful_reflects_unitary dagH F) (at level 20). Definition X_aux_type_center_of_contr (b : D) (anot : C)(hnot : unitary dagD (H anot) b) : X b. Proof. set (cnot := F anot). use tpair. - exists cnot. intros c u. unfold cnot. set (u' := fully_faithful_reflects_unitary dagH fH c anot (unitary_comp u (unitary_inv hnot))). exact (dagger_functor_on_unitary dagF _ _ u'). - exact (λ t t' f p, X_aux_type_center_of_contr_proof b anot hnot t t' f p). Defined. (** Any inhabitant of [X b] is equal to the center of [X b]. *) Lemma X_aux_type_contr_eq (b : D) (anot : C) (hnot : unitary dagD (H anot) b) (Euniv : is_univalent_dagger dagE) : ∏ t : X b, t = X_aux_type_center_of_contr b anot hnot. Proof. intro t. assert (Hpr1 : pr1 (X_aux_type_center_of_contr b anot hnot) = pr1 t). { set (w := daggerisotoid Euniv ((pr2 (pr1 t)) anot hnot) : pr1 (pr1 (X_aux_type_center_of_contr b anot hnot)) = pr1 (pr1 t)). apply (total2_paths_f w). simpl. destruct t as [[c1 k1] q1]. simpl in *. apply funextsec; intro a. apply funextsec; intro h. set (gah := fH^-i _ _ (unitary_comp h (unitary_inv hnot))). set (qhelp := q1 (tpair _ a h)(tpair _ anot hnot) (pr1 gah)). simpl in *. assert (feedtoqhelp : #H (fH^-1 (pr1 h · pr1 (unitary_inv hnot)))· pr1 hnot = pr1 h). { inv_functor fH a anot. refine (assoc' _ _ _ @ _ @ id_right _). apply maponpaths. exact (pr22 hnot). } assert (quack := qhelp feedtoqhelp). simpl in *. intermediate_path (unitary_comp (dagger_functor_on_unitary dagF _ _ (fH^-i _ _ (unitary_comp h (unitary_inv hnot)))) (idtodaggeriso _ _ _ w) ). - generalize w; intro w0. induction w0. apply unitary_eq. apply pathsinv0, id_right. - apply unitary_eq. simpl. unfold w. refine (_ @ quack). do 2 apply maponpaths. apply idtodaggeriso_daggerisotoid. } apply pathsinv0. apply (total2_paths_f Hpr1). apply proofirrelevance. repeat (apply impred; intro). apply homset_property. Qed. (** Putting everything together: [X b] is contractible. *) Definition iscontr_X (Euniv : is_univalent_dagger dagE) : ∏ b : D, iscontr (X b). Proof. intro b. assert (HH : isaprop (iscontr (X b))). apply isapropiscontr. apply (pr1 wH b (tpair (λ x, isaprop x) (iscontr (X b)) HH)). intro t. exists (X_aux_type_center_of_contr b (pr1 t) (pr2 t)). exact (X_aux_type_contr_eq b (pr1 t) (pr2 t) Euniv). Defined. (** The object part of [G], [Go b], is defined as the first component of the center of [X b]. *) (** *** [G] on objects *) Context (Euniv : is_univalent_dagger dagE). Local Definition Go : D -> E := λ b : D, pr1 (pr1 (pr1 (iscontr_X Euniv b))). Local Definition k (b : D) : ∏ a : C, unitary _ (H a) b -> unitary _ (F a) (Go b) := pr2 (pr1 (pr1 (iscontr_X Euniv b))). Local Definition q (b : D) := pr2 (pr1 (iscontr_X Euniv b)). (** Given any inhabitant of [X b], its first component is equal to [Go b]. *) Definition Xphi (b : D) (t : X b) : pr1 (pr1 t) = Go b. Proof. set (p1 := pr2 (iscontr_X Euniv b) t). exact (base_paths _ _ (base_paths _ _ p1)). Defined. (** Given any inhabitant [t : X b], its second component is equal to [k b], modulo transport along [Xphi b t]. *) Definition Xkphi_transp (b : D) (t : X b) : ∏ a : C, ∏ h : unitary _ (H a) b, transportf _ (Xphi b t) (kX _ t) a h = k b a h. Proof. intro ; intro. set (p := fiber_paths (base_paths _ _ (pr2 (iscontr_X Euniv b) t))). exact (toforallpaths _ _ _ ((toforallpaths _ _ _ p) a) h). Qed. (** Similarly to the lemma before, the second component of [t] is the same as [k b], modulo postcomposition with an isomorphism. *) Definition Xkphi_idtoiso (b : D) (t : X b) : ∏ a : C, ∏ h : unitary _ (H a) b, k b a h · idtodaggeriso dagE _ _ (!Xphi b t) = kX _ t a h. Proof. intros a h. rewrite <- (Xkphi_transp _ t). generalize (Xphi b t). intro i; destruct i. apply id_right. Qed. (** *** Preparation for [G] on morphisms *) (** [G f] will be defined as the first component of the center of contraction of [Y f]. *) Local Definition Y {b b' : D} (f : b --> b') := ∑ g : Go b --> Go b', ∏ a : C, ∏ h : unitary _ (H a) b, ∏ a' : C, ∏ h' : unitary _ (H a') b', ∏ l : a --> a', #H l · h' = h · f -> #F l · k b' a' h' = k b a h · g. Lemma Y_inhab_proof (b b' : D) (f : b --> b') (a0 : C) (h0 : unitary _ (H a0) b) (a0' : C) (h0' : unitary _ (H a0') b') : ∏ (a : C) (h : unitary _ (H a) b) (a' : C) (h' : unitary _ (H a') b') (l : a --> a'), #H l· h' = h· f -> #F l· k b' a' h' = k b a h· ((unitary_inv (k b a0 h0)· #F (fH^-1 ((h0· f)· unitary_inv h0')))· k b' a0' h0'). Proof. intros a h a' h' l alpha. set (m := fH^-i _ _ (unitary_comp h0 (unitary_inv h))). set (m' := fH^-i _ _ (unitary_comp h0' (unitary_inv h'))). assert (sss : unitary_comp (dagger_functor_on_unitary dagF _ _ m) (k b a h) = k b a0 h0). { apply unitary_eq. apply (q b (tpair _ a0 h0) (tpair _ a h) m). simpl. inv_functor fH a0 a. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths, (pr2 h). } assert (ssss : unitary_comp (dagger_functor_on_unitary dagF _ _ m') (k b' a' h') = k b' a0' h0'). { apply unitary_eq. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m'). simpl; inv_functor fH a0' a'. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths, (pr22 h'). } set (hfh := h0 · f · unitary_inv h0'). set (l0 := fH^-1 hfh). set (g0 := unitary_inv (k b a0 h0) · #F l0 · k b' a0' h0'). assert (sssss : #H (l0 · m') = #H (m · l)). { rewrite functor_comp . unfold m'. simpl. inv_functor fH a0' a'. unfold l0. inv_functor fH a0 a0'. unfold hfh. intermediate_path (h0 · f · (unitary_inv h0' · h0') · unitary_inv h'). { repeat rewrite assoc; apply idpath. } etrans. { apply maponpaths_2, maponpaths. apply (pr22 h0'). } rewrite id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths, pathsinv0. apply unitary_inv_on_right. { apply h. } rewrite assoc. apply unitary_inv_on_left. { apply h'. } apply pathsinv0, alpha. } assert (star5 : unitary_inv m · l0 = l · unitary_inv m'). { apply unitary_inv_on_right. { apply m. } rewrite assoc. apply unitary_inv_on_left. { apply m'. } apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a')), pathsinv0, sssss. } clear sssss. unfold g0. assert (sss'' : k b a h · unitary_inv (k b a0 h0) = unitary_inv (dagger_functor_on_unitary dagF _ _ m)). { apply pathsinv0. apply unitary_inv_on_left. { apply k. } apply pathsinv0. apply unitary_inv_on_right. { apply dagger_functor_on_unitary. } apply pathsinv0, (base_paths _ _ sss). } repeat rewrite assoc. rewrite sss''. clear sss'' sss. rewrite dagger_functor_on_unitary_inv. etrans. 2: { apply maponpaths_2, functor_comp. } cbn. unfold m, m' in star5. cbn in star5. rewrite star5; clear star5. rewrite functor_comp. rewrite <- assoc. apply maponpaths. assert (star4 : unitary_inv (dagger_functor_on_unitary dagF _ _ m') · k b' a0' h0' = k b' a' h'). { apply unitary_inv_on_right. { apply dagger_functor_on_unitary. } apply pathsinv0, (base_paths _ _ ssss). } refine (! star4 @ _). apply maponpaths_2. apply pathsinv0, dagF. Qed. (** The center of [Y b b' f]. *) Definition Y_inhab (b b' : D) (f : b --> b') (a0 : C) (h0 : unitary dagD (H a0) b) (a0' : C) (h0' : unitary dagD (H a0') b') : Y f. Proof. set (hfh := h0 · f · unitary_inv h0'). set (l0 := fH^-1 hfh). set (g0 := unitary_inv (k b a0 h0) · #F l0 · k b' a0' h0'). exists g0. apply Y_inhab_proof. Defined. (** Any inhabitant of [Y b b' f] is equal to the center. *) Lemma Y_contr_eq (b b' : D) (f : b --> b') (a0 : C) (h0 : unitary _ (H a0) b) (a0' : C) (h0' : unitary _ (H a0') b') : ∏ t : Y f, t = Y_inhab b b' f a0 h0 a0' h0'. Proof. intro t. apply pathsinv0. assert (Hpr : pr1 (Y_inhab b b' f a0 h0 a0' h0') = pr1 t). { destruct t as [g1 r1]; simpl in *. rewrite <- assoc. use unitary_inv_on_right. { apply k. } set (hfh := h0 · f · unitary_inv h0'). set (l0 := fH^-1 hfh). apply (r1 a0 h0 a0' h0' l0). unfold l0. inv_functor fH a0 a0' . unfold hfh. repeat rewrite <- assoc. apply maponpaths. refine (_ @ id_right _). apply maponpaths. apply h0'. } apply (total2_paths_f Hpr). apply proofirrelevance. repeat (apply impred; intro). apply homset_property. Qed. (** The type [Y b b' f] is contractible. *) Definition Y_iscontr (b b' : D) (f : b --> b') : iscontr (Y f). Proof. assert (HH : isaprop (iscontr (Y f))). { apply isapropiscontr. } apply (pr1 wH b (tpair (λ x, isaprop x) (iscontr (Y f)) HH)). intros [a0 h0]. apply (pr1 wH b' (tpair (λ x, isaprop x) (iscontr (Y f)) HH)). intros [a0' h0']. exists (Y_inhab b b' f a0 h0 a0' h0'). apply Y_contr_eq. Defined. (** *** [G] on morphisms *) (** We now have the data necessary to define the functor [G]. *) Definition preimage_functor_data : functor_data D E. Proof. exists Go. intros b b' f. exact (pr11 (Y_iscontr b b' f)). Defined. Definition G {x y : D} (f : D⟦x,y⟧) := (pr11 (Y_iscontr _ _ f)). (** The above data is indeed functorial. *) Lemma is_functor_preimage_functor_data : is_functor preimage_functor_data. Proof. split. - unfold functor_idax. simpl. intro b. assert (PR2 : ∏ (a : C) (h : unitary _ (H a) b) (a' : C) (h' : unitary _ (H a') b) (l : a --> a'), #H l· h' = h· identity b -> #F l· k b a' h' = k b a h· identity (Go b)). { intros a h a' h' l LL. rewrite id_right. apply (q b (tpair _ a h) (tpair _ a' h') l). rewrite id_right in LL. apply LL. } set (Gbrtilde := tpair _ (identity (Go b)) PR2 : Y (identity b)). set (H' := pr2 (Y_iscontr b b (identity b)) Gbrtilde). set (H'' := base_paths _ _ H'). simpl in H'. rewrite <- H'. apply idpath. - (** composition *) intros b b' b'' f f'. assert (HHHH : isaprop (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f')))). { apply homset_property. } apply (pr1 wH b (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0 h0]; simpl. apply (pr1 wH b' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0' h0']; simpl. apply (pr1 wH b'' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0'' h0'']. simpl; clear HHHH. set (l0 := fH^-1 (h0 · f · unitary_inv h0')). set (l0' := fH^-1 (h0' · f' · unitary_inv h0'')). set (l0'' := fH^-1 (h0 · (f· f') · unitary_inv h0'')). assert (L : l0 · l0' = l0''). { apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a0'')). simpl; rewrite functor_comp. unfold l0'. inv_functor fH a0' a0''. unfold l0. inv_functor fH a0 a0'. intermediate_path (h0 · f · (unitary_inv h0' · h0') · f' · unitary_inv h0''). { repeat rewrite assoc; apply idpath. } etrans. { do 2 apply maponpaths_2. apply maponpaths. apply h0'. } rewrite id_right. unfold l0''. inv_functor fH a0 a0''. repeat rewrite assoc; apply idpath. } assert (PR2 : ∏ (a : C) (h : unitary _ (H a) b)(a' : C) (h' : unitary _ (H a') b') (l : a --> a'), #H l· h' = h· f -> #F l· k b' a' h' = k b a h· ((unitary_inv (k b a0 h0)· #F l0)· k b' a0' h0') ). { intros a h a' h' l. intro alpha. set (m := fH^-i _ _ (unitary_comp h0 (unitary_inv h))). set (m' := fH^-i _ _ (unitary_comp h0' (unitary_inv h'))). assert (sss : unitary_comp (dagger_functor_on_unitary dagF _ _ m) (k b a h) = k b a0 h0). { apply unitary_eq; simpl. apply (q b (tpair _ a0 h0) (tpair _ a h) m). simpl. inv_functor fH a0 a. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths, h. } assert (ssss : unitary_comp (dagger_functor_on_unitary dagF _ _ m') (k b' a' h') = k b' a0' h0'). { apply unitary_eq; simpl. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m'); simpl. inv_functor fH a0' a'. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths, h'. } assert (sssss : #H (l0 · m') = #H (m · l)). { rewrite functor_comp. unfold m'; simpl. inv_functor fH a0' a'. unfold l0. inv_functor fH a0 a0'. intermediate_path (h0 · f · (unitary_inv h0' · h0') · unitary_inv h'). { repeat rewrite assoc; apply idpath. } etrans. { apply maponpaths_2, maponpaths , h0'. } rewrite id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths. apply pathsinv0. apply unitary_inv_on_right. { apply h. } rewrite assoc. apply unitary_inv_on_left. { apply h'. } apply pathsinv0. apply alpha. } assert (star5 : unitary_inv m · l0 = l · unitary_inv m'). { apply unitary_inv_on_right. { apply m. } rewrite assoc. apply unitary_inv_on_left. { apply m'. } apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a' )). apply pathsinv0. apply sssss. } clear sssss. set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b a h · unitary_inv (k b a0 h0) = unitary_inv (dagger_functor_on_unitary dagF _ _ m)). { apply pathsinv0. apply unitary_inv_on_left. { apply k. } apply pathsinv0. apply unitary_inv_on_right. { apply dagger_functor_on_unitary. } apply pathsinv0. apply sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, dagger_functor_on_unitary_inv_on_ob. } rewrite <- functor_comp. etrans. 2: { apply maponpaths_2, maponpaths. refine (! star5 @ _). apply maponpaths_2. apply (Isos.inverse_unique_precat _ _ m) ; apply m. } clear star5. rewrite functor_comp. etrans. 2: { apply maponpaths_2, maponpaths. exact (dagger_functor_on_unitary_inv_on_ob dagF _ _ m'). } assert (star4 : unitary_inv (dagger_functor_on_unitary dagF _ _ m') · k b' a0' h0' = k b' a' h' ). { apply unitary_inv_on_right. { apply dagger_functor_on_unitary. } set (ssss' := base_paths _ _ ssss). apply pathsinv0. simpl in ssss'. simpl. apply ssss'; clear ssss'. } rewrite <- assoc. apply maponpaths. apply pathsinv0, star4. } assert (HGf : G f = unitary_inv (k b a0 h0) · #F l0 · k b' a0' h0'). { set (Gbrtilde := tpair _ (unitary_inv (k b a0 h0) · #F l0 · k b' a0' h0') PR2 : Y f). set (H' := pr2 (Y_iscontr b b' f) Gbrtilde). set (H'' := base_paths _ _ H'). simpl in H'. unfold G. rewrite <- H'. apply idpath. } clear PR2. assert (PR2 : ∏ (a : C) (h : unitary _ (H a) b') (a' : C) (h' : unitary _ (H a') b'') (l : a --> a'), #H l· h' = h· f' -> #F l· k b'' a' h' = k b' a h· ((unitary_inv (k b' a0' h0')· #F l0')· k b'' a0'' h0'')). { intros a' h' a'' h'' l'. intro alpha. set (m := fH^-i _ _ (unitary_comp h0' (unitary_inv h'))). set (m' := fH^-i _ _ (unitary_comp h0'' (unitary_inv h''))). assert (sss : unitary_comp (dagger_functor_on_unitary dagF _ _ m) (k b' a' h') = k b' a0' h0'). { apply unitary_eq; simpl. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m); simpl. inv_functor fH a0' a'. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths. apply h'. } assert (ssss : unitary_comp (dagger_functor_on_unitary dagF _ _ m') (k b'' a'' h'') = k b'' a0'' h0''). { apply unitary_eq; simpl. apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m'); simpl. inv_functor fH a0'' a''. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths. apply h''. } assert (sssss : #H (l0' · m') = #H (m · l')). { rewrite functor_comp. unfold m'. simpl. inv_functor fH a0'' a''. unfold l0'. inv_functor fH a0' a0''. intermediate_path (h0' · f' · (unitary_inv h0'' · h0'') · unitary_inv h''). { repeat rewrite assoc; apply idpath. } etrans. { apply maponpaths_2, maponpaths, h0''. } rewrite id_right, functor_comp. inv_functor fH a0' a'. repeat rewrite <- assoc. apply maponpaths, pathsinv0, unitary_inv_on_right. { apply h'. } rewrite assoc. apply unitary_inv_on_left. { apply h''. } apply pathsinv0, alpha. } assert (star5 : unitary_inv m · l0' = l' · unitary_inv m'). { apply unitary_inv_on_right. { apply m. } rewrite assoc. apply unitary_inv_on_left. { apply m'. } apply (invmaponpathsweq (weq_from_fully_faithful fH a0' a'' )), pathsinv0, sssss. } set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b' a' h' · unitary_inv (k b' a0' h0') = unitary_inv (dagger_functor_on_unitary dagF _ _ m)). { apply pathsinv0, unitary_inv_on_left, pathsinv0, unitary_inv_on_right. - apply k. - apply dagger_functor_on_unitary. - apply pathsinv0, sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. etrans. 2: { do 2 apply maponpaths_2. exact (! dagger_functor_on_unitary_inv_on_ob dagF _ _ m). } rewrite <- functor_comp. etrans. 2: apply maponpaths_2, maponpaths, pathsinv0, star5. clear star5 sssss. rewrite functor_comp. etrans. 2: { apply maponpaths_2, maponpaths. exact (dagger_functor_on_unitary_inv_on_ob dagF _ _ m'). } assert (star4 : unitary_inv (dagger_functor_on_unitary dagF _ _ m') · k b'' a0'' h0'' = k b'' a'' h'' ). { apply unitary_inv_on_right. { apply dagger_functor_on_unitary. } set (ssss' := base_paths _ _ ssss). apply pathsinv0. simpl in *; apply ssss'. } rewrite <- assoc. apply maponpaths. exact (! star4). } assert (HGf' : G f' = unitary_inv (k b' a0' h0') · #F l0' · k b'' a0'' h0''). { set (Gbrtilde := tpair _ (unitary_inv (k b' a0' h0') · #F l0' · k b'' a0'' h0'') PR2 : Y f'). set (H' := pr2 (Y_iscontr b' b'' f') Gbrtilde). unfold G. rewrite <- (base_paths _ _ H'). apply idpath. } clear PR2. assert (PR2 : ∏ (a : C) (h : unitary _ (H a) b) (a' : C) (h' : unitary _ (H a') b'') (l : a --> a'), #H l· h' = h· (f· f') -> #F l· k b'' a' h' = k b a h· ((unitary_inv (k b a0 h0)· #F l0'')· k b'' a0'' h0'')). { intros a h a'' h'' l. intro alpha. set (m := fH^-i _ _ (unitary_comp h0 (unitary_inv h))). set (m' := fH^-i _ _ (unitary_comp h0'' (unitary_inv h''))). assert (sss : unitary_comp (dagger_functor_on_unitary dagF _ _ m) (k b a h) = k b a0 h0). { apply unitary_eq. apply (q b (tpair _ a0 h0) (tpair _ a h) m); simpl. inv_functor fH a0 a. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths. apply h. } assert (ssss : unitary_comp (dagger_functor_on_unitary dagF _ _ m') (k b'' a'' h'') = k b'' a0'' h0''). { apply unitary_eq. apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m'). simpl; inv_functor fH a0'' a''. rewrite <- assoc. refine (_ @ id_right _). apply maponpaths. apply h''. } assert (sssss : #H (l0'' · m') = #H (m · l)). { rewrite functor_comp. unfold m'. simpl. inv_functor fH a0'' a''. unfold l0''. inv_functor fH a0 a0''. intermediate_path (h0 · (f · f') · (unitary_inv h0'' · h0'') · unitary_inv h''). { repeat rewrite assoc; apply idpath. } etrans. { apply maponpaths_2, maponpaths, h0''. } rewrite id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths, pathsinv0, unitary_inv_on_right. { apply h. } repeat rewrite assoc. apply unitary_inv_on_left, pathsinv0. { apply h''. } repeat rewrite <- assoc. apply alpha. } assert (star5 : unitary_inv m · l0'' = l · unitary_inv m'). { apply unitary_inv_on_right. { apply m. } rewrite assoc. apply unitary_inv_on_left. { apply m'. } apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a'' )). apply pathsinv0, sssss. } set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b a h · unitary_inv (k b a0 h0) = unitary_inv (dagger_functor_on_unitary dagF _ _ m)). { apply pathsinv0, unitary_inv_on_left, pathsinv0, unitary_inv_on_right. - apply k. - apply dagger_functor_on_unitary. - apply pathsinv0, sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. etrans. 2: { do 2 apply maponpaths_2. exact (! dagger_functor_on_unitary_inv_on_ob dagF _ _ m). } rewrite <- functor_comp. etrans. 2: apply maponpaths_2, maponpaths, (! star5). clear star5 sssss. rewrite functor_comp. etrans. 2: { apply maponpaths_2, maponpaths. exact (dagger_functor_on_unitary_inv_on_ob dagF _ _ m'). } assert (star4 : unitary_inv (dagger_functor_on_unitary dagF _ _ m') · k b'' a0'' h0'' = k b'' a'' h''). { apply unitary_inv_on_right, pathsinv0, (base_paths _ _ ssss). apply dagger_functor_on_unitary. } rewrite <- assoc. apply maponpaths. exact (! star4). } assert (HGff' : G (f · f') = unitary_inv (k b a0 h0) · #F l0'' · k b'' a0'' h0''). { set (Gbrtilde := tpair _ (unitary_inv (k b a0 h0) · #F l0'' · k b'' a0'' h0'') PR2 : Y (f · f')). unfold G. rewrite <- (pr2 (Y_iscontr b b'' (f · f')) Gbrtilde). apply idpath. } clear PR2. fold (G (f · f')). fold (G (f)) (G f'). rewrite HGf, HGf'. intermediate_path (unitary_inv (k b a0 h0)· #F l0· (k b' a0' h0'· unitary_inv (k b' a0' h0'))· #F l0'· k b'' a0'' h0''). { etrans. 2: { do 2 apply maponpaths_2. apply maponpaths, pathsinv0, k. } rewrite id_right, HGff'. repeat rewrite <- assoc. apply maponpaths. rewrite <- L. rewrite functor_comp. repeat rewrite <- assoc. apply idpath. } now repeat rewrite <- assoc. Qed. (** We call the functor [GG] ... *) Definition GG : functor D E := tpair _ preimage_functor_data is_functor_preimage_functor_data. (** ** [G] is the preimage of [F] under [ _ O H] *) (** Given any [a : A], we produce an element in [X (H a)], whose first component is [F a]. This allows to prove [G (H a) = F a]. *) Lemma qF (a0 : C) : ∏ (t t' : ∑ a : C, unitary dagD (H a) (H a0)) (f : pr1 t --> pr1 t'), #H f· pr2 t' = pr2 t -> #F f· #F (fH^-1 (pr2 t')) = #F (fH^-1 (pr2 t)). Proof. simpl. intros [a h] [a' h'] f L. simpl in L; simpl. rewrite <- functor_comp. apply maponpaths. apply (invmaponpathsweq (weq_from_fully_faithful fH a a0) (f· fH^-1 h') (fH^-1 h) ). inv_functor fH a a0. rewrite functor_comp. inv_functor fH a' a0. apply L. Qed. Definition kFa (a0 : C) : ∏ a : C, unitary _ (H a) (H a0) -> unitary _ (F a) (F a0) := fun (a : C) (h : unitary _ (H a) (H a0)) => dagger_functor_on_unitary dagF _ _ (fully_faithful_reflects_unitary dagH fH _ _ h). Definition XtripleF (a0 : C) : X (H a0) := tpair _ (tpair _ (F a0) (kFa a0)) (qF a0). Lemma phi (a0 : C) : pr1 (pr1 (functor_composite H GG)) a0 = pr1 (pr1 F) a0. Proof. exact (!Xphi _ (XtripleF a0)). Defined. Lemma extphi : pr1 (pr1 (functor_composite H GG)) = pr1 (pr1 F). Proof. apply funextsec. unfold homot. apply phi. Defined. (** Now for the functor as a whole. It remains to prove equality on morphisms, modulo transport. *) Lemma is_preimage_for_pre_composition : functor_composite H GG = F. Proof. apply (functor_eq _ _ E (functor_composite H GG) F). apply (total2_paths_f extphi). apply funextsec; intro a0; apply funextsec; intro a0'; apply funextsec; intro f. rewrite FunctorCategory.transport_of_functor_map_is_pointwise. unfold extphi. unfold Univalence.double_transport. rewrite toforallpaths_funextsec. rewrite <- Univalence.idtoiso_postcompose. rewrite <- Univalence.idtoiso_precompose. rewrite Univalence.idtoiso_inv. rewrite <- assoc. assert (PSIf : ∏ (a : C) (h : unitary _ (H a) (H a0)) (a' : C) (h' : unitary _ (H a') (H a0')) (l : a --> a'), #H l· h' = h· #H f -> #F l· k (H a0') a' h' = k (H a0) a h· ((pr1 (idtodaggeriso dagE _ _ (phi a0)) · #F f) · unitary_inv (idtodaggeriso dagE _ _ (phi a0')))). { intros a h a' h' l alpha. rewrite assoc. apply unitary_inv_on_left. { apply idtodaggeriso. } unfold phi. repeat rewrite assoc. rewrite (Xkphi_idtoiso (H a0) (XtripleF a0)). repeat rewrite <- assoc. rewrite (Xkphi_idtoiso (H a0') (XtripleF a0')). simpl. assert (HH4 : fH^-1 h · f = l · fH^-1 h'). { apply (invmaponpathsweq (weq_from_fully_faithful fH a a0')). simpl; repeat rewrite functor_comp. inv_functor fH a a0. inv_functor fH a' a0'. apply pathsinv0, alpha. } intermediate_path (#F (fH^-1 h· f)). { now rewrite functor_comp. } rewrite HH4. now rewrite functor_comp. } set (Ybla := tpair _ (idtodaggeriso _ _ _ (phi a0) · #F f · unitary_inv (idtodaggeriso _ _ _ (phi a0'))) PSIf : Y (#H f)). set (Ycontr := pr2 (Y_iscontr _ _ (#(pr1 H) f)) Ybla). set (Ycontr2 := base_paths _ _ Ycontr); simpl in *. change (H a0) with (pr1 H a0). change (H a0') with (pr1 H a0'). change (G (#H f)) with (G (#(pr1 H) f)). change (#H f) with (# (pr1 H) f). rewrite <- Ycontr2. repeat rewrite assoc. etrans. { do 3 apply maponpaths_2. refine (_ @ idpath (identity _)). generalize (phi a0). intro p ; induction p ; apply id_right. } rewrite id_left. repeat rewrite <- assoc. etrans. { apply maponpaths. refine (_ @ idpath (identity _)). rewrite dagger_of_idtodaggeriso. etrans. { apply maponpaths_2, idtodaggeriso_is_dagger_of_idtodaggeriso. } refine (_ @ pr22 (idtodaggeriso dagE _ _ (phi a0'))). rewrite pathsinv0inv0. apply maponpaths. generalize (phi a0'). intro p ; induction p ; apply idpath. } apply id_right. Qed. Lemma GG_is_dagger_functor : is_dagger_functor dagD dagE GG. Proof. intros x y f. transparent assert (rhs : (Y (dagD x y f))). { exists (dagE (Go x) (Go y) (G f)). intros c h c' h' l p. apply (dagger_injective dagE). do 2 rewrite dagger_to_law_comp. rewrite dagger_to_law_idemp. rewrite <- dagF. apply unitary_inv_on_left. { apply k. } unfold G. set (p0 := pr21 (Y_iscontr _ _ (dagD _ _ f)) _ h _ h' l p). rewrite assoc'. assert (pf : # H (dagC c c' l) · h = h' · f). { rewrite dagH. apply (dagger_injective dagD). do 2 rewrite dagger_to_law_comp. rewrite dagger_to_law_idemp. use unitary_inv_on_left. { apply h'. } rewrite assoc'. rewrite p. rewrite assoc. etrans. 2: apply maponpaths_2, pathsinv0, (pr22 h). apply pathsinv0, id_left. } etrans. 2: { apply maponpaths, pathsinv0. exact (pr21 (Y_iscontr _ _ f) _ h' _ h (dagC _ _ l) pf). } rewrite assoc. etrans. 2: apply maponpaths_2, pathsinv0, k. apply pathsinv0, id_left. } exact (base_paths _ _ (! pr2 (Y_iscontr _ _ (dagD x y f)) rhs)). Qed. End IntermediateProp. Lemma Precomp_is_unitarily_eso (Euniv : is_univalent_dagger dagE) : is_unitarily_eso (dagger_pre_composition_functor_is_dagger_functor dagH dagE). Proof. intros [F dagF] p' f. apply f. exists (_ ,, GG_is_dagger_functor dagF Euniv). apply idtodaggeriso. use subtypePath. { intro ; apply isaprop_is_dagger_functor. } apply is_preimage_for_pre_composition. Qed. End Precomp_with_dagger_weak_equiv. Lemma Precomp_of_dagger_weak_equiv_is_dagger_weak_equiv {C D E : category} {dagC : dagger C} {dagD : dagger D} {H : functor C D} {dagH : is_dagger_functor dagC dagD H} (wH : is_weak_dagger_equiv dagH) {dagE : dagger E} (univE : is_univalent_dagger dagE) : is_weak_dagger_equiv (dagger_pre_composition_functor_is_dagger_functor dagH dagE). Proof. split. - exact (Precomp_is_unitarily_eso _ wH univE). - exact (Precomp_is_ff _ wH). Qed. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Functors/WeakEquivalences.v000066400000000000000000000064141451125700300302560ustar00rootroot00000000000000(* In this file, we have formalized: 1: The definition of a weak (dagger) equivalence between dagger categories 2: We have shown that any weak dagger equivalence induces a unitary isomorphism, i.e. dagger isomorphism, *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Transformations. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Require Import UniMath.CategoryTheory.DaggerCategories.Univalence. Require Import UniMath.CategoryTheory.DaggerCategories.FunctorCategory. Local Open Scope cat. Definition unitary_to_z_iso {C : category} {dag : dagger C} {x y : C} (u : unitary dag x y) : z_iso x y := make_z_iso _ _ (pr2 u). Section WeakDaggerEquivalences. Definition is_unitarily_eso {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : UU := ∏ d : D, ∃ c : C, unitary dagD (F c) d. Definition is_unitarily_eso_is_eso {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : is_unitarily_eso dagF -> essentially_surjective F. Proof. intros p d. use (factor_through_squash_hProp _ _ (p d)). clear p ; intro p. apply hinhpr. exists (pr1 p). exact (unitary_to_z_iso (pr2 p)). Qed. Lemma isaprop_is_unitarily_eso {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : isaprop (is_unitarily_eso dagF). Proof. apply impred_isaprop ; intro. apply isapropishinh. Qed. Definition is_weak_dagger_equiv {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : UU := is_unitarily_eso dagF × fully_faithful F. Lemma isaprop_is_weak_dagger_equiv {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : isaprop (is_weak_dagger_equiv dagF). Proof. apply isapropdirprod. - apply isaprop_is_unitarily_eso. - apply isaprop_fully_faithful. Qed. End WeakDaggerEquivalences. Section DaggerEquivalences. Definition is_unitarily_split_eso {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : UU := ∏ d : D, ∑ c : C, unitary dagD (F c) d. Definition is_dagger_equiv {C D : category} {dagC : dagger C} {dagD : dagger D} {F : functor C D} (dagF : is_dagger_functor dagC dagD F) : UU := is_unitarily_split_eso dagF × fully_faithful F. End DaggerEquivalences. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Transformations.v000066400000000000000000000055531451125700300264130ustar00rootroot00000000000000(* No special notion of 'dagger natural transformation' is required. However, some concepts are defined in terms of natural transformations. 1. The category of dagger functors and natural transformations has the structure of dagger category. The dagger of a natural transformation is given by taking the dagger objectwise. This is called the 'dagger adjoint'. 2. A unitary morphism in the dagger functor category is given by a natural isomorphism whose inverse is given objectwise by the dagger [unitary_functors]. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Functors. Local Open Scope cat. Section DaggerAdjoint. Definition dagger_adjoint_data {C D : category} {dagC : dagger C} {dagD : dagger D} {F G : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) (α : nat_trans F G) : nat_trans_data G F := λ c, dagD _ _ (α c). Definition dagger_adjoint_is_nat_trans {C D : category} {dagC : dagger C} {dagD : dagger D} {F G : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) (α : nat_trans F G) : is_nat_trans _ _ (dagger_adjoint_data dagF dagG α). Proof. intro ; intros. apply (dagger_injective dagD). refine (dagger_to_law_comp _ _ _ _ _ _ @ _ @ ! dagger_to_law_comp _ _ _ _ _ _). refine (maponpaths_2 compose (dagger_to_law_idemp _ _ _ _) _ @ _). refine (_ @ ! maponpaths_12 compose (idpath _) (dagger_to_law_idemp _ _ _ _)). refine (! maponpaths (compose (α x')) (dagG _ _ f) @ _). refine (_ @ maponpaths_12 compose (dagF _ _ f) (idpath _)). apply pathsinv0, (pr2 α). Qed. Definition dagger_adjoint {C D : category} {dagC : dagger C} {dagD : dagger D} {F G : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) (α : nat_trans F G) : nat_trans G F := _ ,, dagger_adjoint_is_nat_trans dagF dagG α. End DaggerAdjoint. Section UnitaryFunctors. Definition unitary_functors {C D : category} {dagC : dagger C} {dagD : dagger D} {F G : functor C D} (dagF : is_dagger_functor dagC dagD F) (dagG : is_dagger_functor dagC dagD G) : UU := ∑ α : nat_trans F G, (∏ x : C, Isos.is_inverse_in_precat (α x) (dagD _ _ (α x))). End UnitaryFunctors. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Unitary.v000066400000000000000000000122771451125700300246560ustar00rootroot00000000000000(* In this file, we have formalized the (correct) notion of isomorphisms in dagger categories, the so called unitary morphisms. Notice that this definition is different compared to (non-dagger) categories, therefore, we can not reuse is_z_isomorphism. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Local Open Scope cat. Section UnitaryMorphisms. Definition is_unitary {C : category} (dag : dagger_structure C) {x y : C} (f : C⟦x,y⟧) : UU := is_inverse_in_precat f (dag x y f). Lemma isaprop_is_unitary {C : category} (dag : dagger_structure C) {x y : C} (f : C⟦x,y⟧) : isaprop (is_unitary dag f). Proof. apply isaprop_is_inverse_in_precat. Qed. Definition unitary {C : category} (dag : dagger_structure C) (x y : C) : UU := ∑ f : C⟦x,y⟧, is_unitary dag f. Definition unitary_to_mor {C : category} {dag : dagger_structure C} {x y : C} (u : unitary dag x y) : C⟦x,y⟧ := pr1 u. Coercion unitary_to_mor : unitary >-> precategory_morphisms. Lemma isaset_unitary {C : category} (dag : dagger_structure C) (x y : C) : isaset (unitary dag x y). Proof. apply isaset_total2. - apply homset_property. - intro ; apply isasetaprop ; apply isaprop_is_unitary. Qed. Lemma unitary_eq {C : category} {dag : dagger_structure C} {x y : C} (f g : unitary dag x y) : pr1 f = pr1 g -> f = g. Proof. intro p. apply (total2_paths_f p). apply isaprop_is_unitary. Qed. Definition unitary_id {C : category} (dag : dagger C) (x : C) : unitary dag x x. Proof. exists (identity_z_iso x). abstract (apply make_is_inverse_in_precat ; [ refine (id_left _ @ _) ; apply dagger_to_law_id | refine (id_right _ @ _) ; apply dagger_to_law_id ]). Defined. Lemma is_unitary_comp {C : category} {dag : dagger C} {x y z : C} {f : C⟦x,y⟧} (ff : is_unitary dag f) {g : C⟦y,z⟧} (gg : is_unitary dag g) : is_unitary dag (f · g). Proof. split. - etrans. { apply maponpaths, dagger_to_law_comp. } etrans. { apply assoc. } etrans. { apply maponpaths_2, assoc'. } etrans. { apply maponpaths_2, maponpaths, gg. } etrans. { apply maponpaths_2, id_right. } apply ff. - etrans. { apply maponpaths_2, dagger_to_law_comp. } etrans. { apply assoc. } etrans. { apply maponpaths_2, assoc'. } etrans. { apply maponpaths_2, maponpaths, ff. } etrans. { apply maponpaths_2, id_right. } apply gg. Qed. Definition unitary_comp {C : category} {dag : dagger C} {x y z : C} (f : unitary dag x y) (g : unitary dag y z) : unitary dag x z := _ ,, is_unitary_comp (pr2 f) (pr2 g). Lemma unitary_inv_is_unitary {C : category} {dag : dagger C} {x y : C} {f : C⟦x,y⟧} (ff : is_unitary dag f) : is_unitary dag (pr1 dag x y f). Proof. split. - refine (! dagger_to_law_comp dag y x y (pr1 dag x y f) f @ _). etrans. { apply maponpaths, ff. } apply dagger_to_law_id. - refine (! dagger_to_law_comp dag x y x f (pr1 dag x y f) @ _). etrans. { apply maponpaths, ff. } apply dagger_to_law_id. Qed. Definition unitary_inv {C : category} {dag : dagger C} {x y : C} (f : unitary dag x y) : unitary dag y x := _ ,, unitary_inv_is_unitary (pr2 f). Lemma unitary_inv_of_unitary_inv {C : category} {dag : dagger C} {x y : C} (f : unitary dag x y) : unitary_inv (unitary_inv f) = f. Proof. use unitary_eq. apply dagger_to_law_idemp. Qed. End UnitaryMorphisms. Section EquationalReasoningLemmas. Context {C : category} (dag : dagger C). Lemma unitary_inv_to_left {a b c : C} (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧) : is_unitary dag f -> dag _ _ f · h = g → h = f · g. Proof. exact (λ u p, z_iso_inv_to_left _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ _ p). Qed. Lemma unitary_inv_on_left {a b c : C} (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧) : is_unitary dag g -> h = f · g → f = h · dag _ _ g. Proof. exact (λ u p, z_iso_inv_on_left _ _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ p). Qed. Lemma unitary_inv_on_right {a b c : C} (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧) : is_unitary dag f -> h = f · g → dag _ _ f · h = g. Proof. exact (λ u p, z_iso_inv_on_right _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ _ p). Qed. Lemma unitary_inv_to_right {a b c : C} (f : C⟦ a, b ⟧) (g : C⟦b, c⟧) (h : C⟦ a, c ⟧) : is_unitary dag g -> f = h · dag _ _ g → f · g = h. Proof. exact (λ u p, z_iso_inv_to_right _ _ _ _ (make_z_iso _ _ (_,,pr2 u)) _ p). Qed. End EquationalReasoningLemmas. UniMath-20231010/UniMath/CategoryTheory/DaggerCategories/Univalence.v000066400000000000000000000073661451125700300253170ustar00rootroot00000000000000(* In this file, we have formalized the (correct) notion of isomorphisms and univalence of dagger categories. Notice that these definitions are different compared to (non-dagger) categories, therefore, we can not reuse it. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DaggerCategories.Categories. Require Import UniMath.CategoryTheory.DaggerCategories.Unitary. Local Open Scope cat. Section DaggerUnivalence. Definition idtodaggeriso {C : category} (dag : dagger C) (x y : C) : x = y -> unitary dag x y. Proof. intro p ; induction p. exact (unitary_id dag x). Defined. Definition idtodaggermor {C : category} (dag : dagger C) {x y : C} (p : x = y) : C⟦x,y⟧ := pr1 (idtodaggeriso dag _ _ p). Definition is_univalent_dagger {C : category} (dag : dagger C) : UU := ∏ x y, isweq (idtodaggeriso dag x y). Lemma isaprop_is_univalent_dagger {C : category} (dag : dagger C) : isaprop (is_univalent_dagger dag). Proof. do 2 (apply impred_isaprop ; intro) ; apply isapropisweq. Qed. Definition daggerisotoid {C : category} {dag : dagger C} (u : is_univalent_dagger dag) {x y : C} : unitary dag x y -> x = y := invmap (make_weq _ (u x y)). Lemma daggerisotoid_idtodaggeriso {C : category} {dag : dagger C} (u : is_univalent_dagger dag) {x y : C} (p : x = y) : daggerisotoid u (idtodaggeriso dag _ _ p) = p. Proof. apply (homotinvweqweq (make_weq _ (u x y))). Qed. Lemma idtodaggeriso_daggerisotoid {C : category} {dag : dagger C} (u : is_univalent_dagger dag) {x y : C} (p : unitary dag x y) : idtodaggeriso dag _ _ (daggerisotoid u p) = p. Proof. apply (homotweqinvweq (make_weq _ (u x y))). Qed. Lemma idtodaggermor_daggerisotoid {C : category} {dag : dagger C} (u : is_univalent_dagger dag) {x y : C} (p : unitary dag x y) : idtodaggermor dag (daggerisotoid u p) = pr1 p. Proof. apply (maponpaths pr1). apply idtodaggeriso_daggerisotoid. Qed. End DaggerUnivalence. Section Lemmas. Lemma idtodaggeriso_is_dagger_of_idtodaggeriso {C : category} (dagC : dagger C) {x y : C} (p : x = y) : pr1 (idtodaggeriso dagC x y p) = dagC y x (pr1 (idtodaggeriso dagC y x (! p))). Proof. induction p. apply pathsinv0, dagger_to_law_id. Qed. Lemma idtodaggermor_is_dagger_of_idtodaggermor {C : category} (dagC : dagger C) {x y : C} (p : x = y) : idtodaggermor dagC p = dagC y x (idtodaggermor dagC (! p)). Proof. induction p. apply pathsinv0, dagger_to_law_id. Qed. Lemma idtodaggeriso_idpath_is_id {C : category} (dagC : dagger C) (x : C) : pr1 (idtodaggeriso dagC x x (idpath x)) = identity x. Proof. apply idpath. Qed. Lemma idtodaggermor_idpath_is_id {C : category} (dagC : dagger C) (x : C) : pr1 (idtodaggeriso dagC x x (idpath x)) = identity x. Proof. apply idpath. (* exact (idtodaggeriso_idpath_is_id dagC x *) Qed. Lemma idtomor_is_dagger_of_idtomor_of_pathsinv0 {C : category} (dagC : dagger C) {x y : C} (p : x = y) : idtomor _ _ p = dagC _ _ (idtomor _ _ (! p)). Proof. induction p. apply pathsinv0, dagger_to_law_id. Qed. Lemma idtoiso_of_pathsinv_is_dagger_of_idtoiso {C : category} (dagC : dagger C) {x y : C} (p : x = y) : pr1 (Univalence.idtoiso (! p)) = dagC x y (pr1 (Univalence.idtoiso p)). Proof. induction p. apply pathsinv0, dagger_to_law_id. Qed. End Lemmas. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/000077500000000000000000000000001451125700300223555ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Adjunctions.v000066400000000000000000000263231451125700300250330ustar00rootroot00000000000000(** Contents: - Definition of homset correspondences for a displayed adjunction. - Homset correspondences are weak equivalences. - The right adjoint functor of a displayed adjunction preserves cartesian morphisms. Written by Tamara von Glehn and Noam Zeilberger at the School and Workshop on Univalent Mathematics, December 2017 *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Section fix_disp_adjunction. Context {C C' : category} (A : adjunction C C') {D : disp_cat C} {D': disp_cat C'} (X : disp_adjunction A D D'). Let F := left_functor A. Let G := right_functor A. Let FF : disp_functor F D D' := left_adj_over X. Let GG : disp_functor G D' D := right_adj_over X. Let η : functor_identity C ⟹ F ∙ G := adjunit A. Let ε : G ∙ F ⟹ functor_identity C' := adjcounit A. Let ηη : disp_nat_trans η (disp_functor_identity D) (disp_functor_composite FF GG) := unit_over X. Let εε : disp_nat_trans ε (disp_functor_composite GG FF) (disp_functor_identity D') := counit_over X. Local Open Scope hide_transport_scope. Section DispHomSetIso_from_Adjunction. (* Naming: homset_conj_inv lies over φ_adj_inv and has inverse homset_conj, homset_conj' lies over φ_adj and has inverse homset_conj'_inv. *) Definition homset_conj_inv {c : C} {c' : C'} (g : C⟦c, G c'⟧) (d : D c) (d' : D' c') : (d -->[g] GG _ d') -> (FF _ d -->[#F g · ε _] d') := λ alpha, comp_disp (♯ FF alpha) (εε _ _). Definition homset_conj' {c : C} {c' : C'} (f : C'⟦F c, c'⟧) (d : D c) (d' : D' c') : (FF _ d -->[f] d') -> (d -->[η _ · #G f] GG _ d') := λ beta, comp_disp (ηη _ _) (♯ GG beta). Definition homset_conj'_inv {c : C} {c' : C'} (f : C'⟦F c, c'⟧) (d : D c) (d' : D' c') : (d -->[η _ · #G f] GG _ d') -> (FF _ d -->[f] d'). Proof. set (equiv := φ_adj_inv_after_φ_adj A f : # F (η c · # G f) · ε c' = f). exact (λ alpha, transportf _ equiv (homset_conj_inv _ _ _ alpha)). Defined. Definition homset_conj {c : C} {c' : C'} (g : C⟦c, G c'⟧) (d : D c) (d' : D' c') : (FF _ d -->[#F g · ε _] d') -> (d -->[g] GG _ d'). Proof. set (equiv := φ_adj_after_φ_adj_inv A g : η c · # G (# F g · ε c') = g). exact (λ beta, transportf _ equiv (homset_conj' _ _ _ beta)). Defined. (** * Naturality of homset bijections *) Open Scope mor_disp. Lemma homset_conj_inv_natural_precomp {c : C} {c' : C'} {g : C⟦c, G c'⟧} {c'' : C} {f : C⟦c'', c⟧} {d : D c} {d' : D' c'} {d'' : D c''} (gg : d -->[g] GG _ d') (ff : d'' -->[f] d) : homset_conj_inv _ _ _ (ff ;; gg) = transportb _ (φ_adj_inv_natural_precomp A _ _ g _ f) (♯ FF ff ;; homset_conj_inv _ _ _ gg). Proof. unfold homset_conj_inv. rewrite disp_functor_comp. rewrite assoc_disp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply maponpaths_2, homset_property. Defined. Lemma homset_conj_inv_natural_postcomp {c : C} {c' : C'} {g : C⟦c, G c'⟧} {c'' : C'} {f : C'⟦c', c''⟧} {d : D c} {d' : D' c'} {d'' : D' c''} (gg : d -->[g] GG _ d') (ff : d' -->[f] d'') : homset_conj_inv _ _ _ (gg ;; ♯ GG ff) = transportb _ (φ_adj_inv_natural_postcomp A _ _ g _ f) (homset_conj_inv _ _ _ gg ;; ff). Proof. unfold homset_conj_inv. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite 2 assoc_disp_var. cbn. set (nat_εε := disp_nat_trans_ax εε ff). cbn in nat_εε. rewrite nat_εε. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite 3 transport_f_f. apply maponpaths_2, homset_property. Defined. Lemma homset_conj'_natural_precomp {c : C} {c' : C'} {f : C'⟦F c, c'⟧} {c'' : C} {k : C⟦c'', c⟧} {d : D c} {d' : D' c'} {d'' : D c''} (ff : FF _ d -->[f] d') (kk : d'' -->[k] d) : homset_conj' _ _ _ (♯ FF kk ;; ff) = transportb _ (φ_adj_natural_precomp A _ _ f _ k) (kk ;; homset_conj' _ _ _ ff). Proof. unfold homset_conj'. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite 2 assoc_disp. cbn. set (nat_ηη := disp_nat_trans_ax_var ηη kk). cbn in nat_ηη. rewrite nat_ηη. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite 3 transport_f_f. apply maponpaths_2, homset_property. Defined. Lemma homset_conj'_natural_postcomp {c : C} {c' : C'} {f : C'⟦F c, c'⟧} {c'' : C'} {k : C'⟦c', c''⟧} {d : D c} {d' : D' c'} {d'' : D' c''} (ff : FF _ d -->[f] d') (kk : d' -->[k] d'') : homset_conj' _ _ _ (ff ;; kk) = transportb _ (φ_adj_natural_postcomp A _ _ f _ k) (homset_conj' _ _ _ ff ;; ♯ GG kk). Proof. unfold homset_conj'. rewrite disp_functor_comp. rewrite assoc_disp_var. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2, homset_property. Defined. Lemma homset_conj_inv_after_conj' {c : C} {c' : C'} (f : C'⟦F c, c'⟧)(d : D c) (d' : D' c') (beta : FF _ d -->[f] d') : transportf _ (φ_adj_inv_after_φ_adj A f) (homset_conj_inv _ _ _ (homset_conj' f d d' beta)) = beta. Proof. unfold homset_conj'. cbn. set (eq := homset_conj_inv_natural_postcomp (ηη c d) beta). cbn in eq. rewrite eq. unfold homset_conj_inv. cbn. rewrite transport_f_b. (* Note : there should probably be an accessor function for this *) assert (triangle1 : ♯ FF (ηη c d);; εε (F c) (FF c d) = transportb _ (triangle_id_left_ad A c ) (id_disp _)) by (exact ((pr1 (pr2 X)) c d)). cbn in triangle1. rewrite triangle1. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite 2 transport_f_f. intermediate_path (transportf _ (idpath _) beta). - apply maponpaths_2, homset_property. - apply idpath. Defined. Lemma homset_conj'_after_conj_inv {c : C} {c' : C'} {g : C⟦c, G c'⟧} {d : D c} (d' : D' c') (alpha : d -->[g] GG _ d') : transportf _ (φ_adj_after_φ_adj_inv A g) (homset_conj' _ _ _ (homset_conj_inv g d d' alpha)) = alpha. unfold homset_conj_inv. cbn. set (eq := homset_conj'_natural_precomp (εε c' d') alpha). cbn in eq. rewrite eq. unfold homset_conj'. cbn. rewrite transport_f_b. assert (triangle2 : (ηη (G c') (GG c' d');; ♯ GG (εε c' d')) = transportb _ (triangle_id_right_ad A c') (id_disp _)) by (exact (pr2 (pr2 X) c' d')). cbn in triangle2. rewrite triangle2. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite id_right_disp. unfold transportb. rewrite 2 transport_f_f. intermediate_path (transportf _ (idpath _ ) alpha). - apply maponpaths_2, homset_property. - apply idpath. Defined. Close Scope mor_disp. (** * homset_conj_inv and homset_conj' are weak equivalences. *) Lemma homset_conj_after_conj_inv {c : C} {c' : C'} {g : C⟦c, G c'⟧} {d : D c} (d' : D' c') (alpha : d -->[g] GG _ d') : homset_conj _ _ _ (homset_conj_inv _ _ _ alpha) = alpha. Proof. apply homset_conj'_after_conj_inv. Defined. Lemma homset_conj_inv_after_conj {c : C} {c' : C'} {g : C⟦c, G c'⟧} (d : D c) {d' : D' c'} (beta : FF _ d -->[#F g · ε _] d') : homset_conj_inv _ _ _ (homset_conj _ _ _ beta) = beta. Proof. unfold homset_conj. rewrite <- homset_conj_inv_after_conj'. unfold homset_conj_inv. rewrite disp_functor_transportf. rewrite mor_disp_transportf_postwhisker. apply maponpaths_2, homset_property. Defined. Lemma homset_conj'_inv_after_conj' {c : C} {c' : C'} (f : C'⟦F c, c'⟧)(d : D c) (d' : D' c') (beta : FF _ d -->[f] d') : homset_conj'_inv _ _ _ (homset_conj' _ _ _ beta) = beta. Proof. apply homset_conj_inv_after_conj'. Defined. Lemma homset_conj'_after_conj'_inv {c : C} {c' : C'} (f : C'⟦F c, c'⟧) (d : D c) (d' : D' c') (alpha : d -->[η _ · #G f] GG _ d') : homset_conj' _ _ _ (homset_conj'_inv _ _ _ alpha) = alpha. Proof. unfold homset_conj', homset_conj'_inv. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. rewrite <- homset_conj'_after_conj_inv. apply maponpaths_2, homset_property. Defined. Lemma dispadjunction_hom_weq (c : C) (c' : C') (g : C⟦c, G c'⟧) (d : D c) (d' : D' c') : (d -->[g] GG _ d') ≃ (FF _ d -->[# F g · ε _] d'). Proof. exists (homset_conj_inv _ _ _). apply (isweq_iso _ (homset_conj _ _ _)). - apply homset_conj_after_conj_inv. - apply homset_conj_inv_after_conj. Defined. Lemma dispadjunction_hom_weq' (c : C) (c' : C') (f : C'⟦F c, c'⟧) (d : D c) (d' : D' c') : (FF _ d -->[f] d') ≃ (d -->[η _ · # G f] GG _ d'). Proof. exists (homset_conj' _ _ _). apply (isweq_iso _ (homset_conj'_inv _ _ _)). - apply homset_conj'_inv_after_conj'. - apply homset_conj'_after_conj'_inv. Defined. End DispHomSetIso_from_Adjunction. (** * The right adjoint functor of a displayed adjunction preserves cartesian morphisms. *) Lemma right_over_adj_preserves_cartesianness : is_cartesian_disp_functor GG. Proof. unfold is_cartesian_disp_functor. intros c c' f d d' ff ff_cart. intros c'' g d'' h. set (eq := φ_adj_inv_natural_postcomp A _ _ g _ f : # F (g · # G f) · ε c = # F g · (ε c') · f). Open Scope mor_disp. apply (@iscontrweqb _ (∑ gg, (gg;; ff) = transportf _ eq (homset_conj_inv _ _ _ h))). - apply (weqbandf (dispadjunction_hom_weq _ _ g _ _)). intro gg. cbn. set (eq2 := homset_conj_inv_natural_postcomp gg ff). cbn in eq2. apply weqimplimpl. + intro p. rewrite <- p. rewrite eq2. rewrite transport_f_b. intermediate_path (transportf _ (idpath _ ) (♯ FF gg;; εε c' d';; ff)). * apply idpath. * apply maponpaths_2, homset_property. + intro p. set (equiv1 := homset_conj'_after_conj_inv _ h). set (equiv2 := homset_conj'_after_conj_inv _ (gg;; ♯ GG ff)). unfold homset_conj' in equiv1, equiv2. rewrite <- equiv1. rewrite <- equiv2. rewrite eq2. rewrite p. rewrite transport_b_f. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2, homset_property. + apply homsets_disp. + apply homsets_disp. - apply ff_cart. Defined. End fix_disp_adjunction. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Binproducts.v000066400000000000000000001517431451125700300250530ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2022 *) (** ********************************************************** Contents : - defines a notion of binary products for displayed categories that gives binary products on its total category - same programme for terminal objects ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Local Open Scope mor_disp. Section FixDispCat. Context {C : category} (D : disp_cat C). Definition is_dispBinProduct_naive (c d p : C) (p1 : p --> c) (p2 : p --> d) (cc : D c) (dd : D d) (pp : D p) (pp1 : pp -->[p1] cc) (pp2 : pp -->[p2] dd) : UU := ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd), ∃! (fg : a --> p) (fgfg : aa -->[fg] pp), ∑ fgok : ((fg · p1 = f) × (fg · p2 = g)), (fgfg ;; pp1 = transportb _ (pr1 fgok) ff) × (fgfg ;; pp2 = transportb _ (pr2 fgok) gg). Definition is_dispBinProduct (c d : C) (P : BinProduct C c d) (cc : D c) (dd : D d) (pp : D (BinProductObject _ P)) (pp1 : pp -->[BinProductPr1 _ P] cc) (pp2 : pp -->[BinProductPr2 _ P] dd) : UU := ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd), ∃! (fgfg : aa -->[BinProductArrow _ P f g] pp), (fgfg ;; pp1 = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff) × (fgfg ;; pp2 = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg). Definition dispBinProduct (c d : C) (P : BinProduct C c d) (cc : D c) (dd : D d) : UU := ∑ pppp1pp2 : (∑ pp : D (BinProductObject _ P), (pp -->[BinProductPr1 _ P] cc) × (pp -->[BinProductPr2 _ P] dd)), is_dispBinProduct c d P cc dd (pr1 pppp1pp2) (pr1 (pr2 pppp1pp2)) (pr2 (pr2 pppp1pp2)). Definition make_dispBinProduct_locally_prop (c d : C) (P : BinProduct C c d) (cc : D c) (dd : D d) (LP : locally_propositional D) (dBP_data : ∑ pp : D (BinProductObject _ P), (pp -->[BinProductPr1 _ P] cc) × (pp -->[BinProductPr2 _ P] dd)) (mediating : ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd), aa -->[ BinProductArrow C P f g] pr1 dBP_data) : dispBinProduct c d P cc dd. Proof. exists dBP_data. intro; intros. use tpair. - exists (mediating a f g aa ff gg). abstract (split; apply LP). - abstract (intro t; apply subtypePath; [intro; apply isapropdirprod; apply homsets_disp | apply LP]). Defined. Definition dispBinProductObject {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d} (dP : dispBinProduct c d P cc dd) : D (BinProductObject _ P) := pr1 (pr1 dP). Definition dispBinProductPr1 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d} (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr1 _ P] cc := pr1 (pr2 (pr1 dP)). Definition dispBinProductPr2 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d} (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr2 _ P] dd := pr2 (pr2 (pr1 dP)). Definition is_dispBinProduct_dispBinProduct {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d} (dP : dispBinProduct c d P cc dd) : is_dispBinProduct c d P cc dd (dispBinProductObject P dP) (dispBinProductPr1 P dP) (dispBinProductPr2 P dP). Proof. exact (pr2 dP). Defined. Definition dispBinProductArrow {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d} (dP : dispBinProduct c d P cc dd) {a : C} {f : a --> c} {g : a --> d} {aa : D a} (ff : aa -->[f] cc) (gg : aa -->[g] dd) : aa -->[BinProductArrow _ P f g] dispBinProductObject P dP. Proof. exact (pr1 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg))). Defined. Lemma dispBinProductPr1Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd): ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd), dispBinProductArrow P dP ff gg ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff. Proof. intros a f g aa ff gg. exact (pr1 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))). Qed. Lemma dispBinProductPr2Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd): ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd), dispBinProductArrow P dP ff gg ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg. Proof. intros a f g aa ff gg. exact (pr2 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))). Qed. Lemma dispBinProductArrowUnique {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) (f : x --> c) (g : x --> d) (ff : xx -->[f] cc) (gg : xx -->[g] dd) (kk : xx -->[BinProductArrow _ P f g] dispBinProductObject P dP) : kk ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff -> kk ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg -> kk = dispBinProductArrow P dP ff gg. Proof. intros H1 H2. apply path_to_ctr; split; assumption. Qed. (* transparent proofs for the standard binary products -- upstream? Definition BinProductArrowUnique' (c d : C) (P : BinProduct C c d) (x : C) (f : x --> c) (g : x --> d) (k : x --> BinProductObject C P) : k · BinProductPr1 C P = f -> k · BinProductPr2 C P = g -> k = BinProductArrow C P f g. Proof. intros; apply path_to_ctr; split; assumption. Defined. Definition BinProductArrowEta' (c d : C) (P : BinProduct C c d) (x : C) (f : x --> BinProductObject C P) : f = BinProductArrow C P (f · BinProductPr1 C P) (f · BinProductPr2 C P). Proof. apply BinProductArrowUnique'; apply idpath. Defined. *) Lemma dispBinProductArrowEta {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) {fg : x --> BinProductObject C P } (fgfg : xx -->[ fg] dispBinProductObject P dP) : fgfg = transportb (mor_disp xx (dispBinProductObject P dP)) (BinProductArrowEta C c d P x fg) (dispBinProductArrow P dP (fgfg ;; dispBinProductPr1 P dP) (fgfg ;; dispBinProductPr2 P dP)). Proof. apply transportf_transpose_right. apply dispBinProductArrowUnique. - etrans. { apply mor_disp_transportf_postwhisker. } unfold transportb. apply (maponpaths (fun z => transportf (mor_disp xx cc) z (fgfg ;; dispBinProductPr1 P dP))). apply C. - etrans. { apply mor_disp_transportf_postwhisker. } unfold transportb. apply (maponpaths (fun z => transportf (mor_disp xx dd) z (fgfg ;; dispBinProductPr2 P dP))). apply C. Qed. Lemma dispBinProduct_endo_is_identity {a b : C} (aa : D a) (bb : D b) (P : BinProduct _ a b) (dP : dispBinProduct a b P aa bb) {k : BinProductObject _ P --> BinProductObject _ P} (kk: dispBinProductObject P dP -->[k] dispBinProductObject P dP) (H1 : k · BinProductPr1 _ P = BinProductPr1 _ P) (dH1 : kk ;; dispBinProductPr1 P dP = transportb _ H1 (dispBinProductPr1 P dP)) (H2 : k · BinProductPr2 _ P = BinProductPr2 _ P) (dH2 : kk ;; dispBinProductPr2 P dP = transportb _ H2 (dispBinProductPr2 P dP)) : transportf _ (BinProduct_endo_is_identity C a b P k H1 H2) (id_disp (dispBinProductObject P dP)) = kk. Proof. apply pathsinv0. etrans. { apply dispBinProductArrowEta. } apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite id_left_disp. rewrite transport_f_b. apply transportf_comp_lemma. etrans. 2: { apply pathsinv0; exact dH1. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite id_left_disp. rewrite transport_f_b. apply transportf_comp_lemma. etrans. 2: { apply pathsinv0; exact dH2. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Definition dispBinProductOfArrows {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd) {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb) {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd) : dispBinProductObject Pab dPab -->[BinProductOfArrows C Pcd Pab f g] dispBinProductObject Pcd dPcd := dispBinProductArrow Pcd dPcd (dispBinProductPr1 Pab dPab ;; ff) (dispBinProductPr2 Pab dPab ;; gg). Lemma dispBinProductOfArrowsPr1 {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd) {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb) {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd) : dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr1 Pcd dPcd = transportb _ (BinProductOfArrowsPr1 _ Pcd Pab f g) (dispBinProductPr1 Pab dPab ;; ff). Proof. unfold dispBinProductOfArrows. etrans. { apply dispBinProductPr1Commutes. } apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) cc) z (dispBinProductPr1 Pab dPab ;; ff))). apply C. Qed. Lemma dispBinProductOfArrowsPr2 {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd) {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb) {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd) : dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr2 Pcd dPcd = transportb _ (BinProductOfArrowsPr2 _ Pcd Pab f g) (dispBinProductPr2 Pab dPab ;; gg). Proof. unfold dispBinProductOfArrows. etrans. { apply dispBinProductPr2Commutes. } apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) dd) z (dispBinProductPr2 Pab dPab ;; gg))). apply C. Qed. Lemma dispPostcompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd) {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb) {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd) {x : C} {xx : D x} {k : x --> a} {h : x --> b} (kk: xx -->[k] aa) (hh: xx -->[h] bb) : dispBinProductArrow Pab dPab kk hh ;; dispBinProductOfArrows dPcd dPab ff gg = transportb _ (postcompWithBinProductArrow C Pcd Pab f g k h) (dispBinProductArrow Pcd dPcd (kk ;; ff) (hh ;; gg)). Proof. apply transportb_transpose_right. apply dispBinProductArrowUnique. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { apply pathsinv0, mor_disp_transportf_prewhisker. } rewrite assoc_disp. rewrite dispBinProductPr1Commutes. rewrite transport_f_b. apply transportf_comp_lemma. unfold transportb. etrans. 2: { apply pathsinv0, mor_disp_transportf_postwhisker. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { apply pathsinv0, mor_disp_transportf_prewhisker. } rewrite assoc_disp. rewrite dispBinProductPr2Commutes. rewrite transport_f_b. apply transportf_comp_lemma. unfold transportb. etrans. 2: { apply pathsinv0, mor_disp_transportf_postwhisker. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Lemma dispPrecompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd) {a : C} {aa : D a} {f : a --> c} {g : a --> d} (ff: aa -->[f] cc) (gg: aa -->[g] dd) {x : C} {xx : D x} {k : x --> a} (kk: xx -->[k] aa) : kk ;; dispBinProductArrow Pcd dPcd ff gg = transportb _ (precompWithBinProductArrow C Pcd f g k) (dispBinProductArrow Pcd dPcd (kk ;; ff) (kk ;; gg)). Proof. apply transportb_transpose_right. apply dispBinProductArrowUnique. - rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. rewrite transport_f_f. etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Definition dispBinProducts (Ps : BinProducts C) : UU := ∏ (c d : C) (cc : D c) (dd : D d), dispBinProduct c d (Ps c d) cc dd. Lemma dispBinProductOfArrows_comp { Ps : BinProducts C } (dPs : dispBinProducts Ps) {a b c d x y : C} {aa : D a} {bb : D b} {cc : D c} {dd: D d} {xx : D x} {yy : D y} {f : a --> c} {f' : b --> d} {g : c --> x} {g' : d --> y} (ff : aa -->[f] cc) (ff' : bb -->[f'] dd) (gg : cc -->[g] xx) (gg' : dd -->[g'] yy) : dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) ff ff' ;; dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) gg gg' = transportb _ (BinProductOfArrows_comp _ _ _ _ _ _ _ _ f f' g g') (dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) (ff;;gg) (ff';;gg')). Proof. apply transportb_transpose_right. apply dispBinProductArrowUnique. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { apply pathsinv0, mor_disp_transportf_prewhisker. } do 2 rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. do 2 rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } rewrite transport_f_f. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - etrans. { apply mor_disp_transportf_postwhisker. } rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { apply pathsinv0, mor_disp_transportf_prewhisker. } do 2 rewrite assoc_disp. rewrite dispBinProductOfArrowsPr2. do 2 rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } rewrite transport_f_f. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Definition total_category_Binproducts_data (Ps : BinProducts C) (dPs : dispBinProducts Ps) (ccc ddd : total_category D) : ∑ p : total_category D, total_category D ⟦ p, ccc ⟧ × total_category D ⟦ p, ddd ⟧. Proof. induction ccc as [c cc]. induction ddd as [d dd]. - exists (BinProductObject _ (Ps c d) ,, dispBinProductObject (Ps c d) (dPs c d cc dd)). split. + use tpair. * apply BinProductPr1. * apply dispBinProductPr1. + use tpair. * apply BinProductPr2. * apply dispBinProductPr2. Defined. Definition total_category_Binproducts_mediating_morphism (Ps : BinProducts C) (dPs : dispBinProducts Ps) {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) : ∑ h : x --> BinProductObject C (Ps c d), xx -->[h] dispBinProductObject (Ps c d) (dPs c d cc dd). Proof. use tpair. - apply BinProductArrow; assumption. - apply dispBinProductArrow; assumption. Defined. Local Lemma total_category_Binproducts_mediating_morphism_ok (Ps : BinProducts C) (dPs : dispBinProducts Ps) {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) : BinProductArrow C (Ps c d) f g · BinProductPr1 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff × BinProductArrow C (Ps c d) f g · BinProductPr2 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg. Proof. split. - use total2_paths_f; cbn. + apply BinProductPr1Commutes. + apply transportf_pathsinv0. apply pathsinv0. apply dispBinProductPr1Commutes. - use total2_paths_f; cbn. + apply BinProductPr2Commutes. + apply transportf_pathsinv0. apply pathsinv0. apply dispBinProductPr2Commutes. Qed. Local Lemma total_category_Binproducts_mediating_morphism_unique (Ps : BinProducts C) (dPs : dispBinProducts Ps) {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) {fg : x --> BinProductObject C (Ps c d)} (fgfg : xx -->[fg] dispBinProductObject (Ps c d) (dPs c d cc dd)) : fg · BinProductPr1 C (Ps c d),, fgfg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff × fg · BinProductPr2 C (Ps c d),, fgfg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg → fg,, fgfg = total_category_Binproducts_mediating_morphism Ps dPs ff gg. Proof. intro H. induction H as [H1 H2]. cbn in *. induction (total2_paths_equiv _ _ _ H1) as [H1l H1r]. induction (total2_paths_equiv _ _ _ H2) as [H2l H2r]. clear H1 H2. use total2_paths_f; cbn. - use path_to_ctr; split; assumption. - cbn in *. rewrite <- H1r, <- H2r. clear H1r H2r ff gg. induction H1l. induction H2l. (* apply dispBinProductArrowEta. would work with [BinProductArrowEta'] *) (* we proceed as follows: *) cbn. etrans. 2: { assert (aux := dispBinProductArrowEta (Ps c d) cc dd (dPs _ _ cc dd) xx fgfg). apply transportf_transpose_left in aux. exact aux. } apply (maponpaths (fun z => transportf (mor_disp xx (dispBinProductObject (Ps c d) (dPs c d cc dd))) z fgfg)). apply C. Qed. Definition total_category_Binproducts (Ps : BinProducts C) (dPs : dispBinProducts Ps) : BinProducts (total_category D). Proof. intros ccc ddd. use tpair. - apply (total_category_Binproducts_data Ps dPs). - induction ccc as [c cc]. induction ddd as [d dd]. intros aaa fff ggg. destruct aaa as [a aa]; destruct fff as [f ff]; destruct ggg as [g gg]. cbn. use unique_exists. + exact (total_category_Binproducts_mediating_morphism Ps dPs ff gg). + exact (total_category_Binproducts_mediating_morphism_ok Ps dPs ff gg). + intro y. apply isapropdirprod. * apply (homset_property (total_category D) (a ,, aa) (c ,, cc)). * apply (homset_property (total_category D) (a ,, aa) (d ,, dd)). + intro fgfgfg. induction fgfgfg as [fg fgfg]. exact (total_category_Binproducts_mediating_morphism_unique Ps dPs ff gg fgfg). Defined. (** ** analogously for terminal objects *) Definition is_dispTerminal (P : Terminal C) (pp : D (TerminalObject P)) : UU := ∏ (a : C) (aa : D a), iscontr (aa -->[TerminalArrow P a] pp). Definition dispTerminal (P : Terminal C) : UU := ∑ pp : D (TerminalObject P), is_dispTerminal P pp. Definition make_dispTerminal_locally_prop (P : Terminal C) (LP : locally_propositional D) (dTO_data : D (TerminalObject P)) (mediating : ∏ (a : C) (aa : D a), aa -->[TerminalArrow P a] dTO_data) : dispTerminal P. Proof. exists dTO_data. intro; intros. use tpair. - exact (mediating a aa). - intro; apply LP. Defined. Definition dispTerminalObject {P : Terminal C} (dP : dispTerminal P) : D (TerminalObject P) := pr1 dP. Definition is_dispTerminal_dispTerminal (P : Terminal C) (dP : dispTerminal P) : is_dispTerminal P (dispTerminalObject dP) := pr2 dP. Definition dispTerminalArrow (P : Terminal C) (dP : dispTerminal P) {a : C} (aa : D a) : aa -->[TerminalArrow P a] dispTerminalObject dP := pr1 (is_dispTerminal_dispTerminal P dP a aa). Lemma dispTerminalArrowUnique (P : Terminal C) (dP : dispTerminal P) {x : C} (xx : D x) (kk : xx -->[TerminalArrow P x] dispTerminalObject dP) : kk = dispTerminalArrow P dP xx. Proof. apply (pr2 (pr2 dP x xx)). Qed. Lemma dispTerminalArrowUnique' (P : Terminal C) (dP : dispTerminal P) {x : C} (xx : D x) (f: x --> TerminalObject P) (kk : xx -->[f] dispTerminalObject dP) : kk = transportb _ (TerminalArrowUnique P x f) (dispTerminalArrow P dP xx). Proof. apply transportf_transpose_right. apply dispTerminalArrowUnique. Qed. Lemma dispTerminalArrowEq {T : Terminal C} {TT: dispTerminal T} {a : C} {aa : D a} {f g : a --> T} (ff: aa -->[f] dispTerminalObject TT) (gg: aa -->[g] dispTerminalObject TT) : ff = transportb _ (TerminalArrowEq f g) gg. Proof. induction (TerminalArrowEq f g). cbn. rewrite (dispTerminalArrowUnique' _ _ _ _ ff). rewrite (dispTerminalArrowUnique' _ _ _ _ gg). apply idpath. Qed. Definition total_category_Terminal (P : Terminal C) (dP : dispTerminal P) : Terminal (total_category D). Proof. use tpair. - exists (TerminalObject P). exact (dispTerminalObject dP). - intros aaa. destruct aaa as [a aa]. cbn. use tpair. + exact (TerminalArrow P a,, dispTerminalArrow P dP aa). + intro fff. induction fff as [f ff]. use total2_paths_f; cbn. * apply TerminalArrowUnique. * apply dispTerminalArrowUnique. Defined. (** Displayed equalizers *) Definition is_disp_Equalizer {x y : C} {f g : x --> y} (e : Equalizer f g) {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (ee : D e) (ar_e : ee -->[ EqualizerArrow e ] xx) (pp : transportf (λ z, _ -->[ z ] _) (EqualizerEqAr e) (ar_e ;; ff) = ar_e ;; gg) : UU := ∏ (w : C) (ww : D w) (h : w --> x) (hh : ww -->[ h ] xx) (q : h · f = h · g) (qq : transportf (λ z, _ -->[ z ] _) q (hh ;; ff) = hh ;; gg), ∃! (ii : ww -->[ EqualizerIn e w h q ] ee), transportf (λ z, _ -->[ z ] _) (EqualizerCommutes e w h q) (ii ;; ar_e) = hh. Definition disp_Equalizer {x y : C} {f g : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (e : Equalizer f g) : UU := ∑ (ee : D e) (ar_e : ee -->[ EqualizerArrow e ] xx) (pp : transportf (λ z, _ -->[ z ] _) (EqualizerEqAr e) (ar_e ;; ff) = ar_e ;; gg), is_disp_Equalizer e ee ar_e pp. Definition disp_Equalizers (EC : Equalizers C) : UU := ∏ (x y : C) (f g : x --> y) (xx : D x) (yy : D y) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy), disp_Equalizer ff gg (EC x y f g). Section TotalEqualizer. Context {x y : C} {f g : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (e : Equalizer f g) (ee : disp_Equalizer ff gg e). Let t_x : total_category D := x ,, xx. Let t_y : total_category D := y ,, yy. Let t_f : t_x --> t_y := f ,, ff. Let t_g : t_x --> t_y := g ,, gg. Let t_e : total_category D := _ ,, pr1 ee. Let t_i : t_e --> t_x := _ ,, pr12 ee. Proposition total_Equalizer_path : t_i · t_f = t_i · t_g. Proof. use total2_paths_f. - apply EqualizerEqAr. - apply (pr122 ee). Qed. Section TotalEqualizerUMP. Context {w : C} {ww : D w} {h : w --> x} (hh : ww -->[ h ] xx). Let t_w : total_category D := w ,, ww. Let t_h : t_w --> t_x := h ,, hh. Context (t_q : t_h · t_f = t_h · t_g). Let q : h · f = h · g := base_paths _ _ t_q. Let qq : transportf (λ z, _ -->[ z ] _) q (hh ;; ff) = hh ;; gg := fiber_paths t_q. Proposition total_Equalizer_unique : isaprop (∑ (φ : t_w --> t_e), φ · t_i = t_h). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use total2_paths_f. - use EqualizerInsEq. exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))). - assert (r : pr11 φ₂ = EqualizerIn e w h q). { exact (isEqualizerInUnique _ _ _ _ (pr22 e) _ _ _ (pr11 φ₂) (maponpaths pr1 (pr2 φ₂))). } rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (pr21 φ₂)). rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (transportf _ _ _)). apply maponpaths. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr222 ee w ww h hh q qq)) (transportf _ _ _ ,, _) (transportf _ _ _ ,, _))). + cbn. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr2 φ₁)). apply maponpaths_2. apply homset_property. + cbn. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. refine (_ @ fiber_paths (pr2 φ₂)). apply maponpaths_2. apply homset_property. Qed. Definition total_EqualizerIn : t_w --> t_e. Proof. refine (EqualizerIn e w h q ,, _). exact (pr11 (pr222 ee w ww h hh q qq)). Defined. Proposition total_EqualizerIn_commutes : total_EqualizerIn · t_i = t_h. Proof. use total2_paths_f. - apply EqualizerCommutes. - exact (pr21 (pr222 ee w ww h hh q qq)). Defined. End TotalEqualizerUMP. Definition total_Equalizer : @Equalizer (total_category D) t_x t_y t_f t_g. Proof. use make_Equalizer. - exact t_e. - exact t_i. - exact total_Equalizer_path. - intros w h q. use iscontraprop1. + apply total_Equalizer_unique. exact q. + simple refine (_ ,, _). * exact (total_EqualizerIn (pr2 h) q). * exact (total_EqualizerIn_commutes (pr2 h) q). Defined. End TotalEqualizer. Definition total_Equalizers (EC : Equalizers C) (DC : disp_Equalizers EC) : Equalizers (total_category D). Proof. intros x y f g. exact (total_Equalizer (pr2 f) (pr2 g) (EC _ _ (pr1 f) (pr1 g)) (DC _ _ _ _ _ _ (pr2 f) (pr2 g))). Defined. (** Displayed coequalizers *) Definition is_disp_Coequalizer {x y : C} {f g : x --> y} (e : Coequalizer f g) {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} (ee : D e) (ar_e : yy -->[ CoequalizerArrow e ] ee) (pp : transportf (λ z, _ -->[ z ] _) (CoequalizerEqAr e) (ff ;; ar_e) = gg ;; ar_e) : UU := ∏ (w : C) (ww : D w) (h : y --> w) (hh : yy -->[ h ] ww) (q : f · h = g · h) (qq : transportf (λ z, _ -->[ z ] _) q (ff ;; hh) = gg ;; hh), ∃! (ii : ee -->[ CoequalizerOut e w h q ] ww), transportf (λ z, _ -->[ z ] _) (CoequalizerCommutes e w h q) (ar_e ;; ii) = hh. Definition disp_Coequalizer {x y : C} {f g : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (e : Coequalizer f g) : UU := ∑ (ee : D e) (ar_e : yy -->[ CoequalizerArrow e ] ee) (pp : transportf (λ z, _ -->[ z ] _) (CoequalizerEqAr e) (ff ;; ar_e) = gg ;; ar_e), is_disp_Coequalizer e ee ar_e pp. Definition disp_Coequalizers (DC : Coequalizers C) : UU := ∏ (x y : C) (f g : x --> y) (xx : D x) (yy : D y) (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy), disp_Coequalizer ff gg (DC x y f g). Section TotalCoequalizer. Context {x y : C} {f g : x --> y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (gg : xx -->[ g ] yy) (e : Coequalizer f g) (ee : disp_Coequalizer ff gg e). Let t_x : total_category D := x ,, xx. Let t_y : total_category D := y ,, yy. Let t_f : t_x --> t_y := f ,, ff. Let t_g : t_x --> t_y := g ,, gg. Let t_e : total_category D := _ ,, pr1 ee. Let t_i : t_y --> t_e := _ ,, pr12 ee. Proposition total_Coequalizer_path : t_f · t_i = t_g · t_i. Proof. use total2_paths_f. - apply CoequalizerEqAr. - apply (pr122 ee). Qed. Section TotalCoequalizerUMP. Context {w : C} {ww : D w} {h : y --> w} (hh : yy -->[ h ] ww). Let t_w : total_category D := w ,, ww. Let t_h : t_y --> t_w := h ,, hh. Context (t_q : t_f · t_h = t_g · t_h). Let q : f · h = g · h := base_paths _ _ t_q. Let qq : transportf (λ z, _ -->[ z ] _) q (ff ;; hh) = gg ;; hh := fiber_paths t_q. Proposition total_Coequalizer_unique : isaprop (∑ (φ : t_e --> t_w), t_i · φ = t_h). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use total2_paths_f. - use CoequalizerOutsEq. exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))). - assert (r : pr11 φ₂ = CoequalizerOut e w h q). { exact (isCoequalizerOutUnique _ _ _ _ (pr22 e) _ _ _ (pr11 φ₂) (maponpaths pr1 (pr2 φ₂))). } rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (pr21 φ₂)). rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (transportf _ _ _)). apply maponpaths. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr222 ee w ww h hh q qq)) (transportf _ _ _ ,, _) (transportf _ _ _ ,, _))). + cbn. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr2 φ₁)). apply maponpaths_2. apply homset_property. + cbn. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. refine (_ @ fiber_paths (pr2 φ₂)). apply maponpaths_2. apply homset_property. Qed. Definition total_CoequalizerOut : t_e --> t_w. Proof. refine (CoequalizerOut e w h q ,, _). exact (pr11 (pr222 ee w ww h hh q qq)). Defined. Proposition total_CoequalizerOut_commutes : t_i · total_CoequalizerOut = t_h. Proof. use total2_paths_f. - apply CoequalizerCommutes. - exact (pr21 (pr222 ee w ww h hh q qq)). Defined. End TotalCoequalizerUMP. Definition total_Coequalizer : @Coequalizer (total_category D) t_x t_y t_f t_g. Proof. use make_Coequalizer. - exact t_e. - exact t_i. - exact total_Coequalizer_path. - intros w h q. use iscontraprop1. + apply total_Coequalizer_unique. exact q. + simple refine (_ ,, _). * exact (total_CoequalizerOut (pr2 h) q). * exact (total_CoequalizerOut_commutes (pr2 h) q). Defined. End TotalCoequalizer. Definition total_Coequalizers (EC : Coequalizers C) (DC : disp_Coequalizers EC) : Coequalizers (total_category D). Proof. intros x y f g. exact (total_Coequalizer (pr2 f) (pr2 g) (EC _ _ (pr1 f) (pr1 g)) (DC _ _ _ _ _ _ (pr2 f) (pr2 g))). Defined. (** Type-indexed products *) Section FixType. Context (I : UU). Definition disp_isProduct {d : I → C} (dd : ∏ (i : I), D (d i)) (p : Product I C d) (pp : D p) (ππ : ∏ (i : I), pp -->[ ProductPr _ _ p i ] dd i) : UU := ∏ (w : C) (ww : D w) (f : ∏ (i : I), w --> d i) (ff : ∏ (i : I), ww -->[ f i ] dd i), ∃! (hh : ww -->[ ProductArrow _ _ p f ] pp), ∏ (i : I), transportf (λ z, _ -->[ z ] _) (ProductPrCommutes _ _ _ p _ f i) (hh ;; ππ i) = ff i. Definition disp_Product {d : I → C} (dd : ∏ (i : I), D (d i)) (p : Product I C d) : UU := ∑ (pp : D p) (ππ : ∏ (i : I), pp -->[ ProductPr _ _ p i ] dd i), disp_isProduct dd p pp ππ. Definition disp_Products (PC : Products I C) : UU := ∏ (d : I → C) (dd : ∏ (i : I), D (d i)), disp_Product dd (PC d). Section TotalProduct. Context (d_dd : I → total_category D). Let d : I → C := λ i, pr1 (d_dd i). Let dd : ∏ (i : I), D (d i) := λ i, pr2 (d_dd i). Context (p : Product I C d) (pp : disp_Product dd p). Definition total_category_Product : total_category D := _ ,, pr1 pp. Definition total_category_ProductPr (i : I) : total_category_Product --> d_dd i := _ ,, pr12 pp i. Section TotalProductUMP. Context {w : C} (ww : D w) {f : ∏ (i : I), w --> d i} (ff : ∏ (i : I), ww -->[ f i ] dd i). Let t_w : total_category D := w ,, ww. Let t_f : ∏ (i : I), t_w --> d_dd i := λ i, f i ,, ff i. Proposition total_category_ProductUnique : isaprop (∑ (φ : t_w --> total_category_Product), ∏ (i : I), φ · total_category_ProductPr i = t_f i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use total2_paths_f. - use ProductArrow_eq. intro i. exact (maponpaths pr1 (pr2 φ₁ i @ !(pr2 φ₂ i))). - assert (r : pr11 φ₂ = ProductArrow _ _ p f). { use ProductArrow_eq. intro i. refine (maponpaths pr1 (pr2 φ₂ i) @ _). cbn. rewrite ProductPrCommutes. apply idpath. } rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (pr21 φ₂)). rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (transportf _ _ _)). apply maponpaths. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr22 pp w ww f ff)) (transportf _ _ _ ,, _) (transportf _ _ _ ,, _))). + cbn. intro i. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr2 φ₁ i)). apply maponpaths_2. apply homset_property. + cbn. intro i. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. refine (_ @ fiber_paths (pr2 φ₂ i)). apply maponpaths_2. apply homset_property. Qed. Definition total_category_ProductArrow : t_w --> total_category_Product := _ ,, pr11 (pr22 pp w ww f ff). Proposition total_category_ProductPrCommutes (i : I) : total_category_ProductArrow · total_category_ProductPr i = t_f i. Proof. use total2_paths_f. - exact (ProductPrCommutes _ _ _ p _ _ i). - exact (pr21 (pr22 pp w ww f ff) i). Qed. End TotalProductUMP. Definition total_category_isProduct : isProduct _ _ _ total_category_Product total_category_ProductPr. Proof. intros w f. use iscontraprop1. - apply total_category_ProductUnique. - simple refine (_ ,, _). + exact (total_category_ProductArrow (pr2 w) (λ i, pr2 (f i))). + exact (total_category_ProductPrCommutes (pr2 w) (λ i, pr2 (f i))). Defined. End TotalProduct. Definition total_Products (PC : Products I C) (DC : disp_Products PC) : Products I (total_category D). Proof. intros d. use make_Product. - exact (total_category_Product d _ (DC _ _)). - exact (total_category_ProductPr d _ (DC _ _)). - apply total_category_isProduct. Defined. End FixType. (** Displayed binary coproducts *) Definition disp_isBinCoproduct {x y : C} {xx : D x} {yy : D y} (p : BinCoproduct x y) (pp : D p) (ιι₁ : xx -->[ BinCoproductIn1 p ] pp) (ιι₂ : yy -->[ BinCoproductIn2 p ] pp) : UU := ∏ (w : C) (ww : D w) (f : x --> w) (ff : xx -->[ f ] ww) (g : y --> w) (gg : yy -->[ g ] ww), ∃! (hh : pp -->[ BinCoproductArrow p f g ] ww), (transportf (λ z, _ -->[ z ] _) (BinCoproductIn1Commutes _ _ _ p _ f g) (ιι₁ ;; hh) = ff) × (transportf (λ z, _ -->[ z ] _) (BinCoproductIn2Commutes _ _ _ p _ f g) (ιι₂ ;; hh) = gg). Definition disp_BinCoproduct {x y : C} (xx : D x) (yy : D y) (p : BinCoproduct x y) : UU := ∑ (pp : D p) (ιι₁ : xx -->[ BinCoproductIn1 p ] pp) (ιι₂ : yy -->[ BinCoproductIn2 p ] pp), disp_isBinCoproduct p pp ιι₁ ιι₂. Definition disp_BinCoproducts (PC : BinCoproducts C) : UU := ∏ (x y : C) (xx : D x) (yy : D y), disp_BinCoproduct xx yy (PC x y). Section TotalBinCoproduct. Context (x_xx y_yy : total_category D). Let x : C := pr1 x_xx. Let y : C := pr1 y_yy. Let xx : D x := pr2 x_xx. Let yy : D y := pr2 y_yy. Context (p : BinCoproduct x y) (pp : disp_BinCoproduct xx yy p). Definition total_category_BinCoproduct : total_category D := _ ,, pr1 pp. Definition total_category_BinCoproductIn1 : x_xx --> total_category_BinCoproduct := _ ,, pr12 pp. Definition total_category_BinCoproductIn2 : y_yy --> total_category_BinCoproduct := _ ,, pr122 pp. Section TotalBinCoproductUMP. Context {w : C} (ww : D w) {f : x --> w} (ff : xx -->[ f ] ww) {g : y --> w} (gg : yy -->[ g ] ww). Let t_w : total_category D := w ,, ww. Let t_f : x_xx --> t_w := f ,, ff. Let t_g : y_yy --> t_w := g ,, gg. Proposition total_category_BinCoproductUnique : isaprop (∑ (fg : total_category_BinCoproduct --> t_w), (total_category_BinCoproductIn1 · fg = t_f) × (total_category_BinCoproductIn2 · fg = t_g)). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use isapropdirprod ; apply homset_property. } use total2_paths_f. - use BinCoproductArrowsEq. + exact (maponpaths pr1 (pr12 φ₁ @ !(pr12 φ₂))). + exact (maponpaths pr1 (pr22 φ₁ @ !(pr22 φ₂))). - assert (r : pr11 φ₂ = BinCoproductArrow p f g). { use BinCoproductArrowsEq. + refine (maponpaths pr1 (pr12 φ₂) @ _). cbn. rewrite BinCoproductIn1Commutes. apply idpath. + refine (maponpaths pr1 (pr22 φ₂) @ _). cbn. rewrite BinCoproductIn2Commutes. apply idpath. } rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (pr21 φ₂)). rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (transportf _ _ _)). apply maponpaths. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr222 pp w ww f ff g gg)) (transportf _ _ _ ,, _) (transportf _ _ _ ,, _))). + cbn. split. * rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr12 φ₁)). apply maponpaths_2. apply homset_property. * rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr22 φ₁)). apply maponpaths_2. apply homset_property. + cbn. split. * rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr12 φ₂)). apply maponpaths_2. apply homset_property. * rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr22 φ₂)). apply maponpaths_2. apply homset_property. Qed. Definition total_category_BinCoproductArrow : total_category_BinCoproduct --> t_w := _ ,, pr11 (pr222 pp w ww f ff g gg). Proposition total_category_BinCoproductArrowIn1 : total_category_BinCoproductIn1 · total_category_BinCoproductArrow = t_f. Proof. use total2_paths_f. - apply BinCoproductIn1Commutes. - exact (pr121 (pr222 pp w ww f ff g gg)). Qed. Proposition total_category_BinCoproductArrowIn2 : total_category_BinCoproductIn2 · total_category_BinCoproductArrow = t_g. Proof. use total2_paths_f. - apply BinCoproductIn2Commutes. - exact (pr221 (pr222 pp w ww f ff g gg)). Qed. End TotalBinCoproductUMP. Definition total_category_isBinCoproduct : isBinCoproduct _ _ _ total_category_BinCoproduct total_category_BinCoproductIn1 total_category_BinCoproductIn2. Proof. intros w f g. use iscontraprop1. - apply total_category_BinCoproductUnique. - simple refine (_ ,, _ ,, _). + exact (total_category_BinCoproductArrow (pr2 w) (pr2 f) (pr2 g)). + apply total_category_BinCoproductArrowIn1. + apply total_category_BinCoproductArrowIn2. Defined. End TotalBinCoproduct. Definition total_BinCoproducts (PC : BinCoproducts C) (DC : disp_BinCoproducts PC) : BinCoproducts (total_category D). Proof. intros x y. use make_BinCoproduct. - exact (total_category_BinCoproduct x y (PC (pr1 x) (pr1 y)) (DC _ _ (pr2 x) (pr2 y))). - exact (total_category_BinCoproductIn1 x y (PC (pr1 x) (pr1 y)) (DC _ _ (pr2 x) (pr2 y))). - exact (total_category_BinCoproductIn2 x y (PC (pr1 x) (pr1 y)) (DC _ _ (pr2 x) (pr2 y))). - exact (total_category_isBinCoproduct x y (PC (pr1 x) (pr1 y)) (DC _ _ (pr2 x) (pr2 y))). Defined. (** Displayed coproducts indexed over arbitrary types *) Section FixType. Context (I : UU). Definition disp_isCoproduct {d : I → C} (dd : ∏ (i : I), D (d i)) (p : Coproduct I C d) (pp : D p) (ππ : ∏ (i : I), dd i -->[ CoproductIn _ _ p i ] pp) : UU := ∏ (w : C) (ww : D w) (f : ∏ (i : I), d i --> w) (ff : ∏ (i : I), dd i -->[ f i ] ww), ∃! (hh : pp -->[ CoproductArrow _ _ p f ] ww), ∏ (i : I), transportf (λ z, _ -->[ z ] _) (CoproductInCommutes _ _ _ p _ f i) (ππ i ;; hh) = ff i. Definition disp_Coproduct {d : I → C} (dd : ∏ (i : I), D (d i)) (p : Coproduct I C d) : UU := ∑ (pp : D p) (ππ : ∏ (i : I), dd i -->[ CoproductIn _ _ p i ] pp), disp_isCoproduct dd p pp ππ. Definition disp_Coproducts (PC : Coproducts I C) : UU := ∏ (d : I → C) (dd : ∏ (i : I), D (d i)), disp_Coproduct dd (PC d). Section TotalCoproduct. Context (d_dd : I → total_category D). Let d : I → C := λ i, pr1 (d_dd i). Let dd : ∏ (i : I), D (d i) := λ i, pr2 (d_dd i). Context (p : Coproduct I C d) (pp : disp_Coproduct dd p). Definition total_category_Coproduct : total_category D := _ ,, pr1 pp. Definition total_category_CoproductIn (i : I) : d_dd i --> total_category_Coproduct := _ ,, pr12 pp i. Section TotalCoproductUMP. Context {w : C} (ww : D w) {f : ∏ (i : I), d i --> w} (ff : ∏ (i : I), dd i -->[ f i ] ww). Let t_w : total_category D := w ,, ww. Let t_f : ∏ (i : I), d_dd i --> t_w := λ i, f i ,, ff i. Proposition total_category_CoproductUnique : isaprop (∑ (φ : total_category_Coproduct --> t_w), ∏ (i : I), total_category_CoproductIn i · φ = t_f i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use total2_paths_f. - use CoproductArrow_eq. intro i. exact (maponpaths pr1 (pr2 φ₁ i @ !(pr2 φ₂ i))). - assert (r : pr11 φ₂ = CoproductArrow _ _ p f). { use CoproductArrow_eq. intro i. refine (maponpaths pr1 (pr2 φ₂ i) @ _). cbn. rewrite CoproductInCommutes. apply idpath. } rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (pr21 φ₂)). rewrite <- (transportbfinv (λ z, _ -->[ z ] _) r (transportf _ _ _)). apply maponpaths. use (maponpaths pr1 (proofirrelevance _ (isapropifcontr (pr22 pp w ww f ff)) (transportf _ _ _ ,, _) (transportf _ _ _ ,, _))). + cbn. intro i. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (_ @ fiber_paths (pr2 φ₁ i)). apply maponpaths_2. apply homset_property. + cbn. intro i. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. refine (_ @ fiber_paths (pr2 φ₂ i)). apply maponpaths_2. apply homset_property. Qed. Definition total_category_CoproductArrow : total_category_Coproduct --> t_w := _ ,, pr11 (pr22 pp w ww f ff). Proposition total_category_CoproductInCommutes (i : I) : total_category_CoproductIn i · total_category_CoproductArrow = t_f i. Proof. use total2_paths_f. - exact (CoproductInCommutes _ _ _ p _ _ i). - exact (pr21 (pr22 pp w ww f ff) i). Qed. End TotalCoproductUMP. Definition total_category_isCoproduct : isCoproduct _ _ _ total_category_Coproduct total_category_CoproductIn. Proof. intros w f. use iscontraprop1. - apply total_category_CoproductUnique. - simple refine (_ ,, _). + exact (total_category_CoproductArrow (pr2 w) (λ i, pr2 (f i))). + exact (total_category_CoproductInCommutes (pr2 w) (λ i, pr2 (f i))). Defined. End TotalCoproduct. Definition total_Coproducts (PC : Coproducts I C) (DC : disp_Coproducts PC) : Coproducts I (total_category D). Proof. intros d. use make_Coproduct. - exact (total_category_Coproduct d _ (DC _ _)). - exact (total_category_CoproductIn d _ (DC _ _)). - apply total_category_isCoproduct. Defined. End FixType. End FixDispCat. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/CatIsoDisplayed.v000066400000000000000000000165071451125700300255760ustar00rootroot00000000000000(* In this file, it is shown that the projection functor (from a displayed category to its base) is an isomorphism of categories, if the corresponding displayed category is trivial in the sense that the fibers (both over objects and morphisms) are contractible [forgetful_is_iso]. If the displayed category is univalent, the requirement that the fibers over any object are contractible can be weakenend to only requiring existence, i.e., chosen displayed objects. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Section DisplayedCatIso. Context {C : category} (D : disp_cat C). Context (uo : ∏ c : C, iscontr (D c)). Context (is_contr_disp_mor : ∏ (c1 c2 : C) (f : C⟦c1,c2⟧), iscontr (pr1 (uo c1) -->[f] (pr1 (uo c2)))). Lemma uf_eq {c1 c2 : C} (f : C⟦c1,c2⟧) : ∏ (d1 : D c1) (d2 : D c2), (d1 -->[f] d2) ≃ (pr1 (uo c1) -->[f] pr1 (uo c2)). Proof. intros d1 d2. assert (p1 : d1 = pr1 (uo c1)). { apply uo. } assert (p2 : d2 = pr1 (uo c2)). { apply uo. } induction p1. induction p2. apply idweq. Defined. Lemma uf0 {c1 c2 : C} (f : C⟦c1,c2⟧) : ∏ (d1 : D c1) (d2 : D c2), iscontr (d1 -->[f] d2). Proof. intros d1 d2. use (iscontrweqb' (is_contr_disp_mor _ _ f)). apply uf_eq. Defined. Lemma weq_hom' {c1 : C} {c2 : C} (f : C ⟦ c1, c2 ⟧) : ∃! x : (∑ f0 : C ⟦ c1, c2 ⟧, pr1 (uo c1) -->[ f0] pr1 (uo c2)), pr1 x = f. Proof. use tpair. - simple refine ((_ ,, _) ,, _). + exact f. + apply (pr1 (is_contr_disp_mor _ _ f)). + apply idpath. - intros [[g gg] p]. use subtypePath. { intro ; apply homset_property. } use subtypePath. { intro. apply isapropifcontr. apply is_contr_disp_mor. } exact p. Qed. Lemma weq_hom {c1 : C} {c2 : C} (d1 : D c1) (d2 : D c2) (f : C ⟦ c1, c2 ⟧) : ∃! x : (∑ f0 : C ⟦ c1, c2 ⟧, d1 -->[ f0] d2), pr1 x = f. Proof. use tpair. - simple refine ((_ ,, _) ,, _). + exact f. + apply uf0. + apply idpath. - cbn. intros [[g gg] q]. use subtypePath. { intro ; apply homset_property. } use subtypePath. { intro. apply isapropifcontr. apply uf0. } exact q. Qed. Lemma weq_ob (c : C) : ∃! x : (∑ x : C, D x), pr1 x = c. Proof. use tpair. - simple refine ((c ,, _) ,, _). + apply uo. + apply idpath. - intros [[c' d'] p]. cbn in *. use total2_paths_f. + use subtypePath. { intro ; apply isapropifcontr, uo. } exact p. + simpl. etrans. { apply (transportf_total2_paths_f (A := C) (B := λ x : C, D x) (λ x : C, x = c)). } induction p. apply idpath. Qed. Definition forgetful_is_iso : is_catiso (pr1_category D). Proof. split. - intros [c1 d1] [c2 d2] f. apply weq_hom. - intro c. apply weq_ob. Defined. End DisplayedCatIso. Section DisplayedCatIsoUnivalence. Context {C : category} (D : disp_cat C) (Duniv : is_univalent_disp D). Context (uo : ∏ c : C, D c) (uf : ∏ (c1 c2 : C) (f : C⟦c1,c2⟧) (d1 : D c1) (d2 : D c2), iscontr (d1 -->[f] d2)). Lemma only_isos_above_an_iso {c1 c2 : C} {f : C⟦c1,c2⟧} {d1 : D c1} {d2 : D c2} (ff : d1 -->[f] d2) : ∏ fi : is_z_isomorphism f, is_z_iso_disp (_ ,, fi) ff. Proof. intro fi. use tpair. * apply (uf c2 c1 (pr1 fi)). * split ; (apply proofirrelevance ; apply isapropifcontr ; apply uf). Qed. Lemma only_isos_above_an_id {c : C} (d1 d2 : D c) : is_z_iso_disp (idtoiso (idpath c)) (pr1 (uf _ _ (identity c) d1 d2)). Proof. apply only_isos_above_an_iso. Qed. Lemma z_iso_disp_iscontr {c : C} (d1 d2 : D c) : iscontr (z_iso_disp (idtoiso (idpath c)) d1 d2). Proof. use tpair. - refine (_ ,, _). apply only_isos_above_an_id. - intro i. use subtypePath. { intro ; apply isaprop_is_z_iso_disp. } apply proofirrelevance. apply isapropifcontr. apply uf. Qed. Lemma isaprop_uo (c : C) : isaprop (D c). Proof. intros d1 d2. use tpair. - use (isotoid_disp Duniv (idpath c)). exact (_ ,, only_isos_above_an_id d1 d2). - intro. apply proofirrelevance. apply isapropifcontr. refine (iscontrweqb _ (z_iso_disp_iscontr d1 d2)). unfold is_univalent_disp in Duniv. refine ( _ ,, _). apply Duniv. Qed. Definition forgetful_is_iso_univ : is_catiso (pr1_category D). Proof. use forgetful_is_iso. - intro. use tpair. + apply uo. + intro. apply isaprop_uo. - intro ; intros ; apply uf. Defined. End DisplayedCatIsoUnivalence. Section CatIsoToContractibleFibers. Context {C : category} {D : disp_cat C} (F : is_catiso (pr1_category D)). Let inv_i := inv_catiso (_ ,, F). Definition object_is_proj (x : C) : x = pr1 (inv_i x) := ! homotweqinvweq (make_weq pr1 (pr2 F)) x. Definition object_as_proj_equal_fibers (x : C) : D x ≃ D (pr1 (inv_i x)). Proof. induction (object_is_proj x). apply idweq. Defined. Let W := invweq (catiso_ob_weq (_ ,, F)) : ob C ≃ ∑ x : C, D x. Lemma catiso_is_globally_prop' (x : C) : ∏ d1 d2 : D x, x ,, d1 = x ,, d2. Proof. intros d1 d2. set (g := isinclweq _ _ _ (pr2 (invweq W)) x). set (h := g ((x ,, d1) ,, idpath _) ((x ,, d2) ,, idpath _)). exact (base_paths _ _ (pr1 h)). Defined. Lemma catiso_is_globally_prop (x : C) : ∏ d1 d2 : D x, d1 = d2. Proof. intros d1 d2. set (h := total2_section_path x d2 (λ z, invweq (object_as_proj_equal_fibers z) (pr2 (inv_i z)))). refine (_ @ h (catiso_is_globally_prop' x _ d2)). set (h' := total2_section_path x d1 (λ z, invweq (object_as_proj_equal_fibers z) (pr2 (inv_i z)))). exact (! h' (catiso_is_globally_prop' x _ d1)). Defined. Definition catiso_is_globally_contr (x : C) : iscontr (D x). Proof. use (iscontrweqb' _ (object_as_proj_equal_fibers x)). use tpair. - exact (pr2 (inv_i x)). - intro ; apply catiso_is_globally_prop. Defined. (* Definition catiso_is_locally_contr' {x y : C} (f : C⟦x, y⟧) : iscontr (pr2 (inv_i x) -->[Univalence.double_transport (object_is_proj x) (object_is_proj y) f] pr2 (inv_i y)). Proof. set (ff := pr2 (#inv_i f)). Admitted. Definition catiso_is_locally_contr {x y : C} (f : C⟦x, y⟧) : iscontr (pr1 (catiso_is_globally_contr x) -->[f] pr1 (catiso_is_globally_contr y)). Proof. use (iscontrweqb' (catiso_is_locally_contr' f)). Defined. *) End CatIsoToContractibleFibers. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Codomain.v000066400000000000000000000122041451125700300242740ustar00rootroot00000000000000 (** * The slice displayed category - Definition of the slice displayed category - Proof that a morphism is cartesian if and only if it is a pullback *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope cat. (** ** The displayed codomain The total category associated to this displayed category is going to be isomorphic to the arrow category, but it won't be the same: the components of the objects and morphisms will be arranged differently *) (* TODO: perhaps rename [slice_disp], and make [C] implicit? *) Section Codomain_Disp. Context (C : category). Definition cod_disp_ob_mor : disp_cat_ob_mor C. Proof. exists (λ x : C, ∑ y, y --> x). simpl; intros x y xx yy f. exact (∑ ff : pr1 xx --> pr1 yy, ff · pr2 yy = pr2 xx · f). Defined. Definition cod_id_comp : disp_cat_id_comp _ cod_disp_ob_mor. Proof. split. - simpl; intros. exists (identity _ ). abstract ( etrans; [apply id_left |]; apply pathsinv0, id_right ). - simpl; intros x y z f g xx yy zz ff gg. exists (pr1 ff · pr1 gg). abstract ( apply pathsinv0; etrans; [apply assoc |]; etrans; [apply maponpaths_2, (! (pr2 ff)) |]; etrans; [eapply pathsinv0, assoc |]; etrans; [apply maponpaths, (! (pr2 gg))|]; apply assoc). Defined. Definition cod_disp_data : disp_cat_data _ := (cod_disp_ob_mor ,, cod_id_comp). Lemma cod_disp_axioms : disp_cat_axioms C cod_disp_data. Proof. repeat apply tpair; intros; try apply homset_property. - apply subtypePath. { intro. apply homset_property. } etrans. apply id_left. destruct ff as [ff H]. apply pathsinv0. etrans. use (pr1_transportf (A := C⟦x,y⟧)). cbn; apply (eqtohomot (transportf_const _ _)). - apply subtypePath. { intro. apply homset_property. } etrans. apply id_right. destruct ff as [ff H]. apply pathsinv0. etrans. use (pr1_transportf (A := C⟦x,y⟧)). cbn; apply (eqtohomot (transportf_const _ _)). - apply subtypePath. { intro. apply homset_property. } etrans. apply assoc. destruct ff as [ff H]. apply pathsinv0. etrans. unfold mor_disp. use (pr1_transportf (A := C⟦x,w⟧)). cbn; apply (eqtohomot (transportf_const _ _)). - apply (isofhleveltotal2 2). + apply homset_property. + intro. apply isasetaprop. apply homset_property. Qed. Definition disp_codomain : disp_cat C := (cod_disp_data ,, cod_disp_axioms). End Codomain_Disp. Section Pullbacks_Cartesian. Context {C:category}. Definition isPullback_cartesian_in_cod_disp { Γ Γ' : C } {f : Γ' --> Γ} {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p) : (isPullback (pr2 ff)) -> is_cartesian ff. Proof. intros Hpb Δ g q hh. eapply iscontrweqf. 2: { use Hpb. + exact (pr1 q). + exact (pr1 hh). + simpl in q. use (pr2 q · g). + etrans. apply (pr2 hh). apply assoc. } eapply weqcomp. 2: apply weqtotal2asstol. apply weq_subtypes_iff. - intro. apply isapropdirprod; apply homset_property. - intro. apply (isofhleveltotal2 1). + apply homset_property. + intros. apply homsets_disp. - intros gg; split; intros H. + exists (pr2 H). apply subtypePath. intro; apply homset_property. exact (pr1 H). + split. * exact (maponpaths pr1 (pr2 H)). * exact (pr1 H). Qed. Definition cartesian_isPullback_in_cod_disp { Γ Γ' : C } {f : Γ' --> Γ} {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p) : (isPullback (pr2 ff)) <- is_cartesian ff. Proof. intros cf c h k H. destruct p as [a x]. destruct p' as [b y]. destruct ff as [H1 H2]. unfold is_cartesian in cf. simpl in *. eapply iscontrweqf. 2: { use cf. + exact Γ'. + exact (identity _ ). + exists c. exact k. + cbn. exists h. etrans. apply H. apply maponpaths. apply (! id_left _ ). } eapply weqcomp. apply weqtotal2asstor. apply weq_subtypes_iff. - intro. apply (isofhleveltotal2 1). + apply homset_property. + intros. match goal with |[|- isofhlevel 1 (?x = _ )] => set (X := x) end. set (XR := @homsets_disp _ (disp_codomain C )). specialize (XR _ _ _ _ _ X). apply XR. - cbn. intro. apply isapropdirprod; apply homset_property. - intros gg; split; intros HRR. + split. * exact (maponpaths pr1 (pr2 HRR)). * etrans. apply (pr1 HRR). apply id_right. + use tpair. * rewrite id_right. exact (pr2 HRR). * apply subtypePath. intro; apply homset_property. exact (pr1 HRR). Qed. Definition cartesian_iff_isPullback { Γ Γ' : C } {f : Γ' --> Γ} {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p) : (isPullback (pr2 ff)) <-> is_cartesian ff. Proof. split. - apply isPullback_cartesian_in_cod_disp. - apply cartesian_isPullback_in_cod_disp. Defined. End Pullbacks_Cartesian. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/ComprehensionC.v000066400000000000000000000125231451125700300254630ustar00rootroot00000000000000 (** * Displayed Category from a category with display maps Definition of the displayed category of display maps over a category [C] Given a category with display maps [C], we define a displayed category over [C]. Objects over [c:C] are display maps into [c]. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Codomain. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope cat. (** * Definition of a cartesian displayed functor *) (* TODO: upstream to with definition of fibrations/cartesianness *) Definition is_cartesian_disp_functor {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') : UU := ∏ (c c' : C) (f : c' --> c) (d : D c) (d' : D c') (ff : d' -->[f] d), is_cartesian ff -> is_cartesian (♯ FF ff). (* TODO: upstream *) Lemma isaprop_is_cartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : isaprop (is_cartesian ff). Proof. repeat (apply impred_isaprop; intro). apply isapropiscontr. Qed. (* TODO: upstream *) Lemma is_cartesian_from_z_iso_to_cartesian {C : category} {D : disp_cat C} {c} {d : D c} {c' : C} {f : c' --> c} {d0'} {ff : d0' -->[f] d} (ff_cart : is_cartesian ff) {d1'} {ff' : d1' -->[f] d} (i : z_iso_disp (identity_z_iso _) d0' d1') (e : (i ;; ff')%mor_disp = transportb _ (id_left _) ff) : is_cartesian ff'. Proof. intros c'' g d'' h. refine (iscontrweqf _ (ff_cart c'' g d'' h)). use weq_subtypes'. - eapply weqcomp. + exists (fun gg => (gg ;; i))%mor_disp. apply z_iso_disp_postcomp. + exists (transportf _ (id_right _)). apply isweqtransportf. - intro; apply homsets_disp. - intro; apply homsets_disp. - simpl. intros gg. (* Better, if [weq_pathscomp0] existed: apply weq_to_iff, weq_pathscomp0. *) assert (forall X (x y z : X), x = y -> (x = z <-> y = z)) as H. { intros X x y z p; split. + intros q; exact (!p @ q). + intros q; exact (p @ q). } apply H. apply pathsinv0. etrans. apply mor_disp_transportf_postwhisker. etrans. eapply transportf_bind. apply assoc_disp_var. etrans. eapply transportf_bind. etrans. apply maponpaths, e. apply mor_disp_transportf_prewhisker. refine (_ @ idpath_transportf _ _). apply maponpaths_2, homset_property. Defined. (* TODO: upstream *) (* TODO: upstream also *) (** For a functor to be cartesian, it’s enough to show that it preserves _some_ cartesian lift of each lifting problem. Of course, this can only happen when the domain is a fibration; and in practice, it is useful exactly in the case where one has shown it is a fibration by exhibiting some particular construction of (mere existence of) cartesian lifts. *) Lemma cartesian_functor_from_fibration {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'} (H : forall (c c' : C) (f : c' --> c) (d : D c), ∥ total2 (fun ff : cartesian_lift d f => is_cartesian (♯ FF ff)) ∥) : is_cartesian_disp_functor FF. Proof. intros c c' f d d' ff ff_cart. use (squash_to_prop (H _ _ f d)). - apply isaprop_is_cartesian. - intros [ff' ff'_cart]. use (is_cartesian_from_z_iso_to_cartesian ff'_cart). + refine (transportf (fun i => z_iso_disp i _ _) _ (@disp_functor_on_z_iso_disp _ _ _ _ _ FF _ _ _ _ (identity_z_iso _) _)). apply (z_iso_eq _ _), functor_id. refine (cartesian_lifts_iso ff' (_,,_)). exact (_,,ff_cart). + etrans. { apply maponpaths_2. refine (@pr1_transportf _ _ (fun i ff => is_z_iso_disp i ff) _ _ _ _). } etrans. { apply maponpaths_2. apply functtransportf. } etrans. { apply mor_disp_transportf_postwhisker. } etrans. { eapply maponpaths. simpl. etrans. { eapply pathsinv0, disp_functor_comp_var. } eapply transportf_bind. etrans. { apply maponpaths, cartesian_factorisation_commutes'. } apply disp_functor_transportf. } etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Qed. Lemma cartesian_functor_from_cleaving {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'} (clD : cleaving D) (H : forall c c' f d, is_cartesian (♯ FF (clD c c' f d))) : is_cartesian_disp_functor FF. Proof. apply cartesian_functor_from_fibration. intros c c' f d. apply hinhpr. exists (clD c c' f d). apply H. Qed. Definition comprehension_cat_structure (C : category) : UU := ∑ (D : disp_cat C) (H : cleaving D) (F : disp_functor (functor_identity _ ) D (disp_codomain C)), is_cartesian_disp_functor F. Arguments comprehension_cat_structure _ : clear implicits. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Constructions.v000066400000000000000000000676401451125700300254360ustar00rootroot00000000000000 (** Some important constructions on displayed categories Partial contents: - Full subcategory as total category of a displayed category - Displayed category given by a structure on objects and a proposition on morphisms of the base category - Direct products of displayed categories (and their projections) - [dirprod_disp_cat D1 D2] - [dirprodpr1_disp_functor], [dirprodpr2_disp_functor] - Sigmas of displayed categories - Displayed functor cat *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. (* Needed for [functor_lifting]. *) Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Local Open Scope cat. Local Open Scope mor_disp_scope. Section Auxiliary. (* TODO: Move this to another file *) Lemma isweqcontrprop (X Y : UU) (f : X → Y) : iscontr X → isaprop Y → isweq f. Proof. intros HX HY. apply isweqimplimpl. - intros. apply HX. - apply isapropifcontr. apply HX. - apply HY. Defined. End Auxiliary. (** * Full subcategories *) Section full_subcat. Definition disp_full_sub_ob_mor (C : precategory_ob_mor) (P : C → UU) : disp_cat_ob_mor C := (P,, (λ a b aa bb f, unit)). Definition disp_full_sub_id_comp (C : precategory_data) (P : C → UU) : disp_cat_id_comp C (disp_full_sub_ob_mor C P). Proof. split; intros; apply tt. Defined. Definition disp_full_sub_data (C : precategory_data) (P : C → UU) : disp_cat_data C := disp_full_sub_ob_mor C P,, disp_full_sub_id_comp C P. Lemma disp_full_sub_locally_prop (C : category) (P : C → UU) : locally_propositional (disp_full_sub_data C P). Proof. intro; intros; apply isapropunit. Qed. Definition disp_full_sub (C : category) (P : C → UU) : disp_cat C. Proof. use make_disp_cat_locally_prop. - exact (disp_full_sub_data C P). - apply disp_full_sub_locally_prop. Defined. Lemma disp_full_sub_univalent (C : category) (P : C → UU) : (∏ x : C, isaprop (P x)) → is_univalent_disp (disp_full_sub C P). Proof. intro HP. apply is_univalent_disp_from_fibers. intros x xx xx'. cbn in *. apply isweqcontrprop. apply HP. apply isofhleveltotal2. - apply isapropunit. - intro. apply (@isaprop_is_z_iso_disp _ (disp_full_sub C P)). Defined. Definition full_subcat (C : category) (P : C → UU) : category := total_category (disp_full_sub C P). Definition is_univalent_full_subcat (C : category) (univC : is_univalent C) (P : C → UU) : (∏ x : C, isaprop (P x)) → is_univalent (full_subcat C P). Proof. intro H. apply is_univalent_total_category. - exact univC. - exact (disp_full_sub_univalent _ _ H). Defined. End full_subcat. (** * Displayed category from structure on objects and compatibility on morphisms *) Section struct_hom. Variable C : category. (* Variable univC : is_univalent C. *) Variable P : ob C -> UU. (* Variable Pisset : ∏ x, isaset (P x). *) Variable H : ∏ (x y : C), P x → P y → C⟦x,y⟧ → UU. Arguments H {_ _} _ _ _ . Variable Hisprop : ∏ x y a b (f : C⟦x,y⟧), isaprop (H a b f). Variable Hid : ∏ (x : C) (a : P x), H a a (identity _ ). Variable Hcomp : ∏ (x y z : C) a b c (f : C⟦x,y⟧) (g : C⟦y,z⟧), H a b f → H b c g → H a c (f · g). Definition disp_struct_ob_mor : disp_cat_ob_mor C. Proof. exists P. intros ? ? f a b; exact (H f a b ). Defined. Definition disp_struct_id_comp : disp_cat_id_comp _ disp_struct_ob_mor. Proof. split; cbn; intros. - apply Hid. - eapply Hcomp. apply X. apply X0. Qed. Definition disp_struct_data : disp_cat_data C := _ ,, disp_struct_id_comp. Definition disp_struct : disp_cat C. Proof. use make_disp_cat_locally_prop. - exact disp_struct_data. - intro; intros; apply Hisprop. Defined. End struct_hom. (** * Products of displayed (pre)categories We directly define direct products of displayed categories over a base. An alternative would be to define the direct product as the [sigma_disp_cat] of the pullback to either factor. *) Definition dirprod_disp_cat_ob_mor {C : precategory_ob_mor} (D1 D2 : disp_cat_ob_mor C) : disp_cat_ob_mor C. Proof. exists (λ c, D1 c × D2 c). intros x y xx yy f. exact (pr1 xx -->[f] pr1 yy × pr2 xx -->[f] pr2 yy). Defined. Definition dirprod_disp_cat_id_comp {C : precategory_data} (D1 D2 : disp_cat_data C) : disp_cat_id_comp _ (dirprod_disp_cat_ob_mor D1 D2). Proof. apply tpair. - intros x (x1, x2). exact (id_disp x1,, id_disp x2). - intros x y z f g xx yy zz ff gg. exact ((pr1 ff ;; pr1 gg),, (pr2 ff ;; pr2 gg)). Defined. Definition dirprod_disp_cat_data {C : precategory_data} (D1 D2 : disp_cat_data C) : disp_cat_data C := (_ ,, dirprod_disp_cat_id_comp D1 D2). Section Dirprod. Context {C : category} (D1 D2 : disp_cat C). Definition dirprod_disp_cat_axioms : disp_cat_axioms _ (dirprod_disp_cat_data D1 D2). Proof. repeat apply make_dirprod. - intros. apply dirprod_paths; use (id_left_disp _ @ !_). + use pr1_transportf. + apply pr2_transportf. - intros. apply dirprod_paths; use (id_right_disp _ @ !_). + use pr1_transportf. + apply pr2_transportf. - intros. apply dirprod_paths; use (assoc_disp _ _ _ @ !_). + use pr1_transportf. + apply pr2_transportf. - intros. apply isaset_dirprod; apply homsets_disp. Qed. Definition dirprod_disp_cat : disp_cat C := (_ ,, dirprod_disp_cat_axioms). (** ** Characterization of the isomorphisms of the direct product of displayed categories *) (** TODO: generalize over an aritrary base isomorphism *) Definition z_iso_disp_prod1 {x : C} (xx1 xx1' : D1 x) (xx2 xx2' : D2 x) : @z_iso_disp _ dirprod_disp_cat _ _ (identity_z_iso x) (xx1,, xx2) (xx1',, xx2') → (z_iso_disp (identity_z_iso x) xx1 xx1') × (z_iso_disp (identity_z_iso x) xx2 xx2'). Proof. unfold z_iso_disp. cbn. intros [[f1 f2] Hff]. destruct Hff as [[g1 g2] Hfg]. cbn in Hfg. destruct Hfg as [Hgf Hfg]. use tpair. - exists f1, g1. split. + etrans. apply (maponpaths dirprod_pr1 Hgf). apply pr1_transportf. + etrans. apply (maponpaths dirprod_pr1 Hfg). apply pr1_transportf. - exists f2, g2. split. + etrans. apply (maponpaths dirprod_pr2 Hgf). apply pr2_transportf. + etrans. apply (maponpaths dirprod_pr2 Hfg). apply pr2_transportf. Defined. Definition z_iso_disp_prod2 {x : C} (xx1 xx1' : D1 x) (xx2 xx2' : D2 x) : (z_iso_disp (identity_z_iso x) xx1 xx1') × (z_iso_disp (identity_z_iso x) xx2 xx2') → @z_iso_disp _ dirprod_disp_cat _ _ (identity_z_iso x) (xx1,, xx2) (xx1',, xx2'). Proof. unfold z_iso_disp. cbn. intros [[f1 Hf1] [f2 Hf2]]. destruct Hf1 as [g1 [Hgf1 Hfg1]]. destruct Hf2 as [g2 [Hgf2 Hfg2]]. exists (f1,,f2), (g1,,g2). split. - apply dirprod_paths. + etrans. apply Hgf1. apply pathsinv0. apply pr1_transportf. + etrans. apply Hgf2. apply pathsinv0. apply pr2_transportf. - apply dirprod_paths. + etrans. apply Hfg1. apply pathsinv0. apply pr1_transportf. + etrans. apply Hfg2. apply pathsinv0. apply pr2_transportf. Defined. Lemma z_iso_disp_prod21 {x : C} (xx1 xx1' : D1 x) (xx2 xx2' : D2 x) i : z_iso_disp_prod2 xx1 xx1' xx2 xx2' (z_iso_disp_prod1 xx1 xx1' xx2 xx2' i) = i. Proof. apply eq_z_iso_disp. cbn. reflexivity. Qed. Lemma z_iso_disp_prod12 {x : C} (xx1 xx1' : D1 x) (xx2 xx2' : D2 x) (t : z_iso_disp (identity_z_iso x) xx1 xx1' × z_iso_disp (identity_z_iso x) xx2 xx2') : z_iso_disp_prod1 xx1 xx1' xx2 xx2' (z_iso_disp_prod2 xx1 xx1' xx2 xx2' t) = t. Proof. apply dirprod_paths. - apply eq_z_iso_disp. cbn. reflexivity. - apply eq_z_iso_disp. cbn. reflexivity. Qed. Lemma z_iso_disp_prod_weq (x : C) (xx1 xx1' : D1 x) (xx2 xx2' : D2 x) : @z_iso_disp _ dirprod_disp_cat _ _ (identity_z_iso x) (xx1,, xx2) (xx1',, xx2') ≃ (z_iso_disp (identity_z_iso x) xx1 xx1') × (z_iso_disp (identity_z_iso x) xx2 xx2'). Proof. exists (z_iso_disp_prod1 xx1 xx1' xx2 xx2'). use isweq_iso. - apply z_iso_disp_prod2. - apply z_iso_disp_prod21. - apply z_iso_disp_prod12. Defined. Lemma z_iso_disp_aux_weq (U1 : is_univalent_in_fibers D1) (U2 : is_univalent_in_fibers D2) (x : C) (xx xx' : D1 x × D2 x) : xx = xx' ≃ @z_iso_disp _ dirprod_disp_cat _ _ (identity_z_iso x) xx xx'. Proof. eapply weqcomp. apply pathsdirprodweq. apply invweq. eapply weqcomp. apply z_iso_disp_prod_weq. apply invweq. apply weqdirprodf. - exists idtoiso_fiber_disp. apply U1. - exists idtoiso_fiber_disp. apply U2. Defined. Lemma dirprod_disp_cat_is_univalent : is_univalent_disp D1 → is_univalent_disp D2 → is_univalent_disp dirprod_disp_cat. Proof. intros HD1 HD2. apply is_univalent_disp_from_fibers. intros x xx xx'. use isweqhomot. - apply z_iso_disp_aux_weq. + apply is_univalent_in_fibers_from_univalent_disp. apply HD1. + apply is_univalent_in_fibers_from_univalent_disp. apply HD2. - intros p. induction p. cbn. apply (@eq_z_iso_disp _ dirprod_disp_cat). reflexivity. - apply z_iso_disp_aux_weq. Defined. Definition dirprodpr1_disp_functor_data : disp_functor_data (functor_identity C) dirprod_disp_cat (D1). Proof. use tpair. - intros x xx; exact (pr1 xx). - intros x y xx yy f ff; exact (pr1 ff). Defined. Definition dirprodpr1_disp_functor_axioms : disp_functor_axioms dirprodpr1_disp_functor_data. Proof. split. - intros; apply idpath. - intros; apply idpath. Qed. Definition dirprodpr1_disp_functor : disp_functor (functor_identity C) dirprod_disp_cat (D1) := (dirprodpr1_disp_functor_data,, dirprodpr1_disp_functor_axioms). Definition dirprodpr2_disp_functor_data : disp_functor_data (functor_identity C) dirprod_disp_cat (D2). Proof. use tpair. - intros x xx; exact (pr2 xx). - intros x y xx yy f ff; exact (pr2 ff). Defined. Definition dirprodpr2_disp_functor_axioms : disp_functor_axioms dirprodpr2_disp_functor_data. Proof. split. - intros; apply idpath. - intros; apply idpath. Qed. Definition dirprodpr2_disp_functor : disp_functor (functor_identity C) dirprod_disp_cat (D2) := (dirprodpr2_disp_functor_data,, dirprodpr2_disp_functor_axioms). End Dirprod. Declare Scope disp_cat_scope. Notation "D1 × D2" := (dirprod_disp_cat D1 D2) : disp_cat_scope. Delimit Scope disp_cat_scope with disp_cat. Bind Scope disp_cat_scope with disp_cat. (** ** Functors into displayed categories *) (** Just like how context morphisms in a CwA can be built up out of terms, similarly, the basic building-block for functors into (total cats of) displayed categories will be analogous to a term. We call it a _section_ (though we define it intrinsically, not as a section in a (bi)category), since it corresponds to a section of the forgetful functor. *) Section Sections. Definition section_disp_data {C} (D : disp_cat C) : UU := ∑ (Fob : forall x:C, D x), (forall (x y:C) (f:x --> y), Fob x -->[f] Fob y). Definition section_disp_on_objects {C} {D : disp_cat C} (F : section_disp_data D) (x : C) := pr1 F x : D x. Coercion section_disp_on_objects : section_disp_data >-> Funclass. Definition section_disp_on_morphisms {C} {D : disp_cat C} (F : section_disp_data D) {x y : C} (f : x --> y) := pr2 F _ _ f : F x -->[f] F y. Notation "# F" := (section_disp_on_morphisms F) (at level 3) : mor_disp_scope. Definition section_disp_axioms {C} {D : disp_cat C} (F : section_disp_data D) : UU := ((forall x:C, # F (identity x) = id_disp (F x)) × (forall (x y z : C) (f : x --> y) (g : y --> z), # F (f · g) = (# F f) ;; (# F g))). Definition section_disp {C} (D : disp_cat C) : UU := total2 (@section_disp_axioms C D). Definition section_disp_data_from_section_disp {C} {D : disp_cat C} (F : section_disp D) := pr1 F. Coercion section_disp_data_from_section_disp : section_disp >-> section_disp_data. Definition section_disp_id {C} {D : disp_cat C} (F : section_disp D) := pr1 (pr2 F). Definition section_disp_comp {C} {D : disp_cat C} (F : section_disp D) := pr2 (pr2 F). End Sections. (** With sections defined, we can now define _lifts_ to a displayed category of a functor into the base. *) Section Functor_Lifting. Notation "# F" := (section_disp_on_morphisms F) (at level 3) : mor_disp_scope. Definition functor_lifting {C C' : category} (D : disp_cat C) (F : functor C' C) := section_disp (reindex_disp_cat F D). Identity Coercion section_from_functor_lifting : functor_lifting >-> section_disp. (** Note: perhaps it would be better to define [functor_lifting] directly? Reindexed displayed-cats are a bit confusing to work in, since a term like [id_disp xx] is ambiguous: it can mean both the identity in the original displayed category, or the identity in the reindexing, which is nearly but not quite the same. This shows up already in the proofs of [lifted_functor_axioms] below. *) Definition lifted_functor_data {C C' : category} {D : disp_cat C} {F : functor C' C} (FF : functor_lifting D F) : functor_data C' (total_category D). Proof. exists (λ x, (F x ,, FF x)). intros x y f. exists (# F f)%cat. exact (# FF f). Defined. Definition lifted_functor_axioms {C C' : category} {D : disp_cat C} {F : functor C' C} (FF : functor_lifting D F) : is_functor (lifted_functor_data FF). Proof. split. - intros x. use total2_paths_f; simpl. apply functor_id. eapply pathscomp0. apply maponpaths, (section_disp_id FF). cbn. apply transportfbinv. - intros x y z f g. use total2_paths_f; simpl. apply functor_comp. eapply pathscomp0. apply maponpaths, (section_disp_comp FF). cbn. apply transportfbinv. Qed. Definition lifted_functor {C C' : category} {D : disp_cat C} {F : functor C' C} (FF : functor_lifting D F) : functor C' (total_category D) := (_ ,, lifted_functor_axioms FF). Lemma from_lifted_functor {C C' : category} {D : disp_cat C} {F : functor C' C} (FF : functor_lifting D F): functor_composite (lifted_functor FF) (pr1_category D) = F. Proof. use (functor_eq _ _ (homset_property C)). apply idpath. Qed. (** redo the development for the special case that F is the identity *) Definition section_functor_data {C : category} {D : disp_cat C} (sd : section_disp D) : functor_data C (total_category D). Proof. exists (λ x, (x ,, sd x)). intros x y f. exists f. exact (section_disp_on_morphisms sd f). Defined. Definition section_functor_axioms {C : category} {D : disp_cat C} (sd : section_disp D) : is_functor (section_functor_data sd). Proof. split. - intro x. use total2_paths_f; simpl. + apply idpath. + apply (section_disp_id sd). - intros x y z f g. use total2_paths_f; simpl. + apply idpath. + apply (section_disp_comp sd). Qed. Definition section_functor {C : category} {D : disp_cat C} (sd : section_disp D): functor C (total_category D) := section_functor_data sd,, section_functor_axioms sd. Lemma from_section_functor {C : category} {D : disp_cat C} (sd : section_disp D): functor_composite (section_functor sd) (pr1_category D) = functor_identity C. Proof. use (functor_eq _ _ (homset_property C)). apply idpath. Qed. End Functor_Lifting. (* Natural transformations of sections *) Section Section_transformation. Definition section_nat_trans_disp_data {C : category} {D : disp_cat C} (F F' : section_disp D) : UU := ∏ (x : C), F x -->[identity _] F' x. Definition section_nat_trans_disp_axioms {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp_data F F') : UU := ∏ x x' (f : x --> x'), transportf _ (id_right _ @ !(id_left _)) (section_disp_on_morphisms F f ;; nt x') = nt x ;; section_disp_on_morphisms F' f. Lemma isaprop_section_nat_trans_disp_axioms {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp_data F F') : isaprop (section_nat_trans_disp_axioms nt). Proof. do 3 (apply impred; intro). apply homsets_disp. Qed. Definition section_nat_trans_disp {C : category} {D : disp_cat C} (F F': section_disp D) : UU := ∑ (nt : section_nat_trans_disp_data F F'), section_nat_trans_disp_axioms nt. Definition section_nt_disp_data_from_section_nt_disp {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : section_nat_trans_disp_data F F' := pr1 nt. Definition section_nat_trans_data_from_section_nat_trans_disp_funclass {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : ∏ x : ob C, F x -->[identity _] F' x := section_nt_disp_data_from_section_nt_disp nt. Coercion section_nat_trans_data_from_section_nat_trans_disp_funclass : section_nat_trans_disp >-> Funclass. Definition section_nt_disp_axioms_from_section_nt_disp {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : section_nat_trans_disp_axioms nt := pr2 nt. Definition section_nat_trans_data {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : nat_trans_data (section_functor F) (section_functor F'). Proof. intro x. exists (identity _). exact (nt x). Defined. Definition section_nat_trans_axioms {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : is_nat_trans (section_functor F) (section_functor F') (section_nat_trans_data nt). Proof. intros x x' f. use total2_paths_f. - simpl. now rewrite id_left, id_right. - simpl. rewrite <- (section_nt_disp_axioms_from_section_nt_disp nt). apply transportf_paths. apply homset_property. Qed. Definition section_nat_trans {C : category} {D : disp_cat C} {F F': section_disp D} (nt : section_nat_trans_disp F F') : nat_trans (section_functor F) (section_functor F') := section_nat_trans_data nt,, section_nat_trans_axioms nt. Definition section_nat_trans_id {C : category} {D : disp_cat C} (F : section_disp D) : section_nat_trans_disp F F. Proof. use tpair. - intro. exact (id_disp _). - simpl. intros x x' f. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Defined. Definition section_nat_trans_comp {C : category} {D : disp_cat C} {F F' F'': section_disp D} (FF' : section_nat_trans_disp F F') (F'F'' : section_nat_trans_disp F' F'') : section_nat_trans_disp F F''. Proof. use tpair. - intro x. exact (transportf _ (id_left _) (FF' x ;; F'F'' x)). - simpl. intros x x' f. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var, transport_f_f. rewrite <- (section_nt_disp_axioms_from_section_nt_disp F'F''). rewrite mor_disp_transportf_prewhisker, transport_f_f. do 2 rewrite assoc_disp, transport_f_b. rewrite <- (section_nt_disp_axioms_from_section_nt_disp FF'). rewrite mor_disp_transportf_postwhisker, transport_f_f. apply maponpaths_2. apply homset_property. Defined. Lemma section_nat_trans_eq {C : category} {D : disp_cat C} (F F' : section_disp D) (a a' : section_nat_trans_disp F F'): (∏ x, a x = a' x) -> a = a'. Proof. intro H. assert (H' : pr1 a = pr1 a'). { now apply funextsec. } apply (total2_paths_f H'). apply proofirrelevance. apply isaprop_section_nat_trans_disp_axioms. Qed. Definition section_nat_trans_id_left {C : category} {D : disp_cat C} {F F': section_disp D} (FF' : section_nat_trans_disp F F') : section_nat_trans_comp (section_nat_trans_id F) FF' = FF'. Proof. use section_nat_trans_eq. intro x. simpl. rewrite id_left_disp. rewrite transport_f_b. apply transportf_set. apply homset_property. Qed. Definition section_nat_trans_id_right {C : category} {D : disp_cat C} {F F': section_disp D} (FF' : section_nat_trans_disp F F') : section_nat_trans_comp FF' (section_nat_trans_id F') = FF'. Proof. use section_nat_trans_eq. intro x. simpl. rewrite id_right_disp. rewrite transport_f_b. apply transportf_set. apply homset_property. Qed. Definition section_nat_trans_assoc {C : category} {D : disp_cat C} {F1 F2 F3 F4: section_disp D} (F12 : section_nat_trans_disp F1 F2) (F23 : section_nat_trans_disp F2 F3) (F34 : section_nat_trans_disp F3 F4) : section_nat_trans_comp F12 (section_nat_trans_comp F23 F34) = section_nat_trans_comp (section_nat_trans_comp F12 F23) F34. Proof. use section_nat_trans_eq. intro x. simpl. rewrite mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. do 2 rewrite transport_f_f. rewrite assoc_disp. rewrite transport_f_b. apply maponpaths_2. apply homset_property. Qed. End Section_transformation. (** * Displayed functor category Displayed functors and natural transformations form a displayed category over the ordinary functor category between the bases. *) Section Functor. (* TODO: clean up this section a bit. *) Variables C' C : category. Variable D' : disp_cat C'. Variable D : disp_cat C. Let FunctorsC'C := functor_category C' C. Definition disp_functor_cat : disp_cat (FunctorsC'C). Proof. use tpair. - use tpair. + use tpair. * intro F. apply (disp_functor F D' D). * simpl. intros F' F FF' FF a. apply (disp_nat_trans a FF' FF). + use tpair. * intros x xx. apply disp_nat_trans_id. * intros ? ? ? ? ? ? ? ? X X0. apply (disp_nat_trans_comp X X0 ). - repeat split. + apply disp_nat_trans_id_left. + apply disp_nat_trans_id_right. + apply disp_nat_trans_assoc. + intros ; apply isaset_disp_nat_trans. Defined. (** TODO : characterize isos in the displayed functor cat *) (** TODO: integrate [has_homsets] assumptions below! *) Definition pointwise_z_iso_from_nat_z_iso {A X : precategory} {hsX : has_homsets X} {F G : functor_precategory A X hsX} (b : z_iso F G) (a : A) : z_iso (pr1 F a) (pr1 G a) := functor_z_iso_pointwise_if_z_iso _ _ _ _ _ b (pr2 b)_ . Definition pointwise_inv_is_inv_on_z_iso {A X : precategory} {hsX : has_homsets X} {F G : functor_precategory A X hsX} (b : z_iso F G) (a : A) : inv_from_z_iso (pointwise_z_iso_from_nat_z_iso b a) = pr1 (inv_from_z_iso b) a. Proof. apply idpath. Defined. (** TODO : write a few lemmas about isos in the disp functor precat, to make the following sane However: it seems to be better to work on https://github.com/UniMath/UniMath/issues/362 first. *) Definition is_pointwise_z_iso_if_is_disp_functor_cat_z_iso (x y : FunctorsC'C) (f : z_iso x y) (xx : disp_functor_cat x) (yy : disp_functor_cat y) (FF : xx -->[ f ] yy) (H : is_z_iso_disp f FF) : forall x' (xx' : D' x') , is_z_iso_disp (pointwise_z_iso_from_nat_z_iso f _ ) (pr1 FF _ xx' ). Proof. intros x' xx'. use tpair. - set (X:= pr1 H). simpl in X. apply (transportb _ (pointwise_inv_is_inv_on_z_iso f _ ) (X x' xx')). - simpl. repeat split. + etrans. apply mor_disp_transportf_postwhisker. apply pathsinv0. apply transportf_comp_lemma. assert (XR:= pr1 (pr2 H)). assert (XRT := (maponpaths pr1 XR)). assert (XRT' := toforallpaths _ _ _ (toforallpaths _ _ _ XRT x')). apply pathsinv0. etrans. apply XRT'. clear XRT' XRT XR. assert (XR := @disp_nat_trans_transportf C' C D' D). specialize (XR _ _ _ _ (! z_iso_after_z_iso_inv f)). etrans. apply XR. apply maponpaths_2, homset_property. + etrans. apply mor_disp_transportf_prewhisker. apply pathsinv0. apply transportf_comp_lemma. assert (XR:= inv_mor_after_z_iso_disp H). assert (XRT := (maponpaths pr1 XR)). assert (XRT' := toforallpaths _ _ _ (toforallpaths _ _ _ XRT x')). apply pathsinv0. etrans. apply XRT'. clear XRT' XRT XR. assert (XR := @disp_nat_trans_transportf C' C D' D). specialize (XR _ _ _ _ (! z_iso_inv_after_z_iso f)). etrans. apply XR. apply maponpaths_2, homset_property. Defined. (* The following part has holes because of the migration from [iso] to [z_iso] as notion of isomorphism. It compiled at the moment of commenting it. But at the price of two "Admitted". Lemma is_disp_nat_trans_pointwise_inv (x y : FunctorsC'C) (f : z_iso x y) (xx : disp_functor_cat x) (yy : disp_functor_cat y) (FF : xx -->[ f] yy) (H : ∏ (x' : C') (xx' : D' x'), is_z_iso_disp (pointwise_z_iso_from_nat_z_iso f x') (pr1 FF x' xx')) (x' x0 : C') (f0 : x' --> x0) (xx' : D' x') (xx0 : D' x0) (ff : xx' -->[ f0] xx0) : # (pr1 yy) ff ;; pr1 (H x0 xx0) = transportb (mor_disp (pr1 yy x' xx') (pr1 xx x0 xx0)) (nat_trans_ax (inv_from_z_iso f) x' x0 f0) (pr1 (H x' xx') ;; # (pr1 xx) ff). Proof. show_id_type. Admitted. Definition inv_disp_from_pointwise_z_iso (x y : FunctorsC'C) (f : z_iso x y) (xx : disp_functor_cat x) (yy : disp_functor_cat y) (FF : xx -->[ f ] yy) (H : forall x' (xx' : D' x') , is_z_iso_disp (pointwise_z_iso_from_nat_z_iso f _ ) (pr1 FF _ xx' )) : yy -->[ inv_from_z_iso f] xx. Proof. use tpair. + intros x' xx'. simpl in xx. simpl in yy. apply (pr1 (H x' xx')). + intros x' x0 f0 xx' xx0 ff. apply is_disp_nat_trans_pointwise_inv. Defined. Definition is_disp_functor_cat_iso_if_pointwise_z_iso (x y : FunctorsC'C) (f : z_iso x y) (xx : disp_functor_cat x) (yy : disp_functor_cat y) (FF : xx -->[ f ] yy) (H : forall x' (xx' : D' x') , is_z_iso_disp (pointwise_z_iso_from_nat_z_iso f _ ) (pr1 FF _ xx' )) : is_z_iso_disp f FF. Proof. use tpair. - apply (inv_disp_from_pointwise_z_iso _ _ _ _ _ FF H). - split. + apply subtypePath. { intro. apply isaprop_disp_nat_trans_axioms. } apply funextsec; intro c'. apply funextsec; intro xx'. apply pathsinv0. etrans. apply disp_nat_trans_transportf. cbn. apply pathsinv0. admit. (* etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. apply (iso_disp_after_inv_mor (H c' xx')). etrans. apply transport_f_f. apply maponpaths_2, homset_property. *) + apply subtypePath. { intro. apply isaprop_disp_nat_trans_axioms. } apply funextsec; intro c'. apply funextsec; intro xx'. apply pathsinv0. etrans. apply disp_nat_trans_transportf. cbn. apply pathsinv0. admit. (* etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths. apply (inv_mor_after_iso_disp (H c' xx')). etrans. apply transport_f_f. apply maponpaths_2, homset_property. *) Admitted. Definition is_disp_functor_cat_z_iso_iff_pointwise_z_iso (x y : FunctorsC'C) (f : z_iso x y) (xx : disp_functor_cat x) (yy : disp_functor_cat y) (FF : xx -->[ f ] yy) : (∏ x' (xx' : D' x') , is_z_iso_disp (pointwise_z_iso_from_nat_z_iso f _ ) (pr1 FF _ xx' )) <-> is_z_iso_disp f FF. Proof. split. - apply is_disp_functor_cat_iso_if_pointwise_z_iso. - apply is_pointwise_z_iso_if_is_disp_functor_cat_z_iso. Defined. *) End Functor. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Core.v000066400000000000000000000377771451125700300234610ustar00rootroot00000000000000(** /A module for “displayed categories”, based over UniMath’s [CategoryTheory] library. Roughly, a “displayed category _D_ over a category _C_” is analogous to “a family of types _Y_ indexed over a type _X_”. A displayed category has a “total category” ∑ _C_ _D_, with a functor to _D_; and indeed displayed categories should be equivalent to categories over _D_, by taking fibers. In a little more detail: if [D] is a displayed category over [C], then [D] has a type of objects indexed over [ob C], and for each [x y : C, f : x --> y, xx : D x, yy : D y], a type of “morphisms over [f] from [xx] to [yy]”. The identity and composition (and axioms) for [D] all overlie the corresponding structure on [C]. Two major motivations for displayed categories: - Pragmatically, they give a convenient tool for building categories of “structured objects”, and functors into such categories, encapsulating a lot of frequently-used constructions, and allowing for very modular proofs of e.g. saturation of such categories. - More conceptually, they give a setting for defining Grothendieck fibrations and isofibrations without mentioning equality of objects. Contents: - Displayed categories: [disp_cat C] - various access functions, etc. - utility lemmas - isomorphisms - saturation - Total categories (and their forgetful functors) - [total_category D] - [pr1_category D] - Functors between displayed categories, over functors between their bases - [functor_lifting], [lifted_functor] - [disp_functor], [total_functor] - properties of functors: [disp_functor_ff], … - natural transformations: [disp_nat_trans], … *) (* TODO: this file has become large and unwieldy; should probably be split up. Displayed functors can certainly be happily split off. Should total cats stay here, or also be split out? *) Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Local Open Scope type_scope. (* Undelimit Scope transport. *) (** * Displayed categories *) (* Here is an iterated ∑-type that displays a logical structure equivalent to the type called disp_cat defined below. *) Definition disp_cat' (C : category) : UU := ∑ (ob_disp : C -> UU) (mor_disp : ∏ {x y : C}, (x --> y) -> ob_disp x -> ob_disp y -> UU) (id_disp : ∏ {x : C} (xx : ob_disp x), mor_disp (identity x) xx xx) (comp_disp : ∏ {x y z : C} {f : x --> y} {g : y --> z} {xx : ob_disp x} {yy : ob_disp y} {zz : ob_disp z}, mor_disp f xx yy -> mor_disp g yy zz -> mor_disp (f · g) xx zz) (id_left_disp : ∏ {x y} {f : x --> y} {xx} {yy} (ff : mor_disp f xx yy), comp_disp (id_disp xx) ff = transportb (λ g, mor_disp g xx yy) (id_left _) ff) (id_right_disp : ∏ {x y} {f : x --> y} {xx} {yy} (ff : mor_disp f xx yy), comp_disp ff (id_disp yy) = transportb (λ g, mor_disp g xx yy) (id_right _) ff) (assoc_disp : ∏ {x y z w} {f : x --> y} {g : y --> z} {h : z --> w} {xx} {yy} {zz} {ww} (ff : mor_disp f xx yy) (gg : mor_disp g yy zz) (hh : mor_disp h zz ww), comp_disp ff (comp_disp gg hh) = transportb (λ k, mor_disp k _ _) (assoc _ _ _) (comp_disp (comp_disp ff gg) hh)), (* homsets_disp : *) ∏ x y (f : x --> y) xx yy, isaset (mor_disp f xx yy). (** ** Definition *) (** The actual definition is structured analogously to [category], as an iterated ∑-type: - [disp_cat] - [disp_cat_data] - [disp_cat_ob_mor] - [ob_disp] - [mod_disp] - [disp_cat_id_comp] - [id_disp] - [comp_disp] - [disp_cat_axioms] - [id_left_disp] - [id_right_disp] - [assoc_disp] - [homsets_disp] *) Section Disp_Cat. Definition disp_cat_ob_mor (C : precategory_ob_mor) := ∑ (obd : C -> UU), (∏ x y:C, obd x -> obd y -> (x --> y) -> UU). Definition make_disp_cat_ob_mor (C : precategory_ob_mor) (obd : C -> UU) (mord : ∏ x y:C, obd x -> obd y -> (x --> y) -> UU) : disp_cat_ob_mor C := obd,, mord. Definition ob_disp {C: precategory_ob_mor} (D : disp_cat_ob_mor C) : C -> UU := pr1 D. Coercion ob_disp : disp_cat_ob_mor >-> Funclass. Definition mor_disp {C: precategory_ob_mor} {D : disp_cat_ob_mor C} {x y} xx yy (f : x --> y) := pr2 D x y xx yy f : UU. Local Notation "xx -->[ f ] yy" := (mor_disp xx yy f) (at level 50, left associativity, yy at next level). Definition disp_cat_id_comp (C : precategory_data) (D : disp_cat_ob_mor C) : UU := (forall (x:C) (xx : D x), xx -->[identity x] xx) × (forall (x y z : C) (f : x --> y) (g : y --> z) (xx:D x) (yy:D y) (zz:D z), (xx -->[f] yy) -> (yy -->[g] zz) -> (xx -->[f · g] zz)). Definition disp_cat_data C := total2 (disp_cat_id_comp C). Definition disp_cat_ob_mor_from_disp_cat_data {C: precategory_data} (D : disp_cat_data C) : disp_cat_ob_mor C := pr1 D. Coercion disp_cat_ob_mor_from_disp_cat_data : disp_cat_data >-> disp_cat_ob_mor. Definition id_disp {C: precategory_data} {D : disp_cat_data C} {x:C} (xx : D x) : xx -->[identity x] xx := pr1 (pr2 D) x xx. Definition comp_disp {C: precategory_data} {D : disp_cat_data C} {x y z : C} {f : x --> y} {g : y --> z} {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : xx -->[f · g] zz := pr2 (pr2 D) _ _ _ _ _ _ _ _ ff gg. Definition locally_propositional {C : category} (D : disp_cat_data C) : UU := ∏ (x y : C) (f : x --> y) (xx : D x) (yy : D y), isaprop (xx -->[ f ] yy). Definition isaprop_locally_propositional {C : category} (D : disp_cat_data C) : isaprop (locally_propositional D). Proof. do 5 (use impred ; intro). apply isapropisaprop. Defined. Declare Scope mor_disp_scope. Local Notation "ff ;; gg" := (comp_disp ff gg) (at level 50, left associativity, format "ff ;; gg") : mor_disp_scope. Delimit Scope mor_disp_scope with mor_disp. Bind Scope mor_disp_scope with mor_disp. Local Open Scope mor_disp_scope. Definition disp_cat_axioms (C : category) (D : disp_cat_data C) : UU := (∏ x y (f : x --> y) (xx : D x) yy (ff : xx -->[f] yy), id_disp _ ;; ff = transportb _ (id_left _) ff) × (∏ x y (f : x --> y) (xx : D x) yy (ff : xx -->[f] yy), ff ;; id_disp _ = transportb _ (id_right _) ff) × (∏ x y z w f g h (xx : D x) (yy : D y) (zz : D z) (ww : D w) (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww), ff ;; (gg ;; hh) = transportb _ (assoc _ _ _) ((ff ;; gg) ;; hh)) × (∏ x y f (xx : D x) (yy : D y), isaset (xx -->[f] yy)). Definition disp_cat (C : category) := total2 (disp_cat_axioms C). Definition disp_cat_data_from_disp_cat {C} (D : disp_cat C) := pr1 D : disp_cat_data C. Coercion disp_cat_data_from_disp_cat : disp_cat >-> disp_cat_data. Definition make_disp_cat_locally_prop {C : category} {D : disp_cat_data C} (LP : locally_propositional D) : disp_cat C. Proof. exists D. abstract (repeat split; intro; intros; try apply LP; apply isasetaprop; apply LP). Defined. (** All the axioms are given in two versions, [foo : T1 = transportb e T2] and [foo_var : T2 = transportf e T1], so that either direction can be invoked easily in “compute left-to-right” style. *) (* TODO: consider naming conventions? *) (* TODO: maybe would be better to have a single [pathsinv0_dep] lemma, or something. *) Definition id_left_disp {C} {D : disp_cat C} {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy) : id_disp _ ;; ff = transportb _ (id_left _) ff := pr1 (pr2 D) _ _ _ _ _ _. Definition id_left_disp_var {C} {D : disp_cat C} {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy) : ff = transportf _ (id_left _) (id_disp _ ;; ff). Proof. apply transportf_transpose_right. apply @pathsinv0, id_left_disp. Qed. Definition id_right_disp {C} {D : disp_cat C} {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy) : ff ;; id_disp _ = transportb _ (id_right _) ff := pr1 (pr2 (pr2 D)) _ _ _ _ _ _. Definition id_right_disp_var {C} {D : disp_cat C} {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy) : ff = transportf _ (id_right _) (ff ;; id_disp _). Proof. apply transportf_transpose_right. apply @pathsinv0, id_right_disp. Qed. Definition assoc_disp {C} {D : disp_cat C} {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w} (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww) : ff ;; (gg ;; hh) = transportb _ (assoc _ _ _) ((ff ;; gg) ;; hh) := pr1 (pr2 (pr2 (pr2 D))) _ _ _ _ _ _ _ _ _ _ _ _ _ _. Definition assoc_disp_var {C} {D : disp_cat C} {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w} (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww) : (ff ;; gg) ;; hh = transportf _ (assoc _ _ _) (ff ;; (gg ;; hh)). Proof. apply pathsinv0, transportf_pathsinv0. apply pathsinv0, assoc_disp. Defined. Definition homsets_disp {C} {D : disp_cat C} {x y} (f : x --> y) (xx : D x) (yy : D y) : isaset (xx -->[f] yy) := pr2 (pr2 (pr2 (pr2 D))) _ _ _ _ _. Definition double_transport_disp {C C':category} {D':disp_cat C'} {a b a' b':C} (F:functor C C') (f:a-->b) (x:D' (F a)) (y:D' (F b)) (p:a=a') (q:b=b') : x-->[#F f]y -> transportf (λ z, D' (F z)) p x -->[# F (double_transport p q f)] transportf (λ z, D' (F z)) q y. Proof. intro Df. destruct p, q. exact Df. Defined. (** ** Utility lemmas *) Section Lemmas. (** [etrans_disp]: a version of [etrans_dep] for use when the equality transport in the RHS of the goal is already present, and not of the form produced by [etrans_dep], so [etrans_dep] doesn’t apply. Where possible, [etrans_dep] should still be used, since it *produces* a RHS, whereas this does not (and so leads to lots of unsolved existentials if used where not needed). NOTE: as with [etrans_dep], proofs using [etrans_disp] seem to typecheck more slowly than proofs using [etrans] plus other lemmas directly. *) Lemma pathscomp0_disp {C} {D : disp_cat C} {x y} {f f' f'' : x --> y} (e : f' = f) (e' : f'' = f') (e'' : f'' = f) {xx : D x} {yy} (ff : xx -->[f] yy) (ff' : xx -->[f'] yy) (ff'' : xx -->[f''] yy) : (ff = transportf _ e ff') -> (ff' = transportf _ e' ff'') -> ff = transportf _ e'' ff''. Proof. intros ee ee'. etrans. eapply pathscomp0_dep. apply ee. apply ee'. apply maponpaths_2, homset_property. Qed. Tactic Notation "etrans_disp" := eapply @pathscomp0_disp. Lemma isaprop_disp_cat_axioms (C : category) (D : disp_cat_data C) : isaprop (disp_cat_axioms C D). Proof. apply isofhlevelsn. intro X. set (XR := ( _ ,, X) : disp_cat C). apply isofhleveltotal2. - repeat (apply impred; intro). apply (@homsets_disp _ XR). - intros x. repeat (apply isofhleveldirprod); repeat (apply impred; intro). + apply (@homsets_disp _ XR). + apply (@homsets_disp _ XR). + apply isapropiscontr. Qed. (* TODO: consider naming of following few transport lemmas *) Lemma mor_disp_transportf_postwhisker {C : precategory} {D : disp_cat_data C} {x y z : C} {f f' : x --> y} (ef : f = f') {g : y --> z} {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : (transportf _ ef ff) ;; gg = transportf _ (cancel_postcomposition _ _ g ef) (ff ;; gg). Proof. destruct ef; apply idpath. Qed. Lemma mor_disp_transportf_prewhisker {C : precategory} {D : disp_cat_data C} {x y z : C} {f : x --> y} {g g' : y --> z} (eg : g = g') {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : ff ;; (transportf _ eg gg) = transportf _ (maponpaths (compose f) eg) (ff ;; gg). Proof. destruct eg; apply idpath. Qed. (* TODO: use the following lemmas in more of the displayed category proofs. Most instances of [mor_disp_transportf_Xwhisker] are places that can be simplified with these. *) (* TODO: consider naming of [cancel_Xcomposition_disp]. Currently follows the UniMath base lemmas, but those are bad names — cancellation properties traditionally mean things like like [ ax = ay -> x = y ], whereas these lemmas are the converse of that. *) Lemma cancel_postcomposition_disp {C} {D : disp_cat C} {x y z} {f f' : x --> y} {e : f' = f} {g : y --> z} {xx : D x} {yy} {zz} {ff : xx -->[f] yy} {ff' : xx -->[f'] yy} (gg : yy -->[g] zz) (ee : ff = transportf _ e ff') : ff ;; gg = transportf _ (cancel_postcomposition _ _ g e) (ff' ;; gg). Proof. etrans. apply maponpaths_2, ee. apply mor_disp_transportf_postwhisker. Qed. Lemma cancel_precomposition_disp {C} {D : disp_cat C} {x y z} {f : x --> y} {g g' : y --> z} {e : g' = g} {xx : D x} {yy} {zz} (ff : xx -->[f] yy) {gg : yy -->[g] zz} {gg' : yy -->[g'] zz} (ee : gg = transportf _ e gg') : ff ;; gg = transportf _ (cancel_precomposition _ _ _ _ _ _ f e) (ff ;; gg'). Proof. etrans. apply maponpaths, ee. apply mor_disp_transportf_prewhisker. Qed. Lemma assoc4_disp {C: category} {D: disp_cat C} {a b c d e: C} {da: D a} {db: D b} {dc: D c} {dd: D d} {de: D e} {f: a--> b} {g: b --> c} {h: c --> d} {i: d --> e} (df: da -->[f] db) (dg: db -->[g] dc) (dh: dc -->[h] dd) (di: dd -->[i] de) : df ;; dg ;; dh ;; di = transportb _ (assoc4 C a b c d e f g h i) (df ;; (dg ;; dh) ;; di). Proof. rewrite assoc_disp. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply PartA.transportb_transpose_right. apply (maponpaths (λ e, transportf _ e _)). apply uip. apply homset_property. Qed. Lemma id_conjugation_disp {C: category} {D: disp_cat C} {a b: C} {da: D a} {db: D b} {f: a--> b} {g: b --> a} {x: b --> b} (df: da -->[f] db) (dg: db -->[g] da) (dx: db -->[x] db) (e0: x = identity _) (e1 : f · g = identity _) : dx = transportb _ e0 (id_disp _) -> df ;; dg = transportb _ e1 (id_disp _) -> df ;; dx ;;dg = transportb _ (id_conjugation f g x e0 e1) (id_disp _). Proof. intros H H'. rewrite H. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite (id_right_disp df). rewrite transport_f_b. repeat rewrite mor_disp_transportf_postwhisker. rewrite H'. rewrite transport_f_b. apply (maponpaths (λ e, transportf _ e _)). apply uip. apply homset_property. Qed. End Lemmas. End Disp_Cat. (** Redeclare sectional notations globally. *) Notation "xx -->[ f ] yy" := (mor_disp xx yy f) (at level 50, left associativity, yy at next level). Declare Scope mor_disp_scope. Notation "ff ;; gg" := (comp_disp ff gg) (at level 50, left associativity, format "ff ;; gg") : mor_disp_scope. Delimit Scope mor_disp_scope with mor_disp. Bind Scope mor_disp_scope with mor_disp. Local Open Scope mor_disp_scope. (** A useful notation for hiding the huge irrelevant equalities that occur in algebra of displayed categories. For individual proofs, use [Open Scope hide_transport_scope.] at the start, and then [Close Scope hide_transport_scope.] afterwards. For whole files/sections, use [Local Open Scope hide_transport_scope.] Level is chosen to bind *tighter* than categorical composition, for readability. *) (* TODO: consider symbol(s) used. *) Declare Scope hide_transport_scope. Notation "#? x" := (transportf _ _ x) (at level 45) : hide_transport_scope. Notation "#?' x" := (transportb _ _ x) (at level 45) : hide_transport_scope. (** * Functors - Reindexing of displayed cats along functors: [reindex_disp_cat] - Functors into displayed cats, lifting functors into the base: [functor_lifting] - Functors between displayed cats, over functors between the bases: [disp_functor] - Natural transformations between these: [disp_nat_trans] *) (** some TODOs for the displayed-cats library: - add lemmas connecting with products of cats (as required for displayed bicats) - add more applications of the displayed arrow category: slices; equalisers, inserters; hence groups etc. *) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/DisplayedCatEq.v000066400000000000000000000301611451125700300254010ustar00rootroot00000000000000(********************************************************************************* Equality of displayed functors We are interested in the following bicategories: - The bicategory of displayed categories - The bicategory of fibrations over a fixed category - The bicategory of fibrations For each of these bicategories, we want to prove that it is univalent. That requires two things: - Proving that the identity of displayed functors is equivalent to the type of displayed natural isomorphisms between them - Proving that the identity of displayed categories is equivalent to the type of displayed adjoint equivalences between them. In this file, we look at the second of these two statements. The main idea of the proof is to characterize the identity relation for displayed categories step by step. In addition, there is one important trick in this proof: we characterize the identity relation for displayed categories lying over a fixed category `C` instead of displayed categories who lie over categories that are equal. This simplifies the construction, while no generality is lost. Contents 1. Lemmas about equality of displayed functors 2. Equality of displayed functors is the same as natural isomorphisms *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedFunctorEq. Require Import UniMath.CategoryTheory.DisplayedCats.EquivalenceOverId. Local Open Scope cat. Local Open Scope mor_disp. Section DisplayedCatEq. Context {C : category} (D₁ : disp_cat C) (D₂ : disp_cat C) (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂). (** 1. Lemmas about equality of displayed categories *) Definition disp_cat_eq_step_1 : D₁ = D₂ ≃ pr1 D₁ = pr1 D₂. Proof. use path_sigma_hprop. apply isaprop_disp_cat_axioms. Defined. Definition disp_cat_eq_step_2 : pr1 D₁ = pr1 D₂ ≃ pr1 D₁ ╝ pr1 D₂. Proof. exact (total2_paths_equiv _ (pr1 D₁) (pr1 D₂)). Defined. Definition disp_cat_eq_step_3 : pr1 D₁ ╝ pr1 D₂ ≃ ∑ (p : pr11 D₁ ╝ pr11 D₂), transportf (disp_cat_id_comp C) (total2_paths_f (pr1 p) (pr2 p)) (pr21 D₁) = pr21 D₂. Proof. exact (invweq (weqfp (invweq (total2_paths_equiv _ (pr11 D₁) (pr11 D₂))) (λ p, transportf _ p (pr21 D₁) = pr21 D₂))). Defined. Definition disp_cat_eq_step_4_help : pr11 D₁ ╝ pr11 D₂ ≃ ∑ (pob : ∏ (x : C), D₁ x = D₂ x), ∏ (x y : C) (xx : D₁ x) (yy : D₁ y) (f : x --> y), xx -->[ f ] yy = eqweqmap (pob x) xx -->[ f ] eqweqmap (pob y) yy. Proof. use weqbandf. - exact (weqtoforallpaths _ _ _). - intro p. induction D₁ as [ [ [ D₁o D₁m ] [ D₁i D₁c ] ] D₁a ]. induction D₂ as [ [ [ D₂o D₂m ] [ D₂i D₂c ] ] D₂a ]. cbn in p. induction p. cbn. refine (weqonsecfibers _ _ (λ x, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ y, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ xx, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ yy, _) ∘ weqtoforallpaths _ _ _)%weq. exact (weqtoforallpaths _ _ _)%weq. Defined. Definition disp_cat_id_comp_eq (pob : ∏ (x : C), D₁ x = D₂ x) (pmor : ∏ (x y : C) (xx : D₁ x) (yy : D₁ y) (f : x --> y), xx -->[ f ] yy = eqweqmap (pob x) xx -->[ f ] eqweqmap (pob y) yy) : UU := (∏ (x : C) (xx : D₁ x), eqweqmap (pmor x x xx xx (identity x)) (id_disp xx) = id_disp (eqweqmap (pob x) xx)) × (∏ (x y z : C) (f : x --> y) (g : y --> z) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[ f ] yy) (gg : yy -->[ g ] zz), eqweqmap (pmor _ _ _ _ _) (ff ;; gg) = eqweqmap (pmor _ _ _ _ f) ff ;; eqweqmap (pmor _ _ _ _ g) gg). Definition disp_cat_eq_step_4 : (∑ (p : pr11 D₁ ╝ pr11 D₂), transportf (disp_cat_id_comp C) (total2_paths_f (pr1 p) (pr2 p)) (pr21 D₁) = pr21 D₂) ≃ ∑ (pob : ∏ (x : C), D₁ x = D₂ x), ∑ (pmor : ∏ (x y : C) (xx : D₁ x) (yy : D₁ y) (f : x --> y), xx -->[ f ] yy = eqweqmap (pob x) xx -->[ f ] eqweqmap (pob y) yy), disp_cat_id_comp_eq pob pmor. Proof. refine (invweq (totalAssociativity _) ∘ _)%weq. use weqbandf. - exact disp_cat_eq_step_4_help. - intro p. unfold disp_cat_id_comp_eq ; cbn. induction D₁ as [ [ [ D₁o D₁m ] [ D₁i D₁c ] ] D₁a ]. induction D₂ as [ [ [ D₂o D₂m ] [ D₂i D₂c ] ] D₂a ]. cbn in p. induction p as [ p₁ p₂ ]. cbn in p₁. induction p₁. cbn in p₂. induction p₂. cbn. refine (_ ∘ pathsdirprodweq)%weq. use weqdirprodf. + refine (weqonsecfibers _ _ (λ x, _) ∘ weqtoforallpaths _ _ _)%weq. exact (weqtoforallpaths _ _ _). + refine (weqonsecfibers _ _ (λ x, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ y, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ z, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ f, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ g, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ xx, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ yy, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ zz, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ ff, _) ∘ weqtoforallpaths _ _ _)%weq. exact (weqtoforallpaths _ _ _). Defined. Definition disp_cat_eq_functor : UU := ∑ (pob : ∏ (x : C), D₁ x ≃ D₂ x), ∑ (pmor : ∏ (x y : C) (xx : D₁ x) (yy : D₁ y) (f : x --> y), xx -->[ f ] yy ≃ pob x xx -->[ f ] pob y yy), (∏ (x : C) (xx : D₁ x), pmor _ _ _ _ _ (id_disp xx) = id_disp (pob x xx)) × (∏ (x y z : C) (f : x --> y) (g : y --> z) (xx : D₁ x) (yy : D₁ y) (zz : D₁ z) (ff : xx -->[ f ] yy) (gg : yy -->[ g ] zz), pmor _ _ _ _ _ (ff ;; gg) = pmor _ _ _ _ _ ff ;; pmor _ _ _ _ _ gg). Definition disp_cat_eq_step_5 : (∑ (pob : ∏ (x : C), D₁ x = D₂ x), ∑ (pmor : ∏ (x y : C) (xx : D₁ x) (yy : D₁ y) (f : x --> y), xx -->[ f ] yy = eqweqmap (pob x) xx -->[ f ] eqweqmap (pob y) yy), disp_cat_id_comp_eq pob pmor) ≃ disp_cat_eq_functor. Proof. use weqbandf. - refine (weqonsecfibers _ _ (λ x, _)). exact (univalence _ _). - intro pob. use weqbandf. + cbn. refine (weqonsecfibers _ _ (λ x, _)). refine (weqonsecfibers _ _ (λ y, _)). refine (weqonsecfibers _ _ (λ xx, _)). refine (weqonsecfibers _ _ (λ yy, _)). refine (weqonsecfibers _ _ (λ f, _)). exact (univalence _ _). + cbn. intro pmor. exact (idweq _). Defined. Definition disp_cat_eq_step_6_left : disp_cat_eq_functor → ∑ (F : disp_functor (functor_identity C) D₁ D₂), (∏ (x : C), isweq (F x)) × disp_functor_ff F. Proof. intro FF. simple refine (_ ,, _ ,, _). - simple refine ((_ ,, _) ,, (_ ,, _)). + exact (λ x, pr1 FF x). + exact (λ x y xx yy f ff, pr12 FF x y xx yy f ff). + exact (λ x xx, pr122 FF x xx). + exact (λ x y z xx yy zz f g ff gg, pr222 FF x y z f g xx yy zz ff gg). - exact (λ x, pr2 (pr1 FF x)). - intros x y xx yy f. exact (pr2 (pr12 FF x y xx yy f)). Defined. Definition disp_cat_eq_step_6_right : (∑ (F : disp_functor (functor_identity C) D₁ D₂), (∏ (x : C), isweq (F x)) × disp_functor_ff F) → disp_cat_eq_functor. Proof. intro FF. induction FF as [ FF [ HF₁ HF₂ ]]. simple refine (_ ,, _ ,, _ ,, _). - intro x. use make_weq. + exact (FF x). + exact (HF₁ x). - intros x y xx yy f. use make_weq. + exact (λ ff, ♯FF ff). + apply HF₂. - intros x xx ; cbn. exact (disp_functor_id FF xx). - intros x y z f g xx yy zz ff gg ; cbn. exact (disp_functor_comp FF ff gg). Defined. Definition disp_cat_eq_step_6 : disp_cat_eq_functor ≃ ∑ (F : disp_functor (functor_identity C) D₁ D₂), (∏ (x : C), isweq (F x)) × disp_functor_ff F. Proof. use weq_iso. - exact disp_cat_eq_step_6_left. - exact disp_cat_eq_step_6_right. - apply idpath. - apply idpath. Defined. Definition disp_cat_eq_step_7 : (∑ (F : disp_functor (functor_identity C) D₁ D₂), (∏ (x : C), isweq (F x)) × disp_functor_ff F) ≃ ∑ (F : disp_functor (functor_identity C) D₁ D₂), disp_functor_disp_ess_surj F × disp_functor_ff F. Proof. use weqfibtototal. intro FF. use weqimplimpl. - intros HFF. split. + intros x yy. apply hinhpr. refine (invmap (make_weq _ (pr1 HFF x)) yy ,, _). apply (idtoiso_disp (idpath _)) ; cbn. apply (homotweqinvweq (make_weq (FF x) (pr1 HFF x))). + exact (pr2 HFF). - intros HFF. split. + intro x. exact (disp_ess_surj_ob_weq HD₁ HD₂ (pr1 HFF) (pr2 HFF) x). + exact (pr2 HFF). - use isapropdirprod. + use impred ; intro. apply isapropisweq. + apply isaprop_disp_functor_ff. - apply isapropdirprod. + apply propproperty. + apply isaprop_disp_functor_ff. Defined. Definition disp_cat_eq_step_8 : (∑ (F : disp_functor (functor_identity C) D₁ D₂), disp_functor_disp_ess_surj F × disp_functor_ff F) ≃ ∑ (F : disp_functor (functor_identity C) D₁ D₂), is_equiv_over_id F. Proof. use weqfibtototal. intro F. use weqimplimpl. - intros HF. use is_equiv_from_ff_ess_over_id. + exact (disp_functor_disp_ess_surj_to_split HD₁ HD₂ (pr1 HF) (pr2 HF)). + exact (pr2 HF). - intros HF. split. + exact (is_equiv_over_id_to_ess_surj F HF). + exact (is_equiv_over_id_to_ff F HF). - apply isapropdirprod. + apply propproperty. + apply isaprop_disp_functor_ff. - exact (isaprop_is_equiv_over_id HD₁ HD₂ F). Defined. Definition disp_cat_eq : D₁ = D₂ ≃ ∑ (F : disp_functor (functor_identity C) D₁ D₂), is_equiv_over_id F := (disp_cat_eq_step_8 ∘ disp_cat_eq_step_7 ∘ disp_cat_eq_step_6 ∘ disp_cat_eq_step_5 ∘ disp_cat_eq_step_4 ∘ disp_cat_eq_step_3 ∘ disp_cat_eq_step_2 ∘ disp_cat_eq_step_1)%weq. End DisplayedCatEq. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/DisplayedFunctorEq.v000066400000000000000000000217601451125700300263170ustar00rootroot00000000000000(********************************************************************************* Equality of displayed functors We are interested in the following bicategories: - The bicategory of displayed categories - The bicategory of fibrations over a fixed category - The bicategory of fibrations For each of these bicategories, we want to prove that it is univalent. That requires two things: - Proving that the identity of displayed functors is equivalent to the type of displayed natural isomorphisms between them - Proving that the identity of displayed categories is equivalent to the type of displayed adjoint equivalences between them. In this file, we look at the first of these two statements. The main idea of the proof is to characterize the identity relation for displayed functors step by step. For example, we start by proving [disp_functor_eq_step_1], which says that two displayed functors are equal if their data is equal. After that, we use the characterization of paths in sigma types to prove [disp_functor_eq_step_2]. In [disp_functor_eq_step_3], we further refine the obtained characterizations using function extensionality. In [disp_functor_eq_step_4], we use displayed univalence and in [disp_functor_eq_step_5] we recover displayed natural isomorphisms. By composing all these equivalences ([disp_functor_eq_weq]), we obtain the desired equivalence. In addition, there is one important trick in this proof: we characterize the identity relation for displayed functors lying over a fixed functor `F` instead of displayed functors `FF` and `GG` lying over `F` and `G` with a path `p : F = G`. This simplifies the construction, while no generality is lost. Contents 1. Lemmas about equality of displayed functors 2. Equality of displayed functors is the same as natural isomorphisms *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Local Open Scope mor_disp. Section DisplayedFunctorEq. Context {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF GG : disp_functor F D₁ D₂) (HD₂ : is_univalent_disp D₂). (** 1. Lemmas about equality of displayed functors *) Definition disp_functor_eq_step_1 : FF = GG ≃ pr1 FF = pr1 GG. Proof. use path_sigma_hprop. apply isaprop_disp_functor_axioms. Defined. Definition disp_functor_eq_step_2 : pr1 FF = pr1 GG ≃ pr1 FF ╝ pr1 GG. Proof. exact (total2_paths_equiv _ (pr1 FF) (pr1 GG)). Defined. Definition disp_functor_eq_step_3 : pr1 FF ╝ pr1 GG ≃ ∑ (p : ∏ (x : C₁) (xx : D₁ x), FF x xx = GG x xx), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; idtoiso_disp (idpath _) (p y yy) = transportb _ (id_right _ @ !(id_left _)) (idtoiso_disp (idpath _) (p x xx) ;; ♯GG ff). Proof. use weqbandf. - exact (weqonsecfibers _ _ (λ x, weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _)%weq. - intro p. induction FF as [ [ FFo FFm ] FFp ]. induction GG as [ [ GGo GGm ] GGp ]. cbn in p. induction p ; cbn. refine (weqonsecfibers _ _ (λ x, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ y, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ xx, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ yy, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ f, _) ∘ weqtoforallpaths _ _ _)%weq. refine (weqonsecfibers _ _ (λ ff, _) ∘ weqtoforallpaths _ _ _)%weq. use weqimplimpl. + intro pp. rewrite id_right_disp. rewrite id_left_disp. rewrite pp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. + intro pp. rewrite id_right_disp, id_left_disp in pp. unfold transportb in pp. rewrite transport_f_f in pp. refine (!_ @ maponpaths (λ z, transportf _ (id_right _) z) pp @ _). * rewrite transport_f_f. apply transportf_set. apply homset_property. * rewrite transport_f_f. apply transportf_set. apply homset_property. + apply D₂. + apply D₂. Defined. Definition disp_functor_eq_step_4 : (∑ (p : ∏ (x : C₁) (xx : D₁ x), FF x xx = GG x xx), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; idtoiso_disp (idpath _) (p y yy) = transportb _ (id_right _ @ !(id_left _)) (idtoiso_disp (idpath _) (p x xx) ;; ♯GG ff)) ≃ (∑ (p : ∏ (x : C₁) (xx : D₁ x), z_iso_disp (identity_z_iso _) (FF x xx) (GG x xx)), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; p y yy = transportb _ (id_right _ @ !(id_left _)) (p x xx ;; ♯GG ff)). Proof. use weqbandf. - exact (weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, make_weq _ (HD₂ _ _ (idpath _) _ _)))). - intro p. use weqimplimpl. + intros pp x y xx yy f ff. cbn -[idtoiso_disp]. exact (pp x y xx yy f ff). + intros pp x y xx yy f ff. cbn -[idtoiso_disp]. exact (pp x y xx yy f ff). + repeat (use impred ; intro). apply D₂. + repeat (use impred ; intro). apply D₂. Defined. Definition disp_functor_eq_step_5_left : (∑ (p : ∏ (x : C₁) (xx : D₁ x), z_iso_disp (identity_z_iso _) (FF x xx) (GG x xx)), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; p y yy = transportb _ (id_right _ @ !(id_left _)) (p x xx ;; ♯GG ff)) → disp_nat_z_iso FF GG (nat_z_iso_id F). Proof. simple refine (λ p, (_ ,, _) ,, _). - exact (λ x xx, pr1 (pr1 p x xx)). - abstract (intros x y f xx yy ff ; refine (pr2 p x y xx yy f ff @ _) ; apply maponpaths_2 ; apply homset_property). - intros x xx. exact (pr2 (pr1 p x xx)). Defined. Definition disp_functor_eq_step_5_right : disp_nat_z_iso FF GG (nat_z_iso_id F) → ∑ (p : ∏ (x : C₁) (xx : D₁ x), z_iso_disp (identity_z_iso _) (FF x xx) (GG x xx)), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; p y yy = transportb _ (id_right _ @ !(id_left _)) (p x xx ;; ♯GG ff). Proof. simple refine (λ p, (λ x xx, _ ,, _) ,, _). - exact (p x xx). - exact (pr2 p x xx). - abstract (intros x y f xx yy ff ; refine (disp_nat_trans_ax p ff @ _) ; apply maponpaths_2 ; apply homset_property). Defined. Definition disp_functor_eq_step_5 : (∑ (p : ∏ (x : C₁) (xx : D₁ x), z_iso_disp (identity_z_iso _) (FF x xx) (GG x xx)), ∏ (x y : C₁) (xx : D₁ x) (yy : D₁ y) (f : x --> y) (ff : xx -->[ f ] yy), ♯FF ff ;; p y yy = transportb _ (id_right _ @ !(id_left _)) (p x xx ;; ♯GG ff)) ≃ disp_nat_z_iso FF GG (nat_z_iso_id F). Proof. use weq_iso. - exact disp_functor_eq_step_5_left. - exact disp_functor_eq_step_5_right. - intro p. use subtypePath. { intro. repeat (use impred ; intro). apply D₂. } use funextsec ; intro x. use funextsec ; intro xx. use subtypePath. { intro. apply isaprop_is_z_iso_disp. } apply idpath. - intro p. use subtypePath. { intro. repeat (use impred ; intro). apply isaprop_is_z_iso_disp. } use disp_nat_trans_eq. intros x xx. apply idpath. Defined. (** 2. Equality of displayed functors is the same as natural isomorphisms *) Definition disp_functor_eq_weq : FF = GG ≃ disp_nat_z_iso FF GG (nat_z_iso_id F) := (disp_functor_eq_step_5 ∘ disp_functor_eq_step_4 ∘ disp_functor_eq_step_3 ∘ disp_functor_eq_step_2 ∘ disp_functor_eq_step_1)%weq. End DisplayedFunctorEq. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/EquivalenceOverId.v000066400000000000000000000677371451125700300261420ustar00rootroot00000000000000(********************************************************************************* Properties over equivalences over the identity In this file, we collect various properties of equivalences over the identity. Contents 1. If a displayed functor is eso and ff, then its object map is an equivalence 2. Essentially surjective functors are split essentially surjective 3. Being an equivalence is a proposition 4. Equivalences are (split) essentially surjective 5. Equivalences are fully faithful 6. Equivalences are cartesian 7. Equivalences are opcartesian *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.DisplayedFunctorEq. Local Open Scope cat. Local Open Scope mor_disp. (** 1. If a displayed functor is eso and ff, then its object map is an equivalence *) Proposition isaprop_hfiber_ff_disp {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂) {FF : disp_functor F D₁ D₂} (HFF : disp_functor_ff FF) (x : C₁) (yy : D₂(F x)) : isaprop (hfiber (FF x) yy). Proof. use invproofirrelevance. intros φ₁ φ₂. induction φ₁ as [ ww₁ ι₁ ]. induction φ₂ as [ ww₂ ι₂ ]. enough (∑ (p : ww₁ = ww₂), maponpaths (FF x) p = ι₁ @ !ι₂) as p. { use total2_paths_f. - exact (pr1 p). - rewrite transportf_paths_FlFr. cbn. rewrite maponpaths_for_constant_function. rewrite pathscomp0rid. rewrite (pr2 p). rewrite pathscomp_inv. rewrite pathsinv0inv0. rewrite <- path_assoc. rewrite pathsinv0l. rewrite pathscomp0rid. apply idpath. } enough (∑ (p : z_iso_disp (identity_z_iso _) ww₁ ww₂), ♯FF p = transportb (λ z, _ -->[ z ] _) (functor_id F _) (pr1 (idtoiso_disp (idpath _) (ι₁ @ !ι₂)))) as p. { refine (isotoid_disp HD₁ (idpath _) (pr1 p) ,, _). use (invmaponpathsincl _ (isinclweq _ _ _ (HD₂ _ _ (idpath _) _ _))). cbn -[idtoiso_disp]. use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ]. refine (pr1_idtoiso_disp_functor _ _ @ _). rewrite idtoiso_isotoid_disp. use transportf_transpose_left. exact (pr2 p). } pose (disp_functor_ff_inv _ HFF (transportb (λ z, _ -->[ z ] _) (functor_id F _) (pr1 (idtoiso_disp (idpath _) (ι₁ @ !ι₂))))) as ff. simple refine ((ff ,, _) ,, _). - apply FFinv_on_z_iso_is_z_iso. use is_z_iso_disp_transportb_fun_eq. apply idtoiso_disp. - apply FF_disp_functor_ff_inv. Qed. Proposition disp_ess_surj_ob_weq {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂) {FF : disp_functor F D₁ D₂} (HFF₁ : disp_functor_disp_ess_surj FF) (HFF₂ : disp_functor_ff FF) (x : C₁) : isweq (FF x). Proof. intros yy. use (factor_through_squash _ _ (HFF₁ x yy)). { apply isapropiscontr. } intros xx. induction xx as [ xx i ]. use iscontraprop1. - exact (isaprop_hfiber_ff_disp HD₁ HD₂ HFF₂ x yy). - refine (xx ,, _). exact (isotoid_disp HD₂ (idpath _) i). Qed. (** 2. Essentially surjective functors are split essentially surjective *) Proposition disp_functor_disp_ess_surj_to_split {C : category} {D₁ D₂ : disp_cat C} (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂) {F : disp_functor (functor_identity C) D₁ D₂} (H₁ : disp_functor_disp_ess_surj F) (H₂ : disp_functor_ff F) : disp_functor_disp_ess_split_surj F. Proof. intros x yy. refine (factor_through_squash _ (λ z, z) (H₁ x yy)). refine (isofhlevelweqf _ _ (isaprop_hfiber_ff_disp HD₁ HD₂ H₂ x yy)). use weqfibtototal. intro xx ; cbn. exact (make_weq _ (HD₂ x x (idpath _) _ _)). Defined. (** 3. Being an equivalence is a proposition *) Definition path_right_adjoint_over_id_data_help {C : category} {D₁ D₂ : disp_cat C} {F : disp_functor (functor_identity C) D₁ D₂} {HF₁ HF₂ : right_adjoint_over_id_data F} (p₁ : pr1 HF₁ = pr1 HF₂) (p₂ : ∏ (x : C) (xx : D₁ x), pr12 HF₁ x xx ;; idtoiso_disp (idpath _) (maponpaths (λ z, pr11 z x (F x xx)) p₁) = transportf (λ z, _ -->[ z ] _) (!(id_right _)) (pr12 HF₂ x xx)) (p₃ : ∏ (x : C) (xx : D₂ x), pr22 HF₁ x xx = transportf (λ z, _ -->[ z ] _) (id_left _) (♯F (idtoiso_disp (idpath _) (maponpaths (λ z, pr11 z x xx) p₁)) ;; pr22 HF₂ x xx)) : HF₁ = HF₂. Proof. induction HF₁ as [ R₁ [ η₁ ε₁ ]]. induction HF₂ as [ R₂ [ η₂ ε₂ ]]. cbn in p₁. induction p₁. apply maponpaths. apply pathsdirprod. - use disp_nat_trans_eq. intros x xx. pose (q := p₂ x xx). cbn in q. rewrite id_right_disp in q. unfold transportb in q. refine (_ @ maponpaths (transportb _ _) q @ _). + rewrite transportbfinv. apply idpath. + rewrite transportbfinv. apply idpath. - use disp_nat_trans_eq. intros x xx. refine (p₃ x xx @ _) ; cbn. rewrite (disp_functor_id F). unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Definition path_right_adjoint_over_id_data {C : category} {D₁ D₂ : disp_cat C} (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂) {F : disp_functor (functor_identity C) D₁ D₂} {HF₁ HF₂ : right_adjoint_over_id_data F} (p₁ : disp_nat_z_iso (pr1 HF₁) (pr1 HF₂) (nat_z_iso_id (functor_identity C))) (p₂ : ∏ (x : C) (xx : D₁ x), (pr12 HF₁) x xx ;; p₁ x (F x xx) = transportf (λ z, _ -->[ z ] _) (!(id_right _)) ((pr12 HF₂) x xx)) (p₃ : ∏ (x : C) (xx : D₂ x), pr22 HF₁ x xx = transportf (λ z, _ -->[ z ] _) (id_left _) (♯F (p₁ x xx) ;; pr22 HF₂ x xx)) : HF₁ = HF₂. Proof. use path_right_adjoint_over_id_data_help. - exact (invmap (disp_functor_eq_weq _ _ HD₁) p₁). - intros x xx. refine (_ @ p₂ x xx). apply maponpaths. refine (_ @ maponpaths (λ z, (pr11 z) x (F x xx)) (homotweqinvweq (disp_functor_eq_weq (pr1 HF₁) (pr1 HF₂) HD₁) p₁)). generalize (invmap (disp_functor_eq_weq (pr1 HF₁) (pr1 HF₂) HD₁) p₁). intro p. induction p ; cbn. apply idpath. - intros x xx. refine (p₃ x xx @ _). apply maponpaths. apply maponpaths_2. apply maponpaths. refine (!_). refine (_ @ maponpaths (λ z, (pr11 z) x xx) (homotweqinvweq (disp_functor_eq_weq (pr1 HF₁) (pr1 HF₂) HD₁) p₁)). generalize (invmap (disp_functor_eq_weq (pr1 HF₁) (pr1 HF₂) HD₁) p₁). intro p. induction p ; cbn. apply idpath. Qed. Section IsEquivOverIdIsProp. Context {C : category} {D₁ D₂ : disp_cat C} (HD₁ : is_univalent_disp D₁) (HD₂ : is_univalent_disp D₂) (F : disp_functor (functor_identity C) D₁ D₂). Section Defs. Context (HF₁ HF₂ : is_equiv_over_id F). Let R₁ : disp_functor (functor_identity C) D₂ D₁ := HF₁. Let η₁ : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite F R₁) := unit_over_id HF₁. Let ε₁ : disp_nat_trans (nat_trans_id _) (disp_functor_composite R₁ F) (disp_functor_identity _) := counit_over_id HF₁. Let R₂ : disp_functor (functor_identity C) D₂ D₁ := HF₂. Let η₂ : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite F R₂) := unit_over_id HF₂. Let ε₂ : disp_nat_trans (nat_trans_id _) (disp_functor_composite R₂ F) (disp_functor_identity _) := counit_over_id HF₂. Definition isaprop_is_equiv_over_id_nat_trans : disp_nat_trans (nat_z_iso_id (functor_identity C)) R₁ R₂ := disp_nat_trans_over_id_comp (disp_nat_trans_over_id_prewhisker R₁ η₂) (disp_nat_trans_over_id_postwhisker R₂ ε₁). Proposition isaprop_is_equiv_over_id_is_nat_z_iso : is_disp_nat_z_iso (nat_z_iso_id (functor_identity C)) isaprop_is_equiv_over_id_nat_trans. Proof. intros x xx ; cbn. pose (η₂ x (R₁ x xx) ;; ♯ R₂ (ε₁ x xx)). cbn in m. use (@is_z_iso_disp_transportf_fun_eq C D₁ x x (z_iso_comp (identity_z_iso x) (identity_z_iso x))). use (z_iso_disp_comp (_ ,, _) (_ ,, _)). - apply HF₂. - exact (is_z_iso_disp_independent_of_is_z_iso _ _ (pr2 (disp_functor_on_z_iso_disp R₂ (make_z_iso_disp _ (is_z_iso_counit_over_id HF₁ x xx))))). Defined. Definition isaprop_is_equiv_over_id_nat_z_iso : disp_nat_z_iso R₁ R₂ (nat_z_iso_id (functor_identity C)) := isaprop_is_equiv_over_id_nat_trans ,, isaprop_is_equiv_over_id_is_nat_z_iso. Proposition isaprop_is_equiv_over_id_eq_1 (x : C) (xx : D₁ x) : η₁ x xx ;; isaprop_is_equiv_over_id_nat_z_iso x (F x xx) = transportf (λ z, _ -->[ z ] _) (!(id_right _)) (η₂ x xx). Proof. cbn. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply (disp_nat_trans_ax η₂). } unfold transportb. cbn. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. refine (!_). apply (disp_functor_comp_var R₂). } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 3 apply maponpaths. exact (triangle_1_over_id HF₁ x xx). } unfold transportb. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite disp_functor_id. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Proposition isaprop_is_equiv_over_id_eq_2 (x : C) (xx : D₂ x) : ε₁ x xx = transportf (λ z, _ -->[ z ] _) (id_left _) (♯F (isaprop_is_equiv_over_id_nat_z_iso x xx) ;; ε₂ x xx). Proof. cbn. rewrite (disp_functor_transportf _ F). rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. apply (disp_nat_trans_ax ε₂). } unfold transportb. cbn. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact (triangle_1_over_id HF₂ x (R₁ x xx)). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. End Defs. Proposition isaprop_is_equiv_over_id : isaprop (is_equiv_over_id F). Proof. use invproofirrelevance. intros HF₁ HF₂. use subtypePath. { intro. apply isaprop_form_equiv_over_id. } use subtypePath. { intro. apply isaprop_form_disp_adjunction_id. } use (path_right_adjoint_over_id_data HD₁ HD₂). - exact (isaprop_is_equiv_over_id_nat_z_iso HF₁ HF₂). - exact (isaprop_is_equiv_over_id_eq_1 HF₁ HF₂). - exact (isaprop_is_equiv_over_id_eq_2 HF₁ HF₂). Qed. End IsEquivOverIdIsProp. Section PropertiesOfEquivOverId. Context {C : category} {D₁ : disp_cat C} {D₂ : disp_cat C} (LL : disp_functor (functor_identity _) D₁ D₂) (HLL : is_equiv_over_id LL). Let RR : disp_functor (functor_identity _) D₂ D₁ := HLL. Let η : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite LL RR) := unit_over_id HLL. Let ε : disp_nat_trans (nat_trans_id _) (disp_functor_composite RR LL) (disp_functor_identity _) := counit_over_id HLL. (** 4. Equivalences are (split) essentially surjective *) Proposition is_equiv_over_id_to_split_ess_surj : disp_functor_disp_ess_split_surj LL. Proof. intros x yy. refine (RR x yy ,, ε x yy ,, _). exact (is_z_iso_counit_over_id HLL x yy). Defined. Proposition is_equiv_over_id_to_ess_surj : disp_functor_disp_ess_surj LL. Proof. intros x yy. apply hinhpr. apply is_equiv_over_id_to_split_ess_surj. Qed. (** 5. Equivalences are fully faithful *) Proposition is_equiv_over_id_to_ff : disp_functor_ff LL. Proof. intros x y xx yy f. use isweq_iso. - cbn ; intro ff. refine (transportf (λ z, _ -->[ z ] _) _ (η x xx ;; ♯ RR ff ;; inv_mor_disp_from_z_iso (is_z_iso_unit_over_id HLL y yy))). abstract (cbn ; rewrite id_left, id_right ; apply idpath). - abstract (intro ff ; cbn ; etrans ; [ apply maponpaths ; apply maponpaths_2 ; exact (disp_nat_trans_ax_var η ff) | ] ; cbn ; rewrite mor_disp_transportf_postwhisker ; rewrite transport_f_f ; rewrite assoc_disp_var ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; exact (inv_mor_after_z_iso_disp (is_z_iso_unit_over_id (pr2 HLL) y yy)) | ] ; cbn ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite id_right_disp ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). - abstract (cbn ; intro ff ; rewrite (disp_functor_transportf _ LL) ; rewrite disp_functor_comp ; unfold transportb ; rewrite transport_f_f ; rewrite disp_functor_comp ; unfold transportb ; rewrite mor_disp_transportf_postwhisker ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; apply triangle_1_over_id_alt | ] ; rewrite assoc_disp_var ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; apply (disp_nat_trans_ax (counit_over_id HLL)) | ] ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; cbn ; rewrite assoc_disp ; unfold transportb ; rewrite transport_f_f ; etrans ; [ apply maponpaths ; apply maponpaths_2 ; exact (triangle_1_over_id HLL x xx) | ] ; unfold transportb ; rewrite mor_disp_transportf_postwhisker ; rewrite transport_f_f ; rewrite id_left_disp ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property) ; rewrite triangle_1_over_id_alt. Qed. End PropertiesOfEquivOverId. (** 6. Equivalences are cartesian *) Section EquivIsCartesian. Context {C : category} {D₁ D₂ : disp_cat C} {L : disp_functor (functor_identity C) D₁ D₂} (HL : is_equiv_over_id L). Let R : disp_functor (functor_identity C) D₂ D₁ := HL. Let η : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite L R) := unit_over_id HL. Let ε : disp_nat_trans (nat_trans_id _) (disp_functor_composite R L) (disp_functor_identity _) := counit_over_id HL. Section Cartesian. Context {x y : C} {f : y --> x} {xx : D₁ x} {yy : D₁ y} {ff : yy -->[ f ] xx} (Hff : is_cartesian ff) {w : C} {g : w --> y} (ww : D₂ w) (hh : ww -->[ g · f ] L x xx). Proposition is_cartesian_equiv_over_id_unique : isaprop (∑ (gg : ww -->[ g ] L y yy), gg ;; ♯ L ff = hh). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply D₂. } use (invmaponpathsweq (make_weq _ (is_equiv_over_id_to_ff _ (equiv_inv _ HL) _ _ _ _ _))). cbn. refine (id_right_disp_var _ @ _ @ !(id_right_disp_var _)). apply maponpaths. etrans. { apply maponpaths. exact (!(transportf_transpose_left (z_iso_disp_after_inv_mor (is_z_iso_unit_over_id HL y yy)))). } refine (!_). etrans. { apply maponpaths. exact (!(transportf_transpose_left (z_iso_disp_after_inv_mor (is_z_iso_unit_over_id HL y yy)))). } refine (!_). rewrite !mor_disp_transportf_prewhisker. apply maponpaths. rewrite !assoc_disp. apply maponpaths. apply maponpaths_2. use (cartesian_factorisation_unique Hff). rewrite !assoc_disp_var. apply maponpaths. etrans. { apply maponpaths. apply (disp_nat_trans_ax_var (disp_nat_z_iso_to_trans_inv (α := nat_z_iso_id _) (η ,, is_z_iso_unit_over_id HL))). } refine (!_). etrans. { apply maponpaths. apply (disp_nat_trans_ax_var (disp_nat_z_iso_to_trans_inv (α := nat_z_iso_id _) (η ,, is_z_iso_unit_over_id HL))). } cbn. rewrite !mor_disp_transportf_prewhisker. apply maponpaths. rewrite !assoc_disp. apply maponpaths. apply maponpaths_2. refine (!(disp_functor_comp_var R _ _) @ _ @ disp_functor_comp_var R _ _). do 2 apply maponpaths. exact (pr2 φ₂ @ !(pr2 φ₁)). Qed. Definition is_cartesian_equiv_over_id_fact : ww -->[ g ] L y yy. Proof. pose (cartesian_factorisation Hff _ (transportf (λ z, _ -->[ z ] _) (id_right _) (♯R hh ;; inv_mor_disp_from_z_iso (is_z_iso_unit_over_id HL x xx)))) as m. exact (transportf (λ z, _ -->[ z ] _) (id_left _) (inv_mor_disp_from_z_iso (is_z_iso_counit_over_id HL w ww) ;; ♯L m)). Defined. Proposition is_cartesian_equiv_over_id_comm : is_cartesian_equiv_over_id_fact ;; ♯ L ff = hh. Proof. unfold is_cartesian_equiv_over_id_fact ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. refine (!_). apply (disp_functor_comp_var L). } rewrite cartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. apply triangle_1_over_id_alt. } apply (disp_nat_trans_ax ε). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply (z_iso_disp_after_inv_mor (is_z_iso_counit_over_id (pr2 HL) w ww)). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. cbn. apply transportf_set. apply homset_property. Qed. End Cartesian. Proposition is_cartesian_equiv_over_id : is_cartesian_disp_functor L. Proof. intros x y f xx yy ff Hff w g ww hh. use iscontraprop1. - exact (is_cartesian_equiv_over_id_unique Hff ww hh). - simple refine (_ ,, _). + exact (is_cartesian_equiv_over_id_fact Hff ww hh). + exact (is_cartesian_equiv_over_id_comm Hff ww hh). Defined. End EquivIsCartesian. (** 7. Equivalences are opcartesian *) Section EquivIsOpcartesian. Context {C : category} {D₁ D₂ : disp_cat C} {L : disp_functor (functor_identity C) D₁ D₂} (HL : is_equiv_over_id L). Let R : disp_functor (functor_identity C) D₂ D₁ := HL. Let η : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite L R) := unit_over_id HL. Let ε : disp_nat_trans (nat_trans_id _) (disp_functor_composite R L) (disp_functor_identity _) := counit_over_id HL. Section Opcartesian. Context {x y : C} {f : y --> x} {xx : D₁ x} {yy : D₁ y} {ff : yy -->[ f ] xx} (Hff : is_opcartesian ff) {w : C} {g : x --> w} (ww : D₂ w) (hh : L y yy -->[ f · g ] ww). Proposition is_opcartesian_equiv_over_id_unique : isaprop (∑ (gg : L x xx -->[ g ] ww), ♯L ff ;; gg = hh). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply D₂. } use (invmaponpathsweq (make_weq _ (is_equiv_over_id_to_ff _ (equiv_inv _ HL) _ _ _ _ _))). cbn. refine (id_left_disp_var _ @ _ @ !(id_left_disp_var _)). apply maponpaths. etrans. { apply maponpaths_2. exact (!(transportf_transpose_left (z_iso_disp_after_inv_mor (is_z_iso_unit_over_id HL _ _)))). } refine (!_). etrans. { apply maponpaths_2. exact (!(transportf_transpose_left (z_iso_disp_after_inv_mor (is_z_iso_unit_over_id HL _ _)))). } refine (!_). rewrite !mor_disp_transportf_postwhisker. apply maponpaths. rewrite !assoc_disp_var. do 2 apply maponpaths. use (opcartesian_factorisation_unique Hff). rewrite !assoc_disp. apply maponpaths. etrans. { apply maponpaths_2. exact (disp_nat_trans_ax η ff). } refine (!_). etrans. { apply maponpaths_2. exact (disp_nat_trans_ax η ff). } cbn. unfold transportb. rewrite !mor_disp_transportf_postwhisker. apply maponpaths. rewrite !assoc_disp_var. do 2 apply maponpaths. refine (!(disp_functor_comp_var R _ _) @ _ @ disp_functor_comp_var R _ _). do 2 apply maponpaths. exact (pr2 φ₂ @ !(pr2 φ₁)). Qed. Definition is_opcartesian_equiv_over_id_fact : L x xx -->[ g ] ww. Proof. pose (opcartesian_factorisation Hff _ (transportf (λ z, _ -->[ z ] _) (id_left _) (η y yy ;; ♯R hh))) as m. exact (transportf (λ z, _ -->[ z ] _) (id_right _) (♯L m ;; ε w ww)). Defined. Proposition is_opcartesian_equiv_over_id_comm : ♯ L ff ;; is_opcartesian_equiv_over_id_fact = hh. Proof. unfold is_opcartesian_equiv_over_id_fact ; cbn. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply (disp_functor_comp_var L). } rewrite opcartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply (disp_nat_trans_ax ε). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply (triangle_1_over_id HL). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. cbn. apply transportf_set. apply homset_property. Qed. End Opcartesian. Proposition is_opcartesian_equiv_over_id : is_opcartesian_disp_functor L. Proof. intros x y f xx yy ff Hff w ww g hh. use iscontraprop1. - exact (is_opcartesian_equiv_over_id_unique Hff ww hh). - simple refine (_ ,, _). + exact (is_opcartesian_equiv_over_id_fact Hff ww hh). + exact (is_opcartesian_equiv_over_id_comm Hff ww hh). Defined. End EquivIsOpcartesian. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Equivalences.v000066400000000000000000001471451451125700300252040ustar00rootroot00000000000000 (** “Displayed equivalences” of displayed categories. *) (** ** Contents: - Displayed adjunctions and equivalences - Displayed Adjunctions: [disp_adjunction] - Displayed Equivalences: [equiv_over] - Constructions - Equivalence from ess. split and ff (incomplete) - Adjunctions and equivalences displayed over an identity functor - Displayed Adjunctions over identity: [disp_adjunction_id] - Displayed Equivalences over identity: [equiv_over_id] - Constructions - Equivalence from ess. split and ff over identity [is_equiv_from_ff_ess_over_id] - Inverses and composition of displayed adjunctions/equivalences over identity - Induced adjunctions/equivalences of fiber categories over identity [fiber_equiv] *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Local Open Scope type_scope. Local Open Scope mor_disp_scope. (** * General definition of displayed adjunctions and equivalences *) Section DisplayedAdjunction. Definition disp_adjunction_data {C C' : category} (A : adjunction_data C C') (F := left_functor A) (G := right_functor A) (eta := adjunit A) (eps := adjcounit A) (D : disp_cat C) (D' : disp_cat C') : UU := ∑ (FF : disp_functor F D D') (GG : disp_functor G D' D), (disp_nat_trans eta (disp_functor_identity _ ) (disp_functor_composite FF GG)) × (disp_nat_trans eps (disp_functor_composite GG FF) (disp_functor_identity _ )). Section notation. Context {C C' : category} {A : adjunction_data C C'} {D D'} (X : disp_adjunction_data A D D'). Definition left_adj_over : disp_functor _ _ _ := pr1 X. Definition right_adj_over : disp_functor _ _ _ := pr1 (pr2 X). Definition unit_over : disp_nat_trans _ _ _ := pr1 (pr2 (pr2 X)). Definition counit_over : disp_nat_trans _ _ _ := pr2 (pr2 (pr2 X)). End notation. Definition triangle_1_statement_over {C C' : category} {A : adjunction C C'} {D D'} (X : disp_adjunction_data A D D') (FF := left_adj_over X) (ηη := unit_over X) (εε := counit_over X) : UU := ∏ x xx, ♯ FF (ηη x xx) ;; εε _ (FF _ xx) = transportb _ (triangle_id_left_ad A x ) (id_disp _) . Definition triangle_2_statement_over {C C' : category} {A : adjunction C C'} {D D'} (AA : disp_adjunction_data A D D') (GG := right_adj_over AA) (ηη := unit_over AA) (εε := counit_over AA) : UU := ∏ x xx, ηη _ (GG x xx) ;; ♯ GG (εε _ xx) = transportb _ (triangle_id_right_ad A _ ) (id_disp _). Definition form_disp_adjunction {C C' : category} (A : adjunction C C') {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction_data A D D') : UU := triangle_1_statement_over AA × triangle_2_statement_over AA. Definition disp_adjunction {C C' : category} (A : adjunction C C') D D' : UU := ∑ AA : disp_adjunction_data A D D', triangle_1_statement_over AA × triangle_2_statement_over AA. Coercion data_of_disp_adjunction (C C' : category) (A : adjunction C C') D D' (AA : disp_adjunction A D D') : disp_adjunction_data _ _ _ := pr1 AA. Definition triangle_1_over {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction A D D') : triangle_1_statement_over AA := pr1 (pr2 AA). Definition triangle_2_over {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction A D D') : triangle_2_statement_over AA := pr2 (pr2 AA). (** The terminology is difficult to choose here: the proposition “F is a left adjoint” is the same as the type of “right adjoints to F”, so should this type be called something more like [left_adjoint F] or [right_adjoint F]? Our choice here does _not_ agree with that of the base UniMath category theory library. TODO: consider these conventions, and eventually harmonise them by changing it either here or in UniMath. *) Definition right_adjoint_over_data {C C' : category} {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor (left_functor A) D D') : UU := ∑ (GG : disp_functor (right_functor A) D' D), (disp_nat_trans (adjunit A) (disp_functor_identity _) (disp_functor_composite FF GG)) × (disp_nat_trans (adjcounit A ) (disp_functor_composite GG FF) (disp_functor_identity _)). Definition functor_of_right_adjoint_over {C C' : category} {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor (left_functor A) D D'} (GG : right_adjoint_over_data FF) := pr1 GG. Coercion functor_of_right_adjoint_over : right_adjoint_over_data >-> disp_functor. Definition adjunction_of_right_adjoint_over_data {C C' : category} {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor (left_functor A) D D'} (GG : right_adjoint_over_data FF) : disp_adjunction_data A D D' := (FF,, GG). Coercion adjunction_of_right_adjoint_over_data : right_adjoint_over_data >-> disp_adjunction_data. Definition right_adjoint_of_disp_adjunction_data {C C' : category} {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction_data A D D') : right_adjoint_over_data (left_adj_over AA) (* coercion does not trigger *) := pr2 AA. Definition right_adjoint_over {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor (left_functor A) D D') : UU := ∑ GG : right_adjoint_over_data FF, form_disp_adjunction A GG. Definition data_of_right_adjoint_over {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor (left_functor A) D D'} (GG : right_adjoint_over FF) : right_adjoint_over_data FF := pr1 GG. Coercion data_of_right_adjoint_over : right_adjoint_over >-> right_adjoint_over_data. Definition adjunction_of_right_adjoint_over {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor (left_functor A) D D') (GG : right_adjoint_over FF) : disp_adjunction A D D' := (adjunction_of_right_adjoint_over_data GG ,, pr2 GG). Definition right_adjoint_of_disp_adjunction {C C' : category} {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction A D D') : right_adjoint_over (left_adj_over AA) := (right_adjoint_of_disp_adjunction_data AA ,, pr2 AA). End DisplayedAdjunction. Section DisplayedEquivalences. Definition form_equiv_over {C C' : category} {E : equivalence_of_cats C C'} {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction_data E D D') : UU := (∏ x xx, is_z_iso_disp (adjunitiso E x) (unit_over AA x xx)) × (∏ x xx, is_z_iso_disp (adjcounitiso E x) (counit_over AA x xx)). Definition is_z_iso_unit_over {C C' : category} (E : equivalence_of_cats C C') {D D'} (AA : disp_adjunction_data E D D') (EE : form_equiv_over AA) : ∏ (x : C) (xx : D x), is_z_iso_disp (adjunitiso E x) ((unit_over AA) x xx) := pr1 EE. Definition is_z_iso_counit_over {C C' : category} (E : equivalence_of_cats C C') {D D'} (AA : disp_adjunction_data E D D') (EE : form_equiv_over AA) : ∏ (x0 : C') (xx : D' x0), is_z_iso_disp (adjcounitiso E x0) ((counit_over AA) x0 xx) := pr2 EE. Definition equiv_over {C C' : category} (E : adj_equiv C C') (D : disp_cat C) (D' : disp_cat C') : UU := ∑ AA : disp_adjunction E D D', @form_equiv_over _ _ E _ _ (pr1 AA). (* argument A is not inferred *) Coercion adjunction_of_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} (EE : equiv_over E D D') : disp_adjunction _ _ _ := pr1 EE. Coercion axioms_of_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} (EE : equiv_over E D D') : form_equiv_over _ := pr2 EE. Definition is_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} (FF : disp_functor (left_functor E) D D') : UU := ∑ GG : @right_adjoint_over _ _ E _ _ FF, @form_equiv_over _ _ E _ _ GG. (* argument E is not inferred *) Definition right_adjoint_of_is_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} {FF : disp_functor (left_functor E) D D'} (EE : is_equiv_over E FF) := pr1 EE. Coercion right_adjoint_of_is_equiv_over : is_equiv_over >-> right_adjoint_over. Definition equiv_of_is_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} {FF : disp_functor (left_functor E) D D'} (EE : is_equiv_over E FF) : equiv_over E D D' := (adjunction_of_right_adjoint_over _ EE ,, pr2 EE). Coercion equiv_of_is_equiv_over : is_equiv_over >-> equiv_over. (* Again, don’t worry about the ambiguous path generated here. *) (** ** Lemmas on the triangle identities *) Local Open Scope hide_transport_scope. Lemma triangle_2_from_1_for_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction_data E D D') (EE : form_equiv_over (E:=E) AA) : triangle_1_statement_over (A:=E) AA -> triangle_2_statement_over (A:=E) AA. Proof. destruct AA as [FF [GG [η ε]]]. destruct EE as [Hη Hε]; cbn in Hη, Hε. unfold triangle_1_statement_over, triangle_2_statement_over; cbn. intros T1 x yy. (* Algebraically, this goes as follows: η G ; G ε = G ε^ ; η^ G ; η G ; G ε ; η G ; G ε [by inverses, 1] = G ε^ ; η^ G ; η G ; η G F G ; G F G ε ; G ε [by naturality, 2] = G ε^ ; η^ G ; η G ; η G F G ; G ε F G ; G ε [by naturality, 3] = G ε^ ; η^ G ; η G ; G F η G ; G ε F G ; G ε [by naturality, 4] = G ε^ ; η^ G ; η G ; G (F η ; ε F ) G ; G ε [by functoriality, 5] = G ε^ ; η^ G ; η G ; G ε [by T1, 6] = 1 [by inverses, 7] It’s perhaps most readable when written in string diagrams. *) etrans. apply id_left_disp_var. etrans. eapply transportf_bind. eapply cancel_postcomposition_disp. etrans. eapply transportf_transpose_right. apply @pathsinv0. refine (z_iso_disp_after_inv_mor _). refine (disp_functor_on_is_z_iso_disp GG _). apply Hε. (*1a*) eapply transportf_bind. eapply cancel_postcomposition_disp. etrans. apply id_right_disp_var. eapply transportf_bind. etrans. eapply cancel_precomposition_disp. eapply transportf_transpose_right. apply @pathsinv0. refine (z_iso_disp_after_inv_mor _). apply (Hη). (*1b*) eapply transportf_bind, assoc_disp. etrans. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. etrans. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. exact (disp_nat_trans_ax η (♯ GG (ε x yy))). (*2*) eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. cbn. etrans. eapply transportf_transpose_right. apply @pathsinv0, (disp_functor_comp GG). eapply transportf_bind. etrans. apply maponpaths. apply (disp_nat_trans_ax ε). (*3*) cbn. etrans. apply (disp_functor_transportf _ GG). eapply transportf_bind. apply (disp_functor_comp GG). eapply transportf_bind. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. apply (disp_nat_trans_ax η (η _ (GG x yy))). (*4*) cbn. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. etrans. eapply transportf_transpose_right. apply @pathsinv0, (disp_functor_comp GG). (*5*) eapply transportf_bind. etrans. apply maponpaths, T1. (*6*) etrans. apply (disp_functor_transportf _ GG). eapply transportf_bind. apply (disp_functor_id GG). eapply transportf_bind. apply id_left_disp. etrans. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. etrans. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. exact (z_iso_disp_after_inv_mor _). (*7a*) eapply transportf_bind. apply id_left_disp. apply maponpaths. exact (z_iso_disp_after_inv_mor _). (*7b*) etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Time Qed. Lemma triangle_1_from_2_for_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D' : disp_cat C'} (AA : disp_adjunction_data E D D') (EE : form_equiv_over (E:=E) AA) : triangle_2_statement_over (A:=E) AA -> triangle_1_statement_over (A:=E) AA. Proof. (* dual to previous lemma *) Abort. Definition is_equiv_of_equiv_over {C C' : category} (E : adj_equiv C C') {D : disp_cat C} {D': disp_cat C'} (EE : equiv_over E D D') : is_equiv_over E (left_adj_over EE). Proof. use tpair. - apply (right_adjoint_of_disp_adjunction EE). - apply (axioms_of_equiv_over E EE). Defined. (* TODO: adjointification of a quasi-equivalence. *) End DisplayedEquivalences. Section Constructions. (** * Constructions on and of displayed equivalences *) (** ** Full + faithful + ess split => equivalence *) Local Open Scope cat. Section Equiv_from_ff_plus_ess_split. (* TODO: consider naming throughout this section! Especially: anything with [ses] should be fixed. *) Context {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') (FF_split : disp_functor_disp_ess_split_surj FF) (FF_ff : disp_functor_ff FF). (** *** Utility lemmas from fullness+faithfulness *) (* TODO: inline throughout? *) Let FFweq {x y} xx yy (f : x --> y) : xx -->[ f] yy ≃ FF x xx -->[#F f] FF y yy := disp_functor_ff_weq _ FF_ff xx yy f. Let FFinv {x y} {xx} {yy} {f} : FF x xx -->[#F f] FF y yy → xx -->[ f] yy := @disp_functor_ff_inv _ _ _ _ _ _ FF_ff x y xx yy f. (* TODO: once [disp_functor_ff_transportf_gen] is done, replace this with that. *) Lemma FFinv_transportf {x y : C} {f f' : x --> y} (e : f = f') {xx : D x} {yy : D y} (ff : FF _ xx -->[#F f] FF _ yy) : FFinv (transportf (λ f', _ -->[#F f'] _ ) e ff) = transportf _ e (FFinv ff). Proof. destruct e. apply idpath. Qed. Definition disp_functor_ff_reflects_isos {x y} {xx : D x} {yy : D y} {f : z_iso x y} (ff : xx -->[ f ] yy) (isiso: is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff)) : is_z_iso_disp _ ff. Proof. set (FFffinv := inv_mor_disp_from_z_iso isiso). set (FFffinv':= transportf (λ f', _ -->[ _ ] _ ) (functor_on_inv_from_z_iso F f) FFffinv). cbn in FFffinv'. set (ffinv := FFinv FFffinv'). exists ffinv. split. - abstract (unfold ffinv, FFffinv'; clear ffinv FFffinv' ; apply (invmaponpathsweq (@FFweq _ _ _ _ _ )) ; cbn ; etrans ; [ apply (disp_functor_comp FF) | ] ; etrans ; [ apply maponpaths ; apply maponpaths_2 ; apply (homotweqinvweq (@FFweq _ _ _ _ _ )) | ] ; rewrite transportf_const ; unfold idfun ; unfold FFffinv ; clear FFffinv ; etrans ; [ apply maponpaths ; apply (z_iso_disp_after_inv_mor isiso) | ] ; etrans ; [ apply transport_f_f | ] ; apply pathsinv0 ; etrans ; [ apply (disp_functor_transportf _ FF) | ] ; etrans ; [ apply maponpaths ; apply disp_functor_id | ] ; etrans ; [ apply transport_f_f | ] ; apply maponpaths_2 ; apply homset_property). - abstract (unfold ffinv, FFffinv'; clear ffinv FFffinv' ; apply (invmaponpathsweq (@FFweq _ _ _ _ _ )) ; cbn ; etrans ; [ apply (disp_functor_comp FF) | ] ; etrans ; [ apply maponpaths ; apply maponpaths ; apply (homotweqinvweq (@FFweq _ _ _ _ _ )) | ] ; etrans ; [ apply maponpaths ; eapply maponpaths ; apply (eqtohomot (transportf_const _ _)) | ] ; etrans ; [ apply maponpaths ; unfold FFffinv ; apply (inv_mor_after_z_iso_disp isiso) | ] ; etrans ; [ apply transport_f_f | ] ; apply pathsinv0 ; etrans ; [ apply (disp_functor_transportf _ FF) | ] ; etrans ; [ apply maponpaths ; apply disp_functor_id | ] ; etrans ; [ apply transport_f_f | ] ; apply maponpaths_2 ; apply homset_property). Defined. Definition FFinv_on_z_iso_is_z_iso {x y} {xx : D x} {yy : D y} {f : z_iso x y} (ff : FF _ xx -->[ (#F)%cat f ] FF _ yy) (Hff: is_z_iso_disp (functor_on_z_iso F f) ff) : is_z_iso_disp _ (FFinv ff). Proof. apply disp_functor_ff_reflects_isos. use (transportf _ _ Hff). apply @pathsinv0. use homotweqinvweq. Qed. (* TODO: The converse functor. *) End Equiv_from_ff_plus_ess_split. (* TODO: Induced adjunctions / equivalences of fiber cats. *) End Constructions. (** * Displayed equivalences and adjunctions over identity *) (** ** Adjunctions *) Section AdjunctionsOverId. (** In general, one can define displayed equivalences/adjunctions over any equivalences/adjunctions between the bases (and probably more generally still). For now we just give the case over a single base precategory — i.e. over an identity functor. We give the “bidirectional” version first, and then the “handed” versions afterwards, with enough coercions between the two to (hopefully) make it easy to work with both versions. *) (* TODO: consider carefully the graph of coercions in this section; make them more systematic, and whatever we decide on, DOCUMENT the system clearly. *) Definition disp_adjunction_id_data {C} (D D' : disp_cat C) : UU := ∑ (FF : disp_functor (functor_identity _) D D') (GG : disp_functor (functor_identity _) D' D), (disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite FF GG)) × (disp_nat_trans (nat_trans_id _ ) (disp_functor_composite GG FF) (disp_functor_identity _)). (* TODO: consider naming of these access functions *) Definition left_adj_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') : disp_functor _ D D' := pr1 A. Coercion left_adj_over_id : disp_adjunction_id_data >-> disp_functor. Definition right_adj_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') : disp_functor _ D' D := pr1 (pr2 A). Definition unit_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') := pr1 (pr2 (pr2 A)). Definition counit_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') := pr2 (pr2 (pr2 A)). (** Triangle identies for an adjunction *) (** Note: the statements of these axioms include [_statement_] to distinguish them from the _instances_ of these statements given by the access functions of [form_adjunction]. This roughly follows the pattern of [univalenceStatement], [funextfunStatement], etc., but departs from it slightly to follow our more general convention of using underscores instead of camelcase. *) Definition triangle_1_statement_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') (FF := left_adj_over_id A) (η := unit_over_id A) (ε := counit_over_id A) : UU := ∏ x xx, ♯ FF ( η x xx) ;; ε _ (FF _ xx) = transportb _ (id_left _ ) (id_disp _) . Definition triangle_2_statement_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') (GG := right_adj_over_id A) (η := unit_over_id A) (ε := counit_over_id A) : UU := ∏ x xx, η _ (GG x xx) ;; ♯ GG (ε _ xx) = transportb _ (id_left _ ) (id_disp _). Definition form_disp_adjunction_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') : UU := triangle_1_statement_over_id A × triangle_2_statement_over_id A. Definition disp_adjunction_id {C} (D D' : disp_cat C) : UU := ∑ A : disp_adjunction_id_data D D', form_disp_adjunction_id A. Definition data_of_disp_adjunction_id {C} {D D' : disp_cat C} (A : disp_adjunction_id D D') := pr1 A. Coercion data_of_disp_adjunction_id : disp_adjunction_id >-> disp_adjunction_id_data. Definition triangle_1_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id D D') := pr1 (pr2 A). Definition triangle_2_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id D D') := pr2 (pr2 A). (** The “left-handed” version: right adjoints to a given functor *) (** The terminology is difficult to choose here: the proposition “F is a left adjoint” is the same as the type of “right adjoints to F”, so should this type be called something more like [left_adjoint F] or [right_adjoint F]? Our choice here does _not_ agree with that of the base UniMath category theory library. TODO: consider these conventions, and eventually harmonise them by changing it either here or in UniMath. *) Definition right_adjoint_over_id_data {C} {D D' : disp_cat C} (FF : disp_functor (functor_identity _) D D') : UU := ∑ (GG : disp_functor (functor_identity _) D' D), (disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (disp_functor_composite FF GG)) × (disp_nat_trans (nat_trans_id _ ) (disp_functor_composite GG FF) (disp_functor_identity _)). Definition functor_of_right_adjoint_over_id {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (GG : right_adjoint_over_id_data FF) := pr1 GG. Coercion functor_of_right_adjoint_over_id : right_adjoint_over_id_data >-> disp_functor. Definition adjunction_of_right_adjoint_over_id_data {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (GG : right_adjoint_over_id_data FF) : disp_adjunction_id_data D D' := (FF,, GG). Coercion adjunction_of_right_adjoint_over_id_data : right_adjoint_over_id_data >-> disp_adjunction_id_data. Definition right_adjoint_of_disp_adjunction_id_data {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') : right_adjoint_over_id_data A := pr2 A. Definition right_adjoint_over_id {C} {D D' : disp_cat C} (FF : disp_functor (functor_identity _) D D') : UU := ∑ GG : right_adjoint_over_id_data FF, form_disp_adjunction_id GG. Definition data_of_right_adjoint_over_id {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (GG : right_adjoint_over_id FF) := pr1 GG. Coercion data_of_right_adjoint_over_id : right_adjoint_over_id >-> right_adjoint_over_id_data. Definition adjunction_of_right_adjoint_over_id {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (GG : right_adjoint_over_id FF) : disp_adjunction_id D D' := (adjunction_of_right_adjoint_over_id_data GG ,, pr2 GG). Definition right_adjoint_of_disp_adjunction_id {C} {D D' : disp_cat C} (A : disp_adjunction_id D D') : right_adjoint_over_id A := (right_adjoint_of_disp_adjunction_id_data A,, pr2 A). (* TODO: add the dual-handedness version, i.e. indexed over GG instead of FF. *) End AdjunctionsOverId. (** Being an adjunction is a proposition *) Proposition isaprop_form_disp_adjunction_id {C : category} {D₁ D₂ : disp_cat C} (F : disp_functor (functor_identity C) D₁ D₂) (HF : right_adjoint_over_id_data F) : isaprop (form_disp_adjunction_id HF). Proof. use isapropdirprod ; do 2 (use impred ; intro). - apply D₂. - apply D₁. Qed. Section EquivalencesOverId. (** ** Displayed equivalences over id (adjoint and quasi) *) Definition form_equiv_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') (η := unit_over_id A) (ε := counit_over_id A) : UU := (∏ x xx, is_z_iso_disp (identity_z_iso _ ) (η x xx)) × (∏ x xx, is_z_iso_disp (identity_z_iso _ ) (ε x xx)). Definition is_z_iso_unit_over_id {C} {D D' : disp_cat C} {A : disp_adjunction_id_data D D'} (E : form_equiv_over_id A) := pr1 E. Definition is_z_iso_counit_over_id {C} {D D' : disp_cat C} {A : disp_adjunction_id_data D D'} (E : form_equiv_over_id A) := pr2 E. Definition equiv_over_id {C} (D D' : disp_cat C) : UU := ∑ A : disp_adjunction_id D D', form_equiv_over_id A. Definition adjunction_of_equiv_over_id {C} {D D' : disp_cat C} (A : equiv_over_id D D') := pr1 A. Coercion adjunction_of_equiv_over_id : equiv_over_id >-> disp_adjunction_id. Definition axioms_of_equiv_over_id {C} {D D' : disp_cat C} (A : equiv_over_id D D') := pr2 A. Coercion axioms_of_equiv_over_id : equiv_over_id >-> form_equiv_over_id. Definition is_equiv_over_id {C} {D D' : disp_cat C} (FF : disp_functor (functor_identity _) D D') : UU := ∑ GG : right_adjoint_over_id FF, form_equiv_over_id GG. Definition right_adjoint_of_is_equiv_over_id {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (E : is_equiv_over_id FF) := pr1 E. Coercion right_adjoint_of_is_equiv_over_id : is_equiv_over_id >-> right_adjoint_over_id. Definition equiv_of_is_equiv_over_id {C} {D D' : disp_cat C} {FF : disp_functor _ D D'} (E : is_equiv_over_id FF) : equiv_over_id D D' := (adjunction_of_right_adjoint_over_id E ,, pr2 E). Coercion equiv_of_is_equiv_over_id : is_equiv_over_id >-> equiv_over_id. (* Again, don’t worry about the ambiguous path generated here. *) Definition is_equiv_of_equiv_over_id {CC} {DD DD' : disp_cat CC} (E : equiv_over_id DD DD') : is_equiv_over_id E := (right_adjoint_of_disp_adjunction_id E,, axioms_of_equiv_over_id E). (* TODO: right-handed versions *) (* TODO: [quasi_equiv_over_id] (without triangle identities). *) (** ** Lemmas on the triangle identities *) Local Open Scope hide_transport_scope. Lemma triangle_2_from_1_for_equiv_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') (E : form_equiv_over_id A) : triangle_1_statement_over_id A -> triangle_2_statement_over_id A. Proof. destruct A as [FF [GG [η ε]]]. destruct E as [Hη Hε]; cbn in Hη, Hε. unfold triangle_1_statement_over_id, triangle_2_statement_over_id; cbn. intros T1 x yy. (* Algebraically, this goes as follows: η G ; G ε = G ε^ ; η^ G ; η G ; G ε ; η G ; G ε [by inverses, 1] = G ε^ ; η^ G ; η G ; η G F G ; G F G ε ; G ε [by naturality, 2] = G ε^ ; η^ G ; η G ; η G F G ; G ε F G ; G ε [by naturality, 3] = G ε^ ; η^ G ; η G ; G F η G ; G ε F G ; G ε [by naturality, 4] = G ε^ ; η^ G ; η G ; G (F η ; ε F ) G ; G ε [by functoriality, 5] = G ε^ ; η^ G ; η G ; G ε [by T1, 6] = 1 [by inverses, 7] It’s perhaps most readable when written in string diagrams. *) etrans. apply id_left_disp_var. etrans. eapply transportf_bind. eapply cancel_postcomposition_disp. etrans. eapply transportf_transpose_right. apply @pathsinv0. refine (z_iso_disp_after_inv_mor _). refine (disp_functor_on_is_z_iso_disp GG _). apply Hε. (*1a*) eapply transportf_bind. eapply cancel_postcomposition_disp. etrans. apply id_right_disp_var. eapply transportf_bind. etrans. eapply cancel_precomposition_disp. eapply transportf_transpose_right. apply @pathsinv0. refine (z_iso_disp_after_inv_mor _). apply (Hη). (*1b*) eapply transportf_bind, assoc_disp. etrans. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. etrans. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. exact (disp_nat_trans_ax η (♯ GG (ε x yy))). (*2*) eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. cbn. etrans. eapply transportf_transpose_right. apply @pathsinv0, (disp_functor_comp GG). eapply transportf_bind. etrans. apply maponpaths. apply (disp_nat_trans_ax ε). (*3*) cbn. etrans. apply (disp_functor_transportf _ GG). eapply transportf_bind. apply (disp_functor_comp GG). eapply transportf_bind. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. apply (disp_nat_trans_ax η (η x (GG x yy))). (*4*) cbn. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. etrans. eapply transportf_transpose_right. apply @pathsinv0, (disp_functor_comp GG). (*5*) eapply transportf_bind. etrans. apply maponpaths, T1. (*6*) etrans. apply (disp_functor_transportf _ GG). eapply transportf_bind. apply (disp_functor_id GG). eapply transportf_bind. apply id_left_disp. etrans. eapply transportf_bind. etrans. apply assoc_disp_var. eapply transportf_bind. etrans. eapply cancel_precomposition_disp. etrans. apply assoc_disp. eapply transportf_bind. etrans. eapply cancel_postcomposition_disp. exact (z_iso_disp_after_inv_mor _). (*7a*) eapply transportf_bind. apply id_left_disp. apply maponpaths. exact (z_iso_disp_after_inv_mor _). (*7b*) etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Qed. (* TODO: [Qed.] takes about 30sec! [etrans_dep] + [etrans_disp] make it shorter and more readable (see commit 7c1f411a), but make the typechecking time even worse. *) Lemma triangle_1_from_2_for_equiv_over_id {C} {D D' : disp_cat C} (A : disp_adjunction_id_data D D') (E : form_equiv_over_id A) : triangle_2_statement_over_id A -> triangle_1_statement_over_id A. Proof. (* dual to previous lemma *) Abort. (* TODO: adjointification of a quasi-equivalence. *) End EquivalencesOverId. (** Being an equivalence is a proposition *) Proposition isaprop_form_equiv_over_id {C : category} {D₁ D₂ : disp_cat C} (HF : disp_adjunction_id_data D₁ D₂) : isaprop (form_equiv_over_id HF). Proof. use isapropdirprod ; repeat (use impred ; intro) ; apply isaprop_is_z_iso_disp. Qed. (** Useful lemma *) Proposition triangle_1_over_id_alt {C : category} {D₁ : disp_cat C} {D₂ : disp_cat C} (LL : disp_functor (functor_identity _) D₁ D₂) (HLL : is_equiv_over_id LL) {x : C} (xx : D₁ x) : ♯ LL (inv_mor_disp_from_z_iso (is_z_iso_unit_over_id HLL x xx)) = counit_over_id HLL x (LL x xx). Proof. refine (_ @ !(id_left_disp_var _)). rewrite disp_functor_id_var. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. exact (!(transportf_transpose_left (z_iso_disp_after_inv_mor (is_z_iso_unit_over_id HLL x xx)))). } rewrite disp_functor_transportf. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. exact (triangle_1_over_id HLL x xx). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. (** * Constructions on and of displayed equivalences over identity *) (** ** Full + faithful + ess split => equivalence *) Section Equiv_from_ff_plus_ess_split. (* TODO: consider naming throughout this section! Especially: anything with [ses] should be fixed. *) Context {C : category} {D' D : disp_cat C} (FF : disp_functor (functor_identity _) D' D) (FF_split : disp_functor_disp_ess_split_surj FF) (FF_ff : disp_functor_ff FF). (** *** Utility lemmas from fullness+faithfulness *) (* TODO: inline throughout? *) Let FFweq {x y} xx yy (f : x --> y) := disp_functor_ff_weq _ FF_ff xx yy f. Let FFinv {x y} {xx} {yy} {f} := @disp_functor_ff_inv _ _ _ _ _ _ FF_ff x y xx yy f. (* TODO: once [disp_functor_ff_transportf_gen] is done, replace this with that. *) Lemma FFinv_over_id_transportf {x y : C} {f f' : x --> y} (e : f = f') {xx : D' x} {yy : D' y} (ff : FF _ xx -->[f] FF _ yy) : FFinv (transportf _ e ff) = transportf _ e (FFinv ff). Proof. destruct e. apply idpath. Qed. Definition disp_functor_id_ff_reflects_isos {x y} {xx : D' x} {yy : D' y} {f : z_iso x y} (ff : xx -->[ f ] yy) (isiso: is_z_iso_disp f (♯ FF ff)) : is_z_iso_disp _ ff. Proof. use (disp_functor_ff_reflects_isos FF FF_ff). exact (disp_functor_on_is_z_iso_disp (disp_functor_identity _) isiso). Qed. Definition FFinv_over_id_on_z_iso_is_z_iso {x y} {xx : D' x} {yy : D' y} {f : z_iso x y} (ff : FF _ xx -->[ f ] FF _ yy) (Hff: is_z_iso_disp f ff) : is_z_iso_disp _ (FFinv ff). Proof. apply disp_functor_id_ff_reflects_isos. use (transportf _ _ Hff). apply @pathsinv0. use homotweqinvweq. Qed. (** *** Converse functor *) (* TODO: does [Local Definition] actually keep it local? It seems not — e.g. [Print GG_data] still works after the section closes. Is there a way to actually keep them local? If not, find less generic names for [GG] and its components. *) Local Definition GG_data : disp_functor_data (functor_identity _ ) D D'. Proof. use tpair. + intros x xx. exact (pr1 (FF_split x xx)). + intros x y xx yy f ff; simpl. set (Hxx := FF_split x xx). set (Hyy := FF_split y yy). apply FFinv. refine (transportf (mor_disp _ _) _ _). 2: exact ((pr2 Hxx ;; ff) ;; inv_mor_disp_from_z_iso (pr2 Hyy)). cbn. etrans. apply id_right. apply id_left. Defined. Local Lemma GG_ax : disp_functor_axioms GG_data. Proof. split; simpl. + intros x xx. apply invmap_eq. cbn. etrans. 2: apply @pathsinv0, (disp_functor_id FF). etrans. apply maponpaths. etrans. apply maponpaths_2, id_right_disp. etrans. apply mor_disp_transportf_postwhisker. apply maponpaths, (inv_mor_after_z_iso_disp (pr2 (FF_split _ _))). etrans. apply transport_f_f. etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. + intros x y z xx yy zz f g ff gg. apply invmap_eq. cbn. etrans. 2: { apply @pathsinv0. etrans. apply (disp_functor_comp FF). etrans. apply maponpaths. etrans. apply maponpaths; use homotweqinvweq. apply maponpaths_2; use homotweqinvweq. etrans. apply maponpaths. etrans. apply mor_disp_transportf_prewhisker. apply maponpaths. etrans. apply mor_disp_transportf_postwhisker. apply maponpaths. etrans. apply maponpaths, assoc_disp_var. etrans. apply mor_disp_transportf_prewhisker. apply maponpaths. etrans. apply assoc_disp. apply maponpaths. etrans. apply maponpaths_2. etrans. apply assoc_disp_var. apply maponpaths. etrans. apply maponpaths. exact (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))). etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths, id_right_disp. apply transport_f_f. etrans. apply maponpaths_2, transport_f_f. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply transport_f_f. (* A trick to hide the huge equality term: *) apply maponpaths_2. shelve. } etrans. apply maponpaths. etrans. apply maponpaths_2, assoc_disp. etrans. apply mor_disp_transportf_postwhisker. apply maponpaths. apply assoc_disp_var. etrans. apply transport_f_f. etrans. apply transport_f_f. apply maponpaths_2, homset_property. Unshelve. 2: apply idpath. Qed. Definition GG : disp_functor _ _ _ := (_ ,, GG_ax). Definition ε_ses_ff_data : disp_nat_trans_data (nat_trans_id _ ) (disp_functor_composite GG FF) (disp_functor_identity _ ) := λ x xx, (pr2 (FF_split x xx)). Lemma ε_ses_ff_ax : disp_nat_trans_axioms ε_ses_ff_data. Proof. intros x y f xx yy ff. cbn. unfold ε_ses_ff_data. etrans. apply maponpaths_2; use homotweqinvweq. etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. etrans. apply assoc_disp_var. apply maponpaths. etrans. apply maponpaths. apply (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))). etrans. apply mor_disp_transportf_prewhisker. apply maponpaths, id_right_disp. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Qed. Definition ε_ses_ff : disp_nat_trans (nat_trans_id _ ) (disp_functor_composite GG FF) (disp_functor_identity _ ) := (ε_ses_ff_data,, ε_ses_ff_ax). Definition η_ses_ff_data : disp_nat_trans_data (nat_trans_id _) (disp_functor_identity _ ) (disp_functor_composite FF GG). Proof. intros x xx. cbn. apply FFinv. exact (inv_mor_disp_from_z_iso (pr2 (FF_split _ _))). Defined. Definition η_ses_ff_ax : disp_nat_trans_axioms η_ses_ff_data. Proof. intros x y f xx yy ff. cbn. unfold η_ses_ff_data. (* This feels a bit roundabout. Can it be simplified? *) apply @pathsinv0. etrans. eapply maponpaths. etrans. apply @pathsinv0, disp_functor_ff_inv_compose. apply maponpaths. etrans. apply mor_disp_transportf_prewhisker. apply maponpaths. etrans. apply assoc_disp. apply maponpaths. etrans. apply maponpaths_2. etrans. apply assoc_disp. apply maponpaths. etrans. apply maponpaths_2, (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))). etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths, id_left_disp. apply transport_f_f. etrans. apply maponpaths_2, transport_f_f. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. etrans. apply maponpaths. etrans. apply transport_f_f. apply transport_f_f. apply FFinv_over_id_transportf. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply homset_property. etrans. apply (disp_functor_ff_inv_compose _ FF_ff). apply maponpaths_2, homotinvweqweq. Qed. Definition η_ses_ff : disp_nat_trans (nat_trans_id _) (disp_functor_identity _ ) (disp_functor_composite FF GG) := (_ ,, η_ses_ff_ax). Definition GGεη : right_adjoint_over_id_data FF := (GG,, (η_ses_ff,, ε_ses_ff)). Lemma form_equiv_GGεη : form_equiv_over_id GGεη. Proof. split; intros x xx; cbn. - unfold η_ses_ff_data. apply (@FFinv_over_id_on_z_iso_is_z_iso _ _ _ _ (identity_z_iso _)). eapply is_z_iso_disp_independent_of_is_z_iso. exact (@is_z_iso_inv_from_z_iso_disp _ _ _ _ (identity_z_iso _) _ _ _). - unfold ε_ses_ff_data. apply is_z_iso_disp_from_z_iso. Qed. Lemma tri_1_GGεη : triangle_1_statement_over_id GGεη. Proof. intros x xx; cbn. unfold ε_ses_ff_data, η_ses_ff_data. etrans. apply maponpaths_2; use homotweqinvweq. etrans. exact (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))). apply maponpaths_2, homset_property. Qed. Lemma tri_2_GGεη : triangle_2_statement_over_id GGεη. Proof. apply triangle_2_from_1_for_equiv_over_id. apply form_equiv_GGεη. apply tri_1_GGεη. Qed. Theorem is_equiv_from_ff_ess_over_id : is_equiv_over_id FF. Proof. use ((GGεη,, _) ,, _). split. apply tri_1_GGεη. apply tri_2_GGεη. apply form_equiv_GGεη. Defined. End Equiv_from_ff_plus_ess_split. (** ** Inverses and composition of adjunctions/equivalences *) Section Nat_Trans_Disp_Inv. Context {C : category} {D' D : disp_cat C} {FF GG : disp_functor (functor_identity _) D' D} (alpha : disp_nat_trans (nat_trans_id _ ) FF GG) (Ha : ∏ x xx, is_z_iso_disp (identity_z_iso _ ) (alpha x xx)). (* Lemma inv_ax : disp_nat_trans_axioms (λ (x : C) (xx : D' x), @inv_mor_disp_from_iso _ _ _ _ (identity_iso _ ) _ _ _ (Ha x xx)). *) Local Lemma inv_ax : @disp_nat_trans_axioms C C (functor_identity_data C) (functor_identity_data C) (@nat_trans_id C C (functor_identity_data C)) D' D GG FF (λ (x : C) (xx : D' x), @inv_mor_disp_from_z_iso C D ((functor_identity C) x) ((functor_identity C) x) (@identity_z_iso C ((functor_identity C) x)) (FF x xx) (GG x xx) (alpha x xx) (Ha x xx)). Proof. intros x y f xx yy ff. apply pathsinv0. apply transportf_pathsinv0. apply pathsinv0. set (XR := @z_iso_disp_precomp). specialize (XR _ _ _ _ (identity_z_iso _ ) _ _ (alpha x xx ,, Ha x xx) ). match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E. specialize (XR _ (identity x · f) (FF y yy)). set (R := make_weq _ XR). apply (invmaponpathsweq R). unfold R. unfold E. cbn. etrans. apply assoc_disp. etrans. apply maponpaths. apply maponpaths_2. apply (inv_mor_after_z_iso_disp (Ha x xx)). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_left_disp. etrans. apply transport_f_f. apply pathsinv0. etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths. apply assoc_disp. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths_2. apply (disp_nat_trans_ax_var alpha). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp_var. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths. apply (inv_mor_after_z_iso_disp (Ha _ _ )). etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_right_disp. etrans. apply transport_f_f. apply maponpaths_2. apply homset_property. Qed. Local Definition inv : disp_nat_trans (nat_trans_id _ ) GG FF. Proof. use tpair. - intros x xx. apply (inv_mor_disp_from_z_iso (Ha _ _ )). - apply inv_ax. Defined. End Nat_Trans_Disp_Inv. Section Displayed_Equiv_Inv. Context {C : category} {D' D : disp_cat C} (FF : disp_functor (functor_identity _) D' D) (isEquiv : is_equiv_over_id FF). Let GG : disp_functor _ D D' := right_adjoint_of_is_equiv_over_id isEquiv. Let η : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_identity D') (disp_functor_composite FF GG) := unit_over_id isEquiv. Let ε : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_composite GG FF) (disp_functor_identity D) := counit_over_id isEquiv. Definition η_inv : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_identity D) (disp_functor_composite GG FF). Proof. apply (inv ε). apply (is_z_iso_counit_over_id isEquiv). Defined. Definition ε_inv : disp_nat_trans (nat_trans_id (functor_identity C)) (disp_functor_composite FF GG) (disp_functor_identity D'). Proof. apply (inv η). cbn. apply (is_z_iso_unit_over_id isEquiv). Defined. Definition inv_adjunction_data : disp_adjunction_id_data D D'. Proof. exists GG. exists FF. exists η_inv. exact ε_inv. Defined. Lemma form_equiv_inv_adjunction_data : form_equiv_over_id inv_adjunction_data. Proof. cbn. use tpair. + intros. cbn. set (XR:= @is_z_iso_inv_from_is_z_iso_disp). specialize (XR _ D _ _ _ _ _ _ (is_z_iso_counit_over_id (pr2 isEquiv) x xx)). cbn in XR. eapply is_z_iso_disp_independent_of_is_z_iso. apply XR. + cbn. intros. set (XR:= @is_z_iso_inv_from_is_z_iso_disp). specialize (XR _ D' _ _ _ _ _ _ (is_z_iso_unit_over_id (pr2 isEquiv) x xx)). cbn in XR. eapply is_z_iso_disp_independent_of_is_z_iso. apply XR. Qed. Lemma inv_triangle_1_statement_over_id : triangle_1_statement_over_id inv_adjunction_data. Proof. intros x xx. cbn. set (XR:= @z_iso_disp_precomp). set (Gepsxxx := (♯ GG (ε x xx))). set (RG := @disp_functor_on_is_z_iso_disp _ _ (functor_identity C)). specialize (RG _ _ GG). specialize (RG _ _ _ _ (identity_z_iso _ ) (ε x xx)). specialize (RG (is_z_iso_counit_over_id (pr2 isEquiv) x xx)). transparent assert (Ge : (z_iso_disp (identity_z_iso x) (GG _ (FF _ (GG _ xx))) (GG _ xx))). { apply (make_z_iso_disp (f:=identity_z_iso _ ) Gepsxxx). eapply is_z_iso_disp_independent_of_is_z_iso. apply RG. } match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E. specialize (XR _ _ _ _ _ _ _ Ge). specialize (XR _ (identity x · identity x ) (GG x xx)). apply (invmaponpathsweq (make_weq _ XR)). unfold E; clear E. cbn. clear RG XR Ge. unfold Gepsxxx. etrans. apply assoc_disp. etrans. apply maponpaths. apply maponpaths_2. eapply pathsinv0. apply (disp_functor_comp_var GG). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths_2. apply maponpaths. apply (inv_mor_after_z_iso_disp (is_z_iso_counit_over_id (pr2 isEquiv) x xx)). etrans. apply maponpaths. apply maponpaths_2. apply (disp_functor_transportf _ GG). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply ( transport_f_f _ _ _ _ ). etrans. apply maponpaths. apply maponpaths_2. apply (disp_functor_id GG). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_left_disp. etrans. apply transport_f_f. match goal with |[|- transportf _ ?EE _ = _ ] => generalize EE end. intro EE. set (XR:= @z_iso_disp_precomp). set (etaGxxx := η _ (GG x xx)). transparent assert (Ge : (z_iso_disp (identity_z_iso x) (GG _ xx) (GG _ (FF _ (GG _ xx))) )). { apply (make_z_iso_disp (f:=identity_z_iso _ ) etaGxxx). eapply is_z_iso_disp_independent_of_is_z_iso. apply (is_z_iso_unit_over_id (pr2 isEquiv) ). } match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E. specialize (XR _ _ _ _ _ _ _ Ge). specialize (XR _ (identity x · (identity x · identity x) ) (GG x xx)). apply (invmaponpathsweq (make_weq _ XR)). cbn. unfold etaGxxx. unfold E. clear E. clear XR Ge etaGxxx. clear Gepsxxx. etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths. apply (inv_mor_after_z_iso_disp (is_z_iso_unit_over_id (pr2 isEquiv) x _ )). etrans. apply transport_f_f. apply pathsinv0. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths. apply maponpaths. apply id_right_disp. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. set (XR := triangle_2_over_id isEquiv). unfold triangle_1_statement_over_id in XR. cbn in XR. etrans. apply maponpaths. apply XR. etrans. apply transport_f_f. apply maponpaths_2. apply homset_property. Qed. Lemma inv_triangle_2_statement_over_id : triangle_2_statement_over_id inv_adjunction_data. Proof. apply triangle_2_from_1_for_equiv_over_id. - apply form_equiv_inv_adjunction_data. - apply inv_triangle_1_statement_over_id. Qed. Definition equiv_inv : is_equiv_over_id GG. Proof. use tpair. - use tpair. + exact (FF,, (η_inv,, ε_inv)). + use tpair. cbn. apply inv_triangle_1_statement_over_id. apply inv_triangle_2_statement_over_id. - apply form_equiv_inv_adjunction_data. Defined. End Displayed_Equiv_Inv. Section Displayed_Equiv_Compose. (* TODO: give composites of displayed equivalences. *) End Displayed_Equiv_Compose. (** ** Induced adjunctions/equivalences of fiber precats *) Section Equiv_Fibers. Context {C : category}. Definition fiber_is_left_adj {D D' : disp_cat C} {FF : disp_functor (functor_identity _) D D'} (EFF : right_adjoint_over_id FF) (c : C) : is_left_adjoint (fiber_functor FF c). Proof. destruct EFF as [[GG [η ε]] axs]; simpl in axs. exists (fiber_functor GG _). exists (fiber_nat_trans η _,, fiber_nat_trans ε _). use tpair; cbn. + unfold triangle_1_statement. intros d; cbn. set (thisax := pr1 axs c d); clearbody thisax; clear axs. etrans. apply maponpaths, thisax. etrans. apply transport_f_b. use (@maponpaths_2 _ _ _ _ _ (paths_refl _)). apply homset_property. + unfold triangle_2_statement. intros d; cbn. set (thisax := pr2 axs c d); clearbody thisax; clear axs. etrans. apply maponpaths, thisax. etrans. apply transport_f_b. use (@maponpaths_2 _ _ _ _ _ (paths_refl _)). apply homset_property. Defined. Definition fiber_equiv {D D' : disp_cat C} {FF : disp_functor (functor_identity _) D D'} (EFF : is_equiv_over_id FF) (c : C) : adj_equivalence_of_cats (fiber_functor FF c). Proof. exists (fiber_is_left_adj EFF c). destruct EFF as [[[GG [η ε]] tris] isos]; cbn in isos; cbn. use tpair. + intros d. apply is_z_iso_fiber_from_is_z_iso_disp. apply (is_z_iso_unit_over_id isos). + intros d. apply is_z_iso_fiber_from_is_z_iso_disp. apply (is_z_iso_counit_over_id isos). Defined. End Equiv_Fibers. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples.v000066400000000000000000000537701451125700300243360ustar00rootroot00000000000000 (** * Examples A typical use for displayed categories is for constructing categories of structured objects, over a given (specific or general) category. We give a few examples here: - category of topological space as total category - arrow precategories - objects with N-actions - elements, over hSet *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Limits. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Local Open Scope mor_disp_scope. (** * Displayed category of groups *) Module group. Definition grp_structure_data (X : hSet) : UU := (X -> X -> X) × X × (X -> X). Definition mult {X : hSet} (G : grp_structure_data X) : X -> X -> X := pr1 G. Definition e {X : hSet} (G : grp_structure_data X) : X := pr1 (pr2 G). Definition inv {X : hSet} (G : grp_structure_data X) : X -> X := pr2 (pr2 G). Definition grp_structure_axioms {X : hSet} (G : grp_structure_data X) : UU := (∏ x y z : X, mult G x (mult G y z) = mult G (mult G x y) z) × (∏ x : X, mult G x (e G) = x) × (∏ x : X, mult G (e G) x = x) × (∏ x : X, mult G x (inv G x) = e G) × (∏ x : X, mult G (inv G x) x = e G). Definition grp_assoc {X : hSet} {G : grp_structure_data X} (GH : grp_structure_axioms G) : ∏ x y z : X, mult G x (mult G y z) = mult G (mult G x y) z := pr1 GH. Definition grp_e_r {X : hSet} {G : grp_structure_data X} (GH : grp_structure_axioms G) : ∏ x : X, mult G x (e G) = x := pr1 (pr2 GH). Definition grp_e_l {X : hSet} {G : grp_structure_data X} (GH : grp_structure_axioms G) : ∏ x : X, mult G (e G) x = x := pr1 (pr2 (pr2 GH)). Definition grp_inv_r {X : hSet} {G : grp_structure_data X} (GH : grp_structure_axioms G) : ∏ x : X, mult G x (inv G x) = e G := pr1 (pr2 (pr2 (pr2 GH))). Definition grp_inv_l {X : hSet} {G : grp_structure_data X} (GH : grp_structure_axioms G) : ∏ x : X, mult G (inv G x) x = e G := pr2 (pr2 (pr2 (pr2 GH))). Definition grp_structure (X : hSet) : UU := ∑ G : grp_structure_data X, grp_structure_axioms G. Coercion grp_data {X} (G : grp_structure X) : grp_structure_data X := pr1 G. Coercion grp_axioms {X} (G : grp_structure X) : grp_structure_axioms _ := pr2 G. Definition is_grp_hom {X Y : hSet} (f : X -> Y) (GX : grp_structure X) (GY : grp_structure Y) : UU := (∏ x x', f (mult GX x x') = mult GY (f x) (f x')) × (f (e GX) = e GY). Definition grp_hom_mult {X Y : hSet} {f : X -> Y} {GX : grp_structure X} {GY : grp_structure Y} (is : is_grp_hom f GX GY) : ∏ x x', f (mult GX x x') = mult GY (f x) (f x') := pr1 is. Definition grp_hom_e {X Y : hSet} {f : X -> Y} {GX : grp_structure X} {GY : grp_structure Y} (is : is_grp_hom f GX GY) : f (e GX) = e GY := pr2 is. Definition isaprop_is_grp_hom {X Y : hSet} (f : X -> Y) (GX : grp_structure X) (GY : grp_structure Y) : isaprop (is_grp_hom f GX GY). Proof. repeat apply (isofhleveldirprod); repeat (apply impred; intro); apply setproperty. Qed. Definition disp_grp : disp_cat hset_category. Proof. use disp_struct. - exact grp_structure. - intros X Y GX GY f. exact (is_grp_hom f GX GY). - intros. apply isaprop_is_grp_hom. - intros. simpl. repeat split; intros; apply idpath. - intros ? ? ? ? ? ? ? ? Gf Gg ; simpl in *; repeat split; intros; simpl; cbn. + rewrite (grp_hom_mult Gf). apply (grp_hom_mult Gg). + rewrite (grp_hom_e Gf). apply (grp_hom_e Gg). Defined. End group. (** ** The displayed arrow category A very fertile example: many others can be obtained from it by reindexing. *) Section Arrow_Disp. Context (C:category). Definition arrow_disp_ob_mor : disp_cat_ob_mor (category_binproduct C C). Proof. exists (λ xy : (C × C), (pr1 xy) --> (pr2 xy)). simpl; intros xx' yy' g h ff'. exact (pr1 ff' · h = g · pr2 ff'). Defined. Definition arrow_id_comp : disp_cat_id_comp _ arrow_disp_ob_mor. Proof. split. - simpl; intros. eapply pathscomp0. apply id_left. apply pathsinv0, id_right. - simpl; intros x y z f g xx yy zz ff gg. eapply pathscomp0. apply @pathsinv0, assoc. eapply pathscomp0. apply maponpaths, gg. eapply pathscomp0. apply assoc. eapply pathscomp0. apply cancel_postcomposition, ff. apply pathsinv0, assoc. Qed. Definition arrow_data : disp_cat_data _ := (arrow_disp_ob_mor ,, arrow_id_comp). Lemma arrow_axioms : disp_cat_axioms (category_binproduct C C) arrow_data. Proof. repeat apply tpair; intros; try apply homset_property. apply isasetaprop, homset_property. Qed. Definition arrow_disp : disp_cat (category_binproduct C C) := (arrow_data ,, arrow_axioms). End Arrow_Disp. (** ** Objects with N-action For any category C, “C-objects equipped with an N-action” (or more elementarily, with an endomorphism) form a displayed category over C Section ZAct. Once we have pullbacks of displayed precategories, this can be obtained as a pullback of the previous example. *) Section NAction. Context (C:category). Definition NAction_disp_ob_mor : disp_cat_ob_mor C. Proof. exists (λ c, c --> c). intros x y xx yy f. exact (f · yy = xx · f). Defined. Definition NAction_id_comp : disp_cat_id_comp C NAction_disp_ob_mor. Proof. split. - simpl; intros. eapply pathscomp0. apply id_left. apply pathsinv0, id_right. - simpl; intros x y z f g xx yy zz ff gg. eapply pathscomp0. apply @pathsinv0, assoc. eapply pathscomp0. apply maponpaths, gg. eapply pathscomp0. apply assoc. eapply pathscomp0. apply cancel_postcomposition, ff. apply pathsinv0, assoc. Qed. Definition NAction_data : disp_cat_data C := (NAction_disp_ob_mor ,, NAction_id_comp). Lemma NAction_axioms : disp_cat_axioms C NAction_data. Proof. repeat apply tpair; intros; try apply homset_property. apply isasetaprop, homset_property. Qed. Definition NAction_disp : disp_cat C := (NAction_data ,, NAction_axioms). End NAction. (** ** Elements of sets A presheaf on a (pre)category can be viewed as a fiberwise discrete displayed (pre)category. In fact, the universal example of this is the case corresponding to the identity functor on [SET]. So, having given the displayed category for this case, one obtains it for arbitrary presheaves by reindexing. *) (* TODO: move? ponder? *) Section Elements_Disp. Definition elements_ob_mor : disp_cat_ob_mor HSET. Proof. use tpair. - simpl. exact (λ X, X). - simpl. intros X Y x y f. exact (f x = y). Defined. Lemma elements_id_comp : disp_cat_id_comp HSET elements_ob_mor. Proof. apply tpair; simpl. - intros X x. apply idpath. - intros X Y Z f g x y z e_fx_y e_gy_z. cbn. eapply pathscomp0. apply maponpaths, e_fx_y. apply e_gy_z. Qed. Definition elements_data : disp_cat_data HSET := (_ ,, elements_id_comp). Lemma elements_axioms : disp_cat_axioms HSET elements_data. Proof. repeat split; intros; try apply setproperty. apply isasetaprop; apply setproperty. Qed. Definition elements_universal : disp_cat HSET := (_ ,, elements_axioms). Definition disp_cat_of_elements {C : category} (P : functor C HSET) := reindex_disp_cat P elements_universal. Definition elements_universal_mor_eq {X Y : HSET} {f : X --> Y} {x : elements_universal X} {y : elements_universal Y} (ff₁ ff₂ : x -->[ f ] y) : ff₁ = ff₂. Proof. apply Y. Qed. Definition is_z_iso_disp_elements_universal {X Y : HSET} {f : X --> Y} (Hf : is_z_isomorphism f) {x : elements_universal X} {y : elements_universal Y} (ff : x -->[ f ] y) : is_z_iso_disp (make_z_iso' _ Hf) ff. Proof. simple refine (_ ,, _ ,, _). - pose (eqtohomot (z_iso_inv_after_z_iso (make_z_iso' f Hf)) x) as p. cbn in *. refine (_ @ p). apply maponpaths. exact (!ff). - apply elements_universal_mor_eq. - apply elements_universal_mor_eq. Qed. Definition is_opcartesian_disp_elements_universal {X Y : HSET} {f : X --> Y} {x : elements_universal X} {y : elements_universal Y} (p : x -->[ f ] y) : is_opcartesian p. Proof. intros Z z g q. use iscontraprop1. - use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply elements_universal. } apply elements_universal_mor_eq. - simple refine (_ ,, _). + exact (maponpaths g (!p) @ q). + apply elements_universal_mor_eq. Qed. Definition opcleaving_elements_universal : opcleaving elements_universal. Proof. intros X Y x f. simple refine (_ ,, _). - exact (f x). - refine (idpath _ ,, _) ; cbn. apply is_opcartesian_disp_elements_universal. Defined. (* TODO: compare to other definitions of this in the library! *) Definition precat_of_elements {C : category} (P : functor C HSET) := total_category (disp_cat_of_elements P). End Elements_Disp. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Section functor_algebras. Context {C : category} (F : functor C C). Definition functor_alg_ob : C -> UU := λ c, F c --> c. Definition functor_alg_mor : ∏ (x y : C), functor_alg_ob x → functor_alg_ob y → C⟦x,y⟧ → UU. Proof. intros c d a a' r. exact ( (#F r)%cat · a' = a · r). Defined. Definition isaprop_functor_alg_mor : ∏ (x y : C) a a' r, isaprop (functor_alg_mor x y a a' r). Proof. intros. simpl. apply homset_property. Qed. Definition functor_alg_id : ∏ (x : C) (a : functor_alg_ob x), functor_alg_mor _ _ a a (identity x ). Proof. intros; unfold functor_alg_mor. rewrite functor_id; rewrite id_left; apply pathsinv0; apply id_right . Qed. Definition functor_alg_comp : ∏ (x y z : C) a b c (f : C⟦x,y⟧) (g : C⟦y,z⟧), functor_alg_mor _ _ a b f → functor_alg_mor _ _ b c g → functor_alg_mor _ _ a c (f · g). Proof. cbn; intros ? ? ? ? ? ? ? ? X X0; unfold functor_alg_mor in *; rewrite functor_comp; rewrite <-assoc; rewrite X0; rewrite assoc; rewrite X; apply (!assoc _ _ _ ) . Qed. Definition disp_cat_functor_alg : disp_cat C := disp_struct _ _ functor_alg_mor isaprop_functor_alg_mor functor_alg_id functor_alg_comp. Definition total_functor_alg : category := total_category disp_cat_functor_alg. Lemma isaset_functor_alg_ob : ∏ x : C, isaset (functor_alg_ob x). Proof. intro c. apply homset_property. Qed. Lemma is_univalent_disp_functor_alg : is_univalent_disp disp_cat_functor_alg. Proof. use is_univalent_disp_from_SIP_data. - apply isaset_functor_alg_ob. - unfold functor_alg_mor. intros x a a' H H'. rewrite functor_id in H'. rewrite id_left in H'. rewrite id_right in H'. apply H'. Defined. Definition iso_cleaving_functor_alg : iso_cleaving disp_cat_functor_alg. Proof. intros c c' i d. cbn in *. use tpair. - exact (compose (compose (functor_on_z_iso F i) d) (z_iso_inv_from_z_iso i)). - cbn. unfold z_iso_disp. cbn. use tpair. + abstract ( etrans; [eapply pathsinv0; apply id_right |]; repeat rewrite <- assoc; do 2 apply maponpaths; apply pathsinv0; apply z_iso_after_z_iso_inv ). + use tpair. * unfold functor_alg_mor. cbn. repeat rewrite assoc. unfold functor_alg_mor. cbn. rewrite <- functor_comp. rewrite z_iso_after_z_iso_inv. rewrite functor_id. rewrite id_left. apply idpath. * split; apply homset_property. Defined. Local Notation "'π'" := (pr1_category disp_cat_functor_alg). Definition creates_limits_functor_alg : creates_limits disp_cat_functor_alg. Proof. intros J D x L isL. unfold creates_limit. cbn. transparent assert (FC : (cone (mapdiagram π D) (F x))). { use make_cone. - intro j. eapply compose. apply ((#F)%cat (coneOut L j )). cbn. exact (pr2 (dob D j)). - abstract ( red; intros; cbn; assert (XR := pr2 (dmor D e)); cbn in XR; etrans; [eapply pathsinv0; apply assoc |]; etrans; [apply maponpaths, (!XR) |]; etrans; [apply assoc |]; apply maponpaths_2; rewrite <- functor_comp; apply maponpaths; apply (coneOutCommutes L) ). } transparent assert (LL : (LimCone (mapdiagram π D))). { use make_LimCone. apply x. apply L. apply isL. } use tpair. - use tpair. + use tpair. * use (limArrow LL). apply FC. * abstract ( use tpair ; [ intro j; cbn; set (XR := limArrowCommutes LL _ FC); cbn in XR; apply pathsinv0; apply XR | cbn; intros i j e; apply subtypePath; [ intro; apply homset_property |]; cbn; apply (coneOutCommutes L) ]). + abstract ( intro t; cbn; use total2_paths_f; [ cbn; apply (limArrowUnique LL); induction t as [t [H1 H2]]; cbn in *; intro j; apply pathsinv0, H1 |]; apply proofirrelevance; apply isofhleveltotal2; [ apply impred_isaprop; intro; apply homset_property |]; intros; do 3 (apply impred_isaprop; intro); apply (homset_property (total_category _ )) ). - cbn. intros x' CC. set (πCC := mapcone π D CC). use unique_exists. + use tpair. * cbn. use (limArrow LL _ πCC). * set (XR := limArrowCommutes LL). cbn in XR. set (H1:= coneOutCommutes CC). simpl in H1. destruct x' as [c a]. cbn. unfold disp_cat_functor_alg in a. cbn in a. cbn in πCC. transparent assert (X : (cone (mapdiagram π D) (F c))). { use make_cone. - intro j. apply (λ f, a · f). cbn. apply (coneOut CC j). - abstract ( intros u v e; cbn; rewrite <- assoc; apply maponpaths; apply (maponpaths pr1 (coneOutCommutes CC _ _ _ )) ). } { unfold functor_alg_mor. intermediate_path (limArrow LL _ X). - apply (limArrowUnique LL). intro j. rewrite <- assoc. rewrite (limArrowCommutes LL). cbn. rewrite assoc. rewrite <- functor_comp. etrans. apply maponpaths_2. apply maponpaths. apply (limArrowCommutes LL). cbn. set (H := pr2 (coneOut CC j)). cbn in H. apply H. - apply pathsinv0. use (limArrowUnique LL). intro j. rewrite <- assoc. rewrite (limArrowCommutes LL). cbn. apply idpath. } + simpl. intro j. apply subtypePath. { intro. apply homset_property. } cbn. apply (limArrowCommutes LL). + intros. apply impred_isaprop. intro t. (apply (homset_property (total_category _ ))). + simpl. intros. apply subtypePath. { intro. apply homset_property. } apply (limArrowUnique LL). intro u. specialize (X u). apply (maponpaths pr1 X). Defined. End functor_algebras. Section monad_algebras. Context {C : category} (T : Monad C). Let T' : C ⟶ C := T. Let FAlg : category := total_functor_alg T'. Definition isMonadAlg (Xa : FAlg) : UU := η T (pr1 Xa) · pr2 Xa = identity _ × (#T')%cat (pr2 Xa) · pr2 Xa = μ T _ · pr2 Xa. Definition disp_cat_monad_alg_over_functor_alg : disp_cat FAlg := disp_full_sub _ isMonadAlg. Definition disp_cat_monad_alg : disp_cat C := sigma_disp_cat disp_cat_monad_alg_over_functor_alg. End monad_algebras. (** * Any category is a displayed category over unit *) Require Import UniMath.CategoryTheory.categories.StandardCategories. Section over_terminal_category. Variable C : category. Definition disp_over_unit_data : disp_cat_data unit_category. Proof. use tpair. - use tpair. + intro. apply (ob C). + simpl. intros x y c c' e. apply (C ⟦c, c'⟧). - use tpair. + simpl. intros. apply identity. + intros ? ? ? ? ? a b c f g. apply (compose (C:=C) f g ). Defined. Definition disp_over_unit_axioms : disp_cat_axioms _ disp_over_unit_data. Proof. repeat split; cbn; intros. - apply id_left. - etrans. apply id_right. apply pathsinv0. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)). - etrans. apply assoc. apply pathsinv0. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)). - apply homset_property. Qed. Definition disp_over_unit : disp_cat _ := _ ,, disp_over_unit_axioms. Lemma is_univalent_disp_disp_over_unit (HC : is_univalent C) : is_univalent_disp disp_over_unit. Proof. intros a b e aa bb. induction e. assert (H : isweq (λ (f : z_iso aa bb), (morphism_from_z_iso _ _ f ,, inv_from_z_iso f ,, z_iso_after_z_iso_inv f ,, z_iso_inv_after_z_iso f) : z_iso_disp (identity_z_iso a) aa bb)). { use isweq_iso. - exact (λ (f : z_iso_disp (identity_z_iso a) aa bb), (make_z_iso (mor_disp_from_z_iso f) (inv_mor_disp_from_z_iso f) (inv_mor_after_z_iso_disp f ,, z_iso_disp_after_inv_mor f))). - intro. apply z_iso_eq. apply idpath. - intro. apply eq_z_iso_disp. apply idpath. } use weqhomot. - exact (weqcomp (make_weq _ (HC _ _)) (make_weq _ H)). - intro ee. induction ee. apply eq_z_iso_disp. apply idpath. Qed. End over_terminal_category. Lemma disp_over_unit_fiber_equals_cat (C : category) (u : unit) : (disp_over_unit C)[{u}] = C. Proof. apply (subtypePath (λ _, isaprop_has_homsets _)). refine (subtypePairEquality' _ (isaprop_is_precategory _ (homset_property C))). induction C as [C Hhomsets]. induction C as [Cdata Hisprecategory]. exact (maponpaths (λ x, (pr1 Cdata) ,, x) (pathsdirprod (idpath _) (idpath _))). Qed. Section cartesian_product_pb. Variable C C' : category. (* TODO: use a better name here (this one is baffling out of context) *) Definition disp_cartesian : disp_cat C := reindex_disp_cat (functor_to_unit C) (disp_over_unit C'). Definition cartesian : category := total_category disp_cartesian. Lemma cartesian_is_binproduct : cartesian = category_binproduct C C'. Proof. apply subtypePairEquality'; [ | apply isaprop_has_homsets]. apply subtypePairEquality'; [ | apply isaprop_is_precategory, has_homsets_precategory_binproduct; apply homset_property]. use total2_paths_f. - apply idpath. - use total2_paths_f; [| rewrite transportf_const]; repeat (apply funextsec; intro); (use total2_paths_f; [apply idpath | ]); exact (transportf_set _ _ _ (isasetaprop (isasetunit _ _)) @ idpath _). Qed. End cartesian_product_pb. Section arrow. Variable C : category. Definition disp_arrow_data : disp_cat_data (cartesian C C). Proof. use tpair. - use tpair. + intro H. exact (pr1 H --> pr2 H). + cbn. intros xy ab f g h. exact (compose f (pr2 h) = compose (pr1 h) g ). - split; intros. + cbn. apply pathsinv0. etrans. apply id_left. cbn in xx. unfold mor_disp. cbn. etrans. eapply pathsinv0. apply id_right. apply maponpaths, pathsinv0. apply (eqtohomot (transportf_const _ _)). + cbn in *. unfold mor_disp. cbn. etrans. apply maponpaths, (eqtohomot (transportf_const _ _)). etrans. apply assoc. etrans. apply maponpaths_2. apply X. etrans. eapply pathsinv0, assoc. etrans. apply maponpaths. apply X0. apply assoc. Defined. Definition disp_arrow_axioms : disp_cat_axioms _ disp_arrow_data. Proof. repeat split; intros; try apply homset_property. apply isasetaprop. apply homset_property. Qed. Definition disp_arrow : disp_cat (cartesian C C) := _ ,, disp_arrow_axioms. Definition arrow : category := total_category disp_arrow. Definition disp_domain : disp_cat C := sigma_disp_cat disp_arrow. Definition total_domain := total_category disp_domain. End arrow. Section cartesian_product. Variables C C' : category. Definition disp_cartesian_ob_mor : disp_cat_ob_mor C. Proof. use tpair. - exact (λ c, C'). - cbn. intros x y x' y' f. exact (C'⟦x', y'⟧). Defined. Definition disp_cartesian_data : disp_cat_data C. Proof. exists disp_cartesian_ob_mor. use tpair; cbn. - intros; apply identity. - intros ? ? ? ? ? ? ? ? f g. apply (f · g). Defined. Definition disp_cartesian_axioms : disp_cat_axioms _ disp_cartesian_data. Proof. repeat split; intros; cbn. - etrans. apply id_left. apply pathsinv0. etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)). apply idpath. - etrans. apply id_right. apply pathsinv0. etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)). apply idpath. - etrans. apply assoc. apply pathsinv0. etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)). apply idpath. - apply homset_property. Qed. Definition disp_cartesian' : disp_cat C := _ ,, disp_cartesian_axioms. End cartesian_product. (* *) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/000077500000000000000000000000001451125700300241335ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/AlgebraStructures.v000066400000000000000000000610361451125700300277710ustar00rootroot00000000000000(***************************************************************** Algebra structures In this file, we construct the Eilenberg-Moore category of monads over set as a category of structured sets. Note that we can instantiate this with, for example, the free abelian group monad, and that way we get the category of abelian groups. Contents 1. Algebra structures 2. The cartesian structure of algebras 3. Equalizers of algebras 4. Type indexed products of algebras 5. The free algebra adjunction 6. Every algebra is a coequalizer of a free algebra *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Section MonadToStruct. Context (M : Monad SET). (** 1. Algebra structures *) Definition monad_algebra_laws {X : SET} (f : M X --> X) : UU := (η M X · f = identity X) × (μ M X · f = #M f · f). Definition monad_algebra (X : SET) : UU := ∑ (f : M X --> X), monad_algebra_laws f. Definition make_monad_algebra {X : SET} (f : M X --> X) (p : monad_algebra_laws f) : monad_algebra X := f ,, p. Coercion monad_algebra_struct_to_mor {X : hSet} (f : monad_algebra X) : M X --> X := pr1 f. Proposition monad_algebra_unit {X : hSet} (f : monad_algebra X) : η M X · f = identity _. Proof. exact (pr12 f). Qed. Proposition monad_algebra_mu {X : hSet} (f : monad_algebra X) : μ M X · f = #M f · f. Proof. exact (pr22 f). Qed. Definition monad_to_hset_struct_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact monad_algebra. - exact (λ X Y f g h, f · h = #M h · g). Defined. Proposition monad_to_hset_struct_laws : hset_struct_laws monad_to_hset_struct_data. Proof. repeat split. - intro X. use isaset_total2. + apply homset_property. + intro f. apply isasetaprop. apply isapropdirprod ; apply homset_property. - intros X Y f g h. apply homset_property. - intros X f ; cbn. rewrite (functor_id M). apply idpath. - intros X Y Z fX fY fZ h₁ h₂ Mh₁ Mh₂ ; cbn -[Monad] in *. use funextsec. intro x. rewrite (eqtohomot Mh₁). rewrite (eqtohomot Mh₂). rewrite (eqtohomot (functor_comp M h₁ h₂)). apply idpath. - intros X fX fX' p q. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } cbn -[Monad] in *. use funextsec. intro x. refine (eqtohomot p x @ _). apply maponpaths. exact (eqtohomot (functor_id M X) x). Qed. Definition monad_to_hset_struct : hset_struct := monad_to_hset_struct_data ,, monad_to_hset_struct_laws. Definition category_of_monad_algebra : category := category_of_hset_struct monad_to_hset_struct. (** 2. The cartesian structure of algebras *) Proposition unit_monad_algebra_laws : @monad_algebra_laws unitHSET (λ _, tt). Proof. split. - cbn. use funextsec. intro x. apply isapropunit. - apply idpath. Qed. Definition unit_monad_algebra : monad_algebra unitHSET. Proof. use make_monad_algebra. - exact (λ _, tt). - exact unit_monad_algebra_laws. Defined. Section ProdAlgebra. Context {X Y : SET} (f : monad_algebra X) (g : monad_algebra Y). Let XY : SET := (X × Y)%set. Let p₁ : XY --> X := dirprod_pr1. Let p₂ : XY --> Y := dirprod_pr2. Definition prod_monad_algebra_map : M XY --> XY := BinProductArrow _ (BinProductsHSET X Y) (#M p₁ · f) (#M p₂ · g). Proposition prod_monad_algebra_laws : monad_algebra_laws prod_monad_algebra_map. Proof. split. - use (BinProductArrowsEq _ _ _ (BinProductsHSET X Y)). + rewrite !assoc'. etrans. { apply maponpaths. apply (BinProductPr1Commutes _ _ _ (BinProductsHSET X Y)). } rewrite !assoc. rewrite id_left. rewrite <- (nat_trans_ax (η M) _ _ p₁). rewrite !assoc'. rewrite (monad_algebra_unit f). apply idpath. + rewrite !assoc'. etrans. { apply maponpaths. apply (BinProductPr2Commutes _ _ _ (BinProductsHSET X Y)). } rewrite !assoc. rewrite id_left. rewrite <- (nat_trans_ax (η M) _ _ p₂). rewrite !assoc'. rewrite (monad_algebra_unit g). apply idpath. - use (BinProductArrowsEq _ _ _ (BinProductsHSET X Y)). + rewrite !assoc'. etrans. { apply maponpaths. apply (BinProductPr1Commutes _ _ _ (BinProductsHSET X Y)). } refine (!_). etrans. { apply maponpaths. apply (BinProductPr1Commutes _ _ _ (BinProductsHSET X Y)). } rewrite !assoc. rewrite <- functor_comp. etrans. { apply maponpaths_2. apply maponpaths. apply (BinProductPr1Commutes _ _ _ (BinProductsHSET X Y)). } rewrite <- (nat_trans_ax (μ M) _ _ p₁). rewrite functor_comp. rewrite !assoc'. rewrite (monad_algebra_mu f). apply idpath. + rewrite !assoc'. etrans. { apply maponpaths. apply (BinProductPr2Commutes _ _ _ (BinProductsHSET X Y)). } refine (!_). etrans. { apply maponpaths. apply (BinProductPr2Commutes _ _ _ (BinProductsHSET X Y)). } rewrite !assoc. rewrite <- functor_comp. etrans. { apply maponpaths_2. apply maponpaths. apply (BinProductPr2Commutes _ _ _ (BinProductsHSET X Y)). } rewrite <- (nat_trans_ax (μ M) _ _ p₂). rewrite functor_comp. rewrite !assoc'. rewrite (monad_algebra_mu g). apply idpath. Qed. Definition prod_monad_algebra : monad_algebra XY. Proof. use make_monad_algebra. - exact prod_monad_algebra_map. - exact prod_monad_algebra_laws. Defined. End ProdAlgebra. Definition monad_to_hset_cartesian_struct_data : hset_cartesian_struct_data := monad_to_hset_struct ,, unit_monad_algebra ,, λ X Y f g, prod_monad_algebra f g. Proposition monad_to_hset_cartesian_struct_laws : hset_cartesian_struct_laws monad_to_hset_cartesian_struct_data. Proof. split4. - intros X f ; cbn. apply idpath. - intros X Y f g ; cbn. apply idpath. - intros X Y f g ; cbn. apply idpath. - intros W X Y fW fX fY g₁ g₂ Mg₁ Mg₂ ; cbn -[Monad] in *. use funextsec. intro x. use pathsdirprod ; cbn. + refine (eqtohomot Mg₁ _ @ _). apply maponpaths. refine (!_). etrans. { refine (!_). apply (eqtohomot (functor_comp M _ _)). } apply idpath. + refine (eqtohomot Mg₂ _ @ _). apply maponpaths. refine (!_). etrans. { refine (!_). apply (eqtohomot (functor_comp M _ _)). } apply idpath. Qed. Definition monad_to_hset_cartesian_struct : hset_cartesian_struct := monad_to_hset_cartesian_struct_data ,, monad_to_hset_cartesian_struct_laws. (** 3. Equalizers of algebras *) Section EqualizerAlgebra. Context {X Y : SET} {f g : X --> Y} (hX : monad_algebra X) (hY : monad_algebra Y) (Mf : hX · f = #M f · hY) (Mg : hX · g = #M g · hY). Let E : SET := (∑ x, hProp_to_hSet (eqset (f x) (g x)))%set. Let π : E --> X := λ z, pr1 z. Definition equalizer_algebra_map : M E --> E. Proof. use (EqualizerIn (Equalizers_in_HSET X Y f g)). - exact (#M π · hX). - abstract (rewrite !assoc' ; rewrite Mf, Mg ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- !functor_comp ; apply maponpaths ; apply (EqualizerEqAr (Equalizers_in_HSET X Y f g))). Defined. Proposition equalizer_algebra_laws : monad_algebra_laws equalizer_algebra_map. Proof. split. - use (EqualizerInsEq (Equalizers_in_HSET X Y f g)). rewrite !assoc'. etrans. { apply maponpaths. apply (EqualizerCommutes (Equalizers_in_HSET X Y f g)). } rewrite !id_left. rewrite !assoc. rewrite <- (nat_trans_ax (η M) _ _ π). rewrite !assoc'. rewrite monad_algebra_unit. rewrite id_right. apply idpath. - use (EqualizerInsEq (Equalizers_in_HSET X Y f g)). rewrite !assoc'. etrans. { apply maponpaths. apply (EqualizerCommutes (Equalizers_in_HSET X Y f g)). } refine (!_). etrans. { apply maponpaths. apply (EqualizerCommutes (Equalizers_in_HSET X Y f g)). } rewrite !assoc. rewrite <- functor_comp. etrans. { apply maponpaths_2. apply maponpaths. apply (EqualizerCommutes (Equalizers_in_HSET X Y f g)). } rewrite <- (nat_trans_ax (μ M) _ _ π). rewrite functor_comp. rewrite !assoc'. rewrite (monad_algebra_mu hX). apply idpath. Qed. Definition equalizer_algebra : monad_algebra E. Proof. use make_monad_algebra. - exact equalizer_algebra_map. - exact equalizer_algebra_laws. Defined. End EqualizerAlgebra. Definition monad_to_hset_equalizer_struct_data : hset_equalizer_struct_data monad_to_hset_struct := λ X Y f g hX hY Mf Mg, equalizer_algebra hX hY Mf Mg. Proposition monad_to_hset_equalizer_struct_laws : hset_equalizer_struct_laws monad_to_hset_equalizer_struct_data. Proof. split. - intros X Y f g hX hY Mf Mg. apply idpath. - intros X Y f g hX hY Mf Mg W hW k Mk q. use funextsec. intro x. use subtypePath. { intro. apply setproperty. } cbn -[Monad] in *. refine (eqtohomot Mk x @ _). apply maponpaths. refine (!_). exact (!(eqtohomot (functor_comp M _ _) _)). Qed. Definition monad_to_hset_equalizer_struct : hset_equalizer_struct monad_to_hset_struct := monad_to_hset_equalizer_struct_data ,, monad_to_hset_equalizer_struct_laws. (** 4. Type indexed products of algebras *) Section TypeProdAlgebra. Context {J : UU} {D : J → hSet} (p : ∏ (i : J), monad_algebra (D i)). Let prod : Product J SET D := ProductsHSET J D. Definition monad_type_prod_map : M prod --> prod := ProductArrow _ _ prod (λ i, #M (ProductPr _ _ _ i) · p i). Proposition monad_type_prod_laws : monad_algebra_laws monad_type_prod_map. Proof. split. - use (ProductArrow_eq _ _ _ prod). intro i. rewrite id_left. rewrite !assoc'. etrans. { apply maponpaths. apply ProductPrCommutes. } rewrite !assoc. rewrite <- (nat_trans_ax (η M)). rewrite !assoc'. rewrite (monad_algebra_unit (p i)). rewrite id_right. apply idpath. - use (ProductArrow_eq _ _ _ prod). intro i. rewrite !assoc'. etrans. { apply maponpaths. apply ProductPrCommutes. } refine (!_). etrans. { apply maponpaths. apply ProductPrCommutes. } rewrite !assoc. rewrite <- functor_comp. etrans. { apply maponpaths_2. apply maponpaths. apply ProductPrCommutes. } rewrite <- (nat_trans_ax (μ M)). rewrite functor_comp. rewrite !assoc'. rewrite (monad_algebra_mu (p i)). apply idpath. Qed. End TypeProdAlgebra. Definition monad_to_hset_struct_type_prod_data (J : UU) : hset_struct_type_prod_data monad_to_hset_struct J. Proof. intros D p. use make_monad_algebra. - exact (monad_type_prod_map p). - exact (monad_type_prod_laws p). Defined. Proposition monad_to_hset_struct_type_prod_laws (J : UU) : hset_struct_type_prod_laws (monad_to_hset_struct_type_prod_data J). Proof. split. - intros D PD i. apply idpath. - intros D PD W hW ps Mps. cbn -[Monad] in *. use funextsec ; intro x. use funextsec ; intro i. refine (eqtohomot (Mps i) x @ _). apply maponpaths. refine (!_). exact (!(eqtohomot (functor_comp M _ _) _)). Qed. Definition monad_to_hset_struct_type_prod (J : UU) : hset_struct_type_prod monad_to_hset_struct J := monad_to_hset_struct_type_prod_data J ,, monad_to_hset_struct_type_prod_laws J. (** 5. The free algebra adjunction *) Proposition monad_free_alg_laws (X : hSet) : monad_algebra_laws (μ M X). Proof. split. - apply Monad_law1. - exact (!(@Monad_law3 _ M X)). Qed. Definition monad_free_alg_struct (X : hSet) : monad_algebra (M X). Proof. use make_monad_algebra. - exact (μ M X). - exact (monad_free_alg_laws X). Defined. Definition monad_free_alg (X : hSet) : category_of_monad_algebra := M X ,, monad_free_alg_struct X. Section FreeAlgAdjunction. Context {X : hSet} {Y : hSet} (hY : monad_algebra Y) (f : X → Y). Let YY : category_of_monad_algebra := Y ,, hY. Proposition monad_to_hset_struct_adj_lift_unique : isaprop (∑ f' : monad_free_alg X --> YY, η M X · # (underlying_of_hset_struct monad_to_hset_struct) f' = f). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use eq_mor_hset_struct. cbn ; intro x. pose (eqtohomot (@Monad_law2 _ M X) x) as p. cbn in p. rewrite <- p ; clear p. pose (eqtohomot (pr21 φ₁) (# M (η M X) x)) as p. cbn in p. rewrite p ; clear p. pose (eqtohomot (pr21 φ₂) (# M (η M X) x)) as p. cbn in p. rewrite p ; clear p. apply maponpaths. refine (!(eqtohomot (functor_comp M (η M X) (pr11 φ₁)) x) @ _). refine (_ @ eqtohomot (functor_comp M (η M X) (pr11 φ₂)) x). apply maponpaths_2. exact (pr2 φ₁ @ !(pr2 φ₂)). Qed. Definition monad_to_hset_struct_adj_lift : monad_free_alg X --> YY. Proof. refine (#M f · hY ,, _). cbn. use funextsec. intro x. etrans. { apply maponpaths. exact (!(eqtohomot (nat_trans_ax (μ M) _ _ f) x)). } cbn. refine (eqtohomot (monad_algebra_mu hY) (# M (# M f) x) @ _). cbn. apply maponpaths. exact (!(eqtohomot (functor_comp M _ _) _)). Defined. Proposition monad_to_hset_struct_adj_lift_eq : η M X · #M f · hY = f. Proof. rewrite <- (nat_trans_ax (η M) _ _ f). rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. exact (monad_algebra_unit hY). Qed. End FreeAlgAdjunction. Definition monad_underlying_is_right_adjoint : is_right_adjoint (underlying_of_hset_struct monad_to_hset_struct). Proof. use right_adjoint_left_from_partial. - exact (λ X, monad_free_alg X). - exact (λ X, η M X). - refine (λ X Y f, _). use iscontraprop1. + exact (monad_to_hset_struct_adj_lift_unique (pr2 Y) f). + simple refine (_ ,, _). * exact (monad_to_hset_struct_adj_lift (pr2 Y) f). * exact (monad_to_hset_struct_adj_lift_eq (pr2 Y) f). Defined. Definition monad_free_alg_functor : SET ⟶ category_of_monad_algebra := left_adjoint monad_underlying_is_right_adjoint. Definition monad_free_alg_unit : functor_identity _ ⟹ monad_free_alg_functor ∙ underlying_of_hset_struct monad_to_hset_struct := unit_from_right_adjoint monad_underlying_is_right_adjoint. Definition monad_free_alg_counit : underlying_of_hset_struct monad_to_hset_struct ∙ monad_free_alg_functor ⟹ functor_identity _ := counit_from_right_adjoint monad_underlying_is_right_adjoint. Definition free_alg_coproduct (X Y : hSet) : BinCoproduct (monad_free_alg X) (monad_free_alg Y) := (monad_free_alg (setcoprod X Y) ,, _ ,, _) ,, left_adjoint_preserves_bincoproduct (left_adjoint monad_underlying_is_right_adjoint) (is_left_adjoint_left_adjoint _) _ _ _ _ _ (pr2 (BinCoproductsHSET X Y)). Proposition mor_from_free_alg_eq {X : hSet} {Y : category_of_monad_algebra} {f g : monad_free_alg_functor X --> Y} (p : η M X · pr1 f = η M X · pr1 g) : f = g. Proof. refine (!(id_left _) @ _ @ id_left _). etrans. { apply maponpaths_2. refine (!_). exact (triangle_id_left_ad (pr2 monad_underlying_is_right_adjoint) X). } refine (!_). etrans. { apply maponpaths_2. refine (!_). exact (triangle_id_left_ad (pr2 monad_underlying_is_right_adjoint) X). } refine (!_). rewrite !assoc'. use subtypePath. { intro ; apply homset_property. } enough (# M (η M X · η M (M X)) · μ M (M X) · (# M (identity _) · μ M X · pr1 f) = # M (η M X · η M (M X)) · μ M (M X) · (# M (identity _) · μ M X · pr1 g)) as q. { exact q. } rewrite !functor_id. rewrite id_left. etrans. { apply maponpaths. exact (pr2 f). } refine (!_). etrans. { apply maponpaths. exact (pr2 g). } refine (!_). rewrite !assoc. apply maponpaths_2. rewrite !functor_comp. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. exact (@Monad_law2 _ M (M X)). } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. exact (@Monad_law2 _ M (M X)). } refine (!_). rewrite !id_left. rewrite <- !functor_comp. apply maponpaths. exact p. Qed. (** 6. Every algebra is a coequalizer of a free algebra *) Section AlgebraAsCoequalizer. Context {X : hSet} (hX : monad_algebra X). Let F : SET ⟶ category_of_monad_algebra := monad_free_alg_functor. Let AX : category_of_monad_algebra := X ,, hX. Let FX : category_of_monad_algebra := monad_free_alg X. Let FUFX : category_of_monad_algebra := monad_free_alg (pr1 FX). Definition algebra_as_coequalizer_left_map : FUFX --> FX := monad_free_alg_counit FX. Let ℓ : FUFX --> FX := algebra_as_coequalizer_left_map. Definition algebra_as_coequalizer_right_map : FUFX --> FX := #F hX. Let ρ : FUFX --> FX := algebra_as_coequalizer_right_map. Definition algebra_as_coequalizer_arr : FX --> AX. Proof. simple refine (_ ,, _). - exact hX. - exact (monad_algebra_mu hX). Defined. Proposition algebra_as_coequalizer_arr_eq : ℓ · algebra_as_coequalizer_arr = ρ · algebra_as_coequalizer_arr. Proof. unfold ℓ, ρ. unfold algebra_as_coequalizer_left_map. unfold algebra_as_coequalizer_right_map. use subtypePath. { intro. apply homset_property. } simpl. rewrite (functor_id M). etrans. { apply maponpaths_2. exact (id_left (μ M X)). } refine (monad_algebra_mu hX @ _). apply maponpaths_2. rewrite (functor_comp M). refine (_ @ assoc _ _ _). refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply Monad_law2. Qed. Section UMP. Context {Y : category_of_monad_algebra} (g : FX --> Y) (p : ℓ · g = ρ · g). Proposition algebra_as_coequalizer_ump_unique : isaprop (∑ φ, algebra_as_coequalizer_arr · φ = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use subtypePath. { intro. apply homset_property. } refine (!(id_left _) @ _ @ id_left _). etrans. { apply maponpaths_2. exact (!(monad_algebra_unit hX)). } refine (!_). etrans. { apply maponpaths_2. exact (!(monad_algebra_unit hX)). } rewrite !assoc'. apply maponpaths. refine (!_). exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))). Qed. Lemma algebra_as_coequalizer_ump_eq_lem_1 : # M hX · pr1 g = μ M X · pr1 g. Proof. refine (_ @ maponpaths pr1 (!p) @ _). - refine (maponpaths (λ z, z · _) _). simpl. rewrite (functor_comp M). refine (_ @ assoc (#M hX) _ _). refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply Monad_law2. - refine (maponpaths (λ z, z · _) _). refine (_ @ id_left _). refine (maponpaths (λ z, z · _) _). apply functor_id. Qed. Lemma algebra_as_coequalizer_ump_eq_lem_2 : hX · η M X · pr1 g = pr1 g. Proof. etrans. { apply maponpaths_2. exact (nat_trans_ax (η M) _ _ hX). } rewrite !assoc'. rewrite algebra_as_coequalizer_ump_eq_lem_1. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. apply Monad_law1. Qed. Lemma algebra_as_coequalizer_ump_eq : hX · (η M X · pr1 g) = # M (η M X · pr1 g) · pr12 Y. Proof. rewrite functor_comp. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. exact (!(pr2 g)). } rewrite !assoc. rewrite (@Monad_law2 _ M). rewrite id_left. refine (!_). apply algebra_as_coequalizer_ump_eq_lem_2. Qed. Definition algebra_as_coequalizer_ump : AX --> Y. Proof. simple refine (_ ,, _). - exact (η M X · pr1 g). - exact algebra_as_coequalizer_ump_eq. Defined. Proposition algebra_as_coequalizer_ump_comm : algebra_as_coequalizer_arr · algebra_as_coequalizer_ump = g. Proof. use subtypePath. { intro. apply homset_property. } simpl. apply algebra_as_coequalizer_ump_eq_lem_2. Qed. End UMP. Definition algebra_as_coequalizer : Coequalizer ℓ ρ. Proof. use make_Coequalizer. - exact AX. - exact algebra_as_coequalizer_arr. - exact algebra_as_coequalizer_arr_eq. - intros Y g p. use iscontraprop1. + exact (algebra_as_coequalizer_ump_unique g). + simple refine (_ ,, _). * exact (algebra_as_coequalizer_ump g p). * exact (algebra_as_coequalizer_ump_comm g p). Defined. End AlgebraAsCoequalizer. End MonadToStruct. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/CategoryOfPosets.v000066400000000000000000000157311451125700300275710ustar00rootroot00000000000000(***************************************************************** The category of posets We construct the category of posets as a displayed category over the category of sets. In addition, we equip this category with a terminal object and with binary products. We also construct equalizers and exponentials for this category. Contents 1. The category of posets 2. Terminal object 3. Binary products and type indexed products 4. Equalizers 5. Exponentials *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.categories.HSET.All. Local Open Scope cat. (** 1. The category of posets *) Definition poset_disp_cat : disp_cat SET. Proof. use disp_struct. - exact (λ X, PartialOrder X). - exact (λ X₁ X₂ R₁ R₂ f, is_monotone R₁ R₂ f). - exact (λ X₁ X₂ R₁ R₂ f, isaprop_is_monotone R₁ R₂ f). - exact (λ X R, idfun_is_monotone R). - exact (λ X₁ X₂ X₃ R₁ R₂ R₃ f g Hf Hg, comp_is_monotone Hf Hg). Defined. Lemma poset_disp_cat_locally_prop : locally_propositional poset_disp_cat. Proof. intro; intros; apply isaprop_is_monotone. Qed. Proposition is_univalent_poset_disp_cat : is_univalent_disp poset_disp_cat. Proof. use is_univalent_disp_from_SIP_data. - exact (λ X, isaset_PartialOrder X). - cbn. refine (λ X R₁ R₂ p q, _). use subtypePath. { intro. apply isaprop_isPartialOrder. } use funextsec ; intro. use funextsec ; intro. use weqtopathshProp. use weqimplimpl. + apply p. + apply q. + apply (pr1 R₁). + apply (pr1 R₂). Qed. Definition category_of_posets : category := total_category poset_disp_cat. Definition is_univalent_category_of_posets : is_univalent category_of_posets. Proof. use is_univalent_total_category. - exact is_univalent_HSET. - exact is_univalent_poset_disp_cat. Defined. (** 2. Terminal object *) Definition dispTerminal_poset_disp_cat : dispTerminal poset_disp_cat TerminalHSET. Proof. use make_dispTerminal_locally_prop. - exact poset_disp_cat_locally_prop. - exact unit_PartialOrder. - intros X RX. exact (λ x y p, tt). Defined. Definition Terminal_category_of_posets : Terminal category_of_posets. Proof. use total_category_Terminal. - exact TerminalHSET. - exact dispTerminal_poset_disp_cat. Defined. (** 3. Binary products *) Definition dispBinProducts_poset_disp_cat : dispBinProducts poset_disp_cat BinProductsHSET. Proof. intros X₁ X₂ R₁ R₂. use make_dispBinProduct_locally_prop. - exact poset_disp_cat_locally_prop. - exists (prod_PartialOrder R₁ R₂). split ; cbn. + exact (dirprod_pr1_is_monotone R₁ R₂). + exact (dirprod_pr2_is_monotone R₁ R₂). - cbn. intros W f g RW Hf Hg. exact (prodtofun_is_monotone Hf Hg). Defined. Definition BinProducts_category_of_posets : BinProducts category_of_posets. Proof. use total_category_Binproducts. - exact BinProductsHSET. - exact dispBinProducts_poset_disp_cat. Defined. Definition Products_category_of_posets (J : UU) : Products J category_of_posets. Proof. intro D. use make_Product. - exact (_ ,, depfunction_poset _ (λ j, pr2 (D j))). - exact (λ j, _ ,, is_monotone_depfunction_poset_pr _ _ j). - intros R f. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; use eq_monotone_function ; intro x ; use funextsec ; intro j ; exact (eqtohomot (maponpaths pr1 (pr2 φ₁ j @ !(pr2 φ₂ j))) x)). + simple refine (_ ,, _). * exact (_ ,, is_monotone_depfunction_poset_pair (λ j, pr1 (f j)) (λ j, pr2 (f j))). * abstract (intro j ; use eq_monotone_function ; cbn ; intro x ; apply idpath). Defined. (** 4. Equalizers *) Definition Equalizers_category_of_posets : Equalizers category_of_posets. Proof. intros X Y f g. simple refine ((_ ,, _) ,, (_ ,, _)). - exact (_ ,, Equalizer_order (pr2 X) (pr1 Y) (pr1 f) (pr1 g)). - exact (_ ,, Equalizer_pr1_monotone (pr2 X) (pr1 Y) (pr1 f) (pr1 g)). - abstract (use eq_monotone_function ; intro w ; cbn in w ; cbn ; exact (pr2 w)). - simpl. intros W h p. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use eq_monotone_function ; intro w ; use subtypePath ; [ intro ; apply (pr1 Y) | ] ; refine (eqtohomot (maponpaths pr1 (pr2 φ₁)) w @ !_) ; exact (eqtohomot (maponpaths pr1 (pr2 φ₂)) w)). + simple refine (_ ,, _). * exact (_ ,, Equalizer_map_monotone _ _ _ _ _ (pr2 h) (eqtohomot (maponpaths pr1 p))). * abstract (use eq_monotone_function ; intro w ; apply idpath). Defined. (** 5. Exponentials *) Definition Exponentials_category_of_posets : Exponentials BinProducts_category_of_posets. Proof. intros X. use left_adjoint_from_partial. - exact (λ Y, _ ,, monotone_function_PartialOrder (pr2 X) (pr2 Y)). - exact (λ Y, eval_monotone_function (pr2 X) (pr2 Y)). - refine (λ Y Z f, _). use iscontraprop1. + abstract (use invproofirrelevance ; intros g₁ g₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use eq_monotone_function ; intro z ; use eq_monotone_function ; intro x ; refine (!(eqtohomot (maponpaths pr1 (pr2 g₁)) (x ,, z)) @ _) ; exact (eqtohomot (maponpaths pr1 (pr2 g₂)) (x ,, z))). + simple refine (_ ,, _). * exact (lam_monotone_function (pr2 X) (pr2 Y) f). * abstract (use subtypePath ; [ intro ; apply isaprop_is_monotone | ] ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/DCPOStructures.v000066400000000000000000000206311451125700300271550ustar00rootroot00000000000000(***************************************************************** DCPOs In this file, we define the category of DCPOs and Scott continuous functions as a category of structured sets. We show that this category has the following structure: - A terminal object ([Terminal_DCPO]) - Binary products ([BinProducts_DCPO]) - Products indexed by types ([Products_DCPO]) - Equalizers ([Equalizers_DCPO]) - Exponentials ([Exponentials_DCPO]) - Binary coproducts ([BinCoproducts_DCPO]) - Coproducts indexed by sets ([Coproducts_DCPO]) We also show that the underlying functor going from DCPOs to sets has a left adjoint ([is_right_adjoint_DCPO_underlying]). Contents 1. DCPO structures 2. Cartesian structure of DCPOs 3. Function spaces of DCPOs 4. Limits of DCPOs 5. Binary coproducts of DCPOs 6. Set-indexed coproducts of DCPOs 7. The adjunction coming from discrete DCPOs *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. (** 1. DCPO structures *) Definition struct_dcpo_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, dcpo_struct X). - exact (λ X Y PX PY f, is_scott_continuous PX PY f). Defined. Definition struct_dcpo_laws : hset_struct_laws struct_dcpo_data. Proof. split5. - intro X. apply isaset_dcpo_struct. - intros X Y px py f. apply isaprop_is_scott_continuous. - intros X PX ; cbn in *. apply id_is_scott_continuous. - intros X Y Z PX PY PZ f g Pf Pg. exact (comp_is_scott_continuous Pf Pg). - intros X PX PX' p q ; cbn in *. exact (eq_dcpo_struct _ _ p q). Defined. Definition struct_dcpo : hset_struct := struct_dcpo_data ,, struct_dcpo_laws. Definition DCPO : univalent_category := univalent_category_of_hset_struct struct_dcpo. Definition DCPO_underlying : DCPO ⟶ SET := underlying_of_hset_struct struct_dcpo. (** 2. Cartesian structure of DCPOs *) Definition cartesian_struct_dcpo_data : hset_cartesian_struct_data := struct_dcpo ,, unit_dcpo_struct ,, λ X Y DX DY, prod_dcpo_struct DX DY. Definition cartesian_struct_dcpo_laws : hset_cartesian_struct_laws cartesian_struct_dcpo_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X DX. exact (is_scott_continuous_to_unit DX). - intros X Y DX DY. exact (is_scott_continuous_dirprod_pr1 DX DY). - intros X Y DX DY ; cbn in *. exact (is_scott_continuous_dirprod_pr2 DX DY). - intros W X Y DW DY DZ f g Df Dg ; cbn in *. exact (is_scott_continuous_prodtofun Df Dg). Qed. (** 3. Function spaces of DCPOs *) Definition cartesian_struct_dcpo : hset_cartesian_struct := cartesian_struct_dcpo_data ,, cartesian_struct_dcpo_laws. Definition cartesian_closed_struct_dcpo_data : hset_cartesian_closed_struct_data. Proof. refine (cartesian_struct_dcpo ,, _ ,, _). - abstract (intros X Y DX DY y ; exact (is_scott_continuous_constant DX DY y)). - exact (λ X Y DX DY, dcpo_struct_funspace DX DY). Defined. Proposition cartesian_closed_struct_dcpo_laws : closed_under_fun_laws cartesian_closed_struct_dcpo_data. Proof. split. - intros X Y DX DY ; cbn in *. exact (is_scott_continuous_eval (X ,, DX) (Y ,, DY)). - intros X Y Z DX DY DZ f Df ; cbn in *. apply (@is_scott_continuous_lam (X ,, DX) (Y ,, DY) (Z ,, DZ) (f ,, Df)). Qed. Definition cartesian_closed_struct_dcpo : hset_cartesian_closed_struct := cartesian_closed_struct_dcpo_data ,, cartesian_closed_struct_dcpo_laws. (** 4. Limits of DCPOs *) Definition equalizers_struct_dcpo : hset_equalizer_struct struct_dcpo. Proof. simple refine (_ ,, _). - intros X Y f g DX DY Df Dg. exact (@equalizer_dcpo_struct (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg)). - refine (_ ,, _). + abstract (intros X Y f g DX DY Df Dg ; exact (@is_scott_continuous_equalizer_pr1 (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg))). + abstract (intros X Y f g DX DY Df Dg W DW h Dh q ; exact (@is_scott_continuous_equalizer_map (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg) (W ,, DW) (h ,, Dh) q)). Defined. Definition type_products_struct_dcpo (I : UU) : hset_struct_type_prod struct_dcpo I. Proof. simple refine (_ ,, _). - exact (λ D DD, @depfunction_dcpo_struct I (λ i, D i ,, DD i)). - split ; cbn. + abstract (intros D DD i ; exact (is_scott_continuous_depfunction_pr (λ i, D i ,, DD i) i)). + abstract (intros D DD W DW fs Hfs ; exact (@is_scott_continuous_depfunction_map _ (λ i, D i ,, DD i) (W ,, DW) (λ i, fs i ,, Hfs i))). Defined. Definition Terminal_DCPO : Terminal DCPO := Terminal_category_of_hset_struct cartesian_struct_dcpo. Definition BinProducts_DCPO : BinProducts DCPO := BinProducts_category_of_hset_struct cartesian_struct_dcpo. Definition Products_DCPO (I : UU) : Products I DCPO := Products_category_of_hset_struct_type_prod (type_products_struct_dcpo I). Definition Equalizers_DCPO : Equalizers DCPO := Equalizers_category_of_hset_struct equalizers_struct_dcpo. Definition Exponentials_DCPO : Exponentials BinProducts_DCPO := Exponentials_struct cartesian_closed_struct_dcpo. (** 5. Binary coproducts of DCPOs *) Definition binary_coproducts_struct_dcpo : hset_binary_coprod_struct struct_dcpo. Proof. simple refine (_ ,, _). - exact (λ X Y PX PY, coproduct_dcpo_struct (X ,, PX) (Y ,, PY)). - simple refine (_ ,, _ ,, _) ; cbn. + abstract (intros X Y PX PY ; cbn ; exact (is_scott_continuous_inl (X ,, PX) (Y ,, PY))). + abstract (intros X Y PX PY ; cbn ; exact (is_scott_continuous_inr (X ,, PX) (Y ,, PY))). + abstract (intros X Y Z PX PY PZ f g Pf Pg ; exact (@is_scott_continuous_sumofmaps (X ,, PX) (Y ,, PY) (Z ,, PZ) f Pf g Pg)). Defined. Definition BinCoproducts_DCPO : BinCoproducts DCPO := BinCoproducts_category_of_hset_struct binary_coproducts_struct_dcpo. (** 6. Set-indexed coproducts of DCPOs *) Definition set_coproducts_struct_dcpo (I : hSet) : hset_struct_set_coprod struct_dcpo I. Proof. simple refine (_ ,, _). - exact (λ Y PY, coproduct_set_dcpo_struct (λ i, Y i ,, PY i)). - simple refine (_ ,, _) ; cbn. + abstract (intros Y PY ; cbn ; exact (is_scott_continuous_incl (λ i, Y i ,, PY i))). + abstract (refine (λ Y PY W PW f Pf, _) ; exact (@is_scott_continuous_set_coproduct_map I (λ i, Y i ,, PY i) (W ,, PW) f Pf)). Defined. Definition Coproducts_DCPO (I : hSet) : Coproducts I DCPO := Coproducts_category_of_hset_struct_set_coprod (set_coproducts_struct_dcpo I). (** 7. The adjunction coming from discrete DCPOs *) Definition discrete_dcpo_struct : discrete_hset_struct struct_dcpo. Proof. use make_discrete_hset_struct. - exact (λ X, discrete_dcpo_struct X). - exact (λ X Y f, discrete_dcpo_mor f). - exact (λ X PX, discrete_dcpo_counit (X ,, PX)). Defined. Definition is_right_adjoint_DCPO_underlying : is_right_adjoint DCPO_underlying := discrete_hset_struct_to_is_right_adjoint discrete_dcpo_struct. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/Opposite.v000066400000000000000000000122101451125700300261200ustar00rootroot00000000000000(****************************************************************** Opposites of displayed categories If we have a displayed category `D` on a category `C`, then we can define a displayed category on `C^op` ******************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Local Open Scope mor_disp. Section OpDispCat. Context {C : category} (D : disp_cat C). Definition op_disp_cat_ob_mor : disp_cat_ob_mor C^op. Proof. simple refine (_ ,, _). - exact (λ x, D x). - exact (λ x y xx yy f, yy -->[ f ] xx). Defined. Definition op_disp_cat_id_comp : disp_cat_id_comp C^op op_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ x xx, id_disp _). - refine (λ x y z f g xx yy zz ff gg, _) ; cbn in *. exact (gg ;; ff). Defined. Definition op_disp_cat_data : disp_cat_data C^op. Proof. simple refine (_ ,, _). - exact op_disp_cat_ob_mor. - exact op_disp_cat_id_comp. Defined. Definition op_disp_cat_axioms : disp_cat_axioms C^op op_disp_cat_data. Proof. repeat split ; cbn ; intros. - apply id_right_disp. - apply id_left_disp. - rewrite assoc_disp. unfold transportb. rewrite transport_f_f. refine (!_). apply transportf_set. apply C. - apply D. Qed. Definition op_disp_cat : disp_cat C^op. Proof. simple refine (_ ,, _). - exact op_disp_cat_data. - exact op_disp_cat_axioms. Defined. End OpDispCat. Definition to_z_iso_disp_op_disp_cat {C : category} {D : disp_cat C} {x y : C} {f : z_iso y x} {xx : D x} {yy : D y} (ff : yy -->[ f ] xx) (Hff : is_z_iso_disp f ff) : @is_z_iso_disp _ (op_disp_cat D) x y (opp_z_iso f) _ _ ff. Proof. simple refine (_ ,, _ ,, _). - simple refine (transportb (λ z, _ -->[ z ] _) _ (inv_mor_disp_from_z_iso Hff)). apply idpath. - cbn. apply inv_mor_after_z_iso_disp. - cbn. apply z_iso_disp_after_inv_mor. Defined. Definition z_iso_disp_to_op_disp_cat {C : category} {D : disp_cat C} {x : C} {xx yy : D x} (f : z_iso_disp (identity_z_iso x) xx yy) : @z_iso_disp _ (op_disp_cat D) _ _ (@identity_z_iso (op_cat C) x) xx yy. Proof. use make_z_iso_disp. - exact (inv_mor_disp_from_z_iso f). - simple refine (_ ,, _ ,, _). + exact (pr1 f). + abstract (cbn ; refine (z_iso_disp_after_inv_mor f @ _) ; apply maponpaths_2 ; apply homset_property). + abstract (cbn ; refine (inv_mor_after_z_iso_disp f @ _) ; apply maponpaths_2 ; apply homset_property). Defined. Definition z_iso_disp_from_op_disp_cat {C : category} {D : disp_cat C} {x : C} {xx yy : D x} (f : @z_iso_disp _ (op_disp_cat D) _ _ (@identity_z_iso C^op x) xx yy) : z_iso_disp (identity_z_iso x) xx yy. Proof. use make_z_iso_disp. - exact (inv_mor_disp_from_z_iso f). - simple refine (_ ,, _ ,, _). + exact (pr1 f). + abstract (cbn ; refine (z_iso_disp_after_inv_mor f @ _) ; apply maponpaths_2 ; apply homset_property). + abstract (cbn ; refine (inv_mor_after_z_iso_disp f @ _) ; apply maponpaths_2 ; apply homset_property). Defined. Definition z_iso_disp_weq_op_disp_cat {C : category} {D : disp_cat C} {x : C} (xx yy : D x) : @z_iso_disp _ (op_disp_cat D) _ _ (@identity_z_iso C^op x) xx yy ≃ z_iso_disp (identity_z_iso x) xx yy. Proof. use make_weq. - exact z_iso_disp_from_op_disp_cat. - use isweq_iso. + exact z_iso_disp_to_op_disp_cat. + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. Definition is_univalent_op_disp_cat {C : category} {D : disp_cat C} (HD : is_univalent_disp D) : is_univalent_disp (op_disp_cat D). Proof. intros x y p xx yy. induction p. use weqhomot. - exact (z_iso_disp_weq_op_disp_cat xx yy ∘ make_weq _ (HD x x (idpath _) xx yy))%weq. - abstract (intro p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; induction p ; cbn ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PointedDCPOStrict.v000066400000000000000000000155761451125700300276010ustar00rootroot00000000000000(***************************************************************** The category of DCPPOs and strict functions We construct the category of DCPPos and strict Scott continuous functions as a category of structured sets. We show that this category has the following structure - A terminal object ([Terminal_DCPPO_strict]) - Binary products ([BinProducts_DCPPO_strict]) - Products indexed by types ([Products_DCPPO_strict]) - Equalizers ([Equalizers_DCPPO_strict]) - An initial object ([Initial_DCPPO_strict]) Contents 1. Structures of dcppos with strict functions 2. The cartesian structure of dcppos 3. Structure on the category of DCPPOs 4. Dcppos form a pointed structure *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Local Open Scope cat. Local Open Scope dcpo. (** 1. Structures of dcppos with strict functions *) Definition struct_pointed_dcppo_strict_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, dcppo_struct X). - exact (λ X Y DX DY f, is_strict_scott_continuous DX DY f). Defined. Definition struct_dcpoo_strict_laws : hset_struct_laws struct_pointed_dcppo_strict_data. Proof. split5. - intro X. use isaset_total2. + apply isaset_dcpo_struct. + intro PX. use isaset_total2. * apply setproperty. * intro. use impred_isaset. intro. apply isasetaprop. apply propproperty. - intros X Y DX DY f. apply isaprop_is_strict_scott_continuous. - intros X DX. apply id_is_strict_scott_continuous. - intros X Y Z DX DY DZ f g Df Dg. exact (comp_is_strict_scott_continuous Df Dg). - intros X PX PX' p q ; cbn in *. exact (eq_dcppo_strict_struct _ _ p q). Qed. Definition struct_dcppo_strict : hset_struct := struct_pointed_dcppo_strict_data ,, struct_dcpoo_strict_laws. Definition DCPPO_strict : univalent_category := univalent_category_of_hset_struct struct_dcppo_strict. Definition DCPPO_strict_underlying : DCPPO_strict ⟶ SET := underlying_of_hset_struct struct_dcppo_strict. (** 2. The cartesian structure of dcppos *) Definition cartesian_struct_dcppo_strict_data : hset_cartesian_struct_data := struct_dcppo_strict ,, unit_dcppo_struct ,, λ X Y DX DY, prod_dcppo_struct DX DY. Definition cartesian_struct_dcppo_strict_laws : hset_cartesian_struct_laws cartesian_struct_dcppo_strict_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X DX ; cbn in *. apply is_strict_scott_continuous_constant. - intros X Y DX DY. apply is_strict_scott_continuous_dirprod_pr1. - intros X Y DX DY. apply is_strict_scott_continuous_dirprod_pr2. - intros W X Y DW DX DY f g Df Dg. exact (is_strict_scott_continuous_prodtofun Df Dg). Qed. Definition cartesian_struct_dcppo_strict : hset_cartesian_struct := cartesian_struct_dcppo_strict_data ,, cartesian_struct_dcppo_strict_laws. (** 3. Structure on the category of DCPPOs *) Definition equalizers_struct_dcppo_strict : hset_equalizer_struct struct_dcppo_strict. Proof. simple refine (_ ,, _). - intros X Y f g DX DY Df Dg. exact (@equalizer_dcppo_struct (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg)). - split. + abstract (intros X Y f g DX DY Df Dg ; cbn in * ; exact (@is_strict_scott_continuous_equalizer_pr1 (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg))). + abstract (intros X Y f g DX DY Df Dg W DW h Dh q ; exact (@is_strict_scott_continuous_equalizer_map (X ,, DX) (Y ,, DY) (f ,, Df) (g ,, Dg) (W ,, DW) (h ,, Dh) q)). Defined. Definition type_products_struct_dcppo_strict (I : UU) : hset_struct_type_prod struct_dcppo_strict I. Proof. simple refine (_ ,, _). - exact (λ D PD, depfunction_dcppo_struct (λ i, D i ,, PD i)). - split ; cbn. + abstract (intros D PD i ; exact (@is_strict_scott_continuous_depfunction_pr I (λ i, D i ,, PD i) i)). + abstract (intros D PD W DW fs Hfs ; exact (@is_strict_scott_continuous_depfunction_map I (λ i, D i ,, PD i) (W ,, DW) (λ i, fs i ,, Hfs i))). Defined. Definition Terminal_DCPPO_strict : Terminal DCPPO_strict := Terminal_category_of_hset_struct cartesian_struct_dcppo_strict. Definition BinProducts_DCPPO_strict : BinProducts DCPPO_strict := BinProducts_category_of_hset_struct cartesian_struct_dcppo_strict. Definition Equalizers_DCPPO_strict : Equalizers DCPPO_strict := Equalizers_category_of_hset_struct equalizers_struct_dcppo_strict. Definition Products_DCPPO_strict (I : UU) : Products I DCPPO_strict := Products_category_of_hset_struct_type_prod (type_products_struct_dcppo_strict I). Definition Initial_DCPPO_strict : Initial DCPPO_strict. Proof. use make_Initial. - exact unit_dcppo. - intros Y. use iscontraprop1. + abstract (use invproofirrelevance ; intros f₁ f₂ ; use (@eq_strict_scott_continuous_map unit_dcppo Y f₁ f₂) ; intro x ; induction x ; refine (@strict_scott_continuous_map_on_point unit_dcppo _ f₁ @ !_) ; exact (@strict_scott_continuous_map_on_point unit_dcppo _ f₂)). + refine ((λ _, ⊥_{Y}) ,, _). abstract (cbn ; apply is_strict_scott_continuous_constant). Defined. (** 4. Dcppos form a pointed structure *) Definition pointed_struct_dcppo_strict_data : pointed_hset_struct_data struct_dcppo_strict := λ X DX, ⊥_{X ,, DX}. Proposition pointed_struct_dcppo_strict_laws : pointed_hset_struct_laws pointed_struct_dcppo_strict_data. Proof. split. - intros X Y RX RY. apply is_strict_scott_continuous_constant. - intros X Y f PX PY Pf ; cbn in *. apply Pf. Qed. Definition pointed_struct_dcppo_strict : pointed_hset_struct struct_dcppo_strict := pointed_struct_dcppo_strict_data ,, pointed_struct_dcppo_strict_laws. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PointedDCPOStructures.v000066400000000000000000000120311451125700300304730ustar00rootroot00000000000000(***************************************************************** Pointed DCPOs We construct the category of pointed DCPOs and Scott continuous functions (not necessarily strict). Note that since we do not look at strict functions, the resulting category does not have all limits and colimits. However, it has a terminal object, binary products, and it is cartesian closed. In addition, it has products indexed by arbitrary types. Contents 1. Pointed DCPO structures 2. Cartesian structure of pointed DCPOs 3. Structure on the category of DCPPOs *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. Local Open Scope dcpo. (** 1. Pointed DCPO structures *) Definition struct_dcppo_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, dcppo_struct X). - exact (λ X Y PX PY f, is_scott_continuous PX PY f). Defined. Definition struct_dcppo_laws : hset_struct_laws struct_dcppo_data. Proof. split5. - intro X. apply isaset_dcppo_struct. - intros X Y px py f. apply isaprop_is_scott_continuous. - intros X PX ; cbn in *. apply id_is_scott_continuous. - intros X Y Z PX PY PZ f g Pf Pg. exact (comp_is_scott_continuous Pf Pg). - intros X PX PX' p q ; cbn in *. exact (eq_dcppo_struct _ _ p q). Defined. Definition struct_dcppo : hset_struct := struct_dcppo_data ,, struct_dcppo_laws. Definition DCPPO : univalent_category := univalent_category_of_hset_struct struct_dcppo. Definition DCPPO_underlying : DCPPO ⟶ SET := underlying_of_hset_struct struct_dcppo. (** 2. Cartesian structure of pointed DCPOs *) Definition cartesian_struct_dcppo_data : hset_cartesian_struct_data := struct_dcppo ,, unit_dcppo_struct ,, λ X Y DX DY, prod_dcppo_struct DX DY. Definition cartesian_struct_dcppo_laws : hset_cartesian_struct_laws cartesian_struct_dcppo_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X DX ; cbn in *. exact (is_scott_continuous_to_unit DX). - intros X Y DX DY ; cbn in *. exact (is_scott_continuous_dirprod_pr1 DX DY). - intros X Y DX DY ; cbn in *. exact (is_scott_continuous_dirprod_pr2 DX DY). - intros W X Y DW DY DZ f g Df Dg ; cbn in *. exact (is_scott_continuous_prodtofun Df Dg). Qed. Definition cartesian_struct_dcppo : hset_cartesian_struct := cartesian_struct_dcppo_data ,, cartesian_struct_dcppo_laws. Definition cartesian_closed_struct_dcppo_data : hset_cartesian_closed_struct_data. Proof. refine (cartesian_struct_dcppo ,, _ ,, _). - abstract (intros X Y DX DY y ; cbn in * ; exact (is_scott_continuous_constant DX DY y)). - exact (λ X Y DX DY, dcppo_struct_funspace DX DY). Defined. Proposition cartesian_closed_struct_dcppo_laws : closed_under_fun_laws cartesian_closed_struct_dcppo_data. Proof. split. - intros X Y DX DY ; cbn in *. exact (is_scott_continuous_eval (X ,, pr1 DX) (Y ,, pr1 DY)). - intros X Y Z DX DY DZ f Df ; cbn in *. apply (@is_scott_continuous_lam (X ,, pr1 DX) (Y ,, pr1 DY) (Z ,, pr1 DZ) (f ,, Df)). Qed. Definition cartesian_closed_struct_dcppo : hset_cartesian_closed_struct := cartesian_closed_struct_dcppo_data ,, cartesian_closed_struct_dcppo_laws. (** 3. Structure on the category of DCPPOs *) Definition type_products_struct_dcppo (I : UU) : hset_struct_type_prod struct_dcppo I. Proof. simple refine (_ ,, _). - exact (λ D DD, @depfunction_dcppo_struct I (λ i, D i ,, DD i)). - split ; cbn. + abstract (intros D DD i ; exact (is_scott_continuous_depfunction_pr (λ i, D i ,, pr1 (DD i)) i)). + abstract (intros D DD W DW fs Hfs ; exact (@is_scott_continuous_depfunction_map _ (λ i, D i ,, pr1 (DD i)) (W ,, pr1 DW) (λ i, fs i ,, Hfs i))). Defined. Definition Terminal_DCPPO : Terminal DCPPO := Terminal_category_of_hset_struct cartesian_struct_dcppo. Definition BinProducts_DCPPO : BinProducts DCPPO := BinProducts_category_of_hset_struct cartesian_struct_dcppo. Definition Exponentials_DCPPO : Exponentials BinProducts_DCPPO := Exponentials_struct cartesian_closed_struct_dcppo. Definition Products_DCPPO (I : UU) : Products I DCPPO := Products_category_of_hset_struct_type_prod (type_products_struct_dcppo I). UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PointedPosetStrict.v000066400000000000000000000347621451125700300301440ustar00rootroot00000000000000(***************************************************************** The category of pointed posets and strict functions We construct the category of pointed posets and strict monotone functions as a category of structured sets. In addition, we show that this category is monoidal closed via the smash product. Contents 1. Structures of pointed posets 2. The cartesian structure of pointed posets 3. Limits of pointed posets 4. Pointed posets form a pointed structure 5. The smash product of pointed posets *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Local Open Scope cat. (** 1. Structures of pointed posets *) Definition struct_pointed_poset_strict_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, pointed_PartialOrder X). - exact (λ X Y PX PY f, is_strict_and_monotone PX PY f). Defined. Definition struct_pointed_poset_strict_laws : hset_struct_laws struct_pointed_poset_strict_data. Proof. split5. - intro X. use isaset_total2. + apply isaset_PartialOrder. + intro PX. use isaset_total2. * apply setproperty. * intro. use impred_isaset. intro. apply isasetaprop. apply propproperty. - intros X Y PX PY f. apply isapropdirprod. + apply isaprop_is_monotone. + apply setproperty. - intros X PX. apply idfun_is_strict_and_monotone. - intros X Y Z PX PY PZ f g Pf Pg. exact (comp_is_strict_and_monotone Pf Pg). - intros X PX PX' p q ; cbn in *. exact (eq_pointed_PartialOrder_strict_and_monotone p q). Qed. Definition struct_pointed_poset_strict : hset_struct := struct_pointed_poset_strict_data ,, struct_pointed_poset_strict_laws. Definition category_of_pointed_poset_strict : category := category_of_hset_struct struct_pointed_poset_strict. (** 2. The cartesian structure of pointed posets *) Definition cartesian_struct_pointed_poset_strict_data : hset_cartesian_struct_data := struct_pointed_poset_strict ,, unit_pointed_PartialOrder ,, λ X Y PX PY, prod_pointed_PartialOrder PX PY. Definition cartesian_struct_pointed_poset_strict_laws : hset_cartesian_struct_laws cartesian_struct_pointed_poset_strict_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X PX ; cbn in *. split. + intros x y p. exact tt. + apply idpath. - intros X Y PX PY ; cbn in *. apply dirprod_pr1_is_strict_and_monotone. - intros X Y PX PY ; cbn in *. apply dirprod_pr2_is_strict_and_monotone. - intros W X Y PW PY PZ f g Pf Pg ; cbn in *. exact (prodtofun_is_strict_and_monotone Pf Pg). Qed. Definition cartesian_struct_pointed_poset_strict : hset_cartesian_struct := cartesian_struct_pointed_poset_strict_data ,, cartesian_struct_pointed_poset_strict_laws. (** 3. Limits of pointed posets *) Definition equalizers_struct_pointed_poset_strict : hset_equalizer_struct struct_pointed_poset_strict. Proof. simple refine (_ ,, _). - intros X Y f g PX PY Pf Pg. exact (Equalizer_pointed_PartialOrder Pf Pg). - split. + abstract (intros X Y f g PX PY Pf Pg ; cbn in * ; exact (Equalizer_pr1_strict_and_monotone Pf Pg)). + abstract (intros X Y f g PX PY Pf Pg W PW h Ph q ; exact (Equalizer_map_strict_and_monotone Pf Pg PW Ph (eqtohomot q))). Defined. Definition type_products_struct_pointed_poset_strict (I : UU) : hset_struct_type_prod struct_pointed_poset_strict I. Proof. simple refine (_ ,, _). - exact (λ D fs, depfunction_pointed_poset _ fs). - split ; cbn. + abstract (intros D PD i ; apply is_strict_and_monotone_depfunction_pointed_poset_pr). + abstract (intros D PD W PW fs Hfs ; apply is_strict_and_monotone_depfunction_pointed_poset_pair ; exact Hfs). Defined. (** 4. Pointed posets form a pointed structure *) Definition pointed_struct_pointed_poset_strict_data : pointed_hset_struct_data struct_pointed_poset_strict := λ X RX, ⊥_{RX}. Proposition pointed_struct_pointed_poset_strict_laws : pointed_hset_struct_laws pointed_struct_pointed_poset_strict_data. Proof. split. - intros X Y RX RY. apply constant_is_strict_and_monotone. - intros X Y f PX PY Pf ; cbn in *. apply Pf. Qed. Definition pointed_struct_pointed_poset_strict : pointed_hset_struct struct_pointed_poset_strict := pointed_struct_pointed_poset_strict_data ,, pointed_struct_pointed_poset_strict_laws. (** 5. The smash product of pointed posets *) Proposition pointed_poset_strict_smash_eqrel_equiv {X Y : hSet} (PX : pointed_PartialOrder X) (PY : pointed_PartialOrder Y) (xy₁ xy₂ : X × Y) : smash_eqrel cartesian_struct_pointed_poset_strict pointed_struct_pointed_poset_strict PX PY xy₁ xy₂ <-> @downward_closed_to_eqrel (X × Y)%set (smash_set PX PY) xy₁ xy₂. Proof. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. split. - use factor_through_squash. { apply propproperty. } intro p. unfold product_point_coordinate in p. cbn in p. unfold pointed_struct_pointed_poset_strict_data in p. apply hinhpr. induction p as [ p | p ]. + exact (inl p). + apply inr. split. * exact (hinhpr (pr1 p)). * exact (hinhpr (pr2 p)). - use factor_through_squash. { apply propproperty. } intro p. unfold smash_set in p ; cbn in p. induction p as [ p | p ]. + exact (hinhpr (inl p)). + assert (p₁ := pr1 p). revert p₁. use factor_through_squash. { apply propproperty. } intros p₁. assert (p₂ := pr2 p). revert p₂. use factor_through_squash. { apply propproperty. } intros p₂. apply hinhpr. apply inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_poset_strict_data. split. * exact p₁. * exact p₂. Qed. Definition struct_pointed_poset_strict_with_smash_data : hset_struct_with_smash_data cartesian_struct_pointed_poset_strict pointed_struct_pointed_poset_strict. Proof. refine (_ ,, _). - exact pointed_PartialOrder_boolset. - intros X Y PX PY. use (pointed_quotient_poset (prod_pointed_PartialOrder PX PY) (smash_set PX PY) (smash_set_downward_closd PX PY)). exact (pointed_poset_strict_smash_eqrel_equiv PX PY). Defined. Proposition struct_pointed_poset_strict_with_smash_laws : hset_struct_with_smash_laws struct_pointed_poset_strict_with_smash_data. Proof. repeat split. - intros b₁ b₂ p ; cbn in p. induction b₁, b₂. + apply refl_PartialOrder. + induction p. + apply pointed_PartialOrder_min_point. + apply refl_PartialOrder. - intros x y p . unfold pointed_hset_struct_unit_map ; cbn. unfold pointed_struct_pointed_poset_strict_data. assert (q := pr1 Pf x y p) ; cbn in q. induction (f x), (f y). + apply Pg. exact p. + induction q. + apply (pr2 PY). + apply (pr2 PY). - unfold pointed_hset_struct_unit_map. cbn. unfold pointed_struct_pointed_poset_strict_data. induction (f ⊥_{PX}). + apply Pg. + apply idpath. - intros x₁ x₂ p ; cbn. apply hinhpr. use inr. refine (p ,, _). apply refl_PartialOrder. - use iscompsetquotpr ; cbn. apply hinhpr. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_poset_strict_data. split. + exact (inl (idpath _)). + exact (inl (idpath _)). - intros y₁ y₂ p ; cbn. apply hinhpr. use inr. exact (refl_PartialOrder (pr1 PX) x ,, p). - use iscompsetquotpr ; cbn. apply hinhpr. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_poset_strict_data. split. + exact (inr (idpath _)). + exact (inr (idpath _)). - intros xy₁ xy₂ p ; cbn. apply hinhpr. use inr. exact p. - use setquotunivprop'. { intro. repeat (use impred ; intro). apply propproperty. } intros xy₁. use setquotunivprop'. { intro. repeat (use impred ; intro). apply propproperty. } intros xy₂. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ] ; cbn. use factor_through_squash. { apply propproperty. } intro p. induction p as [ p | p]. + revert p. use factor_through_squash. { apply propproperty. } intro p. induction p as [ p | p ] ; rewrite p. * assert (h ⊥_{PX} y₁ = ⊥_{PZ}) as q. { refine (!(hp₂ (⊥_{PX}) y₁) @ _). apply (pr2 Ph). } rewrite q. apply (pr2 PZ). * assert (h x₁ ⊥_{PY} = ⊥_{PZ}) as q. { refine (hp₂ x₁ (⊥_{PY}) @ _). apply (pr2 Ph). } rewrite q. apply (pr2 PZ). + exact (pr1 Ph (x₁ ,, y₁) (x₂ ,, y₂) p). - apply (pr2 Ph). Qed. Definition struct_pointed_poset_strict_with_smash : hset_struct_with_smash cartesian_struct_pointed_poset_strict pointed_struct_pointed_poset_strict := struct_pointed_poset_strict_with_smash_data ,, struct_pointed_poset_strict_with_smash_laws. Definition struct_pointed_poset_strict_with_smash_closed_pointed_data : hset_struct_with_smash_closed_data struct_pointed_poset_strict_with_smash := λ X Y PX PY, strict_and_monotone_pointed_PartialOrder PX PY. Proposition struct_pointed_poset_strict_with_smash_closed_pointed_laws : hset_struct_with_smash_closed_pointed_laws struct_pointed_poset_strict_with_smash_closed_pointed_data. Proof. intros X Y PX PY x. apply idpath. Qed. Definition struct_pointed_poset_strict_with_smash_closed_pointed : hset_struct_with_smash_closed_pointed struct_pointed_poset_strict_with_smash := struct_pointed_poset_strict_with_smash_closed_pointed_data ,, struct_pointed_poset_strict_with_smash_closed_pointed_laws. Proposition struct_pointed_poset_strict_with_smash_adj_laws : hset_struct_with_smash_closed_adj_laws struct_pointed_poset_strict_with_smash_closed_pointed. Proof. split. - intros PX PY PZ f. induction PX as [ X RX ]. induction PY as [ Y RY ]. induction PZ as [ Z RZ ]. induction f as [ f Hf ]. split. + use setquotunivprop'. { intro. repeat (use impred ; intro). apply propproperty. } intros xy₁. use setquotunivprop'. { intro. repeat (use impred ; intro). apply propproperty. } intros xy₂. use factor_through_squash. { apply propproperty. } cbn in *. induction xy₁ as [ x₁ y₁ ], xy₂ as [ x₂ y₂ ]. intro p. induction p as [ p | p ]. * revert p. use factor_through_squash. { apply propproperty. } cbn. intro p. induction p as [ p | p ]. ** assert (pr1 (f x₁) y₁ = ⊥_{RZ}) as r. { rewrite p. exact (eqtohomot (maponpaths pr1 (pr2 Hf)) y₁). } rewrite r. apply (pr2 RZ). ** assert (pr1 (f x₁) y₁ = ⊥_{RZ}) as r. { rewrite p. apply (pr2 (f x₁)). } rewrite r. apply (pr2 RZ). * cbn ; cbn in p. refine (trans_PartialOrder RZ _ _). ** exact (pr12 (f x₁) _ _ (pr2 p)). ** exact (pr1 Hf _ _ (pr1 p) y₂). + cbn. etrans. { apply maponpaths_2. exact (pr2 Hf). } apply idpath. - intros PX PY PZ f. induction PX as [ X RX ]. induction PY as [ Y RY ]. induction PZ as [ Z RZ ]. induction f as [ f Hf ]. split. + intros x₁ x₂ p y. apply (pr1 Hf). cbn in *. apply hinhpr. use inr. refine (p ,, _). apply refl_PartialOrder. + use eq_strict_and_monotone_function. intro y. cbn. refine (_ @ pr2 Hf). apply maponpaths. use iscompsetquotpr. apply hinhpr. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_poset_strict_data. split. * exact (inl (idpath _)). * exact (inl (idpath _)). Qed. Definition struct_pointed_poset_strict_with_smash_adj : hset_struct_with_smash_closed_adj struct_pointed_poset_strict_with_smash := struct_pointed_poset_strict_with_smash_closed_pointed ,, struct_pointed_poset_strict_with_smash_adj_laws. Proposition struct_pointed_poset_strict_with_smash_laws_enrich : hset_struct_with_smash_closed_laws_enrich struct_pointed_poset_strict_with_smash_adj. Proof. split. - intros PX PY PZ. induction PX as [ X RX ]. induction PY as [ Y RY ]. induction PZ as [ Z RZ ]. split. + intros f₁ f₂ p. use setquotunivprop'. { intro. apply propproperty. } intros xz. induction xz as [ x z ]. cbn in *. apply p. + use eq_strict_and_monotone_function. use setquotunivprop'. { intro. apply setproperty. } intro x ; cbn in *. apply idpath. - intros PX PY PZ. induction PX as [ X RX ]. induction PY as [ Y RY ]. induction PZ as [ Z RZ ]. split. + intros f₁ f₂ p x y. cbn in *. apply p. + use eq_strict_and_monotone_function. intro x. use eq_strict_and_monotone_function. intro z. cbn. apply idpath. Qed. Definition pointed_struct_pointed_poset_strict_with_smash_closed : hset_struct_with_smash_closed := cartesian_struct_pointed_poset_strict ,, pointed_struct_pointed_poset_strict ,, struct_pointed_poset_strict_with_smash ,, struct_pointed_poset_strict_with_smash_adj ,, struct_pointed_poset_strict_with_smash_laws_enrich. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PointedPosetStructures.v000066400000000000000000000054141451125700300310470ustar00rootroot00000000000000(***************************************************************** Pointed posets In this file, we define the category of pointed posets and monotone functions (not necessarily strict) as a category of structured sets. We also show that it is a cartesian structure. Note: since we don't require that the morphisms are strict functions (i.e., preserve the bottom element), this category is not complete and cocomplete. It is also not cartesian closed. Contents 1. Structures of pointed posets 2. Cartesian structure of posets *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. (** 1. Structures of pointed posets *) Definition struct_pointed_poset_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, pointed_PartialOrder X). - exact (λ X Y PX PY f, is_monotone PX PY f). Defined. Definition struct_pointed_poset_laws : hset_struct_laws struct_pointed_poset_data. Proof. split5. - intro X. use isaset_total2. + apply isaset_PartialOrder. + intro PX. apply isasetaprop. apply isaprop_bottom_element. - intros X Y PX PY f. apply isaprop_is_monotone. - intros X PX. apply idfun_is_monotone. - intros X Y Z PX PY PZ f g Pf Pg. exact (comp_is_monotone Pf Pg). - intros X PX PX' p q ; cbn in *. exact (eq_pointed_PartialOrder_monotone p q). Qed. Definition struct_pointed_poset : hset_struct := struct_pointed_poset_data ,, struct_pointed_poset_laws. (** 2. Cartesian structure of posets *) Definition cartesian_struct_pointed_poset_data : hset_cartesian_struct_data := struct_pointed_poset ,, unit_pointed_PartialOrder ,, λ X Y PX PY, prod_pointed_PartialOrder PX PY. Definition cartesian_struct_pointed_poset_laws : hset_cartesian_struct_laws cartesian_struct_pointed_poset_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X PX ; cbn in *. intros x y p. exact tt. - intros X Y PX PY ; cbn in *. apply dirprod_pr1_is_monotone. - intros X Y PX PY ; cbn in *. apply dirprod_pr2_is_monotone. - intros W X Y PW PY PZ f g Pf Pg ; cbn in *. exact (prodtofun_is_monotone Pf Pg). Qed. Definition cartesian_struct_pointed_poset : hset_cartesian_struct := cartesian_struct_pointed_poset_data ,, cartesian_struct_pointed_poset_laws. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PointedSetStructures.v000066400000000000000000000170451451125700300305130ustar00rootroot00000000000000(***************************************************************** Pointed set structures We define the category of pointed sets as a category of structured sets. In addition, we construct the smash product. Contents 1. Structures of pointed sets 2. Limits and colimits of pointed sets 3. Pointed sets form a pointed structure 4. The smash product *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Local Open Scope cat. (** 1. Structures of pointed sets *) Definition struct_pointed_hset_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, X). - exact (λ X Y x y f, f x = y). Defined. Definition struct_pointed_hset_laws : hset_struct_laws struct_pointed_hset_data. Proof. repeat split. - intro X. apply setproperty. - intros X Y px py f. apply setproperty. - intros X Y Z px py pz f g p q ; cbn in *. rewrite p, q. apply idpath. - intros X px px' p q ; cbn in *. exact p. Qed. Definition struct_pointed_hset : hset_struct := struct_pointed_hset_data ,, struct_pointed_hset_laws. (** 2. Limits and colimits of pointed sets *) Definition cartesian_struct_pointed_hset_data : hset_cartesian_struct_data := struct_pointed_hset ,, tt ,, λ X Y x y, x ,, y. Definition cartesian_struct_pointed_hset_laws : hset_cartesian_struct_laws cartesian_struct_pointed_hset_data. Proof. repeat split. intros W X Y pw px py f g p q ; cbn in *. unfold prodtofuntoprod ; cbn. rewrite p, q. apply idpath. Qed. Definition cartesian_struct_pointed_hset : hset_cartesian_struct := cartesian_struct_pointed_hset_data ,, cartesian_struct_pointed_hset_laws. Definition equalizers_struct_pointed_hset : hset_equalizer_struct struct_pointed_hset. Proof. simple refine (_ ,, _). - refine (λ X Y f g px py p q, px ,, _). abstract (exact (p @ !q)). - abstract (repeat split ; cbn ; intros X Y f g px py p q W pw h r s ; use subtypePath ; [ intro ; apply setproperty | ] ; exact r). Defined. Definition coequalizers_struct_pointed_hset : hset_coequalizer_struct struct_pointed_hset. Proof. simple refine (_ ,, _). - exact (λ X Y f g px py p q, setquotpr _ py). - abstract (repeat split ; cbn ; intros X Y f g px py p q W pw h r s ; exact r). Defined. Definition type_products_struct_pointed_hset (I : UU) : hset_struct_type_prod struct_pointed_hset I. Proof. simple refine (_ ,, _). - exact (λ D fs, fs). - abstract (repeat split ; cbn ; intros D PD W pw fs pq ; use funextsec ; exact pq). Defined. (** 3. Pointed sets form a pointed structure *) Definition pointed_struct_pointed_hset_data : pointed_hset_struct_data struct_pointed_hset := λ X x, x. Proposition pointed_struct_pointed_hset_laws : pointed_hset_struct_laws pointed_struct_pointed_hset_data. Proof. split. - intros X Y PX PY ; cbn. apply idpath. - intros X Y f PX PY Pf ; cbn in *. exact Pf. Qed. Definition pointed_struct_pointed_hset : pointed_hset_struct struct_pointed_hset := pointed_struct_pointed_hset_data ,, pointed_struct_pointed_hset_laws. (** 4. The smash product *) Definition pointed_struct_pointed_hset_with_smash_data : hset_struct_with_smash_data cartesian_struct_pointed_hset pointed_struct_pointed_hset. Proof. split. - exact false. - exact (λ X Y x y, setquotpr _ (x ,, y)). Defined. Proposition pointed_struct_pointed_hset_with_smash_laws : hset_struct_with_smash_laws pointed_struct_pointed_hset_with_smash_data. Proof. repeat split. - intros X Y x y f pf g pg. cbn in *. unfold pointed_hset_struct_unit_map. rewrite pf. apply idpath. - intro y. use iscompsetquotpr. apply hinhpr. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_hset_data. split. + exact (inl (idpath _)). + exact (inl (idpath _)). - intro x. use iscompsetquotpr. apply hinhpr. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_hset_data. split. + exact (inr (idpath _)). + exact (inr (idpath _)). - intros Z z h Ph hp₁ hp₂ hp₃ ; cbn in *. exact Ph. Qed. Definition pointed_struct_pointed_hset_with_smash : hset_struct_with_smash cartesian_struct_pointed_hset pointed_struct_pointed_hset. Proof. use make_hset_struct_with_smash. - exact pointed_struct_pointed_hset_with_smash_data. - exact pointed_struct_pointed_hset_with_smash_laws. Defined. Definition pointed_struct_pointed_hset_with_smash_closed_pointed : hset_struct_with_smash_closed_pointed pointed_struct_pointed_hset_with_smash. Proof. refine ((λ X Y x y, (λ _, y) ,, idpath _) ,, _). intro ; intros. apply idpath. Defined. Proposition pointed_struct_pointed_hset_with_smash_adj_laws : hset_struct_with_smash_closed_adj_laws pointed_struct_pointed_hset_with_smash_closed_pointed. Proof. split. - intros X Y Z f. induction X as [ X x ]. induction Y as [ Y y ]. induction Z as [ Z z ]. induction f as [ f p ]. cbn in *. exact (eqtohomot (maponpaths pr1 p) y). - intros X Y Z f. induction X as [ X x ]. induction Y as [ Y y ]. induction Z as [ Z z ]. induction f as [ f p ]. use subtypePath. { intro. apply setproperty. } use funextsec. intro a. refine (_ @ p). refine (maponpaths f _). use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. unfold pointed_struct_pointed_hset_data. split ; use inl ; apply idpath. Qed. Definition pointed_struct_pointed_hset_with_smash_adj : hset_struct_with_smash_closed_adj pointed_struct_pointed_hset_with_smash := pointed_struct_pointed_hset_with_smash_closed_pointed ,, pointed_struct_pointed_hset_with_smash_adj_laws. Proposition pointed_struct_pointed_hset_with_smash_laws_enrich : hset_struct_with_smash_closed_laws_enrich pointed_struct_pointed_hset_with_smash_adj. Proof. split. - intros X Y Z. induction X as [ X x ]. induction Y as [ Y y ]. induction Z as [ Z z ]. use subtypePath. { intro ; apply setproperty. } use funextsec. use setquotunivprop'. { intro ; apply setproperty. } intro xz. cbn in *. apply idpath. - intros X Y Z. induction X as [ X x ]. induction Y as [ Y y ]. induction Z as [ Z z ]. use subtypePath. { intro ; apply setproperty. } use funextsec. intro a. use subtypePath. { intro ; apply setproperty. } use funextsec. intro b. cbn in *. apply idpath. Qed. Definition pointed_struct_pointed_hset_with_smash_closed : hset_struct_with_smash_closed := cartesian_struct_pointed_hset ,, pointed_struct_pointed_hset ,, pointed_struct_pointed_hset_with_smash ,, pointed_struct_pointed_hset_with_smash_adj ,, pointed_struct_pointed_hset_with_smash_laws_enrich. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/PosetStructures.v000066400000000000000000000136551451125700300275320ustar00rootroot00000000000000(***************************************************************** Poset structure Since posets are structured sets, we can define the category of posets in a rather convenient way. This approach is taken in this file. Contents 1. Poset structures of set 2. Posets is a cartesian structure 3. Limits of posets 4. Exponentials of posets 5. Binary coproducts of posets *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. (** 1. Poset structures of set *) Definition struct_poset_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, PartialOrder X). - exact (λ X Y PX PY f, is_monotone PX PY f). Defined. Definition struct_poset_laws : hset_struct_laws struct_poset_data. Proof. repeat split. - intro X. apply isaset_PartialOrder. - intros X Y px py f. apply isaprop_is_monotone. - intros X PX ; cbn in *. apply idfun_is_monotone. - intros X Y Z PX PY PZ f g Pf Pg. exact (comp_is_monotone Pf Pg). - intros X PX PX' p q ; cbn in *. exact (eq_PartialOrder p q). Qed. Definition struct_poset : hset_struct := struct_poset_data ,, struct_poset_laws. (** 2. Posets is a cartesian structure *) Definition cartesian_struct_poset_data : hset_cartesian_struct_data := struct_poset ,, unit_PartialOrder ,, λ X Y PX PY, prod_PartialOrder PX PY. Definition cartesian_struct_poset_laws : hset_cartesian_struct_laws cartesian_struct_poset_data. Proof. refine (_ ,, _ ,, _ ,, _). - intros X PX x y p ; cbn in *. exact tt. - intros X Y PX PY ; cbn in *. apply dirprod_pr1_is_monotone. - intros X Y PX PY ; cbn in *. apply dirprod_pr2_is_monotone. - intros W X Y PW PY PZ f g Pf Pg ; cbn in *. exact (prodtofun_is_monotone Pf Pg). Qed. Definition cartesian_struct_poset : hset_cartesian_struct := cartesian_struct_poset_data ,, cartesian_struct_poset_laws. (** 3. Limits of posets *) Definition equalizers_struct_poset : hset_equalizer_struct struct_poset. Proof. simple refine (_ ,, _). - intros X Y f g PX PY Pf Pg. exact (Equalizer_order PX _ f g). - repeat split. + abstract (intros X Y f g PX PY Pf Pg ; cbn in * ; exact (Equalizer_pr1_monotone PX Y f g)). + abstract (intros X Y f g PX PY Pf Pg W PW h Ph q ; exact (Equalizer_map_monotone PX Y f g PW Ph (eqtohomot q))). Defined. Definition type_products_struct_poset (I : UU) : hset_struct_type_prod struct_poset I. Proof. simple refine (_ ,, _). - exact (λ D fs, depfunction_poset _ fs). - repeat split ; cbn. + abstract (intros D PD i ; apply is_monotone_depfunction_poset_pr). + abstract (intros D PD W PW fs Hfs i ; apply is_monotone_depfunction_poset_pair ; exact Hfs). Defined. (** 4. Exponentials of posets *) Definition poset_fun_space {X Y : hSet} (PX : PartialOrder X) (PY : PartialOrder Y) : PartialOrder (@struct_fun_hSet struct_poset X Y PX PY). Proof. use make_PartialOrder. - exact (λ f g, ∀ (x : X), PY (pr1 f x) (pr1 g x)). - refine ((_ ,, _) ,, _). + abstract (intros f g h p q x ; exact (trans_PartialOrder PY (p x) (q x))). + abstract (intros f x ; exact (refl_PartialOrder PY (pr1 f x))). + abstract (intros f g p q ; use eq_monotone_function ; intro x ; exact (antisymm_PartialOrder PY (p x) (q x))). Defined. Definition cartesian_closed_struct_poset_data : hset_cartesian_closed_struct_data. Proof. refine (cartesian_struct_poset ,, _ ,, _). - abstract (intros X Y PX PY y x₁ x₂ p ; cbn ; apply refl_PartialOrder). - exact (λ X Y PX PY, poset_fun_space PX PY). Defined. Proposition cartesian_closed_struct_poset_laws : closed_under_fun_laws cartesian_closed_struct_poset_data. Proof. repeat split. - intros X Y PX PY xf yg p. induction xf as [ x [ f Hf ]]. induction yg as [ y [ g Hg ]]. cbn in *. induction p as [ p q ]. exact (trans_PartialOrder PY (q x) (Hg _ _ p)). - intros X Y Z PX PY PZ f Pf z₁ z₂ p x. cbn in *. exact (Pf (x ,, z₁) (x ,, z₂) (refl_PartialOrder PX x ,, p)). Qed. Definition cartesian_closed_struct_poset : hset_cartesian_closed_struct := cartesian_closed_struct_poset_data ,, cartesian_closed_struct_poset_laws. (** 5. Binary coproducts of posets *) Definition binary_coproducts_struct_poset : hset_binary_coprod_struct struct_poset. Proof. simple refine (_ ,, _). - exact (λ X Y PX PY, coproduct_PartialOrder PX PY). - simple refine (_ ,, _ ,, _) ; cbn. + abstract (intros X Y PX PY ; cbn ; exact (is_monotone_inl PX PY)). + abstract (intros X Y PX PY ; cbn ; exact (is_monotone_inr PX PY)). + abstract (intros X Y Z PX PY PZ f g Pf Pg ; exact (is_monotone_sumofmaps _ _ Pf Pg)). Defined. (** 6. Set-indexed coproducts of posets *) Definition set_coproducts_struct_poset (I : hSet) : hset_struct_set_coprod struct_poset I. Proof. simple refine (_ ,, _). - exact (λ Y PY, coproduct_set_PartialOrder _ PY). - simple refine (_ ,, _) ; cbn. + abstract (intros Y PY ; cbn ; exact (is_monotone_set_in _ PY)). + abstract (refine (λ Y PY W PW f Pf, _) ; exact (is_monotone_set_coproduct_map _ _ Pf)). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/Reindexing.v000066400000000000000000001416101451125700300264210ustar00rootroot00000000000000(******************************************************************* Results on the reindexing displayed category In this file, we collect results on the displayed category obtained by reindexing. Content: 1. Transport lemma 2. Characterization of displayed isomorphisms 3. Univalence 4. Characterization of cartesian and opcartesian morphisms 5. Cleaving 6. Functor from reindexing 7. Mapping property 8. Reindexing along opfibrations gives pullbacks 9. Reindexing of functors 10. Reindexing of natural transformations 11. Pseudofunctoriality of reindexing ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope mor_disp. Local Open Scope cat. (** ** Reindexing *) Section Reindexing. Local Open Scope mor_disp. Local Open Scope cat. Context {C' C : category} (F : functor C' C) (D : disp_cat C). Definition reindex_disp_cat_ob_mor : disp_cat_ob_mor C'. Proof. exists (λ c, D (F c)). intros x y xx yy f. exact (xx -->[# F f] yy). Defined. Definition reindex_disp_cat_id_comp : disp_cat_id_comp C' reindex_disp_cat_ob_mor. Proof. apply tpair. - simpl; intros x xx. refine (transportb _ _ _). apply functor_id. apply id_disp. - simpl; intros x y z f g xx yy zz ff gg. refine (transportb _ _ _). apply functor_comp. exact (ff ;; gg). Defined. Definition reindex_disp_cat_data : disp_cat_data C' := (_ ,, reindex_disp_cat_id_comp). Definition reindex_disp_cat_axioms : disp_cat_axioms C' reindex_disp_cat_data. Proof. repeat apply tpair; cbn. - intros x y f xx yy ff. eapply pathscomp0. apply maponpaths, mor_disp_transportf_postwhisker. eapply pathscomp0. apply transport_b_f. eapply pathscomp0. apply maponpaths, id_left_disp. eapply pathscomp0. apply transport_f_b. eapply pathscomp0. 2: apply @pathsinv0, (functtransportb (# F)). unfold transportb; apply maponpaths_2, homset_property. - intros x y f xx yy ff. eapply pathscomp0. apply maponpaths, mor_disp_transportf_prewhisker. eapply pathscomp0. apply transport_b_f. eapply pathscomp0. apply maponpaths, id_right_disp. eapply pathscomp0. apply transport_f_b. eapply pathscomp0. 2: apply @pathsinv0, (functtransportb (# F)). unfold transportb; apply maponpaths_2, homset_property. - intros x y z w f g h xx yy zz ww ff gg hh. eapply pathscomp0. apply maponpaths, mor_disp_transportf_prewhisker. eapply pathscomp0. apply transport_b_f. eapply pathscomp0. apply maponpaths, assoc_disp. eapply pathscomp0. apply transport_f_b. apply pathsinv0. eapply pathscomp0. apply (functtransportb (# F)). eapply pathscomp0. apply transport_b_b. eapply pathscomp0. apply maponpaths, mor_disp_transportf_postwhisker. eapply pathscomp0. apply transport_b_f. unfold transportb; apply maponpaths_2, homset_property. - intros; apply homsets_disp. Qed. Definition reindex_disp_cat : disp_cat C' := (_ ,, reindex_disp_cat_axioms). (** ** A functor of displayed categories from reindexing *) Definition reindex_disp_functor : disp_functor F reindex_disp_cat D. Proof. use tpair. - use tpair. + cbn. intro x. exact (idfun _ ). + cbn. intros x x' d d' f. exact (idfun _ ). - abstract ( split; [intros; apply idpath |]; intros; apply idpath ). Defined. End Reindexing. (** 1. Transport lemma *) Definition transportf_reindex {C' C : category} {D : disp_cat C} {F : C' ⟶ C} {x y : C'} {xx : D(F x)} {yy : D(F y)} {f g : x --> y} (p : f = g) (ff : xx -->[# F f] yy) : transportf (@mor_disp C' (reindex_disp_cat F D) _ _ xx yy) p ff = transportf (@mor_disp C D _ _ xx yy) (maponpaths (# F) p) ff. Proof. induction p ; apply idpath. Qed. (** 2. Characterization of displayed isomorphisms *) Definition z_iso_disp_to_z_iso_disp_reindex {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D : disp_cat C₂} {x : C₁} {xx yy : D (F x)} : z_iso_disp (identity_z_iso (F x)) xx yy → @z_iso_disp _ (reindex_disp_cat F D) _ _ (identity_z_iso x) xx yy. Proof. intros i. use make_z_iso_disp. - exact (transportb (λ z, _ -->[ z ] _) (functor_id _ _) i). - simple refine (_ ,, _ ,, _). + exact (transportb (λ z, _ -->[ z ] _) (functor_id _ _) (inv_mor_disp_from_z_iso i)). + abstract (cbn ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite mor_disp_transportf_postwhisker ; rewrite transport_f_f ; refine (maponpaths (λ z, transportf _ _ z) (z_iso_disp_after_inv_mor i) @ _) ; unfold transportb ; rewrite !transport_f_f ; refine (!_) ; etrans ; [ apply transportf_reindex | ] ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). + abstract (cbn ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite mor_disp_transportf_postwhisker ; rewrite transport_f_f ; refine (maponpaths (λ z, transportf _ _ z) (inv_mor_after_z_iso_disp i) @ _) ; unfold transportb ; rewrite !transport_f_f ; refine (!_) ; etrans ; [ apply transportf_reindex | ] ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). Defined. Definition z_iso_disp_reindex_to_z_iso_disp {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D : disp_cat C₂} {x : C₁} {xx yy : D (F x)} : @z_iso_disp _ (reindex_disp_cat F D) _ _ (identity_z_iso x) xx yy → z_iso_disp (identity_z_iso (F x)) xx yy. Proof. intros i. use make_z_iso_disp. - exact (transportf (λ z, _ -->[ z ] _) (functor_id _ _) i). - simple refine (_ ,, _ ,, _). + exact (transportf (λ z, _ -->[ z ] _) (functor_id _ _) (inv_mor_disp_from_z_iso i)). + abstract (unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; pose (z_iso_disp_after_inv_mor i) as p ; cbn in p ; exact (transportf_transpose_right p) | ] ; unfold transportb ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; apply transportf_reindex | ] ; rewrite !transport_f_f ; apply maponpaths_2 ; apply homset_property). + abstract (unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite mor_disp_transportf_postwhisker ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; pose (inv_mor_after_z_iso_disp i) as p ; cbn in p ; exact (transportf_transpose_right p) | ] ; unfold transportb ; rewrite !transport_f_f ; etrans ; [ apply maponpaths ; apply transportf_reindex | ] ; rewrite !transport_f_f ; apply maponpaths_2 ; apply homset_property). Defined. Definition z_iso_disp_weq_z_iso_disp_reindex {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D : disp_cat C₂} {x : C₁} (xx yy : D (F x)) : z_iso_disp (identity_z_iso (F x)) xx yy ≃ @z_iso_disp _ (reindex_disp_cat F D) _ _ (identity_z_iso x) xx yy. Proof. use make_weq. - exact z_iso_disp_to_z_iso_disp_reindex. - use isweq_iso. + exact z_iso_disp_reindex_to_z_iso_disp. + abstract (intros i ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; cbn ; apply transportfbinv). + abstract (intros i ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; cbn ; apply transportbfinv). Defined. (** 3. The univalence *) Definition is_univalent_reindex_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : is_univalent_disp D) : is_univalent_disp (reindex_disp_cat F D). Proof. intros x y p xx yy. induction p. use weqhomot. - exact (z_iso_disp_weq_z_iso_disp_reindex xx yy ∘ make_weq (@idtoiso_disp _ D _ _ (idpath _) xx yy) (HD _ _ _ xx yy))%weq. - abstract (intros p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. Definition univalent_reindex_cat {C₁ C₂ : univalent_category} (F : C₁ ⟶ C₂) (D : disp_univalent_category C₂) : univalent_category. Proof. use make_univalent_category. - exact (total_category (reindex_disp_cat F (pr1 D))). - use is_univalent_total_category. + exact (pr2 C₁). + exact (is_univalent_reindex_disp_cat F _ (pr2 D)). Defined. (** 4. Characterization of cartesian and opcartesian morphisms *) Definition is_cartesian_in_reindex_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) {x y : C₁} {f : x --> y} {xx : D (F x)} {yy : D (F y)} (ff : xx -->[ #F f ] yy) (Hff : is_cartesian ff) : @is_cartesian _ (reindex_disp_cat F D) y x f yy xx ff. Proof. intros z g zz gg ; cbn in *. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply D | ] ; use (cartesian_factorisation_unique Hff) ; rewrite (transportf_transpose_right (pr2 φ₁)) ; rewrite (transportf_transpose_right (pr2 φ₂)) ; apply idpath). - simple refine (_ ,, _). + refine (cartesian_factorisation Hff (#F g) (transportf (λ z, _ -->[ z ] _) _ gg)). abstract (apply functor_comp). + abstract (cbn ; rewrite cartesian_factorisation_commutes ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Section IsCartesianFromReindexDispCat. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : cleaving D) {x y : C₁} {f : x --> y} {xx : D (F x)} {yy : D (F y)} (ff : xx -->[ #F f ] yy) (Hff : @is_cartesian _ (reindex_disp_cat F D) y x f yy xx ff). Let ℓ : cartesian_lift yy (# F f) := HD (F y) (F x) (#F f) yy. Let m : xx -->[ identity (F x)] pr1 ℓ := cartesian_factorisation ℓ (identity _) (transportb (λ z, _ -->[ z ] _) (id_left _) ff). Let minv' : pr1 ℓ -->[ # F (identity x · f)] yy := transportb _ (maponpaths (λ z, #F z) (id_left _)) (pr12 ℓ). Let minv : pr1 ℓ -->[ identity (F x)] xx := transportf _ (functor_id _ _) (cartesian_factorisation Hff _ minv'). Local Lemma minv_m : (minv ;; m)%mor_disp = transportb (λ z, _ -->[ z ] _) (z_iso_after_z_iso_inv (make_z_iso' _ (identity_is_z_iso (F x)))) (id_disp ℓ). Proof. unfold minv, m. unfold transportb. use (cartesian_factorisation_unique ℓ). rewrite !mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. unfold m. rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { apply maponpaths. pose (cartesian_factorisation_commutes Hff (identity x) (transportb (mor_disp (pr1 ℓ) yy) (maponpaths (λ z, _) (id_left f)) (pr12 ℓ))). cbn in p. apply (transportf_transpose_right p). } unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Local Lemma m_minv : (m ;; minv)%mor_disp = transportb (λ z, _ -->[ z ] _) (z_iso_inv_after_z_iso (make_z_iso' _ (identity_is_z_iso (F x)))) (id_disp xx). Proof. cbn. unfold m, minv. rewrite mor_disp_transportf_prewhisker. pose (cartesian_factorisation ℓ (identity _) (transportb (λ z, xx -->[ z] yy) (id_left ((# F)%Cat f)) ff) ;; cartesian_factorisation Hff (identity _) (transportb (mor_disp (pr1 ℓ) yy) (maponpaths (λ z, (# F)%Cat z) (id_left f)) (pr12 ℓ)))%mor_disp as m'. pose (@cartesian_factorisation_unique _ _ _ _ _ _ _ _ Hff _ (identity _) xx (transportf _ (id_left _) m') (id_disp _)) as p. cbn in p ; unfold transportb in p. simple refine (_ @ maponpaths (transportf (λ z, _ -->[ z ] _) (functor_id _ _ @ !(id_left _))) (p _) @ _). - rewrite transport_f_f. apply maponpaths_2. apply homset_property. - cbn. unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. unfold m'. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. pose (cartesian_factorisation_commutes Hff (identity _) (transportb (mor_disp (pr1 ℓ) yy) (maponpaths (λ z : C₁ ⟦ x, y ⟧, (# F)%Cat z) (id_left f)) (pr12 ℓ))) as q. cbn in q. exact (transportb_transpose_right q). } unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition is_cartesian_from_reindex_disp_cat : is_cartesian ff. Proof. use (z_iso_disp_to_is_cartesian _ ℓ). - apply identity. - apply identity_is_z_iso. - apply id_left. - exact m. - simple refine (_ ,, _ ,, _). + exact minv. + exact minv_m. + exact m_minv. - apply cartesian_factorisation_commutes. Defined. End IsCartesianFromReindexDispCat. Definition is_opcartesian_in_reindex_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) {x y : C₁} {f : x --> y} {xx : D (F x)} {yy : D (F y)} (ff : xx -->[ #F f ] yy) (Hff : is_opcartesian ff) : @is_opcartesian _ (reindex_disp_cat F D) x y f xx yy ff. Proof. intros z zz g gg ; cbn in *. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply D | ] ; use (opcartesian_factorisation_unique Hff) ; rewrite (transportf_transpose_right (pr2 φ₁)) ; rewrite (transportf_transpose_right (pr2 φ₂)) ; apply idpath). - simple refine (_ ,, _). + refine (opcartesian_factorisation Hff (#F g) (transportf (λ z, _ -->[ z ] _) _ gg)). abstract (apply functor_comp). + abstract (cbn ; rewrite opcartesian_factorisation_commutes ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Section IsOpCartesianFromReindexDispCat. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : opcleaving D) {x y : C₁} {f : x --> y} {xx : D (F x)} {yy : D (F y)} (ff : xx -->[ #F f ] yy) (Hff : @is_opcartesian _ (reindex_disp_cat F D) x y f xx yy ff). Let ℓ : opcartesian_lift _ xx (# F f) := HD (F x) (F y) xx (#F f). Let m : pr1 ℓ -->[ identity (F y)] yy := opcartesian_factorisation (mor_of_opcartesian_lift_is_opcartesian _ ℓ) (identity _) (transportb (λ z, _ -->[ z ] _) (id_right _) ff). Let minv' : xx -->[ # F (f · identity y) ] pr1 ℓ := transportb _ (maponpaths (λ z, #F z) (id_right _)) (pr12 ℓ). Let minv : yy -->[ identity (F y)] pr1 ℓ := transportf _ (functor_id _ _) (opcartesian_factorisation Hff _ minv'). Local Lemma op_minv_m : (minv ;; m)%mor_disp = transportb (λ z, _ -->[ z ] _) (z_iso_after_z_iso_inv (make_z_iso' _ (identity_is_z_iso _))) (id_disp _). Proof. pose (p := @opcartesian_factorisation_unique _ _ _ _ _ _ _ _ Hff _ yy (identity _) (transportf (λ z, _ -->[ z ] _) (id_left _ @ !(functor_id _ _)) (minv ;; m)%mor_disp) (id_disp _)). simple refine (_ @ maponpaths (transportf (λ z, _ -->[ z ] _) (functor_id _ _ @ !(id_left _))) (p _) @ _) ; clear p. - rewrite transport_f_f. refine (!_). apply transportf_set. apply homset_property. - rewrite id_right_disp. cbn. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. unfold minv. rewrite assoc_disp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. pose (opcartesian_factorisation_commutes Hff (identity _) minv') as p. cbn in p. exact (transportf_transpose_right p). } rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. unfold minv', m. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite opcartesian_factorisation_commutes. rewrite transport_f_f. refine (_ @ !(transportf_reindex _ ff)). apply maponpaths_2. apply homset_property. - cbn. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Local Lemma op_m_minv : (m ;; minv)%mor_disp = transportb (λ z, _ -->[ z ] _) (z_iso_inv_after_z_iso (make_z_iso' _ (identity_is_z_iso _))) (id_disp _). Proof. cbn. unfold m, minv. use (opcartesian_factorisation_unique (mor_of_opcartesian_lift_is_opcartesian _ ℓ)). unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite assoc_disp. rewrite opcartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. pose (opcartesian_factorisation_commutes Hff (identity _) minv') as p. cbn in p. apply (transportf_transpose_right p). } rewrite transport_f_f. unfold minv'. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Local Lemma is_opcartesian_from_reindex_disp_cat_help : ff = transportf (λ z, _ -->[ z ] _) (id_right _) (opcleaving_mor HD _ _ ;; m)%mor_disp. Proof. unfold m. rewrite opcartesian_factorisation_commutes. rewrite transportfbinv. apply idpath. Qed. Definition is_opcartesian_from_reindex_disp_cat : is_opcartesian ff. Proof. refine (transportb is_opcartesian is_opcartesian_from_reindex_disp_cat_help _). apply is_opcartesian_transportf. use is_opcartesian_comp_disp. - apply mor_of_opcartesian_lift_is_opcartesian. - use is_opcartesian_z_iso_disp. + apply identity_is_z_iso. + simple refine (_ ,, _ ,, _). * exact minv. * apply op_minv_m. * apply op_m_minv. Defined. End IsOpCartesianFromReindexDispCat. (** 5. Cleaving *) Definition cleaving_reindex_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : cleaving D) : cleaving (reindex_disp_cat F D). Proof. intros x y f d. pose (HD (F x) (F y) (#F f) d) as lift. simple refine (_ ,, (_ ,, _)). - exact (pr1 lift). - exact (pr12 lift). - simpl. apply is_cartesian_in_reindex_disp_cat. exact (pr22 lift). Defined. Definition opcleaving_reindex_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : opcleaving D) : opcleaving (reindex_disp_cat F D). Proof. intros x y d f. pose (HD (F x) (F y) d (#F f)) as lift. simple refine (_ ,, (_ ,, _)). - exact (pr1 lift). - exact (pr12 lift). - simpl. apply is_opcartesian_in_reindex_disp_cat. exact (pr22 lift). Defined. (** 6. Functor from reindexing *) Definition reindex_disp_cat_disp_functor_data {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) : disp_functor_data F (reindex_disp_cat F D) D. Proof. simple refine (_ ,, _). - exact (λ _ xx, xx). - exact (λ _ _ _ _ _ ff, ff). Defined. Definition reindex_disp_cat_disp_functor_axioms {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) : disp_functor_axioms (reindex_disp_cat_disp_functor_data F D). Proof. split ; cbn ; intros ; apply idpath. Qed. Definition reindex_disp_cat_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) : disp_functor F (reindex_disp_cat F D) D. Proof. simple refine (_ ,, _). - exact (reindex_disp_cat_disp_functor_data F D). - exact (reindex_disp_cat_disp_functor_axioms F D). Defined. Definition is_cartesian_reindex_disp_cat_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : cleaving D) : is_cartesian_disp_functor (reindex_disp_cat_disp_functor F D). Proof. intros x y f xx yy ff Hff. apply is_cartesian_from_reindex_disp_cat. - exact HD. - exact Hff. Defined. Definition is_opcartesian_reindex_disp_cat_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂) (HD : opcleaving D) : is_opcartesian_disp_functor (reindex_disp_cat_disp_functor F D). Proof. intros x y f xx yy ff Hff. apply is_opcartesian_from_reindex_disp_cat. - exact HD. - exact Hff. Defined. (** 7. Mapping property *) Definition lift_functor_into_reindex_data {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_functor_data F₁ D₁ (reindex_disp_cat F₂ D₃). Proof. simple refine (_ ,, _). - exact (λ x xx, FF x xx). - exact (λ x y xx yy f ff, ♯ FF ff). Defined. Definition lift_functor_into_reindex_axioms {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_functor_axioms (lift_functor_into_reindex_data FF). Proof. split. - intros x xx ; cbn. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite transport_f_f. refine (!_). rewrite (disp_functor_id FF). unfold transportb. apply maponpaths_2. apply homset_property. - intros x y z xx yy zz f g ff gg ; cbn. unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite transport_f_f. rewrite (disp_functor_comp FF). unfold transportb. apply maponpaths_2. apply homset_property. Qed. Definition lift_functor_into_reindex {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_functor F₁ D₁ (reindex_disp_cat F₂ D₃). Proof. simple refine (_ ,, _). - exact (lift_functor_into_reindex_data FF). - exact (lift_functor_into_reindex_axioms FF). Defined. Definition is_cartesian_lift_functor_into_reindex {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {FF : disp_functor (F₁ ∙ F₂) D₁ D₃} (HFF : is_cartesian_disp_functor FF) : is_cartesian_disp_functor (lift_functor_into_reindex FF). Proof. intros x y f xx yy ff Hff. apply is_cartesian_in_reindex_disp_cat. apply HFF. exact Hff. Defined. Definition is_opcartesian_lift_functor_into_reindex {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {FF : disp_functor (F₁ ∙ F₂) D₁ D₃} (HFF : is_opcartesian_disp_functor FF) : is_opcartesian_disp_functor (lift_functor_into_reindex FF). Proof. intros x y f xx yy ff Hff. apply is_opcartesian_in_reindex_disp_cat. apply HFF. exact Hff. Defined. Definition lift_functor_into_reindex_commute_data {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_nat_trans_data (nat_trans_id _) (disp_functor_composite (lift_functor_into_reindex FF) (reindex_disp_cat_disp_functor _ _)) FF := λ x xx, id_disp _. Definition lift_functor_into_reindex_commute_axioms {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_nat_trans_axioms (lift_functor_into_reindex_commute_data FF). Proof. intros x y f xx yy ff ; unfold lift_functor_into_reindex_commute_data ; cbn. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition lift_functor_into_reindex_commute {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} (FF : disp_functor (F₁ ∙ F₂) D₁ D₃) : disp_nat_trans (nat_trans_id _) (disp_functor_composite (lift_functor_into_reindex FF) (reindex_disp_cat_disp_functor _ _)) FF. Proof. simple refine (_ ,, _). - exact (lift_functor_into_reindex_commute_data FF). - exact (lift_functor_into_reindex_commute_axioms FF). Defined. Definition lift_functor_into_reindex_disp_nat_trans_data {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ F₁' : C₁ ⟶ C₂} {α : F₁ ⟹ F₁'} {F₂ : C₂ ⟶ C₃} {FF₁ : disp_functor (F₁ ∙ F₂) D₁ D₃} {FF₂ : disp_functor (F₁' ∙ F₂) D₁ D₃} (αα : disp_nat_trans (post_whisker α _) FF₁ FF₂) : disp_nat_trans_data α (lift_functor_into_reindex_data FF₁) (lift_functor_into_reindex_data FF₂) := λ x xx, αα x xx. Definition lift_functor_into_reindex_disp_nat_trans_axioms {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ F₁' : C₁ ⟶ C₂} {α : F₁ ⟹ F₁'} {F₂ : C₂ ⟶ C₃} {FF₁ : disp_functor (F₁ ∙ F₂) D₁ D₃} {FF₂ : disp_functor (F₁' ∙ F₂) D₁ D₃} (αα : disp_nat_trans (post_whisker α _) FF₁ FF₂) : disp_nat_trans_axioms (lift_functor_into_reindex_disp_nat_trans_data αα). Proof. intros x y f xx yy ff ; cbn ; unfold lift_functor_into_reindex_disp_nat_trans_data. etrans. { apply maponpaths. exact (disp_nat_trans_ax αα ff). } unfold transportb. rewrite !transport_f_f. refine (!_). etrans. { apply transportf_reindex. } rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition lift_functor_into_reindex_disp_nat_trans {C₁ C₂ C₃ : category} {D₁ : disp_cat C₁} {D₃ : disp_cat C₃} {F₁ F₁' : C₁ ⟶ C₂} {α : F₁ ⟹ F₁'} {F₂ : C₂ ⟶ C₃} {FF₁ : disp_functor (F₁ ∙ F₂) D₁ D₃} {FF₂ : disp_functor (F₁' ∙ F₂) D₁ D₃} (αα : disp_nat_trans (post_whisker α _) FF₁ FF₂) : disp_nat_trans α (lift_functor_into_reindex FF₁) (lift_functor_into_reindex FF₂). Proof. simple refine (_ ,, _). - exact (lift_functor_into_reindex_disp_nat_trans_data αα). - exact (lift_functor_into_reindex_disp_nat_trans_axioms αα). Defined. (** 8. Reindexing along opfibrations gives pullbacks *) Section ReindexIsPB. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D₂ : disp_cat C₂) (HD₂ : iso_cleaving D₂). (** Universal property for functors *) Context {C₀ : category} (G : C₀ ⟶ total_category D₂) (H : C₀ ⟶ C₁) (α : nat_z_iso (H ∙ F) (G ∙ pr1_category D₂)). Definition reindex_pb_ump_1_data : functor_data C₀ (total_category (reindex_disp_cat F D₂)). Proof. use make_functor_data. - exact (λ x, H x ,, pr1 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α x) (pr2 (G x)))). - refine (λ x y f, # H f ,, _). refine (transportb (λ z, _ -->[ z ] _) _ (pr2 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α x) (pr2 (G x))) ;; (pr2 (#G f))%Cat ;; inv_mor_disp_from_z_iso (pr2 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α y) (pr2 (G y)))))%mor_disp). abstract (cbn ; use z_iso_inv_on_left ; refine (!_) ; exact (nat_trans_ax α _ _ f)). Defined. Definition reindex_pb_ump_1_is_functor : is_functor reindex_pb_ump_1_data. Proof. split. - intros x. use total2_paths_f ; cbn. + apply functor_id. + unfold transportb. etrans. { apply transportf_reindex. } rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. exact (transportb_transpose_right (fiber_paths (functor_id G x))). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply id_right_disp. } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. exact (inv_mor_after_z_iso_disp (pr2 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α x) (pr2 (G x))))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros x y z f g. use total2_paths_f ; cbn. + apply functor_comp. + unfold transportb. etrans. { apply transportf_reindex. } rewrite mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. exact (transportb_transpose_right (fiber_paths (functor_comp G f g))). } unfold transportb ; cbn. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite !assoc_disp_var. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. refine (!_). etrans. { do 3 apply maponpaths. rewrite !assoc_disp. unfold transportb. rewrite transport_f_f. apply maponpaths. do 2 apply maponpaths_2. exact (z_iso_disp_after_inv_mor (pr2 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α y) (pr2 (G y))))). } unfold transportb. rewrite !mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_pb_ump_1 : C₀ ⟶ total_category (reindex_disp_cat F D₂). Proof. use make_functor. - exact reindex_pb_ump_1_data. - exact reindex_pb_ump_1_is_functor. Defined. Definition reindex_pb_ump_1_pr1 : reindex_pb_ump_1 ∙ pr1_category _ ⟹ H. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition reindex_pb_ump_1_pr1_nat_iso : nat_z_iso (reindex_pb_ump_1 ∙ pr1_category _) H. Proof. use make_nat_z_iso. - exact reindex_pb_ump_1_pr1. - intro. apply identity_is_z_iso. Defined. Definition reindex_pb_ump_1_pr2_nat_z_iso_data : nat_trans_data (reindex_pb_ump_1 ∙ total_functor (reindex_disp_cat_disp_functor F D₂)) G := λ x, α x ,, pr12 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α x) (pr2 (G x))). Definition reindex_pb_ump_1_pr2_is_nat_trans : is_nat_trans _ _ reindex_pb_ump_1_pr2_nat_z_iso_data. Proof. intros x y f. use total2_paths_f ; cbn. - exact (nat_trans_ax α _ _ f). - unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite !assoc_disp_var. rewrite !transport_f_f. etrans. { do 3 apply maponpaths. exact (z_iso_disp_after_inv_mor (pr2 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α y) (pr2 (G y))))). } unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Definition reindex_pb_ump_1_pr2 : reindex_pb_ump_1 ∙ total_functor (reindex_disp_cat_disp_functor F D₂) ⟹ G. Proof. use make_nat_trans. - exact reindex_pb_ump_1_pr2_nat_z_iso_data. - exact reindex_pb_ump_1_pr2_is_nat_trans. Defined. Definition reindex_pb_ump_1_pr2_nat_z_iso : nat_z_iso (reindex_pb_ump_1 ∙ total_functor (reindex_disp_cat_disp_functor F D₂)) G. Proof. use make_nat_z_iso. - exact reindex_pb_ump_1_pr2. - intros x. use is_z_iso_total. + exact (pr2 (nat_z_iso_pointwise_z_iso α x)). + exact (pr22 (HD₂ _ _ (nat_z_iso_pointwise_z_iso α x) (pr2 (G x)))). Defined. (** Universal property for natural transformations *) Context (Φ₁ Φ₂ : C₀ ⟶ total_category (reindex_disp_cat F D₂)) (τ₁ : Φ₁ ∙ pr1_category _ ⟹ Φ₂ ∙ pr1_category _) (τ₂ : Φ₁ ∙ total_functor (reindex_disp_cat_disp_functor F D₂) ⟹ Φ₂ ∙ total_functor (reindex_disp_cat_disp_functor F D₂)) (p : ∏ (x : C₀), pr1 (τ₂ x) = # F (τ₁ x)). Definition reindex_pb_ump_2_data : nat_trans_data Φ₁ Φ₂. Proof. refine (λ x, τ₁ x ,, _). exact (transportf (λ z, _ -->[ z ] _) (p x) (pr2 (τ₂ x))). Defined. Definition reindex_pb_ump_2_is_nat_trans : is_nat_trans Φ₁ Φ₂ reindex_pb_ump_2_data. Proof. intros x y f. use total2_paths_f ; cbn. - exact (nat_trans_ax τ₁ _ _ f). - unfold transportb. etrans. { apply transportf_reindex. } rewrite transport_f_f. rewrite !mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (nat_trans_ax τ₂ _ _ f))). } unfold transportb. rewrite transport_f_f. cbn. apply maponpaths_2. apply homset_property. Qed. Definition reindex_pb_ump_2 : Φ₁ ⟹ Φ₂. Proof. use make_nat_trans. - exact reindex_pb_ump_2_data. - exact reindex_pb_ump_2_is_nat_trans. Defined. Definition reindex_pb_ump_2_pr1 : post_whisker reindex_pb_ump_2 (pr1_category _) = τ₁. Proof. use nat_trans_eq. { intro ; apply homset_property. } intro x ; cbn. apply idpath. Qed. Definition reindex_pb_ump_2_pr2 : post_whisker reindex_pb_ump_2 (total_functor (reindex_disp_cat_disp_functor F D₂)) = τ₂. Proof. use nat_trans_eq. { intro ; apply homset_property. } intro x ; cbn. use total2_paths_f ; cbn. - exact (!(p x)). - rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. (** Universal property for equalities *) Context (n₁ n₂ : Φ₁ ⟹ Φ₂) (n₁_pr1 : post_whisker n₁ (pr1_category _) = τ₁) (n₁_pr2 : post_whisker n₁ (total_functor (reindex_disp_cat_disp_functor F D₂)) = τ₂) (n₂_pr1 : post_whisker n₂ (pr1_category _) = τ₁) (n₂_pr2 : post_whisker n₂ (total_functor (reindex_disp_cat_disp_functor F D₂)) = τ₂). Definition reindex_pb_ump_eq : n₁ = n₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. use total2_paths_f. - pose (nat_trans_eq_pointwise n₁_pr1 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr1 x) as q₂. cbn in q₁, q₂. exact (q₁ @ !q₂). - cbn. pose (nat_trans_eq_pointwise n₁_pr2 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr2 x) as q₂. cbn in q₁, q₂. refine (_ @ fiber_paths (q₁ @ !q₂)). cbn. etrans. { apply transportf_reindex. } apply maponpaths_2. apply homset_property. Qed. End ReindexIsPB. (** 9. Reindexing of functors *) Section ReindexOfDispFunctor. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) {D₁ D₂ : disp_cat C₂} (G : disp_functor (functor_identity _) D₁ D₂). Local Open Scope mor_disp. Definition reindex_of_disp_functor_data : disp_functor_data (functor_identity _) (reindex_disp_cat F D₁) (reindex_disp_cat F D₂). Proof. simple refine (_ ,, _). - exact (λ x xx, G (F x) xx). - exact (λ x y xx yy f ff, ♯ G ff). Defined. Definition reindex_of_disp_functor_axioms : disp_functor_axioms reindex_of_disp_functor_data. Proof. split. - intros x xx ; cbn. unfold transportb. rewrite (disp_functor_transportf _ G). rewrite disp_functor_id. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros x y z xx yy zz f g ff gg ; cbn. unfold transportb. rewrite (disp_functor_transportf _ G). rewrite disp_functor_comp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_of_disp_functor : disp_functor (functor_identity _) (reindex_disp_cat F D₁) (reindex_disp_cat F D₂). Proof. simple refine (_ ,, _). - exact reindex_of_disp_functor_data. - exact reindex_of_disp_functor_axioms. Defined. Definition reindex_of_disp_functor_is_cartesian_disp_functor (HD₁ : cleaving D₁) (HG : is_cartesian_disp_functor G) : is_cartesian_disp_functor reindex_of_disp_functor. Proof. intros x y f xx yy ff Hff. apply is_cartesian_in_reindex_disp_cat ; cbn. apply HG. use is_cartesian_from_reindex_disp_cat. - exact HD₁. - exact Hff. Defined. Definition reindex_of_disp_functor_is_opcartesian_disp_functor (HD₁ : opcleaving D₁) (HG : is_opcartesian_disp_functor G) : is_opcartesian_disp_functor reindex_of_disp_functor. Proof. intros x y f xx yy ff Hff. apply is_opcartesian_in_reindex_disp_cat ; cbn. apply HG. use is_opcartesian_from_reindex_disp_cat. - exact HD₁. - exact Hff. Defined. End ReindexOfDispFunctor. Definition reindex_of_cartesian_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) {D₁ D₂ : disp_cat C₂} (G : cartesian_disp_functor (functor_identity _) D₁ D₂) (HD₁ : cleaving D₁) : cartesian_disp_functor (functor_identity _) (reindex_disp_cat F D₁) (reindex_disp_cat F D₂) := reindex_of_disp_functor F G ,, reindex_of_disp_functor_is_cartesian_disp_functor F G HD₁ (pr2 G). Definition reindex_of_opcartesian_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) {D₁ D₂ : disp_cat C₂} (G : opcartesian_disp_functor (functor_identity _) D₁ D₂) (HD₁ : opcleaving D₁) : opcartesian_disp_functor (functor_identity _) (reindex_disp_cat F D₁) (reindex_disp_cat F D₂) := reindex_of_disp_functor F G ,, reindex_of_disp_functor_is_opcartesian_disp_functor F G HD₁ (pr2 G). (** 10. Reindexing of natural transformations *) Section ReindexOfDispNatTrans. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) {D₁ D₂ : disp_cat C₂} {G₁ G₂ : disp_functor (functor_identity _) D₁ D₂} (α : disp_nat_trans (nat_trans_id _) G₁ G₂). Let reindex_of_disp_nat_trans_data : disp_nat_trans_data (nat_trans_id _) (reindex_of_disp_functor F G₁) (reindex_of_disp_functor F G₂) := λ x xx, transportb (λ z, _ -->[ z ] _) (functor_id F x) (α (F x) xx). Definition reindex_of_disp_nat_trans_axioms : disp_nat_trans_axioms reindex_of_disp_nat_trans_data. Proof. intros x y f xx yy ff ; cbn ; unfold reindex_of_disp_nat_trans_data. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths. exact (disp_nat_trans_ax α ff). } unfold transportb. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_of_disp_nat_trans : disp_nat_trans (nat_trans_id _) (reindex_of_disp_functor F G₁) (reindex_of_disp_functor F G₂). Proof. simple refine (_ ,, _). - exact reindex_of_disp_nat_trans_data. - exact reindex_of_disp_nat_trans_axioms. Defined. End ReindexOfDispNatTrans. (** 11. Pseudofunctoriality of reindexing *) Section ReindexOfId. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D : disp_cat C₂). Let reindex_of_disp_functor_identity_data : disp_nat_trans_data (nat_trans_id _) (disp_functor_identity _) (reindex_of_disp_functor_data F (disp_functor_identity D)) := λ x xx, transportb (λ z, _ -->[ z ] _) (functor_id F x) (id_disp _). Definition reindex_of_disp_functor_identity_axioms : disp_nat_trans_axioms reindex_of_disp_functor_identity_data. Proof. intros x y f xx yy ff ; cbn ; unfold reindex_of_disp_functor_identity_data. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_of_disp_functor_identity : disp_nat_trans (nat_trans_id _) (disp_functor_identity _) (reindex_of_disp_functor F (disp_functor_identity D)). Proof. simple refine (_ ,, _). - exact reindex_of_disp_functor_identity_data. - exact reindex_of_disp_functor_identity_axioms. Defined. End ReindexOfId. Section ReindexOfComp. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) {D₁ D₂ D₃ : disp_cat C₂} (G₁ : disp_functor (functor_identity _) D₁ D₂) (G₂ : disp_functor (functor_identity _) D₂ D₃). Let reindex_of_disp_functor_composite_data : disp_nat_trans_data (nat_trans_id _) (disp_functor_over_id_composite (reindex_of_disp_functor F G₁) (reindex_of_disp_functor F G₂)) (reindex_of_disp_functor F (disp_functor_over_id_composite G₁ G₂)) := λ x xx, transportb (λ z, _ -->[ z ] _) (functor_id F x) (id_disp _). Definition reindex_of_disp_functor_composite_axioms : disp_nat_trans_axioms reindex_of_disp_functor_composite_data. Proof. intros x y f xx yy ff ; cbn ; unfold reindex_of_disp_functor_composite_data. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp, id_right_disp. unfold transportb. rewrite !transport_f_f. refine (!_). etrans. { apply transportf_reindex. } rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition reindex_of_disp_functor_composite : disp_nat_trans (nat_trans_id _) (disp_functor_over_id_composite (reindex_of_disp_functor F G₁) (reindex_of_disp_functor F G₂)) (reindex_of_disp_functor F (disp_functor_over_id_composite G₁ G₂)). Proof. simple refine (_ ,, _). - exact reindex_of_disp_functor_composite_data. - exact reindex_of_disp_functor_composite_axioms. Defined. End ReindexOfComp. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/SetStructures.v000066400000000000000000000062501451125700300271640ustar00rootroot00000000000000(***************************************************************** Set structures A simple example of a structure of sets, would be the trivial structure. Structures above sets and morphisms would be be inhabitants of the unit type Contents 1. The trivial structure 2. The trivial structure is cartesian 3. The trivial structure is cartesian closed 4. Some limits and colimits for trivial structures *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. (** 1. The trivial structure *) Definition struct_plain_hset_data : hset_struct_data. Proof. simple refine (_ ,, _). - exact (λ X, unit). - exact (λ X Y x y f, unit). Defined. Definition struct_plain_hset_laws : hset_struct_laws struct_plain_hset_data. Proof. repeat split. - intro X. apply isasetunit. - intros X Y px py f. apply isapropunit. - intros X px py f g. apply isapropunit. Qed. Definition struct_plain_hset : hset_struct := struct_plain_hset_data ,, struct_plain_hset_laws. (** 2. The trivial structure is cartesian *) Definition cartesian_struct_plain_hset_data : hset_cartesian_struct_data := struct_plain_hset ,, tt ,, λ _ _ _ _, tt. Definition cartesian_struct_plain_hset_laws : hset_cartesian_struct_laws cartesian_struct_plain_hset_data. Proof. repeat split. Qed. Definition cartesian_struct_plain_hset : hset_cartesian_struct := cartesian_struct_plain_hset_data ,, cartesian_struct_plain_hset_laws. (** 3. The trivial structure is cartesian closed *) Definition cartesian_closed_struct_plain_hset_data : hset_cartesian_closed_struct_data. Proof. simple refine (cartesian_struct_plain_hset ,, _ ,, _). - exact (λ _ _ _ _ _, tt). - exact (λ _ _ _ _, tt). Defined. Definition cartesian_closed_struct_plain_hset_laws : closed_under_fun_laws cartesian_closed_struct_plain_hset_data. Proof. repeat split. Qed. Definition cartesian_closed_struct_plain_hset : hset_cartesian_closed_struct := cartesian_closed_struct_plain_hset_data ,, cartesian_closed_struct_plain_hset_laws. (** 4. Some limits and colimits for trivial structures *) Definition equalizers_struct_plain_hset : hset_equalizer_struct struct_plain_hset. Proof. refine ((λ _ _ _ _ _ _ _ _, tt) ,, _). abstract (repeat split). Defined. Definition coequalizers_struct_plain_hset : hset_coequalizer_struct struct_plain_hset. Proof. refine ((λ _ _ _ _ _ _ _ _, tt) ,, _). abstract (repeat split). Defined. Definition type_products_struct_plain_hset (I : UU) : hset_struct_type_prod struct_plain_hset I. Proof. simple refine ((λ _ _, tt) ,, _). abstract (repeat split). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/Sigma.v000066400000000000000000000237021451125700300253660ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Local Open Scope mor_disp_scope. Local Open Scope weq_scope. (** * Sigmas of displayed (pre)categories *) Section Sigma. Context {C : category} {D : disp_cat C} (E : disp_cat (total_category D)). Definition sigma_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. exists (λ c, ∑ (d : D c), (E (c,,d))). intros x y xx yy f. exact (∑ (fD : pr1 xx -->[f] pr1 yy), (pr2 xx -->[f,,fD] pr2 yy)). Defined. Definition sigma_disp_cat_id_comp : disp_cat_id_comp _ sigma_disp_cat_ob_mor. Proof. apply tpair. - intros x xx. exists (id_disp _). exact (id_disp (pr2 xx)). - intros x y z f g xx yy zz ff gg. exists (pr1 ff ;; pr1 gg). exact (pr2 ff ;; pr2 gg). Defined. Definition sigma_disp_cat_data : disp_cat_data C := (_ ,, sigma_disp_cat_id_comp). Definition sigma_disp_cat_axioms : disp_cat_axioms _ sigma_disp_cat_data. Proof. repeat apply tpair. - intros x y f [xx xxx] [yy yyy] [ff fff]; simpl in ff, fff. use total2_reassoc_paths'. + simpl. apply id_left_disp. + simpl. apply (pathscomp0 (id_left_disp fff)). apply maponpaths_2. apply homset_property. - intros x y f [xx xxx] [yy yyy] [ff fff]; simpl in ff, fff. use total2_reassoc_paths'. + simpl. apply id_right_disp. + simpl. apply (pathscomp0 (id_right_disp fff)). apply maponpaths_2. apply homset_property. - intros x y z w f g h [xx xxx] [yy yyy] [zz zzz] [ww www] [ff fff] [gg ggg] [hh hhh]. simpl in ff, fff, gg, ggg, hh, hhh. use total2_reassoc_paths'. + simpl. apply assoc_disp. + apply (pathscomp0 (assoc_disp fff ggg hhh)). apply maponpaths_2. apply homset_property. - intros. apply isaset_total2. + apply homsets_disp. + intros. apply homsets_disp. Qed. Definition sigma_disp_cat : disp_cat C := (_ ,, sigma_disp_cat_axioms). Definition sigmapr1_disp_functor_data : disp_functor_data (functor_identity C) sigma_disp_cat D. Proof. use tpair. - intros x xx; exact (pr1 xx). - intros x y xx yy f ff; exact (pr1 ff). Defined. Definition sigmapr1_disp_functor_axioms : disp_functor_axioms sigmapr1_disp_functor_data. Proof. split. - intros; apply idpath. - intros; apply idpath. Qed. Definition sigmapr1_disp_functor : disp_functor (functor_identity C) sigma_disp_cat D := (sigmapr1_disp_functor_data,, sigmapr1_disp_functor_axioms). (* TODO: complete [sigmapr2_disp]; will be a [functor_lifting], not a [disp_functor]. *) (** ** Transport and isomorphism lemmas *) Lemma pr1_transportf_sigma_disp {x y : C} {f f' : x --> y} (e : f = f') {xxx : sigma_disp_cat x} {yyy} (fff : xxx -->[f] yyy) : pr1 (transportf _ e fff) = transportf _ e (pr1 fff). Proof. destruct e; apply idpath. Qed. Lemma pr2_transportf_sigma_disp {x y : C} {f f' : x --> y} (e : f = f') {xxx : sigma_disp_cat x} {yyy} (fff : xxx -->[f] yyy) : pr2 (transportf _ e fff) = transportf (λ ff, pr2 xxx -->[ff] _ ) (two_arg_paths_f (*total2_paths2*) e (! pr1_transportf_sigma_disp e fff)) (pr2 fff). Proof. destruct e. apply pathsinv0. etrans. apply maponpaths_2, maponpaths, maponpaths. apply (homsets_disp _ _ _ _ _ _ (idpath _)). apply idpath. Qed. (** ** Univalence *) (** *** Characterization of the isos of sigma_disp_cat *) Lemma E_mor_eq {x y xx yy} {xxx : E (x ,, xx)} {yyy : E (y ,, yy)} (xxx' := (xx ,, xxx) : sigma_disp_cat _) (yyy' := (yy ,, yyy) : sigma_disp_cat _) (f : z_iso x y) (g := inv_from_z_iso f) {ff gg fff ggg} {H1 : compose (C := total_category D) (a := (_ ,, _)) (b := (_ ,, _)) (c := (_ ,, _)) (z_iso_mor f ,, ff) (g ,, gg) = identity _} (H2 : comp_disp (D := sigma_disp_cat) (xx := (xx ,, xxx)) (yy := (yy ,, yyy)) (zz := (xx ,, xxx)) (ff ,, fff) (gg ,, ggg) = transportb _ (z_iso_inv_after_z_iso f) (id_disp _)) : fff ;; ggg = transportb _ H1 (id_disp _). Proof. induction (total2_paths_equiv _ _ _ H2) as [H3 H4]. refine (transportb_transpose_right (e := H3) H4 @ _). unfold transportb. simpl. apply transportf_transpose_right. rewrite pr2_transportf_sigma_disp, (functtransportf _ _ (two_arg_paths_f _ _)), (functtransportf _ _ (!H3)), transport_b_f, transport_f_f. apply transportf_set. apply (homset_property (total_category _)). Qed. Definition sigma_iso_to_iso {x y} {xxx : sigma_disp_cat x} {yyy : sigma_disp_cat y} (f : z_iso x y) (fff : z_iso_disp f xxx yyy) : ∑ ff, z_iso_disp (total_z_iso f ff (xx := (_ ,, _)) (yy := (_ ,, _))) (pr2 xxx) (pr2 yyy). Proof. use tpair. - repeat use tpair. + exact (pr1 (mor_disp_from_z_iso fff)). + exact (pr1 (inv_mor_disp_from_z_iso fff)). + abstract exact (maponpaths _ (z_iso_disp_after_inv_mor fff) @ pr1_transportf_sigma_disp _ _). + abstract exact (maponpaths _ (inv_mor_after_z_iso_disp fff) @ pr1_transportf_sigma_disp _ _). - repeat use tpair. + exact (pr2 (mor_disp_from_z_iso fff)). + exact (pr2 (inv_mor_disp_from_z_iso fff)). + exact (E_mor_eq (z_iso_inv f) (z_iso_disp_after_inv_mor fff)). + exact (E_mor_eq f (inv_mor_after_z_iso_disp fff)). Defined. Lemma sigma_mor_eq {x y f g} {xxx : sigma_disp_cat x} {yyy : sigma_disp_cat y} {fff : xxx -->[f] yyy} {ggg : xxx -->[g] yyy} {H1 : f = g} {H2} (H3 : pr2 fff = transportb _ (total2_paths_b (s := (_ ,, _)) (s' := (_ ,, _)) H1 H2) (pr2 ggg)) : fff = transportb _ H1 ggg. Proof. use total2_paths_f. - refine (H2 @ !_). apply pr1_transportf_sigma_disp. - refine (maponpaths _ H3 @ _ @ !(pr2_transportf_sigma_disp _ _)). refine (functtransportf _ _ _ _ @ _). apply transportf_transpose_right. refine (transport_b_f _ _ _ _ @ transport_f_f _ _ _ _ @ _). exact (transportf_set _ _ _ (homset_property (total_category _) (_ ,, _) (_ ,, _))). Qed. Definition iso_to_sigma_is_disp_inverse {x y} {xxx : sigma_disp_cat x} {yyy : sigma_disp_cat y} {f : z_iso x y} (fff : ∑ ff, z_iso_disp (total_z_iso f ff (xx := (_ ,, _)) (yy := (_ ,, _))) (pr2 xxx) (pr2 yyy)) : is_disp_inverse (D := sigma_disp_cat) (z_iso_is_inverse_in_precat f) (mor_disp_from_z_iso (pr1 fff) ,, mor_disp_from_z_iso (pr2 fff)) (inv_mor_disp_from_z_iso (pr1 fff) ,, inv_mor_disp_from_z_iso (pr2 fff)). Proof. use tpair; use sigma_mor_eq. - exact (z_iso_disp_after_inv_mor (pr1 fff)). - refine (z_iso_disp_after_inv_mor (pr2 fff) @ _). apply transportf_transpose_right. refine (transport_b_b _ _ _ _ @ _). exact (transportf_set _ _ _ (homset_property _ _ _)). - exact (inv_mor_after_z_iso_disp (pr1 fff)). - refine (inv_mor_after_z_iso_disp (pr2 fff) @ _). apply transportf_transpose_right. refine (transport_b_b _ _ _ _ @ _). exact (transportf_set _ _ _ (homset_property _ _ _)). Qed. Definition iso_to_sigma_iso {x y} {xxx : sigma_disp_cat x} {yyy : sigma_disp_cat y} (f : z_iso x y) (fff : ∑ ff, z_iso_disp (total_z_iso f ff (xx := (_ ,, _)) (yy := (_ ,, _))) (pr2 xxx) (pr2 yyy)) : z_iso_disp f xxx yyy := _ ,, _ ,, iso_to_sigma_is_disp_inverse fff. Definition sigma_disp_z_iso_equiv {x y} {xxx : sigma_disp_cat x} {yyy : sigma_disp_cat y} (f : z_iso x y) : z_iso_disp f xxx yyy ≃ ∑ ff, z_iso_disp (total_z_iso f ff (xx := (_ ,, _)) (yy := (_ ,, _))) (pr2 xxx) (pr2 yyy). Proof. use weq_iso. - exact (sigma_iso_to_iso f). - exact (iso_to_sigma_iso f). - abstract ( intro; apply eq_z_iso_disp; now use total2_paths_f ). - abstract ( intro; use total2_paths_f; [now apply eq_z_iso_disp | apply eq_z_iso_disp]; refine (pr1_transportf (B := λ ff, (pr2 xxx) -->[_ ,, pr1 ff] _) _ _ @ _); refine (functtransportf _ _ _ _ @ _); exact (transportf_set _ _ _ (homset_property _ _ _)) ). Defined. (* Local Open Scope hide_transport_scope. *) (** *** The univalence proof *) Lemma is_univalent_sigma_disp (DD : is_univalent_disp D) (EE : is_univalent_disp E) : is_univalent_disp sigma_disp_cat. Proof. apply is_univalent_disp_from_fibers. intros x xx yy. use weqhomot. - induction xx as [xx xxx], yy as [yy yyy]. refine ( weqcomp (Y := (xx,, xxx : sigma_disp_cat x) ╝ yy,, yyy) _ (weqcomp (Y := ∑ ee : xx = yy, z_iso_disp (@total_z_iso _ D (_ ,, _) (_ ,, _) _ (idtoiso_disp (idpath _) ee)) xxx yyy) _ (weqcomp (Y := ∑ ff, (z_iso_disp (total_z_iso _ ff) xxx yyy)) _ _ ))). + apply total2_paths_equiv. + apply weqfibtototal. intro ee. induction (ee : xx = yy). refine (weqcomp (Y := z_iso_disp (idtoiso (C := total_category _) (total2_paths2_f (idpath x) (idpath _))) xxx yyy) _ _). * exact (make_weq (λ ee, idtoiso_disp (idpath _) ee) (EE _ _ _ _ _)). * now refine (make_weq _ (isweqtransportf (λ I, z_iso_disp I _ _) (z_iso_eq _ _ _))). + exact (weqfp (make_weq _ (DD _ _ (idpath _) _ _)) _). + exact (invweq (sigma_disp_z_iso_equiv (xxx := (_ ,, _)) (yyy := (_ ,, _)) _)). - assert (lemma1 : ∏ i i' (e : i = i') ii, pr1 (transportf (λ _, z_iso_disp _ (pr2 xx) (pr2 yy)) e ii) = transportf _ (maponpaths pr1 e) (pr1 ii)). { intros i i' e. now induction e. } intro ee. apply eq_z_iso_disp. induction ee. cbn. refine (maponpaths _ (lemma1 _ (total_z_iso _ (identity_z_iso_disp _)) _ _ @ _)). refine (maponpaths_2 (y' := idpath _) _ _ _). apply homset_property. Qed. End Sigma. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Examples/UnitalBinop.v000066400000000000000000000267041451125700300265570ustar00rootroot00000000000000(** Author: Niels van der Weide Suppose, we have a set `X` with a binary operation `f : X → X → X`. Since init elments for `f` are unique, the type of unit elements of `f` is a proposition. This means we have two ways of defining a univalent category of sets with a unital binary operations: 1. We define it as a full subcategory of the category of sets with a binary operation 2. We use algebras of the signature describing sets with a binary operation and a unit, which satisfy the necessary axioms. Note that in the first category the morphismms are all functions between sets which preserve the binary relation, while the morphisms in the second category must preserve the unit element as well. As a consequence, the forgetful is full and faithful in the first construction, while in the second it is only faithful. On the nLab, there are definitions which describe when functors forget properties and when functors forget stuff. https://ncatlab.org/nlab/show/stuff%2C+structure%2C+property#definitions With this terminology, we can argue why the first approach adds the unit as a property while in the second approach it is added as structure. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Local Open Scope cat. (** Let us start by defining sets with a binary operation on them. To do so, we use algebras on the diagonal functor. Let us repeat the diagonal. After that, we show we have a univalent category of sets with a binary operation. *) Definition diag : HSET ⟶ HSET. Proof. exact (bindelta_functor HSET ∙ binproduct_functor BinProductsHSET). Defined. Definition binop_category : category. Proof. simple refine (FunctorAlg diag). Defined. Definition is_univalent_binop : is_univalent binop_category. Proof. exact (is_univalent_FunctorAlg is_univalent_HSET diag). Defined. Definition binop : univalent_category. Proof. use make_univalent_category. - exact binop_category. - exact is_univalent_binop. Defined. (** In the remainder, we need some projections. *) Section ProjectionsBinop. Variable (m : binop). Definition carrier : hSet := pr1 m. Definition operation : carrier → carrier → carrier := λ x y, pr2 m (x ,, y). End ProjectionsBinop. (** Now we look at two ways of defining a category of sets with a binary operation and a unit. The first way, is by using the full subcategory. This gives rise to a univalent category since unit elements are unique. *) Definition is_unit (m : binop) (e : carrier m) : UU := (∏ (x : carrier m), operation m x e = x) × (∏ (x : carrier m), operation m e x = x). Definition has_unit (m : binop) : UU := ∑ (e : carrier m), is_unit m e. Definition isaprop_has_unit (m : binop) : isaprop (has_unit m). Proof. use invproofirrelevance. intros e₁ e₂. use subtypePath. { intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty. } exact (!(pr22 e₂ (pr1 e₁)) @ pr12 e₁ (pr1 e₂)). Defined. Definition unit_binop_property_disp_cat : disp_cat binop := disp_full_sub binop has_unit. Definition unit_binop_property_cat : category := total_category unit_binop_property_disp_cat. Definition is_univalent_property_unit_binop : is_univalent unit_binop_property_cat. Proof. use is_univalent_total_category. - exact is_univalent_binop. - use disp_full_sub_univalent. exact isaprop_has_unit. Defined. Definition unit_binop_property : univalent_category. Proof. use make_univalent_category. - exact unit_binop_property_cat. - exact is_univalent_property_unit_binop. Defined. (** To argue that the unit element is really added as a property, we look at the forgetful functor to sets with binary operations. This functor only forgets the unit and, since the unit was added as a property, it is full and faithful. Note that in this displayed category: - the displayed objects form a proposition - the displayed morphisms are contractible *) Definition forget_unit_property_adds_properties : adds_properties unit_binop_property_disp_cat. Proof. apply pr1_category_fully_faithful. intro ; intros. apply iscontrunit. Defined. (** Next we show how to define sets with a binary operation and a unit where the unit is added as structure. To do so, we use displayed categories. To prove univalence of the total category, we use displayed univalence. *) Definition point_disp_cat_ob_mor : disp_cat_ob_mor binop. Proof. use make_disp_cat_ob_mor ; cbn. - exact (λ X, carrier X). - exact (λ X Y x y f, pr1 f x = y). Defined. Definition point_disp_cat_id_comp : disp_cat_id_comp binop point_disp_cat_ob_mor. Proof. use tpair. - exact (λ _ _, idpath _). - exact (λ X Y Z f g x y z p q, maponpaths (pr1 g) p @ q). Defined. Definition point_disp_cat_data : disp_cat_data binop. Proof. use tpair. - exact point_disp_cat_ob_mor. - exact point_disp_cat_id_comp. Defined. Definition point_disp_cat_laws : disp_cat_axioms binop point_disp_cat_data. Proof. repeat split. - cbn ; intros ; apply setproperty. - cbn ; intros ; apply setproperty. - cbn ; intros ; apply setproperty. - cbn ; intros. apply isasetaprop. apply setproperty. Qed. Definition point_disp_cat : disp_cat binop. Proof. use tpair. - exact point_disp_cat_data. - exact point_disp_cat_laws. Defined. Definition point_disp_cat_disp_univalent : is_univalent_disp point_disp_cat. Proof. use is_univalent_disp_from_fibers. intros X x y. use isweq_iso. - intros f. exact (pr1 f). - intros e. induction e ; cbn. apply idpath. - intros e. use subtypePath. { intro ; apply isaprop_is_z_iso_disp. } cbn. induction (pr1 e). apply idpath. Defined. Definition pointed_binop_category : category := total_category point_disp_cat. Definition pointed_binop : univalent_category. Proof. simple refine (_ ,, _). - exact pointed_binop_category. - refine (is_univalent_total_category _ point_disp_cat_disp_univalent). exact is_univalent_binop. Defined. (** Some projections of sets with a binary operation and a point. *) Section ProjectionsPointedBinop. Variable (m : pointed_binop). Definition pointed_carrier : hSet := pr11 m. Definition pointed_operation : pointed_carrier → pointed_carrier → pointed_carrier := λ x y, pr21 m (x ,, y). Definition point_of : pointed_carrier := pr2 m. End ProjectionsPointedBinop. (** Up to now, we only added the element which represents the unit. Beside that, we also need to add the necessary laws. *) Definition is_unit_point : pointed_binop → UU := λ X, is_unit (pr1 X) (pr2 X). Definition isaprop_is_unit_point (X : pointed_binop) : isaprop (is_unit_point X). Proof. use isapropdirprod ; use impred ; intro ; apply setproperty. Defined. Definition unit_binop_structure_disp_cat : disp_cat binop := sigma_disp_cat (disp_full_sub pointed_binop is_unit_point). Definition unit_binop_structure_cat : category := total_category unit_binop_structure_disp_cat. Definition is_univalent_structure_unit_binop : is_univalent unit_binop_structure_cat. Proof. use is_univalent_total_category. - apply binop. - apply is_univalent_disp_from_fibers. intros x xx yy. use isweqimplimpl. + intros f. use subtypePath. { intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty. } exact (pr11 f). + apply isapropifcontr. apply isaprop_has_unit. + use invproofirrelevance. intros f g. use subtypePath. { intro ; apply isaprop_is_z_iso_disp. } use subtypePath. { intro ; apply isapropunit. } apply setproperty. Defined. Definition unit_binop_structure : univalent_category. Proof. use make_univalent_category. - exact unit_binop_structure_cat. - exact is_univalent_structure_unit_binop. Defined. (** We finish by arguing that the unit is indeed added structure for this construction. To do so, we prove that the forgetful functor is faithful. *) Definition forget_unit_structure_faithful : adds_structure unit_binop_structure_disp_cat. Proof. intros m₁ m₂ f. apply pr1_category_faithful. intro ; intros ; simpl. use (@isaprop_total2 (make_hProp _ _) (λ _, make_hProp _ _)). - apply setproperty. - apply isapropunit. Defined. (** We can also show that this forgetful functor isn't full. This is because not every homomorphism between sets with binary operations preserve the unit element. For that, we use the following example. *) Definition nat_unit_binop_structure : unit_binop_structure. Proof. simple refine ((natset ,, _) ,, _ ,, _) ; cbn. - exact (λ n, pr1 n + pr2 n). - exact 0. - split ; cbn. + apply natplusr0. + apply natplusl0. Defined. Definition bool_unit_binop_structure : unit_binop_structure. Proof. simple refine ((boolset ,, _) ,, _ ,, _) ; cbn. - exact (λ b, orb (pr1 b) (pr2 b)). - exact false. - split ; cbn ; intro x ; induction x ; apply idpath. Defined. Definition nat_to_bool : nat → bool := λ _, true. Definition nat_plus_to_bool_or : pr1_category _ nat_unit_binop_structure --> pr1_category _ bool_unit_binop_structure. Proof. refine (nat_to_bool ,, _). use funextsec. intro x ; apply idpath. Defined. Definition unit_binop_structure_disp_cat_not_adds_properties : ¬(adds_properties unit_binop_structure_disp_cat). Proof. intros H. induction H as [H₁ H₂]. clear H₂. specialize (H₁ _ _ nat_plus_to_bool_or). revert H₁. use (@hinhuniv _ hfalse). intros H ; cbn. pose (pr121 H) as p. cbn in p. pose (eqtohomot (maponpaths pr1 (pr2 H)) 0) as q. cbn in q. pose (!q @ p) as r. unfold nat_to_bool in r. exact (nopathstruetofalse r). Qed. (** Now let us look at the hlevels of the displayed objects and morphisms of this displayed category. More specifically, both the type of displayed objects and the type of displayed morphisms form propositions. *) Definition unit_binop_structure_disp_cat_mor_prop : locally_propositional unit_binop_structure_disp_cat. Proof. apply disp_cat_is_locally_propositional. apply forget_unit_structure_faithful. Defined. Definition unit_binop_structure_disp_cat_mor_not_contr : ¬(locally_contractible unit_binop_structure_disp_cat). Proof. intro H. apply unit_binop_structure_disp_cat_not_adds_properties. apply pr1_category_fully_faithful. exact H. Defined. Definition unit_binop_structure_disp_cat_ob_prop (X : binop) : isaprop (unit_binop_structure_disp_cat X). Proof. apply isaprop_has_unit. Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Fiber.v000066400000000000000000000271631451125700300236040ustar00rootroot00000000000000 Require Import UniMath.Foundations.PartA. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Local Open Scope mor_disp. (** * Fiber categories *) (** A displayed category gives a _fiber_ category over each object of the base. These are most interesting in the case where the displayed category is an isofibration. *) Section Fiber. Context {C : category} (D : disp_cat C) (c : C). Definition fiber_category_data : precategory_data. Proof. use tpair. - use tpair. + apply (ob_disp D c). + intros xx xx'. apply (mor_disp xx xx' (identity c)). - use tpair. + intros. apply id_disp. + cbn. intros. apply (transportf _ (id_right _ ) (comp_disp X X0)). Defined. Lemma fiber_is_precategory : is_precategory fiber_category_data. Proof. apply is_precategory_one_assoc_to_two. repeat split; intros; cbn. - etrans. apply maponpaths. apply id_left_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply (homset_property). apply idpath. - etrans. apply maponpaths. apply id_right_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply (homset_property). apply idpath. - etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp. etrans. apply transport_f_f. apply pathsinv0. etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition fiber_precategory : precategory := ( _ ,, fiber_is_precategory). Lemma has_homsets_fiber_category : has_homsets fiber_precategory. Proof. intros x y. apply homsets_disp. Qed. Definition fiber_category : category := ( fiber_precategory ,, has_homsets_fiber_category). Definition z_iso_disp_from_z_iso_fiber (a b : fiber_category) : z_iso a b -> z_iso_disp (identity_z_iso c) a b. Proof. intro i. use tpair. + apply (pr1 i). + cbn. use tpair. * apply (inv_from_z_iso i). * abstract ( split; [ assert (XR := z_iso_after_z_iso_inv i); cbn in *; assert (XR' := transportf_pathsinv0' _ _ _ _ XR); etrans; [ apply (!XR') |]; unfold transportb; apply maponpaths_2; apply homset_property |assert (XR := z_iso_inv_after_z_iso i); cbn in *; assert (XR' := transportf_pathsinv0' _ _ _ _ XR); etrans; [ apply (!XR') | ]; unfold transportb; apply maponpaths_2; apply homset_property ] ). Defined. Definition z_iso_fiber_from_z_iso_disp (a b : fiber_category) : z_iso a b <- z_iso_disp (identity_z_iso c) a b. Proof. intro i. use tpair. + apply (pr1 i). + cbn in *. use tpair. apply (inv_mor_disp_from_z_iso i). abstract (split; cbn; [ assert (XR := inv_mor_after_z_iso_disp i); etrans; [ apply maponpaths , XR |]; etrans; [ apply transport_f_f |]; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath | assert (XR := z_iso_disp_after_inv_mor i); etrans; [ apply maponpaths , XR |] ; etrans; [ apply transport_f_f |]; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath ]). Defined. Lemma z_iso_disp_z_iso_fiber (a b : fiber_category) : z_iso a b ≃ z_iso_disp (identity_z_iso c) a b. Proof. exists (z_iso_disp_from_z_iso_fiber a b). use (isweq_iso _ (z_iso_fiber_from_z_iso_disp _ _ )). - intro. apply z_iso_eq. apply idpath. - intro. apply eq_z_iso_disp. apply idpath. Defined. (** ** Univalence *) Variable H : is_univalent_disp D. Let idto1 (a b : fiber_category) : a = b ≃ z_iso_disp (identity_z_iso c) a b := make_weq (@idtoiso_fiber_disp _ _ _ a b) (H _ _ (idpath _ ) a b). Let idto2 (a b : fiber_category) : a = b -> z_iso_disp (identity_z_iso c) a b := funcomp (λ p : a = b, idtoiso p) (z_iso_disp_z_iso_fiber a b). Lemma eq_idto1_idto2 (a b : fiber_category) : ∏ p : a = b, idto1 _ _ p = idto2 _ _ p. Proof. intro p. induction p. apply eq_z_iso_disp. apply idpath. Qed. Lemma is_univalent_fiber_cat (a b : fiber_category) : isweq (λ p : a = b, idtoiso p). Proof. use (twooutof3a _ (z_iso_disp_z_iso_fiber a b)). - use (isweqhomot (idto1 a b)). + intro p. apply eq_idto1_idto2. + apply weqproperty. - apply weqproperty. Defined. Lemma is_univalent_fiber : is_univalent fiber_category. Proof. intros a b. apply is_univalent_fiber_cat. Defined. End Fiber. Arguments fiber_precategory {_} _ _ . Arguments fiber_category {_} _ _ . (* TODO: is this a terrible notation? Probably. *) Notation "D [{ x }]" := (fiber_category D x)(at level 3,format "D [{ x }]"). Section UnivalentFiber. Lemma is_univalent_disp_from_is_univalent_fiber {C : category} (D : disp_cat C) : (∏ (c : C), is_univalent D[{c}]) → is_univalent_disp D. Proof. intro H. apply is_univalent_disp_from_fibers. intros c xx xx'. specialize (H c). set (w := make_weq _ (H xx xx')). set (w' := weqcomp w (z_iso_disp_z_iso_fiber D _ xx xx')). apply (weqhomot _ w'). intro e. induction e. apply eq_z_iso_disp. apply idpath. Defined. Definition is_univalent_disp_iff_fibers_are_univalent {C : category} (D : disp_cat C) : is_univalent_disp D <-> (∏ (c : C), is_univalent D[{c}]). Proof. split; intro H. - intro. apply is_univalent_fiber. apply H. - apply is_univalent_disp_from_is_univalent_fiber. apply H. Defined. End UnivalentFiber. Definition univalent_fiber_category {C : category} (D : disp_univalent_category C) (c : C) : univalent_category. Proof. refine (D [{ c }] ,, _). apply is_univalent_fiber. exact (pr2 D). Defined. Proposition idtoiso_fiber_category {C : category} {D : disp_cat C} {x : C} {xx yy : D x} (p : xx = yy) : pr1 (@idtoiso (D [{ x }]) xx yy p) = pr1 (@idtoiso_disp C D x x (idpath x) xx yy p). Proof. induction p ; cbn. apply idpath. Qed. (** ** Fiber functors Functors between displayed categories induce functors between their fibers. *) Section Fiber_Functors. Local Open Scope mor_disp. Section fix_context. Context {C C' : category} {D} {D'} {F : functor C C'} (FF : disp_functor F D D') (x : C). Definition fiber_functor_data : functor_data D[{x}] D'[{F x}]. Proof. use tpair. - apply (λ xx', FF xx'). - intros xx' xx ff. apply (transportf _ (functor_id _ _ ) (♯ FF ff)). Defined. Lemma is_functor_fiber_functor : is_functor fiber_functor_data. Proof. split; unfold functor_idax, functor_compax; cbn. - intros. apply transportf_pathsinv0. apply pathsinv0. apply disp_functor_id. - intros. etrans. apply maponpaths. apply disp_functor_transportf. etrans. apply transport_f_f. etrans. apply maponpaths. apply disp_functor_comp. etrans. apply transport_f_f. apply pathsinv0. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. apply maponpaths_2, homset_property. Qed. Definition fiber_functor : functor D[{x}] D'[{F x}] := ( _ ,, is_functor_fiber_functor). End fix_context. (* TODO: consider lemma organisation in this file *) Definition is_z_iso_fiber_from_is_z_iso_disp {C : category} {D : disp_cat C} {c : C} {d d' : D c} (ff : d -->[identity c] d') (Hff : is_z_iso_disp (identity_z_iso c) ff) : @is_z_isomorphism (fiber_category D c) _ _ ff. Proof. exists (pr1 Hff). use tpair; cbn. + set (H := pr2 (pr2 Hff)). etrans. apply maponpaths, H. etrans. apply transport_f_b. use (@maponpaths_2 _ _ _ _ _ (paths_refl _)). apply homset_property. + set (H := pr1 (pr2 Hff)). etrans. apply maponpaths, H. etrans. apply transport_f_b. use (@maponpaths_2 _ _ _ _ _ (paths_refl _)). apply homset_property. Qed. Definition fiber_nat_trans {C C' : category} {F : functor C C'} {D D'} {FF FF' : disp_functor F D D'} (α : disp_nat_trans (nat_trans_id F) FF FF') (c : C) : nat_trans (fiber_functor FF c) (fiber_functor FF' c). Proof. use tpair; simpl. - intro d. exact (α c d). - unfold is_nat_trans; intros d d' ff; simpl. set (αff := pr2 α _ _ _ _ _ ff); simpl in αff. cbn. etrans. apply maponpaths, mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths, αff. etrans. apply transport_f_b. apply @pathsinv0. etrans. apply maponpaths, mor_disp_transportf_prewhisker. etrans. apply transport_f_f. apply maponpaths_2, homset_property. Defined. Lemma fiber_functor_ff {C C' : category} {D} {D'} {F : functor C C'} (FF : disp_functor F D D') (H : disp_functor_ff FF) (c : C) : fully_faithful (fiber_functor FF c). Proof. intros xx yy; cbn. set (XR := H _ _ xx yy (identity _ )). apply twooutof3c. - apply XR. - apply isweqtransportf. Defined. End Fiber_Functors. (** Fiber fucntor of the identity and the composition *) Definition fiber_functor_identity {C : category} (D : disp_cat C) (x : C) : nat_z_iso (functor_identity _) (fiber_functor (disp_functor_identity D) x). Proof. use make_nat_z_iso. - use make_nat_trans. + exact (λ _, identity _). + intros xx yy ff ; cbn. rewrite id_right_disp. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros xx. apply (@is_z_isomorphism_identity (fiber_category D x)). Defined. Definition fiber_functor_comp {C : category} {D₁ D₂ D₃ : disp_cat C} (F : disp_functor (functor_identity C) D₁ D₂) (G : disp_functor (functor_identity C) D₂ D₃) (x : C) : nat_z_iso (fiber_functor F x ∙ fiber_functor G x) (fiber_functor (disp_functor_over_id_composite F G) x). Proof. use make_nat_z_iso. - use make_nat_trans. + exact (λ _, identity _). + intros xx yy ff ; cbn. rewrite id_right_disp. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros xx. apply (@is_z_isomorphism_identity (fiber_category _ x)). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Fibrations.v000066400000000000000000002611241451125700300246520ustar00rootroot00000000000000(** Definitions of various kinds of _fibrations_, using displayed categories. *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite. Local Open Scope type_scope. Local Open Scope mor_disp_scope. (* Local Open Scope hide_transport_scope. *) (** Fibratons, opfibrations, and isofibrations are all displayed categories with extra lifting conditions. Classically, these lifting conditions are usually taken by default as mere existence conditions; when they are given by operations, one speaks of a _cloven_ fibration, etc. We make the cloven version the default, so [is_fibration] etc are the cloven notions, and call the mere-existence versions _un-cloven_. (This conventional is provisional and and might change in future.) *) (** * Isofibrations *) (** The easiest to define are _isofibrations_, since they do not depend on a definition of (co-)cartesian-ness (because all displayed isomorphisms are cartesian). *) Section Isofibrations. (** Given an iso φ : c' =~ c in C, and an object d in D c, there’s some object d' in D c', and an iso φbar : d' =~ d over φ. *) Definition iso_cleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (i : z_iso c' c) (d : D c), ∑ d' : D c', z_iso_disp i d' d. Definition iso_fibration (C : category) : UU := ∑ D : disp_cat C, iso_cleaving D. Definition is_uncloven_iso_cleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (i : z_iso c' c) (d : D c), ∃ d' : D c', z_iso_disp i d' d. Definition weak_iso_fibration (C : category) : UU := ∑ D : disp_cat C, is_uncloven_iso_cleaving D. (** As with fibrations, there is an evident dual version. However, in the iso case, it is self-dual: having forward (i.e. cocartesian) liftings along isos is equivalent to having backward (cartesian) liftings. *) Definition is_op_isofibration {C : category} (D : disp_cat C) : UU := forall (c c' : C) (i : z_iso c c') (d : D c), ∑ d' : D c', z_iso_disp i d d'. Lemma is_isofibration_iff_is_op_isofibration {C : category} (D : disp_cat C) : iso_cleaving D <-> is_op_isofibration D. Proof. (* TODO: give this! *) Abort. End Isofibrations. (** * Fibrations *) Section Fibrations. Definition is_cartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : UU := forall c'' (g : c'' --> c') (d'' : D c'') (hh : d'' -->[g·f] d), ∃! (gg : d'' -->[g] d'), gg ;; ff = hh. (** See also [cartesian_factorisation'] below, for when the map one wishes to factor is not judgementally over [g;;f], but over some equal map. *) Definition cartesian_factorisation {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c''} (g : c'' --> c') {d'' : D c''} (hh : d'' -->[g·f] d) : d'' -->[g] d' := pr1 (pr1 (H _ g _ hh)). Definition cartesian_factorisation_commutes {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c''} (g : c'' --> c') {d'' : D c''} (hh : d'' -->[g·f] d) : cartesian_factorisation H g hh ;; ff = hh := pr2 (pr1 (H _ g _ hh)). (** While [cartesian_factorisation_commutes] shows that composition with and factorisation through a cartesian morphism are one-sided inverses in one direction, the following shows the other direction. **) Definition cartesian_factorisation_of_composite {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c'' : C} {g : c'' --> c'} {d'' : D c''} (gg : d'' -->[g] d') : gg = cartesian_factorisation H g (gg ;; ff). Proof. exact (maponpaths pr1 (pr2 (H _ _ _ _) (_,, idpath _))). Defined. (** This is essentially the third access function for [is_cartesian], but given in a more usable form than [pr2 (H …)] would be. *) Definition cartesian_factorisation_unique {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c''} {g : c'' --> c'} {d'' : D c''} (gg gg' : d'' -->[g] d') : (gg ;; ff = gg' ;; ff) -> gg = gg'. Proof. intro Hggff. eapply pathscomp0. apply (cartesian_factorisation_of_composite H). eapply pathscomp0. apply maponpaths, Hggff. apply pathsinv0, cartesian_factorisation_of_composite. Qed. Definition cartesian_factorisation' {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c''} (g : c'' --> c') {h : c'' --> c} {d'' : D c''} (hh : d'' -->[h] d) (e : (g · f = h)) : d'' -->[g] d'. Proof. use (cartesian_factorisation H g). exact (transportb _ e hh). Defined. Definition cartesian_factorisation_commutes' {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_cartesian ff) {c''} (g : c'' --> c') {h : c'' --> c} {d'' : D c''} (hh : d'' -->[h] d) (e : (g · f = h)) : (cartesian_factorisation' H g hh e) ;; ff = transportb _ e hh. Proof. apply cartesian_factorisation_commutes. Qed. Definition cartesian_lift {C : category} {D : disp_cat C} {c} (d : D c) {c' : C} (f : c' --> c) : UU := ∑ (d' : D c') (ff : d' -->[f] d), is_cartesian ff. Definition object_of_cartesian_lift {C : category} {D : disp_cat C} {c} (d : D c) {c' : C} (f : c' --> c) (fd : cartesian_lift d f) : D c' := pr1 fd. Coercion object_of_cartesian_lift : cartesian_lift >-> ob_disp. Definition mor_disp_of_cartesian_lift {C : category} {D : disp_cat C} {c} (d : D c) {c' : C} (f : c' --> c) (fd : cartesian_lift d f) : (fd : D c') -->[f] d := pr1 (pr2 fd). Coercion mor_disp_of_cartesian_lift : cartesian_lift >-> mor_disp. Definition cartesian_lift_is_cartesian {C : category} {D : disp_cat C} {c} (d : D c) {c' : C} (f : c' --> c) (fd : cartesian_lift d f) : is_cartesian fd := pr2 (pr2 fd). Coercion cartesian_lift_is_cartesian : cartesian_lift >-> is_cartesian. Definition is_cartesian_disp_functor {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') : UU := ∏ (c c' : C) (f : c' --> c) (d : D c) (d' : D c') (ff : d' -->[f] d), is_cartesian ff -> is_cartesian (♯ FF ff). Definition disp_functor_identity_is_cartesian_disp_functor {C : category} (D : disp_cat C) : is_cartesian_disp_functor (disp_functor_identity D). Proof. intros x y f xx yy ff Hff. exact Hff. Defined. Definition disp_functor_composite_is_cartesian_disp_functor {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {D₃ : disp_cat C₃} {FF : disp_functor F D₁ D₂} {GG : disp_functor G D₂ D₃} (HFF : is_cartesian_disp_functor FF) (HGG : is_cartesian_disp_functor GG) : is_cartesian_disp_functor (disp_functor_composite FF GG). Proof. intros x y f xx yy ff Hff. apply HGG. apply HFF. exact Hff. Defined. Definition disp_functor_over_id_composite_is_cartesian {C : category} {D₁ D₂ D₃ : disp_cat C} {FF : disp_functor (functor_identity C) D₁ D₂} {GG : disp_functor (functor_identity C) D₂ D₃} (HFF : is_cartesian_disp_functor FF) (HGG : is_cartesian_disp_functor GG) : is_cartesian_disp_functor (disp_functor_over_id_composite FF GG). Proof. intros x y f xx yy ff Hff. apply HGG. apply HFF. exact Hff. Defined. Definition cartesian_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D₁ : disp_cat C₁) (D₂ : disp_cat C₂) : UU := ∑ (FF : disp_functor F D₁ D₂), is_cartesian_disp_functor FF. Coercion disp_functor_of_cartesian_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : cartesian_disp_functor F D₁ D₂) : disp_functor F D₁ D₂ := pr1 FF. Definition cartesian_disp_functor_is_cartesian {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : cartesian_disp_functor F D₁ D₂) : is_cartesian_disp_functor FF := pr2 FF. Definition cartesian_disp_functor_on_cartesian {C : category} {D₁ D₂ : disp_cat C} (F : cartesian_disp_functor (functor_identity C) D₁ D₂) {x y : C} {f : x --> y} {xx : D₁ x} {yy : D₁ y} {ff : xx -->[ f ] yy} (Hff : is_cartesian ff) : is_cartesian (♯ F ff) := pr2 F y x f yy xx ff Hff. Lemma isaprop_is_cartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : isaprop (is_cartesian ff). Proof. repeat (apply impred_isaprop; intro). apply isapropiscontr. Defined. Proposition isaprop_is_cartesian_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : isaprop (is_cartesian_disp_functor FF). Proof. do 7 (use impred ; intro). apply isaprop_is_cartesian. Qed. (* TODO: should the arguments be re-ordered as in [cartesian_lift]? If so, reorder in [isofibration] etc as well, for consistency. *) (* TODO: consider renaming to e.g. [cleaving] to follow convention that [is_] is reserved for hprops. *) Definition cleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (f : c' --> c) (d : D c), cartesian_lift d f. (** ** (Cloven) fibration *) Definition fibration (C : category) : UU := ∑ D : disp_cat C, cleaving D. (** ** Weak fibration *) (* TODO: give access functions! *) Definition is_cleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (f : c' --> c) (d : D c), ∥ cartesian_lift d f ∥. Definition weak_fibration (C : category) : UU := ∑ D : disp_cat C, is_cleaving D. (** ** Connection with isofibrations *) Lemma is_z_iso_from_is_cartesian {C : category} {D : disp_cat C} {c c' : C} (i : z_iso c' c) {d : D c} {d'} (ff : d' -->[i] d) : is_cartesian ff -> is_z_iso_disp i ff. Proof. intros Hff. use (_,,_); try split. - use (cartesian_factorisation' Hff (inv_from_z_iso i) (id_disp _)). apply z_iso_after_z_iso_inv. - apply cartesian_factorisation_commutes'. - apply (cartesian_factorisation_unique Hff). etrans. apply assoc_disp_var. rewrite cartesian_factorisation_commutes'. etrans. eapply transportf_bind. etrans. apply mor_disp_transportf_prewhisker. eapply transportf_bind, id_right_disp. apply pathsinv0. etrans. apply mor_disp_transportf_postwhisker. etrans. eapply transportf_bind, id_left_disp. apply maponpaths_2, homset_property. Qed. Lemma is_isofibration_from_is_fibration {C : category} {D : disp_cat C} : cleaving D -> iso_cleaving D. Proof. intros D_fib c c' f d. assert (fd := D_fib _ _ f d). exists (fd : D _). exists (fd : _ -->[_] _). apply is_z_iso_from_is_cartesian; exact fd. Defined. (** ** Uniqueness of cartesian lifts *) (* TODO: show that when [D] is _univalent_, cartesian lifts are literally unique, and so any uncloven fibration (isofibration, etc) is in fact cloven. *) Definition cartesian_lifts_iso {C : category} {D : disp_cat C} {c} {d : D c} {c' : C} {f : c' --> c} (fd fd' : cartesian_lift d f) : z_iso_disp (identity_z_iso c') fd fd'. Proof. use (_,,(_,,_)). - exact (cartesian_factorisation' fd' (identity _) fd (id_left _)). - exact (cartesian_factorisation' fd (identity _) fd' (id_left _)). - cbn; split. + apply (cartesian_factorisation_unique fd'). etrans. apply assoc_disp_var. rewrite cartesian_factorisation_commutes'. etrans. eapply transportf_bind, mor_disp_transportf_prewhisker. rewrite cartesian_factorisation_commutes'. etrans. apply transport_f_f. apply pathsinv0. etrans. apply mor_disp_transportf_postwhisker. rewrite id_left_disp. etrans. apply transport_f_f. apply maponpaths_2, homset_property. + apply (cartesian_factorisation_unique fd). etrans. apply assoc_disp_var. rewrite cartesian_factorisation_commutes'. etrans. eapply transportf_bind, mor_disp_transportf_prewhisker. rewrite cartesian_factorisation_commutes'. etrans. apply transport_f_f. apply pathsinv0. etrans. apply mor_disp_transportf_postwhisker. rewrite id_left_disp. etrans. apply transport_f_f. apply maponpaths_2, homset_property. Defined. Definition cartesian_lifts_iso_commutes {C : category} {D : disp_cat C} {c} {d : D c} {c' : C} {f : c' --> c} (fd fd' : cartesian_lift d f) : (cartesian_lifts_iso fd fd') ;; fd' = transportb _ (id_left _) (fd : _ -->[_] _). Proof. cbn. apply cartesian_factorisation_commutes'. Qed. (** In a displayed _category_ (i.e. _univalent_), cartesian lifts are literally unique, if they exist; that is, the type of cartesian lifts is always a proposition. *) Definition isaprop_cartesian_lifts {C : category} {D : disp_cat C} (D_cat : is_univalent_disp D) {c} (d : D c) {c' : C} (f : c' --> c) : isaprop (cartesian_lift d f). Proof. apply invproofirrelevance; intros fd fd'. use total2_paths_f. { apply (isotoid_disp D_cat (idpath _)); cbn. apply cartesian_lifts_iso. } apply subtypePath. { intros ff. repeat (apply impred; intro). apply isapropiscontr. } etrans. { exact (! transport_map (λ x:D c', pr1) _ _). } cbn. etrans. apply transportf_precompose_disp. rewrite idtoiso_isotoid_disp. use (pathscomp0 (maponpaths _ _) (transportfbinv _ _ _)). apply (precomp_with_z_iso_disp_is_inj (cartesian_lifts_iso fd fd')). etrans. apply assoc_disp. etrans. eapply transportf_bind, cancel_postcomposition_disp. use inv_mor_after_z_iso_disp. etrans. eapply transportf_bind, id_left_disp. apply pathsinv0. etrans. apply mor_disp_transportf_prewhisker. etrans. eapply transportf_bind, cartesian_lifts_iso_commutes. apply maponpaths_2, homset_property. Defined. Definition univalent_fibration_is_cloven {C : category} {D : disp_cat C} (D_cat : is_univalent_disp D) : is_cleaving D -> cleaving D. Proof. intros D_fib c c' f d. apply (squash_to_prop (D_fib c c' f d)). apply isaprop_cartesian_lifts; assumption. auto. Defined. End Fibrations. Definition isaprop_cleaving {C : univalent_category} (D : disp_cat C) (HD : is_univalent_disp D) : isaprop (cleaving D). Proof. repeat (use impred ; intro). apply isaprop_cartesian_lifts. exact HD. Defined. Section Discrete_Fibrations. Definition is_discrete_fibration {C : category} (D : disp_cat C) : UU := (forall (c c' : C) (f : c' --> c) (d : D c), ∃! d' : D c', d' -->[f] d) × (forall c, isaset (D c)). Definition discrete_fibration C : UU := ∑ D : disp_cat C, is_discrete_fibration D. Coercion disp_cat_from_discrete_fibration C (D : discrete_fibration C) : disp_cat C := pr1 D. Definition unique_lift {C} {D : discrete_fibration C} {c c'} (f : c' --> c) (d : D c) : ∃! d' : D c', d' -->[f] d := pr1 (pr2 D) c c' f d. Definition isaset_fiber_discrete_fibration {C} (D : discrete_fibration C) (c : C) : isaset (D c) := pr2 (pr2 D) c. (** TODO: move upstream *) Lemma pair_inj {A : UU} {B : A -> UU} (is : isaset A) {a : A} {b b' : B a} : (a,,b) = (a,,b') -> b = b'. Proof. intro H. use (invmaponpathsincl _ _ _ _ H). apply isofhlevelffib. intro. apply is. Defined. Lemma disp_mor_unique_disc_fib C (D : discrete_fibration C) : ∏ (c c' : C) (f : c --> c') (d : D c) (d' : D c') (ff ff' : d -->[f] d'), ff = ff'. Proof. intros. assert (XR := unique_lift f d'). assert (foo : ((d,,ff) : ∑ d0, d0 -->[f] d') = (d,,ff')). { apply proofirrelevancecontr. apply XR. } apply (pair_inj (isaset_fiber_discrete_fibration _ _ ) foo). Defined. Lemma isaprop_disc_fib_hom C (D : discrete_fibration C) : ∏ (c c' : C) (f : c --> c') (d : D c) (d' : D c'), isaprop (d -->[f] d'). Proof. intros. apply invproofirrelevance. intros x x'. apply disp_mor_unique_disc_fib. Qed. Definition fibration_from_discrete_fibration C (D : discrete_fibration C) : cleaving D. Proof. intros c c' f d. use tpair. - exact (pr1 (iscontrpr1 (unique_lift f d))). - use tpair. + exact (pr2 (iscontrpr1 (unique_lift f d))). + intros c'' g db hh. set (ff := pr2 (iscontrpr1 (unique_lift f d)) ). cbn in ff. set (d' := pr1 (iscontrpr1 (unique_lift f d))) in *. set (ggff := pr2 (iscontrpr1 (unique_lift (g·f) d)) ). cbn in ggff. set (d'' := pr1 (iscontrpr1 (unique_lift (g·f) d))) in *. set (gg := pr2 (iscontrpr1 (unique_lift g d'))). cbn in gg. set (d3 := pr1 (iscontrpr1 (unique_lift g d'))) in *. assert (XR : ((d'',, ggff) : ∑ r, r -->[g·f] d) = (db,,hh)). { apply proofirrelevancecontr. apply (pr2 D). } assert (XR1 : ((d'',, ggff) : ∑ r, r -->[g·f] d) = (d3 ,,gg;;ff)). { apply proofirrelevancecontr. apply (pr2 D). } assert (XT := maponpaths pr1 XR). cbn in XT. assert (XT1 := maponpaths pr1 XR1). cbn in XT1. generalize XR. generalize XR1; clear XR1. destruct XT. generalize gg; clear gg. destruct XT1. intros gg XR1 XR0. apply iscontraprop1. * apply invproofirrelevance. intros x x'. apply subtypePath. { intro. apply homsets_disp. } apply disp_mor_unique_disc_fib. * exists gg. cbn. assert (XX := pair_inj (isaset_fiber_discrete_fibration _ _ ) XR1). assert (YY := pair_inj (isaset_fiber_discrete_fibration _ _ ) XR0). etrans. apply (!XX). apply YY. Defined. Section Equivalence_disc_fibs_presheaves. (* GOAL: correspondence between discrete fibrations and presheaves. Outline via categories: - show that the fibers of a discrete fibration are (discrete categories on) sets, and that the disp morphism types are props; - define the category of discrete fibrations over C, using [disp_functor_id] for morphisms, and with [homset_property] coming from the previous point; - construct equivalence of cats; probably easiest by explicit functors and natural isos (not by “ess split” plus “full and faithful”); - show [disc_fib_precat C] is univalent (possibly _using_ the above equivalence of cats, to get “isos of displayed cats are weq to isos btn associated presheaves”?); - conclude equivalence of types. More direct equivalence of types: - ? *) Variable C : category. Definition precat_of_discrete_fibs_ob_mor : precategory_ob_mor. Proof. exists (discrete_fibration C). intros a b. exact (disp_functor (functor_identity _ ) a b). Defined. Definition precat_of_discrete_fibs_data : precategory_data. Proof. exists precat_of_discrete_fibs_ob_mor. split. - intro. exact (@disp_functor_identity _ _ ). - intros ? ? ? f g. exact (disp_functor_composite f g ). Defined. Lemma eq_discrete_fib_mor (F G : precat_of_discrete_fibs_ob_mor) (a b : F --> G) (H : ∏ x y, pr1 (pr1 a) x y = pr1 (pr1 b) x y) : a = b. Proof. apply subtypePath. { intro. apply isaprop_disp_functor_axioms. } use total2_paths_f. - apply funextsec. intro x. apply funextsec. intro y. apply H. - repeat (apply funextsec; intro). apply disp_mor_unique_disc_fib. Qed. Definition precat_axioms_of_discrete_fibs : is_precategory precat_of_discrete_fibs_data. Proof. repeat split; intros; apply eq_discrete_fib_mor; intros; apply idpath. Qed. Definition precat_of_discrete_fibs : precategory := (_ ,, precat_axioms_of_discrete_fibs). Lemma has_homsets_precat_of_discrete_fibs : has_homsets precat_of_discrete_fibs. Proof. intros f f'. apply (isofhleveltotal2 2). - apply (isofhleveltotal2 2). + do 2 (apply impred; intro). apply isaset_fiber_discrete_fibration. + intro. do 6 (apply impred; intro). apply homsets_disp. - intro. apply isasetaprop. apply isaprop_disp_functor_axioms. Qed. Definition Precat_of_discrete_fibs : category := ( precat_of_discrete_fibs ,, has_homsets_precat_of_discrete_fibs). (** ** Functor from discrete fibrations to presheaves *) (** *** Functor on objects *) (* TODO: split into data and properties *) Definition preshv_data_from_disc_fib_ob (D : discrete_fibration C) : functor_data C^op HSET_univalent_category. Proof. use tpair. + intro c. exists (D c). apply isaset_fiber_discrete_fibration. + intros c' c f x. cbn in *. exact (pr1 (iscontrpr1 (unique_lift f x))). Defined. Definition preshv_ax_from_disc_fib_ob (D : discrete_fibration C) : is_functor (preshv_data_from_disc_fib_ob D). Proof. split. + intro c; cbn. apply funextsec; intro x. simpl. apply pathsinv0. apply path_to_ctr. apply id_disp. + intros c c' c'' f g. cbn in *. apply funextsec; intro x. apply pathsinv0. apply path_to_ctr. eapply comp_disp. * apply (pr2 (iscontrpr1 (unique_lift g _))). * apply (pr2 (iscontrpr1 (unique_lift f _ ))). Qed. Definition preshv_from_disc_fib_ob (D : discrete_fibration C) : PreShv C := (_ ,, preshv_ax_from_disc_fib_ob D). (** *** Functor on morphisms *) Definition foo : functor_data Precat_of_discrete_fibs (PreShv C). Proof. exists preshv_from_disc_fib_ob. intros D D' a. use tpair. - intro c. simpl. exact (pr1 a c). - abstract ( intros x y f; cbn in *; apply funextsec; intro d; apply path_to_ctr; apply ♯a; apply (pr2 (iscontrpr1 (unique_lift f _ ))) ). Defined. (** *** Functor properties *) Definition bar : is_functor foo. Proof. split. - intro D. apply nat_trans_eq. { apply has_homsets_HSET. } intro c . apply idpath. - intros D E F a b. apply nat_trans_eq. { apply has_homsets_HSET. } intro c. apply idpath. Qed. Definition functor_Disc_Fibs_to_preShvs : functor _ _ := ( _ ,, bar). (** ** Functor from presheaves to discrete fibrations *) (** *** Functor on objects *) (* TODO: split into data and properties *) Definition disp_cat_from_preshv (D : PreShv C) : disp_cat C. Proof. use tpair. - use tpair. + exists (λ c, pr1hSet (pr1 D c)). intros x y c d f. exact (functor_on_morphisms (pr1 D) f d = c). + split. * intros; cbn in *; apply (toforallpaths _ _ _ (functor_id D x ) _ ). * intros ? ? ? ? ? ? ? ? X X0; cbn in *; etrans; [apply (toforallpaths _ _ _ (functor_comp D g f ) _ ) |]; cbn; etrans; [ apply maponpaths; apply X0 |]; (* here maponpaths depends on cbn *) apply X. - abstract ( repeat use tpair; cbn; intros; try apply setproperty; apply isasetaprop; apply setproperty ). Defined. Definition disc_fib_from_preshv (D : PreShv C) : discrete_fibration C. Proof. use tpair. - apply (disp_cat_from_preshv D). - cbn. split. + intros c c' f d. simpl. use unique_exists. * apply (functor_on_morphisms (pr1 D) f d). * apply idpath. * intro. apply setproperty. * intros. apply pathsinv0. assumption. + intro. simpl. apply setproperty. Defined. (** *** Functor on morphisms *) Definition functor_data_preShv_Disc_fibs : functor_data (PreShv C) Precat_of_discrete_fibs. Proof. use tpair. - apply disc_fib_from_preshv. - intros F G a. use tpair. + use tpair. * intros c. apply (pr1 a c). * intros x y X Y f H; assert (XR := nat_trans_ax a); apply pathsinv0; etrans; [|apply (toforallpaths _ _ _ (XR _ _ f))]; cbn; apply maponpaths, (!H). + cbn. abstract (repeat use tpair; cbn; intros; apply setproperty). Defined. (** *** Functor properties *) Definition is_functor_functor_data_preShv_Disc_fibs : is_functor functor_data_preShv_Disc_fibs . Proof. split; unfold functor_idax, functor_compax; intros; apply eq_discrete_fib_mor; intros; apply idpath. Qed. Definition functor_preShvs_to_Disc_Fibs : functor _ _ := ( _ ,, is_functor_functor_data_preShv_Disc_fibs ). Definition η_disc_fib : nat_trans (functor_identity _ ) (functor_preShvs_to_Disc_Fibs ∙ functor_Disc_Fibs_to_preShvs). Proof. use tpair. - intro F. cbn. use tpair. + red. cbn. intro c; apply idfun. + intros c c' f. cbn in *. apply idpath. - abstract ( intros F G a; apply nat_trans_eq; [ apply has_homsets_HSET |]; intro c ; apply idpath ). Defined. Definition ε_disc_fib : nat_trans (functor_Disc_Fibs_to_preShvs ∙ functor_preShvs_to_Disc_Fibs) (functor_identity _ ). Proof. use tpair. - intro D. use tpair. + use tpair. * cbn. intro c; apply idfun. * cbn. intros c c' x y f H. set (XR := pr2 (iscontrpr1 (unique_lift f y))). cbn in XR. apply (transportf (λ t, t -->[f] y) H XR). + abstract (split; cbn; intros; apply disp_mor_unique_disc_fib). - abstract (intros c c' f; apply eq_discrete_fib_mor; intros; apply idpath). Defined. Definition ε_inv_disc_fib : nat_trans (functor_identity _ ) (functor_Disc_Fibs_to_preShvs ∙ functor_preShvs_to_Disc_Fibs). Proof. use tpair. - intro D. cbn. use tpair. + use tpair. * cbn. intro c; apply idfun. * abstract ( intros c c' x y f H; cbn; apply pathsinv0; apply path_to_ctr; apply H ). + abstract ( split; [ intros x y; apply isaset_fiber_discrete_fibration |]; intros; apply isaset_fiber_discrete_fibration ). - abstract (intros c c' f; apply eq_discrete_fib_mor; intros; apply idpath). Defined. Definition adjunction_data_disc_fib : adjunction_data (PreShv C) Precat_of_discrete_fibs. Proof. exists functor_preShvs_to_Disc_Fibs. exists functor_Disc_Fibs_to_preShvs. exists η_disc_fib. exact ε_disc_fib. Defined. Lemma forms_equivalence_disc_fib : forms_equivalence adjunction_data_disc_fib. Proof. split. - intro F. apply nat_trafo_z_iso_if_pointwise_z_iso. intro c. cbn. set (XR := hset_equiv_is_z_iso _ _ (idweq (pr1 F c : hSet) )). apply XR. - intro F. use (_ ,, (_,,_ )). + apply ε_inv_disc_fib. + apply eq_discrete_fib_mor. intros. apply idpath. + apply eq_discrete_fib_mor. intros. apply idpath. Qed. Definition adj_equivalence_disc_fib : adj_equivalence_of_cats _ := adjointification (_ ,, forms_equivalence_disc_fib). End Equivalence_disc_fibs_presheaves. End Discrete_Fibrations. (** The notion of an opcartesian morphism *) Section Opcartesian. Context {C : category} {D : disp_cat C}. Definition is_opcartesian {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} (ff : cc₁ -->[ f ] cc₂) : UU := ∏ (c₃ : C) (cc₃ : D c₃) (g : c₂ --> c₃) (hh : cc₁ -->[ f · g ] cc₃), ∃! (gg : cc₂ -->[ g ] cc₃), ff ;; gg = hh. Section ProjectionsOpcartesian. Context {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} {ff : cc₁ -->[ f ] cc₂} (Hff : is_opcartesian ff) {c₃ : C} {cc₃ : D c₃} (g : c₂ --> c₃) (hh : cc₁ -->[ f · g ] cc₃). Definition opcartesian_factorisation : cc₂ -->[ g ] cc₃ := pr11 (Hff c₃ cc₃ g hh). Definition opcartesian_factorisation_commutes : ff ;; opcartesian_factorisation = hh := pr21 (Hff c₃ cc₃ g hh). Definition opcartesian_factorisation_unique (gg₁ gg₂ : cc₂ -->[ g ] cc₃) (H : ff ;; gg₁ = ff ;; gg₂) : gg₁ = gg₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hff c₃ cc₃ g (ff ;; gg₁))) (gg₁ ,, idpath _) (gg₂ ,, !H))). Qed. End ProjectionsOpcartesian. End Opcartesian. (** Opcartesian morphism *) Definition is_cartesian_weq_is_opcartesian {C : category} {D : disp_cat C} {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} (ff : cc₁ -->[ f ] cc₂) : is_cartesian ff ≃ @is_opcartesian _ (op_disp_cat D) _ _ _ _ _ ff. Proof. use make_weq. - exact (λ Hff c₃ cc₃ g hh, Hff c₃ g cc₃ hh). - use isweq_iso. + exact (λ Hff c₃ cc₃ g hh, Hff c₃ g cc₃ hh). + intro ; apply idpath. + intro ; apply idpath. Defined. Definition is_opcartesian_weq_is_cartesian {C : category} {D : disp_cat C} {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} (ff : cc₁ -->[ f ] cc₂) : is_opcartesian ff ≃ @is_cartesian _ (op_disp_cat D) _ _ _ _ _ ff. Proof. use make_weq. - exact (λ Hff c₃ cc₃ g hh, Hff c₃ g cc₃ hh). - use isweq_iso. + exact (λ Hff c₃ cc₃ g hh, Hff c₃ g cc₃ hh). + intro ; apply idpath. + intro ; apply idpath. Defined. Definition is_cartesian_to_is_opcartesian {C : category} {D : disp_cat C} {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} {ff : cc₁ -->[ f ] cc₂} (Hff : @is_cartesian _ (op_disp_cat D) _ _ _ _ _ ff) : is_opcartesian ff := invmap (is_opcartesian_weq_is_cartesian ff) Hff. Definition isaprop_is_opcartesian {C : category} {D : disp_cat C} {c₁ c₂ : C} {f : c₁ --> c₂} {cc₁ : D c₁} {cc₂ : D c₂} (ff : cc₁ -->[ f ] cc₂) : isaprop (is_opcartesian ff). Proof. apply (isofhlevelweqb 1 (is_opcartesian_weq_is_cartesian ff)). apply isaprop_is_cartesian. Qed. (** Opcleavings *) Section Opcleaving. Context {C : category} (D : disp_cat C). Definition opcartesian_lift {c₁ c₂ : C} (cc₁ : D c₁) (f : c₁ --> c₂) : UU := ∑ (cc₂ : D c₂) (ff : cc₁ -->[ f ] cc₂), is_opcartesian ff. Definition ob_of_opcartesian_lift {c₁ c₂ : C} {cc₁ : D c₁} {f : c₁ --> c₂} (ℓ : opcartesian_lift cc₁ f) : D c₂ := pr1 ℓ. Definition mor_of_opcartesian_lift {c₁ c₂ : C} {cc₁ : D c₁} {f : c₁ --> c₂} (ℓ : opcartesian_lift cc₁ f) : cc₁ -->[ f ] ob_of_opcartesian_lift ℓ := pr12 ℓ. Definition mor_of_opcartesian_lift_is_opcartesian {c₁ c₂ : C} {cc₁ : D c₁} {f : c₁ --> c₂} (ℓ : opcartesian_lift cc₁ f) : is_opcartesian (mor_of_opcartesian_lift ℓ) := pr22 ℓ. Definition opcleaving : UU := ∏ (c₁ c₂ : C) (cc₁ : D c₁) (f : c₁ --> c₂), opcartesian_lift cc₁ f. Definition is_opcleaving : UU := ∏ (c₁ c₂ : C) (cc₁ : D c₁) (f : c₁ --> c₂), ∥ opcartesian_lift cc₁ f ∥. End Opcleaving. Definition opcleaving_ob {C : category} {D : disp_cat C} (HD : opcleaving D) {c c' : C} (f : c --> c') (d : D c) : D c' := ob_of_opcartesian_lift _ (HD c c' d f). Definition opcleaving_mor {C : category} {D : disp_cat C} (HD : opcleaving D) {c c' : C} (f : c --> c') (d : D c) : d -->[ f ] opcleaving_ob HD f d := mor_of_opcartesian_lift _ (HD c c' d f). Definition cleaving_weq_opcleaving {C : category} (D : disp_cat C) : cleaving D ≃ @opcleaving _ (op_disp_cat D). Proof. use make_weq. - exact (λ HD c₁ c₂ cc₁ f, let ℓ := HD c₁ c₂ f cc₁ in (* TODO: see #1470 *) tpair (fun cc₂ => total2 (fun ff => @is_opcartesian _ _ _ _ _ cc₁ cc₂ ff)) (pr1 ℓ) (tpair (@is_opcartesian _ _ _ _ _ cc₁ ℓ) (pr12 ℓ) (pr1weq (is_cartesian_weq_is_opcartesian ℓ) ℓ))). - use isweq_iso. + refine (λ HD c₁ c₂ cc₁ f, let ℓ := HD c₁ c₂ f cc₁ in pr1 ℓ ,, pr12 ℓ ,, _). exact (invmap (is_cartesian_weq_is_opcartesian _) (pr22 ℓ)). + intro ; apply idpath. + intro ; apply idpath. Defined. Definition opcleaving_weq_cleaving {C : category} (D : disp_cat C) : opcleaving D ≃ @cleaving _ (op_disp_cat D). Proof. use make_weq. - exact (λ HD c₁ c₂ cc₁ f, let ℓ := HD c₁ c₂ f cc₁ in (* TODO: see #1470 *) tpair (fun d' => total2 (fun ff => @is_cartesian _ _ _ _ _ f d' ff)) (pr1 ℓ) (tpair (@is_cartesian _ _ _ _ _ f (pr1 ℓ)) (pr12 ℓ) (pr1weq (@is_opcartesian_weq_is_cartesian _ D _ _ _ _ _ (pr12 ℓ)) (pr22 ℓ)))). - use isweq_iso. + refine (λ HD c₁ c₂ cc₁ f, let ℓ := HD c₁ c₂ f cc₁ in pr1 ℓ ,, pr12 ℓ ,, _). exact (invmap (is_opcartesian_weq_is_cartesian _) (pr22 ℓ)). + intro ; apply idpath. + intro ; apply idpath. Defined. Definition isaprop_opcleaving {C : univalent_category} (D : disp_cat C) (HD : is_univalent_disp D) : isaprop (opcleaving D). Proof. use (isofhlevelweqb 1 (opcleaving_weq_cleaving D)). use (@isaprop_cleaving (op_unicat C) (op_disp_cat _) _). apply is_univalent_op_disp_cat. exact HD. Defined. (** Cloven opfibration *) Definition opfibration (C : category) : UU := ∑ (D : disp_cat C), opcleaving D. (** Weak opfibration *) Definition weak_opfibration (C : category) : UU := ∑ (D : disp_cat C), is_opcleaving D. Definition is_opcartesian_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D : disp_cat C₁} {D' : disp_cat C₂} (FF : disp_functor F D D') : UU := ∏ (c c' : C₁) (f : c' --> c) (d : D c) (d' : D c') (ff : d' -->[f] d), is_opcartesian ff -> is_opcartesian (♯ FF ff). Proposition isaprop_is_opcartesian_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : isaprop (is_opcartesian_disp_functor FF). Proof. do 7 (use impred ; intro). apply isaprop_is_opcartesian. Qed. Definition disp_functor_identity_is_opcartesian_disp_functor {C : category} (D : disp_cat C) : is_opcartesian_disp_functor (disp_functor_identity D). Proof. intros x y f xx yy ff Hff. exact Hff. Defined. Definition disp_functor_composite_is_opcartesian_disp_functor {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {D₃ : disp_cat C₃} {FF : disp_functor F D₁ D₂} {GG : disp_functor G D₂ D₃} (HFF : is_opcartesian_disp_functor FF) (HGG : is_opcartesian_disp_functor GG) : is_opcartesian_disp_functor (disp_functor_composite FF GG). Proof. intros x y f xx yy ff Hff. apply HGG. apply HFF. exact Hff. Defined. Definition disp_functor_over_id_composite_is_opcartesian {C : category} {D₁ D₂ D₃ : disp_cat C} {FF : disp_functor (functor_identity C) D₁ D₂} {GG : disp_functor (functor_identity C) D₂ D₃} (HFF : is_opcartesian_disp_functor FF) (HGG : is_opcartesian_disp_functor GG) : is_opcartesian_disp_functor (disp_functor_over_id_composite FF GG). Proof. intros x y f xx yy ff Hff. apply HGG. apply HFF. exact Hff. Defined. Definition opcartesian_disp_functor {C₁ C₂ : category} (F : C₁ ⟶ C₂) (D₁ : disp_cat C₁) (D₂ : disp_cat C₂) : UU := ∑ (FF : disp_functor F D₁ D₂), is_opcartesian_disp_functor FF. Coercion disp_functor_of_opcartesian_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : opcartesian_disp_functor F D₁ D₂) : disp_functor F D₁ D₂ := pr1 FF. Definition opcartesian_disp_functor_is_opcartesian {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : opcartesian_disp_functor F D₁ D₂) : is_opcartesian_disp_functor FF := pr2 FF. (** Opfibrations are isofibrations *) Section IsoCleavingFromOpcleaving. Context {C : category} (D : disp_cat C) (HD : opcleaving D). Section Lift. Context {x y : C} (f : z_iso x y) (d : D y). Definition z_iso_cleaving_from_opcleaving_ob : D x := opcleaving_ob HD (inv_from_z_iso f) d. Let ℓ : d -->[ inv_from_z_iso f ] z_iso_cleaving_from_opcleaving_ob := opcleaving_mor HD (inv_from_z_iso f) d. Let ℓ_opcart : is_opcartesian (pr12 (HD y x d (inv_from_z_iso f))) := pr22 (HD _ _ d (inv_from_z_iso f)). Definition z_iso_cleaving_from_opcleaving_ob_disp_iso_map : z_iso_cleaving_from_opcleaving_ob -->[ f ] d. Proof. use (opcartesian_factorisation ℓ_opcart). refine (transportb (λ z, _ -->[ z ] _) _ (id_disp d)). apply z_iso_after_z_iso_inv. Defined. Definition z_iso_cleaving_from_opcleaving_ob_disp_iso : z_iso_disp f z_iso_cleaving_from_opcleaving_ob d. Proof. use make_z_iso_disp. - exact z_iso_cleaving_from_opcleaving_ob_disp_iso_map. - simple refine (_ ,, _ ,, _). + exact ℓ. + abstract (apply opcartesian_factorisation_commutes). + abstract (apply (opcartesian_factorisation_unique ℓ_opcart) ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite assoc_disp ; unfold transportb ; etrans ; [ apply maponpaths ; apply maponpaths_2 ; apply (opcartesian_factorisation_commutes ℓ_opcart) | ] ; unfold transportb ; rewrite mor_disp_transportf_postwhisker ; rewrite id_left_disp, id_right_disp ; unfold transportb ; rewrite !transport_f_f ; apply maponpaths_2 ; apply homset_property). Defined. End Lift. Definition iso_cleaving_from_opcleaving : iso_cleaving D := λ x y f d, z_iso_cleaving_from_opcleaving_ob f d ,, z_iso_cleaving_from_opcleaving_ob_disp_iso f d. End IsoCleavingFromOpcleaving. Section isofibration_from_disp_over_univalent. Context (C : category) (Ccat : is_univalent C) (D : disp_cat C). Definition iso_cleaving_category : iso_cleaving D. Proof. intros c c' i d. use tpair. - exact (transportb D (isotoid _ Ccat i) d). - generalize i. clear i. apply forall_isotoid. { apply Ccat. } intro e. induction e. cbn. rewrite isotoid_identity_iso. cbn. apply identity_z_iso_disp. Defined. End isofibration_from_disp_over_univalent. (** * Split fibrations *) Definition cleaving_ob {C : category} {D : disp_cat C} (X : cleaving D) {c c' : C} (f : c' --> c) (d : D c) : D c' := X _ _ f d. Definition cleaving_mor {C : category} {D : disp_cat C} (X : cleaving D) {c c' : C} (f : c' --> c) (d : D c) : cleaving_ob X f d -->[f] d := X _ _ f d. Definition is_split_id {C : category} {D : disp_cat C} (X : cleaving D) : UU := ∏ c (d : D c), ∑ e : cleaving_ob X (identity _) d = d, cleaving_mor X (identity _) d = transportb (λ x, x -->[ _ ] _ ) e (id_disp d). Definition is_split_comp {C : category} {D : disp_cat C} (X : cleaving D) : UU := ∏ (c c' c'' : C) (f : c' --> c) (g : c'' --> c') (d : D c), ∑ e : cleaving_ob X (g · f) d = cleaving_ob X g (cleaving_ob X f d), cleaving_mor X (g · f) d = transportb (λ x, x -->[ _ ] _ ) e (cleaving_mor X g (cleaving_ob X f d) ;; cleaving_mor X f d). Definition is_split {C : category} {D : disp_cat C} (X : cleaving D) : UU := is_split_id X × is_split_comp X × (∏ c, isaset (D c)). Lemma is_split_fibration_from_discrete_fibration {C : category} {D : disp_cat C} (X : is_discrete_fibration D) : is_split (fibration_from_discrete_fibration _ (D,,X)). Proof. repeat split. - intros c d. cbn. use tpair. + apply pathsinv0. apply path_to_ctr. apply id_disp. + cbn. apply (disp_mor_unique_disc_fib _ (D,,X)). - intros c c' c'' f g d. cbn. use tpair. + set (XR := unique_lift f d). set (d' := pr1 (iscontrpr1 XR)). set (f' := pr2 (iscontrpr1 XR)). cbn in f'. set (g' := pr2 (iscontrpr1 (unique_lift g d'))). cbn in g'. set (gf' := g' ;; f'). match goal with |[ |- ?a = ?b ] => assert (X0 : (a,,pr2 (iscontrpr1 (unique_lift (g · f) d))) = (b,,gf')) end. { apply proofirrelevancecontr. apply X. } apply (maponpaths pr1 X0). + apply (disp_mor_unique_disc_fib _ (D,,X)). - apply isaset_fiber_discrete_fibration. Defined. (** Some standard cartesian cells *) Definition is_cartesian_id_disp {C : category} {D : disp_cat C} {x : C} (xx : D x) : is_cartesian (id_disp xx). Proof. intros z g zz hh. use iscontraprop1. - abstract (use invproofirrelevance ; intros f₁ f₂ ; use subtypePath ; [ intro ; intros ; apply D | ] ; refine (id_right_disp_var _ @ _ @ !(id_right_disp_var _)) ; rewrite (pr2 f₁), (pr2 f₂) ; apply idpath). - use tpair. + exact (transportf _ (id_right _) hh). + abstract (simpl ; rewrite id_right_disp ; unfold transportb ; rewrite transport_f_f ; rewrite pathsinv0r ; apply idpath). Defined. Definition is_cartesian_comp_disp {C : category} {D : disp_cat C} {x : C} {xx : D x} {y : C} {yy : D y} {z : C} {zz : D z} {f : x --> y} {g : y --> z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} (Hff : is_cartesian ff) (Hgg : is_cartesian gg) : is_cartesian (ff ;; gg)%mor_disp. Proof. intros w h ww hh'. use iscontraprop1. - abstract (use invproofirrelevance ; intros f₁ f₂ ; use subtypePath ; [ intro ; apply D | ] ; use (cartesian_factorisation_unique Hff) ; use (cartesian_factorisation_unique Hgg) ; rewrite !assoc_disp_var ; rewrite (pr2 f₁), (pr2 f₂) ; apply idpath). - simple refine (_ ,, _). + exact (cartesian_factorisation Hff h (cartesian_factorisation Hgg (h · f) (transportf (λ z, _ -->[ z ] _) (assoc _ _ _) hh'))). + abstract (simpl ; rewrite assoc_disp ; rewrite !cartesian_factorisation_commutes ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition is_cartesian_z_iso_disp {C : category} {D : disp_cat C} {x : C} {xx : D x} {y : C} {yy : D y} {f : x --> y} {Hf : is_z_isomorphism f} {ff : xx -->[ f ] yy} (Hff : is_z_iso_disp (make_z_iso' f Hf) ff) : is_cartesian ff. Proof. intros z g zz gf. use iscontraprop1. - abstract (apply invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply D | ] ; pose (pr2 φ₁ @ !(pr2 φ₂)) as r ; refine (id_right_disp_var _ @ _ @ !(id_right_disp_var _)) ; pose (transportf_transpose_left (inv_mor_after_z_iso_disp Hff)) as r' ; rewrite <- !r' ; clear r' ; rewrite !mor_disp_transportf_prewhisker ; rewrite !assoc_disp ; unfold transportb ; rewrite !transport_f_f ; apply maponpaths ; apply maponpaths_2 ; exact r). - simple refine (_ ,, _). + refine (transportf (λ z, _ -->[ z ] _) _ (gf ;; inv_mor_disp_from_z_iso Hff)%mor_disp). abstract (rewrite assoc' ; refine (_ @ id_right _) ; apply maponpaths ; apply (z_iso_inv_after_z_iso (make_z_iso' f Hf))). + abstract (simpl ; rewrite mor_disp_transportf_postwhisker ; rewrite assoc_disp_var ; rewrite transport_f_f ; etrans ; [ do 2 apply maponpaths ; apply (z_iso_disp_after_inv_mor Hff) | ] ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite id_right_disp ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property ; rewrite disp_id_right). Defined. Definition is_cartesian_transportf {C : category} {D : disp_cat C} {x y : C} {f f' : x --> y} (p : f = f') {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : is_cartesian ff) : is_cartesian (transportf (λ z, _ -->[ z ] _) p ff). Proof. intros c g cc gg. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply D | ] ; use (cartesian_factorisation_unique Hff) ; pose (p₁ := pr2 φ₁) ; pose (p₂ := pr2 φ₂) ; cbn in p₁, p₂ ; rewrite mor_disp_transportf_prewhisker in p₁ ; rewrite mor_disp_transportf_prewhisker in p₂ ; pose (transportb_transpose_right p₁) as r₁ ; pose (transportb_transpose_right p₂) as r₂ ; exact (r₁ @ !r₂)). - simple refine (_ ,, _). + exact (cartesian_factorisation Hff g (transportb (λ z, _ -->[ z ] _) (maponpaths (λ z, g · z) p) gg)). + abstract (cbn ; rewrite mor_disp_transportf_prewhisker ; rewrite cartesian_factorisation_commutes ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition is_cartesian_precomp {C : category} {D : disp_cat C} {x y z : C} {f : x --> y} {g : y --> z} {h : x --> z} {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} {hh : xx -->[ h ] zz} (p : h = f · g) (pp : (ff ;; gg = transportf (λ z, _ -->[ z ] _) p hh)%mor_disp) (Hgg : is_cartesian gg) (Hhh : is_cartesian hh) : is_cartesian ff. Proof. intros w φ ww φφ. use iscontraprop1. - abstract (use invproofirrelevance ; intros ψ₁ ψ₂ ; use subtypePath ; [ intro ; apply D | ] ; use (cartesian_factorisation_unique Hhh) ; rewrite <- (transportb_transpose_left pp) ; unfold transportb ; rewrite !mor_disp_transportf_prewhisker ; rewrite !assoc_disp ; rewrite (pr2 ψ₁), (pr2 ψ₂) ; apply idpath). - simple refine (_ ,, _). + refine (cartesian_factorisation Hhh φ (transportf (λ z, _ -->[ z ] _) _ (φφ ;; gg)%mor_disp)). abstract (rewrite p ; rewrite assoc ; apply idpath). + abstract (simpl ; use (cartesian_factorisation_unique Hgg) ; rewrite assoc_disp_var ; rewrite pp ; rewrite mor_disp_transportf_prewhisker ; rewrite transport_f_f ; rewrite cartesian_factorisation_commutes ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition z_iso_disp_to_is_cartesian {C : category} {D : disp_cat C} {x y z : C} {f : x --> z} {g : y --> z} {h : y --> x} (Hh : is_z_isomorphism h) {p : h · f = g} {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] zz} {gg : yy -->[ g ] zz} {hh : yy -->[ h ] xx} (Hff : is_cartesian ff) (Hhh : is_z_iso_disp (make_z_iso' h Hh) hh) (pp : (hh ;; ff = transportb _ p gg)%mor_disp) : is_cartesian gg. Proof. intros q k qq kg. assert (f = inv_from_z_iso (make_z_iso' h Hh) · g) as r. { abstract (refine (!_) ; use z_iso_inv_on_right ; exact (!p)). } assert (transportf (λ z, _ -->[ z ] _) r ff = inv_mor_disp_from_z_iso Hhh ;; gg)%mor_disp as rr. { abstract (rewrite <- (transportb_transpose_left pp) ; unfold transportb ; rewrite mor_disp_transportf_prewhisker ; rewrite assoc_disp ; refine (!_) ; etrans ; [ do 2 apply maponpaths ; apply maponpaths_2 ; exact (z_iso_disp_after_inv_mor Hhh) | ] ; unfold transportb ; rewrite mor_disp_transportf_postwhisker ; rewrite id_left_disp ; unfold transportb ; rewrite !transport_f_f ; apply maponpaths_2 ; apply homset_property). } use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply D | ] ; use (postcomp_with_z_iso_disp_is_inj Hh (idpath _) Hhh) ; cbn ; use (cartesian_factorisation_unique Hff) ; rewrite !assoc_disp_var ; rewrite pp ; unfold transportb ; rewrite !mor_disp_transportf_prewhisker ; rewrite !transport_f_f ; apply maponpaths ; exact (pr2 φ₁ @ !(pr2 φ₂))). - simple refine (_ ,, _). + refine (transportf (λ z, _ -->[ z ] _) _ (cartesian_factorisation Hff (k · h) (transportf (λ z, _ -->[ z ] _) _ kg) ;; inv_mor_disp_from_z_iso Hhh)%mor_disp). * abstract (rewrite assoc' ; etrans ; [ apply maponpaths ; apply (z_iso_inv_after_z_iso (make_z_iso' h Hh)) | ] ; apply id_right). * abstract (rewrite assoc' ; rewrite p ; apply idpath). + abstract (simpl ; rewrite mor_disp_transportf_postwhisker ; rewrite assoc_disp_var ; etrans ; [ do 3 apply maponpaths ; exact (!rr) | ] ; rewrite transport_f_f ; rewrite mor_disp_transportf_prewhisker ; rewrite cartesian_factorisation_commutes ; rewrite !transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition is_opcartesian_id_disp {C : category} {D : disp_cat C} {x : C} (xx : D x) : is_opcartesian (id_disp xx). Proof. apply is_cartesian_to_is_opcartesian. exact (@is_cartesian_id_disp _ (op_disp_cat D) _ xx). Defined. Definition is_opcartesian_comp_disp {C : category} {D : disp_cat C} {x : C} {xx : D x} {y : C} {yy : D y} {z : C} {zz : D z} {f : x --> y} {g : y --> z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} (Hff : is_opcartesian ff) (Hgg : is_opcartesian gg) : is_opcartesian (ff ;; gg)%mor_disp. Proof. apply is_cartesian_to_is_opcartesian. use (@is_cartesian_comp_disp _ (op_disp_cat D)). - apply is_opcartesian_weq_is_cartesian. exact Hgg. - apply is_opcartesian_weq_is_cartesian. exact Hff. Defined. Definition is_opcartesian_postcomp {C : category} {D : disp_cat C} {x y z : C} {f : x --> y} {g : y --> z} {h : x --> z} {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} {hh : xx -->[ h ] zz} (p : h = f · g) (pp : (ff ;; gg = transportf (λ z, _ -->[ z ] _) p hh)%mor_disp) (Hff : is_opcartesian ff) (Hhh : is_opcartesian hh) : is_opcartesian gg. Proof. apply is_cartesian_to_is_opcartesian. use (@is_cartesian_precomp _ (op_disp_cat D) _ _ _ g f h zz yy xx gg ff hh p pp). - apply is_opcartesian_weq_is_cartesian. exact Hff. - apply is_opcartesian_weq_is_cartesian. exact Hhh. Defined. Definition is_opcartesian_z_iso_disp {C : category} {D : disp_cat C} {x : C} {xx : D x} {y : C} {yy : D y} {f : x --> y} {Hf : is_z_isomorphism f} {ff : xx -->[ f ] yy} (Hff : is_z_iso_disp (make_z_iso' f Hf) ff) : is_opcartesian ff. Proof. apply is_cartesian_to_is_opcartesian. use (@is_cartesian_z_iso_disp _ (op_disp_cat D) _ _ _ _ _ _ ff). - exact (pr2 (@opp_z_iso C _ _ (make_z_iso' f Hf))). - use (@to_z_iso_disp_op_disp_cat C D y x (make_z_iso' f Hf) yy xx ff). exact Hff. Defined. Definition is_opcartesian_transportf {C : category} {D : disp_cat C} {x y : C} {f f' : x --> y} (p : f = f') {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : is_opcartesian ff) : is_opcartesian (transportf (λ z, _ -->[ z ] _) p ff). Proof. apply is_cartesian_to_is_opcartesian. apply (@is_cartesian_transportf _ (op_disp_cat D)). apply is_opcartesian_weq_is_cartesian. exact Hff. Defined. (** Cartesian factorisation of disp nat trans and functor *) Section CartesianFactorisationDispNatTrans. Context {C₁ C₂ : category} {F₁ F₂ F₃ : C₁ ⟶ C₂} {α : F₂ ⟹ F₃} {β : F₁ ⟹ F₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {FF₁ : disp_functor F₁ D₁ D₂} {FF₂ : disp_functor F₂ D₁ D₂} {FF₃ : disp_functor F₃ D₁ D₂} (αα : disp_nat_trans α FF₂ FF₃) (ββ : disp_nat_trans (nat_trans_comp _ _ _ β α) FF₁ FF₃) (Hαα : ∏ (x : C₁) (xx : D₁ x), is_cartesian (αα x xx)). Definition cartesian_factorisation_disp_nat_trans_data : disp_nat_trans_data β FF₁ FF₂ := λ x xx, cartesian_factorisation (Hαα x xx) (β x) (ββ x xx). Definition cartesian_factorisation_disp_nat_trans_axioms : disp_nat_trans_axioms cartesian_factorisation_disp_nat_trans_data. Proof. intros x y f xx yy ff ; cbn in *. unfold cartesian_factorisation_disp_nat_trans_data. use (cartesian_factorisation_unique (Hαα y yy)). rewrite assoc_disp_var. rewrite cartesian_factorisation_commutes. refine (maponpaths _ (disp_nat_trans_ax ββ ff) @ _). unfold transportb. rewrite !transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. exact (disp_nat_trans_ax αα ff). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. apply maponpaths_2. apply homset_property. Qed. Definition cartesian_factorisation_disp_nat_trans : disp_nat_trans β FF₁ FF₂. Proof. simple refine (_ ,, _). - exact cartesian_factorisation_disp_nat_trans_data. - exact cartesian_factorisation_disp_nat_trans_axioms. Defined. End CartesianFactorisationDispNatTrans. Section CartesianFactorisationDispFunctor. Context {C₁ C₂ : category} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (HD₁ : cleaving D₂) {F G : C₁ ⟶ C₂} (GG : disp_functor G D₁ D₂) (α : F ⟹ G). Definition cartesian_factorisation_disp_functor_data : disp_functor_data F D₁ D₂. Proof. simple refine (_ ,, _). - exact (λ x xx, pr1 (HD₁ (G x) (F x) (α x) (GG x xx))). - exact (λ x y xx yy f ff, cartesian_factorisation (pr22 (HD₁ (G y) (F y) (α y) (GG y yy))) _ (transportb (λ z, _ -->[ z ] _) (nat_trans_ax α _ _ f) (pr12 (HD₁ (G x) (F x) (α x) (GG x xx)) ;; ♯ GG ff))). Defined. Definition cartesian_factorisation_disp_functor_axioms : disp_functor_axioms cartesian_factorisation_disp_functor_data. Proof. repeat split. - intros x xx ; cbn. use (cartesian_factorisation_unique (pr22 (HD₁ (G x) (F x) (α x) (GG x xx)))). rewrite cartesian_factorisation_commutes. rewrite disp_functor_id. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros x y z xx yy zz f g ff hh ; cbn. use (cartesian_factorisation_unique (pr22 (HD₁ (G z) (F z) (α z) (GG z zz)))). unfold transportb. rewrite cartesian_factorisation_commutes. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite !assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition cartesian_factorisation_disp_functor : disp_functor F D₁ D₂. Proof. simple refine (_ ,, _). - exact cartesian_factorisation_disp_functor_data. - exact cartesian_factorisation_disp_functor_axioms. Defined. Definition cartesian_factorisation_disp_functor_is_cartesian (HGG : is_cartesian_disp_functor GG) : is_cartesian_disp_functor cartesian_factorisation_disp_functor. Proof. intros x y f xx yy ff Hff ; cbn. pose (HGff := HGG _ _ _ _ _ _ Hff). refine (is_cartesian_precomp (idpath _) _ (pr22 (HD₁ (G x) (F x) (α x) (GG x xx))) (is_cartesian_transportf (!(nat_trans_ax α _ _ f)) (is_cartesian_comp_disp (pr22 (HD₁ (G y) (F y) (α y) (GG y yy))) HGff))). rewrite cartesian_factorisation_commutes. apply idpath. Qed. Definition cartesian_factorisation_disp_functor_cell_data : disp_nat_trans_data α cartesian_factorisation_disp_functor_data GG := λ x xx, pr12 (HD₁ (G x) (F x) (α x) (GG x xx)). Definition cartesian_factorisation_disp_functor_cell_axioms : disp_nat_trans_axioms cartesian_factorisation_disp_functor_cell_data. Proof. intros x y f xx yy ff ; cbn ; unfold cartesian_factorisation_disp_functor_cell_data. unfold transportb. rewrite cartesian_factorisation_commutes. apply idpath. Qed. Definition cartesian_factorisation_disp_functor_cell : disp_nat_trans α cartesian_factorisation_disp_functor_data GG. Proof. simple refine (_ ,, _). - exact cartesian_factorisation_disp_functor_cell_data. - exact cartesian_factorisation_disp_functor_cell_axioms. Defined. Definition cartesian_factorisation_disp_functor_cell_is_cartesian {x : C₁} (xx : D₁ x) : is_cartesian (cartesian_factorisation_disp_functor_cell x xx). Proof. exact (pr22 (HD₁ (G x) (F x) (α x) (GG x xx))). Defined. End CartesianFactorisationDispFunctor. (** Cartesian factorisation of disp nat trans and functor *) Section OpCartesianFactorisationDispNatTrans. Context {C₁ C₂ : category} {F₁ F₂ F₃ : C₁ ⟶ C₂} {α : F₁ ⟹ F₂} {β : F₂ ⟹ F₃} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {FF₁ : disp_functor F₁ D₁ D₂} {FF₂ : disp_functor F₂ D₁ D₂} {FF₃ : disp_functor F₃ D₁ D₂} (αα : disp_nat_trans α FF₁ FF₂) (ββ : disp_nat_trans (nat_trans_comp _ _ _ α β) FF₁ FF₃) (Hαα : ∏ (x : C₁) (xx : D₁ x), is_opcartesian (αα x xx)). Definition opcartesian_factorisation_disp_nat_trans_data : disp_nat_trans_data β FF₂ FF₃ := λ x xx, opcartesian_factorisation (Hαα x xx) (β x) (ββ x xx). Definition opcartesian_factorisation_disp_nat_trans_axioms : disp_nat_trans_axioms opcartesian_factorisation_disp_nat_trans_data. Proof. intros x y f xx yy ff ; cbn in *. unfold opcartesian_factorisation_disp_nat_trans_data. use (opcartesian_factorisation_unique (Hαα x xx)). unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite !assoc_disp. unfold transportb. rewrite transport_f_f. rewrite opcartesian_factorisation_commutes. etrans. { apply maponpaths. apply maponpaths_2. apply (disp_nat_trans_ax_var αα ff). } rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite opcartesian_factorisation_commutes. etrans. { apply maponpaths. exact (disp_nat_trans_ax ββ ff). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition opcartesian_factorisation_disp_nat_trans : disp_nat_trans β FF₂ FF₃. Proof. simple refine (_ ,, _). - exact opcartesian_factorisation_disp_nat_trans_data. - exact opcartesian_factorisation_disp_nat_trans_axioms. Defined. End OpCartesianFactorisationDispNatTrans. Section OpCartesianFactorisationDispFunctor. Context {C₁ C₂ : category} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (HD₁ : opcleaving D₂) {F G : C₁ ⟶ C₂} (FF : disp_functor F D₁ D₂) (α : F ⟹ G). Definition opcartesian_factorisation_disp_functor_data : disp_functor_data G D₁ D₂. Proof. simple refine (_ ,, _). - exact (λ x xx, ob_of_opcartesian_lift _ (HD₁ (F x) (G x) (FF x xx) (α x))). - exact (λ x y xx yy f ff, opcartesian_factorisation (mor_of_opcartesian_lift_is_opcartesian _ (HD₁ (F x) (G x) (FF x xx) (α x))) _ (transportf (λ z, _ -->[ z ] _) (nat_trans_ax α _ _ f) (♯ FF ff ;; mor_of_opcartesian_lift _ (HD₁ (F y) (G y) (FF y yy) (α y))))). Defined. Definition opcartesian_factorisation_disp_functor_axioms : disp_functor_axioms opcartesian_factorisation_disp_functor_data. Proof. repeat split. - intros x xx ; cbn. use (opcartesian_factorisation_unique (pr22 (HD₁ (F x) (G x) (FF x xx) (α x)))). rewrite opcartesian_factorisation_commutes. rewrite disp_functor_id. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - intros x y z xx yy zz f g ff hh ; cbn. use (opcartesian_factorisation_unique (pr22 (HD₁ (F x) (G x) (FF x xx) (α x)))). unfold transportb. rewrite opcartesian_factorisation_commutes. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite !assoc_disp. unfold transportb. rewrite !transport_f_f. rewrite opcartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite !assoc_disp_var. unfold transportb. rewrite transport_f_f. rewrite opcartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition opcartesian_factorisation_disp_functor : disp_functor G D₁ D₂. Proof. simple refine (_ ,, _). - exact opcartesian_factorisation_disp_functor_data. - exact opcartesian_factorisation_disp_functor_axioms. Defined. Definition opcartesian_factorisation_disp_functor_is_opcartesian (HFF : is_opcartesian_disp_functor FF) : is_opcartesian_disp_functor opcartesian_factorisation_disp_functor. Proof. intros x y f xx yy ff Hff ; cbn. pose (HFff := HFF _ _ _ _ _ _ Hff). use (is_opcartesian_postcomp (idpath _) _ (pr22 (HD₁ (F y) (G y) (FF y yy) (α y))) (is_opcartesian_transportf (nat_trans_ax α _ _ f) (is_opcartesian_comp_disp HFff (pr22 (HD₁ (F x) (G x) (FF x xx) (α x)))))). rewrite opcartesian_factorisation_commutes. apply idpath. Qed. Definition opcartesian_factorisation_disp_functor_cell_data : disp_nat_trans_data α FF opcartesian_factorisation_disp_functor_data := λ x xx, pr12 (HD₁ (F x) (G x) (FF x xx) (α x)). Definition opcartesian_factorisation_disp_functor_cell_axioms : disp_nat_trans_axioms opcartesian_factorisation_disp_functor_cell_data. Proof. intros x y f xx yy ff ; cbn ; unfold opcartesian_factorisation_disp_functor_cell_data. unfold transportb. rewrite opcartesian_factorisation_commutes. rewrite transport_f_f. refine (!_). apply transportf_set. apply homset_property. Qed. Definition opcartesian_factorisation_disp_functor_cell : disp_nat_trans α FF opcartesian_factorisation_disp_functor_data. Proof. simple refine (_ ,, _). - exact opcartesian_factorisation_disp_functor_cell_data. - exact opcartesian_factorisation_disp_functor_cell_axioms. Defined. Definition opcartesian_factorisation_disp_functor_cell_is_opcartesian {x : C₁} (xx : D₁ x) : is_opcartesian (opcartesian_factorisation_disp_functor_cell x xx). Proof. exact (pr22 (HD₁ (F x) (G x) (FF x xx) (α x))). Defined. End OpCartesianFactorisationDispFunctor. Section fiber_functor_from_cleaving. Context {C : category} (D : disp_cat C) (F : cleaving D). Context {c c' : C} (f : C⟦c', c⟧). Let lift_f : ∏ d : D c, cartesian_lift d f := F _ _ f. Definition fiber_functor_from_cleaving_data : functor_data (D [{c}]) (D [{c'}]). Proof. use tpair. + intro d. exact (object_of_cartesian_lift _ _ (lift_f d)). + intros d' d ff. cbn. set (XR' := @cartesian_factorisation C D _ _ f). specialize (XR' _ _ _ (lift_f d)). use XR'. * use (transportf (mor_disp _ _ ) _ (mor_disp_of_cartesian_lift _ _ (lift_f d') ;; ff)). etrans; [ apply id_right |]; apply pathsinv0; apply id_left. Defined. Lemma is_functor_from_cleaving_data : is_functor fiber_functor_from_cleaving_data. Proof. split. - intro d; cbn. apply pathsinv0. apply path_to_ctr. etrans; [apply id_left_disp |]. apply pathsinv0. etrans. { apply maponpaths. apply id_right_disp. } etrans; [ apply transport_f_f |]. unfold transportb. apply maponpaths_2. apply homset_property. - intros d'' d' d ff' ff; cbn. apply pathsinv0. apply path_to_ctr. etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0. etrans. { apply maponpaths; apply mor_disp_transportf_prewhisker. } etrans; [apply transport_f_f |]. apply transportf_comp_lemma. apply pathsinv0. etrans; [apply assoc_disp_var |]. apply pathsinv0. apply transportf_comp_lemma. apply pathsinv0. etrans ; [ apply maponpaths, cartesian_factorisation_commutes |]. etrans ; [ apply mor_disp_transportf_prewhisker |]. apply pathsinv0. apply transportf_comp_lemma. apply pathsinv0. etrans; [ apply assoc_disp |]. apply pathsinv0. apply transportf_comp_lemma. apply pathsinv0. etrans; [ apply maponpaths_2, cartesian_factorisation_commutes |]. etrans; [ apply mor_disp_transportf_postwhisker |]. etrans. { apply maponpaths. apply assoc_disp_var. } etrans. { apply transport_f_f. } apply maponpaths_2, homset_property. Qed. Definition fiber_functor_from_cleaving : D [{c}] ⟶ D [{c'}] := make_functor _ is_functor_from_cleaving_data. End fiber_functor_from_cleaving. Section Essential_Surjectivity. Definition fiber_functor_ess_split_surj {C C' : category} {D} {D'} {F : functor C C'} (FF : disp_functor F D D') (H : disp_functor_ff FF) {X : disp_functor_ess_split_surj FF} {Y : is_op_isofibration D} (* TODO: change to [is_isofibration], once [is_isofibration_iff_is_op_isofibration] is provided *) (x : C) : ∏ yy : D'[{F x}], ∑ xx : D[{x}], z_iso (fiber_functor FF _ xx) yy. Proof. intro yy. set (XR := X _ yy). destruct XR as [c'' [i [xx' ii]]]. set (YY := Y _ _ i xx'). destruct YY as [ dd pe ]. use tpair. - apply dd. - (* now need disp_functor_on_iso_disp *) set (XR := disp_functor_on_z_iso_disp FF pe). set (XR' := z_iso_inv_from_z_iso_disp XR). (* now need composition of iso_disps *) apply (invweq (z_iso_disp_z_iso_fiber _ _ _ _)). set (XRt := z_iso_disp_comp XR' ii). transparent assert (XH : (z_iso_comp (z_iso_inv_from_z_iso (functor_on_z_iso F i)) (functor_on_z_iso F i) = identity_z_iso _ )). { apply z_iso_eq. cbn. etrans. { apply pathsinv0, functor_comp. } apply functor_id_id. apply z_iso_after_z_iso_inv. } set (XRT := transportf (λ r, z_iso_disp r (FF x dd) yy ) XH). apply XRT. assumption. Defined. End Essential_Surjectivity. (** A sufficient condition for when a cartesian factorization is an isomorphism *) Definition is_z_iso_disp_cartesian_factorisation {C : category} {D : disp_cat C} {w x y : C} {f : w --> x} (Hf : is_z_isomorphism f) (fiso := (f ,, Hf) : z_iso w x) {g : x --> y} (Hg : is_z_isomorphism g) (giso := (g ,, Hg) : z_iso x y) {ww : D w} {xx : D x} {yy : D y} {gg : xx -->[ g ] yy} (Hgg : is_cartesian gg) (hh : ww -->[ f · g ] yy) (Hhh : is_z_iso_disp (z_iso_comp fiso giso) hh) : is_z_iso_disp fiso (cartesian_factorisation Hgg f hh). Proof. simple refine (_ ,, _ ,, _). - refine (transportf (λ z, _ -->[ z ] _) _ (gg ;; inv_mor_disp_from_z_iso Hhh)%mor_disp). abstract (cbn ; rewrite !assoc ; refine (_ @ id_left _) ; apply maponpaths_2 ; exact (z_iso_inv_after_z_iso giso)). - use (cartesian_factorisation_unique Hgg). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite !mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite assoc_disp_var. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. etrans ; [ do 2 apply maponpaths ; apply (z_iso_disp_after_inv_mor Hhh) | ]. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. rewrite mor_disp_transportf_postwhisker. rewrite id_left_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. - cbn. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. refine (maponpaths _ (inv_mor_after_z_iso_disp Hhh) @ _). unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Defined. (** The fiber functor of the identity *) Section FiberFunctorCleavingIdenttiy. Context {C : category} {D : disp_cat C} (HD : cleaving D) (x : C). Definition fiber_functor_from_cleaving_identity_data : nat_trans_data (functor_identity _) (fiber_functor_from_cleaving D HD (identity x)). Proof. intros xx. refine (cartesian_factorisation (cartesian_lift_is_cartesian _ _ (HD x x (identity x) xx)) (identity x) (transportb (λ z, _ -->[ z ] _) _ (id_disp _))). abstract (exact (id_left _)). Defined. Proposition fiber_functor_from_cleaving_identity_laws : is_nat_trans _ _ fiber_functor_from_cleaving_identity_data. Proof. intros xx yy f ; cbn. unfold fiber_functor_from_cleaving_identity_data. use (cartesian_factorisation_unique (HD x x (identity x) yy)). rewrite !mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Defined. Definition fiber_functor_from_cleaving_identity : functor_identity _ ⟹ fiber_functor_from_cleaving D HD (identity x). Proof. use make_nat_trans. - exact fiber_functor_from_cleaving_identity_data. - exact fiber_functor_from_cleaving_identity_laws. Defined. Definition is_nat_z_iso_fiber_functor_from_cleaving_identity : is_nat_z_iso fiber_functor_from_cleaving_identity. Proof. intros xx ; cbn. use is_z_iso_fiber_from_is_z_iso_disp. use is_z_iso_disp_cartesian_factorisation. { apply is_z_isomorphism_identity. } cbn in x. use (is_z_iso_disp_transportb_fun_eq (identity_z_iso x) (id_disp xx)). apply id_is_z_iso_disp. Defined. End FiberFunctorCleavingIdenttiy. Arguments fiber_functor_from_cleaving_identity_data {C D} HD x /. (** The fiber functor of a compositio *) Section FiberFunctorCleavingComp. Context {C : category} {D : disp_cat C} (HD : cleaving D) {x y z : C} (f : y --> x) (g : z --> y). Definition fiber_functor_from_cleaving_comp_data : nat_trans_data (fiber_functor_from_cleaving D HD f ∙ fiber_functor_from_cleaving D HD g) (fiber_functor_from_cleaving D HD (g · f)). Proof. intros xx. refine (cartesian_factorisation (cartesian_lift_is_cartesian _ _ (HD x z (g · f) xx)) _ (transportb (λ z, _ -->[ z ] _) _ (HD y z g (HD x y f xx) ;; HD x y f xx)%mor_disp)). abstract (exact (id_left _)). Defined. Proposition fiber_functor_from_cleaving_comp_laws : is_nat_trans _ _ fiber_functor_from_cleaving_comp_data. Proof. intros xx yy gg ; cbn. unfold fiber_functor_from_cleaving_comp_data. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite !mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. refine (!_). rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition fiber_functor_from_cleaving_comp : fiber_functor_from_cleaving D HD f ∙ fiber_functor_from_cleaving D HD g ⟹ fiber_functor_from_cleaving D HD (g · f). Proof. use make_nat_trans. - exact fiber_functor_from_cleaving_comp_data. - exact fiber_functor_from_cleaving_comp_laws. Defined. Definition fiber_functor_from_cleaving_comp_inv (xx : D x) : D[{z}] ⟦ pr1 (HD x z (g · f) xx) , pr1 (HD y z g (HD x y f xx)) ⟧. Proof. refine (cartesian_factorisation (HD y z g (HD x y f xx)) _ (cartesian_factorisation (HD x y f xx) _ (transportf (λ z, _ -->[ z ] _) _ (HD x z (g · f) xx)))). abstract (rewrite !assoc' ; rewrite id_left ; apply idpath). Defined. Proposition fiber_functor_from_cleaving_comp_inv_left (xx : D x) : fiber_functor_from_cleaving_comp xx · fiber_functor_from_cleaving_comp_inv xx = identity _. Proof. cbn. unfold fiber_functor_from_cleaving_comp_data, fiber_functor_from_cleaving_comp_inv. unfold transportb. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply maponpaths_2. apply homset_property. Qed. Proposition fiber_functor_from_cleaving_comp_inv_right (xx : D x) : fiber_functor_from_cleaving_comp_inv xx · fiber_functor_from_cleaving_comp xx = identity _. Proof. cbn. unfold fiber_functor_from_cleaving_comp_data, fiber_functor_from_cleaving_comp_inv. unfold transportb. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite !cartesian_factorisation_commutes. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. apply maponpaths_2. apply homset_property. Qed. Definition is_nat_z_iso_fiber_functor_from_cleaving_comp : is_nat_z_iso fiber_functor_from_cleaving_comp. Proof. intros xx. use make_is_z_isomorphism. - cbn -[fiber_category]. exact (fiber_functor_from_cleaving_comp_inv xx). - split. + exact (fiber_functor_from_cleaving_comp_inv_left xx). + exact (fiber_functor_from_cleaving_comp_inv_right xx). Defined. End FiberFunctorCleavingComp. Arguments fiber_functor_from_cleaving_comp_data {C D} HD {x y z} f g /. (** The fiber functor of a cartesian functor is natural *) Locate cartesian_disp_functor_on_cartesian. Section FiberFunctorNatural. Context {C : category} {D₁ D₂ : disp_cat C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (F : cartesian_disp_functor (functor_identity C) D₁ D₂) {x y : C} (f : y --> x). Definition fiber_functor_natural_data : nat_trans_data (fiber_functor F x ∙ fiber_functor_from_cleaving D₂ HD₂ f) (fiber_functor_from_cleaving D₁ HD₁ f ∙ fiber_functor F y). Proof. intro xx. refine (cartesian_factorisation (cartesian_disp_functor_on_cartesian F (HD₁ x y f xx)) _ (transportf (λ z, _ -->[ z ] _) _ (HD₂ x y f (F x xx)))). abstract (exact (!(id_left _))). Defined. Proposition fiber_functor_natural_laws : is_nat_trans _ _ fiber_functor_natural_data. Proof. intros xx yy ff. unfold fiber_functor_natural_data ; cbn. use (cartesian_factorisation_unique (cartesian_disp_functor_on_cartesian F (HD₁ _ _ _ _))). rewrite !mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite !transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. refine (!_). apply (disp_functor_comp_var F). } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition fiber_functor_natural : fiber_functor F x ∙ fiber_functor_from_cleaving D₂ HD₂ f ⟹ fiber_functor_from_cleaving D₁ HD₁ f ∙ fiber_functor F y. Proof. use make_nat_trans. - exact fiber_functor_natural_data. - exact fiber_functor_natural_laws. Defined. Definition fiber_functor_natural_inv (xx : D₁ x) : F y (HD₁ x y f xx) -->[ identity y] pr1 (HD₂ x y f (F x xx)). Proof. refine (cartesian_factorisation (HD₂ _ _ _ _) _ (transportf (λ z, _ -->[ z ] _) _ (♯ F (pr12 (HD₁ x y f xx)))))%mor_disp. abstract (exact (!(id_left _))). Defined. Proposition fiber_functor_natural_inv_left (xx : D₁ x) : fiber_functor_natural xx · fiber_functor_natural_inv xx = identity _. Proof. cbn. unfold fiber_functor_natural_data, fiber_functor_natural_inv ; cbn. use (cartesian_factorisation_unique (HD₂ _ _ _ _)). rewrite id_left_disp. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. unfold transportb. apply maponpaths_2. apply homset_property. Qed. Proposition fiber_functor_natural_inv_right (xx : D₁ x) : transportf (λ z, _ -->[ z ] _) (id_right (identity y)) (fiber_functor_natural_inv xx ;; fiber_functor_natural_data xx)%mor_disp = id_disp _. Proof. cbn. unfold fiber_functor_natural_data, fiber_functor_natural_inv ; cbn. use (cartesian_factorisation_unique (cartesian_disp_functor_on_cartesian F (HD₁ _ _ _ _))). rewrite id_left_disp. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. unfold transportb. apply maponpaths_2. apply homset_property. Qed. Definition is_nat_z_iso_fiber_functor_natural : is_nat_z_iso fiber_functor_natural. Proof. intros xx. use make_is_z_isomorphism. - exact (fiber_functor_natural_inv xx). - split. + exact (fiber_functor_natural_inv_left xx). + exact (fiber_functor_natural_inv_right xx). Defined. Definition fiber_functor_natural_nat_z_iso : nat_z_iso (fiber_functor F x ∙ fiber_functor_from_cleaving D₂ HD₂ f) (fiber_functor_from_cleaving D₁ HD₁ f ∙ fiber_functor F y). Proof. use make_nat_z_iso. - exact fiber_functor_natural. - exact is_nat_z_iso_fiber_functor_natural. Defined. End FiberFunctorNatural. Arguments fiber_functor_natural_data {C D₁ D₂} HD₁ HD₂ F {x y} f /. (** Lemma for composing `idtoiso` with a cartesian lift *) Proposition idtoiso_disp_cartesian_lift {C : category} (D : disp_cat C) (HD : cleaving D) {x y : C} {f g : x --> y} (yy : D y) (p : g = f) : (idtoiso_disp (idpath _) (maponpaths (λ (h : x --> y), pr1 (HD _ _ h _)) p) ;; HD y x f yy = transportf (λ z, _ -->[ z ] _) (p @ !(id_left _)) (HD y x g yy))%mor_disp. Proof. induction p ; cbn. rewrite id_left_disp. apply idpath. Qed. (** Transporting the object of a cartesian lift *) Proposition transportf_object_cartesian_lift {C : category} {D : disp_cat C} (HD : cleaving D) {x : C} (xx : D x) {f g : x --> x} (p : f = g) (ff : xx -->[ identity x ] object_of_cartesian_lift _ _ (HD x x f xx)) : transportf (λ (h : x --> x), _ -->[ identity x ] object_of_cartesian_lift _ _ (HD x x h xx)) p ff = cartesian_factorisation (HD x x g xx) _ (ff ;; transportf (λ z, _ -->[ z ] _) p (HD x x f xx))%mor_disp. Proof. induction p ; cbn. use (cartesian_factorisation_unique (HD x x f xx)). rewrite cartesian_factorisation_commutes. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/FunctorCategory.v000066400000000000000000000205321451125700300256640ustar00rootroot00000000000000(** * Functor category as a displayed category *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope cat. Local Open Scope mor_disp_scope. Definition base_precategory_ob_mor (C D:precategory_data) : precategory_ob_mor := make_precategory_ob_mor (C → D) (λ F₀ G₀ : C → D, ∏ x : C, D ⟦ F₀ x, G₀ x ⟧). Definition base_precategory_data (C D:precategory_data) : precategory_data := make_precategory_data (base_precategory_ob_mor C D) (λ (F₀ : C → D) (x : C), identity (F₀ x)) (λ (F₀ G₀ H₀ : C → D) (FG : ∏ x : C, D ⟦ F₀ x, G₀ x ⟧) (GH : ∏ x : C, D ⟦ G₀ x, H₀ x ⟧) (x : C), FG x · GH x). Section FunctorsDisplayed. Context (C D : category). (** ** Base category. The base category contains: - Objects: functions F₀ : C₀ → D₀ - Morphisms: transformations γₓ : D₀ ⟦F₀ x, G₀ x⟧ *) Lemma is_precategory_base_precategory_data : is_precategory (base_precategory_data C D). Proof. apply make_is_precategory. - intros F₀ G₀. cbn. intros γ. apply funextsec. intros x. apply id_left. - intros F₀ G₀. cbn. intros γ. apply funextsec. intros x. apply id_right. - intros F₀ G₀ H₀ K₀. cbn. intros γ θ μ. apply funextsec. intros x. apply assoc. - intros F₀ G₀ H₀ K₀. cbn. intros γ θ μ. apply funextsec. intros x. apply assoc'. Qed. Definition base_precategory : precategory := make_precategory (base_precategory_data C D) is_precategory_base_precategory_data. Lemma has_homsets_base_precategory_ob_mor : has_homsets (base_precategory_ob_mor C D). Proof. intros F₀ G₀. cbn. apply (impred 2). intro. apply D. Qed. Definition base_category : category := make_category base_precategory has_homsets_base_precategory_ob_mor. (** ** Step 1 - Objects: actions of functors on maps - Morphisms: naturality of transformations The univalence of this displayed category can be expressed as a concrete case of the Structure Identity Principle (however, UniMath.CategoryTheory.DisplayedCats.SIP is not employed). *) Definition disp_morph : disp_cat_data (base_precategory_data C D). Proof. use tpair. - exists (λ F₀, ∏ (a b : C), C ⟦a, b⟧ → D ⟦F₀ a, F₀ b⟧). cbn. intros F₀ G₀ F₁ G₁ γ. exact (∏ (a b : C) (f : C ⟦a, b⟧), F₁ _ _ f · γ b = γ a · G₁ _ _ f). - repeat use tpair; cbn. + cbn; intros. etrans. apply id_right. apply pathsinv0. apply id_left. + cbn. intros ???????? S1 S2 a b f. etrans. apply assoc. etrans. apply cancel_postcomposition, S1. etrans. apply assoc'. etrans. apply cancel_precomposition, S2. apply assoc. Defined. Lemma step1_disp_axioms : disp_cat_axioms base_category disp_morph. Proof. repeat split; intros; repeat (apply impred; intro); repeat (apply funextsec; intro); try apply homset_property. cbn. repeat (apply (impred 2); intro). apply hlevelntosn. apply homset_property. Qed. Definition step1_disp : disp_cat base_category. Proof. exists disp_morph. exact step1_disp_axioms. Defined. Lemma step1_disp_univalent : is_univalent_disp step1_disp. Proof. apply is_univalent_disp_from_fibers. hnf; cbn; intros x f g. apply isweqimplimpl. - intro i. unfold z_iso_disp in i. cbn in i. apply funextsec. intro. destruct i as (ff, Hff). apply funextsec. intro. apply funextsec. intro. etrans. { apply pathsinv0. apply id_right. } etrans. { apply ff. } apply id_left. - assert (KK : isaset (∏ a b : C, C ⟦ a, b ⟧ → D ⟦ x a, x b ⟧)). + repeat (apply (impred 2); intro). apply homset_property. + apply KK. - apply isaproptotal2. + unfold isPredicate. intro u. apply (isaprop_is_z_iso_disp (D := step1_disp)). + cbn. intros u v Hu Hv. apply funextsec. intro a. apply funextsec. intro b. apply funextsec. intro t. apply homset_property. Defined. Definition step1_total : category := total_category step1_disp. (** ** Step 2 - Objects: functors preserve identities - Morphisms: unit *) Definition step2_disp : disp_cat step1_total := disp_full_sub step1_total (λ F : step1_total, let F₁ := pr2 F in ∏ (x : C), F₁ _ _ (identity x) = identity _). (** ** Step 3 - Objects: functors preserve composition - Morphisms: unit *) Definition step3_disp : disp_cat step1_total := disp_full_sub step1_total (λ F : step1_total, let F₁ := pr2 F in ∏ (a b c: C) (f : C⟦a,b⟧) (g : C⟦b,c⟧), F₁ _ _ (f · g) = F₁ _ _ f · F₁ _ _ g). (** ** Step 4 Combine everything together *) Definition functor_disp_cat : disp_cat step1_total := dirprod_disp_cat step2_disp step3_disp. Definition functor_total_cat : category := total_category functor_disp_cat. (** This construction is univalent *) Lemma functor_disp_cat_univalent : is_univalent_disp functor_disp_cat. Proof. apply dirprod_disp_cat_is_univalent. - apply disp_full_sub_univalent. intros [F₀ F₁]. apply impred. intros x. cbn[pr2]. apply homset_property. - apply disp_full_sub_univalent. intros [F₀ F₁]. repeat (apply impred; intros ?). cbn[pr2]. apply homset_property. Defined. Definition base_category_z_iso_to_z_iso_fam (F₀ G₀ : base_category) : z_iso F₀ G₀ → (∏ (x : C), z_iso (F₀ x) (G₀ x)). Proof. intros [γ Hγ]. destruct Hγ as [θ [Hγθ Hθγ]]. intros x. exists (γ x), (θ x). split. - apply (toforallpaths _ _ _ Hγθ). - apply (toforallpaths _ _ _ Hθγ). Defined. Definition base_category_z_iso_fam_to_z_iso (F₀ G₀ : base_category) : (∏ (x : C), z_iso (F₀ x) (G₀ x)) → z_iso F₀ G₀. Proof. intros γ. exists γ, (λ x, inv_from_z_iso (γ x)). split. - apply funextsec. intros x. cbn. apply z_iso_inv_after_z_iso. - apply funextsec. intros x. cbn. apply z_iso_after_z_iso_inv. Defined. Lemma base_category_z_iso_weq (F₀ G₀ : base_category) : z_iso F₀ G₀ ≃ (∏ (x : C), z_iso (F₀ x) (G₀ x)). Proof. exists (base_category_z_iso_to_z_iso_fam F₀ G₀). use isweq_iso. - apply base_category_z_iso_fam_to_z_iso. - intros x. apply z_iso_eq. apply idpath. - intros x. apply funextsec. intros y. apply z_iso_eq. apply idpath. Defined. Definition base_category_z_iso_fam_weq (F₀ G₀ : base_category) : is_univalent D → F₀ ~ G₀ ≃ (∏ (x : C), z_iso (F₀ x) (G₀ x)). Proof. intros HD. apply weqonsecfibers. intros x. exists idtoiso. apply HD. Defined. Definition base_category_z_iso_weq_aux (F₀ G₀ : base_category) : is_univalent D → F₀ = G₀ ≃ z_iso F₀ G₀. Proof. intros HD. eapply weqcomp. apply weqtoforallpaths. eapply weqcomp. apply base_category_z_iso_fam_weq, HD. apply invweq. apply base_category_z_iso_weq. Defined. Lemma base_category_univalent : is_univalent D → is_univalent base_category. Proof. intros HD. unfold is_univalent. unfold base_category. simpl. intros F₀ G₀. use isweqhomot. - apply base_category_z_iso_weq_aux, HD. - intros p. induction p. simpl. show_id_type. cbn. apply (z_iso_eq(C:=base_category)). apply idpath. - apply base_category_z_iso_weq_aux. Defined. Lemma functor_total_cat_univalent : is_univalent D → is_univalent functor_total_cat. Proof. intros HD. apply is_univalent_total_category. - apply is_univalent_total_category. + apply base_category_univalent, HD. + apply step1_disp_univalent. - apply functor_disp_cat_univalent. Defined. End FunctorsDisplayed. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Functors.v000066400000000000000000000445611451125700300243610ustar00rootroot00000000000000 Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope cat. (** ** Functors over functors between bases *) (** One could define these in terms of functor-liftings, as: [[ Definition disp_functor {C C' : category} (F : functor C C') (D : disp_cat C) (D' : disp_cat C') := functor_lifting D' (functor_composite (pr1_category D) F). ]] However, it seems like it may probably be cleaner to define these independently. TODO: reassess this design decision after some experience using it! *) Section Disp_Functor. Definition disp_functor_data {C' C : precategory_data} (F : functor_data C' C) (D' : disp_cat_data C') (D : disp_cat_data C) := ∑ (Fob : ∏ x, D' x -> D (F x)), ∏ x y (xx : D' x) (yy : D' y) (f : x --> y), (xx -->[f] yy) -> (Fob _ xx -->[ # F f ] Fob _ yy). Definition disp_functor_on_objects {C' C : precategory_data} {F : functor_data C' C} {D' : disp_cat_data C'} {D : disp_cat_data C} (FF : disp_functor_data F D' D) {x : C'} (xx : D' x) : D (F x) := pr1 FF x xx. Coercion disp_functor_on_objects : disp_functor_data >-> Funclass. (** Unfortunately, the coercion loses implicitness of the {x:C'} argument: we have to write [ FF _ xx ] instead of just [ FF xx ]. If anyone knows a way to avoid this, we would be happy to hear it! *) Definition disp_functor_on_morphisms {C' C : precategory_data} {F : functor_data C' C} {D' : disp_cat_data C'} {D : disp_cat_data C} (FF : disp_functor_data F D' D) {x y : C'} {xx : D' x} {yy} {f : x --> y} (ff : xx -->[f] yy) : (FF _ xx) -->[ # F f ] (FF _ yy) := pr2 FF x y xx yy f ff. Local Open Scope mor_disp_scope. (* To input ♯ using agda-mode type \# or \sharp *) Notation "♯ F" := (disp_functor_on_morphisms F) (at level 3) : mor_disp_scope. Definition disp_functor_axioms {C' C : category} {F : functor C' C} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor_data F D' D) := (∏ x (xx : D' x), ♯ FF (id_disp xx) = transportb _ (functor_id F x) (id_disp (FF _ xx))) × (∏ x y z (xx : D' x) yy zz (f : x --> y) (g : y --> z) (ff : xx -->[f] yy) (gg : yy -->[g] zz), ♯ FF (ff ;; gg) = transportb _ (functor_comp F f g) (♯ FF ff ;; ♯ FF gg)). Lemma isaprop_disp_functor_axioms {C' C : category} {F : functor C' C} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor_data F D' D) : isaprop (disp_functor_axioms FF). Proof. apply isapropdirprod; repeat (apply impred; intros); apply homsets_disp. Qed. Definition disp_functor {C' C : category} (F : functor C' C) (D' : disp_cat C') (D : disp_cat C) := ∑ FF : disp_functor_data F D' D, disp_functor_axioms FF. Definition disp_functor_data_from_disp_functor {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) : disp_functor_data F D' D := pr1 FF. Coercion disp_functor_data_from_disp_functor : disp_functor >-> disp_functor_data. Definition disp_functor_id {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) {x} (xx : D' x) : ♯ FF (id_disp xx) = transportb _ (functor_id F x) (id_disp (FF _ xx)) := pr1 (pr2 FF) x xx. Proposition disp_functor_id_var {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) {x : C₁} (xx : D₁ x) : id_disp (FF x xx) = transportf (λ z, _ -->[ z ] _) (functor_id F x) (♯ FF (id_disp xx)). Proof. rewrite disp_functor_id. rewrite transportfbinv. apply idpath. Qed. Definition disp_functor_comp {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) {x y z} {xx : D' x} {yy} {zz} {f : x --> y} {g : y --> z} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : ♯ FF (ff ;; gg) = transportb _ (functor_comp F f g) (♯ FF ff ;; ♯ FF gg) := pr2 (pr2 FF) _ _ _ _ _ _ _ _ ff gg. (** variant access function *) Definition disp_functor_comp_var {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) {x y z} {xx : D' x} {yy} {zz} {f : x --> y} {g : y --> z} (ff : xx -->[f] yy) (gg : yy -->[g] zz) : transportf _ (functor_comp F f g) (♯ FF (ff ;; gg)) = ♯ FF ff ;; ♯ FF gg. Proof. apply transportf_pathsinv0. apply pathsinv0, disp_functor_comp. Defined. (** Useful transport lemma for [disp_functor]. *) Lemma disp_functor_eq {C C':category} {F: functor C C'} {D:disp_cat C} {D':disp_cat C'} (DF DF': disp_functor F D D') : pr1 DF = pr1 DF' -> DF = DF'. Proof. intro H. apply (total2_paths_f H). apply proofirrelevance. apply isaprop_disp_functor_axioms. Defined. Lemma disp_functor_transportf {C' C : category} {D' : disp_cat C'} {D : disp_cat C} (F : functor C' C) (FF : disp_functor F D' D) (x' x : C') (f' f : x' --> x) (p : f' = f) (xx' : D' x') (xx : D' x) (ff : xx' -->[ f' ] xx) : ♯ FF (transportf _ p ff) = transportf _ (maponpaths (# F) p) (♯FF ff). Proof. induction p. apply idpath. Defined. (** ** Composite and identity functors. *) Definition disp_functor_composite_data {C C' C'' : category} {D} {D'} {D''} {F : functor C C'} {F' : functor C' C''} (FF : disp_functor F D D') (FF' : disp_functor F' D' D'') : disp_functor_data (functor_composite F F') D D''. Proof. use tpair. + intros x xx. exact (FF' _ (FF _ xx)). + intros x y xx yy f ff. exact (♯ FF' (♯ FF ff)). Defined. Lemma disp_functor_composite_axioms {C C' C'' : category} {D} {D'} {D''} {F : functor C C'} {F' : functor C' C''} (FF : disp_functor F D D') (FF' : disp_functor F' D' D'') : disp_functor_axioms (disp_functor_composite_data FF FF'). Proof. split; simpl. + intros x xx. etrans. apply maponpaths. apply disp_functor_id. etrans. apply disp_functor_transportf. etrans. apply maponpaths. apply disp_functor_id. etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. + intros. etrans. apply maponpaths. apply disp_functor_comp. etrans. apply disp_functor_transportf. etrans. apply maponpaths. apply disp_functor_comp. etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Qed. Definition disp_functor_composite {C C' C'' : category} {D} {D'} {D''} {F : functor C C'} {F' : functor C' C''} (FF : disp_functor F D D') (FF' : disp_functor F' D' D'') : disp_functor (functor_composite F F') D D''. Proof. use tpair. - apply (disp_functor_composite_data FF FF'). - apply disp_functor_composite_axioms. Defined. Definition disp_functor_identity {C : category} (D : disp_cat C) : disp_functor (functor_identity _ ) D D. Proof. use tpair. - use tpair. + intros; assumption. + cbn. intros. assumption. - split; simpl. + intros; apply idpath. + intros; apply idpath. Defined. (** ** Action of functors on z_isos. *) Section Functors_on_z_isos. (* TODO: functor_on_inv_from_z_iso should have implicit arguments *) Lemma disp_functor_on_z_iso_disp_aux1 {C C'} {F} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') {x y} {xx : D x} {yy} {f : z_iso x y} (ff : xx -->[f] yy) (Hff : is_z_iso_disp f ff) : transportf _ (functor_on_inv_from_z_iso F f) (♯ FF (inv_mor_disp_from_z_iso Hff)) ;; ♯ FF ff = transportb _ (z_iso_after_z_iso_inv _) (id_disp _). Proof. etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths, @pathsinv0, disp_functor_comp_var. etrans. apply transport_f_f. etrans. apply maponpaths, maponpaths, z_iso_disp_after_inv_mor. etrans. apply maponpaths, disp_functor_transportf. etrans. apply transport_f_f. etrans. apply maponpaths, disp_functor_id. etrans. apply transport_f_b. unfold transportb. apply maponpaths_2, homset_property. Qed. Lemma disp_functor_on_z_iso_disp_aux2 {C C'} {F} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') {x y} {xx : D x} {yy} {f : z_iso x y} (ff : xx -->[f] yy) (Hff : is_z_iso_disp f ff) : ♯ FF ff ;; transportf _ (functor_on_inv_from_z_iso F f) (♯ FF (inv_mor_disp_from_z_iso Hff)) = transportb _ (z_iso_inv_after_z_iso (functor_on_z_iso _ _)) (id_disp (FF x xx)). Proof. etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths, @pathsinv0, disp_functor_comp_var. etrans. apply transport_f_f. etrans. apply maponpaths, maponpaths, inv_mor_after_z_iso_disp. etrans. apply maponpaths, disp_functor_transportf. etrans. apply transport_f_f. etrans. apply maponpaths, disp_functor_id. etrans. apply transport_f_f. unfold transportb. apply maponpaths_2, homset_property. Qed. (** Let's see how [disp_functor]s behave on [z_iso_disp]s *) (** TODO: consider naming *) (* Undelimit Scope transport. *) Definition disp_functor_on_is_z_iso_disp {C C'} {F} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') {x y} {xx : D x} {yy} {f : z_iso x y} {ff : xx -->[f] yy} (Hff : is_z_iso_disp f ff) : is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff). Proof. exists (transportf _ (functor_on_inv_from_z_iso F f) (♯ FF (inv_mor_disp_from_z_iso Hff))); split. - apply disp_functor_on_z_iso_disp_aux1. - apply disp_functor_on_z_iso_disp_aux2. Defined. Definition disp_functor_on_z_iso_disp {C C'} {F} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') {x y} {xx : D x} {yy} {f : z_iso x y} (ff : z_iso_disp f xx yy) : z_iso_disp (functor_on_z_iso F f) (FF _ xx) (FF _ yy) := (_ ,, disp_functor_on_is_z_iso_disp _ ff). End Functors_on_z_isos. (** ** Properties of functors *) Section Functor_Properties. Definition disp_functor_ff {C C'} {F} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') := ∏ x y (xx : D x) (yy : D y) (f : x --> y), isweq (fun ff : xx -->[f] yy => ♯ FF ff). Proposition isaprop_disp_functor_ff {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : isaprop (disp_functor_ff FF). Proof. do 5 (use impred ; intro). apply isapropisweq. Qed. Section ff_reflects_isos. (* TODO: Try making FF implicit, since it can be inferred from [FF_ff]. *) Context {C C' : category} {F : functor C C'} {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D') (FF_ff : disp_functor_ff FF). Definition disp_functor_ff_weq {x y} xx yy f := make_weq _ (FF_ff x y xx yy f). Definition disp_functor_ff_inv {x y} {xx} {yy} {f : x --> y} := invmap (disp_functor_ff_weq xx yy f). (* TODO: add a general version [disp_functor_ff_inv_transportf], where the transportf on the LHS is arbitrary. *) Lemma disp_functor_ff_inv_transportf {x y : C} {f f' : x --> y} (e : f = f') {xx : D x} {yy : D y} (ff : FF _ xx -->[#F f] FF _ yy) : disp_functor_ff_inv (transportf _ (maponpaths (# F) e) ff) = transportf _ e (disp_functor_ff_inv ff). Proof. induction e. apply idpath. Qed. (* TODO: move the transport to the RHS. *) Lemma disp_functor_ff_inv_identity {x : C} (xx : D x) : disp_functor_ff_inv (transportb _ (functor_id F _ ) (id_disp (FF _ xx))) = id_disp xx. Proof. apply invmap_eq. apply pathsinv0. apply (disp_functor_id FF). Qed. (* TODO: move the transport to the RHS. *) Lemma disp_functor_ff_inv_compose {x y z : C} {f : x --> y} {g : y --> z} {xx} {yy} {zz} (ff : FF _ xx -->[#F f] FF _ yy) (gg : FF _ yy -->[#F g] FF _ zz) : disp_functor_ff_inv (transportb _ (functor_comp F _ _ ) (ff ;; gg)) = disp_functor_ff_inv ff ;; disp_functor_ff_inv gg. Proof. apply invmap_eq. cbn. apply pathsinv0. etrans. apply (disp_functor_comp FF). apply maponpaths. etrans. apply maponpaths. exact (homotweqinvweq _ _). apply maponpaths_2. exact (homotweqinvweq _ _). Qed. Definition disp_functor_ff_reflects_isos {x y} {xx : D x} {yy : D y} {f : z_iso x y} (ff : xx -->[f] yy) (isiso: is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff)) : is_z_iso_disp _ ff. Proof. set (FFffinv := inv_mor_disp_from_z_iso isiso). set (FFffinv' := transportb _ (functor_on_inv_from_z_iso _ _ ) FFffinv). set (ffinv := disp_functor_ff_inv FFffinv'). exists ffinv. split. - unfold ffinv. unfold FFffinv'. admit. - admit. Abort. End ff_reflects_isos. Proposition FF_disp_functor_ff_inv {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {FF : disp_functor F D₁ D₂} (HFF : disp_functor_ff FF) {x y : C₁} {f : x --> y} {xx : D₁ x} {yy : D₁ y} (ff : FF x xx -->[ (#F f)%Cat ] FF y yy) : ♯FF (disp_functor_ff_inv FF HFF ff) = ff. Proof. apply (homotweqinvweq ((disp_functor_ff_weq FF HFF xx yy f))). Qed. (** Given a base functor [F : C —> C'] and a displayed functor [FF : D' -> D] over it, there are two different “essential surjectivity” conditions one can put on [FF]. Given [c : C] and [d : D' (F c)], one can ask for a lift of [d] either in [D c] itself, or more generally in some fiber [D c'] with [c'] isomorphic to [c]. The second version is better-behaved in general; but the stricter first version is equivalent when [D] is an isofibration, and is simpler to work with. So we call the second version “essentially split surjective”, [disp_functor_ess_split_surj], and the first “displayed ess. split surj.”, [disp_functor_disp_ess_split_surj]. *) Definition disp_functor_ess_split_surj {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D D') : UU := ∏ x (xx : D' (F x)), ∑ y : C, ∑ i : z_iso y x, ∑ yy : D y, z_iso_disp (functor_on_z_iso F i) (FF _ yy) xx. Definition disp_functor_disp_ess_split_surj {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D D') : UU := ∏ x (xx : D' (F x)), ∑ (yy : D x), z_iso_disp (identity_z_iso _) (FF _ yy) xx. (* TODO: add access functions for these. *) Definition disp_functor_disp_ess_surj {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : hProp := ∀ (x : C₁) (yy : D₂ (F x)), ∃ (xx : D₁ x), z_iso_disp (identity_z_iso _) (FF x xx) yy. End Functor_Properties. End Disp_Functor. (* Redeclare notations globally: *) Local Open Scope mor_disp_scope. Notation "♯ F" := (disp_functor_on_morphisms F) (at level 3) : mor_disp_scope. #[deprecated(note="Use '♯' (input: \# or \sharp) instead.")] Notation "# F" := ♯ F (only parsing) : mor_disp_scope. (** Operations on displayed functors/transformations over the identity *) Section CompDispFunctorOverIdentity. Context {C : category} {D₁ D₂ D₃ : disp_cat C} (FF : disp_functor (functor_identity C) D₁ D₂) (GG : disp_functor (functor_identity C) D₂ D₃). Definition disp_functor_over_id_composite_data : disp_functor_data (functor_identity C) D₁ D₃. Proof. simple refine (_ ,, _). - exact (λ x xx, GG x (FF x xx)). - exact (λ x y xx yy f ff, (♯GG (♯FF ff))). Defined. Definition disp_functor_over_id_composite_axioms : disp_functor_axioms disp_functor_over_id_composite_data. Proof. split. - intros x xx ; cbn. rewrite (disp_functor_id FF) ; cbn. rewrite (disp_functor_id GG) ; cbn. apply idpath. - intros x y z xx yy zz f g ff gg ; cbn. etrans. { apply maponpaths. exact (disp_functor_comp FF ff gg). } cbn. exact (disp_functor_comp GG (♯ FF ff) (♯ FF gg)). Qed. Definition disp_functor_over_id_composite : disp_functor (functor_identity C) D₁ D₃. Proof. simple refine (_ ,, _). - exact disp_functor_over_id_composite_data. - exact disp_functor_over_id_composite_axioms. Defined. End CompDispFunctorOverIdentity. (** Various lemmas *) Proposition pr1_idtoiso_disp_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) {x : C₁} {xx yy : D₁ x} (p : xx = yy) : pr1 (idtoiso_disp (idpath (F x)) (maponpaths (FF x) p)) = transportf (λ z, _ -->[ z ] _) (functor_id F _) (♯FF (idtoiso_disp (idpath x) p)). Proof. induction p. cbn. rewrite disp_functor_id. rewrite transportfbinv. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Isos.v000066400000000000000000000565471451125700300235020ustar00rootroot00000000000000 Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Local Open Scope cat. Local Open Scope mor_disp_scope. (** ** Isomorphisms (and lemmas) *) Section Isos. Definition is_disp_inverse {C : precategory} {D : disp_cat_data C} {x y : C} {f : x --> y} {g: y --> x} (isinv: is_inverse_in_precat f g) {xx : D x} {yy : D y} (ff : xx -->[f] yy) (gg : yy -->[g] xx) : UU := gg ;; ff = transportb _ (pr2 isinv) (id_disp yy) × ff ;; gg = transportb _ (pr1 isinv) (id_disp xx). Definition is_z_iso_disp {C : precategory} {D : disp_cat_data C} {x y : C} (f : z_iso x y) {xx : D x} {yy} (ff : xx -->[f] yy) : UU := ∑ (gg : yy -->[inv_from_z_iso f] xx), is_disp_inverse (z_iso_is_inverse_in_precat f) ff gg. Definition z_iso_disp {C : precategory} {D : disp_cat_data C} {x y : C} (f : z_iso x y) (xx : D x) (yy : D y) := ∑ ff : xx -->[f] yy, is_z_iso_disp f ff. Definition make_z_iso_disp {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y} {xx : D x} {yy : D y} (ff : xx -->[f] yy) (is : is_z_iso_disp f ff) : z_iso_disp _ _ _ := (ff,, is). Definition mor_disp_from_z_iso {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} (i : z_iso_disp f xx yy) : _ -->[ _ ] _ := pr1 i. Coercion mor_disp_from_z_iso : z_iso_disp >-> mor_disp. Definition is_z_iso_disp_from_z_iso {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} (i : z_iso_disp f xx yy) : is_z_iso_disp f i := pr2 i. Coercion is_z_iso_disp_from_z_iso : z_iso_disp >-> is_z_iso_disp. Definition inv_mor_disp_from_z_iso {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} {ff : xx -->[f] yy} (i : is_z_iso_disp f ff) : _ -->[ _ ] _ := pr1 i. Definition z_iso_disp_after_inv_mor {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} {ff : xx -->[f] yy} (i : is_z_iso_disp f ff) : inv_mor_disp_from_z_iso i ;; ff = transportb _ (z_iso_after_z_iso_inv _) (id_disp _). Proof. apply (pr2 i). Qed. Definition inv_mor_after_z_iso_disp {C : precategory} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} {ff : xx -->[f] yy} (i : is_z_iso_disp f ff) : ff ;; inv_mor_disp_from_z_iso i = transportb _ (z_iso_inv_after_z_iso _) (id_disp _). Proof. apply (pr2 (pr2 i)). Qed. Lemma isaprop_is_disp_inverse {C : category} {D : disp_cat C} {x y : C} (f : x --> y) (g: y --> x) (isinv: is_inverse_in_precat f g) {xx : D x} {yy : D y} (ff : xx -->[f] yy) (gg : yy -->[g] xx) : isaprop (is_disp_inverse isinv ff gg). Proof. apply isapropdirprod; apply homsets_disp. Qed. Lemma isaprop_is_z_iso_disp {C : category} {D : disp_cat C} {x y : C} (f : z_iso x y) {xx : D x} {yy} (ff : xx -->[f] yy) : isaprop (is_z_iso_disp f ff). Proof. apply invproofirrelevance; intros i i'. apply subtypePath. - intros gg. apply isaprop_is_disp_inverse. (* uniqueness of inverses *) (* TODO: think about better lemmas for this sort of calculation? e.g. all that repeated application of [transport_f_f], etc. *) - destruct i as [gg [gf fg]], i' as [gg' [gf' fg']]; simpl. etrans. eapply pathsinv0, transportfbinv. etrans. apply maponpaths, @pathsinv0, id_right_disp. etrans. apply maponpaths, maponpaths. etrans. eapply pathsinv0, transportfbinv. apply maponpaths, @pathsinv0, fg'. etrans. apply maponpaths, mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths, assoc_disp. etrans. apply transport_f_f. etrans. apply maponpaths, maponpaths_2, gf. etrans. apply maponpaths, mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths, id_left_disp. etrans. apply transport_f_f. use (@maponpaths_2 _ _ _ (transportf _) _ (idpath _)). apply homset_property. Qed. Lemma isaset_z_iso_disp {C : category} {D : disp_cat C} {x y} (f : z_iso x y) (xx : D x) (yy : D y) : isaset (z_iso_disp f xx yy). Proof. apply isaset_total2. - apply homsets_disp. - intros. apply isasetaprop, isaprop_is_z_iso_disp. Qed. Lemma eq_z_iso_disp {C : category} {D : disp_cat C} {x y : C} (f : z_iso x y) {xx : D x} {yy} (ff ff' : z_iso_disp f xx yy) : pr1 ff = pr1 ff' -> ff = ff'. Proof. apply subtypePath; intro; apply isaprop_is_z_iso_disp. Qed. Lemma is_z_iso_disp_transportf {C : category} {D : disp_cat C} {x y : C} {f f' : z_iso x y} (e : f = f') {xx : D x} {yy} {ff : xx -->[f] yy} (is : is_z_iso_disp _ ff) : is_z_iso_disp f' (transportf _ (maponpaths _ e) ff). Proof. induction e. apply is. Qed. Lemma transportf_z_iso_disp {C : category} {D : disp_cat C} {x y : C} {xx : D x} {yy} {f f' : z_iso x y} (e : f = f') (ff : z_iso_disp f xx yy) : pr1 (transportf (λ g, z_iso_disp g _ _) e ff) = transportf _ (maponpaths pr1 e) (pr1 ff). Proof. destruct e; apply idpath. Qed. Definition is_z_iso_inv_from_z_iso_disp {C : category} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} (i : z_iso_disp f xx yy) : is_z_iso_disp (z_iso_inv_from_z_iso f) (inv_mor_disp_from_z_iso i). Proof. use tpair. - change ( xx -->[ z_iso_inv_from_z_iso (z_iso_inv_from_z_iso f)] yy). set (XR := transportb (mor_disp xx yy ) (maponpaths pr1 (z_iso_inv_z_iso_inv _ _ f))). apply XR. apply i. - cbn. split. + abstract ( etrans ;[ apply mor_disp_transportf_postwhisker |]; etrans ; [ apply maponpaths; apply (inv_mor_after_z_iso_disp i) | ]; etrans ;[ apply transport_f_f |]; apply transportf_comp_lemma; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath ). + abstract ( etrans ;[ apply mor_disp_transportf_prewhisker |]; etrans ;[ apply maponpaths; apply (z_iso_disp_after_inv_mor i) |]; etrans ;[ apply transport_f_f |]; apply transportf_comp_lemma; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath ). Defined. Definition is_z_iso_inv_from_is_z_iso_disp {C : category} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} (ff : xx -->[f] yy) (i : is_z_iso_disp f ff) : is_z_iso_disp (z_iso_inv_from_z_iso f) (inv_mor_disp_from_z_iso i). Proof. apply (is_z_iso_inv_from_z_iso_disp (ff ,, i)). Defined. Definition z_iso_inv_from_z_iso_disp {C : category} {D : disp_cat_data C} {x y : C} {f : z_iso x y}{xx : D x} {yy : D y} (i : z_iso_disp f xx yy) : z_iso_disp (z_iso_inv_from_z_iso f) yy xx. Proof. exists (inv_mor_disp_from_z_iso i). apply is_z_iso_inv_from_z_iso_disp. Defined. Definition z_iso_disp_comp {C : category} {D : disp_cat C} {x y z : C} {f : z_iso x y} {g : z_iso y z} {xx : D x} {yy : D y} {zz : D z} (ff : z_iso_disp f xx yy) (gg : z_iso_disp g yy zz) : z_iso_disp (z_iso_comp f g) xx zz. Proof. use tpair. - apply (ff ;; gg). - use tpair. + apply (transportb (mor_disp zz xx) (maponpaths pr1 (z_iso_inv_of_z_iso_comp _ _ _ f g))). cbn. apply (inv_mor_disp_from_z_iso gg ;; inv_mor_disp_from_z_iso ff). + split. * etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. apply assoc_disp_var. etrans. apply maponpaths, maponpaths, maponpaths. apply assoc_disp. etrans. apply maponpaths, maponpaths, maponpaths, maponpaths. eapply (maponpaths (λ x, x ;; gg)). apply z_iso_disp_after_inv_mor. etrans. apply transport_f_f. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths, maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths, maponpaths. apply id_left_disp. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply z_iso_disp_after_inv_mor. etrans. apply transport_f_f. apply transportf_comp_lemma; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * cbn. simpl. etrans. apply assoc_disp_var. etrans. apply maponpaths, maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths, maponpaths, maponpaths. apply assoc_disp. etrans. apply maponpaths, maponpaths, maponpaths, maponpaths. eapply (maponpaths (λ x, x ;; inv_mor_disp_from_z_iso ff )). apply inv_mor_after_z_iso_disp. etrans. apply maponpaths, maponpaths, maponpaths, maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths, maponpaths, maponpaths, maponpaths, maponpaths. apply id_left_disp. etrans. apply maponpaths, maponpaths. apply transport_f_f. etrans. apply maponpaths, maponpaths. apply transport_f_f. etrans. apply maponpaths, maponpaths. apply transport_f_f. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply inv_mor_after_z_iso_disp. etrans. apply transport_f_f. apply transportf_comp_lemma; apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Defined. Definition id_is_z_iso_disp {C} {D : disp_cat C} {x : C} (xx : D x) : is_z_iso_disp (identity_z_iso x) (id_disp xx). Proof. exists (id_disp _); split. - etrans. apply id_left_disp. apply maponpaths_2, homset_property. - etrans. apply id_left_disp. apply maponpaths_2, homset_property. Defined. Definition identity_z_iso_disp {C} {D : disp_cat C} {x : C} (xx : D x) : z_iso_disp (identity_z_iso x) xx xx := (_ ,, id_is_z_iso_disp _). Lemma idtoiso_disp {C} {D : disp_cat C} {x x' : C} (e : x = x') {xx : D x} {xx' : D x'} (ee : transportf _ e xx = xx') : z_iso_disp (idtoiso e) xx xx'. Proof. destruct e, ee; apply identity_z_iso_disp. Defined. Lemma idtoiso_fiber_disp {C} {D : disp_cat C} {x : C} {xx xx' : D x} (ee : xx = xx') : z_iso_disp (identity_z_iso x) xx xx'. Proof. exact (idtoiso_disp (idpath _) ee). Defined. Lemma z_iso_disp_precomp {C : category} {D : disp_cat C} {x y : C} (f : z_iso x y) {xx : D x} {yy} (ff : z_iso_disp f xx yy) : forall (y' : C) (f' : y --> y') (yy' : D y'), isweq (fun ff' : yy -->[ f' ] yy' => pr1 ff ;; ff'). Proof. intros y' f' yy'. use isweq_iso. + intro X. set (XR := (pr1 (pr2 ff)) ;; X). set (XR' := transportf _ (assoc _ _ _ ) XR). set (XRRT := transportf _ (maponpaths (λ xyz, xyz · f') (z_iso_after_z_iso_inv f)) XR'). set (XRRT' := transportf _ (id_left _ ) XRRT). apply XRRT'. + intros. simpl. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths_2. apply (pr2 (pr2 ff)). etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_left_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply C. apply idpath. + intros; simpl. etrans. apply maponpaths. apply transport_f_f. etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths_2. assert (XR := pr2 (pr2 (pr2 ff))). simpl in XR. apply XR. etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_left_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply C. apply idpath. Defined. Lemma z_iso_disp_postcomp {C : category} {D : disp_cat C} {x y : C} (i : z_iso x y) {xx : D x} {yy} (ii : z_iso_disp i xx yy) : forall (x' : C) (f' : x' --> x) (xx' : D x'), isweq (fun ff : xx' -->[ f' ] xx => ff ;; ii)%mor_disp. Proof. intros y' f' yy'. use isweq_iso. + intro X. set (XR := X ;; (pr1 (pr2 ii))). set (XR' := transportf (λ x, _ -->[ x ] _) (!assoc _ _ _ ) XR). set (XRRT := transportf (λ x, _ -->[ x ] _ ) (maponpaths (λ xyz, _ · xyz) (z_iso_inv_after_z_iso _ )) XR'). set (XRRT' := transportf _ (id_right _ ) XRRT). apply XRRT'. + intros. simpl. etrans. apply transport_f_f. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp_var. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths. apply (pr2 (pr2 (pr2 ii))). etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_right_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply C. apply idpath. + intros; simpl. etrans. apply maponpaths_2. apply transport_f_f. etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths. apply mor_disp_transportf_postwhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply assoc_disp_var. etrans. apply transport_f_f. etrans. apply maponpaths. apply maponpaths. assert (XR := pr1 (pr2 (pr2 ii))). simpl in XR. apply XR. etrans. apply maponpaths. apply mor_disp_transportf_prewhisker. etrans. apply transport_f_f. etrans. apply maponpaths. apply id_right_disp. etrans. apply transport_f_f. apply transportf_comp_lemma_hset. apply C. apply idpath. Defined. (* Useful when you want to prove [is_z_iso_disp], and you have some lemma [awesome_lemma] which gives that, but over a different (or just opaque) proof of [is_z_isomorphism] in the base. Then you can use [eapply is_z_iso_disp_independent_of_is_z_iso; apply awesome_lemma.]. *) Lemma is_z_iso_disp_independent_of_is_z_iso {C : category} {D : disp_cat_data C} {x y : C} (f : z_iso x y) {xx : D x} {yy} (ff : xx -->[f] yy) {H'f : is_z_isomorphism f} (Hff : is_z_iso_disp ((f : _ --> _),,H'f) ff) : is_z_iso_disp f ff. Proof. destruct f as [F Hf]. assert (E : Hf = H'f). apply isaprop_is_z_isomorphism. destruct E. exact Hff. Qed. End Isos. (** ** More utility lemmas *) (** A few more general lemmas for displayed-cat algebra, that require isomorphisms to state. *) Section Utilities. (** Note: closely analogous to [idtoiso_precompose]. We name it differently to fit the convention of naming equalities according to their LHS, for reference during calculation. *) Lemma transportf_precompose_disp {C} {D : disp_cat C} {c d : C} (f : c --> d ) {cc cc' : D c} (e : cc = cc') {dd} (ff : cc -->[f] dd) : transportf (λ xx : D c, xx -->[f] dd) e ff = transportf _ (id_left _) (z_iso_inv_from_z_iso_disp (idtoiso_disp (idpath _) (e)) ;; ff). Proof. destruct e; cbn. rewrite (@id_left_disp _ _ _ _ _ cc). apply pathsinv0, transportfbinv. Qed. (* TODO: add dual [transportf_postcompose_disp]. *) Definition precomp_with_z_iso_disp_is_inj {C : category} {D : disp_cat C} {a b c : C} {i : z_iso a b} {f : b --> c} {aa : D a} {bb} {cc} (ii : z_iso_disp i aa bb) {ff ff' : bb -->[f] cc} : (ii ;; ff = ii ;; ff') -> ff = ff'. Proof. intros e. use pathscomp0. - use (transportf _ _ ((z_iso_inv_from_z_iso_disp ii ;; ii) ;; ff)). etrans; [ apply maponpaths_2, z_iso_after_z_iso_inv | apply id_left ]. - apply pathsinv0. etrans. eapply transportf_bind. eapply cancel_postcomposition_disp, (z_iso_disp_after_inv_mor ii). rewrite (@id_left_disp _ _ _ _ _ bb). etrans. apply transport_f_f. use (@maponpaths_2 _ _ _ _ _ (idpath _)). apply homset_property. - etrans. eapply transportf_bind, assoc_disp_var. rewrite e. etrans. eapply transportf_bind, assoc_disp. etrans. eapply transportf_bind. eapply cancel_postcomposition_disp, (z_iso_disp_after_inv_mor ii). rewrite id_left_disp. etrans. apply transport_f_f. use (@maponpaths_2 _ _ _ _ _ (idpath _)). apply homset_property. Qed. (* TODO: add dual [postcomp_with_iso_disp_is_inj]. *) Definition postcomp_with_z_iso_disp_is_inj {C : category} {D : disp_cat C} {x y z : C} {f : x --> y} {g : x --> y} {h : y --> z} (Hh : is_z_isomorphism h) (p : f = g) {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] yy} {gg : xx -->[ g ] yy} {hh : yy -->[ h ] zz} (Hhh : is_z_iso_disp (h ,, Hh) hh) (pp : (ff ;; hh = transportb (λ z, _ -->[ z ] _) (maponpaths (λ z, _ · h) p) (gg ;; hh))%mor_disp) : ff = transportb _ p gg. Proof. refine (id_right_disp_var _ @ _). pose (transportb_transpose_left (inv_mor_after_z_iso_disp Hhh)) as q. etrans. { do 2 apply maponpaths. exact (!q). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact pp. } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. exact (inv_mor_after_z_iso_disp Hhh). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite id_right_disp. unfold transportb. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. End Utilities. (** Displayed isomorphisms are closed under transporting *) Definition is_z_iso_disp_transportf_fun_eq {C : category} {D : disp_cat C} {x y : C} {f g : z_iso x y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (p : pr1 f = pr1 g) (Hff : is_z_iso_disp f ff) : is_z_iso_disp g (transportf (λ z, _ -->[ z ] _) p ff). Proof. simple refine (_ ,, _ ,, _). - refine (transportf (λ z, _ -->[ z ] _) _ (inv_mor_disp_from_z_iso Hff)). abstract (induction f as [ f Hf ] ; induction g as [ g Hg ] ; cbn in * ; induction p ; do 2 apply maponpaths ; apply isaprop_is_z_isomorphism). - abstract (induction f as [ f Hf ] ; induction g as [ g Hg ] ; cbn in * ; induction p ; cbn ; rewrite mor_disp_transportf_postwhisker ; refine (maponpaths _ (z_iso_disp_after_inv_mor Hff) @ _) ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). - abstract (induction f as [ f Hf ] ; induction g as [ g Hg ] ; cbn in * ; induction p ; cbn ; rewrite mor_disp_transportf_prewhisker ; refine (maponpaths _ (inv_mor_after_z_iso_disp Hff) @ _) ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). Defined. Definition is_z_iso_disp_transportb_fun_eq {C : category} {D : disp_cat C} {x y : C} (f : z_iso x y) {g : z_iso x y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (p : pr1 g = pr1 f) (Hff : is_z_iso_disp f ff) : is_z_iso_disp g (transportb (λ z, _ -->[ z ] _) p ff). Proof. apply is_z_iso_disp_transportf_fun_eq. exact Hff. Defined. Definition disp_z_iso_inv_on_left {C : category} {D : disp_cat C} {x y z : C} {f : x --> y} {g : y --> z} {h : x --> z} (Hf : is_z_isomorphism f) {xx : D x} {yy : D y} {zz : D z} {ff : xx -->[ f ] yy} {gg : yy -->[ g ] zz} {hh : xx -->[ h ] zz} (Hff : is_z_iso_disp (f ,, Hf) ff) (p : f · g = h) : gg = transportf _ (z_iso_inv_on_right _ _ _ (f,,Hf) g h (! p)) (pr1 Hff ;; hh) -> ff ;; gg = transportb _ p hh. Proof. intro q. rewrite q. clear q. rewrite mor_disp_transportf_prewhisker. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact (pr2 (pr2 Hff)). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. etrans. { apply maponpaths_2. refine (_ @ idpath (id_left _)). apply homset_property. } apply pathsinv0, id_left_disp_var. Qed. Definition disp_z_iso_inv_on_right {C : category} {D : disp_cat C} {x y z : C} {f : x --> y} {g : y --> z} {h : x --> z} (Hg : is_z_isomorphism g) {xx : D x} {yy : D y} {zz : D z} (ff : xx -->[ f ] yy) {gg : yy -->[ g ] zz} (hh : xx -->[ h ] zz) (Hgg : is_z_iso_disp (g ,, Hg) gg) (p : f · g = h) : ff = transportb _ (z_iso_inv_on_left _ _ _ f (g,,Hg) h (! p)) (hh ;; pr1 Hgg) -> ff ;; gg = transportb _ p hh. Proof. intro q. rewrite q. clear q. unfold transportb. rewrite mor_disp_transportf_postwhisker. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. exact (pr1 (pr2 Hgg)). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { apply maponpaths_2. refine (_ @ idpath (id_right _)). apply homset_property. } apply pathsinv0, id_right_disp_var. Qed. Lemma precomp_disp_id_left_inj {C : category} {D : disp_cat C} {y z : C} {f : C⟦y,z⟧} {yy : D y} {zz : D z} (ff1 ff2 : yy -->[f] zz) : id_disp yy ;; ff1 = id_disp yy ;; ff2 → ff1 = ff2. Proof. intro p. rewrite ! id_left_disp in p. refine (transportb_transpose_right p @ _). rewrite transport_b_b. use transportf_set. apply homset_property. Qed. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Limits.v000066400000000000000000000063001451125700300240040ustar00rootroot00000000000000(** Limits *) Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope type_scope. Local Open Scope mor_disp_scope. Section Creates_Limits. (* TODO: consider implicitness of argument *) Definition creates_limit {C : category} (D : disp_cat C) {J : graph} (F : diagram J (total_category D)) {x : C} (L : cone (mapdiagram (pr1_category D) F) x) (isL : isLimCone _ x L) : UU := ∑ (CC : iscontr ( ∑ (d : D x) (δ : ∏ j : vertex J, d -->[coneOut L j] (pr2 (dob F j))), forms_cone(c:=(x,,d)) F (λ j, (coneOut L j ,, δ j)))) , isLimCone _ _ (make_cone _ (pr2 (pr2 (iscontrpr1 CC)))). Definition creates_limits {C : category} (D : disp_cat C) : UU := ∏ (J : graph) (F : diagram J (total_category D)) (x : C) (L : cone (mapdiagram (pr1_category D) F) x) (isL : isLimCone _ x L), creates_limit _ _ _ isL. End Creates_Limits. Section creates_preserves. Context {C : category} (D : disp_cat C) (H : creates_limits D) (J : graph) (X : Lims_of_shape J C). Notation π := (pr1_category D). Definition total_limits : Lims_of_shape J (total_category D). Proof. intro d. set (πd := mapdiagram π d). set (LL := X πd). set (L := pr1 LL). set (c := pr1 L). set (isL := pr2 LL). cbn in isL. set (XR := H _ d _ _ isL). unfold creates_limit in XR. cbn. use (make_LimCone _ _ _ (pr2 XR)). Defined. Lemma pr1_preserves_limit (d : diagram J (total_category D)) (x : total_category D) (CC : cone d x) : preserves_limit π _ x CC. Proof. intro H1. set (XR := X (mapdiagram π d)). use is_z_iso_isLim. - apply X. - match goal with |[ |- is_z_isomorphism ?foo ] => set (T:= foo) end. destruct X as [[a L] isL]. cbn in isL. clear XR. set (tL := H _ _ _ _ isL). unfold creates_limit in tL. set (RR := pr1 tL). set (RT1 := pr2 tL). (* set (RX := isLim_is_iso _ (make_LimCone _ _ CC H1) _ _ RT1). cbn in RX. set (XR := @functor_on_is_iso_is_iso _ _ π _ _ _ RX). cbn in XR. match goal with |[ H : is_iso ?f |- _ ] => set (T':= f) end. *) set (RX := isLim_is_z_iso _ (make_LimCone _ _ _ RT1) _ _ H1). set (XR := @functor_on_is_z_isomorphism _ _ π _ _ _ RX). match goal with |[ H : is_z_isomorphism ?f |- _ ] => set (T':= f) end. assert (X0 : T' = T). { clear XR. clear RX. unfold T. unfold T'. apply (limArrowUnique (make_LimCone _ _ _ isL)) . intro j. set (RRt := make_LimCone _ _ _ RT1). set (RRtt := limArrowCommutes RRt x CC j). set (RH := maponpaths (#π)%Cat RRtt). cbn in RH. apply RH. } rewrite <- X0. apply XR. Defined. End creates_preserves. (* *) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/000077500000000000000000000000001451125700300253005ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/CartesiannessOfComposites.v000066400000000000000000000225311451125700300326270ustar00rootroot00000000000000(** Definitions of various kinds of Lemmas about _fibrations_, leading up to a theorem characterizing their composites. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.Prefibrations. Local Open Scope type_scope. Local Open Scope mor_disp_scope. (* First some technical lemmas about factorisation through a composite, where the latter morphism is cartesian. *) Definition postcomp_pres_comm {C : category} {D : disp_cat C} {c c' c'' c''' : C} {f : c' --> c} {f' : c'' --> c'} {g' : c''' --> c''} {d : D c} {d' : D c'} {d'' : D c''} {d''' : D c'''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') (gg' : d''' -->[g'] d'') (gg : d''' -->[g' · f'] d') (hh : d''' -->[g' · (f' · f)] d) (comm_right : gg ;; ff = transportf (mor_disp d''' d) (assoc g' f' f) hh) : (gg' ;; ff' = gg) -> (gg' ;; (ff' ;; ff) = hh). Proof. intro comm_left. eapply pathscomp0. - apply assoc_disp. - eapply pathscomp0. 2: { apply transportbfinv. } + apply maponpaths. eapply pathscomp0. 2: { exact comm_right. } * apply maponpaths_2. exact comm_left. Qed. Definition postcomp_refl_comm {C : category} {D : disp_cat C} {c c' c'' c''' : C} {f : c' --> c} {f' : c'' --> c'} {g' : c''' --> c''} {d : D c} {d' : D c'} {d'' : D c''} {d''' : D c'''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') (gg' : d''' -->[g'] d'') (gg : d''' -->[g' · f'] d') (hh : d''' -->[g' · (f' · f)] d) (H : is_cartesian ff) (comm_right : gg ;; ff = transportf (mor_disp d''' d) (assoc g' f' f) hh) : (gg' ;; (ff' ;; ff) = hh) -> (gg' ;; ff' = gg). Proof. intro comm_all. apply (cartesian_factorisation_unique H). eapply pathscomp0. - apply assoc_disp_var. - eapply pathscomp0. 2: { apply pathsinv0. exact comm_right. } + apply maponpaths. exact comm_all. Qed. (* In the following we show that postcomposition with cartesian morphisms preserves and reflects (pre)cartesianness. *) Definition postcomp_w_cart_pres_cart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_cartesian ff' -> is_cartesian (ff' ;; ff)). Proof. intros cartff cartff'. unfold is_cartesian. intros c''' g' d''' hh. apply iscontraprop1. - apply invproofirrelevance. unfold isProofIrrelevant. intros (gg0, commbig0) (gg1, commgg1). apply subtypePairEquality. + intro gg. apply homsets_disp. + apply (cartesian_factorisation_unique cartff'). apply (cartesian_factorisation_unique cartff). eapply pathscomp0. * apply assoc_disp_var. * eapply pathscomp0. -- apply maponpaths. apply (pathscomp0 commbig0). apply pathsinv0. exact commgg1. -- apply pathsinv0. apply assoc_disp_var. - use tpair. + apply (cartesian_factorisation cartff'). apply (cartesian_factorisation cartff). apply (transportb _ (! assoc _ _ _)). exact hh. + eapply pathscomp0. * apply assoc_disp. * eapply pathscomp0. --apply maponpaths. eapply pathscomp0. ++ eapply maponpaths_2. apply cartesian_factorisation_commutes. ++ apply cartesian_factorisation_commutes'. -- apply transportfbinv. Defined. Definition postcomp_w_cart_pres_pre'cart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_pre'cartesian ff' -> is_pre'cartesian (ff' ;; ff)). Proof. intros cartff pre'cartff'. unfold is_pre'cartesian. intros d''' hh. apply iscontraprop1. - apply invproofirrelevance. unfold isProofIrrelevant. intros [gg0 commbig0] [gg1 commbig1]. eapply subtypePairEquality. + intro gg. apply homsets_disp. + apply (pre'cartesian_factorisation_unique pre'cartff'). apply (cartesian_factorisation_unique cartff). eapply pathscomp0. 2: { apply pathsinv0. apply assoc_disp_var. } * eapply pathscomp0. -- apply assoc_disp_var. -- apply maponpaths. apply (pathscomp0 commbig0). apply pathsinv0. exact commbig1. - use tpair. + apply (pre'cartesian_factorisation pre'cartff'). apply (cartesian_factorisation cartff). apply (transportb _ (! assoc _ _ _)). exact hh. + eapply pathscomp0. 2: { apply (transportfbinv _ (! assoc _ _ _)). } * eapply pathscomp0. -- apply assoc_disp. -- apply maponpaths. eapply pathscomp0. ++ eapply maponpaths_2. apply pre'cartesian_factorisation_commutes. ++ apply cartesian_factorisation_commutes'. Defined. Definition postcomp_w_cart_refl_cart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_cartesian (ff' ;; ff) -> is_cartesian ff'). Proof. intros cartff cartff'ff. unfold is_cartesian. intros c''' g' d''' gg. apply iscontraprop1. - apply invproofirrelevance. unfold isProofIrrelevant. intros (gg0, commbig0) (gg1, commbig1). apply subtypePairEquality. + intro ggtemp. apply homsets_disp. + apply (cartesian_factorisation_unique cartff'ff). eapply pathscomp0. 2: { apply pathsinv0. apply assoc_disp. } * eapply pathscomp0. -- apply assoc_disp. -- apply maponpaths. eapply maponpaths_2. exact (commbig0 @ ! commbig1). - use tpair. + apply (cartesian_factorisation cartff'ff). apply (transportb _ (assoc _ _ _)). exact (gg ;; ff). + apply (cartesian_factorisation_unique cartff). eapply pathscomp0. 2: { apply transportfbinv. } * eapply pathscomp0. -- apply assoc_disp_var. -- apply maponpaths. apply cartesian_factorisation_commutes. Defined. Definition postcomp_w_cart_refl_pre'cart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_pre'cartesian (ff' ;; ff) -> is_pre'cartesian ff'). Proof. intros cartff pre'cartff'ff. unfold is_pre'cartesian. intros d''' gg. apply iscontraprop1. - apply invproofirrelevance. unfold isProofIrrelevant. intros (gg0, commbig0) (gg1, commbig1). apply subtypePairEquality. + intro ggtemp. apply homsets_disp. + apply (pre'cartesian_factorisation_unique pre'cartff'ff). eapply pathscomp0. 2: { apply pathsinv0. apply assoc_disp. } * eapply pathscomp0. -- apply assoc_disp. -- apply maponpaths. eapply maponpaths_2. exact (commbig0 @ ! commbig1). - use tpair. + apply (pre'cartesian_factorisation pre'cartff'ff). apply (transportb _ (assoc _ _ _)). exact (gg ;; ff). + apply (cartesian_factorisation_unique cartff). eapply pathscomp0. 2: { apply transportfbinv. } * eapply pathscomp0. -- apply assoc_disp_var. -- apply maponpaths. apply pre'cartesian_factorisation_commutes. Defined. Definition postcomp_w_cart_pres_precart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_precartesian ff' -> is_precartesian (ff' ;; ff)). Proof. intros cartff precartff'. apply pre'_implies_pre. eapply postcomp_w_cart_pres_pre'cart. - exact cartff. - apply pre_implies_pre'. exact precartff'. Defined. Definition postcomp_w_cart_refl_precart {C : category} {D : disp_cat C} {c c' c'' : C} {f : c' --> c} {f' : c'' --> c'} {d : D c} {d' : D c'} {d'' : D c''} (ff : d' -->[f] d) (ff' : d'' -->[f'] d') : is_cartesian ff -> (is_precartesian (ff' ;; ff) -> is_precartesian ff'). Proof. intros cartff precartff'ff. apply pre'_implies_pre. eapply postcomp_w_cart_refl_pre'cart. - exact cartff. - apply pre_implies_pre'. exact precartff'ff. Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/DispCatsEquivFunctors.v000066400000000000000000000275171451125700300317530ustar00rootroot00000000000000(** This file is meant to provide an equivalence between the displayed categories on a base category and the functors into the base category. For now it only contains the construction of a displayed category from a functor. *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.Prefibrations. Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.CartesiannessOfComposites. Local Open Scope type_scope. Local Open Scope mor_disp_scope. Section TransportMorphisms. (* In the transport of morphisms we have to make a choice in the order of transports, which we denote by "st" and "ts" (source/target). Of course the results are propositionally equal.*) Definition transportf_mor_ts {C : category} {c0 c1 c0' c1' : C} (H0 : c0 = c0') (H1 : c1 = c1') : (c0 --> c1) -> (c0' --> c1'). Proof. intro f. apply (transportf _ H1). apply (transportf (λ c, C⟦c, c1⟧) H0). exact f. Defined. Definition transportf_mor_st {C : category} {c0 c1 c0' c1' : C} (H0 : c0 = c0') (H1 : c1 = c1') : (c0 --> c1) -> (c0' --> c1'). Proof. intro f. apply (transportf (λ c, C⟦c, c1'⟧) H0). apply (transportf _ H1). exact f. Defined. Definition transportf_mor_eq {C : category} {c0 c1 c0' c1' : C} (H0 : c0 = c0') (H1 : c1 = c1') (f: c0 --> c1) : transportf_mor_ts H0 H1 f = transportf_mor_st H0 H1 f. Proof. induction H0. induction H1. apply idpath_transportf. Qed. (* Choose which to use as standard. *) Definition transportf_mor {C : category} {c0 c1 c0' c1' : C} (H0 : c0 = c0') (H1 : c1 = c1') := transportf_mor_ts H0 H1. Definition transp_pres_id {C : category} {c c' : C} (H : c = c') : identity c' = transportf_mor H H (identity c). Proof. induction H. apply idpath_transportf. Qed. Definition transp_pres_comp {C : category} {c0 c0' c1 c2 c2' : C} (H0 : c0 = c0') (H2 : c2 = c2') (f0: c0 --> c1) (f1 : c1 --> c2) : transportf_mor H0 H2 (f0 · f1) = (transportf_mor H0 (idpath _) f0) · (transportf_mor (idpath _) H2 f1). Proof. induction H2. induction H0. apply idpath_transportf. Qed. Definition transp_pres_comp' {C : category} {c0 c0' c1 c1' c2 c2' : C} (H0 : c0 = c0') (H1 : c1 = c1') (H2 : c2 = c2') (f0: c0 --> c1) (f1 : c1 --> c2) : transportf_mor H0 H2 (f0 · f1) = (transportf_mor H0 H1 f0) · (transportf_mor H1 H2 f1). Proof. eapply pathscomp0. - apply transp_pres_comp. - apply pathsinv0. eapply pathscomp0. + apply (maponpaths _ (transportf_mor_eq H1 H2 _)). + apply transport_compose'. Qed. End TransportMorphisms. Section DispCatOfFibers. Definition disp_cat_of_fibers_ob {B C : category} (F : functor C B) : B -> UU. Proof. intro b. exact (∑ c : C, b = F c). Defined. Definition disp_cat_of_fibers_mor {B C : category} (F : functor C B) : ∏ (b b' : B), disp_cat_of_fibers_ob F b -> disp_cat_of_fibers_ob F b' -> (b --> b') -> UU. Proof. intros b b' [c H_ob] [c' H'_ob] f. exact (∑ (g : c --> c'), (functor_on_morphisms F) g = transportf_mor H_ob H'_ob f). Defined. Definition disp_cat_of_fibers_mor' {B C : category} {F : functor C B} {b b' : B} (c : disp_cat_of_fibers_ob F b) (c' : disp_cat_of_fibers_ob F b') : (b --> b') -> UU := disp_cat_of_fibers_mor F b b' c c'. Definition disp_cat_of_fibers_ob_mor {B C : category} (F : functor C B) : disp_cat_ob_mor B. Proof. exists (disp_cat_of_fibers_ob F). exact (disp_cat_of_fibers_mor F). Defined. Definition disp_cat_of_fibers_id {B C : category} (F : functor C B) : (∏ (b : B) (c_H : disp_cat_of_fibers_ob F b), disp_cat_of_fibers_mor' c_H c_H (identity b)). Proof. intros b [c H]. exists (identity c). eapply pathscomp0. - apply functor_id. - apply transp_pres_id. Defined. Definition disp_cat_of_fibers_id' {B C : category} {F : functor C B} {b : B} (c_H : disp_cat_of_fibers_ob F b) : disp_cat_of_fibers_mor' c_H c_H (identity b) := disp_cat_of_fibers_id F b c_H. Definition disp_cat_of_fibers_comp {B C : category} (F : functor C B) : ∏ (b b' b'' : B) (f : b --> b') (f': b' --> b'') (c : disp_cat_of_fibers_ob F b) (c' : disp_cat_of_fibers_ob F b') (c'' : disp_cat_of_fibers_ob F b''), (disp_cat_of_fibers_mor' c c' f) -> (disp_cat_of_fibers_mor' c' c'' f') -> (disp_cat_of_fibers_mor' c c'' (f · f')). Proof. intros b b' b'' f f' [c H_ob] [c' H'_ob] [c'' H''_ob] [g H_mor] [g' H'_mor]. exists (g · g'). eapply pathscomp0. - apply functor_comp. - eapply pathscomp0. 2: { apply pathsinv0. apply (transp_pres_comp' H_ob H'_ob H''_ob). } + eapply pathscomp0. * exact (maponpaths (λ mor, mor · ((# F)%Cat g')) H_mor). * exact (maponpaths (λ mor, (transportf_mor H_ob H'_ob f) · mor) H'_mor). Defined. Definition disp_cat_of_fibers_comp' {B C : category} {F : functor C B} {b b' b'' : B} {f : b --> b'} {f': b' --> b''} {c : disp_cat_of_fibers_ob F b} {c' : disp_cat_of_fibers_ob F b'} {c'' : disp_cat_of_fibers_ob F b''} (g : disp_cat_of_fibers_mor F b b' c c' f) (g' : disp_cat_of_fibers_mor F b' b'' c' c'' f') : (disp_cat_of_fibers_mor F b b'' c c'' (f · f')) := disp_cat_of_fibers_comp F b b' b'' f f' c c' c'' g g'. Definition disp_cat_of_fibers_id_comp {B C : category} (F : functor C B) : disp_cat_id_comp B (disp_cat_of_fibers_ob_mor F) := (disp_cat_of_fibers_id F ,, disp_cat_of_fibers_comp F). Definition disp_cat_of_fibers_data {B C : category} (F : functor C B) : disp_cat_data B. Proof. exists (disp_cat_of_fibers_ob_mor F). apply disp_cat_of_fibers_id_comp. Defined. Definition disp_cat_of_fibers_id_left {B C : category} (F : functor C B) : ∏ (b b' : B) (f : b --> b') (c : disp_cat_of_fibers_ob F b) (c' : disp_cat_of_fibers_ob F b') (g : disp_cat_of_fibers_mor' c c' f), disp_cat_of_fibers_comp' (disp_cat_of_fibers_id F _ _) g = transportb _ (id_left _) g. Proof. intros b b' f [c H_ob] [c' H'_ob] [g H_mor]. apply subtypePath. - intros mor. apply homset_property. - simpl. apply pathsinv0. eapply pathscomp0. + apply (@pr1_transportf _ _ (λ mor, (λ mor', (functor_on_morphisms F) mor' = transportf_mor H_ob H'_ob mor))). + simpl. eapply pathscomp0. * apply (eqtohomot (transportf_const _ _)). * apply pathsinv0. apply id_left. Qed. Definition disp_cat_of_fibers_id_left' {B C : category} {F : functor C B} {b b' : B} {f : b --> b'} {c : disp_cat_of_fibers_ob F b} {c' : disp_cat_of_fibers_ob F b'} (g : disp_cat_of_fibers_mor' c c' f) : disp_cat_of_fibers_comp' (disp_cat_of_fibers_id F _ _) g = transportb _ (id_left _) g := disp_cat_of_fibers_id_left F b b' f c c' g. Definition disp_cat_of_fibers_id_right {B C : category} (F : functor C B) : ∏ (b b' : B) (f : b --> b') (c : disp_cat_of_fibers_ob F b) (c' : disp_cat_of_fibers_ob F b') (g : disp_cat_of_fibers_mor' c c' f), disp_cat_of_fibers_comp' g (disp_cat_of_fibers_id F _ _) = transportb _ (id_right _) g. Proof. intros b b' f [c H_ob] [c' H'_ob] [g H_mor]. apply subtypePath. - intros mor. apply homset_property. - simpl. apply pathsinv0. eapply pathscomp0. + apply (@pr1_transportf _ _ (λ mor, (λ mor', (functor_on_morphisms F) mor' = transportf_mor H_ob H'_ob mor))). + simpl. eapply pathscomp0. * apply (eqtohomot (transportf_const _ _)). * apply pathsinv0. apply id_right. Qed. Definition disp_cat_of_fibers_id_right' {B C : category} {F : functor C B} {b b' : B} {f : b --> b'} {c : disp_cat_of_fibers_ob F b} {c' : disp_cat_of_fibers_ob F b'} (g : disp_cat_of_fibers_mor' c c' f) : disp_cat_of_fibers_comp' g (disp_cat_of_fibers_id F _ _) = transportb _ (id_right _) g := disp_cat_of_fibers_id_right F b b' f c c' g. Definition disp_cat_of_fibers_assoc {B C : category} (F : functor C B) : ∏ (b0 b1 b2 b3 : B) (f1 : b0 --> b1) (f2 : b1 --> b2) (f3 : b2 --> b3) (c0 : disp_cat_of_fibers_ob F b0) (c1 : disp_cat_of_fibers_ob F b1) (c2 : disp_cat_of_fibers_ob F b2) (c3 : disp_cat_of_fibers_ob F b3) (g1 : disp_cat_of_fibers_mor' c0 c1 f1) (g2 : disp_cat_of_fibers_mor' c1 c2 f2) (g3 : disp_cat_of_fibers_mor' c2 c3 f3), disp_cat_of_fibers_comp' g1 (disp_cat_of_fibers_comp' g2 g3) = transportb _ (assoc _ _ _) (disp_cat_of_fibers_comp' (disp_cat_of_fibers_comp' g1 g2) g3). Proof. intros b0 b1 b2 b3 f1 f2 f3 [c0 H0_ob] [c1 H1_ob] [c2 H2_ob] [c3 H3_ob] [g1 H1_mor] [g2 H2_mor] [g3 H3_mor]. apply subtypePath. - intros mor. apply homset_property. - simpl. apply pathsinv0. eapply pathscomp0. + (*set (pr1trans := pr1_transportf (assoc f1 f2 f3) (disp_cat_of_fibers_comp' (disp_cat_of_fibers_comp' (g1,, H1_mor) (g2,, H2_mor)) (g3,, H3_mor))).*) apply (@pr1_transportf _ _ (λ mor, (λ mor', (functor_on_morphisms F) mor' = transportf_mor H0_ob H3_ob mor))). + simpl. eapply pathscomp0. * apply (eqtohomot (transportf_const _ _)). * apply pathsinv0. apply assoc. Qed. Definition disp_cat_of_fibers_assoc' {B C : category} {F : functor C B} {b0 b1 b2 b3 : B} {f1 : b0 --> b1} {f2 : b1 --> b2} {f3 : b2 --> b3} {c0 : disp_cat_of_fibers_ob F b0} {c1 : disp_cat_of_fibers_ob F b1} {c2 : disp_cat_of_fibers_ob F b2} {c3 : disp_cat_of_fibers_ob F b3} (g1 : disp_cat_of_fibers_mor' c0 c1 f1) (g2 : disp_cat_of_fibers_mor' c1 c2 f2) (g3 : disp_cat_of_fibers_mor' c2 c3 f3) : disp_cat_of_fibers_comp' g1 (disp_cat_of_fibers_comp' g2 g3) = transportb _ (assoc _ _ _) (disp_cat_of_fibers_comp' (disp_cat_of_fibers_comp' g1 g2) g3) := disp_cat_of_fibers_assoc F b0 b1 b2 b3 f1 f2 f3 c0 c1 c2 c3 g1 g2 g3. Definition disp_cat_of_fibers_homsets {B C : category} (F : functor C B) : ∏ (b b' : B) (f : b --> b') (c_H : disp_cat_of_fibers_ob F b) (c'_H : disp_cat_of_fibers_ob F b'), isaset (disp_cat_of_fibers_mor' c_H c'_H f). Proof. intros b b' f c_H c'_H. apply isaset_total2. - apply (homset_property C). - intros g. apply isasetaprop. apply (homset_property B). Qed. Definition disp_cat_of_fibers_homsets' {B C : category} {F : functor C B} {b b' : B} (f : b --> b') (c_H : disp_cat_of_fibers_ob F b) (c'_H : disp_cat_of_fibers_ob F b') : isaset (disp_cat_of_fibers_mor' c_H c'_H f) := disp_cat_of_fibers_homsets F b b' f c_H c'_H. Definition disp_cat_of_fibers_axioms {B C : category} (F : functor C B) : disp_cat_axioms B (disp_cat_of_fibers_data F). Proof. exists (disp_cat_of_fibers_id_left F). exists (disp_cat_of_fibers_id_right F). exists (disp_cat_of_fibers_assoc F). exact (disp_cat_of_fibers_homsets F). Qed. Definition disp_cat_of_fibers {B C : category} (F : functor C B) : disp_cat B. Proof. exists (disp_cat_of_fibers_data F). exact (disp_cat_of_fibers_axioms F). Defined. End DispCatOfFibers. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/DisplayedDisplayedCats.v000066400000000000000000000213231451125700300320600ustar00rootroot00000000000000Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Foundations.All. Local Open Scope type_scope. Local Open Scope mor_disp_scope. Section DisplayedDisplayedCategories. Definition disp_disp_cat (C : category) : UU := ∑ (D : disp_cat C), disp_cat (total_category D). Definition base_disp_cat {C : category} (E : disp_disp_cat C) : disp_cat C := pr1 E. Definition top_disp_cat {C : category} (E : disp_disp_cat C) : disp_cat (total_category (base_disp_cat E)) := pr2 E. End DisplayedDisplayedCategories. Section CompositeDisplayedCategories. Definition composite_disp_cat_ob_mor {C : category} (DD : disp_disp_cat C) : disp_cat_ob_mor C. Proof. destruct DD as [D E]. use tpair. - intro x. exact (∑ xx : D x, E (x ,, xx)). - simpl. intros x y [xx xxx] [yy yyy] f. exact (∑ ff : xx -->[f] yy, xxx -->[(f ,, ff)] yyy). Defined. Definition composite_disp_cat_id_comp {C : category} (DD : disp_disp_cat C) : disp_cat_id_comp C (composite_disp_cat_ob_mor DD). Proof. destruct DD as [D E]. use tpair. - intros x [xx xxx]. use tpair. + simpl. exact (id_disp xx). + simpl. exact (id_disp xxx). - simpl. intros x y z f g [xx xxx] [yy yyy] [zz zzz] [ff fff] [gg ggg]. use tpair. + exact (ff ;; gg). + simpl. exact (fff ;; ggg). Defined. Definition composite_disp_cat_data {C : category} (DD : disp_disp_cat C) := (composite_disp_cat_ob_mor DD ,, composite_disp_cat_id_comp DD) : disp_cat_data C. Definition composite_disp_cat_axioms {C : category} (DD : disp_disp_cat C) : disp_cat_axioms C (composite_disp_cat_data DD). Proof. destruct DD as [D E]. repeat split. - intros x y f [xx xxx] [yy yyy] [ff fff]. use total2_reassoc_paths'. + simpl. apply id_left_disp. + simpl. apply (pathscomp0 (id_left_disp fff)). apply maponpaths_2. apply homset_property. - intros x y f [xx xxx] [yy yyy] [ff fff]. use total2_reassoc_paths'. + simpl. apply id_right_disp. + simpl. eapply pathscomp0. * apply (id_right_disp fff). * apply maponpaths_2. apply homset_property. - intros x y z w f g h [xx xxx] [yy yyy] [zz zzz] [ww www] [ff fff] [gg ggg] [hh hhh]. use total2_reassoc_paths'. + simpl. apply assoc_disp. + simpl. eapply pathscomp0. * apply (assoc_disp fff ggg hhh). * apply maponpaths_2. apply homset_property. - intros x y f [xx xxx] [yy yyy]. apply isaset_total2. + apply homsets_disp. + intros ff. apply homsets_disp. Qed. Definition composite_disp_cat {C : category} (DD : disp_disp_cat C) : disp_cat C := (_,, composite_disp_cat_axioms DD). End CompositeDisplayedCategories. Section Auxiliary. (* Auxiliary lemmas for the axioms of fiber displayed categories. *) (* analogous to UniMath.MoreFoundations.PartA.total2_reassoc_paths' for fiber instead of composite: *) Definition total2_fiber_path {A : UU} {B : A -> UU} {C : (∑ a, B a) -> UU} (a : A) (Ca : B a -> UU := λ b, C (a ,, b)) {b1 b2 : B a} (c1 : Ca b1) (c2 : Ca b2) (eb : b1 = b2) (ec : c1 = transportb C (two_arg_paths_b (idpath a) eb) c2) : c1 = transportb Ca eb c2. Proof. destruct eb; cbn. destruct (! ec); cbn. apply idpath. Defined. (* the following lemma roughly means that a morphism of dependent types commutes with transport: *) Definition mor_disp_types_comm_transp {A B : UU} (P: A → UU) (Q : B → UU) (f0: A → B) (f1: ∏ a : A, P a → Q(f0 a)) {x x' : A} (h: x = x') : ∏ (p : P x), transportf Q (maponpaths f0 h) (f1 x p) = f1 x' (transportf P h p). Proof. intro p. induction h. apply idpath. Defined. End Auxiliary. Section FiberDisplayedCategories. Definition fiber_disp_cat_ob_mor {C : category} (DD : disp_disp_cat C) (c : C) : disp_cat_ob_mor (base_disp_cat DD)[{c}]. Proof. destruct DD as [D E]. use tpair. - simpl. intro x. exact (E (c ,, x)). - simpl. intros x y xx yy f. exact (xx -->[(identity c ,, f)] yy). Defined. Definition fiber_disp_cat_id_comp {C : category} (DD : disp_disp_cat C) (c : C) : disp_cat_id_comp (base_disp_cat DD)[{c}] (fiber_disp_cat_ob_mor DD c). Proof. destruct DD as [D E]. split. - simpl. intros x xx. apply (@id_disp _ E _ xx). - simpl. intros x y z f g xx yy zz ff gg. use (transportf _ _ (ff ;; gg)). use total2_paths_f; simpl. + apply id_right. + apply idpath. Defined. Definition fiber_disp_cat_data {C : category} (DD : disp_disp_cat C) (c : C) := (fiber_disp_cat_ob_mor DD c,, fiber_disp_cat_id_comp DD c) : disp_cat_data (base_disp_cat DD)[{c}]. Definition fiber_disp_cat_axioms {C : category} (DD : disp_disp_cat C) (c : C) : disp_cat_axioms (base_disp_cat DD)[{c}] (fiber_disp_cat_data DD c). Proof. destruct DD as [D E]. repeat split; intros; simpl. - simpl in *. use total2_fiber_path. unfold ";;". apply transportf_transpose_left. apply (pathscomp0 (id_left_disp ff)). eapply pathscomp0. 2: { apply pathsinv0. apply transport_b_b. } + unfold transportb. apply maponpaths_2. apply homset_property. - simpl in *. use total2_fiber_path. unfold ";;". apply transportf_transpose_left. apply (pathscomp0 (id_right_disp ff)). eapply pathscomp0. 2: { apply pathsinv0. apply transport_b_b. } unfold transportb. apply maponpaths_2. apply homset_property. - simpl in *. use total2_fiber_path. unfold ";;"; simpl. apply transportf_transpose_left. eapply pathscomp0. 2: { apply pathsinv0. apply transport_b_b. } use pathscomp0. + eapply transportf. 2: { exact (ff ;; (gg ;; hh)). } unfold "·"; simpl. use total2_paths_f; simpl. * apply maponpaths. apply id_right. * apply (mor_disp_types_comm_transp _ _ (λ e, identity c · e) (λ e ee, f ;; ee)). + eapply pathscomp0. * apply pathsinv0. unfold "·"; simpl. apply (mor_disp_types_comm_transp (mor_disp yy ww) (mor_disp xx ww) _ (λ e ee, ff ;; ee) (@total2_paths_f _ _ (identity c · identity c,, _) (identity c,, _) (id_right (identity c)) (idpath (transportf (mor_disp y w) (id_right (identity c)) (g ;; h)))) (gg ;; hh)). * apply maponpaths_2. apply (homset_property (total_category D) (c,, x) (c,, w)). + eapply pathscomp0. 2: { apply pathsinv0. apply transport_b_f. } apply transportf_transpose_right. use pathscomp0. * use transportf. -- exact ((identity c,, f : total_category D ⟦(c,, x), (c,, y)⟧) · (identity c,, g : total_category D ⟦(c,, y), (c,, z)⟧) · (identity c,, h : total_category D ⟦(c,, z), (c,, w)⟧)). -- simpl. apply (maponpaths (λ e, pr2 (pr2 (total_category_data D)) (c,, x) (c,, z) (c,, w) e (identity c,, h))). use total2_paths_f; simpl. ++ apply id_right. ++ apply idpath. -- exact (ff ;; gg ;; hh). * eapply pathscomp0. -- apply transport_b_f. -- apply transportf_transpose_left. apply (pathscomp0 (assoc_disp ff gg hh)). eapply pathscomp0. 2: { apply pathsinv0. apply transport_b_f. } unfold transportb. unfold ";;" at 1 2 9 10. apply maponpaths_2. apply (homset_property (total_category D) (c,, x) (c,, w)). * apply (mor_disp_types_comm_transp _ _ (λ e : total_category_data D ⟦ c,, x, c,, z ⟧, e · (identity c,, h : total_category D ⟦(c,, z), (c,, w)⟧)) (λ e ee, ee ;; hh)). - apply homsets_disp. Qed. Definition fiber_disp_cat {C : category} (DD : disp_disp_cat C) (c : C) : disp_cat (base_disp_cat DD)[{c}] := (_,, fiber_disp_cat_axioms DD c). End FiberDisplayedCategories. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/FibrationsCharacterisation.v000066400000000000000000000125331451125700300327770ustar00rootroot00000000000000(** Definitions of various kinds of Lemmas about _fibrations_, leading up to a theorem characterizing their composites. *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.Prefibrations. Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.CartesiannessOfComposites. Local Open Scope type_scope. Local Open Scope mor_disp_scope. Definition precleaving_comp_is_precart {C : category} {D : disp_cat C} (lift : precleaving D) := forall (c c' c'' : C) (f' : c'' --> c') (f : c' --> c) (d : D c), is_precartesian ((lift _ _ f' (object_of_precartesian_lift (lift _ _ f d))) ;; (lift _ _ f d)). Definition precleaving_is_cleaving {C : category} {D : disp_cat C} (lift : precleaving D) := forall (c c' : C) (f: c' --> c) (d : D c), is_cartesian (lift _ _ f d). Lemma transportf_cancel {X : UU} (P : X → UU) {x x' : X} (e : x = x') (y0 y1 : P x): transportf P e y0 = transportf P e y1 -> y0 = y1. Proof. induction e. apply idfun. Defined. Definition assoc_eq {C} {D : disp_cat C} {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w} (ff ff' : xx -->[f] yy) (gg gg' : yy -->[g] zz) (hh hh' : zz -->[h] ww) : ff ;; (gg ;; hh) = ff' ;; (gg' ;; hh') -> (ff ;; gg) ;; hh = (ff' ;; gg') ;; hh'. Proof. intro H. eapply pathscomp0. - apply assoc_disp_var. - eapply pathscomp0. + apply maponpaths. exact H. + apply pathsinv0. apply assoc_disp_var. Qed. Definition assoc_eq_var {C} {D : disp_cat C} {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w} (ff ff' : xx -->[f] yy) (gg gg' : yy -->[g] zz) (hh hh' : zz -->[h] ww) : (ff ;; gg) ;; hh = (ff' ;; gg') ;; hh' -> ff ;; (gg ;; hh) = ff' ;; (gg' ;; hh'). Proof. intro H. eapply pathscomp0. - apply assoc_disp. - eapply pathscomp0. + apply maponpaths. exact H. + apply pathsinv0. apply assoc_disp. Qed. Definition prefibration_w_precart_closed_implies_fibration {C : category} {D : disp_cat C} (lift : precleaving D) : precleaving_comp_is_precart lift -> precleaving_is_cleaving lift. Proof. unfold precleaving_comp_is_precart, precleaving_is_cleaving. intros liftclosed c c' f d. unfold is_cartesian. intros c'' g d'' hh. apply iscontraprop1. - apply invproofirrelevance. unfold isProofIrrelevant. intros [gg0 comm0] [gg1 comm1]. apply subtypePairEquality. + intro gg. apply homsets_disp. + eapply transportf_cancel. eapply pathscomp0. * apply pathsinv0. use precartesian_factorisation_commutes. 3: { use precartesian_lift_is_precartesian. apply lift. } * eapply pathscomp0. 2: { use precartesian_factorisation_commutes. 3: { use precartesian_lift_is_precartesian. apply lift. } } -- apply maponpaths_2. eapply precartesian_factorisation_unique. ++ apply liftclosed. ++ apply assoc_eq_var. eapply pathscomp0. ** apply maponpaths_2. apply precartesian_factorisation_commutes. ** eapply pathscomp0. --- eapply pathscomp0. +++ apply mor_disp_transportf_postwhisker. +++ eapply pathscomp0. *** apply maponpaths. exact (comm0 @ ! comm1). *** apply pathsinv0. apply mor_disp_transportf_postwhisker. --- apply pathsinv0. apply maponpaths_2. apply precartesian_factorisation_commutes. - use tpair. + apply (transportf _ (id_left _)). eapply comp_disp. 2: { apply lift. } eapply precartesian_factorisation. * apply liftclosed. * exact hh. + simpl. eapply pathscomp0. * eapply pathscomp0. -- apply mor_disp_transportf_postwhisker. -- eapply pathscomp0. ++ apply maponpaths. apply assoc_disp_var. ++ eapply pathscomp0. ** apply transport_f_f. ** apply maponpaths_2. apply homset_property. * apply transportf_transpose_left. apply precartesian_factorisation_commutes. Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/MoreFibrations/Prefibrations.v000066400000000000000000000241771451125700300303110ustar00rootroot00000000000000Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *) Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.Foundations.All. Local Open Scope type_scope. Local Open Scope mor_disp_scope. (** * Prefibrations *) Section Precartesian_morphisms. (** The following two equivalent definitions are convenient in different situations. *) Definition is_precartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : UU := forall (d'' : D c') (hh : d'' -->[f] d), ∃! (gg : d'' -->[identity c'] d'), gg ;; ff = transportb _ (id_left _) hh. Definition is_pre'cartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : UU := forall (d'' : D c') (hh : d'' -->[identity c' · f] d), ∃! (gg : d'' -->[identity c'] d'), gg ;; ff = hh. Definition pre'_implies_pre {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : is_pre'cartesian ff -> is_precartesian ff. Proof. intros H d'' hh. apply H. Defined. Coercion pre'_implies_pre : is_pre'cartesian >-> is_precartesian. Definition pre_implies_pre' {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : is_precartesian ff -> is_pre'cartesian ff. Proof. intros H d'' hh. induction (transportbfinv _ (id_left _) hh). apply H. Defined. (** See also [precartesian_factorisation'] below, for when the map one wishes to factor is not judgementally over [f], but over some equal map. TODO! *) Definition precartesian_factorisation {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_precartesian ff) {d'': D c'} (hh : d'' -->[f] d) : d'' -->[identity c'] d' := pr1 (pr1 (H _ hh)). Definition pre'cartesian_factorisation {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_pre'cartesian ff) {d'': D c'} (hh : d'' -->[identity c' · f] d) : d'' -->[identity c'] d' := pr1 (pr1 (H _ hh)). Definition precartesian_factorisation_commutes {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_precartesian ff) {d'': D c'} (hh : d'' -->[f] d) : precartesian_factorisation H hh ;; ff = transportb _ (id_left _) hh := pr2 (pr1 (H _ hh)). Definition pre'cartesian_factorisation_commutes {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_pre'cartesian ff) {d'': D c'} (hh : d'' -->[identity c' · f] d) : pre'cartesian_factorisation H hh ;; ff = hh := pr2 (pr1 (H _ hh)). Definition precartesian_factorisation_of_composite {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_precartesian ff) {d'' : D c'} (gg : d'' -->[identity c'] d') : gg = precartesian_factorisation H (transportf _ (id_left _) (gg ;; ff)). Proof. exact (maponpaths pr1 ((pr2 (H _ _)) (_,, ! ((transportbfinv _ _ _))))). Defined. Definition pre'cartesian_factorisation_of_composite {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_pre'cartesian ff) {d'' : D c'} (gg : d'' -->[identity c'] d') : gg = pre'cartesian_factorisation H (gg ;; ff). Proof. exact (maponpaths pr1 ((pr2 (H _ _)) (_,, idpath _))). Defined. Definition pre'cartesian_factorisation_unique {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_pre'cartesian ff) {d'': D c'} (gg gg' : d'' -->[identity c'] d') : (gg ;; ff = gg' ;; ff) -> gg = gg'. Proof. intro Hggff. eapply pathscomp0. - apply (pre'cartesian_factorisation_of_composite H). - eapply pathscomp0. + apply maponpaths. exact Hggff. + apply pathsinv0. apply pre'cartesian_factorisation_of_composite. Defined. Definition precartesian_factorisation_unique {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} {ff : d' -->[f] d} (H : is_precartesian ff) {d'': D c'} (gg gg' : d'' -->[identity c'] d') : (gg ;; ff = gg' ;; ff) -> gg = gg'. Proof. intro Hggff. eapply pathscomp0. - apply (precartesian_factorisation_of_composite H). - eapply pathscomp0. + apply maponpaths. apply maponpaths. exact Hggff. + apply pathsinv0. apply precartesian_factorisation_of_composite. Defined. Definition isaprop_is_precartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : isaprop (is_precartesian ff). Proof. repeat (apply impred_isaprop; intro). apply isapropiscontr. Defined. Definition isaprop_is_pre'cartesian {C : category} {D : disp_cat C} {c c' : C} {f : c' --> c} {d : D c} {d' : D c'} (ff : d' -->[f] d) : isaprop (is_pre'cartesian ff). Proof. repeat (apply impred_isaprop; intro). apply isapropiscontr. Defined. End Precartesian_morphisms. Section Precartesian_lifts. Definition precartesian_lift {C : category} {D : disp_cat C} {c c' : C} (d : D c) (f : c' --> c) : UU := ∑ (d' : D c') (ff : d' -->[f] d), is_precartesian ff. Definition pre'cartesian_lift {C : category} {D : disp_cat C} {c c' : C} (d : D c) (f : c' --> c) : UU := ∑ (d' : D c') (ff : d' -->[f] d), is_pre'cartesian ff. Definition object_of_precartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : precartesian_lift d f) : D c' := pr1 fd. Coercion object_of_precartesian_lift : precartesian_lift >-> ob_disp. Definition object_of_pre'cartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : pre'cartesian_lift d f) : D c' := pr1 fd. Coercion object_of_pre'cartesian_lift : pre'cartesian_lift >-> ob_disp. Definition mor_disp_of_precartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : precartesian_lift d f) : (fd : D c') -->[f] d := pr1 (pr2 fd). Coercion mor_disp_of_precartesian_lift : precartesian_lift >-> mor_disp. Definition mor_disp_of_pre'cartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : pre'cartesian_lift d f) : (fd : D c') -->[f] d := pr1 (pr2 fd). Coercion mor_disp_of_pre'cartesian_lift : pre'cartesian_lift >-> mor_disp. Definition precartesian_lift_is_precartesian {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : precartesian_lift d f) : is_precartesian fd := pr2 (pr2 fd). Coercion precartesian_lift_is_precartesian : precartesian_lift >-> is_precartesian. Definition pre'cartesian_lift_is_pre'cartesian {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : pre'cartesian_lift d f) : is_pre'cartesian fd := pr2 (pr2 fd). Coercion pre'cartesian_lift_is_pre'cartesian : pre'cartesian_lift >-> is_pre'cartesian. Definition pre'_implies_precartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : pre'cartesian_lift d f) : precartesian_lift d f. Proof. exists (pr1 fd). exists (pr1 (pr2 fd)). apply pre'_implies_pre. exact (pr2 (pr2 fd)). Defined. Coercion pre'_implies_precartesian_lift : pre'cartesian_lift >-> precartesian_lift. Definition pre_implies_pre'cartesian_lift {C : category} {D : disp_cat C} {c c' : C} {d : D c} {f : c' --> c} (fd : precartesian_lift d f) : pre'cartesian_lift d f. Proof. exists (pr1 fd). exists (pr1 (pr2 fd)). apply pre_implies_pre'. exact (pr2 (pr2 fd)). Defined. End Precartesian_lifts. Section Precleavages. Definition precleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (f : c' --> c) (d : D c), precartesian_lift d f. Definition pre'cleaving {C : category} (D : disp_cat C) : UU := forall (c c' : C) (f : c' --> c) (d : D c), pre'cartesian_lift d f. Definition pre_implies_pre'cleaving {C : category} (D : disp_cat C) : precleaving D -> pre'cleaving D. Proof. unfold pre'cleaving. intros H c c' f d. apply pre_implies_pre'cartesian_lift. apply H. Defined. Coercion pre_implies_pre'cleaving : precleaving >-> pre'cleaving. Definition pre'_implies_precleaving {C : category} (D : disp_cat C) : pre'cleaving D -> precleaving D. Proof. unfold precleaving. intros H c c' f d. apply pre'_implies_precartesian_lift. apply H. Defined. (* TODO: Show that the above functions yield an equivalence *) End Precleavages. Section Prefibrations. Definition prefibration (C : category) : UU := ∑ (D : disp_cat C), precleaving D. Definition pre'fibration (C : category) : UU := ∑ (D : disp_cat C), pre'cleaving D. Definition pre'_implies_prefibration (C : category) : pre'fibration C -> prefibration C. Proof. intro F. exists (pr1 F). apply pre'_implies_precleaving. exact (pr2 F). Defined. Coercion pre'_implies_prefibration : pre'fibration >-> prefibration. Definition pre_implies_pre'fibration (C : category) : prefibration C -> pre'fibration C. Proof. intro F. exists (pr1 F). apply pre_implies_pre'cleaving. exact (pr2 F). Defined. End Prefibrations. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/NaturalTransformations.v000066400000000000000000000710051451125700300272670ustar00rootroot00000000000000 Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope cat. Local Open Scope mor_disp. (** ** Displayed Natural Transformations *) Section Disp_Nat_Trans. Definition disp_nat_trans_data {C' C : precategory_data} {F' F : functor_data C' C} (a : forall x, F' x --> F x) {D' : disp_cat_data C'} {D : disp_cat_data C} (R' : disp_functor_data F' D' D) (R : disp_functor_data F D' D) := forall (x : C') (xx : D' x), R' x xx -->[ a x ] R x xx . Definition disp_nat_trans_axioms {C' C : precategory_data} {F' F : functor_data C' C} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat_data C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b : disp_nat_trans_data a R' R) : UU := forall (x' x : C') (f : x' --> x) (xx' : D' x') (xx : D' x) (ff : xx' -->[ f ] xx), ♯ R' ff ;; b _ xx = transportb _ (nat_trans_ax a _ _ f ) (b _ xx' ;; ♯ R ff). Lemma isaprop_disp_nat_trans_axioms {C' C : category} {F' F : functor_data C' C} (a : nat_trans F' F) {D' : disp_cat_data C'} {D : disp_cat C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b : disp_nat_trans_data a R' R) : isaprop (disp_nat_trans_axioms b). Proof. repeat (apply impred; intro). apply homsets_disp. Qed. Definition disp_nat_trans {C' C : precategory_data} {F' F : functor_data C' C} (a : nat_trans F' F) {D' : disp_cat_data C'} {D : disp_cat_data C} (R' : disp_functor_data F' D' D) (R : disp_functor_data F D' D) : UU := ∑ b : disp_nat_trans_data a R' R, disp_nat_trans_axioms b. Definition disp_nat_trans_pr1 {C' C : precategory_data} {F' F : functor_data C' C} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat_data C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b : disp_nat_trans a R' R) {x : C'} (xx : D' x): R' x xx -->[ a x ] R x xx := pr1 b x xx. Coercion disp_nat_trans_pr1 : disp_nat_trans >-> Funclass. Definition disp_nat_trans_ax {C' C : precategory_data} {F' F : functor_data C' C} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat_data C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b : disp_nat_trans a R' R) {x' x : C'} {f : x' --> x} {xx' : D' x'} {xx : D' x} (ff : xx' -->[ f ] xx): ♯ R' ff ;; b _ xx = transportb _ (nat_trans_ax a _ _ f ) (b _ xx' ;; ♯ R ff) := pr2 b _ _ f _ _ ff. Lemma disp_nat_trans_ax_var {C' C : precategory_data} {F' F : functor_data C' C} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat_data C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b : disp_nat_trans a R' R) {x' x : C'} {f : x' --> x} {xx' : D' x'} {xx : D' x} (ff : xx' -->[ f ] xx): b _ xx' ;; ♯ R ff = transportf _ (nat_trans_ax a _ _ f) (♯ R' ff ;; b _ xx). Proof. apply pathsinv0, transportf_pathsinv0. apply pathsinv0, disp_nat_trans_ax. Defined. (** identity disp_nat_trans *) Definition disp_nat_trans_id_ax {C' C : category} {F': functor_data C' C} {D' : disp_cat_data C'} {D : disp_cat C} (R' : disp_functor_data F' D' D) : @disp_nat_trans_axioms _ _ _ _ (nat_trans_id _ ) _ _ R' R' (λ (x : C') (xx : D' x), id_disp (R' x xx)). Proof. intros x' x f xx' xx ff; etrans; [ apply id_right_disp |]; apply transportf_comp_lemma; apply pathsinv0. etrans; [apply id_left_disp |]. unfold transportb. apply maponpaths_2, homset_property. Qed. Definition disp_nat_trans_id {C' C : category} {F': functor_data C' C} {D' : disp_cat_data C'} {D : disp_cat C} (R' : disp_functor_data F' D' D) : disp_nat_trans (nat_trans_id F') R' R'. Proof. use tpair. - intros x xx. apply id_disp. - apply disp_nat_trans_id_ax. Defined. (** composition of disp_nat_trans *) Definition disp_nat_trans_comp_ax {C' C : category} {F'' F' F : functor_data C' C} {a' : nat_trans F'' F'} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat C} {R'' : disp_functor_data F'' D' D} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b' : disp_nat_trans a' R'' R') (b : disp_nat_trans a R' R) : @disp_nat_trans_axioms _ _ _ _ (nat_trans_comp _ _ _ a' a) _ _ R'' R (λ (x : C') (xx : D' x), b' x xx ;; b x xx). Proof. intros x' x f xx' xx ff; etrans; [ apply assoc_disp |]; apply transportf_comp_lemma; apply transportf_pathsinv0; apply pathsinv0; rewrite (disp_nat_trans_ax b'); etrans; [ apply mor_disp_transportf_postwhisker |]; apply transportf_comp_lemma; apply pathsinv0; etrans; [ apply assoc_disp_var |]; apply pathsinv0; apply transportf_comp_lemma; apply pathsinv0; rewrite (disp_nat_trans_ax_var b); rewrite mor_disp_transportf_prewhisker; apply transportf_comp_lemma; apply pathsinv0; etrans; [ apply assoc_disp_var |]. apply maponpaths_2, homset_property. Qed. Definition disp_nat_trans_comp {C' C : category} {F'' F' F : functor_data C' C} {a' : nat_trans F'' F'} {a : nat_trans F' F} {D' : disp_cat_data C'} {D : disp_cat C} {R'' : disp_functor_data F'' D' D} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b' : disp_nat_trans a' R'' R') (b : disp_nat_trans a R' R) : disp_nat_trans (nat_trans_comp _ _ _ a' a) R'' R. Proof. use tpair. - intros x xx. apply (comp_disp (b' _ _ ) (b _ _ )). - apply disp_nat_trans_comp_ax. Defined. Definition disp_nat_trans_eq {C' C : category} {F' F : functor_data C' C} (a : nat_trans F' F) {D' : disp_cat_data C'} {D : disp_cat C} {R' : disp_functor_data F' D' D} {R : disp_functor_data F D' D} (b b' : disp_nat_trans a R' R) : (∏ x (xx : D' x), b x xx = b' x xx) → b = b'. Proof. intro H. apply subtypePath. { intro r. apply isaprop_disp_nat_trans_axioms. } apply funextsec. intro x. apply funextsec. intro xx. apply H. Qed. End Disp_Nat_Trans. Section Utilities. Lemma disp_nat_trans_transportf {C' C : category} {D' : disp_cat C'} {D : disp_cat C} (F' F : functor C' C) (a' a : nat_trans F' F) (p : a' = a ) (FF' : disp_functor F' D' D) (FF : disp_functor F D' D) (b : disp_nat_trans a' FF' FF) (c' : C') (xx' : D' c') : pr1 (transportf (λ x, disp_nat_trans x FF' FF) p b) c' xx' = transportf (mor_disp (FF' c' xx') (FF c' xx')) (nat_trans_eq_pointwise p _ ) (b c' xx'). Proof. induction p. assert (XR : nat_trans_eq_pointwise (idpath a') c' = idpath _ ). { apply homset_property. } rewrite XR. apply idpath. Qed. Lemma disp_nat_trans_id_left {C' C : category} {D' : disp_cat C'} {D : disp_cat C} (F' F : functor C' C) (a : nat_trans F' F) (FF' : disp_functor F' D' D) (FF : disp_functor F D' D) (b : disp_nat_trans a FF' FF) : disp_nat_trans_comp (disp_nat_trans_id FF') b = transportb (λ f : nat_trans F' F, disp_nat_trans f FF' FF) (id_left (a : [C', C] ⟦ _ , _ ⟧)) b. Proof. apply subtypePath. { intro. apply isaprop_disp_nat_trans_axioms. } apply funextsec; intro c'. apply funextsec; intro xx'. apply pathsinv0. etrans. apply disp_nat_trans_transportf. apply pathsinv0. etrans. apply id_left_disp. unfold transportb. apply maponpaths_2, homset_property. Qed. Lemma disp_nat_trans_id_right {C' C : category} {D' : disp_cat C'} {D : disp_cat C} (F' F : functor C' C) (a : nat_trans F' F) (FF' : disp_functor F' D' D) (FF : disp_functor F D' D) (b : disp_nat_trans a FF' FF) : disp_nat_trans_comp b (disp_nat_trans_id FF) = transportb (λ f : nat_trans F' F, disp_nat_trans f FF' FF) (id_right (a : [C',C] ⟦ _ , _ ⟧)) b. Proof. apply subtypePath. { intro. apply isaprop_disp_nat_trans_axioms. } apply funextsec; intro c'. apply funextsec; intro xx'. apply pathsinv0. etrans. apply disp_nat_trans_transportf. apply pathsinv0. etrans. apply id_right_disp. unfold transportb. apply maponpaths_2, homset_property. Qed. Lemma disp_nat_trans_assoc {C' C : category} {D' : disp_cat C'} {D : disp_cat C} (x y z w : functor C' C) (f : nat_trans x y) (g : nat_trans y z) (h : nat_trans z w) (xx : disp_functor x D' D) (yy : disp_functor y D' D) (zz : disp_functor z D' D) (ww : disp_functor w D' D) (ff : disp_nat_trans f xx yy) (gg : disp_nat_trans g yy zz) (hh : disp_nat_trans h zz ww) : disp_nat_trans_comp ff (disp_nat_trans_comp gg hh) = transportb (λ f0 : nat_trans x w, disp_nat_trans f0 xx ww) (assoc (f : [C', C] ⟦_,_⟧) g h) (disp_nat_trans_comp (disp_nat_trans_comp ff gg) hh). Proof. apply subtypePath. { intro. apply isaprop_disp_nat_trans_axioms. } apply funextsec; intro c'. apply funextsec; intro xx'. apply pathsinv0. etrans. apply disp_nat_trans_transportf. apply pathsinv0. etrans. apply assoc_disp. unfold transportb. apply maponpaths_2. apply homset_property. Qed. Lemma isaset_disp_nat_trans {C' C : category} {D' : disp_cat C'} {D : disp_cat C} {x y : functor C' C} (f : nat_trans x y) (xx : disp_functor x D' D) (yy : disp_functor y D' D) : isaset (disp_nat_trans f xx yy). Proof. intros. simpl in *. apply (isofhleveltotal2 2). * do 2 (apply impred; intro). apply homsets_disp. * intro d. do 6 (apply impred; intro). apply hlevelntosn. apply homsets_disp. Qed. Definition pre_whisker_disp_nat_trans {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G₁ G₂ : C₂ ⟶ C₃} {n : G₁ ⟹ G₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {D₃ : disp_cat C₃} (FF : disp_functor F D₁ D₂) {GG₁ : disp_functor G₁ D₂ D₃} {GG₂ : disp_functor G₂ D₂ D₃} (nn : disp_nat_trans n GG₁ GG₂) : disp_nat_trans (pre_whisker F n) (disp_functor_composite FF GG₁) (disp_functor_composite FF GG₂). Proof. use tpair. - exact (λ x xx, nn (F x) (FF x xx)). - abstract (intros x y f xx yy ff ; cbn ; rewrite (disp_nat_trans_ax nn) ; apply maponpaths_2 ; apply C₃). Defined. Definition post_whisker_disp_nat_trans {C₁ C₂ C₃ : category} {F₁ F₂ : C₁ ⟶ C₂} {n : F₁ ⟹ F₂} {G : C₂ ⟶ C₃} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {D₃ : disp_cat C₃} {FF₁ : disp_functor F₁ D₁ D₂} {FF₂ : disp_functor F₂ D₁ D₂} (nn : disp_nat_trans n FF₁ FF₂) (GG : disp_functor G D₂ D₃) : disp_nat_trans (post_whisker n G) (disp_functor_composite FF₁ GG) (disp_functor_composite FF₂ GG). Proof. use tpair. - exact (λ x xx, ♯ GG (nn x xx)). - abstract (intros x y f xx yy ff ; cbn ; rewrite <- !(disp_functor_comp_var GG) ; unfold transportb ; rewrite transport_f_f ; rewrite (disp_nat_trans_ax_var nn) ; rewrite disp_functor_transportf ; rewrite transport_f_f ; apply maponpaths_2 ; apply C₃). Defined. End Utilities. Section CompDispNatTransOverId. Context {C : category} {D₁ D₂ : disp_cat C} {FF GG HH : disp_functor (functor_identity C) D₁ D₂} (α : disp_nat_trans (nat_trans_id _) FF GG) (β : disp_nat_trans (nat_trans_id _) GG HH). Let disp_nat_trans_over_id_comp_data : disp_nat_trans_data (nat_trans_id _) FF HH. Proof. refine (λ x xx, transportf (λ z, _ -->[ z ] _) _ (α x xx ;; β x xx)). abstract (cbn ; apply id_left). Defined. Definition disp_nat_trans_over_id_comp_axioms : disp_nat_trans_axioms disp_nat_trans_over_id_comp_data. Proof. intros x y f xx yy ff ; unfold disp_nat_trans_over_id_comp_data ; cbn. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact (disp_nat_trans_ax α ff). } unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. exact (disp_nat_trans_ax β ff). } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition disp_nat_trans_over_id_comp : disp_nat_trans (nat_trans_id _) FF HH. Proof. simple refine (_ ,, _). - exact disp_nat_trans_over_id_comp_data. - exact disp_nat_trans_over_id_comp_axioms. Defined. End CompDispNatTransOverId. Section PreWhiskDispNatTransOverId. Context {C : category} {D₁ D₂ D₃ : disp_cat C} (FF : disp_functor (functor_identity C) D₁ D₂) {GG₁ GG₂ : disp_functor (functor_identity C) D₂ D₃} (α : disp_nat_trans (nat_trans_id _) GG₁ GG₂). Let disp_nat_trans_over_id_prewhisker_data : disp_nat_trans_data (nat_trans_id _) (disp_functor_composite FF GG₁) (disp_functor_composite FF GG₂) := λ x xx, α x (FF x xx). Definition disp_nat_trans_over_id_prewhisker_axioms : disp_nat_trans_axioms disp_nat_trans_over_id_prewhisker_data. Proof. intros x y f xx yy ff ; cbn. exact (disp_nat_trans_ax α (♯ FF ff)). Qed. Definition disp_nat_trans_over_id_prewhisker : disp_nat_trans (nat_trans_id _) (disp_functor_composite FF GG₁) (disp_functor_composite FF GG₂). Proof. simple refine (_ ,, _). - exact disp_nat_trans_over_id_prewhisker_data. - exact disp_nat_trans_over_id_prewhisker_axioms. Defined. End PreWhiskDispNatTransOverId. Section PreWhiskDispNatTransOverId. Context {C : category} {D₁ D₂ D₃ : disp_cat C} {FF₁ FF₂ : disp_functor (functor_identity C) D₁ D₂} (GG : disp_functor (functor_identity C) D₂ D₃) (α : disp_nat_trans (nat_trans_id _) FF₁ FF₂). Let disp_nat_trans_over_id_postwhisker_data : disp_nat_trans_data (nat_trans_id _) (disp_functor_composite FF₁ GG) (disp_functor_composite FF₂ GG) := λ x xx, (♯ GG (α x xx)). Definition disp_nat_trans_over_id_postwhisker_axioms : disp_nat_trans_axioms disp_nat_trans_over_id_postwhisker_data. Proof. intros x y f xx yy ff ; unfold disp_nat_trans_over_id_postwhisker_data ; cbn. etrans. { refine (!_). exact (disp_functor_comp_var GG (♯ FF₁ ff) (α y yy)). } etrans. { do 2 apply maponpaths. exact (disp_nat_trans_ax α ff). } unfold transportb. rewrite disp_functor_transportf. rewrite transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Definition disp_nat_trans_over_id_postwhisker : disp_nat_trans (nat_trans_id _) (disp_functor_composite FF₁ GG) (disp_functor_composite FF₂ GG). Proof. simple refine (_ ,, _). - exact disp_nat_trans_over_id_postwhisker_data. - exact disp_nat_trans_over_id_postwhisker_axioms. Defined. End PreWhiskDispNatTransOverId. (** Pointwise inverse of displayed natural transformation *) Section PointwiseInverse. Context {C C' : category} {F : C ⟶ C'} {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'} {GG : disp_functor F D D'} (αα : disp_nat_trans (nat_trans_id F) FF GG) (Hαα : ∏ (x : C) (xx : D x), is_z_iso_disp (identity_z_iso (pr1 F x)) (pr1 αα x xx)). Let pointwise_inverse_disp_nat_trans_data : disp_nat_trans_data (nat_trans_id F) GG FF := λ x xx, inv_mor_disp_from_z_iso (Hαα x xx). Definition pointwise_inverse_disp_nat_trans_axioms : disp_nat_trans_axioms pointwise_inverse_disp_nat_trans_data. Proof. intros x y f xx yy ff. use (precomp_with_z_iso_disp_is_inj (make_z_iso_disp _ (Hαα x xx))). simpl. refine (assoc_disp _ _ _ @ _). unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. refine (!_). refine (transport_f_f _ _ _ _ @ _). etrans. { apply maponpaths. apply maponpaths_2. apply (inv_mor_after_z_iso_disp (Hαα x xx)). } etrans. { apply maponpaths. etrans. { apply mor_disp_transportf_postwhisker. } etrans. { apply maponpaths. apply id_left_disp. } apply transport_f_f. } etrans. { apply transport_f_f. } assert (transportf (mor_disp (FF x xx) (GG y yy)) (nat_trans_ax (nat_trans_id F) x y f) (♯ FF ff;; pr1 αα y yy) = pr1 αα x xx;; ♯ GG ff) as X. { apply transportf_transpose_left. exact (pr2 αα x y f xx yy ff). } refine (!_). apply transportf_transpose_left. etrans. { apply maponpaths_2. exact (!X). } rewrite mor_disp_transportf_postwhisker. etrans. { etrans. { apply maponpaths. etrans. { apply assoc_disp_var. } etrans. { apply maponpaths. etrans. { apply maponpaths. apply (inv_mor_after_z_iso_disp (Hαα y yy)). } etrans. { apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths. apply id_right_disp. } apply transport_f_f. } apply transport_f_f. } apply transport_f_f. } refine (!_). etrans. { apply transport_f_f. } apply maponpaths_2. apply homset_property. Qed. Definition pointwise_inverse_disp_nat_trans : disp_nat_trans (nat_trans_id F) GG FF. Proof. simple refine (_ ,, _). - exact pointwise_inverse_disp_nat_trans_data. - exact pointwise_inverse_disp_nat_trans_axioms. Defined. End PointwiseInverse. Lemma pointwise_inverse_disp_nat_trans_over_id_left {C : category} {D : disp_cat C} {D' : disp_cat C} {FF GG : disp_functor (functor_identity _) D D'} (αα : disp_nat_trans (nat_trans_id _) FF GG) (Hαα : ∏ (x : C) (xx : D x), is_z_iso_disp (identity_z_iso x) (pr1 αα x xx)) : disp_nat_trans_over_id_comp αα (pointwise_inverse_disp_nat_trans αα Hαα) = disp_nat_trans_id _. Proof. use disp_nat_trans_eq. intros x xx ; cbn. etrans. { apply maponpaths. apply (inv_mor_after_z_iso_disp (Hαα x xx)). } unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Lemma pointwise_inverse_disp_nat_trans_over_id_right {C : category} {D : disp_cat C} {D' : disp_cat C} {FF GG : disp_functor (functor_identity _) D D'} (αα : disp_nat_trans (nat_trans_id _) FF GG) (Hαα : ∏ (x : C) (xx : D x), is_z_iso_disp (identity_z_iso x) (pr1 αα x xx)) : disp_nat_trans_over_id_comp (pointwise_inverse_disp_nat_trans αα Hαα) αα = disp_nat_trans_id _. Proof. use disp_nat_trans_eq. intros x xx ; cbn. etrans. { apply maponpaths. apply (z_iso_disp_after_inv_mor (Hαα x xx)). } unfold transportb. rewrite transport_f_f. apply transportf_set. apply homset_property. Qed. Section disp_nat_iso. Context {C C': category} {D: disp_cat C} {D': disp_cat C'} {F G: functor C C'}. Definition is_disp_nat_z_iso {DF: disp_functor F D D'} {DG: disp_functor G D D'} (α: nat_z_iso F G) (β: disp_nat_trans α DF DG) : UU := ∏ (c:C) (d:D c), is_z_iso_disp (nat_z_iso_pointwise_z_iso α c) (β c d). Definition disp_nat_z_iso (DF: disp_functor F D D') (DG: disp_functor G D D') (α: nat_z_iso F G): UU := ∑ (β : disp_nat_trans α DF DG), is_disp_nat_z_iso α β. Context {DF: disp_functor F D D'} {DG: disp_functor G D D'}. Definition disp_nat_z_iso_to_trans {α: nat_z_iso F G} (µ : disp_nat_z_iso DF DG α) : disp_nat_trans α DF DG := pr1 µ. Coercion disp_nat_z_iso_to_trans : disp_nat_z_iso >-> disp_nat_trans. End disp_nat_iso. Proposition isaprop_is_disp_nat_z_iso {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {τ : nat_z_iso F G} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {FF : disp_functor F D₁ D₂} {GG : disp_functor G D₁ D₂} (ττ : disp_nat_trans τ FF GG) : isaprop (is_disp_nat_z_iso τ ττ). Proof. repeat (use impred ; intro). apply isaprop_is_z_iso_disp. Qed. Section disp_nat_z_iso_inv. Context {C C': category} {D: disp_cat C} {D': disp_cat C'} {F G: functor C C'}. Context {DF: disp_functor F D D'} {DG: disp_functor G D D'}. Local Open Scope mor_disp. Lemma disp_nat_z_iso_to_trans_inv_data {α: nat_z_iso F G} (β :disp_nat_z_iso DF DG α) : disp_nat_trans_data (nat_z_iso_to_trans_inv α) DG DF. Proof. intros c d. exact (pr1 (pr2 β c d)). Defined. Lemma disp_nat_z_iso_to_trans_inv_axioms {α: nat_z_iso F G} (β :disp_nat_z_iso DF DG α) : disp_nat_trans_axioms (disp_nat_z_iso_to_trans_inv_data β). Proof. intros a b f x y Df. set (eq_nat_trans := nat_trans_ax (nat_z_iso_to_trans_inv α) a b f). apply (postcomp_with_z_iso_disp_is_inj _ _ (pr2 β b y)). etrans. apply assoc_disp_var. apply PartA.transportf_transpose_left. etrans. apply (maponpaths _ (pr1 (pr2 (pr2 β b y)))). etrans. apply mor_disp_transportf_prewhisker. apply PartA.transportf_transpose_left. etrans. apply id_right_disp. apply pathsinv0. etrans. apply transport_b_b. etrans. apply transport_b_b. apply PartA.transportf_transpose_left. etrans. apply assoc_disp_var. apply PartA.transportf_transpose_left. etrans. apply (maponpaths _ ((pr2 (pr1 β)) a b f x y Df)). etrans. apply mor_disp_transportf_prewhisker. apply PartA.transportf_transpose_left. etrans. apply assoc_disp. apply PartA.transportf_transpose_left. etrans. apply (maponpaths (λ Dg, Dg ;; ♯ DG Df) (pr1 (pr2 (pr2 β a x)))). etrans. apply mor_disp_transportf_postwhisker. apply PartA.transportf_transpose_left. etrans. apply id_left_disp. apply pathsinv0. etrans. apply transport_b_b. etrans. apply transport_b_b. etrans. apply transport_b_b. etrans. apply transport_b_b. etrans. apply transport_b_b. apply two_arg_paths. * apply uip. apply homset_property. * reflexivity. Qed. Definition disp_nat_z_iso_to_trans_inv {α: nat_z_iso F G} (β :disp_nat_z_iso DF DG α) : disp_nat_trans (nat_z_iso_to_trans_inv α) DG DF := (disp_nat_z_iso_to_trans_inv_data β,, disp_nat_z_iso_to_trans_inv_axioms β). Definition disp_nat_z_iso_inv {α: nat_z_iso F G} (β :disp_nat_z_iso DF DG α) : disp_nat_z_iso DG DF (nat_z_iso_inv α). Proof. use tpair. - exact (disp_nat_z_iso_to_trans_inv β). - intros c d. exists (β c d). split. * exact (pr2 (pr2 (pr2 β c d))). * exact (pr1 (pr2 (pr2 β c d))). Defined. Local Open Scope cat. Lemma nat_z_iso_iso_inv (α: nat_z_iso F G) (c:C) (d:D c) : α c · nat_z_iso_to_trans_inv α c = identity (F c). Proof. apply (pr2 (pr2 α c)). Qed. Lemma disp_nat_z_iso_iso_inv {α: nat_z_iso F G} (β: disp_nat_z_iso DF DG α) (c:C) (d:D c) : (β c d) ;; (disp_nat_z_iso_to_trans_inv β c d) = transportb (mor_disp (DF c d) (DF c d)) (nat_z_iso_iso_inv α c d) (id_disp (DF c d)). Proof. etrans. apply (pr2 (pr2 (pr2 β c d))). apply two_arg_paths. - apply uip. apply homset_property. - reflexivity. Qed. Lemma nat_z_iso_inv_iso (α: nat_z_iso F G) (c:C) (d:D c) : nat_z_iso_to_trans_inv α c · α c = identity (G c). Proof. apply (pr2 (pr2 α c)). Qed. Lemma disp_nat_z_iso_inv_iso {α: nat_z_iso F G} (β: disp_nat_z_iso DF DG α) (c:C) (d:D c) : (disp_nat_z_iso_to_trans_inv β c d) ;; (β c d) = transportb (mor_disp (DG c d) (DG c d)) (nat_z_iso_inv_iso α c d) (id_disp (DG c d)). Proof. etrans. apply (pr1 (pr2 (pr2 β c d))). apply two_arg_paths. - apply uip. apply homset_property. - reflexivity. Qed. Local Close Scope cat. End disp_nat_z_iso_inv. Local Close Scope mor_disp. Section disp_nat_z_iso_comp. Context {C C': category} {D: disp_cat C} {D': disp_cat C'} {F G H: functor C C'}. Context {DF: disp_functor F D D'} {DG: disp_functor G D D'} {DH: disp_functor H D D'}. Lemma disp_nat_trans_comp_inv {α: nat_z_iso F G} {α': nat_z_iso G H} (β: disp_nat_z_iso DF DG α) (β': disp_nat_z_iso DG DH α') (c:C) (d:D c) : is_disp_inverse (nat_z_iso_pointwise_z_iso (nat_z_iso_comp α α') c) (disp_nat_trans_comp β β' c d) (disp_nat_trans_comp (disp_nat_z_iso_inv β') (disp_nat_z_iso_inv β) c d). Proof. split. - etrans. apply assoc_disp. apply PartA.transportb_transpose_left. etrans. apply assoc4_disp. apply PartA.transportb_transpose_left. etrans. apply id_conjugation_disp. * apply disp_nat_z_iso_inv_iso. * apply disp_nat_z_iso_inv_iso. * unfold transportb. repeat rewrite transport_f_f. apply two_arg_paths. -- apply uip. apply homset_property. -- reflexivity. - etrans. apply assoc_disp. apply PartA.transportb_transpose_left. etrans. apply assoc4_disp. apply PartA.transportb_transpose_left. etrans. apply id_conjugation_disp. * apply disp_nat_z_iso_iso_inv. * apply disp_nat_z_iso_iso_inv. * unfold transportb. repeat rewrite transport_f_f. apply two_arg_paths. -- apply uip. apply homset_property. -- reflexivity. Qed. Definition disp_nat_z_iso_comp {α: nat_z_iso F G} {α': nat_z_iso G H} (β: disp_nat_z_iso DF DG α) (β': disp_nat_z_iso DG DH α') : disp_nat_z_iso DF DH (nat_z_iso_comp α α') . Proof. exists (disp_nat_trans_comp β β'). intros c d. exists (disp_nat_trans_comp (disp_nat_z_iso_inv β') (disp_nat_z_iso_inv β) c d). apply disp_nat_trans_comp_inv. Defined. End disp_nat_z_iso_comp. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Projection.v000066400000000000000000000373341451125700300246720ustar00rootroot00000000000000(** Author: Niels van der Weide In this file, we show the following: - a displayed category adds properties if the type of displayed morphisms is contractible - a displayed category adds structure if the type of displayed morphisms is a proposition *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope cat. (** We start with the definitions from https://ncatlab.org/nlab/show/stuff%2C+structure%2C+property#definitions *) Definition adds_structure {C : category} (D : disp_cat C) : UU := faithful (pr1_category D). Definition adds_properties {C : category} (D : disp_cat C) : UU := full_and_faithful (pr1_category D). Definition discrete_pr1_category {C : category} (D : disp_cat C) : UU := faithful (pr1_category D) × conservative (pr1_category D). Definition pseudomonic_pr1_category {C : category} (D : disp_cat C) : UU := pseudomonic (pr1_category D). (** Now we give some conditions to check whether structure or properties are being added via the hlevel of the displayed morphisms. Local propositionality is now found in [Core.v] A displayed category is locally inhabited if there is a displayed morphism above each morphism in the base. *) Definition locally_inhabited {C : category} (D : disp_cat C) : UU := ∏ (x y : C) (f : x --> y) (xx : D x) (yy : D y), xx -->[ f ] yy. Definition locally_iso_inhabited {C : category} (D : disp_cat C) : UU := ∏ (x y : C) (f : z_iso x y) (xx : D x) (yy : D y), xx -->[ f ] yy. (** Lastly, we look at local contractability. *) Definition locally_contractible {C : category} (D : disp_cat C) : UU := ∏ (x y : C) (f : x --> y) (xx : D x) (yy : D y), iscontr (xx -->[ f ] yy). Definition isaprop_locally_contractible {C : category} (D : disp_cat C) : isaprop (locally_contractible D). Proof. do 5 (use impred ; intro). apply isapropiscontr. Defined. Definition locally_iso_contractible {C : category} (D : disp_cat C) : UU := ∏ (x y : C) (f : z_iso x y) (xx : D x) (yy : D y), iscontr (xx -->[ f ] yy). Definition isaprop_locally_iso_contractible {C : category} (D : disp_cat C) : isaprop (locally_iso_contractible D). Proof. do 5 (use impred ; intro). apply isapropiscontr. Defined. (** A displayed category is called groupoidal if all morphisms over isomorphisms are also isomorphisms. *) Definition groupoidal_disp_cat {C : category} (D : disp_cat_data C) : UU := ∏ (x y : C) (f : x --> y) (Hf : is_z_isomorphism f) (xx : D x) (yy : D y) (ff : xx -->[ f ] yy), is_z_iso_disp (make_z_iso' f Hf) ff. Definition isaprop_groupoidal_disp_cat {C : category} (D : disp_cat C) : isaprop (groupoidal_disp_cat D). Proof. do 7 (use impred ; intro). apply isaprop_is_z_iso_disp. Qed. (** Discrete displayed categories are both groupoidal and locally propositional. *) Definition discrete_disp_cat {C : category} (D : disp_cat C) : UU := locally_propositional D × groupoidal_disp_cat D. (** We define pseudomonic displayed categories as well *) Definition pseudomonic_disp_cat {C : category} (D : disp_cat C) : UU := locally_propositional D × locally_iso_inhabited D. Definition isaprop_pseudomonic_disp_cat {C : category} (D : disp_cat C) : isaprop (pseudomonic_disp_cat D). Proof. use invproofirrelevance. intros φ₁ φ₂. use pathsdirprod. - apply isaprop_locally_propositional. - repeat (use funextsec ; intro). apply (pr1 φ₁). Qed. (** Now let us look at the relations between these properties. *) Definition locally_propositional_if_locally_contractible {C : category} (D : disp_cat C) : locally_contractible D → locally_propositional D. Proof. intros HD ? ; intros. apply isapropifcontr. apply HD. Defined. Definition locally_inhabited_if_locally_contractible {C : category} (D : disp_cat C) : locally_contractible D → locally_inhabited D. Proof. intros HD ? ; intros. apply HD. Defined. Definition locally_contractible_if_locally_inhabited_prop {C : category} (D : disp_cat C) : locally_inhabited D → locally_propositional D → locally_contractible D. Proof. intros HD₁ HD₂ x y f xx yy. use iscontraprop1. - exact (HD₂ x y f xx yy). - exact (HD₁ x y f xx yy). Defined. Definition locally_groupoid_if_pseudomonic {C : category} (D : disp_cat C) (H : pseudomonic_disp_cat D) : groupoidal_disp_cat D. Proof. intros x y f Hf xx yy ff. simple refine (_ ,, (_ ,, _)). + exact (pr2 H y x (z_iso_inv (f ,, Hf)) yy xx). + apply H. + apply H. Defined. Definition pseudomonic_to_iso_contractible {C : category} {D : disp_cat C} (H : pseudomonic_disp_cat D) : locally_iso_contractible D. Proof. intros x y f xx yy. use iscontraprop1. - apply H. - apply H. Qed. Definition pseudomonic_weq_locally_prop_and_iso_contractible {C : category} (D : disp_cat C) : pseudomonic_disp_cat D ≃ locally_propositional D × locally_iso_contractible D. Proof. use weqimplimpl. - intro H. split. + apply H. + apply pseudomonic_to_iso_contractible. exact H. - intro H. split. + exact (pr1 H). + intros x y f xx yy. apply (pr2 H). - apply isaprop_pseudomonic_disp_cat. - apply isapropdirprod. + apply isaprop_locally_propositional. + apply isaprop_locally_iso_contractible. Defined. (** Locally propositionality implies the displayed objects form a set. For this, we assume the displayed univalence. *) Definition locally_propositional_to_obj_set {C : category} (D : disp_cat C) (HD₁ : is_univalent_disp D) (HD₂ : locally_propositional D) : ∏ (x : C), isaset (D x). Proof. intros x xx yy. specialize (HD₁ x x (idpath _) xx yy). apply (isofhlevelweqb 1 (make_weq _ HD₁)). use isofhleveltotal2. - apply HD₂. - intro. apply isaprop_is_z_iso_disp. Defined. (** Locally contractibility implies the displayed objects form a proposition. We first show that all displayed morphisms are invertible. Again we assume displayed univalence. *) Definition locally_contractible_disp_iso {C : category} (D : disp_cat C) {x y : C} {f : z_iso x y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (HD : locally_contractible D) : is_z_iso_disp f ff. Proof. simple refine (_ ,, _ ,, _). - apply HD. - apply (locally_propositional_if_locally_contractible _ HD). - apply (locally_propositional_if_locally_contractible _ HD). Defined. Definition locally_iso_contractible_disp_iso {C : category} (D : disp_cat C) {x y : C} {f : z_iso x y} {xx : D x} {yy : D y} (ff : xx -->[ f ] yy) (HD : locally_iso_contractible D) (HD' : locally_propositional D) : is_z_iso_disp f ff. Proof. simple refine (_ ,, _ ,, _). - apply (HD y x (z_iso_inv f) yy xx). - apply HD'. - apply HD'. Defined. Definition locally_contractible_to_obj_prop {C : category} (D : disp_cat C) (HD₁ : is_univalent_disp D) (HD₂ : locally_contractible D) : ∏ (x : C), isaprop (D x). Proof. intros x xx yy. specialize (HD₁ x x (idpath _) xx yy). apply (isofhlevelweqb 0 (make_weq _ HD₁)). use isofhleveltotal2. - apply HD₂. - intro f. apply iscontraprop1. + apply isaprop_is_z_iso_disp. + apply locally_contractible_disp_iso. apply HD₂. Defined. Definition locally_iso_contractible_to_obj_prop {C : category} (D : disp_cat C) (HD₁ : is_univalent_disp D) (HD₂ : locally_iso_contractible D) (HD₃ : locally_propositional D) : ∏ (x : C), isaprop (D x). Proof. intros x xx yy. specialize (HD₁ x x (idpath _) xx yy). apply (isofhlevelweqb 0 (make_weq _ HD₁)). use isofhleveltotal2. - apply HD₂. - intro f. apply iscontraprop1. + apply isaprop_is_z_iso_disp. + apply locally_iso_contractible_disp_iso. * apply HD₂. * exact HD₃. Defined. (** We can instantiate this to pseudomonic displayed categories *) Definition pseudomonic_disp_cat_to_obj_prop {C : category} (D : disp_cat C) (HD₁ : is_univalent_disp D) (HD₂ : pseudomonic_disp_cat D) : ∏ (x : C), isaprop (D x). Proof. apply locally_iso_contractible_to_obj_prop. - exact HD₁. - apply pseudomonic_to_iso_contractible. exact HD₂. - apply HD₂. Defined. (** Adding properties is the same as being locally propositional *) Definition pr1_category_faithful {C : category} (D : disp_cat C) (HD : locally_propositional D) : adds_structure D. Proof. intros x y f. use invproofirrelevance. intros fib₁ fib₂. use subtypePath. { intro ; apply homset_property. } use subtypePath. { intro ; apply HD. } exact (pr2 fib₁ @ !(pr2 fib₂)). Defined. Definition disp_cat_is_locally_propositional {C : category} (D : disp_cat C) (HD : adds_structure D) : locally_propositional D. Proof. intros x y f xx yy. apply invproofirrelevance. intros ff gg. unfold faithful in HD. specialize (HD (x ,, xx) (y ,, yy) f). pose (proofirrelevance _ HD ((f ,, ff) ,, idpath _) ((f ,, gg) ,, idpath _)) as HD'. simpl in HD'. pose (maponpaths pr1 HD') as p. refine (_ @ fiber_paths p). refine (!_) ; cbn. apply transportf_set. apply homset_property. Defined. Definition adds_structure_weq_locally_propositional {C : category} (D : disp_cat C) : adds_structure D ≃ locally_propositional D. Proof. use weqimplimpl. - exact (disp_cat_is_locally_propositional D). - exact (pr1_category_faithful D). - apply isaprop_faithful. - apply isaprop_locally_propositional. Defined. Definition pr1_category_full {C : category} (D : disp_cat C) (HD : locally_inhabited D) : full (pr1_category D). Proof. intros x y f. apply hinhpr. refine ((f ,, _) ,, idpath _) ; cbn. exact (HD (pr1 x) (pr1 y) f (pr2 x) (pr2 y)). Defined. Definition pr1_category_fully_faithful {C : category} (D : disp_cat C) (HD : locally_contractible D) : adds_properties D. Proof. split. - apply pr1_category_full. apply locally_inhabited_if_locally_contractible. apply HD. - apply pr1_category_faithful. apply locally_propositional_if_locally_contractible. apply HD. Defined. Section DispProjectionIsContractible. Context {C : category} (D : disp_cat C) (HD : adds_properties D). Definition pr1_category_inhabited : locally_inhabited D. Proof. intros x y f xx yy. pose (pr1 HD (x ,, xx) (y ,, yy) f) as i. unfold issurjective in i. cbn in i. use (@hinhuniv _ (make_hProp _ _) _ i). - apply disp_cat_is_locally_propositional. apply HD. - cbn ; intros z. pose (pr21 z) as m. pose (pr2 z) as p. cbn in m, p. exact (transportf (λ z, xx -->[ z ] yy) p m). Defined. Definition pr1_category_locally_contractible : locally_contractible D. Proof. use locally_contractible_if_locally_inhabited_prop. - exact pr1_category_inhabited. - apply disp_cat_is_locally_propositional. apply HD. Defined. End DispProjectionIsContractible. Definition adds_properties_weq_locally_contractible {C : category} (D : disp_cat C) : adds_properties D ≃ locally_contractible D. Proof. use weqimplimpl. - exact (pr1_category_locally_contractible D). - exact (pr1_category_fully_faithful D). - apply isaprop_full_and_faithful. - apply isaprop_locally_contractible. Defined. (** Next we relate groupoidal displayed categories with conservativity *) Definition groupoidal_disp_cat_to_conservative {C : category} {D : disp_cat C} (HD : groupoidal_disp_cat D) : conservative (pr1_category D). Proof. intros x y f Hf. use is_z_iso_total. - exact Hf. - apply HD. Defined. Definition conservative_to_groupoidal_disp_cat {C : category} {D : disp_cat C} (HD : conservative (pr1_category D)) : groupoidal_disp_cat D. Proof. intros x y f Hf xx yy ff. assert (@is_z_isomorphism (total_category D) (_ ,, _) (_ ,, _) (f ,, ff)) as Hff. { apply HD. apply Hf. } refine (transportf (λ z, is_z_iso_disp (make_z_iso' f z) ff) _ (is_z_iso_disp_from_total Hff)). apply isaprop_is_z_isomorphism. Defined. Definition groupoidal_disp_cat_weq_conservative {C : category} (D : disp_cat C) : groupoidal_disp_cat D ≃ conservative (pr1_category D). Proof. use weqimplimpl. - exact groupoidal_disp_cat_to_conservative. - exact conservative_to_groupoidal_disp_cat. - exact (isaprop_groupoidal_disp_cat D). - apply isaprop_conservative. Defined. (** We can also characterize discrete displayed categories *) Definition discrete_disp_cat_weq_discrete_projection {C : category} (D : disp_cat C) : discrete_disp_cat D ≃ discrete_pr1_category D. Proof. use weqdirprodf. - exact (invweq (adds_structure_weq_locally_propositional D)). - exact (groupoidal_disp_cat_weq_conservative D). Defined. (** Now we characterize at pseudomonic displayed categories *) Definition pseudomonic_disp_cat_to_pseudomonic_pr1 {C : category} (D : disp_cat C) (H : pseudomonic_disp_cat D) : pseudomonic_pr1_category D. Proof. split. - apply pr1_category_faithful. apply H. - intros x y f. apply hinhpr. simple refine (((pr1 f ,, pr2 H (pr1 x) (pr1 y) f (pr2 x) (pr2 y)) ,, _) ,, _). + cbn. use is_z_iso_total. * exact (pr2 f). * cbn. apply locally_groupoid_if_pseudomonic. apply H. + use z_iso_eq ; cbn. apply idpath. Qed. Definition pseudomonic_disp_cat_from_pseudomonic_pr1 {C : category} (D : disp_cat C) (H : pseudomonic_pr1_category D) : pseudomonic_disp_cat D. Proof. split. - apply disp_cat_is_locally_propositional. apply H. - intros x y f xx yy. use (factor_through_squash _ _ (pr2 H (x ,, xx) (y ,, yy) f)). + apply disp_cat_is_locally_propositional. apply H. + intros ff. exact (transportf (λ z, _ -->[ z ] _) (maponpaths pr1 (pr2 ff)) (pr211 ff)). Qed. Definition pseudomonic_disp_cat_weq_pseudomonic_pr1 {C : category} (D : disp_cat C) : pseudomonic_disp_cat D ≃ pseudomonic_pr1_category D. Proof. use weqimplimpl. - exact (pseudomonic_disp_cat_to_pseudomonic_pr1 D). - exact (pseudomonic_disp_cat_from_pseudomonic_pr1 D). - apply isaprop_pseudomonic_disp_cat. - apply isaprop_pseudomonic. Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/README.md000066400000000000000000000016101451125700300236320ustar00rootroot00000000000000Package *Displayed_Cats* =================================================== Authors: Benedikt Ahrens, Peter LeFanu Lumsdaine Contents -------- The files of this package provide: * *Auxiliary.v* * Some background material * *Core.v* * Definition of displayed categories * Definition of total categories * Displayed functors * Displayed natural transformations * *Fibrations.v* * Definitions of isofibrations, (op)fibrations, discrete fibrations * Clovenness of any univalent fibration * *Constructions.v* * Direct product of displayed categories * Sigmas of displayed categories * Displayed functor categories * Fiber categories * *Equivalences.v* * Displayed adjunctions * Displayed equivalences * Transfer of displayed equivalences to fibers * *Examples.v* * Displayed arrow category * *SIP.v* * Proof of the Structure Identity Principle (HoTT book, chapter 9.8) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/ReindexingForward.v000066400000000000000000001147131451125700300261740ustar00rootroot00000000000000 (* reindexing forward (reindexig_f) for displayed categories and the universal property that it respects.*) (* D -- functor reindexing_forward --> reindexing_forward *) (* ↓ ↓ ↓ *) (* C ------------------- F -------------------> C' *) (* May 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Export UniMath.CategoryTheory.Core.Categories. Require Export UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration. Local Open Scope cat. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Declare Scope reindexing_forward_scope. Notation "↙ x" := (pr1 x) (at level 2):reindexing_forward_scope. Notation "← x" := (pr2 (pr2 x)) (at level 2):reindexing_forward_scope. Notation "¤ x" := (pr1(pr2 x)) (at level 2):reindexing_forward_scope. (* Recreate base objects from an object x' over c' of the reindexing_forward *) (* x:= (← x') -----?-----> x' =: (↙ x', ¤ x', ← x') *) (* ↓ ↓ *) (* c:= (↙ x') -----F-----> c' *) (* ¤ x: F c = c' *) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section reindexing_forward. Local Open Scope reindexing_forward_scope. Context {C C':category} (D :disp_cat C) (F :functor C C'). (* D -- functor reindexing_forward --> reindexing_forward *) (* ↓ ↓ ↓ *) (* C ------------------- F -------------------> C' *) Definition reindexing_forward_ob_mor : disp_cat_ob_mor C'. Proof. use make_disp_cat_ob_mor. - exact (λ c', ∑c:C,(F c=c' × ob_disp D c)). - intros a' b' x' y' f'. exact (∑f:(↙ x')-->(↙ y'), (double_transport (¤ x') (¤ y') (# F f)=f' × (← x')-->[f](← y'))). Defined. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (* Some lemmas to caracterize the equality of reindexing_forward objects and morphisms *) Lemma reindexing_forward_ob_eq {c' : C'} {x' :ob_disp reindexing_forward_ob_mor c'} {y' :ob_disp reindexing_forward_ob_mor c'} (e0 : ↙x' = ↙y') : transportf (λ c, F c = c') e0 ¤x' = ¤y' -> transportf _ e0 ←x' = ←y' -> x' = y'. Proof. intros e1 e2. apply (total2_paths_f e0). etrans. exact (transportf_dirprod C (λ c, F c = c') D x' y' e0). apply dirprod_paths. - exact e1. - exact e2. Defined. (* As UIP can be used, equalities between morphisms are simpler *) Lemma reindexing_forward_mor_eq {a' b':C'} {x' :ob_disp reindexing_forward_ob_mor a'} {y' :ob_disp reindexing_forward_ob_mor b'} {f': C' ⟦ a', b' ⟧} {Df' : x' -->[ f'] y'} {Dg' : x' -->[ f'] y'} (e:↙ Df' = ↙ Dg') :transportf _ e ←Df' = ←Dg' -> Df'= Dg'. Proof. intro H. apply (total2_paths_f e). etrans. apply (transportf_dirprod (↙x' --> ↙ y') (λ f, double_transport ¤ (x') ¤ (y') (# F f) = f') (mor_disp ←x' ←y') Df' Dg' e). apply dirprod_paths. - apply uip. apply homset_property. - apply H. Defined. (* Same than the one above but with transportf *) Lemma reindexing_forward_paths_f_mor {a' b':C'} {x' :ob_disp reindexing_forward_ob_mor a'} {y' :ob_disp reindexing_forward_ob_mor b'} {f': C' ⟦ a', b' ⟧} {g': C' ⟦ a', b' ⟧} {p:g'=f'} (Df' : x' -->[ f'] y') (Dg' : x' -->[ g'] y') (e:↙ Dg' = ↙ Df') :← Df' = transportf _ e (← Dg') -> (Df'=transportf _ p Dg'). Proof. intro H. destruct p. exact (! reindexing_forward_mor_eq e (! H)). Qed. Lemma pr1_transportf_mor_disp_reindexing_forward {a' b' : C'} {f' g' : a' --> b'} {x' :ob_disp reindexing_forward_ob_mor a'} {y' :ob_disp reindexing_forward_ob_mor b'} (e : f' = g') (ff' : x' -->[f'] y') : pr1 (transportf (mor_disp x' y') e ff') = pr1 ff'. Proof. destruct e. reflexivity. Defined. Opaque pr1_transportf_mor_disp_reindexing_forward. Lemma pr22_transportf_mor_disp_reindexing_forward {a' b' : C'} {f' g' : a' --> b'} {x' :ob_disp reindexing_forward_ob_mor a'} {y' :ob_disp reindexing_forward_ob_mor b'} (e : f' = g') (ff' : x' -->[f'] y') : pr22 (transportf (mor_disp x' y') e ff') = transportf (mor_disp (pr22 x') (pr22 y')) (! pr1_transportf_mor_disp_reindexing_forward e ff') (pr22 ff'). Proof. destruct e. reflexivity. Qed. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Lemma reindexing_forward_id {c': C'} {x' : ob_disp reindexing_forward_ob_mor c'} : identity c' = double_transport (¤ x') (¤ x') (# F (identity (↙ x'))). Proof. destruct (¤ x'). apply pathsinv0. exact (functor_id_id C C' F _ _ (idpath _)). Qed. Lemma reindexing_forward_comp {a' b' c': C'} {x' : ob_disp reindexing_forward_ob_mor a'} {y' : ob_disp reindexing_forward_ob_mor b'} {z' : ob_disp reindexing_forward_ob_mor c'} {f':C' ⟦ a', b' ⟧} {g':C' ⟦ b', c' ⟧} {Df': x' -->[ f'] y'} {Dg': y' -->[ g'] z'} :f' · g' = double_transport (¤ x') (¤ z') (# F (↙ Df' · ↙ Dg')). Proof. destruct (¤ Df'), (¤ Dg'). destruct (¤ x'), (¤ y'), (¤ z'). cbn. apply pathsinv0. apply functor_comp. Defined. Definition reindexing_forward_id_comp : disp_cat_id_comp C' reindexing_forward_ob_mor. Proof. use tpair. - intros c' x'. exists (identity (↙ x')). use tpair. * apply (! reindexing_forward_id). * exact (id_disp (← x')). - intros a' b' c' f' g' x' y' z'. intros Df' Dg'. exists ((↙ Df')·(↙ Dg')). use tpair. * apply (! reindexing_forward_comp). * exact (comp_disp (← Df') (← Dg')). Defined. Definition reindexing_forward_disp_cat_data : disp_cat_data C' := (reindexing_forward_ob_mor,, reindexing_forward_id_comp). Local Open Scope mor_disp. Definition reindexing_forward_disp_cat_axioms : disp_cat_axioms C' reindexing_forward_disp_cat_data. Proof. repeat apply tpair. - intros a' b' f' x' y' Df'. apply (reindexing_forward_paths_f_mor (id_disp x' ;; Df') Df' (! id_left (↙ Df'))). exact (id_left_disp (← Df')). - intros a' b' f' x' y' Df'. apply (reindexing_forward_paths_f_mor (Df';; id_disp y') Df' (! id_right (↙ Df'))). exact (id_right_disp (← Df')). - intros a' b' c' d' f' g' h' x' y' z' w' Df' Dg' Dh'. apply (reindexing_forward_paths_f_mor (Df' ;; (Dg' ;; Dh')) (Df' ;; Dg' ;; Dh') (! assoc (↙ Df') (↙ Dg') (↙ Dh') )). exact (assoc_disp (← Df') (← Dg') (← Dh')). - intros a' b' f' x' y'. apply isaset_total2. * apply homset. * intro f. apply isaset_dirprod. --apply isasetaprop. apply homset_property. --apply homsets_disp. Qed. Local Close Scope mor_disp. Local Close Scope reindexing_forward_scope. End reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Definition reindexing_forward {C C':category} (D:disp_cat C) (F: functor C C') : disp_cat C' := (reindexing_forward_disp_cat_data D F,, reindexing_forward_disp_cat_axioms D F). (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section functor_reindexing_forward. Context {C C':category} (D :disp_cat C) (F :functor C C'). (* D -- functor reindexing_forward --> reindexing_forward *) (* ↓ ↓ ↓ *) (* C ---------- F ----------> C' *) Definition data_functor_reindexing_forward : disp_functor_data F D (reindexing_forward D F). Proof. use tpair. - exact (λ (c:C) (d: D c), (c,, idpath (F c),, d)). - intros a b x y f Df. exact (f ,,idpath (# F f),, Df). Defined. Local Open Scope mor_disp. Definition axioms_reindexing_forward_functor : disp_functor_axioms data_functor_reindexing_forward. Proof. use tpair. - intros a x. apply (reindexing_forward_paths_f_mor D F (♯ (data_functor_reindexing_forward) (id_disp x)) (id_disp (data_functor_reindexing_forward a x)) (idpath _)). exact (idpath (id_disp x)). - intros a b c x y z f g Df Dg. apply (reindexing_forward_paths_f_mor D F (♯ (data_functor_reindexing_forward) (Df;;Dg)) (♯ data_functor_reindexing_forward Df ;; ♯ data_functor_reindexing_forward Dg) (idpath _)). exact (idpath (Df;;Dg)). Qed. Local Close Scope mor_disp. End functor_reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Definition functor_reindexing_forward {C C':category} (D:disp_cat C) (F:functor C C') : disp_functor F D (reindexing_forward D F) := (data_functor_reindexing_forward D F,, axioms_reindexing_forward_functor D F). (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section functor_universal_property_reindexing_forward. Context {C C' C'': category} {D:disp_cat C} {F: functor C C'}. Let D' := reindexing_forward D F. Let DF := functor_reindexing_forward D F. Context (H: functor C' C'') (D'': disp_cat C'') (DG: disp_functor (F ∙ H) D D''). Local Notation "X ◦ Y" := (disp_functor_composite X Y) (at level 45). (* ---------------- DG ----------------> *) (* D -- DF --> D' -- functor univ prop --> D'' *) (* ↓ ↓ ↓ ↓ ↓ *) (* C -- F --> C' ---------- H ----------> C'' *) Local Open Scope reindexing_forward_scope. Definition data_functor_univ_prop_reindexing_forward : disp_functor_data H D' D''. Proof. use tpair. - intros c' d'. exact (transportf (λ x, D'' (H x)) (¤ d') (DG (↙ d') (← d'))). - intros a' b' x' y' f' Df'. apply (transportf (λ f0, mor_disp _ _ (# H f0)) (¤ Df')). apply double_transport_disp. exact ((♯ DG (← Df'))%mor_disp). Defined. Local Close Scope reindexing_forward_scope. Definition axioms_functor_univ_prop_reindexing_forward : disp_functor_axioms data_functor_univ_prop_reindexing_forward. Proof. use tpair. - intros c' d'. induction d' as (c,(p,d)). destruct p. cbn. etrans. apply functtransportf. etrans. apply (maponpaths _ (disp_functor_id DG d)). etrans. apply transport_f_b. unfold transportb. apply two_arg_paths. * apply uip. apply homset_property. * reflexivity. - intros a' b' c' x' y' z' f' g' Df' Dg'. induction Df' as (f,(pf,Df)). induction Dg' as (g,(pg,Dg)). destruct pf, pg. cbn. etrans. apply functtransportf. rewrite (disp_functor_comp DG). destruct (pr1 (pr2 x')), (pr1 (pr2 z')). cbn. destruct (pr1 (pr2 y')). cbn. etrans. apply transport_f_b. unfold transportb. apply two_arg_paths. * apply uip. apply homset_property. * reflexivity. Qed. End functor_universal_property_reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Definition functor_univ_prop_reindexing_forward {C C' C'': category} {D:disp_cat C} {F: functor C C'} (H: functor C' C'') (D'': disp_cat C'') (DG: disp_functor (F ∙ H) D D'') : disp_functor H (reindexing_forward D F) D'' := (data_functor_univ_prop_reindexing_forward H D'' DG,, axioms_functor_univ_prop_reindexing_forward H D'' DG). (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section unicity_universal_property_reindexing_forward. Context {C C' C'': category} {D:disp_cat C} {F: functor C C'}. Let D' := reindexing_forward D F. Let DF := functor_reindexing_forward D F. Context (H: functor C' C'') (D'': disp_cat C'') (DG: disp_functor (F ∙ H) D D''). Let DH := functor_univ_prop_reindexing_forward H D'' DG. Local Notation "X ◦ Y" := (disp_functor_composite X Y) (at level 45). (* Here we prove the unicity of DH *) (* -------- DG --------> *) (* D -- DF --> D' -- DH --> D'' *) (* ↓ ↓ ↓ ↓ ↓ *) (* C -- F --> C' -- H --> C'' *) Definition univ_prop_reindexing_forward_eq : disp_functor_composite DF DH= DG. Proof. apply disp_functor_eq. reflexivity. Defined. Definition univ_prop_reindexing_forward : disp_nat_z_iso (DF ◦ DH) DG (nat_z_iso_id (F ∙ H)). Proof. - repeat use tpair. * exact (λ c d,id_disp (DG c d)). * intros a b f x y Df. cbn. etrans. apply id_right_disp. apply pathsinv0. rewrite id_left_disp. etrans. apply transport_b_b. apply two_arg_paths. -- apply uip. apply homset_property. -- reflexivity. * intros c d. cbn. exists (id_disp (DG c d)). split; apply id_left_disp. Defined. Local Open Scope reindexing_forward_scope. (*Lemma to use the fact that the total functor of DF is invertible*) Definition DF_inv_mor (DM DN: disp_functor H D' D'') (c':C') (d':D' c') : (DF ◦ DM) ↙d' ←d' -->[identity _] (DF ◦ DN) ↙d' ←d' -> DM c' d' -->[identity _] DN c' d'. Proof. intro Hyp. induction d' as (c,(p,d)). destruct p. exact Hyp. Defined. Lemma DF_inv_mor_simpl {DM DN: disp_functor H D' D''} {c':C'} {d':D' c'} (A: (DF ◦ DM) ↙d' ←d' -->[identity _] (DF ◦ DN) ↙d' ←d') (B: (DF ◦ DN) ↙d' ← d'-->[identity _] (DF ◦ DM) ↙d' ←d') : (A;;B = transportb _ (id_left _) (id_disp _)-> (DF_inv_mor DM DN c' d' A);;(DF_inv_mor DN DM c' d' B) = transportb _ (id_left _) (id_disp (DM c' d')))%mor_disp. Proof. intro Hyp. induction d' as (c,(p,d)). destruct p. exact Hyp. Qed. Local Open Scope mor_disp. (*creation of a natural transformation from DH0 to DH1 for any DH0 and DH1*) Lemma DH0_DH1_nat_trans_data {DH0 DH1:disp_functor H D' D''} (β: disp_nat_trans (nat_z_iso_id (F ∙ H)) (DF ◦ DH0) (DF ◦ DH1)) :disp_nat_trans_data (nat_z_iso_id H) DH0 DH1. Proof. intros c' d'. apply (DF_inv_mor DH0 DH1 c' d'). exact (β ↙d' ←d'). Defined. Lemma DH0_DH1_nat_trans_axioms {DH0 DH1 :disp_functor H D' D''} (β: disp_nat_trans (nat_z_iso_id (F ∙ H)) (DF ◦ DH0) (DF ◦ DH1)) : disp_nat_trans_axioms (DH0_DH1_nat_trans_data β). Proof. intros a' b' f' x' y' Df'. induction x' as (a,(px,x)). induction y' as (b,(py,y)). induction Df' as (f,(pf,Df)). destruct px, py, pf. cbn. etrans. apply (pr2 β a b f x y Df). apply two_arg_paths. - apply uip. apply homset_property. - reflexivity. Qed. Definition DH0_DH1_nat_trans {DH0 DH1 :disp_functor H D' D''} (β: disp_nat_trans (nat_z_iso_id (F ∙ H)) (DF ◦ DH0) (DF ◦ DH1)) : disp_nat_trans (nat_z_iso_id H) DH0 DH1 := (DH0_DH1_nat_trans_data β,, DH0_DH1_nat_trans_axioms β). (*Proof that the displayed natural transformation above is an isomorphism*) Lemma DH0_DH1_is_disp_nat_z_iso {DH0 DH1 :disp_functor H D' D''} (β: disp_nat_z_iso (DF ◦ DH0) (DF ◦ DH1) (nat_z_iso_id (F ∙ H))) : is_disp_nat_z_iso (nat_z_iso_id H) (DH0_DH1_nat_trans β). Proof. set (β_inv := disp_nat_z_iso_to_trans_inv β). intros c' d'. use tpair. - cbn. apply (DF_inv_mor DH1 DH0 c' d'). exact (β_inv ↙d' ←d'). - split. * apply DF_inv_mor_simpl. etrans. apply (pr2 (pr2 β ↙d' ←d')). apply (maponpaths (λ e, transportf _ e _)). apply uip. apply homset_property. * apply DF_inv_mor_simpl. etrans. apply (pr2 (pr2 β ↙d' ←d')). apply (maponpaths (λ e, transportf _ e _)). apply uip. apply homset_property. Defined. Lemma DH0_DH1_disp_nat_z_iso {DH0 DH1 :disp_functor H D' D''} (β: disp_nat_z_iso (DF ◦ DH0) (DF ◦ DH1) (nat_z_iso_id (F ∙ H))) : disp_nat_z_iso DH0 DH1 (nat_z_iso_id H). Proof. use tpair. - exact (DH0_DH1_nat_trans β). - apply DH0_DH1_is_disp_nat_z_iso. Defined. Theorem unicity_univ_prop_reindexing_forward : ∏ DH' :disp_functor H D' D'', disp_nat_z_iso (disp_functor_composite DF DH') DG (nat_z_iso_id (F ∙ H)) -> disp_nat_z_iso DH' DH (nat_z_iso_id H). Proof. intros DH' µ'. apply DH0_DH1_disp_nat_z_iso. apply (transportf _ (comp_nat_z_iso_id_left (nat_z_iso_id (F ∙ H)))). apply (disp_nat_z_iso_comp µ'). apply (transportf _ nat_z_iso_inv_id). exact (disp_nat_z_iso_inv univ_prop_reindexing_forward). Defined. Local Close Scope mor_disp. Local Close Scope reindexing_forward_scope. End unicity_universal_property_reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section fibrations_and_reindexing_forward. Context {C C' C'': category} {D:disp_cat C} {F: functor C C'}. Let D' := reindexing_forward D F. Let DF := functor_reindexing_forward D F. Context (H: functor C' C'') (D'': disp_cat C'') (DG: disp_functor (F ∙ H) D D''). Let DH := functor_univ_prop_reindexing_forward H D'' DG. (* -------- DG --------> *) (* D -- DF --> D' -- DH --> D'' *) (* ↓ ↓ ↓ ↓ ↓ *) (* C -- F --> C' -- H --> C'' *) Local Open Scope reindexing_forward_scope. Local Lemma unicity_gg' {a' b' c': C'} {f' : a' --> b'} {g' : c' --> a'} {x' : D' a'} {y' : D' b'} {z' : D' c'} (ff' : x' -->[f'] y') (gg' : z' -->[g'] x') (hh' : z' -->[g' · f'] y') e (Hyp1 : ∏ g : C ⟦ ↙z', ↙x' ⟧, (# F g = double_transport (!¤z') (!¤x') g') × (g · ↙ff' = ↙hh') -> ↙gg' = g) (Hyp2 : ∏ (gg : ←z' -->[ ↙gg' ] ←x'), (gg ;; ←ff')%mor_disp = transportb (mor_disp ←z' ←y') e ←hh' -> ←gg' = gg) : ∏ gg'_bis : z' -->[ g'] x', (gg'_bis ;; ff')%mor_disp = hh' -> gg'_bis = gg'. Proof. intros gg'_bis p. induction gg'_bis as (g_bis, (pg_bis, gg_bis)). assert (↙gg' = g_bis) as eq_g. { apply Hyp1. split. - exact (double_transport_transpose pg_bis). - exact (maponpaths pr1 p). } destruct eq_g. assert (¤gg' = pg_bis) as eq_pg. { apply uip. apply homset_property. } destruct eq_pg. assert (←gg' = gg_bis) as eq_gg. { apply Hyp2. specialize (transportb_transpose_right (fiber_paths p)) as X. etrans. apply (transportb_transpose_right (fiber_paths X)). etrans. apply (maponpaths (λ f, f _) (transportf_const _ _)). cbn. etrans. apply pr2_transportf. cbn. unfold transportb. apply two_arg_paths. - apply uip. apply homset_property. - reflexivity. } destruct eq_gg. reflexivity. Qed. Local Lemma commute_in_C' {a' b' c': C'} {f' : a' --> b'} {g' : c' --> a'} {x' : D' a'} {y' : D' b'} {z' : D' c'} (ff' : x' -->[f'] y') (hh' : z' -->[g' · f'] y') : # F ↙hh' = double_transport (! ¤z') (! ¤x') g' · # F ↙ff'. Proof. etrans. apply (double_transport_transpose (¤hh')). apply pathsinv0. etrans. apply (maponpaths (λ f0', _ · f0') (double_transport_transpose (¤ff'))). apply double_transport_compose. Qed. Local Lemma commute_in_D' {a' b' c': C'} {f' : a' --> b'} {g' : c' --> a'} {x' : D' a'} {y' : D' b'} {z' : D' c'} (ff' : x' -->[f'] y') (hh' : z' -->[g' · f'] y') (Hyp1 : ∑ φ : C ⟦ ↙ (z'), ↙ (x') ⟧, (# F φ = double_transport (! ¤z') (! ¤x') g') × (φ · ↙ff' = ↙hh')) (Hyp2 : ∑ gg : ←z' -->[pr1 Hyp1] ←x', (gg ;; ←ff')%mor_disp = transportb (mor_disp ←z' ←y') (pr22 Hyp1) ←hh') (g:= pr1 Hyp1) (pg := double_transport_transpose' (pr12 Hyp1)) (gg := pr1 Hyp2) (gg' := g,, pg,,gg : z' -->[ g'] x') : (gg' ;; ff')%mor_disp = hh'. Proof. apply (total2_paths_f (pr22 Hyp1 : ↙(gg' ;; ff')%mor_disp = ↙hh')). assert (pr1 (transportf (λ f , ( double_transport ¤z' ¤y' (# F f) = g' · f' ) × ( ←z' -->[ f] ←y')) (pr22 Hyp1) (pr2 (gg' ;; ff')%mor_disp)) = ¤ hh'). { apply uip. apply homset_property. } apply (total2_paths_f X). etrans. apply (maponpaths (λ f, f _) (transportf_const _ _)). cbn. etrans. apply pr2_transportf. cbn. exact (transportf_transpose_left (pr2 Hyp2)). Qed. Lemma is_cartesian_reindexing_forward_of_cleaving {a' b' : C'} {f' : a' --> b'} {x' : D' a'} {y' : D' b'} (ff' : x' -->[f'] y') (st_car : is_cartesian_sfib F (↙ff')) (car : is_cartesian (←ff')) : is_cartesian ff'. Proof. intros c' g' z' hh'. (* introduction of variables *) set (Hyp1 := st_car (↙z') (↙hh') (double_transport (!¤z') (!¤x') g') (commute_in_C' ff' hh')). set (Hyp2 := car (↙z') (pr11 Hyp1) (←z') (transportb (mor_disp _ _) (pr221 Hyp1) (←hh'))). set (g:= pr11 Hyp1). set (pg := double_transport_transpose' (pr121 Hyp1)). set (gg := pr11 Hyp2). (* introduction of gg' *) set (gg' := (g,, pg,, gg) : z' -->[ g'] x'). (* proof that gg' is unique *) apply (unique_exists gg' (commute_in_D' ff' hh' (pr1 Hyp1) (pr1 Hyp2))). intro gg'_bis. - apply homsets_disp. - exact (unicity_gg' ff' gg' hh' (pr221 Hyp1) (λ g0, uniqueExists (b:= g0) Hyp1 (pr21 Hyp1)) (λ gg0, uniqueExists (b:= gg0) Hyp2 (pr21 Hyp2))). Defined. Theorem is_cleaving_reindexing_forward_of_cleaving (cl:cleaving D) (st: street_fib F) (univ : is_univalent C') : cleaving D'. Proof. intros b' a' f' y'. (* introduction of variables *) set (st_fib := st ↙y' a' (transportb _ ¤y' f')). set (a := pr1 st_fib). set (f := pr112 st_fib : C ⟦ a, ↙y' ⟧). set (px := isotoid C' univ (pr212 st_fib) : F a = a'). set (cl_fib := cl ↙y' a f ←y'). set (x := pr1 cl_fib). set (ff := pr12 cl_fib : x -->[f] ←y'). assert (double_transport px ¤y' (# F f) = f') as pf. { unfold double_transport. apply transportf_transpose_left. etrans. apply transportf_isotoid. apply z_iso_inv_on_right. exact (pr122 st_fib). } set (x' := (a,, px,, x) : D' a'). set (ff' := (f,, pf,, ff) : x' -->[f'] y'). (*cartesian lift*) exists x'. exists ff'. (*is cartesian *) apply (is_cartesian_reindexing_forward_of_cleaving ff' (pr222 st_fib) cl_fib). Defined. Local Close Scope reindexing_forward_scope. End fibrations_and_reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section univalence_and_reindexing_forward. Context {C C' C'': category} {D:disp_cat C} {F: functor C C'}. Let D' := reindexing_forward D F. (* D ---------> D'*) (* ↓ ↓ ↓ *) (* C --- F ---> C'*) Local Notation "X ⁻¹" := (inv_from_z_iso X) (at level 0). Local Notation "X ⁽⁻¹⁾" := (inv_mor_disp_from_z_iso X) (at level 0). Local Open Scope reindexing_forward_scope. (*Type equivalent to eqality in D' *) Local Definition Split_eq {c' : C'} (x' y' : D' c') := ∑ (e0:↙x' = ↙y'), (transportf (λ c, F c = c') e0 ¤x'= ¤y' × transportf D e0 ←x' = ←y'). (*Type equivalent to the z_iso_disp in D' *) Local Definition Split_z_iso {c' : C'} (x' y' : D' c') := ∑ (i0 : z_iso ↙x' ↙y'), (double_transport ¤x' ¤y' (# F i0) = identity c' × z_iso_disp i0 ←x' ←y'). Local Close Scope reindexing_forward_scope. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section weq_Equality_to_Split_eq. Local Definition reindexing_forward_ob_eq_to_Split_eq {c' : C'} {x' y' : D' c'} (e : x' = y') : Split_eq x' y'. Proof. exists (maponpaths pr1 e). split. - etrans. exact (! functtransportf pr1 _ e _). exact (transport_section (λ z', pr12 z') e). - etrans. exact (! functtransportf pr1 _ e _). exact (transport_section (λ z', pr22 z') e). Defined. Local Definition Split_eq_to_reindexing_forward_ob_eq {c' : C'} {x' y' : D' c'} (e' : Split_eq x' y') : x' = y' := reindexing_forward_ob_eq D F (pr1 e') (pr12 e') (pr22 e'). Local Lemma weq_reindexing_forward_ob_eq_Split_eq_opaque {c' : C'} {x' y' : D' c'} : (∏ (e : x' = y'), Split_eq_to_reindexing_forward_ob_eq (reindexing_forward_ob_eq_to_Split_eq e) = e) × (∏ (e' : Split_eq x' y'), reindexing_forward_ob_eq_to_Split_eq (Split_eq_to_reindexing_forward_ob_eq e') = e'). Proof. split. - intro e. destruct e. reflexivity. - intro e'. induction e' as (e0, (e1, e2)). induction x' as (a, (px, x)). induction y' as (b, (py, y)). cbn in e0. destruct e0. cbn in *. destruct e1, e2. reflexivity. Qed. Lemma weq_reindexing_forward_ob_eq_Split_eq {c' : C'} {x' y' : D' c'} : weq (x' = y') (Split_eq x' y'). Proof. apply (make_weq reindexing_forward_ob_eq_to_Split_eq). apply (isweq_iso _ Split_eq_to_reindexing_forward_ob_eq). - exact (pr1 weq_reindexing_forward_ob_eq_Split_eq_opaque). - exact (pr2 weq_reindexing_forward_ob_eq_Split_eq_opaque). Defined. End weq_Equality_to_Split_eq. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section weq_Split_z_iso_to_z_iso. Context {c' : C'}. Local Notation "x' -->[] y'" := (mor_disp x' y' (identity_z_iso c')) (at level 0). Local Open Scope reindexing_forward_scope. Local Lemma double_transport_z_iso_to_z_iso_inv {a b c d: C'} (i : z_iso a b) (i' : z_iso c d) {e1 : a = c} {e2 : b = d} : double_transport e1 e2 (pr1 i) = pr1 i' -> double_transport e2 e1 ( i⁻¹) = i'⁻¹. Proof. destruct e1, e2. intro H. apply z_iso_eq in H. apply (maponpaths inv_from_z_iso H). Qed. Local Lemma disp_inverse_iso_f_from_iso_ff' {x' y' : D' c'} {i0 : z_iso ↙x' ↙y'} {e : double_transport ¤x' ¤y' (# F i0) = identity c'} {i2 : z_iso_disp i0 ←x' ←y'} : is_disp_inverse (identity_z_iso c') (↙ i0,, e,, ↙ i2 : x' -->[] y') (i0⁻¹,, double_transport_z_iso_to_z_iso_inv (functor_on_z_iso F i0) (identity_z_iso c') e ,, i2⁽⁻¹⁾ : y' -->[] x'). Proof. split. - refine (reindexing_forward_paths_f_mor D F _ _ _ _). exact (pr122 i2). - refine (reindexing_forward_paths_f_mor D F _ _ _ _). exact (pr222 i2). Qed. Local Definition Split_z_iso_to_reindexing_forward_ob_z_iso {x' y' : D' c'} (i : Split_z_iso x' y') : z_iso_disp (identity_z_iso c') x' y'. Proof. exists ( pr11 i,, pr12 i ,, pr122 i : x' -->[] y'). exists ((pr1 i)⁻¹,, double_transport_z_iso_to_z_iso_inv (functor_on_z_iso F (pr1 i)) (identity_z_iso c') (pr12 i),, (pr22 i)⁽⁻¹⁾ : y' -->[] x'). exact disp_inverse_iso_f_from_iso_ff'. Defined. Local Lemma is_inverse_iso_f_from_iso_ff' {x' y' : D' c'} {iso_ff' : z_iso_disp (identity_z_iso c') x' y'} : is_inverse_in_precat (pr11 iso_ff') (pr112 iso_ff'). Proof. split. - etrans. apply (maponpaths pr1 (pr222 iso_ff')). etrans. apply (! maponpaths pr1 (id_left_disp (id_disp x'))). exact (id_left _). - etrans. apply (maponpaths pr1 (pr122 iso_ff')). etrans. apply (! maponpaths pr1 (id_left_disp (id_disp y'))). exact (id_left _). Qed. Local Lemma iso_f_from_iso_ff' {x' y' : D' c'} (iso_ff' : z_iso_disp (identity_z_iso c') x' y') : z_iso ↙x' ↙y'. Proof. exists (pr11 iso_ff'). exists (pr112 iso_ff'). exact is_inverse_iso_f_from_iso_ff'. Defined. Local Lemma pr22_composition {x' y' : D' c'} {f' g' : c' --> c'} (ff' : x' -->[f'] y') (gg' : y' -->[g'] x') (e : f' · g' = identity c') e' : (ff' ;; gg')%mor_disp = transportb (mor_disp x' x') e (id_disp x') -> (←ff' ;; ←gg')%mor_disp = transportb (mor_disp ←x' ←x') e' ←(id_disp x'). Proof. intro H0. specialize (fiber_paths (fiber_paths H0)) as H. cbn in H. rewrite transportf_const in H. rewrite pr2_transportf in H. unfold base_paths, transportb in H. rewrite pr22_transportf_mor_disp_reindexing_forward in H. apply transportb_transpose_right in H. etrans. exact H. etrans. apply transport_b_b. apply maponpaths_2. apply uip. apply homset_property. Qed. Local Lemma is_disp_inverse_iso_ff_from_iso_ff' {x' y' : D' c'} {iso_ff' : z_iso_disp (identity_z_iso c') x' y'} : is_disp_inverse (iso_f_from_iso_ff' iso_ff') (pr221 iso_ff') (pr221 (pr2 iso_ff')). Proof. split. - exact (pr22_composition _ _ _ _ (pr122 iso_ff')). - exact (pr22_composition _ _ _ _ (pr222 iso_ff')). Qed. Local Lemma iso_ff_from_iso_ff' {x' y' : D' c'} (iso_ff' : z_iso_disp (identity_z_iso c') x' y') : z_iso_disp (iso_f_from_iso_ff' iso_ff') ←x' ←y'. Proof. exists (pr22 (pr1 iso_ff')). exists (pr22 (pr12 iso_ff')). exact is_disp_inverse_iso_ff_from_iso_ff'. Defined. Local Definition reindexing_forward_ob_z_iso_to_Split_z_iso {x' y' : D' c'} : z_iso_disp (identity_z_iso c') x' y' -> Split_z_iso x' y'. Proof. intro iso_ff'. exists (iso_f_from_iso_ff' iso_ff'). split. - exact (pr12 (pr1 iso_ff')). - exact (iso_ff_from_iso_ff' iso_ff'). Defined. Local Lemma weq_reindexing_forward_Split_z_iso_ob_z_iso_opaque {x' y' : D' c'} : (∏ (i' : Split_z_iso x' y'), reindexing_forward_ob_z_iso_to_Split_z_iso (Split_z_iso_to_reindexing_forward_ob_z_iso i') = i') × (∏ (i : z_iso_disp (identity_z_iso c') x' y'), Split_z_iso_to_reindexing_forward_ob_z_iso (reindexing_forward_ob_z_iso_to_Split_z_iso i) = i). Proof. split. - intro i'. use total2_paths_f. * apply z_iso_eq. reflexivity. * etrans. apply (transportf_dirprod (z_iso ↙x' ↙y') (λ i1, double_transport ¤ x' ¤ y' (# F i1) = identity c') (λ i1, z_iso_disp i1 ← x' ← y')). apply dirprod_paths. + apply uip. apply homset_property. + apply eq_z_iso_disp. etrans. apply transportf_z_iso_disp. apply pathsinv0. etrans. apply (! idpath_transportf _ (pr122 i')). apply transportf_paths. apply uip. apply homset_property. - intro i. apply eq_z_iso_disp. reflexivity. Qed. Lemma weq_reindexing_forward_Split_z_iso_ob_z_iso {x' y' : D' c'} : weq (Split_z_iso x' y') (z_iso_disp (identity_z_iso c') x' y'). Proof. apply (make_weq Split_z_iso_to_reindexing_forward_ob_z_iso). apply (isweq_iso _ reindexing_forward_ob_z_iso_to_Split_z_iso). - exact (pr1 weq_reindexing_forward_Split_z_iso_ob_z_iso_opaque). - exact (pr2 weq_reindexing_forward_Split_z_iso_ob_z_iso_opaque). Defined. Local Close Scope reindexing_forward_scope. End weq_Split_z_iso_to_z_iso. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Section weq_Split_eq_to_Split_z_iso. Context (uC : is_univalent C) (uC' : is_univalent C') (uD : is_univalent_disp D). Local Lemma transportf_path_C_paths {a b : C} {c' : C'} (p : F a = c') (q : F b = c') (i :z_iso a b) : (! p @ (isotoid C' uC' (functor_on_z_iso F i))) @ q = idpath c' -> transportf (λ c, F c = c') (isotoid C uC i) p = q. Proof. intro H. etrans. apply (functtransportf F (λ x, x = c') _ p). etrans. apply (transportf_id2 (maponpaths F _) p). etrans. apply (maponpaths (λ e0, ! e0 @ p) (maponpaths_isotoid _ _ _ _ uC' _ _ _)). apply pathsinv0. apply path_inverse_from_right. etrans. apply (maponpaths (λ e0 , e0 @ q) (! path_comp_inv_inv _ _)). etrans. apply (maponpaths (λ e0, (_ @ e0) @ _) (pathsinv0inv0 _)). apply H. Qed. Local Lemma pr12_Split_eq_to_pr12_Split_z_iso {a b : C} {c' : C'} (px : F a = c') (py : F b = c') (i0: z_iso a b) : double_transport px py (# F i0) = identity c' -> transportf (λ c, F c = c') (isotoid C uC i0) px = py. Proof. intro H. apply transportf_path_C_paths. apply (idtoiso_inj C' uC'). apply z_iso_eq. simpl. etrans. apply pr1_idtoiso_concat. etrans. apply (maponpaths (λ X, pr1 X · _) (idtoiso_concat _ _ _ _ _ _)). simpl. etrans. apply (maponpaths (λ X, _ · pr1 X · _) (idtoiso_isotoid _ _ _ _ _)). apply pathsinv0. etrans. apply (! H). etrans. apply double_transport_idtoiso. apply (maponpaths ( λ var, var · (idtoiso py))). apply maponpaths_2. exact (maponpaths pr1 (! idtoiso_inv _ _ _ _)). Qed. Local Definition Split_z_iso_to_Split_eq {c' : C'} {x' y' : D' c'} : Split_z_iso x' y' -> Split_eq x' y'. Proof. intro i'. exists (isotoid C uC (pr1 i')). split. - apply pr12_Split_eq_to_pr12_Split_z_iso. exact (pr12 i'). - apply (isotoid_disp uD). exact (transportf (λ i, z_iso_disp i _ _) (! idtoiso_isotoid _ _ _ _ _) (pr22 i')). Defined. Local Lemma pr12_Split_z_iso_to_pr12_Split_eq {a b : C} {c' : C'} (px : F a = c') (py : F b = c') (e0: a = b) : transportf (λ c, F c = c') (e0) px = py -> double_transport px py (# F (idtoiso e0)) = identity c'. Proof. intro H. destruct e0, px, H. exact (functor_id F a). Qed. Local Definition Split_eq_to_Split_z_iso {c' : C'} {x' y' : D' c'} : Split_eq x' y' -> Split_z_iso x' y'. Proof. intro e'. exists (idtoiso (pr1 e')). split. - apply pr12_Split_z_iso_to_pr12_Split_eq. exact (pr12 e'). - apply idtoiso_disp. exact (pr22 e'). Defined. Local Open Scope reindexing_forward_scope. Lemma isotoid_disp_transportf_idtoiso_disp {c c' : C} {e0 e1: c = c'} {d : D c} {d' : D c'} (e : transportf D e0 d = d') e2 e3 : isotoid_disp uD e1 (transportf (λ i0 : z_iso c c', z_iso_disp i0 d d') e2 (idtoiso_disp e0 e)) = transportf (λ en : c =c', transportf D en d = d') e3 e. Proof. destruct e3, e0, e. assert (e2 = idpath (identity_z_iso c)) as E. { apply uip. apply isaset_z_iso. } rewrite E. etrans. apply (isotoid_idtoiso_disp uD (idpath c) (idpath d)). reflexivity. Qed. Local Lemma weq_Split_eq_Split_z_iso_opaque {c' : C'} {x' y' : D' c'} : (∏ (e' : Split_eq x' y'), Split_z_iso_to_Split_eq (Split_eq_to_Split_z_iso e') = e') × (∏ (i' : Split_z_iso x' y'), Split_eq_to_Split_z_iso (Split_z_iso_to_Split_eq i') = i'). Proof. split. - intro e'. apply pathsinv0. use total2_paths_f. * exact (! isotoid_idtoiso C uC ↙x' ↙y' (pr1 e')). * etrans. apply (transportf_dirprod (↙x' = ↙y') (λ e0, transportf (λ c : C, F c = c') e0 ¤ x' = ¤ y') (λ e0, transportf D e0 ← x' = ← y')). apply dirprod_paths. + apply uip. exact (univalent_category_has_groupoid_ob (C',, uC') (F ↙y') c'). + exact (! isotoid_disp_transportf_idtoiso_disp _ _ _). - intro i'. apply pathsinv0. use total2_paths_f. * exact (! idtoiso_isotoid C uC ↙x' ↙y' (pr1 i')). * etrans. apply (transportf_dirprod (z_iso ↙x' ↙y') (λ i0, double_transport ¤ x' ¤ y' (# F i0) = identity c') (λ i0, z_iso_disp i0 ← x' ← y')). apply dirprod_paths. + apply uip. apply homset_property. + exact (! idtoiso_isotoid_disp _ _ _). Qed. Lemma weq_Split_eq_Split_z_iso {c' : C'} {x' y' : D' c'} : weq (Split_eq x' y') (Split_z_iso x' y'). Proof. apply (make_weq Split_eq_to_Split_z_iso). apply (isweq_iso _ Split_z_iso_to_Split_eq). - exact (pr1 weq_Split_eq_Split_z_iso_opaque). - exact (pr2 weq_Split_eq_Split_z_iso_opaque). Defined. Local Close Scope reindexing_forward_scope. End weq_Split_eq_to_Split_z_iso. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) Local Open Scope reindexing_forward_scope. Theorem is_univalent_reindexing_forward_of_univalent (uD : is_univalent_disp D) (uC' : is_univalent C') (uC : is_univalent C) : is_univalent_disp D'. Proof. apply is_univalent_disp_from_fibers. intros c' x' y'. use weqhomot. - apply (weqcomp weq_reindexing_forward_ob_eq_Split_eq). apply (weqcomp (weq_Split_eq_Split_z_iso uC uC' uD)). exact weq_reindexing_forward_Split_z_iso_ob_z_iso. - intro e. destruct e. apply eq_z_iso_disp. cbn. apply maponpaths. apply two_arg_paths. * apply uip. apply homset_property. * reflexivity. Defined. End univalence_and_reindexing_forward. (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*) (* End of file. *) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/SIP.v000066400000000000000000000042541451125700300232040ustar00rootroot00000000000000 (** * The Structure Identity Principle A short proof of the SIP (HoTT book, chapter 9.8) *) Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope mor_disp_scope. (** * The Structure Identity Principle *) Section SIP. (** ** The data and properties according to HoTT book, chapter 9.8 *) Variable C : category. Variable univC : is_univalent C. Variable P : ob C -> UU. Variable Pisset : ∏ x, isaset (P x). Variable H : ∏ (x y : C), P x → P y → C⟦x,y⟧ → UU. Arguments H {_ _} _ _ _ . Variable Hisprop : ∏ x y a b (f : C⟦x,y⟧), isaprop (H a b f). Variable Hid : ∏ (x : C) (a : P x), H a a (identity _ ). Variable Hcomp : ∏ (x y z : C) a b c (f : C⟦x,y⟧) (g : C⟦y,z⟧), H a b f → H b c g → H a c (f · g). Variable Hstandard : ∏ (x : C) (a a' : P x), H a a' (identity _ ) → H a' a (identity _ ) → a = a'. (** ** A displayed precategory from the data *) Definition disp_cat_from_SIP_data : disp_cat C := disp_struct C P (@H) Hisprop Hid Hcomp. (** ** Displayed category from SIP data is univalent *) Lemma is_univalent_disp_from_SIP_data : is_univalent_disp disp_cat_from_SIP_data. Proof. apply is_univalent_disp_from_fibers. intros x a b. apply isweqimplimpl. - intro i. apply Hstandard. * apply i. * apply (inv_mor_disp_from_z_iso i). - apply Pisset. - apply isofhleveltotal2. + apply Hisprop. + intro. apply (@isaprop_is_z_iso_disp _ disp_cat_from_SIP_data). Defined. (** ** The conclusion of SIP: total category is univalent *) Definition SIP : is_univalent (total_category disp_cat_from_SIP_data). Proof. apply is_univalent_total_category. - apply univC. - apply is_univalent_disp_from_SIP_data. Defined. End SIP. (** TODO: add some examples *) UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/StreetFibration.v000066400000000000000000000600071451125700300256530ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope cat. (** The definition of a Street fibration of categories *) Section StreetFibration. Context {E B : category} (F : E ⟶ B). Definition is_cartesian_sfib {e₁ e₂ : E} (f : e₁--> e₂) : UU := ∏ (z : E) (g : z --> e₂) (h : F z --> F e₁) (p : #F g = h · #F f), ∃! (φ : z --> e₁), #F φ = h × φ · f = g. Definition isaprop_is_cartesian_sfib {e₁ e₂ : E} (f : e₁--> e₂) : isaprop (is_cartesian_sfib f). Proof. do 4 (apply impred ; intro). apply isapropiscontr. Qed. Definition cartesian_factorization_sfib {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_cartesian_sfib f) {z : E} (g : z --> e₂) (h : F z --> F e₁) (p : #F g = h · #F f) : z --> e₁ := pr11 (Hf z g h p). Definition cartesian_factorization_sfib_over {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_cartesian_sfib f) {z : E} (g : z --> e₂) (h : F z --> F e₁) (p : #F g = h · #F f) : #F (cartesian_factorization_sfib Hf g h p) = h := pr121 (Hf z g h p). Definition cartesian_factorization_sfib_commute {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_cartesian_sfib f) {z : E} (g : z --> e₂) (h : F z --> F e₁) (p : #F g = h · #F f) : cartesian_factorization_sfib Hf g h p · f = g := pr221 (Hf z g h p). Definition cartesian_factorization_sfib_unique {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_cartesian_sfib f) {z : E} (g : z --> e₂) (h : F z --> F e₁) {p : #F g = h · #F f} (φ₁ φ₂ : z --> e₁) (p₁ : #F φ₁ = h) (p₂ : #F φ₂ = h) (q₁ : φ₁ · f = g) (q₂ : φ₂ · f = g) : φ₁ = φ₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hf z g h p)) (φ₁ ,, p₁ ,, q₁) (φ₂ ,, p₂ ,, q₂))). Defined. Definition street_fib : UU := ∏ (e : E) (b : B) (f : b --> F e), ∑ (bb : E) (ff_i : bb --> e × z_iso (F bb) b), # F (pr1 ff_i) = pr2 ff_i · f × is_cartesian_sfib (pr1 ff_i). End StreetFibration. (** *) Definition lift_unique_sfib_map {E B : category} (F : E ⟶ B) {e : E} {b : B} (f : b --> F e) (bb₁ bb₂ : E) (ff₁ : bb₁ --> e) (β₁ : z_iso (F bb₁) b) (ff₂ : bb₂ --> e) (β₂ : z_iso (F bb₂) b) (over₁ : # F (ff₁) = β₁ · f) (over₂ : # F (ff₂) = β₂ · f) (cart₁ : is_cartesian_sfib F ff₁) (cart₂ : is_cartesian_sfib F ff₂) : bb₁ --> bb₂. Proof. refine (cartesian_factorization_sfib F cart₂ ff₁ (β₁ · inv_from_z_iso β₂) _). abstract (rewrite over₁, over₂ ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite z_iso_after_z_iso_inv ; rewrite id_left ; apply idpath). Defined. Section UniqueLifts. Context {E B : category} (F : E ⟶ B) {e : E} {b : B} (f : b --> F e) (bb₁ bb₂ : E) (ff₁ : bb₁ --> e) (β₁ : z_iso (F bb₁) b) (ff₂ : bb₂ --> e) (β₂ : z_iso (F bb₂) b) (over₁ : # F (ff₁) = β₁ · f) (over₂ : # F (ff₂) = β₂ · f) (cart₁ : is_cartesian_sfib F ff₁) (cart₂ : is_cartesian_sfib F ff₂). Let ζ : bb₁ --> bb₂ := lift_unique_sfib_map F f bb₁ bb₂ ff₁ β₁ ff₂ β₂ over₁ over₂ cart₁ cart₂. Let ζinv : bb₂ --> bb₁ := lift_unique_sfib_map F f bb₂ bb₁ ff₂ β₂ ff₁ β₁ over₂ over₁ cart₂ cart₁. Local Lemma lift_unique_sfib_inv₁ : ζ · ζinv = identity bb₁. Proof. unfold ζ, ζinv, lift_unique_sfib_map. use (cartesian_factorization_sfib_unique F cart₁ ff₁ (identity _)). - rewrite id_left. apply idpath. - rewrite functor_comp. rewrite !cartesian_factorization_sfib_over. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite z_iso_after_z_iso_inv. rewrite id_left. rewrite z_iso_inv_after_z_iso. apply idpath. - apply functor_id. - rewrite !assoc'. rewrite !cartesian_factorization_sfib_commute. apply idpath. - apply id_left. Qed. Local Lemma lift_unique_sfib_inv₂ : ζinv · ζ = identity bb₂. Proof. unfold ζ, ζinv, lift_unique_sfib_map. use (cartesian_factorization_sfib_unique F cart₂ ff₂ (identity _)). - rewrite id_left. apply idpath. - rewrite functor_comp. rewrite !cartesian_factorization_sfib_over. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite z_iso_after_z_iso_inv. rewrite id_left. rewrite z_iso_inv_after_z_iso. apply idpath. - apply functor_id. - rewrite !assoc'. rewrite !cartesian_factorization_sfib_commute. apply idpath. - apply id_left. Qed. Definition lift_unique_sfib : z_iso bb₁ bb₂. Proof. exists ζ. exists ζinv. split. - exact lift_unique_sfib_inv₁. - exact lift_unique_sfib_inv₂. Defined. End UniqueLifts. (** The projection of a fibration is a Street fibration *) Section CleavingToStreetFib. Context {B : category} {D : disp_cat B}. Let E : category := total_category D. Let P : E ⟶ B := pr1_category D. Local Definition is_cartesian_to_unique_sfib {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_cartesian (pr2 f)) {z : E} (g : z --> e₂) (h : P z --> P e₁) (p : # P g = h · # P f) : isaprop (∑ φ : E ⟦ z, e₁ ⟧, # P φ = h × φ · f = g). Proof. pose (lift := H (pr1 z) h (pr2 z) (transportf (λ z, _ -->[ z ] _) p (pr2 g))). use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use (total2_paths_f (pr12 φ₁ @ !(pr12 φ₂))). pose (φφ₁ := transportf (λ z, _ -->[ z ] _) (pr12 φ₁) (pr21 φ₁)). pose (φφ₂ := transportf (λ z, _ -->[ z ] _) (pr12 φ₂) (pr21 φ₂)). simpl in φφ₁, φφ₂. assert ((φφ₁ ;; pr2 f)%mor_disp = transportf (λ w, pr2 z -->[ w ] pr2 e₂) p (pr2 g)) as H₁. { unfold φφ₁. rewrite mor_disp_transportf_postwhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (pr22 φ₁))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. } assert ((φφ₂ ;; pr2 f)%mor_disp = transportf (λ w, pr2 z -->[ w ] pr2 e₂) p (pr2 g)) as H₂. { unfold φφ₂. rewrite mor_disp_transportf_postwhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (pr22 φ₂))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. } pose (proofirrelevance _ (isapropifcontr lift)) as q. assert (r := maponpaths pr1 (q (φφ₁ ,, H₁) (φφ₂ ,, H₂))). cbn in r. unfold φφ₁, φφ₂ in r. simple refine (_ @ maponpaths (transportb _ (pr12 φ₂)) r @ _) ; unfold transportb ; rewrite transport_f_f. + apply maponpaths_2. apply homset_property. + apply transportf_set. apply homset_property. Qed. Definition is_cartesian_to_is_cartesian_sfib {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_cartesian (pr2 f)) : is_cartesian_sfib P f. Proof. intros z g h p. pose (lift := H (pr1 z) h (pr2 z) (transportf (λ z, _ -->[ z ] _) p (pr2 g))). use iscontraprop1. - exact (is_cartesian_to_unique_sfib f H g h p). - simple refine ((h ,, pr11 lift) ,, (idpath _ ,, _)) ; cbn. abstract (pose (pr21 lift) as q ; cbn in q ; use total2_paths_f ; [ exact (!p) | cbn ; rewrite q ; rewrite transport_f_f ; apply transportf_set ; apply homset_property ]). Defined. Local Definition is_cartesian_sfib_to_unique_cartesian {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_cartesian_sfib P f) {z : B} (g : z --> pr1 e₁) (zz : D z) (gf : zz -->[ g · pr1 f] pr2 e₂) : isaprop (∑ gg, (gg ;; pr2 f)%mor_disp = gf). Proof. pose (lift := H (z ,, zz) (g · pr1 f ,, gf) g (idpath _)). use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply D. } pose (φφ₁ := (g ,, pr1 φ₁) : E ⟦ z,, zz, e₁ ⟧). assert (# P φφ₁ = g × φφ₁ · f = g · pr1 f,, gf) as H₁. { split ; cbn. - apply idpath. - apply maponpaths. exact (pr2 φ₁). } pose (φφ₂ := (g ,, pr1 φ₂) : E ⟦ z,, zz, e₁ ⟧). assert (# P φφ₂ = g × φφ₂ · f = g · pr1 f,, gf) as H₂. { split ; cbn. - apply idpath. - apply maponpaths. exact (pr2 φ₂). } assert (q := maponpaths (λ z, pr1 z) (proofirrelevance _ (isapropifcontr lift) (φφ₁ ,, H₁) (φφ₂ ,, H₂))). cbn in q. refine (!_ @ fiber_paths q). apply transportf_set. apply homset_property. Qed. Definition is_cartesian_sfib_to_is_cartesian {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_cartesian_sfib P f) : is_cartesian (pr2 f). Proof. intros z g zz gf. pose (lift := H (z ,, zz) (g · pr1 f ,, gf) g (idpath _)). use iscontraprop1. - apply is_cartesian_sfib_to_unique_cartesian. exact H. - simple refine (_ ,, _). + exact (transportf (λ z, _ -->[ z ] _) (pr121 lift) (pr211 lift)). + abstract (simpl ; pose (transportb_transpose_right (fiber_paths (pr221 lift))) as p ; rewrite mor_disp_transportf_postwhisker ; cbn in p ; refine (maponpaths _ p @ _) ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition fibration_is_street_fib (HD : cleaving D) : street_fib (pr1_category D). Proof. intros e b f. pose (HD (pr1 e) b f (pr2 e)) as c. refine ((b ,, pr1 c) ,, ((f ,, pr12 c) ,, identity_z_iso b) ,, _). simpl. split. - apply (!(id_left _)). - apply is_cartesian_to_is_cartesian_sfib. exact (pr22 c). Defined. End CleavingToStreetFib. (** Morphisms between Street fibrations *) Definition preserves_cartesian {B₁ B₂ E₁ E₂ : category} (P₁ : E₁ ⟶ B₁) (P₂ : E₂ ⟶ B₂) (FE : E₁ ⟶ E₂) : UU := ∏ (e₁ e₂ : E₁) (f : e₁ --> e₂), is_cartesian_sfib P₁ f → is_cartesian_sfib P₂ (#FE f). Definition identity_preserves_cartesian {B E : category} (P : E ⟶ B) : preserves_cartesian P P (functor_identity E). Proof. intros ? ? ? H. exact H. Qed. Definition composition_preserves_cartesian {B₁ B₂ B₃ E₁ E₂ E₃ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} {P₃ : E₃ ⟶ B₃} {FE₁ : E₁ ⟶ E₂} {FE₂ : E₂ ⟶ E₃} (HFE₁ : preserves_cartesian P₁ P₂ FE₁) (HFE₂ : preserves_cartesian P₂ P₃ FE₂) : preserves_cartesian P₁ P₃ (FE₁ ∙ FE₂). Proof. intros ? ? ? H. apply HFE₂. apply HFE₁. exact H. Qed. Definition isaprop_preserves_cartesian {B₁ B₂ E₁ E₂ : category} (P₁ : E₁ ⟶ B₁) (P₂ : E₂ ⟶ B₂) (FE : E₁ ⟶ E₂) : isaprop (preserves_cartesian P₁ P₂ FE). Proof. do 4 (use impred ; intro). apply isaprop_is_cartesian_sfib. Qed. Definition mor_of_street_fib {B₁ B₂ E₁ E₂ : category} (P₁ : E₁ ⟶ B₁) (P₂ : E₂ ⟶ B₂) : UU := ∑ (FB : B₁ ⟶ B₂) (FE : E₁ ⟶ E₂), preserves_cartesian P₁ P₂ FE × nat_z_iso (P₁ ∙ FB) (FE ∙ P₂). Definition mor_of_street_fib_base {B₁ B₂ E₁ E₂ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} (F : mor_of_street_fib P₁ P₂) : B₁ ⟶ B₂ := pr1 F. Definition mor_of_street_fib_total {B₁ B₂ E₁ E₂ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} (F : mor_of_street_fib P₁ P₂) : E₁ ⟶ E₂ := pr12 F. Definition mor_of_street_fib_preserves_cartesian {B₁ B₂ E₁ E₂ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} (F : mor_of_street_fib P₁ P₂) : preserves_cartesian P₁ P₂ (mor_of_street_fib_total F) := pr122 F. Definition mor_of_street_fib_preserves_nat_z_iso {B₁ B₂ E₁ E₂ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} (F : mor_of_street_fib P₁ P₂) : nat_z_iso (P₁ ∙ mor_of_street_fib_base F) (mor_of_street_fib_total F ∙ P₂) := pr222 F. Definition id_mor_of_street_fib_nat_trans {B E : category} (P : E ⟶ B) : P ∙ functor_identity B ⟹ functor_identity E ∙ P. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros ? ? ? ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition id_mor_of_street_fib_nat_z_iso {B E : category} (P : E ⟶ B) : nat_z_iso (P ∙ functor_identity B) (functor_identity E ∙ P). Proof. use make_nat_z_iso. - exact (id_mor_of_street_fib_nat_trans P). - intro x. cbn. apply identity_is_z_iso. Defined. Definition id_mor_of_street_fib {B E : category} (P : E ⟶ B) : mor_of_street_fib P P := functor_identity _ ,, functor_identity _ ,, identity_preserves_cartesian _ ,, id_mor_of_street_fib_nat_z_iso P. Definition comp_mor_of_street_fib_nat_trans {B₁ B₂ B₃ E₁ E₂ E₃ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} {P₃ : E₃ ⟶ B₃} (F₁ : mor_of_street_fib P₁ P₂) (F₂ : mor_of_street_fib P₂ P₃) : P₁ ∙ (mor_of_street_fib_base F₁ ∙ mor_of_street_fib_base F₂) ⟹ (mor_of_street_fib_total F₁ ∙ mor_of_street_fib_total F₂) ∙ P₃. Proof. use make_nat_trans. - exact (λ x, #(mor_of_street_fib_base F₂) (mor_of_street_fib_preserves_nat_z_iso F₁ x) · mor_of_street_fib_preserves_nat_z_iso F₂ _). - abstract (intros x y f ; cbn ; rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; exact (nat_trans_ax (mor_of_street_fib_preserves_nat_z_iso F₁) _ _ f) | ] ; rewrite functor_comp ; rewrite !assoc' ; apply maponpaths ; apply (nat_trans_ax (mor_of_street_fib_preserves_nat_z_iso F₂))). Defined. Definition comp_mor_of_street_fib_nat_z_iso {B₁ B₂ B₃ E₁ E₂ E₃ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} {P₃ : E₃ ⟶ B₃} (F₁ : mor_of_street_fib P₁ P₂) (F₂ : mor_of_street_fib P₂ P₃) : nat_z_iso (P₁ ∙ (mor_of_street_fib_base F₁ ∙ mor_of_street_fib_base F₂)) ((mor_of_street_fib_total F₁ ∙ mor_of_street_fib_total F₂) ∙ P₃). Proof. use make_nat_z_iso. - exact (comp_mor_of_street_fib_nat_trans F₁ F₂). - intro x. cbn. apply is_z_iso_comp_of_is_z_isos. + apply functor_on_is_z_isomorphism. apply (mor_of_street_fib_preserves_nat_z_iso F₁). + apply (mor_of_street_fib_preserves_nat_z_iso F₂). Defined. Definition comp_mor_of_street_fib {B₁ B₂ B₃ E₁ E₂ E₃ : category} {P₁ : E₁ ⟶ B₁} {P₂ : E₂ ⟶ B₂} {P₃ : E₃ ⟶ B₃} (F₁ : mor_of_street_fib P₁ P₂) (F₂ : mor_of_street_fib P₂ P₃) : mor_of_street_fib P₁ P₃ := mor_of_street_fib_base F₁ ∙ mor_of_street_fib_base F₂ ,, mor_of_street_fib_total F₁ ∙ mor_of_street_fib_total F₂ ,, composition_preserves_cartesian (mor_of_street_fib_preserves_cartesian F₁) (mor_of_street_fib_preserves_cartesian F₂) ,, comp_mor_of_street_fib_nat_z_iso F₁ F₂. (** The type of Street fibrations is a proposition *) Definition isaprop_street_fib {B E : category} (HE : is_univalent E) (F : E ⟶ B) : isaprop (street_fib F). Proof. use impred ; intro e. use impred ; intro b. use impred ; intro f. use invproofirrelevance. intros φ₁ φ₂. use total2_paths_f. - apply (isotoid _ HE). exact (lift_unique_sfib F f (pr1 φ₁) (pr1 φ₂) (pr112 φ₁) (pr212 φ₁) (pr112 φ₂) (pr212 φ₂) (pr122 φ₁) (pr122 φ₂) (pr222 φ₁) (pr222 φ₂)). - use subtypePath. { intro. apply isapropdirprod ; [ apply homset_property | apply isaprop_is_cartesian_sfib ]. } rewrite pr1_transportf. use dirprod_paths. + etrans. { apply (@pr1_transportf E (λ x, x --> e) (λ x _, z_iso (F x) b)). } rewrite transportf_isotoid. cbn. apply cartesian_factorization_sfib_commute. + rewrite pr2_transportf. use subtypePath. { intro. apply isaprop_is_z_isomorphism. } unfold z_iso. rewrite pr1_transportf. rewrite transportf_functor_isotoid. cbn. etrans. { apply maponpaths_2. apply cartesian_factorization_sfib_over. } rewrite !assoc'. rewrite z_iso_after_z_iso_inv. apply id_right. Qed. (** Lemmas on cartesian cells for Street fibrations *) Definition is_cartesian_sfib_eq {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ : C₁} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) (Hf₁ : is_cartesian_sfib F f₁) : is_cartesian_sfib F f₂. Proof. induction p. exact Hf₁. Defined. Definition z_iso_is_cartesian_sfib {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ : C₁} (i : x₁ --> x₂) (Hi : is_z_isomorphism i) : is_cartesian_sfib F i. Proof. pose (i_iso := make_z_iso' _ Hi). intros w g h p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; refine (!(id_right _) @ _ @ id_right _) ; rewrite <- (z_iso_inv_after_z_iso i_iso) ; cbn ; rewrite !assoc ; rewrite (pr22 φ₁), (pr22 φ₂) ; apply idpath). - simple refine (_ ,, _ ,, _). + exact (g · inv_from_z_iso i_iso). + abstract (rewrite functor_comp ; rewrite p ; rewrite !assoc' ; rewrite <- functor_comp ; etrans ; [ do 2 apply maponpaths ; exact (z_iso_inv_after_z_iso i_iso) | ] ; rewrite functor_id ; apply id_right). + abstract (cbn ; rewrite !assoc' ; refine (_ @ id_right _) ; apply maponpaths ; apply z_iso_after_z_iso_inv). Defined. Section CompositionCartesian. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ x₃ : C₁} {f : x₁ --> x₂} (Hf : is_cartesian_sfib F f) {g : x₂ --> x₃} (Hg : is_cartesian_sfib F g). Section Factorization. Context {w : C₁} {h₁ : w --> x₃} {h₂ : F w --> F x₁} (p : # F h₁ = h₂ · # F (f · g)). Definition comp_is_cartesian_sfib_factor_help : w --> x₂. Proof. use (cartesian_factorization_sfib _ Hg h₁ (h₂ · #F f)). abstract (refine (p @ _) ; rewrite functor_comp ; rewrite assoc ; apply idpath). Defined. Definition comp_is_cartesian_sfib_factor : w --> x₁. Proof. use (cartesian_factorization_sfib _ Hf). - exact comp_is_cartesian_sfib_factor_help. - exact h₂. - apply cartesian_factorization_sfib_over. Defined. Definition comp_is_cartesian_sfib_factor_over : # F comp_is_cartesian_sfib_factor = h₂. Proof. apply cartesian_factorization_sfib_over. Qed. Definition comp_is_cartesian_sfib_factor_comm : comp_is_cartesian_sfib_factor · (f · g) = h₁. Proof. unfold comp_is_cartesian_sfib_factor, comp_is_cartesian_sfib_factor_help. rewrite !assoc. rewrite !cartesian_factorization_sfib_commute. apply idpath. Qed. Definition comp_is_cartesian_sfib_factor_unique : isaprop (∑ φ, # F φ = h₂ × φ · (f · g) = h₁). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use (cartesian_factorization_sfib_unique _ Hf comp_is_cartesian_sfib_factor_help h₂). - apply cartesian_factorization_sfib_over. - exact (pr12 φ₁). - exact (pr12 φ₂). - use (cartesian_factorization_sfib_unique _ Hg h₁ (h₂ · #F f)). + rewrite p. rewrite functor_comp. rewrite !assoc. apply idpath. + rewrite functor_comp. rewrite (pr12 φ₁). apply idpath. + apply cartesian_factorization_sfib_over. + rewrite assoc'. apply (pr22 φ₁). + apply cartesian_factorization_sfib_commute. - use (cartesian_factorization_sfib_unique _ Hg h₁ (h₂ · #F f)). + rewrite p. rewrite functor_comp. rewrite !assoc. apply idpath. + rewrite functor_comp. rewrite (pr12 φ₂). apply idpath. + apply cartesian_factorization_sfib_over. + rewrite assoc'. apply (pr22 φ₂). + apply cartesian_factorization_sfib_commute. Qed. End Factorization. Definition comp_is_cartesian_sfib : is_cartesian_sfib F (f · g). Proof. intros w h₁ h₂ p. use iscontraprop1. - exact (comp_is_cartesian_sfib_factor_unique p). - simple refine (_ ,, _ ,, _). + exact (comp_is_cartesian_sfib_factor p). + exact (comp_is_cartesian_sfib_factor_over p). + exact (comp_is_cartesian_sfib_factor_comm p). Defined. End CompositionCartesian. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/StreetOpFibration.v000066400000000000000000000447431451125700300261630ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Local Open Scope cat. (** The definition of a Street opfibration of categories *) Section StreetOpFibration. Context {E B : category} (F : E ⟶ B). Definition is_opcartesian_sopfib {e₁ e₂ : E} (f : e₁--> e₂) : UU := ∏ (e₃ : E) (g : e₁ --> e₃) (h : F e₂ --> F e₃) (p : #F g = #F f · h), ∃! (φ : e₂ --> e₃), #F φ = h × f · φ = g. Definition isaprop_is_opcartesian_sopfib {e₁ e₂ : E} (f : e₁--> e₂) : isaprop (is_opcartesian_sopfib f). Proof. do 4 (apply impred ; intro). apply isapropiscontr. Qed. Definition opcartesian_factorization_sopfib {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_opcartesian_sopfib f) {e₃ : E} (g : e₁ --> e₃) (h : F e₂ --> F e₃) (p : #F g = #F f · h) : e₂ --> e₃ := pr11 (Hf e₃ g h p). Definition opcartesian_factorization_sopfib_over {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_opcartesian_sopfib f) {e₃ : E} (g : e₁ --> e₃) (h : F e₂ --> F e₃) (p : #F g = #F f · h) : #F (opcartesian_factorization_sopfib Hf g h p) = h := pr121 (Hf e₃ g h p). Definition opcartesian_factorization_sopfib_commute {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_opcartesian_sopfib f) {e₃ : E} (g : e₁ --> e₃) (h : F e₂ --> F e₃) (p : #F g = #F f · h) : f · opcartesian_factorization_sopfib Hf g h p = g := pr221 (Hf e₃ g h p). Definition opcartesian_factorization_sopfib_unique {e₁ e₂ : E} {f : e₁--> e₂} (Hf : is_opcartesian_sopfib f) {e₃ : E} (g : e₁ --> e₃) (h : F e₂ --> F e₃) (p : #F g = #F f · h) (φ₁ φ₂ : e₂ --> e₃) (p₁ : #F φ₁ = h) (p₂ : #F φ₂ = h) (q₁ : f · φ₁ = g) (q₂ : f · φ₂ = g) : φ₁ = φ₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hf e₃ g h p)) (φ₁ ,, p₁ ,, q₁) (φ₂ ,, p₂ ,, q₂))). Defined. Definition street_opfib : UU := ∏ (e : E) (b : B) (f : F e --> b), ∑ (bb : E) (ff_i : e --> bb × z_iso b (F bb)), # F (pr1 ff_i) = f · pr2 ff_i × is_opcartesian_sopfib (pr1 ff_i). End StreetOpFibration. (** The projection of an opfibration is a Street opfibration *) Section OpcleavingToStreetOpFib. Context {B : category} {D : disp_cat B}. Let E : category := total_category D. Let P : E ⟶ B := pr1_category D. Local Definition is_opcartesian_to_unique_sopfib {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_opcartesian (pr2 f)) {z : E} (g : e₁ --> z) (h : P e₂ --> P z) (p : # P g = # P f · h) : isaprop (∑ φ : E ⟦ e₂, z ⟧, # P φ = h × f · φ = g). Proof. pose (lift := H (pr1 z) (pr2 z) h (transportf (λ z, _ -->[ z ] _) p (pr2 g))). use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use (total2_paths_f (pr12 φ₁ @ !(pr12 φ₂))). pose (φφ₁ := transportf (λ z, _ -->[ z ] _) (pr12 φ₁) (pr21 φ₁)). pose (φφ₂ := transportf (λ z, _ -->[ z ] _) (pr12 φ₂) (pr21 φ₂)). simpl in φφ₁, φφ₂. assert ((pr2 f ;; φφ₁)%mor_disp = transportf (λ w, pr2 e₁ -->[ w ] pr2 z) p (pr2 g)) as H₁. { unfold φφ₁. rewrite mor_disp_transportf_prewhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (pr22 φ₁))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. } assert ((pr2 f ;; φφ₂)%mor_disp = transportf (λ w, pr2 e₁ -->[ w ] pr2 z) p (pr2 g)) as H₂. { unfold φφ₂. rewrite mor_disp_transportf_prewhisker. etrans. { apply maponpaths. exact (transportb_transpose_right (fiber_paths (pr22 φ₂))). } unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. } pose (proofirrelevance _ (isapropifcontr lift)) as q. assert (r := maponpaths pr1 (q (φφ₁ ,, H₁) (φφ₂ ,, H₂))). cbn in r. unfold φφ₁, φφ₂ in r. simple refine (_ @ maponpaths (transportb _ (pr12 φ₂)) r @ _) ; unfold transportb ; rewrite transport_f_f. + apply maponpaths_2. apply homset_property. + apply transportf_set. apply homset_property. Qed. Definition is_opcartesian_to_is_opcartesian_sopfib {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_opcartesian (pr2 f)) : is_opcartesian_sopfib P f. Proof. intros z g h p. pose (lift := H (pr1 z) (pr2 z) h (transportf (λ z, _ -->[ z ] _) p (pr2 g))). use iscontraprop1. - exact (is_opcartesian_to_unique_sopfib _ H _ _ p). - simple refine ((h ,, pr11 lift) ,, (idpath _ ,, _)) ; cbn. abstract (pose (pr21 lift) as q ; cbn in q ; use total2_paths_f ; [ exact (!p) | cbn ; rewrite q ; rewrite transport_f_f ; apply transportf_set ; apply homset_property ]). Defined. Local Definition is_opcartesian_sopfib_to_unique_opcartesian {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_opcartesian_sopfib P f) {z : B} (g : pr1 e₂ --> z) (zz : D z) (gf : pr2 e₁ -->[ pr1 f · g ] zz) : isaprop (∑ gg, (pr2 f ;; gg)%mor_disp = gf). Proof. pose (lift := H (z ,, zz) (pr1 f · g ,, gf) g (idpath _)). use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply D. } pose (φφ₁ := (g ,, pr1 φ₁) : E ⟦ e₂ , z,, zz ⟧). assert (# P φφ₁ = g × f · φφ₁ = pr1 f · g ,, gf) as H₁. { split ; cbn. - apply idpath. - apply maponpaths. exact (pr2 φ₁). } pose (φφ₂ := (g ,, pr1 φ₂) : E ⟦ e₂ , z,, zz ⟧). assert (# P φφ₂ = g × f · φφ₂ = pr1 f · g ,, gf) as H₂. { split ; cbn. - apply idpath. - apply maponpaths. exact (pr2 φ₂). } assert (q := maponpaths (λ z, pr1 z) (proofirrelevance _ (isapropifcontr lift) (φφ₁ ,, H₁) (φφ₂ ,, H₂))). cbn in q. refine (!_ @ fiber_paths q). apply transportf_set. apply homset_property. Qed. Definition is_opcartesian_sopfib_to_is_opcartesian {e₁ e₂ : E} (f : e₁ --> e₂) (H : is_opcartesian_sopfib P f) : is_opcartesian (pr2 f). Proof. intros z zz g gf. pose (lift := H (z ,, zz) (pr1 f · g ,, gf) g (idpath _)). use iscontraprop1. - apply is_opcartesian_sopfib_to_unique_opcartesian. exact H. - simple refine (_ ,, _). + exact (transportf (λ z, _ -->[ z ] _) (pr121 lift) (pr211 lift)). + abstract (simpl ; pose (transportb_transpose_right (fiber_paths (pr221 lift))) as p ; rewrite mor_disp_transportf_prewhisker ; cbn in p ; refine (maponpaths _ p @ _) ; unfold transportb ; rewrite transport_f_f ; apply transportf_set ; apply homset_property). Defined. Definition opfibration_is_street_opfib (HD : opcleaving D) : street_opfib (pr1_category D). Proof. intros e b f. pose (HD (pr1 e) b (pr2 e) f) as c. refine ((b ,, pr1 c) ,, ((f ,, pr12 c) ,, identity_z_iso b) ,, _). simpl. split. - apply (!(id_right _)). - apply is_opcartesian_to_is_opcartesian_sopfib. exact (pr22 c). Defined. End OpcleavingToStreetOpFib. (** *) Definition lift_unique_sopfib_map {E B : category} (F : E ⟶ B) {e : E} {b : B} (f : F e --> b) (bb₁ bb₂ : E) (ff₁ : e --> bb₁) (β₁ : z_iso b (F bb₁)) (ff₂ : e --> bb₂) (β₂ : z_iso b (F bb₂)) (over₁ : # F (ff₁) = f · β₁) (over₂ : # F (ff₂) = f · β₂) (cart₁ : is_opcartesian_sopfib F ff₁) (cart₂ : is_opcartesian_sopfib F ff₂) : bb₁ --> bb₂. Proof. use (opcartesian_factorization_sopfib F cart₁ ff₂ (inv_from_z_iso β₁ · β₂) _). abstract (rewrite over₁, over₂ ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite z_iso_inv_after_z_iso ; rewrite id_left ; apply idpath). Defined. Section UniqueLifts. Context {E B : category} (F : E ⟶ B) {e : E} {b : B} (f : F e --> b) (bb₁ bb₂ : E) (ff₁ : e --> bb₁) (β₁ : z_iso b (F bb₁)) (ff₂ : e --> bb₂) (β₂ : z_iso b (F bb₂)) (over₁ : # F (ff₁) = f · β₁) (over₂ : # F (ff₂) = f · β₂) (cart₁ : is_opcartesian_sopfib F ff₁) (cart₂ : is_opcartesian_sopfib F ff₂). Let ζ : bb₁ --> bb₂ := lift_unique_sopfib_map F f bb₁ bb₂ ff₁ β₁ ff₂ β₂ over₁ over₂ cart₁ cart₂. Let ζinv : bb₂ --> bb₁ := lift_unique_sopfib_map F f bb₂ bb₁ ff₂ β₂ ff₁ β₁ over₂ over₁ cart₂ cart₁. Local Lemma lift_unique_sopfib_inv₁ : ζ · ζinv = identity bb₁. Proof. unfold ζ, ζinv, lift_unique_sopfib_map. use (opcartesian_factorization_sopfib_unique F cart₁ ff₁ (identity _)). - rewrite id_right. apply idpath. - rewrite functor_comp. rewrite !opcartesian_factorization_sopfib_over. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite z_iso_inv_after_z_iso. rewrite id_left. rewrite z_iso_after_z_iso_inv. apply idpath. - apply functor_id. - rewrite !assoc. rewrite !opcartesian_factorization_sopfib_commute. apply idpath. - apply id_right. Qed. Local Lemma lift_unique_sopfib_inv₂ : ζinv · ζ = identity bb₂. Proof. unfold ζ, ζinv, lift_unique_sopfib_map. use (opcartesian_factorization_sopfib_unique F cart₂ ff₂ (identity _)). - rewrite id_right. apply idpath. - rewrite functor_comp. rewrite !opcartesian_factorization_sopfib_over. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite z_iso_inv_after_z_iso. rewrite id_left. rewrite z_iso_after_z_iso_inv. apply idpath. - apply functor_id. - rewrite !assoc. rewrite !opcartesian_factorization_sopfib_commute. apply idpath. - apply id_right. Qed. Definition lift_unique_sopfib : z_iso bb₁ bb₂. Proof. exists ζ. exists ζinv. split. - exact lift_unique_sopfib_inv₁. - exact lift_unique_sopfib_inv₂. Defined. End UniqueLifts. (** The type of Street opfibrations is a proposition *) Definition isaprop_street_opfib {B E : category} (HE : is_univalent E) (F : E ⟶ B) : isaprop (street_opfib F). Proof. use impred ; intro e. use impred ; intro b. use impred ; intro f. use invproofirrelevance. intros φ₁ φ₂. use total2_paths_f. - apply (isotoid _ HE). exact (lift_unique_sopfib F f (pr1 φ₁) (pr1 φ₂) (pr112 φ₁) (pr212 φ₁) (pr112 φ₂) (pr212 φ₂) (pr122 φ₁) (pr122 φ₂) (pr222 φ₁) (pr222 φ₂)). - use subtypePath. { intro. apply isapropdirprod ; [ apply homset_property | apply isaprop_is_opcartesian_sopfib ]. } rewrite pr1_transportf. use dirprod_paths. + etrans. { apply (@pr1_transportf E (λ x, e --> x) (λ x _, z_iso _ (F x))). } rewrite transportf_isotoid'. apply opcartesian_factorization_sopfib_commute. + rewrite pr2_transportf. use subtypePath. { intro. apply isaprop_is_z_isomorphism. } unfold z_iso. rewrite pr1_transportf. rewrite transportf_functor_isotoid'. etrans. { apply maponpaths. apply opcartesian_factorization_sopfib_over. } rewrite !assoc. etrans. { apply maponpaths_2. apply z_iso_inv_after_z_iso. } apply id_left. Qed. (** Lemmas on opcartesian cells for Street fibrations *) Definition is_opcartesian_sopfib_eq {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ : C₁} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) (Hf₁ : is_opcartesian_sopfib F f₁) : is_opcartesian_sopfib F f₂. Proof. induction p. exact Hf₁. Defined. Definition iso_is_opcartesian_sopfib {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ : C₁} (i : x₁ --> x₂) (Hi : is_z_isomorphism i) : is_opcartesian_sopfib F i. Proof. pose (i_iso := make_z_iso' _ Hi). intros w g h p. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; refine (!(id_left _) @ _ @ id_left _) ; rewrite <- (z_iso_after_z_iso_inv i_iso) ; cbn ; rewrite !assoc' ; rewrite (pr22 φ₁), (pr22 φ₂) ; apply idpath). - simple refine (_ ,, _ ,, _). + exact (inv_from_z_iso i_iso · g). + abstract (rewrite functor_comp ; rewrite p ; rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; exact (z_iso_after_z_iso_inv i_iso) | ] ; rewrite functor_id ; apply id_left). + abstract (cbn ; rewrite !assoc ; refine (_ @ id_left _) ; apply maponpaths_2 ; exact (z_iso_inv_after_z_iso i_iso)). Defined. Section CompositionOpCartesian. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x₁ x₂ x₃ : C₁} {f : x₁ --> x₂} (Hf : is_opcartesian_sopfib F f) {g : x₂ --> x₃} (Hg : is_opcartesian_sopfib F g). Section Factorization. Context {w : C₁} {h₁ : x₁ --> w} {h₂ : F x₃ --> F w} (p : # F h₁ = # F (f · g) · h₂). Definition comp_is_opcartesian_sopfib_factor_help : x₂ --> w. Proof. use (opcartesian_factorization_sopfib _ Hf h₁ (#F g · h₂)). abstract (refine (p @ _) ; rewrite functor_comp ; rewrite !assoc ; apply idpath). Defined. Definition comp_is_opcartesian_sopfib_factor : x₃ --> w. Proof. use (opcartesian_factorization_sopfib _ Hg). - exact comp_is_opcartesian_sopfib_factor_help. - exact h₂. - apply opcartesian_factorization_sopfib_over. Defined. Definition comp_is_opcartesian_sopfib_factor_over : # F comp_is_opcartesian_sopfib_factor = h₂. Proof. apply opcartesian_factorization_sopfib_over. Qed. Definition comp_is_opcartesian_sopfib_factor_comm : f · g · comp_is_opcartesian_sopfib_factor = h₁. Proof. unfold comp_is_opcartesian_sopfib_factor, comp_is_opcartesian_sopfib_factor_help. rewrite !assoc'. rewrite !opcartesian_factorization_sopfib_commute. apply idpath. Qed. Definition comp_is_opcartesian_sopfib_factor_unique : isaprop (∑ φ, # F φ = h₂ × f · g · φ = h₁). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use (opcartesian_factorization_sopfib_unique _ Hg comp_is_opcartesian_sopfib_factor_help h₂). - apply opcartesian_factorization_sopfib_over. - exact (pr12 φ₁). - exact (pr12 φ₂). - use (opcartesian_factorization_sopfib_unique _ Hf h₁ (#F g · h₂)). + rewrite p. rewrite functor_comp. rewrite !assoc. apply idpath. + rewrite functor_comp. rewrite (pr12 φ₁). apply idpath. + apply opcartesian_factorization_sopfib_over. + rewrite assoc. apply (pr22 φ₁). + apply opcartesian_factorization_sopfib_commute. - use (opcartesian_factorization_sopfib_unique _ Hf h₁ (#F g · h₂)). + rewrite p. rewrite functor_comp. rewrite !assoc. apply idpath. + rewrite functor_comp. rewrite (pr12 φ₂). apply idpath. + apply opcartesian_factorization_sopfib_over. + rewrite assoc. apply (pr22 φ₂). + apply opcartesian_factorization_sopfib_commute. Qed. End Factorization. Definition comp_is_opcartesian_sopfib : is_opcartesian_sopfib F (f · g). Proof. intros w h₁ h₂ p. use iscontraprop1. - exact (comp_is_opcartesian_sopfib_factor_unique p). - simple refine (_ ,, _ ,, _). + exact (comp_is_opcartesian_sopfib_factor p). + exact (comp_is_opcartesian_sopfib_factor_over p). + exact (comp_is_opcartesian_sopfib_factor_comm p). Defined. End CompositionOpCartesian. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Structures/000077500000000000000000000000001451125700300245405ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Structures/CartesianStructure.v000066400000000000000000000561711451125700300305730ustar00rootroot00000000000000(***************************************************************** Structures on sets In this file, we look at a particular class of structures on the category of set that is closed under products and the terminal object. Key in this development are displayed categories and the structure identity principle. The notion of structure that we consider, consists of: - For every hSet, a set of structures on that set - For every function, a proposition that represents wheter this function preserves the structure. The notion of structure must be closed under product and there must be a structure for the unit set. We also require that structure-preserving maps are closed under identity, composition, constant functions, and pairing. We also require that projections and the map to the unit set are structure preserving. The final requirement is the notion of 'standardness' (see the HoTT book), from which we conclude the univalence of the category of structured sets. We also give conditions that guarantee the category of structures is a cartesian category. Finally, we look at structures for which we have a section on the corresponding displayed category. This gives the following requirements: - For every set `X`, we have a structure `PX` on `X` - Every map `f : X → Y` is a structure preserving map from `PX` to `PY` - If we have a set `X` with a structure `S` on it, then the identity is a structure preserving map from `PX` to `S`. This gives a left adjoint of the forgetful functor. Contents 1. Definition of the structures 2. The corresponding displayed category 3. The total category 4. Transporting structures 5. Cartesian structures 6. Transport laws for cartesian structures 7. Terminal object and products from cartesian structures 8. Sections of structures *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Local Open Scope cat. (** 1. Definition of the structures *) Definition hset_struct_data : UU := ∑ (P : hSet → UU), (∏ (X Y : hSet), P X → P Y → (X → Y) → UU). Definition hset_struct_data_to_fam (P : hset_struct_data) : hSet → UU := pr1 P. Coercion hset_struct_data_to_fam : hset_struct_data >-> Funclass. Definition mor_hset_struct (P : hset_struct_data) {X Y : hSet} (PX : P X) (PY : P Y) (f : X → Y) : UU := pr2 P X Y PX PY f. Definition hset_struct_laws (P : hset_struct_data) : UU := (∏ (X : hSet), isaset (P X)) × (∏ (X Y : hSet) (PX : P X) (PY : P Y) (f : X → Y), isaprop (mor_hset_struct P PX PY f)) × (∏ (X : hSet) (PX : P X), mor_hset_struct P PX PX (λ x, x)) × (∏ (X Y Z : hSet) (PX : P X) (PY : P Y) (PZ : P Z) (f : X → Y) (g : Y → Z) (Mf : mor_hset_struct P PX PY f) (Mg : mor_hset_struct P PY PZ g), mor_hset_struct P PX PZ (λ x, g(f x))) × (∏ (X : hSet) (PX PX' : P X), mor_hset_struct P PX PX' (λ x, x) → mor_hset_struct P PX' PX (λ x, x) → PX = PX'). Definition hset_struct : UU := ∑ (P : hset_struct_data), hset_struct_laws P. Coercion hset_struct_to_data (P : hset_struct) : hset_struct_data := pr1 P. Section Projections. Context (P : hset_struct). Proposition isaset_hset_struct_on_set (X : hSet) : isaset (P X). Proof. exact (pr12 P X). Qed. Proposition isaprop_hset_struct_on_mor {X Y : hSet} (PX : P X) (PY : P Y) (f : X → Y) : isaprop (mor_hset_struct P PX PY f). Proof. exact (pr122 P X Y PX PY f). Defined. Proposition hset_struct_id {X : hSet} (PX : P X) : mor_hset_struct P PX PX (λ x, x). Proof. exact (pr1 (pr222 P) X PX). Qed. Proposition hset_struct_comp {X Y Z : hSet} {PX : P X} {PY : P Y} {PZ : P Z} {f : X → Y} {g : Y → Z} (Mf : mor_hset_struct P PX PY f) (Mg : mor_hset_struct P PY PZ g) : mor_hset_struct P PX PZ (λ x, g(f x)). Proof. exact (pr12 (pr222 P) X Y Z PX PY PZ f g Mf Mg). Qed. Proposition hset_struct_standard {X : hSet} {PX PX' : P X} (Mf : mor_hset_struct P PX PX' (λ x, x)) (Mf' : mor_hset_struct P PX' PX (λ x, x)) : PX = PX'. Proof. exact (pr22 (pr222 P) X PX PX' Mf Mf'). Qed. End Projections. Section SetStructure. Context (P : hset_struct). (** 2. The corresponding displayed category *) Definition hset_struct_disp_cat : disp_cat SET := disp_struct SET P (λ X Y PX PY f, mor_hset_struct P PX PY f) (λ X Y PX PY f, isaprop_hset_struct_on_mor P PX PY f) (λ X PX, hset_struct_id P PX) (λ X Y Z PX PY PZ f g Mf Mg, hset_struct_comp P Mf Mg). Proposition is_univalent_disp_hset_struct_disp_cat : is_univalent_disp hset_struct_disp_cat. Proof. use is_univalent_disp_from_SIP_data. - exact (isaset_hset_struct_on_set P). - exact (λ X PX PX' Mf Mf', hset_struct_standard P Mf Mf'). Qed. (** 3. The total category *) Definition category_of_hset_struct : category := total_category hset_struct_disp_cat. Proposition eq_mor_hset_struct {X Y : category_of_hset_struct} {f g : X --> Y} (p : ∏ (x : pr11 X), pr1 f x = pr1 g x) : f = g. Proof. use subtypePath. { intro. apply isaprop_hset_struct_on_mor. } use funextsec. exact p. Qed. Definition underlying_of_hset_struct : category_of_hset_struct ⟶ HSET := pr1_category _. Definition is_univalent_category_of_hset_struct : is_univalent category_of_hset_struct. Proof. use is_univalent_total_category. - exact is_univalent_HSET. - exact is_univalent_disp_hset_struct_disp_cat. Defined. Definition univalent_category_of_hset_struct : univalent_category. Proof. use make_univalent_category. - exact category_of_hset_struct. - exact is_univalent_category_of_hset_struct. Defined. (** 4. Transporting structures *) Definition transportf_struct_weq {X Y : hSet} (w : X ≃ Y) (PX : P X) : P Y := transportf P (univalence_hSet w) PX. Proposition transportf_struct_idweq (X : hSet) (PX : P X) : transportf_struct_weq (idweq X) PX = PX. Proof. refine (_ @ idpath_transportf _ _). unfold transportf_struct_weq. apply maponpaths_2. apply univalence_hSet_idweq. Qed. Definition transportf_mor_weq {X₁ X₂ Y₁ Y₂ : hSet} (w₁ : X₁ ≃ Y₁) (w₂ : X₂ ≃ Y₂) (f : X₁ → X₂) : Y₁ → Y₂ := λ y, w₂ (f (invmap w₁ y)). Definition transportf_struct_mor_via_transportf {X₁ X₂ Y₁ Y₂ : hSet} (p₁ : X₁ = Y₁) (PX₁ : P X₁) (p₂ : X₂ = Y₂) (PX₂ : P X₂) (f : X₁ → X₂) (Hf : mor_hset_struct P PX₁ PX₂ f) : mor_hset_struct P (transportf P p₁ PX₁) (transportf P p₂ PX₂) (transportf_mor_weq (hSet_univalence_map _ _ p₁) (hSet_univalence_map _ _ p₂) f). Proof. induction p₁, p₂ ; cbn. exact Hf. Qed. Definition transportf_struct_mor {X₁ X₂ Y₁ Y₂ : hSet} (w₁ : X₁ ≃ Y₁) (PX₁ : P X₁) (w₂ : X₂ ≃ Y₂) (PX₂ : P X₂) (f : X₁ → X₂) (Hf : mor_hset_struct P PX₁ PX₂ f) : mor_hset_struct P (transportf_struct_weq w₁ PX₁) (transportf_struct_weq w₂ PX₂) (transportf_mor_weq w₁ w₂ f). Proof. pose (transportf_struct_mor_via_transportf (univalence_hSet w₁) PX₁ (univalence_hSet w₂) PX₂ f Hf) as H. rewrite !hSet_univalence_map_univalence_hSet in H. exact H. Qed. Definition transportf_struct_mor_via_eq {X₁ X₂ Y₁ Y₂ : hSet} (w₁ : X₁ ≃ Y₁) (PX₁ : P X₁) (w₂ : X₂ ≃ Y₂) (PX₂ : P X₂) (f : X₁ → X₂) (Hf : mor_hset_struct P PX₁ PX₂ f) (g : Y₁ → Y₂) (p : ∏ (y : Y₁), g y = transportf_mor_weq w₁ w₂ f y) : mor_hset_struct P (transportf_struct_weq w₁ PX₁) (transportf_struct_weq w₂ PX₂) g. Proof. refine (transportf _ _ (transportf_struct_mor w₁ PX₁ w₂ PX₂ f Hf)). use funextsec. intro y. exact (!(p y)). Qed. Definition transportf_mor_weq_prod {X₁ X₂ X₃ Y₁ Y₂ Y₃ : hSet} (w₁ : X₁ ≃ Y₁) (w₂ : X₂ ≃ Y₂) (w₃ : X₃ ≃ Y₃) (f : X₁ × X₂ → X₃) : Y₁ × Y₂ → Y₃ := λ y, w₃ (f (invmap w₁ (pr1 y) ,, invmap w₂ (pr2 y))). End SetStructure. (** 5. Cartesian structures *) Definition hset_cartesian_struct_data : UU := ∑ (P : hset_struct), P unitHSET × (∏ (X Y : hSet) (PX : P X) (PY : P Y), P (X × Y)%set). Coercion hset_cartesian_struct_datat_to_struct (P : hset_cartesian_struct_data) : hset_struct := pr1 P. Definition hset_struct_unit (P : hset_cartesian_struct_data) : P unitHSET := pr12 P. Definition hset_struct_unit_ob (P : hset_cartesian_struct_data) : category_of_hset_struct P := _ ,, hset_struct_unit P. Definition hset_struct_prod (P : hset_cartesian_struct_data) {X Y : hSet} (PX : P X) (PY : P Y) : P (X × Y)%set := pr22 P X Y PX PY. Definition hset_struct_prod_ob {P : hset_cartesian_struct_data} (PX PY : category_of_hset_struct P) : category_of_hset_struct P := _ ,, hset_struct_prod P (pr2 PX) (pr2 PY). Definition hset_cartesian_struct_laws (P : hset_cartesian_struct_data) : UU := (∏ (X : hSet) (PX : P X), mor_hset_struct P PX (hset_struct_unit P) (λ _ : X, tt)) × (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P (hset_struct_prod P PX PY) PX dirprod_pr1) × (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P (hset_struct_prod P PX PY) PY dirprod_pr2) × (∏ (W X Y : hSet) (PW : P W) (PX : P X) (PY : P Y) (f : W → X) (g : W → Y) (Mf : mor_hset_struct P PW PX f) (Mg : mor_hset_struct P PW PY g), mor_hset_struct P PW (hset_struct_prod P PX PY) (prodtofuntoprod (f ,, g))). Definition hset_cartesian_struct : UU := ∑ (P : hset_cartesian_struct_data), hset_cartesian_struct_laws P. Coercion hset_cartesian_struct_to_data (P : hset_cartesian_struct) : hset_cartesian_struct_data := pr1 P. Section Projections. Context (P : hset_cartesian_struct). Proposition hset_struct_to_unit {X : hSet} (PX : P X) : mor_hset_struct P PX (hset_struct_unit P) (λ _ : X, tt). Proof. exact (pr12 P X PX). Qed. Proposition hset_struct_pr1 {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P (hset_struct_prod P PX PY) PX dirprod_pr1. Proof. exact (pr122 P X Y PX PY). Qed. Proposition hset_struct_pr2 {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P (hset_struct_prod P PX PY) PY dirprod_pr2. Proof. exact (pr1 (pr222 P) X Y PX PY). Qed. Proposition hset_struct_pair {W X Y : hSet} {PW : P W} {PX : P X} {PY : P Y} {f : W → X} {g : W → Y} (Mf : mor_hset_struct P PW PX f) (Mg : mor_hset_struct P PW PY g) : mor_hset_struct P PW (hset_struct_prod P PX PY) (prodtofuntoprod (f ,, g)). Proof. exact (pr2 (pr222 P) W X Y PW PX PY f g Mf Mg). Qed. End Projections. (** 6. Transport laws for cartesian structures *) Section TransportCartesian. Context (P : hset_cartesian_struct). Definition transportf_struct_mor_prod_via_transportf {X₁ X₂ X₃ Y₁ Y₂ Y₃ : hSet} (p₁ : X₁ = Y₁) (PX₁ : P X₁) (p₂ : X₂ = Y₂) (PX₂ : P X₂) (p₃ : X₃ = Y₃) (PX₃ : P X₃) (f : X₁ × X₂ → X₃) (Hf : mor_hset_struct P (hset_struct_prod P PX₁ PX₂) PX₃ f) : mor_hset_struct P (hset_struct_prod P (transportf P p₁ PX₁) (transportf P p₂ PX₂)) (transportf P p₃ PX₃) (transportf_mor_weq_prod (hSet_univalence_map _ _ p₁) (hSet_univalence_map _ _ p₂) (hSet_univalence_map _ _ p₃) f). Proof. induction p₁, p₂, p₃. exact Hf. Qed. Definition transportf_struct_mor_prod {X₁ X₂ X₃ Y₁ Y₂ Y₃ : hSet} (w₁ : X₁ ≃ Y₁) (PX₁ : P X₁) (w₂ : X₂ ≃ Y₂) (PX₂ : P X₂) (w₃ : X₃ ≃ Y₃) (PX₃ : P X₃) (f : X₁ × X₂ → X₃) (Hf : mor_hset_struct P (hset_struct_prod P PX₁ PX₂) PX₃ f) : mor_hset_struct P (hset_struct_prod P (transportf_struct_weq P w₁ PX₁) (transportf_struct_weq P w₂ PX₂)) (transportf_struct_weq P w₃ PX₃) (transportf_mor_weq_prod w₁ w₂ w₃ f). Proof. pose (transportf_struct_mor_prod_via_transportf (univalence_hSet w₁) PX₁ (univalence_hSet w₂) PX₂ (univalence_hSet w₃) PX₃ f Hf) as H. rewrite !hSet_univalence_map_univalence_hSet in H. exact H. Qed. Definition transportf_struct_mor_prod_via_eq {X₁ X₂ X₃ Y₁ Y₂ Y₃ : hSet} (w₁ : X₁ ≃ Y₁) (PX₁ : P X₁) (w₂ : X₂ ≃ Y₂) (PX₂ : P X₂) (w₃ : X₃ ≃ Y₃) (PX₃ : P X₃) (f : X₁ × X₂ → X₃) (Hf : mor_hset_struct P (hset_struct_prod P PX₁ PX₂) PX₃ f) (g : Y₁ × Y₂ → Y₃) (p : ∏ (y : Y₁ × Y₂), g y = transportf_mor_weq_prod w₁ w₂ w₃ f y) : mor_hset_struct P (hset_struct_prod P (transportf_struct_weq P w₁ PX₁) (transportf_struct_weq P w₂ PX₂)) (transportf_struct_weq P w₃ PX₃) g. Proof. refine (transportf _ _ (transportf_struct_mor_prod w₁ PX₁ w₂ PX₂ w₃ PX₃ f Hf)). use funextsec. intro y. exact (!(p y)). Qed. Definition transportf_struct_weq_on_weq_transportf {X Y : hSet} (p : X = Y) (PX : P X) : mor_hset_struct P PX (transportf P p PX) (hSet_univalence_map _ _ p). Proof. induction p ; cbn. apply hset_struct_id. Qed. Definition transportf_struct_weq_on_weq {X Y : hSet} (w : X ≃ Y) (PX : P X) : mor_hset_struct P PX (transportf_struct_weq P w PX) w. Proof. pose (transportf_struct_weq_on_weq_transportf (univalence_hSet w) PX) as H. rewrite hSet_univalence_map_univalence_hSet in H. exact H. Qed. Definition transportf_struct_weq_on_invweq_transportf {X Y : hSet} (p : X = Y) (PX : P X) : mor_hset_struct P (transportf P p PX) PX (hSet_univalence_map _ _ (!p)). Proof. induction p ; cbn. apply hset_struct_id. Qed. Definition transportf_struct_weq_on_invweq {X Y : hSet} (w : X ≃ Y) (PX : P X) : mor_hset_struct P (transportf_struct_weq P w PX) PX (invmap w). Proof. pose (transportf_struct_weq_on_invweq_transportf (univalence_hSet w) PX) as H. rewrite univalence_hSet_inv in H. rewrite hSet_univalence_map_univalence_hSet in H. exact H. Qed. End TransportCartesian. (** 7. Terminal object and products from cartesian structures *) Section TerminalAndProductCartesian. Context (P : hset_cartesian_struct). Definition dispTerminal_hset_disp_struct : dispTerminal (hset_struct_disp_cat P) TerminalHSET. Proof. refine (hset_struct_unit P ,, _). intros X PX. use iscontraprop1. - apply isaprop_hset_struct_on_mor. - exact (hset_struct_to_unit P PX). Defined. Definition dispBinProducts_hset_disp_struct : dispBinProducts (hset_struct_disp_cat P) BinProductsHSET. Proof. intros X Y PX PY. simple refine ((_ ,, (_ ,, _)) ,, _). - exact (hset_struct_prod P PX PY). - exact (hset_struct_pr1 P PX PY). - exact (hset_struct_pr2 P PX PY). - intros W f g PW Mf Mg ; cbn. use iscontraprop1. + abstract (use isaproptotal2 ; [ intro ; apply isapropdirprod ; apply hset_struct_disp_cat | ] ; intros ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _ ,, _). * exact (hset_struct_pair P Mf Mg). * apply isaprop_hset_struct_on_mor. * apply isaprop_hset_struct_on_mor. Defined. Definition Terminal_category_of_hset_struct : Terminal (category_of_hset_struct P). Proof. use total_category_Terminal. - exact TerminalHSET. - exact dispTerminal_hset_disp_struct. Defined. Definition BinProducts_category_of_hset_struct : BinProducts (category_of_hset_struct P). Proof. use total_category_Binproducts. - exact BinProductsHSET. - exact dispBinProducts_hset_disp_struct. Defined. End TerminalAndProductCartesian. (** 8. Sections of structures *) Definition discrete_hset_struct_data (P : hset_struct) : UU := ∑ (PX : ∏ (X : hSet), P X), ∏ (X Y : hSet) (f : X → Y), mor_hset_struct P (PX X) (PX Y) f. Definition discrete_hset_struct_data_ob {P : hset_struct} (PX : discrete_hset_struct_data P) (X : hSet) : P X := pr1 PX X. Coercion discrete_hset_struct_data_ob : discrete_hset_struct_data >-> Funclass. Proposition discrete_hset_struct_data_mor {P : hset_struct} (PX : discrete_hset_struct_data P) {X Y : hSet} (f : X → Y) : mor_hset_struct P (PX X) (PX Y) f. Proof. exact (pr2 PX X Y f). Qed. Definition discrete_hset_struct_laws {P : hset_struct} (PX : discrete_hset_struct_data P) : UU := ∏ (Z : hSet) (PZ : P Z), mor_hset_struct P (PX Z) PZ (λ z, z). Definition discrete_hset_struct (P : hset_struct) : UU := ∑ (PX : discrete_hset_struct_data P), discrete_hset_struct_laws PX. Coercion discrete_hset_struct_to_data {P : hset_struct} (PX : discrete_hset_struct P) : discrete_hset_struct_data P := pr1 PX. Definition discrete_hset_struct_counit {P : hset_struct} (PX : discrete_hset_struct P) {Z : hSet} (PZ : P Z) : mor_hset_struct P (PX Z) PZ (λ z, z) := pr2 PX Z PZ. Definition make_discrete_hset_struct (P : hset_struct) (PX : ∏ (X : hSet), P X) (Pf : ∏ (X Y : hSet) (f : X → Y), mor_hset_struct P (PX X) (PX Y) f) (Pη : ∏ (Z : hSet) (PZ : P Z), mor_hset_struct P (PX Z) PZ (λ z, z)) : discrete_hset_struct P := (PX ,, Pf) ,, Pη. Section DiscreteHSetStructSection. Context {P : hset_struct} (PX : discrete_hset_struct P). Definition discrete_hset_struct_section_data : section_disp_data (hset_struct_disp_cat P). Proof. refine ((λ X, PX X) ,, λ X Y f, _). exact (discrete_hset_struct_data_mor PX f). Defined. Proposition discrete_hset_struct_section_axioms : section_disp_axioms discrete_hset_struct_section_data. Proof. split. - intros X ; cbn. apply isaprop_hset_struct_on_mor. - intros X Y Z f g ; cbn. apply isaprop_hset_struct_on_mor. Qed. Definition discrete_hset_struct_section : section_disp (hset_struct_disp_cat P). Proof. simple refine (_ ,, _). - exact discrete_hset_struct_section_data. - exact discrete_hset_struct_section_axioms. Defined. Definition discrete_hset_struct_to_are_adjoint_unit : functor_identity _ ⟹ section_functor discrete_hset_struct_section ∙ underlying_of_hset_struct P. Proof. use make_nat_trans. - exact (λ X, identity _). - abstract (intros X Y f ; cbn ; apply idpath). Defined. Definition discrete_hset_struct_to_are_adjoint_counit : underlying_of_hset_struct P ∙ section_functor discrete_hset_struct_section ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ X, identity _ ,, discrete_hset_struct_counit PX (pr2 X)). - abstract (intros X Y f ; use eq_mor_hset_struct ; intro x ; cbn ; apply idpath). Defined. Definition discrete_hset_struct_to_are_adjoint : are_adjoints (section_functor discrete_hset_struct_section) (underlying_of_hset_struct P). Proof. simple refine ((_ ,, _) ,, (_ ,, _)). - exact discrete_hset_struct_to_are_adjoint_unit. - exact discrete_hset_struct_to_are_adjoint_counit. - abstract (intro X ; use eq_mor_hset_struct ; intro x ; cbn ; apply idpath). - abstract (intro ; cbn ; apply idpath). Defined. Definition discrete_hset_struct_to_is_right_adjoint : is_right_adjoint (underlying_of_hset_struct P) := section_functor discrete_hset_struct_section ,, discrete_hset_struct_to_are_adjoint. End DiscreteHSetStructSection. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Structures/StructureLimitsAndColimits.v000066400000000000000000000667521451125700300322600ustar00rootroot00000000000000(***************************************************************** Limits and colimits of structures The category of structures might have additional structure. For example, it could be cartesian closed or it could have all limits. In this file, we give conditions that guarantee the existence of certain limits/colimits in the category of structures. We also provide conditions from which we can conclude that this category is cartesian closed (where the internal hom would be given by the set of morphisms). Besides that, we define pointed structures: structures together with a chosen point. Note that a in a pointed structures, the point does not have to be an arbitrary point. For example, groups would form a pointed structure, where we can select the identity element to be the point for each structure. Contents 1. Cartesian closed structures 2. Equalizers of structures 3. Coequalizers 4. Type indexed products 5. Pointed structures 6. Binary coproducts 7. Set-indexed coproducts *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.MonadAlgebras. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Local Open Scope cat. (** 1. Cartesian closed structures *) Definition struct_fun {P : hset_struct} {X Y : hSet} (PX : P X) (PY : P Y) : UU := ∑ (f : X → Y), mor_hset_struct P PX PY f. Definition struct_fun_to_fun {P : hset_struct} {X Y : hSet} {PX : P X} {PY : P Y} (f : struct_fun PX PY) : X → Y := pr1 f. Coercion struct_fun_to_fun : struct_fun >-> Funclass. Definition struct_fun_hSet {P : hset_struct} {X Y : hSet} (PX : P X) (PY : P Y) : hSet. Proof. use (make_hSet (struct_fun PX PY)). use isaset_total2. - apply funspace_isaset. apply setproperty. - intro. apply isasetaprop. apply isaprop_hset_struct_on_mor. Defined. Definition closed_under_fun_data (P : hset_struct) : UU := ∏ (X Y : hSet) (PX : P X) (PY : P Y), P (struct_fun_hSet PX PY). Definition struct_contains_constant (P : hset_struct) : UU := ∏ (X Y : hSet) (PX : P X) (PY : P Y) (y : Y), mor_hset_struct P PX PY (λ x, y). Definition hset_cartesian_closed_struct_data : UU := ∑ (P : hset_cartesian_struct) (constP : struct_contains_constant P), closed_under_fun_data P. Coercion hset_cartesian_closed_struct_data_to_struct (P : hset_cartesian_closed_struct_data) : hset_cartesian_struct := pr1 P. Proposition hset_struct_const (P : hset_cartesian_closed_struct_data) {X Y : hSet} (PX : P X) (PY : P Y) (y : Y) : mor_hset_struct P PX PY (λ x, y). Proof. exact (pr12 P X Y PX PY y). Qed. Proposition hset_struct_pointwise (P : hset_cartesian_closed_struct_data) {X Y Z : hSet} {PX : P X} {PY : P Y} {PZ : P Z} (f : X × Z → Y) (Pf : mor_hset_struct P (hset_struct_prod P PX PZ) PY f) (z : Z) : mor_hset_struct P PX PY (λ x : X, f (x ,, z)). Proof. exact (hset_struct_comp P (hset_struct_pair P (hset_struct_id P PX) (hset_struct_const P PX PZ z)) Pf). Qed. Definition hset_struct_fun (P : hset_cartesian_closed_struct_data) {X Y : hSet} (PX : P X) (PY : P Y) : P (struct_fun_hSet PX PY) := pr22 P X Y PX PY. Definition closed_under_fun_laws (P : hset_cartesian_closed_struct_data) : UU := (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P (hset_struct_prod P PX (hset_struct_fun P PX PY)) PY (λ xf, pr12 xf (pr1 xf))) × (∏ (X Y Z : hSet) (PX : P X) (PY : P Y) (PZ : P Z) (f : X × Z → Y) (Pf : mor_hset_struct P (hset_struct_prod P PX PZ) PY f), mor_hset_struct P PZ (hset_struct_fun P PX PY) (λ z, _ ,, hset_struct_pointwise P f Pf z)). Definition hset_cartesian_closed_struct : UU := ∑ (P : hset_cartesian_closed_struct_data), closed_under_fun_laws P. Coercion hset_cartesian_closed_struct_to_data (P : hset_cartesian_closed_struct) : hset_cartesian_closed_struct_data := pr1 P. Section ClosedUnderFunLaws. Context (P : hset_cartesian_closed_struct). Proposition closed_under_fun_eval {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P (hset_struct_prod P PX (hset_struct_fun P PX PY)) PY (λ xf, pr12 xf (pr1 xf)). Proof. exact (pr12 P X Y PX PY). Qed. Proposition closed_under_fun_lam {X Y Z : hSet} {PX : P X} {PY : P Y} {PZ : P Z} (f : X × Z → Y) (Pf : mor_hset_struct P (hset_struct_prod P PX PZ) PY f) : mor_hset_struct P PZ (hset_struct_fun P PX PY) (λ z, _ ,, hset_struct_pointwise P f Pf z). Proof. exact (pr22 P X Y Z PX PY PZ f Pf). Qed. End ClosedUnderFunLaws. Definition Exponentials_struct (P : hset_cartesian_closed_struct) : Exponentials (BinProducts_category_of_hset_struct P). Proof. intros PX. use left_adjoint_from_partial. - exact (λ PY, _ ,, hset_struct_fun P (pr2 PX) (pr2 PY)). - exact (λ PY, _ ,, closed_under_fun_eval P _ _). - refine (λ Y Z f, _). use iscontraprop1. + abstract (use invproofirrelevance ; intros g₁ g₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use eq_mor_hset_struct ; intro z ; use eq_mor_hset_struct ; intro x ; refine (!(eqtohomot (maponpaths pr1 (pr2 g₁)) (x ,, z)) @ _) ; exact (eqtohomot (maponpaths pr1 (pr2 g₂)) (x ,, z))). + simple refine (_ ,, _). * exact (_ ,, closed_under_fun_lam P (pr1 f) (pr2 f)). * abstract (use eq_mor_hset_struct ; intro x ; cbn ; apply idpath). Defined. (** 2. Equalizers of structures *) Definition hset_equalizer_struct_data (P : hset_struct) : UU := ∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g), P (∑ (x : X), hProp_to_hSet (eqset (f x) (g x)))%set. Definition hset_struct_equalizer {P : hset_struct} (EP : hset_equalizer_struct_data P) {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) : P (∑ (x : X), hProp_to_hSet (eqset (f x) (g x)))%set := EP X Y f g PX PY Pf Pg. Definition hset_struct_equalizer_ob {P : hset_struct} (EP : hset_equalizer_struct_data P) {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) : category_of_hset_struct P := _ ,, hset_struct_equalizer EP Pf Pg. Definition hset_equalizer_struct_laws {P : hset_struct} (EP : hset_equalizer_struct_data P) : UU := (∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g), mor_hset_struct P (hset_struct_equalizer EP Pf Pg) PX pr1) × (∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) (W : hSet) (PW : P W) (h : W → X) (Ph : mor_hset_struct P PW PX h) (q : (λ w, f(h w)) = (λ w, g(h w))), mor_hset_struct P PW (hset_struct_equalizer EP Pf Pg) (λ w, h w ,, eqtohomot q w)). Definition hset_equalizer_struct (P : hset_struct) : UU := ∑ (EP : hset_equalizer_struct_data P), hset_equalizer_struct_laws EP. Coercion hset_equalizer_struct_to_data {P : hset_struct} (EP : hset_equalizer_struct P) : hset_equalizer_struct_data P := pr1 EP. Section EqualizerLaws. Context {P : hset_struct} (EP : hset_equalizer_struct P). Proposition hset_equalizer_pr_struct {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) : mor_hset_struct P (hset_struct_equalizer EP Pf Pg) PX pr1. Proof. exact (pr12 EP X Y f g PX PY Pf Pg). Qed. Proposition hset_equalizer_arrow_struct {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) {W : hSet} (PW : P W) (h : W → X) (Ph : mor_hset_struct P PW PX h) (q : (λ w, f(h w)) = (λ w, g(h w))) : mor_hset_struct P PW (hset_struct_equalizer EP Pf Pg) (λ w, h w ,, eqtohomot q w). Proof. exact (pr22 EP X Y f g PX PY Pf Pg W PW h Ph q). Qed. End EqualizerLaws. Definition disp_Equalizers_hset_disp_struct {P : hset_struct} (EP : hset_equalizer_struct P) : disp_Equalizers (hset_struct_disp_cat P) Equalizers_in_HSET. Proof. intros X Y f g PX PY Pf Pg. simple refine (_ ,, _ ,, _ ,, _). - exact (hset_struct_equalizer EP Pf Pg). - exact (hset_equalizer_pr_struct EP Pf Pg). - apply isaprop_hset_struct_on_mor. - intros W PW h Ph q qq. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isasetaprop ; apply isaprop_hset_struct_on_mor | ] ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _). * exact (hset_equalizer_arrow_struct EP Pf Pg PW h Ph q). * apply isaprop_hset_struct_on_mor. Defined. Definition Equalizers_category_of_hset_struct {P : hset_struct} (EP : hset_equalizer_struct P) : Equalizers (category_of_hset_struct P). Proof. use total_Equalizers. - exact Equalizers_in_HSET. - exact (disp_Equalizers_hset_disp_struct EP). Defined. (** 3. Coequalizers of structures *) Definition hset_coequalizer_struct_data (P : hset_struct) : UU := ∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g), P (coequalizer_hSet f g). Definition hset_struct_coequalizer {P : hset_struct} (EP : hset_coequalizer_struct_data P) {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) : P (coequalizer_hSet f g) := EP X Y f g PX PY Pf Pg. Definition hset_coequalizer_struct_laws {P : hset_struct} (EP : hset_coequalizer_struct_data P) : UU := (∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g), mor_hset_struct P PY (hset_struct_coequalizer EP Pf Pg) (coequalizer_map_hSet f g)) × (∏ (X Y : hSet) (f g : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) (Z : hSet) (PZ : P Z) (h : Y → Z) (Ph : mor_hset_struct P PY PZ h) (q : (λ w, h(f w)) = (λ w, h(g w))), mor_hset_struct P (hset_struct_coequalizer EP Pf Pg) PZ (coequalizer_out_hSet f g h (eqtohomot q))). Definition hset_coequalizer_struct (P : hset_struct) : UU := ∑ (EP : hset_coequalizer_struct_data P), hset_coequalizer_struct_laws EP. Coercion hset_coequalizer_struct_to_data {P : hset_struct} (EP : hset_coequalizer_struct P) : hset_coequalizer_struct_data P := pr1 EP. Section CoequalizerLaws. Context {P : hset_struct} (EP : hset_coequalizer_struct P). Proposition hset_coequalizer_map_struct {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) : mor_hset_struct P PY (hset_struct_coequalizer EP Pf Pg) (coequalizer_map_hSet f g). Proof. exact (pr12 EP X Y f g PX PY Pf Pg). Qed. Proposition hset_equalizer_out_struct {X Y : hSet} {f g : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) (Pg : mor_hset_struct P PX PY g) {Z : hSet} (PZ : P Z) (h : Y → Z) (Ph : mor_hset_struct P PY PZ h) (q : (λ w, h(f w)) = (λ w, h(g w))) : mor_hset_struct P (hset_struct_coequalizer EP Pf Pg) PZ (coequalizer_out_hSet f g h (eqtohomot q)). Proof. exact (pr22 EP X Y f g PX PY Pf Pg Z PZ h Ph q). Qed. End CoequalizerLaws. Definition disp_Coequalizers_hset_disp_struct {P : hset_struct} (EP : hset_coequalizer_struct P) : disp_Coequalizers (hset_struct_disp_cat P) Coequalizers_HSET. Proof. intros X Y f g PX PY Pf Pg. simple refine (_ ,, _ ,, _ ,, _). - exact (hset_struct_coequalizer EP Pf Pg). - exact (hset_coequalizer_map_struct EP Pf Pg). - apply isaprop_hset_struct_on_mor. - intros W PW h Ph q qq. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isasetaprop ; apply isaprop_hset_struct_on_mor | ] ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _). * exact (hset_equalizer_out_struct EP Pf Pg PW h Ph q). * apply isaprop_hset_struct_on_mor. Defined. Definition Coequalizers_category_of_hset_struct {P : hset_struct} (EP : hset_coequalizer_struct P) : Coequalizers (category_of_hset_struct P). Proof. use total_Coequalizers. - exact Coequalizers_HSET. - exact (disp_Coequalizers_hset_disp_struct EP). Defined. (** 4. Type indexed products *) Definition hset_struct_type_prod_data (P : hset_struct) (I : UU) : UU := ∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)), P (forall_hSet D). Definition hset_struct_type_prod_laws {P : hset_struct} {I : UU} (HP : hset_struct_type_prod_data P I) : UU := (∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)) (i : I), mor_hset_struct P (HP D PD) (PD i) (λ f, f i)) × (∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)) (W : hSet) (PW : P W) (fs : ∏ (i : I), W → D i) (Pfs : ∏ (i : I), mor_hset_struct P PW (PD i) (fs i)), mor_hset_struct P PW (HP D PD) (λ w i, fs i w)). Definition hset_struct_type_prod (P : hset_struct) (I : UU) : UU := ∑ (P : hset_struct_type_prod_data P I), hset_struct_type_prod_laws P. Definition hset_struct_type_prod_to_data {P : hset_struct} {I : UU} (HP : hset_struct_type_prod P I) {D : I → hSet} (PD : ∏ (i : I), P (D i)) : P (forall_hSet D) := pr1 HP D PD. Coercion hset_struct_type_prod_to_data : hset_struct_type_prod >-> Funclass. Definition hset_struct_type_prod_ob {P : hset_struct} {I : UU} (EP : hset_struct_type_prod P I) (D : I → hSet) (PD : ∏ (i : I), P (D i)) : category_of_hset_struct P := _ ,, EP D PD. Section Projections. Context {P : hset_struct} {I : UU} (HP : hset_struct_type_prod P I). Proposition hset_struct_type_prod_pr {D : I → hSet} (PD : ∏ (i : I), P (D i)) (i : I) : mor_hset_struct P (HP D PD) (PD i) (λ f, f i). Proof. exact (pr12 HP D PD i). Qed. Proposition hset_struct_type_prod_pair {D : I → hSet} (PD : ∏ (i : I), P (D i)) (W : hSet) (PW : P W) (fs : ∏ (i : I), W → D i) (Pfs : ∏ (i : I), mor_hset_struct P PW (PD i) (fs i)) : mor_hset_struct P PW (HP D PD) (λ w i, fs i w). Proof. exact (pr22 HP D PD W PW fs Pfs). Qed. End Projections. Definition dispProducts_hset_struct {P : hset_struct} {I : UU} (HP : hset_struct_type_prod P I) : disp_Products (hset_struct_disp_cat P) I (ProductsHSET I). Proof. intros D DD. simple refine (_ ,, (_ ,, _)). - exact (HP D DD). - exact (hset_struct_type_prod_pr HP DD). - intros W PW fs Hf. use iscontraprop1. + abstract (use isaproptotal2 ; [ intro ; use impred ; intro ; apply hset_struct_disp_cat | ] ; intros ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _). * exact (hset_struct_type_prod_pair HP _ _ _ _ Hf). * intro i. apply isaprop_hset_struct_on_mor. Defined. Definition Products_category_of_hset_struct_type_prod {P : hset_struct} {I : UU} (HP : hset_struct_type_prod P I) : Products I (category_of_hset_struct P). Proof. use total_Products. - exact (ProductsHSET I). - exact (dispProducts_hset_struct HP). Defined. (** 5. Pointed structures *) Definition pointed_hset_struct_data (P : hset_struct) : UU := ∏ (X : hSet), P X → X. Definition hset_struct_point {P : hset_struct} (Px : pointed_hset_struct_data P) {X : hSet} (PX : P X) : X := Px X PX. Definition pointed_hset_struct_laws {P : hset_struct} (Pt : pointed_hset_struct_data P) : UU := (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P PX PY (λ _, hset_struct_point Pt PY)) × (∏ (X Y : hSet) (f : X → Y) (PX : P X) (PY : P Y) (Pf : mor_hset_struct P PX PY f), f (hset_struct_point Pt PX) = hset_struct_point Pt PY). Definition pointed_hset_struct (P : hset_struct) : UU := ∑ (Pt : pointed_hset_struct_data P), pointed_hset_struct_laws Pt. Coercion pointed_hset_struct_to_data {P : hset_struct} (Pt : pointed_hset_struct P) : pointed_hset_struct_data P := pr1 Pt. Proposition pointed_hset_struct_const {P : hset_struct} (Pt : pointed_hset_struct P) {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P PX PY (λ _, hset_struct_point Pt PY). Proof. exact (pr12 Pt X Y PX PY). Qed. Proposition pointed_hset_struct_preserve_point {P : hset_struct} (Pt : pointed_hset_struct P) {X Y : hSet} {f : X → Y} {PX : P X} {PY : P Y} (Pf : mor_hset_struct P PX PY f) : f (hset_struct_point Pt PX) = hset_struct_point Pt PY. Proof. exact (pr22 Pt X Y f PX PY Pf). Qed. Proposition transportf_hset_struct_point {P : hset_cartesian_struct} (Pt : pointed_hset_struct P) {X Y : hSet} (p : X ≃ Y) (PX : P X) : hset_struct_point Pt (transportf P (univalence_hSet p) PX) = p (hset_struct_point Pt PX). Proof. exact (!(pointed_hset_struct_preserve_point Pt (transportf_struct_weq_on_weq P p PX))). Qed. (** 6. Binary coproducts *) Definition hset_binary_coprod_struct_data (P : hset_struct) : UU := ∏ (X Y : hSet) (PX : P X) (PY : P Y), P (BinCoproductObject (BinCoproductsHSET X Y)). Definition hset_struct_binary_coprod {P : hset_struct} (EP : hset_binary_coprod_struct_data P) {X Y : hSet} (PX : P X) (PY : P Y) : P (BinCoproductObject (BinCoproductsHSET X Y)) := EP X Y PX PY. Definition hset_binary_coprod_struct_laws {P : hset_struct} (EP : hset_binary_coprod_struct_data P) : UU := (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P PX (hset_struct_binary_coprod EP PX PY) inl) × (∏ (X Y : hSet) (PX : P X) (PY : P Y), mor_hset_struct P PY (hset_struct_binary_coprod EP PX PY) inr) × (∏ (X Y Z : hSet) (PX : P X) (PY : P Y) (PZ : P Z) (f : X → Z) (g : Y → Z) (Pf : mor_hset_struct P PX PZ f) (Pg : mor_hset_struct P PY PZ g), mor_hset_struct P (hset_struct_binary_coprod EP PX PY) PZ (sumofmaps f g)). Definition hset_binary_coprod_struct (P : hset_struct) : UU := ∑ (EP : hset_binary_coprod_struct_data P), hset_binary_coprod_struct_laws EP. Coercion hset_binary_coprod_struct_to_data {P : hset_struct} (EP : hset_binary_coprod_struct P) : hset_binary_coprod_struct_data P := pr1 EP. Section BinaryCoprodLaws. Context {P : hset_struct} (EP : hset_binary_coprod_struct P). Proposition hset_binary_coprod_struct_inl {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P PX (hset_struct_binary_coprod EP PX PY) inl. Proof. exact (pr12 EP X Y PX PY). Qed. Proposition hset_binary_coprod_struct_inr {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P PY (hset_struct_binary_coprod EP PX PY) inr. Proof. exact (pr122 EP X Y PX PY). Qed. Proposition hset_binary_coprod_struct_sumofmaps {X Y Z : hSet} {PX : P X} {PY : P Y} {PZ : P Z} {f : X → Z} {g : Y → Z} (Pf : mor_hset_struct P PX PZ f) (Pg : mor_hset_struct P PY PZ g) : mor_hset_struct P (hset_struct_binary_coprod EP PX PY) PZ (sumofmaps f g). Proof. exact (pr222 EP X Y Z PX PY PZ f g Pf Pg). Qed. End BinaryCoprodLaws. Definition disp_BinCoproducts_hset_disp_struct {P : hset_struct} (EP : hset_binary_coprod_struct P) : disp_BinCoproducts (hset_struct_disp_cat P) BinCoproductsHSET. Proof. intros X Y PX PY. simple refine (_ ,, _ ,, _ ,, _). - exact (hset_struct_binary_coprod EP PX PY). - exact (hset_binary_coprod_struct_inl EP PX PY). - exact (hset_binary_coprod_struct_inr EP PX PY). - intros W PW f Pf g Pg. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply isasetaprop ; apply isaprop_hset_struct_on_mor | ] ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _ ,, _). * exact (hset_binary_coprod_struct_sumofmaps EP Pf Pg). * apply isaprop_hset_struct_on_mor. * apply isaprop_hset_struct_on_mor. Defined. Definition BinCoproducts_category_of_hset_struct {P : hset_struct} (EP : hset_binary_coprod_struct P) : BinCoproducts (category_of_hset_struct P). Proof. use total_BinCoproducts. - exact BinCoproductsHSET. - exact (disp_BinCoproducts_hset_disp_struct EP). Defined. (** 7. Set-indexed coproducts *) Definition hset_struct_set_coprod_data (P : hset_struct) (I : hSet) : UU := ∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)), P (∑ (i : I), D i)%set. Definition hset_struct_set_coprod_laws {P : hset_struct} {I : hSet} (HP : hset_struct_set_coprod_data P I) : UU := (∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)) (i : I), mor_hset_struct P (PD i) (HP D PD) (λ d, i ,, d)) × (∏ (D : I → hSet) (PD : ∏ (i : I), P (D i)) (W : hSet) (PW : P W) (fs : ∏ (i : I), D i → W) (Pfs : ∏ (i : I), mor_hset_struct P (PD i) PW (fs i)), mor_hset_struct P (HP D PD) PW (λ id, fs (pr1 id) (pr2 id))). Definition hset_struct_set_coprod (P : hset_struct) (I : hSet) : UU := ∑ (P : hset_struct_set_coprod_data P I), hset_struct_set_coprod_laws P. Definition hset_struct_set_coprod_to_data {P : hset_struct} {I : hSet} (HP : hset_struct_set_coprod P I) {D : I → hSet} (PD : ∏ (i : I), P (D i)) : P (∑ (i : I), D i)%set := pr1 HP D PD. Coercion hset_struct_set_coprod_to_data : hset_struct_set_coprod >-> Funclass. Definition hset_struct_set_coprod_ob {P : hset_struct} {I : hSet} (EP : hset_struct_set_coprod P I) (D : I → hSet) (PD : ∏ (i : I), P (D i)) : category_of_hset_struct P := _ ,, EP D PD. Section Projections. Context {P : hset_struct} {I : hSet} (HP : hset_struct_set_coprod P I). Proposition hset_struct_set_coprod_in {D : I → hSet} (PD : ∏ (i : I), P (D i)) (i : I) : mor_hset_struct P (PD i) (HP D PD) (λ d, i ,, d). Proof. exact (pr12 HP D PD i). Qed. Proposition hset_struct_set_coprod_sum {D : I → hSet} (PD : ∏ (i : I), P (D i)) {W : hSet} (PW : P W) {fs : ∏ (i : I), D i → W} (Pfs : ∏ (i : I), mor_hset_struct P (PD i) PW (fs i)) : mor_hset_struct P (HP D PD) PW (λ id, fs (pr1 id) (pr2 id)). Proof. exact (pr22 HP D PD W PW fs Pfs). Qed. End Projections. Definition dispCoproducts_hset_struct {P : hset_struct} {I : hSet} (HP : hset_struct_set_coprod P I) : disp_Coproducts (hset_struct_disp_cat P) I (CoproductsHSET I (pr2 I)). Proof. intros D DD. simple refine (_ ,, (_ ,, _)). - exact (HP D DD). - exact (hset_struct_set_coprod_in HP DD). - intros W PW fs Hf. use iscontraprop1. + abstract (use isaproptotal2 ; [ intro ; use impred ; intro ; apply hset_struct_disp_cat | ] ; intros ; apply isaprop_hset_struct_on_mor). + simple refine (_ ,, _). * exact (hset_struct_set_coprod_sum HP _ _ Hf). * intro i. apply isaprop_hset_struct_on_mor. Defined. Definition Coproducts_category_of_hset_struct_set_coprod {P : hset_struct} {I : hSet} (HP : hset_struct_set_coprod P I) : Coproducts I (category_of_hset_struct P). Proof. use total_Coproducts. - exact (CoproductsHSET I (pr2 I)). - exact (dispCoproducts_hset_struct HP). Defined. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Structures/StructuresSmashProduct.v000066400000000000000000000730031451125700300314520ustar00rootroot00000000000000(***************************************************************** Structures with smash products In this file, we define a general notion of structure that supports a smash product. If we have a pointed structure (if a set can be equipped with a structure, then we have a point, and structure preserving maps preserve the point), then we can define an equivalence relation on the product that identifies all points for which at least 1 coordinate is the point arising from the structure. For a structure to support smash products, the first requirement is that the quotient with the aforementioned equivalence relation can be equipped with a structure. In addition, we must be able to equip the booleans with the structure, because these will ultimately form the unit of the desired monoidal structure. This leads to the definition `hset_struct_with_smash`, and from that, we construct the smash product and the unit. However, this is not sufficient in general to construct the desired monoidal structure (a counterexample would be topological spaces with a base point), and thus we look at more conditions. The first additional requirement is that we must have function spaces (`hset_struct_with_smash_closed_pointed`). This condition says that we can equip the hom-sets with the structure. In addition, we also require that the currying and uncurrying are structure preserving maps. These conditions are necessary to prove that the anticipated monoidal structure is closed. This is actually still not enough to construct the desired monoidal structure. Our solution is inspired by Construction 4.19 and Lemma 4.20 in https://arxiv.org/pdf/0710.0082.pdf. The idea is to strengthen the requirement further: informally, we could say that aforementioned adjunction must be properly enriched (note that formally stating this, would be circular, because such an enrichment would presuppose that we already constructed the desired monoidal category). The extra requirements state that the maps that witness the isomorphisms between the homsets of the aforementioned adjunction, are themselves structure preserving maps as well. Contents 1. Equivalence relation of smash product 2. Structures with smash products 3. Accessors for structures with smash products 4. Structures with pointed homs 5. Accessors of structures with pointed homs 6. Structures with an pointed hom-adjunction 7. Accessores for structures with an pointed hom-adjunction 8. Closed smash product structures *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Local Open Scope cat. Section SmashProduct. Context (P : hset_cartesian_struct) (Pt : pointed_hset_struct P) {X Y : hSet} (PX : P X) (PY : P Y). Let Px : X := hset_struct_point Pt PX. Let Py : Y := hset_struct_point Pt PY. (** 1. Equivalence relation of smash product *) Definition product_point_coordinate (xy : X × Y) : UU := (pr1 xy = Px) ⨿ (pr2 xy = Py). Definition smash_hrel : hrel (X × Y) := λ xy₁ xy₂, xy₁ = xy₂ ∨ (product_point_coordinate xy₁ × product_point_coordinate xy₂). Proposition iseqrel_smash_hrel : iseqrel smash_hrel. Proof. refine ((_ ,, _) ,, _). - intros x₁ x₂ x₃. use factor_through_squash. { use impred ; intro. apply propproperty. } intros p₁. use factor_through_squash. { apply propproperty. } intros p₂. apply hinhpr. induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ] ; cbn in *. + exact (inl (p₁ @ p₂)). + induction p₁. exact (inr p₂). + induction p₂. exact (inr p₁). + exact (inr (pr1 p₁ ,, pr2 p₂)). - intros xy. exact (hinhpr (inl (idpath _))). - intros xy₁ xy₂. use factor_through_squash. { apply propproperty. } intros p. apply hinhpr. induction p as [ p | p ] ; cbn in *. + exact (inl (!p)). + exact (inr (pr2 p ,, pr1 p)). Qed. Definition smash_eqrel : eqrel (X × Y). Proof. use make_eqrel. - exact smash_hrel. - exact iseqrel_smash_hrel. Defined. Definition map_from_smash {Z : hSet} (h : X → Y → Z) (hp₁ : ∏ (y₁ y₂ : Y), h Px y₁ = h Px y₂) (hp₂ : ∏ (x : X) (y : Y), h x Py = h Px y) (hp₃ : ∏ (x₁ x₂ : X), h x₁ Py = h x₂ Py) : setquot smash_eqrel → Z. Proof. use setquotuniv. - exact (λ xy, h (pr1 xy) (pr2 xy)). - abstract (intros xy₁ xy₂ ; use factor_through_squash ; [ apply setproperty | ] ; intro p ; induction p as [ p | p ] ; [ induction p ; apply idpath | ] ; induction p as [ p₁ p₂ ] ; induction xy₁ as [ x₁ y₁ ] ; induction xy₂ as [ x₂ y₂ ] ; induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ] ; cbn in * ; rewrite p₁, p₂ ; [ apply hp₁ | refine (!_) ; apply hp₂ | apply hp₂ | apply hp₃ ]). Defined. Definition map_from_smash' {Z : UU} (HZ : isaset Z) (h : X → Y → Z) (hp₁ : ∏ (y₁ y₂ : Y), h Px y₁ = h Px y₂) (hp₂ : ∏ (x : X) (y : Y), h x Py = h Px y) (hp₃ : ∏ (x₁ x₂ : X), h x₁ Py = h x₂ Py) : setquot smash_eqrel → Z := @map_from_smash (make_hSet Z HZ) h hp₁ hp₂ hp₃. Definition map_from_smash_pt {Z : hSet} (PZ : P Z) (Pz := hset_struct_point Pt PZ) (h : X → Y → Z) (hp₁ : ∏ (y : Y), h Px y = Pz) (hp₂ : ∏ (x : X), h x Py = Pz) : setquot smash_eqrel → Z. Proof. use map_from_smash. - exact h. - abstract (intros y₁ y₂ ; rewrite !hp₁ ; apply idpath). - abstract (intros x y ; rewrite hp₁, hp₂ ; apply idpath). - abstract (intros x₁ x₂ ; rewrite !hp₂ ; apply idpath). Defined. End SmashProduct. (** 2. Structures with smash products *) Definition pointed_hset_struct_map_from_unit {P : hset_struct} (Pt : pointed_hset_struct P) {Y : hSet} (PY : P Y) (y : Y) (b : bool) : Y := if b then y else hset_struct_point Pt PY. Definition pointed_hset_struct_unit_map {P : hset_struct} (Pt : pointed_hset_struct P) {X Y : hSet} (PY : P Y) (f : X → bool) (g : X → Y) (x : X) : Y := if f x then g x else hset_struct_point Pt PY. Definition hset_struct_with_smash_data (P : hset_cartesian_struct) (Pt : pointed_hset_struct P) : UU := P boolset × (∏ (X Y : hSet) (PX : P X) (PY : P Y), P (setquotinset (smash_eqrel P Pt PX PY))). Definition hset_struct_with_smash_laws {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash_data P Pt) : UU := (hset_struct_point Pt (pr1 SP) = false) × (∏ (X Y : hSet) (PX : P X) (PY : P Y), hset_struct_point Pt (pr2 SP X Y PX PY) = setquotpr _ (hset_struct_point Pt PX ,, hset_struct_point Pt PY)) × (∏ (Y : hSet) (PY : P Y) (y : Y), mor_hset_struct P (pr1 SP) PY (pointed_hset_struct_map_from_unit Pt PY y)) × (∏ (X Y : hSet) (PX : P X) (PY : P Y) (f : X → bool) (Pf : mor_hset_struct P PX (pr1 SP) f) (g : X → Y) (Pg : mor_hset_struct P PX PY g), mor_hset_struct P PX PY (pointed_hset_struct_unit_map Pt PY f g)) × ∏ (X Y : hSet) (PX : P X) (PY : P Y), (∏ (y : Y), mor_hset_struct P PX (pr2 SP X Y PX PY) (λ x, setquotpr (smash_eqrel P Pt PX PY) (x ,, y))) × (∏ (x : X), mor_hset_struct P PY (pr2 SP X Y PX PY) (λ y, setquotpr (smash_eqrel P Pt PX PY) (x ,, y))) × (mor_hset_struct P (hset_struct_prod P PX PY) (pr2 SP X Y PX PY) (setquotpr (smash_eqrel P Pt PX PY))) × (∏ (Z : hSet) (PZ : P Z) (h : X → Y → Z) (Ph : mor_hset_struct P (hset_struct_prod P PX PY) PZ (λ xy, h (pr1 xy) (pr2 xy))) (hp₁ : ∏ (y₁ y₂ : Y), h (hset_struct_point Pt PX) y₁ = h (hset_struct_point Pt PX) y₂) (hp₂ : ∏ (x : X) (y : Y), h x (hset_struct_point Pt PY) = h (hset_struct_point Pt PX) y) (hp₃ : ∏ (x₁ x₂ : X), h x₁ (hset_struct_point Pt PY) = h x₂ (hset_struct_point Pt PY)), mor_hset_struct P (pr2 SP X Y PX PY) PZ (map_from_smash P Pt PX PY h hp₁ hp₂ hp₃)). Definition hset_struct_with_smash (P : hset_cartesian_struct) (Pt : pointed_hset_struct P) : UU := ∑ (SP : hset_struct_with_smash_data P Pt), hset_struct_with_smash_laws SP. (** 3. Accessors for structures with smash products *) Definition make_hset_struct_with_smash {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash_data P Pt) (SPL : hset_struct_with_smash_laws SP) : hset_struct_with_smash P Pt := SP ,, SPL. Definition hset_struct_with_smash_unit {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : P boolset := pr11 SP. Definition hset_struct_with_smash_unit_ob {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : category_of_hset_struct P := _ ,, hset_struct_with_smash_unit SP. Definition hset_struct_with_smash_setquot {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) : P (setquotinset (smash_eqrel P Pt PX PY)) := pr21 SP X Y PX PY. Coercion hset_struct_with_smash_setquot : hset_struct_with_smash >-> Funclass. Definition hset_struct_with_smash_setquot_ob {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) (PX PY : category_of_hset_struct P) : category_of_hset_struct P := _ ,, SP _ _ (pr2 PX) (pr2 PY). Proposition hset_struct_with_smash_point_unit {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : hset_struct_point Pt (hset_struct_with_smash_unit SP) = false. Proof. exact (pr12 SP). Qed. Proposition hset_struct_with_smash_point_smash {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) : hset_struct_point Pt (SP X Y PX PY) = setquotpr _ (hset_struct_point Pt PX ,, hset_struct_point Pt PY). Proof. exact (pr122 SP X Y PX PY). Qed. Proposition hset_struct_with_smash_map_from_unit {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {Y : hSet} (PY : P Y) (y : Y) : mor_hset_struct P (hset_struct_with_smash_unit SP) PY (pointed_hset_struct_map_from_unit Pt PY y). Proof. exact (pr1 (pr222 SP) Y PY y). Qed. Proposition hset_struct_with_smash_map_bool {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} {PX : P X} {PY : P Y} {f : X → bool} (Pf : mor_hset_struct P PX (hset_struct_with_smash_unit SP) f) {g : X → Y} (Pg : mor_hset_struct P PX PY g) : mor_hset_struct P PX PY (pointed_hset_struct_unit_map Pt PY f g). Proof. exact (pr12 (pr222 SP) X Y PX PY f Pf g Pg). Qed. Proposition hset_struct_with_smash_setquotpr_l {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) (y : Y) : mor_hset_struct P PX (SP X Y PX PY) (λ x, setquotpr (smash_eqrel P Pt PX PY) (x ,, y)). Proof. exact (pr1 (pr22 (pr222 SP) X Y PX PY) y). Qed. Proposition hset_struct_with_smash_setquotpr_r {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) (x : X) : mor_hset_struct P PY (SP X Y PX PY) (λ y, setquotpr (smash_eqrel P Pt PX PY) (x ,, y)). Proof. exact (pr12 (pr22 (pr222 SP) X Y PX PY) x). Qed. Proposition hset_struct_with_smash_setquotpr {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) : mor_hset_struct P (hset_struct_prod P PX PY) (SP X Y PX PY) (setquotpr (smash_eqrel P Pt PX PY)). Proof. exact (pr122 (pr22 (pr222 SP) X Y PX PY)). Qed. Proposition hset_struct_with_smash_map_from_smash {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) {Z : hSet} (PZ : P Z) (Pz := hset_struct_point Pt PZ) (h : X → Y → Z) (Ph : mor_hset_struct P (hset_struct_prod P PX PY) PZ (λ xy, h (pr1 xy) (pr2 xy))) (hp₁ : ∏ (y₁ y₂ : Y), h (hset_struct_point Pt PX) y₁ = h (hset_struct_point Pt PX) y₂) (hp₂ : ∏ (x : X) (y : Y), h x (hset_struct_point Pt PY) = h (hset_struct_point Pt PX) y) (hp₃ : ∏ (x₁ x₂ : X), h x₁ (hset_struct_point Pt PY) = h x₂ (hset_struct_point Pt PY)) : mor_hset_struct P (SP X Y PX PY) PZ (map_from_smash P Pt PX PY h hp₁ hp₂ hp₃). Proof. exact (pr222 (pr22 (pr222 SP) X Y PX PY) Z PZ h Ph hp₁ hp₂ hp₃). Qed. Proposition hset_struct_with_smash_map_from_smash' {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {X Y : hSet} (PX : P X) (PY : P Y) {Z : UU} (HZ : isaset Z) (PZ : P (Z ,, HZ)) (Pz := hset_struct_point Pt PZ) (h : X → Y → Z) (Ph : mor_hset_struct P (hset_struct_prod P PX PY) PZ (λ xy, h (pr1 xy) (pr2 xy))) (hp₁ : ∏ (y₁ y₂ : Y), h (hset_struct_point Pt PX) y₁ = h (hset_struct_point Pt PX) y₂) (hp₂ : ∏ (x : X) (y : Y), h x (hset_struct_point Pt PY) = h (hset_struct_point Pt PX) y) (hp₃ : ∏ (x₁ x₂ : X), h x₁ (hset_struct_point Pt PY) = h x₂ (hset_struct_point Pt PY)) : mor_hset_struct P (SP X Y PX PY) PZ (map_from_smash' P Pt PX PY HZ h hp₁ hp₂ hp₃). Proof. exact (pr222 (pr22 (pr222 SP) X Y PX PY) _ PZ h Ph hp₁ hp₂ hp₃). Qed. (** 4. Structures with pointed homs *) Definition hset_struct_with_smash_closed_data {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : UU := ∏ (X Y : hSet) (PX : P X) (PY : P Y), P (@homset (category_of_hset_struct P) (X ,, PX) (Y ,, PY)). Definition hset_struct_with_smash_closed_pointed_laws {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_data SP) : UU := ∏ (X Y : hSet) (PX : P X) (PY : P Y) (x : X), pr1 (hset_struct_point Pt (PC X Y PX PY)) x = hset_struct_point Pt PY. Definition hset_struct_with_smash_closed_pointed {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : UU := ∑ (PC : hset_struct_with_smash_closed_data SP), hset_struct_with_smash_closed_pointed_laws PC. (** 5. Accessors of structures with pointed homs *) Definition hset_struct_with_smash_closed_to_funspace {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_pointed SP) (X Y : category_of_hset_struct P) : category_of_hset_struct P := _ ,, pr1 PC (pr1 X) (pr1 Y) (pr2 X) (pr2 Y). Proposition hset_struct_with_smash_closed_funspace_point {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_pointed SP) {X Y : hSet} (PX : P X) (PY : P Y) (x : X) : pr1 (hset_struct_point Pt (pr1 PC X Y PX PY)) x = hset_struct_point Pt PY. Proof. exact (pr2 PC X Y PX PY x). Qed. (** 6. Structures with an pointed hom-adjunction *) Definition hset_struct_smash_curry_fun {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_pointed SP) {PX PY PZ : category_of_hset_struct P} (f : PX --> hset_struct_with_smash_closed_to_funspace PC PY PZ) : setquot (smash_hrel P Pt (pr2 PX) (pr2 PY)) → pr11 PZ. Proof. use map_from_smash. - exact (λ x y, pr1 (pr1 f x) y). - abstract (intros y₁ y₂ ; cbn ; rewrite !(pointed_hset_struct_preserve_point Pt (pr2 f)) ; refine (pr2 PC _ _ _ _ _ @ !_) ; exact (pr2 PC _ _ _ _ _)). - abstract (intros x y ; cbn ; rewrite !(pointed_hset_struct_preserve_point Pt (pr2 f)) ; refine (_ @ !(pr2 PC _ _ _ _ _)) ; exact (pointed_hset_struct_preserve_point Pt (pr2 (pr1 f x)))). - abstract (intros x₁ x₂ ; cbn ; refine (pointed_hset_struct_preserve_point Pt (pr2 (pr1 f x₁)) @ !_) ; refine (pointed_hset_struct_preserve_point Pt (pr2 (pr1 f x₂)))). Defined. Definition hset_struct_smash_uncurry_fun {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) {PX PY PZ : category_of_hset_struct P} (g : hset_struct_with_smash_setquot_ob SP PX PY --> PZ) (x : pr11 PX) : PY --> PZ. Proof. simple refine (_ ,, _). - exact (λ y, pr1 g (setquotpr _ (x ,, y))). - abstract (use (hset_struct_comp P _ (pr2 g)) ; apply hset_struct_with_smash_setquotpr_r). Defined. Definition hset_struct_smash_eval_fun {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_pointed SP) {X Y : hSet} (PX : P X) (PY : P Y) : setquot (smash_eqrel P Pt (pr1 PC X Y PX PY) PX) → Y. Proof. exact (hset_struct_smash_curry_fun PC (identity _)). Defined. Definition hset_struct_with_smash_closed_adj_laws {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_pointed SP) : UU := (∏ (PX PY PZ : category_of_hset_struct P) (f : PX --> hset_struct_with_smash_closed_to_funspace PC PY PZ), mor_hset_struct P (pr2 (hset_struct_with_smash_setquot_ob SP PX PY)) (pr2 PZ) (hset_struct_smash_curry_fun PC f)) × (∏ (PX PY PZ : category_of_hset_struct P) (f : hset_struct_with_smash_setquot_ob SP PX PY --> PZ), mor_hset_struct P (pr2 PX) (pr1 PC _ _ (pr2 PY) (pr2 PZ)) (hset_struct_smash_uncurry_fun SP f)). Definition hset_struct_with_smash_closed_adj {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} (SP : hset_struct_with_smash P Pt) : UU := ∑ (PC : hset_struct_with_smash_closed_pointed SP), hset_struct_with_smash_closed_adj_laws PC. (** 7. Accessores for structures with an pointed hom-adjunction *) Coercion hset_struct_with_smash_closed_to_point {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) : hset_struct_with_smash_closed_pointed SP := pr1 PC. Definition hset_struct_with_smash_closed_adj_to_hom {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) (X Y : hSet) (PX : P X) (PY : P Y) : P (@homset (category_of_hset_struct P) (X ,, PX) (Y ,, PY)) := pr11 PC X Y PX PY. Coercion hset_struct_with_smash_closed_adj_to_hom : hset_struct_with_smash_closed_adj >-> Funclass. Definition hset_struct_smash_curry {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) {PX PY PZ : category_of_hset_struct P} (f : PX --> hset_struct_with_smash_closed_to_funspace PC PY PZ) : hset_struct_with_smash_setquot_ob SP PX PY --> PZ := hset_struct_smash_curry_fun (pr1 PC) f ,, pr12 PC PX PY PZ f. Definition hset_struct_smash_uncurry {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) {PX PY PZ : category_of_hset_struct P} (g : hset_struct_with_smash_setquot_ob SP PX PY --> PZ) : PX --> hset_struct_with_smash_closed_to_funspace PC PY PZ := hset_struct_smash_uncurry_fun SP g ,, pr22 PC PX PY PZ g. Definition hset_struct_with_smash_closed_smash_eval {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) (X Y : category_of_hset_struct P) : hset_struct_with_smash_setquot_ob SP (hset_struct_with_smash_closed_to_funspace PC X Y) X --> Y := hset_struct_smash_curry PC (identity _). (** 8. Closed smash product structures *) Definition hset_struct_with_smash_closed_laws_enrich {P : hset_cartesian_struct} {Pt : pointed_hset_struct P} {SP : hset_struct_with_smash P Pt} (PC : hset_struct_with_smash_closed_adj SP) : UU := (∏ (PX PY PZ : category_of_hset_struct P), mor_hset_struct P (pr2 (hset_struct_with_smash_closed_to_funspace PC PX (hset_struct_with_smash_closed_to_funspace PC PZ PY))) (pr2 (hset_struct_with_smash_closed_to_funspace PC (hset_struct_with_smash_setquot_ob SP PX PZ) PY)) (hset_struct_smash_curry PC)) × (∏ (PX PY PZ : category_of_hset_struct P), mor_hset_struct P (pr2 (hset_struct_with_smash_closed_to_funspace PC (hset_struct_with_smash_setquot_ob SP PX PZ) PY)) (pr2 (hset_struct_with_smash_closed_to_funspace PC PX (hset_struct_with_smash_closed_to_funspace PC PZ PY))) (hset_struct_smash_uncurry PC)). Definition hset_struct_with_smash_closed : UU := ∑ (P : hset_cartesian_struct) (Pt : pointed_hset_struct P) (SP : hset_struct_with_smash P Pt) (PC : hset_struct_with_smash_closed_adj SP), hset_struct_with_smash_closed_laws_enrich PC. Coercion hset_struct_with_smash_closed_to_struct (PC : hset_struct_with_smash_closed) : hset_cartesian_struct := pr1 PC. Coercion hset_struct_with_smash_closed_point (PC : hset_struct_with_smash_closed) : pointed_hset_struct PC := pr12 PC. Definition hset_struct_with_smash_closed_unit (PC : hset_struct_with_smash_closed) : category_of_hset_struct PC := hset_struct_with_smash_unit_ob (pr122 PC). Definition hset_struct_with_smash_closed_smash {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) : category_of_hset_struct PC := hset_struct_with_smash_setquot_ob (pr122 PC) PX PY. Notation "PX ∧* PY" := (hset_struct_with_smash_closed_smash PX PY) (at level 30, right associativity) : cat. Proposition hset_struct_with_smash_closed_point_unit (PC : hset_struct_with_smash_closed) : hset_struct_point PC (pr2 (hset_struct_with_smash_closed_unit PC)) = false. Proof. exact (hset_struct_with_smash_point_unit (pr122 PC)). Qed. Proposition hset_struct_with_smash_closed_point_smash {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) : hset_struct_point PC (pr2 (PX ∧* PY)) = setquotpr _ (hset_struct_point PC (pr2 PX) ,, hset_struct_point PC (pr2 PY)). Proof. exact (hset_struct_with_smash_point_smash (pr122 PC) (pr2 PX) (pr2 PY)). Qed. Definition hset_struct_with_smash_closed_map_bool {PC : hset_struct_with_smash_closed} {PX PY : category_of_hset_struct PC} (f : PX --> hset_struct_with_smash_closed_unit PC) (g : PX --> PY) : PX --> PY := _ ,, hset_struct_with_smash_map_bool (pr122 PC) (pr2 f) (pr2 g). Definition hset_struct_with_smash_closed_setquotpr_l {PC : hset_struct_with_smash_closed} {PX PY : category_of_hset_struct PC} (y : pr11 PY) : PX --> PX ∧* PY := _ ,, hset_struct_with_smash_setquotpr_l (pr122 PC) _ _ y. Definition hset_struct_with_smash_closed_setquotpr_r {PC : hset_struct_with_smash_closed} {PX PY : category_of_hset_struct PC} (x : pr11 PX) : PY --> PX ∧* PY := _ ,, hset_struct_with_smash_setquotpr_r (pr122 PC) _ _ x. Definition hset_struct_with_smash_closed_setquotpr {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) : hset_struct_prod_ob PX PY --> PX ∧* PY := _ ,, hset_struct_with_smash_setquotpr (pr122 PC) (pr2 PX) (pr2 PY). Definition hset_struct_with_smash_closed_to_funspace_ob {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) : category_of_hset_struct PC := hset_struct_with_smash_closed_to_funspace (pr1 (pr222 PC)) PX PY. Notation "PX -->* PY" := (hset_struct_with_smash_closed_to_funspace_ob PX PY) (at level 20, right associativity) : cat. Proposition hset_struct_with_smash_closed_fun_point {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) (x : pr11 PX) : pr1 (hset_struct_point PC (pr2 (PX -->* PY))) x = hset_struct_point PC (pr2 PY). Proof. apply hset_struct_with_smash_closed_funspace_point. Qed. Definition hset_struct_smash_closed_curry {PC : hset_struct_with_smash_closed} {PX PY PZ : category_of_hset_struct PC} (f : PX --> PY -->* PZ) : (PX ∧* PY) --> PZ := hset_struct_smash_curry (pr1 (pr222 PC)) f. Definition hset_struct_smash_closed_uncurry {PC : hset_struct_with_smash_closed} {PX PY PZ : category_of_hset_struct PC} (g : (PX ∧* PY) --> PZ) : PX --> PY -->* PZ := hset_struct_smash_uncurry (pr1 (pr222 PC)) g. Definition hset_struct_with_smash_closed_eval {PC : hset_struct_with_smash_closed} (PX PY : category_of_hset_struct PC) : (PX -->* PY) ∧* PX --> PY := hset_struct_with_smash_closed_smash_eval (pr1 (pr222 PC)) PX PY. Definition hset_struct_smash_enriched_curry {PC : hset_struct_with_smash_closed} (PX PY PZ : category_of_hset_struct PC) : (PX -->* PY -->* PZ) --> ((PX ∧* PY) -->* PZ) := _ ,, pr12 (pr222 PC) PX PZ PY. Definition hset_struct_smash_enriched_uncurry {PC : hset_struct_with_smash_closed} (PX PY PZ : category_of_hset_struct PC) : ((PX ∧* PY) -->* PZ) --> (PX -->* PY -->* PZ) := _ ,, pr22 (pr222 PC) PX PZ PY. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Total.v000066400000000000000000000367361451125700300236460ustar00rootroot00000000000000 (** * Total Categories and Total Functors *) Require Import UniMath.Foundations.Sets. (* Needed for pr1_issurjective *) Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Local Open Scope mor_disp. (** ** Definition and forgetful functor *) (* Any displayed category has a total category, with a forgetful functor to the base category. *) Section Total_Category. Section Total_Category_data. Context {C : precategory_data} (D : disp_cat_data C). Definition total_category_ob_mor : precategory_ob_mor. Proof. exists (∑ x:C, D x). intros xx yy. (* note: we use projections rather than destructing, so that [ xx --> yy ] can β-reduce without [xx] and [yy] needing to be in whnf *) exact (∑ (f : pr1 xx --> pr1 yy), pr2 xx -->[f] pr2 yy). Defined. Definition total_category_id_comp : precategory_id_comp (total_category_ob_mor). Proof. apply tpair; simpl. - intros. exists (identity _). apply id_disp. - intros xx yy zz ff gg. exists (pr1 ff · pr1 gg). exact (pr2 ff ;; pr2 gg). Defined. Definition total_category_data : precategory_data := (total_category_ob_mor ,, total_category_id_comp). End Total_Category_data. (* TODO: make notations [( ,, )] and [ ;; ] different levels? ;; should bind tighter, perhaps, and ,, looser? *) Lemma total_category_is_precat {C : category} (D : disp_cat C) : is_precategory (total_category_data D). Proof. apply is_precategory_one_assoc_to_two. repeat apply tpair; simpl. - intros xx yy ff; cbn. use total2_paths_f; simpl. apply id_left. eapply pathscomp0. apply maponpaths, id_left_disp. apply transportfbinv. - intros xx yy ff; cbn. use total2_paths_f; simpl. apply id_right. eapply pathscomp0. apply maponpaths, id_right_disp. apply transportfbinv. - intros xx yy zz ww ff gg hh. use total2_paths_f; simpl. apply assoc. eapply pathscomp0. apply maponpaths, assoc_disp. apply transportfbinv. Qed. (* The “pre-category” version, without homsets *) Definition total_precategory {C : category} (D : disp_cat C) : precategory := (total_category_data D ,, total_category_is_precat D). Lemma total_category_has_homsets {C : category} (D : disp_cat C) : has_homsets (total_category_data D). Proof. intros ? ?; simpl. apply isaset_total2. apply homset_property. intros; apply homsets_disp. Qed. Definition total_category {C : category} (D : disp_cat C) : category := (total_precategory D,, total_category_has_homsets D). Definition pr1_category_data {C : category} (D : disp_cat C) : functor_data (total_category D) C. Proof. exists pr1. intros a b; exact pr1. Defined. Lemma pr1_category_is_functor {C : category} (D : disp_cat C) : is_functor (pr1_category_data D). Proof. apply tpair. - intros x; apply idpath. - intros x y z f g; apply idpath. Qed. Definition pr1_category {C : category} (D : disp_cat C) : functor (total_category D) C := make_functor (pr1_category_data D) (pr1_category_is_functor D). Lemma full_pr1_category {C : category} (D : disp_cat C) (H : ∏ (a b : total_category D) (x : C ⟦ pr1 a, pr1 b ⟧), (∥ pr2 a -->[ x] pr2 b ∥)) : full (pr1_category D). Proof. intros ? ?. use pr1_issurjective. apply H. Defined. Lemma faithful_pr1_category {C : category} (D : disp_cat C) (H : ∏ (a b : total_precategory D) (x : C ⟦ pr1 a, pr1 b ⟧), isaprop (pr2 a -->[ x] pr2 b)) : faithful (pr1_category D). Proof. intros ? ?. apply isinclpr1, H. Defined. Definition fully_faithful_pr1_category {C : category} (D : disp_cat C) (H : ∏ (a b : total_precategory D) (x : C ⟦ pr1 a, pr1 b ⟧), iscontr (pr2 a -->[ x] pr2 b)) : fully_faithful (pr1_category D). Proof. intros ? ?. apply isweqpr1, H. Defined. (** ** Isomorphisms and saturation *) Definition is_z_iso_total {C : category} {D : disp_cat C} {xx yy : total_category D} (ff : xx --> yy) (i : is_z_isomorphism (pr1 ff)) (fi := pr1 ff,, i) (ii : is_z_iso_disp fi (pr2 ff)) : is_z_isomorphism ff. Proof. exists (inv_from_z_iso fi,, pr1 ii). abstract ( refine (total2_paths_f _ _ ,, total2_paths_f _ _); [ exact (maponpaths _ (inv_mor_after_z_iso_disp ii) @ transportfbinv _ _ _) | exact (maponpaths _ (z_iso_disp_after_inv_mor ii) @ transportfbinv _ _ _) ] ). Defined. Definition inv_from_z_iso_in_total {C : category} {D : disp_cat C} {x y : C} {f : x --> y} (Hf : is_z_isomorphism f) {xx : D x} {yy : D y} {ff : xx -->[ f ] yy} (Hff : is_z_iso_disp (f ,, Hf) ff) : pr1 (inv_from_z_iso (make_z_iso' _ (@is_z_iso_total C D (x ,, xx) (y ,, yy) (f ,, ff) Hf Hff))) = inv_from_z_iso (_,,Hf). Proof. apply inv_z_iso_unique'. unfold precomp_with ; cbn. exact (maponpaths pr1 (z_iso_inv_after_z_iso (make_z_iso' _ (@is_z_iso_total C D (x ,, xx) (y ,, yy) (f ,, ff) Hf Hff)))). Qed. Definition is_z_iso_base_from_total {C : category} {D : disp_cat C} {xx yy : total_category D} {ff : xx --> yy} (i : is_z_isomorphism ff) : is_z_isomorphism (pr1 ff). Proof. set (ffi := ff ,, i). exists (pr1 (inv_from_z_iso ffi)). split. - exact (maponpaths pr1 (z_iso_inv_after_z_iso ffi)). - exact (maponpaths pr1 (z_iso_after_z_iso_inv ffi)). Qed. Definition z_iso_base_from_total {C : category} {D : disp_cat C} {xx yy : total_category D} (ffi : z_iso xx yy) : z_iso (pr1 xx) (pr1 yy) := _ ,, (is_z_iso_base_from_total (pr2 ffi)). Definition inv_z_iso_base_from_total {C : category} {D : disp_cat C} {xx yy : total_precategory D} (ffi : z_iso xx yy) : inv_from_z_iso (z_iso_base_from_total ffi) = pr1 (inv_from_z_iso ffi). Proof. apply pathsinv0, inv_z_iso_unique'. unfold precomp_with. exact (maponpaths pr1 (z_iso_inv_after_z_iso ffi)). Qed. Definition is_z_iso_disp_from_total {C : category} {D : disp_cat C} {xx yy : total_precategory D} {ff : xx --> yy} (i : is_z_isomorphism ff) (ffi := ff ,, i) : is_z_iso_disp (z_iso_base_from_total (ff,,i)) (pr2 ff). Proof. use tpair; [ | split]. - eapply transportb. apply inv_z_iso_base_from_total. exact (pr2 (inv_from_z_iso ffi)). - etrans. apply mor_disp_transportf_postwhisker. etrans. apply maponpaths, @pathsinv0. exact (fiber_paths (!z_iso_after_z_iso_inv ffi)). etrans. apply transport_f_f. use (toforallpaths _ _ _ _ (id_disp _)). unfold transportb; apply maponpaths, homset_property. - etrans. apply mor_disp_transportf_prewhisker. etrans. apply maponpaths, @pathsinv0. exact (fiber_paths (!z_iso_inv_after_z_iso ffi)). etrans. apply transport_f_f. use (toforallpaths _ _ _ _ (id_disp _)). unfold transportb; apply maponpaths, homset_property. Qed. Definition z_iso_disp_from_total {C : category} {D : disp_cat C} {xx yy : total_precategory D} (ff : z_iso xx yy) : z_iso_disp (z_iso_base_from_total ff) (pr2 xx) (pr2 yy). Proof. exact (_,, is_z_iso_disp_from_total (pr2 ff)). Defined. Definition total_z_iso {C : category} {D : disp_cat C} {xx yy : total_category D} (f : z_iso (pr1 xx) (pr1 yy)) (ff : z_iso_disp f (pr2 xx) (pr2 yy)) : z_iso xx yy. Proof. exists (pr1 f,, pr1 ff). apply (is_z_iso_total (pr1 f,, pr1 ff) (pr2 f) (pr2 ff)). Defined. Lemma inv_mor_total_z_iso {C : category} {D : disp_cat C} {xx yy : total_category D} (f : z_iso (pr1 xx) (pr1 yy)) (ff : z_iso_disp f (pr2 xx) (pr2 yy)) : inv_from_z_iso (total_z_iso f ff) = (inv_from_z_iso f,, inv_mor_disp_from_z_iso ff). Proof. (* Could de-opacify [is_z_iso_total] and then use [inv_from_z_iso_]. If de-opacfying [is_z_iso_total] would make its inverse compute definitionally, that’d be wonderful, but for the sake of just this one lemma, it’s probably not worth it. So we prove this the hard way. *) apply cancel_precomposition_z_iso with (total_z_iso f ff). etrans. apply z_iso_inv_after_z_iso. apply pathsinv0. use total2_paths_f; cbn. - apply z_iso_inv_after_z_iso. - etrans. apply maponpaths, inv_mor_after_z_iso_disp. apply transportfbinv. Qed. Definition total_z_iso_equiv_map {C : category} {D : disp_cat C} {xx yy : total_category D} : (∑ f : z_iso (pr1 xx) (pr1 yy), z_iso_disp f (pr2 xx) (pr2 yy)) -> z_iso xx yy := λ ff, total_z_iso (pr1 ff) (pr2 ff). Definition total_isweq_z_iso {C : category} {D : disp_cat C} (xx yy : total_category D) : isweq (@total_z_iso_equiv_map _ _ xx yy). Proof. use isweq_iso. - intros ff. exists (z_iso_base_from_total ff). apply z_iso_disp_from_total. - intros [f ff]. use total2_paths_f. + apply z_iso_eq, idpath. + apply eq_z_iso_disp. etrans. apply transportf_z_iso_disp. simpl pr2. simpl (pr1 (z_iso_disp_from_total _)). use (@maponpaths_2 _ _ _ (transportf _) _ (idpath _)). apply homset_property. - intros f. apply z_iso_eq; simpl. destruct f as [[f ff] w]; apply idpath. Qed. Definition total_z_iso_equiv {C : category} {D : disp_cat C} (xx yy : total_category D) : (∑ f : z_iso (pr1 xx) (pr1 yy), z_iso_disp f (pr2 xx) (pr2 yy)) ≃ z_iso xx yy := make_weq _ (total_isweq_z_iso xx yy). Lemma is_univalent_total_category {C : category} {D : disp_cat C} (CC : is_univalent C) (DD : is_univalent_disp D) : is_univalent (total_category D). Proof. intros xs ys. set (x := pr1 xs). set (xx := pr2 xs). set (y := pr1 ys). set (yy := pr2 ys). use weqhomot. apply (@weqcomp _ (∑ e : x = y, transportf _ e xx = yy) _). apply total2_paths_equiv. apply (@weqcomp _ (∑ e : x = y, z_iso_disp (idtoiso e) xx yy) _). apply weqfibtototal. intros e. exists (λ ee, idtoiso_disp e ee). apply DD. apply (@weqcomp _ (∑ f : z_iso x y, z_iso_disp f xx yy) _). use (weqfp (make_weq _ _)). apply CC. apply total_z_iso_equiv. intros e; destruct e; apply z_iso_eq; cbn. apply idpath. Qed. End Total_Category. Arguments pr1_category [C] D. Section TotalUnivalent. Definition total_univalent_category {C : univalent_category} (D : disp_univalent_category C) : univalent_category. Proof. use make_univalent_category. - exact (total_category D). - exact (is_univalent_total_category (pr2 C) (pr2 D)). Defined. End TotalUnivalent. (** ** Total functors of displayed functors*) Section Total_Functors. Definition total_functor_data {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) : functor_data (total_category D') (total_category D). Proof. use make_functor_data. - intros xx. exists (F (pr1 xx)). exact (FF _ (pr2 xx)). - intros xx yy ff. exists (# F (pr1 ff))%cat. exact (♯ FF (pr2 ff)). Defined. Definition total_functor_axioms {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) : is_functor (total_functor_data FF). Proof. split. - intros xx; use total2_paths_f. apply functor_id. etrans. apply maponpaths, disp_functor_id. apply transportfbinv. - intros xx yy zz ff gg; use total2_paths_f; simpl. apply functor_comp. etrans. apply maponpaths, disp_functor_comp. apply transportfbinv. Qed. Definition total_functor {C' C} {F} {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D) : functor (total_category D') (total_category D) := (total_functor_data FF,, total_functor_axioms FF). (** Laws for total fucntors *) Definition total_functor_commute {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : pr1_category D₁ ∙ F ⟹ total_functor FF ∙ pr1_category D₂. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros ? ? ? ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition total_functor_commute_z_iso {C₁ C₂ : category} {F : C₁ ⟶ C₂} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} (FF : disp_functor F D₁ D₂) : nat_z_iso (pr1_category D₁ ∙ F) (total_functor FF ∙ pr1_category D₂). Proof. use make_nat_z_iso. * exact (total_functor_commute FF). * intro. apply identity_is_z_iso. Defined. Definition total_functor_identity {C : category} (D : disp_cat C) : functor_identity (total_category D) ⟹ total_functor (disp_functor_identity D). Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros ? ? ? ; simpl ; refine (@id_right (total_category _) _ _ _ @ _) ; exact (!(@id_left (total_category _) _ _ _))). Defined. Definition total_functor_comp {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {D₃ : disp_cat C₃} (FF : disp_functor F D₁ D₂) (GG : disp_functor G D₂ D₃) : total_functor FF ∙ total_functor GG ⟹ total_functor (disp_functor_composite FF GG). Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; refine (@id_right (total_category _) _ _ _ @ _) ; exact (!(@id_left (total_category _) _ _ _))). Defined. End Total_Functors. Section Total_Nat_Trans. (** Total natural transformation *) Definition total_nat_trans {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {τ : F ⟹ G} {D₁ : disp_cat C₁} {D₂ : disp_cat C₂} {FF : disp_functor F D₁ D₂} {GG : disp_functor G D₁ D₂} (ττ : disp_nat_trans τ FF GG) : nat_trans (total_functor FF) (total_functor GG). Proof. use make_nat_trans. - exact (λ x, τ (pr1 x) ,, ττ (pr1 x) (pr2 x)). - abstract (intros x y f ; cbn ; use total2_paths_b ; [ exact (nat_trans_ax τ _ _ (pr1 f)) | exact (disp_nat_trans_ax ττ (pr2 f))]). Defined. End Total_Nat_Trans. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/TotalAdjunction.v000066400000000000000000000441421451125700300256530ustar00rootroot00000000000000(* In this file, we show how any displayed adjunction (resp. equivalence) induces an adjunction (resp. equivalence) between the corresponding total categories. Created by Kobe Wullaert at 06/12/2022. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions. Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope mor_disp_scope. Local Open Scope type_scope. Local Open Scope cat. Section TotalFunctorCompositeIdentity. Definition total_functor_identity_inv {C : category} (D : disp_cat C) : nat_trans (total_functor (disp_functor_identity D)) (functor_identity (total_category D)). Proof. apply nat_trans_id. Defined. Context {C1 C2 C3 : category} {F : functor C1 C2} {G : functor C2 C3} {D1 : disp_cat C1} {D2 : disp_cat C2} {D3 : disp_cat C3} (FF : disp_functor F D1 D2) (GG : disp_functor G D2 D3). Definition total_functor_comp_inv : nat_trans (total_functor (disp_functor_composite FF GG)) (total_functor FF ∙ total_functor GG). Proof. apply nat_trans_id. Defined. End TotalFunctorCompositeIdentity. Section TotalAdjunction. Context {C1 C2 : category} {F : adjunction C1 C2}. Let L := left_functor F. Let R := right_functor F. Let η := adjunit F. Let ε := adjcounit F. Context {D1 : disp_cat C1} {D2 : disp_cat C2} (FF : disp_adjunction F D1 D2). Let LL := left_adj_over FF. Let RR := right_adj_over FF. Let ηη := unit_over FF. Let εε := counit_over FF. Definition total_adjunction_data : adjunction_data (total_category D1) (total_category D2). Proof. use make_adjunction_data. - exact (total_functor LL). - exact (total_functor RR). - use (nat_trans_comp _ _ _ (total_functor_identity D1)). use (nat_trans_comp _ _ _ _ (total_functor_comp_inv _ _)). use total_nat_trans. + exact η. + exact ηη. - use (nat_trans_comp _ _ _ (total_functor_comp _ _)). use (nat_trans_comp _ _ _ _ (total_functor_identity_inv _)). use total_nat_trans. + exact ε. + exact εε. Defined. Definition total_adjunction_triangle1 : triangle_1_statement total_adjunction_data. Proof. intro x. use total2_paths_b. - cbn. etrans. { apply maponpaths. etrans. { apply id_left. } apply id_right. } etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply id_left. } apply id_right. } exact (triangle_1_statement_from_adjunction F (pr1 x)). - cbn. set (t := triangle_1_over FF (pr1 x) (pr2 x)). unfold triangle_1_statement_over in t. cbn in t. set (a1_goal := (id_disp (pr2 x) ;; (ηη (pr1 x) (pr2 x) ;; id_disp (RR (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)))))). set (a1_t := (unit_over FF (pr1 x) (pr2 x))). assert (p : a1_goal = transportb _ (id_left (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x)))) @ id_right (η (pr1 x))) a1_t). { unfold a1_goal. rewrite id_right_disp. rewrite id_left_disp. now rewrite transport_b_b. } etrans. { apply maponpaths_2, maponpaths. exact p. } clear p. set (a2_t := counit_over FF (left_functor F (pr1 x)) (left_adj_over FF (pr1 x) (pr2 x))). set (a2_goal := (id_disp (LL (right_functor F (left_functor F (pr1 x))) (RR (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)))) ;; (εε (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)) ;; id_disp (LL (pr1 x) (pr2 x))))). assert (p : a2_goal = transportb _ (id_left (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x))) @ id_right (ε (left_functor F (pr1 x)))) a2_t). { unfold a2_goal. rewrite id_right_disp. rewrite id_left_disp. now rewrite transport_b_b. } etrans. { apply maponpaths. exact p. } clear p. assert (q : (# (left_functor F)) (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x))))) · (identity (left_functor F (right_functor F (left_functor F (pr1 x)))) · (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x)))) = (# (left_functor F)) (adjunit F (pr1 x)) · adjcounit F (left_functor F (pr1 x))). { rewrite ! id_left. now rewrite ! id_right. } use pathscomp0. { exact (transportb _ q (♯ (left_adj_over FF) (unit_over FF (pr1 x) (pr2 x)) ;; counit_over FF (left_functor F (pr1 x)) (left_adj_over FF (pr1 x) (pr2 x)))). } + cbn. etrans. { apply mor_disp_transportf_prewhisker. } assert (hh : (# (left_functor F)) (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x))))) · ε (left_functor F (pr1 x)) = (# (left_functor F))%Cat (adjunit F (pr1 x)) · adjcounit F (left_functor F (pr1 x))). { apply maponpaths_2. apply maponpaths. refine (id_left _ @ _). apply id_right. } assert (h : (maponpaths (compose ((# (left_functor F)) (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x))))))) (! (id_left (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x))) @ id_right (ε (left_functor F (pr1 x)))))) = hh @ ! q). { apply homset_property. } etrans. { apply maponpaths_2. exact h. } unfold a2_t. unfold transportb. use transportf_transpose_left. unfold transportb. rewrite transport_f_f. do 2 rewrite pathscomp_inv. rewrite path_assoc. rewrite pathsinv0r. simpl. rewrite disp_functor_transportf. use transportf_transpose_right. unfold transportb. unfold a1_t. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use transportf_set. apply homset_property. + cbn. etrans. { apply maponpaths. exact t. } unfold transportb. rewrite transport_f_f. use transportf_paths. apply homset_property. Qed. Definition total_adjunction_triangle2 : triangle_2_statement total_adjunction_data. Proof. intro x. use total2_paths_b. - cbn. etrans. { do 2 apply maponpaths. etrans. { apply id_left. } apply id_right. } etrans. { apply maponpaths_2. etrans. { apply id_left. } apply id_right. } exact (triangle_2_statement_from_adjunction F (pr1 x)). - cbn. set (t := triangle_2_over FF (pr1 x) (pr2 x)). unfold triangle_2_statement_over in t. cbn in t. set (q := (id_left (ε (pr1 x) · identity (pr1 x)) @ id_right (ε (pr1 x)))). assert (p : (id_disp (LL (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x))) ;; (εε (pr1 x) (pr2 x) ;; id_disp (pr2 x))) = transportb _ q (counit_over FF (pr1 x) (pr2 x))). { rewrite id_right_disp. rewrite id_left_disp. now rewrite transport_b_b. } etrans. { do 2 apply maponpaths. exact p. } clear p. unfold q. clear q. assert (p : identity (right_functor F (pr1 x)) · (η (right_functor F (pr1 x)) · identity (right_functor F (left_functor F (right_functor F (pr1 x))))) · (# (right_functor F))%Cat (identity (left_functor F (right_functor F (pr1 x))) · (ε (pr1 x) · identity (pr1 x))) = unit_from_are_adjoints F (right_functor F (pr1 x)) · (# (right_functor F))%Cat (counit_from_are_adjoints F (pr1 x))). { rewrite ! id_left. now rewrite ! id_right. } use pathscomp0. { exact (transportb _ p (transportb (mor_disp (right_adj_over FF (pr1 x) (pr2 x)) (right_adj_over FF (pr1 x) (pr2 x))) (triangle_id_right_ad F (pr1 x)) (id_disp (right_adj_over FF (pr1 x) (pr2 x))))). } 2: { cbn. rewrite transport_b_b. apply maponpaths_2. apply homset_property. } cbn. rewrite transport_b_b. unfold transportb. rewrite disp_functor_transportf. rewrite mor_disp_transportf_prewhisker. use transportf_transpose_left. unfold transportb. rewrite transport_f_f. assert (qq : identity (right_functor F (pr1 x)) · (adjunit F (right_functor F (pr1 x)) · identity (right_functor F (left_functor F (right_functor F (pr1 x))))) · (# (right_functor F))%Cat (adjcounit F (pr1 x)) = adjunit F (right_functor F (pr1 x)) · (# (right_functor F))%Cat (adjcounit F (pr1 x))). { rewrite ! id_left. now rewrite ! id_right. } assert (q : id_disp (RR (pr1 x) (pr2 x)) ;; (ηη (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x)) ;; id_disp (RR (left_functor F (right_functor F (pr1 x))) (LL (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x))))) ;; ♯ RR (counit_over FF (pr1 x) (pr2 x)) = transportb _ qq ( unit_over FF (right_functor F (pr1 x)) (right_adj_over FF (pr1 x) (pr2 x)) ;; ♯ (right_adj_over FF) (counit_over FF (pr1 x) (pr2 x)))). { rewrite id_left_disp. rewrite id_right_disp. rewrite transport_b_b. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply maponpaths_2. apply homset_property. } refine (q @ _). etrans. { apply maponpaths. exact t. } rewrite transport_b_b. unfold transportb. use maponpaths_2. apply homset_property. Qed. Definition total_adjunction : adjunction (total_category D1) (total_category D2). Proof. use make_adjunction. - exact total_adjunction_data. - split. + apply total_adjunction_triangle1. + apply total_adjunction_triangle2. Defined. End TotalAdjunction. Section TotalEquivalence. Context {C1 C2 : category} {F : adj_equiv C1 C2}. Let L := left_functor F. Let R := right_functor F. Let η := adjunit F. Let ε := adjcounit F. Context {D1 : disp_cat C1} {D2 : disp_cat C2} (FF : equiv_over F D1 D2). Let LL := left_adj_over FF. Let RR := right_adj_over FF. Let ηη := unit_over FF. Let εε := counit_over FF. Definition total_adjunction_forms_equivalence1_base : ∏ x : total_category D1, is_z_isomorphism (pr1 (adjunit (total_adjunction FF) x)). Proof. intro x. use is_z_iso_comp_of_is_z_isos. - apply Isos.identity_is_z_iso. - use Isos.is_z_iso_comp_of_is_z_isos. + apply (adj_equiv_of_cats_from_adj F). + apply Isos.identity_is_z_iso. Defined. Definition total_adjunction_forms_equivalence1_disp_inv : ∏ x : total_category D1, RR (F (pr1 x)) (LL (pr1 x) (pr2 x)) -->[identity (R (F (pr1 x))) · is_z_isomorphism_mor ((pr122 F) (pr1 x)) · identity (pr1 x)] pr2 x. Proof. intro x. set (f := pr1 (pr12 FF (pr1 x) (pr2 x))). assert (p : identity (right_adjoint F (F (pr1 x))) · Isos.is_z_isomorphism_mor ((pr122 F) (pr1 x)) · identity (pr1 x) = Isos.is_z_isomorphism_mor ((pr122 F) (pr1 x))). { rewrite id_left. now apply id_right. } exact (transportf (mor_disp _ _) (! p) f). Defined. Lemma total_adjunction_forms_equivalence1_disp_inv_is_inv : ∏ x : total_category D1, is_disp_inverse (z_iso_is_inverse_in_precat (pr1 (adjunit (total_adjunction FF) x),, total_adjunction_forms_equivalence1_base x)) (pr2 (adjunit (total_adjunction FF) x)) (total_adjunction_forms_equivalence1_disp_inv x). Proof. unfold total_adjunction_forms_equivalence1_base. unfold total_adjunction_forms_equivalence1_disp_inv. split. - cbn. use transportf_transpose_right. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. cbn. set (ff := pr12 (pr12 FF (pr1 x) (pr2 x))). cbn in ff. set (fff := transportf_transpose_left ff). refine (_ @ fff). use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. rewrite id_left_disp. rewrite transport_b_b. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. use transportf_set. apply homset_property. - cbn. use transportf_transpose_right. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. cbn. set (ff := pr22 (pr12 FF (pr1 x) (pr2 x))). cbn in ff. set (fff := transportf_transpose_left ff). refine (_ @ fff). use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. rewrite id_left_disp. rewrite transport_b_b. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use transportf_set. apply homset_property. Qed. Definition total_adjunction_forms_equivalence1 : ∏ a : total_category D1, Isos.is_z_isomorphism (adjunit (total_adjunction FF) a). Proof. intro x. use is_z_iso_total. - exact (total_adjunction_forms_equivalence1_base x). - exists (total_adjunction_forms_equivalence1_disp_inv x). exact (total_adjunction_forms_equivalence1_disp_inv_is_inv x). Defined. Definition total_adjunction_forms_equivalence2_base : ∏ b : total_category D2, Isos.is_z_isomorphism (pr1 (adjcounit (total_adjunction FF) b)). Proof. intro. use Isos.is_z_iso_comp_of_is_z_isos. - apply Isos.identity_is_z_iso. - use Isos.is_z_iso_comp_of_is_z_isos. + apply (adj_equiv_of_cats_from_adj F). + apply Isos.identity_is_z_iso. Defined. Definition total_adjunction_forms_equivalence2_disp_inv : ∏ x : total_category D2, pr2 (functor_identity (total_category D2) x) -->[ inv_from_z_iso (pr1 (adjcounit (total_adjunction FF) x),, total_adjunction_forms_equivalence2_base x)] pr2 ((pr121 (total_adjunction FF) ∙ pr11 (total_adjunction FF)) x). Proof. intro x. set (f := pr1 (pr22 FF (pr1 x) (pr2 x))). cbn. assert (p : identity (pr1 x) · Isos.is_z_isomorphism_mor ((pr222 F) (pr1 x)) · identity (F (right_adjoint F (pr1 x))) = Isos.is_z_isomorphism_mor ((pr222 F) (pr1 x))). { rewrite id_left. now apply id_right. } exact (transportf (mor_disp _ _) (! p) f). Defined. Lemma total_adjunction_forms_equivalence2_disp_inv_is_inv : ∏ x : total_category D2, is_disp_inverse (z_iso_is_inverse_in_precat (pr1 (adjcounit (total_adjunction FF) x),, total_adjunction_forms_equivalence2_base x)) (pr2 (adjcounit (total_adjunction FF) x)) (total_adjunction_forms_equivalence2_disp_inv x). Proof. unfold total_adjunction_forms_equivalence2_base. unfold total_adjunction_forms_equivalence2_disp_inv. split. - cbn. use transportf_transpose_right. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. cbn. set (ff := pr12 (pr22 FF (pr1 x) (pr2 x))). cbn in ff. set (fff := transportf_transpose_left ff). refine (_ @ fff). use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. rewrite id_left_disp. rewrite transport_b_b. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. use transportf_set. apply homset_property. - cbn. use transportf_transpose_right. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. cbn. set (ff := pr22 (pr22 FF (pr1 x) (pr2 x))). cbn in ff. set (fff := transportf_transpose_left ff). refine (_ @ fff). use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. rewrite id_left_disp. rewrite transport_b_b. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use transportf_set. apply homset_property. Qed. Definition total_adjunction_forms_equivalence2 : ∏ b : total_category D2, Isos.is_z_isomorphism (adjcounit (total_adjunction FF) b). Proof. intro x. use is_z_iso_total. - exact (total_adjunction_forms_equivalence2_base x). - exists (total_adjunction_forms_equivalence2_disp_inv x). exact (total_adjunction_forms_equivalence2_disp_inv_is_inv x). Defined. Definition total_adjunction_forms_equivalence : forms_equivalence (total_adjunction FF). Proof. split. - exact total_adjunction_forms_equivalence1. - exact total_adjunction_forms_equivalence2. Defined. Definition total_adj_equivalence_of_cats : adj_equivalence_of_cats (total_functor LL). Proof. exists (total_adjunction FF). exact total_adjunction_forms_equivalence. Defined. Definition total_equivalence : adj_equiv (total_category D1) (total_category D2). Proof. exists (left_functor (total_adjunction FF)). exact total_adj_equivalence_of_cats. Defined. End TotalEquivalence. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/TotalCategoryFacts.v000066400000000000000000000117311451125700300263110ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope mor_disp_scope. Section DisplayedToTotalEsoFF. Context {C1 C2 : category} {F : functor C1 C2} {D1 : disp_cat C1} {D2 : disp_cat C2} {FF : disp_functor F D1 D2}. Definition disp_functor_ff_to_total_ff (F_ff : fully_faithful F) (FF_ff : disp_functor_ff FF) : fully_faithful (total_functor FF). Proof. intros a b. cbn. set (TF := F_ff (pr1 a) (pr1 b)). set (TFF := FF_ff (pr1 a) (pr1 b) (pr2 a) (pr2 b)). set (TF' := make_weq _ TF). set (H := @weqtotal2 _ _ _ _ TF' (λ f, make_weq _ (TFF f))). apply (isweqhomot H). - intro. apply idpath. - apply H. Qed. Definition disp_functor_eso_to_total_eso (F_eso : essentially_surjective F) (FF_eso : disp_functor_disp_ess_split_surj FF) (I : iso_cleaving D2) : essentially_surjective (total_functor FF). Proof. intros [b bb]. set (F_eso_bb := F_eso b). unfold disp_functor_disp_ess_split_surj in FF_eso. apply (squash_to_prop F_eso_bb). - apply propproperty. - clear F_eso_bb F_eso. intros [a i]. apply hinhpr. set (XR := FF_eso a). clearbody XR; clear FF_eso. set (II := I _ _ i bb). set (cc := pr1 II). set (ii := pr2 II). cbn in ii. set (XR2 := XR cc). set (aa := pr1 XR2). set (jj := pr2 XR2). use tpair. + use tpair. * exact a. * cbn. apply aa. + cbn. cbn in jj. apply total_z_iso_equiv_map; cbn. use tpair. * apply i. * cbn. set (XRr := z_iso_disp_comp jj ii). assert (p : Isos.z_iso_comp (Isos.identity_z_iso (F a)) i = i). { use total2_paths_f. - apply id_left. - apply Isos.isaprop_is_z_isomorphism. } induction p. exact XRr. Qed. End DisplayedToTotalEsoFF. Section ProductOfDisplayedFunctorsOverFixedBase. Context {C1 C2 : category} {F : functor C1 C2} {D1 D1' : disp_cat C1} {D2 D2' : disp_cat C2} (FF : disp_functor F D1 D2) (FF' : disp_functor F D1' D2'). Definition disp_prod_functor_over_fixed_base_data : disp_functor_data F (D1 × D1')%disp_cat (D2 × D2')%disp_cat. Proof. exists (λ x, dirprodf (FF x) (FF' x)). intros x y xx yy f ff. exists (pr21 FF x y (pr1 xx) (pr1 yy) f (pr1 ff)). exact (pr21 FF' x y (pr2 xx) (pr2 yy) f (pr2 ff)). Defined. Lemma disp_prod_functor_over_fixed_base_is_functor : disp_functor_axioms disp_prod_functor_over_fixed_base_data. Proof. split. - intros x xx. use total2_paths_f. + refine (pr12 FF x (pr1 xx) @ _). apply pathsinv0, pr1_transportf. + rewrite transportf_const. refine (pr12 FF' x (pr2 xx) @ _). apply pathsinv0, pr2_transportf. - intros x y z xx yy zz f g ff gg. use total2_paths_f. + refine (pr22 FF x y z (pr1 xx) (pr1 yy) (pr1 zz) f g (pr1 ff) (pr1 gg) @ _). apply pathsinv0, pr1_transportf. + rewrite transportf_const. refine (pr22 FF' x y z (pr2 xx) (pr2 yy) (pr2 zz) f g (pr2 ff) (pr2 gg) @ _). apply pathsinv0, pr2_transportf. Qed. Definition disp_prod_functor_over_fixed_base : disp_functor F (D1 × D1')%disp_cat (D2 × D2')%disp_cat := _ ,, disp_prod_functor_over_fixed_base_is_functor. Definition disp_prod_functor_over_fixed_base_ff (FF_ff : disp_functor_ff FF) (FF'_ff : disp_functor_ff FF') : disp_functor_ff disp_prod_functor_over_fixed_base. Proof. unfold disp_functor_ff in *. intros a b [x x'] [y y'] f. use isweqhomot. - apply (weqdirprodf (make_weq _ (FF_ff _ _ _ _ _ )) (make_weq _ (FF'_ff _ _ _ _ _ ))). - intro. apply idpath. - apply weqproperty. Qed. Definition disp_prod_functor_over_fixed_base_eso (FF_ff : disp_functor_disp_ess_split_surj FF) (FF'_ff : disp_functor_disp_ess_split_surj FF') : disp_functor_disp_ess_split_surj disp_prod_functor_over_fixed_base. Proof. unfold disp_functor_disp_ess_split_surj in *. intros a [x x']. specialize (FF_ff a x). induction FF_ff as [y i]. specialize (FF'_ff a x'). induction FF'_ff as [y' i']. exists (y,,y'). cbn. apply z_iso_disp_prod2. exact (make_dirprod i i'). Qed. End ProductOfDisplayedFunctorsOverFixedBase. UniMath-20231010/UniMath/CategoryTheory/DisplayedCats/Univalence.v000066400000000000000000000066561451125700300246520ustar00rootroot00000000000000 Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope cat. Local Open Scope mor_disp. (** ** Saturation: displayed univalent categories *) Section Univalent_Categories. Definition is_univalent_disp {C} (D : disp_cat C) := ∏ x x' (e : x = x') (xx : D x) (xx' : D x'), isweq (λ ee, @idtoiso_disp _ _ _ _ e xx xx' ee). Definition isaprop_is_univalent_disp {C : category} (D : disp_cat C) : isaprop (is_univalent_disp D). Proof. unfold is_univalent_disp. do 5 (use impred ; intro). apply isapropisweq. Defined. Definition is_univalent_in_fibers {C} (D : disp_cat C) : UU := ∏ x (xx xx' : D x), isweq (fun e : xx = xx' => idtoiso_fiber_disp e). (* TODO: maybe rename further. *) Lemma is_univalent_disp_from_fibers {C} {D : disp_cat C} : is_univalent_in_fibers D -> is_univalent_disp D. Proof. intros H x x' e. destruct e. apply H. Qed. Definition is_univalent_in_fibers_from_univalent_disp {C} (D : disp_cat C) : is_univalent_disp D -> is_univalent_in_fibers D. Proof. unfold is_univalent_disp , is_univalent_in_fibers. intros H x xx xx'. specialize (H x x (idpath _ ) xx xx'). apply H. Defined. Lemma univalent_disp_cat_has_groupoid_obs {C} (D : disp_cat C) (is_u : is_univalent_disp D) : ∏ c, isofhlevel 3 (D c). Proof. intro c. change (isofhlevel 3 (D c)) with (∏ a b : D c, isofhlevel 2 (a = b)). intros xx xx'. set (XR := is_univalent_in_fibers_from_univalent_disp _ is_u). apply (isofhlevelweqb _ (make_weq _ (XR _ xx xx'))). apply isaset_z_iso_disp. Defined. Definition disp_univalent_category C := ∑ D : disp_cat C, is_univalent_disp D. Definition make_disp_univalent_category {C} {D : disp_cat C} (H : is_univalent_disp D) : disp_univalent_category C := (D,,H). Definition disp_cat_of_disp_univalent_cat {C} (D : disp_univalent_category C) : disp_cat C := pr1 D. Coercion disp_cat_of_disp_univalent_cat : disp_univalent_category >-> disp_cat. Definition disp_univalent_category_is_univalent_disp {C} (D : disp_univalent_category C) : is_univalent_disp D := pr2 D. Coercion disp_univalent_category_is_univalent_disp : disp_univalent_category >-> is_univalent_disp. Definition isotoid_disp {C} {D : disp_cat C} (D_cat : is_univalent_disp D) {c c' : C} (e : c = c') {d : D c} {d'} (i : z_iso_disp (idtoiso e) d d') : transportf _ e d = d'. Proof. exact (invmap (make_weq (idtoiso_disp e) (D_cat _ _ _ _ _)) i). Defined. Definition idtoiso_isotoid_disp {C} {D : disp_cat C} (D_cat : is_univalent_disp D) {c c' : C} (e : c = c') {d : D c} {d'} (i : z_iso_disp (idtoiso e) d d') : idtoiso_disp e (isotoid_disp D_cat e i) = i. Proof. use homotweqinvweq. Qed. Definition isotoid_idtoiso_disp {C} {D : disp_cat C} (D_cat : is_univalent_disp D) {c c' : C} (e : c = c') {d : D c} {d'} (ee : transportf _ e d = d') : isotoid_disp D_cat e (idtoiso_disp e ee) = ee. Proof. use homotinvweqweq. Qed. End Univalent_Categories. UniMath-20231010/UniMath/CategoryTheory/ElementaryTopos.v000066400000000000000000000447401451125700300231560ustar00rootroot00000000000000(** ** Following Saunders Mac Lane & Ieke Moerdijk Sheaves in Geometry and Logic - A First Introduction to Topos theory. Chapter IV.1 and IV.2 Contents : - definition of elementary topos ([Topos]) as a category which has: -) finite limits meaning: --) Terminal Object --) Binary Pullbacks -) Power Object -) Subobject Classifier - definition of the [KroneckerDelta] predicate and the [SingletonArrow] - proof that [SingletonArrow] is monic ([SingletonArrow_isMonic]) - derivation of exponentials [Exponentials_from_Topos] *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.SubobjectClassifier. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.PowerObject. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Subobjects. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Local Open Scope cat. (* An elementary topos is a category which has: -) finite limits meaning: --) Terminal Object --) Binary Pullbacks -) Power Object -) Subobject Classifier *) Definition Topos_Structure (C : category) := ∑ (PB : Pullbacks C) (T : Terminal C) (Ω : subobject_classifier T), (PowerObject (BinProductsFromPullbacks PB T) Ω). Definition Topos := ∑ (C:category), Topos_Structure C. Definition make_Topos_Structure {C:category} (PB : Pullbacks C) (T : Terminal C) (Ω: subobject_classifier T) (P: PowerObject (BinProductsFromPullbacks PB T) Ω) : Topos_Structure C. Proof. split with PB. split with T. split with Ω. exact P. Defined. Definition make_Topos {C:category} (str: Topos_Structure C) : Topos. Proof. split with C. exact str. Defined. Section ToposAccessor. Context (C : Topos). Definition Topos_category : category := pr1 C. Definition Topos_Pullbacks : Pullbacks Topos_category := pr1 (pr2 C). Definition Topos_Terminal : Terminal Topos_category := pr1 (pr2 (pr2 C)). Definition Topos_SubobjectClassifier : subobject_classifier (Topos_Terminal) := pr1 (pr2 (pr2 (pr2 C))). Definition Topos_BinProducts : BinProducts Topos_category := BinProductsFromPullbacks (Topos_Pullbacks) (Topos_Terminal). Definition Topos_PowerObject : PowerObject (Topos_BinProducts) (Topos_SubobjectClassifier) := pr2 (pr2 (pr2 (pr2 C))). End ToposAccessor. Coercion Topos_category : Topos >->category. Section Topos. Context {C:Topos}. Let T := Topos_Terminal C. Let PB := Topos_Pullbacks C. Let BinProd := Topos_BinProducts C. Let P := Topos_PowerObject C. Let Ω := Topos_SubobjectClassifier C. Local Notation "c ⨉ d" := (BinProductObject C (BinProd c d))(at level 5). (*\bigtimes*) Local Notation "f ⨱ g" := (BinProductOfArrows _ (BinProd _ _) (BinProd _ _) f g) (at level 10). (*\timesbar*) Section KroneckerDelta. (*The [KroneckerDelta] predicate is defined as the chraracteristic morphis of the [diagonalMap], The [SingletonArrow] is defined as the [PowerObject_transpose] of the [KroneckerDelta]*) Definition KroneckerDelta (B : C) : C⟦ B ⨉ B , Ω⟧. Proof. use characteristic_morphism. + exact B. + use diagonalMap. Defined. Local Notation "'δ' B" := (KroneckerDelta B)(at level 8). Definition SingletonArrow (B : C) : C⟦ B , (PowerObject_on_ob P) B⟧. Proof. use PowerObject_transpose. use KroneckerDelta. Defined. Local Notation "'{⋅}' B" := (SingletonArrow B)(at level 8). (*Proof that [SingletonArrow] is Monic and definition of his characteristic map [SingletonPred]*) Local Definition auxpb {X B: C} (b: C⟦ X , B⟧) : Pullback (identity B ⨱ b) (diagonalMap BinProd B). Proof. use make_Pullback. + exact X. + use BinProductArrow. - exact b. - exact (identity X). + exact b. + simpl. rewrite postcompWithBinProductArrow. use pathsinv0. use BinProductArrowUnique. - rewrite !assoc'. unfold diagonalMap'. now rewrite BinProductPr1Commutes. - rewrite !assoc'. unfold diagonalMap'. now rewrite BinProductPr2Commutes, id_left, id_right. + use make_isPullback. intros Y y1 y2 r. set (y11 := (y1 · (BinProductPr1 _ (BinProd B X)))). set (y12 := (y1 · (BinProductPr2 _ (BinProd B X)))). (* rewrite (BinProductArrowEta _ _ _ _ _ y1). *) assert (r1 := maponpaths (λ f, compose f (BinProductPr1 C (BinProd B B))) r). assert (r2 := maponpaths (λ f, compose f (BinProductPr2 C (BinProd B B))) r). simpl in r1, r2. unfold diagonalMap' in r1, r2. rewrite !assoc', BinProductOfArrowsPr1, BinProductPr1Commutes, !id_right in r1. rewrite !assoc', BinProductOfArrowsPr2, BinProductPr2Commutes, !id_right, assoc in r2. fold y11 in r1. fold y12 in r2. use make_iscontr. - split with y12. use (tpair _ _ r2). rewrite precompWithBinProductArrow. use pathsinv0. use BinProductArrowUnique. * now rewrite r2, <-r1. * now rewrite id_right. - intro t. induction t as (t,(tri1,tri2)). use subtypePath. * unfold isPredicate. intro. use isofhleveldirprod. ++ use homset_property. ++ use homset_property. * cbn. assert (Ts := maponpaths (λ f, compose f (BinProductPr2 C (BinProd B X))) tri1). simpl in Ts. rewrite assoc', BinProductPr2Commutes, id_right in Ts. exact Ts. Defined. Lemma SingletonArrow_isMonic (B: C) : isMonic ({⋅} B). Proof. use make_isMonic. intros X b b' p. assert (q : (((identity B) ⨱ b) · (δ B) = ((identity B) ⨱ b') · (δ B))). { rewrite (PowerObject_transpose_tri P (δ B)). fold BinProd. rewrite !assoc, !BinProductOfArrows_idxcomp. use (maponpaths (( nat_z_iso_inv (PowerObject_nat_z_iso P)) (X,,B))). exact p. } (** Consider this diagram << b ! X --------> B --------> T | | | b x id | diagonalMap| | true v v v B x X --------> B x B --------> Ω id x b δB >> We prove the left-hand square is a pullback (even when we substitue b with b') in [pbl] and [pbl'], the right-hand square is the definition of [KroneckerDelta] and it is a Pullback, so the whole rectangle is a pullback ([pb] [pb']) using [q] we note b x id and b' x id are [pullbackPr1] of the same diagram, thus they differ by an isomorphism [h] *) set (pbr := subobject_classifier_pullback Ω (diagonalMap BinProd B)). set (pbl := auxpb b). set (pbl' := auxpb b'). set (pb := pullback_glue_pullback C pbr pbl). set (pb' := pullback_glue_pullback C pbr pbl'). fold δ B in pb, pb'. transparent assert (pb'' : (Pullback ((identity B) ⨱ b' · δ B) Ω)). { use (Pullback_mor_paths q (idpath _)). exact pb. } induction (pullbackiso _ pb' pb'') as (h,(h_tri1,h_tri2)). cbn - [BinProd] in h, h_tri1. rewrite (precompWithBinProductArrow _ (BinProd B X)) in h_tri1. assert (h_tri11 := (maponpaths (λ f, compose f (BinProductPr1 C (BinProd B X))) h_tri1)). cbn beta in h_tri11. rewrite !BinProductPr1Commutes in h_tri11. assert (h_tri12 := (maponpaths (λ f, compose f (BinProductPr2 C (BinProd B X))) h_tri1)). cbn beta in h_tri12. rewrite !BinProductPr2Commutes, id_right in h_tri12. rewrite h_tri12, id_left in h_tri11. exact h_tri11. Defined. Definition SingletonArrow_Monic (B: C) := make_Monic C (SingletonArrow B) (SingletonArrow_isMonic B). Definition SingletonPred (B: C) : C ⟦ PowerObject_on_ob P B , Ω ⟧. Proof. use characteristic_morphism. { exact B. } use SingletonArrow_Monic. Defined. End KroneckerDelta. (*In this section we show that an elementary topos has exponentials*) Section Exponentials. Local Notation "'δ' B" := (KroneckerDelta B)(at level 8). Local Notation "'{⋅}' B" := (SingletonArrow B)(at level 8). (*[v b c] in Sets would be, given an element x of b and a relation as a subset of c x b, the subset of c of all the element in relation with x*) Let v (b c : C) : C ⟦ (b ⨉ (PowerObject_on_ob P (c ⨉ b))) , (PowerObject_on_ob P c) ⟧. Proof. use (PowerObject_transpose). use (compose (BinProduct_assoc BinProd c b (PowerObject_on_ob P (c ⨉ b)))). use PowerObject_inPred. Defined. (*[u b c] in Sets would be, given a relation as a subset of c x b, the subset of b of all the element x such that (v b c) x is a Singleton*) Let u (b c : C) : C ⟦ PowerObject_on_ob P (c ⨉ b) , (PowerObject_on_ob P b) ⟧. Proof. use (PowerObject_transpose). use (compose (b:= (PowerObject_on_ob P c))). - use v. - use SingletonPred. Defined. Let name_true (b : C) : C ⟦ T, PowerObject_on_ob P b ⟧. Proof. use (PowerObject_charname_nat_z_iso P). exact (TerminalArrow T b · true Ω). Defined. (*we are going to use [left_adjoint_from_partial], so, given (b c : C) we set up: Subobject_dom G0 (the object c^b : C) ev (the evaluation morphism : C ⟦ b x c^b , c ⟧ universality (a proof which show e b c is universal) *) (*G0 is defined as the pullback of name_true through u*) Let G0 (b c : C) : Subobjectscategory (PowerObject_on_ob P (c ⨉ b)). Proof. use (PullbackSubobject PB). { exact (PowerObject_on_ob P b). } { use Subobjectscategory_ob. - exact T. - exact (name_true b). - use from_terminal_isMonic. } - use u. Defined. Local Lemma G0_Sqr (b c : C) : (Subobject_mor (G0 b c) · (u b c) = (TerminalArrow T _ ) · (name_true b)). Proof. cbn. rewrite PullbackSqrCommutes. repeat use cancel_postcomposition. use TerminalArrowUnique. Qed. (** Consider this diagram << ev ---------------------------------------------------- | | | id x G0 v {·} v b x c^b --------> b x P(c x b) ------> Pc <--------- C | | | | id x ! | id x u | SingletonPred| |! v v v v b x T --------> b x Pb -----------> Ω <--------- T | id x name_true inmap true ʌ | | ---------------------------------------------------- ! >> The left-hand square is b x (def of c^b), the middle square is the definition of v from u, the right-hand square is the definition of SingletonPred and it is a Pullback, the bottom distorted square is the definition of name_true. Every square commutes. We define [ev] as the [PullbackArrow] of the right-hand square *) Local Definition ev_aux (b c: C) : (identity b) ⨱ (Subobject_mor (G0 b c)) · v b c · characteristic_morphism Ω (SingletonArrow_Monic c) = (identity b) ⨱ (TerminalArrow T (Subobject_dom (G0 b c))) · TerminalArrow T (BinProd b T) · Ω. Proof. rewrite assoc'. assert (p : (identity b) ⨱ (u b c) · PowerObject_inPred P b = v b c · characteristic_morphism Ω (SingletonArrow_Monic c)). { use pathsinv0. use (PowerObject_transpose_tri P). } induction p. rewrite assoc, BinProductOfArrows_idxcomp. rewrite G0_Sqr. rewrite !assoc', <-BinProductOfArrows_idxcomp, !assoc'. use cancel_precomposition. unfold name_true. rewrite (PowerObject_charname_nat_z_iso_tri(b:=b) P). rewrite !assoc. use cancel_postcomposition. use TerminalArrowUnique. Qed. Let ev (b c: C) : C ⟦ b ⨉ (Subobject_dom (G0 b c)), c ⟧. Proof. assert (p : PullbackObject (subobject_classifier_pullback Ω (SingletonArrow_Monic c)) = c). { apply idpath. } induction p. use PullbackArrow. - exact ((identity _) ⨱ (Subobject_mor (G0 b c)) · (v b c)). - exact ((identity b) ⨱ (TerminalArrow T (Subobject_dom (G0 b c)))· (TerminalArrow T _)). - apply ev_aux. Defined. Local Lemma ev_tri (b c : C) : ev b c · SingletonArrow_Monic c = (identity _) ⨱ ( Subobject_mor (G0 b c)) · (v b c). Proof. use (PullbackArrow_PullbackPr1 (subobject_classifier_pullback Ω (SingletonArrow_Monic c))). Qed. (*UNIVERSALITY Given f : C ⟦ b x a , c ⟧ we need to show there is a unique g : C ⟦ a , c^b ⟧ such that f = (id x g)·ev we define such g as the [PullbackArrow] the following diagram << ! c^b -------------> T | | G0 | | name_true h v v a --->P (c x b) ----------> Pb u b c >> where h is the transpose of ((id c) x f)·(δ c) but as a morphism C ⟦ (c x b) x a , Ω ⟧ (so we need to precompose [BinProduct_assoc]) *) Let h {c b a : C} (f: C ⟦ b ⨉ a, c ⟧) := PowerObject_transpose P ((z_iso_inv (BinProduct_assoc BinProd c b a)) · (identity c) ⨱ f · (δ c)). Local Lemma h_sq {c b a : C} (f: C ⟦ b ⨉ a, c ⟧) : f · SingletonArrow_Monic c = (identity b) ⨱ (h f) · v b c. Proof. use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso (nat_z_iso_inv (PowerObject_nat_z_iso P)) (b ⨉ a,,c)))). simpl. fold BinProd. rewrite <-!BinProductOfArrows_idxcomp, !assoc'. intermediate_path ((identity c) ⨱ f · KroneckerDelta c). { use cancel_precomposition. apply pathsinv0. use PowerObject_transpose_tri. } use pathsinv0. intermediate_path ( (identity c) ⨱ ((identity b) ⨱ (h f)) · ((BinProduct_assoc BinProd c b (PowerObject_on_ob P c ⨉ b)) · PowerObject_inPred P c ⨉ b)). { use cancel_precomposition. use pathsinv0. use (PowerObject_transpose_tri P). } rewrite assoc. rewrite BinProduct_OfArrows_assoc. use pathsinv0. rewrite !assoc'. use z_iso_inv_to_left. rewrite assoc. rewrite BinProductOfArrows_id. use PowerObject_transpose_tri. Qed. Local Lemma g_aux (c b a : C) (f: C ⟦ constprod_functor1 BinProd b a, c ⟧) : h f · u b c = TerminalArrow T a · Subobject_mor (Subobjectscategory_ob (name_true b) (from_terminal_isMonic T (PowerObject_on_ob P b) (name_true b))). Proof. assert (p : name_true b = Subobject_mor (Subobjectscategory_ob (name_true b) (from_terminal_isMonic T (PowerObject_on_ob P b) (name_true b)))). { apply idpath. } induction p. use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso (nat_z_iso_inv (PowerObject_nat_z_iso P)) (a,,b)))). simpl. fold BinProd. rewrite <-!BinProductOfArrows_idxcomp, !assoc'. intermediate_path ((identity b) ⨱ (h f) · (v b c · SingletonPred c)). { use cancel_precomposition. use pathsinv0. use PowerObject_transpose_tri. } use pathsinv0. intermediate_path ((identity b) ⨱ (TerminalArrow T a) · (BinProductPr1 C (BinProd b T) · ((TerminalArrow T b · Ω)))). { use cancel_precomposition. use PowerObject_charname_nat_z_iso_tri. } intermediate_path (f · SingletonArrow_Monic c · SingletonPred c). { rewrite !assoc', subobject_classifier_square_commutes, !assoc. use cancel_postcomposition. use TerminalArrowEq. } rewrite !assoc. use cancel_postcomposition. use h_sq. Qed. Let g (c b a : C) (f: C ⟦ constprod_functor1 BinProd b a, c ⟧) : C ⟦ a, Subobject_dom (G0 b c) ⟧. Proof. use PullbackArrow. + exact (h f). + use TerminalArrow. + apply g_aux. Defined. Local Lemma h_tri {c b a : C} (f: C ⟦ b ⨉ a, c ⟧): (g c b a f · Subobject_mor (G0 b c) = h f). Proof. use PullbackArrow_PullbackPr1. Qed. Local Lemma g_tri {c b a : C} (f: C ⟦ b ⨉ a, c ⟧) : f = (identity b) ⨱ (g c b a f) · ev b c. Proof. use (MonicisMonic _ (SingletonArrow_Monic c)). now rewrite !assoc', ev_tri, !assoc, BinProductOfArrows_idxcomp, h_tri, h_sq. Qed. (* Opaque isBinProduct_Pullback. *) Local Lemma universality (b c : C): is_universal_arrow_from (constprod_functor1 BinProd b) c (Subobject_dom (G0 b c)) (ev b c). Proof. intros a f. use unique_exists. + exact (g c b a f). + use g_tri. + intro. use homset_property. + intros g' g_tri'. simpl in g_tri'. unfold BinProduct_of_functors_mor in g_tri'. simpl in g_tri'. use (MonicisMonic _ (Subobject_Monic (G0 b c))). use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso (nat_z_iso_inv (PowerObject_nat_z_iso P)) (a,,c ⨉ b)))). unfold hset_z_iso_equiv. cbn - [BinProd G0 Subobject_mor isBinProduct_Pullback]. fold BinProd. rewrite <-BinProductOfArrows_id. use (cancel_z_iso' (BinProduct_assoc BinProd _ _ _)). rewrite !assoc. intermediate_path ( (identity c) ⨱ ((identity b) ⨱ (g' · Subobject_mor (G0 b c)))· BinProduct_assoc BinProd _ _ _ · PowerObject_inPred _ _). { use cancel_postcomposition. use pathsinv0. use (BinProduct_OfArrows_assoc BinProd). } use pathsinv0. intermediate_path ( (identity c) ⨱ ((identity b) ⨱ ((g c b a f) · Subobject_mor (G0 b c)))· BinProduct_assoc BinProd _ _ _ · PowerObject_inPred _ _). { use cancel_postcomposition. use pathsinv0. use (BinProduct_OfArrows_assoc BinProd). } rewrite !assoc'. use (invmaponpathsweq (hset_z_iso_equiv _ _ (nat_z_iso_pointwise_z_iso ( (PowerObject_nat_z_iso P)) (b⨉a,,c)))). unfold hset_z_iso_equiv. cbn - [BinProd G0 Subobject_mor BinProduct_assoc]. unfold PowerObject_nt_data. rewrite !PowerObject_transpose_precomp. fold (v b c). rewrite <-!(BinProductOfArrows_idxcomp _ BinProd _ (Subobject_mor _)). rewrite !assoc'. rewrite <-!ev_tri. rewrite !assoc. use cancel_postcomposition. rewrite <-g_tri. use g_tri'. Defined. Definition Exponentials_from_Topos : Exponentials (BinProd). Proof. intro b. use left_adjoint_from_partial. + intro c. exact (Subobject_dom (G0 b c)). + exact (ev b). + exact (universality b). Defined. End Exponentials. End Topos.UniMath-20231010/UniMath/CategoryTheory/Elements.v000066400000000000000000000474271451125700300216050ustar00rootroot00000000000000(** **************************************************************************** The category of elements of a functor "F : C ⟶ HSET" Contents: - Category of elements ([cat_of_elems]) - Functoriality of the constructon of the category of elements ([cat_of_elems_on_nat_trans]) - The forgetful functor from the category of elements to C ([cat_of_elems_forgetful]) Originally written by: Dan Grayson Ported to CT by: Anders Mörtberg *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Examples. Local Open Scope cat. Definition pointed_sets : category := total_category elements_universal. Definition is_univalent_disp_elements_universal : is_univalent_disp elements_universal. Proof. use is_univalent_disp_from_fibers. intros X x₁ x₂. use isweqimplimpl. - exact (λ p, pr1 p). - apply X. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + apply X. + apply isaprop_is_z_iso_disp. Qed. Definition is_univalent_pointed_sets : is_univalent pointed_sets. Proof. use is_univalent_total_category. - apply is_univalent_HSET. - exact is_univalent_disp_elements_universal. Defined. Definition pointed_sets_univalent : univalent_category. Proof. use make_univalent_category. - exact pointed_sets. - exact is_univalent_pointed_sets. Defined. Definition set_of_pointed_set : pointed_sets_univalent ⟶ HSET_univalent_category := pr1_category elements_universal. Definition is_z_iso_pointed_sets {X Y : pointed_sets} (f : X --> Y) (Hf : is_z_isomorphism (pr1 f)) : is_z_isomorphism f. Proof. use tpair. - simple refine (_ ,, _). + exact (inv_from_z_iso (make_z_iso' _ Hf)). + abstract (cbn ; pose (pr2 f) as p ; cbn in p ; rewrite <- p ; exact (eqtohomot (z_iso_inv_after_z_iso (make_z_iso' _ Hf)) (pr2 X))). - split. + abstract (use subtypePath ; [ intro ; apply (pr1 X) | ] ; exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf))). + abstract (use subtypePath ; [ intro ; apply (pr1 Y) | ] ; exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf))). Defined. Section CategoryOfElements. Context {C : category} (F : C ⟶ HSET). Definition disp_cat_of_elems_ob_mor : disp_cat_ob_mor C. Proof. simple refine (_ ,, _). - exact (λ c, (F c : hSet)). - exact (λ c₁ c₂ x y f, #F f x = y). Defined. Definition disp_cat_of_elems_id_comp : disp_cat_id_comp C disp_cat_of_elems_ob_mor. Proof. split. - exact (λ c x, eqtohomot (functor_id F c) x). - refine (λ c₁ c₂ c₃ f g x₁ x₂ x₃ p q, _) ; cbn in *. refine (eqtohomot (functor_comp F f g) x₁ @ _) ; cbn. exact (maponpaths (# F g) p @ q). Qed. Definition disp_cat_of_elems_data : disp_cat_data C. Proof. simple refine (_ ,, _). - exact disp_cat_of_elems_ob_mor. - exact disp_cat_of_elems_id_comp. Defined. Definition disp_mor_elems_isaprop {c₁ c₂ : C} (f : c₁ --> c₂) (x₁ : disp_cat_of_elems_data c₁) (x₂ : disp_cat_of_elems_data c₂) : isaprop (x₁ -->[ f ] x₂). Proof. use invproofirrelevance. intros φ₁ φ₂. cbn in *. apply (F c₂). Qed. Definition disp_cat_of_elems_axioms : disp_cat_axioms C disp_cat_of_elems_data. Proof. repeat split ; intros ; cbn. - apply disp_mor_elems_isaprop. - apply disp_mor_elems_isaprop. - apply disp_mor_elems_isaprop. - apply isasetaprop. apply disp_mor_elems_isaprop. Qed. Definition disp_cat_of_elems : disp_cat C. Proof. simple refine (_ ,, _). - exact disp_cat_of_elems_data. - exact disp_cat_of_elems_axioms. Defined. Definition is_univalent_disp_disp_cat_of_elems : is_univalent_disp disp_cat_of_elems. Proof. use is_univalent_disp_from_fibers. intros c x₁ x₂. use isweqimplimpl. - intro f. exact (!(eqtohomot (functor_id F c) x₁) @ pr1 f). - apply (F c). - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + apply disp_mor_elems_isaprop. + apply isaprop_is_z_iso_disp. Qed. Definition is_z_iso_disp_cat_of_elems {c₁ c₂ : C} {f : z_iso c₁ c₂} {x : disp_cat_of_elems c₁} {y : disp_cat_of_elems c₂} (p : x -->[ f ] y) : is_z_iso_disp f p. Proof. simple refine (_ ,, (_ ,, _)) ; cbn in *. - rewrite <- p. refine (!(eqtohomot (functor_comp F f (inv_from_z_iso f)) x) @ _). rewrite z_iso_inv_after_z_iso. apply (eqtohomot (functor_id F c₁) x). - apply disp_mor_elems_isaprop. - apply disp_mor_elems_isaprop. Qed. Definition disp_cat_of_elems_is_opcartesian {c₁ c₂ : C} {f : c₁ --> c₂} {x₁ : disp_cat_of_elems c₁} {x₂ : disp_cat_of_elems c₂} (p : x₁ -->[ f ] x₂) : is_opcartesian p. Proof. intros c₃ x₃ g hh. use iscontraprop1. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; cbn -[isaprop]. + apply disp_mor_elems_isaprop. + apply disp_cat_of_elems. - simple refine (_ ,, _) ; cbn in *. + refine (_ @ hh). refine (maponpaths (#F g) (!p) @ _). exact (!(eqtohomot (functor_comp F f g) x₁)). + apply disp_mor_elems_isaprop. Qed. Definition disp_cat_of_elems_opcleaving : opcleaving disp_cat_of_elems. Proof. intros c₁ c₂ x₁ f ; cbn in *. simple refine (_ ,, _ ,, _) ; cbn. - exact (#F f x₁). - apply idpath. - apply disp_cat_of_elems_is_opcartesian. Defined. Definition cat_of_elems_path_lift {x₁ x₂ : C} (p : x₁ = x₂) (y : disp_cat_of_elems x₂) : disp_cat_of_elems x₁. Proof. induction p. exact y. Defined. Definition cat_of_elems_path_path {x₁ x₂ : C} (p : x₁ = x₂) (y : disp_cat_of_elems x₂) : #F (idtoiso p) (cat_of_elems_path_lift p y) = y. Proof. induction p. cbn. exact (eqtohomot (functor_id F x₁) y). Qed. Definition cat_of_elems_path_natural {x₁ x₂ x₁' x₂' : C} (f₁ : x₁ --> x₁') (f₂ : x₂ --> x₂') (p : x₁ = x₂) (p' : x₁' = x₂') (y : disp_cat_of_elems x₂) (y' : disp_cat_of_elems x₂') (q : f₁ · idtoiso p' = idtoiso p · f₂) (r : y' = # F f₂ y) : cat_of_elems_path_lift p' y' = #F f₁ (cat_of_elems_path_lift p y). Proof. induction p, p'. cbn ; cbn in *. rewrite id_left, id_right in q. rewrite q. exact r. Qed. Section CatOfElemsIsoCleaving. Context (HC : is_univalent C) {x₁ x₂ : C} (f : x₁ --> x₂) (Hf : is_z_isomorphism f) (y : disp_cat_of_elems x₂). Definition cat_of_elems_iso_lift : disp_cat_of_elems x₁ := cat_of_elems_path_lift (isotoid _ HC (make_z_iso' _ Hf)) y. Definition cat_of_elems_iso_path : #F f cat_of_elems_iso_lift = y. Proof. refine (_ @ cat_of_elems_path_path (isotoid _ HC (make_z_iso' _ Hf)) y). apply maponpaths_2. rewrite idtoiso_isotoid. apply idpath. Qed. End CatOfElemsIsoCleaving. Definition cat_of_elems_z_iso_natural (HC : is_univalent C) {x₁ x₂ x₁' x₂' : C} (f₁ : x₁ --> x₁') (f₂ : x₂ --> x₂') (g₁ : x₁ --> x₂) (Hg₁ : is_z_isomorphism g₁) (g₂ : x₁' --> x₂') (Hg₂ : is_z_isomorphism g₂) (y : disp_cat_of_elems x₂) (y' : disp_cat_of_elems x₂') (q : f₁ · g₂ = g₁ · f₂) (r : y' = # F f₂ y) : cat_of_elems_iso_lift HC g₂ Hg₂ y' = #F f₁ (cat_of_elems_iso_lift HC g₁ Hg₁ y). Proof. use (cat_of_elems_path_natural f₁ f₂). rewrite !idtoiso_isotoid ; cbn. - exact q. - exact r. Qed. Definition cat_of_elems : category := total_category disp_cat_of_elems. Definition is_univalent_cat_of_elems (HC : is_univalent C) : is_univalent cat_of_elems. Proof. use is_univalent_total_category. - exact HC. - exact is_univalent_disp_disp_cat_of_elems. Defined. Definition is_z_iso_cat_of_elems {cx₁ cx₂ : cat_of_elems} (f : cx₁ --> cx₂) (Hf : is_z_isomorphism (pr1 f)) : is_z_isomorphism f. Proof. use tpair. - simple refine (inv_from_z_iso (make_z_iso' _ Hf) ,, _). abstract (cbn ; pose (pr2 f) as p ; cbn in p ; rewrite <- p ; exact (eqtohomot (z_iso_inv_after_z_iso (functor_on_z_iso F (make_z_iso' _ Hf))) (pr2 cx₁))). - split. + abstract (use subtypePath ; [ intro ; apply (F _) | ] ; apply (z_iso_inv_after_z_iso (make_z_iso' _ Hf))). + abstract (use subtypePath ; [ intro ; apply (F _) | ] ; apply (z_iso_after_z_iso_inv (make_z_iso' _ Hf))). Defined. Definition cat_of_elems_forgetful : cat_of_elems ⟶ C := pr1_category disp_cat_of_elems. Definition cat_of_elems_to_pointed_data : functor_data cat_of_elems pointed_sets. Proof. use make_functor_data. - exact (λ cx, F (pr1 cx) ,, pr2 cx). - exact (λ cx₁ cx₂ fp, #F (pr1 fp) ,, pr2 fp). Defined. Definition cat_of_elems_to_pointed_is_functor : is_functor cat_of_elems_to_pointed_data. Proof. split. - intros cx ; cbn in *. use subtypePath. { intro. apply (F _). } cbn. use funextsec. intro x. exact (eqtohomot (functor_id F (pr1 cx)) x). - intros cx₁ cx₂ cx₃ fp₁ fp₂ ; cbn in *. use subtypePath. { intro. apply (F _). } cbn. use funextsec. intro x. exact (eqtohomot (functor_comp F _ _) x). Qed. Definition cat_of_elems_to_pointed : cat_of_elems ⟶ pointed_sets. Proof. use make_functor. - exact cat_of_elems_to_pointed_data. - exact cat_of_elems_to_pointed_is_functor. Defined. Definition cat_of_elems_commute : cat_of_elems_to_pointed ∙ set_of_pointed_set ⟹ cat_of_elems_forgetful ∙ F. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros cx₁ cx₂ f ; cbn ; apply idpath). Defined. Definition cat_of_elems_commute_z_iso : nat_z_iso (cat_of_elems_to_pointed ∙ set_of_pointed_set) (cat_of_elems_forgetful ∙ F). Proof. use make_nat_z_iso. - exact cat_of_elems_commute. - intro. apply identity_is_z_iso. Defined. Section FunctorToCatOfElems. Context {C' : category} (G₁ : C' ⟶ pointed_sets) (G₂ : C' ⟶ C) (γ : nat_z_iso (G₁ ∙ set_of_pointed_set) (G₂ ∙ F)). Definition functor_to_cat_of_elems_data : functor_data C' cat_of_elems. Proof. use make_functor_data. - exact (λ c, G₂ c ,, γ c (pr2 (G₁ c))). - refine (λ c₁ c₂ f, # G₂ f ,, _). abstract (cbn ; refine (!(eqtohomot (nat_trans_ax γ _ _ f) (pr2 (G₁ c₁))) @ _) ; cbn ; apply maponpaths ; exact (pr2 (# G₁ f))). Defined. Definition functor_to_cat_of_elems_is_functor : is_functor functor_to_cat_of_elems_data. Proof. split. - intro x ; cbn. use subtypePath. { intro. apply (F _). } cbn. apply functor_id. - intros x y z f g ; cbn. use subtypePath. { intro. apply (F _). } cbn. apply functor_comp. Qed. Definition functor_to_cat_of_elems : C' ⟶ cat_of_elems. Proof. use make_functor. - exact functor_to_cat_of_elems_data. - exact functor_to_cat_of_elems_is_functor. Defined. Definition functor_to_cat_of_elems_pointed_nat_trans : functor_to_cat_of_elems ∙ cat_of_elems_to_pointed ⟹ G₁. Proof. use make_nat_trans. - refine (λ x, inv_from_z_iso (nat_z_iso_pointwise_z_iso γ x) ,, _) ; cbn. abstract (exact (eqtohomot (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso γ x)) (pr2 (G₁ x)))). - abstract (intros c₁ c₂ f ; cbn ; use subtypePath ; [ intro ; apply (pr1 (G₁ c₂)) | ] ; cbn ; use funextsec ; intro x ; exact (eqtohomot (nat_trans_ax (nat_z_iso_to_trans_inv γ) _ _ f) x)). Defined. Definition functor_to_cat_of_elems_pointed : nat_z_iso (functor_to_cat_of_elems ∙ cat_of_elems_to_pointed) G₁. Proof. use make_nat_z_iso. - exact functor_to_cat_of_elems_pointed_nat_trans. - intro. use is_z_iso_pointed_sets. apply is_z_iso_inv_from_z_iso. Defined. Definition functor_to_cat_of_elems_forgetful_nat_trans : functor_to_cat_of_elems ∙ cat_of_elems_forgetful ⟹ G₂. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition functor_to_cat_of_elems_forgetful : nat_z_iso (functor_to_cat_of_elems ∙ cat_of_elems_forgetful) G₂. Proof. use make_nat_z_iso. - exact functor_to_cat_of_elems_forgetful_nat_trans. - intro. apply identity_is_z_iso. Defined. Definition functor_to_cat_of_elems_commute (c : C') : cat_of_elems_commute (functor_to_cat_of_elems c) = # set_of_pointed_set (functor_to_cat_of_elems_pointed_nat_trans c) · γ c. Proof. use funextsec. intro x ; cbn. exact (!(eqtohomot (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso γ c)) x)). Qed. End FunctorToCatOfElems. Section NatTransToCatOfElems. Context {C' : category} {G₁ G₂ : C' ⟶ cat_of_elems} (τ₁ : G₁ ∙ cat_of_elems_to_pointed ⟹ G₂ ∙ cat_of_elems_to_pointed) (τ₂ : G₁ ∙ cat_of_elems_forgetful ⟹ G₂ ∙ cat_of_elems_forgetful) (p : ∏ (x : C'), # F (τ₂ x) (pr2 (G₁ x)) = pr1 (τ₁ x) (pr2 (G₁ x))). Definition nat_trans_to_cat_of_elems : G₁ ⟹ G₂. Proof. use make_nat_trans. - simple refine (λ x, τ₂ x ,, _) ; cbn. abstract (exact (p x @ pr2 (τ₁ x))). - abstract (intros x y f ; cbn ; use subtypePath ; [ intro ; apply (F _) | ] ; cbn ; exact (nat_trans_ax τ₂ _ _ f)). Defined. End NatTransToCatOfElems. End CategoryOfElements. Definition univalent_cat_of_elems {C : univalent_category} (F : C ⟶ SET) : univalent_category. Proof. use make_univalent_category. - exact (cat_of_elems F). - apply is_univalent_cat_of_elems. apply C. Defined. (* Section cat_of_elems_def. Context {C : precategory} (X : C ⟶ HSET). Definition cat_of_elems_ob_mor : precategory_ob_mor. Proof. exists (∑ (c : C), X c : hSet). intros a b. apply (∑ (f : C⟦pr1 a,pr1 b⟧), # X f (pr2 a) = pr2 b). Defined. Definition cat_of_elems_data : precategory_data. Proof. exists cat_of_elems_ob_mor. split. + intros a. exists (identity (pr1 a)). abstract (exact (eqtohomot ((functor_id X) (pr1 a)) (pr2 a))). + intros a b c f g. exists (pr1 f · pr1 g). abstract (exact ((eqtohomot ((functor_comp X) (pr1 f) (pr1 g)) (pr2 a)) @ (maponpaths (# X (pr1 g)) (pr2 f) @ (pr2 g)))). Defined. Definition get_mor {x y : cat_of_elems_data} (f : _⟦x,y⟧) := pr1 f. Lemma cat_of_elems_mor_eq (x y : cat_of_elems_data) (f g : _⟦x,y⟧) : get_mor f = get_mor g → f = g. Proof. intros p. apply subtypePath. - intro r; apply setproperty. - exact p. Qed. Lemma is_precategory_cat_of_elems_data : is_precategory cat_of_elems_data. Proof. split; [split|split]; intros; apply cat_of_elems_mor_eq. + apply id_left. + apply id_right. + apply assoc. + apply assoc'. Defined. Definition cat_of_elems : precategory := (cat_of_elems_data,,is_precategory_cat_of_elems_data). Lemma has_homsets_cat_of_elems (hsC : has_homsets C) : has_homsets cat_of_elems. Proof. intros a b. apply isaset_total2. - apply hsC. - intro f. apply isasetaprop, setproperty. Qed. End cat_of_elems_def. Arguments get_mor {_ _ _ _} _. (** Type as \int in Agda mode *) Notation "∫ X" := (cat_of_elems X) (at level 3) : cat. Section cat_of_elems_theory. Context {C : precategory} {X Y : C ⟶ HSET}. Definition get_ob (x : ∫ X) : C := pr1 x. Definition get_el (x : ∫ X) : X (get_ob x) : hSet := pr2 x. Definition get_eqn {x y : ∫ X} (f : (∫ X)⟦x,y⟧) : # X (get_mor f) (get_el x) = get_el y := pr2 f. Definition make_ob (c : C) (x : X c : hSet) : ∫ X := (c,,x). Definition make_mor (r s : ∫ X) (f : C⟦get_ob r,get_ob s⟧) (i : # X f (get_el r) = get_el s) : (∫ X)⟦r,s⟧ := (f,,i). (** Functoriality of the construction of the category of elements *) Definition cat_of_elems_on_nat_trans_data (α : X ⟹ Y) : functor_data (∫ X) (∫ Y). Proof. exists (λ a, (get_ob a,,α (get_ob a) (get_el a))). intros b c f. exists (get_mor f). abstract (exact (!eqtohomot (pr2 α (get_ob b) (get_ob c) (get_mor f)) (get_el b) @ maponpaths (α (get_ob c)) (get_eqn f))). Defined. Lemma cat_of_elems_on_nat_trans_is_functor (α : X ⟹ Y) : is_functor (cat_of_elems_on_nat_trans_data α). Proof. split. - now intros a; apply cat_of_elems_mor_eq. - now intros a b c f g; apply cat_of_elems_mor_eq. Qed. Definition cat_of_elems_on_nat_trans (α : X ⟹ Y) : ∫ X ⟶ ∫ Y := (cat_of_elems_on_nat_trans_data α,,cat_of_elems_on_nat_trans_is_functor α). (* maybe make a functor [C,SET] ⟶ [category of Precategories] *) (** The forgetful functor from the category of elements to C *) Definition cat_of_elems_forgetful : ∫ X ⟶ C. Proof. use make_functor. - exists pr1. intros a b; apply pr1. - now split. Defined. Lemma reflects_isos_cat_of_elems_forgetful : reflects_isos cat_of_elems_forgetful. Proof. intros [c x] [d y] f Hf. apply is_iso_from_is_z_iso. assert (H := is_z_iso_from_is_iso _ Hf); clear Hf. destruct f as [f i]; destruct H as [f' j]. assert (i' : #X f' y = x). { intermediate_path (#X f' (#X f x)). - exact (maponpaths (#X f') (!i)). - intermediate_path (#X (f' ∘ f) x). + exact (eqtohomot (!functor_comp X f f') x). + intermediate_path (#X (identity c) x). * exact (eqtohomot (maponpaths #X (pr1 j)) x). * exact (eqtohomot (functor_id X c) x). } exists (f' ,, i'). split; apply cat_of_elems_mor_eq; [ exact (pr1 j) | exact (pr2 j) ]. Qed. End cat_of_elems_theory. *) UniMath-20231010/UniMath/CategoryTheory/ElementsOp.v000066400000000000000000000162761451125700300221020ustar00rootroot00000000000000(** **************************************************************************** The category of elements of a presheaf "F : C^op ⟶ HSET" Contents: - Category of elements ([cat_of_elems]) - Functoriality of the constructon of the category of elements ([cat_of_elems_on_nat_trans]) - The forgetful functor from the category of elements to C ([cat_of_elems_forgetful]) Originally written by: Matthew Weaver (based on Elements.v by Dan Grayson) Ported to CT by: Anders Mörtberg *******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Section cat_of_elems_def. Context {C : category} (X : C^op ⟶ HSET). Definition cat_of_elems_ob_mor : precategory_ob_mor. Proof. exists (∑ (c : C), X c : hSet). intros a b. apply (∑ (f : C⟦pr1 a,pr1 b⟧), (pr2 a) = # X f (pr2 b)). Defined. Definition cat_of_elems_data : precategory_data. Proof. exists cat_of_elems_ob_mor. split. + intros a. exists (identity (pr1 a)). abstract (exact (eqtohomot (!(functor_id X) (pr1 a)) (pr2 a))). + intros a b c f g. exists (pr1 f · pr1 g). abstract (exact ((pr2 f) @ maponpaths (#X (pr1 f)) (pr2 g) @ (eqtohomot (!(functor_comp X) (pr1 g) (pr1 f)) (pr2 c)))). Defined. Definition get_mor {x y : cat_of_elems_data} (f : _⟦x,y⟧) := pr1 f. Lemma cat_of_elems_mor_eq (x y : cat_of_elems_data) (f g : _⟦x,y⟧) : get_mor f = get_mor g → f = g. Proof. intros p. apply subtypePath. - intro r; apply setproperty. - exact p. Qed. Lemma is_precategory_cat_of_elems_data : is_precategory cat_of_elems_data. Proof. split; [split|split]; intros; apply cat_of_elems_mor_eq. + apply id_left. + apply id_right. + apply assoc. + apply assoc'. Defined. Definition precat_of_elems : precategory := (cat_of_elems_data,,is_precategory_cat_of_elems_data). End cat_of_elems_def. Arguments get_mor {_ _ _ _} _. Lemma has_homsets_cat_of_elems {C : category} (X : C^op ⟶ HSET) : has_homsets (precat_of_elems X). Proof. intros a b. apply isaset_total2. - apply C. - intro f. apply isasetaprop, setproperty. Qed. Definition cat_of_elems {C : category} (X : C^op ⟶ HSET) : category := make_category _ (has_homsets_cat_of_elems X). (** Type as \int in Agda mode *) Notation "∫ X" := (cat_of_elems X) (at level 3) : cat. Section cat_of_elems_theory. Context {C : category} {X Y : C^op ⟶ HSET}. Definition get_ob (x : ∫ X) : C := pr1 x. Definition get_el (x : ∫ X) : X (get_ob x) : hSet := pr2 x. Definition get_eqn {x y : ∫ X} (f : (∫ X)⟦x,y⟧) : get_el x = # X (get_mor f) (get_el y) := pr2 f. Definition make_ob (c : C) (x : X c : hSet) : ∫ X := (c,,x). Definition make_mor (r s : ∫ X) (f : C⟦get_ob r,get_ob s⟧) (i : get_el r = # X f (get_el s)) : (∫ X)⟦r,s⟧ := (f,,i). (* Any f : J → I and ρ : X I defines a morphism from (J,,# X ρ) to (I,,ρ) in ∫ X *) Definition mor_to_el_mor {I J : C} (f : J --> I) (ρ : pr1 X I : hSet) : ∫ X ⟦ make_ob J (# (pr1 X) f ρ), make_ob I ρ ⟧ := make_mor (J,,# (pr1 X) f ρ) (I,,ρ) f (idpath (# (pr1 X) f ρ)). Lemma base_paths_maponpaths_make_ob {I : C} x y (e : x = y) : base_paths _ _ (maponpaths (make_ob I) e) = idpath I. Proof. now induction e. Qed. Lemma transportf_make_ob_eq {I J} (f : C⟦J,I⟧) {a b} (e : make_ob J a = make_ob J b) : transportf (λ x : ∫ X, C⟦pr1 x,I⟧) e f = transportf (λ x, C⟦x,I⟧) (base_paths _ _ e) f. Proof. now induction e. Qed. Lemma transportf_make_ob {A : PreShv (∫ X)} {I : C} {x y} (e : x = y) (u : pr1 (pr1 A (make_ob I x))) : transportf (λ x, pr1 (pr1 A (make_ob I x))) e u = transportf (λ x, pr1 (pr1 A x)) (maponpaths (make_ob I) e) u. Proof. now induction e. Qed. Lemma make_ob_identity_eq {I : C} (ρ : pr1 (pr1 X I)) : make_ob I (# (pr1 X) (identity I) ρ) = make_ob I ρ. Proof. exact (maponpaths (make_ob I) (eqtohomot (functor_id X I) ρ)). Defined. Lemma mor_to_el_mor_id {I : C} (ρ : pr1 (pr1 X I)) : mor_to_el_mor (identity I) ρ = transportb (λ Z, ∫ X⟦Z, make_ob I ρ⟧) (make_ob_identity_eq ρ) (identity _). Proof. apply (@transportf_transpose_right _ (λ Z : ∫ X, ∫ X ⟦Z,_⟧)), cat_of_elems_mor_eq; simpl. unfold transportb; rewrite pathsinv0inv0. rewrite transportf_total2; simpl; rewrite transportf_make_ob_eq. now unfold make_ob_identity_eq; rewrite base_paths_maponpaths_make_ob, idpath_transportf. Qed. Lemma make_ob_comp_eq {I J K} (ρ : pr1 (pr1 X I)) (f : C^op⟦I,J⟧) (g : C^op⟦J,K⟧) : make_ob _ (# (pr1 X) (f · g) ρ) = make_ob _ (# (pr1 X) g (# (pr1 X) f ρ)). Proof. exact (maponpaths (make_ob K) (eqtohomot (functor_comp X f g) ρ)). Defined. Lemma mor_to_el_mor_comp {I J K} (ρ : pr1 (pr1 X I)) (f : C^op⟦I,J⟧) (g : C^op⟦J,K⟧) : mor_to_el_mor (f · g) ρ = transportb (λ Z, ∫ X⟦Z,_⟧) (make_ob_comp_eq ρ f g) (mor_to_el_mor g (# (pr1 X) f ρ) · mor_to_el_mor f ρ). Proof. apply (@transportf_transpose_right _ (λ Z : ∫ X, ∫ X ⟦Z,_⟧)), cat_of_elems_mor_eq; simpl. unfold transportb; rewrite pathsinv0inv0. rewrite transportf_total2; simpl; rewrite transportf_make_ob_eq. now unfold make_ob_comp_eq; rewrite base_paths_maponpaths_make_ob, idpath_transportf. Qed. (** Functoriality of the construction of the category of elements *) Definition cat_of_elems_on_nat_trans_data (α : X ⟹ Y) : functor_data (∫ X) (∫ Y). Proof. exists (λ a, (get_ob a,, α (get_ob a) (get_el a))). intros b c f. exists (get_mor f). abstract (exact (maponpaths (α (get_ob b)) (get_eqn f) @ eqtohomot (pr2 α (get_ob c) (get_ob b) (get_mor f)) (get_el c))). Defined. Lemma cat_of_elems_on_nat_trans_is_functor (α : X ⟹ Y) : is_functor (cat_of_elems_on_nat_trans_data α). Proof. split. - now intros a; apply cat_of_elems_mor_eq. - now intros a b c f g; apply cat_of_elems_mor_eq. Qed. Definition cat_of_elems_on_nat_trans (α : X ⟹ Y) : ∫ X ⟶ ∫ Y := (cat_of_elems_on_nat_trans_data α,, cat_of_elems_on_nat_trans_is_functor α). (* maybe make a functor [C,SET] ⟶ [category of Precategories] *) (** The forgetful functor from the category of elements to C *) Definition cat_of_elems_forgetful : ∫ X ⟶ C. Proof. use make_functor. - exists pr1. intros a b; apply pr1. - now split. Defined. Lemma reflects_isos_cat_of_elems_forgetful : reflects_isos cat_of_elems_forgetful. Proof. intros [c x] [d y] f Hf. destruct f as [f i]; destruct Hf as [f' j]. assert (i' : y = #X f' x). { intermediate_path (#X (identity d) y). - exact (eqtohomot (!functor_id X d) y). - intermediate_path (#X (f ∘ f') y). + exact (eqtohomot (!maponpaths #X (pr2 j)) y). + intermediate_path (#X f' (#X f y)). * exact (eqtohomot ((functor_comp X) f f') y). * exact (maponpaths (#X f') (!i)). } exists (f',,i'). split; apply cat_of_elems_mor_eq; [ exact (pr1 j) | exact (pr2 j) ]. Qed. End cat_of_elems_theory. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/000077500000000000000000000000001451125700300221605ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/000077500000000000000000000000001451125700300237435ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/CopowerFunctor.v000066400000000000000000000234621451125700300271200ustar00rootroot00000000000000(********************************************************************** Functoriality of copowers In this file, we show that the copower is functorial. In addition, we prove various useful lemmas. Contents 1. Action on objects 2. Precomposition with copower functions 3. Action on morphisms 4. Enriched action on morphisms 5. Functoriality 6. Copowers on morphism objects **********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Import MonoidalNotations. Local Open Scope moncat. Local Open Scope cat. Section CopowerFunctor. Context {V : sym_mon_closed_cat} {C : category} {EC : enrichment C V} (copowC : enrichment_copower EC). (** 1. Action on objects *) Definition copow_ob (v : V) (r : C) : C := pr1 (copowC v r). Definition mor_of_copow_ob (v : V) (r : C) : v --> EC ⦃ r , copow_ob v r ⦄ := copower_cocone_mor _ _ _ (pr1 (copowC v r)). (** 2. Precomposition with copower functions *) Proposition arr_to_copower_precomp {v : V} {x y r : C} (f : I_{ V} --> v ⊸ (EC ⦃ r , x ⦄)) (g : x --> y) : arr_to_copower _ _ _ (pr2 (copowC v r)) f · g = arr_to_copower _ _ _ (pr2 (copowC v r)) (f · internal_postcomp _ (postcomp_arr EC r g)). Proof. use arr_to_copower_eq. { exact (pr2 (copowC v r)). } refine (!_). etrans. { apply arr_to_copower_commutes. } use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_postcomp, is_copower_enriched_map. rewrite !internal_beta. rewrite tensor_split. refine (!_). etrans. { rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_comp_l_id_l. apply idpath. } rewrite !assoc'. apply maponpaths. rewrite enriched_from_arr_comp. rewrite !assoc. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite enrichment_assoc. unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { do 4 apply maponpaths_2. exact (!(arr_to_copower_commutes EC _ _ (pr2 (copowC v r)) f)). } rewrite !tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. unfold is_copower_enriched_map. rewrite internal_beta. apply idpath. } rewrite !assoc. rewrite <- tensor_split'. refine (!_). etrans. { apply maponpaths_2. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite tensor_split. rewrite !assoc'. rewrite mon_linvunitor_triangle. rewrite tensor_linvunitor. apply idpath. } rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. rewrite tensor_split. apply idpath. } rewrite !assoc'. rewrite tensor_comp_l_id_r. apply idpath. } rewrite !assoc'. apply maponpaths. rewrite <- !tensor_comp_mor. rewrite id_left, !id_right. apply idpath. Qed. (** 3. Action on morphisms *) Definition copow_mor {v₁ v₂ : V} (f : v₁ --> v₂) (r : C) : copow_ob v₁ r --> copow_ob v₂ r. Proof. use arr_to_copower. { exact (pr2 (copowC v₁ r)). } exact (internal_lam (mon_lunitor _ · f · mor_of_copow_ob v₂ r)). Defined. Proposition copow_mor_commute {v₁ v₂ : V} (f : v₁ --> v₂) (r : C) : enriched_from_arr EC (copow_mor f r) · is_copower_enriched_map EC v₁ r _ _ = internal_lam (mon_lunitor _ · f · mor_of_copow_ob v₂ r). Proof. apply arr_to_copower_commutes. Qed. (** 4. Enriched action on morphisms *) Definition copow_enriched_mor (v₁ v₂ : V) (r : C) : v₁ ⊸ v₂ --> EC ⦃ copow_ob v₁ r , copow_ob v₂ r ⦄. Proof. use mor_to_copower. { exact (pr2 (copowC v₁ r)). } use internal_postcomp. apply mor_of_copow_ob. Defined. Proposition copow_enriched_mor_commute (v₁ v₂ : V) (r : C) : (copow_enriched_mor v₁ v₂ r · is_copower_enriched_map EC v₁ r _ _) #⊗ identity v₁ · internal_eval v₁ _ = internal_eval v₁ v₂ · mor_of_copow_ob v₂ r. Proof. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (mor_to_copower_commutes EC v₁ r (pr2 (copowC v₁ r)) (internal_postcomp _ (mor_of_copow_ob v₂ r)))) as p. cbn in p. unfold internal_postcomp in p. rewrite !internal_beta in p. exact p. Qed. (** 5. Functoriality *) Proposition copow_id_mor (v : V) (r : C) : copow_mor (identity v) r = identity _. Proof. use arr_to_copower_eq. { exact (pr2 (copowC v r)). } refine (copow_mor_commute (identity v) r @ _). rewrite enriched_from_arr_id. unfold is_copower_enriched_map. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite tensor_split. rewrite !assoc'. rewrite !internal_beta. rewrite id_left. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply idpath. Qed. Proposition copow_comp_mor {v₁ v₂ v₃ : V} (f : v₁ --> v₂) (g : v₂ --> v₃) (r : C) : copow_mor (f · g) r = copow_mor f r · copow_mor g r. Proof. use arr_to_copower_eq. { exact (pr2 (copowC v₁ r)). } refine (copow_mor_commute (f · g) r @ _). refine (!_). etrans. { apply maponpaths_2. apply maponpaths. apply arr_to_copower_precomp. } etrans. { apply arr_to_copower_commutes. } use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite tensor_split. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. unfold internal_postcomp. rewrite !internal_beta. rewrite !assoc. rewrite !internal_beta. rewrite !assoc'. do 2 apply maponpaths. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (copow_mor_commute g r)) as p. cbn in p. rewrite !tensor_comp_r_id_r in p. rewrite !assoc' in p. unfold is_copower_enriched_map in p. rewrite !internal_beta in p. rewrite !assoc in p. rewrite <- tensor_split' in p. refine (!(id_left _) @ _). rewrite <- mon_linvunitor_lunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. exact (!p). } unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. apply idpath. Qed. (** 6. Copowers on morphism objects *) Definition copow_on_enriched_mor (r₁ r₂ : C) : copow_ob (EC ⦃ r₁ , r₂ ⦄) r₁ --> r₂. Proof. use arr_to_copower. { exact (pr2 (copowC _ _)). } exact (internal_from_arr (identity _)). Defined. Proposition copow_on_enriched_mor_commute (r₁ r₂ : C) : (enriched_from_arr EC (copow_on_enriched_mor r₁ r₂) · is_copower_enriched_map EC _ _ _ _) #⊗ identity _ · internal_eval _ _ = mon_lunitor _. Proof. etrans. { do 2 apply maponpaths_2. apply arr_to_copower_commutes. } unfold internal_from_arr. rewrite internal_beta. apply id_right. Qed. Proposition precomp_copow_on_enriched_mor_commute (x r₁ r₂ : C) : (precomp_arr EC x (copow_on_enriched_mor r₁ r₂) · is_copower_enriched_map EC _ _ _ _) #⊗ identity _ · internal_eval _ _ = enriched_comp EC r₁ r₂ x. Proof. rewrite !tensor_comp_r_id_r. unfold is_copower_enriched_map. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. unfold precomp_arr. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- mon_inv_triangle. apply idpath. } rewrite <- !tensor_comp_id_l. rewrite <- tensor_id_id. apply maponpaths. rewrite tensor_linvunitor. refine (_ @ mon_linvunitor_lunitor _). rewrite !assoc'. apply maponpaths. refine (_ @ copow_on_enriched_mor_commute _ _). rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_split. rewrite <- tensor_split'. apply idpath. Qed. End CopowerFunctor. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedBinaryCoproducts.v000066400000000000000000000507341451125700300310770ustar00rootroot00000000000000(***************************************************************** Coproducts in enriched categories In this file, we define the notion of coproducts for enriched categories. The idea is the same as for initial objects: we need to express the universal property in the arbitrary monoidal categories instead of just set. Let `x` and `y` be objects of a category `C` enriched over `V`. The coproduct `x + y` satisfies the following universal property: for every `z`, the hom object `C ⟦ x + y , z ⟧` is the product of the hom objects `C ⟦ x , z ⟧` and `C ⟦ y , z ⟧`. Contents 1. Cocones of enriched coproducts 2. Binary products in an enriched category 3. Being a binary coproduct is a proposition 4. Binary products in the underlying category 5. Builders for binary coproducts 6. Coproducts are closed under iso 7. Coproducts are isomorphic 8. Enriched categories with coproducts *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedCoproducts. Context {V : monoidal_cat} {C : category} (E : enrichment C V) (x y : C). (** 1. Cocones of enriched coproducts *) Definition enriched_binary_coprod_cocone : UU := ∑ (a : C), I_{V} --> E ⦃ x , a ⦄ × I_{V} --> E ⦃ y , a ⦄. Coercion ob_enriched_binary_coprod_cocone (a : enriched_binary_coprod_cocone) : C := pr1 a. Definition enriched_coprod_cocone_in1 (a : enriched_binary_coprod_cocone) : x --> a := enriched_to_arr E (pr12 a). Definition enriched_coprod_cocone_in2 (a : enriched_binary_coprod_cocone) : y --> a := enriched_to_arr E (pr22 a). Definition make_enriched_binary_coprod_cocone (a : C) (p₁ : I_{V} --> E ⦃ x , a ⦄) (p₂ : I_{V} --> E ⦃ y , a ⦄) : enriched_binary_coprod_cocone := a ,, p₁ ,, p₂. (** 2. Binary products in an enriched category *) Definition is_binary_coprod_enriched (a : enriched_binary_coprod_cocone) : UU := ∏ (w : C), isBinProduct V (E ⦃ x , w ⦄) (E ⦃ y , w ⦄) (E ⦃ a , w ⦄) (precomp_arr E w (enriched_coprod_cocone_in1 a)) (precomp_arr E w (enriched_coprod_cocone_in2 a)). Definition is_binary_coprod_enriched_to_BinProduct {a : enriched_binary_coprod_cocone} (Ha : is_binary_coprod_enriched a) (w : C) : BinProduct V (E ⦃ x , w ⦄) (E ⦃ y , w ⦄). Proof. use make_BinProduct. - exact (E ⦃ a , w ⦄). - exact (precomp_arr E w (enriched_coprod_cocone_in1 a)). - exact (precomp_arr E w (enriched_coprod_cocone_in2 a)). - exact (Ha w). Defined. Definition binary_coprod_enriched : UU := ∑ (a : enriched_binary_coprod_cocone), is_binary_coprod_enriched a. Coercion cone_of_binary_coprod_enriched (a : binary_coprod_enriched) : enriched_binary_coprod_cocone := pr1 a. Coercion binary_coprod_enriched_is_coprod (a : binary_coprod_enriched) : is_binary_coprod_enriched a := pr2 a. (** 3. Being a binary coproduct is a proposition *) Proposition isaprop_is_binary_coprod_enriched (a : enriched_binary_coprod_cocone) : isaprop (is_binary_coprod_enriched a). Proof. use impred ; intro. apply isaprop_isBinProduct. Qed. (** 4. Binary products in the underlying category *) Section InUnderlying. Context {a : enriched_binary_coprod_cocone} (Ha : is_binary_coprod_enriched a). Definition is_binary_coprod_enriched_arrow {w : C} (f : x --> w) (g : y --> w) : a --> w. Proof. refine (enriched_to_arr E _). use (BinProductArrow _ (is_binary_coprod_enriched_to_BinProduct Ha w)). - exact (enriched_from_arr E f). - exact (enriched_from_arr E g). Defined. Proposition is_binary_coprod_enriched_arrow_in1 {w : C} (f : x --> w) (g : y --> w) : enriched_coprod_cocone_in1 a · is_binary_coprod_enriched_arrow f g = f. Proof. unfold is_binary_coprod_enriched_arrow, enriched_coprod_cocone_in1. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ BinProductPr1Commutes _ _ _ (is_binary_coprod_enriched_to_BinProduct Ha w) _ (enriched_from_arr E f) (enriched_from_arr E g)). cbn. unfold precomp_arr, enriched_coprod_cocone_in1. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite !enriched_from_to_arr. rewrite tensor_rinvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split'. apply idpath. Qed. Proposition is_binary_coprod_enriched_arrow_in2 {w : C} (f : x --> w) (g : y --> w) : enriched_coprod_cocone_in2 a · is_binary_coprod_enriched_arrow f g = g. Proof. unfold is_binary_coprod_enriched_arrow, enriched_coprod_cocone_in2. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ BinProductPr2Commutes _ _ _ (is_binary_coprod_enriched_to_BinProduct Ha w) _ (enriched_from_arr E f) (enriched_from_arr E g)). cbn. unfold precomp_arr, enriched_coprod_cocone_in2. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite !enriched_from_to_arr. rewrite tensor_rinvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split'. apply idpath. Qed. Proposition is_binary_coprod_enriched_arrow_eq {w : C} {f g : a --> w} (q₁ : enriched_coprod_cocone_in1 a · f = enriched_coprod_cocone_in1 a · g) (q₂ : enriched_coprod_cocone_in2 a · f = enriched_coprod_cocone_in2 a · g) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (BinProductArrowsEq _ _ _ (is_binary_coprod_enriched_to_BinProduct Ha w)). - cbn. unfold precomp_arr. rewrite !assoc. rewrite !tensor_rinvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split'. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite <- !(enriched_to_arr_comp E). exact q₁. - cbn. unfold precomp_arr. rewrite !assoc. rewrite !tensor_rinvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split'. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite <- !(enriched_to_arr_comp E). exact q₂. Qed. Definition underlying_BinCoproduct : BinCoproduct x y. Proof. use make_BinCoproduct. - exact a. - exact (enriched_coprod_cocone_in1 a). - exact (enriched_coprod_cocone_in2 a). - intros w f g. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; exact (is_binary_coprod_enriched_arrow_eq (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). + exact (is_binary_coprod_enriched_arrow f g ,, is_binary_coprod_enriched_arrow_in1 f g ,, is_binary_coprod_enriched_arrow_in2 f g). Defined. End InUnderlying. (** 5. Builders for binary coproducts *) Definition make_is_binary_coprod_enriched (a : enriched_binary_coprod_cocone) (sum : ∏ (w : C) (v : V) (f : v --> E ⦃ x , w ⦄) (g : v --> E ⦃ y , w ⦄), v --> E ⦃ a , w ⦄) (sum_in1 : ∏ (w : C) (v : V) (f : v --> E ⦃ x , w ⦄) (g : v --> E ⦃ y , w ⦄), sum w v f g · precomp_arr E w (enriched_coprod_cocone_in1 a) = f) (sum_in2 : ∏ (w : C) (v : V) (f : v --> E ⦃ x , w ⦄) (g : v --> E ⦃ y , w ⦄), sum w v f g · precomp_arr E w (enriched_coprod_cocone_in2 a) = g) (sum_eq : ∏ (w : C) (v : V) (φ₁ φ₂ : v --> E ⦃ a , w ⦄) (q₁ : φ₁ · precomp_arr E w (enriched_coprod_cocone_in1 a) = φ₂ · precomp_arr E w (enriched_coprod_cocone_in1 a)) (q₂ : φ₁ · precomp_arr E w (enriched_coprod_cocone_in2 a) = φ₂ · precomp_arr E w (enriched_coprod_cocone_in2 a)), φ₁ = φ₂) : is_binary_coprod_enriched a. Proof. intro w. use make_isBinProduct. intros v f g. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; exact (sum_eq w v (pr1 φ₁) (pr1 φ₂) (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). - simple refine (_ ,, _ ,, _). + exact (sum w v f g). + exact (sum_in1 w v f g). + exact (sum_in2 w v f g). Defined. Definition binary_coprod_enriched_to_coprod (BPV : BinProducts V) (a : enriched_binary_coprod_cocone) (w : C) : E ⦃ a , w ⦄ --> BPV (E ⦃ x , w ⦄) (E ⦃ y , w ⦄). Proof. use BinProductArrow. - exact (precomp_arr E w (enriched_coprod_cocone_in1 a)). - exact (precomp_arr E w (enriched_coprod_cocone_in2 a)). Defined. Definition make_is_binary_coprod_enriched_from_z_iso (BPV : BinProducts V) (a : enriched_binary_coprod_cocone) (Ha : ∏ (w : C), is_z_isomorphism (binary_coprod_enriched_to_coprod BPV a w)) : is_binary_coprod_enriched a. Proof. intro w. use (isBinProduct_z_iso (pr2 (BPV (E ⦃ x , w ⦄) (E ⦃ y , w ⦄))) (_ ,, Ha w) _). - abstract (unfold binary_coprod_enriched_to_coprod ; cbn ; refine (!_) ; apply BinProductPr1Commutes). - abstract (unfold binary_coprod_enriched_to_coprod ; cbn ; refine (!_) ; apply BinProductPr2Commutes). Defined. Section BinaryCoproductFromUnderlying. Context (BPV : BinProducts V) (a : enriched_binary_coprod_cocone) (coprod : isBinCoproduct C x y a (enriched_coprod_cocone_in1 a) (enriched_coprod_cocone_in2 a)) (w : C). Definition coprod_from_underlying_arr_map (f : I_{V} --> BPV (E ⦃ x , w ⦄) (E ⦃ y , w ⦄)) : I_{V} --> E ⦃ a , w ⦄. Proof. apply enriched_from_arr. use (BinCoproductArrow (make_BinCoproduct _ _ _ _ _ _ coprod)). - exact (enriched_to_arr E (f · BinProductPr1 _ _)). - exact (enriched_to_arr E (f · BinProductPr2 _ _)). Defined. Proposition coprod_from_underlying_arr_map_eq₁ (f : I_{V} --> E ⦃ a , w ⦄) : coprod_from_underlying_arr_map (f · binary_coprod_enriched_to_coprod BPV a w) = f. Proof. unfold coprod_from_underlying_arr_map. refine (_ @ enriched_from_to_arr E f). apply maponpaths. use (BinCoproductArrowsEq _ _ _ (make_BinCoproduct C x y a _ _ coprod)). - unfold binary_coprod_enriched_to_coprod. rewrite !assoc'. rewrite !BinProductPr1Commutes. rewrite !BinCoproductIn1Commutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. unfold precomp_arr. rewrite !assoc. rewrite tensor_rinvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite enriched_from_to_arr. rewrite <- tensor_split'. apply idpath. - unfold binary_coprod_enriched_to_coprod. rewrite !assoc'. rewrite !BinProductPr2Commutes. rewrite !BinCoproductIn2Commutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. unfold precomp_arr. rewrite !assoc. rewrite tensor_rinvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite enriched_from_to_arr. rewrite <- tensor_split'. apply idpath. Qed. Proposition coprod_from_underlying_arr_map_eq₂ (f : I_{V} --> BPV (E ⦃ x , w ⦄) (E ⦃ y , w ⦄)) : coprod_from_underlying_arr_map f · binary_coprod_enriched_to_coprod BPV a w = f. Proof. unfold coprod_from_underlying_arr_map. use (BinProductArrowsEq _ _ _ (BPV (E ⦃ x , w ⦄) (E ⦃ y , w ⦄))). - unfold binary_coprod_enriched_to_coprod. rewrite !assoc'. rewrite !BinProductPr1Commutes. rewrite enriched_from_arr_precomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct C x y a _ _ coprod)). - unfold binary_coprod_enriched_to_coprod. rewrite !assoc'. rewrite !BinProductPr2Commutes. rewrite enriched_from_arr_precomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct C x y a _ _ coprod)). Qed. End BinaryCoproductFromUnderlying. Definition make_is_binary_coprod_enriched_from_underlying (BPV : BinProducts V) (a : enriched_binary_coprod_cocone) (prod : isBinCoproduct C x y a (enriched_coprod_cocone_in1 a) (enriched_coprod_cocone_in2 a)) (HV : conservative_moncat V) : is_binary_coprod_enriched a. Proof. use (make_is_binary_coprod_enriched_from_z_iso BPV). intros w. use HV. use isweq_iso. - exact (coprod_from_underlying_arr_map BPV a prod w). - exact (coprod_from_underlying_arr_map_eq₁ BPV a prod w). - exact (coprod_from_underlying_arr_map_eq₂ BPV a prod w). Defined. (** 6. Coproducts are closed under iso *) Section CoprodIso. Context (a : enriched_binary_coprod_cocone) (Ha : is_binary_coprod_enriched a) (b : C) (f : z_iso a b). Definition enriched_binary_prod_cone_from_iso : enriched_binary_coprod_cocone := make_enriched_binary_coprod_cocone b (enriched_from_arr E (enriched_coprod_cocone_in1 a · f)) (enriched_from_arr E (enriched_coprod_cocone_in2 a · f)). Definition is_binary_coprod_enriched_from_iso : is_binary_coprod_enriched enriched_binary_prod_cone_from_iso. Proof. intros w. use (isBinProduct_z_iso (Ha w)). - exact (precomp_arr_z_iso E w f). - abstract (cbn ; rewrite <- precomp_arr_comp ; apply maponpaths ; unfold enriched_binary_prod_cone_from_iso ; cbn ; unfold enriched_coprod_cocone_in1 ; cbn ; rewrite enriched_to_from_arr ; apply idpath). - abstract (cbn ; rewrite <- precomp_arr_comp ; apply maponpaths ; unfold enriched_binary_prod_cone_from_iso ; cbn ; unfold enriched_coprod_cocone_in2 ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End CoprodIso. (** 7. Coproducts are isomorphic *) Definition map_between_coproduct_enriched {a b : enriched_binary_coprod_cocone} (Ha : is_binary_coprod_enriched a) (Hb : is_binary_coprod_enriched b) : a --> b := is_binary_coprod_enriched_arrow Ha (enriched_coprod_cocone_in1 b) (enriched_coprod_cocone_in2 b). Lemma iso_between_coproduct_enriched_inv {a b : enriched_binary_coprod_cocone} (Ha : is_binary_coprod_enriched a) (Hb : is_binary_coprod_enriched b) : map_between_coproduct_enriched Ha Hb · map_between_coproduct_enriched Hb Ha = identity _. Proof. unfold map_between_coproduct_enriched. use (is_binary_coprod_enriched_arrow_eq Ha). - rewrite !assoc. rewrite !is_binary_coprod_enriched_arrow_in1. rewrite id_right. apply idpath. - rewrite !assoc. rewrite !is_binary_coprod_enriched_arrow_in2. rewrite id_right. apply idpath. Qed. Definition iso_between_coproduct_enriched {a b : enriched_binary_coprod_cocone} (Ha : is_binary_coprod_enriched a) (Hb : is_binary_coprod_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_coproduct_enriched Ha Hb). - exact (map_between_coproduct_enriched Hb Ha). - split. + apply iso_between_coproduct_enriched_inv. + apply iso_between_coproduct_enriched_inv. Defined. End EnrichedCoproducts. (** 8. Enriched categories with coproducts *) Definition enrichment_binary_coprod {V : monoidal_cat} {C : category} (E : enrichment C V) : UU := ∏ (x y : C), ∑ (a : enriched_binary_coprod_cocone E x y), is_binary_coprod_enriched E x y a. Proposition isaprop_enrichment_binary_coprod {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) : isaprop (enrichment_binary_coprod E). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro x. use funextsec ; intro y. use subtypePath. { intro. apply isaprop_is_binary_coprod_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_coproduct_enriched. + exact (pr2 (φ₁ x y)). + exact (pr2 (φ₂ x y)). - rewrite transportf_dirprod. use pathsdirprod. + rewrite transportf_enriched_arr_r. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_coproduct_enriched ; cbn. apply is_binary_coprod_enriched_arrow_in1. + rewrite transportf_enriched_arr_r. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_coproduct_enriched ; cbn. apply is_binary_coprod_enriched_arrow_in2. Qed. Definition cat_with_enrichment_coproduct (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_binary_coprod C. Coercion cat_with_enrichment_coproduct_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_coproduct V) : cat_with_enrichment V := pr1 C. Definition coproducts_of_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_coproduct V) : enrichment_binary_coprod C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedCoequalizers.v000066400000000000000000000441621451125700300302510ustar00rootroot00000000000000(***************************************************************** Coequalizers in enriched categories In this file, we define coequalizers in enriched categories. In addition, we show that they give rise to coequalizers in the underlying categories, and we show several properties of them. One way to formulate the universal property of coequalizers, is by expressing them as a natural bijection between two homsets. A morphism from the coequalizer of `f : x --> y` and `g : x --> y` to some `z` is the same a morphism `y --> z` that makes a certain diagram commute. For enriched categories, we formulate this universal property in the monoidal category `V`. Contents 1. Cones of enriched coequalizers 2. Coequalizers in an enriched category 3. Being an coequalizer is a proposition 4. Coequalizers in the underlying category 5. Builders for coequalizers 6. Coequalizers are closed under iso 7. Enriched categories with products *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedCoequalizer. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {x y : C} (f g : x --> y). (** 1. Cones of enriched coequalizers *) Definition enriched_coequalizer_cocone : UU := ∑ (a : C) (p : I_{V} --> E ⦃ y , a ⦄), f · enriched_to_arr E p = g · enriched_to_arr E p. Coercion ob_enriched_coequalizer_cocone (a : enriched_coequalizer_cocone) : C := pr1 a. Definition enriched_coequalizer_cocone_in (a : enriched_coequalizer_cocone) : y --> a := enriched_to_arr E (pr12 a). Definition enriched_coequalizer_cocone_eq (a : enriched_coequalizer_cocone) : f · enriched_coequalizer_cocone_in a = g · enriched_coequalizer_cocone_in a := pr22 a. Definition make_enriched_coequalizer_cocone (a : C) (p : I_{V} --> E ⦃ y , a ⦄) (q : f · enriched_to_arr E p = g · enriched_to_arr E p) : enriched_coequalizer_cocone := a ,, p ,, q. Proposition precomp_eq_from_coequalizer_cocone (a : enriched_coequalizer_cocone) (w : C) : precomp_arr E w (enriched_coequalizer_cocone_in a) · precomp_arr E w f = precomp_arr E w (enriched_coequalizer_cocone_in a) · precomp_arr E w g. Proof. rewrite <- !precomp_arr_comp. apply maponpaths. apply enriched_coequalizer_cocone_eq. Qed. (** 2. Coequalizers in an enriched category *) Definition is_coequalizer_enriched (a : enriched_coequalizer_cocone) : UU := ∏ (w : C), isEqualizer (precomp_arr E w f) (precomp_arr E w g) (precomp_arr E w (enriched_coequalizer_cocone_in a)) (precomp_eq_from_coequalizer_cocone a w). Definition is_coequalizer_enriched_to_Equalizer {a : enriched_coequalizer_cocone} (Ha : is_coequalizer_enriched a) (w : C) : Equalizer (precomp_arr E w f) (precomp_arr E w g). Proof. use make_Equalizer. - exact (E ⦃ a , w ⦄). - exact (precomp_arr E w (enriched_coequalizer_cocone_in a)). - exact (precomp_eq_from_coequalizer_cocone a w). - exact (Ha w). Defined. Definition coequalizer_enriched : UU := ∑ (a : enriched_coequalizer_cocone), is_coequalizer_enriched a. Coercion cocone_of_coequalizer_enriched (a : coequalizer_enriched) : enriched_coequalizer_cocone := pr1 a. Coercion coequalizer_enriched_is_coequalizer (a : coequalizer_enriched) : is_coequalizer_enriched a := pr2 a. (** 3. Being an coequalizer is a proposition *) Proposition isaprop_is_coequalizer_enriched (a : enriched_coequalizer_cocone) : isaprop (is_coequalizer_enriched a). Proof. use impred ; intro. apply isaprop_isEqualizer. Qed. (** 4. Coequalizers in the underlying category *) Section InUnderlying. Context {a : enriched_coequalizer_cocone} (Ha : is_coequalizer_enriched a). Definition underlying_Coequalizer_arr {w : C} (h : y --> w) (q : f · h = g · h) : a --> w. Proof. use (enriched_to_arr E). use (EqualizerIn (is_coequalizer_enriched_to_Equalizer Ha w)). - exact (enriched_from_arr E h). - abstract (rewrite !enriched_from_arr_precomp ; rewrite q ; apply idpath). Defined. Proposition underlying_Coequalizer_arr_in {w : C} (h : y --> w) (q : f · h = g · h) : enriched_coequalizer_cocone_in a · underlying_Coequalizer_arr h q = h. Proof. unfold underlying_Coequalizer_arr, enriched_coequalizer_cocone_in. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. rewrite enriched_from_arr_comp. rewrite !enriched_from_to_arr. refine (_ @ EqualizerCommutes (is_coequalizer_enriched_to_Equalizer Ha w) I_{V} (enriched_from_arr E h) _). rewrite tensor_split'. rewrite !assoc. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite <- tensor_rinvunitor. cbn. unfold precomp_arr. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. do 3 apply maponpaths. refine (!_). apply enriched_from_to_arr. Qed. Proposition underlying_Coequalizer_arr_eq {w : C} {h₁ h₂ : a --> w} (q : enriched_coequalizer_cocone_in a · h₁ = enriched_coequalizer_cocone_in a · h₂) : h₁ = h₂. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (EqualizerInsEq (is_coequalizer_enriched_to_Equalizer Ha w)). cbn. unfold precomp_arr. rewrite !assoc. rewrite !tensor_rinvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split'. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite <- !(enriched_to_arr_comp E). exact q. Qed. Definition underlying_Coequalizer : Coequalizer f g. Proof. use make_Coequalizer. - exact a. - exact (enriched_coequalizer_cocone_in a). - exact (enriched_coequalizer_cocone_eq a). - intros w h q. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; exact (underlying_Coequalizer_arr_eq (pr2 φ₁ @ !(pr2 φ₂)))). + exact (underlying_Coequalizer_arr h q ,, underlying_Coequalizer_arr_in h q). Defined. End InUnderlying. (** 5. Builders for coequalizers *) Definition make_is_coequalizer_enriched (a : enriched_coequalizer_cocone) (eq_arr_eq : ∏ (w : C) (v : V) (h₁ h₂ : v --> E ⦃ a , w ⦄) (q : h₁ · precomp_arr E w (enriched_coequalizer_cocone_in a) = h₂ · precomp_arr E w (enriched_coequalizer_cocone_in a)), h₁ = h₂) (eq_in : ∏ (w : C) (v : V) (h : v --> E ⦃ y , w ⦄) (q : h · precomp_arr E w f = h · precomp_arr E w g), v --> E ⦃ a , w ⦄) (eq_in_eq : ∏ (w : C) (v : V) (h : v --> E ⦃ y , w ⦄) (q : h · precomp_arr E w f = h · precomp_arr E w g), eq_in w v h q · precomp_arr E w (enriched_coequalizer_cocone_in a) = h) : is_coequalizer_enriched a. Proof. intro w. use make_isEqualizer. intros v h q. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; exact (eq_arr_eq w v _ _ (pr2 φ₁ @ !(pr2 φ₂)))). - exact (eq_in w v h q,, eq_in_eq w v h q). Defined. Definition coequalizer_enriched_to_equalizer (EqV : Equalizers V) (a : enriched_coequalizer_cocone) (w : C) : E ⦃ a , w ⦄ --> EqV (E ⦃ y , w ⦄) _ (precomp_arr E w f) (precomp_arr E w g). Proof. use EqualizerIn. - exact (precomp_arr E w (enriched_coequalizer_cocone_in a)). - exact (precomp_eq_from_coequalizer_cocone a w). Defined. Definition make_is_coequalizer_enriched_from_z_iso (EqV : Equalizers V) (a : enriched_coequalizer_cocone) (Ha : ∏ (w : C), is_z_isomorphism (coequalizer_enriched_to_equalizer EqV a w)) : is_coequalizer_enriched a. Proof. intro w. use (isEqualizer_z_iso (pr22 (EqV _ _ (precomp_arr E w f) (precomp_arr E w g))) (_ ,, Ha w)). abstract (unfold coequalizer_enriched_to_equalizer ; cbn ; refine (!_) ; apply EqualizerCommutes). Defined. Section CoequalizersFromUnderlying. Context (EqV : Equalizers V) (a : enriched_coequalizer_cocone) (eq_a : isCoequalizer f g (enriched_coequalizer_cocone_in a) (enriched_coequalizer_cocone_eq a)) (w : C). Definition coequalizer_enriched_from_underlying_map (h : I_{V} --> EqV _ _ (precomp_arr E w f) (precomp_arr E w g)) : I_{V} --> E ⦃ a , w ⦄. Proof. use enriched_from_arr. use (CoequalizerOut (make_Coequalizer _ _ _ _ eq_a)). - exact (enriched_to_arr E (h · EqualizerArrow _)). - abstract (use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn ; rewrite !enriched_from_arr_comp ; rewrite !enriched_from_to_arr ; rewrite tensor_split' ; rewrite !assoc ; rewrite !mon_linvunitor_I_mon_rinvunitor_I ; rewrite <- !tensor_rinvunitor ; rewrite !assoc' ; rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)) ; refine (maponpaths (λ z, _ · z) (EqualizerEqAr (EqV _ _ (precomp_arr E w f) (precomp_arr E w g))) @ _) ; refine (!_) ; rewrite tensor_split' ; rewrite !assoc ; rewrite <- tensor_rinvunitor ; rewrite !assoc' ; do 2 apply maponpaths ; unfold precomp_arr ; rewrite !assoc' ; apply idpath). Defined. Proposition coequalizer_enriched_from_underlying_map_inv₁ (h : I_{V} --> E ⦃ a , w ⦄) : coequalizer_enriched_from_underlying_map (h · coequalizer_enriched_to_equalizer EqV a w) = h. Proof. unfold coequalizer_enriched_from_underlying_map. refine (_ @ enriched_from_to_arr E h). apply maponpaths. use (isCoequalizerOutsEq eq_a). etrans. { apply (CoequalizerCommutes (make_Coequalizer _ _ _ _ eq_a)). } unfold enriched_coequalizer_cocone_in. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite tensor_split'. rewrite !assoc. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite <- tensor_rinvunitor. rewrite enriched_from_to_arr. rewrite !assoc'. apply maponpaths. unfold coequalizer_enriched_to_equalizer. rewrite EqualizerCommutes. rewrite !assoc. apply idpath. Qed. Proposition coequalizer_enriched_from_underlying_map_inv₂ (h : I_{V} --> EqV _ _ (precomp_arr E w f) (precomp_arr E w g)) : coequalizer_enriched_from_underlying_map h · coequalizer_enriched_to_equalizer EqV a w = h. Proof. unfold coequalizer_enriched_from_underlying_map. use (isEqualizerInsEq (pr22 (EqV _ _ _ _))). unfold coequalizer_enriched_to_equalizer. rewrite !assoc'. rewrite EqualizerCommutes. rewrite enriched_from_arr_precomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (CoequalizerCommutes (make_Coequalizer _ _ _ _ eq_a)). Qed. End CoequalizersFromUnderlying. Definition make_is_coequalizer_enriched_from_underlying (EqV : Equalizers V) (a : enriched_coequalizer_cocone) (eq_a : isCoequalizer f g (enriched_coequalizer_cocone_in a) (enriched_coequalizer_cocone_eq a)) (HV : conservative_moncat V) : is_coequalizer_enriched a. Proof. use (make_is_coequalizer_enriched_from_z_iso EqV). intros w. use HV. use isweq_iso. - exact (coequalizer_enriched_from_underlying_map EqV a eq_a w). - exact (coequalizer_enriched_from_underlying_map_inv₁ EqV a eq_a w). - exact (coequalizer_enriched_from_underlying_map_inv₂ EqV a eq_a w). Defined. (** 6. Coequalizers are closed under iso *) Section CoequalizerIso. Context (a : enriched_coequalizer_cocone) (Ha : is_coequalizer_enriched a) (b : C) (h : z_iso a b). Definition enriched_coequalizer_cocone_from_iso : enriched_coequalizer_cocone. Proof. refine (make_enriched_coequalizer_cocone b (enriched_from_arr E (enriched_coequalizer_cocone_in a · h)) _). abstract (rewrite !enriched_to_from_arr ; rewrite !assoc ; apply maponpaths_2 ; exact (enriched_coequalizer_cocone_eq a)). Defined. Definition is_coequalizer_enriched_from_iso : is_coequalizer_enriched enriched_coequalizer_cocone_from_iso. Proof. intros w. use (isEqualizer_z_iso (Ha w)). - exact (precomp_arr_z_iso E w h). - abstract (cbn ; rewrite <- precomp_arr_comp ; apply maponpaths ; unfold enriched_coequalizer_cocone_from_iso ; cbn ; unfold enriched_coequalizer_cocone_in ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End CoequalizerIso. (** 7. Coequalizers are isomorphic *) Definition map_between_coequalizer_enriched {a b : enriched_coequalizer_cocone} (Ha : is_coequalizer_enriched a) (Hb : is_coequalizer_enriched b) : a --> b := underlying_Coequalizer_arr Ha (enriched_coequalizer_cocone_in b) (enriched_coequalizer_cocone_eq b). Lemma iso_between_coequalizer_enriched_inv {a b : enriched_coequalizer_cocone} (Ha : is_coequalizer_enriched a) (Hb : is_coequalizer_enriched b) : map_between_coequalizer_enriched Ha Hb · map_between_coequalizer_enriched Hb Ha = identity _. Proof. unfold map_between_coequalizer_enriched. use (underlying_Coequalizer_arr_eq Ha). rewrite !assoc. rewrite !underlying_Coequalizer_arr_in. rewrite id_right. apply idpath. Qed. Definition iso_between_coequalizer_enriched {a b : enriched_coequalizer_cocone} (Ha : is_coequalizer_enriched a) (Hb : is_coequalizer_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_coequalizer_enriched Ha Hb). - exact (map_between_coequalizer_enriched Hb Ha). - split. + apply iso_between_coequalizer_enriched_inv. + apply iso_between_coequalizer_enriched_inv. Defined. End EnrichedCoequalizer. (** 7. Enriched categories with products *) Definition enrichment_coequalizers {V : monoidal_cat} {C : category} (E : enrichment C V) : UU := ∏ (x y : C) (f g : x --> y), ∑ (a : enriched_coequalizer_cocone E f g), is_coequalizer_enriched E f g a. Proposition isaprop_enrichment_coequalizers {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) : isaprop (enrichment_coequalizers E). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. use funextsec ; intro g. use subtypePath. { intro. apply isaprop_is_coequalizer_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_coequalizer_enriched. + exact (pr2 (φ₁ x y f g)). + exact (pr2 (φ₂ x y f g)). - use subtypePath. { intro. apply homset_property. } rewrite pr1_transportf. rewrite transportf_enriched_arr_r. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_coequalizer_enriched ; cbn. apply underlying_Coequalizer_arr_in. Qed. Definition cat_with_enrichment_coequalizers (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_coequalizers C. Coercion cat_with_enrichment_coequalizers_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_coequalizers V) : cat_with_enrichment V := pr1 C. Definition coequalizers_of_cat_with_enrichment_coequalizers {V : monoidal_cat} (C : cat_with_enrichment_coequalizers V) : enrichment_coequalizers C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedColimits.v000066400000000000000000000363701451125700300273700ustar00rootroot00000000000000(***************************************************************** Colimits in enriched categories In this file, we define the notion of colimit in enriched categories. Note that these limits refer to weighted colimits rather than so-called conical colimits, because the former is actually the correct notion of colimit in this setting. Contents 1. Cocones of enriched colimits 2. Colimits in an enriched category 3. Being a colimit is a proposition 4. Instances of colimits 4.1. Copowers as colimits 4.2. Conical colimits as colimits *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.Ends. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedConicalColimits. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Opaque sym_mon_braiding. Section EnrichedColimit. Context {V : sym_mon_closed_cat} {I C : category} (E : enrichment C V) (D : I ⟶ C) (W : I^opp ⟶ V). (** 1. Coones of enriched colimits *) Definition enriched_colim_cocone : UU := ∑ (a : C), ∑ (fs : ∏ (i : I), W i --> E ⦃ D i , a ⦄), ∏ (i j : I) (f : j --> i), fs i · precomp_arr E a (#D f) = #W f · fs j. Coercion ob_enriched_colim_cocone (a : enriched_colim_cocone) : C := pr1 a. Definition enriched_colim_cocone_in (a : enriched_colim_cocone) (i : I) : W i --> E ⦃ D i , a ⦄ := pr12 a i. Proposition enriched_colim_cocone_commute (a : enriched_colim_cocone) {i j : I} (f : j --> i) : enriched_colim_cocone_in a i · precomp_arr E a (#D f) = #W f · enriched_colim_cocone_in a j. Proof. exact (pr22 a i j f). Qed. Definition make_enriched_colim_cocone (a : C) (fs : ∏ (i : I), W i --> E ⦃ D i , a ⦄) (eqs : ∏ (i j : I) (f : j --> i), fs i · precomp_arr E a (#D f) = #W f · fs j) : enriched_colim_cocone := a ,, fs ,, eqs. (** 2. Colimits in an enriched category *) Definition weighted_hom_co_data (w : C) : functor_data (category_binproduct (I^opp) I) V. Proof. use make_functor_data. - exact (λ i, W (pr2 i) ⊸ (E ⦃ D (pr1 i) , w ⦄)). - exact (λ i j k, internal_pre_post_comp (#W (pr2 k)) (precomp_arr E w (#D (pr1 k)))). Defined. Proposition weighted_hom_co_is_functor (w : C) : is_functor (weighted_hom_co_data w). Proof. split. - intro i ; cbn. rewrite !functor_id. rewrite precomp_arr_id. rewrite (functor_id W). rewrite internal_pre_post_comp_id. apply idpath. - intros i j k f g ; cbn. refine (_ @ internal_pre_post_comp_comp _ _ _ _). rewrite !functor_comp. rewrite !precomp_arr_comp. pose (functor_comp W (pr2 g) (pr2 f)) as p. cbn in p. rewrite p. apply idpath. Qed. Definition weighted_hom_co (w : C) : category_binproduct (I^opp) I ⟶ V. Proof. use make_functor. - exact (weighted_hom_co_data w). - exact (weighted_hom_co_is_functor w). Defined. Definition is_colim_enriched_wedge_data (a : enriched_colim_cocone) (w : C) : wedge_data (weighted_hom_co w). Proof. use make_wedge_data. - exact (E ⦃ a , w ⦄). - exact (λ i, internal_lam (identity _ #⊗ enriched_colim_cocone_in a i · enriched_comp E _ _ _)). Defined. Proposition is_colim_enriched_is_wedge (a : enriched_colim_cocone) (w : C) : is_wedge (weighted_hom_co w) (is_colim_enriched_wedge_data a w). Proof. intros i j g ; cbn. rewrite !functor_id. rewrite (functor_id W). rewrite precomp_arr_id. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_pre_post_comp. rewrite !internal_beta. rewrite !tensor_id_id. rewrite id_left, id_right. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite enriched_comp_precomp_arr. rewrite !assoc. rewrite <- !tensor_comp_id_l. apply maponpaths_2. apply maponpaths. apply enriched_colim_cocone_commute. Qed. Definition is_colim_enriched_wedge (a : enriched_colim_cocone) (w : C) : wedge (weighted_hom_co w). Proof. use make_wedge. - exact (is_colim_enriched_wedge_data a w). - exact (is_colim_enriched_is_wedge a w). Defined. Definition is_colim_enriched (a : enriched_colim_cocone) : UU := ∏ (w : C), is_end (weighted_hom_co w) (is_colim_enriched_wedge a w). Definition colim_enriched : UU := ∑ (a : enriched_colim_cocone), is_colim_enriched a. Coercion cocone_of_colim_enriched (a : colim_enriched) : enriched_colim_cocone := pr1 a. Definition enriched_colim_cocone_is_colim (a : colim_enriched) : is_colim_enriched a := pr2 a. (** 3. Being a colimit is a proposition *) Proposition isaprop_is_colim_enriched (a : enriched_colim_cocone) : isaprop (is_colim_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. End EnrichedColimit. (** 4. Instances of colimits *) (** 4.1. Copowers as colimits *) Section ColimitToCopower. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (v : V) (x : C). Let I : category := unit_category. Let D : I ⟶ C := constant_functor _ _ x. Let W : I^opp ⟶ V := constant_functor _ _ v. Context (a : colim_enriched E D W). Definition copower_from_colim_cocone : copower_cocone E v x. Proof. use make_copower_cocone. - exact a. - exact (enriched_colim_cocone_in _ _ _ a tt). Defined. Section CopowerUMP. Context (w : C). Definition copower_from_colim_wedge_data : wedge_data (weighted_hom_co E D W w). Proof. use make_wedge_data ; cbn. - exact (v ⊸ (E ⦃ x , w ⦄)). - exact (λ _, identity _). Defined. Proposition copower_from_colim_is_wedge : is_wedge (weighted_hom_co E D W w) copower_from_colim_wedge_data. Proof. intros i j k. apply idpath. Qed. Definition copower_from_colim_wedge : wedge (weighted_hom_co E D W w). Proof. use make_wedge. - exact copower_from_colim_wedge_data. - exact copower_from_colim_is_wedge. Defined. Proposition copower_from_colim_wedge_inv_1 : is_copower_enriched_map E v x copower_from_colim_cocone w · mor_to_end (weighted_hom_co E D W w) (pr2 a w) copower_from_colim_wedge = identity _. Proof. use (mor_to_end_eq _ (pr2 a w)). intro i. rewrite !assoc'. etrans. { apply maponpaths. exact (mor_to_end_comm _ (pr2 a w) copower_from_colim_wedge i). } refine (id_right _ @ _ @ !(id_left _)). use internal_funext. intros z h. rewrite tensor_split. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. etrans. { apply internal_beta. } induction i. apply idpath. Qed. Proposition copower_from_colim_wedge_inv_2 : mor_to_end (weighted_hom_co E D W w) (pr2 a w) copower_from_colim_wedge · is_copower_enriched_map E v x copower_from_colim_cocone w = identity _. Proof. exact (mor_to_end_comm (weighted_hom_co E D W w) (pr2 a w) copower_from_colim_wedge tt). Qed. End CopowerUMP. Definition is_copower_enriched_from_colim_cone : is_copower_enriched _ _ _ copower_from_colim_cocone. Proof. use make_is_copower_enriched. - exact (λ w, mor_to_end _ (pr2 a w) (copower_from_colim_wedge w)). - exact copower_from_colim_wedge_inv_1. - exact copower_from_colim_wedge_inv_2. Defined. End ColimitToCopower. (** 4.2. Conical limits as limits *) Section ColimitToConical. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) {I : category} (D : I ⟶ C). Let W : I^opp ⟶ V := constant_functor _ _ I_{V}. Context (a : colim_enriched E D W). Definition enriched_weighted_to_conical_cocone : enriched_conical_colim_cocone D. Proof. use make_enriched_conical_colim_cocone. - exact a. - exact (λ i, enriched_to_arr E (enriched_colim_cocone_in _ _ _ a i)). - abstract (intros i j f ; cbn ; use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn ; rewrite enriched_from_to_arr ; pose (enriched_colim_cocone_commute _ _ _ a f) as p ; cbn in p ; rewrite id_left in p ; rewrite <- p ; rewrite enriched_from_arr_comp ; rewrite enriched_from_to_arr ; rewrite tensor_split ; rewrite !assoc ; rewrite <- tensor_linvunitor ; unfold precomp_arr ; rewrite !assoc ; apply maponpaths_2 ; rewrite tensor_rinvunitor ; rewrite tensor_linvunitor ; rewrite mon_rinvunitor_I_mon_linvunitor_I ; rewrite !assoc' ; apply maponpaths ; rewrite <- tensor_split ; rewrite <- tensor_split' ; apply idpath). Defined. Section ConicalColimUMP. Context {w : C} (v : V) (fs : ∏ (i : I), v --> E ⦃ D i , w ⦄) (ps : ∏ (i j : I) (k : j --> i), fs i · precomp_arr E w (#D k) = fs j). Proposition enriched_weighted_to_conical_is_conical_colim_unique : isaprop (∑ (g : v --> E ⦃ a , w ⦄), ∏ (i : I), g · precomp_arr E w (enriched_to_arr E (enriched_colim_cocone_in E D W a i)) = fs i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use (mor_to_end_eq _ (pr2 a w)). intros i ; cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite !internal_beta. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_right. rewrite !tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. pose (p := maponpaths (λ z, mon_runitor _ · z) (pr2 φ₁ i @ !(pr2 φ₂ i))). cbn in p. unfold precomp_arr in p. rewrite !enriched_from_to_arr in p. rewrite !assoc' in p. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) in p. rewrite !tensor_rinvunitor in p. rewrite !assoc in p. rewrite !mon_runitor_rinvunitor in p. rewrite !id_left in p. rewrite <- !tensor_split' in p. exact p. Qed. Definition enriched_weighted_to_conical_is_conical_colim_wedge_data : wedge_data (weighted_hom_co E D W w). Proof. use make_wedge_data. - exact v. - exact (λ i, internal_lam (mon_runitor _ · fs i)). Defined. Proposition enriched_weighted_to_conical_is_conical_colim_is_wedge : is_wedge (weighted_hom_co E D W w) enriched_weighted_to_conical_is_conical_colim_wedge_data. Proof. intros i j f ; cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_pre_post_comp. rewrite !internal_beta. rewrite functor_id. rewrite precomp_arr_id. rewrite id_right. rewrite !tensor_id_id. rewrite !id_left. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. rewrite !assoc'. do 2 apply maponpaths. apply ps. Qed. Definition enriched_weighted_to_conical_is_conical_colim_wedge : wedge (weighted_hom_co E D W w). Proof. use make_wedge. - exact enriched_weighted_to_conical_is_conical_colim_wedge_data. - exact enriched_weighted_to_conical_is_conical_colim_is_wedge. Defined. Definition enriched_weighted_to_conical_is_conical_colim_mor : v --> E ⦃ a , w ⦄ := mor_to_end _ (pr2 a w) enriched_weighted_to_conical_is_conical_colim_wedge. Proposition enriched_weighted_to_conical_is_conical_colim_mor_eq (i : I) : enriched_weighted_to_conical_is_conical_colim_mor · precomp_arr E w (enriched_to_arr E (enriched_colim_cocone_in E D W a i)) = fs i. Proof. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (mor_to_end_comm _ (pr2 a w) enriched_weighted_to_conical_is_conical_colim_wedge i)) as p. cbn in p. rewrite tensor_comp_id_r in p. rewrite !assoc' in p. rewrite !internal_beta in p. rewrite !assoc in p. rewrite <- tensor_split' in p. refine (_ @ id_left _). rewrite <- mon_rinvunitor_runitor. rewrite !assoc'. rewrite <- p. unfold precomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split'. rewrite enriched_from_to_arr. apply idpath. Qed. End ConicalColimUMP. Definition enriched_weighted_to_conical_is_conical_colim : is_conical_colim_enriched E D enriched_weighted_to_conical_cocone. Proof. intros w v cc. use iscontraprop1. - exact (enriched_weighted_to_conical_is_conical_colim_unique v (pr1 cc)). - refine (enriched_weighted_to_conical_is_conical_colim_mor v (pr1 cc) (pr2 cc) ,, _). intros i. exact (enriched_weighted_to_conical_is_conical_colim_mor_eq v (pr1 cc) (pr2 cc) i). Defined. End ColimitToConical. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedConicalColimits.v000066400000000000000000000420041451125700300306500ustar00rootroot00000000000000(***************************************************************** Enriched conical colimits We define conical colimits for enriched categories. A conical colimit is the colimit of a functor to the underlying category of an enriched category. Note that in ordinary category theory, these colimits are called colimits rather than conical colimits. The reason for that, is that the 'right' notion of colimit in enriched category is that of a weighted colimit. The copower is an example of a colimit that is not conical. In addition, we show that conical colimits can be constructed from type-indexed coproducts and coequalizers. We use a similar construction as the one used to construct colimits from coproducts and coequalizers in ordinary category theory. Content 1. Cocones of enriched conical colimits 2. Conical colimits in an enriched category 3. Being a conical colimit is a proposition 4. Accessors for conical colimits 5. Conical colimits are isomorphic 6. Construction of conical colimits *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section EnrichedConicalColimit. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {I : category} (D : I ⟶ C). (** 1. Cocones of enriched conical colimits *) Definition enriched_conical_colim_cocone : UU := ∑ (a : C), ∑ (ps : ∏ (i : I), D i --> a), ∏ (i j : I) (f : i --> j), #D f · ps j = ps i. Coercion ob_enriched_conical_colim_cocone (a : enriched_conical_colim_cocone) : C := pr1 a. Definition enriched_conical_colim_cocone_in (a : enriched_conical_colim_cocone) (i : I) : D i --> a := pr12 a i. Proposition enriched_enriched_conical_colim_cocone_commute (a : enriched_conical_colim_cocone) {i j : I} (f : i --> j) : #D f · enriched_conical_colim_cocone_in a j = enriched_conical_colim_cocone_in a i. Proof. exact (pr22 a i j f). Qed. Definition make_enriched_conical_colim_cocone (a : C) (ps : ∏ (i : I), D i --> a) (eqs : ∏ (i j : I) (f : i --> j), #D f · ps j = ps i) : enriched_conical_colim_cocone := a ,, ps ,, eqs. (** 2. Conical colimits in an enriched category *) Definition is_conical_colim_enriched_diagram (a : enriched_conical_colim_cocone) (w : C) : diagram (I^opp) V. Proof. use make_diagram. - exact (λ i, E ⦃ D i , w ⦄). - exact (λ i j f, precomp_arr E w (#D f)). Defined. Definition is_conical_colim_enriched_cone (a : enriched_conical_colim_cocone) (w : C) : cone (is_conical_colim_enriched_diagram a w) (E ⦃ a , w ⦄). Proof. use make_cone. - exact (λ i, precomp_arr E w (enriched_conical_colim_cocone_in a i)). - abstract (intros i j f ; cbn ; rewrite <- precomp_arr_comp ; rewrite enriched_enriched_conical_colim_cocone_commute ; apply idpath). Defined. Definition is_conical_colim_enriched (a : enriched_conical_colim_cocone) : UU := ∏ (w : C), isLimCone (is_conical_colim_enriched_diagram a w) (E ⦃ a , w ⦄) (is_conical_colim_enriched_cone a w). Definition is_conical_colim_enriched_to_Lim {a : enriched_conical_colim_cocone} (Ha : is_conical_colim_enriched a) (w : C) : LimCone (is_conical_colim_enriched_diagram a w). Proof. use make_LimCone. - exact (E ⦃ a , w ⦄). - exact (is_conical_colim_enriched_cone a w). - exact (Ha w). Defined. Definition conical_colim_enriched : UU := ∑ (a : enriched_conical_colim_cocone), is_conical_colim_enriched a. Coercion cocone_of_enriched_conical_colim_cocone (a : conical_colim_enriched) : enriched_conical_colim_cocone := pr1 a. Coercion conical_colim_enriched_is_conical_colim (a : conical_colim_enriched) : is_conical_colim_enriched a := pr2 a. (** 3. Being a conical colimit is a proposition *) Proposition isaprop_is_conical_colim_enriched (a : enriched_conical_colim_cocone) : isaprop (is_conical_colim_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. (** 4. Accessors for conical colimits *) Section ConicalColimAccessors. Context (a : conical_colim_enriched). Definition is_conical_colim_enriched_arrow (w : C) (gs : ∏ (i : I), D i --> w) (qs : ∏ (i j : I) (f : i --> j), # D f · gs j = gs i) : a --> w. Proof. refine (enriched_to_arr E _). use (limArrow (make_LimCone _ _ _ (pr2 a w))). simple refine (_ ,, _). - exact (λ i, enriched_from_arr E (gs i)). - abstract (intros i j f ; cbn ; rewrite enriched_from_arr_precomp ; apply maponpaths ; exact (qs j i f)). Defined. Proposition is_conical_colim_enriched_map_in (w : C) (gs : ∏ (i : I), D i --> w) (qs : ∏ (i j : I) (f : i --> j), # D f · gs j = gs i) (i : I) : enriched_conical_colim_cocone_in a i · is_conical_colim_enriched_arrow w gs qs = gs i. Proof. unfold is_conical_colim_enriched_arrow, enriched_conical_colim_cocone_in. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. rewrite enriched_from_arr_comp. rewrite !enriched_from_to_arr. rewrite tensor_split'. rewrite !assoc. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite <- tensor_rinvunitor. etrans. { rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). apply (limArrowCommutes (make_LimCone _ _ _ (pr2 a w))). } cbn. apply idpath. Qed. Proposition is_conical_colim_enriched_arrow_eq {w : C} {f g : a --> w} (q : ∏ (i : I), enriched_conical_colim_cocone_in a i · f = enriched_conical_colim_cocone_in a i · g) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (arr_to_LimCone_eq (is_conical_colim_enriched_to_Lim (pr2 a) w)). intro i ; cbn. rewrite !enriched_from_arr_precomp. rewrite q. apply idpath. Qed. End ConicalColimAccessors. (** 5. Conical colimits are isomorphic *) Definition map_between_conical_colim_enriched (a b : conical_colim_enriched) : a --> b. Proof. use (is_conical_colim_enriched_arrow a). - exact (enriched_conical_colim_cocone_in b). - exact (λ _ _ f, enriched_enriched_conical_colim_cocone_commute b f). Defined. Lemma iso_between_conical_colim_enriched_inv (a b : conical_colim_enriched) : map_between_conical_colim_enriched a b · map_between_conical_colim_enriched b a = identity _. Proof. unfold map_between_conical_colim_enriched. use (is_conical_colim_enriched_arrow_eq a). intro j. rewrite !assoc. rewrite !is_conical_colim_enriched_map_in. rewrite id_right. apply idpath. Qed. Definition iso_between_conical_colim_enriched (a b : conical_colim_enriched) : z_iso a b. Proof. use make_z_iso. - exact (map_between_conical_colim_enriched a b). - exact (map_between_conical_colim_enriched b a). - split. + apply iso_between_conical_colim_enriched_inv. + apply iso_between_conical_colim_enriched_inv. Defined. Proposition isaprop_conical_colim_enriched (HC : is_univalent C) : isaprop (conical_colim_enriched). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaprop_is_conical_colim_enriched. } use total2_paths_f. - use (isotoid _ HC). apply iso_between_conical_colim_enriched. - use subtypePath. { intro. repeat (use impred ; intro). apply homset_property. } rewrite pr1_transportf. rewrite transportf_sec_constant. use funextsec. intro j. rewrite transportf_isotoid'. apply is_conical_colim_enriched_map_in. Qed. End EnrichedConicalColimit. (** 6. Construction of conical colimits *) Section ConstructionOfConicalColimit. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {I' : category} (D : I' ⟶ C) (PE : ∏ (J : UU), enrichment_coprod E J) (EE : enrichment_coequalizers E). Let I : category := I'^opp. Let coprod_src : C := pr1 (PE (∑ (x : I) (y : I), x --> y) (λ z, D (pr12 z))). Let is_coprod_src : is_coprod_enriched E _ coprod_src := pr2 (PE (∑ (x : I) (y : I), x --> y) (λ z, D (pr12 z))). Let coprod_tar : C := pr1 (PE I D). Let is_coprod_tar : is_coprod_enriched E D coprod_tar := pr2 (PE I D). Local Definition enriched_conical_colim_from_coprod_coequalizers_l : coprod_src --> coprod_tar := is_coprod_enriched_arrow _ _ is_coprod_src (λ j, enriched_coprod_cocone_in _ _ _ (pr12 j)). Let f : coprod_src --> coprod_tar := enriched_conical_colim_from_coprod_coequalizers_l. Local Proposition enriched_conical_colim_from_coprod_coequalizers_l_in {i j : I} (k : i --> j) : enriched_coprod_cocone_in _ _ _ (i ,, j ,, k) · f = enriched_coprod_cocone_in _ _ _ j. Proof. exact (is_coprod_enriched_arrow_in _ _ is_coprod_src _ (i ,, j ,, k)). Qed. Local Definition enriched_conical_colim_from_coprod_coequalizers_r : coprod_src --> coprod_tar := is_coprod_enriched_arrow _ _ is_coprod_src (λ j, #D (pr22 j) · enriched_coprod_cocone_in _ _ _ (pr1 j)). Let g : coprod_src --> coprod_tar := enriched_conical_colim_from_coprod_coequalizers_r. Local Proposition enriched_conical_colim_from_coprod_coequalizers_r_in {i j : I} (k : i --> j) : enriched_coprod_cocone_in _ _ _ (i ,, j ,, k) · g = #D k · enriched_coprod_cocone_in _ _ _ i. Proof. exact (is_coprod_enriched_arrow_in _ _ is_coprod_src _ (i ,, j ,, k)). Qed. Definition enriched_conical_colim_ob_from_coprod_coequalizers : C := pr1 (EE _ _ f g). Let colim : C := enriched_conical_colim_ob_from_coprod_coequalizers. Definition enriched_conical_colim_ob_from_coprod_coequalizers_is_coequalizer : is_coequalizer_enriched E f g colim := pr2 (EE _ _ f g). Definition enriched_conical_colim_in_from_coprod_coequalizers (i : I) : D i --> colim := enriched_coprod_cocone_in _ _ _ i · enriched_coequalizer_cocone_in _ _ _ (pr1 (EE _ _ f g)). Proposition enriched_conical_colim_eq_from_coprod_coequalizers {i j : I} (k : i --> j) : # D k · enriched_conical_colim_in_from_coprod_coequalizers i = enriched_conical_colim_in_from_coprod_coequalizers j. Proof. unfold enriched_conical_colim_in_from_coprod_coequalizers. rewrite !assoc. rewrite <- enriched_conical_colim_from_coprod_coequalizers_r_in. rewrite <- (enriched_conical_colim_from_coprod_coequalizers_l_in k). rewrite !assoc'. apply maponpaths. refine (!_). exact (enriched_coequalizer_cocone_eq _ _ _ (pr1 (EE _ _ f g))). Qed. Definition enriched_conical_colim_from_coprod_coequalizers_cocone : enriched_conical_colim_cocone D. Proof. use make_enriched_conical_colim_cocone. - exact colim. - exact enriched_conical_colim_in_from_coprod_coequalizers. - exact (λ i j k, enriched_conical_colim_eq_from_coprod_coequalizers k). Defined. Section EnrichedConicalColimUMP. Context (w : C) (v : V) (fs : ∏ (i : I), v --> E ⦃ D i , w ⦄) (qs : ∏ (i j : I) (k : i --> j), fs i · precomp_arr E w (# D k) = fs j). Proposition enriched_conical_colim_from_coprod_coequalizers_unique : isaprop (∑ (φ : v --> E ⦃ colim , w ⦄), ∏ (i : I), φ · precomp_arr E w (enriched_conical_colim_in_from_coprod_coequalizers i) = fs i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use (EqualizerInsEq (is_coequalizer_enriched_to_Equalizer _ _ _ enriched_conical_colim_ob_from_coprod_coequalizers_is_coequalizer w)). use (ProductArrow_eq _ _ _ (is_coprod_enriched_to_Product _ _ is_coprod_tar w)). intro i ; cbn. rewrite !assoc'. rewrite <- !precomp_arr_comp. exact (pr2 φ₁ i @ !(pr2 φ₂ i)). Qed. Definition enriched_conical_colim_from_coprod_coequalizers_mor : v --> E ⦃ colim , w ⦄. Proof. use (EqualizerIn (is_coequalizer_enriched_to_Equalizer _ _ _ enriched_conical_colim_ob_from_coprod_coequalizers_is_coequalizer w)). - exact (ProductArrow _ _ (is_coprod_enriched_to_Product _ _ is_coprod_tar w) fs). - abstract (use (ProductArrow_eq _ _ _ (is_coprod_enriched_to_Product _ _ is_coprod_src w)) ; intros ijk ; cbn ; pose (ProductPrCommutes I V _ (is_coprod_enriched_to_Product E D is_coprod_tar w) _ fs) as p ; cbn in p ; rewrite !assoc' ; rewrite <- !precomp_arr_comp ; rewrite enriched_conical_colim_from_coprod_coequalizers_l_in ; rewrite enriched_conical_colim_from_coprod_coequalizers_r_in ; rewrite precomp_arr_comp ; rewrite !assoc ; rewrite !p ; refine (!_) ; apply qs). Defined. Proposition enriched_conical_colim_from_coprod_coequalizers_commute (i : I) : enriched_conical_colim_from_coprod_coequalizers_mor · precomp_arr E w (enriched_conical_colim_in_from_coprod_coequalizers i) = fs i. Proof. unfold enriched_conical_colim_from_coprod_coequalizers_mor. unfold enriched_conical_colim_in_from_coprod_coequalizers. rewrite precomp_arr_comp. rewrite !assoc. rewrite (EqualizerCommutes (is_coequalizer_enriched_to_Equalizer E f g enriched_conical_colim_ob_from_coprod_coequalizers_is_coequalizer w)). rewrite (ProductPrCommutes _ _ _ (is_coprod_enriched_to_Product E D is_coprod_tar w)). apply idpath. Qed. End EnrichedConicalColimUMP. Definition enriched_conical_colim_from_coprod_coequalizers_is_colim : is_conical_colim_enriched E D enriched_conical_colim_from_coprod_coequalizers_cocone. Proof. intros w v cc ; cbn. use iscontraprop1. - exact (enriched_conical_colim_from_coprod_coequalizers_unique w v (pr1 cc)). - simple refine (_ ,, _). + exact (enriched_conical_colim_from_coprod_coequalizers_mor _ _ (pr1 cc) (pr2 cc)). + exact (enriched_conical_colim_from_coprod_coequalizers_commute _ _ (pr1 cc) (pr2 cc)). Defined. Definition enriched_conical_colim_from_coprod_coequalizers : conical_colim_enriched E D := enriched_conical_colim_from_coprod_coequalizers_cocone ,, enriched_conical_colim_from_coprod_coequalizers_is_colim. End ConstructionOfConicalColimit. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedCopowers.v000066400000000000000000000214071451125700300274010ustar00rootroot00000000000000(***************************************************************** Copowers We define the notion of copowers in the setting of enriched category theory. In ordinary category theory, all colimits can be constructed from so-called conical colimits (colimits of a functor). However, this is not necessarily the case for enriched category theory. Instead, a more general class of colimits is studied, called weighted colimits. One example of a weighted colimits that is not a conical colimit, is the copower. Suppose that `V` is a symmetric monoidal closed category and that `C` is enriched over `V`. Given two objects `v : V` and `x : C`, the copower is defined by the following natural isomorphism C ⟦ v ⊙ x , y ⟧ ≅ v ⊸ C ⟦ x , y ⟧ where `⊸` denotes the internal hom of `V`. If we were looking at categories enriched over sets, then the copower of a set `X` with the object `x` would be the coproduct consisting of a copy of `x` for every member of `X`. Contents 1. Cocones of copowers 2. Copowers in an enriched category 3. Being a copower is a proposition 4. Accessors for copowers 5. Builders for copowers 6. Copowers are closed under iso 7. Enriched categories with copowers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Opaque sym_mon_braiding. Section EnrichedCopowers. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (v : V) (x : C). (** 1. Cocones of copowers *) Definition copower_cocone : UU := ∑ (a : C), v --> E ⦃ x , a ⦄. Coercion ob_copower_cocone (a : copower_cocone) : C := pr1 a. Definition copower_cocone_mor (a : copower_cocone) : v --> E ⦃ x , a ⦄ := pr2 a. Definition make_copower_cocone (a : C) (f : v --> E ⦃ x , a ⦄) : copower_cocone := a ,, f. (** 2. Copowers in an enriched category *) Definition is_copower_enriched_map (a : copower_cocone) (w : C) : E ⦃ a , w ⦄ --> v ⊸ (E ⦃ x , w ⦄) := internal_lam (identity _ #⊗ copower_cocone_mor a · enriched_comp E _ _ _). Definition is_copower_enriched (a : copower_cocone) : UU := ∏ (w : C), is_z_isomorphism (is_copower_enriched_map a w). Definition is_copower_enriched_iso {a : copower_cocone} (Ha : is_copower_enriched a) (w : C) : z_iso (E ⦃ a , w ⦄) (v ⊸ (E ⦃ x , w ⦄)) := _ ,, Ha w. (** 3. Being a copower is a proposition *) Proposition isaprop_is_copower_enriched (a : copower_cocone) : isaprop (is_copower_enriched a). Proof. use impred ; intro. apply isaprop_is_z_isomorphism. Qed. (** 4. Accessors for copowers *) Section Accessors. Context {a : copower_cocone} (Ha : is_copower_enriched a). Definition mor_to_copower {w : V} {b : C} (f : w --> v ⊸ (E ⦃ x , b ⦄)) : w --> E ⦃ a , b ⦄ := f · inv_from_z_iso (is_copower_enriched_iso Ha b). Proposition mor_to_copower_commutes {w : V} {b : C} (f : w --> v ⊸ (E ⦃ x , b ⦄)) : mor_to_copower f · is_copower_enriched_map a b = f. Proof. unfold mor_to_copower. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply z_iso_after_z_iso_inv. Qed. Proposition mor_to_copower_eq {w : V} {b : C} {f g : w --> E ⦃ a , b ⦄} (p : f · is_copower_enriched_map a b = g · is_copower_enriched_map a b) : f = g. Proof. use (cancel_z_iso _ _ (is_copower_enriched_iso Ha _)). exact p. Qed. Definition arr_to_copower {b : C} (f : I_{V} --> v ⊸ (E ⦃ x , b ⦄)) : a --> b := enriched_to_arr E (mor_to_copower f). Proposition arr_to_copower_commutes {b : C} (f : I_{V} --> v ⊸ (E ⦃ x , b ⦄)) : enriched_from_arr E (arr_to_copower f) · is_copower_enriched_map a b = f. Proof. unfold arr_to_copower. rewrite enriched_from_to_arr. apply mor_to_copower_commutes. Qed. Proposition arr_to_copower_eq {b : C} {f g : a --> b} (p : enriched_from_arr E f · is_copower_enriched_map a b = enriched_from_arr E g · is_copower_enriched_map a b) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use mor_to_copower_eq. exact p. Qed. End Accessors. (** 5. Builders for copowers *) Definition make_is_copower_enriched (a : copower_cocone) (p_map : ∏ (w : C), v ⊸ (E ⦃ x , w ⦄) --> E ⦃ a , w ⦄) (H₁ : ∏ (w : C), is_copower_enriched_map a w · p_map w = identity _) (H₂ : ∏ (w : C), p_map w · is_copower_enriched_map a w = identity _) : is_copower_enriched a. Proof. intro w. use make_is_z_isomorphism. - exact (p_map w). - split. + exact (H₁ w). + exact (H₂ w). Defined. (** 6. Copowers are closed under iso *) Section CopowerIso. Context (a : copower_cocone) (Ha : is_copower_enriched a) (b : C) (f : z_iso a b). Definition copower_cocone_from_iso : copower_cocone. Proof. use make_copower_cocone. - exact b. - exact (copower_cocone_mor a · postcomp_arr E x f). Defined. Definition is_copower_enriched_from_iso : is_copower_enriched copower_cocone_from_iso. Proof. intros w. refine (transportf is_z_isomorphism _ (is_z_iso_comp_of_is_z_isos _ _ (precomp_arr_is_z_iso E w _ (pr2 f)) (Ha w))). unfold precomp_arr, is_copower_enriched_map. cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. refine (!_). etrans. { rewrite tensor_split. apply idpath. } rewrite !assoc'. rewrite !internal_beta. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite enrichment_assoc. apply idpath. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite <- tensor_id_id. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite tensor_split. rewrite !assoc'. rewrite <- mon_inv_triangle. apply idpath. } rewrite <- !tensor_comp_id_l. apply maponpaths. rewrite !assoc'. apply maponpaths. unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite <- !tensor_split. rewrite <- !tensor_split'. apply idpath. Qed. End CopowerIso. End EnrichedCopowers. (** 7. Enriched categories with copowers *) Definition enrichment_copower {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) : UU := ∏ (v : V) (x : C), ∑ (e : copower_cocone E v x), is_copower_enriched E v x e. Definition cat_with_enrichment_copower (V : sym_mon_closed_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_copower C. Coercion cat_with_enrichment_copower_to_cat_with_enrichment {V : sym_mon_closed_cat} (C : cat_with_enrichment_copower V) : cat_with_enrichment V := pr1 C. Definition copowers_of_cat_with_enrichment {V : sym_mon_closed_cat} (C : cat_with_enrichment_copower V) : enrichment_copower C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedCoproducts.v000066400000000000000000000364441451125700300277340ustar00rootroot00000000000000(***************************************************************** Type indexed enriched coproducts In this file, we define type indexed coproducts for enriched categories. The ideas are similar as for binary coproducts; the only difference being that instead of having two summands, the summands are indexed by a type. Content 1. Cocones of enriched coproducts 2. Coproducts in an enriched category 3. Being a coproduct is a proposition 4. Coproducts in the underlying category 5. Builders for coproducts 6. Coproducts are closed under iso 7. Coproducts are isomorphic 8. Enriched categories with coproducts *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.coproducts. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedCoproducts. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {J : UU} (D : J → C). (** 1. Cocones of enriched coproducts *) Definition enriched_coprod_cocone : UU := ∑ (a : C), ∏ (j : J), I_{V} --> E ⦃ D j , a ⦄. Coercion ob_enriched_coprod_cocone (a : enriched_coprod_cocone) : C := pr1 a. Definition enriched_coprod_cocone_in (a : enriched_coprod_cocone) (j : J) : D j --> a := enriched_to_arr E (pr2 a j). Definition make_enriched_coprod_cocone (a : C) (p : ∏ (j : J), I_{V} --> E ⦃ D j , a ⦄) : enriched_coprod_cocone := a ,, p. (** 2. Coproducts in an enriched category *) Definition is_coprod_enriched (a : enriched_coprod_cocone) : UU := ∏ (w : C), isProduct J V (λ j, E ⦃ D j , w ⦄) (E ⦃ a , w ⦄) (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)). Definition is_coprod_enriched_to_Product {a : enriched_coprod_cocone} (Ha : is_coprod_enriched a) (w : C) : Product J V (λ j, E ⦃ D j , w ⦄). Proof. use make_Product. - exact (E ⦃ a , w ⦄). - exact (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)). - exact (Ha w). Defined. Definition coprod_enriched : UU := ∑ (a : enriched_coprod_cocone), is_coprod_enriched a. Coercion cocone_of_coprod_enriched (a : coprod_enriched) : enriched_coprod_cocone := pr1 a. Coercion coprod_enriched_is_coprod (a : coprod_enriched) : is_coprod_enriched a := pr2 a. (** 3. Being a coproduct is a proposition *) Proposition isaprop_is_coprod_enriched (a : enriched_coprod_cocone) : isaprop (is_coprod_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. (** 4. Coproducts in the underlying category *) Section InUnderlying. Context {a : enriched_coprod_cocone} (Ha : is_coprod_enriched a). Definition is_coprod_enriched_arrow {w : C} (f : ∏ (j : J), D j --> w) : a --> w. Proof. refine (enriched_to_arr E _). use (ProductArrow _ _ (is_coprod_enriched_to_Product Ha w)). exact (λ j, enriched_from_arr E (f j)). Defined. Proposition is_coprod_enriched_arrow_in {w : C} (f : ∏ (j : J), D j --> w) (j : J) : enriched_coprod_cocone_in a j · is_coprod_enriched_arrow f = f j. Proof. unfold is_coprod_enriched_arrow, enriched_coprod_cocone_in. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ ProductPrCommutes _ _ _ (is_coprod_enriched_to_Product Ha w) _ (λ j, enriched_from_arr E (f j)) j). cbn. unfold precomp_arr, enriched_coprod_cocone_in. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. rewrite mon_linvunitor_I_mon_rinvunitor_I. apply maponpaths. rewrite <- tensor_split'. rewrite !enriched_from_to_arr. apply idpath. Qed. Proposition is_coprod_enriched_arrow_eq {w : C} {f g : a --> w} (q : ∏ (j : J), enriched_coprod_cocone_in a j · f = enriched_coprod_cocone_in a j · g) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (ProductArrow_eq _ _ _ (is_coprod_enriched_to_Product Ha w)). intro j. cbn. unfold precomp_arr. rewrite !assoc. rewrite !tensor_rinvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split'. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite <- !(enriched_to_arr_comp E). exact (q j). Qed. Definition underlying_Coproduct : Coproduct J C D. Proof. use make_Coproduct. - exact a. - exact (enriched_coprod_cocone_in a). - intros w f. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; exact (is_coprod_enriched_arrow_eq (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))). + exact (is_coprod_enriched_arrow f ,, is_coprod_enriched_arrow_in f). Defined. End InUnderlying. (** 5. Builders for coproducts *) Definition make_is_coprod_enriched (a : enriched_coprod_cocone) (sum : ∏ (w : C) (v : V) (f : ∏ (j : J), v --> E ⦃ D j , w ⦄), v --> E ⦃ a , w ⦄) (in_sum : ∏ (w : C) (v : V) (f : ∏ (j : J), v --> E ⦃ D j , w ⦄) (j : J), sum w v f · precomp_arr E w (enriched_coprod_cocone_in a j) = f j) (sum_eq : ∏ (w : C) (v : V) (φ₁ φ₂ : v --> E ⦃ a , w ⦄) (q : ∏ (j : J), φ₁ · precomp_arr E w (enriched_coprod_cocone_in a j) = φ₂ · precomp_arr E w (enriched_coprod_cocone_in a j)), φ₁ = φ₂) : is_coprod_enriched a. Proof. intro w. use make_isProduct. { apply homset_property. } intros v f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; exact (sum_eq w v (pr1 φ₁) (pr1 φ₂) (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))). - simple refine (_ ,, _). + exact (sum w v f). + exact (in_sum w v f). Defined. Definition coprod_enriched_to_prod (PV : Products J V) (a : enriched_coprod_cocone) (w : C) : E ⦃ a , w ⦄ --> PV (λ j, E ⦃ D j , w ⦄). Proof. use ProductArrow. exact (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)). Defined. Definition make_is_coprod_enriched_from_z_iso (PV : Products J V) (a : enriched_coprod_cocone) (Ha : ∏ (w : C), is_z_isomorphism (coprod_enriched_to_prod PV a w)) : is_coprod_enriched a. Proof. intro w. use (isProduct_z_iso _ _ _ _ (pr2 (PV (λ j, E ⦃ D j , w ⦄)))). - exact (z_iso_inv (_ ,, Ha w)). - abstract (intro j ; unfold coprod_enriched_to_prod ; cbn ; refine (!_) ; apply (ProductPrCommutes _ _ _ (PV (λ j, E ⦃ D j , w ⦄)))). Defined. Section CoproductFromUnderlying. Context (PV : Products J V) (a : enriched_coprod_cocone) (coprod : isCoproduct J C D a (enriched_coprod_cocone_in a)) (w : C). Definition coprod_from_underlying_arr_map (f : I_{V} --> PV (λ j, E ⦃ D j , w ⦄)) : I_{V} --> E ⦃ a , w ⦄. Proof. apply enriched_from_arr. use (CoproductArrow _ _ (make_Coproduct _ _ _ _ _ coprod)). intro j. exact (enriched_to_arr E (f · ProductPr _ _ _ j)). Defined. Proposition coprod_from_underlying_arr_map_eq₁ (f : I_{V} --> E ⦃ a , w ⦄) : coprod_from_underlying_arr_map (f · coprod_enriched_to_prod PV a w) = f. Proof. unfold coprod_from_underlying_arr_map. refine (_ @ enriched_from_to_arr E f). apply maponpaths. use (CoproductArrow_eq _ _ _ (make_Coproduct _ _ _ _ _ coprod)). unfold coprod_enriched_to_prod. intro j. rewrite CoproductInCommutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite !assoc'. etrans. { apply maponpaths. apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ D k , w ⦄)) _ _ j). } unfold precomp_arr. rewrite !assoc. rewrite tensor_rinvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite enriched_from_to_arr. apply idpath. Qed. Proposition coprod_from_underlying_arr_map_eq₂ (f : I_{V} --> PV (λ j, E ⦃ D j , w ⦄)) : coprod_from_underlying_arr_map f · coprod_enriched_to_prod PV a w = f. Proof. unfold coprod_from_underlying_arr_map. use (ProductArrow_eq _ _ _ (PV (λ j, E ⦃ D j , w ⦄))). unfold coprod_enriched_to_prod. intro j. rewrite !assoc'. etrans. { apply maponpaths. apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ D k , w ⦄)) _ _ j). } rewrite enriched_from_arr_precomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (CoproductInCommutes _ _ _ (make_Coproduct _ _ _ _ _ coprod)). Qed. End CoproductFromUnderlying. Definition make_is_coprod_enriched_from_underlying (PV : Products J V) (a : enriched_coprod_cocone) (prod : isCoproduct J C D a (enriched_coprod_cocone_in a)) (HV : conservative_moncat V) : is_coprod_enriched a. Proof. use (make_is_coprod_enriched_from_z_iso PV). intros w. use HV. use isweq_iso. - exact (coprod_from_underlying_arr_map PV a prod w). - exact (coprod_from_underlying_arr_map_eq₁ PV a prod w). - exact (coprod_from_underlying_arr_map_eq₂ PV a prod w). Defined. (** 6. Coproducts are closed under iso *) Section CoprodIso. Context (a : enriched_coprod_cocone) (Ha : is_coprod_enriched a) (b : C) (f : z_iso b a). Definition enriched_coprod_cocone_from_iso : enriched_coprod_cocone := make_enriched_coprod_cocone b (λ j, enriched_from_arr E (enriched_coprod_cocone_in a j · inv_from_z_iso f)). Definition is_coprod_enriched_from_iso : is_coprod_enriched enriched_coprod_cocone_from_iso. Proof. intros w. use (isProduct_z_iso _ _ _ _ (Ha w)). - exact (precomp_arr_z_iso E w f). - abstract (intro j ; cbn ; rewrite <- precomp_arr_comp ; apply maponpaths ; unfold enriched_coprod_cocone_from_iso ; cbn ; unfold enriched_coprod_cocone_in ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End CoprodIso. (** 7. Coproducts are isomorphic *) Definition map_between_coproduct_enriched {a b : enriched_coprod_cocone} (Ha : is_coprod_enriched a) (Hb : is_coprod_enriched b) : b --> a := is_coprod_enriched_arrow Hb (enriched_coprod_cocone_in a). Lemma iso_between_coproduct_enriched_inv {a b : enriched_coprod_cocone} (Ha : is_coprod_enriched a) (Hb : is_coprod_enriched b) : map_between_coproduct_enriched Ha Hb · map_between_coproduct_enriched Hb Ha = identity _. Proof. unfold map_between_coproduct_enriched. use (is_coprod_enriched_arrow_eq Hb). intro j. rewrite !assoc. rewrite !is_coprod_enriched_arrow_in. rewrite id_right. apply idpath. Qed. Definition iso_between_coproduct_enriched {a b : enriched_coprod_cocone} (Ha : is_coprod_enriched a) (Hb : is_coprod_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_coproduct_enriched Hb Ha). - exact (map_between_coproduct_enriched Ha Hb). - split. + apply iso_between_coproduct_enriched_inv. + apply iso_between_coproduct_enriched_inv. Defined. End EnrichedCoproducts. (** 8. Enriched categories with coproducts *) Definition enrichment_coprod {V : monoidal_cat} {C : category} (E : enrichment C V) (J : UU) : UU := ∏ (D : J → C), ∑ (a : enriched_coprod_cocone E D), is_coprod_enriched E D a. Proposition isaprop_enrichment_coprod {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) (J : UU) : isaprop (enrichment_coprod E J). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro D. use subtypePath. { intro. apply isaprop_is_coprod_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_coproduct_enriched. + exact (pr2 (φ₁ D)). + exact (pr2 (φ₂ D)). - rewrite transportf_sec_constant. use funextsec. intro j. rewrite transportf_enriched_arr_r. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_coproduct_enriched ; cbn. etrans. { apply is_coprod_enriched_arrow_in. } apply idpath. Qed. Definition cat_with_enrichment_coproduct (V : monoidal_cat) (J : UU) : UU := ∑ (C : cat_with_enrichment V), enrichment_coprod C J. Coercion cat_with_enrichment_coproduct_to_cat_with_enrichment {V : monoidal_cat} {J : UU} (C : cat_with_enrichment_coproduct V J) : cat_with_enrichment V := pr1 C. Definition coproducts_of_cat_with_enrichment {V : monoidal_cat} {J : UU} (C : cat_with_enrichment_coproduct V J) : enrichment_coprod C J := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/EnrichedInitial.v000066400000000000000000000152001451125700300271630ustar00rootroot00000000000000(***************************************************************** Initial objects in enriched categories We define the notion of initial objects in the context of enriched category theory. In ordinary category theory, an object is called initial if there is a unique morphism to every object in the category. To translate this concept to enriched category theory, we need to phrase this universal property in an arbitrary monoidal category instead of for sets. The idea is as follows. We want to say that an object `x` is initial. For every `y`, we have an object `C ⟦ x , y ⟧` in the monoidal category `V`. Then `x` is initial if this hom-object is a terminal object in `V`. Contents 1. Initial objects in an enriched category 2. Being initial is a proposition 3. Accessors for initial objects 4. Builders for initial objects 5. Being initial is closed under iso 6. Initial objects are isomorphic 7. Enriched categories with a terminal object *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedInitial. Context {V : monoidal_cat} {C : category} (E : enrichment C V). (** 1. Initial objects in an enriched category *) Definition is_initial_enriched (x : C) : UU := ∏ (y : C), isTerminal V (E ⦃ x , y ⦄). Definition initial_enriched : UU := ∑ (x : C), is_initial_enriched x. Coercion initial_enriched_to_ob (x : initial_enriched) : C := pr1 x. Coercion initial_enriched_to_is_initial (x : initial_enriched) : is_initial_enriched x := pr2 x. (** 2. Being initial is a proposition *) Proposition isaprop_is_initial_enriched (x : C) : isaprop (is_initial_enriched x). Proof. do 2 (use impred ; intro). apply isapropiscontr. Qed. (** 3. Accessors for initial objects *) Section Accessors. Context {x : C} (Hx : is_initial_enriched x). Definition is_initial_enriched_arrow (y : C) : I_{V} --> E ⦃ x , y ⦄ := TerminalArrow (_ ,, Hx y) I_{V}. Definition is_initial_enriched_eq {y : C} (f g : I_{V} --> E ⦃ x , y ⦄) : f = g. Proof. apply (@TerminalArrowEq _ (_ ,, Hx y) I_{V}). Qed. Definition initial_underlying : Initial C. Proof. refine (x ,, _). intros y. use iscontraprop1. - abstract (use invproofirrelevance ; intros f g ; refine (!(enriched_to_from_arr E f) @ _ @ enriched_to_from_arr E g) ; apply maponpaths ; apply is_initial_enriched_eq). - exact (enriched_to_arr E (is_initial_enriched_arrow y)). Defined. End Accessors. (** 4. Builders for initial objects *) Definition make_is_initial_enriched (x : C) (f : ∏ (w : V) (y : C), w --> E ⦃ x , y ⦄) (p : ∏ (w : V) (y : C) (f g : w --> E ⦃ x , y ⦄), f = g) : is_initial_enriched x. Proof. intros y w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; apply p). - apply f. Defined. Definition make_is_initial_enriched_from_iso (TV : Terminal V) (x : C) (Hx : ∏ (y : C), is_z_isomorphism (TerminalArrow TV (E ⦃ x , y ⦄))) : is_initial_enriched x. Proof. intros y. use (iso_to_Terminal TV). exact (z_iso_inv (TerminalArrow TV (E ⦃ x , y ⦄) ,, Hx y)). Defined. Definition initial_enriched_from_underlying (TC : Initial C) (TV : Terminal V) (HV : conservative_moncat V) : is_initial_enriched TC. Proof. use (make_is_initial_enriched_from_iso TV). intro y. use HV. use isweq_iso. - intro f. apply enriched_from_arr. apply (InitialArrow TC). - abstract (intros f ; cbn ; refine (_ @ enriched_from_to_arr E f) ; apply maponpaths ; apply InitialArrowEq). - abstract (intros f ; cbn ; apply TerminalArrowEq). Defined. (** 5. Being initial is closed under iso *) Definition initial_enriched_from_iso {x y : C} (Hx : is_initial_enriched x) (f : z_iso x y) : is_initial_enriched y. Proof. intros w. use (iso_to_Terminal (_ ,, Hx w)) ; cbn. exact (precomp_arr_z_iso E w (z_iso_inv f)). Defined. (** 6. Initial objects are isomorphic *) Definition iso_between_initial_enriched {x y : C} (Hx : is_initial_enriched x) (Hy : is_initial_enriched y) : z_iso x y. Proof. use make_z_iso. - exact (enriched_to_arr E (is_initial_enriched_arrow Hx y)). - exact (enriched_to_arr E (is_initial_enriched_arrow Hy x)). - split. + abstract (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ; apply maponpaths ; apply (is_initial_enriched_eq Hx)). + abstract (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ; apply maponpaths ; apply (is_initial_enriched_eq Hy)). Defined. Definition isaprop_initial_enriched (HC : is_univalent C) : isaprop initial_enriched. Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaprop_is_initial_enriched. } use (isotoid _ HC). use iso_between_initial_enriched. - exact (pr2 φ₁). - exact (pr2 φ₂). Defined. End EnrichedInitial. (** 7. Enriched categories with a terminal object *) Definition cat_with_enrichment_initial (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), initial_enriched C. Coercion cat_with_enrichment_initial_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_initial V) : cat_with_enrichment V := pr1 C. Definition initial_of_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_initial V) : initial_enriched C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/000077500000000000000000000000001451125700300255215ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/OppositeEnrichedColimits.v000066400000000000000000000134351451125700300326660ustar00rootroot00000000000000(***************************************************************** Colimits in the enriched opposite category If an enriched category has limits, then its opposite inherits these as colimits. Contents 1. Initial object 2. Binary coproducts 3. Coequalizers 4. Type indexed coproducts 5. Copowers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section OppositeColimits. Context {V : sym_monoidal_cat} {C : category} (E : enrichment C V). Let E' : enrichment (C^opp) V := op_enrichment V E. (** 1. Initial object *) Definition opposite_initial_enriched (T : terminal_enriched E) : initial_enriched E'. Proof. exact T. Defined. (** 2. Binary coproducts *) Section OppositeBinaryCoproducts. Context {x y : C} (s : binary_prod_enriched E x y). Definition opposite_binary_coprod_enriched_is_coprod : is_binary_coprod_enriched E' x y (pr1 s). Proof. intro w. use (isBinProduct_eq_arrow _ _ (pr2 s w)). - abstract (unfold E' ; rewrite op_enrichment_precomp ; apply maponpaths ; cbn ; apply idpath). - abstract (unfold E' ; rewrite op_enrichment_precomp ; apply maponpaths ; cbn ; apply idpath). Defined. Definition opposite_binary_coprod_enriched : binary_coprod_enriched E' x y. Proof. simple refine (_ ,, _). - exact (pr1 s). - exact opposite_binary_coprod_enriched_is_coprod. Defined. End OppositeBinaryCoproducts. Definition opposite_enrichment_binary_coprod (H : enrichment_binary_prod E) : enrichment_binary_coprod E' := λ x y, opposite_binary_coprod_enriched (H x y). (** 3. Coequalizers *) Section OppositeCoequalizers. Context {x y : C} {f g : x --> y} (e : equalizer_enriched E f g). Definition opposite_is_coequalizer_enriched : is_coequalizer_enriched E' f g (pr1 e). Proof. intro w. use (isEqualizer_eq _ _ _ _ _ (pr2 e w)). - abstract (refine (!_) ; apply op_enrichment_precomp). - abstract (refine (!_) ; apply op_enrichment_precomp). - abstract (refine (!_) ; apply op_enrichment_precomp). Defined. Definition opposite_coequalizer_enriched : coequalizer_enriched E' f g := pr1 e ,, opposite_is_coequalizer_enriched. End OppositeCoequalizers. (** 4. Type indexed coproducts *) Section OppositeCoproducts. Context {J : UU} (ys : J → C) (s : prod_enriched E ys). Definition opposite_coprod_enriched_is_coprod : is_coprod_enriched E' ys (pr1 s). Proof. intro w. use (isProduct_eq_arrow _ (pr2 s w)). abstract (intro j ; unfold E' ; rewrite op_enrichment_precomp ; apply maponpaths ; cbn ; apply idpath). Defined. Definition opposite_coprod_enriched : coprod_enriched E' ys. Proof. simple refine (_ ,, _). - exact (pr1 s). - exact opposite_coprod_enriched_is_coprod. Defined. End OppositeCoproducts. End OppositeColimits. (** 5. Copowers *) Definition opposite_copower_enriched {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) {v : V} {x : C} (e : power_cone E v x) (He : is_power_enriched E v x e) : is_copower_enriched (op_enrichment V E) v x e. Proof. intros w. use (is_z_isomorphism_path _ (He w)). abstract (unfold is_copower_enriched_map, is_power_enriched_map ; use internal_funext ; intros a h ; rewrite tensor_split ; rewrite !assoc' ; rewrite internal_beta ; refine (!_) ; rewrite tensor_split ; rewrite !assoc' ; rewrite internal_beta ; apply idpath). Defined. Definition opposite_enrichment_copower {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (HE : enrichment_power E) : enrichment_copower (op_enrichment V E) := λ v x, pr1 (HE v x) ,, opposite_copower_enriched _ _ (pr2 (HE v x)). UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/PosetEnrichedColimits.v000066400000000000000000001025121451125700300321510ustar00rootroot00000000000000(***************************************************************** Colimits in categories enriched over posets If we have a category enriched over posets, then we can characterize colimits using elementary terms. The characterization is similar for products: the initial object is inherited from the underlying category, while for coproducts and coequalizer, we need to demand that the arrow coming from the universal property is monotone. To construct copowers in a category `C` enriched over posets, we assume that we have a poset `P` and an object `x` of `C`. To construct the copower, we take a coproduct of `x` indexed by the underlying set of `P`. As such, `C` must have 'large enough' coproducts, because otherwise, this product cannot be constructed. Contents 1. Initial object 2. Binary coroducts 3. Coqualizers 4. Copowers 5. Type indexed coproducts *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.CategoryOfPosets. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.PosetEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.PosetsMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Proposition isaprop_Coequalizer {C : category} (HC : is_univalent C) {x y : C} (f g : x --> y) : isaprop (Coequalizer f g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - apply homset_property. - simpl. repeat (use impred ; intro). apply isapropiscontr. } use total2_paths_f. - use (isotoid _ HC). exact (z_iso_between_Coequalizer φ₁ φ₂). - rewrite transportf_isotoid' ; cbn. apply CoequalizerCommutes. Qed. Section PosetEnrichmentColimits. Context {C : category} (E : poset_enrichment C). Let E' : enrichment C poset_sym_mon_closed_cat := make_enrichment_over_poset C E. (** 1. Initial object *) Section PosetEnrichedInitial. Context {x : C} (Hx : isInitial C x). Let I : Initial C := make_Initial x Hx. Definition poset_enrichment_is_initial : is_initial_enriched E' x. Proof. use make_is_initial_enriched. - intros P y. simple refine (_ ,, _). + exact (λ _, InitialArrow I y). + abstract (intros x₁ x₂ p ; apply refl_PartialOrder). - abstract (intros P y f g ; use eq_monotone_function ; intros z ; apply (@InitialArrowEq _ I)). Defined. End PosetEnrichedInitial. Definition make_poset_enrichment_initial (HC : Initial C) : initial_enriched E' := pr1 HC ,, poset_enrichment_is_initial (pr2 HC). Definition poset_terminal_enriched_weq_Initial (HC : is_univalent C) : initial_enriched E' ≃ Initial C. Proof. use weqimplimpl. - exact (λ T, initial_underlying E' T). - exact make_poset_enrichment_initial. - apply (isaprop_initial_enriched _ HC). - apply (isaprop_Initial _ HC). Defined. (** 2. Binary coproducts *) Definition poset_enrichment_binary_coprod : UU := ∑ (BC : BinCoproducts C), ∏ (x₁ x₂ y : C) (f f' : x₁ --> y) (qf : E _ _ f f') (g g' : x₂ --> y) (qg : E _ _ g g'), E _ _ (BinCoproductArrow (BC x₁ x₂) f g) (BinCoproductArrow (BC x₁ x₂) f' g'). Proposition isaprop_poset_enrichment_binary_coprod (HC : is_univalent C) : isaprop poset_enrichment_binary_coprod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - do 2 (use impred ; intro). apply (isaprop_BinCoproduct _ HC). - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedCoprodAccessors. Context (EBC : poset_enrichment_binary_coprod). Definition poset_enrichment_obj_binary_coprod (x y : C) : C := pr1 EBC x y. Definition poset_enrichment_obj_in1 (x y : C) : x --> poset_enrichment_obj_binary_coprod x y := BinCoproductIn1 (pr1 EBC x y). Definition poset_enrichment_obj_in2 (x y : C) : y --> poset_enrichment_obj_binary_coprod x y := BinCoproductIn2 (pr1 EBC x y). Definition poset_enrichment_obj_sum {z x y : C} (f : x --> z) (g : y --> z) : poset_enrichment_obj_binary_coprod x y --> z := BinCoproductArrow (pr1 EBC x y) f g. Proposition poset_enrichment_obj_in1_sum {z x y : C} (f : x --> z) (g : y --> z) : poset_enrichment_obj_in1 x y · poset_enrichment_obj_sum f g = f. Proof. apply BinCoproductIn1Commutes. Qed. Proposition poset_enrichment_obj_in2_sum {z x y : C} (f : x --> z) (g : y --> z) : poset_enrichment_obj_in2 x y · poset_enrichment_obj_sum f g = g. Proof. apply BinCoproductIn2Commutes. Qed. Proposition poset_enrichment_binary_coprod_arr_eq {w x y : C} {f g : poset_enrichment_obj_binary_coprod x y --> w} (p : poset_enrichment_obj_in1 x y · f = poset_enrichment_obj_in1 x y · g) (q : poset_enrichment_obj_in2 x y · f = poset_enrichment_obj_in2 x y · g) : f = g. Proof. use (BinCoproductArrowsEq _ _ _ (pr1 EBC x y)). - exact p. - exact q. Qed. Definition poset_enrichment_binary_coprod_pair (x y z : C) : E' ⦃ x , z ⦄ ⊗ (E' ⦃ y , z ⦄) --> E' ⦃ poset_enrichment_obj_binary_coprod x y , z ⦄. Proof. simple refine (_ ,, _). - exact (λ fg, poset_enrichment_obj_sum (pr1 fg) (pr2 fg)). - intros fg₁ fg₂ p. apply (pr2 EBC). + exact (pr1 p). + exact (pr2 p). Defined. End PosetEnrichedCoprodAccessors. Section PosetCoprod. Context (EBC : poset_enrichment_binary_coprod) (x y : C). Definition make_poset_enriched_binary_coprod_cocone : enriched_binary_coprod_cocone E' x y. Proof. use make_enriched_binary_coprod_cocone. - exact (poset_enrichment_obj_binary_coprod EBC x y). - exact (enriched_from_arr E' (poset_enrichment_obj_in1 EBC x y)). - exact (enriched_from_arr E' (poset_enrichment_obj_in2 EBC x y)). Defined. Definition poset_enrichment_binary_coprod_is_coprod : is_binary_coprod_enriched E' x y make_poset_enriched_binary_coprod_cocone. Proof. use make_is_binary_coprod_enriched. - intros z P f g. refine (_ · poset_enrichment_binary_coprod_pair _ _ _ _). simple refine (_ ,, _). + exact (prodtofuntoprod (pr1 f ,, pr1 g)). + apply prodtofun_is_monotone. * exact (pr2 f). * exact (pr2 g). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_in1_sum). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_in2_sum). - abstract (intros z P φ₁ φ₂ q₁ q₂ ; use eq_monotone_function ; intro w ; use poset_enrichment_binary_coprod_arr_eq ; [ exact (eqtohomot (maponpaths (λ f, pr1 f) q₁) w) | exact (eqtohomot (maponpaths (λ f, pr1 f) q₂) w) ]). Defined. End PosetCoprod. Definition make_poset_enrichment_binary_coprod (EBC : poset_enrichment_binary_coprod) : enrichment_binary_coprod E' := λ x y, make_poset_enriched_binary_coprod_cocone EBC x y ,, poset_enrichment_binary_coprod_is_coprod EBC x y. Section ToPosetCoproduct. Context (EP : enrichment_binary_coprod E') {x₁ x₂ y : C}. Let prod : poset_sym_mon_closed_cat := (E' ⦃ x₁ , y ⦄) ⊗ (E' ⦃ x₂ , y ⦄). Let prod_pr1 : prod --> E' ⦃ x₁ , y ⦄ := _ ,, dirprod_pr1_is_monotone _ _. Let prod_pr2 : prod --> E' ⦃ x₂ , y ⦄ := _ ,, dirprod_pr2_is_monotone _ _. Definition poset_to_underlying_binary_coprod_map (f : x₁ --> y) (g : x₂ --> y) : underlying_BinCoproduct E' x₁ x₂ (pr2 (EP x₁ x₂)) --> y := pr1 (BinProductArrow category_of_posets (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP x₁ x₂)) y) prod_pr1 prod_pr2) (f ,, g). Proposition poset_to_underlying_binary_coprod_map_in1 (f : x₁ --> y) (g : x₂ --> y) : enriched_coprod_cocone_in1 E' x₁ x₂ (pr1 (EP x₁ x₂)) · poset_to_underlying_binary_coprod_map f g = f. Proof. exact (eqtohomot (maponpaths pr1 (BinProductPr1Commutes category_of_posets _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP x₁ x₂)) y) _ prod_pr1 prod_pr2)) (f ,, g)). Qed. Proposition poset_to_underlying_binary_coprod_map_in2 (f : x₁ --> y) (g : x₂ --> y) : enriched_coprod_cocone_in2 E' x₁ x₂ (pr1 (EP x₁ x₂)) · poset_to_underlying_binary_coprod_map f g = g. Proof. exact (eqtohomot (maponpaths pr1 (BinProductPr2Commutes category_of_posets _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP x₁ x₂)) y) _ prod_pr1 prod_pr2)) (f ,, g)). Qed. Proposition poset_to_underlying_binary_coprod_map_monotone {φ₁ φ₂ : x₁ --> y} {ψ₁ ψ₂ : x₂ --> y} (p : E x₁ y φ₁ φ₂) (q : E x₂ y ψ₁ ψ₂) : E _ _ (poset_to_underlying_binary_coprod_map φ₁ ψ₁) (poset_to_underlying_binary_coprod_map φ₂ ψ₂). Proof. exact (pr2 (@BinProductArrow _ _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP x₁ x₂)) y) prod prod_pr1 prod_pr2) (φ₁ ,, ψ₁) (φ₂ ,, ψ₂) (p ,, q)). Qed. Proposition poset_to_underlying_binary_coprod_map_eq (f : x₁ --> y) (g : x₂ --> y) : BinCoproductArrow (underlying_BinCoproduct E' x₁ x₂ (pr2 (EP x₁ x₂))) f g = poset_to_underlying_binary_coprod_map f g. Proof. use is_binary_coprod_enriched_arrow_eq. - exact (pr2 (EP x₁ x₂)). - refine (_ @ !(poset_to_underlying_binary_coprod_map_in1 f g)). apply (BinCoproductIn1Commutes C _ _ (underlying_BinCoproduct E' x₁ x₂ (pr2 (EP x₁ x₂))) _ f g). - refine (_ @ !(poset_to_underlying_binary_coprod_map_in2 f g)). apply (BinCoproductIn2Commutes C _ _ (underlying_BinCoproduct E' x₁ x₂ (pr2 (EP x₁ x₂))) _ f g). Qed. End ToPosetCoproduct. Definition to_poset_enrichment_binary_coprod (EP : enrichment_binary_coprod E') : poset_enrichment_binary_coprod. Proof. simple refine (_ ,, _). - exact (λ x y, underlying_BinCoproduct E' x y (pr2 (EP x y))). - abstract (intros x y₁ y₂ f f' p g g' q ; rewrite !poset_to_underlying_binary_coprod_map_eq ; apply (poset_to_underlying_binary_coprod_map_monotone EP p q)). Defined. Definition poset_enrichment_coprod_weq (HC : is_univalent C) : enrichment_binary_coprod E' ≃ poset_enrichment_binary_coprod. Proof. use weqimplimpl. - apply to_poset_enrichment_binary_coprod. - apply make_poset_enrichment_binary_coprod. - apply (isaprop_enrichment_binary_coprod HC). - apply (isaprop_poset_enrichment_binary_coprod HC). Defined. (** 3. Coequalizers *) Definition poset_enrichment_coequalizers : UU := ∑ (EC : Coequalizers C), ∏ (x y z : C) (f g : x --> y) (h₁ h₂ : y --> z) (p₁ : f · h₁ = g · h₁) (p₂ : f · h₂ = g · h₂) (qh : E _ _ h₁ h₂), E _ _ (CoequalizerOut (EC x y f g) z h₁ p₁) (CoequalizerOut (EC x y f g) z h₂ p₂). Proposition isaprop_poset_enrichment_coequalizers (HC : is_univalent C) : isaprop poset_enrichment_coequalizers. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Coequalizer. exact HC. - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedCoequalizerAccessors. Context (EEC : poset_enrichment_coequalizers). Definition poset_enrichment_obj_coequalizer {x y : C} (f g : x --> y) : C := pr1 EEC x y f g. Definition poset_enrichment_obj_coeq_in {x y : C} (f g : x --> y) : y --> poset_enrichment_obj_coequalizer f g := CoequalizerArrow (pr1 EEC x y f g). Proposition poset_enrichment_obj_coeq_in_eq {x y : C} (f g : x --> y) : f · poset_enrichment_obj_coeq_in f g = g · poset_enrichment_obj_coeq_in f g. Proof. apply CoequalizerEqAr. Qed. Definition poset_enrichment_obj_from_coequalizer {x y z : C} {f g : x --> y} (h : y --> z) (q : f · h = g · h) : poset_enrichment_obj_coequalizer f g --> z := CoequalizerOut (pr1 EEC x y f g) z h q. Proposition poset_enrichment_obj_from_coequalizer_in {x y z : C} {f g : x --> y} (h : y --> z) (q : f · h = g · h) : poset_enrichment_obj_coeq_in f g · poset_enrichment_obj_from_coequalizer h q = h. Proof. apply CoequalizerCommutes. Qed. Proposition poset_enrichment_coequalizer_arr_eq {x y z : C} {f g : x --> y} {h₁ h₂ : poset_enrichment_obj_coequalizer f g --> z} (q : poset_enrichment_obj_coeq_in f g · h₁ = poset_enrichment_obj_coeq_in f g · h₂) : h₁ = h₂. Proof. use CoequalizerOutsEq. exact q. Qed. Definition poset_enrichment_coequalizer_to_equalizer {x y z : C} (f g : x --> y) : Equalizers_category_of_posets _ _ (precomp_arr E' z f) (precomp_arr E' z g) --> E' ⦃ poset_enrichment_obj_coequalizer f g , z ⦄. Proof. simple refine (_ ,, _). - cbn. exact (λ hp, poset_enrichment_obj_from_coequalizer (pr1 hp) (pr2 hp)). - intros h₁ h₂ q. exact (pr2 EEC x y z f g (pr1 h₁) (pr1 h₂) (pr2 h₁) (pr2 h₂) q). Defined. End PosetEnrichedCoequalizerAccessors. Section PosetCoequalizer. Context (EEC : poset_enrichment_coequalizers) {x y : C} (f g : x --> y). Definition make_poset_enrichment_coequalizer_cocone : enriched_coequalizer_cocone E' f g. Proof. use make_enriched_coequalizer_cocone. - exact (poset_enrichment_obj_coequalizer EEC f g). - exact (enriched_from_arr E' (poset_enrichment_obj_coeq_in EEC f g)). - exact (poset_enrichment_obj_coeq_in_eq EEC f g). Defined. Definition make_poset_enrichment_coequalizer_is_coequalizer : is_coequalizer_enriched E' f g make_poset_enrichment_coequalizer_cocone. Proof. use make_is_coequalizer_enriched. - abstract (intros w P φ₁ φ₂ q ; use eq_monotone_function ; intro z ; use poset_enrichment_coequalizer_arr_eq ; exact (eqtohomot (maponpaths pr1 q) z)). - intros w P h q. refine (_ · poset_enrichment_coequalizer_to_equalizer EEC f g). simple refine (_ ,, _). + refine (λ z, pr1 h z ,, _). exact (eqtohomot (maponpaths pr1 q) z). + abstract (apply Equalizer_map_monotone ; apply (pr2 h)). - abstract (intros w P h q ; use eq_monotone_function ; intros z ; apply poset_enrichment_obj_from_coequalizer_in). Defined. End PosetCoequalizer. Definition make_poset_enrichment_coequalizers (EEC : poset_enrichment_coequalizers) : enrichment_coequalizers E'. Proof. intros x y f g. simple refine (_ ,, _). - exact (make_poset_enrichment_coequalizer_cocone EEC f g). - exact (make_poset_enrichment_coequalizer_is_coequalizer EEC f g). Defined. Section ToPosetCoequalizer. Context (EEC : enrichment_coequalizers E') {x y z : C} (f g : x --> y). Let Eq : Equalizer _ _ := Equalizers_category_of_posets _ _ (precomp_arr E' z f) (precomp_arr E' z g). Let Eq_pr : Eq --> E' ⦃ y , z ⦄ := EqualizerArrow _. Let Eq_path : Eq_pr · precomp_arr E' z f = Eq_pr · precomp_arr E' z g := EqualizerEqAr _. Definition poset_to_underlying_coequalizer_map (h : y --> z) (q : f · h = g · h) : underlying_Coequalizer E' f g (pr2 (EEC x y f g)) --> z := pr1 (EqualizerIn (is_coequalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) z) Eq Eq_pr Eq_path) (h ,, q). Proposition poset_to_underlying_coequalizer_map_in (h : y --> z) (q : f · h = g · h) : enriched_coequalizer_cocone_in E' f g (pr1 (EEC x y f g)) · poset_to_underlying_coequalizer_map h q = h. Proof. exact (eqtohomot (maponpaths pr1 (EqualizerCommutes (is_coequalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) z) Eq Eq_pr Eq_path)) (h ,, q)). Qed. Proposition poset_to_underlying_coequalizer_map_monotone (h₁ h₂ : y --> z) (q₁ : f · h₁ = g · h₁) (q₂ : f · h₂ = g · h₂) (ph : E y z h₁ h₂) : E _ _ (poset_to_underlying_coequalizer_map h₁ q₁) (poset_to_underlying_coequalizer_map h₂ q₂). Proof. apply (pr2 (EqualizerIn (is_coequalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) z) Eq Eq_pr Eq_path) (h₁ ,, q₁) (h₂ ,, q₂) ph). Qed. Proposition poset_to_underlying_coequalizer_map_eq (h : y --> z) (q : f · h = g · h) : CoequalizerOut (underlying_Coequalizer E' f g (pr2 (EEC x y f g))) z h q = poset_to_underlying_coequalizer_map h q. Proof. use underlying_Coequalizer_arr_eq. { exact (pr2 (EEC x y f g)). } etrans. { apply (CoequalizerCommutes (underlying_Coequalizer E' f g (pr2 (EEC x y f g)))). } refine (!_). apply poset_to_underlying_coequalizer_map_in. Qed. End ToPosetCoequalizer. Definition to_poset_enrichment_coequalizer (EEC : enrichment_coequalizers E') : poset_enrichment_coequalizers. Proof. simple refine (_ ,, _). - exact (λ x y f g, underlying_Coequalizer E' f g (pr2 (EEC x y f g))). - abstract (intros w x y f g h₁ h₂ p₁ p₂ qh ; rewrite !poset_to_underlying_coequalizer_map_eq ; apply poset_to_underlying_coequalizer_map_monotone ; exact qh). Defined. Definition poset_enrichment_coequalizer_weq (HC : is_univalent C) : enrichment_coequalizers E' ≃ poset_enrichment_coequalizers. Proof. use weqimplimpl. - apply to_poset_enrichment_coequalizer. - apply make_poset_enrichment_coequalizers. - apply (isaprop_enrichment_coequalizers HC). - apply (isaprop_poset_enrichment_coequalizers HC). Defined. (** 4. Copowers *) Definition poset_enrichment_copows : UU := ∑ (coprods : ∏ (P : poset_sym_mon_closed_cat), Coproducts (pr11 P) C), ∏ (P : poset_sym_mon_closed_cat) (x : C), is_monotone (pr2 P) (E x (coprods P (λ _, x))) (CoproductIn _ _ (coprods P (λ _, x))) × (∏ (y : C), is_monotone (monotone_function_PartialOrder (pr2 P) (E x y)) (E (coprods P (λ _, x)) y) (λ f, CoproductArrow _ _ (coprods P (λ _, x)) (pr1 f))). Section PosetEnrichmentCopowersAccessors. Context (HE : poset_enrichment_copows). Definition poset_copows_coprod (P : poset_sym_mon_closed_cat) (x : C) : Coproduct (pr11 P) C (λ _, x) := pr1 HE P (λ _, x). Definition poset_copows_in {P : poset_sym_mon_closed_cat} {x : C} (i : pr11 P) : x --> poset_copows_coprod P x := CoproductIn _ _ (poset_copows_coprod P x) i. Proposition poset_copows_monotone_in (P : poset_sym_mon_closed_cat) (x : C) : is_monotone (pr2 P) (E x (poset_copows_coprod P x)) poset_copows_in. Proof. exact (pr1 (pr2 HE P x)). Qed. Proposition poset_copows_monotone_coproduct_arr (P : poset_sym_mon_closed_cat) (x y : C) : is_monotone (monotone_function_PartialOrder (pr2 P) (E x y)) (E (poset_copows_coprod P x) y) (λ f, CoproductArrow _ _ (poset_copows_coprod P x) (pr1 f)). Proof. exact (pr2 (pr2 HE P x) y). Qed. End PosetEnrichmentCopowersAccessors. Section PosetEnrichmentCopowers. Context (HE : poset_enrichment_copows) (P : poset_sym_mon_closed_cat) (x : C). Let copow : Coproduct _ C (λ _, x) := poset_copows_coprod HE P x. Let copow_in : ∏ (_ : pr11 P), x --> copow := λ i, poset_copows_in HE i. Definition poset_copower_cocone : copower_cocone E' P x. Proof. simple refine (_ ,, _). - exact copow. - simple refine (_ ,, _). + exact copow_in. + exact (poset_copows_monotone_in HE P x). Defined. Definition poset_copower_map (y : C) : P ⊸ (E' ⦃ x , y ⦄) --> E' ⦃ poset_copower_cocone , y ⦄. Proof. simple refine (_ ,, _). - intro f. exact (CoproductArrow _ _ copow (pr1 f)). - exact (poset_copows_monotone_coproduct_arr HE P x y). Defined. Definition poset_copower_is_copower : is_copower_enriched E' P x poset_copower_cocone. Proof. use make_is_copower_enriched. - exact poset_copower_map. - abstract (intro y ; use eq_monotone_function ; intro f ; cbn in f ; use CoproductArrow_eq ; intro i ; apply (CoproductInCommutes _ _ _ copow)). - abstract (intro y ; use eq_monotone_function ; intro f ; use eq_monotone_function ; intro i ; cbn ; apply (CoproductInCommutes _ _ _ copow)). Defined. End PosetEnrichmentCopowers. Definition poset_enrichment_copowers_from_coproducts (HE : poset_enrichment_copows) : enrichment_copower E'. Proof. intros P x. simple refine (_ ,, _). - exact (poset_copower_cocone HE P x). - apply poset_copower_is_copower. Defined. (** 5. Type indexed coproducts *) Section TypeIndexedCoproducts. Context (J : UU). Definition poset_enrichment_coprod : UU := ∑ (PC : Coproducts J C), ∏ (x : C) (ys : J → C) (fs₁ : ∏ (j : J), ys j --> x) (fs₂ : ∏ (j : J), ys j --> x) (q : ∏ (j : J), E _ _ (fs₁ j) (fs₂ j)), E _ _ (CoproductArrow _ _ (PC ys) fs₁) (CoproductArrow _ _ (PC ys) fs₂). Proposition isaprop_poset_enrichment_coprod (HC : is_univalent C) : isaprop poset_enrichment_coprod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Coproduct. exact HC. - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedCoprodAccessors. Context (EC : poset_enrichment_coprod). Definition poset_enrichment_obj_coprod (ys : J → C) : C := pr1 EC ys. Definition poset_enrichment_obj_coprod_in (ys : J → C) (j : J) : ys j --> poset_enrichment_obj_coprod ys := CoproductIn _ _ (pr1 EC ys) j. Definition poset_enrichment_obj_coprod_sum {x : C} {ys : J → C} (fs : ∏ (j : J), ys j --> x) : poset_enrichment_obj_coprod ys --> x := CoproductArrow _ _ (pr1 EC ys) fs. Proposition poset_enrichment_obj_coprod_in_sum {x : C} {ys : J → C} (fs : ∏ (j : J), ys j --> x) (j : J) : poset_enrichment_obj_coprod_in ys j · poset_enrichment_obj_coprod_sum fs = fs j. Proof. apply CoproductInCommutes. Qed. Proposition poset_enrichment_coprod_arr_eq {x : C} {ys : J → C} {f g : poset_enrichment_obj_coprod ys --> x} (p : ∏ (j : J), poset_enrichment_obj_coprod_in ys j · f = poset_enrichment_obj_coprod_in ys j · g) : f = g. Proof. use (CoproductArrow_eq _ _ _ (pr1 EC ys)). exact p. Qed. Definition poset_enrichment_coprod_pair (x : C) (ys : J → C) : Products_category_of_posets J (λ j, E' ⦃ ys j , x ⦄) --> E' ⦃ poset_enrichment_obj_coprod ys , x ⦄. Proof. simple refine (_ ,, _). - exact (λ fs, poset_enrichment_obj_coprod_sum (λ j, fs j)). - intros fs₁ fs₂ p. apply (pr2 EC). exact p. Defined. End PosetEnrichedCoprodAccessors. Section PosetCoprod. Context (EC : poset_enrichment_coprod) (ys : J → C). Definition make_poset_enriched_coprod_cocone : enriched_coprod_cocone E' ys. Proof. use make_enriched_coprod_cocone. - exact (poset_enrichment_obj_coprod EC ys). - exact (λ j, enriched_from_arr E' (poset_enrichment_obj_coprod_in EC ys j)). Defined. Definition poset_enrichment_coprod_is_coprod : is_coprod_enriched E' ys make_poset_enriched_coprod_cocone. Proof. use make_is_coprod_enriched. - intros z P fs. refine (_ · poset_enrichment_coprod_pair _ _ _). simple refine (_ ,, _). + exact (λ x j, pr1 (fs j) x). + abstract (use is_monotone_depfunction_poset_pair ; intro j ; exact (pr2 (fs j))). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_coprod_in_sum). - abstract (intros z P φ₁ φ₂ q ; use eq_monotone_function ; intro w ; use poset_enrichment_coprod_arr_eq ; intro j ; exact (eqtohomot (maponpaths (λ f, pr1 f) (q j)) w)). Defined. End PosetCoprod. Definition make_poset_enrichment_coprod (EC : poset_enrichment_coprod) : enrichment_coprod E' J := λ ys, make_poset_enriched_coprod_cocone EC ys ,, poset_enrichment_coprod_is_coprod EC ys. Section ToPosetCoproduct. Context (EP : enrichment_coprod E' J) {x : C} (ys : J → C). Let prod : poset_sym_mon_closed_cat := Products_category_of_posets J (λ j, E' ⦃ ys j , x ⦄). Let prod_pr : ∏ (j : J), prod --> E' ⦃ ys j , x ⦄ := λ j, _ ,, is_monotone_depfunction_poset_pr _ _ _. Definition poset_to_underlying_coprod_map (fs : ∏ (j : J), ys j --> x) : underlying_Coproduct E' ys (pr2 (EP ys)) --> x := pr1 (ProductArrow J category_of_posets (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod_pr) fs. Proposition poset_to_underlying_coprod_map_pr (fs : ∏ (j : J), ys j --> x) (j : J) : enriched_coprod_cocone_in E' ys (pr1 (EP ys)) j · poset_to_underlying_coprod_map fs = fs j. Proof. exact (eqtohomot (maponpaths pr1 (ProductPrCommutes J category_of_posets _ (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) _ prod_pr j)) fs). Qed. Proposition poset_to_underlying_coprod_map_monotone {φ ψ : ∏ (j : J), ys j --> x} (p : ∏ (j : J), E (ys j) x (φ j) (ψ j)) : E _ _ (poset_to_underlying_coprod_map φ) (poset_to_underlying_coprod_map ψ). Proof. exact (pr2 (@ProductArrow _ _ _ (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod prod_pr) φ ψ p). Qed. Proposition poset_to_underlying_coprod_map_eq (fs : ∏ (j : J), ys j --> x) : CoproductArrow _ C (underlying_Coproduct E' ys (pr2 (EP ys))) fs = poset_to_underlying_coprod_map fs. Proof. use is_coprod_enriched_arrow_eq. - exact (pr2 (EP ys)). - intro j. refine (_ @ !(poset_to_underlying_coprod_map_pr fs j)). apply (CoproductInCommutes _ C _ (underlying_Coproduct E' ys (pr2 (EP ys))) _ fs). Qed. End ToPosetCoproduct. Definition to_poset_enrichment_coprod (EP : enrichment_coprod E' J) : poset_enrichment_coprod. Proof. simple refine (_ ,, _). - exact (λ ys, underlying_Coproduct E' ys (pr2 (EP ys))). - abstract (intros x ys fs₁ fs₂ p ; rewrite !poset_to_underlying_coprod_map_eq ; apply (poset_to_underlying_coprod_map_monotone EP _ p)). Defined. Definition poset_enrichment_prod_weq (HC : is_univalent C) : enrichment_coprod E' J ≃ poset_enrichment_coprod. Proof. use weqimplimpl. - apply to_poset_enrichment_coprod. - apply make_poset_enrichment_coprod. - apply (isaprop_enrichment_coprod HC). - apply (isaprop_poset_enrichment_coprod HC). Defined. End TypeIndexedCoproducts. End PosetEnrichmentColimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/SelfEnrichedColimits.v000066400000000000000000000467051451125700300317630ustar00rootroot00000000000000(***************************************************************** Colimits in self enriched categories We construct colimits in self enriched categories. Copowers in the self enriched category come from the tensor in the monoidal category. To show how the construction of colimits works, we show how to construct an initial object in the self-enriched category Suppose that `V` is a symmetric monoidal closed category and let `x` be an initial object in `V`. We want to show that `x` also is an initial object in the enriched sense. This means that for all objects `y`, we must show that `x ⊸ y` is terminal in `V`. So, we must show that for every `w` the type `w --> x ⊸ y` is contractible. Since `⊸` is right adjoint to `⊗`, the types `w --> x ⊸ y` and `w ⊗ x --> y` are equivalent. As such, it suffices to show that `w ⊗ x --> y` is contractible. This is equivalent to `w ⊗ x` being an initial object, so it suffices to show that `w ⊗ x` is initial. Since `V` is monoidal closed, we know that the functor `x ↦ w ⊗ x` is a left adjoint, and thus it preserves initial objects. Since `x` is initial, we also get that `w ⊗ x` is initial, so we conclude that `V` has an initial object in the enriched sense. Contents 1. Initial objects 2. Binary coproducts 3. Coequalizers 4. Copowers 5. Type indexed coproducts *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section SelfEnrichmentColimits. Context (V : sym_mon_closed_cat). (** 1. Initial objects *) Definition self_enrichment_initial (v : Initial V) : initial_enriched (self_enrichment V). Proof. refine (pr1 v ,, _). intros x y ; cbn. use (iscontrweqb (internal_hom_equiv _ _ _)). exact (left_adjoint_preserves_initial _ (sym_mon_closed_left_tensor_left_adjoint V y) _ (pr2 v) x). Defined. (** 2. Binary coproducts *) Section SelfEnrichedCoproduct. Context {x y : V} (c : BinCoproduct x y). Let ι₁ : I_{V} --> x ⊸ c := enriched_from_arr (self_enrichment V) (BinCoproductIn1 c). Let ι₂ : I_{V} --> y ⊸ c := enriched_from_arr (self_enrichment V) (BinCoproductIn2 c). Definition make_self_enriched_binary_coprod_cocone : enriched_binary_coprod_cocone (self_enrichment V) x y. Proof. use make_enriched_binary_coprod_cocone. - exact c. - exact ι₁. - exact ι₂. Defined. Definition self_enriched_is_binary_coprod_paths_weq {w z : V} (f : z --> x ⊸ w) (g : z --> y ⊸ w) (fg : z --> c ⊸ w) : (fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₁) = f × fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₂) = g) ≃ (identity z #⊗ BinCoproductIn1 c · (fg #⊗ identity c · internal_eval c w) = f #⊗ identity x · internal_eval x w) × (identity z #⊗ BinCoproductIn2 c · (fg #⊗ identity c · internal_eval c w) = g #⊗ identity y · internal_eval y w). Proof. use weqimplimpl. - intros pq. split. + rewrite !assoc. rewrite <- tensor_split. pose (p := pr1 pq) ; cbn in p. rewrite self_enrichment_precomp in p. rewrite <- p. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split'. apply maponpaths_2. apply maponpaths. rewrite internal_to_from_arr. apply idpath. + rewrite !assoc. rewrite <- tensor_split. pose (p := pr2 pq) ; cbn in p. rewrite self_enrichment_precomp in p. rewrite <- p. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split'. apply maponpaths_2. apply maponpaths. rewrite internal_to_from_arr. apply idpath. - intros pq. split. + pose (p := pr1 pq). rewrite !assoc in p. rewrite <- tensor_split in p. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite self_enrichment_precomp. rewrite !assoc'. rewrite internal_beta. rewrite (tensor_split f h). rewrite !assoc'. rewrite <- p. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite id_left, id_right. do 2 apply maponpaths. cbn. apply internal_to_from_arr. + pose (p := pr2 pq) ; cbn in p. rewrite !assoc in p. rewrite <- tensor_split in p. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite self_enrichment_precomp. rewrite !assoc'. rewrite internal_beta. rewrite (tensor_split g h). rewrite !assoc'. rewrite <- p. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite id_left, id_right. do 2 apply maponpaths. cbn. apply internal_to_from_arr. - apply isapropdirprod ; apply homset_property. - apply isapropdirprod ; apply homset_property. Qed. Definition self_enriched_is_binary_coprod_weq {w z : V} (f : z --> x ⊸ w) (g : z --> y ⊸ w) : (∑ (fg : z --> c ⊸ w), fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₁) = f × fg · precomp_arr (self_enrichment V) w (internal_to_arr ι₂) = g) ≃ (∑ (fg : z ⊗ c --> w), identity z #⊗ BinCoproductIn1 c · fg = f #⊗ identity x · internal_eval x w × identity z #⊗ BinCoproductIn2 c · fg = g #⊗ identity y · internal_eval y w). Proof. use weqtotal2. - exact (internal_hom_equiv z c w). - exact (self_enriched_is_binary_coprod_paths_weq f g). Defined. Definition self_enriched_is_binary_coprod : is_binary_coprod_enriched (self_enrichment V) x y make_self_enriched_binary_coprod_cocone. Proof. intros w z f g. use (iscontrweqb (self_enriched_is_binary_coprod_weq f g)). apply (left_adjoint_preserves_bincoproduct _ (sym_mon_closed_left_tensor_left_adjoint V z) _ _ _ _ _ (pr2 c)). Defined. End SelfEnrichedCoproduct. Definition self_enrichment_binary_coproducts (coprodV : BinCoproducts V) : enrichment_binary_coprod (self_enrichment V) := λ x y, make_self_enriched_binary_coprod_cocone (coprodV x y) ,, self_enriched_is_binary_coprod (coprodV x y). (** 3. Coequalizers *) Section SelfEnrichmentCoequalizer. Context {x y : V} {f g : x --> y} (c : Coequalizer f g). Let e : y --> c := CoequalizerArrow c. Definition make_self_enriched_coequalizer_cocone : enriched_coequalizer_cocone (self_enrichment V) f g. Proof. use make_enriched_coequalizer_cocone. - exact c. - exact (enriched_from_arr (self_enrichment V) e). - abstract (cbn ; rewrite !internal_to_from_arr ; exact (CoequalizerEqAr c)). Defined. Definition self_enriched_is_coequalizer_path_weq {w z : V} (h : z --> y ⊸ w) (φ : z --> c ⊸ w) : (φ · precomp_arr (self_enrichment V) w (internal_to_arr (internal_from_arr e)) = h) ≃ (identity z #⊗ CoequalizerArrow c · (φ #⊗ identity c · internal_eval c w) = h #⊗ identity y · internal_eval y w). Proof. use weqimplimpl. - intro p. rewrite self_enrichment_precomp in p. rewrite <- p. rewrite tensor_comp_id_r. rewrite !assoc'. rewrite internal_beta. rewrite internal_to_from_arr. rewrite !assoc. rewrite <- tensor_split. rewrite <- tensor_split'. apply idpath. - intro p. use internal_funext. intros a k. rewrite !assoc in p. rewrite <- tensor_split in p. rewrite self_enrichment_precomp. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite internal_to_from_arr. rewrite (tensor_split h k). rewrite !assoc'. rewrite <- p. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite id_right. rewrite id_left. apply idpath. - apply homset_property. - apply homset_property. Qed. Definition self_enriched_is_coequalizer_weq {w z : V} (h : z --> y ⊸ w) (r : h · precomp_arr (self_enrichment V) w f = h · precomp_arr (self_enrichment V) w g) : (∑ (φ : z --> c ⊸ w), φ · precomp_arr (self_enrichment V) w (internal_to_arr (internal_from_arr e)) = h) ≃ (∑ (φ : z ⊗ c --> w), identity z #⊗ CoequalizerArrow c · φ = h #⊗ identity _ · internal_eval y w). Proof. use weqtotal2. - exact (internal_hom_equiv z c w). - exact (self_enriched_is_coequalizer_path_weq h). Defined. Definition make_self_enriched_is_coequalizer : is_coequalizer_enriched (self_enrichment V) f g make_self_enriched_coequalizer_cocone. Proof. intros w z h r. use (iscontrweqb (self_enriched_is_coequalizer_weq h r)). refine (left_adjoint_preserves_coequalizer _ (sym_mon_closed_left_tensor_left_adjoint V z) _ _ _ _ _ _ _ _ (pr22 c) _ _ _). - cbn. rewrite <- !tensor_comp_id_l. apply maponpaths. apply CoequalizerEqAr. - abstract (cbn ; pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) r) as r' ; cbn in r' ; rewrite !self_enrichment_precomp in r' ; rewrite !tensor_comp_id_r in r' ; rewrite !assoc' in r' ; rewrite !internal_beta in r' ; rewrite !assoc in r' ; rewrite <- !tensor_split' in r' ; rewrite !assoc ; rewrite <- !tensor_split ; exact r'). Defined. End SelfEnrichmentCoequalizer. Definition self_enrichment_coequalizers (coeqV : Coequalizers V) : enrichment_coequalizers (self_enrichment V) := λ x y f g, make_self_enriched_coequalizer_cocone (coeqV x y f g) ,, make_self_enriched_is_coequalizer (coeqV x y f g). (** 4. Copowers *) Section SelfEnrichmentCopower. Context (v₁ v₂ : V). Definition self_enrichment_copower_cocone : copower_cocone (self_enrichment V) v₁ v₂. Proof. use make_copower_cocone. - exact (v₁ ⊗ v₂). - exact (internal_pair v₁ v₂). Defined. Proposition self_enrichment_is_copower_eq_1 (w : V) : is_copower_enriched_map (self_enrichment V) v₁ v₂ self_enrichment_copower_cocone w · internal_uncurry v₁ v₂ w = identity _. Proof. cbn. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_uncurry. rewrite internal_beta. unfold is_copower_enriched_map. rewrite tensor_split. rewrite <- tensor_id_id. etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_rassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite internal_beta ; cbn. rewrite tensor_comp_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. unfold internal_pair. rewrite internal_beta. rewrite tensor_id_id. apply id_left. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite mon_rassociator_lassociator. apply id_right. Qed. Proposition self_enrichment_is_copower_eq_2 (w : V) : internal_uncurry v₁ v₂ w · is_copower_enriched_map (self_enrichment V) v₁ v₂ self_enrichment_copower_cocone w = identity _. Proof. use internal_funext ; cbn. intros a₁ h₁. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map ; cbn. rewrite internal_beta. use internal_funext ; cbn. intros a₂ h₂. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. unfold internal_pair. rewrite internal_beta. rewrite tensor_id_id. apply id_left. } rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_split. rewrite !assoc'. unfold internal_uncurry. rewrite internal_beta. rewrite !assoc. rewrite tensor_rassociator. rewrite !assoc'. apply idpath. } rewrite !assoc. rewrite mon_lassociator_rassociator. rewrite id_left. apply idpath. Qed. Definition self_enrichment_is_copower : is_copower_enriched (self_enrichment V) v₁ v₂ self_enrichment_copower_cocone. Proof. use make_is_copower_enriched. - exact (λ w, internal_uncurry v₁ v₂ w). - exact self_enrichment_is_copower_eq_1. - exact self_enrichment_is_copower_eq_2. Defined. End SelfEnrichmentCopower. Definition self_enrichment_copowers : enrichment_copower (self_enrichment V) := λ v₁ v₂, self_enrichment_copower_cocone v₁ v₂ ,, self_enrichment_is_copower v₁ v₂. (** 5. Type indexed coproducts *) Section SelfEnrichmentTypeCoproduct. Context {J : UU} {D : J → V} (coprod : Coproduct J V D). Let ι : ∏ (j : J), I_{V} --> D j ⊸ coprod := λ j, enriched_from_arr (self_enrichment V) (CoproductIn _ _ coprod j). Definition self_enriched_coprod_cocone : enriched_coprod_cocone (self_enrichment V) D. Proof. use make_enriched_coprod_cocone. - exact coprod. - exact ι. Defined. Definition self_enriched_is_coprod_weq_path {w z : V} (f : ∏ (j : J), z --> D j ⊸ w) (fs : z --> coprod ⊸ w) (j : J) : (fs · precomp_arr (self_enrichment V) w (internal_to_arr (internal_from_arr (CoproductIn J V coprod j))) = f j) ≃ (identity z #⊗ CoproductIn J V coprod j · (fs #⊗ identity coprod · internal_eval coprod w) = f j #⊗ identity (D j) · internal_eval (D j) w). Proof. rewrite internal_to_from_arr. rewrite self_enrichment_precomp. rewrite !assoc. rewrite <- tensor_split. use weqimplimpl. - intro p. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) p) as q. cbn in q. rewrite tensor_comp_id_r in q. rewrite !assoc' in q. rewrite internal_beta in q. rewrite !assoc in q. rewrite <- tensor_split' in q. exact q. - intro p. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite (tensor_split fs h). rewrite (tensor_split (f j) h). rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. exact p. - apply homset_property. - apply homset_property. Qed. Definition self_enriched_is_coprod_weq {w z : V} (f : ∏ (j : J), z --> D j ⊸ w) : (∑ (fs : z --> coprod ⊸ w), ∏ (j : J), fs · precomp_arr (self_enrichment V) w (internal_to_arr (ι j)) = f j) ≃ (∑ (fs : z ⊗ coprod --> w), ∏ (j : J), identity z #⊗ CoproductIn _ _ coprod j · fs = f j #⊗ identity _ · internal_eval (D j) w). Proof. use weqtotal2. - exact (internal_hom_equiv z coprod w). - intro fs ; cbn -[ι]. use weqonsecfibers. intro j. apply self_enriched_is_coprod_weq_path. Defined. Definition self_enriched_is_coprod : is_coprod_enriched (self_enrichment V) D self_enriched_coprod_cocone. Proof. intros w z f. use (iscontrweqb (self_enriched_is_coprod_weq f)). apply (left_adjoint_preserves_coproduct _ (sym_mon_closed_left_tensor_left_adjoint V z) _ _ _ _ (pr2 coprod)). Defined. End SelfEnrichmentTypeCoproduct. Definition self_enrichment_coprod (J : UU) (HV : Coproducts J V) : enrichment_coprod (self_enrichment V) J := λ D, self_enriched_coprod_cocone (HV D) ,, self_enriched_is_coprod (HV D). End SelfEnrichmentColimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v000066400000000000000000001015331451125700300330610ustar00rootroot00000000000000(***************************************************************** Colimits in categories enriched over structures In this file we characterize colimits in categories enriched over structures. The proofs and characterizations are in essence the same as for posets. A category enriched over structures inherits its colimits from the underlying category if inclsuons and the maps arising from the universal property are structure preserving. Contents 1. Initial object 2. Binary coproducts 3. Coequalizers 4. Type indexed coproducts 5. Copowers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.StructureEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.StructuresMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section StructureEnrichmentColimits. Context {P : hset_cartesian_closed_struct} {C : category} (E : struct_enrichment P C). Let E' : enrichment C (sym_mon_closed_cat_of_hset_struct P) := make_enrichment_over_struct P C E. (** 1. Initial object *) Section StructureEnrichedInitial. Context {x : C} (Hx : isInitial C x). Let T : Initial C := make_Initial x Hx. Definition structure_enrichment_is_initial : is_initial_enriched E' x. Proof. use make_is_initial_enriched. - intros X y. simple refine (_ ,, _). + exact (λ _, InitialArrow T y). + abstract (cbn ; apply hset_struct_const). - abstract (intros X y f g ; use eq_mor_hset_struct ; intros z ; apply (@InitialArrowEq _ T)). Defined. End StructureEnrichedInitial. Definition make_structure_enrichment_initial (HC : Initial C) : initial_enriched E' := pr1 HC ,, structure_enrichment_is_initial (pr2 HC). Definition structure_terminal_enriched_weq_Initial (HC : is_univalent C) : initial_enriched E' ≃ Initial C. Proof. use weqimplimpl. - exact (λ T, initial_underlying E' T). - exact make_structure_enrichment_initial. - apply (isaprop_initial_enriched _ HC). - apply (isaprop_Initial _ HC). Defined. (** 2. Binary coproducts *) Definition structure_enrichment_binary_coprod : UU := ∑ (BC : BinCoproducts C), ∏ (x y z : C), mor_hset_struct P (hset_struct_prod P (E x z) (E y z)) (E (BC x y) z) (λ fg, BinCoproductArrow (BC x y) (pr1 fg) (pr2 fg)). Proposition isaprop_structure_enrichment_binary_coprod (HC : is_univalent C) : isaprop structure_enrichment_binary_coprod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - do 2 (use impred ; intro). apply (isaprop_BinCoproduct _ HC). - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedCoprodAccessors. Context (EBC : structure_enrichment_binary_coprod). Definition structure_enrichment_obj_binary_coprod (x y : C) : C := pr1 EBC x y. Definition structure_enrichment_obj_in1 (x y : C) : x --> structure_enrichment_obj_binary_coprod x y := BinCoproductIn1 (pr1 EBC x y). Definition structure_enrichment_obj_in2 (x y : C) : y --> structure_enrichment_obj_binary_coprod x y := BinCoproductIn2 (pr1 EBC x y). Definition structure_enrichment_obj_sum {z x y : C} (f : x --> z) (g : y --> z) : structure_enrichment_obj_binary_coprod x y --> z := BinCoproductArrow (pr1 EBC x y) f g. Proposition structure_enrichment_obj_in1_sum {z x y : C} (f : x --> z) (g : y --> z) : structure_enrichment_obj_in1 x y · structure_enrichment_obj_sum f g = f. Proof. apply BinCoproductIn1Commutes. Qed. Proposition structure_enrichment_obj_in2_sum {z x y : C} (f : x --> z) (g : y --> z) : structure_enrichment_obj_in2 x y · structure_enrichment_obj_sum f g = g. Proof. apply BinCoproductIn2Commutes. Qed. Proposition structure_enrichment_binary_coprod_arr_eq {w x y : C} {f g : structure_enrichment_obj_binary_coprod x y --> w} (p : structure_enrichment_obj_in1 x y · f = structure_enrichment_obj_in1 x y · g) (q : structure_enrichment_obj_in2 x y · f = structure_enrichment_obj_in2 x y · g) : f = g. Proof. use (BinCoproductArrowsEq _ _ _ (pr1 EBC x y)). - exact p. - exact q. Qed. Definition structure_enrichment_binary_coprod_pair (x y z : C) : E' ⦃ x , z ⦄ ⊗ (E' ⦃ y , z ⦄) --> E' ⦃ structure_enrichment_obj_binary_coprod x y , z ⦄ := _ ,, pr2 EBC x y z. End StructureEnrichedCoprodAccessors. Section StructureCoprod. Context (EBC : structure_enrichment_binary_coprod) (x y : C). Definition make_structure_enriched_binary_coprod_cocone : enriched_binary_coprod_cocone E' x y. Proof. use make_enriched_binary_coprod_cocone. - exact (structure_enrichment_obj_binary_coprod EBC x y). - exact (enriched_from_arr E' (structure_enrichment_obj_in1 EBC x y)). - exact (enriched_from_arr E' (structure_enrichment_obj_in2 EBC x y)). Defined. Definition structure_enrichment_binary_coprod_is_coprod : is_binary_coprod_enriched E' x y make_structure_enriched_binary_coprod_cocone. Proof. use make_is_binary_coprod_enriched. - intros z X f g. refine (_ · structure_enrichment_binary_coprod_pair _ _ _ _). simple refine (_ ,, _). + exact (prodtofuntoprod (pr1 f ,, pr1 g)). + apply hset_struct_pair. * exact (pr2 f). * exact (pr2 g). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_in1_sum). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_in2_sum). - abstract (intros z X φ₁ φ₂ q₁ q₂ ; use eq_mor_hset_struct ; intro w ; use structure_enrichment_binary_coprod_arr_eq ; [ exact (eqtohomot (maponpaths (λ f, pr1 f) q₁) w) | exact (eqtohomot (maponpaths (λ f, pr1 f) q₂) w) ]). Defined. End StructureCoprod. Definition make_structure_enrichment_binary_coprod (EBC : structure_enrichment_binary_coprod) : enrichment_binary_coprod E' := λ x y, make_structure_enriched_binary_coprod_cocone EBC x y ,, structure_enrichment_binary_coprod_is_coprod EBC x y. Section ToStructureCoproduct. Context (EP : enrichment_binary_coprod E') {x y z : C}. Let prod : sym_monoidal_cat_of_hset_struct P := (E' ⦃ y , x ⦄) ⊗ (E' ⦃ z , x ⦄). Let prod_pr1 : prod --> E' ⦃ y , x ⦄ := _ ,, hset_struct_pr1 _ _ _. Let prod_pr2 : prod --> E' ⦃ z , x ⦄ := _ ,, hset_struct_pr2 _ _ _. Definition structure_to_underlying_binary_coprod_map (f : y --> x) (g : z --> x) : underlying_BinCoproduct E' y z (pr2 (EP y z)) --> x := pr1 (BinProductArrow (sym_monoidal_cat_of_hset_struct P) (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) prod_pr1 prod_pr2) (f ,, g). Proposition structure_to_underlying_binary_coprod_map_in1 (f : y --> x) (g : z --> x) : enriched_coprod_cocone_in1 E' y z (pr1 (EP y z)) · structure_to_underlying_binary_coprod_map f g = f. Proof. pose (eqtohomot (maponpaths pr1 (BinProductPr1Commutes _ _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) _ prod_pr1 prod_pr2)) (f ,, g)) as p. cbn in p. exact p. Qed. Proposition structure_to_underlying_binary_coprod_map_in2 (f : y --> x) (g : z --> x) : enriched_coprod_cocone_in2 E' y z (pr1 (EP y z)) · structure_to_underlying_binary_coprod_map f g = g. Proof. pose (eqtohomot (maponpaths pr1 (BinProductPr2Commutes _ _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) _ prod_pr1 prod_pr2)) (f ,, g)) as p. cbn in p. exact p. Qed. Proposition structure_to_underlying_binary_coprod_map_eq : (λ fg, BinCoproductArrow (underlying_BinCoproduct E' y z (pr2 (EP y z))) (pr1 fg) (pr2 fg)) = (λ fg, structure_to_underlying_binary_coprod_map (pr1 fg) (dirprod_pr2 fg)). Proof. use funextsec. intros fg. use is_binary_coprod_enriched_arrow_eq. - exact (pr2 (EP y z)). - refine (_ @ !(structure_to_underlying_binary_coprod_map_in1 _ _)). apply (BinCoproductIn1Commutes C _ _ (underlying_BinCoproduct E' y z (pr2 (EP y z))) _ _ _). - refine (_ @ !(structure_to_underlying_binary_coprod_map_in2 _ _)). apply (BinCoproductIn2Commutes C _ _ (underlying_BinCoproduct E' y z (pr2 (EP y z))) _ _ _). Qed. Proposition structure_to_underlying_binary_coprod_map_structure_preserving : mor_hset_struct P (hset_struct_prod P (E y x) (E z x)) (E (underlying_BinCoproduct E' y z (pr2 (EP y z))) x) (λ fg, BinCoproductArrow (underlying_BinCoproduct E' y z (pr2 (EP y z))) (pr1 fg) (pr2 fg)). Proof. exact (transportb _ structure_to_underlying_binary_coprod_map_eq (pr2 (@BinProductArrow _ _ _ (is_binary_coprod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) prod prod_pr1 prod_pr2))). Qed. End ToStructureCoproduct. Definition to_structure_enrichment_binary_coprod (EP : enrichment_binary_coprod E') : structure_enrichment_binary_coprod. Proof. simple refine (_ ,, _). - exact (λ x y, underlying_BinCoproduct E' x y (pr2 (EP x y))). - abstract (intros x y z ; apply structure_to_underlying_binary_coprod_map_structure_preserving). Defined. Definition structure_enrichment_binary_coprod_weq (HC : is_univalent C) : enrichment_binary_coprod E' ≃ structure_enrichment_binary_coprod. Proof. use weqimplimpl. - apply to_structure_enrichment_binary_coprod. - apply make_structure_enrichment_binary_coprod. - apply (isaprop_enrichment_binary_coprod HC). - apply (isaprop_structure_enrichment_binary_coprod HC). Defined. (** 3. Coequalizers *) Section CoequalizerStructures. Context (HP : hset_equalizer_struct P). Definition structure_enrichment_coequalizers : UU := ∑ (EC : Coequalizers C), ∏ (w x y : C) (f g : x --> y), mor_hset_struct P (hset_struct_equalizer HP (pr2 (precomp_arr E' w f)) (pr2 (precomp_arr E' w g))) (E (EC x y f g) w) (λ h, CoequalizerOut (EC x y f g) w (pr1 h) (pr2 h)). Proposition isaprop_structure_enrichment_coequalizers (HC : is_univalent C) : isaprop structure_enrichment_coequalizers. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Coequalizer. exact HC. - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedCoequalizerAccessors. Context (EEC : structure_enrichment_coequalizers). Definition structure_enrichment_obj_coequalizer {x y : C} (f g : x --> y) : C := pr1 EEC x y f g. Definition structure_enrichment_obj_coequalizer_in {x y : C} (f g : x --> y) : y --> structure_enrichment_obj_coequalizer f g := CoequalizerArrow (pr1 EEC x y f g). Proposition structure_enrichment_obj_in_eq {x y : C} (f g : x --> y) : f · structure_enrichment_obj_coequalizer_in f g = g · structure_enrichment_obj_coequalizer_in f g. Proof. apply CoequalizerEqAr. Qed. Definition structure_enrichment_obj_from_coequalizer {w x y : C} {f g : x --> y} (h : y --> w) (q : f · h = g · h) : structure_enrichment_obj_coequalizer f g --> w := CoequalizerOut (pr1 EEC x y f g) w h q. Proposition structure_enrichment_obj_from_coequalizer_in {w x y : C} {f g : x --> y} (h : y --> w) (q : f · h = g · h) : structure_enrichment_obj_coequalizer_in f g · structure_enrichment_obj_from_coequalizer h q = h. Proof. apply CoequalizerCommutes. Qed. Proposition structure_enrichment_coequalizer_arr_eq {w x y : C} {f g : x --> y} {h₁ h₂ : structure_enrichment_obj_coequalizer f g --> w} (q : structure_enrichment_obj_coequalizer_in f g · h₁ = structure_enrichment_obj_coequalizer_in f g · h₂) : h₁ = h₂. Proof. use CoequalizerOutsEq. exact q. Qed. Definition structure_enrichment_to_coequalizer {w x y : C} (f g : x --> y) : hset_struct_equalizer_ob HP (pr2 (precomp_arr E' w f)) (pr2 (precomp_arr E' w g)) --> E' ⦃ structure_enrichment_obj_coequalizer f g , w⦄ := _ ,, pr2 EEC w x y f g. End StructureEnrichedCoequalizerAccessors. Section StructureCoequalizer. Context (EEC : structure_enrichment_coequalizers) {x y : C} (f g : x --> y). Definition make_structure_enrichment_coequalizer_cocone : enriched_coequalizer_cocone E' f g. Proof. use make_enriched_coequalizer_cocone. - exact (structure_enrichment_obj_coequalizer EEC f g). - exact (enriched_from_arr E' (structure_enrichment_obj_coequalizer_in EEC f g)). - exact (structure_enrichment_obj_in_eq EEC f g). Defined. Definition make_structure_enrichment_coequalizer_is_coequalizer : is_coequalizer_enriched E' f g make_structure_enrichment_coequalizer_cocone. Proof. use make_is_coequalizer_enriched. - abstract (intros w X φ₁ φ₂ q ; use eq_mor_hset_struct ; intro z ; use structure_enrichment_coequalizer_arr_eq ; exact (eqtohomot (maponpaths pr1 q) z)). - intros w X h q. refine (_ · structure_enrichment_to_coequalizer EEC f g). simple refine (_ ,, _). + refine (λ z, pr1 h z ,, _). exact (eqtohomot (maponpaths pr1 q) z). + abstract (apply hset_equalizer_arrow_struct ; exact (pr2 h)). - abstract (intros w X h q ; use eq_mor_hset_struct ; intros z ; apply structure_enrichment_obj_from_coequalizer_in). Defined. End StructureCoequalizer. Definition make_structure_enrichment_coequalizers (EEC : structure_enrichment_coequalizers) : enrichment_coequalizers E'. Proof. intros x y f g. simple refine (_ ,, _). - exact (make_structure_enrichment_coequalizer_cocone EEC f g). - exact (make_structure_enrichment_coequalizer_is_coequalizer EEC f g). Defined. Section ToStructureCoequalizer. Context (EEC : enrichment_coequalizers E') {w x y : C} (f g : x --> y). Let Eq : Equalizer _ _ := Equalizers_category_of_hset_struct HP _ _ (precomp_arr E' w f) (precomp_arr E' w g). Let Eq_pr : Eq --> E' ⦃ y , w ⦄ := EqualizerArrow _. Let Eq_path : Eq_pr · precomp_arr E' w f = Eq_pr · precomp_arr E' w g := EqualizerEqAr _. Definition structure_to_underlying_coequalizer_map (h : y --> w) (q : f · h = g · h) : underlying_Coequalizer E' f g (pr2 (EEC x y f g)) --> w := pr1 (EqualizerIn (is_coequalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path) (h ,, q). Proposition structure_to_underlying_coequalizer_map_in (h : y --> w) (q : f · h = g · h) : enriched_coequalizer_cocone_in E' f g (pr1 (EEC x y f g)) · structure_to_underlying_coequalizer_map h q = h. Proof. pose (eqtohomot (maponpaths pr1 (EqualizerCommutes (is_coequalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path)) (h ,, q)) as p. cbn in p. exact p. Qed. Definition to_structure_enrichment_coequalizer_structure_preserving : mor_hset_struct P (hset_struct_equalizer HP (pr2 (precomp_arr E' w f)) (pr2 (precomp_arr E' w g))) (E (underlying_Coequalizer E' f g (pr2 (EEC x y f g))) w) (λ h, CoequalizerOut (underlying_Coequalizer E' f g (pr2 (EEC x y f g))) w (pr1 h) (pr2 h)). Proof. refine (transportb _ _ (pr2 (EqualizerIn (is_coequalizer_enriched_to_Equalizer E' _ _ (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path))). use funextsec. intros fg. use underlying_Coequalizer_arr_eq. - exact (pr2 (EEC x y f g)). - refine (_ @ !(structure_to_underlying_coequalizer_map_in (pr1 fg) (pr2 fg))). apply (CoequalizerCommutes (underlying_Coequalizer E' f g (pr2 (EEC x y f g)))). Qed. End ToStructureCoequalizer. Definition to_structure_enrichment_coequalizer (EEC : enrichment_coequalizers E') : structure_enrichment_coequalizers. Proof. simple refine (_ ,, _). - exact (λ x y f g, underlying_Coequalizer E' f g (pr2 (EEC x y f g))). - abstract (intros w x y f g ; apply to_structure_enrichment_coequalizer_structure_preserving). Defined. Definition structure_enrichment_coequalizer_weq (HC : is_univalent C) : enrichment_coequalizers E' ≃ structure_enrichment_coequalizers. Proof. use weqimplimpl. - apply to_structure_enrichment_coequalizer. - apply make_structure_enrichment_coequalizers. - apply (isaprop_enrichment_coequalizers HC). - apply (isaprop_structure_enrichment_coequalizers HC). Defined. End CoequalizerStructures. (** 4. Type indexed coproducts *) Section StructureTypeIndexedCoproducts. Context {J : UU} (HP : hset_struct_type_prod P J). Definition structure_enrichment_coprod : UU := ∑ (PC : Coproducts J C), ∏ (x : C) (ys : J → C), mor_hset_struct P (HP _ (λ j, pr2 (E' ⦃ ys j , x ⦄))) (E (PC ys) x) (λ h, CoproductArrow _ _ (PC ys) (λ i, h i)). Proposition isaprop_structure_enrichment_coprod (HC : is_univalent C) : isaprop structure_enrichment_coprod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Coproduct. exact HC. - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedCoprodAccessors. Context (EC : structure_enrichment_coprod). Definition structure_enrichment_obj_coprod (ys : J → C) : C := pr1 EC ys. Definition structure_enrichment_obj_coprod_in (ys : J → C) (j : J) : ys j --> structure_enrichment_obj_coprod ys := CoproductIn _ _ (pr1 EC ys) j. Definition structure_enrichment_obj_coprod_sum {x : C} {ys : J → C} (fs : ∏ (j : J), ys j --> x) : structure_enrichment_obj_coprod ys --> x := CoproductArrow _ _ (pr1 EC ys) fs. Proposition structure_enrichment_obj_coprod_sum_in {x : C} {ys : J → C} (fs : ∏ (j : J), ys j --> x) (j : J) : structure_enrichment_obj_coprod_in ys j · structure_enrichment_obj_coprod_sum fs = fs j. Proof. apply CoproductInCommutes. Qed. Proposition structure_enrichment_coprod_arr_eq {x : C} {ys : J → C} {f g : structure_enrichment_obj_coprod ys --> x} (p : ∏ (j : J), structure_enrichment_obj_coprod_in ys j · f = structure_enrichment_obj_coprod_in ys j · g) : f = g. Proof. use (CoproductArrow_eq _ _ _ (pr1 EC ys)). exact p. Qed. Definition structure_enrichment_coprod_pair (x : C) (ys : J → C) : hset_struct_type_prod_ob HP _ (λ j, pr2 (E' ⦃ ys j , x ⦄)) --> E' ⦃ pr1 EC ys , x ⦄ := _ ,, pr2 EC x ys. End StructureEnrichedCoprodAccessors. Section StructureCoprod. Context (EBC : structure_enrichment_coprod) (ys : J → C). Definition make_structure_enriched_coprod_cocone : enriched_coprod_cocone E' ys. Proof. use make_enriched_coprod_cocone. - exact (structure_enrichment_obj_coprod EBC ys). - exact (λ j, enriched_from_arr E' (structure_enrichment_obj_coprod_in EBC ys j)). Defined. Definition structure_enrichment_coprod_is_coprod : is_coprod_enriched E' ys make_structure_enriched_coprod_cocone. Proof. use make_is_coprod_enriched. - intros z X fs. refine (_ · structure_enrichment_coprod_pair _ _ _). simple refine (_ ,, _). + exact (λ x j, pr1 (fs j) x). + abstract (use hset_struct_type_prod_pair ; intro j ; exact (pr2 (fs j))). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_coprod_sum_in). - abstract (intros z X φ₁ φ₂ q ; use eq_mor_hset_struct ; intro w ; use structure_enrichment_coprod_arr_eq ; intro j ; exact (eqtohomot (maponpaths (λ f, pr1 f) (q j)) w)). Defined. End StructureCoprod. Definition make_structure_enrichment_coprod (EBC : structure_enrichment_coprod) : enrichment_coprod E' J := λ ys, make_structure_enriched_coprod_cocone EBC ys ,, structure_enrichment_coprod_is_coprod EBC ys. Section ToStructureCoproduct. Context (EP : enrichment_coprod E' J) {x : C} (ys : J → C). Let prod : Product _ _ _ := Products_category_of_hset_struct_type_prod HP (λ j, E' ⦃ ys j , x ⦄). Let prod_pr : ∏ (j : J), prod --> E' ⦃ ys j , x ⦄ := λ j, _ ,, hset_struct_type_prod_pr HP (λ j, pr2 (E' ⦃ ys j , x ⦄)) j. Definition structure_to_underlying_coprod_map (fs : ∏ (j : J), ys j --> x) : underlying_Coproduct E' ys (pr2 (EP ys)) --> x := pr1 (ProductArrow _ _ (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod_pr) fs. Proposition structure_to_underlying_coprod_map_in (fs : ∏ (j : J), ys j --> x) (j : J) : enriched_coprod_cocone_in E' ys (pr1 (EP ys)) j · structure_to_underlying_coprod_map fs = fs j. Proof. pose (eqtohomot (maponpaths pr1 (ProductPrCommutes J _ _ (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) _ prod_pr j)) fs) as p. cbn in p. exact p. Qed. Definition to_structure_enrichment_coprod_structure_preserving : mor_hset_struct P (HP (λ j, pr1 (E' ⦃ ys j , x ⦄)) (λ j : J, pr2 (E' ⦃ ys j , x ⦄))) (E (underlying_Coproduct E' ys (pr2 (EP ys))) x) (λ h, CoproductArrow J C (underlying_Coproduct E' ys (pr2 (EP ys))) (λ i, h i)). Proof. refine (transportb _ _ (pr2 (@ProductArrow _ _ _ (is_coprod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod prod_pr))). use funextsec. intros fg. use is_coprod_enriched_arrow_eq. - exact (pr2 (EP ys)). - intro j. refine (_ @ !(structure_to_underlying_coprod_map_in _ j)). apply (CoproductInCommutes _ _ _ (underlying_Coproduct E' ys (pr2 (EP ys)))). Qed. End ToStructureCoproduct. Definition to_structure_enrichment_coprod (EP : enrichment_coprod E' J) : structure_enrichment_coprod. Proof. simple refine (_ ,, _). - exact (λ ys, underlying_Coproduct E' ys (pr2 (EP ys))). - intros x ys. apply to_structure_enrichment_coprod_structure_preserving. Defined. Definition structure_enrichment_coprod_weq (HC : is_univalent C) : enrichment_coprod E' J ≃ structure_enrichment_coprod. Proof. use weqimplimpl. - apply to_structure_enrichment_coprod. - apply make_structure_enrichment_coprod. - apply (isaprop_enrichment_coprod HC). - apply (isaprop_structure_enrichment_coprod HC). Defined. End StructureTypeIndexedCoproducts. (** 5. Copowers *) Definition structure_enrichment_copows : UU := ∑ (prods : ∏ (X : category_of_hset_struct P), Coproducts (pr11 X) C), ∏ (X : category_of_hset_struct P) (x : C), mor_hset_struct P (pr2 X) (E x (prods X (λ _, x))) (CoproductIn _ _ (prods X (λ _, x))) × (∏ (y : C), mor_hset_struct P (hset_struct_fun P (pr2 X) (E x y)) (E (prods X (λ _, x)) y) (λ f, CoproductArrow _ _ (prods X (λ _, x)) (pr1 f))). Section StructureEnrichmentCopowersAccessors. Context (HE : structure_enrichment_copows). Definition structure_copows_coprod (X : category_of_hset_struct P) (x : C) : Coproduct (pr11 X) C (λ _, x) := pr1 HE X (λ _, x). Definition structure_copows_in {X : category_of_hset_struct P} {x : C} (i : pr11 X) : x --> structure_copows_coprod X x := CoproductIn _ _ (structure_copows_coprod X x) i. Proposition structure_copows_mor_in (X : category_of_hset_struct P) (x : C) : mor_hset_struct P (pr2 X) (E x (structure_copows_coprod X x)) structure_copows_in. Proof. exact (pr1 (pr2 HE X x)). Qed. Proposition structure_copows_mor_coproduct_arr (X : category_of_hset_struct P) (x y : C) : mor_hset_struct P (hset_struct_fun P (pr2 X) (E x y)) (E (structure_copows_coprod X x) y) (λ f, CoproductArrow _ _ (structure_copows_coprod X x) (pr1 f)). Proof. exact (pr2 (pr2 HE X x) y). Qed. End StructureEnrichmentCopowersAccessors. Section StructureEnrichmentCopowers. Context (HE : structure_enrichment_copows) (X : sym_mon_closed_cat_of_hset_struct P) (x : C). Let copow : Coproduct _ C (λ _, x) := structure_copows_coprod HE X x. Let copow_in : ∏ (_ : pr11 X), x --> copow := λ i, structure_copows_in HE i. Definition structure_copower_cocone : copower_cocone E' X x. Proof. simple refine (_ ,, _). - exact copow. - simple refine (_ ,, _). + exact copow_in. + exact (structure_copows_mor_in HE X x). Defined. Definition structure_copower_map (y : C) : X ⊸ (E' ⦃ x , y ⦄) --> E' ⦃ structure_copower_cocone , y ⦄. Proof. simple refine (_ ,, _). - intro f. exact (CoproductArrow _ _ copow (pr1 f)). - exact (structure_copows_mor_coproduct_arr HE X x y). Defined. Definition structure_copower_is_copower : is_copower_enriched E' X x structure_copower_cocone. Proof. use make_is_copower_enriched. - exact structure_copower_map. - abstract (intro y ; use eq_mor_hset_struct ; intro f ; cbn in f ; use CoproductArrow_eq ; intro i ; apply (CoproductInCommutes _ _ _ copow)). - abstract (intro y ; use eq_mor_hset_struct ; intro f ; use eq_mor_hset_struct ; intro i ; cbn ; apply (CoproductInCommutes _ _ _ copow)). Defined. End StructureEnrichmentCopowers. Definition structure_enrichment_copowers_from_coproducts (HE : structure_enrichment_copows) : enrichment_copower E'. Proof. intros X x. simple refine (_ ,, _). - exact (structure_copower_cocone HE X x). - apply structure_copower_is_copower. Defined. End StructureEnrichmentColimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/000077500000000000000000000000001451125700300237015ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/ChangeOfBase.v000066400000000000000000000157401451125700300263440ustar00rootroot00000000000000Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section Change_Of_Base. Context {Mon_V Mon_V' : monoidal_cat} (F : lax_monoidal_functor Mon_V Mon_V'). Definition change_of_base_enriched_precat_data (A : enriched_precat Mon_V) : enriched_precat_data Mon_V'. Proof. use make_enriched_precat_data. - exact A. - intros x y. exact (F (enriched_cat_mor x y)). - intro x. exact (mon_functor_unit F · #F (enriched_cat_identity _)). - intros x y z. exact (mon_functor_tensor F _ _ · #F (enriched_cat_comp _ y _)). Defined. Definition change_of_base_enriched_id_ax (A : enriched_precat Mon_V) : enriched_id_ax (change_of_base_enriched_precat_data A). Proof. intros a b. split; cbn. - rewrite <- (functor_id F). rewrite <- (id_left (#F (identity _))). rewrite tensor_comp_mor. rewrite assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_mon_functor_tensor. apply idpath. } rewrite !assoc'. rewrite <- (functor_comp F). etrans. { do 3 apply maponpaths. apply enriched_id_left. } rewrite !assoc. exact (!(mon_functor_lunitor F _)). - rewrite <- (functor_id F). rewrite <- (id_left (#F (identity _))). rewrite tensor_comp_mor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_mon_functor_tensor. apply idpath. } rewrite !assoc'. rewrite <- (functor_comp F). etrans. { do 3 apply maponpaths. apply enriched_id_right. } rewrite !assoc. exact (!(mon_functor_runitor F _)). Qed. Definition change_of_base_enriched_assoc_ax (A : enriched_precat Mon_V) : enriched_assoc_ax (change_of_base_enriched_precat_data A). Proof. intros a b c d. simpl in a, b, c, d. cbn. rewrite <- (functor_id F). rewrite <- (id_left (#F (identity _))). rewrite tensor_comp_mor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_mon_functor_tensor. rewrite !assoc'. rewrite <- functor_comp. rewrite enriched_assoc. rewrite !functor_comp. apply idpath. } rewrite !assoc. apply cancel_postcomposition. rewrite mon_functor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite <- tensor_mon_functor_tensor. rewrite functor_id. apply idpath. Qed. Definition change_of_base_enriched_precat (A : enriched_precat Mon_V) : enriched_precat Mon_V'. Proof. use make_enriched_precat. - exact (change_of_base_enriched_precat_data A). - exact (change_of_base_enriched_id_ax A). - exact (change_of_base_enriched_assoc_ax A). Defined. Definition change_of_base_enriched_functor_data {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_data (change_of_base_enriched_precat A) (change_of_base_enriched_precat B). Proof. use make_enriched_functor_data. + exact G. + intros x y. exact (#F (enriched_functor_on_morphisms G _ _)). Defined. Definition change_of_base_enriched_functor_unit_ax {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_unit_ax (change_of_base_enriched_functor_data G). Proof. intro a. cbn. rewrite assoc'. apply cancel_precomposition. rewrite <- (functor_comp F). apply maponpaths. apply enriched_functor_on_identity. Qed. Definition change_of_base_enriched_functor_comp_ax {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_comp_ax (change_of_base_enriched_functor_data G). Proof. intros a b c. cbn. rewrite assoc. rewrite tensor_mon_functor_tensor. rewrite !assoc'. apply cancel_precomposition. cbn. rewrite <- !(functor_comp F). apply maponpaths. apply enriched_functor_on_comp. Qed. Definition change_of_base_enriched_functor {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor (change_of_base_enriched_precat A) (change_of_base_enriched_precat B). Proof. use make_enriched_functor. - exact (change_of_base_enriched_functor_data G). - exact (change_of_base_enriched_functor_unit_ax G). - exact (change_of_base_enriched_functor_comp_ax G). Defined. Lemma lax_monoidal_functor_on_postcompose_underlying_morphism {A : enriched_precat Mon_V} (x : A) {y z : A} (f : underlying_morphism y z) : # F (postcompose_underlying_morphism x f) = @postcompose_underlying_morphism _ (change_of_base_enriched_precat _) _ _ _ (mon_functor_unit F · # F f). Proof. unfold postcompose_underlying_morphism. do 2 rewrite (functor_comp F). cbn. rewrite assoc. apply cancel_postcomposition. rewrite <- (functor_id F). rewrite <- (id_left (#F (identity _))). rewrite tensor_comp_mor. rewrite assoc, assoc'. rewrite tensor_mon_functor_tensor. rewrite assoc. apply cancel_postcomposition. change (# F (is_z_isomorphism_mor ?f)) with (is_z_isomorphism_mor (functor_on_is_z_isomorphism F f)). change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)). apply pathsinv0. rewrite mon_functor_linvunitor. apply idpath. Qed. Lemma lax_monoidal_functor_on_precompose_underlying_morphism {A : enriched_precat Mon_V} {x y : A} (z : A) (f : underlying_morphism x y) : # F (precompose_underlying_morphism z f) = @precompose_underlying_morphism _ (change_of_base_enriched_precat _) _ _ _ (mon_functor_unit F · # F f). Proof. unfold precompose_underlying_morphism. do 2 rewrite (functor_comp F). cbn. rewrite assoc. apply cancel_postcomposition. rewrite <- (functor_id F). rewrite <- (id_left (#F (identity _))). rewrite tensor_comp_mor. rewrite assoc, assoc'. apply (transportb (λ g, _ = _ · g) (tensor_mon_functor_tensor F _ _)). rewrite assoc. apply cancel_postcomposition. change (# F (is_z_isomorphism_mor ?f)) with (is_z_isomorphism_mor (functor_on_is_z_isomorphism F f)). change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)). apply pathsinv0. rewrite mon_functor_rinvunitor. apply idpath. Qed. Definition change_of_base_enriched_nat_trans {A B : enriched_precat Mon_V} {G H : enriched_functor A B} (a : enriched_nat_trans G H) : enriched_nat_trans (change_of_base_enriched_functor G) (change_of_base_enriched_functor H). Proof. use make_enriched_nat_trans. - intro x. exact (mon_functor_unit F · #F (a x)). - abstract (intros x y; cbn; rewrite <- lax_monoidal_functor_on_postcompose_underlying_morphism; rewrite <- lax_monoidal_functor_on_precompose_underlying_morphism; rewrite <- !(functor_comp F); apply maponpaths; apply enriched_nat_trans_ax). Defined. End Change_Of_Base. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/Enriched.v000066400000000000000000000701311451125700300256130ustar00rootroot00000000000000(** * Enriched categories *) (** ** Contents - Definition - Enriched functors - Composition of enriched functors *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Notation "( c , d )" := (make_catbinprod c d). Notation "( f #, g )" := (catbinprodmor f g). Section aux. Lemma bifunctor_on_morphisms_comm {A B C : category} (F : A ⊠ B ⟶ C) {a a' : A} {b b' : B} (f : a --> a') (g : b --> b') : #F (f #, identity _) · #F (identity _ #, g) = #F (identity _ #, g) · #F (f #, identity _). Proof. rewrite <- !functor_comp. change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). rewrite !id_left, !id_right. reflexivity. Qed. Lemma bifunctor_comp_left {A B C : category} (F : A ⊠ B ⟶ C) {a a' a'' : A} {b : B} (f : a --> a') (g : a' --> a'') : #F (f · g #, identity b) = #F (f #, identity _) · #F (g #, identity _). Proof. rewrite <- (functor_comp F). change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). rewrite id_left. reflexivity. Qed. Lemma bifunctor_comp_right {A B C : category} (F : A ⊠ B ⟶ C) {a : A} {b b' b'' : B} (f : b --> b') (g : b' --> b'') : #F (identity a #, f · g) = #F (identity _ #, f) · #F (identity _ #, g). Proof. rewrite <- (functor_comp F). change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). rewrite id_left. reflexivity. Qed. End aux. Section A. (** For the whole file, fix a monoidal category. *) Context {Mon_V : monoidal_cat}. Let I := I_{Mon_V}. (** ** Definition *) (** This definition is based on that on the nLab *) Section Def. Definition enriched_precat_data : UU := ∑ C : UU, (* Type of objects *) ∑ mor : C -> C -> ob Mon_V, (* Object of morphisms *) dirprod (∏ x : C, I --> mor x x) (* Identities *) (∏ x y z : C, mor y z ⊗ mor x y --> mor x z). (* Composition morphism *) (** Accessors *) Definition enriched_cat_ob (d : enriched_precat_data) : UU := pr1 d. Definition enriched_cat_mor {d : enriched_precat_data} : enriched_cat_ob d -> enriched_cat_ob d -> ob Mon_V := pr1 (pr2 d). Definition enriched_cat_identity {d : enriched_precat_data} : ∏ x : enriched_cat_ob d, I --> enriched_cat_mor x x := pr1 (pr2 (pr2 d)). Definition enriched_cat_comp {d : enriched_precat_data} (x y z : enriched_cat_ob d) : enriched_cat_mor y z ⊗ enriched_cat_mor x y --> enriched_cat_mor x z := pr2 (pr2 (pr2 d)) x y z. Coercion enriched_cat_ob : enriched_precat_data >-> UU. (** Constructor. Use like so: [use make_enriched_cat_data] *) Definition make_enriched_precat_data (C : UU) (mor : ∏ x y : C, ob Mon_V) (ids : ∏ x : C, I --> mor x x) (assoc : ∏ x y z : C, mor y z ⊗ mor x y --> mor x z) : enriched_precat_data. Proof. unfold enriched_precat_data. use tpair; [|use tpair; [|use make_dirprod]]. - exact C. - exact mor. - exact ids. - exact assoc. Defined. Section Axioms. Context (e : enriched_precat_data). (** Associativity axiom for enriched categories: << (C(c, d) ⊗ C(b, c)) ⊗ C(a, b) --------> C(c, d) ⊗ (C(b, c) ⊗ C(a, b)) | | ∘ ⊗ identity | identity ⊗ ∘ | V V C(b, d) ⊗ C(a, b) -----> C(a, d) <------ C(c, d) ⊗ C(a, c) >> *) Definition enriched_assoc_ax : UU := ∏ a b c d : enriched_cat_ob e, (enriched_cat_comp b c d #⊗ (identity _)) · enriched_cat_comp a _ _ = mon_lassociator _ _ _ · ((identity _ #⊗ enriched_cat_comp _ _ _) · enriched_cat_comp _ _ _). Lemma isaprop_enriched_assoc_ax : has_homsets Mon_V -> isaprop (enriched_assoc_ax). Proof. intro hsV; do 4 (apply impred; intro); apply hsV. Defined. (** Identity axiom(s) for enriched categories: << I ⊗ C(a, b) ---> C(b, b) ⊗ C(a, b) \ | \ V C(a, b) >> (And the symmetrized version.) *) Definition enriched_id_ax : UU := ∏ a b : enriched_cat_ob e, dirprod (enriched_cat_identity b #⊗ (identity _) · enriched_cat_comp a b b = mon_lunitor _) ((identity _ #⊗ enriched_cat_identity a) · enriched_cat_comp a a b = mon_runitor _). End Axioms. Definition enriched_precat : UU := ∑ d : enriched_precat_data, (enriched_id_ax d) × (enriched_assoc_ax d). Definition enriched_precat_to_enriched_precat_data : enriched_precat -> enriched_precat_data := pr1. Coercion enriched_precat_to_enriched_precat_data : enriched_precat >-> enriched_precat_data. Definition make_enriched_precat (d : enriched_precat_data) (idax : enriched_id_ax d) (assocax : enriched_assoc_ax d) : enriched_precat := tpair _ d (make_dirprod idax assocax). (** Accessors *) Definition enriched_id_left {A : enriched_precat} (a b : A) : enriched_cat_identity b #⊗ (identity _) · enriched_cat_comp a b b = mon_lunitor _ := pr1 (pr1 (pr2 A) _ _). Definition enriched_id_right {A : enriched_precat} (a b : A) : (identity _ #⊗ enriched_cat_identity a) · enriched_cat_comp a a b = mon_runitor _ := pr2 (pr1 (pr2 A) _ _). Definition enriched_assoc {A : enriched_precat} (a b c d : A) : (enriched_cat_comp b c d #⊗ (identity _)) · enriched_cat_comp a _ _ = mon_lassociator _ _ _ · ((identity _ #⊗ enriched_cat_comp _ _ _) · enriched_cat_comp _ _ _) := pr2 (pr2 A) a b c d. End Def. (** *** Enriched functors *) Section Functors. Context {D E : enriched_precat}. Definition enriched_functor_data : UU := ∑ F : enriched_cat_ob D -> enriched_cat_ob E, ∏ x y : enriched_cat_ob D, Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧. Definition make_enriched_functor_data (F : enriched_cat_ob D -> enriched_cat_ob E) (mor : ∏ x y : enriched_cat_ob D, Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧) : enriched_functor_data := tpair _ F mor. (** Accessors *) Definition enriched_functor_on_objects (F : enriched_functor_data) : enriched_cat_ob D -> enriched_cat_ob E := pr1 F. Coercion enriched_functor_on_objects : enriched_functor_data >-> Funclass. Definition enriched_functor_on_morphisms (F : enriched_functor_data) : ∏ x y : enriched_cat_ob D, Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧ := pr2 F. Section Axioms. Context (F : enriched_functor_data). Definition enriched_functor_unit_ax : UU := ∏ a : enriched_cat_ob D, enriched_cat_identity a · enriched_functor_on_morphisms F a a = enriched_cat_identity (F a). Definition enriched_functor_comp_ax : UU := ∏ a b c : enriched_cat_ob D, enriched_cat_comp a b c · enriched_functor_on_morphisms F a c = (enriched_functor_on_morphisms F b c) #⊗ (enriched_functor_on_morphisms F a b) · enriched_cat_comp _ _ _. End Axioms. Definition enriched_functor : UU := ∑ d : enriched_functor_data, enriched_functor_unit_ax d × enriched_functor_comp_ax d. (** Constructor *) Definition make_enriched_functor (d : enriched_functor_data) (uax : enriched_functor_unit_ax d) (cax : enriched_functor_comp_ax d) : enriched_functor := tpair _ d (make_dirprod uax cax). (** Coercion to *_data *) Definition enriched_functor_to_enriched_functor_data (F : enriched_functor) : enriched_functor_data := pr1 F. Coercion enriched_functor_to_enriched_functor_data : enriched_functor >-> enriched_functor_data. (** Accessors for axioms*) Definition enriched_functor_on_identity (F : enriched_functor) : enriched_functor_unit_ax F := (pr1 (pr2 F)). Definition enriched_functor_on_comp (F : enriched_functor) : enriched_functor_comp_ax F := (pr2 (pr2 F)). End Functors. Arguments enriched_functor_data _ _ : clear implicits. Arguments enriched_functor _ _ : clear implicits. Definition enriched_functor_identity (A : enriched_precat) : enriched_functor A A. Proof. use make_enriched_functor. - use make_enriched_functor_data. + intro a. exact a. + intros x y. exact (identity _). - intro a. apply id_right. - abstract (intros a b c; simpl ; rewrite tensor_id_id ; rewrite id_left, id_right; reflexivity). Defined. (** *** Composition of enriched functors *) Definition enriched_functor_comp_data {P Q R : enriched_precat} (F : enriched_functor_data P Q) (G : enriched_functor_data Q R) : enriched_functor_data P R. Proof. use make_enriched_functor_data. - exact (λ x, G (F x)). - intros x y; cbn. refine (_ · (enriched_functor_on_morphisms G (F x) (F y))). apply (enriched_functor_on_morphisms F). Defined. Definition enriched_functor_comp {P Q R : enriched_precat} (F : enriched_functor P Q) (G : enriched_functor Q R) : enriched_functor P R. Proof. use make_enriched_functor. - apply (enriched_functor_comp_data F G). - (** Unit axioms *) intros a. unfold enriched_functor_comp_data; cbn. refine (assoc _ _ _ @ _). refine (maponpaths (fun f => f · _) (pr1 (pr2 F) a) @ _). apply enriched_functor_on_identity. - (** Composition axioms *) intros a b c; cbn. refine (assoc _ _ _ @ _). refine (maponpaths (fun f => f · _) (enriched_functor_on_comp F _ _ _) @ _). rewrite tensor_comp_mor. (* Get rid of the common prefix *) refine (_ @ assoc _ _ _). refine (!assoc _ _ _ @ _). apply (maponpaths (fun f => _ · f)). apply enriched_functor_on_comp. Defined. (* TODO Definition enriched_functor_data_eq {A B : enriched_precat Mon_V} {F G : enriched_functor_data _ A B} : (∏ a : A, F a = G a) -> (∏ (a a' : A), enriched_functor_on_morphisms F a a' = enriched_functor_on_morphisms G a a') -> F = G. *) Definition enriched_functor_eq {A B : enriched_precat} {F G : enriched_functor A B} : (enriched_functor_to_enriched_functor_data F = enriched_functor_to_enriched_functor_data G) -> F = G. Proof. intro H. use total2_paths_b. - assumption. - apply proofirrelevance. apply isapropdirprod. + apply impred_isaprop. intro. apply homset_property. + repeat (apply impred_isaprop;intro). apply homset_property. Defined. Section UnderlyingMorphisms. Definition underlying_morphism {A : enriched_precat} (x y : A) := I --> enriched_cat_mor x y. Definition precompose_underlying_morphism {A : enriched_precat} {x y : A} (z : A) (f : underlying_morphism x y) : enriched_cat_mor y z --> enriched_cat_mor x z := (mon_rinvunitor _ · (identity _ #⊗ f) · enriched_cat_comp _ _ _). Definition postcompose_underlying_morphism {A : enriched_precat} (x : A) {y z : A} (f : underlying_morphism y z) : enriched_cat_mor x y --> enriched_cat_mor x z := (mon_linvunitor _ · (f #⊗ identity _) · enriched_cat_comp _ _ _). Definition precompose_identity {A : enriched_precat} {x y : A} : precompose_underlying_morphism y (enriched_cat_identity x) = identity _. Proof. unfold precompose_underlying_morphism. rewrite assoc'. apply (transportb (λ f, _ · f = _) (enriched_id_right _ _)). apply mon_rinvunitor_runitor. Qed. Definition postcompose_identity {A : enriched_precat} {x y : A} : postcompose_underlying_morphism x (enriched_cat_identity y) = identity _. Proof. unfold postcompose_underlying_morphism. rewrite assoc'. apply (transportb (λ h, _ · h = _) (enriched_id_left _ _)). apply mon_linvunitor_lunitor. Qed. Lemma precompose_underlying_morphism_enriched_cat_comp {A : enriched_precat} {w x y z : A} (f : underlying_morphism w x) : ((identity _ #⊗ precompose_underlying_morphism y f) · enriched_cat_comp w y z = enriched_cat_comp x y z · precompose_underlying_morphism z f)%cat. Proof. unfold precompose_underlying_morphism. rewrite !assoc. rewrite tensor_rinvunitor. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. apply idpath. } refine (!_). rewrite assoc. rewrite (assoc' _ _ (enriched_cat_comp w x z)). rewrite (@enriched_assoc A). rewrite !assoc. rewrite !tensor_comp_id_l. do 2 apply cancel_postcomposition. rewrite assoc'. rewrite <- tensor_id_id. apply pathsinv0. etrans. { apply cancel_precomposition. apply tensor_lassociator. } rewrite assoc. apply cancel_postcomposition. rewrite <- mon_rinvunitor_triangle. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply mon_rassociator_lassociator. Qed. Lemma enriched_cat_comp_underlying_morphism_middle {A : enriched_precat} {w x y z : A} (f : underlying_morphism x y) : ((identity _ #⊗ postcompose_underlying_morphism w f) · enriched_cat_comp w y z = (precompose_underlying_morphism z f #⊗ identity _) · enriched_cat_comp w x z). Proof. unfold precompose_underlying_morphism, postcompose_underlying_morphism. rewrite !tensor_comp_id_r, !tensor_comp_id_l. apply pathsinv0. rewrite assoc'. rewrite (@enriched_assoc A). rewrite !assoc. do 2 apply cancel_postcomposition. rewrite assoc'. etrans. { apply cancel_precomposition. apply tensor_lassociator. } rewrite assoc. apply cancel_postcomposition. rewrite mon_inv_triangle. apply idpath. Qed. Lemma postcompose_underlying_morphism_enriched_cat_comp {A : enriched_precat} {w x y z : A} (f : underlying_morphism y z) : ((postcompose_underlying_morphism x f #⊗ identity _) · enriched_cat_comp w x z = enriched_cat_comp w x y · postcompose_underlying_morphism w f). Proof. unfold postcompose_underlying_morphism. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split. rewrite tensor_split'. apply idpath. } refine (!_). rewrite assoc. rewrite !tensor_comp_id_r. rewrite assoc'. rewrite (@enriched_assoc A). rewrite !assoc. do 2 apply cancel_postcomposition. rewrite assoc'. etrans. { apply cancel_precomposition. apply tensor_lassociator. } rewrite assoc. rewrite tensor_id_id. apply cancel_postcomposition. apply mon_linvunitor_triangle. Qed. Definition postcompose_underlying_morphism_composite {A : enriched_precat} (w : A) {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : postcompose_underlying_morphism w (f · postcompose_underlying_morphism _ g) = postcompose_underlying_morphism _ f · postcompose_underlying_morphism _ g. Proof. unfold postcompose_underlying_morphism. rewrite !tensor_comp_id_r. rewrite !assoc'. do 2 apply cancel_precomposition. rewrite enriched_assoc. rewrite !assoc. apply cancel_postcomposition. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. apply idpath. } simpl. rewrite assoc. rewrite tensor_id_id. rewrite assoc. rewrite mon_linvunitor_triangle. rewrite !assoc'. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc. apply cancel_postcomposition. apply pathsinv0. apply tensor_linvunitor. Qed. Definition precompose_underlying_morphism_composite {A : enriched_precat} (w : A) {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : precompose_underlying_morphism w (f · postcompose_underlying_morphism _ g) = precompose_underlying_morphism _ g · precompose_underlying_morphism _ f. Proof. unfold postcompose_underlying_morphism, precompose_underlying_morphism. rewrite !tensor_comp_id_l. rewrite !assoc. rewrite (assoc' _ (enriched_cat_comp y z w)). rewrite tensor_rinvunitor. rewrite !assoc'. refine (!_). etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. apply idpath. } refine (!_). rewrite assoc. rewrite (assoc' _ _ (enriched_cat_comp x y w)). rewrite enriched_assoc. rewrite !assoc. do 2 apply cancel_postcomposition. rewrite <- tensor_id_id. rewrite !assoc'. apply cancel_precomposition. do 2 rewrite assoc. rewrite tensor_lassociator. rewrite assoc. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- mon_rinvunitor_triangle. rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { refine (maponpaths (λ z, z · _) _). apply mon_rassociator_lassociator. } apply id_left. } rewrite <- !tensor_comp_mor. apply maponpaths. rewrite !assoc. rewrite tensor_linvunitor. rewrite tensor_rinvunitor. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split, <- tensor_split'. apply idpath. Qed. Definition underlying_morphism_compose_swap {A : enriched_precat} {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : f · postcompose_underlying_morphism _ g = g · precompose_underlying_morphism _ f. Proof. unfold postcompose_underlying_morphism. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite assoc. rewrite <- tensor_comp_mor. rewrite id_left, id_right. apply idpath. } unfold precompose_underlying_morphism. rewrite !assoc. refine (maponpaths (λ z, z · _) _). rewrite tensor_rinvunitor. rewrite !assoc'. rewrite <- tensor_split'. refine (maponpaths (λ z, z · _) _). apply mon_linvunitor_I_mon_rinvunitor_I. Qed. Definition pre_post_compose_commute {A : enriched_precat} {w x y z : A} (f : underlying_morphism w x) (g : underlying_morphism y z) : precompose_underlying_morphism _ f · postcompose_underlying_morphism _ g = postcompose_underlying_morphism _ g · precompose_underlying_morphism _ f. Proof. unfold postcompose_underlying_morphism. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split. rewrite tensor_split'. apply idpath. } rewrite !assoc'. do 2 apply cancel_precomposition. unfold precompose_underlying_morphism. rewrite !assoc. rewrite tensor_comp_id_l. rewrite tensor_rinvunitor. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. apply idpath. } rewrite !assoc'. rewrite (enriched_assoc w). rewrite !assoc. do 2 apply cancel_postcomposition. rewrite assoc'. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc. rewrite <- mon_rinvunitor_triangle. etrans. { refine (maponpaths (λ z, z · _) _). rewrite !assoc'. etrans. { apply maponpaths. apply mon_rassociator_lassociator. } apply id_right. } rewrite tensor_comp_id_l. apply idpath. Qed. Definition enriched_functor_on_postcompose {A B : enriched_precat} (F : enriched_functor A B) {y z : A} (f : underlying_morphism y z) (x : A) : postcompose_underlying_morphism x f · enriched_functor_on_morphisms F _ _ = enriched_functor_on_morphisms F _ _ · postcompose_underlying_morphism _ (f · enriched_functor_on_morphisms F _ _). Proof. unfold postcompose_underlying_morphism. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left, id_right. apply idpath. } apply cancel_precomposition. rewrite enriched_functor_on_comp. rewrite !assoc. apply cancel_postcomposition. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. Definition enriched_functor_on_precompose {A B : enriched_precat} (F : enriched_functor A B) {x y : A} (f : underlying_morphism x y) (z : A) : precompose_underlying_morphism z f · enriched_functor_on_morphisms F _ _ = enriched_functor_on_morphisms F _ _ · precompose_underlying_morphism _ (f · enriched_functor_on_morphisms F _ _). Proof. unfold precompose_underlying_morphism. rewrite !assoc. rewrite tensor_rinvunitor. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left, id_right. apply idpath. } apply cancel_precomposition. rewrite enriched_functor_on_comp. rewrite !assoc. apply cancel_postcomposition. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. End UnderlyingMorphisms. Section NatTrans. Definition enriched_nat_trans_data {A B : enriched_precat} (F G : enriched_functor A B) := ∏ a : A, underlying_morphism (F a) (G a). Definition enriched_nat_trans_law {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans_data F G) := ∏ (x y : A), enriched_functor_on_morphisms F x y · postcompose_underlying_morphism _ (a y) = enriched_functor_on_morphisms G x y · precompose_underlying_morphism _ (a x). Definition enriched_nat_trans {A B : enriched_precat} (F G : enriched_functor A B) := ∑ a : enriched_nat_trans_data F G, enriched_nat_trans_law a. Definition enriched_nat_trans_data_from_enriched_nat_trans {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) : ∏ a : A, I --> enriched_cat_mor (F a) (G a) := pr1 a. Coercion enriched_nat_trans_data_from_enriched_nat_trans : enriched_nat_trans >-> Funclass. Definition enriched_nat_trans_ax {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) :enriched_nat_trans_law a := pr2 a. Definition make_enriched_nat_trans {A B : enriched_precat} {F G : enriched_functor A B} a l : enriched_nat_trans F G := (a,, l). Definition enriched_nat_trans_eq {A B : enriched_precat} {F G : enriched_functor A B} {a a' : enriched_nat_trans F G} : (∏ x : A, a x = a' x) -> a = a'. Proof. intro H. use total2_paths_b. - apply funextsec. assumption. - apply proofirrelevance. repeat (apply impred_isaprop; intro). apply homset_property. Defined. Definition enriched_nat_trans_identity {A B : enriched_precat} (F : enriched_functor A B) : enriched_nat_trans F F. Proof. use make_enriched_nat_trans. - intro x. apply enriched_cat_identity. - abstract (intros x y; rewrite precompose_identity, postcompose_identity; reflexivity). Defined. Definition enriched_nat_trans_comp {A B : enriched_precat} {F G H : enriched_functor A B} (a : enriched_nat_trans F G) (b : enriched_nat_trans G H) : enriched_nat_trans F H. Proof. use make_enriched_nat_trans. - intro x. exact (a x · postcompose_underlying_morphism _ (b x)). - abstract (intros x y; rewrite postcompose_underlying_morphism_composite; rewrite assoc; rewrite enriched_nat_trans_ax; rewrite assoc'; rewrite pre_post_compose_commute; rewrite assoc; rewrite enriched_nat_trans_ax; rewrite precompose_underlying_morphism_composite; apply assoc'). Defined. End NatTrans. Section EnrichedFunctorCategory. Lemma isaset_enriched_nat_trans {A B : enriched_precat} (F G : enriched_functor A B) : isaset (enriched_nat_trans F G). Proof. apply isaset_total2. - apply impred_isaset. intro. apply homset_property. - intro. apply isasetaprop. repeat (apply impred_isaprop; intro). apply homset_property. Qed. Lemma enriched_nat_trans_assoc {A B : enriched_precat} {F G H K : enriched_functor A B} (f : enriched_nat_trans F G) (g : enriched_nat_trans G H) (h : enriched_nat_trans H K) : enriched_nat_trans_comp f (enriched_nat_trans_comp g h) = enriched_nat_trans_comp (enriched_nat_trans_comp f g) h. Proof. apply enriched_nat_trans_eq. intro x. cbn. rewrite postcompose_underlying_morphism_composite. apply assoc. Qed. Definition enriched_functor_precategory_data (A B : enriched_precat) : precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact (enriched_functor A B). + intros F G. exact (enriched_nat_trans F G). - intros c. apply enriched_nat_trans_identity. - intros a b c f g. exact (enriched_nat_trans_comp f g). Defined. Definition enriched_functor_category (A B : enriched_precat) : category. Proof. use make_category. - use make_precategory. + exact (enriched_functor_precategory_data A B). + repeat split;simpl. * abstract (intros; apply enriched_nat_trans_eq; intro; cbn; rewrite underlying_morphism_compose_swap; rewrite precompose_identity; apply id_right). * abstract (intros; apply enriched_nat_trans_eq; intro; cbn; rewrite postcompose_identity; apply id_right). * abstract (intros; apply enriched_nat_trans_assoc). * abstract (intros; apply pathsinv0; apply enriched_nat_trans_assoc). - intros a b. apply isaset_enriched_nat_trans. Defined. End EnrichedFunctorCategory. Section Whisker. Definition pre_whisker {A B C : enriched_precat} (F : enriched_functor A B) {G H : enriched_functor B C} (a : enriched_nat_trans G H) : enriched_nat_trans (enriched_functor_comp F G) (enriched_functor_comp F H). Proof. use make_enriched_nat_trans. - intro x. exact (a (F x)). - abstract (intros x y; simpl; rewrite !assoc'; apply cancel_precomposition; apply enriched_nat_trans_ax). Defined. Definition post_whisker {A B C : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) (H : enriched_functor B C) : enriched_nat_trans (enriched_functor_comp F H) (enriched_functor_comp G H). Proof. use make_enriched_nat_trans. - intro x. exact (a x · enriched_functor_on_morphisms H _ _). - abstract (intros x y; simpl; rewrite !assoc'; rewrite <- enriched_functor_on_precompose, <- enriched_functor_on_postcompose; rewrite !assoc; apply cancel_postcomposition; apply enriched_nat_trans_ax). Defined. End Whisker. Section Unit. Definition unit_enriched_precat_data : enriched_precat_data. Proof. use make_enriched_precat_data. - exact unit. - intros. exact (I_{Mon_V}). - intros. exact (identity _). - intros. exact (mon_lunitor _). Defined. Definition unit_enriched_precat : enriched_precat. Proof. use make_enriched_precat. - exact unit_enriched_precat_data. - split; cbn. + abstract (rewrite tensor_id_id ; apply id_left). + abstract (rewrite tensor_id_id ; rewrite id_left ; apply mon_lunitor_I_mon_runitor_I). - abstract (intros a b c d ; cbn ; rewrite !assoc ; apply cancel_postcomposition ; rewrite mon_lunitor_I_mon_runitor_I ; rewrite mon_triangle ; rewrite mon_runitor_I_mon_lunitor_I ; apply idpath). Defined. Definition element_functor_data {A : enriched_precat} (a : A) : enriched_functor_data unit_enriched_precat A. Proof. use make_enriched_functor_data. - intro. exact a. - intros x y. induction x, y. apply enriched_cat_identity. Defined. Definition element_functor_unit_ax {A : enriched_precat} (a : A) : enriched_functor_unit_ax (element_functor_data a). Proof. intro t. induction t. simpl. apply id_left. Qed. Definition element_functor_comp_ax {A : enriched_precat} (a : A) : enriched_functor_comp_ax (element_functor_data a). Proof. intros t t' t''. induction t, t', t''. cbn. rewrite tensor_split. rewrite !assoc'. rewrite enriched_id_left. rewrite tensor_lunitor. apply idpath. Qed. Definition element_functor {A : enriched_precat} (a : A) : enriched_functor unit_enriched_precat A. Proof. use make_enriched_functor. - exact (element_functor_data a). - exact (element_functor_unit_ax a). - exact (element_functor_comp_ax a). Defined. End Unit. End A. Arguments enriched_precat_data _ : clear implicits. Arguments enriched_precat _ : clear implicits. Arguments enriched_functor_data {_} _ _. Arguments enriched_functor {_} _ _. Arguments unit_enriched_precat _ : clear implicits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/EnrichmentEquiv.v000066400000000000000000000260711451125700300272040ustar00rootroot00000000000000(***************************************************************** Equivalence of enrichments and enriched categories We have two notions of enriched categories: one is the usual definition that can be found in textbooks and the other makes use of enrichments. In this file, we prove that these two notions are actually equivalent. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.UnderlyingCategory. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section EnrichmentToEnrichedCat. Context {V : monoidal_cat} (E : cat_with_enrichment V). Definition make_enriched_cat_data : enriched_precat_data V. Proof. simple refine (_ ,, (_ ,, (_ ,, _))). - exact E. - exact (λ x y, E ⦃ x , y ⦄). - exact (enriched_id E). - exact (enriched_comp E). Defined. Definition make_enriched_cat_id_ax : enriched_id_ax make_enriched_cat_data. Proof. intros x y. split ; cbn. - refine (!_). apply (pr2 E). - refine (!_). apply (pr2 E). Qed. Definition make_enriched_cat_assoc_ax : enriched_assoc_ax make_enriched_cat_data. Proof. intros w x y z ; cbn. rewrite !assoc. apply (pr2 E). Qed. Definition make_enriched_cat : enriched_precat V. Proof. simple refine (_ ,, _ ,, _). - exact make_enriched_cat_data. - exact make_enriched_cat_id_ax. - exact make_enriched_cat_assoc_ax. Defined. End EnrichmentToEnrichedCat. Definition cat_with_enrichment_alt_data_help {V : monoidal_cat} (ob : UU) (arr : ob -> ob -> V) : UU := ∑ (mor : ob -> ob -> UU), (∏ (x : ob), mor x x) × (∏ (x y z : ob), mor x y → mor y z → mor x z) × (∏ (x y : ob), mor x y → I_{V} --> arr x y) × (∏ (x y : ob), I_{V} --> arr x y → mor x y). Definition path_cat_with_enrichment_alt_data_help_lemma {V : monoidal_cat} {ob : UU} {arr : ob -> ob -> V} {E₁ E₂ : cat_with_enrichment_alt_data_help ob arr} (p : pr1 E₁ = pr1 E₂) (q₁ : ∏ (x : ob), transportf (λ T, T x x) p (pr12 E₁ x) = pr12 E₂ x) (q₂ : ∏ (x y z : ob) (g₁ : pr1 E₁ x y) (g₂ : pr1 E₁ y z), transportf (λ T, T x z) p (pr122 E₁ _ _ _ g₁ g₂) = pr122 E₂ _ _ _ (transportf (λ T, T x y) p g₁) (transportf (λ T, T y z) p g₂)) (q₃ : ∏ (x y : ob) (g : pr1 E₁ x y), (pr1 (pr222 E₁)) _ _ g = (pr1 (pr222 E₂)) _ _ (transportf (λ T, T x y) p g)) (q₄ : ∏ (x y : ob) (g : I_{V} --> arr x y), transportf (λ T, T x y) p (pr2 (pr222 E₁) _ _ g) = pr2 (pr222 E₂) _ _ g) : E₁ = E₂. Proof. induction E₁ as [ D₁ E₁ ]. induction E₂ as [ D₂ E₂ ]. cbn in *. induction p. cbn in *. apply maponpaths. repeat (use pathsdirprod). - use funextsec ; intro. apply q₁. - repeat (use funextsec ; intro). apply q₂. - repeat (use funextsec ; intro). apply q₃. - repeat (use funextsec ; intro). apply q₄. Qed. Definition fam_eq {X : UU} {Y₁ Y₂ : X → X → UU} (p : ∏ (x₁ x₂ : X), Y₁ x₁ x₂ ≃ Y₂ x₁ x₂) : Y₁ = Y₂. Proof. use funextsec ; intro x₁. use funextsec ; intro x₂. exact (invmap (univalence (Y₁ x₁ x₂) (Y₂ x₁ x₂)) (p x₁ x₂)). Defined. Definition transportf_fam_eq {X : UU} {Y₁ Y₂ : X → X → UU} (p : ∏ (x₁ x₂ : X), Y₁ x₁ x₂ ≃ Y₂ x₁ x₂) {x₁ x₂ : X} (y : Y₁ x₁ x₂) : transportf (λ T, T _ _) (fam_eq p) y = p x₁ x₂ y. Proof. unfold fam_eq. etrans. { apply (transportf_funextfun (λ T, T x₂)). } etrans. { apply (transportf_funextfun (idfun UU)). } cbn. rewrite pr1_eqweqmap. exact (maponpaths (λ z, pr1 z y) (homotweqinvweq (univalence (Y₁ x₁ x₂) (Y₂ x₁ x₂)) (p x₁ x₂))). Qed. Definition path_cat_with_enrichment_alt_data_help {V : monoidal_cat} {ob : UU} {arr : ob -> ob -> V} {E₁ E₂ : cat_with_enrichment_alt_data_help ob arr} (f : ∏ (x y : ob), pr1 E₁ x y → pr1 E₂ x y) (Hf : ∏ (x y : ob), isweq (f x y)) (p₁ : ∏ (x : ob), f _ _ (pr12 E₁ x) = pr12 E₂ x) (p₂ : ∏ (x y z : ob) (g₁ : pr1 E₁ x y) (g₂ : pr1 E₁ y z), f _ _ (pr122 E₁ _ _ _ g₁ g₂) = pr122 E₂ _ _ _ (f _ _ g₁) (f _ _ g₂)) (p₃ : ∏ (x y : ob) (g : pr1 E₁ x y), (pr1 (pr222 E₁)) _ _ g = (pr1 (pr222 E₂)) _ _ (f _ _ g)) (p₄ : ∏ (x y : ob) (g : I_{V} --> arr x y), f _ _ (pr2 (pr222 E₁) _ _ g) = pr2 (pr222 E₂) _ _ g) : E₁ = E₂. Proof. use path_cat_with_enrichment_alt_data_help_lemma. - use fam_eq. intros x₁ x₂. use make_weq. + exact (f x₁ x₂). + exact (Hf x₁ x₂). - intros x. rewrite transportf_fam_eq. apply p₁. - intros x y z g₁ g₂. rewrite !transportf_fam_eq. apply p₂. - intros x y g. rewrite !transportf_fam_eq. apply p₃. - intros x y g. rewrite !transportf_fam_eq. apply p₄. Qed. Definition cat_with_enrichment_alt_data (V : monoidal_cat) : UU := ∑ (ob : UU) (arr : ob -> ob -> V), (∏ (x : ob), I_{V} --> arr x x) × (∏ (x y z : ob), arr y z ⊗ arr x y --> arr x z) × cat_with_enrichment_alt_data_help ob arr. Definition cat_with_enrichment_alt_data_precategory_data {V : monoidal_cat} (E : cat_with_enrichment_alt_data V) : precategory_data. Proof. use make_precategory_data. - use make_precategory_ob_mor. + exact (pr1 E). + exact (pr12 (pr222 E)). - exact (pr122 (pr222 E)). - exact (pr1 (pr222 (pr222 E))). Defined. Definition cat_with_enrichment_alt_data_enrichment {V : monoidal_cat} (E : cat_with_enrichment_alt_data V) : enrichment_data (cat_with_enrichment_alt_data_precategory_data E) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (pr12 E). - exact (pr122 E). - exact (pr1 (pr222 E)). - exact (pr12 (pr222 (pr222 E))). - exact (pr22 (pr222 (pr222 E))). Defined. Definition cat_with_enrichment_alt_laws {V : monoidal_cat} (E : cat_with_enrichment_alt_data V) : UU := has_homsets (cat_with_enrichment_alt_data_precategory_data E) × is_precategory (cat_with_enrichment_alt_data_precategory_data E) × enrichment_laws (cat_with_enrichment_alt_data_enrichment E). Definition cat_with_enrichment_alt (V : monoidal_cat) : UU := ∑ (E : cat_with_enrichment_alt_data V), cat_with_enrichment_alt_laws E. Definition cat_with_enrichment_to_alt {V : monoidal_cat} (E : cat_with_enrichment V) : cat_with_enrichment_alt V. Proof. simple refine ((_ ,, (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _)) ,, _). - exact (ob (pr1 E)). - exact (pr11 (pr2 E)). - exact (pr121 (pr2 E)). - exact (pr1 (pr221 (pr2 E))). - exact (pr21 (pr111 E)). - apply identity. - exact (λ _ _ _ f g, f · g). - exact (pr12 (pr221 (pr2 E))). - exact (pr22 (pr221 (pr2 E))). - simple refine (_ ,, _ ,, _). + apply homset_property. + exact (pr211 E). + exact (pr22 E). Defined. Definition cat_with_enrichment_from_alt {V : monoidal_cat} (E : cat_with_enrichment_alt V) : cat_with_enrichment V. Proof. simple refine (((((_ ,, _) ,, (_ ,, _)) ,, _) ,, _) ,, _). - exact (pr11 E). - exact (pr122 (pr221 E)). - exact (pr1 (pr222 (pr221 E))). - exact (pr12 (pr222 (pr221 E))). - exact (pr122 E). - exact (pr12 E). - simple refine ((_ ,, _ ,, _ ,, _ ,, _) ,, _). + exact (pr121 E). + exact (pr1 (pr221 E)). + exact (pr12 (pr221 E)). + exact (pr122 (pr222 (pr221 E))). + exact (pr222 (pr222 (pr221 E))). + exact (pr222 E). Defined. Definition cat_with_enrichment_weq_alt (V : monoidal_cat) : cat_with_enrichment V ≃ cat_with_enrichment_alt V. Proof. use weq_iso. - exact cat_with_enrichment_to_alt. - exact cat_with_enrichment_from_alt. - intro E. apply idpath. - intro E. apply idpath. Defined. Definition enriched_precat_weq_cat_with_enrichment_inv_left {V : monoidal_cat} (E : enriched_precat V) : make_enriched_cat (underlying_cat_with_enrichment V E) = E. Proof. use subtypePath. { intro ; apply isapropdirprod. + repeat (use impred ; intro) ; cbn -[isofhlevel]. apply isapropdirprod ; apply homset_property. + repeat (use impred ; intro) ; cbn -[isofhlevel]. apply homset_property. } cbn. apply idpath. Qed. Definition enriched_precat_weq_cat_with_enrichment_inv_right {V : monoidal_cat} (E : cat_with_enrichment V) : underlying_cat_with_enrichment V (make_enriched_cat E) = E. Proof. use (invmaponpathsweq (cat_with_enrichment_weq_alt V)). use subtypePath. { intro z. use invproofirrelevance. intros φ₁ φ₂. repeat (use pathsdirprod) ; repeat (use funextsec ; intro) ; try (apply homset_property) ; try (apply φ₁) ; apply isapropiscontr. } cbn. do 4 apply maponpaths. use path_cat_with_enrichment_alt_data_help. - exact (λ x y f, enriched_to_arr (pr2 E) f). - apply isweq_enriched_to_arr. - cbn. intro x. rewrite enriched_to_arr_id. apply idpath. - cbn. intros x y z f g. rewrite (enriched_to_arr_comp (pr2 E)). rewrite !enriched_from_to_arr. apply idpath. - cbn. intros x y f. refine (!_). apply enriched_from_to_arr. - cbn. intros x y f. apply idpath. Qed. Definition enriched_precat_weq_cat_with_enrichment (V : monoidal_cat) : enriched_precat V ≃ cat_with_enrichment V. Proof. use weq_iso. - exact (underlying_cat_with_enrichment V). - exact make_enriched_cat. - exact enriched_precat_weq_cat_with_enrichment_inv_left. - exact enriched_precat_weq_cat_with_enrichment_inv_right. Defined. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/Opposite.v000066400000000000000000000073101451125700300256730ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section Opposite. Context {Mon_V : monoidal_cat}. Definition opposite_enriched_precat (A : enriched_precat Mon_V) : enriched_precat (_ ,, monoidal_swapped Mon_V). Proof. use make_enriched_precat. - use make_enriched_precat_data. + exact A. + intros x y. exact (enriched_cat_mor y x). + intro x. simpl. exact (enriched_cat_identity x). + intros x y z. exact (enriched_cat_comp z y x). - split; simpl in a, b; simpl. + refine (_ @ enriched_id_right b a). apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). + refine (_ @ enriched_id_left b a). apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). - intros a b c d ; cbn. refine (!(id_left _) @ _). etrans. { apply maponpaths_2. exact (!(mon_rassociator_lassociator _ _ _)). } rewrite !assoc'. apply maponpaths. refine (_ @ !(enriched_assoc d c b a) @ _). + apply maponpaths. apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). + apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). Defined. Definition opposite_enriched_functor {A B : enriched_precat Mon_V} (F : enriched_functor A B) : enriched_functor (opposite_enriched_precat A) (opposite_enriched_precat B). Proof. use make_enriched_functor. - use make_enriched_functor_data. + intro x. exact (F x). + intros x y. exact (enriched_functor_on_morphisms F y x). - intro x. cbn. apply enriched_functor_on_identity. - intros x y z. cbn. refine (enriched_functor_on_comp F z y x @ _). apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). Defined. (* note the direction *) Definition opposite_enriched_nat_trans {A B : enriched_precat Mon_V} {F G : enriched_functor A B} (a : enriched_nat_trans F G) : enriched_nat_trans (opposite_enriched_functor G) (opposite_enriched_functor F). Proof. use make_enriched_nat_trans. - intro x. exact (a x). - intros x y. cbn. apply pathsinv0. refine (_ @ enriched_nat_trans_ax a y x @ _). + apply maponpaths. unfold precompose_underlying_morphism, postcompose_underlying_morphism. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite <- whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). + apply maponpaths. unfold precompose_underlying_morphism, postcompose_underlying_morphism. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. cbn. rewrite <- whiskerscommutes ; [ apply idpath | ]. apply (pr2 Mon_V). Defined. End Opposite. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enriched/UnderlyingCategory.v000066400000000000000000000117001451125700300277050ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section EnrichedMors. Context (V : monoidal_cat) (C : enriched_precat V). Definition underlying_precategory_ob_mor_enriched : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact C. - exact (λ x y, I_{V} --> enriched_cat_mor x y). Defined. Definition underlying_precategory_data_enriched : precategory_data. Proof. use make_precategory_data. - exact underlying_precategory_ob_mor_enriched. - exact (λ x , enriched_cat_identity x). - exact (λ x y z f g, mon_linvunitor _ · g #⊗ f · enriched_cat_comp x y z). Defined. Definition underlying_precategory_enriched_laws : is_precategory underlying_precategory_data_enriched. Proof. use is_precategory_one_assoc_to_two. repeat split. - cbn ; intros x y f. rewrite !assoc'. rewrite tensor_split'. rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (enriched_id_right x y : _ = mon_runitor _). } rewrite tensor_runitor. rewrite mon_runitor_I_mon_lunitor_I. rewrite assoc. etrans. { apply maponpaths_2. exact (mon_linvunitor_lunitor _). } apply id_left. - cbn ; intros x y f. rewrite !assoc'. rewrite tensor_split. rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (enriched_id_left x y : _ = mon_lunitor _). } rewrite tensor_lunitor. rewrite assoc. etrans. { apply maponpaths_2. exact (mon_linvunitor_lunitor _). } apply id_left. - cbn ; intros w x y z f g h. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (enriched_assoc w x y z : (_ #⊗ _) · _ = mon_lassociator _ _ _ · ((_ #⊗ _) · _)). } rewrite !assoc. apply maponpaths_2. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. etrans. { do 3 apply maponpaths. refine (!_). apply tensor_comp_mor. } rewrite id_right. rewrite !tensor_comp_l_id_l. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. exact (!(tensor_linvunitor (mon_linvunitor _))). } rewrite !assoc'. etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. rewrite <- tensor_lassociator. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. apply tensor_lassociator. Qed. Definition underlying_precategory_enriched : precategory. Proof. use make_precategory. - exact underlying_precategory_data_enriched. - exact underlying_precategory_enriched_laws. Defined. Definition underlying_category_enriched : category. Proof. use make_category. - exact underlying_precategory_enriched. - intros x y. apply homset_property. Defined. Definition enrichment_data_of_underlying_category : enrichment_data underlying_category_enriched V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, enriched_cat_mor x y). - exact (λ x , enriched_cat_identity x). - exact (λ x y z, enriched_cat_comp x y z). - exact (λ x y f, f). - exact (λ x y f, f). Defined. Definition enrichment_laws_of_underlying_category : enrichment_laws enrichment_data_of_underlying_category. Proof. repeat split ; cbn ; intros. - refine (!_). apply C. - refine (!_). apply C. - rewrite !assoc'. apply C. Qed. Definition enrichment_of_underlying_category : enrichment underlying_category_enriched V. Proof. simple refine (_ ,, _). - exact enrichment_data_of_underlying_category. - exact enrichment_laws_of_underlying_category. Defined. Definition underlying_cat_with_enrichment : cat_with_enrichment V := underlying_category_enriched ,, enrichment_of_underlying_category. End EnrichedMors. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/EnrichedRezkCompletion.v000066400000000000000000000123361451125700300267630ustar00rootroot00000000000000(************************************************************************* The Rezk Completion for Enriched Categories We use the Yoneda lemma and the image factorization to construct the Rezk completion for enriched categories. For this construction, we have to assume that the monoidal category `V` over which we enrich, is a univalent category. The structure of the proof is mostly same as for ordinary categories. The main difference is that instead of looking at all presheaves, we only look at those presheaves that are enriched. Note that we do not extend the Rezk completion for ordinary categories. Such an approach would be possible as well, and it would consists of the following steps: - Showing that enrichments can be lifted along weak equivalences. This requires the enriching category `V` to be univalent. In addition, one needs to formulate enrichments via functors. Composition and identity need to be lifted as well. Here one needs that the opposite, the product, and the core of categories preserve univalence. - Showing that enriched functors and enriched transformations can be lifted along weak equivalences. Such an approach is more complicated than what we do in this file. Our approach is an application of the Yoneda lemma, and we do not need any heavy lifting. However, the advantage of the lifting approach is that if one assumes that the Rezk completion preserves the universe level (which would be the case if one construct the Rezk completion as a higher inductive type provided that the HIT is postulated in an appropriate way), then the resulting Rezk completion for enriched categories also preserves the universe level. Our approach increases the universe level for the same reason as why the Rezk completion for ordinary categories increases the universe level. Contents 1. The Rezk completion and its enrichment 2. The weak equivalence *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.FullyFaithful. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FunctorCategory. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.ImageEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.Yoneda. Require Import UniMath.CategoryTheory.EnrichedCats.YonedaLemma. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Local Open Scope cat. Local Open Scope moncat. Section EnrichedRezkCompletion. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (EqV : Equalizers V) (PV : Products C V) (PV' : Products (C × C) V) (HV : is_univalent V). (** * 1. The Rezk completion and its enrichment *) Definition enriched_rezk_completion : univalent_category. Proof. use make_univalent_category. - exact (full_img_sub_precategory (enriched_yoneda_functor E)). - use is_univalent_full_sub_category. use is_univalent_enriched_functor_cat. exact HV. Defined. Definition enriched_rezk_completion_enrichment : enrichment enriched_rezk_completion V. Proof. use image_enrichment. exact (enriched_presheaf_enrichment E EqV PV PV'). Defined. (** * 2. The weak equivalence *) Definition enriched_rezk_completion_map : C ⟶ enriched_rezk_completion := functor_full_img _. Definition enriched_rezk_completion_map_enrichment : functor_enrichment enriched_rezk_completion_map E enriched_rezk_completion_enrichment. Proof. apply image_proj_enrichment. apply enriched_yoneda_enrichment. Defined. Proposition is_essentially_surjective_enriched_rezk_completion_map : essentially_surjective enriched_rezk_completion_map. Proof. apply functor_full_img_essentially_surjective. Qed. Proposition is_fully_faithful_enriched_rezk_completion_map : fully_faithful_enriched_functor enriched_rezk_completion_map_enrichment. Proof. exact (fully_faithful_enriched_factorization_precomp (enriched_yoneda_enrichment E EqV PV PV') enriched_rezk_completion_map_enrichment _ (image_factorization_enriched_commutes_inv _) (fully_faithful_enriched_yoneda _ _ _ _) image_incl_enrichment_fully_faithful). Qed. End EnrichedRezkCompletion. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Enrichment.v000066400000000000000000000746111451125700300244540ustar00rootroot00000000000000(***************************************************************** Enrichments of categories In this file, we define enrichments of categories, functors, and natural transformations. Note that we define these enrichments as categories/functors/transformations with extra data and properties, whereas the standard definition of enriched category does not do so. There are a couple of reasons for this choice: - It will help use prove the univalence of the bicategory of univalent enriched categories. That is because in the whole proof, we don't have to prove equality of the type of objects. As such, we can reuse the proof that the bicategory of univalent categories is univalent. - If we would use the usual definition of enriched categories, then in order to access the morphisms, we would first need to take the underlying category. With this definition, we can use a coercion instead. Our definition is loosely inspired by the one given by McDermott and Uustalu in "What makes a strong monad?" https://arxiv.org/pdf/2207.00851.pdf We also define faithful monoidal categories. These are monoidal categories in which the representable functor is faithful. This property is useful, because it implies that every natural transformation is actually enriched. Contents 1. Enrichments of categories 2. Equality of enrichments 3. Faithfulness 4. Composition operations 5. Transport lemmas *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.covyoneda. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Enrichments of categories *) Definition enrichment_data (C : precategory_data) (V : monoidal_cat) : UU := ∑ (arr : C → C → V), (∏ (x : C), I_{V} --> arr x x) × (∏ (x y z : C), arr y z ⊗ arr x y --> arr x z) × (∏ (x y : C), x --> y → I_{V} --> arr x y) × (∏ (x y : C), I_{V} --> arr x y → x --> y). Definition arr_enrichment_data {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) (x y : C) : V := pr1 E x y. Notation "E ⦃ x , y ⦄" := (arr_enrichment_data E x y) (at level 49). Definition enriched_id {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) (x : C) : I_{V} --> E ⦃ x , x ⦄ := pr12 E x. Definition enriched_comp {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) (x y z : C) : (E ⦃ y , z ⦄) ⊗ (E ⦃ x , y ⦄) --> E ⦃ x , z ⦄ := pr122 E x y z. Definition enriched_from_arr {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) {x y : C} (f : x --> y) : I_{V} --> E ⦃ x , y ⦄ := pr1 (pr222 E) x y f. Definition enriched_to_arr {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) {x y : C} (f : I_{V} --> E ⦃ x , y ⦄) : x --> y := pr2 (pr222 E) x y f. Definition enrichment_laws {C : precategory_data} {V : monoidal_cat} (E : enrichment_data C V) : UU := (∏ (x y : C), mon_lunitor (E ⦃ x , y ⦄) = enriched_id E y #⊗ identity _ · enriched_comp E x y y) × (∏ (x y : C), mon_runitor (E ⦃ x , y ⦄) = identity _ #⊗ enriched_id E x · enriched_comp E x x y) × (∏ (w x y z : C), enriched_comp E x y z #⊗ identity (E ⦃ w, x ⦄) · enriched_comp E w x z = mon_lassociator _ _ _ · identity _ #⊗ enriched_comp E w x y · enriched_comp E w y z) × (∏ (x y : C) (f : x --> y), enriched_to_arr E (enriched_from_arr E f) = f) × (∏ (x y : C) (f : I_{V} --> E ⦃ x , y ⦄), enriched_from_arr E (enriched_to_arr E f) = f) × (∏ (x : C), enriched_to_arr E (enriched_id E x) = identity x) × (∏ (x y z : C) (f : x --> y) (g : y --> z), f · g = enriched_to_arr E (mon_linvunitor I_{V} · (enriched_from_arr E g #⊗ enriched_from_arr E f) · enriched_comp E x y z)). Definition isaprop_enrichment_laws {C : category} {V : monoidal_cat} (E : enrichment_data C V) : isaprop (enrichment_laws E). Proof. repeat (use isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property. Qed. Definition enrichment (C : category) (V : monoidal_cat) : UU := ∑ (E : enrichment_data C V), enrichment_laws E. Coercion enrichment_to_data {C : category} {V : monoidal_cat} (E : enrichment C V) : enrichment_data C V := pr1 E. Section EnrichmentLaws. Context {C : category} {V : monoidal_cat} (E : enrichment C V). Definition enrichment_id_left (x y : C) : mon_lunitor (E ⦃ x , y ⦄) = enriched_id E y #⊗ identity _ · enriched_comp E x y y. Proof. exact (pr12 E x y). Qed. Definition enrichment_id_right (x y : C) : mon_runitor (E ⦃ x , y ⦄) = identity _ #⊗ enriched_id E x · enriched_comp E x x y. Proof. exact (pr122 E x y). Qed. Definition enrichment_assoc (w x y z : C) : enriched_comp E x y z #⊗ identity _ · enriched_comp E w x z = mon_lassociator _ _ _ · identity _ #⊗ enriched_comp E w x y · enriched_comp E w y z. Proof. exact (pr1 (pr222 E) w x y z). Qed. Definition enrichment_assoc' (w x y z : C) : identity _ #⊗ enriched_comp E w x y · enriched_comp E w y z = mon_rassociator _ _ _ · enriched_comp E x y z #⊗ identity _ · enriched_comp E w x z. Proof. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. apply enrichment_assoc. } rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. apply idpath. Qed. Definition enriched_to_from_arr {x y : C} (f : x --> y) : enriched_to_arr E (enriched_from_arr E f) = f. Proof. exact (pr12 (pr222 E) x y f). Qed. Definition enriched_from_to_arr {x y : C} (f : I_{V} --> E ⦃ x , y ⦄) : enriched_from_arr E (enriched_to_arr E f) = f. Proof. exact (pr122 (pr222 E) x y f). Qed. Definition enriched_to_arr_id (x : C) : enriched_to_arr E (enriched_id E x) = identity x. Proof. exact (pr1 (pr222 (pr222 E)) x). Qed. Definition enriched_from_arr_id (x : C) : enriched_from_arr E (identity x) = enriched_id E x. Proof. refine (_ @ enriched_from_to_arr _). apply maponpaths. refine (!_). apply enriched_to_arr_id. Qed. Definition enriched_to_arr_comp {x y z : C} (f : x --> y) (g : y --> z) : f · g = enriched_to_arr E (mon_linvunitor I_{V} · (enriched_from_arr E g #⊗ enriched_from_arr E f) · enriched_comp E x y z). Proof. exact (pr2 (pr222 (pr222 E)) x y z f g). Qed. Definition enriched_from_arr_comp {x y z : C} (f : x --> y) (g : y --> z) : enriched_from_arr E (f · g) = mon_linvunitor I_{V} · (enriched_from_arr E g #⊗ enriched_from_arr E f) · enriched_comp E x y z. Proof. refine (_ @ enriched_from_to_arr _). apply maponpaths. apply enriched_to_arr_comp. Qed. Definition isweq_enriched_from_arr (x y : C) : isweq (@enriched_from_arr _ _ E x y). Proof. use isweq_iso. - exact (enriched_to_arr E). - intro f. apply enriched_to_from_arr. - intro f. apply enriched_from_to_arr. Defined. Definition isweq_enriched_to_arr (x y : C) : isweq (@enriched_to_arr _ _ E x y). Proof. exact (pr2 (invweq (_ ,, isweq_enriched_from_arr x y))). Defined. End EnrichmentLaws. Definition cat_with_enrichment (V : monoidal_cat) : UU := ∑ (C : category), enrichment C V. Coercion cat_with_enrichment_to_cat {V : monoidal_cat} (E : cat_with_enrichment V) : category := pr1 E. Coercion cat_with_enrichment_to_enrichment {V : monoidal_cat} (E : cat_with_enrichment V) : enrichment E V := pr2 E. (** 2. Equality of enrichments *) Definition enrichment_data_hom_weq {C : precategory_data} {V : monoidal_cat} (HV : is_univalent V) (E₁ E₂ : enrichment_data C V) : (pr1 E₁ = pr1 E₂) ≃ ∏ (x y : C), z_iso (pr1 E₁ x y) (pr1 E₂ x y) := (weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, _ ,, HV _ _) ∘ weqtoforallpaths _ _ _) ∘ weqtoforallpaths _ _ _)%weq. Definition enrichment_data_hom_path_help {C : precategory_data} {V : monoidal_cat} (E₁ E₂ : enrichment_data C V) : UU := ∑ (fs : ∏ (x y : C), z_iso (pr1 E₁ x y) (pr1 E₂ x y)), (∏ (x : C), enriched_id E₁ x · fs x x = enriched_id E₂ x) × (∏ (x y z : C), enriched_comp E₁ x y z · fs x z = fs y z #⊗ fs x y · enriched_comp E₂ x y z) × (∏ (x y : C) (f : x --> y), enriched_from_arr E₁ f · fs x y = enriched_from_arr E₂ f) × (∏ (x y : C) (f : I_{V} --> E₁ ⦃ x , y ⦄), enriched_to_arr E₁ f = enriched_to_arr E₂ (f · fs x y)). Definition enrichment_data_hom_path {C : category} {V : monoidal_cat} (HV : is_univalent V) (E₁ E₂ : enrichment_data C V) : E₁ ╝ E₂ ≃ enrichment_data_hom_path_help E₁ E₂. Proof. use (weqbandf (enrichment_data_hom_weq HV E₁ E₂)). intros p. induction E₁ as [ M₁ E₁ ]. induction E₂ as [ M₂ E₂ ]. cbn in *. induction p. cbn. use weqimplimpl. - intro p. induction p. repeat split ; intros. + rewrite id_right. apply idpath. + rewrite id_right. rewrite tensor_id_id. rewrite id_left. apply idpath. + apply id_right. + rewrite id_right. apply idpath. - intros p. repeat (use pathsdirprod). + use funextsec ; intro x. pose (pr1 p x) as q. rewrite id_right in q. exact q. + use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. pose (pr12 p x y z) as q. rewrite id_right in q. rewrite tensor_id_id in q. rewrite id_left in q. exact q. + use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. pose (pr122 p x y f) as q. cbn in q. rewrite id_right in q. exact q. + use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. pose (pr222 p x y f) as q. cbn in q. rewrite id_right in q. exact q. - repeat (apply isaset_dirprod) ; repeat (use impred_isaset ; intro) ; apply homset_property. - repeat (apply isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property. Defined. (** 3. Faithfulness *) Definition faithful_moncat (V : monoidal_cat) : UU := ∏ (x y : V) (f g : x --> y), (∏ (a : I_{V} --> x), a · f = a · g) → f = g. Proposition isaprop_faithful_moncat (V : monoidal_cat) : isaprop (faithful_moncat V). Proof. repeat (use impred ; intro). apply homset_property. Qed. Proposition faithful_weq_covyoneda_faithful (V : monoidal_cat) : faithful_moncat V ≃ faithful (covyoneda V (I_{V})). Proof. use weqimplimpl. - intros HV x y f. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } apply HV. intros g. exact (eqtohomot (pr2 φ₁ @ !(pr2 φ₂)) g). - intros HV x y f g H. use (invmaponpathsincl _ (HV x y) f g). use funextsec. exact H. - apply isaprop_faithful_moncat. - apply isaprop_faithful. Qed. Definition conservative_moncat (V : monoidal_cat) : UU := ∏ (x y : V) (f : x --> y), isweq (λ (a : I_{V} --> x), a · f) → is_z_isomorphism f. Proposition isaprop_conservative_moncat (V : monoidal_cat) : isaprop (conservative_moncat V). Proof. repeat (use impred ; intro). apply isaprop_is_z_isomorphism. Qed. Proposition conservative_weq_covyoneda_conservative (V : monoidal_cat) : conservative_moncat V ≃ conservative (covyoneda V (I_{V})). Proof. use weqimplimpl. - intros HV x y f Hf. apply HV. exact (hset_z_iso_is_equiv _ _ (_ ,, Hf)). - intros HV x y f Hf. apply HV. use (hset_equiv_is_z_iso _ _ (_ ,, _)). exact Hf. - apply isaprop_conservative_moncat. - apply isaprop_conservative. Qed. (** 4. Composition operations *) Definition precomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {x y : C} (z : C) (f : x --> y) : E ⦃ y , z ⦄ --> E ⦃ x , z ⦄ := mon_rinvunitor _ · (identity _ #⊗ enriched_from_arr E f) · enriched_comp E x y z. Definition precomp_arr_id {C : category} {V : monoidal_cat} (E : enrichment C V) (x y : C) : precomp_arr E _ (identity x) = identity (E ⦃ x , y ⦄). Proof. unfold precomp_arr. rewrite enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply mon_rinvunitor_runitor. Qed. Definition precomp_arr_comp {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : w --> x) (g : x --> y) : precomp_arr E z (f · g) = precomp_arr E z g · precomp_arr E z f. Proof. unfold precomp_arr. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite enriched_from_arr_comp. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply tensor_rassociator. } etrans. { rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { apply maponpaths_2. exact (!(tensor_comp_mor _ _ _ _)). } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite !id_left, !id_right. refine (tensor_split' _ _ @ _). rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply tensor_rinvunitor. } rewrite !assoc. refine (!_). refine (tensor_comp_id_r _ _ @ _). apply maponpaths_2. refine (tensor_comp_id_r _ _ @ _). refine (!_). etrans. { apply tensor_rinvunitor. } apply maponpaths_2. refine (!(mon_rinvunitor_triangle _ _) @ _). rewrite mon_rinvunitor_I_mon_linvunitor_I. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply mon_lassociator_rassociator. Qed. Definition enriched_id_precomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {x y : C} (f : x --> y) : enriched_id E y · precomp_arr E _ f = enriched_from_arr E f. Proof. unfold precomp_arr. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply tensor_lunitor. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite mon_lunitor_I_mon_runitor_I. apply mon_rinvunitor_runitor. Qed. Definition enriched_from_arr_precomp {C : category} {V : monoidal_cat} (E : enrichment C V) {x y z : C} (f : x --> y) (g : y --> z) : enriched_from_arr E g · precomp_arr E _ f = enriched_from_arr E (f · g). Proof. unfold precomp_arr. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths. apply tensor_split'. } rewrite !assoc. apply maponpaths_2. refine (!_). rewrite mon_linvunitor_I_mon_rinvunitor_I. apply tensor_rinvunitor. Qed. Definition enriched_comp_precomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : w --> x) : enriched_comp E x y z · precomp_arr E z f = (identity _ #⊗ precomp_arr E y f) · enriched_comp E w y z. Proof. unfold precomp_arr. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } rewrite !assoc. apply maponpaths_2. refine (_ @ !(tensor_comp_id_l _ _)). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { do 2 apply maponpaths_2. exact (!(tensor_id_id _ _)). } apply tensor_lassociator. } rewrite !assoc. refine (_ @ !(tensor_comp_id_l _ _)). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_rinvunitor_triangle. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply mon_rassociator_lassociator. Qed. Definition postcomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {y z : C} (x : C) (f : y --> z) : E ⦃ x , y ⦄ --> E ⦃ x , z ⦄ := mon_linvunitor _ · (enriched_from_arr E f #⊗ identity _) · enriched_comp E x y z. Definition postcomp_arr_id {C : category} {V : monoidal_cat} (E : enrichment C V) (x y : C) : postcomp_arr E _ (identity y) = identity (E ⦃ x , y ⦄). Proof. unfold postcomp_arr. rewrite enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Definition postcomp_arr_comp {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : x --> y) (g : y --> z) : postcomp_arr E w (f · g) = postcomp_arr E w f · postcomp_arr E w g. Proof. unfold postcomp_arr. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite enriched_from_arr_comp. etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc. } rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply tensor_lassociator. } etrans. { rewrite !assoc. do 2 apply maponpaths_2. rewrite mon_linvunitor_I_mon_rinvunitor_I. refine (!_). apply mon_inv_triangle. } etrans. { apply maponpaths_2. exact (!(tensor_comp_mor _ _ _ _)). } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite !id_left, !id_right. refine (tensor_split _ _ @ _). rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply tensor_linvunitor. } rewrite !assoc. refine (!_). refine (tensor_comp_id_l _ _ @ _). apply maponpaths_2. refine (tensor_comp_id_l _ _ @ _). refine (!_). etrans. { apply tensor_linvunitor. } apply maponpaths_2. refine (!(mon_linvunitor_triangle _ _) @ _). rewrite mon_linvunitor_I_mon_rinvunitor_I. refine (!_). apply mon_inv_triangle. Qed. Definition enriched_id_postcomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {x y : C} (f : x --> y) : enriched_id E x · postcomp_arr E _ f = enriched_from_arr E f. Proof. unfold postcomp_arr. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply tensor_runitor. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite mon_runitor_I_mon_lunitor_I. apply mon_linvunitor_lunitor. Qed. Definition enriched_from_arr_postcomp {C : category} {V : monoidal_cat} (E : enrichment C V) {x y z : C} (f : x --> y) (g : y --> z) : enriched_from_arr E f · postcomp_arr E _ g = enriched_from_arr E (f · g). Proof. unfold postcomp_arr. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths. apply tensor_split. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_linvunitor. Qed. Definition enriched_comp_postcomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : y --> z) : enriched_comp E w x y · postcomp_arr E w f = (postcomp_arr E x f #⊗ identity _) · enriched_comp E w x z. Proof. unfold postcomp_arr. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. refine (_ @ !(tensor_comp_id_r _ _)). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc. refine (_ @ !(tensor_comp_id_r _ _)). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply mon_lassociator_rassociator. Qed. Proposition precomp_postcomp_arr_assoc {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : x --> y) : (precomp_arr E z f #⊗ identity _) · enriched_comp E w x z = (identity _ #⊗ postcomp_arr E w f) · enriched_comp E _ _ _. Proof. unfold precomp_arr. rewrite !tensor_comp_id_r. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. apply maponpaths_2. unfold postcomp_arr. rewrite !tensor_comp_id_l. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite mon_inv_triangle. apply idpath. Qed. Definition precomp_postcomp_arr {C : category} {V : monoidal_cat} (E : enrichment C V) {w x y z : C} (f : w --> x) (g : y --> z) : precomp_arr E y f · postcomp_arr E w g = postcomp_arr E x g · precomp_arr E z f. Proof. unfold precomp_arr, postcomp_arr. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_r. } etrans. { refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. apply idpath. Qed. Definition postcomp_arr_is_z_iso {V : monoidal_cat} {C : category} (E : enrichment C V) (w : C) {x y : C} (f : x --> y) (Hf : is_z_isomorphism f) : is_z_isomorphism (postcomp_arr E w f). Proof. pose (f_iso := make_z_iso _ _ Hf). use make_is_z_isomorphism. - exact (postcomp_arr E w (inv_from_z_iso f_iso)). - split. + abstract (rewrite <- postcomp_arr_comp ; rewrite <- postcomp_arr_id ; apply maponpaths ; apply (z_iso_inv_after_z_iso f_iso)). + abstract (rewrite <- postcomp_arr_comp ; rewrite <- postcomp_arr_id ; apply maponpaths ; apply (z_iso_after_z_iso_inv f_iso)). Defined. Definition postcomp_arr_z_iso {V : monoidal_cat} {C : category} (E : enrichment C V) (w : C) {x y : C} (f : z_iso x y) : z_iso (E ⦃ w , x ⦄) (E ⦃ w , y ⦄). Proof. refine (postcomp_arr E w f ,, _). use postcomp_arr_is_z_iso. exact (pr2 f). Defined. Definition precomp_arr_is_z_iso {V : monoidal_cat} {C : category} (E : enrichment C V) (z : C) {x y : C} (f : x --> y) (Hf : is_z_isomorphism f) : is_z_isomorphism (precomp_arr E z f). Proof. pose (f_iso := make_z_iso _ _ Hf). use make_is_z_isomorphism. - exact (precomp_arr E z (inv_from_z_iso f_iso)). - split. + abstract (rewrite <- precomp_arr_comp ; rewrite <- precomp_arr_id ; apply maponpaths ; apply (z_iso_after_z_iso_inv f_iso)). + abstract (rewrite <- precomp_arr_comp ; rewrite <- precomp_arr_id ; apply maponpaths ; apply (z_iso_inv_after_z_iso f_iso)). Defined. Definition precomp_arr_z_iso {V : monoidal_cat} {C : category} (E : enrichment C V) (z : C) {x y : C} (f : z_iso x y) : z_iso (E ⦃ y , z ⦄) (E ⦃ x , z ⦄). Proof. refine (precomp_arr E z f ,, _). use precomp_arr_is_z_iso. exact (pr2 f). Defined. (** 5. Transport lemmas *) Proposition transportf_enriched_arr_l {V : monoidal_cat} {C : category} (E : enrichment C V) {x₁ x₂ : C} (p : x₁ = x₂) (y : C) (f : I_{V} --> E ⦃ x₁ , y ⦄) : transportf (λ (x : C), I_{V} --> E ⦃ x , y ⦄) p f = enriched_from_arr E (idtoiso (!p) · enriched_to_arr E f). Proof. induction p ; cbn. rewrite id_left. rewrite enriched_from_to_arr. apply idpath. Qed. Proposition transportf_enriched_arr_r {V : monoidal_cat} {C : category} (E : enrichment C V) (x : C) {y₁ y₂ : C} (p : y₁ = y₂) (f : I_{ V} --> E ⦃ x , y₁ ⦄) : transportf (λ (y : C), I_{V} --> E ⦃ x , y ⦄) p f = enriched_from_arr E (enriched_to_arr E f · idtoiso p). Proof. induction p ; cbn. rewrite id_right. rewrite enriched_from_to_arr. apply idpath. Qed. Proposition transportf_enriched_l {V : monoidal_cat} {C : category} (E : enrichment C V) {x₁ x₂ : C} (p : x₁ = x₂) {y : C} {v : V} (f : v --> E ⦃ x₁ , y ⦄) : transportf (λ (x : C), v --> E ⦃ x , y ⦄) p f = f · precomp_arr E y (idtoiso (!p)). Proof. induction p ; cbn. rewrite precomp_arr_id. rewrite id_right. apply idpath. Qed. Proposition transportf_enriched_r {V : monoidal_cat} {C : category} (E : enrichment C V) (x : C) {y₁ y₂ : C} (p : y₁ = y₂) (v : V) (f : v --> E ⦃ x , y₁ ⦄) : transportf (λ (y : C), v --> E ⦃ x , y ⦄) p f = f · postcomp_arr E x (idtoiso p). Proof. Proof. induction p ; cbn. rewrite postcomp_arr_id. rewrite id_right. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/EnrichmentAdjunction.v000066400000000000000000000167701451125700300264750ustar00rootroot00000000000000(********************************************************************** Enriched adjunctions In this file, we define the notion of enriched adjunctions. To do so, we first define the notion of an enrichment of an adjunction, which is a pair of an enrichment for both functors and for the unit and counit. An enriched adjunction is a pair of an adjunction together with an enrichment. Context 1. Enrichments of adjunctions 2. Enriched adjunctions 3. Isos between the enriched homs **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. (** 1. Enrichments of adjunctions *) Definition adjunction_enrichment {V : monoidal_cat} {C₁ C₂ : category} (L : adjunction C₁ C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : UU := ∑ (EL : functor_enrichment (left_adjoint L) E₁ E₂) (ER : functor_enrichment (right_adjoint L) E₂ E₁), (nat_trans_enrichment (adjunit L) (functor_id_enrichment E₁) (functor_comp_enrichment EL ER)) × (nat_trans_enrichment (adjcounit L) (functor_comp_enrichment ER EL)) (functor_id_enrichment E₂). Definition make_adjunction_enrichment {V : monoidal_cat} {C₁ C₂ : category} (L : adjunction C₁ C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) (EL : functor_enrichment (left_adjoint L) E₁ E₂) (ER : functor_enrichment (right_adjoint L) E₂ E₁) (Eη : nat_trans_enrichment (adjunit L) (functor_id_enrichment E₁) (functor_comp_enrichment EL ER)) (Eε : nat_trans_enrichment (adjcounit L) (functor_comp_enrichment ER EL) (functor_id_enrichment E₂)) : adjunction_enrichment L E₁ E₂ := EL ,, ER ,, Eη ,, Eε. Section Accessors. Context {V : monoidal_cat} {C₁ C₂ : category} {L : adjunction C₁ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EL : adjunction_enrichment L E₁ E₂). Definition left_adjoint_enrichment : functor_enrichment (left_adjoint L) E₁ E₂ := pr1 EL. Definition right_adjoint_enrichment : functor_enrichment (right_adjoint L) E₂ E₁ := pr12 EL. Definition adjoint_unit_enrichment : nat_trans_enrichment (adjunit L) (functor_id_enrichment E₁) (functor_comp_enrichment left_adjoint_enrichment right_adjoint_enrichment) := pr122 EL. Definition adjoint_counit_enrichment : nat_trans_enrichment (adjcounit L) (functor_comp_enrichment right_adjoint_enrichment left_adjoint_enrichment) (functor_id_enrichment E₂) := pr222 EL. End Accessors. (** 2. Enriched adjunctions *) Definition enriched_adjunction {V : monoidal_cat} {C₁ C₂ : category} (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : UU := ∑ (L : adjunction C₁ C₂), adjunction_enrichment L E₁ E₂. Coercion enriched_adjunction_to_adjunction {V : monoidal_cat} {C₁ C₂ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (L : enriched_adjunction E₁ E₂) : adjunction C₁ C₂ := pr1 L. Coercion enriched_adjunction_to_enrichment {V : monoidal_cat} {C₁ C₂ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (L : enriched_adjunction E₁ E₂) : adjunction_enrichment L E₁ E₂ := pr2 L. (** 3. Isos between the enriched homs *) Section HomEquiv. Context {V : monoidal_cat} {C₁ C₂ : category} {A : adjunction C₁ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EA : adjunction_enrichment A E₁ E₂). Let L : C₁ ⟶ C₂ := left_adjoint A. Let EL : functor_enrichment L E₁ E₂ := left_adjoint_enrichment EA. Let R : C₂ ⟶ C₁ := right_adjoint A. Let ER : functor_enrichment R E₂ E₁ := right_adjoint_enrichment EA. Let η : functor_identity _ ⟹ L ∙ R := adjunit A. Let Eη : nat_trans_enrichment η (functor_id_enrichment _) (functor_comp_enrichment EL ER) := adjoint_unit_enrichment EA. Let ε : R ∙ L ⟹ functor_identity _ := adjcounit A. Let Eε : nat_trans_enrichment ε (functor_comp_enrichment ER EL) (functor_id_enrichment _) := adjoint_counit_enrichment EA. Definition adjunction_enrichment_left_hom (x : C₁) (y : C₂) : E₂ ⦃ L x , y ⦄ --> E₁ ⦃ x , R y ⦄ := ER (L x) y · precomp_arr E₁ (R y) (η x). Definition adjunction_enrichment_right_hom (x : C₁) (y : C₂) : E₁ ⦃ x , R y ⦄ --> E₂ ⦃ L x , y ⦄ := EL x (R y) · postcomp_arr E₂ (L x) (ε y). Proposition adjunction_enrichment_hom_is_inverse (x : C₁) (y : C₂) : is_inverse_in_precat (adjunction_enrichment_left_hom x y) (adjunction_enrichment_right_hom x y). Proof. split ; unfold adjunction_enrichment_left_hom, adjunction_enrichment_right_hom. - rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- functor_enrichment_precomp_arr. rewrite !assoc'. apply maponpaths. apply idpath. } rewrite precomp_postcomp_arr. rewrite !assoc. etrans. { apply maponpaths_2. exact (!(nat_trans_enrichment_to_comp Eε (L x) y)). } cbn. rewrite id_left. rewrite <- precomp_arr_comp. refine (_ @ precomp_arr_id _ _ _). apply maponpaths. exact (triangle_1_statement_from_adjunction A x). - rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- functor_enrichment_postcomp_arr. rewrite !assoc'. apply maponpaths. apply idpath. } rewrite <- precomp_postcomp_arr. rewrite !assoc. etrans. { apply maponpaths_2. exact (nat_trans_enrichment_to_comp Eη x (R y)). } cbn. rewrite id_left. rewrite <- postcomp_arr_comp. refine (_ @ postcomp_arr_id _ _ _). apply maponpaths. exact (triangle_2_statement_from_adjunction A y). Qed. Definition adjunction_enrichment_hom_iso (x : C₁) (y : C₂) : z_iso (E₂ ⦃ L x , y ⦄) (E₁ ⦃ x , R y ⦄). Proof. use make_z_iso. - exact (adjunction_enrichment_left_hom x y). - exact (adjunction_enrichment_right_hom x y). - exact (adjunction_enrichment_hom_is_inverse x y). Qed. End HomEquiv. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/EnrichmentFunctor.v000066400000000000000000000274331451125700300260150ustar00rootroot00000000000000(***************************************************************** Enrichments of functors In this file, we define functos with enrichments. The approach we take, is the same as for enrichments for categories. Contents 1. Functors with enrichments 2. Fully faithful functors 3. The enriched identity functor 4. The composition of enriched functors 5. The constant functor 6. Lemmas for pre- and postcomposition *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.terminal. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Functors with enrichments *) Definition functor_enrichment_data {V : monoidal_cat} {C₁ C₂ : category} (F : C₁ ⟶ C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : UU := ∏ (x y : C₁), E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , F y ⦄. Definition is_functor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment_data F E₁ E₂) : UU := (∏ (x : C₁), enriched_id E₁ x · FE x x = enriched_id E₂ (F x)) × (∏ (x y z : C₁), enriched_comp E₁ x y z · FE x z = FE y z #⊗ FE x y · enriched_comp E₂ (F x) (F y) (F z)) × (∏ (x y : C₁) (f : x --> y), enriched_from_arr E₂ (#F f) = enriched_from_arr E₁ f · FE x y). Definition isaprop_is_functor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment_data F E₁ E₂) : isaprop (is_functor_enrichment FE). Proof. repeat (use isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property. Qed. Definition functor_enrichment {V : monoidal_cat} {C₁ C₂ : category} (F : C₁ ⟶ C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : UU := ∑ (FE : functor_enrichment_data F E₁ E₂), is_functor_enrichment FE. Definition isaset_functor_enrichment {V : monoidal_cat} {C₁ C₂ : category} (F : C₁ ⟶ C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : isaset (functor_enrichment F E₁ E₂). Proof. use isaset_total2. - do 2 (use impred_isaset ; intro). apply homset_property. - intro. apply isasetaprop. apply isaprop_is_functor_enrichment. Qed. Definition functor_enrichment_to_data {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) (x y : C₁) : E₁ ⦃ x, y ⦄ --> E₂ ⦃ F x, F y ⦄ := pr1 FE x y. Coercion functor_enrichment_to_data : functor_enrichment >-> Funclass. Section FunctorLaws. Context {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂). Definition functor_enrichment_id (x : C₁) : enriched_id E₁ x · FE x x = enriched_id E₂ (F x). Proof. exact (pr12 FE x). Qed. Definition functor_enrichment_comp (x y z : C₁) : enriched_comp E₁ x y z · FE x z = FE y z #⊗ FE x y · enriched_comp E₂ (F x) (F y) (F z). Proof. exact (pr122 FE x y z). Qed. Definition functor_enrichment_from_arr {x y : C₁} (f : x --> y) : enriched_from_arr E₂ (#F f) = enriched_from_arr E₁ f · FE x y. Proof. exact (pr222 FE x y f). Qed. End FunctorLaws. Definition functor_with_enrichment {V : monoidal_cat} (E₁ : cat_with_enrichment V) (E₂ : cat_with_enrichment V) : UU := ∑ (F : E₁ ⟶ E₂), functor_enrichment F E₁ E₂. Coercion functor_with_enrichment_to_functor {V : monoidal_cat} {E₁ : cat_with_enrichment V} {E₂ : cat_with_enrichment V} (F : functor_with_enrichment E₁ E₂) : E₁ ⟶ E₂ := pr1 F. (** 2. Fully faithful functors *) Definition fully_faithful_enriched_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : UU := ∏ (x y : C₁), is_z_isomorphism (EF x y). Definition isaprop_fully_faithful_enriched_functor {C₁ C₂ : category} {F : C₁ ⟶ C₂} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : isaprop (fully_faithful_enriched_functor EF). Proof. repeat (use impred ; intro). apply isaprop_is_z_isomorphism. Qed. Definition fully_faithful_enriched_functor_to_faithful {C₁ C₂ : category} {F : C₁ ⟶ C₂} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) (HEF : fully_faithful_enriched_functor EF) : faithful F. Proof. intros x y f. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } refine (!(enriched_to_from_arr E₁ (pr1 φ₁)) @ _). refine (_ @ enriched_to_from_arr E₁ (pr1 φ₂)). apply maponpaths. use (cancel_z_iso _ _ (_ ,, HEF x y)) ; cbn. pose (maponpaths (enriched_from_arr E₂) (pr2 φ₁ @ !(pr2 φ₂))) as p. rewrite !(functor_enrichment_from_arr EF) in p. exact p. Qed. (** 3. The enriched identity functor *) Definition functor_id_enrichment {V : monoidal_cat} {C : category} (E : enrichment C V) : functor_enrichment (functor_identity C) E E. Proof. refine ((λ x y, identity _) ,, _). repeat split. - abstract (intro x ; cbn ; apply id_right). - abstract (intros x y z ; cbn ; rewrite id_right ; rewrite tensor_id_id ; rewrite id_left ; apply idpath). - abstract (intros x y f ; cbn ; rewrite id_right ; apply idpath). Defined. Definition functor_id_enrichment_fully_faithful {V : monoidal_cat} {C : category} (E : enrichment C V) : fully_faithful_enriched_functor (functor_id_enrichment E). Proof. intros x y. apply is_z_isomorphism_identity. Defined. (** 4. The composition of enriched functors *) Definition functor_comp_enrichment {V : monoidal_cat} {C₁ C₂ C₃ : category} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} (FE₁ : functor_enrichment F₁ E₁ E₂) (FE₂ : functor_enrichment F₂ E₂ E₃) : functor_enrichment (F₁ ∙ F₂) E₁ E₃. Proof. refine ((λ x y, FE₁ x y · FE₂ (F₁ x) (F₁ y)) ,, _). repeat split ; cbn. - abstract (intros x ; rewrite !assoc ; etrans ; [ apply maponpaths_2 ; apply functor_enrichment_id | ] ; apply functor_enrichment_id). - abstract (intros x y z ; rewrite !assoc ; etrans ; [ apply maponpaths_2 ; apply functor_enrichment_comp | ] ; rewrite !assoc' ; etrans ; [ apply maponpaths ; apply functor_enrichment_comp | ] ; rewrite !assoc ; apply maponpaths_2 ; rewrite tensor_comp_mor ; apply idpath). - abstract (intros x y f ; etrans ; [ apply (functor_enrichment_from_arr FE₂) | ] ; etrans ; [ apply maponpaths_2 ; apply (functor_enrichment_from_arr FE₁) | ] ; rewrite !assoc ; apply idpath). Defined. Definition functor_comp_enrichment_fully_faithful {V : monoidal_cat} {C₁ C₂ C₃ : category} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {FE₁ : functor_enrichment F₁ E₁ E₂} {FE₂ : functor_enrichment F₂ E₂ E₃} (HF₁ : fully_faithful_enriched_functor FE₁) (HF₂ : fully_faithful_enriched_functor FE₂) : fully_faithful_enriched_functor (functor_comp_enrichment FE₁ FE₂). Proof. intros x y ; cbn. use is_z_iso_comp_of_is_z_isos. - apply HF₁. - apply HF₂. Defined. (** 5. The constant functor *) Definition functor_constant_enrichment {V : monoidal_cat} (HV : isTerminal V (I_{V})) {C₁ C₂ : category} (a : C₂) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : functor_enrichment (constant_functor _ _ a) E₁ E₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (λ x y, TerminalArrow (_ ,, HV) _ · enriched_id E₂ a). - abstract (intros x ; cbn ; rewrite !assoc ; refine (_ @ id_left _) ; apply maponpaths_2 ; apply (@TerminalArrowEq _ (_ ,, HV))). - abstract (intros x y z ; cbn ; refine (!_) ; etrans ; [ apply maponpaths_2 ; apply tensor_comp_mor | ] ; rewrite !assoc' ; etrans ; [ apply maponpaths ; rewrite tensor_split ; rewrite !assoc' ; rewrite <- enrichment_id_left ; rewrite tensor_lunitor ; apply idpath | ] ; rewrite !assoc ; apply maponpaths_2 ; apply (@TerminalArrowEq _ (_ ,, HV))). - abstract (intros x y f ; cbn ; rewrite enriched_from_arr_id ; refine (!(id_left _) @ _) ; rewrite !assoc ; apply maponpaths_2 ; apply (@TerminalArrowEq _ (_ ,, HV))). Defined. (** 6. Lemmas for pre- and postcomposition *) Definition functor_enrichment_precomp_arr {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) {w x y : C₁} (f : w --> x) : FE x y · precomp_arr E₂ (F y) (#F f) = precomp_arr E₁ y f · FE w y. Proof. unfold precomp_arr. rewrite !assoc. rewrite tensor_rinvunitor. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite (functor_enrichment_from_arr FE). rewrite tensor_comp_l_id_l. rewrite !assoc'. rewrite functor_enrichment_comp. apply idpath. Qed. Definition functor_enrichment_postcomp_arr {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) {x y z : C₁} (f : y --> z) : FE x y · postcomp_arr E₂ (F x) (#F f) = postcomp_arr E₁ x f · FE x z. Proof. unfold postcomp_arr. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split. rewrite (functor_enrichment_from_arr FE). rewrite tensor_comp_r_id_l. rewrite !assoc'. rewrite functor_enrichment_comp. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/EnrichmentMonad.v000066400000000000000000000051671451125700300254330ustar00rootroot00000000000000(********************************************************************** Enriched monads In this file, we define the basic notions for enriched monads. More specifically, we define enrichments of monads and we define enriched monads. Contents 1. Enrichments of monads 2. Enriched monads **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. (** 1. Enrichments of monads *) Definition monad_enrichment {V : monoidal_cat} {C : category} (E : enrichment C V) (M : Monad C) : UU := ∑ (EM : functor_enrichment M E E), nat_trans_enrichment (η M) (functor_id_enrichment _) EM × nat_trans_enrichment (μ M) (functor_comp_enrichment EM EM) EM. Coercion endo_of_monad_enrichment {V : monoidal_cat} {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M) : functor_enrichment M E E := pr1 EM. Definition unit_of_monad_enrichment {V : monoidal_cat} {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M) : nat_trans_enrichment (η M) (functor_id_enrichment _) EM := pr12 EM. Definition mu_of_monad_enrichment {V : monoidal_cat} {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M) : nat_trans_enrichment (μ M) (functor_comp_enrichment EM EM) EM := pr22 EM. (** 2. Enriched monads *) Definition enriched_monad {V : monoidal_cat} {C : category} (E : enrichment C V) : UU := ∑ (M : Monad C), monad_enrichment E M. Coercion enriched_monad_to_monad {V : monoidal_cat} {C : category} {E : enrichment C V} (M : enriched_monad E) : Monad C := pr1 M. Definition enriched_monad_enrichment {V : monoidal_cat} {C : category} {E : enrichment C V} (M : enriched_monad E) : monad_enrichment E M := pr2 M. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/EnrichmentTransformation.v000066400000000000000000000361571451125700300274060ustar00rootroot00000000000000(***************************************************************** Enrichments of transformations In this file, we define enriched transformations. The definition is based on the same ideas as used in the definition for enrichments for categories and for functors. We also show that every natural transformation can be enriched if the monoidal category is faithful. Contents 1. Natural transformations with enrichments 2. The identity transformation 3. The unitors 4. The associators 5. Composition 6. Enriched transformations on faithful monoidal categories *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.whiskering. Opaque mon_lunitor mon_linvunitor. Opaque mon_runitor mon_rinvunitor. Opaque mon_lassociator mon_rassociator. Local Open Scope cat. Local Open Scope moncat. (** 1. Natural transformations with enrichments *) Definition nat_trans_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : nat_trans_data F G) {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₁ E₂) : UU := ∏ (x y : C₁), mon_rinvunitor (E₁ ⦃ x , y ⦄) · GE x y #⊗ enriched_from_arr E₂ (τ x) · enriched_comp E₂ _ _ _ = mon_linvunitor (E₁ ⦃ x , y ⦄) · enriched_from_arr E₂ (τ y) #⊗ FE x y · enriched_comp E₂ _ _ _. Definition nat_trans_with_enrichment {V : monoidal_cat} {E₁ : cat_with_enrichment V} {E₂ : cat_with_enrichment V} (F : functor_with_enrichment E₁ E₂) (G : functor_with_enrichment E₁ E₂) : UU := ∑ (τ : nat_trans_data F G), nat_trans_enrichment τ (pr2 F) (pr2 G). Definition isaprop_nat_trans_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : nat_trans_data F G) {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₁ E₂) : isaprop (nat_trans_enrichment τ FE GE). Proof. do 2 (use impred ; intro). apply homset_property. Qed. Definition eq_nat_trans_with_enrichment {V : monoidal_cat} {E₁ : cat_with_enrichment V} {E₂ : cat_with_enrichment V} {F : functor_with_enrichment E₁ E₂} {G : functor_with_enrichment E₁ E₂} {τ₁ τ₂ : nat_trans_with_enrichment F G} (p : ∏ (x : E₁), pr1 τ₁ x = pr1 τ₂ x) : τ₁ = τ₂. Proof. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use funextsec. exact p. Qed. Definition isaset_nat_trans_with_enrichment {V : monoidal_cat} {E₁ : cat_with_enrichment V} {E₂ : cat_with_enrichment V} (F : functor_with_enrichment E₁ E₂) (G : functor_with_enrichment E₁ E₂) : isaset (nat_trans_with_enrichment F G). Proof. use isaset_total2. - use impred_isaset. intro. apply homset_property. - intro. apply isasetaprop. do 2 (use impred ; intro). apply homset_property. Qed. Proposition nat_trans_enrichment_via_comp {V : monoidal_cat} {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : nat_trans_data F G) {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (p : ∏ (x y : C₁), EG x y · precomp_arr E₂ (G y) (τ x) = EF x y · postcomp_arr E₂ (F x) (τ y)) : nat_trans_enrichment τ EF EG. Proof. intros x y. refine (_ @ p x y @ _) ; unfold postcomp_arr, precomp_arr. - rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. rewrite <- tensor_split'. apply idpath. - rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. rewrite <- tensor_split. apply idpath. Qed. Proposition nat_trans_enrichment_to_comp {V : monoidal_cat} {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {τ : nat_trans_data F G} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (Eτ : nat_trans_enrichment τ EF EG) (x y : C₁) : EG x y · precomp_arr E₂ (G y) (τ x) = EF x y · postcomp_arr E₂ (F x) (τ y). Proof. refine (_ @ Eτ x y @ _) ; unfold postcomp_arr, precomp_arr. - rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. rewrite <- tensor_split'. apply idpath. - rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. rewrite <- tensor_split. apply idpath. Qed. (** 2. The identity transformation *) Definition id_trans_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_trans_id F) FE FE. Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_right. apply idpath. Qed. (** 3. The unitors *) Definition lunitor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_trans_id F) (functor_comp_enrichment (functor_id_enrichment _) FE) FE. Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_left, !id_right. apply idpath. Qed. Definition linvunitor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_trans_id F) FE (functor_comp_enrichment (functor_id_enrichment _) FE). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_left, !id_right. apply idpath. Qed. Definition runitor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_trans_id F) (functor_comp_enrichment FE (functor_id_enrichment _)) FE. Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_right. apply idpath. Qed. Definition rinvunitor_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_trans_id F) FE (functor_comp_enrichment FE (functor_id_enrichment _)). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_right. apply idpath. Qed. (** 4. The associators *) Definition lassociator_enrichment {V : monoidal_cat} {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {E₄ : enrichment C₄ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₂ E₃) (HE : functor_enrichment H E₃ E₄) : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment (functor_comp_enrichment FE GE) HE) (functor_comp_enrichment FE (functor_comp_enrichment GE HE)). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_right. rewrite !assoc'. apply idpath. Qed. Definition rassociator_enrichment {V : monoidal_cat} {C₁ C₂ C₃ C₄ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {H : C₃ ⟶ C₄} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {E₄ : enrichment C₄ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₂ E₃) (HE : functor_enrichment H E₃ E₄) : nat_trans_enrichment (nat_trans_id _) (functor_comp_enrichment FE (functor_comp_enrichment GE HE)) (functor_comp_enrichment (functor_comp_enrichment FE GE) HE). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_id, postcomp_arr_id. rewrite !id_right. rewrite !assoc'. apply idpath. Qed. (** 5. Composition *) Definition comp_trans_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F₁ F₂ F₃ : C₁ ⟶ C₂} {τ₁ : F₁ ⟹ F₂} {τ₂ : F₂ ⟹ F₃} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {FE₁ : functor_enrichment F₁ E₁ E₂} {FE₂ : functor_enrichment F₂ E₁ E₂} {FE₃ : functor_enrichment F₃ E₁ E₂} (τE₁ : nat_trans_enrichment τ₁ FE₁ FE₂) (τE₂ : nat_trans_enrichment τ₂ FE₂ FE₃) : nat_trans_enrichment (nat_trans_comp _ _ _ τ₁ τ₂) FE₁ FE₃. Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite precomp_arr_comp, postcomp_arr_comp. rewrite !assoc. rewrite (nat_trans_enrichment_to_comp τE₂). rewrite !assoc'. rewrite <- precomp_postcomp_arr. rewrite !assoc. rewrite (nat_trans_enrichment_to_comp τE₁). apply idpath. Qed. Definition pre_whisker_enrichment {V : monoidal_cat} {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G₁ G₂ : C₂ ⟶ C₃} {τ : G₁ ⟹ G₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} (FE : functor_enrichment F E₁ E₂) {GE₁ : functor_enrichment G₁ E₂ E₃} {GE₂ : functor_enrichment G₂ E₂ E₃} (τE : nat_trans_enrichment τ GE₁ GE₂) : nat_trans_enrichment (pre_whisker F τ : _ ∙ _ ⟹ _ ∙ _) (functor_comp_enrichment FE GE₁) (functor_comp_enrichment FE GE₂). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite !assoc'. apply maponpaths. rewrite (nat_trans_enrichment_to_comp τE). apply idpath. Qed. Definition post_whisker_enrichment {V : monoidal_cat} {C₁ C₂ C₃ : category} {F₁ F₂ : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {τ : F₁ ⟹ F₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {FE₁ : functor_enrichment F₁ E₁ E₂} {FE₂ : functor_enrichment F₂ E₁ E₂} (τE : nat_trans_enrichment τ FE₁ FE₂) (GE : functor_enrichment G E₂ E₃) : nat_trans_enrichment (post_whisker τ G : _ ∙ _ ⟹ _ ∙ _) (functor_comp_enrichment FE₁ GE) (functor_comp_enrichment FE₂ GE). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite !assoc'. rewrite (functor_enrichment_precomp_arr GE). rewrite (functor_enrichment_postcomp_arr GE). rewrite !assoc. apply maponpaths_2. rewrite (nat_trans_enrichment_to_comp τE). apply idpath. Qed. (** 6. Enriched transformations on faithful monoidal categories *) Definition is_nat_trans_from_enrichment {V : monoidal_cat} {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {τ : nat_trans_data F G} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {FE : functor_enrichment F E₁ E₂} {GE : functor_enrichment G E₁ E₂} (H : nat_trans_enrichment τ FE GE) : is_nat_trans _ _ τ. Proof. intros x y f. pose (H x y) as p. cbn in p. use (invmaponpathsweq (_ ,, isweq_enriched_from_arr E₂ _ _)). cbn. rewrite !enriched_from_arr_comp. rewrite (functor_enrichment_from_arr FE). rewrite (functor_enrichment_from_arr GE). etrans. { apply maponpaths_2. apply maponpaths. apply tensor_comp_l_id_l. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_linvunitor. } refine (!_). etrans. { apply maponpaths_2. apply maponpaths. apply tensor_comp_r_id_l. } rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. exact p. Qed. Definition faithful_moncat_nat_trans_enrichment {V : monoidal_cat} (HV : faithful_moncat V) {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : F ⟹ G) {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₁ E₂) : nat_trans_enrichment τ FE GE. Proof. intros x y. use HV. intros a. pose (maponpaths (λ z, enriched_from_arr E₂ z) (nat_trans_ax τ x y (enriched_to_arr E₁ a))) as p. cbn in p. rewrite !enriched_from_arr_comp in p. rewrite (functor_enrichment_from_arr FE) in p. rewrite (functor_enrichment_from_arr GE) in p. rewrite !enriched_from_to_arr in p. refine (_ @ !p @ _). - rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths. apply tensor_comp_r_id_l. } rewrite !assoc. apply maponpaths_2. rewrite mon_linvunitor_I_mon_rinvunitor_I. refine (!_). apply tensor_rinvunitor. - rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. apply tensor_comp_l_id_l. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_linvunitor. Qed. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/000077500000000000000000000000001451125700300237365ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/ChangeOfBase.v000066400000000000000000000532431451125700300264010ustar00rootroot00000000000000(***************************************************************** Change of base for enriched categories In this file, we define the change of base for enriched categories. In textbooks, this construction works as follows: if we have two monoidal categories `V₁` and `V₂` and a lax monoidal functor `F : V₁ ⟶ V₂`, then every category enriched over `V₁` gives rise to a category enriched over `V₂`. The objects stay the same and for the enriched morphisms, we use the functor `F`. However, in a univalent setting, we would like to restrict this construction. Let `V₁` be any monoidal category (for example, `Set`) and let `V₂` be the terminal monoidal category (only one object and only one morphism). Then we have a functor `V₁ ⟶ V₂` and as such, every category enriched over `V₁` is also enriched over the terminal monoidal category. However, between any two objects in a category enriched over the terminal monoidal category, there is at most one isomorphism. As such, if we leave the objects the same in this construction, this does not in general give rise to a univalent category. To guarantee that the change of base actually gives rise to a univalent category, we define a notion of preserving the underlying category (`preserve_underlying`), and this is sufficient to construct the desired assumptions. As such, univalence of the change of base follows directly from the univalence of the original category. We also show that functors that satisfy the following two conditions preserve the underlying category: - The functor is fully faithful on morphisms from the unit - The functor is a strong monoidal functor We also discuss the action of the change of base on functors and natural transformations. Contents 1. Functors that preserve the underlying category 1.1. The definition of such functors 1.2. Conditions that imply preservation of the underlying category 2. Change of base: enrichment for categories 3. Change of base: enrichment for functors 4. Change of base: enrichment for natural transformations 5. Change of base on the identity 6. Change of base on composition *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Functors that preserve the underlying category *) (** 1.1. The definition of such functors *) Definition preserve_underlying_data {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : UU := ∏ (v : V₁), I_{V₂} --> F v → I_{V₁} --> v. Definition preserves_underlying_laws {V₁ V₂ : monoidal_cat} {F : lax_monoidal_functor V₁ V₂} (Fv : preserve_underlying_data F) : UU := (∏ (v : V₁) (f : I_{V₂} --> F v), mon_functor_unit F · #F (Fv v f) = f) × (∏ (v : V₁) (f : I_{V₁} --> v), Fv v (mon_functor_unit F · #F f) = f). Definition preserve_underlying {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : UU := ∑ (Fv : preserve_underlying_data F), preserves_underlying_laws Fv. Definition make_preserve_underlying {V₁ V₂ : monoidal_cat} {F : lax_monoidal_functor V₁ V₂} (Fv : preserve_underlying_data F) (HFv : preserves_underlying_laws Fv) : preserve_underlying F := Fv ,, HFv. Definition preserve_underlying_to_data {V₁ V₂ : monoidal_cat} {F : lax_monoidal_functor V₁ V₂} (Fv : preserve_underlying F) (v : V₁) : I_{V₂} --> F v → I_{V₁} --> v := pr1 Fv v. Coercion preserve_underlying_to_data : preserve_underlying >-> Funclass. Section Laws. Context {V₁ V₂ : monoidal_cat} {F : lax_monoidal_functor V₁ V₂} (Fv : preserve_underlying F). Proposition preserve_underlying_right_inv {v : V₁} (f : I_{V₂} --> F v) : mon_functor_unit F · #F (Fv v f) = f. Proof. exact (pr12 Fv v f). Qed. Proposition preserve_underlying_left_inv {v : V₁} (f : I_{V₁} --> v) : Fv v (mon_functor_unit F · #F f) = f. Proof. exact (pr22 Fv v f). Qed. End Laws. (** 1.2. Conditions that imply preservation of the underlying category *) Definition strong_fully_faithful_on_points_to_preserve_underlying {V₁ V₂ : monoidal_cat} {F : strong_monoidal_functor V₁ V₂} (HF : ∏ (x : V₁), isweq (λ (f : I_{V₁} --> x), #F f)) : preserve_underlying F. Proof. use make_preserve_underlying. - exact (λ v f, invmap (make_weq _ (HF v)) (strong_functor_unit_inv F · f)). - split. + abstract (intros v f ; refine (maponpaths (λ z, _ · z) (homotweqinvweq (make_weq _ (HF v)) _) @ _) ; rewrite !assoc ; rewrite strong_functor_unit_unit_inv ; apply id_left). + abstract (intros v f ; rewrite !assoc ; rewrite strong_functor_unit_inv_unit ; rewrite id_left ; apply (homotinvweqweq (make_weq _ (HF v)) _)). Defined. Definition strong_fully_faithful_to_preserve_underlying {V₁ V₂ : monoidal_cat} {F : strong_monoidal_functor V₁ V₂} (HF : fully_faithful F) : preserve_underlying F. Proof. use strong_fully_faithful_on_points_to_preserve_underlying. intro v. apply HF. Defined. Section ChangeOfBase. Context {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) (Fv : preserve_underlying F). (** 2. Change of base: enrichment for categories *) Section Enrichment. Context {C : category} (E : enrichment C V₁). Definition change_of_base_enrichment_data : enrichment_data C V₂. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, F (E ⦃ x , y ⦄)). - exact (λ x, mon_functor_unit F · #F (enriched_id E x)). - exact (λ x y z, mon_functor_tensor F _ _ · #F (enriched_comp E x y z)). - exact (λ x y f, mon_functor_unit F · #F (enriched_from_arr E f)). - exact (λ x y f, enriched_to_arr E (Fv _ f)). Defined. Definition change_of_base_enrichment_laws : enrichment_laws change_of_base_enrichment_data. Proof. repeat split. - intros x y ; cbn. refine (mon_functor_lunitor F (E ⦃ x, y ⦄) @ _). refine (!_). etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. exact (enrichment_id_left E x y). } rewrite functor_comp. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply tensor_mon_functor_tensor. } apply maponpaths_2. apply maponpaths. apply functor_id. - intros x y ; cbn. refine (mon_functor_runitor F (E ⦃ x, y ⦄) @ _). refine (!_). etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. exact (enrichment_id_right E x y). } rewrite functor_comp. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply tensor_mon_functor_tensor. } do 2 apply maponpaths_2. apply functor_id. - intros w x y z ; cbn. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (!_). apply functor_id. } apply (tensor_mon_functor_tensor F). } etrans. { rewrite !assoc. do 2 apply maponpaths_2. refine (!_). apply (mon_functor_lassociator F). } etrans. { rewrite !assoc'. do 2 apply maponpaths. rewrite <- !functor_comp. apply maponpaths. rewrite !assoc. refine (!_). apply enrichment_assoc. } refine (!_). etrans. { etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply functor_id. } apply (tensor_mon_functor_tensor F). } rewrite !assoc'. rewrite <- functor_comp. apply idpath. } apply idpath. - intros x y f ; cbn. refine (_ @ enriched_to_from_arr E f). apply maponpaths. apply preserve_underlying_left_inv. - intros x y f ; cbn. rewrite enriched_from_to_arr. apply preserve_underlying_right_inv. - intros x ; cbn. refine (_ @ enriched_to_arr_id E _). apply maponpaths. apply preserve_underlying_left_inv. - intros x y z f g ; cbn. refine (enriched_to_arr_comp E f g @ _). apply maponpaths. refine (!_). rewrite tensor_comp_l_id_l. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite tensor_comp_r_id_l. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite tensor_mon_functor_tensor. rewrite !assoc'. rewrite <- functor_comp. apply idpath. } rewrite !assoc. rewrite <- mon_functor_linvunitor. rewrite <- functor_comp. apply idpath. } rewrite preserve_underlying_left_inv. apply idpath. Qed. Definition change_of_base_enrichment : enrichment C V₂. Proof. simple refine (_ ,, _). - exact change_of_base_enrichment_data. - exact change_of_base_enrichment_laws. Defined. End Enrichment. (** 3. Change of base: enrichment for functors *) Section EnrichmentFunctor. Context {C₁ C₂ : category} {H : C₁ ⟶ C₂} {E₁ : enrichment C₁ V₁} {E₂ : enrichment C₂ V₁} (HE : functor_enrichment H E₁ E₂). Definition change_of_base_functor_enrichment_laws : @is_functor_enrichment _ _ _ H (change_of_base_enrichment E₁) (change_of_base_enrichment E₂) (λ x y : C₁, # F (HE x y)). Proof. repeat split. - intros x ; cbn. rewrite !assoc'. rewrite <- functor_comp. do 2 apply maponpaths. apply functor_enrichment_id. - intros x y z ; cbn. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. apply (tensor_mon_functor_tensor F). } rewrite !assoc'. rewrite <- !functor_comp. do 2 apply maponpaths. refine (!_). apply functor_enrichment_comp. - intros x y f ; cbn. rewrite !assoc'. rewrite <- (functor_comp F). do 2 apply maponpaths. apply functor_enrichment_from_arr. Qed. Definition change_of_base_functor_enrichment : functor_enrichment H (change_of_base_enrichment E₁) (change_of_base_enrichment E₂). Proof. simple refine (_ ,, _). - exact (λ x y, #F (HE x y)). - exact change_of_base_functor_enrichment_laws. Defined. End EnrichmentFunctor. (** 4. Change of base: enrichment for natural transformations *) Definition change_of_base_nat_trans_enrichment {C₁ C₂ : category} {H₁ H₂ : C₁ ⟶ C₂} {τ : H₁ ⟹ H₂} {E₁ : enrichment C₁ V₁} {E₂ : enrichment C₂ V₁} {HE₁ : functor_enrichment H₁ E₁ E₂} {HE₂ : functor_enrichment H₂ E₁ E₂} (Hτ : nat_trans_enrichment τ HE₁ HE₂) : nat_trans_enrichment τ (change_of_base_functor_enrichment HE₁) (change_of_base_functor_enrichment HE₂). Proof. intros x y ; cbn. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_l_id_l. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply (tensor_mon_functor_tensor F). } rewrite !assoc'. rewrite <- functor_comp. apply idpath. } etrans. { rewrite !assoc. apply maponpaths_2. refine (!_). apply (mon_functor_rinvunitor F). } refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_r_id_l. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply (tensor_mon_functor_tensor F). } rewrite !assoc'. rewrite <- functor_comp. apply idpath. } etrans. { rewrite !assoc. apply maponpaths_2. refine (!_). apply (mon_functor_linvunitor F). } rewrite <- !functor_comp. apply maponpaths. rewrite !assoc. refine (!_). apply Hτ. Qed. (** 5. Change of base on the identity *) Definition change_of_base_enrichment_identity {C : univalent_category} (E : enrichment C V₁) : nat_trans_enrichment (λ _, identity _) (functor_id_enrichment (change_of_base_enrichment E)) (change_of_base_functor_enrichment (functor_id_enrichment E)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. rewrite <- enrichment_id_right. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. refine (!_). apply (mon_functor_runitor F). } rewrite mon_rinvunitor_runitor. refine (!_). etrans. { apply maponpaths. rewrite tensor_comp_r_id_l. rewrite !assoc'. apply maponpaths. rewrite <- !functor_id. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. rewrite <- enrichment_id_left. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. refine (!_). apply (mon_functor_lunitor F). } rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition change_of_base_enrichment_identity_inv {C : univalent_category} (E : enrichment C V₁) : nat_trans_enrichment (λ _, identity _) (change_of_base_functor_enrichment (functor_id_enrichment E)) (functor_id_enrichment (change_of_base_enrichment E)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- functor_id. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. rewrite <- enrichment_id_right. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. refine (!_). apply (mon_functor_runitor F). } rewrite mon_rinvunitor_runitor. refine (!_). etrans. { apply maponpaths. rewrite tensor_comp_r_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. rewrite <- enrichment_id_left. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. refine (!_). apply (mon_functor_lunitor F). } rewrite mon_linvunitor_lunitor. apply idpath. Qed. (** 6. Change of base on composition *) Definition change_of_base_enrichment_comp {C₁ C₂ C₃ : univalent_category} {G₁ : C₁ ⟶ C₂} {G₂ : C₂ ⟶ C₃} {E₁ : enrichment C₁ V₁} {E₂ : enrichment C₂ V₁} {E₃ : enrichment C₃ V₁} (EG₁ : functor_enrichment G₁ E₁ E₂) (EG₂ : functor_enrichment G₂ E₂ E₃) : nat_trans_enrichment (λ c, identity _) (functor_comp_enrichment (change_of_base_functor_enrichment EG₁) (change_of_base_functor_enrichment EG₂)) (change_of_base_functor_enrichment (functor_comp_enrichment EG₁ EG₂)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. do 2 apply maponpaths. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. apply idpath. } rewrite functor_comp. etrans. { apply maponpaths. rewrite !assoc. rewrite <- (mon_functor_runitor F). apply idpath. } rewrite !assoc. rewrite mon_rinvunitor_runitor. rewrite id_left. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite <- functor_comp. rewrite tensor_comp_r_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. do 2 apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply idpath. } rewrite functor_comp. etrans. { apply maponpaths. rewrite !assoc. rewrite <- (mon_functor_lunitor F). apply idpath. } rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Definition change_of_base_enrichment_comp_inv {C₁ C₂ C₃ : univalent_category} {G₁ : C₁ ⟶ C₂} {G₂ : C₂ ⟶ C₃} {E₁ : enrichment C₁ V₁} {E₂ : enrichment C₂ V₁} {E₃ : enrichment C₃ V₁} (EG₁ : functor_enrichment G₁ E₁ E₂) (EG₂ : functor_enrichment G₂ E₂ E₃) : nat_trans_enrichment (λ c, identity _) (change_of_base_functor_enrichment (functor_comp_enrichment EG₁ EG₂)) (functor_comp_enrichment (change_of_base_functor_enrichment EG₁) (change_of_base_functor_enrichment EG₂)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite !assoc'. etrans. { apply maponpaths. rewrite <- functor_comp. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. do 2 apply maponpaths. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. apply idpath. } rewrite functor_comp. etrans. { apply maponpaths. rewrite !assoc. rewrite <- (mon_functor_runitor F). apply idpath. } rewrite !assoc. rewrite mon_rinvunitor_runitor. rewrite id_left. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_r_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite (tensor_mon_functor_tensor F). rewrite !assoc'. rewrite <- functor_comp. do 2 apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply idpath. } rewrite functor_comp. etrans. { apply maponpaths. rewrite !assoc. rewrite <- (mon_functor_lunitor F). apply idpath. } rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. End ChangeOfBase. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/DialgebraEnriched.v000066400000000000000000000715771451125700300274620ustar00rootroot00000000000000(********************************************************************** The enriched category of dialgebras We construct an enrichment over the category of dialgebras between two enriched functors. In addition, we show that this gives rise to inserters in the bicategory of enriched categories. Note that to construct this enrichment, we assume that the monoidal category `V` has equalizers. This is because morphisms in the category of dialgebras come with a requirement that a certain diagram commutes. As such, this requirement must also be present in the enrichment. To formulate this requirement, we use equalizers. Contents 1. The enrichment of dialgebras 2. Enrichment of the first projection 3. Enrichment of functors to dialgebras 4. Enrichment of natural transformations to dialgebras **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.limits.equalizers. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedDialgebras. Context (V : monoidal_cat) (EV : Equalizers V) {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (FE : functor_enrichment F E₁ E₂) (GE : functor_enrichment G E₁ E₂). (** 1. The enrichment of dialgebras *) Definition dialgebra_enrichment_mor_left {x y : C₁} (f : F x --> G x) (g : F y --> G y) : E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , G y ⦄ := GE x y · mon_rinvunitor _ · identity _ #⊗ enriched_from_arr E₂ f · enriched_comp _ _ _ _. Definition dialgebra_enrichment_mor_right {x y : C₁} (f : F x --> G x) (g : F y --> G y) : E₁ ⦃ x , y ⦄ --> E₂ ⦃ F x , G y ⦄ := FE x y · mon_linvunitor _ · enriched_from_arr E₂ g #⊗ identity _ · enriched_comp _ _ _ _. Definition dialgebra_enrichment_mor {x y : C₁} (f : F x --> G x) (g : F y --> G y) : V := EV _ _ (dialgebra_enrichment_mor_left f g) (dialgebra_enrichment_mor_right f g). Definition dialgebra_enrichment_mor_incl {x y : C₁} (f : F x --> G x) (g : F y --> G y) : dialgebra_enrichment_mor f g --> E₁ ⦃ x , y ⦄ := EqualizerArrow (EV _ _ (dialgebra_enrichment_mor_left f g) (dialgebra_enrichment_mor_right f g)). Definition dialgebra_enrichment_mor_incl_eq {x y : C₁} (f : F x --> G x) (g : F y --> G y) : dialgebra_enrichment_mor_incl f g · dialgebra_enrichment_mor_left f g = dialgebra_enrichment_mor_incl f g · dialgebra_enrichment_mor_right f g. Proof. exact (EqualizerEqAr (EV _ _ (dialgebra_enrichment_mor_left f g) (dialgebra_enrichment_mor_right f g))). Qed. Definition dialgebra_enrichment_mor_eq_of_mor {x y : C₁} (f : F x --> G x) (g : F y --> G y) {v : V} {φ₁ φ₂ : v --> dialgebra_enrichment_mor f g} (p : φ₁ · dialgebra_enrichment_mor_incl f g = φ₂ · dialgebra_enrichment_mor_incl f g) : φ₁ = φ₂. Proof. use (isEqualizerInsEq (pr22 (EV _ _ (dialgebra_enrichment_mor_left f g) (dialgebra_enrichment_mor_right f g)))). exact p. Qed. Definition dialgebra_enrichment_id_eq {x : C₁} (f : F x --> G x) : enriched_id E₁ x · dialgebra_enrichment_mor_left f f = enriched_id E₁ x · dialgebra_enrichment_mor_right f f. Proof. unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right. etrans. { apply maponpaths. do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left, id_right. rewrite !assoc. rewrite tensor_rinvunitor. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_linvunitor. apply idpath. } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left, id_right. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. rewrite mon_linvunitor_I_mon_rinvunitor_I. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). rewrite !id_left. rewrite (functor_enrichment_id FE). rewrite (functor_enrichment_id GE). rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite tensor_runitor. apply maponpaths_2. apply mon_lunitor_I_mon_runitor_I. Qed. Definition dialgebra_enrichment_id {x : C₁} (f : F x --> G x) : I_{V} --> dialgebra_enrichment_mor f f. Proof. use EqualizerIn. - exact (enriched_id E₁ x). - exact (dialgebra_enrichment_id_eq f). Defined. Definition dialgebra_enrichment_id_incl {x : C₁} (f : F x --> G x) : dialgebra_enrichment_id f · dialgebra_enrichment_mor_incl f f = enriched_id E₁ x. Proof. apply EqualizerCommutes. Qed. Definition dialgebra_enrichment_comp_mor {x y z : C₁} (f₁ : F x --> G x) (f₂ : F y --> G y) (f₃ : F z --> G z) : dialgebra_enrichment_mor f₂ f₃ ⊗ dialgebra_enrichment_mor f₁ f₂ --> E₁ ⦃ x, z ⦄ := dialgebra_enrichment_mor_incl f₂ f₃ #⊗ dialgebra_enrichment_mor_incl f₁ f₂ · enriched_comp _ _ _ _. Definition dialgebra_enrichment_comp_eq {x y z : C₁} (f₁ : F x --> G x) (f₂ : F y --> G y) (f₃ : F z --> G z) : dialgebra_enrichment_comp_mor f₁ f₂ f₃ · dialgebra_enrichment_mor_left f₁ f₃ = dialgebra_enrichment_comp_mor f₁ f₂ f₃ · dialgebra_enrichment_mor_right f₁ f₃. Proof. unfold dialgebra_enrichment_comp_mor. unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite (functor_enrichment_comp FE). rewrite (functor_enrichment_comp GE). rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. do 2 apply maponpaths_2. apply tensor_rinvunitor. } refine (!_). etrans. { apply maponpaths. do 2 apply maponpaths_2. apply tensor_linvunitor. } refine (!_). rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). etrans. { do 2 apply maponpaths. apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } refine (!_). etrans. { do 2 apply maponpaths. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. refine (!_). etrans. { do 3 apply maponpaths. apply enrichment_assoc. } refine (!_). etrans. { do 3 apply maponpaths. apply enrichment_assoc'. } rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). etrans. { do 2 apply maponpaths. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply tensor_id_id. } apply tensor_rassociator. } refine (!_). etrans. { do 2 apply maponpaths. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_id_id. } apply tensor_lassociator. } rewrite <- mon_rinvunitor_triangle. rewrite <- mon_linvunitor_triangle. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). etrans. { do 2 apply maponpaths. do 3 apply maponpaths_2. apply mon_rassociator_lassociator. } refine (!_). etrans. { do 2 apply maponpaths. do 3 apply maponpaths_2. apply mon_lassociator_rassociator. } rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_right. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_comp_mor. } etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_comp_mor. } etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite !id_right. etrans. { apply maponpaths_2. apply maponpaths. refine (_ @ dialgebra_enrichment_mor_incl_eq f₁ f₂). rewrite !assoc'. apply maponpaths. rewrite !assoc. apply idpath. } unfold dialgebra_enrichment_mor_right. refine (!_). etrans. { do 2 apply maponpaths_2. refine (_ @ !(dialgebra_enrichment_mor_incl_eq f₂ f₃)). rewrite !assoc'. apply maponpaths. rewrite !assoc. apply idpath. } unfold dialgebra_enrichment_mor_left. rewrite !tensor_comp_mor. rewrite !assoc'. apply maponpaths. rewrite tensor_comp_r_id_r. rewrite tensor_comp_l_id_r. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc. } rewrite !assoc. rewrite tensor_comp_l_id_r. do 2 apply maponpaths_2. rewrite tensor_comp_r_id_r. rewrite tensor_comp_l_id_r. rewrite !assoc'. etrans. { apply maponpaths. apply tensor_lassociator. } rewrite !assoc. apply maponpaths_2. refine (!_). apply mon_inv_triangle. Qed. Definition dialgebra_enrichment_comp {x y z : C₁} (f₁ : F x --> G x) (f₂ : F y --> G y) (f₃ : F z --> G z) : dialgebra_enrichment_mor f₂ f₃ ⊗ dialgebra_enrichment_mor f₁ f₂ --> dialgebra_enrichment_mor f₁ f₃. Proof. use EqualizerIn. - exact (dialgebra_enrichment_comp_mor f₁ f₂ f₃). - exact (dialgebra_enrichment_comp_eq f₁ f₂ f₃). Defined. Definition dialgebra_enrichment_comp_incl {x y z : C₁} (f₁ : F x --> G x) (f₂ : F y --> G y) (f₃ : F z --> G z) : dialgebra_enrichment_comp f₁ f₂ f₃ · dialgebra_enrichment_mor_incl f₁ f₃ = dialgebra_enrichment_comp_mor f₁ f₂ f₃. Proof. apply EqualizerCommutes. Qed. Definition dialgebra_enrichment_from_arr_eq {x y : C₁} {f : F x --> G x} {g : F y --> G y} (h : x --> y) (p : f · # G h = # F h · g) : enriched_from_arr E₁ h · dialgebra_enrichment_mor_left f g = enriched_from_arr E₁ h · dialgebra_enrichment_mor_right f g. Proof. unfold dialgebra_enrichment_mor_left, dialgebra_enrichment_mor_right. rewrite !assoc. rewrite tensor_rinvunitor. rewrite tensor_linvunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite !id_left, !id_right. rewrite <- (functor_enrichment_from_arr FE). rewrite <- (functor_enrichment_from_arr GE). use (invmaponpathsweq (_ ,, isweq_enriched_to_arr E₂ _ _)). cbn. rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite !assoc. rewrite <- !(enriched_to_arr_comp E₂). exact (!p). Qed. Definition dialgebra_enrichment_from_arr {x y : C₁} {f : F x --> G x} {g : F y --> G y} (h : x --> y) (p : f · # G h = # F h · g) : I_{V} --> dialgebra_enrichment_mor f g. Proof. use EqualizerIn. - exact (enriched_from_arr E₁ h). - exact (dialgebra_enrichment_from_arr_eq h p). Defined. Definition dialgebra_enrichment_from_arr_incl {x y : C₁} {f : F x --> G x} {g : F y --> G y} (h : x --> y) (p : f · # G h = # F h · g) : dialgebra_enrichment_from_arr h p · dialgebra_enrichment_mor_incl f g = enriched_from_arr E₁ h. Proof. apply EqualizerCommutes. Defined. Definition dialgebra_enrichment_to_arr_mor {x y : C₁} {f : F x --> G x} {g : F y --> G y} (h : I_{V} --> dialgebra_enrichment_mor f g) : x --> y := enriched_to_arr E₁ (h · dialgebra_enrichment_mor_incl _ _). Definition dialgebra_enrichment_to_arr_eq {x y : C₁} {f : F x --> G x} {g : F y --> G y} (h : I_{V} --> dialgebra_enrichment_mor f g) : f · # G (dialgebra_enrichment_to_arr_mor h) = # F (dialgebra_enrichment_to_arr_mor h) · g. Proof. unfold dialgebra_enrichment_to_arr_mor. use (invmaponpathsweq (_ ,, isweq_enriched_from_arr E₂ _ _)). cbn. rewrite !enriched_from_arr_comp. rewrite (functor_enrichment_from_arr FE). rewrite (functor_enrichment_from_arr GE). rewrite !enriched_from_to_arr. pose (dialgebra_enrichment_mor_incl_eq f g) as p. unfold dialgebra_enrichment_mor_left in p. unfold dialgebra_enrichment_mor_right in p. rewrite !assoc in p. rewrite tensor_rinvunitor in p. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. etrans. { apply maponpaths. apply maponpaths_2. apply tensor_comp_r_id_l. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. etrans. { apply maponpaths. refine (_ @ p). rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { refine (!_). apply tensor_comp_mor. } rewrite id_right, id_left. apply idpath. } clear p. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite mon_linvunitor_I_mon_rinvunitor_I. rewrite !assoc'. apply maponpaths. etrans. { refine (!_). apply tensor_comp_mor. } rewrite id_left, id_right. apply idpath. Qed. Definition dialgebra_enrichment_data : enrichment_data (dialgebra F G) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ f g, dialgebra_enrichment_mor (pr2 f) (pr2 g)). - exact (λ f, dialgebra_enrichment_id (pr2 f)). - exact (λ f₁ f₂ f₃, dialgebra_enrichment_comp (pr2 f₁) (pr2 f₂) (pr2 f₃)). - exact (λ f g τ, dialgebra_enrichment_from_arr (pr1 τ) (pr2 τ)). - refine (λ f g τ, dialgebra_enrichment_to_arr_mor τ ,, _). exact (dialgebra_enrichment_to_arr_eq τ). Defined. Definition dialgebra_enrichment_laws : enrichment_laws dialgebra_enrichment_data. Proof. repeat split. - intros f g. use dialgebra_enrichment_mor_eq_of_mor. cbn. rewrite !assoc'. rewrite dialgebra_enrichment_comp_incl. unfold dialgebra_enrichment_comp_mor. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left. rewrite dialgebra_enrichment_id_incl. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply idpath. - intros f g. use dialgebra_enrichment_mor_eq_of_mor. cbn. rewrite !assoc'. rewrite dialgebra_enrichment_comp_incl. unfold dialgebra_enrichment_comp_mor. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left. rewrite dialgebra_enrichment_id_incl. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. apply idpath. - intros w x y z. use dialgebra_enrichment_mor_eq_of_mor. cbn. rewrite !assoc'. rewrite !dialgebra_enrichment_comp_incl. unfold dialgebra_enrichment_comp_mor. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left. rewrite !dialgebra_enrichment_comp_incl. unfold dialgebra_enrichment_comp_mor. etrans. { apply maponpaths_2. apply tensor_comp_r_id_r. } rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _ @ tensor_comp_mor _ _ _ _). rewrite id_left, id_right. apply maponpaths. rewrite dialgebra_enrichment_comp_incl. apply idpath. - intros x y f. use subtypePath. { intro. apply homset_property. } cbn. unfold dialgebra_enrichment_to_arr_mor. rewrite dialgebra_enrichment_from_arr_incl. apply enriched_to_from_arr. - intros x y f. cbn. use dialgebra_enrichment_mor_eq_of_mor. rewrite dialgebra_enrichment_from_arr_incl. unfold dialgebra_enrichment_to_arr_mor. rewrite enriched_from_to_arr. apply idpath. - intros f. use subtypePath. { intro. apply homset_property. } cbn. unfold dialgebra_enrichment_to_arr_mor. rewrite dialgebra_enrichment_id_incl. rewrite enriched_to_arr_id. apply idpath. - intros x y z f g. use subtypePath. { intro. apply homset_property. } cbn. unfold dialgebra_enrichment_to_arr_mor. rewrite !assoc'. rewrite dialgebra_enrichment_comp_incl. etrans. { apply (enriched_to_arr_comp E₁ (pr1 f) (pr1 g)). } apply maponpaths. rewrite !assoc'. apply maponpaths. unfold dialgebra_enrichment_comp_mor. rewrite !assoc. apply maponpaths_2. refine (_ @ tensor_comp_mor _ _ _ _). rewrite !dialgebra_enrichment_from_arr_incl. apply idpath. Qed. Definition dialgebra_enrichment : enrichment (dialgebra F G) V. Proof. simple refine (_ ,, _). - exact dialgebra_enrichment_data. - exact dialgebra_enrichment_laws. Defined. (** 2. Enrichment of the first projection *) Definition dialgebra_pr1_enrichment : functor_enrichment (dialgebra_pr1 F G) dialgebra_enrichment E₁. Proof. simple refine (_ ,, _). - exact (λ f g, dialgebra_enrichment_mor_incl (pr2 f) (pr2 g)). - repeat split. + abstract (intro f ; cbn ; apply dialgebra_enrichment_id_incl). + abstract (intros x y z ; cbn ; apply dialgebra_enrichment_comp_incl). + abstract (intros x y f ; cbn ; refine (!_) ; apply dialgebra_enrichment_from_arr_incl). Defined. Definition dialgebra_nat_trans_enrichment : nat_trans_enrichment (dialgebra_nat_trans F G) (functor_comp_enrichment dialgebra_pr1_enrichment FE) (functor_comp_enrichment dialgebra_pr1_enrichment GE). Proof. intros f g ; cbn. unfold dialgebra_nat_trans_data. rewrite tensor_comp_r_id_l. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } pose (dialgebra_enrichment_mor_incl_eq (pr2 f) (pr2 g)) as p. refine (_ @ p @ _). - unfold dialgebra_enrichment_mor_left. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. apply maponpaths. refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left, id_right. apply idpath. - unfold dialgebra_enrichment_mor_right. refine (!_). rewrite tensor_comp_l_id_l. rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left, id_right. apply idpath. Qed. (** 3. Enrichment of functors to dialgebras *) Section FunctorToDialgebraEnrichment. Context {C₀ : category} {E₀ : enrichment C₀ V} {K : C₀ ⟶ C₁} {EK : functor_enrichment K E₀ E₁} (τ : K ∙ F ⟹ K ∙ G) (Eτ : nat_trans_enrichment τ (functor_comp_enrichment EK FE) (functor_comp_enrichment EK GE)). Definition nat_trans_to_dialgebra_enrichment_mor_eq (x y : C₀) : EK x y · dialgebra_enrichment_mor_left (τ x) (τ y) = EK x y · dialgebra_enrichment_mor_right (τ x) (τ y). Proof. unfold dialgebra_enrichment_mor_left. unfold dialgebra_enrichment_mor_right. rewrite !assoc. rewrite tensor_rinvunitor. rewrite tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). rewrite !id_left, !id_right. rewrite !assoc. exact (Eτ x y). Qed. Definition nat_trans_to_dialgebra_enrichment_mor (x y : C₀) : E₀ ⦃ x , y ⦄ --> dialgebra_enrichment_mor (τ x) (τ y). Proof. use EqualizerIn. - exact (EK x y). - exact (nat_trans_to_dialgebra_enrichment_mor_eq x y). Defined. Definition nat_trans_to_dialgebra_enrichment_mor_incl (x y : C₀) : nat_trans_to_dialgebra_enrichment_mor x y · dialgebra_enrichment_mor_incl (τ x) (τ y) = EK x y. Proof. apply EqualizerCommutes. Qed. Definition nat_trans_to_dialgebra_enrichment : functor_enrichment (nat_trans_to_dialgebra K τ) E₀ dialgebra_enrichment. Proof. simple refine (_ ,, _). - exact nat_trans_to_dialgebra_enrichment_mor. - repeat split. + abstract (intros x ; use dialgebra_enrichment_mor_eq_of_mor ; cbn ; rewrite !assoc' ; rewrite nat_trans_to_dialgebra_enrichment_mor_incl ; rewrite dialgebra_enrichment_id_incl ; apply (functor_enrichment_id EK)). + abstract (intros x y z ; use dialgebra_enrichment_mor_eq_of_mor ; cbn ; rewrite !assoc' ; rewrite nat_trans_to_dialgebra_enrichment_mor_incl ; rewrite dialgebra_enrichment_comp_incl ; refine (functor_enrichment_comp EK x y z @ _) ; unfold dialgebra_enrichment_comp_mor ; rewrite !assoc ; apply maponpaths_2 ; refine (_ @ tensor_comp_mor _ _ _ _) ; rewrite !nat_trans_to_dialgebra_enrichment_mor_incl ; apply idpath). + abstract (intros x y f ; use dialgebra_enrichment_mor_eq_of_mor ; cbn ; rewrite !assoc' ; rewrite nat_trans_to_dialgebra_enrichment_mor_incl ; rewrite dialgebra_enrichment_from_arr_incl ; apply (functor_enrichment_from_arr EK)). Defined. Definition nat_trans_to_dialgebra_pr1_enrichment : nat_trans_enrichment (nat_trans_to_dialgebra_pr1 K τ) (functor_comp_enrichment nat_trans_to_dialgebra_enrichment dialgebra_pr1_enrichment) EK. Proof. intros x y ; cbn. rewrite nat_trans_to_dialgebra_enrichment_mor_incl. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. } refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. Qed. Definition nat_trans_to_dialgebra_pr1_enrichment_inv : nat_trans_enrichment (nat_z_iso_inv (nat_trans_to_dialgebra_pr1_nat_z_iso K τ)) EK (functor_comp_enrichment nat_trans_to_dialgebra_enrichment dialgebra_pr1_enrichment). Proof. intros x y ; cbn. rewrite nat_trans_to_dialgebra_enrichment_mor_incl. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. } refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. Qed. End FunctorToDialgebraEnrichment. (** 4. Enrichment of natural transformations to dialgebras *) Definition build_nat_trans_to_dialgebra_enrichment {C₀ : category} {E₀ : enrichment C₀ V} {H₁ H₂ : C₀ ⟶ dialgebra F G} {EH₁ : functor_enrichment H₁ E₀ dialgebra_enrichment} {EH₂ : functor_enrichment H₂ E₀ dialgebra_enrichment} {τ : H₁ ∙ dialgebra_pr1 F G ⟹ H₂ ∙ dialgebra_pr1 F G} (Eτ : nat_trans_enrichment τ (functor_comp_enrichment EH₁ dialgebra_pr1_enrichment) (functor_comp_enrichment EH₂ dialgebra_pr1_enrichment)) (p : ∏ (x : C₀), pr2 (H₁ x) · # G (τ x) = # F (τ x) · pr2 (H₂ x)) : nat_trans_enrichment (build_nat_trans_to_dialgebra _ _ τ p) EH₁ EH₂. Proof. intros x y ; cbn. use dialgebra_enrichment_mor_eq_of_mor. rewrite !assoc'. rewrite !dialgebra_enrichment_comp_incl. unfold dialgebra_enrichment_comp_mor. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). rewrite !dialgebra_enrichment_from_arr_incl. rewrite !assoc. exact (Eτ x y). Qed. End EnrichedDialgebras. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/EilenbergMooreEnriched.v000066400000000000000000000272651451125700300305010ustar00rootroot00000000000000(********************************************************************** The enriched Eilenberg-Moore category In this file, we construct an enrichment for the Eilenberg-Moore category. To do so, we make use of the fact that we already constructed enrichments for the full subcategory and for the category of dialgebras. In addition, we construct the relevant functors and natural transformation to prove the universal property. Contents 1. The enrichment of the Eilenberg-Moore category 2. The cone 3. The universal property **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Local Open Scope moncat. Section EnrichedEilenbergMoore. Context {V : monoidal_cat} (HV : Equalizers V) {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M). (** 1. The enrichment of the Eilenberg-Moore category *) Definition eilenberg_moore_enrichment : enrichment (eilenberg_moore_cat M) V. Proof. use fullsub_enrichment. use (dialgebra_enrichment _ HV). - exact E. - exact E. - exact EM. - exact (functor_id_enrichment E). Defined. (** 2. The cone *) Definition eilenberg_moore_pr_enrichment : functor_enrichment (eilenberg_moore_pr M) eilenberg_moore_enrichment E. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (λ x y, dialgebra_pr1_enrichment V HV _ _ (pr1 x) (pr1 y)). - abstract (intros x ; cbn ; apply dialgebra_enrichment_id_incl). - abstract (intros x y z ; cbn ; apply dialgebra_enrichment_comp_incl). - abstract (intros x y f ; cbn ; refine (!_) ; apply dialgebra_enrichment_from_arr_incl). Defined. Definition eilenberg_moore_nat_trans_enrichment : nat_trans_enrichment (eilenberg_moore_nat_trans M) (functor_comp_enrichment eilenberg_moore_pr_enrichment EM) (functor_comp_enrichment (functor_id_enrichment _) eilenberg_moore_pr_enrichment). Proof. intros x y. pose (dialgebra_nat_trans_enrichment V HV EM (functor_id_enrichment _) (pr1 x) (pr1 y)). refine (_ @ p). apply maponpaths_2. apply maponpaths. cbn. rewrite id_left, id_right. apply idpath. Qed. (** 3. The universal property *) Section EilenbergMooreUMP1. Context {C' : category} {E' : enrichment C' V} {F : C' ⟶ C} (FE : functor_enrichment F E' E) (τ : F ∙ M ⟹ functor_identity _ ∙ F) (Eτ : nat_trans_enrichment τ (functor_comp_enrichment FE EM) (functor_comp_enrichment (functor_id_enrichment _) FE)) (τη : ∏ (x : C'), η M (F x) · τ x = identity _) (τμ : ∏ (x : C'), # M (τ x) · τ x = μ M (F x) · τ x). Definition functor_to_em_enrichment_mor_eq (x y : C') : FE x y · dialgebra_enrichment_mor_left V (functor_id_enrichment E) (τ x) (τ y) = FE x y · @dialgebra_enrichment_mor_right _ _ _ _ (functor_identity C) _ _ EM (F x) (F y) (τ x) (τ y). Proof. unfold dialgebra_enrichment_mor_left. unfold dialgebra_enrichment_mor_right. rewrite !assoc. rewrite tensor_rinvunitor. rewrite tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). rewrite !id_left, !id_right. rewrite !assoc. pose (p := Eτ x y). cbn in p. rewrite id_left in p. exact p. Qed. Definition functor_to_em_enrichment_mor (x y : C') : E' ⦃ x , y ⦄ --> dialgebra_enrichment_mor V HV EM (functor_id_enrichment E) (τ x) (τ y). Proof. use EqualizerIn. - exact (FE x y). - exact (functor_to_em_enrichment_mor_eq x y). Defined. Definition functor_to_em_enrichment_mor_incl (x y : C') : functor_to_em_enrichment_mor x y · dialgebra_enrichment_mor_incl _ _ _ _ _ _ = FE x y. Proof. apply EqualizerCommutes. Qed. Definition functor_to_eilenberg_moore_cat_enrichment : functor_enrichment (functor_to_eilenberg_moore_cat M F τ τη τμ) E' eilenberg_moore_enrichment. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact functor_to_em_enrichment_mor. - abstract (intros x ; use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment _)) ; cbn ; rewrite !assoc' ; rewrite functor_to_em_enrichment_mor_incl ; refine (_ @ !(dialgebra_enrichment_id_incl _ _ _ _ _)) ; apply (functor_enrichment_id FE)). - abstract (intros x y z ; use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment _)) ; cbn ; rewrite !assoc' ; rewrite functor_to_em_enrichment_mor_incl ; rewrite dialgebra_enrichment_comp_incl ; refine (functor_enrichment_comp FE x y z @ _) ; unfold dialgebra_enrichment_comp_mor ; rewrite !assoc ; apply maponpaths_2 ; refine (_ @ tensor_comp_mor _ _ _ _) ; rewrite !functor_to_em_enrichment_mor_incl ; apply idpath). - abstract (intros x y f ; use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment _)) ; cbn ; rewrite !assoc' ; rewrite functor_to_em_enrichment_mor_incl ; refine (dialgebra_enrichment_from_arr_incl _ _ _ _ _ _ @ _) ; apply (functor_enrichment_from_arr FE)). Defined. Definition functor_to_eilenberg_moore_cat_pr_enrichment : nat_trans_enrichment (functor_to_eilenberg_moore_cat_pr M F τ τη τμ) (functor_comp_enrichment functor_to_eilenberg_moore_cat_enrichment eilenberg_moore_pr_enrichment) FE. Proof. intros x y ; cbn. rewrite functor_to_em_enrichment_mor_incl. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. } refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. Qed. Definition functor_to_eilenberg_moore_cat_pr_enrichment_inv : nat_trans_enrichment (nat_z_iso_inv (functor_to_eilenberg_moore_cat_pr_nat_z_iso M F τ τη τμ)) FE (functor_comp_enrichment functor_to_eilenberg_moore_cat_enrichment eilenberg_moore_pr_enrichment). Proof. intros x y ; cbn. rewrite functor_to_em_enrichment_mor_incl. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. } refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. Qed. End EilenbergMooreUMP1. Definition nat_trans_to_eilenberg_moore_cat_enrichment {C' : category} (E' : enrichment C' V) {F₁ F₂ : C' ⟶ eilenberg_moore_cat M} {FE₁ : functor_enrichment F₁ E' eilenberg_moore_enrichment} {FE₂ : functor_enrichment F₂ E' eilenberg_moore_enrichment} (τ : F₁ ∙ eilenberg_moore_pr M ⟹ F₂ ∙ eilenberg_moore_pr M) (Eτ : nat_trans_enrichment τ (functor_comp_enrichment FE₁ eilenberg_moore_pr_enrichment) (functor_comp_enrichment FE₂ eilenberg_moore_pr_enrichment)) (p : ∏ (x : C'), mor_of_eilenberg_moore_ob (F₁ x) · τ x = # M (τ x) · mor_of_eilenberg_moore_ob (F₂ x)) : nat_trans_enrichment (nat_trans_to_eilenberg_moore_cat M F₁ F₂ τ p) FE₁ FE₂. Proof. intros x y ; cbn. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment _)). rewrite !assoc'. etrans. { do 2 apply maponpaths. apply dialgebra_enrichment_comp_incl. } unfold dialgebra_enrichment_comp_mor. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } refine (!_). etrans. { rewrite !assoc'. do 2 apply maponpaths. apply dialgebra_enrichment_comp_incl. } unfold dialgebra_enrichment_comp_mor. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } etrans. { apply maponpaths. do 2 apply maponpaths_2. apply dialgebra_enrichment_from_arr_incl. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply dialgebra_enrichment_from_arr_incl. } rewrite !assoc. exact (Eτ x y). Qed. End EnrichedEilenbergMoore. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/EmptyEnriched.v000066400000000000000000000104271451125700300266710ustar00rootroot00000000000000(********************************************************************** The empty enriched category In this file, we define the empty enriched categories, which is the enriched categories without any objects. In addition, we provide the necessary functors and natural transformations in order to prove that it is a strict biinitial object in the bicategory of enriched categories. Contents 1. The empty enriched category 2. Functors from the empty enriched category 3. Natural transformations involving the empty enriched category **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. Section EnrichedEmpty. Context (V : monoidal_cat). (** 1. The empty enriched category *) Definition empty_category_enrichment_data : enrichment_data empty_category V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x, fromempty x). - exact (λ x, fromempty x). - exact (λ x, fromempty x). - exact (λ x, fromempty x). - exact (λ x, fromempty x). Defined. Definition empty_category_enrichment : enrichment empty_category V. Proof. simple refine (_ ,, _). - exact empty_category_enrichment_data. - abstract (repeat split ; intro x ; induction x). Defined. (** 2. Functors from the empty enriched category *) Definition functor_from_empty_enrichment {C : category} (E : enrichment C V) : functor_enrichment (functor_from_empty C) empty_category_enrichment E. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (λ x, fromempty x). - abstract (intro x ; induction x). - abstract (intro x ; induction x). - abstract (intro x ; induction x). Defined. (** 3. Natural transformations involving the empty enriched category *) Definition nat_trans_from_empty_enrichment {C : category} {E : enrichment C V} {F G : empty_category ⟶ C} (FE : functor_enrichment F empty_category_enrichment E) (GE : functor_enrichment G empty_category_enrichment E) : nat_trans_enrichment (nat_trans_from_empty F G) FE GE. Proof. intro x. induction x. Qed. Definition nat_trans_to_empty_enrichment {C₁ C₂ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {F : C₁ ⟶ empty_category} (EF : functor_enrichment F E₁ empty_category_enrichment) {G : empty_category ⟶ C₂} (EG : functor_enrichment G empty_category_enrichment E₂) {H : C₁ ⟶ C₂} (EH : functor_enrichment H E₁ E₂) : nat_trans_enrichment (nat_trans_to_empty F G H) EH (functor_comp_enrichment EF EG). Proof. intros x. induction (F x). Qed. Definition nat_trans_to_empty_inv_enrichment {C₁ C₂ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {F : C₁ ⟶ empty_category} (EF : functor_enrichment F E₁ empty_category_enrichment) {G : empty_category ⟶ C₂} (EG : functor_enrichment G empty_category_enrichment E₂) {H : C₁ ⟶ C₂} (EH : functor_enrichment H E₁ E₂) : nat_trans_enrichment (nat_z_iso_inv (make_nat_z_iso _ _ _ (nat_trans_to_empty_is_nat_z_iso F G H))) (functor_comp_enrichment EF EG) EH. Proof. intros x. induction (F x). Qed. End EnrichedEmpty. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/FullSubEnriched.v000066400000000000000000000066541451125700300271560ustar00rootroot00000000000000(********************************************************************** The full subcategory of enriched category We show that the full subcategory of an enriched category is again enriched over the same monoidal category. We also show that the inclusion is an enriched functor. Contents 1. The enrichment over the full subcategory 2. The enrichment of the inclusion **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. Section FullSub. Context (V : monoidal_cat) {C : category} (E : enrichment C V) (P : C → hProp). (** 1. The enrichment over the full subcategory *) Definition fullsub_enrichment_data : enrichment_data (subcategory C (full_sub_precategory P)) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, E ⦃ pr1 x , pr1 y ⦄). - exact (λ x, enriched_id E (pr1 x)). - exact (λ x y z, enriched_comp E (pr1 x) (pr1 y) (pr1 z)). - exact (λ x y f, enriched_from_arr E (pr1 f)). - exact (λ x y f, enriched_to_arr E f ,, tt). Defined. Definition fullsub_enrichment_laws : enrichment_laws fullsub_enrichment_data. Proof. repeat split ; intros ; cbn. - apply enrichment_id_left. - apply enrichment_id_right. - apply enrichment_assoc. - use subtypePath. { intro. apply isapropunit. } apply enriched_to_from_arr. - apply enriched_from_to_arr. - use subtypePath. { intro. apply isapropunit. } apply enriched_to_arr_id. - use subtypePath. { intro. apply isapropunit. } apply enriched_to_arr_comp. Qed. Definition fullsub_enrichment : enrichment (subcategory C (full_sub_precategory P)) V. Proof. simple refine (_ ,, _). - exact fullsub_enrichment_data. - exact fullsub_enrichment_laws. Defined. (** 2. The enrichment of the inclusion *) Definition fullsub_inclusion_enrichment : functor_enrichment (sub_precategory_inclusion _ _) fullsub_enrichment E. Proof. simple refine (_ ,, _). - exact (λ x y, identity _). - repeat split. + abstract (cbn ; intro x ; apply id_right). + abstract (cbn ; intros x y z ; rewrite id_right ; rewrite tensor_id_id ; rewrite id_left ; apply idpath). + abstract (cbn ; intros x y f ; rewrite id_right ; apply idpath). Defined. Definition fullsub_inclusion_enrichment_fully_faithful : fully_faithful_enriched_functor fullsub_inclusion_enrichment. Proof. intros x y. apply is_z_isomorphism_identity. Defined. End FullSub. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/FunctorCategory.v000066400000000000000000000720471451125700300272550ustar00rootroot00000000000000(********************************************************************** The category of enriched functors We define the category of enriched functors and prove that it gives rise to a univalent category. To do so, we use displayed categories. The objects of this category are enriched functors and the morphisms are enriched natural transformations. In addition, we show that there is an enrichment over the functor category if the category over which we enriched is a complete monoidal closed category. To construct this enrichment, we must encode the type of enriched natural transformations as an object in the monoidal category `V`. The idea behind this encoding is as follows: first of all, an enriched transformation consists of a family of morphisms. We encode this by taking a suitable product (we call it `P₁` below). Second of all, an enriched transformation satisfies a commutativity condition. We encode this by taking a suitable equalizer: this means that we look at those families of morphisms such that a certain square commutes. We do so by first defining the product `P₂` (note that we take a product over pairs of objects in `C₁`). As such, we must construct two morphisms from `P₁` to `P₂`. Each of these represents one side of the naturality square. It is important to note that in the definition of `P₂`, we make use of the fact that the monoidal category `V` is closed. The encoded condition relates to the usual condition of V-naturality by adjointness. One might think that one could also use ends (as defined in Limits.Ends) to construct the required object. However, this is not the case. If one would do so, then only gets natural transformations that ar not necessarily enriched. This would thus not give the right morphisms in the category. Contents 1. The category of enriched functors 2. This category is univalent 3. The enrichment 4. Enrichment for presheaf categories **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.HomFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedFunctorCategory. Context {V : monoidal_cat} {C₁ C₂ : category} (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V). Definition functor_enrichment_disp_cat_ob_mor : disp_cat_ob_mor [C₁ , C₂]. Proof. simple refine (_ ,, _). - exact (λ F, functor_enrichment F E₁ E₂). - exact (λ F₁ F₂ FE₁ FE₂ α, nat_trans_enrichment (pr1 α) FE₁ FE₂). Defined. Definition functor_enrichment_disp_cat_id_comp : disp_cat_id_comp [C₁, C₂] functor_enrichment_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ F FE, id_trans_enrichment FE). - exact (λ F₁ F₂ F₃ τ θ FE₁ FE₂ FE₃ τE θE, comp_trans_enrichment τE θE). Defined. Definition functor_enrichment_disp_cat_data : disp_cat_data [C₁ , C₂]. Proof. simple refine (_ ,, _). - exact functor_enrichment_disp_cat_ob_mor. - exact functor_enrichment_disp_cat_id_comp. Defined. Definition functor_enrichment_disp_cat : disp_cat [C₁ , C₂]. Proof. simple refine (_ ,, _). - exact functor_enrichment_disp_cat_data. - abstract (repeat split ; intro ; intros ; try (apply isaprop_nat_trans_enrichment) ; apply isasetaprop ; apply isaprop_nat_trans_enrichment). Defined. Definition is_univalent_disp_functor_enrichment_disp_cat : is_univalent_disp functor_enrichment_disp_cat. Proof. use is_univalent_disp_from_fibers. intros F FE₁ FE₂. use isweqimplimpl. - cbn in * ; intro τ. use subtypePath. { intro. apply isaprop_is_functor_enrichment. } use funextsec ; intro x. use funextsec ; intro y. pose (p := pr1 τ x y). cbn in p. rewrite !enriched_from_arr_id in p. refine (_ @ !p @ _) ; clear p. + rewrite <- !(functor_enrichment_id FE₁). rewrite (tensor_comp_r_id_l _ _ (FE₁ x y)). rewrite !assoc'. rewrite <- (functor_enrichment_comp FE₁). rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). exact (enrichment_id_left E₁ x y). } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. + rewrite <- !(functor_enrichment_id FE₂). rewrite (tensor_comp_l_id_l (FE₂ x y)). rewrite !assoc'. rewrite <- (functor_enrichment_comp FE₂). rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). exact (enrichment_id_right E₁ x y). } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. - apply isaset_functor_enrichment. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply isaprop_nat_trans_enrichment. Qed. (** 1. The category of enriched functors *) Definition enriched_functor_category : category := total_category functor_enrichment_disp_cat. (** 2. This category is univalent *) Definition is_univalent_enriched_functor_cat (HC₂ : is_univalent C₂) : is_univalent enriched_functor_category. Proof. use is_univalent_total_category. - use is_univalent_functor_category. exact HC₂. - exact is_univalent_disp_functor_enrichment_disp_cat. Defined. End EnrichedFunctorCategory. Definition enriched_univalent_functor_category {V : monoidal_cat} (C₁ C₂ : univalent_category) (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) : univalent_category := enriched_functor_category E₁ E₂ ,, is_univalent_enriched_functor_cat _ _ (pr2 C₂). (** 3. The enrichment *) Section EnrichedFunctorCategory. Context {V : sym_mon_closed_cat} {C₁ C₂ : category} (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V) (EqV : Equalizers V) (PV : Products C₁ V) (PV' : Products (C₁ × C₁) V). Definition hom_functor_on_functors (F G : C₁ ⟶ C₂) : category_binproduct (C₁^opp) C₁ ⟶ V := pair_functor (functor_op F) G ∙ enriched_hom_functor E₂. Section FunctorEnrichmentConstruction. Context {F G : C₁ ⟶ C₂} (EF : functor_enrichment F E₁ E₂) (EG : functor_enrichment G E₁ E₂). Let P₁ : Product C₁ V (λ x, E₂ ⦃ F x, G x ⦄) := PV (λ x, E₂ ⦃ F x , G x ⦄). Let P₂ : Product (C₁ × C₁) V (λ xy, (E₁ ⦃ pr1 xy, pr2 xy ⦄) ⊸ (E₂ ⦃ F (pr1 xy), G (pr2 xy) ⦄)) := PV' (λ xy, E₁ ⦃ pr1 xy , pr2 xy ⦄ ⊸ (E₂ ⦃ F (pr1 xy) , G (pr2 xy) ⦄)). Definition enriched_functor_left_map_ob (x y : C₁) : E₂ ⦃ F x , G x ⦄ --> (E₁ ⦃ x, y ⦄) ⊸ (E₂ ⦃ F x , G y ⦄). Proof. use internal_lam. exact (sym_mon_braiding _ _ _ · (EG _ _ #⊗ identity _) · enriched_comp _ _ _ _). Defined. Let σ : ∏ (x y : C₁), E₂ ⦃ F x , G x ⦄ --> (E₁ ⦃ x, y ⦄) ⊸ (E₂ ⦃ F x , G y ⦄) := enriched_functor_left_map_ob. Definition enriched_functor_right_map_ob (x y : C₁) : E₂ ⦃ F y , G y ⦄ --> (E₁ ⦃ x, y ⦄) ⊸ (E₂ ⦃ F x , G y ⦄). Proof. use internal_lam. exact ((identity _ #⊗ EF _ _) · enriched_comp _ _ _ _). Defined. Let ρ : ∏ (x y : C₁), E₂ ⦃ F y , G y ⦄ --> (E₁ ⦃ x, y ⦄) ⊸ (E₂ ⦃ F x , G y ⦄) := enriched_functor_right_map_ob. Definition enriched_functor_left_map : P₁ --> P₂. Proof. use ProductArrow. exact (λ xy, ProductPr _ _ _ (pr1 xy) · σ (pr1 xy) (pr2 xy)). Defined. Definition enriched_functor_right_map : P₁ --> P₂. Proof. use ProductArrow. exact (λ xy, ProductPr _ _ _ (pr2 xy) · ρ (pr1 xy) (pr2 xy)). Defined. Definition enriched_functor_hom : Equalizer enriched_functor_left_map enriched_functor_right_map := EqV _ _ enriched_functor_left_map enriched_functor_right_map. Definition enriched_functor_hom_pr (i : C₁) : enriched_functor_hom --> E₂ ⦃ F i, G i ⦄ := EqualizerArrow _ · ProductPr _ _ _ i. Definition enriched_functor_hom_eq (i j : C₁) : enriched_functor_hom_pr i · σ i j = enriched_functor_hom_pr j · ρ i j. Proof. pose (maponpaths (λ z, z · ProductPr _ _ _ (i ,, j)) (EqualizerEqAr enriched_functor_hom)) as p. cbn in p. unfold enriched_functor_left_map in p. unfold enriched_functor_right_map in p. rewrite !assoc' in p. rewrite !(ProductPrCommutes _ _ _ P₂ _ _ (i ,, j)) in p. rewrite !assoc in p. exact p. Qed. Definition enriched_functor_hom_eq' (x y : C₁) : sym_mon_braiding V _ _ · (EG x y #⊗ enriched_functor_hom_pr x · enriched_comp E₂ (F x) (G x) (G y)) = enriched_functor_hom_pr y #⊗ EF x y · enriched_comp E₂ (F x) (F y) (G y). Proof. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (enriched_functor_hom_eq x y)) as p. cbn in p. rewrite !tensor_comp_r_id_r in p. unfold σ, ρ in p. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob in p. rewrite !assoc' in p. rewrite !internal_beta in p. rewrite !assoc in p. rewrite tensor_sym_mon_braiding in p. rewrite <- tensor_split' in p. rewrite !assoc' in p. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) in p. rewrite <- tensor_split in p. exact p. Qed. Definition mor_to_enriched_functor_hom {v : V} (fv : ∏ (i : C₁) , v --> E₂ ⦃ F i, G i ⦄) (p : ∏ (x y : C₁), fv x · σ x y = fv y · ρ x y) : v --> enriched_functor_hom. Proof. use EqualizerIn. - use ProductArrow. exact fv. - abstract (use ProductArrow_eq ; intros xy ; unfold enriched_functor_left_map ; unfold enriched_functor_right_map ; rewrite !assoc' ; rewrite !(ProductPrCommutes _ _ _ P₂) ; rewrite !assoc ; rewrite !(ProductPrCommutes _ _ _ P₁) ; apply p). Defined. Proposition mor_to_enriched_functor_hom_pr {v : V} (fv : ∏ (i : C₁) , v --> E₂ ⦃ F i, G i ⦄) (p : ∏ (x y : C₁), fv x · σ x y = fv y · ρ x y) (i : C₁) : mor_to_enriched_functor_hom fv p · enriched_functor_hom_pr i = fv i. Proof. unfold mor_to_enriched_functor_hom, enriched_functor_hom_pr. rewrite !assoc. rewrite EqualizerCommutes. apply (ProductPrCommutes _ _ _ P₁). Qed. Definition mor_to_enriched_functor_unique {v : V} (f g : v --> enriched_functor_hom) (p : ∏ (x : C₁), f · enriched_functor_hom_pr x = g · enriched_functor_hom_pr x) : f = g. Proof. use EqualizerInsEq. use ProductArrow_eq. intro x. rewrite !assoc'. exact (p x). Defined. End FunctorEnrichmentConstruction. Section EnrichmentIdentity. Context {F : C₁ ⟶ C₂} (EF : functor_enrichment F E₁ E₂). Proposition enriched_functor_hom_id_eq (x y : C₁) : enriched_id E₂ (F x) · enriched_functor_left_map_ob EF x y = enriched_id E₂ (F y) · enriched_functor_right_map_ob EF x y. Proof. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob. rewrite !assoc'. rewrite !internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. apply idpath. } refine (!_). etrans. { rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. apply idpath. } rewrite tensor_lunitor. rewrite tensor_runitor. rewrite !assoc. do 2 apply maponpaths_2. rewrite sym_mon_braiding_runitor. apply idpath. Qed. Definition enriched_functor_hom_id : I_{V} --> enriched_functor_hom EF EF. Proof. use mor_to_enriched_functor_hom. - exact (λ x, enriched_id E₂ (F x)). - exact enriched_functor_hom_id_eq. Defined. Proposition enriched_functor_hom_id_comm (x : C₁) : enriched_functor_hom_id · enriched_functor_hom_pr EF EF x = enriched_id E₂ (F x). Proof. exact (mor_to_enriched_functor_hom_pr EF EF _ _ x). Qed. End EnrichmentIdentity. Section EnrichmentComp. Context {F G H : C₁ ⟶ C₂} (EF : functor_enrichment F E₁ E₂) (EG : functor_enrichment G E₁ E₂) (EH : functor_enrichment H E₁ E₂). Definition enriched_functor_hom_comp_data (x : C₁) : enriched_functor_hom EG EH ⊗ enriched_functor_hom EF EG --> E₂ ⦃ F x , H x ⦄ := enriched_functor_hom_pr EG EH x #⊗ enriched_functor_hom_pr EF EG x · enriched_comp _ _ _ _. Proposition enriched_functor_hom_comp_laws (x y : C₁) : enriched_functor_hom_comp_data x · enriched_functor_left_map_ob EH x y = enriched_functor_hom_comp_data y · enriched_functor_right_map_ob EF x y. Proof. unfold enriched_functor_hom_comp_data. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob. rewrite !assoc'. rewrite !internal_beta. etrans. { etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_split. rewrite tensor_split'. rewrite !assoc'. rewrite enrichment_assoc'. rewrite !assoc. rewrite <- tensor_id_id. rewrite tensor_rassociator. apply idpath. } etrans. { etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_rassociator. apply idpath. } rewrite !assoc. do 4 apply maponpaths_2. refine (!(id_left _) @ _). rewrite <- mon_lassociator_rassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply sym_mon_hexagon_rassociator. } etrans. { rewrite !assoc'. do 3 apply maponpaths. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_left. rewrite !id_right. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_comp_r_id_l. apply idpath. } rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. exact (enriched_functor_hom_eq' EG EH x y). } etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. do 2 apply maponpaths_2. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. rewrite tensor_lassociator. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite id_right. rewrite <- tensor_comp_id_l. rewrite <- !tensor_comp_mor. rewrite id_left, id_right. apply maponpaths_2. apply maponpaths. rewrite tensor_split'. rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- tensor_split. exact (enriched_functor_hom_eq' EF EG x y). } etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_comp_l_id_r. rewrite !assoc'. rewrite enrichment_assoc'. apply idpath. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite id_left. rewrite <- tensor_lassociator. rewrite !assoc'. rewrite mon_lassociator_rassociator. rewrite id_right. apply idpath. } rewrite !assoc'. rewrite <- tensor_split'. rewrite <- !tensor_comp_mor. rewrite id_right. apply idpath. Qed. Definition enriched_functor_hom_comp : enriched_functor_hom EG EH ⊗ enriched_functor_hom EF EG --> enriched_functor_hom EF EH. Proof. use mor_to_enriched_functor_hom. - exact enriched_functor_hom_comp_data. - exact enriched_functor_hom_comp_laws. Defined. Proposition enriched_functor_hom_comp_comm (x : C₁) : enriched_functor_hom_comp · enriched_functor_hom_pr EF EH x = (enriched_functor_hom_pr EG EH x #⊗ enriched_functor_hom_pr EF EG x) · enriched_comp E₂ (F x) (G x) (H x). Proof. unfold enriched_functor_hom_comp. rewrite mor_to_enriched_functor_hom_pr. apply idpath. Qed. End EnrichmentComp. Section EnrichmentFromArr. Context {F G : C₁ ⟶ C₂} {τ : F ⟹ G} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (Eτ : nat_trans_enrichment τ EF EG). Proposition enriched_functor_hom_from_arr_eq (x y : C₁) : enriched_from_arr E₂ (τ x) · enriched_functor_left_map_ob EG x y = enriched_from_arr E₂ (τ y) · enriched_functor_right_map_ob EF x y. Proof. pose (p := Eτ x y). use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob. rewrite !assoc'. rewrite !internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split. apply idpath. } etrans. { rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. do 2 apply maponpaths. refine (!(id_left _) @ _). rewrite <- mon_runitor_rinvunitor. rewrite !assoc'. apply maponpaths. rewrite !assoc. exact p. } clear p. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply tensor_split. } rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite sym_mon_braiding_runitor. rewrite mon_lunitor_linvunitor. rewrite id_left. rewrite <- tensor_split'. apply idpath. Qed. Definition enriched_functor_hom_from_arr : I_{V} --> enriched_functor_hom EF EG. Proof. use mor_to_enriched_functor_hom. - exact (λ x, enriched_from_arr E₂ (τ x)). - exact enriched_functor_hom_from_arr_eq. Defined. Proposition enriched_functor_hom_from_arr_comm (x : C₁) : enriched_functor_hom_from_arr · enriched_functor_hom_pr EF EG x = enriched_from_arr E₂ (τ x). Proof. unfold enriched_functor_hom_from_arr. rewrite mor_to_enriched_functor_hom_pr. apply idpath. Qed. End EnrichmentFromArr. Section EnrichmentToArr. Context {F G : C₁ ⟶ C₂} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (τ : I_{V} --> enriched_functor_hom EF EG). Definition enrichment_functor_hom_to_arr_data : nat_trans_data F G := λ x, enriched_to_arr E₂ (τ · enriched_functor_hom_pr EF EG x). Proposition enrichment_functor_hom_to_arr_enrichment : nat_trans_enrichment enrichment_functor_hom_to_arr_data EF EG. Proof. unfold enrichment_functor_hom_to_arr_data. intros x y ; cbn. rewrite !enriched_from_to_arr. rewrite tensor_comp_r_id_l. rewrite tensor_comp_l_id_l. pose (enriched_functor_hom_eq' EF EG x y) as p. rewrite !assoc'. rewrite <- p. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite sym_mon_braiding_linvunitor. apply idpath. Qed. Definition enrichment_functor_hom_to_arr : F ⟹ G. Proof. use make_nat_trans. - exact enrichment_functor_hom_to_arr_data. - exact (is_nat_trans_from_enrichment enrichment_functor_hom_to_arr_enrichment). Defined. End EnrichmentToArr. Definition enriched_functor_category_enrichment_data : enrichment_data (enriched_functor_category E₁ E₂) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ F G, enriched_functor_hom (pr2 F) (pr2 G)). - exact (λ F, enriched_functor_hom_id (pr2 F)). - exact (λ F G H, enriched_functor_hom_comp (pr2 F) (pr2 G) (pr2 H)). - exact (λ F G τ, enriched_functor_hom_from_arr (pr2 τ)). - exact (λ F G τ, enrichment_functor_hom_to_arr τ ,, enrichment_functor_hom_to_arr_enrichment τ). Defined. Proposition enriched_functor_category_enrichment_laws : enrichment_laws enriched_functor_category_enrichment_data. Proof. repeat split. - intros F G. use mor_to_enriched_functor_unique. intro x ; cbn. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left. etrans. { do 2 apply maponpaths_2. apply enriched_functor_hom_id_comm. } rewrite tensor_split. rewrite !assoc'. rewrite <- tensor_lunitor. apply maponpaths. refine (!_). apply enrichment_id_left. - intros F G. use mor_to_enriched_functor_unique. intro x ; cbn. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left. etrans. { apply maponpaths_2. apply maponpaths. apply enriched_functor_hom_id_comm. } rewrite tensor_split'. rewrite !assoc'. rewrite <- tensor_runitor. apply maponpaths. refine (!_). apply enrichment_id_right. - intros F₁ F₂ F₃ F₄. use mor_to_enriched_functor_unique. intro x ; cbn. rewrite !assoc'. etrans. { apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left. etrans. { do 2 apply maponpaths_2. apply enriched_functor_hom_comp_comm. } rewrite tensor_comp_r_id_l. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_split. rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite id_left, id_right. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. refine (!_). etrans. { apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !assoc. apply maponpaths_2. rewrite <- tensor_comp_mor. rewrite id_left. etrans. { apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !tensor_comp_l_id_r. apply idpath. - intros F G τ. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq ; [ apply homset_property | ]. intro x ; cbn. unfold enrichment_functor_hom_to_arr_data. etrans. { apply maponpaths. apply enriched_functor_hom_from_arr_comm. } apply enriched_to_from_arr. - intros F G τ. use mor_to_enriched_functor_unique. intro x ; cbn. etrans. { apply enriched_functor_hom_from_arr_comm. } cbn. apply enriched_from_to_arr. - intros F. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq ; [ apply homset_property | ]. intro x ; cbn. unfold enrichment_functor_hom_to_arr_data. etrans. { apply maponpaths. apply enriched_functor_hom_id_comm. } apply enriched_to_arr_id. - intros F G H τ θ. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq ; [ apply homset_property | ]. intro x ; cbn. unfold enrichment_functor_hom_to_arr_data. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. etrans. { do 2 apply maponpaths. apply enriched_functor_hom_comp_comm. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. apply maponpaths. rewrite <- tensor_comp_mor. rewrite !enriched_functor_hom_from_arr_comm. apply idpath. } refine (!_). apply enriched_to_arr_comp. Qed. Definition enriched_functor_category_enrichment : enrichment (enriched_functor_category E₁ E₂) V := enriched_functor_category_enrichment_data ,, enriched_functor_category_enrichment_laws. End EnrichedFunctorCategory. (** 4. Enrichment for presheaf categories *) Definition enriched_presheaf_enrichment {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (EqV : Equalizers V) (PV : Products C V) (PV' : Products (C × C) V) : enrichment (enriched_functor_category (op_enrichment V E) (self_enrichment V)) V := enriched_functor_category_enrichment (op_enrichment V E) (self_enrichment V) EqV PV PV'. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/HomFunctor.v000066400000000000000000000173111451125700300262140ustar00rootroot00000000000000(********************************************************************** Hom functor for enriched categories Enrichments can also be formulated using functors and natural transformations. In this file, we show that every enrichment gives rise to a hom functor, and that the identity and composition give rise to natural transformations. Note that formulating enrichments using functors and natural transformations have additional laws, which expresses the functoriality and the naturality of the hom-functor and the identity and composition. The laws for enrichments have the same formulation irregardless of whether we use a formulation with functors and transformations or as given in Enrichments.v. Contents 1. The enriched hom functor 2. The transformation that is pointwise the enriched identity 3. The transformation that is pointwise the enriched composition **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Local Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Section HomFunctor. Context {V : monoidal_cat} {C : category} (E : enrichment C V). (** 1. The enriched hom functor *) Definition enriched_hom_functor_data : functor_data (category_binproduct C^op C) V. Proof. use make_functor_data. - exact (λ x, E ⦃ pr1 x , pr2 x ⦄). - exact (λ x y f, precomp_arr E (pr2 x) (pr1 f) · postcomp_arr E (pr1 y) (pr2 f)). Defined. Definition enriched_hom_functor_laws : is_functor enriched_hom_functor_data. Proof. split. - intros x ; cbn. rewrite precomp_arr_id, postcomp_arr_id. apply id_left. - intros x y z f g ; cbn. rewrite precomp_arr_comp, postcomp_arr_comp ; cbn. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. apply precomp_postcomp_arr. Qed. Definition enriched_hom_functor : category_binproduct C^op C ⟶ V. Proof. use make_functor. - exact enriched_hom_functor_data. - exact enriched_hom_functor_laws. Defined. (** 2. The transformation that is pointwise the enriched identity *) Definition enriched_id_nat_trans_data : nat_trans_data (constant_functor (core C) V (I_{V})) (core_diag C ∙ enriched_hom_functor) := λ x, enriched_id E x. Definition enriched_id_nat_trans_laws : is_nat_trans _ _ enriched_id_nat_trans_data. Proof. intros x y f ; unfold enriched_id_nat_trans_data ; cbn. rewrite id_left. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. apply enriched_id_precomp_arr. } etrans. { apply enriched_from_arr_postcomp. } etrans. { apply maponpaths. exact (z_iso_after_z_iso_inv f). } apply enriched_from_arr_id. Qed. Definition enriched_id_nat_trans : constant_functor _ V (I_{V}) ⟹ core_diag _ ∙ enriched_hom_functor. Proof. use make_nat_trans. - exact enriched_id_nat_trans_data. - exact enriched_id_nat_trans_laws. Defined. (** 3. The transformation that is pointwise the enriched composition *) Definition enriched_comp_nat_trans_left_functor : category_binproduct (category_binproduct C^op (core C)) C ⟶ V := bindelta_pair_functor (bindelta_pair_functor (pr1_functor _ _ ∙ pr2_functor _ _ ∙ functor_core_op _) (pr2_functor _ _) ∙ enriched_hom_functor) (bindelta_pair_functor (pr1_functor _ _ ∙ pr1_functor _ _) (pr1_functor _ _ ∙ pr2_functor _ _ ∙ functor_core _) ∙ enriched_hom_functor) ∙ monoidal_cat_tensor _. Definition enriched_comp_nat_trans_right_functor : C^op ⊠ core C ⊠ C ⟶ V := bindelta_pair_functor (pr1_functor _ _ ∙ pr1_functor _ _) (pr2_functor _ _) ∙ enriched_hom_functor. Definition enriched_comp_nat_trans_data : nat_trans_data enriched_comp_nat_trans_left_functor enriched_comp_nat_trans_right_functor := λ x, enriched_comp E (pr11 x) (pr21 x) (pr2 x). Definition enriched_comp_nat_trans_laws : is_nat_trans _ _ enriched_comp_nat_trans_data. Proof. intros x y f ; cbn. enough ((precomp_arr E (pr2 x) (inv_from_z_iso (pr21 f)) · postcomp_arr E (pr21 y) (pr2 f)) #⊗ (precomp_arr E (pr21 x) (pr11 f) · postcomp_arr E (pr11 y) (pr121 f)) · enriched_comp_nat_trans_data y = enriched_comp_nat_trans_data x · precomp_arr E (pr2 x) (pr11 f) · postcomp_arr E (pr11 y) (pr2 f)) as X. { rewrite !assoc. exact X. } unfold enriched_comp_nat_trans_data. refine (!_). etrans. { apply maponpaths_2. apply enriched_comp_precomp_arr. } rewrite !assoc'. etrans. { apply maponpaths. apply enriched_comp_postcomp_arr. } rewrite !assoc. etrans. { apply maponpaths_2. exact (!(tensor_split _ _)). } refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply precomp_postcomp_arr. } apply tensor_comp_mor. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply tensor_split. } unfold precomp_arr. etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. etrans. { do 2 apply maponpaths. apply enrichment_assoc. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_l _ _)). } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply mon_inv_triangle. } etrans. { apply maponpaths. exact (!(tensor_comp_id_l _ _)). } refine (!(tensor_comp_id_l _ _) @ _). refine (_ @ tensor_id_id _ _). apply maponpaths. refine (_ @ !(postcomp_arr_comp E (pr121 f) (inv_from_z_iso (pr21 f))) @ _). - apply maponpaths. rewrite !assoc. apply idpath. - etrans. { apply maponpaths. exact (z_iso_inv_after_z_iso (pr21 f)). } apply postcomp_arr_id. Qed. Definition enriched_comp_nat_trans : enriched_comp_nat_trans_left_functor ⟹ enriched_comp_nat_trans_right_functor. Proof. use make_nat_trans. - exact enriched_comp_nat_trans_data. - exact enriched_comp_nat_trans_laws. Defined. End HomFunctor. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/ImageEnriched.v000066400000000000000000000077001451125700300266150ustar00rootroot00000000000000(********************************************************************** Image factorization of enriched categories Enriched functors between enriched categories can be factorized into a essentially surjective functor followed by a enriched fully faithful functor. Contents 1. The enriched image 2. The factorization functors 3. The commutation **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. Section ImageEnriched. Context {V : monoidal_cat} {C₁ C₂ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {F : C₁ ⟶ C₂} (EF : functor_enrichment F E₁ E₂). (** 1. The enriched image *) Definition image_enrichment : enrichment (full_img_sub_precategory F) V := fullsub_enrichment V E₂ _. (** 2. The factorization functors *) Definition image_incl_enrichment : functor_enrichment (sub_precategory_inclusion _ _) image_enrichment E₂ := fullsub_inclusion_enrichment V E₂ _. Definition image_incl_enrichment_fully_faithful : fully_faithful_enriched_functor image_incl_enrichment := fullsub_inclusion_enrichment_fully_faithful V E₂ _. Definition image_proj_enrichment : functor_enrichment (functor_full_img _) E₁ image_enrichment. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (λ x y, EF x y). - abstract (intro x ; cbn ; exact (functor_enrichment_id EF x)). - abstract (intros x y z ; cbn ; exact (functor_enrichment_comp EF x y z)). - abstract (intros x y f ; exact (functor_enrichment_from_arr EF f)). Defined. (** 3. The commutation *) Definition image_factorization_enriched_commutes : nat_trans_enrichment (full_image_inclusion_commute_nat_iso F) (functor_comp_enrichment image_proj_enrichment image_incl_enrichment) EF. Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite tensor_comp_l_id_l. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. apply maponpaths_2. refine (_ @ !(mon_linvunitor_lunitor _)). apply mon_rinvunitor_runitor. Qed. Definition image_factorization_enriched_commutes_inv : nat_trans_enrichment (nat_z_iso_inv (full_image_inclusion_commute_nat_iso F)) EF (functor_comp_enrichment image_proj_enrichment image_incl_enrichment). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite tensor_comp_r_id_l. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. apply maponpaths_2. refine (_ @ !(mon_linvunitor_lunitor _)). apply mon_rinvunitor_runitor. Qed. End ImageEnriched. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/KleisliEnriched.v000066400000000000000000001221651451125700300271720ustar00rootroot00000000000000(********************************************************************** The enriched Kleisli category In this file we define an enrichment of the Kleisli category (that is not guaranteed to be univalent). Contents 1. Data of the enrichment 2. The laws of the enrichment 3. The enrichment **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KleisliCategory. Local Open Scope cat. Local Open Scope moncat. Section EnrichedKleisli. Context {V : monoidal_cat} {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M). (** 1. Data of the enrichment *) Definition Kleisli_cat_monad_enrichment_data : enrichment_data (Kleisli_cat_monad M) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, E ⦃ x , M y ⦄). - exact (λ x, enriched_from_arr E (η M x)). - exact (λ x y z, endo_of_monad_enrichment EM y (M z) #⊗ identity _ · enriched_comp E x (M y) (M(M z)) · mon_linvunitor _ · enriched_from_arr E (μ M z) #⊗ identity _ · enriched_comp E x (M (M z)) (M z)). - exact (λ x y f, enriched_from_arr E (f · η M y)). - exact (λ x y f, enriched_to_arr E f). Defined. (** 2. The laws of the enrichment *) Definition Kleisli_cat_monad_enrichment_laws : enrichment_laws Kleisli_cat_monad_enrichment_data. Proof. repeat split. - intros x y ; cbn. refine (enrichment_id_left _ _ _ @ _). etrans. { rewrite <- (enriched_from_arr_id E (M y)). rewrite <- (@Monad_law2 _ M y). rewrite enriched_from_arr_comp. apply idpath. } refine (!_). etrans. { rewrite !assoc. etrans. { do 4 apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_right. rewrite <- (functor_enrichment_from_arr EM). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_split. } rewrite tensor_split'. rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } apply idpath. } rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. rewrite tensor_split. rewrite !assoc. do 2 apply maponpaths_2. refine (!_). apply tensor_linvunitor. } rewrite !assoc'. rewrite tensor_comp_id_r. apply maponpaths. cbn. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply tensor_id_id. } apply tensor_rassociator. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_r. } refine (!(tensor_comp_id_r _ _) @ _). apply idpath. - intros x y ; cbn. rewrite !assoc'. refine (_ @ id_left _). refine (!_). etrans. { apply maponpaths_2. refine (!_). apply mon_runitor_rinvunitor. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { etrans. { apply maponpaths. rewrite !assoc. do 4 apply maponpaths_2. refine (!_). apply tensor_split. } rewrite !assoc. do 3 apply maponpaths_2. exact (unit_of_monad_enrichment EM x (M y)). } cbn. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc'. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 3 apply maponpaths_2. etrans. { do 2 apply maponpaths. refine (!_). apply tensor_id_id. } refine (!_). apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. } pose (maponpaths (enriched_from_arr E) (@Monad_law1 _ M y)) as p. rewrite enriched_from_arr_id in p. rewrite enriched_from_arr_comp in p. refine (_ @ mon_linvunitor_lunitor _). apply maponpaths. refine (_ @ !(enrichment_id_left _ _ _)). rewrite !assoc. apply maponpaths_2. etrans. { etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_id_r. } refine (!_). apply tensor_comp_id_r. } refine (!_). apply tensor_comp_id_r. } apply maponpaths_2. refine (_ @ p). apply maponpaths_2. refine (!_). etrans. { rewrite tensor_split. apply idpath. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_linvunitor. - intros w x y z ; cbn. (* The equation basically says that for all f : w --> M x g : x --> M y h : y --> M z we have (f · #M ((g · #M h) · μ M z)) · μ M z = ((f · #M g) · μ M y) · #M h · μ M z *) rewrite !assoc'. (* (f · #M ((g · #M h) · μ M z)) · μ M z = f · (#M ((g · #M h) · μ M z) · μ M z) *) etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } refine (!_). (* ((f · #M g) · μ M y) · #M h · μ M z = ((f · #M g) · μ M y) · (#M h · μ M z) *) etrans. { do 3 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } etrans. { do 3 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. exact (!(tensor_comp_id_r _ _)). } exact (!(tensor_comp_id_r _ _)). } refine (!(tensor_split) _ _ @ _). apply tensor_split'. } (* ((f · #M g) · μ M y) · (#M h · μ M z) = (f · #M g) · (μ M y · (#M h · μ M z)) *) etrans. { rewrite !assoc'. do 2 apply maponpaths. etrans. { apply maponpaths_2. rewrite !assoc. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } rewrite !assoc'. (* (f · #M g) · (μ M y · (#M h · μ M z)) = f · (#M g · (μ M y · (#M h · μ M z))) *) etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } exact (!(tensor_comp_id_r _ _)). } rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. do 2 apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. (* Simplify so that `w` does not occur in the equation *) refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 2 apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { exact (!(tensor_comp_id_r _ _)). } refine (!_). etrans. { do 3 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply tensor_rassociator. } etrans. { apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } etrans. { rewrite !assoc. etrans. { do 4 apply maponpaths_2. apply mon_lassociator_rassociator. } rewrite id_left. etrans. { do 2 apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } exact (!(tensor_comp_id_r _ _)). } apply maponpaths_2. clear w. (* We simplified the equation, and now we need to show that for all g : x --> M y h : y --> M z we have #M ((g · #M h) · μ M z) · μ M z = #M g · (μ M y · (#M h · μ M z)) *) rewrite !assoc'. refine (!_). (* #M ((g · #M h) · μ M z) · μ M z = (#M (g · #M h) · #M (μ M z)) · μ M z *) etrans. { do 4 apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. apply (functor_enrichment_comp EM). } rewrite !assoc'. (* (#M (g · #M h) · #M (μ M z)) · μ M z = #M (g · #M h) · (#M (μ M z) · μ M z) *) etrans. { do 5 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } etrans. { do 5 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } (* #M (g · #M h) · (#M (μ M z) · μ M z) = (#M g · #M(#M h)) · (#M (μ M z) · μ M z) *) etrans. { apply maponpaths. rewrite !assoc. etrans. { do 6 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 5 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. do 4 apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. apply (functor_enrichment_comp EM). } (* (#M g · #M(#M h)) · (#M (μ M z) · μ M z) = #M g · (#M(#M h) · (#M (μ M z) · μ M z)) *) etrans. { rewrite !assoc'. do 3 apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_l_id_r. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. do 3 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. do 2 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. etrans. { do 5 apply maponpaths_2. etrans. { apply maponpaths. apply tensor_split. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply tensor_linvunitor. } rewrite !assoc. apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply tensor_split. } refine (!_). etrans. { apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc'. apply maponpaths. etrans. { refine (!_). apply tensor_comp_id_r. } refine (!_). etrans. { do 6 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 5 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 4 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 3 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } rewrite !assoc'. exact (!(tensor_comp_id_r _ _)). } etrans. { exact (!(tensor_comp_id_r _ _)). } apply maponpaths_2. clear x. (* We simplified the equation, and now we need to show that for all h : y --> M z we have μ M y · (#M h · μ M z) = #M(#M h) · (#M (μ M z) · μ M z) *) assert (enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (# M (μ M z)) · enriched_comp E (M (M (M z))) (M (M z)) (M z) = enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (μ M (M z)) · enriched_comp E (M (M (M z))) (M (M z)) (M z)) as p. { refine (!(id_left _) @ _ @ id_left _). etrans. { apply maponpaths_2. refine (!_). apply mon_lunitor_linvunitor. } etrans. { rewrite !assoc'. apply maponpaths. pose (p := maponpaths (enriched_from_arr E) (@Monad_law3 _ M z)). rewrite !enriched_from_arr_comp in p. cbn in p. rewrite !assoc. exact p. } rewrite !assoc. do 2 apply maponpaths_2. apply mon_lunitor_linvunitor. } rewrite (functor_enrichment_from_arr EM) in p. (** #M(#M h) · (#M (μ M z) · μ M z) = #M(#M h) · (μ M (M z) · μ M z) *) etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 3 apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } etrans. { do 2 apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths_2. exact (!(tensor_comp_id_r _ _)). } etrans. { exact (!(tensor_comp_id_r _ _)). } apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. exact (!(tensor_split _ _)). } exact p. } clear p. (* #M(#M h) · (μ M (M z) · μ M z) = (#M(#M h) · μ M (M z)) · μ M z *) etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } refine (!_). (* μ M y · (#M h · μ M z) = (μ M y · #M h) · μ M z *) etrans. { do 3 apply maponpaths. apply enrichment_assoc. } rewrite !assoc. apply maponpaths_2. etrans. { do 4 apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { apply maponpaths. refine (!(tensor_split _ _) @ _). apply tensor_split'. } apply idpath. } refine (!_). etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply tensor_split'. } rewrite !assoc. apply maponpaths_2. rewrite mon_linvunitor_I_mon_rinvunitor_I. refine (!_). apply tensor_rinvunitor. } rewrite !assoc'. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { rewrite !assoc. do 3 apply maponpaths_2. refine (!_). apply tensor_id_id. } etrans. { apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. refine (!_). apply tensor_comp_id_l. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply mon_rinvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rassociator_lassociator. } apply id_left. } exact (!(tensor_comp_id_l _ _)). } refine (!(tensor_comp_id_l _ _) @ _). refine (!_). etrans. { etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. exact (!(tensor_id_id _ _)). } apply tensor_lassociator. } rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (!(tensor_comp_id_l _ _)). } rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_l _ _)). } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply mon_inv_triangle. } exact (!(tensor_comp_id_l _ _)). } apply maponpaths. (* We simplified the equation, and now we need to show that for all h : y --> M z we have #M(#M h) · μ M (M z) = μ M y · #M h *) pose (p := mu_of_monad_enrichment EM y (M z)). cbn in p. etrans. { apply maponpaths. apply maponpaths_2. exact (!(tensor_split' _ _)). } rewrite !assoc. refine (!p @ _) ; clear p. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. exact (!(tensor_split' _ _)). - intros x y f ; cbn. rewrite enriched_to_from_arr. etrans. { apply maponpaths. apply bind_η. } apply id_right. - intros x y f ; cbn. rewrite enriched_from_arr_comp. rewrite enriched_from_to_arr. etrans. { apply maponpaths_2. apply maponpaths. apply maponpaths_2. etrans. { apply maponpaths. apply bind_η. } apply enriched_from_arr_id. } rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. - intros x ; cbn. rewrite enriched_to_from_arr. apply idpath. - intros x y z f g ; cbn. unfold bind. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. rewrite enriched_from_to_arr. rewrite enriched_from_arr_comp. rewrite !assoc'. apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths. refine (!_). apply tensor_id_id. } refine (!_). apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. } rewrite <- !tensor_comp_mor. rewrite !id_left. rewrite id_right. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. exact (@Monad_law2 _ M y). } apply id_right. } apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths. apply (@Monad_law2 _ M z). } apply id_right. } rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { refine (!_). apply tensor_comp_mor. } rewrite !id_left, id_right. apply maponpaths. rewrite (functor_enrichment_from_arr EM g). apply idpath. Qed. (** 3. The enrichment *) Definition Kleisli_cat_monad_enrichment : enrichment (Kleisli_cat_monad M) V. Proof. simple refine (_ ,, _). - exact Kleisli_cat_monad_enrichment_data. - exact Kleisli_cat_monad_enrichment_laws. Defined. Definition Left_Kleisli_functor_enrichment_laws : @is_functor_enrichment _ _ _ (Left_Kleisli_functor M) E Kleisli_cat_monad_enrichment (λ x y : C, postcomp_arr E x (η M y)). Proof. repeat split. - intro x. exact (enriched_id_postcomp_arr E (η M x)). - cbn. intros x y z. etrans. { apply enriched_comp_postcomp_arr. } refine (!_). etrans. { apply maponpaths_2. apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 4 apply maponpaths_2. exact (!(tensor_split _ _)). } unfold postcomp_arr. etrans. { do 4 apply maponpaths_2. apply tensor_comp_l_id_r. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply tensor_id_id. } refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!(tensor_id_id _ _) @ _). apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. do 4 apply maponpaths_2. apply mon_lassociator_rassociator. } rewrite id_left. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. exact (!(tensor_id_id _ _)). } apply tensor_rassociator. } rewrite !assoc'. etrans. { do 2 apply maponpaths. etrans. { do 2 apply maponpaths. refine (!_). apply tensor_comp_id_r. } etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_r. } refine (!_). apply tensor_comp_id_r. } rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_comp_l_id_l. } rewrite !assoc'. apply maponpaths. apply tensor_rassociator. } rewrite !assoc'. etrans. { do 2 apply maponpaths. refine (!_). apply tensor_comp_id_r. } rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } refine (!(tensor_comp_id_r _ _) @ _). refine (_ @ tensor_id_id _ _). apply maponpaths_2. rewrite !assoc'. pose (unit_of_monad_enrichment EM y (M z)). cbn in p. etrans. { do 2 apply maponpaths. etrans. { do 2 apply maponpaths. apply enrichment_assoc. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !assoc'. apply maponpaths. apply tensor_lassociator. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply tensor_id_id. } refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_linvunitor. } rewrite !assoc. etrans. { do 3 apply maponpaths_2. exact p. } clear p. pose (p := maponpaths (enriched_from_arr E) (@Monad_law1 _ M z)). rewrite enriched_from_arr_id in p. rewrite enriched_from_arr_comp in p. cbn in p. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_comp_l_id_r. } rewrite !assoc'. etrans. { apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_id_r. } etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { apply maponpaths. apply maponpaths_2. etrans. { refine (!_). apply tensor_comp_id_r. } rewrite !assoc. apply maponpaths_2. exact p. } etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. - cbn. intros x y f. rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (@η_bind _ M _ _ (η M y)). } refine (!_). apply enriched_from_arr_postcomp. Qed. Definition Left_Kleisli_functor_enrichment : functor_enrichment (Left_Kleisli_functor M) E Kleisli_cat_monad_enrichment. Proof. simple refine (_ ,, _). - exact (λ x y, postcomp_arr E x (η M y)). - exact Left_Kleisli_functor_enrichment_laws. Defined. End EnrichedKleisli. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/OppositeEnriched.v000066400000000000000000000537531451125700300274060ustar00rootroot00000000000000(***************************************************************** The opposite enriched category If we look at categories enriched over a symmetric monoidal category, then we can form the opposite. In addition, we construct the desired enriched functors and natural transformations to show that this gives rise to a duality involution on the bicategory of enriched categories Contents 1. Enrichment of the opposite 2. Pseudofunctoriality 2.1. Opposite of enriched functors 2.2. Opposite of enriched transformations 2.3. Opposite of the identity enriched functors 2.4. Opposite of the composition of enriched functors 3. Duality involution 3.1. The unit and the inverse 3.2. The naturality of the unit 3.3. Inverse laws 3.4. The triangle *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope moncat. Opaque sym_mon_braiding. Import MonoidalNotations. Section OppositeEnriched. Context (V : sym_monoidal_cat) {C : category} (E : enrichment C V). (** 1. Enrichment of the opposite *) Definition op_enrichment_data : enrichment_data (C^opp) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, E ⦃ y , x ⦄). - exact (λ x, enriched_id E x). - exact (λ x y z, sym_mon_braiding V _ _ · enriched_comp E z y x). - exact (λ x y f, enriched_from_arr E f). - exact (λ x y f, enriched_to_arr E f). Defined. Definition op_enrichment_laws : enrichment_laws op_enrichment_data. Proof. repeat split. - intros x y ; cbn in *. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite sym_mon_braiding_runitor. apply idpath. - intros x y ; cbn in *. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite sym_mon_braiding_lunitor. apply idpath. - intros w x y z ; cbn in *. rewrite tensor_comp_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply tensor_sym_mon_braiding. } rewrite !assoc'. rewrite enrichment_assoc'. rewrite !assoc. apply maponpaths_2. rewrite tensor_comp_id_l. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite sym_mon_tensor_rassociator. rewrite !assoc'. rewrite mon_lassociator_rassociator. rewrite id_right. rewrite !assoc. rewrite <- sym_mon_hexagon_lassociator. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lassociator_rassociator. apply id_left. } rewrite tensor_sym_mon_braiding. apply idpath. - intros x y f ; cbn in *. apply enriched_to_from_arr. - intros x y f ; cbn in *. apply enriched_from_to_arr. - intros x ; cbn in *. apply enriched_to_arr_id. - intros x y z f g ; cbn in *. refine (enriched_to_arr_comp E g f @ _). apply maponpaths. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite tensor_sym_mon_braiding. rewrite sym_mon_braiding_id. rewrite id_left. apply idpath. Qed. Definition op_enrichment : enrichment (C^opp) V := op_enrichment_data ,, op_enrichment_laws. Proposition op_enrichment_precomp (w : C) {x y : C} (f : x --> y) : precomp_arr op_enrichment w f = postcomp_arr E w f. Proof. unfold precomp_arr, postcomp_arr ; cbn. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite !assoc. rewrite sym_mon_braiding_rinvunitor. apply idpath. Qed. Proposition op_enrichment_postcomp {x y : C} (f : x --> y) (z : C) : postcomp_arr op_enrichment z f = precomp_arr E z f. Proof. unfold precomp_arr, postcomp_arr ; cbn. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite !assoc. rewrite sym_mon_braiding_linvunitor. apply idpath. Qed. End OppositeEnriched. (** 2. Pseudofunctoriality *) (** 2.1. Opposite of enriched functors *) Definition functor_op_enrichment (V : sym_monoidal_cat) {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : functor_enrichment (functor_op F) (op_enrichment V E₁) (op_enrichment V E₂). Proof. refine ((λ x y, EF y x) ,, _). repeat split. - abstract (cbn ; intro x ; exact (functor_enrichment_id EF x)). - abstract (cbn ; intros x y z ; rewrite !assoc' ; rewrite (functor_enrichment_comp EF z y x) ; rewrite !assoc ; apply maponpaths_2 ; rewrite tensor_sym_mon_braiding ; apply idpath). - abstract (cbn ; intros x y f ; apply functor_enrichment_from_arr). Defined. (** 2.2. Opposite of enriched transformations *) Definition nat_trans_op_enrichment (V : sym_monoidal_cat) {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : F ⟹ G) {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (Eτ : nat_trans_enrichment τ EF EG) : @nat_trans_enrichment V (C₁^opp) (C₂^opp) _ _ (op_nt τ) _ _ (functor_op_enrichment V EG) (functor_op_enrichment V EF). Proof. intros x y ; cbn in *. pose (p := Eτ y x). etrans. { rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. rewrite sym_mon_braiding_rinvunitor. apply idpath. } refine (!p @ _) ; clear p. refine (!_). rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. rewrite sym_mon_braiding_linvunitor. apply idpath. Qed. (** 2.3. Opposite of the identity enriched functors *) Definition functor_identity_op_enrichment (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (functor_identity_op C) (functor_id_enrichment (op_enrichment V E)) (functor_op_enrichment V (functor_id_enrichment E)). Proof. intros x y ; cbn. rewrite! enriched_from_arr_id. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_left, <- enrichment_id_right. rewrite sym_mon_braiding_lunitor, sym_mon_braiding_runitor. rewrite mon_rinvunitor_runitor. rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition functor_identity_op_inv_enrichment (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (nat_z_iso_inv (functor_identity_op_nat_z_iso C)) (functor_op_enrichment V (functor_id_enrichment E)) (functor_id_enrichment (op_enrichment V E)). Proof. intros x y ; cbn. rewrite! enriched_from_arr_id. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_left, <- enrichment_id_right. rewrite sym_mon_braiding_lunitor, sym_mon_braiding_runitor. rewrite mon_rinvunitor_runitor. rewrite mon_linvunitor_lunitor. apply idpath. Qed. (** 2.4. Opposite of the composition of enriched functors *) Definition functor_comp_op_enrichment (V : sym_monoidal_cat) {C₁ C₂ C₃ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (EF : functor_enrichment F E₁ E₂) (EG : functor_enrichment G E₂ E₃) : @nat_trans_enrichment V (C₁^opp) (C₃^opp) _ _ (functor_comp_op F G) _ _ (functor_comp_enrichment (functor_op_enrichment V EF) (functor_op_enrichment V EG)) (functor_op_enrichment V (functor_comp_enrichment EF EG)). Proof. intros x y ; cbn. rewrite! enriched_from_arr_id. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc. rewrite sym_mon_braiding_linvunitor, sym_mon_braiding_rinvunitor. rewrite <- (functor_enrichment_id EG). rewrite <- (functor_enrichment_id EF). rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_r_id_l. rewrite tensor_comp_mor. rewrite !assoc'. rewrite <- (functor_enrichment_comp EG). rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- (functor_enrichment_comp EF). rewrite !assoc. rewrite <- enrichment_id_left. apply idpath. } rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. apply idpath. } rewrite !assoc. rewrite mon_rinvunitor_runitor. rewrite id_left. apply idpath. Qed. Definition functor_comp_op_inv_enrichment (V : sym_monoidal_cat) {C₁ C₂ C₃ : category} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (EF : functor_enrichment F E₁ E₂) (EG : functor_enrichment G E₂ E₃) : @nat_trans_enrichment V (C₁^opp) (C₃^opp) _ _ (nat_z_iso_inv (functor_comp_op_nat_z_iso F G)) _ _ (functor_op_enrichment V (functor_comp_enrichment EF EG)) (functor_comp_enrichment (functor_op_enrichment V EF) (functor_op_enrichment V EG)). Proof. intros x y ; cbn. rewrite! enriched_from_arr_id. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc. rewrite sym_mon_braiding_linvunitor, sym_mon_braiding_rinvunitor. rewrite <- (functor_enrichment_id EG). rewrite <- (functor_enrichment_id EF). rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_r_id_l. rewrite tensor_comp_mor. rewrite !assoc'. rewrite <- (functor_enrichment_comp EG). rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- (functor_enrichment_comp EF). rewrite !assoc. rewrite <- enrichment_id_left. apply idpath. } rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. apply idpath. } rewrite !assoc. rewrite mon_rinvunitor_runitor. rewrite id_left. apply idpath. Qed. (** 3. Duality involution *) (** 3.1. The unit and the inverse *) Definition op_enriched_unit (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : functor_enrichment (functor_identity C) E (op_enrichment V (op_enrichment V E)). Proof. refine ((λ x y, identity _) ,, _). repeat split ; cbn. - abstract (intro x ; apply id_right). - abstract (intros x y z ; rewrite id_right ; rewrite tensor_id_id ; rewrite id_left ; rewrite !assoc ; rewrite sym_mon_braiding_inv ; rewrite id_left ; apply idpath). - abstract (intros x y f ; rewrite id_right ; apply idpath). Defined. Definition op_enriched_unit_inv (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : functor_enrichment (functor_identity _) (op_enrichment V (op_enrichment V E)) E. Proof. refine ((λ x y, identity _) ,, _). repeat split. - abstract (intros x ; cbn ; rewrite id_right ; apply idpath). - abstract (intros x y z ; cbn ; rewrite !id_right ; rewrite tensor_id_id ; rewrite !assoc ; rewrite sym_mon_braiding_inv ; apply idpath). - abstract (intros x y f ; cbn ; rewrite id_right ; apply idpath). Defined. (** 3.2. The naturality of the unit *) Definition op_enriched_unit_naturality (V : sym_monoidal_cat) {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : nat_trans_enrichment (op_unit_nat_trans F) (functor_comp_enrichment (op_enriched_unit V E₁) (functor_op_enrichment V (functor_op_enrichment V EF))) (functor_comp_enrichment EF (op_enriched_unit V E₂)). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left, !id_right. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite mon_rinvunitor_runitor. apply id_left. } rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Definition op_enriched_unit_naturality_inv (V : sym_monoidal_cat) {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_z_iso_to_trans_inv (op_unit_nat_z_iso F)) (functor_comp_enrichment EF (op_enriched_unit V E₂)) (functor_comp_enrichment (op_enriched_unit V E₁) (functor_op_enrichment V (functor_op_enrichment V EF))). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left, !id_right. rewrite !enriched_from_arr_id. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite mon_rinvunitor_runitor. apply id_left. } rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Definition op_enriched_unit_inv_naturality (V : sym_monoidal_cat) {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : nat_trans_enrichment (op_unit_inv_nat_trans F) (functor_comp_enrichment (op_enriched_unit_inv V E₁) EF) (functor_comp_enrichment (functor_op_enrichment V (functor_op_enrichment V EF)) (op_enriched_unit_inv V E₂)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite id_left, id_right. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite mon_rinvunitor_runitor. apply id_left. } rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Definition op_enriched_unit_inv_naturality_inv (V : sym_monoidal_cat) {C₁ C₂ : category} {F : C₁ ⟶ C₂} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} (EF : functor_enrichment F E₁ E₂) : nat_trans_enrichment (nat_z_iso_to_trans_inv (op_unit_inv_nat_z_iso F)) (functor_comp_enrichment (functor_op_enrichment V (functor_op_enrichment V EF)) (op_enriched_unit_inv V E₂)) (functor_comp_enrichment (op_enriched_unit_inv V E₁) EF). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite id_left, id_right. etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite mon_rinvunitor_runitor. apply id_left. } rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. (** 3.3. Inverse laws *) Definition op_enriched_unit_unit_inv (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (op_unit_unit_inv_nat_trans C) (functor_id_enrichment E) (functor_comp_enrichment (op_enriched_unit V E) (op_enriched_unit_inv V E)). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite id_left. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite mon_rinvunitor_runitor. rewrite <- enrichment_id_left. rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition op_enriched_unit_unit_inv_inv (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (nat_z_iso_to_trans_inv (op_unit_unit_inv_nat_z_iso C)) (functor_comp_enrichment (op_enriched_unit V E) (op_enriched_unit_inv V E)) (functor_id_enrichment E). Proof. intros x y ; cbn. rewrite !enriched_from_arr_id. rewrite id_left. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite mon_rinvunitor_runitor. rewrite <- enrichment_id_left. rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition op_enriched_unit_inv_unit (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (op_unit_inv_unit_nat_trans C) (functor_comp_enrichment (op_enriched_unit_inv V E) (op_enriched_unit V E)) (functor_id_enrichment (op_enrichment V (op_enrichment V E))). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left. rewrite !enriched_from_arr_id. rewrite <- enrichment_id_right. rewrite mon_rinvunitor_runitor. rewrite <- enrichment_id_left. rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition op_enriched_unit_inv_unit_inv (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (nat_z_iso_to_trans_inv (op_unit_inv_unit_nat_z_iso C)) (functor_id_enrichment (op_enrichment V (op_enrichment V E))) (functor_comp_enrichment (op_enriched_unit_inv V E) (op_enriched_unit V E)). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left. rewrite !enriched_from_arr_id. rewrite <- enrichment_id_right. rewrite mon_rinvunitor_runitor. rewrite <- enrichment_id_left. rewrite mon_linvunitor_lunitor. apply idpath. Qed. (** 3.4. The triangle *) Definition op_enriched_triangle (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (λ _, identity _) (op_enriched_unit V (op_enrichment V E)) (functor_op_enrichment V (op_enriched_unit V E)). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left. rewrite !enriched_from_arr_id. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite <- enrichment_id_left. rewrite sym_mon_braiding_lunitor. rewrite sym_mon_braiding_runitor. rewrite mon_rinvunitor_runitor. rewrite mon_linvunitor_lunitor. apply idpath. Qed. Definition op_enriched_triangle_inv (V : sym_monoidal_cat) {C : category} (E : enrichment C V) : nat_trans_enrichment (λ _, identity _) (functor_op_enrichment V (op_enriched_unit V E)) (op_enriched_unit V (op_enrichment V E)). Proof. intros x y ; cbn. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite !sym_mon_braiding_inv. rewrite !id_left. rewrite !enriched_from_arr_id. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite !tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite <- enrichment_id_left. rewrite sym_mon_braiding_lunitor. rewrite sym_mon_braiding_runitor. rewrite mon_rinvunitor_runitor. rewrite mon_linvunitor_lunitor. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/PosetEnriched.v000066400000000000000000000351461451125700300266720ustar00rootroot00000000000000(********************************************************************** Categories enriched over posets In this file, we study categories enriched over posets. We provide an elementary definition for both enrichments of categories and of functors and we prove the equivalence of these notions with the general notion of enrichments via the cartesian monoidal category of posets. Enrichments of posets for categories means that every hom-set is equipped with the structure of a poset and that composition is monotone, while enrichment for functors means that the action on morphisms is monotone. Contents 1. The monoidal category is faithful 2. Elementary definition of poset enrichments 3. Equivalence of enrichments with the elementary definition 4. Elementary definition of poset enriched functors 5. Equivalence of functor enrichments with elementary definition **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.CategoryOfPosets. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.PosetsMonoidal. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Local Open Scope cat. (** 1. The monoidal category is faithful *) Definition poset_faithful_moncat : faithful_moncat poset_monoidal_cat. Proof. intros R₁ R₂ f g p. use eq_monotone_function. intro x. assert (is_monotone unit_PartialOrder (pr2 R₁) (λ _, x)) as H. { intros w₁ w₂ q. apply refl_PartialOrder. } exact (eqtohomot (maponpaths pr1 (p ((λ _, x) ,, H))) tt). Qed. (** 2. Elementary definition of poset enrichments *) Definition poset_enrichment_data (C : category) : UU := ∏ (x y : C), PartialOrder (homset x y). Definition poset_enrichment_laws {C : category} (PEC : poset_enrichment_data C) : UU := (∏ (x y z : C) (f₁ f₂ : x --> y) (g : y --> z) (p : PEC x y f₁ f₂), PEC x z (f₁ · g) (f₂ · g)) × (∏ (x y z : C) (f : x --> y) (g₁ g₂ : y --> z) (p : PEC y z g₁ g₂), PEC x z (f · g₁) (f · g₂)). Proposition isaprop_poset_enrichment_laws {C : category} (PEC : poset_enrichment_data C) : isaprop (poset_enrichment_laws PEC). Proof. use isapropdirprod ; (repeat (use impred ; intro)) ; apply propproperty. Qed. Definition poset_enrichment (C : category) : UU := ∑ (PEC : poset_enrichment_data C), poset_enrichment_laws PEC. Definition poset_enrichment_hom_poset {C : category} (PEC : poset_enrichment C) (x y : C) : PartialOrder (x --> y ,, homset_property C x y) := pr1 PEC x y. Coercion poset_enrichment_hom_poset : poset_enrichment >-> Funclass. Proposition poset_enrichment_comp_l {C : category} (PEC : poset_enrichment C) {x y z : C} {f₁ f₂ : x --> y} (g : y --> z) (p : PEC x y f₁ f₂) : PEC x z (f₁ · g) (f₂ · g). Proof. exact (pr12 PEC x y z f₁ f₂ g p). Qed. Proposition poset_enrichment_comp_r {C : category} (PEC : poset_enrichment C) {x y z : C} (f : x --> y) {g₁ g₂ : y --> z} (p : PEC y z g₁ g₂) : PEC x z (f · g₁) (f · g₂). Proof. exact (pr22 PEC x y z f g₁ g₂ p). Qed. (** 3. Equivalence of enrichments with the elementary definition *) Section MakePosetEnrichment. Context (C : category) (PEC : poset_enrichment C). Definition make_enrichment_over_poset_data : enrichment_data C poset_monoidal_cat. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, _ ,, PEC x y). - refine (λ x, (λ _, identity _) ,, _). abstract (cbn ; intros t₁ t₂ p ; apply refl_PartialOrder). - simple refine (λ x y z, _ ,, _) ; cbn in *. + exact (λ fg, pr2 fg · pr1 fg). + abstract (intros fg₁ fg₂ p ; cbn in * ; exact (trans_PartialOrder _ (poset_enrichment_comp_l PEC _ (pr2 p)) (poset_enrichment_comp_r PEC _ (pr1 p)))). - refine (λ x y f, (λ _, f) ,, _). abstract (intros t₁ t₂ p ; cbn in * ; apply refl_PartialOrder). - exact (λ x y f, pr1 f tt). Defined. Proposition make_enrichment_over_poset_laws : enrichment_laws make_enrichment_over_poset_data. Proof. repeat split. - intros x y. use eq_monotone_function. intro a ; cbn. rewrite id_right. apply idpath. - intros x y. use eq_monotone_function. intro a ; cbn. rewrite id_left. apply idpath. - intros w x y z. use eq_monotone_function. intro a ; cbn. rewrite assoc. apply idpath. - intros x y f. use eq_monotone_function. intro a ; cbn in *. apply maponpaths. apply isapropunit. Qed. Definition make_enrichment_over_poset : enrichment C poset_monoidal_cat := make_enrichment_over_poset_data ,, make_enrichment_over_poset_laws. End MakePosetEnrichment. Section FromPosetEnrichment. Context (C : category) (E : enrichment C poset_monoidal_cat). Definition make_poset_enrichment_rel (x y : C) : hrel (x --> y). Proof. refine (λ f g, _). use make_hProp. - exact (pr12 (E ⦃ x , y ⦄) (pr1 (enriched_from_arr E f) tt) (pr1 (enriched_from_arr E g) tt)). - apply (pr12 (E ⦃ x , y ⦄)). Defined. Definition make_poset_enrichment_data : poset_enrichment_data C. Proof. intros x y. simple refine (_ ,, ((_ ,, _) ,, _)). - exact (make_poset_enrichment_rel x y). - intros f g h p q. exact (trans_PartialOrder (pr2 (E ⦃ x , y ⦄)) p q). - intros f. exact (refl_PartialOrder (pr2 (E ⦃ x , y ⦄)) _). - cbn. intros f g p q. rewrite <- (enriched_to_from_arr E f). rewrite <- (enriched_to_from_arr E g). apply maponpaths. use eq_monotone_function. intro w. induction w. exact (antisymm_PartialOrder (pr2 (E ⦃ x , y ⦄)) p q). Defined. Proposition make_poset_enrichment_laws : poset_enrichment_laws make_poset_enrichment_data. Proof. repeat split. - intros x y z f₁ f₂ g p ; cbn. rewrite !enriched_from_arr_comp ; cbn. pose (Ef₁ := enriched_from_arr E f₁ : monotone_function _ _). pose (Ef₂ := enriched_from_arr E f₂ : monotone_function _ _). pose (Eg := enriched_from_arr E g : monotone_function _ _). use (pr2 (enriched_comp E x y z) (Eg tt ,, Ef₁ tt) (Eg tt ,, Ef₂ tt)). split. + apply refl_PartialOrder. + exact p. - intros x y z f g₁ g₂ p ;cbn. rewrite !enriched_from_arr_comp ; cbn. pose (Ef := enriched_from_arr E f : monotone_function _ _). pose (Eg₁ := enriched_from_arr E g₁ : monotone_function _ _). pose (Eg₂ := enriched_from_arr E g₂ : monotone_function _ _). use (pr2 (enriched_comp E x y z) (Eg₁ tt ,, Ef tt) (Eg₂ tt ,, Ef tt)). split. + exact p. + apply refl_PartialOrder. Qed. Definition make_poset_enrichment : poset_enrichment C := make_poset_enrichment_data ,, make_poset_enrichment_laws. End FromPosetEnrichment. Section EnrichmentOverPosetInverse. Context {C : category} (E : enrichment C poset_monoidal_cat). Definition enrichment_over_poset_weq_poset_enrichment_inv_iso (x y : C) : z_iso ((pr11 (make_enrichment_over_poset C (make_poset_enrichment C E))) x y) (E ⦃ x , y ⦄). Proof. use make_z_iso ; cbn. - simple refine (_ ,, _). + exact (λ f, pr1 (enriched_from_arr E f) tt). + abstract (cbn ; intros f g p ; apply p). - simple refine (_ ,, _). + refine (λ f, enriched_to_arr E _). simple refine (_ ,, _). * exact (λ _, f). * abstract (cbn ; intros t₁ t₂ p ; apply refl_PartialOrder). + abstract (intros f₁ f₂ p ; cbn ; rewrite !enriched_from_to_arr ; cbn ; exact p). - split. + abstract (use eq_monotone_function ; intro f ; cbn in * ; refine (_ @ enriched_to_from_arr E f) ; apply maponpaths ; use eq_monotone_function ; intro t ; cbn ; apply maponpaths ; apply isapropunit). + abstract (use eq_monotone_function ; intro f ; cbn in * ; assert (is_monotone unit_PartialOrder (pr2 (E ⦃ x, y ⦄)) (λ _ : unit, f)) as H ; [ intros t₁ t₂ p ; apply refl_PartialOrder | ] ; refine (_ @ eqtohomot (maponpaths pr1 (enriched_from_to_arr E (_ ,, H))) tt) ; cbn ; apply maponpaths_2 ; do 3 apply maponpaths ; apply isaprop_is_monotone). Defined. Definition enrichment_over_poset_weq_poset_enrichment_inv_1 : make_enrichment_over_poset C (make_poset_enrichment C E) = E. Proof. use subtypePath. { intro. apply isaprop_enrichment_laws. } use (invweq (total2_paths_equiv _ _ _)). use (invmap (enrichment_data_hom_path _ _ _)). { exact is_univalent_category_of_posets. } simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact enrichment_over_poset_weq_poset_enrichment_inv_iso. - abstract (intro x ; use eq_monotone_function ; intro w ; cbn ; rewrite enriched_from_arr_id ; apply maponpaths ; apply isapropunit). - abstract (intros x y z ; use eq_monotone_function ; intro w ; cbn ; rewrite enriched_from_arr_comp ; cbn ; apply idpath). - abstract (intros x y f ; use eq_monotone_function ; intro w ; cbn ; apply maponpaths ; apply isapropunit). - abstract (intros x y f ; cbn ; refine (!_) ; refine (_ @ enriched_to_from_arr E (pr1 f tt)) ; apply maponpaths ; use eq_monotone_function ; intro w ; cbn ; induction w ; apply idpath). Defined. End EnrichmentOverPosetInverse. Definition enrichment_over_poset_weq_poset_enrichment_inv_2 {C : category} (E : poset_enrichment C) : make_poset_enrichment C (make_enrichment_over_poset C E) = E. Proof. use subtypePath. { intro. apply isaprop_poset_enrichment_laws. } use funextsec ; intro x. use funextsec ; intro y. use subtypePath. { intro. apply isaprop_isPartialOrder. } apply idpath. Qed. Definition enrichment_over_poset_weq_poset_enrichment (C : category) : enrichment C poset_monoidal_cat ≃ poset_enrichment C. Proof. use weq_iso. - exact (make_poset_enrichment C). - exact (make_enrichment_over_poset C). - exact enrichment_over_poset_weq_poset_enrichment_inv_1. - exact enrichment_over_poset_weq_poset_enrichment_inv_2. Defined. (** 4. Elementary definition of poset enriched functors *) Definition functor_poset_enrichment {C₁ C₂ : category} (P₁ : poset_enrichment C₁) (P₂ : poset_enrichment C₂) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁) (f g : x --> y), P₁ x y f g → P₂ (F x) (F y) (#F f) (#F g). (** 5. Equivalence of functor enrichments with elementary definition *) Definition make_functor_poset_enrichment {C₁ C₂ : category} (P₁ : poset_enrichment C₁) (P₂ : poset_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_enrichment F (make_enrichment_over_poset C₁ P₁) (make_enrichment_over_poset C₂ P₂)) : functor_poset_enrichment P₁ P₂ F. Proof. intros x y f g p. pose (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr HF f)) tt) as pf. pose (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr HF g)) tt) as pg. cbn in pf, pg. rewrite pf, pg. exact (pr2 (HF x y) f g p). Qed. Definition make_functor_enrichment_over_poset {C₁ C₂ : category} (P₁ : poset_enrichment C₁) (P₂ : poset_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_poset_enrichment P₁ P₂ F) : functor_enrichment F (make_enrichment_over_poset C₁ P₁) (make_enrichment_over_poset C₂ P₂). Proof. simple refine (_ ,, _). - refine (λ x y, (λ f, #F f) ,, λ f g p, _). exact (HF x y f g p). - repeat split. + abstract (intros x ; use eq_monotone_function ; intro w ; cbn ; apply functor_id). + abstract (intros x y z ; use eq_monotone_function ; intro w ; cbn ; apply functor_comp). + abstract (intros x y z ; use eq_monotone_function ; intro w ; cbn ; apply idpath). Defined. Definition functor_enrichment_over_poset_weq_poset_enrichment {C₁ C₂ : category} (P₁ : poset_enrichment C₁) (P₂ : poset_enrichment C₂) (F : C₁ ⟶ C₂) : functor_enrichment F (make_enrichment_over_poset C₁ P₁) (make_enrichment_over_poset C₂ P₂) ≃ functor_poset_enrichment P₁ P₂ F. Proof. use weq_iso. - exact (make_functor_poset_enrichment P₁ P₂ F). - exact (make_functor_enrichment_over_poset P₁ P₂ F). - abstract (intro EF ; use subtypePath ; [ intro ; apply isaprop_is_functor_enrichment | ] ; use funextsec ; intro x ; use funextsec ; intro y ; use eq_monotone_function ; intro f ; cbn ; exact (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr EF f)) tt)). - abstract (intros EF ; use funextsec ; intro x ; use funextsec ; intro y ; use funextsec ; intro f ; use funextsec ; intro g ; use funextsec ; intro p ; apply propproperty). Defined. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/ProductEnriched.v000066400000000000000000000741171451125700300272210ustar00rootroot00000000000000(********************************************************************************* Product of enriched categories We show that the product of enriched categories is again enriched over the same monoidal category. For this, we assume that the monoidal category is cartesian. Note that this is different from what is usual in enriched category theory. Suppose that we have two category `E₁` and `E₂` enriched over some monoidal category `V`. Their product is usually defined as follows: - Objects: pairs `x : E₁` and y : E₂` - Morphisms from `(x₁ ,, y₁)` to `(x₂ ,, y₂)` are given by ``` E₁ ⦃ x₁ , x₂ ⦄ ⊗ E₂ ⦃ y₁ , y₂ ⦄ ``` To guarantee that the composition can be defined, we need to assume that `V` is symmetric. In our setting, we would like the construction to be compatible with univalence. As such, the isomorphisms are determined: by univalence, isomorphisms from `(x₁ ,, y₁)` to `(x₂ ,, y₂)` should be the same as pairs of isomorphisms from `x₁` to `x₂` and `y₁` to `y₂`. For that reason, we would like the morphisms in the product to be pairs of morphisms in `E₁` and in `E₂`. This is not the case in general for arbitrary monoidal categories. For example, if we look at the category of abelian groups with the tensor product, then morphisms in the product are not necessarily pairs of morphisms. For that reason, we assume that `V` is cartesian, which is sufficient to guarantee that the morphisms in the product are pairs of morphisms. *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section ProductEnrichment. Context (V : monoidal_cat) (HV : is_cartesian V) {C₁ C₂ : category} (E₁ : enrichment C₁ V) (E₂ : enrichment C₂ V). Definition product_enrichment_hom (x₁ y₁ : C₁) (x₂ y₂ : C₂) : V := (E₁ ⦃ x₁ , y₁ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄). Definition product_enrichment_id (x₁ : C₁) (x₂ : C₂) : I_{V} --> product_enrichment_hom x₁ x₁ x₂ x₂. Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (enriched_id E₁ x₁). - exact (enriched_id E₂ x₂). Defined. Proposition product_enrichment_id_pr1 (x₁ : C₁) (x₂ : C₂) : product_enrichment_id x₁ x₂ · semi_cart_tensor_pr1 HV _ _ = enriched_id E₁ x₁. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Proposition product_enrichment_id_pr2 (x₁ : C₁) (x₂ : C₂) : product_enrichment_id x₁ x₂ · semi_cart_tensor_pr2 HV _ _ = enriched_id E₂ x₂. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Definition product_enrichment_pr1_comp (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ --> (E₁ ⦃ y₁, z₁ ⦄) ⊗ (E₁ ⦃ x₁, y₁ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _). - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _). Defined. Proposition product_enrichment_pr1_comp_pr1 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr1 HV _ _ = semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Proposition product_enrichment_pr1_comp_pr2 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr2 HV _ _ = semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Definition product_enrichment_pr2_comp (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ --> (E₂ ⦃ y₂, z₂ ⦄) ⊗ (E₂ ⦃ x₂, y₂ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _). - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _). Defined. Proposition product_enrichment_pr2_comp_pr1 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr1 HV _ _ = semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Proposition product_enrichment_pr2_comp_pr2 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr2 HV _ _ = semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Definition product_enrichment_comp (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ --> product_enrichment_hom x₁ z₁ x₂ z₂. Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₁ x₁ y₁ z₁). - exact (product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₂ x₂ y₂ z₂). Defined. Proposition product_enrichment_comp_pr1 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr1 HV _ _ = product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₁ x₁ y₁ z₁. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Proposition product_enrichment_comp_pr2 (x₁ y₁ z₁ : C₁) (x₂ y₂ z₂ : C₂) : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ · semi_cart_tensor_pr2 HV _ _ = product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₂ x₂ y₂ z₂. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Definition product_enrichment_from_arr {x₁ y₁ : C₁} {x₂ y₂ : C₂} (f : x₁ --> y₁) (g : x₂ --> y₂) : I_{V} --> product_enrichment_hom x₁ y₁ x₂ y₂. Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (enriched_from_arr E₁ f). - exact (enriched_from_arr E₂ g). Defined. Proposition product_enrichment_from_arr_pr1 {x₁ y₁ : C₁} {x₂ y₂ : C₂} (f : x₁ --> y₁) (g : x₂ --> y₂) : product_enrichment_from_arr f g · semi_cart_tensor_pr1 HV _ _ = enriched_from_arr E₁ f. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Proposition product_enrichment_from_arr_pr2 {x₁ y₁ : C₁} {x₂ y₂ : C₂} (f : x₁ --> y₁) (g : x₂ --> y₂) : product_enrichment_from_arr f g · semi_cart_tensor_pr2 HV _ _ = enriched_from_arr E₂ g. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). Qed. Definition product_enrichment_to_arr {x₁ y₁ : C₁} {x₂ y₂ : C₂} (fg : I_{V} --> product_enrichment_hom x₁ y₁ x₂ y₂) : (x₁ --> y₁) × (x₂ --> y₂) := enriched_to_arr E₁ (fg · semi_cart_tensor_pr1 HV _ _) ,, enriched_to_arr E₂ (fg · semi_cart_tensor_pr2 HV _ _). Definition triple_pr1_pr1 (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ ⊗ product_enrichment_hom w₁ x₁ w₂ x₂ --> (E₁ ⦃ y₁ , z₁ ⦄) ⊗ (E₁ ⦃ x₁ , y₁ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _). Defined. Definition triple_pr1 (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ ⊗ product_enrichment_hom w₁ x₁ w₂ x₂ --> (E₁ ⦃ y₁ , z₁ ⦄) ⊗ (E₁ ⦃ x₁ , y₁ ⦄) ⊗ (E₁ ⦃ w₁ , x₁ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - apply triple_pr1_pr1. - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _). Defined. Proposition triple_pr1_eq (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ #⊗ identity _ · product_enrichment_pr1_comp w₁ x₁ z₁ w₂ x₂ z₂ = triple_pr1 _ _ _ _ _ _ _ _ · enriched_comp E₁ x₁ y₁ z₁ #⊗ identity _. Proof. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. - rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. rewrite !assoc. rewrite cartesian_tensor_pr1. rewrite !assoc'. rewrite product_enrichment_comp_pr1. refine (!_). etrans. { apply maponpaths. apply cartesian_tensor_pr1. } rewrite !assoc. apply maponpaths_2. etrans. { apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. + etrans. { apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. apply idpath. + etrans. { apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. apply idpath. - rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. rewrite !assoc. rewrite cartesian_tensor_pr2. rewrite !assoc'. rewrite id_left. refine (!_). etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite id_right. etrans. { apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply idpath. Qed. Definition triple_pr2_pr1 (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ ⊗ product_enrichment_hom w₁ x₁ w₂ x₂ --> (E₂ ⦃ y₂ , z₂ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _). - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _). Defined. Definition triple_pr2 (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂ ⊗ product_enrichment_hom w₁ x₁ w₂ x₂ --> (E₂ ⦃ y₂ , z₂ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄) ⊗ (E₂ ⦃ w₂ , x₂ ⦄). Proof. use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)). - apply triple_pr2_pr1. - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _). Defined. Proposition triple_pr2_eq (w₁ x₁ y₁ z₁ : C₁) (w₂ x₂ y₂ z₂ : C₂) : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ #⊗ identity _ · product_enrichment_pr2_comp w₁ x₁ z₁ w₂ x₂ z₂ = triple_pr2 _ _ _ _ _ _ _ _ · enriched_comp E₂ x₂ y₂ z₂ #⊗ identity _. Proof. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. - rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. rewrite !assoc. rewrite cartesian_tensor_pr1. rewrite !assoc'. rewrite product_enrichment_comp_pr2. refine (!_). etrans. { apply maponpaths. apply cartesian_tensor_pr1. } rewrite !assoc. apply maponpaths_2. etrans. { apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. + etrans. { apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. apply idpath. + etrans. { apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. apply idpath. - rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. rewrite !assoc. rewrite cartesian_tensor_pr2. rewrite !assoc'. rewrite id_left. refine (!_). etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite id_right. etrans. { apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply idpath. Qed. Definition product_enrichment_data : enrichment_data (category_binproduct C₁ C₂) V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ xy₁ xy₂, product_enrichment_hom (pr1 xy₁) (pr1 xy₂) (pr2 xy₁) (pr2 xy₂)). - exact (λ xy, product_enrichment_id (pr1 xy) (pr2 xy)). - exact (λ xy₁ xy₂ xy₃, product_enrichment_comp _ _ _ _ _ _). - exact (λ xy₁ xy₂ fg, product_enrichment_from_arr (pr1 fg) (pr2 fg)). - exact (λ xy₁ xy₂ fg, product_enrichment_to_arr fg). Defined. Proposition product_enrichment_laws : enrichment_laws product_enrichment_data. Proof. repeat split. - intros xy₁ xy₂. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)). + cbn. refine (mon_lunitor_pr1 _ _ _ @ _). rewrite enrichment_id_left. rewrite !assoc'. rewrite product_enrichment_comp_pr1. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite !assoc'. etrans. { apply maponpaths. apply product_enrichment_id_pr1. } rewrite !assoc. apply maponpaths_2. rewrite cartesian_tensor_pr1. rewrite id_right. apply idpath. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite id_right. refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr2. } rewrite id_right. rewrite cartesian_tensor_pr2. apply idpath. + cbn. refine (mon_lunitor_pr2 _ _ _ @ _). rewrite enrichment_id_left. rewrite !assoc'. rewrite product_enrichment_comp_pr2. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite !assoc'. etrans. { apply maponpaths. apply product_enrichment_id_pr2. } rewrite !assoc. apply maponpaths_2. rewrite cartesian_tensor_pr1. rewrite id_right. apply idpath. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite id_right. refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr2. } rewrite id_right. rewrite cartesian_tensor_pr2. apply idpath. - intros xy₁ xy₂. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)). + cbn. refine (mon_runitor_pr1 _ _ _ @ _). rewrite enrichment_id_right. rewrite !assoc'. rewrite product_enrichment_comp_pr1. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite !assoc'. rewrite id_left, id_right. rewrite cartesian_tensor_pr1. apply idpath. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite !assoc. rewrite !cartesian_tensor_pr2. rewrite id_right. rewrite !assoc'. apply maponpaths. refine (!_). apply product_enrichment_id_pr1. + cbn. refine (mon_runitor_pr2 _ _ _ @ _). rewrite enrichment_id_right. rewrite !assoc'. rewrite product_enrichment_comp_pr2. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite !assoc'. rewrite id_left, id_right. rewrite cartesian_tensor_pr1. apply idpath. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite !assoc. rewrite !cartesian_tensor_pr2. rewrite id_right. rewrite !assoc'. apply maponpaths. refine (!_). apply product_enrichment_id_pr2. - intros w x y z. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. + rewrite !assoc'. rewrite !product_enrichment_comp_pr1. rewrite !assoc. rewrite triple_pr1_eq. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. etrans. { do 2 apply maponpaths. apply cartesian_tensor_pr1. } rewrite id_right. rewrite mon_lassociator_pr1. rewrite product_enrichment_pr1_comp_pr1. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite id_right. rewrite !assoc. rewrite mon_lassociator_pr1. refine (!_). etrans. { apply maponpaths_2. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). * rewrite !assoc'. etrans. { do 2 apply maponpaths. apply cartesian_tensor_pr2. } rewrite product_enrichment_pr1_comp_pr2. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_tensor_pr2. } rewrite !assoc'. rewrite product_enrichment_comp_pr1. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite mon_lassociator_pr2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. ** rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr1. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } rewrite !assoc. etrans. { apply maponpaths_2. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). ** rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite !assoc. etrans. { apply maponpaths_2. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !id_right. apply idpath. + rewrite !assoc'. rewrite !product_enrichment_comp_pr2. rewrite !assoc. rewrite triple_pr2_eq. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. etrans. { do 2 apply maponpaths. apply cartesian_tensor_pr1. } rewrite id_right. rewrite mon_lassociator_pr1. rewrite product_enrichment_pr2_comp_pr1. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_tensor_pr1. } rewrite id_right. rewrite !assoc. rewrite mon_lassociator_pr1. refine (!_). etrans. { apply maponpaths_2. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). * rewrite !assoc'. etrans. { do 2 apply maponpaths. apply cartesian_tensor_pr2. } rewrite product_enrichment_pr2_comp_pr2. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_tensor_pr2. } rewrite !assoc'. rewrite product_enrichment_comp_pr2. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite mon_lassociator_pr2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. ** rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr1. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_tensor_pr1. } rewrite !assoc. etrans. { apply maponpaths_2. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). ** rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_tensor_pr2. } rewrite !assoc. etrans. { apply maponpaths_2. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)). } rewrite !id_right. apply idpath. - intros x y f ; cbn. use pathsdirprod. + rewrite product_enrichment_from_arr_pr1. rewrite enriched_to_from_arr. apply idpath. + rewrite product_enrichment_from_arr_pr2. rewrite enriched_to_from_arr. apply idpath. - intros x y f ; cbn. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. + refine (product_enrichment_from_arr_pr1 _ _ @ _). apply enriched_from_to_arr. + refine (product_enrichment_from_arr_pr2 _ _ @ _). apply enriched_from_to_arr. - intros x ; cbn. use pathsdirprod. + rewrite product_enrichment_id_pr1. apply enriched_to_arr_id. + rewrite product_enrichment_id_pr2. apply enriched_to_arr_id. - intros x y z f g ; cbn. use pathsdirprod. + rewrite (enriched_to_arr_comp E₁). apply maponpaths. rewrite !assoc'. apply maponpaths. rewrite product_enrichment_comp_pr1. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr1. rewrite !assoc. rewrite !cartesian_tensor_pr1. rewrite !assoc'. refine (cartesian_tensor_pr1 _ _ _ @ _). apply maponpaths. refine (!_). apply product_enrichment_from_arr_pr1. * rewrite !assoc'. rewrite product_enrichment_pr1_comp_pr2. rewrite !assoc. rewrite !cartesian_tensor_pr2. rewrite !assoc'. refine (cartesian_tensor_pr2 _ _ _ @ _). apply maponpaths. refine (!_). apply product_enrichment_from_arr_pr1. + rewrite (enriched_to_arr_comp E₂). apply maponpaths. rewrite !assoc'. apply maponpaths. rewrite product_enrichment_comp_pr2. rewrite !assoc. apply maponpaths_2. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr1. rewrite !assoc. rewrite !cartesian_tensor_pr1. rewrite !assoc'. refine (cartesian_tensor_pr1 _ _ _ @ _). apply maponpaths. refine (!_). apply product_enrichment_from_arr_pr2. * rewrite !assoc'. rewrite product_enrichment_pr2_comp_pr2. rewrite !assoc. rewrite !cartesian_tensor_pr2. rewrite !assoc'. refine (cartesian_tensor_pr2 _ _ _ @ _). apply maponpaths. refine (!_). apply product_enrichment_from_arr_pr2. Qed. Definition product_enrichment : enrichment (category_binproduct C₁ C₂) V := product_enrichment_data ,, product_enrichment_laws. End ProductEnrichment. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/SelfEnriched.v000066400000000000000000000362751451125700300264750ustar00rootroot00000000000000(******************************************************************** Self-enriched categories We show that every symmetric monoidal category can be enriched over itself. We also show that every strong monad gives rise to an enriched monad. Contents 1. Self-enrichment 2. Strong monad to enriched monad ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.StrongMonad. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section SelfEnrichment. Context (V : sym_mon_closed_cat). (** 1. Self-enrichment *) Definition self_enrichment_data : enrichment_data V V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, x ⊸ y). - exact internal_id. - exact internal_comp. - exact (@internal_from_arr V). - exact (@internal_to_arr V). Defined. Proposition self_enrichment_laws : enrichment_laws self_enrichment_data. Proof. repeat split. - exact internal_id_left. - exact internal_id_right. - exact internal_assoc. - exact (@internal_to_from_arr V). - exact (@internal_from_to_arr V). - exact internal_to_arr_id. - exact (@internal_to_arr_comp V). Qed. Definition self_enrichment : enrichment V V. Proof. simple refine (_ ,, _). - exact self_enrichment_data. - exact self_enrichment_laws. Defined. Proposition self_enrichment_postcomp {w x y : V} (f : x --> y) : postcomp_arr self_enrichment w f = internal_lam (internal_eval _ _ · f). Proof. use internal_funext. intros a h. unfold postcomp_arr ; cbn. rewrite !tensor_comp_r_id_r. etrans. { rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite internal_beta. rewrite !assoc. rewrite tensor_lunitor. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite mon_linvunitor_lunitor. apply idpath. } refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply idpath. Qed. Proposition self_enrichment_precomp {x y z : V} (f : x --> y) : precomp_arr self_enrichment z f = internal_lam (identity _ #⊗ f · internal_eval _ _). Proof. use internal_funext. intros a h. unfold precomp_arr ; cbn. rewrite !tensor_comp_r_id_r. etrans. { rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. unfold internal_from_arr. rewrite internal_beta. rewrite tensor_comp_id_l. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite <- mon_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite mon_rinvunitor_runitor. apply idpath. } refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply idpath. Qed. (** 2. Strong monad to enriched monad *) Section StrengthToFunctorEnrichment. Context {F : V ⟶ V} (tF : left_strength F). Proposition strength_to_enrichment_laws : @is_functor_enrichment _ _ _ F self_enrichment self_enrichment (λ x y, internal_lam (tF (internal_hom x y) x · # F (internal_eval x y))). Proof. repeat split. - intros x ; cbn. use internal_funext. intros w h. refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. unfold internal_id. rewrite internal_beta. rewrite tensor_lunitor. apply idpath. } refine (!_). rewrite tensor_split. rewrite tensor_comp_id_r. rewrite !assoc'. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite <- functor_id. rewrite (left_strength_natural tF). rewrite !assoc'. rewrite <- functor_comp. unfold internal_id. rewrite internal_beta. rewrite left_strength_mon_lunitor. apply idpath. } rewrite tensor_lunitor. apply idpath. - intros x y z ; cbn. use internal_funext. intros w h. etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. apply idpath. } etrans. { rewrite !assoc. etrans. { apply maponpaths_2. rewrite tensor_split. rewrite <- functor_id. rewrite !assoc'. rewrite left_strength_natural. apply idpath. } rewrite !assoc'. rewrite <- !functor_comp. unfold internal_comp. rewrite internal_beta. apply idpath. } refine (!_). etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply maponpaths_2. apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !tensor_comp_id_l. rewrite !assoc. rewrite <- tensor_lassociator. rewrite tensor_id_id. rewrite !assoc'. etrans. { apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite left_strength_natural. apply idpath. } rewrite !assoc. rewrite <- left_strength_mon_lassociator. apply idpath. } rewrite !assoc'. rewrite <- !functor_comp. apply idpath. - intros x y f ; cbn. use internal_funext. intros w h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). etrans. { rewrite tensor_split. rewrite <- functor_id. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite left_strength_natural. rewrite !assoc'. rewrite <- functor_comp. unfold internal_from_arr. rewrite internal_beta. rewrite functor_comp. rewrite !assoc. rewrite left_strength_mon_lunitor. apply idpath. } rewrite !assoc. rewrite tensor_lunitor. refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite internal_beta. rewrite !assoc. rewrite tensor_lunitor. apply idpath. } apply idpath. Qed. Definition strength_to_enrichment : functor_enrichment F self_enrichment self_enrichment. Proof. simple refine (_ ,, _). - exact (λ x y, internal_lam (tF _ _ · #F (internal_eval x y))). - exact strength_to_enrichment_laws. Defined. End StrengthToFunctorEnrichment. Section StrengthToMonadEnrichment. Context {M : Monad V} (tM : left_strong_monad M). Proposition monad_left_strong_to_enrichment_eta : nat_trans_enrichment (η M) (functor_id_enrichment self_enrichment) (strength_to_enrichment tM). Proof. intros x y ; cbn. use internal_funext. intros w h. etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite <- tensor_comp_mor. rewrite id_right. unfold internal_from_arr. rewrite internal_beta. apply idpath. } etrans. { rewrite !assoc'. do 2 apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } etrans. { apply maponpaths. rewrite tensor_comp_id_l. rewrite !assoc. rewrite <- mon_triangle. apply idpath. } etrans. { rewrite !assoc. rewrite <- tensor_comp_mor. rewrite mon_rinvunitor_runitor. rewrite id_right. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. } refine (!_). etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_id_id. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite internal_beta. rewrite !assoc. rewrite tensor_lunitor. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite mon_linvunitor_lunitor. apply idpath. } rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. refine (nat_trans_ax (η M) _ _ (internal_eval x y) @ _). rewrite !assoc. apply maponpaths_2. refine (!_). apply (left_strong_monad_unit tM). Qed. Proposition monad_left_strong_to_enrichment_mu : nat_trans_enrichment (μ M) (functor_comp_enrichment (strength_to_enrichment tM) (strength_to_enrichment tM)) (strength_to_enrichment tM). Proof. intros x y ; cbn. use internal_funext. intros w h. etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. unfold internal_from_arr. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite tensor_comp_id_l. etrans. { apply maponpaths. rewrite !assoc. rewrite <- mon_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite mon_rinvunitor_runitor. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. apply left_strong_monad_mu. } etrans. { rewrite !assoc'. do 3 apply maponpaths. exact (!(nat_trans_ax (μ M) _ _ (internal_eval x y))). } refine (!_). etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite tensor_split. unfold internal_from_arr. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_lunitor. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite mon_linvunitor_lunitor. apply idpath. } cbn. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite <- functor_id. rewrite left_strength_natural. rewrite !assoc'. apply maponpaths. rewrite <- !functor_comp. apply maponpaths. rewrite internal_beta. apply idpath. Qed. Definition monad_left_strong_to_enrichment : monad_enrichment self_enrichment M := strength_to_enrichment tM ,, monad_left_strong_to_enrichment_eta ,, monad_left_strong_to_enrichment_mu. End StrengthToMonadEnrichment. End SelfEnrichment. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/SetEnriched.v000066400000000000000000000176571451125700300263420ustar00rootroot00000000000000(***************************************************************** Enrichment over the category of sets One of the simplest categories over which we can study enrichments is the category of sets. In this file, we show that enrichments over the category of sets exist and that they are unique. From that, we conclude that the notions of category, functor, and natural transformations are equivalent to their enrichment counterpart if we look at enrichments over the category of sets. Contents 1. Enrichments over sets are unique for categories 2. Enrichments over sets are unique for functors 3. Enrichments over sets are unique for natural transformations *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Examples.SetCartesianMonoidal. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Proposition set_faithful_moncat : faithful_moncat SET_monoidal_cat. Proof. intros X Y f g p. use funextsec. intro x. exact (eqtohomot (p (λ _, x)) tt). Qed. Proposition set_conservative_moncat : conservative_moncat SET_monoidal_cat. Proof. intros X Y f Hf. use (hset_equiv_is_z_iso _ _ (_ ,, _)). use isweq_iso. - exact (λ y, invmap (_ ,, Hf) (λ _, y) tt). - abstract (intros x ; exact (eqtohomot (homotinvweqweq (_ ,, Hf) (λ _, x)) tt)). - abstract (intros y ; exact (eqtohomot (homotweqinvweq (_ ,, Hf) (λ _, y)) tt)). Defined. (** 1. Enrichments over sets are unique for categories *) Section UniqueSetEnrichment. Context (C : category). Definition set_enrichment_data : enrichment_data C SET_monoidal_cat. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, make_hSet (x --> y) (homset_property C x y)). - exact (λ x _, identity x). - exact (λ x y z fg, pr2 fg · pr1 fg). - exact (λ x y f _, f). - exact (λ x y f, f tt). Defined. Proposition set_enrichment_laws : enrichment_laws set_enrichment_data. Proof. repeat split. - intros x y. use funextsec ; intro ; cbn. rewrite id_right. apply idpath. - intros x y. use funextsec ; intro ; cbn. rewrite id_left. apply idpath. - intros w x y z. use funextsec ; intro ; cbn. apply assoc. - intros x y f. use funextsec ; intro w ; cbn. apply maponpaths. apply isapropunit. Qed. Definition set_enrichment : enrichment C SET_monoidal_cat. Proof. simple refine (_ ,, _). - exact set_enrichment_data. - exact set_enrichment_laws. Defined. Theorem iscontr_set_enrichment : iscontr (enrichment C SET_monoidal_cat). Proof. refine (set_enrichment ,, _). intro E. use subtypePath. { intro. apply isaprop_enrichment_laws. } use (invweq (total2_paths_equiv _ _ _)). use (invmap (enrichment_data_hom_path _ (pr1 E) set_enrichment_data)). { exact is_univalent_HSET. } simple refine (_ ,, _ ,, _ ,, _ ,, _). - intros x y. use make_z_iso. + exact (λ f, enriched_to_arr E (λ _, f)). + exact (λ f, enriched_from_arr E f tt). + split. * use funextsec ; intro f ; cbn. rewrite enriched_from_to_arr. apply idpath. * use funextsec ; intro f ; cbn. refine (_ @ enriched_to_from_arr E _). apply maponpaths. use funextsec. intro z. apply maponpaths. apply isapropunit. - intro x ; use funextsec ; intro f ; cbn. refine (_ @ enriched_to_arr_id E _). apply maponpaths. use funextsec. intro z. apply maponpaths. apply isapropunit. - intros x y z ; use funextsec ; intro f ; cbn. use (invmaponpathsweq (invweq (_ ,, isweq_enriched_to_arr E _ _))) ; cbn. rewrite enriched_from_arr_comp ; cbn. rewrite !enriched_from_to_arr. apply idpath. - intros x y f ; use funextsec ; intro w ; cbn. refine (_ @ enriched_to_from_arr E _). apply maponpaths. use funextsec. intro z. apply maponpaths. apply isapropunit. - intros x y f ; cbn. apply maponpaths. use funextsec. intro z. apply maponpaths. apply isapropunit. Qed. End UniqueSetEnrichment. Definition cat_with_set_enrichment_weq_cat : cat_with_enrichment SET_monoidal_cat ≃ category. Proof. use weqpr1. intro. apply iscontr_set_enrichment. Defined. (** 2. Enrichments over sets are unique for functors *) Section UniqueFunctorSetEnrichment. Context {C₁ C₂ : category} (F : C₁ ⟶ C₂). Definition functor_set_enrichment : functor_enrichment F (set_enrichment C₁) (set_enrichment C₂). Proof. simple refine (_ ,, _). - exact (λ x y f, #F f). - repeat split. + abstract (intro x ; cbn ; use funextsec ; intro ; apply functor_id). + abstract (intros x y f ; cbn ; use funextsec ; intro ; apply functor_comp). Defined. Theorem iscontr_functor_set_enrichment : iscontr (functor_enrichment F (set_enrichment C₁) (set_enrichment C₂)). Proof. refine (functor_set_enrichment ,, _). intro EF. use subtypePath. { intro. apply isaprop_is_functor_enrichment. } use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. cbn. exact (!(eqtohomot (functor_enrichment_from_arr EF f) tt)). Qed. End UniqueFunctorSetEnrichment. Definition functor_with_set_enrichment_weq_functor (C₁ C₂ : category) : functor_with_enrichment (C₁ ,, set_enrichment C₁) (C₂ ,, set_enrichment C₂) ≃ C₁ ⟶ C₂. Proof. use weqpr1. intro. apply iscontr_functor_set_enrichment. Defined. (** 3. Enrichments over sets are unique for natural transformations *) Section UniqueNatTransSetEnrichment. Context {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (τ : F ⟹ G). Definition nat_trans_set_enrichment : nat_trans_enrichment τ (functor_set_enrichment F) (functor_set_enrichment G). Proof. intros x y ; cbn. use funextsec ; intro f ; cbn. exact (!(nat_trans_ax τ _ _ f)). Qed. Theorem iscontr_nat_trans_set_enrichment : iscontr (nat_trans_enrichment τ (functor_set_enrichment F) (functor_set_enrichment G)). Proof. refine (nat_trans_set_enrichment ,, _). intro. apply isaprop_nat_trans_enrichment. Qed. End UniqueNatTransSetEnrichment. Definition nat_trans_with_set_enrichment_weq_nat_trans {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : @nat_trans_with_enrichment _ (C₁ ,, set_enrichment C₁) (C₂ ,, set_enrichment C₂) (F ,, functor_set_enrichment F) (G ,, functor_set_enrichment G) ≃ F ⟹ G. Proof. use weq_iso. - exact (λ τ, pr1 τ ,, is_nat_trans_from_enrichment (pr2 τ)). - exact (λ τ, pr1 τ ,, nat_trans_set_enrichment τ). - abstract (intro τ ; use eq_nat_trans_with_enrichment ; intro x ; cbn ; apply idpath). - abstract (intro τ ; use nat_trans_eq ; [ apply homset_property | ] ; intro x ; cbn ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/SliceEnriched.v000066400000000000000000000154001451125700300266260ustar00rootroot00000000000000(********************************************************************** Enriched slice categories In this file, we define enriched slice categories. The approach that we take, is based on the fact that slice categories can be defined using dialgebras. As such, we can reuse the fact that we already showed that the category of dialgebras has an enrichment, and we can specialize that to obtain an enrichment for slice categories. Let's be more specific. Suppose that we have a category `C` and an object `x` in `C`. To construct the slice category `C/x` we take the category of dialgebras between the identity and the functor that is constantly `x`. As such, the objects of this category are pairs of an object `a` in `C` together with a morphism `a --> x`. As such, this corresponds to objects in the slice category `C/x`. The same can be said for morphisms. Note that we assume that the monoidal category `V` has equalizers and that the unit is terminal. The reason for that, is because of how morphisms in the slice category are defined. If we have two objects `f : a --> x` and `g : b --> x` in the slice `C/x`, then a morphism from `f` to `g` consists of a morphism `h : a --> b` such that we have `f = g · h`. Equalizers are used to o encode the commutativity requirement. If one were to define it concretely, one would take the equalizer of the following diagram ``` h ↦ h · g ------------> a --> b a --> x ----> 𝟙 ----> f ``` Instead of this concrete definition, we reuse that we already defined the enriched category of dialgebras. Contents 1. Enrichment for slice categories 2. An equivalence between dialgebras and the slice **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.terminal. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedSlice. Context (V : monoidal_cat) (HV𝟙 : isTerminal V (I_{V})) (HV : Equalizers V) {C : category} (E : enrichment C V) (x : C). (** 1. Enrichment for slice categories *) Definition slice_cat_enrichment : enrichment (dialgebra (functor_identity C) (constant_functor C C x)) V := dialgebra_enrichment V HV (functor_id_enrichment E) (functor_constant_enrichment HV𝟙 x E E). (** 2. An equivalence between dialgebras and the slice *) Definition dialgebra_to_slice_data : functor_data (dialgebra (functor_identity C) (constant_functor C C x)) (slice_cat C x). Proof. use make_functor_data. - exact (λ x, x). - refine (λ x y f, pr1 f ,, _) ; cbn. abstract (exact (!(id_right _) @ pr2 f)). Defined. Definition dialgebra_to_slice_is_functor : is_functor dialgebra_to_slice_data. Proof. repeat split. - intro ; intros. use subtypePath ; [ intro ; apply homset_property | ] ; cbn. apply idpath. - intro ; intros. use subtypePath ; [ intro ; apply homset_property | ] ; cbn. apply idpath. Qed. Definition dialgebra_to_slice : dialgebra (functor_identity C) (constant_functor C C x) ⟶ slice_cat C x. Proof. use make_functor. - exact dialgebra_to_slice_data. - exact dialgebra_to_slice_is_functor. Defined. Definition slice_to_dialgebra_data : functor_data (slice_cat C x) (dialgebra (functor_identity C) (constant_functor C C x)). Proof. use make_functor_data. - exact (λ x, x). - refine (λ x y f, pr1 f ,, _) ; cbn. abstract (exact (id_right _ @ pr2 f)). Defined. Definition slice_to_dialgebra_is_functor : is_functor slice_to_dialgebra_data. Proof. repeat split. - intro ; intros. use subtypePath ; [ intro ; apply homset_property | ] ; cbn. apply idpath. - intro ; intros. use subtypePath ; [ intro ; apply homset_property | ] ; cbn. apply idpath. Qed. Definition slice_to_dialgebra : slice_cat C x ⟶ dialgebra (functor_identity C) (constant_functor C C x). Proof. use make_functor. - exact slice_to_dialgebra_data. - exact slice_to_dialgebra_is_functor. Defined. Definition dialgebra_to_slice_unit : functor_identity _ ⟹ dialgebra_to_slice ∙ slice_to_dialgebra. Proof. use make_nat_trans. - refine (λ f, identity _ ,, _). abstract (cbn ; exact (id_right _ @ !(id_left _))). - abstract (intros f₁ f₂ τ ; use subtypePath ; [ intro ; apply homset_property | ] ; cbn ; exact (id_right _ @ !(id_left _))). Defined. Definition dialgebra_to_slice_counit : slice_to_dialgebra ∙ dialgebra_to_slice ⟹ functor_identity _. Proof. use make_nat_trans. - refine (λ f, identity _ ,, _). abstract (cbn ; exact (!(id_left _))). - abstract (intros f₁ f₂ τ ; use subtypePath ; [ intro ; apply homset_property | ] ; cbn ; exact (id_right _ @ !(id_left _))). Defined. Definition dialgebra_to_slice_adj_equiv : adj_equivalence_of_cats dialgebra_to_slice. Proof. simple refine ((_ ,, ((_ ,, _) ,, _ ,, _)) ,, _ ,, _). - exact slice_to_dialgebra. - exact dialgebra_to_slice_unit. - exact dialgebra_to_slice_counit. - abstract (intros f ; use subtypePath ; [ intro ; apply homset_property | ] ; cbn ; apply id_left). - abstract (intros f ; use subtypePath ; [ intro ; apply homset_property | ] ; cbn ; apply id_left). - intro f. use is_z_iso_dialgebra. cbn. apply is_z_isomorphism_identity. - intro f. use z_iso_to_slice_precat_z_iso. cbn. apply is_z_isomorphism_identity. Defined. End EnrichedSlice. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/SmashStructureEnriched.v000066400000000000000000000655221451125700300305750ustar00rootroot00000000000000(***************************************************************** Enrichments over smash products In this file, we characterize enrichments over structures with smash products in more elementary terms. The idea is the same as for cartesian structures (see StructureEnriched.v), but there is one difference. This difference is caused by the fact that the smash product is a quotient. As such, this must be taken into account, and thus we get an additional requirement. Since the structurs we enrich over, are pointed, every homset has a distinguished point, which we call the zero morphism. The additional requirement says that composition with a zero morphism again gives a zero morphism. Contents 1. The monoidal category is faithful 2. Elementary definition of enrichment over structures 3. Equivalence between the two definitions of enrichments 4. Elementary definition of functor enrichments over structures 5. Equivalence between the two definition of functor enrichments *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.SmashProductMonoidal. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Local Open Scope cat. Section FixAStructureWithSmash. Context (P : hset_struct_with_smash_closed). (** 1. The monoidal category is faithful *) Definition category_of_smash_struct_faithful_moncat : faithful_moncat (smash_product_monoidal_cat P). Proof. intros R₁ R₂ f g p. use subtypePath. { intro ; cbn -[isaprop]. apply isaprop_hset_struct_on_mor. } use funextsec ; intro x. assert (mor_hset_struct P (pr2 (monoidal_unit (smash_product_monoidal_cat P))) (pr2 R₁) (pointed_hset_struct_map_from_unit P (pr2 R₁) x)) as H. { apply hset_struct_with_smash_map_from_unit. } exact (eqtohomot (maponpaths pr1 (p (_ ,, H))) true). Qed. (** 2. Elementary definition of enrichment over structures *) Definition smash_struct_enrichment_data (C : category) : UU := ∏ (x y : C), P (homset x y). Definition smash_struct_enrichment_point {C : category} (SC : smash_struct_enrichment_data C) (x y : C) : x --> y := hset_struct_point P (SC x y). Definition smash_struct_enrichment_laws {C : category} (SC : smash_struct_enrichment_data C) : UU := (∏ (x y z : C), mor_hset_struct P (hset_struct_prod P (SC y z) (SC x y)) (SC x z) (λ (fg : C ⟦ y, z ⟧ × C ⟦ x, y ⟧), pr2 fg · pr1 fg)) × (∏ (x y z : C) (f : x --> y), f · smash_struct_enrichment_point SC y z = smash_struct_enrichment_point SC x z) × (∏ (x y z : C) (f : y --> z), smash_struct_enrichment_point SC x y · f = smash_struct_enrichment_point SC x z). Proposition isaprop_smash_struct_enrichment_laws {C : category} (SC : smash_struct_enrichment_data C) : isaprop (smash_struct_enrichment_laws SC). Proof. repeat (use isapropdirprod) ; repeat (use impred ; intro). - apply isaprop_hset_struct_on_mor. - apply homset_property. - apply homset_property. Qed. Definition smash_struct_enrichment (C : category) : UU := ∑ (SC : smash_struct_enrichment_data C), smash_struct_enrichment_laws SC. Definition smash_struct_enrichment_to_data {C : category} (SC : smash_struct_enrichment C) (x y : C) : P (homset x y) := pr1 SC x y. Coercion smash_struct_enrichment_to_data : smash_struct_enrichment >-> Funclass. Proposition smash_struct_enrichment_comp {C : category} (SC : smash_struct_enrichment C) (x y z : C) : mor_hset_struct P (hset_struct_prod P (SC y z) (SC x y)) (SC x z) (λ (fg : C ⟦ y, z ⟧ × C ⟦ x, y ⟧), pr2 fg · pr1 fg). Proof. exact (pr12 SC x y z). Qed. Proposition smash_struct_enrichment_comp_point_l {C : category} (SC : smash_struct_enrichment C) (x y z : C) (f : x --> y) : f · smash_struct_enrichment_point SC y z = smash_struct_enrichment_point SC x z. Proof. exact (pr122 SC x y z f). Qed. Proposition smash_struct_enrichment_comp_point_r {C : category} (SC : smash_struct_enrichment C) (x y z : C) (f : y --> z) : smash_struct_enrichment_point SC x y · f = smash_struct_enrichment_point SC x z. Proof. exact (pr222 SC x y z f). Qed. (** 3. Equivalence between the two definitions of enrichments *) Section MakeSmashStructEnrichment. Context (C : category) (SC : smash_struct_enrichment C). Definition smash_struct_comp {x y z : C} : setquot (smash_eqrel (pr1 P) (pr12 P) (SC y z) (SC x y)) → homset x z. Proof. use map_from_smash. - exact (λ f g, g · f). - abstract (intros f₁ f₂ ; cbn ; rewrite !(smash_struct_enrichment_comp_point_l SC) ; apply idpath). - abstract (intros g f ; cbn ; rewrite !(smash_struct_enrichment_comp_point_l SC) ; rewrite !(smash_struct_enrichment_comp_point_r SC) ; apply idpath). - abstract (intros g₁ g₂ ; cbn ; rewrite !(smash_struct_enrichment_comp_point_r SC) ; apply idpath). Defined. Definition make_enrichment_over_smash_struct_data : enrichment_data C (smash_product_monoidal_cat P). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, _ ,, SC x y). - refine (λ x, pointed_hset_struct_map_from_unit P (SC x x) (identity _) ,, _). abstract (cbn ; apply hset_struct_with_smash_map_from_unit). - simple refine (λ x y z, _ ,, _). + exact smash_struct_comp. + use hset_struct_with_smash_map_from_smash. apply smash_struct_enrichment_comp. - refine (λ x y f, pointed_hset_struct_map_from_unit P (SC x y) f ,, _). abstract (cbn ; apply hset_struct_with_smash_map_from_unit). - exact (λ x y f, pr1 f true). Defined. Proposition make_enrichment_over_smash_struct_laws : enrichment_laws make_enrichment_over_smash_struct_data. Proof. repeat split. - intros x y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply homset_property | ]. intro a. induction a as [ b f ]. induction b ; cbn in *. + rewrite id_right. apply idpath. + rewrite (smash_struct_enrichment_comp_point_l SC). apply idpath. - intros x y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply homset_property | ]. intro a. induction a as [ f b ]. induction b ; cbn in *. + rewrite id_left. apply idpath. + rewrite (smash_struct_enrichment_comp_point_r SC). apply idpath. - intros w x y z. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply homset_property | ]. intro a. induction a as [ a h ]. revert a. use setquotunivprop' ; [ intro ; apply homset_property | ]. intro a. induction a as [ f g ] ; cbn in *. rewrite assoc. apply idpath. - intros x y f. use eq_mor_hset_struct. intro a. induction a ; cbn. + apply idpath. + rewrite <- (pointed_hset_struct_preserve_point _ (pr2 f)). apply maponpaths. apply hset_struct_with_smash_point_unit. Qed. Definition make_enrichment_over_smash_struct : enrichment C (smash_product_monoidal_cat P) := make_enrichment_over_smash_struct_data ,, make_enrichment_over_smash_struct_laws. End MakeSmashStructEnrichment. Section FromStructSmashEnrichment. Context (C : category) (E : enrichment C (smash_product_monoidal_cat P)). Definition mor_to_enriched_smash_hom {x y : C} (f : x --> y) : pr11 (E ⦃ x , y ⦄) := pr1 (enriched_from_arr E f) true. Definition enriched_smash_hom_to_mor {x y : C} (f : pr11 (E ⦃ x , y ⦄)) : x --> y. Proof. assert (mor_hset_struct P (pr2 (monoidal_unit (smash_product_monoidal_cat P))) (pr2 (E ⦃ x , y ⦄)) (pointed_hset_struct_map_from_unit P (pr2 (E ⦃ x , y ⦄)) f)) as H. { apply hset_struct_with_smash_map_from_unit. } exact (enriched_to_arr E (_ ,, H)). Defined. Definition mor_weq_enriched_smash_hom (x y : C) : pr11 (E ⦃ x , y ⦄) ≃ (x --> y). Proof. use weq_iso. - exact enriched_smash_hom_to_mor. - exact mor_to_enriched_smash_hom. - abstract (intro f ; unfold mor_to_enriched_smash_hom, enriched_smash_hom_to_mor ; rewrite enriched_from_to_arr ; apply idpath). - abstract (intro f ; unfold mor_to_enriched_smash_hom, enriched_smash_hom_to_mor ; refine (_ @ enriched_to_from_arr E f) ; apply maponpaths ; use eq_mor_hset_struct ; intro b ; cbn ; induction b ; [ apply idpath | ] ; cbn ; rewrite <- (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E f))) ; apply maponpaths ; apply hset_struct_with_smash_point_unit). Defined. Definition make_smash_struct_enrichment_data : smash_struct_enrichment_data C. Proof. intros x y. refine (transportf_struct_weq P _ (pr2 (E ⦃ x , y ⦄))). exact (mor_weq_enriched_smash_hom x y). Defined. Proposition enriched_from_arr_smash_lemma (x y : C) : pr1 (enriched_from_arr E (hset_struct_point P (make_smash_struct_enrichment_data x y))) true = hset_struct_point P (pr2 (E ⦃ x, y ⦄)). Proof. assert (mor_hset_struct P (pr2 (monoidal_unit (smash_product_monoidal_cat P))) (pr2 (E ⦃ x, y ⦄)) (pointed_hset_struct_map_from_unit P (pr2 (E ⦃ x, y ⦄)) (hset_struct_point P (pr2 (E ⦃ x, y ⦄))))) as H. { apply hset_struct_with_smash_map_from_unit. } refine (_ @ maponpaths (λ z, pr1 z true) (enriched_from_to_arr E (_ ,, H))). apply maponpaths_2. apply maponpaths. unfold make_smash_struct_enrichment_data. unfold transportf_struct_weq. rewrite transportf_hset_struct_point. cbn ; unfold enriched_smash_hom_to_mor. apply maponpaths. use eq_mor_hset_struct. intro ; cbn. apply idpath. Qed. Proposition make_smash_struct_enrichment_laws : smash_struct_enrichment_laws make_smash_struct_enrichment_data. Proof. repeat split. - intros x y z. use (transportf_struct_mor_prod_via_eq P). + exact (λ fg, pr1 (enriched_comp E x y z) (setquotpr _ fg)). + abstract (refine (hset_struct_comp P _ (pr2 (enriched_comp E x y z))) ; apply hset_struct_with_smash_setquotpr). + intros fg ; cbn. unfold enriched_smash_hom_to_mor. rewrite (enriched_to_arr_comp E). apply maponpaths. use eq_mor_hset_struct. intro b ; induction b ; cbn. * apply idpath. * pose (pointed_hset_struct_preserve_point P (pr2 (enriched_comp E x y z))) as p. refine (_ @ p). apply maponpaths. refine (_ @ !(hset_struct_with_smash_point_smash _ _ _)). use iscompsetquotpr. apply hinhpr. use inr. split ; unfold product_point_coordinate. ** use inr. cbn. rewrite <- (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E (pr2 fg)))). apply maponpaths. refine (!_). apply hset_struct_with_smash_point_unit. ** use inl. apply idpath. - intros x y z f. unfold smash_struct_enrichment_point. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. rewrite enriched_from_arr_comp. use subtypePath. { intro ; cbn -[isaprop]. apply isaprop_hset_struct_on_mor. } use funextsec ; intro a. cbn. induction a ; cbn. + rewrite !enriched_from_arr_smash_lemma. pose (pointed_hset_struct_preserve_point P (pr2 (enriched_comp E x y z))) as p. refine (_ @ p). apply maponpaths. refine (_ @ !(hset_struct_with_smash_point_smash _ _ _)). use iscompsetquotpr. apply hinhpr. use inr. split ; unfold product_point_coordinate. * use inl. apply idpath. * use inl. apply idpath. + refine (!_). etrans. { apply maponpaths. exact (!(hset_struct_with_smash_point_unit (pr122 P))). } refine (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E _)) @ _). refine (!_). pose (pointed_hset_struct_preserve_point P (pr2 (enriched_comp E x y z))) as p. refine (_ @ p). apply maponpaths. refine (_ @ !(hset_struct_with_smash_point_smash _ _ _)). use iscompsetquotpr. apply hinhpr. use inr. split ; unfold product_point_coordinate. * use inr. cbn. rewrite <- (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E f))). apply maponpaths. refine (!_). apply hset_struct_with_smash_point_unit. * use inl. apply idpath. - intros x y z f. unfold smash_struct_enrichment_point. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. rewrite enriched_from_arr_comp. use subtypePath. { intro ; cbn -[isaprop]. apply isaprop_hset_struct_on_mor. } use funextsec ; intro a. cbn. induction a ; cbn. + rewrite !enriched_from_arr_smash_lemma. pose (pointed_hset_struct_preserve_point P (pr2 (enriched_comp E x y z))) as p. refine (_ @ p). apply maponpaths. refine (_ @ !(hset_struct_with_smash_point_smash _ _ _)). use iscompsetquotpr. apply hinhpr. use inr. split ; unfold product_point_coordinate. * use inr. apply idpath. * use inl. apply idpath. + refine (!_). etrans. { apply maponpaths. exact (!(hset_struct_with_smash_point_unit (pr122 P))). } refine (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E _)) @ _). refine (!_). pose (pointed_hset_struct_preserve_point P (pr2 (enriched_comp E x y z))) as p. refine (_ @ p). apply maponpaths. refine (_ @ !(hset_struct_with_smash_point_smash _ _ _)). use iscompsetquotpr. apply hinhpr. use inr. split ; unfold product_point_coordinate. * use inr. cbn. etrans. { apply maponpaths. refine (!_). apply (hset_struct_with_smash_point_unit (pr122 P)). } exact (pointed_hset_struct_preserve_point _ (pr2 (enriched_from_arr E _))). * use inl. apply idpath. Qed. Definition make_smash_struct_enrichment : smash_struct_enrichment C. Proof. simple refine (_ ,, _). - exact make_smash_struct_enrichment_data. - exact make_smash_struct_enrichment_laws. Defined. End FromStructSmashEnrichment. Section SmashEnrichmentEquiv. Context {C : category} (E : enrichment C (smash_product_monoidal_cat P)). Definition enrichment_over_smash_struct_weq_struct_enrichment_iso (x y : C) : @z_iso (category_of_hset_struct P) (homset x y ,, make_smash_struct_enrichment_data C E x y) (E ⦃ x , y ⦄). Proof. use make_z_iso. - simple refine (_ ,, _). + exact (λ f, pr1 (enriched_from_arr E f) true). + cbn. apply transportf_struct_weq_on_invweq. - simple refine (_ ,, _). + refine (λ f, enriched_to_arr E (pointed_hset_struct_map_from_unit P (pr2 (E ⦃ x, y ⦄)) f ,, _)). apply hset_struct_with_smash_map_from_unit. + cbn. apply transportf_struct_weq_on_weq. - split. + use eq_mor_hset_struct. intro w ; cbn. refine (_ @ enriched_to_from_arr E _). apply maponpaths. use eq_mor_hset_struct. intro b. induction b ; cbn. * apply idpath. * refine (!(pointed_hset_struct_preserve_point P (pr2 (enriched_from_arr E w))) @ _). apply maponpaths. apply hset_struct_with_smash_point_unit. + use eq_mor_hset_struct. intro f. cbn. rewrite enriched_from_to_arr. apply idpath. Defined. Definition enrichment_over_smash_struct_weq_smash_struct_enrichment_inv_1 : make_enrichment_over_smash_struct C (make_smash_struct_enrichment C E) = E. Proof. use subtypePath. { intro. apply isaprop_enrichment_laws. } use (invweq (total2_paths_equiv _ _ _)). use (invmap (enrichment_data_hom_path _ _ _)). { exact (is_univalent_category_of_hset_struct P). } simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact enrichment_over_smash_struct_weq_struct_enrichment_iso. - intro x. use eq_mor_hset_struct. intro b. induction b ; cbn. + rewrite enriched_from_arr_id. apply idpath. + refine (!_). etrans. { apply maponpaths. refine (!_). apply (hset_struct_with_smash_point_unit (pr122 P)). } refine (pointed_hset_struct_preserve_point P (pr2 (enriched_id E x)) @ _). refine (!_). apply enriched_from_arr_smash_lemma. - intros x y z. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros fg ; cbn ; cbn in fg. induction fg as [ f g ]. rewrite enriched_from_arr_comp ; cbn. apply idpath. - intros x y f. use eq_mor_hset_struct. intro b. induction b ; cbn. + apply idpath. + refine (!_). etrans. { apply maponpaths. refine (!_). apply (hset_struct_with_smash_point_unit (pr122 P)). } refine (pointed_hset_struct_preserve_point P (pr2 (enriched_from_arr E f)) @ _). refine (!_). apply enriched_from_arr_smash_lemma. - intros x y f. refine (!(enriched_to_from_arr E (pr1 f true)) @ _). apply maponpaths. use eq_mor_hset_struct. intro b ; induction b. + cbn. apply idpath. + cbn. etrans. { apply maponpaths. refine (!_). apply (hset_struct_with_smash_point_unit (pr122 P)). } refine (pointed_hset_struct_preserve_point P (pr2 (enriched_from_arr E _)) @ _). refine (!_). etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (hset_struct_with_smash_point_unit (pr122 P)). } exact (pointed_hset_struct_preserve_point P (pr2 f)). } cbn. apply enriched_from_arr_smash_lemma. Qed. End SmashEnrichmentEquiv. Proposition enrichment_over_smash_struct_weq_smash_struct_enrichment_inv_2 {C : category} (E : smash_struct_enrichment C) : make_smash_struct_enrichment C (make_enrichment_over_smash_struct C E) = E. Proof. use subtypePath. { intro. apply isaprop_smash_struct_enrichment_laws. } use funextsec ; intro x. use funextsec ; intro y. simpl. unfold make_smash_struct_enrichment_data. unfold make_enrichment_over_smash_struct. simpl. unfold transportf_struct_weq. refine (_ @ idpath_transportf _ _). apply maponpaths_2. refine (_ @ univalence_hSet_idweq _). apply maponpaths. use subtypePath. { intro ; apply isapropisweq. } apply idpath. Qed. Definition enrichment_over_smash_struct_weq_smash_struct_enrichment (C : category) : enrichment C (smash_product_monoidal_cat P) ≃ smash_struct_enrichment C. Proof. use weq_iso. - exact (make_smash_struct_enrichment C). - exact (make_enrichment_over_smash_struct C). - apply enrichment_over_smash_struct_weq_smash_struct_enrichment_inv_1. - apply enrichment_over_smash_struct_weq_smash_struct_enrichment_inv_2. Defined. (** 4. Elementary definition of functor enrichments over structures *) Definition functor_smash_struct_enrichment {C₁ C₂ : category} (P₁ : smash_struct_enrichment C₁) (P₂ : smash_struct_enrichment C₂) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁), mor_hset_struct P (P₁ x y) (P₂ (F x) (F y)) (λ f, #F f). (** 5. Equivalence between the two definition of functor enrichments *) Definition make_functor_smash_struct_enrichment {C₁ C₂ : category} (P₁ : smash_struct_enrichment C₁) (P₂ : smash_struct_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_enrichment F (make_enrichment_over_smash_struct C₁ P₁) (make_enrichment_over_smash_struct C₂ P₂)) : functor_smash_struct_enrichment P₁ P₂ F. Proof. intros x y. refine (transportf _ _ (pr2 (HF x y))). use funextsec. intro f. pose (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr HF f)) true) as p. cbn in p. exact (!p). Qed. Definition make_functor_enrichment_over_smash_struct {C₁ C₂ : category} (P₁ : smash_struct_enrichment C₁) (P₂ : smash_struct_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_smash_struct_enrichment P₁ P₂ F) : functor_enrichment F (make_enrichment_over_smash_struct C₁ P₁) (make_enrichment_over_smash_struct C₂ P₂). Proof. simple refine (_ ,, _). - exact (λ x y, (λ f, #F f) ,, HF x y). - repeat split. + abstract (intros x ; use eq_mor_hset_struct ; intro b ; induction b ; cbn ; [ apply functor_id | ] ; exact (pointed_hset_struct_preserve_point _ (HF x x))). + abstract (intros x y z ; use eq_mor_hset_struct ; use setquotunivprop' ; [ intro ; apply homset_property | ] ; intros fg ; induction fg as [ f g ] ; apply functor_comp). + abstract (intros x y f ; use eq_mor_hset_struct ; intro b ; induction b ; cbn ; [ apply idpath | ] ; refine (!_) ; apply (pointed_hset_struct_preserve_point _ (HF x y))). Defined. Definition functor_enrichment_over_smash_struct_weq_smash_struct_enrichment {C₁ C₂ : category} (P₁ : smash_struct_enrichment C₁) (P₂ : smash_struct_enrichment C₂) (F : C₁ ⟶ C₂) : functor_enrichment F (make_enrichment_over_smash_struct C₁ P₁) (make_enrichment_over_smash_struct C₂ P₂) ≃ functor_smash_struct_enrichment P₁ P₂ F. Proof. use weq_iso. - exact (make_functor_smash_struct_enrichment P₁ P₂ F). - exact (make_functor_enrichment_over_smash_struct P₁ P₂ F). - abstract (intro EF ; use subtypePath ; [ intro ; apply isaprop_is_functor_enrichment | ] ; use funextsec ; intro x ; use funextsec ; intro y ; use eq_mor_hset_struct ; intro f ; cbn ; exact (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr EF f)) true)). - abstract (intros EF ; use funextsec ; intro x ; use funextsec ; intro y ; cbn ; apply isaprop_hset_struct_on_mor). Defined. End FixAStructureWithSmash. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/StructureEnriched.v000066400000000000000000000370401451125700300275730ustar00rootroot00000000000000(***************************************************************** Enrichment over structured sets In this file, we look at categories enriched over a notion of structured sets. The notion of structured sets in consideration here is designed so that structures are preserved under product and the unit set has a structure. As such, we have a cartesian monoidal category of structured sets (`StructuresMonoidal.v`). We first show that this monoidal category is faithful. From this, it follows that all natural transformations are enriched, so afterwards we don't consider enriched transformations. Afterwards, we give an elementary definition of enrichment over structures. This elementary notion says that for every homset, we have a structure and that composition preserves the structure. This notion of enrichment is equivalent to the usual one. Lastly, we do the same for enriched functors, and for those, enrichment is the same as the action on morphisms being a structure-preserving map. Again this is equivalent to the general definition of enrichment. We can apply the content of this file to various notions of structured sets, such as posets and domains. However, note that not for every notion of structured set this gives the 'right' notion of enriched category. For example, for abelian groups (or modules), the corresponding notion of enriched category should be over a different monoidal category than the one induced by the cartesian structure of these categories. For these notions of structure, one should construct the tensor product instead and show that this gives rise to a monoidal category. Contents 1. The monoidal category is faithful 2. Elementary definition of enrichment over structures 3. Equivalence of enrichments with the elementary definition 4. Elementary definition of functor enrichments over structures 5. Equivalence of functor enrichments with elementary definition *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.StructuresMonoidal. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Local Open Scope cat. Section FixAStructure. Context (P : hset_cartesian_closed_struct). (** 1. The monoidal category is faithful *) Definition category_of_hset_struct_faithful_moncat : faithful_moncat (monoidal_cat_of_hset_struct P). Proof. intros R₁ R₂ f g p. use subtypePath. { intro ; cbn -[isaprop]. apply isaprop_hset_struct_on_mor. } use funextsec ; intro x. assert (mor_hset_struct P (hset_struct_unit P) (pr2 R₁) (λ _, x)) as H. { apply hset_struct_const. } exact (eqtohomot (maponpaths pr1 (p ((λ _, x) ,, H))) tt). Qed. (** 2. Elementary definition of enrichment over structures *) Definition struct_enrichment_data (C : category) : UU := ∏ (x y : C), P (homset x y). Definition struct_enrichment_laws {C : category} (SC : struct_enrichment_data C) : UU := ∏ (x y z : C), mor_hset_struct P (hset_struct_prod P (SC y z) (SC x y)) (SC x z) (λ (fg : C ⟦ y, z ⟧ × C ⟦ x, y ⟧), pr2 fg · pr1 fg). Proposition isaprop_struct_enrichment_laws {C : category} (SC : struct_enrichment_data C) : isaprop (struct_enrichment_laws SC). Proof. repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Definition struct_enrichment (C : category) : UU := ∑ (SC : struct_enrichment_data C), struct_enrichment_laws SC. Definition struct_enrichment_to_data {C : category} (SC : struct_enrichment C) (x y : C) : P (homset x y) := pr1 SC x y. Coercion struct_enrichment_to_data : struct_enrichment >-> Funclass. Proposition struct_enrichment_comp {C : category} (SC : struct_enrichment C) (x y z : C) : mor_hset_struct P (hset_struct_prod P (SC y z) (SC x y)) (SC x z) (λ (fg : C ⟦ y, z ⟧ × C ⟦ x, y ⟧), pr2 fg · pr1 fg). Proof. exact (pr2 SC x y z). Qed. (** 3. Equivalence of enrichments with the elementary definition *) Section MakeStructEnrichment. Context (C : category) (SC : struct_enrichment C). Definition make_enrichment_over_struct_data : enrichment_data C (monoidal_cat_of_hset_struct P). Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ x y, _ ,, SC x y). - refine (λ x, (λ _, identity _) ,, _). abstract (cbn ; apply hset_struct_const). - simple refine (λ x y z, _ ,, _) ; cbn in *. + exact (λ fg, pr2 fg · pr1 fg). + apply struct_enrichment_comp. - refine (λ x y f, (λ _, f) ,, _). apply hset_struct_const. - exact (λ x y f, pr1 f tt). Defined. Proposition make_enrichment_over_struct_laws : enrichment_laws make_enrichment_over_struct_data. Proof. repeat split. - intros x y. use eq_mor_hset_struct. intro a ; cbn. rewrite id_right. apply idpath. - intros x y. use eq_mor_hset_struct. intro a ; cbn. rewrite id_left. apply idpath. - intros w x y z. use eq_mor_hset_struct. intro a ; cbn. rewrite assoc. apply idpath. - intros x y f. use eq_mor_hset_struct. intro a ; cbn in *. apply maponpaths. apply isapropunit. Qed. Definition make_enrichment_over_struct : enrichment C (monoidal_cat_of_hset_struct P) := make_enrichment_over_struct_data ,, make_enrichment_over_struct_laws. End MakeStructEnrichment. Section FromStructEnrichment. Context (C : category) (E : enrichment C (monoidal_cat_of_hset_struct P)). Definition mor_to_enriched_hom {x y : C} (f : x --> y) : pr11 (E ⦃ x , y ⦄) := pr1 (enriched_from_arr E f) tt. Definition enriched_hom_to_mor {x y : C} (f : pr11 (E ⦃ x , y ⦄)) : x --> y. Proof. assert (mor_hset_struct P (hset_struct_unit P) (pr2 (E ⦃ x, y ⦄)) (λ _, f)) as H. { apply hset_struct_const. } exact (enriched_to_arr E (_ ,, H)). Defined. Definition mor_weq_enriched_hom (x y : C) : pr11 (E ⦃ x , y ⦄) ≃ (x --> y). Proof. use weq_iso. - exact enriched_hom_to_mor. - exact mor_to_enriched_hom. - abstract (intro f ; unfold mor_to_enriched_hom, enriched_hom_to_mor ; rewrite enriched_from_to_arr ; apply idpath). - abstract (intro f ; unfold mor_to_enriched_hom, enriched_hom_to_mor ; refine (_ @ enriched_to_from_arr E f) ; apply maponpaths ; use eq_mor_hset_struct ; intro t ; cbn ; apply maponpaths ; apply isapropunit). Defined. Definition make_struct_enrichment_data : struct_enrichment_data C. Proof. intros x y. refine (transportf_struct_weq P _ (pr2 (E ⦃ x , y ⦄))). exact (mor_weq_enriched_hom x y). Defined. Proposition make_struct_enrichment_laws : struct_enrichment_laws make_struct_enrichment_data. Proof. intros x y z. use (transportf_struct_mor_prod_via_eq P). - exact (pr1 (enriched_comp E x y z)). - exact (pr2 (enriched_comp E x y z)). - intros fg ; cbn. unfold enriched_hom_to_mor. rewrite (enriched_to_arr_comp E). apply maponpaths. use eq_mor_hset_struct. intro t ; induction t. apply idpath. Qed. Definition make_struct_enrichment : struct_enrichment C. Proof. simple refine (_ ,, _). - exact make_struct_enrichment_data. - exact make_struct_enrichment_laws. Defined. End FromStructEnrichment. Section EnrichmentEquiv. Context {C : category} (E : enrichment C (monoidal_cat_of_hset_struct P)). Definition enrichment_over_struct_weq_struct_enrichment_iso (x y : C) : @z_iso (category_of_hset_struct P) (homset x y ,, make_struct_enrichment_data C E x y) (E ⦃ x , y ⦄). Proof. use make_z_iso. - simple refine (_ ,, _). + exact (λ f, pr1 (enriched_from_arr E f) tt). + cbn. apply transportf_struct_weq_on_invweq. - simple refine (_ ,, _). + refine (λ f, enriched_to_arr E ((λ _, f) ,, _)). apply hset_struct_const. + cbn. apply transportf_struct_weq_on_weq. - split. + use eq_mor_hset_struct. intro w ; cbn. refine (_ @ enriched_to_from_arr E _). apply maponpaths. use eq_mor_hset_struct. intro t. cbn. apply maponpaths. apply isapropunit. + use eq_mor_hset_struct. intro f. cbn. rewrite enriched_from_to_arr. apply idpath. Defined. Definition enrichment_over_struct_weq_struct_enrichment_inv_1 : make_enrichment_over_struct C (make_struct_enrichment C E) = E. Proof. use subtypePath. { intro. apply isaprop_enrichment_laws. } use (invweq (total2_paths_equiv _ _ _)). use (invmap (enrichment_data_hom_path _ _ _)). { exact (is_univalent_category_of_hset_struct P). } simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact enrichment_over_struct_weq_struct_enrichment_iso. - intro x. use eq_mor_hset_struct. intro t ; cbn. rewrite enriched_from_arr_id. apply maponpaths. apply isapropunit. - intros x y z. use eq_mor_hset_struct. intro t ; cbn. rewrite enriched_from_arr_comp ; cbn. apply idpath. - intros x y f. use eq_mor_hset_struct. intro t. cbn. apply maponpaths. apply isapropunit. - intros x y f. cbn. assert (mor_hset_struct P (hset_struct_unit P) (make_struct_enrichment_data C E x y) (λ _, pr1 f tt)) as H. { apply hset_struct_const. } refine (!(enriched_to_from_arr E (pr1 f tt)) @ _). apply maponpaths. use eq_mor_hset_struct. intro t ; induction t. cbn. apply idpath. Defined. End EnrichmentEquiv. Proposition enrichment_over_struct_weq_struct_enrichment_inv_2 {C : category} (E : struct_enrichment C) : make_struct_enrichment C (make_enrichment_over_struct C E) = E. Proof. use subtypePath. { intro. apply isaprop_struct_enrichment_laws. } use funextsec ; intro x. use funextsec ; intro y. simpl. unfold make_struct_enrichment_data. unfold make_enrichment_over_struct. simpl. unfold transportf_struct_weq. refine (_ @ idpath_transportf _ _). apply maponpaths_2. refine (_ @ univalence_hSet_idweq _). apply maponpaths. use subtypePath. { intro ; apply isapropisweq. } apply idpath. Qed. Definition enrichment_over_struct_weq_struct_enrichment (C : category) : enrichment C (monoidal_cat_of_hset_struct P) ≃ struct_enrichment C. Proof. use weq_iso. - exact (make_struct_enrichment C). - exact (make_enrichment_over_struct C). - apply enrichment_over_struct_weq_struct_enrichment_inv_1. - apply enrichment_over_struct_weq_struct_enrichment_inv_2. Defined. (** 4. Elementary definition of functor enrichments over structures *) Definition functor_struct_enrichment {C₁ C₂ : category} (P₁ : struct_enrichment C₁) (P₂ : struct_enrichment C₂) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁), mor_hset_struct P (P₁ x y) (P₂ (F x) (F y)) (λ f, #F f). (** 5. Equivalence of functor enrichments with elementary definition *) Definition make_functor_struct_enrichment {C₁ C₂ : category} (P₁ : struct_enrichment C₁) (P₂ : struct_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_enrichment F (make_enrichment_over_struct C₁ P₁) (make_enrichment_over_struct C₂ P₂)) : functor_struct_enrichment P₁ P₂ F. Proof. intros x y. refine (transportf _ _ (pr2 (HF x y))). use funextsec. intro f. pose (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr HF f)) tt) as p. cbn in p. exact (!p). Qed. Definition make_functor_enrichment_over_struct {C₁ C₂ : category} (P₁ : struct_enrichment C₁) (P₂ : struct_enrichment C₂) (F : C₁ ⟶ C₂) (HF : functor_struct_enrichment P₁ P₂ F) : functor_enrichment F (make_enrichment_over_struct C₁ P₁) (make_enrichment_over_struct C₂ P₂). Proof. simple refine (_ ,, _). - exact (λ x y, (λ f, #F f) ,, HF x y). - repeat split. + abstract (intros x ; use eq_mor_hset_struct ; intro f ; cbn ; apply functor_id). + abstract (intros x y z ; use eq_mor_hset_struct ; intro f ; cbn ; apply functor_comp). + abstract (intros x y f ; use eq_mor_hset_struct ; intro w ; cbn ; apply idpath). Defined. Definition functor_enrichment_over_struct_weq_struct_enrichment {C₁ C₂ : category} (P₁ : struct_enrichment C₁) (P₂ : struct_enrichment C₂) (F : C₁ ⟶ C₂) : functor_enrichment F (make_enrichment_over_struct C₁ P₁) (make_enrichment_over_struct C₂ P₂) ≃ functor_struct_enrichment P₁ P₂ F. Proof. use weq_iso. - exact (make_functor_struct_enrichment P₁ P₂ F). - exact (make_functor_enrichment_over_struct P₁ P₂ F). - abstract (intro EF ; use subtypePath ; [ intro ; apply isaprop_is_functor_enrichment | ] ; use funextsec ; intro x ; use funextsec ; intro y ; use eq_mor_hset_struct ; intro f ; cbn ; exact (eqtohomot (maponpaths pr1 (functor_enrichment_from_arr EF f)) tt)). - abstract (intros EF ; use funextsec ; intro x ; use funextsec ; intro y ; cbn ; apply isaprop_hset_struct_on_mor). Defined. End FixAStructure. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/UnitEnriched.v000066400000000000000000000233541451125700300265150ustar00rootroot00000000000000(********************************************************************** The unit enriched category We construct the unit enriched category and we define some functors and natural transformations related to it. We give two constructions of this enriched category. For the first construction, we assume that the monoidal category is semi-cartesian. Writing `𝟙` for the unit of the monoidal category, we define the objects and morphisms of the unit enriched category to be inhabitants of the unit type, and the enrichment is given by `𝟙`. As a consequence, the morphisms in this enriched category are be isomorphic to `𝟙 --> 𝟙`. Note that in this construction we assume that the unit of the involved monoidal category `V` is a terminal object, which is usually not required in textbooks. The reason for that is that if we don't require the unit to be terminal, there could be multiple isomorphisms from `𝟙` to `𝟙`. The resulting enriched category is then not guaranteed to be univalent. For the other construction, we assume that `V` has a terminal object. The construction proceeds mostly the same, but the only difference is that the enrichment is given by the terminal object. This construction always gives rise to a terminal object in the bicategory of enriched categories. Contents 1. The enrichment of the unit category 2. Enrichment for functors/natural transformations to the unit 3. The enrichment of the unit category via terminal objects 4. Enrichment for functors/natural transformations to the unit via terminal objects **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.limits.terminal. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section UnitEnrichment. Context (V : monoidal_cat) (HV : is_semicartesian V). (** 1. The enrichment of the unit category *) Definition unit_enrichment_data : enrichment_data unit_category V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ _ _, I_{V}). - exact (λ _, identity _). - exact (λ _ _ _, mon_lunitor _). - exact (λ _ _ _, identity _). - intros x y f. apply isapropunit. Defined. Definition unit_enrichment_laws : enrichment_laws unit_enrichment_data. Proof. repeat split. - cbn ; intros x y. refine (!_). refine (_ @ id_left _). apply maponpaths_2. apply tensor_id_id. - cbn ; intros x y. refine (!_). refine (_ @ id_left _). rewrite mon_lunitor_I_mon_runitor_I. apply maponpaths_2. apply tensor_id_id. - intros w x y z ; cbn. apply maponpaths_2. etrans. { rewrite mon_lunitor_I_mon_runitor_I. apply idpath. } apply mon_triangle. - cbn ; intros x y f. apply isasetunit. - cbn ; intros x y f. apply (@TerminalArrowEq _ (_ ,, (HV : isTerminal _ _))). - cbn ; intro x. apply isasetunit. - cbn ; intros x y z f g. apply isasetunit. Qed. Definition unit_enrichment : enrichment unit_category V. Proof. simple refine (_ ,, _). - exact unit_enrichment_data. - exact unit_enrichment_laws. Defined. Definition unit_cat_with_enrichment : cat_with_enrichment V := pr1 unit_category ,, unit_enrichment. (** 2. Enrichment for functors/natural transformations to the unit *) Definition functor_to_unit_enrichment {C : category} (E : enrichment C V) : functor_enrichment (functor_to_unit C) E unit_enrichment. Proof. simple refine (_ ,, _). - exact (λ x y, TerminalArrow (_ ,, (HV : isTerminal _ _)) _). - abstract (repeat split ; intros ; apply (@TerminalArrowEq _ (_ ,, (HV : isTerminal _ _)))). Defined. Definition nat_trans_to_unit_enrichment {C : category} (E : enrichment C V) {F G : C ⟶ unit_category} (EF : functor_enrichment F E unit_enrichment) (EG : functor_enrichment F E unit_enrichment) : nat_trans_enrichment (unit_category_nat_trans F G) EF EG. Proof. intros x y ; cbn. rewrite !assoc'. etrans. { apply maponpaths. rewrite mon_lunitor_I_mon_runitor_I. apply tensor_runitor. } refine (!_). etrans. { apply maponpaths. apply tensor_lunitor. } rewrite !assoc. apply (@TerminalArrowEq _ (_ ,, (HV : isTerminal _ _))). Qed. Definition constant_functor_enrichment (E : cat_with_enrichment V) (x : E) : functor_enrichment (constant_functor unit_cat_with_enrichment E x) unit_cat_with_enrichment E. Proof. simple refine (_ ,, _). - exact (λ _ _, enriched_id _ _). - repeat split. + abstract (intros y ; cbn ; apply id_left). + abstract (intros y₁ y₂ y₃ ; cbn ; rewrite tensor_split ; rewrite assoc' ; rewrite <- enrichment_id_left ; rewrite tensor_lunitor ; apply idpath). + abstract (intros y₁ y₂ f ; cbn ; rewrite enriched_from_arr_id ; rewrite id_left ; apply idpath). Defined. Definition functor_from_unit_cat_with_enrichment (E : cat_with_enrichment V) (x : E) : functor_with_enrichment unit_cat_with_enrichment E. Proof. simple refine (_ ,, _). - exact (constant_functor unit_cat_with_enrichment E x). - exact (constant_functor_enrichment E x). Defined. Definition constant_nat_trans_enrichment {C : category} (E : enrichment C V) {x y : C} (f : x --> y) : nat_trans_enrichment (constant_nat_trans _ f) (constant_functor_enrichment (C ,, E) x) (constant_functor_enrichment (C ,, E) y). Proof. intros z₁ z₂ ; cbn. etrans. { rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_lunitor_I_mon_runitor_I. etrans. { apply maponpaths_2. apply mon_rinvunitor_runitor. } apply id_left. } refine (!_). etrans. { rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite tensor_runitor. rewrite !assoc. rewrite mon_runitor_I_mon_lunitor_I. etrans. { apply maponpaths_2. apply mon_linvunitor_lunitor. } apply id_left. } apply idpath. Qed. End UnitEnrichment. Section UnitEnrichmentViaTerminal. Context (V : monoidal_cat) (T : Terminal V). (** 3. The enrichment of the unit category via terminal objects *) Definition unit_enrichment_data_from_terminal : enrichment_data unit_category V. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _). - exact (λ _ _, T). - exact (λ _, TerminalArrow T _). - exact (λ _ _ _, TerminalArrow T _). - exact (λ _ _ _, TerminalArrow T _). - abstract (intros x y f ; cbn ; apply isapropunit). Defined. Definition unit_enrichment_laws_from_terminal : enrichment_laws unit_enrichment_data_from_terminal. Proof. repeat split. - cbn ; intros x y. apply TerminalArrowEq. - cbn ; intros x y. apply TerminalArrowEq. - cbn ; intros w x y z. apply TerminalArrowEq. - cbn ; intros x y f. apply isasetunit. - cbn ; intros x y f. apply (@TerminalArrowEq _ T). - cbn ; intro x. apply isasetunit. - cbn ; intros x y z f g. apply isasetunit. Qed. Definition unit_enrichment_from_terminal : enrichment unit_category V. Proof. simple refine (_ ,, _). - exact unit_enrichment_data_from_terminal. - exact unit_enrichment_laws_from_terminal. Defined. Definition unit_cat_with_enrichment_from_terminal : cat_with_enrichment V := pr1 unit_category ,, unit_enrichment_from_terminal. (** 4. Enrichment for functors/natural transformations to the unit via terminal objects *) Definition functor_to_unit_enrichment_from_terminal {C : category} (E : enrichment C V) : functor_enrichment (functor_to_unit C) E unit_enrichment_from_terminal. Proof. simple refine (_ ,, _). - exact (λ x y, TerminalArrow T _). - abstract (repeat split ; intros ; apply (@TerminalArrowEq _ T)). Defined. Definition nat_trans_to_unit_enrichment_from_terminal {C : category} (E : enrichment C V) {F G : C ⟶ unit_category} (EF : functor_enrichment F E unit_enrichment_from_terminal) (EG : functor_enrichment F E unit_enrichment_from_terminal) : nat_trans_enrichment (unit_category_nat_trans F G) EF EG. Proof. intros x y ; cbn. rewrite !assoc'. apply TerminalArrowEq. Qed. End UnitEnrichmentViaTerminal. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/UnivalentKleisliEnriched.v000066400000000000000000001374531451125700300310660ustar00rootroot00000000000000(********************************************************************** The enriched univalent Kleisli category We construct an enrichment of the univalent Kleisli category. Note that since this category is defined as a subcategory of the Eilenberg-Moore category, we assume that the monoidal category over which we enrich, has equalizers. Contents 1. Enrichment of the free algebra functor 2. Enrichment of the univalent Kleisli category 3. Functor to the Kleisli category 4. Functor between the two different versions of the Kleisli category 5. The functor is fully faithful **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.categories.KleisliCategory. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.EilenbergMooreEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.ImageEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.KleisliEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KleisliCategory. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Section EnrichedKleisli. Context {V : monoidal_cat} (HV : Equalizers V) {C : category} {E : enrichment C V} {M : Monad C} (EM : monad_enrichment E M). (** 1. Enrichment of the free algebra functor *) Definition free_alg_enrichment_mor (x y : C) : E ⦃ x, y ⦄ --> eilenberg_moore_enrichment HV EM ⦃ free_alg_em M x, free_alg_em M y ⦄. Proof. use EqualizerIn. - exact (EM x y). - abstract (cbn ; unfold dialgebra_enrichment_mor_left ; unfold dialgebra_enrichment_mor_right ; cbn ; rewrite id_left ; rewrite !assoc ; etrans ; [ do 2 apply maponpaths_2 ; apply tensor_rinvunitor | ] ; rewrite !assoc' ; etrans ; [ apply maponpaths ; rewrite !assoc ; apply maponpaths_2 ; exact (!(tensor_split' _ _)) | ] ; rewrite !assoc ; refine (mu_of_monad_enrichment EM x y @ _) ; apply maponpaths_2 ; cbn ; refine (!_) ; etrans ; [ apply maponpaths_2 ; apply tensor_linvunitor | ] ; rewrite !assoc' ; apply maponpaths ; refine (!_) ; apply tensor_split). Defined. Definition free_alg_enrichment_mor_incl (x y : C) : free_alg_enrichment_mor x y · dialgebra_enrichment_mor_incl V HV EM (functor_id_enrichment E) (μ M x) (μ M y) = EM x y. Proof. apply EqualizerCommutes. Qed. Definition free_alg_enrichment_laws : is_functor_enrichment free_alg_enrichment_mor. Proof. repeat split. - intro x. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). rewrite !assoc'. rewrite free_alg_enrichment_mor_incl. refine (!_). etrans. { apply dialgebra_enrichment_id_incl. } refine (!_). apply functor_enrichment_id. - intros x y z. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). rewrite !assoc'. rewrite free_alg_enrichment_mor_incl. refine (!_). etrans. { apply maponpaths. apply dialgebra_enrichment_comp_incl. } unfold dialgebra_enrichment_comp_mor. cbn. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite !free_alg_enrichment_mor_incl. refine (!_). apply functor_enrichment_comp. - intros x y f. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). rewrite !assoc'. rewrite free_alg_enrichment_mor_incl. etrans. { apply dialgebra_enrichment_from_arr_incl. } apply functor_enrichment_from_arr. Qed. Definition free_alg_enrichment : functor_enrichment (free_alg_em M) E (eilenberg_moore_enrichment HV EM). Proof. simple refine (_ ,, _). - exact free_alg_enrichment_mor. - exact free_alg_enrichment_laws. Defined. (** 2. Enrichment of the univalent Kleisli category *) Definition Kleisli_cat_enrichment : enrichment (kleisli_cat M) V. Proof. use image_enrichment. exact (eilenberg_moore_enrichment HV EM). Defined. (** 3. Functor to the Kleisli category *) Definition kleisli_incl_enrichment : functor_enrichment (kleisli_incl M) E Kleisli_cat_enrichment. Proof. use image_proj_enrichment. exact free_alg_enrichment. Defined. (** 4. Functor between the two different versions of the Kleisli category *) Definition functor_to_kleisli_cat_enrichment_mor (x y : C) : E ⦃ x, M y ⦄ --> E ⦃ M x, M y ⦄ := mon_linvunitor _ · enriched_from_arr E (μ M y) #⊗ EM x (M y) · enriched_comp E (M x) (M(M y)) (M y). Definition functor_to_kleisli_cat_enrichment_eq (x y : C) : functor_to_kleisli_cat_enrichment_mor x y · @dialgebra_enrichment_mor_left V C C M (functor_identity C) E E (functor_id_enrichment E) (M x) (M y) (μ M x) (μ M y) = functor_to_kleisli_cat_enrichment_mor x y · @dialgebra_enrichment_mor_right V C C M (functor_identity C) E E EM (M x) (M y) (μ M x) (μ M y). Proof. unfold dialgebra_enrichment_mor_left. unfold dialgebra_enrichment_mor_right. unfold functor_to_kleisli_cat_enrichment_mor. cbn. rewrite !id_left. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. apply (functor_enrichment_comp EM). } rewrite !assoc'. etrans. { do 3 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply tensor_split. } apply tensor_split'. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply tensor_split'. } apply tensor_split. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } apply maponpaths. etrans. { etrans. { apply maponpaths_2. apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 4 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_id_id. } apply tensor_lassociator. } rewrite !assoc. apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc. etrans. { do 4 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_rinvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_rassociator_lassociator. } apply id_right. } apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_id_l. } refine (!_). apply tensor_comp_id_l. } refine (!_). apply tensor_comp_id_l. } etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_comp_mor. } rewrite id_left, id_right. rewrite !assoc. exact (mu_of_monad_enrichment EM x (M y)). } cbn. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !assoc'. apply maponpaths. apply maponpaths_2. apply tensor_comp_id_l. } etrans. { rewrite !assoc. do 3 apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } refine (!_). etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. exact (!(tensor_comp_mor _ _ _ _)). } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. etrans. { apply maponpaths_2. apply tensor_linvunitor. } apply tensor_comp_mor. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths. refine (!_). apply tensor_id_id. } refine (!_). apply tensor_lassociator. } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. } etrans. { apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply idpath. } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. apply maponpaths_2. rewrite !assoc. apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply idpath. } assert (enriched_from_arr E (μ M y) #⊗ (enriched_from_arr E (μ M y) · EM (M (M y)) (M y)) · enriched_comp E (M (M (M y))) (M (M y)) (M y) = enriched_from_arr E (μ M y) #⊗ enriched_from_arr E (μ M (M y)) · enriched_comp E (M (M (M y))) (M (M y)) (M y)) as p. { pose (maponpaths (λ z, mon_lunitor _ · enriched_from_arr E z) (@Monad_law3 _ M y)) as p. cbn in p. rewrite !enriched_from_arr_comp in p. rewrite (functor_enrichment_from_arr EM) in p. rewrite !assoc in p. refine (_ @ p @ _). - refine (!(id_left _) @ _). rewrite !assoc. do 2 apply maponpaths_2. refine (!_). apply mon_lunitor_linvunitor. - refine (_ @ id_left _). rewrite !assoc. do 2 apply maponpaths_2. apply mon_lunitor_linvunitor. } etrans. { apply maponpaths. apply maponpaths_2. exact p. } clear p. etrans. { apply maponpaths. apply tensor_comp_r_id_r. } rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { do 2 apply maponpaths. apply tensor_rassociator. } etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply tensor_id_id. } rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. etrans. { apply maponpaths_2. exact (!(tensor_split' _ _)). } apply tensor_comp_l_id_l. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { refine (!_). apply tensor_split'. } apply maponpaths_2. apply mon_rinvunitor_I_mon_linvunitor_I. Qed. Definition functor_to_kleisli_cat_enrichment_data (x y : C) : E ⦃ x, M y ⦄ --> dialgebra_enrichment_mor V HV EM (functor_id_enrichment E) (μ M x) (μ M y). Proof. use EqualizerIn. - exact (functor_to_kleisli_cat_enrichment_mor x y). - exact (functor_to_kleisli_cat_enrichment_eq x y). Defined. Definition functor_to_kleisli_cat_enrichment_data_incl (x y : C) : functor_to_kleisli_cat_enrichment_data x y · dialgebra_enrichment_mor_incl _ _ _ _ _ _ = functor_to_kleisli_cat_enrichment_mor x y. Proof. apply EqualizerCommutes. Qed. Definition functor_to_kleisli_cat_enrichment_is_enrichment : @is_functor_enrichment _ _ _ (functor_to_kleisli_cat M) (Kleisli_cat_monad_enrichment EM) Kleisli_cat_enrichment functor_to_kleisli_cat_enrichment_data. Proof. repeat split. - intros x ; cbn. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). refine (!_). refine (dialgebra_enrichment_id_incl _ _ _ _ _ @ _). refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply functor_to_kleisli_cat_enrichment_data_incl. } unfold functor_to_kleisli_cat_enrichment_mor. rewrite <- enriched_from_arr_id. rewrite <- (@Monad_law2 _ M x). rewrite enriched_from_arr_comp ; cbn. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. rewrite <- (functor_enrichment_from_arr EM). apply idpath. - (** The proof for this goal is in essence that for all f : x --> M y g : y --> M z we have (#M f · μ M y) · (#M g · μ M z) = #M f · (μ M y · (#M g · μ M z)) = #M f · ((μ M y · #M g) · μ M z) = #M f · ((#M (#M g) · μ M z) · μ M z) = #M f · (#M (#M g) · (μ M z · μ M z)) = (#M f · #M (#M g)) · (μ M z · μ M z)) = #M (f · #M g) · (μ M z · μ M z) = #M(f · #M g) · (#M (μ M z) · μ M z) = (#M(f · #M g) · #M (μ M z)) · μ M z = #M((f · #M g) · μ M z) · μ M z *) intros x y z ; cbn. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). rewrite !assoc'. etrans. { do 5 apply maponpaths. apply functor_to_kleisli_cat_enrichment_data_incl. } refine (!_). etrans. { apply maponpaths. apply dialgebra_enrichment_comp_incl. } unfold dialgebra_enrichment_comp_mor. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). etrans. { apply maponpaths. apply functor_to_kleisli_cat_enrichment_data_incl. } apply maponpaths_2. apply functor_to_kleisli_cat_enrichment_data_incl. } unfold functor_to_kleisli_cat_enrichment_mor. rewrite !assoc'. etrans. { etrans. { apply maponpaths_2. rewrite !assoc. apply tensor_comp_l_id_r. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc'. etrans. { rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite tensor_comp_mor. rewrite !assoc'. apply maponpaths. apply tensor_rassociator. } rewrite !assoc'. do 2 apply maponpaths. etrans. { apply maponpaths_2. apply tensor_split. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_split. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } cbn. etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (!_). apply tensor_id_id. } apply tensor_lassociator. } etrans. { apply maponpaths. rewrite !assoc'. apply tensor_comp_id_r. } rewrite !assoc. apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { refine (!_). apply tensor_id_id. } apply maponpaths_2. refine (!_). apply tensor_id_id. } apply tensor_lassociator. } etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. apply tensor_split'. } rewrite !assoc. apply tensor_split. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. rewrite !assoc. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 3 apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply tensor_id_id. } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply tensor_split'. } etrans. { do 2 apply maponpaths_2. apply tensor_comp_r_id_l. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths. apply tensor_comp_id_r. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left, id_right. apply idpath. } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_l. } etrans. { refine (!_). apply tensor_comp_id_l. } apply maponpaths. etrans. { etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. exact (!(tensor_split' _ _)). } rewrite !assoc. apply maponpaths_2. exact (!(tensor_split' _ _)). } pose (maponpaths (λ z, mon_runitor _ · z) (mu_of_monad_enrichment EM y (M z))) as p. cbn in p. refine (_ @ p). refine (!_). rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply mon_runitor_rinvunitor. } rewrite id_left. apply idpath. } rewrite !assoc'. etrans. { do 4 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths_2. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } apply tensor_split. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_id_r _ _) @ _). rewrite !assoc'. apply maponpaths_2. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc'. etrans. { do 5 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } etrans. { do 4 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. rewrite id_left. rewrite !assoc'. etrans. { do 2 apply maponpaths_2. apply maponpaths. rewrite assoc. apply maponpaths. apply tensor_comp_l_id_r. } etrans. { apply maponpaths_2. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. apply tensor_rassociator. } rewrite !assoc'. do 2 apply maponpaths. etrans. { do 2 apply maponpaths_2. apply tensor_id_id. } refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc. refine (tensor_comp_r_id_l _ _ _ @ _). apply idpath. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc'. apply maponpaths. refine ((!tensor_comp_id_l _ _) @ _). apply maponpaths. exact (!(functor_enrichment_comp EM x (M y) (M(M z)))). } refine (!_). etrans. { do 4 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. exact (functor_enrichment_comp EM x (M(M z)) (M z)). } etrans. { do 4 apply maponpaths. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_l_id_r. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. etrans. { rewrite !assoc'. do 5 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right. etrans. { apply tensor_comp_r_id_l. } apply maponpaths. apply tensor_split'. } refine (!_). etrans. { apply maponpaths. apply tensor_comp_id_l. } rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 5 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 4 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc'. apply maponpaths. refine (!(tensor_split _ _) @ _). apply tensor_split'. } rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply tensor_comp_id_r. } rewrite !assoc. do 2 apply maponpaths_2. refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply mon_runitor_triangle. } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. } rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths. apply mon_triangle. } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rassociator_lassociator. } apply id_left. } etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } etrans. { rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!(tensor_comp_id_l _ _) @ _). etrans. { apply maponpaths. apply mon_linvunitor_lunitor. } apply tensor_id_id. } apply id_left. } rewrite !assoc'. etrans. { apply maponpaths_2. apply tensor_comp_id_r. } refine (!_). etrans. { apply maponpaths. apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } etrans. { rewrite !assoc. do 5 apply maponpaths_2. refine (!(tensor_comp_id_r _ _) @ _). etrans. { apply maponpaths_2. apply tensor_linvunitor. } apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. rewrite !assoc'. apply tensor_comp_id_r. } rewrite !assoc. apply maponpaths_2. refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. refine (!(tensor_split' _ _) @ _). refine (tensor_split _ _ @ _). apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths. apply tensor_split. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_linvunitor. } etrans. { do 4 apply maponpaths_2. rewrite !assoc'. apply tensor_comp_id_l. } etrans. { do 2 apply maponpaths_2. rewrite !assoc'. apply tensor_comp_id_r. } rewrite !assoc'. apply maponpaths. rewrite !assoc. assert (enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (# M (μ M z)) · enriched_comp E (M (M (M z))) (M (M z)) (M z) = enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (μ M (M z)) · enriched_comp E (M (M (M z))) (M (M z)) (M z)) as p. { pose (p := maponpaths (λ z, mon_lunitor _ · enriched_from_arr E z) (@Monad_law3 _ M z)). cbn in p. rewrite !enriched_from_arr_comp in p. refine (_ @ p @ _). - rewrite !assoc. apply maponpaths_2. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply mon_lunitor_linvunitor. - rewrite !assoc. apply maponpaths_2. refine (_ @ id_left _). apply maponpaths_2. apply mon_lunitor_linvunitor. } etrans. { apply maponpaths_2. refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. refine (!_). apply tensor_id_id. } apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. etrans. { rewrite !assoc. apply maponpaths_2. exact (!(tensor_split _ _)). } exact (!p). } clear p. refine (!_). etrans. { rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 2 apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { apply maponpaths. exact (!(tensor_comp_id_r _ _)). } etrans. { do 2 apply maponpaths. exact (!(tensor_id_id _ _)). } refine (!_). apply tensor_lassociator. } rewrite !assoc. do 2 apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { apply maponpaths_2. apply mon_linvunitor_I_mon_rinvunitor_I. } apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. refine (!_). apply (functor_enrichment_from_arr EM). - intros x y f ; cbn. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). unfold bind. refine (dialgebra_enrichment_from_arr_incl _ _ _ _ _ _ @ _). rewrite !assoc'. refine (!_). etrans ; [ apply maponpaths ; apply functor_to_kleisli_cat_enrichment_data_incl | ]. unfold functor_to_kleisli_cat_enrichment_mor. rewrite !assoc'. etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths. apply (@Monad_law2 _ M y). } apply id_right. } rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. rewrite (functor_enrichment_from_arr EM). apply idpath. Qed. Definition functor_to_kleisli_cat_enrichment : functor_enrichment (functor_to_kleisli_cat M) (Kleisli_cat_monad_enrichment EM) Kleisli_cat_enrichment. Proof. simple refine (_ ,, _). - exact functor_to_kleisli_cat_enrichment_data. - exact functor_to_kleisli_cat_enrichment_is_enrichment. Defined. (** 5. The functor is fully faithful *) Section FullyFaithfulToKleisli. Context (x y : C). Definition functor_to_kleisli_cat_enrichment_inv : Kleisli_cat_enrichment ⦃ functor_to_kleisli_cat M x, functor_to_kleisli_cat M y ⦄ --> Kleisli_cat_monad_enrichment EM ⦃ x, y ⦄ := dialgebra_enrichment_mor_incl _ _ _ _ _ _ · mon_rinvunitor _ · (identity _ #⊗ enriched_from_arr E (η M x)) · enriched_comp E x (M x) (M y). Local Lemma functor_to_kleisli_cat_enrichment_inv_right : functor_to_kleisli_cat_enrichment_data x y · functor_to_kleisli_cat_enrichment_inv = identity _. Proof. unfold functor_to_kleisli_cat_enrichment_inv. cbn. rewrite !assoc. etrans. { do 3 apply maponpaths_2. apply functor_to_kleisli_cat_enrichment_data_incl. } unfold functor_to_kleisli_cat_enrichment_mor. (* We show that for all f : x --> M y we have η M x · (#M f · μ M y) = f *) rewrite !assoc'. (* η M x · (#M f · μ M y) = (η M x · #M f) · μ M y *) etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { do 2 apply maponpaths_2. exact (!(tensor_id_id _ _)). } apply tensor_lassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_rinvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_rassociator_lassociator. } apply id_right. } rewrite !assoc'. etrans. { apply maponpaths. apply maponpaths_2. apply tensor_split'. } rewrite !assoc'. (* (η M x · #M f) · μ M y = (f · η M y) · μ M y *) etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. exact (!(tensor_comp_id_l _ _)). } etrans. { apply maponpaths. exact (!(tensor_comp_id_l _ _)). } refine (!(tensor_comp_id_l _ _) @ _). apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. exact (!(tensor_split' _ _)). } rewrite !assoc. exact (unit_of_monad_enrichment EM x (M y)). } cbn. (* (f · η M y) · μ M y = f · (η M y · μ M y) *) etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc'. } (* f · (η M y · μ M y) = f · id *) etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths_2. apply tensor_comp_id_l. } rewrite !assoc'. etrans. { apply maponpaths. apply tensor_rassociator. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_inv_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } apply id_right. } etrans. { apply maponpaths. exact (!(tensor_comp_id_r _ _)). } refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. rewrite !assoc. etrans. { apply maponpaths_2. apply tensor_rinvunitor. } rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite !assoc'. apply maponpaths. exact (!(tensor_split' _ _)). } refine (!(tensor_comp_id_r _ _) @ _). apply maponpaths_2. pose (p := maponpaths (enriched_from_arr E) (@Monad_law1 _ M y)). rewrite enriched_from_arr_id in p. rewrite enriched_from_arr_comp in p. cbn in p. exact p. } (* f · id = f *) etrans. { apply maponpaths. refine (!_). apply enrichment_id_left. } apply mon_linvunitor_lunitor. Qed. Local Lemma functor_to_kleisli_cat_enrichment_inv_left : functor_to_kleisli_cat_enrichment_inv · functor_to_kleisli_cat_enrichment_data x y = identity _. Proof. use (dialgebra_enrichment_mor_eq_of_mor V HV EM (functor_id_enrichment E)). rewrite id_left. etrans. { rewrite !assoc'. apply maponpaths. apply functor_to_kleisli_cat_enrichment_data_incl. } unfold functor_to_kleisli_cat_enrichment_mor. unfold functor_to_kleisli_cat_enrichment_inv. cbn. rewrite !assoc'. pose (dialgebra_enrichment_mor_incl_eq V HV EM (functor_id_enrichment E) (μ M x) (μ M y)) as p. unfold dialgebra_enrichment_mor_right in p. cbn in p. etrans. { apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. etrans. { do 3 apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_left. apply maponpaths. apply (functor_enrichment_comp EM). } etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_triangle. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. apply tensor_comp_l_id_r. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_lassociator. } rewrite !assoc'. etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. apply enrichment_assoc'. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (!(tensor_comp_mor _ _ _ _)). } rewrite id_right. etrans. { do 2 apply maponpaths. exact (!(tensor_comp_mor _ _ _ _)). } rewrite id_left. etrans. { apply maponpaths. exact (!(tensor_comp_mor _ _ _ _)). } rewrite id_left. etrans. { apply maponpaths. apply tensor_split'. } rewrite !assoc. apply maponpaths_2. refine (!_). apply tensor_rinvunitor. } rewrite !assoc. etrans. { do 3 apply maponpaths_2. refine (_ @ !p). rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply tensor_linvunitor. } rewrite !assoc'. apply maponpaths. refine (!_). apply tensor_split. } refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. clear p. unfold dialgebra_enrichment_mor_left ; cbn. (* For all f : M x --> M y we have #M (η M x) · (μ M x · f) = f *) rewrite id_left. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!(tensor_split' _ _) @ _). apply tensor_split. } rewrite !assoc'. apply maponpaths. apply enrichment_assoc. } pose (p := maponpaths (enriched_from_arr E) (@Monad_law2 _ M x)). rewrite enriched_from_arr_id in p. rewrite enriched_from_arr_comp in p. rewrite (functor_enrichment_from_arr EM) in p. cbn in p. etrans. { do 3 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. etrans. { do 2 apply maponpaths_2. exact (!(tensor_id_id _ _)). } apply tensor_lassociator. } etrans. { do 2 apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply mon_rinvunitor_triangle. } rewrite !assoc'. etrans. { apply maponpaths. apply mon_rassociator_lassociator. } apply id_right. } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. exact (!(tensor_comp_id_l _ _)). } etrans. { apply maponpaths_2. exact (!(tensor_comp_id_l _ _)). } refine (!(tensor_comp_id_l _ _) @ _). apply maponpaths. etrans. { do 2 apply maponpaths_2. apply tensor_rinvunitor. } rewrite mon_rinvunitor_I_mon_linvunitor_I. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. exact (!(tensor_split' _ _)). } rewrite !assoc. exact p. } etrans. { apply maponpaths. refine (!_). apply enrichment_id_right. } apply mon_rinvunitor_runitor. Qed. End FullyFaithfulToKleisli. Definition fully_faithful_functor_to_kleisli_cat_enrichment : fully_faithful_enriched_functor functor_to_kleisli_cat_enrichment. Proof. intros x y. use make_is_z_isomorphism. - exact (functor_to_kleisli_cat_enrichment_inv x y). - split. + exact (functor_to_kleisli_cat_enrichment_inv_right x y). + exact (functor_to_kleisli_cat_enrichment_inv_left x y). Defined. End EnrichedKleisli. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Examples/Yoneda.v000066400000000000000000000531311451125700300253470ustar00rootroot00000000000000(********************************************************************** The Yoneda embedding for enriched categories In this file, we define the Yoneda embedding for enriched categories. To do so, we first define representable presheaves and representable natural transformations. There are a couple of things to notice about this construction, First of all, to guarantee that the presheaf category is enriched, we need to assume that the monoidal category over which we enrich, is symmetric and closed, and that we have enough limits, namely equalizers and products indexed over the objects of `C` (for this, we must assume that `C` is sufficiently small compared to `V`). Second of all, since the presheaves land in the monoidal category `V`, most of the construction is manipulating the function spaces of `V`. Contents 1. Representable presheaves 2. Representable natural transformations 3. The enriched Yoneda embedding **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FunctorCategory. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section YonedaEmbedding. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (EqV : Equalizers V) (PV : Products C V) (PV' : Products (C × C) V). (** 1. Representable presheaves *) Section RepresentablePresheaf. Context (y : C). Definition enriched_repr_presheaf_data : functor_data (C ^opp) V. Proof. use make_functor_data. - exact (λ x, E ⦃ x , y ⦄). - exact (λ x₁ x₂ f, precomp_arr E y f). Defined. Proposition is_functor_enriched_repr_presheaf : is_functor enriched_repr_presheaf_data. Proof. split. - intros x ; cbn. rewrite precomp_arr_id. apply idpath. - intros x₁ x₂ x₃ f₁ f₂ ; cbn. rewrite precomp_arr_comp. apply idpath. Qed. Definition enriched_repr_presheaf_functor : C^opp ⟶ V. Proof. use make_functor. - exact enriched_repr_presheaf_data. - exact is_functor_enriched_repr_presheaf. Defined. Definition enriched_repr_presheaf_enrichment_data : functor_enrichment_data enriched_repr_presheaf_functor (op_enrichment V E) (self_enrichment V) := λ x₁ x₂, internal_lam (sym_mon_braiding _ _ _ · enriched_comp E x₂ x₁ y). Arguments enriched_repr_presheaf_enrichment_data /. Proposition enriched_repr_presheaf_enrichment_laws : is_functor_enrichment enriched_repr_presheaf_enrichment_data. Proof. repeat split. - intro x ; cbn -[sym_mon_braiding]. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). etrans. { apply maponpaths_2. apply tensor_split. } rewrite !assoc'. unfold internal_id. rewrite internal_beta. refine (!_). rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite tensor_split'. rewrite !assoc'. rewrite <- enrichment_id_right. rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. apply sym_mon_braiding_runitor. - intros x₁ x₂ x₃ ; cbn -[sym_mon_braiding]. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. rewrite <- tensor_comp_mor. rewrite id_right. apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !tensor_comp_id_r. rewrite !assoc'. apply idpath. } rewrite enrichment_assoc. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite sym_mon_tensor_lassociator. rewrite !assoc. rewrite mon_lassociator_rassociator. rewrite id_left. rewrite !assoc'. refine (!_). etrans. { rewrite tensor_split'. apply idpath. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_rassociator. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite <- tensor_sym_mon_braiding. rewrite tensor_comp_id_l. apply idpath. } rewrite !assoc. rewrite <- tensor_lassociator. rewrite tensor_id_id. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite <- sym_mon_hexagon_rassociator. rewrite !assoc'. rewrite mon_rassociator_lassociator. rewrite id_right. apply idpath. } rewrite !assoc. rewrite mon_lassociator_rassociator. apply id_left. - intros x₁ x₂ f ; cbn -[sym_mon_braiding]. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite internal_beta. unfold precomp_arr. rewrite !assoc. apply maponpaths_2. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite tensor_sym_mon_braiding. apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!(id_right _) @ _). rewrite <- mon_runitor_rinvunitor. rewrite !assoc. apply maponpaths_2. apply sym_mon_braiding_runitor. Qed. Definition enriched_repr_presheaf_enrichment : functor_enrichment enriched_repr_presheaf_functor (op_enrichment V E) (self_enrichment V) := enriched_repr_presheaf_enrichment_data ,, enriched_repr_presheaf_enrichment_laws. Definition enriched_repr_presheaf : enriched_functor_category (op_enrichment V E) (self_enrichment V). Proof. simple refine (_ ,, _). - exact enriched_repr_presheaf_functor. - exact enriched_repr_presheaf_enrichment. Defined. End RepresentablePresheaf. Arguments enriched_repr_presheaf_enrichment_data /. (** 2. Representable natural transformations *) Section RepresentableTransformation. Context {y₁ y₂ : C} (g : y₁ --> y₂). Definition enriched_repr_nat_trans_mor : enriched_repr_presheaf_functor y₁ ⟹ enriched_repr_presheaf_functor y₂. Proof. use make_nat_trans. - exact (λ x, postcomp_arr E x g). - abstract (intros x₁ x₂ f ; cbn ; rewrite precomp_postcomp_arr ; apply idpath). Defined. Proposition enriched_repr_nat_trans_enrichment : nat_trans_enrichment enriched_repr_nat_trans_mor (enriched_repr_presheaf_enrichment y₁) (enriched_repr_presheaf_enrichment y₂). Proof. intros x₁ x₂ ; cbn -[sym_mon_braiding]. use internal_funext. intros a h. unfold internal_comp. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite !internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. unfold internal_from_arr. rewrite internal_beta. rewrite tensor_split. rewrite id_right. rewrite !assoc'. rewrite internal_beta. apply idpath. } refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. unfold internal_from_arr. rewrite internal_beta. rewrite tensor_split. rewrite id_right. rewrite !assoc'. rewrite internal_beta. apply idpath. } refine (!_). etrans. { rewrite tensor_comp_id_l. rewrite !assoc. do 3 apply maponpaths_2. rewrite !assoc'. rewrite <- mon_triangle. rewrite tensor_split. rewrite !assoc'. rewrite <- tensor_comp_id_r. rewrite mon_rinvunitor_runitor. rewrite tensor_id_id. apply id_right. } refine (!_). etrans. { apply maponpaths_2. rewrite tensor_split. apply idpath. } rewrite !assoc'. apply maponpaths. etrans. { rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lunitor. rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. rewrite mon_lunitor_triangle. rewrite <- tensor_comp_id_r. rewrite mon_linvunitor_lunitor. rewrite tensor_id_id. apply idpath. } rewrite id_left. rewrite !assoc'. rewrite enriched_comp_postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_sym_mon_braiding. apply idpath. Qed. Definition enriched_repr_nat_trans : enriched_repr_presheaf y₁ --> enriched_repr_presheaf y₂ := enriched_repr_nat_trans_mor ,, enriched_repr_nat_trans_enrichment. End RepresentableTransformation. (** 3. The enriched Yoneda embedding *) Definition enriched_yoneda_data : functor_data C (enriched_functor_category (op_enrichment V E) (self_enrichment V)). Proof. use make_functor_data. - exact (λ y, enriched_repr_presheaf y). - exact (λ y₁ y₂ g, enriched_repr_nat_trans g). Defined. Proposition is_functor_enriched_yoneda : is_functor enriched_yoneda_data. Proof. split. - intros y. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq ; [ apply homset_property | ]. intros x ; cbn. apply postcomp_arr_id. - intros y₁ y₂ y₃ g₁ g₂. use subtypePath. { intro. apply isaprop_nat_trans_enrichment. } use nat_trans_eq ; [ apply homset_property | ]. intros x ; cbn. apply postcomp_arr_comp. Qed. Definition enriched_yoneda_functor : C ⟶ enriched_functor_category (op_enrichment V E) (self_enrichment V). Proof. use make_functor. - exact enriched_yoneda_data. - exact is_functor_enriched_yoneda. Defined. Definition enriched_yoneda_enrichment_data_ob (y₁ y₂ : C) : E ⦃ y₁, y₂ ⦄ --> PV (λ x, (E ⦃ x, y₁ ⦄) ⊸ (E ⦃ x, y₂ ⦄)) := ProductArrow _ _ _ (λ x, internal_lam (enriched_comp E x y₁ y₂)). Arguments enriched_yoneda_enrichment_data_ob /. Proposition enriched_yoneda_enrichment_data_eq (y₁ y₂ : C) : enriched_yoneda_enrichment_data_ob y₁ y₂ · @enriched_functor_left_map V (C^opp) _ _ _ _ PV' (enriched_repr_presheaf_functor y₁) _ (enriched_repr_presheaf_enrichment y₂) = enriched_yoneda_enrichment_data_ob y₁ y₂ · enriched_functor_right_map _ _ _ _ (enriched_repr_presheaf_enrichment y₁). Proof. use ProductArrow_eq. intros x. unfold enriched_functor_left_map, enriched_functor_right_map. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (ProductPrCommutes (C × C) V _ _ _ _ _) @ _). refine (_ @ !(maponpaths (λ z, _ · z) (ProductPrCommutes (C × C) V _ _ _ _ _))). rewrite !assoc. cbn. refine (maponpaths (λ z, z · _) (ProductPrCommutes C V _ _ _ _ _) @ _). refine (_ @ !(maponpaths (λ z, z · _) (ProductPrCommutes C V _ _ _ _ _))). use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob. rewrite !assoc'. rewrite !internal_beta. cbn -[sym_mon_braiding]. use internal_funext. intros a' h'. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } etrans. { rewrite !assoc. rewrite <- tensor_comp_mor. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_mor. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. rewrite <- tensor_comp_mor. rewrite id_right. rewrite internal_beta. apply idpath. } refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite internal_beta. apply idpath. } etrans. { rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !tensor_comp_id_l. rewrite !assoc'. rewrite enrichment_assoc'. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. refine (!_). etrans. { do 3 apply maponpaths. apply tensor_split. } rewrite !assoc. apply maponpaths_2. etrans. { rewrite tensor_split'. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. rewrite <- tensor_comp_mor. rewrite id_left, id_right. apply idpath. } refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite tensor_rassociator. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. refine (_ @ id_right _). rewrite <- mon_lassociator_rassociator. rewrite !assoc. apply maponpaths_2. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply sym_mon_hexagon_lassociator. } rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite sym_mon_braiding_inv. rewrite tensor_id_id. rewrite id_left. apply idpath. Qed. Definition enriched_yoneda_enrichment_data : functor_enrichment_data enriched_yoneda_functor E (enriched_presheaf_enrichment E EqV PV PV'). Proof. intros y₁ y₂. refine (EqualizerIn _ _ (enriched_yoneda_enrichment_data_ob y₁ y₂) _). exact (enriched_yoneda_enrichment_data_eq y₁ y₂). Defined. Arguments enriched_yoneda_enrichment_data /. Proposition is_functor_enrichment_enriched_yoneda : is_functor_enrichment enriched_yoneda_enrichment_data. Proof. repeat split. - intros x ; cbn. use EqualizerInsEq. rewrite !assoc'. unfold enriched_functor_hom_id, mor_to_enriched_functor_hom. rewrite !EqualizerCommutes. use ProductArrow_eq. intro y. rewrite !assoc'. cbn. etrans. { apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } refine (_ @ !(ProductPrCommutes C V _ _ _ _ _)). use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. unfold internal_id. rewrite internal_beta. rewrite enrichment_id_left. rewrite !assoc. rewrite <- tensor_split. apply idpath. - intros x y z ; cbn. use EqualizerInsEq. rewrite !assoc'. unfold enriched_functor_hom_comp, mor_to_enriched_functor_hom. rewrite !EqualizerCommutes. use ProductArrow_eq. intro w. rewrite !assoc'. etrans. { apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } refine (!_). etrans. { apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } unfold enriched_functor_hom_comp_data, enriched_functor_hom_pr. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite !assoc. rewrite !EqualizerCommutes. etrans. { apply maponpaths_2. etrans. { apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } apply maponpaths_2. exact (ProductPrCommutes C V _ _ _ _ _). } refine (!_). use internal_funext ; cbn. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. refine (!_). etrans. { rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply maponpaths_2. apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite enrichment_assoc. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_comp_id_l. apply idpath. - intros x y f ; cbn. use EqualizerInsEq. rewrite !assoc'. unfold enriched_functor_hom_from_arr, mor_to_enriched_functor_hom. rewrite !EqualizerCommutes. use ProductArrow_eq. intro z. rewrite !assoc'. cbn. refine (ProductPrCommutes C V _ _ _ _ _ @ !_). etrans. { apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite internal_beta. unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_linvunitor. apply id_left. } rewrite <- tensor_split. apply idpath. Qed. Definition enriched_yoneda_enrichment : functor_enrichment enriched_yoneda_functor E (enriched_presheaf_enrichment E EqV PV PV') := enriched_yoneda_enrichment_data ,, is_functor_enrichment_enriched_yoneda. Definition enriched_yoneda : enriched_functor_category E (enriched_presheaf_enrichment E EqV PV PV') := enriched_yoneda_functor ,, enriched_yoneda_enrichment. End YonedaEmbedding. Arguments enriched_repr_presheaf_enrichment_data /. Arguments enriched_yoneda_enrichment_data_ob /. Arguments enriched_yoneda_enrichment_data /. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/FullyFaithful.v000066400000000000000000000163161451125700300251340ustar00rootroot00000000000000(************************************************************************* Lemmas for fully faithful enriched functors This file collects several lemmas on fully faithful enriched functors. The current lemmas are: - If `G` and `F ∙ G` are fully faithful, then `F` is fully faithful as well ([fully_faithful_enriched_precomp]) - Fully faithful functors are closed under natural isomorphis ([fully_faithful_enriched_nat_z_iso]) We also use these lemmas for a factorization lemma for fully faithful functors ([fully_faithful_enriched_factorization_precomp]). Contents 1. Composition of fully faithful functors 2. Fully faithful functors are closed under natural isomorphism 3. Factorization of fully faithful functors *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. (** * 1. Composition of fully faithful functors *) Section FullyFaithfulPrecomp. Context {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} (EF : functor_enrichment F E₁ E₂) (EG : functor_enrichment G E₂ E₃) (HFG : fully_faithful_enriched_functor (functor_comp_enrichment EF EG)) (HG : fully_faithful_enriched_functor EG). Section Iso. Context (x y : C₁). Let φ : z_iso (E₁ ⦃ x , y ⦄) (E₃ ⦃ G (F x) , G (F y) ⦄) := _ ,, HFG x y. Let ψ : z_iso _ _ := _ ,, HG (F x) (F y). Definition fully_faithful_precomp_inv : E₂ ⦃ F x , F y ⦄ --> E₁ ⦃ x , y ⦄ := EG (F x) (F y) · inv_from_z_iso φ. Proposition fully_faithful_precomp_inv_right : EF x y · fully_faithful_precomp_inv = identity _. Proof. unfold fully_faithful_precomp_inv. rewrite !assoc. refine (_ @ z_iso_inv_after_z_iso φ). apply maponpaths_2. apply idpath. Qed. Proposition fully_faithful_precomp_inv_left : fully_faithful_precomp_inv · EF x y = identity _. Proof. unfold fully_faithful_precomp_inv. refine (_ @ z_iso_inv_after_z_iso ψ). rewrite !assoc'. apply maponpaths. refine (!(id_right _) @ _). rewrite <- (z_iso_inv_after_z_iso ψ). rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. apply z_iso_after_z_iso_inv. Qed. End Iso. Proposition fully_faithful_enriched_precomp : fully_faithful_enriched_functor EF. Proof. intros x y. use make_is_z_isomorphism. - exact (fully_faithful_precomp_inv x y). - split. + exact (fully_faithful_precomp_inv_right x y). + exact (fully_faithful_precomp_inv_left x y). Qed. End FullyFaithfulPrecomp. (** * 2. Fully faithful functors are closed under natural isomorphism *) Section FullyFaithfulIso. Context {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {α : nat_z_iso F G} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {EF : functor_enrichment F E₁ E₂} {EG : functor_enrichment G E₁ E₂} (Hα : nat_trans_enrichment α EF EG) (HF : fully_faithful_enriched_functor EF). Section Iso. Context (x y : C₁). Let φ : z_iso (E₁ ⦃ x , y ⦄) (E₂ ⦃ F x , F y ⦄) := _ ,, HF x y. Definition fully_faithful_enriched_nat_z_iso_inv : E₂ ⦃ G x , G y ⦄ --> E₁ ⦃ x, y ⦄ := precomp_arr _ _ (α x) · postcomp_arr _ _ (inv_from_z_iso (nat_z_iso_pointwise_z_iso α y)) · inv_from_z_iso φ. Arguments fully_faithful_enriched_nat_z_iso_inv /. Proposition fully_faithful_enriched_nat_z_iso_inv_right : EG x y · fully_faithful_enriched_nat_z_iso_inv = identity _. Proof. cbn. refine (_ @ z_iso_inv_after_z_iso φ). rewrite !assoc. apply maponpaths_2. rewrite (nat_trans_enrichment_to_comp Hα x y). rewrite !assoc'. rewrite <- postcomp_arr_comp. etrans. { do 2 apply maponpaths. exact (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso α y)). } rewrite postcomp_arr_id. apply id_right. Qed. Proposition fully_faithful_enriched_nat_z_iso_inv_left : fully_faithful_enriched_nat_z_iso_inv · EG x y = identity _. Proof. cbn. refine (_ @ postcomp_arr_id _ _ _). refine (!_). etrans. { apply maponpaths. exact (!(z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso α y))). } cbn. rewrite precomp_postcomp_arr. rewrite postcomp_arr_comp. rewrite !assoc'. apply maponpaths. refine (!(id_left _) @ _). rewrite <- precomp_arr_id. etrans. { apply maponpaths_2. apply maponpaths. exact (!(z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso α x))). } rewrite precomp_arr_comp. rewrite !assoc'. apply maponpaths. rewrite precomp_postcomp_arr. etrans. { apply maponpaths_2. refine (!(id_left _) @ _). rewrite <- (z_iso_after_z_iso_inv φ). rewrite !assoc'. apply maponpaths. exact (!(nat_trans_enrichment_to_comp Hα x y)). } rewrite !assoc'. rewrite <- precomp_arr_comp. etrans. { do 3 apply maponpaths. exact (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso α x)). } rewrite precomp_arr_id. rewrite id_right. apply idpath. Qed. End Iso. Proposition fully_faithful_enriched_nat_z_iso : fully_faithful_enriched_functor EG. Proof. intros x y. use make_is_z_isomorphism. - exact (fully_faithful_enriched_nat_z_iso_inv x y). - split. + exact (fully_faithful_enriched_nat_z_iso_inv_right x y). + exact (fully_faithful_enriched_nat_z_iso_inv_left x y). Qed. End FullyFaithfulIso. (** * 3. Factorization of fully faithful functors *) Proposition fully_faithful_enriched_factorization_precomp {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₃} {G : C₁ ⟶ C₂} {H : C₂ ⟶ C₃} {α : nat_z_iso F (G ∙ H)} {V : monoidal_cat} {E₁ : enrichment C₁ V} {E₂ : enrichment C₂ V} {E₃ : enrichment C₃ V} (EF : functor_enrichment F E₁ E₃) (EG : functor_enrichment G E₁ E₂) (EH : functor_enrichment H E₂ E₃) (Hα : nat_trans_enrichment α EF (functor_comp_enrichment EG EH)) (HEF : fully_faithful_enriched_functor EF) (HEH : fully_faithful_enriched_functor EH) : fully_faithful_enriched_functor EG. Proof. exact (fully_faithful_enriched_precomp _ _ (fully_faithful_enriched_nat_z_iso Hα HEF) HEH). Qed. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/000077500000000000000000000000001451125700300234215ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedBinaryProducts.v000066400000000000000000000475311451125700300302340ustar00rootroot00000000000000(***************************************************************** Enriched binary products In this file, we define binary products in the enriched setting. For ordinary categories, we can formulate the universal property of products via hom-sets. More specifically, the product `a × b` of `a` and `b` satisfies the following universal property: for every `z`, we have a natural isomorphism from `z --> a × b` to `(z --> a) × (z --> b)`. From this natural isomorphism, we can deduce that a cone for the product consists of an object `z` together with projections `z --> a` and `z --> b`, and that to give a map `z --> a × b`, it suffices to give `z --> a` and `z --> b`. To define enriched products, we formulate this universal property in monoidal categories. More specifically, we say that the hom object `z --> a × b` is the product of `z --> a` and `z --> b`. Content 1. Cones of enriched products 2. Binary products in an enriched category 3. Being a binary product is a proposition 4. Binary products in the underlying category 5. Builders for binary products 6. Products are closed under iso 7. Products are isomorphic 8. Enriched categories with products *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.binproducts. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedProducts. Context {V : monoidal_cat} {C : category} (E : enrichment C V) (x y : C). (** 1. Cones of enriched binary products *) Definition enriched_binary_prod_cone : UU := ∑ (a : C), I_{V} --> E ⦃ a , x ⦄ × I_{V} --> E ⦃ a , y ⦄. Coercion ob_enriched_binary_prod_cone (a : enriched_binary_prod_cone) : C := pr1 a. Definition enriched_prod_cone_pr1 (a : enriched_binary_prod_cone) : a --> x := enriched_to_arr E (pr12 a). Definition enriched_prod_cone_pr2 (a : enriched_binary_prod_cone) : a --> y := enriched_to_arr E (pr22 a). Definition make_enriched_binary_prod_cone (a : C) (p₁ : I_{V} --> E ⦃ a , x ⦄) (p₂ : I_{V} --> E ⦃ a , y ⦄) : enriched_binary_prod_cone := a ,, p₁ ,, p₂. (** 2. Binary products in an enriched category *) Definition is_binary_prod_enriched (a : enriched_binary_prod_cone) : UU := ∏ (w : C), isBinProduct V (E ⦃ w , x ⦄) (E ⦃ w , y ⦄) (E ⦃ w , a ⦄) (postcomp_arr E w (enriched_prod_cone_pr1 a)) (postcomp_arr E w (enriched_prod_cone_pr2 a)). Definition is_binary_prod_enriched_to_BinProduct {a : enriched_binary_prod_cone} (Ha : is_binary_prod_enriched a) (w : C) : BinProduct V (E ⦃ w , x ⦄) (E ⦃ w , y ⦄). Proof. use make_BinProduct. - exact (E ⦃ w , a ⦄). - exact (postcomp_arr E w (enriched_prod_cone_pr1 a)). - exact (postcomp_arr E w (enriched_prod_cone_pr2 a)). - exact (Ha w). Defined. Definition binary_prod_enriched : UU := ∑ (a : enriched_binary_prod_cone), is_binary_prod_enriched a. Coercion cone_of_binary_prod_enriched (a : binary_prod_enriched) : enriched_binary_prod_cone := pr1 a. Coercion binary_prod_enriched_is_prod (a : binary_prod_enriched) : is_binary_prod_enriched a := pr2 a. (** 3. Being a binary product is a proposition *) Proposition isaprop_is_binary_prod_enriched (a : enriched_binary_prod_cone) : isaprop (is_binary_prod_enriched a). Proof. use impred ; intro. apply isaprop_isBinProduct. Qed. (** 4. Binary products in the underlying category *) Section InUnderlying. Context {a : enriched_binary_prod_cone} (Ha : is_binary_prod_enriched a). Definition is_binary_prod_enriched_arrow {w : C} (f : w --> x) (g : w --> y) : w --> a. Proof. refine (enriched_to_arr E _). use (BinProductArrow _ (is_binary_prod_enriched_to_BinProduct Ha w)). - exact (enriched_from_arr E f). - exact (enriched_from_arr E g). Defined. Proposition is_binary_prod_enriched_arrow_pr1 {w : C} (f : w --> x) (g : w --> y) : is_binary_prod_enriched_arrow f g · enriched_prod_cone_pr1 a = f. Proof. unfold is_binary_prod_enriched_arrow, enriched_prod_cone_pr1. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ BinProductPr1Commutes _ _ _ (is_binary_prod_enriched_to_BinProduct Ha w) _ (enriched_from_arr E f) (enriched_from_arr E g)). cbn. unfold postcomp_arr, enriched_prod_cone_pr1. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. rewrite !enriched_from_to_arr. apply idpath. Qed. Proposition is_binary_prod_enriched_arrow_pr2 {w : C} (f : w --> x) (g : w --> y) : is_binary_prod_enriched_arrow f g · enriched_prod_cone_pr2 a = g. Proof. unfold is_binary_prod_enriched_arrow, enriched_prod_cone_pr2. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ BinProductPr2Commutes _ _ _ (is_binary_prod_enriched_to_BinProduct Ha w) _ (enriched_from_arr E f) (enriched_from_arr E g)). cbn. unfold postcomp_arr, enriched_prod_cone_pr2. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. rewrite !enriched_from_to_arr. apply idpath. Qed. Proposition is_binary_prod_enriched_arrow_eq {w : C} {f g : w --> a} (q₁ : f · enriched_prod_cone_pr1 a = g · enriched_prod_cone_pr1 a) (q₂ : f · enriched_prod_cone_pr2 a = g · enriched_prod_cone_pr2 a) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (BinProductArrowsEq _ _ _ (is_binary_prod_enriched_to_BinProduct Ha w)). - cbn. unfold postcomp_arr. rewrite !assoc. rewrite !tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite <- !(enriched_to_arr_comp E). exact q₁. - cbn. unfold postcomp_arr. rewrite !assoc. rewrite !tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite <- !(enriched_to_arr_comp E). exact q₂. Qed. Definition underlying_BinProduct : BinProduct C x y. Proof. use make_BinProduct. - exact a. - exact (enriched_prod_cone_pr1 a). - exact (enriched_prod_cone_pr2 a). - intros w f g. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; exact (is_binary_prod_enriched_arrow_eq (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). + exact (is_binary_prod_enriched_arrow f g ,, is_binary_prod_enriched_arrow_pr1 f g ,, is_binary_prod_enriched_arrow_pr2 f g). Defined. End InUnderlying. (** 5. Builders for binary products *) Definition make_is_binary_prod_enriched (a : enriched_binary_prod_cone) (pair : ∏ (w : C) (v : V) (f : v --> E ⦃ w, x ⦄) (g : v --> E ⦃ w, y ⦄), v --> E ⦃ w , a ⦄) (pair_pr1 : ∏ (w : C) (v : V) (f : v --> E ⦃ w, x ⦄) (g : v --> E ⦃ w, y ⦄), pair w v f g · postcomp_arr E w (enriched_prod_cone_pr1 a) = f) (pair_pr2 : ∏ (w : C) (v : V) (f : v --> E ⦃ w, x ⦄) (g : v --> E ⦃ w, y ⦄), pair w v f g · postcomp_arr E w (enriched_prod_cone_pr2 a) = g) (pair_eq : ∏ (w : C) (v : V) (φ₁ φ₂ : v --> E ⦃ w , a ⦄) (q₁ : φ₁ · postcomp_arr E w (enriched_prod_cone_pr1 a) = φ₂ · postcomp_arr E w (enriched_prod_cone_pr1 a)) (q₂ : φ₁ · postcomp_arr E w (enriched_prod_cone_pr2 a) = φ₂ · postcomp_arr E w (enriched_prod_cone_pr2 a)), φ₁ = φ₂) : is_binary_prod_enriched a. Proof. intro w. use make_isBinProduct. intros v f g. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; exact (pair_eq w v (pr1 φ₁) (pr1 φ₂) (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))). - simple refine (_ ,, _ ,, _). + exact (pair w v f g). + exact (pair_pr1 w v f g). + exact (pair_pr2 w v f g). Defined. Definition binary_prod_enriched_to_prod (BPV : BinProducts V) (a : enriched_binary_prod_cone) (w : C) : E ⦃ w, a ⦄ --> BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄). Proof. use BinProductArrow. - exact (postcomp_arr E w (enriched_prod_cone_pr1 a)). - exact (postcomp_arr E w (enriched_prod_cone_pr2 a)). Defined. Definition make_is_binary_prod_enriched_from_z_iso (BPV : BinProducts V) (a : enriched_binary_prod_cone) (Ha : ∏ (w : C), is_z_isomorphism (binary_prod_enriched_to_prod BPV a w)) : is_binary_prod_enriched a. Proof. intro w. use (isBinProduct_z_iso (pr2 (BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄))) (_ ,, Ha w) _). - abstract (unfold binary_prod_enriched_to_prod ; cbn ; refine (!_) ; apply BinProductPr1Commutes). - abstract (unfold binary_prod_enriched_to_prod ; cbn ; refine (!_) ; apply BinProductPr2Commutes). Defined. Section BinaryProductFromUnderlying. Context (BPV : BinProducts V) (a : enriched_binary_prod_cone) (prod : isBinProduct C x y a (enriched_prod_cone_pr1 a) (enriched_prod_cone_pr2 a)) (w : C). Definition prod_from_underlying_arr_map (f : I_{V} --> BPV (E ⦃ w , x ⦄) (E ⦃ w, y ⦄)) : I_{V} --> E ⦃ w, a ⦄. Proof. apply enriched_from_arr. use (BinProductArrow _ (make_BinProduct _ _ _ _ _ _ prod)). - exact (enriched_to_arr E (f · BinProductPr1 _ _)). - exact (enriched_to_arr E (f · BinProductPr2 _ _)). Defined. Proposition prod_from_underlying_arr_map_eq₁ (f : I_{V} --> E ⦃ w, a ⦄) : prod_from_underlying_arr_map (f · binary_prod_enriched_to_prod BPV a w) = f. Proof. unfold prod_from_underlying_arr_map. refine (_ @ enriched_from_to_arr E f). apply maponpaths. use (BinProductArrowsEq _ _ _ (make_BinProduct C x y a _ _ prod)). - unfold binary_prod_enriched_to_prod. rewrite !assoc'. rewrite !BinProductPr1Commutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite !assoc'. rewrite enriched_from_to_arr. apply maponpaths. rewrite !assoc. apply idpath. - unfold binary_prod_enriched_to_prod. rewrite !assoc'. rewrite !BinProductPr2Commutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite !assoc'. rewrite enriched_from_to_arr. apply maponpaths. rewrite !assoc. apply idpath. Qed. Proposition prod_from_underlying_arr_map_eq₂ (f : I_{V} --> BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄)) : prod_from_underlying_arr_map f · binary_prod_enriched_to_prod BPV a w = f. Proof. unfold prod_from_underlying_arr_map. use (BinProductArrowsEq _ _ _ (BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄))). - unfold binary_prod_enriched_to_prod. rewrite !assoc'. rewrite !BinProductPr1Commutes. rewrite enriched_from_arr_postcomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (BinProductPr1Commutes _ _ _ (make_BinProduct C x y a _ _ prod)). - unfold binary_prod_enriched_to_prod. rewrite !assoc'. rewrite !BinProductPr2Commutes. rewrite enriched_from_arr_postcomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (BinProductPr2Commutes _ _ _ (make_BinProduct C x y a _ _ prod)). Qed. End BinaryProductFromUnderlying. Definition make_is_binary_prod_enriched_from_underlying (BPV : BinProducts V) (a : enriched_binary_prod_cone) (prod : isBinProduct C x y a (enriched_prod_cone_pr1 a) (enriched_prod_cone_pr2 a)) (HV : conservative_moncat V) : is_binary_prod_enriched a. Proof. use (make_is_binary_prod_enriched_from_z_iso BPV). intros w. use HV. use isweq_iso. - exact (prod_from_underlying_arr_map BPV a prod w). - exact (prod_from_underlying_arr_map_eq₁ BPV a prod w). - exact (prod_from_underlying_arr_map_eq₂ BPV a prod w). Defined. (** 6. Products are closed under iso *) Section ProdIso. Context (a : enriched_binary_prod_cone) (Ha : is_binary_prod_enriched a) (b : C) (f : z_iso b a). Definition enriched_binary_prod_cone_from_iso : enriched_binary_prod_cone := make_enriched_binary_prod_cone b (enriched_from_arr E (f · enriched_prod_cone_pr1 a)) (enriched_from_arr E (f · enriched_prod_cone_pr2 a)). Definition is_binary_prod_enriched_from_iso : is_binary_prod_enriched enriched_binary_prod_cone_from_iso. Proof. intros w. use (isBinProduct_z_iso (Ha w)). - exact (postcomp_arr_z_iso E w f). - abstract (cbn ; rewrite <- postcomp_arr_comp ; apply maponpaths ; unfold enriched_binary_prod_cone_from_iso ; cbn ; unfold enriched_prod_cone_pr1 ; cbn ; rewrite enriched_to_from_arr ; apply idpath). - abstract (cbn ; rewrite <- postcomp_arr_comp ; apply maponpaths ; unfold enriched_binary_prod_cone_from_iso ; cbn ; unfold enriched_prod_cone_pr2 ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End ProdIso. (** 7. Products are isomorphic *) Definition map_between_product_enriched {a b : enriched_binary_prod_cone} (Ha : is_binary_prod_enriched a) (Hb : is_binary_prod_enriched b) : a --> b := is_binary_prod_enriched_arrow Hb (enriched_prod_cone_pr1 a) (enriched_prod_cone_pr2 a). Lemma iso_between_product_enriched_inv {a b : enriched_binary_prod_cone} (Ha : is_binary_prod_enriched a) (Hb : is_binary_prod_enriched b) : map_between_product_enriched Ha Hb · map_between_product_enriched Hb Ha = identity _. Proof. unfold map_between_product_enriched. use (is_binary_prod_enriched_arrow_eq Ha). - rewrite !assoc'. rewrite !is_binary_prod_enriched_arrow_pr1. rewrite id_left. apply idpath. - rewrite !assoc'. rewrite !is_binary_prod_enriched_arrow_pr2. rewrite id_left. apply idpath. Qed. Definition iso_between_product_enriched {a b : enriched_binary_prod_cone} (Ha : is_binary_prod_enriched a) (Hb : is_binary_prod_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_product_enriched Ha Hb). - exact (map_between_product_enriched Hb Ha). - split. + apply iso_between_product_enriched_inv. + apply iso_between_product_enriched_inv. Defined. End EnrichedProducts. (** 8. Enriched categories with products *) Definition enrichment_binary_prod {V : monoidal_cat} {C : category} (E : enrichment C V) : UU := ∏ (x y : C), ∑ (a : enriched_binary_prod_cone E x y), is_binary_prod_enriched E x y a. Proposition isaprop_enrichment_binary_prod {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) : isaprop (enrichment_binary_prod E). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro x. use funextsec ; intro y. use subtypePath. { intro. apply isaprop_is_binary_prod_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_product_enriched. + exact (pr2 (φ₁ x y)). + exact (pr2 (φ₂ x y)). - rewrite transportf_dirprod. use pathsdirprod. + rewrite transportf_enriched_arr_l. rewrite idtoiso_inv. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_product_enriched ; cbn. apply is_binary_prod_enriched_arrow_pr1. + rewrite transportf_enriched_arr_l. rewrite idtoiso_inv. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_product_enriched ; cbn. apply is_binary_prod_enriched_arrow_pr2. Qed. Definition cat_with_enrichment_binary_prod (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_binary_prod C. Coercion cat_with_enrichment_binary_prod_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_binary_prod V) : cat_with_enrichment V := pr1 C. Definition binary_prod_of_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_binary_prod V) : enrichment_binary_prod C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedConicalLimits.v000066400000000000000000000403421451125700300300070ustar00rootroot00000000000000(***************************************************************** Enriched conical limits We define conical limits for enriched categories. A conical limit is the limit of a functor to the underlying category of an enriched category. Note that in ordinary category theory, these limits are called limits rather than conical limits. The reason for that, is that the 'right' notion of limit in enriched category is that of a weighted limit. The power is an example of a limit that is not conical. In addition, we show that conical limits can be constructed from type-indexed products and equalizers. We use a similar construction as the one used to construct limits from products and equalizers in ordinary category theory. Content 1. Cones of enriched conical limits 2. Conical limits in an enriched category 3. Being a conical limit is a proposition 4. Accessors for conical limits 5. Conical limits are isomorphic 6. Construction of conical limits *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section EnrichedConicalLimit. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {I : category} (D : I ⟶ C). (** 1. Cones of enriched conical limits *) Definition enriched_conical_lim_cone : UU := ∑ (a : C), ∑ (ps : ∏ (i : I), a --> D i), ∏ (i j : I) (f : i --> j), ps i · #D f = ps j. Coercion ob_enriched_conical_lim_cone (a : enriched_conical_lim_cone) : C := pr1 a. Definition enriched_conical_lim_cone_pr (a : enriched_conical_lim_cone) (i : I) : a --> D i := pr12 a i. Proposition enriched_conical_lim_cone_commute (a : enriched_conical_lim_cone) {i j : I} (f : i --> j) : enriched_conical_lim_cone_pr a i · #D f = enriched_conical_lim_cone_pr a j. Proof. exact (pr22 a i j f). Qed. Definition make_enriched_conical_lim_cone (a : C) (ps : ∏ (i : I), a --> D i) (eqs : ∏ (i j : I) (f : i --> j), ps i · #D f = ps j) : enriched_conical_lim_cone := a ,, ps ,, eqs. (** 2. Conical limits in an enriched category *) Definition is_conical_lim_enriched_diagram (a : enriched_conical_lim_cone) (w : C) : diagram I V. Proof. use make_diagram. - exact (λ i, E ⦃ w , D i ⦄). - exact (λ i j f, postcomp_arr E w (#D f)). Defined. Definition is_conical_lim_enriched_cone (a : enriched_conical_lim_cone) (w : C) : cone (is_conical_lim_enriched_diagram a w) (E ⦃ w, a ⦄). Proof. use make_cone. - exact (λ i, postcomp_arr E w (enriched_conical_lim_cone_pr a i)). - abstract (intros i j f ; cbn ; rewrite <- postcomp_arr_comp ; rewrite enriched_conical_lim_cone_commute ; apply idpath). Defined. Definition is_conical_lim_enriched (a : enriched_conical_lim_cone) : UU := ∏ (w : C), isLimCone (is_conical_lim_enriched_diagram a w) (E ⦃ w , a ⦄) (is_conical_lim_enriched_cone a w). Definition is_conical_lim_enriched_to_Lim {a : enriched_conical_lim_cone} (Ha : is_conical_lim_enriched a) (w : C) : LimCone (is_conical_lim_enriched_diagram a w). Proof. use make_LimCone. - exact (E ⦃ w , a ⦄). - exact (is_conical_lim_enriched_cone a w). - exact (Ha w). Defined. Definition conical_lim_enriched : UU := ∑ (a : enriched_conical_lim_cone), is_conical_lim_enriched a. Coercion cone_of_conical_lim_enriched (a : conical_lim_enriched) : enriched_conical_lim_cone := pr1 a. Coercion enriched_conical_lim_cone_is_conical_lim (a : conical_lim_enriched) : is_conical_lim_enriched a := pr2 a. (** 3. Being a conical limit is a proposition *) Proposition isaprop_is_conical_lim_enriched (a : enriched_conical_lim_cone) : isaprop (is_conical_lim_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. (** 4. Accessors for conical limits *) Section ConicalLimAccessors. Context (a : conical_lim_enriched). Definition is_conical_lim_enriched_arrow (w : C) (gs : ∏ (i : I), w --> D i) (qs : ∏ (i j : I) (f : i --> j), gs i · # D f = gs j) : w --> a. Proof. refine (enriched_to_arr E _). use (limArrow (make_LimCone _ _ _ (pr2 a w))). simple refine (_ ,, _). - exact (λ i, enriched_from_arr E (gs i)). - abstract (intros i j f ; cbn ; rewrite enriched_from_arr_postcomp ; apply maponpaths ; exact (qs i j f)). Defined. Proposition is_conical_lim_enriched_map_pr (w : C) (gs : ∏ (i : I), w --> D i) (qs : ∏ (i j : I) (f : i --> j), gs i · # D f = gs j) (i : I) : is_conical_lim_enriched_arrow w gs qs · enriched_conical_lim_cone_pr a i = gs i. Proof. unfold is_conical_lim_enriched_arrow, enriched_conical_lim_cone_pr. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. rewrite enriched_from_arr_comp. rewrite !enriched_from_to_arr. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. etrans. { rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). apply (limArrowCommutes (make_LimCone _ _ _ (pr2 a w))). } cbn. apply idpath. Qed. Proposition is_conical_lim_enriched_arrow_eq {w : C} {f g : w --> a} (q : ∏ (i : I), f · enriched_conical_lim_cone_pr a i = g · enriched_conical_lim_cone_pr a i) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (arr_to_LimCone_eq (is_conical_lim_enriched_to_Lim (pr2 a) w)). intro i ; cbn. rewrite !enriched_from_arr_postcomp. rewrite q. apply idpath. Qed. End ConicalLimAccessors. (** 5. Conical limits are isomorphic *) Definition map_between_conical_lim_enriched (a b : conical_lim_enriched) : a --> b. Proof. use (is_conical_lim_enriched_arrow b). - exact (enriched_conical_lim_cone_pr a). - exact (λ _ _ f, enriched_conical_lim_cone_commute a f). Defined. Lemma iso_between_conical_lim_enriched_inv (a b : conical_lim_enriched) : map_between_conical_lim_enriched a b · map_between_conical_lim_enriched b a = identity _. Proof. unfold map_between_conical_lim_enriched. use (is_conical_lim_enriched_arrow_eq a). intro j. rewrite !assoc'. rewrite !is_conical_lim_enriched_map_pr. rewrite id_left. apply idpath. Qed. Definition iso_between_conical_lim_enriched (a b : conical_lim_enriched) : z_iso a b. Proof. use make_z_iso. - exact (map_between_conical_lim_enriched a b). - exact (map_between_conical_lim_enriched b a). - split. + apply iso_between_conical_lim_enriched_inv. + apply iso_between_conical_lim_enriched_inv. Defined. Proposition isaprop_conical_lim_enriched (HC : is_univalent C) : isaprop (conical_lim_enriched). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaprop_is_conical_lim_enriched. } use total2_paths_f. - use (isotoid _ HC). apply iso_between_conical_lim_enriched. - use subtypePath. { intro. repeat (use impred ; intro). apply homset_property. } rewrite pr1_transportf. rewrite transportf_sec_constant. use funextsec. intro j. rewrite transportf_isotoid. use z_iso_inv_on_right ; cbn. refine (!_). apply is_conical_lim_enriched_map_pr. Qed. End EnrichedConicalLimit. (** 6. Construction of conical limits *) Section ConstructionOfConicalLimit. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {I : category} (D : I ⟶ C) (PE : ∏ (J : UU), enrichment_prod E J) (EE : enrichment_equalizers E). Let prod_src : C := pr1 (PE I D). Let is_prod_src : is_prod_enriched E D prod_src := pr2 (PE I D). Let prod_tar : C := pr1 (PE (∑ (x : I) (y : I), x --> y) (λ z, D (pr12 z))). Let is_prod_tar : is_prod_enriched E _ prod_tar := pr2 (PE (∑ (x : I) (y : I), x --> y) (λ z, D (pr12 z))). Local Definition enriched_conical_lim_from_prod_equalizers_l : prod_src --> prod_tar := is_prod_enriched_arrow _ _ is_prod_tar (λ j, enriched_prod_cone_pr _ _ _ (pr12 j)). Let f : prod_src --> prod_tar := enriched_conical_lim_from_prod_equalizers_l. Local Proposition enriched_conical_lim_from_prod_equalizers_l_pr {i j : I} (k : i --> j) : f · enriched_prod_cone_pr _ _ _ (i ,, j ,, k) = enriched_prod_cone_pr _ _ _ j. Proof. exact (is_prod_enriched_arrow_pr _ _ is_prod_tar (λ j, enriched_prod_cone_pr _ _ _ (pr12 j)) (i ,, j ,, k)). Qed. Local Definition enriched_conical_lim_from_prod_equalizers_r : prod_src --> prod_tar := is_prod_enriched_arrow _ _ is_prod_tar (λ j, enriched_prod_cone_pr _ _ _ (pr1 j) · #D (pr22 j)). Let g : prod_src --> prod_tar := enriched_conical_lim_from_prod_equalizers_r. Local Proposition enriched_conical_lim_from_prod_equalizers_r_pr {i j : I} (k : i --> j) : g · enriched_prod_cone_pr _ _ _ (i ,, j ,, k) = enriched_prod_cone_pr _ _ _ i · #D k. Proof. exact (is_prod_enriched_arrow_pr _ _ is_prod_tar _ (i ,, j ,, k)). Qed. Definition enriched_conical_lim_ob_from_prod_equalizers : C := pr1 (EE _ _ f g). Let lim : C := enriched_conical_lim_ob_from_prod_equalizers. Definition enriched_conical_lim_ob_from_prod_equalizers_is_equalizer : is_equalizer_enriched E f g lim := pr2 (EE _ _ f g). Definition enriched_conical_lim_pr_from_prod_equalizers (i : I) : lim --> D i := enriched_equalizer_cone_pr _ _ _ (pr1 (EE _ _ f g)) · enriched_prod_cone_pr _ _ _ i. Proposition enriched_conical_lim_eq_from_prod_equalizers {i j : I} (k : i --> j) : enriched_conical_lim_pr_from_prod_equalizers i · # D k = enriched_conical_lim_pr_from_prod_equalizers j. Proof. unfold enriched_conical_lim_pr_from_prod_equalizers. rewrite !assoc'. rewrite <- enriched_conical_lim_from_prod_equalizers_r_pr. rewrite <- (enriched_conical_lim_from_prod_equalizers_l_pr k). rewrite !assoc. apply maponpaths_2. refine (!_). exact (enriched_equalizer_cone_eq _ _ _ (pr1 (EE _ _ f g))). Qed. Definition enriched_conical_lim_from_prod_equalizers_cone : enriched_conical_lim_cone D. Proof. use make_enriched_conical_lim_cone. - exact lim. - exact enriched_conical_lim_pr_from_prod_equalizers. - exact (λ i j k, enriched_conical_lim_eq_from_prod_equalizers k). Defined. Section EnrichedConicalLimUMP. Context (w : C) (v : V) (fs : ∏ (i : I), v --> E ⦃ w, D i ⦄) (qs : ∏ (i j : I) (k : i --> j), fs i · postcomp_arr E w (# D k) = fs j). Proposition enriched_conical_lim_from_prod_equalizers_unique : isaprop (∑ (φ : v --> E ⦃ w, lim ⦄), ∏ (i : I), φ · postcomp_arr E w (enriched_conical_lim_pr_from_prod_equalizers i) = fs i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use (EqualizerInsEq (is_equalizer_enriched_to_Equalizer _ _ _ enriched_conical_lim_ob_from_prod_equalizers_is_equalizer w)). use (ProductArrow_eq _ _ _ (is_prod_enriched_to_Product _ _ is_prod_src w)). intro i ; cbn. rewrite !assoc'. rewrite <- !postcomp_arr_comp. exact (pr2 φ₁ i @ !(pr2 φ₂ i)). Qed. Definition enriched_conical_lim_from_prod_equalizers_mor : v --> E ⦃ w , lim ⦄. Proof. use (EqualizerIn (is_equalizer_enriched_to_Equalizer _ _ _ enriched_conical_lim_ob_from_prod_equalizers_is_equalizer w)). - exact (ProductArrow _ _ (is_prod_enriched_to_Product _ _ is_prod_src w) fs). - abstract (use (ProductArrow_eq _ _ _ (is_prod_enriched_to_Product _ _ is_prod_tar w)) ; intros ijk ; cbn ; pose (ProductPrCommutes I V _ (is_prod_enriched_to_Product E D is_prod_src w) _ fs) as p ; cbn in p ; rewrite !assoc' ; rewrite <- !postcomp_arr_comp ; rewrite enriched_conical_lim_from_prod_equalizers_l_pr ; rewrite enriched_conical_lim_from_prod_equalizers_r_pr ; rewrite postcomp_arr_comp ; rewrite !assoc ; rewrite !p ; refine (!_) ; apply qs). Defined. Proposition enriched_conical_lim_from_prod_equalizers_commute (i : I) : enriched_conical_lim_from_prod_equalizers_mor · postcomp_arr E w (enriched_conical_lim_pr_from_prod_equalizers i) = fs i. Proof. unfold enriched_conical_lim_from_prod_equalizers_mor. unfold enriched_conical_lim_pr_from_prod_equalizers. rewrite postcomp_arr_comp. rewrite !assoc. rewrite (EqualizerCommutes (is_equalizer_enriched_to_Equalizer E f g enriched_conical_lim_ob_from_prod_equalizers_is_equalizer w)). rewrite (ProductPrCommutes _ _ _ (is_prod_enriched_to_Product E D is_prod_src w)). apply idpath. Qed. End EnrichedConicalLimUMP. Definition enriched_conical_lim_from_prod_equalizers_is_lim : is_conical_lim_enriched E D enriched_conical_lim_from_prod_equalizers_cone. Proof. intros w v cc ; cbn. use iscontraprop1. - exact (enriched_conical_lim_from_prod_equalizers_unique w v (pr1 cc)). - simple refine (_ ,, _). + exact (enriched_conical_lim_from_prod_equalizers_mor _ _ (pr1 cc) (pr2 cc)). + exact (enriched_conical_lim_from_prod_equalizers_commute _ _ (pr1 cc) (pr2 cc)). Defined. Definition enriched_conical_lim_from_prod_equalizers : conical_lim_enriched E D := enriched_conical_lim_from_prod_equalizers_cone ,, enriched_conical_lim_from_prod_equalizers_is_lim. End ConstructionOfConicalLimit. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedEqualizers.v000066400000000000000000000424501451125700300274030ustar00rootroot00000000000000(***************************************************************** Enriched equalizers We define the notion of equalizers in the enriched setting. To do so, we formulate the universal property for equalizers in arbitrary monoidal categories rather than just set. Whereas cones for cones we can use the same definition, we need to reformulate the universal property to take the enrichment into account. The idea here is the same as for terminal objects and for binary products. Content 1. Cones of enriched equalizers 2. Equalizers in an enriched category 3. Being an equalizer is a proposition 4. Equalizers in the underlying category 5. Builders for equalizers 6. Equalizers are closed under iso 7. Equalizers are isomorphic 8. Enriched categories with equalizers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.equalizers. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedEqualizer. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {x y : C} (f g : x --> y). (** 1. Cones of enriched equalizers *) Definition enriched_equalizer_cone : UU := ∑ (a : C) (p : I_{V} --> E ⦃ a , x ⦄), enriched_to_arr E p · f = enriched_to_arr E p · g. Coercion ob_enriched_equalizer_cone (a : enriched_equalizer_cone) : C := pr1 a. Definition enriched_equalizer_cone_pr (a : enriched_equalizer_cone) : a --> x := enriched_to_arr E (pr12 a). Definition enriched_equalizer_cone_eq (a : enriched_equalizer_cone) : enriched_equalizer_cone_pr a · f = enriched_equalizer_cone_pr a · g := pr22 a. Definition make_enriched_equalizer_cone (a : C) (p : I_{V} --> E ⦃ a , x ⦄) (q : enriched_to_arr E p · f = enriched_to_arr E p · g) : enriched_equalizer_cone := a ,, p ,, q. Proposition postcomp_eq_from_equalizer_cone (a : enriched_equalizer_cone) (w : C) : postcomp_arr E w (enriched_equalizer_cone_pr a) · postcomp_arr E w f = postcomp_arr E w (enriched_equalizer_cone_pr a) · postcomp_arr E w g. Proof. rewrite <- !postcomp_arr_comp. apply maponpaths. apply enriched_equalizer_cone_eq. Qed. (** 2. Equalizers in an enriched category *) Definition is_equalizer_enriched (a : enriched_equalizer_cone) : UU := ∏ (w : C), isEqualizer (postcomp_arr E w f) (postcomp_arr E w g) (postcomp_arr E w (enriched_equalizer_cone_pr a)) (postcomp_eq_from_equalizer_cone a w). Definition is_equalizer_enriched_to_Equalizer {a : enriched_equalizer_cone} (Ha : is_equalizer_enriched a) (w : C) : Equalizer (postcomp_arr E w f) (postcomp_arr E w g). Proof. use make_Equalizer. - exact (E ⦃ w , a ⦄). - exact (postcomp_arr E w (enriched_equalizer_cone_pr a)). - exact (postcomp_eq_from_equalizer_cone a w). - exact (Ha w). Defined. Definition equalizer_enriched : UU := ∑ (a : enriched_equalizer_cone), is_equalizer_enriched a. Coercion cone_of_equalizer_enriched (a : equalizer_enriched) : enriched_equalizer_cone := pr1 a. Coercion equalizer_enriched_is_equalizer (a : equalizer_enriched) : is_equalizer_enriched a := pr2 a. (** 3. Being an equalizer is a proposition *) Proposition isaprop_is_equalizer_enriched (a : enriched_equalizer_cone) : isaprop (is_equalizer_enriched a). Proof. use impred ; intro. apply isaprop_isEqualizer. Qed. (** 4. Equalizers in the underlying category *) Section InUnderlying. Context {a : enriched_equalizer_cone} (Ha : is_equalizer_enriched a). Definition underlying_Equalizer_arr {w : C} (h : w --> x) (q : h · f = h · g) : w --> a. Proof. use (enriched_to_arr E). use (EqualizerIn (is_equalizer_enriched_to_Equalizer Ha w)). - exact (enriched_from_arr E h). - abstract (rewrite !enriched_from_arr_postcomp ; rewrite q ; apply idpath). Defined. Proposition underlying_Equalizer_arr_pr {w : C} (h : w --> x) (q : h · f = h · g) : underlying_Equalizer_arr h q · enriched_equalizer_cone_pr a = h. Proof. unfold underlying_Equalizer_arr, enriched_equalizer_cone_pr. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. rewrite enriched_from_arr_comp. rewrite !enriched_from_to_arr. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite !assoc'. refine (maponpaths (λ z, _ · z) _ @ EqualizerCommutes (is_equalizer_enriched_to_Equalizer Ha w) I_{V} (enriched_from_arr E h) _). cbn ; unfold postcomp_arr. rewrite !assoc'. apply maponpaths. do 2 apply maponpaths_2. refine (!_). apply enriched_from_to_arr. Qed. Proposition underlying_Equalizer_arr_eq {w : C} {h₁ h₂ : w --> a} (q : h₁ · enriched_equalizer_cone_pr a = h₂ · enriched_equalizer_cone_pr a) : h₁ = h₂. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (EqualizerInsEq (is_equalizer_enriched_to_Equalizer Ha w)). cbn. unfold postcomp_arr. rewrite !assoc. rewrite !tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite <- !(enriched_to_arr_comp E). exact q. Qed. Definition underlying_Equalizer : Equalizer f g. Proof. use make_Equalizer. - exact a. - exact (enriched_equalizer_cone_pr a). - exact (enriched_equalizer_cone_eq a). - intros w h q. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; exact (underlying_Equalizer_arr_eq (pr2 φ₁ @ !(pr2 φ₂)))). + exact (underlying_Equalizer_arr h q ,, underlying_Equalizer_arr_pr h q). Defined. End InUnderlying. (** 5. Builders for equalizers *) Definition make_is_equalizer_enriched (a : enriched_equalizer_cone) (eq_arr_eq : ∏ (w : C) (v : V) (h₁ h₂ : v --> E ⦃ w, a ⦄) (q : h₁ · postcomp_arr E w (enriched_equalizer_cone_pr a) = h₂ · postcomp_arr E w (enriched_equalizer_cone_pr a)), h₁ = h₂) (eq_in : ∏ (w : C) (v : V) (h : v --> E ⦃ w, x ⦄) (q : h · postcomp_arr E w f = h · postcomp_arr E w g), v --> E ⦃ w, a ⦄) (eq_in_eq : ∏ (w : C) (v : V) (h : v --> E ⦃ w, x ⦄) (q : h · postcomp_arr E w f = h · postcomp_arr E w g), eq_in w v h q · postcomp_arr E w (enriched_equalizer_cone_pr a) = h) : is_equalizer_enriched a. Proof. intro w. use make_isEqualizer. intros v h q. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; exact (eq_arr_eq w v _ _ (pr2 φ₁ @ !(pr2 φ₂)))). - exact (eq_in w v h q,, eq_in_eq w v h q). Defined. Definition equalizer_enriched_to_equalizer (EqV : Equalizers V) (a : enriched_equalizer_cone) (w : C) : E ⦃ w , a ⦄ --> EqV (E ⦃ w, x ⦄) _ (postcomp_arr E w f) (postcomp_arr E w g). Proof. use EqualizerIn. - exact (postcomp_arr E w (enriched_equalizer_cone_pr a)). - exact (postcomp_eq_from_equalizer_cone a w). Defined. Definition make_is_equalizer_enriched_from_z_iso (EqV : Equalizers V) (a : enriched_equalizer_cone) (Ha : ∏ (w : C), is_z_isomorphism (equalizer_enriched_to_equalizer EqV a w)) : is_equalizer_enriched a. Proof. intro w. use (isEqualizer_z_iso (pr22 (EqV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄) (postcomp_arr E w f) (postcomp_arr E w g))) (_ ,, Ha w)). abstract (unfold equalizer_enriched_to_equalizer ; cbn ; refine (!_) ; apply EqualizerCommutes). Defined. Section EqualizersFromUnderlying. Context (EqV : Equalizers V) (a : enriched_equalizer_cone) (eq_a : isEqualizer f g (enriched_equalizer_cone_pr a) (enriched_equalizer_cone_eq a)) (w : C). Definition equalizer_enriched_from_underlying_map (h : I_{ V} --> EqV _ _ (postcomp_arr E w f) (postcomp_arr E w g)) : I_{ V} --> E ⦃ w, a ⦄. Proof. use enriched_from_arr. use (EqualizerIn (make_Equalizer _ _ _ _ eq_a)). - exact (enriched_to_arr E (h · EqualizerArrow _)). - abstract (use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn ; rewrite !enriched_from_arr_comp ; rewrite !enriched_from_to_arr ; rewrite tensor_split ; rewrite !assoc ; rewrite <- tensor_linvunitor ; rewrite !assoc' ; rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)) ; refine (maponpaths (λ z, _ · z) (EqualizerEqAr (EqV _ _ (postcomp_arr E w f) (postcomp_arr E w g))) @ _) ; refine (!_) ; rewrite tensor_split ; rewrite !assoc ; rewrite <- tensor_linvunitor ; rewrite !assoc' ; do 2 apply maponpaths ; unfold postcomp_arr ; rewrite !assoc' ; apply idpath). Defined. Proposition equalizer_enriched_from_underlying_map_inv₁ (h : I_{ V} --> E ⦃ w, a ⦄) : equalizer_enriched_from_underlying_map (h · equalizer_enriched_to_equalizer EqV a w) = h. Proof. unfold equalizer_enriched_from_underlying_map. refine (_ @ enriched_from_to_arr E h). apply maponpaths. use (isEqualizerInsEq eq_a). etrans. { apply (EqualizerCommutes (make_Equalizer _ _ _ _ eq_a)). } unfold enriched_equalizer_cone_pr. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite enriched_from_to_arr. rewrite !assoc'. apply maponpaths. unfold equalizer_enriched_to_equalizer. rewrite EqualizerCommutes. rewrite !assoc. apply idpath. Qed. Proposition equalizer_enriched_from_underlying_map_inv₂ (h : I_{ V} --> EqV _ _ (postcomp_arr E w f) (postcomp_arr E w g)) : equalizer_enriched_from_underlying_map h · equalizer_enriched_to_equalizer EqV a w = h. Proof. unfold equalizer_enriched_from_underlying_map. use (isEqualizerInsEq (pr22 (EqV _ _ _ _))). unfold equalizer_enriched_to_equalizer. rewrite !assoc'. rewrite EqualizerCommutes. rewrite enriched_from_arr_postcomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (EqualizerCommutes (make_Equalizer _ _ _ _ eq_a)). Qed. End EqualizersFromUnderlying. Definition make_is_equalizer_enriched_from_underlying (EqV : Equalizers V) (a : enriched_equalizer_cone) (eq_a : isEqualizer f g (enriched_equalizer_cone_pr a) (enriched_equalizer_cone_eq a)) (HV : conservative_moncat V) : is_equalizer_enriched a. Proof. use (make_is_equalizer_enriched_from_z_iso EqV). intros w. use HV. use isweq_iso. - exact (equalizer_enriched_from_underlying_map EqV a eq_a w). - exact (equalizer_enriched_from_underlying_map_inv₁ EqV a eq_a w). - exact (equalizer_enriched_from_underlying_map_inv₂ EqV a eq_a w). Defined. (** 6. Equalizers are closed under iso *) Section EqualizerIso. Context (a : enriched_equalizer_cone) (Ha : is_equalizer_enriched a) (b : C) (h : z_iso b a). Definition enriched_equalizer_cone_from_iso : enriched_equalizer_cone. Proof. refine (make_enriched_equalizer_cone b (enriched_from_arr E (h · enriched_equalizer_cone_pr a)) _). abstract (rewrite !enriched_to_from_arr ; rewrite !assoc' ; apply maponpaths ; exact (enriched_equalizer_cone_eq a)). Defined. Definition is_equalizer_enriched_from_iso : is_equalizer_enriched enriched_equalizer_cone_from_iso. Proof. intros w. use (isEqualizer_z_iso (Ha w)). - exact (postcomp_arr_z_iso E w h). - abstract (cbn ; rewrite <- postcomp_arr_comp ; apply maponpaths ; unfold enriched_equalizer_cone_from_iso ; cbn ; unfold enriched_equalizer_cone_pr ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End EqualizerIso. (** 7. Equalizers are isomorphic *) Definition map_between_equalizer_enriched {a b : enriched_equalizer_cone} (Ha : is_equalizer_enriched a) (Hb : is_equalizer_enriched b) : a --> b := underlying_Equalizer_arr Hb (enriched_equalizer_cone_pr a) (enriched_equalizer_cone_eq a). Lemma iso_between_equalizer_enriched_inv {a b : enriched_equalizer_cone} (Ha : is_equalizer_enriched a) (Hb : is_equalizer_enriched b) : map_between_equalizer_enriched Ha Hb · map_between_equalizer_enriched Hb Ha = identity _. Proof. unfold map_between_equalizer_enriched. use (underlying_Equalizer_arr_eq Ha). rewrite !assoc'. rewrite !underlying_Equalizer_arr_pr. rewrite id_left. apply idpath. Qed. Definition iso_between_equalizer_enriched {a b : enriched_equalizer_cone} (Ha : is_equalizer_enriched a) (Hb : is_equalizer_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_equalizer_enriched Ha Hb). - exact (map_between_equalizer_enriched Hb Ha). - split. + apply iso_between_equalizer_enriched_inv. + apply iso_between_equalizer_enriched_inv. Defined. End EnrichedEqualizer. (** 8. Enriched categories with equalizers *) Definition enrichment_equalizers {V : monoidal_cat} {C : category} (E : enrichment C V) : UU := ∏ (x y : C) (f g : x --> y), ∑ (a : enriched_equalizer_cone E f g), is_equalizer_enriched E f g a. Proposition isaprop_enrichment_equalizers {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) : isaprop (enrichment_equalizers E). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro f. use funextsec ; intro g. use subtypePath. { intro. apply isaprop_is_equalizer_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_equalizer_enriched. + exact (pr2 (φ₁ x y f g)). + exact (pr2 (φ₂ x y f g)). - use subtypePath. { intro. apply homset_property. } rewrite pr1_transportf. rewrite transportf_enriched_arr_l. rewrite idtoiso_inv. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_equalizer_enriched ; cbn. apply underlying_Equalizer_arr_pr. Qed. Definition cat_with_enrichment_equalizers (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_equalizers C. Coercion cat_with_enrichment_equalizers_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_equalizers V) : cat_with_enrichment V := pr1 C. Definition equalizers_of_cat_with_enrichment_equalizers {V : monoidal_cat} (C : cat_with_enrichment_equalizers V) : enrichment_equalizers C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedLimits.v000066400000000000000000000363471451125700300265300ustar00rootroot00000000000000(***************************************************************** Limits in enriched categories In this file, we define the notion of limit in enriched categories. Note that these limits refer to weighted limits rather than so-called conical limits, because the former is actually the correct notion of limit in this setting. Contents 1. Cones of enriched limits 2. Limits in an enriched category 3. Being a limit is a proposition 4. Instances of limits 4.1. Powers as limits 4.2. Conical limits as limits *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.Ends. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedConicalLimits. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Opaque sym_mon_braiding. Section EnrichedLimit. Context {V : sym_mon_closed_cat} {I C : category} (E : enrichment C V) (D : I ⟶ C) (W : I ⟶ V). (** 1. Cones of enriched limits *) Definition enriched_lim_cone : UU := ∑ (a : C), ∑ (fs : ∏ (i : I), W i --> E ⦃ a , D i ⦄), ∏ (i j : I) (f : i --> j), fs i · postcomp_arr E a (#D f) = #W f · fs j. Coercion ob_enriched_lim_cone (a : enriched_lim_cone) : C := pr1 a. Definition enriched_lim_cone_pr (a : enriched_lim_cone) (i : I) : W i --> E ⦃ a , D i ⦄ := pr12 a i. Proposition enriched_lim_cone_commute (a : enriched_lim_cone) {i j : I} (f : i --> j) : enriched_lim_cone_pr a i · postcomp_arr E a (#D f) = #W f · enriched_lim_cone_pr a j. Proof. exact (pr22 a i j f). Qed. Definition make_enriched_lim_cone (a : C) (fs : ∏ (i : I), W i --> E ⦃ a , D i ⦄) (eqs : ∏ (i j : I) (f : i --> j), fs i · postcomp_arr E a (#D f) = #W f · fs j) : enriched_lim_cone := a ,, fs ,, eqs. (** 2. Limits in an enriched category *) Definition weighted_hom_data (w : C) : functor_data (category_binproduct (I^opp) I) V. Proof. use make_functor_data. - exact (λ i, W (pr1 i) ⊸ (E ⦃ w , D (pr2 i) ⦄)). - exact (λ i j k, internal_pre_post_comp (#W (pr1 k)) (postcomp_arr E w (#D (pr2 k)))). Defined. Proposition weighted_hom_is_functor (w : C) : is_functor (weighted_hom_data w). Proof. split. - intro i ; cbn. rewrite !functor_id. rewrite postcomp_arr_id. rewrite internal_pre_post_comp_id. apply idpath. - intros i j k f g ; cbn. rewrite !functor_comp. rewrite !postcomp_arr_comp. rewrite internal_pre_post_comp_comp. apply idpath. Qed. Definition weighted_hom (w : C) : category_binproduct (I^opp) I ⟶ V. Proof. use make_functor. - exact (weighted_hom_data w). - exact (weighted_hom_is_functor w). Defined. Definition is_lim_enriched_wedge_data (a : enriched_lim_cone) (w : C) : wedge_data (weighted_hom w). Proof. use make_wedge_data. - exact (E ⦃ w , a ⦄). - exact (λ i, internal_lam (identity _ #⊗ enriched_lim_cone_pr a i · sym_mon_braiding _ _ _ · enriched_comp E _ _ _)). Defined. Proposition is_lim_enriched_is_wedge (a : enriched_lim_cone) (w : C) : is_wedge (weighted_hom w) (is_lim_enriched_wedge_data a w). Proof. intros i j g ; cbn -[sym_mon_braiding]. rewrite !functor_id. rewrite postcomp_arr_id. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_pre_post_comp. rewrite !internal_beta. rewrite !tensor_id_id. rewrite id_left, id_right. rewrite !assoc. rewrite tensor_split. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite tensor_sym_mon_braiding. rewrite !assoc'. rewrite enriched_comp_postcomp_arr. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)). rewrite <- tensor_comp_id_r. rewrite enriched_lim_cone_commute. rewrite tensor_comp_id_r. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- tensor_sym_mon_braiding. rewrite !assoc. refine (!_). rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. Qed. Definition is_lim_enriched_wedge (a : enriched_lim_cone) (w : C) : wedge (weighted_hom w). Proof. use make_wedge. - exact (is_lim_enriched_wedge_data a w). - exact (is_lim_enriched_is_wedge a w). Defined. Definition is_lim_enriched (a : enriched_lim_cone) : UU := ∏ (w : C), is_end (weighted_hom w) (is_lim_enriched_wedge a w). Definition lim_enriched : UU := ∑ (a : enriched_lim_cone), is_lim_enriched a. Coercion cone_of_lim_enriched (a : lim_enriched) : enriched_lim_cone := pr1 a. Definition enriched_lim_cone_is_lim (a : lim_enriched) : is_lim_enriched a := pr2 a. (** 3. Being a limit is a proposition *) Proposition isaprop_is_lim_enriched (a : enriched_lim_cone) : isaprop (is_lim_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. End EnrichedLimit. (** 4. Instances of limits *) (** 4.1. Powers as limits *) Section LimitToPower. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (v : V) (x : C). Let I : category := unit_category. Let D : I ⟶ C := constant_functor _ _ x. Let W : I ⟶ V := constant_functor _ _ v. Context (a : lim_enriched E D W). Definition power_from_lim_cone : power_cone E v x. Proof. use make_power_cone. - exact a. - exact (enriched_lim_cone_pr _ _ _ a tt). Defined. Section PowerUMP. Context (w : C). Definition power_from_lim_wedge_data : wedge_data (weighted_hom E D W w). Proof. use make_wedge_data ; cbn. - exact (v ⊸ (E ⦃ w, x ⦄)). - exact (λ _, identity _). Defined. Proposition power_from_lim_is_wedge : is_wedge (weighted_hom E D W w) power_from_lim_wedge_data. Proof. intros i j k. apply idpath. Qed. Definition power_from_lim_wedge : wedge (weighted_hom E D W w). Proof. use make_wedge. - exact power_from_lim_wedge_data. - exact power_from_lim_is_wedge. Defined. Proposition power_from_lim_wedge_inv_1 : is_power_enriched_map E v x power_from_lim_cone w · mor_to_end (weighted_hom E D W w) (enriched_lim_cone_is_lim E _ _ a w) power_from_lim_wedge = identity _. Proof. use (mor_to_end_eq _ (pr2 a w)). intro i. rewrite !assoc'. etrans. { apply maponpaths. exact (mor_to_end_comm _ (pr2 a w) power_from_lim_wedge i). } refine (id_right _ @ _ @ !(id_left _)). use internal_funext. intros z h. rewrite tensor_split. rewrite !assoc'. unfold is_power_enriched_map. rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. etrans. { apply internal_beta. } rewrite !assoc. induction i. apply idpath. Qed. Proposition power_from_lim_wedge_inv_2 : mor_to_end (weighted_hom E D W w) (pr2 a w) power_from_lim_wedge · is_power_enriched_map E v x power_from_lim_cone w = identity _. Proof. exact (mor_to_end_comm (weighted_hom E D W w) (pr2 a w) power_from_lim_wedge tt). Qed. End PowerUMP. Definition is_power_enriched_from_lim_cone : is_power_enriched _ _ _ power_from_lim_cone. Proof. use make_is_power_enriched. - exact (λ w, mor_to_end _ (pr2 a w) (power_from_lim_wedge w)). - exact power_from_lim_wedge_inv_1. - exact power_from_lim_wedge_inv_2. Defined. End LimitToPower. (** 4.2. Conical limits as limits *) Section LimitToConical. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) {I : category} (D : I ⟶ C). Let W : I ⟶ V := constant_functor _ _ I_{V}. Context (a : lim_enriched E D W). Definition enriched_weighted_to_conical_cone : enriched_conical_lim_cone D. Proof. use make_enriched_conical_lim_cone. - exact a. - exact (λ i, enriched_to_arr E (enriched_lim_cone_pr _ _ _ a i)). - abstract (intros i j f ; cbn ; use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn ; rewrite enriched_from_to_arr ; pose (enriched_lim_cone_commute _ _ _ a f) as p ; cbn in p ; rewrite id_left in p ; rewrite <- p ; rewrite enriched_from_arr_comp ; rewrite enriched_from_to_arr ; rewrite tensor_split ; rewrite !assoc ; rewrite <- tensor_linvunitor ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; apply idpath). Defined. Section ConicalLimUMP. Context {w : C} (v : V) (fs : ∏ (i : I), v --> E ⦃ w, D i ⦄) (ps : ∏ (i j : I) (k : i --> j), fs i · postcomp_arr E w (#D k) = fs j). Proposition enriched_weighted_to_conical_is_conical_lim_unique : isaprop (∑ (g : v --> E ⦃ w, a ⦄), ∏ (i : I), g · postcomp_arr E w (enriched_to_arr E (enriched_lim_cone_pr E D W a i)) = fs i). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use impred ; intro. apply homset_property. } use (mor_to_end_eq _ (pr2 a w)). intros i ; cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite !internal_beta. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_right. rewrite !tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. rewrite !tensor_comp_r_id_l. rewrite !assoc'. apply maponpaths. pose (p := maponpaths (λ z, mon_lunitor _ · z) (pr2 φ₁ i @ !(pr2 φ₂ i))). cbn in p. unfold postcomp_arr in p. rewrite !enriched_from_to_arr in p. rewrite !assoc' in p. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) in p. rewrite !tensor_linvunitor in p. rewrite !assoc in p. rewrite !mon_lunitor_linvunitor in p. rewrite !id_left in p. rewrite <- !tensor_split in p. exact p. Qed. Definition enriched_weighted_to_conical_is_conical_lim_wedge_data : wedge_data (weighted_hom E D W w). Proof. use make_wedge_data. - exact v. - exact (λ i, internal_lam (mon_runitor _ · fs i)). Defined. Proposition enriched_weighted_to_conical_is_conical_lim_is_wedge : is_wedge (weighted_hom E D W w) enriched_weighted_to_conical_is_conical_lim_wedge_data. Proof. intros i j f ; cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_pre_post_comp. rewrite !internal_beta. rewrite functor_id. rewrite postcomp_arr_id. rewrite id_right. rewrite !tensor_id_id. rewrite !id_left. rewrite tensor_split. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. rewrite !assoc'. do 2 apply maponpaths. refine (!_). apply ps. Qed. Definition enriched_weighted_to_conical_is_conical_lim_wedge : wedge (weighted_hom E D W w). Proof. use make_wedge. - exact enriched_weighted_to_conical_is_conical_lim_wedge_data. - exact enriched_weighted_to_conical_is_conical_lim_is_wedge. Defined. Definition enriched_weighted_to_conical_is_conical_lim_mor : v --> E ⦃ w, a ⦄ := mor_to_end _ (pr2 a w) enriched_weighted_to_conical_is_conical_lim_wedge. Proposition enriched_weighted_to_conical_is_conical_lim_mor_eq (i : I) : enriched_weighted_to_conical_is_conical_lim_mor · postcomp_arr E w (enriched_to_arr E (enriched_lim_cone_pr E D W a i)) = fs i. Proof. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (mor_to_end_comm _ (pr2 a w) enriched_weighted_to_conical_is_conical_lim_wedge i)) as p. cbn in p. rewrite tensor_comp_id_r in p. rewrite !assoc' in p. rewrite !internal_beta in p. rewrite !assoc in p. rewrite <- tensor_split' in p. rewrite tensor_sym_mon_braiding in p. refine (_ @ id_left _). rewrite <- mon_rinvunitor_runitor. rewrite !assoc'. rewrite <- p. unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite sym_mon_braiding_rinvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. rewrite enriched_from_to_arr. apply idpath. Qed. End ConicalLimUMP. Definition enriched_weighted_to_conical_is_conical_lim : is_conical_lim_enriched E D enriched_weighted_to_conical_cone. Proof. intros w v cc. use iscontraprop1. - exact (enriched_weighted_to_conical_is_conical_lim_unique v (pr1 cc)). - refine (enriched_weighted_to_conical_is_conical_lim_mor v (pr1 cc) (pr2 cc) ,, _). intros i. exact (enriched_weighted_to_conical_is_conical_lim_mor_eq v (pr1 cc) (pr2 cc) i). Defined. End LimitToConical. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedPowers.v000066400000000000000000000216321451125700300265350ustar00rootroot00000000000000(***************************************************************** Powers in enriched categories Let `C` be a category enriched over `V`. If we have an object `x : C` and an object `v : V`, then the power `v ⋔ x` informally represents a `v`-indexed product of `x`. More precisely, the power satisfies the following universal property z --> v ⋔ x ≅ v ⊸ (z --> x) where `⊸` denotes the internal hom of `V`. If we look at categories enriched over sets, then the power is indeed such a product. Content 1. Cones of powers 2. Powers in an enriched category 3. Being a power is a proposition 4. Accessors for powers 5. Builders for powers 6. Powers are closed under iso 7. Enriched categories with powers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Opaque sym_mon_braiding. Section EnrichedPowers. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (v : V) (x : C). (** 1. Cones of powers *) Definition power_cone : UU := ∑ (a : C), v --> E ⦃ a , x ⦄. Coercion ob_power_cone (a : power_cone) : C := pr1 a. Definition power_cone_mor (a : power_cone) : v --> E ⦃ a , x ⦄ := pr2 a. Definition make_power_cone (a : C) (f : v --> E ⦃ a , x ⦄) : power_cone := a ,, f. (** 2. Powers in an enriched category *) Definition is_power_enriched_map (a : power_cone) (w : C) : E ⦃ w , a ⦄ --> v ⊸ (E ⦃ w , x ⦄) := internal_lam (identity _ #⊗ power_cone_mor a · sym_mon_braiding V _ _ · enriched_comp E w a x). Definition is_power_enriched (a : power_cone) : UU := ∏ (w : C), is_z_isomorphism (is_power_enriched_map a w). Definition is_power_enriched_iso {a : power_cone} (Ha : is_power_enriched a) (w : C) : z_iso (E ⦃ w , a ⦄) (v ⊸ (E ⦃ w , x ⦄)) := _ ,, Ha w. (** 3. Being a power is a proposition *) Proposition isaprop_is_power_enriched (a : power_cone) : isaprop (is_power_enriched a). Proof. use impred ; intro. apply isaprop_is_z_isomorphism. Qed. (** 4. Accessors for powers *) Section Accessors. Context {a : power_cone} (Ha : is_power_enriched a). Definition mor_to_power {w : V} {b : C} (f : w --> v ⊸ (E ⦃ b, x ⦄)) : w --> E ⦃ b , a ⦄ := f · inv_from_z_iso (is_power_enriched_iso Ha b). Proposition mor_to_power_commutes {w : V} {b : C} (f : w --> v ⊸ (E ⦃ b, x ⦄)) : mor_to_power f · is_power_enriched_map a b = f. Proof. unfold mor_to_power. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply z_iso_after_z_iso_inv. Qed. Proposition mor_to_power_eq {w : V} {b : C} {f g : w --> E ⦃ b , a ⦄} (p : f · is_power_enriched_map a b = g · is_power_enriched_map a b) : f = g. Proof. use (cancel_z_iso _ _ (is_power_enriched_iso Ha _)). exact p. Qed. Definition arr_to_power {b : C} (f : I_{V} --> v ⊸ (E ⦃ b, x ⦄)) : b --> a := enriched_to_arr E (mor_to_power f). Proposition arr_to_power_commutes {b : C} (f : I_{V} --> v ⊸ (E ⦃ b, x ⦄)) : enriched_from_arr E (arr_to_power f) · is_power_enriched_map a b = f. Proof. unfold arr_to_power. rewrite enriched_from_to_arr. apply mor_to_power_commutes. Qed. Proposition arr_to_power_eq {b : C} {f g : b --> a} (p : enriched_from_arr E f · is_power_enriched_map a b = enriched_from_arr E g · is_power_enriched_map a b) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use mor_to_power_eq. exact p. Qed. End Accessors. (** 5. Builders for powers *) Definition make_is_power_enriched (a : power_cone) (p_map : ∏ (w : C), v ⊸ (E ⦃ w, x ⦄) --> E ⦃ w, a ⦄) (H₁ : ∏ (w : C), is_power_enriched_map a w · p_map w = identity _) (H₂ : ∏ (w : C), p_map w · is_power_enriched_map a w = identity _) : is_power_enriched a. Proof. intro w. use make_is_z_isomorphism. - exact (p_map w). - split. + exact (H₁ w). + exact (H₂ w). Defined. (** 6. Powers are closed under iso *) Section PowerIso. Context (a : power_cone) (Ha : is_power_enriched a) (b : C) (f : z_iso b a). Definition power_cone_from_iso : power_cone. Proof. use make_power_cone. - exact b. - exact (power_cone_mor a · precomp_arr E x f). Defined. Definition is_power_enriched_from_iso : is_power_enriched power_cone_from_iso. Proof. intros w. refine (transportf is_z_isomorphism _ (is_z_iso_comp_of_is_z_isos _ _ (postcomp_arr_is_z_iso E w _ (pr2 f)) (Ha w))). unfold postcomp_arr, is_power_enriched_map. cbn. use internal_funext. intros z h. rewrite !tensor_comp_r_id_r. refine (!_). etrans. { rewrite tensor_split. apply idpath. } rewrite !assoc'. rewrite !internal_beta. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. rewrite enrichment_assoc'. apply idpath. } rewrite !assoc. apply maponpaths_2. etrans. { do 2 apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } refine (!_). etrans. { rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_id_id. rewrite tensor_rassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_rassociator. rewrite !assoc. apply maponpaths_2. rewrite tensor_split'. rewrite mon_inv_triangle. rewrite !assoc'. rewrite mon_lassociator_rassociator. rewrite id_right. apply idpath. } rewrite <- !tensor_comp_id_r. apply maponpaths_2. rewrite !assoc'. apply maponpaths. unfold precomp_arr. rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. rewrite <- tensor_split'. apply idpath. Qed. End PowerIso. End EnrichedPowers. (** 7. Enriched categories with powers *) Definition enrichment_power {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) : UU := ∏ (v : V) (x : C), ∑ (e : power_cone E v x), is_power_enriched E v x e. Definition cat_with_enrichment_power (V : sym_mon_closed_cat) : UU := ∑ (C : cat_with_enrichment V), enrichment_power C. Coercion cat_with_enrichment_power_to_cat_with_enrichment {V : sym_mon_closed_cat} (C : cat_with_enrichment_power V) : cat_with_enrichment V := pr1 C. Definition powers_of_cat_with_enrichment {V : sym_mon_closed_cat} (C : cat_with_enrichment_power V) : enrichment_power C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedProducts.v000066400000000000000000000351631451125700300270650ustar00rootroot00000000000000(***************************************************************** Type indexed enriched products In this file, we define the type indexed products in enriched categories. The definition foollows the same ideas as the definition for enriched binary, and the only difference is that we index the product by a type. Content 1. Cones of enriched products 2. Products in an enriched category 3. Being a product is a proposition 4. Products in the underlying category 5. Builders for products 6. Products are closed under iso 7. Products are isomorphic 8. Enriched categories with products *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.products. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedProducts. Context {V : monoidal_cat} {C : category} (E : enrichment C V) {J : UU} (D : J → C). (** 1. Cones of enriched products *) Definition enriched_prod_cone : UU := ∑ (a : C), ∏ (j : J), I_{V} --> E ⦃ a , D j ⦄. Coercion ob_enriched_prod_cone (a : enriched_prod_cone) : C := pr1 a. Definition enriched_prod_cone_pr (a : enriched_prod_cone) (j : J) : a --> D j := enriched_to_arr E (pr2 a j). Definition make_enriched_prod_cone (a : C) (p : ∏ (j : J), I_{V} --> E ⦃ a , D j ⦄) : enriched_prod_cone := a ,, p. (** 2. Products in an enriched category *) Definition is_prod_enriched (a : enriched_prod_cone) : UU := ∏ (w : C), isProduct J V (λ j, E ⦃ w , D j ⦄) (E ⦃ w , a ⦄) (λ j, postcomp_arr E w (enriched_prod_cone_pr a j)). Definition is_prod_enriched_to_Product {a : enriched_prod_cone} (Ha : is_prod_enriched a) (w : C) : Product J V (λ j, E ⦃ w , D j ⦄). Proof. use make_Product. - exact (E ⦃ w , a ⦄). - exact (λ j, postcomp_arr E w (enriched_prod_cone_pr a j)). - exact (Ha w). Defined. Definition prod_enriched : UU := ∑ (a : enriched_prod_cone), is_prod_enriched a. Coercion cone_of_prod_enriched (a : prod_enriched) : enriched_prod_cone := pr1 a. Coercion prod_enriched_is_prod (a : prod_enriched) : is_prod_enriched a := pr2 a. (** 3. Being a product is a proposition *) Proposition isaprop_is_prod_enriched (a : enriched_prod_cone) : isaprop (is_prod_enriched a). Proof. repeat (use impred ; intro). apply isapropiscontr. Qed. (** 4. Products in the underlying category *) Section InUnderlying. Context {a : enriched_prod_cone} (Ha : is_prod_enriched a). Definition is_prod_enriched_arrow {w : C} (f : ∏ (j : J), w --> D j) : w --> a. Proof. refine (enriched_to_arr E _). use (ProductArrow _ _ (is_prod_enriched_to_Product Ha w)). exact (λ j, enriched_from_arr E (f j)). Defined. Proposition is_prod_enriched_arrow_pr {w : C} (f : ∏ (j : J), w --> D j) (j : J) : is_prod_enriched_arrow f · enriched_prod_cone_pr a j = f j. Proof. unfold is_prod_enriched_arrow, enriched_prod_cone_pr. use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn. refine (_ @ ProductPrCommutes _ _ _ (is_prod_enriched_to_Product Ha w) _ (λ j, enriched_from_arr E (f j)) j). cbn. unfold postcomp_arr, enriched_prod_cone_pr. rewrite enriched_from_arr_comp. rewrite !assoc. apply maponpaths_2. rewrite tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite <- tensor_split. rewrite !enriched_from_to_arr. apply idpath. Qed. Proposition is_prod_enriched_arrow_eq {w : C} {f g : w --> a} (q : ∏ (j : J), f · enriched_prod_cone_pr a j = g · enriched_prod_cone_pr a j) : f = g. Proof. refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _). apply maponpaths. use (ProductArrow_eq _ _ _ (is_prod_enriched_to_Product Ha w)). intro j. cbn. unfold postcomp_arr. rewrite !assoc. rewrite !tensor_linvunitor. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- !tensor_split. use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn. rewrite !assoc. rewrite <- !(enriched_to_arr_comp E). exact (q j). Qed. Definition underlying_Product : Product J C D. Proof. use make_Product. - exact a. - exact (enriched_prod_cone_pr a). - intros w f. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; exact (is_prod_enriched_arrow_eq (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))). + exact (is_prod_enriched_arrow f ,, is_prod_enriched_arrow_pr f). Defined. End InUnderlying. (** 5. Builders for products *) Definition make_is_prod_enriched (a : enriched_prod_cone) (pair : ∏ (w : C) (v : V) (f : ∏ (j : J), v --> E ⦃ w , D j ⦄), v --> E ⦃ w , a ⦄) (pair_pr : ∏ (w : C) (v : V) (f : ∏ (j : J), v --> E ⦃ w , D j ⦄) (j : J), pair w v f · postcomp_arr E w (enriched_prod_cone_pr a j) = f j) (pair_eq : ∏ (w : C) (v : V) (φ₁ φ₂ : v --> E ⦃ w , a ⦄) (q : ∏ (j : J), φ₁ · postcomp_arr E w (enriched_prod_cone_pr a j) = φ₂ · postcomp_arr E w (enriched_prod_cone_pr a j)), φ₁ = φ₂) : is_prod_enriched a. Proof. intro w. use make_isProduct. { apply homset_property. } intros v f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; exact (pair_eq w v (pr1 φ₁) (pr1 φ₂) (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))). - simple refine (_ ,, _). + exact (pair w v f). + exact (pair_pr w v f). Defined. Definition prod_enriched_to_prod (PV : Products J V) (a : enriched_prod_cone) (w : C) : E ⦃ w, a ⦄ --> PV (λ j, E ⦃ w, D j ⦄). Proof. use ProductArrow. exact (λ j, postcomp_arr E w (enriched_prod_cone_pr a j)). Defined. Definition make_is_prod_enriched_from_z_iso (PV : Products J V) (a : enriched_prod_cone) (Ha : ∏ (w : C), is_z_isomorphism (prod_enriched_to_prod PV a w)) : is_prod_enriched a. Proof. intro w. use (isProduct_z_iso _ _ _ _ (pr2 (PV (λ j, E ⦃ w , D j ⦄)))). - exact (z_iso_inv (_ ,, Ha w)). - abstract (intro j ; unfold prod_enriched_to_prod ; cbn ; refine (!_) ; apply (ProductPrCommutes _ _ _ (PV (λ j, E ⦃ w , D j ⦄)))). Defined. Section ProductFromUnderlying. Context (PV : Products J V) (a : enriched_prod_cone) (prod : isProduct J C D a (enriched_prod_cone_pr a)) (w : C). Definition prod_from_underlying_arr_map (f : I_{V} --> PV (λ j, E ⦃ w , D j ⦄)) : I_{V} --> E ⦃ w, a ⦄. Proof. apply enriched_from_arr. use (ProductArrow _ _ (make_Product _ _ _ _ _ prod)). intro j. exact (enriched_to_arr E (f · ProductPr _ _ _ j)). Defined. Proposition prod_from_underlying_arr_map_eq₁ (f : I_{V} --> E ⦃ w, a ⦄) : prod_from_underlying_arr_map (f · prod_enriched_to_prod PV a w) = f. Proof. unfold prod_from_underlying_arr_map. refine (_ @ enriched_from_to_arr E f). apply maponpaths. use (ProductArrow_eq _ _ _ (make_Product _ _ _ _ _ prod)). unfold prod_enriched_to_prod. intro j. rewrite ProductPrCommutes ; cbn. rewrite (enriched_to_arr_comp E). apply maponpaths. rewrite tensor_split. rewrite !assoc. rewrite <- tensor_linvunitor. rewrite !assoc'. rewrite enriched_from_to_arr. apply maponpaths. rewrite !assoc. etrans. { apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ w , D k ⦄)) _ _ j). } apply idpath. Qed. Proposition prod_from_underlying_arr_map_eq₂ (f : I_{V} --> PV (λ j, E ⦃ w , D j ⦄)) : prod_from_underlying_arr_map f · prod_enriched_to_prod PV a w = f. Proof. unfold prod_from_underlying_arr_map. use (ProductArrow_eq _ _ _ (PV (λ j, E ⦃ w, D j ⦄))). unfold prod_enriched_to_prod. intro j. rewrite !assoc'. etrans. { apply maponpaths. apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ w , D k ⦄)) _ _ j). } rewrite enriched_from_arr_postcomp. refine (_ @ enriched_from_to_arr E _). apply maponpaths. apply (ProductPrCommutes _ _ _ (make_Product _ _ _ _ _ prod)). Qed. End ProductFromUnderlying. Definition make_is_prod_enriched_from_underlying (PV : Products J V) (a : enriched_prod_cone) (prod : isProduct J C D a (enriched_prod_cone_pr a)) (HV : conservative_moncat V) : is_prod_enriched a. Proof. use (make_is_prod_enriched_from_z_iso PV). intros w. use HV. use isweq_iso. - exact (prod_from_underlying_arr_map PV a prod w). - exact (prod_from_underlying_arr_map_eq₁ PV a prod w). - exact (prod_from_underlying_arr_map_eq₂ PV a prod w). Defined. (** 6. Products are closed under iso *) Section ProdIso. Context (a : enriched_prod_cone) (Ha : is_prod_enriched a) (b : C) (f : z_iso b a). Definition enriched_prod_cone_from_iso : enriched_prod_cone := make_enriched_prod_cone b (λ j, enriched_from_arr E (f · enriched_prod_cone_pr a j)). Definition is_prod_enriched_from_iso : is_prod_enriched enriched_prod_cone_from_iso. Proof. intros w. use (isProduct_z_iso _ _ _ _ (Ha w)). - exact (postcomp_arr_z_iso E w (z_iso_inv f)). - abstract (intro j ; cbn ; rewrite <- postcomp_arr_comp ; apply maponpaths ; unfold enriched_prod_cone_from_iso ; cbn ; unfold enriched_prod_cone_pr ; cbn ; rewrite enriched_to_from_arr ; apply idpath). Defined. End ProdIso. (** 7. Products are isomorphic *) Definition map_between_product_enriched {a b : enriched_prod_cone} (Ha : is_prod_enriched a) (Hb : is_prod_enriched b) : a --> b := is_prod_enriched_arrow Hb (enriched_prod_cone_pr a). Lemma iso_between_product_enriched_inv {a b : enriched_prod_cone} (Ha : is_prod_enriched a) (Hb : is_prod_enriched b) : map_between_product_enriched Ha Hb · map_between_product_enriched Hb Ha = identity _. Proof. unfold map_between_product_enriched. use (is_prod_enriched_arrow_eq Ha). intro j. rewrite !assoc'. rewrite !is_prod_enriched_arrow_pr. rewrite id_left. apply idpath. Qed. Definition iso_between_product_enriched {a b : enriched_prod_cone} (Ha : is_prod_enriched a) (Hb : is_prod_enriched b) : z_iso a b. Proof. use make_z_iso. - exact (map_between_product_enriched Ha Hb). - exact (map_between_product_enriched Hb Ha). - split. + apply iso_between_product_enriched_inv. + apply iso_between_product_enriched_inv. Defined. End EnrichedProducts. (** 8. Enriched categories with products *) Definition enrichment_prod {V : monoidal_cat} {C : category} (E : enrichment C V) (J : UU) : UU := ∏ (D : J → C), ∑ (a : enriched_prod_cone E D), is_prod_enriched E D a. Proposition isaprop_enrichment_prod {V : monoidal_cat} {C : category} (HC : is_univalent C) (E : enrichment C V) (J : UU) : isaprop (enrichment_prod E J). Proof. use invproofirrelevance. intros φ₁ φ₂. use funextsec ; intro D. use subtypePath. { intro. apply isaprop_is_prod_enriched. } use total2_paths_f. - use (isotoid _ HC). use iso_between_product_enriched. + exact (pr2 (φ₁ D)). + exact (pr2 (φ₂ D)). - rewrite transportf_sec_constant. use funextsec. intro j. rewrite transportf_enriched_arr_l. rewrite idtoiso_inv. rewrite idtoiso_isotoid. cbn. refine (_ @ enriched_from_to_arr E _). apply maponpaths. unfold map_between_product_enriched ; cbn. etrans. { apply is_prod_enriched_arrow_pr. } apply idpath. Qed. Definition cat_with_enrichment_product (V : monoidal_cat) (J : UU) : UU := ∑ (C : cat_with_enrichment V), enrichment_prod C J. Coercion cat_with_enrichment_product_to_cat_with_enrichment {V : monoidal_cat} {J : UU} (C : cat_with_enrichment_product V J) : cat_with_enrichment V := pr1 C. Definition products_of_cat_with_enrichment {V : monoidal_cat} {J : UU} (C : cat_with_enrichment_product V J) : enrichment_prod C J := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/EnrichedTerminal.v000066400000000000000000000170441451125700300270330ustar00rootroot00000000000000(***************************************************************** Terminal objects in enriched categories In this file, we define the notion of a terminal objects in the context of enriched category theory. The first we formulate, is the universal property of terminal objects. This must be done in a slightly differently compared to the terminal objects of ordinary categories. Usually, the universal property of terminal objects is expressed by saying that for each object the set of morphisms between them is equivalent to the unit set. This universal property is expressed in the category of sets. For enriched categories, we express it in the monoidal category `V` over which we enriched. More specifically, we say that the hom-object is a terminal object. One interesting aspect about limits and colimits in enriched category theory is that under certain conditions, we can deduce the existence of enriched limits from the existence of ordinary limits in the underlying category. A condition that allows us to do so, is conservativity of the functor `V(1, -)`. This conservativity allows us to prove that a morphism in `V` is isomorphic by only looking at the underlying category. Examples of monoidal categories that satisfy this condition include the category of abelian groups or the category of R-modules. The reason why they are conservative, is because a morphism in those categories is an isomorphism if and only if the underlying morphism between sets is an equivalence. We also prove that terminal objects are closed under isomorphism and that any two terminal objects are isomorphic. Contents 1. Terminal objects in an enriched category 2. Being terminal is a proposition 3. Accessors for terminal objects 4. Builders for terminal objects 5. Being terminal is closed under iso 6. Terminal objects are isomorphic 7. Enriched categories with a terminal object *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.limits.terminal. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section EnrichedTerminal. Context {V : monoidal_cat} {C : category} (E : enrichment C V). (** 1. Terminal objects in an enriched category *) Definition is_terminal_enriched (x : C) : UU := ∏ (y : C), isTerminal V (E ⦃ y, x ⦄). Definition terminal_enriched : UU := ∑ (x : C), is_terminal_enriched x. Coercion terminal_enriched_to_ob (x : terminal_enriched) : C := pr1 x. Coercion terminal_enriched_to_is_terminal (x : terminal_enriched) : is_terminal_enriched x := pr2 x. (** 2. Being terminal is a proposition *) Proposition isaprop_is_terminal_enriched (x : C) : isaprop (is_terminal_enriched x). Proof. do 2 (use impred ; intro). apply isapropiscontr. Qed. (** 3. Accessors for terminal objects *) Section Accessors. Context {x : C} (Hx : is_terminal_enriched x). Definition is_terminal_enriched_arrow (y : C) : I_{V} --> E ⦃ y , x ⦄ := TerminalArrow (_ ,, Hx y) I_{V}. Definition is_terminal_enriched_eq {y : C} (f g : I_{V} --> E ⦃ y , x ⦄) : f = g. Proof. apply (@TerminalArrowEq _ (_ ,, Hx y) I_{V}). Qed. Definition terminal_underlying : Terminal C. Proof. refine (x ,, _). intros y. use iscontraprop1. - abstract (use invproofirrelevance ; intros f g ; refine (!(enriched_to_from_arr E f) @ _ @ enriched_to_from_arr E g) ; apply maponpaths ; apply is_terminal_enriched_eq). - exact (enriched_to_arr E (is_terminal_enriched_arrow y)). Defined. End Accessors. (** 4. Builders for terminal objects *) Definition make_is_terminal_enriched (x : C) (f : ∏ (w : V) (y : C), w --> E ⦃ y , x ⦄) (p : ∏ (w : V) (y : C) (f g : w --> E ⦃ y , x ⦄), f = g) : is_terminal_enriched x. Proof. intros y w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; apply p). - apply f. Defined. Definition make_is_terminal_enriched_from_iso (TV : Terminal V) (x : C) (Hx : ∏ (y : C), is_z_isomorphism (TerminalArrow TV (E ⦃ y, x ⦄))) : is_terminal_enriched x. Proof. intros y. use (iso_to_Terminal TV). exact (z_iso_inv (TerminalArrow TV (E ⦃ y, x ⦄) ,, Hx y)). Defined. Definition terminal_enriched_from_underlying (TC : Terminal C) (TV : Terminal V) (HV : conservative_moncat V) : is_terminal_enriched TC. Proof. use (make_is_terminal_enriched_from_iso TV). intro y. use HV. use isweq_iso. - intro f. apply enriched_from_arr. apply (TerminalArrow TC). - abstract (intros f ; cbn ; refine (_ @ enriched_from_to_arr E f) ; apply maponpaths ; apply TerminalArrowEq). - abstract (intros f ; cbn ; apply TerminalArrowEq). Defined. (** 5. Being terminal is closed under iso *) Definition terminal_enriched_from_iso {x y : C} (Hx : is_terminal_enriched x) (f : z_iso x y) : is_terminal_enriched y. Proof. intros w. use (iso_to_Terminal (_ ,, Hx w)) ; cbn. exact (postcomp_arr_z_iso E w f). Defined. (** 6. Terminal objects are isomorphic *) Definition iso_between_terminal_enriched {x y : C} (Hx : is_terminal_enriched x) (Hy : is_terminal_enriched y) : z_iso x y. Proof. use make_z_iso. - exact (enriched_to_arr E (is_terminal_enriched_arrow Hy x)). - exact (enriched_to_arr E (is_terminal_enriched_arrow Hx y)). - split. + abstract (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ; apply maponpaths ; apply (is_terminal_enriched_eq Hx)). + abstract (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ; apply maponpaths ; apply (is_terminal_enriched_eq Hy)). Defined. Definition isaprop_terminal_enriched (HC : is_univalent C) : isaprop terminal_enriched. Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaprop_is_terminal_enriched. } use (isotoid _ HC). use iso_between_terminal_enriched. - exact (pr2 φ₁). - exact (pr2 φ₂). Defined. End EnrichedTerminal. (** 7. Enriched categories with a terminal object *) Definition cat_with_enrichment_terminal (V : monoidal_cat) : UU := ∑ (C : cat_with_enrichment V), terminal_enriched C. Coercion cat_with_enrichment_terminal_to_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_terminal V) : cat_with_enrichment V := pr1 C. Definition terminal_of_cat_with_enrichment {V : monoidal_cat} (C : cat_with_enrichment_terminal V) : terminal_enriched C := pr2 C. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/Examples/000077500000000000000000000000001451125700300251775ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/Examples/OppositeEnrichedLimits.v000066400000000000000000000135251451125700300320220ustar00rootroot00000000000000(***************************************************************** Limits in the enriched opposite category If an enriched category has colimits, then its opposite inherits these as limits. Contents 1. Terminal object 2. Binary products 3. Equalizers 4. Type indexed products 5. Powers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section OppositeLimits. Context {V : sym_monoidal_cat} {C : category} (E : enrichment C V). Let E' : enrichment (C^opp) V := op_enrichment V E. (** 1. Terminal object *) Definition opposite_terminal_enriched (I : initial_enriched E) : terminal_enriched E'. Proof. exact I. Defined. (** 2. Binary products *) Section OppositeBinaryProducts. Context {x y : C} (s : binary_coprod_enriched E x y). Definition opposite_binary_prod_enriched_is_prod : is_binary_prod_enriched E' x y (pr1 s). Proof. intro w. use (isBinProduct_eq_arrow _ _ (pr2 s w)). - abstract (unfold E' ; rewrite op_enrichment_postcomp ; apply maponpaths ; cbn ; apply idpath). - abstract (unfold E' ; rewrite op_enrichment_postcomp ; apply maponpaths ; cbn ; apply idpath). Defined. Definition opposite_binary_prod_enriched : binary_prod_enriched E' x y. Proof. simple refine (_ ,, _). - exact (pr1 s). - exact opposite_binary_prod_enriched_is_prod. Defined. End OppositeBinaryProducts. Definition opposite_enrichment_binary_prod (H : enrichment_binary_coprod E) : enrichment_binary_prod E' := λ x y, opposite_binary_prod_enriched (H x y). (** 3. Equalizers *) Section OppositeEqualizers. Context {x y : C} {f g : x --> y} (e : coequalizer_enriched E f g). Definition opposite_is_equalizer_enriched : is_equalizer_enriched E' f g (pr1 e). Proof. intro w. use (isEqualizer_eq _ _ _ _ _ (pr2 e w)). - abstract (refine (!_) ; apply op_enrichment_postcomp). - abstract (refine (!_) ; apply op_enrichment_postcomp). - abstract (refine (!_) ; apply op_enrichment_postcomp). Defined. Definition opposite_equalizer_enriched : equalizer_enriched E' f g := pr1 e ,, opposite_is_equalizer_enriched. End OppositeEqualizers. (** 4. Type indexed products *) Section OppositeProducts. Context {J : UU} (ys : J → C) (s : coprod_enriched E ys). Definition opposite_prod_enriched_is_prod : is_prod_enriched E' ys (pr1 s). Proof. intro w. use (isProduct_eq_arrow _ (pr2 s w)). abstract (intro j ; unfold E' ; rewrite op_enrichment_postcomp ; apply maponpaths ; cbn ; apply idpath). Defined. Definition opposite_prod_enriched : prod_enriched E' ys. Proof. simple refine (_ ,, _). - exact (pr1 s). - exact opposite_prod_enriched_is_prod. Defined. End OppositeProducts. End OppositeLimits. (** 5. Powers *) Definition opposite_power_enriched {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) {v : V} {x : C} (e : copower_cocone E v x) (He : is_copower_enriched E v x e) : is_power_enriched (op_enrichment V E) v x e. Proof. intros w. use (is_z_isomorphism_path _ (He w)). abstract (unfold is_copower_enriched_map, is_power_enriched_map ; use internal_funext ; intros a h ; rewrite tensor_split ; rewrite !assoc' ; rewrite internal_beta ; refine (!_) ; rewrite tensor_split ; rewrite !assoc' ; rewrite internal_beta ; do 2 apply maponpaths ; cbn -[sym_mon_braiding] ; rewrite !assoc ; rewrite sym_mon_braiding_inv ; apply id_left). Defined. Definition opposite_enrichment_power {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (HE : enrichment_copower E) : enrichment_power (op_enrichment V E) := λ v x, pr1 (HE v x) ,, opposite_power_enriched _ _ (pr2 (HE v x)). UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/Examples/PosetEnrichedLimits.v000066400000000000000000001002341451125700300313040ustar00rootroot00000000000000(***************************************************************** Limits in categories enriched over posets If we have a category enriched over posets, then we can characterize terminal objects, products, and equalizers using elementary terms. Such a category has a terminal object if and only if the underlying category has a terminal object. For products and equalizers, we also demand that the arrow coming from the universal property is monotone. To construct powers in a category `C` enriched over posets, we assume that we have a poset `P` and an object `x` of `C`. To construct the power, we take a product of `x` indexed by the underlying set of `P`. As such, `C` must have 'large enough' products, because otherwise, this product cannot be constructed. Note that for powers, we do not construct an equivalence between the elementary version and the enriched version. The reason for that, is that for the elementary version, we assume that `C` has products of all diagrams indexed by the underlying set of a poset `P`. However, for powers, we only need such products for constant diagrams. As such, our elementary version is actually stronger. Contents 1. Terminal object 2. Binary products 3. Equalizers 4. Powers 5. Type indexed products *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.CategoryOfPosets. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.PosetEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.PosetsMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section PosetEnrichmentLimits. Context {C : category} (E : poset_enrichment C). Let E' : enrichment C poset_sym_mon_closed_cat := make_enrichment_over_poset C E. (** 1. Terminal object *) Section PosetEnrichedTerminal. Context {x : C} (Hx : isTerminal C x). Let T : Terminal C := make_Terminal x Hx. Definition poset_enrichment_is_terminal : is_terminal_enriched E' x. Proof. use make_is_terminal_enriched. - intros P y. simple refine (_ ,, _). + exact (λ _, TerminalArrow T y). + abstract (intros x₁ x₂ p ; apply refl_PartialOrder). - abstract (intros P y f g ; use eq_monotone_function ; intros z ; apply (@TerminalArrowEq _ T)). Defined. End PosetEnrichedTerminal. Definition make_poset_enrichment_terminal (HC : Terminal C) : terminal_enriched E' := pr1 HC ,, poset_enrichment_is_terminal (pr2 HC). Definition poset_terminal_enriched_weq_Terminal (HC : is_univalent C) : terminal_enriched E' ≃ Terminal C. Proof. use weqimplimpl. - exact (λ T, terminal_underlying E' T). - exact make_poset_enrichment_terminal. - apply (isaprop_terminal_enriched _ HC). - apply (isaprop_Terminal _ HC). Defined. (** 2. Binary products *) Definition poset_enrichment_binary_prod : UU := ∑ (BC : BinProducts C), ∏ (x y₁ y₂ : C) (f f' : x --> y₁) (qf : E _ _ f f') (g g' : x --> y₂) (qg : E _ _ g g'), E _ _ (BinProductArrow _ (BC y₁ y₂) f g) (BinProductArrow _ (BC y₁ y₂) f' g'). Proposition isaprop_poset_enrichment_binary_prod (HC : is_univalent C) : isaprop poset_enrichment_binary_prod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - do 2 (use impred ; intro). apply (isaprop_BinProduct HC). - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedProdAccessors. Context (EBC : poset_enrichment_binary_prod). Definition poset_enrichment_obj_binary_prod (x y : C) : C := pr1 EBC x y. Definition poset_enrichment_obj_pr1 (x y : C) : poset_enrichment_obj_binary_prod x y --> x := BinProductPr1 _ (pr1 EBC x y). Definition poset_enrichment_obj_pr2 (x y : C) : poset_enrichment_obj_binary_prod x y --> y := BinProductPr2 _ (pr1 EBC x y). Definition poset_enrichment_obj_pair {z x y : C} (f : z --> x) (g : z --> y) : z --> poset_enrichment_obj_binary_prod x y := BinProductArrow _ (pr1 EBC x y) f g. Proposition poset_enrichment_obj_pair_pr1 {z x y : C} (f : z --> x) (g : z --> y) : poset_enrichment_obj_pair f g · poset_enrichment_obj_pr1 x y = f. Proof. apply BinProductPr1Commutes. Qed. Proposition poset_enrichment_obj_pair_pr2 {z x y : C} (f : z --> x) (g : z --> y) : poset_enrichment_obj_pair f g · poset_enrichment_obj_pr2 x y = g. Proof. apply BinProductPr2Commutes. Qed. Proposition poset_enrichment_binary_prod_arr_eq {w x y : C} {f g : w --> poset_enrichment_obj_binary_prod x y} (p : f · poset_enrichment_obj_pr1 x y = g · poset_enrichment_obj_pr1 x y) (q : f · poset_enrichment_obj_pr2 x y = g · poset_enrichment_obj_pr2 x y) : f = g. Proof. use (BinProductArrowsEq _ _ _ (pr1 EBC x y)). - exact p. - exact q. Qed. Definition poset_enrichment_binary_prod_pair (x y z : C) : E' ⦃ z, x ⦄ ⊗ (E' ⦃ z , y ⦄) --> E' ⦃ z , poset_enrichment_obj_binary_prod x y ⦄. Proof. simple refine (_ ,, _). - exact (λ fg, poset_enrichment_obj_pair (pr1 fg) (pr2 fg)). - intros fg₁ fg₂ p. apply (pr2 EBC). + exact (pr1 p). + exact (pr2 p). Defined. End PosetEnrichedProdAccessors. Section PosetProd. Context (EBC : poset_enrichment_binary_prod) (x y : C). Definition make_poset_enriched_binary_prod_cone : enriched_binary_prod_cone E' x y. Proof. use make_enriched_binary_prod_cone. - exact (poset_enrichment_obj_binary_prod EBC x y). - exact (enriched_from_arr E' (poset_enrichment_obj_pr1 EBC x y)). - exact (enriched_from_arr E' (poset_enrichment_obj_pr2 EBC x y)). Defined. Definition poset_enrichment_binary_prod_is_prod : is_binary_prod_enriched E' x y make_poset_enriched_binary_prod_cone. Proof. use make_is_binary_prod_enriched. - intros z P f g. refine (_ · poset_enrichment_binary_prod_pair _ _ _ _). simple refine (_ ,, _). + exact (prodtofuntoprod (pr1 f ,, pr1 g)). + apply prodtofun_is_monotone. * exact (pr2 f). * exact (pr2 g). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_pair_pr1). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_pair_pr2). - abstract (intros z P φ₁ φ₂ q₁ q₂ ; use eq_monotone_function ; intro w ; use poset_enrichment_binary_prod_arr_eq ; [ exact (eqtohomot (maponpaths (λ f, pr1 f) q₁) w) | exact (eqtohomot (maponpaths (λ f, pr1 f) q₂) w) ]). Defined. End PosetProd. Definition make_poset_enrichment_binary_prod (EBC : poset_enrichment_binary_prod) : enrichment_binary_prod E' := λ x y, make_poset_enriched_binary_prod_cone EBC x y ,, poset_enrichment_binary_prod_is_prod EBC x y. Section ToPosetProduct. Context (EP : enrichment_binary_prod E') {x y₁ y₂ : C}. Let prod : poset_sym_mon_closed_cat := (E' ⦃ x , y₁ ⦄) ⊗ (E' ⦃ x , y₂ ⦄). Let prod_pr1 : prod --> E' ⦃ x, y₁ ⦄ := _ ,, dirprod_pr1_is_monotone _ _. Let prod_pr2 : prod --> E' ⦃ x, y₂ ⦄ := _ ,, dirprod_pr2_is_monotone _ _. Definition poset_to_underlying_binary_prod_map (f : x --> y₁) (g : x --> y₂) : x --> underlying_BinProduct E' y₁ y₂ (pr2 (EP y₁ y₂)) := pr1 (BinProductArrow category_of_posets (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y₁ y₂)) x) prod_pr1 prod_pr2) (f ,, g). Proposition poset_to_underlying_binary_prod_map_pr1 (f : x --> y₁) (g : x --> y₂) : poset_to_underlying_binary_prod_map f g · enriched_prod_cone_pr1 E' y₁ y₂ (pr1 (EP y₁ y₂)) = f. Proof. exact (eqtohomot (maponpaths pr1 (BinProductPr1Commutes category_of_posets _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y₁ y₂)) x) _ prod_pr1 prod_pr2)) (f ,, g)). Qed. Proposition poset_to_underlying_binary_prod_map_pr2 (f : x --> y₁) (g : x --> y₂) : poset_to_underlying_binary_prod_map f g · enriched_prod_cone_pr2 E' y₁ y₂ (pr1 (EP y₁ y₂)) = g. Proof. exact (eqtohomot (maponpaths pr1 (BinProductPr2Commutes category_of_posets _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y₁ y₂)) x) _ prod_pr1 prod_pr2)) (f ,, g)). Qed. Proposition poset_to_underlying_binary_prod_map_monotone {φ₁ φ₂ : x --> y₁} {ψ₁ ψ₂ : x --> y₂} (p : E x y₁ φ₁ φ₂) (q : E x y₂ ψ₁ ψ₂) : E _ _ (poset_to_underlying_binary_prod_map φ₁ ψ₁) (poset_to_underlying_binary_prod_map φ₂ ψ₂). Proof. exact (pr2 (@BinProductArrow _ _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y₁ y₂)) x) prod prod_pr1 prod_pr2) (φ₁ ,, ψ₁) (φ₂ ,, ψ₂) (p ,, q)). Qed. Proposition poset_to_underlying_binary_prod_map_eq (f : x --> y₁) (g : x --> y₂) : BinProductArrow C (underlying_BinProduct E' y₁ y₂ (pr2 (EP y₁ y₂))) f g = poset_to_underlying_binary_prod_map f g. Proof. use is_binary_prod_enriched_arrow_eq. - exact (pr2 (EP y₁ y₂)). - refine (_ @ !(poset_to_underlying_binary_prod_map_pr1 f g)). apply (BinProductPr1Commutes C _ _ (underlying_BinProduct E' y₁ y₂ (pr2 (EP y₁ y₂))) _ f g). - refine (_ @ !(poset_to_underlying_binary_prod_map_pr2 f g)). apply (BinProductPr2Commutes C _ _ (underlying_BinProduct E' y₁ y₂ (pr2 (EP y₁ y₂))) _ f g). Qed. End ToPosetProduct. Definition to_poset_enrichment_binary_prod (EP : enrichment_binary_prod E') : poset_enrichment_binary_prod. Proof. simple refine (_ ,, _). - exact (λ x y, underlying_BinProduct E' x y (pr2 (EP x y))). - abstract (intros x y₁ y₂ f f' p g g' q ; rewrite !poset_to_underlying_binary_prod_map_eq ; apply (poset_to_underlying_binary_prod_map_monotone EP p q)). Defined. Definition poset_enrichment_binary_prod_weq (HC : is_univalent C) : enrichment_binary_prod E' ≃ poset_enrichment_binary_prod. Proof. use weqimplimpl. - apply to_poset_enrichment_binary_prod. - apply make_poset_enrichment_binary_prod. - apply (isaprop_enrichment_binary_prod HC). - apply (isaprop_poset_enrichment_binary_prod HC). Defined. (** 3. Equalizers *) Definition poset_enrichment_equalizers : UU := ∑ (EC : Equalizers C), ∏ (w x y : C) (f g : x --> y) (h₁ h₂ : w --> x) (p₁ : h₁ · f = h₁ · g) (p₂ : h₂ · f = h₂ · g) (qh : E _ _ h₁ h₂), E _ _ (EqualizerIn (EC x y f g) w h₁ p₁) (EqualizerIn (EC x y f g) w h₂ p₂). Proposition isaprop_poset_enrichment_equalizers (HC : is_univalent C) : isaprop poset_enrichment_equalizers. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Equalizer. exact HC. - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedEqualizerAccessors. Context (EEC : poset_enrichment_equalizers). Definition poset_enrichment_obj_equalizer {x y : C} (f g : x --> y) : C := pr1 EEC x y f g. Definition poset_enrichment_obj_equalizer_pr {x y : C} (f g : x --> y) : poset_enrichment_obj_equalizer f g --> x := EqualizerArrow (pr1 EEC x y f g). Proposition poset_enrichment_obj_pr_eq {x y : C} (f g : x --> y) : poset_enrichment_obj_equalizer_pr f g · f = poset_enrichment_obj_equalizer_pr f g · g. Proof. apply EqualizerEqAr. Qed. Definition poset_enrichment_obj_to_equalizer {w x y : C} {f g : x --> y} (h : w --> x) (q : h · f = h · g) : w --> poset_enrichment_obj_equalizer f g := EqualizerIn (pr1 EEC x y f g) w h q. Proposition poset_enrichment_obj_to_equalizer_pr {w x y : C} {f g : x --> y} (h : w --> x) (q : h · f = h · g) : poset_enrichment_obj_to_equalizer h q · poset_enrichment_obj_equalizer_pr f g = h. Proof. apply EqualizerCommutes. Qed. Proposition poset_enrichment_equalizer_arr_eq {w x y : C} {f g : x --> y} {h₁ h₂ : w --> poset_enrichment_obj_equalizer f g} (q : h₁ · poset_enrichment_obj_equalizer_pr f g = h₂ · poset_enrichment_obj_equalizer_pr f g) : h₁ = h₂. Proof. use EqualizerInsEq. exact q. Qed. Definition poset_enrichment_to_equalizer {w x y : C} (f g : x --> y) : Equalizers_category_of_posets _ _ (postcomp_arr E' w f) (postcomp_arr E' w g) --> E' ⦃ w , poset_enrichment_obj_equalizer f g ⦄. Proof. simple refine (_ ,, _). - exact (λ hp, poset_enrichment_obj_to_equalizer (pr1 hp) (pr2 hp)). - intros h₁ h₂ q. apply EEC. exact q. Defined. End PosetEnrichedEqualizerAccessors. Section PosetEqualizer. Context (EEC : poset_enrichment_equalizers) {x y : C} (f g : x --> y). Definition make_poset_enrichment_equalizer_cone : enriched_equalizer_cone E' f g. Proof. use make_enriched_equalizer_cone. - exact (poset_enrichment_obj_equalizer EEC f g). - exact (enriched_from_arr E' (poset_enrichment_obj_equalizer_pr EEC f g)). - exact (poset_enrichment_obj_pr_eq EEC f g). Defined. Definition make_poset_enrichment_equalizer_is_equalizer : is_equalizer_enriched E' f g make_poset_enrichment_equalizer_cone. Proof. use make_is_equalizer_enriched. - abstract (intros w P φ₁ φ₂ q ; use eq_monotone_function ; intro z ; use poset_enrichment_equalizer_arr_eq ; exact (eqtohomot (maponpaths pr1 q) z)). - intros w P h q. refine (_ · poset_enrichment_to_equalizer EEC f g). simple refine (_ ,, _). + refine (λ z, pr1 h z ,, _). exact (eqtohomot (maponpaths pr1 q) z). + abstract (apply Equalizer_map_monotone ; apply (pr2 h)). - abstract (intros w P h q ; use eq_monotone_function ; intros z ; apply poset_enrichment_obj_to_equalizer_pr). Defined. End PosetEqualizer. Definition make_poset_enrichment_equalizers (EEC : poset_enrichment_equalizers) : enrichment_equalizers E'. Proof. intros x y f g. simple refine (_ ,, _). - exact (make_poset_enrichment_equalizer_cone EEC f g). - exact (make_poset_enrichment_equalizer_is_equalizer EEC f g). Defined. Section ToPosetEqualizer. Context (EEC : enrichment_equalizers E') {w x y : C} (f g : x --> y). Let Eq : Equalizer _ _ := Equalizers_category_of_posets _ _ (postcomp_arr E' w f) (postcomp_arr E' w g). Let Eq_pr : Eq --> E' ⦃ w , x ⦄ := EqualizerArrow _. Let Eq_path : Eq_pr · postcomp_arr E' w f = Eq_pr · postcomp_arr E' w g := EqualizerEqAr _. Definition poset_to_underlying_equalizer_map (h : w --> x) (q : h · f = h · g) : w --> underlying_Equalizer E' f g (pr2 (EEC x y f g)) := pr1 (EqualizerIn (is_equalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path) (h ,, q). Proposition poset_to_underlying_equalizer_map_pr (h : w --> x) (q : h · f = h · g) : poset_to_underlying_equalizer_map h q · enriched_equalizer_cone_pr E' f g (pr1 (EEC x y f g)) = h. Proof. exact (eqtohomot (maponpaths pr1 (EqualizerCommutes (is_equalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path)) (h ,, q)). Qed. Proposition poset_to_underlying_equalizer_map_monotone (h₁ h₂ : w --> x) (q₁ : h₁ · f = h₁ · g) (q₂ : h₂ · f = h₂ · g) (ph : E w x h₁ h₂) : E _ _ (poset_to_underlying_equalizer_map h₁ q₁) (poset_to_underlying_equalizer_map h₂ q₂). Proof. apply (pr2 (EqualizerIn (is_equalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path) (h₁ ,, q₁) (h₂ ,, q₂) ph). Qed. Proposition poset_to_underlying_equalizer_map_eq (h : w --> x) (q : h · f = h · g) : EqualizerIn (underlying_Equalizer E' f g (pr2 (EEC x y f g))) w h q = poset_to_underlying_equalizer_map h q. Proof. use underlying_Equalizer_arr_eq. { exact (pr2 (EEC x y f g)). } etrans. { apply (EqualizerCommutes (underlying_Equalizer E' f g (pr2 (EEC x y f g)))). } refine (!_). apply poset_to_underlying_equalizer_map_pr. Qed. End ToPosetEqualizer. Definition to_poset_enrichment_equalizer (EEC : enrichment_equalizers E') : poset_enrichment_equalizers. Proof. simple refine (_ ,, _). - exact (λ x y f g, underlying_Equalizer E' f g (pr2 (EEC x y f g))). - abstract (intros w x y f g h₁ h₂ p₁ p₂ qh ; rewrite !poset_to_underlying_equalizer_map_eq ; apply poset_to_underlying_equalizer_map_monotone ; exact qh). Defined. Definition poset_enrichment_equalizer_weq (HC : is_univalent C) : enrichment_equalizers E' ≃ poset_enrichment_equalizers. Proof. use weqimplimpl. - apply to_poset_enrichment_equalizer. - apply make_poset_enrichment_equalizers. - apply (isaprop_enrichment_equalizers HC). - apply (isaprop_poset_enrichment_equalizers HC). Defined. (** 4. Powers *) Definition poset_enrichment_pows : UU := ∑ (prods : ∏ (P : poset_sym_mon_closed_cat), Products (pr11 P) C), ∏ (P : poset_sym_mon_closed_cat) (x : C), is_monotone (pr2 P) (E (prods P (λ _, x)) x) (ProductPr _ _ (prods P (λ _, x))) × (∏ (y : C), is_monotone (monotone_function_PartialOrder (pr2 P) (E y x)) (E y (prods P (λ _, x))) (λ f, ProductArrow _ _ (prods P (λ _, x)) (pr1 f))). Section PosetEnrichmentPowersAccessors. Context (HE : poset_enrichment_pows). Definition poset_pows_prod (P : poset_sym_mon_closed_cat) (x : C) : Product (pr11 P) C (λ _, x) := pr1 HE P (λ _, x). Definition poset_pows_pr {P : poset_sym_mon_closed_cat} {x : C} (i : pr11 P) : poset_pows_prod P x --> x := ProductPr _ _ (poset_pows_prod P x) i. Proposition poset_pows_monotone_pr (P : poset_sym_mon_closed_cat) (x : C) : is_monotone (pr2 P) (E (poset_pows_prod P x) x) poset_pows_pr. Proof. exact (pr1 (pr2 HE P x)). Qed. Proposition poset_pows_monotone_product_arr (P : poset_sym_mon_closed_cat) (x y : C) : is_monotone (monotone_function_PartialOrder (pr2 P) (E y x)) (E y (poset_pows_prod P x)) (λ f, ProductArrow _ _ (poset_pows_prod P x) (pr1 f)). Proof. exact (pr2 (pr2 HE P x) y). Qed. End PosetEnrichmentPowersAccessors. Section PosetEnrichmentPowers. Context (HE : poset_enrichment_pows) (P : poset_sym_mon_closed_cat) (x : C). Let pow : Product _ C (λ _, x) := poset_pows_prod HE P x. Let pow_pr : ∏ (_ : pr11 P), pow --> x := λ i, poset_pows_pr HE i. Definition poset_power_cone : power_cone E' P x. Proof. simple refine (_ ,, _). - exact pow. - simple refine (_ ,, _). + exact pow_pr. + exact (poset_pows_monotone_pr HE P x). Defined. Definition poset_power_map (y : C) : P ⊸ (E' ⦃ y, x ⦄) --> E' ⦃ y, poset_power_cone ⦄. Proof. simple refine (_ ,, _). - intro f. exact (ProductArrow _ _ pow (pr1 f)). - exact (poset_pows_monotone_product_arr HE P x y). Defined. Definition poset_power_is_power : is_power_enriched E' P x poset_power_cone. Proof. use make_is_power_enriched. - exact poset_power_map. - abstract (intro y ; use eq_monotone_function ; intro f ; cbn in f ; use ProductArrow_eq ; intro i ; apply (ProductPrCommutes _ _ _ pow)). - abstract (intro y ; use eq_monotone_function ; intro f ; use eq_monotone_function ; intro i ; cbn ; apply (ProductPrCommutes _ _ _ pow)). Defined. End PosetEnrichmentPowers. Definition poset_enrichment_powers_from_products (HE : poset_enrichment_pows) : enrichment_power E'. Proof. intros P x. simple refine (_ ,, _). - exact (poset_power_cone HE P x). - apply poset_power_is_power. Defined. (** 5. Type indexed products *) Section TypeIndexedProducts. Context (J : UU). Definition poset_enrichment_prod : UU := ∑ (PC : Products J C), ∏ (x : C) (ys : J → C) (fs₁ : ∏ (j : J), x --> ys j) (fs₂ : ∏ (j : J), x --> ys j) (q : ∏ (j : J), E _ _ (fs₁ j) (fs₂ j)), E _ _ (ProductArrow _ _ (PC ys) fs₁) (ProductArrow _ _ (PC ys) fs₂). Proposition isaprop_poset_enrichment_prod (HC : is_univalent C) : isaprop poset_enrichment_prod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Product. exact HC. - repeat (use impred ; intro). apply propproperty. Qed. Section PosetEnrichedProdAccessors. Context (EC : poset_enrichment_prod). Definition poset_enrichment_obj_prod (ys : J → C) : C := pr1 EC ys. Definition poset_enrichment_obj_prod_pr (ys : J → C) (j : J) : poset_enrichment_obj_prod ys --> ys j := ProductPr _ _ (pr1 EC ys) j. Definition poset_enrichment_obj_prod_pair {x : C} {ys : J → C} (fs : ∏ (j : J), x --> ys j) : x --> poset_enrichment_obj_prod ys := ProductArrow _ _ (pr1 EC ys) fs. Proposition poset_enrichment_obj_prod_pair_pr {x : C} {ys : J → C} (fs : ∏ (j : J), x --> ys j) (j : J) : poset_enrichment_obj_prod_pair fs · poset_enrichment_obj_prod_pr ys j = fs j. Proof. apply ProductPrCommutes. Qed. Proposition poset_enrichment_prod_arr_eq {x : C} {ys : J → C} {f g : x --> poset_enrichment_obj_prod ys} (p : ∏ (j : J), f · poset_enrichment_obj_prod_pr ys j = g · poset_enrichment_obj_prod_pr ys j) : f = g. Proof. use (ProductArrow_eq _ _ _ (pr1 EC ys)). exact p. Qed. Definition poset_enrichment_prod_pair (x : C) (ys : J → C) : Products_category_of_posets J (λ j, E' ⦃ x , ys j ⦄) --> E' ⦃ x , poset_enrichment_obj_prod ys ⦄. Proof. simple refine (_ ,, _). - exact (λ fs, poset_enrichment_obj_prod_pair (λ j, fs j)). - intros fs₁ fs₂ p. apply (pr2 EC). exact p. Defined. End PosetEnrichedProdAccessors. Section PosetProd. Context (EBC : poset_enrichment_prod) (ys : J → C). Definition make_poset_enriched_prod_cone : enriched_prod_cone E' ys. Proof. use make_enriched_prod_cone. - exact (poset_enrichment_obj_prod EBC ys). - exact (λ j, enriched_from_arr E' (poset_enrichment_obj_prod_pr EBC ys j)). Defined. Definition poset_enrichment_prod_is_prod : is_prod_enriched E' ys make_poset_enriched_prod_cone. Proof. use make_is_prod_enriched. - intros z P fs. refine (_ · poset_enrichment_prod_pair _ _ _). simple refine (_ ,, _). + exact (λ x j, pr1 (fs j) x). + abstract (use is_monotone_depfunction_poset_pair ; intro j ; exact (pr2 (fs j))). - abstract (intros z P f g ; use eq_monotone_function ; intros w ; cbn ; apply poset_enrichment_obj_prod_pair_pr). - abstract (intros z P φ₁ φ₂ q ; use eq_monotone_function ; intro w ; use poset_enrichment_prod_arr_eq ; intro j ; exact (eqtohomot (maponpaths (λ f, pr1 f) (q j)) w)). Defined. End PosetProd. Definition make_poset_enrichment_prod (EBC : poset_enrichment_prod) : enrichment_prod E' J := λ ys, make_poset_enriched_prod_cone EBC ys ,, poset_enrichment_prod_is_prod EBC ys. Section ToPosetProduct. Context (EP : enrichment_prod E' J) {x : C} (ys : J → C). Let prod : poset_sym_mon_closed_cat := Products_category_of_posets J (λ j, E' ⦃ x , ys j ⦄). Let prod_pr : ∏ (j : J), prod --> E' ⦃ x , ys j ⦄ := λ j, _ ,, is_monotone_depfunction_poset_pr _ _ _. Definition poset_to_underlying_prod_map (fs : ∏ (j : J), x --> ys j) : x --> underlying_Product E' ys (pr2 (EP ys)) := pr1 (ProductArrow J category_of_posets (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod_pr) fs. Proposition poset_to_underlying_prod_map_pr (fs : ∏ (j : J), x --> ys j) (j : J) : poset_to_underlying_prod_map fs · enriched_prod_cone_pr E' ys (pr1 (EP ys)) j = fs j. Proof. exact (eqtohomot (maponpaths pr1 (ProductPrCommutes J category_of_posets _ (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) _ prod_pr j)) fs). Qed. Proposition poset_to_underlying_prod_map_monotone {φ ψ : ∏ (j : J), x --> ys j} (p : ∏ (j : J), E x (ys j) (φ j) (ψ j)) : E _ _ (poset_to_underlying_prod_map φ) (poset_to_underlying_prod_map ψ). Proof. exact (pr2 (@ProductArrow _ _ _ (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod prod_pr) φ ψ p). Qed. Proposition poset_to_underlying_prod_map_eq (fs : ∏ (j : J), x --> ys j) : ProductArrow _ C (underlying_Product E' ys (pr2 (EP ys))) fs = poset_to_underlying_prod_map fs. Proof. use is_prod_enriched_arrow_eq. - exact (pr2 (EP ys)). - intro j. refine (_ @ !(poset_to_underlying_prod_map_pr fs j)). apply (ProductPrCommutes _ C _ (underlying_Product E' ys (pr2 (EP ys))) _ fs). Qed. End ToPosetProduct. Definition to_poset_enrichment_prod (EP : enrichment_prod E' J) : poset_enrichment_prod. Proof. simple refine (_ ,, _). - exact (λ ys, underlying_Product E' ys (pr2 (EP ys))). - abstract (intros x ys fs₁ fs₂ p ; rewrite !poset_to_underlying_prod_map_eq ; apply (poset_to_underlying_prod_map_monotone EP _ p)). Defined. Definition poset_enrichment_prod_weq (HC : is_univalent C) : enrichment_prod E' J ≃ poset_enrichment_prod. Proof. use weqimplimpl. - apply to_poset_enrichment_prod. - apply make_poset_enrichment_prod. - apply (isaprop_enrichment_prod HC). - apply (isaprop_poset_enrichment_prod HC). Defined. End TypeIndexedProducts. End PosetEnrichmentLimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/Examples/SelfEnrichedLimits.v000066400000000000000000000623711451125700300311140ustar00rootroot00000000000000(***************************************************************** Limits in self enriched categories Self enriched categories inherit their limits from the underlying category. In addition, self enriched categories always have powers, and these are given by the internal hom. Contents 1. Terminal object 2. Binary products 3. Equalizers 4. Powers 5. Type indexed products *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Opaque sym_mon_braiding. Section SelfEnrichmentLimits. Context (V : sym_mon_closed_cat). (** 1. Terminal object *) Section SelfEnrichmentTerminal. Context (v : V) (Hv : isTerminal V v). Definition self_enrichment_is_terminal_enriched : is_terminal_enriched (self_enrichment V) v. Proof. use make_is_terminal_enriched. - exact (λ _ _, internal_lam (TerminalArrow (_ ,, Hv) _)). - abstract (cbn ; intros w y f g ; use internal_funext ; intros a h ; apply (@TerminalArrowEq _ (v ,, Hv))). Defined. End SelfEnrichmentTerminal. Definition self_enrichment_terminal (HV : Terminal V) : terminal_enriched (self_enrichment V) := pr1 HV ,, self_enrichment_is_terminal_enriched _ (pr2 HV). (** 2. Binary products *) Section SelfEnrichmentProduct. Context {v₁ v₂ w : V} (π₁ : w --> v₁) (π₂ : w --> v₂) (H : isBinProduct _ _ _ _ π₁ π₂). Let prod : BinProduct V v₁ v₂ := make_BinProduct _ _ _ _ _ _ H. Definition self_enrichment_binary_product_pr1 : I_{V} --> w ⊸ v₁ := internal_lam (mon_lunitor _ · π₁). Definition self_enrichment_binary_product_pr2 : I_{V} --> w ⊸ v₂ := internal_lam (mon_lunitor _ · π₂). Definition self_enrichment_binary_products_cone : enriched_binary_prod_cone (self_enrichment V) v₁ v₂. Proof. use make_enriched_binary_prod_cone. - exact w. - exact self_enrichment_binary_product_pr1. - exact self_enrichment_binary_product_pr2. Defined. Definition self_enrichment_pair {a b : V} (f : a --> b ⊸ v₁) (g : a --> b ⊸ v₂) : a --> b ⊸ w := internal_lam (BinProductArrow V prod (f #⊗ identity _ · internal_eval _ _) (g #⊗ identity _ · internal_eval _ _)). Proposition self_enrichment_pair_pr1 {a b : V} (f : a --> b ⊸ v₁) (g : a --> b ⊸ v₂) : self_enrichment_pair f g · postcomp_arr (self_enrichment V) _ (internal_to_arr self_enrichment_binary_product_pr1) = f. Proof. rewrite self_enrichment_postcomp. use internal_funext. intros c h ; cbn. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. etrans. { rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. unfold self_enrichment_pair. rewrite internal_beta. unfold internal_to_arr. unfold self_enrichment_binary_product_pr1. rewrite !assoc'. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_linvunitor_lunitor. apply id_left. } apply (BinProductPr1Commutes _ _ _ prod). } rewrite !assoc. rewrite <- tensor_split. apply idpath. Qed. Proposition self_enrichment_pair_pr2 {a b : V} (f : a --> b ⊸ v₁) (g : a --> b ⊸ v₂) : self_enrichment_pair f g · postcomp_arr (self_enrichment V) _ (internal_to_arr self_enrichment_binary_product_pr2) = g. Proof. rewrite self_enrichment_postcomp. use internal_funext. intros c h ; cbn. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. etrans. { rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. unfold self_enrichment_pair. rewrite internal_beta. unfold internal_to_arr. unfold self_enrichment_binary_product_pr2. rewrite !assoc'. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_linvunitor_lunitor. apply id_left. } apply (BinProductPr2Commutes _ _ _ prod). } rewrite !assoc. rewrite <- tensor_split. apply idpath. Qed. Definition pair_fun_pr1 {a b : V} (φ : a --> b ⊸ w) : a --> b ⊸ v₁ := φ · postcomp_arr (self_enrichment V) _ (internal_to_arr self_enrichment_binary_product_pr1). Definition pair_fun_pr2 {a b : V} (φ : a --> b ⊸ w) : a --> b ⊸ v₂ := φ · postcomp_arr (self_enrichment V) _ (internal_to_arr self_enrichment_binary_product_pr2). Proposition pair_eq_pr1 {a b c : V} (φ : a --> b ⊸ w) (h : c --> b) : φ #⊗ h · internal_eval b w · BinProductPr1 V prod = pair_fun_pr1 φ #⊗ h · internal_eval _ _. Proof. unfold pair_fun_pr1 ; cbn. rewrite self_enrichment_postcomp. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite internal_beta. apply maponpaths. unfold internal_to_arr. unfold self_enrichment_binary_product_pr1. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Proposition pair_eq_pr2 {a b c : V} (φ : a --> b ⊸ w) (h : c --> b) : φ #⊗ h · internal_eval b w · BinProductPr2 V prod = pair_fun_pr2 φ #⊗ h · internal_eval _ _. Proof. unfold pair_fun_pr2 ; cbn. rewrite self_enrichment_postcomp. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite internal_beta. apply maponpaths. unfold internal_to_arr. unfold self_enrichment_binary_product_pr2. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite mon_linvunitor_lunitor. rewrite id_left. apply idpath. Qed. Proposition self_enrichment_pair_eq {a b : V} (φ ψ : a --> b ⊸ w) (p₁ : pair_fun_pr1 φ = pair_fun_pr1 ψ) (p₂ : pair_fun_pr2 φ = pair_fun_pr2 ψ) : φ = ψ. Proof. use internal_funext. intros c h. use (BinProductArrowsEq _ _ _ prod). - rewrite !pair_eq_pr1. rewrite p₁. apply idpath. - rewrite !pair_eq_pr2. rewrite p₂. apply idpath. Qed. End SelfEnrichmentProduct. Definition self_enrichment_binary_products (PV : BinProducts V) : enrichment_binary_prod (self_enrichment V). Proof. intros v₁ v₂. pose (w := PV v₁ v₂ : V). pose (π₁ := BinProductPr1 _ (PV v₁ v₂) : w --> v₁). pose (π₂ := BinProductPr2 _ (PV v₁ v₂) : w --> v₂). pose (H := pr2 (PV v₁ v₂) : isBinProduct V v₁ v₂ w π₁ π₂). simple refine (_ ,, _). - exact (self_enrichment_binary_products_cone π₁ π₂). - use make_is_binary_prod_enriched. + exact (λ _ _ f g, self_enrichment_pair π₁ π₂ H f g). + exact (λ _ _ f g, self_enrichment_pair_pr1 π₁ π₂ H f g). + exact (λ _ _ f g, self_enrichment_pair_pr2 π₁ π₂ H f g). + exact (λ _ _ f g, self_enrichment_pair_eq π₁ π₂ H f g). Defined. (** 3. Equalizers *) Section SelfEnrichmentEqualizer. Context {v₁ v₂ e : V} {f g : v₁ --> v₂} (p : e --> v₁) (pfg : p · f = p · g) (H : isEqualizer f g p pfg). Let Eq : Equalizer f g := make_Equalizer _ _ _ _ H. Proposition self_enrichment_equalizer_cone_eq : internal_to_arr (internal_lam (mon_lunitor e · p)) · f = internal_to_arr (internal_lam (mon_lunitor e · p)) · g. Proof. unfold internal_to_arr. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite internal_beta. rewrite !assoc. rewrite !mon_linvunitor_lunitor. rewrite !id_left. exact pfg. Qed. Definition self_enrichment_equalizer_cone : enriched_equalizer_cone (self_enrichment V) f g. Proof. use make_enriched_equalizer_cone. - exact e. - exact (internal_lam (mon_lunitor _ · p)). - exact self_enrichment_equalizer_cone_eq. Defined. Proposition self_enrichment_equalizer_eq {a b : V} (φ₁ φ₂ : b --> a ⊸ e) (q : φ₁ · postcomp_arr (self_enrichment V) a (internal_to_arr (internal_lam (mon_lunitor e · p))) = φ₂ · postcomp_arr (self_enrichment V) a (internal_to_arr (internal_lam (mon_lunitor e · p)))) : φ₁ = φ₂. Proof. use internal_funext. intros w h. use (EqualizerInsEq Eq) ; cbn. rewrite !self_enrichment_postcomp in q. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) q) as q'. cbn in q'. rewrite !tensor_comp_id_r in q'. rewrite !assoc' in q'. rewrite !internal_beta in q'. unfold internal_to_arr in q'. rewrite !assoc' in q'. rewrite !internal_beta in q'. rewrite !(maponpaths (λ z, _ · (_ · z)) (assoc _ _ _)) in q'. rewrite !mon_linvunitor_lunitor in q'. rewrite id_left in q'. rewrite tensor_split. rewrite !assoc'. rewrite q'. rewrite !assoc. rewrite <- tensor_split. apply idpath. Qed. Proposition self_enrichment_equalizer_arr_eq {a b : V} (h : b --> a ⊸ v₁) (q : h · postcomp_arr (self_enrichment V) _ f = h · postcomp_arr (self_enrichment V) _ g) : h #⊗ identity a · internal_eval a v₁ · f = h #⊗ identity a · internal_eval a v₁ · g. Proof. rewrite !self_enrichment_postcomp in q. pose (maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) q) as q'. cbn in q'. rewrite !tensor_comp_id_r in q'. rewrite !assoc' in q'. rewrite !internal_beta in q'. rewrite !assoc in q'. exact q'. Qed. Definition self_enrichment_equalizer_arr {a b : V} (h : b --> a ⊸ v₁) (q : h · postcomp_arr (self_enrichment V) _ f = h · postcomp_arr (self_enrichment V) _ g) : b --> a ⊸ e. Proof. use internal_lam. use (EqualizerIn Eq). - exact (h #⊗ identity _ · internal_eval _ _). - exact (self_enrichment_equalizer_arr_eq h q). Defined. Definition self_enrichment_equalizer_arr_pr {a b : V} (h : b --> a ⊸ v₁) (q : h · postcomp_arr (self_enrichment V) _ f = h · postcomp_arr (self_enrichment V) _ g) : self_enrichment_equalizer_arr h q · postcomp_arr (self_enrichment V) _ (internal_to_arr (internal_lam (mon_lunitor e · p))) = h. Proof. rewrite self_enrichment_postcomp ; cbn. use internal_funext. intros c k. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. unfold internal_to_arr. rewrite !assoc'. rewrite internal_beta. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite mon_linvunitor_lunitor. apply id_left. } unfold self_enrichment_equalizer_arr. etrans. { rewrite tensor_split. rewrite !assoc. etrans. { apply maponpaths_2. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc'. rewrite (EqualizerCommutes Eq). rewrite !assoc. rewrite <- tensor_split. apply idpath. } apply idpath. Qed. Definition self_enrichment_equalizer_is_equalizer : is_equalizer_enriched (self_enrichment V) f g self_enrichment_equalizer_cone. Proof. use make_is_equalizer_enriched. - exact (λ _ _ h₁ h₂ q, self_enrichment_equalizer_eq h₁ h₂ q). - exact (λ _ _ h q, self_enrichment_equalizer_arr h q). - exact (λ _ _ h q, self_enrichment_equalizer_arr_pr h q). Defined. End SelfEnrichmentEqualizer. Definition self_enrichment_equalizers (EV : Equalizers V) : enrichment_equalizers (self_enrichment V). Proof. intros v₁ v₂ f g. pose (e := EV _ _ f g : V). pose (p := EqualizerArrow (EV _ _ f g) : e --> v₁). pose (pfg := EqualizerEqAr (EV _ _ f g) : p · f = p · g). pose (H := pr22 (EV _ _ f g) : isEqualizer f g p pfg). exact (self_enrichment_equalizer_cone p pfg ,, self_enrichment_equalizer_is_equalizer p pfg H). Defined. (** 4. Powers *) Section SelfEnrichmentPower. Context (v₁ v₂ : V). Definition self_enrichment_power_cone : power_cone (self_enrichment V) v₁ v₂. Proof. use make_power_cone. - exact (v₁ ⊸ v₂). - exact (internal_lam (sym_mon_braiding _ _ _ · internal_eval v₁ v₂)). Defined. Proposition is_power_self_enrichment_power_cone_eq_1 (w : V) : is_power_enriched_map _ _ _ self_enrichment_power_cone w · internal_swap_arg v₁ v₂ w = identity _. Proof. use internal_funext. intros a₁ h₁. unfold internal_swap_arg. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. use internal_funext. intros a₂ h₂. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. etrans. { rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_rassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. do 2 apply maponpaths_2. rewrite tensor_split. rewrite !assoc'. apply maponpaths. unfold is_power_enriched_map. rewrite internal_beta. apply idpath. } cbn. rewrite !assoc'. etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. unfold internal_comp. rewrite internal_beta. apply idpath. } rewrite !assoc'. etrans. { do 3 apply maponpaths. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { rewrite !assoc. do 4 apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_rassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_comp_id_l. rewrite <- tensor_sym_mon_braiding. rewrite tensor_comp_id_l. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_lassociator. rewrite tensor_split'. apply idpath. } rewrite !assoc'. refine (_ @ !(tensor_comp_r_id_l _ _ _)). apply maponpaths. etrans. { do 4 apply maponpaths. rewrite tensor_sym_mon_braiding. apply idpath. } refine (_ @ !(tensor_split _ _)). apply maponpaths. refine (_ @ id_left _). rewrite !assoc. apply maponpaths_2. refine (!(id_right _) @ _). rewrite !assoc'. rewrite <- mon_lassociator_rassociator. apply maponpaths. etrans. { do 3 apply maponpaths. rewrite !assoc. apply maponpaths_2. apply sym_mon_hexagon_lassociator. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite sym_mon_braiding_inv. rewrite tensor_id_id. rewrite id_left. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite sym_mon_braiding_inv. rewrite tensor_id_id. apply id_left. Qed. Proposition is_power_self_enrichment_power_cone_eq_2 (w : V) : internal_swap_arg v₁ v₂ w · is_power_enriched_map (self_enrichment V) v₁ v₂ self_enrichment_power_cone w = identity _. Proof. use internal_funext. intros a₁ h₁. rewrite tensor_comp_r_id_r. unfold is_power_enriched_map. rewrite !assoc'. rewrite internal_beta ; cbn. use internal_funext. intros a₂ h₂. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_left. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_id_r. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. apply idpath. } etrans. { rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_sym_mon_braiding. rewrite tensor_split. rewrite tensor_comp_id_r. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. unfold internal_swap_arg. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. do 2 apply maponpaths_2. etrans. { do 3 apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite <- tensor_id_id. rewrite <- tensor_lassociator. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_comp_id_r. rewrite <- tensor_sym_mon_braiding. rewrite tensor_comp_id_r. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite !id_right, id_left. apply idpath. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite sym_mon_hexagon_lassociator. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite sym_mon_braiding_inv. rewrite tensor_id_id. apply id_left. } rewrite mon_lassociator_rassociator. apply id_right. } rewrite <- tensor_comp_id_r. rewrite sym_mon_braiding_inv. apply tensor_id_id. Qed. Definition is_power_self_enrichment_power_cone : is_power_enriched (self_enrichment V) v₁ v₂ self_enrichment_power_cone. Proof. use make_is_power_enriched. - exact (λ w, internal_swap_arg v₁ v₂ w). - exact is_power_self_enrichment_power_cone_eq_1. - exact is_power_self_enrichment_power_cone_eq_2. Defined. End SelfEnrichmentPower. Definition self_enrichment_powers : enrichment_power (self_enrichment V) := λ v₁ v₂, self_enrichment_power_cone v₁ v₂ ,, is_power_self_enrichment_power_cone v₁ v₂. (** 5. Type indexed products *) Section SelfEnrichmentProduct. Context {J : UU} {D : J → V} (prod : Product J V D). Definition self_enrichment_prod_cone : enriched_prod_cone (self_enrichment V) D. Proof. use make_enriched_prod_cone. - exact prod. - exact (λ j, enriched_from_arr (self_enrichment V) (ProductPr _ _ prod j)). Defined. Definition self_enrichment_is_product : is_prod_enriched (self_enrichment V) D self_enrichment_prod_cone. Proof. use make_is_prod_enriched. - exact (λ v₁ v₂ f, internal_lam (ProductArrow _ _ prod (λ j, f j #⊗ identity _ · internal_eval _ _))). - abstract (intros v₁ v₂ f j ; cbn ; rewrite self_enrichment_postcomp ; use internal_funext ; intros a h ; rewrite tensor_comp_r_id_r ; rewrite !assoc' ; rewrite internal_beta ; rewrite tensor_split ; rewrite !assoc' ; rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) ; rewrite internal_beta ; rewrite internal_to_from_arr ; rewrite ProductPrCommutes ; rewrite !assoc ; rewrite <- tensor_split ; apply idpath). - abstract (intros v₁ v₂ φ₁ φ₂ p ; cbn in * ; use internal_funext ; intros a h ; use (ProductArrow_eq _ _ _ prod) ; intro j ; pose (q := maponpaths (λ z, z #⊗ identity _ · internal_eval _ _) (p j)) ; cbn in q ; rewrite !self_enrichment_postcomp in q ; rewrite !tensor_comp_id_r in q ; rewrite !assoc' in q ; rewrite !internal_beta in q ; rewrite !internal_to_from_arr in q ; rewrite (tensor_split φ₁ h) ; rewrite (tensor_split φ₂ h) ; rewrite !assoc' ; rewrite q ; apply idpath). Defined. End SelfEnrichmentProduct. Definition self_enrichment_prod (J : UU) (PV : Products J V) : enrichment_prod (self_enrichment V) J := λ D, self_enrichment_prod_cone (PV D) ,, self_enrichment_is_product (PV D). End SelfEnrichmentLimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/Limits/Examples/StructureEnrichedLimits.v000066400000000000000000000777521451125700300322340ustar00rootroot00000000000000(***************************************************************** Limits in categories enriched over structures In this file we characterize limits in categories enriched over structures. The proofs and characterizations are in essence the same as for posets. A category enriched over structures inherits its limits from the underlying category if projections and the maps arising from the universal property are structure preserving. Contents 1. Terminal object 2. Binary products 3. Equalizers 4. Type indexed products 5. Powers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.StructureEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.StructuresMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section StructureEnrichmentLimits. Context {P : hset_cartesian_closed_struct} {C : category} (E : struct_enrichment P C). Let E' : enrichment C (sym_mon_closed_cat_of_hset_struct P) := make_enrichment_over_struct P C E. (** 1. Terminal object *) Section StructureEnrichedTerminal. Context {x : C} (Hx : isTerminal C x). Let T : Terminal C := make_Terminal x Hx. Definition structure_enrichment_is_terminal : is_terminal_enriched E' x. Proof. use make_is_terminal_enriched. - intros X y. simple refine (_ ,, _). + exact (λ _, TerminalArrow T y). + abstract (cbn ; apply hset_struct_const). - abstract (intros X y f g ; use eq_mor_hset_struct ; intros z ; apply (@TerminalArrowEq _ T)). Defined. End StructureEnrichedTerminal. Definition make_structure_enrichment_terminal (HC : Terminal C) : terminal_enriched E' := pr1 HC ,, structure_enrichment_is_terminal (pr2 HC). Definition structure_terminal_enriched_weq_Terminal (HC : is_univalent C) : terminal_enriched E' ≃ Terminal C. Proof. use weqimplimpl. - exact (λ T, terminal_underlying E' T). - exact make_structure_enrichment_terminal. - apply (isaprop_terminal_enriched _ HC). - apply (isaprop_Terminal _ HC). Defined. (** 2. Binary products *) Definition structure_enrichment_binary_prod : UU := ∑ (BC : BinProducts C), ∏ (x y z : C), mor_hset_struct P (hset_struct_prod P (E z x) (E z y)) (E z (BC x y)) (λ fg, BinProductArrow _ (BC x y) (pr1 fg) (pr2 fg)). Proposition isaprop_structure_enrichment_binary_prod (HC : is_univalent C) : isaprop structure_enrichment_binary_prod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - do 2 (use impred ; intro). apply (isaprop_BinProduct HC). - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedProdAccessors. Context (EBC : structure_enrichment_binary_prod). Definition structure_enrichment_obj_binary_prod (x y : C) : C := pr1 EBC x y. Definition structure_enrichment_obj_pr1 (x y : C) : structure_enrichment_obj_binary_prod x y --> x := BinProductPr1 _ (pr1 EBC x y). Definition structure_enrichment_obj_pr2 (x y : C) : structure_enrichment_obj_binary_prod x y --> y := BinProductPr2 _ (pr1 EBC x y). Definition structure_enrichment_obj_pair {z x y : C} (f : z --> x) (g : z --> y) : z --> structure_enrichment_obj_binary_prod x y := BinProductArrow _ (pr1 EBC x y) f g. Proposition structure_enrichment_obj_pair_pr1 {z x y : C} (f : z --> x) (g : z --> y) : structure_enrichment_obj_pair f g · structure_enrichment_obj_pr1 x y = f. Proof. apply BinProductPr1Commutes. Qed. Proposition structure_enrichment_obj_pair_pr2 {z x y : C} (f : z --> x) (g : z --> y) : structure_enrichment_obj_pair f g · structure_enrichment_obj_pr2 x y = g. Proof. apply BinProductPr2Commutes. Qed. Proposition structure_enrichment_binary_prod_arr_eq {w x y : C} {f g : w --> structure_enrichment_obj_binary_prod x y} (p : f · structure_enrichment_obj_pr1 x y = g · structure_enrichment_obj_pr1 x y) (q : f · structure_enrichment_obj_pr2 x y = g · structure_enrichment_obj_pr2 x y) : f = g. Proof. use (BinProductArrowsEq _ _ _ (pr1 EBC x y)). - exact p. - exact q. Qed. Definition structure_enrichment_binary_prod_pair (x y z : C) : E' ⦃ z , x ⦄ ⊗ (E' ⦃ z , y ⦄) --> E' ⦃ z , structure_enrichment_obj_binary_prod x y ⦄ := _ ,, pr2 EBC x y z. End StructureEnrichedProdAccessors. Section StructureProd. Context (EBC : structure_enrichment_binary_prod) (x y : C). Definition make_structure_enriched_binary_prod_cone : enriched_binary_prod_cone E' x y. Proof. use make_enriched_binary_prod_cone. - exact (structure_enrichment_obj_binary_prod EBC x y). - exact (enriched_from_arr E' (structure_enrichment_obj_pr1 EBC x y)). - exact (enriched_from_arr E' (structure_enrichment_obj_pr2 EBC x y)). Defined. Definition structure_enrichment_binary_prod_is_prod : is_binary_prod_enriched E' x y make_structure_enriched_binary_prod_cone. Proof. use make_is_binary_prod_enriched. - intros z X f g. refine (_ · structure_enrichment_binary_prod_pair _ _ _ _). simple refine (_ ,, _). + exact (prodtofuntoprod (pr1 f ,, pr1 g)). + apply hset_struct_pair. * exact (pr2 f). * exact (pr2 g). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_pair_pr1). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_pair_pr2). - abstract (intros z X φ₁ φ₂ q₁ q₂ ; use eq_mor_hset_struct ; intro w ; use structure_enrichment_binary_prod_arr_eq ; [ exact (eqtohomot (maponpaths (λ f, pr1 f) q₁) w) | exact (eqtohomot (maponpaths (λ f, pr1 f) q₂) w) ]). Defined. End StructureProd. Definition make_structure_enrichment_binary_prod (EBC : structure_enrichment_binary_prod) : enrichment_binary_prod E' := λ x y, make_structure_enriched_binary_prod_cone EBC x y ,, structure_enrichment_binary_prod_is_prod EBC x y. Section ToStructureProduct. Context (EP : enrichment_binary_prod E') {x y z : C}. Let prod : sym_monoidal_cat_of_hset_struct P := (E' ⦃ x , y ⦄) ⊗ (E' ⦃ x , z ⦄). Let prod_pr1 : prod --> E' ⦃ x , y ⦄ := _ ,, hset_struct_pr1 _ _ _. Let prod_pr2 : prod --> E' ⦃ x , z ⦄ := _ ,, hset_struct_pr2 _ _ _. Definition structure_to_underlying_binary_prod_map (f : x --> y) (g : x --> z) : x --> underlying_BinProduct E' y z (pr2 (EP y z)) := pr1 (BinProductArrow (sym_monoidal_cat_of_hset_struct P) (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) prod_pr1 prod_pr2) (f ,, g). Proposition structure_to_underlying_binary_prod_map_pr1 (f : x --> y) (g : x --> z) : structure_to_underlying_binary_prod_map f g · enriched_prod_cone_pr1 E' y z (pr1 (EP y z)) = f. Proof. pose (eqtohomot (maponpaths pr1 (BinProductPr1Commutes _ _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) _ prod_pr1 prod_pr2)) (f ,, g)) as p. cbn in p. exact p. Qed. Proposition structure_to_underlying_binary_prod_map_pr2 (f : x --> y) (g : x --> z) : structure_to_underlying_binary_prod_map f g · enriched_prod_cone_pr2 E' y z (pr1 (EP y z)) = g. Proof. pose (eqtohomot (maponpaths pr1 (BinProductPr2Commutes _ _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) _ prod_pr1 prod_pr2)) (f ,, g)) as p. cbn in p. exact p. Qed. Proposition structure_to_underlying_binary_prod_map_eq : (λ fg, BinProductArrow C (underlying_BinProduct E' y z (pr2 (EP y z))) (pr1 fg) (pr2 fg)) = (λ fg, structure_to_underlying_binary_prod_map (pr1 fg) (dirprod_pr2 fg)). Proof. use funextsec. intros fg. use is_binary_prod_enriched_arrow_eq. - exact (pr2 (EP y z)). - refine (_ @ !(structure_to_underlying_binary_prod_map_pr1 _ _)). apply (BinProductPr1Commutes C _ _ (underlying_BinProduct E' y z (pr2 (EP y z))) _ _ _). - refine (_ @ !(structure_to_underlying_binary_prod_map_pr2 _ _)). apply (BinProductPr2Commutes C _ _ (underlying_BinProduct E' y z (pr2 (EP y z))) _ _ _). Qed. Proposition structure_to_underlying_binary_prod_map_structure_preserving : mor_hset_struct P (hset_struct_prod P (E x y) (E x z)) (E x (underlying_BinProduct E' y z (pr2 (EP y z)))) (λ fg, BinProductArrow C (underlying_BinProduct E' y z (pr2 (EP y z))) (pr1 fg) (pr2 fg)). Proof. exact (transportb _ structure_to_underlying_binary_prod_map_eq (pr2 (@BinProductArrow _ _ _ (is_binary_prod_enriched_to_BinProduct E' _ _ (pr2 (EP y z)) x) prod prod_pr1 prod_pr2))). Qed. End ToStructureProduct. Definition to_structure_enrichment_binary_prod (EP : enrichment_binary_prod E') : structure_enrichment_binary_prod. Proof. simple refine (_ ,, _). - exact (λ x y, underlying_BinProduct E' x y (pr2 (EP x y))). - abstract (intros x y z ; apply structure_to_underlying_binary_prod_map_structure_preserving). Defined. Definition structure_enrichment_binary_prod_weq (HC : is_univalent C) : enrichment_binary_prod E' ≃ structure_enrichment_binary_prod. Proof. use weqimplimpl. - apply to_structure_enrichment_binary_prod. - apply make_structure_enrichment_binary_prod. - apply (isaprop_enrichment_binary_prod HC). - apply (isaprop_structure_enrichment_binary_prod HC). Defined. (** 3. Equalizers *) Section EqualizerStructures. Context (HP : hset_equalizer_struct P). Definition structure_enrichment_equalizers : UU := ∑ (EC : Equalizers C), ∏ (w x y : C) (f g : x --> y), mor_hset_struct P (hset_struct_equalizer HP (pr2 (postcomp_arr E' w f)) (pr2 (postcomp_arr E' w g))) (E w (EC x y f g)) (λ h, EqualizerIn (EC x y f g) w (pr1 h) (pr2 h)). Proposition isaprop_structure_enrichment_equalizers (HC : is_univalent C) : isaprop structure_enrichment_equalizers. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Equalizer. exact HC. - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedEqualizerAccessors. Context (EEC : structure_enrichment_equalizers). Definition structure_enrichment_obj_equalizer {x y : C} (f g : x --> y) : C := pr1 EEC x y f g. Definition structure_enrichment_obj_equalizer_pr {x y : C} (f g : x --> y) : structure_enrichment_obj_equalizer f g --> x := EqualizerArrow (pr1 EEC x y f g). Proposition structure_enrichment_obj_pr_eq {x y : C} (f g : x --> y) : structure_enrichment_obj_equalizer_pr f g · f = structure_enrichment_obj_equalizer_pr f g · g. Proof. apply EqualizerEqAr. Qed. Definition structure_enrichment_obj_to_equalizer {w x y : C} {f g : x --> y} (h : w --> x) (q : h · f = h · g) : w --> structure_enrichment_obj_equalizer f g := EqualizerIn (pr1 EEC x y f g) w h q. Proposition structure_enrichment_obj_to_equalizer_pr {w x y : C} {f g : x --> y} (h : w --> x) (q : h · f = h · g) : structure_enrichment_obj_to_equalizer h q · structure_enrichment_obj_equalizer_pr f g = h. Proof. apply EqualizerCommutes. Qed. Proposition structure_enrichment_equalizer_arr_eq {w x y : C} {f g : x --> y} {h₁ h₂ : w --> structure_enrichment_obj_equalizer f g} (q : h₁ · structure_enrichment_obj_equalizer_pr f g = h₂ · structure_enrichment_obj_equalizer_pr f g) : h₁ = h₂. Proof. use EqualizerInsEq. exact q. Qed. Definition structure_enrichment_to_equalizer {w x y : C} (f g : x --> y) : hset_struct_equalizer_ob HP (pr2 (postcomp_arr E' w f)) (pr2 (postcomp_arr E' w g)) --> E' ⦃ w , structure_enrichment_obj_equalizer f g ⦄ := _ ,, pr2 EEC w x y f g. End StructureEnrichedEqualizerAccessors. Section StructureEqualizer. Context (EEC : structure_enrichment_equalizers) {x y : C} (f g : x --> y). Definition make_structure_enrichment_equalizer_cone : enriched_equalizer_cone E' f g. Proof. use make_enriched_equalizer_cone. - exact (structure_enrichment_obj_equalizer EEC f g). - exact (enriched_from_arr E' (structure_enrichment_obj_equalizer_pr EEC f g)). - exact (structure_enrichment_obj_pr_eq EEC f g). Defined. Definition make_structure_enrichment_equalizer_is_equalizer : is_equalizer_enriched E' f g make_structure_enrichment_equalizer_cone. Proof. use make_is_equalizer_enriched. - abstract (intros w X φ₁ φ₂ q ; use eq_mor_hset_struct ; intro z ; use structure_enrichment_equalizer_arr_eq ; exact (eqtohomot (maponpaths pr1 q) z)). - intros w X h q. refine (_ · structure_enrichment_to_equalizer EEC f g). simple refine (_ ,, _). + refine (λ z, pr1 h z ,, _). exact (eqtohomot (maponpaths pr1 q) z). + abstract (apply hset_equalizer_arrow_struct ; exact (pr2 h)). - abstract (intros w X h q ; use eq_mor_hset_struct ; intros z ; apply structure_enrichment_obj_to_equalizer_pr). Defined. End StructureEqualizer. Definition make_structure_enrichment_equalizers (EEC : structure_enrichment_equalizers) : enrichment_equalizers E'. Proof. intros x y f g. simple refine (_ ,, _). - exact (make_structure_enrichment_equalizer_cone EEC f g). - exact (make_structure_enrichment_equalizer_is_equalizer EEC f g). Defined. Section ToStructureEqualizer. Context (EEC : enrichment_equalizers E') {w x y : C} (f g : x --> y). Let Eq : Equalizer _ _ := Equalizers_category_of_hset_struct HP _ _ (postcomp_arr E' w f) (postcomp_arr E' w g). Let Eq_pr : Eq --> E' ⦃ w , x ⦄ := EqualizerArrow _. Let Eq_path : Eq_pr · postcomp_arr E' w f = Eq_pr · postcomp_arr E' w g := EqualizerEqAr _. Definition structure_to_underlying_equalizer_map (h : w --> x) (q : h · f = h · g) : w --> underlying_Equalizer E' f g (pr2 (EEC x y f g)) := pr1 (EqualizerIn (is_equalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path) (h ,, q). Proposition structure_to_underlying_equalizer_map_pr (h : w --> x) (q : h · f = h · g) : structure_to_underlying_equalizer_map h q · enriched_equalizer_cone_pr E' f g (pr1 (EEC x y f g)) = h. Proof. pose (eqtohomot (maponpaths pr1 (EqualizerCommutes (is_equalizer_enriched_to_Equalizer E' f g (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path)) (h ,, q)) as p. cbn in p. exact p. Qed. Definition to_structure_enrichment_equalizer_structure_preserving : mor_hset_struct P (hset_struct_equalizer HP (pr2 (postcomp_arr E' w f)) (pr2 (postcomp_arr E' w g))) (E w (underlying_Equalizer E' f g (pr2 (EEC x y f g)))) (λ h, EqualizerIn (underlying_Equalizer E' f g (pr2 (EEC x y f g))) w (pr1 h) (pr2 h)). Proof. refine (transportb _ _ (pr2 (EqualizerIn (is_equalizer_enriched_to_Equalizer E' _ _ (pr2 (EEC x y f g)) w) Eq Eq_pr Eq_path))). use funextsec. intros fg. use underlying_Equalizer_arr_eq. - exact (pr2 (EEC x y f g)). - refine (_ @ !(structure_to_underlying_equalizer_map_pr (pr1 fg) (pr2 fg))). apply (EqualizerCommutes (underlying_Equalizer E' f g (pr2 (EEC x y f g)))). Qed. End ToStructureEqualizer. Definition to_structure_enrichment_equalizer (EEC : enrichment_equalizers E') : structure_enrichment_equalizers. Proof. simple refine (_ ,, _). - exact (λ x y f g, underlying_Equalizer E' f g (pr2 (EEC x y f g))). - abstract (intros w x y f g ; apply to_structure_enrichment_equalizer_structure_preserving). Defined. Definition structure_enrichment_equalizer_weq (HC : is_univalent C) : enrichment_equalizers E' ≃ structure_enrichment_equalizers. Proof. use weqimplimpl. - apply to_structure_enrichment_equalizer. - apply make_structure_enrichment_equalizers. - apply (isaprop_enrichment_equalizers HC). - apply (isaprop_structure_enrichment_equalizers HC). Defined. End EqualizerStructures. (** 4. Type indexed products *) Section StructureTypeIndexedProducts. Context {J : UU} (HP : hset_struct_type_prod P J). Definition structure_enrichment_prod : UU := ∑ (PC : Products J C), ∏ (x : C) (ys : J → C), mor_hset_struct P (HP _ (λ j, pr2 (E' ⦃ x , ys j ⦄))) (E x (PC ys)) (λ h, ProductArrow _ _ (PC ys) (λ i, h i)). Proposition isaprop_structure_enrichment_prod (HC : is_univalent C) : isaprop structure_enrichment_prod. Proof. simple refine (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - repeat (use impred ; intro). apply isaprop_Product. exact HC. - repeat (use impred ; intro). apply isaprop_hset_struct_on_mor. Qed. Section StructureEnrichedProdAccessors. Context (EC : structure_enrichment_prod). Definition structure_enrichment_obj_prod (ys : J → C) : C := pr1 EC ys. Definition structure_enrichment_obj_prod_pr (ys : J → C) (j : J) : structure_enrichment_obj_prod ys --> ys j := ProductPr _ _ (pr1 EC ys) j. Definition structure_enrichment_obj_prod_pair {x : C} {ys : J → C} (fs : ∏ (j : J), x --> ys j) : x --> structure_enrichment_obj_prod ys := ProductArrow _ _ (pr1 EC ys) fs. Proposition structure_enrichment_obj_prod_pair_pr {x : C} {ys : J → C} (fs : ∏ (j : J), x --> ys j) (j : J) : structure_enrichment_obj_prod_pair fs · structure_enrichment_obj_prod_pr ys j = fs j. Proof. apply ProductPrCommutes. Qed. Proposition structure_enrichment_prod_arr_eq {x : C} {ys : J → C} {f g : x --> structure_enrichment_obj_prod ys} (p : ∏ (j : J), f · structure_enrichment_obj_prod_pr ys j = g · structure_enrichment_obj_prod_pr ys j) : f = g. Proof. use (ProductArrow_eq _ _ _ (pr1 EC ys)). exact p. Qed. Definition structure_enrichment_prod_pair (x : C) (ys : J → C) : hset_struct_type_prod_ob HP _ (λ j, pr2 (E' ⦃ x , ys j ⦄)) --> E' ⦃ x , pr1 EC ys ⦄ := _ ,, pr2 EC x ys. End StructureEnrichedProdAccessors. Section StructureProd. Context (EBC : structure_enrichment_prod) (ys : J → C). Definition make_structure_enriched_prod_cone : enriched_prod_cone E' ys. Proof. use make_enriched_prod_cone. - exact (structure_enrichment_obj_prod EBC ys). - exact (λ j, enriched_from_arr E' (structure_enrichment_obj_prod_pr EBC ys j)). Defined. Definition structure_enrichment_prod_is_prod : is_prod_enriched E' ys make_structure_enriched_prod_cone. Proof. use make_is_prod_enriched. - intros z X fs. refine (_ · structure_enrichment_prod_pair _ _ _). simple refine (_ ,, _). + exact (λ x j, pr1 (fs j) x). + abstract (use hset_struct_type_prod_pair ; intro j ; exact (pr2 (fs j))). - abstract (intros z X f g ; use eq_mor_hset_struct ; intros w ; cbn ; apply structure_enrichment_obj_prod_pair_pr). - abstract (intros z X φ₁ φ₂ q ; use eq_mor_hset_struct ; intro w ; use structure_enrichment_prod_arr_eq ; intro j ; exact (eqtohomot (maponpaths (λ f, pr1 f) (q j)) w)). Defined. End StructureProd. Definition make_structure_enrichment_prod (EBC : structure_enrichment_prod) : enrichment_prod E' J := λ ys, make_structure_enriched_prod_cone EBC ys ,, structure_enrichment_prod_is_prod EBC ys. Section ToStructureProduct. Context (EP : enrichment_prod E' J) {x : C} (ys : J → C). Let prod : Product _ _ _ := Products_category_of_hset_struct_type_prod HP (λ j, E' ⦃ x , ys j ⦄). Let prod_pr : ∏ (j : J), prod --> E' ⦃ x , ys j ⦄ := λ j, _ ,, hset_struct_type_prod_pr HP (λ j, pr2 (E' ⦃ x , ys j ⦄)) j. Definition structure_to_underlying_prod_map (fs : ∏ (j : J), x --> ys j) : x --> underlying_Product E' ys (pr2 (EP ys)) := pr1 (ProductArrow _ _ (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod_pr) fs. Proposition structure_to_underlying_prod_map_pr (fs : ∏ (j : J), x --> ys j) (j : J) : structure_to_underlying_prod_map fs · enriched_prod_cone_pr E' ys (pr1 (EP ys)) j = fs j. Proof. pose (eqtohomot (maponpaths pr1 (ProductPrCommutes J _ _ (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) _ prod_pr j)) fs) as p. cbn in p. exact p. Qed. Definition to_structure_enrichment_prod_structure_preserving : mor_hset_struct P (HP (λ j, pr1 (E' ⦃ x, ys j ⦄)) (λ j : J, pr2 (E' ⦃ x, ys j ⦄))) (E x (underlying_Product E' ys (pr2 (EP ys)))) (λ h, ProductArrow J C (underlying_Product E' ys (pr2 (EP ys))) (λ i, h i)). Proof. refine (transportb _ _ (pr2 (@ProductArrow _ _ _ (is_prod_enriched_to_Product E' _ (pr2 (EP ys)) x) prod prod_pr))). use funextsec. intros fg. use is_prod_enriched_arrow_eq. - exact (pr2 (EP ys)). - intro j. refine (_ @ !(structure_to_underlying_prod_map_pr _ j)). apply (ProductPrCommutes _ _ _ (underlying_Product E' ys (pr2 (EP ys)))). Qed. End ToStructureProduct. Definition to_structure_enrichment_prod (EP : enrichment_prod E' J) : structure_enrichment_prod. Proof. simple refine (_ ,, _). - exact (λ ys, underlying_Product E' ys (pr2 (EP ys))). - intros x ys. apply to_structure_enrichment_prod_structure_preserving. Defined. Definition structure_enrichment_prod_weq (HC : is_univalent C) : enrichment_prod E' J ≃ structure_enrichment_prod. Proof. use weqimplimpl. - apply to_structure_enrichment_prod. - apply make_structure_enrichment_prod. - apply (isaprop_enrichment_prod HC). - apply (isaprop_structure_enrichment_prod HC). Defined. End StructureTypeIndexedProducts. (** 5. Powers *) Definition structure_enrichment_pows : UU := ∑ (prods : ∏ (X : category_of_hset_struct P), Products (pr11 X) C), ∏ (X : category_of_hset_struct P) (x : C), mor_hset_struct P (pr2 X) (E (prods X (λ _, x)) x) (ProductPr _ _ (prods X (λ _, x))) × (∏ (y : C), mor_hset_struct P (hset_struct_fun P (pr2 X) (E y x)) (E y (prods X (λ _, x))) (λ f, ProductArrow _ _ (prods X (λ _, x)) (pr1 f))). Section StructureEnrichmentPowersAccessors. Context (HE : structure_enrichment_pows). Definition structure_pows_prod (X : category_of_hset_struct P) (x : C) : Product (pr11 X) C (λ _, x) := pr1 HE X (λ _, x). Definition structure_pows_pr {X : category_of_hset_struct P} {x : C} (i : pr11 X) : structure_pows_prod X x --> x := ProductPr _ _ (structure_pows_prod X x) i. Proposition structure_pows_mor_pr (X : category_of_hset_struct P) (x : C) : mor_hset_struct P (pr2 X) (E (structure_pows_prod X x) x) structure_pows_pr. Proof. exact (pr1 (pr2 HE X x)). Qed. Proposition structure_pows_mor_product_arr (X : category_of_hset_struct P) (x y : C) : mor_hset_struct P (hset_struct_fun P (pr2 X) (E y x)) (E y (structure_pows_prod X x)) (λ f, ProductArrow _ _ (structure_pows_prod X x) (pr1 f)). Proof. exact (pr2 (pr2 HE X x) y). Qed. End StructureEnrichmentPowersAccessors. Section StructureEnrichmentPowers. Context (HE : structure_enrichment_pows) (X : sym_mon_closed_cat_of_hset_struct P) (x : C). Let pow : Product _ C (λ _, x) := structure_pows_prod HE X x. Let pow_pr : ∏ (_ : pr11 X), pow --> x := λ i, structure_pows_pr HE i. Definition structure_power_cone : power_cone E' X x. Proof. simple refine (_ ,, _). - exact pow. - simple refine (_ ,, _). + exact pow_pr. + exact (structure_pows_mor_pr HE X x). Defined. Definition structure_power_map (y : C) : X ⊸ (E' ⦃ y , x ⦄) --> E' ⦃ y , structure_power_cone ⦄. Proof. simple refine (_ ,, _). - intro f. exact (ProductArrow _ _ pow (pr1 f)). - exact (structure_pows_mor_product_arr HE X x y). Defined. Definition structure_power_is_power : is_power_enriched E' X x structure_power_cone. Proof. use make_is_power_enriched. - exact structure_power_map. - abstract (intro y ; use eq_mor_hset_struct ; intro f ; cbn in f ; use ProductArrow_eq ; intro i ; apply (ProductPrCommutes _ _ _ pow)). - abstract (intro y ; use eq_mor_hset_struct ; intro f ; use eq_mor_hset_struct ; intro i ; cbn ; apply (ProductPrCommutes _ _ _ pow)). Defined. End StructureEnrichmentPowers. Definition structure_enrichment_powers_from_products (HE : structure_enrichment_pows) : enrichment_power E'. Proof. intros X x. simple refine (_ ,, _). - exact (structure_power_cone HE X x). - apply structure_power_is_power. Defined. End StructureEnrichmentLimits. UniMath-20231010/UniMath/CategoryTheory/EnrichedCats/YonedaLemma.v000066400000000000000000000252221451125700300245450ustar00rootroot00000000000000(************************************************************************* The Yoneda lemma for enriched categories We prove the Yoneda lemma for enriched categories. For enriched categories, there are several options for formulating the Yoneda lemma. First of all, one could look at the weak Yoneda lemma. The weak Yoneda lemma says something about the *set* of natural transformations, namely that this section is isomorphic to the collection of global elements. This statement is proven in Section 1.9 of [1]. Alternatively, one could truly use the enrichments. Instead of talking about the set of natural transformations, one talks about the object in the category `V` over which we enrich. The existence of this object relies on `V` being a symmetric closed monoidal category with enough limits. This statement is called the strong Yoneda Lemma, and it is proven in Section 2.4 of [1]. In this file, we prove the strong Yoneda lemma. The precise formulation that we use, is that the Yoneda embedding is a fully faithful enriched functor. The main challenge in the proof is applying the naturality. In the strong Yoneda lemma, we are working with an object in `V` that represents the enriched natural transformations. This object is defined when constructing the enriched functor category (see Examples.FunctorCategory.v). Concretely, we take an equalizer (represents the naturality condition) of a product (the morphisms of the natural transformation). To use the naturality, we need to use the fact that the equalizer gives rise to an equalizer diagram. This comes up in the statement [yoneda_inv_left]. References [1]: Basic Concepts of Enriched Category Theory, Max Kelly (http://www.tac.mta.ca/tac/reprints/articles/10/tr10.pdf) Contents 1. The inverse of the Yoneda embedding 2. The strong Yoneda lemma *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FunctorCategory. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.Yoneda. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section YonedaLemma. Context {V : sym_mon_closed_cat} {C : category} (E : enrichment C V) (EqV : Equalizers V) (PV : Products C V) (PV' : Products (C × C) V). (** * 1. The inverse of the Yoneda embedding *) Section Inverse. Context (x y : C). Definition yoneda_inv : enriched_presheaf_enrichment E EqV PV PV' ⦃ enriched_yoneda_functor E x , enriched_yoneda_functor E y ⦄ --> E ⦃ x, y ⦄ := EqualizerArrow _ · ProductPr _ _ _ x · mon_rinvunitor _ · (identity _ #⊗ enriched_id E x) · internal_eval (E ⦃ x , x ⦄) (E ⦃ x, y ⦄). Arguments yoneda_inv /. Proposition yoneda_inv_right : enriched_yoneda_enrichment E EqV PV PV' x y · yoneda_inv = identity _. Proof. cbn. rewrite !assoc. rewrite EqualizerCommutes. etrans. { do 3 apply maponpaths_2. exact (ProductPrCommutes C V _ _ _ _ _). } rewrite tensor_rinvunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite <- enrichment_id_right. apply idpath. } apply mon_rinvunitor_runitor. Qed. Proposition yoneda_inv_left : yoneda_inv · enriched_yoneda_enrichment E EqV PV PV' x y = identity _. Proof. cbn. use EqualizerInsEq. rewrite !assoc'. rewrite EqualizerCommutes. rewrite id_left. refine (_ @ id_right _). use ProductArrow_eq. intro z. rewrite !assoc'. rewrite id_left. etrans. { do 5 apply maponpaths. exact (ProductPrCommutes C V _ _ _ _ _). } use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. (* we want to use naturality *) pose (EqualizerEqAr (enriched_functor_hom (op_enrichment V E) (self_enrichment V) EqV PV PV' (enriched_repr_presheaf_enrichment E x) (enriched_repr_presheaf_enrichment E y))) as p₁. cbn in p₁. unfold enriched_functor_left_map, enriched_functor_right_map in p₁. unfold enriched_functor_left_map_ob, enriched_functor_right_map_ob in p₁. (* we apply naturality on a morphism going from `x` to `y` *) pose (maponpaths (λ f, f · ProductPr (C ^opp × C ^opp) V _ (x ,, z)) p₁ : _ = _) as p₂. rewrite !assoc' in p₂. pose (!(maponpaths (λ z, _ · z) (ProductPrCommutes (C^opp × C^opp) V _ _ _ _ _)) @ p₂ @ maponpaths (λ z, _ · z) (ProductPrCommutes (C^opp × C^opp) V _ _ _ _ _)) as p₃. cbn -[sym_mon_braiding] in p₃. pose (maponpaths (λ z, z #⊗ h · internal_eval _ _) p₃) as p. cbn -[sym_mon_braiding] in p. refine (_ @ maponpaths (λ f, f · mon_rinvunitor _ · (identity _ #⊗ enriched_id E x) · internal_eval _ _) p @ _). - rewrite !tensor_comp_r_id_r. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite internal_beta. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_rinvunitor. rewrite tensor_comp_id_r. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc'. apply idpath. } rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_id_id. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite <- mon_rinvunitor_triangle. rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. apply id_left. } apply sym_mon_braiding_inv. - rewrite !tensor_comp_r_id_r. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite internal_beta. rewrite tensor_rinvunitor. rewrite !assoc'. etrans. { apply maponpaths. rewrite tensor_comp_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite <- tensor_id_id. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply idpath. } rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. etrans. { do 2 apply maponpaths_2. apply maponpaths. rewrite <- tensor_split'. rewrite tensor_split. apply idpath. } rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite internal_beta. apply idpath. } refine (_ @ id_left _). rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_comp_id_l. etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. rewrite <- enrichment_id_left. apply idpath. } rewrite sym_mon_braiding_lunitor. rewrite <- mon_runitor_triangle. refine (_ @ mon_rinvunitor_runitor _). apply maponpaths. rewrite !assoc. rewrite mon_lassociator_rassociator. apply id_left. Qed. End Inverse. (** * 2. The strong Yoneda lemma *) Proposition fully_faithful_enriched_yoneda : fully_faithful_enriched_functor (enriched_yoneda_enrichment E EqV PV PV'). Proof. intros x y. use make_is_z_isomorphism. - exact (yoneda_inv x y). - split. + exact (yoneda_inv_right x y). + exact (yoneda_inv_left x y). Defined. End YonedaLemma. UniMath-20231010/UniMath/CategoryTheory/EpiFacts.v000066400000000000000000000137141451125700300215170ustar00rootroot00000000000000(** - Definition of an effective epimorphism. - Proof that natural transformations that are pointwise effective epis are effective epis. - Proof that if the target category has pushouts, a natural transformation that is an epimorphism is pointwise epimorphic - Faithul functors reflect epimorphisms - Definition of a split epimorphism - Split epis are absolute (ie are preserved by any functor) Ambroise LAFONT January 2017 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.pullbacks. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.coequalizers. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.graphs.pushouts. Require Import UniMath.CategoryTheory.limits.graphs.eqdiag. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.coequalizers. Local Open Scope cat. (** Definition of an effective epimorphism. An effective epimorphism p: A -> B is a morphism which has a kernel pair and which is the coequalizer of its kernel pair. *) Section EffectiveEpi. Context {C:category} {A B:C}. Variable (f: C ⟦A,B⟧). Definition kernel_pair := Pullback f f. Definition isEffective := ∑ g:kernel_pair, (isCoequalizer (PullbackPr1 g) (PullbackPr2 g) f (PullbackSqrCommutes g)). End EffectiveEpi. Definition EpisAreEffective (C:category) := ∏ (A B:C) (f:C⟦A,B⟧), isEpi f -> isEffective f. (** Let f be a natural transformation. If f is pointwise effective, then f is effective *) Section IsEffectivePw. Context {C : category} {D : category} . Local Notation CD := (functor_category C D). Lemma eq_pb_pw {X Y Z:functor C D} (a: X ⟹ Z) (b: Y ⟹ Z) (c:C) : eq_diag (pullback_diagram D (a c) (b c)) (diagram_pointwise (pullback_diagram CD a b) c). Proof. intros. use tpair. use StandardFiniteSets.three_rec_dep; apply idpath. use StandardFiniteSets.three_rec_dep; use StandardFiniteSets.three_rec_dep; exact (empty_rect _ ) || (exact (λ _, idpath _)). Defined. Lemma eq_coeq_pw {X Y: functor C D} (a b:X ⟹ Y) (c:C) : eq_diag (Coequalizer_diagram D (a c) (b c)) (diagram_pointwise (Coequalizer_diagram CD a b) c). Proof. intros. use tpair. use StandardFiniteSets.two_rec_dep; reflexivity. use StandardFiniteSets.two_rec_dep; use StandardFiniteSets.two_rec_dep; try exact (empty_rect _ ). intros g'. destruct g'. apply idpath. apply idpath. Defined. Context {X Y :functor C D } {a:X ⟹ Y}. Lemma isEffectivePw : (∏ (x:C), isEffective (a x)) -> isEffective (C:=CD) a. Proof. intros h. red. transparent assert (f:(kernel_pair (C:=CD) a)). { apply equiv_Pullback_2. apply LimFunctorCone. intro c. specialize (h c). set (f := pr1 h). apply equiv_Pullback_1 in f. use (eq_diag_liftlimcone _ _ f). apply eq_pb_pw. } exists f. apply equiv_isCoequalizer2. apply pointwise_Colim_is_isColimFunctor. intro x. set (g:= f). assert (hf := (pr2 (h x))); simpl in hf. apply equiv_isCoequalizer1 in hf. set (eqd := eq_coeq_pw (PullbackPr1 g) (PullbackPr2 g) x). set (z:= (eq_diag_iscolimcocone _ eqd hf)). set (CC := (make_ColimCocone _ _ _ z)). apply (is_z_iso_isColim _ CC). rewrite <- (colimArrowUnique CC _ _ (identity _)). apply identity_is_z_iso. use StandardFiniteSets.two_rec_dep; cbn beta; rewrite id_right; apply idpath. Qed. End IsEffectivePw. (** if the target category has pushouts, a natural transformation that is an epimorphism is pointwise epimorphic *) Section PointwiseEpi. Context {C : category} {D : category}. Local Notation CD := (functor_category C D). Lemma eq_po_pw {X Y Z :functor C D} {a: X ⟹ Y } {b: X ⟹ Z} x : eq_diag (pushout_diagram D (a x) (b x)) (diagram_pointwise (pushout_diagram CD a b) x). Proof. use tpair. use StandardFiniteSets.three_rec_dep; apply idpath. use StandardFiniteSets.three_rec_dep; use StandardFiniteSets.three_rec_dep; exact (empty_rect _ )||exact (λ _, idpath _). Defined. Lemma Pushouts_pw_epi (colimD : graphs.pushouts.Pushouts D) (A B : functor C D) (a: A ⟹ B) (epia:isEpi (C:=CD) a) : ∏ (x:C), isEpi (a x). Proof. intro x; simpl. apply (epi_to_pushout (C:=CD)) in epia. apply pushout_to_epi. simpl. apply equiv_isPushout1 in epia. apply equiv_isPushout2. red in epia. red. eapply isColimFunctor_is_pointwise_Colim in epia; cycle 1. { intro c. eapply eq_diag_liftcolimcocone. - apply eq_po_pw. - apply colimD. } apply (eq_diag_iscolimcocone _ (sym_eq_diag _ _ (eq_po_pw x)))in epia; cycle 1. set (CC := (make_ColimCocone _ _ _ epia)). eapply (is_z_iso_isColim _ CC). rewrite <- (colimArrowUnique CC _ _ (identity _)). apply identity_is_z_iso. use StandardFiniteSets.three_rec_dep; cbn beta; rewrite id_right; apply idpath. Qed. End PointwiseEpi. (** faithul functors reflect epimorphisms *) Lemma faithful_reflects_epis {C D:precategory} (U:functor C D) (hU:faithful U) {a b:C} (f:C⟦a,b⟧) : isEpi (#U f) -> isEpi f. Proof. intros hf c u v huv. eapply invmaponpathsincl. apply hU. cbn. apply hf. rewrite <- functor_comp, <- functor_comp. now rewrite huv. Qed. UniMath-20231010/UniMath/CategoryTheory/Epis.v000066400000000000000000000127311451125700300207170ustar00rootroot00000000000000(** * Epis *) (** ** Contents - Definition of Epis - Construction of the subcategory of Epis - Construction of Epis in functor categories More proofs/definitions about epi can be found in EpiFacts *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. (** * Definition of Epis *) Section def_epi. Variable C : precategory. Hypothesis hs : has_homsets C. (** Definition and construction of isEpi. *) Definition isEpi {x y : C} (f : x --> y) : UU := ∏ (z : C) (g h : y --> z), f · g = f · h -> g = h. Definition make_isEpi {x y : C} (f : x --> y) (H : ∏ (z : C) (g h : y --> z), f · g = f · h -> g = h) : isEpi f := H. Lemma isapropisEpi {y z : C} (f : y --> z) : isaprop (isEpi f). Proof. apply impred_isaprop; intros t. apply impred_isaprop; intros g. apply impred_isaprop; intros h. apply impred_isaprop; intros H. apply hs. Qed. (** Definition and construction of Epi. *) Definition Epi (x y : C) : UU := ∑ f : x --> y, isEpi f. Definition make_Epi {x y : C} (f : x --> y) (H : isEpi f) : Epi x y := tpair _ f H. (** Gets the arrow out of Epi. *) Definition EpiArrow {x y : C} (E : Epi x y) : C⟦x, y⟧ := pr1 E. Coercion EpiArrow : Epi >-> precategory_morphisms. Definition EpiisEpi {x y : C} (E : Epi x y) : isEpi E := pr2 E. (** Isomorphism to isEpi and Epi. *) Lemma is_iso_isEpi {x y : C} (f : x --> y) (H : is_z_isomorphism f) : isEpi f. Proof. apply make_isEpi. intros z g h X. apply (pre_comp_with_z_iso_is_inj H). exact X. Qed. Lemma is_iso_Epi {x y : C} (f : x --> y) (H : is_z_isomorphism f) : Epi x y. Proof. apply (make_Epi f (is_iso_isEpi f H)). Defined. (** Identity to isEpi and Epi. *) Lemma identity_isEpi {x : C} : isEpi (identity x). Proof. apply (is_iso_isEpi (identity x) (is_z_isomorphism_identity x)). Defined. Lemma identity_Epi {x : C} : Epi x x. Proof. exact (tpair _ (identity x) (identity_isEpi)). Defined. (** Composition of isEpis and Epis. *) Definition isEpi_comp {x y z : C} (f : x --> y) (g : y --> z) : isEpi f -> isEpi g -> isEpi (f · g). Proof. intros X X0. unfold isEpi. intros z0 g0 h X1. repeat rewrite <- assoc in X1. apply X in X1. apply X0 in X1. apply X1. Qed. Definition Epi_comp {x y z : C} (E1 : Epi x y) (E2 : Epi y z) : Epi x z := tpair _ (E1 · E2) (isEpi_comp E1 E2 (pr2 E1) (pr2 E2)). (** If precomposition of g with f is an epi, then g is an epi. *) Definition isEpi_precomp {x y z : C} (f : x --> y) (g : y --> z) : isEpi (f · g) -> isEpi g. Proof. intros X. intros w φ ψ H. apply (maponpaths (λ g', f · g')) in H. repeat rewrite assoc in H. apply (X w _ _ H). Defined. Lemma isEpi_path {x y : C} (f1 f2 : x --> y) (e : f1 = f2) (isE : isEpi f1) : isEpi f2. Proof. induction e. exact isE. Qed. (** Transport of isEpi *) Lemma transport_target_isEpi {x y z : C} (f : x --> y) (E : isEpi f) (e : y = z) : isEpi (transportf (precategory_morphisms x) e f). Proof. induction e. apply E. Qed. Lemma transport_source_isEpi {x y z : C} (f : y --> z) (E : isEpi f) (e : y = x) : isEpi (transportf (λ x' : ob C, precategory_morphisms x' z) e f). Proof. induction e. apply E. Qed. End def_epi. Arguments isEpi [C] [x] [y] _. Lemma precomp_with_epi_isincl {C : category} {A B : ob C} {f : A --> B} : isEpi f -> ∏ c, isincl (@precomp_with _ _ _ f c). Proof. intros is_epi ? ?. apply invproofirrelevance. intros z w. apply subtypePath; [intros ? ?; apply homset_property|]. apply (is_epi _ (hfiberpr1 _ _ z) (hfiberpr1 _ _ w)). exact (hfiberpr2 _ _ z @ !hfiberpr2 _ _ w). Qed. (** * Construction of the subcategory consisting of all epis. *) Section epis_subcategory. Variable C : category. Definition hsubtype_obs_isEpi : hsubtype C := (λ c : C, make_hProp _ isapropunit). Definition hsubtype_mors_isEpi : ∏ (a b : C), hsubtype (C⟦a, b⟧) := (λ a b : C, (fun f : C⟦a, b⟧ => make_hProp _ (isapropisEpi C C f))). Definition subprecategory_of_epis : sub_precategories C. Proof. use tpair. split. - exact hsubtype_obs_isEpi. - exact hsubtype_mors_isEpi. - cbn. unfold is_sub_precategory. cbn. split. + intros a tt. exact (identity_isEpi C). + apply isEpi_comp. Defined. Definition has_homsets_subprecategory_of_epis : has_homsets subprecategory_of_epis. Proof. intros a b. apply is_set_sub_precategory_morphisms. Qed. Definition subprecategory_of_epis_ob (c : C) : ob (subprecategory_of_epis) := tpair _ c tt. End epis_subcategory. (** * In functor categories epis can be constructed from pointwise epis *) Section epis_functorcategories. Lemma is_nat_trans_epi_from_pointwise_epis (C D : precategory) (hs : has_homsets D) (F G : ob (functor_precategory C D hs)) (α : F --> G) (H : ∏ a : ob C, isEpi (pr1 α a)) : isEpi α. Proof. intros G' β η H'. use (nat_trans_eq hs). intros x. set (H'' := nat_trans_eq_pointwise H' x). cbn in H''. apply (H x) in H''. exact H''. Qed. End epis_functorcategories. UniMath-20231010/UniMath/CategoryTheory/Equivalences/000077500000000000000000000000001451125700300222505ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Equivalences/CompositesAndInverses.v000066400000000000000000000377461451125700300267470ustar00rootroot00000000000000(** * Composition and inverses of (adjoint) equivalences of precategories *) (** ** Contents - Preliminaries - Composition - Inverses - 2 out of 3 property - Pairing equivalences *) (** Ported from UniMath/TypeTheory, could use more cleanup *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. (** ** Preliminaries *) Lemma is_z_iso_comp_is_z_iso {C : category} {a b c : ob C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) : is_z_isomorphism f -> is_z_isomorphism g -> is_z_isomorphism (f · g). Proof. intros Hf Hg. apply (is_z_iso_comp_of_is_z_isos f g Hf Hg). Defined. Lemma functor_is_z_iso_is_z_iso {C C' : category} (F : functor C C') {a b : ob C} (f : C ⟦a,b⟧) (fH : is_z_isomorphism f) : is_z_isomorphism (#F f). Proof. apply (z_iso_is_z_isomorphism (functor_on_z_iso F (make_z_iso' f fH))). Defined. Coercion left_adj_from_adj_equiv (X Y : category) (K : functor X Y) (HK : adj_equivalence_of_cats K) : is_left_adjoint K := pr1 HK. (** ** Equivalences *) Section A. Variables D1 D2 : category. Variable F : functor D1 D2. Variable GG : adj_equivalence_of_cats F. Let G : functor D2 D1 := right_adjoint GG. Let η := unit_from_left_adjoint GG. Let ε := counit_from_left_adjoint GG. Let ηinv a := z_iso_inv_from_z_iso (unit_pointwise_z_iso_from_adj_equivalence GG a). Let εinv a := z_iso_inv_from_z_iso (counit_pointwise_z_iso_from_adj_equivalence GG a). Lemma right_adj_equiv_is_ff : fully_faithful G. Proof. intros c d. set (inv := (fun f : D1 ⟦G c, G d⟧ => εinv _ · #F f · ε _ )). simpl in inv. apply (isweq_iso _ inv ). - intro f. simpl in f. unfold inv. assert (XR := nat_trans_ax ε). simpl in XR. rewrite <- assoc. etrans. apply maponpaths. apply XR. rewrite assoc. etrans. apply maponpaths_2. apply z_iso_after_z_iso_inv. apply id_left. - intro g. unfold inv. do 2 rewrite functor_comp. intermediate_path ((# G (inv_from_z_iso (counit_pointwise_z_iso_from_adj_equivalence GG c)) · ηinv _ ) · (η _ · # G (# F g)) · # G (ε d)). + do 4 rewrite <- assoc. apply maponpaths. do 2 rewrite assoc. etrans. 2: do 2 apply maponpaths_2; eapply pathsinv0, z_iso_after_z_iso_inv. refine (_ @ assoc _ _ _). exact (!id_left _). + assert (XR := nat_trans_ax η). simpl in XR. rewrite <- XR. clear XR. do 3 rewrite <- assoc. etrans. do 3 apply maponpaths. apply triangle_id_right_ad. rewrite id_right. rewrite assoc. etrans. 2: apply id_left. apply maponpaths_2. etrans. apply maponpaths_2. apply functor_on_inv_from_z_iso. assert (XR := triangle_id_right_ad (pr2 (pr1 GG))); simpl in XR. unfold ηinv; simpl. pose (XRR := maponpaths pr1 (z_iso_inv_of_z_iso_comp _ _ _ (unit_pointwise_z_iso_from_adj_equivalence GG ((adj_equivalence_inv GG) c)) (functor_on_z_iso G (counit_pointwise_z_iso_from_adj_equivalence GG c)) )). simpl in XRR. etrans. apply (! XRR). clear XRR. apply pathsinv0, inv_z_iso_unique'. cbn. unfold precomp_with. rewrite id_right. apply XR. Defined. Lemma right_adj_equiv_is_ess_sur : essentially_surjective G. Proof. intro d. apply hinhpr. exists (F d). exact (ηinv d). Defined. End A. (** ** Composition *) Section eqv_comp. Context {A B C : category} {F : functor A B} {F' : functor B C}. Hypothesis HF : adj_equivalence_of_cats F. Hypothesis HF' : adj_equivalence_of_cats F'. Definition comp_adj_equivalence_of_cats : adj_equivalence_of_cats (functor_composite F F'). Proof. exists (is_left_adjoint_functor_composite HF HF'). use tpair. - intro. apply is_z_iso_comp_is_z_iso. + apply (pr1 (pr2 HF)). + simpl. refine (eqweqmap (maponpaths is_z_isomorphism _) _). refine (_ @ !id_right _). exact (!id_left _). apply functor_is_z_iso_is_z_iso, (pr1 (pr2 HF')). - cbn. intro. apply is_z_iso_comp_is_z_iso. + refine (eqweqmap (maponpaths is_z_isomorphism _) _). refine (_ @ !id_left _). refine (_ @ !id_left _). exact (!id_right _). apply functor_is_z_iso_is_z_iso, (pr2 (pr2 HF)). + apply (pr2 (pr2 HF')). Defined. End eqv_comp. (** ** Inverses *) Section eqv_inv. Local Definition nat_z_iso_to_pointwise_z_iso {A B : category} {F G : functor A B} (n : nat_z_iso F G) (x : ob A) : z_iso (F x) (G x) := make_z_iso' _ (pr2 n x). Local Lemma nat_z_iso_inv_after_nat_z_iso {A B : category} {F G : functor A B} (n : nat_z_iso F G) : ∏ x, (nat_z_iso_to_pointwise_z_iso n) x · (nat_z_iso_inv n) x = identity _. Proof. intro; apply z_iso_inv_after_z_iso. Qed. Context {A B : category} {F : functor A B} (adEquivF : adj_equivalence_of_cats F). Local Notation η := (unit_from_left_adjoint adEquivF). Local Notation ε := (counit_from_left_adjoint adEquivF). Local Notation G := (right_adjoint (pr1 adEquivF)). Local Notation ηiso := (unit_nat_z_iso_from_adj_equivalence_of_cats adEquivF). Local Notation εiso := (counit_nat_z_iso_from_adj_equivalence_of_cats adEquivF). Lemma form_adjunction_inv : form_adjunction _ F (nat_z_iso_inv εiso) (nat_z_iso_inv ηiso). Proof. split. - intro b. (** Use the right triangle identity that we already know *) refine (_ @ triangle_id_right_ad (pr2 (pr1 adEquivF)) b). (** Transform it by precomposing with the inverse isos *) apply (pre_comp_with_z_iso_is_inj' (f:=#G (nat_z_iso_to_pointwise_z_iso εiso b))); [apply (functor_is_z_iso_is_z_iso G), z_iso_is_z_isomorphism |]. (** Cancel the isos *) unfold adjunit; unfold adjcounit. unfold pr2, pr1. rewrite assoc. rewrite <- functor_comp. unfold left_functor; unfold pr1. rewrite nat_z_iso_inv_after_nat_z_iso. rewrite functor_id. rewrite id_left. rewrite assoc. (** Again, precompose with the inverse iso *) use (pre_comp_with_z_iso_is_inj' (f:=(nat_z_iso_to_pointwise_z_iso ηiso (G b)))); [apply z_iso_is_z_isomorphism; rewrite z_iso_inv_after_z_iso|]. rewrite (nat_z_iso_inv_after_nat_z_iso ηiso). refine (!triangle_id_right_ad (pr2 (pr1 adEquivF)) _ @ _). refine (!id_left _ @ _). repeat rewrite assoc. do 2 rewrite <- assoc. (* This is inelegant... *) apply (maponpaths (fun f => f · _)). apply (!triangle_id_right_ad (pr2 (pr1 adEquivF)) _). - (** Same proof, just backwards *) intro a. refine (_ @ triangle_id_left_ad (pr2 (pr1 adEquivF)) a). apply (pre_comp_with_z_iso_is_inj' (f:=nat_z_iso_to_pointwise_z_iso εiso (F a))); [apply z_iso_is_z_isomorphism; rewrite z_iso_inv_after_z_iso|]. rewrite assoc. rewrite (nat_z_iso_inv_after_nat_z_iso εiso). rewrite id_left. apply (pre_comp_with_z_iso_is_inj' (f:=#F (nat_z_iso_to_pointwise_z_iso ηiso a))); [apply (functor_is_z_iso_is_z_iso F), z_iso_is_z_isomorphism |]. unfold adjunit; unfold adjcounit. unfold right_functor. unfold pr2, pr1. refine (_ @ !assoc _ _ _). refine (!functor_comp F _ _ @ _). rewrite (nat_z_iso_inv_after_nat_z_iso ηiso). rewrite functor_id. refine (!triangle_id_left_ad (pr2 (pr1 adEquivF)) _ @ _). refine (!id_left _ @ _). repeat rewrite assoc. do 2 rewrite <- assoc. (* This is inelegant... *) apply (maponpaths (fun f => f · _)). apply (!triangle_id_left_ad (pr2 (pr1 adEquivF)) _). Qed. Definition is_left_adjoint_inv : is_left_adjoint G. Proof. use tpair. - apply F. - use tpair. exists (pr1 (nat_z_iso_inv εiso)). exact (pr1 (nat_z_iso_inv ηiso)). apply form_adjunction_inv. Defined. Definition adj_equivalence_of_cats_inv : adj_equivalence_of_cats G. Proof. exists is_left_adjoint_inv. split; intro; unfold is_left_adjoint_inv; cbn. - apply (is_z_iso_inv_from_z_iso(_,,dirprod_pr2 (pr2 adEquivF) a)). - apply (is_z_iso_inv_from_z_iso(_,,dirprod_pr1 (pr2 adEquivF) b)). Defined. End eqv_inv. (** Closure under natural isomorphisms *) Definition nat_z_iso_equivalence_of_cats {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (α : F ⟹ G) (Hα : is_nat_z_iso α) (HF : adj_equivalence_of_cats F) : equivalence_of_cats C₁ C₂. Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact G. + exact (right_adjoint HF). + exact (nat_trans_comp _ _ _ (adjunit HF) (post_whisker α _)). + exact (nat_trans_comp _ _ _ (pre_whisker _ (nat_z_iso_inv (make_nat_z_iso _ _ α Hα))) (adjcounit HF)). - split. + intro x ; cbn. use is_z_iso_comp_of_is_z_isos. * apply (unit_nat_z_iso_from_adj_equivalence_of_cats HF). * apply functor_is_z_iso_is_z_iso. apply Hα. + intro x ; cbn. use is_z_iso_comp_of_is_z_isos. * apply (is_z_iso_inv_from_z_iso(_,,(Hα (pr1 (pr1 HF) x)))). * apply (counit_nat_z_iso_from_adj_equivalence_of_cats HF). Defined. Definition nat_iso_adj_equivalence_of_cats {C₁ C₂ : category} {F G : C₁ ⟶ C₂} (α : F ⟹ G) (Hα : is_nat_z_iso α) (HF : adj_equivalence_of_cats F) : adj_equivalence_of_cats G := adjointification (nat_z_iso_equivalence_of_cats α Hα HF). (** 2 out of 3 property *) Section TwoOutOfThree. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₂ ⟶ C₃) (H : C₁ ⟶ C₃) (ν : nat_z_iso (F ∙ G) H). Definition two_out_of_three_first (HG : adj_equivalence_of_cats G) (HH : adj_equivalence_of_cats H) : adj_equivalence_of_cats F. Proof. pose (ζ := make_nat_z_iso (F ∙ functor_identity _) (F ∙ (G ∙ right_adjoint HG)) _ (pre_whisker_on_nat_z_iso F (unit_nat_z_iso_from_adj_equivalence_of_cats HG) (pr2 (unit_nat_z_iso_from_adj_equivalence_of_cats HG)))). use (nat_iso_adj_equivalence_of_cats _ _ (comp_adj_equivalence_of_cats HH (adj_equivalence_of_cats_inv HG))). - exact (nat_trans_comp (H ∙ right_adjoint HG) ((F ∙ G) ∙ right_adjoint HG) _ (post_whisker (nat_z_iso_inv ν) (right_adjoint HG)) (nat_z_iso_inv ζ)). - use is_nat_z_iso_comp. + use post_whisker_z_iso_is_z_iso. apply (nat_z_iso_inv ν). + apply (nat_z_iso_inv ζ). Defined. Definition two_out_of_three_second (HF : adj_equivalence_of_cats F) (HH : adj_equivalence_of_cats H) : adj_equivalence_of_cats G. Proof. use (nat_iso_adj_equivalence_of_cats _ _ (comp_adj_equivalence_of_cats (adj_equivalence_of_cats_inv HF) HH)). - exact (nat_trans_comp (right_adjoint HF ∙ H) (right_adjoint HF ∙ F ∙ G) G (pre_whisker (right_adjoint HF) (nat_z_iso_inv ν)) (post_whisker (counit_nat_z_iso_from_adj_equivalence_of_cats HF) G)). - use is_nat_z_iso_comp. + apply (pre_whisker_on_nat_z_iso (right_adjoint HF) (nat_z_iso_inv ν)). apply (nat_z_iso_inv ν). + apply (post_whisker_z_iso_is_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats HF) G). apply (counit_nat_z_iso_from_adj_equivalence_of_cats HF). Defined. Definition two_out_of_three_comp (HF : adj_equivalence_of_cats F) (HG : adj_equivalence_of_cats G) : adj_equivalence_of_cats H. Proof. use (nat_iso_adj_equivalence_of_cats ν (pr2 ν)). exact (comp_adj_equivalence_of_cats HF HG). Defined. End TwoOutOfThree. (** Pairing equivalences *) Section PairEquivalence. Context {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} (HF : adj_equivalence_of_cats F) (HG : adj_equivalence_of_cats G). Let L : category_binproduct C₁ C₂ ⟶ category_binproduct C₁' C₂' := pair_functor F G. Let R : category_binproduct C₁' C₂' ⟶ category_binproduct C₁ C₂ := pair_functor (right_adjoint HF) (right_adjoint HG). Definition pair_equivalence_of_cats_unit_data : nat_trans_data (functor_identity _) (L ∙ R) := λ x, adjunit HF (pr1 x) ,, adjunit HG (pr2 x). Definition pair_equivalence_of_cats_unit_is_nat_trans : is_nat_trans _ _ pair_equivalence_of_cats_unit_data. Proof. intros x y f. use pathsdirprod ; cbn. - exact (nat_trans_ax (adjunit HF) _ _ (pr1 f)). - exact (nat_trans_ax (adjunit HG) _ _ (pr2 f)). Qed. Definition pair_equivalence_of_cats_unit : functor_identity (category_binproduct C₁ C₂) ⟹ L ∙ R. Proof. use make_nat_trans. - exact pair_equivalence_of_cats_unit_data. - exact pair_equivalence_of_cats_unit_is_nat_trans. Defined. Definition pair_equivalence_of_cats_counit_data : nat_trans_data (R ∙ L) (functor_identity _) := λ x, adjcounit HF (pr1 x) ,, adjcounit HG (pr2 x). Definition pair_equivalence_of_cats_counit_is_nat_trans : is_nat_trans _ _ pair_equivalence_of_cats_counit_data. Proof. intros x y f. use pathsdirprod ; cbn. - exact (nat_trans_ax (adjcounit HF) _ _ (pr1 f)). - exact (nat_trans_ax (adjcounit HG) _ _ (pr2 f)). Qed. Definition pair_equivalence_of_cats_counit : R ∙ L ⟹ functor_identity _. Proof. use make_nat_trans. - exact pair_equivalence_of_cats_counit_data. - exact pair_equivalence_of_cats_counit_is_nat_trans. Defined. Definition pair_equivalence_of_cats : equivalence_of_cats (category_binproduct C₁ C₂) (category_binproduct C₁' C₂'). Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact L. + exact R. + exact pair_equivalence_of_cats_unit. + exact pair_equivalence_of_cats_counit. - split. + intro x. use is_z_iso_binprod_z_iso. * exact (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (unit_nat_z_iso_from_adj_equivalence_of_cats HF) (pr1 x))). * exact (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (unit_nat_z_iso_from_adj_equivalence_of_cats HG) (pr2 x))). + intro x. use is_z_iso_binprod_z_iso. * exact (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats HF) (pr1 x))). * exact (z_iso_is_z_isomorphism (nat_z_iso_pointwise_z_iso (counit_nat_z_iso_from_adj_equivalence_of_cats HG) (pr2 x))). Defined. End PairEquivalence. Definition pair_adj_equivalence_of_cats {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} (HF : adj_equivalence_of_cats F) (HG : adj_equivalence_of_cats G) : adj_equivalence_of_cats (pair_functor F G) := adjointification (pair_equivalence_of_cats HF HG). UniMath-20231010/UniMath/CategoryTheory/Equivalences/Core.v000066400000000000000000000506251451125700300233370ustar00rootroot00000000000000(** ** Equivalence of categories Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) *) (** ** Contents: - Definition of (adjoint) equivalence of categories - Equivalence of categories yields weak equivalence of object types - A fully faithful and ess. surjective functor induces equivalence of precategories, if the source is a univalent_category. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** * Sloppy equivalence of categories *) Definition forms_equivalence {A B : category} (X : adjunction_data A B) (η := adjunit X) (ε := adjcounit X) : UU := (∏ a, is_z_isomorphism (η a)) × (∏ b, is_z_isomorphism (ε b)). Definition make_forms_equivalence {A B : category} (adjData : adjunction_data A B) (η := adjunit adjData) (ε := adjcounit adjData) (η_iso : ∏(a : A), is_z_isomorphism (η a)) (ε_iso : ∏(b : B), is_z_isomorphism (ε b)) : forms_equivalence adjData := (η_iso ,, ε_iso). Definition equivalence_of_cats (A B : category) : UU := ∑ (X : adjunction_data A B), forms_equivalence X. Coercion adjunction_data_from_equivalence_of_cats {A B} (X : equivalence_of_cats A B) : adjunction_data A B := pr1 X. Definition make_equivalence_of_cats {A B : category} (adjData : adjunction_data A B) (eqvProp : forms_equivalence adjData) : equivalence_of_cats A B := (adjData ,, eqvProp). Definition adjunitiso {A B : category} (X : equivalence_of_cats A B) (a : A) : z_iso a (right_functor X (left_functor X a)). Proof. exists (adjunit X a). exact (pr1 (pr2 X) a). Defined. Definition adjcounitiso {A B : category} (X : equivalence_of_cats A B) (b : B) : z_iso (left_functor X (right_functor X b)) b. Proof. exists (adjcounit X b). exact (pr2 (pr2 X) b). Defined. (** * Equivalence of (pre)categories *) Definition adj_equivalence_of_cats {A B : category} (F : functor A B) : UU := ∑ (H : is_left_adjoint F), forms_equivalence H. Definition adj_from_equiv (D1 D2 : category) (F : functor D1 D2): adj_equivalence_of_cats F → is_left_adjoint F := λ x, pr1 x. Coercion adj_from_equiv : adj_equivalence_of_cats >-> is_left_adjoint. Definition make_adj_equivalence_of_cats {A B : category} (F : functor A B) (G : functor B A) η ε (H1 : form_adjunction F G η ε) (H2 : forms_equivalence ((F,,G,,η,,ε))) : adj_equivalence_of_cats F. Proof. use tpair. - exists G. exists (η,,ε). apply H1. - apply H2. Defined. Definition adj_equivalence_inv {A B : category} {F : functor A B} (HF : adj_equivalence_of_cats F) : functor B A := right_adjoint HF. Local Notation "HF ^^-1" := (adj_equivalence_inv HF)(at level 3). Section Accessors. Context {A B : category} {F : functor A B} (HF : adj_equivalence_of_cats F). Definition unit_pointwise_z_iso_from_adj_equivalence : ∏ a, z_iso a (HF^^-1 (F a)). Proof. intro a. exists (unit_from_left_adjoint HF a). exact (pr1 (pr2 HF) a). Defined. Definition counit_pointwise_z_iso_from_adj_equivalence : ∏ b, z_iso (F (HF^^-1 b)) b. Proof. intro b. exists (counit_from_left_adjoint HF b). exact (pr2 (pr2 HF) b). Defined. Definition unit_nat_z_iso_from_adj_equivalence_of_cats : nat_z_iso (functor_identity A) (functor_composite F (right_adjoint HF)). Proof. exists (unit_from_left_adjoint HF). exact (dirprod_pr1 (pr2 HF)). Defined. Definition counit_nat_z_iso_from_adj_equivalence_of_cats : nat_z_iso (functor_composite (right_adjoint HF) F) (functor_identity B). Proof. exists (counit_from_left_adjoint HF). exact (dirprod_pr2 (pr2 HF)). Defined. Definition unit_z_iso_from_adj_equivalence_of_cats : z_iso (C:=[A, A]) (functor_identity A) (functor_composite F (right_adjoint HF)). Proof. exists (unit_from_left_adjoint HF). apply nat_trafo_z_iso_if_pointwise_z_iso. intro c. apply (pr1 (pr2 HF)). Defined. Definition counit_z_iso_from_adj_equivalence_of_cats : z_iso (C:=[B, B]) (functor_composite (right_adjoint HF) F) (functor_identity B). Proof. exists (counit_from_left_adjoint HF). apply nat_trafo_z_iso_if_pointwise_z_iso. intro c. apply (pr2 (pr2 HF)). Defined. End Accessors. Section AdjEquiv. Definition adj_equiv (A B : category) : UU := ∑ F : functor A B, adj_equivalence_of_cats F. Coercion left_adjequiv (A B : category) (F : adj_equiv A B) : functor A B := pr1 F. Coercion adj_equiv_of_cats_from_adj {A B : category} (E : adj_equiv A B) : adj_equivalence_of_cats E := pr2 E. Coercion adj_from_adj_equiv {A B} (F : adj_equiv A B) : adjunction A B. Proof. use make_adjunction. use(make_adjunction_data F). - exact(right_adjoint F). - exact(adjunit F). - exact(adjcounit F). - use make_form_adjunction. + apply triangle_id_left_ad. + apply triangle_id_right_ad. Defined. Coercion equiv_from_adj_equiv {A B} (F : adj_equiv A B) : equivalence_of_cats A B. Proof. use make_equivalence_of_cats. use(make_adjunction_data F). - exact(right_adjoint F). - exact(adjunit F). - exact(adjcounit F). - use make_forms_equivalence. + apply unit_pointwise_z_iso_from_adj_equivalence. + apply counit_pointwise_z_iso_from_adj_equivalence. Defined. End AdjEquiv. (** * Adjointification of a sloppy equivalence *) (** ** One triangle equality is enough *) (** Proof ported from Peter Lumsdaine's proof of the analog for displayed categories see UniMath/TypeTheory *) Lemma triangle_2_from_1 {C D} (A : adjunction_data C D) (E : forms_equivalence A) : triangle_1_statement A -> triangle_2_statement A. Proof. destruct A as [F [G [η ε]]]. destruct E as [Hη Hε]; cbn in Hη, Hε. unfold triangle_1_statement, triangle_2_statement; cbn. intros T1 x. assert (etaH := nat_trans_ax η); cbn in etaH. assert (epsH := nat_trans_ax ε); cbn in epsH. (* Algebraically, this goes as follows: η G ; G ε = G ε^ ; η^ G ; η G ; G ε ; η G ; G ε [by inverses, 1] = G ε^ ; η^ G ; η G ; η G F G ; G F G ε ; G ε [by naturality, 2] = G ε^ ; η^ G ; η G ; η G F G ; G ε F G ; G ε [by naturality, 3] = G ε^ ; η^ G ; η G ; G F η G ; G ε F G ; G ε [by naturality, 4] = G ε^ ; η^ G ; η G ; G (F η ; ε F ) G ; G ε [by functoriality, 5] = G ε^ ; η^ G ; η G ; G ε [by T1, 6] = 1 [by inverses, 7] *) apply (invmaponpathsweq (make_weq _ (z_iso_comp_left_isweq (_,,Hη _ ) _ ))). cbn. apply pathsinv0. etrans. apply id_left. etrans. apply (! id_right _ ). apply pathsinv0. apply (z_iso_inv_to_left _ _ _ (_,,Hη _ )). apply (invmaponpathsweq (make_weq _ (z_iso_comp_left_isweq (functor_on_z_iso G (_,,Hε _ )) _ ))). cbn. set (XR' := functor_on_z_iso G (_,,Hε x)). cbn in XR'. apply pathsinv0. etrans. apply id_left. etrans. apply (! id_right _ ). apply pathsinv0. apply (z_iso_inv_to_left _ _ _ XR'). unfold XR'; clear XR'. repeat rewrite assoc. set (i := inv_from_z_iso (functor_on_z_iso G (ε x ,, Hε x))). set (i' := inv_from_z_iso (η (G x) ,, Hη (G x))). etrans. apply cancel_postcomposition. repeat rewrite <- assoc. rewrite etaH. apply idpath. etrans. repeat rewrite <- assoc. rewrite <- functor_comp. rewrite (epsH). rewrite functor_comp. apply idpath. etrans. apply maponpaths. apply maponpaths. repeat rewrite assoc. rewrite etaH. apply cancel_postcomposition. rewrite <- assoc. rewrite <- functor_comp. rewrite T1. rewrite functor_id. apply id_right. etrans. apply maponpaths. rewrite assoc. apply cancel_postcomposition. use (z_iso_after_z_iso_inv (_ ,, Hη _ )). rewrite id_left. apply (z_iso_after_z_iso_inv ). Defined. (** ** Adjointification *) Section adjointification. Context {C D : category} (E : equivalence_of_cats C D). Let F : functor C D := left_functor E. Let G : functor D C := right_functor E. Let ηntiso : z_iso (C:= [C,C]) (functor_identity _ ) (F ∙ G). Proof. use z_iso_from_nat_z_iso. exists (adjunit E). intro c. apply (pr1 (pr2 E)). Defined. Let εntiso : z_iso (C:= [D,D]) (G ∙ F) (functor_identity _ ). Proof. use z_iso_from_nat_z_iso. exists (adjcounit E). intro c. apply (pr2 (pr2 E)). Defined. Let FF : functor [D,D] [C, D] := (pre_comp_functor F). Let GG : functor [C, D] [D, D] := (pre_comp_functor G). Definition ε'ntiso : z_iso (C:= [D,D]) (G ∙ F) (functor_identity _ ). Proof. eapply z_iso_comp. set (XR := functor_on_z_iso GG (functor_on_z_iso FF εntiso)). set (XR':= z_iso_inv_from_z_iso XR). apply XR'. eapply z_iso_comp. 2: apply εntiso. set (XR := functor_on_z_iso (pre_comp_functor G) (z_iso_inv_from_z_iso ηntiso)). set (XR':= functor_on_z_iso (post_comp_functor F) XR). apply XR'. Defined. Definition adjointification_triangle_1 : triangle_1_statement (F,,G,, pr1 ηntiso,, pr1 ε'ntiso). Proof. intro x. cbn. repeat rewrite assoc. assert (ηinvH := nat_trans_ax (inv_from_z_iso ηntiso)). cbn in ηinvH. simpl in ηinvH. assert (εinvH := nat_trans_ax (inv_from_z_iso εntiso)). cbn in εinvH. simpl in εinvH. etrans. apply cancel_postcomposition. apply cancel_postcomposition. etrans. apply maponpaths. apply (! (id_right _ )). rewrite id_right. apply εinvH. repeat rewrite assoc. rewrite assoc4. apply id_conjugation. - etrans. eapply pathsinv0. apply functor_comp. etrans. apply maponpaths. etrans. apply maponpaths. eapply pathsinv0. apply id_right. rewrite id_right. apply ηinvH. etrans. apply maponpaths. apply (nat_trans_inv_pointwise_inv_before_z_iso _ _ _ _ _ ηntiso (pr2 ηntiso)). apply functor_id. - assert (XR := nat_trans_inv_pointwise_inv_before_z_iso _ _ _ _ _ εntiso (pr2 εntiso)). cbn in XR. etrans. apply cancel_postcomposition. eapply pathsinv0. apply id_right. rewrite id_right. apply XR. Qed. Lemma adjointification_forms_equivalence : forms_equivalence (F,, G,, pr1 ηntiso,, pr1 ε'ntiso). Proof. split. - cbn. apply (nat_trafo_pointwise_z_iso_if_z_iso _ ηntiso (pr2 ηntiso)). - cbn. apply (nat_trafo_pointwise_z_iso_if_z_iso _ ε'ntiso (pr2 ε'ntiso)). Qed. Definition adjointification_triangle_2 : triangle_2_statement (F,,G,,pr1 ηntiso,,pr1 ε'ntiso). Proof. use triangle_2_from_1. - apply adjointification_forms_equivalence. - apply adjointification_triangle_1. Qed. Definition adjointification : adj_equivalence_of_cats F. Proof. use make_adj_equivalence_of_cats. - exact G. - apply ηntiso. - apply ε'ntiso. - exists adjointification_triangle_1. apply adjointification_triangle_2. - apply adjointification_forms_equivalence. Defined. End adjointification. (** * Identity functor is an adjoint equivalence *) Lemma identity_functor_is_adj_equivalence {A : category} : adj_equivalence_of_cats (functor_identity A). Proof. use tpair. - exact is_left_adjoint_functor_identity. - now split; intros a; apply identity_is_z_iso. Defined. (** * Equivalence of categories yields equivalence of object types *) (** Fundamentally needed that both source and target are categories *) Lemma adj_equiv_of_cats_is_weq_of_objects (A B : category) (HA : is_univalent A) (HB : is_univalent B) (F : [A, B]) (HF : adj_equivalence_of_cats F) : isweq (pr1 (pr1 F)). Proof. set (G := right_adjoint HF). set (et := unit_z_iso_from_adj_equivalence_of_cats HF). set (ep := counit_z_iso_from_adj_equivalence_of_cats HF). set (AAcat := is_univalent_functor_category A _ HA). set (BBcat := is_univalent_functor_category B _ HB). set (Et := isotoid _ AAcat et). set (Ep := isotoid _ BBcat ep). apply (isweq_iso _ (λ b, pr1 (right_adjoint HF) b)); intro a. apply (!toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ Et)) a). now apply (toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ Ep))). Defined. Definition weq_on_objects_from_adj_equiv_of_cats (A B : category) (HA : is_univalent A) (HB : is_univalent B) (F : ob [A, B]) (HF : adj_equivalence_of_cats F) : weq (ob A) (ob B). Proof. exists (pr1 (pr1 F)). now apply (@adj_equiv_of_cats_is_weq_of_objects _ _ HA). Defined. (** If the source precategory is a univalent_category, then being split essentially surjective is a proposition *) Lemma isaprop_sigma_z_iso (A B : category) (HA : is_univalent A) (F : functor A B) (HF : fully_faithful F) : ∏ b : ob B, isaprop (∑ a : ob A, z_iso (F a) b). Proof. intro b. apply invproofirrelevance. intros x x'; destruct x as [a f]; destruct x' as [a' f']. set (fminusf := z_iso_comp f (z_iso_inv_from_z_iso f')). set (g := iso_from_fully_faithful_reflection HF fminusf). apply (two_arg_paths_f (B:=λ a', z_iso (F a') b) (isotoid _ HA g)). intermediate_path (z_iso_comp (z_iso_inv_from_z_iso (functor_on_z_iso F (idtoiso (isotoid _ HA g)))) f). - generalize (isotoid _ HA g). intro p0; destruct p0. rewrite <- functor_on_z_iso_inv. simpl. rewrite z_iso_inv_of_z_iso_id. apply z_iso_eq. simpl; rewrite functor_id. rewrite id_left. apply idpath. - rewrite idtoiso_isotoid. unfold g; clear g. unfold fminusf; clear fminusf. assert (HFg : functor_on_z_iso F (iso_from_fully_faithful_reflection HF (z_iso_comp f (z_iso_inv_from_z_iso f'))) = z_iso_comp f (z_iso_inv_from_z_iso f')). + generalize (z_iso_comp f (z_iso_inv_from_z_iso f')). intro h. apply z_iso_eq; simpl. set (H3:= homotweqinvweq (weq_from_fully_faithful HF a a')). simpl in H3. unfold fully_faithful_inv_hom. unfold invweq; simpl. rewrite H3; apply idpath. + rewrite HFg. rewrite z_iso_inv_of_z_iso_comp. apply z_iso_eq; simpl. repeat rewrite <- assoc. rewrite z_iso_after_z_iso_inv. rewrite id_right. set (H := z_iso_inv_z_iso_inv _ _ f'). now apply (base_paths _ _ H). Qed. Lemma isaprop_split_essentially_surjective (A B : category) (HA : is_univalent A) (F : functor A B) (HF : fully_faithful F) : isaprop (split_essentially_surjective F). Proof. apply impred; intro. now apply isaprop_sigma_z_iso. Qed. (** If the source precategory is a univalent_category, then essential surjectivity of a fully faithful functor implies split essential surjectivity. *) Lemma ff_essentially_surjective_to_split (A B : category) (HA : is_univalent A) (F : functor A B) (HF : fully_faithful F) (HF' : essentially_surjective F) : split_essentially_surjective F. Proof. intro b. apply (squash_to_prop (HF' b)). - apply isaprop_sigma_z_iso; assumption. - exact (idfun _). Defined. (** * From full faithfullness and ess surj to equivalence *) (** A fully faithful and ess. surjective functor induces an equivalence of precategories, if the source is a univalent_category. *) Section from_fully_faithful_and_ess_surj_to_equivalence. Variables A B : category. Hypothesis HA : is_univalent A. Variable F : functor A B. Hypothesis HF : fully_faithful F. Hypothesis HS : essentially_surjective F. (** Definition of a functor which will later be the right adjoint. *) Definition rad_ob : ob B -> ob A. Proof. use split_essentially_surjective_inv_on_obj. - exact F. - apply ff_essentially_surjective_to_split; assumption. Defined. (** Definition of the epsilon transformation *) Definition rad_eps (b : ob B) : z_iso (F (rad_ob b)) b. Proof. apply (pr2 (HS b (tpair (λ x, isaprop x) _ (isaprop_sigma_z_iso A B HA F HF b)) (λ x, x))). Defined. (** The right adjoint on morphisms *) Definition rad_mor (b b' : ob B) (g : b --> b') : rad_ob b --> rad_ob b'. Proof. set (epsgebs' := rad_eps b · g · z_iso_inv_from_z_iso (rad_eps b')). set (Gg := fully_faithful_inv_hom HF (rad_ob b) _ epsgebs'). exact Gg. Defined. (** Definition of the eta transformation *) Definition rad_eta (a : ob A) : a --> rad_ob (F a). Proof. set (epsFa := inv_from_z_iso (rad_eps (F a))). exact (fully_faithful_inv_hom HF _ _ epsFa). Defined. (** Above data specifies a functor *) Definition rad_functor_data : functor_data B A. Proof. exists rad_ob. exact rad_mor. Defined. Lemma rad_is_functor : is_functor rad_functor_data. Proof. split. simpl. intro b. simpl. unfold rad_mor. simpl. rewrite id_right, z_iso_inv_after_z_iso, fully_faithful_inv_identity. apply idpath. intros a b c f g. simpl. unfold rad_mor; simpl. rewrite <- fully_faithful_inv_comp. apply maponpaths. repeat rewrite <- assoc. repeat apply maponpaths. rewrite assoc. rewrite z_iso_after_z_iso_inv, id_left. apply idpath. Qed. Definition rad : ob [B, A]. Proof. exists rad_functor_data. apply rad_is_functor. Defined. (** Epsilon is natural *) Lemma rad_eps_is_nat_trans : is_nat_trans (functor_composite rad F) (functor_identity B) (λ b, rad_eps b). Proof. unfold is_nat_trans. simpl. intros b b' g. unfold rad_mor; unfold fully_faithful_inv_hom. set (H3 := homotweqinvweq (weq_from_fully_faithful HF (pr1 rad b) (pr1 rad b'))). simpl in *. rewrite H3; clear H3. repeat rewrite <- assoc. rewrite z_iso_after_z_iso_inv, id_right. apply idpath. Qed. Definition rad_eps_trans : nat_trans _ _ := tpair (is_nat_trans _ _ ) _ rad_eps_is_nat_trans. (** Eta is natural *) Ltac inv_functor x y := let H:=fresh in set (H:= homotweqinvweq (weq_from_fully_faithful HF x y)); simpl in H; unfold fully_faithful_inv_hom; simpl; rewrite H; clear H. Lemma rad_eta_is_nat_trans : is_nat_trans (functor_identity A) (functor_composite F rad) (λ a, rad_eta a). Proof. unfold is_nat_trans. simpl. intros a a' f. unfold rad_mor. simpl. apply (invmaponpathsweq (weq_from_fully_faithful HF a (rad_ob (F a')))). simpl; repeat rewrite functor_comp. unfold rad_eta. set (HHH := rad_eps_is_nat_trans (F a) (F a')). simpl in HHH; rewrite <- HHH; clear HHH. inv_functor a' (rad_ob (F a')). inv_functor a (rad_ob (F a)). inv_functor (rad_ob (F a)) (rad_ob (F a')). unfold rad_mor. simpl. repeat rewrite <- assoc. rewrite z_iso_inv_after_z_iso. rewrite id_right. inv_functor (rad_ob (F a)) (rad_ob (F a')). repeat rewrite assoc. rewrite z_iso_after_z_iso_inv. rewrite id_left. apply idpath. Qed. Definition rad_eta_trans : nat_trans _ _ := tpair (is_nat_trans _ _ ) _ rad_eta_is_nat_trans. (** The data [rad], [eta], [eps] forms an adjunction *) Lemma rad_form_adjunction : form_adjunction F rad rad_eta_trans rad_eps_trans. Proof. split; simpl. - intro a. cbn. unfold rad_eta. inv_functor a (rad_ob (F a)). apply z_iso_after_z_iso_inv. - intro b. apply (invmaponpathsweq (weq_from_fully_faithful HF (rad_ob b) (rad_ob b))). simpl; rewrite functor_comp. unfold rad_eta. inv_functor (rad_ob b) (rad_ob (F (rad_ob b))). unfold rad_mor. inv_functor (rad_ob (F (rad_ob b))) (rad_ob b). repeat rewrite assoc. rewrite z_iso_after_z_iso_inv. rewrite <- assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left. rewrite functor_id. apply idpath. Qed. Definition rad_are_adjoints : are_adjoints F rad. Proof. exists (make_dirprod rad_eta_trans rad_eps_trans). apply rad_form_adjunction. Defined. Definition rad_is_left_adjoint : is_left_adjoint F. Proof. exists rad. apply rad_are_adjoints. Defined. (** Get an equivalence of precategories: remains to show that [eta], [eps] are isos *) Lemma rad_equivalence_of_cats : adj_equivalence_of_cats F. Proof. exists rad_is_left_adjoint. split; simpl. intro a. unfold rad_eta. set (H := fully_faithful_reflects_iso_proof _ _ _ HF a (rad_ob (F a))). simpl in *. set (H' := H (z_iso_inv_from_z_iso (rad_eps (F a)))). change ((fully_faithful_inv_hom HF a (rad_ob (F a)) (inv_from_z_iso (rad_eps (F a))))) with (fully_faithful_inv_hom HF a (rad_ob (F a)) (z_iso_inv_from_z_iso (rad_eps (F a)))). apply H'. intro b. apply (pr2 (rad_eps b)). Defined. End from_fully_faithful_and_ess_surj_to_equivalence. UniMath-20231010/UniMath/CategoryTheory/Equivalences/FullyFaithful.v000066400000000000000000000141251451125700300252200ustar00rootroot00000000000000(** * Fully faithful functors and equivalences Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) Revised by: Marco Maggesi (November 2017), Langston Barrett (April 2018) *) (** ** Contents : - Fully faithful functor from an equivalence - Functor from an equivalence is essentially surjective - Fully faithful essentially surjective functors preserve all [hProp]s on hom-types *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Local Open Scope cat. (** ** Fully faithful functor from an equivalence *) Section from_equiv_to_fully_faithful. Variables A B : category. Variable F : A ⟶ B. Variable H : adj_equivalence_of_cats F. Local Definition G : B ⟶ A := adj_equivalence_inv H. Local Definition eta : ∏ a : A, z_iso a (G (F a)) := unit_pointwise_z_iso_from_adj_equivalence H. Local Definition eps : ∏ b : B, z_iso (F (G b)) b := counit_pointwise_z_iso_from_adj_equivalence H. Definition inverse {a b} (g : B⟦F a, F b⟧) : A⟦a, b⟧ := eta a · #G g · inv_from_z_iso (eta b). Lemma inverse_is_inverse_1 a b (f : a --> b) : inverse (#F f) = f. Proof. unfold inverse. set (H' := nat_trans_ax (adjunit (pr1 H))). simpl in H'; rewrite <- H'; clear H'; simpl in *. rewrite <- assoc. intermediate_path (f · identity _). apply maponpaths. set (H' := z_iso_inv_after_z_iso (eta b)). apply H'. rewrite id_right. apply idpath. Qed. Lemma triangle_id_inverse (a : A) : z_iso_inv_from_z_iso (functor_on_z_iso F (eta a)) = eps (F a). Proof. apply z_iso_eq. simpl. match goal with | [ |- ?x = ?y ] => transitivity (x · identity _) end. apply pathsinv0, id_right. apply z_iso_inv_on_right. set (H' := triangle_id_left_ad (pr2 (pr1 H)) a). apply pathsinv0. apply H'. Qed. Lemma triangle_id_inverse' (a : A) : inv_from_z_iso (functor_on_z_iso F (eta a)) = eps (F a). Proof. apply (base_paths _ _ (triangle_id_inverse a)). Qed. Lemma inverse_is_inverse_2 a b (g : F a --> F b) : #F (inverse g) = g. Proof. unfold inverse. repeat rewrite functor_comp. rewrite functor_on_inv_from_z_iso. simpl. rewrite triangle_id_inverse'. rewrite <- assoc. set (H' := nat_trans_ax (adjcounit (pr1 H))). simpl in H'; rewrite H'; clear H'. rewrite assoc. set (H' := pathsinv0 (triangle_id_left_ad (pr2 (pr1 H)) a)). match goal with [|- ?f · ?g = ?h] => assert (H'' : identity _ = f) end. - simpl in *; apply H'. - rewrite <- H''. rewrite id_left. apply idpath. Qed. Lemma fully_faithful_from_equivalence : fully_faithful F. Proof. unfold fully_faithful. intros a b. apply (isweq_iso _ (@inverse a b)). - apply inverse_is_inverse_1. - apply inverse_is_inverse_2. Qed. (** ** Functor from an equivalence is essentially surjective *) Lemma functor_from_equivalence_is_essentially_surjective : essentially_surjective F. Proof. unfold essentially_surjective. intros b; apply hinhpr. exists (G b). apply counit_pointwise_z_iso_from_adj_equivalence. Defined. End from_equiv_to_fully_faithful. (** ** Fully faithful essentially surjective functors preserve all [hProp]s on hom-types *) Section HomtypeProperties. Context {C D : category} (F : functor C D). (** For every hom-type in D, there merely exists a hom-type in C to which it is equivalent. For split essentially surjective functors, this could be strengthened to an untruncated version. *) (* TODO: better name? *) Lemma ff_es_homtype_weq (FFF : fully_faithful F) (FES : essentially_surjective F) : (∏ d d' : ob D, ∥ ∑ c c' : ob C, C⟦c, c'⟧ ≃ D⟦d, d'⟧ ∥). Proof. intros d d'. (** Obtain the c, c' for which F c ≅ d and F c' ≅ d'. *) apply (squash_to_prop (FES d)); [apply isapropishinh|]; intros c. apply (squash_to_prop (FES d')); [apply isapropishinh|]; intros c'. apply hinhpr. exists (pr1 c), (pr1 c'). (** Homsets between isomorphic objects are equivalent. *) intermediate_weq (D ⟦ F (pr1 c), F (pr1 c') ⟧). - apply weq_from_fully_faithful; assumption. - intermediate_weq (D ⟦ F (pr1 c), d' ⟧). + eapply make_weq. apply z_iso_comp_left_isweq. Unshelve. exact (pr2 c'). + eapply make_weq. apply z_iso_comp_right_weq. Unshelve. exact (z_iso_inv_from_is_z_iso (pr1 (pr2 c)) (pr2 (pr2 c))). Defined. Lemma ff_es_homtype_property (FFF : fully_faithful F) (FES : essentially_surjective F) (P : UU → hProp) (prop : ∏ a b : ob C, P (C⟦a, b⟧)) : (∏ a b : ob D, P (D⟦a, b⟧)). Proof. intros a b. apply (squash_to_prop (ff_es_homtype_weq FFF FES a b)); [apply propproperty|]; intros H. use transportf. - exact (P (C⟦(pr1 H), (pr1 (pr2 H))⟧)). - apply maponpaths. apply weqtopaths. exact (pr2 (pr2 H)). - apply prop. Defined. (** Corollary: Equivalences preserve [hProp]s on hom-types. *) Corollary equivalence_homtype_property (E : adj_equivalence_of_cats F) (P : UU → hProp) (prop : ∏ a b : ob C, P (C⟦a, b⟧)) : (∏ a b : ob D, P (D⟦a, b⟧)). Proof. apply ff_es_homtype_property. - apply fully_faithful_from_equivalence; assumption. - apply functor_from_equivalence_is_essentially_surjective; assumption. - assumption. Defined. (** Corollary: Fully faithful essentially surjective functors preserve the property of having hom-sets. *) Corollary ff_es_preserves_homsets (FFF : fully_faithful F) (FES : essentially_surjective F) (hsC : has_homsets C) : has_homsets D. Proof. refine (ff_es_homtype_property FFF FES (λ t, make_hProp _ (isapropisaset t)) _). apply hsC. Defined. (** Other applications: ff/es functors preserve univalence, being a groupoid, merely having any type of (co)limits, etc. *) End HomtypeProperties. UniMath-20231010/UniMath/CategoryTheory/ExactCategories/000077500000000000000000000000001451125700300226765ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/ExactCategories/ExactCategories.v000066400000000000000000003110701451125700300261410ustar00rootroot00000000000000(** * Exact categories *) (** ** Contents - Preliminaries - Diagram chasing lemmas - The definition of exact category - Equivalence with Quillen's definition - The exact category structure induced on X by a function X -> ob M, where M is an exact category. *) Require Export UniMath.Foundations.All. Require Export UniMath.MoreFoundations.Notations. Require Export UniMath.MoreFoundations.PartA. Require Export UniMath.Algebra.BinaryOperations. Require Export UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Export UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Export UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.Core.NaturalTransformations. Require Export UniMath.CategoryTheory.Monics. Require Export UniMath.CategoryTheory.Epis. Require Export UniMath.CategoryTheory.limits.zero. Require Export UniMath.CategoryTheory.limits.kernels. Require Export UniMath.CategoryTheory.limits.cokernels. Require Export UniMath.CategoryTheory.limits.binproducts. Require Export UniMath.CategoryTheory.limits.bincoproducts. Require Export UniMath.CategoryTheory.limits.pullbacks. Require Export UniMath.CategoryTheory.limits.pushouts. Require Export UniMath.CategoryTheory.limits.BinDirectSums. Require Export UniMath.CategoryTheory.limits.Opp. Require Export UniMath.CategoryTheory.CategoriesWithBinOps. Require Export UniMath.CategoryTheory.opp_precat. Require Export UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Export UniMath.CategoryTheory.PreAdditive. Require Export UniMath.CategoryTheory.Morphisms. Require Export UniMath.CategoryTheory.Additive. Require Export UniMath.CategoryTheory.Subcategory.Full. Require Export UniMath.MoreFoundations.Propositions. Local Arguments grinv {_}. Local Open Scope logic. Local Open Scope cat. Local Definition hom (C:precategory_data) : ob C -> ob C -> UU := λ c c', precategory_morphisms c c'. Local Definition Hom (C : category) : ob C -> ob C -> hSet := λ c c', make_hSet _ (homset_property C c c'). Local Definition Hom_add (C : PreAdditive) : ob C -> ob C -> abgr := λ c c', (@to_abgr C c c'). (* move upstream, when ready *) Section InvestigateNotations. Context (M : PreAdditive) (x y z:M) (f g : hom M x y) (h k : Hom_add M y z). Local Open Scope abgrcat. Goal empty. set (Q := h+k). set (r := -g). set (t := f-g). set (p := f·h + (h∘f) · 1). set (o := (h + h) · 1 = h). set (s := f+g). set (u := f·1). set (v := f·0·h). (* Set Printing All. *) Abort. End InvestigateNotations. Section Categories. Definition isPushout' {M:category} {a b c d : M} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) : hProp. Proof. exists (∑ (H : f · in1 = g · in2), isPushout f g in1 in2 H). abstract ( (* this abstraction is important! *) apply isaproptotal2 ; [ intros H; apply isaprop_isPushout | intros H H' po po'; apply homset_property ]) using _P_. Defined. Definition isPullback' {M:category} {a b c d : M} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) : hProp. Proof. exists (∑ (H : p1 · f = p2· g), isPullback (*f g p1 p2*) H). exact (_P_ (oppositeCategory M) a b c d f g p1 p2). Defined. Lemma isPullback'_up_to_z_iso {M:category} {a b c d d' : M} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (i : z_iso d' d) : isPullback' f g p1 p2 -> isPullback' f g (i·p1) (i·p2). Proof. intros [e pb]. use tpair. - abstract (rewrite 2 assoc'; apply maponpaths; exact e) using _P_. - cbn beta. intros T r s eq. assert (Q := pb T r s eq). use (iscontrweqf _ Q); clear Q. use weqtotal2. { apply z_iso_comp_left_weq. exact (z_iso_inv i). } { intros h. cbn beta. apply weqiff. { cbn. rewrite 2 (assoc' h). rewrite 2 (assoc _ i). rewrite z_iso_after_z_iso_inv. rewrite 2 id_left. apply isrefl_logeq. } { apply isapropdirprod; apply homset_property. } { apply isapropdirprod; apply homset_property. } } Defined. Lemma isPushout'_up_to_z_iso {M:category} {a b c d d' : M} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (i : z_iso d d') : isPushout' f g in1 in2 -> isPushout' f g (i∘in1) (i∘in2). Proof. exact (isPullback'_up_to_z_iso (M:=oppositeCategory M) f g in1 in2 (opp_z_iso i)). Qed. (* Section bottleneck. *) (* Context {M:category} {a b c d : M} (f : b --> a) (g : c --> a) *) (* (p1 : d --> b) (p2 : d --> c) (pb : isPullback' f g p1 p2). *) (* Time Check (pb : @isPushout' (oppositeCategory M) a b c d f g p1 p2). *) (* (* without the abstraction above, this would be too slow, 13.5 seconds *) *) (* End bottleneck. *) Lemma Pushout_to_isPushout' {M:category} {a b c : M} (f : a --> b) (g : a --> c) (po : Pushout f g) : isPushout' f g (PushoutIn1 po) (PushoutIn2 po). Proof. use tpair. - apply PushoutSqrCommutes. - cbn beta. apply isPushout_Pushout. Qed. Lemma Pullback_to_isPullback' {M:category} {a b c : M} (f : b --> a) (g : c --> a) (pb : Pullback f g) : isPullback' f g (PullbackPr1 pb) (PullbackPr2 pb). Proof. use tpair. - apply PullbackSqrCommutes. - cbn beta. apply isPullback_Pullback. Qed. End Categories. Section MorphismPairs. Goal ∏ (M : precategory) (P Q : MorphismPair M) (f:MorphismPairIsomorphism P Q), InverseMorphismPairIsomorphism (InverseMorphismPairIsomorphism f) = f. Proof. (* Because this fails, we will have two (dual) properties in the definition of exact category, so we can get duality to work better. *) Fail reflexivity. Abort. End MorphismPairs. Section Pullbacks. (* move upstream *) Local Open Scope type. Definition IsoArrowTo {M : category} {A A' B:M} (g : A --> B) (g' : A' --> B) := ∑ i : z_iso A A', i · g' = g. Coercion IsoArrowTo_pr1 {M : category} {A A' B:M} (g : A --> B) (g' : A' --> B) : IsoArrowTo g g' -> z_iso A A' := pr1. Definition IsoArrowFrom {M : category} {A B B':M} (g : A --> B) (g' : A --> B') := ∑ i : z_iso B B', g · i = g'. Coercion IsoArrowFrom_pr1 {M : category} {A B B':M} (g : A --> B) (g' : A --> B') : IsoArrowFrom g g' -> z_iso B B' := pr1. (* this definition of IsoArrow is asymmetric *) Definition IsoArrow {M : category} {A A' B B':M} (g : A --> B) (g' : A' --> B') := ∑ (i : z_iso A A') (j : z_iso B B'), i · g' = g · j. Definition pullbackiso1 {M : category} {A B C:M} {f : A --> C} {g : B --> C} (pb : Pullback f g) (pb' : Pullback f g) : IsoArrowTo (PullbackPr1 pb) (PullbackPr1 pb') := pr1 (pullbackiso _ pb pb'),,pr12 (pullbackiso _ pb pb'). Definition pullbackiso2 {M : category} {A B C:M} {f : A --> C} {g : B --> C} (pb : Pullback f g) (pb' : Pullback f g) : IsoArrowTo (PullbackPr2 pb) (PullbackPr2 pb') := pr1 (pullbackiso _ pb pb'),,pr22 (pullbackiso _ pb pb'). Section OppositeIsoArrows. Definition opposite_IsoArrowTo {M:category} {A A' B:M} {g : A --> B} {g' : A' --> B} : IsoArrowTo g g' -> IsoArrowFrom (M:=M^op) g' g. Proof. intros i. Fail exact i. use tpair. - exact (opp_z_iso (pr1 i)). - cbn. exact (pr2 i). Defined. Definition opposite_IsoArrowFrom {M:category} {A B B':M} {g : A --> B} {g' : A --> B'} : IsoArrowFrom g g' -> IsoArrowTo (M:=M^op) g' g. Proof. intros i. use tpair. - exact (opp_z_iso (pr1 i)). - cbn. exact (pr2 i). Defined. Definition opposite_IsoArrow {M:category} {A A' B B':M} (g : A --> B) (g' : A' --> B') : IsoArrow g g' -> IsoArrow (M:=M^op) (opp_mor g') (opp_mor g). Proof. intros i. exists (opp_z_iso (pr12 i)). exists (opp_z_iso (pr1 i)). exact (! pr22 i). Defined. End OppositeIsoArrows. Lemma IsoArrowTo_isaprop (M : category) {A A' B:M} (g : A --> B) (g' : A' --> B) : isMonic g' -> isaprop (IsoArrowTo g g'). Proof. intros i. apply invproofirrelevance; intros k k'. apply subtypePath. - intro. apply homset_property. - induction k as [[k K] e], k' as [[k' K'] e']; cbn; cbn in e, e'. induction (i A k k' (e @ !e')). apply maponpaths. apply isaprop_is_z_isomorphism. Qed. Lemma IsoArrowFrom_isaprop (M : category) {A B B':M} (g : A --> B) (g' : A --> B') : isEpi g -> isaprop (IsoArrowFrom g g'). Proof. intros i. apply invproofirrelevance; intros k k'. apply subtypePath. { intros j. apply homset_property. } induction k as [[k K] e], k' as [[k' K'] e']; cbn; cbn in e, e'. apply subtypePath; cbn. { intros f. apply isaprop_is_z_isomorphism. } use i. exact (e @ !e'). Qed. End Pullbacks. Local Open Scope abgrcat. (* This exactly duplicates definitions upstream, but Import doesn't get the ones overridden, which are useful (mysteriously) for printing: *) Local Notation "0" := (unel (grtomonoid (abgrtogr _))) : abgrcat. Local Notation "0" := (unel (grtomonoid (abgrtogr (to_abgr _ _)))) : abgrcat. Local Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f g) : abgrcat. Local Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f g) : abgrcat. Local Notation " - g" := (@grinv (abgrtogr _) g) : abgrcat. Local Notation " - g" := (@grinv (abgrtogr (to_abgr _ _)) g) : abgrcat. Local Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat. Local Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat. Section PreAdditive. (** Reprove some standard facts in additive categories with the 0 map (the zero element of the group) replacing the zero map (defined by composing maps to and from the zero object). *) Lemma ThroughZeroIsZero {M:PreAdditive} (a b:M) (Z : Zero M) (f : a --> Z) (g : Z --> b) : f · g = 0. Proof. intermediate_path ((0:a-->Z) · g). - apply (maponpaths (postcomp_with g)). apply ArrowsToZero. - apply to_postmor_unel'. Qed. Definition elem21 {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) (f:A-->B) : AB-->AB := 1 + π₁·f·ι₂. Section Foo. (* because we open scopes *) Definition elem21_isiso {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) (f:A-->B) : is_z_isomorphism (elem21 AB f). Proof. exists (1 - π₁·f·ι₂). unfold elem21. split. - rewrite leftDistribute, 2 rightDistribute. rewrite id_left. refine (_ @ runax (Hom_add _ _ _) _). rewrite assocax. apply maponpaths. rewrite id_right, id_left. rewrite rightMinus. rewrite <- assocax. rewrite grlinvax. rewrite lunax. rewrite assoc'. rewrite <- (assoc π₁ f ι₂). rewrite (assoc ι₂). rewrite DirectSumIn2Pr1. rewrite zeroLeft. rewrite zeroRight. rewrite grinvunel. reflexivity. - rewrite leftDistribute, 2 rightDistribute. rewrite id_left. refine (_ @ runax (Hom_add _ _ _) _). rewrite assocax. apply maponpaths. rewrite id_right, id_left. rewrite leftMinus. rewrite <- assocax. rewrite grrinvax. rewrite lunax. rewrite assoc'. rewrite <- (assoc π₁ f ι₂). rewrite (assoc ι₂). rewrite DirectSumIn2Pr1. rewrite zeroLeft. rewrite zeroRight. rewrite grinvunel. reflexivity. Defined. End Foo. Definition elem12 {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) (f:B-->A) : AB-->AB := 1 + π₂·f·ι₁. Definition elem12_isiso {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) (f:B-->A) : is_z_isomorphism (elem12 AB f). Proof. exists (1 - π₂·f·ι₁). unfold elem12. split. - rewrite leftDistribute, 2 rightDistribute. rewrite id_left. refine (_ @ runax (Hom_add _ _ _) _). rewrite assocax. apply maponpaths. rewrite id_right, id_left. rewrite rightMinus. rewrite <- assocax. rewrite grlinvax. rewrite lunax. rewrite assoc'. rewrite <- (assoc _ f _). rewrite 2 (assoc ι₁). rewrite DirectSumIn1Pr2. rewrite zeroLeft. rewrite zeroLeft. rewrite 2 zeroRight. use grinvunel. - rewrite leftDistribute, 2 rightDistribute. rewrite id_left. refine (_ @ runax (Hom_add _ _ _) _). rewrite assocax. apply maponpaths. rewrite id_right, id_left. rewrite leftMinus. rewrite <- assocax. rewrite grrinvax. rewrite lunax. rewrite assoc'. rewrite <- (assoc _ f _). rewrite (assoc ι₁). rewrite (assoc ι₁). rewrite DirectSumIn1Pr2. rewrite 2 zeroLeft. rewrite 2 zeroRight. use grinvunel. Defined. Definition isKernel' {M:PreAdditive} {x y z : M} (f : x --> y) (g : y --> z) : hProp := f · g = 0 ∧ ∀ (w : M) (h : w --> y), h · g = 0 ⇒ ∃! φ : w --> x, φ · f = h. Definition hasKernel {M:PreAdditive} {y z : M} (g : y --> z) : hProp := ∃ x (f:x-->y), isKernel' f g. Lemma isKernel_iff {M:PreAdditive} {x y z : M} (Z:Zero M) (f : x --> y) (g : y --> z) : isKernel' f g <-> ∑ e : f · g = ZeroArrow Z x z, isKernel Z f g e. Proof. split. { intros [e' ik]. use tpair. { refine (e' @ _). apply PreAdditive_unel_zero. } intros T h e. exact (ik T h (e @ ! PreAdditive_unel_zero _ _ _ _)). } { intros [e ik]. use tpair. { refine (e @ ! _). apply PreAdditive_unel_zero. } cbn beta. intros T h e'. exact (ik T h (e' @ PreAdditive_unel_zero _ _ _ _)). } Qed. Definition isKernel'_to_Kernel {M:PreAdditive} (Z:Zero M) {x y z : M} (f : x --> y) (g : y --> z) : isKernel' f g -> Kernel Z g. Proof. intros co. exists (x,,f). now apply isKernel_iff. Defined. Definition isCokernel' {M:PreAdditive} {x y z : M} (f : x --> y) (g : y --> z) : hProp := f · g = 0 ∧ ∀ (w : M) (h : y --> w), f · h = 0 ⇒ ∃! φ : z --> w, g · φ = h. Definition hasCokernel {M:PreAdditive} {x y : M} (f : x --> y) : hProp := ∃ z (g:y-->z), isCokernel' f g. Lemma isCokernel_iff {M:PreAdditive} {x y z : M} (Z:Zero M) (f : x <-- y) (g : y <-- z) : isCokernel' g f <-> ∑ e : f ∘ g = ZeroArrow Z z x, isCokernel Z g f e. Proof. split. { intros [e' ik]. use tpair. { refine (e' @ _). apply PreAdditive_unel_zero. } intros T h e. exact (ik T h (e @ ! PreAdditive_unel_zero _ _ _ _)). } { intros [e ik]. use tpair. { refine (e @ ! _). apply PreAdditive_unel_zero. } cbn beta. intros T h e'. exact (ik T h (e' @ PreAdditive_unel_zero _ _ _ _)). } Qed. Definition isCokernel'_to_Cokernel {M:PreAdditive} (Z:Zero M) {x y z : M} (f : x --> y) (g : y --> z) : isCokernel' f g -> Cokernel Z f. Proof. intros co. exists (z,,g). now apply isCokernel_iff. Defined. Section Tmp. Lemma PushoutCokernel {M:PreAdditive} {A B C D E:M} (i:A-->B) (p:B-->C) (j:B-->D) (p':D-->E) (j':C-->E) : isCokernel' i p -> isPushout' (M:=M) j p p' j' -> isCokernel' (i·j) p'. Proof. intros [b co] [e po]. (* We show the universal property of the cokernel by showing uniqueness and existence simultaneously, i.e., by working with equivalences to show a type is contractible. *) split. - rewrite assoc'. (* ambiguous coercions! (category_to_precategory (categoryWithAbgrops_category _)) (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _)) *) rewrite e. (* unfold category_to_precategory, pr1 in e. rewrite e. *) rewrite assoc. rewrite b. apply zeroLeft. - intros T h v. rewrite assoc' in v. assert (Q := co T (j·h) v); cbn in Q. generalize Q; clear Q. apply iscontrweqb. use make_weq. + intros [k w]; exists (j'·k). rewrite assoc. rewrite <- e. rewrite assoc'. rewrite w. reflexivity. + cbn beta. intros [l w]; unfold hfiber. assert (PO := po T h l (!w)); clear po. generalize PO; clear PO. apply iscontrweqb. refine (weqcomp (weqtotal2asstor _ _) _). apply weqfibtototal; intros m. cbn. apply weqiff. { split. - intros [x y]. split. + exact x. + exact (maponpaths pr1 y). - intros [x y]. exists x. induction y. apply maponpaths, to_has_homsets. } { apply isofhleveltotal2. - apply to_has_homsets. - intros u. refine ((_:isofhlevel 2 _) _ _). apply isofhleveltotal2. + apply to_has_homsets. + intros n. apply hlevelntosn. apply to_has_homsets. } { apply isapropdirprod; apply to_has_homsets. } Qed. End Tmp. Lemma PullbackKernel {M:PreAdditive} {A B C D E:M} (i:A<--B) (p:B<--C) (j:B<--D) (p':D<--E) (j':C<--E) : isKernel' p i -> isPullback' (M:=M) j p p' j' -> isKernel' p' (i∘j). Proof. exact (@PushoutCokernel (oppositePreAdditive M) A B C D E i p j p' j'). Defined. Lemma KernelIsMonic {M:PreAdditive} {x y z:M} (f : x --> y) (g : y --> z) : isKernel' f g -> isMonic f. Proof. intros [t i] w p q e. set (T := ∑ r : w --> x, r · f = q · f). assert (ic : ∏ t1 t2 : T, t1 = t2). { apply proofirrelevancecontr. use i. rewrite assoc'. rewrite t. apply zeroRight. } set (t1 := (p,,e) : T). set (t2 := (q,,idpath _) : T). assert (Q := ic t1 t2). exact (maponpaths pr1 Q). Qed. Lemma CokernelIsEpi {M:PreAdditive} {x y z:M} (f : x --> y) (g : y --> z) : isCokernel' f g -> isEpi g. Proof. exact (KernelIsMonic (M:=oppositePreAdditive M) g f). Qed. Definition makeMonicKernel {M:PreAdditive} {x y z : M} (f : x --> y) (g : y --> z) : isMonic f -> f · g = 0 -> (∏ (w : M) (h : w --> y), h · g = 0 -> ∑ φ : w --> x, φ · f = h) -> isKernel' f g. Proof. intros im eq ex. exists eq. intros w h e. apply iscontraprop1. - apply invproofirrelevance; intros [r R] [s S]. Unset Printing Notations. Arguments paths _ _ _ : clear implicits. try assumption. refine (@subtypePath_prop _ _ (_,,_) (_,,_) _); simpl. apply im. exact (R@!S). - apply ex. exact e. Qed. Definition makeEpiCokernel {M:PreAdditive} {x y z : M} (f : x --> y) (g : y --> z) : isEpi g -> f · g = 0 -> (∏ (w : M) (h : y --> w), f · h = 0 -> ∑ φ : z --> w, g · φ = h) -> isCokernel' f g. Proof. exact (makeMonicKernel (M:=oppositePreAdditive M) g f). Qed. Lemma IsoWithKernel {M:PreAdditive} {x y z z':M} (f : x --> y) (g : y --> z) (h : z --> z') : isKernel' f g -> is_z_isomorphism h -> isKernel' f (g·h). Proof. intros i j. apply makeMonicKernel. - exact (KernelIsMonic _ _ i). - exact (assoc _ _ _ @ maponpaths (postcomp_with _) (pr1 i) @ zeroLeft h). - intros w k e. apply (pr2 i). refine (post_comp_with_iso_is_inj _ _ h (is_iso_from_is_z_iso h j) _ _ _ _). refine (! assoc _ _ _ @ e @ ! zeroLeft _). Qed. Lemma IsoWithCokernel {M:PreAdditive} {x x' y z:M} (f : x --> y) (g : y --> z) (h : x' --> x) : isCokernel' f g -> is_z_isomorphism h -> isCokernel' (h·f) g. Proof. exact (λ c i, IsoWithKernel (M:=oppositePreAdditive M) g f h c (opp_is_z_isomorphism h i)). Qed. Lemma KernelOfZeroMapIsIso {M:PreAdditive} {x y z:M} (g : x --> y) : isKernel' g (0 : y --> z) -> is_z_isomorphism g. (* compare with KernelofZeroArrow_is_iso *) Proof. intros [_ ke]. use (is_z_iso_from_is_iso' M). intros T h. exact (ke _ _ (zeroRight _)). Defined. Lemma CokernelOfZeroMapIsIso {M:PreAdditive} {x y z:M} (g : y --> z) : isCokernel' (0 : x --> y) g -> is_z_isomorphism g. (* compare with CokernelofZeroArrow_is_iso *) Proof. intros [_ co]. use is_z_iso_from_is_iso. intros T h. exact (co _ _ (zeroLeft _)). Defined. Lemma KernelUniqueness {M:PreAdditive} {x x' y z : M} {f : x --> y} {f' : x' --> y} {g : y --> z} : isKernel' f g -> isKernel' f' g -> iscontr (IsoArrowTo f f'). Proof. intros i j. apply iscontraprop1. - exact (IsoArrowTo_isaprop M f f' (KernelIsMonic f' g j)). - induction (iscontrpr1 (pr2 j _ f (pr1 i))) as [p P]. induction (iscontrpr1 (pr2 i _ f' (pr1 j))) as [q Q]. use tpair. + exists p. exists q. split. * apply (KernelIsMonic _ _ i). rewrite assoc'. rewrite Q. rewrite P. rewrite id_left. reflexivity. * apply (KernelIsMonic _ _ j). rewrite assoc'. rewrite P. rewrite Q. rewrite id_left. reflexivity. + cbn. exact P. Defined. Lemma CokernelUniqueness {M:PreAdditive} {x y z z' : M} {f : x --> y} {g : y --> z} {g' : y --> z'} : isCokernel' f g -> isCokernel' f g' -> iscontr (IsoArrowFrom g g'). Proof. intros i j. (* The dual proof would go like this: assert (Q := KernelUniqueness (M:=oppositePreAdditive M) i j). generalize Q. Now we would need this: weq (IsoArrowTo g g') (IsoArrowFrom g g') *) apply iscontraprop1. - exact (IsoArrowFrom_isaprop M g g' (CokernelIsEpi f g i)). - induction (iscontrpr1 (pr2 j _ g (pr1 i))) as [p P]. induction (iscontrpr1 (pr2 i _ g' (pr1 j))) as [q Q]. use tpair. + exists q. exists p. split. * apply (CokernelIsEpi _ _ i). rewrite assoc. rewrite Q. rewrite P. rewrite id_right. reflexivity. * apply (CokernelIsEpi _ _ j). rewrite assoc. rewrite P. rewrite Q. rewrite id_right. reflexivity. + cbn. exact Q. Defined. Lemma DirectSumToPullback {M:PreAdditive} {A B:M} (S : BinDirectSum A B) (Z : Zero M) : Pullback (0 : A --> Z) (0 : B --> Z). Proof. use tpair. - exists S. exact (to_Pr1 S,, to_Pr2 S). - cbn. use tpair. + apply ArrowsToZero. + cbn. intros T f g e. exact (to_isBinProduct M S T f g). Defined. Lemma DirectSumToPushout {M:PreAdditive} {A B:M} (S : BinDirectSum A B) (Z : Zero M) : Pushout (0 : Z --> A) (0 : Z --> B). Proof. use tpair. - exists S. exact (to_In1 S,, to_In2 S). - cbn. use tpair. + apply ArrowsFromZero. + cbn. intros T f g e. exact (to_isBinCoproduct M S T f g). Defined. Definition directSumMap {M:PreAdditive} {a b c d:M} (ac : BinDirectSum a c) (bd : BinDirectSum b d) (f : a --> b) (g : c --> d) : ac --> bd := BinDirectSumIndAr f g _ _. Lemma directSumMapEqPr1 {M:PreAdditive} {a b c d:M} {ac : BinDirectSum a c} {bd : BinDirectSum b d} {f : a --> b} {g : c --> d} : directSumMap ac bd f g · π₁ = π₁ · f. Proof. apply BinDirectSumPr1Commutes. Qed. Lemma directSumMapEqPr2 {M:PreAdditive} {a b c d:M} {ac : BinDirectSum a c} {bd : BinDirectSum b d} {f : a --> b} {g : c --> d} : directSumMap ac bd f g · π₂ = π₂ · g. Proof. apply BinDirectSumPr2Commutes. Qed. Lemma directSumMapEqIn1 {M:PreAdditive} {a b c d:M} {ac : BinDirectSum a c} {bd : BinDirectSum b d} {f : a --> b} {g : c --> d} : ι₁ · directSumMap ac bd f g = f · ι₁. Proof. unfold directSumMap. rewrite BinDirectSumIndArEq. apply BinDirectSumIn1Commutes. Qed. Lemma directSumMapEqIn2 {M:PreAdditive} {a b c d:M} {ac : BinDirectSum a c} {bd : BinDirectSum b d} {f : a --> b} {g : c --> d} : ι₂ · directSumMap ac bd f g = g · ι₂. Proof. unfold directSumMap. rewrite BinDirectSumIndArEq. apply BinDirectSumIn2Commutes. Qed. (* One of these should replace to_BinOpId upstream. Also fix ToBinDirectSumFormula and FromBinDirectSumFormula. *) Definition to_BinOpId' {M:PreAdditive} {a b co : M} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum i1 i2 p1 p2) : p1 · i1 + p2 · i2 = identity co := to_BinOpId B. Definition to_BinOpId'' {M:PreAdditive} {a b : M} (ab : BinDirectSum a b) : (to_Pr1 ab · to_In1 ab) + (to_Pr2 ab · to_In2 ab) = 1 := to_BinOpId ab. Definition ismonoidfun_prop {G H:abgr} (f:G->H) : hProp := make_hProp (ismonoidfun f) (isapropismonoidfun f). Definition PreAdditive_functor (M N:PreAdditive) := ∑ F : M ⟶ N, ∀ A B:M, ismonoidfun_prop (@functor_on_morphisms M N F A B : A --> B -> F A --> F B). Coercion PreAdditive_functor_to_functor {M N:PreAdditive} : PreAdditive_functor M N -> functor M N := pr1. Definition functor_on_morphisms_add {C C' : PreAdditive} (F : PreAdditive_functor C C') { a b : C} : monoidfun (a --> b) (F a --> F b) := monoidfunconstr (pr2 F a b). Local Notation "# F" := (functor_on_morphisms_add F) : abgrcat. Lemma add_functor_comp {M N:PreAdditive} (F : PreAdditive_functor M N) {A B C:M} (f:A --> B) (g:B --> C) : # F (f · g) = # F f · # F g. Proof. exact (functor_comp F f g). Qed. Lemma add_functor_add {M N:PreAdditive} (F : PreAdditive_functor M N) {A B:M} (f g:A --> B) : # F (f+g) = # F f + # F g. Proof. exact (ismonoidfunisbinopfun (pr2 F A B) f g). Qed. Lemma add_functor_zero {M N:PreAdditive} (F : PreAdditive_functor M N) (A B:M) : functor_on_morphisms_add (a:=A) (b:=B) F 0 = 0. Proof. exact (ismonoidfununel (pr2 F A B)). Qed. Lemma add_functor_sub {M N:PreAdditive} (F : PreAdditive_functor M N) {A B:M} (g:A --> B) : # F (-g) = - # F g. Proof. exact (grinvandmonoidfun _ _ (pr2 F A B) g). Qed. Lemma zeroCriterion {M:PreAdditive} {Z:M} : identity Z = 0 <-> isZero Z. Proof. split. { intros e. split. - intros T. exists 0. intros h. refine (! id_left h @ _). induction (!e); clear e. apply zeroLeft. - intros T. exists 0. intros h. refine (! id_right h @ _). induction (!e); clear e. apply zeroRight. } { intros i. apply (isapropifcontr (pr1 i Z)). } Qed. Lemma applyFunctorToIsZero {M N:PreAdditive} (F : PreAdditive_functor M N) (Z : M) : isZero Z -> isZero (F Z). Proof. exact (λ i, pr1 zeroCriterion (! functor_id F Z @ maponpaths (#F) (pr2 zeroCriterion i) @ add_functor_zero F Z Z)). Qed. Definition applyFunctorToZero {M N:PreAdditive} (F : PreAdditive_functor M N) : Zero M -> Zero N. Proof. intros Z. exact (F Z,, applyFunctorToIsZero F Z (pr2 Z)). Defined. Definition applyFunctorToIsBinDirectSum {M N:PreAdditive} (F : PreAdditive_functor M N) (A B S : M) (i1 : A --> S) (i2 : B --> S) (p1 : S --> A) (p2 : S --> B) : isBinDirectSum i1 i2 p1 p2 -> isBinDirectSum (# F i1) (# F i2) (# F p1) (# F p2). Proof. intros ds. repeat split. - rewrite <- add_functor_comp. rewrite (to_IdIn1 ds). apply functor_id. - rewrite <- add_functor_comp. rewrite (to_IdIn2 ds). apply functor_id. - rewrite <- add_functor_comp. rewrite (to_Unel1 ds); unfold to_unel. use ismonoidfununel. use (pr2 F). - rewrite <- add_functor_comp. rewrite (to_Unel2 ds); unfold to_unel. use ismonoidfununel. use (pr2 F). - rewrite <- 2 add_functor_comp. rewrite <- add_functor_add. rewrite (to_BinOpId' ds). apply functor_id. Qed. Definition applyFunctorToBinDirectSum {M N:PreAdditive} (F : PreAdditive_functor M N) {A B:M} : BinDirectSum A B -> BinDirectSum (F A) (F B) := λ S, make_BinDirectSum _ _ _ _ _ _ _ _ (applyFunctorToIsBinDirectSum F A B S ι₁ ι₂ π₁ π₂ (pr2 S)). Definition induced_PreAdditive_incl (M : PreAdditive) {X:Type} (j : X -> ob M) : PreAdditive_functor (induced_PreAdditive M j) M. Proof. exists (induced_precategory_incl j). intros A B. split. + intros f g. reflexivity. + reflexivity. Defined. Definition SwitchMap {M:PreAdditive} (a b:M) (ab : BinDirectSum a b) (ba : BinDirectSum b a) : ab --> ba := π₁ · ι₂ + π₂ · ι₁. Lemma SwitchMapEqn {M:PreAdditive} {a b:M} (ab : BinDirectSum a b) (ba : BinDirectSum b a) : SwitchMap a b ab ba · SwitchMap b a ba ab = 1. Proof. unfold SwitchMap. rewrite <- to_BinOpId''. rewrite leftDistribute, 2 rightDistribute. rewrite assoc', (assoc ι₂). rewrite DirectSumIn2Pr1. rewrite zeroLeft, zeroRight, lunax. rewrite assoc', (assoc ι₂). rewrite (to_IdIn2 ba), id_left. apply maponpaths. rewrite assoc', (assoc ι₁). rewrite (to_IdIn1 ba), id_left. rewrite assoc', (assoc ι₁). rewrite DirectSumIn1Pr2. rewrite zeroLeft, zeroRight, runax. reflexivity. Defined. Definition SwitchIso {M:PreAdditive} (a b:M) (ab : BinDirectSum a b) (ba : BinDirectSum b a) : z_iso ab ba. Proof. exists (SwitchMap _ _ _ _). exists (SwitchMap _ _ _ _). split; apply SwitchMapEqn. Defined. Lemma SwitchMapEqnTo {M:PreAdditive} {a b c:M} (bc : BinDirectSum b c) (cb : BinDirectSum c b) (f:a-->b) (g:a-->c) : ToBinDirectSum bc f g · SwitchMap b c bc cb = ToBinDirectSum cb g f. Proof. unfold SwitchMap. apply ToBinDirectSumsEq. - rewrite rightDistribute. rewrite 2 assoc. rewrite 2 BinDirectSumPr1Commutes, BinDirectSumPr2Commutes. rewrite leftDistribute. rewrite 2 assoc'. rewrite (to_Unel2 cb). unfold to_unel. (* fix to_Unel2! *) rewrite zeroRight. rewrite lunax. rewrite (to_IdIn1 cb). rewrite id_right. reflexivity. - rewrite assoc'. rewrite leftDistribute. rewrite (assoc' π₂ _ π₂). rewrite (to_Unel1 cb). unfold to_unel. rewrite zeroRight. rewrite runax. rewrite 2 assoc. rewrite BinDirectSumPr1Commutes, BinDirectSumPr2Commutes. rewrite assoc'. rewrite (to_IdIn2 cb). rewrite id_right. reflexivity. Qed. Lemma SwitchMapMapEqn {M:PreAdditive} {a b c d:M} (ac : BinDirectSum a c) (ca : BinDirectSum c a) (bd : BinDirectSum b d) (db : BinDirectSum d b) (f : a --> b) (g : c --> d) : SwitchMap c a ca ac · directSumMap ac bd f g = directSumMap ca db g f · SwitchMap d b db bd. Proof. unfold SwitchMap. rewrite leftDistribute. rewrite assoc'. rewrite directSumMapEqIn2. rewrite assoc. rewrite rightDistribute. rewrite assoc. rewrite directSumMapEqPr1. apply maponpaths. rewrite assoc'. rewrite directSumMapEqIn1. rewrite assoc. rewrite assoc. rewrite directSumMapEqPr2. reflexivity. Qed. Definition directSumMapSwitch {M:PreAdditive} {a b c d:M} (ac : BinDirectSum a c) (ca : BinDirectSum c a) (bd : BinDirectSum b d) (db : BinDirectSum d b) (f : a --> b) (g : c --> d) : IsoArrow (directSumMap ac bd f g) (directSumMap ca db g f). Proof. exists (SwitchIso _ _ _ _). exists (SwitchIso _ _ _ _). apply SwitchMapMapEqn. Defined. Lemma opposite_directSumMap {M:PreAdditive} {a b c d:M} (ac : BinDirectSum a c) (bd : BinDirectSum b d) (f : a --> b) (g : c --> d) : directSumMap (M:=oppositePreAdditive M) (oppositeBinDirectSum bd) (oppositeBinDirectSum ac) (opp_mor f) (opp_mor g) = opp_mor (directSumMap ac bd f g). Proof. apply BinDirectSumIndArEq. Qed. Lemma opposite_directSumMap' {M:PreAdditive} {a b c d:M} (ac : BinDirectSum a c) (bd : BinDirectSum b d) (f : a --> b) (g : c --> d) : opp_mor (directSumMap (M:=oppositePreAdditive M) (oppositeBinDirectSum bd) (oppositeBinDirectSum ac) (opp_mor f) (opp_mor g)) = directSumMap ac bd f g. Proof. apply (maponpaths opp_mor). apply opposite_directSumMap. Qed. Lemma SumOfKernels {M:PreAdditive} {x y z X Y Z : M} (xX : BinDirectSum x X) (yY : BinDirectSum y Y) (zZ : BinDirectSum z Z) (f : x --> y) (g : y --> z) (f' : X --> Y) (g' : Y --> Z) : isKernel' f g -> isKernel' f' g' -> isKernel' (directSumMap xX yY f f') (directSumMap yY zZ g g'). Proof. intros i i'. split. { refine (BinDirectSumIndArComp _ _ _ _ _ _ _ _ @ ! _). apply ToBinDirectSumUnique. - exact (zeroLeft _ @ ! zeroRight _ @ maponpaths _ (! pr1 i)). - exact (zeroLeft _ @ ! zeroRight _ @ maponpaths _ (! pr1 i')). } intros w h e. apply iscontraprop1. 2:{ assert (e1 := ! assoc _ _ _ @ ! maponpaths (precomp_with _) directSumMapEqPr1 @ assoc _ _ _ @ maponpaths (postcomp_with _) e @ zeroLeft _). assert (e2 := ! assoc _ _ _ @ ! maponpaths (precomp_with _) directSumMapEqPr2 @ assoc _ _ _ @ maponpaths (postcomp_with _) e @ zeroLeft _). induction (iscontrpr1 (pr2 i w (h · π₁) e1)) as [h1 H1]. induction (iscontrpr1 (pr2 i' w (h · π₂) e2)) as [h2 H2]. exists (ToBinDirectSum _ h1 h2). apply ToBinDirectSumsEq. + refine (! assoc _ _ _ @ _ @ H1). refine (maponpaths (precomp_with _) directSumMapEqPr1 @ _). unfold precomp_with. refine (assoc _ _ _ @ _). apply (maponpaths (postcomp_with _)). apply BinDirectSumPr1Commutes. + refine (! assoc _ _ _ @ _ @ H2). refine (maponpaths (precomp_with _) directSumMapEqPr2 @ _). unfold precomp_with. refine (assoc _ _ _ @ _). apply (maponpaths (postcomp_with _)). apply BinDirectSumPr2Commutes. } apply invproofirrelevance. intros [k K] [k' K']. apply subtypePath_prop; cbn. apply ToBinDirectSumsEq. - refine (KernelIsMonic _ _ i _ _ _ _). exact (! assoc _ _ _ @ ! maponpaths (precomp_with k) directSumMapEqPr1 @ assoc _ _ _ @ maponpaths (postcomp_with _) (K @ !K') @ ! assoc _ _ _ @ maponpaths (precomp_with k') directSumMapEqPr1 @ assoc _ _ _). - refine (KernelIsMonic _ _ i' _ _ _ _). exact (! assoc _ _ _ @ ! maponpaths (precomp_with k) directSumMapEqPr2 @ assoc _ _ _ @ maponpaths (postcomp_with _) (K @ !K') @ ! assoc _ _ _ @ maponpaths (precomp_with k') directSumMapEqPr2 @ assoc _ _ _). Qed. Lemma SumOfCokernels {M:PreAdditive} {x y z X Y Z : M} (xX : BinDirectSum x X) (yY : BinDirectSum y Y) (zZ : BinDirectSum z Z) (f : x --> y) (g : y --> z) (f' : X --> Y) (g' : Y --> Z) : isCokernel' f g -> isCokernel' f' g' -> isCokernel' (directSumMap xX yY f f') (directSumMap yY zZ g g'). Proof. intros i i'. rewrite <- (opposite_directSumMap' xX yY f f'). rewrite <- (opposite_directSumMap' yY zZ g g'). exact (SumOfKernels (M:=oppositePreAdditive M) (oppositeBinDirectSum zZ) (oppositeBinDirectSum yY) (oppositeBinDirectSum xX) g f g' f' i i'). Qed. Lemma inducedMapReflectsKernels (M : PreAdditive) {X:Type} (j : X -> ob M) {A B C:induced_PreAdditive M j} (i:A-->B) (p:B-->C) : isKernel' (# (induced_PreAdditive_incl M j) i) (# (induced_PreAdditive_incl M j) p) -> isKernel' i p. Proof. exact (λ k, pr1 k,,λ T h e, pr2 k (j T) h e). Qed. Lemma inducedMapReflectsCokernels (M : PreAdditive) {X:Type} (j : X -> ob M) {A B C:induced_PreAdditive M j} (i:A-->B) (p:B-->C) : isCokernel' (# (induced_PreAdditive_incl M j) i) (# (induced_PreAdditive_incl M j) p) -> isCokernel' i p. Proof. exact (λ k, pr1 k,,λ T h e, pr2 k (j T) h e). Qed. End PreAdditive. Section KernelCokernelPairs. Definition isKernelCokernelPair {M :PreAdditive} {A B C:M} (i : A --> B) (p: B --> C) : hProp := isKernel' i p ∧ isCokernel' i p. Definition PairToKernel {M :PreAdditive} {A B C:M} {i : A --> B} {p: B --> C} : isKernelCokernelPair i p -> isKernel' i p := pr1. Definition PairToCokernel {M :PreAdditive} {A B C:M} {i : A --> B} {p: B --> C} : isKernelCokernelPair i p -> isCokernel' i p := pr2. Lemma inducedMapReflectsKernelCokernelPairs (M : PreAdditive) {X:Type} (j : X -> ob M) {A B C:induced_PreAdditive M j} (i:A-->B) (p:B-->C) : isKernelCokernelPair (# (induced_PreAdditive_incl M j) i) (# (induced_PreAdditive_incl M j) p) -> isKernelCokernelPair i p. Proof. intros [k c]. split. - now apply inducedMapReflectsKernels. - now apply inducedMapReflectsCokernels. Qed. Definition opposite_isKernelCokernelPair {M:PreAdditive} {A B C:M} {i : A --> B} {p: B --> C} : isKernelCokernelPair i p -> isKernelCokernelPair (M:=oppositePreAdditive M) p i. Proof. intros s. split. - exact (PairToCokernel s). - exact (PairToKernel s). Defined. Lemma PairUniqueness1 {M :PreAdditive} {A A' B C:M} (i : A --> B) (i' : A' --> B) (p: B --> C) : isKernelCokernelPair i p -> isKernelCokernelPair i' p -> iscontr (IsoArrowTo i i'). Proof. intros [k _] [k' _]. exact (KernelUniqueness k k'). Defined. Lemma PairUniqueness2 {M :PreAdditive} {A B C C':M} (i : A --> B) (p: B --> C) (p': B --> C') : isKernelCokernelPair i p -> isKernelCokernelPair i p' -> iscontr (IsoArrowFrom p p'). Proof. intros [_ c] [_ c']. exact (CokernelUniqueness c c'). Defined. Lemma kerCokerDirectSum {M :PreAdditive} {A B:M} (S:BinDirectSum A B) : isKernelCokernelPair (to_In1 S) (to_Pr2 S). Proof. assert (E := BinDirectSum_isBinDirectSum M S). split. - exists (to_Unel1 S). intros T h H. use unique_exists; cbn beta. + exact (h · to_Pr1 S). + refine (! assoc _ _ _ @ _ @ id_right _). rewrite <- (to_BinOpId' S). rewrite rightDistribute. rewrite (assoc h (to_Pr2 S) (to_In2 S)). rewrite H; clear H. rewrite zeroLeft. apply pathsinv0. apply (runax (T-->S)). + intros k. apply to_has_homsets. + clear H. intros k e. induction e. rewrite assoc'. rewrite (to_IdIn1 S). apply pathsinv0, id_right. - exists (to_Unel1 S). intros T h H. use unique_exists; cbn beta. + exact (ι₂ · h). + refine (assoc _ _ _ @ _ @ id_left h). rewrite <- (to_BinOpId' S). rewrite leftDistribute. rewrite <- (assoc (to_Pr1 S) (to_In1 S) h). rewrite H; clear H. rewrite zeroRight. apply pathsinv0. apply (lunax (S-->T)). + intros k. apply to_has_homsets. + clear H. intros k e. induction e. rewrite assoc. rewrite (to_IdIn2 S). exact (! id_left _). Qed. Lemma kerCoker10 {M :PreAdditive} (Z:Zero M) (A:M) : isKernelCokernelPair (identity A) (0 : A --> Z). Proof. exact (kerCokerDirectSum (TrivialDirectSum Z A)). Qed. Lemma kerCoker01 {M :PreAdditive} (Z:Zero M) (A:M) : isKernelCokernelPair (0 : Z --> A) (identity A). Proof. exact (kerCokerDirectSum (TrivialDirectSum' Z A)). Qed. Lemma PairPushoutMap {M :PreAdditive} {A B C A':M} {i : A --> B} {p : B --> C} (pr : isKernelCokernelPair i p) (r : A --> A') (po : Pushout i r) : ∑ (q : po --> C), PushoutIn1 po · q = p × PushoutIn2 po · q = 0. Proof. refine (iscontrpr1 (isPushout_Pushout po C p 0 _)). refine (pr1 (PairToCokernel pr) @ ! _). apply zeroRight. Qed. Lemma PairPullbackMap {M :PreAdditive} {A B C A':M} {i : A <-- B} {p : B <-- C} (pr : isKernelCokernelPair p i) (r : A <-- A') (pb : Pullback i r) : ∑ (q : pb <-- C), PullbackPr1 pb ∘ q = p × PullbackPr2 pb ∘ q = 0. Proof. (* giving the dual proof here helps later! *) exact (PairPushoutMap (M:=oppositePreAdditive M) (opposite_isKernelCokernelPair pr) r pb). Defined. Lemma PairPushoutCokernel {M :PreAdditive} {A B C A':M} (i : A --> B) (p : B --> C) (pr : isKernelCokernelPair i p) (r : A --> A') (po : Pushout i r) (j := PushoutIn2 po) (pp := PairPushoutMap pr r po) : isCokernel' j (pr1 pp). Proof. set (s := PushoutIn1 po). induction pp as [q [e1 e2]]; change (isCokernel' j q); change (hProptoType (s · q = p)) in e1; change (hProptoType (j · q = 0)) in e2. exists e2. intros T h e. assert (L : i · (s · h) = 0). { refine (assoc _ _ _ @ _). intermediate_path (r · j · h). { apply (maponpaths (λ s, s · h)). exact (PushoutSqrCommutes po). } refine (! assoc _ _ _ @ _). induction (!e). apply zeroRight. } assert (V := iscontrpr1 ((pr22 pr) T (s · h) L)); clear L. induction V as [k e3]. use iscontraprop1. { apply invproofirrelevance; intros φ φ'. apply subtypePath_prop. induction φ as [φ e4]; induction φ' as [φ' e5]; cbn. use (_ : isEpi q). { apply (isEpi_precomp M s q). rewrite e1. apply (CokernelIsEpi i p). apply pr. } exact (e4 @ ! e5). } exists k. use (MorphismsOutofPushoutEqual (isPushout_Pushout po)); fold s j. { refine (assoc _ _ _ @ _ @ e3). apply (maponpaths (λ s, s · k)). exact e1. } { refine (assoc _ _ _ @ _ @ ! e). rewrite e2. apply zeroLeft. } Qed. Lemma PairPullbackKernel {M : PreAdditive} {A B C A':M} (i : A <-- B) (p : B <-- C) (pr : isKernelCokernelPair p i) (r : A <-- A') (pb : Pullback i r) (j := PullbackPr2 pb) (pp := PairPullbackMap pr r pb) : isKernel' (pr1 pp) j. Proof. (* Here's where giving the right proof of PairPullbackMap above helped us give this dual proof here. *) exact (PairPushoutCokernel (M:=oppositePreAdditive M) i p (opposite_isKernelCokernelPair pr) r pb). Defined. Lemma SumOfKernelCokernelPairs {M : PreAdditive} {x y z X Y Z : M} (xX : BinDirectSum x X) (yY : BinDirectSum y Y) (zZ : BinDirectSum z Z) {f : x --> y} {g : y --> z} {f' : X --> Y} {g' : Y --> Z} : isKernelCokernelPair f g -> isKernelCokernelPair f' g' -> isKernelCokernelPair (directSumMap xX yY f f') (directSumMap yY zZ g g'). Proof. intros i i'. exists (SumOfKernels _ _ _ f g f' g' (pr1 i) (pr1 i')). exact (SumOfCokernels _ _ _ f g f' g' (pr2 i) (pr2 i')). Qed. End KernelCokernelPairs. Section theDefinition. Definition ExactCategoryData := ∑ M:AdditiveCategory, MorphismPair M -> hProp. (* properties added below *) Coercion ExactCategoryDataToAdditiveCategory (ME : ExactCategoryData) : AdditiveCategory := pr1 ME. Definition isExact {M : ExactCategoryData} (E : MorphismPair M) : hProp := pr2 M E. Definition isExact2 {M : ExactCategoryData} {A B C:M} (f:A-->B) (g:B-->C) := isExact (make_MorphismPair f g). Definition isAdmissibleMonomorphism {M : ExactCategoryData} {A B:M} (i : A --> B) : hProp := ∃ C (p : B --> C), isExact2 i p. Definition AdmissibleMonomorphism {M : ExactCategoryData} (A B:M) : Type := ∑ (i : A --> B), isAdmissibleMonomorphism i. Coercion AdmMonoToMap {M : ExactCategoryData} {A B:M} : AdmissibleMonomorphism A B -> A --> B := pr1. Coercion AdmMonoToMap' {M : ExactCategoryData} {A B:M} : AdmissibleMonomorphism A B -> (A --> B)%cat := pr1. Definition isAdmissibleEpimorphism {M : ExactCategoryData} {B C:M} (p : B --> C) : hProp := ∃ A (i : A --> B), isExact2 i p. Definition AdmissibleEpimorphism {M : ExactCategoryData} (B C:M) : Type := ∑ (p : B --> C), isAdmissibleEpimorphism p. Coercion AdmEpiToMap {M : ExactCategoryData} {B C:M} : AdmissibleEpimorphism B C -> B --> C := pr1. Coercion AdmEpiToMap' {M : ExactCategoryData} {B C:M} : AdmissibleEpimorphism B C -> (B --> C)%cat := pr1. Lemma ExactToAdmMono {M : ExactCategoryData} {A B C:M} {i : A --> B} {p : B --> C} : isExact2 i p -> isAdmissibleMonomorphism i. Proof. intros e. exact (hinhpr(C,,p,,e)). Qed. Lemma ExactToAdmEpi {M : ExactCategoryData} {A B C:M} {i : A --> B} {p : B --> C} : isExact2 i p -> isAdmissibleEpimorphism p. Proof. intros e. exact (hinhpr(A,,i,,e)). Qed. (** The following definition is definition 2.1 from the paper of Bühler. *) Local Definition ExactCategoryProperties (M : ExactCategoryData) : hProp := ((∀ (P Q : MorphismPair M), MorphismPairIsomorphism P Q ⇒ isExact P ⇒ isExact Q) ∧ (∀ (P Q : MorphismPair M), MorphismPairIsomorphism Q P ⇒ isExact P ⇒ isExact Q)) ∧ ((∀ A:M, isAdmissibleMonomorphism (identity A)) ∧ (∀ A:M, isAdmissibleEpimorphism (identity A))) ∧ (∀ P : MorphismPair M, isExact P ⇒ isKernelCokernelPair (Mor1 P) (Mor2 P)) ∧ ((∀ (A B C:M) (f : A --> B) (g : B --> C), isAdmissibleMonomorphism f ⇒ isAdmissibleMonomorphism g ⇒ isAdmissibleMonomorphism (f · g)) ∧ (∀ (A B C:M) (f : A --> B) (g : B --> C), isAdmissibleEpimorphism f ⇒ isAdmissibleEpimorphism g ⇒ isAdmissibleEpimorphism (f · g))) ∧ ((∀ (A B C:M) (f : A --> B) (g : C --> B), isAdmissibleEpimorphism f ⇒ ∃ (PB : Pullback f g), isAdmissibleEpimorphism (PullbackPr2 PB)) ∧ (∀ (A B C:M) (f : B --> A) (g : B --> C), isAdmissibleMonomorphism f ⇒ ∃ (PO : Pushout f g), isAdmissibleMonomorphism (PushoutIn2 PO))). (** The following definition is from Higher Algebraic K-theory I, by Quillen. We prove below that the two definitions are equivalent. *) Local Definition ExactCategoryProperties_Quillen (M : ExactCategoryData) : hProp := (∀ (P Q:MorphismPair M), MorphismPairIsomorphism P Q ⇒ isExact P ⇒ isExact Q) ∧ (∀ (A B:M) (AB:BinDirectSum A B), isExact2 (to_In1 AB) (to_Pr2 AB)) ∧ (∀ P : MorphismPair M, isExact P ⇒ isKernel' (Mor1 P) (Mor2 P) ∧ isCokernel' (Mor1 P) (Mor2 P)) ∧ ((∀ (A B C:M) (f : A --> B) (g : B --> C), isAdmissibleMonomorphism f ⇒ isAdmissibleMonomorphism g ⇒ isAdmissibleMonomorphism (f · g)) ∧ (∀ (A B C:M) (f : A --> B) (g : B --> C), isAdmissibleEpimorphism f ⇒ isAdmissibleEpimorphism g ⇒ isAdmissibleEpimorphism (f · g))) ∧ ((∀ (A B C:M) (f : A --> B) (g : C --> B), isAdmissibleEpimorphism f ⇒ ∃ (PB : Pullback f g), isAdmissibleEpimorphism (PullbackPr2 PB)) ∧ (∀ (A B C:M) (f : B --> A) (g : B --> C), isAdmissibleMonomorphism f ⇒ ∃ (PO : Pushout f g), isAdmissibleMonomorphism (PushoutIn2 PO))) ∧ ((∀ (A B C:M) (i:A-->B) (j:B-->C), hasCokernel i ⇒ isAdmissibleMonomorphism (i·j) ⇒ isAdmissibleMonomorphism i) ∧ (∀ (A B C:M) (i:A-->B) (j:B-->C), hasKernel j ⇒ isAdmissibleEpimorphism (i·j) ⇒ isAdmissibleEpimorphism j)). Definition ExactCategory := ∑ (ME:ExactCategoryData), ExactCategoryProperties ME. Coercion ExactCategoryToData (M:ExactCategory) : ExactCategoryData := pr1 M. Definition make_ExactCategory (ME:ExactCategoryData) (p : ExactCategoryProperties ME) : ExactCategory := ME,,p. Definition isExactFunctor {M N:ExactCategory} (F : M ⟶ N) : hProp := ∀ (P : MorphismPair M), isExact P ⇒ isExact (applyFunctorToPair F P). Definition ExactFunctor (M N:ExactCategory) := ∑ F : M ⟶ N, isExactFunctor F. (* TO DO : show an exact functor is additive, or else include that as a condition. That includes showing it induces monoid functions on Hom groups. Start by defining preadditive functors and additive functors. *) Coercion ExactFunctorToFunctor {M N:ExactCategory} : ExactFunctor M N -> (M ⟶ N) := pr1. Definition ShortExactSequence (M:ExactCategory) := ∑ (P : MorphismPair M), isExact P. Coercion ShortExactSequenceToMorphismPair {M:ExactCategory} (P : ShortExactSequence M) : MorphismPair M := pr1 P. Definition ShortExactSequenceMap {M:ExactCategory} (P Q:ShortExactSequence M) := MorphismPairMap P Q. Definition applyFunctorToShortExactSequence {M N:ExactCategory} (F : ExactFunctor M N) : ShortExactSequence M -> ShortExactSequence N. Proof. intros E. exists (applyFunctorToPair F E). induction E as [E iE]. unfold ShortExactSequenceToMorphismPair,pr1. exact (pr2 F E iE). Defined. Definition composeExactFunctors {L M N:ExactCategory} : ExactFunctor L M -> ExactFunctor M N -> ExactFunctor L N. Proof. intros F G. exists (F ∙ G). exact (λ E e, pr2 G _ (pr2 F E e)). Defined. End theDefinition. Declare Scope excat. Delimit Scope excat with excat. Local Open Scope excat. Notation "A ↣ B" := (AdmissibleMonomorphism A B) : excat. Notation "B ↠ C" := (AdmissibleEpimorphism B C) : excat. Notation "F ∙ G" := (composeExactFunctors F G) : excat. Notation "M ⟶ N" := (ExactFunctor M N) : excat. Section ExactCategoryAccessFunctions. Context {M:ExactCategory}. Definition EC_IsomorphicToExact {P Q:MorphismPair M} : MorphismPairIsomorphism P Q ⇒ isExact P ⇒ isExact Q := pr112 M P Q. Definition EC_IsomorphicToExact' {P Q:MorphismPair M} : MorphismPairIsomorphism Q P ⇒ isExact P ⇒ isExact Q := pr212 M P Q. Definition EC_IdentityIsMono (A:M) : isAdmissibleMonomorphism (identity A) := pr1 (pr122 M) A. Definition IdentityMono (A:M) : AdmissibleMonomorphism A A := identity A,, EC_IdentityIsMono A. Definition EC_IdentityIsEpi (A:M) : isAdmissibleEpimorphism (identity A) := pr2 (pr122 M) A. Definition IdentityEpi (A:M) : AdmissibleEpimorphism A A := identity A,, EC_IdentityIsEpi A. Definition EC_ExactToKernelCokernel {P : MorphismPair M} : isExact P ⇒ isKernelCokernelPair (Mor1 P) (Mor2 P) := pr12 (pr22 M) P. Definition EC_ExactToKernel {P : MorphismPair M} : isExact P ⇒ isKernel' (Mor1 P) (Mor2 P) := λ i, (pr1 (EC_ExactToKernelCokernel i)). Definition EC_ExactToCokernel {P : MorphismPair M} : isExact P ⇒ isCokernel' (Mor1 P) (Mor2 P) := λ i, (pr2 (EC_ExactToKernelCokernel i)). Definition EC_ComposeMono {A B C:M} (f : A --> B) (g : B --> C) : isAdmissibleMonomorphism f -> isAdmissibleMonomorphism g -> isAdmissibleMonomorphism (f · g) := pr112 (pr222 M) A B C f g. Definition EC_ComposeEpi {A B C:M} (f : A --> B) (g : B --> C) : isAdmissibleEpimorphism f ⇒ isAdmissibleEpimorphism g ⇒ isAdmissibleEpimorphism (f · g) := pr212 (pr222 M) A B C f g. Definition EC_PullbackEpi {A B C:M} (f : A --> B) (g : C --> B) : isAdmissibleEpimorphism f ⇒ ∃ (PB : Pullback f g), isAdmissibleEpimorphism (PullbackPr2 PB) := pr122 (pr222 M) A B C f g. Definition EC_PushoutMono {A B C:M} (f : B --> A) (g : B --> C) : isAdmissibleMonomorphism f ⇒ ∃ (PO : Pushout f g), isAdmissibleMonomorphism (PushoutIn2 PO) := pr222 (pr222 M) A B C f g. End ExactCategoryAccessFunctions. Section OppositeExactCategory. Definition oppositeExactCategoryData (M:ExactCategoryData) : ExactCategoryData. Proof. exists (oppositeAdditiveCategory M). exact (λ p, @isExact M (opp_MorphismPair p)). Defined. Definition oppositeExactCategory (M:ExactCategory) : ExactCategory. Proof. use (make_ExactCategory (oppositeExactCategoryData M)). split. { split;intros P Q f. - exact (EC_IsomorphicToExact' (opp_MorphismPairIsomorphism f)). - exact (EC_IsomorphicToExact (opp_MorphismPairIsomorphism f)). } split. { split. - exact EC_IdentityIsEpi. - exact EC_IdentityIsMono. } split. { intros P i. exact (opposite_isKernelCokernelPair (EC_ExactToKernelCokernel i)). } split. { split. { intros A B C f g i j. exact (@EC_ComposeEpi M C B A g f j i). } { intros A B C f g i j. exact (@EC_ComposeMono M C B A g f j i). } } { split. { exact (@EC_PushoutMono M). } { exact (@EC_PullbackEpi M). } } Defined. End OppositeExactCategory. Notation "C '^op'" := (oppositeExactCategory C) (at level 3, format "C ^op") : excat. Section ExactCategoryFacts. Lemma ExactToMono {M : ExactCategory} {A B C:M} {i : A --> B} {p : B --> C} : isExact2 i p -> isMonic i. Proof. intros e. exact (KernelIsMonic i p (EC_ExactToKernel e)). Qed. Lemma ExactToEpi {M : ExactCategory} {A B C:M} {i : A --> B} {p : B --> C} : isExact2 i p -> isEpi p. Proof. intros e. refine (CokernelIsEpi i p (EC_ExactToCokernel e)). Qed. Lemma ExactSequenceFromMono {M : ExactCategory} {A B C:M} (i : A --> B) (p : B --> C) : isCokernel' i p -> isAdmissibleMonomorphism i -> isExact2 i p. Proof. intros co mo. apply (squash_to_hProp mo); clear mo; intros [C' [p' e]]. assert (co' := pr2 (EC_ExactToKernelCokernel e) : isCokernel' i p'). assert (R := iscontrpr1 (CokernelUniqueness co' co)). induction R as [R r]. use (EC_IsomorphicToExact _ e). exists (identity_z_iso _). exists (identity_z_iso _). exists R. split. - split. + exact (id_left _ @ ! id_right _). + exact (id_right _ @ ! id_left _). - split. + exact (id_left _ @ ! r). + exact (r @ !id_left _). Qed. Lemma ExactSequenceFromEpi {M : ExactCategory} {A B C:M} (i : A --> B) (p : B --> C) : isKernel' i p -> isAdmissibleEpimorphism p -> isExact2 i p. Proof. exact (ExactSequenceFromMono (M:=M^op) p i). Defined. Lemma ExactSequence10 {M : ExactCategory} (A:M) (Z:Zero M) : isExact2 (identity A) (0 : A --> Z). Proof. exact (ExactSequenceFromMono _ _ (pr2 (kerCoker10 Z A)) (EC_IdentityIsMono A)). Qed. Lemma ExactSequence01 {M : ExactCategory} (A:M) (Z:Zero M) : isExact2 (0 : Z --> A) (identity A). Proof. exact (ExactSequenceFromEpi _ _ (pr1 (kerCoker01 Z A)) (EC_IdentityIsEpi A)). Qed. Lemma FromZeroIsMono {M : ExactCategory} (Z:Zero M) (A:M) : isAdmissibleMonomorphism (0 : Z --> A). Proof. apply hinhpr. exists A. exists (identity A). use ExactSequence01. Defined. Definition MonoFromZero {M : ExactCategory} (Z:Zero M) (A:M) : Z ↣ A := (0 : Z --> A),,FromZeroIsMono Z A. Lemma ToZeroIsEpi {M : ExactCategory} (A:M) (Z:Zero M) : isAdmissibleEpimorphism (0 : A --> Z). Proof. apply hinhpr. exists A. exists (identity A). use ExactSequence10. Defined. Definition EpiToZero {M : ExactCategory} (A:M) (Z:Zero M) : A ↠ Z := (0 : A --> Z),,ToZeroIsEpi A Z. Goal ∏ (M:ExactCategory) (A:M) (Z:Zero M), EpiToZero A Z = MonoFromZero (M:=M^op) (Zero_opp M Z) A. Abort. Lemma IsomMono1 {M : ExactCategory} {A B B':M} (f : A --> B) (f' : A --> B') : IsoArrowFrom f f' -> isAdmissibleMonomorphism f -> isAdmissibleMonomorphism f'. Proof. intros [i I] E. apply (squash_to_hProp E); clear E; intros [C [p E]]. apply hinhpr. exists C. exists (z_iso_inv i · p). use (EC_IsomorphicToExact _ E). exists (identity_z_iso A). exists i. exists (identity_z_iso C). split; cbn. - split. + exact (id_left _ @ ! I). + exact (I @ ! id_left _). - split. + refine (assoc _ _ _ @ _ @ id_left _ @ ! id_right _). apply (maponpaths (λ k, k · p)). apply z_iso_inv_after_z_iso. + apply pathsinv0. refine (assoc _ _ _ @ _ @ id_left _ @ ! id_right _). apply (maponpaths (λ k, k · p)). apply z_iso_inv_after_z_iso. Qed. Lemma IsomEpi1 {M : ExactCategory} {A A' B:M} (f : A --> B) (f' : A' --> B) : IsoArrowTo f' f -> isAdmissibleEpimorphism f -> isAdmissibleEpimorphism f'. Proof. intros i e. exact (IsomMono1 (M:=M^op) f f' (opposite_IsoArrowTo i) e). Defined. Lemma IsomMono {M : ExactCategory} {A A' B B':M} (f : A --> B) (f' : A' --> B') : IsoArrow f f' -> isAdmissibleMonomorphism f -> isAdmissibleMonomorphism f'. Proof. intros [g [h e]] i. apply (squash_to_hProp i); clear i; intros [C [p E]]. apply hinhpr. exists C. exists (z_iso_inv h · p). use (EC_IsomorphicToExact _ E). simple refine (make_MorphismPairIsomorphism (make_MorphismPair f p) (make_MorphismPair f' (z_iso_inv h · p)) g h (identity_z_iso C) e _). refine (assoc _ _ _ @ maponpaths (postcomp_with p) _ @ id_left p @ ! id_right p). apply z_iso_inv_after_z_iso. Qed. Lemma IsomEpi {M : ExactCategory} {A A' B B':M} (f : A --> B) (f' : A' --> B') : IsoArrow f' f -> isAdmissibleEpimorphism f -> isAdmissibleEpimorphism f'. Proof. intros i. exact (IsomMono (M:=M^op) f f' (opposite_IsoArrow _ _ i)). Defined. Lemma PullbackEpiIsEpi {M : ExactCategory} {A B C:M} (f : A --> B) (g : C --> B) (pb : Pullback f g) : isAdmissibleEpimorphism f -> isAdmissibleEpimorphism (PullbackPr2 pb). (* dual needed *) Proof. intros fepi. assert (qb := EC_PullbackEpi f g fepi). apply (squash_to_hProp qb); clear qb; intros [qb epi2]. assert (I := pullbackiso2 pb qb). apply (IsomEpi1 _ _ I). exact epi2. Qed. Lemma IsPullbackEpiIsEpi {M : ExactCategory} {P A B C:M} {f : A --> B} {g : C --> B} {h : P --> A} {k : P --> C} : isPullback' (M:=M) f g h k -> isAdmissibleEpimorphism f -> isAdmissibleEpimorphism k. (* dual needed *) Proof. intros pb. exact (PullbackEpiIsEpi f g (make_Pullback _ (pr2 pb))). Qed. Lemma IsIsoIsMono {M : ExactCategory} {A B:M} (f:A-->B) : is_z_isomorphism f -> isAdmissibleMonomorphism f. Proof. intros i. use (IsomMono1 (identity A)). - use tpair. + exact (f,,i). + cbn. apply id_left. - apply EC_IdentityIsMono. Qed. Lemma IsoIsMono {M : ExactCategory} {A B:M} (f:z_iso A B) : isAdmissibleMonomorphism (z_iso_mor f). Proof. use IsIsoIsMono. apply f. Qed. Definition IsoToAdmMono {M : ExactCategory} {A B:M} (f:z_iso A B) : AdmissibleMonomorphism A B := z_iso_mor f,,IsoIsMono f. Lemma IsoIsEpi {M : ExactCategory} {A B:M} (f:z_iso A B) : isAdmissibleEpimorphism (z_iso_mor f). Proof. exact (IsoIsMono (M:=M^op) (opp_z_iso f)). Defined. Definition IsoToAdmEpi {M : ExactCategory} {A B:M} (f:z_iso A B) : AdmissibleEpimorphism A B := z_iso_mor f,,IsoIsEpi f. Lemma DirectSumToExact {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isExact2 (to_In1 S) (to_Pr2 S). Proof. use ExactSequenceFromEpi. { exact (PairToKernel (kerCokerDirectSum S)). } apply (squash_to_hProp (to_hasZero M)); intros Z. set (pb := DirectSumToPullback S Z). change (isAdmissibleEpimorphism (PullbackPr2 pb)). assert (Q := EC_PullbackEpi (0 : A --> Z) (0 : B --> Z) (ToZeroIsEpi A Z)). apply (squash_to_hProp Q); clear Q; intros [pb' R']. exact (IsomEpi1 (PullbackPr2 pb') (PullbackPr2 pb) (pullbackiso2 pb pb') R'). Qed. Lemma DirectSumToExact' {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isExact2 (to_In2 S) (to_Pr1 S). Proof. exact (DirectSumToExact (reverseBinDirectSum S)). Qed. Lemma In1IsAdmMono {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isAdmissibleMonomorphism (ι₁ : A --> S). Proof. exact (hinhpr (B,,to_Pr2 S,,DirectSumToExact S)). Qed. Lemma In2IsAdmMono {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isAdmissibleMonomorphism (ι₂ : B --> S). Proof. exact (hinhpr (A,,to_Pr1 S,,DirectSumToExact' S)). Qed. Lemma Pr1IsAdmEpi {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isAdmissibleEpimorphism (π₁ : S --> A). Proof. exact (hinhpr (B,,to_In2 S,,DirectSumToExact' S)). Qed. Lemma Pr2IsAdmEpi {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : isAdmissibleEpimorphism (π₂ : S --> B). Proof. exact (hinhpr (A,,to_In1 S,,DirectSumToExact S)). Qed. Definition In1AdmMono {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : AdmissibleMonomorphism A S := ι₁ ,, In1IsAdmMono S. Definition In2AdmMono {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : AdmissibleMonomorphism B S := ι₂ ,, In2IsAdmMono S. Definition Pr1AdmEpi {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : AdmissibleEpimorphism S A := π₁ ,, Pr1IsAdmEpi S. Definition Pr2AdmEpi {M : ExactCategory} {A B:M} (S:BinDirectSum A B) : AdmissibleEpimorphism S B := π₂ ,, Pr2IsAdmEpi S. Definition TrivialExactSequence {M : ExactCategory} (A:M) (Z:Zero M) : ShortExactSequence M. Proof. assert (Q := DirectSumToExact (TrivialDirectSum Z A)). exact (make_MorphismPair ι₁ π₂,, Q). Defined. Definition TrivialExactSequence' {M : ExactCategory} (Z:Zero M) (A:M) : ShortExactSequence M. Proof. assert (Q := DirectSumToExact (TrivialDirectSum' Z A)). exact (make_MorphismPair ι₁ π₂,, Q). Defined. Lemma ExactPushout {M : ExactCategory} {A B C A':M} (i : A --> B) (p : B --> C) (pr : isExact2 i p) (r : A --> A') : ∃ (po : Pushout i r), isExact2 (PushoutIn2 po) (pr1 (PairPushoutMap (EC_ExactToKernelCokernel pr) r po)). Proof. assert (I := ExactToAdmMono pr). assert (R := EC_PushoutMono i r I). apply (squash_to_hProp R); clear R; intros [po J]; apply hinhpr. exists po. use ExactSequenceFromMono. { exact (PairPushoutCokernel i p (EC_ExactToKernelCokernel pr) r po). } exact J. Qed. Lemma ExactPushout' {M : ExactCategory} {A B C A':M} (i : A --> B) (p : B --> C) (pr : isExact2 i p) (r : A --> A') : ∃ (B':M) (i':A'-->B') (s:B-->B') (p':B'-->C), s·p' = p ∧ isPushout' (M:=M) i r s i' ∧ isExact2 i' p'. Proof. assert (I := ExactToAdmMono pr). assert (R := EC_PushoutMono i r I). use (hinhfun _ R); clear R; intros [po J]. set (pomap := PairPushoutMap (EC_ExactToKernelCokernel pr) r po). set (p' := pr1 pomap). exists po. exists (PushoutIn2 po). exists (PushoutIn1 po). exists p'. split. { exact (pr12 pomap). } split. { apply Pushout_to_isPushout'. } { use ExactSequenceFromMono. { exact (PairPushoutCokernel i p (EC_ExactToKernelCokernel pr) r po). } exact J. } Qed. Lemma ExactPullback {M : ExactCategory} {A B C A':M} (i : A <-- B) (p : B <-- C) (pr : isExact2 p i) (r : A <-- A') : ∃ (pb : Pullback i r), isExact2 (pr1 (PairPullbackMap (EC_ExactToKernelCokernel pr) r pb)) (PullbackPr2 pb). Proof. assert (I := hinhpr (C ,, p ,, pr) : isAdmissibleEpimorphism i). assert (R := EC_PullbackEpi i r I). apply (squash_to_hProp R); clear R; intros [pb J]; apply hinhpr. exists pb. use ExactSequenceFromEpi. { exact (PairPullbackKernel i p (EC_ExactToKernelCokernel pr) r pb). } exact J. Qed. Lemma ExactPullback' {M : ExactCategory} {A B C A':M} (i : A <-- B) (p : B <-- C) (pr : isExact2 p i) (r : A <-- A') : ∃ (B':M) (i':A'<--B') (s:B<--B') (p':B'<--C), s∘p' = p ∧ isPullback' (M:=M) i r s i' ∧ isExact2 p' i'. Proof. assert (I := ExactToAdmEpi pr). assert (R := EC_PullbackEpi i r I). use (hinhfun _ R); clear R; intros [pb J]. set (pbmap := PairPullbackMap (EC_ExactToKernelCokernel pr) r pb). set (p' := pr1 pbmap). exists pb. exists (PullbackPr2 pb). exists (PullbackPr1 pb). exists p'. split. { exact (pr12 pbmap). } split. { apply Pullback_to_isPullback'. } { use ExactSequenceFromEpi. { exact (PairPullbackKernel i p (EC_ExactToKernelCokernel pr) r pb). } exact J. } Qed. Lemma MonicAdmEpiIsIso {M : ExactCategory} {A B:M} (p : A ↠ B) : isMonic p -> is_z_isomorphism p. Proof. induction p as [p E]. cbn. intros I. apply (squash_to_prop E). { apply (isaprop_is_z_isomorphism (C:=M)). } clear E; intros [K [i E]]. assert (Q := EC_ExactToKernelCokernel E); clear E. induction Q as [ke co]; change (hProptoType (isKernel' i p)) in ke; change (hProptoType (isCokernel' i p)) in co. assert (Q : i = 0). { use (I K i 0). exact (pr1 ke @ ! zeroLeft _). } clear I ke. induction (!Q); clear Q. exact (CokernelOfZeroMapIsIso p co). Qed. Lemma EpiAdmMonoIsIso {M : ExactCategory} {A B:M} (i : A ↣ B) : isEpi i -> is_z_isomorphism i. Proof. intros e. exact (opp_is_z_isomorphism _ (MonicAdmEpiIsIso (M:=M^op) i e)). Defined. Lemma MonoPlusIdentity {M : ExactCategory} {A B:M} (f:A-->B) (C:M) (AC : BinDirectSum A C) (BC : BinDirectSum B C) : isAdmissibleMonomorphism f -> isAdmissibleMonomorphism (directSumMap AC BC f (identity C)). Proof. (* see Bühler's 2.9 *) intro i. apply (squash_to_hProp i). intros [D [p j]]. apply hinhpr. exists D. exists (π₁ · p). apply ExactSequenceFromEpi. 2:{ apply EC_ComposeEpi. - apply Pr1IsAdmEpi. - exact (hinhpr(A,,f,,j)). } apply (squash_to_hProp (to_hasZero M)); intros Z. apply (squash_to_hProp (to_hasBinDirectSums D Z)); intros DZ. assert (m := pr1 (SumOfKernelCokernelPairs AC BC DZ (EC_ExactToKernelCokernel j : isKernelCokernelPair f p) (kerCoker10 Z C : isKernelCokernelPair (identity C) 0))). assert (R : directSumMap BC DZ p 0 · to_Pr1 DZ = to_Pr1 BC · p). { apply directSumMapEqPr1. } induction R. apply IsoWithKernel. { exact m. } exists (ι₁). split. { refine (! runax (_ --> _) _ @ ! _ @ to_BinOpId'' _). apply maponpaths. apply ThroughZeroIsZero. } { refine (to_IdIn1 DZ). } Qed. Lemma EpiPlusIdentity {M : ExactCategory} {A B:M} (f:A-->B) (C:M) (AC : BinDirectSum A C) (BC : BinDirectSum B C) : isAdmissibleEpimorphism f -> isAdmissibleEpimorphism (directSumMap AC BC f (identity C)). Proof. intro i. rewrite <- opposite_directSumMap'. exact (MonoPlusIdentity (M:=M^op) f C (oppositeBinDirectSum BC) (oppositeBinDirectSum AC) i). Defined. Lemma IdentityPlusMono {M : ExactCategory} {B C:M} (A:M) (f:B-->C) (AB : BinDirectSum A B) (AC : BinDirectSum A C) : isAdmissibleMonomorphism f -> isAdmissibleMonomorphism (directSumMap AB AC (identity A) f). Proof. intros i. use (IsomMono (directSumMap (reverseBinDirectSum AB) (reverseBinDirectSum AC) f (identity A)) (directSumMap AB AC (identity A) f)). - exists (SwitchIso _ _ _ _). exists (SwitchIso _ _ _ _). apply SwitchMapMapEqn. - apply MonoPlusIdentity. exact i. Defined. Lemma IdentityPlusEpi {M : ExactCategory} {B C:M} (A:M) (f:B-->C) (AB : BinDirectSum A B) (AC : BinDirectSum A C) : isAdmissibleEpimorphism f -> isAdmissibleEpimorphism (directSumMap AB AC (identity A) f). Proof. intros i. use (IsomEpi (directSumMap (reverseBinDirectSum AB) (reverseBinDirectSum AC) f (identity A)) (directSumMap AB AC (identity A) f)). - exists (SwitchIso _ _ _ _). exists (SwitchIso _ _ _ _). apply SwitchMapMapEqn. - apply EpiPlusIdentity. exact i. Defined. Lemma SumOfExactSequences {M:ExactCategory} {A B C A' B' C':M} (AA' : BinDirectSum A A') (BB' : BinDirectSum B B') (CC' : BinDirectSum C C') {f : A --> B} {g : B --> C} {f' : A' --> B'} {g' : B' --> C'} : isExact2 f g -> isExact2 f' g' -> isExact2 (directSumMap AA' BB' f f') (directSumMap BB' CC' g g'). Proof. (* see Bühler's 2.9 *) intros i i'. apply ExactSequenceFromMono. { use SumOfCokernels. - exact (EC_ExactToCokernel i). - exact (EC_ExactToCokernel i'). } apply (squash_to_hProp (to_hasBinDirectSums A B')); intros AB'. set (j := directSumMap AB' BB' f (identity B')). set (k := directSumMap AA' AB' (identity A) f'). assert (kj : k · j = directSumMap AA' BB' f f'). { apply ToBinDirectSumUnique. - refine (! assoc _ _ _ @ _). intermediate_path (k · (π₁ · f)). + apply maponpaths. apply directSumMapEqPr1. + refine (assoc _ _ _ @ _). apply (maponpaths (postcomp_with _)). exact (directSumMapEqPr1 @ id_right _). - refine (! assoc _ _ _ @ _). intermediate_path (k · (π₂ · (identity B'))). + apply maponpaths. apply directSumMapEqPr2. + refine (assoc _ _ _ @ id_right _ @ _). apply directSumMapEqPr2. } induction kj. use (EC_ComposeMono k j). - apply IdentityPlusMono. exact (ExactToAdmMono i'). - apply MonoPlusIdentity. exact (ExactToAdmMono i). Qed. Lemma AdmMonoEnlargement {M:ExactCategory} {A B C:M} (BC : BinDirectSum B C) (i:A-->B) (f:A-->C) : isAdmissibleMonomorphism i -> isAdmissibleMonomorphism (ToBinDirectSum BC i f). Proof. (* see Bühler's 2.12 *) intros I. (* write the map as a composite of three maps *) apply (squash_to_hProp (to_hasBinDirectSums A C)); intros AC. assert (e : ToBinDirectSum BC i f = ι₁ · (1 + π₁·f·ι₂) · (directSumMap AC _ i 1)). { apply ToBinDirectSumsEq. - rewrite BinDirectSumPr1Commutes. rewrite assoc'. unfold directSumMap. unfold BinDirectSumIndAr. rewrite BinDirectSumPr1Commutes. rewrite assoc. rewrite rightDistribute. rewrite 2 leftDistribute. rewrite id_right. rewrite (to_IdIn1 AC). rewrite id_left. refine (! runax (A-->B) _ @ _). apply maponpaths. rewrite assoc. rewrite (assoc' _ _ π₁). rewrite (to_Unel2 AC). unfold to_unel. rewrite zeroRight, zeroLeft. reflexivity. - rewrite BinDirectSumPr2Commutes. rewrite assoc'. unfold directSumMap. unfold BinDirectSumIndAr. rewrite BinDirectSumPr2Commutes. rewrite assoc. rewrite rightDistribute. rewrite 2 leftDistribute. rewrite 2 id_right. rewrite (to_Unel1 AC). unfold to_unel. rewrite lunax. rewrite id_right. rewrite 2 assoc. rewrite (to_IdIn1 AC). rewrite id_left. rewrite assoc'. rewrite (to_IdIn2 AC). rewrite id_right. reflexivity. } induction (!e); clear e. apply EC_ComposeMono. - apply EC_ComposeMono. + apply In1IsAdmMono. + apply IsIsoIsMono. apply elem21_isiso. - now apply MonoPlusIdentity. Qed. Lemma SumOfAdmissibleEpis {M:ExactCategory} {A B A' B':M} (AA' : BinDirectSum A A') (BB' : BinDirectSum B B') (f : A --> B) (f' : A' --> B') : isAdmissibleEpimorphism f -> isAdmissibleEpimorphism f' -> isAdmissibleEpimorphism (directSumMap AA' BB' f f'). Proof. intros e e'. apply (squash_to_hProp e); clear e; intros [C [g e]]. apply (squash_to_hProp e'); clear e'; intros [C' [g' e']]. apply (squash_to_hProp (to_hasBinDirectSums C C')); intros CC'. exact (ExactToAdmEpi (SumOfExactSequences CC' _ _ e e')). Qed. Lemma SumOfAdmissibleMonos {M:ExactCategory} {A B A' B':M} (AA' : BinDirectSum A A') (BB' : BinDirectSum B B') (f : A --> B) (f' : A' --> B') : isAdmissibleMonomorphism f -> isAdmissibleMonomorphism f' -> isAdmissibleMonomorphism (directSumMap AA' BB' f f'). Proof. intros e e'. apply (squash_to_hProp e); clear e; intros [C [g e]]. apply (squash_to_hProp e'); clear e'; intros [C' [g' e']]. apply (squash_to_hProp (to_hasBinDirectSums C C')); intros CC'. exact (ExactToAdmMono (SumOfExactSequences _ _ CC' e e')). Qed. Lemma MapPlusIdentityToCommSq {M:ExactCategory} {A B:M} (f:A-->B) (C:M) (AC : BinDirectSum A C) (BC : BinDirectSum B C) : f · ι₁ = ι₁ · (directSumMap AC BC f (identity C)). Proof. apply ToBinDirectSumsEq. - rewrite assoc'. rewrite (to_IdIn1 BC). rewrite id_right. unfold directSumMap. unfold BinDirectSumIndAr. rewrite assoc'. rewrite BinDirectSumPr1Commutes. rewrite assoc. rewrite (to_IdIn1 AC). rewrite id_left. reflexivity. - rewrite assoc'. rewrite (to_Unel1 BC). unfold to_unel. rewrite zeroRight. unfold directSumMap, BinDirectSumIndAr. rewrite assoc'. rewrite BinDirectSumPr2Commutes. rewrite id_right. apply pathsinv0. use (to_Unel1 AC). Qed. Lemma KernelPlusIdentity {M:ExactCategory} {A B C:M} (f:A-->B) (g:B-->C) (D:M) (BD : BinDirectSum B D) (CD : BinDirectSum C D) : isKernel' (f · ι₁) (directSumMap BD CD g (identity D)) -> isKernel' f g. Proof. intros K. apply makeMonicKernel. - exact (isMonic_postcomp _ _ _ (KernelIsMonic _ _ K)). - use (to_In1_isMonic _ CD). rewrite zeroLeft. rewrite assoc'. assert (Q := pr1 K); simpl in Q. rewrite assoc' in Q. rewrite directSumMapEqIn1 in Q. exact Q. - intros T h eqn. assert (E : h · ι₁ · directSumMap BD CD g (identity D) = 0). { rewrite assoc'. rewrite directSumMapEqIn1. rewrite assoc. refine (maponpaths (λ r, r·ι₁) eqn @ _). apply zeroLeft. } assert (Q := iscontrpr1 (pr2 K T (h·ι₁) E)); simpl in Q. induction Q as [p e]. exists p. rewrite assoc in e. apply (to_In1_isMonic _ _ _ _ _ e). Qed. Lemma CokernelPlusIdentity {M:ExactCategory} {A B C:M} (f:A-->B) (g:B-->C) (D:M) (BD : BinDirectSum B D) (CD : BinDirectSum C D): isCokernel' f g -> isCokernel' (f · ι₁) (directSumMap BD CD g (identity D)). Proof. intros ic. split. { rewrite assoc'. rewrite directSumMapEqIn1. rewrite assoc. rewrite (pr1 ic). apply zeroLeft. } intros T h u. apply iscontraprop1. { apply invproofirrelevance. intros [r r'] [s s']. apply subtypePath_prop; cbn. assert (Q := r' @ ! s'); clear r' s' u h. apply FromBinDirectSumsEq. - assert (L := maponpaths (λ w, ι₁ · w) Q); clear Q. simpl in L. rewrite 2 assoc in L. rewrite directSumMapEqIn1 in L. rewrite 2 assoc' in L. exact (CokernelIsEpi _ g ic _ _ _ L). - assert (L := maponpaths (λ w, ι₂ · w) Q); clear Q. simpl in L. rewrite 2 assoc in L. rewrite directSumMapEqIn2 in L. rewrite 2 assoc' in L. rewrite 2 id_left in L. exact L. } assert (Q := iscontrpr1 (pr2 ic _ _ (assoc _ _ _ @ u))). induction Q as [q Q]. exists (π₁ · q + π₂ · ι₂ · h). rewrite rightDistribute. rewrite assoc. rewrite assoc. rewrite assoc. unfold directSumMap. unfold BinDirectSumIndAr. rewrite BinDirectSumPr1Commutes,BinDirectSumPr2Commutes. rewrite id_right. rewrite assoc'. rewrite Q. rewrite assoc. rewrite <- leftDistribute. refine (_ @ id_left _). apply (maponpaths (λ w, w·h)). use to_BinOpId''. Qed. Lemma MapPlusIdentityToPullback {M:ExactCategory} {A B:M} (f:A-->B) (C:M) (AC : BinDirectSum A C) (BC : BinDirectSum B C) : isPullback (MapPlusIdentityToCommSq f C AC BC). Proof. intros T g h e. apply iscontraprop1. - apply invproofirrelevance. intros [p [P P']] [q [Q Q']]. apply subtypePath. { intros r. apply isapropdirprod; apply to_has_homsets. } cbn. clear P Q. refine (! id_right _ @ _ @ id_right _). rewrite <- (to_IdIn1 AC). rewrite 2 assoc. induction (!P'), (!Q'). reflexivity. - exists (h · π₁). split. + refine (_ @ id_right _). rewrite <- (to_IdIn1 BC). rewrite (assoc g). rewrite e. rewrite (assoc' h _ π₁). unfold directSumMap. unfold BinDirectSumIndAr. rewrite BinDirectSumPr1Commutes. rewrite assoc. reflexivity. + refine (_ @ id_right _). rewrite <- (to_BinOpId' AC). rewrite rightDistribute. rewrite assoc. refine (! runax (Hom_add _ _ _) _ @ _). apply maponpaths. rewrite assoc. apply pathsinv0. assert (K : h · π₂ = 0). { refine ( _ @ maponpaths (λ w, w · π₂) (!e) @ _ ). - rewrite assoc'. unfold directSumMap. unfold BinDirectSumIndAr. rewrite BinDirectSumPr2Commutes. rewrite id_right. reflexivity. - rewrite assoc'. rewrite (to_Unel1 BC). unfold to_unel. apply zeroRight. } rewrite K. apply zeroLeft. Qed. (** The "obscure" axiom c of Quillen. *) Lemma AdmMonoFromComposite {M:ExactCategory} {A B C:M} (i:A-->B) (j:B-->C) : hasCokernel i -> isAdmissibleMonomorphism (i·j) -> isAdmissibleMonomorphism i. Proof. (* see Bühler's 2.16 *) intros hc im. apply (squash_to_hProp (to_hasBinDirectSums C B)); intros CB. apply (squash_to_hProp (to_hasBinDirectSums B C)); intros BC. set (q := ToBinDirectSum CB (i · j) i). assert (s := AdmMonoEnlargement _ (i·j) i im : isAdmissibleMonomorphism q); clear im. assert (e : q · elem12 _ (grinv j) = ToBinDirectSum CB 0 i). { apply ToBinDirectSumsEq. - rewrite BinDirectSumPr1Commutes. unfold elem12. rewrite rightDistribute, leftDistribute. rewrite id_right. rewrite (assoc' π₂). rewrite (assoc q). rewrite (assoc (q · π₂)). rewrite (assoc' _ _ π₁). rewrite (to_IdIn1 CB). rewrite id_right. rewrite rightMinus. unfold q. rewrite BinDirectSumPr1Commutes, BinDirectSumPr2Commutes. apply (grrinvax (Hom_add _ _ _)). - rewrite BinDirectSumPr2Commutes. unfold elem12. rewrite rightDistribute, leftDistribute. rewrite id_right. rewrite assoc. rewrite (assoc' _ _ π₂). rewrite (to_Unel1 CB); unfold to_unel. rewrite zeroRight. rewrite runax. unfold q. rewrite BinDirectSumPr2Commutes. reflexivity. } assert (e' : q · elem12 _ (grinv j) · SwitchMap _ _ _ _ = ToBinDirectSum BC i 0). { rewrite e. apply SwitchMapEqnTo. } assert (l : isAdmissibleMonomorphism (ToBinDirectSum BC i 0)). { induction e'. apply EC_ComposeMono. - apply EC_ComposeMono. + exact s. + apply IsIsoIsMono. apply elem12_isiso. - apply IsIsoIsMono. apply (SwitchIso C B). } clear e' e s q. apply (squash_to_hProp hc); clear hc; intros [D [k ic]]. apply (squash_to_hProp (to_hasBinDirectSums D C)); intros DC. assert (PB := is_symmetric_isPullback _ (MapPlusIdentityToPullback k C BC DC)). assert (co := CokernelPlusIdentity i k C BC DC ic). assert (es := ExactSequenceFromMono _ _ co); clear co. assert (t : i · to_In1 BC = ToBinDirectSum BC i 0). { rewrite <- ToBinDirectSumFormulaUnique. unfold ToBinDirectSumFormula. rewrite rewrite_op. rewrite zeroLeft, runax. reflexivity. } assert (l' : isAdmissibleMonomorphism (i · to_In1 BC)). { induction (!t). exact l. } clear l t. assert (ee := es l'); clear es l'. use (ExactToAdmMono (p:=k)). use (ExactSequenceFromEpi i k). - use KernelPlusIdentity. 4: exact (EC_ExactToKernel ee). - use (IsPullbackEpiIsEpi (_,,PB)). exact (ExactToAdmEpi ee). Qed. Lemma AdmEpiFromComposite {M:ExactCategory} {A B C:M} (i:A-->B) (j:B-->C) : hasKernel j -> isAdmissibleEpimorphism (i·j) -> isAdmissibleEpimorphism j. Proof. exact (AdmMonoFromComposite (M:=M^op) j i). Qed. Section Tmp. Lemma CokernelSequence {M:ExactCategory} {A B C P R:M} (i : A --> B) (j : B --> C) (p : B --> P) (q : C --> R) : isExact2 i p -> isExact2 j q -> ∃ Q (s : C --> Q) (k : P --> Q) (r : Q --> R), isExact2 (i·j) s ∧ isExact2 k r ∧ isPushout' (M:=M) j p s k ∧ s · r = q. Proof. intros ip jq. assert (co := EC_ExactToCokernel ip : isCokernel' i p). assert (b := EC_ExactToCokernel jq : isCokernel' j q). assert (I := ExactToAdmMono ip). assert (J := ExactToAdmMono jq). assert (IJ := EC_ComposeMono _ _ I J). induction b as [a co']. assert (ijq : i · (j · q) = 0). { rewrite a. apply zeroRight. } assert (po := EC_PushoutMono j p (ExactToAdmMono jq)). use (hinhfun _ po); clear po; intros [[[Q [s k]] [e1 po]] K]. change (isPushout j p s k e1) in po; change (hProptoType (isAdmissibleMonomorphism k)) in K; change (hProptoType (j · s = p · k)) in e1. assert (L := PushoutCokernel _ _ _ _ _ co (_,,po)). exists Q. exists s. exists k. assert (e2 : j · q = p · 0). { rewrite a. now rewrite zeroRight. } assert (PO := iscontrpr1 (po R q 0 e2)). induction PO as [u [e3 e4]]. exists u. assert (ijs := ExactSequenceFromMono (i·j) s L IJ). exists ijs. split. { use (ExactSequenceFromMono k u _ K). exists e4. intros T h e0. assert (e5 : j · (s · h) = 0). { rewrite assoc. rewrite e1. rewrite assoc'. rewrite e0. now rewrite zeroRight. } assert (W := co' T (s·h) e5); cbn in W. use (iscontrweqf _ W). apply weqfibtototal; intros l. apply weqiff. rewrite <- e3. rewrite assoc'. split. { intros e. now apply (CokernelIsEpi (i·j) s (EC_ExactToCokernel ijs)). } { intros e. now apply maponpaths. } + apply to_has_homsets. + apply to_has_homsets. } split. - exists e1. exact po. - exact e3. Defined. End Tmp. Lemma KernelSequence {M:ExactCategory} {A B C P R:M} (i : B --> A) (j : C --> B) (p : P --> B) (q : R --> C) : isExact2 p i -> isExact2 q j -> ∃ Q (s : Q --> C) (k : Q --> P) (r : R --> Q), isExact2 s (j·i) ∧ isExact2 r k ∧ isPullback' (M:=M) j p s k ∧ r · s = q. Proof. exact (CokernelSequence (M := oppositeExactCategory M) i j p q). Defined. Lemma ExactIso3 {M:ExactCategory} {A B C C':M} (i:A-->B) (p:B-->C) (t:z_iso C C') : isExact2 i p -> isExact2 i (p·t). Proof. intros ex. use (EC_IsomorphicToExact _ ex). exists (identity_z_iso A). exists (identity_z_iso B). exists t. repeat split;cbn. - now rewrite id_left, id_right. - now rewrite id_left, id_right. - apply id_left. - apply pathsinv0, id_left. Qed. Lemma ExactIso2 {M:ExactCategory} {A B C B':M} (i:A-->B) (p:B-->C) (t:z_iso B B') : isExact2 i p -> isExact2 (i · t) (z_iso_inv t · p). Proof. intros ex. use (EC_IsomorphicToExact _ ex). exists (identity_z_iso A). exists t. exists (identity_z_iso C). repeat split;cbn. - exact (id_left _). - exact (! id_left _). - rewrite assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. reflexivity. - rewrite assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. reflexivity. Qed. Lemma ExactIso1 {M:ExactCategory} {A' A B C:M} (t:z_iso A' A) (i:A-->B) (p:B-->C) : isExact2 i p -> isExact2 (t·i) p. Proof. exact (ExactIso3 (M:=oppositeExactCategory M) p i (opp_z_iso t)). Defined. End ExactCategoryFacts. Section EquivalenceOfTwoDefinitions. Theorem EquivalenceOfTwoDefinitions (D:ExactCategoryData) : ExactCategoryProperties D ⇔ ExactCategoryProperties_Quillen D. Proof. split. { intros prop. set (M := (D,,prop) : ExactCategory). split. { exact (@EC_IsomorphicToExact M). } split. { exact (@DirectSumToExact M). } split. { exact (@EC_ExactToKernelCokernel M). } split. { split. { exact (@EC_ComposeMono M). } { exact (@EC_ComposeEpi M). } } split. { split. { exact (@EC_PullbackEpi M). } { exact (@EC_PushoutMono M). } } { split. { exact (@AdmMonoFromComposite M). } { exact (@AdmEpiFromComposite M). } } } { intros [P1 [P2 [P3 [[P4 P4'] [[P5 P5'] [P6 P7]]]]]]. split. { split. { exact P1. } { intros P Q i. exact (P1 P Q (InverseMorphismPairIsomorphism i)). } } { split. { split. { intros A. apply (squash_to_hProp (to_hasZero D)); intros Z. apply hinhpr. exists Z. set (Q := TrivialDirectSum Z A). exists (to_Pr2 Q). exact (P2 A Z Q). } { intros A. apply (squash_to_hProp (to_hasZero D)); intros Z. apply hinhpr. exists Z. set (Q := TrivialDirectSum' Z A). exists (to_In1 Q). exact (P2 Z A Q). } } split. { exact P3. } split. { split. { exact P4. } { exact P4'. } } split. { exact P5. } { exact P5'. } } } Defined. End EquivalenceOfTwoDefinitions. Section SplitSequences. Definition isSplit2 {M:PreAdditive} {A B C:M} (i:A-->B) (q:B-->C) : hProp := ∃ (p:A<--B) (j:B<--C), isBinDirectSum i j p q. Lemma commax_hom {M:PreAdditive} {A B:M} (f g:A-->B) : f+g = g+f. Proof. exact (commax (A-->B) f g). Qed. Section Foo. Goal ∏ {M:PreAdditive} {A B C:M} (i:A-->B) (p:B-->C), isSplit2 (M:=M) i p = isSplit2 (M := oppositePreAdditive M) p i. Proof. Fail reflexivity. intros M A B C k r. unfold isSplit2, isBinDirectSum; cbn; rewrite rewrite_op. (* do we need this? *) Abort. End Foo. Lemma opposite_isSplit2 {M:PreAdditive} {A B C:M} (i:A-->B) (p:B-->C) : isSplit2 i p -> isSplit2 (M := oppositePreAdditive M) p i. Proof. intros s. Fail exact s. (* sigh *) use (hinhfun _ s); intros [q [j jq]]. exists j. exists q. exists (to_IdIn2 jq). exists (to_IdIn1 jq). exists (to_Unel1 jq). exists (to_Unel2 jq). rewrite commax_hom. exact (to_BinOpId' jq). Qed. Definition isSplit {M:PreAdditive} (P : MorphismPair M) : hProp := isSplit2 (Mor1 P) (Mor2 P). Lemma opposite_isSplit {M:PreAdditive} (P : MorphismPair M) : isSplit P -> isSplit (M:=oppositePreAdditive M) (MorphismPair_opp P). Proof. exact (opposite_isSplit2 _ _). Qed. Definition isSplitMonomorphism {M:PreAdditive} {A B:M} (i : A --> B) : hProp := ∃ C (p : B --> C), isSplit2 i p. Definition isSplitEpimorphism {M:PreAdditive} {B C:M} (p : B --> C) : hProp := ∃ A (i : A --> B), isSplit2 i p. Lemma opposite_isSplitMonomorphism {M:PreAdditive} {A B:M} (i : A --> B) : isSplitMonomorphism i -> isSplitEpimorphism (M:=oppositePreAdditive M) i. Proof. intros s. use (hinhfun _ s); clear s. intros [C [p s]]. exists C. exists p. exact (opposite_isSplit2 _ _ s). Qed. Lemma opposite_isSplitEpimorphism {M:PreAdditive} {A B:M} (p : A --> B) : isSplitEpimorphism p -> isSplitMonomorphism (M:=oppositePreAdditive M) p. Proof. intros s. use (hinhfun _ s); clear s. intros [C [i s]]. exists C. exists i. exact (opposite_isSplit2 _ _ s). Qed. Lemma DirectSumToSplit {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) : isSplit2 (to_In1 AB) (to_Pr2 AB). Proof. exact (hinhpr (π₁,, ι₂,, BinDirectSum_isBinDirectSum M AB)). Qed. Lemma DirectSumToSplit' {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) : isSplit2 (to_In2 AB) (to_Pr1 AB). Proof. exact (hinhpr(π₂,,ι₁,,BinDirectSum_isBinDirectSum M (reverseBinDirectSum AB))). Qed. Lemma IsomorphicToSplit {M:PreAdditive} (P Q : MorphismPair M) : MorphismPairIsomorphism P Q ⇒ isSplit P ⇒ isSplit Q. Proof. intros [f' [f [f'' [[e _] [e' _]]]]] ex. apply (squash_to_hProp ex); clear ex; intros [q [j su]]; apply hinhpr. exists (z_iso_inv f · q · f'). exists (z_iso_inv f'' · j · f). split. { intermediate_path (z_iso_inv f' · Mor1 P · q · f'). { rewrite 2 assoc. apply (maponpaths (λ k, k·f')). apply (maponpaths (λ k, k·q)). apply pathsinv0. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. exact e. } { rewrite 2 assoc'. rewrite (assoc _ q _). intermediate_path (z_iso_inv f' · (identity _ · f')). { apply maponpaths. apply (maponpaths (λ k, k·f')). exact (to_IdIn1 su). } { rewrite id_left. apply z_iso_after_z_iso_inv. } } } split. { rewrite assoc'. rewrite e'. rewrite assoc. rewrite (assoc' _ j _). apply wrap_inverse. apply (to_IdIn2 su). } split. { assert (r := to_Unel1 su); unfold to_unel in r. assert (r' := maponpaths (λ t, t · f'') r); cbn in r'; clear r. rewrite assoc' in r'. rewrite <- e' in r'. rewrite assoc in r'. rewrite <- e in r'. assert (r'' := maponpaths (λ t, z_iso_inv f' · t) r'); clear r'; cbn in r''. rewrite 2 assoc in r''. rewrite z_iso_after_z_iso_inv in r''. rewrite assoc' in r''. rewrite id_left in r''. rewrite zeroLeft,zeroRight in r''. exact r''. } split. { rewrite 2 assoc. rewrite (assoc' _ f _). rewrite z_iso_inv_after_z_iso. rewrite id_right. rewrite (assoc' _ j _). rewrite (to_Unel2 su). unfold to_unel. rewrite zeroRight, zeroLeft. reflexivity. } { apply (cancel_z_iso' f). rewrite id_right. rewrite rightDistribute. rewrite 3 (assoc f). rewrite z_iso_inv_after_z_iso, id_left. rewrite assoc'. rewrite e. rewrite assoc. rewrite (assoc f). rewrite e'. rewrite (assoc' _ f''). rewrite 2 (assoc f''). rewrite z_iso_inv_after_z_iso, id_left. rewrite assoc. rewrite <- leftDistribute. rewrite (to_BinOpId' su). rewrite id_left. reflexivity. } Qed. Lemma DirectSumToKernel {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) : isKernel' (to_In1 AB) (to_Pr2 AB). Proof. apply makeMonicKernel. - apply to_In1_isMonic. - exact (to_Unel1 AB). - intros T h e. exists (h · π₁). refine (_ @ id_right _). rewrite <- (to_BinOpId AB). rewrite rewrite_op. rewrite rightDistribute. rewrite assoc'. rewrite (assoc _ π₂ _). rewrite e. rewrite zeroLeft. rewrite runax. reflexivity. Defined. Lemma DirectSumToCokernel {M:PreAdditive} {A B:M} (AB : BinDirectSum A B) : isCokernel' (to_In1 AB) (to_Pr2 AB). Proof. apply makeEpiCokernel. - apply to_Pr2_isEpi. - exact (to_Unel1 AB). - intros T h e. exists (ι₂ · h). refine (_ @ id_left _). rewrite <- (to_BinOpId AB). rewrite rewrite_op. rewrite leftDistribute. rewrite assoc. rewrite (assoc' _ ι₁ _). rewrite e. rewrite zeroRight. rewrite lunax. reflexivity. Defined. Lemma isSplitToKernelCokernelPair {M:PreAdditive} {A B C:M} (i:A-->B) (p:B-->C) : isSplit2 i p -> isKernelCokernelPair i p. Proof. intros sp. apply (squash_to_hProp sp); clear sp; intros [j [q issum]]. set (S := make_BinDirectSum _ _ _ _ _ _ _ _ issum). exact (DirectSumToKernel S,,DirectSumToCokernel S). Qed. Lemma ComposeSplitMono {M:AdditiveCategory} {A B C : M} (i : A --> B) (j : B --> C) : isSplitMonomorphism i ⇒ isSplitMonomorphism j ⇒ isSplitMonomorphism (i · j). Proof. intros s t. apply (squash_to_hProp s); clear s; intros [P [p ip]];cbn in P. apply (squash_to_hProp ip); clear ip; intros [p' [i' ip]]. change (hProptoType (isBinDirectSum i i' p' p)) in ip. apply (squash_to_hProp t); clear t; intros [Q [q jq]];cbn in Q. apply (squash_to_hProp jq); clear jq; intros [q' [j' jq]]. change (hProptoType (isBinDirectSum j j' q' q)) in jq. apply (squash_to_hProp (to_hasBinDirectSums P Q)); intros PQ. apply hinhpr;unfold ExactCategoryDataToAdditiveCategory,pr1. exists PQ. exists (q' · p · ι₁ + q · ι₂). apply hinhpr. exists (q' · p'). exists (π₁ · i' · j + π₂ · j'). repeat split; rewrite ? rewrite_op. { rewrite assoc'. rewrite (assoc j). rewrite (to_IdIn1 jq). rewrite id_left. rewrite (to_IdIn1 ip). reflexivity. } { rewrite rightDistribute, 2 leftDistribute. rewrite (assoc' q'). rewrite (assoc' _ j). rewrite (assoc j). rewrite (to_IdIn1 jq). rewrite id_left. rewrite assoc'. rewrite (assoc i'). rewrite (to_IdIn2 ip). rewrite id_left. rewrite (assoc _ q'). rewrite (assoc' _ j'). rewrite (to_Unel2 jq); unfold to_unel. rewrite zeroRight, zeroLeft, runax. rewrite (assoc' _ j). rewrite (assoc j). rewrite (to_Unel1 jq). unfold to_unel. rewrite zeroLeft, zeroRight, lunax. rewrite assoc'. rewrite (assoc j'). rewrite (to_IdIn2 jq). rewrite id_left. apply (to_BinOpId PQ). } { rewrite rightDistribute. rewrite assoc'. rewrite (assoc' q'). rewrite (assoc j). rewrite (to_IdIn1 jq). rewrite id_left. rewrite assoc. rewrite (to_Unel1 ip); unfold to_unel. rewrite zeroLeft. rewrite lunax. rewrite assoc'. rewrite (assoc j). rewrite (to_Unel1 jq); unfold to_unel. rewrite zeroLeft, zeroRight. reflexivity. } { rewrite leftDistribute. rewrite assoc'. rewrite (assoc j). rewrite (to_IdIn1 jq). rewrite id_left. rewrite (assoc' _ i'). rewrite (to_Unel2 ip); unfold to_unel. rewrite zeroRight. rewrite lunax. rewrite assoc'. rewrite (assoc j'). rewrite (to_Unel2 jq);unfold to_unel. rewrite zeroLeft, zeroRight. reflexivity. } { rewrite rightDistribute, 2 leftDistribute. rewrite assoc. rewrite (assoc' _ i'). rewrite (assoc' _ ι₁). rewrite (assoc ι₁). rewrite (to_IdIn1 PQ). rewrite id_left. rewrite assoc. rewrite (assoc' q). rewrite (assoc _ _ (i' · j)). rewrite (to_Unel2 PQ); unfold to_unel. rewrite zeroLeft, zeroRight, runax. rewrite <- assocax. rewrite <- (leftDistribute _ _ j). rewrite 2 (assoc' q'). rewrite <- (rightDistribute q'). rewrite (to_BinOpId' ip). rewrite id_right. rewrite (assoc' _ ι₁). rewrite (assoc ι₁). rewrite (to_Unel1 PQ); unfold to_unel. rewrite zeroLeft, zeroRight, lunax. rewrite (assoc' q). rewrite (assoc ι₂). rewrite (to_IdIn2 PQ). rewrite id_left. exact (to_BinOpId' jq). } Qed. Lemma ComposeSplitEpi {M:AdditiveCategory} {A B C : M} (p : A --> B) (q : B --> C) : isSplitEpimorphism p ⇒ isSplitEpimorphism q ⇒ isSplitEpimorphism (p · q). Proof. intros r s. exact (opposite_isSplitMonomorphism _ (ComposeSplitMono (M:=oppositeAdditiveCategory M) _ _ (opposite_isSplitEpimorphism _ s) (opposite_isSplitEpimorphism _ r))). Qed. Lemma PullbackSplitEpi {M:AdditiveCategory} {A A'' C : M} (q : A --> A'') (g : C --> A'') : isSplitEpimorphism q -> ∃ PB : Pullback q g, isSplitEpimorphism (PullbackPr2 PB). Proof. intros s. apply (squash_to_hProp s); clear s; intros [A' [i e]]. apply (squash_to_hProp e); clear e; intros [p [j e]]. apply (squash_to_hProp (to_hasBinDirectSums A' C)); intros A'C. apply hinhpr. use tpair. - use tpair. + exists A'C. exists (π₁ · i + π₂ · g · j). exact π₂. + simpl. rewrite rewrite_op. use tpair. * rewrite leftDistribute. rewrite (assoc' _ j q). rewrite (to_IdIn2 e). rewrite id_right. rewrite (assoc' _ i q). rewrite (to_Unel1 e); unfold to_unel. rewrite zeroRight, lunax. reflexivity. * intros T r s eqn. apply iscontraprop1. { apply invproofirrelevance. intros h k. apply subtypePath. { intros l. apply isapropdirprod;apply to_has_homsets. } induction h as [h [H H']], k as [k [K K']]. simpl. rewrite <- (id_right h), <- (id_right k). rewrite <- (to_BinOpId' A'C). rewrite 2 rightDistribute. rewrite 4 assoc. rewrite H', K'. apply (maponpaths (λ z, z + s · ι₂)). rewrite rightDistribute in H, K. rewrite 3 assoc in H, K. rewrite H' in H. rewrite K' in K. apply (maponpaths (λ z, z · ι₁)). apply (to_In1_isMonic _ (make_BinDirectSum _ _ _ _ _ _ _ _ e)). change (h · π₁ · i = k · π₁ · i). apply (grrcan (T-->A) (s · g · j)). exact (H @ !K). } exists (r · p · ι₁ + s · ι₂). split. { rewrite leftDistribute, 2 rightDistribute. rewrite assoc'. rewrite (assoc _ _ i). rewrite (to_IdIn1 A'C). rewrite id_left. rewrite (assoc' (r · p)). rewrite 2 (assoc ι₁). rewrite (to_Unel1 A'C); unfold to_unel. rewrite 2 zeroLeft, zeroRight, runax. rewrite (assoc' s). rewrite (assoc ι₂). rewrite (to_Unel2 A'C); unfold to_unel. rewrite zeroLeft, zeroRight, lunax. rewrite 2 assoc. rewrite (assoc' s). rewrite (to_IdIn2 A'C). rewrite id_right. rewrite (!eqn). rewrite 2 assoc'. rewrite <- (rightDistribute r). rewrite (to_BinOpId' e). apply id_right. } { rewrite leftDistribute. rewrite (assoc' (r · p)). rewrite (to_Unel1 A'C); unfold to_unel. rewrite zeroRight, lunax. rewrite assoc'. rewrite (to_IdIn2 A'C). apply id_right. } - cbn. exact (hinhpr(A',,ι₁,, hinhpr (π₁,,ι₂,,BinDirectSum_isBinDirectSum _ A'C))). Qed. Lemma PushoutSplitMono {M:AdditiveCategory} {A A' C : M} (i : A' --> A) (g : A' --> C) : isSplitMonomorphism i ⇒ ∃ PO : Pushout i g, isSplitMonomorphism (PushoutIn2 PO). Proof. intros s. assert (Q := @PullbackSplitEpi (oppositeAdditiveCategory M) _ _ _ i g (opposite_isSplitMonomorphism _ s)). use (hinhfun _ Q); clear Q; intros [A''C epi]. exists (A''C). exact (opposite_isSplitEpimorphism _ epi). Qed. End SplitSequences. Section AdditiveToExact. Lemma AdditiveExactnessProperties (M:AdditiveCategory) : ExactCategoryProperties (M,,isSplit). Proof. split;unfold ExactCategoryDataToAdditiveCategory,pr1. - split. { intros P Q. apply IsomorphicToSplit. } { intros P Q i e. use IsomorphicToSplit. 2 : { exact (InverseMorphismPairIsomorphism i). } exact e. } - split. { split. { intros A. apply (squash_to_hProp (to_hasZero M)); intros Z. apply hinhpr. exists Z. set (Q := TrivialDirectSum Z A). exact (to_Pr2 Q,, DirectSumToSplit Q). } { intros A. apply (squash_to_hProp (to_hasZero M)); intros Z. apply hinhpr. exists Z. set (Q := TrivialDirectSum' Z A). exact (to_In1 Q,, DirectSumToSplit Q). } } split. { intros P. exact (isSplitToKernelCokernelPair (Mor1 P) (Mor2 P)). } split. { split. { exact (@ComposeSplitMono M). } { exact (@ComposeSplitEpi M). } } { split. { exact (@PullbackSplitEpi M). } { exact (@PushoutSplitMono M). } } Defined. Definition AdditiveToExact : AdditiveCategory -> ExactCategory := λ M, make_ExactCategory (M,,isSplit) (AdditiveExactnessProperties M). Lemma additive_exact_opposite {M:AdditiveCategory} : AdditiveToExact (oppositeAdditiveCategory M) = oppositeExactCategory (AdditiveToExact M). Proof. intros. apply subtypePath_prop. apply pair_path_in2. apply funextsec; intros P. apply hPropUnivalence. * exact (opposite_isSplit P). * exact (opposite_isSplit (MorphismPair_opp P)). Qed. End AdditiveToExact. Section InducedExactCategory. Definition exts_lift (M:ExactCategory) {X:Type} (j : X -> ob M) := zero_lifts M j ∧ ∀ a B c (i : j a --> B) (p : B --> j c), isExact2 i p ⇒ ∃ b, z_iso (j b) B. Definition exts_lift_sums (M:ExactCategory) {X:Type} (j : X -> ob M) : exts_lift M j -> sums_lift M j. Proof. intros el. exists (pr1 el). exact (λ a c S, pr2 el a S c ι₁ π₂ (DirectSumToExact S)). Defined. Definition induced_ExactCategoryData {M:ExactCategory} {X:Type} (j : X -> ob M) : exts_lift M j -> ExactCategoryData. Proof. intros el. exists (induced_Additive M j (exts_lift_sums M j el)). exact (λ P, isExact2 (Mor1 P) (Mor2 P)). Defined. Definition opp_exts_lift {M:ExactCategory} {X:Type} (j : X -> ob M) : exts_lift M j -> exts_lift (oppositeExactCategory M) j. Proof. intros [hz ce]. exists (opp_zero_lifts j hz). intros a B c i p ex. generalize (ce c B a p i ex). apply hinhfun. intros [b t]. exists b. exact (z_iso_inv (opp_z_iso t)). Defined. Lemma opp_sums_exts_lift (M:ExactCategory) {X:Type} (j : X -> ob M) (ce : exts_lift M j ): opp_sums_lift M j (exts_lift_sums M j ce) = exts_lift_sums M^op j (opp_exts_lift j ce). Proof. apply pair_path_in2. apply funextsec; intro a. apply funextsec; intro b. apply funextsec; intro S. apply isapropishinh. Qed. Goal ∏ {M:ExactCategory} {X:Type} (j : X -> ob M) (ce : exts_lift M j), oppositeExactCategoryData (induced_ExactCategoryData j ce) = induced_ExactCategoryData (M:=oppositeExactCategory M) j (opp_exts_lift j ce). Proof. intros. simple refine (total2_paths2_f _ _). - refine (induced_opposite_Additive j (exts_lift_sums M j ce) @ _). apply maponpaths. apply opp_sums_exts_lift. - apply funextsec; intros P. apply hPropUnivalence. (* Getting this to work would be good, because then some proofs below could be shortened by using duality. *) + intros ex. admit. + intros ex. admit. Abort. Definition induced_ExactCategoryProperties {M:ExactCategory} {X:Type} (j : X -> ob M) (ce : exts_lift M j) : ExactCategoryProperties (induced_ExactCategoryData j ce). Proof. set (N := induced_ExactCategoryData j ce). induction ce as [hz ce]. transparent assert (J : (PreAdditive_functor N M)). { exact (induced_PreAdditive_incl M j). } split. + split;intros P Q t. * exact (EC_IsomorphicToExact (applyFunctorToPairIsomorphism J _ _ t)). * exact (EC_IsomorphicToExact' (applyFunctorToPairIsomorphism J _ _ t)). + split. * apply (squash_to_hProp hz). intros [_Z iz]. set (zM := make_Zero (j _Z) iz). assert (izz : @isZero N _Z). { split; intros a; apply iz. } set (zN := @make_Zero N _Z izz). (* J zN = zM judgmentally *) split. { intros A. use ExactToAdmMono. 3 : { exact (pr2 (TrivialExactSequence (J A) zM)). } } { intros A. use ExactToAdmEpi. 3 : { exact (pr2 (TrivialExactSequence' zM (J A))). } } * split;unfold ExactCategoryDataToAdditiveCategory,pr1. { intros P iP. apply inducedMapReflectsKernelCokernelPairs. exact (EC_ExactToKernelCokernel iP). } split. { split. { intros A B C f g mf mg. apply (squash_to_hProp mf); clear mf; intros [P [p fp]]. apply (squash_to_hProp mg); clear mg; intros [R [q gq]]. assert (cs := CokernelSequence _ _ _ _ fp gq). apply (squash_to_hProp cs); clear cs; intros [T [s [k [r [fgs [kr _]]]]]]. apply (squash_to_hProp (ce P T R k r kr)); intros [U α]. apply hinhpr. exists U. exists (s · z_iso_inv α). exact (ExactIso3 (f·g) s (z_iso_inv α) fgs). } { intros A B C f g mf mg. apply (squash_to_hProp mf); clear mf; intros [P [p fp]]. apply (squash_to_hProp mg); clear mg; intros [R [q gq]]. assert (cs := KernelSequence _ _ _ _ gq fp). apply (squash_to_hProp cs); clear cs; intros [T [s [k [r [fgs [kr _]]]]]]. apply (squash_to_hProp (ce P T R r k kr)); intros [U α]. apply hinhpr. exists U. exists (α · s). exact (ExactIso1 α s (f·g) fgs). } } split. { intros A A'' B'' p f'' ep. apply (squash_to_hProp ep); clear ep; intros [A' [i ex]]. assert (Q := ExactPullback' p i ex f''). use (squash_to_hProp Q); clear Q; intros [B [p' [f [i' [eq [pb ex']]]]]]. assert (Q := ce A' B B'' i' p' ex'). apply (squash_to_hProp Q); clear Q; intros [_B t]. assert (t' := z_iso_inv t); clear t. set (i'' := i' · t'). set (p'' := z_iso_inv t' · p'). assert (ex'' := ExactIso2 (M:=M) _ _ t' ex' : isExact2 i'' p''). assert (pb' : isPullback' (M:=M) p f'' (z_iso_inv t'·f) p''). { exact (isPullback'_up_to_z_iso (M:=M) _ _ _ _ (z_iso_inv t') pb). } induction pb' as [eq2 pb']. apply hinhpr. use tpair. - use tpair. + exists _B. exists (z_iso_inv t'·f). exact p''. + cbn. exists eq2. now apply induced_precategory_reflects_pullbacks. - cbn beta. exact (ExactToAdmEpi (M:=N) ex''). } { intros A A'' B'' p f'' ep. apply (squash_to_hProp ep); clear ep; intros [A' [i ex]]. assert (Q := ExactPushout' p i ex f''). use (squash_to_hProp Q); clear Q; intros [B [p' [f [i' [eq [pb ex']]]]]]. assert (Q := ce B'' B A' p' i' ex'). apply (squash_to_hProp Q); clear Q; intros [_B t]. set (i'' := i' ∘ t). set (p'' := z_iso_inv t ∘ p'). assert (ex'' := ExactIso2 (M:=M) _ _ _ ex' : isExact2 p'' i''). assert (pb' : isPushout' (M:=M) p f'' (z_iso_inv t∘f) p''). { exact (isPushout'_up_to_z_iso (M:=M) _ _ _ _ _ pb). } induction pb' as [eq2 pb']. apply hinhpr. use tpair. - use tpair. + exists _B. exists (z_iso_inv t∘f). exact p''. + cbn. exists eq2. now apply induced_precategory_reflects_pushouts. - cbn beta. exact (ExactToAdmMono (M:=N) ex''). } Qed. Definition induced_ExactCategory {M:ExactCategory} {X:Type} (j : X -> ob M) (ce : exts_lift M j) : ExactCategory := make_ExactCategory (induced_ExactCategoryData j ce) (induced_ExactCategoryProperties j ce). End InducedExactCategory. UniMath-20231010/UniMath/CategoryTheory/ExactCategories/README.md000066400000000000000000000033721451125700300241620ustar00rootroot00000000000000K-theory ======== Author: Daniel R. Grayson In this subdirectory of "CategoryTheory" we formalize the category theory useful in higher algebraic K-theory, namely Quillen's theory of exact categories, as developed here: * Daniel Quillen, Higher algebraic K-theory. I, Algebraic K-theory, I: Higher K-theories (Proc. Conf., Battelle Memorial Inst., Seattle, Wash., 1972), Springer, Berlin, 1973, pp. 85–147. Lecture Notes in Math., Vol. 341. We also follow the careful and efficient exposition presented here: * Bühler, Theo, Exact categories, Expo. Math. 28 (2010), no. 1, 1–69. Note: it might be nice to work toward definitions of "additive category" and "abelian category" as properties of a category, rather than as added structures. That is the approach of Mac Lane in sections 18, 19, and 21 of [Duality for groups](http://projecteuclid.org/DPubS/Repository/1.0/Disseminate?view=body&id=pdf_1&handle=euclid.bams/1183515045), Bull. Amer. Math. Soc., Volume 56, Number 6 (1950), 485-516. Acknowledgments =============== I thank the Oswald Veblen Fund and the Bell Companies Fellowship for supporting my stay at the Institute for Advanced Study in Fall, 2013, and in Spring, 2014, where I started writing this code. I thank The Ambrose Monell Foundation for supporting my stay at the Institute for Advanced Study in Fall, 2015, where I continued working on this code. I thank the Oswald Veblen Fund and the Friends of the Institute for Advanced Study for supporting my stay at the Institute for Advanced Study in Spring, 2017, where I continued working on this code. I thank the Center for Advanced Study of the Norwegian Academy of Science and Letters, where much work on this was done, in October-November, 2018, and in February-March, 2019. UniMath-20231010/UniMath/CategoryTheory/ExactCategories/Tests.v000066400000000000000000000247101451125700300241730ustar00rootroot00000000000000(** Exact category prerequisite tests *) Require Export UniMath.Foundations.All. Require Export UniMath.CategoryTheory.Monics. Require Export UniMath.CategoryTheory.Epis. Require Export UniMath.CategoryTheory.limits.zero. Require Export UniMath.CategoryTheory.limits.kernels. Require Export UniMath.CategoryTheory.limits.cokernels. Require Export UniMath.CategoryTheory.limits.binproducts. Require Export UniMath.CategoryTheory.limits.bincoproducts. Require Export UniMath.CategoryTheory.limits.pullbacks. Require Export UniMath.CategoryTheory.limits.pushouts. Require Export UniMath.CategoryTheory.limits.BinDirectSums. Require Export UniMath.CategoryTheory.limits.Opp. Require Export UniMath.CategoryTheory.CategoriesWithBinOps. Require Export UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Export UniMath.CategoryTheory.opp_precat. Require Export UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Export UniMath.CategoryTheory.PreAdditive. Require Export UniMath.CategoryTheory.Morphisms. Require Export UniMath.CategoryTheory.Additive. Require Export UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.Subcategory.Full. Require Export UniMath.MoreFoundations.Notations. Require Export UniMath.MoreFoundations.PartA. Require Export UniMath.MoreFoundations.Propositions. Require Export UniMath.Algebra.BinaryOperations. Require Export UniMath.Algebra.Monoids. Require Export UniMath.Algebra.Groups. Import AddNotation. Local Open Scope addmonoid. Local Open Scope abgr. Local Open Scope logic. Local Open Scope cat. Local Arguments isZero {_} _. Local Arguments BinDirectSumOb {_ _ _}. Local Arguments to_binop {_ _ _}. Local Arguments grinv {_}. Local Arguments BinDirectSum {_}. Local Arguments to_Pr1 {_ _ _} _. Local Arguments to_Pr2 {_ _ _} _. Local Arguments to_In1 {_ _ _} _. Local Arguments to_In2 {_ _ _} _. Local Arguments to_BinOpId {_ _ _ _ _ _ _ _}. Local Arguments to_IdIn1 {_ _ _ _ _ _ _ _}. Local Arguments to_IdIn2 {_ _ _ _ _ _ _ _}. Local Arguments to_Unel1 {_ _ _ _ _ _ _ _}. Local Arguments to_Unel2 {_ _ _ _ _ _ _ _}. Local Arguments MorphismPair : clear implicits. Local Arguments morphism_from_iso {_ _ _}. Local Arguments ToBinDirectSum {_ _ _} _ {_}. Local Arguments isBinDirectSum {_ _ _ _}. Require Import UniMath.CategoryTheory.ExactCategories.ExactCategories. Goal ∏ (C:category) (a b:C) (f: a --> b), isMonic (C:=C) f = isEpi (C:=C^op) f. reflexivity. Defined. Goal ∏ (C:category) (a b:C) (f: a --> b), isEpi (C:=C) f = isMonic (C:=C^op) f. reflexivity. Defined. (** Here's why we prefer to use z_iso instead of iso : *) Goal ∏ (C:precategory) (a b:C) (f:z_iso a b), z_iso_inv (z_iso_inv f) = f. reflexivity. Defined. Goal ∏ (C:precategory) (a b:C) (f:z_iso (C:=C) a b), opp_z_iso (opp_z_iso f) = f. reflexivity. Defined. Goal ∏ (C:category) (a b:C) (f:z_iso (C:=C^op) b a), opp_z_iso (opp_z_iso f) = f. reflexivity. Defined. Goal ∏ (M : category) {X:Type} (j : X -> ob M), induced_precategory M^op j = (induced_category M j)^op. Proof. reflexivity. Defined. Goal ∏ (M:precategory) (P:MorphismPair M), MorphismPair_opp (MorphismPair_opp P) = P. Proof. reflexivity. Qed. Goal ∏ {M : category} (A B C:M) (f : A --> C) (g : B --> C), Pullback f g = Pushout (C:=M^op) f g. reflexivity. Defined. Goal ∏ {M : category} (A B C:M) (f : A --> C) (g : A --> C), Pushout f g = Pullback (C:=M^op) f g. reflexivity. Defined. Goal ∏ (M : precategoryWithBinOps), oppositePrecategoryWithBinOps (oppositePrecategoryWithBinOps M) = M. Proof. reflexivity. Defined. Goal ∏ {M:precategoryWithBinOps} {X:Type} (j : X -> ob M), oppositePrecategoryWithBinOps (induced_precategoryWithBinOps M j) = induced_precategoryWithBinOps (oppositePrecategoryWithBinOps M) j. Proof. reflexivity. (* 0.038 secs *) Qed. Goal ∏ (M : categoryWithAbgrops), oppositeCategoryWithAbgrops (oppositeCategoryWithAbgrops M) = M. Proof. reflexivity. Defined. Goal ∏ {M:categoryWithAbgrops} {X:Type} (j : X -> ob M), oppositeCategoryWithAbgrops (induced_categoryWithAbgrops M j) = induced_categoryWithAbgrops (oppositeCategoryWithAbgrops M) j. Proof. reflexivity. (* 0.183 secs *) Qed. Goal ∏ (M : PreAdditive), oppositePreAdditive (oppositePreAdditive M) = M. Proof. reflexivity. Defined. Goal ∏ (M:PreAdditive) (x y:M) (xy : BinDirectSum x y), oppositeBinDirectSum (M:=oppositePreAdditive M) (oppositeBinDirectSum xy) = xy. Proof. reflexivity. Defined. Goal ∏ (M:PreAdditive) (A B:M) (AB : BinDirectSum A B), reverseBinDirectSum (oppositeBinDirectSum AB) = oppositeBinDirectSum (reverseBinDirectSum AB). reflexivity. Defined. Goal ∏ (M:PreAdditive) (A B:M) (AB : BinDirectSum A B), reverseBinDirectSum (reverseBinDirectSum AB) = AB. Fail reflexivity. Abort. Local Definition hom (C:precategory_data) : ob C -> ob C -> UU := λ c c', precategory_morphisms c c'. Local Definition Hom (C : category) : ob C -> ob C -> hSet := λ c c', make_hSet _ (homset_property C c c'). Local Definition Hom_add (C : PreAdditive) : ob C -> ob C -> abgr := λ c c', (@to_abgr C c c'). Section Sanity. Context (M : category) (x y:M) (f : hom M x y) (g : Hom M x y). Goal Hom M x y. exact f. Defined. Goal hom M x y. exact g. Defined. End Sanity. Section Sanity2. Context (M : PreAdditive) (x y:M) (f : hom M x y) (g : Hom M x y) (h : Hom_add M x y). Goal Hom_add M x y. exact f. Defined. Goal Hom_add M x y. exact g. Defined. Goal Hom M x y. exact f. Defined. Goal Hom M x y. exact h. Defined. Goal hom M x y. exact g. Defined. Goal hom M x y. exact h. Defined. End Sanity2. Goal ∏ (M:precategory) (P:MorphismPair M), MorphismPair_opp (MorphismPair_opp P) = P. Proof. reflexivity. Qed. Goal ∏ (M:category) (p:MorphismPair (M^op)), MorphismPair M. intros. exact (MorphismPair_opp p). Qed. Goal ∏ (M:category) (P Q : MorphismPair M^op) (f:MorphismPairIsomorphism P Q), opp_MorphismPairIsomorphism (opp_MorphismPairIsomorphism f) = f. Proof. reflexivity. Qed. Goal ∏ (M:category) (P Q : MorphismPair M^op), MorphismPairIsomorphism (C:=M^op) P Q -> MorphismPairIsomorphism (C:=M) (MorphismPair_opp Q) (MorphismPair_opp P). Proof. intros M P Q. exact (opp_MorphismPairIsomorphism (M:=M^op) ). Qed. Goal ∏ (M : AdditiveCategory), oppositeAdditiveCategory (oppositeAdditiveCategory M) = M. Proof. reflexivity. Defined. Goal ∏ {M:AdditiveCategory} {X:Type} (j : X -> ob M) (su : sums_lift M j), opp_sums_lift (oppositeAdditiveCategory M) j (opp_sums_lift M j su) = su. Proof. reflexivity. Qed. Goal ∏ (M:ExactCategoryData), oppositeExactCategoryData (oppositeExactCategoryData M) = M. reflexivity. Qed. Goal ∏ (M:ExactCategory), ExactCategoryDataToAdditiveCategory (ExactCategoryToData (oppositeExactCategory M)) = oppositeAdditiveCategory (ExactCategoryDataToAdditiveCategory (ExactCategoryToData M)). Proof. reflexivity. Defined. Goal ∏ (M:ExactCategory), oppositeExactCategory (oppositeExactCategory M) = M. Proof. reflexivity. Defined. Goal ∏ (M:ExactCategory) (A B:M) (f : A --> B), isAdmissibleMonomorphism f = isAdmissibleEpimorphism (M:=oppositeExactCategory M) (opp_mor f). Proof. reflexivity. Defined. Goal ∏ (M:ExactCategory) (A B:M) (f : A --> B), isAdmissibleEpimorphism f = isAdmissibleMonomorphism (M:=oppositeExactCategory M) (opp_mor f). Proof. reflexivity. Defined. Goal ∏ (M:ExactCategory) (A B:M), AdmissibleMonomorphism A B = @AdmissibleEpimorphism (oppositeExactCategory M) B A. Proof. reflexivity. Defined. Goal ∏ (M:ExactCategory) (A B:M), AdmissibleEpimorphism A B = @AdmissibleMonomorphism (oppositeExactCategory M) B A. Proof. reflexivity. Defined. Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Mor1 (TrivialExactSequence A Z) = identity A. reflexivity. Qed. Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Ob3 (TrivialExactSequence A Z) = Z. reflexivity. Qed. Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Mor2 (TrivialExactSequence' Z A) = identity A. reflexivity. Qed. Goal ∏ {M : ExactCategory} {A:M} (Z:Zero M), Ob1 (TrivialExactSequence' Z A) = Z. reflexivity. Qed. Goal ∏ {M:ExactCategory} {X:Type} (j : X -> ob M) (ce : exts_lift M j), opp_exts_lift (M:=oppositeExactCategory M) j (opp_exts_lift (M:=M) j ce) = ce. Proof. reflexivity. Defined. (** Exact category tests *) Goal ∏ (M:category) (A A' B:M) (g : A --> B) (g' : A' --> B) (i:IsoArrowTo g g'), opposite_IsoArrowFrom (opposite_IsoArrowTo i) = i. Proof. reflexivity. Defined. Goal ∏ (M:category) (A B B':M) (g : A --> B) (g' : A --> B') (i:IsoArrowFrom g g'), opposite_IsoArrowTo (opposite_IsoArrowFrom i) = i. Proof. reflexivity. Defined. Goal ∏ {M:category} {X:Type} (j : X -> ob M) (hz : zero_lifts M j), opp_zero_lifts (C:= M^op) j (opp_zero_lifts (C:=M) j hz) = hz. Proof. reflexivity. Defined. Goal ∏ (M:category), oppositeCategory (oppositeCategory M) = M. reflexivity. Qed. Goal ∏ {M:category} {a b c d : M} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c), isPullback' f g p1 p2 = isPushout' (M := oppositeCategory M) f g p1 p2. Proof. reflexivity. Defined. Goal ∏ {M:category} {a b c d : M} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d), isPushout' f g in1 in2 = isPullback' (M := oppositeCategory M) f g in1 in2. Proof. reflexivity. Defined. Goal ∏ (M:category) (A A' B:M) (g : A --> B) (g' : A' --> B) (i:IsoArrowTo g g'), opposite_IsoArrowFrom (opposite_IsoArrowTo i) = i. Proof. reflexivity. Defined. Goal ∏ (M:category) (A B B':M) (g : A --> B) (g' : A --> B') (i:IsoArrowFrom g g'), opposite_IsoArrowTo (opposite_IsoArrowFrom i) = i. Proof. reflexivity. Defined. Goal ∏ (M:PreAdditive) (x y z : M) (f : x --> y) (g : y --> z), isKernel' (M:=M) f g = isCokernel' (M:=oppositePreAdditive M) g f. reflexivity. Defined. Goal ∏ (M:PreAdditive) (x y z : M) (f : x --> y) (g : y --> z), isCokernel' (M:=M) f g = isKernel' (M:=oppositePreAdditive M) g f. reflexivity. Defined. Goal ∏ (M :PreAdditive) (A B C A':M) (i : A <-- B) (p : B <-- C) (pr : isKernelCokernelPair p i) (r : A <-- A') (pb : Pullback i r), PairPullbackMap pr r pb = PairPushoutMap (M:=oppositePreAdditive M) (opposite_isKernelCokernelPair pr) r pb. Proof. reflexivity. Defined. Goal ∏ (M :PreAdditive) (A B C A':M) (i : A --> B) (p : B --> C) (pr : isKernelCokernelPair i p) (r : A --> A') (po : Pushout i r), PairPushoutMap pr r po = PairPullbackMap (M:=oppositePreAdditive M) (opposite_isKernelCokernelPair pr) r po. Proof. reflexivity. Defined. UniMath-20231010/UniMath/CategoryTheory/ExponentiationLeftAdjoint.v000066400000000000000000000263671451125700300251610ustar00rootroot00000000000000(** **************************************************************************** If a category C is small and has binary products then yoneda of any object is tiny, that is, exponentiation by it has a right adjoint in the presheaf category on C ([is_left_adjoint_exp_yoneda]). The proof closely follows the one on page 10 of: Internal Universes in Models of Homotopy Type Theory (2018) Daniel R. Licata, Ian Orton, Andrew M. Pitts, Bas Spitters https://arxiv.org/abs/1801.07664 In order to show that the exponential functor Yon(c) ⇒ _ has a right adjoint we show that it is isomorphic to the functor given by precomposition by the product functor c × _. The precomposition functor always has a right adjoint given by right Kan extension. This isomorphism is constructed by a chain of four isomorphisms at the set level. These are then lifted to an isomorphism on the level of functors using that they are all natural. We show that the exponential and precomposition with product functors are isomorphic by the isomorphisms (Yon(c) → F) x ≅ Ĉ(Yon(x), Yon(c) → F) ≅ Ĉ(Yon(c) × Yon(x), F) ≅ Ĉ(Yon(c × x), F) ≅ ((c × _)* F) x which are all natural in both F and x. This gives an isomorphism of the functors. We show each functor isomorphism separately. The three functors in the middle are denoted Fun1, Fun2 and Fun3 respectively. Written by: Elisabeth Bonnevier, 2019 ********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.YonedaBinproducts. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.Presheaf. Local Open Scope cat. Section tiny_object_preshv. Context {C : category} (PC : BinProducts C) (c : C). Let prod_functor_c : functor C C := constprod_functor1 PC c. Let Yon {C : category} : C ⟶ PreShv C := yoneda C. Definition precomp_prod_functor : functor (PreShv C) (PreShv C). Proof. use pre_composition_functor. apply functor_opp. exact prod_functor_c. Defined. Lemma precomp_prod_functor_has_right_adjoint : is_left_adjoint precomp_prod_functor. Proof. apply RightKanExtension_from_limits. apply LimsHSET. Defined. Definition PreShv_exponentials : Exponentials (@BinProducts_PreShv C). Proof. apply Exponentials_functor_HSET. Defined. Definition exp (F : PreShv C) : functor (PreShv C) (PreShv C) := pr1 (PreShv_exponentials F). (** The first isomorphism. Follows from the yoneda lemma. *) Definition Fun1_functor_data : functor_data (PreShv C) (PreShv C). Proof. use make_functor_data. - intro F. use functor_composite. + exact (PreShv C)^op. + use functor_opp. exact Yon. + exact (yoneda _ ((exp (Yon c)) F)). - intros F G α. use make_nat_trans. + intros X f. exact (f · (# (exp (Yon c)) α)). + intros X Y f. use funextsec; intro h. use assoc'. Defined. Lemma is_functor_Fun1 : is_functor Fun1_functor_data. Proof. split; [ intro F | intros F G H α β ]; use (nat_trans_eq has_homsets_HSET); intro X; use funextsec; intro f; [ set (idax := id_right f); rewrite <- (functor_id (exp (Yon c)) F) in idax; use idax | set (compax := assoc f (# (exp (Yon c)) α) (# (exp (Yon c)) β)); rewrite <- (functor_comp (exp (Yon c)) α β) in compax; use compax ]. Qed. Definition Fun1 : functor (PreShv C) (PreShv C) := make_functor _ is_functor_Fun1. Lemma first_iso_on_sets (F : PreShv C) (x : C) : z_iso (pr1 (Fun1 F) x) (pr1 ((exp (Yon c)) F) x). Proof. use hset_equiv_z_iso. use yoneda_weq. Defined. Lemma first_iso_nat_in_x (F : PreShv C) : is_nat_trans (pr1 (Fun1 F)) _ (λ x, first_iso_on_sets F x). Proof. use is_natural_yoneda_iso. Qed. Lemma first_iso_nat_in_F: is_nat_trans Fun1 (exp (Yon c)) (λ F, make_nat_trans (pr1 (Fun1 F)) _ (first_iso_on_sets F) (first_iso_nat_in_x F)). Proof. intros X Y f. apply (nat_trans_eq has_homsets_HSET); intros x. apply funextsec; intros g. apply (nat_trans_eq has_homsets_HSET); intros y. now apply funextsec. Qed. Lemma first_iso_on_functors : @z_iso [PreShv C, PreShv C] (exp (Yon c)) Fun1. Proof. use z_iso_inv_from_z_iso. use make_PreShv_functor_z_iso. - intros F x. use first_iso_on_sets. - intro F. use first_iso_nat_in_x. - use first_iso_nat_in_F. Defined. (** The second isomorphism. Follows from the fact that the exponential functor is right adjoint to the product functor. *) Definition Fun2_functor_data : functor_data (PreShv C) (PreShv C). Proof. use make_functor_data. - intro F. use functor_composite. + exact (PreShv C)^op. + use functor_opp. use functor_composite. * exact (PreShv C). * exact Yon. * exact (constprod_functor1 (@BinProducts_PreShv C) (Yon c)). + exact (Yon F). - intros F G α. use make_nat_trans. + intros X f. exact (f · α). + intros X Y f. use funextsec; intro g. use assoc'. Defined. Lemma is_functor_Fun2 : is_functor Fun2_functor_data. Proof. split; [ intro F | intros F G H α β ]; use (nat_trans_eq has_homsets_HSET); intro X; use funextsec; intro f; [ use id_right | use assoc ]. Qed. Definition Fun2 : functor (PreShv C) (PreShv C) := make_functor _ is_functor_Fun2. Lemma second_iso_on_sets (F : PreShv C) (x : C) : z_iso (pr1 (Fun1 F) x) (pr1 (Fun2 F) x). Proof. use hset_equiv_z_iso. use invweq. use (adjunction_hom_weq (pr2 (PreShv_exponentials (Yon c)))). Defined. Lemma second_iso_nat_in_x (F : PreShv C) : is_nat_trans (pr1 (Fun1 F)) (pr1 (Fun2 F)) (λ x, second_iso_on_sets F x). Proof. intros X Y f. apply funextsec; intro g. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intro. apply maponpaths; apply idpath. Qed. Lemma second_iso_nat_in_F : is_nat_trans Fun1 Fun2 (λ F, make_nat_trans (pr1 (Fun1 F)) (pr1 (Fun2 F)) (second_iso_on_sets F) (second_iso_nat_in_x F)). Proof. intros X Y f. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intros g. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intros h. apply (maponpaths (pr1 f x0)). apply (maponpaths (pr1 (pr1 g x0 (pr2 h)) x0)). now apply pathsdirprod; [use id_left|]. Qed. Lemma second_iso_on_functors : @z_iso [PreShv C, PreShv C] Fun1 Fun2. Proof. use make_PreShv_functor_z_iso. - intros F x. use second_iso_on_sets. - intro F. use second_iso_nat_in_x. - use second_iso_nat_in_F. Defined. (** The third isomorphism. Follows from the fact that the Yoneda functor commutes with binary products. *) Definition Fun3_functor_data : functor_data (PreShv C) (PreShv C). Proof. use make_functor_data. - intro F. use functor_composite. + exact (PreShv C)^op. + use functor_opp. use functor_composite. * exact C. * exact (constprod_functor1 PC c). * exact Yon. + use Yon; apply F. - intros F G α. use make_nat_trans. + intros X f. exact (f · α). + intros X Y f. use funextsec; intro g. use assoc'. Defined. Lemma is_functor_Fun3 : is_functor Fun3_functor_data. Proof. split; [ intro F | intros F G H α β ]; use (nat_trans_eq has_homsets_HSET); intro X; use funextsec; intro f; [ use id_right | use assoc ]. Qed. Definition Fun3 : functor (PreShv C) (PreShv C) := make_functor _ is_functor_Fun3. Lemma third_iso_on_sets (F : PreShv C) (x : C) : z_iso (pr1 (Fun2 F) x) (pr1 (Fun3 F) x). Proof. use hset_equiv_z_iso. use iso_comp_right_weq. use iso_yoneda_binproducts. Defined. Lemma third_iso_nat_in_x (F : PreShv C) : is_nat_trans (pr1 (Fun2 F)) (pr1 (Fun3 F)) (λ x, third_iso_on_sets F x). Proof. intros X Y f. apply funextsec; intro g. apply (nat_trans_eq has_homsets_HSET); intros x. apply funextsec; intros y. apply (maponpaths (pr1 g x)), pathsdirprod; cbn; unfold yoneda_morphisms_data, BinProduct_of_functors_mor; cbn. - now rewrite <- assoc, (BinProductOfArrowsPr1 _ (PC c X) (PC c Y)), id_right. - now rewrite <- !assoc, (BinProductOfArrowsPr2 _ (PC c X) (PC c Y)). Qed. Lemma third_iso_nat_in_F : is_nat_trans Fun2 Fun3 (λ F, make_nat_trans (pr1 (Fun2 F)) (pr1 (Fun3 F)) (third_iso_on_sets F) (third_iso_nat_in_x F)). Proof. intros X Y f. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intros g. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intros h. apply maponpaths; apply idpath. Qed. Lemma third_iso_on_functors : @z_iso [PreShv C, PreShv C] Fun2 Fun3. Proof. use make_PreShv_functor_z_iso. - intros F x. use third_iso_on_sets. - intro F. use third_iso_nat_in_x. - use third_iso_nat_in_F. Defined. (** The fourth isomorphism. Follows from the yoneda lemma. *) Lemma fourth_iso_on_sets (F : PreShv C) (x : C) : z_iso (pr1 (Fun3 F) x) (pr1 (precomp_prod_functor F) x). Proof. use hset_equiv_z_iso. use yoneda_weq. Defined. Lemma fourth_iso_nat_in_x (F : PreShv C) : is_nat_trans (pr1 (Fun3 F)) _ (λ x, fourth_iso_on_sets F x). Proof. intros X Y f. use (is_natural_yoneda_iso _ _ _ _ (BinProduct_of_functors_mor _ _ PC _ _ _ _ _)). Qed. Lemma fourth_iso_nat_in_F: is_nat_trans Fun3 precomp_prod_functor (λ F, make_nat_trans (pr1 (Fun3 F)) _ (fourth_iso_on_sets F) (fourth_iso_nat_in_x F)). Proof. intros X Y f. apply (nat_trans_eq has_homsets_HSET); intro. apply funextsec; intros g. apply idpath. Qed. Lemma fourth_iso_on_functors : @z_iso [(PreShv C), (PreShv C)] Fun3 precomp_prod_functor. Proof. use make_PreShv_functor_z_iso. - intros F x. use fourth_iso_on_sets. - intro F. use fourth_iso_nat_in_x. - use fourth_iso_nat_in_F. Defined. (** The exponential functor and the precomposition functor are isomorphic. *) Lemma iso_exp_precomp_prod_functor : @z_iso [PreShv C, PreShv C] precomp_prod_functor (exp (Yon c)). Proof. use z_iso_inv_from_z_iso. use (z_iso_comp first_iso_on_functors). use (z_iso_comp second_iso_on_functors). use (z_iso_comp third_iso_on_functors). use fourth_iso_on_functors. Defined. (** The exponential functor has a right adjoint. *) Theorem is_left_adjoint_exp_yoneda : is_left_adjoint (exp (Yon c)). Proof. use is_left_adjoint_closed_under_iso. - exact precomp_prod_functor. - use iso_exp_precomp_prod_functor. - use precomp_prod_functor_has_right_adjoint. Defined. End tiny_object_preshv. UniMath-20231010/UniMath/CategoryTheory/FiveLemma.v000066400000000000000000000651251451125700300216710ustar00rootroot00000000000000(** * FiveLemma *) (** ** Contents - Definition of structures for five lemma - Five Lemma structure to opposite category - Five Lemma - Five Lemma for short exact sequences, [ShortExact] *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AbelianPushoutPullback. Require Import UniMath.CategoryTheory.ShortExactSequences. Require Import UniMath.CategoryTheory.PseudoElements. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. (** ** FiveLemma Five lemma says that if you have the following commutative diagram in an abelian category C_1 --> C_2 --> C_3 --> C_4 --> C_5 f_1 | f_2 | f_3 | f_4 | f_5 | D_1 --> D_2 --> D_3 --> D_4 --> D_5 where the rows are exact and the morphisms f_1, f_2, f_4, and f_5 are isomorphisms, then f_3 is an isomorphism. Exactness of the first row means that an image of C_1 --> C_2 is a kernel of C_2 --> C_3, an image of C_2 --> C_3 is a kernel of C_3 --> C_4, and an image of C_3 --> C_4 is a kernel of C_4 --> C_5. The idea of the proof is to show that f_3 is monic and epi, and thus is an isomorphism by [monic_epi_is_iso]. To show that f_3 is monic, we use pseudo elements, [PseudoElem]. By [PEq_isMonic] it suffices to show that if a is a pseudo element of C_3 is mapped to PZero by f_3, then a is pseudo equal to PZero. We construct a pseudo element a' of C_1 which is mapped to a by the composite C_1 --> C_2 --> C_3. Since the first row is exact, this composite is Zero, and thus the pseudo image is PZero. We construct such a pseudo element a' as follows. First, by using exactness at C_3, and the fact that a is mapped to Pzero by C_3 --> C_4 (because of commutativity of f_3 f_4 square and the fact that f_4 is a monic), we obtain by [PEq_isExact] a pseudo element b' of C_2 which is mapped to a. The image of b' under f_2 · D_2 --> D_3 is PZero by commutativity and the assumption that a is mapped to PZero. By [PEq_isExact] we obtain aa pseudo element b'' of D_1 which is mapped to the image of b' under f_2. By the fact that f_1 is an epi, we get a pseudo element a' which is mapped to b''. Now, using commutativity of the square f_1 f_2, and the fact that f_2 is a monic, we get that the image of a' under C_1 --> C_2 is b'. Hence a' is mapped to a, under C_1 --> C_2 --> C_3, and the proof is complete. See [FiveLemma_isMonic] for formalization of the above. To show that f_3 is an epi we use opposite categories. First we transform the above diagram to the following diagram in the opposite category D_5 --> D_4 --> D_3 --> D_2 --> D_1 f_1 | f_2 | f_3 | f_4 | f_5 | C_5 --> D_2 --> D_3 --> D_4 --> C_5 Thus, we need to show that f_3 is monic (here f_3 is the opposite morphism of f_3 in the first diagram), to show that the original f_3 is epi! But this follows from the above proof. See [FiveLemma_isEpi]. Finally, in [FiveLemma] we put [FiveLemma_isMonic] and [FiveLemma_isEpi] together, and prove the lemma. Five lemma is sometimes used for short exact sequences in which case C_1, C_5, D_1, and D_5 are Zeros. Thus, f_1 and f_5 are automatically isomorphisms, and one only needs to show that f_2 and f_4 are isomorphisms. This is proved in [ShortExactFiveLemma]. *) (** ** Introduction In this section we define the data needed to state the five lemma. The main definitions are [FiveRow] and [FiveRowMorphism]. The first contains the data of a row in the five lemma, and the second contains the data for a morphism between two rows. [FiveRow] consists of Objects of the row, [FiveRowObs], differentials of the row [FiveRowDiffs], equations that composition of consecutive differentials is zero, [FiveRowDiffsEq], and the fact that the row is exact, [FiveRowExacts]. [FiveRowMorphism] takes arguments two [FiveRow] and consists of morphisms between the objects in the rows, [FiveRowMors], and commutativity of the squares, [FiveRowMorsComm]. **) Section five_lemma_data. Context {A : AbelianPreCat}. (** ** Rows *) (** *** Objects for a row *) Definition FiveRowObs : UU := (ob A) × (ob A) × (ob A) × (ob A) × (ob A). Definition make_FiveRowObs (C1 C2 C3 C4 C5 : ob A) : FiveRowObs := (C1,,(C2,,(C3,,(C4,,C5)))). Definition FOb1 (FRO : FiveRowObs) : ob A := dirprod_pr1 FRO. Definition FOb2 (FRO : FiveRowObs) : ob A := dirprod_pr1 (dirprod_pr2 FRO). Definition FOb3 (FRO : FiveRowObs) : ob A := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 FRO)). Definition FOb4 (FRO : FiveRowObs) : ob A := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRO))). Definition FOb5 (FRO : FiveRowObs) : ob A := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRO))). (** *** Differentials for a row *) Definition FiveRowDiffs (FRO : FiveRowObs) : UU := (A⟦FOb1 FRO, FOb2 FRO⟧) × (A⟦FOb2 FRO, FOb3 FRO⟧) × (A⟦FOb3 FRO, FOb4 FRO⟧) × (A⟦FOb4 FRO, FOb5 FRO⟧). Definition make_FiveRowDiffs (FRO : FiveRowObs) (f1 : A⟦FOb1 FRO, FOb2 FRO⟧) (f2 : A⟦FOb2 FRO, FOb3 FRO⟧) (f3 : A⟦FOb3 FRO, FOb4 FRO⟧) (f4 : A⟦FOb4 FRO, FOb5 FRO⟧) : FiveRowDiffs FRO := (f1,,(f2,,(f3,,f4))). Definition FDiff1 {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) : A⟦FOb1 FRO, FOb2 FRO⟧ := dirprod_pr1 FRD. Definition FDiff2 {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) : A⟦FOb2 FRO, FOb3 FRO⟧ := dirprod_pr1 (dirprod_pr2 FRD). Definition FDiff3 {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) : A⟦FOb3 FRO, FOb4 FRO⟧ := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 FRD)). Definition FDiff4 {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) : A⟦FOb4 FRO, FOb5 FRO⟧ := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRD)). (** *** Composition of consecutive differentials is 0 *) Definition FiveRowDiffsEq {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) : UU := (FDiff1 FRD · FDiff2 FRD = ZeroArrow (to_Zero A) _ _) × (FDiff2 FRD · FDiff3 FRD = ZeroArrow (to_Zero A) _ _) × (FDiff3 FRD · FDiff4 FRD = ZeroArrow (to_Zero A) _ _). Definition make_FiveRowDiffsEq {FRO : FiveRowObs} (FRD : FiveRowDiffs FRO) (H1 : FDiff1 FRD · FDiff2 FRD = ZeroArrow (to_Zero A) _ _) (H2 : FDiff2 FRD · FDiff3 FRD = ZeroArrow (to_Zero A) _ _) (H3 : FDiff3 FRD · FDiff4 FRD = ZeroArrow (to_Zero A) _ _) : FiveRowDiffsEq FRD := (H1,,(H2,,H3)). Definition FEq1 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} (FRDE : FiveRowDiffsEq FRD) : FDiff1 FRD · FDiff2 FRD = ZeroArrow (to_Zero A) _ _ := dirprod_pr1 FRDE. Definition FEq2 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} (FRDE : FiveRowDiffsEq FRD) : FDiff2 FRD · FDiff3 FRD = ZeroArrow (to_Zero A) _ _ := dirprod_pr1 (dirprod_pr2 FRDE). Definition FEq3 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} (FRDE : FiveRowDiffsEq FRD) : FDiff3 FRD · FDiff4 FRD = ZeroArrow (to_Zero A) _ _ := dirprod_pr2 (dirprod_pr2 FRDE). (** *** Row is exact *) Definition FiveRowExacts {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} (FRDE : FiveRowDiffsEq FRD) : UU := (isExact A (FDiff1 FRD) (FDiff2 FRD) (FEq1 FRDE)) × (isExact A (FDiff2 FRD) (FDiff3 FRD) (FEq2 FRDE)) × (isExact A (FDiff3 FRD) (FDiff4 FRD) (FEq3 FRDE)). Definition make_FiveRowExacts {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} (FRDE : FiveRowDiffsEq FRD) (H1 : isExact A (FDiff1 FRD) (FDiff2 FRD) (FEq1 FRDE)) (H2 : isExact A (FDiff2 FRD) (FDiff3 FRD) (FEq2 FRDE)) (H3 : isExact A (FDiff3 FRD) (FDiff4 FRD) (FEq3 FRDE)) : FiveRowExacts FRDE := (H1,,(H2,,H3)). Definition FEx1 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} {FRDE : FiveRowDiffsEq FRD} (FRE : FiveRowExacts FRDE) : isExact A (FDiff1 FRD) (FDiff2 FRD) (FEq1 FRDE) := dirprod_pr1 FRE. Definition FEx2 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} {FRDE : FiveRowDiffsEq FRD} (FRE : FiveRowExacts FRDE) : isExact A (FDiff2 FRD) (FDiff3 FRD) (FEq2 FRDE) := dirprod_pr1 (dirprod_pr2 FRE). Definition FEx3 {FRO : FiveRowObs} {FRD : FiveRowDiffs FRO} {FRDE : FiveRowDiffsEq FRD} (FRE : FiveRowExacts FRDE) : isExact A (FDiff3 FRD) (FDiff4 FRD) (FEq3 FRDE) := dirprod_pr2 (dirprod_pr2 FRE). (** *** Define row for [FiveLemma] *) Definition FiveRow : UU := ∑ (FRO : FiveRowObs), (∑ (FRD : FiveRowDiffs FRO), (∑ (FRDE : FiveRowDiffsEq FRD), FiveRowExacts FRDE)). Definition make_FiveRow (FRO : FiveRowObs) (FRD : FiveRowDiffs FRO) (FRDE : FiveRowDiffsEq FRD) (FRE : FiveRowExacts FRDE) : FiveRow := (FRO,,(FRD,,(FRDE,,FRE))). Definition FiveRow_Obs (FR : FiveRow) : FiveRowObs := pr1 FR. Coercion FiveRow_Obs : FiveRow >-> FiveRowObs. Definition FiveRow_Diffs (FR : FiveRow) : FiveRowDiffs FR := pr1 (pr2 FR). Coercion FiveRow_Diffs : FiveRow >-> FiveRowDiffs. Definition FiveRow_DiffsEq (FR : FiveRow) : FiveRowDiffsEq FR := pr1 (pr2 (pr2 FR)). Coercion FiveRow_DiffsEq : FiveRow >-> FiveRowDiffsEq. Definition FiveRow_Exacts (FR : FiveRow) : FiveRowExacts FR := pr2 (pr2 (pr2 FR)). Coercion FiveRow_Exacts : FiveRow >-> FiveRowExacts. (** ** Morphism of [FiveRows] *) (** *** Morphisms in the morphism *) Definition FiveRowMors (FR1 FR2 : FiveRow) : UU := (A⟦FOb1 FR1, FOb1 FR2⟧) × (A⟦FOb2 FR1, FOb2 FR2⟧) × (A⟦FOb3 FR1, FOb3 FR2⟧) × (A⟦FOb4 FR1, FOb4 FR2⟧) × (A⟦FOb5 FR1, FOb5 FR2⟧). Definition make_FiveRowMors (FR1 FR2 : FiveRow) (f1 : A⟦FOb1 FR1, FOb1 FR2⟧) (f2 : A⟦FOb2 FR1, FOb2 FR2⟧) (f3 : A⟦FOb3 FR1, FOb3 FR2⟧) (f4 : A⟦FOb4 FR1, FOb4 FR2⟧) (f5 : A⟦FOb5 FR1, FOb5 FR2⟧) : FiveRowMors FR1 FR2 := (f1,,(f2,,(f3,,(f4,,f5)))). Definition FMor1 {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : A⟦FOb1 FR1, FOb1 FR2⟧ := dirprod_pr1 FRMs. Definition FMor2 {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : A⟦FOb2 FR1, FOb2 FR2⟧ := dirprod_pr1 (dirprod_pr2 FRMs). Definition FMor3 {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : A⟦FOb3 FR1, FOb3 FR2⟧ := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 FRMs)). Definition FMor4 {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : A⟦FOb4 FR1, FOb4 FR2⟧ := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRMs))). Definition FMor5 {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : A⟦FOb5 FR1, FOb5 FR2⟧ := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRMs))). (** *** Commutativity of the squares *) Definition FiveRowMorsComm {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) : UU := (FDiff1 FR1 · FMor2 FRMs = FMor1 FRMs · FDiff1 FR2) × (FDiff2 FR1 · FMor3 FRMs = FMor2 FRMs · FDiff2 FR2) × (FDiff3 FR1 · FMor4 FRMs = FMor3 FRMs · FDiff3 FR2) × (FDiff4 FR1 · FMor5 FRMs = FMor4 FRMs · FDiff4 FR2). Definition make_FiveRowMorsComm {FR1 FR2 : FiveRow} (FRMs : FiveRowMors FR1 FR2) (H1 : FDiff1 FR1 · FMor2 FRMs = FMor1 FRMs · FDiff1 FR2) (H2 : FDiff2 FR1 · FMor3 FRMs = FMor2 FRMs · FDiff2 FR2) (H3 : FDiff3 FR1 · FMor4 FRMs = FMor3 FRMs · FDiff3 FR2) (H4 : FDiff4 FR1 · FMor5 FRMs = FMor4 FRMs · FDiff4 FR2) : FiveRowMorsComm FRMs := (H1,,(H2,,(H3,,H4))). Definition FComm1 {FR1 FR2 : FiveRow} {FRMs : FiveRowMors FR1 FR2} (FRMC : FiveRowMorsComm FRMs) : FDiff1 FR1 · FMor2 FRMs = FMor1 FRMs · FDiff1 FR2 := dirprod_pr1 FRMC. Definition FComm2 {FR1 FR2 : FiveRow} {FRMs : FiveRowMors FR1 FR2} (FRMC : FiveRowMorsComm FRMs) : FDiff2 FR1 · FMor3 FRMs = FMor2 FRMs · FDiff2 FR2 := dirprod_pr1 (dirprod_pr2 FRMC). Definition FComm3 {FR1 FR2 : FiveRow} {FRMs : FiveRowMors FR1 FR2} (FRMC : FiveRowMorsComm FRMs) : FDiff3 FR1 · FMor4 FRMs = FMor3 FRMs · FDiff3 FR2 := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 FRMC)). Definition FComm4 {FR1 FR2 : FiveRow} {FRMs : FiveRowMors FR1 FR2} (FRMC : FiveRowMorsComm FRMs) : FDiff4 FR1 · FMor5 FRMs = FMor4 FRMs · FDiff4 FR2 := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 FRMC)). (** *** Morphism of rows *) Definition FiveRowMorphism (FR1 FR2 : FiveRow) : UU := ∑ (FRMs : FiveRowMors FR1 FR2), FiveRowMorsComm FRMs. Definition make_FiveRowMorphism (FR1 FR2 : FiveRow) (FRMs : FiveRowMors FR1 FR2) (FRMC : FiveRowMorsComm FRMs) : FiveRowMorphism FR1 FR2 := (FRMs,,FRMC). Definition FiveRowMorphism_Mors {FR1 FR2 : FiveRow} (FRM : FiveRowMorphism FR1 FR2) : FiveRowMors FR1 FR2 := pr1 FRM. Coercion FiveRowMorphism_Mors : FiveRowMorphism >-> FiveRowMors. Definition FiveRowMorphism_Comms {FR1 FR2 : FiveRow} (FRM : FiveRowMorphism FR1 FR2) : FiveRowMorsComm FRM := pr2 FRM. Coercion FiveRowMorphism_Comms : FiveRowMorphism >-> FiveRowMorsComm. End five_lemma_data. (** ** Introduction In this section we translate the definitions in the previous section [five_lemma_data] to opposite categories, so that [FiveLemma_isEpi] can use these. *) Section five_lemma_opp. Definition FiveRowObs_opp {A : AbelianPreCat} (FRO : FiveRowObs) : @FiveRowObs (Abelian_opp A) := @make_FiveRowObs (Abelian_opp A) (FOb5 FRO) (FOb4 FRO) (FOb3 FRO) (FOb2 FRO) (FOb1 FRO). Definition FiveRowDiffs_opp {A : AbelianPreCat} {FRO : @FiveRowObs A} (FRD : FiveRowDiffs FRO) : @FiveRowDiffs (Abelian_opp A) (FiveRowObs_opp FRO) := @make_FiveRowDiffs (Abelian_opp A) (FiveRowObs_opp FRO) (FDiff4 FRD) (FDiff3 FRD) (FDiff2 FRD) (FDiff1 FRD). Local Opaque ZeroArrow. Local Lemma FiveRowDiffsEq_opp1 {A : AbelianPreCat} {FRO : @FiveRowObs A} {FRD : @FiveRowDiffs A FRO} (FRDE : @FiveRowDiffsEq A FRO FRD) : (@FDiff1 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) · (@FDiff2 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) = ZeroArrow (to_Zero (Abelian_opp A)) _ _. Proof. use (pathscomp0 (FEq3 FRDE)). use ZeroArrow_opp. Qed. Local Lemma FiveRowDiffsEq_opp2 {A : AbelianPreCat} {FRO : @FiveRowObs A} {FRD : @FiveRowDiffs A FRO} (FRDE : @FiveRowDiffsEq A FRO FRD) : (@FDiff2 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) · (@FDiff3 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) = ZeroArrow (to_Zero (Abelian_opp A)) _ _. Proof. use (pathscomp0 (FEq2 FRDE)). use ZeroArrow_opp. Qed. Local Lemma FiveRowDiffsEq_opp3 {A : AbelianPreCat} {FRO : @FiveRowObs A} {FRD : @FiveRowDiffs A FRO} (FRDE : @FiveRowDiffsEq A FRO FRD) : (@FDiff3 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) · (@FDiff4 (Abelian_opp A) _ (FiveRowDiffs_opp FRD)) = ZeroArrow (to_Zero (Abelian_opp A)) _ _. Proof. use (pathscomp0 (FEq1 FRDE)). use ZeroArrow_opp. Qed. Definition FiveRowDiffsEq_opp {A : AbelianPreCat} {FRO : @FiveRowObs A} {FRD : @FiveRowDiffs A FRO} (FRDE : @FiveRowDiffsEq A FRO FRD) : @FiveRowDiffsEq (Abelian_opp A) _ (FiveRowDiffs_opp FRD) := @make_FiveRowDiffsEq _ _ (FiveRowDiffs_opp FRD) (FiveRowDiffsEq_opp1 FRDE) (FiveRowDiffsEq_opp2 FRDE) (FiveRowDiffsEq_opp3 FRDE). Definition FiveRowExacts_opp {A : AbelianPreCat} {FRO : @FiveRowObs A} {FRD : @FiveRowDiffs A FRO} {FRDE : @FiveRowDiffsEq A FRO FRD} (FRE : @FiveRowExacts A FRO FRD FRDE) : @FiveRowExacts (Abelian_opp A) _ _ (FiveRowDiffsEq_opp FRDE) := @make_FiveRowExacts (Abelian_opp A) _ _ (FiveRowDiffsEq_opp FRDE) (isExact_opp (FEx3 FRE)) (isExact_opp (FEx2 FRE)) (isExact_opp (FEx1 FRE)). Definition FiveRow_opp {A : AbelianPreCat} (FR : @FiveRow A) : @FiveRow (Abelian_opp A) := @make_FiveRow (Abelian_opp A) (FiveRowObs_opp FR) (FiveRowDiffs_opp FR) (FiveRowDiffsEq_opp FR) (FiveRowExacts_opp FR). Definition FiveRowMors_opp {A : AbelianPreCat} {FR1 FR2 : @FiveRow A} (FRM : @FiveRowMors A FR1 FR2) : @FiveRowMors (Abelian_opp A) (FiveRow_opp FR2) (FiveRow_opp FR1) := @make_FiveRowMors (Abelian_opp A) (FiveRow_opp FR2) (FiveRow_opp FR1) (FMor5 FRM) (FMor4 FRM) (FMor3 FRM) (FMor2 FRM) (FMor1 FRM). Definition FiveRowMorsComm_opp {A : AbelianPreCat} {FR1 FR2 : @FiveRow A} {FRM : @FiveRowMors A FR1 FR2} (FRMC : @FiveRowMorsComm A FR1 FR2 FRM) : @FiveRowMorsComm (Abelian_opp A) _ _ (FiveRowMors_opp FRM) := @make_FiveRowMorsComm (Abelian_opp A) _ _ (FiveRowMors_opp FRM) (! FComm4 FRMC) (! FComm3 FRMC) (! FComm2 FRMC) (! FComm1 FRMC). Definition FiveRowMorphism_opp {A : AbelianPreCat} {FR1 FR2 : @FiveRow A} (FRM : @FiveRowMorphism A FR1 FR2) : @FiveRowMorphism (Abelian_opp A) (FiveRow_opp FR2) (FiveRow_opp FR1) := @make_FiveRowMorphism (Abelian_opp A) (FiveRow_opp FR2) (FiveRow_opp FR1) (FiveRowMors_opp FRM) (FiveRowMorsComm_opp FRM). End five_lemma_opp. (** ** Introduction In this section we prove the five lemma following the sketch of a proof on top of this file. *) Section five_lemma. Lemma FiveLemma_isMonic {A : AbelianPreCat} {FR1 FR2 : FiveRow} (FRM : FiveRowMorphism FR1 FR2) (H1 : is_z_isomorphism (FMor1 FRM)) (H2 : is_z_isomorphism (FMor2 FRM)) (H4 : is_z_isomorphism (FMor4 FRM)) (H5 : is_z_isomorphism (FMor5 FRM)) : isMonic (FMor3 (A:=A) FRM). Proof. use (dirprod_pr2 (PEq_isMonic (FMor3 FRM))). intros d' a X. apply pathsinv0. cbn in X. set (X' := PEq_Zero_Eq' _ _ X). cbn in X'. assert (e1 : a · FDiff3 FR1 = ZeroArrow (to_Zero A) _ _). { set (comm := FComm3 FRM). use (is_iso_isMonic A _ H4). rewrite <- assoc. rewrite comm. clear comm. rewrite assoc. rewrite X'. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. } set (b := dirprod_pr1 (PEq_isExact _ _ (FEq2 FR1)) (FEx2 FR1) a e1). set (PE1 := PseudoIm b (FMor2 FRM)). assert (e2 : PE1 · FDiff2 FR2 = ZeroArrow (to_Zero A) _ _). { cbn. set (comm := FComm2 FRM). rewrite <- assoc. rewrite <- comm. clear comm. rewrite assoc. set (tmp := PEqEq (PFiber_Eq b)). cbn in tmp. use (EpiisEpi _ (PEqEpi2 (PFiber_Eq b))). rewrite assoc. cbn in tmp. cbn. rewrite <- tmp. clear tmp. rewrite <- assoc. rewrite X'. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. } set (b' := dirprod_pr1 (PEq_isExact _ _ (FEq1 FR2)) (FEx1 FR2) PE1 e2). set (a' := dirprod_pr1 (PEq_isEpi (FMor1 FRM)) (is_iso_isEpi A _ H1) b'). assert (e3 : PEq (PseudoIm a' (FDiff1 FR1)) b). { assert (e31 : PEq (PseudoIm (PseudoIm a' (FDiff1 FR1)) (FMor2 FRM)) (PseudoIm b (FMor2 FRM))). { use (PEq_trans (PEq_Im_Comm a' (FComm1 FRM))). use (PEq_trans (PEq_Im _ _ (FDiff1 FR2) (PFiber_Eq a'))). use (PEq_trans (PFiber_Eq b')). use PEq_refl. } exact (dirprod_pr1 (PEq_isMonic' (FMor2 FRM)) (is_iso_isMonic A _ H2) (PseudoIm a' (FDiff1 FR1)) b e31). } assert (e4 : PEq (PseudoIm (PseudoIm a' (FDiff1 FR1)) (FDiff2 FR1)) a). { use (PEq_trans _ (PFiber_Eq b)). use (PEq_trans _ (PEq_Im _ _ (FDiff2 FR1) e3)). use PEq_refl. } use PEq_Zero_Eq'. - exact (PseudoOb a'). - use (PEq_trans (PEq_symm e4)). use (PEq_trans (PEq_Comp a' (FDiff1 FR1) (FDiff2 FR1))). use (PEq_trans (PEq_Im_Paths a' (FEq1 FR1))). use PEq_Eq_Zero. cbn. apply ZeroArrow_comp_right. Qed. Context {A : AbelianPreCat}. Lemma FiveLemma_isEpi {FR1 FR2 : FiveRow} (FRM : FiveRowMorphism FR1 FR2) (H1 : is_z_isomorphism (FMor1 FRM)) (H2 : is_z_isomorphism (FMor2 FRM)) (H4 : is_z_isomorphism (FMor4 FRM)) (H5 : is_z_isomorphism (FMor5 FRM)) : isEpi (FMor3 (A:=A) FRM). Proof. use opp_isMonic. set (H1' := opp_is_z_isomorphism _ H1). set (H2' := opp_is_z_isomorphism _ H2). set (H4' := opp_is_z_isomorphism _ H4). set (H5' := opp_is_z_isomorphism _ H5). set (FRM' := FiveRowMorphism_opp FRM). exact (FiveLemma_isMonic FRM' H5' H4' H2' H1'). Qed. Lemma FiveLemma {FR1 FR2 : FiveRow} (FRM : FiveRowMorphism FR1 FR2) (H1 : is_z_isomorphism (FMor1 FRM)) (H2 : is_z_isomorphism (FMor2 FRM)) (H4 : is_z_isomorphism (FMor4 FRM)) (H5 : is_z_isomorphism (FMor5 FRM)) : is_z_isomorphism (FMor3 (A:=A) FRM). Proof. use monic_epi_is_iso. - use FiveLemma_isMonic. + exact H1. + exact H2. + exact H4. + exact H5. - use FiveLemma_isEpi. + exact H1. + exact H2. + exact H4. + exact H5. Qed. End five_lemma. (** ** Introduction Five lemma for short exact sequences. Suppose you have a morphism of short exact sequences represented by the following diagram 0 --> C_1 --> C_2 --> C_3 --> 0 | f_2 | f_3 | f_4 | | 0 --> D_1 --> D_2 --> D_3 --> 0 If f_2 and f_4 are isomorphisms, then f_3 is an isomorphism. This is proved in [ShortExactFiveLemma]. *) Section short_exact_five_lemma. Context {A : AbelianPreCat}. (** ** Construction of the first row *) Definition ShortExactObs1 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowObs A. Proof. use make_FiveRowObs. - exact (to_Zero A). - exact (Ob1 SSE1). - exact (Ob2 SSE1). - exact (Ob3 SSE1). - exact (to_Zero A). Defined. Definition ShortExactDiffs1 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowDiffs A (ShortExactObs1 Mor). Proof. use make_FiveRowDiffs. - exact (ZeroArrow (to_Zero A) _ _). - exact (Mor1 SSE1). - exact (Mor2 SSE1). - exact (ZeroArrow (to_Zero A) _ _). Defined. Lemma ShortExactDiffsEq1 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowDiffsEq A _ (ShortExactDiffs1 Mor). Proof. use make_FiveRowDiffsEq. - cbn. apply ZeroArrow_comp_left. - cbn. use (ShortShortExactData_Eq (to_Zero A) SSE1). - cbn. apply ZeroArrow_comp_right. Qed. Lemma ShortExactExacts1 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowExacts A _ _ (ShortExactDiffsEq1 Mor). Proof. use make_FiveRowExacts. - cbn. use isExactisMonic. exact (ShortExactSequences.isMonic SSE1). - unfold isExact. exact (ShortShortExact_isKernel SSE1). - cbn. use isExactisEpi. exact (ShortExactSequences.isEpi SSE1). Qed. Definition ShortExactRow1 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRow A. Proof. use make_FiveRow. - exact (ShortExactObs1 Mor). - exact (ShortExactDiffs1 Mor). - exact (ShortExactDiffsEq1 Mor). - exact (ShortExactExacts1 Mor). Defined. (** ** Construction of the second row *) Definition ShortExactObs2 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowObs A. Proof. use make_FiveRowObs. - exact (to_Zero A). - exact (Ob1 SSE2). - exact (Ob2 SSE2). - exact (Ob3 SSE2). - exact (to_Zero A). Defined. Definition ShortExactDiffs2 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowDiffs A (ShortExactObs2 Mor). Proof. use make_FiveRowDiffs. - exact (ZeroArrow (to_Zero A) _ _). - exact (Mor1 SSE2). - exact (Mor2 SSE2). - exact (ZeroArrow (to_Zero A) _ _). Defined. Lemma ShortExactDiffsEq2 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowDiffsEq A _ (ShortExactDiffs2 Mor). Proof. use make_FiveRowDiffsEq. - cbn. apply ZeroArrow_comp_left. - cbn. use (ShortShortExactData_Eq (to_Zero A) SSE2). - cbn. apply ZeroArrow_comp_right. Qed. Lemma ShortExactExacts2 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowExacts A _ _ (ShortExactDiffsEq2 Mor). Proof. use make_FiveRowExacts. - cbn. use isExactisMonic. exact (ShortExactSequences.isMonic SSE2). - unfold isExact. exact (ShortShortExact_isKernel SSE2). - cbn. use isExactisEpi. exact (ShortExactSequences.isEpi SSE2). Qed. Definition ShortExactRow2 {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRow A. Proof. use make_FiveRow. - exact (ShortExactObs2 Mor). - exact (ShortExactDiffs2 Mor). - exact (ShortExactDiffsEq2 Mor). - exact (ShortExactExacts2 Mor). Defined. (** ** Construction of the morphism between rows *) Definition ShortExactMors {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowMors A (ShortExactRow1 Mor) (ShortExactRow2 Mor). Proof. use make_FiveRowMors. - exact (identity _). - exact (MPMor1 Mor). - exact (MPMor2 Mor). - exact (MPMor3 Mor). - exact (identity _). Defined. Lemma ShortExactMorComm {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowMorsComm A _ _ (ShortExactMors Mor). Proof. use make_FiveRowMorsComm. - cbn. rewrite ZeroArrow_comp_left. rewrite id_left. apply idpath. - cbn. exact (! (MPComm1 Mor)). - cbn. exact (! (MPComm2 Mor)). - cbn. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition ShortExactMor {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) : @FiveRowMorphism A (ShortExactRow1 Mor) (ShortExactRow2 Mor). Proof. use make_FiveRowMorphism. - exact (ShortExactMors Mor). - exact (ShortExactMorComm Mor). Defined. (** ** FiveLemma for short exact sequences *) Lemma ShortExactFiveLemma {SSE1 SSE2 : ShortExact A} (Mor : MPMor SSE1 SSE2) (H2 : is_z_isomorphism (MPMor1 Mor)) (H4 : is_z_isomorphism (MPMor3 Mor)) : is_z_isomorphism (MPMor2 Mor). Proof. set (FR1 := ShortExactRow1 Mor). set (FR2 := ShortExactRow2 Mor). set (FM := ShortExactMor Mor). use (FiveLemma FM). - exact (is_z_isomorphism_identity _). - exact H2. - exact H4. - exact (is_z_isomorphism_identity _). Qed. End short_exact_five_lemma. UniMath-20231010/UniMath/CategoryTheory/FunctorAlgebras.v000066400000000000000000000502221451125700300230750ustar00rootroot00000000000000(** **************************************************************** Benedikt Ahrens started March 2015 Extended by: Anders Mörtberg. October 2015 Rewritten using displayed categories by: Kobe Wullaert. October 2022 *******************************************************************) (** *************************************************************** Contents : - Category of algebras of an endofunctor - This category is saturated if base precategory is - Lambek's lemma: if (A,a) is an inital F-algebra then a is an iso - The natural numbers are initial for X ↦ 1 + X ******************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. (* The following are used for examples *) Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.NNO. Local Open Scope cat. (** ** Category of algebras of an endofunctor *) Section Algebra_Definition. Context {C : category} (F : functor C C). Definition algebra_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. use tpair. - exact (λ x, F x --> x). - exact (λ x y hx hy f, hx · f = #F f · hy). Defined. Definition algebra_disp_cat_id_comp : disp_cat_id_comp C algebra_disp_cat_ob_mor. Proof. split. - intros x hx ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - intros x y z f g hx hy hz hf hg ; cbn in *. rewrite !functor_comp. rewrite !assoc. rewrite hf. rewrite !assoc'. rewrite hg. apply idpath. Qed. Definition algebra_disp_cat_data : disp_cat_data C := algebra_disp_cat_ob_mor ,, algebra_disp_cat_id_comp. Definition algebra_disp_cat_axioms : disp_cat_axioms C algebra_disp_cat_data. Proof. repeat split ; intros ; try (apply homset_property). apply isasetaprop. apply homset_property. Qed. Definition algebra_disp_cat : disp_cat C := algebra_disp_cat_data ,, algebra_disp_cat_axioms. Definition category_FunctorAlg : category := total_category algebra_disp_cat. Definition FunctorAlg := category_FunctorAlg. Definition algebra_ob : UU := ob FunctorAlg. (* this coercion causes confusion, and it is not inserted when parsing most of the time thus removing coercion globally *) Definition alg_carrier (X : algebra_ob) : C := pr1 X. Local Coercion alg_carrier : algebra_ob >-> ob. Definition alg_map (X : algebra_ob) : F X --> X := pr2 X. (** A morphism of F-algebras (F X, g : F X --> X) and (F Y, h : F Y --> Y) is a morphism f : X --> Y such that the following diagram commutes: << >>>>>>> master F f F x ----> F y | | | g | h V V x ------> y f >> *) Definition is_algebra_mor (X Y : algebra_ob) (f : alg_carrier X --> alg_carrier Y) : UU := alg_map X · f = #F f · alg_map Y. Definition algebra_mor (X Y : algebra_ob) : UU := FunctorAlg⟦X,Y⟧. Coercion mor_from_algebra_mor {X Y : algebra_ob} (f : algebra_mor X Y) : C⟦X, Y⟧ := pr1 f. Lemma algebra_mor_commutes (X Y : algebra_ob) (f : algebra_mor X Y) : alg_map X · f = #F f · alg_map Y. Proof. exact (pr2 f). Qed. (*Definition algebra_mor_id (X : algebra_ob) : algebra_mor X X. Proof. exists (identity _ ). abstract (unfold is_algebra_mor; rewrite id_right ; rewrite functor_id; rewrite id_left; apply idpath). Defined. Definition algebra_mor_comp (X Y Z : algebra_ob) (f : algebra_mor X Y) (g : algebra_mor Y Z) : algebra_mor X Z. Proof. exists (f · g). abstract (unfold is_algebra_mor; rewrite assoc; rewrite algebra_mor_commutes; rewrite <- assoc; rewrite algebra_mor_commutes; rewrite functor_comp, assoc; apply idpath). Defined. Definition precategory_alg_ob_mor : precategory_ob_mor. Proof. exists algebra_ob. exact algebra_mor. Defined. Definition precategory_alg_data : precategory_data. Proof. exists precategory_alg_ob_mor. exists algebra_mor_id. exact algebra_mor_comp. Defined.*) End Algebra_Definition. (* Definition isaset_algebra_mor {C : category} (F : functor C C) (X Y : algebra_ob F) : isaset (algebra_mor F X Y). Proof. apply (isofhleveltotal2 2). - apply C. - intro f. apply isasetaprop. apply C. Qed.*) Definition algebra_mor_eq' {C : category} {F : functor C C} {X Y : algebra_ob F} (f g : algebra_mor F X Y) : (f : alg_carrier F X --> alg_carrier F Y) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro a. apply C. Defined. Definition algebra_mor_eq {C : category} {F : functor C C} {X Y : FunctorAlg F} (f g : (FunctorAlg F)⟦X,Y⟧) : ((pr1 f : alg_carrier F X --> alg_carrier F Y) = (pr1 g)) -> f = g. Proof. exact (algebra_mor_eq' f g). Defined. (* Lemma is_precategory_precategory_alg_data {C : category} (F : functor C C) : is_precategory (precategory_alg_data F). Proof. repeat split; intros; simpl. - apply algebra_mor_eq. apply id_left. - apply algebra_mor_eq. apply id_right. - apply algebra_mor_eq. apply assoc. - apply algebra_mor_eq. apply assoc'. Qed. Definition precategory_FunctorAlg {C : category} (F : functor C C) : precategory := tpair _ _ (is_precategory_precategory_alg_data F). Lemma has_homsets_FunctorAlg {C : category} (F : functor C C) : has_homsets (precategory_FunctorAlg F). Proof. intros f g. apply isaset_algebra_mor. Qed. Definition category_FunctorAlg {C : category} (F : functor C C) : category := make_category (precategory_FunctorAlg F) (has_homsets_FunctorAlg F). Notation FunctorAlg := category_FunctorAlg.*) Section fixacategory. Context {C : category} (F : functor C C). (** forgetful functor from FunctorAlg to its underlying category *) (* first step of definition *) (* Definition forget_algebras_data : functor_data (FunctorAlg F) C. Proof. set (onobs := fun alg : FunctorAlg F => dialgebra_carrier alg). apply (make_functor_data onobs). intros alg1 alg2 m. exact (mor_from_dialgebra_mor m). Defined. *) (* the forgetful functor *) Definition forget_algebras : functor (category_FunctorAlg F) C := pr1_category (algebra_disp_cat F). (*Proof. Check dialgebra_pr1. apply (make_functor forget_algebras_data). abstract ( split; [intro alg; apply idpath | intros alg1 alg2 alg3 m n; apply idpath] ). Defined.*) End fixacategory. (** ** This category is saturated if the base category is *) Section FunctorAlg_saturated. Context {C : category} (H : is_univalent C) (F : functor C C). Definition algebra_eq_type (X Y : FunctorAlg F) : UU := ∑ p : z_iso (pr1 X) (pr1 Y), is_algebra_mor F X Y p. Definition algebra_ob_eq (X Y : FunctorAlg F) : (X = Y) ≃ algebra_eq_type X Y. Proof. eapply weqcomp. - apply total2_paths_equiv. - set (H1 := make_weq _ (H (pr1 X) (pr1 Y))). apply (weqbandf H1). simpl. intro p. destruct X as [X α]. destruct Y as [Y β]; simpl in *. destruct p. rewrite idpath_transportf. unfold is_algebra_mor; simpl. rewrite functor_id. rewrite id_left, id_right. apply idweq. Defined. Definition is_z_iso_from_is_algebra_iso (X Y : FunctorAlg F) (f : X --> Y) : is_z_isomorphism f → is_z_isomorphism (pr1 f). Proof. intro p. set (H' := z_iso_inv_after_z_iso (make_z_iso' f p)). set (H'':= z_iso_after_z_iso_inv (make_z_iso' f p)). exists (pr1 (inv_from_z_iso (make_z_iso' f p))). split; simpl. - apply (maponpaths pr1 H'). - apply (maponpaths pr1 H''). Defined. Definition inv_algebra_mor_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y) : is_z_isomorphism (pr1 f) → (Y --> X). Proof. intro T. set (fiso:=make_z_iso' (pr1 f) T). set (finv:=inv_from_z_iso fiso). exists finv. unfold finv. apply pathsinv0. apply z_iso_inv_on_left. simpl. rewrite functor_on_inv_from_z_iso. rewrite <- assoc. apply pathsinv0. apply z_iso_inv_on_right. simpl. apply (pr2 f). Defined. Definition is_algebra_iso_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y) : is_z_isomorphism (pr1 f) → is_z_isomorphism f. Proof. intro T. exists (inv_algebra_mor_from_is_z_iso f T). split; simpl. - apply algebra_mor_eq. apply (z_iso_inv_after_z_iso (make_z_iso' (pr1 f) T)). - apply algebra_mor_eq. apply (z_iso_after_z_iso_inv (make_z_iso' (pr1 f) T)). Defined. Definition algebra_iso_first_z_iso {X Y : FunctorAlg F} : z_iso X Y ≃ ∑ f : X --> Y, is_z_isomorphism (pr1 f). Proof. apply (weqbandf (idweq _ )). unfold idweq. simpl. intro f. apply weqimplimpl. - apply is_z_iso_from_is_algebra_iso. - apply is_algebra_iso_from_is_z_iso. - apply (isaprop_is_z_isomorphism (C:=FunctorAlg F) f). - apply (isaprop_is_z_isomorphism (pr1 f)). Defined. Definition swap (A B : UU) : A × B → B × A. Proof. intro ab. exists (pr2 ab). exact (pr1 ab). Defined. Definition swapweq (A B : UU) : (A × B) ≃ (B × A). Proof. exists (swap A B). apply (isweq_iso _ (swap B A)). - abstract ( intro ab; destruct ab; apply idpath ). - abstract ( intro ba; destruct ba; apply idpath ). Defined. Definition algebra_z_iso_rearrange {X Y : FunctorAlg F} : (∑ f : X --> Y, is_z_isomorphism (pr1 f)) ≃ algebra_eq_type X Y. Proof. eapply weqcomp. - apply weqtotal2asstor. - simpl. unfold algebra_eq_type. apply invweq. eapply weqcomp. + apply weqtotal2asstor. + simpl. apply (weqbandf (idweq _ )). unfold idweq. simpl. intro f; apply swapweq. Defined. Definition algebra_idtoiso (X Y : FunctorAlg F) : (X = Y) ≃ z_iso X Y. Proof. eapply weqcomp. - apply algebra_ob_eq. - eapply weqcomp. + apply (invweq (algebra_z_iso_rearrange)). + apply (invweq algebra_iso_first_z_iso). Defined. Lemma isweq_idtoiso_FunctorAlg (X Y : FunctorAlg F) : isweq (@idtoiso _ X Y). Proof. apply (isweqhomot (algebra_idtoiso X Y)). - intro p. induction p. simpl. apply (z_iso_eq(C:=FunctorAlg F)). apply algebra_mor_eq. apply idpath. - apply (pr2 _ ). Defined. Lemma is_univalent_FunctorAlg : is_univalent (FunctorAlg F). Proof. intros X Y. apply isweq_idtoiso_FunctorAlg. Defined. Lemma idtomor_FunctorAlg_commutes (X Y: FunctorAlg F) (e: X = Y) : mor_from_algebra_mor F (idtomor _ _ e) = idtomor _ _ (maponpaths (alg_carrier F) e). Proof. induction e. apply idpath. Qed. Corollary idtoiso_FunctorAlg_commutes (X Y: FunctorAlg F) (e: X = Y) : mor_from_algebra_mor F (morphism_from_z_iso _ _ (idtoiso e)) = idtoiso (maponpaths (alg_carrier F) e). Proof. unfold morphism_from_z_iso. rewrite eq_idtoiso_idtomor. etrans. 2: { apply pathsinv0, eq_idtoiso_idtomor. } apply idtomor_FunctorAlg_commutes. Qed. End FunctorAlg_saturated. (** ** Lambek's lemma: If (A,a) is an initial F-algebra then a is an iso *) Section Lambeks_lemma. Variables (C : category) (F : functor C C). Variables (Aa : FunctorAlg F) (AaIsInitial : isInitial (FunctorAlg F) Aa). Local Definition AaInitial : Initial (FunctorAlg F) := make_Initial _ AaIsInitial. Local Notation A := (alg_carrier _ Aa). Local Notation a := (alg_map _ Aa). (* (FA,Fa) is an F-algebra *) Local Definition FAa : FunctorAlg F := tpair (λ X, C ⟦F X,X⟧) (F A) (# F a). Local Definition Fa' := InitialArrow AaInitial FAa. Local Definition a' : C⟦A,F A⟧ := mor_from_algebra_mor F Fa'. Local Definition Ha' := algebra_mor_commutes _ _ _ Fa'. Lemma initialAlg_is_iso_subproof : is_inverse_in_precat a a'. Proof. assert (Ha'a : a' · a = identity A). { assert (algMor_a'a : is_algebra_mor _ _ _ (a' · a)). { unfold is_algebra_mor, a'; rewrite functor_comp. eapply pathscomp0; [|eapply cancel_postcomposition; apply Ha']. apply assoc. } apply pathsinv0; set (X := tpair _ _ algMor_a'a). apply (maponpaths pr1 (!@InitialEndo_is_identity _ AaInitial X)). } split; trivial. eapply pathscomp0; [apply Ha'|]; cbn. rewrite <- functor_comp. eapply pathscomp0; [eapply maponpaths; apply Ha'a|]. apply functor_id. Qed. Lemma initialAlg_is_z_iso : is_z_isomorphism a. Proof. exists a'. exact initialAlg_is_iso_subproof. Defined. End Lambeks_lemma. (** ** The natural numbers are intial for X ↦ 1 + X *) (** This can be used as a definition of a natural numbers object (NNO) in any category with binary coproducts and a terminal object. We prove the universal property of NNOs below. *) Section Nats. Context (C : category). Context (bc : BinCoproducts C). Context (hsC : has_homsets C). Context (T : Terminal C). Local Notation "1" := T. Local Notation "f + g" := (BinCoproductOfArrows _ _ _ f g). Local Notation "[ f , g ]" := (BinCoproductArrow _ _ f g). Let F : functor C C := BinCoproduct_of_functors _ _ bc (constant_functor _ _ 1) (functor_identity _). (** F on objects: X ↦ 1 + X *) Definition F_compute1 : ∏ c : C, F c = BinCoproductObject (bc 1 c) := fun c => (idpath _). (** F on arrows: f ↦ [identity 1, f] *) Definition F_compute2 {x y : C} : ∏ f : x --> y, # F f = (identity 1) + f := fun c => (idpath _). Definition nat_ob : UU := Initial (FunctorAlg F). Definition nat_ob_carrier (N : nat_ob) : ob C := alg_carrier _ (InitialObject N). Local Coercion nat_ob_carrier : nat_ob >-> ob. (** We have an arrow alg_map : (F N = 1 + N) --> N, so by the η-rule (UMP) for the coproduct, we can assume that it arises from a pair of maps [nat_ob_z,nat_ob_s] by composing with coproduct injections. << in1 in2 1 ----> 1 + N <---- N | | | nat_ob_z | | alg_map | nat_ob_s | V | +-------> N <-------+ >> *) Definition nat_ob_z (N : nat_ob) : (1 --> N) := BinCoproductIn1 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)). Definition nat_ob_s (N : nat_ob) : (N --> N) := BinCoproductIn2 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)). Local Notation "0" := (nat_ob_z _). (** Use the universal property of the coproduct to make any object with a point and an endomorphism into an F-algebra *) Definition make_F_alg {X : ob C} (f : 1 --> X) (g : X --> X) : ob (FunctorAlg F). Proof. refine (X,, _). exact (BinCoproductArrow _ f g). Defined. (** Using make_F_alg, X will be an F-algebra, and by initiality of N, there will be a unique morphism of F-algebras N --> X, which can be projected to a morphism in C. *) Definition nat_ob_rec (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), (N --> X) := fun f g => mor_from_algebra_mor F (InitialArrow N (make_F_alg f g)). (** When calling the recursor on 0, you get the base case. Specifically, nat_ob_z · nat_ob_rec = f *) Lemma nat_ob_rec_z (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), nat_ob_z N · nat_ob_rec N f g = f. Proof. intros f g. pose (inlN := BinCoproductIn1 (bc 1 N)). pose (succ := nat_ob_s N). (** By initiality of N, there is a unique morphism making the following diagram commute: << inlN identity 1 + nat_ob_rec 1 -----> 1 + N -------------------------> 1 + X | | alg_map N | | alg_map X V V N --------------------------> X nat_ob_rec >> This proof uses somewhat idiosyncratic "forward reasoning", transforming the term "diagram" rather than the goal. *) pose (diagram := maponpaths (fun x => inlN · x) (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))). rewrite (F_compute2 _) in diagram. (** Using the η-rules for coproducts, we can assume that alg_map X = [f,g] for f : 1 --> X, g : X --> X. *) rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram. (** Using the β-rules for coproducts, we can simplify some of the terms *) (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *) rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X) (identity 1) _ _ _) in diagram. (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *) rewrite (BinCoproductIn1Commutes C 1 N (bc 1 _) _ _ _) in diagram. (** We can dispense with the identity *) rewrite (id_left _) in diagram. rewrite assoc in diagram. rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram. refine (_ @ (BinCoproductIn1Commutes C _ _ (bc 1 _) _ f g)). rewrite (!BinCoproductIn1Commutes C _ _ (bc 1 _) _ 0 succ). unfold nat_ob_rec in *. exact diagram. Defined. Opaque nat_ob_rec_z. (** The succesor case: nat_ob_s · nat_ob_rec = nat_ob_rec · g The proof is very similar. *) Lemma nat_ob_rec_s (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), nat_ob_s N · nat_ob_rec N f g = nat_ob_rec N f g · g. Proof. intros f g. pose (inrN := BinCoproductIn2 (bc 1 N)). pose (succ := nat_ob_s N). (** By initiality of N, there is a unique morphism making the same diagram commute as above, but with "inrN" in place of "inlN". *) pose (diagram := maponpaths (fun x => inrN · x) (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))). rewrite (F_compute2 _) in diagram. rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram. (** Using the β-rules for coproducts, we can simplify some of the terms *) (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *) rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X) (identity 1) _ _ _) in diagram. (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *) rewrite (BinCoproductIn2Commutes C 1 N (bc 1 _) _ _ _) in diagram. rewrite assoc in diagram. rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram. refine (_ @ maponpaths (fun x => nat_ob_rec N f g · x) (BinCoproductIn2Commutes C _ _ (bc 1 _) _ f g)). rewrite (!BinCoproductIn2Commutes C _ _ (bc 1 _) _ 0 (nat_ob_s N)). unfold nat_ob_rec in *. exact diagram. Defined. Opaque nat_ob_rec_s. End Nats. (** nat_ob implies NNO *) Lemma nat_ob_NNO {C : category} (BC : BinCoproducts C) (hsC : has_homsets C) (TC : Terminal C) : nat_ob _ BC TC → NNO TC. Proof. intros N. use make_NNO. - exact (nat_ob_carrier _ _ _ N). - apply nat_ob_z. - apply nat_ob_s. - intros n z s. use unique_exists. + apply (nat_ob_rec _ _ _ _ z s). + split; [ apply nat_ob_rec_z | apply nat_ob_rec_s ]. + intros x; apply isapropdirprod; apply hsC. + intros x [H1 H2]. transparent assert (xalg : (FunctorAlg (BinCoproduct_of_functors C C BC (constant_functor C C TC) (functor_identity C)) ⟦ InitialObject N, make_F_alg C BC TC z s ⟧)). { refine (x,,_). abstract (apply pathsinv0; etrans; [apply precompWithBinCoproductArrow |]; rewrite id_left, <- H1; etrans; [eapply maponpaths, pathsinv0, H2|]; now apply pathsinv0, BinCoproductArrowUnique; rewrite assoc; apply maponpaths). } exact (maponpaths pr1 (InitialArrowUnique N (make_F_alg C BC TC z s) xalg)). Defined. UniMath-20231010/UniMath/CategoryTheory/FunctorCategory.v000066400000000000000000000460541451125700300231420ustar00rootroot00000000000000(** * Functor (pre)categories Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) *) (** ** Contents - Isomorphisms in functor category are pointwise isomorphisms - Isomorphic Functors are equal if target precategory is univalent_category [functor_eq_from_functor_iso] - Functor precategory is univalent_category if target precategory is [is_univalent_functor_category] *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** ** Functor category [[C, D]] *) Definition functor_precategory_ob_mor (C C' : precategory_data): precategory_ob_mor := make_precategory_ob_mor (functor C C') (λ F F' : functor C C', nat_trans F F'). (** *** The data of the functor precategory *) Definition functor_precategory_data (C : precategory_data)(C' : precategory): precategory_data. Proof. apply (make_precategory_data (functor_precategory_ob_mor C C')). + intro a; simpl. apply (nat_trans_id (pr1 a)). + intros a b c f g. apply (nat_trans_comp _ _ _ f g). Defined. (** *** Above data forms a precategory *) Lemma is_precategory_functor_precategory_data (C:precategory_data)(C' : precategory) (hs: has_homsets C'): is_precategory (functor_precategory_data C C'). Proof. apply is_precategory_one_assoc_to_two. repeat split; simpl; intros. unfold identity. simpl. apply nat_trans_eq. apply hs. intro x; simpl. apply id_left. apply nat_trans_eq. apply hs. intro x; simpl. apply id_right. apply nat_trans_eq. apply hs. intro x; simpl. apply assoc. Qed. Definition functor_precategory (C : precategory_data) (C' : precategory) (hs: has_homsets C'): precategory := tpair (λ C, is_precategory C) (functor_precategory_data C C') (is_precategory_functor_precategory_data C C' hs). Notation "[ C , D , hs ]" := (functor_precategory C D hs) : cat. Lemma functor_category_has_homsets (C : precategory_data) (D : precategory) (hs: has_homsets D): has_homsets [C, D, hs]. Proof. intros F G. apply isaset_nat_trans. apply hs. Defined. Definition functor_category (C : precategory_data) (D : category) : category := make_category (functor_precategory C D D) (functor_category_has_homsets C D D). Definition functor_identity_as_ob (C : precategory) (hsC : has_homsets C) : [C, C, hsC] := (functor_identity C). Definition functor_composite_as_ob {C C' C'' : precategory} {hsC' : has_homsets C'} {hsC'' : has_homsets C''} (F : [C, C', hsC']) (F' : [C', C'', hsC'']) : [C, C'', hsC''] := tpair _ _ (is_functor_composite F F'). (** Characterizing isomorphisms in the functor category *) Lemma is_nat_trans_inv_from_pointwise_inv_ext {C : precategory_data} {D : precategory} (hs: has_homsets D) {F G : functor_data C D} {A : nat_trans F G} (H : is_nat_iso A) : is_nat_trans _ _ (λ a : ob C, inv_from_iso (tpair _ _ (H a))). Proof. red. intros x x' f. apply pathsinv0. apply iso_inv_on_right. rewrite assoc. apply iso_inv_on_left. set (HA:= pr2 A). simpl in *. apply pathsinv0. unfold is_nat_trans in HA. apply HA. Qed. Lemma is_nat_trans_inv_from_pointwise_inv (C : precategory_data)(D : precategory) (hs: has_homsets D) (F G : ob [C,D,hs]) (A : F --> G) (H : is_nat_iso A) : is_nat_trans _ _ (λ a : ob C, inv_from_iso (tpair _ _ (H a))). Proof. apply is_nat_trans_inv_from_pointwise_inv_ext. exact hs. Qed. Definition nat_trans_inv_from_pointwise_inv (C : precategory_data)(D : precategory) (hs: has_homsets D) (F G : ob [C,D,hs]) (A : F --> G) (H : is_nat_iso A) : G --> F := tpair _ _ (is_nat_trans_inv_from_pointwise_inv _ _ _ _ _ _ H). Definition nat_trans_inv_from_pointwise_inv_ext {C : precategory_data}{D : precategory} (hs: has_homsets D) {F G : functor_data C D} (A : nat_trans F G) (H : is_nat_iso A) : nat_trans G F := tpair _ _ (is_nat_trans_inv_from_pointwise_inv_ext hs H). Lemma nat_trans_inv_is_iso {C : precategory_data}{D : precategory} (hs: has_homsets D) {F G : functor_data C D} (A : nat_trans F G) (H : is_nat_iso A) : is_nat_iso (nat_trans_inv_from_pointwise_inv_ext hs A H). Proof. intros a. apply is_iso_inv_from_iso. Defined. Lemma is_inverse_nat_trans_inv_from_pointwise_inv (C : precategory_data)(C' : precategory) (hs: has_homsets C') (F G : [C, C', hs]) (A : F --> G) (H : is_nat_iso A) : is_inverse_in_precat A (nat_trans_inv_from_pointwise_inv C C' _ F G A H). Proof. simpl; split; simpl. - apply nat_trans_eq. apply hs. intro x; simpl. set (T := iso_inv_after_iso (tpair _ (pr1 A x) (H x))). apply T. - apply nat_trans_eq. apply hs. intro x; simpl. set (T := iso_after_iso_inv (tpair _ (pr1 A x) (H x))). apply T. Qed. Lemma functor_iso_if_pointwise_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) : is_nat_iso A -> is_iso A . Proof. intro H. apply (is_iso_qinv _ (nat_trans_inv_from_pointwise_inv _ _ _ _ _ _ H)). simpl; apply is_inverse_nat_trans_inv_from_pointwise_inv. Defined. Definition functor_iso_from_pointwise_iso (C : precategory_data)(C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (H : is_nat_iso A) : iso F G := tpair _ _ (functor_iso_if_pointwise_iso _ _ _ _ _ _ H). Lemma is_functor_iso_pointwise_if_iso (C : precategory_data)(C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) : is_iso A -> is_nat_iso A. Proof. intros H a. set (T := inv_from_iso (tpair _ A H)). set (TA := iso_inv_after_iso (tpair _ A H)). set (TA' := iso_after_iso_inv (tpair _ A H)). simpl in *. apply (is_iso_qinv _ (T a)). unfold is_inverse_in_precat in *; simpl; split. - unfold T. set (H1' := nat_trans_eq_pointwise TA). apply H1'. - apply (nat_trans_eq_pointwise TA'). Defined. Lemma is_functor_z_iso_pointwise_if_z_iso (C : precategory_data)(C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) : is_z_isomorphism A -> is_nat_z_iso (pr1 A). Proof. intros H a. set (T := inv_from_z_iso (tpair _ A H)). set (TA := z_iso_inv_after_z_iso (tpair _ A H)). set (TA' := z_iso_after_z_iso_inv (tpair _ A H)). simpl in *. exists (T a). split. - unfold T. set (H1' := nat_trans_eq_pointwise TA). apply H1'. - apply (nat_trans_eq_pointwise TA'). Defined. Lemma nat_trans_inv_pointwise_inv_before (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_iso A) : ∏ a : C, pr1 (inv_from_iso (make_iso A Aiso)) a · pr1 A a = identity _ . Proof. intro a. set (TA' := iso_after_iso_inv (make_iso A Aiso)). apply (nat_trans_eq_pointwise TA'). Qed. Lemma nat_trans_inv_pointwise_inv_after (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_iso A) : ∏ a : C, pr1 A a · pr1 (inv_from_iso (make_iso A Aiso)) a = identity _ . Proof. intro a. set (TA := iso_inv_after_iso (make_iso A Aiso)). apply (nat_trans_eq_pointwise TA). Qed. Lemma nat_trans_inv_pointwise_inv_before_z_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_z_isomorphism A) : ∏ a : C, pr1 (inv_from_z_iso (A,, Aiso)) a · pr1 A a = identity _ . Proof. intro a. set (TA' := z_iso_after_z_iso_inv (A,,Aiso)). apply (nat_trans_eq_pointwise TA'). Qed. Lemma nat_trans_inv_pointwise_inv_after_z_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_z_isomorphism A) : ∏ a : C, pr1 A a · pr1 (inv_from_z_iso (A,,Aiso)) a = identity _ . Proof. intro a. set (TA := z_iso_inv_after_z_iso (A,,Aiso)). apply (nat_trans_eq_pointwise TA). Qed. Definition functor_iso_pointwise_if_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C',hs]) (A : F --> G) (H : is_iso A) : ∏ a : ob C, iso (pr1 F a) (pr1 G a) := λ a, tpair _ _ (is_functor_iso_pointwise_if_iso C C' _ F G A H a). Definition functor_z_iso_pointwise_if_z_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C',hs]) (A : F --> G) (H : is_z_isomorphism A) : ∏ a : ob C, z_iso (pr1 F a) (pr1 G a) := λ a, tpair _ _ (is_functor_z_iso_pointwise_if_z_iso C C' _ F G A H a). Lemma nat_trans_inv_pointwise_inv_after_p (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_iso A) a : inv_from_iso (functor_iso_pointwise_if_iso C C' hs F G A Aiso a) = pr1 (inv_from_iso (make_iso A Aiso)) a. Proof. apply pathsinv0. apply inv_iso_unique'. unfold precomp_with. simpl. set (TA := iso_inv_after_iso (make_iso A Aiso)). simpl in TA. apply (nat_trans_eq_pointwise TA). Qed. Lemma nat_trans_inv_pointwise_inv_after_p_z_iso (C : precategory_data) (C' : precategory) (hs: has_homsets C') (F G : ob [C, C', hs]) (A : F --> G) (Aiso: is_z_isomorphism A) a : inv_from_z_iso (functor_z_iso_pointwise_if_z_iso C C' hs F G A Aiso a) = pr1 (inv_from_z_iso (A,, Aiso)) a. Proof. apply idpath. Qed. Definition pr1_pr1_functor_eq_from_functor_iso (C : precategory_data) (D : category) (H : is_univalent D) (F G : functor_category C D) : z_iso F G -> pr1 (pr1 F) = pr1 (pr1 G). Proof. intro A. apply funextsec. intro t. apply isotoid. assumption. apply (functor_z_iso_pointwise_if_z_iso _ _ _ _ _ A). apply (pr2 A). Defined. Lemma transport_of_functor_map_is_pointwise (C : precategory_data) (D : precategory) (F0 G0 : ob C -> ob D) (F1 : ∏ a b : ob C, a --> b -> F0 a --> F0 b) (gamma : F0 = G0 ) (a b : ob C) (f : a --> b) : transportf (fun x : ob C -> ob D => ∏ a0 b0 : ob C, a0 --> b0 -> x a0 --> x b0) gamma F1 a b f = double_transport (toforallpaths (λ _ : ob C, D) F0 G0 gamma a) (toforallpaths (λ _ : ob C, D) F0 G0 gamma b) (F1 a b f). Proof. induction gamma. apply idpath. Qed. Lemma nat_trans_comp_pointwise (C : precategory_data)(C' : precategory) (hs: has_homsets C') (F G H : ob [C, C', hs]) (A : F --> G) (A' : G --> H) (B : F --> H) : A · A' = B -> ∏ a, pr1 A a · pr1 A' a = pr1 B a. Proof. intros H' a. intermediate_path (pr1 (A · A') a). apply idpath. destruct H'. apply idpath. Qed. Definition pr1_functor_eq_from_functor_z_iso (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C , D, D]) : z_iso F G -> pr1 F = pr1 G. Proof. intro A. apply (total2_paths_f (pr1_pr1_functor_eq_from_functor_iso C D H F G A)). unfold pr1_pr1_functor_eq_from_functor_iso. apply funextsec; intro a. apply funextsec; intro b. apply funextsec; intro f. rewrite transport_of_functor_map_is_pointwise. rewrite toforallpaths_funextsec. etrans. { apply double_transport_idtoiso. } rewrite idtoiso_isotoid. rewrite idtoiso_isotoid. etrans. { rewrite <- assoc. apply cancel_precomposition. apply (nat_trans_ax (pr1 A)). } etrans. { apply cancel_postcomposition. apply nat_trans_inv_pointwise_inv_after_p_z_iso. } rewrite assoc. apply remove_id_left; try apply idpath. set (TA' := z_iso_after_z_iso_inv A). set (TA'' := nat_trans_comp_pointwise _ _ _ _ _ _ _ _ _ TA'). apply TA''. Defined. Definition functor_eq_from_functor_z_iso {C : precategory_data} {D : category} (H : is_univalent D) (F G : ob [C , D, D]) (H' : z_iso F G) : F = G. Proof. apply (functor_eq _ _ D F G). apply pr1_functor_eq_from_functor_z_iso; assumption. Defined. Lemma idtoiso_functorcat_compute_pointwise (C : precategory_data) (D : precategory) (hs: has_homsets D) (F G : ob [C, D, hs]) (p : F = G) (a : ob C) : functor_z_iso_pointwise_if_z_iso C D _ F G (idtoiso p) (pr2 (idtoiso p)) a = idtoiso (toforallpaths (λ _ : ob C, D) (pr1 (pr1 F)) (pr1 (pr1 G)) (base_paths (pr1 F) (pr1 G) (base_paths F G p)) a). Proof. induction p. apply (z_iso_eq(C:=D,,hs)). apply idpath. Qed. Lemma functor_eq_from_functor_z_iso_idtoiso (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C, D, D]) (p : F = G) : functor_eq_from_functor_z_iso H F G (idtoiso p) = p. Proof. simpl; apply functor_eq_eq_from_functor_ob_eq. apply D. unfold functor_eq_from_functor_z_iso. unfold functor_eq. rewrite base_total2_paths. unfold pr1_functor_eq_from_functor_z_iso. rewrite base_total2_paths. unfold pr1_pr1_functor_eq_from_functor_iso. apply (invmaponpathsweq (weqtoforallpaths _ _ _ )). simpl. rewrite toforallpaths_funextsec. apply funextsec; intro a. rewrite idtoiso_functorcat_compute_pointwise. apply isotoid_idtoiso. Qed. Lemma idtoiso_functor_eq_from_functor_z_iso (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C, D, D]) (gamma : z_iso F G) : idtoiso (functor_eq_from_functor_z_iso H F G gamma) = gamma. Proof. apply (z_iso_eq(C:=functor_category C D)). simpl; apply nat_trans_eq; intro a. apply D. assert (H' := idtoiso_functorcat_compute_pointwise C D _ F G (functor_eq_from_functor_z_iso H F G gamma) a). simpl in *. assert (H2 := maponpaths (@pr1 _ _ ) H'). simpl in H2. etrans. { apply H2. } clear H' H2. unfold functor_eq_from_functor_z_iso. unfold functor_eq. rewrite base_total2_paths. unfold pr1_functor_eq_from_functor_z_iso. rewrite base_total2_paths. intermediate_path (pr1 (idtoiso (isotoid D H (functor_z_iso_pointwise_if_z_iso C D D F G gamma (pr2 gamma) a)))). 2: { rewrite idtoiso_isotoid. apply idpath. } apply maponpaths. apply maponpaths. unfold pr1_pr1_functor_eq_from_functor_iso. rewrite toforallpaths_funextsec. apply idpath. Qed. Lemma isweq_idtoiso_functorcat (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C, D, D]) : isweq (@idtoiso _ F G). Proof. apply (isweq_iso _ (functor_eq_from_functor_z_iso H F G)). apply functor_eq_from_functor_z_iso_idtoiso. apply idtoiso_functor_eq_from_functor_z_iso. Defined. Lemma is_univalent_functor_category (C : precategory_data) (D : category) (H : is_univalent D) : is_univalent (functor_category C D). Proof. intros F G. apply isweq_idtoiso_functorcat. apply H. Defined. Definition univalent_functor_category (C₁ C₂ : univalent_category) : univalent_category. Proof. use make_univalent_category. - exact (functor_category C₁ C₂). - exact (is_univalent_functor_category _ _ (pr2 C₂)). Defined. Definition iso_to_nat_iso {C D : category} (F G : C ⟶ D) : @iso (functor_category C D) F G → nat_iso F G. Proof. intros α. use make_nat_iso. - exact (pr1 α). - use is_functor_iso_pointwise_if_iso. apply α. Defined. Definition nat_iso_to_iso {C D : category} (F G : C ⟶ D) : nat_iso F G → @iso (functor_category C D) F G. Proof. intros α. use functor_iso_from_pointwise_iso ; apply α. Defined. Definition iso_is_nat_iso {C D : category} (F G : C ⟶ D) : @iso (functor_category C D) F G ≃ nat_iso F G. Proof. refine (make_weq (iso_to_nat_iso F G) _). use isweq_iso. - exact (nat_iso_to_iso F G). - intros X. use subtypePath. + intro. apply isaprop_is_iso. + apply nat_trans_eq. { apply D. } reflexivity. - intros X. use subtypePath. + intro. apply isaprop_is_nat_iso. + reflexivity. Defined. Lemma functor_comp_pw {C C' D D' : precategory} hsD hsD' (F : [C,D,hsD] ⟶ [C',D',hsD']) {a b c} (f : [C,D,hsD] ⟦ a, b ⟧) (g : [C,D,hsD] ⟦ b, c ⟧) (x :C') : (# F f:nat_trans _ _) x · (# F g:nat_trans _ _) x = ((# F (f · g)) : nat_trans _ _ ) x . Proof. now rewrite functor_comp. Qed. Lemma functor_cancel_pw {C C' D D' : precategory} hsD hsD' (F : [C,D,hsD] ⟶ [C',D',hsD']) {a b } (f g : [C,D,hsD] ⟦ a, b ⟧) (x :C') : f = g -> ((# F f ) : nat_trans _ _ ) x = (# F g:nat_trans _ _) x . Proof. intro e. now induction e. Qed. (** a small diversion on [z_iso] for natural transformations *) Lemma nat_trafo_z_iso_if_pointwise_z_iso {C : precategory_data} {C' : precategory} (hs: has_homsets C') {F G : ob [C, C', hs]} (α : F --> G) : is_nat_z_iso (pr1 α) -> is_z_isomorphism α . Proof. intro H. red. set (αinv := nat_z_iso_to_trans_inv (make_nat_z_iso _ _ α H)). exists αinv. split; apply (nat_trans_eq hs); intro c; cbn. - exact (pr1 (pr2 (H c))). - exact (pr2 (pr2 (H c))). Defined. Definition z_iso_from_nat_z_iso {C : precategory_data} {C' : precategory} (hs: has_homsets C') {F G : ob [C, C', hs]} (α : nat_z_iso F G) : z_iso F G := pr1 α ,, nat_trafo_z_iso_if_pointwise_z_iso hs (pr1 α) (pr2 α). (** the other direction is even more basic since the homset requirement is not used in the proof *) Lemma nat_trafo_pointwise_z_iso_if_z_iso {C : precategory_data} {C' : precategory} (hs: has_homsets C') {F G : ob [C, C', hs]} (α : F --> G) : is_z_isomorphism α -> is_nat_z_iso (pr1 α). Proof. intro H. red. intro c. set (αcinv := pr1 (inv_from_z_iso (α,,H)) c). use make_is_z_isomorphism. - exact αcinv. - assert (HH := is_z_isomorphism_is_inverse_in_precat H). induction HH as [HH1 HH2]. apply (maponpaths pr1) in HH1. apply toforallpaths in HH1. apply (maponpaths pr1) in HH2. apply toforallpaths in HH2. split. + apply HH1. + apply HH2. Defined. Definition nat_z_iso_from_z_iso {C : precategory_data} {C' : precategory} (hs: has_homsets C') {F G : ob [C, C', hs]} (α : z_iso F G) : nat_z_iso F G := pr1 α ,, nat_trafo_pointwise_z_iso_if_z_iso hs (pr1 α) (pr2 α). Definition z_iso_is_nat_z_iso {C D : category} (F G : C ⟶ D) : @z_iso (functor_category C D) F G ≃ nat_z_iso F G. Proof. refine (make_weq (nat_z_iso_from_z_iso D (F:=F)(G:=G)) _). use isweq_iso. - apply z_iso_from_nat_z_iso. - intros X. use subtypePath. + intro. apply (isaprop_is_z_isomorphism(C:=functor_category C D)). + apply nat_trans_eq. { apply D. } reflexivity. - intros X. use subtypePath. + intro. apply isaprop_is_nat_z_iso. + reflexivity. Defined. Notation "[ C , D , hs ]" := (functor_precategory C D hs) : cat. Notation "[ C , D ]" := (functor_category C D) : cat. Declare Scope Cat. Notation "G □ F" := (functor_composite (F:[_,_]) (G:[_,_]) : [_,_]) (at level 35) : Cat. (* to input: type "\Box" or "\square" or "\sqw" or "\sq" with Agda input method *) Definition functor_compose {A B C : category} (F : ob [A, B]) (G : ob [B , C]) : ob [A , C] := functor_composite F G. (* Local Notation "G 'O' F '{' hsB hsC '}'" := (functor_compose hsB hsC F G) (at level 200). Local Notation "G 'o' F '{' hsB hsC '}'" := (functor_compose hsB hsC F G : functor _ _ ) (at level 200). *) UniMath-20231010/UniMath/CategoryTheory/FunctorCoalgebras.v000066400000000000000000000241471451125700300234260ustar00rootroot00000000000000(** *************************************************************** Contents: - Category of coalgebras over an endofunctor. - Dual of Lambek's lemma: if (A,α) is final coalgebra, α is an isomorphism. - Primitive corecursion. ******************************************************************) Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Section Coalgebra_Definition. Context {C : category} (F : functor C C). Definition coalgebra_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. use tpair. - exact (λ x, x --> F x). - exact (λ x y hx hy f, hx · #F f = f · hy). Defined. Definition coalgebra_disp_cat_id_comp : disp_cat_id_comp C coalgebra_disp_cat_ob_mor. Proof. split. - intros x hx ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - intros x y z f g hx hy hz hf hg ; cbn in *. rewrite !functor_comp. rewrite !assoc. rewrite hf. rewrite !assoc'. rewrite hg. apply idpath. Qed. Definition coalgebra_disp_cat_data : disp_cat_data C := coalgebra_disp_cat_ob_mor ,, coalgebra_disp_cat_id_comp. Definition coalgebra_disp_cat_axioms : disp_cat_axioms C coalgebra_disp_cat_data. Proof. repeat split ; intros ; try (apply homset_property). apply isasetaprop. apply homset_property. Qed. Definition coalgebra_disp_cat : disp_cat C := coalgebra_disp_cat_data ,, coalgebra_disp_cat_axioms. Definition CoAlg_category : category := total_category coalgebra_disp_cat. Definition coalgebra_ob : UU := ob CoAlg_category. Definition coalg_carrier (X : coalgebra_ob) : C := pr1 X. Local Coercion coalg_carrier : coalgebra_ob >-> ob. Definition coalg_map (X : coalgebra_ob) : C ⟦X, F X ⟧ := pr2 X. (** A homomorphism of F-coalgebras (F A, α : C ⟦A, F A⟧) and (F B, β : C ⟦B, F B⟧) is a morphism f : C ⟦A, B⟧ s.t. the below diagram commutes. << f A -----> B | | | α | β | | V V F A ---> F B F f >> *) Definition is_coalgebra_mor (X Y : coalgebra_ob) (f : coalg_carrier X --> coalg_carrier Y) : UU := coalg_map X · #F f = f · coalg_map Y. Definition coalgebra_mor (X Y : coalgebra_ob) : UU := CoAlg_category⟦X,Y⟧. Coercion mor_from_coalgebra_mor {X Y : coalgebra_ob} (f : coalgebra_mor X Y) : C⟦X, Y⟧ := pr1 f. Lemma coalgebra_mor_commutes {X Y : coalgebra_ob} (f : coalgebra_mor X Y) : coalg_map X · #F f = pr1 f · coalg_map Y. Proof. exact (pr2 f). Qed. Definition coalgebra_homo_eq {X Y : coalgebra_ob} (f g : coalgebra_mor X Y) : (f : C ⟦X, Y⟧) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro. apply homset_property. Defined. End Coalgebra_Definition. Section Lambek_dual. (** Dual of Lambeks Lemma : If (A,α) is final F-coalgebra, then α is an iso *) Context (C : category) (F : functor C C) (X : coalgebra_ob F). Local Notation F_CoAlg := (CoAlg_category F). Context (isTerminalX : isTerminal F_CoAlg X). Definition TerminalX : Terminal F_CoAlg := make_Terminal _ isTerminalX. Local Notation α := (coalg_map F (TerminalObject TerminalX)). Local Notation A := (coalg_carrier F (TerminalObject TerminalX)). (** FX := (FA,Fα) is also an F-coalgebra *) Definition FX : ob F_CoAlg := tpair _ (F A) (#F α). (** By terminality there is an arrow α' : FA → A, s.t.: << α' FA ------> A | | | Fα | α V V FFA ------> FA Fα' >> commutes *) Definition f : F_CoAlg ⟦FX, TerminalX⟧ := (@TerminalArrow F_CoAlg TerminalX FX). Definition α' : C ⟦F A, A⟧ := mor_from_coalgebra_mor F f. Definition αα'_mor : coalgebra_mor F X X. Proof. exists (α · α'). simpl. rewrite <- assoc. apply cancel_precomposition. rewrite functor_comp. apply (coalgebra_mor_commutes F f). Defined. Definition αα'_idA : α · α' = identity A := maponpaths pr1 (TerminalEndo_is_identity (T:=TerminalX) αα'_mor). Lemma α'α_idFA : α' · α = identity (F A). Proof. rewrite <- functor_id. rewrite <- αα'_idA. rewrite functor_comp. unfold α'. apply pathsinv0. apply (coalgebra_mor_commutes F f). Defined. Lemma finalcoalgebra_is_z_iso : is_z_isomorphism α. Proof. use make_is_z_isomorphism. - exact α'. - split. + exact αα'_idA. + exact α'α_idFA. Defined. Definition finalcoalgebra_z_iso : z_iso A (F A) := α,, finalcoalgebra_is_z_iso. (* Definition finalcoalgebra_iso : iso A (F A) := z_iso_to_iso finalcoalgebra_z_iso. *) End Lambek_dual. Section PrimitiveCorecursion. Context {C : category} (CP : BinCoproducts C) {F : functor C C} {νF : coalgebra_ob F} (isTerminalνF : isTerminal (CoAlg_category F) νF). Context {x : C} (ϕ : C⟦x, F(CP x (pr1 νF))⟧). Definition X_coproduct_νF_coalgebra : coalgebra_ob F. Proof. exists (CP x (pr1 νF)). exact (BinCoproductArrow (CP x (pr1 νF)) ϕ (pr2 νF · #F (BinCoproductIn2 (CP x (pr1 νF))))). Defined. Let h : C⟦x, pr1 νF⟧ := (BinCoproductIn1 (CP x (pr1 νF)) · pr1 (@TerminalArrow (CoAlg_category F) (νF,,isTerminalνF) X_coproduct_νF_coalgebra)). Lemma X_coproduct_νF_coalgebra_morphism_into_νF_aux : pr2 X_coproduct_νF_coalgebra -->[ BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))] pr2 νF. Proof. cbn. etrans. 1: apply postcompWithBinCoproductArrow. etrans. 2: apply pathsinv0, postcompWithBinCoproductArrow. assert (p0 : ϕ · # F (BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))) = h · pr2 νF). { unfold h. set (t := pr2 (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)). cbn in t. etrans. 2: apply assoc. etrans. 2: apply maponpaths, t. etrans. 2: apply assoc'. etrans. 2: apply maponpaths_2, pathsinv0, BinCoproductIn1Commutes. do 2 apply maponpaths. assert (p1 : identity (pr1 νF) = BinCoproductIn2 (CP x (pr1 νF)) · pr1 (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)). { etrans. 1: apply (base_paths _ _ (TerminalArrowUnique (νF,,isTerminalνF) νF (identity _))). transparent assert (f : ((CoAlg_category F)⟦νF,νF⟧)). { refine (_ · (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)). exists (BinCoproductIn2 (CP x (pr1 νF))). apply pathsinv0, BinCoproductIn2Commutes. } exact (! base_paths _ _ (TerminalArrowUnique (νF,,isTerminalνF) νF f)). } rewrite p1. apply pathsinv0, BinCoproductArrowEta. } rewrite p0. apply maponpaths. etrans. 1: apply assoc'. etrans. { apply maponpaths. etrans. 1: apply pathsinv0, functor_comp. apply maponpaths. apply BinCoproductIn2Commutes. } etrans. { apply maponpaths. apply functor_id. } exact (id_right _ @ ! id_left _). Qed. Definition X_coproduct_νF_coalgebra_morphism_into_νF : (CoAlg_category F ⟦ X_coproduct_νF_coalgebra, νF⟧). Proof. exists (BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))). exact X_coproduct_νF_coalgebra_morphism_into_νF_aux. Defined. Definition primitive_corecursion_characteristic_formula (h : C⟦x, pr1 νF⟧) : UU := h · (pr2 νF) = ϕ · #F (BinCoproductArrow (CP _ _) h (identity _)). Lemma primitive_corecursion_existence : primitive_corecursion_characteristic_formula h. Proof. etrans. { apply assoc'. } etrans. { apply maponpaths. exact (! pr2 (@TerminalArrow (CoAlg_category F) (νF,,isTerminalνF) X_coproduct_νF_coalgebra)). } cbn. etrans. { apply assoc. } etrans. { apply maponpaths_2. apply BinCoproductIn1Commutes. } do 2 apply maponpaths. apply pathsinv0. exact (base_paths _ _ (TerminalArrowUnique (νF,, isTerminalνF) _ X_coproduct_νF_coalgebra_morphism_into_νF)). Qed. Lemma primitive_corecursion_aux (p : ∑ h : C ⟦ x, pr1 νF ⟧, primitive_corecursion_characteristic_formula h) : p = h,, primitive_corecursion_existence. Proof. use total2_paths_f. - assert (q : (pr1 p = BinCoproductIn1 (CP x (pr1 νF)) · (BinCoproductArrow (CP _ _) (pr1 p) (identity _)))). { apply pathsinv0, BinCoproductIn1Commutes. } etrans. 1: exact q. simpl. apply maponpaths. transparent assert ( f : ( CoAlg_category F ⟦ X_coproduct_νF_coalgebra, νF⟧)). { exists ( BinCoproductArrow (CP x (pr1 νF)) (pr1 p) (identity (pr1 νF))). cbn. etrans. 1: apply postcompWithBinCoproductArrow. etrans. 2: apply pathsinv0, postcompWithBinCoproductArrow. use (BinCoproductArrowUnique _ _ _ (CP x (pr1 νF)) (F (pr1 νF))). - etrans. 1: apply BinCoproductIn1Commutes. exact (! pr2 p). - etrans. 1: apply BinCoproductIn2Commutes. etrans. 1: apply assoc'. etrans. { apply maponpaths. etrans. 1: apply pathsinv0, functor_comp. apply maponpaths. apply BinCoproductIn2Commutes. } etrans. { apply maponpaths. apply functor_id. } exact (id_right _ @ ! id_left _). } exact (base_paths _ _ (TerminalArrowUnique (νF,, isTerminalνF) X_coproduct_νF_coalgebra f)). - apply homset_property. Qed. Definition primitive_corecursion : ∃! h : C⟦x, pr1 νF⟧, primitive_corecursion_characteristic_formula h. Proof. exists (h ,, primitive_corecursion_existence). apply primitive_corecursion_aux. Defined. End PrimitiveCorecursion. UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/000077500000000000000000000000001451125700300246455ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/IsOpfibration.v000066400000000000000000000141361451125700300276110ustar00rootroot00000000000000(******************************************************************************* We show that the functor `∫ F ⟶ C` is a Street opfibration *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory. Require Import UniMath.CategoryTheory.GrothendieckConstruction.Projection. Local Open Scope cat. Section IsOpcartesianTotalSetCategory. Context {C : setcategory} (G : C ⟶ cat_of_setcategory) {e₁ e₂ : total_setcategory_of_set_functor G} {f : e₁ --> e₂} (Hf : is_z_isomorphism (pr2 f)). Section Factorization. Context {e₃ : total_setcategory_of_set_functor G} (g : e₁ --> e₃) (h : pr1 e₂ --> pr1 e₃) (p : pr1 g = pr1 f · h). Definition is_opcartesian_total_setcategory_of_set_functor_factor_unique : isaprop (∑ φ, # (pr1_total_category_of_set_functor G) φ = h × f · φ = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_mor_category_of_set_functor. - exact (pr12 φ₁ @ !(pr12 φ₂)). - pose (q := eq_mor_category_of_set_functor_pr2 (pr22 φ₁ @ !(pr22 φ₂))). cbn in q. use (cancel_z_iso' (# (pr1 (# G (pr11 φ₁))) (pr2 f) ,, _)). { cbn. apply functor_on_is_z_isomorphism. exact Hf. } cbn. use (cancel_z_iso' (idtoiso (eq_in_set_fiber (functor_comp G (pr1 f) (pr11 φ₁)) (pr2 e₁)))). rewrite !assoc. refine (q @ _) ; clear q. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. apply maponpaths_2. apply (from_eq_cat_of_setcategory (maponpaths (λ z, #G z) (pr12 φ₁ @ !(pr12 φ₂))) (pr2 f)). } rewrite !assoc'. etrans. { do 3 apply maponpaths. etrans. { refine (!_). apply (pr1_idtoiso_concat (maponpaths (λ z, (pr11 z) (pr2 e₂)) (!(maponpaths (λ z, # G z) (pr12 φ₁ @ ! pr12 φ₂))))). } apply setcategory_refl_idtoiso. } rewrite id_right. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply pr1_idtoiso_concat. } refine (!_). etrans. { refine (!_). exact (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G (pr1 f) (pr11 φ₂)) (pr2 e₁))). } apply setcategory_eq_idtoiso. Qed. Definition is_opcartesian_total_setcategory_of_set_functor_factor_eq : pr1 (# G h) (pr1 (# G (pr1 f)) (pr2 e₁)) = pr1 (# G (pr1 g)) (pr2 e₁). Proof. refine (!(eq_in_set_fiber (functor_comp G (pr1 f) h) (pr2 e₁)) @ _). apply maponpaths_2. do 2 apply maponpaths. exact (!p). Qed. Definition is_opcartesian_total_setcategory_of_set_functor_factor : e₂ --> e₃. Proof. refine (h ,, #(pr1 (#G h)) (inv_from_z_iso (_ ,, Hf)) · idtoiso _ · pr2 g). apply is_opcartesian_total_setcategory_of_set_functor_factor_eq. Defined. Definition is_opcartesian_total_setcategory_of_set_functor_factor_comm : f · is_opcartesian_total_setcategory_of_set_functor_factor = g. Proof. unfold is_opcartesian_total_setcategory_of_set_functor_factor. use eq_mor_category_of_set_functor. - cbn. exact (!p). - cbn. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply functor_comp. } etrans. { apply maponpaths. exact (z_iso_inv_after_z_iso (pr2 f ,, Hf)). } apply functor_id. } rewrite id_left. etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G _ _) _)). } apply setcategory_eq_idtoiso. Qed. End Factorization. Definition is_opcartesian_total_setcategory_of_set_functor : is_opcartesian_sopfib (pr1_total_category_of_set_functor G) f. Proof. intros e₃ g h p. use iscontraprop1. - exact (is_opcartesian_total_setcategory_of_set_functor_factor_unique g h). - simple refine (_ ,, (_ ,, _)). + exact (is_opcartesian_total_setcategory_of_set_functor_factor g h p). + abstract (cbn ; apply idpath). + exact (is_opcartesian_total_setcategory_of_set_functor_factor_comm g h p). Defined. End IsOpcartesianTotalSetCategory. Definition street_opfib_pr1_total_setcategory {C : setcategory} (G : C ⟶ cat_of_setcategory) : street_opfib (pr1_total_category_of_set_functor G). Proof. intros x y f. simple refine (_ ,, (_ ,, _) ,, _ ,, _). - exact (y ,, pr1 (#G f) (pr2 x)). - exact (f ,, identity _). - apply identity_z_iso. - exact (!(id_right f)). - apply is_opcartesian_total_setcategory_of_set_functor. apply is_z_isomorphism_identity. Defined. UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/IsPullback.v000066400000000000000000001146161451125700300270760ustar00rootroot00000000000000(******************************************************************************* Pullbacks from the Grothendieck construction We show that the following square is a pullback square ∫ G₁ ⟶ ∫ G₂ | | V V C₁ ⟶ C₂ *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory. Require Import UniMath.CategoryTheory.GrothendieckConstruction.Projection. Require Import UniMath.CategoryTheory.GrothendieckConstruction.IsosInTotal. Local Open Scope cat. Section PullbackFromTotal. Context {C₁ C₂ : setcategory} {F : C₁ ⟶ C₂} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} (α : G₁ ⟹ F ∙ G₂) (Hα : is_nat_z_iso α). Let αiso : nat_z_iso G₁ (F ∙ G₂) := α ,, Hα. Let αinv : F ∙ G₂ ⟹ G₁ := nat_z_iso_inv αiso. Local Lemma α_iso_α_inv (x : C₁) (y : pr1 (G₂ (F x))) : pr1 (α x) (pr1 (αinv x) y) = y. Proof. exact (maponpaths (λ z, pr11 z y) (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso αiso x))). Qed. Local Lemma α_iso_α_inv_on_mor (x : C₁) {y₁ y₂ : pr1 (G₂ (F x))} (f : y₁ --> y₂) : # (pr1 (α x)) (# (pr1 (αinv x)) f) = idtoiso (α_iso_α_inv x y₁) · f · idtoiso (!(α_iso_α_inv x y₂)). Proof. refine (from_eq_cat_of_setcategory (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso αiso x)) f @ _) ; cbn. apply setcategory_eq_idtoiso_comp. Qed. Local Lemma α_inv_α_iso (x : C₁) (y : pr1 (G₁ x)) : pr1 (αinv x) (pr1 (α x) y) = y. Proof. exact (maponpaths (λ z, pr11 z y) (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso αiso x))). Qed. Local Lemma α_inv_α_iso_on_mor (x : C₁) {y₁ y₂ : pr1 (G₁ x)} (f : y₁ --> y₂) : # (pr1 (αinv x)) (# (pr1 (α x)) f) = idtoiso (α_inv_α_iso x y₁) · f · idtoiso (!(α_inv_α_iso x y₂)). Proof. refine (from_eq_cat_of_setcategory (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso αiso x)) f @ _) ; cbn. apply setcategory_eq_idtoiso_comp. Qed. Section PbMor. Context {C₀ : setcategory} (P₁ : C₀ ⟶ C₁) (P₂ : C₀ ⟶ total_setcategory_of_set_functor G₂) (β : P₁ ∙ F ⟹ P₂ ∙ pr1_total_category_of_set_functor G₂) (Hβ : is_nat_z_iso β). Definition total_set_category_pb_ump_1_mor_eq {x y : C₀} (f : x --> y) : pr1 (# G₁ (# P₁ f)) ((pr11 (αinv (P₁ x))) ((pr11 (# G₂ (pr1 (Hβ x)))) (pr2 (P₂ x)))) = pr1 (αinv (P₁ y)) (pr1 (# G₂ (pr1 (Hβ y))) (pr1 (# G₂ (pr1 (# P₂ f))) (pr2 (P₂ x)))). Proof. pose (maponpaths (λ z, pr11 z ((pr11 (# G₂ (pr1 (Hβ x)))) (pr2 (P₂ x)))) (nat_trans_ax αinv _ _ (#P₁ f))) as p. cbn -[αinv] in p. refine (!p @ _). apply maponpaths. refine (maponpaths (λ z, pr11 z (pr2 (P₂ x))) (!(functor_comp G₂ (pr1 (Hβ x)) (# F (# P₁ f)))) @ _). refine (!(maponpaths (λ z, pr1 (# G₂ z) (pr2 (P₂ x))) (nat_trans_ax (nat_z_iso_inv (β ,, Hβ)) _ _ f)) @ _). exact (maponpaths (λ z, pr11 z (pr2 (P₂ x))) (functor_comp G₂ _ _)). Qed. Definition total_set_category_pb_ump_1_mor_data : functor_data C₀ (total_setcategory_of_set_functor G₁). Proof. use make_functor_data. - refine (λ x, P₁ x ,, _). apply (αinv (P₁ x)). apply (# G₂ (pr1 (Hβ x))). exact (pr2 (P₂ x)). - refine (λ x y f, #P₁ f ,, _ · #(pr1 (αinv (P₁ y))) (# (pr1 (# G₂ (pr1 (Hβ y)))) (pr2 (# P₂ f)))). apply idtoiso. exact (total_set_category_pb_ump_1_mor_eq f). Defined. Definition total_set_category_pb_ump_1_mor_is_functor : is_functor total_set_category_pb_ump_1_mor_data. Proof. split. - intro x. use eq_mor_category_of_set_functor. + apply functor_id. + cbn -[αinv]. etrans. { do 3 apply maponpaths. exact (eq_mor_category_of_set_functor_pr2 (functor_id P₂ x)). } cbn -[αinv]. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id G₂ _) _)). } refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (Hβ x)))). } refine (!_). apply (pr1_maponpaths_idtoiso (αinv (P₁ x))). } etrans. { refine (!_). apply (pr1_idtoiso_concat (total_set_category_pb_ump_1_mor_eq _)). } refine (!_). etrans. { refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id G₁ (P₁ x)) _)). } apply setcategory_eq_idtoiso. - intros x y z f g. use eq_mor_category_of_set_functor. + apply functor_comp. + cbn -[αinv]. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. exact (eq_mor_category_of_set_functor_pr2 (functor_comp P₂ f g)). } refine (functor_comp _ _ _ @ _). apply maponpaths. apply functor_comp. } refine (functor_comp _ _ _ @ _). apply maponpaths. apply functor_comp. } cbn -[αinv]. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (Hβ z)))). } refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (P₁ z))). } refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (Hβ z)))). } refine (!_). apply (pr1_maponpaths_idtoiso (αinv (P₁ z))). } refine (!_). apply (pr1_idtoiso_concat (total_set_category_pb_ump_1_mor_eq (f · g))). } refine (!_). apply (pr1_idtoiso_concat (total_set_category_pb_ump_1_mor_eq (f · g) @ _)). } refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₁ (# P₁ g))). } refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G₁ (# P₁ f) (# P₁ g)) _)). } refine (!_). apply (pr1_idtoiso_concat (_ @ eq_in_set_fiber (functor_comp G₁ (# P₁ f) (# P₁ g)) _)). } etrans. { apply maponpaths_2. apply maponpaths. exact (from_eq_cat_of_setcategory (!(nat_trans_ax αinv _ _ (# P₁ g))) (# (pr1 (# G₂ (pr1 (Hβ y)))) (pr2 (# P₂ f)))). } etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat ((_ @ eq_in_set_fiber (functor_comp G₁ (# P₁ f) (# P₁ g)) _) @ _)). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (!_). apply (pr1_idtoiso_concat _ (total_set_category_pb_ump_1_mor_eq g)). } cbn -[αinv]. etrans. { apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths. exact (from_eq_cat_of_setcategory (!(functor_comp G₂ (pr1 (Hβ y)) (# F (# P₁ g))) @ maponpaths (λ q, # G₂ q) (!(nat_trans_ax (nat_z_iso_inv (β ,, Hβ)) _ _ g)) @ functor_comp G₂ _ _) (pr2 (# P₂ f))). } refine (functor_comp _ _ _ @ _). apply maponpaths_2. apply functor_comp. } etrans. { apply maponpaths_2. do 2 (refine (assoc _ _ _ @ _) ; apply maponpaths_2). etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (P₁ z))). } refine (!_). apply (pr1_idtoiso_concat (((_ @ eq_in_set_fiber (functor_comp G₁ _ _) _) @ _) @ _)). } do 2 refine (assoc' _ _ _ @ _). etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (P₁ z))). } refine (!_). apply (pr1_idtoiso_concat _ (_ @ total_set_category_pb_ump_1_mor_eq g)). } etrans. { apply maponpaths. etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } apply id_right. } apply maponpaths_2. apply setcategory_eq_idtoiso. Qed. Definition total_set_category_pb_ump_1_mor : C₀ ⟶ total_setcategory_of_set_functor G₁. Proof. use make_functor. - exact total_set_category_pb_ump_1_mor_data. - exact total_set_category_pb_ump_1_mor_is_functor. Defined. Definition total_set_category_pb_ump_1_mor_pr1 : total_set_category_pb_ump_1_mor ∙ pr1_total_category_of_set_functor G₁ ⟹ P₁. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition total_set_category_pb_ump_1_mor_pr1_is_nat_z_iso : is_nat_z_iso total_set_category_pb_ump_1_mor_pr1. Proof. intro x. apply is_z_isomorphism_identity. Defined. Definition total_set_category_pb_ump_1_mor_pr2_eq (x : C₀) : pr1 (# G₂ (β x)) (pr1 (pr1 α (P₁ x)) ((pr11 (αinv (P₁ x))) ((pr11 (# G₂ (pr1 (Hβ x)))) (pr2 (P₂ x))))) = pr2 (P₂ x). Proof. etrans. { apply maponpaths. apply α_iso_α_inv. } etrans. { exact (maponpaths (λ z, pr11 z (pr2 (P₂ x))) (!(functor_comp G₂ (pr1 (Hβ x)) (β x)))). } etrans. { apply maponpaths_2. do 2 apply maponpaths. exact (z_iso_after_z_iso_inv (_ ,, Hβ x)). } cbn. etrans. { exact (maponpaths (λ z, pr11 z (pr2 (P₂ x))) (functor_id G₂ _)). } cbn. apply idpath. Qed. Definition total_set_category_pb_ump_1_mor_pr2_data : nat_trans_data (total_set_category_pb_ump_1_mor ∙ functor_total_category_of_set_functor F α) P₂. Proof. refine (λ x, β x ,, _). refine (idtoiso _). apply total_set_category_pb_ump_1_mor_pr2_eq. Defined. Definition total_set_category_pb_ump_1_mor_pr2_is_nat_trans : is_nat_trans _ _ total_set_category_pb_ump_1_mor_pr2_data. Proof. intros x y f. use eq_mor_category_of_set_functor. - apply (nat_trans_ax β). - cbn -[αinv]. etrans. { apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (α (P₁ y))). } etrans. { apply maponpaths. apply α_iso_α_inv_on_mor. } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat (maponpaths (pr11 (α (P₁ y))) (total_set_category_pb_ump_1_mor_eq f))). } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat _ (maponpaths (pr11 (α (P₁ y))) (total_set_category_pb_ump_1_mor_eq f) @ _)). } refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (β y))). } apply maponpaths_2. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (β y))). } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G₂ _ _) _)). } do 2 refine (assoc' _ _ _ @ _). etrans. { do 2 apply maponpaths. refine (!_). apply (pr1_idtoiso_concat _ (total_set_category_pb_ump_1_mor_pr2_eq y)). } etrans. { apply maponpaths. apply maponpaths_2. exact (from_eq_cat_of_setcategory ((!functor_comp G₂ (pr1 (Hβ y)) (β y)) @ maponpaths (λ z, # G₂ z) (z_iso_after_z_iso_inv (_ ,, Hβ y)) @ functor_id G₂ _) (pr2 (# P₂ f))). } etrans. { apply maponpaths. do 2 refine (assoc' _ _ _ @ _). do 2 apply maponpaths. refine (!_). apply (pr1_idtoiso_concat _ (_ @ total_set_category_pb_ump_1_mor_pr2_eq y)). } do 2 refine (assoc _ _ _ @ _). etrans. { do 2 apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G₂ _ _) _ @ _)). } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } refine (id_right _ @ _). refine (_ @ assoc' _ _ _). apply maponpaths_2. refine (!_). etrans. { etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (# P₂ f)))). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G₂ _ _) _)). } refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G₂ _ _) _ @ _)). } apply setcategory_eq_idtoiso. Qed. Definition total_set_category_pb_ump_1_mor_pr2 : total_set_category_pb_ump_1_mor ∙ functor_total_category_of_set_functor F α ⟹ P₂. Proof. use make_nat_trans. - exact total_set_category_pb_ump_1_mor_pr2_data. - exact total_set_category_pb_ump_1_mor_pr2_is_nat_trans. Defined. Definition total_set_category_pb_ump_1_mor_pr2_is_nat_z_iso_eq (x : C₀) : pr1 (# G₂ (pr1 (Hβ x))) (pr2 (P₂ x)) = pr1 (pr1 α (P₁ x)) ((pr11 (αinv (P₁ x))) ((pr11 (# G₂ (pr1 (Hβ x)))) (pr2 (P₂ x)))). Proof. refine (!_). apply α_iso_α_inv. Qed. Definition total_set_category_pb_ump_1_mor_pr2_is_nat_z_iso : is_nat_z_iso total_set_category_pb_ump_1_mor_pr2. Proof. intro x. use is_z_iso_total_setcategory_of_set_functor. - exact (Hβ x). - exact (idtoiso (total_set_category_pb_ump_1_mor_pr2_is_nat_z_iso_eq x)). - abstract (cbn ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (Hβ x)))) | ] ; etrans ; [ refine (!_) ; apply (pr1_idtoiso_concat _ (total_set_category_pb_ump_1_mor_pr2_is_nat_z_iso_eq x)) | ] ; apply setcategory_eq_idtoiso). - abstract (cbn ; etrans ; [ apply maponpaths_2 ; refine (!_) ; apply (pr1_maponpaths_idtoiso (# G₂ (β x))) | ] ; etrans ; [ refine (!_) ; apply (pr1_idtoiso_concat _ (total_set_category_pb_ump_1_mor_pr2_eq x)) | ] ; apply setcategory_eq_idtoiso). Defined. End PbMor. Section PbCell. Context {C₀ : setcategory} {φ₁ φ₂ : pr1 C₀ ⟶ total_setcategory_of_set_functor G₁} (δ₁ : φ₁ ∙ pr1_total_category_of_set_functor G₁ ⟹ φ₂ ∙ pr1_total_category_of_set_functor G₁) (δ₂ : φ₁ ∙ functor_total_category_of_set_functor F α ⟹ φ₂ ∙ functor_total_category_of_set_functor F α) (q : ∏ (x : C₀), pr1 (δ₂ x) = # F (δ₁ x)). Definition total_set_category_pb_ump_2_unique : isaprop (∑ (γ : φ₁ ⟹ φ₂), post_whisker γ (pr1_total_category_of_set_functor G₁) = δ₁ × post_whisker γ (functor_total_category_of_set_functor F α) = δ₂). Proof. use invproofirrelevance. intros ζ ξ. use subtypePath. { intro. use isapropdirprod ; apply isaset_nat_trans ; apply homset_property. } use nat_trans_eq. { apply homset_property. } intro x. use eq_mor_category_of_set_functor. - exact (nat_trans_eq_pointwise (pr12 ζ) x @ !(nat_trans_eq_pointwise (pr12 ξ) x)). - assert (p := maponpaths (λ z, #(pr1 (αinv (pr1 (φ₂ x)))) z) (eq_mor_category_of_set_functor_pr2 (nat_trans_eq_pointwise (pr22 ζ) x @ !(nat_trans_eq_pointwise (pr22 ξ) x)))). cbn -[αinv] in p. assert (pr1 (# G₁ (pr1 (pr1 ζ x))) (pr2 (φ₁ x)) = pr1 (αinv (pr1 (φ₂ x))) (pr1 (# G₂ (# F (pr1 ((pr11 ζ) x)))) (pr1 (pr1 α (pr1 (φ₁ x))) (pr2 (φ₁ x))))) as X. { pose (maponpaths (λ z, pr11 z (pr1 (pr1 α (pr1 (φ₁ x))) (pr2 (φ₁ x)))) (nat_trans_ax αinv _ _ (pr1 (pr11 ζ x)))) as r. cbn -[αinv] in r. refine (_ @ !r). apply maponpaths. refine (!_). apply α_inv_α_iso. } simple refine (_ @ maponpaths (λ z, idtoiso X · z · idtoiso (α_inv_α_iso _ _)) p @ _). + refine (!_). etrans. { apply maponpaths_2. apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. apply α_inv_α_iso_on_mor. } etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ x)))). } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { refine (assoc' _ _ _ @ _). apply maponpaths. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } refine (id_right _ @ _). etrans. { apply maponpaths_2. apply setcategory_refl_idtoiso. } apply id_left. + etrans. { apply maponpaths_2. apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. apply α_inv_α_iso_on_mor. } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ x)))). } refine (!_). apply pr1_idtoiso_concat. } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ x)))). } refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } do 2 refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { refine (!_). apply pr1_idtoiso_concat. } apply setcategory_refl_idtoiso. } apply id_right. } apply maponpaths_2. apply setcategory_eq_idtoiso. Qed. Definition total_set_category_pb_ump_2_cell_data : nat_trans_data φ₁ φ₂. Proof. refine (λ x, δ₁ x ,, _). refine (idtoiso _ · # (pr1 (αinv (pr1 (φ₂ x)))) (pr2 (δ₂ x)) · idtoiso _). - abstract (rewrite q ; cbn -[αinv] ; pose (maponpaths (λ z, pr11 z (pr2 (φ₁ x))) (nat_trans_ax α _ _ (δ₁ x))) as p ; cbn in p ; refine (!_) ; etrans ; [ apply maponpaths ; exact (!p) | ] ; apply α_inv_α_iso). - apply α_inv_α_iso. Defined. Definition total_set_category_pb_ump_2_cell_is_nat_trans : is_nat_trans φ₁ φ₂ total_set_category_pb_ump_2_cell_data. Proof. intros x y f. use eq_mor_category_of_set_functor. - exact (nat_trans_ax δ₁ _ _ f). - cbn -[αinv]. refine (!_). rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G₁ _ _) _)). } etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. apply functor_comp. } rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₁ (pr1 (# φ₂ f)))). } refine (!_). apply (pr1_idtoiso_concat (_ @ eq_in_set_fiber (functor_comp G₁ _ _) _)). } etrans. { do 2 apply maponpaths_2. apply maponpaths. exact (from_eq_cat_of_setcategory (!(nat_trans_ax αinv _ _ (pr1 (# φ₂ f)))) (pr2 (δ₂ x))). } etrans. { apply maponpaths_2. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₁ (pr1 (# φ₂ f)))). } refine (!_). apply (pr1_idtoiso_concat _ (maponpaths (λ z, pr1 (# G₁ (pr1 (# φ₂ f))) z) _)). } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_idtoiso_concat (_ @ maponpaths (λ z, pr1 (# G₁ (pr1 (# φ₂ f))) z) _)). } pose (maponpaths (λ z, # (pr1 (αinv (pr1 (φ₂ y)))) z) (eq_mor_category_of_set_functor_pr2 (nat_trans_ax δ₂ _ _ f))) as p. cbn -[αinv] in p. assert (pr1 (# G₁ (pr1 (# φ₁ f) · δ₁ y)) (pr2 (φ₁ x)) = pr1 (αinv (pr1 (φ₂ y))) (pr1 (# G₂ (# F (pr1 (# φ₁ f)) · pr1 (δ₂ y))) (pr1 (pr1 α (pr1 (φ₁ x))) (pr2 (φ₁ x))))) as X1. { rewrite q. cbn -[αinv]. rewrite <- functor_comp. refine (!_). etrans. { apply (maponpaths (λ z, pr11 z (pr1 (pr1 α (pr1 (φ₁ x))) (pr2 (φ₁ x)))) (nat_trans_ax αinv _ _ (pr1 (# φ₁ f) · δ₁ y))). } cbn -[αinv]. apply maponpaths. apply α_inv_α_iso. } simple refine (_ @ maponpaths (λ z, idtoiso X1 · z · idtoiso (α_inv_α_iso _ _)) (!p) @ _). + refine (!_). etrans. { etrans. { apply maponpaths_2. apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ y)))). } apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. apply α_inv_α_iso_on_mor. } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ y)))). } refine (!_). apply pr1_idtoiso_concat. } apply maponpaths_2. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ y)))). } etrans. { apply maponpaths_2. do 3 refine (assoc _ _ _ @ _). do 2 apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } refine (!_). apply pr1_idtoiso_concat. } do 3 refine (assoc' _ _ _ @ _). do 2 apply maponpaths. etrans. { apply maponpaths. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } apply id_right. } do 2 refine (assoc _ _ _ @ _). apply maponpaths_2. apply setcategory_eq_idtoiso_comp. + apply maponpaths_2. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ y)))). } etrans. { apply maponpaths. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (pr1 (δ₂ y)))). } refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (αinv (pr1 (φ₂ y)))). } refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths. etrans. { apply maponpaths. exact (from_eq_cat_of_setcategory (maponpaths (λ z, #G₂ z) (q y)) (# (pr1 (α (pr1 (φ₁ y)))) (pr2 (# φ₁ f)))). } refine (functor_comp _ _ _ @ _). etrans. { apply maponpaths. refine (!_). apply pr1_maponpaths_idtoiso. } apply maponpaths_2. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_maponpaths_idtoiso. } etrans. { refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths_2. apply maponpaths. apply (from_eq_cat_of_setcategory (nat_trans_ax αinv _ _(δ₁ y)) (# (pr1 (α (pr1 (φ₁ y)))) (pr2 (# φ₁ f)))). } etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { refine (assoc' _ _ _ @ _). apply maponpaths. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths_2. apply maponpaths. cbn -[αinv]. etrans. { apply maponpaths. apply α_inv_α_iso_on_mor. } refine (functor_comp _ _ _ @ _). apply maponpaths_2. apply functor_comp. } etrans. { apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₁ (δ₁ y))). } refine (!_). apply pr1_idtoiso_concat. } etrans. { refine (assoc' _ _ _ @ _). apply maponpaths. etrans. { apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₁ (δ₁ y))). } refine (!_). apply pr1_idtoiso_concat. } apply setcategory_eq_idtoiso_comp. Qed. Definition total_set_category_pb_ump_2_cell : φ₁ ⟹ φ₂. Proof. use make_nat_trans. - exact total_set_category_pb_ump_2_cell_data. - exact total_set_category_pb_ump_2_cell_is_nat_trans. Defined. Definition total_set_category_pb_ump_2_pr1 : post_whisker total_set_category_pb_ump_2_cell (pr1_total_category_of_set_functor G₁) = δ₁. Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. apply idpath. Qed. Definition total_set_category_pb_ump_2_pr2 : post_whisker total_set_category_pb_ump_2_cell (functor_total_category_of_set_functor F α) = δ₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. use eq_mor_category_of_set_functor. - cbn. exact (!(q x)). - cbn -[αinv]. etrans. { apply maponpaths. refine (functor_comp _ _ _ @ _). apply maponpaths_2. refine (functor_comp _ _ _ @ _). apply maponpaths. apply α_iso_α_inv_on_mor. } rewrite !assoc'. etrans. { do 4 apply maponpaths. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (α (pr1 (φ₂ x)))). } refine (!_). apply pr1_idtoiso_concat. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (α (pr1 (φ₂ x)))). } refine (!_). apply (pr1_idtoiso_concat (functor_total_category_of_set_functor_eq F α (total_set_category_pb_ump_2_cell_data x))). } refine (!_). apply (pr1_idtoiso_concat (functor_total_category_of_set_functor_eq F α (total_set_category_pb_ump_2_cell_data x) @ _)). } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } refine (id_right _ @ _). apply maponpaths_2. apply setcategory_eq_idtoiso. Qed. End PbCell. End PullbackFromTotal. UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/IsosInTotal.v000066400000000000000000000103121451125700300272410ustar00rootroot00000000000000(******************************************************************************* Isos in the Grothendieck construction In this file we classify isomophisms in the total category of a functor from a strict category `C` to the category of strict categories. *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory. Local Open Scope cat. Section IsoInTotal. Context {C : setcategory} (F : C ⟶ cat_of_setcategory) {x y : total_setcategory_of_set_functor F} (f : x --> y) (H₁ : is_z_isomorphism (pr1 f)). Let fiso : z_iso (pr1 x) (pr1 y) := _ ,, H₁. Local Lemma inverse_path_1 : pr1 (# F (inv_from_z_iso fiso)) (pr1 (# F (pr1 f)) (pr2 x)) = pr2 x. Proof. etrans. { exact (maponpaths (λ z, pr11 z (pr2 x)) (!(functor_comp F (pr1 f) (inv_from_z_iso fiso)))). } etrans. { apply maponpaths_2. do 2 apply maponpaths. apply (z_iso_inv_after_z_iso fiso). } etrans. { exact (maponpaths (λ z, pr11 z (pr2 x)) (functor_id F _)). } apply idpath. Qed. Local Lemma inverse_path_2 : pr1 (# F (pr1 f)) (pr1 (# F (inv_from_z_iso fiso)) (pr2 y)) = pr2 y. Proof. etrans. { exact (maponpaths (λ z, pr11 z (pr2 y)) (!(functor_comp F (inv_from_z_iso fiso) (pr1 f)))). } etrans. { apply maponpaths_2. do 2 apply maponpaths. apply (z_iso_after_z_iso_inv fiso). } etrans. { exact (maponpaths (λ z, pr11 z (pr2 y)) (functor_id F _)). } apply idpath. Qed. Context (inv2 : pr1 (# F (inv_from_z_iso fiso)) (pr2 y) --> pr2 x) (H₂ : # (pr1 (# F (inv_from_z_iso fiso))) (pr2 f) · inv2 = idtoiso inverse_path_1) (H₃ : # (pr1 (# F (pr1 f))) inv2 · pr2 f = idtoiso inverse_path_2). Local Definition is_z_iso_total_setcategory_of_set_functor_inv : y --> x := inv_from_z_iso fiso ,, inv2. Local Definition is_z_iso_total_setcategory_of_set_functor_is_inverse : is_inverse_in_precat f is_z_iso_total_setcategory_of_set_functor_inv. Proof. split. - use eq_mor_category_of_set_functor. + apply (z_iso_inv_after_z_iso fiso). + cbn. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact H₂. } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp F _ _) _)). } refine (!_). etrans. { refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id F _) _)). } apply setcategory_eq_idtoiso. - use eq_mor_category_of_set_functor. + apply (z_iso_after_z_iso_inv fiso). + cbn. refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact H₃. } etrans. { refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp F _ _) _)). } refine (!_). etrans. { refine (!_). apply (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id F _) _)). } apply setcategory_eq_idtoiso. Qed. Definition is_z_iso_total_setcategory_of_set_functor : is_z_isomorphism f. Proof. use make_is_z_isomorphism. - exact is_z_iso_total_setcategory_of_set_functor_inv. - exact is_z_iso_total_setcategory_of_set_functor_is_inverse. Defined. End IsoInTotal. UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/Projection.v000066400000000000000000000405221451125700300271530ustar00rootroot00000000000000(******************************************************************************* The projection Given a strict functor `F : C ⟶ StrictCat`, then we have a projection going from `∫ F` to `C`. In addition, the Grothendieck construction is pseudofunctorial. Contents 1. The projection 2. Action on 1-cells 3. Action on 2-cells 4. Identitor 5. Compositor *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory. Local Open Scope cat. (** 1. The projection *) Definition pr1_total_category_of_set_functor_data {C : setcategory} (F : C ⟶ cat_of_setcategory) : functor_data (total_setcategory_of_set_functor F) C. Proof. use make_functor_data. - exact (λ x, pr1 x). - exact (λ _ _ f, pr1 f). Defined. Definition pr1_total_category_of_set_is_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : is_functor (pr1_total_category_of_set_functor_data F). Proof. split ; intro ; intros ; apply idpath. Qed. Definition pr1_total_category_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : total_setcategory_of_set_functor F ⟶ C. Proof. use make_functor. - exact (pr1_total_category_of_set_functor_data F). - exact (pr1_total_category_of_set_is_functor F). Defined. (** 2. Action on 1-cells *) Section FunctorTotalCategoryFromSetFunctor. Context {C₁ C₂ : setcategory} (F : C₁ ⟶ C₂) {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} (α : G₁ ⟹ F ∙ G₂). Definition functor_total_category_of_set_functor_eq {x y : total_precategory_of_set_functor G₁} (f : x --> y) : pr1 (# G₂ (# F (pr1 f))) (pr1 (pr1 α (pr1 x)) (pr2 x)) = pr1 (α (pr1 y)) (pr1 (# G₁ (pr1 f)) (pr2 x)). Proof. exact (!(eqtohomot (maponpaths (λ z, pr11 z) (nat_trans_ax α _ _ (pr1 f))) (pr2 x))). Qed. Definition functor_total_category_of_set_functor_data : functor_data (total_setcategory_of_set_functor G₁) (total_setcategory_of_set_functor G₂). Proof. use make_functor_data. - exact (λ x, F (pr1 x) ,, pr1 (pr1 α (pr1 x)) (pr2 x)). - refine (λ x y f, #F (pr1 f) ,, _). exact (idtoiso (functor_total_category_of_set_functor_eq f) · # (pr1 (α (pr1 y))) (pr2 f)). Defined. Definition is_functor_functor_total_category_of_set_functor : is_functor functor_total_category_of_set_functor_data. Proof. split. - intro x. use eq_mor_category_of_set_functor ; cbn. + apply functor_id. + etrans. { apply maponpaths. refine (!_). exact (pr1_maponpaths_idtoiso (α (pr1 x)) (eq_in_set_fiber (functor_id G₁ (pr1 x)) (pr2 x))). } etrans. { refine (!_). exact (pr1_idtoiso_concat _ (maponpaths (pr1 (α (pr1 x))) (eq_in_set_fiber (functor_id G₁ (pr1 x)) (pr2 x)))). } refine (!_). etrans. { refine (!_). exact (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id G₂ (F (pr1 x))) (pr1 (pr1 α (pr1 x)) (pr2 x)))). } apply setcategory_eq_idtoiso. - intros x y z f g. use eq_mor_category_of_set_functor ; cbn. + apply functor_comp. + cbn. refine (!_). rewrite !assoc. etrans. { do 3 apply maponpaths_2. refine (!_). exact (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G₂ (# F (pr1 f)) (# F (pr1 g))) (pr1 (pr1 α (pr1 x)) (pr2 x)))). } rewrite !assoc'. etrans. { apply maponpaths. apply maponpaths_2. etrans. { apply functor_comp. } apply maponpaths_2. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (# F (pr1 g))) (functor_total_category_of_set_functor_eq f)). } rewrite !assoc. etrans. { do 3 apply maponpaths_2. refine (!_). exact (pr1_idtoiso_concat (maponpaths (λ q, pr1 (# G₂ q) (pr1 (pr1 α (pr1 x)) (pr2 x))) (functor_comp F (pr1 f) (pr1 g)) @ eq_in_set_fiber (functor_comp G₂ (# F (pr1 f)) (# F (pr1 g))) (pr1 (pr1 α (pr1 x)) (pr2 x))) (maponpaths (pr1 (# G₂ (# F (pr1 g)))) (functor_total_category_of_set_functor_eq f))). } refine (!_). rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply functor_comp. } apply maponpaths. apply functor_comp. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. refine (!_). exact (pr1_maponpaths_idtoiso (α (pr1 z)) (eq_in_set_fiber (functor_comp G₁ (pr1 f) (pr1 g)) (pr2 x))). } refine (!_). exact (pr1_idtoiso_concat _ (maponpaths (pr1 (α (pr1 z))) (eq_in_set_fiber (functor_comp G₁ (pr1 f) (pr1 g)) (pr2 x)))). } etrans. { apply maponpaths. exact (from_eq_cat_of_setcategory (nat_trans_ax α _ _ (pr1 g)) (pr2 f)). } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } cbn. apply setcategory_eq_idtoiso_comp. Qed. Definition functor_total_category_of_set_functor : total_setcategory_of_set_functor G₁ ⟶ total_setcategory_of_set_functor G₂. Proof. use make_functor. - exact functor_total_category_of_set_functor_data. - exact is_functor_functor_total_category_of_set_functor. Defined. Definition functor_total_category_of_set_functor_comm : pr1_total_category_of_set_functor G₁ ∙ F ⟹ functor_total_category_of_set_functor ∙ pr1_total_category_of_set_functor G₂. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; exact (id_right _ @ !(id_left _))). Defined. Definition is_nat_z_iso_functor_total_category_of_set_functor_comm : is_nat_z_iso functor_total_category_of_set_functor_comm. Proof. intro ; cbn. apply identity_is_z_iso. Defined. End FunctorTotalCategoryFromSetFunctor. (** 3. Action on 2-cells *) Section NatTransTotalCategoryFromNatTrans. Context {C₁ C₂ : setcategory} {F₁ F₂ : C₁ ⟶ C₂} (α : F₁ ⟹ F₂) {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} (β₁ : G₁ ⟹ F₁ ∙ G₂) (β₂ : G₁ ⟹ F₂ ∙ G₂) (p : ∏ (x : C₁), pr1 β₁ x ∙ # (pr1 G₂) (pr1 α x) = pr1 β₂ x). Definition nat_trans_total_category_of_set_functor_eq (x : total_precategory_of_set_functor G₁) : pr1 (# G₂ (α (pr1 x))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x)) = pr1 (pr1 β₂ (pr1 x)) (pr2 x). Proof. exact (eqtohomot (maponpaths (λ z, pr11 z) (p (pr1 x))) (pr2 x)). Qed. Definition nat_trans_total_category_of_set_functor_data : nat_trans_data (functor_total_category_of_set_functor F₁ β₁) (functor_total_category_of_set_functor F₂ β₂). Proof. refine (λ x, α (pr1 x) ,, _). exact (idtoiso (nat_trans_total_category_of_set_functor_eq x)). Defined. Definition nat_trans_total_category_of_set_functor_is_nat_trans : is_nat_trans _ _ nat_trans_total_category_of_set_functor_data. Proof. intros x y f. use eq_mor_category_of_set_functor. - apply nat_trans_ax. - cbn. rewrite !assoc'. etrans. { apply maponpaths. apply maponpaths_2. apply functor_comp. } rewrite !assoc. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (α (pr1 y)))). } refine (!_). apply (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp G₂ (# F₁ (pr1 f)) (α (pr1 y))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))). } refine (!_). etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). exact (pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))). } etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (# G₂ (# F₂ (pr1 f)))). } refine (!_). apply (pr1_idtoiso_concat (_ @ eq_in_set_fiber (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))). } refine (!_). apply (pr1_idtoiso_concat ((_ @ eq_in_set_fiber (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x))) @ _)). } refine (!_). etrans. { apply maponpaths_2. apply maponpaths. exact (from_eq_cat_of_setcategory (p (pr1 y)) (pr2 f)). } rewrite !assoc'. etrans. { do 3 apply maponpaths. refine (!_). exact (pr1_idtoiso_concat _ (nat_trans_total_category_of_set_functor_eq y)). } rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply pr1_idtoiso_concat. } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } etrans. { apply id_right. } apply maponpaths_2. apply setcategory_eq_idtoiso. Qed. Definition nat_trans_total_category_of_set_functor : functor_total_category_of_set_functor F₁ β₁ ⟹ functor_total_category_of_set_functor F₂ β₂. Proof. use make_nat_trans. - exact nat_trans_total_category_of_set_functor_data. - exact nat_trans_total_category_of_set_functor_is_nat_trans. Defined. End NatTransTotalCategoryFromNatTrans. (** 4. Identitor *) Definition functor_total_category_of_set_functor_on_id_data {C : setcategory} (F : C ⟶ cat_of_setcategory) : nat_trans_data (functor_identity _) (functor_total_category_of_set_functor (functor_identity C) (nat_trans_id F)) := λ _, identity _. Definition functor_total_category_of_set_functor_on_id_is_nat_trans {C : setcategory} (F : C ⟶ cat_of_setcategory) : is_nat_trans _ _ (functor_total_category_of_set_functor_on_id_data F). Proof. intros x y f. refine (id_right _ @ _ @ !(id_left _)). use eq_mor_category_of_set_functor. - apply idpath. - cbn. rewrite id_left. refine (!_). etrans. { apply maponpaths_2. apply setcategory_refl_idtoiso. } apply id_left. Qed. Definition functor_total_category_of_set_functor_on_id {C : setcategory} (F : C ⟶ cat_of_setcategory) : functor_identity _ ⟹ functor_total_category_of_set_functor (functor_identity C) (nat_trans_id F). Proof. use make_nat_trans. - exact (functor_total_category_of_set_functor_on_id_data F). - exact (functor_total_category_of_set_functor_on_id_is_nat_trans F). Defined. Definition is_nat_z_iso_functor_total_category_of_set_functor_on_id {C : setcategory} (F : C ⟶ cat_of_setcategory) : is_nat_z_iso (functor_total_category_of_set_functor_on_id_data F). Proof. intro. apply identity_is_z_iso. Defined. (** 5. Compositor *) Definition functor_total_category_of_set_functor_on_comp_data {C₁ C₂ C₃ : setcategory} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} {G₃ : C₃ ⟶ cat_of_setcategory} (α : G₁ ⟹ F₁ ∙ G₂) (β : G₂ ⟹ F₂ ∙ G₃) : nat_trans_data (functor_total_category_of_set_functor F₁ α ∙ functor_total_category_of_set_functor F₂ β) (functor_total_category_of_set_functor (F₁ ∙ F₂) (nat_trans_comp _ _ _ α (pre_whisker F₁ β))) := λ _, identity _. Definition functor_total_category_of_set_functor_on_comp_is_nat_trans {C₁ C₂ C₃ : setcategory} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} {G₃ : C₃ ⟶ cat_of_setcategory} (α : G₁ ⟹ F₁ ∙ G₂) (β : G₂ ⟹ F₂ ∙ G₃) : is_nat_trans _ _ (functor_total_category_of_set_functor_on_comp_data α β). Proof. intros x y f. refine (id_right _ @ _ @ !(id_left _)). use eq_mor_category_of_set_functor ; cbn. - apply idpath. - cbn. refine (_ @ !(id_left _)). etrans. { apply maponpaths. apply functor_comp. } rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. refine (!_). apply (pr1_maponpaths_idtoiso (β (F₁ (pr1 y)))). } etrans. { refine (!_). exact (pr1_idtoiso_concat _ (maponpaths (pr1 (β (F₁ (pr1 y)))) (functor_total_category_of_set_functor_eq F₁ α f))). } apply setcategory_eq_idtoiso. Qed. Definition functor_total_category_of_set_functor_on_comp {C₁ C₂ C₃ : setcategory} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} {G₃ : C₃ ⟶ cat_of_setcategory} (α : G₁ ⟹ F₁ ∙ G₂) (β : G₂ ⟹ F₂ ∙ G₃) : functor_total_category_of_set_functor F₁ α ∙ functor_total_category_of_set_functor F₂ β ⟹ functor_total_category_of_set_functor (F₁ ∙ F₂) (nat_trans_comp _ _ _ α (pre_whisker F₁ β)). Proof. use make_nat_trans. - exact (functor_total_category_of_set_functor_on_comp_data α β). - exact (functor_total_category_of_set_functor_on_comp_is_nat_trans α β). Defined. Definition is_nat_z_iso_functor_total_category_of_set_functor_on_comp {C₁ C₂ C₃ : setcategory} {F₁ : C₁ ⟶ C₂} {F₂ : C₂ ⟶ C₃} {G₁ : C₁ ⟶ cat_of_setcategory} {G₂ : C₂ ⟶ cat_of_setcategory} {G₃ : C₃ ⟶ cat_of_setcategory} (α : G₁ ⟹ F₁ ∙ G₂) (β : G₂ ⟹ F₂ ∙ G₃) : is_nat_z_iso (functor_total_category_of_set_functor_on_comp α β). Proof. intro. apply identity_is_z_iso. Defined. UniMath-20231010/UniMath/CategoryTheory/GrothendieckConstruction/TotalCategory.v000066400000000000000000000176701451125700300276300ustar00rootroot00000000000000(******************************************************************************* The Grothendieck construction Suppose we have a strict functor `F : C ⟶ StrictCat` where `C` is a strict category. Then we can define a strict category `∫ F`, called the Grothendieck construction. In this file, we construct this category *******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Local Open Scope cat. Definition total_precategory_ob_mor_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : precategory_ob_mor. Proof. simple refine (_ ,, _). - exact (∑ (x : ob C), ob (pr1 (F x))). - exact (λ x y, ∑ (f : pr1 x --> pr1 y), pr1 (#F f) (pr2 x) --> pr2 y). Defined. Definition eq_in_set_fiber {C : setcategory} {F : C ⟶ cat_of_setcategory} {x₁ x₂ : C} {f g : F x₁ --> F x₂} (p : f = g) (y : pr1 (F x₁)) : pr11 f y = pr11 g y. Proof. exact (eqtohomot (maponpaths (λ z, pr11 z) p) y). Qed. Definition total_precategory_data_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : precategory_data. Proof. use make_precategory_data. - exact (total_precategory_ob_mor_of_set_functor F). - refine (λ x, identity _ ,, _). apply idtoiso. exact (eq_in_set_fiber (functor_id F (pr1 x)) (pr2 x)). - refine (λ x y z f g, pr1 f · pr1 g ,, _ · # (pr1 (# F (pr1 g))) (pr2 f) · pr2 g). apply idtoiso. exact (eq_in_set_fiber (functor_comp F (pr1 f) (pr1 g)) (pr2 x)). Defined. Definition eq_mor_category_of_set_functor {C : setcategory} {F : C ⟶ cat_of_setcategory} {x y : total_precategory_data_of_set_functor F} {f g : x --> y} (p : pr1 f = pr1 g) (q : pr2 f = idtoiso (maponpaths (λ z, pr1 (#F z) (pr2 x)) p) · pr2 g) : f = g. Proof. induction f as [ f₁ f₂ ]. induction g as [ g₁ g₂ ]. cbn in p, q. induction p. apply maponpaths. cbn in q. rewrite id_left in q. exact q. Qed. Definition eq_mor_category_of_set_functor_pr1 {C : setcategory} {F : C ⟶ cat_of_setcategory} {x y : total_precategory_data_of_set_functor F} {f g : x --> y} (p : f = g) : pr1 f = pr1 g. Proof. exact (base_paths _ _ p). Defined. Definition eq_mor_category_of_set_functor_pr2 {C : setcategory} {F : C ⟶ cat_of_setcategory} {x y : total_precategory_data_of_set_functor F} {f g : x --> y} (p : f = g) : pr2 f = idtoiso (maponpaths (λ z, pr1 (#F z) (pr2 x)) (eq_mor_category_of_set_functor_pr1 p)) · pr2 g. Proof. induction p. cbn. exact (!(id_left _)). Qed. Definition is_precategory_total_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : is_precategory (total_precategory_data_of_set_functor F). Proof. use make_is_precategory_one_assoc. - intros x y f ; cbn. use eq_mor_category_of_set_functor ; cbn. + apply id_left. + apply maponpaths_2. etrans. { apply maponpaths. refine (!_). exact (pr1_maponpaths_idtoiso (# F (pr1 f)) (eq_in_set_fiber (functor_id F (pr1 x)) (pr2 x))). } etrans. { refine (!_). exact (pr1_idtoiso_concat (eq_in_set_fiber (functor_comp F _ (pr1 f)) (pr2 x)) _). } apply setcategory_eq_idtoiso. - intros x y f ; cbn. use eq_mor_category_of_set_functor ; cbn. + apply id_right. + etrans. { apply maponpaths_2. apply maponpaths. exact (from_eq_cat_of_setcategory (functor_id F (pr1 y)) (pr2 f)). } cbn. rewrite !assoc. etrans. { do 3 apply maponpaths_2. exact (!(pr1_idtoiso_concat (eq_in_set_fiber (functor_comp F (pr1 f) _) (pr2 x)) _)). } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { exact (!(pr1_idtoiso_concat _ (eq_in_set_fiber (functor_id F (pr1 y)) (pr2 y)))). } apply setcategory_refl_idtoiso. } apply id_right. } apply maponpaths_2. apply setcategory_eq_idtoiso. - intros w x y z f g h ; cbn. use eq_mor_category_of_set_functor ; cbn. + apply assoc. + refine (assoc _ _ _ @ _ @ assoc' _ _ _). apply maponpaths_2. refine (!_). etrans. { do 2 apply maponpaths. apply functor_comp. } do 2 refine (assoc _ _ _ @ _). refine (_ @ assoc' _ _ _). apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply maponpaths. exact (from_eq_cat_of_setcategory (functor_comp F (pr1 g) (pr1 h)) (pr2 f)). } cbn. rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (!(pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp F (pr1 g) (pr1 h)) (pr2 x)))). } do 2 refine (assoc _ _ _ @ _). etrans. { do 2 apply maponpaths_2. exact (!(pr1_idtoiso_concat (eq_in_set_fiber (functor_comp F (pr1 f) (pr1 g · pr1 h)) (pr2 w)) _)). } refine (!_). refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. exact (!(pr1_idtoiso_concat _ (eq_in_set_fiber (functor_comp F (pr1 f · pr1 g) (pr1 h)) (pr2 w)))). } rewrite !assoc'. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } apply id_right. } refine (!_). etrans. { apply maponpaths. apply functor_comp. } refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { apply maponpaths. exact (!(pr1_maponpaths_idtoiso (# F (pr1 h)) (eq_in_set_fiber (functor_comp F (pr1 f) (pr1 g)) (pr2 w)))). } etrans. { refine (!_). exact (pr1_idtoiso_concat (maponpaths (λ q, pr1 (# F q) (pr2 w)) (assoc (pr1 f) (pr1 g) (pr1 h)) @ eq_in_set_fiber (functor_comp F (pr1 f · pr1 g) (pr1 h)) (pr2 w)) _). } apply setcategory_eq_idtoiso. Qed. Definition total_precategory_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : precategory. Proof. use make_precategory. - exact (total_precategory_data_of_set_functor F). - exact (is_precategory_total_of_set_functor F). Defined. Definition is_setcategory_total_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : is_setcategory (total_precategory_of_set_functor F). Proof. split. - apply isaset_total2. + apply C. + intro. apply (F x). - intros x y. apply isaset_total2. + apply homset_property. + intro. apply homset_property. Defined. Definition total_setcategory_of_set_functor {C : setcategory} (F : C ⟶ cat_of_setcategory) : setcategory. Proof. simple refine (_ ,, _). - exact (total_precategory_of_set_functor F). - exact (is_setcategory_total_of_set_functor F). Defined. UniMath-20231010/UniMath/CategoryTheory/GrothendieckTopos.v000066400000000000000000000163021451125700300234500ustar00rootroot00000000000000(** * Grothendick toposes *) (** ** Contents - Definition of Grothendieck topology - Grothendieck topologies - Precategory of sheaves - Grothendieck toposes *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Subobjects. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.limits.graphs.pullbacks. Require Import UniMath.CategoryTheory.limits.graphs.equalizers. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Equivalences.Core. (** * Definiton of Grothendieck topology The following definition is a formalization of the definition in Sheaves in Geometry and Logic, Saunders Mac Lane and Ieke Moerdijk, pages 109 and 110. Grothendieck topology is a collection J(c) of subobjects of the Yoneda functor, for every object of C, such that: - The Yoneda functor y(c) is in J(c). - Pullback of a subobject in J(c) along any morphism h : c' --> c is in J(c') - If S is a subobject of y(c) such that for all objects c' and all morphisms h : c' --> c in C the pullback of S along h is in J(c'), then S is in J(c). *) Section def_grothendiecktopology. Variable C : category. (** A sieve on c is a subobject of the yoneda functor. *) Definition sieve (c : C) : UU := Subobjectscategory (yoneda C c). (* Coq does not automatically convert the following types *) Definition FunctorPrecatObToFunctor (c : [C^op, HSET]) : functor (op_cat C) HSET := c. Definition FunctorPrecatMorToNatTrans {c c': functor_precategory (opp_precat C) HSET has_homsets_HSET} (h : c --> c') : nat_trans (FunctorPrecatObToFunctor c) (FunctorPrecatObToFunctor c') := h. Definition sieve_functor {c : C} (S : sieve c) : functor (opp_precat C) HSET := precategory_object_from_sub_precategory_object _ _ (slicecat_ob_object _ _ S). Definition sieve_nat_trans {c : C} (S : sieve c) : nat_trans (sieve_functor S) (FunctorPrecatObToFunctor (yoneda C c)) := precategory_morphism_from_sub_precategory_morphism _ _ _ _ (slicecat_ob_morphism _ _ S). (** ** Grothendieck topology *) Definition collection_of_sieves : UU := ∏ (c : C), hsubtype (sieve c). Definition isGrothendieckTopology_maximal_sieve (COS : collection_of_sieves) : UU := ∏ (c : C), COS c (Subobjectscategory_ob (identity (yoneda C c)) (identity_isMonic _)). Definition isGrothendieckTopology_stability (COS : collection_of_sieves) : UU := ∏ (c c' : C) (h : c' --> c) (s : sieve c), COS c s -> COS c' (PullbackSubobject (FunctorcategoryPullbacks C^op HSET HSET_Pullbacks) s (yoneda_morphisms C _ _ h)). Definition isGrothendieckTopology_transitivity (COS : collection_of_sieves) : UU := ∏ (c : C) (s : sieve c), (∏ (c' : C) (h : c' --> c), COS c' (PullbackSubobject (FunctorcategoryPullbacks C^op HSET HSET_Pullbacks) s (yoneda_morphisms C _ _ h)) -> COS c s). Definition isGrothendieckTopology (COS : collection_of_sieves) : UU := (isGrothendieckTopology_maximal_sieve COS) × (isGrothendieckTopology_stability COS) × (isGrothendieckTopology_transitivity COS). Definition GrothendieckTopology : UU := ∑ COS : collection_of_sieves, isGrothendieckTopology COS. (** Accessor functions *) Definition GrothendieckTopology_COS (GT : GrothendieckTopology) : collection_of_sieves := pr1 GT. Definition GrothendieckTopology_isGrothendieckTopology (GT : GrothendieckTopology) : isGrothendieckTopology (GrothendieckTopology_COS GT) := pr2 GT. (** ** Sheaves *) (** For some reason I need the following *) Definition Presheaf : UU := functor (opp_precat C) HSET. Definition PresheafToFunctor (P : Presheaf) : functor (opp_precat C) HSET := P. Definition make_Presheaf (F : functor (opp_precat C) HSET) : Presheaf := F. (** This is a formalization of the definition on page 122 *) Definition isSheaf (P : Presheaf) (GT : GrothendieckTopology) : UU := ∏ (c : C) (S : sieve c) (isCOS : GrothendieckTopology_COS GT c S) (τ : nat_trans (sieve_functor S) (PresheafToFunctor P)), iscontr (∑ η : nat_trans (FunctorPrecatObToFunctor (yoneda C c)) (PresheafToFunctor P), nat_trans_comp _ _ _ (sieve_nat_trans S) η = τ). Lemma isaprop_isSheaf (GT : GrothendieckTopology) (P : Presheaf) : isaprop(isSheaf P GT). Proof. apply impred_isaprop; intros t. apply impred_isaprop; intros S. apply impred_isaprop; intros isCOS. apply impred_isaprop; intros τ. apply isapropiscontr. Qed. (** The category of sheaves is the full subcategory of presheaves consisting of the presheaves which satisfy the isSheaf proposition. *) Definition hsubtype_obs_isSheaf (GT : GrothendieckTopology) : hsubtype (functor_category C^op HSET) := (λ P : functor_precategory (opp_precat C) HSET has_homsets_HSET, make_hProp _ (isaprop_isSheaf GT (make_Presheaf P))). Definition categoryOfSheaves (GT : GrothendieckTopology) : sub_precategories (functor_category C^op HSET) := full_sub_precategory (hsubtype_obs_isSheaf GT). End def_grothendiecktopology. (** * Definition of Grothendieck topos Grothendieck topos is a precategory which is equivalent to the category of sheaves on some Grothendieck topology. *) Section def_grothendiecktopos. Variable C : category. (** Here (pr1 D) is the precategory which is equivalent to the precategory of sheaves on the Grothendieck topology (pr2 D). *) Definition GrothendieckTopos : UU := ∑ D' : (∑ D : category × (GrothendieckTopology C), functor (pr1 D) (categoryOfSheaves C (pr2 D))), (adj_equivalence_of_cats (pr2 D')). (** Accessor functions *) Definition GrothendieckTopos_category (GT : GrothendieckTopos) : category := pr1 (pr1 (pr1 GT)). Coercion GrothendieckTopos_category : GrothendieckTopos >-> category. Definition GrothendieckTopos_GrothendieckTopology (GT : GrothendieckTopos) : GrothendieckTopology C := pr2 (pr1 (pr1 GT)). Definition GrothendieckTopos_functor (GT : GrothendieckTopos) : functor (GrothendieckTopos_category GT) (categoryOfSheaves C (GrothendieckTopos_GrothendieckTopology GT)) := pr2 (pr1 GT). Definition GrothendieckTopos_equivalence (GT : GrothendieckTopos) : adj_equivalence_of_cats (GrothendieckTopos_functor GT) := pr2 GT. End def_grothendiecktopos. UniMath-20231010/UniMath/CategoryTheory/Groupoids.v000066400000000000000000000225511451125700300217730ustar00rootroot00000000000000(** * Groupoids Author: Langston Barrett (@siddharthist), March 2018 *) (** ** Contents - Definitions - Pregroupoid - Groupoid - Univalent groupoid - An alternative characterization of univalence for groupoids - Lemmas - Subgroupoids - Discrete categories *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. (** ** Definitions *) (** A precategory is a pregroupoid when all of its arrows are [iso]s. *) Definition is_pregroupoid (C : category) := ∏ (x y : C) (f : x --> y), is_z_isomorphism f. Lemma isaprop_is_pregroupoid (C : category) : isaprop (is_pregroupoid C). Proof. do 3 (apply impred; intro). apply isaprop_is_z_isomorphism. Defined. Definition pregroupoid : UU := ∑ C : category, is_pregroupoid C. (** Constructors, accessors, and coersions *) Definition make_pregroupoid (C : category) (is : is_pregroupoid C) : pregroupoid := (C,, is). Definition pregroupoid_to_precategory : pregroupoid -> category := pr1. Definition pregroupoid_is_pregroupoid : ∏ gpd : pregroupoid, is_pregroupoid (pr1 gpd) := pr2. Coercion pregroupoid_to_precategory : pregroupoid >-> category. (** A category is a groupoid when all of its arrows are [iso]s. *) Definition groupoid : UU := ∑ C : category, is_pregroupoid C. (** Constructors, accessors, and coersions *) Definition make_groupoid (C : category) (is : is_pregroupoid C) : groupoid := (C,, is). Definition groupoid_to_category : groupoid -> category := pr1. Definition groupoid_is_pregroupoid : ∏ gpd : groupoid, is_pregroupoid (pr1 gpd) := pr2. Coercion groupoid_to_category : groupoid >-> category. Definition groupoid_to_pregroupoid : groupoid → pregroupoid := λ gpd, make_pregroupoid gpd (groupoid_is_pregroupoid gpd). Coercion groupoid_to_pregroupoid : groupoid >-> pregroupoid. Definition univalent_groupoid : UU := ∑ C : univalent_category, is_pregroupoid C. (** Constructors, accessors, and coersions *) Definition make_univalent_groupoid (C : univalent_category) (is : is_pregroupoid C) : univalent_groupoid := (C,, is). Definition univalent_groupoid_to_univalent_category : univalent_groupoid -> univalent_category := pr1. Coercion univalent_groupoid_to_univalent_category : univalent_groupoid >-> univalent_category. Definition univalent_groupoid_is_pregroupoid : ∏ ugpd : univalent_groupoid, is_pregroupoid (pr1 ugpd) := pr2. Definition univalent_groupoid_to_groupoid : univalent_groupoid -> groupoid := λ ugpd, make_groupoid ugpd (univalent_groupoid_is_pregroupoid ugpd). Coercion univalent_groupoid_to_groupoid : univalent_groupoid >-> groupoid. (** An alternative characterization of univalence for groupoids *) Definition is_univalent_pregroupoid (pgpd : pregroupoid) := (∏ a b : ob pgpd, isweq (fun path : a = b => idtomor a b path)) × has_homsets pgpd. (** The morphism part of an isomorphism is an inclusion. *) Lemma morphism_from_iso_is_incl (C : category) (a b : ob C) : isincl (@morphism_from_z_iso C a b). Proof. intro g. apply (isofhlevelweqf _ (ezweqpr1 _ _)). apply isaprop_is_z_isomorphism. Qed. (** The alternative characterization implies the normal one. Note that the other implication is missing, it should be completed if possible. *) Lemma is_univalent_pregroupoid_is_univalent {pgpd : groupoid} : is_univalent_pregroupoid pgpd -> is_univalent pgpd. Proof. intros ig. intros a b. use (isofhlevelff 0 idtoiso (morphism_from_z_iso _ _)). + use (isweqhomot (idtomor _ _)). * intro p; destruct p; reflexivity. * apply ig. + apply (morphism_from_iso_is_incl pgpd). Qed. (** ** Lemmas *) (** In a pregroupoid, the hom-types are equivalent to the type of isomorphisms. *) Lemma pregroupoid_hom_weq_iso {pgpd : pregroupoid} (a b : pgpd) : (a --> b) ≃ z_iso a b. Proof. use weq_iso. - intros f; refine (f,, _); apply pregroupoid_is_pregroupoid. - apply pr1. - reflexivity. - intro; apply z_iso_eq; reflexivity. Defined. Lemma pregroupoid_hom_weq_iso_idtoiso {pgpd : pregroupoid} (a : pgpd) : pregroupoid_hom_weq_iso a a (identity a) = idtoiso (idpath a). Proof. apply z_iso_eq; reflexivity. Defined. Lemma pregroupoid_hom_weq_iso_comp {pgpd : pregroupoid} {a b c : ob pgpd} (f : a --> b) (g : b --> c) : z_iso_comp (pregroupoid_hom_weq_iso _ _ f) (pregroupoid_hom_weq_iso _ _ g) = (pregroupoid_hom_weq_iso _ _ (f · g)). Proof. apply z_iso_eq; reflexivity. Defined. (** If D is a groupoid, then a functor category into it is as well. *) Lemma is_pregroupoid_functor_cat {C : precategory} {D : category} (gr_D : is_pregroupoid D) : is_pregroupoid (functor_category C D). Proof. intros F G α; apply nat_trafo_z_iso_if_pointwise_z_iso. intros c; apply gr_D. Defined. (** In a univalent groupoid, arrows are equivalent to paths *) Lemma univalent_groupoid_arrow_weq_path {ugpd : univalent_groupoid} {a b : ob ugpd} : (a --> b) ≃ a = b. Proof. intermediate_weq (z_iso a b). - apply (@pregroupoid_hom_weq_iso ugpd). - apply invweq; use make_weq. + exact idtoiso. + apply univalent_category_is_univalent. Defined. (** ** Subgroupoids *) (** Every category has a subgroupoid of all the objects and only the [iso]s. *) Definition maximal_subgroupoid {C : category} : pregroupoid. Proof. use make_pregroupoid. - use make_category. + use make_precategory; use tpair. * use tpair. -- exact (ob C). -- exact (λ a b, ∑ f : a --> b, is_z_isomorphism f). * unfold precategory_id_comp; cbn. use make_dirprod. -- exact (λ a, identity a,, identity_is_z_iso _). -- intros ? ? ? f g; exact (z_iso_comp f g). * use make_dirprod; intros; apply z_iso_eq. -- apply id_left. -- apply id_right. * use make_dirprod; intros; apply z_iso_eq. -- apply assoc. -- apply assoc'. + cbn. intros a b. cbn. apply isaset_z_iso. - intros ? ? f. exists (z_iso_inv_from_z_iso f). use make_dirprod; apply z_iso_eq. + apply z_iso_inv_after_z_iso. + apply z_iso_after_z_iso_inv. Defined. Goal ∏ C:category, pregroupoid_to_precategory (@maximal_subgroupoid (C^op)) = (@maximal_subgroupoid C)^op. Proof. Fail reflexivity. Abort. (* The first thing preventing the proof above is this: *) Goal ∏ (C:category) (a b:C) (f : C ⟦ b, a ⟧), @is_z_isomorphism C^op a b f = @is_z_isomorphism C b a f. Proof. Fail reflexivity. Abort. (** ** Discrete categories *) (** See [Categories.categories.StandardCategories] for a proof that any discrete category is equivalent to the path groupoid of its objects. *) (** A discrete category is a univalent [pregroupoid] with an underlying [setcategory]. Why? In this case, all arrows must be identities: every arrow has an inverse, and isos induce equality (by univalence). *) Definition is_discrete (C : category) := (is_setcategory C × is_pregroupoid C × is_univalent C). Definition discrete_category : UU := ∑ C : category, is_discrete C. Definition make_discrete_category : ∏ C : category, is_discrete C → discrete_category := tpair is_discrete. Definition discrete_category_to_univalent_groupoid : discrete_category -> univalent_groupoid := λ disc, make_univalent_groupoid (make_univalent_category (pr1 disc) (dirprod_pr2 (dirprod_pr2 (pr2 disc)))) (dirprod_pr1 (dirprod_pr2 (pr2 disc))). Coercion discrete_category_to_univalent_groupoid : discrete_category >-> univalent_groupoid. Definition discrete_category_is_discrete : ∏ C : discrete_category, is_discrete C := pr2. Definition discrete_category_is_setcategory : ∏ C : discrete_category, is_setcategory C := λ C, dirprod_pr1 (pr2 C). Lemma isaprop_is_discrete (C : category) : isaprop (is_discrete C). Proof. apply isapropdirprod; [|apply isapropdirprod]. - apply isaprop_is_setcategory. - apply isaprop_is_pregroupoid. - apply isaprop_is_univalent. Defined. (** In a discrete category, hom-types are propositions. *) Lemma discrete_category_hom_prop {disc : discrete_category} {a b : ob disc} : isaprop (a --> b). Proof. apply (@isofhlevelweqf _ (a = b)). - apply invweq, (@univalent_groupoid_arrow_weq_path disc). - apply (isaset_ob (_ ,, discrete_category_is_setcategory _)). Defined. (** A functor between discrete categories is given by a function on their objects. *) Lemma discrete_functor {C D : discrete_category} (f : ob C → ob D) : functor C D. Proof. use make_functor. - use make_functor_data. + apply f. + intros a b atob. pose (aeqb := @univalent_groupoid_arrow_weq_path C _ _ atob). exact (transportf (λ z, _ ⟦ f a, z ⟧) (maponpaths f aeqb) (identity _)). - split. + intro; apply discrete_category_hom_prop. + intros ? ? ? ? ?; apply discrete_category_hom_prop. Defined. Definition discrete_cat_nat_trans {C : precategory} {D : discrete_category} {F G : functor C D} (t : ∏ x : ob C, F x --> G x) : is_nat_trans F G t. Proof. intros ? ? ?; apply discrete_category_hom_prop. Defined. UniMath-20231010/UniMath/CategoryTheory/HomotopicalCategory.v000066400000000000000000000211471451125700300237740ustar00rootroot00000000000000(** * HomotopicalCategory *) (** ** Contents - Definitions: - two_of_six - two_of_three - homotopical_category - homotopical_functor - is_minimal (minimal homotopical category) - Properties: - two_of_six_is_prop - two_of_three_is_prop - is_homotopical_is_prop - is_homotopical_functor_is_prop - is_minimal_is_prop - Results: - [two_of_six_implies_two_of_three] - [cats_minimal_homotopical] (any category is a minimal homotopical category) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Open Scope cat. Definition morph_class (C : category) := ∏ (x y : C), hsubtype (x --> y). Definition category_with_weq := ∑ C : category, morph_class C. Definition category_with_weq_pr1 (C : category_with_weq) : category := pr1 C. Coercion category_with_weq_pr1 : category_with_weq >-> category. Definition two_of_six {C : category} (W : morph_class C) := ∏ (x y z t : C) (f : x --> y) (g : y --> z) (h : z --> t) (gf : W x z (f · g)) (hg : W y t (g · h)), (W x y f) × (W y z g) × (W z t h) × (W x t (f · g · h)). Proposition two_of_six_is_prop {C : category} (W : morph_class C) : isaprop (two_of_six W). Proof. unfold two_of_six. repeat (apply impred ; intro). apply isofhleveltotal2. apply (W _ _ _). intro. apply isofhleveltotal2. apply (W _ _ _). intro. apply isofhleveltotal2. apply (W _ _ _). intro. apply (W _ _ _). Defined. Definition is_homotopical (C : category_with_weq) : UU := two_of_six (pr2 C). Proposition is_homotopical_is_prop (C : category_with_weq) : isaprop (is_homotopical C). Proof. apply two_of_six_is_prop. Defined. Definition homotopical_category : UU := ∑ (C : category_with_weq), is_homotopical C. Definition homotopical_category_pr1 (C : homotopical_category) : category_with_weq := pr1 C. Coercion homotopical_category_pr1 : homotopical_category >-> category_with_weq. Definition category_with_weq_pr2 (C : category_with_weq) : morph_class (pr1 C) := pr2 C. Definition is_homotopical_functor {C C' : homotopical_category} (F : functor C C') : UU := ∏ (x y : C) (f : category_with_weq_pr2 C x y), category_with_weq_pr2 C' _ _ (# F (pr1 f)). Proposition is_homotopical_functor_is_prop {C C' : homotopical_category} (F : functor C C') : isaprop (is_homotopical_functor F). Proof. repeat (apply impred ; intro). apply (pr21 C'). Defined. Definition homotopical_functor (C C' : homotopical_category) : UU := ∑ f : functor C C', is_homotopical_functor f. Definition two_of_three {C : category} (W : morph_class C) := ∏ (x y z : C) (f : x --> y) (g : y --> z), (W _ _ f × W _ _ g -> W _ _ (f · g)) × (W _ _ f × W _ _ (f · g) -> W _ _ g) × (W _ _ g × W _ _ (f · g) -> W _ _ f). Proposition two_of_three_is_prop {C : category} (W : morph_class C) : isaprop (two_of_three W). Proof. unfold two_of_three. repeat (apply impred ; intro). apply isofhleveltotal2. - apply impred. intros. apply (W _ _ _). - intros. apply isofhleveltotal2. apply impred. intros. apply (W _ _ _). intros. apply impred. intros. apply (W _ _ _). Defined. Lemma two_of_six_implies_two_of_three {C : category} {W : morph_class C} (p : two_of_six W) : two_of_three W. Proof. unfold two_of_three. intros. split. - intros. rewrite <- (id_right f) in X. rewrite <- (id_left g) in X. pose (p _ _ _ _ _ _ _ (pr1 X) (pr2 X)). rewrite id_right in d. apply (pr222 d). - split. intros. destruct X as [ X1 X2 ]. rewrite <- (id_left f) in X1. pose (p _ _ _ _ _ _ _ X1 X2). apply (pr122 d). intros. destruct X as [ X1 X2 ]. rewrite <- (id_right g) in X1. pose (p _ _ _ _ _ _ _ X2 X1). apply (pr1 d). Defined. (* In the following we show categories are minimal homotopical categories. *) Lemma left_inv_monic_is_right_inv {C : category} {x y : C} (f : x -->y) (f_is_monic : isMonic f) (g : y --> x) (is_left_inv : g · f = identity _) : f · g = identity _. Proof. apply (maponpaths (fun k => f · k)) in is_left_inv. rewrite assoc in is_left_inv. rewrite id_right in is_left_inv. rewrite <- id_left in is_left_inv. apply f_is_monic in is_left_inv. apply is_left_inv. Defined. Lemma right_inv_epi_is_left_inv {C : category} {x y : C} (f : x --> y) (f_is_epic : isEpi f) (g : y --> x) (is_right_inv : f · g = identity _) : g · f = identity _. Proof. apply (maponpaths (fun k => k · f)) in is_right_inv. rewrite id_left in is_right_inv. rewrite <- id_right in is_right_inv. rewrite <- assoc in is_right_inv. apply f_is_epic in is_right_inv. apply is_right_inv. Defined. Lemma iso_two_of_three_right {C : precategory} {x y z : C} {f : x --> y} {g : y --> z} (gf_is_iso : is_iso (f · g)) (f_is_iso : is_iso f) : is_iso g. Proof. assert (g_right_inv : g · ((inv_from_iso (make_iso _ gf_is_iso)) · f) = identity _). pose (iso_inv_after_iso (make_iso _ gf_is_iso)). apply (maponpaths (fun k => (inv_from_iso (make_iso _ f_is_iso)) · k · f)) in p. simpl in p. rewrite assoc in p. rewrite assoc in p. rewrite iso_after_iso_inv in p. rewrite id_left in p. rewrite id_right in p. rewrite iso_after_iso_inv in p. rewrite <- assoc in p. apply p. assert (g_left_inv : ((inv_from_iso (make_iso _ gf_is_iso)) · f) · g = identity _). rewrite <- assoc. apply (iso_after_iso_inv (make_iso _ gf_is_iso)). eapply (is_iso_qinv _ _). exists g_right_inv. apply g_left_inv. Defined. Lemma z_iso_two_of_three_right {C : category} {x y z : C} {f : x --> y} {g : y --> z} (gf_is_iso : is_z_isomorphism (f · g)) (f_is_iso : is_z_isomorphism f) : is_z_isomorphism g. Proof. apply is_z_iso_from_is_iso. eapply iso_two_of_three_right. exact (is_iso_from_is_z_iso _ gf_is_iso). exact (is_iso_from_is_z_iso _ f_is_iso). Defined. Lemma iso_two_of_three_left {C : precategory} {x y z : C} {f : x --> y} {g : y --> z} (gf_is_iso : is_iso (f · g)) (g_is_iso : is_iso g) : is_iso f. Proof. assert (f_right_inv : f · (g · (inv_from_iso (make_iso _ gf_is_iso))) = identity _). rewrite assoc. apply (iso_inv_after_iso (make_iso _ gf_is_iso)). assert (f_left_inv : (g · (inv_from_iso (make_iso _ gf_is_iso))) · f = identity _). pose (iso_after_iso_inv (make_iso _ gf_is_iso)). apply (maponpaths (fun k => g · k · (inv_from_iso (make_iso _ g_is_iso)))) in p. simpl in p. rewrite <- assoc in p. rewrite <- assoc in p. rewrite <- assoc in p. rewrite id_right in p. pose (iso_inv_after_iso (make_iso _ g_is_iso)). simpl in p0. rewrite p0 in p. clear p0. rewrite id_right in p. rewrite assoc in p. apply p. eapply (is_iso_qinv _ _). exists f_right_inv. apply f_left_inv. Defined. Lemma z_iso_two_of_three_left {C : category} {x y z : C} {f : x --> y} {g : y --> z} (gf_is_iso : is_z_isomorphism (f · g)) (g_is_iso : is_z_isomorphism g) : is_z_isomorphism f. Proof. apply is_z_iso_from_is_iso. eapply iso_two_of_three_left. exact (is_iso_from_is_z_iso _ gf_is_iso). exact (is_iso_from_is_z_iso _ g_is_iso). Defined. Definition is_minimal (C : homotopical_category) : UU := ∏ (x y : C) (f : pr21 C x y), is_iso (pr1 f). Proposition is_minimal_is_prop (C : homotopical_category) : isaprop (is_minimal C). Proof. unfold is_minimal. apply impred ; intro. apply impred ; intro. apply impred ; intro. apply isaprop_is_iso. Defined. (* Any category is a minimal homotopical category taking the weak equivalences to be the isos *) Lemma cats_minimal_homotopical (C : category) : homotopical_category. Proof. unfold homotopical_category. pose (C_Weq := (C ,, (fun x y f => (is_z_isomorphism f ,, isaprop_is_z_isomorphism f))) : category_with_weq ). exists C_Weq. unfold is_homotopical. unfold two_of_six. intros. assert (g_is_iso : is_z_isomorphism g). { assert (g_is_monic : isMonic g). apply (isMonic_postcomp _ g h). simpl in hg. apply (is_iso_isMonic _ _ hg). assert (g_left_inv : ((is_z_isomorphism_mor gf) · f · g) = identity _). rewrite <- assoc. apply (z_iso_after_z_iso_inv (f · g ,, gf)). pose (g_right_inv := left_inv_monic_is_right_inv _ g_is_monic _ g_left_inv). eapply make_is_z_isomorphism. split. apply g_right_inv. apply g_left_inv. } pose (f_is_iso := z_iso_two_of_three_left gf g_is_iso). split. apply f_is_iso. split. apply g_is_iso. split. apply (z_iso_two_of_three_right hg g_is_iso). rewrite <- assoc. apply is_z_isomorphism_comp. apply f_is_iso. apply hg. Defined. UniMath-20231010/UniMath/CategoryTheory/HorizontalComposition.v000066400000000000000000000276311451125700300244010ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of horizontal composition for natural transformations ([horcomp]) Written by: Benedikt Ahrens, Ralph Matthes (2015) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors. Local Open Scope cat. Section horizontal_composition. Variables C D E : category. Variables F F' : functor C D. Variables G G' : functor D E. Variable α : F ⟹ F'. Variable β : G ⟹ G'. Definition horcomp_data : nat_trans_data (F ∙ G) (F' ∙ G') := λ c : C, β (F c) · #G' (α c). Lemma is_nat_trans_horcomp : is_nat_trans _ _ horcomp_data. Proof. intros c d f; unfold horcomp_data; simpl. rewrite assoc, nat_trans_ax, <- !assoc; apply maponpaths. now rewrite <- !functor_comp, nat_trans_ax. Qed. Definition horcomp : nat_trans (F ∙ G) (F' ∙ G') := tpair _ _ is_nat_trans_horcomp. End horizontal_composition. Arguments horcomp { _ _ _ } { _ _ _ _ } _ _ . Lemma horcomp_id_prewhisker {C D E : category} (X : functor C D) (Z Z' : functor D E) (f : nat_trans Z Z') : horcomp (nat_trans_id X) f = pre_whisker _ f. Proof. apply (nat_trans_eq E); intro x; simpl; unfold horcomp_data; simpl. now rewrite functor_id, id_right. Qed. Lemma horcomp_id_left (C D : category) (X : functor C C) (Z Z' : functor C D)(f : nat_trans Z Z') : ∏ c : C, horcomp (nat_trans_id X) f c = f (X c). Proof. intro c; simpl. unfold horcomp_data; simpl. now rewrite functor_id, id_right. Qed. Lemma horcomp_id_postwhisker (A B C : category) (X X' : [A, B]) (α : X --> X') (Z : [B, C]) : horcomp α (nat_trans_id _ ) = post_whisker α Z. Proof. apply nat_trans_eq_alt; intro a; apply id_left. Qed. Definition functorial_composition_legacy_data (A B C : category) : functor_data (precategory_binproduct_data [A, B] [B, C]) [A, C]. Proof. exists (λ FG, functor_composite (pr1 FG) (pr2 FG)). intros a b αβ. exact (horcomp (pr1 αβ) (pr2 αβ)). Defined. Lemma is_functor_functorial_composition_legacy_data (A B C : category) : is_functor (functorial_composition_legacy_data A B C). Proof. split. - red. intros FG. apply (nat_trans_eq C). intros x. apply remove_id_left. + apply idpath. + exact (functor_id (pr2 FG) ((pr1 (pr1 FG)) x)). - red. intros FG1 FG2 FG3 αβ1 αβ2. induction αβ1 as [α1 β1]. induction αβ2 as [α2 β2]. apply (nat_trans_eq C). intros a. simpl. unfold horcomp_data; simpl. rewrite <- ?assoc. apply cancel_precomposition. rewrite functor_comp. rewrite -> ?assoc. apply cancel_postcomposition. apply pathsinv0. apply nat_trans_ax. Qed. Definition functorial_composition_legacy (A B C : category) : functor (precategory_binproduct [A, B] [B, C]) [A, C]. Proof. exists (functorial_composition_legacy_data A B C). apply is_functor_functorial_composition_legacy_data. Defined. Definition functorial_composition_data (A B C : category) : functor_data (precategory_binproduct_data [A, B] [B, C]) [A, C]. Proof. exists (λ FG, functor_composite (pr1 FG) (pr2 FG)). intros F G αβ. exact (# (post_comp_functor (pr2 F)) (pr1 αβ) · # (pre_comp_functor (pr1 G)) (pr2 αβ)). Defined. Lemma is_functor_functorial_composition_data (A B C : category) : is_functor (functorial_composition_data A B C). Proof. split. - red. intros FG. unfold functorial_composition_data. unfold functor_on_morphisms. unfold pr2. change (# (post_comp_functor (pr2 FG)) (identity (pr1 FG)) · # (pre_comp_functor (pr1 FG)) (identity (pr2 FG)) = identity _). do 2 rewrite functor_id. apply id_left. - red. intros FG1 FG2 FG3 αβ1 αβ2. induction αβ1 as [α1 β1]. induction αβ2 as [α2 β2]. unfold functorial_composition_data. unfold functor_on_morphisms. unfold pr2. change (# (post_comp_functor (pr2 FG1)) (α1 · α2) · # (pre_comp_functor (pr1 FG3)) (β1 · β2) = # (post_comp_functor (pr2 FG1)) α1 · # (pre_comp_functor (pr1 FG2)) β1 · (# (post_comp_functor (pr2 FG2)) α2 · # (pre_comp_functor (pr1 FG3)) β2)). repeat rewrite functor_comp. repeat rewrite <- assoc. apply maponpaths. repeat rewrite assoc. apply cancel_postcomposition. (* we need the interchange between the two variants of presenting horcomp already here *) apply (nat_trans_eq C). intro a. cbn. apply nat_trans_ax. Qed. Definition functorial_composition (A B C : category) : functor (category_binproduct [A, B] [B, C]) [A, C]. Proof. exists (functorial_composition_data A B C). apply is_functor_functorial_composition_data. Defined. Goal ∏ (A B C : category) (F G : precategory_binproduct_data [A, B] [B, C]) (αβ : precategory_binproduct_data [A, B] [B, C] ⟦ F, G ⟧), # (functorial_composition _ _ _ ) αβ = # (post_comp_functor (pr2 F)) (pr1 αβ) · # (pre_comp_functor (pr1 G)) (pr2 αβ). Proof. intros. apply idpath. Qed. Lemma horcomp_pre_post (C D : category) (E : category) (F F' : functor C D) (G G' : functor D E) (f:nat_trans F F') (g:nat_trans G G') : horcomp f g = compose (C:=functor_category C E) (a:= (F ∙ G)) (b:= (F ∙ G')) (c:= (F' ∙ G')) (pre_whisker F g) (post_whisker f G'). Proof. intros. apply (nat_trans_eq (homset_property E)). intros; apply idpath. Qed. (* the other view as composition is not by definition but follows from naturality *) Lemma horcomp_post_pre (C D : category) (E : category) (F F' : functor C D) (G G' : functor D E) (f:nat_trans F F') (g:nat_trans G G') : horcomp f g = compose (C:=functor_category C E) (a:= (F ∙ G)) (b:= (F' ∙ G)) (c:= (F' ∙ G')) (post_whisker f G) (pre_whisker F' g). Proof. intros. apply (nat_trans_eq (homset_property E)). intro x. unfold horcomp, horcomp_data. cbn. apply pathsinv0. apply nat_trans_ax. Qed. (** now in the functor category *) Lemma functorial_composition_pre_post (C D E: category) (F F' : [C, D]) (G G' : [D, E]) (f: [C, D]⟦F, F'⟧) (g: [D, E]⟦G, G'⟧) : # (functorial_composition _ _ _) (f,, g:precategory_binproduct [C, D] [D, E] ⟦(F,,G), (F',,G')⟧) = # (pre_comp_functor F) g · # (post_comp_functor G') f. Proof. apply (nat_trans_eq E). intro c. cbn. apply nat_trans_ax. Qed. Lemma functorial_composition_post_pre (C D E : category) (F F' : [C, D]) (G G' : [D, E]) (f: [C, D]⟦F, F'⟧) (g: [D, E]⟦G, G'⟧) : # (functorial_composition _ _ _) (f,, g:precategory_binproduct [C, D] [D, E] ⟦(F,,G), (F',,G')⟧) = # (post_comp_functor G) f · # (pre_comp_functor F') g. Proof. apply idpath. Defined. (* this seems justified not to be ended with Qed *) Corollary functorial_composition_legacy_ok {A B C : category} : functorial_composition_legacy A B C = functorial_composition _ _ _. Proof. apply functor_eq. - apply homset_property. - cbn. use functor_data_eq. + intro FG. apply idpath. + intros FG1 FG2 αβ. cbn. apply (horcomp_post_pre _ _ C). Qed. (** ** currying functorial composition *) (** we define the two possible curried forms anew for better applicability *) Definition pre_composition_as_a_functor_data (A B C: category) : functor_data [A , B] [[B, C], [A, C]]. Proof. use make_functor_data. - apply pre_composition_functor. - intros H1 H2 η. use make_nat_trans. + intro G. cbn. exact (# (post_comp_functor G) η). + intros G G' β. etrans. apply pathsinv0, functorial_composition_pre_post. apply functorial_composition_post_pre. Defined. Lemma pre_composition_as_a_functor_data_is_fun (A B C : category) : is_functor (pre_composition_as_a_functor_data A B C). Proof. split. - intro H. apply (nat_trans_eq (homset_property _ )). intro G. cbn. apply post_whisker_identity; exact C. - intros H1 H2 H3 β β'. apply (nat_trans_eq (functor_category_has_homsets A C C)). intro G. cbn. apply post_whisker_composition; exact C. Qed. Definition pre_composition_as_a_functor (A B C : category) : functor [A , B] [[B, C], [A, C]] := _ ,, pre_composition_as_a_functor_data_is_fun A B C. Definition post_composition_as_a_functor_data (A B C : category) : functor_data [B, C] [[A, B], [A, C]]. Proof. use make_functor_data. - apply post_composition_functor. - intros H1 H2 η. use make_nat_trans. + intro G. cbn. exact (# (pre_comp_functor G) η). + intros G G' β. etrans. 2: { apply functorial_composition_pre_post. } apply pathsinv0, functorial_composition_post_pre. Defined. Definition post_composition_as_a_functor_data_is_fun (A B C : category) : is_functor (post_composition_as_a_functor_data A B C). Proof. split. - intro H. apply (nat_trans_eq (functor_category_has_homsets A C C)). intro G. cbn. apply pre_whisker_identity; exact C. - intros H1 H2 H3 β β'. apply (nat_trans_eq (functor_category_has_homsets A C C)). intro G. cbn. apply pre_whisker_composition; exact C. Qed. Definition post_composition_as_a_functor (A B C : category) : functor [B, C] [[A, B], [A, C]] := _ ,, post_composition_as_a_functor_data_is_fun A B C. (** [α_functors] itself is natural *) Section associativity. Context (C D E F: category). Definition assoc_left_gen : precategory_binproduct(precategory_binproduct [C, D] [D, E]) [E, F] ⟶ [C, F] := functor_composite (pair_functor (functorial_composition _ _ _ ) (functor_identity _)) (functorial_composition _ _ _ ). Definition assoc_right_gen : precategory_binproduct(precategory_binproduct [C, D] [D, E]) [E, F] ⟶ [C, F] := functor_composite (precategory_binproduct_unassoc _ _ _) (functor_composite (pair_functor (functor_identity _) (functorial_composition _ _ _ )) (functorial_composition _ _ _ )). Local Lemma is_nat_trans_a_functors: is_nat_trans assoc_left_gen assoc_right_gen (λ F : (C ⟶ D × D ⟶ E) × E ⟶ F, α_functors (pr1 (pr1 F)) (pr2 (pr1 F)) (pr2 F)). Proof. intros f f' m. (* unfold α_functors. etrans; [ use id_right |]. apply pathsinv0. etrans; [ use id_left |]. *) apply (nat_trans_eq F). intro c. cbn. rewrite id_right. rewrite id_left. etrans. { apply cancel_postcomposition. apply functor_comp. } rewrite assoc. apply idpath. Qed. Definition associativity_as_nat_z_iso: nat_z_iso assoc_left_gen assoc_right_gen. Proof. exists (_,, is_nat_trans_a_functors). intro f1f2f3. apply α_functors_pointwise_is_z_iso. Defined. End associativity. Section leftunit. Context (C D: category). Definition lunit_left_gen : [C, D] ⟶ [C, D] := pre_comp_functor (functor_identity C). Local Lemma is_nat_trans_l_functors: is_nat_trans lunit_left_gen (functor_identity [C, D]) (@λ_functors C D). Proof. intros F F' m. apply (nat_trans_eq (homset_property D)). intro c. cbn. rewrite id_left. apply id_right. Qed. Definition left_unit_as_nat_z_iso: nat_z_iso lunit_left_gen (functor_identity [C, D]). Proof. use make_nat_z_iso. + use make_nat_trans. * intro F. apply λ_functors. * apply is_nat_trans_l_functors. + intro F. cbn. use nat_trafo_z_iso_if_pointwise_z_iso. intro c. use tpair. * exact (identity (pr1 F c)). * abstract ( apply Isos.is_inverse_in_precat_identity ). Defined. End leftunit. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/000077500000000000000000000000001451125700300232125ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/CartesianToIndexedFunctor.v000066400000000000000000000133201451125700300304560ustar00rootroot00000000000000(************************************************************************ Every cartesian functor gives rise to an indexed functor In this file, we prove that every cartesian functor between two fibrations gives rise to an indexed functor between the corresponding indexed categories. The main idea behind this construction is that every displayed functor gives rise to a fiber functor between the fibers. The data for this construction is already given in the directory on displayed categories, and the only thing that is added here, is a proof of the laws of an indexed functor. Contents 1. The data 2. The laws 3. The indexed functor from a cartesian functor ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Local Open Scope cat. Section CartesianFunctorToIndexedFunctor. Context {C : category} {D₁ D₂ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) (F : cartesian_disp_functor (functor_identity C) D₁ D₂). (** 1. The data *) Definition cartesian_disp_functor_to_indexed_functor_data : indexed_functor_data (cleaving_to_indexed_cat D₁ HD₁) (cleaving_to_indexed_cat D₂ HD₂). Proof. use make_indexed_functor_data. - exact (fiber_functor F). - exact (λ x y f, fiber_functor_natural_nat_z_iso HD₁ HD₂ F f). Defined. (** 2. The laws *) Proposition cartesian_disp_functor_to_indexed_functor_laws : indexed_functor_laws cartesian_disp_functor_to_indexed_functor_data. Proof. split. - intros x xx ; cbn. use (cartesian_factorisation_unique (cartesian_disp_functor_on_cartesian F (HD₁ _ _ _ _))). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite transport_f_f. refine (!_). etrans. { refine (!_). apply (disp_functor_comp_var F). } rewrite cartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite transport_f_f. rewrite disp_functor_id. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros x y z f g xx ; cbn. rewrite mor_disp_transportf_postwhisker. use (cartesian_factorisation_unique (cartesian_disp_functor_on_cartesian F (HD₁ _ _ _ _))). rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 3 apply maponpaths. refine (!_). apply (disp_functor_comp_var F). } rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite disp_functor_transportf. rewrite !mor_disp_transportf_prewhisker. rewrite !transport_f_f. rewrite disp_functor_comp. unfold transportb. rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 2 apply maponpaths. rewrite assoc_disp. apply idpath. } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. (** 3. The indexed functor from a cartesian functor *) Definition cartesian_disp_functor_to_indexed_functor : indexed_functor (cleaving_to_indexed_cat D₁ HD₁) (cleaving_to_indexed_cat D₂ HD₂). Proof. use make_indexed_functor. - exact cartesian_disp_functor_to_indexed_functor_data. - exact cartesian_disp_functor_to_indexed_functor_laws. Defined. End CartesianFunctorToIndexedFunctor. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/CoreIndexedCategory.v000066400000000000000000000062551451125700300273000ustar00rootroot00000000000000(********************************************************************* The fiberwise core of an indexed category In this file, we define the fiberwise core of an indexed category. More specifically, if we have a category `Φ` indexed over `C`, then the fiberwise core of `Φ` is defined to be the core of `Φ x` on every object `x`. Contents 1. The data 2. The laws 3. The fiberwise core *********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Local Open Scope cat. Section FiberwiseCore. Context {C : category} (Φ : indexed_cat C). (** 1. The data *) Definition core_indexed_cat_data : indexed_cat_data C. Proof. use make_indexed_cat_data. - exact (λ x, univalent_core (Φ x)). - exact (λ x y f, core_functor (Φ $ f)). - intros x. use make_nat_trans. + exact (λ xx, indexed_cat_id_z_iso Φ xx). + intros xx yy ff ; cbn. use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ]. cbn. apply (nat_trans_ax (indexed_cat_id Φ x)). - intros x y z f g. use make_nat_trans. + exact (λ xx, indexed_cat_comp_z_iso Φ f g xx). + intros xx yy ff ; cbn. use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ]. cbn. apply (nat_trans_ax (indexed_cat_comp Φ f g)). Defined. Definition core_indexed_cat_isos : indexed_cat_isos core_indexed_cat_data. Proof. split ; intros ; apply is_pregroupoid_core. Defined. (** 2. The laws *) Proposition core_indexed_cat_laws : indexed_cat_laws core_indexed_cat_data. Proof. repeat split. - intros x y f xx ; cbn in *. use subtypePath. { intro. apply isaprop_is_z_isomorphism. } cbn. refine (indexed_cat_lunitor Φ f xx @ _). apply maponpaths. refine (_ @ !(@idtoiso_core (Φ y) _ _ _)). apply idpath. - intros x y f xx ; cbn in *. use subtypePath. { intro. apply isaprop_is_z_isomorphism. } cbn. refine (indexed_cat_runitor Φ f xx @ _). apply maponpaths. refine (_ @ !(@idtoiso_core (Φ y) _ _ _)). apply idpath. - intros w x y z f g h ww ; cbn in *. use subtypePath. { intro. apply isaprop_is_z_isomorphism. } cbn. refine (_ @ indexed_cat_lassociator Φ f g h ww). apply maponpaths. refine (@idtoiso_core (Φ z) _ _ _ @ _). apply idpath. Qed. (** 3. The fiberwise core *) Definition core_indexed_cat : indexed_cat C. Proof. use make_indexed_cat. - exact core_indexed_cat_data. - exact core_indexed_cat_isos. - exact core_indexed_cat_laws. Defined. End FiberwiseCore. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/FibrationToIndexedCategory.v000066400000000000000000000156531451125700300306320ustar00rootroot00000000000000(************************************************************************ Every fibration gives rise to an indexed category In this file, we prove that every fibration gives rise to an indexed category. This construction makes use of the fiber of a displayed category. The pseudofunctoriality of the fiber follows from the fact that we have a cleaving. Note that all relevant constructions for this file are already given in the directory on displayed categories, and here, they are only collected. Compared to that directory, the only new thing is that we prove the laws of indexed categories. Contents 1. The data 2. The laws 3. The identitor and compositor are natural isos 4. The indexed category from a fibration ************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Section FibrationToIndexedCat. Context {C : category} (D : disp_univalent_category C) (HD : cleaving D). (** 1. The data *) Definition cleaving_to_indexed_cat_data : indexed_cat_data (C^opp). Proof. use make_indexed_cat_data. - exact (λ x, univalent_fiber_category D x). - exact (λ x y f, fiber_functor_from_cleaving D HD f). - exact (λ x, fiber_functor_from_cleaving_identity HD x). - exact (λ x y z f g, fiber_functor_from_cleaving_comp HD f g). Defined. (** 2. The laws *) Proposition cleaving_to_indexed_cat_laws : indexed_cat_laws cleaving_to_indexed_cat_data. Proof. repeat split. - intros x y f xx ; cbn. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite id_left_disp. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. apply idtoiso_fiber_category. } apply idtoiso_disp_cartesian_lift. } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros x y f xx ; cbn. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite !mor_disp_transportf_postwhisker. rewrite !transport_f_f. rewrite id_left_disp. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. etrans. { apply maponpaths_2. apply idtoiso_fiber_category. } apply idtoiso_disp_cartesian_lift. } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. - intros w x y z f g h ww ; cbn. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. use (cartesian_factorisation_unique (HD _ _ _ _)). rewrite assoc_disp_var. rewrite !mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. etrans. { do 3 apply maponpaths. etrans. { apply maponpaths_2. apply idtoiso_fiber_category. } apply idtoiso_disp_cartesian_lift. } rewrite !mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. refine (!_). rewrite assoc_disp_var. rewrite transport_f_f. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite !transport_f_f. apply maponpaths_2. apply homset_property. Qed. (** 3. The identitor and compositor are natural isos *) Definition cleaving_to_indexed_cat_isos : indexed_cat_isos cleaving_to_indexed_cat_data. Proof. split. - intros x xx ; cbn. apply is_nat_z_iso_fiber_functor_from_cleaving_identity. - intros x y z f g xx ; cbn. apply is_nat_z_iso_fiber_functor_from_cleaving_comp. Defined. (** 4. The indexed category from a fibration *) Definition cleaving_to_indexed_cat : indexed_cat (C^opp). Proof. use make_indexed_cat. - exact cleaving_to_indexed_cat_data. - exact cleaving_to_indexed_cat_isos. - exact cleaving_to_indexed_cat_laws. Defined. End FibrationToIndexedCat. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedCategory.v000066400000000000000000000230071451125700300264610ustar00rootroot00000000000000(************************************************************************* Indexed categories A category indexed on `C` is the same as a pseudofunctor from `C^op` to the bicategory of categories. However, one can also formulate this definition without referring to bicategories and pseudofunctors, and that is what we define in this file. Compared to the definition of a pseudofunctor into `Cat`, the definition in this file has the following simplifications: - Some of the laws hold by default. This is because `C^op` is a discrete bicategory and the laws that quantify over all 2-cells (preservation of vertical and horizontal composition) then can be proven using path induction. - The laws are formulated as pointwise equalities of natural transformations rather than equality of natural transformations. It is worthwhile to note that `indexed_cat C` represents a pseudofunctor from `C` to the bicategory of univalent categories and not a pseudofunctor from `C^op`. Contents 1. The data of an indexed category 2. The laws of indexed categories 3. Indexed categories 3.1. Derived laws 3.2. Isomorphisms for the identity and composition *************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. (** 1. The data of an indexed category *) Definition indexed_cat_data (C : category) : UU := ∑ (F₀ : C → univalent_category) (F₁ : ∏ (x y : C), x --> y → F₀ x ⟶ F₀ y), (∏ (x : C), functor_identity _ ⟹ F₁ x x (identity x)) × (∏ (x y z : C) (f : x --> y) (g : y --> z), F₁ x y f ∙ F₁ y z g ⟹ F₁ x z (f · g)). Definition make_indexed_cat_data {C : category} (F₀ : C → univalent_category) (F₁ : ∏ (x y : C), x --> y → F₀ x ⟶ F₀ y) (Fid : ∏ (x : C), functor_identity _ ⟹ F₁ x x (identity x)) (Fcomp : ∏ (x y z : C) (f : x --> y) (g : y --> z), F₁ x y f ∙ F₁ y z g ⟹ F₁ x z (f · g)) : indexed_cat_data C := F₀ ,, F₁ ,, Fid ,, Fcomp. Definition indexed_cat_on_ob {C : category} (F : indexed_cat_data C) (x : C) : univalent_category := pr1 F x. Coercion indexed_cat_on_ob : indexed_cat_data >-> Funclass. Definition indexed_cat_on_mor {C : category} (F : indexed_cat_data C) {x y : C} (f : x --> y) : F x ⟶ F y := pr12 F x y f. Notation "F $ f" := (indexed_cat_on_mor F f) (at level 60). Definition indexed_cat_id {C : category} (F : indexed_cat_data C) (x : C) : functor_identity _ ⟹ (F $ identity x) := pr122 F x. Definition indexed_cat_comp {C : category} (F : indexed_cat_data C) {x y z : C} (f : x --> y) (g : y --> z) : (F $ f) ∙ (F $ g) ⟹ (F $ (f · g)) := pr222 F x y z f g. Definition indexed_cat_isos {C : category} (F : indexed_cat_data C) : UU := (∏ (x : C) (xx : F x), is_z_isomorphism (indexed_cat_id F x xx)) × (∏ (x y z : C) (f : x --> y) (g : y --> z) (xx : F x), is_z_isomorphism (indexed_cat_comp F f g xx)). (** 2. The laws of indexed categories *) Definition indexed_cat_laws {C : category} (F : indexed_cat_data C) : UU := (∏ (x y : C) (f : x --> y) (xx : F x), identity ((F $ f) xx) = # (F $ f) (indexed_cat_id F x xx) · indexed_cat_comp F (identity x) f xx · idtoiso (maponpaths (λ g, (F $ g) xx) (id_left f))) × (∏ (x y : C) (f : x --> y) (xx : F x), identity ((F $ f) xx) = indexed_cat_id F y ((F $ f) xx) · indexed_cat_comp F f (identity y) xx · idtoiso (maponpaths (λ g, (F $ g) xx) (id_right f))) × (∏ (w x y z : C) (f : w --> x) (g : x --> y) (h : y --> z) (ww : F w), indexed_cat_comp F g h ((F $ f) ww) · indexed_cat_comp F f (g · h) ww · idtoiso (maponpaths (λ k, (F $ k) ww) (assoc f g h)) = # (F $ h) (indexed_cat_comp F f g ww) · indexed_cat_comp F (f · g) h ww). (** 3. Indexed categories *) Definition indexed_cat (C : category) : UU := ∑ (F : indexed_cat_data C), indexed_cat_isos F × indexed_cat_laws F. Definition make_indexed_cat {C : category} (F : indexed_cat_data C) (HF₁ : indexed_cat_isos F) (HF₂ : indexed_cat_laws F) : indexed_cat C := F ,, HF₁ ,, HF₂. Coercion indexed_cat_to_data {C : category} (F : indexed_cat C) : indexed_cat_data C := pr1 F. Section IndexedCatLaws. Context {C : category} (Φ : indexed_cat C). Definition is_z_isomorphism_indexed_cat_id {x : C} (xx : Φ x) : is_z_isomorphism (indexed_cat_id Φ x xx). Proof. exact (pr112 Φ x xx). Defined. Definition is_z_isomorphism_indexed_cat_comp {x y z : C} (f : x --> y) (g : y --> z) (xx : Φ x) : is_z_isomorphism (indexed_cat_comp Φ f g xx). Proof. exact (pr212 Φ x y z f g xx). Defined. Proposition indexed_cat_lunitor {x y : C} (f : x --> y) (xx : Φ x) : identity ((Φ $ f) xx) = # (Φ $ f) (indexed_cat_id Φ x xx) · indexed_cat_comp Φ (identity x) f xx · idtoiso (maponpaths (λ g, (Φ $ g) xx) (id_left f)). Proof. exact (pr122 Φ x y f xx). Qed. Proposition indexed_cat_runitor {x y : C} (f : x --> y) (xx : Φ x) : identity ((Φ $ f) xx) = indexed_cat_id Φ y ((Φ $ f) xx) · indexed_cat_comp Φ f (identity y) xx · idtoiso (maponpaths (λ g, (Φ $ g) xx) (id_right f)). Proof. exact (pr1 (pr222 Φ) x y f xx). Qed. Proposition indexed_cat_lassociator {w x y z : C} (f : w --> x) (g : x --> y) (h : y --> z) (ww : Φ w) : indexed_cat_comp Φ g h ((Φ $ f) ww) · indexed_cat_comp Φ f (g · h) ww · idtoiso (maponpaths (λ k, (Φ $ k) ww) (assoc f g h)) = # (Φ $ h) (indexed_cat_comp Φ f g ww) · indexed_cat_comp Φ (f · g) h ww. Proof. exact (pr2 (pr222 Φ) w x y z f g h ww). Qed. (** 3.1. Derived laws *) Proposition indexed_cat_lunitor_alt {x y : C} (f : x --> y) (xx : Φ x) : # (Φ $ f) (indexed_cat_id Φ x xx) · indexed_cat_comp Φ (identity x) f xx = idtoiso (maponpaths (λ g, (Φ $ g) xx) (!(id_left f))). Proof. refine (_ @ id_left _). cbn. rewrite (indexed_cat_lunitor f xx). refine (!(id_right _) @ _). rewrite !assoc'. do 2 apply maponpaths. refine (_ @ pr1_idtoiso_concat _ _). change (identity ((Φ $ identity x · f) xx)) with (pr1 (idtoiso (idpath ((Φ $ identity x · f) xx)))). do 2 apply maponpaths. refine (_ @ maponpathscomp0 (λ g, (Φ $ g) xx) _ _). rewrite pathsinv0r. apply idpath. Qed. Proposition indexed_cat_runitor_alt {x y : C} (f : x --> y) (xx : Φ x) : indexed_cat_id Φ y ((Φ $ f) xx) · indexed_cat_comp Φ f (identity y) xx = idtoiso (maponpaths (λ g, (Φ $ g) xx) (!(id_right f))). Proof. refine (_ @ id_left _). cbn. rewrite (indexed_cat_runitor f xx). refine (!(id_right _) @ _). rewrite !assoc'. do 2 apply maponpaths. refine (_ @ pr1_idtoiso_concat _ _). change (identity ((Φ $ f · identity y) xx)) with (pr1 (idtoiso (idpath ((Φ $ f · identity y) xx)))). do 2 apply maponpaths. refine (_ @ maponpathscomp0 (λ g, (Φ $ g) xx) _ _). rewrite pathsinv0r. apply idpath. Qed. End IndexedCatLaws. (** 3.2. Isomorphisms for the identity and composition *) Definition indexed_cat_id_z_iso {C : category} (Φ : indexed_cat C) {x : C} (xx : Φ x) : z_iso xx ((Φ $ identity x) xx). Proof. refine (indexed_cat_id Φ x xx ,, _). apply is_z_isomorphism_indexed_cat_id. Defined. Definition indexed_cat_id_nat_z_iso {C : category} (Φ : indexed_cat C) (x : C) : nat_z_iso (functor_identity (Φ x)) (Φ $ identity x). Proof. refine (indexed_cat_id Φ x ,, _). intro. apply is_z_isomorphism_indexed_cat_id. Defined. Definition indexed_cat_comp_z_iso {C : category} (Φ : indexed_cat C) {x y z : C} (f : x --> y) (g : y --> z) (xx : Φ x) : z_iso ((Φ $ g) ((Φ $ f) xx)) ((Φ $ (f · g)) xx). Proof. refine (indexed_cat_comp Φ f g xx ,, _). apply is_z_isomorphism_indexed_cat_comp. Defined. Definition indexed_cat_comp_nat_z_iso {C : category} (F : indexed_cat C) {x y z : C} (f : x --> y) (g : y --> z) : nat_z_iso ((F $ f) ∙ (F $ g)) (F $ (f · g)). Proof. use make_nat_z_iso. - exact (indexed_cat_comp F f g). - intro. apply is_z_isomorphism_indexed_cat_comp. Defined. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedCategoryToFibration.v000066400000000000000000000476461451125700300306410ustar00rootroot00000000000000(************************************************************************* Indexed categories give rise to fibrations In this file, we show that every indexed category over `C` gives rise to a fibration over `C`. To prove that, we take the following steps. First, we show that every indexed category gives rise to a displayed category over `C`. This is also known as the Grothendieck construction (see https://ncatlab.org/nlab/show/Grothendieck+construction#Definition). The only difference arises from the fact that we used displayed categories: whereas one usually would define objects and morphisms to be pairs, the displayed objects and morphisms are not. The total category of the displayed category that we define, corresponds to the usual definition of the Grothendieck construction. After that, we prove some properties of this displayed categories. We first classify the isomorphisms, and with that, we prove that this displayed category is univalent. We also characterize cartesian morphisms as certain isomorphisms, and using that, we construct a cleaving for the displayed category. Contents 1. The displayed category arising from an indexed category 2. Isomorphisms in the displayed category from an indexed category 3. The univalence of that displayed category 4. Cartesian morphisms are the same as certain isomorphisms 5. The cleaving from an indexed category *************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Local Open Scope cat. Section IndexedCatToFibration. Context {C : category} (Φ : indexed_cat (C^opp)). (** 1. The displayed category arising from an indexed category *) Definition indexed_cat_to_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. simple refine (_ ,, _). - exact (λ x, Φ x). - exact (λ x y xx yy f, xx --> (Φ $ f) yy). Defined. Definition indexed_cat_to_disp_cat_id_comp : disp_cat_id_comp C indexed_cat_to_disp_cat_ob_mor. Proof. split. - exact (λ x xx, indexed_cat_id Φ x xx). - exact (λ x y z f g xx yy zz ff gg, ff · #(Φ $ f) gg · indexed_cat_comp Φ g f zz). Defined. Definition indexed_cat_to_disp_cat_data : disp_cat_data C. Proof. simple refine (_ ,, _). - exact indexed_cat_to_disp_cat_ob_mor. - exact indexed_cat_to_disp_cat_id_comp. Defined. Proposition transportf_indexed_cat_to_disp_cat {x y : C} {xx : indexed_cat_to_disp_cat_data x} {yy : indexed_cat_to_disp_cat_data y} {f g : x --> y} (p : f = g) (ff : xx --> (Φ $ f) yy) : transportf (λ z, xx -->[ z ] yy) p ff = ff · idtoiso (maponpaths (λ h, (Φ $ h) yy) p). Proof. induction p ; cbn. rewrite id_right. apply idpath. Qed. Proposition indexed_cat_to_disp_cat_axioms : disp_cat_axioms C indexed_cat_to_disp_cat_data. Proof. repeat split. - intros x y f xx yy ff ; cbn in *. etrans. { apply maponpaths_2. exact (!(nat_trans_ax (indexed_cat_id Φ x) _ _ ff)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply (indexed_cat_runitor_alt Φ). } unfold transportb. rewrite transportf_indexed_cat_to_disp_cat. apply idpath. - intros x y f xx yy ff ; cbn in *. rewrite !assoc'. etrans. { apply maponpaths. apply (indexed_cat_lunitor_alt Φ). } unfold transportb. rewrite transportf_indexed_cat_to_disp_cat. apply idpath. - intros w x y z f g h ww xx yy zz ff gg hh ; cbn in *. rewrite !functor_comp. rewrite !assoc'. etrans. { do 3 apply maponpaths. refine (!_). apply (indexed_cat_lassociator Φ h g f zz). } unfold transportb. rewrite transportf_indexed_cat_to_disp_cat. rewrite !assoc'. cbn. do 2 apply maponpaths. etrans. { do 2 refine (assoc _ _ _ @ _). etrans. { do 2 apply maponpaths_2. apply (nat_trans_ax (indexed_cat_comp Φ g f)). } do 2 refine (assoc' _ _ _ @ _). apply idpath. } do 6 apply maponpaths. apply homset_property. - intros x y f xx yy ; cbn in *. apply homset_property. Qed. Definition indexed_cat_to_disp_cat : disp_cat C. Proof. simple refine (_ ,, _). - exact indexed_cat_to_disp_cat_data. - exact indexed_cat_to_disp_cat_axioms. Defined. (** 2. Isomorphisms in the displayed category from an indexed category *) Definition indexed_cat_to_disp_cat_z_iso_weq_base {x : C} (xx₁ xx₂ : Φ x) : (xx₁ --> xx₂) ≃ (xx₁ --> (Φ $ identity x) xx₂). Proof. use weq_iso. - exact (λ f, f · indexed_cat_id Φ x xx₂). - exact (λ f, f · inv_from_z_iso (indexed_cat_id_z_iso Φ xx₂)). - abstract (intro f ; cbn ; rewrite !assoc' ; refine (_ @ id_right _) ; apply maponpaths ; exact (z_iso_inv_after_z_iso (indexed_cat_id_z_iso Φ xx₂))). - abstract (intro f ; cbn ; rewrite !assoc' ; refine (_ @ id_right _) ; apply maponpaths ; exact (z_iso_after_z_iso_inv (indexed_cat_id_z_iso Φ xx₂))). Defined. Section IsoWeqDispIso. Context {x : C} (xx₁ xx₂ : Φ x) (f : xx₁ --> xx₂). Section IsoToDispIso. Context (Hf : is_z_isomorphism f). Let f_iso := (f ,, Hf) : z_iso xx₁ xx₂. Definition indexed_cat_to_disp_cat_to_disp_iso_inv : xx₂ --> (Φ $ identity x) xx₁ := inv_from_z_iso f_iso · indexed_cat_id Φ x xx₁. Proposition indexed_cat_to_disp_cat_to_disp_iso_inv_right : indexed_cat_to_disp_cat_to_disp_iso_inv · # (Φ $ identity x) (f · indexed_cat_id Φ x xx₂) · indexed_cat_comp Φ (identity x) (identity x) xx₂ = indexed_cat_id Φ x xx₂ · idtoiso (maponpaths (λ h, (Φ $ h) xx₂) (!(id_left _))). Proof. unfold indexed_cat_to_disp_cat_to_disp_iso_inv. rewrite functor_comp. rewrite !assoc'. etrans. { do 3 apply maponpaths. apply (indexed_cat_lunitor_alt Φ). } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply (nat_trans_ax (indexed_cat_id Φ x)). } cbn. rewrite !assoc. rewrite z_iso_after_z_iso_inv. refine (maponpaths (λ z, z · _) (id_left _) @ _). do 4 apply maponpaths. apply homset_property. Qed. Proposition indexed_cat_to_disp_cat_to_disp_iso_inv_left : f · indexed_cat_id Φ x xx₂ · # (Φ $ identity x) indexed_cat_to_disp_cat_to_disp_iso_inv · indexed_cat_comp Φ (identity x) (identity x) xx₁ = indexed_cat_id Φ x xx₁ · idtoiso (maponpaths (λ h, (Φ $ h) xx₁) (!(id_left _))). Proof. unfold indexed_cat_to_disp_cat_to_disp_iso_inv. rewrite functor_comp. rewrite !assoc'. etrans. { do 3 apply maponpaths. apply (indexed_cat_lunitor_alt Φ). } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply (nat_trans_ax (indexed_cat_id Φ x)). } cbn. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply (z_iso_inv_after_z_iso f_iso). } refine (maponpaths (λ z, z · _) (id_left _) @ _). do 4 apply maponpaths. apply homset_property. Qed. Definition indexed_cat_to_disp_cat_to_disp_iso : @is_z_iso_disp _ indexed_cat_to_disp_cat _ _ (identity_z_iso x) _ _ (indexed_cat_to_disp_cat_z_iso_weq_base xx₁ xx₂ f). Proof. simple refine (_ ,, _ ,, _). - exact indexed_cat_to_disp_cat_to_disp_iso_inv. - abstract (cbn ; unfold transportb ; rewrite transportf_indexed_cat_to_disp_cat ; refine (indexed_cat_to_disp_cat_to_disp_iso_inv_right @ _) ; do 4 apply maponpaths ; apply homset_property). - abstract (cbn ; unfold transportb ; rewrite transportf_indexed_cat_to_disp_cat ; refine (indexed_cat_to_disp_cat_to_disp_iso_inv_left @ _) ; do 4 apply maponpaths ; apply homset_property). Defined. End IsoToDispIso. Section DispIsoToIso. Context (Hf : @is_z_iso_disp _ indexed_cat_to_disp_cat _ _ (identity_z_iso x) _ _ (indexed_cat_to_disp_cat_z_iso_weq_base xx₁ xx₂ f)). Definition indexed_cat_to_disp_cat_from_disp_iso_inv : xx₂ --> xx₁ := inv_mor_disp_from_z_iso Hf · inv_from_z_iso (indexed_cat_id_z_iso Φ xx₁). Proposition indexed_cat_to_disp_cat_from_disp_iso_inv_right : f · indexed_cat_to_disp_cat_from_disp_iso_inv = identity _. Proof. unfold indexed_cat_to_disp_cat_from_disp_iso_inv. rewrite !assoc. refine (!_). use z_iso_inv_on_left. rewrite id_left. pose (inv_mor_after_z_iso_disp Hf) as p. cbn in p. unfold transportb in p. rewrite transportf_indexed_cat_to_disp_cat in p. use (cancel_z_iso _ _ (idtoiso (maponpaths (λ h, (Φ $ h) xx₁) (!(id_left (identity x)))))). refine (_ @ p) ; clear p. rewrite !assoc'. apply maponpaths. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (indexed_cat_id Φ x)). } cbn. rewrite !assoc'. apply maponpaths. apply (indexed_cat_runitor_alt Φ). Qed. Proposition indexed_cat_to_disp_cat_from_disp_iso_inv_left : indexed_cat_to_disp_cat_from_disp_iso_inv · f = identity _. Proof. unfold indexed_cat_to_disp_cat_from_disp_iso_inv. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax (nat_z_iso_inv (indexed_cat_id_nat_z_iso Φ x)) _ _ _ : _ · inv_from_z_iso (indexed_cat_id_z_iso Φ xx₂) = inv_from_z_iso (indexed_cat_id_z_iso Φ xx₁) · f). } rewrite !assoc. refine (!_). use z_iso_inv_on_left. rewrite id_left. use (cancel_z_iso _ _ (idtoiso (maponpaths (λ h, (Φ $ h) xx₂) (!(id_left (identity x)))))). pose (z_iso_disp_after_inv_mor Hf) as p. cbn in p. unfold transportb in p. rewrite transportf_indexed_cat_to_disp_cat in p. refine (_ @ p) ; clear p. rewrite !functor_comp. rewrite !assoc'. do 2 apply maponpaths. refine (!_). refine (indexed_cat_lunitor_alt Φ _ _ @ _). do 3 apply maponpaths. apply homset_property. Qed. Definition indexed_cat_to_disp_cat_from_disp_iso : is_z_isomorphism f. Proof. simple refine (_ ,, _ ,, _). - exact indexed_cat_to_disp_cat_from_disp_iso_inv. - exact indexed_cat_to_disp_cat_from_disp_iso_inv_right. - exact indexed_cat_to_disp_cat_from_disp_iso_inv_left. Defined. End DispIsoToIso. Definition indexed_cat_to_disp_cat_z_iso_weq_fiber : is_z_isomorphism f ≃ @is_z_iso_disp _ indexed_cat_to_disp_cat _ _ (identity_z_iso x) _ _ (indexed_cat_to_disp_cat_z_iso_weq_base xx₁ xx₂ f). Proof. use weqimplimpl. - exact indexed_cat_to_disp_cat_to_disp_iso. - exact indexed_cat_to_disp_cat_from_disp_iso. - apply isaprop_is_z_isomorphism. - apply isaprop_is_z_iso_disp. Defined. End IsoWeqDispIso. Definition indexed_cat_to_disp_cat_z_iso_weq {x : C} (xx₁ xx₂ : Φ x) : z_iso xx₁ xx₂ ≃ @z_iso_disp _ indexed_cat_to_disp_cat _ _ (identity_z_iso _) xx₁ xx₂. Proof. use weqbandf. - exact (indexed_cat_to_disp_cat_z_iso_weq_base xx₁ xx₂). - exact (indexed_cat_to_disp_cat_z_iso_weq_fiber xx₁ xx₂). Defined. Definition is_z_iso_disp_indexed_cat_to_disp_cat {x : C} (xx₁ xx₂ : Φ x) (f : xx₁ --> (Φ $ identity x) xx₂) (Hf : is_z_isomorphism f) : @is_z_iso_disp _ indexed_cat_to_disp_cat _ _ (identity_z_iso x) xx₁ xx₂ f. Proof. pose (f' := f · inv_from_z_iso (indexed_cat_id_z_iso Φ xx₂)). refine (transportf (λ z, is_z_iso_disp _ z) _ (indexed_cat_to_disp_cat_to_disp_iso xx₁ xx₂ f' _)). - cbn ; unfold f'. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply z_iso_after_z_iso_inv. - use is_z_isomorphism_comp. + exact Hf. + apply is_z_iso_inv_from_z_iso. Defined. (** 3. The univalence of that displayed category *) Proposition is_univalent_disp_indexed_cat_to_disp_cat : is_univalent_disp indexed_cat_to_disp_cat. Proof. use is_univalent_disp_from_fibers. intros x xx₁ xx₂. use weqhomot. - exact (indexed_cat_to_disp_cat_z_iso_weq xx₁ xx₂ ∘ make_weq idtoiso (pr2 (Φ x) _ _))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; cbn ; apply id_left). Defined. (** 4. Cartesian morphisms are the same as certain isomorphisms *) Section Cartesians. Context {x y : C} {f : x --> y} {xx : Φ x} {yy : Φ y} {ff : xx --> (Φ $ f) yy} (Hff : is_z_isomorphism ff) {w : C} (g : w --> x) {ww : Φ w} (hh : ww --> (Φ $ g · f) yy). Let ff_iso : z_iso xx ((Φ $ f) yy) := ff ,, Hff. Proposition is_cartesian_indexed_cat_factorisation_unique : isaprop (∑ gg, gg · # (Φ $ g) ff · indexed_cat_comp Φ f g yy = hh). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use (cancel_z_iso _ _ (functor_on_z_iso (Φ $ g) ff_iso)). use (cancel_z_iso _ _ (indexed_cat_comp_z_iso Φ f g yy)). exact (pr2 φ₁ @ ! (pr2 φ₂)). Qed. Definition is_cartesian_indexed_cat_factorisation : ww --> (Φ $ g) xx := hh · inv_from_z_iso (indexed_cat_comp_z_iso Φ f g yy) · # (Φ $ g) (inv_from_z_iso ff_iso). Proposition is_cartesian_indexed_cat_factorisation_commutes : is_cartesian_indexed_cat_factorisation · # (Φ $ g) ff · indexed_cat_comp Φ f g yy = hh. Proof. unfold is_cartesian_indexed_cat_factorisation. rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite <- functor_comp. rewrite z_iso_after_z_iso_inv. rewrite functor_id. apply idpath. } rewrite id_left. rewrite z_iso_after_z_iso_inv. apply id_right. Qed. End Cartesians. Proposition is_cartesian_indexed_cat {x y : C} {f : x --> y} {xx : Φ x} {yy : Φ y} (ff : xx --> (Φ $ f) yy) (Hff : is_z_isomorphism ff) : @is_cartesian _ indexed_cat_to_disp_cat y x f yy xx ff. Proof. intros w g ww hh ; cbn in *. use iscontraprop1. - exact (is_cartesian_indexed_cat_factorisation_unique Hff g hh). - simple refine (_ ,, _). + exact (is_cartesian_indexed_cat_factorisation Hff g hh). + exact (is_cartesian_indexed_cat_factorisation_commutes Hff g hh). Defined. Section CartesianAreIsos. Context {x y : C} {f : x --> y} {xx : Φ x} {yy : Φ y} (ff : xx --> (Φ $ f) yy) (Hff : @is_cartesian _ indexed_cat_to_disp_cat y x f yy xx ff). Let ζ : (Φ $ f) yy --> (Φ $ identity x · f) yy := indexed_cat_id Φ x ((Φ $ f) yy) · indexed_cat_comp Φ f (identity x) yy. Let φ : (Φ $ f) yy --> (Φ $ identity x) xx := cartesian_factorisation Hff (identity _) ζ. Definition is_cartesian_to_iso_indexed_cat_inv : (Φ $ f) yy --> xx := φ · inv_from_z_iso (indexed_cat_id_z_iso Φ xx). Proposition is_cartesian_to_iso_indexed_cat_left : ff · is_cartesian_to_iso_indexed_cat_inv = identity xx. Proof. unfold is_cartesian_to_iso_indexed_cat_inv, φ. rewrite !assoc. refine (!_). use z_iso_inv_on_left. use (cartesian_factorisation_unique Hff) ; cbn. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. exact (cartesian_factorisation_commutes Hff (identity _) ζ). } unfold ζ. rewrite !assoc. apply maponpaths_2. etrans. { apply (nat_trans_ax (indexed_cat_id Φ x)). } apply maponpaths_2. refine (!_). apply id_left. Qed. Proposition is_cartesian_to_iso_indexed_cat_right : is_cartesian_to_iso_indexed_cat_inv · ff = identity ((Φ $ f) yy). Proof. unfold is_cartesian_to_iso_indexed_cat_inv, φ. rewrite !assoc'. etrans. { apply maponpaths. exact (!(nat_trans_ax (nat_z_iso_inv (indexed_cat_id_nat_z_iso Φ x)) _ _ ff) : inv_from_z_iso (indexed_cat_id_z_iso Φ xx) · ff = # (Φ $ identity x) ff · inv_from_z_iso (indexed_cat_id_z_iso Φ ((Φ $ f) yy))). } cbn. rewrite !assoc. refine (!_). use z_iso_inv_on_left. rewrite id_left. use (cancel_z_iso _ _ (indexed_cat_comp_z_iso Φ f (identity x) yy)). exact (cartesian_factorisation_commutes Hff (identity _) ζ). Qed. Definition is_cartesian_to_iso_indexed_cat : is_z_isomorphism ff. Proof. simple refine (_ ,, _ ,, _). - exact is_cartesian_to_iso_indexed_cat_inv. - exact is_cartesian_to_iso_indexed_cat_left. - exact is_cartesian_to_iso_indexed_cat_right. Defined. End CartesianAreIsos. (** 5. The cleaving from an indexed category *) Definition indexed_cat_to_cleaving : cleaving indexed_cat_to_disp_cat. Proof. intros y x f yy ; cbn in *. refine ((Φ $ f) yy ,, identity _ ,, _). use is_cartesian_indexed_cat. apply is_z_isomorphism_identity. Defined. End IndexedCatToFibration. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedFunctor.v000066400000000000000000000120771451125700300263310ustar00rootroot00000000000000(************************************************************************* Indexed functors An indexed functor between two indexed categories is the same as a pseudonatural transformation between the corresponding pseudofunctors. In this file, we formulate this notion only using terminology from 1-category theory and without referring to bicategories, pseudofunctors, and pseudonatural transformations. In addition, we can make one simplification in this definition. A pseudonatural transformation has an invertible 2-cell witnessing the naturality ([indexed_functor_natural]), and this invertible 2-cell must itself also be natural. If we are looking at indexed categories, then the source bicategory is actually discrete. As such, this second naturality condition follows by path induction. Contents 1. The data of an indexed functor 2. The laws of an indexed functor 3. Indexed functors *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Local Open Scope cat. (** 1. The data of an indexed functor *) Definition indexed_functor_data {C : category} (Φ Ψ : indexed_cat C) : UU := ∑ (τ₀ : ∏ (x : C), Φ x ⟶ Ψ x), ∏ (x y : C) (f : x --> y), nat_z_iso (τ₀ x ∙ (Ψ $ f)) ((Φ $ f) ∙ τ₀ y). Definition make_indexed_functor_data {C : category} {Φ Ψ : indexed_cat C} (τ₀ : ∏ (x : C), Φ x ⟶ Ψ x) (τ₁ : ∏ (x y : C) (f : x --> y), nat_z_iso (τ₀ x ∙ (Ψ $ f)) ((Φ $ f) ∙ τ₀ y)) : indexed_functor_data Φ Ψ := τ₀ ,, τ₁. Definition indexed_functor_to_functor {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor_data Φ Ψ) (x : C) : Φ x ⟶ Ψ x := pr1 τ x. Coercion indexed_functor_to_functor : indexed_functor_data >-> Funclass. Definition indexed_functor_natural {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor_data Φ Ψ) {x y : C} (f : x --> y) : nat_z_iso (τ x ∙ (Ψ $ f)) ((Φ $ f) ∙ τ y) := pr2 τ x y f. Definition indexed_functor_natural_z_iso {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor_data Φ Ψ) {x y : C} (f : x --> y) (xx : Φ x) : z_iso ((Ψ $ f) (τ x xx)) (τ y ((Φ $ f) xx)) := nat_z_iso_pointwise_z_iso (indexed_functor_natural τ f) xx. (** 2. The laws of an indexed functor *) Definition indexed_functor_laws {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor_data Φ Ψ) : UU := (∏ (x : C) (xx : Φ x), indexed_cat_id Ψ x (τ x xx) · indexed_functor_natural τ (identity x) xx = # (τ x) (indexed_cat_id Φ x xx)) × (∏ (x y z : C) (f : x --> y) (g : y --> z) (xx : Φ x), indexed_cat_comp Ψ f g (τ x xx) · indexed_functor_natural τ (f · g) xx = # (Ψ $ g) (indexed_functor_natural τ f xx) · (indexed_functor_natural τ g) ((Φ $ f) xx) · # (τ z) (indexed_cat_comp Φ f g xx)). (** 3. Indexed functors *) Definition indexed_functor {C : category} (Φ Ψ : indexed_cat C) : UU := ∑ (τ : indexed_functor_data Φ Ψ), indexed_functor_laws τ. Definition make_indexed_functor {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor_data Φ Ψ) (Hτ : indexed_functor_laws τ) : indexed_functor Φ Ψ := τ ,, Hτ. Coercion indexed_functor_to_data {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor Φ Ψ) : indexed_functor_data Φ Ψ := pr1 τ. Section IndexedFunctorLaws. Context {C : category} {Φ Ψ : indexed_cat C} (τ : indexed_functor Φ Ψ). Proposition indexed_functor_id {x : C} (xx : Φ x) : indexed_cat_id Ψ x (τ x xx) · indexed_functor_natural τ (identity x) xx = # (τ x) (indexed_cat_id Φ x xx). Proof. exact (pr12 τ x xx). Qed. Proposition indexed_functor_comp {x y z : C} (f : x --> y) (g : y --> z) (xx : Φ x) : indexed_cat_comp Ψ f g (τ x xx) · indexed_functor_natural τ (f · g) xx = # (Ψ $ g) (indexed_functor_natural τ f xx) · (indexed_functor_natural τ g) ((Φ $ f) xx) · # (τ z) (indexed_cat_comp Φ f g xx). Proof. exact (pr22 τ x y z f g xx). Qed. End IndexedFunctorLaws. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedFunctorToCartesian.v000066400000000000000000000104431451125700300304610ustar00rootroot00000000000000(************************************************************************* Indexed functors give rise to cartesian functors We show that every indexed functor between indexed categories give rise to a cartesian functor between their corresponding fibrations. We first construct the displayed functor ([indexed_functor_to_disp_functor]), and to prove it preserves cartesian morphisms, we use the characterization of cartesian morphisms in the Grothendieck construction. Contents 1. The displayed functor arising from an indexed functor 2. Preservation of cartesian morphisms *************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Local Open Scope cat. Section IndexedFunctorToCartesianFunctor. Context {C : category} {Φ Ψ : indexed_cat (C^opp)} (τ : indexed_functor Φ Ψ). (** 1. The displayed functor arising from an indexed functor *) Definition indexed_functor_to_disp_functor_data : disp_functor_data (functor_identity C) (indexed_cat_to_disp_cat Φ) (indexed_cat_to_disp_cat Ψ). Proof. simple refine (_ ,, _). - exact (λ x, τ x). - exact (λ x y xx yy f ff, #(τ x) ff · inv_from_z_iso (indexed_functor_natural_z_iso τ f yy)). Defined. Proposition indexed_functor_to_disp_functor_axioms : disp_functor_axioms indexed_functor_to_disp_functor_data. Proof. split. - intros x xx ; cbn in *. etrans. { apply maponpaths_2. exact (!(indexed_functor_id τ xx)). } refine (!_). use z_iso_inv_on_left. apply idpath. - intros x y z xx yy zz f g ff gg ; cbn in *. refine (!_). use z_iso_inv_on_left. rewrite !functor_comp. rewrite !assoc'. apply maponpaths. refine (!_). use z_iso_inv_on_right. etrans. { do 2 apply maponpaths. exact (indexed_functor_comp τ g f zz). } cbn. rewrite !assoc. apply maponpaths_2. refine (_ @ nat_trans_ax (indexed_functor_natural τ f) _ _ _). apply maponpaths_2. cbn. rewrite <- !functor_comp. apply maponpaths. rewrite !assoc'. rewrite z_iso_after_z_iso_inv. apply id_right. Qed. Definition indexed_functor_to_disp_functor : disp_functor (functor_identity C) (indexed_cat_to_disp_cat Φ) (indexed_cat_to_disp_cat Ψ). Proof. simple refine (_ ,, _). - exact indexed_functor_to_disp_functor_data. - exact indexed_functor_to_disp_functor_axioms. Defined. (** 2. Preservation of cartesian morphisms *) Definition is_cartesian_indexed_functor_to_disp_functor : is_cartesian_disp_functor indexed_functor_to_disp_functor. Proof. intros x y f xx yy ff Hff ; cbn in *. apply is_cartesian_indexed_cat. use is_z_iso_comp_of_is_z_isos. - use functor_on_is_z_isomorphism. exact (is_cartesian_to_iso_indexed_cat Φ ff Hff). - apply is_z_isomorphism_inv. Defined. Definition indexed_functor_to_cartesian_disp_functor : cartesian_disp_functor (functor_identity _) (indexed_cat_to_disp_cat Φ) (indexed_cat_to_disp_cat Ψ). Proof. simple refine (_ ,, _). - exact indexed_functor_to_disp_functor. - exact is_cartesian_indexed_functor_to_disp_functor. Defined. End IndexedFunctorToCartesianFunctor. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedTransformation.v000066400000000000000000000070451451125700300277160ustar00rootroot00000000000000(************************************************************************* Indexed transformations An indexed natural transformation is the same as a modification between two pseudonatural transformations. In this file, we formulate this notion using only terminology from 1-category theory. Note that no simplifications are made compared to the original definition. Contents 1. The data of an indexed natural transformation 2. The law of an indexed natural transformation 3. Indexed natural transformations *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Local Open Scope cat. (** 1. The data of an indexed natural transformation *) Definition indexed_nat_trans_data {C : category} {Φ Ψ : indexed_cat C} (τ θ : indexed_functor Φ Ψ) : UU := ∏ (x : C), τ x ⟹ θ x. (** 2. The law of an indexed natural transformation *) Definition indexed_nat_trans_law {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans_data τ θ) : UU := ∏ (x y : C) (f : x --> y) (xx : Φ x), indexed_functor_natural τ f xx · m y ((Φ $ f) xx) = # (Ψ $ f) (m x xx) · indexed_functor_natural θ f xx. (** 3. Indexed natural transformations *) Definition indexed_nat_trans {C : category} {Φ Ψ : indexed_cat C} (τ θ : indexed_functor Φ Ψ) : UU := ∑ (m : indexed_nat_trans_data τ θ), indexed_nat_trans_law m. Definition make_indexed_nat_trans {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans_data τ θ) (Hm : indexed_nat_trans_law m) : indexed_nat_trans τ θ := m ,, Hm. Definition indexed_nat_trans_to_data {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans τ θ) (x : C) : τ x ⟹ θ x := pr1 m x. Coercion indexed_nat_trans_to_data : indexed_nat_trans >-> Funclass. Proposition indexed_nat_trans_natural {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans τ θ) {x y : C} (f : x --> y) (xx : Φ x) : indexed_functor_natural τ f xx · m y ((Φ $ f) xx) = # (Ψ $ f) (m x xx) · indexed_functor_natural θ f xx. Proof. exact (pr2 m x y f xx). Qed. Proposition indexed_nat_trans_natural_inv {C : category} {Φ Ψ : indexed_cat C} {τ θ : indexed_functor Φ Ψ} (m : indexed_nat_trans τ θ) {x y : C} (f : x --> y) (xx : Φ x) : m y ((Φ $ f) xx) · inv_from_z_iso (indexed_functor_natural_z_iso θ f xx) = inv_from_z_iso (indexed_functor_natural_z_iso τ f xx) · # (Ψ $ f) (m x xx). Proof. refine (!_). use z_iso_inv_on_right. rewrite !assoc. use z_iso_inv_on_left. exact (indexed_nat_trans_natural m f xx). Qed. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/IndexedTransformationToTransformation.v000066400000000000000000000101631451125700300331430ustar00rootroot00000000000000(************************************************************************* Indexed transformations give rise to displayed transformations We show that every indexed transformation between indexed functors give rise to a displayed natural transformation between their corresponding cartesian functors. Contents 1. The data 2. The proof of naturality 3. The displayed natural transformation *************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategoryToFibration. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctorToCartesian. Local Open Scope cat. Section IndexedTransformationToDispNatTrans. Context {C : category} {Φ Ψ : indexed_cat (C^opp)} {τ θ: indexed_functor Φ Ψ} (m : indexed_nat_trans τ θ). (** 1. The data *) Definition indexed_nat_trans_to_disp_nat_trans_data : disp_nat_trans_data (nat_trans_id _) (indexed_functor_to_cartesian_disp_functor τ) (indexed_functor_to_cartesian_disp_functor θ) := λ x xx, m x xx · indexed_cat_id Ψ _ (θ x xx). (** 2. The proof of naturality *) Proposition indexed_nat_trans_to_disp_nat_trans_axioms : disp_nat_trans_axioms indexed_nat_trans_to_disp_nat_trans_data. Proof. intros x y f xx yy ff ; cbn in *. unfold transportb, indexed_nat_trans_to_disp_nat_trans_data. rewrite !functor_comp. refine (_ @ !(transportf_indexed_cat_to_disp_cat _ _ _)). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. exact (!(indexed_nat_trans_natural_inv m f yy)). } rewrite !assoc. etrans. { do 3 apply maponpaths_2. apply (nat_trans_ax (m x)). } rewrite !assoc'. apply maponpaths. refine (!_). etrans. { rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (indexed_cat_id Ψ x)). } cbn. rewrite !assoc'. apply maponpaths. refine (!_). apply (nat_trans_ax (indexed_cat_id Ψ x)). } cbn. rewrite !assoc'. do 2 apply maponpaths. refine (_ @ !(indexed_cat_lunitor_alt Ψ _ _)). rewrite !assoc. etrans. { apply maponpaths_2. apply (indexed_cat_runitor_alt Ψ). } refine (!(pr1_idtoiso_concat _ _) @ _). do 2 apply maponpaths. refine (!(maponpathscomp0 (λ g, (Ψ $ g) (θ y yy)) _ _) @ _). apply maponpaths. apply homset_property. Qed. (** 3. The displayed natural transformation *) Definition indexed_nat_trans_to_disp_nat_trans : disp_nat_trans (nat_trans_id _) (indexed_functor_to_cartesian_disp_functor τ) (indexed_functor_to_cartesian_disp_functor θ). Proof. simple refine (_ ,, _). - exact indexed_nat_trans_to_disp_nat_trans_data. - exact indexed_nat_trans_to_disp_nat_trans_axioms. Defined. End IndexedTransformationToDispNatTrans. Arguments indexed_nat_trans_to_disp_nat_trans_data {C Φ Ψ τ θ} m /. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/NatTransToIndexed.v000066400000000000000000000103021451125700300267330ustar00rootroot00000000000000(************************************************************************ Every natural transformation gives rise to an indexed transformation We prove that every displayed natural transformation between two cartesian functors gives rise to a indexed transformation between the corresponding indexed functors. The data of the indexed transformation can directly be constructed from the displayed transformation, and the only work is proving the laws. Contents 1. The data 2. The naturality 3. The indexed natural transformation ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations. Require Import UniMath.CategoryTheory.DisplayedCats.Fiber. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedFunctor. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedTransformation. Require Import UniMath.CategoryTheory.IndexedCategories.FibrationToIndexedCategory. Require Import UniMath.CategoryTheory.IndexedCategories.CartesianToIndexedFunctor. Section NatTransToIndexedNatTrans. Context {C : category} {D₁ D₂ : disp_univalent_category C} (HD₁ : cleaving D₁) (HD₂ : cleaving D₂) {F G : cartesian_disp_functor (functor_identity C) D₁ D₂} (τ : disp_nat_trans (nat_trans_id _) F G). (** 1. The data *) Definition disp_nat_trans_to_indexed_nat_trans_data : indexed_nat_trans_data (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F) (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ G). Proof. intro x. use make_nat_trans. - exact (λ xx, τ x xx). - abstract (intros xx yy ff ; cbn ; refine (maponpaths (transportf _ _) (disp_nat_trans_ax τ ff) @ _) ; unfold transportb ; rewrite transport_f_f ; apply maponpaths_2 ; apply homset_property). Defined. (** 2. The naturality *) Proposition disp_nat_trans_to_indexed_nat_trans_law : indexed_nat_trans_law disp_nat_trans_to_indexed_nat_trans_data. Proof. intros x y f xx ; cbn. refine (!_). use (cartesian_factorisation_unique (cartesian_disp_functor_on_cartesian G (HD₁ _ _ _ _))). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite transport_f_f. refine (!_). rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. etrans. { do 2 apply maponpaths. apply (disp_nat_trans_ax_var τ). } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. unfold transportb. rewrite transport_f_f. rewrite cartesian_factorisation_commutes. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. (** 3. The indexed natural transformation *) Definition disp_nat_trans_to_indexed_nat_trans : indexed_nat_trans (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ F) (cartesian_disp_functor_to_indexed_functor HD₁ HD₂ G). Proof. use make_indexed_nat_trans. - exact disp_nat_trans_to_indexed_nat_trans_data. - exact disp_nat_trans_to_indexed_nat_trans_law. Defined. End NatTransToIndexedNatTrans. UniMath-20231010/UniMath/CategoryTheory/IndexedCategories/OpIndexedCategory.v000066400000000000000000000140071451125700300267600ustar00rootroot00000000000000(********************************************************************* The fiberwise opposite of an indexed category In this file, we define the fiberwise opposite of indexed categories. More specifically, if we have a category `Φ` indexed over `C`, then the fiberwise opposite of `Φ` is defined to be the opposite of `Φ x` on every object `x`. Contents 1. The data 2. The laws 3. The fiberwise core *********************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.IndexedCategories.IndexedCategory. Local Open Scope cat. Section FiberwiseOp. Context {C : category} (Φ : indexed_cat C). (** 1. The data *) Definition op_indexed_cat_data : indexed_cat_data C. Proof. use make_indexed_cat_data. - exact (λ x, op_unicat (Φ x)). - exact (λ x y f, functor_opp (Φ $ f)). - exact (λ x, nat_trans_comp _ _ _ (functor_identity_op _) (op_nt (nat_z_iso_inv (indexed_cat_id_nat_z_iso Φ x)))). - exact (λ x y z f g, nat_trans_comp _ _ _ (functor_comp_op_nat_z_iso _ _) (op_nt (nat_z_iso_inv (indexed_cat_comp_nat_z_iso Φ f g)))). Defined. Definition op_indexed_cat_isos : indexed_cat_isos op_indexed_cat_data. Proof. split. - intros x xx. use opp_is_z_isomorphism. use is_z_isomorphism_comp. + apply (is_z_iso_inv_from_z_iso (indexed_cat_id_z_iso Φ xx)). + cbn. apply is_z_isomorphism_identity. - intros x y z f g xx. use opp_is_z_isomorphism. use is_z_isomorphism_comp. + apply (is_z_iso_inv_from_z_iso (indexed_cat_comp_z_iso Φ f g xx)). + cbn. apply is_z_isomorphism_identity. Defined. (** 2. The laws *) Proposition op_indexed_cat_laws : indexed_cat_laws op_indexed_cat_data. Proof. repeat split. - intros x y f xx ; cbn in *. rewrite !id_right. change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_id Φ xx)) with (inv_from_z_iso (indexed_cat_id_z_iso Φ xx)). change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ (identity x) f xx)) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ (identity x) f xx)). rewrite functor_on_inv_from_z_iso. rewrite !assoc. use z_iso_inv_on_left ; cbn. refine (_ @ !(id_left _)). refine (!_). use z_iso_inv_on_left ; cbn. refine (_ @ !(indexed_cat_lunitor_alt Φ f xx)). refine (@idtoiso_opp (Φ y) _ _ _ @ _). rewrite maponpathsinv0. apply idpath. - intros x y f xx ; cbn in *. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. apply id_right. } apply maponpaths_2. apply id_right. } change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_id Φ ((Φ $ f) xx))) with (inv_from_z_iso (indexed_cat_id_z_iso Φ ((Φ $ f) xx))). change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ f (identity y) xx)) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ f (identity y) xx)). rewrite !assoc. refine (!_). use z_iso_inv_on_left ; cbn. refine (_ @ !(id_left _)). refine (!_). use z_iso_inv_on_left ; cbn. refine (_ @ !(indexed_cat_runitor_alt Φ f xx)). refine (@idtoiso_opp (Φ y) _ _ _ @ _). rewrite maponpathsinv0. apply idpath. - intros w x y z f g h ww ; cbn in *. rewrite !id_right. change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ f (g · h) ww)) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ f (g · h) ww)). change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ g h ((Φ $ f) ww))) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ g h ((Φ $ f) ww))). change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ (f · g) h ww)) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ (f · g) h ww)). change (is_z_isomorphism_mor (is_z_isomorphism_indexed_cat_comp Φ f g ww)) with (inv_from_z_iso (indexed_cat_comp_z_iso Φ f g ww)). rewrite functor_on_inv_from_z_iso. refine (assoc _ _ _ @ _). use z_iso_inv_on_left ; cbn. refine (!(id_left _) @ _). refine (!_). use z_iso_inv_on_left ; cbn. rewrite !assoc'. refine (!_). etrans. { do 3 apply maponpaths. exact (!(indexed_cat_lassociator Φ f g h ww)). } etrans. { do 2 apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. apply z_iso_after_z_iso_inv. } rewrite id_left. etrans. { apply maponpaths. refine (assoc _ _ _ @ _). apply maponpaths_2. apply z_iso_after_z_iso_inv. } rewrite id_left. etrans. { apply maponpaths_2. apply (@idtoiso_opp (Φ z)). } etrans. { apply maponpaths_2. do 2 apply maponpaths. refine (!_). apply (maponpathsinv0 (λ k, (Φ $ k) ww)). } etrans. { refine (!_). apply pr1_idtoiso_concat. } rewrite <- (maponpathscomp0 (λ k, (Φ $ k) ww)). rewrite pathsinv0l. apply idpath. Qed. (** 3. The fiberwise core *) Definition op_indexed_cat : indexed_cat C. Proof. use make_indexed_cat. - exact op_indexed_cat_data. - exact op_indexed_cat_isos. - exact op_indexed_cat_laws. Defined. End FiberwiseOp. UniMath-20231010/UniMath/CategoryTheory/Inductives/000077500000000000000000000000001451125700300217415ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Inductives/LambdaCalculus.v000066400000000000000000000242241451125700300250100ustar00rootroot00000000000000(** This file contains a direct formalization of the lambda calculus ([LambdaCalculus]) as the initial algebra of the lambda calculus functor. A better formalization where the lambda calculus and a substitution monad is obtained from a binding signature can be found in SubstitutionSystems/LamFromBindingSig.v. Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Adjunctions.Examples. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Local Notation "'chain'" := (diagram nat_graph). Section lambdacalculus. Local Notation "'HSET2'":= [HSET, HSET]. (* Local Definition has_homsets_HSET2 : has_homsets HSET2. Proof. apply functor_category_has_homsets. Defined. *) Local Definition BinProductsHSET2 : BinProducts HSET2. Proof. apply (BinProducts_functor_precat _ _ BinProductsHSET). Defined. Local Definition BinCoproductsHSET2 : BinCoproducts HSET2. Proof. apply (BinCoproducts_functor_precat _ _ BinCoproductsHSET). Defined. Local Lemma Exponentials_HSET2 : Exponentials BinProductsHSET2. Proof. apply Exponentials_functor_HSET. Defined. Local Lemma InitialHSET2 : Initial HSET2. Proof. apply (Initial_functor_precat _ _ InitialHSET). Defined. Local Definition CCHSET : Colims_of_shape nat_graph HSET := ColimsHSET_of_shape nat_graph. Local Notation "' x" := (omega_cocont_constant_functor x) (at level 10). Local Notation "'Id'" := (omega_cocont_functor_identity _). Local Notation "F * G" := (omega_cocont_BinProduct_of_functors_alt BinProductsHSET2 _ (is_omega_cocont_constprod_functor1 _ Exponentials_HSET2) F G). Local Notation "F + G" := (omega_cocont_BinCoproduct_of_functors BinCoproductsHSET2 F G). Local Notation "'_' 'o' 'option'" := (omega_cocont_pre_composition_functor (option_functor BinCoproductsHSET TerminalHSET) CCHSET) (at level 10). (** The lambda calculus functor with one component for variables, one for application and one for abstraction/lambda *) Definition lambdaOmegaFunctor : omega_cocont_functor HSET2 HSET2 := omega_cocont_constant_functor (C:= [_,_]) (D:=[_,_])(functor_identity HSET) + (Id * Id + _ o option). (* Definition lambdaOmegaFunctor : omega_cocont_functor HSET2 HSET2 := '(functor_identity HSET) + (Id * Id + _ o option). *) Let lambdaFunctor : functor HSET2 HSET2 := pr1 lambdaOmegaFunctor. Let is_omega_cocont_lambdaFunctor : is_omega_cocont lambdaFunctor := pr2 lambdaOmegaFunctor. Lemma lambdaFunctor_Initial : Initial (category_FunctorAlg lambdaFunctor). Proof. apply (colimAlgInitial InitialHSET2 is_omega_cocont_lambdaFunctor). apply ColimsFunctorCategory_of_shape; apply ColimsHSET_of_shape. Defined. (** The lambda calculus *) Definition LambdaCalculus : HSET2 := alg_carrier _ (InitialObject lambdaFunctor_Initial). Let LambdaCalculus_mor : HSET2⟦lambdaFunctor LambdaCalculus,LambdaCalculus⟧ := alg_map _ (InitialObject lambdaFunctor_Initial). Let LambdaCalculus_alg : algebra_ob lambdaFunctor := InitialObject lambdaFunctor_Initial. Definition var_map : HSET2⟦functor_identity HSET,LambdaCalculus⟧ := BinCoproductIn1 (BinCoproductsHSET2 _ _) · LambdaCalculus_mor. (* How to do this nicer? *) Definition prod2 (x y : HSET2) : HSET2. Proof. apply BinProductsHSET2; [apply x | apply y]. Defined. Definition app_map : HSET2⟦prod2 LambdaCalculus LambdaCalculus,LambdaCalculus⟧ := BinCoproductIn1 (BinCoproductsHSET2 _ _) · BinCoproductIn2 (BinCoproductsHSET2 _ _) · LambdaCalculus_mor. Definition app_map' (x : HSET) : HSET⟦(pr1 LambdaCalculus x × pr1 LambdaCalculus x)%set,pr1 LambdaCalculus x⟧. Proof. apply app_map. Defined. Let precomp_option X := (pre_composition_functor _ _ HSET (option_functor BinCoproductsHSET TerminalHSET) X). Definition lam_map : HSET2⟦precomp_option LambdaCalculus,LambdaCalculus⟧ := BinCoproductIn2 (BinCoproductsHSET2 _ _) · BinCoproductIn2 (BinCoproductsHSET2 _ _) · LambdaCalculus_mor. Definition make_lambdaAlgebra (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : algebra_ob lambdaFunctor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar (BinCoproductArrow _ fapp flam)). Defined. Definition foldr_map (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : algebra_mor lambdaFunctor LambdaCalculus_alg (make_lambdaAlgebra X fvar fapp flam). Proof. apply (InitialArrow lambdaFunctor_Initial (make_lambdaAlgebra X fvar fapp flam)). Defined. Definition foldr_map' (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : HSET2 ⟦ pr1 LambdaCalculus_alg, pr1 (make_lambdaAlgebra X fvar fapp flam) ⟧. Proof. apply (foldr_map X fvar fapp flam). Defined. Lemma foldr_var (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET2 _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. apply id_left. Defined. Lemma foldr_app (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : app_map · foldr_map X fvar fapp flam = # (pr1 (Id * Id)) (foldr_map X fvar fapp flam) · fapp. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET2 _ _) · BinCoproductIn2 (BinCoproductsHSET2 _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0. eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. rewrite assoc. eapply pathscomp0. eapply cancel_postcomposition, cancel_postcomposition, BinCoproductOfArrowsIn1. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn2Commutes|]. rewrite <- assoc. now eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. Defined. Lemma foldr_lam (X : HSET2) (fvar : HSET2⟦functor_identity HSET,X⟧) (fapp : HSET2⟦prod2 X X,X⟧) (flam : HSET2⟦precomp_option X,X⟧) : lam_map · foldr_map X fvar fapp flam = # (pr1 (_ o option)) (foldr_map X fvar fapp flam) · flam. Proof. assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET2 _ _) · BinCoproductIn2 (BinCoproductsHSET2 _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0. eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. rewrite assoc. eapply pathscomp0. eapply cancel_postcomposition, cancel_postcomposition, BinCoproductOfArrowsIn2. rewrite <- assoc. eapply pathscomp0. eapply maponpaths, BinCoproductIn2Commutes. rewrite <- assoc. now eapply pathscomp0; [eapply maponpaths, BinCoproductIn2Commutes|]. Defined. End lambdacalculus. (* Old version *) (* Definition Lambda : functor HSET2 HSET2. *) (* Proof. *) (* eapply coproduct_of_functors. *) (* apply CoproductsHSET2. *) (* apply (constant_functor HSET2 HSET2 (functor_identity HSET)). *) (* eapply coproduct_of_functors. *) (* apply CoproductsHSET2. *) (* (* app *) *) (* eapply functor_composite. *) (* apply delta_functor. *) (* apply binproduct_functor. *) (* apply ProductsHSET2. *) (* (* lam *) *) (* apply (pre_composition_functor _ _ _ has_homsets_HSET _ *) (* (option_functor _ CoproductsHSET TerminalHSET)). *) (* Defined. *) (* Lemma omega_cocont_LambdaFunctor : is_omega_cocont LambdaFunctor. *) (* Proof. *) (* apply is_omega_cocont_coproduct_of_functors. *) (* apply (Products_functor_precat _ _ ProductsHSET). *) (* apply functor_category_has_homsets. *) (* apply functor_category_has_homsets. *) (* simpl. *) (* apply is_omega_cocont_functor_identity. *) (* apply has_homsets_HSET2. *) (* apply is_omega_cocont_coproduct_of_functors. *) (* apply (Products_functor_precat _ _ ProductsHSET). *) (* apply functor_category_has_homsets. *) (* apply functor_category_has_homsets. *) (* apply is_omega_cocont_functor_composite. *) (* apply functor_category_has_homsets. *) (* apply is_omega_cocont_delta_functor. *) (* apply (Products_functor_precat _ _ ProductsHSET). *) (* apply functor_category_has_homsets. *) (* apply is_omega_cocont_binproduct_functor. *) (* apply functor_category_has_homsets. *) (* apply Exponentials_functor_HSET. *) (* apply has_homsets_HSET. *) (* apply is_omega_cocont_pre_composition_functor. *) (* apply LimsHSET. *) (* Defined. *) UniMath-20231010/UniMath/CategoryTheory/Inductives/Lists.v000066400000000000000000000522531451125700300232350ustar00rootroot00000000000000(** This file contains formalizations of lists. First over sets as the initial algebra of the list functor ([List]) and then more generally over any type defined as iterated products ([list]). Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.PartA. (* flip *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. (** * Lists as the colimit of a chain given by the list functor: F(X) = 1 + A * X *) Section lists. Variable A : HSET. Local Open Scope cocont_functor_hset_scope. (** F(X) = 1 + (A * X) *) Definition L_A : omega_cocont_functor HSET HSET := '1 + 'A * Id. Let listFunctor : functor HSET HSET := pr1 L_A. Let is_omega_cocont_listFunctor : is_omega_cocont listFunctor := pr2 L_A. Lemma listFunctor_Initial : Initial (category_FunctorAlg listFunctor). Proof. apply (colimAlgInitial InitialHSET is_omega_cocont_listFunctor (ColimCoconeHSET _ _)). Defined. (** The type of lists of A's *) Definition μL_A : HSET := alg_carrier _ (InitialObject listFunctor_Initial). Definition List : UU := pr1 μL_A. Let List_mor : HSET⟦listFunctor μL_A,μL_A⟧ := alg_map _ (InitialObject listFunctor_Initial). Let List_alg : algebra_ob listFunctor := InitialObject listFunctor_Initial. Definition nil_map : HSET⟦unitHSET,μL_A⟧ := BinCoproductIn1 (BinCoproductsHSET _ _) · List_mor. Definition nil : List := nil_map tt. Definition cons_map : HSET⟦(A × μL_A)%set,μL_A⟧ := BinCoproductIn2 (BinCoproductsHSET _ _) · List_mor. Definition cons : pr1 A → List -> List := λ a l, cons_map (a,,l). (** Get recursion/iteration scheme: << x : X f : A × X -> X ------------------------------------ foldr x f : List A -> X >> *) Definition make_listAlgebra (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) : algebra_ob listFunctor. Proof. set (x' := λ (_ : unit), x). apply (tpair _ X (sumofmaps x' f) : algebra_ob listFunctor). Defined. Definition foldr_map (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) : algebra_mor _ List_alg (make_listAlgebra X x f). Proof. apply (InitialArrow listFunctor_Initial (make_listAlgebra X x f)). Defined. (** Iteration/fold *) Definition foldr (X : HSET) (x : pr1 X) (f : pr1 A → pr1 X → pr1 X) : List → pr1 X. Proof. apply (foldr_map _ x (λ a, f (pr1 a) (pr2 a))). Defined. (* Maybe quantify over "λ _ : unit, x" instead of nil? *) Lemma foldr_nil (X : hSet) (x : X) (f : pr1 A → X -> X) : foldr X x f nil = x. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X x (λ a, f (pr1 a) (pr2 a))))). apply (toforallpaths _ _ _ F tt). Qed. Lemma foldr_cons (X : hSet) (x : X) (f : pr1 A → X -> X) (a : pr1 A) (l : List) : foldr X x f (cons a l) = f a (foldr X x f l). Proof. assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X x (λ a, f (pr1 a) (pr2 a))))). assert (Fal := toforallpaths _ _ _ F (a,,l)). clear F. unfold compose in Fal. simpl in Fal. apply Fal. Opaque foldr_map. Qed. (* This Qed is slow unless foldr_map is Opaque *) Transparent foldr_map. (** The induction principle for lists defined using foldr *) Section list_induction. Variables (P : List -> UU) (PhSet : ∏ l, isaset (P l)). Variables (P0 : P nil) (Pc : ∏ a l, P l -> P (cons a l)). Let P' : UU := ∑ l, P l. Let P0' : P' := (nil,, P0). Let Pc' : pr1 A → P' -> P' := λ (a : pr1 A) (p : P'), cons a (pr1 p),,Pc a (pr1 p) (pr2 p). Definition P'HSET : HSET. Proof. apply (tpair _ P'). abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]). Defined. (** This line is crucial for isalghom_pr1foldr to typecheck *) Opaque is_omega_cocont_listFunctor. Lemma isalghom_pr1foldr : is_algebra_mor listFunctor List_alg List_alg (λ l, pr1 (foldr P'HSET P0' Pc' l)). Proof. apply (BinCoproductArrow_eq_cor _ BinCoproductsHSET). - apply funextfun; intro x; induction x. apply (maponpaths pr1 (foldr_nil P'HSET P0' Pc')). - apply funextfun; intro x; destruct x as [a l]. apply (maponpaths pr1 (foldr_cons P'HSET P0' Pc' a l)). Qed. (* Transparent is_omega_cocont_listFunctor. *) Definition pr1foldr_algmor : algebra_mor listFunctor List_alg List_alg. Proof. use tpair. - exact (λ l, pr1 (foldr P'HSET P0' Pc' l)). - hnf. apply isalghom_pr1foldr. Defined. Transparent is_omega_cocont_listFunctor. Lemma pr1foldr_algmor_identity : identity List_alg = pr1foldr_algmor. Proof. now rewrite (@InitialEndo_is_identity _ listFunctor_Initial pr1foldr_algmor). Qed. (** The induction principle for lists *) Lemma listInd l : P l. Proof. assert (H : pr1 (foldr P'HSET P0' Pc' l) = l). apply (toforallpaths _ _ _ (maponpaths pr1 (!pr1foldr_algmor_identity)) l). rewrite <- H. apply (pr2 (foldr P'HSET P0' Pc' l)). Defined. End list_induction. Lemma listIndhProp (P : List → hProp) : P nil → (∏ a l, P l → P (cons a l)) → ∏ l, P l. Proof. intros Pnil Pcons. apply listInd; try assumption. intro l; apply isasetaprop, propproperty. Defined. (* This variation is easier to use *) Lemma listIndProp (P : List → UU) (HP : ∏ l, isaprop (P l)) : P nil → (∏ a l, P l → P (cons a l)) → ∏ l, P l. Proof. intros Pnil Pcons. apply listInd; try assumption. intro l; apply isasetaprop, HP. Defined. Local Open Scope nat_scope. Local Notation "'A'" := (pr1 A). Definition length : List -> nat := foldr natHSET 0 (λ _ (n : nat), 1 + n). Definition map (f : A -> A) : List -> List := foldr _ nil (λ (x : A) (xs : List), cons (f x) xs). Lemma length_map (f : A -> A) : ∏ xs, length (map f xs) = length xs. Proof. apply listIndProp. - intros l; apply isasetnat. - now unfold map; rewrite foldr_nil. - simpl; unfold map, length; simpl; intros a l Hl. now rewrite !foldr_cons, <- Hl. Qed. Definition concatenate : List -> List -> List := λ l l', foldr _ l cons l'. End lists. (** Some examples of computations with lists over nat *) Section nat_examples. Definition cons_nat a l : List natHSET := cons natHSET a l. Local Infix "::" := cons_nat. Local Notation "[]" := (nil natHSET) (at level 0, format "[]"). Definition testlist : List natHSET := 5 :: 2 :: []. Definition testlistS : List natHSET := map natHSET S testlist. Definition sum : List natHSET -> nat := foldr natHSET natHSET 0 (λ x y, x + y). (* None of these compute *) (* Eval cbn in length _ (nil natHSET). *) (* Eval vm_compute in length _ testlist. *) (* Eval vm_compute in length _ testlistS. *) (* Eval vm_compute in sum testlist. *) (* Eval vm_compute in sum testlistS. *) (* All of these compute *) Goal length _ (nil natHSET) = 0. reflexivity. Qed. Goal length _ testlist = length _ testlistS. reflexivity. Qed. Goal sum testlistS = sum testlist + length _ testlist. lazy. reflexivity. Qed. Goal length _ (concatenate _ testlist testlistS) = length _ testlist + length _ testlistS. reflexivity. Qed. Goal sum (concatenate _ testlist testlistS) = sum testlistS + sum testlist. reflexivity. Qed. Goal (∏ l, length _ (2 :: l) = S (length _ l)). simpl. intro l. try apply idpath. (* this doesn't work *) unfold length, cons_nat. rewrite foldr_cons. cbn. apply idpath. Abort. (* some experiments: *) (* Definition const {A B : UU} : A -> B -> A := λ x _, x. *) (* Eval compute in const 0 (nil natHSET). *) (* Axiom const' : ∏ {A B : UU}, A -> B -> A. *) (* Eval compute in const' 0 1. *) (* Eval compute in const' 0 (nil natHSET). *) (* Time Eval vm_compute in nil natHSET. (* This crashes my computer by using up all memory *) *) End nat_examples. (** * Equivalence with lists as iterated products *) Section list. Lemma isaset_list (A : HSET) : isaset (list (pr1 A)). Proof. apply isaset_total2; [apply isasetnat|]. intro n; induction n as [|n IHn]; simpl; [apply isasetunit|]. apply isaset_dirprod; [ apply setproperty | apply IHn ]. Qed. Definition to_List (A : HSET) : list (pr1 A) -> List A. Proof. intros l. destruct l as [n l]. induction n as [|n IHn]. + exact (nil A). + apply (cons _ (pr1 l) (IHn (pr2 l))). Defined. Definition to_list (A : HSET) : List A -> list (pr1 A). Proof. apply (foldr A (list (pr1 A),,isaset_list A)). * apply (0,,tt). * intros a L; simpl in *. apply (tpair _ (S (pr1 L)) (a,,pr2 L)). Defined. Lemma to_listK (A : HSET) : ∏ x : list (pr1 A), to_list A (to_List A x) = x. Proof. intro l; destruct l as [n l]; unfold to_list, to_List. induction n as [|n IHn]; simpl. - rewrite foldr_nil. now destruct l. - rewrite foldr_cons; simpl. now rewrite IHn. Qed. Lemma to_ListK (A : HSET) : ∏ y : List A, to_List A (to_list A y) = y. Proof. apply listIndProp. * intro l; apply setproperty. * now unfold to_list; rewrite foldr_nil. * unfold to_list, to_List; intros a l IH. rewrite foldr_cons; simpl. apply maponpaths, pathsinv0. eapply pathscomp0; [eapply pathsinv0, IH|]; simpl. now destruct foldr. Qed. (** Equivalence between list and List for A a set *) Lemma weq_list (A : HSET) : list (pr1 A) ≃ List A. Proof. use tpair. - apply to_List. - use isweq_iso. + apply to_list. + apply to_listK. + apply to_ListK. Defined. (* This doesn't compute: *) (* Eval compute in (to_list _ testlist). *) (* This does compute: *) Goal to_list _ testlist = 2,,5,,2,,tt. reflexivity. Qed. End list. (** Alternative version of lists using a more direct proof of omega-cocontinuity. This definition has slightly better computational properties. *) Module AltList. (* The functor "x * F" is omega_cocont. This is only proved for set at the moment as it needs that the category is cartesian closed *) Section constprod_functor. Variables (x : hSet). Definition constprod_functor : functor HSET HSET := BinProduct_of_functors HSET HSET BinProductsHSET (constant_functor HSET HSET x) (functor_identity HSET). Lemma omega_cocontConstProdFunctor : is_omega_cocont constprod_functor. Proof. intros hF c L ccL HcL cc. use tpair. - transparent assert (HX : (cocone hF (funset x HcL))). { use make_cocone. * simpl; intro n; apply flip, (curry (Z := λ _,_)), (pr1 cc). * abstract (destruct cc as [f hf]; simpl; intros m n e; rewrite <- (hf m n e); destruct e; simpl; repeat (apply funextfun; intro); apply idpath). } use tpair. + simpl; apply uncurry, flip. apply (colimArrow (make_ColimCocone _ _ _ ccL) (funset x HcL)). apply HX. + cbn. destruct cc as [f hf]; simpl; intro n. apply funextfun; intro p. change p with (pr1 p,,pr2 p). assert (XR := colimArrowCommutes (make_ColimCocone hF c L ccL) _ HX n). unfold flip, curry, colimIn in *; simpl in *. now rewrite <- (toforallpaths _ _ _ (toforallpaths _ _ _ XR (pr2 p)) (pr1 p)). - abstract ( intro p; unfold uncurry; simpl; apply subtypePath; simpl; [ intro g; apply impred; intro t; use (let ff : HSET ⟦(x × dob hF t)%set,HcL⟧ := _ in _); [ simpl; apply (pr1 cc) | apply (@has_homsets_HSET _ HcL _ ff) ] | destruct p as [t p]; simpl; apply funextfun; intro xc; destruct xc as [x' c']; simpl; use (let g : HSET⟦colim (make_ColimCocone hF c L ccL), funset x HcL⟧ := _ in _); [ simpl; apply flip, (curry (Z := λ _,_)), t | rewrite <- (colimArrowUnique _ _ _ g); [apply idpath | ]; destruct cc as [f hf]; unfold is_cocone_mor in p; simpl in *; now intro n; simpl; rewrite <- (p n) ] ]). Defined. End constprod_functor. (* The functor "x + F" is omega_cocont. Assumes that the category has coproducts *) Section constcoprod_functor. Variables (C : category) (x : C) (PC : BinCoproducts C). Definition constcoprod_functor : functor C C := BinCoproduct_of_functors C C PC (constant_functor C C x) (functor_identity C). Lemma omega_cocontConstCoprodFunctor : is_omega_cocont constcoprod_functor. Proof. intros hF c L ccL HcL cc. use tpair. - use tpair. + eapply BinCoproductArrow. * exact (BinCoproductIn1 (PC x (dob hF 0)) · pr1 cc 0). * use (let ccHcL : cocone hF HcL := _ in _). { use make_cocone. - intros n; exact (BinCoproductIn2 (PC x (dob hF n)) · pr1 cc n). - abstract ( intros m n e; destruct e; simpl; destruct cc as [f hf]; simpl in *; rewrite <- (hf m _ (idpath _)), !assoc; apply cancel_postcomposition; unfold constcoprod_functor; cbn; apply pathsinv0; etrans; [apply BinCoproductOfArrowsIn2|]; apply idpath). } apply (pr1 (pr1 (ccL HcL ccHcL))). + abstract ( destruct cc as [f hf]; simpl in *; simpl; intro n; unfold constcoprod_functor; cbn; etrans; [apply precompWithBinCoproductArrow |]; apply pathsinv0, BinCoproductArrowUnique; red in hf; [ rewrite id_left; induction n as [|n IHn]; [apply idpath|]; etrans; [| apply IHn]; unfold constant_functor; simpl; rewrite <- (hf n _ (idpath _)), assoc; unfold constant_functor; simpl; apply pathsinv0; etrans; [apply cancel_postcomposition; apply BinCoproductOfArrowsIn1 |]; now rewrite id_left | rewrite <- (hf n _ (idpath _)); destruct ccL as [t p]; destruct t as [t p0]; simpl in *; rewrite p0; simpl; now apply maponpaths, hf]). - abstract ( destruct cc as [f hf]; simpl in *; intro t; apply subtypePath; simpl; [ intro g; apply impred; intro; apply C | destruct t as [t p]; destruct ccL as [t0 p0]; unfold is_cocone_mor in *; unfold constcoprod_functor; destruct t0 as [t0 p1]; simpl; apply BinCoproductArrowUnique; [ unfold coconeIn in p; simpl in p; rewrite <- (p 0), assoc; apply cancel_postcomposition; apply pathsinv0; etrans; [apply BinCoproductOfArrowsIn1 |]; apply id_left | use (let temp : ∑ x0 : C ⟦ c, HcL ⟧, ∏ v : nat, coconeIn L v · x0 = BinCoproductIn2 (PC x (dob hF v)) · f v := _ in _); [ apply (tpair _ (BinCoproductIn2 (PC x c) · t)); intro n; unfold coconeIn in p; simpl in p; rewrite <- (p n), !assoc; apply cancel_postcomposition; apply pathsinv0; etrans; [apply BinCoproductOfArrowsIn2 |]; apply idpath|]; apply (maponpaths pr1 (p0 temp))]]). Defined. End constcoprod_functor. (* Lists as the colimit of a chain given by the list functor: F(X) = 1 + A * X *) Section lists. Variable A : HSET. (* F(X) = A * X *) Definition stream : functor HSET HSET := constprod_functor1 BinProductsHSET A. (* F(X) = 1 + (A * X) *) Definition listFunctor : functor HSET HSET := functor_composite stream (constcoprod_functor _ unitHSET BinCoproductsHSET). Lemma omega_cocont_listFunctor : is_omega_cocont listFunctor. Proof. apply (is_omega_cocont_functor_composite). - apply omega_cocontConstProdFunctor. (* If I use this length doesn't compute with vm_compute... *) (* - apply (omega_cocont_constprod_functor1 _ _ has_homsets_HSET Exponentials_HSET). *) - apply (omega_cocontConstCoprodFunctor _). Defined. Lemma listFunctor_Initial : Initial (category_FunctorAlg listFunctor). Proof. apply (colimAlgInitial InitialHSET omega_cocont_listFunctor (ColimCoconeHSET _ _)). Defined. Definition List : HSET := alg_carrier _ (InitialObject listFunctor_Initial). Let List_mor : HSET⟦listFunctor List,List⟧ := alg_map _ (InitialObject listFunctor_Initial). Let List_alg : algebra_ob listFunctor := InitialObject listFunctor_Initial. Definition nil_map : HSET⟦unitHSET,List⟧. Proof. simpl; intro x. use List_mor. apply inl. exact x. Defined. Definition nil : pr1 List := nil_map tt. Definition cons_map : HSET⟦(A × List)%set,List⟧. Proof. intros xs. use List_mor. exact (inr xs). Defined. Definition cons : pr1 A × pr1 List -> pr1 List := cons_map. (* Get recursion/iteration scheme: *) (* x : X f : A × X -> X *) (* ------------------------------------ *) (* foldr x f : List A -> X *) Definition make_listAlgebra (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) : algebra_ob listFunctor. Proof. set (x' := λ (_ : unit), x). apply (tpair _ X (sumofmaps x' f) : algebra_ob listFunctor). Defined. Definition foldr_map (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) : algebra_mor _ List_alg (make_listAlgebra X x f). Proof. apply (InitialArrow listFunctor_Initial (make_listAlgebra X x f)). Defined. Definition foldr (X : HSET) (x : pr1 X) (f : pr1 A × pr1 X -> pr1 X) : pr1 List -> pr1 X. Proof. apply (foldr_map _ x f). Defined. (* Maybe quantify over "λ _ : unit, x" instead of nil? *) Lemma foldr_nil (X : hSet) (x : X) (f : pr1 A × X -> X) : foldr X x f nil = x. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X x f))). apply (toforallpaths _ _ _ F tt). Qed. Lemma foldr_cons (X : hSet) (x : X) (f : pr1 A × X -> X) (a : pr1 A) (l : pr1 List) : foldr X x f (cons (a,,l)) = f (a,,foldr X x f l). Proof. assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X x f))). apply (toforallpaths _ _ _ F (a,,l)). Qed. (* This defines the induction principle for lists using foldr *) Section list_induction. Variables (P : pr1 List -> UU) (PhSet : ∏ l, isaset (P l)). Variables (P0 : P nil) (Pc : ∏ (a : pr1 A) (l : pr1 List), P l -> P (cons (a,,l))). Let P' : UU := ∑ l, P l. Let P0' : P' := (nil,, P0). Let Pc' : pr1 A × P' -> P' := λ ap : pr1 A × P', cons (pr1 ap,, pr1 (pr2 ap)),,Pc (pr1 ap) (pr1 (pr2 ap)) (pr2 (pr2 ap)). Definition P'HSET : HSET. Proof. apply (tpair _ P'). abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]). Defined. Lemma isalghom_pr1foldr : is_algebra_mor _ List_alg List_alg (λ l, pr1 (foldr P'HSET P0' Pc' l)). Proof. apply BinCoproductArrow_eq_cor. - apply funextfun; intro x; destruct x; apply idpath. - apply funextfun; intro x; destruct x as [a l]. apply (maponpaths pr1 (foldr_cons P'HSET P0' Pc' a l)). Qed. Definition pr1foldr_algmor : algebra_mor _ List_alg List_alg := tpair _ _ isalghom_pr1foldr. Lemma pr1foldr_algmor_identity : identity _ = pr1foldr_algmor. Proof. now rewrite (@InitialEndo_is_identity _ listFunctor_Initial pr1foldr_algmor). Qed. Lemma listInd l : P l. Proof. assert (H : pr1 (foldr P'HSET P0' Pc' l) = l). apply (toforallpaths _ _ _ (maponpaths pr1 (!pr1foldr_algmor_identity)) l). rewrite <- H. apply (pr2 (foldr P'HSET P0' Pc' l)). Defined. End list_induction. Lemma listIndProp (P : pr1 List -> UU) (HP : ∏ l, isaprop (P l)) : P nil -> (∏ a l, P l → P (cons (a,, l))) -> ∏ l, P l. Proof. intros Pnil Pcons. apply listInd; try assumption. intro l; apply isasetaprop, HP. Defined. Definition natHSET : HSET. Proof. exists nat. abstract (apply isasetnat). Defined. Definition length : pr1 List -> nat := foldr natHSET 0 (λ x, S (pr2 x)). Definition map (f : pr1 A -> pr1 A) : pr1 List -> pr1 List := foldr _ nil (λ xxs : pr1 A × pr1 List, cons (f (pr1 xxs),, pr2 xxs)). Lemma length_map (f : pr1 A -> pr1 A) : ∏ xs, length (map f xs) = length xs. Proof. apply listIndProp. - intros l; apply isasetnat. - apply idpath. - simpl; unfold map, length; simpl; intros a l Hl. simpl. now rewrite !foldr_cons, <- Hl. Qed. End lists. (* Some examples of computations with lists over nat *) Section nat_examples. Definition cons_nat a l : pr1 (List natHSET) := cons natHSET (a,,l). Infix "::" := cons_nat. Notation "[]" := (nil natHSET) (at level 0, format "[]"). Definition testlist : pr1 (List natHSET) := 5 :: 2 :: []. Definition testlistS : pr1 (List natHSET) := map natHSET S testlist. Definition sum : pr1 (List natHSET) -> nat := foldr natHSET natHSET 0 (λ xy, pr1 xy + pr2 xy). (* All of these work *) (* Eval cbn in length _ (nil natHSET). *) (* Eval vm_compute in length _ testlist. *) (* Eval vm_compute in length _ testlistS. *) (* Eval vm_compute in sum testlist. *) (* Eval vm_compute in sum testlistS. *) (* Goal length _ testlist = 2. *) (* vm_compute. *) (* Restart. *) (* cbn. *) (* Restart. *) (* compute. (* does not work when foldr is opaque with "Opaque foldr." *) *) (* Restart. *) (* cbv. (* does not work when foldr is opaque with "Opaque foldr." *) *) (* Restart. *) (* native_compute. *) (* Abort. *) Goal (∏ l, length _ (2 :: l) = S (length _ l)). simpl. intro l. try apply idpath. (* this doesn't work *) unfold length, cons_nat. rewrite foldr_cons. cbn. apply idpath. Abort. End nat_examples. End AltList. UniMath-20231010/UniMath/CategoryTheory/Inductives/PropositionalLogic.v000066400000000000000000000222661451125700300257600ustar00rootroot00000000000000(** This file contains a formalization of the syntax of propositional logic as the initial algebra of a functor. Following Goldblatt's 'Topoi', all of the connectives are treated as primitive. As stated there, they are _a priori_ distinct; their interdefinability is naturally propositional, not definitional. Written by: Langston Barrett, 2019 *) (** ** Contents - Definition of PL syntax as an initial algebra - Definition of a PL valuation in [bool] - TODO: Definition of a PL valuation in an (order-theoretic) algebra *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Bool. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Adamek. Local Open Scope cat. Local Open Scope cocont_functor_hset_scope. Section PL. Let times x y := BinProductObject _ (BinProductsHSET x y). Local Infix "⊗" := times. Variable (vars : hSet). (** << PL_functor Var Rec := Var (* -- arity 1, sentences *) + Rec (* -- arity 1, ¬ (not) *) + (Rec × Rec) (* -- arity 2, ∧ (and) *) + (Rec × Rec) (* -- arity 2, ∨ (or) *) + (Rec × Rec) (* -- arity 2, → (implies) *) >> *) Definition PL_functor : omega_cocont_functor HSET HSET := (omega_cocont_constant_functor (vars : HSET)) + Id + (Id * Id) + (Id * Id) + (Id * Id). (* Definition PL_functor : omega_cocont_functor HSET HSET := ' vars + Id + (Id * Id) + (Id * Id) + (Id * Id). *) (** The following three statements are crucial for performance. *) Definition PL_functor' : functor HSET HSET := pr1 PL_functor. Let is_omega_cocont_PL_functor' : is_omega_cocont PL_functor' := pr2 PL_functor. Opaque is_omega_cocont_PL_functor'. Lemma PL_functor_initial : Initial (category_FunctorAlg PL_functor'). Proof. apply (colimAlgInitial InitialHSET is_omega_cocont_PL_functor' (ColimCoconeHSET _ _)). Defined. Let PL_alg : algebra_ob PL_functor' := InitialObject PL_functor_initial. (** The underlying set of the initial algebra *) Definition PL : hSet := alg_carrier _ PL_alg. Definition PL_type : UU := pr1hSet PL. Definition PL_var : HSET⟦vars, PL⟧. refine (_ · alg_map _ PL_alg). intro v; do 4 apply inl; exact v. Defined. Definition PL_not : HSET⟦PL, PL⟧. refine (_ · alg_map _ PL_alg). intro s; do 3 apply inl; apply inr; exact s. Defined. Definition PL_and : HSET⟦PL ⊗ PL, PL⟧. refine (_ · alg_map _ PL_alg). intro s; do 2 apply inl; apply inr; exact s. Defined. Definition PL_and_fun (x : PL_type) (y : PL_type) : PL_type := PL_and (make_dirprod x y). Definition PL_or : HSET⟦PL ⊗ PL, PL⟧. refine (_ · alg_map _ PL_alg). intro s; do 1 apply inl; apply inr; exact s. Defined. Definition PL_or_fun (x : PL_type) (y : PL_type) : PL_type := PL_or (make_dirprod x y). Definition PL_impl : HSET⟦PL ⊗ PL, PL⟧. refine (_ · alg_map _ PL_alg). intro s; apply inr; exact s. Defined. Definition PL_impl_fun (x : PL_type) (y : PL_type) : PL_type := PL_impl (make_dirprod x y). Definition PL_iff_fun (x : PL_type) (y : PL_type) : PL_type := PL_and_fun (PL_impl (make_dirprod x y)) (PL_impl (make_dirprod y x)). Declare Scope PL. Delimit Scope PL with PL. Notation "¬" := (PL_not) : PL. Infix "∧" := (PL_and) : PL. Infix "∨" := (PL_or) : PL. Infix "⇒" := (PL_impl) : PL. Infix "⇔" := (PL_iff_fun) (at level 90) : PL. Definition make_PL_algebra (X : hSet) (vs : vars -> X) (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) : algebra_ob PL_functor'. Proof. exists X. cbn; do 5 (try (apply sumofmaps)). - assumption. (* vs *) - exact not. - apply (invweq (weqfunfromdirprod _ _ _)); exact and. - apply (invweq (weqfunfromdirprod _ _ _)); exact or. - apply (invweq (weqfunfromdirprod _ _ _)); exact impl. Defined. (** The fold, or catamorphism: given the same structure of operations on any other set, we can construct an interpretation of PL in that set. *) Definition PL_fold_alg_mor {X : hSet} (vs : vars -> X) (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) : algebra_mor PL_functor' PL_alg (make_PL_algebra X vs not and or impl). Proof. apply (InitialArrow PL_functor_initial (make_PL_algebra X vs not and or impl)). Defined. Definition PL_fold {X : hSet} (vs : vars -> X) (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X) : PL -> X := mor_from_algebra_mor _ (PL_fold_alg_mor vs not and or impl). (** Some lemmas expressing the computational behavior of [PL_fold] *) Section FoldComputationLemmas. Context {X : hSet} (vs : vars -> X) (not : X -> X) (and : X -> X -> X) (or : X -> X -> X) (impl : X -> X -> X). Let fold := PL_fold vs not and or impl. Let mor := PL_fold_alg_mor vs not and or impl. Let comm := algebra_mor_commutes _ _ _ mor. Lemma PL_fold_var : ∏ z, fold (PL_var z) = vs z. Proof. reflexivity. Qed. Lemma PL_fold_not : ∏ p, fold (PL_not p) = not (fold p). Proof. intro. do 3 apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply eqtohomot in comm. specialize (comm p). exact comm. Qed. Lemma PL_fold_and : ∏ p q, fold (PL_and (make_dirprod p q)) = and (fold p) (fold q). Proof. intros p q. do 2 apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply eqtohomot in comm. specialize (comm (make_dirprod p q)). exact comm. Qed. Lemma PL_fold_or : ∏ p q, fold (PL_or (make_dirprod p q)) = or (fold p) (fold q). Proof. intros p q. apply (maponpaths (λ x, (inl : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply eqtohomot in comm. specialize (comm (make_dirprod p q)). exact comm. Qed. Lemma PL_fold_impl : ∏ p q, fold (PL_impl (make_dirprod p q)) = impl (fold p) (fold q). Proof. intros p q. apply (maponpaths (λ x, (inr : HSET ⟦_, BinCoproductsHSET _ _⟧) · x)) in comm. apply eqtohomot in comm. specialize (comm (make_dirprod p q)). apply comm. Qed. End FoldComputationLemmas. (** The induction principle. Mirrors the proof for lists. *) Section PL_ind. Context {P : PL -> UU} (PhSet : ∏ l, isaset (P l)). Context (P_vars : ∏ v : vars, P (PL_var v)) (P_not : ∏ pl, P pl -> P (PL_not pl)) (P_and : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_and (make_dirprod pl1 pl2))) (P_or : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_or (make_dirprod pl1 pl2))) (P_impl : ∏ pl1 pl2, P pl1 -> P pl2 -> P (PL_impl (make_dirprod pl1 pl2))). Let P' : UU := ∑ pl : PL, P pl. Let P'_vars (v : vars) : P' := (PL_var v,, P_vars v). Let P'_not (pl : P') : P' := (PL_not (pr1 pl),, P_not _ (pr2 pl)). Let P'_and (pl1 pl2 : P') : P' := (PL_and (make_dirprod (pr1 pl1) (pr1 pl2)),, P_and _ _ (pr2 pl1) (pr2 pl2)). Let P'_or (pl1 pl2 : P') : P' := (PL_or (make_dirprod (pr1 pl1) (pr1 pl2)),, P_or _ _ (pr2 pl1) (pr2 pl2)). Let P'_impl (pl1 pl2 : P') : P' := (PL_impl (make_dirprod (pr1 pl1) (pr1 pl2)),, P_impl _ _ (pr2 pl1) (pr2 pl2)). Definition P'HSET : HSET. Proof. use make_hSet. - exact P'. - abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]). Defined. Opaque is_omega_cocont_PL_functor'. Lemma is_algebra_morphism_pr1_PL_fold : is_algebra_mor _ PL_alg PL_alg (λ l, pr1 (@PL_fold P'HSET P'_vars P'_not P'_and P'_or P'_impl l)). Proof. apply (BinCoproductArrow_eq_cor _ BinCoproductsHSET). - apply funextfun; intro x; induction x as [x2 | x3]. + induction x2 as [x4 | x5]. * induction x4 as [x6 | x7]. -- cbn in x6. (* This line takes forever, more performance work to be done. *) (* apply (maponpaths pr1 (@PL_fold_var P'HSET P'_vars P'_not P'_and P'_or P'_impl x6)). *) Abort. End PL_ind. End PL. (** A valuation for atomic sentences can be extended to one for all sentences. *) Definition bool_valuation {vars : hSet} (V : vars -> bool) : PL vars -> bool. Proof. use (@PL_fold vars boolset). - assumption. (* V *) - exact negb. - exact andb. - exact orb. - exact implb. Defined. UniMath-20231010/UniMath/CategoryTheory/Inductives/Trees.v000066400000000000000000000171201451125700300232130ustar00rootroot00000000000000(** Definition of binary trees ([Tree]) implemented similarily to lists as the initial algebra of the tree functor. Written by: Anders Mörtberg (2016) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.Inductives.Lists. Local Open Scope cat. (** * Binary trees *) Section bintrees. Variable A : HSET. Local Open Scope cocont_functor_hset_scope. (** The tree functor: F(X) = 1 + A * X * X *) Definition treeOmegaFunctor : omega_cocont_functor HSET HSET := '1 + 'A * (Id * Id). Let treeFunctor : functor HSET HSET := pr1 treeOmegaFunctor. Let is_omega_cocont_treeFunctor : is_omega_cocont treeFunctor := pr2 treeOmegaFunctor. Lemma treeFunctor_Initial : Initial (category_FunctorAlg treeFunctor). Proof. apply (colimAlgInitial InitialHSET is_omega_cocont_treeFunctor (ColimCoconeHSET _ _)). Defined. (** The type of binary trees *) Definition Tree : HSET := alg_carrier _ (InitialObject treeFunctor_Initial). Let Tree_mor : HSET⟦treeFunctor Tree,Tree⟧ := alg_map _ (InitialObject treeFunctor_Initial). Let Tree_alg : algebra_ob treeFunctor := InitialObject treeFunctor_Initial. Definition leaf_map : HSET⟦unitHSET,Tree⟧. Proof. simpl; intro x. use Tree_mor. apply inl, x. Defined. Definition leaf : pr1 Tree := leaf_map tt. Definition node_map : HSET⟦(A × (Tree × Tree))%set,Tree⟧. Proof. intros xs. use Tree_mor. exact (inr xs). Defined. Definition node : pr1 A × (pr1 Tree × pr1 Tree) -> pr1 Tree := node_map. (** Get recursion/iteration scheme: << x : X f : A × X × X -> X ------------------------------------ foldr x f : Tree A -> X >> *) Definition make_treeAlgebra (X : HSET) (x : pr1 X) (f : HSET⟦(A × X × X)%set,X⟧) : algebra_ob treeFunctor. Proof. set (x' := λ (_ : unit), x). apply (tpair _ X (sumofmaps x' f) : algebra_ob treeFunctor). Defined. Definition foldr_map (X : HSET) (x : pr1 X) (f : HSET⟦(A × X × X)%set,X⟧) : algebra_mor _ Tree_alg (make_treeAlgebra X x f). Proof. apply (InitialArrow treeFunctor_Initial (make_treeAlgebra X x f)). Defined. Definition foldr (X : HSET) (x : pr1 X) (f : pr1 A × pr1 X × pr1 X -> pr1 X) : pr1 Tree -> pr1 X. Proof. apply (foldr_map _ x f). Defined. (* Maybe quantify over "λ _ : unit, x" instead of nil? *) Lemma foldr_leaf (X : hSet) (x : X) (f : pr1 A × X × X -> X) : foldr X x f leaf = x. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X x f))). apply (toforallpaths _ _ _ F tt). Qed. Lemma foldr_node (X : hSet) (x : X) (f : pr1 A × X × X -> X) (a : pr1 A) (l1 l2 : pr1 Tree) : foldr X x f (node (a,,l1,,l2)) = f (a,,foldr X x f l1,,foldr X x f l2). Proof. assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET _ _)· x) (algebra_mor_commutes _ _ _ (foldr_map X x f))). assert (Fal := toforallpaths _ _ _ F (a,,l1,,l2)). clear F. (* apply Fal. *) (* This doesn't work here. why? *) unfold compose in Fal. simpl in Fal. apply Fal. Opaque foldr_map. Qed. (* This Qed is slow unless foldr_map is Opaque *) Transparent foldr_map. (** This defines the induction principle for trees using foldr *) Section tree_induction. Variables (P : pr1 Tree -> UU) (PhSet : ∏ l, isaset (P l)). Variables (P0 : P leaf) (Pc : ∏ (a : pr1 A) (l1 l2 : pr1 Tree), P l1 -> P l2 -> P (node (a,,l1,,l2))). Let P' : UU := ∑ l, P l. Let P0' : P' := (leaf,, P0). Let Pc' : pr1 A × P' × P' -> P'. Proof. intros ap. apply (tpair _ (node (pr1 ap,,pr1 (pr1 (pr2 ap)),,pr1 (pr2 (pr2 ap))))). apply (Pc _ _ _ (pr2 (pr1 (pr2 ap))) (pr2 (pr2 (pr2 ap)))). (* λ ap : pr1 A × P' × P', node (pr1 ap,, pr1 (pr2 ap)),,Pc (pr1 ap) (pr1 (pr2 ap)) (pr2 (pr2 ap)). *) Defined. Definition P'HSET : HSET. Proof. apply (tpair _ P'). abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]). Defined. (* This line is crucial for isalghom_pr1foldr to typecheck *) Opaque is_omega_cocont_treeFunctor. Lemma isalghom_pr1foldr : is_algebra_mor _ Tree_alg Tree_alg (λ l, pr1 (foldr P'HSET P0' Pc' l)). Proof. apply BinCoproductArrow_eq_cor. - apply funextfun; intro x; destruct x. apply (maponpaths pr1 (foldr_leaf P'HSET P0' Pc')). - apply funextfun; intro x; destruct x as [a [l1 l2]]. apply (maponpaths pr1 (foldr_node P'HSET P0' Pc' a l1 l2)). Qed. Definition pr1foldr_algmor : algebra_mor _ Tree_alg Tree_alg := tpair _ _ isalghom_pr1foldr. Lemma pr1foldr_algmor_identity : identity _ = pr1foldr_algmor. Proof. now rewrite (@InitialEndo_is_identity _ treeFunctor_Initial pr1foldr_algmor). Qed. Transparent is_omega_cocont_treeFunctor. Lemma treeInd l : P l. Proof. assert (H : pr1 (foldr P'HSET P0' Pc' l) = l). apply (toforallpaths _ _ _ (maponpaths pr1 (!pr1foldr_algmor_identity)) l). rewrite <- H. apply (pr2 (foldr P'HSET P0' Pc' l)). Defined. End tree_induction. Lemma treeIndProp (P : pr1 Tree -> UU) (HP : ∏ l, isaprop (P l)) : P leaf -> (∏ a l1 l2, P l1 → P l2 → P (node (a,,l1,,l2))) -> ∏ l, P l. Proof. intros Pnil Pcons. apply treeInd; try assumption. intro l; apply isasetaprop, HP. Defined. End bintrees. (** Some tests *) Section nat_examples. Local Open Scope nat_scope. Definition size : pr1 (Tree natHSET) -> nat := foldr natHSET natHSET 0 (λ x, S (pr1 (pr2 x) + pr2 (pr2 x))). Lemma size_node a l1 l2 : size (node natHSET (a,,l1,,l2)) = 1 + size l1 + size l2. Proof. unfold size. now rewrite foldr_node. Qed. Definition map (f : nat -> nat) (l : pr1 (Tree natHSET)) : pr1 (Tree natHSET) := foldr natHSET (Tree natHSET) (leaf natHSET) (λ a, node natHSET (f (pr1 a),, pr1 (pr2 a),, pr2 (pr2 a))) l. Lemma size_map (f : nat -> nat) : ∏ l, size (map f l) = size l. Proof. apply treeIndProp. - intros l. apply isasetnat. - now unfold map; rewrite foldr_leaf. - intros a l1 l2 ih1 ih2; unfold map. now rewrite foldr_node, !size_node, <- ih1, <- ih2. Qed. Definition sum : pr1 (Tree natHSET) -> nat := foldr natHSET natHSET 0 (λ x, pr1 x + pr1 (pr2 x) + pr2 (pr2 x)). Definition testtree : pr1 (Tree natHSET). Proof. use node_map; repeat split. - apply 5. - use node_map; repeat split. + apply 6. + exact (leaf_map _ tt). + exact (leaf_map _ tt). - exact (leaf_map _ tt). Defined. End nat_examples. (** ** Flattening of a tree into a list *) Local Notation "a :: b" := (cons _ a b). (* Check concatenate. *) Definition flatten (A : HSET) : pr1 (Tree A) -> List A. Proof. intro t. use (foldr A). - apply nil. - intro all'. set (a := pr1 all'). set (l := pr1 (pr2 all')). set (l' := pr2 (pr2 all')). cbn beta in l'. exact (concatenate _ l (concatenate _ (a :: nil _ ) l')). - exact t. Defined. Goal Lists.sum (flatten _ testtree) = sum testtree. reflexivity. Qed. UniMath-20231010/UniMath/CategoryTheory/IsoCommaCategory.v000066400000000000000000000351021451125700300232210ustar00rootroot00000000000000(**************************************************************** Iso comma categories Given functors `F : C₁ ⟶ C₃` and `G : C₂ ⟶ C₃`. Then the iso-comma category of `F` and `G` is defined as follows: - Objects: pairs `(x, y) : C₁ × C₂` with an iso `F x --> G y` - Morphisms: morphisms from `(x₁, y₁, i₁)` to `(x₂, y₂, i₂)` consists of maps `f : x₁ --> x₂` and `g : y₁ --> y₂` such that that the following square commutes F x₁ --> F x₂ | | | | v v G y₁ --> G y₂ In this file, we define the iso-comma category using displayed category. We also prove that it's univalent, and we define the necessary projection functors and transformations. We also show that the iso-comma category satisfies the universal mapping property of a pullback. *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Section IsoCommaCategory. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃). (** Definition of iso comma categories via displayed categories *) Definition iso_comma_disp_cat_ob_mor : disp_cat_ob_mor (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact (λ x, z_iso (F (pr1 x)) (G (pr2 x))). - exact (λ x y i₁ i₂ f, #F (pr1 f) · i₂ = i₁ · #G (pr2 f)). Defined. Definition iso_comma_disp_cat_id_comp : disp_cat_id_comp _ iso_comma_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - intros x i ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - cbn ; intros x y z f g i₁ i₂ i₃ p q. rewrite !functor_comp. rewrite !assoc'. rewrite q. rewrite !assoc. rewrite p. apply idpath. Qed. Definition iso_comma_disp_cat_data : disp_cat_data (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact iso_comma_disp_cat_ob_mor. - exact iso_comma_disp_cat_id_comp. Defined. Definition iso_comma_disp_cat_axioms : disp_cat_axioms _ iso_comma_disp_cat_data. Proof. repeat split ; intros ; try (apply homset_property). apply isasetaprop. apply homset_property. Qed. Definition iso_comma_disp_cat : disp_cat (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact iso_comma_disp_cat_data. - exact iso_comma_disp_cat_axioms. Defined. Definition iso_comma : category := total_category iso_comma_disp_cat. Definition eq_iso_comma_mor {x y : iso_comma} {f g : x --> y} (p : pr11 f = pr11 g) (q : pr21 f = pr21 g) : f = g. Proof. use subtypePath. { intro. apply homset_property. } use pathsdirprod. - exact p. - exact q. Qed. Definition is_z_iso_iso_comma {x y : iso_comma} (f : x --> y) (H₁ : is_z_isomorphism (pr11 f)) (H₂ : is_z_isomorphism (pr21 f)) : is_z_isomorphism f. Proof. simple refine ((_ ,, _) ,, _). split. - exact (inv_from_z_iso (_ ,, H₁)). - exact (inv_from_z_iso (_ ,, H₂)). - abstract (cbn ; rewrite !functor_on_inv_from_z_iso ; use z_iso_inv_on_left ; rewrite assoc' ; refine (!_) ; use z_iso_inv_on_right ; cbn ; refine (!_) ; apply (pr2 f)). - split. + abstract (use eq_iso_comma_mor ; cbn ; [ apply (z_iso_inv_after_z_iso (make_z_iso' _ H₁)) | apply (z_iso_inv_after_z_iso (make_z_iso' _ H₂)) ]). + abstract (use eq_iso_comma_mor ; cbn ; [ apply (z_iso_after_z_iso_inv (make_z_iso' _ H₁)) | apply (z_iso_after_z_iso_inv (make_z_iso' _ H₂)) ]). Defined. Definition is_pregroupoid_iso_comma (HC₁ : is_pregroupoid C₁) (HC₂ : is_pregroupoid C₂) : is_pregroupoid iso_comma. Proof. intros x y f. apply is_z_iso_iso_comma. - apply HC₁. - apply HC₂. Defined. (** Univalence of the iso-comma category *) Definition is_univalent_disp_iso_comma_disp_cat (HC₃ : is_univalent C₃) : is_univalent_disp iso_comma_disp_cat. Proof. intros x y p i₁ i₂. induction p. use isweqimplimpl. - intros p. pose (pr1 p) as m. cbn in m. rewrite !functor_id in m. rewrite id_left, id_right in m. use subtypePath. { intro ; apply isaprop_is_z_isomorphism. } exact (!m). - apply isaset_z_iso. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_iso_comma (HC₁ : is_univalent C₁) (HC₂ : is_univalent C₂) (HC₃ : is_univalent C₃) : is_univalent iso_comma. Proof. use is_univalent_total_category. - apply is_univalent_category_binproduct. + exact HC₁. + exact HC₂. - exact (is_univalent_disp_iso_comma_disp_cat HC₃). Defined. (** Projection functors *) Definition iso_comma_pr1 : iso_comma ⟶ C₁ := pr1_category iso_comma_disp_cat ∙ pr1_functor C₁ C₂. Definition iso_comma_pr2 : iso_comma ⟶ C₂ := pr1_category iso_comma_disp_cat ∙ pr2_functor C₁ C₂. (** Natural isomorphism witnessing the commutation *) Definition iso_comma_commute_nat_trans_data : nat_trans_data (iso_comma_pr1 ∙ F) (iso_comma_pr2 ∙ G). Proof. intros x ; cbn in x. exact (pr2 x). Defined. Definition iso_comma_commute_is_nat_trans : is_nat_trans _ _ iso_comma_commute_nat_trans_data. Proof. intros x y f ; unfold iso_comma_commute_nat_trans_data ; cbn ; cbn in f. exact (pr2 f). Qed. Definition iso_comma_commute_nat_trans : iso_comma_pr1 ∙ F ⟹ iso_comma_pr2 ∙ G. Proof. use make_nat_trans. - exact iso_comma_commute_nat_trans_data. - exact iso_comma_commute_is_nat_trans. Defined. Definition iso_comma_commute : nat_z_iso (iso_comma_pr1 ∙ F) (iso_comma_pr2 ∙ G). Proof. use make_nat_z_iso. - exact iso_comma_commute_nat_trans. - intros x. apply z_iso_is_z_isomorphism. Defined. (** Mapping property of iso-comma category We need to check three mapping properties: - The first one gives the existence of a functor - The second one gives the existence of a natural transformation - The third one can be used to show that two natural transformations are equal *) Section UniversalMappingProperty. Context {D : category} (P : D ⟶ C₁) (Q : D ⟶ C₂) (η : nat_z_iso (P ∙ F) (Q ∙ G)). (** The functor witnessing the universal property *) Definition iso_comma_ump1_data : functor_data D iso_comma. Proof. use make_functor_data. - exact (λ d, (P d ,, Q d) ,, nat_z_iso_pointwise_z_iso η d). - exact (λ d₁ d₂ f, (#P f ,, #Q f) ,, nat_trans_ax η _ _ f). Defined. Definition iso_comma_ump1_is_functor : is_functor iso_comma_ump1_data. Proof. split. - intro x ; cbn. use subtypePath. { intro ; apply homset_property. } cbn. rewrite !functor_id. apply idpath. - intros x y z f g ; cbn. use subtypePath. { intro ; apply homset_property. } cbn. rewrite !functor_comp. apply idpath. Qed. Definition iso_comma_ump1 : D ⟶ iso_comma. Proof. use make_functor. - exact iso_comma_ump1_data. - exact iso_comma_ump1_is_functor. Defined. (** The computation rules *) Definition iso_comma_ump1_pr1_nat_trans_data : nat_trans_data (iso_comma_ump1 ∙ iso_comma_pr1) P := λ x, identity _. Definition iso_comma_ump1_pr1_is_nat_trans : is_nat_trans _ _ iso_comma_ump1_pr1_nat_trans_data. Proof. intros x y f ; cbn ; unfold iso_comma_ump1_pr1_nat_trans_data. rewrite id_left, id_right. apply idpath. Qed. Definition iso_comma_ump1_pr1_nat_trans : iso_comma_ump1 ∙ iso_comma_pr1 ⟹ P. Proof. use make_nat_trans. - exact iso_comma_ump1_pr1_nat_trans_data. - exact iso_comma_ump1_pr1_is_nat_trans. Defined. (** Computation rule for first projection *) Definition iso_comma_ump1_pr1 : nat_z_iso (iso_comma_ump1 ∙ iso_comma_pr1) P. Proof. use make_nat_z_iso. - exact iso_comma_ump1_pr1_nat_trans. - intro. apply identity_is_z_iso. Defined. Definition iso_comma_ump1_pr2_nat_trans_data : nat_trans_data (iso_comma_ump1 ∙ iso_comma_pr2) Q := λ x, identity _. Definition iso_comma_ump1_pr2_is_nat_trans : is_nat_trans _ _ iso_comma_ump1_pr2_nat_trans_data. Proof. intros x y f ; cbn ; unfold iso_comma_ump1_pr2_nat_trans_data. rewrite id_left, id_right. apply idpath. Qed. Definition iso_comma_ump1_pr2_nat_trans : iso_comma_ump1 ∙ iso_comma_pr2 ⟹ Q. Proof. use make_nat_trans. - exact iso_comma_ump1_pr2_nat_trans_data. - exact iso_comma_ump1_pr2_is_nat_trans. Defined. (** Computation rule for second projection *) Definition iso_comma_ump1_pr2 : nat_z_iso (iso_comma_ump1 ∙ iso_comma_pr2) Q. Proof. use make_nat_z_iso. - exact iso_comma_ump1_pr2_nat_trans. - intro. apply identity_is_z_iso. Defined. (** Computation rule for natural iso *) Definition iso_comma_ump1_commute : pre_whisker iso_comma_ump1 iso_comma_commute = nat_trans_comp _ _ _ (nat_trans_functor_assoc_inv _ _ _) (nat_trans_comp _ _ _ (post_whisker iso_comma_ump1_pr1 F) (nat_trans_comp _ _ _ η (nat_trans_comp _ _ _ (post_whisker (nat_z_iso_inv iso_comma_ump1_pr2) G) (nat_trans_functor_assoc _ _ _)))). Proof. use nat_trans_eq. { apply homset_property. } intro ; cbn ; unfold iso_comma_ump1_pr1_nat_trans_data. rewrite (functor_id F), (functor_id G). rewrite !id_left. rewrite id_right. apply idpath. Qed. (** Now we look at the second universal mapping property *) Context (Φ₁ Φ₂ : D ⟶ iso_comma) (τ₁ : Φ₁ ∙ iso_comma_pr1 ⟹ Φ₂ ∙ iso_comma_pr1) (τ₂ : Φ₁ ∙ iso_comma_pr2 ⟹ Φ₂ ∙ iso_comma_pr2) (p : ∏ (x : D), pr12 (Φ₁ x) · #G (τ₂ x) = #F (τ₁ x) · pr12 (Φ₂ x)). Definition iso_comma_ump2_nat_trans_data : nat_trans_data Φ₁ Φ₂. Proof. intro x. simple refine ((_ ,, _) ,, _) ; cbn. - exact (τ₁ x). - exact (τ₂ x). - abstract (exact (!(p x))). Defined. Definition iso_comma_ump2_is_nat_trans : is_nat_trans _ _ iso_comma_ump2_nat_trans_data. Proof. intros x y f. use eq_iso_comma_mor. - exact (nat_trans_ax τ₁ _ _ f). - exact (nat_trans_ax τ₂ _ _ f). Qed. Definition iso_comma_ump2 : Φ₁ ⟹ Φ₂. Proof. use make_nat_trans. - exact iso_comma_ump2_nat_trans_data. - exact iso_comma_ump2_is_nat_trans. Defined. (** The computation rules *) Definition iso_comma_ump2_pr1 : post_whisker iso_comma_ump2 iso_comma_pr1 = τ₁. Proof. use nat_trans_eq. { intro ; apply homset_property. } intro x ; cbn. apply idpath. Qed. Definition iso_comma_ump2_pr2 : post_whisker iso_comma_ump2 iso_comma_pr2 = τ₂. Proof. use nat_trans_eq. { intro ; apply homset_property. } intro x ; cbn. apply idpath. Qed. (** The uniqueness *) Context {n₁ n₂ : Φ₁ ⟹ Φ₂} (n₁_pr1 : post_whisker n₁ iso_comma_pr1 = τ₁) (n₁_pr2 : post_whisker n₁ iso_comma_pr2 = τ₂) (n₂_pr1 : post_whisker n₂ iso_comma_pr1 = τ₁) (n₂_pr2 : post_whisker n₂ iso_comma_pr2 = τ₂). Definition iso_comma_ump_eq : n₁ = n₂. Proof. use nat_trans_eq. { apply homset_property. } intro x. use eq_iso_comma_mor. - pose (nat_trans_eq_pointwise n₁_pr1 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr1 x) as q₂. cbn in q₁, q₂. exact (q₁ @ !q₂). - pose (nat_trans_eq_pointwise n₁_pr2 x) as q₁. pose (nat_trans_eq_pointwise n₂_pr2 x) as q₂. cbn in q₁, q₂. exact (q₁ @ !q₂). Qed. End UniversalMappingProperty. End IsoCommaCategory. Definition univalent_iso_comma {C₁ C₂ C₃ : univalent_category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃) : univalent_category. Proof. use make_univalent_category. - exact (iso_comma F G). - apply is_univalent_iso_comma. + exact (pr2 C₁). + exact (pr2 C₂). + exact (pr2 C₃). Defined. (** Essentially surjective functors are closed under pullback *) Definition iso_comma_essentially_surjective {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (HF : essentially_surjective F) (G : C₂ ⟶ C₃) : essentially_surjective (iso_comma_pr2 F G). Proof. intros y. use (factor_through_squash _ _ (HF (G y))). - apply isapropishinh. - intros x. induction x as [ x i ]. apply hinhpr. simple refine (((_ ,, _) ,, _) ,, _) ; cbn. + exact x. + exact y. + exact i. + apply identity_z_iso. Defined. UniMath-20231010/UniMath/CategoryTheory/LatticeObject.v000066400000000000000000000314511451125700300225330ustar00rootroot00000000000000(** ***************************************************************************** Internal lattice objects in a category Contents: - Lattice objects ([latticeob]) - Bounded lattice objects ([bounded_latticeob]) - Proof that a subobject of a (bounded) lattice object is a lattice object ([sublatticeob], [sub_bounded_latticeob]) Based on "Sheaves in Geometry and Logic" by Mac Lane and Moerdijk (Section IV.8, page 198) Written by: Anders Mörtberg, 2017 *********************************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.Monoids. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. (** * Definition of lattice objects and bounded lattice objects *) Section LatticeObject_def. Context {C : category} {BPC : BinProducts C}. Local Notation "c ⊗ d" := (BinProductObject C (BPC c d)) : cat. Local Notation "f '××' g" := (BinProductOfArrows _ _ _ f g) (at level 80) : cat. Local Notation "1" := (identity _) : cat. Let π1 {x y} : C⟦x ⊗ y,x⟧ := BinProductPr1 _ (BPC x y). Let π2 {x y} : C⟦x ⊗ y,y⟧ := BinProductPr2 _ (BPC x y). Definition binprod_assoc (x y z : C) : C⟦(x ⊗ y) ⊗ z,x ⊗ (y ⊗ z)⟧ := BinProductArrow _ _ (π1 · π1) (BinProductArrow _ _ (π1 · π2) π2). Let α {x y z} : C⟦(x ⊗ y) ⊗ z,x ⊗ (y ⊗ z)⟧ := binprod_assoc x y z. Definition binprod_delta (x : C) : C⟦x,x ⊗ x⟧ := BinProductArrow _ _ (identity x) (identity x). Let δ {x} : C⟦x,x ⊗ x⟧ := binprod_delta x. Definition binprod_swap (x y : C) : C⟦x ⊗ y,y ⊗ x⟧ := BinProductArrow _ _ (BinProductPr2 _ _) (BinProductPr1 _ _). Let τ {x y} : C⟦x ⊗ y,y ⊗ x⟧ := binprod_swap x y. (** Equation witnessing that a morphism representing a binary operation is associative as illustrated by the diagram: << f×1 (L ⊗ L) ⊗ L -------> L ⊗ L | | α | | V | L ⊗ (L ⊗ L) | f | | 1×f | | V V L ⊗ L -----------> L f >> *) Definition isassoc_cat {L} (f : C⟦L ⊗ L,L⟧) : UU := (f ×× 1) · f = α · (1 ×× f) · f. (** Equation witnessing that a morphism representing a binary operation is commutative as illustrated by the diagram: << L ⊗ L | \ | \ τ | \ f | \ | V L ⊗ L -----> L f >> *) Definition iscomm_cat {L} (f : C⟦L ⊗ L,L⟧) : UU := f = τ · f. (** Equation witnessing the absorbtion law as illustrated by the diagram: << δ×1 α L ⊗ L ------> (L ⊗ L) ⊗ L -------> L ⊗ (L ⊗ L) | | π1 | | 1×g V V L <------------------------------- L ⊗ L f >> If f is ∧ and g is ∨ this expresses: x ∧ (x ∨ y) = x *) Definition isabsorb_cat {L} (f g : C⟦L ⊗ L,L⟧) : UU := (δ ×× 1) · α · (1 ×× g) · f = π1. Definition latticeop_cat {L} (meet_mor join_mor : C⟦L ⊗ L,L⟧) := (isassoc_cat meet_mor × iscomm_cat meet_mor) × (isassoc_cat join_mor × iscomm_cat join_mor) × (isabsorb_cat meet_mor join_mor × isabsorb_cat join_mor meet_mor). (** A lattice object L has operation meet and join satisfying the above laws *) Definition latticeob (L : C) : UU := ∑ (meet_mor join_mor : C⟦L ⊗ L,L⟧), latticeop_cat meet_mor join_mor. Definition make_latticeob {L : C} {meet_mor join_mor : C⟦L ⊗ L,L⟧} : latticeop_cat meet_mor join_mor → latticeob L := λ (isL : latticeop_cat meet_mor join_mor), meet_mor,, join_mor ,, isL. Definition meet_mor {L : C} (isL : latticeob L) : C⟦L ⊗ L,L⟧ := pr1 isL. Definition join_mor {L : C} (isL : latticeob L) : C⟦L ⊗ L,L⟧ := pr1 (pr2 isL). (** Bounded lattice objects *) Context {TC : Terminal C}. Let ι {x : C} : C⟦x,TC ⊗ x⟧ := BinProductArrow _ _ (TerminalArrow _ _) (identity x). (** Given u : C⟦TC,L⟧ the equation witnessing the left unit law is given by the diagram: << ι L ------> 1 ⊗ L | | 1 | | u×1 V V L <------ L ⊗ L f >> *) Definition islunit_cat {L} (f : C⟦L ⊗ L,L⟧) (u : C⟦TC,L⟧) : UU := ι · (u ×× 1) · f = 1. Definition bounded_latticeop_cat {L} (l : latticeob L) (bot top : C⟦TC,L⟧) := (islunit_cat (join_mor l) bot) × (islunit_cat (meet_mor l) top). Definition bounded_latticeob (L : C) : UU := ∑ (l : latticeob L) (bot top : C⟦TC,L⟧), bounded_latticeop_cat l bot top. Definition make_bounded_latticeob {L} {l : latticeob L} {bot top : C⟦TC,L⟧} : bounded_latticeop_cat l bot top → bounded_latticeob L := λ bl, l,, bot,, top,, bl. Definition bounded_latticeob_to_latticeob X : bounded_latticeob X → latticeob X := pr1. Coercion bounded_latticeob_to_latticeob : bounded_latticeob >-> latticeob. Definition bot_mor {L} (isL : bounded_latticeob L) : C⟦TC,L⟧ := pr1 (pr2 isL). Definition top_mor {L} (isL : bounded_latticeob L) : C⟦TC,L⟧ := pr1 (pr2 (pr2 isL)). End LatticeObject_def. Arguments latticeob {_} _ _. Arguments bounded_latticeob {_} _ _ _. Section LatticeObject_accessors. Context {C : category} (BPC : BinProducts C) {L : C} (isL : latticeob BPC L). Definition isassoc_meet_mor : isassoc_cat (meet_mor isL) := pr1 (pr1 (pr2 (pr2 isL))). Definition iscomm_meet_mor : iscomm_cat (meet_mor isL) := pr2 (pr1 (pr2 (pr2 isL))). Definition isassoc_join_mor : isassoc_cat (join_mor isL) := pr1 (pr1 (pr2 (pr2 (pr2 isL)))). Definition iscomm_join_mor : iscomm_cat (join_mor isL) := pr2 (pr1 (pr2 (pr2 (pr2 isL)))). Definition meet_mor_absorb_join_mor : isabsorb_cat (meet_mor isL) (join_mor isL) := pr1 (pr2 (pr2 (pr2 (pr2 isL)))). Definition join_mor_absorb_meet_mor : isabsorb_cat (join_mor isL) (meet_mor isL) := pr2 (pr2 (pr2 (pr2 (pr2 isL)))). End LatticeObject_accessors. Section BoundedLatticeObject_accessors. Context {C : category} (BPC : BinProducts C) (TC : Terminal C). Context {L : C} (l : bounded_latticeob BPC TC L). Definition islunit_join_mor_bot_mor : islunit_cat (join_mor l) (bot_mor l) := pr1 (pr2 (pr2 (pr2 l))). Definition islunit_meet_mor_top_mor : islunit_cat (meet_mor l) (top_mor l) := pr2 (pr2 (pr2 (pr2 l))). End BoundedLatticeObject_accessors. (** * Definition of sublattice objects *) Section SublatticeObject. Context {C : category} (BPC : BinProducts C) {M L : C}. Context {i : C⟦M,L⟧} (Hi : isMonic i) (l : latticeob BPC L). Local Notation "c ⊗ d" := (BinProductObject C (BPC c d)) : cat. Local Notation "f '××' g" := (BinProductOfArrows _ _ _ f g) (at level 90) : cat. (** This asserts that i is a lattice homomorphism internally *) Context {meet_mor_M : C⟦M ⊗ M,M⟧} (Hmeet : meet_mor_M · i = (i ×× i) · meet_mor l). Context {join_mor_M : C⟦M ⊗ M,M⟧} (Hjoin : join_mor_M · i = (i ×× i) · join_mor l). Local Lemma identity_comm : identity M · i = i · identity L. Proof. rewrite id_left, id_right. reflexivity. Qed. Local Lemma binprod_assoc_comm : ((i ×× i) ×× i) · @binprod_assoc _ BPC L L L = @binprod_assoc _ BPC M M M · (i ×× (i ×× i)). Proof. unfold binprod_assoc; rewrite postcompWithBinProductArrow. apply BinProductArrowUnique. - rewrite <-assoc, BinProductPr1Commutes. rewrite assoc, BinProductOfArrowsPr1, <- assoc, BinProductOfArrowsPr1, assoc. reflexivity. - rewrite postcompWithBinProductArrow. apply BinProductArrowUnique. + etrans; [ apply cancel_postcomposition; rewrite <-assoc; apply maponpaths, BinProductPr2Commutes |]. rewrite <- assoc, BinProductPr1Commutes. rewrite assoc, BinProductOfArrowsPr1, <- assoc, BinProductOfArrowsPr2, assoc. reflexivity. + etrans; [ apply cancel_postcomposition; rewrite <-assoc; apply maponpaths, BinProductPr2Commutes |]. rewrite <- assoc, BinProductPr2Commutes, BinProductOfArrowsPr2. reflexivity. Qed. Local Lemma binprod_delta_comm : i · @binprod_delta _ BPC L = @binprod_delta _ BPC M · (i ×× i). Proof. unfold binprod_delta; rewrite postcompWithBinProductArrow. apply BinProductArrowUnique. - rewrite <-assoc, BinProductPr1Commutes, identity_comm. reflexivity. - rewrite <-assoc, BinProductPr2Commutes, identity_comm. reflexivity. Qed. Local Lemma isassoc_cat_comm {f : C⟦M ⊗ M,M⟧} {g : C⟦L ⊗ L,L⟧} (Hfg : f · i = (i ×× i) · g) : isassoc_cat g → isassoc_cat f. Proof. unfold isassoc_cat; intros H; apply Hi. rewrite <-!assoc, !Hfg, !assoc, BinProductOfArrows_comp, Hfg, <- !assoc, identity_comm. rewrite <- BinProductOfArrows_comp, <- assoc, H, !assoc. apply cancel_postcomposition. rewrite <-!assoc, BinProductOfArrows_comp, Hfg, identity_comm. rewrite <- BinProductOfArrows_comp, !assoc, binprod_assoc_comm. reflexivity. Qed. Local Lemma iscomm_cat_comm {f : C⟦M ⊗ M,M⟧} {g : C⟦L ⊗ L,L⟧} (Hfg : f · i = (i ×× i) · g) : iscomm_cat g → iscomm_cat f. Proof. unfold iscomm_cat; intros H; apply Hi. rewrite <- !assoc, !Hfg. etrans; [eapply maponpaths, H|]. rewrite !assoc; apply cancel_postcomposition. unfold binprod_swap; rewrite postcompWithBinProductArrow. apply BinProductArrowUnique; rewrite <- assoc. * now rewrite BinProductPr1Commutes, BinProductOfArrowsPr2. * now rewrite BinProductPr2Commutes, BinProductOfArrowsPr1. Qed. Local Lemma isabsorb_cat_comm {f1 f2 : C⟦M ⊗ M,M⟧} {g1 g2 : C⟦L ⊗ L,L⟧} (Hfg1 : f1 · i = (i ×× i) · g1) (Hfg2 : f2 · i = (i ×× i) · g2) : isabsorb_cat g1 g2 → isabsorb_cat f1 f2. Proof. unfold isabsorb_cat; intros H; apply Hi. assert (HH : BinProductPr1 C (BPC M M) · i = (i ×× i) · BinProductPr1 C (BPC L L)). { now rewrite BinProductOfArrowsPr1. } rewrite HH, <- H, <-!assoc, Hfg1, !assoc. apply cancel_postcomposition. rewrite <-!assoc, BinProductOfArrows_comp, Hfg2, identity_comm, !assoc. rewrite BinProductOfArrows_comp, <-identity_comm, binprod_delta_comm. etrans; [| eapply pathsinv0; do 2 apply cancel_postcomposition; now rewrite <-BinProductOfArrows_comp]. rewrite <-!assoc; apply maponpaths. rewrite assoc, binprod_assoc_comm, <-assoc; apply maponpaths. now rewrite identity_comm, BinProductOfArrows_comp. Qed. Definition sub_latticeob : latticeob BPC M. Proof. use make_latticeob. - apply meet_mor_M. - apply join_mor_M. - repeat split. + now apply (isassoc_cat_comm Hmeet), (isassoc_meet_mor _ l). + now apply (iscomm_cat_comm Hmeet), (iscomm_meet_mor _ l). + now apply (isassoc_cat_comm Hjoin), (isassoc_join_mor _ l). + now apply (iscomm_cat_comm Hjoin), (iscomm_join_mor _ l). + now apply (isabsorb_cat_comm Hmeet Hjoin), (meet_mor_absorb_join_mor _ l). + now apply (isabsorb_cat_comm Hjoin Hmeet), (join_mor_absorb_meet_mor _ l). Defined. End SublatticeObject. Section SubboundedlatticeObject. Context {C : category} (BPC : BinProducts C) (TC : Terminal C). Context {M L : C} {i : C⟦M,L⟧} (Hi : isMonic i) (l : bounded_latticeob BPC TC L). Local Notation "c ⊗ d" := (BinProductObject C (BPC c d)) : cat. Local Notation "f '××' g" := (BinProductOfArrows _ _ _ f g) (at level 90) : cat. Context {meet_mor_M : C⟦M ⊗ M,M⟧} (Hmeet : meet_mor_M · i = (i ×× i) · meet_mor l). Context {join_mor_M : C⟦M ⊗ M,M⟧} (Hjoin : join_mor_M · i = (i ×× i) · join_mor l). Context {bot_mor_M : C⟦TC,M⟧} (Hbot : bot_mor_M · i = bot_mor l). Context {top_mor_M : C⟦TC,M⟧} (Htop : top_mor_M · i = top_mor l). Lemma islunit_cat_comm {fM : C⟦M ⊗ M,M⟧} {fL : C⟦L ⊗ L,L⟧} (Hf : fM · i = (i ×× i) · fL) {gM : C ⟦TC,M⟧} {gL : C⟦TC,L⟧} (Hg : gM · i = gL) : islunit_cat fL gL → islunit_cat fM gM. Proof. unfold islunit_cat; intros H; apply Hi. rewrite <-!assoc. etrans; [ do 2 apply maponpaths; apply Hf |]. rewrite identity_comm, <-H, postcompWithBinProductArrow, !assoc. apply cancel_postcomposition. rewrite !postcompWithBinProductArrow, <-assoc, Hg, !id_left. apply pathsinv0, BinProductArrowUnique. - rewrite <- assoc, BinProductPr1Commutes, assoc. now apply cancel_postcomposition, TerminalArrowUnique. - now rewrite <- assoc, BinProductPr2Commutes, id_right. Qed. Definition sub_bounded_latticeob : bounded_latticeob BPC TC M. Proof. use make_bounded_latticeob. - exact (sub_latticeob BPC Hi l Hmeet Hjoin). - exact bot_mor_M. - exact top_mor_M. - split. + now apply (islunit_cat_comm Hjoin Hbot), (islunit_join_mor_bot_mor BPC TC l). + now apply (islunit_cat_comm Hmeet Htop), (islunit_meet_mor_top_mor BPC TC l). Defined. End SubboundedlatticeObject. UniMath-20231010/UniMath/CategoryTheory/LeftKanExtension.v000066400000000000000000000401401451125700300232330ustar00rootroot00000000000000(*********************************************************************** Left Kan extensions In this file, we define left Kan extensions of functors. In addition, we construct a left adjoint to the precomposition functor. To define the left Kan extension, we use the pointwise formula for it, which defines it as a conical colimit. Contents 1. Pointwise definition of the left Kan extension 1.1. Action on objects 1.2. Action on morphisms 1.3. Functoriality 1.4. Definition of the left Kan extension 1.5. Natural transformation that witnesses commutation (the unit) 2. Left Kan extension of natural transformations 2.1. Extending transformations 2.2. Naturality of unit 3. Functoriality of assigning the left Kan extension 4. Adjunction coming from left Kan extensions 4.1. The left adjoint (left Kan extension) 4.2. The unit 4.3. The counit 4.4. The triangles 4.5. The adjunction ***********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.CommaCategories. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. (** 1. Pointwise definition of the left Kan extension Note: we assume `C₁` below to be small. *) Section LeftKanExtension. Context {C₁ C₂ D : category} (ColimsD : Colims D) (P : C₁ ⟶ C₂) (F : C₁ ⟶ D). (** 1.1. Action on objects *) Definition lan_comma (x : C₂) : category := comma P (constant_functor unit_category _ x). Definition lan_pr (x : C₂) : lan_comma x ⟶ D := comma_pr1 _ _ ∙ F. Definition lan_colim (x : C₂) : ColimCocone (diagram_from_functor (lan_comma x) D (lan_pr x)) := ColimsD _ (diagram_from_functor _ _ (lan_pr x)). Definition lan_point (x : C₂) : D := colim (lan_colim x). (** 1.2. Action on morphisms *) Section LanMor. Context {x y : C₂} (f : x --> y). Definition lan_mor_cocone_ob (z : C₁) (h : P z --> x) : F z --> lan_point y := colimIn (lan_colim y) ((z ,, tt) ,, h · f). Definition lan_mor_forms_cocone {z₁ z₂ : C₁} (h₁ : P z₁ --> x) (h₂ : P z₂ --> x) (e : z₁ --> z₂) (p : h₁ = # P e · h₂) : # F e · lan_mor_cocone_ob z₂ h₂ = lan_mor_cocone_ob z₁ h₁. Proof. refine (colimInCommutes (lan_colim y) ((z₁ ,, tt) ,, h₁ · f) ((z₂ ,, tt) ,, h₂ · f) ((e ,, idpath _) ,, _)). abstract (cbn ; rewrite id_right ; rewrite !assoc ; apply maponpaths_2 ; exact p). Defined. Definition lan_mor : D ⟦ lan_point x , lan_point y ⟧. Proof. refine (colim_mor (lan_colim x) (lan_point y) (λ v, lan_mor_cocone_ob (pr11 v) (pr2 v)) (λ v₁ v₂ e, lan_mor_forms_cocone (pr2 v₁) (pr2 v₂) (pr11 e) _)). abstract (exact(!(id_right _) @ pr2 e)). Defined. Definition lan_mor_colimIn (w : C₁) (h : P w --> x) (a : unit) : colimIn (lan_colim x) ((w ,, a) ,, h) · lan_mor = colimIn (lan_colim y) ((w ,, a) ,, h · f). Proof. induction a. unfold lan_mor. rewrite colim_mor_commute. apply idpath. Qed. End LanMor. Definition lan_data : functor_data C₂ D. Proof. use make_functor_data. - exact lan_point. - exact @lan_mor. Defined. (** 1.3. Functoriality *) Definition lan_is_functor : is_functor lan_data. Proof. split. - intros x ; cbn. use colim_mor_eq. intros v. rewrite id_right. refine (lan_mor_colimIn (identity x) (pr11 v) (pr2 v) _ @ _). rewrite id_right. apply idpath. - intros x y z f g. cbn. use colim_mor_eq. intros v. rewrite !assoc. etrans. { apply lan_mor_colimIn. } refine (!_). etrans. { apply maponpaths_2. apply lan_mor_colimIn. } etrans. { apply (lan_mor_colimIn g (pr11 v) (pr2 v · f)). } rewrite !assoc'. apply idpath. Qed. (** 1.4. Definition of the left Kan extension *) Definition lan : C₂ ⟶ D. Proof. use make_functor. - exact lan_data. - exact lan_is_functor. Defined. (** 1.5. Natural transformation that witnesses commutation *) Definition lan_commute_data : nat_trans_data F (P ∙ lan) := λ x, colimIn (lan_colim (P x)) ((x ,, tt) ,, identity _). Definition lan_commute_is_nat_trans : is_nat_trans F (P ∙ lan) lan_commute_data. Proof. intros x y f. cbn. refine (!_). etrans. { exact (lan_mor_colimIn (#P f) x (identity _) _). } rewrite id_left. exact (!(colimInCommutes (lan_colim (P y)) ((x ,, tt) ,, #P f) ((y ,, tt) ,, identity _) ((f ,, idpath _) ,, idpath _))). Qed. Definition lan_commute : F ⟹ P ∙ lan. Proof. use make_nat_trans. - exact lan_commute_data. - exact lan_commute_is_nat_trans. Defined. End LeftKanExtension. (** 2. Left Kan extension of natural transformations *) Section LeftKanExtensionNatTrans. Context {C₁ C₂ D : category} (ColimsD : Colims D) (P : C₁ ⟶ C₂) {F G : C₁ ⟶ D} (τ : F ⟹ G). (** 2.1. Extending transformations *) Definition lan_nat_trans_data_cocone_ob (x : C₂) (w : C₁) (h : P w --> x) : F w --> lan_point ColimsD P G x := τ w · colimIn (lan_colim ColimsD P G x) ((w ,, tt) ,, h). Definition lan_nat_trans_data_cocone_forms_cocone {x : C₂} {w₁ w₂ : C₁} {h₁ : P w₁ --> x} {h₂ : P w₂ --> x} {e : w₁ --> w₂} (p : h₁ · identity _ = #P e · h₂) : # F e · lan_nat_trans_data_cocone_ob x w₂ h₂ = lan_nat_trans_data_cocone_ob x w₁ h₁. Proof. unfold lan_nat_trans_data_cocone_ob. rewrite !assoc. etrans. { apply maponpaths_2. exact (nat_trans_ax τ _ _ e). } rewrite !assoc'. apply maponpaths. exact (colimInCommutes (lan_colim ColimsD P G x) ((w₁,, tt),, h₁) ((w₂,, tt),, h₂) ((e ,, idpath _) ,, p)). Qed. Definition lan_nat_trans_data : nat_trans_data (lan ColimsD P F) (lan ColimsD P G) := λ x, colim_mor (lan_colim ColimsD P F x) _ (λ v, lan_nat_trans_data_cocone_ob x (pr11 v) (pr2 v)) (λ _ _ e, lan_nat_trans_data_cocone_forms_cocone (pr2 e)). Definition lan_nat_trans_colimIn (x : C₂) (w : C₁) (h : P w --> x) (a : unit) : colimIn (lan_colim ColimsD P F x) ((w ,, a) ,, h) · lan_nat_trans_data x = τ w · colimIn (lan_colim ColimsD P G x) ((w ,, a) ,, h). Proof. unfold lan_nat_trans_data. induction a. rewrite colim_mor_commute. apply idpath. Qed. Definition lan_nat_trans_is_nat_trans : is_nat_trans _ _ lan_nat_trans_data. Proof. intros x y f ; cbn. use colim_mor_eq. intros v. rewrite !assoc. etrans. { apply maponpaths_2. apply lan_mor_colimIn. } etrans. { apply (lan_nat_trans_colimIn y (pr11 v) (pr2 v · f)). } refine (!_). etrans. { apply maponpaths_2. apply lan_nat_trans_colimIn. } rewrite !assoc'. etrans. { apply maponpaths. apply lan_mor_colimIn. } apply idpath. Qed. Definition lan_nat_trans : lan ColimsD P F ⟹ lan ColimsD P G. Proof. use make_nat_trans. - exact lan_nat_trans_data. - exact lan_nat_trans_is_nat_trans. Defined. (** 2.2. Naturality of unit *) Definition lan_commute_natural : nat_trans_comp _ _ _ τ (lan_commute ColimsD P G) = nat_trans_comp _ _ _ (lan_commute ColimsD P F) (pre_whisker P (lan_nat_trans )). Proof. use nat_trans_eq. { apply homset_property. } intro x ; cbn. unfold lan_commute_data. refine (!_). apply lan_nat_trans_colimIn. Qed. End LeftKanExtensionNatTrans. (** 3. Functoriality of assigning the left Kan extension *) Definition lan_nat_trans_id {C₁ C₂ D : category} (ColimsD : Colims D) (P : C₁ ⟶ C₂) (F : C₁ ⟶ D) : lan_nat_trans ColimsD P (nat_trans_id F) = nat_trans_id _. Proof. use nat_trans_eq. { apply homset_property. } intro x. use colim_mor_eq. intro v. etrans. { apply lan_nat_trans_colimIn. } exact (id_left _ @ !(id_right _)). Qed. Definition lan_nat_trans_comp {C₁ C₂ D : category} (ColimsD : Colims D) (P : C₁ ⟶ C₂) {F G H : C₁ ⟶ D} (τ₁ : F ⟹ G) (τ₂ : G ⟹ H) : lan_nat_trans ColimsD P (nat_trans_comp _ _ _ τ₁ τ₂) = nat_trans_comp _ _ _ (lan_nat_trans ColimsD P τ₁) (lan_nat_trans ColimsD P τ₂). Proof. use nat_trans_eq. { apply homset_property. } intro x. use colim_mor_eq. intro v. etrans. { apply lan_nat_trans_colimIn. } refine (_ @ assoc' _ _ _). refine (!_). etrans. { apply maponpaths_2. apply lan_nat_trans_colimIn. } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. apply lan_nat_trans_colimIn. } apply assoc. Qed. (** 4. Adjunction coming from left Kan extensions *) Section LeftKanExtensionAdjunction. Context {C₁ C₂ D : category} (ColimsD : Colims D) (P : C₁ ⟶ C₂). (** 4.1. The left adjoint (left Kan extension) *) Definition lan_functor_data : functor_data [ C₁ , D ] [ C₂ , D ]. Proof. use make_functor_data. - exact (λ F, lan ColimsD P F). - exact (λ _ _ τ, lan_nat_trans ColimsD P τ). Defined. Definition lan_functor_is_functor : is_functor lan_functor_data. Proof. split. - intro ; intros. apply lan_nat_trans_id. - intro ; intros. apply lan_nat_trans_comp. Qed. Definition lan_functor : [ C₁ , D ] ⟶ [ C₂ , D ]. Proof. use make_functor. - exact lan_functor_data. - exact lan_functor_is_functor. Defined. (** 4.2. The unit *) Definition lan_precomposition_unit : functor_identity _ ⟹ lan_functor ∙ pre_comp_functor P. Proof. use make_nat_trans. - exact (λ F, lan_commute ColimsD P F). - exact (λ F G τ, lan_commute_natural ColimsD P τ). Defined. (** 4.3. The counit *) Definition lan_precomposition_counit_point (F : C₂ ⟶ D) (x : C₂) : lan_point ColimsD P (P ∙ F) x --> F x. Proof. use colim_mor. - exact (λ v, #F (pr2 v)). - abstract (intros v₁ v₂ e ; refine (!(functor_comp F _ _) @ maponpaths (λ z, #F z) _) ; exact (!(pr2 e) @ id_right _)). Defined. Definition lan_precomposition_counit_point_colimIn (F : C₂ ⟶ D) (x : C₂) (w : C₁) (f : P w --> x) (a : unit) : colimIn (lan_colim ColimsD P (P ∙ F) x) ((w ,, a) ,, f) · lan_precomposition_counit_point F x = #F f. Proof. etrans. { apply colim_mor_commute. } apply idpath. Qed. Definition lan_precomposition_counit_natural (F : C₂ ⟶ D) {x y : C₂} (f : x --> y) : lan_mor ColimsD P (P ∙ F) f · lan_precomposition_counit_point F y = lan_precomposition_counit_point F x · # F f. Proof. use colim_mor_eq. intros v. rewrite !assoc. etrans. { apply maponpaths_2. apply lan_mor_colimIn. } rewrite lan_precomposition_counit_point_colimIn. etrans. { apply (lan_precomposition_counit_point_colimIn F y (pr11 v) (pr2 v · f)). } apply (functor_comp F). Qed. Definition lan_precomposition_counit_data (F : C₂ ⟶ D) : lan_data ColimsD P (P ∙ F) ⟹ F. Proof. use make_nat_trans. - exact (lan_precomposition_counit_point F). - exact (@lan_precomposition_counit_natural F). Defined. Definition lan_precomposition_counit_natural_trans {F G : C₂ ⟶ D} (τ : F ⟹ G) : nat_trans_comp _ _ _ (lan_nat_trans ColimsD P (pre_whisker P τ : P ∙ F ⟹ P ∙ G)) (lan_precomposition_counit_data G) = nat_trans_comp _ _ _ (lan_precomposition_counit_data F) τ. Proof. use nat_trans_eq. { apply homset_property. } intro x. use colim_mor_eq. intro v ; cbn -[comma]. rewrite !assoc. etrans. { apply maponpaths_2. apply (lan_nat_trans_colimIn ColimsD P (pre_whisker P τ : P ∙ F ⟹ P ∙ G)). } refine (!_). etrans. { apply maponpaths_2. apply lan_precomposition_counit_point_colimIn. } refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply lan_precomposition_counit_point_colimIn. } refine (!_). apply (nat_trans_ax τ). Qed. Definition lan_precomposition_counit : pre_comp_functor P ∙ lan_functor ⟹ functor_identity _. Proof. use make_nat_trans. - exact lan_precomposition_counit_data. - exact @lan_precomposition_counit_natural_trans. Defined. (** 4.4. The triangles *) Definition lan_precomposition_triangle_1 (F : C₁ ⟶ D) : nat_trans_comp _ _ _ (lan_nat_trans ColimsD P (lan_commute ColimsD P F)) (lan_precomposition_counit_data (lan ColimsD P F)) = nat_trans_id (lan_data ColimsD P F). Proof. use nat_trans_eq. { apply homset_property. } intro x. use colim_mor_eq. intro v ; cbn -[comma]. refine (assoc _ _ _ @ _ @ !(id_right _)). etrans. { apply maponpaths_2. apply lan_nat_trans_colimIn. } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. apply (lan_precomposition_counit_point_colimIn (lan ColimsD P F)). } etrans. { exact (lan_mor_colimIn ColimsD P F (pr2 v) (pr11 v) (identity _) tt). } induction v as [ v₁ v₃ ]. induction v₁ as [ v₁ v₂ ]. induction v₂. cbn. rewrite id_left. apply idpath. Qed. Definition lan_precomposition_triangle_2 (F : C₂ ⟶ D) : nat_trans_comp _ _ _ (lan_commute ColimsD P (P ∙ F)) (pre_whisker P (lan_precomposition_counit_data F)) = nat_trans_id (functor_composite_data P F). Proof. use nat_trans_eq. { apply homset_property. } intro x. cbn. etrans. { apply lan_precomposition_counit_point_colimIn. } apply functor_id. Qed. (** 4.5. The adjunction *) Definition lan_precomposition_are_adjoints : are_adjoints lan_functor (pre_comp_functor P). Proof. simple refine ((_ ,, _) ,, (_ ,, _)). - exact lan_precomposition_unit. - exact lan_precomposition_counit. - exact lan_precomposition_triangle_1. - exact lan_precomposition_triangle_2. Defined. Definition is_right_adjoint_precomposition : is_right_adjoint (pre_comp_functor P) := lan_functor ,, lan_precomposition_are_adjoints. End LeftKanExtensionAdjunction. UniMath-20231010/UniMath/CategoryTheory/LocalizingClass.v000066400000000000000000002350761451125700300231110ustar00rootroot00000000000000(** * Localizing class *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Require Import UniMath.CategoryTheory.Core.Functors. (** * Localizing class and localization of categories. In this section we define localization of categories when the collection of morphisms forms so called localizing class. The axioms of localizing class S are the following - every identity morphism must be in the collection - if f and g are in S, then so is f · g - Suppose we morphisms s : X --> Y and f : Z --> Y such that s in in S. Then we can find a square, that is morphisms, s' : W --> Z and f' : W --> X, such that s' in in S and we have s' · f = f' · s. - Dual version of the previous. Suppose s : X --> Y and f : X --> Z such that s in in S. Then we can find a square, that is morphisms, s' : Z --> W and f' : Y --> W, such that s' is in S and we have s' · f = f' · s. - Suppose we have a morphism s : X --> Y contained in S and two morphisms f g : Y --> Z such that s · f = s · g. Then S contains a morphism s' such that f · s' = f · s'. - Dual of the above. Suppose we have a morphism s : Z --> W in S and two morphisms f g : Y --> Z such that f · s = g · s. Then we can find a morphism s' in S such that s' · f = s' · g. *) Section def_roofs. Variable C : precategory. Hypothesis hs : has_homsets C. Definition SubsetsOfMors : UU := ∏ (x y : ob C), hsubtype (make_hSet (C⟦x, y⟧) (hs x y)). (** ** Localizing classes *) (** *** Identities and compositions are in the subset of morphisms *) Definition isLocalizingClass1 (SOM : SubsetsOfMors) : UU := (∏ (x : ob C), SOM x x (identity x)) × (∏ (x y z : ob C) (f : x --> y) (e1 : SOM x y f) (g : y --> z) (e2 : SOM y z g), SOM x z (f · g)). Definition isLocClassIs {SOM : SubsetsOfMors} (H : isLocalizingClass1 SOM) : ∏ (x : ob C), SOM x x (identity x) := pr1 H. Definition isLocClassComp {SOM : SubsetsOfMors} (H : isLocalizingClass1 SOM) : ∏ (x y z : ob C) (f : x --> y) (e1 : SOM x y f) (g : y --> z) (e2 : SOM y z g), SOM x z (f · g) := pr2 H. (** **** Squares *) Definition LocSqr1 (SOM : SubsetsOfMors) {x y z : ob C} (s : x --> y) (e1 : SOM x y s) (f : x --> z) : UU := ∑ D : (∑ (w : ob C), C⟦y, w⟧ × C⟦z, w⟧), (SOM z (pr1 D) (dirprod_pr2 (pr2 D))) × (s · (dirprod_pr1 (pr2 D)) = f · (dirprod_pr2 (pr2 D))). Definition LocSqr1Ob {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e1 : SOM x y s} {f : x --> z} (LS1 : LocSqr1 SOM s e1 f) : ob C := pr1 (pr1 LS1). Coercion LocSqr1Ob : LocSqr1 >-> ob. Definition LocSqr1Mor1 {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e1 : SOM x y s} {f : x --> z} (LS1 : LocSqr1 SOM s e1 f) : C⟦y, LS1⟧ := dirprod_pr1 (pr2 (pr1 LS1)). Definition LocSqr1Mor2 {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e1 : SOM x y s} {f : x --> z} (LS1 : LocSqr1 SOM s e1 f) : C⟦z, LS1⟧ := dirprod_pr2 (pr2 (pr1 LS1)). Definition LocSqr1Mor2Is {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e1 : SOM x y s} {f : x --> z} (LS1 : LocSqr1 SOM s e1 f) : SOM z LS1 (LocSqr1Mor2 LS1) := pr1 (pr2 LS1). Definition LocSqr1Comm {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e1 : SOM x y s} {f : x --> z} (LS1 : LocSqr1 SOM s e1 f) : s · (LocSqr1Mor1 LS1) = f · (LocSqr1Mor2 LS1) := dirprod_pr2 (pr2 LS1). Definition LocSqr2 (SOM : SubsetsOfMors) {y z w : ob C} (s : y --> w) (e1 : SOM y w s) (f : z --> w) : UU := ∑ D : (∑ (x : ob C), C⟦x, y⟧ × C⟦x, z⟧), (SOM (pr1 D) z (dirprod_pr2 (pr2 D))) × ((dirprod_pr1 (pr2 D)) · s = (dirprod_pr2 (pr2 D)) · f). Definition LocSqr2Ob {SOM : SubsetsOfMors} {y z w : ob C} {s : y --> w} {e1 : SOM y w s} {f : z --> w} (LS2 : LocSqr2 SOM s e1 f) : ob C := pr1 (pr1 LS2). Coercion LocSqr2Ob : LocSqr2 >-> ob. Definition LocSqr2Mor1 {SOM : SubsetsOfMors} {y z w : ob C} {s : y --> w} {e1 : SOM y w s} {f : z --> w} (LS2 : LocSqr2 SOM s e1 f) : C⟦LS2, y⟧ := dirprod_pr1 (pr2 (pr1 LS2)). Definition LocSqr2Mor2 {SOM : SubsetsOfMors} {y z w : ob C} {s : y --> w} {e1 : SOM y w s} {f : z --> w} (LS2 : LocSqr2 SOM s e1 f) : C⟦LS2, z⟧ := dirprod_pr2 (pr2 (pr1 LS2)). Definition LocSqr2Mor2Is {SOM : SubsetsOfMors} {y z w : ob C} {s : y --> w} {e1 : SOM y w s} {f : z --> w} (LS2 : LocSqr2 SOM s e1 f) : SOM LS2 z (LocSqr2Mor2 LS2) := dirprod_pr1 (pr2 LS2). Definition LocSqr2Comm {SOM : SubsetsOfMors} {y z w : ob C} {s : y --> w} {e1 : SOM y w s} {f : z --> w} (LS2 : LocSqr2 SOM s e1 f) : (LocSqr2Mor1 LS2) · s = (LocSqr2Mor2 LS2) · f := dirprod_pr2 (pr2 LS2). (** *** Completion to squares *) Definition isLocalizingClass2 (SOM : SubsetsOfMors) : UU := (∏ (x y z : ob C) (s : x --> y) (e1 : SOM x y s) (f : x --> z), (LocSqr1 SOM s e1 f)) × (∏ (y z w : ob C) (s : y --> w) (e1 : SOM y w s) (f : z --> w), (LocSqr2 SOM s e1 f)). Definition isLocClassSqr1 {SOM : SubsetsOfMors} (H : isLocalizingClass2 SOM) : ∏ (x y z : ob C) (s : x --> y) (e1 : SOM x y s) (f : x --> z), LocSqr1 SOM s e1 f := dirprod_pr1 H. Definition isLocClassSqr2 {SOM : SubsetsOfMors} (H : isLocalizingClass2 SOM) : ∏ (y z w : ob C) (s : y --> w) (e1 : SOM y w s) (f : z --> w), LocSqr2 SOM s e1 f := dirprod_pr2 H. (** **** Pre- and post switch *) Definition PreSwitch (SOM : SubsetsOfMors) {x y z : ob C} (s : x --> y) (e : SOM x y s) (f g : y --> z) (H : s · f = s · g) : UU := ∑ D : (∑ (w : ob C), C⟦z, w⟧), (SOM z (pr1 D) (pr2 D)) × (f · (pr2 D) = g · (pr2 D)). Definition PreSwitchOb {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e : SOM x y s} {f g : y --> z} {H : s · f = s · g} (PreS : PreSwitch SOM s e f g H) : ob C := pr1 (pr1 PreS). Coercion PreSwitchOb : PreSwitch >-> ob. Definition PreSwitchMor {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e : SOM x y s} {f g : y --> z} {H : s · f = s · g} (PreS : PreSwitch SOM s e f g H) : C⟦z, PreS⟧ := pr2 (pr1 PreS). Definition PreSwitchMorIs {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e : SOM x y s} {f g : y --> z} {H : s · f = s · g} (PreS : PreSwitch SOM s e f g H) : SOM z PreS (PreSwitchMor PreS) := dirprod_pr1 (pr2 PreS). Definition PreSwitchEq {SOM : SubsetsOfMors} {x y z : ob C} {s : x --> y} {e : SOM x y s} {f g : y --> z} {H : s · f = s · g} (PreS : PreSwitch SOM s e f g H) : f · (PreSwitchMor PreS) = g · (PreSwitchMor PreS) := dirprod_pr2 (pr2 PreS). (** **** Post switch *) Definition PostSwitch (SOM : SubsetsOfMors) {y z w : ob C} (f g : y --> z) (s : z --> w) (e : SOM z w s) (H : f · s = g · s) : UU := ∑ D : (∑ (x : ob C), C⟦x, y⟧), (SOM (pr1 D) y (pr2 D)) × ((pr2 D) · f = (pr2 D) · g). Definition PostSwitchOb {SOM : SubsetsOfMors} {y z w : ob C} {f g : y --> z} {s : z --> w} {e : SOM z w s} {H : f · s = g · s} (PostS : PostSwitch SOM f g s e H) : ob C := pr1 (pr1 PostS). Coercion PostSwitchOb : PostSwitch >-> ob. Definition PostSwitchMor {SOM : SubsetsOfMors} {y z w : ob C} {f g : y --> z} {s : z --> w} {e : SOM z w s} {H : f · s = g · s} (PostS : PostSwitch SOM f g s e H) : C⟦PostS, y⟧ := pr2 (pr1 PostS). Definition PostSwitchMorIs {SOM : SubsetsOfMors} {y z w : ob C} {f g : y --> z} {s : z --> w} {e : SOM z w s} {H : f · s = g · s} (PostS : PostSwitch SOM f g s e H) : SOM PostS y (PostSwitchMor PostS) := dirprod_pr1 (pr2 PostS). Definition PostSwitchEq {SOM : SubsetsOfMors} {y z w : ob C} {f g : y --> z} {s : z --> w} {e : SOM z w s} {H : f · s = g · s} (PostS : PostSwitch SOM f g s e H) : (PostSwitchMor PostS) · f = (PostSwitchMor PostS) · g := dirprod_pr2 (pr2 PostS). (** *** Pre- and postcomposition with morphisms in the subset *) Definition isLocalizingClass3 (SOM : SubsetsOfMors) : UU := (∏ (x y z : ob C) (s : x --> y) (e : SOM x y s) (f g : y --> z) (H : s · f = s · g), PreSwitch SOM s e f g H) × (∏ (y z w : ob C) (f g : y --> z) (s : z --> w) (e : SOM z w s) (H : f · s = g · s), PostSwitch SOM f g s e H). Definition isLocClassPre {SOM : SubsetsOfMors} (H : isLocalizingClass3 SOM) : ∏ (x y z : ob C) (s : x --> y) (e : SOM x y s) (f g : y --> z) (H : s · f = s · g), PreSwitch SOM s e f g H := dirprod_pr1 H. Definition isLocClassPost {SOM : SubsetsOfMors} (H : isLocalizingClass3 SOM) : ∏ (y z w : ob C) (f g : y --> z) (s : z --> w) (e : SOM z w s) (H : f · s = g · s), PostSwitch SOM f g s e H := dirprod_pr2 H. (** *** Localizing class *) Definition isLocalizingClass (SOM : SubsetsOfMors) : UU := (isLocalizingClass1 SOM) × (isLocalizingClass2 SOM) × (isLocalizingClass3 SOM). Definition isLocalizingClass_isLocalizingClass1 {SOM : SubsetsOfMors} (H : isLocalizingClass SOM) : isLocalizingClass1 SOM := dirprod_pr1 H. Coercion isLocalizingClass_isLocalizingClass1 : isLocalizingClass >-> isLocalizingClass1. Definition isLocalizingClass_isLocalizingClass2 {SOM : SubsetsOfMors} (H : isLocalizingClass SOM) : isLocalizingClass2 SOM := dirprod_pr1 (dirprod_pr2 H). Coercion isLocalizingClass_isLocalizingClass2 : isLocalizingClass >-> isLocalizingClass2. Definition isLocalizingClass_isLocalizingClass3 {SOM : SubsetsOfMors} (H : isLocalizingClass SOM) : isLocalizingClass3 SOM := dirprod_pr2 (dirprod_pr2 H). Coercion isLocalizingClass_isLocalizingClass3 : isLocalizingClass >-> isLocalizingClass3. (** Collection of morphisms in C *) Variable SOM : SubsetsOfMors. (** The above collection satisfies the conditions of localizin class. See the comment on top of this section. *) Hypothesis iLC : isLocalizingClass SOM. (** ** Roofs *) Definition Roof (x y : ob C) : UU := ∑ D : (∑ z : ob C, C⟦z, x⟧ × C⟦z, y⟧), (SOM (pr1 D) x (dirprod_pr1 (pr2 D))). Definition make_Roof (x y z : ob C) (s : z --> x) (f : z --> y) (e : SOM z x s) : Roof x y := tpair _ (tpair _ z (s,,f)) e. Definition RoofOb {x y : ob C} (R : Roof x y) : ob C := pr1 (pr1 R). Coercion RoofOb : Roof >-> ob. Definition RoofMor1 {x y : ob C} (R : Roof x y) : C⟦R, x⟧ := dirprod_pr1 (pr2 (pr1 R)). Definition RoofMor1Is {x y : ob C} (R : Roof x y) : SOM R x (RoofMor1 R) := pr2 R. Definition RoofMor2 {x y : ob C} (R : Roof x y) : C⟦R, y⟧ := dirprod_pr2 (pr2 (pr1 R)). (** ** Coroofs *) Definition Coroof (x y : ob C) : UU := ∑ D : (∑ z : ob C, C⟦x, z⟧ × C⟦y, z⟧), (SOM y (pr1 D) (dirprod_pr2 (pr2 D))). Definition make_Coroof (x y z : ob C) (f : x --> z) (s : y --> z) (e : SOM y z s) : Coroof x y := tpair _ (tpair _ z (f,,s)) e. Definition CoroofOb {x y : ob C} (CR : Coroof x y) : ob C := pr1 (pr1 CR). Coercion CoroofOb : Coroof >-> ob. Definition CoroofMor1 {x y : ob C} (CR : Coroof x y) : C⟦x, CR⟧ := dirprod_pr1 (pr2 (pr1 CR)). Definition CoroofMor2 {x y : ob C} (CR : Coroof x y) : C⟦y, CR⟧ := dirprod_pr2 (pr2 (pr1 CR)). Definition CoroofMor2Is {x y : ob C} (CR : Coroof x y) : SOM y CR (CoroofMor2 CR) := pr2 CR. Definition RoofToCoroof {x y : ob C} (R : Roof x y) : Coroof x y. Proof. set (sqr := isLocClassSqr1 iLC _ _ _ (RoofMor1 R) (RoofMor1Is R) (RoofMor2 R)). use make_Coroof. - exact sqr. - exact (LocSqr1Mor1 sqr). - exact (LocSqr1Mor2 sqr). - exact (LocSqr1Mor2Is sqr). Defined. (** ** RoofTop *) (** These are used to define an equivalence relation between roofs *) Definition RoofTop {x y : ob C} (R1 R2 : Roof x y) : UU := ∑ D : (∑ w : ob C, C⟦w, R1⟧ × C⟦w, R2⟧), (SOM (pr1 D) x ((dirprod_pr1 (pr2 D)) · (RoofMor1 R1))) × ((dirprod_pr1 (pr2 D)) · (RoofMor1 R1) = (dirprod_pr2 (pr2 D)) · (RoofMor1 R2)) × ((dirprod_pr1 (pr2 D)) · (RoofMor2 R1) = (dirprod_pr2 (pr2 D)) · (RoofMor2 R2)). Definition make_RoofTop {x y : ob C} {R1 R2 : Roof x y} (w : ob C) (s : w --> R1) (f : w --> R2) (e : SOM w x (s · RoofMor1 R1)) (H1 : s · (RoofMor1 R1) = f · (RoofMor1 R2)) (H2 : s · (RoofMor2 R1) = f · (RoofMor2 R2)) : RoofTop R1 R2 := tpair _ (tpair _ w (s,,f)) (e,,(H1,,H2)). Definition RoofTopOb {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : ob C := pr1 (pr1 T). Coercion RoofTopOb : RoofTop >-> ob. Definition RoofTopMor1 {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : C⟦T, R1⟧ := dirprod_pr1 (pr2 (pr1 T)). Definition RoofTopMor1Is {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : (SOM T x ((RoofTopMor1 T) · (RoofMor1 R1))) := (dirprod_pr1 (pr2 T)). Definition RoofTopMor2 {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : C⟦T, R2⟧ := dirprod_pr2 (pr2 (pr1 T)). Definition RoofTopEq1 {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : (RoofTopMor1 T) · (RoofMor1 R1) = (RoofTopMor2 T) · (RoofMor1 R2) := dirprod_pr1 (dirprod_pr2 (pr2 T)). Definition RoofTopEq2 {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : (RoofTopMor1 T) · (RoofMor2 R1) = (RoofTopMor2 T) · (RoofMor2 R2) := dirprod_pr2 (dirprod_pr2 (pr2 T)). (** We define an equivalence relation between the roofs *) Definition RoofHrel' {x y : ob C} (R1 R2 : Roof x y) : hProp := ishinh (RoofTop R1 R2). Definition RoofHrel (x y : ob C) : hrel (Roof x y) := (λ R1 : Roof x y, λ R2 : Roof x y, RoofHrel' R1 R2). Lemma RoofEqrel (x y : ob C) : iseqrel (RoofHrel x y). Proof. use iseqrelconstr. (* is trans *) - intros R1 R2 R3 T1' T2'. use (squash_to_prop T1'). apply isapropishinh. intros T1. clear T1'. use (squash_to_prop T2'). apply isapropishinh. intros T2. clear T2'. set (tmp := isLocClassSqr2 iLC T2 T1 x (RoofTopMor1 T2 · RoofMor1 R2) (RoofTopMor1Is T2) (RoofTopMor2 T1 · RoofMor1 R2)). induction tmp as [D1 D2]. induction D1 as [w m]. induction m as [m1 m2]. induction D2 as [D1 D2]. cbn in D1, D2. repeat rewrite assoc in D2. set (tmp := isLocClassPost iLC w R2 x (m1 · RoofTopMor1 T2) (m2 · RoofTopMor2 T1) (RoofMor1 R2) (RoofMor1Is R2) D2). induction tmp as [t p]. intros P X. apply X. clear X P. use make_RoofTop. + exact (pr1 t). + exact ((pr2 t) · m2 · RoofTopMor1 T1). + exact ((pr2 t) · m1 · RoofTopMor2 T2). + repeat rewrite <- assoc. use (isLocClassComp iLC). * exact (dirprod_pr1 p). * use (isLocClassComp iLC). -- exact D1. -- exact (RoofTopMor1Is T1). + induction p as [p1 p2]. repeat rewrite assoc in p2. set (tmp := RoofTopEq1 T2). repeat rewrite <- assoc. rewrite <- tmp. clear tmp. repeat rewrite assoc. repeat rewrite <- (assoc (pr2 t)). rewrite D2. repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. exact (RoofTopEq1 T1). + induction p as [p1 p2]. repeat rewrite assoc in p2. set (tmp := RoofTopEq2 T2). repeat rewrite <- assoc. rewrite <- tmp. clear tmp. repeat rewrite assoc. rewrite p2. repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. exact (RoofTopEq2 T1). (* isrefl *) - intros R1. intros P X. apply X. clear X P. use make_RoofTop. + exact R1. + exact (identity R1). + exact (identity R1). + rewrite id_left. exact (RoofMor1Is R1). + apply idpath. + apply idpath. (* issymm *) - intros R1 R2 T'. use (squash_to_prop T'). apply isapropishinh. intros T. clear T'. intros P X. apply X. clear X P. use make_RoofTop. + exact T. + exact (RoofTopMor2 T). + exact (RoofTopMor1 T). + rewrite <- (RoofTopEq1 T). exact (RoofTopMor1Is T). + exact (! (RoofTopEq1 T)). + exact (! (RoofTopEq2 T)). Qed. (** We are interested in the equivalence classes of roofs. *) (* Definition eqclass {X : UU} {r : eqrel X} : UU := ∑ A : hsubtype X, iseqclass r A. *) Definition RoofEqclass (x y : ob C) : UU := ∑ A : hsubtype (Roof x y), iseqclass (make_eqrel _ (RoofEqrel x y)) A. Lemma isasetRoofEqclass (x y : ob C) : isaset (RoofEqclass x y). Proof. apply isaset_total2. - apply isasethsubtype. - intros x0. apply isasetaprop. apply isapropiseqclass. Defined. Definition make_RoofEqclass {x y : ob C} (A : hsubtype (Roof x y)) (H : iseqclass (make_eqrel _ (RoofEqrel x y)) A) : RoofEqclass x y := tpair _ A H. Definition RoofEqclassIn {x y : ob C} (RE : RoofEqclass x y) : hsubtype (Roof x y) := pr1 RE. Definition RoofEqclassIs {x y : ob C} (RE : RoofEqclass x y) : iseqclass (make_eqrel _ (RoofEqrel x y)) (RoofEqclassIn RE) := pr2 RE. Definition RoofEqclassEq {x y : ob C} (RE1 RE2 : RoofEqclass x y) (H1 : ∏ (R : Roof x y) (H : (pr1 RE1) R), (pr1 RE2) R) (H2 : ∏ (R : Roof x y) (H : (pr1 RE2) R), (pr1 RE1) R) : RE1 = RE2. Proof. use total2_paths_f. - use funextfun. intros g. apply hPropUnivalence. + apply H1. + apply H2. - apply proofirrelevance. apply isapropiseqclass. Qed. Definition RoofEqclassDisjoint {x y : ob C} (RE1 RE2 : RoofEqclass x y) (R1 R2 : Roof x y) (H1 : RoofEqclassIn RE1 R1) (H2 : RoofEqclassIn RE2 R2) (H : (make_eqrel _ (RoofEqrel x y)) R1 R2) : RE1 = RE2. Proof. use RoofEqclassEq. - intros R H'. set (tmp := eqax1 (pr2 RE1) R1 R2 H H1). set (tmp' := eqax2 (pr2 RE1) R R2 H' tmp). apply eqrelsymm in tmp'. apply (eqax1 (pr2 RE2) R2 R tmp' H2). - intros R H'. apply eqrelsymm in H. set (tmp := eqax1 (pr2 RE2) R2 R1 H H2). set (tmp' := eqax2 (pr2 RE2) R1 R tmp H'). apply (eqax1 (pr2 RE1) R1 R tmp' H1). Qed. Definition RoofEqclassFromRoof {x y : ob C} (R : Roof x y) : RoofEqclass x y. Proof. use tpair. - exact (λ RR : Roof x y, (make_eqrel _ (RoofEqrel x y)) RR R). - use tpair. + intros P X. apply X. clear X P. use tpair. * exact R. * apply eqrelrefl. + split. * intros x1 x2 X X0. use eqreltrans. -- exact x1. -- apply eqrelsymm. apply X. -- apply X0. * intros x1 x2 X X0. use eqreltrans. -- exact R. -- exact X. -- apply eqrelsymm. apply X0. Defined. Definition RoofEqclassFromRoofIn {x y : ob C} (R : Roof x y) : RoofEqclassIn (RoofEqclassFromRoof R) R. Proof. intros P X. apply X. clear X P. use make_RoofTop. - exact R. - exact (identity R). - exact (identity R). - use (isLocClassComp iLC). + apply (isLocClassIs iLC). + apply (RoofMor1Is R). - apply idpath. - apply idpath. Qed. Definition RoofEqclassEqRoof {x y : ob C} (RE : RoofEqclass x y) (R : Roof x y) (HR : RoofEqclassIn RE R) : RE = RoofEqclassFromRoof R. Proof. use RoofEqclassEq. - intros R0 HR0. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R))). + exact R. + use (eqax2 (RoofEqclassIs RE)). * exact HR. * exact HR0. + apply RoofEqclassFromRoofIn. - intros R0 HR0. use (eqax1 (RoofEqclassIs RE)). + exact R. + use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof R))). * apply RoofEqclassFromRoofIn. * exact HR0. + exact HR. Qed. Definition RoofEqClassIn {x y : ob C} (R1 R2 R3 : Roof x y) (H1 : RoofEqclassIn (RoofEqclassFromRoof R1) R2) (H2 : (make_eqrel _ (RoofEqrel x y)) R2 R3) : RoofEqclassIn (RoofEqclassFromRoof R1) R3. Proof. exact (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R1)) R2 R3 H2 H1). Qed. Definition RoofEqClassIn2 {x y : ob C} (RE : RoofEqclass x y) (R2 R3 : Roof x y) (H1 : RoofEqclassIn RE R2) (H2 : (make_eqrel _ (RoofEqrel x y)) R2 R3) : RoofEqclassIn RE R3. Proof. use (squash_to_prop (pr1 (RoofEqclassIs RE))). apply propproperty. intros RE1. induction RE1 as [RE1 RE2]. apply (eqax1 (RoofEqclassIs RE) RE1 R3). - use eqreltrans. + exact R2. + apply (eqax2 (RoofEqclassIs RE) RE1 R2 RE2 H1). + apply H2. - apply RE2. Qed. Definition roof_comp {x y z : ob C} (R1 : Roof x y) (R2 : Roof y z) : Roof x z. Proof. set (LS2 := isLocClassSqr2 iLC R2 R1 y (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). use make_Roof. - exact LS2. - exact ((LocSqr2Mor2 LS2) · (RoofMor1 R1)). - exact ((LocSqr2Mor1 LS2) · (RoofMor2 R2)). - use (isLocClassComp iLC). + exact (LocSqr2Mor2Is LS2). + exact (RoofMor1Is R1). Defined. (** ** Composition of roofs *) (** Construct a "commutative coroof" from RoofTop *) Definition RoofTopToCoroof {x y : ob C} {R1 R2 : Roof x y} (T : RoofTop R1 R2) : ∑ CR : Coroof x y, (RoofMor1 R1 · CoroofMor1 CR = RoofMor2 R1 · CoroofMor2 CR) × (RoofMor1 R2 · CoroofMor1 CR = RoofMor2 R2 · CoroofMor2 CR). Proof. set (sqr1 := isLocClassSqr1 iLC _ _ _ (RoofMor1 R1) (RoofMor1Is R1) (RoofMor2 R1)). set (sqr2 := isLocClassSqr1 iLC _ _ _ (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R2)). set (sqr3 := isLocClassSqr1 iLC _ _ _ (LocSqr1Mor2 sqr1) (LocSqr1Mor2Is sqr1) (LocSqr1Mor2 sqr2)). set (mor1 := RoofTopMor1 T · RoofMor1 R1 · LocSqr1Mor1 sqr1 · LocSqr1Mor1 sqr3). set (mor2 := RoofTopMor1 T · RoofMor1 R1 · LocSqr1Mor1 sqr2 · LocSqr1Mor2 sqr3). assert (H : RoofTopMor1 T · RoofMor1 R1 · (LocSqr1Mor1 sqr1 · LocSqr1Mor1 sqr3) = RoofTopMor1 T · RoofMor1 R1 · (LocSqr1Mor1 sqr2 · LocSqr1Mor2 sqr3)). { set (tmp1 := LocSqr1Comm sqr1). set (tmp2 := LocSqr1Comm sqr2). set (tmp3 := LocSqr1Comm sqr3). rewrite assoc. rewrite <- (assoc _ (RoofMor1 R1)). rewrite tmp1. rewrite assoc. rewrite <- assoc. rewrite tmp3. rewrite assoc. rewrite (RoofTopEq2 T). rewrite <- (assoc _ (RoofMor2 R2)). rewrite <- tmp2. rewrite assoc. rewrite (RoofTopEq1 T). rewrite assoc. apply idpath. } set (PreS := isLocClassPre iLC _ _ _ (RoofTopMor1 T · RoofMor1 R1) (RoofTopMor1Is T) (LocSqr1Mor1 sqr1 · LocSqr1Mor1 sqr3) (LocSqr1Mor1 sqr2 · LocSqr1Mor2 sqr3) H). use tpair. - use make_Coroof. + exact PreS. + exact (LocSqr1Mor1 sqr1 · LocSqr1Mor1 sqr3 · PreSwitchMor PreS). + exact (LocSqr1Mor2 sqr2 · LocSqr1Mor2 sqr3 · PreSwitchMor PreS). + use (isLocClassComp iLC). * use (isLocClassComp iLC). -- exact (LocSqr1Mor2Is sqr2). -- exact (LocSqr1Mor2Is sqr3). * exact (PreSwitchMorIs PreS). - cbn. split. + rewrite <- (LocSqr1Comm sqr3). rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. apply (LocSqr1Comm sqr1). + rewrite (PreSwitchEq PreS). rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. apply (LocSqr1Comm sqr2). Defined. Opaque RoofTopToCoroof. (** Precomposition with equivalent roofs yield equivalent roofs. *) Lemma roof_pre_comp {x y z : ob C} (R1 R2 : Roof x y) (e : (make_eqrel (RoofHrel x y) (RoofEqrel x y)) R1 R2) (R3 : Roof y z) : (make_eqrel (RoofHrel x z) (RoofEqrel x z)) (roof_comp R1 R3) (roof_comp R2 R3). Proof. use (squash_to_prop e). apply propproperty. intros T. set (T' := RoofTopToCoroof T). induction T' as [CR eq]. intros P X. apply X. clear X P. set (R4 := roof_comp R1 R3). set (R5 := roof_comp R2 R3). unfold roof_comp in R4. unfold roof_comp in R5. set (sqr4 := isLocClassSqr2 iLC R3 R1 y (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R1)). set (sqr5 := isLocClassSqr2 iLC R3 R2 y (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R2)). fold sqr4 in R4. fold sqr5 in R5. set (sqr6 := isLocClassSqr2 iLC R5 R4 x (LocSqr2Mor2 sqr5 · RoofMor1 R2) (RoofMor1Is R5) (LocSqr2Mor2 sqr4 · RoofMor1 R1)). assert (s : SOM R3 CR (RoofMor1 R3 · CoroofMor2 CR)). { use (isLocClassComp iLC). - exact (RoofMor1Is R3). - exact (CoroofMor2Is CR). } assert (H : LocSqr2Mor1 sqr6 · LocSqr2Mor1 sqr5 · (RoofMor1 R3 · CoroofMor2 CR) = LocSqr2Mor2 sqr6 · LocSqr2Mor1 sqr4 · (RoofMor1 R3 · CoroofMor2 CR)). { rewrite assoc. rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr5)). rewrite (LocSqr2Comm sqr5). rewrite <- (assoc _ (LocSqr2Mor1 sqr4)). rewrite (LocSqr2Comm sqr4). rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- (dirprod_pr1 eq). rewrite <- (dirprod_pr2 eq). rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. set (tmp := LocSqr2Comm sqr6). rewrite assoc in tmp. rewrite assoc in tmp. apply tmp. } set (PostS := isLocClassPost iLC _ _ _ (LocSqr2Mor1 sqr6 · LocSqr2Mor1 sqr5) (LocSqr2Mor2 sqr6 · LocSqr2Mor1 sqr4) (RoofMor1 R3 · CoroofMor2 CR) s H). use make_RoofTop. - exact PostS. - exact (PostSwitchMor PostS · LocSqr2Mor2 sqr6). - exact (PostSwitchMor PostS · LocSqr2Mor1 sqr6). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (PostSwitchMorIs PostS). * exact (LocSqr2Mor2Is sqr6). + exact (RoofMor1Is R4). - cbn. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply (! (LocSqr2Comm sqr6)). - cbn. rewrite assoc. rewrite assoc. set (tmp := ! (PostSwitchEq PostS)). rewrite assoc in tmp. rewrite assoc in tmp. apply (maponpaths (λ f : _, f · RoofMor2 R3)) in tmp. apply tmp. Qed. (** Postcomposition with equivalent roofs yield equivalent roofs. *) Lemma roof_post_comp {x y z : ob C} (R1 : Roof x y) (R2 R3 : Roof y z) (e : (make_eqrel (RoofHrel y z) (RoofEqrel y z)) R2 R3) : (make_eqrel (RoofHrel x z) (RoofEqrel x z)) (roof_comp R1 R2) (roof_comp R1 R3). Proof. use (squash_to_prop e). apply propproperty. intros T. clear e. set (T' := RoofTopToCoroof T). induction T' as [CR eq]. intros P X. apply X. clear X P. set (R4 := roof_comp R1 R2). set (R5 := roof_comp R1 R3). unfold roof_comp in R4. unfold roof_comp in R5. set (sqr4 := isLocClassSqr2 iLC R2 R1 y (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). set (sqr5 := isLocClassSqr2 iLC R3 R1 y (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R1)). fold sqr4 in R4. fold sqr5 in R5. set (sqr6 := isLocClassSqr2 iLC R5 R4 R1 (LocSqr2Mor2 sqr5) (LocSqr2Mor2Is sqr5) (LocSqr2Mor2 sqr4)). assert (H : LocSqr2Mor1 sqr6 · LocSqr2Mor1 sqr5 · RoofMor2 R3 · CoroofMor2 CR = LocSqr2Mor2 sqr6 · LocSqr2Mor1 sqr4 · RoofMor2 R2 · CoroofMor2 CR). { rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- (dirprod_pr1 eq). rewrite <- (dirprod_pr2 eq). rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr4)). rewrite (LocSqr2Comm sqr4). rewrite <- (assoc _ (LocSqr2Mor1 sqr5)). rewrite (LocSqr2Comm sqr5). rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. apply (LocSqr2Comm sqr6). } set (PostS := isLocClassPost iLC _ _ _ (LocSqr2Mor1 sqr6 · LocSqr2Mor1 sqr5 · RoofMor2 R3) (LocSqr2Mor2 sqr6 · LocSqr2Mor1 sqr4 · RoofMor2 R2) (CoroofMor2 CR) (CoroofMor2Is CR) H). use make_RoofTop. - exact PostS. - exact (PostSwitchMor PostS · LocSqr2Mor2 sqr6). - exact (PostSwitchMor PostS · LocSqr2Mor1 sqr6). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (PostSwitchMorIs PostS). * exact (LocSqr2Mor2Is sqr6). + exact (RoofMor1Is R4). - cbn. rewrite assoc. rewrite assoc. apply cancel_postcomposition. set (tmp := ! (LocSqr2Comm sqr6)). apply (maponpaths (λ f : _, PostSwitchMor PostS · f)) in tmp. rewrite assoc in tmp. rewrite assoc in tmp. apply tmp. - cbn. apply pathsinv0. rewrite assoc. rewrite assoc. set (tmp := PostSwitchEq PostS). rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc in tmp. apply tmp. Qed. Lemma roof_comp_iscontr (x y z : ob C) (e1 : RoofEqclass x y) (e2 : RoofEqclass y z) : iscontr (∑ e3 : RoofEqclass x z, ∏ (f : Roof x y) (s1 : (RoofEqclassIn e1) f) (g : Roof y z) (s2 : (RoofEqclassIn e2) g), (RoofEqclassIn e3) (roof_comp f g)). Proof. induction e1 as [e1 e1eq]. induction e2 as [e2 e2eq]. use (squash_to_prop (dirprod_pr1 e1eq)). apply isapropiscontr. intros R1. induction R1 as [R1 R1']. use (squash_to_prop (dirprod_pr1 e2eq)). apply isapropiscontr. intros R2. induction R2 as [R2 R2']. use tpair. - use tpair. + use make_RoofEqclass. * exact (λ RR : (Roof x z), (make_eqrel _ (RoofEqrel x z)) RR (roof_comp R1 R2)). * use iseqclassconstr. -- intros P X. apply X. clear X P. use tpair. ++ exact (roof_comp R1 R2). ++ use eqrelrefl. -- intros R3 R4 H1 H2. cbn beta in H2. cbn beta. use (squash_to_prop H1). apply propproperty. intros T1. use (squash_to_prop H2). apply propproperty. intros T2. apply eqrelsymm in H1. use eqreltrans. ++ exact R3. ++ exact H1. ++ exact H2. -- intros R3 R4 H1 H2. cbn beta in H1, H2. apply eqrelsymm in H2. use eqreltrans. ++ exact (roof_comp R1 R2). ++ exact H1. ++ exact H2. + cbn. intros R3 R3' R4 R4'. set (tmp1 := eqax2 e1eq R1 R3 R1' R3'). set (tmp2 := eqax2 e2eq R2 R4 R2' R4'). set (tmp_pre := roof_pre_comp R1 R3 tmp1 R4). set (tmp_post := roof_post_comp R1 R2 R4 tmp2). assert (X : (make_eqrel (RoofHrel x z) (RoofEqrel x z)) (roof_comp R3 R4) (roof_comp R1 R2)). { apply eqrelsymm. use eqreltrans. - exact (roof_comp R1 R4). - exact tmp_post. - exact tmp_pre. } exact X. (* Uniqueness *) - intros t. use total2_paths_f. + use RoofEqclassEq. * intros R HR. cbn. set (tmp1 := eqax2 (pr2 (pr1 t))). apply tmp1. -- exact HR. -- apply (pr2 t). ++ cbn. exact R1'. ++ cbn. exact R2'. * intros R HR. cbn in HR. set (tmp1 := eqax1 (pr2 (pr1 t))). apply (tmp1 (roof_comp R1 R2)). -- apply eqrelsymm. apply HR. -- apply (pr2 t). ++ cbn. exact R1'. ++ cbn. exact R2'. + apply proofirrelevance. apply impred_isaprop. intros t0. apply impred_isaprop. intros t1. apply impred_isaprop. intros t2. apply impred_isaprop. intros t3. apply impred_isaprop. intros t4. apply impred_isaprop. intros t5. apply propproperty. Qed. Local Lemma roof_comp_iscontr_in (x y z : ob C) (R1 : Roof x y) (R2 : Roof y z) : RoofEqclassIn (pr1 (pr1 (roof_comp_iscontr _ _ _ (RoofEqclassFromRoof R1) (RoofEqclassFromRoof R2)))) (roof_comp R1 R2). Proof. use (pr2 (pr1 (roof_comp_iscontr x y z (RoofEqclassFromRoof R1) (RoofEqclassFromRoof R2)))). - apply RoofEqclassFromRoofIn. - apply RoofEqclassFromRoofIn. Qed. (** ** Definition of the localization *) Definition loc_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) (ob C) (λ x y : ob C, RoofEqclass x y). Definition IdRoof (x : ob C) : Roof x x. Proof. use make_Roof. - exact x. - exact (identity x). - exact (identity x). - exact (isLocClassIs iLC x). Defined. Lemma IdRoofEqrel_left {x y : ob C} (R1 : Roof x y) : (make_eqrel (RoofHrel x y) (RoofEqrel x y)) R1 (roof_comp (IdRoof x) R1). Proof. set (comp := roof_comp (IdRoof x) R1). unfold roof_comp in comp. set (sqr := isLocClassSqr2 iLC R1 (IdRoof x) x (RoofMor1 R1) (RoofMor1Is R1) (RoofMor2 (IdRoof x))). fold sqr in comp. apply eqrelsymm. intros P X. apply X. clear X P. use make_RoofTop. - exact comp. - exact (identity comp). - exact (LocSqr2Mor1 sqr). - use (isLocClassComp iLC). + apply (isLocClassIs iLC). + apply (RoofMor1Is comp). - rewrite id_left. cbn. apply (! (LocSqr2Comm sqr)). - cbn. rewrite id_left. apply idpath. Qed. Lemma IdRoofEqrel_right {x y : ob C} (R1 : Roof x y) : (make_eqrel (RoofHrel x y) (RoofEqrel x y)) R1 (roof_comp R1 (IdRoof y)). Proof. set (comp := roof_comp R1 (IdRoof y)). unfold roof_comp in comp. set (sqr := isLocClassSqr2 iLC (IdRoof y) R1 y (RoofMor1 (IdRoof y)) (RoofMor1Is (IdRoof y)) (RoofMor2 R1)). fold sqr in comp. apply eqrelsymm. intros P X. apply X. clear X P. use make_RoofTop. - exact comp. - exact (identity comp). - exact (LocSqr2Mor2 sqr). - use (isLocClassComp iLC). + apply (isLocClassIs iLC). + apply (RoofMor1Is comp). - rewrite id_left. cbn. apply idpath. - rewrite id_left. cbn. apply (LocSqr2Comm sqr). Qed. Definition IdRoofEqclass (x : ob C) : RoofEqclass x x. Proof. exact (RoofEqclassFromRoof (make_Roof x x x (identity x) (identity x) (isLocClassIs iLC x))). Defined. Definition loc_precategory_data : precategory_data := make_precategory_data loc_precategory_ob_mor (λ (x : ob C), IdRoofEqclass x) (fun (x y z : ob C) (f : RoofEqclass x y) (g : RoofEqclass y z) => pr1 (pr1 (roof_comp_iscontr x y z f g))). Lemma loc_id_left_in {x y : loc_precategory_data} (f : loc_precategory_data⟦x, y⟧) (R1 : Roof x y) (H1 : RoofEqclassIn f R1) : pr1 (identity x · f) (roof_comp (IdRoof x) R1). Proof. apply (pr2 (pr1 (roof_comp_iscontr x x y (IdRoofEqclass x) f))). - apply RoofEqclassFromRoofIn. - apply H1. Qed. Local Lemma loc_id_left {x y : loc_precategory_data} (f : loc_precategory_data⟦x, y⟧) : identity x · f = f. Proof. use (squash_to_prop (pr1 (RoofEqclassIs f))). apply isasetRoofEqclass. intros f'. induction f' as [f1 f2]. use RoofEqclassEq. - intros R HR. set (tmp := IdRoofEqrel_left R). set (e1 := eqax1 (RoofEqclassIs (identity x · f)) _ _ tmp HR). (* Need to show that eqrel f1 R *) assert (X : RoofEqclassIn (identity x · f) (roof_comp (IdRoof x) f1)). { cbn. apply (pr2 (pr1 (roof_comp_iscontr x x y (IdRoofEqclass x) f)) (IdRoof x)). - apply RoofEqclassFromRoofIn. - apply f2. } set (e2 := eqax2 (RoofEqclassIs (identity x · f)) _ _ e1 X). set (e3 := IdRoofEqrel_left R). use (eqax1 (RoofEqclassIs f)). + exact (roof_comp (IdRoof x) f1). + use eqreltrans. * exact (roof_comp (IdRoof x) R). * apply eqrelsymm. apply e2. * apply eqrelsymm. apply e3. + set (e4 := IdRoofEqrel_left f1). use (eqax1 (RoofEqclassIs f)). -- exact f1. -- exact e4. -- exact f2. - intros R HR. set (tmp := IdRoofEqrel_left R). use (eqax1 (RoofEqclassIs (identity x · f))). + exact (roof_comp (IdRoof x) R). + apply eqrelsymm. apply tmp. + apply (pr2 (pr1 (roof_comp_iscontr x x y (IdRoofEqclass x) f))). * apply RoofEqclassFromRoofIn. * apply HR. Qed. Local Lemma loc_id_right {x y : loc_precategory_data} (f : loc_precategory_data⟦x, y⟧) : f · identity y = f. Proof. use (squash_to_prop (pr1 (RoofEqclassIs f))). apply isasetRoofEqclass. intros f'. induction f' as [f1 f2]. use RoofEqclassEq. - intros R HR. set (tmp := IdRoofEqrel_right R). set (e1 := eqax1 (RoofEqclassIs (f · identity y)) _ _ tmp HR). (* Need to show (eqrel ...) f1 R *) assert (X : RoofEqclassIn (f · identity y) (roof_comp f1 (IdRoof y))). { cbn. apply (pr2 (pr1 (roof_comp_iscontr x y y f (IdRoofEqclass y)))). - apply f2. - apply RoofEqclassFromRoofIn. } set (e2 := eqax2 (RoofEqclassIs (f · identity y)) _ _ e1 X). use (eqax1 (RoofEqclassIs f)). + exact (roof_comp f1 (IdRoof y)). + use eqreltrans. * exact (roof_comp R (IdRoof y)). * apply eqrelsymm. apply e2. * apply eqrelsymm. apply tmp. + set (e4 := IdRoofEqrel_right f1). use (eqax1 (RoofEqclassIs f)). -- exact f1. -- exact e4. -- exact f2. - intros R HR. set (tmp := IdRoofEqrel_right R). use (eqax1 (RoofEqclassIs (f · identity y))). + exact (roof_comp R (IdRoof y)). + apply eqrelsymm. apply tmp. + apply (pr2 (pr1 (roof_comp_iscontr x y y f (IdRoofEqclass y)))). * apply HR. * apply RoofEqclassFromRoofIn. Qed. Local Definition loc_precategory_assoc_Roof (x y z w : loc_precategory_data) (R1 : Roof x y) (R2 : Roof y z) (R3 : Roof z w) : Roof x w. Proof. set (sqr1 := isLocClassSqr2 iLC _ _ _ (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). set (sqr2 := isLocClassSqr2 iLC _ _ _ (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R2)). set (sqr3 := isLocClassSqr2 iLC _ _ _ (LocSqr2Mor2 sqr2) (LocSqr2Mor2Is sqr2) (LocSqr2Mor1 sqr1)). use make_Roof. - exact sqr3. - exact (LocSqr2Mor2 sqr3 · LocSqr2Mor2 sqr1 · RoofMor1 R1). - exact (LocSqr2Mor1 sqr3 · LocSqr2Mor1 sqr2 · RoofMor2 R3). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (LocSqr2Mor2Is sqr3). * exact (LocSqr2Mor2Is sqr1). + exact (RoofMor1Is R1). Defined. Local Lemma loc_precategory_assoc_eqrel1 {x y z w : loc_precategory_data} (R1 : Roof x y) (R2 : Roof y z) (R3 : Roof z w) : (make_eqrel (RoofHrel x w) (RoofEqrel x w)) (roof_comp (roof_comp R1 R2) R3) (loc_precategory_assoc_Roof x y z w R1 R2 R3). Proof. set (R4 := roof_comp R1 R2). set (R5 := roof_comp R2 R3). set (R6 := loc_precategory_assoc_Roof x y z w R1 R2 R3). set (R6' := roof_comp R4 R3). set (CR := RoofToCoroof R3). set (sqrop := isLocClassSqr1 iLC R3 z w (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R3)). set (sqr1 := isLocClassSqr2 iLC R2 R1 y (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). set (sqr2 := isLocClassSqr2 iLC R3 R2 z (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R2)). set (sqr3 := isLocClassSqr2 iLC sqr2 sqr1 R2 (LocSqr2Mor2 sqr2) (LocSqr2Mor2Is sqr2) (LocSqr2Mor1 sqr1)). set (sqr4 := isLocClassSqr2 iLC R3 sqr1 z (RoofMor1 R3) (RoofMor1Is R3) (LocSqr2Mor1 sqr1 · RoofMor2 R2)). set (sqr := isLocClassSqr2 iLC _ _ _ (LocSqr2Mor2 sqr3) (LocSqr2Mor2Is sqr3) (LocSqr2Mor2 sqr4)). assert (H : LocSqr2Mor2 sqr · RoofMor2 R6' · CoroofMor2 CR = LocSqr2Mor1 sqr · RoofMor2 R6 · CoroofMor2 CR). { cbn. fold sqrop. fold sqr1. fold sqr2. fold sqr3. fold sqr4. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- assoc. rewrite <- (LocSqr1Comm sqrop). rewrite <- (assoc _ (RoofMor2 R3)). rewrite <- (LocSqr1Comm sqrop). rewrite assoc. rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr4)). rewrite (LocSqr2Comm sqr4). rewrite assoc. rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr2)). rewrite (LocSqr2Comm sqr2). rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. rewrite <- (LocSqr2Comm sqr). rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply (! (LocSqr2Comm sqr3)). } set (PostS := isLocClassPost iLC _ _ _ (LocSqr2Mor2 sqr · RoofMor2 R6') (LocSqr2Mor1 sqr · RoofMor2 R6) (CoroofMor2 CR) (CoroofMor2Is CR) H). intros P X. apply X. clear X P. use make_RoofTop. - exact (PostS). - exact (PostSwitchMor PostS · LocSqr2Mor2 sqr). - exact (PostSwitchMor PostS · LocSqr2Mor1 sqr). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (PostSwitchMorIs PostS). * exact (LocSqr2Mor2Is sqr). + exact (RoofMor1Is R6'). - rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. cbn. fold sqr1. fold sqr2. fold sqr3. fold sqr4. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. exact (! (LocSqr2Comm sqr)). - rewrite <- assoc. rewrite <- assoc. exact (PostSwitchEq PostS). Qed. Local Lemma loc_precategory_assoc_eqrel2 (x y z w : loc_precategory_data) (R1 : Roof x y) (R2 : Roof y z) (R3 : Roof z w) : (make_eqrel (RoofHrel x w) (RoofEqrel x w)) (roof_comp R1 (roof_comp R2 R3)) (loc_precategory_assoc_Roof x y z w R1 R2 R3). Proof. set (R4 := roof_comp R1 R2). set (R5 := roof_comp R2 R3). set (R6 := loc_precategory_assoc_Roof x y z w R1 R2 R3). set (R6' := roof_comp R1 R5). set (CR := RoofToCoroof R2). set (sqrop := isLocClassSqr1 iLC R2 y z (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R2)). set (sqr1 := isLocClassSqr2 iLC R2 R1 y (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). set (sqr2 := isLocClassSqr2 iLC R3 R2 z (RoofMor1 R3) (RoofMor1Is R3) (RoofMor2 R2)). set (sqr3 := isLocClassSqr2 iLC sqr2 sqr1 R2 (LocSqr2Mor2 sqr2) (LocSqr2Mor2Is sqr2) (LocSqr2Mor1 sqr1)). set (sqr4 := isLocClassSqr2 iLC sqr2 R1 y (LocSqr2Mor2 sqr2 · RoofMor1 R2) (isLocClassComp iLC sqr2 R2 y (LocSqr2Mor2 sqr2) (LocSqr2Mor2Is sqr2) (RoofMor1 R2) (RoofMor1Is R2)) (RoofMor2 R1)). assert (e0 : SOM _ _ (LocSqr2Mor2 sqr3 · LocSqr2Mor2 sqr1)). { use (isLocClassComp iLC). - exact (LocSqr2Mor2Is sqr3). - exact (LocSqr2Mor2Is sqr1). } set (sqr := isLocClassSqr2 iLC _ _ _ (LocSqr2Mor2 sqr3 · LocSqr2Mor2 sqr1) e0 (LocSqr2Mor2 sqr4)). assert (e : SOM R3 CR (RoofMor1 R3 · CoroofMor2 CR)). { use (isLocClassComp iLC). - exact (RoofMor1Is R3). - exact (CoroofMor2Is CR). } assert (H : LocSqr2Mor2 sqr · LocSqr2Mor1 sqr4 · LocSqr2Mor1 sqr2 · (RoofMor1 R3 · LocSqr1Mor2 sqrop) = LocSqr2Mor1 sqr · LocSqr2Mor1 sqr3 · LocSqr2Mor1 sqr2 · (RoofMor1 R3 · LocSqr1Mor2 sqrop)). { rewrite assoc. rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr2)). rewrite (LocSqr2Comm sqr2). rewrite assoc. rewrite <- (assoc _ (LocSqr2Mor1 sqr2)). rewrite (LocSqr2Comm sqr2). rewrite assoc. rewrite <- assoc. rewrite <- (LocSqr1Comm sqrop). rewrite assoc. rewrite <- (assoc _ _ (LocSqr1Mor2 sqrop)). rewrite <- (LocSqr1Comm sqrop). rewrite assoc. apply cancel_postcomposition. rewrite <- (assoc _ (LocSqr2Mor1 sqr3)). rewrite (LocSqr2Comm sqr3). rewrite assoc. rewrite <- assoc. rewrite <- assoc. rewrite (LocSqr2Comm sqr4). rewrite assoc. rewrite <- (LocSqr2Comm sqr). rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. apply (! (LocSqr2Comm sqr1)). } set (PostS := isLocClassPost iLC _ _ _ (LocSqr2Mor2 sqr · LocSqr2Mor1 sqr4 · LocSqr2Mor1 sqr2) (LocSqr2Mor1 sqr · LocSqr2Mor1 sqr3 · LocSqr2Mor1 sqr2) (RoofMor1 R3 · CoroofMor2 CR) e H). intros P X. apply X. clear X P. use make_RoofTop. - exact PostS. - exact (PostSwitchMor PostS · LocSqr2Mor2 sqr). - exact (PostSwitchMor PostS · LocSqr2Mor1 sqr). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (PostSwitchMorIs PostS). * exact (LocSqr2Mor2Is sqr). + exact (RoofMor1Is R6'). - cbn. fold sqr1. fold sqr2. fold sqr3. fold sqr4. rewrite <- assoc. apply pathsinv0. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. rewrite <- assoc. apply (LocSqr2Comm sqr). - cbn. fold sqr1. fold sqr2. fold sqr3. fold sqr4. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. set (tmp := PostSwitchEq PostS). rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc in tmp. exact tmp. Qed. Local Lemma loc_precategory_assoc_eqrel (x y z w : loc_precategory_data) (R1 : Roof x y) (R2 : Roof y z) (R3 : Roof z w) : (make_eqrel (RoofHrel x w) (RoofEqrel x w)) (roof_comp R1 (roof_comp R2 R3)) (roof_comp (roof_comp R1 R2) R3). Proof. use eqreltrans. - exact (loc_precategory_assoc_Roof x y z w R1 R2 R3). - exact (loc_precategory_assoc_eqrel2 x y z w R1 R2 R3). - apply eqrelsymm. exact (loc_precategory_assoc_eqrel1 R1 R2 R3). Qed. Local Lemma loc_precategory_assoc (a b c d : loc_precategory_data) (f : loc_precategory_data ⟦a, b⟧) (g : loc_precategory_data ⟦b, c⟧) (h : loc_precategory_data ⟦c, d⟧) : f · (g · h) = f · g · h. Proof. use (squash_to_prop (pr1 (RoofEqclassIs f))). apply isasetRoofEqclass. intros f'. use (squash_to_prop (pr1 (RoofEqclassIs g))). apply isasetRoofEqclass. intros g'. use (squash_to_prop (pr1 (RoofEqclassIs h))). apply isasetRoofEqclass. intros h'. induction f' as [f1 f2]. induction g' as [g1 g2]. induction h' as [h1 h2]. use RoofEqclassEq. - intros R HR. assert (X1 : pr1 (f · (g · h)) (roof_comp f1 (roof_comp g1 h1))). { apply (pr2 (pr1 (roof_comp_iscontr a b d f (pr1 (pr1 (roof_comp_iscontr b c d g h)))))). - apply f2. - apply (pr2 (pr1 (roof_comp_iscontr b c d g h))). + apply g2. + apply h2. } assert (X2 : pr1 (f · g · h) (roof_comp (roof_comp f1 g1) h1)). { apply (pr2 (pr1 (roof_comp_iscontr a c d (pr1 (pr1 (roof_comp_iscontr a b c f g))) h))). - apply (pr2 (pr1 (roof_comp_iscontr a b c f g))). + apply f2. + apply g2. - apply h2. } set (X3 := loc_precategory_assoc_eqrel a b c d f1 g1 h1). use (eqax1 (RoofEqclassIs (f · g · h))). + exact (roof_comp f1 (roof_comp g1 h1)). + use (eqax2 (RoofEqclassIs (f · (g · h)))). * exact X1. * exact HR. + use (eqax1 (RoofEqclassIs (f · g · h))). * exact (roof_comp (roof_comp f1 g1) h1). * apply eqrelsymm. exact X3. * exact X2. - intros R HR. assert (X1 : pr1 (f · (g · h)) (roof_comp f1 (roof_comp g1 h1))). { apply (pr2 (pr1 (roof_comp_iscontr a b d f (pr1 (pr1 (roof_comp_iscontr b c d g h)))))). - apply f2. - apply (pr2 (pr1 (roof_comp_iscontr b c d g h))). + apply g2. + apply h2. } assert (X2 : pr1 (f · g · h) (roof_comp (roof_comp f1 g1) h1)). { apply (pr2 (pr1 (roof_comp_iscontr a c d (pr1 (pr1 (roof_comp_iscontr a b c f g))) h))). - apply (pr2 (pr1 (roof_comp_iscontr a b c f g))). + apply f2. + apply g2. - apply h2. } set (X3 := loc_precategory_assoc_eqrel a b c d f1 g1 h1). use (eqax1 (RoofEqclassIs (f · (g · h)))). + exact (roof_comp f1 (roof_comp g1 h1)). + use eqreltrans. * exact (roof_comp (roof_comp f1 g1) h1). * exact X3. * use (eqax2 (RoofEqclassIs (f · g · h))). -- exact X2. -- exact HR. + exact X1. Qed. Lemma is_precategory_loc_precategory_data : is_precategory loc_precategory_data. Proof. apply is_precategory_one_assoc_to_two. split. - split. + intros a b f. apply loc_id_left. + intros a b f. apply loc_id_right. - intros a b c d f g h. apply loc_precategory_assoc. Qed. (** The category of roofs under the correct equivalence relation *) Definition loc_precategory : precategory := tpair _ _ is_precategory_loc_precategory_data. (** In particular, loc_precategory has homsets. *) Lemma has_homsets_loc_precategory : has_homsets loc_precategory. Proof. intros R1 R2. apply isasetRoofEqclass. Qed. (** ** Universal property *) (** We verify that loc_precategory satisfies the universal property required for localization of categories. Universal property: Suppose F : C -> D is a functor which maps the morphisms in SOM to isomorphisms in D. Then there exists a unique functor H : loc_precategory -> D such that functor_composite [FunctorToLocalization] H = F, where FunctorToLocalization is the natural inclusion functor C -> loc_precategory. The unique functor H is constructed in [LocalizationUniversalFunctor], commutativity is proved in [LocalizationUniversalFunctorComm], and uniqueness of the functor is proved in [LocalizationUniversalFunctorUnique]. In case the objects of D satisfy isaset, then we also show that commutativity is unique. This means that the type "functor_composite [FunctorToLocalization] H = F" has only one term. *) (** Maps a morphism to roofs *) Definition MorToRoof {x y : ob C} (f : x --> y) : Roof x y. Proof. use make_Roof. - exact x. - exact (identity x). - exact f. - exact (isLocClassIs iLC x). Defined. (** MorToRoof is linear with respect to composition in C. *) Lemma MorphismCompEqrel {x y z : ob C} (f : x --> y) (g : y --> z) : (make_eqrel _ (RoofEqrel x z)) (MorToRoof (f · g)) (roof_comp (MorToRoof f) (MorToRoof g)). Proof. set (Rf := MorToRoof f). set (Rg := MorToRoof g). set (Rfg := MorToRoof (f · g)). unfold roof_comp. set (sqr1 := isLocClassSqr2 iLC Rg Rf y (RoofMor1 Rg) (RoofMor1Is Rg) (RoofMor2 Rf)). set (CR := RoofToCoroof (MorToRoof g)). set (sqrop := isLocClassSqr1 iLC y y z (identity y) (isLocClassIs iLC y) g). assert (H : LocSqr2Mor1 sqr1 · RoofMor2 Rg · CoroofMor2 CR = LocSqr2Mor2 sqr1 · f · g · CoroofMor2 CR). { cbn. fold sqrop. rewrite <- assoc. rewrite <- (LocSqr1Comm sqrop). rewrite id_left. rewrite <- assoc. rewrite <- (LocSqr1Comm sqrop). rewrite id_left. apply cancel_postcomposition. set (tmp := LocSqr2Comm sqr1). cbn in tmp. rewrite id_right in tmp. exact tmp. } set (PostS := isLocClassPost iLC _ _ _ (LocSqr2Mor1 sqr1 · RoofMor2 Rg) (LocSqr2Mor2 sqr1 · f · g) (CoroofMor2 CR) (CoroofMor2Is CR) H). intros P X. apply X. clear X P. use make_RoofTop. - exact PostS. - exact (PostSwitchMor PostS · (LocSqr2Mor2 sqr1)). - exact (PostSwitchMor PostS). - use (isLocClassComp iLC). + use (isLocClassComp iLC). * exact (PostSwitchMorIs PostS). * exact (LocSqr2Mor2Is sqr1). + exact (RoofMor1Is Rfg). - cbn. rewrite assoc. apply idpath. - cbn. set (tmp := PostSwitchEq PostS). cbn in tmp. rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc in tmp. rewrite assoc. rewrite assoc. exact (! (tmp)). Qed. (** This is used to show that the natural inclusion functor C --> loc_precategory respects composition. See [FunctorToLocalization]. *) Lemma FunctorToLocalization_comp {x y z : ob C} (f : x --> y) (g : y --> z) : RoofEqclassFromRoof (MorToRoof (f · g)) = pr1 (pr1 (roof_comp_iscontr x y z (RoofEqclassFromRoof (MorToRoof f)) (RoofEqclassFromRoof (MorToRoof g)))). Proof. set (tmpp := roof_comp_iscontr_in x y z (MorToRoof f) (MorToRoof g)). set (eqclass := pr1 (pr1 (roof_comp_iscontr x y z (RoofEqclassFromRoof (MorToRoof f)) (RoofEqclassFromRoof (MorToRoof g))))). fold eqclass in tmpp. set (cont := pr1 (roof_comp_iscontr x y z (RoofEqclassFromRoof (MorToRoof f)) (RoofEqclassFromRoof (MorToRoof g)))). set (cont' := pr2 cont). cbn in cont, cont'. use RoofEqclassEq. - intros R HR. unfold RoofEqclassIn in tmpp. use (eqax1 (RoofEqclassIs eqclass)). + exact (roof_comp (MorToRoof f) (MorToRoof g)). + use eqreltrans. * exact (MorToRoof (f · g)). * apply eqrelsymm. apply MorphismCompEqrel. * set (HR' := RoofEqclassFromRoofIn (MorToRoof (f · g))). use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof (MorToRoof (f · g))))). -- exact HR'. -- exact HR. + exact tmpp. - intros R HR. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof (MorToRoof (f · g))))). + exact (MorToRoof (f · g)). + use eqreltrans. * exact (roof_comp (MorToRoof f) (MorToRoof g)). * apply MorphismCompEqrel. * use (eqax2 (RoofEqclassIs eqclass)). -- exact tmpp. -- exact HR. + apply RoofEqclassFromRoofIn. Qed. (** This is the natural inclusion functor from C to loc_precategory. It is identity on objects and sends a morphisms f : X --> Y to a roof (id_X, f). *) Definition FunctorToLocalization : functor C loc_precategory. Proof. use tpair. - use functor_data_constr. + intros x. exact x. + intros x y f. exact (RoofEqclassFromRoof (MorToRoof f)). - split. + intros x. apply idpath. + intros x y z f g. exact (FunctorToLocalization_comp f g). Defined. (** This definition is the map used by the unique localization functor to map morphisms. It sends a roof (s, f) to the composite (# F s)^{-1} · (# F f). *) Definition MorMap (D : precategory) (hsD : has_homsets D) (F : functor C D) (x y : ob C) (H : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : Roof x y -> D⟦F x, F y⟧. Proof. intros R. exact (inv_from_iso (make_iso _ (H _ _(RoofMor1 R) (RoofMor1Is R))) · (# F (RoofMor2 R))). Defined. (** One of the 2-out-of-3 properties for isomorphisms. *) Lemma is_iso_pre {D : precategory} {x y z : D} (f : x --> y) (g : y --> z) (H1 : is_iso (f · g)) (H2 : is_iso g) : is_iso f. Proof. set (iso1 := make_iso _ H1). set (iso2 := make_iso _ H2). set (inv1 := inv_from_iso iso1). set (inv2 := inv_from_iso iso2). use is_iso_qinv. - exact (g · inv1). - split. + rewrite assoc. unfold inv1. set (tmp := iso_inv_after_iso iso1). cbn in tmp. apply tmp. + set (tmp := iso_inv_after_iso iso2). cbn in tmp. rewrite <- tmp. clear tmp. rewrite <- assoc. apply cancel_precomposition. apply (post_comp_with_iso_is_inj _ _ g H2). set (tmp := iso_after_iso_inv iso2). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. set (tmp := iso_after_iso_inv iso1). cbn in tmp. exact tmp. Qed. (** These two lemmas are used in the proof of [MorMap_iscomprelfun]. *) Lemma MorMap_top_mor1_is_iso (D : precategory) (hsD : has_homsets D) (F : functor C D) (x y : ob C) (H : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) (R1 R2 : Roof x y) (T : RoofTop R1 R2) : is_iso (# F (RoofTopMor1 T)). Proof. use (@is_iso_pre D). - exact (F x). - exact (# F (RoofMor1 R1)). - rewrite <- functor_comp. apply H. apply (RoofTopMor1Is T). - apply H. apply (RoofMor1Is R1). Qed. Lemma MorMap_top_mor2_is_iso (D : precategory) (hsD : has_homsets D) (F : functor C D) (x y : ob C) (H : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) (R1 R2 : Roof x y) (T : RoofTop R1 R2) : is_iso (# F (RoofTopMor2 T)). Proof. use (@is_iso_pre D). - exact (F x). - exact (# F (RoofMor1 R2)). - rewrite <- functor_comp. rewrite <- (RoofTopEq1 T). apply H. apply (RoofTopMor1Is T). - apply H. apply (RoofMor1Is R2). Qed. (** Equation for compositions of inverses *) Lemma inv_from_iso_comp {D : precategory} {x y z : D} (f : iso x y) (g : iso y z) : inv_from_iso (iso_comp f g) = inv_from_iso g · inv_from_iso f. Proof. apply pathsinv0. apply inv_iso_unique'. unfold precomp_with. unfold iso_comp. cbn. rewrite assoc. rewrite <- (assoc _ g). rewrite iso_inv_after_iso. rewrite id_right. apply iso_inv_after_iso. Qed. (** MorMap is compatible with equivalence relation of roofs when one assumes that all the morpsisms in SOM are mapped to isomorphisms. *) Lemma MorMap_iscomprelfun (D : precategory) (hsD : has_homsets D) (F : functor C D) (x y : ob C) (H : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : iscomprelfun (make_eqrel _ (RoofEqrel x y)) (MorMap D hsD F x y H). Proof. intros R1 R2 T'. use (squash_to_prop T'). apply hsD. intros T. clear T'. set (iso1 := make_iso _ (H _ _ _ (RoofMor1Is R1))). set (iso2 := make_iso _ (H _ _ _ (RoofMor1Is R2))). set (iso3 := make_iso _ (MorMap_top_mor1_is_iso D hsD F x y H R1 R2 T)). set (iso4 := make_iso _ (MorMap_top_mor2_is_iso D hsD F x y H R1 R2 T)). unfold MorMap. rewrite <- (id_left (# F (RoofMor2 R1))). rewrite <- (iso_after_iso_inv (iso3)). cbn. rewrite <- assoc. rewrite <- functor_comp. rewrite assoc. rewrite <- inv_from_iso_comp. rewrite (RoofTopEq2 T). rewrite functor_comp. fold iso1 iso2 iso3 iso4. assert (X : iso_comp iso3 iso1 = iso_comp iso4 iso2). { apply eq_iso. cbn. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. apply (RoofTopEq1 T). } rewrite X. rewrite inv_from_iso_comp. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. set (tmp := iso_after_iso_inv iso4). cbn in tmp. rewrite tmp. clear tmp. apply id_left. Qed. (** There is a unique morphism in D such that all the roofs R which are in equivalence class eqclass are mapped to. This uses the assumption H' which says that all morphisms in SOM are mapped to isomorphisms in D. *) Lemma MorMap_iscontr (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) (x y : C) (eqclass : RoofEqclass x y) : iscontr (∑ g : D⟦F x, F y⟧, ∏ (R : Roof x y) (H1 : RoofEqclassIn (eqclass) R), g = MorMap D hsD F x y H' R). Proof. use (squash_to_prop (pr1 (RoofEqclassIs eqclass))). apply isapropiscontr. intros R. induction R as [R1 R2]. set (tmp := MorMap_iscomprelfun D hsD F x y H'). unfold iscomprelfun in tmp. use unique_exists. - exact (MorMap D hsD F x y H' R1). - cbn. intros R' HR'. apply tmp. use (eqax2 (RoofEqclassIs eqclass)). + exact R2. + exact HR'. - intros y0. apply impred_isaprop. intros t. apply impred_isaprop. intros t0. apply hsD. - intros y0 T. cbn beta in T. exact (T R1 R2). Qed. (** MorMap equality from MorMap_iscontr *) Lemma MorMap_iscontr_eq (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) (x y : C) (eqclass : RoofEqclass x y) (R : Roof x y) (H1 : RoofEqclassIn eqclass R) : pr1 (pr1 (MorMap_iscontr D hsD F H' x y eqclass)) = MorMap D hsD F x y H' R. Proof. apply (pr2 (pr1 (MorMap_iscontr D hsD F H' x y eqclass))). exact H1. Qed. (** Equivalence class equality of roof_comp_iscontr with roof_comp's using R1'' and R2'' *) Lemma roof_comp_iscontr_eqclass {x y z : ob C} (R1 : RoofEqclass x y) (R2 : RoofEqclass y z) (R1' : Roof x y) (R1'' : RoofEqclassIn R1 R1') (R2' : Roof y z) (R2'' : RoofEqclassIn R2 R2') : pr1 (pr1 (roof_comp_iscontr x y z R1 R2)) = RoofEqclassFromRoof (roof_comp R1' R2'). Proof. set (tmp := pr2 (pr1 (roof_comp_iscontr x y z R1 R2)) R1' R1'' R2' R2''). use RoofEqclassEq. - intros R3 HR3. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof (roof_comp R1' R2')))). + exact (roof_comp R1' R2'). + use (eqax2 (RoofEqclassIs (pr1 (pr1 (roof_comp_iscontr x y z R1 R2))))). * exact tmp. * exact HR3. + apply RoofEqclassFromRoofIn. - intros R3 HR3. use (eqax1 (RoofEqclassIs (pr1 (pr1 (roof_comp_iscontr x y z R1 R2))))). + exact (roof_comp R1' R2'). + use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof (roof_comp R1' R2')))). * apply RoofEqclassFromRoofIn. * exact HR3. + apply tmp. Qed. (** MorMap is linear with respect to composition in D *) Lemma MorMap_compose (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) {x y z : ob C} (R1 : Roof x y) (R2 : Roof y z) : MorMap D hsD F x z H' (roof_comp R1 R2) = MorMap D hsD F x y H' R1 · MorMap D hsD F y z H' R2. Proof. set (sqr := isLocClassSqr2 iLC R2 R1 y (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1)). unfold roof_comp. fold sqr. unfold MorMap at 1. cbn. set (iso1 := make_iso (# F (LocSqr2Mor2 sqr · RoofMor1 R1)) (H' sqr x (LocSqr2Mor2 sqr · RoofMor1 R1) (isLocClassComp iLC sqr R1 x (LocSqr2Mor2 sqr) (LocSqr2Mor2Is sqr) (RoofMor1 R1) (RoofMor1Is R1)))). set (iso2 := make_iso _ (H' sqr R1 (LocSqr2Mor2 sqr) (LocSqr2Mor2Is sqr))). set (iso3 := make_iso _ (H' R1 x (RoofMor1 R1) (RoofMor1Is R1))). set (iso4 := make_iso _ (H' R2 y (RoofMor1 R2) (RoofMor1Is R2))). assert (X : iso1 = iso_comp iso2 iso3). { use eq_iso. cbn. rewrite functor_comp. apply idpath. } rewrite X. rewrite inv_from_iso_comp. rewrite functor_comp. rewrite assoc. unfold MorMap. rewrite assoc. fold iso3 iso4. apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := LocSqr2Comm sqr). apply (pre_comp_with_iso_is_inj (C:=D) _ _ _ _ (pr2 iso2)). rewrite assoc. set (tmp2 := iso_inv_after_iso iso2). cbn in tmp2. cbn. rewrite tmp2. clear tmp2. rewrite id_left. apply (post_comp_with_iso_is_inj (C:=D) _ _ _ (pr2 iso4)). cbn. rewrite <- functor_comp. rewrite tmp. clear tmp. rewrite functor_comp. rewrite <- assoc. apply cancel_precomposition. rewrite <- assoc. set (tmp2 := iso_after_iso_inv iso4). cbn in tmp2. rewrite tmp2. rewrite id_right. apply idpath. Qed. (** Construct a roof representing s^{-1} from a morphism s in SOM *) Definition InvRoofFromMorInSom {x y : C} (s : y --> x) (S : SOM y x s) : Roof x y. Proof. use make_Roof. - exact y. - exact s. - exact (identity y). - exact S. Defined. (** Roof is equivalent to composition of its "components". *) Definition RoofDecomposeEqrel {x y : C} (R : Roof x y) : (make_eqrel _ (RoofEqrel x y)) R (roof_comp (InvRoofFromMorInSom (RoofMor1 R) (RoofMor1Is R)) (MorToRoof (RoofMor2 R))). Proof. unfold roof_comp. set (sqr := isLocClassSqr2 iLC (MorToRoof (RoofMor2 R)) (InvRoofFromMorInSom (RoofMor1 R) (RoofMor1Is R)) R (RoofMor1 (MorToRoof (RoofMor2 R))) (RoofMor1Is (MorToRoof (RoofMor2 R))) (RoofMor2 (InvRoofFromMorInSom (RoofMor1 R) (RoofMor1Is R)))). fold sqr. intros P X. apply X. clear X P. use make_RoofTop. - exact sqr. - exact (LocSqr2Mor2 sqr). - exact (identity (sqr)). - use (isLocClassComp iLC). + exact (LocSqr2Mor2Is sqr). + exact (RoofMor1Is R). - rewrite id_left. cbn. apply idpath. - cbn. set (tmp := LocSqr2Comm sqr). cbn in tmp. rewrite id_right in tmp. rewrite id_right in tmp. rewrite id_left. rewrite tmp. apply idpath. Qed. (** Composition of RoofEqclasses is the same as the equivalence class of composition of the roofs. *) Lemma RoofEqclassCompToRoofComp {x y z : C} (R1 : Roof x y) (R2 : Roof y z) : @compose loc_precategory x y z (RoofEqclassFromRoof R1) (RoofEqclassFromRoof R2) = (RoofEqclassFromRoof (roof_comp R1 R2)). Proof. apply RoofEqclassEqRoof. apply (pr2 (pr1 (roof_comp_iscontr x y z (RoofEqclassFromRoof R1) (RoofEqclassFromRoof R2)))). - apply RoofEqclassFromRoofIn. - apply RoofEqclassFromRoofIn. Qed. (** Equivalent roofs give rise to the same equivalence class. *) Lemma RoofEqClassEq1 {x y : ob C} (R1 R2 : Roof x y) (H : (make_eqrel _ (RoofEqrel x y)) R1 R2) : (RoofEqclassFromRoof R1) = (RoofEqclassFromRoof R2). Proof. use RoofEqclassEq. - intros R HR. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R2))). + exact R1. + use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof R1))). * exact (RoofEqclassFromRoofIn R1). * exact HR. + use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof R2))). * exact H. * exact (RoofEqclassFromRoofIn R2). - intros R HR. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R1))). + exact R2. + use (eqax2 (RoofEqclassIs (RoofEqclassFromRoof R2))). * exact (RoofEqclassFromRoofIn R2). * exact HR. + use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R1))). * exact R1. * exact H. * exact (RoofEqclassFromRoofIn R1). Qed. (** This lemma is used to show that inverse roof composed with roof gives the same equivalence class as the IdRoof. *) Lemma RoofEqclassCompInvRToId {x y : ob C} (f1 : Roof x y) : @compose loc_precategory _ _ _ (RoofEqclassFromRoof (InvRoofFromMorInSom (RoofMor1 f1) (RoofMor1Is f1))) (RoofEqclassFromRoof (MorToRoof (RoofMor1 f1))) = (RoofEqclassFromRoof (IdRoof x)). Proof. set (R1 := (InvRoofFromMorInSom (RoofMor1 f1) (RoofMor1Is f1))). set (R2 := (MorToRoof (RoofMor1 f1))). set (tmp := pr2 (pr1 (roof_comp_iscontr x f1 x (RoofEqclassFromRoof R1) (RoofEqclassFromRoof R2)))). cbn in tmp. use pathscomp0. - exact (RoofEqclassFromRoof (roof_comp R1 R2)). - use RoofEqclassEqRoof. apply tmp. + apply RoofEqclassFromRoofIn. + apply RoofEqclassFromRoofIn. - apply RoofEqClassEq1. intros P X. apply X. clear X P. clear tmp. unfold roof_comp. set (sqr := (isLocClassSqr2 iLC R2 R1 f1 (RoofMor1 R2) (RoofMor1Is R2) (RoofMor2 R1))). use make_RoofTop. + exact sqr. + cbn. exact (identity sqr). + exact (LocSqr2Mor2 sqr · (RoofMor1 f1)). + use (isLocClassComp iLC). * exact (isLocClassIs iLC _). * exact (RoofMor1Is _). + rewrite id_left. cbn. rewrite id_right. apply idpath. + rewrite id_left. rewrite id_right. cbn. set (tmp := LocSqr2Comm sqr). cbn in tmp. rewrite id_right in tmp. rewrite id_right in tmp. rewrite tmp. apply idpath. Qed. (** This lemma shows that the equivalence class of roofs induced by a roof R is equal to the equivalence class of roofs induced by composition of roofs (InvRoof (RoofMor1 R)) and (MorToRoof (RoofMor2 R)) *) Lemma RoofEqclassToRoofComp {x y : ob C} (R : Roof x y) : RoofEqclassFromRoof R = RoofEqclassFromRoof (roof_comp (InvRoofFromMorInSom (RoofMor1 R) (RoofMor1Is R)) (MorToRoof (RoofMor2 R))). Proof. use RoofEqclassEqRoof. use (eqax1 (RoofEqclassIs (RoofEqclassFromRoof R))). - exact R. - exact (RoofDecomposeEqrel R). - apply RoofEqclassFromRoofIn. Defined. Opaque RoofEqclassToRoofComp. (** This lemma is used to show that the localization functor [LocalizationUniversalFunctor] is indeed a functor. *) Lemma LocalizationUniversalFunctor_isfunctor (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : @is_functor loc_precategory_data D (functor_data_constr loc_precategory_ob_mor D (λ x : C, F x) (λ (x y : C) (eqclass : RoofEqclass x y), pr1 (pr1 (MorMap_iscontr D hsD F H' x y eqclass)))). Proof. split. - intros x. cbn. cbn in *. set (tmp := pr2 (pr1 (MorMap_iscontr D hsD F H' x x (IdRoofEqclass x))) (IdRoof x)). assert (H2 : MorMap D hsD F x x H' (IdRoof x) = identity (F x)). { unfold MorMap. cbn. set (iso := make_iso _ (H' x x (identity x) (isLocClassIs iLC x))). set (tmpp := iso_after_iso_inv iso). cbn in tmpp. apply tmpp. } use (pathscomp0 _ H2). apply tmp. apply RoofEqclassFromRoofIn. - intros x y z R1 R2. cbn. use (squash_to_prop (pr1 (RoofEqclassIs R1))). apply hsD. intros R1'. induction R1' as [R1' R1'']. use (squash_to_prop (pr1 (RoofEqclassIs R2))). apply hsD. intros R2'. induction R2' as [R2' R2'']. rewrite (MorMap_iscontr_eq D hsD F H' x y R1 R1' R1''). rewrite (MorMap_iscontr_eq D hsD F H' y z R2 R2' R2''). rewrite (roof_comp_iscontr_eqclass R1 R2 R1' R1'' R2' R2''). set (tmp := pr2 (pr1 (MorMap_iscontr D hsD F H' x z (RoofEqclassFromRoof (roof_comp R1' R2')))) (roof_comp R1' R2') (RoofEqclassFromRoofIn (roof_comp R1' R2'))). rewrite tmp. clear tmp. apply MorMap_compose. Qed. (** The universal functor which we use to factor F through loc_precategory *) Definition LocalizationUniversalFunctor (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : functor loc_precategory D. Proof. use make_functor. - use functor_data_constr. + intros x. exact (F x). + intros x y eqclass. apply (pr1 (pr1 (MorMap_iscontr D hsD F H' x y eqclass))). - exact (LocalizationUniversalFunctor_isfunctor D hsD F H'). Defined. (** We show that LocalizationUniversalFunctor satisfies the commutativity required for the universal functor. *) Definition LocalizationUniversalFunctorComm (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : functor_composite FunctorToLocalization (LocalizationUniversalFunctor D hsD F H') = F. Proof. use (functor_eq _ _ hsD). use total2_paths_f. - apply idpath. - cbn. use funextsec. intros a. use funextsec. intros b. use funextsec. intros f. use (pathscomp0 (MorMap_iscontr_eq D hsD F H' a b (RoofEqclassFromRoof (MorToRoof f)) (MorToRoof f) (RoofEqclassFromRoofIn _))). unfold MorToRoof. unfold MorMap. cbn. set (iso := (make_iso (# F (identity a)) (H' a a (identity a) (isLocClassIs iLC a)))). assert (X : iso = identity_iso (F a)). { use eq_iso. cbn. rewrite functor_id. apply idpath. } rewrite X. cbn. apply id_left. Qed. (** This lemma shows uniqueness of the functor LocalizationUniversalFunctor *) Lemma LocalizationUniversalFunctorUnique (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : C ⟦ x, y ⟧), SOM x y f → is_iso (# F f)) (y : functor loc_precategory D) (T : functor_composite FunctorToLocalization y = F) : y = (LocalizationUniversalFunctor D hsD F H'). Proof. use (functor_eq _ _ hsD). use total2_paths_f. - induction T. apply idpath. - use funextsec. intros a. use funextsec. intros b. use funextsec. intros f. induction T. cbn. use (squash_to_prop (pr1 (RoofEqclassIs f))). apply hsD. intros f'. induction f' as [f1 f2]. rewrite (RoofEqclassEqRoof f f1 f2). use (pathscomp0 _ (! (pr2 (pr1 (MorMap_iscontr D hsD (functor_composite FunctorToLocalization y) H' a b (RoofEqclassFromRoof f1))) f1 (RoofEqclassFromRoofIn f1)))). rewrite (RoofEqclassToRoofComp f1). rewrite <- (RoofEqclassCompToRoofComp (InvRoofFromMorInSom (RoofMor1 f1) (RoofMor1Is f1)) (MorToRoof (RoofMor2 f1))). use (pathscomp0 (@functor_comp loc_precategory D y _ _ _ (RoofEqclassFromRoof (InvRoofFromMorInSom (RoofMor1 f1) (RoofMor1Is f1))) (RoofEqclassFromRoof (MorToRoof (RoofMor2 f1))))). unfold functor_composite. cbn. apply cancel_postcomposition. set (iso1 := make_iso _ (H' f1 a (RoofMor1 f1) (RoofMor1Is f1))). apply (post_comp_with_iso_is_inj _ _ _ (pr2 iso1)). use (pathscomp0 _ (! (iso_after_iso_inv iso1))). unfold iso1. clear iso1. cbn. set (tmp := @functor_comp loc_precategory D y _ _ _ (RoofEqclassFromRoof (InvRoofFromMorInSom (RoofMor1 f1) (RoofMor1Is f1))) (RoofEqclassFromRoof (MorToRoof (RoofMor1 f1)))). unfold functor_on_morphisms in tmp. apply pathsinv0 in tmp. use (pathscomp0 tmp). clear tmp. rewrite RoofEqclassCompInvRToId. apply (@functor_id loc_precategory D y). Qed. (** The following lemma only applies when the objects of D satisfy isaset. *) Lemma LocalizationUniversalProperty (D : precategory) (hsD : has_homsets D) (hssD : isaset D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)) : iscontr (∑ H : functor loc_precategory D, functor_composite FunctorToLocalization H = F). Proof. use unique_exists. (* The functor *) - exact (LocalizationUniversalFunctor D hsD F H'). (* Commutativity of the functor *) - exact (LocalizationUniversalFunctorComm D hsD F H'). (* Uniqueness of commutativity *) - intros y. apply (functor_isaset _ _ hsD hssD). (* Uniqueness of the functor *) - exact (LocalizationUniversalFunctorUnique D hsD F H'). Defined. Opaque LocalizationUniversalProperty. (** The functor FunctorToLocalization maps morphisms in SOM to isomorphisms *) Definition FunctorToLocalization_is_iso : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# FunctorToLocalization f). Proof. intros x y f s. cbn. use (@is_iso_qinv loc_precategory). - exact (RoofEqclassFromRoof (InvRoofFromMorInSom f s)). - split. + set (sqr := isLocClassSqr2 iLC (InvRoofFromMorInSom f s) (MorToRoof f) y (RoofMor1 (InvRoofFromMorInSom f s)) (RoofMor1Is (InvRoofFromMorInSom f s)) (RoofMor2 (MorToRoof f))). set (PostS := isLocClassPost iLC sqr x y (LocSqr2Mor2 sqr) (LocSqr2Mor1 sqr) f s (! (LocSqr2Comm sqr))). rewrite RoofEqclassCompToRoofComp. use RoofEqClassEq1. intros P X. apply X. clear X P. unfold roof_comp. fold sqr. use make_RoofTop. * exact PostS. * exact (PostSwitchMor PostS). * exact (PostSwitchMor PostS · LocSqr2Mor2 sqr). * use (isLocClassComp iLC). -- exact (PostSwitchMorIs PostS). -- use (isLocClassComp iLC). ++ exact (LocSqr2Mor2Is sqr). ++ exact (isLocClassIs iLC x). * cbn. rewrite assoc. apply idpath. * cbn. rewrite assoc. rewrite id_right. rewrite id_right. exact (! (PostSwitchEq PostS)). + set (sqr := isLocClassSqr2 iLC (MorToRoof f) (InvRoofFromMorInSom f s) x (RoofMor1 (MorToRoof f)) (RoofMor1Is (MorToRoof f)) (RoofMor2 (InvRoofFromMorInSom f s))). rewrite RoofEqclassCompToRoofComp. use RoofEqClassEq1. intros P X. apply X. clear X P. unfold roof_comp. fold sqr. use make_RoofTop. * exact sqr. * exact (identity sqr). * exact (LocSqr2Mor2 sqr · f). * use (isLocClassComp iLC). -- exact (isLocClassIs iLC sqr). -- use (isLocClassComp iLC). ++ exact (LocSqr2Mor2Is sqr). ++ exact s. * rewrite id_left. cbn. rewrite id_right. apply idpath. * rewrite id_left. cbn. rewrite id_right. set (tmp := LocSqr2Comm sqr). cbn in tmp. rewrite id_right in tmp. rewrite id_right in tmp. rewrite tmp. apply idpath. Qed. (** Localization of categories is unique up to isomorphism of categories and loc_precategory is one such precategory. *) Lemma LocalizationUniversalCategory (CC : precategory) (hss : has_homsets CC) (In : functor C CC) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# In f)) (HH : ∏ (D : precategory) (hsD : has_homsets D) (F : functor C D) (H' : ∏ (x y : C) (f : x --> y) (s : SOM x y f), is_iso (# F f)), ∑ HH : functor CC D, (functor_composite In HH = F) × (∏ (yy : functor CC D) (comm : functor_composite In yy = F), yy = HH)) : ∑ D : (functor CC loc_precategory × functor loc_precategory CC), (functor_composite (dirprod_pr1 D) (dirprod_pr2 D) = (functor_identity _)) × (functor_composite (dirprod_pr2 D) (dirprod_pr1 D) = (functor_identity _)). Proof. set (comm1 := LocalizationUniversalFunctorComm CC hss In H'). set (tmp := HH loc_precategory has_homsets_loc_precategory FunctorToLocalization FunctorToLocalization_is_iso). induction tmp as [inv1 p]. induction p as [comm2 unique2]. set (inv2 := (LocalizationUniversalFunctor CC hss In H')). use tpair. - use make_dirprod. + exact inv1. + exact inv2. - use make_dirprod. + cbn. rewrite <- comm2 in comm1. rewrite functor_assoc in comm1. set (tmp := HH CC hss In H'). induction tmp as [F' CC2]. induction CC2 as [comm3 unique3]. set (tmp1 := unique3 (functor_identity CC) (functor_identity_right _ _ _)). set (tmp2 := unique3 (functor_composite inv1 (LocalizationUniversalFunctor CC hss In H')) comm1). rewrite <- tmp1 in tmp2. exact tmp2. + cbn. rewrite <- comm1 in comm2. rewrite functor_assoc in comm2. set (tmp := LocalizationUniversalFunctorUnique loc_precategory has_homsets_loc_precategory FunctorToLocalization FunctorToLocalization_is_iso). set (tmp1 := tmp _ comm2). fold inv2 in tmp1. set (tmp2 := tmp (functor_identity _) (functor_identity_right _ _ _)). rewrite <- tmp2 in tmp1. exact tmp1. Defined. Opaque LocalizationUniversalCategory. End def_roofs. UniMath-20231010/UniMath/CategoryTheory/Monads/000077500000000000000000000000001451125700300210455ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monads/Comonads.v000066400000000000000000000406451451125700300230100ustar00rootroot00000000000000(** ********************************************************** Contents: - dualization of the contents of [Monads.v], but not the part on substitution (that would become redecoration), i.e., Section [MonadsUsingCoproducts] Written by Ralph Matthes, 2023 ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section Comonad_disp_def. Context {C : category}. Definition disp_Comonad_data (F : functor C C) : UU := (F ⟹ F ∙ F) × (F ⟹ functor_identity C). Definition disp_δ {F : functor C C} (T : disp_Comonad_data F) : F ⟹ F ∙ F := pr1 T. Definition disp_ε {F : functor C C} (T : disp_Comonad_data F) : F ⟹ functor_identity C := pr2 T. (** the names of the components follow Mac Lane *) Definition disp_Comonad_laws {F : functor C C} (T : disp_Comonad_data F) : UU := ( (∏ c : C, disp_δ T c · disp_ε T (F c) = identity (F c)) × (∏ c : C, disp_δ T c · #F (disp_ε T c) = identity (F c)) ) × (∏ c : C, disp_δ T c · #F (disp_δ T c) = disp_δ T c · disp_δ T (F c)). Lemma isaprop_disp_Comonad_laws {F : functor C C} (T : disp_Comonad_data F) : isaprop (disp_Comonad_laws T). Proof. repeat apply isapropdirprod; apply impred; intro c; apply C. Qed. Definition disp_Comonad_Mor_laws {F F' : functor C C} (T : disp_Comonad_data F) (T' : disp_Comonad_data F') (α : F ⟹ F') : UU := (∏ a : C, α a · disp_δ T' a = disp_δ T a · #F (α a) · α (F' a)) × (∏ a : C, α a · disp_ε T' a = disp_ε T a). Lemma isaprop_disp_Comonad_Mor_laws {F F' : functor C C} (T : disp_Comonad_data F) (T' : disp_Comonad_data F') (α : F ⟹ F') : isaprop (disp_Comonad_Mor_laws T T' α). Proof. apply isapropdirprod; apply impred; intro c; apply C. Qed. Lemma comonads_category_id_subproof {F : functor C C} (T : disp_Comonad_data F) (Tlaws : disp_Comonad_laws T) : disp_Comonad_Mor_laws T T (nat_trans_id F). Proof. split; intros a; simpl. - now rewrite id_left, id_right, functor_id, id_right. - now apply id_left. Qed. Lemma comonads_category_comp_subproof {F F' F'' : functor C C} (T : disp_Comonad_data F) (Tlaws : disp_Comonad_laws T) (T' : disp_Comonad_data F') (T'laws : disp_Comonad_laws T') (T'' : disp_Comonad_data F'') (T''laws : disp_Comonad_laws T'') (α : F ⟹ F') (α' : F' ⟹ F'') : disp_Comonad_Mor_laws T T' α → disp_Comonad_Mor_laws T' T'' α' → disp_Comonad_Mor_laws T T'' (nat_trans_comp _ _ _ α α'). Proof. intros Hα Hα'. split; intros; simpl. - rewrite assoc'. set (H:=pr1 Hα' a); simpl in H. rewrite H; clear H. rewrite functor_comp. set (H:=pr1 Hα a); simpl in H. do 2 rewrite assoc. rewrite H; clear H; rewrite <- !assoc. do 2 apply maponpaths. now rewrite !assoc, nat_trans_ax. - rewrite assoc'. etrans. { apply maponpaths, (pr2 Hα'). } apply (pr2 Hα). Qed. Definition comonads_category_disp : disp_cat [C,C]. Proof. use disp_cat_from_SIP_data. - intro F. exact (∑ T : disp_Comonad_data F, disp_Comonad_laws T). - intros F F' [T Tlaws] [T' T'laws] α. exact (disp_Comonad_Mor_laws T T' α). - intros F F' [T Tlaws] [T' T'laws] α. apply isaprop_disp_Comonad_Mor_laws. - intros F [T Tlaws]. apply (comonads_category_id_subproof _ Tlaws). - intros F F' F'' [T Tlaws] [T' T'laws] [T'' T''laws] α α'. apply (comonads_category_comp_subproof _ Tlaws _ T'laws _ T''laws). Defined. Definition category_Comonad : category := total_category comonads_category_disp. Definition Comonad : UU := ob category_Comonad. Coercion functor_from_Comonad (T : Comonad) : functor C C := pr1 T. Definition δ (T : Comonad) : T ⟹ T ∙ T := pr112 T. Definition ε (T : Comonad) : T ⟹ functor_identity C := pr212 T. Lemma Comonad_law1 {T : Comonad} : ∏ c : C, δ T c · ε T (T c) = identity (T c). Proof. exact (pr1 (pr122 T)). Qed. Lemma Comonad_law2 {T : Comonad} : ∏ c : C, δ T c · #T (ε T c) = identity (T c). Proof. exact (pr2 (pr122 T)). Qed. Lemma Comonad_law3 {T : Comonad} : ∏ c : C, δ T c · #T (δ T c) = δ T c · δ T (T c). Proof. exact (pr222 T). Qed. Lemma comonads_category_disp_eq (F : functor C C) (T T' : comonads_category_disp F) : pr1 T = pr1 T' -> T = T'. Proof. intro H. induction T as [T Tlaws]. induction T' as [T' T'laws]. use total2_paths_f; [apply H |]. apply isaprop_disp_Comonad_laws. Qed. Lemma comonads_category_Pisset (F : functor C C) : isaset (∑ T : disp_Comonad_data F, disp_Comonad_laws T). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. { apply isasetdirprod; apply [C,C]. } intro T. apply isasetaprop. apply isaprop_disp_Comonad_laws. Qed. Lemma comonads_category_Hstandard {F : functor C C} (T : disp_Comonad_data F) (Tlaws : disp_Comonad_laws T) (T' : disp_Comonad_data F) (T'laws : disp_Comonad_laws T') : disp_Comonad_Mor_laws T T' (nat_trans_id F) → disp_Comonad_Mor_laws T' T (nat_trans_id F) → T,, Tlaws = T',, T'laws. Proof. intros H H'. apply subtypeInjectivity. { intro T0. apply isaprop_disp_Comonad_laws. } cbn. induction T as [δ ε]. induction T' as [δ' ε']. apply dirprodeq; cbn. - apply nat_trans_eq; [apply C|]. intro a. assert (Hinst := pr1 H a). cbn in Hinst. rewrite id_right in Hinst. rewrite id_left in Hinst. rewrite functor_id in Hinst. rewrite id_right in Hinst. exact (!Hinst). - apply nat_trans_eq; [apply C|]. intro a. assert (Hinst := pr2 H a). cbn in Hinst. rewrite id_left in Hinst. exact (!Hinst). Qed. Definition is_univalent_comonads_category_disp : is_univalent_disp comonads_category_disp. Proof. use is_univalent_disp_from_SIP_data. - exact comonads_category_Pisset. - intros F [T Tlaws] [T' T'laws]. apply comonads_category_Hstandard. Defined. End Comonad_disp_def. Arguments category_Comonad _ : clear implicits. Arguments Comonad _ : clear implicits. Definition is_univalent_category_Comonad {C : category} (HC : is_univalent C) : is_univalent (category_Comonad C). Proof. apply is_univalent_total_category. - apply is_univalent_functor_category. apply HC. - apply is_univalent_comonads_category_disp. Defined. Section pointfree. Context (C : category) (T0: functor C C) (T : disp_Comonad_data T0). Let EndC := [C, C]. Let ε := disp_ε T. Let δ := disp_δ T. Definition Comonad_laws_pointfree : UU := ( (nat_trans_comp _ _ _ δ (pre_whisker T0 ε) = identity(C:=EndC) T0) × (nat_trans_comp _ _ _ δ (post_whisker ε T0) = identity(C:=EndC) T0) ) × (nat_trans_comp _ _ _ δ (post_whisker δ T0) = nat_trans_comp _ _ _ δ (pre_whisker T0 δ)). Lemma pointfree_is_equiv: Comonad_laws_pointfree <-> disp_Comonad_laws T. Proof. split. - intro H. induction H as [[H1 H2] H3]. split. + split. * intro c. apply (maponpaths pr1) in H1. apply toforallpaths in H1. apply H1. * intro c. apply (maponpaths pr1) in H2. apply toforallpaths in H2. apply H2. + intro c. apply (maponpaths pr1) in H3. apply toforallpaths in H3. apply H3. - intro H. induction H as [[H1 H2] H3]. split. + split. * apply nat_trans_eq_alt. exact H1. * apply nat_trans_eq_alt. exact H2. + apply nat_trans_eq; try apply homset_property. exact H3. Qed. Let T0' := T0 : EndC. Let ε' := ε: EndC⟦T0', functor_identity C⟧. Let δ' := δ: EndC⟦T0', functor_compose T0' T0'⟧. Definition Comonad_laws_pointfree_in_functor_category : UU := ( (δ' · #(pre_composition_functor _ _ _ T0') ε' = identity(C:=EndC) T0') × (δ' · #(post_composition_functor _ _ _ T0') ε' = identity(C:=EndC) T0') ) × (δ' · #(post_composition_functor _ _ _ T0') δ' = (δ' · #(pre_composition_functor _ _ _ T0') δ')). (** the last variant of the laws is convertible with the one before *) Goal Comonad_laws_pointfree = Comonad_laws_pointfree_in_functor_category. Proof. apply idpath. Qed. End pointfree. Definition Comonad_Mor {C : category} (T T' : Comonad C) : UU := category_Comonad C ⟦T, T'⟧. Coercion nat_trans_from_monad_mor {C : category} (T T' : Comonad C) (s : Comonad_Mor T T') : T ⟹ T' := pr1 s. Definition Comonad_Mor_laws {C : category} {T T' : Comonad C} (α : T ⟹ T') : UU := (∏ a : C, α a · δ T' a = δ T a · #T (α a) · α (T' a)) × (∏ a : C, α a · ε T' a = ε T a). Definition Comonad_Mor_ε {C : category} {T T' : Comonad C} (α : Comonad_Mor T T') : ∏ a : C, α a · ε T' a = ε T a. Proof. exact (pr22 α). Qed. Definition Comonad_Mor_δ {C : category} {T T' : Comonad C} (α : Comonad_Mor T T') : ∏ a : C, α a · δ T' a = δ T a · #T (α a) · α (T' a). Proof. exact (pr12 α). Qed. Definition Comonad_Mor_equiv {C : category} {T T' : Comonad C} (α β : Comonad_Mor T T') : α = β ≃ (pr1 α = pr1 β). Proof. apply subtypeInjectivity; intro a. apply isaprop_disp_Comonad_Mor_laws. Defined. Lemma isaset_Comonad_Mor {C : category} (T T' : Comonad C) : isaset (Comonad_Mor T T'). Proof. apply homset_property. Qed. Definition Comonad_composition {C : category} {T T' T'' : Comonad C} (α : Comonad_Mor T T') (α' : Comonad_Mor T' T'') : Comonad_Mor T T'' := α · α'. Definition forgetfunctor_Comonad (C : category) : functor (category_Comonad C) [C,C] := pr1_category comonads_category_disp. Lemma forgetComonad_faithful (C : category) : faithful (forgetfunctor_Comonad C). Proof. apply faithful_pr1_category. intros T T' α. apply isaprop_disp_Comonad_Mor_laws. Qed. (** * Definition and lemmas for cobind *) Section cobind. (** Definition of cobind *) Context {C : category} {T : Comonad C}. Definition cobind {a b : C} (f : C⟦T a,b⟧) : C⟦T a,T b⟧ := δ T a · # T f. Lemma ε_cobind {a b : C} (f : C⟦T a,b⟧) : cobind f · ε T b = f. Proof. unfold cobind. rewrite assoc'. etrans. { apply maponpaths. apply (nat_trans_ax (ε T) _ _ f). } rewrite assoc. etrans. { apply cancel_postcomposition, Comonad_law1. } apply id_left. Qed. Lemma cobind_ε {a : C} : cobind (ε T a) = identity (T a). Proof. apply Comonad_law2. Qed. Lemma cobind_cobind {a b c : C} (f : C⟦T a,b⟧) (g : C⟦T b,c⟧) : cobind f · cobind g = cobind (cobind f · g). Proof. unfold cobind; rewrite assoc. rewrite !functor_comp. repeat rewrite assoc. apply cancel_postcomposition. etrans. { rewrite assoc'; apply maponpaths, (nat_trans_ax (δ T) _ _ f). } rewrite assoc. apply cancel_postcomposition. apply (!Comonad_law3 a). Qed. End cobind. (** * Helper lemma for showing two comonads are equal *) Section Comonad_eq_helper. (** * Alternate (equivalent) definition of Comonad *) Section Comonad'_def. Definition raw_Comonad_data (C : category) : UU := ∑ F : C -> C, (((∏ a b : ob C, a --> b -> F a --> F b) × (∏ a : ob C, F a --> F (F a))) × (∏ a : ob C, F a --> a)). Coercion functor_data_from_raw_Comonad_data {C : category} (T : raw_Comonad_data C) : functor_data C C := make_functor_data (pr1 T) (pr1 (pr1 (pr2 T))). Definition Comonad'_data_laws {C : category} (T : raw_Comonad_data C) := ((is_functor T) × (is_nat_trans T (functor_composite_data T T) (pr2 (pr1 (pr2 T))))) × (is_nat_trans T (functor_identity C) (pr2 (pr2 T))). Definition Comonad'_data (C : category) := ∑ (T : raw_Comonad_data C), Comonad'_data_laws T. Definition Comonad'_data_to_Comonad_data {C : category} (T : Comonad'_data C) : disp_Comonad_data (_,, pr1 (pr1 (pr2 T))) := ((pr2 (pr1 (pr2 (pr1 T))),, (pr2 (pr1 (pr2 T))))),, (pr2 (pr2 (pr1 T)),, (pr2 (pr2 T))). Definition Comonad' (C : category) := ∑ (T : Comonad'_data C), (disp_Comonad_laws (Comonad'_data_to_Comonad_data T)). End Comonad'_def. (** * Equivalence of Comonad and Comonad' *) Section Comonad_Comonad'_equiv. Definition Comonad'_to_Comonad {C : category} (T : Comonad' C) : Comonad C := (_,,(Comonad'_data_to_Comonad_data (pr1 T),, pr2 T)). Definition Comonad_to_raw_data {C : category} (T : Comonad C) : raw_Comonad_data C. Proof. use tpair. - exact (functor_on_objects T). - use tpair. + use tpair. * exact (@functor_on_morphisms C C T). * exact (δ T). + exact (ε T). Defined. Definition Comonad_to_Comonad'_data {C : category} (T : Comonad C) : Comonad'_data C := (Comonad_to_raw_data T,, ((pr2 (T : functor C C),, (pr2 (δ T))),, pr2 (ε T))). Definition Comonad_to_Comonad' {C : category} (T : Comonad C) : Comonad' C := (Comonad_to_Comonad'_data T,, pr22 T). Definition Comonad'_to_Comonad_to_Comonad' {C : category} (T : Comonad' C) : Comonad_to_Comonad' (Comonad'_to_Comonad T) = T := (idpath T). Definition Comonad_to_Comonad'_to_Comonad {C : category} (T : Comonad C) : Comonad'_to_Comonad (Comonad_to_Comonad' T) = T := (idpath T). End Comonad_Comonad'_equiv. Lemma Comonad'_eq_raw_data (C : category) (T T' : Comonad' C) : pr1 (pr1 T) = pr1 (pr1 T') -> T = T'. Proof. intro e. apply subtypePath. - intro. now apply isaprop_disp_Comonad_laws. - apply subtypePath. + intro. apply isapropdirprod. * apply isapropdirprod. -- apply (isaprop_is_functor C C), homset_property. -- apply (isaprop_is_nat_trans C C), homset_property. * apply (isaprop_is_nat_trans C C), homset_property. + apply e. Qed. Lemma Comonad_eq_raw_data (C : category) (T T' : Comonad C) : Comonad_to_raw_data T = Comonad_to_raw_data T' -> T = T'. Proof. intro e. apply (invmaponpathsweq (_,, (isweq_iso _ _ (@Comonad_to_Comonad'_to_Comonad C) (@Comonad'_to_Comonad_to_Comonad' C)))). now apply (Comonad'_eq_raw_data C). Qed. End Comonad_eq_helper. Section Comonads_from_adjunctions. (** This follow a remark of a single line on p.139 in Mac Lane, 2nd edition. *) Definition sndfunctor_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : functor D D := R ∙ L. Definition Comonad_data_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : disp_Comonad_data (sndfunctor_from_adjunction H). Proof. use tpair. - exact (pre_whisker R (post_whisker (adjunit H) L)). - exact (adjcounit H). Defined. Lemma Comonad_laws_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : disp_Comonad_laws (Comonad_data_from_adjunction H). Proof. cbn. use make_dirprod. + use make_dirprod. * intro c; cbn. apply triangle_id_left_ad. * intro c; cbn. rewrite <- functor_id. rewrite <- functor_comp. apply maponpaths. apply triangle_id_right_ad. + intro c; cbn. do 2 (rewrite <- functor_comp). apply maponpaths. apply pathsinv0. apply (nat_trans_ax ((unit_from_are_adjoints H))). Qed. Definition Comonad_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : Comonad D. Proof. exists (sndfunctor_from_adjunction H). exact (Comonad_data_from_adjunction H,, Comonad_laws_from_adjunction H). Defined. End Comonads_from_adjunctions. UniMath-20231010/UniMath/CategoryTheory/Monads/Derivative.v000066400000000000000000000604201451125700300233400ustar00rootroot00000000000000(** ********************************************************** Contents: - "maybe" monad (binary coproduct with a fixed object) [maybe_monad] - distributive laws for pairs of monads [monad_dist_laws] - in particular: the distributive law for the maybe monad and any monad [deriv_dist] - composition of two monads with a distributive law [monad_comp] - in particular: derivative of a monad (composing with maybe) [monad_deriv] - monad morphism from the first composand to the composition of monads [monad_to_comp] - in particular: monad morphism from a monad to its derivative [monad_to_deriv] - left module over a monad T obtained by composing a monad having a distributive law with T [LModule_comp_laws] - in particular: the derivative of a left module over a monad [LModule_deriv] - Commutation of module derivation with pullback [pb_LModule_deriv_iso] Written by: Joseph Helfer (May 2017) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.LModules. Local Open Scope cat. (** * Definition of distributive laws for Monads and composition of Monads cf. Beck "Distributive laws" (1969) *) Section comp_def. Section DistrLaws. Context {C : category} {S T : Monad C}. (** distributivity law for a pair of monads *) Definition monad_dist_laws (a : T ∙ S ⟹ S ∙ T) := (((∏ x : C, η S (T x) · a x = #T (η S x)) × (∏ x : C, #S (η T x) · a x = η T (S x))) × (∏ x : C, a (T x) · #T (a x) · μ T (S x) = #S (μ T x) · a x)) × (∏ x : C, #S (a x) · a (S x) · #T (μ S x) = μ S (T x) · a x). Definition monad_dist_law1 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) := (pr1 (pr1 (pr1 l))). Definition monad_dist_law2 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) := (pr2 (pr1 (pr1 l))). Definition monad_dist_law3 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) := (pr2 (pr1 l)). Definition monad_dist_law4 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) := pr2 l. End DistrLaws. (** composition of monads with a distributive law *) Definition monad_comp_mu {C : category} {S T : Monad C} (a : T ∙ S ⟹ S ∙ T) : (S ∙ T ∙ S ∙ T) ⟹ (S ∙ T) := nat_trans_comp _ _ _ (post_whisker (pre_whisker S a) T) (nat_trans_comp _ _ _ (pre_whisker (S ∙ S) (μ T)) (post_whisker (μ S) T)). Definition monad_comp_eta {C : category} {S T : Monad C} (a : T ∙ S ⟹ S ∙ T): functor_identity C ⟹ S ∙ T := nat_trans_comp _ _ _ (η S) (pre_whisker S (η T)). Definition monad_comp_data {C : category} {S T : Monad C} (a : T ∙ S ⟹ S ∙ T) : disp_Monad_data (S ∙ T) := tpair _ (monad_comp_mu a) (monad_comp_eta a). (** Below are the proofs of the monad laws for the composition of monads. We prove them as separate lemmas not only because they are somewhat lengthy, but also for the following reason: the μ and η for this monad are defined via operations on natural transformations, rather than their value being given explicitly at each object. However, for the proofs, it is desirable to have these explicit expressions; the easiest way to accomplish this is to write out the statements by hand in the desired form (as ugly as they may be). This is also done for the same reason later in the file, where the proofs of the individual lemmas are not as lengthy. *) (** Here is the diagram corresponding to this proof. The outside of the diagram represents the equation to be proved. The numbers indicate the order in which the sub-diagrams are used. TSTSx ---------------> TTSSx -----------> TSSx ------------> TSx ^ #T (a (Sx)) ^ μ T (SSx) ^ #T (μ S x) ^ | | / / |η T (STSx) |η T (TSSx) /id / | 1 | 3 / / a (Sx) / / STSx --------------> TSSx ------------ 4 / ^ ^ / | 2 /#T (η S (Sx)) / |η S (TSx) / / | _________________/ / |/ id / TSx ------------------------------------------------ *) Context {C : category} {S T : Monad C}. Local Lemma monad_comp_law1 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : ∏ x : C, (η S (T (S x))) · (η T (S (T (S x)))) · (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x))) = identity (T (S x)). Proof. intro x. (* 1 *) rewrite <- assoc. rewrite !(assoc ((η T) (S (T (S x))))). rewrite <- (nat_trans_ax (η T) (S (T (S x)))). (* 2 *) simpl. rewrite !assoc. etrans. { do 3 apply cancel_postcomposition. apply (monad_dist_law1 l). } (* 3 *) rewrite <- (assoc (# T ((η S) (S x)))). etrans. { apply cancel_postcomposition. apply cancel_precomposition. apply (Monad_law1). } (* 4 *) rewrite id_right. rewrite <- functor_comp. rewrite <- functor_id. now etrans; try apply maponpaths; try apply Monad_law1. Defined. (** The diagram for this proof (see above for explanation): TSTSx ---------------> TTSSx -----------> TSSx ------------> TSx ^ #T (a (Sx)) ^ μ T (SSx) ^ #T (μ S x) ^ | 1 / 2 / / |#T #S (η T (Sx)) / /id / | /#T (η T (SSx)) / / | _______________/ / / | / / / TSSx -------------------------------- 3 / ^ / | / |#T #S (η S x) / | id / TSx ------------------------------------------------ *) Local Lemma monad_comp_law2 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : ∏ x : C, #T (#S ((η S x) · (η T (S x)))) · (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x))) = identity (T (S x)). Proof. intro x. (* 1 *) rewrite !assoc. rewrite <- functor_comp. rewrite (functor_comp S). rewrite <- !assoc. etrans. { apply cancel_postcomposition. apply maponpaths. apply cancel_precomposition. apply (monad_dist_law2 l). } (* 2 *) rewrite functor_comp. rewrite <- assoc. rewrite (assoc (# T ((η T) (S (S x))))). rewrite Monad_law2. (* 3 *) rewrite id_left. rewrite <- functor_comp. rewrite <- functor_id. now etrans; try apply maponpaths; try apply Monad_law2. Defined. (** Here, more enlightening than a diagram is just the "strategy" of the proof: each side of the equation consists of some applications of the monad multiplications μ T and μ S and the distributive law 'a'. The strategy is - (1) using repeated applications of the third and fourth axioms for the distributive law and the naturality of μ T, μ S, and 'a' - to arrange for all the applications of 'a' to come first, and then the applications μ T and μ S. Thus, both sides are transformed to a composite TSTSTSx --> TTTSSSx -> TSx; then (2) the first composands are equal by the naturality of 'a', and the second composands are equal by the naturality and associativity of μ T and μ S. *) Local Lemma monad_comp_law3 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : ∏ x : C, #T (#S (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x)))) · (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x))) = #T (a (S (T (S x)))) · (μ T (S (S (T (S x)))) · #T (μ S (T (S x)))) · (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x))). Proof. intro x. (* 1 *) rewrite assoc. rewrite <- functor_comp. rewrite <- nat_trans_ax. do 2 rewrite (functor_comp S). rewrite (assoc _ _ (#S ((μ T) (S x)))). rewrite <- (assoc _ (#S ((μ T) (S x))) _). rewrite <- (monad_dist_law3 l). rewrite <- assoc. rewrite <- (assoc (a (T (S x)))). rewrite (assoc _ (a (T (S x)))). simpl. etrans. { apply cancel_postcomposition. apply maponpaths. apply cancel_precomposition. apply cancel_postcomposition. apply (nat_trans_ax a). } rewrite <- assoc. rewrite (assoc _ (# T (a (S x)))). etrans. { apply cancel_postcomposition. apply maponpaths. do 2 apply cancel_precomposition. apply cancel_postcomposition. apply (! (functor_comp T _ _)). } etrans. { apply cancel_postcomposition. apply maponpaths. do 2 apply cancel_precomposition. apply cancel_postcomposition. apply maponpaths. apply (nat_trans_ax a). } rewrite <- assoc. rewrite <- (assoc _ (# T ((μ S) (T (S x))))). rewrite (assoc (# T ((μ S) (T (S x))))). rewrite <- functor_comp. rewrite <- (monad_dist_law4 l). rewrite (assoc ((μ T) (S (S (T (S x)))))). rewrite <- (nat_trans_ax (μ T)). (* 2 *) rewrite !functor_comp. rewrite !assoc. rewrite <- functor_comp. etrans. { do 5 apply cancel_postcomposition. apply maponpaths. apply (nat_trans_ax a). } do 2 rewrite <- assoc. rewrite (assoc (# T ((μ T) (S (S x))))). rewrite <- !(functor_comp T ((μ T) (S (S x)))). rewrite <- (nat_trans_ax (μ T)). rewrite !functor_comp. rewrite !assoc. simpl. rewrite <- (assoc _ (# T (# T (# T (# S ((μ S) x)))))). rewrite <- !functor_comp. rewrite (@Monad_law3 C S). rewrite !functor_comp. rewrite !assoc. rewrite <- (assoc _ (# T ((μ T) (S x)))). rewrite (@Monad_law3 C T). apply pathsinv0. rewrite <- (assoc _ ((μ T) (T (S (S x))))). rewrite <- nat_trans_ax. now rewrite !assoc. Defined. Definition monad_comp {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : Monad C. Proof. exists (S ∙ T). exists (monad_comp_data a). exact (make_dirprod (make_dirprod (monad_comp_law1 l) (monad_comp_law2 l)) (monad_comp_law3 l)). Defined. (** morphism from the factor T to the composite S ∙ T of two monads *) Definition monad_to_comp_data {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : T ⟹ monad_comp l := post_whisker (η S) T. (** We prove the monad morphism laws as separate lemmas for the reason explained in the comment near the beginning of the file *) (** The diagram for this proof (see above for explanation): TTx------------------------------------------------------------------->Tx | \ μ T x | | ¯¯¯¯¯¯¯¯¯¯¯¯¯\ | |#T (η S (Tx)) \#T (#T (η S x) 5 #T (η S x)| | 2 \ | v #T (a x) v id μ T (Sx) | TSTx----------------TTSx------------------TTSx--------------------- | | | ^ \ | |#T #S #T (η S x) |#T #T #S (η S x) / \ | | | _____________/ #T #T (μ S x) 3 \ | | 1 | 4 / \ | v v / v v TSTSx-------------->TTSSx-------------------------->TSSx-------------->TSx #T (a (Sx)) μ T (SSx) #T (μ S x) *) Local Lemma monad_to_comp_law1 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : ∏ x : C, μ T x · #T (η S x) = #T (η S (T x)) · #T (#S (#T (η S x))) · (#T (a (S x)) · (μ T (S (S x)) · #T (μ S x))). Proof. intro x. (* 1 *) rewrite <- assoc. rewrite (assoc (# T (# S (# T ((η S) x))))). rewrite <- functor_comp. apply pathsinv0. etrans. { apply cancel_precomposition. apply cancel_postcomposition. apply maponpaths. apply (nat_trans_ax a). } (* 2 *) rewrite functor_comp. rewrite !assoc. rewrite <- functor_comp. rewrite (monad_dist_law1 l). (* 3 *) rewrite <- !assoc. rewrite <- (nat_trans_ax (μ T) (S (S x))). (* 4 *) rewrite (assoc (# T (# T (# S ((η S) x))))). simpl. rewrite <- !functor_comp. etrans. { apply cancel_precomposition. apply cancel_postcomposition. do 2 apply maponpaths. apply Monad_law2. } (* 5 *) rewrite !functor_id. rewrite id_left. now rewrite <- (nat_trans_ax (μ T) x). Defined. Local Definition monad_to_comp_law2 {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : ∏ x : C, η T x · #T (η S x) = η S x · (η T (S x)). Proof. intro x. now rewrite <- (nat_trans_ax (η T) x ). Defined. Definition monad_to_comp {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) : Monad_Mor T (monad_comp l) := (monad_to_comp_data l,, make_dirprod (monad_to_comp_law1 l) (monad_to_comp_law2 l)). End comp_def. (** * Definition of the "Maybe" monad (coproduct with a fixed object) *) Section maybe_def. Context {C : category} (o : C) (co : BinCoproducts C). Definition maybe_functor : functor C C := constcoprod_functor1 co o. (** [maybe_functor] is the same as [UniMath.SubstitutionSystems.SignatureExamples.genopt], which is introduced there only by [Let], and a different notion of distributive law is studied *) Definition maybe_mu : maybe_functor ∙ maybe_functor ⟹ maybe_functor := coproduct_nat_trans C C co (constant_functor C C o) maybe_functor maybe_functor (coproduct_nat_trans_in1 C C co (constant_functor C C o) (functor_identity C)) (nat_trans_id maybe_functor). Definition maybe_eta : functor_identity C ⟹ maybe_functor := coproduct_nat_trans_in2 C C co (constant_functor C C o) (functor_identity C). Definition maybe_monad_data : disp_Monad_data maybe_functor := maybe_mu ,, maybe_eta. (** We prove the monad laws as separate lemmas for the reason explained in the comment near the beginning of the file *) Local Lemma maybe_monad_law1 : ∏ c : C, BinCoproductIn2 (co o (co o c)) · BinCoproductArrow _ (BinCoproductIn1 (co o c)) (identity (co o c)) = identity (co o c). Proof. intro c. now rewrite BinCoproductIn2Commutes. Defined. Local Lemma maybe_monad_law2 : ∏ c : C, BinCoproductOfArrows C (co o c) (co o (co o c)) (identity o) (BinCoproductIn2 (co o c)) · BinCoproductArrow _ (BinCoproductIn1 (co o c)) (identity (co o c)) = identity (co o c). Proof. intro c. now rewrite precompWithBinCoproductArrow, id_left, <- (id_right (BinCoproductIn1 (co o c))), <- BinCoproductArrowEta. Defined. Local Lemma maybe_monad_law3 : ∏ c : C, BinCoproductOfArrows C (co o (co o (co o c))) (co o (co o c)) (identity o) (BinCoproductArrow (co o (co o c)) (BinCoproductIn1 (co o c)) (identity (co o c))) · BinCoproductArrow _ (BinCoproductIn1 (co o c)) (identity (co o c)) = BinCoproductArrow _ (BinCoproductIn1 (co o (co o c))) (identity (co o (co o c))) · BinCoproductArrow _ (BinCoproductIn1 (co o c)) (identity (co o c)). Proof. intro c. now rewrite precompWithBinCoproductArrow, postcompWithBinCoproductArrow, !id_right, postcompWithBinCoproductArrow, !id_left, BinCoproductIn1Commutes. Defined. Definition maybe_monad : Monad C. Proof. exists maybe_functor. exists maybe_monad_data. exact (make_dirprod (make_dirprod maybe_monad_law1 maybe_monad_law2) maybe_monad_law3). Defined. (** Definition of the derivative of a monad, i.e. precomposing with the maybe monad *) Section deriv_def. Definition functor_deriv {D : category} (T : functor C D) : functor C D := maybe_monad ∙ T. (** The distributive law for any monad with the Maybe monad. This is the obvious map (TX + Y) -> T (X + Y) - i.e., T(in1) on the first component and (in2 · η T) on the second component *) Definition deriv_dist (T : Monad C) : (T ∙ maybe_monad) ⟹ (maybe_monad ∙ T) := coproduct_nat_trans C C co (constant_functor C C o) T (functor_deriv T) (nat_trans_comp _ _ _ (coproduct_nat_trans_in1 C C co (constant_functor C C o) (functor_identity C)) (pre_whisker maybe_monad (η T))) (post_whisker (coproduct_nat_trans_in2 C C co (constant_functor C C o) (functor_identity C)) T). (** We prove the distributive law axioms as separate lemmas for the reason explained in the comment near the beginning of the file *) Local Lemma deriv_dist_law1 (T : Monad C) : ∏ x : C, BinCoproductIn2 (co o (T x)) · BinCoproductArrow _ (BinCoproductIn1 _ · η T _) (#T (BinCoproductIn2 _)) = #T (BinCoproductIn2 (co o x)). Proof. intro x. now rewrite BinCoproductIn2Commutes. Defined. Local Lemma deriv_dist_law2 (T : Monad C) : ∏ x : C, BinCoproductOfArrows C (co o x) (co o (T x)) (identity o) (η T x) · BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o x)) (#T (BinCoproductIn2 _)) = η T (co o x). Proof. intro x. rewrite precompWithBinCoproductArrow. rewrite id_left. etrans. { apply maponpaths. apply (!(nat_trans_ax (η T) _ _ _)). } now rewrite <- BinCoproductArrowEta. Defined. Local Lemma deriv_dist_law3 (T : Monad C) : ∏ x : C, BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o (T x))) (#T (BinCoproductIn2 _)) · #T (BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o x)) (#T (BinCoproductIn2 _))) · μ T (co o x) = BinCoproductOfArrows C (co o (T (T x))) (co o (T x)) (identity o) (μ T x) · BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o x)) (#T (BinCoproductIn2 _)). Proof. intro x. do 2 rewrite postcompWithBinCoproductArrow. rewrite <- functor_comp. rewrite BinCoproductIn2Commutes. rewrite <- (assoc (BinCoproductIn1 (co o (T x)))). rewrite <- (nat_trans_ax (η T) (co o (T x))). rewrite (assoc (BinCoproductIn1 (co o (T x)))). rewrite <- (assoc _ ((η T) (T (co o x)))). rewrite Monad_law1. simpl. rewrite BinCoproductIn1Commutes. rewrite precompWithBinCoproductArrow. rewrite id_left. rewrite id_right. now rewrite <- (nat_trans_ax (μ T) x). Defined. Local Lemma deriv_dist_law4 (T : Monad C) : ∏ x : C, BinCoproductOfArrows C (co o (co o (T x))) (co o (T (co o x))) (identity o) (BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o x)) (#T (BinCoproductIn2 _))) · BinCoproductArrow _ (BinCoproductIn1 _ · η T (co o (co o x))) (#T (BinCoproductIn2 _)) · #T (BinCoproductArrow _ (BinCoproductIn1 _) (identity _)) = BinCoproductArrow (co o (co o (T x))) (BinCoproductIn1 _) (identity (co o (T x))) · BinCoproductArrow (co o (T x)) (BinCoproductIn1 (co o x) · η T (co o x)) (#T (BinCoproductIn2 _)). Proof. intro x. rewrite precompWithBinCoproductArrow. rewrite postcompWithBinCoproductArrow. rewrite <- (assoc _ (# T (BinCoproductIn2 (co o (co o x))))). rewrite <- functor_comp. rewrite BinCoproductIn2Commutes. rewrite functor_id. rewrite id_right. rewrite id_left. rewrite <- assoc. rewrite <- (nat_trans_ax (η T) (co o (co o x))). simpl. rewrite assoc. rewrite BinCoproductIn1Commutes. rewrite postcompWithBinCoproductArrow. rewrite id_left. now rewrite BinCoproductIn1Commutes. Defined. Definition deriv_dist_is_monad_dist (T : Monad C) : monad_dist_laws (deriv_dist T) := make_dirprod (make_dirprod (make_dirprod (deriv_dist_law1 T) (deriv_dist_law2 T)) (deriv_dist_law3 T)) (deriv_dist_law4 T). Definition monad_deriv (T: Monad C) : Monad C := monad_comp (deriv_dist_is_monad_dist T). (** the morphism from a monad to its derivative *) Definition monad_to_deriv (T : Monad C) : Monad_Mor T (monad_deriv T) := monad_to_comp (deriv_dist_is_monad_dist T). (** derivative of a left module over a monad *) Lemma LModule_comp_law1 {D : category} {T : Monad C} {S : Monad C} {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) (L : LModule T D) : ∏ x : C, #L (#S (η T x)) · (#L (a x) · lm_mult T L (S x)) = identity (L (S x)). Proof. intro x. now rewrite assoc, <- functor_comp, (monad_dist_law2 l), (LModule_law1 T (S x)). Defined. Lemma LModule_comp_law2 {D : category} {T : Monad C} {S : Monad C} {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) (L : LModule T D) : ∏ x : C, #L (#S (μ T x)) · (#L (a x) · lm_mult T L (S x)) = (#L (a (T x)) · lm_mult T L (S (T x))) · (#L (a x) · lm_mult T L (S x)). Proof. intro x. rewrite assoc. rewrite <- functor_comp. rewrite <- (monad_dist_law3 l). rewrite !functor_comp. rewrite <- assoc. rewrite (LModule_law2 T (S x)). rewrite assoc. rewrite <- (assoc _ (#L (#T (a x)))). etrans. { apply cancel_postcomposition. apply cancel_precomposition. apply (nat_trans_ax (lm_mult T L)). } now rewrite !assoc. Defined. Definition LModule_comp_data {D : category} {T : Monad C} {S : Monad C} (a : T ∙ S ⟹ S ∙ T) (L : LModule T D) : LModule_data T D := (S ∙ L,, nat_trans_comp _ _ _ (post_whisker a L) (pre_whisker S (lm_mult T L))). Definition LModule_comp_laws {D : category} {T : Monad C} {S : Monad C} {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a) (L : LModule T D) : (LModule_laws T (LModule_comp_data a L)) := make_dirprod (LModule_comp_law1 l L) (LModule_comp_law2 l L). Definition LModule_deriv {D : category} {T : Monad C} (L : LModule T D) : LModule T D := (LModule_comp_data (deriv_dist T) L,, LModule_comp_laws (deriv_dist_is_monad_dist T) L). End deriv_def. End maybe_def. (** Derivation on modules commutes with the pullback: if m is a monad morphism, then m*(M') is isomorphic to m*(M)' *) Section pullback_deriv. Context {C : category} (o : C) (* derivation X ↦ X + o *) (bcpC : limits.bincoproducts.BinCoproducts C ) {D : category}. Let MOD (R : Monad C) := (category_LModule R D). Context {R S : Monad C} (f : Monad_Mor R S) (M : LModule S D). Local Notation "M '" := (LModule_deriv o bcpC M) (at level 30). Local Notation pb_d := (pb_LModule f (M ')). Local Notation d_pb := ((pb_LModule f M ) '). (** Pointwise equality of the involved multiplication *) Lemma pb_LModule_deriv_eq_mult c : # M (BinCoproductOfArrows C (bcpC o (R c)) (bcpC o (S c)) (identity o) (pr1 (pr1 f) c)) · (# (pr1 M) (BinCoproductArrow (bcpC o (S c)) (BinCoproductIn1 (bcpC o c) · pr1 (η S) (bcpC o c)) (# (pr1 (pr1 S)) (BinCoproductIn2 (bcpC o c)))) · pr1 (lm_mult S M) (bcpC o c)) = # (pr1 M) (BinCoproductArrow (bcpC o (R c)) (BinCoproductIn1 (bcpC o c) · pr1 (η R) (bcpC o c)) (# (pr1 (pr1 R)) (BinCoproductIn2 (bcpC o c)))) · (# (pr1 M) (pr1 (pr1 f) (bcpC o c)) · (lm_mult S M) (bcpC o c)). Proof. repeat rewrite assoc. apply cancel_postcomposition. do 2 rewrite <- functor_comp. apply maponpaths. etrans;[ apply precompWithBinCoproductArrow|]. rewrite id_left. rewrite postcompWithBinCoproductArrow. apply map_on_two_paths. - rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. apply Monad_Mor_η. - apply pathsinv0. apply nat_trans_ax. Qed. Definition pb_LModule_deriv_iso : iso (C := MOD R) pb_d d_pb := LModule_same_func_iso (pb_LModule_laws f (M ')) (LModule_comp_laws (deriv_dist_is_monad_dist o bcpC R) (pb_LModule f M)) pb_LModule_deriv_eq_mult. End pullback_deriv. UniMath-20231010/UniMath/CategoryTheory/Monads/KTriples.v000066400000000000000000000332541451125700300230000ustar00rootroot00000000000000(* ============================================================================================= *) (** * Kleisli Triples *) (* *) (* Contents: *) (* *) (* - Theory of monads based on the Haskell-style bind operator. *) (* - Category of Kleisli monads [category_Kleisli C] on [C] *) (* - Forgetful functor [forgetfunctor_Kleisli] from monads to endofunctors on [C] *) (* *) (* Written by: Marco Maggesi, Cosimo Perini (2017) *) (* ============================================================================================= *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.RelativeMonads. Local Open Scope cat. Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )). (* --------------------------------------------------------------------------------------------- *) (* ** Definition of Kleisli. *) (* --------------------------------------------------------------------------------------------- *) Section Kleisli_defn. Context {C : category}. (* ----- Datatype for Kleisli data ----- *) Definition Kleisli_Data : UU := ∑ T : C → C, (∏ a : C, a --> T a) × (∏ a b : C, (a --> T b) → (T a --> T b)). (* ----- Projections ----- *) Definition Kleisli_Data_ob (T: Kleisli_Data) (c : C) : C := pr1 T c. Coercion Kleisli_Data_ob : Kleisli_Data >-> Funclass. Definition η (T : Kleisli_Data) : ∏ a : C, a --> T a := pr1 (pr2 T). Definition bind (T : Kleisli_Data) {a b : C} : C⟦a,T b⟧ → C⟦T a,T b⟧ := pr2 (pr2 T) a b. (* ----- Kleisli Laws: Data and Projections ----- *) Definition Kleisli_Laws (T : Kleisli_Data) := (∏ a, bind T (η T a) = identity (T a)) × (∏ a b (f : C⟦a,T b⟧), bind T f ∘ η T a = f) × (∏ a b c (f : C⟦a,T b⟧) (g : C⟦b,T c⟧), bind T g ∘ bind T f = bind T (bind T g ∘ f)). Lemma isaprop_Kleisli_Laws (T : Kleisli_Data) : isaprop (Kleisli_Laws T). Proof. repeat apply isapropdirprod; repeat (apply impred_isaprop; intros); apply homset_property. Defined. Definition bind_bind {T : Kleisli_Data} (H: Kleisli_Laws T) : ∏ a b c (f : C⟦a,T b⟧) (g : C⟦b,T c⟧), bind T g ∘ bind T f = bind T (bind T g ∘ f) := pr2 (pr2 H). Definition bind_η {T : Kleisli_Data} (H : Kleisli_Laws T) : ∏ a b (f : C⟦a,T b⟧), bind T f ∘ η T a = f := pr1 (pr2 H). Definition η_bind {T : Kleisli_Data} (H : Kleisli_Laws T) : ∏ a, bind T (η T a) = identity (T a) := pr1 H. (* ----- Packing the whole data -----*) Definition KleisliMonad : UU := ∑ (T : Kleisli_Data), Kleisli_Laws T. (* argument [C] will be set as not implicit after the end of the section *) Coercion Kleisli_Data_from_Kleisli (T : KleisliMonad) : Kleisli_Data := pr1 T. Coercion kleisli_laws (T : KleisliMonad) : Kleisli_Laws (pr1 T) := pr2 T. End Kleisli_defn. Arguments KleisliMonad: clear implicits. Arguments Kleisli_Data: clear implicits. (* --------------------------------------------------------------------------------------------- *) (* ** KleisliMonad Precategory *) (* --------------------------------------------------------------------------------------------- *) Section Kleisli_precategory. (* ----- Morphisms of KleisliMonad Monads ----- *) Definition Kleisli_Mor_laws {C : category} (T T': Kleisli_Data C) (α : ∏ a : C, T a --> T' a) : UU := (∏ a : C, α a ∘ η T a = η T' a) × (∏ (a b : C) (f : C⟦a,T b⟧), bind T' (α b ∘ f) ∘ α a = α b ∘ (bind T f)). Lemma isaprop_Kleisli_Mor_laws {C : category} (T T' : Kleisli_Data C) (α : ∏ a : C, T a --> T' a) : isaprop (Kleisli_Mor_laws T T' α). Proof. apply isapropdirprod; repeat (apply impred_isaprop; intros); apply homset_property. Defined. Definition Kleisli_Mor {C : category} (T T' : Kleisli_Data C) : UU := ∑ (α : ∏ a : C, T a --> T' a), Kleisli_Mor_laws T T' α. Definition nat_trans_from_kleisli_mor {C : category} {T T' : Kleisli_Data C} (s : Kleisli_Mor T T') : ∏ a : C, T a --> T' a := pr1 s. Definition Kleisli_Mor_η {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : ∏ a : C, η T a · nat_trans_from_kleisli_mor α a = η T' a := pr1 (pr2 α). Definition Kleisli_Mor_bind {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : ∏ (a b : C) (f : C⟦a,T b⟧), bind T' (nat_trans_from_kleisli_mor α b ∘ f) ∘ nat_trans_from_kleisli_mor α a = nat_trans_from_kleisli_mor α b ∘ (bind T f) := pr2 (pr2 α). Definition Kleisli_Mor_equiv {C : category} {T T' : KleisliMonad C} (α β : Kleisli_Mor T T') : α = β ≃ (nat_trans_from_kleisli_mor α = nat_trans_from_kleisli_mor β). Proof. apply subtypeInjectivity. intro a. now apply isaprop_Kleisli_Mor_laws. Defined. (* ----- Definition of map with some laws ----- *) Definition map {C : category} (T : Kleisli_Data C) {a b : C} (f : a --> b) : T a --> T b := bind T (η T b ∘ f). Lemma map_id {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : ∏ a : C, map T (identity a) = identity (T a). Proof. intro. unfold map. rewrite id_left. now apply η_bind. Defined. Lemma map_map {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : ∏ (a b c : C) (f : a --> b) (g : b --> c), map T (g ∘ f) = map T g ∘ map T f. Proof. intros. unfold map. rewrite (bind_bind H). do 2 rewrite <- assoc. now rewrite (bind_η H). Defined. Lemma map_bind {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : ∏ (a b c : C) (f : b --> c) (g : a --> T b), map T f ∘ bind T g = bind T (map T f ∘ g). Proof. intros. unfold map. now rewrite (bind_bind H). Defined. Lemma bind_map {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : ∏ (a b c : C) (f : b --> T c) (g : a --> b), bind T f ∘ map T g = bind T (f ∘ g). Proof. intros. unfold map. rewrite (bind_bind H). rewrite <- assoc. now rewrite (bind_η H). Defined. Lemma map_η {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : ∏ (a b : C) (f : a --> b), map T f ∘ η T a = η T b ∘ f. Proof. intros. unfold map. now rewrite (bind_η H). Defined. Definition μ {C : category} (T : Kleisli_Data C) (a : C) : T (T a) --> T a := bind T (identity (T a)). (* ----- Morphisms of KleisliMonad Monads are Natural Transformations ----- *) Definition kleisli_functor_data {C : category} (T : Kleisli_Data C) : functor_data C C := make_functor_data T (@map C T). Definition is_functor_kleisli {C : category} {T : Kleisli_Data C} (H : Kleisli_Laws T) : is_functor(kleisli_functor_data T) := map_id H ,, map_map H. Definition kleisli_functor {C : category} (T : KleisliMonad C) : functor C C := make_functor (kleisli_functor_data T) (is_functor_kleisli T). Lemma is_nat_trans_kleisli_mor {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : is_nat_trans (kleisli_functor T) (kleisli_functor T') (nat_trans_from_kleisli_mor α). Proof. unfold is_nat_trans. intros. simpl. unfold map. rewrite <- (Kleisli_Mor_bind α). rewrite <- assoc. now rewrite (Kleisli_Mor_η α). Defined. Definition nat_trans_kleisli_mor {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : nat_trans (kleisli_functor T) (kleisli_functor T') := make_nat_trans (kleisli_functor T) (kleisli_functor T') (nat_trans_from_kleisli_mor α) (is_nat_trans_kleisli_mor α). Lemma Kleisli_Mor_eq {C : category} {T T' : KleisliMonad C} (α α' : Kleisli_Mor T T') : nat_trans_from_kleisli_mor α = nat_trans_from_kleisli_mor α' → α = α'. Proof. apply Kleisli_Mor_equiv. Defined. (* ----- η natural transformation. ----- *) Lemma is_nat_trans_η {C : category} (T : KleisliMonad C) : is_nat_trans (functor_identity C) (kleisli_functor T) (η T). Proof. unfold is_nat_trans. simpl. intros. now rewrite (map_η T). Defined. Definition nat_trans_η {C : category} (T : KleisliMonad C) : functor_identity C ⟹ kleisli_functor T := (η T,, is_nat_trans_η T). (* ----- μ natural transformation. ----- *) Lemma is_nat_trans_μ {C : category} (T : KleisliMonad C) : is_nat_trans (kleisli_functor T ∙ kleisli_functor T) (kleisli_functor T) (μ T). Proof. unfold is_nat_trans, μ. simpl. intros. rewrite (map_bind T), (bind_map T). now rewrite id_left, id_right. Defined. Definition nat_trans_μ {C : category} (T : KleisliMonad C) : kleisli_functor T ∙ kleisli_functor T ⟹ kleisli_functor T := μ T,, is_nat_trans_μ T. (* ----- Identity Morphism ----- *) Lemma Kleisli_identity_laws {C : category} (T : KleisliMonad C) : Kleisli_Mor_laws T T (λ a : C, identity (T a)). Proof. split; simpl; intros a. - apply id_right. - intros. do 2 rewrite id_right; apply id_left. Defined. Definition Kleisli_identity {C : category} (T : KleisliMonad C) : Kleisli_Mor T T := (λ a : C, identity (T a)),, Kleisli_identity_laws T. (* ----- Composition of Morphisms ----- *) Lemma Kleisli_composition_laws {C : category} {T T' T'' : KleisliMonad C} (α : Kleisli_Mor T T') (α' : Kleisli_Mor T' T'') : Kleisli_Mor_laws T T'' (λ a : C, nat_trans_from_kleisli_mor α a · nat_trans_from_kleisli_mor α' a). Proof. split; intros; simpl. - rewrite assoc. set (H := Kleisli_Mor_η α). rewrite H. apply Kleisli_Mor_η. - pathvia (nat_trans_from_kleisli_mor α a · (nat_trans_from_kleisli_mor α' a · bind T'' ((f · nat_trans_from_kleisli_mor α b) · nat_trans_from_kleisli_mor α' b))). * now repeat rewrite assoc. * rewrite (Kleisli_Mor_bind α'). rewrite assoc. rewrite (Kleisli_Mor_bind α). apply pathsinv0. apply assoc. Defined. Definition Kleisli_composition {C : category} {T T' T'' : KleisliMonad C} (α : Kleisli_Mor T T') (α' : Kleisli_Mor T' T'') : Kleisli_Mor T T'' := (λ a : C, nat_trans_from_kleisli_mor α a · nat_trans_from_kleisli_mor α' a),, Kleisli_composition_laws α α'. (* ----- Precategory of KleisliMonad Monads ----- *) Definition precategory_Kleisli_ob_mor (C : category) : precategory_ob_mor := make_precategory_ob_mor (KleisliMonad C) Kleisli_Mor. Definition precategory_Kleisli_Data (C : category) : precategory_data := make_precategory_data (precategory_Kleisli_ob_mor C) (@Kleisli_identity C) (@Kleisli_composition C). Lemma precategory_Kleisli_axioms (C : category) : is_precategory (precategory_Kleisli_Data C). Proof. repeat split; simpl; intros. - apply (invmap (Kleisli_Mor_equiv _ _ )). apply funextsec. intros x. apply id_left. - apply (invmap (Kleisli_Mor_equiv _ _ )). apply funextsec. intros x. apply id_right. - apply (invmap (Kleisli_Mor_equiv _ _ )). apply funextsec. intros x. apply assoc. - apply (invmap (Kleisli_Mor_equiv _ _ )). apply funextsec. intros x. apply assoc'. Defined. Definition precategory_Kleisli (C : category) : precategory := precategory_Kleisli_Data C,, precategory_Kleisli_axioms C. Lemma has_homsets_Kleisli (C : category) : has_homsets (precategory_Kleisli C). Proof. intros F G. simpl. unfold Kleisli_Mor. apply isaset_total2 . - apply impred_isaset. intro. apply C. - intros. apply isasetaprop. apply isaprop_Kleisli_Mor_laws. Defined. (* ----- Category of KleisliMonad Monads ----- *) Definition category_Kleisli (C : category) : category := precategory_Kleisli C ,, has_homsets_Kleisli C. Definition forgetfunctor_Kleisli (C : category) : functor (category_Kleisli C) (functor_category C C). Proof. use make_functor. - simpl. use make_functor_data. + simpl. exact (λ T : KleisliMonad C, kleisli_functor T). + simpl. intros T T' α. exact (nat_trans_kleisli_mor α). - split. + red. intros. simpl. apply nat_trans_eq. * apply C. * intros; apply idpath. + unfold functor_compax. simpl. intros. apply nat_trans_eq. * apply C. * intros. apply idpath. Defined. Lemma forgetKleisli_faithful (C : category) : faithful (forgetfunctor_Kleisli C). Proof. intros T T'. simpl. apply isinclbetweensets. - apply isaset_total2. + apply impred_isaset. intros. apply C. + intros. apply isasetaprop. apply isaprop_Kleisli_Mor_laws. - apply isaset_nat_trans. apply C. - intros α α' p. apply Kleisli_Mor_eq. apply funextsec. intro c. change (pr1 (nat_trans_kleisli_mor α) c = pr1 (nat_trans_kleisli_mor α') c). now rewrite p. Defined. (** inherit the univalence result from [precategory_RelMonad] *) (* Lemma is_univalent_precategory_Kleisli {C : category} (H: is_univalent C) (R R': KleisliMonad C) : is_univalent (category_Kleisli C). Proof. exact (is_univalent_RelMonad H (functor_identity C) R R'). Qed. *) End Kleisli_precategory. UniMath-20231010/UniMath/CategoryTheory/Monads/KTriplesEquiv.v000066400000000000000000000450101451125700300240030ustar00rootroot00000000000000(* ============================================================================================= *) (* * Equivalence of category between Kleisli monads and multiplicative monads. *) (* *) (* Contents: *) (* - kleislification (functor from multiplicative monads to Kleisli monads). *) (* - unkleislification (functor from Kleisli monads to multiplicative monads). *) (* - kleislification/unkleislification is an equivalence of categories. *) (* *) (* Written by: Marco Maggesi, Cosimo Perini (2017) *) (* ============================================================================================= *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KTriples. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Local Open Scope cat. Lemma Monad_Mor_eq {C : category} (T T' : Monad C) (α β : Monad_Mor T T') (e : ∏ a : C, α a = β a) : α = β. Proof. use subtypePath. - intro. apply isaprop_disp_Monad_Mor_laws; apply homset_property. - now apply (nat_trans_eq_alt). Defined. (* ----- Monad associated to a Kleisli monad ----- *) Definition unkleislify_data {C : category} (T : KleisliMonad C) : disp_Monad_data (kleisli_functor T) := nat_trans_μ T ,, nat_trans_η T. Lemma unkleislify_laws {C : category} (T : KleisliMonad C) : disp_Monad_laws (unkleislify_data T). Proof. split; simpl; intros; unfold μ. + split; intros. * apply (bind_η T). * rewrite (bind_map T). rewrite id_right. apply (η_bind T). + rewrite (bind_map T). rewrite id_right. rewrite (bind_bind T). now rewrite id_left. Defined. Definition unkleislify {C : category} (T : KleisliMonad C) : Monad C := kleisli_functor T ,, unkleislify_data T ,, unkleislify_laws T. (* ----- Monad morphism associated to a Kleisli monad morphism ----- *) Lemma unkleislify_mor_laws {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : Monad_Mor_laws (T := unkleislify T) (T' := unkleislify T') (nat_trans_kleisli_mor α). Proof. split; simpl; intros; unfold μ. + rewrite <- assoc. rewrite (bind_map T'). rewrite id_right. rewrite <- (Kleisli_Mor_bind α). now rewrite id_left. + apply Kleisli_Mor_η. Defined. Definition unkleislify_mor {C : category} {T T' : KleisliMonad C} (α : Kleisli_Mor T T') : Monad_Mor (unkleislify T) (unkleislify T') := nat_trans_kleisli_mor α ,, unkleislify_mor_laws α. (* ----- Functor from KleisliMonad to Monads. ----- *) Definition functor_data_unkleislify (C : category) : functor_data (category_Kleisli C) (category_Monad C). Proof. use make_functor_data. - exact (λ T : KleisliMonad C, unkleislify T). - intros. apply (unkleislify_mor X). Defined. Lemma is_functor_unkleislify {C : category} : is_functor (functor_data_unkleislify C). Proof. split; red; simpl; intros. - unfold unkleislify_mor. apply subtypePath; simpl. + intro. apply isaprop_disp_Monad_Mor_laws; apply homset_property. + apply subtypePath; simpl. * intro. apply isaprop_is_nat_trans; apply homset_property. * now apply funextsec. - apply subtypePath; simpl. + intro. apply isaprop_disp_Monad_Mor_laws; apply homset_property. + apply subtypePath; simpl. * intro. apply isaprop_is_nat_trans; apply homset_property. * now apply funextsec. Defined. Definition functor_unkleislify {C : category} : functor (category_Kleisli C) (category_Monad C) := (functor_data_unkleislify C) ,, is_functor_unkleislify. (* ----- Support Lemmas. ----- *) Lemma Monad_law4 {C : category} {T : Monad C} {a b : C} (f : a --> b) : Monads.η T a · # T f = f · Monads.η T b. Proof. apply pathsinv0. apply (nat_trans_ax (Monads.η T) _ _ f). Defined. Lemma Monad_law5 {C : category} {T : Monad C} {a b: C} (f: a --> b) : # T (# T f) · (Monads.μ T b) = (Monads.μ T a) · (# T f). Proof. apply (nat_trans_ax (Monads.μ T) _ _ f). Defined. (* ----- Kleisli monad associated to a Monad. ----- *) Definition Monad_Kleisli_data {C : category} (T : Monad C) : Kleisli_Data C. Proof. exists T. exact ((Monads.η T: nat_trans_data _ _),, (@Monads.bind C T)). Defined. Lemma Monad_Kleisli_laws {C : category} (T : Monad C) : Kleisli_Laws (Monad_Kleisli_data T). Proof. split. - exact Monad_law2. - split. + exact (@Monads.η_bind C T). + exact (@Monads.bind_bind C T). Defined. (* ----- Kleisli monad morphism associated to a Monad morphism. ----- *) Definition kleislify {C : category} (M : Monad C) : KleisliMonad C := Monad_Kleisli_data M ,, Monad_Kleisli_laws M. Lemma kleislify_mor_law {C : category} {M M' : Monad C} (α : Monad_Mor M M') : Kleisli_Mor_laws (kleislify M) (kleislify M') (λ x : C, α x). Proof. split; simpl; intros. - apply Monad_Mor_η. - unfold bind. unfold Monad_Kleisli_data. simpl. unfold Monads.bind. rewrite functor_comp. do 2 rewrite assoc. set (H := nat_trans_ax α). simpl in H. rewrite <- H. rewrite assoc4. rewrite <-H. rewrite <- assoc4. set (H2 := Monad_Mor_μ α b). simpl in H2. do 3 rewrite <- assoc. unfold Monads.μ in H2. simpl in H2. unfold Monads.μ. simpl. do 3 rewrite assoc. rewrite assoc4. repeat rewrite <- assoc. apply cancel_precomposition. rewrite assoc. rewrite H. apply pathsinv0. apply H2. Defined. Definition kleislify_mor {C : category} {M M' : Monad C} (α : Monad_Mor M M') : Kleisli_Mor (kleislify M) (kleislify M') := (λ x:C, α x) ,, kleislify_mor_law α. Definition functor_data_kleislify (C : category) : functor_data (category_Monad C) (category_Kleisli C). Proof. use make_functor_data. - exact (λ T : Monad C, kleislify T). - intros. apply (kleislify_mor X). Defined. (* ----- Functoriality of [kleislify]. ----- *) Lemma is_functor_kleislify {C : category} : is_functor (functor_data_kleislify C). Proof. split; red; simpl; intros. - unfold kleislify_mor. apply subtypePath; simpl. + intro. apply isaprop_Kleisli_Mor_laws; apply homset_property. + reflexivity. - apply subtypePath; simpl. + intro. apply isaprop_Kleisli_Mor_laws; apply homset_property. + reflexivity. Defined. Definition functor_kleislify {C : category} : functor (category_Monad C) (category_Kleisli C) := (functor_data_kleislify C) ,, is_functor_kleislify. (* ----- Proof of the isomorphism. ----- *) Section Adjunction. Context {C : category}. (* this result could not be preserved with the parameter [F] as field of [Kleisli_Data]: Lemma Kleisli_data_eq {F : C → C} (K K' : Kleisli_Data F) (η_eq : ∏ a : C, η K a = η K' a) (bind_eq : ∏ (a b : C) (f : a --> F b), bind K f = bind K' f) : K = K'. Proof. intros. apply dirprod_paths. - change (η K = η K'). apply funextsec. intro a. apply η_eq. - apply funextsec. intro a. apply funextsec. intro b. apply funextfun. intro f. apply bind_eq. Defined. *) Lemma unkleislify_data_eq (T : KleisliMonad C) : Monad_Kleisli_data (unkleislify T) = T. Proof. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (maponpaths (λ p, tpair _ _ p )). apply pair_path_in2. simpl. apply funextsec. intro a. apply funextsec. intro b. apply funextfun. intro f. unfold Monads.bind. abstract (simpl; unfold μ; rewrite (bind_map T); rewrite id_right; apply idpath). Defined. Lemma kleislify_unkleislify (T : KleisliMonad C) : kleislify (unkleislify T) = T. Proof. unfold unkleislify, kleislify. simpl. destruct T as (D, L). simpl. use total2_paths_f; simpl. apply unkleislify_data_eq. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (isaprop_Kleisli_Laws D). Defined. Lemma unkleislify_kleislify (M : Monad C) : unkleislify (kleislify M) = M. Proof. apply Monad_eq_raw_data. unfold Monad_to_raw_data. simpl. apply (pair_path_in2). apply total2_paths2. 2: apply idpath. apply total2_paths2. - apply funextsec. intro a. apply funextsec; intro b. apply funextfun; intro f. simpl. unfold map. unfold bind. unfold η. simpl. unfold Monads.bind, Monads.η. rewrite functor_comp. rewrite <- assoc. set (H:= Monad_law2 (T:=M) b). simpl in H. unfold Monads.η, Monads.μ in H. simpl in H. unfold Monads.μ. etrans. { apply cancel_precomposition. apply H. } apply id_right. - apply funextsec; intro x. set (H:= functor_id (C:=C) (C':=C) M (M x)). simpl in H. unfold μ. simpl. unfold bind, Monads.μ. simpl. unfold Monads.bind, Monads.μ. etrans. { apply cancel_postcomposition. apply H. } apply id_left. Defined. Definition eps (T : KleisliMonad C) (a : C) : C ⟦ T a, T a ⟧ := identity (pr1 T a). Lemma eps_morph_law (T : KleisliMonad C) : Kleisli_Mor_laws T (kleislify (unkleislify T)) (eps T). Proof. split; simpl; intros. - apply id_right. - rewrite id_left, id_right. rewrite id_right. unfold μ. unfold bind. simpl. unfold Monads.bind. unfold Monads.μ. simpl. unfold μ. rewrite (bind_map T). now rewrite id_right. Defined. Definition eps_morph (T : KleisliMonad C) : Kleisli_Mor T (kleislify (unkleislify T)) := eps T ,, eps_morph_law T. Lemma epsinv_morph_law (T : KleisliMonad C) : Kleisli_Mor_laws (kleislify (unkleislify T)) T (eps T). Proof. split; simpl; intros. - apply id_right. - rewrite id_left, id_right. rewrite id_right. unfold μ. unfold bind. simpl. unfold Monads.bind. unfold Monads.μ. simpl. unfold μ. rewrite (bind_map T). now rewrite id_right. Defined. Definition epsinv_morph (T : KleisliMonad C) : Kleisli_Mor (kleislify (unkleislify T)) T := eps T ,, epsinv_morph_law T. Lemma is_inverse_epsinv (T : KleisliMonad C) : is_inverse_in_precat (eps_morph T : category_Kleisli C ⟦T, kleislify (unkleislify T)⟧) (epsinv_morph T). Proof. split. - apply Kleisli_Mor_eq. apply funextsec. intro a. simpl. unfold eps. apply id_left. - apply Kleisli_Mor_eq. apply funextsec. intro a. simpl. unfold eps. apply id_left. Defined. Definition is_z_iso_eps_morph (T : KleisliMonad C) : is_z_isomorphism (eps_morph T : category_Kleisli C ⟦ T,(kleislify (unkleislify T))⟧) := epsinv_morph T,, is_inverse_epsinv T. Lemma is_natural_eps : is_nat_trans (functor_identity (category_Kleisli C)) (functor_unkleislify ∙ functor_kleislify) eps_morph. Proof. red. simpl. intros T T' α. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (Kleisli_Mor_eq(T := T)(T' := kleislify(unkleislify T'))). simpl. apply funextsec. intro a. unfold nat_trans_from_kleisli_mor, eps. rewrite id_left. apply id_right. Defined. Definition eps_natural : functor_identity (category_Kleisli C) ⟹ functor_unkleislify ∙ functor_kleislify := eps_morph ,, is_natural_eps. Definition eta_arrow (T : Monad C) (a : C) : C ⟦ T a, T a ⟧ := identity (T a). Lemma eta_arrow_natural (T : Monad C) : is_nat_trans (kleisli_functor_data (kleislify T)) T (eta_arrow T). Proof. intros a b f. simpl. unfold eta_arrow. rewrite id_left, id_right. unfold map, bind, η. simpl. unfold Monads.bind, Monads.η, Monads.μ. rewrite functor_comp. rewrite <- assoc. set (H := Monad_law2 (T := T) b). progress simpl in H. unfold Monads.η, Monads.μ in H. etrans. { apply cancel_precomposition. apply H. } now rewrite id_right. Defined. Definition eta_data (T : Monad C) : kleisli_functor_data (kleislify T) ⟹ T := eta_arrow T ,, eta_arrow_natural T. Lemma is_nat_trans_etainv (T : Monad C) : is_nat_trans T (kleisli_functor_data (kleislify T)) (eta_arrow T). Proof. intros a b f. simpl. unfold eta_arrow. rewrite id_right. rewrite id_left. unfold map, bind, η. simpl. unfold Monads.bind, Monads.η, Monads.μ. rewrite functor_comp. rewrite <- assoc. set (H := Monad_law2 (T := T) b). progress simpl in H. unfold Monads.η, Monads.μ in H. etrans. 2: { apply cancel_precomposition. apply pathsinv0. apply H. } now rewrite id_right. Defined. Definition etainv_data (T : Monad C) : T ⟹ kleisli_functor_data (kleislify T) := eta_arrow T ,, is_nat_trans_etainv T. Lemma etainv_data_laws (T : Monad C) : @Monad_Mor_laws C T (@unkleislify C (@kleislify C T)) (etainv_data T). Proof. split; simpl; intros. - unfold eta_arrow. rewrite id_right. unfold map, μ, Monads.μ, bind. simpl. unfold Monads.bind, η, Monads.μ. simpl. unfold Monads.η. do 2 rewrite id_left. rewrite functor_id, id_left. rewrite <- assoc. set (H := Monad_law3 (T := T) a). progress simpl in H. unfold Monads.μ in H. etrans. 2: { apply cancel_precomposition. apply H. } rewrite assoc. rewrite <- functor_comp. set (H1 := Monad_law1 (T := T) a). progress simpl in H1. unfold Monads.η, Monads.μ in H1. etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply pathsinv0. (* UniMath.MoreFoundations.Tactics.show_id_type. *) eapply H1. } now rewrite functor_id, id_left. - apply id_right. Defined. Definition etainv_morph (T : Monad C) : Monad_Mor T (unkleislify (kleislify T)) := etainv_data T ,, etainv_data_laws T. Lemma etainv_morph_law (T : Monad C) : Monad_Mor_laws (T := T) (T' := (unkleislify (kleislify T))) (etainv_data T). Proof. split; simpl; intro a. - unfold eta_arrow. rewrite id_right. rewrite id_left. unfold Monads.μ, bind, μ, map, μ, bind, map, μ. simpl. unfold Monads.bind, Monad_Kleisli_data; simpl. unfold Monads.μ, η. rewrite functor_comp. cbn. rewrite functor_id. do 2 rewrite id_left. set (H1 := Monad_law2 (T := T) (T a)). unfold Monads.μ, Monads.η in H1. progress simpl in H1. simpl. unfold Monads.η. etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply H1. } now rewrite id_left. - apply id_right. Defined. Lemma eta_data_laws (T : Monad C) : @Monad_Mor_laws C (@unkleislify C (@kleislify C T)) T (eta_data T). Proof. split; simpl; intros. - unfold eta_arrow. rewrite id_right. rewrite id_left. unfold Monads.μ, μ, bind, μ. simpl. unfold Monads.bind, Monads.μ. rewrite functor_id. do 2 rewrite id_left. apply idpath. - apply id_right. Defined. Definition eta_morph (T : Monad C) : Monad_Mor (unkleislify (kleislify T)) T := eta_data T ,, eta_data_laws T. Lemma is_inverse_etainv (T : Monad C) : is_inverse_in_precat (eta_morph T : category_Monad C ⟦unkleislify (kleislify T), T⟧) (etainv_morph T : category_Monad C ⟦T, unkleislify (kleislify T)⟧). Proof. split. - apply Monad_Mor_eq. intros. simpl. unfold eta_arrow. apply id_left. - apply Monad_Mor_eq. intros. simpl. unfold eta_arrow. apply id_left. Defined. Definition is_z_iso_eta_morph (T : Monad C) : is_z_isomorphism (eta_morph T : category_Monad C ⟦unkleislify (kleislify T), T⟧) := etainv_morph T,, is_inverse_etainv T. Lemma is_natural_eta : is_nat_trans (functor_composite_data (functor_data_kleislify C) (functor_data_unkleislify C)) (functor_identity (category_Monad C)) eta_morph. Proof. red; simpl. intros T T' α. apply (Monad_Mor_eq (unkleislify (kleislify T))). intros. simpl. unfold eta_arrow. now rewrite id_left, id_right. Defined. Definition eta_natural : functor_kleislify ∙ functor_unkleislify ⟹ functor_identity (category_Monad C) := eta_morph ,, is_natural_eta. Lemma form_adjunction_eps_eta : form_adjunction functor_unkleislify functor_kleislify eps_natural eta_natural. Proof. split; red; simpl. - intro T. apply (Monad_Mor_eq (unkleislify T) (unkleislify T)). intros. simpl. unfold eps. now rewrite id_left. - intro T. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (Kleisli_Mor_eq (T:=kleislify T) (T':=kleislify T)). intros. simpl. apply funextsec. intro a. unfold eps. now rewrite id_left. Defined. Definition are_adjoint_monad_form_kleislify : are_adjoints functor_unkleislify functor_kleislify := (eps_natural ,, eta_natural) ,, form_adjunction_eps_eta. Definition is_left_adjoint_functor_unkleislify : is_left_adjoint functor_unkleislify := functor_kleislify ,, are_adjoint_monad_form_kleislify. Lemma form_equivalence_unkleislify : forms_equivalence is_left_adjoint_functor_unkleislify. Proof. split; simpl. - intros T. apply is_z_iso_eps_morph. - intros T. apply is_z_iso_eta_morph. Defined. Lemma is_catiso : is_catiso (functor_unkleislify(C:=C)). Proof. split. - apply fully_faithful_from_equivalence. use (is_left_adjoint_functor_unkleislify,, form_equivalence_unkleislify). - apply (isweq_iso _ (λ T : Monad C, kleislify T)). + intro T. simpl. apply kleislify_unkleislify. + simpl. apply unkleislify_kleislify. Defined. Corollary weq_Kleisli_Monad_categories: (category_Monad C) ≃ (category_Kleisli C). Proof. set (aux := pr2 is_catiso). exact (invweq (make_weq _ aux)). Defined. (** This is the main result of [UniMath.CategoryTheory.Monads.Kleisli]. *) End Adjunction. UniMath-20231010/UniMath/CategoryTheory/Monads/Kleisli.v000066400000000000000000000107071451125700300226350ustar00rootroot00000000000000(** ********************************************************** Contents: - "Kleisli" definition of monad [Kleisli] - equivalence of this definition and the "monoidal" definition [weq_Kleisli_Monad] Written by: Joseph Helfer, Matthew Weaver, 2017 ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.KTriples. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.RelativeMonads. Local Open Scope cat. (** Remark that a monad on C is the same as a relative monad for the identity functor on C *) Goal ∏ (C : category), KleisliMonad C = RelMonad (functor_identity C). Proof. intros. apply idpath. Qed. Coercion RelMonad_from_Kleisli {C : category} (T : KleisliMonad C) := (T : RelMonad (functor_identity C)). (** * Equivalence of the types of KleisliMonad and "monoidal" monads *) Section monad_types_equiv. Definition Monad_to_Kleisli {C : category} : Monad C → KleisliMonad C := λ T, (functor_on_objects T ,, (pr1 (η T) ,, @bind C T)) ,, @Monad_law2 C T ,, (@η_bind C T ,, @bind_bind C T). Definition Kleisli_to_functor {C : category} (T: KleisliMonad C) : C ⟶ C. Proof. use make_functor. - use make_functor_data. + exact (RelMonad_from_Kleisli T). + apply r_lift. - apply is_functor_r_lift. Defined. Definition Kleisli_to_μ {C : category} (T: KleisliMonad C) : Kleisli_to_functor T ∙ Kleisli_to_functor T ⟹ Kleisli_to_functor T. Proof. use tpair. - exact (λ (x : C), r_bind T (identity (T x))). - intros x x' f; simpl. unfold r_lift. now rewrite (r_bind_r_bind T), <- assoc, (r_eta_r_bind T (T x')), id_right, (r_bind_r_bind T), id_left. Defined. Definition Kleisli_to_η {C : category} (T: KleisliMonad C) : functor_identity C ⟹ Kleisli_to_functor T. Proof. use tpair. - exact (r_eta T). - intros x x' f; simpl. unfold r_lift. now rewrite (r_eta_r_bind T x). Defined. Definition Kleisli_to_Monad {C : category} (T : KleisliMonad C) : Monad C. Proof. use (Kleisli_to_functor T,, (Kleisli_to_μ T ,, Kleisli_to_η T) ,, _). do 2 try apply tpair; intros; simpl. - apply (r_eta_r_bind T). - unfold r_lift. now rewrite (r_bind_r_bind T), <- assoc, (r_eta_r_bind T (T c)), id_right, (r_bind_r_eta T). - unfold r_lift. now rewrite !(r_bind_r_bind T), id_left, <- assoc, (r_eta_r_bind T (T c)), id_right. Defined. Proposition Kleisli_to_Monad_to_Kleisli {C : category} (T : KleisliMonad C) : Monad_to_Kleisli (Kleisli_to_Monad T) = T. Proof. apply subtypePath. - intro. do 2 try apply isapropdirprod; do 5 try (apply impred; intro); apply homset_property. - apply (maponpaths (λ p, tpair _ _ p )); simpl. apply dirprod_paths. * apply idpath. * repeat (apply funextsec; unfold homot; intro). simpl; unfold Monads.bind; simpl; unfold r_lift. now rewrite (r_bind_r_bind T), <- assoc, (r_eta_r_bind T (T x0)), id_right. Defined. Lemma Monad_to_Kleisli_to_Monad_raw_data {C : category} (T : Monad C) : Monad_to_raw_data (Kleisli_to_Monad (Monad_to_Kleisli T)) = Monad_to_raw_data T. Proof. apply (maponpaths (λ p, tpair _ _ p )); simpl. apply dirprod_paths. + apply dirprod_paths; repeat (apply funextsec; unfold homot; intro); simpl. * unfold r_lift, r_bind, r_eta; simpl. unfold Monads.bind. rewrite (functor_comp T), <- assoc. change (# T x1 · (# T (η T x0) · μ T x0) = #T x1). now rewrite (@Monad_law2 C T x0), id_right. * unfold Monads.bind, r_bind; simpl. now rewrite (functor_id T), id_left. + apply idpath. Defined. Definition Monad_to_Kleisli_to_Monad {C : category} (T : Monad C) : Kleisli_to_Monad (Monad_to_Kleisli T) = T. Proof. apply Monad_eq_raw_data . apply Monad_to_Kleisli_to_Monad_raw_data. Defined. Definition isweq_Monad_to_Kleisli {C : category} : isweq Monad_to_Kleisli := isweq_iso _ _ (Monad_to_Kleisli_to_Monad(C:=C)) Kleisli_to_Monad_to_Kleisli. Definition weq_Kleisli_Monad {C : category} : Monad C ≃ KleisliMonad C := _,, isweq_Monad_to_Kleisli. End monad_types_equiv. UniMath-20231010/UniMath/CategoryTheory/Monads/KleisliCategory.v000066400000000000000000000274031451125700300243340ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of the Kleisli category of a monad. - The canonical adjunction between a category C and the Kleisli category of a monad on C. TODO: - Show that this definition is equivalent to the Kleisli category of a relative monad with respect to the identity functor. Written by: Brandon Doherty (July 2018) ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Section Monad_Lemmas. (*A couple of lemmas involving bind*) Lemma bind_comp_η {C : category} {T : Monad C} {a b : C} (f : C ⟦a , b⟧) : bind (f · (η T) b) = # T f. Proof. unfold bind; rewrite functor_comp. rewrite <- assoc. rewrite <- id_right. apply cancel_precomposition. apply bind_η. Qed. Lemma bind_identity {C : category} {T : Monad C} (a : C) : bind (identity (T a)) = (μ T) a. Proof. unfold bind. rewrite functor_id. apply id_left. Qed. End Monad_Lemmas. Section Kleisli_Categories. Definition Kleisli_precat_ob_mor_monad {C : category} (T : Monad C) : precategory_ob_mor. Proof. use tpair. - exact (ob C). - intros X Y. exact (X --> T Y). Defined. Definition Kleisli_precat_data_monad {C : category} (T : Monad C) : precategory_data. Proof. use make_precategory_data. - exact (Kleisli_precat_ob_mor_monad T). - intro c. exact (η T c). - intros a b c f g. exact (f · (bind g)). Defined. Lemma Kleisli_precat_monad_is_precat {C : category} (T : Monad C) : is_precategory (Kleisli_precat_data_monad T). Proof. apply is_precategory_one_assoc_to_two. split. - split. + intros a b f. unfold identity; unfold compose; cbn. apply η_bind. + intros a b f. unfold identity; unfold compose; cbn. rewrite <- id_right. apply cancel_precomposition. apply bind_η. - intros a b c d f g h. unfold compose; cbn. rewrite <- bind_bind. apply assoc. Defined. Definition Kleisli_precat_monad {C : category} (T : Monad C) : precategory := (Kleisli_precat_data_monad T,,Kleisli_precat_monad_is_precat T). Lemma Kleisli_precat_monad_has_homsets {C : category} (T : Monad C) (hs : has_homsets C) : has_homsets (Kleisli_precat_data_monad T). Proof. intros a b. apply hs. Defined. Definition Kleisli_cat_monad {C : category} (T : Monad C): category := (Kleisli_precat_monad T,, Kleisli_precat_monad_has_homsets T (homset_property C)). (*TODO: show that this is equivalent to the definition of the Kleisli category of a relative monad with respect to the identity*) (*The canonical adjunction between C and the Kleisli category of a monad on C*) Definition Left_Kleisli_functor_data {C : category} (T: Monad C) : functor_data C (Kleisli_precat_monad T). Proof. use make_functor_data. - apply idfun. - intros a b f; unfold idfun. exact (f · (η T) b). Defined. Lemma Left_Kleisli_is_functor {C : category} (T: Monad C) : is_functor (Left_Kleisli_functor_data T). Proof. split. - intro a. unfold Left_Kleisli_functor_data; cbn. apply id_left. - intros a b c f g. unfold Left_Kleisli_functor_data; cbn. do 2 (rewrite <- assoc). apply cancel_precomposition. apply pathsinv0. apply η_bind. Defined. Definition Left_Kleisli_functor {C : category} (T : Monad C) : functor C (Kleisli_cat_monad T) := (Left_Kleisli_functor_data T,,Left_Kleisli_is_functor T). Definition Right_Kleisli_functor_data {C : category} (T : Monad C) : functor_data (Kleisli_cat_monad T) C. Proof. use make_functor_data. - exact T. - intros a b. apply bind. Defined. Lemma Right_Kleisli_is_functor {C : category} (T : Monad C) : is_functor (Right_Kleisli_functor_data T). Proof. use tpair. - intro a. unfold Right_Kleisli_functor_data; unfold identity; unfold functor_on_morphisms; cbn. apply bind_η. - intros a b c f g; cbn. apply pathsinv0. apply bind_bind. Defined. Definition Right_Kleisli_functor {C : category} (T : Monad C) : functor (Kleisli_cat_monad T) C := (Right_Kleisli_functor_data T,,Right_Kleisli_is_functor T). (*Composition of the left and right Kleisli functors is equal to T as a functor*) Definition Kleisli_functor_left_right_compose {C : category} (T : Monad C) : (Left_Kleisli_functor T) ∙ (Right_Kleisli_functor T) = T. Proof. use functor_eq. - apply homset_property. - use functor_data_eq_from_nat_trans. + intro a; apply idpath. + intros a b f; cbn. rewrite id_right. rewrite id_left. apply bind_comp_η. Defined. (*Showing that these functors are adjoints*) Definition Kleisli_homset_iso {C : category} (T : Monad C) : natural_hom_weq (Left_Kleisli_functor T) (Right_Kleisli_functor T). Proof. use tpair. - intros a b; cbn. apply idweq. - cbn; split. + intros. rewrite <- assoc. apply cancel_precomposition. apply η_bind. + intros; apply idpath. Defined. Definition Kleisli_functors_are_adjoints {C : category} (T : Monad C) : are_adjoints (Left_Kleisli_functor T) (Right_Kleisli_functor T) := adj_from_nathomweq (Kleisli_homset_iso T). Definition Left_Kleisli_is_left_adjoint {C : category} (T : Monad C) : is_left_adjoint (Left_Kleisli_functor T) := are_adjoints_to_is_left_adjoint (Left_Kleisli_functor T) (Right_Kleisli_functor T) (Kleisli_functors_are_adjoints T). Definition Right_Kleisli_is_right_adjoint {C : category} (T : Monad C) : is_right_adjoint (Right_Kleisli_functor T) := are_adjoints_to_is_right_adjoint (Left_Kleisli_functor T) (Right_Kleisli_functor T) (Kleisli_functors_are_adjoints T). Theorem Kleisli_adjunction_monad_eq {C : category} (T : Monad C) : Monad_from_adjunction (Kleisli_functors_are_adjoints T) = T. Proof. use Monad_eq_raw_data. apply total2_paths_equiv; use tpair. + cbn. apply idpath. + cbn. apply total2_paths_equiv; use tpair. * cbn. apply total2_paths_equiv; use tpair. -- cbn. do 2 (apply funextsec; intro). apply funextfun; intro f. cbn. apply bind_comp_η. -- cbn. rewrite transportf_const. cbn. apply funextsec; intro c. apply bind_identity. * cbn. rewrite transportf_const. apply idpath. Defined. End Kleisli_Categories. (** Two useful laws *) Definition η_η_bind {C : category} (M : Monad C) (x : C) : η M x · η M _ · bind (identity _) = η M x. Proof. rewrite bind_identity. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply Monad_law1. Qed. Definition η_bind_bind {C : category} (M : Monad C) (x : C) : η M (M(M x)) · bind (identity _) · bind (identity _) = μ M x · η M (M x) · bind (identity _). Proof. rewrite !bind_identity. rewrite Monad_law1, id_left. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. apply Monad_law1. } apply id_right. Qed. (** The universal mapping property of the Kleisli category *) Section KleisliUMP1. Context {C₁ C₂ : category} (m : Monad C₁) (F : C₁ ⟶ C₂) (γ : m ∙ F ⟹ F) (p₁ : ∏ (x : C₁), #F (η m x) · γ x = identity _) (p₂ : ∏ (x : C₁), γ _ · γ x = #F (μ m x) · γ x). Definition functor_from_kleisli_cat_monad_data : functor_data (Kleisli_cat_monad m) C₂. Proof. use make_functor_data. - exact F. - exact (λ x y f, #F f · γ y). Defined. Definition functor_from_kleisli_cat_monad_is_functor : is_functor functor_from_kleisli_cat_monad_data. Proof. split. - intro x ; cbn. apply p₁. - intros x y z f g ; cbn ; unfold bind. rewrite !functor_comp. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. exact (!(p₂ z)). } rewrite !assoc. apply maponpaths_2. exact (nat_trans_ax γ _ _ g). Qed. Definition functor_from_kleisli_cat_monad : Kleisli_cat_monad m ⟶ C₂. Proof. use make_functor. - exact functor_from_kleisli_cat_monad_data. - exact functor_from_kleisli_cat_monad_is_functor. Defined. Definition functor_from_kleisli_cat_monad_nat_trans : Left_Kleisli_functor m ∙ functor_from_kleisli_cat_monad ⟹ F. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; rewrite id_right, id_left ; rewrite functor_comp ; rewrite !assoc' ; etrans ; [ apply maponpaths ; exact (p₁ y) | ] ; apply id_right). Defined. Definition functor_from_kleisli_cat_monad_nat_trans_is_z_iso : is_nat_z_iso functor_from_kleisli_cat_monad_nat_trans. Proof. intro x. apply is_z_isomorphism_identity. Defined. End KleisliUMP1. Definition kleisli_monad_nat_trans {C : category} (m : Monad C) : m ∙ Left_Kleisli_functor m ⟹ Left_Kleisli_functor m. Proof. use make_nat_trans. - exact (λ x, identity (m x)). - abstract (intros x y f ; cbn ; unfold bind ; rewrite functor_id, !id_left ; rewrite functor_comp ; rewrite !assoc' ; apply maponpaths ; exact (Monad_law1 _ @ !(Monad_law2 _))). Defined. Section KleisliUMP2. Context {C₁ C₂ : category} (m : Monad C₁) {G₁ G₂ : Kleisli_cat_monad m ⟶ C₂} (α : Left_Kleisli_functor m ∙ G₁ ⟹ Left_Kleisli_functor m ∙ G₂) (p : ∏ (x : C₁), #G₁ (kleisli_monad_nat_trans m x) · α x = α (m x) · # G₂ (kleisli_monad_nat_trans m x)). Definition nat_trans_from_kleisli_cat_monad_is_nat_trans : is_nat_trans G₁ G₂ (λ x, α x). Proof. intros x y f. pose (maponpaths (λ z, z · # G₂ (identity (m y))) (nat_trans_ax α _ _ f)) as q. cbn in q. refine (_ @ q @ _) ; clear q. - rewrite !assoc'. refine (!_). etrans. { apply maponpaths. exact (!(p y)). } cbn. rewrite !assoc. apply maponpaths_2. refine (!(functor_comp G₁ _ _) @ _). apply maponpaths. cbn ; unfold bind. rewrite functor_id, id_left. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply Monad_law1. - rewrite !assoc'. apply maponpaths. refine (!(functor_comp G₂ _ _) @ _). apply maponpaths. cbn ; unfold bind. rewrite functor_id, id_left. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply Monad_law1. Qed. Definition nat_trans_from_kleisli_cat_monad : G₁ ⟹ G₂. Proof. use make_nat_trans. - exact (λ x, α x). - exact nat_trans_from_kleisli_cat_monad_is_nat_trans. Defined. Definition pre_whisker_nat_trans_from_kleisli_cat_monad : pre_whisker _ nat_trans_from_kleisli_cat_monad = α. Proof. use nat_trans_eq. { apply homset_property. } intro ; cbn. apply idpath. Qed. Definition nat_trans_from_kleisli_cat_monad_unique {β₁ β₂ : G₁ ⟹ G₂} (q₁ : pre_whisker _ β₁ = α) (q₂ : pre_whisker _ β₂ = α) : β₁ = β₂. Proof. use nat_trans_eq. { apply homset_property. } intro ; cbn. exact (nat_trans_eq_pointwise q₁ x @ !(nat_trans_eq_pointwise q₂ x)). Qed. End KleisliUMP2. UniMath-20231010/UniMath/CategoryTheory/Monads/LModules.v000066400000000000000000000351551451125700300227710ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of left modules ([LModule R]) over a monad [R] on [C] - category of left modules [category_LModule R D] of range [D] over a monad [R] on [C] - Tautological left module [tautological_LModule] : a monad is a module over itself - Forgetful functor to the category of endofunctors [LModule_forget_functor] - Pullback f* M of a module M along a monad morphism f [pb_LModule] - Pullback of a module morphism along a monad morphism [pb_LModule_Mor] - The pullback functor [pb_LModule_functor] - Isomorphisms between modules sharing the same underlying functor and have pointwise equal multiplication [LModule_same_func_iso] - Isomorphism between a module and its pullback along the identity morphism [pb_LModule_id_iso] - Isomorphism between f*(g*(M)) and (fog)* M, where f and g are monad morphisms and M is a module [pb_LModule_comp_iso] Following the scheme of Monads.v Written by: Ambroise Lafont (November 2016) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Local Notation "F ;;; G" := (nat_trans_comp _ _ _ F G) (at level 35). (** * Definition of module *) Section LModule_over_monad. Context {B : category} (M : Monad B) . (** Definition of modules over M of codomain D **) Section LModule_def. Definition LModule_data (D : category) : UU := ∑ F : functor B D, M ∙ F ⟹ F. Coercion functor_from_LModule_data (C : category) (F : LModule_data C) : functor B C := pr1 F. Definition lm_mult {C : category} (F : LModule_data C) : M ∙ F ⟹ F := pr2 F. Local Notation σ := lm_mult. Definition LModule_laws {C : category} (T : LModule_data C) : UU := (∏ c : B, #T (η M c) · σ T c = identity (T c)) × (∏ c : B, #T ((μ M) c) · σ T c = σ T (M c) · σ T c). Lemma isaprop_LModule_laws (C : category) (T : LModule_data C) : isaprop (LModule_laws T). Proof. repeat apply isapropdirprod; apply impred; intro c; apply C. Qed. Definition LModule (C : category) : UU := ∑ T : LModule_data C, LModule_laws T. Coercion LModule_data_from_LModule (C : category) (T : LModule C) : LModule_data C := pr1 T. Lemma LModule_law1 {C : category} {T : LModule C} : ∏ c : B, #T (η M c) · σ T c = identity (T c). Proof. exact ( (pr1 (pr2 T))). Qed. Lemma LModule_law2 {C : category} {T : LModule C} : ∏ c : B, #T ((μ M) c) · σ T c = σ T (M c) · σ T c. Proof. exact (pr2 ( (pr2 T))). Qed. End LModule_def. (** * Monad category *) Section LModule_category. Local Notation σ := lm_mult. Definition LModule_Mor_laws {C : category} {T T' : LModule_data C} (α : T ⟹ T') : UU := ∏ a : B, α (M a) · σ T' a = σ T a · α a. Lemma isaprop_LModule_Mor_laws (C : category) (T T' : LModule_data C) (α : T ⟹ T') : isaprop (LModule_Mor_laws α). Proof. apply impred; intro c; apply C. Qed. Definition LModule_Mor {C : category} (T T' : LModule C) : UU := ∑ α : T ⟹ T', LModule_Mor_laws α. Coercion nat_trans_from_module_mor (C : category) (T T' : LModule C) (s : LModule_Mor T T') : T ⟹ T' := pr1 s. Definition LModule_Mor_σ {C : category} {T T' : LModule C} (α : LModule_Mor T T') : ∏ a : B, α (M a) · σ T' a = σ T a · α a := pr2 α. Lemma LModule_identity_laws {C : category} (T : LModule C) : LModule_Mor_laws (nat_trans_id T). Proof. intro x. now rewrite id_right, id_left. Qed. Definition LModule_identity {C : category} (T : LModule C) : LModule_Mor T T := tpair _ _ (LModule_identity_laws T). Lemma LModule_composition_laws {C : category} {T T' T'' : LModule C} (α : LModule_Mor T T') (α' : LModule_Mor T' T'') : LModule_Mor_laws (nat_trans_comp _ _ _ α α'). Proof. red; intros; simpl. unfold nat_trans_from_module_mor. rewrite assoc. etrans; revgoals. apply cancel_postcomposition. apply (LModule_Mor_σ α a). rewrite <- !assoc. apply cancel_precomposition. apply (LModule_Mor_σ α' a). Qed. Definition LModule_composition {C : category} {T T' T'' : LModule C} (α : LModule_Mor T T') (α' : LModule_Mor T' T'') : LModule_Mor T T'' := tpair _ _ (LModule_composition_laws α α'). Definition LModule_Mor_equiv {C : category} {T T' : LModule C} (α β : LModule_Mor T T') : α = β ≃ (pr1 α = pr1 β). Proof. apply subtypeInjectivity; intro a. apply isaprop_LModule_Mor_laws. Defined. Definition precategory_LModule_ob_mor (C : category) : precategory_ob_mor. Proof. exists (LModule C). exact (λ T T' : LModule C, LModule_Mor T T'). Defined. Definition precategory_LModule_data (C : category) : precategory_data. Proof. exists (precategory_LModule_ob_mor C). exists (@LModule_identity C). exact (@LModule_composition C). Defined. Lemma precategory_LModule_axioms (C : category) : is_precategory (precategory_LModule_data C). Proof. repeat split; simpl; intros. - apply (invmap (LModule_Mor_equiv _ _ )). apply (@id_left (functor_category B C)). - apply (invmap (LModule_Mor_equiv _ _ )). apply (@id_right (functor_category B C)). - apply (invmap (LModule_Mor_equiv _ _ )). apply (@assoc (functor_category B C)). - apply (invmap (LModule_Mor_equiv _ _ )). apply (@assoc' (functor_category B C)). Qed. Definition precategory_LModule (C : category) : precategory := tpair _ _ (precategory_LModule_axioms C). Lemma has_homsets_LModule (C : category) : has_homsets (precategory_LModule C). Proof. intros F G. apply isaset_total2 . - apply isaset_nat_trans. apply homset_property. - intros m. apply isasetaprop. apply isaprop_LModule_Mor_laws. Qed. Definition category_LModule (C : category) : category := (precategory_LModule C,, has_homsets_LModule C). End LModule_category. (** Any monad is a left module over itself *) Definition tautological_LModule_data : LModule_data B := ((M:functor _ _) ,, μ M). Lemma tautological_LModule_law : LModule_laws tautological_LModule_data. Proof. split; intro c. - apply Monad_law2. - apply Monad_law3. Qed. Definition tautological_LModule : LModule B := (tautological_LModule_data ,, tautological_LModule_law). End LModule_over_monad. (** The forgetful functor from the category of left modules to the category of endofunctors *) Section ForgetLModFunctor. Context {B : category} (R : Monad B) (C : category). Local Notation MOD := (category_LModule R C). Definition LModule_forget_functor_data : functor_data MOD [B,C] := make_functor_data (C := MOD) (C' := [B,C]) (fun X => ((X : LModule _ _): functor _ _)) (fun a b f => ((f : LModule_Mor _ _ _) : nat_trans _ _)). Definition LModule_forget_is_functor : is_functor LModule_forget_functor_data := (( fun x => idpath _) : functor_idax LModule_forget_functor_data) ,, ((fun a b c f g => idpath _) : functor_compax LModule_forget_functor_data). Definition LModule_forget_functor: functor MOD [B,C] := make_functor LModule_forget_functor_data LModule_forget_is_functor. End ForgetLModFunctor. (** Let m : M -> M' a monad morphism. m induces a functor m* between the category of left modules over M' and the category of left modules over M If T is a module over M', we call m* T the pullback module of T along m *) Section Pullback_module. Context {B: category} {M M': Monad B} (m: Monad_Mor M M'). Context {C: category}. Variable (T : LModule M' C). Notation "Z ∘ α" := (post_whisker α Z). Local Notation σ := lm_mult. Definition pb_LModule_σ : M ∙ T ⟹ T := nat_trans_comp _ _ _ (T ∘ m) (σ _ T). Definition pb_LModule_data : ∑ F : functor B C, M ∙ F ⟹ F := tpair _ (T:functor B C) pb_LModule_σ. Lemma pb_LModule_laws : LModule_laws M pb_LModule_data. Proof. split. - intro c. cbn. rewrite <- (LModule_law1 _ (T:=T)). rewrite <- (Monad_Mor_η m). rewrite functor_comp. apply assoc. - simpl. intro c. rewrite assoc. rewrite <- (functor_comp T). etrans. apply cancel_postcomposition. apply maponpaths. apply Monad_Mor_μ. rewrite functor_comp. rewrite <- assoc. etrans. apply cancel_precomposition. apply LModule_law2. repeat rewrite functor_comp. etrans. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. apply cancel_postcomposition. apply (nat_trans_ax (σ M' T)). now repeat rewrite assoc. Qed. Definition pb_LModule : LModule M C := tpair _ _ pb_LModule_laws. End Pullback_module. (** Let m:M -> M' be a monad morphism et n : T -> T' a morphism in the category of modules over M'. In this section we construct the morphism m* n : m*T -> m*T' in the category of modules over M between the pullback modules along m. *) Section Pullback_Module_Morphism. Context {B: category} {M M': Monad B} (m: Monad_Mor M M') {C: category} {T T': LModule M' C} (n: LModule_Mor _ T T'). Local Notation pbmT := (pb_LModule m T). Local Notation pbmT' := (pb_LModule m T'). Lemma pb_LModule_Mor_law : LModule_Mor_laws M (T:=pbmT) (T':=pbmT') n. Proof. intros b. cbn. eapply pathscomp0; revgoals. - rewrite <-assoc. apply cancel_precomposition. apply LModule_Mor_σ. - repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0. apply nat_trans_ax. Qed. Definition pb_LModule_Mor : LModule_Mor _ pbmT pbmT' := (_ ,, pb_LModule_Mor_law). End Pullback_Module_Morphism. (** The pullback functor A monad morphism f : R -> S induces a functor between the category of modules over S and the category of modules over R. *) Section PbmFunctor. Context {B C : category} {R S : Monad B} (f : Monad_Mor R S). Let MOD (R : Monad B) := (category_LModule R C). Definition pb_LModule_functor_data : functor_data (MOD S) (MOD R) := make_functor_data (C := MOD S) (C' := MOD R) (pb_LModule f ) (@pb_LModule_Mor _ _ _ f _). Lemma pb_LModule_is_functor : is_functor pb_LModule_functor_data. Proof. split. - intro M. apply LModule_Mor_equiv; apply idpath. - intros X Y Z u v. apply LModule_Mor_equiv; apply idpath. Qed. Definition pb_LModule_functor : functor (MOD S) (MOD R) := make_functor _ pb_LModule_is_functor. End PbmFunctor. (** Construction of an isomorphism between modules sharing the same underlying functor and have pointwise equal multiplication [LModule_M1_M2_iso] *) Section IsoLModPb. Context {B : category} {R : Monad B} {C : category} {F : functor B C}. (** Module morphism between two modules sharing the same functor F and having pointwise equal multiplication *) Lemma LModule_same_func_Mor_laws {m1 m2 : R ∙ F ⟹ F } (hm : ∏ c, m1 c = m2 c) : LModule_Mor_laws R (T := (F ,, m1)) (T' := (F ,, m2)) (nat_trans_id _). Proof. intro c. etrans;[apply id_left|]. apply pathsinv0. etrans;[apply ( (id_right _))|]. apply hm. Qed. Definition LModule_same_func_Mor {m1 m2 : R ∙ F ⟹ F } (hm : ∏ c, m1 c = m2 c) (m1_law : LModule_laws _ (F ,, m1)) (m2_law : LModule_laws _ (F ,, m2)) (M1 : LModule _ _ := _ ,, m1_law) (M2 : LModule _ _ := _ ,, m2_law) : LModule_Mor R M1 M2 := _ ,, LModule_same_func_Mor_laws hm . Context {m1 m2 : R ∙ F ⟹ F }. Let F_data1 : LModule_data _ _ := F ,, m1. Let F_data2 : LModule_data _ _ := F ,, m2. Context (m1_law : LModule_laws _ F_data1). Context (m2_law : LModule_laws _ F_data2). (** The multiplication are pointwise equal *) Context (hm : ∏ c, m1 c = m2 c). Let M1 : LModule _ _ := _ ,, m1_law. Let M2 : LModule _ _ := _ ,, m2_law. (** Isomorphism between M1 and M2 *) Lemma LModule_same_func_Mor_is_inverse : is_inverse_in_precat (C := category_LModule R C) (LModule_same_func_Mor hm m1_law m2_law) (LModule_same_func_Mor (fun c => ! (hm c)) m2_law m1_law). Proof. use make_is_inverse_in_precat. - apply LModule_Mor_equiv. apply (id_left (C := [B, C])). - apply LModule_Mor_equiv. apply (id_right (C := [B, C])). Qed. Definition LModule_same_func_iso : iso (C := category_LModule R C ) M1 M2. Proof. eapply make_iso. eapply is_iso_from_is_z_iso. eapply make_is_z_isomorphism. apply LModule_same_func_Mor_is_inverse. Defined. End IsoLModPb. (** Let T be a module on M'. In this section, we construct the module morphism T -> id* T (which is actully an iso) where id* T is the pullback module of T along the identity morphism in M'. and also the morphism id* T -> T *) Section Pullback_Identity_Module. Context {B : category} {M' : Monad B} {C : category} {T : LModule M' C}. Local Notation pbmid := (pb_LModule (identity M') T). Lemma pbm_id_law : ∏ c : B, (lm_mult _ T) c = (pb_LModule_σ (identity M') T) c. Proof. intro c. cbn. apply pathsinv0. etrans;[|apply id_left]. apply cancel_postcomposition. apply functor_id. Qed. Definition pb_LModule_id_iso : iso (C := precategory_LModule _ C) T pbmid := LModule_same_func_iso _ _ pbm_id_law. End Pullback_Identity_Module. (** In this section, we construct the isomorphism between m*(m'*(T'')) and (m o m')*(T'') where m and m' are monad morphisms, and T'' is a left module. *) Section Pullback_Composition. Context {B : category} {M M' : Monad B} (m : Monad_Mor M M') {C : category} {M'' : Monad B} (m' : Monad_Mor M' M'') (T'' : LModule M'' C). Local Notation comp_pbm := (pb_LModule m (pb_LModule m' T'')). Local Notation pbm_comp := (pb_LModule (m · m') T''). Lemma pb_LModule_comp_law (c : B) : (pb_LModule_σ m (pb_LModule m' T'')) c = (pb_LModule_σ (m · m') T'') c. Proof. cbn. etrans; [apply assoc|]. apply cancel_postcomposition. apply pathsinv0. apply functor_comp. Qed. Definition pb_LModule_comp_iso : iso (C := category_LModule _ C) comp_pbm pbm_comp := LModule_same_func_iso _ _ pb_LModule_comp_law. End Pullback_Composition. UniMath-20231010/UniMath/CategoryTheory/Monads/MonadAlgebras.v000066400000000000000000000270571451125700300237460ustar00rootroot00000000000000(** *************************************************************** Contents : - Definition of the category of algebras of a monad - The free-forgetful adjunction between a category C and the category of algebras of a monad on C - For monads S, T on C: lifting of T to a monad on the category of S-algebras ******************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.Derivative. Local Open Scope cat. Ltac rewrite_cbn x := let H := fresh in (set (H := x); cbn in H; rewrite H; clear H). Ltac rewrite_cbn_inv x := let H := fresh in (set (H := x); cbn in H; rewrite <- H; clear H). Section Algebras. Context {C : category} (T : Monad C). (** Definition of an algebra of a monad T *) Section Algebra_def. Definition Algebra_data : UU := ∑ X : C, T X --> X. Coercion Alg_carrier (X : Algebra_data) : C := pr1 X. Definition Alg_map (X : Algebra_data) : T X --> X := pr2 X. Definition Algebra_laws (X : Algebra_data) : UU := (η T X · Alg_map X = identity X) × (μ T X · Alg_map X = #T (Alg_map X) · Alg_map X). Definition Algebra : UU := ∑ X : Algebra_data, Algebra_laws X. Coercion Algebra_data_from_Algebra (X : Algebra) : Algebra_data := pr1 X. Definition Algebra_idlaw (X : Algebra) : η T X · Alg_map X = identity X := pr1 (pr2 X). Definition Algebra_multlaw (X : Algebra) : μ T X · Alg_map X = #T (Alg_map X) · Alg_map X := pr2 (pr2 X). Definition free_Algebra (X : C) : Algebra. Proof. use tpair. - exists (T X). exact (μ T X). - abstract (split; [apply Monad_law1 | apply pathsinv0; apply Monad_law3]). Defined. End Algebra_def. (** Data for the category of algebras of the monad T, following FunctorAlgebras.v *) Section Algebra_precategory_data. Definition is_Algebra_mor {X Y : Algebra} (f : X --> Y) : UU := Alg_map X · f = #T f · Alg_map Y. Definition Algebra_mor (X Y : Algebra) : UU := ∑ f : X --> Y, is_Algebra_mor f. Coercion mor_from_Algebra_mor {X Y : Algebra} (f : Algebra_mor X Y) : X --> Y := pr1 f. Definition Algebra_mor_commutes {X Y : Algebra} (f : Algebra_mor X Y) : Alg_map X · f = #T f · Alg_map Y := pr2 f. Definition Algebra_mor_id (X : Algebra) : Algebra_mor X X. Proof. exists (identity X). abstract (unfold is_Algebra_mor; rewrite functor_id, id_right, id_left; apply idpath). Defined. Definition Algebra_mor_comp (X Y Z : Algebra) (f : Algebra_mor X Y) (g : Algebra_mor Y Z) : Algebra_mor X Z. Proof. exists (f · g). abstract (unfold is_Algebra_mor; rewrite assoc; rewrite Algebra_mor_commutes; rewrite <- assoc; rewrite Algebra_mor_commutes; rewrite functor_comp, assoc; apply idpath). Defined. Definition precategory_Alg_ob_mor : precategory_ob_mor := (Algebra,, Algebra_mor). Definition precategory_Alg_data : precategory_data := (precategory_Alg_ob_mor,, Algebra_mor_id,, Algebra_mor_comp). End Algebra_precategory_data. End Algebras. (** Definition of the category MonadAlg of algebras for T. Requires that C is a category. *) Section Algebra_category. Context {C : category} (T : Monad C). Definition Algebra_mor_eq {X Y : Algebra T} {f g : Algebra_mor T X Y} : (f : X --> Y) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro h. apply homset_property. Defined. Lemma is_precategory_precategory_Alg_data : is_precategory (precategory_Alg_data T). Proof. apply make_is_precategory; intros; apply Algebra_mor_eq. - apply id_left. - apply id_right. - apply assoc. - apply assoc'. Qed. Definition MonadAlg_precat : precategory := ( _,, is_precategory_precategory_Alg_data). Lemma has_homsets_MonadAlg : has_homsets MonadAlg_precat. Proof. intros X Y. apply (isofhleveltotal2 2). - apply homset_property. - intro f. apply isasetaprop. apply homset_property. Qed. Definition MonadAlg: category := MonadAlg_precat ,, has_homsets_MonadAlg. End Algebra_category. (** Adjunction between MonadAlg T and C, with right adjoint the forgetful functor and left adjoint the free algebra functor. *) Section Algebra_adjunction. Context {C : category} (T : Monad C). Definition forget_Alg_data : functor_data (MonadAlg T) C. Proof. exists (fun X => (X : Algebra T)). intros X Y f. apply f. Defined. (* forgetful functor from MonadAlg T to its underlying category *) Definition forget_Alg : functor (MonadAlg T) C. Proof. exists forget_Alg_data. abstract (split; red; intros; apply idpath). Defined. Definition free_Alg_data : functor_data C (MonadAlg T). Proof. exists (free_Algebra T). intros X Y f. exists (#T f). apply pathsinv0. apply (nat_trans_ax (μ T)). Defined. (* free T-algebra functor on C *) Definition free_Alg : functor C (MonadAlg T). Proof. exists free_Alg_data. abstract (split; red; intros; apply subtypePairEquality'; [ apply functor_id | apply homset_property | apply functor_comp | apply homset_property]). Defined. Definition free_forgetful_are_adjoints : are_adjoints free_Alg forget_Alg. Proof. use make_are_adjoints. - apply (make_nat_trans _ _ (η T)). intros X Y f. apply η. - use make_nat_trans. + intro X. exact (Alg_map T (X : Algebra T),, Algebra_multlaw T X). + intros X Y f. apply Algebra_mor_eq; cbn. apply pathsinv0. apply f. - abstract (split; intro X; [apply Algebra_mor_eq; cbn; apply Monad_law2 | apply Algebra_idlaw]). Defined. Definition forget_free_is_T : free_Alg ∙ forget_Alg = T. Proof. apply functor_eq. - apply homset_property. - apply idpath. Defined. Definition Alg_adjunction_monad_eq : Monad_from_adjunction free_forgetful_are_adjoints = T. Proof. apply Monad_eq_raw_data. apply idpath. Defined. End Algebra_adjunction. Section Liftings. Context {C : category} (S T : Monad C). (** A lifting of (T, η, μ) is a monad (T', η', μ') on (MonadAlg S) which commutes with the forgetful functor: << T' (MonadAlg S) ----------> (MonadAlg S) | | | forget_Alg | forget_Alg | | V V C ---------------------> C T >> and forget_Alg ∙ η = η' ∙ forget_Alg, forget_Alg ∙ μ = μ' ∙ forget_Alg. *) Definition lift_eq (T' : Monad (MonadAlg S)) : UU := functor_composite_data (forget_Alg S) T = functor_composite_data T' (forget_Alg S). Definition lift_η_commutes (T' : Monad (MonadAlg S)) (e : lift_eq T') : UU := transportf _ e (pre_whisker (forget_Alg S) (η T)) = (post_whisker (η T') (forget_Alg S)). (* forget_Alg S ∙ (T ∙ T) = (T' ∙ T') ∙ forget_Alg S *) Definition eq2 (T' : Monad (MonadAlg S))(e : lift_eq T') : functor_composite_data (forget_Alg S) (functor_composite_data T T) = functor_composite_data (functor_composite_data T' T') (forget_Alg S). Proof. apply (pathscomp0 (maponpaths (fun X => functor_composite_data X T) e)). exact (maponpaths (functor_composite_data T') e). Defined. Definition lift_μ_commutes (T' : Monad (MonadAlg S)) (e : lift_eq T') : UU := transportf (fun X => X ⟹ (T' ∙ forget_Alg S)) (eq2 T' e) (transportf _ e (pre_whisker (forget_Alg S) (μ T))) = (post_whisker (μ T') (forget_Alg S)). Definition lifting : UU := ∑ T' : Monad (MonadAlg S), (∑ e : lift_eq T', (lift_η_commutes T' e) × (lift_μ_commutes T' e)). (** A distributive law of S over T induces a lifting of T to S-Algebras *) Section Lifting_from_dist_law. Context {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a). Definition T_on_SAlg : Algebra S -> Algebra S. Proof. intro X. use tpair. - exists (T X). exact (a X · (# T) (Alg_map S X)). - abstract (split; cbn; [ rewrite assoc; rewrite <- functor_id; rewrite <- Algebra_idlaw; rewrite functor_comp; rewrite <- (monad_dist_law1 l); apply idpath | rewrite 2 assoc; rewrite functor_comp; rewrite assoc4; rewrite_cbn (nat_trans_ax a _ _ (Alg_map S X)); rewrite_cbn_inv (monad_dist_law4 l X); rewrite <- assoc4; rewrite <- assoc; rewrite <- functor_comp; rewrite_cbn (Algebra_multlaw S X); rewrite functor_comp; apply assoc]). Defined. Definition lift_functor : (MonadAlg S) ⟶ (MonadAlg S). Proof. use make_functor. - exists T_on_SAlg. intros X Y f. exists ((# T) (mor_from_Algebra_mor S f)). abstract (red; cbn; rewrite <- assoc; rewrite <- functor_comp; rewrite Algebra_mor_commutes; rewrite functor_comp; rewrite 2 assoc; apply cancel_postcomposition; apply pathsinv0; apply a). - abstract (split; red; intros; cbn; apply subtypePairEquality'; [ apply functor_id | apply homset_property | apply functor_comp | apply homset_property]). Defined. Definition lift_η : functor_identity (MonadAlg S) ⟹ lift_functor. Proof. use make_nat_trans. - intro X. cbn in X. exists (η T X). abstract (red; cbn; rewrite assoc; rewrite_cbn (monad_dist_law2 l X); apply (nat_trans_ax (η T))). - abstract (intros X Y f; apply subtypePath; cbn; [ intro; apply homset_property | apply (nat_trans_ax (η T))]). Defined. Definition lift_μ : lift_functor ∙ lift_functor ⟹ lift_functor. Proof. use make_nat_trans. - intro X. cbn in X. exists (μ T X). abstract (red; cbn; rewrite functor_comp; rewrite <- assoc4; rewrite assoc; rewrite_cbn_inv (monad_dist_law3 l X); rewrite <- assoc; rewrite_cbn (nat_trans_ax (μ T) _ _ (Alg_map S X)); apply assoc). - abstract (intros X Y f; apply subtypePath; cbn; [ intro; apply homset_property | apply (nat_trans_ax (μ T))]). Defined. Definition lift_monad : Monad (MonadAlg S). Proof. exists lift_functor. exists (lift_μ ,, lift_η). abstract (split; [ split; intro X; apply subtypePath; [ intro; apply homset_property | apply Monad_law1 | intro; apply homset_property | apply Monad_law2] | intro X; apply subtypePath; [ intro; apply homset_property | apply Monad_law3 ] ]). Defined. Definition lifting_from_dist_law : lifting. Proof. exists lift_monad. exists (idpath _). split. - apply nat_trans_eq. + apply homset_property. + intro X. apply idpath. - apply nat_trans_eq. + apply homset_property. + intro X. apply idpath. Defined. End Lifting_from_dist_law. (** TODO: Construct distributive law from lifting, show distributive laws are equivalent to liftings. *) End Liftings. UniMath-20231010/UniMath/CategoryTheory/Monads/Monads.v000066400000000000000000000512761451125700300224700ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of monads ([Monad]) - category of monads [category_Monad C] on [C] - Forgetful functor [forgetfunctor_Monad] from monads to endofunctors on [C] - Haskell style bind operation ([bind]) - A substitution operator for monads ([monadSubst]) - A helper lemma for proving equality of Monads ([Monad_eq_raw_data]) - Proof that [precategory_Monad C] is univalent if [C] is Written by: Benedikt Ahrens (started March 2015) Extended by: Anders Mörtberg, 2016 Extended by: Ralph Matthes, 2017 (Section MonadsUsingCoproducts) Rewrite by: Ralph Matthes, 2023, defining the category of monads through a displayed category over the endofunctors, this gives the previously missing univalence result nearly for free ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section Monad_disp_def. Context {C : category}. Definition disp_Monad_data (F : functor C C) : UU := (F ∙ F ⟹ F) × (functor_identity C ⟹ F). Definition disp_μ {F : functor C C} (T : disp_Monad_data F) : F ∙ F ⟹ F := pr1 T. Definition disp_η {F : functor C C} (T : disp_Monad_data F) : functor_identity C ⟹ F := pr2 T. Definition disp_Monad_laws {F : functor C C} (T : disp_Monad_data F) : UU := ( (∏ c : C, disp_η T (F c) · disp_μ T c = identity (F c)) × (∏ c : C, #F (disp_η T c) · disp_μ T c = identity (F c)) ) × (∏ c : C, #F (disp_μ T c) · disp_μ T c = disp_μ T (F c) · disp_μ T c). Lemma isaprop_disp_Monad_laws {F : functor C C} (T : disp_Monad_data F) : isaprop (disp_Monad_laws T). Proof. repeat apply isapropdirprod; apply impred; intro c; apply C. Qed. Definition disp_Monad_Mor_laws {F F' : functor C C} (T : disp_Monad_data F) (T' : disp_Monad_data F') (α : F ⟹ F') : UU := (∏ a : C, disp_μ T a · α a = α (F a) · #F' (α a) · disp_μ T' a) × (∏ a : C, disp_η T a · α a = disp_η T' a). Lemma isaprop_disp_Monad_Mor_laws {F F' : functor C C} (T : disp_Monad_data F) (T' : disp_Monad_data F') (α : F ⟹ F') : isaprop (disp_Monad_Mor_laws T T' α). Proof. apply isapropdirprod; apply impred; intro c; apply C. Qed. (* not needed - is part of [monads_category_displayed] Definition monads_disp_cat_ob_mor : disp_cat_ob_mor [C,C]. Proof. use tpair. - intro F. exact (∑ T : disp_Monad_data F, disp_Monad_laws T). - intros F F' [T Tlaws] [T' T'laws] α. exact (disp_Monad_Mor_laws T T' α). Defined. *) Lemma monads_category_id_subproof {F : functor C C} (T : disp_Monad_data F) (Tlaws : disp_Monad_laws T) : disp_Monad_Mor_laws T T (nat_trans_id F). Proof. split; intros a; simpl. - now rewrite id_left, id_right, functor_id, id_left. - now apply id_right. Qed. Lemma monads_category_comp_subproof {F F' F'' : functor C C} (T : disp_Monad_data F) (Tlaws : disp_Monad_laws T) (T' : disp_Monad_data F') (T'laws : disp_Monad_laws T') (T'' : disp_Monad_data F'') (T''laws : disp_Monad_laws T'') (α : F ⟹ F') (α' : F' ⟹ F'') : disp_Monad_Mor_laws T T' α → disp_Monad_Mor_laws T' T'' α' → disp_Monad_Mor_laws T T'' (nat_trans_comp _ _ _ α α'). Proof. intros Hα Hα'. split; intros; simpl. - rewrite assoc. set (H:=pr1 Hα a); simpl in H. rewrite H; clear H; rewrite <- !assoc. set (H:=pr1 Hα' a); simpl in H. rewrite H; clear H. rewrite functor_comp. apply maponpaths. now rewrite !assoc, nat_trans_ax. - rewrite assoc. eapply pathscomp0; [apply cancel_postcomposition, (pr2 Hα)|]. apply (pr2 Hα'). Qed. Definition monads_category_disp : disp_cat [C,C]. Proof. use disp_cat_from_SIP_data. - intro F. exact (∑ T : disp_Monad_data F, disp_Monad_laws T). - intros F F' [T Tlaws] [T' T'laws] α. exact (disp_Monad_Mor_laws T T' α). - intros F F' [T Tlaws] [T' T'laws] α. apply isaprop_disp_Monad_Mor_laws. - intros F [T Tlaws]. apply (monads_category_id_subproof _ Tlaws). - intros F F' F'' [T Tlaws] [T' T'laws] [T'' T''laws] α α'. apply (monads_category_comp_subproof _ Tlaws _ T'laws _ T''laws). Defined. Definition category_Monad : category := total_category monads_category_disp. Definition Monad : UU := ob category_Monad. Coercion functor_from_Monad (T : Monad) : functor C C := pr1 T. Definition μ (T : Monad) : T ∙ T ⟹ T := pr112 T. Definition η (T : Monad) : functor_identity C ⟹ T := pr212 T. Lemma Monad_law1 {T : Monad} : ∏ c : C, η T (T c) · μ T c = identity (T c). Proof. exact (pr1 (pr122 T)). Qed. Lemma Monad_law2 {T : Monad} : ∏ c : C, #T (η T c) · μ T c = identity (T c). Proof. exact (pr2 (pr122 T)). Qed. Lemma Monad_law3 {T : Monad} : ∏ c : C, #T (μ T c) · μ T c = μ T (T c) · μ T c. Proof. exact (pr222 T). Qed. Lemma monads_category_disp_eq (F : functor C C) (T T' : monads_category_disp F) : pr1 T = pr1 T' -> T = T'. Proof. intro H. induction T as [T Tlaws]. induction T' as [T' T'laws]. use total2_paths_f; [apply H |]. apply isaprop_disp_Monad_laws. Qed. Lemma monads_category_Pisset (F : functor C C) : isaset (∑ T : disp_Monad_data F, disp_Monad_laws T). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. { apply isasetdirprod; apply [C,C]. } intro T. apply isasetaprop. apply isaprop_disp_Monad_laws. Qed. Lemma monads_category_Hstandard {F : functor C C} (T : disp_Monad_data F) (Tlaws : disp_Monad_laws T) (T' : disp_Monad_data F) (T'laws : disp_Monad_laws T') : disp_Monad_Mor_laws T T' (nat_trans_id F) → disp_Monad_Mor_laws T' T (nat_trans_id F) → T,, Tlaws = T',, T'laws. Proof. intros H H'. apply subtypeInjectivity. { intro T0. apply isaprop_disp_Monad_laws. } cbn. induction T as [μ η]. induction T' as [μ' η']. apply dirprodeq; cbn. - apply nat_trans_eq; [apply C|]. intro a. assert (Hinst := pr1 H a). cbn in Hinst. rewrite id_right in Hinst. rewrite id_left in Hinst. rewrite functor_id in Hinst. rewrite id_left in Hinst. exact Hinst. - apply nat_trans_eq; [apply C|]. intro a. assert (Hinst := pr2 H a). cbn in Hinst. rewrite id_right in Hinst. exact Hinst. Qed. Definition is_univalent_monads_category_disp : is_univalent_disp monads_category_disp. Proof. use is_univalent_disp_from_SIP_data. - exact monads_category_Pisset. - intros F [T Tlaws] [T' T'laws]. apply monads_category_Hstandard. Defined. End Monad_disp_def. Arguments category_Monad _ : clear implicits. Arguments Monad _ : clear implicits. Definition is_univalent_category_Monad (C : univalent_category) : is_univalent (category_Monad C). Proof. apply SIP. - apply is_univalent_functor_category. apply C. - apply monads_category_Pisset. - intros F [T Tlaws] [T' T'laws]. apply monads_category_Hstandard. Defined. Section pointfree. Context (C : category) (T0: functor C C) (T : disp_Monad_data T0). Let EndC := [C, C]. Let η := disp_η T. Let μ := disp_μ T. Definition Monad_laws_pointfree : UU := ( (nat_trans_comp _ _ _ (pre_whisker T0 η) μ = identity(C:=EndC) T0) × (nat_trans_comp _ _ _ (post_whisker η T0) μ = identity(C:=EndC) T0) ) × (nat_trans_comp _ _ _ (post_whisker μ T0) μ = nat_trans_comp _ _ _ (pre_whisker T0 μ) μ). Lemma pointfree_is_equiv: Monad_laws_pointfree <-> disp_Monad_laws T. Proof. split. - intro H. induction H as [[H1 H2] H3]. split. + split. * intro c. apply (maponpaths pr1) in H1. apply toforallpaths in H1. apply H1. * intro c. apply (maponpaths pr1) in H2. apply toforallpaths in H2. apply H2. + intro c. apply (maponpaths pr1) in H3. apply toforallpaths in H3. apply H3. - intro H. induction H as [[H1 H2] H3]. split. + split. * apply nat_trans_eq_alt. exact H1. * apply nat_trans_eq_alt. exact H2. + apply nat_trans_eq; try apply homset_property. exact H3. Qed. Let T0' := T0 : EndC. Let η' := η: EndC⟦functor_identity C, T0'⟧. Let μ' := μ: EndC⟦functor_compose T0' T0', T0'⟧. Definition Monad_laws_pointfree_in_functor_category : UU := ( (#(pre_composition_functor _ _ _ T0') η' · μ' = identity(C:=EndC) T0') × (#(post_composition_functor _ _ _ T0') η' · μ' = identity(C:=EndC) T0') ) × (#(post_composition_functor _ _ _ T0') μ' · μ' = (#(pre_composition_functor _ _ _ T0') μ') · μ'). (** the last variant of the laws is convertible with the one before *) Goal Monad_laws_pointfree = Monad_laws_pointfree_in_functor_category. Proof. apply idpath. Qed. End pointfree. Definition Monad_Mor {C : category} (T T' : Monad C) : UU := category_Monad C ⟦T, T'⟧. Coercion nat_trans_from_monad_mor {C : category} (T T' : Monad C) (s : Monad_Mor T T') : T ⟹ T' := pr1 s. Definition Monad_Mor_laws {C : category} {T T' : Monad C} (α : T ⟹ T') : UU := (∏ a : C, μ T a · α a = α (T a) · #T' (α a) · μ T' a) × (∏ a : C, η T a · α a = η T' a). Definition Monad_Mor_η {C : category} {T T' : Monad C} (α : Monad_Mor T T') : ∏ a : C, η T a · α a = η T' a. Proof. exact (pr22 α). Qed. Definition Monad_Mor_μ {C : category} {T T' : Monad C} (α : Monad_Mor T T') : ∏ a : C, μ T a · α a = α (T a) · #T' (α a) · μ T' a. Proof. exact (pr12 α). Qed. Definition Monad_Mor_equiv {C : category} {T T' : Monad C} (α β : Monad_Mor T T') : α = β ≃ (pr1 α = pr1 β). Proof. apply subtypeInjectivity; intro a. apply isaprop_disp_Monad_Mor_laws. Defined. Lemma isaset_Monad_Mor {C : category} (T T' : Monad C) : isaset (Monad_Mor T T'). Proof. apply homset_property. Qed. Definition Monad_composition {C : category} {T T' T'' : Monad C} (α : Monad_Mor T T') (α' : Monad_Mor T' T'') : Monad_Mor T T'' := α · α'. Definition forgetfunctor_Monad (C : category) : functor (category_Monad C) [C,C] := pr1_category monads_category_disp. Lemma forgetMonad_faithful (C : category) : faithful (forgetfunctor_Monad C). Proof. apply faithful_pr1_category. intros T T' α. apply isaprop_disp_Monad_Mor_laws. Qed. (** * Definition and lemmas for bind *) Section bind. (** Definition of bind *) Context {C : category} {T : Monad C}. Definition bind {a b : C} (f : C⟦a,T b⟧) : C⟦T a,T b⟧ := # T f · μ T b. Lemma η_bind {a b : C} (f : C⟦a,T b⟧) : η T a · bind f = f. Proof. unfold bind. rewrite assoc. eapply pathscomp0; [apply cancel_postcomposition, (! (nat_trans_ax (η T) _ _ f))|]; simpl. rewrite <- assoc. eapply pathscomp0; [apply maponpaths, Monad_law1|]. apply id_right. Qed. Lemma bind_η {a : C} : bind (η T a) = identity (T a). Proof. apply Monad_law2. Qed. Lemma bind_bind {a b c : C} (f : C⟦a,T b⟧) (g : C⟦b,T c⟧) : bind f · bind g = bind (f · bind g). Proof. unfold bind; rewrite <- assoc. eapply pathscomp0; [apply maponpaths; rewrite assoc; apply cancel_postcomposition, (!nat_trans_ax (μ T) _ _ g)|]. rewrite !functor_comp, <- !assoc. now apply maponpaths, maponpaths, (!Monad_law3 c). Qed. End bind. (** * Operations for monads based on binary coproducts *) Section MonadsUsingCoproducts. Context {C : category} (T : Monad C) (BC : BinCoproducts C). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** operation of weakening in a monad *) Definition mweak (a b : C): C⟦T b, T (a ⊕ b)⟧ := bind (BinCoproductIn2 (BC _ _) · (η T _)). (** operation of exchange in a monad *) Definition mexch (a b c : C): C⟦T (a ⊕ (b ⊕ c)), T (b ⊕ (a ⊕ c))⟧. Proof. set (a1 := BinCoproductIn1 (BC _ _) · BinCoproductIn2 (BC _ _): C⟦a, b ⊕ (a ⊕ c)⟧). set (a21 := BinCoproductIn1 (BC _ _): C⟦b, b ⊕ (a ⊕ c)⟧). set (a22 := BinCoproductIn2 (BC _ _) · BinCoproductIn2 (BC _ _): C⟦c, b ⊕ (a ⊕ c)⟧). exact (bind ((BinCoproductArrow _ a1 (BinCoproductArrow _ a21 a22)) · (η T _))). Defined. (** * Substitution operation for monads *) Section MonadSubst. Definition monadSubstGen {b:C} (a : C) (e : C⟦b,T a⟧) : C⟦T (b ⊕ a), T a⟧ := bind (BinCoproductArrow _ e (η T a)). Lemma subst_interchange_law_gen (c b a : C) (e : C⟦c,T (b ⊕ a)⟧) (f : C⟦b,T a⟧): (monadSubstGen _ e) · (monadSubstGen _ f) = (mexch c b a) · (monadSubstGen _ (f · (mweak c a))) · (monadSubstGen _ (e · (monadSubstGen _ f))). Proof. unfold monadSubstGen, mexch. do 3 rewrite bind_bind. apply maponpaths. apply BinCoproductArrowsEq. + do 4 rewrite assoc. do 2 rewrite BinCoproductIn1Commutes. rewrite <- assoc. rewrite bind_bind. rewrite <- assoc. rewrite (η_bind(a:=let (pr1, _) := pr1 (BC b (c ⊕ a)) in pr1)). rewrite <- assoc. apply pathsinv0. eapply pathscomp0. * apply cancel_precomposition. rewrite assoc. rewrite BinCoproductIn2Commutes. rewrite (η_bind(a:=(c ⊕ a))). apply idpath. * now rewrite BinCoproductIn1Commutes. + rewrite assoc. rewrite BinCoproductIn2Commutes. rewrite (η_bind(a:=b ⊕ a)). do 3 rewrite assoc. rewrite BinCoproductIn2Commutes. apply BinCoproductArrowsEq. * rewrite BinCoproductIn1Commutes. rewrite <- assoc. rewrite bind_bind. do 2 rewrite assoc. rewrite BinCoproductIn1Commutes. rewrite <- assoc. rewrite (η_bind(a:=let (pr1, _) := pr1 (BC b (c ⊕ a)) in pr1)). rewrite assoc. rewrite BinCoproductIn1Commutes. unfold mweak. rewrite <- assoc. rewrite bind_bind. apply pathsinv0. apply remove_id_right; try now idtac. rewrite <- bind_η. apply maponpaths. rewrite <- assoc. rewrite (η_bind(a:=let (pr1, _) := pr1 (BC c a) in pr1)). now rewrite BinCoproductIn2Commutes. * rewrite BinCoproductIn2Commutes. rewrite <- assoc. rewrite bind_bind. do 2 rewrite assoc. rewrite BinCoproductIn2Commutes. do 2 rewrite <- assoc. rewrite (η_bind(a:=let (pr1, _) := pr1 (BC b (c ⊕ a)) in pr1)). apply pathsinv0. eapply pathscomp0. - apply cancel_precomposition. rewrite assoc. rewrite BinCoproductIn2Commutes. rewrite (η_bind(a:=(c ⊕ a))). apply idpath. - now rewrite BinCoproductIn2Commutes. Qed. Context (TC : Terminal C). Local Notation "1" := TC. Definition monadSubst (a : C) (e : C⟦1,T a⟧) : C⟦T (1 ⊕ a), T a⟧ := monadSubstGen a e. Lemma subst_interchange_law (a : C) (e : C⟦1,T (1 ⊕ a)⟧) (f : C⟦1,T a⟧): (monadSubst _ e) · (monadSubst _ f) = (mexch 1 1 a) · (monadSubst _ (f · (mweak 1 a))) · (monadSubst _ (e · (monadSubst _ f))). Proof. apply subst_interchange_law_gen. Qed. End MonadSubst. End MonadsUsingCoproducts. (** * Helper lemma for showing two monads are equal *) Section Monad_eq_helper. (** * Alternate (equivalent) definition of Monad *) Section Monad'_def. Definition raw_Monad_data (C : category) : UU := ∑ F : C -> C, (((∏ a b : ob C, a --> b -> F a --> F b) × (∏ a : ob C, F (F a) --> F a)) × (∏ a : ob C, a --> F a)). Coercion functor_data_from_raw_Monad_data {C : category} (T : raw_Monad_data C) : functor_data C C := make_functor_data (pr1 T) (pr1 (pr1 (pr2 T))). Definition Monad'_data_laws {C : category} (T : raw_Monad_data C) := ((is_functor T) × (is_nat_trans (functor_composite_data T T) T (pr2 (pr1 (pr2 T))))) × (is_nat_trans (functor_identity C) T (pr2 (pr2 T))). Definition Monad'_data (C : category) := ∑ (T : raw_Monad_data C), Monad'_data_laws T. Definition Monad'_data_to_Monad_data {C : category} (T : Monad'_data C) : disp_Monad_data (_,, pr1 (pr1 (pr2 T))) := ((pr2 (pr1 (pr2 (pr1 T))),, (pr2 (pr1 (pr2 T))))),, (pr2 (pr2 (pr1 T)),, (pr2 (pr2 T))). Definition Monad' (C : category) := ∑ (T : Monad'_data C), (disp_Monad_laws (Monad'_data_to_Monad_data T)). End Monad'_def. (** * Equivalence of Monad and Monad' *) Section Monad_Monad'_equiv. Definition Monad'_to_Monad {C : category} (T : Monad' C) : Monad C := (_,,(Monad'_data_to_Monad_data (pr1 T),, pr2 T)). Definition Monad_to_raw_data {C : category} (T : Monad C) : raw_Monad_data C. Proof. use tpair. - exact (functor_on_objects T). - use tpair. + use tpair. * exact (@functor_on_morphisms C C T). * exact (μ T). + exact (η T). Defined. Definition Monad_to_Monad'_data {C : category} (T : Monad C) : Monad'_data C := (Monad_to_raw_data T,, ((pr2 (T : functor C C),, (pr2 (μ T))),, pr2 (η T))). Definition Monad_to_Monad' {C : category} (T : Monad C) : Monad' C := (Monad_to_Monad'_data T,, pr22 T). Definition Monad'_to_Monad_to_Monad' {C : category} (T : Monad' C) : Monad_to_Monad' (Monad'_to_Monad T) = T := (idpath T). Definition Monad_to_Monad'_to_Monad {C : category} (T : Monad C) : Monad'_to_Monad (Monad_to_Monad' T) = T := (idpath T). End Monad_Monad'_equiv. Lemma Monad'_eq_raw_data (C : category) (T T' : Monad' C) : pr1 (pr1 T) = pr1 (pr1 T') -> T = T'. Proof. intro e. apply subtypePath. - intro. now apply isaprop_disp_Monad_laws. - apply subtypePath. + intro. apply isapropdirprod. * apply isapropdirprod. -- apply (isaprop_is_functor C C), homset_property. -- apply (isaprop_is_nat_trans C C), homset_property. * apply (isaprop_is_nat_trans C C), homset_property. + apply e. Qed. Lemma Monad_eq_raw_data (C : category) (T T' : Monad C) : Monad_to_raw_data T = Monad_to_raw_data T' -> T = T'. Proof. intro e. apply (invmaponpathsweq (_,, (isweq_iso _ _ (@Monad_to_Monad'_to_Monad C) (@Monad'_to_Monad_to_Monad' C)))). now apply (Monad'_eq_raw_data C). Qed. End Monad_eq_helper. Section Monads_from_adjunctions. Definition functor_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : functor C C := L∙R. Definition Monad_data_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : disp_Monad_data (functor_from_adjunction H). Proof. use tpair. - exact (pre_whisker L (post_whisker (adjcounit H) R)). - exact (adjunit H). Defined. Lemma Monad_laws_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : disp_Monad_laws (Monad_data_from_adjunction H). Proof. cbn. use make_dirprod. + use make_dirprod. * intro c; cbn. apply triangle_id_right_ad. * intro c; cbn. rewrite <- functor_id. rewrite <- functor_comp. apply maponpaths. apply triangle_id_left_ad. + intro c; cbn. do 2 (rewrite <- functor_comp). apply maponpaths. apply (nat_trans_ax ((counit_from_are_adjoints H))). Qed. Definition Monad_from_adjunction {C D : category} {L : functor C D} {R : functor D C} (H : are_adjoints L R) : Monad C. Proof. exists (functor_from_adjunction H). exact (Monad_data_from_adjunction H,, Monad_laws_from_adjunction H). Defined. End Monads_from_adjunctions. UniMath-20231010/UniMath/CategoryTheory/Monads/README.md000066400000000000000000000026361451125700300223330ustar00rootroot00000000000000Monads within CategoryTheory ============================ A wild mix of material from multiple authors. ## Contents * *Monads.v* --- monads based on monad multiplication, def. of bind operation and substitution, a rawer data format for such monads, monad construction from adjunction * *KleisliCategory.v* --- Kleisli category based on def. in Monads.v and its canonical adjunction * *RelativeMonads.v* --- relative monads (naturally in the setting of Kleisli triples), their Kleisli category (and its canonical relative adjunction), univalence * *KTriples.v* --- monads based on Kleisli triples (i.e., with Haskell-style bind operator), which are a special case of the relative monads * *KTriplesEquiv.v* --- establishes an isomorphism of categories between monads based on monad multiplication and on bind (Kleisli triples) * *Kleisli.v* --- weak equivalence between the "Kleisli" definition of monads (instantiated from RelativeMonads.v) and the "monoidal" definition (with monad multiplication) * *LModules.v* --- left modules over a monad, with pullback constructions * *Derivative.v* --- "maybe" monad, distributive laws for pairs of monads, composition of monads, derivative of a monad and a left module of a monad * *RelativeModules.v* --- modules over relative monads (generalizing material from LModules.v) * *MonadAlgebras.v* --- category of algebras of a monad, free-forgetful adjunction between algebras and base category UniMath-20231010/UniMath/CategoryTheory/Monads/RelMonads_Coreflection.v000066400000000000000000000222121451125700300256130ustar00rootroot00000000000000(** ********************************************************** Contents: - Given a coreflection F -| G : C -> D, and a monad relative to J : A -> C, construct a monad relative to FJ : A -> D - The postcomposition map extends to monad morphisms Benedikt Ahrens, October 2018 ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monads.RelativeMonads. Local Open Scope cat. (** * Postcomposition of a relative monad with a coreflection *) Section RMonad_transfer. Context {A C D : category} (J : functor A C) (F : functor C D) (G : functor D C) (eta : nat_trans (functor_identity C) (functor_composite F G)) (eps : nat_trans (functor_composite G F) (functor_identity D)) (H : form_adjunction F G eta eps). Let R : are_adjoints F G := ((eta,, eps) ,, H). Let NHW : (natural_hom_weq F G) := nathomweq_from_adj R. Let φ {X Y} (f : F X --> Y) : X --> G Y := hom_weq NHW f. Let φinv {X Y} (g : X --> G Y) : F X --> Y := invweq (hom_weq NHW) g. Hypothesis corefl : ∏ c : C, is_iso (eta c). Let ηinv (X : C) : G (F X) --> X := inv_from_iso (make_iso (eta X) (corefl X )). Let ηinv_is_natural : is_nat_trans (F ∙ G) (functor_identity _ ) (fun X => ηinv X). Proof. use is_nat_trans_inv_from_pointwise_inv. apply C. Qed. Section RelMonad_transfer_object. Variable (T : RelMonad_data J). (** The new relative monad is given, on objects, by applying the coreflection *) Definition RelMonad_composed_data : RelMonad_data (J ∙ F). Proof. repeat use tpair. - exact (λ a, F (T a)). - cbn. intro a. exact (#F (r_eta T _ )). - cbn. intros a b f. exact (φinv (r_bind T (φ f · ηinv _ ) · eta _ )). Defined. Notation "'σ'" := (r_bind T). Notation "'v'" := (r_eta T). Notation "'φ'" := (φ_adj R). Notation "'φ-1'" := (φ_adj_inv R). (** ** Proof of the monad axioms of the composed data *) Variable (TH : RelMonad_axioms T). Definition RelMonad_composed_axioms : RelMonad_axioms RelMonad_composed_data. Proof. repeat split; intros; cbn. - etrans. apply (inv_natural_precomp NHW). cbn. rewrite <- (id_right (# F (v c))). etrans. apply maponpaths_2. apply maponpaths. apply maponpaths. apply maponpaths_2. apply (hom_natural_precomp NHW). cbn. rewrite φ_adj_identity. cbn. rewrite <- assoc. set (RT := iso_inv_after_iso (make_iso (eta _ ) (corefl (T c)))). cbn in RT. simpl in RT. etrans. apply maponpaths_2. apply maponpaths. apply maponpaths. apply maponpaths. apply RT. rewrite id_right. etrans. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. etrans. apply maponpaths. apply r_bind_r_eta. apply TH. apply functor_id. - apply pathsinv0. etrans. 2: apply (inv_natural_precomp NHW). rewrite assoc. apply pathsinv0. etrans. apply maponpaths. apply maponpaths_2. apply r_eta_r_bind; apply TH. etrans. apply maponpaths. rewrite <- assoc. apply maponpaths. apply iso_after_iso_inv. rewrite id_right. apply (homotinvweqweq (hom_weq NHW )). - etrans. apply maponpaths. apply (inv_natural_precomp NHW). cbn. etrans. apply maponpaths. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. etrans. apply maponpaths_2. apply (inv_natural_precomp NHW). cbn. etrans. apply maponpaths_2. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. etrans. apply pathsinv0. apply functor_comp. etrans. apply maponpaths. apply r_bind_r_bind. apply TH. apply pathsinv0. etrans. apply (inv_natural_precomp NHW). cbn. etrans. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. etrans. apply maponpaths. apply maponpaths. apply maponpaths_2. apply maponpaths. apply maponpaths. etrans. apply (inv_natural_precomp NHW). cbn. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. apply maponpaths. apply maponpaths. etrans. apply maponpaths_2. apply (hom_natural_postcomp NHW). cbn. etrans. etrans. apply (!assoc _ _ _ ). apply maponpaths. apply ηinv_is_natural. cbn. apply assoc. Qed. End RelMonad_transfer_object. Definition RelMonad_composed (T : RelMonad J) : RelMonad (J ∙ F) := RelMonad_composed_data T,, RelMonad_composed_axioms _ T. (** ** Postcomposition of a monad morphism with a coreflection *) Section RelMonad_transfer_morphism. Context {T T' : RelMonad J} (f : RelMonadMor T T'). Notation "'σ'" := (r_bind _). Notation "'v'" := (r_eta _). Notation "'φ'" := (φ_adj R). Notation "'φ-1'" := (φ_adj_inv R). Definition RelMonadMor_composed_data : RelMonadMor_data (RelMonad_composed T) (RelMonad_composed T') := λ a, (#F (RelMonadMor_map f a)). Lemma RelMonadMor_composed_axioms : RelMonadMor_axioms RelMonadMor_composed_data. Proof. repeat split; cbn; intros. - unfold RelMonadMor_composed_data. cbn. etrans. apply (!functor_comp _ _ _ ). apply maponpaths. apply r_eta_α. apply f. - unfold RelMonadMor_composed_data. cbn. etrans. apply pathsinv0. apply (inv_natural_precomp NHW). cbn. rewrite assoc. etrans. apply (inv_natural_precomp NHW). cbn. etrans. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. rewrite functor_comp. apply pathsinv0. etrans. apply maponpaths_2. apply (inv_natural_precomp NHW). cbn. etrans. apply maponpaths_2. apply maponpaths. apply φ_adj_inv_unit. rewrite id_right. etrans. apply (!functor_comp _ _ _ ). etrans. apply maponpaths. apply (!(α_r_bind f) _ _ _ ). cbn. apply pathsinv0. etrans. apply (!functor_comp _ _ _ ). apply maponpaths. apply maponpaths. apply maponpaths. etrans. apply maponpaths_2. apply φ_adj_natural_postcomp. etrans. apply (!assoc _ _ _ ). etrans. apply maponpaths. apply ηinv_is_natural. apply assoc. Qed. Definition RelMonadMor_composed : RelMonadMor (RelMonad_composed T) (RelMonad_composed T') := RelMonadMor_composed_data ,, RelMonadMor_composed_axioms. End RelMonad_transfer_morphism. (** ** Postcomposing a monad with the right adjoint of a coreflection *) Section RelMonad_transfer_radj_object. Variable (T : RelMonad_data (J ∙ F)). Definition RelMonad_composed_radj_data : RelMonad_data J. Proof. repeat use tpair. - exact (λ a, G (T a)). - cbn. intro a. exact (φ (r_eta T _ )). - cbn. intros a b f. exact (#G (r_bind T (φ_adj_inv R f))). Defined. Notation "'σ'" := (r_bind T). Notation "'v'" := (r_eta T). Notation "'φ'" := (φ_adj R). Notation "'φ-1'" := (φ_adj_inv R). Variable (TH : RelMonad_axioms T). Definition RelMonad_composed_radj_axioms : RelMonad_axioms RelMonad_composed_radj_data. Proof. repeat split; intros; cbn. - etrans. do 2 apply maponpaths. apply φ_adj_inv_after_φ_adj. etrans. apply maponpaths. apply r_bind_r_eta. apply TH. apply functor_id. - etrans. apply pathsinv0. apply φ_adj_natural_postcomp. etrans. apply maponpaths. apply (r_eta_r_bind TH). apply φ_adj_after_φ_adj_inv. - etrans. apply (!functor_comp _ _ _ ). apply maponpaths. etrans. apply (r_bind_r_bind TH). apply maponpaths. apply pathsinv0. apply (φ_adj_inv_natural_postcomp R). Defined. End RelMonad_transfer_radj_object. Definition RelMonad_composed_radj (T : RelMonad (J ∙ F)) : RelMonad J := RelMonad_composed_radj_data T,, RelMonad_composed_radj_axioms _ T. (** ** Postcomposing a monad morphism with the right adjoint of a coreflection *) Section RelMonad_transfer_radj_morphism. Context {T T' : RelMonad (J ∙ F)} (f : RelMonadMor T T'). Notation "'σ'" := (r_bind _). Notation "'v'" := (r_eta _). Notation "'φ'" := (φ_adj R). Notation "'φ-1'" := (φ_adj_inv R). Definition RelMonadMor_composed_radj_data : RelMonadMor_data (RelMonad_composed_radj T) (RelMonad_composed_radj T') := λ a, (#G (RelMonadMor_map f a)). Lemma RelMonadMor_composed_radj_axioms : RelMonadMor_axioms RelMonadMor_composed_radj_data. Proof. repeat split; cbn; intros. - unfold RelMonadMor_composed_radj_data. cbn. etrans. apply pathsinv0, φ_adj_natural_postcomp . apply maponpaths. apply (r_eta_α f). - unfold RelMonadMor_composed_radj_data. cbn. etrans. apply (!functor_comp _ _ _ ). etrans. 2: { apply functor_comp. } apply maponpaths. etrans. apply maponpaths. apply maponpaths. apply (φ_adj_inv_natural_postcomp R). apply (α_r_bind f). Qed. Definition RelMonadMor_composed_radj : RelMonadMor (RelMonad_composed_radj T) (RelMonad_composed_radj T') := RelMonadMor_composed_radj_data ,, RelMonadMor_composed_radj_axioms. End RelMonad_transfer_radj_morphism. End RMonad_transfer. UniMath-20231010/UniMath/CategoryTheory/Monads/RelativeModules.v000066400000000000000000000330011451125700300243350ustar00rootroot00000000000000(* =================================================================================== *) (** * Modules over relative monads *) (* =================================================================================== *) (* ----------------------------------------------------------------------------------- *) (** Contents: *) (** *) (** - Definition of module over a relative monads [RelModule] *) (** - Functoriality for modules [mlift] *) (** - Morphisms between relative modules (over the same monad). *) (** *) (** Written by: Marco Maggesi (started March 2018) *) (* ----------------------------------------------------------------------------------- *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.RelativeMonads. Local Open Scope cat. (* ----------------------------------------------------------------------------------- *) (** ** Miscellanea *) (* ----------------------------------------------------------------------------------- *) Definition isaprop_RelMonad_axioms {C D : precategory_data} {J : C ⟶ D} (hs : has_homsets D) (R : RelMonad_data J) : isaprop (RelMonad_axioms R). Proof. repeat apply isapropdirprod; repeat (apply impred; intros); apply hs. Qed. (* ----------------------------------------------------------------------------------- *) (** ** Definition of module over a relative monad. *) (* ----------------------------------------------------------------------------------- *) Section RelModule_Definition. Context {C D : precategory_data} {J : C ⟶ D}. Definition RelModule_data (R : RelMonad_data J) : UU := ∑ F : C → D, ∏ c d, D ⟦J c, R d⟧ → D ⟦F c, F d⟧. Definition make_relmodule_data (R : RelMonad_data J) (F : C → D) (mbind : ∏ c d, D ⟦J c, R d⟧ → D ⟦F c, F d⟧) : RelModule_data R := F,, mbind. Definition RelModule_ob {R : RelMonad_data J} (M : RelModule_data R) : C → D := pr1 M. Coercion RelModule_ob : RelModule_data >-> Funclass. Section Projections_and_Laws. Context {R : RelMonad_data J}. Definition mbind (M : RelModule_data R) {c d} (f : D⟦J c, R d⟧) : D ⟦M c, M d⟧ := pr2 M _ _ f. Definition mlift (M : RelModule_data R) {a b} (f : C ⟦a, b⟧) : D ⟦pr1 M a, pr1 M b⟧ := mbind M (#J f · r_eta R _). Definition relmodule_functor_data (M : RelModule_data R) : functor_data C D := make_functor_data M (λ a b (f : a -->b), mlift M f). Definition RelModule_laws (M : RelModule_data R) : UU := RelMonad_axioms R × (∏ c, mbind M (r_eta R c) = identity _ ) × (∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧), mbind M f · mbind M g = mbind M (f · r_bind R g)). Coercion relmonad_axiom_from_relmodule {M : RelModule_data R} (X : RelModule_laws M) : RelMonad_axioms R := pr1 X. Definition mbind_r_eta {M : RelModule_data R} (X : RelModule_laws M) : ∏ c, mbind M (r_eta R c) = identity _ := pr1 (pr2 X). Definition mbind_mbind {M : RelModule_data R} (X : RelModule_laws M) : ∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧), mbind M f · mbind M g = mbind M (f · r_bind R g) := pr2 (pr2 X). Lemma isaprop_RelModule_laws (hs : has_homsets D) (M : RelModule_data R) : isaprop (RelModule_laws M). Proof. apply isapropdirprod. - apply isaprop_RelMonad_axioms, hs. - apply isapropdirprod; repeat (apply impred; intros); apply hs. Qed. Lemma mbind_mlift {M : RelModule_data R} (X : RelModule_laws M) {c d e : C} (f : J c --> R d) (g : d --> e) : mbind M f · mlift M g = mbind M (f · r_lift R g). Proof. apply (mbind_mbind X). Qed. End Projections_and_Laws. End RelModule_Definition. (* We make a separate section with stronger hypothesis [RelMonad] to state another fusion law involving [r_lift]. *) Section Projections_and_Laws_2. Context {C : precategory_data} {D : precategory}{J : C ⟶ D} {R : RelMonad J} {M : RelModule_data R} (X : RelModule_laws M). Lemma mlift_mbind {c d e : C} (f : c --> d) (g : J d --> R e) : mlift M f · mbind M g = mbind M (#J f · g). Proof. unfold mlift. etrans. { apply (mbind_mbind X). } apply maponpaths. etrans. { apply pathsinv0, assoc. } apply maponpaths. apply (r_eta_r_bind R). Qed. End Projections_and_Laws_2. (* ----------------------------------------------------------------------------------- *) (** ** Packing the full structure of Relative Module together. *) (* ----------------------------------------------------------------------------------- *) Definition RelModule {C D : precategory_data} {J : C ⟶ D} (R : RelMonad_data J) : UU := ∑ M : RelModule_data R, RelModule_laws M. Definition make_RelModule {C D : precategory_data} {J : C ⟶ D} (R : RelMonad_data J) (M : RelModule_data R) (HM : RelModule_laws M) : RelModule R := (M,, HM). Coercion RelModule_data_from_RelModule {C D : precategory_data} {J : C ⟶ D} {R : RelMonad_data J} (M : RelModule R) : RelModule_data R := pr1 M. Coercion RelModule_laws_from_RelModule {C D : precategory_data} {J : C ⟶ D} {R : RelMonad_data J} (M : RelModule R) : RelModule_laws M := pr2 M. (* ----------------------------------------------------------------------------------- *) (** ** Functoriality of Modules *) (* ----------------------------------------------------------------------------------- *) Section Functor_from_RelModule. Context {C : precategory_data} {D : precategory} {J : C ⟶ D}. Lemma mlift_id {R : RelMonad_data J} {M : RelModule_data R} (X : RelModule_laws M) (c : C) : mlift M (identity c) = identity (M c). Proof. transitivity (mbind M (r_eta R c)). 2: apply (mbind_r_eta X). unfold mlift. cbn. apply maponpaths. etrans. 2: apply id_left. apply maponpaths_2. apply functor_id. Qed. Context {R : RelMonad J} {M : RelModule_data R} (X : RelModule_laws M). Lemma mlift_mlift {c d e : C} (f : c --> d) (g : d --> e) : mlift M f · mlift M g = mlift M (f · g). Proof. unfold mlift at 2. etrans. { apply (mlift_mbind X). } unfold mlift. apply maponpaths. etrans. { apply assoc. } apply maponpaths_2. apply pathsinv0, functor_comp. Qed. Definition functor_data_from_relmodule : functor_data C D := functor_data_constr C D (RelModule_ob M : C → D) (λ a b (f : a --> b), mlift M f). Definition is_functor_mlift : is_functor functor_data_from_relmodule. Proof. split. - red; intro a. apply (mlift_id X). - red. intros. cbn. apply pathsinv0. apply mlift_mlift. Defined. Definition functor_from_relmodule : C ⟶ D := make_functor functor_data_from_relmodule is_functor_mlift. End Functor_from_RelModule. (* ----------------------------------------------------------------------------------- *) (** ** Morphisms of modules over a fixe relative monad. *) (* ----------------------------------------------------------------------------------- *) Section RelModule_Morphism_Definition. Section Part1. Context {C D : precategory_data} {J : C ⟶ D} {R : RelMonad_data J}. Definition is_relmodule_mor (M N : RelModule_data R) (φ : ∏ a : C, M a --> N a) : UU := (∏ a b (f : J a --> R b), mbind M f · φ b = φ a · mbind N f). Lemma isaprop_RelModule_Mor_laws (hs : has_homsets D) (M N : RelModule_data R) (φ : ∏ a : C, M a --> N a) : isaprop (is_relmodule_mor M N φ). Proof. repeat (apply impred; intro); apply hs. Qed. Definition RelModule_Mor (M N : RelModule R) : UU := ∑ (φ : ∏ a : C, M a --> N a), is_relmodule_mor M N φ. Definition relmodule_mor_map {M N : RelModule R} (φ : RelModule_Mor M N) : ∏ a : C, M a --> N a := pr1 φ. Coercion relmodule_mor_map : RelModule_Mor >-> Funclass. Coercion relmodule_mor_property {M N : RelModule R} (φ : RelModule_Mor M N) : is_relmodule_mor M N φ := pr2 φ. End Part1. (** now with [D : precategory, R : RelMonad J] *) Section Part2. Context {C : precategory_data} {D : precategory} {J : C ⟶ D} {R : RelMonad J}. Definition is_nat_trans_relmodule_mor {M N : RelModule R} {φ : ∏ a : C, M a --> N a} (Hφ : is_relmodule_mor M N φ) : is_nat_trans (functor_from_relmodule M) (functor_from_relmodule N) φ. Proof. intros a b f. cbn. unfold mlift. apply Hφ. Defined. Definition RelModule_Mor_equiv (hs : has_homsets D) {M N : RelModule R} (φ ψ : RelModule_Mor M N) : φ = ψ ≃ (pr1 φ = pr1 ψ). Proof. apply subtypeInjectivity; intro a. apply isaprop_RelModule_Mor_laws, hs. Defined. Definition nat_trans_from_relmodule_mor {M N : RelModule R} (φ : RelModule_Mor M N) : functor_from_relmodule M ⟹ functor_from_relmodule N := make_nat_trans (functor_from_relmodule M) (functor_from_relmodule N) φ (is_nat_trans_relmodule_mor φ). Definition is_relmodule_mor_id (M : RelModule R) : is_relmodule_mor M M (λ a, identity (M a)). Proof. intros a b f. etrans. - apply id_right. - apply pathsinv0, id_left. Qed. Definition relmodule_mor_id (M : RelModule R) : RelModule_Mor M M := ((λ a, identity (M a)),, is_relmodule_mor_id M). Definition is_relmodule_mor_comp {L M N : RelModule R} {φ} (φ_mor : is_relmodule_mor L M φ) {ψ} (ψ_mor : is_relmodule_mor M N ψ) : is_relmodule_mor L N (λ a, φ a · ψ a). Proof. intros a b f. etrans. { apply assoc. } etrans. { apply maponpaths_2, φ_mor. } etrans. { apply pathsinv0, assoc. } etrans. 2: apply assoc. apply maponpaths. apply ψ_mor. Qed. Definition relmodule_mor_comp {L M N : RelModule R} (φ : RelModule_Mor L M) (ψ : RelModule_Mor M N) : RelModule_Mor L N := ((λ a, φ a · ψ a),, is_relmodule_mor_comp φ ψ). End Part2. End RelModule_Morphism_Definition. (* ----------------------------------------------------------------------------------- *) (** ** Category of modules over a fixed relative monad. *) (* ----------------------------------------------------------------------------------- *) Section RelModule_Category. Context {C : precategory_data} {D : precategory} {J : C ⟶ D} (R : RelMonad J). Definition relmodule_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor (RelModule R) RelModule_Mor. Definition relmodule_precategory_data : precategory_data := make_precategory_data relmodule_precategory_ob_mor relmodule_mor_id (λ M N P (φ : RelModule_Mor M N) (ψ : RelModule_Mor N P), relmodule_mor_comp φ ψ). Lemma is_precategory_relmodule (hs : has_homsets D) : is_precategory relmodule_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat split. - intros x y f. apply (invmap (RelModule_Mor_equiv hs _ _ )). apply funextsec; intros a. apply id_left. - intros x y f. apply (invmap (RelModule_Mor_equiv hs _ _ )). apply funextsec; intros a. apply id_right. - intros x y z w f g h. apply (invmap (RelModule_Mor_equiv hs _ _ )). apply funextsec. intros a. apply assoc. Qed. Definition RelModule_Precategory (hs : has_homsets D) : precategory := make_precategory relmodule_precategory_data (is_precategory_relmodule hs). Definition has_homsets_RelModule_Precategory (hs : has_homsets D) : has_homsets (RelModule_Precategory hs). Proof. red. cbn. intros M N. apply isaset_total2. - apply impred_isaset. intros. apply hs. - intros P. apply isasetaprop. apply isaprop_RelModule_Mor_laws. apply hs. Defined. End RelModule_Category. (* ----------------------------------------------------------------------------------- *) (** ** Tautological module *) (* *) (** Any relative monad is a left module over itself. *) (* ----------------------------------------------------------------------------------- *) Section Tautological_RelModule. Context {C D : precategory_data} {J : C ⟶ D} (R : RelMonad J). Definition tautological_RelModule_data : RelModule_data R := make_relmodule_data R R (λ a b (f : D⟦J a, R b⟧), r_bind R f). Lemma tautological_RelModule_law : RelModule_laws tautological_RelModule_data. Proof. split. - exact R. - repeat split; cbn; intros. + apply (r_bind_r_eta R). + apply (r_bind_r_bind R). Qed. Definition tautological_RelModule : RelModule R := make_RelModule R tautological_RelModule_data tautological_RelModule_law. End Tautological_RelModule.UniMath-20231010/UniMath/CategoryTheory/Monads/RelativeMonads.v000066400000000000000000001237061451125700300241620ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of relative monads [RelMonad] - Functoriality for relative monads [r_lift] - Kleisli category associated to a relative monad [Kleisli_precat] [Kleisli_cat], canonical relative adjunction [rKleisli_functors_are_relative_adjoints] - Category of relative monads is univalent if the target category is [is_univalent_RelMonad] Reference: % \cite{DBLP:journals/corr/AltenkirchCU14} \par % Written by: Benedikt Ahrens (started May 2017) Extended by: Ralph Matthes (starting August 2018), in particular all on univalence ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** * Definition of relative monads *) Section RMonad_def. Context {C D : precategory_data} {J : functor_data C D}. (* implicitness of arguments for RelMonad_data are set after this section *) Definition RelMonad_data : UU := ∑ F : C -> D, (∏ c, D ⟦J c, F c⟧) × (∏ c d, D ⟦J c, F d⟧ → D ⟦F c, F d⟧). Definition RelMonad_ob (R : RelMonad_data) (c : C) : D := pr1 R c. Coercion RelMonad_ob : RelMonad_data >-> Funclass. Definition r_eta (R : RelMonad_data) c : D ⟦J c, R c⟧ := pr1 (pr2 R) c. Definition r_bind (R : RelMonad_data) {c d} (f : D⟦J c, R d⟧) : D ⟦R c, R d⟧ := pr2 (pr2 R) _ _ f. Definition RelMonad_axioms (R : RelMonad_data) : UU := (∏ c, r_bind R (r_eta R c) = identity _ ) × (∏ c d (f : D⟦J c, R d⟧), r_eta R _ · r_bind R f = f) × (∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧), r_bind R f · r_bind R g = r_bind R (f · r_bind R g)). Lemma isaprop_RelMonad_axioms (R : RelMonad_data)(hs : has_homsets D) : isaprop (RelMonad_axioms R). Proof. apply isapropdirprod. - apply impred_isaprop; intros. apply hs. - apply isapropdirprod; repeat (apply impred_isaprop; intros); apply hs. Defined. Definition r_bind_r_eta {R : RelMonad_data} (X : RelMonad_axioms R) : ∏ c, r_bind R (r_eta R c) = identity _ := pr1 X. Definition r_eta_r_bind {R : RelMonad_data} (X : RelMonad_axioms R) : ∏ c d (f : D⟦J c, R d⟧), r_eta R _ · r_bind R f = f := pr1 (pr2 X). Definition r_bind_r_bind {R : RelMonad_data} (X : RelMonad_axioms R) : ∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧), r_bind R f · r_bind R g = r_bind R (f · r_bind R g) := pr2 (pr2 X). (* implicitness of arguments for RelMonad are set after this section *) Definition RelMonad : UU := ∑ R : RelMonad_data, RelMonad_axioms R. Coercion RelMonad_data_from_RelMonad (R : RelMonad) : RelMonad_data := pr1 R. Coercion RelMonad_axioms_from_RelMonad (R : RelMonad) : RelMonad_axioms R := pr2 R. Lemma RelMonad_eq (R R' : RelMonad)(hs : has_homsets D) : pr1 R = pr1 R' -> R = R'. Proof. intro p. apply (total2_paths_f p). apply proofirrelevance. apply isaprop_RelMonad_axioms. exact hs. Defined. (** previous proof *) Lemma RelMonad_eq_obsolete (R R' : RelMonad)(hs : has_homsets D) : pr1 R = pr1 R' -> R = R'. Proof. intro p. apply subtypeInjectivity. - intro R''. apply isaprop_RelMonad_axioms. exact hs. - assumption. Defined. (** generalize [UniMath.CategoryTheory.Monads.KTriples.map] *) Definition r_lift (R : RelMonad_data) {c d : C} (f : c --> d) : R c --> R d := r_bind R (#J f · r_eta R _ ). End RMonad_def. (** generalize [UniMath.CategoryTheory.Monads.KTriples.map_id] and [UniMath.CategoryTheory.Monads.KTriples.map_map] *) Definition is_functor_r_lift {C: precategory_data} {D: precategory} {J : functor C D} (R : RelMonad) : is_functor (RelMonad_ob R,, @r_lift _ _ J R). Proof. split; [intro c | intros a b c f g]; cbn; unfold r_lift; cbn. - etrans. apply maponpaths. etrans. eapply (maponpaths (λ x, x · _ )). apply functor_id. apply id_left. apply (r_bind_r_eta R). - etrans. 2: { eapply pathsinv0; apply (r_bind_r_bind R). } apply maponpaths. etrans. apply map_on_two_paths. apply functor_comp. apply idpath. etrans. 2: { etrans. 2: apply assoc. eapply pathsinv0. apply maponpaths. apply (r_eta_r_bind R). } apply pathsinv0, assoc. Defined. Definition R_functor {C: precategory_data} {D: precategory} {J : functor C D} (R : RelMonad): functor C D := _,, is_functor_r_lift(J:=J) R. (** generalize [UniMath.CategoryTheory.Monads.KTriples.is_nat_trans_η] *) Definition is_nat_trans_r_eta {C: precategory_data} {D: precategory} {J : functor C D}(R : RelMonad) : is_nat_trans J (R_functor R) (r_eta R). Proof. red. intros c c' f. unfold R_functor; simpl. unfold r_lift; simpl. apply pathsinv0. apply (r_eta_r_bind R). Defined. Definition r_eta_nat_trans {C: precategory_data} {D: precategory} {J : functor C D}(R : RelMonad) : nat_trans J (R_functor R) := _ ,, is_nat_trans_r_eta R. (** generalize [UniMath.CategoryTheory.Monads.KTriples.map_bind] *) Definition r_lift_r_bind {C: precategory_data} {D: precategory} {J : functor C D}(R : RelMonad)(a b c : C) (f : b --> c) (g : J a --> R b) : r_bind R g · r_lift R f = r_bind R (g · r_lift R f). Proof. unfold r_lift. rewrite <- (r_bind_r_bind R). apply idpath. Defined. (** generalize [UniMath.CategoryTheory.Monads.KTriples.bind_map] *) Definition r_bind_r_lift {C: precategory_data} {D: precategory} {J : functor C D}(R : RelMonad)(a b c : C) (f : J b --> R c) (g : a --> b) : r_lift R g · r_bind R f = r_bind R (#J g · f). Proof. unfold r_lift. rewrite (r_bind_r_bind R). apply maponpaths. rewrite <- assoc. apply cancel_precomposition. apply (r_eta_r_bind R). Defined. (* Underlying functor argument should be explicit for RelMonad_data and RelMonad *) Arguments RelMonad_data {C} {D} J. Arguments RelMonad {C} {D} J. (** analogue of [UniMath.CategoryTheory.Core.Functors.functor_eq_eq_from_functor_ob_eq] *) Definition relmonad_eq_eq_from_relmonad_ob_eq {C: precategory_data} {D: precategory} (hs: has_homsets D) {J : functor C D} (R R' : RelMonad J) (p q : R = R') (H : base_paths _ _ (base_paths _ _ p) = base_paths _ _ (base_paths _ _ q)) : p = q. Proof. apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl. assert (H' : base_paths _ _ p = base_paths _ _ q). { apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl. apply (two_arg_paths_f H), uip. apply isaset_dirprod. - apply impred_isaset; intro c. apply hs. - apply impred_isaset; intro c; apply impred_isaset; intro d; apply impred_isaset; intro f. apply hs. } apply (two_arg_paths_f H'), uip, isasetaprop, isaprop_RelMonad_axioms, hs. Defined. (** Kleisli precategory associated to a relative monad *) Section Kleisli_precat. Context {C: precategory_data} {D : precategory} {J : functor_data C D}. Definition Kleisli_precat_ob_mor (R : RelMonad_data J) : precategory_ob_mor := make_precategory_ob_mor (ob C) (λ c d, J c --> R d). Definition Kleisli_precat_data (R : RelMonad_data J) : precategory_data := make_precategory_data (Kleisli_precat_ob_mor R) (λ c, r_eta R c) (λ a b c f g, f · r_bind R g). Lemma Kleisli_precat_is_precat (R : RelMonad J) : is_precategory (Kleisli_precat_data R). Proof. apply is_precategory_one_assoc_to_two. do 2 try apply tpair; try unfold compose; simpl. - intros a b f. apply (r_eta_r_bind R). - intros a b f. now rewrite (r_bind_r_eta R), id_right. - intros a b c d f g h. now rewrite <- assoc, (r_bind_r_bind R). Qed. Definition Kleisli_precat (R : RelMonad J) : precategory := (_,, Kleisli_precat_is_precat R). End Kleisli_precat. (** Kleisli category associated to a relative monad *) Section Kleisli_cat. Lemma Kleisli_precat_has_homsets {C : precategory_data} {D : category} {J : functor_data C D} (R : RelMonad J) (hs : has_homsets D) : has_homsets (Kleisli_precat_data R). Proof. intros a b. apply hs. Defined. Definition Kleisli_cat {C : precategory_data} {D : category} {J : functor_data C D} (R : RelMonad J) : category := (Kleisli_precat R,, Kleisli_precat_has_homsets R (homset_property D)). End Kleisli_cat. Section MorphismsOfRelativeMonads. Definition RelMonadMor_data {C D : precategory_data} {J : functor_data C D} (R R' : RelMonad_data J): UU := ∏ a : C, R a --> R' a. Definition RelMonadMor_axioms {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} (α : RelMonadMor_data R R') : UU := (∏ a : C, r_eta R a · α a = r_eta R' a) × (∏ (a b : C) (f : D⟦J a,R b⟧), α a · r_bind R' (f · α b) = (r_bind R f)· α b). Lemma isaprop_RelMonadMor_axioms {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} (α : RelMonadMor_data R R') (hs : has_homsets D) : isaprop (RelMonadMor_axioms α). Proof. apply isapropdirprod; repeat (apply impred_isaprop; intros); apply hs. Defined. (** generalize [UniMath.CategoryTheory.Monads.KTriples.Kleisli_Mor_η] *) Definition r_eta_α {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} {α : RelMonadMor_data R R'} (X : RelMonadMor_axioms α) : ∏ a : C, r_eta R a · α a = r_eta R' a := pr1 X. (** generalize [UniMath.CategoryTheory.Monads.KTriples.Kleisli_Mor_bind] *) Definition α_r_bind {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} {α : RelMonadMor_data R R'} (X : RelMonadMor_axioms α) : ∏ (a b : C) (f : D⟦J a,R b⟧), α a · r_bind R' (f · α b) = (r_bind R f) · α b := pr2 X. Definition RelMonadMor {C D : precategory_data} {J : functor_data C D} (R R' : RelMonad_data J) : UU := ∑ α : RelMonadMor_data R R', RelMonadMor_axioms α. Coercion RelMonadMor_data_from_RelMonadMor {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} (α : RelMonadMor R R') : RelMonadMor_data R R' := pr1 α. Coercion RelMonadMor_axioms_from_RelMonadMor {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} (α : RelMonadMor R R') : RelMonadMor_axioms α := pr2 α. Definition RelMonadMor_map {C D : precategory_data} {J : functor_data C D} {R R' : RelMonad_data J} (f : RelMonadMor R R') (X : C) : R X --> R' X := (f : RelMonadMor_data _ _ ) X. Definition RelMonadMor_equiv {C D : precategory_data} (hs : has_homsets D) {J : functor_data C D} {R R' : RelMonad_data J} (α β : RelMonadMor R R') : α = β ≃ ((α: RelMonadMor_data R R') = β). Proof. apply subtypeInjectivity. intro a. apply isaprop_RelMonadMor_axioms. exact hs. Defined. (** generalize [UniMath.CategoryTheory.Monads.KTriples.is_nat_trans_kleisli_mor] *) Definition is_nat_trans_RelMonadMor {C : precategory_data} {D: precategory} {J : functor C D} {R R' : RelMonad J} (α : RelMonadMor R R'): is_nat_trans (R_functor R) (R_functor R') (α:RelMonadMor_data R R'). Proof. red. intros c c' f. unfold R_functor; simpl. unfold r_lift; simpl. rewrite <- (α_r_bind α). rewrite <- assoc. now rewrite (r_eta_α α). Defined. Definition nat_trans_RelMonadMor {C : precategory_data} {D: precategory} {J : functor C D} {R R' : RelMonad J} (α : RelMonadMor R R'): nat_trans (R_functor R) (R_functor R') := _ ,, is_nat_trans_RelMonadMor α. End MorphismsOfRelativeMonads. Section PrecategoryOfRelativeMonads. (* ----- Identity Morphism ----- *) Lemma RelMonad_identity_laws {C : precategory_data} {D : precategory} {J : functor_data C D} (R : RelMonad_data J): RelMonadMor_axioms (λ a : C, identity (R a)). Proof. split; simpl; intros c. - apply id_right. - intros. do 2 rewrite id_right; apply id_left. Defined. Definition RelMonad_identity {C : precategory_data} {D : precategory} {J : functor_data C D} (R : RelMonad_data J): RelMonadMor R R := _ ,, RelMonad_identity_laws R. (* ----- Composition of Morphisms ----- *) (** generalize [UniMath.CategoryTheory.Monads.KTriples.Kleisli_composition_laws] *) Lemma RelMonad_composition_laws {C : precategory_data} {D : precategory} {J : functor_data C D} {R R' R'' : RelMonad_data J} (α : RelMonadMor R R') (α' : RelMonadMor R' R''): RelMonadMor_axioms (λ a : C, (α : RelMonadMor_data R R') a · (α' : RelMonadMor_data R' R'') a). Proof. split; intros; simpl. - rewrite assoc. rewrite (r_eta_α α). apply (r_eta_α α'). - intermediate_path ((α:RelMonadMor_data R R') a · ((α':RelMonadMor_data R' R'') a · r_bind R'' ((f · (α:RelMonadMor_data R R') b) · (α':RelMonadMor_data R' R'') b))). * now repeat rewrite assoc. * rewrite (α_r_bind α'). rewrite assoc. rewrite (α_r_bind α). apply pathsinv0. apply assoc. Defined. Definition RelMonad_composition {C : precategory_data} {D : precategory} {J : functor_data C D} {R R' R'' : RelMonad_data J} (α : RelMonadMor R R') (α' : RelMonadMor R' R''): RelMonadMor R R'' := _ ,, RelMonad_composition_laws α α'. (* ----- Precategory of relative Monads (for a given functor [J]) ----- *) Definition precategory_RelMonad_ob_mor {C : precategory_data} {D : precategory} (J : functor_data C D) : precategory_ob_mor := make_precategory_ob_mor (RelMonad J) RelMonadMor. Definition precategory_RelMonad_data {C : precategory_data} {D : precategory} (J : functor_data C D) : precategory_data. Proof. apply (make_precategory_data (precategory_RelMonad_ob_mor J)). - intro R. apply RelMonad_identity. - intros R R' R'' α α'. apply (RelMonad_composition α α'). Defined. Lemma precategory_RelMonad_axioms {C : precategory_data} {D : precategory} (hs : has_homsets D) (J : functor_data C D) : is_precategory (precategory_RelMonad_data J). Proof. repeat split; simpl; intros. - apply (invmap (RelMonadMor_equiv hs _ _ )). apply funextsec. intros x. apply id_left. - apply (invmap (RelMonadMor_equiv hs _ _ )). apply funextsec. intros x. apply id_right. - apply (invmap (RelMonadMor_equiv hs _ _ )). apply funextsec. intros x. apply assoc. - apply (invmap (RelMonadMor_equiv hs _ _ )). apply funextsec. intros x. apply assoc'. Defined. Definition precategory_RelMonad {C : precategory_data} {D : precategory} (hs : has_homsets D) (J : functor_data C D): precategory := _ ,, precategory_RelMonad_axioms hs J. Lemma has_homsets_RelMonad {C : precategory_data} {D : precategory} (hs: has_homsets D) (J : functor_data C D) : has_homsets (precategory_RelMonad hs J). Proof. intros R R'. simpl. unfold RelMonadMor. apply isaset_total2 . - apply impred_isaset. intro. apply hs. - intro α. apply isasetaprop. apply isaprop_RelMonadMor_axioms. apply hs. Defined. (* ----- Category of relative Monads (for a given functor [J]) ----- *) Definition category_RelMonad {C : precategory_data} (D : category) (J : functor_data C D) : category := precategory_RelMonad (homset_property D) J,, has_homsets_RelMonad (homset_property D) J. Definition forgetfunctor_RelMonad {C : precategory} (D : category) (J : functor C D) : functor (category_RelMonad D J) (functor_category C D). Proof. use make_functor. - simpl. use make_functor_data. + simpl. exact (λ R : RelMonad J, R_functor R). + simpl. intros R R' α. exact (nat_trans_RelMonadMor α). - split. + red. intros. simpl. apply nat_trans_eq. * apply D. * intros; apply idpath. + unfold functor_compax. simpl. intros R R' R'' α α'. apply nat_trans_eq. * apply D. * intro c. apply idpath. Defined. Lemma forgetRelMonad_faithful {C : precategory} (D : category) (J : functor C D) : faithful (forgetfunctor_RelMonad D J). Proof. intros R R'. simpl. apply isinclbetweensets. - apply isaset_total2. + apply impred_isaset. intros. apply D. + intros. apply isasetaprop. apply isaprop_RelMonadMor_axioms. apply D. - apply isaset_nat_trans. apply D. - intros α α' p. apply RelMonadMor_equiv. + apply D. + apply funextsec. intro c. change (nat_trans_RelMonadMor α c = nat_trans_RelMonadMor α' c). rewrite p. apply idpath. Defined. End PrecategoryOfRelativeMonads. Section RelativeMonads_saturated. Definition relmonadmor_weq_nat_trans_fails {C : precategory_data} (D : category) (J : functor C D) (R R': RelMonad J) : (category_RelMonad D J ⟦R, R'⟧) ≃ [C, D] ⟦R_functor R, R_functor R'⟧. Proof. apply (make_weq nat_trans_RelMonadMor). use isweq_iso. - intro α. exists (nat_trans_data_from_nat_trans α). split; intros. (* nothing like that! *) Abort. Definition relmonadmor_eq_type {C : precategory_data} (D : category) (J : functor C D)(R R': RelMonad J) : UU := ∑ p : z_iso (C := [C, D]) (R_functor R) (R_functor R'), RelMonadMor_axioms (nat_trans_data_from_nat_trans (morphism_from_z_iso _ _ p)). Definition relmonadmor_ob_eq {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D)(R R': RelMonad J) : (R = R') ≃ relmonadmor_eq_type D J R R'. Proof. eapply weqcomp. - apply total2_paths_equiv. - set (H1 := make_weq _ ( (is_univalent_functor_category C D H) (R_functor R) (R_functor R'))). Abort. (** better upstream *) Definition functor_z_iso_pointwise_if_z_iso' (C : precategory_data) (C' : category) (F G : ob [C, C']) (α: z_iso F G) : ∏ a : ob C, z_iso (pr1 F a) (pr1 G a) := λ a, tpair _ _ (is_functor_z_iso_pointwise_if_z_iso C C' _ F G (pr1 α) (pr2 α) a). Lemma idtoiso_functorcat_compute_pointwise' (C : precategory_data) (D : category) (F G : ob [C, D]) (p : F = G) (a : ob C) : functor_z_iso_pointwise_if_z_iso' C D F G (idtoiso p) a = idtoiso (toforallpaths (λ _ : ob C, D) (pr1 (pr1 F)) (pr1 (pr1 G)) (base_paths (pr1 F) (pr1 G) (base_paths F G p)) a). Proof. induction p. apply z_iso_eq. apply idpath. Qed. (** end of better upstream *) (** a rather trivial observation *) Definition is_z_iso_from_is_relmonadmor_z_iso {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : is_z_isomorphism(C := [C, D]) (nat_trans_RelMonadMor (pr1 α)). Proof. set (H' := z_iso_inv_after_z_iso α). set (H'':= z_iso_after_z_iso_inv α). set (α' := inv_from_z_iso α). exists (nat_trans_RelMonadMor α'). split; simpl. - unfold α'. unfold R_functor. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply (nat_trans_eq D). set (aux := maponpaths pr1 H'). apply toforallpaths in aux. exact aux. - unfold α'. unfold R_functor. apply (nat_trans_eq D). set (aux := maponpaths pr1 H''). apply toforallpaths in aux. exact aux. Defined. (** its immediate consequence *) Definition z_iso_from_is_relmonadmor_z_iso {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : z_iso(C := [C, D]) (R_functor R) (R_functor R') := (_,, is_z_iso_from_is_relmonadmor_z_iso D J α). Corollary z_iso_from_is_relmonadmor_z_iso_p {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') (c : C) : pr1 (pr1 α) c = functor_z_iso_pointwise_if_z_iso' C D (R_functor R) (R_functor R') (z_iso_from_is_relmonadmor_z_iso D J α) c. Proof. apply idpath. Defined. Lemma z_iso_from_is_relmonadmor_z_iso_idtoiso {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (p : @paths (category_RelMonad D J) R R'): z_iso_from_is_relmonadmor_z_iso D J (idtoiso p) = idtoiso(C := [C, D]) (maponpaths (@R_functor C D J) p). Proof. unfold z_iso_from_is_relmonadmor_z_iso. simpl. apply (z_iso_eq(C := [C, D])). simpl. apply (nat_trans_eq D). intro c. induction p. apply idpath. Qed. Definition alternative_inv_to_relmonadmor_z_iso {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : precategory_RelMonad D J ⟦R', R⟧. Proof. use tpair. - intro c. exact (inv_from_z_iso (functor_z_iso_pointwise_if_z_iso' C D (R_functor R) (R_functor R') (z_iso_from_is_relmonadmor_z_iso D J α) c)). - split. + intro c. apply pathsinv0. apply z_iso_inv_on_left. rewrite <- z_iso_from_is_relmonadmor_z_iso_p. apply pathsinv0. apply (r_eta_α (RelMonadMor_axioms_from_RelMonadMor (pr1 α))). + intros c d f. apply z_iso_inv_on_left. rewrite <- assoc. apply pathsinv0. apply z_iso_inv_on_right. do 2 rewrite <- z_iso_from_is_relmonadmor_z_iso_p. intermediate_path (pr1 (pr1 α) c · r_bind R' ((f · (inv_from_z_iso (functor_z_iso_pointwise_if_z_iso' C D (R_functor R) (R_functor R') (z_iso_from_is_relmonadmor_z_iso D J α) d) )) · (functor_z_iso_pointwise_if_z_iso' C D (R_functor R) (R_functor R') (z_iso_from_is_relmonadmor_z_iso D J α) d ))). 2: { apply cancel_precomposition. apply maponpaths. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } apply pathsinv0. rewrite <- z_iso_from_is_relmonadmor_z_iso_p. apply (α_r_bind (RelMonadMor_axioms_from_RelMonadMor (pr1 α))). Defined. Lemma alternative_inv_to_relmonadmor_z_iso_is_inv {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R'): alternative_inv_to_relmonadmor_z_iso D J α = inv_from_z_iso α. Proof. apply inv_z_iso_unique'. unfold precomp_with. apply RelMonadMor_equiv. - apply D. - apply funextsec. intro c. unfold alternative_inv_to_relmonadmor_z_iso. simpl. apply pathsinv0. apply z_iso_inv_on_left. rewrite id_left. intermediate_path (pr1 (pr1 α) c). { apply idpath. } rewrite z_iso_from_is_relmonadmor_z_iso_p. apply idpath. Qed. Corollary z_iso_from_is_relmonadmor_z_iso_inv_p {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') (c : C) : pr1 (inv_from_z_iso α) c = inv_from_z_iso (functor_z_iso_pointwise_if_z_iso' C D (R_functor R) (R_functor R') (z_iso_from_is_relmonadmor_z_iso D J α) c). Proof. rewrite <- alternative_inv_to_relmonadmor_z_iso_is_inv. apply idpath. Qed. (** the other direction, first the inverse monad morphism *) Definition inv_relmonadmor_from_is_z_iso {C : precategory_data} (D : category) (J : functor C D){R R': RelMonad J} (α : category_RelMonad D J ⟦R, R'⟧) : is_z_isomorphism(C := [C, D]) (nat_trans_RelMonadMor α) → category_RelMonad D J ⟦R', R⟧. Proof. intro T. set (fiso := (_,, T): z_iso(C := [C, D]) (R_functor R) (R_functor R')). set (finv := inv_from_z_iso fiso). exists (pr1 finv). unfold finv. split. - intros c. unfold fiso. etrans. { apply maponpaths, pathsinv0. apply (nat_trans_inv_pointwise_inv_after_p_z_iso C D D (R_functor R) (R_functor R')). } apply pathsinv0. apply z_iso_inv_on_left. simpl. apply pathsinv0. apply (r_eta_α (RelMonadMor_axioms_from_RelMonadMor α)). - intros a b f. unfold fiso. etrans. { apply cancel_postcomposition, pathsinv0. apply (nat_trans_inv_pointwise_inv_after_p_z_iso C D D (R_functor R) (R_functor R')). } etrans. { do 3 apply maponpaths. apply pathsinv0. apply (nat_trans_inv_pointwise_inv_after_p_z_iso C D D (R_functor R) (R_functor R')). } etrans. 2: { apply maponpaths. apply (nat_trans_inv_pointwise_inv_after_p_z_iso C D D (R_functor R) (R_functor R')). } apply z_iso_inv_on_left. rewrite <- assoc. apply pathsinv0. apply z_iso_inv_on_right. simpl. etrans. { apply pathsinv0. apply (α_r_bind (RelMonadMor_axioms_from_RelMonadMor α)). } apply cancel_precomposition. apply maponpaths. rewrite <- assoc. etrans. 2: { apply id_right. } apply cancel_precomposition. apply z_iso_inv_on_right. apply pathsinv0. apply id_right. Defined. (** verification that the proposed inverse monad morphism is suitable *) Definition is_relmonadmor_z_iso_from_is_z_iso {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (α : category_RelMonad D J ⟦R, R'⟧) : is_z_isomorphism(C := [C, D]) (nat_trans_RelMonadMor α) → is_z_isomorphism α. Proof. intro T. exists (inv_relmonadmor_from_is_z_iso D J α T). split; simpl. - (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply RelMonadMor_equiv. + apply D. + simpl. set (aux := z_iso_inv_after_z_iso ((_,, T): z_iso(C := [C, D]) (R_functor R) (R_functor R'))). apply (maponpaths pr1) in aux. exact aux. - apply RelMonadMor_equiv. + apply D. + simpl. set (aux := z_iso_after_z_iso_inv ((_,, T): z_iso(C := [C, D]) (R_functor R) (R_functor R'))). apply (maponpaths pr1) in aux. exact aux. Defined. (** its immediate consequence *) Definition relmonadmor_iso_from_is_z_iso {C : precategory_data} (D : category) (J : functor C D)(R R': RelMonad J) (α : precategory_RelMonad D J ⟦R, R'⟧) : is_z_isomorphism(C := [C, D]) (nat_trans_RelMonadMor α) → z_iso(C := category_RelMonad D J) R R'. Proof. intro T. exists α. exact (is_relmonadmor_z_iso_from_is_z_iso D J α T). Defined. Definition relmonadmor_z_iso_first_z_iso {C : precategory_data} (D : category) (J : functor C D)(R R': RelMonad J) : z_iso(C := category_RelMonad D J) R R' ≃ ∑ α : R_functor R ⟹ R_functor R', is_z_isomorphism(C := [C, D]) α. Proof. unfold z_iso. Abort. Definition pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} : z_iso(C := category_RelMonad D J) R R' -> pr1 (pr1 R) = pr1 (pr1 R'). Proof. intro α. change (pr1 (pr1 (R_functor R)) = pr1 (pr1 (R_functor R'))). do 2 apply maponpaths. set (H1 := make_weq _ ((is_univalent_functor_category C D H) (R_functor R) (R_functor R'))). apply H1. apply (z_iso_from_is_relmonadmor_z_iso D J α). Defined. Lemma pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso_idtoiso_aux {C : precategory_data} (D : category) (J : functor C D) {R R': RelMonad J} (p: @paths (category_RelMonad D J) R R'): base_paths (pr1 (R_functor R)) (pr1 (R_functor R')) (base_paths (R_functor R) (R_functor R') (maponpaths R_functor p)) = base_paths (pr1 R) (pr1 R') (base_paths R R' p). Proof. unfold base_paths. (* UniMath.MoreFoundations.Tactics.show_id_type. *) etrans. { apply maponpaths. apply (maponpathscomp (@R_functor C D J) (@functor_data_from_functor C D)). } etrans. { apply (maponpathscomp ((functor_data_from_functor C D ∘ R_functor)%functions) (@functor_on_objects C D)). } etrans. 2: { apply pathsinv0. apply (maponpathscomp (@RelMonad_data_from_RelMonad C D J) (@RelMonad_ob C D J)). } apply idpath. Qed. Lemma pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso_idtoiso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (p: @paths (category_RelMonad D J) R R'): pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso H J (idtoiso p) = base_paths (pr1 R) (pr1 R') (base_paths R R' p). Proof. unfold pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso. simpl. rewrite (z_iso_from_is_relmonadmor_z_iso_idtoiso D J). rewrite functor_eq_from_functor_z_iso_idtoiso. apply pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso_idtoiso_aux. Qed. Lemma transport_of_relmonad_η_is_pointwise {C : precategory_data} {D : precategory} (J : functor C D) (F0 G0 : ob C -> ob D) (F1 : ∏ a : ob C, J a --> F0 a) (gamma : F0 = G0 ) (c: ob C) : transportf (fun x : ob C -> ob D => ∏ a, D ⟦J a, x a⟧) gamma F1 c = transportf (fun d: ob D => D ⟦J c, d⟧) (toforallpaths (λ _ : ob C, D) F0 G0 gamma c) (F1 c). Proof. induction gamma. apply idpath. Defined. Lemma transport_of_relmonad_bind_is_pointwise {C : precategory_data} {D : precategory} (J : functor C D) (F0 G0 : ob C -> ob D) (F1 : ∏ a b : ob C , D ⟦J a, F0 b⟧ → D ⟦F0 a, F0 b⟧) (gamma : F0 = G0 ) (c d : ob C) (f : J c --> G0 d) : transportf (fun x : ob C -> ob D => ∏ a b : ob C , D ⟦J a, x b⟧ → D ⟦x a, x b⟧) gamma F1 c d f = double_transport (toforallpaths (λ _ : ob C, D) F0 G0 gamma c) (toforallpaths (λ _ : ob C, D) F0 G0 gamma d) (F1 c d (transportb (fun x : ob D => D ⟦J c, x⟧) (toforallpaths (λ _ : ob C, D) F0 G0 gamma d) f)). Proof. induction gamma. apply idpath. Defined. (** a preparation for the following lemma *) Lemma isotoid_functorcat_pointwise_aux (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C, D, D]) (p: F = G) (c: C) : let α := idtoiso p in toforallpaths (fun _ : ob C => ob D) (pr1 (pr1 F)) (pr1 (pr1 G)) (maponpaths pr1 (maponpaths pr1 (isotoid (functor_category C D) (is_univalent_functor_category C D H) α))) c = isotoid D H (functor_z_iso_pointwise_if_z_iso C D D F G α (pr2 α) c). Proof. induction p. cbn delta in *. unfold functor_z_iso_pointwise_if_z_iso. (* UniMath.MoreFoundations.Tactics.show_id_type. *) rewrite isotoid_idtoiso. unfold idtoiso. simpl. apply idtoiso_inj; try assumption. rewrite idtoiso_isotoid. simpl. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply z_iso_eq. apply idpath. Defined. (** general lemma on univalence of functor category *) Lemma isotoid_functorcat_pointwise (C : precategory_data) (D : category) (H : is_univalent D) (F G : ob [C, D, D]) (α: z_iso F G) (c: C) : toforallpaths (fun _ : ob C => ob D) (pr1 (pr1 F)) (pr1 (pr1 G)) (maponpaths pr1 (maponpaths pr1 (isotoid (functor_category C D) (is_univalent_functor_category C D H) α))) c = isotoid D H (functor_z_iso_pointwise_if_z_iso' C D F G α c). Proof. assert (aux := isotoid_functorcat_pointwise_aux C D H F G (isotoid (functor_category C D) (is_univalent_functor_category C D H) α)). rewrite (idtoiso_isotoid [C, D] _ ) in aux. apply aux. Qed. Definition η_relmonadmor_eq_from_relmonadmor_z_iso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (α: z_iso(C := category_RelMonad D J) R R') : transportf (fun x : ob C -> ob D => ∏ c, D ⟦J c, x c⟧) (pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso H J α) (pr1 (pr2 (pr1 R))) = pr1 (pr2 (pr1 R')). Proof. apply funextsec; intro c. rewrite transport_of_relmonad_η_is_pointwise. unfold pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso. simpl. rewrite <- idtoiso_postcompose. simpl. change (pr1 (pr2 (pr1 R')) c) with (r_eta R' c). change (pr1 (pr2 (pr1 R)) c) with (r_eta R c). intermediate_path (r_eta R c · (pr1 (pr1 α): RelMonadMor_data _ _) c). 2: { set (X := RelMonadMor_axioms_from_RelMonadMor (pr1 α)). exact (pr1 X c). (* does not terminate: apply (r_eta_α X). *) } apply cancel_precomposition. set (isor := z_iso_from_is_relmonadmor_z_iso D J α). set (isor_p := functor_z_iso_pointwise_if_z_iso' C D _ _ isor c). change (pr1 (pr1 α) c) with (pr1 isor_p). apply maponpaths. unfold precategory_data_from_precategory in isor. simpl in isor. unfold precategory_data_from_precategory; simpl. fold isor. intermediate_path (idtoiso (isotoid _ H isor_p)). 2: { apply idtoiso_isotoid. } apply maponpaths. change (functor_eq_from_functor_z_iso H (R_functor R) (R_functor R') isor) with (isotoid _ (is_univalent_functor_category C D H) isor). apply (isotoid_functorcat_pointwise C D H (R_functor R) (R_functor R')). Defined. Definition bind_relmonadmor_eq_from_relmonadmor_z_iso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (α: z_iso(C := category_RelMonad D J) R R') : transportf (fun x : ob C -> ob D => ∏ c d, D ⟦J c, x d⟧ → D ⟦x c, x d⟧) (pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso H J α) (pr2 (pr2 (pr1 R))) = pr2 (pr2 (pr1 R')). Proof. apply funextsec; intro c. apply funextsec; intro d. apply funextsec; intro f. rewrite transport_of_relmonad_bind_is_pointwise. unfold pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso. simpl. rewrite double_transport_idtoiso. rewrite <- assoc. set (isor := z_iso_from_is_relmonadmor_z_iso D J α). unfold precategory_data_from_precategory in isor. simpl in isor. unfold precategory_data_from_precategory; simpl. fold isor. change (functor_eq_from_functor_z_iso H (R_functor R) (R_functor R') isor) with (isotoid _ (is_univalent_functor_category C D H) isor). do 2 rewrite (isotoid_functorcat_pointwise C D H (R_functor R) (R_functor R')). do 2 rewrite idtoiso_isotoid. change (pr2 (pr2 (pr1 R')) c d f) with (r_bind R' f). change (pr2 (pr2 (pr1 R)) c d) with (r_bind(c:=c)(d:=d) R). rewrite (transportb_isotoid D H). do 2 rewrite <- (z_iso_from_is_relmonadmor_z_iso_inv_p D J α). rewrite <- (z_iso_from_is_relmonadmor_z_iso_p D J α). assert (aux := α_r_bind (RelMonadMor_axioms_from_RelMonadMor (inv_from_z_iso α)) c d f). etrans. { apply assoc. } etrans. { apply cancel_postcomposition. apply aux. } intermediate_path (r_bind R' f · identity _). 2: { apply id_right. } etrans. { apply pathsinv0. apply assoc. } apply cancel_precomposition. assert (aux2 := z_iso_after_z_iso_inv α). apply (maponpaths pr1) in aux2. apply toforallpaths in aux2. apply aux2. Defined. Definition relmonad_eq_from_relmonad_z_iso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : R = R'. Proof. apply RelMonad_eq. - exact D. - set (Hob := pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso H J α). apply (total2_paths_f Hob). apply dirprodeq. + intermediate_path (transportf (λ F : C → D, ∏ c : C, D ⟦ J c, F c ⟧) Hob (pr1 (pr2 (pr1 R)))). { apply pathsinv0. apply (transport_map (fun F => dirprod_pr1(X := ∏ c : C, D ⟦ J c, F c ⟧)(Y := ∏ c d : C, D ⟦ J c, F d ⟧ → D ⟦ F c, F d ⟧))). } apply (η_relmonadmor_eq_from_relmonadmor_z_iso H J α). + intermediate_path (transportf (λ F : C → D, ∏ c d : C, D ⟦ J c, F d ⟧ → D ⟦ F c, F d ⟧) Hob (pr2 (pr2 (pr1 R)))). { apply pathsinv0. apply (transport_map (fun F => dirprod_pr2(X := ∏ c : C, D ⟦ J c, F c ⟧)(Y := ∏ c d : C, D ⟦ J c, F d ⟧ → D ⟦ F c, F d ⟧))). } apply (bind_relmonadmor_eq_from_relmonadmor_z_iso H J α). Defined. (* former more destructive proof: *) Definition relmonad_eq_from_relmonad_z_iso_obsolete {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : R = R'. Proof. set (Hob := pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso H J α). assert (η_eq := η_relmonadmor_eq_from_relmonadmor_z_iso H J α). assert (bind_eq := bind_relmonadmor_eq_from_relmonadmor_z_iso H J α). fold Hob in η_eq, bind_eq. induction R as [[F [e b]] a]. induction R' as [[F' [e' b']] a']. simpl in Hob. induction Hob. cbn in η_eq, bind_eq. apply RelMonad_eq. + exact D. + simpl. apply maponpaths. apply pathsdirprod; assumption. Defined. Lemma relmonad_eq_from_relmonad_z_iso_idtoiso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (p: R = R') : relmonad_eq_from_relmonad_z_iso H J (idtoiso(C := category_RelMonad D J) p) = p. Proof. apply relmonad_eq_eq_from_relmonad_ob_eq. - apply D. - unfold relmonad_eq_from_relmonad_z_iso. unfold RelMonad_eq. rewrite base_total2_paths. rewrite base_total2_paths. apply pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso_idtoiso. Qed. Lemma idtoiso_relmonad_eq_from_relmonad_z_iso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) {R R': RelMonad J} (α : z_iso(C := category_RelMonad D J) R R') : idtoiso(C := category_RelMonad D J) (relmonad_eq_from_relmonad_z_iso H J α) = α. Proof. apply (z_iso_eq(C := category_RelMonad D J)). (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply RelMonadMor_equiv. - apply D. - (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply funextsec; intro c. (* UniMath.MoreFoundations.Tactics.show_id_type. *) etrans. { apply z_iso_from_is_relmonadmor_z_iso_p. } rewrite (z_iso_from_is_relmonadmor_z_iso_idtoiso D J (relmonad_eq_from_relmonad_z_iso H J α)). rewrite idtoiso_functorcat_compute_pointwise'. unfold relmonad_eq_from_relmonad_z_iso. unfold RelMonad_eq. rewrite pr1_pr1_relmonadmor_eq_from_relmonadmor_z_iso_idtoiso_aux. rewrite base_total2_paths. rewrite base_total2_paths. intermediate_path (pr1 (idtoiso (isotoid D H (functor_z_iso_pointwise_if_z_iso' C D _ _ (z_iso_from_is_relmonadmor_z_iso D J α) c)))). 2: { rewrite idtoiso_isotoid. apply idpath. } apply maponpaths. apply maponpaths. apply isotoid_functorcat_pointwise. Qed. Definition relmonadmor_idtoiso {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D)(R R': RelMonad J) : (R = R') ≃ z_iso(C := category_RelMonad D J) R R'. Proof. apply (make_weq (@idtoiso (category_RelMonad D J) R R')). use isweq_iso. - exact (relmonad_eq_from_relmonad_z_iso H J). - intro p. exact (relmonad_eq_from_relmonad_z_iso_idtoiso H J p). - intro α. exact (idtoiso_relmonad_eq_from_relmonad_z_iso H J α). Defined. Lemma isweq_idtoiso_RelMonad {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D)(R R': RelMonad J) : isweq (@idtoiso (category_RelMonad D J) R R'). Proof. apply (isweqhomot (relmonadmor_idtoiso H J R R')). - intro p. induction p. apply idpath. - apply (pr2 _ ). Qed. Lemma is_univalent_RelMonad {C : precategory_data} {D : category} (H: is_univalent D) (J : functor C D) : is_univalent (category_RelMonad D J). Proof. intros R R'. apply isweq_idtoiso_RelMonad. exact H. Defined. End RelativeMonads_saturated. Section RelAdjunctionWithKleisliCategory. (** The canonical relative adjunction between J and the Kleisli category of a J-relative monad This is the obvious generalization of the material in [UniMath.CategoryTheory.Monads.KleisliCategory]. *) Definition Left_rKleisli_functor_data {C: precategory_data} {D : precategory} {J : functor_data C D} (R: RelMonad J) : functor_data C (Kleisli_precat R). Proof. use make_functor_data. - apply idfun. - intros a b f; unfold idfun. exact (#J f · (r_eta R) b). Defined. Lemma Left_rKleisli_is_functor {C: precategory_data} {D : precategory} {J : functor C D} (R: RelMonad J) : is_functor (Left_rKleisli_functor_data R). Proof. split. - intro a. unfold Left_rKleisli_functor_data; simpl. rewrite functor_id. apply id_left. - intros a b c f g. unfold Left_rKleisli_functor_data; simpl. unfold compose at 3; simpl. rewrite functor_comp. do 2 (rewrite <- assoc). apply cancel_precomposition. apply pathsinv0. apply (r_eta_r_bind R). Defined. Definition Left_rKleisli_functor {C: precategory_data} {D : precategory} {J : functor C D} (R: RelMonad J) : functor C (Kleisli_precat R) := (Left_rKleisli_functor_data R,,Left_rKleisli_is_functor R). Definition Right_rKleisli_functor_data {C: precategory_data} {D : precategory} {J : functor_data C D} (R: RelMonad J): functor_data (Kleisli_precat R) D. Proof. use make_functor_data. - exact R. - intros a b. apply r_bind. Defined. Lemma Right_rKleisli_is_functor {C: precategory_data} {D : precategory} {J : functor C D} (R: RelMonad J) : is_functor (Right_rKleisli_functor_data R). Proof. use tpair. - intro a. unfold Right_rKleisli_functor_data; unfold identity; unfold functor_on_morphisms; simpl. apply (r_bind_r_eta R). - intros a b c f g; simpl. apply pathsinv0. apply (r_bind_r_bind R). Defined. Definition Right_rKleisli_functor {C: precategory_data} {D : precategory} {J : functor C D} (R: RelMonad J) : functor (Kleisli_precat R) D := (Right_rKleisli_functor_data R,,Right_rKleisli_is_functor R). (** Composition of the left and right Kleisli functors is equal to [R] as a functor **) Definition rKleisli_functor_left_right_compose {C: precategory} {D : precategory} (hs : has_homsets D) {J : functor C D} (R: RelMonad J) : (Left_rKleisli_functor R) ∙ (Right_rKleisli_functor R) = R_functor R. Proof. use functor_eq. - exact hs. - use functor_data_eq_from_nat_trans. + intro a; apply idpath. + intros a b f; simpl. rewrite id_right. rewrite id_left. apply idpath. Defined. (** Showing that these functors are relative adjoints *) Definition rKleisli_functors_are_relative_adjoints {C: precategory_data} {D : precategory} (hs : has_homsets D) {J : functor C D} (R: RelMonad J) : are_relative_adjoints J (Left_rKleisli_functor R) (Right_rKleisli_functor R). Proof. use tpair. - intros a b. use tpair. + simpl. apply idfun. + simpl. apply idisweq. - simpl; split. + intros a b f c h. unfold compose at 1; simpl. rewrite <- assoc. apply cancel_precomposition. apply (r_eta_r_bind R). + intros a b f c k. reflexivity. Defined. End RelAdjunctionWithKleisliCategory. UniMath-20231010/UniMath/CategoryTheory/Monics.v000066400000000000000000000164021451125700300212460ustar00rootroot00000000000000(** * Monics *) (** ** Contents - Definitions of Monics - Construction of the subcategory of Monics - Construction of monics in functor categories *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. (** * Definition of Monics *) Section def_monic. Variable C : category. Let hs : has_homsets C := homset_property C. (** Definition and construction of isMonic. *) Definition isMonic {y z : C} (f : y --> z) : UU := ∏ (x : C) (g h : x --> y), g · f = h · f -> g = h. Definition make_isMonic {y z : C} (f : y --> z) (H : ∏ (x : C) (g h : x --> y), g · f = h · f -> g = h) : isMonic f := H. Lemma isapropisMonic {y z : C} (f : y --> z) : isaprop (isMonic f). Proof. apply impred_isaprop; intros t. apply impred_isaprop; intros g. apply impred_isaprop; intros h. apply impred_isaprop; intros H. apply hs. Qed. (** Definition and construction of Monic. *) Definition Monic (y z : C) : UU := ∑ f : y --> z, isMonic f. Definition make_Monic {y z : C} (f : y --> z) (H : isMonic f) : Monic y z := tpair _ f H. (** Gets the arrow out of Monic. *) Definition MonicArrow {y z : C} (M : Monic y z) : C⟦y, z⟧ := pr1 M. Coercion MonicArrow : Monic >-> precategory_morphisms. Definition MonicisMonic {y z : C} (M : Monic y z) : isMonic M := pr2 M. (** Isomorphism to isMonic and Monic. *) Lemma is_iso_isMonic {y x : C} (f : y --> x) (H : is_z_isomorphism f) : isMonic f. Proof. apply make_isMonic. intros z g h X. apply (post_comp_with_z_iso_is_inj H). exact X. Qed. Lemma is_iso_Monic {y x : C} (f : y --> x) (H : is_z_isomorphism f) : Monic y x. Proof. apply (make_Monic f (is_iso_isMonic f H)). Defined. (** Identity to isMonic and Monic. *) Lemma identity_isMonic {x : C} : isMonic (identity x). Proof. apply (is_iso_isMonic (identity x) (is_z_isomorphism_identity x)). Defined. Lemma identity_Monic {x : C} : Monic x x. Proof. exact (tpair _ (identity x) (identity_isMonic)). Defined. (** Composition of isMonics and Monics. *) Definition isMonic_comp {x y z : C} (f : x --> y) (g : y --> z) : isMonic f -> isMonic g -> isMonic (f · g). Proof. intros X X0. apply make_isMonic. intros x0 g0 h X1. repeat rewrite assoc in X1. apply X0 in X1. apply X in X1. apply X1. Qed. Definition Monic_comp {x y z : C} (M1 : Monic x y) (M2 : Monic y z) : Monic x z := tpair _ (M1 · M2) (isMonic_comp M1 M2 (pr2 M1) (pr2 M2)). (** If precomposition of g with f is a monic, then f is a monic. *) Definition isMonic_postcomp {x y z : C} (f : x --> y) (g : y --> z) : isMonic (f · g) -> isMonic f. Proof. intros X. intros w φ ψ H. apply (maponpaths (λ f', f' · g)) in H. repeat rewrite <- assoc in H. apply (X w _ _ H). Defined. Lemma isMonic_path {x y : C} (f1 f2 : x --> y) (e : f1 = f2) (isM : isMonic f1) : isMonic f2. Proof. induction e. exact isM. Qed. (** Transport of isMonic *) Lemma transport_target_isMonic {x y z : C} (f : x --> y) (E : isMonic f) (e : y = z) : isMonic (transportf (precategory_morphisms x) e f). Proof. induction e. apply E. Qed. Lemma transport_source_isMonic {x y z : C} (f : y --> z) (E : isMonic f) (e : y = x) : isMonic (transportf (λ x' : ob C, precategory_morphisms x' z) e f). Proof. induction e. apply E. Qed. End def_monic. Arguments isMonic [C] [y] [z] _. (** * Construction of the subcategory consisting of all monics. *) Section monics_subcategory. Variable C : category. Let hs : has_homsets C := homset_property C. Definition hsubtype_obs_isMonic : hsubtype C := (λ c : C, make_hProp _ isapropunit). Definition hsubtype_mors_isMonic : ∏ (a b : C), hsubtype (C⟦a, b⟧) := (λ a b : C, (fun f : C⟦a, b⟧ => make_hProp _ (isapropisMonic C f))). Definition subprecategory_of_monics : sub_precategories C. Proof. use tpair. split. - exact hsubtype_obs_isMonic. - exact hsubtype_mors_isMonic. - cbn. unfold is_sub_precategory. cbn. split. + intros a tt. exact (identity_isMonic C). + apply isMonic_comp. Defined. Definition has_homsets_subprecategory_of_monics : has_homsets subprecategory_of_monics. Proof. intros a b. apply is_set_sub_precategory_morphisms. Qed. Definition subcategory_of_monics : category := make_category _ has_homsets_subprecategory_of_monics. Definition subprecategory_of_monics_ob (c : C) : ob (subcategory_of_monics) := tpair _ c tt. Definition subprecategory_of_monics_mor {c' c : C} (f : c' --> c) (isM : isMonic f) : subcategory_of_monics⟦subprecategory_of_monics_ob c', subprecategory_of_monics_ob c⟧ := tpair _ f isM. (*A morphism (f,,s) in subcategory_of_monics is a z_iso if the underlying morphism is also a z_iso, because the inverse must be monic. *) Local Lemma is_z_iso_in_subcategory_of_monics_from_is_z_iso (a b : subcategory_of_monics) (f : C⟦ pr1 a , pr1 b ⟧) (p : isMonic f) (H : is_z_isomorphism f) : is_z_isomorphism (precategory_morphisms_in_subcat f p). Proof. use make_is_z_isomorphism. + use precategory_morphisms_in_subcat. - exact (is_z_isomorphism_mor H). - use is_iso_isMonic. use is_z_isomorphism_inv. + induction (is_z_isomorphism_is_inverse_in_precat H) as (H1,H2). split. - use eq_in_sub_precategory. exact H1. - use eq_in_sub_precategory. exact H2. Defined. (*The converse of the previous result is always true, see [is_z_iso_from_is_z_iso_in_subcategory]*) Definition is_z_iso_in_subcategory_of_monics_weq (a b : subcategory_of_monics) (f : a --> b) : (is_z_isomorphism (pr1 f)) ≃ (is_z_isomorphism f). Proof. use weqimplimpl. + use is_z_iso_in_subcategory_of_monics_from_is_z_iso. + use is_z_iso_from_is_z_iso_in_subcategory. + use (isaprop_is_z_isomorphism). + use (isaprop_is_z_isomorphism). Defined. End monics_subcategory. (** * In functor categories monics can be constructed from pointwise monics *) Section monics_functorcategories. Lemma is_nat_trans_monic_from_pointwise_monics (C D : category) (F G : ob (functor_category C D)) (α : F --> G) (H : ∏ a : ob C, isMonic (pr1 α a)) : isMonic α. Proof. intros G' β η H'. use (nat_trans_eq). - apply D. - intros x. set (H'' := nat_trans_eq_pointwise H' x). cbn in H''. apply (H x) in H''. exact H''. Qed. End monics_functorcategories. (** Faithful functors reflect monomorphisms. *) Lemma faithful_reflects_mono {C D : category} (F : functor C D) (FF : faithful F) : reflects_morphism F (@isMonic). Proof. unfold reflects_morphism. intros ? ? ? is_monic_Ff. intros ? ? ? eqcomp. apply (Injectivity (# F)). - apply isweqonpathsincl, FF. - apply is_monic_Ff. refine (!(functor_comp F g f) @ _). refine (_ @ functor_comp F h f). apply maponpaths; assumption. Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/000077500000000000000000000000001451125700300213665ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/Adjunctions.v000066400000000000000000001026721451125700300240460ustar00rootroot00000000000000(******************************************************************************************** Monoidal Adjunctions In this file, we define monoidal adjunctions. We define this notion in the following way: a monoidal adjunction is adjunction of categories such that both functors are lax monoidal and such that the unit and counit are monoidal transformations. This is given in [monoidal_adjunction]. A reference for this notion is Section 5.14 in https://www.irif.fr/~mellies/mpri/mpri-ens/biblio/categorical-semantics-of-linear-logic.pdf Note: this notion is what you obtain by unfolding adjunctions internal to the bicategory of monoidal categories. However, in practice it is often useful to use the following characterization: an adjunction is monoidal if the left adjoint is a strong monoidal functor. A reference for this result is Lemma 13 in https://hal.science/hal-00154229/document. The relevant statements are [monoidal_adjunction_from_strong] and [is_strong_left_adjoint]. We prove the same results for symmetric monoidal adjunctions. Contents 1. Monoidal adjunctions 2. Accessors and builders 3. Left adjoints are strongly monoidal 3.1. Preservation of the unit 3.2. Preservation of the tensor 4. If the left adjoint is strong, then the adjunction is monoidal 5. Symmetric monoidal adjunctions 6. Accessors 7. Symmetric monoidal adjunctions from strong functors 8. Symmetric monoidal adjunctions to comonads ********************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. (** 1. Monoidal adjunctions *) Definition monoidal_adjunction {C₁ C₂ : category} (M₁ : monoidal C₁) (M₂ : monoidal C₂) (A : adjunction C₁ C₂) (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A) (ε := adjcounit A) : UU := ∑ (HL : fmonoidal_lax M₁ M₂ L), ∑ (HR : fmonoidal_lax M₂ M₁ R), is_mon_nat_trans (identity_fmonoidal _) (comp_fmonoidal_lax HL HR) η × is_mon_nat_trans (comp_fmonoidal_lax HR HL) (identity_fmonoidal _) ε. (** 2. Accessors and builders *) Definition make_monoidal_adjunction {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {A : adjunction C₁ C₂} (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A) (ε := adjcounit A) (HL : fmonoidal_lax M₁ M₂ L) (HR : fmonoidal_lax M₂ M₁ R) (Hη : is_mon_nat_trans (identity_fmonoidal _) (comp_fmonoidal_lax HL HR) η) (Hε : is_mon_nat_trans (comp_fmonoidal_lax HR HL) (identity_fmonoidal _) ε) : monoidal_adjunction M₁ M₂ A := HL ,, HR ,, Hη ,, Hε. Section MonoidalAdjunctionAccessors. Context {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {A : adjunction C₁ C₂} (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A) (ε := adjcounit A) (HA : monoidal_adjunction M₁ M₂ A). Definition fmonoidal_lax_left_adjoint : fmonoidal_lax M₁ M₂ L := pr1 HA. Definition fmonoidal_lax_right_adjoint : fmonoidal_lax M₂ M₁ R := pr12 HA. Proposition monoidal_adjunit : is_mon_nat_trans (identity_fmonoidal _) (comp_fmonoidal_lax fmonoidal_lax_left_adjoint fmonoidal_lax_right_adjoint) η. Proof. exact (pr122 HA). Qed. Proposition monoidal_adjcounit : is_mon_nat_trans (comp_fmonoidal_lax fmonoidal_lax_right_adjoint fmonoidal_lax_left_adjoint) (identity_fmonoidal _) ε. Proof. exact (pr222 HA). Qed. End MonoidalAdjunctionAccessors. (** 3. Left adjoints are strongly monoidal *) Section LeftAdjointStrong. Context {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {A : adjunction C₁ C₂} (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A : functor_identity _ ⟹ L ∙ R) (ε := adjcounit A : R ∙ L ⟹ functor_identity _) (HA : monoidal_adjunction M₁ M₂ A) (HL := fmonoidal_lax_left_adjoint HA) (HR := fmonoidal_lax_right_adjoint HA) (Hη := monoidal_adjunit HA) (Hε := monoidal_adjcounit HA). (** 3.1. Preservation of the unit *) Definition is_strong_left_adjoint_on_unit : L (monoidal_unit M₁) --> monoidal_unit M₂ := #L (fmonoidal_preservesunit HR) · ε _. Proposition is_strong_left_adjoint_on_unit_laws : is_inverse_in_precat (fmonoidal_preservesunit HL) is_strong_left_adjoint_on_unit. Proof. split ; unfold is_strong_left_adjoint_on_unit. - rewrite !assoc. exact (pr2 Hε). - rewrite !assoc'. etrans. { apply maponpaths. refine (!_). exact (nat_trans_ax ε _ _ (fmonoidal_preservesunit HL)). } cbn -[L R]. rewrite !assoc. rewrite <- functor_comp. refine (_ @ triangle_1_statement_from_adjunction A (monoidal_unit M₁)). apply maponpaths_2. apply maponpaths. refine (!(pr2 Hη) @ _). apply id_left. Qed. (** 3.2. Preservation of the tensor *) Section PreservesTensor. Context (x y : C₁). Definition is_strong_left_adjoint_on_tensor : L (x ⊗_{M₁} y) --> L x ⊗_{M₂} L y := #L((η x ⊗^{M₁} η y) · fmonoidal_preservestensordata HR (L x) (L y)) · ε _. Proposition is_strong_left_adjoint_on_tensor_laws : is_inverse_in_precat (fmonoidal_preservestensordata HL x y) is_strong_left_adjoint_on_tensor. Proof. assert (η (x ⊗_{M₁} y) = (η x ⊗^{M₁} η y) · fmonoidal_preservestensordata HR (L x) (L y) · #R (fmonoidal_preservestensordata HL x y)) as pη. { refine (!(id_left _) @ pr1 Hη x y @ _). rewrite !assoc'. apply idpath. } assert (fmonoidal_preservestensordata HL (R(L x)) (R(L y)) · #L (fmonoidal_preservestensordata HR (L x) (L y)) · ε (L x ⊗_{M₂} L y) = ε (L x) ⊗^{M₂} ε (L y)) as pε. { refine (pr1 Hε (L x) (L y) @ _). apply id_right. } split ; unfold is_strong_left_adjoint_on_tensor. - rewrite functor_comp. rewrite !assoc. etrans. { do 2 apply maponpaths_2. unfold functoronmorphisms1. cbn -[L R]. rewrite functor_comp. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply fmonoidal_preservestensornatright. } rewrite !assoc'. apply maponpaths. refine (!_). apply fmonoidal_preservestensornatleft. } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. exact pε. } rewrite !assoc. etrans. { refine (!_). apply bifunctor_distributes_over_comp ; apply M₂. } etrans. { apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). } etrans. { apply maponpaths. apply (triangle_1_statement_from_adjunction A). } apply bifunctor_distributes_over_id ; apply M₂. - rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } cbn -[L R]. rewrite !assoc. rewrite <- functor_comp. etrans. { apply maponpaths_2. apply maponpaths. exact (!pη). } apply (triangle_1_statement_from_adjunction A). Qed. End PreservesTensor. Definition is_strong_left_adjoint : fmonoidal M₁ M₂ L. Proof. refine (HL ,, _). split. - intros x y. use make_is_z_isomorphism. + exact (is_strong_left_adjoint_on_tensor x y). + exact (is_strong_left_adjoint_on_tensor_laws x y). - use make_is_z_isomorphism. + exact is_strong_left_adjoint_on_unit. + exact is_strong_left_adjoint_on_unit_laws. Defined. End LeftAdjointStrong. (** 4. If the left adjoint is strong, then the adjunction is monoidal *) Section MonoidalAdjunctionFromStrong. Context {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {A : adjunction C₁ C₂} (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A : functor_identity _ ⟹ L ∙ R) (ε := adjcounit A : R ∙ L ⟹ functor_identity _) (HL : fmonoidal M₁ M₂ L). Definition right_adjoint_monoidal_data_from_strong : fmonoidal_data M₂ M₁ R. Proof. simple refine (_ ,, _). - intros x y. exact (η _ · #R (inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly HL (R x) (R y)) · (ε x ⊗^{M₂} ε y))). - exact (η _ · #R (inv_from_z_iso (_ ,, fmonoidal_preservesunitstrongly HL))). Defined. Proposition right_adjoint_monoidal_from_strong_laws : fmonoidal_laxlaws right_adjoint_monoidal_data_from_strong. Proof. repeat split. - intros x y₁ y₂ g ; cbn -[L R]. etrans. { rewrite !assoc. apply maponpaths_2. exact (nat_trans_ax η _ _ (R x ⊗^{M₁}_{l} # R g)). } rewrite !assoc'. cbn -[L R]. rewrite <- !(functor_comp R). do 2 apply maponpaths. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. refine (!_). exact (when_bifunctor_becomes_leftwhiskering M₂ x g). } etrans. { refine (!_). apply bifunctor_distributes_over_comp ; apply M₂. } etrans. { apply maponpaths. refine (!_). exact (nat_trans_ax ε _ _ _). } rewrite id_right. etrans. { apply maponpaths_2. exact (!(id_left (ε x))). } etrans. { apply bifunctor_distributes_over_comp ; apply M₂. } cbn -[L R]. apply maponpaths_2. exact (when_bifunctor_becomes_leftwhiskering M₂ _ _). } rewrite !assoc. apply maponpaths_2. use z_iso_inv_on_right ; cbn -[L R]. rewrite !assoc. use z_iso_inv_on_left ; cbn -[L R]. refine (!_). apply fmonoidal_preservestensornatleft. - intros x₁ x₂ y f ; cbn -[L R]. etrans. { rewrite !assoc. apply maponpaths_2. exact (nat_trans_ax η _ _ (# R f ⊗^{M₁}_{r} R y)). } rewrite !assoc'. cbn -[L R]. rewrite <- !(functor_comp R). do 2 apply maponpaths. refine (!_). etrans. { rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. refine (!_). exact (when_bifunctor_becomes_rightwhiskering M₂ y f). } etrans. { refine (!_). apply bifunctor_distributes_over_comp ; apply M₂. } etrans. { apply maponpaths_2. refine (!_). exact (nat_trans_ax ε _ _ _). } rewrite id_right. etrans. { apply maponpaths. exact (!(id_left (ε y))). } etrans. { apply bifunctor_distributes_over_comp ; apply M₂. } cbn -[L R]. apply maponpaths_2. exact (when_bifunctor_becomes_rightwhiskering M₂ _ _). } rewrite !assoc. apply maponpaths_2. use z_iso_inv_on_right ; cbn -[L R]. rewrite !assoc. use z_iso_inv_on_left ; cbn -[L R]. refine (!_). apply fmonoidal_preservestensornatright. - intros x y z ; cbn -[L R]. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply (nat_trans_ax η _ _ (_ ⊗^{ M₁}_{r} _)). } refine (!_). etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ (_ · (_ ⊗^{ M₁}_{l} _))). } rewrite !assoc'. apply maponpaths. cbn -[L R]. rewrite <- !functor_comp. apply maponpaths. rewrite !assoc'. rewrite !functor_comp. etrans. { do 2 apply maponpaths_2. apply (strong_fmonoidal_preserves_associativity HL). } rewrite !assoc'. etrans. { do 4 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. refine (!_). apply (fmonoidal_preservestensornatleft HL). } rewrite !assoc'. etrans. { do 5 apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, _)). } apply id_left. } etrans. { rewrite !functor_comp. do 4 apply maponpaths. etrans. { apply maponpaths. unfold functoronmorphisms1. rewrite whiskerscommutes ; [ | apply M₂ ]. apply idpath. } rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply (bifunctor_leftcomp M₂). } apply maponpaths. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- !functor_comp. apply (nat_trans_ax ε). } cbn -[L R]. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). } apply id_left. } etrans. { do 3 apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply (bifunctor_leftcomp M₂). } apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, _)). } apply id_left. } use z_iso_inv_on_right ; cbn -[L R]. refine (!_). etrans. { rewrite !assoc. do 3 apply maponpaths_2. refine (!_). apply (fmonoidal_preservestensornatright HL). } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, _)). } apply id_left. } etrans. { rewrite !assoc. apply maponpaths_2. refine (assoc _ _ _ @ _). apply maponpaths_2. etrans. { refine (!_). apply (bifunctor_rightcomp M₂). } apply maponpaths. rewrite !(functor_comp L). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- !functor_comp. apply (nat_trans_ax ε). } cbn -[L R]. rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). } apply id_left. } etrans. { do 2 apply maponpaths_2. apply (bifunctor_rightcomp M₂). } rewrite !assoc'. apply maponpaths. unfold functoronmorphisms1. refine (!_). etrans. { rewrite !assoc. apply maponpaths_2. etrans. { apply maponpaths. apply (bifunctor_leftcomp M₂). } rewrite !assoc. apply maponpaths_2. apply monoidal_associatornatleftright. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply monoidal_associatornatleft. } rewrite !assoc'. apply maponpaths. apply monoidal_associatornatright. } rewrite !assoc. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. apply (bifunctor_rightcomp M₂). } rewrite whiskerscommutes ; [ | apply M₂ ]. rewrite !assoc'. rewrite whiskerscommutes ; [ | apply M₂ ]. rewrite !assoc. rewrite whiskerscommutes ; [ | apply M₂ ]. rewrite !assoc'. apply maponpaths. etrans. { refine (!_). apply (bifunctor_rightcomp M₂). } refine (!_). etrans. { refine (!_). apply (bifunctor_rightcomp M₂). } apply maponpaths. rewrite <- whiskerscommutes ; [ | apply M₂ ]. apply idpath. - intros x ; cbn -[L R]. assert (# L lu^{M₁}_{R x} = inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly HL _ _) · (inv_from_z_iso (_ ,, fmonoidal_preservesunitstrongly HL) ⊗^{ M₂}_{r} L (R x)) · lu^{M₂}_{L(R x)}) as q. { pose (fmonoidal_preservesleftunitality HL (R x)) as p. cbn -[L R] in p. rewrite <- p. rewrite !assoc. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. rewrite !assoc'. apply maponpaths. refine (!(bifunctor_rightcomp M₂ _ _ _ _ _ _) @ _). etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (_ ,, _)). } apply bifunctor_rightid. } rewrite id_right. apply (z_iso_after_z_iso_inv (_ ,, _)). } refine (_ @ id_right _). rewrite <- (triangle_2_statement_from_adjunction A). rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. exact (nat_trans_ax η _ _ (lu^{M₁}_{R x})). } refine (!_). rewrite !assoc'. etrans. { rewrite !assoc. do 2 apply maponpaths_2. exact (nat_trans_ax η _ _ ((η I_{ M₁} · # R _) ⊗^{ M₁}_{r} R x)). } rewrite !assoc'. apply maponpaths. cbn -[L R]. rewrite <- !functor_comp. apply maponpaths. rewrite q. rewrite !assoc'. etrans. { do 2 apply maponpaths. unfold functoronmorphisms1. rewrite !assoc'. apply maponpaths. apply monoidal_leftunitornat. } rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. refine (!_). use z_iso_inv_on_right ; cbn -[L R]. refine (!_). rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply fmonoidal_preservestensornatright. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, _)). } rewrite id_left. etrans. { refine (!_). apply (bifunctor_rightcomp M₂). } apply maponpaths. rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. apply (nat_trans_ax ε). } rewrite !assoc. refine (_ @ id_left _). cbn -[L R]. apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). - intros x ; cbn -[L R]. assert (# L ru^{M₁}_{R x} = inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly HL _ _) · (L (R x) ⊗^{M₂}_{l} inv_from_z_iso (_ ,, fmonoidal_preservesunitstrongly HL)) · ru^{M₂}_{L(R x)}) as q. { pose (fmonoidal_preservesrightunitality HL (R x)) as p. cbn -[L R] in p. rewrite <- p. rewrite !assoc. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. rewrite !assoc'. apply maponpaths. refine (!(bifunctor_leftcomp M₂ _ _ _ _ _ _) @ _). etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (_ ,, _)). } apply bifunctor_leftid. } rewrite id_right. apply (z_iso_after_z_iso_inv (_ ,, _)). } refine (_ @ id_right _). rewrite <- (triangle_2_statement_from_adjunction A). rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. exact (nat_trans_ax η _ _ (ru^{M₁}_{R x})). } refine (!_). rewrite !assoc'. etrans. { rewrite !assoc. do 2 apply maponpaths_2. exact (nat_trans_ax η _ _ (R x ⊗^{M₁}_{l} (η I_{ M₁} · # R _))). } rewrite !assoc'. apply maponpaths. cbn -[L R]. rewrite <- !functor_comp. apply maponpaths. pose (fmonoidal_preservesrightunitality HL (R x)) as p. rewrite q. rewrite !assoc'. etrans. { do 2 apply maponpaths. unfold functoronmorphisms1. rewrite (whiskerscommutes M₂) ; [ | apply M₂ ]. rewrite !assoc'. apply maponpaths. apply monoidal_rightunitornat. } rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. refine (!_). use z_iso_inv_on_right ; cbn -[L R]. refine (!_). rewrite !assoc. etrans. { do 2 apply maponpaths_2. refine (!_). apply fmonoidal_preservestensornatleft. } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, _)). } rewrite id_left. etrans. { refine (!_). apply (bifunctor_leftcomp M₂). } apply maponpaths. rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. apply (nat_trans_ax ε). } rewrite !assoc. refine (_ @ id_left _). cbn -[L R]. apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). Qed. Definition right_adjoint_monoidal_from_strong : fmonoidal_lax M₂ M₁ R := right_adjoint_monoidal_data_from_strong ,, right_adjoint_monoidal_from_strong_laws. Proposition monoidal_adjunction_from_strong_unit : is_mon_nat_trans (identity_fmonoidal M₁) (comp_fmonoidal_lax HL right_adjoint_monoidal_from_strong) η. Proof. split. - intros x y ; cbn -[L R]. rewrite id_left. rewrite !assoc'. rewrite <- (functor_comp R). refine (!_). rewrite !assoc. etrans. { apply maponpaths_2. exact (nat_trans_ax η _ _ (adjunit A x ⊗^{M₁} adjunit A y)). } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. cbn -[L R]. rewrite <- functor_comp. rewrite <- functor_id. apply maponpaths. rewrite !assoc. refine (_ @ z_iso_after_z_iso_inv (_ ,, fmonoidal_preservestensorstrongly HL _ _)). apply maponpaths_2. refine (!_ @ id_right _). use z_iso_inv_on_right ; cbn -[L R]. refine (!_). rewrite !assoc. etrans. { do 2 apply maponpaths_2. unfold functoronmorphisms1. rewrite functor_comp. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (fmonoidal_preservestensornatright HL). } rewrite !assoc'. apply maponpaths. refine (!_). apply (fmonoidal_preservestensornatleft HL). } rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservestensorstrongly HL _ _)). } rewrite id_left. rewrite !assoc. etrans. { refine (!_). apply bifunctor_distributes_over_comp ; apply M₂. } refine (!_). etrans. { refine (!_). apply bifunctor_distributes_over_id ; apply M₂. } refine (!_). etrans. { apply maponpaths. apply (triangle_1_statement_from_adjunction A). } apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). - unfold is_mon_nat_trans_unitlaw ; cbn -[L R]. rewrite id_left. rewrite !assoc'. refine (!(id_right _) @ _). apply maponpaths. rewrite <- functor_comp. rewrite <- functor_id. apply maponpaths. refine (!_). apply z_iso_after_z_iso_inv. Qed. Proposition monoidal_adjunction_from_strong_counit : is_mon_nat_trans (comp_fmonoidal_lax right_adjoint_monoidal_from_strong HL) (identity_fmonoidal M₂) ε. Proof. split. - intros x y ; cbn -[L R]. rewrite id_right. rewrite !(functor_comp R). rewrite !(functor_comp L). rewrite !assoc'. etrans. { do 3 apply maponpaths. apply (nat_trans_ax ε). } cbn -[L R]. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { do 2 apply maponpaths. apply (nat_trans_ax ε). } cbn -[L R]. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). } rewrite id_left. apply (z_iso_inv_after_z_iso (_ ,, _)). - unfold is_mon_nat_trans_unitlaw ; cbn -[L R]. rewrite functor_comp. rewrite !assoc'. etrans. { do 2 apply maponpaths. apply (nat_trans_ax ε). } cbn -[L R]. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (triangle_1_statement_from_adjunction A). } rewrite id_left. exact (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservesunitstrongly HL)). Qed. Definition monoidal_adjunction_from_strong : monoidal_adjunction M₁ M₂ A. Proof. use make_monoidal_adjunction. - exact HL. - exact right_adjoint_monoidal_from_strong. - exact monoidal_adjunction_from_strong_unit. - exact monoidal_adjunction_from_strong_counit. Defined. End MonoidalAdjunctionFromStrong. (** 5. Symmetric monoidal adjunctions *) Definition is_sym_monoidal_adjunction {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} (S₁ : symmetric M₁) (S₂ : symmetric M₂) {A : adjunction C₁ C₂} (HA : monoidal_adjunction M₁ M₂ A) : UU := is_symmetric_monoidal_functor S₁ S₂ (fmonoidal_lax_left_adjoint HA) × is_symmetric_monoidal_functor S₂ S₁ (fmonoidal_lax_right_adjoint HA). Definition sym_monoidal_adjunction {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} (S₁ : symmetric M₁) (S₂ : symmetric M₂) (A : adjunction C₁ C₂) : UU := ∑ (HA : monoidal_adjunction M₁ M₂ A), is_sym_monoidal_adjunction S₁ S₂ HA. (** 6. Accessors *) Section SymMonoidalAdjunctionAccessors. Context {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {S₁ : symmetric M₁} {S₂ : symmetric M₂} {A : adjunction C₁ C₂} (L := left_adjoint A : C₁ ⟶ C₂) (R := right_adjoint A : C₂ ⟶ C₁) (η := adjunit A) (ε := adjcounit A) {HA : monoidal_adjunction M₁ M₂ A} (HAA : is_sym_monoidal_adjunction S₁ S₂ HA). Definition is_symmetric_monoidal_functor_left_adjoint : is_symmetric_monoidal_functor S₁ S₂ (fmonoidal_lax_left_adjoint HA) := pr1 HAA. Definition is_symmetric_monoidal_functor_right_adjoint : is_symmetric_monoidal_functor S₂ S₁ (fmonoidal_lax_right_adjoint HA) := pr2 HAA. End SymMonoidalAdjunctionAccessors. Coercion sym_monoidal_adjunction_to_monoidal_adjunction {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {S₁ : symmetric M₁} {S₂ : symmetric M₂} {A : adjunction C₁ C₂} (HA : sym_monoidal_adjunction S₁ S₂ A) : monoidal_adjunction M₁ M₂ A := pr1 HA. Coercion sym_monoidal_adjunction_to_is_symmetric {C₁ C₂ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {S₁ : symmetric M₁} {S₂ : symmetric M₂} {A : adjunction C₁ C₂} (HA : sym_monoidal_adjunction S₁ S₂ A) : is_sym_monoidal_adjunction S₁ S₂ HA := pr2 HA. (** 7. Symmetric monoidal adjunctions from strong functors *) Section SymMonoidalAdjunctionFromStrong. Context {V₁ V₂ : sym_monoidal_cat} {A : adjunction V₁ V₂} (L := left_adjoint A : V₁ ⟶ V₂) (R := right_adjoint A : V₂ ⟶ V₁) (η := adjunit A : functor_identity _ ⟹ L ∙ R) (ε := adjcounit A : R ∙ L ⟹ functor_identity _) (HL : fmonoidal V₁ V₂ L) (HHL : is_symmetric_monoidal_functor V₁ V₂ HL). Proposition is_sym_monoidal_adjunction_from_strong : is_sym_monoidal_adjunction V₁ V₂ (monoidal_adjunction_from_strong HL). Proof. split. - exact HHL. - intros x y ; cbn. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η). } rewrite !assoc'. apply maponpaths. cbn. rewrite <- !functor_comp. apply maponpaths. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply tensor_sym_mon_braiding. } rewrite !assoc. apply maponpaths_2. use z_iso_inv_on_right. rewrite !assoc. use z_iso_inv_on_left. cbn. refine (!_). apply HHL. Qed. Definition sym_monoidal_adjunction_from_strong : sym_monoidal_adjunction V₁ V₂ A := _ ,, is_sym_monoidal_adjunction_from_strong. End SymMonoidalAdjunctionFromStrong. (** 8. Symmetric monoidal adjunctions to comonads *) Lemma sym_monoidal_adjunction_to_sym_monoidal_cmd_comult {V₁ V₂ : sym_monoidal_cat} (A : adjunction V₁ V₂) (HA : sym_monoidal_adjunction V₁ V₂ A) : is_mon_nat_trans (comp_fmonoidal_lax (fmonoidal_lax_right_adjoint HA) (fmonoidal_lax_left_adjoint HA)) (comp_fmonoidal_lax (comp_fmonoidal_lax (fmonoidal_lax_right_adjoint HA) (fmonoidal_lax_left_adjoint HA)) (comp_fmonoidal_lax (fmonoidal_lax_right_adjoint HA) (fmonoidal_lax_left_adjoint HA))) (δ (Comonad_from_adjunction A)). Proof. cbn. pose (is_mon_nat_trans_prewhisker (fmonoidal_lax_right_adjoint HA) (is_mon_nat_trans_postwhisker (monoidal_adjunit HA) (fmonoidal_lax_left_adjoint HA))) as H. split. - intros x y. refine (_ @ pr1 H x y @ _). + cbn. rewrite functor_id. rewrite id_right. apply idpath. + cbn. rewrite !assoc'. rewrite <- !functor_comp. rewrite !assoc'. rewrite <- !functor_comp. apply idpath. - refine (_ @ pr2 H @ _). + cbn. rewrite functor_id. rewrite id_right. apply idpath. + cbn. rewrite !assoc'. rewrite <- !functor_comp. rewrite !assoc'. rewrite <- !functor_comp. apply idpath. Qed. Definition sym_monoidal_adjunction_to_sym_monoidal_cmd {V₁ V₂ : sym_monoidal_cat} (A : adjunction V₁ V₂) (HA : sym_monoidal_adjunction V₁ V₂ A) : sym_monoidal_cmd V₂. Proof. use make_symmetric_monoidal_comonad. - exact (Comonad_from_adjunction A). - exact (comp_fmonoidal_lax (fmonoidal_lax_right_adjoint HA) (fmonoidal_lax_left_adjoint HA)). - exact (is_symmetric_monoidal_comp (is_symmetric_monoidal_functor_right_adjoint HA) (is_symmetric_monoidal_functor_left_adjoint HA)). - exact (sym_monoidal_adjunction_to_sym_monoidal_cmd_comult A HA). - exact (monoidal_adjcounit HA). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/000077500000000000000000000000001451125700300260405ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/AugmentedSimplexCategory.v000066400000000000000000001333021451125700300332020ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.CategoryTheory.SimplicialSets. (* This file defines: the augmented simplex category Δ or Δ_sd, in several different ways * as a precategory, [precat_Delta] * as a category, [category_Delta] := ([precat_Delta],, [Delta_has_homsets]) * as a monoidal category, [AugmentedSimplexCategory] with tensor product [tensor_functor_ord] given by ordinal addition and unit [tensor_unit] the zero ordinal * as a strict monoidal category, [FinOrdStrict] Similarly, it defines the category of finite cardinals, [FinCard] or Δ_sdg, * as a precategory, [precat_fincard] * as a category, [category_fincard] := ([precat_fincard],, [fincard_has_homsets]) * as a monoidal category, [FinCard] with tensor product [tensor_product_card] given by ordinal addition and unit [tensor_unit] the zero ordinal * as a strict monoidal category [FinCardStrict] and the obvious forgetful functor between them, * as a functor [fget_monoton_functor] * as a lax monoidal functor [U_Mon_Lax] * as a strong monoidal functor [U_Mon_Strong] In addition the file contains some helper lemmas - - [iscontr_inequal], (n > m) ⨿ (n ≤ m) is contractible for n, m : nat - [iscontr_inequal'], (n < m) ⨿ (n ≥ m) is contractible for n, m : nat - [natlthorgeh_left_branch] and [natlthorgeh_right_branch] which allow you to pursue the left branch or the right branch of the preceding proposition if you know which is true - [fincard_hom_extensionality], maps between finite cardinals agree iff they agree pointwise - [morphism_extensionality] same but for maps between finite ordinals - [U_Faithful], which says that the forgetful functor U is faithful - [mon_iso_mon_inv] - if f : n --> m in Δ_sd and U(f) is an isomorphism, then U(f)^{-1} is monotonic - [U_reflects_isos] - if f : n--> m in Δ_sd and U(f) is an isomorphism, then so is f - computational lemmas and rules about the behavior of ordinal addition on morphisms, see for example [pr_n_m_l] and [proj_incl_r] *) Definition fincard_has_homsets (n m : nat) : isaset ((⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) := (Propositions.funspace_isaset (isasetstn m)). Proposition iscontr_inequal (n m : nat) : iscontr ((n > m) ⨿ (n ≤ m)). Proof. unfold iscontr. exists (natgthorleh n m). intro t. induction t. - unfold natgthorleh. induction (isdecrelnatgth n m). + simpl. apply maponpaths. apply (pr2 (n > m)). + contradiction. - unfold natgthorleh. induction (isdecrelnatgth n m). + simpl. assert (¬ (n > m)). { apply natlehtonegnatgth. assumption. } contradiction. + simpl. apply maponpaths. apply (pr2 (n ≤ m)). Defined. Local Proposition iscontr_inequal' (n m : nat) : iscontr ((n < m) ⨿ (n ≥ m)). Proof. change (n < m) with (m > n). change (n ≥ m) with (m ≤ n). exact (iscontr_inequal m n). Defined. Local Proposition fincard_hom_extensionality { n m : nat } { f g : (⟦ n ⟧)%stn → (⟦ m ⟧)%stn } : (∏ x : (⟦ n ⟧)%stn, (pr1 (f x)= pr1 (g x))) -> f=g. Proof. intro X. apply funextfun. intro x. apply subtypeInjectivity_prop. exact (X x). Qed. Definition ordconstr {n : nat} (k : nat) (bd : k < n) : stn n := k,,bd. Definition precat_Delta_precategory_data : precategory_data. (* This definition does differ from the one in CategoryTheory.SimplicialSets. The objects of that category are \[0\] = {0} \[1\] = {0,1} \[2\] = {0, 1, 2} and so on. I call this the "topologists' indexing" as calling the ordinal [2] reflects that it is 2-dimensional. The objects of the category in this file are 0 = \emptyset 1 = {0} 2 = {0,1} and so on, as in the definition of the von Neumann ordinals. The category in CategoryTheory.SimplicialSets does not have the unit object which is necessary for the proposed addition functor. The reindexing / renaming of the objects allows us to define the addition bifunctor sensibly, so that n + m has the obvious meaning; in the category in CategoryTheory.SimplicialSets we have the unfortunate fact that [n] \oplus [m] = [n+m+1]. *) Proof. use make_precategory_data. - exact (make_precategory_ob_mor nat monfunstn). - intros m. apply monfunstnid. (* defining identity and composition law *) - intros l m n f g. exact (monfunstncomp f g). Defined. Definition precat_Delta_is_precategory : is_precategory precat_Delta_precategory_data. Proof. unfold precat_Delta_precategory_data. unfold is_precategory. split. { split. - intros a b f. unfold "id". simpl in *. reflexivity. - intros a b f. unfold "id". simpl in *. reflexivity. } { split. - reflexivity. - reflexivity. } Qed. Definition precat_Delta : precategory := (precat_Delta_precategory_data,, precat_Delta_is_precategory). Notation "C ⊠ D" := (precategory_binproduct C D) (at level 38). Definition precat_fincard_data : precategory_data. Proof. unshelve eapply (make_precategory_data _). - unshelve eapply (make_precategory_ob_mor _ _). * exact nat. * exact (λ n, λ m, (⟦n⟧%stn → ⟦m⟧%stn)). (* Morphisms *) - intro c. exact (idfun (⟦c⟧)%stn). (* Identity *) - intros n m k f g. exact (g∘f). (* Composition law *) Defined. Proposition precat_fincard_is_precategory : is_precategory precat_fincard_data. Proof. unfold precat_Delta_precategory_data. unfold is_precategory. split. { split. - intros a b f. unfold "id". simpl in *. reflexivity. - intros a b f. unfold "id". simpl in *. reflexivity. } { split. - reflexivity. - reflexivity. } Qed. Definition precat_fincard : precategory := (precat_fincard_data,, precat_fincard_is_precategory). Proposition Delta_has_homsets : has_homsets precat_Delta. Proof. unfold has_homsets. simpl. intros a b. apply isaset_total2. - exact (fincard_has_homsets a b). - intro f. apply impred_isaset. intro x. apply impred_isaset. intro y. apply impred_isaset. intro. exact (isasetaprop (propproperty (f x ≤ f y))). Qed. Definition category_Delta : category := (precat_Delta,, Delta_has_homsets). Definition category_fincard : category := (precat_fincard,, fincard_has_homsets). (* The notational convention here is that a subscript d means "has face maps" subscript s means "has degeneracies" and subscript g means "has permutations." *) Notation Δ_sdg := category_fincard. Notation Δ := category_Delta. Notation Δ_sd := category_Delta. Definition Δ_ob_constr ( n : nat) : Δ := n. Definition Δ_sdg_ob_constr ( n : nat) : Δ_sdg := n. Open Scope cat. Definition Δ_mor_constr { n m : nat } ( f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn ) ( pk : ∏ x y : (⟦ n ⟧)%stn, x ≤ y -> f x ≤ f y) : (Δ_ob_constr n) --> (Δ_ob_constr m) := (make_monfunstn f pk). Definition Δ_sdg_mor_constr { n m : nat } ( f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn ) : Δ_sdg_ob_constr n --> Δ_sdg_ob_constr m := f. Definition fget_monoton_functor_data : functor_data category_Delta category_fincard. Proof. use tpair. { exact (idfun nat). } intros a b f. exact (pr1 f). Defined. Proposition fget_monoton_is_functor : is_functor fget_monoton_functor_data. Proof. use tpair. - unfold functor_idax. reflexivity. - unfold functor_compax. reflexivity. Qed. Definition fget_monoton_functor : functor category_Delta category_fincard := (fget_monoton_functor_data,, fget_monoton_is_functor). Local Notation U := fget_monoton_functor. Local Proposition U_faithful { a b : Δ } (f g : a --> b) : (# U f = # U g) -> f = g. Proof. apply subtypeInjectivity. unfold isPredicate. intro. apply impred_isaprop. intro. apply impred_isaprop. intro. apply impred_isaprop. intro. apply propproperty. Qed. Local Proposition morphism_extensionality { a b : Δ } (f g : a --> b) : (∏ x, (# U f) x = (# U g) x) -> f = g. Proof. intro ext_hypothesis. simpl in ext_hypothesis. apply U_faithful. simpl. apply fincard_hom_extensionality. intro x. apply maponpaths. exact (ext_hypothesis x). Qed. (* If f : n -> m is monotonic and has an inverse in fin_card, its inverse is also monotonic.*) Lemma mon_iso_mon_inv {n m : Δ} {f : n --> m} (I : is_z_isomorphism ((# U) f)) : ∏ x y : (⟦m⟧)%stn, x ≤ y -> (is_z_isomorphism_mor I) x ≤ (is_z_isomorphism_mor I) y. Proof. intros x y l. unfold is_z_isomorphism in I. simpl in I. induction I as [I_fn I_is_inverse_in_preord], f as [f_fn f_guarantee]. induction (natlehchoice x y l) as [a | a']. - induction (natgthorleh (I_fn x) (I_fn y)). + (* We will derive a contradiction by proving x ≥ y in contradiction to a *) contradiction (natlthtonegnatgeh x y a). assert (∏ z , f_fn (I_fn z) = z) as X. { intro z. change (f_fn (I_fn z)) with (compose (C:=Δ_sdg) I_fn f_fn z). simpl. set (j := (pr2 I_is_inverse_in_preord)). simpl in j. rewrite j. reflexivity. } rewrite <- (X x), <- (X y); apply f_guarantee. exact (natlthtoleh _ _ a0). + exact b. - simpl is_z_isomorphism_mor. apply subtypeInjectivity_prop in a'. induction a'. exact (isreflnatleh (I_fn x)). Qed. Lemma fincard_inv_is_inverse_in_precat (n m : Δ) (f : n --> m ) (I : is_z_isomorphism ((# U) f)): is_inverse_in_precat f (is_z_isomorphism_mor I,, mon_iso_mon_inv I). Proof. unfold is_z_isomorphism in I. simpl in I. induction I as [g is_inverse], f as [ffun fguarantee]. simpl in is_inverse. induction is_inverse as [l r]. split. - apply morphism_extensionality. simpl. intro x. change ((@compose precat_fincard _ _ _ ffun g) x = x). simpl. rewrite l. reflexivity. - apply morphism_extensionality. intro x. simpl. change (ffun (g x)) with (compose (C:=Δ_sdg) g ffun x). simpl. rewrite r. unfold "id". reflexivity. Qed. Lemma U_reflects_isos (n m : Δ) ( f : n --> m ) : (is_z_isomorphism ((# U) f)) -> (is_z_isomorphism f). Proof. intro I. use tpair. { exact (is_z_isomorphism_mor I,, mon_iso_mon_inv I). } cbv beta. exact (fincard_inv_is_inverse_in_precat n m f I). Defined. Local Proposition U_reflects_id (a : Δ) (f : a --> a) : (# U f) = id (U a) -> f = id a. Proof. intro. apply U_faithful. assumption. Qed. Local Definition ordinal_addition : (Δ ⊠ Δ) → Δ. Proof. simpl. intro nm. induction nm as [n m]. exact (n+m). Defined. Arguments ordinal_addition /. Local Definition pr_n_m_l { n m : nat} ( x : (⟦ n + m⟧)%stn ) (s : x < n) : (⟦ n ⟧)%stn. Proof. exists (stntonat _ x). exact s. Defined. Local Definition pr_n_m_r { n m : nat} ( x : (⟦ n + m⟧)%stn ) (s : x ≥ n) : (⟦ m ⟧)%stn. Proof. exists (stntonat _ x - n). apply nat_split. - exact (stnlt x). - exact s. Defined. Local Definition sumfn {n n' m m' : nat} (f : (⟦ n ⟧)%stn → (⟦ m ⟧)%stn) ( g : (⟦ n' ⟧)%stn → (⟦ m' ⟧)%stn) : (⟦ n + n' ⟧)%stn → (⟦ m + m'⟧)%stn. Proof. intro x. induction (natlthorgeh x n) as [less_n | geq_n]. - set (x' := pr_n_m_l x less_n). refine (ordconstr (n:=m+m') (stntonat _ (f x')) _). apply (natgehgthtrans _ m _). + exact (natlehnplusnm m m'). + exact (stnlt (f x')). - set (x' := pr_n_m_r x geq_n). refine (ordconstr (stntonat _ (g x')+m) _). rewrite natpluscomm. apply natlthandplusl. exact (stnlt (g x')). Defined. Local Proposition pr_n_m_l_compute { n m : nat} ( x : (⟦ n + m⟧)%stn ) (s : x < n) : stntonat _ (pr_n_m_l x s) = stntonat _ x. Proof. reflexivity. Qed. Local Proposition pr_n_m_r_compute { n m : nat} ( x : (⟦ n + m⟧)%stn ) (s : x ≥ n) : stntonat _ (pr_n_m_r x s) = (stntonat _ x) - n. Proof. reflexivity. Qed. Local Proposition proj_incl_l { n m : nat } ( x : (⟦ n + m⟧)%stn ) (s : x < n) : (stn_left n m) (pr_n_m_l x s) = x. Proof. unfold stn_left. simpl. apply subtypeInjectivity_prop. reflexivity. Qed. Local Proposition proj_incl_r { n m : nat } ( x : (⟦ n + m⟧)%stn ) (s : x ≥ n) : (stn_right n m) (pr_n_m_r x s) = x. Proof. unfold stn_right. simpl. apply subtypeInjectivity_prop. simpl. rewrite natpluscomm. exact (minusplusnmm x n s). Qed. Definition natlthorgeh_left_branch {n m : nat} (s : n < m) (j : (n < m) ⨿ (n ≥ m)) : j = inl s := (proofirrelevancecontr (iscontr_inequal m n) j (inl s)). Definition natlthorgeh_right_branch {n m : nat} (s : n ≥ m) (j : (n < m) ⨿ (n ≥ m)) : j = inr s := (proofirrelevancecontr (iscontr_inequal m n) j (inr s)). Local Proposition sumfn_l { n n' m m' : nat} (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) ( g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s : x < n) : (sumfn f g) x < m. Proof. unfold sumfn. rewrite (natlthorgeh_left_branch s _). simpl. exact (stnlt (f (pr_n_m_l x s))). Qed. Local Proposition sumfn_r { n n' m m' : nat } (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) (g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s : x ≥ n) : (sumfn f g) x ≥ m. Proof. unfold sumfn. rewrite (natlthorgeh_right_branch s _). simpl. change (g (pr_n_m_r x s) + m ≥ m). exact (natlehmplusnm _ m). Qed. Local Proposition sumfn_l1 { n n' m m' : nat} (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) ( g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s : x < n) : f (pr_n_m_l x s) = pr_n_m_l ((sumfn f g) x) (sumfn_l f g x s). Proof. apply subtypeInjectivity_prop. simpl. unfold sumfn. rewrite (natlthorgeh_left_branch s _). simpl. reflexivity. Qed. Local Proposition sumfn_r1 { n n' m m' : nat} (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) (g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s :x ≥ n) : g (pr_n_m_r x s) = pr_n_m_r ((sumfn f g) x) (sumfn_r f g x s). Proof. apply subtypeInjectivity_prop. simpl. unfold sumfn. rewrite (natlthorgeh_right_branch s _). simpl. rewrite ( plusminusnmm _ m). reflexivity. Qed. Local Proposition sumfn_l2 { n n' m m' : nat} (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) ( g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s : x < n) : (stn_left m m') (f (pr_n_m_l x s)) = (sumfn f g) x. Proof. rewrite (sumfn_l1 f g x s). exact (proj_incl_l (sumfn f g x) (sumfn_l f g x s)). Qed. Local Proposition sumfn_r2 { n n' m m' : nat} (f : (⟦ n ⟧)%stn -> (⟦ m ⟧)%stn) ( g : (⟦ n' ⟧)%stn -> (⟦ m' ⟧)%stn) (x : (⟦ n + n' ⟧)%stn) ( s : x ≥ n) : (stn_right m m') (g (pr_n_m_r x s)) = (sumfn f g) x. Proof. rewrite (sumfn_r1 f g x s). exact (proj_incl_r (sumfn f g x) (sumfn_r f g x s)). Qed. Local Proposition stn_left_monotonic ( n m : nat ) : ∏ x y : (⟦ n ⟧)%stn, (x ≤ y) -> ( stn_left n m x ) ≤ ( stn_left n m y). Proof. intros x y l. exact l. Qed. Local Proposition stn_right_monotonic ( n m : nat ) : ∏ x y : (⟦ m ⟧)%stn, (x ≤ y) -> ( stn_right n m x ) ≤ ( stn_right n m y). Proof. intros x y l. simpl. change (n + x ≤ n + y). rewrite natpluscomm. rewrite (natpluscomm n y). apply natlehandplusr. exact l. Qed. Definition monfunmonprop { n m : nat } (f : monfunstn n m) := pr2 f. Local Arguments precategory_binproduct_mor /. Local Definition ordinal_hom : ∏ a b : ob (Δ ⊠ Δ), a --> b -> (ordinal_addition a) --> (ordinal_addition b). Proof. simpl. intros nn' mm'. induction nn' as [n n'], mm' as [m m']. intro fg. simpl in fg. induction fg as [f g]. unshelve refine (make_monfunstn _ _). - exact (sumfn f g). - intros x y. induction f as [f_fun f_guarantee]. induction g as [g_fun g_guarantee]. intro l. simpl. change (sumfn f_fun g_fun x ≤ sumfn f_fun g_fun y). unfold sumfn. induction natlthorgeh as [xl | xgth], (natlthorgeh y n) as [yl | ygth]. + simpl. exact (f_guarantee (pr_n_m_l x xl) (pr_n_m_l y yl) l). + simpl. apply natlthtoleh. apply (natgehgthtrans _ m _ ). * exact (natlehmplusnm _ m). * exact (stnlt (f_fun _)). + contradiction (natgthnegleh yl). exact (istransnatleh xgth l). + simpl. change (g_fun (pr_n_m_r x xgth) + m ≤ g_fun (pr_n_m_r y ygth) +m ). apply natlehandplusr. apply g_guarantee. rewrite pr_n_m_r_compute. rewrite pr_n_m_r_compute. exact (natgehandminusr _ _ n l). Defined. Local Definition tensor_data_card : (functor_data (Δ_sdg ⊠ Δ_sdg) Δ_sdg). Proof. use functor_data_constr. + exact ordinal_addition. + intros a b pr. induction pr as [f g]. exact (sumfn f g). Defined. Local Definition tensor_data_ord : (functor_data (Δ ⊠ Δ) Δ). Proof. use functor_data_constr. + exact ordinal_addition. + exact ordinal_hom. Defined. Local Proposition tensor_id_card : (functor_idax tensor_data_card). Proof. intro a. induction a as [n m]. simpl. unfold sumfn. apply fincard_hom_extensionality. intro x. induction natlthorgeh. - simpl. unfold "id". reflexivity. - simpl. unfold "id". simpl. exact (minusplusnmm x n b). Qed. Local Proposition tensor_id_ord : (functor_idax tensor_data_ord). Proof. intro a. apply U_reflects_id. unfold tensor_data_ord. apply (tensor_id_card). Qed. Local Proposition tensor_comp_card : (functor_compax tensor_data_card). Proof. unfold functor_compax. unfold tensor_data_card. simpl. intros a b c f g. induction a as [a0 a1], b as [b0 b1], c as [c0 c1]. simpl in f, g. induction f as [f0 f1], g as [g0 g1]. apply fincard_hom_extensionality. simpl. intro x. unfold "·". simpl. unfold sumfn. induction natlthorgeh. - rewrite (natlthorgeh_left_branch (stnlt (f0 (ordconstr x a) )) _). simpl in *. apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. reflexivity. - rewrite (natlthorgeh_right_branch (natgehplusnmm _ b0) _). simpl in *. apply (maponpaths (λ k : nat, k+c0)). apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. simpl. exact (pathsinv0 (plusminusnmm _ b0)). Qed. Local Proposition tensor_comp_ord : (functor_compax tensor_data_ord). Proof. unfold functor_compax, tensor_data_ord. intros a b c f g. induction f as [f0 f1], g as [g0 g1]. set (Uf := make_dirprod (# U f0) (# U f1)). set (Ug := make_dirprod (# U g0) (# U g1)). apply U_faithful. exact (tensor_comp_card a b c Uf Ug). Qed. Local Proposition tensor_card_is_functor : is_functor tensor_data_card. Proof. split. exact tensor_id_card. exact tensor_comp_card. Qed. Local Proposition tensor_ord_is_functor : is_functor tensor_data_ord. Proof. split. exact tensor_id_ord. exact tensor_comp_ord. Qed. Local Definition tensor_functor_card : functor (Δ_sdg ⊠ Δ_sdg) Δ_sdg. Proof. use make_functor. + exact tensor_data_card. + exact tensor_card_is_functor. Defined. Local Definition tensor_functor_ord : functor (Δ ⊠ Δ) Δ. Proof. use make_functor. + exact tensor_data_ord. + exact tensor_ord_is_functor. Defined. Local Definition tensor_unit : Δ :=0. Arguments tensor_unit /. Local Definition tensor_left_unitor_card : left_unitor tensor_functor_card tensor_unit. Proof. unfold left_unitor, I_pretensor, functor_fix_fst_arg,functor_identity,nat_z_iso. (* We construct the natural transformation. *) use tpair. - unfold "⟹". use tpair. + unfold nat_trans_data. intro x. exact (id x). + abstract (cbv beta; unfold is_nat_trans; intros n m f; apply fincard_hom_extensionality; simpl; unfold functor_fix_fst_arg_ob, tensor_functor_card; simpl; intro x; simpl; rewrite natplusr0; apply maponpaths, maponpaths, subtypeInjectivity_prop; simpl; exact (natminuseqn x)). - cbv beta. (* We prove that it's an isomorphism. *) unfold is_nat_z_iso, is_z_isomorphism, is_inverse_in_precat. intro c. exists (id c). abstract ( split; unfold tensor_functor_card, functor_fix_fst_arg_ob, tensor_data_card; simpl; exact (id_left (id c)); exact (id_left (id c))). Defined. Local Definition tensor_left_unitor_ord : left_unitor tensor_functor_ord tensor_unit. Proof. unfold left_unitor, I_pretensor, functor_fix_fst_arg,functor_identity,nat_z_iso. (* We construct the natural transformation. *) use tpair. - unfold "⟹". use tpair. + unfold nat_trans_data. intro n. exact (id n). + abstract (cbv beta; unfold is_nat_trans; intros n m f; apply morphism_extensionality; unfold tensor_functor_ord; simpl; unfold functor_fix_fst_arg_ob, sumfn; simpl; intro x; apply subtypeInjectivity_prop; simpl; rewrite natplusr0; apply maponpaths, maponpaths, subtypeInjectivity_prop; simpl; exact (natminuseqn x)). - cbv beta; (* We prove that it's an isomorphism. *) unfold is_nat_z_iso; intro c; unfold is_z_isomorphism. exists (id c). abstract (simpl; unfold is_inverse_in_precat; split; unfold tensor_functor_ord, functor_fix_fst_arg_ob, tensor_data_ord; simpl; exact (id_left (id c))). Defined. Local Definition tensor_right_unitor_card_nt_data : nat_trans_data (I_posttensor tensor_functor_card tensor_unit) (functor_identity Δ_sdg). Proof. simpl. unfold "⟹". unfold nat_trans_data. simpl. intro x. unfold functor_fix_snd_arg_ob, tensor_functor_card, tensor_unit. simpl. rewrite natplusr0. exact (idfun _). Defined. Local Definition tensor_right_unitor_card_is_nat_trans : is_nat_trans (I_posttensor tensor_functor_card tensor_unit) (functor_identity Δ_sdg) tensor_right_unitor_card_nt_data. Proof. unfold is_nat_trans, tensor_right_unitor_card_nt_data. simpl. intros n m f. unfold functor_fix_snd_arg_mor; simpl. apply fincard_hom_extensionality; unfold functor_fix_snd_arg_ob; simpl. intro x. unfold "·"; simpl. unfold sumfn. assert (x < n) as j. { simpl; induction (natplusr0 n); exact (stnlt x). } rewrite (natlthorgeh_left_branch j _). simpl. generalize (natgehgthtrans (m+0) m), (! natplusr0 m). intros h p. intermediate_path (pr1 (f (ordconstr x j))). - induction (natplusr0 m). reflexivity. - apply maponpaths, maponpaths, subtypeInjectivity_prop; simpl; induction (natplusr0 n); reflexivity. Qed. Local Definition tensor_right_unitor_card : right_unitor tensor_functor_card tensor_unit. Proof. use tpair. { exact (tensor_right_unitor_card_nt_data,,tensor_right_unitor_card_is_nat_trans). } cbv beta. unfold is_nat_z_iso, is_z_isomorphism. simpl. intro c. use tpair. + simpl. unfold functor_fix_snd_arg_ob, tensor_functor_card. simpl. rewrite natplusr0. exact (idfun _). + abstract(cbv beta; unfold is_inverse_in_precat, tensor_right_unitor_card_nt_data; split; induction (natplusr0 c); unfold functor_fix_snd_arg_ob, tensor_functor_card; simpl; exact (id_left (id Δ_sdg_ob_constr (c + 0))); induction (natplusr0 c); simpl; exact (id_left (id Δ_sdg_ob_constr (c + 0)))). Defined. Local Definition tensor_right_unitor_ord_nt_data : nat_trans_data (I_posttensor tensor_functor_ord tensor_unit) (functor_identity Δ_sd). Proof. unfold nat_trans_data. intro n. use make_monfunstn. * simpl. unfold functor_fix_snd_arg_ob, tensor_functor_ord. simpl. rewrite natplusr0. exact (idfun _). * cbv beta. intros x y leq. induction (natplusr0 n). exact leq. Defined. Arguments tensor_right_unitor_ord_nt_data /. Local Definition tensor_right_unitor_ord_is_nat_trans : is_nat_trans (I_posttensor tensor_functor_ord tensor_unit) (functor_identity Δ_sd) tensor_right_unitor_ord_nt_data. Proof. unfold is_nat_trans. intros n m f. apply U_faithful. rewrite (functor_comp U). simpl. unfold "·". simpl. apply fincard_hom_extensionality. unfold functor_fix_snd_arg_ob, tensor_functor_ord. simpl. induction (natplusr0 m). simpl. intro x. unfold sumfn. assert (x < n) as xbd. { simpl in *. induction (pathsinv0 (natplusr0 n)). exact (stnlt x). } rewrite (natlthorgeh_left_branch xbd _). simpl. apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. induction (natplusr0 n). simpl. reflexivity. Qed. Local Proposition tensor_right_unitor_ord : right_unitor tensor_functor_ord tensor_unit. Proof. unfold right_unitor. use tpair. { exact (tensor_right_unitor_ord_nt_data,,tensor_right_unitor_ord_is_nat_trans). } cbv beta. unfold is_nat_z_iso. simpl. intro c. unfold is_z_isomorphism. use tpair. { simpl. unfold functor_fix_snd_arg_ob. simpl. rewrite natplusr0. exact (monfunstnid c). } { abstract(cbv beta; unfold tensor_right_unitor_ord_nt_data; split; unfold functor_fix_snd_arg_ob; simpl; induction (natplusr0 c); simpl; reflexivity; induction (natplusr0 c); reflexivity). } Defined. Definition tensor_associator_card_nat_trans_data : nat_trans_data (assoc_left tensor_functor_card) (assoc_right tensor_functor_card). Proof. unfold nat_trans_data. simpl. induction x as [nm k], nm as [n m]. simpl. rewrite natplusassoc. exact (idfun _). Defined. Arguments tensor_associator_card_nat_trans_data /. Definition tensor_associator_card_is_nat_trans : is_nat_trans _ _ tensor_associator_card_nat_trans_data. Proof. unfold is_nat_trans. simpl. induction x as [nm k], nm as [n m], x' as [n'm' k'], n'm' as [n' m']. simpl. induction f as [fg h], fg as [f g]. unfold "·". simpl. apply fincard_hom_extensionality. simpl. induction x as [xval xbd]. simpl. induction (natplusassoc n' m' k'). simpl. (* We go by cases depending on the value of x *) unfold sumfn. simpl. set (QQ := internal_paths_rew_r nat (n + m + k ) (n + (m + k )) _ _ _). assert (xval < n + (m + k)) as xbd'. { rewrite (pathsinv0 (natplusassoc n m k)). exact xbd. } assert ((QQ (xval,, xbd)) = (xval,, xbd')) as j. { apply subtypeInjectivity_prop. induction (natplusassoc n m k). reflexivity. } simpl in j. rewrite j. induction (natlthorgeh _ _) as [INDXLN | INDXGTN]. + simpl. assert (xval < (n + m)) as leq by exact (natgehgthtrans _ n _ (natlehnplusnm n m) INDXLN). rewrite (natlthorgeh_left_branch leq _). simpl. reflexivity. + simpl. induction (natlthorgeh _ _) as [XNLM | XNGTM]. * simpl. assert ((xval - n) < m) as SS by exact (nat_split XNLM INDXGTN). rewrite (natlthorgeh_left_branch SS _). simpl. apply (maponpaths (λ k, k + n')), maponpaths, maponpaths, subtypeInjectivity_prop. reflexivity. * simpl. assert (xval - n ≥ m) as SS. { rewrite (pathsinv0 (plusminusnmm m n)). apply natgehandminusr. rewrite natpluscomm. exact XNGTM. } rewrite (natlthorgeh_right_branch SS _). simpl. rewrite natplusassoc, (natpluscomm n' m'). apply (maponpaths (λ k, k + (m' + n'))), maponpaths, maponpaths, subtypeInjectivity_prop. simpl. rewrite natminusminus. reflexivity. Qed. Definition tensor_associator_card_nat_trans : nat_trans (assoc_left tensor_functor_card) (assoc_right tensor_functor_card) := (tensor_associator_card_nat_trans_data,,tensor_associator_card_is_nat_trans). Definition tensor_associator_ord_nat_trans_data : nat_trans_data (assoc_left tensor_functor_ord) (assoc_right tensor_functor_ord). Proof. unfold nat_trans_data. intro x. induction x as [nm k], nm as [n m]. unfold tensor_functor_ord. simpl. rewrite natplusassoc. exact (monfunstnid _). Defined. Arguments tensor_associator_ord_nat_trans_data /. Definition tensor_associator_ord_is_nat_trans : is_nat_trans _ _ tensor_associator_ord_nat_trans_data. Proof. cbv beta. unfold is_nat_trans, tensor_associator_ord_nat_trans_data. simpl. intros nmk n'm'k' fgh. induction nmk as [nm k], nm as [n m]. induction n'm'k' as [n'm' k'], n'm' as [n' m']. induction fgh as [fg h], fg as [f g]. simpl in *. apply U_faithful. unfold U. simpl. apply fincard_hom_extensionality. intro x. simpl. induction (natplusassoc n' m' k'). simpl. unfold sumfn. simpl. set (QQ := internal_paths_rew_r nat (n + m + k ) (n + (m + k )) _ _ _). simpl in QQ. assert (x < n + (m + k)) as xbd'. { rewrite (pathsinv0 (natplusassoc n m k)). exact (stnlt x). } set (x' := ordconstr (stntonat _ x) xbd'). assert (QQ x =x') as RW. { apply subtypeInjectivity_prop. induction (natplusassoc n m k). reflexivity. } rewrite RW. simpl. induction (natlthorgeh x n). + simpl. assert (x < (n + m)) as l. { apply (natgehgthtrans _ n _ ). * rewrite natpluscomm. exact (natlehmplusnm m n). * exact a. } rewrite (natlthorgeh_left_branch l _). simpl. apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. reflexivity. + simpl. induction x as [xval xbd]. simpl. induction (natlthorgeh (xval - n) m). * simpl. assert ( xval < n + m) as l. { rewrite (pathsinv0 (minusplusnmm xval n b)). rewrite (natpluscomm n m). exact (natlthandplusr _ _ n a). } simpl. rewrite (natlthorgeh_left_branch l _). simpl. apply (maponpaths (λ k, k + n')). apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. reflexivity. * simpl. assert (xval ≥ n + m) as geq. { rewrite (pathsinv0 (minusplusnmm xval n b)). rewrite (natpluscomm n m). exact (natlehandplusr _ _ _ b0). } rewrite (natlthorgeh_right_branch geq _). simpl. rewrite (natpluscomm n' m'). rewrite natplusassoc. apply (maponpaths (λ k, k + (m'+n'))). apply maponpaths. apply maponpaths. apply subtypeInjectivity_prop. simpl. exact (pathsinv0 (natminusminus _ _ _)). Qed. Definition tensor_associator_ord_nat_trans : nat_trans (assoc_left tensor_functor_ord) (assoc_right tensor_functor_ord):= (tensor_associator_ord_nat_trans_data,, tensor_associator_ord_is_nat_trans). Definition tensor_associator_card : associator tensor_functor_card. Proof. unfold associator, nat_z_iso, is_nat_z_iso. exists tensor_associator_card_nat_trans. induction c as [nm k], nm as [n m]. unfold is_z_isomorphism. use tpair. - simpl. rewrite natplusassoc. exact (monfunstnid _). - abstract(cbv beta; unfold is_inverse_in_precat; split; simpl; unfold tensor_associator_card_nat_trans_data; simpl; induction (natplusassoc n m k); simpl; apply fincard_hom_extensionality; reflexivity; simpl; unfold tensor_associator_card_nat_trans_data; induction (pathsinv0 (natplusassoc n m k)); simpl; induction (natplusassoc n m k); simpl; apply fincard_hom_extensionality; reflexivity). Defined. Definition tensor_associator_ord : associator tensor_functor_ord. unfold associator, nat_z_iso. exists tensor_associator_ord_nat_trans. unfold is_nat_z_iso. intro c. induction c as [nm k]. induction nm as [n m]. unfold is_z_isomorphism. use tpair. { (* We construct the inverse. *) simpl. rewrite natplusassoc. exact (monfunstnid _). } (* We prove that it is an inverse. *) { abstract(cbv beta; unfold is_inverse_in_precat, tensor_associator_ord_nat_trans, tensor_associator_ord_nat_trans_data; split; simpl; induction (natplusassoc n m k); simpl; apply morphism_extensionality; reflexivity; simpl; induction (pathsinv0 (natplusassoc n m k)); simpl; induction (natplusassoc n m k); simpl; apply morphism_extensionality; reflexivity). } Defined. Proposition triangle_eq_holds_card : triangle_eq tensor_functor_card tensor_unit tensor_left_unitor_card tensor_right_unitor_card tensor_associator_card. Proof. unfold triangle_eq. simpl. intros a b. apply fincard_hom_extensionality. unfold tensor_functor_card, functor_fix_snd_arg_ob, tensor_right_unitor_card_nt_data, tensor_associator_card_nat_trans_data. simpl. intro x. induction x as [xval xbd]. unfold sumfn. simpl. set (QJ := internal_paths_rew_r nat (a + 0 + b) _ _ _ _ ). simpl in QJ. assert (xval < a + b) as XLAB'. { rewrite (pathsinv0 (natplusr0 a)). exact xbd. } set (x' := ordconstr xval XLAB'). unfold "·". simpl. assert ((QJ (xval,, xbd)) = x') as RW. { apply subtypeInjectivity_prop. simpl in *. unfold QJ. generalize (natplusassoc a 0 b). simpl. generalize (a + b). induction p. reflexivity. } simpl in *. rewrite RW. induction (natlthorgeh xval _) as [XLA | XGA]. - simpl. assert (xval < a) as XLA'. { rewrite (natplusr0 a) in XLA. exact XLA. } rewrite (natlthorgeh_left_branch XLA' _). simpl in *. induction (natplusr0 a). reflexivity. - simpl. assert (xval ≥ a) as XGA'. { rewrite (natplusr0 a) in XGA. exact XGA. } rewrite (natlthorgeh_right_branch XGA' _). simpl in *. rewrite (natplusr0 a). reflexivity. Qed. Proposition triangle_eq_holds_ord : triangle_eq tensor_functor_ord tensor_unit tensor_left_unitor_ord tensor_right_unitor_ord tensor_associator_ord. Proof. unfold triangle_eq. simpl. intros a b. apply morphism_extensionality. unfold tensor_functor_ord, functor_fix_snd_arg_ob. simpl. unfold tensor_associator_ord_nat_trans_data. simpl. intro x. induction x as [xval xbd]. unfold sumfn. simpl. set (QJ := internal_paths_rew_r nat (a + 0 + b) _ _ _ _ ). simpl in QJ. assert (xval < a + b) as XLAB'. { rewrite (pathsinv0 (natplusr0 a)). exact xbd. } set (x' := ordconstr xval XLAB'). unfold "·". simpl. assert ((QJ (xval,, xbd)) = x') as RW. { apply subtypeInjectivity_prop. simpl in *. unfold QJ. generalize (natplusassoc a 0 b). simpl. generalize (a + b). induction p. reflexivity. } simpl in *. rewrite RW. apply subtypeInjectivity_prop. induction (natlthorgeh xval _) as [XLA | XGA]. - simpl. assert (xval < a) as XLA'. { rewrite (natplusr0 a) in XLA. exact XLA. } rewrite (natlthorgeh_left_branch XLA' _). simpl in *. induction (natplusr0 a). reflexivity. - simpl. assert (xval ≥ a) as XGA'. { rewrite (natplusr0 a) in XGA. exact XGA. } rewrite (natlthorgeh_right_branch XGA' _). simpl in *. rewrite (natplusr0 a). reflexivity. Qed. Proposition pentagon_eq_holds_card : pentagon_eq tensor_functor_card tensor_associator_card. Proof. unfold pentagon_eq. intros. apply fincard_hom_extensionality. simpl. unfold tensor_associator_card_nat_trans_data. simpl. intro x. induction (natplusassoc b c d). simpl. induction (natplusassoc a b (c + d)). simpl. unfold "·". simpl. induction (natplusassoc (a + b) c d). simpl. unfold "id". simpl. set (k:=(tensor_id_card (make_dirprod a (b + c + d)))). unfold "id" in k. simpl in k. simpl. unfold "id" in k. simpl in k. unfold Δ_sdg_ob_constr. rewrite k. induction (natplusassoc a (b + c) d), (natplusassoc a b c). simpl. set (k':=(tensor_id_card (make_dirprod (a + b + c) d))). unfold "id" in k'. simpl in k'. unfold "id" in k'. simpl in k'. rewrite k'. reflexivity. Qed. Proposition pentagon_eq_holds_ord : pentagon_eq tensor_functor_ord tensor_associator_ord. Proof. unfold pentagon_eq. intros. apply U_faithful. rewrite (functor_comp U), (functor_comp U), (functor_comp U). apply fincard_hom_extensionality. unfold tensor_associator_ord. simpl. unfold tensor_associator_ord_nat_trans_data. simpl. intro x. induction (natplusassoc b c d), (natplusassoc a b (c + d)). unfold "·". simpl. induction (natplusassoc (a + b) c d). set (j:= (tensor_id_card (make_dirprod a (b + c + d)))). unfold tensor_data_card in j. simpl in j. unfold "id" in j. simpl in j. unfold idfun. simpl. unfold idfun in j. rewrite j. induction (natplusassoc a (b + c) d). simpl. induction (natplusassoc a b c). simpl. set (j' := (tensor_id_card (make_dirprod (a + b + c) d))). unfold tensor_data_card in j'. simpl in j'. simpl in j'. unfold "id" in j'. simpl in j'. unfold idfun in *. rewrite j'. reflexivity. Qed. Definition AugmentedSimplexCategory : monoidal_cat. Proof. use make_monoidal_cat. + exact Δ. + exact tensor_functor_ord. + exact tensor_unit. + exact tensor_left_unitor_ord. + exact tensor_right_unitor_ord. + exact tensor_associator_ord. + exact triangle_eq_holds_ord. + exact pentagon_eq_holds_ord. Defined. Definition FinCard : monoidal_cat. Proof. use make_monoidal_cat. + exact Δ_sdg. + exact tensor_functor_card. + exact tensor_unit. + exact tensor_left_unitor_card. + exact tensor_right_unitor_card. + exact tensor_associator_card. + exact triangle_eq_holds_card. + exact pentagon_eq_holds_card. Defined. Definition U_ε : (monoidal_cat_unit FinCard) --> U (monoidal_cat_unit AugmentedSimplexCategory). Proof. unfold U. simpl. unfold monoidal_cat_unit. simpl. exact (idfun (⟦ tensor_unit ⟧)%stn). Defined. Definition U_μ : monoidal_functor_map AugmentedSimplexCategory FinCard U. Proof. unfold monoidal_functor_map. simpl. unfold "⟹". use tpair. - unfold nat_trans_data. unfold precategory_binproduct_data. simpl. simpl. intro x. induction x as [n m]. simpl. exact (idfun (⟦ n + m ⟧)%stn). - abstract(cbv beta; unfold is_nat_trans; simpl; intros x x'; induction x as [n m], x' as [n' m']; unfold precategory_binproduct_mor; intro fg; simpl in fg; induction fg as [f g]; simpl; set (s:= id_left (Δ_sdg_mor_constr (AugmentedSimplexCategory.sumfn (pr1 f) (pr1 g)))); unfold "id" in s; simpl in s; unfold Δ_sdg_mor_constr in s; unfold Δ_sdg_ob_constr in s; unfold idfun; simpl in s; simpl; induction f as [ffun fguarantee], g as [gfun gguarantee]; simpl in s; simpl; unfold "·"; unfold "·" in s; simpl in s; simpl; unfold idfun in s; rewrite s; reflexivity). Defined. Definition U_α : monoidal_functor_associativity AugmentedSimplexCategory FinCard U U_μ. Proof. unfold monoidal_functor_associativity. intros x y z. simpl. unfold MonoidalFunctorsTensored.α_D, MonoidalFunctorsTensored.α_C. simpl. unfold monoidal_cat_associator. simpl. (* We get rid of all the identity morphisms. *) change (idfun (⟦ x + y + z⟧)%stn) with (identity (C:=Δ_sdg) (x + y + z)). change (idfun (⟦ x + y ⟧)%stn) with (identity (C:=Δ_sdg) (x + y)). change (idfun (⟦ x + (y + z) ⟧)%stn) with (identity (C:=Δ_sdg) (x + (y+z))). change (idfun (⟦ y + z ⟧)%stn) with (identity (C:=Δ_sdg) (y+z)). set (j':= (tensor_id_card (make_dirprod (x + y) z))). simpl in *. rewrite j'. set (j:= (tensor_id_card (make_dirprod x (y + z)))). simpl in *. rewrite j. simpl in *. rewrite (id_right (C:=Δ_sdg)), (id_right (C:=Δ_sdg)), (id_right (C:=Δ_sdg)), (id_left (C:=Δ_sdg)). (* Done. *) apply fincard_hom_extensionality. intro t. (* induction t as [tval tbd]. *) cbn. unfold tensor_associator_ord_nat_trans_data, tensor_associator_card_nat_trans_data. cbn. induction (nat_rect _ _). reflexivity. Qed. Local Proposition U_unitality : monoidal_functor_unitality AugmentedSimplexCategory FinCard U U_ε U_μ. Proof. unfold monoidal_functor_unitality. simpl. intro x. unfold MonoidalFunctorsTensored.λ_D, monoidal_cat_left_unitor. simpl. split. - change (idfun (⟦x⟧)%stn) with (identity (C:=Δ_sdg) x). rewrite (id_right (C:=Δ_sdg)), (id_right (C:=Δ_sdg)). cbn. unfold U_ε, sumfn. simpl. apply funextsec. intro A. simpl. apply subtypeInjectivity_prop. simpl. rewrite natminuseqn. rewrite natplusr0. reflexivity. - change (idfun (⟦x⟧)%stn) with (identity (C:=Δ_sdg) x). unfold MonoidalFunctorsTensored.I_C, monoidal_cat_unit. simpl. rewrite (id_right (C:=Δ_sdg)). cbn. unfold tensor_right_unitor_card_nt_data. induction (natplusr0 x). simpl. apply funextsec. intro y. simpl. unfold sumfn. induction y as [yval ybd]. simpl. assert (yval < x) as j. { rewrite (natplusr0 x) in ybd. exact ybd. } rewrite (natlthorgeh_left_branch j _). simpl. induction (! natplusr0 x). simpl. apply subtypeInjectivity_prop. reflexivity. Qed. Definition U_Mon_Lax : lax_monoidal_functor AugmentedSimplexCategory FinCard. Proof. use make_lax_monoidal_functor. + exact U. + exact U_ε. + exact U_μ. + exact U_α. + exact U_unitality. Defined. Definition U_Mon_Strong : strong_monoidal_functor AugmentedSimplexCategory FinCard. Proof. exists U_Mon_Lax. split. - cbn. unfold is_z_isomorphism. use tpair. + simpl. exact (idfun (⟦ tensor_unit ⟧)%stn). + abstract(simpl; unfold is_inverse_in_precat; split; unfold U_ε; exact (id_right (C:=Δ_sdg) (idfun _)); unfold U_ε; exact (id_right (C:=Δ_sdg) (idfun _))). - unfold is_nat_z_iso. simpl. intro c. induction c as [n m]. unfold is_z_isomorphism. simpl. exists (idfun (⟦ n + m⟧)%stn). abstract(unfold is_inverse_in_precat; split; exact (id_right (C:=Δ_sdg) (idfun _)); exact (id_right (C:=Δ_sdg) (idfun _))). Defined. Local Lemma functor_eq_to_object_eq_on_homs (C D : precategory) (F G : functor C D) ( p : F = G) (c : C) (d : D) ( f : d --> G c) : internal_paths_rew_r (C ⟶ D) F G (λ H : C ⟶ D, D ⟦ d , H c⟧) f p = internal_paths_rew_r D (F c) (G c) (λ d' : D, D ⟦ d , d' ⟧) f (maponpaths (λ H : C ⟶ D, H c) p). Proof. induction p. reflexivity. Defined. Local Proposition tensor_card_is_strict_left_iso_id : ∏ eq_λ : I_pretensor (monoidal_cat_tensor FinCard) (monoidal_cat_unit FinCard) = functor_identity (pr1 FinCard), (is_nat_z_iso_id eq_λ (monoidal_cat_left_unitor FinCard)). Proof. intro eq_λ. unfold is_nat_z_iso_id. intro c. unfold nat_comp_to_endo. rewrite functor_eq_to_object_eq_on_homs. set (j := maponpaths _ _). simpl in j. simpl in c. assert (j = idpath c) as RW by apply (setproperty natset); rewrite RW. reflexivity. Qed. Local Arguments monoidal_cat_tensor /. Local Arguments monoidal_cat_unit /. Local Arguments functor_fix_fst_arg /. Local Arguments functor_fix_snd_arg /. Local Arguments functor_fix_fst_arg_ob /. Local Arguments functor_fix_snd_arg_ob /. Local Definition right_unitor_id (c : Δ_sdg) : I_posttensor (monoidal_cat_tensor FinCard) (monoidal_cat_unit FinCard) c = functor_identity (pr1 FinCard) c. Proof. simpl. exact (natplusr0 c). Defined. Local Proposition tensor_card_is_strict_right_iso_id : ∏ eq_ρ : I_posttensor (monoidal_cat_tensor FinCard) (monoidal_cat_unit FinCard) = functor_identity (pr1 FinCard), is_nat_z_iso_id eq_ρ (monoidal_cat_right_unitor FinCard). Proof. unfold is_nat_z_iso_id. intros eq_ρ c. unfold nat_comp_to_endo. set (Δ_sdg := (pr1 FinCard)). set (Rtensor0 := (I_posttensor _ _)). set (idfunctor := (functor_identity _)). rewrite functor_eq_to_object_eq_on_homs. set (j := maponpaths _ _). cbv beta in j. assert (j = right_unitor_id c) as RW by apply (setproperty natset); rewrite RW. unfold right_unitor_id, transportb. apply fincard_hom_extensionality. intro x. unfold Rtensor0 in x. simpl in x. simpl. unfold tensor_right_unitor_card_nt_data. simpl. induction (natplusr0 c). simpl. reflexivity. Qed. Local Proposition tensor_card_is_strict_associator_id : ∏ eq_α : assoc_left tensor_functor_card = assoc_right tensor_functor_card, is_nat_z_iso_id eq_α (monoidal_cat_associator FinCard). Proof. unfold is_nat_z_iso_id. intro eq_α. intro c. simpl in c. induction c as [nm k]. induction nm as [n m]. unfold nat_comp_to_endo. rewrite functor_eq_to_object_eq_on_homs. unfold assoc_left. simpl. set (j:= maponpaths _ _). assert (j = (natplusassoc n m k)) as RW by apply (pr2 natset). rewrite RW. simpl. generalize (natplusassoc n m k). induction p. simpl. reflexivity. Qed. Definition FinCardStrict : strict_monoidal_cat. Proof. use tpair. { exact FinCard. } cbv beta. intros eq_λ eq_ρ eq_α. use tpair. { exact (tensor_card_is_strict_left_iso_id eq_λ). } cbv beta. split. { exact (tensor_card_is_strict_right_iso_id eq_ρ). } exact (tensor_card_is_strict_associator_id eq_α). Defined. Local Proposition tensor_Δ_left_unitor_is_id : ∏ eq_λ : I_pretensor (monoidal_cat_tensor AugmentedSimplexCategory) (monoidal_cat_unit AugmentedSimplexCategory) = functor_identity (pr1 AugmentedSimplexCategory), (is_nat_z_iso_id eq_λ (monoidal_cat_left_unitor AugmentedSimplexCategory)). Proof. unfold is_nat_z_iso_id. intros eq_λ c. unfold nat_comp_to_endo. set (Δ_sd := (pr1 FinCard)). set (Ltensor0 := (I_pretensor _ _)). set (idfunctor := (functor_identity _)). rewrite functor_eq_to_object_eq_on_homs. set (j := maponpaths _ _). unfold monoidal_cat_left_unitor. simpl pr1. unfold tensor_left_unitor_ord. simpl. unfold Ltensor0, idfunctor in j. simpl in j. assert (j = idpath c) as RW by apply (setproperty natset). rewrite RW. reflexivity. Qed. Local Proposition tensor_Δ_right_unitor_is_id : ∏ eq_ρ : I_posttensor (monoidal_cat_tensor AugmentedSimplexCategory) (monoidal_cat_unit AugmentedSimplexCategory) = functor_identity (pr1 AugmentedSimplexCategory), is_nat_z_iso_id eq_ρ (monoidal_cat_right_unitor AugmentedSimplexCategory). Proof. unfold is_nat_z_iso_id. intro eq_ρ. intro c. unfold nat_comp_to_endo. set (Rtensor0 := (I_posttensor _ _)). set (idfunctor := (functor_identity _)). rewrite functor_eq_to_object_eq_on_homs. set (j := maponpaths _ _). cbv beta in j. assert (j = right_unitor_id c) as RW. { apply (setproperty natset). } rewrite RW. simpl. unfold right_unitor_id. induction (natplusr0 c). simpl. reflexivity. Qed. Local Proposition tensor_ord_is_strict_associator_id : ∏ eq_α : assoc_left tensor_functor_ord = assoc_right tensor_functor_ord, is_nat_z_iso_id eq_α (monoidal_cat_associator AugmentedSimplexCategory). Proof. unfold is_nat_z_iso_id. intro eq_α. intro c. simpl in c. induction c as [nm k], nm as [n m]. unfold nat_comp_to_endo. rewrite functor_eq_to_object_eq_on_homs. unfold assoc_left. simpl. set (j:= maponpaths _ _). assert (j = (natplusassoc n m k)) as RW by apply (setproperty natset); rewrite RW. simpl. generalize (natplusassoc n m k). induction p. reflexivity. Qed. Definition FinOrdStrict : strict_monoidal_cat. Proof. use tpair. { exact AugmentedSimplexCategory. } cbv beta. intros eq_λ eq_ρ eq_α. use tpair. { exact (tensor_Δ_left_unitor_is_id eq_λ). } split. { exact (tensor_Δ_right_unitor_is_id eq_ρ). } exact (tensor_ord_is_strict_associator_id eq_α). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/BraidedMonoidalCategories.v000066400000000000000000000047411451125700300332600ustar00rootroot00000000000000(** Braided monoidal precategories. Authors: Mario Román, based on a previous implementation by Anthony Bordg. References: https://ncatlab.org/nlab/show/braided+monoidal+category#the_coherence_laws **) (** ** Contents: - braidings - hexagon equations - braided monoidal categories - accessors *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Local Open Scope cat. (** * Braidings *) Section Braiding. (** In this section, fix a monoidal category. *) Context (MonM : monoidal_cat). Local Definition tensor := monoidal_cat_tensor MonM. Local Definition α := monoidal_cat_associator MonM. Notation "X ⊗ Y" := (tensor (X, Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). (* A braiding is a natural isomorphism from (- ⊗ =) to (= ⊗ -). *) Definition braiding : UU := nat_z_iso tensor (binswap_pair_functor ∙ tensor). (** * Hexagon equations. *) Section HexagonEquations. Context (braid : braiding). Local Definition γ := pr1 braid. Local Definition α₁ := pr1 α. Local Definition α₂ := pr1 (nat_z_iso_inv α). Definition first_hexagon_eq : UU := ∏ (a b c : MonM) , (α₁ ((a , b) , c)) · (γ (a , (b ⊗ c))) · (α₁ ((b , c) , a)) = (γ (a , b) #⊗ (id c)) · (α₁ ((b , a) , c)) · ((id b) #⊗ γ (a , c)). Definition second_hexagon_eq : UU := ∏ (a b c : MonM) , α₂ ((a , b) , c) · (γ (a ⊗ b , c)) · α₂ ((c , a) , b) = ((id a) #⊗ γ (b , c)) · α₂ ((a , c) , b) · (γ (a , c) #⊗ (id b)). End HexagonEquations. End Braiding. (** * Braided monoidal categories *) Definition braided_monoidal_cat : UU := ∑ M : monoidal_cat , ∑ γ : braiding M , (first_hexagon_eq M γ) × (second_hexagon_eq M γ). (** ** Accessors *) Section Braided_Monoidal_Cat_Acessors. Context (M : braided_monoidal_cat). Definition braided_monoidal_cat_monoidal_cat := pr1 M. Definition braided_monoidal_cat_braiding := pr1 (pr2 M). Definition braided_monoidal_cat_first_hexagon_eq := pr1 (pr2 (pr2 M)). Definition braided_monoidal_cat_second_hexagon_eq := pr2 (pr2 (pr2 M)). End Braided_Monoidal_Cat_Acessors. Coercion braided_monoidal_cat_monoidal_cat : braided_monoidal_cat >-> monoidal_cat. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/CategoriesOfMonoids.v000066400000000000000000000114651451125700300321410ustar00rootroot00000000000000(** Categories of monoids for monoidal categories Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log --follow -- UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/CategoriesOfMonoids.v *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Local Open Scope cat. Section Category_of_Monoids. Context (Mon : monoidal_cat). Local Definition tensor := monoidal_cat_tensor Mon. Notation "X ⊗ Y" := (tensor (X , Y)). Notation "f #⊗ g" := (# tensor (f #, g)) (at level 31). Local Definition I := monoidal_cat_unit Mon. Local Definition α' := monoidal_cat_associator Mon. Local Definition λ' := monoidal_cat_left_unitor Mon. Local Definition ρ' := monoidal_cat_right_unitor Mon. Definition monoid_ob_data : UU := ∑ X : Mon, (X ⊗ X --> X) × (I --> X). Definition is_monoid_ob (X : Mon) (μ : X ⊗ X --> X) (η : I --> X) : UU := (μ #⊗ id X · μ = pr1 α' ((X, X), X) · id X #⊗ μ · μ) × (* Pentagon diagram *) (pr1 λ' X = η #⊗ id X · μ) × (pr1 ρ' X = id X #⊗ η · μ). (* Unitor diagrams *) (* This definition deviates from that by Mac Lane (CWM 2nd ed., p.170) since the associator goes in the opposite direction. However, it conforms to the def. on Wikipedia for monoid objects. *) Definition monoid_ob : UU := ∑ X : monoid_ob_data, is_monoid_ob (pr1 X) (pr1 (pr2 X)) (pr2 (pr2 X)). Definition monoid_carrier (X : monoid_ob) : Mon := pr1 (pr1 X). Local Coercion monoid_carrier : monoid_ob >-> ob. Definition monoid_mult (X : monoid_ob) := pr1 (pr2 (pr1 X)). Definition monoid_unit (X : monoid_ob) := pr2 (pr2 (pr1 X)). Definition is_monoid_mor (X Y : monoid_ob) (f : monoid_carrier X --> monoid_carrier Y) : UU := ((@monoid_mult X) · f = f #⊗ f · (@monoid_mult Y)) × (@monoid_unit X) · f = (@monoid_unit Y). Definition monoid_mor (X Y : monoid_ob) : UU := ∑ f : X --> Y, is_monoid_mor X Y f. Coercion mor_from_monoid_mor (X Y : monoid_ob) (f : monoid_mor X Y) : X --> Y := pr1 f. Definition isaprop_is_monoid_mor (X Y : monoid_ob) (f : monoid_carrier X --> monoid_carrier Y): isaprop (is_monoid_mor X Y f). Proof. use isapropdirprod; apply homset_property. Qed. Definition isaset_monoid_mor (X Y : monoid_ob) : isaset (monoid_mor X Y). Proof. apply (isofhleveltotal2 2). - apply homset_property. - intro. apply isasetaprop. apply isaprop_is_monoid_mor. Qed. Definition monoid_mor_eq {X Y : monoid_ob} {f g : monoid_mor X Y} : (f : X --> Y) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro. apply isaprop_is_monoid_mor. Defined. Definition monoid_mor_id (X : monoid_ob) : monoid_mor X X. Proof. exists (id _). red. rewrite id_right. rewrite tensor_id. rewrite id_left. rewrite id_right. split; apply idpath. Defined. Definition monoid_mor_comp (X Y Z : monoid_ob) (f : monoid_mor X Y) (g : monoid_mor Y Z) : monoid_mor X Z. Proof. use tpair; [| split]. - exact (f · g). - rewrite assoc. change (monoid_mult X · pr1 f · g = # tensor (f · g #, f · g) · monoid_mult Z). rewrite (pr1 (pr2 f)). rewrite <- assoc. change ((# tensor (f #, f) · (monoid_mult Y · g) = # tensor (catbinprodmor (f · g) (f · g)) · monoid_mult Z)). rewrite binprod_comp. change ((# tensor (pr1 f #, pr1 f) · (monoid_mult Y · pr1 g) = # tensor ((f #, f) · (g #, g)) · monoid_mult Z)). rewrite functor_comp. rewrite (pr1 (pr2 g)). rewrite assoc. apply idpath. - rewrite assoc. rewrite <- (pr2 (pr2 g)). rewrite <- (pr2 (pr2 f)). apply idpath. Defined. Definition precategory_monoid_ob_mor : precategory_ob_mor. Proof. exists monoid_ob. exact monoid_mor. Defined. Definition precategory_monoid_data : precategory_data. Proof. exists precategory_monoid_ob_mor. exists monoid_mor_id. exact monoid_mor_comp. Defined. Lemma is_precategory_precategory_monoid_data : is_precategory precategory_monoid_data. Proof. repeat split; intros; simpl; apply monoid_mor_eq. - apply id_left. - apply id_right. - apply assoc. - apply assoc'. Defined. Definition precategory_monoid : precategory := tpair _ _ is_precategory_precategory_monoid_data. Local Notation monoid := precategory_monoid. Lemma precategory_monoid_has_homsets: has_homsets precategory_monoid. Proof. red. intros X Y. red. intros f g. apply (isofhlevelweqf 1 (monoid_mor_eq(f := f)(g := g))). apply homset_property. Qed. Definition category_monoid: category := precategory_monoid ,, precategory_monoid_has_homsets. End Category_of_Monoids. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/DisplayedMonoidalCurried.v000066400000000000000000000311451451125700300331520ustar00rootroot00000000000000(* In this file we formalize the definition of a certain monoidal structure on a display category and show that the total category has the structure of a monoidal category if the base category is a monoidal category and the displayed category has this certain monoidal structure. The data of a displayed monoidal category consists of: - A (base) category C. - A displayed category D over C. - A displayed tensor DT which consists of: - D_x → D_y → D_{x ⊗_{T} y} : a → (b → a⊗_{{DT}} b). - (a -->[f] a') → (b -->[g] b') → ( (a ⊗_{{DT}} b) -->[f ⊗^{T} g] (a' ⊗_{{DT}} b') : f'→g'→ (f' ⊗^{{DT}} g'). - A term i : D I, called the displayed unit. - A natural transformation dlu : (i ⊗_{{TD}} (-)) -->[lu_x] (-) with naturality condition: - (id_i ⊗^{{TD}} f') ;; dlu_b = dlu_a ;; f' where the equality is dependent over the naturality condition of lu w.r.t. f, i.e. we have to transport. - A natural transformation dru : ((-) ⊗_{{TD}} i) -->[ru_x] (-) with naturality condition: - (f' ⊗^{{TD}} id_i) ;; dru_b = dru_a ;; f' where the equality is dependent over the naturality condition of ru w.r.t. f, i.e. we have to transport. - A natural transformation dα : ((-)⊗(-))⊗(-) -->[α_{x,y,z}] (-)⊗((-)⊗(-)) with naturality condition: - dα_{a,b,c} ;; (f' ⊗^{{TD}} (g' ⊗^{{TD}} h')) = (f'⊗g')⊗h' ;; dα_{a',b',c'} And the properties of a displayed monoidal category are given by: - Displayed triangle identity: - dα_{a,i,b} ;; (id_a ⊗ dlu_b) = dru_a ⊗ id_b. - Displayed pentagon_identity: - *) Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesCurried. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Local Open Scope cat. Local Open Scope mor_disp_scope. Section displayedmonoidalcategories. Context (C : category) (D : disp_cat C) (T : tensor_data C) (I : C) (α : associator_data T) (lu : leftunitor_data T I) (ru : rightunitor_data T I) (tid : tensorfunctor_id T) (tcomp : tensorfunctor_comp T) (αnat : associator_naturality α) (αiso : associator_is_natiso α) (lunat : leftunitor_naturality lu) (luiso : leftunitor_is_natiso lu) (runat : rightunitor_naturality ru) (ruiso : rightunitor_is_natiso ru) (tri : triangle_identity lu ru α) (pen : pentagon_identity α). Definition displayedtensor_data : UU := ∑ (dt : ∏ (x y : C), (D x) → (D y) -> (D (x ⊗_{T} y))), ∏ (x x' y y' : C), ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧), ∏ (a : D x) (a' : D x') (b : D y) (b' : D y'), (a -->[f] a') -> (b -->[g] b') -> ((dt x y a b)-->[f ⊗^{T} g] (dt x' y' a' b')). Definition displayedtensoronobjects_from_displayedtensordata (dtd : displayedtensor_data) : ∏ (x y : C), (D x) → (D y) -> (D (x ⊗_{T} y)) := pr1 dtd. Notation "a ⊗_{{ dtd }} b" := (displayedtensoronobjects_from_displayedtensordata dtd _ _ a b) (at level 31). Definition displayedtensoronmorphisms_from_displayedtensordata (dtd : displayedtensor_data) : ∏ (x x' y y' : C) (f : C ⟦ x, x' ⟧) (g : C ⟦ y, y' ⟧) (a : D x) (a' : D x') (b : D y) (b' : D y'), (a -->[ f] a') -> (b -->[ g] b') -> ((a ⊗_{{dtd}} b) -->[ f ⊗^{ T} g ] (a' ⊗_{{ dtd}} b')) := pr2 dtd. Notation "f' ⊗^{{ dtd }} g'" := (displayedtensoronmorphisms_from_displayedtensordata dtd _ _ _ _ _ _ _ _ _ _ f' g' ) (at level 31). Definition displayedassociator_data (dtd : displayedtensor_data) : UU := ∏ (x y z : C), ∏ (a : D x) (b : D y) (c : D z), ((a ⊗_{{dtd}} b) ⊗_{{dtd}} c) -->[(α x y z)] (a ⊗_{{dtd}} (b ⊗_{{dtd}} c)). Definition displayedleftunitor_data (dtd : displayedtensor_data) (i : D I) : UU := ∏ (x : C), ∏ (a : D x), ((i ⊗_{{dtd}} a)-->[(lu x)] a). Definition displayedrightunitor_data (dtd : displayedtensor_data) (i : D I) : UU := ∏ (x : C), ∏ (a : D x), ((a ⊗_{{dtd}} i)-->[(ru x)] a). Definition displayedmonoidalcat_data : UU := ∑ dtd : displayedtensor_data, ∑ i : D I, (displayedleftunitor_data dtd i) × (displayedrightunitor_data dtd i) × (displayedassociator_data dtd). Definition displayedtensordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedtensor_data := pr1 DMD. Coercion displayedtensordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedtensor_data. Definition displayedunit_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : D I := pr1 (pr2 DMD). Coercion displayedunit_from_dispmoncatdata : displayedmonoidalcat_data >-> ob_disp. Definition displayedleftunitordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedleftunitor_data DMD DMD := pr1 (pr2 (pr2 DMD)). Coercion displayedleftunitordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedleftunitor_data. Definition displayedrightunitordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedrightunitor_data DMD DMD := pr1 (pr2 (pr2 (pr2 DMD))). Coercion displayedrightunitordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedrightunitor_data. Definition displayedassociatordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedassociator_data DMD := pr2 (pr2 (pr2 (pr2 DMD))). Coercion displayedassociatordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedassociator_data. (** PROPERTIES **) Definition displayedtensor_id (dtd : displayedtensor_data) := ∏ (x y : C), ∏ (a : D x) (b : D y), ((id_disp a) ⊗^{{dtd}} (id_disp b)) = transportb _ (tid x y) (id_disp (a ⊗_{{dtd}} b)). Definition displayedtensor_comp (dtd : displayedtensor_data) := ∏ (x y x' y' x'' y'': C), ∏ (a : D x) (b : D y) (a' : D x') (b' : D y') (a'' : D x'') (b'' : D y''), ∏ (f1 : C⟦x, x'⟧) (g1 : C⟦y,y'⟧) (f2 : C⟦x',x''⟧) (g2 : C⟦y',y''⟧) (f1' : a -->[f1] a') (g1' : b -->[g1] b') (f2' : a' -->[f2] a'') (g2' : b' -->[g2] b''), ((f1'⊗^{{dtd}} g1') ;; (f2'⊗^{{dtd}} g2')) = transportb _ (tcomp x y x' y' x'' y'' f1 f2 g1 g2) ((f1';;f2') ⊗^{{dtd}} (g1';;g2')). Definition displayedassociator_naturality {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU := ∏ (x x' y y' z z' : C), ∏ (a : D x) (a' : D x') (b : D y) (b' : D y') (c : D z) (c' : D z'), ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧), ∏ (f' : a-->[f] a') (g' : b -->[g] b') (h' : c -->[h] c'), ((dα x y z a b c) ;; (f' ⊗^{{dtd}} (g' ⊗^{{dtd}} h'))) = transportb _ (αnat _ _ _ _ _ _ f g h) (((f' ⊗^{{dtd}} g') ⊗^{{dtd}} h') ;; dα _ _ _ a' b' c'). Definition displayedassociator_is_nat_iso {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU := ∏ (x y z : C), ∏ (a : D x) (b : D y) (c : D z), is_z_iso_disp ((α x y z),,(αiso x y z)) (dα x y z a b c). Definition displayedleftunitor_naturality {i : D I} {dtd : displayedtensor_data} (dlud : displayedleftunitor_data dtd i) : UU := ∏ (x y : C), ∏ (a : D x) (b : D y) (f : C⟦x,y⟧) (f' : a -->[f] b), (dlud x a) ;; f' = transportb _ (lunat x y f) (((id_disp i) ⊗^{{dtd}} f') ;; (dlud y b)). Definition displayedleftunitor_is_nat_iso {i : D I} {dtd : displayedtensor_data} (dlu : displayedleftunitor_data dtd i) : UU := ∏ (x : C), ∏ (a : D x), is_z_iso_disp (lu x,, luiso x) (dlu x a). Definition displayedrightunitor_naturality {dtd : displayedtensor_data} {i : D I} (drud : displayedrightunitor_data dtd i) : UU := ∏ (x y : C), ∏ (a : D x) (b : D y) (f : C⟦x,y⟧) (f' : a -->[f] b), ((drud x a) ;; f') = transportb _ (runat x y f) (( f' ⊗^{{dtd}} (id_disp i)) ;; (drud y b)). Definition displayedrightunitor_is_nat_iso {i : D I} {dtd : displayedtensor_data} (dru : displayedrightunitor_data dtd i) : UU := ∏ (x : C), ∏ (a : D x), is_z_iso_disp (ru x,, ruiso x) (dru x a). Definition displayedtriangle_identity {dtd : displayedtensor_data} {i : D I} (dlud : displayedleftunitor_data dtd i) (drud : displayedrightunitor_data dtd i) (dα : displayedassociator_data dtd) := ∏ (x y : C), ∏ (a : D x) (b : D y), ((dα x I y a i b) ;; ((id_disp a) ⊗^{{dtd}} dlud y b )) = transportb _ (tri x y) ((drud x a) ⊗^{{dtd}} id_disp b). Definition displayedpentagon_identity {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU := ∏ (w x y z: C), ∏ (e : D w) (a : D x) (b : D y) (c : D z), (((dα _ _ _ e a b) ⊗^{{dtd}} (id_disp c)) ;; (dα _ _ _ e (a ⊗_{{dtd}} b) c) ;; ((id_disp e) ⊗^{{dtd}} (dα _ _ _ a b c))) = transportb _ (pen w x y z) ((dα (w ⊗_{T} x) y z (e ⊗_{{dtd}} a) b c) ;; (dα w x (y ⊗_{T} z) e a (b ⊗_{{dtd}} c))). Definition displayedmonoidal_laws (DMD : displayedmonoidalcat_data) : UU := (displayedtensor_id DMD) × (displayedtensor_comp DMD) × (displayedassociator_naturality DMD) × (displayedassociator_is_nat_iso DMD) × (displayedleftunitor_naturality DMD) × (displayedleftunitor_is_nat_iso DMD) × (displayedrightunitor_naturality DMD) × (displayedrightunitor_is_nat_iso DMD) × (displayedtriangle_identity DMD DMD DMD) × (displayedpentagon_identity DMD). Definition displayedtensorid_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtensor_id DMD := pr1 DML. Coercion displayedtensorid_from_monoidallaws : displayedmonoidal_laws >-> displayedtensor_id. Definition displayedtensorcomp_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtensor_comp DMD := pr1 (pr2 DML). Coercion displayedtensorcomp_from_monoidallaws : displayedmonoidal_laws >-> displayedtensor_comp. Definition displayedassociatornaturality_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedassociator_naturality DMD := pr1 (pr2 (pr2 DML)). Coercion displayedassociatornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedassociator_naturality. Definition displayedassociatorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedassociator_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 DML))). Coercion displayedassociatorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedassociator_is_nat_iso. Definition displayedleftunitornaturality_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedleftunitor_naturality DMD := pr1 (pr2 (pr2 (pr2 (pr2 DML)))). Coercion displayedleftunitornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedleftunitor_naturality. Definition displayedleftunitorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedleftunitor_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 DML))))). Coercion displayedleftunitorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedleftunitor_is_nat_iso. Definition displayedrightunitornaturality_from_monoidallaws{DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedrightunitor_naturality DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))). Coercion displayedrightunitornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedrightunitor_naturality. Definition displayedrightunitorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedrightunitor_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML))))))). Coercion displayedrightunitorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedrightunitor_is_nat_iso. Definition displayedtriangleidentity_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtriangle_identity DMD DMD DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))))). Coercion displayedtriangleidentity_from_monoidallaws : displayedmonoidal_laws >-> displayedtriangle_identity. Definition displayedpentagonidentity_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedpentagon_identity DMD := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))))). Coercion displayedpentagonidentity_from_monoidallaws : displayedmonoidal_laws >-> displayedpentagon_identity. End displayedmonoidalcategories. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/DisplayedMonoidalTensored.v000066400000000000000000000710631451125700300333430ustar00rootroot00000000000000(** Displayed monoidal categories Author: Benedikt Ahrens 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope cat. Local Open Scope mor_disp_scope. Local Notation "C ⊠ C'" := (category_binproduct C C'). Section DispCartProdOfCats. Context {C C' : category} (D : disp_cat C) (D' : disp_cat C'). Definition disp_binprod_ob_mor : disp_cat_ob_mor (C ⊠ C'). Proof. use tpair. - intro cc'. exact (D (pr1 cc') × D' (pr2 cc')). - intros aa' bb' xx' yy' fg. exact ( (pr1 xx' -->[ pr1 fg ] pr1 yy') × (pr2 xx' -->[ pr2 fg ] pr2 yy' )). Defined. Definition disp_binprod_id_comp : disp_cat_id_comp _ disp_binprod_ob_mor. Proof. use tpair. - intros x xx. use make_dirprod. * apply id_disp. * apply id_disp. - intros aa' bb' cc' ff' gg' xx' yy' zz' hh' ii'. use make_dirprod. * apply (comp_disp (pr1 hh') (pr1 ii')). * apply (comp_disp (pr2 hh') (pr2 ii')). Defined. Definition disp_binprod_data : disp_cat_data (C ⊠ C') := disp_binprod_ob_mor ,, disp_binprod_id_comp. Lemma disp_binprod_transportf_pr1 (a b : C) (f g : a --> b) (a' b' : C') (f' g' : a' --> b') (x : D a) (y : D b) (x' : D' a') (y' : D' b') (ff : x -->[f] y) (ff' : x' -->[f'] y') (e : catbinprodmor f f' = catbinprodmor g g') : transportf (mor_disp _ _) (maponpaths pr1 e) ff = pr1 (transportf (@mor_disp _ disp_binprod_data (a,,a') _ (x,, x') (_,, _)) e (ff,, ff')) . Proof. induction e. apply idpath. Qed. Lemma disp_binprod_transportf_pr2 (a b : C) (f g : a --> b) (a' b' : C') (f' g' : a' --> b') (x : D a) (y : D b) (x' : D' a') (y' : D' b') (ff : x -->[f] y) (ff' : x' -->[f'] y') (e : catbinprodmor f f' = catbinprodmor g g') : transportf (mor_disp _ _) (maponpaths (dirprod_pr2) e) ff' = pr2 (transportf (@mor_disp _ disp_binprod_data (a,,a') _ (x,, x') (_,, _)) e (ff,, ff')) . Proof. induction e. apply idpath. Qed. Lemma disp_binprod_axioms : disp_cat_axioms _ disp_binprod_data. Proof. repeat split. - intros [a a'] [b b'] [f f'] [x x'] [y y'] [ff ff']. simpl in *. apply dirprodeq. * simpl in *. etrans. apply id_left_disp. etrans. 2: { apply disp_binprod_transportf_pr1. } apply transportf_paths. apply C. * simpl in *. etrans. apply id_left_disp. etrans. 2: { apply disp_binprod_transportf_pr2. } apply transportf_paths. apply C'. - intros [a a'] [b b'] [f f'] [x x'] [y y'] [ff ff']. simpl in *. apply dirprodeq. * simpl in *. etrans. apply id_right_disp. etrans. 2: { apply disp_binprod_transportf_pr1. } apply transportf_paths. apply C. * simpl in *. etrans. apply id_right_disp. etrans. 2: { apply disp_binprod_transportf_pr2. } apply transportf_paths. apply C'. - intros [a a'] [b b'] [c c'] [d d'] [f f'] [g g'] [h h'] [x x'] [y y'] [z z'] [w w'] [u u'] [v v'] [r r']. simpl in *. apply dirprodeq. * simpl. etrans. apply assoc_disp. etrans. 2: { apply disp_binprod_transportf_pr1. } apply transportf_paths. apply C. * simpl. etrans. apply assoc_disp. etrans. 2: { apply disp_binprod_transportf_pr2. } apply transportf_paths. apply C'. - intros. apply isasetdirprod. * apply D. * apply D'. Qed. Definition disp_binprod : disp_cat (C ⊠ C') := disp_binprod_data ,, disp_binprod_axioms. End DispCartProdOfCats. Notation "D ⊠⊠ D'" := (disp_binprod D D') (at level 60). Section TotalDispProd. (** We can build the total category of a [disp_binprod D D'], or we can take the cartesian product of two total categories. *) Context {C C' : category} (D : disp_cat C) (D' : disp_cat C'). Let T : category := total_category (D ⊠⊠ D'). Let T' : category := total_category D ⊠ total_category D'. Definition reord1_functor_data : functor_data T T'. Proof. use tpair. - intros [[c c'] [d d']]. exact (make_dirprod (c,,d) (c',,d')). - cbn. intros [[a a'] [d d']] [[b b'] [e e']] [[f f'] [g g']]. exact (make_dirprod (f,,g) (f',,g')). Defined. Definition reord1_functor_axioms : is_functor reord1_functor_data. Proof. split. - intros a. apply idpath. - intros a b c f g. apply idpath. Qed. Definition reord1_functor : functor T T' := reord1_functor_data ,, reord1_functor_axioms. Definition reord1_hom_inverse (a b : T) : T' ⟦ reord1_functor a, reord1_functor b ⟧ → T ⟦ a, b ⟧. Proof. intros [[c d] [c' d']]. cbn in *. use tpair. - exact (make_dirprod c c'). - cbn. exact (make_dirprod d d'). Defined. Definition fully_faithful_reord1_functor : fully_faithful reord1_functor. Proof. intros a b. use isweq_iso. - exact (reord1_hom_inverse a b). - intros. apply idpath. - intros; apply idpath. Defined. Definition reord1_ob_inverse : T' → T. Proof. intros [[c d] [c' d']]. use tpair. - exact (make_dirprod c c'). - exact (make_dirprod d d'). Defined. Definition is_catiso_reord_functor : is_catiso reord1_functor. Proof. split. - exact fully_faithful_reord1_functor. - use isweq_iso. + exact reord1_ob_inverse. + intro; apply idpath. + intro; apply idpath. Defined. Definition catiso_reord : catiso T T' := _ ,, is_catiso_reord_functor . End TotalDispProd. Definition total_bifunctor {C D E : category} (F : C ⊠ D ⟶ E) {DC : disp_cat C} {DD : disp_cat D} {DE : disp_cat E} (FF : disp_functor F (DC ⊠⊠ DD) DE) : total_category DC ⊠ total_category DD ⟶ total_category DE := inv_catiso (catiso_reord DC DD) ∙ total_functor FF. Lemma disp_binprod_transportf (C C' : category) (D : disp_cat C) (D' : disp_cat C') (a b : C) (a' b' : C') (f g : a --> b) (f' g' : a' --> b') (x : D a) (y : D b) (x' : D' a') (y' : D' b') (ff : x -->[f] y) (ff' : x' -->[f'] y') (e : (f,,f') = (g,, g')) : transportf (@mor_disp (C ⊠ C') (disp_binprod D D') (a,,a') (b,,b') (x,,x') (y,,y')) e (ff,, ff') = transportf (mor_disp _ _ ) (maponpaths pr1 e) ff ,, transportf (mor_disp _ _ ) (maponpaths (dirprod_pr2) e) ff'. Proof. induction e. apply idpath. Qed. Section DispCartProdOfFunctors. Context {A A' C C' : category} {F : functor A C} {F' : functor A' C'} {D : disp_cat A} {D' : disp_cat A'} {E : disp_cat C} {E' : disp_cat C'} (G : disp_functor F D E) (G' : disp_functor F' D' E'). Definition disp_pair_functor_data : disp_functor_data (pair_functor F F') (D ⊠⊠ D') (E ⊠⊠ E'). Proof. use tpair. - intros aa' dd'. use make_dirprod. + use G. apply (pr1 dd'). + use G'. apply (pr2 dd'). - cbn. intros aa' aa'' xx' yy' ff' gg'. use make_dirprod. + apply ♯G. apply (pr1 gg'). + apply ♯G'. apply (pr2 gg'). Defined. Lemma disp_pair_functor_axioms : @disp_functor_axioms (A ⊠ A') (C ⊠ C') (pair_functor F F') _ _ disp_pair_functor_data. Proof. split. - intros [a a'] [d d']. apply pathsinv0. etrans. { apply disp_binprod_transportf. } cbn. apply dirprodeq; cbn. + apply pathsinv0. etrans. apply disp_functor_id. apply transportf_paths. apply C. + apply pathsinv0. etrans. apply disp_functor_id. apply transportf_paths. apply C'. - intros [a a'] [b b'] [c c'] [w w'] [x x'] [y y'] [f f'] [g g'] [ff ff'] [gg gg']. cbn in *. apply pathsinv0. etrans. { apply disp_binprod_transportf. } apply pathsinv0. apply dirprodeq; cbn. + etrans. apply disp_functor_comp. apply transportf_paths. apply C. + etrans. apply disp_functor_comp. apply transportf_paths. apply C'. Qed. Definition disp_pair_functor : @disp_functor (A ⊠ A') (C ⊠ C') (pair_functor F F') (D ⊠⊠ D') (E ⊠⊠ E') := disp_pair_functor_data ,, disp_pair_functor_axioms. End DispCartProdOfFunctors. Section DispAssocFunctors. Context (A B C : category) (DA : disp_cat A) (DB : disp_cat B) (DC : disp_cat C). Definition disp_assoc_data : disp_functor_data (precategory_binproduct_assoc A B C) (DA ⊠⊠ (DB ⊠⊠ DC)) ((DA ⊠⊠ DB) ⊠⊠ DC). Proof. use tpair. - intros abc dabc. exact ( (pr1 dabc,,pr12 dabc) ,, pr22 dabc). - intros abc abc' xx yy f g. exact ( (pr1 g,,pr12 g) ,, pr22 g). Defined. (* Make a general lemma that encompasses the two parts here *) Lemma disp_assoc_axioms : disp_functor_axioms disp_assoc_data. Proof. split. - intros x xx. cbn. apply dirprod_paths. + cbn. apply dirprod_paths. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr1 (DA ⊠⊠ DB) DC). } etrans. 2 : { apply (disp_binprod_transportf_pr1 DA DB). } apply pathsinv0. apply transportf_set. apply A. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr1 (DA ⊠⊠ DB) DC). } etrans. 2 : { apply (disp_binprod_transportf_pr2 DA DB). } apply pathsinv0. apply transportf_set. apply B. + cbn. etrans. 2 : { apply (disp_binprod_transportf_pr2 (DA ⊠⊠ DB) DC). } apply pathsinv0. apply transportf_set. apply C. - intros. cbn. apply dirprod_paths. + cbn. apply dirprod_paths. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr1 (DA ⊠⊠ DB) DC). } etrans. 2 : { apply (disp_binprod_transportf_pr1 DA DB). } apply pathsinv0. apply transportf_set. apply A. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr1 (DA ⊠⊠ DB) DC). } etrans. 2 : { apply (disp_binprod_transportf_pr2 DA DB). } apply pathsinv0. apply transportf_set. apply B. + cbn. etrans. 2 : { apply (disp_binprod_transportf_pr2 (DA ⊠⊠ DB) DC). } apply pathsinv0. apply transportf_set. apply C. Qed. Definition disp_assoc : disp_functor (precategory_binproduct_assoc A B C) (DA ⊠⊠ (DB ⊠⊠ DC)) ((DA ⊠⊠ DB) ⊠⊠ DC) := _ ,, disp_assoc_axioms. Definition disp_unassoc_data : disp_functor_data (precategory_binproduct_unassoc A B C) ((DA ⊠⊠ DB) ⊠⊠ DC) (DA ⊠⊠ (DB ⊠⊠ DC)). Proof. use tpair. - intros abc dabc. exact ( pr11 dabc,, (pr21 dabc ,, pr2 dabc)). - intros abc abc' xx yy f g. exact ( pr11 g,, (pr21 g ,, pr2 g)). Defined. (* Make a general lemma that encompasses the two parts here *) Lemma disp_unassoc_axioms : disp_functor_axioms disp_unassoc_data. Proof. split. - intros x xx. cbn. apply dirprod_paths. + cbn. etrans. 2 : { apply (disp_binprod_transportf_pr1 DA (DB ⊠⊠ DC)). } apply pathsinv0. apply transportf_set. apply A. + cbn. apply dirprod_paths. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr2 DA (DB ⊠⊠ DC) ). } etrans. 2 : { apply (disp_binprod_transportf_pr1 DB DC). } apply pathsinv0. apply transportf_set. apply B. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr2 DA (DB ⊠⊠ DC)). } etrans. 2 : { apply (disp_binprod_transportf_pr2 DB DC). } apply pathsinv0. apply transportf_set. apply C. - intros. cbn. apply dirprod_paths. + cbn. etrans. 2 : { apply (disp_binprod_transportf_pr1 DA (DB ⊠⊠ DC)). } apply pathsinv0. apply transportf_set. apply A. + cbn. apply dirprod_paths. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr2 DA (DB ⊠⊠ DC) ). } etrans. 2 : { apply (disp_binprod_transportf_pr1 DB DC). } apply pathsinv0. apply transportf_set. apply B. * cbn. etrans. 2 : { apply maponpaths. apply (disp_binprod_transportf_pr2 DA (DB ⊠⊠ DC)). } etrans. 2 : { apply (disp_binprod_transportf_pr2 DB DC). } apply pathsinv0. apply transportf_set. apply C. Qed. Definition disp_unassoc : disp_functor (precategory_binproduct_assoc A B C) (DA ⊠⊠ (DB ⊠⊠ DC)) ((DA ⊠⊠ DB) ⊠⊠ DC) := _ ,, disp_assoc_axioms. End DispAssocFunctors. Lemma transportf_fst_arg_type {A B C : category} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {F : A ⊠ B ⟶ C} (FF : disp_functor F (DA ⊠⊠ DB) DC) {a₁ a₂ : A} {da₁ : DA a₁} {da₂ : DA a₂} {f f' : a₁ --> a₂} (e : f = f') (ff : da₁ -->[f] da₂) {b₁ b₂ : B} {db₁ : DB b₁} {db₂ : DB b₂} {g : b₁ --> b₂} (gg : db₁ -->[g] db₂) : UU. Proof. refine (@disp_functor_on_morphisms _ _ _ _ _ FF (a₁,,b₁) (a₂,,b₂) (da₁,,db₁) (da₂,,db₂) (f',,g) (make_dirprod (transportf (mor_disp da₁ da₂) e ff) gg) = _ ). set (X := @disp_functor_on_morphisms _ _ _ _ _ FF (a₁,,b₁) (a₂,,b₂) (da₁,,db₁) (da₂,,db₂) (f,,g) (ff,,gg)). refine (transportf _ _ X). apply maponpaths. apply maponpaths_2. apply e. Defined. Lemma transportf_fst_arg {A B C : category} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {F : A ⊠ B ⟶ C} (FF : disp_functor F (DA ⊠⊠ DB) DC) {a₁ a₂ : A} {da₁ : DA a₁} {da₂ : DA a₂} {f f' : a₁ --> a₂} (e : f = f') (ff : da₁ -->[f] da₂) {b₁ b₂ : B} {db₁ : DB b₁} {db₂ : DB b₂} {g : b₁ --> b₂} (gg : db₁ -->[g] db₂) : transportf_fst_arg_type FF e ff gg. Proof. unfold transportf_fst_arg_type. induction e. cbn. apply idpath. Qed. Section disp_fix_fst_arg. Local Notation "( f #, g )" := (catbinprodmor f g). Context {A B C : category} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (F : functor (A ⊠ B) C) (FF : disp_functor F (DA ⊠⊠ DB) DC) (a : A) (da : DA a). Definition disp_functor_fix_fst_arg_ob {b : B} (db : DB b) : DC (F _) := FF (a,,b) (da,, db). Definition disp_functor_fix_fst_arg_mor {b₁ b₂ : B} {f : b₁ --> b₂} {db₁ : DB b₁} {db₂ : DB b₂} (ff : db₁ -->[f] db₂) : FF (a,,b₁) (da,,db₁) -->[ (# F (identity _ #,f))%cat ] FF (a,,b₂) (da,,db₂). Proof. apply ♯FF. apply (id_disp _ ,, ff). Defined. Definition disp_functor_fix_fst_arg_data : disp_functor_data (functor_fix_fst_arg _ _ _ F a) DB DC. Proof. exists @disp_functor_fix_fst_arg_ob. intros x y xx yy f ff. apply disp_functor_fix_fst_arg_mor. apply ff. Defined. Definition disp_functor_fix_fst_arg_axioms : disp_functor_axioms disp_functor_fix_fst_arg_data. Proof. split. - intros. cbn. unfold disp_functor_fix_fst_arg_mor. rewrite (@disp_functor_id _ _ _ _ _ FF). apply transportf_transpose_right. etrans. { apply transport_f_f. } apply transportf_set. apply C. - intros. cbn. unfold disp_functor_fix_fst_arg_mor. apply transportf_transpose_right. set (X := @disp_functor_comp_var _ _ _ _ _ FF). etrans. 2 : { apply X. } cbn. apply transportf_transpose_right. etrans. 2 : { apply maponpaths. apply maponpaths_2. eapply pathsinv0. apply id_left_disp. } etrans. { apply transport_f_f. } apply pathsinv0. etrans. apply transportf_fst_arg. cbn. apply transportf_transpose_right. etrans. apply transport_f_f. apply transportf_set. apply C. Qed. Definition disp_functor_fix_fst_arg : disp_functor (functor_fix_fst_arg _ _ _ F a) DB DC := _ ,, disp_functor_fix_fst_arg_axioms. End disp_fix_fst_arg. Definition displayed_tensor {C : category} (tensor : C ⊠ C ⟶ C) (D : disp_cat C) : UU := disp_functor tensor (disp_binprod D D) D. Identity Coercion displayed_tensor_to_disp_functor : displayed_tensor >-> disp_functor. Definition total_tensor {C : category} (T : C ⊠ C ⟶ C) {D : disp_cat C} (TT : displayed_tensor T D) : total_category D ⊠ total_category D ⟶ total_category D := total_bifunctor T TT. Section section_tensor. (** TT D × D ------------> D ∧ ∧ ∧ S| |S |S C × C ------------> C T *) Context {C : category} {D : disp_cat C} (T : C ⊠ C ⟶ C) (TT : displayed_tensor T D) (S : section_disp D). Local Definition make_prodmor {a₁ a₂ b₁ b₂ : C} (f₁ : a₁ --> b₁) (f₂ : a₂ --> b₂) : C ⊠ C ⟦ a₁,,a₂ , b₁,,b₂ ⟧ := (f₁ ,, f₂). Local Notation "f ⊠' f'" := (make_prodmor f f') (at level 30). Local Definition make_dispprodmor {a₁ a₂ b₁ b₂ : C} {f₁ : a₁ --> b₁} {f₂ : a₂ --> b₂} {d₁ : D a₁} {d₂ : D a₂} {e₁ : D b₁} {e₂ : D b₂} (ff₁ : d₁ -->[f₁] e₁) (ff₂ : d₂ -->[f₂] e₂) : @mor_disp _ (D⊠⊠D) (a₁,,a₂) (b₁,,b₂) (d₁ ,, d₂ ) ( e₁ ,, e₂ ) ( f₁ ,, f₂ ) := ff₁ ,, ff₂. Local Notation "f ⊠⊠' f'" := (make_dispprodmor f f') (at level 30). (** This is leaving the displayed world, so is only useful for validation *) Definition section_functor_pair : functor (C ⊠ C) (total_category D ⊠ total_category D). Proof. use pair_functor. - use section_functor. exact S. - use section_functor. exact S. Defined. (* This does not hold, but hints at what we want to ask for Lemma foobar : functor_composite T (section_functor S) = functor_composite section_functor_pair (total_tensor T TT). Proof. apply functor_eq. - apply homset_property. - cbn. use total2_paths_f. + cbn. apply funextsec. intros [c c']. cbn. use total2_paths_f. * apply idpath. * cbn. *) (** For a strict monoidal functor, the square above should commute up to a displayed natural isomorphism in the D that is the identity in C *) Definition monoidal_tensor_section_data : UU := ∏ (c c' : C), z_iso_disp (identity_z_iso (T (c,,c'))) (S (T (c,,c'))) (TT _ ((S c,, S c') : (D ⊠⊠ D)(c,,c'))). (* Without the identity coercerion [displayed_tensor_to_disp_functor] above, we would need to write disp_functor_on_objects (TT : disp_functor _ _ _) ((S c,, S c') : (D ⊠⊠ D)(c,,c')) instead of TT _ ((S c,, S c') : (D ⊠⊠ D)(c,,c')) *) (** Naturality for [monoidal_tensor_section_data] S(T(c₁ c₁')) ---α(c₁ c₁')---> TT(Sc₁, Sc₁') | | S(T(f₁ f₂) | | TT(Sf₁,Sf₂) v v S(T(c₂ c₂')) ---α(c₂ c₂')---> TT(Sc₂, c₂') Note that this equation is ill-typed: the down-then-horizontal lives over T(f₁,f₂) · id_iso, the horizontal-then-down lives over id_iso · T(f₁,f₂) We transport them both to live over T(f₁,f₂) *) Definition monoidal_tensor_section_natural (α : monoidal_tensor_section_data) : UU := ∏ (c₁ c₁' c₂ c₂' : C) (f : c₁ --> c₂) (f' : c₁' --> c₂'), transportf (mor_disp _ _ ) (id_right _ ) (section_disp_on_morphisms S ((#T ( f ⊠' f')) %cat) ;; α _ _) = transportf (mor_disp _ _ ) (id_left _ ) (α _ _ ;; ♯ TT (section_disp_on_morphisms S f ⊠⊠' (section_disp_on_morphisms S f'))). Definition monoidal_tensor_section : UU := ∑ (α : monoidal_tensor_section_data), monoidal_tensor_section_natural α. Coercion monoidal_tensor_section_data_from_monoidal_tensor_section (α : monoidal_tensor_section) : monoidal_tensor_section_data := pr1 α. Definition monoidal_tensor_ax (α : monoidal_tensor_section) (c₁ c₁' c₂ c₂' : C) (f : c₁ --> c₂) (f' : c₁' --> c₂') : transportf (mor_disp _ _ ) (id_right _ ) (section_disp_on_morphisms S ((#T ( f ⊠' f')) %cat) ;; pr1 α _ _) = transportf (mor_disp _ _ ) (id_left _ ) (pr1 α _ _ ;; ♯TT (section_disp_on_morphisms S f ⊠⊠' (section_disp_on_morphisms S f'))) := pr2 α _ _ _ _ f f'. Definition monoidal_tensor_ax' (α : monoidal_tensor_section) (c₁ c₁' c₂ c₂' : C) (f : c₁ --> c₂) (f' : c₁' --> c₂') : (section_disp_on_morphisms S ((#T ( f ⊠' f')) %cat) ;; pr1 α _ _) = transportb (mor_disp _ _ ) (id_right _ ) ( transportf (mor_disp _ _ ) (id_left _ ) (pr1 α _ _ ;; ♯TT (section_disp_on_morphisms S f ⊠⊠' (section_disp_on_morphisms S f')))). Proof. apply transportf_transpose_right. etrans. 2 : { apply monoidal_tensor_ax. } apply transportf_paths. apply C. Qed. (* Sanity check looks ok, but is cumbersome to prove *) Local Definition sanity_check (α : monoidal_tensor_section) : nat_iso (functor_composite T (section_functor S)) (functor_composite section_functor_pair (total_tensor T TT)). Proof. use make_nat_iso. - use make_nat_trans. + intro a. cbn. use tpair. * exact (identity_iso _ ). * cbn. apply α. + cbn. intros [a a'] [b b'] [f f']. cbn in *. use total2_paths_f. * (* we can prove this in an ugly way, since in the next goal we are transporting along equality between elements of a set anyway For getting a clean display, it would even be good to prove this equality separately and make it `Qed.`. *) (*cbn. etrans. apply id_right. etrans. 2 : { eapply pathsinv0. apply id_left. } apply maponpaths. repeat rewrite id_left. repeat rewrite id_right. apply idpath. *) admit. * cbn. etrans. apply maponpaths. apply monoidal_tensor_ax'. etrans. { apply transport_f_f. } etrans. { apply transport_f_f. } apply pathsinv0. set (X := @disp_functor_comp _ _ _ _ _ TT). etrans. { apply maponpaths. set (X':= @X (a,,a') (b,,b') (b,,b') (S a,, S a') (S b,,S b') (S b,,S b')). set (X'' := @X' ((id _ · f) ⊠' (id _ · f')) (identity b ⊠' id b')). set (X3 := X'' ((id_disp (S a) ;; section_disp_on_morphisms S f) ⊠⊠'(id_disp (S a') ;; section_disp_on_morphisms S f') )). set (X4 := X3 (id_disp (S b) ⊠⊠' (id_disp (S b')))). apply X4. } cbn. etrans. { apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths. apply maponpaths. etrans. { apply maponpaths. set (X' := @disp_functor_id _ _ _ _ _ TT). apply (X' (b,,b')). } apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths. apply maponpaths. apply maponpaths. apply id_right_disp. } etrans. { apply maponpaths. apply maponpaths. apply mor_disp_transportf_prewhisker. } etrans. { apply transport_f_f. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply maponpaths. set (X':= @X (a,,a') (a,,a') (b,,b') (S a,, S a') (S a,,S a') (S b,,S b')). set (X'' := @X' (identity a ⊠' id a') (f ⊠' f') ). set (X3 := X'' (id_disp _ ⊠⊠' (id_disp _ )) (section_disp_on_morphisms S f ⊠⊠' section_disp_on_morphisms S f') ). apply X3. } etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply maponpaths. apply maponpaths_2. set (X' := @disp_functor_id _ _ _ _ _ TT). apply (X' (a,,a')). } etrans. { apply maponpaths. apply assoc_disp. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply maponpaths_2. apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply maponpaths_2. apply id_right_disp. } etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } etrans. { apply transport_f_f. } apply two_arg_paths. -- apply C. -- apply idpath. - intros a b f. cbn. admit. Abort. End section_tensor. Section FixDispTensor. Context {C : category} (tensor : C ⊠ C ⟶ C) {D : disp_cat C} (disp_tensor : displayed_tensor tensor D). Let al : functor _ _ := assoc_left tensor. Let ar : functor _ _ := assoc_right tensor. Definition disp_assoc_left : @disp_functor ((C ⊠ C) ⊠ C) C al ((D ⊠⊠ D) ⊠⊠ D) D . Proof. use disp_functor_composite. - use (disp_binprod D D). - use disp_pair_functor. + use disp_tensor. + use disp_functor_identity. - use disp_tensor. Defined. (* TODO Definition disp_assoc_right : @disp_functor (C ⊠ (C ⊠ C)) C ar (D ⊠⊠ (D ⊠⊠ D)) D . Proof. use disp_functor_composite. - use (disp_binprod D D). - use disp_pair_functor. + use disp_tensor. + use disp_functor_identity. - use disp_tensor. Defined. *) End FixDispTensor. EquivalenceWhiskeredNonCurriedMonoidalCategories.v000066400000000000000000000335771451125700300377600ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitionsRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesReordered. Section MonoidalCategoriesReordered0. Definition lunitor0_nattrans {C : category} (T : bifunctor C C C) (I : C) : UU := ∑ lu : leftunitor_data T I, leftunitor_nat lu. Definition lunitor0 {C : category} (T : bifunctor C C C) (I : C) : UU := ∑ lu : lunitor0_nattrans T I, ∑ lui : leftunitorinv_data T I, leftunitor_iso_law (pr1 lu) lui. Definition runitor0_nattrans {C : category} (T : bifunctor C C C) (I : C) : UU := ∑ ru : rightunitor_data T I, rightunitor_nat ru. Definition runitor0 {C : category} (T : bifunctor C C C) (I : C) : UU := ∑ ru : runitor0_nattrans T I, ∑ rui : rightunitorinv_data T I, rightunitor_iso_law (pr1 ru) rui. Definition associator0_nattrans {C : category} (T : bifunctor C C C) : UU := ∑ ass : associator_data T, associator_nat_leftwhisker ass × associator_nat_rightwhisker ass × associator_nat_leftrightwhisker ass. Definition associator0 {C : category} (T : bifunctor C C C) : UU := ∑ ass : associator0_nattrans T, ∑ assi : associatorinv_data T, associator_iso_law (pr1 ass) assi. Definition monstruct0 (C : category) : UU := ∑ T : bifunctor C C C, ∑ I : C, ∑ lu : lunitor0 T I, ∑ ru : runitor0 T I, ∑ ass : associator0 T, triangle_identity (pr11 lu) (pr11 ru) (pr11 ass) × pentagon_identity (pr11 ass). Definition moncats0 : UU := ∑ C : category, monstruct0 C. End MonoidalCategoriesReordered0. Section EquivalenceMonoidalCategoriesReordered0WithMonstructs. Definition moncats : UU := ∑ C : category, monoidal_struct C. Lemma moncats_equiv_moncats0 : moncats ≃ moncats0. Proof. apply weqfibtototal. intro C. unfold monoidal_struct ; unfold monstruct0. use weq_iso. - intro M. exists (pr111 M). exists (pr211 M). repeat (use tpair). * intro x ; apply (pr1 (pr121 M) x). * intros x y f ; apply (pr2 (pr121 M) x y f). * intro x ; apply (pr1 (pr122 M) x). * intro x ; apply (pr2 (pr122 M) x). * intro x ; apply (pr11 (pr221 M) x). * intros x y f ; apply (pr21 (pr221 M) x y f). * intro x ; apply (pr11 (pr222 M) x). * intro x ; apply (pr21 (pr222 M) x). * intros x y z ; apply (pr12 (pr221 M) x y z). * intro ; intros ; apply (pr122 (pr221 M)). * intro ; intros ; apply (pr1 (pr222 (pr221 M))). * intro ; intros ; apply (pr2 (pr222 (pr221 M))). * intro ; intros ; apply ((pr12 (pr222 M))). * intro ; intros ; apply ((pr22 (pr222 M))). * intro ; intros ; apply (pr112 M). * intro ; intros ; apply (pr212 M). - intro M. use tpair. + exists (pr1 M ,, pr12 M). repeat split ; apply (pr22 M). + simpl. repeat split. * apply (pr22 (pr222 M)). * apply (pr22 (pr222 M)). * apply ((pr122 M)). * apply (pr1 (pr222 M)). * apply (pr12 (pr222 M)). - apply idpath. - apply idpath. Defined. End EquivalenceMonoidalCategoriesReordered0WithMonstructs. Section EquivalenceMonoidalCategoriesReordered0WithUncurried. Definition lunitors_equiv {C : category} (T : bifunctor C C C) (I : C) : lunitor0 T I ≃ left_unitor (bifunctor_to_functorfromproductcat T) I. Proof. use weqtotal2. { use weqtotal2. - apply idweq. - intro lu. use weq_iso. + intro lunat. (* show we get natural transformation *) intros x y f. etrans. { apply maponpaths_2 ; apply when_bifunctor_becomes_leftwhiskering. } apply (lunat x y f). + intro lunattrans. (* show we get the naturality law of the unitor *) intros x y f. use (_ @ lunattrans x y f). apply maponpaths_2. apply (! when_bifunctor_becomes_leftwhiskering _ _ _). + intro. (* Show that (lefunitor_nat lu) is a prop. *) repeat (apply impred_isaprop ; intro) ; apply homset_property. + intro. apply isaprop_is_nat_trans. apply homset_property. } intro lunat. simpl. use (weqtotaltoforall (X := C) (λ x, C ⟦ x, bifunctor_on_objects T I x ⟧)). Defined. Definition runitors_equiv {C : category} (T : bifunctor C C C) (I : C) : runitor0 T I ≃ right_unitor (bifunctor_to_functorfromproductcat T) I. Proof. use weqtotal2. { use weqtotal2. - apply idweq. - intro lu. use weq_iso. + intro runat. (* show we get natural transformation *) intros x y f. etrans. { apply maponpaths_2 ; apply when_bifunctor_becomes_rightwhiskering. } apply (runat x y f). + intro runattrans. (* show we get the naturality law of the unitor *) intros x y f. use (_ @ runattrans x y f). apply maponpaths_2. apply (! when_bifunctor_becomes_rightwhiskering _ _ _). + intro. (* Show that (rightunitor_nat lu) is a prop. *) repeat (apply impred_isaprop ; intro) ; apply homset_property. + intro. apply isaprop_is_nat_trans. apply homset_property. } intro. simpl. use (weqtotaltoforall (X := C) (λ x, C ⟦ x , bifunctor_on_objects T x I ⟧)). Defined. Lemma nat_trans_associator_leftwhisker {C : category} {T : bifunctor C C C} {ass : associator_data T} (assnattrans : is_nat_trans (assoc_left (bifunctor_to_functorfromproductcat T)) (assoc_right (bifunctor_to_functorfromproductcat T)) (λ xyz, ass (pr11 xyz) (pr21 xyz) (pr2 xyz))) : associator_nat_leftwhisker ass. Proof. intros x y z1 z2 h. set (t := ! assnattrans _ _ ((id x #, id y) #, h)). simpl in t. unfold functoronmorphisms1 in t. refine (_ @ t @ _). { etrans. 2: { apply maponpaths ; apply maponpaths_2 ; apply when_bifunctor_becomes_rightwhiskering. } etrans. 2: { apply maponpaths ; apply maponpaths_2 ; use (! bifunctor_distributes_over_id _ _ _ _) ; apply T. } apply maponpaths. etrans. 2: { do 2 apply maponpaths ; apply maponpaths_2 ; apply when_bifunctor_becomes_rightwhiskering. } etrans. 2: { do 2 apply maponpaths ; apply maponpaths_2 ; use (! bifunctor_distributes_over_id _ _ _ _) ; apply T. } etrans. 2: { do 2 apply maponpaths ; apply (! id_left _). } apply (! id_left _). } etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths. etrans. { apply maponpaths ; apply bifunctor_leftid. } etrans. { apply id_right. } apply bifunctor_rightid. } apply bifunctor_rightid. } etrans. { apply assoc'. } apply id_left. Qed. Lemma nat_trans_associator_rightwhisker {C : category} {T : bifunctor C C C} {ass : associator_data T} (assnattrans : is_nat_trans (assoc_left (bifunctor_to_functorfromproductcat T)) (assoc_right (bifunctor_to_functorfromproductcat T)) (λ xyz, ass (pr11 xyz) (pr21 xyz) (pr2 xyz))) : associator_nat_rightwhisker ass. Proof. intros x1 x2 y z f. set (t := ! assnattrans _ _ ((f #, id y) #, id z)). simpl in t. unfold functoronmorphisms1 in t. refine (_ @ t @ _). { etrans. 2: { apply maponpaths ; apply maponpaths_2 ; apply when_bifunctor_becomes_rightwhiskering. } etrans. 2: { apply maponpaths ; apply maponpaths_2. apply (! when_bifunctor_becomes_rightwhiskering _ _ _). } apply maponpaths. etrans. 2: { do 2 apply maponpaths ; apply maponpaths_2 ; apply when_bifunctor_becomes_rightwhiskering. } etrans. 2: { do 2 apply maponpaths ; apply maponpaths_2 ; use (! bifunctor_distributes_over_id _ _ _ _) ; apply T. } etrans. 2: { do 2 apply maponpaths ; apply (! id_left _). } etrans. 2: { do 2 apply maponpaths ; apply (! bifunctor_leftid _ _ _). } etrans. 2: { apply maponpaths. apply (! bifunctor_leftid _ _ _). } apply (! id_right _). } etrans. { do 2 apply maponpaths_2. apply maponpaths. etrans. { apply maponpaths ; apply bifunctor_leftid. } apply id_right. } etrans. { apply maponpaths_2 ; apply maponpaths. apply bifunctor_leftid. } etrans. { apply assoc'. } apply maponpaths. apply id_left. Qed. Lemma nat_trans_associator_leftrightwhisker {C : category} {T : bifunctor C C C} {ass : associator_data T} (assnattrans : is_nat_trans (assoc_left (bifunctor_to_functorfromproductcat T)) (assoc_right (bifunctor_to_functorfromproductcat T)) (λ xyz, ass (pr11 xyz) (pr21 xyz) (pr2 xyz))) : associator_nat_leftrightwhisker ass. Proof. intros x y1 y2 z g. set (t := ! assnattrans _ _ ((id x #, g) #, id z)). simpl in t. refine (_ @ t @ _). { etrans. 2: { do 2 apply maponpaths ; apply (! when_bifunctor_becomes_rightwhiskering _ _ _). } apply maponpaths. apply (! when_bifunctor_becomes_leftwhiskering _ _ _). } etrans. { do 2 apply maponpaths_2 ; apply when_bifunctor_becomes_leftwhiskering. } apply maponpaths_2. apply when_bifunctor_becomes_rightwhiskering. Qed. Definition associators_equiv {C : category} (T : bifunctor C C C) : associator0 T ≃ associator (bifunctor_to_functorfromproductcat T). Proof. use weqtotal2. { use weqtotal2. - use weq_iso. { exact (λ ass xyz, ass (pr11 xyz) (pr21 xyz) (pr2 xyz)). } { exact (λ nt x y z, nt ((x,,y),,z)). } { intro ; apply idpath. } intro ; apply idpath. - intro ass. use weq_iso. + intro assnat. (* show we get natural transformation *) do 3 intro. cbn. unfold functoronmorphisms1. cbn. rewrite !assoc. rewrite (pr12 assnat). rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite (bifunctor_leftcomp T). rewrite !assoc. rewrite (pr22 assnat). apply idpath. } etrans. { apply cancel_precomposition. rewrite assoc'. apply cancel_precomposition. apply (pr1 assnat). } rewrite !assoc. apply cancel_postcomposition. apply pathsinv0. rewrite (bifunctor_rightcomp T). apply idpath. + abstract exact (λ assnattrans, (nat_trans_associator_leftwhisker assnattrans) ,, (nat_trans_associator_rightwhisker assnattrans) ,, (nat_trans_associator_leftrightwhisker assnattrans) ). + intro ; repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply homset_property. + intro. repeat (apply impred_isaprop ; intro) ; apply homset_property. } intro ass. refine (weqtotaltoforall (X := precategory_binproduct_data (precategory_binproduct_data C C) C) _ _ ∘ _)%weq. use weqtotal2. { use weq_iso. { exact (λ assinv xyz, assinv (pr11 xyz) (pr21 xyz) (pr2 xyz)). } { exact (λ assinv x y z, assinv ((x,,y),,z)). } { intro ; apply idpath. } { intro ; apply idpath. } } intro assinv. apply weqimplimpl. - intros isolaw xyz. apply isolaw. - intros isolaw x y z. apply (isolaw ((x,,y),,z)). - repeat (apply impred_isaprop ; intro) ; apply isaprop_is_inverse_in_precat. - repeat (apply impred_isaprop ; intro) ; apply isaprop_is_inverse_in_precat. Defined. Definition moncats0_equiv_uncurried : moncats0 ≃ monoidal_cat. Proof. apply weqfibtototal. intro C. use weqtotal2. { apply bifunctor_equiv_functorfromproductcat. } intro T. use weqtotal2. { apply idweq. } intro I. use weqtotal2. { apply lunitors_equiv. } intro lu. use weqtotal2. { apply runitors_equiv. } intro ru. use weqtotal2. { apply associators_equiv. } intro ass. apply weqdirprodf ; apply weqimplimpl. { intros ti x y. etrans. { apply when_bifunctor_becomes_rightwhiskering. } etrans. 2: { apply maponpaths ; apply (! when_bifunctor_becomes_leftwhiskering _ _ _). } apply (! ti x y). } { intros ti x y. refine (_ @ ! ti x y @ _). - apply maponpaths. apply (! when_bifunctor_becomes_leftwhiskering _ _ _). - apply when_bifunctor_becomes_rightwhiskering. } { repeat (apply impred_isaprop ; intro) ; apply homset_property. } { repeat (apply impred_isaprop ; intro) ; apply homset_property. } { intros pi w x y z. refine (! pi w x y z @ _). etrans. 2: { do 2 apply maponpaths_2 ; apply (! when_bifunctor_becomes_rightwhiskering _ _ _). } apply maponpaths. apply (! when_bifunctor_becomes_leftwhiskering _ _ _). } { intros pi w x y z. refine (_ @ ! pi w x y z). simpl. etrans. 2: { do 2 apply maponpaths_2 ; apply (! when_bifunctor_becomes_rightwhiskering _ _ _). } apply maponpaths. apply (! when_bifunctor_becomes_leftwhiskering _ _ _). } { repeat (apply impred_isaprop ; intro) ; apply homset_property. } repeat (apply impred_isaprop ; intro) ; apply homset_property. Defined. End EquivalenceMonoidalCategoriesReordered0WithUncurried. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalCategoriesCurried.v000066400000000000000000000230461451125700300333220ustar00rootroot00000000000000(* In this file we formalize the definition of a monoidal category in a curried format. The data of a monoidal category consist of: - Category C. - A functor T : C x C → C, called the tensor which is specified as followed: - On the objects: A function Ob(C) → (Ob(C) → Ob(C)) : x → (y → x ⊗_{T} y) - On the morphisms: A function C[x,x'] → ( C[y,y'] -> C[ x ⊗_{T} y, x' ⊗_{T} y']) : f→ (g→ f ⊗^{T} g) - An object I : C, called the unit. - A natural transformation lu : I ⊗_T (-) → (-) with naturality condition lu_y ∘ (Id_I ⊗^{T} f) = f ∘ lu_x. - A natural transformation ru : (-) ⊗_T I → (-) with naturality condition ru_y ∘ (f ⊗^{T} Id_I) = f ∘ ru_x. - A natural transformation α : ((-)⊗_T(-))⊗_T(-) → (-)⊗((-)⊗(-)) with naturality condition f⊗(g⊗h) ∘ α_{x,y,z} = α_{x',y',z'} ∘ (f⊗g)⊗h. The properties of a monoidal category are the following: - Triangle identity: (Id_x ⊗ lu_y) ∘ α_{x,I,y} = ru_x ⊗^{T} Id_y. - Pentagon identity: (Id_w ⊗ α_{x,y,z}) ∘ α_{w,x⊗y,z} ∘ (α_{w,x,y} ⊗ Id_z) = α_{w,x,y⊗z} ∘ α_{w⊗x,y,z}. *) Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. (** Data **) Definition tensor_data (C : category) : UU := ∑ to : C -> C -> C, ∏ (x y x' y' : C), C ⟦x,x'⟧ → C ⟦y,y'⟧ -> C ⟦(to x y),(to x' y')⟧. Definition tensoronobjects_from_tensordata {C : category} (T : tensor_data C) : C->C->C := pr1 T. Notation "x ⊗_{ T } y" := (tensoronobjects_from_tensordata T x y) (at level 31). Definition tensoronmorphisms_from_tensordata {C : category} (T : tensor_data C): ∏ (x y x' y' : C), C ⟦x,x'⟧ → C ⟦y,y'⟧ -> C ⟦x ⊗_{T} y,x' ⊗_{T} y'⟧ := pr2 T. Notation "f ⊗^{ T } g" := (tensoronmorphisms_from_tensordata T _ _ _ _ f g) (at level 31). Definition associator_data {C : category} (T : tensor_data C) : UU := ∏ (x y z : C), C ⟦(x ⊗_{T} y) ⊗_{T} z, x ⊗_{T} (y ⊗_{T} z)⟧. Definition leftunitor_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C ⟦I ⊗_{T} x, x⟧. Definition rightunitor_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C ⟦x ⊗_{T} I, x⟧. Definition monoidalcategory_data (C : category): UU := ∑ T : tensor_data C, ∑ I : C, (leftunitor_data T I) × (rightunitor_data T I) × (associator_data T). Definition tensordata_from_monoidalcatdata {C : category} (MD : monoidalcategory_data C) : tensor_data C := (pr1 MD). Coercion tensordata_from_monoidalcatdata : monoidalcategory_data >-> tensor_data. Definition unit_from_monoidalcatdata {C : category} (MD : monoidalcategory_data C) : C := (pr1 (pr2 MD)). Coercion unit_from_monoidalcatdata : monoidalcategory_data >-> ob. Definition leftunitordata_from_monoidalcatdata {C : category} (MD : monoidalcategory_data C) : leftunitor_data MD MD := (pr1 (pr2 (pr2 MD))). Coercion leftunitordata_from_monoidalcatdata : monoidalcategory_data >-> leftunitor_data. Definition rightunitordata_from_monoidalcatdata {C : category} (MD : monoidalcategory_data C) : rightunitor_data MD MD := (pr1 (pr2 (pr2 (pr2 MD)))). Coercion rightunitordata_from_monoidalcatdata : monoidalcategory_data >-> rightunitor_data. Definition associatordata_from_monoidalcatdata {C : category} (MD : monoidalcategory_data C) : associator_data MD := (pr2 (pr2 (pr2 (pr2 MD)))). Coercion associatordata_from_monoidalcatdata : monoidalcategory_data >-> associator_data. (** Axioms **) Definition tensorfunctor_id {C : category} (T : tensor_data C) : UU := ∏ (x y : C), (identity x) ⊗^{T} identity y = identity (x ⊗_{T} y). Definition tensorfunctor_comp {C : category} (T : tensor_data C) : UU := ∏ (x y x' y' x'' y'' : C), ∏ (f : C ⟦x,x'⟧) (f' : C ⟦x',x''⟧) (g : C ⟦y,y'⟧) (g' : C ⟦y',y''⟧), (f' ⊗^{T} g') ∘ (f ⊗^{T} g) = (f'∘f) ⊗^{T} (g'∘g). Definition associator_naturality {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (x x' y y' z z' : C), ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧), (f ⊗^{T} (g ⊗^{T} h))∘(α x y z) = (α x' y' z')∘ ((f ⊗^{T} g) ⊗^{T} h). Definition associator_is_natiso {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (x y z : C), is_z_isomorphism (α x y z). Definition leftunitor_naturality {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), f∘(lu x) = (lu y)∘((identity I)⊗^{T}f). Definition leftunitor_is_natiso {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) : UU := ∏ (x : C), is_z_isomorphism (lu x). Definition rightunitor_naturality {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), f∘(ru x) = (ru y)∘ (f ⊗^{T} (identity I)). Definition rightunitor_is_natiso {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) : UU := ∏ (x : C), is_z_isomorphism (ru x). Definition triangle_identity {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (ru : rightunitor_data T I) (α : associator_data T) := ∏ (x y : C), (((identity x) ⊗^{T} (lu y) ) ∘ (α x I y)) = ((ru x) ⊗^{T} identity y). Definition pentagon_identity {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (w x y z : C), ((identity w)⊗^{T} (α x y z)) ∘ ((α w (x⊗_{T} y) z) ∘ ((α w x y) ⊗^{T} (identity z))) = (α w x (y⊗_{T} z)) ∘ (α (w⊗_{T}x) y z). Definition monoidal_laws {C : category} (MD : monoidalcategory_data C) : UU := (tensorfunctor_id MD) × (tensorfunctor_comp MD) × (associator_naturality MD) × (associator_is_natiso MD) × (leftunitor_naturality MD) × (leftunitor_is_natiso MD) × (rightunitor_naturality MD) × (rightunitor_is_natiso MD) × (triangle_identity MD MD MD) × (pentagon_identity MD). Definition tensorfunctorialityid_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : tensorfunctor_id MD := pr1 ML. Coercion tensorfunctorialityid_from_monoidallaws : monoidal_laws >-> tensorfunctor_id. Definition tensorfunctorialitycomp_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : tensorfunctor_comp MD := pr1 (pr2 ML). Coercion tensorfunctorialitycomp_from_monoidallaws : monoidal_laws >-> tensorfunctor_comp. Definition associatornaturality_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : associator_naturality MD := pr1 (pr2 (pr2 ML)). Coercion associatornaturality_from_monoidallaws : monoidal_laws >-> associator_naturality. Definition associatorisiso_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : associator_is_natiso MD := pr1 (pr2 (pr2 (pr2 ML))). Coercion associatorisiso_from_monoidallaws : monoidal_laws >-> associator_is_natiso. Definition leftunitornaturality_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : leftunitor_naturality MD := pr1 (pr2 (pr2 (pr2 (pr2 ML)))). Coercion leftunitornaturality_from_monoidallaws : monoidal_laws >-> leftunitor_naturality. Definition leftunitorisiso_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : leftunitor_is_natiso MD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 ML))))). Coercion leftunitorisiso_from_monoidallaws : monoidal_laws >-> leftunitor_is_natiso. Definition rightunitornaturality_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : rightunitor_naturality MD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 ML)))))). Coercion rightunitornaturality_from_monoidallaws : monoidal_laws >-> rightunitor_naturality. Definition rightunitorisiso_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : rightunitor_is_natiso MD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 ML))))))). Coercion rightunitorisiso_from_monoidallaws : monoidal_laws >-> rightunitor_is_natiso. Definition triangleidentity_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : triangle_identity MD MD MD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 ML)))))))). Coercion triangleidentity_from_monoidallaws : monoidal_laws >-> triangle_identity. Definition pentagonidentity_from_monoidallaws {C : category} {MD : monoidalcategory_data C} (ML : monoidal_laws MD) : pentagon_identity MD := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 ML)))))))). Coercion pentagonidentity_from_monoidallaws : monoidal_laws >-> pentagon_identity. Definition monoidalcategory (C : category) : UU := ∑ (MD : monoidalcategory_data C), (monoidal_laws MD). Definition monoidalcategorydata_from_monoidalcategory {C : category} (M : monoidalcategory C) : monoidalcategory_data C := pr1 M. Coercion monoidalcategorydata_from_monoidalcategory : monoidalcategory >-> monoidalcategory_data. Definition monoidallaws_from_monoidalcategory {C : category} (M : monoidalcategory C) : monoidal_laws M := pr2 M. Coercion monoidallaws_from_monoidalcategory : monoidalcategory >-> monoidal_laws. MonoidalCategoriesReordered.v000066400000000000000000000304701451125700300335600ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitionsRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Section MonoidalStructReordered. Definition tensor_unit (C : category) : UU := bifunctor C C C × C. Definition tensor_unit_to_tensor {C : category} (tu : tensor_unit C) : bifunctor C C C := pr1 tu. Coercion tensor_unit_to_tensor : tensor_unit >-> bifunctor. Definition tensor_unit_to_unit {C : category} (tu : tensor_unit C) : ob C := pr2 tu. Coercion tensor_unit_to_unit : tensor_unit >-> ob. (* Unitors and associators *) Definition laxleftunitor {C : category} (tu : tensor_unit C) : UU := ∑ lu : leftunitor_data tu tu, leftunitor_nat lu. Definition laxleftunitor_to_lunitor_data {C : category} {tu : tensor_unit C} (lu : laxleftunitor tu) : leftunitor_data tu tu := pr1 lu. Coercion laxleftunitor_to_lunitor_data : laxleftunitor >-> leftunitor_data. Definition laxleftunitor_to_lunitor_nat {C : category} {tu : tensor_unit C} (lu : laxleftunitor tu) : leftunitor_nat lu := pr2 lu. Definition laxrightunitor {C : category} (tu : tensor_unit C) : UU := ∑ ru : rightunitor_data tu tu, rightunitor_nat ru. Definition laxrightunitor_to_runitor_data {C : category} {tu : tensor_unit C} (ru : laxrightunitor tu) : rightunitor_data tu tu := pr1 ru. Coercion laxrightunitor_to_runitor_data : laxrightunitor >-> rightunitor_data. Definition laxrightunitor_to_runitor_nat {C : category} {tu : tensor_unit C} (ru : laxrightunitor tu) : rightunitor_nat ru := pr2 ru. Definition laxassociator {C : category} (tu : tensor_unit C) : UU := ∑ α : associator_data tu, (associator_nat_leftwhisker α) × (associator_nat_rightwhisker α) × (associator_nat_leftrightwhisker α). Definition laxassociator_to_associator_data {C : category} {tu : tensor_unit C} (α : laxassociator tu) : associator_data tu := pr1 α. Coercion laxassociator_to_associator_data : laxassociator >-> associator_data. Definition laxassociator_to_associator_nat_left {C : category} {tu : tensor_unit C} (α : laxassociator tu) : associator_nat_leftwhisker α := pr12 α. Definition laxassociator_to_associator_nat_right {C : category} {tu : tensor_unit C} (α : laxassociator tu) : associator_nat_rightwhisker α := pr122 α. Definition laxassociator_to_associator_nat_leftright {C : category} {tu : tensor_unit C} (α : laxassociator tu) : associator_nat_leftrightwhisker α := pr222 α. Definition tensor_unit_unitors_associator (C : category) : UU := ∑ tu : tensor_unit C, laxleftunitor tu × laxrightunitor tu × laxassociator tu. Definition tensor_unit_unitors_associator_to_tensor_unit {C : category} (tuua : tensor_unit_unitors_associator C) : tensor_unit C := pr1 tuua. Coercion tensor_unit_unitors_associator_to_tensor_unit : tensor_unit_unitors_associator >-> tensor_unit. Definition tensor_unit_unitors_associator_laxleftunitor {C : category} (tuua : tensor_unit_unitors_associator C) : laxleftunitor tuua := pr12 tuua. Definition tensor_unit_unitors_associator_laxrightunitor {C : category} (tuua : tensor_unit_unitors_associator C) : laxrightunitor tuua := pr122 tuua. Definition tensor_unit_unitors_associator_laxassociator {C : category} (tuua : tensor_unit_unitors_associator C) : laxassociator tuua := pr222 tuua. (* Triangle-pentagon identities and inverses *) Definition lax_monoidal_leftunitor_inverse {C : category} (M : tensor_unit_unitors_associator C) : UU := ∑ lui : leftunitorinv_data M M, leftunitor_iso_law (tensor_unit_unitors_associator_laxleftunitor M) lui. Definition lax_monoidal_leftunitor_inverse_to_inverse_data {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_leftunitor_inverse M) : leftunitorinv_data M M := pr1 lui. Coercion lax_monoidal_leftunitor_inverse_to_inverse_data : lax_monoidal_leftunitor_inverse >-> leftunitorinv_data. Definition lax_monoidal_leftunitor_inverse_to_inverse_law {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_leftunitor_inverse M) : leftunitor_iso_law (tensor_unit_unitors_associator_laxleftunitor M) lui := pr2 lui. Definition lax_monoidal_rightunitor_inverse {C : category} (M : tensor_unit_unitors_associator C) : UU := ∑ lui : rightunitorinv_data M M, rightunitor_iso_law (tensor_unit_unitors_associator_laxrightunitor M) lui. Definition lax_monoidal_rightunitor_inverse_to_inverse_data {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_rightunitor_inverse M) : rightunitorinv_data M M := pr1 lui. Coercion lax_monoidal_rightunitor_inverse_to_inverse_data : lax_monoidal_rightunitor_inverse >-> rightunitorinv_data. Definition lax_monoidal_rightunitor_inverse_to_inverse_law {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_rightunitor_inverse M) : rightunitor_iso_law (tensor_unit_unitors_associator_laxrightunitor M) lui := pr2 lui. Definition lax_monoidal_associator_inverse {C : category} (M : tensor_unit_unitors_associator C) : UU := ∑ lui : associatorinv_data M, associator_iso_law (tensor_unit_unitors_associator_laxassociator M) lui. Definition lax_monoidal_associator_inverse_to_inverse_data {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_associator_inverse M) : associatorinv_data M := pr1 lui. Coercion lax_monoidal_associator_inverse_to_inverse_data : lax_monoidal_associator_inverse >-> associatorinv_data. Definition lax_monoidal_associator_inverse_to_inverse_law {C : category} {M : tensor_unit_unitors_associator C} (lui : lax_monoidal_associator_inverse M) : associator_iso_law (tensor_unit_unitors_associator_laxassociator M) lui := pr2 lui. Definition unitorsassociator_inverses {C : category} (tuua : tensor_unit_unitors_associator C) : UU := lax_monoidal_leftunitor_inverse tuua × lax_monoidal_rightunitor_inverse tuua × lax_monoidal_associator_inverse tuua. Definition unitorsassociator_inverses_to_leftunitorinverse {C : category} {tuua : tensor_unit_unitors_associator C} (ui : unitorsassociator_inverses tuua) : lax_monoidal_leftunitor_inverse tuua := pr1 ui. Definition unitorsassociator_inverses_to_rightunitorinverse {C : category} {tuua : tensor_unit_unitors_associator C} (ui : unitorsassociator_inverses tuua) : lax_monoidal_rightunitor_inverse tuua := pr12 ui. Definition unitorsassociator_inverses_to_associatorinverse {C : category} {tuua : tensor_unit_unitors_associator C} (ui : unitorsassociator_inverses tuua) : lax_monoidal_associator_inverse tuua := pr22 ui. Definition pentagontriangle {C : category} (tuua : tensor_unit_unitors_associator C) : UU := triangle_identity (tensor_unit_unitors_associator_laxleftunitor tuua) (tensor_unit_unitors_associator_laxrightunitor tuua) (tensor_unit_unitors_associator_laxassociator tuua) × pentagon_identity (tensor_unit_unitors_associator_laxassociator tuua). Definition pentagontriangle_to_triangle {C : category} {tuua : tensor_unit_unitors_associator C} (pt : pentagontriangle tuua) : triangle_identity (tensor_unit_unitors_associator_laxleftunitor tuua) (tensor_unit_unitors_associator_laxrightunitor tuua) (tensor_unit_unitors_associator_laxassociator tuua) := pr1 pt. Definition pentagontriangle_to_pentagon {C : category} {tuua : tensor_unit_unitors_associator C} (pt : pentagontriangle tuua) : pentagon_identity (tensor_unit_unitors_associator_laxassociator tuua) := pr2 pt. Definition monoidal_struct (C : category) : UU := ∑ M : tensor_unit_unitors_associator C, pentagontriangle M × unitorsassociator_inverses M. Definition monoidal_struct_to_tensor_unit_unitors_associator {C : category} (M : monoidal_struct C) : tensor_unit_unitors_associator C := pr1 M. Coercion monoidal_struct_to_tensor_unit_unitors_associator : monoidal_struct >-> tensor_unit_unitors_associator. Definition monoidal_struct_to_pentagontriangle {C : category} (M : monoidal_struct C) : pentagontriangle M := pr12 M. Definition monoidal_struct_to_unitorsassociator_inverses {C : category} (M : monoidal_struct C) : unitorsassociator_inverses M := pr22 M. End MonoidalStructReordered. Section ReorderingMonStructEquivalence. Definition monoidal_to_tensor_unit {C : category} (M : monoidal C) : tensor_unit C := monoidal_tensor M ,, monoidal_unit M. Definition monoidal_to_tensor_unit_unitors_associator {C : category} (M : monoidal C) : tensor_unit_unitors_associator C. Proof. exists (monoidal_to_tensor_unit M). repeat split. - exists (monoidal_leftunitordata M). exact (monoidal_leftunitornat M). - exists (monoidal_rightunitordata M). exact (monoidal_rightunitornat M). - exists (monoidal_associatordata M). exists (monoidal_associatornatleft M). exists (monoidal_associatornatright M). exact (monoidal_associatornatleftright M). Defined. Definition monoidal_to_monoidal_struct {C : category} (M : monoidal C) : monoidal_struct C. Proof. exists (monoidal_to_tensor_unit_unitors_associator M). repeat split. - exact (monoidal_triangleidentity M). - exact (monoidal_pentagonidentity M). - exists (monoidal_leftunitorinvdata M). exact (monoidal_leftunitorisolaw M). - exists (monoidal_rightunitorinvdata M). exact (monoidal_rightunitorisolaw M). - exists (monoidal_associatorinvdata M). exact (monoidal_associatorisolaw M). Defined. Definition monoidal_struct_to_monoidal_data {C : category} (M : monoidal_struct C) : monoidal_data C. Proof. set (tuua := monoidal_struct_to_tensor_unit_unitors_associator M). set (tu := tensor_unit_unitors_associator_to_tensor_unit tuua). set (ui := (monoidal_struct_to_unitorsassociator_inverses M)). exists (tensor_unit_to_tensor tu). exists (tensor_unit_to_unit tu). exists (tensor_unit_unitors_associator_laxleftunitor tuua). exists (unitorsassociator_inverses_to_leftunitorinverse ui). exists (pr1 (tensor_unit_unitors_associator_laxrightunitor tuua)). exists (unitorsassociator_inverses_to_rightunitorinverse ui). exists (tensor_unit_unitors_associator_laxassociator tuua). exact (unitorsassociator_inverses_to_associatorinverse ui). Defined. Definition monoidal_struct_to_monoidal_laws {C : category} (M : monoidal_struct C) : monoidal_laws (monoidal_struct_to_monoidal_data M). Proof. set (tuua := monoidal_struct_to_tensor_unit_unitors_associator M). set (tu := tensor_unit_unitors_associator_to_tensor_unit tuua). set (ui := (monoidal_struct_to_unitorsassociator_inverses M)). exists (pr2 (pr111 M)). exists (laxleftunitor_to_lunitor_nat _ ,, lax_monoidal_leftunitor_inverse_to_inverse_law _). exists (laxrightunitor_to_runitor_nat _ ,, lax_monoidal_rightunitor_inverse_to_inverse_law _). split. - exists (laxassociator_to_associator_nat_left _). exists (laxassociator_to_associator_nat_right _). exists (laxassociator_to_associator_nat_leftright _). do 3 intro ; apply lax_monoidal_associator_inverse_to_inverse_law. - apply monoidal_struct_to_pentagontriangle. Defined. Definition monoidal_struct_to_monoidal {C : category} (M : monoidal_struct C) : monoidal C := monoidal_struct_to_monoidal_data M ,, monoidal_struct_to_monoidal_laws M. Definition monoidal_struct_equiv_monoidal (C : category) : monoidal_struct C ≃ monoidal C. Proof. use weq_iso. - exact monoidal_struct_to_monoidal. - exact monoidal_to_monoidal_struct. - apply idpath. - apply idpath. Defined. End ReorderingMonStructEquivalence. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalCategoriesTensored.v000066400000000000000000000435211451125700300335100ustar00rootroot00000000000000(** Monoidal categories Based on an implementation by Anthony Bordg. Behaviour w.r.t. to swapped tensor product added by Ralph Matthes in 2019 Isos replaced by z_isos in 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Notation "'id' X" := (identity X) (at level 30). Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Notation "( c , d )" := (make_catbinprod c d). Notation "( f #, g )" := (catbinprodmor f g). Section Monoidal_Precat. Context {C : category} (tensor : C ⊠ C ⟶ C) (I : C). Notation "X ⊗ Y" := (tensor (X, Y)). Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Lemma tensor_id {X Y : C} : id X #⊗ id Y = id (X ⊗ Y). Proof. apply (functor_id tensor). Qed. Lemma tensor_comp {X Y Z X' Y' Z' : C} (f : X --> Y) (g : Y --> Z) (f' : X' --> Y') (g' : Y' --> Z') : (f · g) #⊗ (f' · g') = f #⊗ f' · g #⊗ g'. Proof. rewrite binprod_comp. apply (functor_comp tensor). Qed. Definition is_z_iso_tensor_z_iso {X Y X' Y' : C} {f : X --> Y} {g : X' --> Y'} (f_is_z_iso : is_z_isomorphism f) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (f #⊗ g). Proof. exact (functor_on_is_z_isomorphism _ (is_z_iso_binprod_z_iso f_is_z_iso g_is_z_iso)). Defined. (* I ⊗ - *) Definition I_pretensor : C ⟶ C := functor_fix_fst_arg _ _ _ tensor I. Lemma I_pretensor_ok: functor_on_objects I_pretensor = λ c, I ⊗ c. Proof. apply idpath. Qed. (* λ *) Definition left_unitor : UU := nat_z_iso I_pretensor (functor_identity C). Definition left_unitor_funclass (λ' : left_unitor): ∏ x : ob C, I_pretensor x --> x := pr1 (nat_z_iso_to_trans λ'). Coercion left_unitor_funclass : left_unitor >-> Funclass. Definition left_unitor_to_nat_trans (λ' : left_unitor): nat_trans I_pretensor (functor_identity C) := nat_z_iso_to_trans λ'. Coercion left_unitor_to_nat_trans: left_unitor >-> nat_trans. (* - ⊗ I *) Definition I_posttensor : C ⟶ C := functor_fix_snd_arg _ _ _ tensor I. Lemma I_posttensor_ok: functor_on_objects I_posttensor = λ c, c ⊗ I. Proof. apply idpath. Qed. (* ρ *) Definition right_unitor : UU := nat_z_iso I_posttensor (functor_identity C). Definition right_unitor_funclass (ρ' : right_unitor): ∏ x : ob C, I_posttensor x --> x := pr1 (nat_z_iso_to_trans ρ'). Coercion right_unitor_funclass : right_unitor >-> Funclass. Definition right_unitor_to_nat_trans (ρ' : right_unitor): nat_trans I_posttensor (functor_identity C) := nat_z_iso_to_trans ρ'. Coercion right_unitor_to_nat_trans: right_unitor >-> nat_trans. (* (- ⊗ =) ⊗ ≡ *) Definition assoc_left : (C ⊠ C) ⊠ C ⟶ C := functor_composite (pair_functor tensor (functor_identity _)) tensor. Lemma assoc_left_ok: functor_on_objects assoc_left = λ c, (ob1 (ob1 c) ⊗ ob2 (ob1 c)) ⊗ ob2 c. Proof. apply idpath. Qed. (* - ⊗ (= ⊗ ≡) *) Definition assoc_right : (C ⊠ C) ⊠ C ⟶ C := functor_composite (precategory_binproduct_unassoc _ _ _) (functor_composite (pair_functor (functor_identity _) tensor) tensor). Lemma assoc_right_ok: functor_on_objects assoc_right = λ c, ob1 (ob1 c) ⊗ (ob2 (ob1 c) ⊗ ob2 c). Proof. apply idpath. Qed. (* α *) Definition associator : UU := nat_z_iso assoc_left assoc_right. (* This definition goes in the opposite direction of that by Mac Lane (CWM 2nd ed., p.162) but conforms to the def. on Wikipedia. *) Definition associator_funclass (α' : associator): ∏ x : ob ((C ⊠ C) ⊠ C), assoc_left x --> assoc_right x := pr1 (nat_z_iso_to_trans α'). Coercion associator_funclass : associator >-> Funclass. Definition associator_to_nat_trans (α' : associator): nat_trans assoc_left assoc_right := nat_z_iso_to_trans α'. Coercion associator_to_nat_trans: associator >-> nat_trans. Definition triangle_eq (λ' : left_unitor) (ρ' : right_unitor) (α' : associator) : UU := ∏ (a b : C), pr1 ρ' a #⊗ id b = pr1 α' ((a, I), b) · id a #⊗ pr1 λ' b. Definition pentagon_eq (α' : associator) : UU := ∏ (a b c d : C), pr1 α' ((a ⊗ b, c), d) · pr1 α' ((a, b), c ⊗ d) = pr1 α' ((a, b), c) #⊗ id d · pr1 α' ((a, b ⊗ c), d) · id a #⊗ pr1 α' ((b, c), d). Definition is_strict (eq_λ : I_pretensor = functor_identity C) (λ' : left_unitor) (eq_ρ : I_posttensor = functor_identity C) (ρ' : right_unitor) (eq_α : assoc_left = assoc_right) (α' : associator) : UU := (is_nat_z_iso_id eq_λ λ') × (is_nat_z_iso_id eq_ρ ρ') × (is_nat_z_iso_id eq_α α'). End Monoidal_Precat. Definition monoidal_cat : UU := ∑ C : category, ∑ tensor : C ⊠ C ⟶ C, ∑ I : C, ∑ λ' : left_unitor tensor I, ∑ ρ' : right_unitor tensor I, ∑ α' : associator tensor, (triangle_eq tensor I λ' ρ' α') × (pentagon_eq tensor α'). (* Definition monoidal_precat_struct : UU := ∑ C : precategory, ∑ tensor : C ⊠ C ⟶ C, ∑ I : C, ∑ λ' : left_unitor tensor I, ∑ ρ' : right_unitor tensor I, ∑ α' : associator tensor, unit. Definition make_monoidal_precat_struct (C: precategory)(tensor: C ⊠ C ⟶ C)(I: C) (λ': left_unitor tensor I)(ρ': right_unitor tensor I)(α': associator tensor): monoidal_precat_struct := (C,, (tensor,, (I,, (λ',, (ρ',, (α',, tt)))))). *) Definition make_monoidal_cat (C: category)(tensor: C ⊠ C ⟶ C)(I: C) (λ': left_unitor tensor I)(ρ': right_unitor tensor I)(α': associator tensor) (eq1: triangle_eq tensor I λ' ρ' α')(eq2: pentagon_eq tensor α'): monoidal_cat := (C,, (tensor,, (I,, (λ',, (ρ',, (α',, (eq1,, eq2))))))). Definition monoidal_cat_cat (M : monoidal_cat) : category := pr1 M. Coercion monoidal_cat_cat : monoidal_cat >-> category. Section Monoidal_Cat_Accessors. Context (M : monoidal_cat). (** it is important that no new coercions are used in the given types in the following projections *) Definition monoidal_cat_tensor : pr1 M ⊠ pr1 M ⟶ pr1 M := pr1 (pr2 M). Definition monoidal_cat_unit : pr1 M := pr1 (pr2 (pr2 M)). Definition monoidal_cat_left_unitor : left_unitor (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) := pr1 (pr2 (pr2 (pr2 M))). Definition monoidal_cat_right_unitor : right_unitor (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) := pr1 (pr2 (pr2 (pr2 (pr2 M)))). Definition monoidal_cat_associator : associator (pr1 (pr2 M)) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M))))). Definition monoidal_cat_triangle_eq : triangle_eq (pr1 (pr2 M)) (pr1 (pr2 (pr2 M))) (pr1 (pr2 (pr2 (pr2 M)))) (pr1 (pr2 (pr2 (pr2 (pr2 M))))) (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))) := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))). Definition monoidal_cat_pentagon_eq : pentagon_eq (pr1 (pr2 M)) (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))) := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 M)))))). End Monoidal_Cat_Accessors. Definition strict_monoidal_cat : UU := ∑ M : monoidal_cat, ∏ (eq_λ : I_pretensor (monoidal_cat_tensor M) (monoidal_cat_unit M) = functor_identity (pr1 M)), ∏ (eq_ρ : I_posttensor (monoidal_cat_tensor M) (monoidal_cat_unit M) = functor_identity (pr1 M)), ∏ (eq_α : assoc_left (monoidal_cat_tensor M) = assoc_right (monoidal_cat_tensor M)), is_strict (monoidal_cat_tensor M) (monoidal_cat_unit M) eq_λ (monoidal_cat_left_unitor M) eq_ρ (monoidal_cat_right_unitor M) eq_α (monoidal_cat_associator M). Section swapped_tensor. Context (M : monoidal_cat). Definition swapping_of_tensor: M ⊠ M ⟶ M := functor_composite binswap_pair_functor (monoidal_cat_tensor M). Definition associator_swapping_of_tensor: associator swapping_of_tensor. Proof. set (α := monoidal_cat_associator M). set (α' := nat_z_iso_to_trans_inv α). red. set (trafo := (pre_whisker reverse_three_args α'): (assoc_left swapping_of_tensor) ⟹ (assoc_right swapping_of_tensor)). assert (tisziso: is_nat_z_iso trafo). { red. intro c. set (aux := pr2 (nat_z_iso_inv α)). apply (pre_whisker_on_nat_z_iso reverse_three_args α' aux). } exact (trafo,, tisziso). Defined. Lemma triangle_eq_swapping_of_tensor: triangle_eq swapping_of_tensor (monoidal_cat_unit M) (monoidal_cat_right_unitor M) (monoidal_cat_left_unitor M) associator_swapping_of_tensor. Proof. red. intros a b. cbn. set (H := monoidal_cat_triangle_eq M). unfold triangle_eq in H. etrans. 2: { apply cancel_precomposition. apply pathsinv0. apply H. } clear H. rewrite assoc. etrans. { apply pathsinv0. apply id_left. } apply cancel_postcomposition. apply pathsinv0. set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M)((b, monoidal_cat_unit M), a)). apply (z_iso_after_z_iso_inv f). Qed. Lemma pentagon_eq_swapping_of_tensor: pentagon_eq swapping_of_tensor associator_swapping_of_tensor. Proof. red. intros a b c d. cbn. set (H := monoidal_cat_pentagon_eq M). unfold pentagon_eq in H. set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, c), monoidal_cat_tensor M (b, a))). apply (z_iso_inv_on_right _ _ _ f). apply pathsinv0. set (f' := nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((monoidal_cat_tensor M (d, c), b), a)). apply (inv_z_iso_unique' _ _ _ f'). unfold precomp_with. rewrite assoc. etrans. { apply cancel_postcomposition. apply H. } clear H. repeat rewrite assoc. etrans. { do 2 apply cancel_postcomposition. rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. apply (functor_comp (functor_fix_fst_arg _ _ _ (monoidal_cat_tensor M) d)). } etrans. { do 2 apply cancel_postcomposition. apply cancel_precomposition. apply maponpaths. apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((c, b), a))). } rewrite functor_id. rewrite id_right. etrans. { apply cancel_postcomposition. rewrite <- assoc. apply cancel_precomposition. apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, monoidal_cat_tensor M (c, b)), a))). } rewrite id_right. etrans. apply pathsinv0. apply (functor_comp (functor_fix_snd_arg _ _ _ (monoidal_cat_tensor M) a)). etrans. { apply maponpaths. apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (monoidal_cat_associator M) ((d, c), b))). } cbn. unfold functor_fix_snd_arg_mor. use functor_id. Qed. Definition swapping_of_monoidal_cat: monoidal_cat. Proof. use (make_monoidal_cat M swapping_of_tensor). - exact (monoidal_cat_unit M). - apply monoidal_cat_right_unitor. - apply monoidal_cat_left_unitor. - exact associator_swapping_of_tensor. - exact triangle_eq_swapping_of_tensor. - exact pentagon_eq_swapping_of_tensor. Defined. End swapped_tensor. Section coherence_lemmas. Context {Mon_V : monoidal_cat}. Let I : Mon_V := monoidal_cat_unit Mon_V. Let tensor : Mon_V ⊠ Mon_V ⟶ Mon_V := monoidal_cat_tensor Mon_V. Let α : associator tensor := monoidal_cat_associator Mon_V. Let l_unitor : left_unitor tensor I := monoidal_cat_left_unitor Mon_V. Let r_unitor : right_unitor tensor I := monoidal_cat_right_unitor Mon_V. Local Notation "X ⊗ Y" := (tensor (X, Y)). Local Notation "f #⊗ g" := (#tensor (f #, g)) (at level 31). Lemma tensor_comp_left {X Y Z W : Mon_V} (f : X --> Y) (g : Y --> Z) : ((f · g) #⊗ id W) = (f #⊗ id W) · (g #⊗ id W). Proof. rewrite <- (functor_comp tensor). change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). rewrite id_left. apply idpath. Defined. Lemma tensor_comp_right {X Y Z W : Mon_V} (f : X --> Y) (g : Y --> Z) : (id W #⊗ (f · g)) = (id W #⊗ f) · (id W #⊗ g). Proof. rewrite <- (functor_comp tensor). change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). rewrite id_left. apply idpath. Defined. Lemma I_posttensor_faithful {X Y : Mon_V} {f g : X --> Y} : (f #⊗ id I) = (g #⊗ id I) -> f = g. Proof. intro H. apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))). use (pathscomp0 (! (nat_trans_ax r_unitor _ _ f))). use (pathscomp0 _ (nat_trans_ax r_unitor _ _ g)). apply cancel_postcomposition. assumption. Defined. Lemma I_pretensor_faithful {X Y : Mon_V} {f g : X --> Y} : (id I #⊗ f) = (id I #⊗ g) -> f = g. Proof. intro H. apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _))). use (pathscomp0 (! (nat_trans_ax l_unitor _ _ f))). use (pathscomp0 _ (nat_trans_ax l_unitor _ _ g)). apply cancel_postcomposition. assumption. Defined. (* The following three lemmas are from [Kelly, 1964]. https://doi.org/10.1016/0021-8693(64)90018-3 monoidal_cat_triangle_eq <-> diagram (6) in [Kelly, 1964] monoidal_cat_pentagon_eq <-> diagram (1) right_unitor_of_tensor <-> diagram (7) left_unitor_right_unitor_of_unit <-> diagram (4) left_unitor_of_tensor <-> diagram (5) *) Lemma right_unitor_of_tensor (X Y : Mon_V) : r_unitor (X ⊗ Y) = α ((X, Y), I) · (id X #⊗ r_unitor Y). Proof. apply I_posttensor_faithful. rewrite tensor_comp_left. apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 α (_, _)))). rewrite assoc'. apply (transportb (λ h, _ = _ · h) (nat_trans_ax α _ _ ((_#, _)#, _))). simpl. rewrite assoc. apply (transportb (λ h, _ = _ · #tensor (id _ #, h)) (monoidal_cat_triangle_eq Mon_V _ _)). apply (transportf (λ k, _ = _ · #tensor (k #, _)) (id_left (id X))). change (?x · ?z #, ?y · ?w) with ((x #, y) · (z #, w)). rewrite (functor_comp tensor). apply (transportb (λ h, h · _ = _) (monoidal_cat_triangle_eq Mon_V _ _)). apply (transportf (λ h, _ · #tensor (h #, _) · _ = _) (functor_id tensor (X, Y))). rewrite assoc'. apply (transportb (λ h, _ · h = _) (nat_trans_ax α _ _ ((_#, _)#, _))). rewrite !assoc. apply cancel_postcomposition. apply monoidal_cat_pentagon_eq. Defined. Lemma left_unitor_right_unitor_of_unit : l_unitor I = r_unitor I. Proof. apply I_pretensor_faithful. apply (pre_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 α ((_, _), _)))). apply (pathscomp0 (! (monoidal_cat_triangle_eq Mon_V I I))). use (pathscomp0 _ (right_unitor_of_tensor I I)). apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))). apply (nat_trans_ax r_unitor). Defined. Lemma left_unitor_of_tensor (X Y : Mon_V) : α ((I, X), Y) · l_unitor (X ⊗ Y) = l_unitor X #⊗ id Y. Proof. apply I_pretensor_faithful. rewrite tensor_comp_right. apply (pre_comp_with_z_iso_is_inj (pr2 α ((I, (I ⊗ X)), Y))). use (pathscomp0 _ (nat_trans_ax α _ _ ((_ #, _) #, _))). simpl. apply (pre_comp_with_z_iso_is_inj (functor_on_is_z_isomorphism (functor_fix_snd_arg _ _ _ tensor Y) (pr2 α ((I, I), X)))). simpl. unfold functor_fix_snd_arg_mor. change (make_dirprod ?x ?y) with (x #, y). rewrite !assoc. apply (transportf (λ h, _ = h · _) (functor_comp tensor _ _)). change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w). apply (transportf (λ h, h · _ = _) (monoidal_cat_pentagon_eq Mon_V I I X Y)). rewrite assoc'. apply (transportf (λ h, _ · h = _) (monoidal_cat_triangle_eq Mon_V _ _)). simpl. apply (transportf (λ h, _ · #tensor (_ #, h) = _) (functor_id tensor (X, Y))). apply (pathscomp0 (! (nat_trans_ax α _ _ ((_ #, _) #, _)))). simpl. apply cancel_postcomposition. apply pathsinv0. apply maponpaths. apply dirprod_paths; simpl; [|apply id_left]. apply pathsinv0. apply monoidal_cat_triangle_eq. Defined. (* Corollaries for the inverses of left and right unitors. *) Lemma tensor_z_isomorphism_left : ∏ (x y z : Mon_V) (f : x --> y) (f_z_iso : is_z_isomorphism f), # tensor (is_z_isomorphism_mor f_z_iso #, id z) = is_z_isomorphism_mor (functor_on_is_z_isomorphism (functor_fix_snd_arg _ _ _ tensor z) f_z_iso). Proof. intros. reflexivity. Qed. Lemma tensor_z_isomorphism_right : ∏ (x y z : Mon_V) (f : x --> y) (f_z_iso : is_z_isomorphism f), # tensor (id z #, is_z_isomorphism_mor f_z_iso) = is_z_isomorphism_mor (functor_on_is_z_isomorphism (functor_fix_fst_arg _ _ _ tensor z) f_z_iso). Proof. intros. reflexivity. Qed. Lemma monoidal_cat_triangle_eq_inv (X Y : Mon_V) : (nat_z_iso_to_trans_inv r_unitor X #⊗ id Y) · α ((X, I), Y) = (id X #⊗ nat_z_iso_to_trans_inv l_unitor Y). Proof. cbn. rewrite (tensor_z_isomorphism_right _ _ _ _ _ : #tensor _ = _). rewrite (tensor_z_isomorphism_left _ _ _ _ _ : #tensor _ = _). change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)). apply z_iso_inv_on_right, z_iso_inv_on_left. apply monoidal_cat_triangle_eq. Qed. Corollary left_unitor_inv_right_unitor_inv_of_unit : nat_z_iso_to_trans_inv l_unitor I = nat_z_iso_to_trans_inv r_unitor _. Proof. apply (post_comp_with_z_iso_is_inj (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _))). apply (pathscomp0 (is_inverse_in_precat2 (is_z_isomorphism_is_inverse_in_precat (pr2 l_unitor _)))). apply (transportb (λ f, id _ = is_z_isomorphism_mor _ · f) left_unitor_right_unitor_of_unit). apply pathsinv0. apply (is_inverse_in_precat2 (is_z_isomorphism_is_inverse_in_precat (pr2 r_unitor _))). Qed. Corollary left_unitor_inv_of_tensor (X Y : Mon_V) : (nat_z_iso_to_trans_inv l_unitor _ #⊗ id _) · α ((_, _), _) = nat_z_iso_to_trans_inv l_unitor (X ⊗ Y). Proof. simpl. rewrite tensor_z_isomorphism_left. change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)). apply z_iso_inv_on_right, z_iso_inv_on_left. apply pathsinv0. apply left_unitor_of_tensor. Qed. Corollary right_unitor_inv_of_tensor (X Y : Mon_V) : (id _ #⊗ nat_z_iso_to_trans_inv r_unitor _) = nat_z_iso_to_trans_inv r_unitor (X ⊗ Y) · α ((_, _), _). Proof. simpl. rewrite tensor_z_isomorphism_right. change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)). apply pathsinv0. apply z_iso_inv_on_right, z_iso_inv_on_left. apply right_unitor_of_tensor. Qed. End coherence_lemmas. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorCategory.v000066400000000000000000001041231451125700300330310ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Local Open Scope cat. Local Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Local Notation "( c , d )" := (make_catbinprod c d). Local Notation "( f #, g )" := (catbinprodmor f g). Section TensorFunctorCategory. Context {C D : category} (TC : functor (C ⊠ C) C) (TD : functor (D ⊠ D) D). Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Definition functor_tensor_map_dom (F : functor C D) : functor (C ⊠ C) D := functor_composite (pair_functor F F) TD. Definition functor_tensor_map_codom (F : functor C D) : functor (C ⊠ C) D := functor_composite TC F. Definition functor_tensor (F : functor C D) : UU := nat_trans (functor_tensor_map_dom F) (functor_tensor_map_codom F). Identity Coercion functor_tensor_c : functor_tensor >-> nat_trans. Definition is_nat_trans_tensor {F G : functor C D} (FF : functor_tensor F) (GG : functor_tensor G) (α : nat_trans F G) : UU := ∏ x y : C, (α x #⊗_D α y) · GG (x, y) = FF (x, y) · α (x ⊗_C y). Lemma isaprop_is_nat_trans_tensor {F G : functor C D} (FF : functor_tensor F) (GG : functor_tensor G) (α : nat_trans F G) : isaprop (is_nat_trans_tensor FF GG α). Proof. do 2 (apply impred_isaprop ; intro) ; apply D. Qed. Lemma is_nat_trans_tensor_id {F : functor C D} (FF : functor_tensor F) : is_nat_trans_tensor FF FF (nat_trans_id F). Proof. intros x y. simpl. rewrite (functor_id TD). exact (id_left _ @ ! id_right _). Qed. Lemma is_nat_trans_tensor_comp {F G H : functor C D} (FF : functor_tensor F) (GG : functor_tensor G) (HH : functor_tensor H) {α : nat_trans F G} {β : nat_trans G H} (αα : is_nat_trans_tensor FF GG α) (ββ : is_nat_trans_tensor GG HH β) : is_nat_trans_tensor FF HH (nat_trans_comp _ _ _ α β). Proof. intros x y. simpl. etrans. { apply maponpaths_2. exact (functor_comp TD (α x #, α y) (β x #, β y)). } rewrite assoc'. etrans. { apply maponpaths. exact (ββ x y). } do 2 rewrite assoc. apply maponpaths_2. apply αα. Qed. Definition functor_tensor_disp_cat_ob_mor : disp_cat_ob_mor [C,D]. Proof. exists (λ F, functor_tensor F). exact (λ F G FF GG α, is_nat_trans_tensor FF GG α). Defined. Definition functor_tensor_disp_cat_id_comp : disp_cat_id_comp _ functor_tensor_disp_cat_ob_mor. Proof. split ; intro ; intros ; [apply is_nat_trans_tensor_id | use is_nat_trans_tensor_comp ; assumption ]. Qed. Definition functor_tensor_disp_cat_data : disp_cat_data [C,D] := _ ,, functor_tensor_disp_cat_id_comp. Definition functor_tensor_disp_cat_axioms : disp_cat_axioms _ functor_tensor_disp_cat_data. Proof. repeat split ; intro ; intros ; try (apply isaprop_is_nat_trans_tensor). use isasetaprop. apply isaprop_is_nat_trans_tensor. Qed. Definition functor_tensor_disp_cat : disp_cat [C,D] := _ ,, functor_tensor_disp_cat_axioms. Definition functor_tensor_cat : category := total_category functor_tensor_disp_cat. End TensorFunctorCategory. Section TensorFunctorCategoryUnivalence. Context {C D : category} (TC : functor (C ⊠ C) C) (TD : functor (D ⊠ D) D). Lemma isaset_functor_tensor_disp_cat (F : functor C D) : isaset (functor_tensor_disp_cat TC TD F). Proof. apply isaset_nat_trans. { apply D. } Qed. Lemma functor_tensor_disp_cat_is_univalent : is_univalent_disp (functor_tensor_disp_cat TC TD). Proof. apply is_univalent_disp_from_fibers. intros F pt1 pt2. use isweqimplimpl. - intro i. use total2_paths_f. + apply funextsec ; intro. set (ix := (pr1 i) (pr1 x) (pr2 x)). cbn in ix. rewrite binprod_id in ix. rewrite (functor_id TD) in ix. rewrite id_right in ix. rewrite id_left in ix. exact (! ix). + do 2 (apply funextsec ; intro). repeat (apply impred_isaprop ; intro). apply D. - apply isaset_functor_tensor_disp_cat. - apply isaproptotal2. + intro ; apply Isos.isaprop_is_z_iso_disp. + do 4 intro ; apply isaprop_is_nat_trans_tensor. Qed. End TensorFunctorCategoryUnivalence. Section TensorFunctorProperties. Lemma functor_tensor_composition_is_nat_trans {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {TE : functor (E ⊠ E) E} {F : functor C D} {G : functor D E} (FF : functor_tensor TC TD F) (GG : functor_tensor TD TE G) : is_nat_trans (functor_tensor_map_dom TE (F ∙ G)) (functor_tensor_map_codom TC (F ∙ G)) (λ cc : C × C, GG (F (pr1 cc), F (pr2 cc)) · # G (FF cc)). Proof. intros cc1 cc2 f. etrans. { rewrite assoc. apply maponpaths_2. exact (pr2 GG ((pair_functor F F) cc1) (pair_functor F F cc2) (# (pair_functor F F) f)). } etrans. 2: { rewrite assoc'. simpl. rewrite <- (functor_comp G). do 2 apply maponpaths. exact (pr2 FF cc1 cc2 f). } rewrite assoc'. apply maponpaths. apply (! functor_comp G _ _). Qed. Definition functor_tensor_composition {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {TE : functor (E ⊠ E) E} {F : functor C D} {G : functor D E} (FF : functor_tensor TC TD F) (GG : functor_tensor TD TE G) : functor_tensor TC TE (functor_composite F G). Proof. exists (λ cc, GG (F (pr1 cc) , F (pr2 cc)) · #G (FF cc)). apply functor_tensor_composition_is_nat_trans. Defined. (* A characterization of the tensor property of monoidal natural transformations in terms of equality/isos of functors/natural transformations. *) Context {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D}. Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Context {F G : functor C D} (FF : functor_tensor TC TD F) (GG : functor_tensor TC TD G) (α : nat_trans F G). Lemma nat_trans_tensor_ntrans1_is_nat_trans : is_nat_trans (functor_tensor_map_dom TD F) (functor_tensor_map_codom TC G) (λ cc : C × C, # TD (α (pr1 cc) #, α (pr2 cc)) · GG cc). Proof. intros cc1 cc2 ff. simpl. rewrite assoc. rewrite <- (functor_comp TD). rewrite <- binprod_comp. do 2 rewrite (pr2 α). rewrite binprod_comp. rewrite (functor_comp TD). do 2 rewrite assoc'. apply maponpaths. apply (pr2 GG). Qed. Definition nat_trans_tensor_ntrans1 : nat_trans (functor_tensor_map_dom TD F) (functor_tensor_map_codom TC G) := _ ,, nat_trans_tensor_ntrans1_is_nat_trans. Definition nat_trans_tensor_ntrans2_is_nat_trans : is_nat_trans (functor_tensor_map_dom TD F) (functor_tensor_map_codom TC G) (λ cc : C × C, FF cc · α (pr1 cc ⊗_C pr2 cc)). Proof. intros cc1 cc2 ff. simpl. set (t := pr2 FF cc1 cc2). simpl in t. rewrite assoc. rewrite t. do 2 rewrite assoc'. apply maponpaths. apply (pr2 α). Qed. Definition nat_trans_tensor_ntrans2 : nat_trans (functor_tensor_map_dom TD F) (functor_tensor_map_codom TC G) := _ ,, nat_trans_tensor_ntrans2_is_nat_trans. Definition is_nat_trans_tensor' : UU := nat_trans_tensor_ntrans1 = nat_trans_tensor_ntrans2. Lemma is_nat_trans_tensor_to_characterization (p : is_nat_trans_tensor') : is_nat_trans_tensor TC TD FF GG α. Proof. intros x y. exact (eqtohomot (base_paths _ _ p) (x,y)). Qed. Lemma is_nat_trans_tensor_from_characterization (p : is_nat_trans_tensor TC TD FF GG α) : is_nat_trans_tensor'. Proof. use nat_trans_eq. { apply D. } exact (λ cc, p (pr1 cc) (pr2 cc)). Qed. End TensorFunctorProperties. Section UnitFunctorCategory. Context {C D : category} (IC : C) (ID : D). Definition functor_unit (F : functor C D) : UU := D⟦ID, pr1 F IC⟧. Definition is_nat_trans_unit {F G : functor C D} (FF : functor_unit F) (GG : functor_unit G) (α : nat_trans F G) : UU := FF · α IC = GG. Definition functor_unit_disp_cat_ob_mor : disp_cat_ob_mor [C,D]. Proof. exists (λ F, functor_unit F). exact (λ F G FF GG α, is_nat_trans_unit FF GG α). Defined. Lemma is_nat_trans_unit_id {F : functor C D} (FF : functor_unit F) : is_nat_trans_unit FF FF (nat_trans_id F). Proof. apply id_right. Qed. Lemma is_nat_trans_unit_comp {F G H : functor C D} (FF : functor_unit F) (GG : functor_unit G) (HH : functor_unit H) {α : nat_trans F G} {β : nat_trans G H} (αα : is_nat_trans_unit FF GG α) (ββ : is_nat_trans_unit GG HH β) : is_nat_trans_unit FF HH (nat_trans_comp _ _ _ α β). Proof. etrans. { apply assoc. } etrans. { apply maponpaths_2 ; exact αα. } exact ββ. Qed. Definition functor_unit_disp_cat_id_comp : disp_cat_id_comp _ functor_unit_disp_cat_ob_mor. Proof. split ; intro ; intros ; [apply is_nat_trans_unit_id | use is_nat_trans_unit_comp ; assumption ]. Qed. Definition functor_unit_disp_cat_data : disp_cat_data [C,D] := _ ,, functor_unit_disp_cat_id_comp. Definition functor_unit_disp_cat_axioms : disp_cat_axioms _ functor_unit_disp_cat_data. Proof. repeat split ; intro ; intros ; try (apply D). use isasetaprop. apply D. Qed. Definition functor_unit_disp_cat : disp_cat [C,D] := _ ,, functor_unit_disp_cat_axioms. Definition functor_unit_cat : category := total_category functor_unit_disp_cat. End UnitFunctorCategory. Section UnitFunctorCategoryUnivalence. Context {C D : category} (IC : C) (ID : D). Lemma functor_unit_disp_cat_is_univalent : is_univalent_disp (functor_unit_disp_cat IC ID). Proof. apply is_univalent_disp_from_fibers. intros F pt1 pt2. use isweqimplimpl. - intro i. refine (_ @ pr1 i). apply (! id_right _). - apply D. - apply isaproptotal2. + intro ; apply Isos.isaprop_is_z_iso_disp. + do 4 intro ; apply D. Qed. End UnitFunctorCategoryUnivalence. Section UnitFunctorProperties. Definition functor_unit_composition {C D E : category} {IC : C} {ID : D} {IE : E} {F : functor C D} {G : functor D E} (FF : functor_unit IC ID F) (GG : functor_unit ID IE G) : functor_unit IC IE (functor_composite F G) := GG · #G FF. End UnitFunctorProperties. Section FunctorTensorUnit. Context {C D : category} (TC : functor (C ⊠ C) C) (TD : functor (D ⊠ D) D) (IC : C) (ID : D). Definition functor_tensorunit_disp_cat : disp_cat [C,D] := dirprod_disp_cat (functor_tensor_disp_cat TC TD) (functor_unit_disp_cat IC ID). Lemma functor_tensorunit_disp_cat_is_univalent : is_univalent_disp functor_tensorunit_disp_cat. Proof. apply dirprod_disp_cat_is_univalent. - apply functor_tensor_disp_cat_is_univalent. - apply functor_unit_disp_cat_is_univalent. Qed. Definition functor_tensorunit_cat : category := total_category functor_tensorunit_disp_cat. End FunctorTensorUnit. Section TensorUnitFunctorProperties. Context {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {TE : functor (E ⊠ E) E} {IC : C} {ID : D} {IE : E}. Definition functor_tensorunit_composition {F : functor C D} {G : functor D E} (FF : functor_tensorunit_disp_cat TC TD IC ID F) (GG : functor_tensorunit_disp_cat TD TE ID IE G) : functor_tensorunit_disp_cat TC TE IC IE (functor_composite F G). Proof. exists (functor_tensor_composition (pr1 FF) (pr1 GG)). exact (functor_unit_composition (pr2 FF) (pr2 GG)). Defined. End TensorUnitFunctorProperties. Section MonoidalFunctorCategory. Context {C D : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {IC : C} {ID : D} (luC : left_unitor TC IC) (luD : left_unitor TD ID) (ruC : right_unitor TC IC) (ruD : right_unitor TD ID) (αC : associator TC) (αD : associator TD). Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Definition functor_lu_disp_cat : disp_cat (functor_tensorunit_cat TC TD IC ID). Proof. use disp_full_sub. intros [F [FT FU]]. exact (∏ x : C, luD (pr1 F x) = FU #⊗_D (id (pr1 F x)) · (pr1 FT) (IC, x) · #(pr1 F) (luC x)). Defined. Definition functor_ru_disp_cat : disp_cat (functor_tensorunit_cat TC TD IC ID). Proof. use disp_full_sub. intros [F [FT FU]]. exact (∏ x : C, ruD (pr1 F x) = (id (pr1 F x)) #⊗_D FU · (pr1 FT) (x, IC) · #(pr1 F) (ruC x)). Defined. Definition functor_ass_disp_cat : disp_cat (functor_tensorunit_cat TC TD IC ID). Proof. use disp_full_sub. intros [F [FT FU]]. exact (∏ (x y z : C), pr1 FT (x, y) #⊗_D id (pr1 F(z)) · pr1 FT (x ⊗_C y, z) · #(pr1 F) (αC ((x, y), z)) = αD ((pr1 F x, pr1 F y), pr1 F z) · id (pr1 F x) #⊗_D pr1 FT (y, z) · pr1 FT (x, y ⊗_C z)). Defined. Lemma functor_lu_disp_cat_is_univalent : is_univalent_disp functor_lu_disp_cat. Proof. apply disp_full_sub_univalent. intro. apply impred_isaprop ; intro ; apply D. Qed. Lemma functor_ru_disp_cat_is_univalent : is_univalent_disp functor_ru_disp_cat. Proof. apply disp_full_sub_univalent. intro. apply impred_isaprop ; intro ; apply D. Qed. Lemma functor_ass_disp_cat_is_univalent : is_univalent_disp functor_ass_disp_cat. Proof. apply disp_full_sub_univalent. intro. do 3 (apply impred_isaprop ; intro) ; apply D. Qed. Definition functor_monoidal_disp_cat : disp_cat (functor_tensorunit_cat TC TD IC ID) := dirprod_disp_cat (dirprod_disp_cat functor_lu_disp_cat functor_ru_disp_cat) functor_ass_disp_cat. Definition functor_monoidal_cat : category := total_category functor_monoidal_disp_cat. End MonoidalFunctorCategory. Section StrongMonoidalFunctorCategory. Context {C D : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {IC : C} {ID : D} (luC : left_unitor TC IC) (luD : left_unitor TD ID) (ruC : right_unitor TC IC) (ruD : right_unitor TD ID) (αC : associator TC) (αD : associator TD). Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Definition functor_strong_monoidal_disp_cat : disp_cat (functor_monoidal_cat luC luD ruC ruD αC αD) := disp_full_sub (functor_monoidal_cat luC luD ruC ruD αC αD) (λ F, is_nat_z_iso (pr121 F : nat_trans _ _) × is_z_isomorphism (pr221 F)). Definition strong_functor_monoidal_cat : category := total_category functor_strong_monoidal_disp_cat. End StrongMonoidalFunctorCategory. Definition LaxMonoidalFunctorCat (M N : monoidal_cat) : category := functor_monoidal_cat (monoidal_cat_left_unitor M) (monoidal_cat_left_unitor N) (monoidal_cat_right_unitor M) (monoidal_cat_right_unitor N) (monoidal_cat_associator M) (monoidal_cat_associator N). Definition StrongMonoidalFunctorCat (M N : monoidal_cat) : category := strong_functor_monoidal_cat (monoidal_cat_left_unitor M) (monoidal_cat_left_unitor N) (monoidal_cat_right_unitor M) (monoidal_cat_right_unitor N) (monoidal_cat_associator M) (monoidal_cat_associator N). Section FunctorMonoidalProperties. Context {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {TE : functor (E ⊠ E) E} {IC : C} {ID : D} {IE : E}. Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Notation "X ⊗_E Y" := (TE (X , Y)) (at level 31). Notation "f #⊗_E g" := (# TE (f #, g)) (at level 31). Definition functor_lu_composition {luC : left_unitor TC IC} {luD : left_unitor TD ID} {luE : left_unitor TE IE} {F : functor C D} {G : functor D E} {FF : functor_tensorunit_disp_cat TC TD IC ID F} {GG : functor_tensorunit_disp_cat TD TE ID IE G} (FFF : functor_lu_disp_cat luC luD (_,,FF)) (GGG : functor_lu_disp_cat luD luE (_,,GG)) : functor_lu_disp_cat luC luE (_,, functor_tensorunit_composition FF GG). Proof. intro x. refine (GGG (F x) @ _). cbn. unfold functor_unit_composition. assert (aux : (pr2 GG · # G (pr2 FF) #, id G (F x)) = (pr2 GG #, id pr1 G (F x)) · (# G (pr2 FF) #, id pr1 G (F x))). { cbn. rewrite id_left. apply idpath. } etrans. 2: { do 2 apply cancel_postcomposition. etrans. 2: { apply maponpaths. exact (! aux). } apply pathsinv0, functor_comp. } clear aux. repeat rewrite assoc'. apply maponpaths. assert (aux1 := nat_trans_ax (pr1 GG) (ID,, F x) (F IC,, F x) (pr2 FF,, id (F x))). cbn in aux1. rewrite functor_id in aux1. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. exact (! aux1). } repeat rewrite assoc'. apply maponpaths. do 2 rewrite <- functor_comp. apply maponpaths. rewrite assoc. apply (FFF x). Qed. Definition functor_ru_composition {ruC : right_unitor TC IC} {ruD : right_unitor TD ID} {ruE : right_unitor TE IE} {F : functor C D} {G : functor D E} {FF : functor_tensorunit_disp_cat TC TD IC ID F} {GG : functor_tensorunit_disp_cat TD TE ID IE G} (FFF : functor_ru_disp_cat ruC ruD (_,,FF)) (GGG : functor_ru_disp_cat ruD ruE (_,,GG)) : functor_ru_disp_cat ruC ruE (_,, functor_tensorunit_composition FF GG). Proof. intro x. refine (GGG (F x) @ _). cbn. unfold functor_unit_composition. assert (aux : (id G (F x) #, pr2 GG · # G (pr2 FF)) = (id G (F x) #, pr2 GG) · (id G (F x) #, # G (pr2 FF))). { cbn. rewrite id_left. apply idpath. } etrans. 2: { do 2 apply cancel_postcomposition. etrans. 2: { apply maponpaths. exact (! aux). } apply pathsinv0, functor_comp. } clear aux. repeat rewrite assoc'. apply maponpaths. assert (aux1 := nat_trans_ax (pr1 GG) (F x,, ID) (F x,, F IC) (id (F x),, pr2 FF)). cbn in aux1. rewrite functor_id in aux1. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. exact (! aux1). } repeat rewrite assoc'. apply maponpaths. do 2 rewrite <- functor_comp. apply maponpaths. rewrite assoc. apply (FFF x). Qed. Definition functor_ass_composition {αC : associator TC} {αD : associator TD} {αE : associator TE} {F : functor C D} {G : functor D E} {FF : functor_tensorunit_disp_cat TC TD IC ID F} {GG : functor_tensorunit_disp_cat TD TE ID IE G} (FFF : functor_ass_disp_cat αC αD (_,,FF)) (GGG : functor_ass_disp_cat αD αE (_,,GG)) : functor_ass_disp_cat αC αE (_,, functor_tensorunit_composition FF GG). Proof. intros x y z. cbn. assert (aux : (id G (F x) #, pr11 GG (F y, F z) · # G (pr11 FF (y, z))) = (id G (F x) #, pr11 GG (F y, F z)) · (id G (F x) #, # G (pr11 FF (y, z)))). { cbn. rewrite id_left. apply idpath. } etrans. 2: { apply cancel_postcomposition. apply maponpaths. etrans. 2: { apply maponpaths. exact (! aux). } apply pathsinv0, functor_comp. } clear aux. assert (auxnat := nat_trans_ax (pr1 GG) (F x,, _) (F x,, F (y ⊗_C z)) (id (F x),, (pr11 FF) (y, z))). cbn in auxnat. rewrite functor_id in auxnat. etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, auxnat. } clear auxnat. assert (GGGinst := GGG (F x) (F y) (F z)). cbn in GGGinst. etrans. 2: { apply cancel_postcomposition. repeat rewrite assoc. apply cancel_postcomposition. exact GGGinst. } clear GGGinst. assert (aux' : (pr11 GG (F x, F y) · # G (pr11 FF (x, y)) #, id G (F z)) = (pr11 GG (F x, F y) #, id G (F z)) · (# G (pr11 FF (x, y)) #, id G (F z))). { cbn. rewrite id_left. apply idpath. } etrans. { do 2 apply cancel_postcomposition. etrans. { apply maponpaths. exact aux'. } apply functor_comp. } clear aux'. repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. do 2 rewrite <- functor_comp. apply maponpaths. rewrite assoc. apply (FFF x y z). } assert (auxnat' := nat_trans_ax (pr1 GG) (F x ⊗_D F y,, F z) (F (x ⊗_C y),, F z) ((pr11 FF) (x, y),, id (F z))). cbn in auxnat'. rewrite functor_id in auxnat'. etrans. { rewrite assoc. apply cancel_postcomposition. exact auxnat'. } clear auxnat'. repeat rewrite assoc'. apply maponpaths. do 2 rewrite <- functor_comp. apply idpath. Qed. Definition functor_monoidal_composition {luC : left_unitor TC IC} {luD : left_unitor TD ID} {luE : left_unitor TE IE} {ruC : right_unitor TC IC} {ruD : right_unitor TD ID} {ruE : right_unitor TE IE} {αC : associator TC} {αD : associator TD} {αE : associator TE} {F : functor C D} {G : functor D E} {FF : functor_tensorunit_disp_cat TC TD IC ID F} {GG : functor_tensorunit_disp_cat TD TE ID IE G} (FFF : functor_monoidal_disp_cat luC luD ruC ruD αC αD (_,,FF)) (GGG : functor_monoidal_disp_cat luD luE ruD ruE αD αE (_,,GG)) : functor_monoidal_disp_cat luC luE ruC ruE αC αE (_,, functor_tensorunit_composition FF GG). Proof. repeat split. - use functor_lu_composition. exact luD. exact (pr11 FFF). exact (pr11 GGG). - use functor_ru_composition. exact ruD. exact (pr21 FFF). exact (pr21 GGG). - use functor_ass_composition. exact αD. exact (pr2 FFF). exact (pr2 GGG). Defined. End FunctorMonoidalProperties. Section AssociatorMonoidalProperty. Definition pair_nat_trans {C1 C2 D1 D2 : category} {F1 G1 : functor C1 D1} {F2 G2 : functor C2 D2} (α : nat_trans F1 G1) (β : nat_trans F2 G2) : nat_trans (pair_functor F1 F2) (pair_functor G1 G2). Proof. use make_nat_trans. - intro x. use catbinprodmor. + exact (α (pr1 x)). + exact (β (pr2 x)). - abstract (intro ; intros ; use total2_paths_f ; [ apply (pr2 α) | rewrite transportf_const ; apply (pr2 β) ] ). Defined. Definition pair_nat_z_iso {C1 C2 D1 D2 : category} {F1 G1 : functor C1 D1} {F2 G2 : functor C2 D2} (α : nat_z_iso F1 G1) (β : nat_z_iso F2 G2) : nat_z_iso (pair_functor F1 F2) (pair_functor G1 G2). Proof. use make_nat_z_iso. { exact (pair_nat_trans α β). } intro x. use tpair. - use catbinprodmor. + exact (pr1 (pr2 α (pr1 x))). + exact (pr1 (pr2 β (pr2 x))). - abstract ( split ; (use total2_paths_f ; [ apply (pr2 α) | rewrite transportf_const ; apply (pr2 β) ] ) ). Defined. Lemma unassoc_commutes {C D : category} (F : functor C D) : nat_z_iso ((pair_functor (pair_functor F F) F) ∙ (precategory_binproduct_unassoc D D D)) ((precategory_binproduct_unassoc C C C) ∙ (pair_functor F (pair_functor F F))). Proof. use make_nat_z_iso. - use make_nat_trans. + intro ; use catbinprodmor ; apply identity. + intro ; intros. use total2_paths_f. * exact (id_right _ @ ! id_left _). * abstract (rewrite transportf_const ; exact (id_right _ @ ! id_left _)). - intro. use tpair. * use catbinprodmor ; apply identity. * abstract (split ; (use total2_paths_f ; [ apply id_right | rewrite transportf_const ; apply id_right ])). Defined. Lemma assoc_right_commutes_with_triple_pairing {C D : category} (F : functor C D) {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {FF : functor_tensor TC TD F} (FF_iso : is_nat_z_iso FF) : nat_z_iso (pair_functor (pair_functor F F) F ∙ assoc_right TD) (assoc_right TC ∙ F). Proof. (* This commuting diagram can be split in 3 commuting diagrams stacked together *) (* Step 1: The top commuting diagram is unassoc_commutes *) use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: apply unassoc_commutes. } use nat_z_iso_comp. 2: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use nat_z_iso_comp. 3: apply nat_z_iso_functor_comp_assoc. apply pre_whisker_nat_z_iso. (* Step 2: The lowest commuting diagram is the tensor preserving commuting one *) use nat_z_iso_comp. 3: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 3: { apply pre_whisker_nat_z_iso. apply (FF ,, FF_iso). } use nat_z_iso_comp. 3: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. apply post_whisker_nat_z_iso. (* Step 3: The middle commuting square is the tensor preserving commuting one but tensored with the identity functor on the left *) use product_of_commuting_squares. { apply (make_nat_z_iso _ _ _ (is_nat_z_iso_nat_trans_id F)). } apply (FF ,, FF_iso). Defined. Lemma pair_functor_composite {C1 C2 C3 D1 D2 D3 : category} (F1 : functor C1 C2) (G1 : functor D1 D2) (F2 : functor C2 C3) (G2 : functor D2 D3) : nat_z_iso (functor_composite (pair_functor F1 G1) (pair_functor F2 G2)) (pair_functor (functor_composite F1 F2) (functor_composite G1 G2)). Proof. use make_nat_z_iso. { apply nat_trans_id. } intro. use tpair. - use catbinprodmor ; apply identity. - split ; apply id_right. Defined. Lemma assoc_left_commutes_with_triple_pairing {C D : category} (F : functor C D) {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {FF : functor_tensor TC TD F} (FF_iso : is_nat_z_iso FF) : nat_z_iso ((pair_functor (pair_functor F F) F) ∙ assoc_left TD) (assoc_left TC ∙ F). Proof. unfold assoc_left. use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: apply pair_functor_composite. } use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: { use pair_nat_z_iso. 3: { exists FF. apply FF_iso. } 2: { exists (nat_trans_id _). apply is_nat_z_iso_nat_trans_id. } } } unfold functor_tensor_map_codom. use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: { use pair_nat_z_iso. 3: { exists (nat_trans_id _). apply is_nat_z_iso_nat_trans_id. } 2: apply functor_commutes_with_id. } } use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: apply (nat_z_iso_inv (pair_functor_composite _ _ _ _)). } use nat_z_iso_comp. 2: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use nat_z_iso_comp. 2: { use pre_whisker_nat_z_iso. 2: { exists FF. apply FF_iso. } } apply nat_z_iso_functor_comp_assoc. Defined. Context {C D : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {IC : C} {ID : D}. Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Definition functor_ass_ntrans1 (αC : associator TC) (αD : associator TD) {F : functor C D} {FF : functor_tensorunit_disp_cat TC TD IC ID F} (FF_iso : is_nat_z_iso (pr11 FF)) : nat_trans (functor_composite (pair_functor (pair_functor F F) F) (functor_composite (pair_functor TD (functor_identity _)) TD) ) (functor_composite (assoc_right TC) F). Proof. set (pF := pair_functor F F). set (pFF := pair_functor pF F). use nat_trans_comp. 2: { exact (pre_whisker pFF αD). } use assoc_right_commutes_with_triple_pairing. - exact (pr1 FF). - exact FF_iso. Defined. Definition functor_ass_ntrans2 (αC : associator TC) (αD : associator TD) {F : functor C D} {FF : functor_tensorunit_disp_cat TC TD IC ID F} (FF_iso : is_nat_z_iso (pr11 FF)) : nat_trans (functor_composite (pair_functor (pair_functor F F) F) (functor_composite (pair_functor TD (functor_identity _)) TD) ) (functor_composite (assoc_right TC) F). Proof. use nat_trans_comp. 3: exact (post_whisker αC F). use assoc_left_commutes_with_triple_pairing. - exact (pr1 FF). - exact FF_iso. Defined. Definition functor_nat_trans_preserves (αC : associator TC) (αD : associator TD) {F : functor C D} {FF : functor_tensorunit_disp_cat TC TD IC ID F} (FF_iso : is_nat_z_iso (pr11 FF)) : UU := functor_ass_ntrans2 αC αD FF_iso = functor_ass_ntrans1 αC αD FF_iso. Lemma functor_ass_to_nat_trans_ass {αC : associator TC} {αD : associator TD} {F : functor C D} {FF : functor_tensorunit_disp_cat TC TD IC ID F} (FF_iso : is_nat_z_iso (pr11 FF)) (FFF : functor_ass_disp_cat αC αD (_,,FF)) : functor_nat_trans_preserves αC αD FF_iso. Proof. use nat_trans_eq. { apply homset_property. } intro x. set (p := FFF (pr11 x) (pr21 x) (pr2 x)). simpl. rewrite assoc. rewrite ! (functor_id TD). rewrite ! id_left. rewrite ! id_right. refine (p @ _). apply assoc'. Qed. Definition functor_ass_from_nat_trans_ass {αC : associator TC} {αD : associator TD} {F : functor C D} {FF : functor_tensorunit_disp_cat TC TD IC ID F} {FF_iso : is_nat_z_iso (pr11 FF)} (FFF : functor_nat_trans_preserves αC αD FF_iso) : functor_ass_disp_cat αC αD (_,,FF). Proof. intros x y z. simpl. set (t := eqtohomot (base_paths _ _ FFF) ((x,y),z)). simpl in t. rewrite ! (functor_id TD) in t. rewrite ! id_left in t. rewrite ! id_right in t. refine (t @ _). apply assoc. Qed. End AssociatorMonoidalProperty. Section StrongMonoidalProperty. Context {C D E : category} {TC : functor (C ⊠ C) C} {TD : functor (D ⊠ D) D} {TE : functor (E ⊠ E) E} {IC : C} {ID : D} {IE : E} {luC : left_unitor TC IC} {luD : left_unitor TD ID} {luE : left_unitor TE IE} {ruC : right_unitor TC IC} {ruD : right_unitor TD ID} {ruE : right_unitor TE IE} {αC : associator TC} {αD : associator TD} {αE : associator TE}. Notation "X ⊗_C Y" := (TC (X , Y)) (at level 31). Notation "f #⊗_C g" := (# TC (f #, g)) (at level 31). Notation "X ⊗_D Y" := (TD (X , Y)) (at level 31). Notation "f #⊗_D g" := (# TD (f #, g)) (at level 31). Notation "X ⊗_E Y" := (TE (X , Y)) (at level 31). Notation "f #⊗_E g" := (# TE (f #, g)) (at level 31). Definition strong_functor_composition {F : functor_monoidal_cat luC luD ruC ruD αC αD} {G : functor_monoidal_cat luD luE ruD ruE αD αE} (FF : functor_strong_monoidal_disp_cat luC luD ruC ruD αC αD F) (GG : functor_strong_monoidal_disp_cat luD luE ruD ruE αD αE G) : functor_strong_monoidal_disp_cat luC luE ruC ruE αC αE (_,, functor_monoidal_composition (pr2 F) (pr2 G)). Proof. split. - intro cc. use is_z_isomorphism_comp. 2: apply (pr2 (functor_on_z_iso (pr11 G) (_,, pr1 FF cc))). exact (pr1 GG ((pr111 F) (pr1 cc), (pr111 F) (pr2 cc))). - use is_z_isomorphism_comp. + exact (pr2 GG). + exact (pr2 (functor_on_z_iso (pr11 G) (make_z_iso' _ (pr2 FF)))). Defined. End StrongMonoidalProperty. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorsCurried.v000066400000000000000000000126401451125700300330360ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesCurried. Local Open Scope cat. Section local_helper_lemmas. (* I would assume that the following lemmas should already exists in the "iso file", but I can't find it (I need is_iso_stable_undertransportation) *) Lemma iso_stable_under_equality {C : category} {x y : C} {f g : C⟦x,y⟧} : (g = f) → (is_z_isomorphism f) → (is_z_isomorphism g). Proof. intros pe pi. induction pe. exact pi. Qed. Lemma iso_stable_under_tranportation {C : category} {x y z : C} {f : C⟦x,y⟧} {pf : y=z} : (is_z_isomorphism f) → (is_z_isomorphism (transportf _ pf f)). Proof. intro pfi. induction pf. use pfi. Qed. Lemma iso_stable_under_equalitytransportation {C : category} {x y z : C} {f : C⟦x,y⟧} {g : C⟦x,z⟧} {pf : y=z} : (g = transportf _ pf f) -> (is_z_isomorphism f) -> (is_z_isomorphism g). Proof. intros p isof. use (iso_stable_under_equality p). use (iso_stable_under_tranportation). exact isof. Qed. End local_helper_lemmas. Section Curried_Monoidal_Functors. Context (C D : category) (M : monoidalcategory_data C) (N : monoidalcategory_data D) (F : functor C D). Notation "x ⊗_{ M } y" := ((tensoronobjects_from_tensordata M) x y) (at level 31). Notation "f ⊗^{ M } g" := ((tensoronmorphisms_from_tensordata M) _ _ _ _ f g) (at level 31). Notation "I_{ M }" := (unit_from_monoidalcatdata M). Notation "lu^{ M }_{ x }" := (leftunitordata_from_monoidalcatdata M x ). Notation "ru^{ M }_{ x }" := (rightunitordata_from_monoidalcatdata M x ). Notation "α^{ M }_{ x , y , z }" := ((associatordata_from_monoidalcatdata M) x y z). (** (Weak) Monoidal functors **) (* Monoidal functor data *) Definition tensor_preserving_data : UU := ∏ (x y : C), D⟦(F x) ⊗_{N} (F y), F (x ⊗_{M} y)⟧. Definition unit_preserving_data : UU := D ⟦ I_{N} , F I_{M} ⟧. Definition monoidalfunctor_data := tensor_preserving_data × unit_preserving_data. Definition tensorpreservingdata_from_monoidalfunctordata (mfd : monoidalfunctor_data) : tensor_preserving_data := pr1 mfd. Coercion tensorpreservingdata_from_monoidalfunctordata : monoidalfunctor_data >-> tensor_preserving_data. Definition unitpreservingdata_from_monoidalfunctordata (mfd : monoidalfunctor_data) : unit_preserving_data := pr2 mfd. Coercion unitpreservingdata_from_monoidalfunctordata : monoidalfunctor_data >-> unit_preserving_data. (* Weak monoidal functor properties *) Definition tensor_preserving_data_is_natural (tpd : tensor_preserving_data) := ∏ (x y x' y' : C) (f : C⟦x,x'⟧) (g : C⟦y,y'⟧), (#F (f ⊗^{M} g))∘(tpd x y) = (tpd x' y')∘((#F f) ⊗^{N} (#F g)). Definition preserves_associativity (tpd : tensor_preserving_data) := ∏ (x y z : C), (#F (α^{M}_{x,y,z})) ∘ (tpd (x ⊗_{M} y) z) ∘ ((tpd x y) ⊗^{N} (identity (F z))) = (tpd x (y ⊗_{M} z)) ∘ ((identity (F x)) ⊗^{N} (tpd y z)) ∘ α^{N}_{F x, F y, F z}. Definition preserves_leftunitality (tpd : tensor_preserving_data) (upd : unit_preserving_data) : UU := ∏ (x : C), ((#F (lu^{M}_{x})) ∘ (tpd I_{M} x) ∘ (upd ⊗^{N} (identity (F x)))) = lu^{N}_{F x}. Definition preserves_rightunitality (tpd : tensor_preserving_data) (upd : unit_preserving_data) : UU := ∏ (x : C), (#F (ru^{M}_{x})) ∘ (tpd x I_{M}) ∘ ((identity (F x)) ⊗^{N} upd) = ru^{N}_{F x}. Definition monoidalfunctor_laws (mfd : monoidalfunctor_data) : UU := (tensor_preserving_data_is_natural mfd) × (preserves_associativity mfd) × (preserves_leftunitality mfd mfd) × (preserves_rightunitality mfd mfd). Definition monoidalfunctor : UU := ∑ (mfd : monoidalfunctor_data), monoidalfunctor_laws mfd. (** Strong and strict monoidal properties *) Definition is_stronglytensorpreserving (tpd : tensor_preserving_data) : UU := ∏ (x y : C), is_z_isomorphism (tpd x y). Definition is_strictlytensorpreserving (tpd : tensor_preserving_data) : UU := ∏ (x y : C), ∑ (pf : (F x) ⊗_{N} (F y) = F (x ⊗_{M} y)), (tpd x y ) = transportf _ pf (identity ((F x) ⊗_{N} (F y))). Lemma strictlytensorpreserving_is_strong {tpd : tensor_preserving_data} (pfstrict : is_strictlytensorpreserving tpd) : is_stronglytensorpreserving tpd. Proof. intros x y. use (iso_stable_under_equalitytransportation (pr2 (pfstrict x y)) (is_z_isomorphism_identity ((F x) ⊗_{N} (F y)))). Defined. Coercion strictlytensorpreserving_is_strong : is_strictlytensorpreserving >-> is_stronglytensorpreserving. Definition is_stronglyunitpreserving (upd : unit_preserving_data) : UU := is_z_isomorphism upd. Definition is_strictlyunitpreserving (upd : unit_preserving_data) : UU := ∑ (pf : I_{N} = (F I_{M})), upd = transportf _ pf (identity I_{N}). Definition strictlyunitpreserving_is_strong {upd : unit_preserving_data} (pfstrict : is_strictlyunitpreserving upd) : is_stronglyunitpreserving upd. Proof. use (iso_stable_under_equalitytransportation (pr2 pfstrict) (is_z_isomorphism_identity I_{N})). Defined. Coercion strictlyunitpreserving_is_strong : is_strictlyunitpreserving >-> is_stronglyunitpreserving. End Curried_Monoidal_Functors. UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions/MonoidalFunctorsTensored.v000066400000000000000000000212231451125700300332210ustar00rootroot00000000000000(** Monoidal functors *) (** behaviour w.r.t. to swapped tensor products added by Ralph Matthes in 2019, then iso changed to z_iso in 2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Section Monoidal_Functor. Context (Mon_C Mon_D : monoidal_cat). Local Definition tensor_C := monoidal_cat_tensor Mon_C. Notation "X ⊗_C Y" := (tensor_C (X , Y)) (at level 31). Notation "f #⊗_C g" := (# tensor_C (f #, g)) (at level 31). Local Definition I_C := monoidal_cat_unit Mon_C. Local Definition α_C := monoidal_cat_associator Mon_C. Local Definition λ_C := monoidal_cat_left_unitor Mon_C. Local Definition ρ_C := monoidal_cat_right_unitor Mon_C. Local Definition tensor_D := monoidal_cat_tensor Mon_D. Notation "X ⊗_D Y" := (tensor_D (X , Y)) (at level 31). Notation "f #⊗_D g" := (# tensor_D (f #, g)) (at level 31). Local Definition I_D := monoidal_cat_unit Mon_D. Local Definition α_D := monoidal_cat_associator Mon_D. Local Definition λ_D := monoidal_cat_left_unitor Mon_D. Local Definition ρ_D := monoidal_cat_right_unitor Mon_D. Section Monoidal_Functor_Conditions. Context (F : Mon_C ⟶ Mon_D). Definition monoidal_functor_map_dom : category_binproduct Mon_C Mon_C ⟶ Mon_D := functor_composite (pair_functor F F) tensor_D. Lemma monoidal_functor_map_dom_ok: functor_on_objects monoidal_functor_map_dom = λ c, F (ob1 c) ⊗_D F (ob2 c). Proof. apply idpath. Qed. Definition monoidal_functor_map_codom : category_binproduct Mon_C Mon_C ⟶ Mon_D := functor_composite tensor_C F. Lemma monoidal_functor_map_codom_ok: functor_on_objects monoidal_functor_map_codom = λ c, F (ob1 c ⊗_C ob2 c). Proof. apply idpath. Qed. Definition monoidal_functor_map := monoidal_functor_map_dom ⟹ monoidal_functor_map_codom. Definition monoidal_functor_map_funclass (μ : monoidal_functor_map) : ∏ x : ob (Mon_C ⊠ Mon_C), monoidal_functor_map_dom x --> monoidal_functor_map_codom x := pr1 μ. Coercion monoidal_functor_map_funclass : monoidal_functor_map >-> Funclass. Definition monoidal_functor_associativity (μ : monoidal_functor_map) := ∏ (x y z : Mon_C), μ (x, y) #⊗_D id F(z) · μ (x ⊗_C y, z) · #F (α_C ((x, y), z)) = α_D ((F x, F y), F z) · id (F x) #⊗_D μ (y, z) · μ (x, y ⊗_C z). Definition monoidal_functor_unitality (ϵ : I_D --> F I_C) (μ : monoidal_functor_map) := ∏ (x : Mon_C), (λ_D (F x) = ϵ #⊗_D (id (F x)) · μ (I_C, x) · #F (λ_C x)) × (ρ_D (F x) = (id (F x)) #⊗_D ϵ · μ (x, I_C) · #F (ρ_C x)). End Monoidal_Functor_Conditions. Definition lax_monoidal_functor : UU := ∑ F : Mon_C ⟶ Mon_D, ∑ ϵ : I_D --> F I_C, ∑ μ : monoidal_functor_map F, (monoidal_functor_associativity F μ) × (monoidal_functor_unitality F ϵ μ). Definition make_lax_monoidal_functor (F : Mon_C ⟶ Mon_D) (ϵ : I_D --> F I_C) (μ : monoidal_functor_map F) (Hass: monoidal_functor_associativity F μ) (Hunit: monoidal_functor_unitality F ϵ μ): lax_monoidal_functor := (F,, (ϵ,, (μ,, (Hass,, Hunit)))). Definition lax_monoidal_functor_functor (lmF : lax_monoidal_functor) : Mon_C ⟶ Mon_D := pr1 lmF. Coercion lax_monoidal_functor_functor : lax_monoidal_functor >-> functor. Definition lax_monoidal_functor_ϵ (lmF : lax_monoidal_functor) : I_D --> lax_monoidal_functor_functor lmF I_C := pr1 (pr2 lmF). Definition lax_monoidal_functor_μ (lmF : lax_monoidal_functor) : monoidal_functor_map (lax_monoidal_functor_functor lmF) := pr1 (pr2 (pr2 lmF)). Definition lax_monoidal_functor_assoc (lmF : lax_monoidal_functor) : monoidal_functor_associativity (lax_monoidal_functor_functor lmF) (lax_monoidal_functor_μ lmF) := pr1 (pr2 (pr2 (pr2 lmF))). Definition lax_monoidal_functor_unital (lmF : lax_monoidal_functor) : monoidal_functor_unitality (lax_monoidal_functor_functor lmF) (lax_monoidal_functor_ϵ lmF) (lax_monoidal_functor_μ lmF) := pr2 (pr2 (pr2 (pr2 lmF))). Definition strong_monoidal_functor : UU := ∑ lmF : lax_monoidal_functor, (is_z_isomorphism (lax_monoidal_functor_ϵ lmF)) (* ϵ is an iso *) × (is_nat_z_iso (lax_monoidal_functor_μ lmF)). (* μ is an iso *) Definition strong_monoidal_functor_lax_monoidal_functor (smF : strong_monoidal_functor) : lax_monoidal_functor := pr1 smF. Coercion strong_monoidal_functor_lax_monoidal_functor : strong_monoidal_functor >-> lax_monoidal_functor. Definition strong_monoidal_functor_ϵ_is_z_iso (smF : strong_monoidal_functor) : is_z_isomorphism (lax_monoidal_functor_ϵ smF) := pr1 (pr2 smF). Definition strong_monoidal_functor_μ_is_nat_z_iso (smF : strong_monoidal_functor) : is_nat_z_iso (lax_monoidal_functor_μ smF) := pr2 (pr2 smF). Definition strong_monoidal_functor_ϵ (smF : strong_monoidal_functor) : z_iso I_D (lax_monoidal_functor_functor smF I_C) := make_z_iso _ _ (strong_monoidal_functor_ϵ_is_z_iso smF). Definition strong_monoidal_functor_ϵ_inv (smF : strong_monoidal_functor) : lax_monoidal_functor_functor smF I_C --> I_D := inv_from_z_iso (strong_monoidal_functor_ϵ smF). Definition strong_monoidal_functor_μ (smF : strong_monoidal_functor) : nat_z_iso (monoidal_functor_map_dom smF) (monoidal_functor_map_codom smF) := make_nat_z_iso _ _ (lax_monoidal_functor_μ smF) (strong_monoidal_functor_μ_is_nat_z_iso smF). Definition strong_monoidal_functor_μ_inv (smF : strong_monoidal_functor) : monoidal_functor_map_codom smF ⟹ monoidal_functor_map_dom smF := nat_z_iso_to_trans_inv (strong_monoidal_functor_μ smF). End Monoidal_Functor. Arguments lax_monoidal_functor_ϵ {_ _} _ . Arguments lax_monoidal_functor_μ {_ _} _ . Arguments lax_monoidal_functor_assoc {_ _} _ . Arguments lax_monoidal_functor_unital {_ _} _ . Arguments strong_monoidal_functor_ϵ_is_z_iso {_ _} _ . Arguments strong_monoidal_functor_μ_is_nat_z_iso {_ _} _ . Arguments strong_monoidal_functor_ϵ {_ _} _ . Arguments strong_monoidal_functor_ϵ_inv {_ _} _ . Arguments strong_monoidal_functor_μ {_ _} _ . Arguments strong_monoidal_functor_μ_inv {_ _} _ . Section swapped_tensor. Context {Mon Mon' : monoidal_cat}. Local Definition tensor := monoidal_cat_tensor Mon. Local Definition tensor' := monoidal_cat_tensor Mon'. Lemma swapping_of_lax_monoidal_functor_assoc (lmF: lax_monoidal_functor Mon Mon'): monoidal_functor_associativity (swapping_of_monoidal_cat Mon) (swapping_of_monoidal_cat Mon') lmF (pre_whisker binswap_pair_functor (lax_monoidal_functor_μ lmF)). Proof. induction lmF as [F [ϵ [μ [Hass Hunit]]]]. red. intros x y z. set (Hass_inst := Hass z y x). apply pathsinv0. rewrite <- assoc. cbn. set (f := nat_z_iso_pointwise_z_iso (monoidal_cat_associator Mon') ((F z, F y), F x)). apply (z_iso_inv_on_right _ _ _ f). transparent assert (is : (is_z_isomorphism (# F (monoidal_cat_associator Mon ((z, y), x))))). { apply functor_on_is_z_isomorphism. apply monoidal_cat_associator. } set (Hass_inst' := z_iso_inv_on_left _ _ _ _ (_,, is) _ (! Hass_inst)). etrans. { exact Hass_inst'. } clear Hass_inst Hass_inst'. do 2 rewrite assoc. apply cancel_precomposition. apply idpath. Qed. Definition swapping_of_lax_monoidal_functor: lax_monoidal_functor Mon Mon' -> lax_monoidal_functor (swapping_of_monoidal_cat Mon) (swapping_of_monoidal_cat Mon'). Proof. intro lmF. induction lmF as [F [ϵ [μ [Hass Hunit]]]]. use make_lax_monoidal_functor. - exact F. - exact ϵ. - exact (pre_whisker binswap_pair_functor μ). - apply (swapping_of_lax_monoidal_functor_assoc (F,, (ϵ,, (μ,, (Hass,, Hunit))))). - abstract ( red; intro x; induction (Hunit x) as [Hunit1 Hunit2]; split; assumption ). Defined. Definition swapping_of_strong_monoidal_functor: strong_monoidal_functor Mon Mon' -> strong_monoidal_functor (swapping_of_monoidal_cat Mon) (swapping_of_monoidal_cat Mon'). Proof. intro smF. induction smF as [lmF [Hϵ Hμ]]. apply (tpair _ (swapping_of_lax_monoidal_functor lmF)). split. - exact Hϵ. - exact (pre_whisker_on_nat_z_iso binswap_pair_functor (lax_monoidal_functor_μ lmF) Hμ). Defined. Lemma swapping_of_strong_monoidal_functor_on_objects (smF: strong_monoidal_functor Mon Mon')(a: Mon): swapping_of_strong_monoidal_functor smF a = smF a. Proof. apply idpath. Qed. End swapped_tensor. TotalDisplayedMonoidalCurried.v000066400000000000000000000352001451125700300340730ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/AlternativeDefinitions(* In this file we show: 1. If a displayed category over a monoidal category has the structure of a displayed monoidal category, then has the total category the structure of a monoidal category. 2. The projection from the total category (equipped with this monoidal structure) to the base (monoidal) category is a strict monoidal functor. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesCurried. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.DisplayedMonoidalCurried. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsCurried. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Local Open Scope mor_disp_scope. Section MonoidalTotalCategory. Context (C : category) (T : tensor_data C) (I : C) (α : associator_data T) (lu : leftunitor_data T I) (ru : rightunitor_data T I) (tid : tensorfunctor_id T) (tcomp : tensorfunctor_comp T) (αnat : associator_naturality α) (αiso : associator_is_natiso α) (lunat : leftunitor_naturality lu) (luiso : leftunitor_is_natiso lu) (runat : rightunitor_naturality ru) (ruiso : rightunitor_is_natiso ru) (tri : triangle_identity lu ru α) (pen : pentagon_identity α) (D : disp_cat C) (dtd : displayedtensor_data C D T) (i : D I) (dα : displayedassociator_data C D T α dtd) (dlu : displayedleftunitor_data C D T I lu dtd i) (dru : displayedrightunitor_data C D T I ru dtd i) (dtid : displayedtensor_id C D T tid dtd) (dtcomp : displayedtensor_comp C D T tcomp dtd) (dαnat : displayedassociator_naturality C D T α αnat dα ) (dαiso : displayedassociator_is_nat_iso C D T α αiso dα ) (dlunat : displayedleftunitor_naturality C D T I lu lunat dlu ) (dluiso : displayedleftunitor_is_nat_iso C D T I lu luiso dlu) (drunat : displayedrightunitor_naturality C D T I ru runat dru ) (druiso : displayedrightunitor_is_nat_iso C D T I ru ruiso dru) (dtri : displayedtriangle_identity C D T I α lu ru tri dlu dru dα) (dpen : displayedpentagon_identity C D T α pen dα). Notation ToD := (total_category D). Notation "x ⊗_{ T } y" := (tensoronobjects_from_tensordata T x y) (at level 31). Notation "f ⊗^{ T } g" := (tensoronmorphisms_from_tensordata T _ _ _ _ f g) (at level 31). Notation "a ⊗_{{ dtd }} b" := (displayedtensoronobjects_from_displayedtensordata _ _ _ dtd _ _ a b) (at level 31). Notation "f' ⊗^{{ dtd }} g'" := (displayedtensoronmorphisms_from_displayedtensordata dtd _ _ _ _ _ _ _ _ _ _ f' g' ) (at level 31). (** DATA **) Definition totalcategory_tensordata : tensor_data ToD. Proof. use tpair. + intros xa yb. exact ((pr1 xa) ⊗_{T} (pr1 yb) ,, (pr2 xa) ⊗_{{dtd}} (pr2 yb)). + intros xa yb xa' yb' f g. split with (pr1 f ⊗^{T} pr1 g). apply (pr2 dtd). - exact (pr2 f). - exact (pr2 g). Defined. Notation TtD := totalcategory_tensordata. Definition totalcategory_associatordata : associator_data TtD. Proof. intros x y z. use tpair. + exact (α (pr1 x) (pr1 y) (pr1 z)). + exact (dα (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)). Defined. Notation TαD := totalcategory_associatordata. Definition totalcategory_unitdata : ToD := (I,,i). Notation TuD := totalcategory_unitdata. Definition totalcategory_leftunitordata : leftunitor_data TtD TuD. Proof. intro x. use tpair. + apply lu. + exact (dlu (pr1 x) (pr2 x)). Defined. Notation TluD := totalcategory_leftunitordata. Definition totalcategory_rightunitordata : rightunitor_data TtD TuD. Proof. intro x. use tpair. + apply ru. + exact (dru (pr1 x) (pr2 x)). Defined. Notation TruD := totalcategory_rightunitordata. Definition totalcategory_monoidalcatdata : (monoidalcategory_data ToD) := (TtD,,TuD,,TluD,,TruD,,TαD). (** PROPERTIES **) Lemma totalcategory_tensorfunctorid : tensorfunctor_id TtD. Proof. intros x y. use total2_paths_b. + apply tid. + apply (dtid (pr1 x) (pr1 y) (pr2 x) (pr2 y)). Qed. Lemma totalcategory_tensorfunctorcomp : tensorfunctor_comp TtD. Proof. intros x y x' y' x'' y'' f f' g g'. use total2_paths_b. + use tcomp. + use (((dtcomp (pr1 x) (pr1 y) (pr1 x') (pr1 y') (pr1 x'') (pr1 y'') (pr2 x) (pr2 y) (pr2 x') (pr2 y') (pr2 x'') (pr2 y'') (pr1 f) (pr1 g) (pr1 f') (pr1 g') (pr2 f) (pr2 g) (pr2 f') (pr2 g')))). Qed. Lemma totalcategory_associatornaturality : associator_naturality TαD. Proof. intros x x' y y' z z' f g h. use total2_paths_b. - exact (αnat (pr1 x) (pr1 x') (pr1 y) (pr1 y') (pr1 z) (pr1 z') (pr1 f) (pr1 g) (pr1 h)). - exact (dαnat (pr1 x) (pr1 x') (pr1 y) (pr1 y') (pr1 z) (pr1 z') (pr2 x) (pr2 x') (pr2 y) (pr2 y') (pr2 z) (pr2 z') (pr1 f) (pr1 g) (pr1 h) (pr2 f) (pr2 g) (pr2 h)). Qed. (* The following part has holes because of the migration from [iso] to [z_iso] as notion of isomorphism. It compiled at the moment of commenting it. But at the price of three "Admitted". Lemma totalcategory_associatorisnatiso : associator_is_natiso TαD. Proof. intros x y z. use tpair. + use tpair. - exact (pr1 (αiso (pr1 x) (pr1 y) (pr1 z))). - cbn. set (pf := (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (αiso (pr1 x) (pr1 y) (pr1 z))))). (* pf : Isos.inv_from_iso (Isos.z_iso_to_iso (α (pr1 x) (pr1 y) (pr1 z),, αiso (pr1 x) (pr1 y) (pr1 z))) = pr1 (αiso (pr1 x) (pr1 y) (pr1 z))) *) admit. (* exact (transportf (*(mor_disp (pr2 x ⊗_{{ dtd}} (pr2 y ⊗_{{ dtd}} pr2 z)) ((pr2 x ⊗_{{ dtd}} pr2 y) ⊗_{{ dtd}} pr2 z))*) _ pf (pr1 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))). *) + use tpair. - use total2_paths_b. -- exact (pr1 (pr2 (αiso (pr1 x) (pr1 y) (pr1 z)))). -- admit. (* etrans. { apply mor_disp_transportf_prewhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr2 (pr2 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. *) - use total2_paths_b. -- exact (pr2 (pr2 (αiso (pr1 x) (pr1 y) (pr1 z)))). -- admit. (* etrans. { apply mor_disp_transportf_postwhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr1 (pr2 (dαiso (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. Qed. *) Admitted. Lemma totalcategory_leftunitornaturality : leftunitor_naturality TluD. Proof. intros x y f. use total2_paths_b. + exact (lunat (pr1 x) (pr1 y) (pr1 f)). + exact (dlunat (pr1 x) (pr1 y) (pr2 x) (pr2 y) (pr1 f) (pr2 f)). Qed. Lemma totalcategory_leftunitorisnatiso : leftunitor_is_natiso TluD. Proof. intros x. use tpair. + use tpair. - exact (pr1 (luiso (pr1 x))). - set (pf (*: Isos.inv_from_iso (Isos.z_iso_to_iso (lu (pr1 x),, luiso (pr1 x))) = pr1 (luiso (pr1 x))*) := (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (luiso (pr1 x)))) ). admit. (* exact (transportf _ pf (pr1 (dluiso (pr1 x) (pr2 x)))). *) + use tpair. - use total2_paths_b. -- exact (pr1 (pr2 (luiso (pr1 x)))). -- admit. (* etrans. { apply mor_disp_transportf_prewhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr2 (pr2 (dluiso (pr1 x) (pr2 x)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. *) - use total2_paths_b. -- exact (pr2 (pr2 (luiso (pr1 x)))). -- admit. (* etrans. { apply mor_disp_transportf_postwhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr1 (pr2 (dluiso (pr1 x) (pr2 x)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. Qed. *) Admitted. Lemma totalcategory_rightunitornaturality : rightunitor_naturality TruD. Proof. intros x y f. use total2_paths_b. + exact (runat (pr1 x) (pr1 y) (pr1 f)). + exact (drunat (pr1 x) (pr1 y) (pr2 x) (pr2 y) (pr1 f) (pr2 f)). Qed. Lemma totalcategory_rightunitorisnatiso : rightunitor_is_natiso TruD. Proof. intros x. use tpair. + use tpair. - exact (pr1 (ruiso (pr1 x))). - set (pf (*: Isos.inv_from_iso (Isos.z_iso_to_iso (lu (pr1 x),, luiso (pr1 x))) = pr1 (luiso (pr1 x))*) := (((pr2 (pr1 (pr2(pr1 C)))) _ _) (pr1 (ruiso (pr1 x)))) ). admit. (* exact (transportf _ pf (pr1 (druiso (pr1 x) (pr2 x)))). *) + use tpair. - use total2_paths_b. -- exact (pr1 (pr2 (ruiso (pr1 x)))). -- admit. (* etrans. { apply mor_disp_transportf_prewhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr2 (pr2 (druiso (pr1 x) (pr2 x)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. *) - use total2_paths_b. -- exact (pr2 (pr2 (ruiso (pr1 x)))). -- admit. (* etrans. { apply mor_disp_transportf_postwhisker. } apply transportb_transpose_right. etrans. { apply transport_f_f. } etrans. { apply maponpaths. apply (pr1 (pr2 (druiso (pr1 x) (pr2 x)))). } etrans. { apply transport_f_f. } apply transportf_set. apply homset_property. Qed. *) Admitted. Lemma totalcategory_triangleidentity : triangle_identity TluD TruD TαD. Proof. intros x y. use total2_paths_b. + exact (tri (pr1 x) (pr1 y)). + exact (dtri (pr1 x) (pr1 y) (pr2 x) (pr2 y)). Qed. Lemma totalcategory_pentagonidentity : pentagon_identity TαD. Proof. intros w x y z. use total2_paths_b. + exact (pen (pr1 w) (pr1 x) (pr1 y) (pr1 z)). + exact (dpen (pr1 w) (pr1 x) (pr1 y) (pr1 z) (pr2 w) (pr2 x) (pr2 y) (pr2 z)). Qed. Definition totalcategory_monoidallaws : monoidal_laws totalcategory_monoidalcatdata := (totalcategory_tensorfunctorid,, totalcategory_tensorfunctorcomp,, totalcategory_associatornaturality,, totalcategory_associatorisnatiso,, totalcategory_leftunitornaturality,, totalcategory_leftunitorisnatiso,, totalcategory_rightunitornaturality,, totalcategory_rightunitorisnatiso,, totalcategory_triangleidentity,, totalcategory_pentagonidentity). Definition totalcategory_monoidalcat : monoidalcategory ToD := (totalcategory_monoidalcatdata,, totalcategory_monoidallaws). Notation π := (pr1_category D). Definition MC : monoidalcategory_data C := (T,,I,,lu,,ru,,α). Definition projection_tensorpreservingdata : tensor_preserving_data ToD C totalcategory_monoidalcatdata MC π := λ x y, identity (π x ⊗_{ MC} π y). Definition projection_unitpreservingdata : unit_preserving_data ToD C totalcategory_monoidalcatdata MC π := identity I. Definition projection_monoidalfunctordata : monoidalfunctor_data ToD C totalcategory_monoidalcatdata MC π := (projection_tensorpreservingdata,,projection_unitpreservingdata). Lemma projection_tensornaturality : tensor_preserving_data_is_natural ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata. Proof. intros xx yy zz ww ff' gg'. exact ((pr1 (pr1 (pr2 (pr1 C))) _ _ (pr1 ff' ⊗^{T} pr1 gg')) @ (pathsinv0 (pr2 (pr1 (pr2 (pr1 C))) _ _ (pr1 ff' ⊗^{T} pr1 gg')))). Qed. Lemma projection_preservesassociativity : preserves_associativity ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata. Proof. intros xx yy zz. rewrite (pr1 (pr1 (pr2 (pr1 C)))). rewrite (pr2 (pr1 (pr2 (pr1 C)))). rewrite tid. rewrite tid. rewrite (pr1 (pr1 (pr2 (pr1 C)))). rewrite (pr2 (pr1 (pr2 (pr1 C)))). apply idpath. Qed. Lemma projection_preservesleftunitality : preserves_leftunitality ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata projection_unitpreservingdata. Proof. intro xx. rewrite tid. rewrite (pr1 (pr1 (pr2 (pr1 C)))). rewrite (pr1 (pr1 (pr2 (pr1 C)))). apply idpath. Qed. Lemma projection_preservesrightunitality : preserves_rightunitality ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata projection_unitpreservingdata. Proof. intro xx. rewrite tid. rewrite (pr1 (pr1 (pr2 (pr1 C)))). rewrite (pr1 (pr1 (pr2 (pr1 C)))). apply idpath. Qed. Definition projection_monoidallaws : monoidalfunctor_laws ToD C totalcategory_monoidalcatdata MC π projection_monoidalfunctordata := (projection_tensornaturality,,projection_preservesassociativity,,projection_preservesleftunitality,,projection_preservesrightunitality). Definition projection_monoidalfunctor : monoidalfunctor ToD C totalcategory_monoidalcatdata MC π := (projection_monoidalfunctordata,,projection_monoidallaws). Lemma projection_strictlytensorpreserving : is_strictlytensorpreserving ToD C totalcategory_monoidalcatdata MC π projection_tensorpreservingdata. Proof. intros xx yy. use tpair. + apply idpath. + apply idpath. Qed. Lemma projection_strictlyunitpreserving : is_strictlyunitpreserving ToD C totalcategory_monoidalcatdata MC π projection_unitpreservingdata. Proof. use tpair. + apply idpath. + apply idpath. Qed. *) End MonoidalTotalCategory. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Categories.v000066400000000000000000001617641451125700300236610ustar00rootroot00000000000000(*************************************************************************** Monoidal categories In this file, we define the notion of monoidal category. In addition, we prove the important laws for monoidal categories. The main definition in this file, takes a so-called displayed approach. More specifically, we define the notion of a monoidal structure on a category. For this notion, we define suitable accessors and we prove the laws. Finally, we also provide a bundled notion of monoidal category, which is a category together with a monoidal structure for it. The necessary accessors and laws are derived from the other notion. In this file, we use a whiskered approach. This means that we have two operations to tensor with morphisms: a left and a right whiskering. Both of these take an object and a morphism as input and they return a morphism as output. Contents 1. Monoidal structures 2. Opposite monoidal category 3. Equivalences from the tensor and unit 4. The unitors coincide 5. Swapping the tensor 6. More monoidal laws 7. Bundled approach to monoidal categories Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/MonoidalCategoriesWhiskered.v ***************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Import BifunctorNotations. (** 1. Monoidal structures *) Section A. (** Data **) Definition tensor_data (C : category) : UU := bifunctor_data C C C. Identity Coercion tensorintobifunctor : tensor_data >-> bifunctor_data. Definition leftunitor_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C⟦I ⊗_{T} x, x⟧. Definition leftunitorinv_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C⟦x, I ⊗_{T} x⟧. Definition rightunitor_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C⟦x ⊗_{T} I, x⟧. Definition rightunitorinv_data {C : category} (T : tensor_data C) (I : C) : UU := ∏ (x : C), C⟦x, x ⊗_{T} I⟧. Definition associator_data {C : category} (T : tensor_data C) : UU := ∏ (x y z : C), C ⟦(x ⊗_{T} y) ⊗_{T} z, x ⊗_{T} (y ⊗_{T} z)⟧. Definition associatorinv_data {C : category} (T : tensor_data C) : UU := ∏ (x y z : C), C ⟦x ⊗_{T} (y ⊗_{T} z), (x ⊗_{T} y) ⊗_{T} z⟧. Definition monoidal_data (C : category): UU := ∑ (T : tensor_data C) (I : C), (leftunitor_data T I) × (leftunitorinv_data T I) × (rightunitor_data T I) × (rightunitorinv_data T I) × (associator_data T) × (associatorinv_data T). Definition make_monoidal_data {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (luinv : leftunitorinv_data T I) (ru : rightunitor_data T I) (ruinv : rightunitorinv_data T I) (α : associator_data T) (αinv : associatorinv_data T) : monoidal_data C := (T,,I,,lu,,luinv,,ru,,ruinv,,α,,αinv). Definition monoidal_tensor_data {C : category} (MD : monoidal_data C) : tensor_data C := pr1 MD. Coercion monoidal_tensor_data : monoidal_data >-> tensor_data. Definition monoidal_unit {C : category} (MD : monoidal_data C) : C := pr12 MD. Notation "I_{ MD }" := (monoidal_unit MD). Definition monoidal_leftunitordata {C : category} (MD : monoidal_data C) : leftunitor_data MD I_{MD} := pr1 (pr22 MD). Notation "lu_{ MD }" := (monoidal_leftunitordata MD). Definition monoidal_leftunitorinvdata {C : category} (MD : monoidal_data C) : leftunitorinv_data MD I_{MD} := pr12 (pr22 MD). Notation "luinv_{ MD }" := (monoidal_leftunitorinvdata MD). Definition monoidal_rightunitordata {C : category} (MD : monoidal_data C) : rightunitor_data MD I_{MD} := pr122 (pr22 MD). Notation "ru_{ MD }" := (monoidal_rightunitordata MD). Definition monoidal_rightunitorinvdata {C : category} (MD : monoidal_data C) : rightunitorinv_data MD I_{MD} := pr1 (pr222 (pr22 MD)). Notation "ruinv_{ MD }" := (monoidal_rightunitorinvdata MD). Definition monoidal_associatordata {C : category} (MD : monoidal_data C) : associator_data MD := pr12 (pr222 (pr22 MD)). Notation "α_{ MD }" := (monoidal_associatordata MD). Definition monoidal_associatorinvdata {C : category} (MD : monoidal_data C) : associatorinv_data MD := pr22 (pr222 (pr22 MD)). Notation "αinv_{ MD }" := (monoidal_associatorinvdata MD). (** Axioms **) Definition leftunitor_nat {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), I ⊗^{ T}_{l} f · lu y = lu x · f. Definition leftunitorinv_nat {C : category} {T : tensor_data C} {I : C} (luinv : leftunitorinv_data T I) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), luinv x · I ⊗^{ T}_{l} f = f · luinv y. Definition leftunitor_iso_law {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (luinv : leftunitorinv_data T I) : UU := ∏ (x : C), is_inverse_in_precat (lu x) (luinv x). Definition leftunitor_law {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (luinv : leftunitorinv_data T I) : UU := leftunitor_nat lu × leftunitor_iso_law lu luinv. Definition leftunitorlaw_nat {C : category} {T : tensor_data C} {I : C} {lu : leftunitor_data T I} {luinv : leftunitorinv_data T I} (lu_law : leftunitor_law lu luinv) : leftunitor_nat lu := pr1 lu_law. Definition leftunitorlaw_iso_law {C : category} {T : tensor_data C} {I : C} {lu : leftunitor_data T I} {luinv : leftunitorinv_data T I} (lu_law : leftunitor_law lu luinv) : leftunitor_iso_law lu luinv := pr2 lu_law. Definition rightunitor_nat {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), f ⊗^{ T}_{r} I · ru y = ru x · f. Definition rightunitorinv_nat {C : category} {T : tensor_data C} {I : C} (ruinv : rightunitorinv_data T I) : UU := ∏ (x y : C), ∏ (f : C ⟦x,y⟧), ruinv x · f ⊗^{ T}_{r} I = f · ruinv y. Definition rightunitor_iso_law {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) (ruinv : rightunitorinv_data T I) : UU := ∏ (x : C), is_inverse_in_precat (ru x) (ruinv x). Definition rightunitor_law {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) (ruinv : rightunitorinv_data T I) : UU := rightunitor_nat ru × rightunitor_iso_law ru ruinv. Definition rightunitorlaw_nat {C : category} {T : tensor_data C} {I : C} {ru : rightunitor_data T I} {ruinv : rightunitorinv_data T I} (rul : rightunitor_law ru ruinv) : rightunitor_nat ru := pr1 rul. Definition rightunitorlaw_iso_law {C : category} {T : tensor_data C} {I : C} {ru : rightunitor_data T I} {ruinv : rightunitorinv_data T I} (rul : rightunitor_law ru ruinv) : rightunitor_iso_law ru ruinv := pr2 rul. Definition associator_nat_leftwhisker {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (x y z z' : C) (h : C⟦z,z'⟧), (α x y z) · (x ⊗^{ T}_{l} (y ⊗^{ T}_{l} h)) = ((x ⊗_{ T} y) ⊗^{ T}_{l} h) · (α x y z'). Definition associator_nat_rightwhisker {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (x x' y z : C) (f : C⟦x,x'⟧), (α x y z) · (f ⊗^{ T}_{r} (y ⊗_{ T} z)) = ((f ⊗^{ T}_{r} y) ⊗^{ T}_{r} z) · (α x' y z). Definition associator_nat_leftrightwhisker {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (x y y' z : C) (g : C⟦y,y'⟧), (α x y z) · (x ⊗^{ T}_{l} (g ⊗^{ T}_{r} z)) = ((x ⊗^{ T}_{l} g) ⊗^{ T}_{r} z) · (α x y' z). Definition associator_iso_law {C : category} {T : tensor_data C} (α : associator_data T) (αinv : associatorinv_data T) : UU := ∏ (x y z : C), is_inverse_in_precat (α x y z) (αinv x y z). Definition associator_law {C : category} {T : tensor_data C} (α : associator_data T) (αinv : associatorinv_data T) : UU := (associator_nat_leftwhisker α) × (associator_nat_rightwhisker α) × (associator_nat_leftrightwhisker α) × (associator_iso_law α αinv). Definition associatorlaw_natleft {C : category} {T : tensor_data C} {α : associator_data T} {αinv : associatorinv_data T} (αl : associator_law α αinv) : associator_nat_leftwhisker α := pr1 αl. Definition associatorlaw_natright {C : category} {T : tensor_data C} {α : associator_data T} {αinv : associatorinv_data T} (αl : associator_law α αinv) : associator_nat_rightwhisker α := pr1 (pr2 αl). Definition associatorlaw_natleftright {C : category} {T : tensor_data C} {α : associator_data T} {αinv : associatorinv_data T} (αl : associator_law α αinv) : associator_nat_leftrightwhisker α := pr1 (pr2 (pr2 αl)). Definition associatorlaw_iso_law {C : category} {T : tensor_data C} {α : associator_data T} {αinv : associatorinv_data T} (αl : associator_law α αinv) : associator_iso_law α αinv := pr2 (pr2 (pr2 αl)). Definition triangle_identity {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (ru : rightunitor_data T I) (α : associator_data T) : UU := ∏ (x y : C), α x I y · x ⊗^{T}_{l} (lu y) = ru x ⊗^{T}_{r} y. (** more triangle laws that are redundant in the axiomatisation *) Definition triangle_identity' {C : category} {T : tensor_data C} {I : C} (lu : leftunitor_data T I) (α : associator_data T) : UU := ∏ (x y : C), α I x y · lu (x ⊗_{T} y) = lu x ⊗^{T}_{r} y. Definition triangle_identity'' {C : category} {T : tensor_data C} {I : C} (ru : rightunitor_data T I) (α : associator_data T) : UU := ∏ (x y : C), α x y I · x ⊗^{T}_{l} (ru y) = ru (x ⊗_{T} y). Definition pentagon_identity {C : category} {T : tensor_data C} (α : associator_data T) : UU := ∏ (w x y z : C), ((α w x y) ⊗^{T}_{r} z) · (α w (x⊗_{T} y) z) · (w ⊗^{T}_{l} (α x y z)) = (α (w⊗_{T}x) y z) · (α w x (y ⊗_{T} z)). Definition monoidal_laws {C : category} (MD : monoidal_data C) : UU := is_bifunctor MD × (leftunitor_law lu_{MD} luinv_{MD}) × (rightunitor_law ru_{MD} ruinv_{MD}) × (associator_law α_{MD} αinv_{MD}) × (triangle_identity lu_{MD} ru_{MD} α_{MD}) × (pentagon_identity α_{MD}). Definition monoidal (C : category) : UU := ∑ (MD : monoidal_data C), (monoidal_laws MD). Definition monoidal_mondata {C : category} (M : monoidal C) : monoidal_data C := pr1 M. Coercion monoidal_mondata : monoidal >-> monoidal_data. Definition monoidal_monlaws {C : category} (M : monoidal C) : monoidal_laws M := pr2 M. Definition monoidal_tensor_is_bifunctor {C : category} (M : monoidal C) : is_bifunctor M := pr12 M. Coercion monoidal_tensor {C : category} (M : monoidal C) : bifunctor C C C := _ ,, monoidal_tensor_is_bifunctor M. Definition monoidal_leftunitorlaw {C : category} (M : monoidal C) : leftunitor_law lu_{M} luinv_{M} := pr12 (monoidal_monlaws M). Definition monoidal_leftunitornat {C : category} (M : monoidal C) : leftunitor_nat lu_{M} := leftunitorlaw_nat (monoidal_leftunitorlaw M). Definition monoidal_leftunitorisolaw {C : category} (M : monoidal C) : leftunitor_iso_law lu_{M} luinv_{M} := leftunitorlaw_iso_law (monoidal_leftunitorlaw M). Lemma monoidal_leftunitorinvnat {C : category} (M : monoidal C) : leftunitorinv_nat luinv_{M}. Proof. intros x y f. apply (z_iso_inv_on_right _ _ _ (_,,_,,monoidal_leftunitorisolaw M x)). cbn. rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,_,,monoidal_leftunitorisolaw M y)). apply pathsinv0, monoidal_leftunitornat. Qed. Definition monoidal_rightunitorlaw {C : category} (M : monoidal C) : rightunitor_law ru_{M} ruinv_{M} := pr122 (monoidal_monlaws M). Definition monoidal_rightunitornat {C : category} (M : monoidal C) : rightunitor_nat ru_{M} := rightunitorlaw_nat (monoidal_rightunitorlaw M). Definition monoidal_rightunitorisolaw {C : category} (M : monoidal C) : rightunitor_iso_law ru_{M} ruinv_{M} := rightunitorlaw_iso_law (monoidal_rightunitorlaw M). Lemma monoidal_rightunitorinvnat {C : category} (M : monoidal C) : rightunitorinv_nat ruinv_{M}. Proof. intros x y f. apply (z_iso_inv_on_right _ _ _ (_,,_,,monoidal_rightunitorisolaw M x)). cbn. rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,_,,monoidal_rightunitorisolaw M y)). apply pathsinv0, monoidal_rightunitornat. Qed. Definition monoidal_associatorlaw {C : category} (M : monoidal C) : associator_law α_{M} αinv_{M} := pr1 (pr222 (monoidal_monlaws M)). Definition monoidal_associatornatleft {C : category} (M : monoidal C) : associator_nat_leftwhisker α_{M} := associatorlaw_natleft (monoidal_associatorlaw M). Definition monoidal_associatornatright {C : category} (M : monoidal C) : associator_nat_rightwhisker α_{M} := associatorlaw_natright (monoidal_associatorlaw M). Definition monoidal_associatornatleftright {C : category} (M : monoidal C) : associator_nat_leftrightwhisker α_{M} := associatorlaw_natleftright (monoidal_associatorlaw M). Definition monoidal_associatorisolaw {C : category} (M : monoidal C) : associator_iso_law α_{M} αinv_{M} := associatorlaw_iso_law (monoidal_associatorlaw M). Lemma associator_nat1 {C : category} (M : monoidal C) {x x' y y' z z' : C} (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧) : (monoidal_associatordata M x y z) · ((f ⊗^{M}_{r} (y ⊗_{M} z)) · (x' ⊗^{M}_{l} ((g ⊗^{M}_{r} z) · (y' ⊗^{M}_{l} h)))) = (((f ⊗^{M}_{r} y) · (x' ⊗^{M}_{l} g)) ⊗^{M}_{r} z) · ((x' ⊗_{M} y') ⊗^{M}_{l} h) · (monoidal_associatordata M x' y' z'). Proof. rewrite assoc. rewrite (monoidal_associatornatright M). rewrite assoc'. etrans. { apply cancel_precomposition. rewrite (bifunctor_leftcomp M). rewrite assoc. rewrite (monoidal_associatornatleftright M). apply idpath. } etrans. { apply cancel_precomposition. rewrite assoc'. apply cancel_precomposition. apply (monoidal_associatornatleft M). } rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply pathsinv0. rewrite (bifunctor_rightcomp M). apply idpath. Qed. Lemma associator_nat2 {C : category} (M : monoidal C) {x x' y y' z z' : C} (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧) : (monoidal_associatordata M x y z) · (f ⊗^{M} (g ⊗^{M} h)) = ((f ⊗^{M} g) ⊗^{M} h) · (monoidal_associatordata M x' y' z'). Proof. intros. unfold functoronmorphisms1. exact (associator_nat1 M f g h). Qed. Definition monoidal_triangleidentity {C : category} (M : monoidal C) : triangle_identity lu_{M} ru_{M} α_{M} := pr12 (pr222 (monoidal_monlaws M)). Definition monoidal_pentagonidentity {C : category} (M : monoidal C) : pentagon_identity α_{M} := pr22 (pr222 (monoidal_monlaws M)). Lemma isaprop_monoidal_laws {C : category} (M : monoidal_data C) : isaprop (monoidal_laws M). Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; repeat (try apply C) ; repeat (apply isaprop_is_inverse_in_precat). Qed. (** Some additional data and properties which one deduces from monoidal categories **) (* Not the best name though, but here my creativity fails *) Lemma swap_nat_along_zisos {C : category} {x1 x2 y1 y2 : C} (p1 : z_iso x1 y1) (p2 : z_iso x2 y2) : ∏ (f: C⟦x1,x2⟧) (g : C⟦y1,y2⟧), (pr1 p1) · g = f · (pr1 p2) -> g · (inv_from_z_iso p2) = (inv_from_z_iso p1) · f. Proof. intros f g p. apply pathsinv0. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply p. Qed. Lemma leftunitor_nat_z_iso {C : category} (M : monoidal C) : nat_z_iso (leftwhiskering_functor M I_{M}) (functor_identity C). Proof. use make_nat_z_iso. - use make_nat_trans. + exact (λ x, lu_{M} x). + exact (λ x y f, monoidal_leftunitornat M x y f). - intro x. exists (luinv_{M} x). apply (monoidal_leftunitorisolaw M x). Defined. Definition rightunitor_nat_z_iso {C : category} (M : monoidal C) : nat_z_iso (rightwhiskering_functor M I_{M}) (functor_identity C). Proof. use make_nat_z_iso. - use make_nat_trans. + exact (λ x, ru_{M} x). + exact (λ x y f, monoidal_rightunitornat M x y f). - intro x. exists (ruinv_{M} x). apply (monoidal_rightunitorisolaw M x). Defined. Definition z_iso_from_associator_iso {C : category} (M : monoidal C) (x y z : C) : z_iso ((x ⊗_{ M} y) ⊗_{ M} z) (x ⊗_{ M} (y ⊗_{ M} z)) := make_z_iso (α_{M} x y z) (αinv_{M} x y z) (monoidal_associatorisolaw M x y z). Definition monoidal_associatorinvnatleft {C : category} (M : monoidal C) : ∏ (x y z z' : C) (h : C⟦z,z'⟧), (x ⊗^{M}_{l} (y ⊗^{M}_{l} h)) · (αinv_{M} x y z') = (αinv_{M} x y z) · ((x ⊗_{M} y) ⊗^{M}_{l} h) . Proof. intros x y z z' h. apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x y z')). apply monoidal_associatornatleft. Qed. Definition monoidal_associatorinvnatright {C : category} (M : monoidal C) : ∏ (x x' y z: C) (f : C⟦x,x'⟧), (f ⊗^{M}_{r} (y ⊗_{M} z)) · (αinv_{M} x' y z) = (αinv_{M} x y z) · ((f ⊗^{M}_{r} y) ⊗^{M}_{r} z). Proof. intros x x' y z f. apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x' y z)). apply monoidal_associatornatright. Qed. Definition monoidal_associatorinvnatleftright {C : category} (M : monoidal C) : ∏ (x y y' z : C) (g : C⟦y,y'⟧), (x ⊗^{M}_{l} (g ⊗^{M}_{r} z)) · (αinv_{M} x y' z) = (αinv_{M} x y z) · ((x ⊗^{M}_{l} g) ⊗^{M}_{r} z). Proof. intros x y y' z g. apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x y' z)). apply monoidal_associatornatleftright. Qed. Definition monoidal_associatorinv_nat1 {C : category} (M : monoidal C) {x x' y y' z z' : C} (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧) : ((f ⊗^{M}_{r} (y ⊗_{M} z)) · (x' ⊗^{M}_{l} ((g ⊗^{M}_{r} z) · (y' ⊗^{M}_{l} h)))) · (αinv_{M} x' y' z') = (αinv_{M} x y z) · ((((f ⊗^{M}_{r} y) · (x' ⊗^{M}_{l} g)) ⊗^{M}_{r} z) · ((x' ⊗_{M} y') ⊗^{ M}_{l} h)). Proof. apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x' y' z') ). unfold z_iso_from_associator_iso. unfold make_z_iso. unfold make_is_z_isomorphism. unfold pr1. apply associator_nat1. Qed. Lemma monoidal_associatorinv_nat2 {C : category} (M : monoidal C) {x x' y y' z z' : C} (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧) : (f ⊗^{M} (g ⊗^{M} h)) · (αinv_{M} x' y' z') = (αinv_{M} x y z) · ((f ⊗^{M} g) ⊗^{M} h). Proof. intros. unfold functoronmorphisms1. apply monoidal_associatorinv_nat1. Qed. Lemma monoidal_triangle_identity_inv {C : category} (M : monoidal C) (x y : C) : x ⊗^{M}_{l} luinv_{M} y · αinv_{M} x I_{ M} y = ruinv_{M} x ⊗^{ M}_{r} y. Proof. apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))). cbn. set (luiy := make_z_iso _ _ (monoidal_leftunitorisolaw M y)). set (luixy := functor_on_z_iso (leftwhiskering_functor M x) luiy). set (ruix := make_z_iso _ _ (monoidal_rightunitorisolaw M x)). set (ruixy := functor_on_z_iso (rightwhiskering_functor M y) ruix). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ ruixy). apply (z_iso_inv_on_left _ _ _ _ luixy). exact (! (monoidal_triangleidentity M) x y). Qed. (* another proof of the same law - could be deleted in some future: *) Lemma monoidal_triangle_identity_inv_alt {C : category} (M : monoidal C) (x y : C) : x ⊗^{M}_{l} (luinv_{M} y) · αinv_{M} x I_{M} y = (ruinv_{M} x) ⊗^{M}_{r} y. Proof. transparent assert (auxiso1 : (z_iso (x ⊗_{ M} y) (x ⊗_{ M} (I_{ M} ⊗_{ M} y)))). { exists (x ⊗^{M}_{l} (luinv_{M} y)). apply (is_z_iso_leftwhiskering_z_iso M). exists (lu_{ M} y). split; apply monoidal_leftunitorisolaw. } transparent assert (auxiso2 : (z_iso (x ⊗_{ M} y) ((x ⊗_{ M} I_{ M}) ⊗_{ M} y))). { exists (ruinv_{ M} x ⊗^{ M}_{r} y). apply (is_z_iso_rightwhiskering_z_iso M). exists (ru_{ M} x). split; apply monoidal_rightunitorisolaw. } apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso M _ _ _)). apply (z_iso_inv_to_left _ _ _ auxiso2). apply (z_iso_inv_to_right _ _ _ _ auxiso1). apply pathsinv0, monoidal_triangleidentity. Qed. Lemma monoidal_pentagon_identity_inv {C : category} (M : monoidal C) (w x y z : C) : w ⊗^{ M}_{l} (αinv_{M} x y z) · αinv_{M} w (x ⊗_{ M} y) z · αinv_{M} w x y ⊗^{ M}_{r} z = αinv_{M} w x (y ⊗_{ M} z) · αinv_{M} (w ⊗_{ M} x) y z. Proof. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)). unfold z_iso_from_associator_iso. unfold make_z_iso. unfold make_is_z_isomorphism. etrans. { apply (pathsinv0 (id_right _)). } apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)). cbn. apply pathsinv0. etrans. { rewrite assoc. apply cancel_postcomposition. apply (pathsinv0 (monoidal_pentagonidentity M w x y z)). } etrans. { rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. rewrite assoc'. apply cancel_precomposition. apply (pathsinv0 (bifunctor_leftcomp M _ _ _ _ _ _)). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply cancel_precomposition. apply maponpaths. apply (pr2 (z_iso_from_associator_iso M x y z)). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply cancel_precomposition. apply (bifunctor_leftid M). } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply id_right. } etrans. { apply cancel_postcomposition. rewrite assoc'. apply cancel_precomposition. apply (pr2 (z_iso_from_associator_iso M w (x⊗_{M}y) z)). } etrans. { apply cancel_postcomposition. apply id_right. } etrans. { apply (pathsinv0 (bifunctor_rightcomp M _ _ _ _ _ _)). } etrans. { apply maponpaths. apply (pr2 (pr2 (z_iso_from_associator_iso M w x y))). } apply (bifunctor_rightid M). Qed. End A. Module MonoidalNotations. Notation "I_{ M }" := (monoidal_unit M) : cat. Notation "lu_{ M }" := (monoidal_leftunitordata M) : cat. Notation "luinv_{ M }" := (monoidal_leftunitorinvdata M) : cat. Notation "ru_{ M }" := (monoidal_rightunitordata M) : cat. Notation "ruinv_{ M }" := (monoidal_rightunitorinvdata M) : cat. Notation "α_{ M }" := (monoidal_associatordata M) : cat. Notation "αinv_{ M }" := (monoidal_associatorinvdata M) : cat. Notation "lu^{ M }_{ x }" := (monoidal_leftunitordata M x ) : cat. Notation "ru^{ M }_{ x }" := ( monoidal_rightunitordata M x ) : cat. Notation "α^{ M }_{ x , y , z }" := (monoidal_associatordata M x y z) : cat. Notation "luinv^{ M }_{ x }" := (monoidal_leftunitorinvdata M x ) : cat. Notation "ruinv^{ M }_{ x }" := ( monoidal_rightunitorinvdata M x ) : cat. Notation "αinv^{ M }_{ x , y , z }" := (monoidal_associatorinvdata M x y z) : cat. End MonoidalNotations. (** 2. Opposite monoidal category *) Section OppositeMonoidal. Context {C : category} (M : monoidal C). Import MonoidalNotations. Definition monoidal_opp_tensor_data : bifunctor_data C^op C^op C^op. Proof. exists (pr11 (monoidal_tensor M)). exists (λ x _ _ g, x ⊗^{M}_{l} g). exact (λ x _ _ f, f ⊗^{M}_{r} x). Defined. Lemma monoidal_opp_is_tensor : is_bifunctor monoidal_opp_tensor_data. Proof. repeat split ; (try (intro ; intros) ; try apply (pr2 (monoidal_tensor M))). exact (! bifunctor_equalwhiskers M a2 a1 b2 b1 f g). Qed. Definition monoidal_opp_tensor : bifunctor C^op C^op C^op := monoidal_opp_tensor_data ,, monoidal_opp_is_tensor. Definition monoidal_opp_data : monoidal_data C^op. Proof. exists monoidal_opp_tensor_data. exists I_{M}. exists luinv_{M}. exists lu_{M}. exists ruinv_{M}. exists ru_{M}. exists αinv_{M}. exact α_{M}. Defined. Definition monoidal_opp_laws : monoidal_laws monoidal_opp_data. Proof. repeat split. - intro ; intros. apply (bifunctor_leftid M). - intro ; intros. apply (bifunctor_rightid M). - intro ; intros. apply (bifunctor_leftcomp M). - intro ; intros. apply (bifunctor_rightcomp M). - intro ; intros. exact (!(bifunctor_equalwhiskers M _ _ _ _ f g)). - intro ; intros ; apply monoidal_leftunitorinvnat. - apply (monoidal_leftunitorisolaw M). - apply (monoidal_leftunitorisolaw M). - intro ; intros ; apply monoidal_rightunitorinvnat. - apply (monoidal_rightunitorisolaw M). - apply (monoidal_rightunitorisolaw M). - intro ; intros ; apply monoidal_associatorinvnatleft. - intro ; intros ; apply monoidal_associatorinvnatright. - intro ; intros ; apply monoidal_associatorinvnatleftright. - apply (monoidal_associatorisolaw M). - apply (monoidal_associatorlaw M). - intro ; intros ; apply monoidal_triangle_identity_inv. - intros w x y z. refine (_ @ monoidal_pentagon_identity_inv M w x y z). simpl ; apply assoc. Qed. Definition monoidal_opp : monoidal C^op := monoidal_opp_data ,, monoidal_opp_laws. End OppositeMonoidal. (** 3. Equivalences from the tensor and unit *) Section EquivalenceFromTensorWithUnit. Context {C : category} (M : monoidal C). Import MonoidalNotations. Definition ladjunction_data_from_tensor_with_unit : adjunction_data C C. Proof. exists (leftwhiskering_functor M I_{M}). exists (functor_identity C). use tpair. - apply (nat_z_iso_inv (leftunitor_nat_z_iso M)). - apply (leftunitor_nat_z_iso M). Defined. Definition lequivalence_from_tensor_with_unit : equivalence_of_cats C C. Proof. exists ladjunction_data_from_tensor_with_unit. split. - intro ; apply (nat_z_iso_inv (leftunitor_nat_z_iso M)). - intro ; apply (leftunitor_nat_z_iso M). Defined. Definition radjunction_data_from_tensor_with_unit : adjunction_data C C. Proof. exists (rightwhiskering_functor M I_{M}). exists (functor_identity C). use tpair. - apply (nat_z_iso_inv (rightunitor_nat_z_iso M)). - apply (rightunitor_nat_z_iso M). Defined. Definition requivalence_from_tensor_with_unit : equivalence_of_cats C C. Proof. exists radjunction_data_from_tensor_with_unit. split. - intro ; apply (nat_z_iso_inv (rightunitor_nat_z_iso M)). - intro ; apply (rightunitor_nat_z_iso M). Defined. Lemma leftwhiskering_fullyfaithful : fully_faithful (leftwhiskering_functor M I_{M}). Proof. apply fully_faithful_from_equivalence. exact (adjointification lequivalence_from_tensor_with_unit). Defined. Lemma rightwhiskering_fullyfaithful : fully_faithful (rightwhiskering_functor M I_{M}). Proof. apply fully_faithful_from_equivalence. exact (adjointification requivalence_from_tensor_with_unit). Defined. Lemma leftwhiskering_faithful : faithful (leftwhiskering_functor M I_{M}). Proof. exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ leftwhiskering_fullyfaithful)). Defined. Lemma rightwhiskering_faithful : faithful (rightwhiskering_functor M I_{M}). Proof. exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ rightwhiskering_fullyfaithful)). Defined. End EquivalenceFromTensorWithUnit. (** 4. The unitors coincide *) Section UnitorsCoincide. Context {C : category} (M : monoidal C). Import MonoidalNotations. Local Lemma lemma0 (x y : C) : ((α_{M} I_{M} I_{M} x) ⊗^{M}_{r} y) · ((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) = (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y. Proof. refine (! bifunctor_rightcomp M _ _ _ _ _ _ @ _). apply maponpaths. apply (monoidal_triangleidentity M I_{M} x). Qed. Local Lemma lemma1 (x y : C) : α_{M} I_{M} (I_{M} ⊗_{M} x) y · (I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y)) = ((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) · α_{M} I_{M} x y. Proof. apply monoidal_associatornatleftright. Qed. Local Lemma lemma2 (x y : C) : I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y) = αinv_{M} I_{M} (I_{M} ⊗_{M} x) y · (((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) · α_{M} I_{M} x y). Proof. set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M I_{ M} (I_{ M} ⊗_{ M} x) y)). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ αiso). apply pathsinv0. apply lemma1. Qed. Local Lemma lemma2' (x y : C) : (I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y = ((αinv_{M} I_{M} I_{M} x) ⊗^{M}_{r} y) · (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y. Proof. apply pathsinv0. set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M I_{ M} I_{ M} x)). set (αisor := functor_on_z_iso (rightwhiskering_functor M y) αiso). apply (z_iso_inv_on_right _ _ _ αisor). apply pathsinv0. apply lemma0. Qed. Local Lemma lemma3 (x y : C) : I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y) = αinv_{M} I_{M} (I_{M} ⊗_{M} x) y · ((((αinv_{M} I_{M} I_{M} x) ⊗^{M}_{r} y) · (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y) · α_{M} I_{M} x y). Proof. refine (lemma2 x y @ _). apply maponpaths. apply maponpaths_2. apply lemma2'. Qed. Local Lemma right_whisker_with_lunitor' (x y : C) : I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y) = I_{M} ⊗^{M}_{l} (α_{M} I_{M} x y · lu_{M} (x ⊗_{M} y)). Proof. refine (lemma3 x y @ _). set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M I_{ M} (I_{ M} ⊗_{M} x) y)). apply (z_iso_inv_on_right _ _ _ αiso). set (αiso' := make_z_iso _ _ (monoidal_associatorisolaw M I_{ M} I_{ M} x)). set (αisor := functor_on_z_iso (rightwhiskering_functor M y) αiso'). etrans. { apply assoc'. } apply (z_iso_inv_on_right _ _ _ αisor). apply pathsinv0. simpl. etrans. { apply assoc. } etrans. { apply maponpaths. apply (bifunctor_leftcomp M _ _ _ _ _ _). } etrans. { apply assoc. } etrans. { apply maponpaths_2. apply (monoidal_pentagonidentity M I_{M} I_{M} x y). } etrans. 2: { apply (associatorlaw_natright (monoidal_associatorlaw M)). } etrans. { apply assoc'. } apply maponpaths. apply monoidal_triangleidentity. Qed. Lemma right_whisker_with_lunitor : triangle_identity' lu_{M} α_{M}. Proof. intros x y. use faithful_reflects_commutative_triangle. 3: { apply leftwhiskering_faithful. } apply pathsinv0. refine (right_whisker_with_lunitor' _ _ @ _). apply (bifunctor_leftcomp (monoidal_tensor M)). Qed. Definition monoidal_triangleidentity' := right_whisker_with_lunitor. Lemma monoidal_triangle_identity'_inv (x y : C) : luinv_{M} (x ⊗_{M} y) · αinv_{M} I_{M} x y = luinv_{M} x ⊗^{M}_{r} y. Proof. apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))). cbn. set (luix := make_z_iso _ _ (monoidal_leftunitorisolaw M x)). set (luixy := functor_on_z_iso (rightwhiskering_functor M y) luix). set (luipxy := make_z_iso _ _ (monoidal_leftunitorisolaw M (x ⊗_{ M} y))). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ luixy). apply (z_iso_inv_on_left _ _ _ _ luipxy). exact (! monoidal_triangleidentity' x y). Qed. Lemma lunitor_preserves_leftwhiskering_with_unit : lu^{M}_{I_{ M} ⊗_{M} I_{M}} = I_{M} ⊗^{ M}_{l} lu^{M}_{I_{ M}}. Proof. apply pathsinv0. set (lun := monoidal_leftunitornat M _ _ (lu_{M} (I_{M}))). etrans. { apply (! id_right _). } etrans. 2: { apply id_right. } etrans. { apply maponpaths. exact (! pr1 (monoidal_leftunitorisolaw M I_{ M})). } etrans. { apply assoc. } etrans. { apply maponpaths_2 ; exact lun. } etrans. { apply assoc'. } apply maponpaths. apply monoidal_leftunitorisolaw. Qed. Lemma unitors_coincide_on_unit' : lu_{M} I_{M} ⊗^{M}_{r} I_{M} = ru_{M} I_{M} ⊗^{M}_{r} I_{M}. Proof. refine (! right_whisker_with_lunitor I_{M} I_{M} @ _). refine (_ @ monoidal_triangleidentity M I_{M} I_{M}). apply maponpaths. apply lunitor_preserves_leftwhiskering_with_unit. Qed. Lemma unitors_coincide_on_unit : lu_{M} I_{M} = ru_{M} I_{M}. Proof. use faithful_reflects_morphism_equality. 3: { apply rightwhiskering_faithful. } apply unitors_coincide_on_unit'. Qed. Corollary unitorsinv_coincide_on_unit : luinv_{M} I_{M} = ruinv_{M} I_{M}. Proof. apply (cancel_z_iso _ _ (lu_{M} I_{M},,(luinv_{M} I_{M},,monoidal_leftunitorisolaw M I_{M}))). cbn. etrans. 2: { rewrite unitors_coincide_on_unit. apply pathsinv0, (monoidal_rightunitorisolaw M I_{M}). } apply (monoidal_leftunitorisolaw M I_{M}). Qed. End UnitorsCoincide. (* Using the lemma for a different category, hence outside of the section. *) Section UnitorsCoincideAlternative. Import MonoidalNotations. Lemma unitorsinv_coincide_on_unit_alt {C : category} (M : monoidal C) : luinv_{M} I_{M} = ruinv_{M} I_{M}. Proof. exact (unitors_coincide_on_unit (monoidal_opp M)). Qed. End UnitorsCoincideAlternative. (** 5. Swapping the tensor *) Section MonoidalSwapped. Import MonoidalNotations. Definition tensor_swapped {V : category} (Mon_V : monoidal V) : tensor_data V. Proof. repeat (use tpair). - intros v w. exact (w ⊗_{Mon_V} v). - intros v w1 w2 f. exact (f ⊗^{Mon_V}_{r} v). - intros v w1 w2 f. exact (v ⊗^{Mon_V}_{l} f). Defined. Definition monoidal_swapped_data {V : category} (Mon_V : monoidal V) : monoidal_data V. Proof. exists (tensor_swapped Mon_V). exists I_{Mon_V}. exists (λ v, ru_{Mon_V} v). exists (λ v, ruinv_{Mon_V} v). exists (λ v, lu_{Mon_V} v). exists (λ v, luinv_{Mon_V} v). exists (λ v1 v2 v3, αinv_{Mon_V} v3 v2 v1). exact (λ v1 v2 v3, α_{Mon_V} v3 v2 v1). Defined. Lemma monoidal_swapped_laws {V : category} (Mon_V : monoidal V) : monoidal_laws (monoidal_swapped_data Mon_V). Proof. repeat split. - intro ; intro ; apply (bifunctor_rightid Mon_V). - intro ; intro ; apply (bifunctor_leftid Mon_V). - intro ; intros ; apply (bifunctor_rightcomp Mon_V). - intro ; intros ; apply (bifunctor_leftcomp Mon_V). - intro ; intros ; apply (! bifunctor_equalwhiskers Mon_V _ _ _ _ _ _). - intro ; intros ; apply monoidal_rightunitornat. - apply monoidal_rightunitorisolaw. - apply monoidal_rightunitorisolaw. - intro ; intros ; apply monoidal_leftunitornat. - apply monoidal_leftunitorisolaw. - apply monoidal_leftunitorisolaw. - intro ; intros ; apply (! monoidal_associatorinvnatright Mon_V _ _ _ _ _). - intro ; intros ; apply (! monoidal_associatorinvnatleft Mon_V _ _ _ _ _). - intro ; intros ; apply (! monoidal_associatorinvnatleftright Mon_V _ _ _ _ _). - apply monoidal_associatorisolaw. - apply monoidal_associatorisolaw. - intro ; intros. cbn. rewrite (! monoidal_triangleidentity Mon_V _ _). rewrite assoc. rewrite (pr2 (monoidal_associatorisolaw Mon_V _ _ _)). apply id_left. - intro ; intros ; apply monoidal_pentagon_identity_inv. Qed. Definition monoidal_swapped {V : category} (Mon_V : monoidal V) : monoidal V := monoidal_swapped_data Mon_V ,, monoidal_swapped_laws Mon_V. End MonoidalSwapped. (** 6. More monoidal laws *) Section MonoidalLaws. Import MonoidalNotations. Lemma left_whisker_with_runitor {C : category} (M : monoidal C) : triangle_identity'' ru_{M} α_{M}. Proof. red; intros x y. assert (aux := right_whisker_with_lunitor (monoidal_swapped M) y x). cbn in aux. rewrite <- aux. rewrite assoc. etrans. { apply cancel_postcomposition. apply monoidal_associatorisolaw. } apply id_left. Qed. Lemma monoidal_triangle_identity''_inv {C : category} (M : monoidal C) (x y : C) : x ⊗^{M}_{l} (ruinv_{M} y) · αinv_{M} x y I_{M} = ruinv_{M} (x ⊗_{M} y). Proof. apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))). cbn. set (ruiy := make_z_iso _ _ (monoidal_rightunitorisolaw M y)). set (ruiyx := functor_on_z_iso (leftwhiskering_functor M x) ruiy). set (ruipxy := make_z_iso _ _ (monoidal_rightunitorisolaw M (x ⊗_{ M} y))). apply pathsinv0. apply (z_iso_inv_on_right _ _ _ ruipxy). apply (z_iso_inv_on_left _ _ _ _ ruiyx). exact (! (left_whisker_with_runitor M) x y). Qed. Lemma lunitorinv_preserves_leftwhiskering_with_unit {C : category} (M : monoidal C) : luinv^{M}_{I_{ M}} ⊗^{ M}_{r} I_{ M} · α^{ M }_{ I_{ M}, I_{ M}, I_{ M}} = I_{ M} ⊗^{ M}_{l} luinv^{M}_{I_{ M}}. Proof. set (t := monoidal_triangle_identity_inv_alt M I_{M} I_{M}). use (_ @ ! z_iso_inv_on_left _ _ _ _ (_,, α^{M}_{_,_,_} ,, _) _ (! t)). - apply maponpaths_2. apply maponpaths. apply unitorsinv_coincide_on_unit_alt. - split ; apply (monoidal_associatorisolaw M). Qed. End MonoidalLaws. (** 7. Bundled approach to monoidal categories *) (** Accessors and notations for monoidal categories *) Declare Scope moncat. Local Open Scope moncat. Definition monoidal_cat : UU := ∑ (C : category), monoidal C. Coercion monoidal_cat_to_cat (V : monoidal_cat) : category := pr1 V. Coercion monoidal_cat_to_monoidal (V : monoidal_cat) : monoidal V := pr2 V. Definition monoidal_cat_tensor_pt {V : monoidal_cat} (x y : V) : V := x ⊗_{ pr2 V } y. Notation "x ⊗ y" := (monoidal_cat_tensor_pt x y) : moncat. Definition monoidal_cat_tensor_mor {V : monoidal_cat} {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : x₁ ⊗ y₁ --> x₂ ⊗ y₂ := f ⊗^{ pr2 V } g. Notation "f #⊗ g" := (monoidal_cat_tensor_mor f g) (at level 31) : moncat. Proposition tensor_mor_left {V : monoidal_cat} (x : V) {y z : V} (f : y --> z) : x ⊗^{V}_{l} f = identity x #⊗ f. Proof. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!_). etrans. { apply maponpaths_2. apply (bifunctor_rightid V). } apply id_left. Qed. Proposition tensor_mor_right {V : monoidal_cat} (x : V) {y z : V} (f : y --> z) : f ⊗^{V}_{r} x = f #⊗ identity x. Proof. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!_). etrans. { apply maponpaths. apply (bifunctor_leftid V). } apply id_right. Qed. Section MonoidalCatAccessors. Context {V : monoidal_cat}. Import MonoidalNotations. Definition tensor_id_id (x y : V) : identity x #⊗ identity y = identity (x ⊗ y). Proof. apply bifunctor_distributes_over_id. - apply (bifunctor_leftid V). - apply (bifunctor_rightid V). Qed. Definition tensor_comp_mor {x₁ x₂ x₃ y₁ y₂ y₃ : V} (f : x₁ --> x₂) (f' : x₂ --> x₃) (g : y₁ --> y₂) (g' : y₂ --> y₃) : (f · f') #⊗ (g · g') = f #⊗ g · f' #⊗ g'. Proof. use bifunctor_distributes_over_comp. - apply (bifunctor_leftcomp V). - apply (bifunctor_rightcomp V). - apply (bifunctor_equalwhiskers V). Qed. Definition tensor_comp_id_l {x y₁ y₂ y₃ : V} (g : y₁ --> y₂) (g' : y₂ --> y₃) : (identity x) #⊗ (g · g') = (identity x) #⊗ g · (identity x) #⊗ g'. Proof. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. Definition tensor_comp_l_id_l {x₁ x₂ y₁ y₂ y₃ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) (g' : y₂ --> y₃) : f #⊗ (g · g') = (identity _) #⊗ g · f #⊗ g'. Proof. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. Definition tensor_comp_l_id_r {x₁ x₂ y₁ y₂ y₃ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) (g' : y₂ --> y₃) : f #⊗ (g · g') = f #⊗ g · (identity _) #⊗ g'. Proof. rewrite <- tensor_comp_mor. rewrite id_right. apply idpath. Qed. Definition tensor_comp_id_r {x₁ x₂ x₃ y : V} (f : x₁ --> x₂) (f' : x₂ --> x₃) : (f · f') #⊗ (identity y) = f #⊗ (identity y) · f' #⊗ (identity y). Proof. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. Definition tensor_comp_r_id_l {x₁ x₂ x₃ y₁ y₂ : V} (f : x₁ --> x₂) (f' : x₂ --> x₃) (g : y₁ --> y₂) : (f · f') #⊗ g = f #⊗ (identity _) · f' #⊗ g. Proof. rewrite <- tensor_comp_mor. rewrite id_left. apply idpath. Qed. Definition tensor_comp_r_id_r {x₁ x₂ x₃ y₁ y₂ : V} (f : x₁ --> x₂) (f' : x₂ --> x₃) (g : y₁ --> y₂) : (f · f') #⊗ g = f #⊗ g · f' #⊗ (identity _). Proof. rewrite <- tensor_comp_mor. rewrite id_right. apply idpath. Qed. Definition tensor_split {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g = identity _ #⊗ g · f #⊗ identity _. Proof. refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left, id_right. apply idpath. Qed. Definition tensor_split' {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g = f #⊗ identity _ · identity _ #⊗ g. Proof. refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left, id_right. apply idpath. Qed. Definition tensor_swap {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ identity _ · identity _ #⊗ g = identity _ #⊗ g · f #⊗ identity _. Proof. rewrite <- tensor_split, <- tensor_split'. apply idpath. Qed. Definition tensor_swap' {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : identity _ #⊗ g · f #⊗ identity _ = f #⊗ identity _ · identity _ #⊗ g. Proof. rewrite <- tensor_split, <- tensor_split'. apply idpath. Qed. Definition mon_lunitor (x : V) : I_{V} ⊗ x --> x := monoidal_leftunitordata V x. Definition tensor_lunitor {x y : V} (f : x --> y) : identity _ #⊗ f · mon_lunitor y = mon_lunitor x · f. Proof. refine (_ @ pr1 (monoidal_leftunitorlaw V) x y f). apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_left _). apply maponpaths_2. apply (bifunctor_rightid V). Qed. Definition mon_linvunitor (x : V) : x --> I_{V} ⊗ x := monoidal_leftunitorinvdata V x. Definition tensor_linvunitor {x y : V} (f : x --> y) : f · mon_linvunitor y = mon_linvunitor x · identity _ #⊗ f. Proof. refine (!(monoidal_leftunitorinvnat V x y f) @ _). apply maponpaths. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid V). Qed. Definition mon_lunitor_linvunitor (x : V) : mon_lunitor x · mon_linvunitor x = identity _. Proof. exact (pr1 (monoidal_leftunitorisolaw V x)). Qed. Definition mon_linvunitor_lunitor (x : V) : mon_linvunitor x · mon_lunitor x = identity _. Proof. exact (pr2 (monoidal_leftunitorisolaw V x)). Qed. Definition mon_runitor (x : V) : x ⊗ I_{V} --> x := monoidal_rightunitordata V x. Definition tensor_runitor {x y : V} (f : x --> y) : f #⊗ identity _ · mon_runitor y = mon_runitor x · f. Proof. refine (_ @ pr1 (monoidal_rightunitorlaw V) x y f). apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). Qed. Definition mon_rinvunitor (x : V) : x --> x ⊗ I_{V} := monoidal_rightunitorinvdata V x. Definition tensor_rinvunitor {x y : V} (f : x --> y) : f · mon_rinvunitor y = mon_rinvunitor x · f #⊗ identity _. Proof. refine (!(monoidal_rightunitorinvnat V x y f) @ _). apply maponpaths. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply (bifunctor_leftid V). Qed. Definition mon_runitor_rinvunitor (x : V) : mon_runitor x · mon_rinvunitor x = identity _. Proof. exact (pr1 (monoidal_rightunitorisolaw V x)). Qed. Definition mon_rinvunitor_runitor (x : V) : mon_rinvunitor x · mon_runitor x = identity _. Proof. exact (pr2 (monoidal_rightunitorisolaw V x)). Qed. Definition mon_lassociator (x y z : V) : (x ⊗ y) ⊗ z --> x ⊗ (y ⊗ z) := α_{ V } x y z. Definition tensor_lassociator {x₁ x₂ y₁ y₂ z₁ z₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) (h : z₁ --> z₂) : (f #⊗ g) #⊗ h · mon_lassociator _ _ _ = mon_lassociator _ _ _ · f #⊗ (g #⊗ h). Proof. refine (!_). apply associator_nat2. Qed. Definition mon_rassociator (x y z : V) : x ⊗ (y ⊗ z) --> (x ⊗ y) ⊗ z := αinv_{ V } x y z. Definition tensor_rassociator {x₁ x₂ y₁ y₂ z₁ z₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) (h : z₁ --> z₂) : f #⊗ (g #⊗ h) · mon_rassociator _ _ _ = mon_rassociator _ _ _ · (f #⊗ g) #⊗ h. Proof. exact (monoidal_associatorinv_nat2 V f g h). Qed. Definition mon_lassociator_rassociator (x y z : V) : mon_lassociator x y z · mon_rassociator x y z = identity _. Proof. exact (pr1 (monoidal_associatorisolaw V x y z)). Qed. Definition mon_rassociator_lassociator (x y z : V) : mon_rassociator x y z · mon_lassociator x y z = identity _. Proof. exact (pr2 (monoidal_associatorisolaw V x y z)). Qed. Definition mon_triangle (x y : V) : mon_runitor x #⊗ identity y = mon_lassociator x I_{V} y · (identity x #⊗ mon_lunitor y). Proof. refine (_ @ !(monoidal_triangleidentity V x y) @ _). - unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). - apply maponpaths. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid V). Qed. Definition mon_inv_triangle (x y : V) : identity x #⊗ mon_linvunitor y = mon_rinvunitor x #⊗ identity y · mon_lassociator x (I_{V}) y. Proof. refine (!_). etrans. { apply maponpaths_2. refine (_ @ !(monoidal_triangle_identity_inv V x y)). unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). } rewrite !assoc'. etrans. { apply maponpaths. apply mon_rassociator_lassociator. } unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite (whiskerscommutes V). - apply maponpaths. refine (!_). apply (bifunctor_rightid V). - apply (bifunctor_equalwhiskers V). Qed. Definition mon_lunitor_triangle (x y : V) : mon_lassociator (I_{V}) x y · mon_lunitor (x ⊗ y) = mon_lunitor x #⊗ identity y. Proof. refine (right_whisker_with_lunitor V x y @ _). unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply (bifunctor_leftid V). Qed. Definition mon_linvunitor_triangle (x y : V) : mon_linvunitor x #⊗ identity y · mon_lassociator (I_{V}) x y = mon_linvunitor (x ⊗ y). Proof. refine (!(id_right _) @ _). etrans. { apply maponpaths. exact (!(mon_lunitor_linvunitor _)). } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply mon_lunitor_triangle. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite <- tensor_comp_id_r. rewrite mon_linvunitor_lunitor. apply tensor_id_id. Qed. Definition mon_runitor_triangle (x y : V) : mon_rassociator x y (I_{V}) · mon_runitor (x ⊗ y) = identity x #⊗ mon_runitor y. Proof. etrans. { apply maponpaths. exact (!(left_whisker_with_runitor V x y)). } rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rassociator_lassociator. } rewrite id_left. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid V). Qed. Definition mon_rinvunitor_triangle (x y : V) : identity x #⊗ mon_rinvunitor y · mon_rassociator x y (I_{V}) = mon_rinvunitor (x ⊗ y). Proof. refine (!(id_right _) @ _). etrans. { apply maponpaths. exact (!(mon_runitor_rinvunitor _)). } rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply mon_runitor_triangle. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite <- tensor_comp_id_l. rewrite mon_rinvunitor_runitor. apply tensor_id_id. Qed. Definition mon_runitor_I_mon_lunitor_I : mon_runitor (I_{V}) = mon_lunitor (I_{V}). Proof. refine (!_). apply unitors_coincide_on_unit. Qed. Definition mon_lunitor_I_mon_runitor_I : mon_lunitor (I_{V}) = mon_runitor (I_{V}). Proof. rewrite mon_runitor_I_mon_lunitor_I. apply idpath. Qed. Definition mon_rinvunitor_I_mon_linvunitor_I : mon_rinvunitor (I_{V}) = mon_linvunitor (I_{V}). Proof. cbn. refine (!_). apply unitorsinv_coincide_on_unit. Qed. Definition mon_linvunitor_I_mon_rinvunitor_I : mon_linvunitor (I_{V}) = mon_rinvunitor (I_{V}). Proof. rewrite mon_rinvunitor_I_mon_linvunitor_I. apply idpath. Qed. Proposition mon_lassociator_lassociator {w x y z : V} : mon_lassociator (w ⊗ x) y z · mon_lassociator w x (y ⊗ z) = mon_lassociator w x y #⊗ identity z · mon_lassociator w (x ⊗ y) z · identity w #⊗ mon_lassociator x y z. Proof. refine (!(monoidal_pentagonidentity V w x y z) @ _). unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite (bifunctor_rightid V). rewrite (bifunctor_leftid V). rewrite !id_left, id_right. apply idpath. Qed. Proposition mon_lassociator_lassociator' {w x y z : V} : mon_lassociator (w ⊗ x) y z · mon_lassociator w x (y ⊗ z) · w ⊗^{V}_{l} mon_rassociator x y z = mon_lassociator w x y ⊗^{V}_{r} z · mon_lassociator w (x ⊗ y) z. Proof. etrans. { apply maponpaths_2. apply mon_lassociator_lassociator. } rewrite <- (when_bifunctor_becomes_leftwhiskering V). rewrite ! assoc'. etrans. { do 2 apply maponpaths. apply pathsinv0, tensor_comp_id_l. } etrans. { do 2 apply maponpaths. apply maponpaths. apply mon_lassociator_rassociator. } rewrite tensor_id_id. rewrite id_right. apply maponpaths_2. apply (when_bifunctor_becomes_rightwhiskering V). Qed. Proposition mon_rassociator_rassociator {w x y z : V} : mon_rassociator w x (y ⊗ z) · mon_rassociator (w ⊗ x) y z = identity w #⊗ mon_rassociator x y z · mon_rassociator w (x ⊗ y) z · mon_rassociator w x y #⊗ identity z. Proof. refine (!(monoidal_pentagon_identity_inv V w x y z) @ _). unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite (bifunctor_rightid V). rewrite (bifunctor_leftid V). rewrite !id_left, id_right. apply idpath. Qed. Definition monoidal_left_tensor_data (x : V) : functor_data V V. Proof. use make_functor_data. - exact (λ y, x ⊗ y). - exact (λ y₁ y₂ f, identity x #⊗ f). Defined. Proposition is_functor_monoidal_left_tensor (x : V) : is_functor (monoidal_left_tensor_data x). Proof. split. - intros y ; cbn. apply tensor_id_id. - intros y₁ y₂ y₃ f g ; cbn. apply tensor_comp_id_l. Qed. Definition monoidal_left_tensor (x : V) : V ⟶ V. Proof. use make_functor. - exact (monoidal_left_tensor_data x). - exact (is_functor_monoidal_left_tensor x). Defined. Definition monoidal_right_tensor_data (y : V) : functor_data V V. Proof. use make_functor_data. - exact (λ x, x ⊗ y). - exact (λ x₁ x₂ f, f #⊗ identity y). Defined. Proposition is_functor_monoidal_right_tensor (y : V) : is_functor (monoidal_right_tensor_data y). Proof. split. - intros x ; cbn. apply tensor_id_id. - intros x₁ x₂ x₃ f g ; cbn. apply tensor_comp_id_r. Qed. Definition monoidal_right_tensor (y : V) : V ⟶ V. Proof. use make_functor. - exact (monoidal_right_tensor_data y). - exact (is_functor_monoidal_right_tensor y). Defined. End MonoidalCatAccessors. Definition monoidal_cat_tensor_data (V : monoidal_cat) : functor_data (category_binproduct V V) V. Proof. use make_functor_data. - exact (λ x, pr1 x ⊗ pr2 x). - exact (λ x y f, pr1 f #⊗ pr2 f). Defined. Proposition is_functor_monoidal_cat_tensor (V : monoidal_cat) : is_functor (monoidal_cat_tensor_data V). Proof. split. - intro x ; cbn. apply tensor_id_id. - intros x y z f g ; cbn. apply tensor_comp_mor. Qed. Definition monoidal_cat_tensor (V : monoidal_cat) : category_binproduct V V ⟶ V. Proof. use make_functor. - exact (monoidal_cat_tensor_data V). - exact (is_functor_monoidal_cat_tensor V). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/CategoriesOfMonoids.v000066400000000000000000000175431451125700300254720ustar00rootroot00000000000000(** In this file, the category of monoids internal to a monoidal category is defined Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/CategoriesOfMonoidsWhiskered.v (git log -- UniMath/CategoryTheory/Monoidal/CategoriesOfMonoids.v gives information on a prior development for the "tensored" format of monoidal categories) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Section Category_of_Monoids. Context {C : category} (M : monoidal C). Notation "x ⊗ y" := (x ⊗_{M} y). Notation "x ⊗l f" := (x ⊗^{M}_{l} f) (at level 31). Notation "f ⊗r y" := (f ⊗^{M}_{r} y) (at level 31). Notation "f ⊗⊗ g" := (f ⊗^{M} g) (at level 31). Let I : C := monoidal_unit M. Let lu : leftunitor_data M (monoidal_unit M) := monoidal_leftunitordata M. Let ru : rightunitor_data M (monoidal_unit M) := monoidal_rightunitordata M. Let α : associator_data M := monoidal_associatordata M. Definition monoid_data (x : C) : UU := C⟦x ⊗ x, x⟧ × C⟦I, x⟧. Definition monoid_data_multiplication {x : C} (m : monoid_data x) : C⟦x ⊗ x, x⟧ := pr1 m. Notation "μ_{ m }" := (monoid_data_multiplication m). Definition monoid_data_unit {x : C} (m : monoid_data x) : C⟦I, x⟧ := pr2 m. Notation "η_{ m }" := (monoid_data_unit m). Definition monoid_laws_assoc {x : C} (m : monoid_data x) : UU := α x x x · (x ⊗l μ_{m}) · μ_{m} = μ_{m} ⊗r x · μ_{m}. Definition monoid_laws_unit_left {x : C} (m : monoid_data x) : UU := (η_{m} ⊗r x) · μ_{m} = lu x. Definition monoid_laws_unit_right {x : C} (m : monoid_data x) : UU := (x ⊗l η_{m}) · μ_{m} = ru x. Definition monoid_laws {x : C} (m : monoid_data x) : UU := monoid_laws_unit_left m × monoid_laws_unit_right m × monoid_laws_assoc m. Lemma isaprop_monoid_laws {x : C} (m : monoid_data x) : isaprop (monoid_laws m). Proof. repeat (apply isapropdirprod) ; apply homset_property. Qed. Definition monoid (x : C) : UU := ∑ m : monoid_data x, monoid_laws m. Definition make_monoid {x : C} (μ : C⟦x ⊗ x, x⟧) (η : C⟦monoidal_unit M, x⟧) (p_ul : (η ⊗r x) · μ = lu x) (p_ur : (x ⊗l η) · μ = ru x) (p_assoc : α x x x · (x ⊗l μ) · μ = μ ⊗r x · μ) : monoid x. Proof. simple refine ((_ ,, _) ,, (_ ,, _ ,, _)). - exact μ. - exact η. - exact p_ul. - exact p_ur. - exact p_assoc. Defined. Definition monoid_to_monoid_data {x : C} (m : monoid x) : monoid_data x := pr1 m. Coercion monoid_to_monoid_data : monoid >-> monoid_data. Definition monoid_to_monoid_laws {x : C} (m : monoid x) : monoid_laws m := pr2 m. Definition monoid_to_unit_left_law {x : C} (m : monoid x) : monoid_laws_unit_left m := pr1 (monoid_to_monoid_laws m). Definition monoid_to_unit_right_law {x : C} (m : monoid x) : monoid_laws_unit_right m := pr12 (monoid_to_monoid_laws m). Definition monoid_to_assoc_law {x : C} (m : monoid x) : monoid_laws_assoc m := pr22 (monoid_to_monoid_laws m). Definition is_monoid_mor_mult {x y : C} (mx : monoid x) (my : monoid y) (f : C⟦x,y⟧) : UU := (f ⊗⊗ f) · μ_{my} = μ_{mx} · f. Definition is_monoid_mor_unit {x y : C} (mx : monoid x) (my : monoid y) (f : C⟦x,y⟧) : UU := η_{mx} · f = η_{my}. Definition is_monoid_mor {x y : C} (mx : monoid x) (my : monoid y) (f : C⟦x,y⟧) : UU := is_monoid_mor_mult mx my f × is_monoid_mor_unit mx my f. Lemma isaprop_is_monoid_mor {x y : C} (mx : monoid x) (my : monoid y) (f : C⟦x,y⟧) : isaprop (is_monoid_mor mx my f). Proof. apply isapropdirprod ; apply homset_property. Qed. Definition monoid_disp_cat_ob_mor : disp_cat_ob_mor C. Proof. exists (λ x, monoid x). exact (λ x y mx my f, is_monoid_mor mx my f). Defined. Lemma id_is_monoid_mor {x : C} (xx : monoid x) : is_monoid_mor xx xx (identity x). Proof. split. - refine (_ @ ! id_right _). etrans. { apply maponpaths_2, bifunctor_distributes_over_id. apply (bifunctor_leftid M). apply (bifunctor_rightid M). } apply id_left. - apply id_right. Qed. Lemma comp_is_monoid_mor {x y z : C} {f : C ⟦ x, y ⟧} {g : C ⟦ y, z ⟧} {xx : monoid x} {yy : monoid y} {zz : monoid z} (pf : is_monoid_mor xx yy f) (pg : is_monoid_mor yy zz g) : is_monoid_mor xx zz (f · g). Proof. split. - etrans. { apply maponpaths_2. apply bifunctor_distributes_over_comp. apply (bifunctor_leftcomp M). apply (bifunctor_rightcomp M). apply (bifunctor_equalwhiskers M). } etrans. 1: apply assoc'. etrans. 1: apply maponpaths, (pr1 pg). etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, (pr1 pf). apply assoc'. - unfold is_monoid_mor_unit. etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, (pr2 pf). apply (pr2 pg). Qed. Definition monoid_disp_cat_id_comp : disp_cat_id_comp C monoid_disp_cat_ob_mor. Proof. split. - intro ; intro ; apply id_is_monoid_mor. - intros x y z f g xx yy zz pf pg. exact (comp_is_monoid_mor pf pg). Qed. Definition monoid_disp_cat_data : disp_cat_data C. Proof. exists monoid_disp_cat_ob_mor. exact monoid_disp_cat_id_comp. Defined. Definition monoid_disp_cat_axioms : disp_cat_axioms C monoid_disp_cat_data. Proof. repeat split ; intro ; intros ; try (apply isaprop_is_monoid_mor). apply isasetaprop ; apply isaprop_is_monoid_mor. Qed. Definition monoid_disp_cat : disp_cat C. Proof. exists monoid_disp_cat_data. exact monoid_disp_cat_axioms. Defined. Definition category_of_monoids_in_monoidal_cat : category := total_category monoid_disp_cat. Let MON : category := category_of_monoids_in_monoidal_cat. Definition monoid_carrier (X : MON) : ob C := pr1 X. Definition monoid_struct (X : MON) : monoid (monoid_carrier X) := pr2 X. Definition monoid_multiplication (X : MON) : C⟦monoid_carrier X ⊗_{ M} monoid_carrier X, monoid_carrier X⟧ := monoid_data_multiplication (monoid_struct X). Definition monoid_unit (X : MON) : C⟦I, monoid_carrier X⟧ := monoid_data_unit (monoid_struct X). Definition monoid_left_unit_law (X : MON) : monoid_laws_unit_left (monoid_struct X) := monoid_to_unit_left_law (monoid_struct X). Definition monoid_right_unit_law (X : MON) : monoid_laws_unit_right (monoid_struct X) := monoid_to_unit_right_law (monoid_struct X). Definition monoid_assoc_law (X : MON) : monoid_laws_assoc (monoid_struct X) := monoid_to_assoc_law (monoid_struct X). End Category_of_Monoids. Definition unit_monoid (V : monoidal_cat) : monoid V (monoidal_unit V). Proof. use make_monoid. - exact (monoidal_leftunitordata V (monoidal_unit V)). - exact (identity (monoidal_unit V)). - etrans. { apply maponpaths_2. apply (bifunctor_rightid V). } apply id_left. - etrans. { apply maponpaths_2. apply (bifunctor_leftid V). } refine (id_left _ @ _). apply unitors_coincide_on_unit. - apply maponpaths_2. etrans. 2: { rewrite unitors_coincide_on_unit. apply monoidal_triangleidentity. } apply idpath. Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/000077500000000000000000000000001451125700300233205ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/CartesianAsComonoids.v000066400000000000000000000354471451125700300275740ustar00rootroot00000000000000(* In this file, we show: if a symmetric monoidal category is cartesian, the forgetful functor from the category of commutative comonoids is an isomorphism of categories. The converse of this statement remains to be done. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.CatIsoDisplayed. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Tensor. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Symmetric. Import MonoidalNotations. Import ComonoidNotations. Local Open Scope cat. Local Open Scope moncat. Section CartesianToCartesianAsComonoids. Context {M : monoidal_cat} (Ccart : is_cartesian M). Let V : sym_monoidal_cat := M,, cartesian_to_symmetric Ccart. Let diag (x : V) : V⟦x, x ⊗ x⟧ := diagonalMap' (is_cartesian_BinProduct Ccart) x. Let aug (x : V) : V⟦x, monoidal_unit M⟧ := (semi_cart_to_unit Ccart x). Lemma identity_of_lwhisker_with_unit (x : V) : monoidal_cat_tensor_mor (aug (monoidal_unit M)) (identity x) = identity (_ ⊗ x). Proof. refine (_ @ tensor_id_id _ _). apply maponpaths_2. apply (semi_cart_to_unit_eq Ccart). Qed. Lemma identity_of_rwhisker_with_unit (x : V) : monoidal_cat_tensor_mor (identity x) (aug I_{M}) = identity (x ⊗ I_{V}). Proof. refine (_ @ tensor_id_id _ _). apply maponpaths. apply (semi_cart_to_unit_eq Ccart). Qed. Lemma cartesian_lunitor (x : V) : semi_cart_tensor_pr2 (pr1 Ccart) I_{ M} x = mon_lunitor x. Proof. refine (_ @ id_left _). unfold semi_cart_tensor_pr2. apply maponpaths_2. apply identity_of_lwhisker_with_unit. Qed. Lemma cartesian_runitor (x : V) : semi_cart_tensor_pr1 (pr1 Ccart) x I_{M} = mon_runitor x. Proof. refine (_ @ id_left _). unfold semi_cart_tensor_pr1. apply maponpaths_2. apply identity_of_rwhisker_with_unit. Qed. Lemma cartesian_linvunitor (x : V) : BinProductArrow V (is_cartesian_BinProduct Ccart I_{ M} x) (semi_cart_to_unit Ccart x) (identity x) = mon_linvunitor x. Proof. apply pathsinv0. use BinProductArrowUnique. - apply (semi_cart_to_unit_eq Ccart). - etrans. { apply maponpaths. apply cartesian_lunitor. } apply monoidal_leftunitorisolaw. Qed. Lemma cartesian_linvunitor' (x : V) : diag x · semi_cart_to_unit Ccart x ⊗^{M}_{r} x = mon_linvunitor x. Proof. etrans. { refine (_ @ postcompWithBinProductArrow _ (is_cartesian_BinProduct Ccart _ _) (is_cartesian_BinProduct Ccart _ _) (semi_cart_to_unit Ccart x) (identity x) (identity x) (identity x)). apply maponpaths. rewrite <- (when_bifunctor_becomes_rightwhiskering M). exact (cartesian_tensor_mor Ccart (semi_cart_to_unit Ccart x) (identity x)). } do 2 rewrite id_left. exact (cartesian_linvunitor x). Qed. Lemma cartesian_rinvunitor (x : V) : BinProductArrow V (is_cartesian_BinProduct Ccart x I_{ M}) (identity x) (semi_cart_to_unit Ccart x) = mon_rinvunitor x. Proof. apply pathsinv0. use BinProductArrowUnique. - etrans. { apply maponpaths. apply cartesian_runitor. } apply monoidal_rightunitorisolaw. - apply (semi_cart_to_unit_eq Ccart). Qed. Lemma cartesian_rinvunitor' (x : V) : diag x · x ⊗^{ M}_{l} aug x = mon_rinvunitor x. Proof. etrans. { refine (_ @ postcompWithBinProductArrow _ (is_cartesian_BinProduct Ccart _ _) (is_cartesian_BinProduct Ccart _ _) (identity x) (semi_cart_to_unit Ccart x) (identity x) (identity x)). apply maponpaths. rewrite <- (when_bifunctor_becomes_leftwhiskering M). exact (cartesian_tensor_mor Ccart (identity x) (semi_cart_to_unit Ccart x)). } do 2 rewrite id_left. exact (cartesian_rinvunitor x). Qed. Lemma cartesian_associator (x y z : V) : mon_lassociator x y z = BinProductArrow V (is_cartesian_BinProduct Ccart _ _) (semi_cart_tensor_pr1 Ccart _ _ · semi_cart_tensor_pr1 Ccart _ _) (semi_cart_tensor_pr2 Ccart _ _ ⊗^{M}_{r} z). Proof. use (BinProductArrowUnique _ _ _ (is_cartesian_BinProduct Ccart _ _)). - apply (mon_lassociator_pr1 Ccart). - refine (mon_lassociator_pr2 Ccart x y z @ _). unfold monoidal_cat_tensor_mor. now apply (when_bifunctor_becomes_rightwhiskering M). Qed. Lemma BinProductArrow_as_diag (x y z : V) (f : V⟦x,y⟧) (g : V⟦x,z⟧) : diag x · f #⊗ g = BinProductArrow V (is_cartesian_BinProduct Ccart y z) f g. Proof. etrans. { apply maponpaths. apply (cartesian_tensor_mor Ccart). } etrans. { apply (postcompWithBinProductArrow _ (is_cartesian_BinProduct Ccart y z) (is_cartesian_BinProduct Ccart x x)). } now do 2 rewrite id_left. Qed. Lemma diag_is_symmetric (x : V) : diag x · cartesian_to_braiding_data Ccart x x = diag x. Proof. apply (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct Ccart x x)). - rewrite assoc'. etrans. { apply maponpaths. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). } etrans. { apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). } apply pathsinv0, (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). - rewrite assoc'. etrans. { apply maponpaths. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). } etrans. { apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). } apply pathsinv0, (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). Qed. Lemma diagonal_commutes_with_assoc (x : V) : diag x · diag x ⊗^{M}_{r} x · mon_lassociator x x x = diag x · x ⊗^{M}_{l} diag x. Proof. rewrite cartesian_associator. etrans. { apply cancel_postcomposition. etrans. { apply maponpaths. apply pathsinv0, (when_bifunctor_becomes_rightwhiskering M). } apply BinProductArrow_as_diag. } etrans. 2: { etrans. 2: { apply maponpaths. apply (when_bifunctor_becomes_leftwhiskering M). } apply pathsinv0, BinProductArrow_as_diag. } etrans. { apply (precompWithBinProductArrow _ (is_cartesian_BinProduct Ccart x (x ⊗ x))). } apply maponpaths_12. - rewrite assoc. etrans. { apply cancel_postcomposition. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct Ccart _ _)). } apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct Ccart x x)). - etrans. { apply maponpaths. etrans. { apply pathsinv0, (when_bifunctor_becomes_rightwhiskering M). } apply (cartesian_tensor_mor Ccart). } etrans. { apply (postcompWithBinProductArrow _ (is_cartesian_BinProduct Ccart x x) (is_cartesian_BinProduct Ccart (is_cartesian_BinProduct Ccart x x) x)). } unfold diag at 2; unfold diagonalMap'; apply maponpaths_12. + apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct Ccart _ _)). + apply id_left. Qed. Definition cartesian_comonoid_data (x : V) : comonoid_data V := x ,, diag x ,, aug x. Lemma cartesian_comonoid_laws (x : V) : comonoid_laws M (cartesian_comonoid_data x). Proof. repeat split. - unfold comonoid_laws_unit_left. cbn. refine (_ @ mon_linvunitor_lunitor x). apply maponpaths_2. exact (cartesian_linvunitor' x). - unfold comonoid_laws_unit_right. cbn. refine (_ @ mon_rinvunitor_runitor x). apply maponpaths_2. exact (cartesian_rinvunitor' x). - unfold comonoid_laws_assoc. cbn. apply diagonal_commutes_with_assoc. Qed. Definition cartesian_monoidal_has_enough_comonoids : ∏ x : V, comonoid M. Proof. intro x. refine (x ,, _ ,, _). exact (cartesian_comonoid_laws x). Defined. Definition cartesian_monoidal_has_enough_comm_comonoids : ∏ x : V, disp_cat_of_commutative_comonoids V x. Proof. intro x. exists (comonoid_to_struct V (cartesian_monoidal_has_enough_comonoids x)). apply diag_is_symmetric. Defined. Lemma cartesian_monoidal_has_unique_comonoids : ∏ x : V, iscontr (disp_cat_of_comonoids V x). Proof. intro x. exists (comonoid_to_struct V (cartesian_monoidal_has_enough_comonoids x)). intro m. use subtypePath. { intro ; apply isaprop_comonoid_laws. } apply dirprodeq. - use (BinProductArrowUnique _ _ _ (is_cartesian_BinProduct Ccart x x)). + refine (_ @ comonoid_to_law_unit_right _ (_,,m)). cbn. unfold semi_cart_tensor_pr1. rewrite ! assoc. apply maponpaths_2. apply maponpaths. unfold monoidal_cat_tensor_mor. rewrite (when_bifunctor_becomes_leftwhiskering M). apply maponpaths. apply (semi_cart_to_unit_eq Ccart). + refine (_ @ comonoid_to_law_unit_left _ (_,,m)). cbn. unfold semi_cart_tensor_pr2. rewrite ! assoc. apply maponpaths_2. apply maponpaths. unfold monoidal_cat_tensor_mor. rewrite (when_bifunctor_becomes_rightwhiskering M). apply maponpaths. apply (semi_cart_to_unit_eq Ccart). - apply (semi_cart_to_unit_eq Ccart). Qed. Lemma cartesian_monoidal_has_unique_comm_comonoids : ∏ x : V, iscontr (disp_cat_of_commutative_comonoids V x). Proof. intro x. apply iscontraprop1. - apply isaproptotal2. + intro ; apply homset_property. + intro ; intros. apply proofirrelevance. apply isapropifcontr. apply cartesian_monoidal_has_unique_comonoids. - apply cartesian_monoidal_has_enough_comm_comonoids. Defined. Lemma cartesian_monoidal_has_enough_comonoids_mor_comult {x y : V} (f : V⟦x, y⟧) : is_comonoid_mor_comult V (cartesian_monoidal_has_enough_comonoids x) (cartesian_monoidal_has_enough_comonoids y) f. Proof. etrans. 2: { apply pathsinv0. apply (precompWithBinProductArrow _ (is_cartesian_BinProduct Ccart y y)). } rewrite id_right. etrans. { apply maponpaths. apply (cartesian_tensor_mor Ccart). } etrans. { apply (postcompWithBinProductArrow _ (is_cartesian_BinProduct Ccart _ _) (is_cartesian_BinProduct Ccart _ _) f f ). } now rewrite id_left. Qed. Definition cartesian_monoidal_has_enough_comonoids_mor {x y : V} (f : V⟦x, y⟧) : comonoid_mor_struct V (cartesian_monoidal_has_enough_comonoids x) (cartesian_monoidal_has_enough_comonoids y) f. Proof. use make_is_comonoid_mor. - exact (cartesian_monoidal_has_enough_comonoids_mor_comult f). - apply (semi_cart_to_unit_eq Ccart). Qed. Lemma cartesian_monoidal_has_enough_comonoids_mor' {x y : V} (f : V⟦x, y⟧) : diag x · f #⊗ f = f · diag y × aug x · identity (monoidal_unit V) = f · aug y. Proof. split. - exact (cartesian_monoidal_has_enough_comonoids_mor_comult f). - apply (semi_cart_to_unit_eq Ccart). Qed. Lemma comult_is_diag {c : V} (m : disp_cat_of_commutative_comonoids V c) : δ_{(_ ,, pr1 m) : comonoid V} = diag c. Proof. refine (idpath (pr111 m) @ _). (* the triple projection is presented to apply maponpaths without an argument *) etrans. { do 3 apply maponpaths. exact (proofirrelevancecontr (cartesian_monoidal_has_unique_comm_comonoids c) m (cartesian_monoidal_has_enough_comm_comonoids c)). } apply idpath. Qed. Lemma cartesian_monoidal_has_enough_comm_comonoids_mor_mult_diag {c1 c2 : V} (m1 : disp_cat_of_commutative_comonoids V c1) (m2 : disp_cat_of_commutative_comonoids V c2) (f : V ⟦ c1, c2 ⟧) : δ_{(_ ,, pr1 m1) : comonoid V} · f #⊗ f = f · δ_{(_ ,, pr1 m2) : comonoid V}. Proof. refine (_ @ cartesian_monoidal_has_enough_comonoids_mor_comult f @ _). -- apply maponpaths_2. apply comult_is_diag. -- apply maponpaths. apply pathsinv0, comult_is_diag. Qed. Definition cartesian_mon_is_comm_comonoids : is_catiso (pr1_category (disp_cat_of_commutative_comonoids V)). Proof. apply forgetful_is_iso_univ. - apply disp_cat_of_commutative_comonoids_is_univalent. - apply cartesian_monoidal_has_enough_comm_comonoids. - intro ; intros. use (iscontrweqf (weqtodirprodwithunit _)). use (iscontrweqf (weqtodirprodwithunit _)). apply iscontraprop1. { apply isapropdirprod ; apply homset_property. } split. + apply cartesian_monoidal_has_enough_comm_comonoids_mor_mult_diag. + apply (semi_cart_to_unit_eq Ccart). Qed. End CartesianToCartesianAsComonoids. (* Section CartesianFromComonoidsToCartesian. Context {C : category} {M : monoidal C} (S : symmetric M). Context (i_i : is_catiso (pr1_category (commutative_comonoids_disp_cat_over_base S))). Let inv_i := inv_catiso (_ ,, i_i). Let F_i := functor_from_catiso _ _ (_ ,, i_i). Definition cartesian_mon_from_comm_comonoids : is_cartesian (C,,M). Proof. use symm_monoidal_is_cartesian_from_comonoid. - exact S. - intro ; apply (catiso_is_globally_contr i_i). - intro ; intros. (* apply catiso_is_locally_contr. *) admit. - admit. - intro ; intro. admit. Admitted. End CartesianFromComonoidsToCartesian. *) UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/Category.v000066400000000000000000000456751451125700300253050ustar00rootroot00000000000000(** In this file, the category of comonoids internal to a monoidal category is defined. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.Examples.DiagonalFunctor. Require Import UniMath.CategoryTheory.Monoidal.Examples.ConstantFunctor. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.categories.Dialgebras. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section CategoryOfComonoids. Context (V : monoidal_cat). Definition disp_cat_of_comonoids_data : disp_cat V := dirprod_disp_cat (dialgebra_disp_cat (functor_identity V) (diag_functor V)) (dialgebra_disp_cat (functor_identity V) (constant_functor _ _ I_{V})). Definition comonoid_struct_data (x : V) : UU := disp_cat_of_comonoids_data x. Definition comonoid_data : UU := total_category disp_cat_of_comonoids_data. Definition comonoid_ob (m : comonoid_data) : ob V := pr1 m. Coercion comonoid_ob : comonoid_data >-> ob. Definition comonoid_comult (m : comonoid_data) : V⟦m , m ⊗ m⟧ := pr12 m. Notation "δ_{ m }" := (comonoid_comult m). Definition comonoid_counit (m : comonoid_data) : V⟦m , monoidal_unit V⟧ := pr22 m. Notation "ε_{ m }" := (comonoid_counit m). Definition comonoid_laws_assoc (m : comonoid_data) : UU := δ_{m} · (δ_{m} ⊗^{V}_{r} m) · mon_lassociator m m m = δ_{m} · m ⊗^{V}_{l} δ_{m}. Definition comonoid_laws_unit_left (m : comonoid_data) : UU := δ_{m} · (ε_{m} ⊗^{V}_{r} m) · mon_lunitor m = identity (comonoid_ob m). Definition comonoid_laws_unit_right (m : comonoid_data) : UU := δ_{m} · (m ⊗^{V}_{l} ε_{m}) · mon_runitor m = identity (comonoid_ob m). Definition comonoid_laws (m : comonoid_data) : UU := comonoid_laws_unit_left m × comonoid_laws_unit_right m × comonoid_laws_assoc m. Lemma isaprop_comonoid_laws (m : comonoid_data) : isaprop (comonoid_laws m). Proof. repeat (apply isapropdirprod) ; apply homset_property. Qed. Definition comonoid_laws_disp_cat : disp_cat (total_category disp_cat_of_comonoids_data). Proof. exact (disp_full_sub _ (λ m, comonoid_laws m)). Defined. Lemma locally_propositional_comonoid_laws_disp_cat : locally_propositional comonoid_laws_disp_cat. Proof. intro ; intros ; apply isapropunit. Qed. Definition disp_cat_of_comonoids : disp_cat V := sigma_disp_cat comonoid_laws_disp_cat. Definition comonoid_struct (x : V) : UU := disp_cat_of_comonoids x. Definition comonoid_category : category := total_category disp_cat_of_comonoids. Definition comonoid : UU := total_category disp_cat_of_comonoids. Definition comonoid_to_struct (m : comonoid) : comonoid_struct (pr1 m) := pr12 m ,, pr22 m. Definition comonoid_to_data (m : comonoid) : comonoid_data := pr1 m ,, pr12 m. Coercion comonoid_to_data : comonoid >-> comonoid_data. Definition comonoid_to_law_assoc (m : comonoid) : comonoid_laws_assoc m := pr2 (pr222 m). Definition comonoid_to_law_unit_left (m : comonoid) : comonoid_laws_unit_left m := pr122 m. Definition comonoid_to_law_unit_right (m : comonoid) : comonoid_laws_unit_right m := pr1 (pr222 m). Definition comonoid_mor_struct (m n : comonoid) (f : V⟦m,n⟧): UU := (comonoid_to_struct m) -->[f] (comonoid_to_struct n). Definition make_is_comonoid_mor {m n : comonoid} {f : V⟦m,n⟧} (f_δ : δ_{m} · f #⊗ f = f · δ_{n}) (f_ε : ε_{m} · identity I_{ V} = f · ε_{n}) : comonoid_mor_struct m n f. Proof. simple refine ((_ ,, _) ,, _). - exact f_δ. - exact f_ε. - exact tt. Defined. Definition comonoid_mor (m n : comonoid) : UU := (total_category disp_cat_of_comonoids)⟦m,n⟧. Definition is_comonoid_mor_comult (m n : comonoid) (f : V⟦m,n⟧) : UU := δ_{m} · (f #⊗ f) = f · δ_{n}. Definition comonoid_mor_comult_law {m n : comonoid} (f : comonoid_mor m n) : is_comonoid_mor_comult m n (pr1 f) (* δ_{m} · (pr1 f ⊗⊗ pr1 f) = pr1 f · δ_{n} *) := pr112 f. Definition is_comonoid_mor_counit (m n : comonoid) (f : V⟦m,n⟧) : UU := f · ε_{n} = ε_{m}. Definition comonoid_mor_counit_law {m n : comonoid} (f : comonoid_mor m n) : is_comonoid_mor_counit m n (pr1 f) (* pr1 f · ε_{n} = ε_{m} *) := ! pr212 f @ id_right _. Lemma is_locally_propositional_comonoid : locally_propositional disp_cat_of_comonoids. Proof. intro ; intros. use (isaprop_total2 (_ ,, _) (λ _ , _ ,, isapropunit)). apply (isaprop_total2 (_ ,, homset_property _ _ _ _ _) (λ _ , _ ,, homset_property _ _ _ _ _)). Qed. End CategoryOfComonoids. Module ComonoidNotations. Notation "δ_{ m }" := (comonoid_comult _ m). Notation "ε_{ m }" := (comonoid_counit _ m). End ComonoidNotations. Section CategoryOfCommutativeComonoids. Context (V : sym_monoidal_cat). Import ComonoidNotations. Definition is_commutative (m : comonoid V) : UU := δ_{m} · sym_mon_braiding V m m = δ_{m}. Definition commutative_comonoids_laws_disp_cat : disp_cat (comonoid_category V). Proof. exact (disp_full_sub _ is_commutative). Defined. Definition disp_cat_of_commutative_comonoids := sigma_disp_cat commutative_comonoids_laws_disp_cat. Definition commutative_comonoid_category : category := total_category disp_cat_of_commutative_comonoids. Definition commutative_comonoid : UU := total_category disp_cat_of_commutative_comonoids. Definition commutative_comonoid_to_comonoid (m : commutative_comonoid) : comonoid V := pr1 m ,, pr12 m. Coercion commutative_comonoid_to_comonoid : commutative_comonoid >-> comonoid. Definition commutative_comonoid_is_commutative (m : commutative_comonoid) : is_commutative m := pr22 m. Lemma is_locally_propositional_commutative_comonoid : locally_propositional disp_cat_of_commutative_comonoids. Proof. intro ; intros. use (isaprop_total2 (_ ,, _) (λ _ , _ ,, isapropunit)). use (isaprop_total2 (_ ,, _) (λ _ , _ ,, isapropunit)). apply (isaprop_total2 (_ ,, homset_property _ _ _ _ _) (λ _ , _ ,, homset_property _ _ _ _ _)). Qed. Definition underlying_commutative_comonoid : commutative_comonoid_category ⟶ V := pr1_category _. End CategoryOfCommutativeComonoids. Section CommutativeComonoidsMorBuilder. Import ComonoidNotations. Context {V : sym_monoidal_cat} (C₁ C₂ : commutative_comonoid V) (f : underlying_commutative_comonoid _ C₁ --> underlying_commutative_comonoid _ C₂) (fδ : δ_{C₁} · f #⊗ f = f · δ_{C₂}) (fε : ε_{C₁} = f · ε_{C₂}). Definition make_commutative_comonoid_mor : C₁ --> C₂. Proof. refine (f ,, ((_ ,, _) ,, tt) ,, tt). - exact fδ. - abstract (cbn ; rewrite id_right ; exact fε). Defined. End CommutativeComonoidsMorBuilder. Definition underlying_comonoid_mor {V : sym_monoidal_cat} {C₁ C₂ : commutative_comonoid V} (f : C₁ --> C₂) : underlying_commutative_comonoid _ C₁ --> underlying_commutative_comonoid _ C₂ := pr1 f. Section CommutativeComonoidsMorProjections. Import ComonoidNotations. Context {V : sym_monoidal_cat} {C₁ C₂ : commutative_comonoid V} (f : C₁ --> C₂). Proposition underlying_comonoid_mor_comult : δ_{C₁} · underlying_comonoid_mor f #⊗ underlying_comonoid_mor f = underlying_comonoid_mor f · δ_{C₂}. Proof. exact (pr1 (pr112 f)). Qed. Proposition underlying_comonoid_mor_counit : ε_{C₁} = underlying_comonoid_mor f · ε_{C₂}. Proof. refine (_ @ pr2 (pr112 f)). exact (!(id_right _)). Qed. End CommutativeComonoidsMorProjections. (** This gives a more convenient builder for commutative comonoids for the bundled version. Note: only one identity law has to be proven *) Section MakeCommutativeComonoid. Context {V : sym_monoidal_cat} (x : V) (δ : x --> x ⊗ x) (ε : x --> I_{V}) (unit_left : δ · (ε #⊗ identity x) · mon_lunitor x = identity x) (assocδ : δ · (δ #⊗ identity x) · mon_lassociator x x x = δ · (identity x #⊗ δ)) (comm : δ · sym_mon_braiding V x x = δ). Definition make_commutative_comonoid_data : comonoid_data V := x ,, δ ,, ε. Proposition make_commutative_comonoid_laws : comonoid_laws V make_commutative_comonoid_data. Proof. repeat split. - refine (_ @ unit_left) ; cbn. apply maponpaths_2. apply maponpaths. rewrite tensor_mor_right. apply idpath. - refine (_ @ unit_left) ; cbn. refine (!_). etrans. { do 2 apply maponpaths_2. exact (!(comm)). } rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. rewrite sym_mon_braiding_lunitor. apply maponpaths_2. rewrite tensor_mor_left. apply idpath. - unfold comonoid_laws_assoc ; cbn. refine (_ @ assocδ @ _). + apply maponpaths_2. apply maponpaths. rewrite tensor_mor_right. apply idpath. + apply maponpaths. rewrite tensor_mor_left. apply idpath. Qed. Definition make_commutative_comonoid : commutative_comonoid V. Proof. simple refine (x ,, ((δ ,, ε) ,, _) ,, _) ; cbn. - exact make_commutative_comonoid_laws. - exact comm. Defined. End MakeCommutativeComonoid. Section ComonoidAux. Context (M : monoidal_cat). Import ComonoidNotations. Definition comonoid_laws_assoc' (m : comonoid M) : δ_{m} · (δ_{m} ⊗^{M}_{r} m) = δ_{m} · m ⊗^{M}_{l} δ_{m} · mon_rassociator m m m. Proof. rewrite <- comonoid_to_law_assoc. rewrite ! assoc'. etrans. 2: { do 2 apply maponpaths. apply pathsinv0. apply monoidal_associatorisolaw. } now rewrite id_right. Qed. Definition comonoid_laws_unit_left' (m : comonoid M) : δ_{m} · (ε_{m} ⊗^{M}_{r} m) = mon_linvunitor m. Proof. refine (_ @ id_left _). rewrite <- comonoid_to_law_unit_left. rewrite ! assoc'. etrans. 2: { do 2 apply maponpaths. apply pathsinv0. apply monoidal_leftunitorisolaw. } now rewrite id_right. Qed. Definition comonoid_laws_unit_right' (m : comonoid M) : δ_{m} · (m ⊗^{M}_{l} ε_{m}) = mon_rinvunitor m. Proof. refine (_ @ id_left _). rewrite <- (comonoid_to_law_unit_right M _). rewrite ! assoc'. etrans. 2: { do 2 apply maponpaths. apply pathsinv0. apply monoidal_rightunitorisolaw. } now rewrite id_right. Qed. End ComonoidAux. Section CommutativeComonoids. Context (M : sym_monoidal_cat). Import ComonoidNotations. Lemma comultiplication_comonoid_4times' (m : comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} = δ_{m} · δ_{m} ⊗^{M}_{r} m · mon_lassociator _ _ _ · δ_{m} ⊗^{M}_{r} _. Proof. etrans. { apply maponpaths. apply (bifunctor_equalwhiskers M). } unfold functoronmorphisms2. rewrite assoc. apply maponpaths_2. apply pathsinv0. apply comonoid_to_law_assoc. Qed. Lemma comultiplication_comonoid_4times_symmetry (m : commutative_comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} · (sym_mon_braiding M m m #⊗ sym_mon_braiding M m m) = δ_{m} · δ_{m} #⊗ δ_{m}. Proof. rewrite assoc'. apply maponpaths. refine (! tensor_comp_mor _ _ _ _ @ _). now rewrite commutative_comonoid_is_commutative. Qed. Lemma comultiplication_comonoid_4times_symmetry_left (m : commutative_comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} · (sym_mon_braiding M m m ⊗^{M}_{r} (m ⊗_{M} m)) = δ_{m} · δ_{m} #⊗ δ_{m}. Proof. rewrite assoc'. apply maponpaths. rewrite <- (when_bifunctor_becomes_rightwhiskering M). refine (! tensor_comp_mor _ _ _ _ @ _). rewrite id_right. apply maponpaths_2. apply commutative_comonoid_is_commutative. Qed. Lemma commutative_symmetric_braiding_using_lwhisker (m : commutative_comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} · α^{M}_{_,_,_} = δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (m ⊗^{M}_{l} δ_{m})). Proof. etrans. 2: { apply maponpaths_2. apply comonoid_to_law_assoc. } rewrite ! assoc'. apply maponpaths. apply pathsinv0. etrans. { apply maponpaths. apply (monoidal_associatornatleft M). } now rewrite ! assoc. Qed. Lemma commutative_symmetric_braiding_using_lrwhisker (m : commutative_comonoid M) : δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (m ⊗^{M}_{l} δ_{m})) · m ⊗^{M}_{l} mon_rassociator _ _ _ = δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (δ_{m} ⊗^{M}_{r} m)). Proof. rewrite ! assoc'. apply maponpaths. rewrite <- (bifunctor_leftcomp M). etrans. { apply pathsinv0, (bifunctor_leftcomp M). } etrans. 2: { apply (bifunctor_leftcomp M). } apply maponpaths. refine (_ @ ! comonoid_laws_assoc' M m). apply assoc. Qed. Lemma commutative_symmetric_braiding_using_lrwhisker' (m : commutative_comonoid M) : δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (δ_{m} ⊗^{M}_{r} m)) · m ⊗^{M}_{l} ((sym_mon_braiding M m m) ⊗^{M}_{r} m) = δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (δ_{m} ⊗^{M}_{r} m)). Proof. rewrite ! assoc'. do 2 apply maponpaths. rewrite <- (bifunctor_leftcomp M). apply maponpaths. rewrite <- (bifunctor_rightcomp M). apply maponpaths. apply commutative_comonoid_is_commutative. Qed. Lemma commutative_symmetric_braiding_using_lrwhisker'' (m : commutative_comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} · α^{M}_{_,_,_} · m ⊗^{M}_{l} mon_rassociator _ _ _ · m ⊗^{M}_{l} ((sym_mon_braiding M m m) ⊗^{M}_{r} m) = δ_{m} · (m ⊗^{M}_{l} δ_{m}) · (m ⊗^{M}_{l} (δ_{m} ⊗^{M}_{r} m)). Proof. refine (_ @ commutative_symmetric_braiding_using_lrwhisker' _). apply maponpaths_2. refine (_ @ commutative_symmetric_braiding_using_lrwhisker _). apply maponpaths_2. exact (commutative_symmetric_braiding_using_lwhisker _). Qed. Lemma comultiplication_comonoid_4times (m : commutative_comonoid M) : δ_{m} · m ⊗^{M}_{l} δ_{ m} · m ⊗^{M}_{l} (δ_{ m} ⊗^{M}_{r} m) = δ_{m} · δ_{m} ⊗^{M} δ_{ m} · mon_lassociator _ _ (_ ⊗ m) · m ⊗^{M}_{l} mon_rassociator _ _ _. Proof. etrans. 2: { apply maponpaths_2. exact (! commutative_symmetric_braiding_using_lwhisker _). } rewrite ! assoc'. apply maponpaths. rewrite <- (bifunctor_leftcomp M). etrans. { apply pathsinv0, (bifunctor_leftcomp M). } etrans. 2: { apply (bifunctor_leftcomp M). } apply maponpaths. refine (comonoid_laws_assoc' M m @ _). apply assoc'. Qed. Lemma commutative_symmetric_braiding_after_4_copies' (m : commutative_comonoid M) : δ_{m} · δ_{m} #⊗ δ_{m} · α^{M}_{_,_,_} · (m ⊗^{M}_{l} αinv^{M}_{_,_,_}) · (m ⊗^{M}_{l} (sym_mon_braiding M m m ⊗^{M}_{r} m)) = δ_{m} · δ_{m} #⊗ δ_{m} · α^{M}_{_,_,_} · m ⊗^{M}_{l} αinv^{M}_{_,_,_}. Proof. refine (commutative_symmetric_braiding_using_lrwhisker'' _ @ _). exact (comultiplication_comonoid_4times _). Qed. Lemma commutative_symmetric_braiding_after_4_copies (m : commutative_comonoid M) : δ_{m} · (δ_{m} #⊗ δ_{m} · (α^{M}_{ m, m, m ⊗_{ M} m} · (m ⊗^{M}_{l} (αinv^{M}_{ m, m, m} · (sym_mon_braiding M m m ⊗^{M}_{r} m · α^{M}_{ m, m, m})) · αinv^{M}_{m, m, m ⊗_{ M} m}))) = δ_{m} · δ_{m} #⊗ δ_{m}. Proof. rewrite ! assoc. etrans. { apply maponpaths_2. rewrite ! (bifunctor_leftcomp M). rewrite ! assoc. apply maponpaths_2. exact (commutative_symmetric_braiding_after_4_copies' _). } etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite <- (bifunctor_leftcomp M). apply maponpaths. apply (monoidal_associatorisolaw M m m m). } rewrite (bifunctor_leftid M). rewrite id_right. etrans. { rewrite assoc'. apply maponpaths. apply (monoidal_associatorisolaw M m m _). } apply id_right. Qed. Lemma comult_before_inner_swap_and_swap (mx my : comonoid M) : δ_{mx} #⊗ δ_{my} · (inner_swap M _ _ _ _ · sym_mon_braiding M _ _ #⊗ sym_mon_braiding M _ _) = δ_{mx} #⊗ δ_{my} · (sym_mon_braiding M (_ ⊗ _) (_ ⊗ _) · inner_swap M _ _ _ _). Proof. apply maponpaths. apply inner_swap_commute_with_swap. Qed. End CommutativeComonoids. Section Univalence. Lemma disp_cat_of_comonoids_is_univalent (V : monoidal_cat) : is_univalent_disp (disp_cat_of_comonoids V). Proof. apply is_univalent_sigma_disp. - apply dirprod_disp_cat_is_univalent ; apply is_univalent_dialgebra_disp_cat. - apply disp_full_sub_univalent. intro ; apply isaprop_comonoid_laws. Qed. Lemma disp_cat_of_commutative_comonoids_is_univalent (V : sym_monoidal_cat) : is_univalent_disp (disp_cat_of_commutative_comonoids V). Proof. apply is_univalent_sigma_disp. - apply disp_cat_of_comonoids_is_univalent. - apply disp_full_sub_univalent. intro ; apply homset_property. Qed. End Univalence. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/CommComonoidsCartesian.v000066400000000000000000000131231451125700300301070ustar00rootroot00000000000000(* In this file, we show how the (symmetric monoidal) category of commutative comonoids, over a symmetric monoidal category, is cartesian. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Tensor. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.MonoidalCartesianBuilder. Local Open Scope cat. Import MonoidalNotations. Import ComonoidNotations. Section CartesianMonoidalCategoryOfCommutativeComonoids. Context (V : sym_monoidal_cat). Lemma diagonal_is_comonoid_mor_counit (m : comonoid V) : is_comonoid_mor_counit V m (tensor_of_comonoids V m m) δ_{m}. Proof. unfold is_comonoid_mor_counit. cbn. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite ! assoc'. etrans. { apply maponpaths. apply maponpaths. exact (monoidal_leftunitornat V _ _ ε_{m}). } refine (_ @ id_left _). rewrite ! assoc. apply maponpaths_2. exact (comonoid_to_law_unit_left _ m). Qed. Lemma aug_is_comonoid_mor_comult (m : comonoid V) : is_comonoid_mor_comult V m (comonoid_disp_unit V) ε_{m}. Proof. refine (assoc _ _ _ @ _). etrans. { apply maponpaths_2. apply comonoid_laws_unit_left'. } apply monoidal_leftunitorinvnat. Qed. Definition commutative_comonoid_to_comonoid_of_comonoids_data (m : commutative_comonoid V) : comonoid_data (symmetric_cat_commutative_comonoids V). Proof. exists m. refine (_ ,, _). - refine (δ_{m} ,, (_ ,, tt) ,, tt). abstract (split ; cbn; [ refine (! commutative_symmetric_braiding_after_4_copies V m @ _); apply maponpaths; cbn; unfold dialgebra_disp_tensor_op; apply maponpaths_2; apply pathsinv0, id_left | refine (id_right _ @ ! diagonal_is_comonoid_mor_counit m @ _); apply maponpaths; unfold dialgebra_disp_tensor_op; cbn; apply maponpaths_2; apply pathsinv0, id_left]). - refine (ε_{m} ,, (_ ,, tt) ,, tt). abstract (split ; cbn; [ refine (aug_is_comonoid_mor_comult m @ _); apply maponpaths; apply pathsinv0, id_left | refine (_ @ assoc' _ _ _); apply pathsinv0, id_right]). Defined. Lemma commutative_comonoid_to_comonoid_of_comonoids_laws (m : commutative_comonoid V) : comonoid_laws (symmetric_cat_commutative_comonoids V) (commutative_comonoid_to_comonoid_of_comonoids_data m). Proof. repeat split ; (use subtypePath ; [intro ; apply is_locally_propositional_commutative_comonoid | apply (pr12 m)]). Qed. Definition commutative_comonoid_to_comonoid_of_comonoids (m : commutative_comonoid V) : comonoid (symmetric_cat_commutative_comonoids V). Proof. exists m. exists (pr2 (commutative_comonoid_to_comonoid_of_comonoids_data m)). exact (commutative_comonoid_to_comonoid_of_comonoids_laws m). Defined. Definition comonoid_mor_is_comonoid_mor {x y : commutative_comonoid V} (f : _⟦x,y⟧) : comonoid_mor_struct (symmetric_cat_commutative_comonoids V) (x,, pr2 (commutative_comonoid_to_comonoid_of_comonoids x)) (y,, pr2 (commutative_comonoid_to_comonoid_of_comonoids y)) f. Proof. apply make_is_comonoid_mor. - use subtypePath. + intro ; apply is_locally_propositional_commutative_comonoid. + apply (pr2 f). - use subtypePath. + intro ; apply is_locally_propositional_commutative_comonoid. + exact (pr2 (pr112 f)). Qed. Definition cartesian_monoidal_cat_of_comm_comonoids : is_cartesian (symmetric_cat_commutative_comonoids V). Proof. use symm_monoidal_is_cartesian_from_comonoid. - exact (λ m, pr2 (commutative_comonoid_to_comonoid_of_comonoids m)). - exact (λ _ _ f, comonoid_mor_is_comonoid_mor f). - use subtypePath. + intro ; apply is_locally_propositional_commutative_comonoid. + apply id_right. - intros mx my. use subtypePath. + intro ; apply is_locally_propositional_commutative_comonoid. + cbn. unfold dialgebra_disp_tensor_op. cbn. now rewrite id_left. Qed. End CartesianMonoidalCategoryOfCommutativeComonoids. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/Monoidal.v000066400000000000000000000151511451125700300252540ustar00rootroot00000000000000(** In this file, the monoidal category of comonoids internal to a symmetric monoidal category is defined. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.Examples.DiagonalFunctor. Require Import UniMath.CategoryTheory.Monoidal.Examples.ConstantFunctor. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Tensor. Import MonoidalNotations. Import ComonoidNotations. Local Open Scope cat. Local Open Scope moncat. Section MonoidalCategoryOfComonoids. Context (V : sym_monoidal_cat). Let V_comult : disp_monoidal (dialgebra_disp_cat _ _) V := dialgebra_disp_monoidal (identity_fmonoidal V) (diag_functor_fmonoidal_lax V). Let V_counit : disp_monoidal (dialgebra_disp_cat (functor_identity V) (constant_functor _ _ I_{V})) V := dialgebra_disp_monoidal (identity_fmonoidal V) (constantly_unit_functor_fmonoidal V). Definition disp_monoidal_comonoids_data : disp_monoidal (disp_cat_of_comonoids_data V) V. Proof. use dirprod_disp_cat_monoidal. - exact V_comult. - exact V_counit. - apply is_locally_propositional_dialgebra_disp_cat. - apply is_locally_propositional_dialgebra_disp_cat. Defined. Definition disp_monoidal_comonoids_comonoid_law_unit : comonoid_laws V I_{ total_monoidal disp_monoidal_comonoids_data}. Proof. refine (_ ,, _ ,, _). - unfold comonoid_laws_unit_left. cbn. unfold dialgebra_disp_unit. rewrite ! id_left. rewrite (bifunctor_rightid V). rewrite id_right. apply monoidal_leftunitorisolaw. - unfold comonoid_laws_unit_right. cbn. unfold dialgebra_disp_unit. rewrite ! id_left. rewrite (bifunctor_leftid V). rewrite id_right. unfold fmonoidal_preservesunit. cbn. unfold diag_preserves_unit. rewrite mon_runitor_I_mon_lunitor_I. apply monoidal_leftunitorisolaw. - unfold comonoid_laws_assoc. cbn. unfold dialgebra_disp_unit. cbn. unfold diag_preserves_unit. rewrite ! id_left. rewrite assoc'. apply maponpaths. apply lunitorinv_preserves_leftwhiskering_with_unit. Qed. Definition disp_monoidal_comonoids_laws : disp_monoidal (comonoid_laws_disp_cat V) (total_monoidal disp_monoidal_comonoids_data). Proof. apply disp_monoidal_fullsub. - exact disp_monoidal_comonoids_comonoid_law_unit. - intros [x1 x2] [y1 y2] mx my. repeat split. + refine (_ @ tensor_of_comonoids_laws_unit_left V (x1 ,, x2 ,, mx) (y1 ,, y2 ,, my)). cbn. unfold dialgebra_disp_tensor_op. apply maponpaths_2. cbn. now do 2 rewrite id_left. + refine (_ @ tensor_of_comonoids_laws_unit_right V (x1 ,, x2 ,, mx) (y1 ,, y2 ,, my)). apply maponpaths_2. cbn. unfold dialgebra_disp_tensor_op. cbn. now do 2 rewrite id_left. + refine (_ @ tensor_of_comonoids_laws_assoc V (x1 ,, x2 ,, mx) (y1 ,, y2 ,, my) @ _). * apply maponpaths_2. cbn. unfold dialgebra_disp_tensor_op. cbn. now rewrite id_left. * cbn. unfold dialgebra_disp_tensor_op. cbn. now rewrite id_left. Defined. Definition disp_monoidal_comonoids : disp_monoidal (disp_cat_of_comonoids V) V. Proof. use sigma_disp_cat_monoidal. - exact disp_monoidal_comonoids_data. - exact disp_monoidal_comonoids_laws. - apply locally_propositional_comonoid_laws_disp_cat. Defined. Definition disp_monoidal_commutative_comonoids_laws : disp_monoidal (commutative_comonoids_laws_disp_cat V) (total_monoidal disp_monoidal_comonoids). Proof. apply disp_monoidal_fullsub. - abstract ( refine (_ @ id_right _); apply maponpaths; apply sym_mon_braiding_id). - abstract ( intros [x1 x2] [y1 y2] mx my; refine (_ @ tensor_of_comm_comonoids V (x1 ,, x2 ,, mx) (y1 ,, y2 ,, my) @ _); [ apply maponpaths_2; cbn; unfold dialgebra_disp_tensor_op; cbn; now rewrite id_left | cbn; unfold dialgebra_disp_tensor_op; cbn; now rewrite id_left]). Defined. Definition disp_monoidal_commutative_comonoids : disp_monoidal (disp_cat_of_commutative_comonoids V) V. Proof. use sigma_disp_cat_monoidal. - exact disp_monoidal_comonoids. - exact disp_monoidal_commutative_comonoids_laws. - intro ; intros. apply isapropunit. Defined. Definition monoidal_cat_comonoids : monoidal_cat. Proof. exists (comonoid_category V). exact (total_monoidal disp_monoidal_comonoids). Defined. Definition monoidal_cat_of_commutative_comonoids : monoidal_cat. Proof. exists (commutative_comonoid_category V). use total_monoidal. - exact V. - exact disp_monoidal_commutative_comonoids. Defined. End MonoidalCategoryOfComonoids. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/MonoidalCartesianBuilder.v000066400000000000000000000257321451125700300304230ustar00rootroot00000000000000(* In this file, builders are provided for showing that a monoidal (resp. symmetric monoidal) category is cartesian; i.e., the tensor product (resp. unit) coincides with the (categorical) product (resp terminal object). *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Tensor. Local Open Scope cat. Import MonoidalNotations. Local Open Scope moncat. (* Definition make_section_into_comonoids : section_disp (comonoid_disp_cat M). Proof. unfold section_disp. use tpair. - exists m. exact mf. - split ; intro ; intros ; apply isaprop_is_comonoid_mor. Defined. *) Section CartesianBuilder. Context (V : monoidal_cat). Context (m : ∏ x : V, disp_cat_of_comonoids V x) (mf : ∏ (x y : V) (f : V⟦x,y⟧), comonoid_mor_struct V (_ ,, m x) (_ ,, m y) f). Import ComonoidNotations. Let εI : V ⟦monoidal_unit V , monoidal_unit V⟧ := ε_{(monoidal_unit V ,, m _) : comonoid V}. Lemma terminal_from_aug_id (x : V) : εI = identity (monoidal_unit V) → iscontr (V⟦x, monoidal_unit V⟧). Proof. exists (ε_{(x ,, m x) : comonoid V}). abstract ( intro f ; refine (_ @ id_right _) ; refine (_ @ ! (pr21 (mf _ _ f))) ; refine (! id_right _ @ _) ; apply maponpaths, pathsinv0 ; assumption). Defined. Definition monoidal_is_semicartesian_from_comonoid (pI : εI = identity (monoidal_unit V)) : is_semicartesian V. Proof. intro ; apply terminal_from_aug_id. assumption. Defined. Section make_cartesian. Context (pI : εI = identity (monoidal_unit V)) {x y z : V} (fx : V⟦z, x⟧) (fy : V⟦z, y⟧). Let δx : V⟦x, x ⊗ x⟧ := δ_{(x ,, m x) : comonoid V}. Let δy : V⟦y, y ⊗ y⟧ := δ_{(y ,, m y) : comonoid V}. Let δz : V⟦z, z ⊗ z⟧ := δ_{(z ,, m z) : comonoid V}. Let εx : V⟦x, monoidal_unit V⟧ := ε_{(x ,, m x) : comonoid V} . Let εy : V⟦y, monoidal_unit V⟧ := ε_{(y ,, m y) : comonoid V}. Let εz : V⟦z, monoidal_unit V⟧ := ε_{(z ,, m z) : comonoid V}. Definition make_isbinprod_from_comonoid_existence_mor : V⟦z, x ⊗ y⟧ := δz · fx #⊗ fy. Lemma make_is_binprod_from_comonoids_existence_mor_1 : δz · fx #⊗ fy · (identity x #⊗ εy · mon_runitor x) = fx. Proof. rewrite ! assoc'. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. refine (_ @ idpath ((identity z #⊗ εz) · (fx #⊗ identity _))). simpl. refine (! tensor_comp_mor _ _ _ _ @ _). refine (_ @ tensor_comp_mor _ _ _ _). rewrite ! id_right. rewrite id_left. apply maponpaths. apply isapropifcontr. apply (terminal_from_aug_id z pI). } etrans. { apply maponpaths. rewrite assoc'. apply maponpaths. apply tensor_runitor. } rewrite ! assoc. refine (_ @ id_left _). apply maponpaths_2. refine ( _ @ comonoid_to_law_unit_right V ((z ,, m z) : comonoid V)). apply maponpaths_2, maponpaths. apply (when_bifunctor_becomes_leftwhiskering V). Qed. Lemma make_is_binprod_from_comonoids_existence_mor_2 : δz · fx #⊗ fy · (εx #⊗ identity y · mon_lunitor y) = fy. Proof. rewrite ! assoc'. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. refine (_ @ idpath ((εz #⊗ identity z ) · (identity _ #⊗ fy))). simpl. refine (! tensor_comp_mor _ _ _ _ @ _). refine (_ @ tensor_comp_mor _ _ _ _). rewrite ! id_right. rewrite id_left. apply maponpaths_2. apply isapropifcontr. apply (terminal_from_aug_id z pI). } etrans. { apply maponpaths. rewrite assoc'. apply maponpaths. apply tensor_lunitor. } rewrite ! assoc. refine (_ @ id_left _). apply maponpaths_2. refine ( _ @ comonoid_to_law_unit_left V ((z ,, m z) : comonoid V)). apply maponpaths_2, maponpaths. apply (when_bifunctor_becomes_rightwhiskering V). Qed. Context (p : identity (x ⊗ y) = δ_{(x ⊗ y ,, m _) : comonoid V} · ((identity x #⊗ εy) #⊗ (εx #⊗ identity y) · mon_runitor x #⊗ mon_lunitor y)). Lemma make_is_binprod_from_comonoids_uniqueness (f : V⟦z, x ⊗ y⟧) (px : f · (identity x #⊗ εy · mon_runitor x) = fx) (py : f · (εx #⊗ identity y · mon_lunitor y) = fy) : f = δz · fx #⊗ fy. Proof. rewrite <- px. rewrite <- py. clear px py. etrans. 2: { apply maponpaths. apply pathsinv0. apply tensor_comp_mor. } etrans. 2: { do 2 apply maponpaths. apply pathsinv0. apply tensor_comp_mor. } rewrite assoc. etrans. 2: { apply maponpaths_2. apply pathsinv0. apply (mf _ _ f). } refine (! id_right _ @ _). rewrite assoc'. apply maponpaths. apply p. Qed. End make_cartesian. Lemma monoidal_is_binproduct_from_comonoid (pI : εI = identity (monoidal_unit V)) (pT : ∏ x y : V, δ_{(x ⊗ y ,, m _) : comonoid V} · ((identity x #⊗ ε_{(y ,, m y) : comonoid V}) #⊗ (ε_{(x ,, m x) : comonoid V} #⊗ identity y) · mon_runitor x #⊗ mon_lunitor y) = identity (x ⊗ y)) : tensor_isBinProduct (monoidal_is_semicartesian_from_comonoid pI). Proof. intros x y. use make_isBinProduct. intros z fx fy. simple refine ((_ ,, _ ,, _) ,, _). - exact (make_isbinprod_from_comonoid_existence_mor fx fy). - exact (make_is_binprod_from_comonoids_existence_mor_1 pI fx fy). - exact (make_is_binprod_from_comonoids_existence_mor_2 pI fx fy). - intro f. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } exact (make_is_binprod_from_comonoids_uniqueness fx fy (! pT x y) (pr1 f) (pr12 f) (pr22 f)). Qed. Definition monoidal_is_cartesian_from_comonoid (pI : εI = identity (monoidal_unit V)) (pT : ∏ x y : V, δ_{(x ⊗ y ,, m _) : comonoid V} · ((identity x #⊗ ε_{(y ,, m y) : comonoid V}) #⊗ (ε_{(x ,, m x) : comonoid V} #⊗ identity y) · mon_runitor x #⊗ mon_lunitor y) = identity (x ⊗ y)) : is_cartesian V. Proof. exists (monoidal_is_semicartesian_from_comonoid pI). exact (monoidal_is_binproduct_from_comonoid pI pT). Defined. End CartesianBuilder. Section CartesianBuilderCommutative. Context (V : sym_monoidal_cat). Context (m : ∏ x : V, disp_cat_of_comonoids V x) (is_comonoid_mor : ∏ (x y : V) (f : V⟦x,y⟧), comonoid_mor_struct V (_ ,, m x) (_ ,, m y) f). Import ComonoidNotations. Let εI : V⟦monoidal_unit V, monoidal_unit V⟧ := ε_{(monoidal_unit V ,, m _) : comonoid V}. Let cm := λ x : V, (x ,, m x) : comonoid V. Lemma comonoid_unit_law_right_inv (x : V) : mon_runitor x · (δ_{cm x} · x ⊗^{V}_{l} ε_{cm x}) = identity _. Proof. etrans. { apply maponpaths. apply (comonoid_laws_unit_right' V (x ,, m x)). } apply monoidal_rightunitorisolaw. Qed. Lemma comonoid_unit_law_left_inv (y : V) : mon_lunitor y · (δ_{cm y} · ε_{cm y} ⊗^{V}_{r} y) = identity _. Proof. etrans. { apply maponpaths. apply (comonoid_laws_unit_left' V (y ,, m y)). } apply monoidal_leftunitorisolaw. Qed. Lemma inner_swap_before_aug (x y : V) : inner_swap V x x y y · (x ⊗^{V}_{l} ε_{cm y}) #⊗ (ε_{cm _} ⊗^{V}_{r} y) = (_ ⊗^{V}_{l} ε_{cm _}) #⊗ (ε_{cm _} ⊗^{V}_{r} _). Proof. refine (_ @ naturality_inner_swap V (identity x) ε_{cm x} ε_{cm y} (identity y) @ _). { now rewrite <- (when_bifunctor_becomes_leftwhiskering V), <- (when_bifunctor_becomes_rightwhiskering V). } rewrite <- (when_bifunctor_becomes_leftwhiskering V), <- (when_bifunctor_becomes_rightwhiskering V). rewrite inner_swap_along_unit. apply id_right. Qed. Context (aug_of_unit : εI = identity I_{V}). Context (diagonal_of_tensor : ∏ x y : V, δ_{cm (x ⊗ y)} = (δ_{cm x} #⊗ δ_{cm y}) · inner_swap V x x y y). Lemma whisker_to_total' (x y : V) : mon_runitor x #⊗ mon_lunitor y · δ_{cm (x ⊗ y)} · (x ⊗^{V}_{l} ε_{cm y}) #⊗ (ε_{cm x} ⊗^{V}_{r} y) = identity _. Proof. rewrite diagonal_of_tensor. etrans. { rewrite ! assoc'. do 2 apply maponpaths. apply inner_swap_before_aug. } etrans. { apply maponpaths. apply pathsinv0, tensor_comp_mor. } refine (! tensor_comp_mor _ _ _ _ @ _). rewrite comonoid_unit_law_left_inv. rewrite comonoid_unit_law_right_inv. apply tensor_id_id. Qed. Lemma whisker_to_total (x y : V) : δ_{cm (x ⊗ y)} · (x ⊗^{V}_{l} ε_{cm y}) #⊗ (ε_{cm x} ⊗^{V}_{r} y) · mon_runitor x ⊗^{V} mon_lunitor y = identity (x ⊗ y). Proof. use (z_iso_inv_to_right _ _ _ _ (_,,_)). { use (is_z_iso_bifunctor_z_iso V). - exact (_ ,, monoidal_rightunitorisolaw V x). - exact (_ ,, monoidal_leftunitorisolaw V y). } rewrite id_left. refine (_ @ id_right _). apply pathsinv0. use z_iso_inv_on_right. refine (! whisker_to_total' x y @ _). now rewrite ! assoc. Qed. Definition symm_monoidal_is_cartesian_from_comonoid : is_cartesian V. Proof. use monoidal_is_cartesian_from_comonoid. - exact m. - exact is_comonoid_mor. - exact aug_of_unit. - abstract ( intro ; intro ; refine (_ @ whisker_to_total x y) ; rewrite <- (when_bifunctor_becomes_rightwhiskering V) ; rewrite <- (when_bifunctor_becomes_leftwhiskering V) ; rewrite ! assoc ; apply idpath). Defined. End CartesianBuilderCommutative. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/Symmetric.v000066400000000000000000000075641451125700300254770ustar00rootroot00000000000000(** In this file, the symmetric monoidal category of comonoids internal to a symmetric monoidal category is defined. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.Examples.DiagonalFunctor. Require Import UniMath.CategoryTheory.Monoidal.Examples.ConstantFunctor. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.SymmetricMonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Tensor. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Monoidal. Local Open Scope cat. Import MonoidalNotations. Import ComonoidNotations. Section SymmetricMonoidalCategoryOfComonoids. Context (V : sym_monoidal_cat). Definition disp_symmetric_comonoids_data : disp_symmetric (disp_monoidal_comonoids_data V) V. Proof. use dirprod_disp_cat_symmetric_monoidal. - use dialgebra_disp_symmetric_monoidal. + apply V. + apply is_symmetric_monoidal_identity. + apply diag_functor_is_symmetric. - use dialgebra_disp_symmetric_monoidal. + apply V. + apply is_symmetric_monoidal_identity. + apply constant_functor_is_symmetric. refine (sym_mon_braiding_lunitor _ _ @ _). apply pathsinv0. apply unitors_coincide_on_unit. Defined. Definition disp_symmetric_comonoids : disp_symmetric (disp_monoidal_comonoids V) V. Proof. use (sigma_disp_cat_monoidal_symmetric). - exact disp_symmetric_comonoids_data. - apply disp_symmetric_fullsub. Defined. Definition symmetric_cat_comonoids : sym_monoidal_cat. Proof. exists (monoidal_cat_comonoids V). exact (total_symmetric _ disp_symmetric_comonoids). Defined. Definition disp_symmetric_commutative_comonoids : disp_symmetric (disp_monoidal_commutative_comonoids V) V. Proof. use (sigma_disp_cat_monoidal_symmetric). - exact disp_symmetric_comonoids. - apply disp_symmetric_fullsub. Defined. Definition symmetric_cat_commutative_comonoids : sym_monoidal_cat. Proof. exists (monoidal_cat_of_commutative_comonoids V). exact (total_symmetric _ disp_symmetric_commutative_comonoids). Defined. End SymmetricMonoidalCategoryOfComonoids. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/Tensor.v000066400000000000000000000474341451125700300247750ustar00rootroot00000000000000(* In this file, the necessary ingredients to show how the (displayed) category of comonoids (resp. commutative comonoids) is (displayed) symmetric. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.Examples.Sigma. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Import MonoidalNotations. Import ComonoidNotations. Local Open Scope cat. Local Open Scope moncat. Section TensorOfComonoids. Context (M : sym_monoidal_cat). Definition tensor_of_comonoids_data (mx my : comonoid M) : comonoid_data M. Proof. exists (mx ⊗ my). split. - refine (δ_{mx} #⊗ δ_{my} · _). exact (inner_swap M mx mx my my). - exact (ε_{mx} #⊗ ε_{my} · lu^{M}_{_}). Defined. Lemma precompose_inner_swap_with_augs_on_left (mx my : comonoid M) : inner_swap M mx mx my my · (ε_{ mx} ⊗^{ M} ε_{ my}) ⊗^{ M}_{r} (mx ⊗_{ M} my) = (ε_{ mx} ⊗^{M}_{r} _) #⊗ (ε_{ my} ⊗^{M}_{r} my) · inner_swap M _ _ _ _. Proof. refine (_ @ naturality_inner_swap (M) ε_{mx} (identity _) ε_{my} (identity _) @ _). - rewrite <- (when_bifunctor_becomes_rightwhiskering M). do 2 apply maponpaths. apply pathsinv0, tensor_id_id. - now rewrite <- ! (when_bifunctor_becomes_rightwhiskering M). Qed. Lemma precompose_inner_swap_with_diag_on_left (mx my : comonoid M) : inner_swap (M) mx mx my my · (δ_{ mx} ⊗^{ M} δ_{ my}) ⊗^{ M}_{r} (mx ⊗_{ M} my) = (δ_{ mx} ⊗^{M}_{r} _) #⊗ (δ_{ my} ⊗^{M}_{r} my) · inner_swap M _ _ _ _. Proof. refine (_ @ naturality_inner_swap (M) δ_{mx} (identity _) δ_{my} (identity _) @ _). - rewrite <- (when_bifunctor_becomes_rightwhiskering M). now (rewrite <- (bifunctor_distributes_over_id (F := M)) ; try (apply (pr21 M))). - now rewrite <- ! (when_bifunctor_becomes_rightwhiskering M). Qed. Lemma precompose_inner_swap_with_augs_on_right (mx my : comonoid M) : inner_swap (M) mx mx my my · (mx ⊗_{ M} my) ⊗^{ M}_{l} (ε_{mx} ⊗^{ M} ε_{my}) = (_ ⊗^{M}_{l} ε_{mx}) #⊗ (_ ⊗^{M}_{l} ε_{my}) · inner_swap (M) _ _ _ _. Proof. refine (_ @ naturality_inner_swap (M) (identity _) ε_{mx} (identity _) ε_{my} @ _). - rewrite <- (when_bifunctor_becomes_leftwhiskering M). now (rewrite <- (bifunctor_distributes_over_id (F := M)) ; try (apply (pr21 M))). - now rewrite <- ! (when_bifunctor_becomes_leftwhiskering M). Qed. Lemma precompose_inner_swap_with_diag_on_right (mx my : comonoid M) : inner_swap (M) mx mx my my · (mx ⊗_{ M} my) ⊗^{ M}_{l} (δ_{ mx} ⊗^{ M} δ_{ my}) = (_ ⊗^{M}_{l} δ_{ mx}) #⊗ (_ ⊗^{M}_{l} δ_{ my}) · inner_swap (M) _ _ _ _. Proof. refine (_ @ naturality_inner_swap (M) (identity _) δ_{mx} (identity _) δ_{my} @ _). - rewrite <- (when_bifunctor_becomes_leftwhiskering M). apply maponpaths. apply maponpaths_2. apply pathsinv0. apply tensor_id_id. - now rewrite <- ! (when_bifunctor_becomes_leftwhiskering M). Qed. Lemma tensor_of_comonoids_laws_unit_left (mx my : comonoid M) : comonoid_laws_unit_left M (tensor_of_comonoids_data mx my). Proof. unfold comonoid_laws_unit_left. cbn. rewrite (bifunctor_rightcomp M). rewrite ! assoc. etrans. { do 2 apply maponpaths_2. rewrite assoc'. apply maponpaths. apply precompose_inner_swap_with_augs_on_left. } rewrite assoc. etrans. { do 3 apply maponpaths_2. apply pathsinv0, tensor_comp_mor. } etrans. { rewrite ! assoc'. apply maponpaths. rewrite assoc. exact (precompose_inner_swap_with_lunitors_on_right (M) mx my). } cbn. etrans. { apply pathsinv0. apply tensor_comp_mor. } etrans. { apply maponpaths. apply comonoid_to_law_unit_left. } etrans. { apply maponpaths_2. apply comonoid_to_law_unit_left. } apply tensor_id_id. Qed. Lemma tensor_of_comonoids_laws_unit_right (mx my : comonoid M) : comonoid_laws_unit_right M (tensor_of_comonoids_data mx my). Proof. unfold comonoid_laws_unit_right. cbn. rewrite (bifunctor_leftcomp M). rewrite ! assoc. etrans. { do 2 apply maponpaths_2. rewrite assoc'. apply maponpaths. apply precompose_inner_swap_with_augs_on_right. } rewrite assoc. etrans. { do 3 apply maponpaths_2. apply pathsinv0, tensor_comp_mor. } etrans. { rewrite ! assoc'. apply maponpaths. rewrite assoc. exact (precompose_inner_swap_with_lunitors_and_runitor (M) mx my). } etrans. { apply pathsinv0, tensor_comp_mor. } etrans. { apply maponpaths. apply comonoid_to_law_unit_right. } etrans. { apply maponpaths_2. apply comonoid_to_law_unit_right. } apply tensor_id_id. Qed. Lemma tensor_of_comonoids_laws_assoc (mx my : comonoid M) : comonoid_laws_assoc M (tensor_of_comonoids_data mx my). Proof. unfold comonoid_laws_assoc. cbn. rewrite ! assoc'. rewrite (bifunctor_rightcomp M). etrans. { apply maponpaths. apply pathsinv0. rewrite ! assoc. do 2 apply maponpaths_2. apply pathsinv0. apply precompose_inner_swap_with_diag_on_left. } rewrite (bifunctor_leftcomp M). etrans. 2: { apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0. apply precompose_inner_swap_with_diag_on_right. } rewrite ! assoc. rewrite <- ! tensor_comp_mor. etrans. 2: { do 3 apply maponpaths_2. apply comonoid_to_law_assoc. } etrans. 2: { do 2 apply maponpaths_2. apply maponpaths. apply comonoid_to_law_assoc. } rewrite ! tensor_comp_mor. rewrite ! assoc'. do 2 apply maponpaths. apply inner_swap_hexagon. Qed. Lemma tensor_of_comonoids_laws (mx my : comonoid M) : comonoid_laws M (tensor_of_comonoids_data mx my). Proof. refine (_ ,, _ ,, _). - exact (tensor_of_comonoids_laws_unit_left mx my). - exact (tensor_of_comonoids_laws_unit_right mx my). - exact (tensor_of_comonoids_laws_assoc mx my). Qed. Definition tensor_of_comonoids (mx my : comonoid M) : comonoid M. Proof. refine (_ ,, _ ,, _). exact (tensor_of_comonoids_laws mx my). Defined. Definition tensor_of_comonoid_mor_mult_left (m : comonoid M) {m1 m2 : comonoid M} {g : M⟦m1,m2⟧} (gg : δ_{_} · g #⊗ g = g · δ_{_}) : δ_{tensor_of_comonoids m m1} · (m ⊗^{ M}_{l} g) #⊗ (m ⊗^{M}_{l} g) = (m ⊗^{M}_{l} g) · δ_{tensor_of_comonoids m m2}. Proof. cbn. etrans. 2:{ rewrite assoc. apply maponpaths_2. rewrite <- (when_bifunctor_becomes_leftwhiskering M). refine (_ @ tensor_comp_mor _ _ _ _ ). rewrite id_left. apply maponpaths. exact gg. } etrans. { rewrite assoc'. apply maponpaths. refine (_ @ naturality_inner_swap (M) (identity _) (identity _) g g). now rewrite <- (when_bifunctor_becomes_leftwhiskering M). } rewrite ! assoc. apply maponpaths_2. refine (! tensor_comp_mor _ _ _ _ @ _). rewrite tensor_id_id. now rewrite id_right. Qed. Definition tensor_of_comonoid_mor_unit_left (m : comonoid M) {m1 m2 : comonoid M} {g : M⟦m1,m2⟧} (gg : ε_{_} · identity I_{M} = g · ε_{_}) : ε_{tensor_of_comonoids _ _} · identity I_{M} = (m ⊗^{ M}_{l} g) · ε_{tensor_of_comonoids _ _}. Proof. cbn. rewrite id_right. rewrite assoc. apply maponpaths_2. rewrite id_right in gg. rewrite <- (when_bifunctor_becomes_leftwhiskering M). refine (_ @ tensor_comp_mor _ _ _ _). rewrite id_left. apply maponpaths. exact gg. Qed. Definition tensor_of_comonoid_mor_left (m : comonoid M) {m1 m2 : comonoid M} {g : M⟦m1,m2⟧} (gg1 : δ_{_} · g #⊗ g = g · δ_{_}) (gg2 : ε_{_} · identity I_{M} = g · ε_{_}) : comonoid_mor_struct M (tensor_of_comonoids m m1) (tensor_of_comonoids m m2) (m ⊗^{ M}_{l} g). Proof. use make_is_comonoid_mor. - apply (tensor_of_comonoid_mor_mult_left m gg1). - apply (tensor_of_comonoid_mor_unit_left m gg2). Qed. Definition comonoid_disp_unit_data : comonoid_data M. Proof. exists (monoidal_unit M). exists (mon_linvunitor _). apply identity. Defined. Lemma comonoid_disp_unit_laws : comonoid_laws M comonoid_disp_unit_data. Proof. refine (_ ,, _ ,, _). - unfold comonoid_laws_unit_left. cbn. rewrite (bifunctor_rightid M). rewrite id_right. apply monoidal_leftunitorisolaw. - unfold comonoid_laws_unit_right. cbn. rewrite (bifunctor_leftid M). rewrite id_right. rewrite mon_runitor_I_mon_lunitor_I. apply monoidal_leftunitorisolaw. - unfold comonoid_laws_assoc. cbn. rewrite ! assoc'. apply maponpaths. apply lunitorinv_preserves_leftwhiskering_with_unit. Qed. Definition comonoid_disp_unit : comonoid M. Proof. exists comonoid_disp_unit_data. refine (_ ,, _). exact comonoid_disp_unit_laws. Defined. Lemma comonoid_disp_lunitor (m : comonoid M) : comonoid_mor_struct M (tensor_of_comonoids comonoid_disp_unit m) m (mon_lunitor m). Proof. use make_is_comonoid_mor. - cbn. etrans. { apply maponpaths. apply pathsinv0. apply (precompose_inner_swap_with_lunitors_on_right (M)). } refine (_ @ monoidal_leftunitornat M _ _ δ_{m}). rewrite ! assoc. apply maponpaths_2. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply inner_swap_inv. } rewrite id_right. rewrite <- (when_bifunctor_becomes_rightwhiskering M). etrans. { apply pathsinv0, tensor_comp_mor. } rewrite id_right. rewrite <- (when_bifunctor_becomes_leftwhiskering M). apply maponpaths_2. apply (monoidal_leftunitorisolaw M I_{M}). - refine (_ @ monoidal_leftunitornat M _ _ ε_{m}). rewrite id_right. cbn. apply maponpaths_2. apply (when_bifunctor_becomes_leftwhiskering M). Qed. Lemma comonoid_disp_lunitor_inv (m : comonoid M) : comonoid_mor_struct M m (tensor_of_comonoids comonoid_disp_unit m) (mon_linvunitor m). Proof. use make_is_comonoid_mor. - cbn. use (z_iso_inv_to_right _ _ _ _ (_ ,, _)). { set (i := monoidal_leftunitorisolaw M m). use (is_z_iso_bifunctor_z_iso M) ; apply (_ ,, pr2 i ,, pr1 i). } cbn. etrans. 2: { apply maponpaths. apply (precompose_inner_swap_with_lunitors_on_right M). } apply pathsinv0. etrans. { rewrite ! assoc'. do 2 apply maponpaths. rewrite assoc. apply maponpaths_2. apply inner_swap_inv. } rewrite id_left. rewrite <- (when_bifunctor_becomes_rightwhiskering M). etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0, tensor_comp_mor. } etrans. { apply maponpaths. do 2 apply maponpaths_2. apply monoidal_leftunitorisolaw. } rewrite id_right. etrans. { apply maponpaths. refine (_ @ monoidal_leftunitornat M _ _ δ_{m}). apply maponpaths_2. apply (when_bifunctor_becomes_leftwhiskering M). } rewrite assoc. refine (_ @ id_left _). apply maponpaths_2. apply monoidal_leftunitorisolaw. - cbn. rewrite assoc. apply pathsinv0. etrans. { apply maponpaths_2. refine (_ @ monoidal_leftunitorinvnat M _ _ ε_{m}). now rewrite <- (when_bifunctor_becomes_leftwhiskering M). } rewrite assoc'. apply maponpaths. apply monoidal_leftunitorisolaw. Qed. Lemma comonoid_disp_braiding (mx my : comonoid M) : comonoid_mor_struct M (tensor_of_comonoids mx my) (tensor_of_comonoids my mx) (sym_mon_braiding M mx my). Proof. apply make_is_comonoid_mor. - cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. apply (tensor_sym_mon_braiding). } rewrite ! assoc'. apply comult_before_inner_swap_and_swap. - cbn. rewrite ! assoc. rewrite id_right. apply maponpaths_2. etrans. 2: { apply (tensor_sym_mon_braiding M). } cbn. refine (! id_right _ @ _). apply maponpaths. apply pathsinv0, sym_mon_braiding_id. Qed. Lemma comonoid_disp_associator (xx yy zz : comonoid M) : comonoid_mor_struct M (tensor_of_comonoids (tensor_of_comonoids xx yy) zz) (tensor_of_comonoids xx (tensor_of_comonoids yy zz)) (mon_lassociator xx yy zz). Proof. apply make_is_comonoid_mor. - cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. apply maponpaths. apply maponpaths_2. apply id_right. } rewrite tensor_comp_mor. rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, associator_nat2. } rewrite ! assoc'. etrans. { apply maponpaths_2. apply maponpaths. apply pathsinv0, id_right. } rewrite tensor_comp_mor. rewrite ! assoc'. apply maponpaths. rewrite ! assoc. apply inner_swap_hexagon'. - cbn. apply pathsinv0. etrans. { apply maponpaths. apply maponpaths_2. apply tensor_comp_l_id_l. } unfold monoidal_cat_tensor_mor. cbn. rewrite ! assoc. etrans. { do 2 apply maponpaths_2. apply pathsinv0, tensor_lassociator. } unfold monoidal_cat_tensor_mor. cbn. rewrite id_right. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_lassociator. } unfold monoidal_cat_tensor_mor. cbn. rewrite assoc'. etrans. { apply maponpaths. apply pathsinv0. apply tensor_comp_mor. } rewrite id_left. etrans. { apply maponpaths. apply maponpaths_2. apply pathsinv0, id_right. } etrans. { apply maponpaths. apply tensor_comp_mor. } rewrite assoc. etrans. { apply maponpaths_2. apply associator_nat2. } etrans. 2: { apply maponpaths. apply id_right. } etrans. 2: { apply pathsinv0, tensor_comp_mor. } rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, mon_triangle. } apply maponpaths_2. apply mon_runitor_I_mon_lunitor_I. Qed. (* Lemma comonoid_disp_associatorinv_mult {x y z : C} (xx : comonoid M x) (yy : comonoid M y) (zz : comonoid M z) : is_comonoid_mor_mult M (tensor_of_comonoids xx (tensor_of_comonoids yy zz)) (tensor_of_comonoids (tensor_of_comonoids xx yy) zz) αinv^{ M }_{ x, y, z}. Proof. unfold is_comonoid_mor_mult. cbn. etrans. 2: { rewrite assoc. apply maponpaths_2. apply maponpaths. apply maponpaths. apply id_right. } rewrite (bifunctor_distributes_over_comp (F := M)) ; try (apply M). rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. apply monoidal_associatorinv_nat2. } rewrite ! assoc'. etrans. { apply maponpaths_2. apply maponpaths_2. apply pathsinv0, id_right. } rewrite (bifunctor_distributes_over_comp (F := M)) ; try (apply M). rewrite ! assoc'. apply maponpaths. rewrite ! assoc. apply rearrange_hexagoninv'. Qed. Lemma comonoid_disp_associatorinv_unit {x y z : C} (xx : comonoid M x) (yy : comonoid M y) (zz : comonoid M z) : is_comonoid_mor_unit M (tensor_of_comonoids xx (tensor_of_comonoids yy zz)) (tensor_of_comonoids (tensor_of_comonoids xx yy) zz) αinv^{ M }_{ x, y, z}. Proof. unfold is_comonoid_mor_unit. cbn. etrans. { apply maponpaths. apply maponpaths_2. apply (tensor_comp_r_id_r). } unfold monoidal_cat_tensor_mor. cbn. rewrite ! assoc. etrans. { do 2 apply maponpaths_2. apply pathsinv0, tensor_rassociator. } unfold monoidal_cat_tensor_mor. cbn. apply maponpaths_2. etrans. { apply maponpaths_2. apply tensor_rassociator. } unfold monoidal_cat_tensor_mor. cbn. rewrite assoc'. etrans. { apply maponpaths. apply pathsinv0. apply (bifunctor_distributes_over_comp (F := M)) ; try (apply M). } rewrite id_right. etrans. { apply maponpaths. apply maponpaths. apply pathsinv0, id_right. } rewrite (bifunctor_distributes_over_comp (F := M)) ; try (apply M). rewrite assoc. etrans. { apply maponpaths_2. apply pathsinv0. apply monoidal_associatorinv_nat2. } etrans. 2: { apply maponpaths_2. apply id_right. } rewrite (bifunctor_distributes_over_comp (F := M)) ; try (apply M). rewrite assoc'. apply maponpaths. apply associator_before_rwhisker_with_lu. Qed. Lemma comonoid_disp_associatorinv {x y z : C} (xx : comonoid M x) (yy : comonoid M y) (zz : comonoid M z) : is_comonoid_mor M (tensor_of_comonoids xx (tensor_of_comonoids yy zz)) (tensor_of_comonoids (tensor_of_comonoids xx yy) zz) αinv^{M}_{x, y, z}. Proof. split. - exact (comonoid_disp_associatorinv_mult xx yy zz). - exact (comonoid_disp_associatorinv_unit xx yy zz). Qed. *) End TensorOfComonoids. Section TensorOfCommutativeComonoids. Context (V : sym_monoidal_cat). Lemma tensor_of_comm_comonoids (mx my : commutative_comonoid V) : is_commutative V (tensor_of_comonoids V mx my). Proof. use (z_iso_inv_on_left _ _ _ _ (inner_swap V _ _ _ _ ,, inner_swap V _ _ _ _ ,, _)). { apply inner_swap_is_z_isomorphism. } cbn. rewrite assoc'. etrans. 2: { apply maponpaths. apply inner_swap_commute_with_swap. } rewrite assoc. etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply pathsinv0, inner_swap_inv. } rewrite id_right. refine (_@ tensor_comp_mor _ _ _ _). etrans. 2: { apply maponpaths_2. apply pathsinv0, commutative_comonoid_is_commutative. } apply maponpaths. apply pathsinv0, commutative_comonoid_is_commutative. Qed. End TensorOfCommutativeComonoids. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Comonoids/TransportComonoidAlongRetraction.v000066400000000000000000000130631451125700300322120ustar00rootroot00000000000000(** Consider a morphism i : B --> a in a monoidal category. Given a comonoid structure on B, we show how the comonoid structure can be transported to a, provided i is part of a retraction pair (and a compatibility condition). Furthermore, i becomes a comonoid homomorphism. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Local Open Scope cat. Local Open Scope moncat. Import ComonoidNotations. Section TransportingComonoidAlongRetractionPair. Context {L : monoidal_cat}. Context (B : comonoid L) {a : L} (i : L⟦a,B⟧) (r : L⟦B,a⟧) (ir : is_retraction i r). Context (p : i · δ_{B} · (r #⊗ r) · (i #⊗ i) = i · δ_{B}). Definition transported_comonoid_comult_data : L⟦a, a ⊗ a⟧. Proof. exact (i · δ_{B} · r #⊗ r). Defined. Definition transported_comonoid_counit_data : L⟦a, monoidal_unit L⟧. Proof. exact (i · ε_{B}). Defined. Definition transported_comonoid_data : disp_cat_of_comonoids_data L a. Proof. split. - exact transported_comonoid_comult_data. - exact transported_comonoid_counit_data. Defined. Local Lemma diagram_1 : i · δ_{B} · (r #⊗ r) · (i #⊗ identity a) = i · δ_{B} · identity (pr1 B) #⊗ r. Proof. etrans. 2: { apply maponpaths_2. exact p. } rewrite ! assoc'. do 3 apply maponpaths. rewrite <- tensor_comp_mor. rewrite id_right. apply maponpaths. apply pathsinv0, ir. Qed. Local Lemma diagram_2 : i · δ_{B} · (r #⊗ r) · (identity a #⊗ i) = i · δ_{B} · r #⊗ identity (pr1 B). Proof. etrans. 2: { apply maponpaths_2. exact p. } rewrite ! assoc'. do 3 apply maponpaths. rewrite <- tensor_comp_mor. rewrite id_right. apply maponpaths_2. apply pathsinv0, ir. Qed. Lemma transported_comonoid_laws_unit_left : comonoid_laws_unit_left L (a,, transported_comonoid_data). Proof. unfold comonoid_laws_unit_left. cbn. unfold transported_comonoid_comult_data. etrans. { apply maponpaths_2. unfold transported_comonoid_counit_data. rewrite tensor_mor_right. rewrite tensor_comp_id_r. rewrite assoc. apply maponpaths_2. apply diagram_1. } etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply tensor_swap'. } etrans. { rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. apply tensor_lunitor. } etrans. { rewrite assoc'. apply maponpaths. rewrite ! assoc. apply maponpaths_2. rewrite <- tensor_mor_right. apply comonoid_to_law_unit_left. } rewrite id_left. exact ir. Qed. Lemma transported_comonoid_laws_unit_right : comonoid_laws_unit_right L (a,, transported_comonoid_data). Proof. unfold comonoid_laws_unit_right. cbn. unfold transported_comonoid_comult_data. etrans. { apply maponpaths_2. unfold transported_comonoid_counit_data. rewrite tensor_mor_left. rewrite tensor_comp_id_l. rewrite assoc. apply maponpaths_2. apply diagram_2. } etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply tensor_swap. } etrans. { rewrite assoc'. apply maponpaths. rewrite assoc'. apply maponpaths. apply tensor_runitor. } etrans. { rewrite assoc'. apply maponpaths. rewrite ! assoc. apply maponpaths_2. rewrite <- tensor_mor_left. apply comonoid_to_law_unit_right. } rewrite id_left. exact ir. Qed. Lemma transported_comonoid_laws_assoc : comonoid_laws_assoc L (a,, transported_comonoid_data). Proof. unfold comonoid_laws_assoc. cbn. unfold transported_comonoid_comult_data. rewrite tensor_mor_left. rewrite tensor_mor_right. rewrite ! tensor_comp_id_l. rewrite ! tensor_comp_id_r. rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. exact (! diagram_2). } etrans. { do 3 apply maponpaths_2. exact diagram_1. } etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply tensor_swap'. } etrans. 2: { rewrite assoc. do 2 apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite <- tensor_mor_left. apply comonoid_to_law_assoc. } rewrite tensor_mor_right. rewrite ! assoc'. do 2 apply maponpaths. rewrite <- tensor_split'. etrans. 2: { apply maponpaths. apply tensor_lassociator. } rewrite ! assoc. apply maponpaths_2. rewrite <- tensor_split. do 2 rewrite <- tensor_comp_mor. apply maponpaths. exact (id_right _ @ ! id_left _). Qed. Definition transported_comonoid : disp_cat_of_comonoids L a. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact transported_comonoid_data. - exact transported_comonoid_laws_unit_left. - exact transported_comonoid_laws_unit_right. - exact transported_comonoid_laws_assoc. Defined. Definition transported_comonoid_mor : comonoid_mor_struct L (a,, transported_comonoid) B i. Proof. use make_is_comonoid_mor. - exact p. - apply id_right. Qed. End TransportingComonoidAlongRetractionPair. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/000077500000000000000000000000001451125700300233045ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/Monoidal.v000066400000000000000000000670751451125700300252540ustar00rootroot00000000000000(********************************************************************************* Displayed monoidal categories In this file, we define the notion of a displayed monoidal category. The style of the definition is similar to the definition of a monoidal category. Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/DisplayedMonoidalWhiskered.v *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Local Open Scope cat. Local Open Scope mor_disp_scope. Import MonoidalNotations. Import DisplayedBifunctorNotations. Section DisplayedMonoidalCategories. Definition disp_tensor {C : category} (D : disp_cat C) (M : monoidal C) : UU := disp_bifunctor M D D D. Identity Coercion disptensor_into_dispbifunctor : disp_tensor >-> disp_bifunctor. Definition disp_leftunitor_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) : UU := ∏ (x : C) (xx : D x), i ⊗⊗_{DT} xx -->[lu^{M}_{x}] xx. Definition disp_leftunitorinv_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) : UU := ∏ (x : C) (xx : D x), xx -->[luinv^{M}_{x}] i ⊗⊗_{DT} xx. Definition disp_rightunitor_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) : UU := ∏ (x : C) (xx : D x), xx ⊗⊗_{DT} i -->[ru^{M}_{x}] xx. Definition disp_rightunitorinv_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) : UU := ∏ (x : C) (xx : D x), xx -->[ruinv^{M}_{x}] xx ⊗⊗_{DT} i. Definition disp_associator_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), (xx ⊗⊗_{DT} yy) ⊗⊗_{DT} zz -->[α^{M}_{x,y,z}] xx ⊗⊗_{DT} (yy ⊗⊗_{DT} zz). Definition disp_associatorinv_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), xx ⊗⊗_{DT} (yy ⊗⊗_{DT} zz) -->[αinv_{M} x y z] (xx ⊗⊗_{DT} yy) ⊗⊗_{DT} zz. Definition disp_monoidal_data {C : category} (D : disp_cat C) (M : monoidal C) : UU := ∑ (DT : disp_tensor D M) (i : D I_{M}), (disp_leftunitor_data DT i) × (disp_leftunitorinv_data DT i) × (disp_rightunitor_data DT i) × (disp_rightunitorinv_data DT i) × (disp_associator_data DT) × (disp_associatorinv_data DT). Definition make_disp_monoidal_data_groupoidal {C : category} (D : disp_cat C) (gdisp : groupoidal_disp_cat D) (M : monoidal C) (DT : disp_tensor D M) (i : D I_{M}) (dlu : disp_leftunitor_data DT i) (dru : disp_rightunitor_data DT i) (dα : disp_associator_data DT) : disp_monoidal_data D M. Proof. exists DT. exists i. exists dlu. use tpair. { intros x xx. set (aux := gdisp _ _ _ (pr2 (leftunitor_nat_z_iso M) x) _ _ (dlu x xx)). exact (pr1 aux). } exists dru. use tpair. { intros x xx. set (aux := gdisp _ _ _ (pr2 (rightunitor_nat_z_iso M) x) _ _ (dru x xx)). exact (pr1 aux). } exists dα. intros x y z xx yy zz. set (aux := gdisp _ _ _ (pr2 (z_iso_from_associator_iso M x y z)) _ _ (dα x y z xx yy zz)). exact (pr1 aux). Defined. Definition disp_monoidal_tensor {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_tensor D M := pr1 DMD. Coercion disp_monoidal_tensor : disp_monoidal_data >-> disp_tensor. Definition disp_monoidal_unit {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : D I_{M} := pr12 DMD. Notation "dI_{ DMD }" := (disp_monoidal_unit DMD). Definition disp_monoidal_leftunitor {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_leftunitor_data DMD dI_{DMD} := pr122 DMD. Notation "dlu_{ DMD }" := (disp_monoidal_leftunitor DMD). Definition disp_monoidal_leftunitorinv {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_leftunitorinv_data DMD dI_{DMD} := pr1 (pr222 DMD). Notation "dluinv_{ DMD }" := (disp_monoidal_leftunitorinv DMD). Definition disp_monoidal_rightunitor {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_rightunitor_data DMD dI_{DMD} := pr12 (pr222 DMD). Notation "dru_{ DMD }" := (disp_monoidal_rightunitor DMD). Definition disp_monoidal_rightunitorinv {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_rightunitorinv_data DMD dI_{DMD} := pr122 (pr222 DMD). Notation "druinv_{ DMD }" := (disp_monoidal_rightunitorinv DMD). Definition disp_monoidal_associator {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_associator_data DMD := pr1 (pr222 (pr222 DMD)). Notation "dα_{ DMD }" := (disp_monoidal_associator DMD). Definition disp_monoidal_associatorinv {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_associatorinv_data DMD := pr2 (pr222 (pr222 DMD)). Notation "dαinv_{ DMD }" := (disp_monoidal_associatorinv DMD). (** PROPERTIES **) Definition disp_leftunitor_nat {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dlu : disp_leftunitor_data DT i) : UU := ∏ (x y : C) (f : C⟦x,y⟧) (xx : D x) (yy : D y) (ff : xx -->[f] yy), (i ⊗⊗^{DT}_{l} ff) ;; (dlu y yy) = transportb _ (pr1 (monoidal_leftunitorlaw M) _ _ _) (dlu x xx ;; ff). Definition disp_leftunitor_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dlu : disp_leftunitor_data DT i) (dluinv : disp_leftunitorinv_data DT i) : UU := ∏ (x : C) (xx : D x), is_disp_inverse (pr2 (monoidal_leftunitorlaw M) x) (dlu x xx) (dluinv x xx). Definition disp_leftunitor_law {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dlu : disp_leftunitor_data DT i) (dluinv : disp_leftunitorinv_data DT i) : UU := disp_leftunitor_nat dlu × disp_leftunitor_iso dlu dluinv. Definition disp_leftunitorlaw_nat {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} {dlu : disp_leftunitor_data DT i} {dluinv : disp_leftunitorinv_data DT i} (dlun : disp_leftunitor_law dlu dluinv) : disp_leftunitor_nat dlu := pr1 dlun. Definition disp_leftunitorlaw_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} {dlu : disp_leftunitor_data DT i} {dluinv : disp_leftunitorinv_data DT i} (dlui : disp_leftunitor_law dlu dluinv) : disp_leftunitor_iso dlu dluinv := pr2 dlui. Definition disp_rightunitor_nat {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dru : disp_rightunitor_data DT i) : UU := ∏ (x y : C) (f : C⟦x,y⟧) (xx : D x) (yy : D y) (ff : xx -->[f] yy), (ff ⊗⊗^{DT}_{r} i) ;; (dru y yy) = transportb _ (pr1 (monoidal_rightunitorlaw M) _ _ _) (dru x xx ;; ff). Definition disp_rightunitor_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dru : disp_rightunitor_data DT i) (druinv : disp_rightunitorinv_data DT i) : UU := ∏ (x : C) (xx : D x), is_disp_inverse (pr2 (monoidal_rightunitorlaw M) x) (dru x xx) (druinv x xx). Definition disp_rightunitor_law {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dru : disp_rightunitor_data DT i) (druinv : disp_rightunitorinv_data DT i) : UU := disp_rightunitor_nat dru × disp_rightunitor_iso dru druinv. Definition disp_rightunitorlaw_nat {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} {dru : disp_rightunitor_data DT i} {druinv : disp_rightunitorinv_data DT i} (drun : disp_rightunitor_law dru druinv) : disp_rightunitor_nat dru := pr1 drun. Definition disp_rightunitorlaw_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} {dru : disp_rightunitor_data DT i} {druinv : disp_rightunitorinv_data DT i} (drui : disp_rightunitor_law dru druinv) : disp_rightunitor_iso dru druinv := pr2 drui. Definition disp_associator_nat_leftwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) : UU := ∏ (x y z1 z2 : C) (h : C⟦z1,z2⟧) (xx : D x) (yy : D y) (zz1 : D z1) (zz2 : D z2) (hh : zz1-->[h] zz2), (dα _ _ _ xx yy zz1) ;; (xx ⊗⊗^{DT}_{l} (yy ⊗⊗^{DT}_{l} hh)) = transportb _ ((associatorlaw_natleft (monoidal_associatorlaw M)) x y z1 z2 h) (((xx ⊗⊗_{DT} yy) ⊗⊗^{DT}_{l} hh) ;; (dα _ _ _ xx yy zz2)). Definition disp_associator_nat_rightwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) : UU := ∏ (x1 x2 y z : C) (f : C⟦x1,x2⟧) (xx1 : D x1) (xx2 : D x2) (yy : D y) (zz : D z) (ff : xx1-->[f] xx2), (dα _ _ _ xx1 yy zz) ;; (ff ⊗⊗^{DT}_{r} (yy ⊗⊗_{DT} zz)) = transportb _ ((associatorlaw_natright (monoidal_associatorlaw M)) x1 x2 y z f) (((ff ⊗⊗^{DT}_{r} yy) ⊗⊗^{DT}_{r} zz) ;; (dα _ _ _ xx2 yy zz)). Definition disp_associator_nat_leftrightwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) : UU := ∏ (x y1 y2 z : C) (g : C⟦y1,y2⟧) (xx : D x) (yy1 : D y1) (yy2 : D y2) (zz : D z) (gg : yy1-->[g] yy2), (dα _ _ _ xx yy1 zz) ;; (xx ⊗⊗^{DT}_{l} (gg ⊗⊗^{DT}_{r} zz)) = transportb _ ((associatorlaw_natleftright (monoidal_associatorlaw M)) x y1 y2 z g) (((xx ⊗⊗^{DT}_{l} gg) ⊗⊗^{DT}_{r} zz) ;; (dα _ _ _ xx yy2 zz)). Definition disp_associator_nat' {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {dα : disp_associator_data DT} (dtl : disp_associator_nat_leftwhisker dα) (dtr : disp_associator_nat_rightwhisker dα) (dtlr : disp_associator_nat_leftrightwhisker dα) : ∏ (x1 x2 y1 y2 z1 z2 : C) (xx1 : D x1) (xx2 : D x2) (yy1 : D y1) (yy2 : D y2) (zz1 : D z1) (zz2 : D z2) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧) (h : C⟦z1,z2⟧) (ff : xx1-->[f] xx2) (gg : yy1 -->[g] yy2) (hh : zz1 -->[h] zz2), ((dα _ _ _ xx1 yy1 zz1) ;; (ff ⊗⊗^{DT} (gg ⊗⊗^{DT} hh))) = transportb _ (associator_nat2 M f g h) (((ff ⊗⊗^{DT} gg) ⊗⊗^{DT} hh) ;; dα _ _ _ xx2 yy2 zz2). Proof. intros. unfold dispfunctoronmorphisms1. etrans. { apply assoc_disp. } rewrite dtr. etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } rewrite transport_b_f. apply transportf_transpose_left. etrans. { apply assoc_disp_var. } apply transportf_transpose_left. rewrite transport_b_b. rewrite transport_b_b. etrans. { apply maponpaths_1. apply maponpaths_1. apply disp_bifunctor_leftcomp. } etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } etrans. { apply maponpaths_1. rewrite assoc_disp. rewrite dtlr. apply transport_f_b. } etrans. { apply maponpaths. apply maponpaths. apply mor_disp_transportf_postwhisker. } etrans. { apply maponpaths. apply transport_f_f. } etrans. { apply mor_disp_transportf_prewhisker. } apply transportf_transpose_left. etrans. { apply maponpaths_1. rewrite assoc_disp_var. apply maponpaths_1. apply maponpaths_1. apply dtl. } etrans. { apply mor_disp_transportf_prewhisker. } apply transportf_transpose_left. etrans. { apply maponpaths. apply mor_disp_transportf_prewhisker. } etrans. { apply mor_disp_transportf_prewhisker. } apply transportf_transpose_left. rewrite assoc_disp. etrans. { apply maponpaths. apply maponpaths_2. apply (pathsinv0 (transportb_transpose_left (disp_bifunctor_rightcomp DT _ _ _ _ _ _ _ _ _ _ _ _))). } rewrite transport_b_b. rewrite transport_b_b. rewrite transport_b_b. etrans. { apply maponpaths. apply mor_disp_transportf_postwhisker. } rewrite transport_b_f. apply transportf_transpose_left. rewrite transport_b_b. etrans. { apply assoc_disp. } apply transportb_transpose_left. use pathsinv0. rewrite transport_f_b. apply transportf_set. apply homset_property. Qed. Definition disp_associator_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) (dαinv : disp_associatorinv_data DT) : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), is_disp_inverse (pr222 (monoidal_associatorlaw M) x y z) (dα _ _ _ xx yy zz) (dαinv _ _ _ xx yy zz). Definition disp_associator_law {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) (dαinv : disp_associatorinv_data DT) : UU := (disp_associator_nat_leftwhisker dα) × (disp_associator_nat_rightwhisker dα) × (disp_associator_nat_leftrightwhisker dα) × (disp_associator_iso dα dαinv). Definition disp_associatorlaw_natleft {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {dα : disp_associator_data DT} {dαinv : disp_associatorinv_data DT} (dαl : disp_associator_law dα dαinv) : disp_associator_nat_leftwhisker dα := pr1 dαl. Definition disp_associatorlaw_natright {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {dα : disp_associator_data DT} {dαinv : disp_associatorinv_data DT} (dαl : disp_associator_law dα dαinv) : disp_associator_nat_rightwhisker dα := pr12 dαl. Definition disp_associatorlaw_natleftright {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {dα : disp_associator_data DT} {dαinv : disp_associatorinv_data DT} (dαl : disp_associator_law dα dαinv) : disp_associator_nat_leftrightwhisker dα := pr122 dαl. Definition disp_associatorlaw_iso {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {dα : disp_associator_data DT} {dαinv : disp_associatorinv_data DT} (dαl : disp_associator_law dα dαinv) : disp_associator_iso dα dαinv := pr222 dαl. Definition disp_triangle_identity {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dlu : disp_leftunitor_data DT i) (dru : disp_rightunitor_data DT i) (dα : disp_associator_data DT) : UU := ∏ (x y : C) (xx : D x) (yy : D y), ((dα x I_{M} y xx i yy) ;; (xx ⊗⊗^{DT}_{l} dlu y yy )) = transportb _ ((monoidal_triangleidentity M) x y) ((dru x xx) ⊗⊗^{DT}_{r} yy). Definition disp_pentagon_identity {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) : UU := ∏ (w x y z : C) (ww : D w) (xx : D x) (yy : D y) (zz : D z), ((dα _ _ _ ww xx yy) ⊗⊗^{DT}_{r} zz) ;; (dα _ _ _ ww (xx ⊗⊗_{DT} yy) zz) ;; (ww ⊗⊗^{DT}_{l} (dα _ _ _ xx yy zz)) = transportb _ ((monoidal_pentagonidentity M) w x y z) ((dα _ _ _ (ww ⊗⊗_{DT} xx) yy zz) ;; (dα _ _ _ ww xx (yy ⊗⊗_{DT} zz))). Definition disp_monoidal_laws {C : category} {D : disp_cat C} {M : monoidal C} (DMD : disp_monoidal_data D M) : UU := (disp_leftunitor_law dlu_{DMD} dluinv_{DMD}) × (disp_rightunitor_law dru_{DMD} druinv_{DMD}) × (disp_associator_law dα_{DMD} dαinv_{DMD}) × (disp_triangle_identity dlu_{DMD} dru_{DMD} dα_{DMD}) × (disp_pentagon_identity dα_{DMD}). Definition disp_monoidal {C : category} (D : disp_cat C) (M : monoidal C) : UU := ∑ (MD : disp_monoidal_data D M), (disp_monoidal_laws MD). Definition make_disp_monoidal_locally_prop {C : category} {D : disp_cat C} (LP : locally_propositional D) {M : monoidal C} (DMD : disp_monoidal_data D M) : disp_monoidal D M. Proof. exists DMD. abstract (repeat split ; try intro ; intros ; apply LP). Defined. Definition make_disp_monoidal_groupoidal {C : category} {D : disp_cat C} (gdisp : groupoidal_disp_cat D) {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) (dlu : disp_leftunitor_data DT i) (dru : disp_rightunitor_data DT i) (dα : disp_associator_data DT) : let DMD := make_disp_monoidal_data_groupoidal D gdisp M DT i dlu dru dα in ∏ (dlu_nat : disp_leftunitor_nat dlu_{DMD}) (dru_nat : disp_rightunitor_nat dru_{DMD}) (dα_nat_left : disp_associator_nat_leftwhisker dα_{DMD}) (dα_nat_right : disp_associator_nat_rightwhisker dα_{DMD}) (dα_nat_left_right : disp_associator_nat_leftrightwhisker dα_{DMD}) (dtriangle : disp_triangle_identity dlu_{DMD} dru_{DMD} dα_{DMD}) (dpentagon : disp_pentagon_identity dα_{DMD}), disp_monoidal D M. Proof. intros. use tpair. - exact DMD. - split5. + split. * exact dlu_nat. * intros x xx. set (aux := gdisp _ _ _ (pr2 (leftunitor_nat_z_iso M) x) _ _ (dlu x xx)). exact (pr2 aux). + split. * exact dru_nat. * intros x xx. set (aux := gdisp _ _ _ (pr2 (rightunitor_nat_z_iso M) x) _ _ (dru x xx)). exact (pr2 aux). + split4. * exact dα_nat_left. * exact dα_nat_right. * exact dα_nat_left_right. * intros x y z xx yy zz. set (aux := gdisp _ _ _ (pr2 (z_iso_from_associator_iso M x y z)) _ _ (dα x y z xx yy zz)). exact (pr2 aux). + exact dtriangle. + exact dpentagon. Defined. Definition disp_monoidal_mondata {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_monoidal_data D M := pr1 DM. Coercion disp_monoidal_mondata : disp_monoidal >-> disp_monoidal_data. Definition disp_monoidal_monlaws {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_monoidal_laws DM := pr2 DM. Definition disp_monoidal_leftunitorlaw {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_leftunitor_law dlu_{DM} dluinv_{DM} := pr1 (disp_monoidal_monlaws DM). Definition disp_monoidal_leftunitornat {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_leftunitor_nat dlu_{DM} := disp_leftunitorlaw_nat (disp_monoidal_leftunitorlaw DM). Definition disp_monoidal_leftunitoriso {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_leftunitor_iso dlu_{DM} dluinv_{DM} := disp_leftunitorlaw_iso (disp_monoidal_leftunitorlaw DM). Definition disp_monoidal_rightunitorlaw {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_rightunitor_law dru_{DM} druinv_{DM} := pr12 (disp_monoidal_monlaws DM). Definition disp_monoidal_rightunitornat {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_rightunitor_nat dru_{DM} := disp_rightunitorlaw_nat (disp_monoidal_rightunitorlaw DM). Definition disp_monoidal_rightunitoriso {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_rightunitor_iso dru_{DM} druinv_{DM} := disp_rightunitorlaw_iso (disp_monoidal_rightunitorlaw DM). Definition disp_monoidal_associatorlaw {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_associator_law dα_{DM} dαinv_{DM} := pr122 (disp_monoidal_monlaws DM). Definition disp_monoidal_associatornatleft {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_associator_nat_leftwhisker dα_{DM} := disp_associatorlaw_natleft (disp_monoidal_associatorlaw DM). Definition disp_monoidal_associatornatright {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_associator_nat_rightwhisker dα_{DM} := disp_associatorlaw_natright (disp_monoidal_associatorlaw DM). Definition disp_monoidal_associatornatleftright {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_associator_nat_leftrightwhisker dα_{DM} := disp_associatorlaw_natleftright (disp_monoidal_associatorlaw DM). Definition disp_monoidal_associatoriso {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_associator_iso dα_{DM} dαinv_{DM} := disp_associatorlaw_iso (disp_monoidal_associatorlaw DM). Definition disp_monoidal_triangleidentity {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_triangle_identity dlu_{DM} dru_{DM} dα_{DM} := pr1 (pr222 (disp_monoidal_monlaws DM)). Definition disp_monoidal_pentagonidentity {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : disp_pentagon_identity dα_{DM} := pr2 (pr222 (disp_monoidal_monlaws DM)). Lemma isaprop_disp_monoidal_laws {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal_data D M) : isaprop (disp_monoidal_laws DM). Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; repeat (try apply D) ; repeat (apply isaprop_is_disp_inverse). Qed. End DisplayedMonoidalCategories. Module DisplayedMonoidalNotations. Notation "dI_{ M }" := (disp_monoidal_unit M). Notation "dlu^{ M }" := (disp_monoidal_leftunitor M). Notation "dru^{ M }" := (disp_monoidal_rightunitor M). Notation "dα^{ M }" := (disp_monoidal_associator M). Notation "dluinv^{ M }" := (disp_monoidal_leftunitorinv M). Notation "druinv^{ M }" := (disp_monoidal_rightunitorinv M). Notation "dαinv^{ M }" := (disp_monoidal_associatorinv M). Notation "dlu^{ M }_{ xx }" := (disp_monoidal_leftunitor M _ xx). Notation "dru^{ M }_{ xx }" := (disp_monoidal_rightunitor M _ xx). Notation "dα^{ M }_{ xx , yy , zz }" := (disp_monoidal_associator M _ _ _ xx yy zz). Notation "dluinv^{ M }_{ xx }" := (disp_monoidal_leftunitorinv M _ xx). Notation "druinv^{ M }_{ xx }" := (disp_monoidal_rightunitorinv M _ xx). Notation "dαinv^{ M }_{ xx , yy , zz }" := (disp_monoidal_associatorinv M _ _ _ xx yy zz). End DisplayedMonoidalNotations. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/MonoidalFunctorLifting.v000066400000000000000000000360071451125700300301210ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope cat. Local Open Scope mor_disp_scope. Section MonoidalFunctorLifting. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Context {C' C : category} {F : functor C' C} {D : disp_cat C}. Let TD : category := total_category D. Context {M' : monoidal C'} {M : monoidal C} (Fm : fmonoidal_lax M' M F) (DM : disp_monoidal D M). Let TM : monoidal TD := total_monoidal DM. Context (sd : functor_lifting D F). Definition fl_preserves_tensor_data : UU := ∏ (x y : C'), sd x ⊗⊗_{DM} sd y -->[fmonoidal_preservestensordata Fm x y] sd (x ⊗_{M'} y). Lemma functorlifting_preserves_tensordata (sd_pt : fl_preserves_tensor_data) : preserves_tensordata M' TM (lifted_functor sd). Proof. intros x y. exists (fmonoidal_preservestensordata Fm x y). exact (sd_pt x y). Defined. Definition fl_preserves_unit : UU := dI_{DM} -->[fmonoidal_preservesunit Fm] sd I_{M'}. Lemma functorlifting_preserves_unit (sp_pu : fl_preserves_unit) : preserves_unit M' TM (lifted_functor sd). Proof. exists (fmonoidal_preservesunit Fm). exact sp_pu. Defined. Definition flmonoidal_data : UU := fl_preserves_tensor_data × fl_preserves_unit. Definition flmonoidal_preserves_tensor_data (ms : flmonoidal_data) : fl_preserves_tensor_data := pr1 ms. Definition flmonoidal_preserves_unit (ms : flmonoidal_data) : fl_preserves_unit := pr2 ms. Definition functorlifting_monoidal_data (ms : flmonoidal_data) : fmonoidal_data M' TM (lifted_functor sd). Proof. split. - exact (functorlifting_preserves_tensordata (flmonoidal_preserves_tensor_data ms)). - exact (functorlifting_preserves_unit (flmonoidal_preserves_unit ms)). Defined. (* This notation comes from Constructions.v, but there is no Notation module, this has to be added *) Notation "# F" := (section_disp_on_morphisms F) (at level 3) : mor_disp_scope. Definition fl_preserves_tensor_nat_left (spt : fl_preserves_tensor_data) : UU := ∏ (x y1 y2 : C') (g : C'⟦y1,y2⟧), sd x ⊗⊗^{DM}_{l} # sd g ;; spt x y2 = transportb _ (fmonoidal_preservestensornatleft Fm x y1 y2 g) (spt x y1 ;; # sd (x ⊗^{M'}_{l} g)). Lemma functorlifting_preserves_tensor_nat_left {spt : fl_preserves_tensor_data} (sptnl : fl_preserves_tensor_nat_left spt) : preserves_tensor_nat_left (functorlifting_preserves_tensordata spt). Proof. intros x y1 y2 g. use total2_paths_b. - exact (fmonoidal_preservestensornatleft Fm x y1 y2 g). - exact (sptnl x y1 y2 g). Qed. Definition fl_preserves_tensor_nat_right (spt : fl_preserves_tensor_data) : UU := ∏ (x1 x2 y : C') (f : C'⟦x1,x2⟧), # sd f ⊗⊗^{DM}_{r} sd y ;; spt x2 y = transportb _ (fmonoidal_preservestensornatright Fm x1 x2 y f) (spt x1 y ;; # sd (f ⊗^{M'}_{r} y)). Lemma functorlifting_preserves_tensor_nat_right {spt : fl_preserves_tensor_data} (sptnl : fl_preserves_tensor_nat_right spt) : preserves_tensor_nat_right (functorlifting_preserves_tensordata spt). Proof. intros x1 x2 y f. use total2_paths_b. - exact (fmonoidal_preservestensornatright Fm x1 x2 y f). - exact (sptnl x1 x2 y f). Qed. Definition fl_preserves_leftunitality (spt : fl_preserves_tensor_data) (spu : fl_preserves_unit) : UU := ∏ (x : C'), spu ⊗⊗^{DM}_{r} sd x ;; spt I_{M'} x ;; # sd lu^{M'}_{x} = transportb _ (fmonoidal_preservesleftunitality Fm x) dlu^{DM}_{sd x}. Definition functorlifting_preserves_leftunitality {spt : fl_preserves_tensor_data} {spu : fl_preserves_unit} (splu : fl_preserves_leftunitality spt spu) : preserves_leftunitality (functorlifting_preserves_tensordata spt) (functorlifting_preserves_unit spu). Proof. intro x. use total2_paths_b. - exact (fmonoidal_preservesleftunitality Fm x). - exact (splu x). Qed. Definition fl_preserves_rightunitality (spt : fl_preserves_tensor_data) (spu : fl_preserves_unit) : UU := ∏ (x : C'), sd x ⊗⊗^{DM}_{l} spu ;; spt x I_{M'} ;; # sd ru^{M'}_{x} = transportb _ (fmonoidal_preservesrightunitality Fm x) dru^{DM}_{sd x}. Definition functorlifting_preserves_rightunitality {spt : fl_preserves_tensor_data} {spu : fl_preserves_unit} (spru : fl_preserves_rightunitality spt spu) : preserves_rightunitality (functorlifting_preserves_tensordata spt) (functorlifting_preserves_unit spu). Proof. intro x. use total2_paths_b. - exact (fmonoidal_preservesrightunitality Fm x). - exact (spru x). Qed. Definition fl_preserves_associativity (spt : fl_preserves_tensor_data ) : UU := ∏ (x y z : C'), spt x y ⊗⊗^{DM}_{r} sd z ;; spt (x ⊗_{M'} y) z ;; # sd α^{M'}_{x, y, z} = transportb _ (fmonoidal_preservesassociativity Fm x y z) (dα^{DM}_{sd x, sd y, sd z} ;; sd x ⊗⊗^{DM}_{l} spt y z ;; spt x (y ⊗_{M'} z)). Definition functorlifting_preserves_associativity {spt : fl_preserves_tensor_data} (spa : fl_preserves_associativity spt) : preserves_associativity (functorlifting_preserves_tensordata spt). Proof. intros x y z. use total2_paths_b. - exact (fmonoidal_preservesassociativity Fm x y z). - exact (spa x y z). Qed. Definition flmonoidal_laxlaws (ms : flmonoidal_data) : UU := fl_preserves_tensor_nat_left (flmonoidal_preserves_tensor_data ms) × fl_preserves_tensor_nat_right (flmonoidal_preserves_tensor_data ms) × fl_preserves_associativity (flmonoidal_preserves_tensor_data ms) × fl_preserves_leftunitality (flmonoidal_preserves_tensor_data ms) (flmonoidal_preserves_unit ms) × fl_preserves_rightunitality (flmonoidal_preserves_tensor_data ms) (flmonoidal_preserves_unit ms). Definition flmonoidal_preserves_tensornatleft {ms : flmonoidal_data} (msl : flmonoidal_laxlaws ms) : fl_preserves_tensor_nat_left (flmonoidal_preserves_tensor_data ms) := pr1 msl. Definition flmonoidal_preserves_tensornatright {ms : flmonoidal_data} (msl : flmonoidal_laxlaws ms) : fl_preserves_tensor_nat_right (flmonoidal_preserves_tensor_data ms) := pr12 msl. Definition flmonoidal_preserves_associativity {ms : flmonoidal_data} (msl : flmonoidal_laxlaws ms) : fl_preserves_associativity (flmonoidal_preserves_tensor_data ms) := pr122 msl. Definition flmonoidal_preserves_leftunitality {ms : flmonoidal_data} (msl : flmonoidal_laxlaws ms) : fl_preserves_leftunitality (flmonoidal_preserves_tensor_data ms) (flmonoidal_preserves_unit ms) := pr122 (pr2 msl). Definition flmonoidal_preserves_rightunitality {ms : flmonoidal_data} (msl : flmonoidal_laxlaws ms) : fl_preserves_rightunitality (flmonoidal_preserves_tensor_data ms) (flmonoidal_preserves_unit ms) := pr222 (pr2 msl). Definition flmonoidal_lax : UU := ∑ (ms : flmonoidal_data), flmonoidal_laxlaws ms. Definition flmonoidal_lax_to_data (sm : flmonoidal_lax) : flmonoidal_data := pr1 sm. Coercion flmonoidal_lax_to_data : flmonoidal_lax >-> flmonoidal_data. Definition flmonoidal_lax_to_laxlaws (sm : flmonoidal_lax) : flmonoidal_laxlaws sm := pr2 sm. Definition functorlifting_monoidal_laxlaws {ms : flmonoidal_data} (ml : flmonoidal_laxlaws ms) : fmonoidal_laxlaws (functorlifting_monoidal_data ms) := (functorlifting_preserves_tensor_nat_left (flmonoidal_preserves_tensornatleft ml),, functorlifting_preserves_tensor_nat_right (flmonoidal_preserves_tensornatright ml),, functorlifting_preserves_associativity (flmonoidal_preserves_associativity ml),, functorlifting_preserves_leftunitality (flmonoidal_preserves_leftunitality ml),, functorlifting_preserves_rightunitality (flmonoidal_preserves_rightunitality ml) ). Definition functorlifting_fmonoidal_lax (ms : flmonoidal_lax) : fmonoidal_lax M' TM (lifted_functor sd) := _ ,, functorlifting_monoidal_laxlaws (flmonoidal_lax_to_laxlaws ms). (* We now define functor liftings of strong monoidal functors and show that they induce a strong monoidal functor *) Definition fl_strongtensor (spt : fl_preserves_tensor_data) (Fs : preserves_tensor_strongly (fmonoidal_preservestensordata Fm)) : UU := ∏ (x y : C'), is_z_iso_disp (_ ,, Fs x y) (spt x y). Definition fl_strongunit (spu : fl_preserves_unit) (Fs : preserves_unit_strongly (fmonoidal_preservesunit Fm)) : UU := is_z_iso_disp (_,, Fs) spu. Definition fl_stronglaws (ms : flmonoidal_lax) (Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)) : UU := fl_strongtensor (flmonoidal_preserves_tensor_data ms) (fmonoidal_preservestensorstrongly ((Fm,,Fs) : fmonoidal M' M F)) × fl_strongunit (flmonoidal_preserves_unit ms) (fmonoidal_preservesunitstrongly ((Fm,,Fs) : fmonoidal M' M F)). Definition flmonoidal (Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)) : UU := ∑ ms : flmonoidal_lax, fl_stronglaws ms Fs. Definition flmonoidal_to_flmonoidal_lax {Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)} (sm : flmonoidal Fs) : flmonoidal_lax := pr1 sm. Coercion flmonoidal_to_flmonoidal_lax : flmonoidal >-> flmonoidal_lax. Definition flmonoidal_to_fl_stronglaws {Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)} (sm : flmonoidal Fs) : fl_stronglaws sm Fs := pr2 sm. Definition flmonoidal_to_flmonoidalstrongtensor {Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)} (sm : flmonoidal Fs) : fl_strongtensor (flmonoidal_preserves_tensor_data sm) (fmonoidal_preservestensorstrongly ((Fm,,Fs) : fmonoidal M' M F)) := pr1 (flmonoidal_to_fl_stronglaws sm). Definition flmonoidal_to_flmonoidalstrongunit {Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)} (sm : flmonoidal Fs) : fl_strongunit (flmonoidal_preserves_unit sm) (fmonoidal_preservesunitstrongly ((Fm,,Fs) : fmonoidal M' M F)) := pr2 (flmonoidal_to_fl_stronglaws sm). Definition functorlifting_preservestensorstrongly {Fs : preserves_tensor_strongly (fmonoidal_preservestensordata Fm)} {ms : flmonoidal_lax} (pfstrong : fl_strongtensor (flmonoidal_preserves_tensor_data ms) Fs) : preserves_tensor_strongly (functorlifting_preserves_tensordata (flmonoidal_preserves_tensor_data ms)). Proof. intros x y. use tpair. - exists (pr1 (Fs x y)). exact (pr1 (pfstrong x y)). - use tpair. + use total2_paths_b. * exact (pr12 (Fs x y)). * exact (pr22 (pfstrong x y)). + use total2_paths_b. * exact (pr22 (Fs x y)). * exact (pr12 (pfstrong x y)). Defined. Definition functorlifting_preservesunitstrongly {Fs : preserves_unit_strongly (fmonoidal_preservesunit Fm)} {ms : flmonoidal_lax} (pfstrong : fl_strongunit (flmonoidal_preserves_unit ms) Fs) : preserves_unit_strongly (functorlifting_preserves_unit (flmonoidal_preserves_unit ms)). Proof. use tpair. - exists (pr1 Fs). exact (pr1 pfstrong). - use tpair. + use total2_paths_b. * exact (pr12 Fs). * exact (pr22 pfstrong). + use total2_paths_b. * exact (pr22 Fs). * exact (pr12 pfstrong). Defined. Definition functorlifting_fmonoidal {Fs : fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm)} (fls : flmonoidal Fs) : fmonoidal M' TM (lifted_functor sd). Proof. exists (functorlifting_fmonoidal_lax fls). use tpair. - use functorlifting_preservestensorstrongly. + apply Fs. + apply fls. - use functorlifting_preservesunitstrongly. + apply Fs. + apply fls. Defined. Lemma isaprop_flmonoidal_laxlaws (fl : flmonoidal_data) : isaprop (flmonoidal_laxlaws fl). Proof. repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; apply homsets_disp. Qed. Lemma isaprop_flmonoidal_stronglaws {Fm_strong : fmonoidal_stronglaws (pr11 Fm) (pr21 Fm)} (fl : flmonoidal Fm_strong) : isaprop (fl_stronglaws (pr1 fl) Fm_strong). Proof. apply isapropdirprod ; repeat (apply impred_isaprop ; intro) ; apply Isos.isaprop_is_z_iso_disp. Qed. Lemma flmonoidal_equality (fl1 fl2 : flmonoidal_lax) : (∏ x y : C', pr11 fl1 x y = pr11 fl2 x y) -> (pr21 fl1 = pr21 fl2) -> fl1 = fl2. Proof. intros pT pU. use total2_paths_f. 2: apply isaprop_flmonoidal_laxlaws. use total2_paths_f. - do 2 (apply funextsec ; intro). apply pT. - cbn. rewrite transportf_const. exact pU. Qed. Lemma flmonoidal_strong_equality {Fm_strong : fmonoidal_stronglaws (pr11 Fm) (pr21 Fm)} (fl1 fl2 : flmonoidal Fm_strong) : (∏ x y : C', pr111 fl1 x y = pr111 fl2 x y) -> (pr211 fl1 = pr211 fl2) -> fl1 = fl2. Proof. intros pT pU. use total2_paths_f. - use flmonoidal_equality. + exact pT. + exact pU. - apply isaprop_flmonoidal_stronglaws. Qed. End MonoidalFunctorLifting. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/MonoidalSections.v000066400000000000000000000411651451125700300267540ustar00rootroot00000000000000(********************************************************************************* Monoidal sections A section on a displayed monoidal category is data and properties such that we can construct a lax/strong monoidal functor from the base to the total category. Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/MonoidalSectionsWhiskered.v *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Local Open Scope cat. Local Open Scope mor_disp_scope. Section MonoidalSections. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Context {C : category} {D : disp_cat C}. Let TD : category := total_category D. Context (M : monoidal C) (DM : disp_monoidal D M). Let TM : monoidal TD := total_monoidal DM. Definition section_preserves_tensor_data (sd : section_disp D) : UU := ∏ (x y : C), sd x ⊗⊗_{DM} sd y -->[identity (x ⊗_{M} y)] sd (x ⊗_{M} y). Lemma sectionfunctor_preserves_tensordata {sd : section_disp D} (spt : section_preserves_tensor_data sd) : preserves_tensordata M TM (section_functor sd). Proof. intros x y. use tpair. - apply identity. - apply spt. Defined. Definition section_preserves_unit (sd : section_disp D) : UU := dI_{DM} -->[identity I_{M}] sd I_{M}. Lemma sectionfunctor_preserves_unit {sd : section_disp D} (spu : section_preserves_unit sd) : preserves_unit M TM (section_functor sd). Proof. use tpair. - apply identity. - apply spu. Defined. Definition smonoidal_data (sd : section_disp D) : UU := (section_preserves_tensor_data sd) × (section_preserves_unit sd). Definition smonoidal_preserves_tensor {sd : section_disp D} (ms : smonoidal_data sd) : section_preserves_tensor_data sd := pr1 ms. Definition smonoidal_preserves_unit {sd : section_disp D} (ms : smonoidal_data sd) : section_preserves_unit sd := pr2 ms. Definition sectionfunctor_fmonoidal_data {sd : section_disp D} (spt : section_preserves_tensor_data sd) (spu : section_preserves_unit sd) : fmonoidal_data M TM (section_functor sd) := (sectionfunctor_preserves_tensordata spt,,sectionfunctor_preserves_unit spu). (* This notation comes from Constructions.v, but there is no Notation module, this has to be added *) Notation "# F" := (section_disp_on_morphisms F) (at level 3) : mor_disp_scope. Definition section_preserves_tensor_nat_left {sd : section_disp D} (spt : section_preserves_tensor_data sd) : UU := ∏ (x y1 y2 : C) (g : C⟦y1,y2⟧), (sd x ⊗⊗^{DM}_{l} #sd g) ;; spt x y2 = transportb _ (id_right (x ⊗^{M}_{l} g) @ pathsinv0 (id_left (x ⊗^{M}_{l} g))) (spt x y1 ;; #sd (x ⊗^{M}_{l} g)). Lemma sectionfunctor_preserves_tensor_nat_left {sd : section_disp D} {spt : section_preserves_tensor_data sd} (sptnl : section_preserves_tensor_nat_left spt) : preserves_tensor_nat_left (sectionfunctor_preserves_tensordata spt). Proof. intros x y1 y2 g. use total2_paths_b. - cbn. rewrite id_left. apply id_right. - cbn. rewrite sptnl. apply transportb_transpose_left. rewrite transport_f_b. apply pathsinv0. apply transportf_set. apply homset_property. Qed. Definition section_preserves_tensor_nat_right {sd : section_disp D} (spt : section_preserves_tensor_data sd) : UU := ∏ (x1 x2 y : C) (f : C⟦x1,x2⟧), (#sd f ⊗⊗^{DM}_{r} sd y) ;; spt x2 y = transportb _ (id_right (f ⊗^{M}_{r} y) @ pathsinv0 (id_left (f ⊗^{M}_{r} y))) (spt x1 y ;; #sd (f ⊗^{M}_{r} y)). Lemma sectionfunctor_preserves_tensor_nat_right {sd : section_disp D} {spt : section_preserves_tensor_data sd} (sptnl : section_preserves_tensor_nat_right spt) : preserves_tensor_nat_right (sectionfunctor_preserves_tensordata spt). Proof. intros x1 x2 y f. use total2_paths_b. - cbn. rewrite id_left. apply id_right. - cbn. rewrite sptnl. apply transportb_transpose_left. rewrite transport_f_b. apply pathsinv0. apply transportf_set. apply homset_property. Qed. (* This equality I should have somewhere, have to check in different files *) Definition equality_for_leftunitality (x : C) : identity I_{M} ⊗^{M}_{r} x · identity (I_{M} ⊗_{M} x) · lu^{M}_{x} = lu^{M}_{x}. Proof. rewrite assoc'. rewrite (bifunctor_rightid M). rewrite id_left. apply id_left. Qed. Definition section_preserves_leftunitality {sd : section_disp D} (spt : section_preserves_tensor_data sd) (spu : section_preserves_unit sd) : UU := ∏ (x : C), spu ⊗⊗^{DM}_{r} sd x ;; spt I_{M} x ;; # sd lu^{M}_{x} = transportb _ (equality_for_leftunitality x) (dlu^{DM}_{sd x}). Definition sectionfunctor_preserves_leftunitality {sd : section_disp D} {spt : section_preserves_tensor_data sd} {spu : section_preserves_unit sd} (splu : section_preserves_leftunitality spt spu) : preserves_leftunitality (sectionfunctor_preserves_tensordata spt) (sectionfunctor_preserves_unit spu). Proof. intro x. use total2_paths_b. - cbn. rewrite assoc'. rewrite (bifunctor_rightid M). rewrite id_left. apply id_left. - cbn. rewrite splu. apply transportb_transpose_left. rewrite transport_f_b. apply pathsinv0. apply transportf_set. apply homset_property. Qed. (* This equality I should have somewhere, have to check in different files *) Definition equality_for_rightunitality (x : C) : x ⊗^{M}_{l} identity I_{M} · identity (x ⊗_{M} I_{M}) · ru^{M}_{x} = ru^{M}_{x}. Proof. rewrite assoc'. rewrite (bifunctor_leftid M). rewrite id_left. apply id_left. Qed. Definition section_preserves_rightunitality {sd : section_disp D} (spt : section_preserves_tensor_data sd) (spu : section_preserves_unit sd) : UU := ∏ (x : C), sd x ⊗⊗^{DM}_{l} spu ;; spt x I_{M} ;; # sd ru^{M}_{x} = transportb _ (equality_for_rightunitality x) (dru^{DM}_{sd x}). Definition sectionfunctor_preserves_rightunitality {sd : section_disp D} {spt : section_preserves_tensor_data sd} {spu : section_preserves_unit sd} (spru : section_preserves_rightunitality spt spu) : preserves_rightunitality (sectionfunctor_preserves_tensordata spt) (sectionfunctor_preserves_unit spu). Proof. intro x. use total2_paths_b. - cbn. rewrite assoc'. rewrite (bifunctor_leftid M). rewrite id_left. apply id_left. - cbn. rewrite spru. apply transportb_transpose_left. rewrite transport_f_b. apply pathsinv0. apply transportf_set. apply homset_property. Qed. (* This equality I should have somewhere, have to check in different files *) Definition equality_for_associativity (x y z : C) : identity (x ⊗_{M} y) ⊗^{M}_{r} z · identity ((x ⊗_{M} y) ⊗_{M} z) · α^{M}_{ x, y, z} = α^{M}_{ x, y, z} · x ⊗^{M}_{l} identity (y ⊗_{M} z) · identity (x ⊗_{M} (y ⊗_{M} z)). Proof. rewrite assoc'. rewrite (bifunctor_leftid M). rewrite id_left. rewrite id_right. rewrite id_right. rewrite (bifunctor_rightid M). apply id_left. Qed. Definition section_preserves_associativity {sd : section_disp D} (spt : section_preserves_tensor_data sd) : UU := ∏ (x y z : C), spt x y ⊗⊗^{DM}_{r} sd z ;; spt (x ⊗_{M} y) z ;; # sd α^{M}_{ x, y, z} = transportb _ (equality_for_associativity x y z) (dα^{DM}_{ sd x, sd y, sd z} ;; sd x ⊗⊗^{DM}_{l} spt y z ;; spt x (y ⊗_{M} z)). Definition sectionfunctor_preserves_associativity {sd : section_disp D} {spt : section_preserves_tensor_data sd} (spa : section_preserves_associativity spt) : preserves_associativity (sectionfunctor_preserves_tensordata spt). Proof. intros x y z. use total2_paths_b. - cbn. rewrite assoc'. rewrite (bifunctor_leftid M). rewrite id_right. rewrite id_right. rewrite id_left. rewrite (bifunctor_rightid M). apply id_left. - cbn. rewrite spa. apply transportb_transpose_left. rewrite transport_f_b. apply pathsinv0. apply transportf_set. apply homset_property. Qed. Definition smonoidal_laxlaws {sd : section_disp D} (ms : smonoidal_data sd) : UU := (section_preserves_tensor_nat_left (smonoidal_preserves_tensor ms)) × (section_preserves_tensor_nat_right (smonoidal_preserves_tensor ms)) × (section_preserves_associativity (smonoidal_preserves_tensor ms)) × (section_preserves_leftunitality (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms)) × (section_preserves_rightunitality (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms)). Definition smonoidal_preserves_tensornatleft {sd : section_disp D} {ms : smonoidal_data sd} (msl : smonoidal_laxlaws ms) : section_preserves_tensor_nat_left (smonoidal_preserves_tensor ms) := pr1 msl. Definition smonoidal_preserves_tensornatright {sd : section_disp D} {ms : smonoidal_data sd} (msl : smonoidal_laxlaws ms) : section_preserves_tensor_nat_right (smonoidal_preserves_tensor ms) := pr1 (pr2 msl). Definition smonoidal_preserves_associativity {sd : section_disp D} {ms : smonoidal_data sd} (msl : smonoidal_laxlaws ms) : section_preserves_associativity (smonoidal_preserves_tensor ms) := pr1 (pr2 (pr2 msl)). Definition smonoidal_preserves_leftunitality {sd : section_disp D} {ms : smonoidal_data sd} (msl : smonoidal_laxlaws ms) : section_preserves_leftunitality (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms) := pr1 (pr2 (pr2 (pr2 msl))). Definition smonoidal_preserves_rightunitality {sd : section_disp D} {ms : smonoidal_data sd} (msl : smonoidal_laxlaws ms) : section_preserves_rightunitality (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms) := pr2 (pr2 (pr2 (pr2 msl))). Definition smonoidal_lax (sd : section_disp D) : UU := ∑ (ms : smonoidal_data sd), smonoidal_laxlaws ms. Definition smonoidal_sdata {sd : section_disp D} (sm : smonoidal_lax sd) : smonoidal_data sd := pr1 sm. Coercion smonoidal_sdata : smonoidal_lax >-> smonoidal_data. Definition smonoidal_slaxlaws {sd : section_disp D} (sm : smonoidal_lax sd) : smonoidal_laxlaws sm := pr2 sm. Definition sectionfunctor_fmonoidal_laxlaws {sd : section_disp D} {ms : smonoidal_data sd} (ml : smonoidal_laxlaws ms) : fmonoidal_laxlaws (sectionfunctor_fmonoidal_data (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms)) := (sectionfunctor_preserves_tensor_nat_left (smonoidal_preserves_tensornatleft ml),, sectionfunctor_preserves_tensor_nat_right (smonoidal_preserves_tensornatright ml),, sectionfunctor_preserves_associativity (smonoidal_preserves_associativity ml),, sectionfunctor_preserves_leftunitality (smonoidal_preserves_leftunitality ml),, sectionfunctor_preserves_rightunitality (smonoidal_preserves_rightunitality ml)). Definition sectionfunctor_fmonoidal_lax {sd : section_disp D} (ms : smonoidal_lax sd) : fmonoidal_lax M TM (section_functor sd) := (sectionfunctor_fmonoidal_data (smonoidal_preserves_tensor ms) (smonoidal_preserves_unit ms) ,, sectionfunctor_fmonoidal_laxlaws (smonoidal_slaxlaws ms)). (* We now define a strong monoidal section and show that each such section induces a strong monoidal functor *) Definition smonoidal_strongtensor {sd : section_disp D} (spt : section_preserves_tensor_data sd) : UU := ∏ (x y : C), is_z_iso_disp (identity_z_iso (x⊗_{M} y)) (spt x y). Definition smonoidal_strongunit {sd : section_disp D} (spu : section_preserves_unit sd) : UU := is_z_iso_disp (identity_z_iso (I_{M})) spu. Definition smonoidal_stronglaws {sd : section_disp D} (ms : smonoidal_data sd) : UU := smonoidal_strongtensor (smonoidal_preserves_tensor ms) × smonoidal_strongunit (smonoidal_preserves_unit ms). Definition smonoidal (sd : section_disp D) : UU := ∑ (ms : smonoidal_lax sd), smonoidal_stronglaws ms. Definition smonoidal_smonoidallax {sd : section_disp D} (sm : smonoidal sd) : smonoidal_lax sd := pr1 sm. Coercion smonoidal_smonoidallax : smonoidal >-> smonoidal_lax. Definition smonoidal_smonoidalstronglaws {sd : section_disp D} (sm : smonoidal sd) : smonoidal_stronglaws sm := pr2 sm. Definition smonoidal_smonoidalstrongtensor {sd : section_disp D} (sm : smonoidal sd) : smonoidal_strongtensor (smonoidal_preserves_tensor sm) := pr1 (smonoidal_smonoidalstronglaws sm). Definition smonoidal_smonoidalstrongunit {sd : section_disp D} (sm : smonoidal sd) : smonoidal_strongunit (smonoidal_preserves_unit sm) := pr2 (smonoidal_smonoidalstronglaws sm). Definition sectionfunctor_preservestensorstrongly {sd : section_disp D} {ms : smonoidal sd} (pfstrong : smonoidal_strongtensor (smonoidal_preserves_tensor ms)) : preserves_tensor_strongly (sectionfunctor_preserves_tensordata (smonoidal_preserves_tensor ms)). Proof. intros x y. use tpair. - use tpair. + apply identity. + exact (pr1 (pfstrong x y)). - use tpair. + use total2_paths_b. * apply id_left. * apply (pr2 (pr2 (pfstrong x y))). + use total2_paths_b. * apply id_left. * apply (pr1 (pr2 (pfstrong x y))). Defined. Definition sectionfunctor_preservesunitstrongly {sd : section_disp D} {ms : smonoidal sd} (pfstrong : smonoidal_strongunit (smonoidal_preserves_unit ms)) : preserves_unit_strongly (sectionfunctor_preserves_unit (smonoidal_preserves_unit ms)). Proof. use tpair. - use tpair. + apply identity. + exact (pr1 pfstrong). - use tpair. + use total2_paths_b. * apply id_left. * apply (pr22 pfstrong). + use total2_paths_b. * apply id_left. * apply (pr1 (pr2 pfstrong)). Defined. Definition sectionfunctor_fmonoidal {sd : section_disp D} (ms : smonoidal sd) : fmonoidal M TM (section_functor sd) := (sectionfunctor_fmonoidal_lax ms ,, sectionfunctor_preservestensorstrongly (smonoidal_smonoidalstrongtensor ms) ,, sectionfunctor_preservesunitstrongly (smonoidal_smonoidalstrongunit ms)). End MonoidalSections. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/Symmetric.v000066400000000000000000000715711451125700300254620ustar00rootroot00000000000000(********************************************************************************* Displayed symmetric monoidal categories In this file, we define the notion of a symmetric displayed monoidal category and show how the total monoidal category is symmetric. Table of contents: 1. DisplayedBraided: - Definition of displayed braiding [disp_braiding] - Construction of braiding on the total category [total_braiding] 2. DisplayedSymmetric: - Definition of displayed symmetric [disp_symmetric] - Construction of symmetry on the total category [total_symmetric] - Proof of redundancy in the axioms of the braiding when considering a symmetric braiding. The redundant set of axioms is given in [disp_symm_braiding_laws]. The proof that we get a braiding [make_disp_symmetric]. 3. Projection: - Proof that the forgetful functor, from the total to the base category, is symmetric [projection_is_symmetric] 4. LocallyPropositional: - A make braiding constructor for locally propositional displayed categories; i.e., only the braiding and (inverse) has to be provided [make_disp_laws_braiding_locally_propositional]. - A make symmetric constructor for locally propositional displayed categories [make_disp_symmetric_locally_propositional] 5. InvertibleMorphismsBraiding - A make braiding constructor for locally invertible displayed categories [make_disp_braiding_locally_groupoidal] 6. InvertibleMorphismsSymmetric - A make symmetric constructor for locally invertible displayed categories [make_disp_symmetric_locally_groupoidal] *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TransportLemmas. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Local Lemma specialized_transport_lemma {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal D M} {x y z1 z2 : C} {f : C⟦x,y ⊗_{M} z1⟧} {g : C⟦z1, z2⟧} {h : C⟦x, y ⊗_{M} z2⟧} {xx : D x} {yy : D y} {zz1 : D z1} {zz2 : D z2} (ff : xx -->[f] (yy ⊗⊗_{DM} zz1)) (gg : zz1 -->[g] zz2) (hh : xx -->[h] (yy ⊗⊗_{DM} zz2)) (p : h = f · identity y ⊗^{ M} g) : ff ;; (id_disp yy ⊗⊗^{DM} gg) = transportf _ p hh → ff ;; yy ⊗⊗^{DM}_{l} gg = transportf _ (p @ maponpaths (λ i, f · i) (when_bifunctor_becomes_leftwhiskering M y g)) hh. Proof. intro q. rewrite <- transport_f_f. etrans. 2: { apply maponpaths. exact q. } clear q. etrans. 2: { apply mor_disp_transportf_prewhisker. } apply maponpaths. unfold dispfunctoronmorphisms1. use transportf_transpose_right. apply pathsinv0, disp_tensor_with_id_on_left. Qed. Local Lemma specialized_transport_lemma' {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal D M} {x y z1 z2 : C} {f : C⟦x,y⟧} {g : C⟦y ⊗_{M} z1, z2⟧} {h : C⟦x ⊗_{M} _, z2⟧} {xx : D x} {yy : D y} {zz1 : D z1} {zz2 : D z2} (ff : xx -->[f] yy) (gg : yy ⊗⊗_{DM} zz1 -->[g] zz2) (hh : xx ⊗⊗_{DM} _ -->[h] zz2) (p : h = f ⊗^{ M} identity z1 · g) : (ff ⊗⊗^{DM} id_disp _) ;; gg = transportf _ p hh → ff ⊗⊗^{DM}_{r} _ ;; gg = transportf _ (p @ maponpaths (λ i, i · g) (when_bifunctor_becomes_rightwhiskering M z1 f)) hh. Proof. intro q. rewrite <- transport_f_f. etrans. 2: { apply maponpaths. exact q. } etrans. 2: { apply mor_disp_transportf_postwhisker. } apply maponpaths_2. unfold dispfunctoronmorphisms1. use transportf_transpose_right. apply pathsinv0, disp_tensor_with_id_on_right. Qed. Section DisplayedBraided. Context {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M). Definition disp_braiding_data (B : braiding_data M) : UU := ∏ (x y : C) (xx : D x) (yy : D y), xx ⊗⊗_{ DM} yy -->[B x y] yy ⊗⊗_{ DM} xx. Definition total_braiding_data {B : braiding_data M} (DB : disp_braiding_data B) : braiding_data (total_monoidal DM) := λ x y, _ ,, DB _ _ (pr2 x) (pr2 y). Section BraidingLaws. Context {B : braiding M} (DB : disp_braiding_data (monoidal_braiding_data B)) (DBinv : disp_braiding_data (monoidal_braiding_data_inv B)). Definition disp_braiding_law_naturality_left : UU := ∏ (x y1 y2 : C) (xx : D x) (yy1 : D y1) (yy2 : D y2) (g : C⟦y1,y2⟧) gg, transportf _ (monoidal_braiding_naturality_left B x y1 y2 g) (DB x y1 xx yy1 ;; gg ⊗⊗^{ DM}_{r} xx) = xx ⊗⊗^{ DM}_{l} gg ;; DB x y2 xx yy2. Definition disp_braiding_law_naturality_right : UU := ∏ (x1 x2 y : C) (xx1 : D x1) (xx2 : D x2) (yy : D y) (f : C⟦x1,x2⟧) ff, transportf _ (monoidal_braiding_naturality_right B x1 x2 y f) (DB x1 y xx1 yy ;; yy ⊗⊗^{ DM}_{l} ff) = ff ⊗⊗^{ DM}_{r} yy ;; DB x2 y xx2 yy. Definition disp_braiding_law_naturality : UU := disp_braiding_law_naturality_left × disp_braiding_law_naturality_right. Definition disp_braiding_iso : UU := ∏ (x y : C) (xx : D x) (yy : D y), is_disp_inverse (monoidal_braiding_inverses B x y) (DB _ _ xx yy) (DBinv _ _ yy xx). Definition disp_braiding_law_hexagon1 : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), transportf _ ((pr122 (monoidal_braiding_laws B)) x y z) (dα^{ DM }_{ xx, yy, zz} ;; DB x (y ⊗_{ M} z) xx (yy ⊗⊗_{ DM} zz) ;; dα^{ DM }_{ yy, zz, xx}) = DB x y xx yy ⊗⊗^{ DM}_{r} zz ;; dα^{ DM }_{ yy, xx, zz} ;; yy ⊗⊗^{ DM}_{l} DB x z xx zz. Definition disp_braiding_law_hexagon2 : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), transportf _ ((pr222 (monoidal_braiding_laws B)) x y z) (dαinv^{DM}_{xx, yy, zz} ;; DB (x ⊗_{M} y) z (xx ⊗⊗_{DM} yy) zz ;; dαinv^{DM}_{zz, xx, yy}) = xx ⊗⊗^{DM}_{l} DB y z yy zz ;; dαinv^{DM}_{xx, zz, yy} ;; DB x z xx zz ⊗⊗^{DM}_{r} yy. Definition disp_braiding_law_hexagon : UU := disp_braiding_law_hexagon1 × disp_braiding_law_hexagon2. Definition disp_braiding_laws : UU := disp_braiding_law_naturality × disp_braiding_iso × disp_braiding_law_hexagon. End BraidingLaws. Definition disp_braiding (B : braiding M) : UU := ∑ (DB : disp_braiding_data (monoidal_braiding_data B)) (DBinv : disp_braiding_data (monoidal_braiding_data_inv B)), disp_braiding_laws DB DBinv. Definition disp_braiding_to_braiding {B : braiding M} (DB : disp_braiding B) : disp_braiding_data (monoidal_braiding_data B) := pr1 DB. Definition disp_braiding_to_braiding_inv {B : braiding M} (DB : disp_braiding B) : disp_braiding_data (monoidal_braiding_data_inv B) := pr12 DB. Definition disp_braiding_to_braiding_laws {B : braiding M} (DB : disp_braiding B) : disp_braiding_laws (disp_braiding_to_braiding DB) (disp_braiding_to_braiding_inv DB) := pr22 DB. Definition disp_braiding_to_naturality {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_naturality (disp_braiding_to_braiding DB) := pr1 (disp_braiding_to_braiding_laws DB). Definition disp_braiding_to_naturality_left {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_naturality_left (disp_braiding_to_braiding DB) := pr1 (disp_braiding_to_naturality DB). Definition disp_braiding_to_naturality_right {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_naturality_right (disp_braiding_to_braiding DB) := pr2 (disp_braiding_to_naturality DB). Definition disp_braiding_to_inverses {B : braiding M} (DB : disp_braiding B) : disp_braiding_iso (disp_braiding_to_braiding DB) (disp_braiding_to_braiding_inv DB) := pr12 (disp_braiding_to_braiding_laws DB). Definition disp_braiding_to_hexagon {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_hexagon (disp_braiding_to_braiding DB) := pr22 (disp_braiding_to_braiding_laws DB). Definition disp_braiding_to_hexagon1 {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_hexagon1 (disp_braiding_to_braiding DB) := pr1 (disp_braiding_to_hexagon DB). Definition disp_braiding_to_hexagon2 {B : braiding M} (DB : disp_braiding B) : disp_braiding_law_hexagon2 (disp_braiding_to_braiding DB) := pr2 (disp_braiding_to_hexagon DB). Lemma total_braiding_naturality_left {B : braiding M} (DB : disp_braiding B) : braiding_law_naturality_left (total_braiding_data (disp_braiding_to_braiding DB)). Proof. intro ; intros. use total2_paths_f. - apply monoidal_braiding_naturality_left. - apply disp_braiding_to_naturality_left. Qed. Lemma total_braiding_naturality_right {B : braiding M} (DB : disp_braiding B) : braiding_law_naturality_right (total_braiding_data (disp_braiding_to_braiding DB)). Proof. intro ; intros. use total2_paths_f. - apply monoidal_braiding_naturality_right. - apply disp_braiding_to_naturality_right. Qed. Lemma total_braiding_naturality {B : braiding M} (DB : disp_braiding B) : braiding_law_naturality (total_braiding_data (disp_braiding_to_braiding DB)). Proof. exists (total_braiding_naturality_left DB). exact (total_braiding_naturality_right DB). Qed. Lemma total_braiding_iso {B : braiding M} (DB : disp_braiding B) : braiding_iso (total_braiding_data (disp_braiding_to_braiding DB)) (total_braiding_data (disp_braiding_to_braiding_inv DB)). Proof. intros [x xx] [y yy]. set (i := is_z_iso_total (total_braiding_data (disp_braiding_to_braiding DB) (x,, xx) (y,, yy)) (_,, monoidal_braiding_inverses B x y : is_z_isomorphism (pr1 B x y))). exact (pr2 (i (_ ,, disp_braiding_to_inverses DB _ _ xx yy))). Qed. Lemma total_braiding_hexagon1 {B : braiding M} (DB : disp_braiding B) : braiding_law_hexagon1 (total_braiding_data (disp_braiding_to_braiding DB)). Proof. intro ; intros. use total2_paths_f. - apply (pr122 (monoidal_braiding_laws B)). - apply disp_braiding_to_hexagon1. Qed. Lemma total_braiding_hexagon2 {B : braiding M} (DB : disp_braiding B) : braiding_law_hexagon2 (total_braiding_data (disp_braiding_to_braiding DB)). Proof. intro ; intros. use total2_paths_f. - apply (pr222 (monoidal_braiding_laws B)). - cbn. apply disp_braiding_to_hexagon2. Qed. Lemma total_braiding_hexagon {B : braiding M} (DB : disp_braiding B) : braiding_law_hexagon (total_braiding_data (disp_braiding_to_braiding DB)). Proof. exists (total_braiding_hexagon1 DB). exact (total_braiding_hexagon2 DB). Qed. Lemma total_braiding_laws {B : braiding M} (DB : disp_braiding B) : braiding_laws (total_braiding_data (disp_braiding_to_braiding DB)) (total_braiding_data (disp_braiding_to_braiding_inv DB)). Proof. refine (_,,_,,_). - exact (total_braiding_naturality DB). - exact (total_braiding_iso DB). - exact (total_braiding_hexagon DB). Qed. Definition total_braiding {B : braiding M} (DB : disp_braiding B) : braiding (total_monoidal DM). Proof. simple refine (_,,_,,_). - exact (total_braiding_data (disp_braiding_to_braiding DB)). - exact (total_braiding_data (disp_braiding_to_braiding_inv DB)). - exact (total_braiding_laws DB). Defined. End DisplayedBraided. Section DisplayedSymmetric. Context {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M). Definition disp_symmetric_data (B : symmetric M) : UU := disp_braiding_data DM B. Definition disp_symmetric (B : symmetric M) : UU := ∑ DB : disp_symmetric_data B, disp_braiding_laws _ DB DB. Definition make_disp_symmetric_locally_prop (LP : locally_propositional D) {B : symmetric M} (DSD : disp_symmetric_data B) : disp_symmetric B. Proof. exists DSD. split3; try split; try (intro; intros); apply LP. Defined. Definition disp_symmetric_to_braiding {B : symmetric M} (DB : disp_symmetric B) : disp_braiding DM (symmetric_to_braiding B). Proof. exists (pr1 DB). exists (pr1 DB). exact (pr2 DB). Defined. Coercion disp_symmetric_to_braiding : disp_symmetric >-> disp_braiding. Definition total_symmetric {B : symmetric M} (DB : disp_symmetric B) : symmetric (total_monoidal DM). Proof. exists (total_braiding_data _ (pr1 DB)). exact (total_braiding_laws _ DB). Defined. Definition disp_sym_moncat_laws_tensored_inv {B : symmetric M} (c : disp_braiding_data DM B) : UU := ∏ (x y : C) (xx : D x) (yy : D y), transportf _ (pr1 (monoidal_braiding_inverses B x y)) (c x y xx yy ;; c y x yy xx) = id_disp (xx ⊗⊗_{DM} yy). Definition disp_sym_moncat_laws_tensored_nat {B : symmetric M} (c : disp_braiding_data DM B) : UU := ∏ (x1 x2 y1 y2 : C) (f : C⟦x1, x2⟧) (g : C⟦y1, y2⟧) (xx1 : D x1) (xx2 : D x2) (yy1 : D y1) (yy2 : D y2) (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2), transportf _ (tensor_sym_mon_braiding ((C,,M),,B) f g) (ff ⊗⊗^{DM} gg ;; c x2 y2 xx2 yy2) = c x1 y1 xx1 yy1 ;; gg ⊗⊗^{DM} ff. Definition disp_sym_moncat_laws_tensored_hex {B : symmetric M} (c : disp_braiding_data DM B) : UU := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z), transportf _ (sym_mon_hexagon_lassociator ((C,,M),,B) x y z) (disp_monoidal_associator _ _ _ _ xx yy zz ;; c _ _ xx (yy ⊗⊗_{DM} zz) ;; disp_monoidal_associator _ _ _ _ yy zz xx) = c x y xx yy ⊗⊗^{DM} id_disp zz ;; disp_monoidal_associator _ _ _ _ yy xx zz ;; id_disp yy ⊗⊗^{DM} c x z xx zz. Definition disp_symm_braiding_laws {B : symmetric M} (c : disp_braiding_data DM B) : UU := disp_sym_moncat_laws_tensored_inv c × disp_sym_moncat_laws_tensored_nat c × disp_sym_moncat_laws_tensored_hex c. Definition braiding_laws_one_hexagon_to_braiding_laws {B : symmetric M} {c : disp_braiding_data DM B} (p_inv : disp_braiding_iso DM c c) (p_nat : disp_braiding_law_naturality DM c) (p_hex1 : disp_braiding_law_hexagon1 DM c) : disp_braiding_law_hexagon2 DM c. Proof. intro ; intros. set (p := transportb_transpose_right (p_hex1 _ _ _ zz xx yy)). rewrite assoc_disp_var. rewrite transport_f_f. use transportf_transpose_left. use disp_z_iso_inv_on_left. { exact (pr2 (z_iso_inv (z_iso_from_associator_iso M x y z))). } { set (t := disp_monoidal_associatoriso DM _ _ _ xx yy zz). exact (_ ,, (pr2 t,, pr1 t)). } etrans. 2: { apply maponpaths_2. apply pathsinv0inv0. } use disp_z_iso_inv_on_left. { refine (_,,_). apply (pr122 B). } { refine (_ ,, _). apply p_inv. } refine (id_right_disp_var _ @ _). use transportf_transpose_left. use disp_z_iso_inv_on_left. { exact (pr2 (z_iso_inv (z_iso_from_associator_iso M z x y))). } { set (t := disp_monoidal_associatoriso DM _ _ _ zz xx yy). exact (_ ,, (pr2 t,, pr1 t)). } cbn. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply pathsinv0. rewrite assoc_disp. rewrite assoc_disp. unfold transportb. rewrite ! transport_f_f. etrans. { apply maponpaths. apply maponpaths_2. exact p. } clear p. cbn. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite ! assoc_disp_var. rewrite transport_f_f. etrans. { do 4 apply maponpaths. rewrite mor_disp_transportf_prewhisker. apply maponpaths. rewrite assoc_disp. apply maponpaths. apply maponpaths_2. refine (! transportf_transpose_left (disp_bifunctor_leftcomp DM _ _ _ _ _ _ _ _ _ _ _ _) @ _). etrans. { do 2 apply maponpaths. apply p_inv. } apply maponpaths. exact (disp_tensor_with_id_left DM (pr2 (monoidal_braiding_inverses B y z)) xx (zz ⊗⊗_{DM} yy)). } unfold transportb. rewrite ! transport_f_f. rewrite ! mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite ! mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_left_disp. etrans. { apply maponpaths. unfold transportb. rewrite mor_disp_transportf_prewhisker. do 2 apply maponpaths. rewrite assoc_disp. apply maponpaths. apply maponpaths_2. apply disp_monoidal_associatoriso. } unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_prewhisker. rewrite (! transportf_transpose_left (disp_bifunctor_rightcomp DM _ _ _ _ _ _ _ _ _ _ _ _)). etrans. { do 3 apply maponpaths. apply maponpaths. exact (pr1 (p_inv _ _ xx zz)). } do 2 rewrite transport_f_f. etrans. { apply maponpaths. apply disp_tensor_with_id_right. } unfold transportb. rewrite transport_f_f. use transportf_set. apply homset_property. Qed. Lemma make_disp_symm_braiding_nat_left {B : symmetric M} {c : disp_braiding_data DM B} (p_nat : disp_sym_moncat_laws_tensored_nat c) : disp_braiding_law_naturality_left DM c. Proof. intro ; intros. use precomp_disp_id_left_inj. set (q := transportb_transpose_right (p_nat _ _ _ _ _ _ xx xx yy1 yy2 (id_disp xx) gg)). unfold dispfunctoronmorphisms1 in q. set (tq := assoc_disp_var (id_disp xx ⊗⊗^{ DM}_{r} yy1) (xx ⊗⊗^{ DM}_{l} gg) (c x y2 xx yy2)) in q. set (q' := transportb_transpose_right (! tq @ q)). rewrite disp_bifunctor_rightid in q'. unfold transportb in q'. rewrite (mor_disp_transportf_postwhisker _ (id_disp (xx ⊗⊗_{ DM} yy1))) in q'. set (q'' := transportb_transpose_right q'). refine (_ @ ! q''). clear q'' q' tq q. unfold transportb. rewrite ! transport_f_f. etrans. 2: { apply maponpaths. apply pathsinv0, assoc_disp. } unfold transportb. rewrite transport_f_f. rewrite mor_disp_transportf_prewhisker. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_left_disp. unfold transportb. rewrite transport_f_f. rewrite disp_bifunctor_leftid. unfold transportb. rewrite ! mor_disp_transportf_prewhisker. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite id_right_disp. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. use transportf_set. apply homset_property. Qed. Lemma make_disp_symm_braiding_nat_right {B : symmetric M} {c : disp_braiding_data DM B} (p_nat : disp_sym_moncat_laws_tensored_nat c) : disp_braiding_law_naturality_right DM c. Proof. intro ; intros. set (q := ! p_nat _ _ _ _ _ _ xx1 xx2 yy yy ff (id_disp yy)). use transportf_transpose_left. set (qq := specialized_transport_lemma (c x1 y xx1 yy) ff _ _ q). refine (qq @ _). clear qq. clear q. use transportf_transpose_left. unfold transportb. rewrite transport_f_f. rewrite path_comp_inv_inv. etrans. 2: { apply maponpaths_2. apply maponpaths. refine (idpath (maponpaths (λ i, i · pr1 B _ _) (when_bifunctor_becomes_rightwhiskering M y f)) @ _). apply homset_property. } etrans. 2: { apply maponpaths_2. apply (maponpathsinv0 (λ i : C ⟦ x1 ⊗_{ M} y, x2 ⊗_{ M} y ⟧, i · pr1 B x2 y)). } etrans. 2: { apply mor_disp_transportf_postwhisker. } apply maponpaths_2. apply disp_tensor_with_id_on_right. Qed. Lemma make_disp_symm_braiding_nat {B : symmetric M} {c : disp_braiding_data DM B} (p_nat : disp_sym_moncat_laws_tensored_nat c) : disp_braiding_law_naturality DM c. Proof. split. - exact (make_disp_symm_braiding_nat_left p_nat). - exact (make_disp_symm_braiding_nat_right p_nat). Qed. Lemma make_disp_symm_braiding_iso {B : symmetric M} {c : disp_braiding_data DM B} (p_inv : disp_sym_moncat_laws_tensored_inv c) : disp_braiding_iso DM c c. Proof. intro ; intros. split. - apply pathsinv0. etrans. { apply maponpaths. exact (! p_inv y x yy xx). } apply transportb_transpose_left. apply maponpaths_2. apply homset_property. - apply pathsinv0. etrans. { apply maponpaths. exact (! p_inv x y xx yy). } apply transportb_transpose_left. apply maponpaths_2. apply homset_property. Qed. Lemma make_disp_symm_braiding_hex1 {B : symmetric M} {c : disp_braiding_data DM B} (p_hex : disp_sym_moncat_laws_tensored_hex c) : disp_braiding_law_hexagon1 DM c. Proof. unfold disp_braiding_law_hexagon1. intro ; intros. set (q := p_hex x y z xx yy zz). set (qq := specialized_transport_lemma _ _ _ _ (! q)). rewrite assoc_disp_var in qq. set (qq' := transportb_transpose_right qq). set (qq'' := specialized_transport_lemma' _ _ _ _ qq'). rewrite assoc_disp in qq''. set (qq''' := transportb_transpose_right qq''). refine (_ @ ! qq'''). clear qq''' qq'' qq' qq q. use transportf_transpose_left. unfold transportb. rewrite ! transport_f_f. apply pathsinv0. use transportf_set. apply homset_property. Qed. Lemma make_disp_symm_braiding_hex2 {B : symmetric M} {c : disp_braiding_data DM B} (p_inv : disp_sym_moncat_laws_tensored_inv c) (p_nat : disp_sym_moncat_laws_tensored_nat c) (p_hex : disp_sym_moncat_laws_tensored_hex c) : disp_braiding_law_hexagon2 DM c. Proof. use braiding_laws_one_hexagon_to_braiding_laws. - exact (make_disp_symm_braiding_iso p_inv). - exact (make_disp_symm_braiding_nat p_nat). - exact (make_disp_symm_braiding_hex1 p_hex). Qed. Lemma make_disp_symm_braiding_laws {B : symmetric M} {c : disp_braiding_data DM B} (p_inv : disp_sym_moncat_laws_tensored_inv c) (p_nat : disp_sym_moncat_laws_tensored_nat c) (p_hex : disp_sym_moncat_laws_tensored_hex c) : disp_braiding_laws DM c c. Proof. refine (_ ,,_,, (_ ,, _)). - exact (make_disp_symm_braiding_nat p_nat). - exact (make_disp_symm_braiding_iso p_inv). - exact (make_disp_symm_braiding_hex1 p_hex). - exact (make_disp_symm_braiding_hex2 p_inv p_nat p_hex). Qed. Definition make_disp_symmetric {B : symmetric M} {c : disp_braiding_data DM B} (p_inv : disp_sym_moncat_laws_tensored_inv c) (p_nat : disp_sym_moncat_laws_tensored_nat c) (p_hex : disp_sym_moncat_laws_tensored_hex c) : disp_symmetric B. Proof. refine (c ,, _). exact (make_disp_symm_braiding_laws p_inv p_nat p_hex). Defined. End DisplayedSymmetric. Section Projection. Context {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal D M} {B : symmetric M} (DB : disp_symmetric DM B). Definition projection_is_symmetric : is_symmetric_monoidal_functor (total_symmetric DM DB) B (projection_fmonoidal DM). Proof. intro ; intro. exact (id_right _ @ ! id_left _). Qed. End Projection. Section LocallyPropositional. Context {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M). Context (LP : locally_propositional D). Lemma make_disp_laws_braiding_locally_propositional {B : braiding M} (DB : disp_braiding_data DM (monoidal_braiding_data B)) (DBinv : disp_braiding_data DM (monoidal_braiding_data_inv B)) : disp_braiding_laws DM DB DBinv. Proof. refine (_ ,, _ ,, _). - split ; intro ; intros ; apply LP. - split ; apply LP. - split ; intro ; intros ; apply LP. Qed. Definition make_disp_braiding_locally_propositional {B : braiding M} (DB : disp_braiding_data DM (monoidal_braiding_data B)) (DBinv : disp_braiding_data DM (monoidal_braiding_data_inv B)) : disp_braiding DM B. Proof. refine (_,,_,,_). exact (make_disp_laws_braiding_locally_propositional DB DBinv). Defined. Definition make_disp_laws_symmetric_locally_propositional {B : symmetric M} (DB : disp_braiding_data DM (monoidal_braiding_data B)) : disp_braiding_laws DM DB DB. Proof. refine (_ ,, _ ,, _). - split ; intro ; intros ; apply LP. - split ; apply LP. - split ; intro ; intros ; apply LP. Qed. Definition make_disp_symmetric_locally_propositional {B : symmetric M} (DB : disp_braiding_data DM (monoidal_braiding_data B)) : disp_symmetric DM B. Proof. refine (_,,_). exact (make_disp_laws_symmetric_locally_propositional DB). Defined. End LocallyPropositional. Section InvertibleMorphismsBraiding. Context {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) (B : braiding M). Context (LG : groupoidal_disp_cat D). Context (DB : disp_braiding_data DM (monoidal_braiding_data B)). Definition DB_obj_inv {x y : C} (xx : D x) (yy : D y) : is_z_iso_disp (make_z_iso' _ (monoidal_braiding_data_inv B x y,, monoidal_braiding_inverses B y x)) (DB y x yy xx). Proof. set (l := LG _ _ (monoidal_braiding_data B y x) (_ ,, monoidal_braiding_inverses B y x)). exact (l _ _ (DB _ _ yy xx)). Defined. Definition DBinv : disp_braiding_data DM (monoidal_braiding_data_inv B). Proof. intros x y xx yy. exact (pr1 (DB_obj_inv xx yy)). Defined. Definition make_disp_laws_braiding_locally_groupoidal (p_nat : disp_braiding_law_naturality DM DB) (p_hex : disp_braiding_law_hexagon DM DB) : disp_braiding_laws DM DB DBinv. Proof. refine (_ ,, _ ,, _). - exact p_nat. - split ; apply DB_obj_inv. - exact p_hex. Qed. Definition make_disp_braiding_locally_groupoidal (p_nat : disp_braiding_law_naturality DM DB) (p_hex : disp_braiding_law_hexagon DM DB) : disp_braiding DM B. Proof. refine (_ ,, _ ,, _). exact (make_disp_laws_braiding_locally_groupoidal p_nat p_hex). Qed. End InvertibleMorphismsBraiding. Section InvertibleMorphismsSymmetric. Context {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) (B : symmetric M). Context (LG : groupoidal_disp_cat D). Context (DB : disp_braiding_data DM (monoidal_braiding_data B)). Definition make_disp_laws_symmetric_locally_groupoidal (p_nat : disp_sym_moncat_laws_tensored_nat DM DB) (p_hex : disp_sym_moncat_laws_tensored_hex DM DB) (p_sym : ∏ x y xx yy, DB x y xx yy ;; DB y x yy xx = transportb _ (pr2 (monoidal_braiding_inverses B y x)) (id_disp (xx ⊗⊗_{ DM} yy))) : disp_sym_moncat_laws_tensored_inv DM DB. Proof. intro ; intros. use transportf_transpose_left. refine (_ @ pr12 (DB_obj_inv _ B LG DB xx yy) @ _). - refine (p_sym _ _ xx yy @ _). exact (! pr12 (DB_obj_inv _ B LG DB xx yy)). - apply maponpaths_2. apply homset_property. Qed. Definition make_disp_symmetric_locally_groupoidal (p_nat : disp_sym_moncat_laws_tensored_nat DM DB) (p_hex : disp_sym_moncat_laws_tensored_hex DM DB) (p_sym : ∏ x y xx yy, DB x y xx yy ;; DB y x yy xx = transportb _ (pr2 (monoidal_braiding_inverses B y x)) (id_disp (xx ⊗⊗_{ DM} yy))) : disp_symmetric DM B. Proof. use make_disp_symmetric. - exact DB. - exact (make_disp_laws_symmetric_locally_groupoidal p_nat p_hex p_sym). - exact p_nat. - exact p_hex. Defined. End InvertibleMorphismsSymmetric. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/SymmetricMonoidalBuilder.v000066400000000000000000000243651451125700300304530ustar00rootroot00000000000000(* In this file, we provide a builder to construct a symmetric displayed monoidal category on a locally propositional displayed category [make_symmetric_monoidal_disp_cat_locally_prop]. This builder takes into account the symmetric aspects found in a monoidal category, e.g., the (displayed) right unitor can be constructed from the left unitor (provided a braiding); the assumptions on the right unitor, follow from those on the left unitor. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section Construct_SymmetricMonoidal_On_LocallyProp_DisplayedCategories. Context (V : sym_monoidal_cat) (D : disp_cat V). Context (disp_tensor_ob : ∏ x y : V, D x → D y → D (x ⊗ y)). Let T {x y : V} (xx : D x) (yy : D y) : D (x ⊗ y) := disp_tensor_ob _ _ xx yy. Context (disp_lwhisker : ∏ (x y1 y2 : V) (g : V⟦ y1, y2 ⟧) (xx : D x) (yy1 : D y1) (yy2 : D y2), yy1 -->[ g] yy2 → T xx yy1 -->[ x ⊗^{V}_{l} g] T xx yy2). Let Tl {x y1 y2 : V} {g : V⟦ y1, y2 ⟧} (xx : D x) {yy1 : D y1} {yy2 : D y2} (gg : yy1 -->[ g] yy2) : T xx yy1 -->[ x ⊗^{V}_{l} g] T xx yy2 := disp_lwhisker _ _ _ _ _ _ _ gg. Context (disp_braiding : ∏ (x y : V) (xx : D x) (yy : D y), T xx yy -->[sym_mon_braiding V x y] T yy xx). Let B {x y : V} (xx : D x) (yy : D y) : T xx yy -->[sym_mon_braiding V x y] T yy xx := disp_braiding x y xx yy. Let Tr {x1 x2 y : V} {f : V⟦ x1, x2 ⟧} {xx1 : D x1} {xx2 : D x2} (yy : D y) (ff : xx1 -->[ f] xx2) : T xx1 yy -->[ f ⊗^{V}_{r} y] T xx2 yy. Proof. set (t := B xx1 yy ;; Tl _ ff ;; B yy xx2). use (transportf _ _ t). etrans. { apply maponpaths_2. apply (monoidal_braiding_naturality_right V). } refine (assoc' _ _ _ @ _). etrans. { apply maponpaths. exact (pr1 ((pr122 (pr2 V)) x2 y)). } apply id_right. Defined. Context (disp_lwhisker_preserves_id : ∏ (x y : V) (xx : D x) (yy : D y), Tl xx (id_disp yy) = transportb _ (bifunctor_leftid V x y) (id_disp (T xx yy))). Context (B_inv : ∏ (x y : V) (xx : D x) (yy : D y), B xx yy ;; B yy xx = transportb _ (sym_mon_braiding_inv V x y) (id_disp _)). Local Lemma disp_rwhisker_preserves_id {x y : V} (xx : D x) (yy : D y) : Tr yy (id_disp xx) = transportb _ (bifunctor_rightid V y x) (id_disp (T xx yy)). Proof. unfold Tr. cbn. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply disp_lwhisker_preserves_id. } unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite B_inv. unfold transportb. rewrite transport_f_f. apply maponpaths_2. apply homset_property. Qed. Context (disp_lwhisker_preserves_comp : ∏ (x y1 y2 y3 : V) (g1 : V⟦ y1, y2 ⟧) (g2 : V⟦ y2, y3 ⟧) (xx : D x) (yy1 : D y1) (yy2 : D y2) (yy3 : D y3) (gg1 : yy1 -->[ g1] yy2) (gg2 : yy2 -->[ g2] yy3), Tl xx (gg1 ;; gg2) = transportb _ (bifunctor_leftcomp V x y1 y2 y3 g1 g2) (Tl _ gg1 ;; Tl _ gg2)). Local Lemma disp_rwhisker_preserves_comp {x1 x2 x3 y : V} {f1 : V⟦ x1, x2 ⟧} {f2 : V⟦ x2, x3 ⟧} {xx1 : D x1} {xx2 : D x2} {xx3 : D x3} (yy : D y) (ff1 : xx1 -->[ f1] xx2) (ff2 : xx2 -->[ f2] xx3) : Tr yy (ff1 ;; ff2) = transportb _ (bifunctor_rightcomp V y x1 x2 x3 f1 f2) (Tr yy ff1 ;; Tr yy ff2). Proof. unfold Tr. cbn. rewrite (disp_lwhisker_preserves_comp _ _ _ _ _ _ _ _ _ _ ff1 ff2). unfold transportb. rewrite ! mor_disp_transportf_prewhisker. unfold transportb. rewrite ! mor_disp_transportf_postwhisker. rewrite ! transport_f_f. etrans. 2: { apply maponpaths. rewrite assoc_disp_var. do 2 apply maponpaths. rewrite assoc_disp. apply maponpaths. apply maponpaths_2. rewrite assoc_disp. apply maponpaths. apply maponpaths_2. apply pathsinv0, B_inv. } unfold transportb. rewrite ! transport_f_f. rewrite ! mor_disp_transportf_prewhisker. unfold transportb. rewrite ! transport_f_f. rewrite ! mor_disp_transportf_postwhisker. rewrite ! mor_disp_transportf_prewhisker. rewrite ! transport_f_f. rewrite id_left_disp. unfold transportb. rewrite ! mor_disp_transportf_postwhisker. rewrite ! mor_disp_transportf_prewhisker. rewrite ! transport_f_f. use transportf_transpose_right. unfold transportb. rewrite transport_f_f. rewrite ! assoc_disp. unfold transportb. rewrite mor_disp_transportf_postwhisker. use transportf_transpose_right. unfold transportb. rewrite ! transport_f_f. use transportf_set. apply homset_property. Qed. (* Lemma B_naturality : B x1 y1 xx1 yy1 ;; Tl yy1 ff = Tl _ ff *) Context (disp_tensor_equalwhiskers : ∏ (x1 x2 y1 y2 : V) (f : V⟦ x1, x2 ⟧) (g : V⟦ y1, y2 ⟧) (xx1 : D x1) (xx2 : D x2) (yy1 : D y1) (yy2 : D y2) (ff : xx1 -->[ f] xx2) (gg : yy1 -->[ g] yy2), Tr yy1 ff ;; Tl xx2 gg = transportb _ (bifunctor_equalwhiskers V x1 x2 y1 y2 f g) (Tl xx1 gg ;; Tr yy2 ff)). Definition make_symmetric_monoidal_disp_cat_tensor : disp_tensor D V. Proof. simple refine ((_,,(_,,_)),,(_,,_,,_,,_,,_)). - exact disp_tensor_ob. - exact disp_lwhisker. - exact (λ _ _ _ _ _ _ yy gg, Tr yy gg). - exact disp_lwhisker_preserves_id. - intro ; intros ; apply disp_rwhisker_preserves_id. - exact disp_lwhisker_preserves_comp. - intro ; intros ; apply disp_rwhisker_preserves_comp. - intro ; intros ; apply disp_tensor_equalwhiskers. Defined. Context (II : D (monoidal_unit V)) (lu_lu : disp_leftunitor_data make_symmetric_monoidal_disp_cat_tensor II) (lu_lu_inv : disp_leftunitorinv_data make_symmetric_monoidal_disp_cat_tensor II). Lemma make_symmetric_monoidal_disp_cat_rightunitor {x : V} (xx : D x) : T xx II -->[mon_runitor x] xx. Proof. use (transportf _ _ (B xx II ;; lu_lu _ xx)). apply sym_mon_braiding_lunitor. Defined. Definition make_symmetric_monoidal_disp_cat_rightunitor_inv {x : V} (xx : D x) : xx -->[mon_rinvunitor x] T xx II. Proof. use (transportf _ _ (lu_lu_inv _ xx ;; B _ _)). apply sym_mon_braiding_linvunitor. Defined. Context (asas : disp_associator_data make_symmetric_monoidal_disp_cat_tensor). Context (asasinv : disp_associatorinv_data make_symmetric_monoidal_disp_cat_tensor). Definition make_symmetric_monoidal_disp_cat_monoidal_data : disp_monoidal_data D V. Proof. exists make_symmetric_monoidal_disp_cat_tensor. exists II. exists lu_lu. exists lu_lu_inv. exists (λ _ xx, make_symmetric_monoidal_disp_cat_rightunitor xx). exists (λ _ xx, make_symmetric_monoidal_disp_cat_rightunitor_inv xx). exists asas. exact asasinv. Defined. Definition make_symmetric_monoidal_disp_cat_monoidal_locally_prop (LP : locally_propositional D) : disp_monoidal D V. Proof. exists make_symmetric_monoidal_disp_cat_monoidal_data. repeat split ; try (intro ; intros) ; apply LP. Defined. Definition make_symmetric_monoidal_disp_cat_locally_prop' (LP : locally_propositional D) : ∑ DM : disp_monoidal D V, disp_symmetric DM V. Proof. exists (make_symmetric_monoidal_disp_cat_monoidal_locally_prop LP). use make_disp_symmetric_locally_propositional. { exact LP. } exact disp_braiding. Defined. End Construct_SymmetricMonoidal_On_LocallyProp_DisplayedCategories. Definition make_symmetric_monoidal_disp_cat_locally_prop (V : sym_monoidal_cat) (D : disp_cat V) (LP : locally_propositional D) (T : ∏ x y : V, D x → D y → D (x ⊗ y)) (Tmor : ∏ (x y1 y2 : V) (g : V⟦ y1, y2 ⟧) (xx : D x) (yy1 : D y1) (yy2 : D y2), yy1 -->[g] yy2 → T x y1 xx yy1 -->[ x ⊗^{V}_{l} g] T x y2 xx yy2) (B : ∏ (x y : V) (xx : D x) (yy : D y), T x y xx yy -->[sym_mon_braiding V x y] T y x yy xx) (II : D (monoidal_unit V)) (lu_lu : ∏ (x : V) (xx : D x), T (monoidal_unit V) x II xx -->[mon_lunitor x] xx) (lu_lu_inv : ∏ (x : V) (xx : D x), xx -->[mon_linvunitor x] T (monoidal_unit V) x II xx) (assass : ∏ (x y z : V) (xx : D x) (yy : D y) (zz : D z), (T _ _ (T _ _ xx yy) zz) -->[mon_lassociator x y z] T _ _ xx (T _ _ yy zz)) (assassinv : ∏ (x y z : V) (xx : D x) (yy : D y) (zz : D z), T _ _ xx (T _ _ yy zz) -->[mon_rassociator x y z] (T _ _ (T _ _ xx yy) zz)) : ∑ DM : disp_monoidal D V, disp_symmetric DM V. Proof. use make_symmetric_monoidal_disp_cat_locally_prop'. - exact T. - exact Tmor. - exact B. - intro ; intros ; apply LP. - intro ; intros ; apply LP. - intro ; intros ; apply LP. - intro ; intros ; apply LP. - exact II. - exact lu_lu. - exact lu_lu_inv. - exact assass. - exact assassinv. - exact LP. Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/TotalMonoidal.v000066400000000000000000000516501451125700300262500ustar00rootroot00000000000000(********************************************************************************* The total category of a displayed monoidal category In this file, we show that the total category of a displayed monoidal category is again a monoidal category. Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/TotalDisplayedMonoidalWhiskered.v *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Local Open Scope mor_disp_scope. Section MonoidalTotalCategory. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Local Notation "T( D )" := (total_category D). (** DATA **) Definition total_tensor_data {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor_data T(D) T(D) T(D). Proof. use make_bifunctor_data. - intros x y. exact (pr1 x ⊗_{M} pr1 y ,, pr2 x ⊗⊗_{DT} pr2 y). - intros x y1 y2 g. exact (pr1 x ⊗^{M}_{l} pr1 g ,, pr2 x ⊗⊗^{DT}_{l} pr2 g). - intros y x1 x2 f. exact (pr1 f ⊗^{M}_{r} pr1 y ,, pr2 f ⊗⊗^{DT}_{r} pr2 y). Defined. Lemma total_leftidax {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor_leftidax (total_tensor_data DT). Proof. intros x y. use total2_paths_b. - exact (bifunctor_leftid (monoidal_tensor M) (pr1 x) (pr1 y)). - exact (disp_bifunctor_leftid DT (pr1 x) (pr1 y) (pr2 x) (pr2 y)). Qed. Lemma total_rightidax {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor_rightidax (total_tensor_data DT). Proof. intros y x. use total2_paths_b. - exact (bifunctor_rightid (monoidal_tensor M) (pr1 y) (pr1 x)). - exact (disp_bifunctor_rightid DT (pr1 x) (pr1 y) (pr2 x) (pr2 y)). Qed. Lemma total_leftcompax {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor_leftcompax (total_tensor_data DT). Proof. intros x y1 y2 y3 g1 g2. use total2_paths_b. - exact (bifunctor_leftcomp (monoidal_tensor M) (pr1 x) (pr1 y1) (pr1 y2) (pr1 y3) (pr1 g1) (pr1 g2)). - exact (disp_bifunctor_leftcomp DT (pr1 x) (pr1 y1) (pr1 y2) (pr1 y3) (pr1 g1) (pr1 g2) (pr2 x) (pr2 y1) (pr2 y2) (pr2 y3) (pr2 g1) (pr2 g2)). Qed. Lemma total_rightcompax {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor_rightcompax (total_tensor_data DT). Proof. intros y x1 x2 x3 f1 f2. use total2_paths_b. - exact (bifunctor_rightcomp (monoidal_tensor M) (pr1 y) (pr1 x1) (pr1 x2) (pr1 x3) (pr1 f1) (pr1 f2)). - exact (disp_bifunctor_rightcomp DT (pr1 x1) (pr1 x2) (pr1 x3) (pr1 y) (pr1 f1) (pr1 f2) (pr2 x1) (pr2 x2) (pr2 x3) (pr2 y) (pr2 f1) (pr2 f2)). Qed. Lemma total_functoronmorphisms_are_equal {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : functoronmorphisms_are_equal (total_tensor_data DT). Proof. intros x1 x2 y1 y2 f g. use total2_paths_b. - exact (bifunctor_equalwhiskers (monoidal_tensor M) (pr1 x1) (pr1 x2) (pr1 y1) (pr1 y2) (pr1 f) (pr1 g)). - exact (disp_bifunctor_equalwhiskers DT (pr1 x1) (pr1 x2) (pr1 y1) (pr1 y2) (pr1 f) (pr1 g) (pr2 x1) (pr2 x2) (pr2 y1) (pr2 y2) (pr2 f) (pr2 g)). Qed. Definition total_tensor {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) : bifunctor T(D) T(D) T(D) := (total_tensor_data DT ,, total_leftidax DT ,, total_rightidax DT ,, total_leftcompax DT ,, total_rightcompax DT ,, total_functoronmorphisms_are_equal DT). Local Notation Tt := total_tensor_data. Definition total_unit {C : category} {D : disp_cat C} {M : monoidal C} (DT : disp_tensor D M) (i : D I_{M}) : T(D) := (I_{M},,i). Notation Tu := total_unit. Definition total_leftunitordata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dlu : disp_leftunitor_data DT i) : leftunitor_data (Tt DT) (Tu DT i). Proof. intro x. use tpair. - exact (lu_{M} (pr1 x)). - exact (dlu (pr1 x) (pr2 x)). Defined. Definition total_leftunitorinvdata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dluinv : disp_leftunitorinv_data DT i) : leftunitorinv_data (Tt DT) (Tu DT i). Proof. intro x. use tpair. - exact (luinv_{M} (pr1 x)). - exact (dluinv (pr1 x) (pr2 x)). Defined. Definition total_rightunitordata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (dru : disp_rightunitor_data DT i) : rightunitor_data (Tt DT) (Tu DT i). Proof. intro x. use tpair. - exact (ru_{M} (pr1 x)). - exact (dru (pr1 x) (pr2 x)). Defined. Definition total_rightunitorinvdata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} {i : D I_{M}} (druinv : disp_rightunitorinv_data DT i) : rightunitorinv_data (Tt DT) (Tu DT i). Proof. intro x. use tpair. - exact (ruinv_{M} (pr1 x)). - exact (druinv (pr1 x) (pr2 x)). Defined. Definition total_associatordata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dα : disp_associator_data DT) : associator_data (Tt DT). Proof. intros x y z. use tpair. - exact (α_{M} (pr1 x) (pr1 y) (pr1 z)). - exact (dα (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)). Defined. Notation Tα := total_associatordata. Definition total_associatorinvdata {C : category} {D : disp_cat C} {M : monoidal C} {DT : disp_tensor D M} (dαinv : disp_associatorinv_data DT) : associatorinv_data (Tt DT). Proof. intros x y z. use tpair. - exact (αinv_{M} (pr1 x) (pr1 y) (pr1 z)). - exact (dαinv (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z)). Defined. Definition total_monoidaldata {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal_data D M) : monoidal_data T(D). Proof. use make_monoidal_data. - exact (total_tensor_data DM). - exact (total_unit DM dI_{DM}). - exact (total_leftunitordata dlu^{DM}). - exact (total_leftunitorinvdata dluinv^{DM}). - exact (total_rightunitordata dru^{DM}). - exact (total_rightunitorinvdata druinv^{DM}). - exact (total_associatordata dα^{DM}). - exact (total_associatorinvdata dαinv^{DM}). Defined. (** PROPERTIES **) Lemma total_leftunitor_iso_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dluiso : disp_leftunitor_iso dlu^{DM} dluinv^{DM}) : leftunitor_iso_law (total_leftunitordata dlu^{DM}) (total_leftunitorinvdata dluinv^{DM}). Proof. intros x. split. - use total2_paths_b. + exact (pr1 (pr2 (monoidal_leftunitorlaw M) (pr1 x))). + exact (pr2 (dluiso (pr1 x) (pr2 x))). - use total2_paths_b. * exact (pr2 (pr2 (monoidal_leftunitorlaw M) (pr1 x))). * exact (pr1 (dluiso (pr1 x) (pr2 x))). Qed. Lemma total_leftunitor_nat {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dluiso : disp_leftunitor_nat dlu^{DM}) : leftunitor_nat (total_leftunitordata dlu^{DM}). Proof. intros x y f. use total2_paths_b. - exact ((pr1 (monoidal_leftunitorlaw M)) (pr1 x) (pr1 y) (pr1 f)). - exact (dluiso (pr1 x) (pr1 y) (pr1 f) (pr2 x) (pr2 y) (pr2 f)). Defined. Lemma total_leftunitor_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dluiso : disp_leftunitor_law dlu^{DM} dluinv^{DM}) : leftunitor_law (total_leftunitordata dlu^{DM}) (total_leftunitorinvdata dluinv^{DM}). Proof. exact (total_leftunitor_nat (pr1 dluiso),,total_leftunitor_iso_law (pr2 dluiso)). Defined. Lemma total_rightunitor_iso_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (druiso : disp_rightunitor_iso dru^{DM} druinv^{DM}) : rightunitor_iso_law (total_rightunitordata dru^{DM}) (total_rightunitorinvdata druinv^{DM}). Proof. intros x. split. - use total2_paths_b. + exact (pr1 (pr2 (monoidal_rightunitorlaw M) (pr1 x))). + exact (pr2 (druiso (pr1 x) (pr2 x))). - use total2_paths_b. * exact (pr2 (pr2 (monoidal_rightunitorlaw M) (pr1 x))). * exact (pr1 (druiso (pr1 x) (pr2 x))). Qed. Lemma total_rightunitor_nat {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (druiso : disp_rightunitor_nat dru^{DM}) : rightunitor_nat (total_rightunitordata dru^{DM}). Proof. intros x y f. use total2_paths_b. - exact ((pr1 (monoidal_rightunitorlaw M)) (pr1 x) (pr1 y) (pr1 f)). - exact (druiso (pr1 x) (pr1 y) (pr1 f) (pr2 x) (pr2 y) (pr2 f)). Defined. Lemma total_rightunitor_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (druiso : disp_rightunitor_law dru^{DM} druinv^{DM}) : rightunitor_law (total_rightunitordata dru^{DM}) (total_rightunitorinvdata druinv^{DM}). Proof. exact (total_rightunitor_nat (pr1 druiso),,total_rightunitor_iso_law (pr2 druiso)). Defined. Lemma total_associator_nat_leftwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dαlnat : disp_associator_nat_leftwhisker dα^{DM}) : associator_nat_leftwhisker (total_associatordata dα^{DM}). Proof. intros x y z z' h. use total2_paths_b. - exact ((associatorlaw_natleft (monoidal_associatorlaw M)) (pr1 x) (pr1 y) (pr1 z) (pr1 z') (pr1 h)). - exact (dαlnat (pr1 x) (pr1 y) (pr1 z) (pr1 z') (pr1 h) (pr2 x) (pr2 y) (pr2 z) (pr2 z') (pr2 h)). Qed. Lemma total_associator_nat_rightwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dαrnat : disp_associator_nat_rightwhisker dα^{DM}) : associator_nat_rightwhisker (total_associatordata dα^{DM}). Proof. intros x1 x2 y z f. use total2_paths_b. - exact ((associatorlaw_natright (monoidal_associatorlaw M)) (pr1 x1) (pr1 x2) (pr1 y) (pr1 z) (pr1 f)). - exact (dαrnat (pr1 x1) (pr1 x2) (pr1 y) (pr1 z) (pr1 f) (pr2 x1) (pr2 x2) (pr2 y) (pr2 z) (pr2 f)). Qed. Lemma total_associator_nat_leftrightwhisker {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dαlrnat : disp_associator_nat_leftrightwhisker dα^{DM}) : associator_nat_leftrightwhisker (total_associatordata dα^{DM}). Proof. intros x y1 y2 z g. use total2_paths_b. - exact ((associatorlaw_natleftright (monoidal_associatorlaw M)) (pr1 x) (pr1 y1) (pr1 y2) (pr1 z) (pr1 g)). - exact (dαlrnat (pr1 x) (pr1 y1) (pr1 y2) (pr1 z) (pr1 g) (pr2 x) (pr2 y1) (pr2 y2) (pr2 z) (pr2 g)). Qed. Lemma total_associator_iso_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dαiso : disp_associator_iso dα^{DM} dαinv^{DM}) : associator_iso_law (total_associatordata dα^{DM}) (total_associatorinvdata dαinv^{DM}). Proof. intros x y z. - split. + use total2_paths_b. * exact (pr1 (associatorlaw_iso_law (monoidal_associatorlaw M) (pr1 x) (pr1 y) (pr1 z))). * exact (pr2 ((dαiso) (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z))). + use total2_paths_b. * exact (pr2 (associatorlaw_iso_law (monoidal_associatorlaw M) (pr1 x) (pr1 y) (pr1 z))). * exact (pr1 ((dαiso) (pr1 x) (pr1 y) (pr1 z) (pr2 x) (pr2 y) (pr2 z))). Qed. Lemma total_associator_law {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dαiso : disp_associator_law dα^{DM} dαinv^{DM}) : associator_law (total_associatordata dα^{DM}) (total_associatorinvdata dαinv^{DM}). Proof. split with (total_associator_nat_leftwhisker (disp_associatorlaw_natleft dαiso)). split with (total_associator_nat_rightwhisker (disp_associatorlaw_natright dαiso)). split with (total_associator_nat_leftrightwhisker (disp_associatorlaw_natleftright dαiso)). exact (total_associator_iso_law (disp_associatorlaw_iso dαiso)). Qed. Lemma total_triangleidentity {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dti : disp_triangle_identity dlu^{DM} dru^{DM} dα^{DM}) : triangle_identity (total_leftunitordata dlu^{DM}) (total_rightunitordata dru^{DM}) (total_associatordata dα^{DM}). Proof. intros x y. use total2_paths_b. - exact ((monoidal_triangleidentity M) (pr1 x) (pr1 y)). - exact (dti (pr1 x) (pr1 y) (pr2 x) (pr2 y)). Qed. Lemma total_pentagonidentity {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal_data D M} (dpi : disp_pentagon_identity dα^{DM}) : pentagon_identity (total_associatordata dα^{DM}). Proof. intros w x y z. use total2_paths_b. - exact ((monoidal_pentagonidentity M) (pr1 w) (pr1 x) (pr1 y) (pr1 z)). - exact (dpi (pr1 w) (pr1 x) (pr1 y) (pr1 z) (pr2 w) (pr2 x) (pr2 y) (pr2 z)). Qed. Definition total_monoidallaws {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : monoidal_laws (total_monoidaldata DM). Proof. exists (pr2 (total_tensor DM)). exists (total_leftunitor_law (disp_monoidal_leftunitorlaw DM)). exists (total_rightunitor_law (disp_monoidal_rightunitorlaw DM)). exists (total_associator_law (disp_monoidal_associatorlaw DM)). exists (total_triangleidentity (disp_monoidal_triangleidentity DM)). exact (total_pentagonidentity (disp_monoidal_pentagonidentity DM)). Qed. Definition total_monoidal {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : monoidal T(D) := (total_monoidaldata DM,, total_monoidallaws DM). Notation "π^{ D }" := (pr1_category D). Notation "TM( DM )" := (total_monoidal DM). Lemma projection_preserves_unit {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_unit TM(DM) M π^{D}. Proof. apply identity. Defined. Lemma projection_preserves_tensordata {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_tensordata TM(DM) M π^{D}. Proof. intros x y. apply identity. Defined. Definition projection_fmonoidaldata {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : fmonoidal_data TM(DM) M π^{D} := (projection_preserves_tensordata DM,, projection_preserves_unit DM). Lemma projection_preserves_tensornatleft {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_tensor_nat_left (projection_preserves_tensordata DM). Proof. intros x y1 y2 g. rewrite id_left. apply id_right. Qed. Lemma projection_preserves_tensornatright {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_tensor_nat_right (projection_preserves_tensordata DM). Proof. intros x1 x2 y f. rewrite id_left. apply id_right. Qed. Lemma projection_preserves_leftunitality {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_leftunitality (projection_preserves_tensordata DM) (projection_preserves_unit DM). Proof. intro x. rewrite (bifunctor_rightid M). rewrite id_left. apply id_left. Qed. Lemma projection_preserves_rightunitality {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_rightunitality (projection_preserves_tensordata DM) (projection_preserves_unit DM). Proof. intro x. rewrite (bifunctor_leftid M). rewrite id_left. apply id_left. Qed. Lemma projection_preserves_associativity {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_associativity (projection_preserves_tensordata DM). Proof. intros x y z. rewrite (bifunctor_leftid M). rewrite id_right. rewrite id_right. rewrite (bifunctor_rightid M). rewrite id_left. rewrite id_right. apply idpath. Qed. Definition projection_fmonoidal_laxlaws {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : fmonoidal_laxlaws (projection_fmonoidaldata DM) := (projection_preserves_tensornatleft DM ,, projection_preserves_tensornatright DM ,, projection_preserves_associativity DM ,, projection_preserves_leftunitality DM ,, projection_preserves_rightunitality DM). Definition projection_fmonoidal_lax {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : fmonoidal_lax TM(DM) M π^{D} := (projection_fmonoidaldata DM,, projection_fmonoidal_laxlaws DM). Definition projection_preservestensor_strictly {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_tensor_strictly (projection_preserves_tensordata DM). Proof. intros x y. use tpair. - apply idpath. - apply idpath. Qed. Definition projection_preservesunit_strictly {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : preserves_unit_strictly (projection_preserves_unit DM). Proof. use tpair. - apply idpath. - apply idpath. Qed. Definition projection_fmonoidal {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) : fmonoidal TM(DM) M π^{D}. Proof. exists (projection_fmonoidal_lax DM). split. - apply strictlytensorpreserving_is_strong. exact (projection_preservestensor_strictly DM). - apply strictlyunitpreserving_is_strong. exact (projection_preservesunit_strictly DM). Defined. End MonoidalTotalCategory. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/TransportLemmas.v000066400000000000000000000113551451125700300266330ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Lemma disp_tensor_distributes_over_transportb_right {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) {x y z : C} {f g : y --> z} (p : f = g) (xx : D x) {yy : D y} {zz : D z} (ff : yy -->[f] zz) (gg : yy -->[g] zz) : ff = transportb _ p gg -> xx ⊗⊗^{DM}_{l} transportb _ p ff = transportb _ (maponpaths (leftwhiskering_on_morphisms M x y z) p) (xx ⊗⊗^{DM}_{l} gg). Proof. induction p. intro q. cbn. apply maponpaths. exact q. Qed. Lemma disp_tensor_distributes_over_transportb_left {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) {x y z : C} {f g : y --> z} (p : f = g) (xx : D x) {yy : D y} {zz : D z} (ff : yy -->[f] zz) (gg : yy -->[g] zz) : ff = transportb _ p gg -> transportb _ p ff ⊗⊗^{DM}_{r} xx = transportb _ (maponpaths (rightwhiskering_on_morphisms M _ _ _) p) (gg ⊗⊗^{DM}_{r} xx). Proof. induction p. intro q. cbn. apply maponpaths. exact q. Qed. Lemma disp_tensor_with_id_left {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) {x y z : C} {f : z --> y} {g : y --> z} (p : g · f = identity y) (xx : D x) (yy : D y) : xx ⊗⊗^{DM}_{l} transportb (mor_disp _ _) p (id_disp yy) = transportb _ (maponpaths (λ i, x ⊗^{M}_{l} i) p @ bifunctor_leftid M x y) (id_disp (xx ⊗⊗_{DM} yy)). Proof. set (pp := disp_tensor_distributes_over_transportb_right DM p xx (transportb _ p (id_disp yy)) (id_disp yy) (idpath _)). rewrite <- transport_b_b. etrans. 2: { apply maponpaths. apply (disp_bifunctor_leftid DM _ _ xx yy). } refine (_ @ pp). apply maponpaths. now rewrite transportb_const. Qed. Lemma disp_tensor_with_id_right {C : category} {D : disp_cat C} {M : monoidal C} (DM : disp_monoidal D M) {x y z : C} {f : z --> y} {g : y --> z} (p : g · f = identity y) (xx : D x) (yy : D y) : transportb (mor_disp _ _) p (id_disp yy) ⊗⊗^{DM}_{r} xx = transportb _ (maponpaths (λ i, i ⊗^{M}_{r} x) p @ bifunctor_rightid M x y) (id_disp (yy ⊗⊗_{DM} _)). Proof. set (pp := disp_tensor_distributes_over_transportb_left DM p xx (transportb _ p (id_disp yy)) (id_disp yy) (idpath _)). rewrite <- transport_b_b. etrans. 2: { apply maponpaths. apply (disp_bifunctor_rightid DM _ _ _ _). } refine (_ @ pp). apply maponpaths. now rewrite transportb_const. Qed. Lemma disp_tensor_with_id_on_right {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal D M} {x y z : C} {f : C⟦x, y⟧} {xx : D x} {yy : D y} {zz : D z} (ff : xx -->[f] yy) : ff ⊗⊗^{ DM} id_disp zz = transportb _ (when_bifunctor_becomes_rightwhiskering M z f) (ff ⊗⊗^{ DM}_{r} zz). Proof. unfold dispfunctoronmorphisms1. etrans. { apply maponpaths. apply disp_bifunctor_leftid. } etrans. { apply mor_disp_transportf_prewhisker. } use transportf_transpose_left. rewrite transport_b_b. etrans. { apply id_right_disp. } apply maponpaths_2. apply homset_property. Qed. Lemma disp_tensor_with_id_on_left {C : category} {D : disp_cat C} {M : monoidal C} {DM : disp_monoidal D M} {x y z : C} {f : C⟦x, y⟧} {xx : D x} {yy : D y} {zz : D z} (ff : xx -->[f] yy) : id_disp zz ⊗⊗^{ DM} ff = transportb _ (when_bifunctor_becomes_leftwhiskering M z f) (zz ⊗⊗^{ DM}_{l} ff). Proof. unfold dispfunctoronmorphisms1. etrans. { apply maponpaths_2. apply disp_bifunctor_rightid. } etrans. { apply mor_disp_transportf_postwhisker. } use transportf_transpose_left. rewrite transport_b_b. etrans. { apply id_left_disp. } apply maponpaths_2. apply homset_property. Qed. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Displayed/WhiskeredDisplayedBifunctors.v000066400000000000000000000547331451125700300313320ustar00rootroot00000000000000(********************************************************************************* Displayed whiskered bifunctors The goal is to define displayed monoidal categories, and for that we use the same style as for monoidal categories. As such, we need to define the notion of a displayed whiskered bifunctor. This is needed for the tensor functor. Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/WhiskeredDisplayedBifunctors.v *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Core.Isos. Open Scope cat. Open Scope mor_disp_scope. Section DisplayedBifunctor. Import BifunctorNotations. Definition disp_bifunctor_data {A B C : category} (F : bifunctor_data A B C) (DA : disp_cat A) (DB : disp_cat B) (DC : disp_cat C) : UU := ∑ (Fob : ∏ (x : A) (y : B), DA x -> DB y -> DC (x ⊗_{F} y)), (∏ (x : A) (y1 y2 : B) (g : B⟦y1,y2⟧) (xx : DA x) (yy1 : DB y1) (yy2 : DB y2), (yy1 -->[g] yy2) -> ((Fob _ _ xx yy1) -->[x ⊗^{F}_{l} g] (Fob _ _ xx yy2))) × (∏ (x1 x2 : A) (y : B) (f : A⟦x1,x2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy : DB y), (xx1 -->[f] xx2) -> ((Fob _ _ xx1 yy) -->[f ⊗^{F}_{r} y] (Fob _ _ xx2 yy))). Definition make_disp_bifunctor_data {A B C : category} (F : bifunctor_data A B C) (DA : disp_cat A) (DB : disp_cat B) (DC : disp_cat C) (Fob : ∏ (x : A) (y : B), DA x -> DB y -> DC (x ⊗_{F} y)) (dlw : ∏ (x : A) (y1 y2 : B) (g : B⟦y1,y2⟧) (xx : DA x) (yy1 : DB y1) (yy2 : DB y2), (yy1 -->[g] yy2) -> ((Fob _ _ xx yy1) -->[x ⊗^{F}_{l} g] (Fob _ _ xx yy2))) (drw : ∏ (x1 x2 : A) (y : B) (f : A⟦x1,x2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy : DB y), (xx1 -->[f] xx2) -> ((Fob _ _ xx1 yy) -->[f ⊗^{F}_{r} y] (Fob _ _ xx2 yy))) : disp_bifunctor_data F DA DB DC := (Fob,,dlw,,drw). Definition disp_bifunctor_on_objects {A B C : category} {F : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : ∏ (x : A) (y : B), DA x -> DB y -> DC (x ⊗_{F} y) := pr1 DF. Local Notation "xx ⊗⊗_{ DF } yy" := (disp_bifunctor_on_objects DF _ _ xx yy) (at level 31). Definition disp_leftwhiskering_on_morphisms {A B C : category} {F : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : ∏ (x : A) (y1 y2 : B) (g : B⟦y1,y2⟧) (xx : DA x) (yy1 : DB y1) (yy2 : DB y2), (yy1 -->[g] yy2) -> ((pr1 DF _ _ xx yy1) -->[x ⊗^{F}_{l} g] (pr1 DF _ _ xx yy2)) := pr1 (pr2 DF). Local Notation "xx ⊗⊗^{ DF }_{l} gg" := (disp_leftwhiskering_on_morphisms DF _ _ _ _ xx _ _ gg) (at level 31). Definition disp_rightwhiskering_on_morphisms {A B C : category} {F : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : ∏ (x1 x2 : A) (y : B) (f : A⟦x1,x2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy : DB y), (xx1 -->[f] xx2) -> ((pr1 DF _ _ xx1 yy) -->[f ⊗^{F}_{r} y] (pr1 DF _ _ xx2 yy)) := pr2 (pr2 DF). Local Notation "ff ⊗⊗^{ DF }_{r} yy" := (disp_rightwhiskering_on_morphisms DF _ _ _ _ _ _ yy ff) (at level 31). Definition disp_bifunctor_leftidax {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := ∏ (x : A) (y : B) (xx : DA x) (yy : DB y), xx ⊗⊗^{DF}_{l} (id_disp yy) = transportb _ (bifunctor_leftid F x y) (id_disp (xx ⊗⊗_{DF} yy)). Definition disp_bifunctor_rightidax {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := ∏ (x : A) (y : B) (xx : DA x) (yy : DB y), (id_disp xx) ⊗⊗^{DF}_{r} yy = transportb _ (bifunctor_rightid F y x) (id_disp (xx ⊗⊗_{DF} yy)). Definition disp_bifunctor_leftcompax {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := ∏ (x : A) (y1 y2 y3 : B) (g1 : B⟦y1,y2⟧) (g2 : B⟦y2,y3⟧) (xx : DA x) (yy1 : DB y1) (yy2 : DB y2) (yy3 : DB y3) (gg1 : yy1 -->[g1] yy2) (gg2 : yy2 -->[g2] yy3), (xx ⊗⊗^{DF}_{l} (gg1 ;; gg2) = transportb _ (bifunctor_leftcomp F _ _ _ _ g1 g2) ((xx ⊗⊗^{DF}_{l} gg1) ;; (xx ⊗⊗^{DF}_{l} gg2))). Definition disp_bifunctor_rightcompax {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := ∏ (x1 x2 x3 : A) (y : B) (f1 : A⟦x1,x2⟧) (f2 : A⟦x2,x3⟧) (xx1 : DA x1) (xx2 : DA x2) (xx3 : DA x3) (yy : DB y) (ff1 : xx1 -->[f1] xx2) (ff2 : xx2 -->[f2] xx3), ((ff1 ;; ff2) ⊗⊗^{DF}_{r} yy = transportb _ (bifunctor_rightcomp F _ _ _ _ f1 f2) ((ff1 ⊗⊗^{DF}_{r} yy) ;; (ff2 ⊗⊗^{DF}_{r} yy)) ). (** Remark:: No make_disp_functor exists in Displayedcats.Functors **) Definition leftwhiskering_dispfunctor {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) (dbli : disp_bifunctor_leftidax DF) (dblc : disp_bifunctor_leftcompax DF) : ∏ (x : A) (xx : DA x), disp_functor (leftwhiskering_functor F x) DB DC. Proof. intros x xx. (* use make_disp_functor. *) use tpair. - use tpair. + intros y yy. exact (xx ⊗⊗_{DF} yy). + intros y1 y2 yy1 yy2 g gg. exact (xx ⊗⊗^{DF}_{l} gg). - use tpair. + intros y yy. exact (dbli x y xx yy). + intros y1 y2 y3 yy1 yy2 yy3 g1 g2 gg1 gg2. cbn. exact (dblc x y1 y2 y3 g1 g2 xx yy1 yy2 yy3 gg1 gg2). Defined. Definition rightwhiskering_dispfunctor {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) (dbri : disp_bifunctor_rightidax DF) (dbrc : disp_bifunctor_rightcompax DF) : ∏ (y : B) (yy : DB y), disp_functor (rightwhiskering_functor F y) DA DC. Proof. intros y yy. (* use make_disp_functor. *) use tpair. - use tpair. + intros x xx. exact (xx ⊗⊗_{DF} yy). + intros x1 x2 xx1 xx2 f ff. exact (ff ⊗⊗^{DF}_{r} yy). - use tpair. + intros x xx. exact (dbri x y xx yy). + intros x1 x2 x3 xx1 xx2 xx3 f1 f2 ff1 ff2. cbn. exact (dbrc x1 x2 x3 y f1 f2 xx1 xx2 xx3 yy ff1 ff2). Defined. Definition dispfunctoronmorphisms1 {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) {x1 x2 : A} {y1 y2 : B} {f : A⟦x1,x2⟧} {g : B⟦y1,y2⟧} {xx1 : DA x1} {xx2 : DA x2} {yy1 : DB y1} {yy2 : DB y2} (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2) : xx1 ⊗⊗_{DF} yy1 -->[f ⊗^{F} g] xx2 ⊗⊗_{DF} yy2 := (ff ⊗⊗^{DF}_{r} yy1) ;; (xx2 ⊗⊗^{DF}_{l} gg). Local Notation "ff ⊗⊗^{ DF } gg" := (dispfunctoronmorphisms1 DF ff gg) (at level 31). Definition dispfunctoronmorphisms2 {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) {x1 x2 : A} {y1 y2 : B} {f : A⟦x1,x2⟧} {g : B⟦y1,y2⟧} {xx1 : DA x1} {xx2 : DA x2} {yy1 : DB y1} {yy2 : DB y2} (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2) : xx1 ⊗⊗_{DF} yy1 -->[functoronmorphisms2 F f g] xx2 ⊗⊗_{DF} yy2 := (xx1 ⊗⊗^{DF}_{l} gg) ;; (ff ⊗⊗^{DF}_{r} yy2). Local Notation "ff ⊗⊗^{ DF }_{2} gg" := (dispfunctoronmorphisms2 DF ff gg) (at level 31). Definition dispfunctoronmorphisms_are_equal {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := ∏ (x1 x2 : A) (y1 y2 : B) (f : A⟦x1,x2⟧) (g : B⟦y1,y2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy1 : DB y1) (yy2 : DB y2) (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2), ff ⊗⊗^{DF} gg = transportb _ (bifunctor_equalwhiskers F _ _ _ _ f g) (ff ⊗⊗^{DF}_{2} gg). Lemma dispwhiskerscommutes {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {DF : disp_bifunctor_data F DA DB DC} (dfmae : dispfunctoronmorphisms_are_equal DF) : ∏ (x1 x2 : A) (y1 y2 : B) (f : A⟦x1,x2⟧) (g : B⟦y1,y2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy1 : DB y1) (yy2 : DB y2) (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2), ((ff ⊗⊗^{ DF}_{r} yy1) ;; (xx2 ⊗⊗^{ DF}_{l} gg) = transportb _ (bifunctor_equalwhiskers F x1 x2 y1 y2 f g) ((xx1 ⊗⊗^{ DF}_{l} gg) ;; (ff ⊗⊗^{ DF}_{r} yy2))). Proof. intros. apply dfmae. Qed. Definition is_disp_bifunctor {A B C : category} (F : bifunctor A B C) {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) : UU := (disp_bifunctor_leftidax DF) × (disp_bifunctor_rightidax DF) × (disp_bifunctor_leftcompax DF) × (disp_bifunctor_rightcompax DF) × (dispfunctoronmorphisms_are_equal DF). Definition disp_bifunctor {A B C : category} (F : bifunctor A B C) (DA : disp_cat A) (DB : disp_cat B) (DC : disp_cat C) : UU := ∑ (DF : disp_bifunctor_data F DA DB DC), is_disp_bifunctor F DF. Definition make_disp_bifunctor {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor_data F DA DB DC) (H : is_disp_bifunctor F DF) : disp_bifunctor F DA DB DC := (DF,,H). Definition make_disp_bifunctor_locally_prop {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {LP : locally_propositional DC} (DF : disp_bifunctor_data F DA DB DC) : disp_bifunctor F DA DB DC. Proof. exists DF. abstract (repeat split ; try intro ; intros ; apply LP). Defined. Definition disp_bifunctordata_from_disp_bifunctor {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : disp_bifunctor_data F DA DB DC := pr1 DF. Coercion disp_bifunctordata_from_disp_bifunctor : disp_bifunctor >-> disp_bifunctor_data. Definition is_disp_bifunctor_from_disp_bifunctor {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : is_disp_bifunctor F DF := pr2 DF. Definition disp_bifunctor_leftid {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : disp_bifunctor_leftidax DF := pr1 (is_disp_bifunctor_from_disp_bifunctor DF). Definition disp_bifunctor_rightid {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : disp_bifunctor_rightidax DF := pr1 (pr2 (is_disp_bifunctor_from_disp_bifunctor DF)). Definition disp_bifunctor_leftcomp {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : disp_bifunctor_leftcompax DF := pr1 (pr2 (pr2 (is_disp_bifunctor_from_disp_bifunctor DF))). Definition disp_bifunctor_rightcomp {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : disp_bifunctor_rightcompax DF := pr1 (pr2 (pr2 (pr2 (is_disp_bifunctor_from_disp_bifunctor DF)))). Definition disp_bifunctor_equalwhiskers {A B C : category} {F : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (DF : disp_bifunctor F DA DB DC) : dispfunctoronmorphisms_are_equal DF := pr2 (pr2 (pr2 (pr2 (is_disp_bifunctor_from_disp_bifunctor DF)))). End DisplayedBifunctor. Module DisplayedBifunctorNotations. Notation "xx ⊗⊗_{ DF } yy" := (disp_bifunctor_on_objects DF _ _ xx yy) (at level 31). Notation "xx ⊗⊗^{ DF }_{l} gg" := (disp_leftwhiskering_on_morphisms DF _ _ _ _ xx _ _ gg) (at level 31). Notation "ff ⊗⊗^{ DF }_{r} yy" := (disp_rightwhiskering_on_morphisms DF _ _ _ _ _ _ yy ff) (at level 31). Notation "ff ⊗⊗^{ DF } gg" := (dispfunctoronmorphisms1 DF ff gg) (at level 31). End DisplayedBifunctorNotations. Section DisplayedWhiskeredBinaturaltransformation. Import DisplayedBifunctorNotations. Definition disp_binat_trans_data {A B C : category} {F : bifunctor_data A B C} {G : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (α : binat_trans_data F G) (DF : disp_bifunctor_data F DA DB DC) (DG : disp_bifunctor_data G DA DB DC) : UU := ∏ (x : A) (y : B) (xx : DA x) (yy : DB y), xx ⊗⊗_{DF} yy -->[α x y] xx ⊗⊗_{DG} yy. Definition make_disp_binat_trans_data {A B C : category} {F : bifunctor_data A B C} {G : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {α : binat_trans_data F G} {DF : disp_bifunctor_data F DA DB DC} {DG : disp_bifunctor_data G DA DB DC} (dα : ∏ (x : A) (y : B) (xx : DA x) (yy : DB y), xx ⊗⊗_{DF} yy -->[α x y] xx ⊗⊗_{DG} yy) : disp_binat_trans_data α DF DG := dα. Definition is_disp_binat_trans {A B C : category} {F : bifunctor_data A B C} {G : bifunctor_data A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {α : binat_trans F G} {DF : disp_bifunctor_data F DA DB DC} {DG : disp_bifunctor_data G DA DB DC} (dα : disp_binat_trans_data α DF DG) : UU := (∏ (x : A) (y1 y2 : B) (g : B⟦y1,y2⟧) (xx : DA x) (yy1 : DB y1) (yy2 : DB y2) (gg : yy1 -->[g] yy2), ((xx ⊗⊗^{DF}_{l} gg) ;; (dα _ _ xx yy2) = transportb _ (pr1 (pr2 α) x y1 y2 _) ((dα _ _ xx yy1) ;; (xx ⊗⊗^{DG}_{l} gg)))) × (∏ (x1 x2 : A) (y : B) (f : A⟦x1,x2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy : DB y) (ff : xx1 -->[f] xx2), ((ff ⊗⊗^{DF}_{r} yy) ;; (dα _ _ xx2 yy) = transportb _ (pr2 (pr2 α) x1 x2 y _) ((dα _ _ xx1 yy) ;; (ff ⊗⊗^{DG}_{r} yy)))). (* Lemma mor_disp_transportb_prewhisker {C : precategory} {D : disp_cat_data C} {x y z : C} {f : x --> y} {g g' : y --> z} (eg : g = g') {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg' : yy -->[g'] zz) : ff ;; (transportb _ eg gg') = transportb _ (maponpaths (compose f) (eg)) (ff ;; gg'). Proof. destruct eg; apply idpath. Qed. Lemma mor_disp_transportb_postwhisker {C : precategory} {D : disp_cat_data C} {x y z : C} {f f' : x --> y} {g : y --> z} (ef : f' = f) {xx : D x} {yy} {zz} (ff' : xx -->[f] yy) (gg : yy -->[g] zz) : (transportb _ ef ff') ;; gg = transportb _ (cancel_postcomposition _ _ g ef) (ff' ;; gg). Proof. destruct ef ; apply idpath. Qed. *) Lemma full_disp_naturality_condition {A B C : category} {F : bifunctor A B C} {G : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {α : binat_trans F G} {DF : disp_bifunctor_data F DA DB DC} {DG : disp_bifunctor_data G DA DB DC} {dα : disp_binat_trans_data α DF DG} (dαn : is_disp_binat_trans dα) (x1 x2 : A) (y1 y2 : B) (f : A⟦x1,x2⟧) (g : B⟦y1,y2⟧) (xx1 : DA x1) (xx2 : DA x2) (yy1 : DB y1) (yy2 : DB y2) (ff : xx1 -->[f] xx2) (gg : yy1 -->[g] yy2) : (ff ⊗⊗^{DF} gg) ;; (dα _ _ xx2 yy2) = transportb _ (full_naturality_condition (pr2 α) f g) ((dα _ _ xx1 yy1) ;; (ff ⊗⊗^{DG} gg)). Proof. unfold dispfunctoronmorphisms1. etrans. { apply assoc_disp_var. } apply transportf_transpose_left. rewrite transport_b_b. rewrite (pr1 dαn). etrans. { apply mor_disp_transportf_prewhisker. } apply transportb_transpose_right. rewrite transport_f_f. apply transportf_transpose_left. etrans. { apply assoc_disp. } rewrite (pr2 dαn). apply transportb_transpose_right. rewrite transport_f_b. apply transportf_transpose_left. etrans. { apply mor_disp_transportf_postwhisker. } apply transportf_transpose_left. rewrite transport_b_b. rewrite assoc_disp_var. apply transportf_transpose_left. rewrite transport_b_b. use pathsinv0. apply transportf_set. apply homset_property. Qed. Definition disp_binat_trans {A B C : category} {F : bifunctor A B C} {G : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} (α : binat_trans F G) (DF : disp_bifunctor_data F DA DB DC) (DG : disp_bifunctor_data G DA DB DC) : UU := ∑ (dα : disp_binat_trans_data α DF DG), is_disp_binat_trans dα. Definition make_disp_binat_trans {A B C : category} {F : bifunctor A B C} {G : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {α : binat_trans F G} {DF : disp_bifunctor_data F DA DB DC} {DG : disp_bifunctor_data G DA DB DC} (dα : disp_binat_trans_data α DF DG) (H : is_disp_binat_trans dα) : disp_binat_trans α DF DG := (dα,,H). (* is_iso_disp is defined using iso instead of z_iso *) Definition is_z_iso_disp {C : precategory} {D : disp_cat_data C} {x y : C} (f : z_iso x y) {xx : D x} {yy : D y} (ff : xx -->[f] yy) : UU := ∑ (gg : yy -->[inv_from_z_iso f] xx), (gg ;; ff = transportb _ (z_iso_after_z_iso_inv _) (id_disp _)) × (ff ;; gg = transportb _ (z_iso_inv_after_z_iso _) (id_disp _)). Definition is_dispbinatiso {A B C : category} {F : bifunctor A B C} {G : bifunctor A B C} {DA : disp_cat A} {DB : disp_cat B} {DC : disp_cat C} {α : binat_trans F G} (αiso : is_binatiso α) {DF : disp_bifunctor_data F DA DB DC} {DG : disp_bifunctor_data G DA DB DC} (dα : disp_binat_trans α DF DG) : UU := ∏ (x : A) (y : B) (xx : DA x) (yy : DB y), is_z_iso_disp (α x y ,, αiso x y) (pr1 dα x y xx yy). End DisplayedWhiskeredBinaturaltransformation. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/000077500000000000000000000000001451125700300231445ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/BinopCartesianMonoidal.v000066400000000000000000000116661451125700300277310ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.DisplayedCartesianMonoidal. Local Open Scope cat. Section BinopCategory. Definition Binop_disp_cat : disp_cat SET. Proof. use disp_struct. - exact (λ X, binop (pr1 X)). - exact (λ X Y m n f, isbinopfun (X := (X,,m)) (Y := (Y,,n)) f). - intros X Y m n f. apply isapropisbinopfun. - intros X m x1 x2. apply idpath. - intros X Y Z m n o f g pf pg. cbn in *. exact (isbinopfuncomp (make_binopfun (X := (X,,m)) (Y := (Y,,n)) f pf) (make_binopfun (X := (Y,,n)) (Y := (Z,,o)) g pg)). Defined. Lemma Binop_disp_cat_locally_prop : locally_propositional Binop_disp_cat. Proof. intro; intros; apply isapropisbinopfun. Qed. Definition Binop_cat : category := total_category Binop_disp_cat. Definition Binop_dispBinproducts : dispBinProducts Binop_disp_cat BinProductsHSET. Proof. intros X Y m n. use make_dispBinProduct_locally_prop. - exact Binop_disp_cat_locally_prop. - use tpair. + intros xy1 xy2. exact (m (pr1 xy1) (pr1 xy2),, n (pr2 xy1) (pr2 xy2)). + split; intros x1 x2; apply idpath. - intros Z f g o pf pg. cbn. intros x1 x2. apply dirprodeq; cbn. + rewrite pf. apply idpath. + rewrite pg. apply idpath. Defined. Definition Binop_dispTerminal : dispTerminal Binop_disp_cat TerminalHSET. Proof. use make_dispTerminal_locally_prop. - exact Binop_disp_cat_locally_prop. - exact (fun _ _ => tt). - cbn. intros X m. intros ? ?. apply idpath. Defined. Definition Binop_cat_cart_monoidal_via_cartesian : monoidal Binop_cat. Proof. use cartesian_monoidal. - apply (total_category_Binproducts _ BinProductsHSET Binop_dispBinproducts). - apply (total_category_Terminal _ TerminalHSET Binop_dispTerminal). Defined. End BinopCategory. Section BinopIsCartesianMonoidal. Local Notation BO := Binop_cat. Local Notation DBO := Binop_disp_cat. Definition BO_cart_disp_monoidal : disp_monoidal DBO SET_cartesian_monoidal := displayedcartesianmonoidalcat BinProductsHSET TerminalHSET Binop_disp_cat Binop_dispBinproducts Binop_dispTerminal. Section ElementaryProof. Definition BO_disp_tensor_data : disp_bifunctor_data SET_cartesian_monoidal DBO DBO DBO. Proof. repeat (use tpair). - intros X Y m n. intros xy1 xy2. exact (m (pr1 xy1) (pr1 xy2),, n (pr2 xy1) (pr2 xy2)). - intros X Y Z f m n o pf. intros x1 x2. use total2_paths_b. + apply idpath. + cbn in *. apply pf. - intros X Y1 Y2 g m m1 m2 pg. intros xy1 xy2. use total2_paths_b. + cbn in *; apply pg. + cbn in *. unfold transportb. rewrite transportf_const. apply idpath. Defined. Definition BO_disp_tensor : disp_tensor DBO SET_cartesian_monoidal. Proof. use make_disp_bifunctor_locally_prop. - exact Binop_disp_cat_locally_prop. - exact BO_disp_tensor_data. Defined. Definition BO_cart_disp_monoidal_data : disp_monoidal_data DBO SET_cartesian_monoidal. Proof. use tpair. - exact BO_disp_tensor. - use tpair. + intros t1 t2 ; induction t1 ; induction t2 ; exact tt. + repeat split. Defined. Definition BO_cart_disp_monoidal_elementary : disp_monoidal DBO SET_cartesian_monoidal. Proof. use make_disp_monoidal_locally_prop. - exact Binop_disp_cat_locally_prop. - exact BO_cart_disp_monoidal_data. Defined. End ElementaryProof. Definition Binop_cat_cart_monoidal : monoidal Binop_cat := total_monoidal BO_cart_disp_monoidal. Lemma Forgetful_BO_to_set_preserves_unit_strictly : preserves_unit_strictly (projection_preserves_unit BO_cart_disp_monoidal). Proof. apply projection_preservesunit_strictly. Qed. Lemma Forgetful_ptset_to_set_preserves_tensor_strictly : preserves_tensor_strictly (projection_preserves_tensordata BO_cart_disp_monoidal). Proof. apply projection_preservestensor_strictly. Qed. End BinopIsCartesianMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/CartesianMonoidal.v000066400000000000000000000452471451125700300267430ustar00rootroot00000000000000(******************************************************************** Construction of cartesian monoidal categories Every category with binary products and a terminal object gives rise to a monoidal category. Contents 1. Construction of cartesian monoidal categories 2. Properties of cartesian monoidal categories 3. Cartesian closed categories 4. Set as cartesian monoidal category 5. Useful lemmas Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/CartesianMonoidalCategoriesWhiskered.v ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. (** 1. Construction of cartesian monoidal categories *) Section GeneralConstruction. Context (C : category) (CP : BinProducts C) (terminal : Terminal C). Definition tensorfrombinprod_data: bifunctor_data C C C. Proof. use make_bifunctor_data. - intros c1 c2. exact (BinProductObject _ (CP c1 c2)). - intros b c1 c2 g. use BinProductOfArrows. + apply identity. + exact g. - intros b1 b2 c f. use BinProductOfArrows. + exact f. + apply identity. Defined. Lemma is_bifunctor_tensorfrombinprod_data : is_bifunctor tensorfrombinprod_data. Proof. repeat split; red; cbn. - intros b c. apply pathsinv0, BinProduct_endo_is_identity. + now rewrite BinProductOfArrowsPr1, id_right. + now rewrite BinProductOfArrowsPr2, id_right. - intros b c. apply pathsinv0, BinProduct_endo_is_identity. + now rewrite BinProductOfArrowsPr1, id_right. + now rewrite BinProductOfArrowsPr2, id_right. - intros b c1 c2 c3 g1 g2. now rewrite BinProductOfArrows_comp, id_right. - intros b1 b2 b3 c f1 f2. now rewrite BinProductOfArrows_comp, id_right. - intros b1 b2 c1 c2 f g. unfold functoronmorphisms1, functoronmorphisms2. unfold leftwhiskering_on_morphisms, rightwhiskering_on_morphisms. cbn. do 2 rewrite BinProductOfArrows_comp. do 2 rewrite id_right. do 2 rewrite id_left. apply idpath. Qed. (** the following is merely a variant of [binproduct_functor] *) Definition tensorfrombinprod : bifunctor C C C. Proof. use make_bifunctor. - exact tensorfrombinprod_data. - exact is_bifunctor_tensorfrombinprod_data. Defined. Definition cartesianmonoidalcat_data : monoidal_data C. Proof. use make_monoidal_data. - exact tensorfrombinprod. - exact (TerminalObject terminal). - intro c. apply BinProductPr2. - intro c. apply BinProductArrow. * apply TerminalArrow. * exact (identity c). - intro c. apply BinProductPr1. - intro c. apply BinProductArrow. * exact (identity c). * apply TerminalArrow. - intros c1 c2 c3. apply BinProductArrow. + use compose. 2: {apply BinProductPr1. } apply BinProductPr1. + apply BinProductArrow. * use compose. 2: {apply BinProductPr1. } apply BinProductPr2. * apply BinProductPr2. - intros a b c. apply BinProductArrow. + apply BinProductArrow. * apply BinProductPr1. * use compose. 2: {apply BinProductPr2. } apply BinProductPr1. + use compose. 2: {apply BinProductPr2. } apply BinProductPr2. Defined. Local Definition MD := cartesianmonoidalcat_data. Local Lemma leftunitor_law_from_binprod: leftunitor_law lu_{MD} luinv_{MD}. Proof. split. - intros c1 c2 f. cbn. apply BinProductOfArrowsPr2. - split. + apply pathsinv0, BinProduct_endo_is_identity. * (* show_id_type. *) apply TerminalArrowEq. * rewrite <- assoc. etrans. { apply maponpaths. apply BinProductPr2Commutes. } apply id_right. + apply BinProductPr2Commutes. Qed. Local Lemma rightunitor_law_from_binprod: rightunitor_law ru_{MD} ruinv_{MD}. Proof. split. - intros c1 c2 f. cbn. apply BinProductOfArrowsPr1. - intro c. split. + apply pathsinv0, BinProduct_endo_is_identity. * rewrite <- assoc. etrans. { apply maponpaths. apply BinProductPr1Commutes. } apply id_right. * apply TerminalArrowEq. + apply BinProductPr1Commutes. Qed. Local Lemma associator_law_from_binprod: associator_law α_{MD} αinv_{MD}. Proof. repeat split. - intros a b c1 c2 h. unfold leftwhiskering_on_morphisms, rightwhiskering_on_morphisms. cbn. rewrite postcompWithBinProductArrow. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply BinProductArrowUnique. + rewrite BinProductPr1Commutes. rewrite id_right. unfold BinProductOfArrows. rewrite id_right. rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. + rewrite id_right. rewrite BinProductPr2Commutes. rewrite postcompWithBinProductArrow. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply BinProductArrowUnique. * rewrite BinProductPr1Commutes. rewrite id_right. unfold BinProductOfArrows. rewrite id_right. rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. * rewrite id_right. rewrite BinProductPr2Commutes. unfold BinProductOfArrows. rewrite id_right. rewrite BinProductPr2Commutes. apply idpath. - intros a1 a2 b c f. unfold leftwhiskering_on_morphisms, rightwhiskering_on_morphisms. cbn. rewrite postcompWithBinProductArrow. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply BinProductArrowUnique. + rewrite BinProductPr1Commutes. rewrite assoc. unfold BinProductOfArrows. rewrite BinProductPr1Commutes. rewrite id_right. etrans. 2: { rewrite <- assoc. rewrite BinProductPr1Commutes. apply assoc'. } apply idpath. + rewrite BinProductPr2Commutes. rewrite id_right. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply BinProductArrowUnique. * rewrite BinProductPr1Commutes. unfold BinProductOfArrows. do 2 rewrite id_right. rewrite assoc. rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr2Commutes. apply idpath. * rewrite BinProductPr2Commutes. unfold BinProductOfArrows. rewrite BinProductPr2Commutes. rewrite id_right. apply idpath. - intros a b1 b2 c g. unfold leftwhiskering_on_morphisms, rightwhiskering_on_morphisms. cbn. rewrite postcompWithBinProductArrow. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } apply BinProductArrowUnique. + rewrite BinProductPr1Commutes. rewrite id_right. rewrite assoc. unfold BinProductOfArrows. rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite id_right. apply idpath. + rewrite BinProductPr2Commutes. rewrite postcompWithBinProductArrow. etrans. 2: { apply pathsinv0, precompWithBinProductArrow. } rewrite id_right. apply BinProductArrowUnique. * rewrite BinProductPr1Commutes. unfold BinProductOfArrows. rewrite assoc. rewrite BinProductPr1Commutes. etrans. 2: { rewrite <- assoc. rewrite BinProductPr2Commutes. apply assoc'. } apply idpath. * rewrite BinProductPr2Commutes. unfold BinProductOfArrows. rewrite BinProductPr2Commutes. rewrite id_right. apply idpath. - apply pathsinv0, BinProduct_endo_is_identity. -- cbn. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite precompWithBinProductArrow. apply pathsinv0, BinProductArrowUnique. ++ apply pathsinv0, BinProductPr1Commutes. ++ rewrite assoc. rewrite BinProductPr2Commutes. apply pathsinv0, BinProductPr1Commutes. -- cbn. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. apply BinProductPr2Commutes. - apply pathsinv0, BinProduct_endo_is_identity. -- cbn. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. apply BinProductPr1Commutes. -- cbn. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite precompWithBinProductArrow. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. apply pathsinv0, BinProductArrowUnique; apply idpath. Qed. Local Lemma triangle_identity_from_binprod: triangle_identity lu_{MD} ru_{MD} α_{MD}. Proof. intros b c. cbn. rewrite postcompWithBinProductArrow. apply pathsinv0, BinProductArrowUnique. - rewrite BinProductOfArrowsPr1. rewrite id_right. apply idpath. - rewrite BinProductOfArrowsPr2. rewrite BinProductPr2Commutes. apply id_right. Qed. Local Lemma pentagon_identity_from_binprod: pentagon_identity α_{MD}. Proof. intros a b c d. cbn. etrans. { rewrite <- assoc. rewrite postcompWithBinProductArrow. rewrite precompWithBinProductArrow. apply idpath. } etrans. 2: { rewrite precompWithBinProductArrow. apply idpath. } apply BinProductArrowsEq. - do 2 rewrite BinProductPr1Commutes. rewrite id_right. rewrite assoc. rewrite BinProductOfArrowsPr1. rewrite assoc. rewrite BinProductPr1Commutes. rewrite <- assoc. rewrite BinProductPr1Commutes. apply assoc. - do 2 rewrite BinProductPr2Commutes. etrans. { rewrite precompWithBinProductArrow. unfold BinProductOfArrows. rewrite precompWithBinProductArrow. apply idpath. } etrans. 2: { rewrite precompWithBinProductArrow. apply idpath. } apply BinProductArrowsEq. + do 2 rewrite BinProductPr1Commutes. etrans. 2: { rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. } etrans. { apply maponpaths. rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. } repeat rewrite assoc. rewrite BinProductPr1Commutes. repeat rewrite <- assoc. apply maponpaths. rewrite assoc. rewrite BinProductPr2Commutes. apply BinProductPr1Commutes. + do 2 rewrite BinProductPr2Commutes. rewrite BinProductPr2Commutes. do 4 rewrite precompWithBinProductArrow. apply BinProductArrowsEq. * do 2 rewrite BinProductPr1Commutes. etrans. { apply maponpaths. rewrite assoc. rewrite BinProductPr1Commutes. apply idpath. } repeat rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. apply BinProductPr2Commutes. * do 4 rewrite BinProductPr2Commutes. apply id_right. Qed. Definition cartesian_monoidal : monoidal C. Proof. exists cartesianmonoidalcat_data. exists is_bifunctor_tensorfrombinprod_data. exists leftunitor_law_from_binprod. exists rightunitor_law_from_binprod. exists associator_law_from_binprod. exists triangle_identity_from_binprod. exact pentagon_identity_from_binprod. Defined. Definition cartesian_monoidalcat : monoidal_cat := C ,, cartesian_monoidal. (** 2. Properties of cartesian monoidal categories *) Proposition is_semicartesian_cartesian_monoidalcat : is_semicartesian cartesian_monoidalcat. Proof. exact (pr2 terminal). Defined. Proposition is_cartesian_cartesian_monoidalcat : is_cartesian cartesian_monoidalcat. Proof. refine (is_semicartesian_cartesian_monoidalcat ,, _). intros x y ; cbn. use (isBinProduct_eq_arrow _ _ (pr2 (CP x y))). - abstract (unfold semi_cart_tensor_pr1 ; cbn ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; cbn ; rewrite !assoc' ; rewrite BinProductOfArrowsPr1 ; rewrite id_right ; rewrite BinProductOfArrowsPr1 ; rewrite id_right ; apply idpath). - abstract (unfold semi_cart_tensor_pr2 ; cbn ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; cbn ; rewrite !assoc' ; rewrite BinProductOfArrowsPr2 ; rewrite id_right ; rewrite BinProductOfArrowsPr2 ; rewrite id_right ; apply idpath). Defined. Definition symmetric_cartesian_monoidalcat : symmetric cartesian_monoidalcat. Proof. use cartesian_to_symmetric. exact is_cartesian_cartesian_monoidalcat. Defined. (** 3. Cartesian closed categories *) Definition sym_mon_closed_cartesian_cat (expC : Exponentials CP) : sym_mon_closed_cat. Proof. use make_sym_mon_closed_cat. - exact (cartesian_monoidalcat ,, symmetric_cartesian_monoidalcat). - exact (exp expC). - exact (exp_eval_alt expC). - exact (λ _ _ _ f, exp_lam_alt expC f). - abstract (cbn ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; cbn ; intros x y z f ; refine (_ @ exp_beta_alt expC f) ; apply maponpaths_2 ; apply prod_lwhisker_rwhisker). - abstract (intros x y z f ; cbn in * ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; cbn ; refine (exp_eta_alt expC f @ _) ; apply maponpaths ; apply maponpaths_2 ; refine (!_) ; apply prod_lwhisker_rwhisker). Defined. End GeneralConstruction. (** 4. Set as cartesian monoidal category *) Definition SET_cartesian_monoidal : monoidal SET. Proof. apply cartesian_monoidal. - apply BinProductsHSET. - apply TerminalHSET. Defined. (** 5. Useful lemmas *) Proposition cartesian_semi_cart_tensor_pr1 (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (x y : V) : semi_cart_tensor_pr1 (is_semicartesian_cartesian_monoidalcat VC VP TV) x y = BinProductPr1 _ _. Proof. unfold semi_cart_tensor_pr1 ; cbn. unfold monoidal_cat_tensor_mor, functoronmorphisms1 ; cbn. rewrite !assoc'. rewrite BinProductOfArrowsPr1. rewrite id_right. rewrite BinProductOfArrowsPr1. apply id_right. Qed. Proposition cartesian_semi_cart_tensor_pr2 (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (x y : V) : semi_cart_tensor_pr2 (is_semicartesian_cartesian_monoidalcat VC VP TV) x y = BinProductPr2 _ _. Proof. unfold semi_cart_tensor_pr2 ; cbn. unfold monoidal_cat_tensor_mor, functoronmorphisms1 ; cbn. rewrite !assoc'. rewrite BinProductOfArrowsPr2. rewrite id_right. rewrite BinProductOfArrowsPr2. apply id_right. Qed. Proposition lassociator_hexagon_two (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (x y z : V) : mon_lassociator x y z · sym_mon_braiding V x _ · mon_lassociator y z x · sym_mon_braiding V y _ · mon_lassociator z x y = sym_mon_braiding V _ z. Proof. use BinProductArrowsEq ; cbn. - rewrite !assoc'. rewrite !BinProductPr1Commutes. etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite BinProductPr1Commutes. apply idpath. } rewrite !cartesian_semi_cart_tensor_pr2. etrans. { do 2 apply maponpaths. rewrite !assoc. apply maponpaths_2. apply BinProductPr2Commutes. } rewrite BinProductPr1Commutes. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply BinProductPr1Commutes. } rewrite !assoc. rewrite !BinProductPr2Commutes. apply idpath. - rewrite !assoc'. rewrite !BinProductPr2Commutes. rewrite !cartesian_semi_cart_tensor_pr1, !cartesian_semi_cart_tensor_pr2. use BinProductArrowsEq. + rewrite !assoc'. rewrite !BinProductPr1Commutes. etrans. { do 3 apply maponpaths. rewrite !assoc. rewrite BinProductPr1Commutes. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite !BinProductPr2Commutes. apply idpath. } rewrite !BinProductPr2Commutes. rewrite !BinProductPr1Commutes. apply idpath. + rewrite !assoc'. rewrite !BinProductPr2Commutes. etrans. { do 2 apply maponpaths. rewrite BinProductPr1Commutes. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite !BinProductPr1Commutes. apply idpath. } rewrite !assoc. rewrite !BinProductPr2Commutes. rewrite !BinProductPr1Commutes. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/ConstantFunctor.v000066400000000000000000000064531451125700300264750ustar00rootroot00000000000000(** Let V be a monoidal category, Given a monoid object y in V, we show how the "constant functor" V → V : x ↦ y is part of a strong monoidal functor. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Local Open Scope cat. Import MonoidalNotations. Section ConstantFunctor. Context (V : monoidal_cat). Context {x : V} (m : monoid V x). Definition constant_functor_fmonoidal_data : fmonoidal_data V V (constant_functor _ _ x). Proof. use tpair. - intros ? ?. apply m. - apply m. Defined. Lemma constant_functor_fmonoidal_laxlaws : fmonoidal_laxlaws constant_functor_fmonoidal_data. Proof. repeat split ; (intro ; intros ; rewrite id_right). - rewrite (bifunctor_leftid V). apply id_left. - rewrite (bifunctor_rightid V). apply id_left. - apply pathsinv0, (monoid_to_assoc_law V m). - apply (monoid_to_unit_left_law V m). - apply (monoid_to_unit_right_law V m). Qed. Definition constant_functor_fmonoidal_lax : fmonoidal_lax V V (constant_functor _ _ x). Proof. exists constant_functor_fmonoidal_data. exact constant_functor_fmonoidal_laxlaws. Defined. Context (comul_iso : is_z_isomorphism (monoid_data_multiplication _ m)) (counit_iso : is_z_isomorphism (monoid_data_unit _ m)). Definition constant_functor_fmonoidal_strong : fmonoidal_stronglaws (fmonoidal_preservestensordata constant_functor_fmonoidal_lax) (fmonoidal_preservesunit constant_functor_fmonoidal_lax). Proof. split. - intro ; intro. apply comul_iso. - apply counit_iso. Defined. Definition constant_functor_fmonoidal : fmonoidal V V (constant_functor _ _ x). Proof. exists constant_functor_fmonoidal_lax. exact constant_functor_fmonoidal_strong. Defined. Definition constant_functor_is_symmetric (S : symmetric V) (m_is_comm : pr1 S x x · monoid_data_multiplication _ m = monoid_data_multiplication _ m) : is_symmetric_monoidal_functor S S constant_functor_fmonoidal. Proof. intro ; intro. rewrite id_right. apply m_is_comm. Qed. End ConstantFunctor. Section UnitExample. Context (V : monoidal_cat). Definition constantly_unit_functor_fmonoidal : fmonoidal V V (constant_functor _ _ (I_{V})). Proof. use constant_functor_fmonoidal. - apply unit_monoid. - exact (pr2 (leftunitor_nat_z_iso V) (I_{V})). - apply identity_is_z_iso. Defined. Definition constantly_unit_functor_is_symmetric (S : symmetric V) : is_symmetric_monoidal_functor S S constantly_unit_functor_fmonoidal. Proof. use constant_functor_is_symmetric. cbn. refine (_ @ id_left _). apply maponpaths_2. apply (sym_mon_braiding_id (V,,S)). Defined. End UnitExample. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/DiagonalFunctor.v000066400000000000000000000147151451125700300264220ustar00rootroot00000000000000(** Let V be a symmetric monoidal category, we show how the "diagonal functor" V → V : x ↦ x ⊗ x is part of a strong monoidal functor. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section DiagFunctor. Context (V : monoidal_cat). Definition diag_functor_data : functor_data V V. Proof. use make_functor_data. - exact (λ x, x ⊗ x). - exact (λ _ _ f, f #⊗ f). Defined. Lemma diag_is_functor : is_functor diag_functor_data. Proof. split ; intro ; intros. - apply tensor_id_id. - apply tensor_comp_mor. Qed. Definition diag_functor : functor V V. Proof. exists diag_functor_data. exact diag_is_functor. Defined. End DiagFunctor. Section DiagFunctorMonoidal. Context (V : sym_monoidal_cat). Let diag := diag_functor V. Definition diag_preserves_tensor_data : preserves_tensordata V V diag. Proof. exact (λ x y, inner_swap V x x y y). Defined. Definition diag_preserves_unit : preserves_unit V V diag. Proof. apply mon_linvunitor. Defined. Definition diag_functor_fmonoidal_data : fmonoidal_data V V diag. Proof. exists diag_preserves_tensor_data. exact diag_preserves_unit. Defined. Lemma diag_functor_fmonoidal_nat_left : preserves_tensor_nat_left (fmonoidal_preservestensordata diag_functor_fmonoidal_data). Proof. intros y x1 x2 f. apply pathsinv0. refine (_ @ naturality_inner_swap V (identity y) (identity y) f f @ _). - apply maponpaths. etrans. 2: { apply maponpaths. apply pathsinv0, (when_bifunctor_becomes_leftwhiskering V). } cbn ; apply maponpaths_2. apply pathsinv0, (when_bifunctor_becomes_leftwhiskering V). - rewrite <- (when_bifunctor_becomes_leftwhiskering V). do 2 apply maponpaths_2. apply tensor_id_id. Qed. Lemma diag_functor_fmonoidal_nat_right : preserves_tensor_nat_right (fmonoidal_preservestensordata diag_functor_fmonoidal_data). Proof. intros x1 x2 y f. apply pathsinv0. refine (_ @ naturality_inner_swap V f f (identity y) (identity y) @ _). - apply maponpaths. etrans. 2: { apply maponpaths. apply pathsinv0, (when_bifunctor_becomes_rightwhiskering V). } cbn ; apply maponpaths_2. apply pathsinv0, (when_bifunctor_becomes_rightwhiskering V). - rewrite <- (when_bifunctor_becomes_rightwhiskering V). apply maponpaths_2. apply maponpaths. apply tensor_id_id. Qed. Lemma diag_functor_fmonoidal_assoc : preserves_associativity (fmonoidal_preservestensordata diag_functor_fmonoidal_data). Proof. intros x y z. refine (_ @ inner_swap_hexagon'_3 V x y z @ _). - now rewrite <- (when_bifunctor_becomes_rightwhiskering V). - now rewrite <- (when_bifunctor_becomes_leftwhiskering V). Qed. Lemma diag_functor_fmonoidal_leftunitality : preserves_leftunitality (fmonoidal_preservestensordata diag_functor_fmonoidal_data) (fmonoidal_preservesunit diag_functor_fmonoidal_data). Proof. intro x. etrans. { apply maponpaths. apply (! precompose_inner_swap_with_lunitors_on_right V x x). } etrans. { rewrite ! assoc. do 2 apply maponpaths_2. rewrite assoc'. apply maponpaths. apply inner_swap_is_z_isomorphism. } rewrite id_right. etrans. { apply maponpaths_2. refine (! bifunctor_rightcomp V _ _ _ _ _ _ @ _). apply maponpaths. apply monoidal_leftunitorisolaw. } rewrite bifunctor_rightid. apply id_left. Qed. Lemma diag_functor_fmonoidal_rightunitality : preserves_rightunitality (fmonoidal_preservestensordata diag_functor_fmonoidal_data) (fmonoidal_preservesunit diag_functor_fmonoidal_data). Proof. intro x. cbn. unfold diag_preserves_unit. unfold diag_preserves_tensor_data. etrans. { apply maponpaths. apply pathsinv0. apply precompose_inner_swap_with_lunitors_and_runitor. } etrans. { rewrite ! assoc. do 2 apply maponpaths_2. rewrite assoc'. apply maponpaths. apply inner_swap_is_z_isomorphism. } rewrite id_right. etrans. { apply maponpaths_2. refine (! bifunctor_leftcomp V _ _ _ _ _ _ @ _). apply maponpaths. apply monoidal_leftunitorisolaw. } rewrite (bifunctor_leftid V). apply id_left. Qed. Lemma diag_functor_fmonoidal_laxlaws : fmonoidal_laxlaws diag_functor_fmonoidal_data. Proof. repeat split. - exact diag_functor_fmonoidal_nat_left. - exact diag_functor_fmonoidal_nat_right. - exact diag_functor_fmonoidal_assoc. - exact diag_functor_fmonoidal_leftunitality. - exact diag_functor_fmonoidal_rightunitality. Qed. Definition diag_functor_fmonoidal_lax : fmonoidal_lax V V diag. Proof. exists diag_functor_fmonoidal_data. exact diag_functor_fmonoidal_laxlaws. Defined. Definition diag_functor_is_strong_fmonoidal : fmonoidal_stronglaws (fmonoidal_preservestensordata diag_functor_fmonoidal_lax) (fmonoidal_preservesunit diag_functor_fmonoidal_lax). Proof. unfold fmonoidal_stronglaws. split. - intro ; intro. apply inner_swap_is_z_isomorphism. - refine (_ ,, _). split ; apply (monoidal_leftunitorisolaw V I_{V}). Defined. Definition diag_functor_fmonoidal : fmonoidal V V diag. Proof. exists diag_functor_fmonoidal_lax. exact diag_functor_is_strong_fmonoidal. Defined. Definition diag_functor_is_symmetric : is_symmetric_monoidal_functor V V diag_functor_fmonoidal. Proof. intro ; intro. apply pathsinv0. apply (inner_swap_commute_with_swap V). Defined. (* Definition diag_functor_lax_monoidal_functor : lax_monoidal_functor V V. Proof. use make_lax_monoidal_functor. - exact diag. - exact diag_preserves_tensor_data. - exact diag_preserves_unit. - . *) End DiagFunctorMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/DisplayedCartesianMonoidal.v000066400000000000000000001175101451125700300305730ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes 2022 *) (** ********************************************************** Contents : - constructs a displayed monoidal category that is displayed over a cartesian monoidal category with the displayed tensor and displayed unit coming from displayed binary products and displayed terminal objects ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Section FixADisplayedCategory. Context {C : category} (CP : BinProducts C) (terminal : Terminal C) (D : disp_cat C) (dP : dispBinProducts D CP) (dterminal : dispTerminal D terminal). Local Definition M : monoidal C := cartesian_monoidal C CP terminal. Definition DCM_tensor_data : disp_bifunctor_data M D D D. Proof. use make_disp_bifunctor_data. - intros c d cc dd. exact (dispBinProductObject D (CP c d) (dP c d cc dd)). - intros c d1 d2 g cc dd1 dd2 gg. exact (dispBinProductOfArrows _ _ _ (id_disp cc) gg). - intros c1 c2 d f cc1 cc2 dd ff. exact (dispBinProductOfArrows _ _ _ ff (id_disp dd)). Defined. Definition DCM_tensor_laws : is_disp_bifunctor M DCM_tensor_data. Proof. red; repeat split; red; intros. - cbn. unfold dispBinProductOfArrows. apply pathsinv0. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_left_disp. rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. rewrite transport_f_b. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_left_disp. rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. rewrite transport_f_b. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold dispBinProductOfArrows. apply pathsinv0. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_left_disp. rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. rewrite transport_f_b. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_left_disp. rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. rewrite transport_f_b. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold dispBinProductOfArrows. apply pathsinv0. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_right_disp. rewrite transport_b_b. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. etrans; [| apply maponpaths, maponpaths, pathsinv0, dispBinProductPr1Commutes]. apply transportf_comp_lemma. rewrite id_right_disp. rewrite transport_b_b. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. etrans; [| apply pathsinv0, dispBinProductPr1Commutes]. rewrite transport_b_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_right_disp. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. etrans; [| apply maponpaths, maponpaths, pathsinv0, dispBinProductPr2Commutes]. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. etrans; [| rewrite assoc_disp; apply idpath]. match goal with | [ |- _ = transportb _ _ (?auxH1 ;; gg2) ] => set (aux1 := auxH1) end. assert (H: aux1 = transportb (mor_disp (dispBinProductObject D (CP x y1) (dP x y1 xx yy1)) yy2) (BinProductPr2Commutes C x y2 (CP x y2) (BinProductObject C (CP x y1)) (BinProductPr1 C (CP x y1) · identity x) (BinProductPr2 C (CP x y1) · g1)) (dispBinProductPr2 D (CP x y1) (dP x y1 xx yy1) ;; gg1)). { apply dispBinProductPr2Commutes. } apply transportf_comp_lemma. unfold transportb in H. etrans; [| apply pathsinv0, (cancel_postcomposition_disp gg2 H)]. clear aux1 H. rewrite assoc_disp_var. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold dispBinProductOfArrows. apply pathsinv0. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite id_right_disp. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. etrans; [| apply maponpaths, maponpaths, pathsinv0, dispBinProductPr1Commutes]. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. etrans; [| rewrite assoc_disp; apply idpath]. unfold transportb. rewrite transport_f_f. match goal with | [ |- _ = transportf _ _ (?auxH1 ;; ff2) ] => set (aux1 := auxH1) end. assert (H: aux1 = transportb (mor_disp (dispBinProductObject D (CP x1 y) (dP x1 y xx1 yy)) xx2) (BinProductPr1Commutes C x2 y (CP x2 y) (BinProductObject C (CP x1 y)) (BinProductPr1 C (CP x1 y) · f1) (BinProductPr2 C (CP x1 y) · identity y)) (dispBinProductPr1 D (CP x1 y) (dP x1 y xx1 yy) ;; ff1)). { apply dispBinProductPr1Commutes. } apply transportf_comp_lemma. unfold transportb in H. etrans; [| apply pathsinv0, (cancel_postcomposition_disp ff2 H)]. clear aux1 H. rewrite assoc_disp_var. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. do 2 rewrite id_right_disp. rewrite transport_b_b. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. etrans; [| apply maponpaths, maponpaths, pathsinv0, dispBinProductPr2Commutes]. apply transportf_comp_lemma. rewrite transport_b_b. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. etrans; [| apply pathsinv0, dispBinProductPr2Commutes]. rewrite transport_b_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold dispfunctoronmorphisms1, dispfunctoronmorphisms2, disp_leftwhiskering_on_morphisms, disp_rightwhiskering_on_morphisms. cbn. do 2 rewrite dispBinProductOfArrows_comp. do 2 rewrite id_left_disp. do 2 rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. unfold dispBinProductOfArrows. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. etrans; [apply maponpaths, dispBinProductPr1Commutes |]. rewrite transport_f_b. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. etrans; [apply maponpaths, dispBinProductPr2Commutes |]. rewrite transport_f_b. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Definition DCM_tensor : disp_tensor D M. Proof. use make_disp_bifunctor. - exact DCM_tensor_data. - exact DCM_tensor_laws. Defined. Definition DCM_unit : D I_{ M} := dispTerminalObject _ dterminal. Definition DCM_leftunitor_data : disp_leftunitor_data DCM_tensor DCM_unit. Proof. red; intros. apply dispBinProductPr2. Defined. Definition DCM_leftunitorinv_data : disp_leftunitorinv_data DCM_tensor DCM_unit. Proof. red; intros. apply dispBinProductArrow. - apply dispTerminalArrow. - apply id_disp. Defined. Definition DCM_rightunitor_data : disp_rightunitor_data DCM_tensor DCM_unit. Proof. red; intros. apply dispBinProductPr1. Defined. Definition DCM_rightunitorinv_data : disp_rightunitorinv_data DCM_tensor DCM_unit. Proof. red; intros. apply dispBinProductArrow. - apply id_disp. - apply dispTerminalArrow. Defined. Definition DCM_associator_data : disp_associator_data DCM_tensor. Proof. red; intros. apply dispBinProductArrow. + use comp_disp. 2: {apply dispBinProductPr1. } apply dispBinProductPr1. + apply dispBinProductArrow. * use comp_disp. 2: {apply dispBinProductPr1. } apply dispBinProductPr2. * apply dispBinProductPr2. Defined. Definition DCM_associatorinv_data : disp_associatorinv_data DCM_tensor. Proof. red; intros. apply dispBinProductArrow. + apply dispBinProductArrow. * apply dispBinProductPr1. * use comp_disp. 2: {apply dispBinProductPr2. } apply dispBinProductPr1. + use comp_disp. 2: {apply dispBinProductPr2. } apply dispBinProductPr2. Defined. Definition DCM_data : disp_monoidal_data D M. Proof. exists DCM_tensor. exists DCM_unit. repeat split. - exact DCM_leftunitor_data. - exact DCM_leftunitorinv_data. - exact DCM_rightunitor_data. - exact DCM_rightunitorinv_data. - exact DCM_associator_data. - exact DCM_associatorinv_data. Defined. (* Set Default Goal Selector "1". *) Lemma DCM_leftunitor_law : disp_leftunitor_law DCM_leftunitor_data DCM_leftunitorinv_data. Proof. split; [| split]; try red; intros. - cbn. etrans. { apply dispBinProductOfArrowsPr2. } unfold DCM_leftunitor_data. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold DCM_leftunitorinv_data, DCM_leftunitor_data. rewrite dispBinProductPr2Commutes. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold DCM_leftunitorinv_data, DCM_leftunitor_data. apply pathsinv0. (* eapply (pathscomp0(b:=?[sh1])). Show sh1. *) etrans. 2: { simple refine (dispBinProduct_endo_is_identity _ _ _ _ _ _ ?[shH1] _ ?[shH2] _). shelve. (* creates one shelved goal *) + apply dispTerminalArrowEq. (* resolves the shelved goal *) + shelve. (* creates one shelved goal *) + rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite id_right_disp. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Unshelve. rewrite <- assoc. rewrite BinProductPr2Commutes. apply id_right. Qed. Lemma DCM_rightunitor_law : disp_rightunitor_law DCM_rightunitor_data DCM_rightunitorinv_data. Proof. split; [| split]; try red; intros. - cbn. unfold DCM_rightunitor_data. etrans; [apply dispBinProductOfArrowsPr1 |]. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold DCM_rightunitorinv_data, DCM_rightunitor_data. rewrite dispBinProductPr1Commutes. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - cbn. unfold DCM_rightunitorinv_data, DCM_rightunitor_data. apply pathsinv0. etrans. 2: { simple refine (dispBinProduct_endo_is_identity _ _ _ _ _ _ ?[shH1] _ ?[shH2] _). shelve. (* creates one shelved goal *) (* Show shH1. *) + rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite id_right_disp. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + shelve. (* creates one shelved goal *) + apply dispTerminalArrowEq. (* resolves second shelved goal *) (* Show shH1. *) } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Unshelve. rewrite <- assoc. rewrite BinProductPr1Commutes. apply id_right. Qed. (* Export Set Default Goal Selector "!". *) Lemma DCM_associator_law : disp_associator_law DCM_associator_data DCM_associatorinv_data. Proof. repeat split; try red; intros. - unfold DCM_associator_data. cbn. rewrite dispPostcompWithBinProductArrow. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. + rewrite id_right_disp. rewrite transport_b_b. etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. apply transportf_comp_lemma. rewrite id_right_disp. rewrite transport_b_b. etrans; [| apply pathsinv0, mor_disp_transportf_postwhisker]. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. * etrans; [ apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. rewrite id_right_disp. rewrite transport_b_b. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite dispBinProductPr1Commutes. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. rewrite id_right_disp. rewrite transport_b_b. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite transport_b_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * etrans; [ apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. rewrite transport_f_b. apply transportf_comp_lemma. rewrite dispBinProductOfArrowsPr2. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductPr2Commutes. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite transport_b_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - unfold DCM_associator_data. cbn. rewrite dispPostcompWithBinProductArrow. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. + rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. etrans; [ apply mor_disp_transportf_postwhisker |]. rewrite dispBinProductPr1Commutes. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite transport_b_f. etrans. 2: { rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. rewrite transport_f_f. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. rewrite transport_f_b. apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [ apply mor_disp_transportf_postwhisker |]. rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. * rewrite id_right_disp. rewrite transport_f_b. etrans; [ apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite dispBinProductPr1Commutes. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite transport_b_f. apply transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. rewrite id_right_disp. rewrite transport_b_b. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_prewhisker]. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * etrans; [ apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. rewrite transport_f_b. apply transportf_comp_lemma. rewrite id_left_disp. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite id_right_disp. rewrite transport_f_b. rewrite dispBinProductPr2Commutes. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - unfold DCM_associator_data. cbn. rewrite dispPostcompWithBinProductArrow. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. + rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. etrans; [ apply mor_disp_transportf_postwhisker |]. rewrite dispBinProductPr1Commutes. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite transport_b_f. etrans. 2: { rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. rewrite transport_f_f. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite id_right_disp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply idpath. } apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite id_right_disp. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. * etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr1. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_prewhisker]. rewrite transport_f_f. apply transportf_comp_lemma. etrans. 2: { rewrite assoc_disp. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply idpath. } apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. apply maponpaths. apply pathsinv0, mor_disp_transportf_postwhisker. } rewrite transport_b_f. etrans. 2: { rewrite assoc_disp_var. rewrite dispBinProductOfArrowsPr2. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. rewrite transport_f_f. rewrite transport_f_b. apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp_var. do 2 rewrite dispBinProductOfArrowsPr2. rewrite transport_f_b. rewrite id_right_disp. rewrite transport_f_b. apply transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite id_right_disp. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_prewhisker]. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - unfold DCM_associator_data, DCM_associatorinv_data. cbn. etrans. { apply pathsinv0. simple refine (dispBinProduct_endo_is_identity _ _ _ _ _ _ ?[shH1] _ ?[shH2] _). + change (αinv^{M}_{ x, y, z} · α^{M}_{ x, y, z} · BinProductPr1 C (CP x (y ⊗_{M} z)) = BinProductPr1 C (CP x (y ⊗_{M} z))). (** it thus appears as intermediary result in Lemma [CartesianMonoidalCategoriesWhiskered.associator_law_from_binprod], but we reprove it here, analogously with the three other goals of this kind to come *) cbn. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite assoc. rewrite BinProductPr1Commutes. apply BinProductPr1Commutes. + rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite dispBinProductPr1Commutes. rewrite transport_f_f. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + change( αinv^{M}_{ x, y, z} · α^{M}_{ x, y, z} · BinProductPr2 C (CP x (y ⊗_{M} z)) = BinProductPr2 C (CP x (y ⊗_{M} z))). cbn. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite precompWithBinProductArrow. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. apply pathsinv0, BinProductArrowUnique; apply idpath. + rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. rewrite dispPrecompWithBinProductArrow. apply transportf_comp_lemma. apply dispBinProductArrowUnique. * etrans; [apply mor_disp_transportf_postwhisker |]. apply transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductPr1Commutes. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite dispBinProductPr2Commutes. rewrite transport_b_f. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * etrans; [apply mor_disp_transportf_postwhisker |]. apply transportf_comp_lemma. rewrite dispBinProductPr2Commutes. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - unfold DCM_associator_data, DCM_associatorinv_data. cbn. etrans. { apply pathsinv0. simple refine (dispBinProduct_endo_is_identity _ _ _ _ _ _ ?[shH1] _ ?[shH2] _). + change (α^{M}_{ x, y, z} · αinv^{M}_{ x, y, z} · BinProductPr1 C (CP (x ⊗_{M} y) z) = BinProductPr1 C (CP (x ⊗_{M} y) z)). cbn. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite precompWithBinProductArrow. apply pathsinv0, BinProductArrowUnique. * apply pathsinv0, BinProductPr1Commutes. * rewrite assoc. rewrite BinProductPr2Commutes. apply pathsinv0, BinProductPr1Commutes. + rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. rewrite dispPrecompWithBinProductArrow. rewrite transport_f_b. apply transportf_comp_lemma. apply dispBinProductArrowUnique. * etrans; [apply mor_disp_transportf_postwhisker |]. apply transportf_comp_lemma. rewrite dispBinProductPr1Commutes. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * etrans; [apply mor_disp_transportf_postwhisker |]. apply transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductPr2Commutes. etrans; [| apply maponpaths, pathsinv0, mor_disp_transportf_postwhisker]. rewrite dispBinProductPr1Commutes. rewrite transport_b_f. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + change (α^{M}_{ x, y, z} · αinv^{M}_{ x, y, z} · BinProductPr2 C (CP (x ⊗_{M} y) z) = BinProductPr2 C (CP (x ⊗_{M} y) z)). cbn. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite assoc. rewrite BinProductPr2Commutes. apply BinProductPr2Commutes. + rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. etrans; [apply maponpaths, mor_disp_transportf_prewhisker |]. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. rewrite assoc_disp. rewrite dispBinProductPr2Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite dispBinProductPr2Commutes. rewrite transport_f_f. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Lemma DCM_triangle_identity : disp_triangle_identity DCM_leftunitor_data DCM_rightunitor_data DCM_associator_data. Proof. red; intros. cbn. unfold DCM_associator_data. rewrite dispPostcompWithBinProductArrow. apply pathsinv0, transportf_comp_lemma. apply dispBinProductArrowUnique. - etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, dispBinProductOfArrowsPr1]. unfold DCM_rightunitor_data. rewrite assoc_disp_var. rewrite id_right_disp. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, mor_disp_transportf_prewhisker]. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, dispBinProductOfArrowsPr2]. rewrite id_right_disp. unfold DCM_leftunitor_data. apply pathsinv0, transportf_comp_lemma. rewrite dispBinProductPr2Commutes. rewrite transport_f_b. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Lemma DCM_pentagon_identity : disp_pentagon_identity DCM_associator_data. Proof. red; intros. unfold DCM_associator_data. cbn. etrans; [apply assoc_disp_var |]. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite dispPostcompWithBinProductArrow. rewrite dispPrecompWithBinProductArrow. unfold transportb. apply pathsinv0, mor_disp_transportf_prewhisker. } etrans; [| apply maponpaths, pathsinv0, dispPrecompWithBinProductArrow]. rewrite transport_f_b. apply pathsinv0, transportf_comp_lemma. etrans; [| apply pathsinv0, dispPrecompWithBinProductArrow]. apply transportf_comp_lemma. apply dispBinProductArrowUnique. - etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite dispBinProductPr1Commutes. apply maponpaths. rewrite id_right_disp. unfold transportb. rewrite mor_disp_transportf_prewhisker. apply maponpaths. rewrite assoc_disp. apply maponpaths. rewrite dispBinProductOfArrowsPr1. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply maponpaths. rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite assoc_disp. rewrite transport_f_f. rewrite transport_f_b. apply idpath. } rewrite transport_b_f. rewrite transport_f_b. do 2 rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite assoc_disp. apply maponpaths. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply idpath. } rewrite transport_b_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. - etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite dispBinProductPr2Commutes. apply maponpaths. rewrite mor_disp_transportf_prewhisker. apply maponpaths. apply pathsinv0, dispPrecompWithBinProductArrow. } rewrite transport_b_f. rewrite transport_f_b. apply transportf_comp_lemma. apply dispBinProductArrowUnique. + etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite dispPrecompWithBinProductArrow. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply maponpaths. rewrite dispBinProductPr1Commutes. apply maponpaths. rewrite assoc_disp. apply maponpaths. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply idpath. } do 2 rewrite transport_f_b. rewrite transport_f_f. apply pathsinv0, transportf_comp_lemma. etrans. 2: { apply maponpaths. rewrite assoc_disp. apply maponpaths. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply idpath. } etrans. 2: { rewrite transport_b_f. rewrite mor_disp_transportf_prewhisker. apply maponpaths. rewrite assoc_disp. apply maponpaths. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite assoc_disp_var. rewrite transport_f_f. apply maponpaths. rewrite mor_disp_transportf_postwhisker. apply maponpaths. rewrite assoc_disp_var. apply maponpaths. apply maponpaths. rewrite assoc_disp. rewrite dispBinProductPr2Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite dispBinProductPr1Commutes. rewrite transport_f_f. rewrite transport_f_b. apply idpath. } rewrite transport_f_b. rewrite mor_disp_transportf_prewhisker. do 4 rewrite transport_f_f. apply transportf_comp_lemma. rewrite assoc_disp. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. + etrans; [apply mor_disp_transportf_postwhisker |]. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite dispPrecompWithBinProductArrow. unfold transportb. rewrite mor_disp_transportf_postwhisker. apply maponpaths. rewrite dispBinProductPr2Commutes. apply maponpaths. rewrite dispBinProductPr2Commutes. apply idpath. } do 2 rewrite transport_f_b. apply transportf_comp_lemma. apply dispBinProductArrowUnique. * rewrite mor_disp_transportf_postwhisker. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite assoc_disp_var. apply maponpaths. apply maponpaths. rewrite assoc_disp_var. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite assoc_disp. rewrite dispBinProductPr1Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. do 2 rewrite transport_f_f. apply idpath. } etrans. 2: { rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply idpath. } apply transportf_comp_lemma. etrans. 2: { apply maponpaths. rewrite assoc_disp_var. apply idpath. } etrans. 2: { rewrite mor_disp_transportf_prewhisker. apply maponpaths. rewrite assoc_disp. rewrite dispBinProductOfArrowsPr1. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. apply maponpaths. rewrite assoc_disp_var. do 2 apply maponpaths. rewrite assoc_disp. rewrite dispBinProductPr2Commutes. unfold transportb. rewrite mor_disp_transportf_postwhisker. rewrite transport_f_f. rewrite dispBinProductPr2Commutes. rewrite transport_f_b. apply idpath. } rewrite mor_disp_transportf_prewhisker. do 3 rewrite transport_f_f. apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. * rewrite mor_disp_transportf_postwhisker. apply pathsinv0, transportf_comp_lemma. etrans. 2: { rewrite assoc_disp_var. apply maponpaths. apply maponpaths. rewrite assoc_disp_var. rewrite dispBinProductPr2Commutes. unfold transportb. rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. rewrite dispBinProductPr2Commutes. rewrite transport_f_b. apply idpath. } rewrite mor_disp_transportf_prewhisker. rewrite transport_f_f. apply transportf_comp_lemma. etrans. 2: { rewrite dispBinProductOfArrowsPr2. rewrite id_right_disp. rewrite transport_b_b. apply idpath. } apply transportf_comp_lemma. apply transportf_comp_lemma_hset; try apply homset_property; apply idpath. Qed. Lemma DCM_laws : disp_monoidal_laws DCM_data. Proof. exists DCM_leftunitor_law. exists DCM_rightunitor_law. exists DCM_associator_law. exists DCM_triangle_identity. exact DCM_pentagon_identity. Qed. Definition displayedcartesianmonoidalcat: disp_monoidal D M := DCM_data ,, DCM_laws. End FixADisplayedCategory. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/EndofunctorsMonoidalElementary.v000066400000000000000000000071261451125700300315230ustar00rootroot00000000000000(** an elementary construction of the monoidal category of endofunctors of a given category a general construction is available for bicategories and a fixed object therein author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Local Open Scope cat. Section FixACategory. Import MonoidalNotations. Context (C : category). Definition monendocat_tensor_data : bifunctor_data [C, C] [C, C] [C, C]. Proof. use make_bifunctor_data. - intros a b. exact (functor_compose a b). - intros a b1 b2 β. exact (lwhisker_CAT _ β). - intros b a1 a2 α. exact (rwhisker_CAT _ α). Defined. (* (** we explicitly do not opacify the following definition: *) *) Definition monendocat_tensor_laws : is_bifunctor monendocat_tensor_data. Proof. split5. - intro; apply lwhisker_id2_CAT. - intro; intros; apply id2_rwhisker_CAT. - intro; intros; apply pathsinv0, lwhisker_vcomp_CAT. - intro; intros; apply pathsinv0, rwhisker_vcomp_CAT. - intro; intros; apply vcomp_whisker_CAT. Qed. (* Defined. *) Definition monendocat_tensor : bifunctor [C, C] [C, C] [C, C] := make_bifunctor monendocat_tensor_data monendocat_tensor_laws. Definition monendocat_monoidal_data : monoidal_data [C, C]. Proof. use make_monoidal_data. - exact monendocat_tensor. - exact (id1_CAT C). - intro; apply lunitor_CAT. - intro; apply linvunitor_CAT. - intro; apply runitor_CAT. - intro; apply rinvunitor_CAT. - intro; apply rassociator_CAT. - intro; apply lassociator_CAT. Defined. Local Definition MD := monendocat_monoidal_data. Local Lemma monendocat_leftunitor_law: leftunitor_law lu_{MD} luinv_{MD}. Proof. split. - intro; intros; apply vcomp_lunitor_CAT. - intro; apply lunitor_CAT_pointwise_is_z_iso. Qed. Local Lemma monendocat_rightunitor_law : rightunitor_law ru_{MD} ruinv_{MD}. Proof. split. - intro; intros; apply vcomp_runitor_CAT. - intro; apply runitor_CAT_pointwise_is_z_iso. Qed. Local Lemma monendocat_associator_law : associator_law α_{MD} αinv_{MD}. Proof. split4. - intro; intros; apply lwhisker_lwhisker_rassociator_CAT. - intro; intros; apply pathsinv0, rwhisker_rwhisker_alt_CAT. - intro; intros; apply rwhisker_lwhisker_rassociator_CAT. - split. + apply (pr22 (lassociator_CAT_pointwise_is_z_iso _ _ _)). + apply lassociator_CAT_pointwise_is_z_iso. Qed. Local Lemma monendocat_triangle_identity : triangle_identity lu_{MD} ru_{MD} α_{MD}. Proof. intro; intros. apply lunitor_lwhisker_CAT. Qed. Local Lemma monendocat_pentagon_identity : pentagon_identity α_{MD}. Proof. intro; intros. apply rassociator_rassociator_CAT. Qed. Definition monendocat_monoidal : monoidal [C, C]. Proof. exists monendocat_monoidal_data. exists monendocat_tensor_laws. exists monendocat_leftunitor_law. exists monendocat_rightunitor_law. exists monendocat_associator_law. exists monendocat_triangle_identity. exact monendocat_pentagon_identity. Defined. End FixACategory. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/Fullsub.v000066400000000000000000000074141451125700300247550ustar00rootroot00000000000000(********************************************************************************* Full subcategories of monoidal categories Given a full subcategory of a monoidal category, that is closed under the unit and the tensor product, the subcategory inherits the monoidal structure [disp_monoidal_fullsub]. Furthermore, if the monoidal category is carries a braiding (or symmetric braiding), it also restricts to the full sub [disp_braiding_fullsub, disp_symmetric_fullsub] *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Local Open Scope cat. Local Open Scope mor_disp_scope. Import BifunctorNotations. Import MonoidalNotations. Section FullSubOfMonoidal. Context {C : category} (M : monoidal C) (P : C → UU) (P_u : P I_{M}) (P_t : ∏ x y : C, P x → P y → P (x ⊗_{ M} y)). Definition disp_monoidal_tensor_data_fullsub : disp_bifunctor_data M (disp_full_sub C P) (disp_full_sub C P) (disp_full_sub C P). Proof. simple refine (_ ,, _). - exact P_t. - split ; intro ; intros ; exact tt. Defined. Definition disp_monoidal_tensor_fullsub : disp_tensor (disp_full_sub C P) M. Proof. use make_disp_bifunctor_locally_prop. - apply disp_full_sub_locally_prop. - exact disp_monoidal_tensor_data_fullsub. Defined. Definition disp_monoidal_data_fullsub : disp_monoidal_data (disp_full_sub C P) M. Proof. unfold disp_monoidal_data. exists disp_monoidal_tensor_fullsub. exists P_u. repeat (use tpair) ; intro ; intros ; exact tt. Defined. Definition disp_monoidal_fullsub : disp_monoidal (disp_full_sub C P) M. Proof. use make_disp_monoidal_locally_prop. - apply disp_full_sub_locally_prop. - exact disp_monoidal_data_fullsub. Defined. Definition monoidal_fullsubcat : monoidal (full_subcat C P) := total_monoidal disp_monoidal_fullsub. Definition disp_braiding_fullsub (B : braiding M) : disp_braiding disp_monoidal_fullsub B. Proof. simple refine (_ ,, _ ,, _). - intro ; intros ; exact tt. - intro ; intros ; exact tt. - abstract (repeat split ; try (intro ; intros) ; apply isapropunit). Defined. Definition braided_monoidal_fullsubcat (B : braiding M) : braiding monoidal_fullsubcat := total_braiding disp_monoidal_fullsub (disp_braiding_fullsub B). Definition disp_symmetric_fullsub (B : symmetric M) : disp_symmetric disp_monoidal_fullsub B. Proof. simple refine (_ ,, _). - intro ; intros ; exact tt. - abstract (repeat split ; try (intro ; intros) ; apply isapropunit). Defined. Definition symmetric_monoidal_fullsubcat (B : symmetric M) : symmetric monoidal_fullsubcat := total_symmetric disp_monoidal_fullsub (disp_symmetric_fullsub B). End FullSubOfMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/LiftPoset.v000066400000000000000000000311731451125700300252510ustar00rootroot00000000000000(***************************************************************** Lifting posets as a monoidal comonad We show that the lifting operation on posets (i.e., adding a new bottom element) gives rise to a monoidal comonad on the monoidal category of pointed posets with the smash product. Content 1. Lifting as a functor 2. Extraction and duplication 3. The comonad 4. Lifting is symmetric monoidal 5. The natural transformations are monoidal 6. Every object has a natural comonoid structure *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.PointedPosetStrict. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.SmashProductMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.PosetsMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.CategoryOfPosets. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Local Open Scope cat. (** 1. Lifting as a functor *) Definition lift_poset_functor_data : functor_data category_of_pointed_poset_strict category_of_pointed_poset_strict. Proof. use make_functor_data. - exact (λ X, _ ,, lift_pointed_PartialOrder (pr12 X)). - exact (λ X Y f, _ ,, lift_strict_and_monotone_map (pr12 f)). Defined. Proposition lift_poset_functor_laws : is_functor lift_poset_functor_data. Proof. split. - intros X. use eq_mor_hset_struct ; cbn. intro x. induction x as [ x | ] ; cbn. + apply idpath. + apply idpath. - intros X Y Z f g. use eq_mor_hset_struct ; cbn. intro x. induction x as [ x | ] ; cbn. + apply idpath. + apply idpath. Qed. Definition lift_poset_functor : category_of_pointed_poset_strict ⟶ category_of_pointed_poset_strict. Proof. use make_functor. - exact lift_poset_functor_data. - exact lift_poset_functor_laws. Defined. (** 2. Extraction and duplication *) Definition lift_poset_dupl : lift_poset_functor ⟹ lift_poset_functor ∙ lift_poset_functor. Proof. use make_nat_trans. - exact (λ X, _ ,, is_strict_and_monotone_lift_pointed_PartialOrder_dupl _). - abstract (intros X Y f ; use eq_mor_hset_struct ; cbn ; intros [ x | [] ] ; cbn ; apply idpath). Defined. Definition lift_poset_extract : lift_poset_functor ⟹ functor_identity _. Proof. use make_nat_trans. - exact (λ X, _ ,, is_strict_and_monotone_lift_pointed_PartialOrder_extract _). - abstract (intros X Y f ; use eq_mor_hset_struct ; cbn ; intros [ x | [] ] ; [ apply idpath | ] ; cbn ; refine (!_) ; apply f). Defined. (** 3. The comonad *) Proposition lift_poset_comonad_laws : disp_Comonad_laws (lift_poset_dupl,, lift_poset_extract). Proof. repeat split. - intro X. use eq_mor_hset_struct. intros [ x | [] ] ; cbn. + apply idpath. + apply idpath. - intro X. use eq_mor_hset_struct. intros [ x | [] ] ; cbn. + apply idpath. + apply idpath. - intro X. use eq_mor_hset_struct. intros [ x | [] ] ; cbn. + apply idpath. + apply idpath. Qed. Definition lift_poset_comonad : Comonad pointed_poset_sym_mon_closed_cat. Proof. refine (lift_poset_functor ,, ((lift_poset_dupl ,, lift_poset_extract) ,, _)). exact lift_poset_comonad_laws. Defined. (** 4. Lifting is symmetric monoidal *) Definition lift_poset_comonad_smash (X Y : pointed_poset_sym_mon_closed_cat) : lift_poset_comonad X ∧* lift_poset_comonad Y --> lift_poset_comonad (X ∧* Y). Proof. simple refine (_ ,, _). - use map_from_smash. + intros x y. induction x as [ x | ] ; induction y as [ y | ]. * refine (inl _). use setquotpr. exact (x ,, y). * exact (inr tt). * exact (inr tt). * exact (inr tt). + abstract (intros [ y₁ | ] [ y₂ | ] ; cbn ; apply idpath). + abstract (intros [ x | ] [ y | ] ; cbn ; apply idpath). + abstract (intros [ x₁ | ] [ x₂ | ] ; cbn ; apply idpath). - use hset_struct_with_smash_map_from_smash. split. + abstract (intros xy₁ xy₂ p ; induction xy₁ as [ x₁ y₁ ] ; induction xy₂ as [ x₂ y₂ ] ; induction x₁ as [ x₁ | ], y₁ as [ y₁ | ], x₂ as [ x₂ | ], y₂ as [ y₂ | ] ; cbn in * ; try (apply tt) ; try (apply p) ; apply hinhpr ; use inr ; exact p ). + abstract (cbn ; apply idpath). Defined. Definition lax_monoidal_data_lift_poset_comonad : fmonoidal_data pointed_poset_sym_mon_closed_cat pointed_poset_sym_mon_closed_cat lift_poset_comonad. Proof. split. - exact lift_poset_comonad_smash. - simple refine (_ ,, _). + exact (λ b, if b then inl true else inr tt). + split. * abstract (intros b₁ b₂ p ; cbn ; induction b₁, b₂ ; cbn in * ; try (exact tt) ; exact p). * apply idpath. Defined. Proposition lax_monoidal_lift_poset_comonad_laws : fmonoidal_laxlaws lax_monoidal_data_lift_poset_comonad. Proof. repeat split. - intros X Y₁ Y₂ g. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ] ; apply idpath. - intros X₁ X₂ Y f. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ] ; apply idpath. - intros X Y Z. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ xy z ]. revert xy. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ] ; induction z as [ z | ] ; apply idpath. - intros X. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. cbn in xy. induction xy as [ b x ]. induction b ; induction x as [ x | [] ] ; cbn ; apply idpath. - intros X. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. cbn in xy. induction xy as [ x b ]. induction b ; induction x as [ x | [] ] ; apply idpath. Qed. Definition lax_monoidal_lift_poset_comonad : fmonoidal_lax pointed_poset_sym_mon_closed_cat pointed_poset_sym_mon_closed_cat lift_poset_comonad. Proof. simple refine (_ ,, _). - exact lax_monoidal_data_lift_poset_comonad. - exact lax_monoidal_lift_poset_comonad_laws. Defined. Proposition is_symmetric_lift_poset_comonad : is_symmetric_monoidal_functor (pr21 pointed_poset_sym_mon_closed_cat) (pr21 pointed_poset_sym_mon_closed_cat) lax_monoidal_lift_poset_comonad. Proof. intros X Y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ] ; apply idpath. Qed. (** 5. The natural transformations are monoidal *) Proposition is_mon_nat_trans_lift_poset_extract : is_mon_nat_trans lax_monoidal_lift_poset_comonad (identity_fmonoidal _) lift_poset_extract. Proof. split. - intros X Y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ]. + use iscompsetquotpr ; cbn. apply hinhpr. apply inl. apply idpath. + use iscompsetquotpr ; cbn. apply hinhpr. apply inr. split. * apply inl. apply idpath. * apply inr. apply idpath. + use iscompsetquotpr ; cbn. apply hinhpr. apply inr. split. * apply inl. apply idpath. * apply inl. apply idpath. + use iscompsetquotpr ; cbn. apply hinhpr. apply inr. split. * apply inl. apply idpath. * apply inr. apply idpath. - use eq_mor_hset_struct. intro x. induction x ; cbn ; apply idpath. Qed. Proposition is_mon_nat_trans_lift_poset_dupl : is_mon_nat_trans lax_monoidal_lift_poset_comonad (comp_fmonoidal_lax lax_monoidal_lift_poset_comonad lax_monoidal_lift_poset_comonad) lift_poset_dupl. Proof. split. - intros X Y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ] ; induction y as [ y | ]. + apply idpath. + apply idpath. + apply idpath. + apply idpath. - use eq_mor_hset_struct. intro x. induction x ; cbn ; apply idpath. Qed. Definition lift_poset_symmetric_monoidal_comonad : symmetric_monoidal_comonad pointed_poset_sym_mon_closed_cat. Proof. use make_symmetric_monoidal_comonad. - exact lift_poset_comonad. - exact lax_monoidal_lift_poset_comonad. - exact is_symmetric_lift_poset_comonad. - apply is_mon_nat_trans_lift_poset_dupl. - apply is_mon_nat_trans_lift_poset_extract. Defined. (** 6. Every object has a natural comonoid structure *) Definition lift_poset_comult_map {X : pointed_poset_sym_mon_closed_cat} (x : pr11 X ⨿ unit) : pr11 (lift_poset_comonad X ∧* lift_poset_comonad X). Proof. induction x as [ x | ]. - exact (setquotpr _ (inl x ,, inl x)). - exact (setquotpr _ (inr tt ,, inr tt)). Defined. Proposition is_strict_and_monotone_lift_poset_comult_map (X : pointed_poset_sym_mon_closed_cat) : is_strict_and_monotone (pr2 (lift_poset_comonad X)) (pr2 (lift_poset_comonad X ∧* lift_poset_comonad X)) (@lift_poset_comult_map X). Proof. split. - intros x₁ x₂ p. induction x₁ as [ x₁ | ], x₂ as [ x₂ | ] ; cbn in *. + refine (hinhpr (inr _)). exact (p ,, p). + exact (fromempty p). + refine (hinhpr (inr _)). exact (tt ,, tt). + refine (hinhpr (inr _)). exact (tt ,, tt). - apply idpath. Qed. Definition lift_poset_comult : lift_poset_functor ⟹ bindelta_pair_functor lift_poset_functor lift_poset_functor ∙ bifunctor_to_functorfromproductcat pointed_poset_sym_mon_closed_cat. Proof. use make_nat_trans. - refine (λ X, lift_poset_comult_map ,, _). exact (is_strict_and_monotone_lift_poset_comult_map X). - abstract (intros X Y f ; use eq_mor_hset_struct ; intro x ; induction x as [ x | ] ; apply idpath). Defined. Definition lift_poset_counit : lift_poset_functor ⟹ constant_functor _ _ (monoidal_unit pointed_poset_sym_mon_closed_cat). Proof. use make_nat_trans. - simple refine (λ X, _ ,, _). + intro x. induction x as [ x | ]. * exact true. * exact false. + split. * abstract (intros x₁ x₂ p ; induction x₁ as [ x₁ | ], x₂ as [ x₂ | ] ; try (exact tt) ; cbn in * ; exact p). * abstract (cbn ; apply idpath). - abstract (intros X Y f ; use eq_mor_hset_struct ; intro x ; induction x as [ x | ] ; cbn ; apply idpath). Defined. Definition lift_commutative_comonoid (X : pointed_poset_sym_mon_closed_cat) : commutative_comonoid pointed_poset_sym_mon_closed_cat. Proof. use make_commutative_comonoid. - exact (lift_poset_functor X). - exact (lift_poset_comult X). - exact (lift_poset_counit X). - abstract (use eq_mor_hset_struct ; intro x ; cbn in x ; induction x as [ x | [ ] ] ; apply idpath). - abstract (use eq_mor_hset_struct ; intro x ; cbn in x ; induction x as [ x | [ ] ] ; apply idpath). - abstract (use eq_mor_hset_struct ; intro x ; cbn in x ; induction x as [ x | [ ] ] ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/MonadsAsMonoidsElementary.v000066400000000000000000000051031451125700300304160ustar00rootroot00000000000000(** In this file, we show how any monoid in the monoidal category of endofunctors is a monad - here w.r.t. the elementary definition of that monoidal category the bicategorical variant is found in [MonadsAsMonoidsWhiskered] we also show the direction from monads to monoids *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Section FixACategory. Context {C : category}. Section MonoidToMonad. Context (M : category_of_monoids_in_monoidal_cat (monendocat_monoidal C)). Let x := monoid_carrier _ M. Let η := monoid_unit _ M. Let μ := monoid_multiplication _ M. Definition monoid_to_disp_Monad_data_CAT : disp_Monad_data x := μ ,, η. Lemma monoid_to_disp_Monad_laws_CAT : disp_Monad_laws monoid_to_disp_Monad_data_CAT. Proof. repeat split. - intro c. set (t := monoid_right_unit_law _ M). exact (toforallpaths _ _ _ (base_paths _ _ t) c). - intro c. set (t := monoid_left_unit_law _ M). exact (toforallpaths _ _ _ (base_paths _ _ t) c). - intro c. set (t := monoid_assoc_law _ M). refine (! (toforallpaths _ _ _ (base_paths _ _ t) c) @ _). etrans. 1: apply assoc'. apply id_left. Qed. Definition monoid_to_monad_CAT : Monad C := _ ,, _ ,, monoid_to_disp_Monad_laws_CAT. End MonoidToMonad. Section MonadToMonoid. Context (M : Monad C). Definition monad_to_monoid_CAT_data : monoid_data (monendocat_monoidal C) (M : C ⟶ C) := μ M ,, η M. Lemma monad_to_monoid_CAT_laws : monoid_laws (monendocat_monoidal C) monad_to_monoid_CAT_data. Proof. split3; apply (nat_trans_eq C); intro c; cbn. - apply Monad_law2. - apply Monad_law1. - rewrite id_left. apply pathsinv0, Monad_law3. Qed. Definition monad_to_monoid_CAT_disp : monoid (monendocat_monoidal C) (M : C ⟶ C) := monad_to_monoid_CAT_data,,monad_to_monoid_CAT_laws. Definition monad_to_monoid_CAT : category_of_monoids_in_monoidal_cat (monendocat_monoidal C) := _,,monad_to_monoid_CAT_disp. End MonadToMonoid. End FixACategory. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/MonoidalDialgebras.v000066400000000000000000000731751451125700300270700ustar00rootroot00000000000000(** ********************************************************** Ralph Matthes August 2022 *) (** ********************************************************** Contents : - constructs a displayed monoidal category that is displayed over the dialgebras, its total category is called the monoidal dialgebras ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalSections. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalFunctorLifting. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope mor_disp_scope. Section FixTwoMonoidalFunctors. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Context {A B : category} {V : monoidal A} {W : monoidal B} {F G : A ⟶ B} (Fm : fmonoidal V W F) (Gm : fmonoidal_lax V W G). (** it is expected that [Fm] could just be an oplax monoidal functor *) Local Definition base_disp : disp_cat A := dialgebra_disp_cat F G. Local Lemma base_disp_cells_isaprop (x y : A) (f : A⟦x, y⟧) (xx : base_disp x) (yy : base_disp y): isaprop (xx -->[f] yy). Proof. intros Hyp Hyp'. apply B. Qed. Definition dialgebra_disp_tensor_op {a a' : A} (f : base_disp a) (f' : base_disp a') : base_disp (a ⊗_{V} a'). Proof. refine (_ · fmonoidal_preservestensordata Gm a a'). refine (pr1 (fmonoidal_preservestensorstrongly Fm a a') · _). exact (f ⊗^{W} f'). Defined. Lemma dialgebra_disp_tensor_comp_aux1 {a a2 a2' : A} {h': a2 --> a2'} (f : base_disp a) (f' : base_disp a2) (g' : base_disp a2') : f'-->[h'] g' -> dialgebra_disp_tensor_op f f' -->[a ⊗^{V}_{l} h'] dialgebra_disp_tensor_op f g'. Proof. intro Hyp'. cbn in Hyp'. cbn. unfold dialgebra_disp_tensor_op. etrans. { repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, fmonoidal_preservestensornatleft. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { rewrite (bifunctor_equalwhiskers W). unfold functoronmorphisms2. repeat rewrite assoc'. do 2 apply maponpaths. apply (bifunctor_equalwhiskers W). } rewrite (bifunctor_equalwhiskers W). unfold functoronmorphisms2. repeat rewrite assoc. apply cancel_postcomposition. assert (aux := fmonoidal_preservestensornatleft Fm a a2 a2' h'). apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm a a2)) in aux. rewrite assoc in aux. apply pathsinv0 in aux. apply (z_iso_inv_on_left _ _ _ _ (_,,fmonoidal_preservestensorstrongly Fm a a2')) in aux. etrans. 2: { apply cancel_postcomposition. apply aux. } clear aux. do 2 rewrite assoc'. apply maponpaths. do 2 rewrite <- (bifunctor_leftcomp W). apply maponpaths. exact Hyp'. Qed. Lemma dialgebra_disp_tensor_comp_aux2 {a1 a1' a : A} {h: a1 --> a1'} (f : base_disp a1) (f' : base_disp a) (g : base_disp a1') : f -->[h] g -> dialgebra_disp_tensor_op f f' -->[h ⊗^{V}_{r} a] dialgebra_disp_tensor_op g f'. Proof. intro Hyp. cbn in Hyp. cbn. unfold dialgebra_disp_tensor_op. etrans. { repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, fmonoidal_preservestensornatright. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { unfold functoronmorphisms1. repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, (bifunctor_equalwhiskers W). } unfold functoronmorphisms1. repeat rewrite assoc. apply cancel_postcomposition. assert (aux := fmonoidal_preservestensornatright Fm _ _ a h). apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm a1 a)) in aux. rewrite assoc in aux. apply pathsinv0 in aux. apply (z_iso_inv_on_left _ _ _ _ (_,,fmonoidal_preservestensorstrongly Fm a1' a)) in aux. etrans. 2: { apply cancel_postcomposition. apply aux. } clear aux. do 2 rewrite assoc'. apply maponpaths. do 2 rewrite <- (bifunctor_rightcomp W). apply maponpaths. exact Hyp. Qed. (** the following "morally right" formulation does not follow the division into the two whiskerings Lemma dialgebra_disp_tensor_comp_aux {a1 a2 a1' a2' : A} {h: a1 --> a1'} {h': a2 --> a2'} (f : base_disp a1) (f' : base_disp a2) (g : base_disp a1') (g' : base_disp a2') : f -->[h] g -> f'-->[h'] g' -> dialgebra_disp_tensor_op f f' -->[h ⊗^{V} h'] dialgebra_disp_tensor_op g g'. Proof. intros Hyp Hyp'. hnf in Hyp, Hyp' |- *. unfold dialgebra_disp_tensor_op. *) Definition dialgebra_disp_tensor : disp_tensor base_disp V. Proof. use make_disp_bifunctor_locally_prop. - apply is_locally_propositional_dialgebra_disp_cat. - use make_disp_bifunctor_data. + intros a a' f f'. exact (dialgebra_disp_tensor_op f f'). + intros; apply dialgebra_disp_tensor_comp_aux1; assumption. + intros; apply dialgebra_disp_tensor_comp_aux2; assumption. Defined. Definition dialgebra_disp_unit: base_disp I_{ V} := pr1 (fmonoidal_preservesunitstrongly Fm) · fmonoidal_preservesunit Gm. Lemma dialgebra_disp_leftunitor_data : disp_leftunitor_data dialgebra_disp_tensor dialgebra_disp_unit. Proof. intros a f. cbn. unfold dialgebra_disp_unit, dialgebra_disp_tensor_op. rewrite (bifunctor_equalwhiskers W). unfold functoronmorphisms2. rewrite bifunctor_rightcomp. set (aux1 := fmonoidal_preservesleftunitality Gm a). etrans. { repeat rewrite assoc'. do 3 apply maponpaths. rewrite assoc. exact aux1. } clear aux1. apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm I_{V} a)). cbn. set (aux2 := fmonoidal_preservesleftunitality Fm a). etrans. { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (bifunctor_equalwhiskers W). } unfold functoronmorphisms1. rewrite assoc'. etrans. { apply maponpaths. apply monoidal_leftunitornat. } repeat rewrite assoc. apply cancel_postcomposition. rewrite <- aux2. clear aux2. repeat rewrite assoc. apply cancel_postcomposition. rewrite <- (bifunctor_rightcomp W). etrans. { apply cancel_postcomposition. apply maponpaths. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservesunitstrongly Fm)). } rewrite bifunctor_rightid. apply id_left. Qed. Lemma dialgebra_disp_rightunitor_data : disp_rightunitor_data dialgebra_disp_tensor dialgebra_disp_unit. Proof. intros a f. cbn. unfold dialgebra_disp_unit, dialgebra_disp_tensor_op. unfold functoronmorphisms1. rewrite (bifunctor_leftcomp W). set (aux1 := fmonoidal_preservesrightunitality Gm a). etrans. { repeat rewrite assoc'. do 3 apply maponpaths. rewrite assoc. exact aux1. } clear aux1. apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm a I_{V})). cbn. set (aux2 := fmonoidal_preservesrightunitality Fm a). etrans. { rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers W). } unfold functoronmorphisms2. rewrite assoc'. etrans. { apply maponpaths. apply monoidal_rightunitornat. } repeat rewrite assoc. apply cancel_postcomposition. rewrite <- aux2. clear aux2. repeat rewrite assoc. apply cancel_postcomposition. rewrite <- (bifunctor_leftcomp W). etrans. { apply cancel_postcomposition. apply maponpaths. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservesunitstrongly Fm)). } rewrite bifunctor_leftid. apply id_left. Qed. Lemma dialgebra_disp_associator_data : disp_associator_data dialgebra_disp_tensor. Proof. intros a1 a2 a3 f1 f2 f3. cbn. unfold dialgebra_disp_tensor_op. etrans. { rewrite (bifunctor_equalwhiskers W). unfold functoronmorphisms2. rewrite bifunctor_rightcomp. repeat rewrite assoc'. do 3 apply maponpaths. rewrite assoc. apply fmonoidal_preservesassociativity. } repeat rewrite assoc. apply cancel_postcomposition. etrans. 2: { unfold functoronmorphisms1 at 1. rewrite (bifunctor_leftcomp W). apply idpath. } repeat rewrite assoc. apply cancel_postcomposition. rewrite bifunctor_leftcomp. rewrite bifunctor_rightcomp. etrans. { apply cancel_postcomposition. rewrite assoc. apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply pathsinv0, bifunctor_equalwhiskers. } unfold functoronmorphisms1 at 1. repeat rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm _ _)). cbn. transparent assert (aux1 : (z_iso (F (a1 ⊗_{V} a2) ⊗_{W} F a3) ((F a1 ⊗_{W} F a2) ⊗_{W} F a3))). { exists (pr1 (fmonoidal_preservestensorstrongly Fm a1 a2) ⊗^{W}_{r} F a3). exists (fmonoidal_preservestensordata Fm a1 a2 ⊗^{W}_{r} F a3). split. - rewrite <- (bifunctor_rightcomp W). etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservestensorstrongly Fm a1 a2)). } apply (bifunctor_rightid W). - rewrite <- (bifunctor_rightcomp W). etrans. { apply maponpaths. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservestensorstrongly Fm a1 a2)). } apply (bifunctor_rightid W). } apply pathsinv0, (z_iso_inv_to_left _ _ _ aux1). cbn. clear aux1. etrans. { repeat rewrite assoc. do 4 apply cancel_postcomposition. apply fmonoidal_preservesassociativity. } etrans. { repeat rewrite assoc. do 3 apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservestensorstrongly Fm a1 _)). } rewrite id_right. etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers W). } etrans; [| apply (associator_nat2 W)]. repeat rewrite assoc'. apply maponpaths. unfold functoronmorphisms1 at 2. repeat rewrite assoc. apply cancel_postcomposition. transparent assert (aux2 : (z_iso (G a1 ⊗_{W} F (a2 ⊗_{V} a3)) (G a1 ⊗_{W} (F a2 ⊗_{W} F a3)))). { exists (G a1 ⊗^{W}_{l} pr1 (fmonoidal_preservestensorstrongly Fm a2 a3)). exists (G a1 ⊗^{W}_{l} fmonoidal_preservestensordata Fm a2 a3). split. - rewrite <- (bifunctor_leftcomp W). etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservestensorstrongly Fm a2 a3)). } apply (bifunctor_leftid W). - rewrite <- (bifunctor_leftcomp W). etrans. { apply maponpaths. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservestensorstrongly Fm a2 a3)). } apply (bifunctor_leftid W). } apply (z_iso_inv_to_right _ _ _ _ aux2). cbn. clear aux2. apply pathsinv0, (bifunctor_equalwhiskers W). Qed. Definition dialgebra_disp_monoidal_data : disp_monoidal_data base_disp V. Proof. use make_disp_monoidal_data_groupoidal. - apply groupoidal_dialgebra_disp_cat. - exact dialgebra_disp_tensor. - exact dialgebra_disp_unit. - exact dialgebra_disp_leftunitor_data. - exact dialgebra_disp_rightunitor_data. - exact dialgebra_disp_associator_data. Defined. Definition dialgebra_disp_monoidal : disp_monoidal base_disp V. Proof. use make_disp_monoidal_locally_prop. - apply is_locally_propositional_dialgebra_disp_cat. - exact dialgebra_disp_monoidal_data. Defined. Definition dialgebra_monoidal : monoidal (dialgebra F G) := total_monoidal dialgebra_disp_monoidal. Definition dialgebra_monoidal_pr1 : fmonoidal dialgebra_monoidal V (dialgebra_pr1 F G) := projection_fmonoidal dialgebra_disp_monoidal. Section IntoMonoidalSection. Context (α : F ⟹ G) (ismnt : is_mon_nat_trans Fm Gm α). Let ismnt_tensor : is_mon_nat_trans_tensorlaw Fm Gm α := pr1 ismnt. Let ismnt_unit : is_mon_nat_trans_unitlaw Fm Gm α := pr2 ismnt. Lemma monnattrans_to_monoidal_section_data : smonoidal_data V dialgebra_disp_monoidal (nat_trans_to_section F G α). Proof. split. - intros a a'. cbn. unfold dialgebra_disp_tensor_op. do 2 rewrite functor_id. rewrite id_left, id_right. rewrite assoc'. rewrite <- ismnt_tensor. rewrite assoc. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservestensorstrongly Fm a a')). } apply id_left. - cbn. unfold dialgebra_disp_unit. do 2 rewrite functor_id. rewrite id_left, id_right. cbn in ismnt_unit. rewrite <- ismnt_unit. rewrite assoc. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservesunitstrongly Fm)). } apply id_left. Qed. Lemma monnattrans_to_monoidal_section_laws : smonoidal_laxlaws V dialgebra_disp_monoidal monnattrans_to_monoidal_section_data. Proof. repeat split; red; intros; apply base_disp_cells_isaprop. Qed. Lemma monnattrans_to_monoidal_section_strongtensor : smonoidal_strongtensor V dialgebra_disp_monoidal (smonoidal_preserves_tensor V dialgebra_disp_monoidal monnattrans_to_monoidal_section_data). Proof. intros a a'. use tpair. - cbn. unfold dialgebra_disp_tensor_op. apply pathsinv0. (* now as for [monnattrans_to_monoidal_section_data] *) do 2 rewrite functor_id. rewrite id_left, id_right. rewrite assoc'. rewrite <- ismnt_tensor. rewrite assoc. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservestensorstrongly Fm a a')). } apply id_left. - split; apply base_disp_cells_isaprop. Qed. Lemma monnattrans_to_monoidal_section_strongunit : smonoidal_strongunit V dialgebra_disp_monoidal (smonoidal_preserves_unit V dialgebra_disp_monoidal monnattrans_to_monoidal_section_data). Proof. use tpair. - cbn. unfold dialgebra_disp_unit. do 2 rewrite functor_id. rewrite id_left, id_right. cbn in ismnt_unit. rewrite <- ismnt_unit. rewrite assoc. apply pathsinv0. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,fmonoidal_preservesunitstrongly Fm)). } apply id_left. - split; apply base_disp_cells_isaprop. Qed. Definition monnattrans_to_monoidal_section : smonoidal V dialgebra_disp_monoidal (nat_trans_to_section F G α). Proof. use tpair. - exact (monnattrans_to_monoidal_section_data,,monnattrans_to_monoidal_section_laws). - split. + exact monnattrans_to_monoidal_section_strongtensor. + exact monnattrans_to_monoidal_section_strongunit. Defined. End IntoMonoidalSection. Section FromMonoidalSection. Context (sd: section_disp (dialgebra_disp_cat F G)). Context (ms: smonoidal_data V dialgebra_disp_monoidal sd). Definition nattrans_from_ms : F ⟹ G := section_to_nat_trans F G sd. Lemma nattrans_from_ms_is_mon_nat_trans : is_mon_nat_trans Fm Gm nattrans_from_ms. Proof. split. - intros a a'. assert (aux := smonoidal_preserves_tensor _ _ ms a a'). cbn in aux. unfold dialgebra_disp_tensor_op in aux. do 2 rewrite functor_id in aux. rewrite id_left, id_right in aux. unfold nattrans_from_ms. cbn. etrans. { apply maponpaths. apply pathsinv0, aux. } repeat rewrite assoc. apply cancel_postcomposition. etrans. { apply cancel_postcomposition. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservestensorstrongly Fm a a')). } apply id_left. - cbn. assert (aux := smonoidal_preserves_unit _ _ ms). cbn in aux. unfold dialgebra_disp_unit in aux. do 2 rewrite functor_id in aux. rewrite id_left, id_right in aux. etrans. { apply maponpaths. apply pathsinv0, aux. } rewrite assoc. etrans. { apply cancel_postcomposition. apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservesunitstrongly Fm)). } apply id_left. Qed. End FromMonoidalSection. (** the following lemma should be instance of a construction with lifting *) Lemma dialgebra_nat_trans_is_mon_nat_trans : is_mon_nat_trans (comp_fmonoidal_lax dialgebra_monoidal_pr1 Fm) (comp_fmonoidal_lax dialgebra_monoidal_pr1 Gm) (dialgebra_nat_trans F G). Proof. split. + intros a a'. unfold fmonoidal_preservestensordata. cbn. unfold fmonoidal_preservestensordata. unfold projection_preserves_tensordata. cbn. unfold dialgebra_nat_trans_data. do 2 rewrite functor_id. do 2 rewrite id_right. unfold dialgebra_disp_tensor_op. etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply (pr12 (fmonoidal_preservestensorstrongly Fm (pr1 a) (pr1 a'))). } rewrite id_left. apply idpath. + unfold is_mon_nat_trans_unitlaw. unfold fmonoidal_preservesunit. cbn. unfold fmonoidal_preservesunit. unfold projection_preserves_unit. cbn. unfold dialgebra_disp_unit. do 2 rewrite functor_id. do 2 rewrite id_right. etrans. { rewrite assoc. apply cancel_postcomposition. apply (pr12 (fmonoidal_preservesunitstrongly Fm)). } unfold fmonoidal_preservesunit. apply id_left. Qed. Section RoundtripForSDData. Local Definition source_type: UU := ∑ α : F ⟹ G, is_mon_nat_trans Fm Gm α. Local Definition target_type: UU := ∑ sd: section_disp (dialgebra_disp_cat F G), smonoidal_data V dialgebra_disp_monoidal sd. Local Definition source_to_target : source_type -> target_type. Proof. intro ass. destruct ass as [α ismnt]. exists (nat_trans_to_section F G α). exact (monnattrans_to_monoidal_section_data α ismnt). Defined. Local Definition target_to_source : target_type -> source_type. Proof. intro ass. destruct ass as [sd ms]. exists (nattrans_from_ms sd). exact (nattrans_from_ms_is_mon_nat_trans sd ms). Defined. Local Lemma roundtrip1 (ass: source_type): target_to_source (source_to_target ass) = ass. Proof. destruct ass as [α [ismnt_tensor ismnt_unit]]. use total2_paths_f. - cbn. unfold nattrans_from_ms. apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip1_with_sections. - cbn. match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + apply impred. intro a. apply impred. intro a'. apply B. + apply B. Qed. Local Lemma roundtrip2 (ass: target_type): source_to_target (target_to_source ass) = ass. Proof. destruct ass as [sd ms]. use total2_paths_f. - cbn. unfold nattrans_from_ms. apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip2_with_sections. - cbn. match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + unfold section_preserves_tensor_data. apply impred. intro a. apply impred. intro a'. apply base_disp_cells_isaprop. + unfold section_preserves_unit. apply base_disp_cells_isaprop. Qed. End RoundtripForSDData. End FixTwoMonoidalFunctors. Section MonoidalNatTransToDialgebraLifting. Context {C1 C2 C3 : category} {M1 : monoidal C1} {M2 : monoidal C2} {M3 : monoidal C3} {F G : C2 ⟶ C3} {Fm : fmonoidal M2 M3 F} {Gm : fmonoidal M2 M3 G} {K : C1 ⟶ C2} {Km : fmonoidal M1 M2 K} {α : K ∙ F ⟹ K ∙ G} (αm : is_mon_nat_trans (comp_fmonoidal Km Fm) (comp_fmonoidal Km Gm) α). Definition monoidal_nat_trans_to_dialgebra_lifting_data : flmonoidal_data Km (dialgebra_disp_monoidal Fm Gm) (nat_trans_to_dialgebra_lifting K α). Proof. use tpair. - intros x y. cbn. unfold dialgebra_disp_tensor_op. rewrite ! assoc'. etrans. { apply maponpaths. exact (! pr1 αm x y). } cbn. etrans. { do 2 rewrite assoc. do 2 apply maponpaths_2. apply (pr2 (fmonoidal_preservestensorstrongly Fm (K x) (K y))). } rewrite assoc'. apply id_left. - cbn. unfold dialgebra_disp_unit. etrans. { rewrite assoc'. apply maponpaths. exact (! pr2 αm). } cbn. etrans. { do 2 rewrite assoc. do 2 apply maponpaths_2. apply (pr2 (fmonoidal_preservesunitstrongly Fm)). } rewrite assoc'. apply id_left. Qed. Lemma monoidal_nat_trans_to_dialgebra_lifting_laxlaws : flmonoidal_laxlaws Km (dialgebra_disp_monoidal Fm Gm) (nat_trans_to_dialgebra_lifting K α) monoidal_nat_trans_to_dialgebra_lifting_data. Proof. repeat split ; intro ; intros ; apply homset_property. Qed. Definition monoidal_nat_trans_to_dialgebra_lifting : flmonoidal_lax Km (dialgebra_disp_monoidal Fm Gm) (nat_trans_to_dialgebra_lifting K α). Proof. exists monoidal_nat_trans_to_dialgebra_lifting_data. exact monoidal_nat_trans_to_dialgebra_lifting_laxlaws. Defined. Lemma monoidal_nat_trans_to_dialgebra_lifting_stronglaws : fl_stronglaws Km (dialgebra_disp_monoidal Fm Gm) (nat_trans_to_dialgebra_lifting K α) monoidal_nat_trans_to_dialgebra_lifting (pr2 Km). Proof. split. - intros x y. use tpair. + cbn. transparent assert (pfG_is_z_iso : (is_z_isomorphism ( (# G)%Cat (inv_from_z_iso (fmonoidal_preservestensordata Km x y,, fmonoidal_preservestensorstrongly (_,, pr2 Km) x y))))). { use functor_on_is_z_isomorphism. apply is_z_iso_inv_from_z_iso. } use (z_iso_inv_to_right _ _ _ _ (_ ,, pfG_is_z_iso)). transparent assert (pfF_is_z_iso : (is_z_isomorphism ((# F)%Cat (inv_from_z_iso (fmonoidal_preservestensordata Km x y,, fmonoidal_preservestensorstrongly (_,, pr2 Km) x y))))). { use functor_on_is_z_isomorphism. apply is_z_iso_inv_from_z_iso. } rewrite assoc'. use (z_iso_inv_to_left _ _ _ (_ ,, pfF_is_z_iso)). exact (! pr1 monoidal_nat_trans_to_dialgebra_lifting_data x y). + repeat (apply funextsec ; intro). split ; apply base_disp_cells_isaprop. - use tpair. + cbn. transparent assert (pfL_is_z_iso : (is_z_isomorphism ( (# F)%Cat (inv_from_z_iso (fmonoidal_preservesunit Km,, fmonoidal_preservesunitstrongly (_ ,, pr2 Km))))) ). { use functor_on_is_z_isomorphism. apply is_z_iso_inv_from_z_iso. } use (z_iso_inv_to_left _ _ _ (_ ,, pfL_is_z_iso)). transparent assert (pfR_is_z_iso : (is_z_isomorphism ((# G)%Cat (inv_from_z_iso (fmonoidal_preservesunit Km,, fmonoidal_preservesunitstrongly (_,, pr2 Km)))))). { use functor_on_is_z_isomorphism. apply is_z_iso_inv_from_z_iso. } rewrite assoc. use (z_iso_inv_to_right _ _ _ _ (_ ,, pfR_is_z_iso)). exact (! pr2 monoidal_nat_trans_to_dialgebra_lifting_data). + split ; apply base_disp_cells_isaprop. Qed. Definition monoidal_nat_trans_to_dialgebra_lifting_strong : flmonoidal Km (dialgebra_disp_monoidal Fm Gm) (nat_trans_to_dialgebra_lifting K α) (pr2 Km). Proof. exists monoidal_nat_trans_to_dialgebra_lifting. exact monoidal_nat_trans_to_dialgebra_lifting_stronglaws. Defined. Definition monoidal_nat_trans_to_dialgebra : fmonoidal_lax _ _ (nat_trans_to_dialgebra K α) := functorlifting_fmonoidal_lax _ _ _ monoidal_nat_trans_to_dialgebra_lifting. Definition monoidal_nat_trans_to_dialgebra_strong : fmonoidal _ _ (nat_trans_to_dialgebra K α) := functorlifting_fmonoidal _ _ _ monoidal_nat_trans_to_dialgebra_lifting_strong. End MonoidalNatTransToDialgebraLifting. Section MonoidalDialgebraLiftingToNatTrans. Context {C1 C2 C3 : category} {M1 : monoidal C1} {M2 : monoidal C2} {M3 : monoidal C3} {F G : C2 ⟶ C3} {Fm : fmonoidal M2 M3 F} {Gm : fmonoidal M2 M3 G} {K : C1 ⟶ C2} {Km : fmonoidal M1 M2 K} {fl : functor_lifting (dialgebra_disp_cat F G) K} (Fl : flmonoidal_lax Km (dialgebra_disp_monoidal Fm Gm) fl). Let α : K ∙ F ⟹ K ∙ G := dialgebra_lifting_to_nat_trans _ fl. Definition monoidal_dialgebra_lifting_to_monoidal_nat_trans : is_mon_nat_trans (comp_fmonoidal Km Fm) (comp_fmonoidal Km Gm) α. Proof. split. - intros x y. cbn. etrans. { rewrite assoc'. apply maponpaths. exact (! pr11 Fl x y). } cbn. do 2 rewrite assoc. apply maponpaths_2. unfold dialgebra_disp_tensor_op. cbn. do 2 rewrite assoc. etrans. { do 2 apply maponpaths_2. apply (fmonoidal_preservestensorstrongly Fm (K x) (K y)). } rewrite assoc'. apply id_left. - red. cbn. etrans. { rewrite assoc'. apply maponpaths. exact (! pr21 Fl). } rewrite assoc. apply maponpaths_2. cbn. unfold dialgebra_disp_unit. rewrite assoc. etrans. { apply maponpaths_2. apply (fmonoidal_preservesunitstrongly Fm). } apply id_left. Qed. (* Definition monoidal_dialgebra_lifting_to_invertible_monoidal_nat_trans *) End MonoidalDialgebraLiftingToNatTrans. Section RoundtripForLiftingData. Context {C1 C2 C3 : category} {M1 : monoidal C1} {M2 : monoidal C2} {M3 : monoidal C3} {F G : C2 ⟶ C3} {Fm : fmonoidal M2 M3 F} {Gm : fmonoidal M2 M3 G} {K : C1 ⟶ C2} {Km : fmonoidal M1 M2 K}. Local Definition source_type': UU := ∑ α : K ∙ F ⟹ K ∙ G, is_mon_nat_trans (comp_fmonoidal Km Fm) (comp_fmonoidal Km Gm) α. Local Definition target_type': UU := ∑ fl : functor_lifting (dialgebra_disp_cat F G) K, flmonoidal_lax Km (dialgebra_disp_monoidal Fm Gm) fl. Local Definition target_type_s': UU := ∑ fl : functor_lifting (dialgebra_disp_cat F G) K, flmonoidal Km (dialgebra_disp_monoidal Fm Gm) fl (pr2 Km). Local Definition source_to_target' : source_type' -> target_type' := λ α, _ ,, monoidal_nat_trans_to_dialgebra_lifting (pr2 α). Local Definition target_to_source' : target_type' -> source_type' := λ fl, _ ,, monoidal_dialgebra_lifting_to_monoidal_nat_trans (pr2 fl). Local Definition source_to_target_s' : source_type' -> target_type_s'. Proof. intro α. use tpair. 2: apply (monoidal_nat_trans_to_dialgebra_lifting_strong (pr2 α)). Defined. Local Definition target_to_source_s' : target_type_s' -> source_type' := λ fl, _ ,, monoidal_dialgebra_lifting_to_monoidal_nat_trans (pr2 fl). Local Lemma roundtrip1' (ass: source_type') : target_to_source' (source_to_target' ass) = ass. Proof. use total2_paths_f. - apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip1_with_liftings. - apply isaprop_is_mon_nat_trans. Qed. Local Lemma roundtrip1_s' (ass: source_type') : target_to_source_s' (source_to_target_s' ass) = ass. Proof. use total2_paths_f. - apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip1_with_liftings. - apply isaprop_is_mon_nat_trans. Qed. Local Lemma roundtrip2' (ass: target_type') : source_to_target' (target_to_source' ass) = ass. Proof. use total2_paths_f. - apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip2_with_liftings. - use flmonoidal_equality ; intros ; apply homset_property. Qed. Local Lemma roundtrip2_s' (ass: target_type_s') : source_to_target_s' (target_to_source_s' ass) = ass. Proof. use total2_paths_f. - apply UniMath.CategoryTheory.categories.Dialgebras.roundtrip2_with_liftings. - use flmonoidal_strong_equality ; intros ; apply homset_property. Qed. End RoundtripForLiftingData. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/MonoidalPointedObjects.v000066400000000000000000000405071451125700300277400ustar00rootroot00000000000000(** the coslice category I/V for a monoidal category is again monoidal The coslice objects have a morphism from the monoidal unit I to an object of V. Since I is often not a terminal object 1 of V, one cannot speak of pointed objects here; I suggest to call them monoidal-pointed objects. author: Ralph Matthes 2022 in 2022 Kobe Wullaert added the part in preparation of showing that taking the category of monoidal-pointed objects is an idempotent operation (strong monoidal functors are constructed between one and two applications of that operation to some argument) - the continuation is found in the package [Bicategories] *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Foundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.coslicecat. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section A. Context {V : category} (Mon_V : monoidal V). Let cosliced : disp_cat V := coslice_cat_disp V I_{Mon_V}. Lemma monoidal_pointed_objects_disp_tensor_data_aux1 (v w w' : V) (g : V ⟦ w, w' ⟧) (pv : cosliced v) (pw : cosliced w) (pw' : cosliced w') (Hypg : pw · g = pw') : luinv^{ Mon_V }_{ I_{ Mon_V}} · pv ⊗^{ Mon_V} pw · v ⊗^{ Mon_V}_{l} g = luinv^{ Mon_V }_{ I_{ Mon_V}} · pv ⊗^{ Mon_V} pw'. Proof. rewrite assoc'. apply maponpaths. rewrite <- Hypg. unfold functoronmorphisms1. rewrite assoc'. apply maponpaths. apply pathsinv0, (bifunctor_leftcomp Mon_V). Qed. Lemma monoidal_pointed_objects_disp_tensor_data_aux2 (v v' w : V) (f : V ⟦ v, v' ⟧) (pv : cosliced v) (pv' : cosliced v') (pw : cosliced w) (Hypf : pv · f = pv') : luinv^{ Mon_V }_{ I_{ Mon_V}} · pv ⊗^{ Mon_V} pw · f ⊗^{ Mon_V}_{r} w = luinv^{ Mon_V }_{ I_{ Mon_V}} · pv' ⊗^{ Mon_V} pw. Proof. rewrite assoc'. apply maponpaths. rewrite <- Hypf. do 2 rewrite (bifunctor_equalwhiskers Mon_V). unfold functoronmorphisms2. rewrite assoc'. apply maponpaths. apply pathsinv0, (bifunctor_rightcomp Mon_V). Qed. Definition monoidal_pointed_objects_disp_tensor_data : disp_bifunctor_data Mon_V cosliced cosliced cosliced. Proof. use make_disp_bifunctor_data. - intros v w pv pw. exact (luinv^{Mon_V}_{I_{Mon_V}} · pv ⊗^{Mon_V} pw). - exact monoidal_pointed_objects_disp_tensor_data_aux1. - exact monoidal_pointed_objects_disp_tensor_data_aux2. Defined. Definition monoidal_pointed_objects_disp_tensor : disp_tensor cosliced Mon_V. Proof. use make_disp_bifunctor_locally_prop. - apply coslice_cat_disp_locally_prop. - exact monoidal_pointed_objects_disp_tensor_data. Defined. Lemma cosliced_groupoidal : groupoidal_disp_cat cosliced. Proof. intros x y f Hf xx yy ff. use tpair. - cbn in *. rewrite <- ff. rewrite assoc'. refine (_ @ id_right _). apply maponpaths. apply (z_iso_inv_after_z_iso (make_z_iso' f Hf)). - split; apply coslice_cat_disp_locally_prop. Qed. Lemma monoidal_pointed_objects_disp_data_verif : disp_leftunitor_data monoidal_pointed_objects_disp_tensor (identity I_{Mon_V}) × disp_rightunitor_data monoidal_pointed_objects_disp_tensor (identity I_{Mon_V}) × disp_associator_data monoidal_pointed_objects_disp_tensor. Proof. split3. - intros v pv. cbn. unfold functoronmorphisms1. rewrite (bifunctor_rightid Mon_V). rewrite id_left. rewrite assoc'. rewrite monoidal_leftunitornat. rewrite assoc. rewrite (pr2 (monoidal_leftunitorisolaw Mon_V _)). apply id_left. - intros v pv. cbn. unfold functoronmorphisms1. rewrite (bifunctor_leftid Mon_V). rewrite id_right. rewrite assoc'. rewrite monoidal_rightunitornat. rewrite assoc. rewrite <- unitors_coincide_on_unit. rewrite (pr2 (monoidal_leftunitorisolaw Mon_V _)). apply id_left. - intros v w u pv pw pu. cbn. rewrite assoc'. apply maponpaths. unfold functoronmorphisms1. rewrite !(bifunctor_rightcomp Mon_V). rewrite !(bifunctor_leftcomp Mon_V). rewrite !assoc'. rewrite <- monoidal_associatornatleft. rewrite !assoc. apply cancel_postcomposition. rewrite !assoc'. rewrite <- (monoidal_associatornatleftright Mon_V). rewrite !assoc. apply cancel_postcomposition. apply (z_iso_inv_to_right _ _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)). cbn. etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, monoidal_triangle_identity_inv. } rewrite <- !(bifunctor_rightcomp Mon_V). apply maponpaths. rewrite unitorsinv_coincide_on_unit. apply monoidal_rightunitorinvnat. Qed. Definition monoidal_pointed_objects_disp_data : disp_monoidal_data cosliced Mon_V. Proof. use make_disp_monoidal_data_groupoidal. - exact cosliced_groupoidal. - exact monoidal_pointed_objects_disp_tensor. - apply identity. - apply monoidal_pointed_objects_disp_data_verif. - apply monoidal_pointed_objects_disp_data_verif. - apply monoidal_pointed_objects_disp_data_verif. Defined. Definition monoidal_pointed_objects_disp : disp_monoidal cosliced Mon_V. Proof. apply make_disp_monoidal_locally_prop. - apply coslice_cat_disp_locally_prop. - exact monoidal_pointed_objects_disp_data. Defined. Definition monoidal_pointed_objects : monoidal (coslice_cat_total V I_{Mon_V}) := total_monoidal monoidal_pointed_objects_disp. Definition forget_monoidal_pointed_objects_data : fmonoidal_data monoidal_pointed_objects Mon_V (pr1_category cosliced). Proof. split; try intro; intros; apply identity. Defined. Definition forget_monoidal_pointed_objects_monoidal_generic : fmonoidal monoidal_pointed_objects Mon_V (pr1_category cosliced) := projection_fmonoidal monoidal_pointed_objects_disp. (** we develop a hand-crafted version since that one came first historically and is still used subsequently *) Lemma forget_monoidal_pointed_objects_laxlaws : fmonoidal_laxlaws forget_monoidal_pointed_objects_data. Proof. split5; intro; intros. - rewrite id_left; apply id_right. - rewrite id_left; apply id_right. - do 2 rewrite id_right. cbn. rewrite (bifunctor_leftid Mon_V). rewrite (bifunctor_rightid Mon_V). rewrite id_right; apply id_left. - cbn. rewrite (bifunctor_rightid Mon_V). rewrite id_left. apply id_left. - cbn. rewrite (bifunctor_leftid Mon_V). rewrite id_left. apply id_left. Qed. Definition forget_monoidal_pointed_objects_lax_monoidal : fmonoidal_lax monoidal_pointed_objects Mon_V (pr1_category cosliced) := forget_monoidal_pointed_objects_data,,forget_monoidal_pointed_objects_laxlaws. Definition forget_monoidal_pointed_objects_monoidal_stronglaws : fmonoidal_stronglaws (fmonoidal_preservestensordata forget_monoidal_pointed_objects_lax_monoidal) (fmonoidal_preservesunit forget_monoidal_pointed_objects_lax_monoidal). Proof. split; try intro; intros; apply identity_is_z_iso. Defined. Definition forget_monoidal_pointed_objects_monoidal : fmonoidal monoidal_pointed_objects Mon_V (pr1_category cosliced) := forget_monoidal_pointed_objects_lax_monoidal ,, forget_monoidal_pointed_objects_monoidal_stronglaws. End A. Section PointedObjectFixpoint. (* Let V be a monoidal category. In this section we construct functors (in both directions) between the monoidal category of monoidal-pointed objects of V, (i.e. the coslice category under the unit object of V) and the category of monoidal-pointed objects of the category of monoidal-pointed objects of V. The constructions in this section are used to show that taking the category of monoidal-pointed objects is idempotent. *) Local Definition ptd_ob {V : category} (Mon_V : monoidal V) : category := coslice_cat_total V I_{ Mon_V}. Local Definition ptd_ob_mon {V : category} (Mon_V : monoidal V) : monoidal (ptd_ob Mon_V) := monoidal_pointed_objects Mon_V. Context {V : category} (Mon_V : monoidal V). Definition ptdob_to_ptdptdob_data : functor_data (ptd_ob Mon_V) (ptd_ob (ptd_ob_mon Mon_V)). Proof. use make_functor_data. - intro f. exists f. exists (pr2 f). apply id_left. - intros f g α. exists α. use total2_paths_f. 2: { apply homset_property. } exact (pr2 α). Defined. Definition ptdob_to_ptdptdob_is_functor : is_functor ptdob_to_ptdptdob_data. Proof. split. - intro. use total2_paths_f. 2: { apply homset_property. } apply idpath. - intro ; intros. use total2_paths_f. 2: { apply homset_property. } apply idpath. Qed. Definition ptdob_to_ptdptdob : functor (ptd_ob Mon_V) (ptd_ob (ptd_ob_mon Mon_V)) := ptdob_to_ptdptdob_data ,, ptdob_to_ptdptdob_is_functor. Definition ptdptdob_to_ptdob_data : functor_data (ptd_ob (ptd_ob_mon Mon_V)) (ptd_ob Mon_V). Proof. use make_functor_data. - exact (λ f, pr1 f). - exact (λ _ _ α, pr1 α). Defined. Definition ptdptdob_to_ptdob_is_functor : is_functor ptdptdob_to_ptdob_data. Proof. repeat split. Qed. Definition ptdptdob_to_ptdob : functor (ptd_ob (ptd_ob_mon Mon_V)) (ptd_ob Mon_V) := ptdptdob_to_ptdob_data ,, ptdptdob_to_ptdob_is_functor. Definition unit_ptdob_data : nat_trans_data (functor_identity (ptd_ob Mon_V)) (functor_composite ptdob_to_ptdptdob ptdptdob_to_ptdob). Proof. intro v. exists (identity _). abstract (apply id_right). Defined. Definition unit_ptdob_is_nat_trans : is_nat_trans _ _ unit_ptdob_data. Proof. intro ; intros. use total2_paths_f. 2: { apply homset_property. } simpl. rewrite id_left. apply id_right. Qed. Definition unit_ptdob : nat_trans (functor_identity (ptd_ob Mon_V)) (functor_composite ptdob_to_ptdptdob ptdptdob_to_ptdob) := unit_ptdob_data ,, unit_ptdob_is_nat_trans. Definition counit_ptdob_data : nat_trans_data (functor_composite ptdptdob_to_ptdob ptdob_to_ptdptdob) (functor_identity (ptd_ob (ptd_ob_mon Mon_V))). Proof. intro v. exists (identity _). abstract (use total2_paths_f ; [ simpl ; rewrite (! pr22 v) ; rewrite id_right ; apply id_left | apply homset_property ]). Defined. Definition counit_ptdob_is_nat_trans : is_nat_trans _ _ counit_ptdob_data. Proof. intro ; intros. use total2_paths_f. 2: { apply homset_property. } use total2_paths_f. 2: { apply homset_property. } cbn. rewrite id_left. apply id_right. Qed. Definition counit_ptdob : nat_trans (functor_composite ptdptdob_to_ptdob ptdob_to_ptdptdob) (functor_identity (ptd_ob (ptd_ob_mon Mon_V))) := counit_ptdob_data ,, counit_ptdob_is_nat_trans. End PointedObjectFixpoint. Section PointedObjectFixpointMonoidal. (* In this section, we show that the data defined in the previous section "PointedObjectFixpoint" is monoidal *) Context {V : category} (Mon_V : monoidal V). Definition ptdptdob_to_ptdob_fmonoidal_data : fmonoidal_data (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptd_ob_mon Mon_V) (ptdptdob_to_ptdob Mon_V). Proof. split. - intros f g. exists (identity _). abstract (apply id_right). - exists (identity _). abstract (apply id_right). Defined. Definition ptdob_to_ptdptdob_fmonoidal_data : fmonoidal_data (ptd_ob_mon Mon_V) (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptdob_to_ptdptdob Mon_V). Proof. split. - intros f g. exists (identity _). abstract ( use total2_paths_f ; [ apply id_right | apply homset_property ] ). - exists (identity _). abstract ( use total2_paths_f ; [ apply id_right | apply homset_property ] ). Defined. Lemma ptdptdob_to_ptdob_fmonoidal_laxlaws : fmonoidal_laxlaws ptdptdob_to_ptdob_fmonoidal_data. Proof. repeat split ; (intro ; intros ; use total2_paths_f ; [ cbn | apply homset_property ]). - rewrite id_left ; apply id_right. - rewrite id_left ; apply id_right. - rewrite (bifunctor_rightid Mon_V). rewrite (bifunctor_leftid Mon_V). rewrite ! id_left. rewrite ! id_right. apply idpath. - rewrite id_right. rewrite (bifunctor_rightid Mon_V). apply id_left. - rewrite id_right. rewrite (bifunctor_leftid Mon_V). apply id_left. Qed. Lemma ptdob_to_ptdptdob_fmonoidal_laxlaws : fmonoidal_laxlaws ptdob_to_ptdptdob_fmonoidal_data. Proof. repeat split ; (intro ; intros ; use total2_paths_f ; [ use total2_paths_f ; cbn | apply homset_property ]). - rewrite id_left ; apply id_right. - apply homset_property. - rewrite id_left ; apply id_right. - apply homset_property. - rewrite (bifunctor_rightid Mon_V). rewrite (bifunctor_leftid Mon_V). rewrite ! id_left. rewrite ! id_right. apply idpath. - apply homset_property. - rewrite id_right. rewrite (bifunctor_rightid Mon_V). apply id_left. - apply homset_property. - rewrite id_right. rewrite (bifunctor_leftid Mon_V). apply id_left. - apply homset_property. Qed. Definition ptdptdob_to_ptdob_fmonoidal_lax : fmonoidal_lax (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptd_ob_mon Mon_V) (ptdptdob_to_ptdob Mon_V). Proof. exists ptdptdob_to_ptdob_fmonoidal_data. exact ptdptdob_to_ptdob_fmonoidal_laxlaws. Defined. Definition ptdob_to_ptdptdob_fmonoidal_lax : fmonoidal_lax (ptd_ob_mon Mon_V) (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptdob_to_ptdptdob Mon_V). Proof. exists ptdob_to_ptdptdob_fmonoidal_data. exact ptdob_to_ptdptdob_fmonoidal_laxlaws. Defined. Definition ptdptdob_to_ptdob_fmonoidal_stronglaws : fmonoidal_stronglaws (fmonoidal_preservestensordata ptdptdob_to_ptdob_fmonoidal_lax) (fmonoidal_preservesunit ptdptdob_to_ptdob_fmonoidal_lax). Proof. split ; ( (try intro ; intros) ; repeat (use tpair) ; [ exact (identity _) | abstract (apply id_right) | abstract (use total2_paths_f ; [ apply id_right | apply homset_property ]) | abstract (use total2_paths_f ; [ apply id_right | apply homset_property ]) ]). Defined. (** TODO: separate data and their verification that should be opaque *) Definition ptdob_to_ptdptdob_fmonoidal_stronglaws : fmonoidal_stronglaws (fmonoidal_preservestensordata ptdob_to_ptdptdob_fmonoidal_lax) (fmonoidal_preservesunit ptdob_to_ptdptdob_fmonoidal_lax). Proof. split; ( (try intro ; intros) ; repeat (use tpair) ; [ exact (identity _) | apply id_right | abstract (use total2_paths_f ; [ apply id_right | apply homset_property ]) | abstract ( use total2_paths_f ; [ use total2_paths_f ; [apply id_right | apply V] | apply homset_property ] ) | abstract ( use total2_paths_f ; [ use total2_paths_f ; [apply id_right | apply V] | apply homset_property ]) ]). Defined. Definition ptdptdob_to_ptdob_fmonoidal : fmonoidal (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptd_ob_mon Mon_V) (ptdptdob_to_ptdob Mon_V). Proof. exists ptdptdob_to_ptdob_fmonoidal_lax. exact ptdptdob_to_ptdob_fmonoidal_stronglaws. Defined. Definition ptdob_to_ptdptdob_fmonoidal : fmonoidal (ptd_ob_mon Mon_V) (ptd_ob_mon (ptd_ob_mon Mon_V)) (ptdob_to_ptdptdob Mon_V). Proof. exists ptdob_to_ptdptdob_fmonoidal_lax. exact ptdob_to_ptdptdob_fmonoidal_stronglaws. Defined. End PointedObjectFixpointMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/PointedSetCartesianMonoidal.v000066400000000000000000000130041451125700300307240ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Binproducts. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.DisplayedCartesianMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Local Open Scope cat. Import DisplayedBifunctorNotations. Section PointedSetCategory. Definition preserve_ptset {X Y : hSet} (x : X) (y : Y) (f : X → Y) : UU := f x = y. Lemma isaprop_preserve_ptset {X Y : hSet} (x : X) (y : Y) (f : X → Y) : isaprop (preserve_ptset x y f). Proof. apply Y. Qed. Definition id_preserve_ptset {X : hSet} (x : X) : preserve_ptset x x (idfun X). Proof. apply idpath. Qed. Lemma comp_preserve_ptset {X Y Z : hSet} {x : X} {y : Y} {z : Z} {f : X → Y} {g : Y→ Z} (pf : preserve_ptset x y f) (pg : preserve_ptset y z g) : preserve_ptset x z (funcomp f g). Proof. unfold preserve_ptset. unfold funcomp. etrans. { apply maponpaths. apply pf. } apply pg. Qed. Definition ptset_disp_cat : disp_cat SET. Proof. use disp_struct. - exact (λ X, pr1 X). - exact (λ _ _ m n f, preserve_ptset m n f). - intros x y m n f. apply isaprop_preserve_ptset. - intros X x. apply id_preserve_ptset. - intros X Y Z f g x y z pf pg. apply (comp_preserve_ptset pf pg). Defined. Lemma ptset_disp_cat_locally_prop : locally_propositional ptset_disp_cat. Proof. intros x y m n f. apply isaprop_preserve_ptset. Qed. Definition ptset_cat : category := total_category ptset_disp_cat. Definition ptset_dispBinProducts : dispBinProducts ptset_disp_cat BinProductsHSET. Proof. intros X Y x y. use make_dispBinProduct_locally_prop. - exact ptset_disp_cat_locally_prop. - exists (x ,, y). split; apply idpath. - cbn. intros Z f g z pf pg. unfold preserve_ptset. unfold prodtofuntoprod. cbn. rewrite pf, pg. apply idpath. Defined. Definition ptset_dispTerminal : dispTerminal ptset_disp_cat TerminalHSET. Proof. use make_dispTerminal_locally_prop. - exact ptset_disp_cat_locally_prop. - exact tt. - cbn. intros X x. apply idpath. Defined. Definition PS_cat_cart_monoidal_via_cartesian : monoidal ptset_cat. Proof. use cartesian_monoidal. - apply (total_category_Binproducts _ BinProductsHSET ptset_dispBinProducts). - apply (total_category_Terminal _ TerminalHSET ptset_dispTerminal). Defined. End PointedSetCategory. Section PointedSetIsCartesianMonoidal. Local Notation PS := ptset_cat. Local Notation DPS := ptset_disp_cat. Definition PS_cart_disp_monoidal : disp_monoidal DPS SET_cartesian_monoidal := displayedcartesianmonoidalcat BinProductsHSET TerminalHSET ptset_disp_cat ptset_dispBinProducts ptset_dispTerminal. Section ElementaryProof. Definition PS_disp_tensor_data : disp_bifunctor_data SET_cartesian_monoidal DPS DPS DPS. Proof. repeat (use tpair). - exact (λ _ _ x y, x,,y). - intros X Y Z f x y z pf. use total2_paths_b. + apply idpath. + cbn in *. apply pf. - intros X Y1 Y2 g x y1 y2 pg. use total2_paths_b. + cbn in * ; apply pg. + cbn in *. unfold transportb. rewrite transportf_const. apply idpath. Defined. Lemma PS_disp_tensor_laws : is_disp_bifunctor SET_cartesian_monoidal PS_disp_tensor_data. Proof. repeat split; red; intros; apply isaprop_preserve_ptset. Qed. Definition PS_disp_tensor : disp_tensor DPS SET_cartesian_monoidal := (PS_disp_tensor_data,, PS_disp_tensor_laws). Definition PS_cart_disp_monoidal_data : disp_monoidal_data DPS SET_cartesian_monoidal. Proof. use tpair. - exact PS_disp_tensor. - use tpair. + exact tt. + repeat split. Defined. Lemma PS_cart_disp_monoidal_laws : disp_monoidal_laws PS_cart_disp_monoidal_data. Proof. repeat split; try (red; intros; apply isaprop_preserve_ptset); try (apply isaprop_preserve_ptset). Qed. Definition PS_cart_disp_monoidal_elementary : disp_monoidal DPS SET_cartesian_monoidal := (PS_cart_disp_monoidal_data,, PS_cart_disp_monoidal_laws). End ElementaryProof. Definition PS_cat_cart_monoidal : monoidal ptset_cat := total_monoidal PS_cart_disp_monoidal. Lemma Forgetful_ptset_to_set_preserves_unit_strictly : preserves_unit_strictly (projection_preserves_unit PS_cart_disp_monoidal). Proof. apply projection_preservesunit_strictly. Qed. Lemma Forgetful_ptset_to_set_preserves_tensor_strictly : preserves_tensor_strictly (projection_preserves_tensordata PS_cart_disp_monoidal). Proof. apply projection_preservestensor_strictly. Qed. End PointedSetIsCartesianMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/PosetsMonoidal.v000066400000000000000000000053551451125700300263030ustar00rootroot00000000000000(******************************************************************** Symmetric monoidal closed categories of posets We define two symmetric monoidal closed categories. One is the category of posets where the monoidal product is the cartesian product of posets. The other one is the category of pointed posets where the monoidal product is the smash product. Contents 1. The cartesian monoidal category of posets 2. The symmetric monoidal category of pointed posets ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.PointedPosetStrict. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.SmashProductMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.CategoryOfPosets. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. (** 1. The cartesian monoidal category of posets *) Definition poset_monoidal_cat : monoidal_cat. Proof. refine (category_of_posets ,, _). use cartesian_monoidalcat. - exact BinProducts_category_of_posets. - exact Terminal_category_of_posets. Defined. Proposition is_cartesian_poset_monoidal_cat : is_cartesian poset_monoidal_cat. Proof. apply is_cartesian_cartesian_monoidalcat. Qed. Definition poset_sym_monoidal_cat : sym_monoidal_cat := poset_monoidal_cat ,, symmetric_cartesian_monoidalcat _ _ _. Definition poset_sym_mon_closed_cat : sym_mon_closed_cat. Proof. use sym_mon_closed_cartesian_cat. - exact category_of_posets. - exact BinProducts_category_of_posets. - exact Terminal_category_of_posets. - exact Exponentials_category_of_posets. Defined. (** 2. The symmetric monoidal category of pointed posets *) Definition pointed_poset_sym_mon_closed_cat : sym_mon_closed_cat. Proof. use smash_product_sym_mon_closed_cat. exact pointed_struct_pointed_poset_strict_with_smash_closed. Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/Relations.v000066400000000000000000000521761451125700300253060ustar00rootroot00000000000000(******************************************************************************************** The category of relations is symmetric monoidal closed In this file, we show that the category of relations is a symmetric monoidal closed category. The monoidal structure is defined by taking the product of sets. Note that this is not a cartesian monoidal structure, because products in the category of relations are disjoint unions. Contents 1. The monoidal category of relations 2. It is symmetric 3. It is monoidal closed ********************************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.Relations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. (** 1. The monoidal category of relations *) Definition tensor_data_REL : tensor_data REL. Proof. use make_bifunctor_data. - exact (λ X₁ X₂, X₁ × X₂)%set. - exact (λ X Y₁ Y₂ R xy₁ xy₂, pr1 xy₁ = pr1 xy₂ ∧ R (pr2 xy₁) (pr2 xy₂))%logic. - exact (λ Y X₁ X₂ R xy₁ xy₂, pr2 xy₁ = pr2 xy₂ ∧ R (pr1 xy₁) (pr1 xy₂))%logic. Defined. Definition leftunitor_REL : leftunitor_data tensor_data_REL unitset := λ X x₁ x₂, (pr2 x₁ = x₂)%logic. Definition leftunitorinv_REL : leftunitorinv_data tensor_data_REL unitset := λ X x₁ x₂, (pr2 x₂ = x₁)%logic. Definition rightunitor_REL : rightunitor_data tensor_data_REL unitset := λ X x₁ x₂, (pr1 x₁ = x₂)%logic. Definition rightunitorinv_REL : rightunitorinv_data tensor_data_REL unitset := λ X x₁ x₂, (pr1 x₂ = x₁)%logic. Definition associator_REL : associator_data tensor_data_REL := λ X Y Z xyz₁ xyz₂, ((pr11 xyz₁ = pr1 xyz₂) ∧ (pr21 xyz₁ = pr12 xyz₂) ∧ (pr2 xyz₁ = pr22 xyz₂))%logic. Definition associatorinv_REL : associatorinv_data tensor_data_REL := λ X Y Z xyz₁ xyz₂, ((pr11 xyz₂ = pr1 xyz₁) ∧ (pr21 xyz₂ = pr12 xyz₁) ∧ (pr2 xyz₂ = pr22 xyz₁))%logic. Definition monoidal_data_REL : monoidal_data REL. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _). - exact tensor_data_REL. - exact unitset. - exact leftunitor_REL. - exact leftunitorinv_REL. - exact rightunitor_REL. - exact rightunitorinv_REL. - exact associator_REL. - exact associatorinv_REL. Defined. Proposition monoidal_laws_REL : monoidal_laws monoidal_data_REL. Proof. split6. - repeat split. + intros X Y ; cbn. use funextsec ; intro xy₁. induction xy₁ as [ x₁ y₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ x₂ y₂ ] ; cbn. use hPropUnivalence. * intros p. use pathsdirprod. ** exact (pr1 p). ** exact (pr2 p). * intros p. split. ** exact (maponpaths dirprod_pr1 p). ** exact (maponpaths dirprod_pr2 p). + intros X Y ; cbn. use funextsec ; intro xy₁. induction xy₁ as [ x₁ y₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ x₂ y₂ ] ; cbn. use hPropUnivalence. * intros p. use pathsdirprod. ** exact (pr2 p). ** exact (pr1 p). * intros p. split. ** exact (maponpaths dirprod_pr2 p). ** exact (maponpaths dirprod_pr1 p). + intros X Y₁ Y₂ Y₃ g₁ g₂. use funextsec ; intro xy₁. induction xy₁ as [ x₁ y₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ x₂ y₂ ] ; cbn. use hPropUnivalence. * intros p. induction p as [ p q ]. induction p. use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; clear q. intros [ y q ]. apply hinhpr. exact ((x₁ ,, y) ,, (idpath _ ,, pr1 q) ,, (idpath _ ,, pr2 q)). * use factor_through_squash ; [ apply propproperty | ]. intros [ y [ [ p₁ p₂ ] [ q₁ q₂ ]]] ; cbn in *. induction p₁, q₁. exact (idpath _ ,, hinhpr (pr2 y ,, p₂ ,, q₂)). + intros X Y₁ Y₂ Y₃ g₁ g₂. use funextsec ; intro xy₁. induction xy₁ as [ y₁ x₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ y₂ x₂ ] ; cbn. use hPropUnivalence. * intros p. induction p as [ p q ]. induction p. use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; clear q. intros [ y q ]. exact (hinhpr ((y ,, x₁) ,, ((idpath _ ,, pr1 q) ,, (idpath _ ,, pr2 q)))). * use factor_through_squash ; [ apply propproperty | ]. intros [ y [ [ p₁ p₂ ] [ q₁ q₂ ]]] ; cbn in *. induction p₁, q₁. exact (idpath _ ,, hinhpr (_ ,, p₂ ,, q₂)). + intros X₁ X₂ Y₁ Y₂ R₁ R₂. use funextsec ; intro xy₁. induction xy₁ as [ y₁ x₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ y₂ x₂ ] ; cbn. use hPropUnivalence. * use factor_through_squash ; [ apply propproperty | ]. intros [ y [ [ p₁ p₂ ] [ q₁ q₂ ]]] ; cbn in *. induction p₁, q₁. exact (hinhpr ((_ ,, _) ,, ((idpath _ ,, q₂) ,, (idpath _ ,, p₂)))). * use factor_through_squash ; [ apply propproperty | ]. intros [ y [ [ p₁ p₂ ] [ q₁ q₂ ]]] ; cbn in *. induction p₁, q₁. exact (hinhpr ((_ ,, _) ,, ((idpath _ ,, q₂) ,, (idpath _ ,, p₂)))). - split. + intros X Y R. use funextsec ; intro x. induction x as [ [] x ]. use funextsec ; intro y. use hPropUnivalence. * use factor_through_squash ; [ apply propproperty | ]. intros [ [ [] y' ] [ [ p₁ p₂ ] p₃ ]] ; cbn in *. induction p₃. exact (hinhpr (x ,, (idpath _ ,, p₂))). * use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p. exact (hinhpr ((tt ,, y) ,, ((idpath _ ,, q) ,, idpath _))). + intros X. split. * use funextsec ; intro x. induction x as [ [] x ]. use funextsec ; intro x'. induction x' as [ [] x' ]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p, q. apply idpath. ** intro p ; cbn in *. refine (hinhpr (x' ,, _ ,, idpath _)). exact (maponpaths dirprod_pr2 p). * use funextsec ; intro x. use funextsec ; intro x'. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p, q. apply idpath. ** intro p ; cbn in *. induction p. exact (hinhpr ((tt ,, x) ,, idpath _ ,, idpath _)). - split. + intros X Y R. use funextsec ; intro x. induction x as [ x [] ]. use funextsec ; intro y. use hPropUnivalence. * use factor_through_squash ; [ apply propproperty | ]. intros [ [ y' [] ] [ [ p₁ p₂ ] p₃ ]] ; cbn in *. induction p₃. exact (hinhpr (x ,, (idpath _ ,, p₂))). * use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p. exact (hinhpr ((y ,, tt) ,, ((idpath _ ,, q) ,, idpath _))). + intros X. split. * use funextsec ; intro x. induction x as [ x [] ]. use funextsec ; intro x'. induction x' as [ x' [] ]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p, q. apply idpath. ** intro p ; cbn in *. refine (hinhpr (x' ,, _ ,, idpath _)). exact (maponpaths dirprod_pr1 p). * use funextsec ; intro x. use funextsec ; intro x'. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros [ a [ p q ]] ; cbn in *. induction p, q. apply idpath. ** intro p ; cbn in *. induction p. exact (hinhpr ((x ,, tt) ,, idpath _ ,, idpath _)). - split4. + intros X Y Z₁ Z₂ R. use funextsec ; intro x. induction x as [ [ x y ] z ]. use funextsec ; intro x'. induction x' as [ x' [ y' z' ]]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros ((a & b & c) & ( p₁ & p₂ & p₃ ) & ( p₄ & p₅ & p₆ )). cbn in *. induction p₁, p₂, p₃, p₄, p₅. refine (hinhpr (((x ,, y) ,, z') ,, _)). repeat split ; try (apply idpath). exact p₆. ** use factor_through_squash ; [ apply propproperty | ]. cbn. intros (((a & b) & c) & (p₁ & p₂) & p₃ & p₄ & p₅) ; cbn in *. induction p₃, p₄, p₅. refine (hinhpr ((x ,, y ,, z) ,, _)) ; cbn. repeat split ; try (apply idpath). *** exact (maponpaths dirprod_pr1 p₁). *** exact (maponpaths dirprod_pr2 p₁). *** exact p₂. + intros X Y₁ Y₂ Z R. use funextsec ; intro x. induction x as [ [ x y ] z ]. use funextsec ; intro x'. induction x' as [ x' [ y' z' ]]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros ((a & b & c) & ((p₁ & p₂ & p₃) & (p₄ & p₅))) ; cbn in *. induction p₁, p₂, p₃. refine (hinhpr (((x' ,, y') ,, z) ,, _)) ; cbn. repeat split ; try (apply idpath). *** exact (maponpaths dirprod_pr1 p₄). *** exact p₅. *** exact (maponpaths dirprod_pr2 p₄). ** use factor_through_squash ; [ apply propproperty | ]. intros (((a & b) & c) & ((p₁ & p₂ & p₃) & (p₄ & p₅ & p₆))) ; cbn in *. induction p₁, p₂, p₄, p₅, p₆. refine (hinhpr ((x ,, y ,, z) ,, _)). repeat split ; try (apply idpath). exact p₃. + intros X₁ X₂ Y Z R. use funextsec ; intro x. induction x as [ [ x y ] z ]. use funextsec ; intro x'. induction x' as [ x' [ y' z' ]]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros ((a & b & c) & ((p₁ & p₂ & p₃) & (p₄ & p₅ & p₆))) ; cbn in *. induction p₁, p₂, p₃, p₄, p₅. refine (hinhpr (((x ,, y') ,, z) ,, _)) ; cbn. repeat split ; try (apply idpath). exact p₆. ** use factor_through_squash ; [ apply propproperty | ]. intros (((a & b) & c) & ((p₁ & p₂ & p₃) & (p₄ & p₅ & p₆))) ; cbn in *. induction p₁, p₂, p₄, p₅, p₆. refine (hinhpr ((x ,, y ,, z) ,, _)). repeat split ; try (apply idpath). exact p₃. + intros X Y Z. split. * use funextsec ; intro x. induction x as [[ x y ] z ]. use funextsec ; intro x'. induction x' as [[ x' y' ] z' ]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros ((a & b & c) & (p₁ & p₂ & p₃) & (p₄ & p₅ & p₆)) ; cbn in *. induction p₁, p₂, p₃, p₄, p₅, p₆. apply idpath. ** cbn ; intro p. refine (hinhpr ((x' ,, (y' ,, z')) ,, _)) ; cbn. repeat split ; try (apply idpath). *** exact (maponpaths dirprod_pr1 (maponpaths dirprod_pr1 p)). *** exact (maponpaths dirprod_pr2 (maponpaths dirprod_pr1 p)). *** exact (maponpaths dirprod_pr2 p). * use funextsec ; intro x. induction x as [ x [ y z ]]. use funextsec ; intro x'. induction x' as [ x' [ y' z' ]]. use hPropUnivalence. ** use factor_through_squash ; [ apply propproperty | ]. intros (((a & b) & c) & (p₁ & p₂ & p₃) & (p₄ & p₅ & p₆)) ; cbn in *. induction p₁, p₂, p₃, p₄, p₅, p₆. apply idpath. ** cbn ; intro p. refine (hinhpr (((x ,, y) ,, z) ,, _)) ; cbn. repeat split ; try (apply idpath). *** exact (maponpaths dirprod_pr1 p). *** exact (maponpaths dirprod_pr1 (maponpaths dirprod_pr2 p)). *** exact (maponpaths dirprod_pr2 (maponpaths dirprod_pr2 p)). - intros X Y. use funextsec ; intro x. induction x as [ [ x [] ] y ]. use funextsec ; intro x'. induction x' as [ x' y' ]. use hPropUnivalence. + use factor_through_squash ; [ apply propproperty | ] ; cbn. intros ( (a & [] & b) & ((p₁ & p₂ & p₃) & (p₄ & p₅)) ) ; cbn in *. induction p₁, p₃, p₄, p₅. split ; apply idpath. + intros [ p q ] ; cbn in *. induction p, q. refine (hinhpr ((x ,, (tt ,, y)) ,, _)) ; cbn. repeat split ; apply idpath. - intros W X Y Z. use funextsec ; intros (((w & x) & y) & z). use funextsec ; intros (w' & x' & y' & z'). use hPropUnivalence. + use factor_through_squash ; [ apply propproperty | ]. intros ((a & (b & c) & d) & (p₁ & p₂ & p₃ & p₄ & p₅)). cbn in p₂, p₃, p₄, p₅. induction p₂, p₃, p₄, p₅. use (factor_through_squash _ _ p₁) ; [ apply propproperty | ] ; clear p₁ ; cbn. intros (((a' & b' & c') & d') & ((p₁ & p₂ & p₃ & p₄) & (p₅ & p₆ & p₇))) ; cbn in *. induction p₁, p₂, p₃, p₄, p₅, p₇. refine (hinhpr (((w ,, x) ,, (y ,, z)) ,, _)) ; cbn. repeat split ; try (apply idpath). * exact (maponpaths dirprod_pr1 p₆). * apply maponpaths_2. exact (maponpaths dirprod_pr2 p₆). + use factor_through_squash ; [ apply propproperty | ]. intros (((a & b) & c & d) & ((p₁ & p₂ & p₃) & (p₄ & p₅ & p₆))) ; cbn in *. induction p₂, p₃, p₄, p₅. refine (hinhpr ((w ,, ((x ,, y) ,, z)) ,, hinhpr (((w ,, (x ,, y)) ,, z) ,, _) ,, _)) ; cbn ; repeat split. * exact (maponpaths dirprod_pr1 p₁). * exact (maponpaths dirprod_pr2 p₁). * exact (maponpaths dirprod_pr1 p₆). * exact (maponpaths dirprod_pr2 p₆). Qed. Definition monoidal_REL : monoidal REL := monoidal_data_REL ,, monoidal_laws_REL. Definition REL_monoidal_cat : monoidal_cat := REL ,, monoidal_REL. (** 2. It is symmetric *) Definition REL_braiding (X Y : hSet) : bin_hrel (X × Y)%set (Y × X)%set := (λ xy yx, pr1 xy = pr2 yx ∧ pr2 xy = pr1 yx)%logic. Proposition REL_braiding_laws : sym_mon_cat_laws_tensored REL_monoidal_cat REL_braiding. Proof. repeat split. - intros X Y. use funextsec ; intro xy₁. induction xy₁ as [ y₁ x₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ y₂ x₂ ] ; cbn. use hPropUnivalence. + use factor_through_squash ; [ apply propproperty | ]. intros [ y [ [ p₁ p₂ ] [ q₁ q₂ ]]] ; cbn in *. induction y as [ a b ] ; cbn in *. induction p₁, p₂, q₁, q₂. apply idpath. + intros p. refine (hinhpr ((_ ,, _) ,, ((idpath _ ,, idpath _) ,, (_ ,, _)))) ; cbn. * exact (maponpaths dirprod_pr2 p). * exact (maponpaths dirprod_pr1 p). - intros X₁ X₂ Y₁ Y₂ R₁ R₂. use funextsec ; intro xy₁. induction xy₁ as [ y₁ x₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ y₂ x₂ ]. use hPropUnivalence. + use factor_through_squash ; [ apply propproperty | ]. intros [ [ a b ] [ p [ q₁ q₂ ]]] ; cbn in q₁, q₂. induction q₁, q₂. use (factor_through_squash _ _ p) ; [ apply propproperty | ] ; cbn ; clear p. intros [ [ c d ] [ [ p₁ p₂ ] [ q₁ q₂ ] ]]. apply hinhpr ; cbn in *. induction p₁, q₁. refine ((x₁ ,, y₁) ,, ((idpath _ ,, idpath _) ,, hinhpr _)) ; cbn. refine ((b ,, y₁) ,, ((idpath _ ,, _) ,, (idpath _ ,, _))) ; cbn. * exact q₂. * exact p₂. + use factor_through_squash ; [ apply propproperty | ]. intros [ [ a b ] [ [ p₁ p₂ ] q]] ; cbn in p₁, p₂. induction p₁, p₂. use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; cbn ; clear q. intros [ [ c d ] [ [ p₁ p₂ ] [ q₁ q₂ ] ]]. apply hinhpr ; cbn in *. induction p₁, q₁. refine ((x₂ ,, c) ,, (hinhpr _ ,, (idpath _ ,, idpath _))) ; cbn. refine ((x₂ ,, x₁) ,, ((idpath _ ,, _) ,, (idpath _ ,, _))) ; cbn. * exact q₂. * exact p₂. - intros X Y Z. use funextsec ; intro xy₁. induction xy₁ as [ [ x₁ y₁ ] z₁ ]. use funextsec ; intro xy₂. induction xy₂ as [ y₂ [ z₂ x₂ ]]. use hPropUnivalence. + use factor_through_squash ; [ apply propproperty | ]. intros ( ((y & z) & x) & q & p₁ & p₂ & p₃). cbn in p₁, p₂, p₃. induction p₁, p₂, p₃. use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; cbn ; clear q. intros ( (a & b & c) & ( p₁ & ( p₂ & p₃ ) ) & ( p₄ & p₅ ) ). cbn in *. induction p₁, p₂, p₃, p₄. refine (hinhpr ((y ,, x₁ ,, z) ,, hinhpr _ ,, hinhpr _)). * refine (((y ,, x₁) ,, z) ,, hinhpr (((y ,, x₁) ,, z) ,, _) ,, _) ; repeat split ; try (apply idpath) ; cbn. ** exact (maponpaths dirprod_pr2 p₅). ** exact (maponpaths dirprod_pr1 p₅). * refine ((y ,, (x₁ ,, z)) ,, ((_ ,, _) ,, (_ ,, (_ ,, _)))) ; apply idpath. + use factor_through_squash ; [ apply propproperty | ]. intros ((a & b & c) & (p₁ & p₂)). use (factor_through_squash _ _ p₁) ; [ apply propproperty | ] ; clear p₁. intros (((a' & b') & c') & (q₁ & q₂ & q₃ & q₄)). cbn in q₂, q₃, q₄. induction q₂, q₃, q₄. use (factor_through_squash _ _ p₂) ; [ apply propproperty | ] ; clear p₂. intros ((a'' & b'' & c'') & ((r₁ & r₂) & (r₃ & r₄ & r₅))). cbn in r₁, r₂, r₃, r₄, r₅. induction r₂, r₃, r₄, r₅. use (factor_through_squash _ _ q₁) ; [ apply propproperty | ] ; clear q₁. intros (((a''' & b''') & c''') & ((s₁ & s₂ & s₃) & s₄ & s₅)) ; cbn in *. induction s₁, s₂, s₃, s₅. refine (hinhpr (((y₁ ,, z₁) ,, x₁) ,, hinhpr ((x₁ ,, (y₁ ,, z₁)) ,, _) ,, _)) ; cbn ; repeat split ; try (apply idpath). * exact (maponpaths dirprod_pr1 s₄). * exact (maponpaths dirprod_pr2 r₁). * exact (maponpaths dirprod_pr2 s₄ @ maponpaths dirprod_pr1 r₁). Qed. Definition symmetric_REL_monoidal_cat : symmetric REL_monoidal_cat. Proof. use make_symmetric. - exact REL_braiding. - exact REL_braiding_laws. Defined. Definition REL_sym_monoidal_cat : sym_monoidal_cat := REL_monoidal_cat ,, symmetric_REL_monoidal_cat. (** 3. It is monoidal closed *) Definition REL_sym_mon_closed_cat : sym_mon_closed_cat. Proof. use make_sym_mon_closed_cat. - exact REL_sym_monoidal_cat. - exact (λ X Y, X × Y)%set. - exact (λ X Y xyx y, pr11 xyx = pr2 xyx ∧ pr21 xyx = y)%logic. - exact (λ X Y Z R z xy, R (z ,, pr1 xy) (pr2 xy)). - intros X Y Z R. use funextsec ; intros (z₁ & x₁). use funextsec ; intro y₁. use hPropUnivalence. + abstract (use factor_through_squash ; [ apply propproperty | ] ; intros (((x₂ & y₂) & x₃) & (q & p₁ & p₂)) ; cbn in p₁, p₂ ; induction p₁, p₂ ; use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; clear q ; cbn ; intros (((x₄ & y₃) & x₅) & ((p₁ & p₂) & p₃ & p₄)) ; cbn in * ; induction p₁, p₄ ; pose (maponpaths dirprod_pr1 p₃) as r₁ ; pose (maponpaths dirprod_pr2 p₃) as r₂ ; cbn in r₁, r₂ ; rewrite <- r₁, <- r₂ ; exact p₂). + abstract (intro r ; refine (hinhpr (((x₁ ,, y₁) ,, x₁) ,, _)) ; repeat split ; try (apply idpath) ; refine (hinhpr (((x₁ ,, y₁) ,, x₁) ,, _)) ; cbn ; repeat split ; try (apply idpath) ; exact r). - intros X Y Z R. use funextsec ; intro z. use funextsec ; intros (x & y). use hPropUnivalence. + abstract (intro r ; refine (hinhpr (((x ,, y) ,, x) ,, _)) ; repeat split ; try (apply idpath) ; refine (hinhpr (((x ,, y) ,, x) ,, _)) ; repeat split ; try (apply idpath) ; cbn ; exact r). + abstract (use factor_through_squash ; [ apply propproperty | ] ; intros (((x₂ & y₂) & x₃) & (q & p₁ & p₂)) ; cbn in p₁, p₂ ; induction p₁, p₂ ; use (factor_through_squash _ _ q) ; [ apply propproperty | ] ; clear q ; cbn ; intros (((x₄ & y₃) & x₅) & ((p₁ & p₂) & p₃ & p₄)) ; cbn in * ; induction p₁, p₄ ; pose (maponpaths dirprod_pr1 p₃) as r₁ ; pose (maponpaths dirprod_pr2 p₃) as r₂ ; cbn in r₁, r₂ ; rewrite <- r₁, <- r₂ ; exact p₂). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/SetCartesianMonoidal.v000066400000000000000000000040541451125700300274060ustar00rootroot00000000000000(** an elementary direct construction of the monoidal category one can also instantiate the construction of cartesian monoidal categories [UniMath.CategoryTheory.Monoidal.CartesianMonoidalCategoriesWhiskered.SET_cartesian_monoidal] *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.categories.HSET.All. Local Open Scope cat. Section SetIsCartesianMonoidal. Definition SET_cart_tensor_data : bifunctor_data SET SET SET. Proof. repeat (use tpair). - intros x y. exact (((pr1 x × pr1 y),, isaset_dirprod (pr2 x) (pr2 y))). - intros x y1 y2 g a. exact (pr1 a,, g (pr2 a)). - intros y x1 x2 f b. exact (f (pr1 b),, pr2 b). Defined. Lemma SET_cart_tensor_laws : is_bifunctor SET_cart_tensor_data. Proof. repeat split. Qed. (* Definition SET_cart_tensor : tensor SET := (SET_cart_tensor_data,, SET_cart_tensor_laws). *) Definition SET_cart_monoidal_data : monoidal_data SET. Proof. use make_monoidal_data. - exact SET_cart_tensor_data. - exact (unit,, isasetunit). - exact (λ _ y, pr2 y). - exact (λ _ y, (tt,, y)). - exact (λ _ y, pr1 y). - exact (λ _ y, (y,, tt)). - intros x y z a. induction a as [[xx yy] zz]. exact (xx,, (yy,,zz)). - intros x y z a. induction a as [xx [yy zz]]. exact ((xx,, yy),,zz). Defined. Lemma SET_cart_monoidal_laws : monoidal_laws SET_cart_monoidal_data. Proof. split. - exact SET_cart_tensor_laws. - repeat split. + apply funextsec; intro a; induction a as [t a]; induction t; apply idpath. + apply funextsec; intro a; induction a as [a t]; induction t; apply idpath. Qed. Definition SET_cart_monoidal : monoidal SET := (SET_cart_monoidal_data,, SET_cart_monoidal_laws). Definition SET_monoidal_cat : monoidal_cat := SET ,, SET_cart_monoidal. End SetIsCartesianMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/SetWithSubset.v000066400000000000000000000155141451125700300261160ustar00rootroot00000000000000(* In this file we construct the category whose objects are pairs, consisting of a set and a subset of that set, as a displayed category. Furthermore, we show that this displayed category is monoidal and we construct a monoidal section which maps a set X to (X,X) (where the second X is considered to be maximal subset of X). *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalSections. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.SetCartesianMonoidal. Section SetWithSubset. Local Definition setsubtype (X : HSET) : UU := hsubtype (pr1 X). Definition SS_disp_cat_ob_mor : disp_cat_ob_mor hset_category. Proof. use tpair. - exact (λ X, setsubtype X). - exact (λ _ _ U V f, hsubtype_preserving U V f). Defined. Definition SS_disp_cat_data : disp_cat_data hset_category. Proof. exists SS_disp_cat_ob_mor. use tpair. - intro ; intro. apply id_hsubtype_preserving. - intros ? ? ? ? ? ? ? ? fsp gsp. apply (comp_hsubtype_preserving fsp gsp). Defined. Lemma SS_disp_cat_locally_prop : locally_propositional SS_disp_cat_data. Proof. intro; intros; apply isaprop_hsubtype_preserving. Qed. Definition SS_disp_cat : disp_cat hset_category. Proof. use make_disp_cat_locally_prop. - exact SS_disp_cat_data. - exact SS_disp_cat_locally_prop. Defined. Definition total_subset_section_data : section_disp_data SS_disp_cat. Proof. exists (λ X, totalsubtype (pr1 X)). intro ; intros. apply total_hsubtype_preserving. Defined. Definition total_subset_section_axioms : section_disp_axioms total_subset_section_data. Proof. use tpair. - intro ; repeat (apply funextsec ; intro) ; apply totalsubtype. - intro ; intros ; repeat (apply funextsec ; intro) ; apply totalsubtype. Qed. Definition total_subset_section : section_disp SS_disp_cat := total_subset_section_data ,, total_subset_section_axioms. End SetWithSubset. Section SetWithSubsetMonoidal. Definition SS_disp_cat_tensor_data : disp_bifunctor_data SET_cart_monoidal SS_disp_cat SS_disp_cat SS_disp_cat. Proof. exists (λ _ _ U V, subtypesdirprod U V). split. - intros X Y1 Y2 g Ux U1 U2 gsp. intros xy2 xy1_prop. use (factor_through_squash _ _ xy1_prop). { apply subtypesdirprod. } intro xy1. split. + rewrite (! pr12 xy1). exact (pr122 xy1). + simpl in *. apply (gsp _). apply hinhpr. exists (pr21 xy1). split. * rewrite (! pr12 xy1). apply idpath. * exact (pr222 xy1). - intros X1 X2 Y f U1 U2 Uy fsp. intros x2y x1y_prop. use (factor_through_squash _ _ x1y_prop). { apply subtypesdirprod. } intro x1y. split. + simpl in *. apply (fsp _). apply hinhpr. exists (pr11 x1y). split. * rewrite (! pr12 x1y). apply idpath. * exact (pr122 x1y). + rewrite (! pr12 x1y). exact (pr222 x1y). Defined. Definition SS_disp_cat_tensor : disp_tensor SS_disp_cat SET_cart_monoidal. Proof. use make_disp_bifunctor_locally_prop. - exact SS_disp_cat_locally_prop. - exact SS_disp_cat_tensor_data. Defined. Definition SS_disp_monoidal_data : disp_monoidal_data SS_disp_cat SET_cart_monoidal. Proof. exists (SS_disp_cat_tensor). exists (totalsubtype (pr1 unitHSET)). repeat (use tpair). - intros X U x xinU_prop. use (factor_through_squash _ _ xinU_prop). { apply U. } intro xinU. rewrite (! pr12 xinU). exact (pr222 xinU). - intros X U x xinU_prop. exists tt. use (factor_through_squash _ _ xinU_prop). { apply U. } intro xinU. rewrite (! pr12 xinU). exact (pr22 xinU). - intros X U x xinU_prop. use (factor_through_squash _ _ xinU_prop). { apply U. } intro xinU. rewrite (! pr12 xinU). exact (pr122 xinU). - intros X U x xinU_prop. refine (_ ,, tt). use (factor_through_squash _ _ xinU_prop). { apply U. } intro xinU. rewrite (! pr12 xinU). exact (pr22 xinU). - intros X Y Z U V W xyz xyzinUVW_prop. use (factor_through_squash _ _ xyzinUVW_prop). { repeat (apply isapropdirprod). + apply U. + apply V. + apply W. } intro xyzinUVW. rewrite (! pr12 xyzinUVW). repeat split ; apply (pr22 xyzinUVW). - intros X Y Z U V W xyz xyzinUVW_prop. use (factor_through_squash _ _ xyzinUVW_prop). { repeat (apply isapropdirprod). + apply U. + apply V. + apply W. } intro xyzinUVW. rewrite (! pr12 xyzinUVW). repeat split ; apply (pr22 xyzinUVW). Defined. Definition SS_disp_monoidal : disp_monoidal SS_disp_cat SET_cart_monoidal. Proof. apply make_disp_monoidal_locally_prop. - exact SS_disp_cat_locally_prop. - exact SS_disp_monoidal_data. Defined. Definition total_subset_section_monoidal_data : smonoidal_data SET_cart_monoidal SS_disp_monoidal total_subset_section. Proof. use tpair. - exact (λ _ _ _ _, tt). - exact (λ _ _, tt). Defined. Definition total_subset_section_monoidal_ax : smonoidal_laxlaws _ _ total_subset_section_monoidal_data. Proof. repeat split ; repeat (intro ; intros ; apply isaprop_hsubtype_preserving). Qed. Definition total_subset_section_monoidal_lax : smonoidal_lax SET_cart_monoidal SS_disp_monoidal total_subset_section := total_subset_section_monoidal_data,, total_subset_section_monoidal_ax. Definition total_subset_section_monoidal : smonoidal SET_cart_monoidal SS_disp_monoidal total_subset_section. Proof. exists (total_subset_section_monoidal_lax). use tpair. - intros X Y. repeat (use tpair) ; repeat (apply isaprop_hsubtype_preserving). exists tt. exact tt. - repeat (use tpair) ; repeat (apply isaprop_hsubtype_preserving). exact (λ _ _, tt). Defined. End SetWithSubsetMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/Sigma.v000066400000000000000000000302131451125700300243720ustar00rootroot00000000000000(* In this file, we construct a displayed monoidal structure on the sigma construction (of displayed categories), given both displayed categories have a displayed monoidal structure. For simplicity, we assume that the upper-most displayed category is locally propositional (this assumption is satisfied for the instantiations). Contents: 1. SigmaConstruction: Constructs the monoidal structure [sigma_disp_cat_monoidal]; 2. SigmaConstructionSymmetric: Constructs a symmetric monoidal structure [sigma_disp_cat_monoidal_symmetric]; 3. Dirprodconstruction: Explicit construction of the product of displayed monoidal categories [dirprod_disp_cat_monoidal, dirprod_disp_cat_symmetric_monoidal]. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Open Scope mor_disp_scope. Import MonoidalNotations. Import DisplayedBifunctorNotations. Section SigmaConstruction. Context {C : category} {M : monoidal C} {D : disp_cat C} {DM : disp_monoidal D M} {E : disp_cat (total_category D)} (EM : disp_monoidal E (total_monoidal DM)). Context (E_prop : locally_propositional E). Definition sigma_disp_cat_tensor_data : disp_bifunctor_data M (sigma_disp_cat E) (sigma_disp_cat E) (sigma_disp_cat E). Proof. simple refine (_ ,, (_ ,, _)). - intros x y [xx xxx] [yy yyy]. exists (xx ⊗⊗_{DM} yy). exact (xxx ⊗⊗_{EM} yyy). - intros x y1 y2 g [xx xxx] [yy1 yyy1] [yy2 yyy2] [gg ggg]. exists (xx ⊗⊗^{DM}_{l} gg). exact (xxx ⊗⊗^{EM}_{l} ggg). - intros y1 y2 x g [yy1 yyy1] [yy2 yyy2] [xx xxx] [gg ggg]. exists (gg ⊗⊗^{DM}_{r} xx). exact (ggg ⊗⊗^{EM}_{r} xxx). Defined. Lemma sigma_disp_is_tensor : is_disp_bifunctor M sigma_disp_cat_tensor_data. Proof. repeat split. - intros x y [xx xxx] [yy yyy]. use total2_paths_f. + refine (disp_bifunctor_leftid DM x y xx yy @ _). apply pathsinv0, pr1_transportf. + apply E_prop. - intros x y [xx xxx] [yy yyy]. use total2_paths_f. + refine (disp_bifunctor_rightid DM x y xx yy @ _). apply pathsinv0, pr1_transportf. + apply E_prop. - intro ; intros. use total2_paths_f. + refine (disp_bifunctor_leftcomp DM _ _ _ _ _ _ _ _ _ _ _ _ @ _). apply pathsinv0, pr1_transportf. + apply E_prop. - intro ; intros. use total2_paths_f. + refine (disp_bifunctor_rightcomp DM _ _ _ _ _ _ _ _ _ _ _ _ @ _). apply pathsinv0, pr1_transportf. + apply E_prop. - intro ; intros. use total2_paths_f. + etrans. { apply disp_bifunctor_equalwhiskers. } apply pathsinv0, pr1_transportf. + apply E_prop. Qed. Definition sigma_disp_cat_tensor : disp_tensor (sigma_disp_cat E) M. Proof. exists sigma_disp_cat_tensor_data. apply sigma_disp_is_tensor. Defined. Definition sigma_disp_cat_unit : sigma_disp_cat E I_{M} := (disp_monoidal_unit DM,, disp_monoidal_unit EM). Definition sigma_disp_cat_lunitor : disp_leftunitor_data sigma_disp_cat_tensor sigma_disp_cat_unit. Proof. intros x [xx xxx]. exists (disp_monoidal_leftunitor DM _ xx). exact (disp_monoidal_leftunitor EM _ xxx). Defined. Definition sigma_disp_cat_lunitorinv : disp_leftunitorinv_data sigma_disp_cat_tensor sigma_disp_cat_unit. Proof. intros x [xx xxx]. exists (disp_monoidal_leftunitorinv DM _ xx). exact (disp_monoidal_leftunitorinv EM _ xxx). Defined. Definition sigma_disp_cat_runitor : disp_rightunitor_data sigma_disp_cat_tensor sigma_disp_cat_unit. Proof. intros x [xx xxx]. exists (disp_monoidal_rightunitor DM _ xx). exact (disp_monoidal_rightunitor EM _ xxx). Defined. Definition sigma_disp_cat_runitorinv : disp_rightunitorinv_data sigma_disp_cat_tensor sigma_disp_cat_unit. Proof. intros x [xx xxx]. exists (disp_monoidal_rightunitorinv DM _ xx). exact (disp_monoidal_rightunitorinv EM _ xxx). Defined. Definition sigma_disp_cat_associator : disp_associator_data sigma_disp_cat_tensor. Proof. intros x y z [xx xxx] [yy yyy] [zz zzz]. exists (disp_monoidal_associator DM _ _ _ xx yy zz). exact (disp_monoidal_associator EM _ _ _ xxx yyy zzz). Defined. Definition sigma_disp_cat_associatorinv : disp_associatorinv_data sigma_disp_cat_tensor. Proof. intros x y z [xx xxx] [yy yyy] [zz zzz]. exists (disp_monoidal_associatorinv DM _ _ _ xx yy zz). exact (disp_monoidal_associatorinv EM _ _ _ xxx yyy zzz). Defined. Definition sigma_disp_cat_monoidal_data : disp_monoidal_data (sigma_disp_cat E) M. Proof. exists sigma_disp_cat_tensor. exists (disp_monoidal_unit DM ,, disp_monoidal_unit EM). exists sigma_disp_cat_lunitor. exists sigma_disp_cat_lunitorinv. exists sigma_disp_cat_runitor. exists sigma_disp_cat_runitorinv. exists sigma_disp_cat_associator. exact sigma_disp_cat_associatorinv. Defined. Lemma sigma_disp_cat_monoidal_laws : disp_monoidal_laws sigma_disp_cat_monoidal_data. Proof. repeat split ; try (intro ; intros) ; use total2_paths_f ; try (apply E_prop). - etrans. { apply (disp_monoidal_leftunitornat DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_leftunitoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_leftunitoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_rightunitornat DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_rightunitoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_rightunitoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_associatornatleft DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_associatornatright DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_associatornatleftright DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_associatoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_associatoriso DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_triangleidentity DM). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_monoidal_pentagonidentity DM). } apply pathsinv0, pr1_transportf. Qed. Definition sigma_disp_cat_monoidal : disp_monoidal (sigma_disp_cat E) M. Proof. exists sigma_disp_cat_monoidal_data. exact sigma_disp_cat_monoidal_laws. Defined. End SigmaConstruction. Section SigmaConstructionSymmetric. Context {C : category} {M : monoidal C} {S : symmetric M} {D : disp_cat C} {DM : disp_monoidal D M} {DS : disp_symmetric DM S} {E : disp_cat (total_category D)} {EM : disp_monoidal E (total_monoidal DM)} (ES : disp_symmetric EM (total_symmetric DM DS)). Context (E_prop : locally_propositional E). Definition sigma_disp_cat_monoidal_braiding_data : disp_braiding_data (sigma_disp_cat_monoidal EM E_prop) S. Proof. intros x y [xx xxx] [yy yyy]. use tpair. - apply DS. - exact (pr1 ES _ _ xxx yyy). Defined. Lemma sigma_disp_cat_monoidal_braiding_laws : disp_braiding_laws (sigma_disp_cat_monoidal EM E_prop) sigma_disp_cat_monoidal_braiding_data sigma_disp_cat_monoidal_braiding_data. Proof. repeat split ; try (intro ; intros) ; use total2_paths_f ; try (apply E_prop). - etrans. { apply pr1_transportf. } apply (disp_braiding_to_naturality_left DM DS). - etrans. { apply pr1_transportf. } apply (disp_braiding_to_naturality_right DM DS). - etrans. { apply (disp_braiding_to_inverses DM DS). } apply pathsinv0, pr1_transportf. - etrans. { apply (disp_braiding_to_inverses DM DS). } etrans. 2: { apply pathsinv0, pr1_transportf. } unfold transportb. apply maponpaths_2. apply homset_property. - etrans. 2: { apply (disp_braiding_to_hexagon1 _ DS). } apply pr1_transportf. - etrans. 2: { apply (disp_braiding_to_hexagon2 _ DS). } apply pr1_transportf. Qed. Definition sigma_disp_cat_monoidal_symmetric : disp_symmetric (sigma_disp_cat_monoidal EM E_prop) S. Proof. exists sigma_disp_cat_monoidal_braiding_data. exact sigma_disp_cat_monoidal_braiding_laws. Defined. End SigmaConstructionSymmetric. Section DirprodConstruction. Import DisplayedMonoidalNotations. Context {C : category} {M : monoidal C} {D : disp_cat C} (DM : disp_monoidal D M) {D' : disp_cat C} (D'M : disp_monoidal D' M). Context (D_prop : locally_propositional D) (D'_prop : locally_propositional D'). Definition dirprod_disp_tensor : disp_bifunctor M (D × D') (D × D') (D × D'). Proof. simple refine ((_ ,, (_,,_)) ,, _). - intros x y xx yy. exact (pr1 xx ⊗⊗_{DM} pr1 yy ,, pr2 xx ⊗⊗_{D'M} pr2 yy). - intros x y1 y2 g xx yy1 yy2 gg. exact (pr1 xx ⊗⊗^{DM}_{l} pr1 gg ,, pr2 xx ⊗⊗^{D'M}_{l} pr2 gg). - intros y1 y2 x f yy1 yy2 xx ff. exact (pr1 ff ⊗⊗^{DM}_{r} pr1 xx ,, pr2 ff ⊗⊗^{D'M}_{r} pr2 xx). - abstract (repeat split ; (try (intro ; intros) ; use total2_paths_f ; [apply D_prop | apply D'_prop])). Defined. Definition dirprod_disp_cat_monoidal_data : disp_monoidal_data (dirprod_disp_cat D D') M. Proof. simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _). - exact dirprod_disp_tensor. - exact (dI_{DM} ,, dI_{D'M}). - intros x [x1 x2]. exact (dlu^{DM} _ x1 ,, dlu^{D'M} _ x2). - intros x [x1 x2]. exact (dluinv^{DM} _ x1 ,, dluinv^{D'M} _ x2). - intros x [x1 x2]. exact (dru^{DM} _ x1 ,, dru^{D'M} _ x2). - intros x [x1 x2]. exact (druinv^{DM} _ x1 ,, druinv^{D'M} _ x2). - intros x y z [x1 x2] [y1 y2] [z1 z2]. exact (dα^{DM} _ _ _ x1 y1 z1 ,, dα^{D'M} _ _ _ x2 y2 z2). - intros x y z [x1 x2] [y1 y2] [z1 z2]. exact (dαinv^{DM} _ _ _ x1 y1 z1 ,, dαinv^{D'M} _ _ _ x2 y2 z2). Defined. Definition dirprod_disp_cat_monoidal : disp_monoidal (dirprod_disp_cat D D') M. Proof. exists dirprod_disp_cat_monoidal_data. abstract (repeat split ; (try (intro ; intros) ; use total2_paths_f ; [apply D_prop | apply D'_prop])). Defined. Definition dirprod_disp_cat_symmetric_monoidal {S : symmetric M} (SM : disp_symmetric DM S) (S'M : disp_symmetric D'M S) : disp_symmetric dirprod_disp_cat_monoidal S. Proof. use tpair. - intros x y [x1 x2] [y1 y2]. exact (pr1 SM _ _ x1 y1 ,, pr1 S'M _ _ x2 y2). - abstract (repeat split ; (try (intro ; intros) ; use total2_paths_f ; [apply D_prop | apply D'_prop])). Defined. End DirprodConstruction. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/SmashProductMonoidal.v000066400000000000000000001012641451125700300274360ustar00rootroot00000000000000(***************************************************************** Monoidal category from smash products We show that every notion of structure that supports a smash product, gives rise to a symmetric monoidal closed category. Note that in the construction, we give two (equivalent) definitions for both of the associators. One of the two definition is convenient for calculation, while the other is better for proving that it is a structure preserving map. Contents 1. Tensor operation 2. Unitors 3. The braiding 4. The associators 5. The monoidal structure 6. It is symmetric 7. It is closed *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Section StructureSmashProduct. Context (P : hset_struct_with_smash_closed). Local Notation "∁" := (category_of_hset_struct P). (** 1. Tensor operation *) Definition hset_struct_smash_prod_mor_r (PX : ∁) {PY₁ PY₂ : ∁} (f : PY₁ --> PY₂) : PX ∧* PY₁ --> PX ∧* PY₂. Proof. simple refine (_ ,, _). - use map_from_smash. + exact (λ x y, setquotpr _ (x ,, pr1 f y)). + abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; exact (inl (idpath _) ,, inl (idpath _))). + abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inr _ ,, inl (idpath _)) ; apply pointed_hset_struct_preserve_point ; exact (pr2 f)). + abstract (intros x₁ x₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inr _ ,, inr _) ; apply (pointed_hset_struct_preserve_point _ (pr2 f))). - abstract (apply hset_struct_with_smash_map_from_smash ; refine (hset_struct_comp P _ (hset_struct_with_smash_setquotpr _ (pr2 PX) (pr2 PY₂))) ; use hset_struct_pair ; [ apply hset_struct_pr1 | refine (hset_struct_comp P _ (pr2 f)) ; apply hset_struct_pr2 ]). Defined. Definition hset_struct_smash_prod_mor_l (PY : ∁) {PX₁ PX₂ : ∁} (f : PX₁ --> PX₂) : PX₁ ∧* PY --> PX₂ ∧* PY. Proof. simple refine (_ ,, _). - use map_from_smash. + exact (λ x y, setquotpr _ (pr1 f x ,, y)). + abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inl _ ,, inl _) ; apply (pointed_hset_struct_preserve_point _ (pr2 f))). + abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inr (idpath _) ,, inl _) ; apply pointed_hset_struct_preserve_point ; exact (pr2 f)). + abstract (intros x₁ x₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; exact (inr (idpath _) ,, inr (idpath _))). - abstract (apply hset_struct_with_smash_map_from_smash ; refine (hset_struct_comp P _ (hset_struct_with_smash_setquotpr _ (pr2 PX₂) (pr2 PY))) ; use hset_struct_pair ; [ refine (hset_struct_comp P _ (pr2 f)) ; apply hset_struct_pr1 | apply hset_struct_pr2 ]). Defined. Definition hset_struct_smash_prod_mor {PY₁ PY₂ : ∁} {PX₁ PX₂ : ∁} (f : PX₁ --> PX₂) (g : PY₁ --> PY₂) : PX₁ ∧* PY₁ --> PX₂ ∧* PY₂. Proof. simple refine (_ ,, _). - use map_from_smash. + exact (λ x y, setquotpr _ (pr1 f x ,, pr1 g y)). + abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inl _ ,, inl _) ; apply (pointed_hset_struct_preserve_point _ (pr2 f))). + abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inr _ ,, inl _) ; unfold product_point_coordinate ; cbn ; apply pointed_hset_struct_preserve_point ; [ exact (pr2 g) | exact (pr2 f) ]). + abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; refine (inr _ ,, inr _) ; unfold product_point_coordinate ; cbn ; apply pointed_hset_struct_preserve_point ; [ exact (pr2 g) | exact (pr2 g) ]). - abstract (apply hset_struct_with_smash_map_from_smash ; refine (hset_struct_comp P _ (hset_struct_with_smash_setquotpr _ (pr2 PX₂) (pr2 PY₂))) ; use hset_struct_pair ; [ refine (hset_struct_comp P _ (pr2 f)) ; apply hset_struct_pr1 | refine (hset_struct_comp P _ (pr2 g)) ; apply hset_struct_pr2 ]). Defined. Local Notation "f '#∧*' g" := (hset_struct_smash_prod_mor f g) (at level 30). Definition smash_product_tensor_data : tensor_data ∁. Proof. simple refine (_ ,, _ ,, _). - exact (λ X Y, X ∧* Y). - exact (λ X Y₁ Y₂ f, hset_struct_smash_prod_mor_r X f). - exact (λ Y X₁ X₂ f, hset_struct_smash_prod_mor_l Y f). Defined. (** 2. Unitors *) Definition hset_struct_smash_prod_lunitor : leftunitor_data smash_product_tensor_data (hset_struct_with_smash_closed_unit P). Proof. intros X. simple refine (_ ,, _). - use map_from_smash. + exact (λ b x, if b then x else hset_struct_point P (pr2 X)). + abstract (intros x₁ x₂ ; cbn ; rewrite hset_struct_with_smash_point_unit ; apply idpath). + abstract (intros b x ; cbn ; rewrite hset_struct_with_smash_point_unit ; induction b ; apply idpath). + abstract (intros b₁ b₂ ; cbn ; induction b₁ ; induction b₂ ; cbn ; apply idpath). - apply hset_struct_with_smash_map_from_smash. use (hset_struct_with_smash_map_bool (pr122 P)). + apply hset_struct_pr1. + apply hset_struct_pr2. Defined. Definition hset_struct_smash_prod_linvunitor : leftunitorinv_data smash_product_tensor_data (hset_struct_with_smash_closed_unit P). Proof. intros X. simple refine (_ ,, _). - exact (λ x, setquotpr _ (true ,, x)). - apply hset_struct_with_smash_setquotpr_r. Defined. Definition hset_struct_smash_prod_runitor : rightunitor_data smash_product_tensor_data (hset_struct_with_smash_closed_unit P). Proof. intros X. simple refine (_ ,, _). - use map_from_smash. + exact (λ x b, if b then x else hset_struct_point P (pr2 X)). + abstract (intros b₁ b₂ ; cbn ; induction b₁ ; induction b₂ ; cbn ; apply idpath). + abstract (intros x b ; cbn ; rewrite hset_struct_with_smash_point_unit ; induction b ; apply idpath). + abstract (intros x₁ x₂ ; cbn ; rewrite hset_struct_with_smash_point_unit ; apply idpath). - apply hset_struct_with_smash_map_from_smash. use (hset_struct_with_smash_map_bool (pr122 P)). + apply hset_struct_pr2. + apply hset_struct_pr1. Defined. Definition hset_struct_smash_prod_rinvunitor : rightunitorinv_data smash_product_tensor_data (hset_struct_with_smash_closed_unit P). Proof. intros X. simple refine (_ ,, _). - exact (λ x, setquotpr _ (x ,, true)). - apply hset_struct_with_smash_setquotpr_l. Defined. (** 3. The braiding *) Definition smash_product_monoidal_cat_braiding (X Y : category_of_hset_struct P) : X ∧* Y --> Y ∧* X. Proof. simple refine (_ ,, _). - use map_from_smash. + exact (λ x y, setquotpr _ (y ,, x)). + abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; use inr ; split ; use inr ; apply idpath). + abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; use inr ; split ; [ use inl | use inr ] ; apply idpath). + abstract (intros x₁ x₂ ; use iscompsetquotpr ; apply hinhpr ; use inr ; split ; use inl ; apply idpath). - apply hset_struct_with_smash_map_from_smash. refine (hset_struct_comp P _ (hset_struct_with_smash_setquotpr _ (pr2 Y) (pr2 X))). use hset_struct_pair. + apply hset_struct_pr2. + apply hset_struct_pr1. Defined. (** 4. The associators *) (** Note: `hset_struct_smash_prod_lassociator_mor` is used to prove that the associator is structure preserving, whereas `hset_struct_smash_prod_lassociator_mor_alt_fun` is used for calculations. *) Definition hset_struct_smash_unlam {X Y Z : ∁} (f : X --> Y -->* Z) : X ∧* Y --> Z := f #∧* identity _ · hset_struct_with_smash_closed_eval Y Z. Definition hset_struct_smash_unlam' {X Y Z : ∁} (f : Y --> X -->* Z) : X ∧* Y --> Z := smash_product_monoidal_cat_braiding _ _ · hset_struct_smash_unlam f. Definition hset_struct_smash_prod_lassociator_mor (X Y Z : ∁) : (X ∧* Y) ∧* Z --> X ∧* (Y ∧* Z). Proof. use hset_struct_smash_unlam. use hset_struct_smash_unlam. refine (_ · hset_struct_smash_enriched_uncurry _ _ _). use hset_struct_smash_closed_uncurry. apply identity. Defined. Definition hset_struct_smash_prod_lassociator_mor_alt_fun {X Y Z : ∁} (xy : pr11 (X ∧* Y)) (z : pr11 Z) : pr11 (X ∧* Y ∧* Z). Proof. revert xy. use map_from_smash'. - apply setproperty. - exact (λ x y, setquotpr _ (x ,, setquotpr _ (y ,, z))). - abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; use inr ; unfold product_point_coordinate ; cbn ; split ; use inl ; apply idpath). - abstract (intros x y ; use iscompsetquotpr ; apply hinhpr ; use inr ; unfold product_point_coordinate ; split ; [ | use inl ; apply idpath ] ; use inr ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)) ; use iscompsetquotpr ; cbn ; apply hinhpr ; use inr ; unfold product_point_coordinate ; cbn ; split ; use inl ; apply idpath). - abstract (intros x₁ x₂ ; use iscompsetquotpr ; apply hinhpr ; use inr ; unfold product_point_coordinate ; split ; cbn ; use inr ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)) ; use iscompsetquotpr ; cbn ; apply hinhpr ; use inr ; unfold product_point_coordinate ; split ; cbn ; use inl ; apply idpath). Defined. Proposition hset_struct_smash_prod_lassociator_mor_alt_eq1 {X Y Z : category_of_hset_struct P} (z₁ z₂ : pr11 Z) : hset_struct_smash_prod_lassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 (X ∧* Y))) z₁ = hset_struct_smash_prod_lassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 (X ∧* Y))) z₂. Proof. etrans. { apply maponpaths_2. apply hset_struct_with_smash_closed_point_smash. } refine (!_). etrans. { apply maponpaths_2. apply hset_struct_with_smash_closed_point_smash. } use iscompsetquotpr. apply hinhpr. use inr ; cbn. unfold product_point_coordinate ; cbn. split. - use inl. apply idpath. - use inl. apply idpath. Qed. Proposition hset_struct_smash_prod_lassociator_mor_alt_eq2 {X Y Z : category_of_hset_struct P} (xy : pr11 (X ∧* Y)) (z : pr11 Z) : hset_struct_smash_prod_lassociator_mor_alt_fun xy (hset_struct_point (pr12 P) (pr2 Z)) = hset_struct_smash_prod_lassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 (X ∧* Y))) z. Proof. revert xy. use setquotunivprop'. { intro. apply setproperty. } intros xy. induction xy as [ x y ]. refine (!_). etrans. { apply maponpaths_2. apply hset_struct_with_smash_closed_point_smash. } use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. - use inl. apply idpath. - use inr. refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)). use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inr. apply idpath. + use inr. apply idpath. Qed. Proposition hset_struct_smash_prod_lassociator_mor_alt_eq3 {X Y Z : category_of_hset_struct P} (xy₁ xy₂ : pr11 (X ∧* Y)) : hset_struct_smash_prod_lassociator_mor_alt_fun xy₁ (hset_struct_point (pr12 P) (pr2 Z)) = hset_struct_smash_prod_lassociator_mor_alt_fun xy₂ (hset_struct_point (pr12 P) (pr2 Z)). Proof. revert xy₁. use setquotunivprop'. { intro. apply setproperty. } intros xy₁. induction xy₁ as [ x₁ y₁ ]. revert xy₂. use setquotunivprop'. { intro. apply setproperty. } intros xy₂. induction xy₂ as [ x₂ y₂ ]. use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split ; use inr ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)). - use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inr. apply idpath. + use inr. apply idpath. - use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inr. apply idpath. + use inr. apply idpath. Qed. Definition hset_struct_smash_prod_lassociator_mor_alt (X Y Z : ∁) : pr11 ((X ∧* Y) ∧* Z) → pr11 (X ∧* (Y ∧* Z)). Proof. use map_from_smash'. - apply setproperty. - exact hset_struct_smash_prod_lassociator_mor_alt_fun. - exact hset_struct_smash_prod_lassociator_mor_alt_eq1. - exact hset_struct_smash_prod_lassociator_mor_alt_eq2. - exact hset_struct_smash_prod_lassociator_mor_alt_eq3. Defined. Definition hset_struct_smash_prod_lassociator_mor_eq_to_alt (X Y Z : ∁) : pr1 (hset_struct_smash_prod_lassociator_mor X Y Z) = hset_struct_smash_prod_lassociator_mor_alt X Y Z. Proof. use funextsec. use setquotunivprop'. { intro. apply setproperty. } intros xyz. induction xyz as [ xy z ]. revert xy. use setquotunivprop'. { intro. apply setproperty. } intros xy. induction xy as [ x y ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. Qed. Definition hset_struct_smash_prod_lassociator : associator_data smash_product_tensor_data. Proof. intros X Y Z. refine (hset_struct_smash_prod_lassociator_mor_alt X Y Z ,, _). abstract (exact (transportf (mor_hset_struct P _ _) (hset_struct_smash_prod_lassociator_mor_eq_to_alt X Y Z) (pr2 (hset_struct_smash_prod_lassociator_mor X Y Z)))). Defined. (** Note: `hset_struct_smash_prod_rassociator_mor` is used to prove that the associator is structure preserving, whereas `hset_struct_smash_prod_rassociator_mor_alt_fun` is used for calculations. *) Definition hset_struct_smash_prod_rassociator_mor (X Y Z : ∁) : X ∧* (Y ∧* Z) --> (X ∧* Y) ∧* Z. Proof. use hset_struct_smash_unlam'. use hset_struct_smash_unlam'. refine (_ · hset_struct_smash_enriched_uncurry _ _ _). use hset_struct_smash_closed_uncurry. refine (smash_product_monoidal_cat_braiding _ _ · _ #∧* identity _). apply smash_product_monoidal_cat_braiding. Defined. Definition hset_struct_smash_prod_rassociator_mor_alt_fun {X Y Z : ∁} (x : pr11 X) (yz : pr11 (Y ∧* Z)) : pr11 ((X ∧* Y) ∧* Z). Proof. revert yz. use map_from_smash'. - apply setproperty. - exact (λ y z, setquotpr _ (setquotpr _ (x ,, y) ,, z)). - abstract (intros z₁ z₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; unfold product_point_coordinate ; split ; use inl ; cbn ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)) ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; unfold product_point_coordinate ; split ; use inr ; apply idpath). - abstract (intros y z ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; unfold product_point_coordinate ; split ; cbn ; [ use inr ; apply idpath | ] ; use inl ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)) ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; unfold product_point_coordinate ; split ; use inr ; apply idpath). - abstract (intros y₁ y₂ ; use iscompsetquotpr ; apply hinhpr ; cbn ; use inr ; unfold product_point_coordinate ; split ; cbn ; use inr ; apply idpath). Defined. Proposition hset_struct_smash_prod_rassociator_mor_alt_eq1 {X Y Z : ∁} (yz₁ yz₂ : pr11 (Y ∧* Z)) : hset_struct_smash_prod_rassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 X)) yz₁ = hset_struct_smash_prod_rassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 X)) yz₂. Proof. revert yz₁. use setquotunivprop'. { intro. apply setproperty. } intros yz₁. induction yz₁ as [ y₁ z₁ ]. revert yz₂. use setquotunivprop'. { intro. apply setproperty. } intros yz₂. induction yz₂ as [ y₂ z₂ ]. use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split ; use inl ; refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)). - use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inl. apply idpath. + use inr. apply idpath. - use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inl. apply idpath. + use inr. apply idpath. Qed. Proposition hset_struct_smash_prod_rassociator_mor_alt_eq2 {X Y Z : ∁} (x : pr11 X) (yz : pr11 (Y ∧* Z)) : hset_struct_smash_prod_rassociator_mor_alt_fun x (hset_struct_point (pr12 P) (pr2 (Y ∧* Z))) = hset_struct_smash_prod_rassociator_mor_alt_fun (hset_struct_point (pr12 P) (pr2 X)) yz. Proof. revert yz. use setquotunivprop'. { intro. apply setproperty. } intros yz. induction yz as [ y z ]. etrans. { apply maponpaths. apply hset_struct_with_smash_closed_point_smash. } use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. - use inr. apply idpath. - use inl. refine (_ @ !(hset_struct_with_smash_closed_point_smash _ _)). use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. + use inl. apply idpath. + use inl. apply idpath. Qed. Proposition hset_struct_smash_prod_rassociator_mor_alt_eq3 {X Y Z : ∁} (x₁ x₂ : pr11 X) : hset_struct_smash_prod_rassociator_mor_alt_fun x₁ (hset_struct_point (pr12 P) (pr2 (Y ∧* Z))) = hset_struct_smash_prod_rassociator_mor_alt_fun x₂ (hset_struct_point (pr12 P) (pr2 (Y ∧* Z))). Proof. etrans. { apply maponpaths. apply hset_struct_with_smash_closed_point_smash. } refine (!_). etrans. { apply maponpaths. apply hset_struct_with_smash_closed_point_smash. } use iscompsetquotpr. apply hinhpr ; cbn. use inr. unfold product_point_coordinate ; cbn. split. - use inr. apply idpath. - use inr. apply idpath. Qed. Definition hset_struct_smash_prod_rassociator_mor_alt (X Y Z : ∁) : pr11 (X ∧* (Y ∧* Z)) → pr11 ((X ∧* Y) ∧* Z). Proof. use map_from_smash'. - apply setproperty. - exact hset_struct_smash_prod_rassociator_mor_alt_fun. - exact hset_struct_smash_prod_rassociator_mor_alt_eq1. - exact hset_struct_smash_prod_rassociator_mor_alt_eq2. - exact hset_struct_smash_prod_rassociator_mor_alt_eq3. Defined. Definition hset_struct_smash_prod_rassociator_mor_eq_to_alt (X Y Z : ∁) : pr1 (hset_struct_smash_prod_rassociator_mor X Y Z) = hset_struct_smash_prod_rassociator_mor_alt X Y Z. Proof. use funextsec. use setquotunivprop'. { intro. apply setproperty. } intros xyz. induction xyz as [ x yz ]. revert yz. use setquotunivprop'. { intro. apply setproperty. } intros yz. induction yz as [ y z ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. Qed. Definition hset_struct_smash_prod_rassociator : associatorinv_data smash_product_tensor_data. Proof. intros X Y Z. refine (hset_struct_smash_prod_rassociator_mor_alt X Y Z ,, _). abstract (exact (transportf (mor_hset_struct P _ _) (hset_struct_smash_prod_rassociator_mor_eq_to_alt X Y Z) (pr2 (hset_struct_smash_prod_rassociator_mor X Y Z)))). Defined. (** 5. The monoidal structure *) Definition smash_product_monoidal_data : monoidal_data (category_of_hset_struct P). Proof. use make_monoidal_data. - exact smash_product_tensor_data. - exact (hset_struct_with_smash_closed_unit P). - exact hset_struct_smash_prod_lunitor. - exact hset_struct_smash_prod_linvunitor. - exact hset_struct_smash_prod_runitor. - exact hset_struct_smash_prod_rinvunitor. - exact hset_struct_smash_prod_lassociator. - exact hset_struct_smash_prod_rassociator. Defined. Proposition smash_product_monoidal_laws : monoidal_laws smash_product_monoidal_data. Proof. repeat split. - intros X Y. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros X Y. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros W X Y Z g₁ g₂. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros W X Y Z f₁ f₂. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros X₁ X₂ Y₁ Y₂ f g. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros X Y f. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. induction x as [ b x ]. cbn in *. induction b. + apply idpath. + refine (!_). apply pointed_hset_struct_preserve_point. exact (pr2 f). - use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro z. induction z as [ b z ]. use iscompsetquotpr. apply hinhpr ; cbn. induction b ; cbn. + use inl. apply idpath. + use inr. split ; unfold product_point_coordinate ; cbn. * use inr. apply idpath. * use inl. rewrite hset_struct_with_smash_point_unit. apply idpath. - use eq_mor_hset_struct. intro z ; cbn. apply idpath. - intros X Y f. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros x. induction x as [ x b ]. cbn in *. induction b. + apply idpath. + refine (!_). apply pointed_hset_struct_preserve_point. exact (pr2 f). - use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro z. induction z as [ z b ]. use iscompsetquotpr. apply hinhpr ; cbn. induction b ; cbn. + use inl. apply idpath. + use inr. split ; unfold product_point_coordinate ; cbn. * use inl. apply idpath. * use inr. rewrite hset_struct_with_smash_point_unit. apply idpath. - use eq_mor_hset_struct. intro z ; cbn. apply idpath. - intros X Y Z₁ Z₂ h. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro z. induction z as [ xx y ]. revert xx. use setquotunivprop'. { intro. apply setproperty. } intro xx. induction xx as [ x₁ x₂ ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. - intros X₁ X₂ Y Z f. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro z. induction z as [ xx y ]. revert xx. use setquotunivprop'. { intro. apply setproperty. } intro xx. induction xx as [ x₁ x₂ ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. - intros X Y₁ Y₂ Z g. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro z. induction z as [ xx y ]. revert xx. use setquotunivprop'. { intro. apply setproperty. } intro xx. induction xx as [ x₁ x₂ ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. - use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro xyz. induction xyz as [ xy z' ]. revert xy. use setquotunivprop'. { intro. apply setproperty. } intro xy. induction xy as [ x' y' ]. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intro xyz. induction xyz as [ x' yz ]. revert yz. use setquotunivprop'. { intro. apply setproperty. } intro yz. induction yz as [ y' z' ]. use iscompsetquotpr. apply hinhpr ; cbn. use inl. apply idpath. - intros X Y. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros xby. induction xby as [ xb y ]. revert xb. use setquotunivprop'. { intro. apply setproperty. } intros xb. induction xb as [ x b ]. use iscompsetquotpr ; cbn. apply hinhpr. induction b. + exact (inl (idpath _)). + use inr. unfold product_point_coordinate ; cbn. split. * exact (inr (idpath _)). * exact (inl (idpath _)). - intros W X Y Z. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros wxyz. induction wxyz as [ wxy z ]. revert wxy. use setquotunivprop'. { intro. apply setproperty. } intros wxy. induction wxy as [ wx y ]. revert wx. use setquotunivprop'. { intro. apply setproperty. } intros wx. induction wx as [ w x ]. use iscompsetquotpr ; cbn. apply hinhpr. use inl. apply idpath. Qed. Definition smash_product_monoidal_cat : monoidal_cat := category_of_hset_struct P ,, smash_product_monoidal_data ,, smash_product_monoidal_laws. (** 6. It is symmetric *) Proposition smash_product_monoidal_cat_symmetric_laws : sym_mon_cat_laws_tensored smash_product_monoidal_cat smash_product_monoidal_cat_braiding. Proof. repeat split. - intros X Y. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros xy. induction xy as [ x y ]. use iscompsetquotpr ; cbn. apply hinhpr. exact (inl (idpath _)). - intros X₁ X₂ Y₁ Y₂ f g. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros xy. induction xy as [ x y ]. use iscompsetquotpr ; cbn. apply hinhpr. exact (inl (idpath _)). - intros X Y Z. use eq_mor_hset_struct. use setquotunivprop'. { intro. apply setproperty. } intros xyz. induction xyz as [ xy z ]. revert xy. use setquotunivprop'. { intro. apply setproperty. } intros xy. induction xy as [ x y ]. use iscompsetquotpr ; cbn. apply hinhpr. exact (inl (idpath _)). Qed. Definition smash_product_monoidal_cat_symmetric : symmetric smash_product_monoidal_cat. Proof. use make_symmetric. - exact smash_product_monoidal_cat_braiding. - exact smash_product_monoidal_cat_symmetric_laws. Defined. Definition smash_product_sym_monoidal_cat : sym_monoidal_cat := smash_product_monoidal_cat ,, smash_product_monoidal_cat_symmetric. (** 7. It is closed *) Definition smash_product_sym_mon_closed_cat : sym_mon_closed_cat. Proof. use make_sym_mon_closed_cat. - exact smash_product_sym_monoidal_cat. - exact (λ X Y, X -->* Y). - exact (λ PX PY, hset_struct_with_smash_closed_eval PX PY). - exact (λ X Y Z f, hset_struct_smash_closed_uncurry f). - abstract (intros X Y Z f ; use eq_mor_hset_struct ; use setquotunivprop' ; [ intro ; apply setproperty | ] ; intros zx ; induction zx as [ z x ] ; cbn ; apply idpath). - abstract (intros X Y Z f ; use eq_mor_hset_struct ; intros z ; use eq_mor_hset_struct ; intros x ; cbn ; apply idpath). Defined. End StructureSmashProduct. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/StructuresMonoidal.v000066400000000000000000000036631451125700300272110ustar00rootroot00000000000000(******************************************************************** The symmetric monoidal closed category of structured sets ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Definition monoidal_cat_of_hset_struct (P : hset_cartesian_struct) : monoidal_cat. Proof. refine (category_of_hset_struct P ,, _). use cartesian_monoidal. - exact (BinProducts_category_of_hset_struct P). - exact (Terminal_category_of_hset_struct P). Defined. Proposition is_cartesian_cat_of_hset_struct (P : hset_cartesian_struct) : is_cartesian (monoidal_cat_of_hset_struct P). Proof. apply is_cartesian_cartesian_monoidalcat. Qed. Definition sym_monoidal_cat_of_hset_struct (P : hset_cartesian_struct) : sym_monoidal_cat := monoidal_cat_of_hset_struct P ,, symmetric_cartesian_monoidalcat _ _ _. Definition sym_mon_closed_cat_of_hset_struct (P : hset_cartesian_closed_struct) : sym_mon_closed_cat. Proof. use sym_mon_closed_cartesian_cat. - exact (category_of_hset_struct P). - exact (BinProducts_category_of_hset_struct P). - exact (Terminal_category_of_hset_struct P). - exact (Exponentials_struct P). Defined. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/SymmetricMonoidalCoEilenbergMoore.v000066400000000000000000000137161451125700300321030ustar00rootroot00000000000000(** the Eilenberg-Moore category for a symmetric monoidal comonad as a symmetric monoidal category author: Ralph Matthes, August 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.Fullsub. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.SymmetricMonoidalDialgebras. Require Import UniMath.CategoryTheory.categories.CoEilenbergMoore. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section Construction. Context {C : category} {M : monoidal C} {HM : symmetric M} (T : symmetric_monoidal_comonad HM). Definition mon_cat_co_eilenberg_moore_base : monoidal (dialgebra (functor_identity C) T) := dialgebra_monoidal (identity_fmonoidal M) (lax_monoidal_from_symmetric_monoidal_comonad HM T). Definition sym_mon_cat_co_eilenberg_moore_base : symmetric mon_cat_co_eilenberg_moore_base. Proof. apply (dialgebra_symmetric_monoidal(Fm:=identity_fmonoidal M) (is_symmetric_monoidal_identity HM) (pr221 T)). Defined. Definition mon_cat_co_eilenberg_moore_extra_condition : dialgebra (functor_identity C) T -> UU := fun f => pr1 (co_eilenberg_moore_cat_pred T f). Definition cat_co_eilenberg_moore : category := full_subcat (dialgebra (functor_identity C) T) mon_cat_co_eilenberg_moore_extra_condition. Local Lemma unit_case : mon_cat_co_eilenberg_moore_extra_condition I_{ mon_cat_co_eilenberg_moore_base}. Proof. split. - cbn. unfold dialgebra_disp_unit. cbn. rewrite id_left. assert (H := symmetric_monoidal_comonad_extra_laws HM T). destruct H as [_ [_ H]]. exact H. - cbn. unfold dialgebra_disp_unit. cbn. rewrite id_left. assert (H := symmetric_monoidal_comonad_extra_laws HM T). destruct H as [[_ H] _]. exact H. Qed. Local Lemma tensor_case : ∏ (f g : dialgebra (functor_identity C) T) (Hf : mon_cat_co_eilenberg_moore_extra_condition f) (Hg : mon_cat_co_eilenberg_moore_extra_condition g), mon_cat_co_eilenberg_moore_extra_condition (f ⊗_{mon_cat_co_eilenberg_moore_base} g). Proof. intros. split. - cbn. unfold dialgebra_disp_tensor_op. cbn. rewrite id_left. assert (H := symmetric_monoidal_comonad_extra_laws HM T). destruct H as [_ [H _]]. red in H. rewrite assoc'. rewrite H. clear H. cbn. rewrite id_right. destruct Hf as [Hf _]. destruct Hg as [Hg _]. etrans. { apply pathsinv0, bifunctor_distributes_over_comp. + exact (bifunctor_leftcomp M). + exact (bifunctor_rightcomp M). + exact (bifunctor_equalwhiskers M). } etrans. { apply maponpaths_12. - exact Hf. - exact Hg. } apply bifunctor_distributes_over_id. + exact (bifunctor_leftid M). + exact (bifunctor_rightid M). - cbn. unfold dialgebra_disp_tensor_op. cbn. rewrite id_left. assert (H := symmetric_monoidal_comonad_extra_laws HM T). destruct H as [[H _] _]. red in H. rewrite assoc'. rewrite H. clear H. cbn. destruct Hf as [_ Hf]. destruct Hg as [_ Hg]. rewrite assoc. etrans. { apply cancel_postcomposition. etrans. { apply pathsinv0, bifunctor_distributes_over_comp. + exact (bifunctor_leftcomp M). + exact (bifunctor_rightcomp M). + exact (bifunctor_equalwhiskers M). } etrans. { apply maponpaths_12. - exact Hf. - exact Hg. } apply bifunctor_distributes_over_comp. + exact (bifunctor_leftcomp M). + exact (bifunctor_rightcomp M). + exact (bifunctor_equalwhiskers M). } clear Hf Hg. repeat rewrite assoc'. apply maponpaths. rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply (preservestensor_is_nattrans_full (fmonoidal_preservestensornatleft (lax_monoidal_from_symmetric_monoidal_comonad HM T)) (fmonoidal_preservestensornatright (lax_monoidal_from_symmetric_monoidal_comonad HM T))). Qed. Definition mon_cat_co_eilenberg_moore_category : category := full_subcat (dialgebra (functor_identity C) T) mon_cat_co_eilenberg_moore_extra_condition. Definition monoidal_cat_co_eilenberg_moore : monoidal _ := monoidal_fullsubcat mon_cat_co_eilenberg_moore_base mon_cat_co_eilenberg_moore_extra_condition unit_case tensor_case. (* slow: Check (monoidal_cat_co_eilenberg_moore : monoidal cat_co_eilenberg_moore). *) Definition symmetric_monoidal_cat_co_eilenberg_moore : symmetric monoidal_cat_co_eilenberg_moore. Proof. apply (symmetric_monoidal_fullsubcat mon_cat_co_eilenberg_moore_base mon_cat_co_eilenberg_moore_extra_condition unit_case tensor_case sym_mon_cat_co_eilenberg_moore_base). Defined. Definition sym_monoidal_cat_co_eilenberg_moore : sym_monoidal_cat. Proof. use tpair. - use tpair. + exact mon_cat_co_eilenberg_moore_category. + exact monoidal_cat_co_eilenberg_moore. - apply symmetric_monoidal_cat_co_eilenberg_moore. Defined. End Construction. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Examples/SymmetricMonoidalDialgebras.v000066400000000000000000000066261451125700300307620ustar00rootroot00000000000000(** ********************************************************** Contents : - constructs a displayed symmetric monoidal category that is displayed over the monoidal dialgebras, its total category is called the symmetric monoidal dialgebras ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. Local Open Scope mor_disp_scope. Section FixTwoSymmetricMonoidalFunctors. Import BifunctorNotations. Import MonoidalNotations. Import DisplayedBifunctorNotations. Import DisplayedMonoidalNotations. Context {A B : category} {V : monoidal A} {W : monoidal B} {HV : symmetric V} {HW : symmetric W} {F G : A ⟶ B} {Fm : fmonoidal V W F} {Gm : fmonoidal_lax V W G} (Fs : is_symmetric_monoidal_functor HV HW Fm) (Gs : is_symmetric_monoidal_functor HV HW Gm). Local Definition base_mon_disp : disp_monoidal (dialgebra_disp_cat F G) V := dialgebra_disp_monoidal Fm Gm. Lemma dialgebra_disp_symmetric_data : disp_symmetric_data base_mon_disp HV. Proof. intros x y xx yy. red in xx, yy. cbn in xx, yy. cbn. unfold dialgebra_disp_tensor_op. repeat rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,fmonoidal_preservestensorstrongly Fm x y)). etrans. { apply maponpaths. apply pathsinv0, Gs. } repeat rewrite assoc. apply cancel_postcomposition. cbn. etrans. 2: { do 2 apply cancel_postcomposition. exact (Fs x y). } etrans. 2: { apply cancel_postcomposition. rewrite assoc'. apply maponpaths. apply pathsinv0, (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservestensorstrongly Fm y x)). } rewrite id_right. apply (tensor_sym_mon_braiding (((B,,W):monoidal_cat),,HW)). Qed. Definition dialgebra_disp_symmetric_monoidal : disp_symmetric base_mon_disp HV. Proof. use make_disp_symmetric_locally_propositional. - apply is_locally_propositional_dialgebra_disp_cat. - exact dialgebra_disp_symmetric_data. Defined. Definition dialgebra_symmetric_monoidal : symmetric (dialgebra_monoidal Fm Gm) := total_symmetric base_mon_disp dialgebra_disp_symmetric_monoidal. End FixTwoSymmetricMonoidalFunctors. UniMath-20231010/UniMath/CategoryTheory/Monoidal/FunctorCategories.v000066400000000000000000000237711451125700300252150ustar00rootroot00000000000000(** some categories of monoidal functors and their univalence - the lax monoidal functors - the symmetric lax monoidal functors - the symmetric lax monoidal comonads (functors with counit and comultiplication) author: Ralph Matthes, August 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monads.Comonads. Local Open Scope cat. Section LaxMonoidalFunctorCategory. Context {C D : category} (M : monoidal C) (N : monoidal D). Definition disp_cat_lax_monoidal_functors : disp_cat [C,D]. Proof. use disp_struct. - intro F. exact (fmonoidal_lax M N F). - intros F G Fm Gm α. exact (is_mon_nat_trans Fm Gm α). - intros; apply isaprop_is_mon_nat_trans. - intros F Fm. apply is_mon_nat_trans_identity. - intros F G H Fm Gm Hm α β Hα Hβ. exact (is_mon_nat_trans_comp Fm Gm Hm α β Hα Hβ). Defined. Definition category_lax_monoidal_functors : category := total_category disp_cat_lax_monoidal_functors. Lemma lax_monoidal_functors_Pisset (F : C ⟶ D) : isaset (fmonoidal_lax M N F). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. { apply isasetdirprod. - apply impred; intro x; apply impred; intro y. apply D. - apply D. } intro fmd. apply isasetaprop. apply isaprop_fmonoidal_laxlaws. Qed. Lemma lax_monoidal_functors_Hstandard {F : C ⟶ D} (Fm Fm' : fmonoidal_lax M N F) : is_mon_nat_trans Fm Fm' (nat_trans_id (pr1 F)) → is_mon_nat_trans Fm' Fm (nat_trans_id (pr1 F)) → Fm = Fm'. Proof. intros H H'. apply fmonoidal_lax_eq. apply dirprodeq. - destruct H as [H _]. apply funextsec; intro c. apply funextsec; intro c'. assert (aux := H c c'). cbn in aux. rewrite id_right in aux. rewrite (bifunctor_distributes_over_id) in aux. + rewrite id_left in aux. exact aux. + apply (bifunctor_leftid N). + apply (bifunctor_rightid N). - destruct H as [_ H]. red in H. cbn in H. rewrite id_right in H. exact H. Qed. Definition is_univalent_disp_cat_lax_monoidal_functors : is_univalent_disp disp_cat_lax_monoidal_functors. Proof. use is_univalent_disp_from_SIP_data. - exact lax_monoidal_functors_Pisset. - intros F Fm Fm'. apply lax_monoidal_functors_Hstandard. Defined. End LaxMonoidalFunctorCategory. Definition is_univalent_category_lax_monoidal_functors {C D : category} (HD : is_univalent D) (M : monoidal C) (N : monoidal D) : is_univalent (category_lax_monoidal_functors M N). Proof. apply is_univalent_total_category. - apply is_univalent_functor_category. apply HD. - apply is_univalent_disp_cat_lax_monoidal_functors. Defined. Section SymmetricLaxMonoidalFunctorCategory. Context {C D : category} {M : monoidal C} {N : monoidal D} (HM : symmetric M) (HN : symmetric N). Definition disp_cat_symmetric_lax_monoidal_functors_aux : disp_cat (category_lax_monoidal_functors M N). Proof. use disp_full_sub. intro FFm. exact (is_symmetric_monoidal_functor HM HN (pr2 FFm)). Defined. Definition is_univalent_disp_cat_symmetric_lax_monoidal_functors_aux : is_univalent_disp disp_cat_symmetric_lax_monoidal_functors_aux. Proof. apply disp_full_sub_univalent. intro F. apply isaprop_is_symmetric_monoidal_functor. Defined. Definition disp_cat_symmetric_lax_monoidal_functors : disp_cat [C,D] := sigma_disp_cat disp_cat_symmetric_lax_monoidal_functors_aux. Definition category_symmetric_lax_monoidal_functors : category := total_category disp_cat_symmetric_lax_monoidal_functors. Definition is_univalent_disp_cat_symmetric_lax_monoidal_functors : is_univalent_disp disp_cat_symmetric_lax_monoidal_functors. Proof. apply is_univalent_sigma_disp. - apply is_univalent_disp_cat_lax_monoidal_functors. - apply is_univalent_disp_cat_symmetric_lax_monoidal_functors_aux. Defined. End SymmetricLaxMonoidalFunctorCategory. Definition is_univalent_category_symmetric_lax_monoidal_functors {C D : category} (HD : is_univalent D) {M : monoidal C} {N : monoidal D} (HM : symmetric M) (HN : symmetric N) : is_univalent (category_symmetric_lax_monoidal_functors HM HN). Proof. apply is_univalent_total_category. - apply is_univalent_functor_category. apply HD. - apply is_univalent_disp_cat_symmetric_lax_monoidal_functors. Defined. Section SymmetricMonoidalComonads. Context {C : category} {M : monoidal C} (HM : symmetric M). Definition symmetric_monoidal_comonads_extra_laws {F : C ⟶ C} (Fm : disp_cat_lax_monoidal_functors M M F) (δ : F ⟹ F ∙ F) (ε : F ⟹ functor_identity C) : UU := is_mon_nat_trans Fm (comp_fmonoidal_lax Fm Fm) δ × is_mon_nat_trans Fm (identity_fmonoidal_lax M) ε. Lemma isaprop_symmetric_monoidal_comonads_extra_laws {F : C ⟶ C} (Fm : disp_cat_lax_monoidal_functors M M F) (δ : F ⟹ F ∙ F) (ε : F ⟹ functor_identity C) : isaprop (symmetric_monoidal_comonads_extra_laws Fm δ ε). Proof. apply isapropdirprod; apply isaprop_is_mon_nat_trans. Qed. Definition disp_cat_symmetric_monoidal_comonads : disp_cat (category_symmetric_lax_monoidal_functors HM HM). Proof. use disp_struct. - intros [F [Fm Fs]]. use total2. + exact (comonads_category_disp F). + intro H. induction H as [[δ ε] _]. exact (symmetric_monoidal_comonads_extra_laws Fm δ ε). - intros F G T T' α. exact (disp_Comonad_Mor_laws (pr11 T) (pr11 T') (pr1 α)). - intros. apply isaprop_disp_Comonad_Mor_laws. - intros F T. apply comonads_category_id_subproof. exact (pr21 T). - intros F F' F'' T T' T'' α α' Hα Hα'. cbn in *. exact (comonads_category_comp_subproof (pr11 T) (pr21 T) (pr11 T') (pr21 T') (pr11 T'') (pr21 T'') _ _ Hα Hα'). Defined. Definition category_symmetric_monoidal_comonad : category := total_category disp_cat_symmetric_monoidal_comonads. Definition symmetric_monoidal_comonad : UU := ob category_symmetric_monoidal_comonad. Coercion comonad_from_symmetric_monoidal_comonad (T : symmetric_monoidal_comonad) : Comonad C := pr11 T ,, pr12 T. Definition lax_monoidal_from_symmetric_monoidal_comonad (T : symmetric_monoidal_comonad) : fmonoidal_lax M M T := pr121 T. Definition symmetric_monoidal_comonad_extra_laws (T : symmetric_monoidal_comonad) : symmetric_monoidal_comonads_extra_laws (pr121 T) (δ T) (ε T) := pr22 T. Definition make_symmetric_monoidal_comonad {T : Comonad C} {Tm : fmonoidal_lax M M (pr1 T)} (Ts : is_symmetric_monoidal_functor HM HM Tm) (Hδ : is_mon_nat_trans Tm (comp_fmonoidal_lax Tm Tm) (δ T)) (Hε : is_mon_nat_trans Tm (identity_fmonoidal_lax M) (ε T)) : symmetric_monoidal_comonad. Proof. use tpair. - use tpair. + exact (pr1 T). + exact (Tm,,Ts). - use tpair. + exact (pr2 T). + exact (Hδ,,Hε). Defined. Lemma category_symmetric_monoidal_comonad_disp_eq (F : category_symmetric_lax_monoidal_functors HM HM) (T T' : disp_cat_symmetric_monoidal_comonads F) : pr1 T = pr1 T' -> T = T'. Proof. intro H. induction T as [T Textralaws]. induction T' as [T' T'extralaws]. apply subtypePath. - intro; apply isaprop_symmetric_monoidal_comonads_extra_laws. - exact H. Qed. Lemma symmetric_monoidal_comonad_category_Pisset (smF : ∑ (F : C ⟶ C) (d : fmonoidal_lax M M F), is_symmetric_monoidal_functor HM HM d) : isaset (∑ H : ∑ T : disp_Comonad_data (pr1 smF), disp_Comonad_laws T, symmetric_monoidal_comonads_extra_laws (pr12 smF) (pr11 H) (pr21 H)). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. - apply isofhleveltotal2. { apply isasetdirprod; apply [C,C]. } intro T. apply isasetaprop. apply isaprop_disp_Comonad_laws. - intro TT. apply isasetaprop. apply isaprop_symmetric_monoidal_comonads_extra_laws. Qed. Lemma symmetric_monoidal_comonad_category_Hstandard (smF : ∑ (F : C ⟶ C) (d : fmonoidal_lax M M F), is_symmetric_monoidal_functor HM HM d) (TT TT' : ∑ H : ∑ T : disp_Comonad_data (pr1 smF), disp_Comonad_laws T, symmetric_monoidal_comonads_extra_laws (pr12 smF) (pr11 H) (pr21 H)) : disp_Comonad_Mor_laws (pr11 TT) (pr11 TT') (nat_trans_id (pr11 smF)) → disp_Comonad_Mor_laws (pr11 TT') (pr11 TT) (nat_trans_id (pr11 smF)) → TT = TT'. Proof. intros H H'. apply category_symmetric_monoidal_comonad_disp_eq. apply comonads_category_Hstandard; assumption. Qed. Definition is_univalent_disp_cat_symmetric_monoidal_comonads : is_univalent_disp disp_cat_symmetric_monoidal_comonads. Proof. use is_univalent_disp_from_SIP_data. - apply symmetric_monoidal_comonad_category_Pisset. - apply symmetric_monoidal_comonad_category_Hstandard. Defined. End SymmetricMonoidalComonads. Definition is_univalent_symmetric_monoidal_comonad {C : category} (HC : is_univalent C) {M : monoidal C} (HM : symmetric M) : is_univalent (category_symmetric_monoidal_comonad HM). Proof. apply is_univalent_total_category. - apply (is_univalent_category_symmetric_lax_monoidal_functors HC). - apply is_univalent_disp_cat_symmetric_monoidal_comonads. Defined. (** Alias for the bundled case *) Definition sym_monoidal_cmd (V : sym_monoidal_cat) : UU := symmetric_monoidal_comonad (pr2 V). Identity Coercion sym_monoidal_cmd_to_symmetric_monoidal_comonad : sym_monoidal_cmd >-> symmetric_monoidal_comonad. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Functors.v000066400000000000000000001643551451125700300233760ustar00rootroot00000000000000(*************************************************************************** Monoidal functors In this file, we define the several notions of functors between monoidal categories. Again we use a displayed approach where we define notions such as lax monoidal structures on functors. We also provide examples, such as the identity and composition. In the end, we provide bundled versions of these defintions. Note that for the bundled versions we reformulate the laws to guarantee the notation is consistent with the bundled versions for monoidal categories. Contents 1. Lax monoidal functors 2. Strong monoidal functors 3. Strict monoidal functors 4. Symmetric monoidal functors 5. The identity is strong monoidal 6. Composition preserves lax/strongly monoidal functors 7. Monoidal natural transformations 8. Inverses of monoidal natural transformations 9. Bundled versions 10. Builders for the bundled versions Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/MonoidalFunctorsWhiskered.v ***************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section local_helper_lemmas. Lemma iso_stable_under_equality {C : category} {x y : C} {f g : C⟦x,y⟧} (p : g = f) (Hf : is_z_isomorphism f) : is_z_isomorphism g. Proof. induction p. exact Hf. Qed. Lemma iso_stable_under_transportf {C : category} {x y z : C} {f : C⟦x,y⟧} (pf : y=z) (Hf : is_z_isomorphism f) : is_z_isomorphism (transportf _ pf f). Proof. induction pf. use Hf. Qed. Lemma iso_stable_under_equalitytransportf {C : category} {x y z : C} {f : C⟦x,y⟧} {g : C⟦x,z⟧} {pf : y = z} (qg : g = transportf _ pf f) (Hf : is_z_isomorphism f) : is_z_isomorphism g. Proof. use (iso_stable_under_equality qg). use (iso_stable_under_transportf). exact Hf. Qed. End local_helper_lemmas. Section MonoidalFunctors. (** 1. Lax monoidal functors *) (** (Weak) Monoidal functors **) (* Monoidal functor data *) Definition preserves_tensordata {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := ∏ (x y : C), D ⟦ F x ⊗_{ N} F y, F (x ⊗_{ M} y) ⟧. Definition preserves_unit {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := D ⟦ I_{N} , F I_{M} ⟧. Definition fmonoidal_data {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := preserves_tensordata M N F × preserves_unit M N F. Definition fmonoidal_preservestensordata {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd : fmonoidal_data M N F) : preserves_tensordata M N F := pr1 fmd. Definition fmonoidal_preservesunit {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd : fmonoidal_data M N F) : preserves_unit M N F := pr2 fmd. Lemma fmonoidal_data_eq {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd1 fmd2 : fmonoidal_data M N F) : (∏ x y : C, fmonoidal_preservestensordata fmd1 x y = fmonoidal_preservestensordata fmd2 x y) -> fmonoidal_preservesunit fmd1 = fmonoidal_preservesunit fmd2 -> fmd1 = fmd2. Proof. intros pT pU. use total2_paths_f. - do 2 (apply funextsec ; intro) ; apply pT. - rewrite transportf_const. apply pU. Qed. (** Properties **) Definition preserves_tensor_nat_left {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x y1 y2 : C) (g : C⟦y1,y2⟧), F x ⊗^{ N}_{l} # F g · pt x y2 = pt x y1 · # F (x ⊗^{ M}_{l} g). Definition preserves_tensor_nat_right {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x1 x2 y : C) (f : C⟦x1,x2⟧), # F f ⊗^{ N}_{r} F y · pt x2 y = pt x1 y · # F (f ⊗^{ M}_{r} y). Definition preserves_leftunitality {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) (pu : preserves_unit M N F) : UU := ∏ (x : C), (pu ⊗^{ N}_{r} F x) · (pt I_{M} x) · (# F lu^{ M }_{ x}) = lu^{ N }_{ F x}. Definition preserves_leftunitalityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) (pu : preserves_unit M N F) : UU := ∏ (x : C), luinv^{ N }_{ F x} · (pu ⊗^{ N}_{r} F x) · (pt I_{M} x) = # F luinv^{ M }_{ x}. Definition preserves_rightunitality {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) (pu : preserves_unit M N F) : UU := ∏ (x : C), ((F x ⊗^{ N}_{l} pu) · (pt x I_{M}) · (# F ru^{ M }_{ x}) = ru^{ N }_{ F x}). Definition preserves_rightunitalityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) (pu : preserves_unit M N F) : UU := ∏ (x : C), ruinv^{ N }_{ F x} · F x ⊗^{ N}_{l} pu · pt x I_{M} = # F ruinv^{ M }_{ x}. Definition preserves_associativity {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x y z : C), ((pt x y) ⊗^{N}_{r} (F z)) · (pt (x ⊗_{M} y) z) · (#F (α^{M}_{x,y,z})) = α^{N}_{F x, F y, F z} · ((F x) ⊗^{N}_{l} (pt y z)) · (pt x (y ⊗_{M} z)). Definition preserves_associativityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x y z : C), αinv^{N}_{F x, F y, F z} · ((pt x y) ⊗^{N}_{r} (F z)) · (pt (x ⊗_{M} y) z) = ((F x) ⊗^{N}_{l} (pt y z)) · (pt x (y ⊗_{M} z)) · (#F (αinv^{M}_{x,y,z})). Definition fmonoidal_laxlaws {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd : fmonoidal_data M N F) : UU := (preserves_tensor_nat_left (fmonoidal_preservestensordata fmd)) × (preserves_tensor_nat_right (fmonoidal_preservestensordata fmd)) × (preserves_associativity (fmonoidal_preservestensordata fmd)) × (preserves_leftunitality (fmonoidal_preservestensordata fmd) (fmonoidal_preservesunit fmd)) × (preserves_rightunitality (fmonoidal_preservestensordata fmd) (fmonoidal_preservesunit fmd)). Lemma isaprop_fmonoidal_laxlaws {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd : fmonoidal_data M N F) : isaprop (fmonoidal_laxlaws fmd). Proof. repeat (apply isapropdirprod); repeat (apply impred; intro); apply D. Qed. Definition fmonoidal_lax {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := ∑ (fmd : fmonoidal_data M N F), fmonoidal_laxlaws fmd. Definition fmonoidal_fdata {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : fmonoidal_data M N F := pr1 fm. Coercion fmonoidal_fdata : fmonoidal_lax >-> fmonoidal_data. Lemma fmonoidal_lax_eq {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd fmd' : fmonoidal_lax M N F) : pr1 fmd = pr1 fmd' -> fmd = fmd'. Proof. intro H. apply subtypePath. - intro; apply isaprop_fmonoidal_laxlaws. - exact H. Qed. Definition fmonoidal_flaws {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : fmonoidal_laxlaws fm := pr2 fm. Definition fmonoidal_preservestensornatleft {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_tensor_nat_left (fmonoidal_preservestensordata fm) := pr12 fm. Definition fmonoidal_preservestensornatright {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_tensor_nat_right (fmonoidal_preservestensordata fm) := pr122 fm. Definition fmonoidal_preservesassociativity {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_associativity (fmonoidal_preservestensordata fm) := pr1 (pr222 fm). Lemma fmonoidal_preservesassociativityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_associativityinv (fmonoidal_preservestensordata fm). Proof. intros x y z. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_associatorisolaw N _ _ _)). cbn. etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. apply fmonoidal_preservesassociativity. } repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. rewrite <- functor_comp. apply maponpaths. apply pathsinv0, (monoidal_associatorisolaw M). } rewrite functor_id. apply pathsinv0, id_right. Qed. Definition fmonoidal_preservesleftunitality {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_leftunitality (fmonoidal_preservestensordata fm) (fmonoidal_preservesunit fm) := pr12 (pr222 fm). Lemma fmonoidal_preservesleftunitalityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_leftunitalityinv (fmonoidal_preservestensordata fm) (fmonoidal_preservesunit fm). Proof. intro x. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_leftunitorisolaw N (F x))). cbn. rewrite <- (fmonoidal_preservesleftunitality fm). repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply pathsinv0, (pr1(monoidal_leftunitorisolaw M x)). } rewrite functor_id. apply pathsinv0, id_right. Qed. Definition fmonoidal_preservesrightunitality {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_rightunitality (fmonoidal_preservestensordata fm) (fmonoidal_preservesunit fm) := pr22 (pr222 fm). Lemma fmonoidal_preservesrightunitalityinv {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fm : fmonoidal_lax M N F) : preserves_rightunitalityinv (fmonoidal_preservestensordata fm) (fmonoidal_preservesunit fm). Proof. intro x. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,_,, monoidal_rightunitorisolaw N (F x))). cbn. rewrite <- (fmonoidal_preservesrightunitality fm). repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply pathsinv0, (pr1(monoidal_rightunitorisolaw M x)). } rewrite functor_id. apply pathsinv0, id_right. Qed. Definition preserves_tensor_strongly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x y : C), is_z_isomorphism (pt x y). Definition pointwise_z_iso_from_preserves_tensor_strongly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (pts : preserves_tensor_strongly pt) (x y : C) : z_iso (F x ⊗_{ N} F y) (F (x ⊗_{ M} y)) := pt x y ,, pts x y. Lemma preserves_associativity_of_inverse_preserves_tensor {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (ptα : preserves_associativity pt) (pts : preserves_tensor_strongly pt) (x y z : C) : (is_z_isomorphism_mor (pts (x ⊗_{M} y) z)) · ((is_z_isomorphism_mor (pts x y)) ⊗^{N}_{r} (F z)) · α^{N}_{F x, F y, F z} = (#F (α^{M}_{x,y,z})) · (is_z_isomorphism_mor (pts x (y ⊗_{M} z))) · ((F x) ⊗^{N}_{l} (is_z_isomorphism_mor (pts y z))). Proof. set (ptsx_yz := pointwise_z_iso_from_preserves_tensor_strongly pts x (y ⊗_{M} z)). set (ptsxy_z := pointwise_z_iso_from_preserves_tensor_strongly pts (x ⊗_{M} y) z). set (ptsfx := functor_on_z_iso (leftwhiskering_functor N (F x)) (pointwise_z_iso_from_preserves_tensor_strongly pts y z)). set (ptsfz := functor_on_z_iso (rightwhiskering_functor N (F z)) (pointwise_z_iso_from_preserves_tensor_strongly pts x y)). apply (z_iso_inv_on_left _ _ _ _ ptsfx). apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ ptsx_yz). rewrite assoc'. rewrite assoc'. etrans. 2: { apply maponpaths. rewrite assoc. exact (ptα x y z). } etrans. 2: { rewrite assoc'. apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite assoc. apply maponpaths_2. exact (! pr222 ptsfz). } rewrite id_left. etrans. 2: { rewrite assoc. apply maponpaths_2. exact (! pr222 ptsxy_z). } apply (! id_left _). Qed. Lemma preserves_tensorinv_nat_right {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (pts : preserves_tensor_strongly pt) (ptrn : preserves_tensor_nat_right pt) (x1 x2 y : C) (f : C⟦x1,x2⟧) : (is_z_isomorphism_mor (pts x1 y)) · # F f ⊗^{ N}_{r} F y = # F (f ⊗^{ M}_{r} y) · (is_z_isomorphism_mor (pts x2 y)). Proof. set (ptiso := pt x1 y ,, pts x1 y : z_iso _ _). apply (z_iso_inv_on_right _ _ _ ptiso). rewrite assoc. etrans. 2: { apply maponpaths_2. apply ptrn. } rewrite assoc'. unfold is_z_isomorphism_mor. rewrite (pr12 (pts x2 y)). apply (! id_right _). Qed. Lemma preserves_tensorinv_nat_left {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (pts : preserves_tensor_strongly pt) (ptrn : preserves_tensor_nat_left pt) (x1 x2 y : C) (f : C⟦x1,x2⟧) : (is_z_isomorphism_mor (pts y x1)) · F y ⊗^{ N}_{l} # F f = # F (y ⊗^{ M}_{l} f) · (is_z_isomorphism_mor (pts y x2)). Proof. set (ptiso := pt y x1 ,, pts y x1 : z_iso _ _). apply (z_iso_inv_on_right _ _ _ ptiso). rewrite assoc. etrans. 2: { apply maponpaths_2. apply ptrn. } rewrite assoc'. unfold is_z_isomorphism_mor. rewrite (pr12 (pts y x2)). apply (! id_right _). Qed. Definition preserves_unit_strongly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pu : preserves_unit M N F) : UU := is_z_isomorphism pu. Definition fmonoidal_stronglaws {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) (pu : preserves_unit M N F) : UU := preserves_tensor_strongly pt × preserves_unit_strongly pu. Lemma isaprop_fmonoidal_stronglaws {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal_data M N F) : isaprop (fmonoidal_stronglaws (pr1 Fm) (pr2 Fm)). Proof. apply isapropdirprod ; repeat (apply impred_isaprop ; intro) ; apply isaprop_is_z_isomorphism. Qed. (** 2. Strong monoidal functors *) Definition fmonoidal {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := ∑ (Fm : fmonoidal_lax M N F), fmonoidal_stronglaws (fmonoidal_preservestensordata Fm) (fmonoidal_preservesunit Fm). Definition fmonoidal_fmonoidallax {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal M N F) : fmonoidal_lax M N F := pr1 Fm. Coercion fmonoidal_fmonoidallax : fmonoidal >-> fmonoidal_lax. Definition fmonoidal_preservestensorstrongly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal M N F) : preserves_tensor_strongly (fmonoidal_preservestensordata Fm) := pr12 Fm. Definition fmonoidal_preservesunitstrongly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal M N F) : preserves_unit_strongly (fmonoidal_preservesunit Fm) := pr22 Fm. Lemma fmonoidal_eq {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (fmd fmd' : fmonoidal M N F) : pr1 fmd = pr1 fmd' -> fmd = fmd'. Proof. intro H. apply subtypePath. - intro; apply isaprop_fmonoidal_stronglaws. - exact H. Qed. (** We now show that everything behaves as expected **) Definition functor_imageoftensor {C D : category} (M : monoidal C) (F : functor C D) : bifunctor C C D := compose_bifunctor_with_functor M F. Definition functor_tensorofimages {C D : category} (F : functor C D) (N : monoidal D) : bifunctor C C D := compose_functor_with_bifunctor F F N. Definition preserves_tensor_is_nattrans_type {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := binat_trans (functor_tensorofimages F N) (functor_imageoftensor M F). (* I really don't know how to call the following lemma *) Definition preservestensor_is_nattrans {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (ptnl : preserves_tensor_nat_left pt) (ptnr : preserves_tensor_nat_right pt) : preserves_tensor_is_nattrans_type M N F. Proof. use make_binat_trans. - use make_binat_trans_data. intros x y. apply pt. - use tpair. + intros x y1 y2 g. apply ptnl. + intros x1 x2 y f. apply ptnr. Defined. Lemma preservestensor_is_nattrans_full {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (ptnl : preserves_tensor_nat_left pt) (ptnr : preserves_tensor_nat_right pt) : ∏ (x1 x2 y1 y2 : C) (f : C⟦x1,x2⟧) (g : C⟦y1,y2⟧), # F f ⊗^{ N} # F g · pt x2 y2 = pt x1 y1 · # F (f ⊗^{ M} g). Proof. intros. etrans. { unfold functoronmorphisms1. rewrite assoc'. rewrite ptnl. apply assoc. } rewrite ptnr. rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. Qed. Definition preserves_tensor_inv_is_nattrans_type {C D : category} (M : monoidal C) (N : monoidal D) (F : functor C D) : UU := binat_trans (functor_imageoftensor M F) (functor_tensorofimages F N). (* name follows [preservestensor_is_nattrans], for lack of a better proposition *) Definition preservestensor_inv_is_nattrans {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (ptnl : preserves_tensor_nat_left pt) (ptnr : preserves_tensor_nat_right pt) (ptstr: preserves_tensor_strongly pt) : preserves_tensor_inv_is_nattrans_type M N F := inv_binattrans_from_binatiso(α:=preservestensor_is_nattrans ptnl ptnr) ptstr. Definition preserves_leftunitality' {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} {pu : preserves_unit M N F} (plu : preserves_leftunitality pt pu) : ∏ (x : C), (pu ⊗^{N} (identity (F x))) · (pt I_{M} x) · (#F (lu^{M}_{x})) = lu^{N}_{F x}. Proof. intro x. unfold functoronmorphisms1. rewrite (bifunctor_leftid N). rewrite id_right. apply plu. Qed. Definition preserves_rightunitality' {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} {pu : preserves_unit M N F} (pru : preserves_rightunitality pt pu) : ∏ (x : C), ((identity (F x)) ⊗^{N} pu) · (pt x I_{M}) · (#F (ru^{M}_{x})) = ru^{N}_{F x}. Proof. intro x. unfold functoronmorphisms1. rewrite (bifunctor_rightid N). rewrite id_left. apply pru. Qed. Definition preserves_leftunitality'' {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal M N F) : ∏ (x : C), (pr1 (fmonoidal_preservestensorstrongly Fm I_{M} x)) · (pr1 (fmonoidal_preservesunitstrongly Fm) ⊗^{N} (identity (F x))) · lu^{N}_{F x} = #F (lu^{M}_{x}). Proof. intro x. set (plu := preserves_leftunitality' (fmonoidal_preservesleftunitality (pr1 Fm)) x). rewrite (! plu). rewrite ! assoc. etrans. { apply maponpaths_2. apply maponpaths_2. rewrite assoc'. apply maponpaths. unfold functoronmorphisms1. do 2 rewrite (bifunctor_leftid N). do 2 rewrite id_right. rewrite <- (bifunctor_rightcomp N). apply maponpaths. apply (fmonoidal_preservesunitstrongly Fm). } rewrite bifunctor_rightid. rewrite id_right. etrans. { apply maponpaths_2. apply (fmonoidal_preservestensorstrongly Fm). } apply id_left. Qed. Proposition strong_fmonoidal_preserves_associativity {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal M N F) (x y z : C) : # F (α^{M}_{x , y , z}) = inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly Fm _ _) · (inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly Fm _ _) ⊗^{N}_{r} _) · (α^{N}_{ F x , F y , F z}) · (F x ⊗^{ N}_{l} fmonoidal_preservestensordata Fm y z) · fmonoidal_preservestensordata Fm x (y ⊗_{ M} z). Proof. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. exact (!(fmonoidal_preservesassociativity Fm x y z)). } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. etrans. { refine (!_). apply (bifunctor_rightcomp N). } apply maponpaths. apply z_iso_after_z_iso_inv. } rewrite (bifunctor_rightid N). rewrite id_left. apply z_iso_after_z_iso_inv. Qed. (** 3. Strict monoidal functors *) (* Strictly preserving monoidal functors *) Definition preserves_tensor_strictly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pt : preserves_tensordata M N F) : UU := ∏ (x y : C), ∑ (pf : (F x) ⊗_{N} (F y) = F (x ⊗_{M} y)), pt x y = transportf _ pf (identity ((F x) ⊗_{N} (F y))). Lemma strictlytensorpreserving_is_strong {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pt : preserves_tensordata M N F} (pst : preserves_tensor_strictly pt) : preserves_tensor_strongly pt. Proof. intros x y. use (iso_stable_under_equalitytransportf (pr2 (pst x y)) (is_z_isomorphism_identity (F x ⊗_{N} F y))). Qed. Definition preserves_unit_strictly {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (pu : preserves_unit M N F) : UU := ∑ (pf : I_{N} = (F I_{M})), pu = transportf _ pf (identity I_{N}). Definition strictlyunitpreserving_is_strong {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} {pu : preserves_unit M N F} (pus : preserves_unit_strictly pu) : preserves_unit_strongly pu. Proof. use (iso_stable_under_equalitytransportf (pr2 pus) (is_z_isomorphism_identity I_{N})). Defined. (** 4. Symmetric monoidal functors *) Definition is_symmetric_monoidal_functor {C D : category} {M : monoidal C} {N : monoidal D} (HM : symmetric M) (HN : symmetric N) {F : functor C D} (HF : fmonoidal_lax M N F) : UU := ∏ (x y : C), monoidal_braiding_data (symmetric_to_braiding HN) (F x) (F y) · fmonoidal_preservestensordata HF y x = fmonoidal_preservestensordata HF x y · #F(monoidal_braiding_data (symmetric_to_braiding HM) x y). Lemma isaprop_is_symmetric_monoidal_functor {C D : category} {M : monoidal C} {N : monoidal D} (HM : symmetric M) (HN : symmetric N) {F : functor C D} (HF : fmonoidal_lax M N F) : isaprop (is_symmetric_monoidal_functor HM HN HF). Proof. apply impred; intro c; apply impred; intro c'; apply D. Qed. (** 5. The identity is strong monoidal *) (** towards a bicategory of monoidal categories *) Definition identity_fmonoidal_data {C : category} (M : monoidal C) : fmonoidal_data M M (functor_identity C). Proof. split. - intros x y. apply identity. - apply identity. Defined. Lemma identity_fmonoidal_laxlaws {C : category} (M : monoidal C) : fmonoidal_laxlaws (identity_fmonoidal_data M). Proof. repeat split; red; unfold fmonoidal_preservesunit, fmonoidal_preservestensordata; cbn; intros. - rewrite id_left. apply id_right. - rewrite id_left. apply id_right. - do 2 rewrite id_right. rewrite (bifunctor_rightid M). rewrite (bifunctor_leftid M). rewrite id_right. apply id_left. - rewrite id_right. rewrite (bifunctor_rightid M). apply id_left. - rewrite id_right. rewrite (bifunctor_leftid M). apply id_left. Qed. Definition identity_fmonoidal_lax {C : category} (M : monoidal C) : fmonoidal_lax M M (functor_identity C) := identity_fmonoidal_data M ,, identity_fmonoidal_laxlaws M. Definition identity_fmonoidal_stronglaws {C : category} (M : monoidal C) : fmonoidal_stronglaws (fmonoidal_preservestensordata (identity_fmonoidal_lax M)) (fmonoidal_preservesunit (identity_fmonoidal_lax M)). Proof. split. - intros x y. apply is_z_isomorphism_identity. - apply is_z_isomorphism_identity. Defined. Definition identity_fmonoidal {C : category} (M : monoidal C) : fmonoidal M M (functor_identity C) := identity_fmonoidal_lax M ,, identity_fmonoidal_stronglaws M. Proposition is_symmetric_monoidal_identity {C : category} {M : monoidal C} (HM : symmetric M) : is_symmetric_monoidal_functor HM HM (identity_fmonoidal_lax M). Proof. intros x y. cbn. rewrite id_left, id_right. apply idpath. Qed. (** 6. Composition preserves lax/strongly monoidal functors *) Definition comp_fmonoidal_data {C D E : category} {M : monoidal C} {N : monoidal D} {O : monoidal E} {F : C ⟶ D} {G : D ⟶ E} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G) : fmonoidal_data M O (F ∙ G). Proof. split. - intros x y. exact (fmonoidal_preservestensordata Gm (F x) (F y) · #G (fmonoidal_preservestensordata Fm x y)). - exact (fmonoidal_preservesunit Gm · #G (fmonoidal_preservesunit Fm)). Defined. Lemma comp_fmonoidal_laxlaws {C D E : category} {M : monoidal C} {N : monoidal D} {O : monoidal E} {F : C ⟶ D} {G : D ⟶ E} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G) : fmonoidal_laxlaws (comp_fmonoidal_data Fm Gm). Proof. repeat split; red; cbn; unfold fmonoidal_preservesunit, fmonoidal_preservestensordata; cbn; intros. - etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply fmonoidal_preservestensornatleft. } rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply fmonoidal_preservestensornatleft. - etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. apply fmonoidal_preservestensornatright. } rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply fmonoidal_preservestensornatright. - assert (auxF := fmonoidal_preservesassociativity Fm x y z). unfold fmonoidal_preservestensordata in auxF. assert (auxG := fmonoidal_preservesassociativity Gm (F x) (F y) (F z)). unfold fmonoidal_preservestensordata in auxG. rewrite (bifunctor_leftcomp O). rewrite (bifunctor_rightcomp O). etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite assoc'. do 2 apply maponpaths. apply pathsinv0, fmonoidal_preservestensornatleft. } etrans. 2: { apply cancel_postcomposition. repeat rewrite assoc. apply cancel_postcomposition. exact auxG. } repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. rewrite <- functor_comp. apply functor_comp. } etrans. 2: { do 2 apply maponpaths. rewrite assoc. exact auxF. } do 2 rewrite functor_comp. repeat rewrite assoc. do 2 apply cancel_postcomposition. apply fmonoidal_preservestensornatright. - assert (auxF := fmonoidal_preservesleftunitality Fm x). assert (auxG := fmonoidal_preservesleftunitality Gm (F x)). unfold fmonoidal_preservesunit, fmonoidal_preservestensordata in auxF, auxG. etrans; [| exact auxG]. clear auxG. rewrite (bifunctor_rightcomp O). rewrite <- auxF. clear auxF. do 2 rewrite functor_comp. repeat rewrite assoc. do 2 apply cancel_postcomposition. repeat rewrite assoc'. apply maponpaths. apply fmonoidal_preservestensornatright. - assert (auxF := fmonoidal_preservesrightunitality Fm x). assert (auxG := fmonoidal_preservesrightunitality Gm (F x)). unfold fmonoidal_preservesunit, fmonoidal_preservestensordata in auxF, auxG. etrans; [| exact auxG]. clear auxG. rewrite (bifunctor_leftcomp O). rewrite <- auxF. clear auxF. do 2 rewrite functor_comp. repeat rewrite assoc. do 2 apply cancel_postcomposition. repeat rewrite assoc'. apply maponpaths. apply fmonoidal_preservestensornatleft. Qed. Definition comp_fmonoidal_lax {C D E : category} {M : monoidal C} {N : monoidal D} {O : monoidal E} {F : C ⟶ D} {G : D ⟶ E} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax N O G) : fmonoidal_lax M O (F ∙ G) := comp_fmonoidal_data Fm Gm ,, comp_fmonoidal_laxlaws Fm Gm. Section CompStrongMonoidal. Context {C D E : category} {M : monoidal C} {N : monoidal D} {O : monoidal E} {F : C ⟶ D} {G : D ⟶ E} (Fm : fmonoidal M N F) (Gm : fmonoidal N O G). Let comp_fmnoidal_unit_inv : G (F I_{M}) --> I_{O} := #G (pr1 (fmonoidal_preservesunitstrongly Fm)) · pr1 (fmonoidal_preservesunitstrongly Gm). Let comp_fmonoidal_tensor_inv (x y : C) : G (F (x ⊗_{ M } y)) --> G (F x) ⊗_{ O } G (F y) := #G (pr1 (fmonoidal_preservestensorstrongly Fm x y)) · pr1 (fmonoidal_preservestensorstrongly Gm (F x) (F y)). Lemma comp_fmonoidal_tensor_inv_laws (x y : C) : is_inverse_in_precat (fmonoidal_preservestensordata (comp_fmonoidal_lax Fm Gm) x y) (comp_fmonoidal_tensor_inv x y). Proof. unfold comp_fmonoidal_tensor_inv. split. - cbn. etrans. { rewrite !assoc'. apply maponpaths. rewrite assoc. apply cancel_postcomposition. rewrite <- functor_comp. apply maponpaths. apply (pr12 (fmonoidal_preservestensorstrongly Fm x y)). } rewrite functor_id. rewrite id_left. apply (pr12 (fmonoidal_preservestensorstrongly Gm (F x) (F y))). - cbn. etrans. { rewrite !assoc'. apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply (pr22 (fmonoidal_preservestensorstrongly Gm (F x) (F y))). } rewrite id_left. rewrite <- functor_comp. etrans. { apply maponpaths. apply (pr22 (fmonoidal_preservestensorstrongly Fm x y)). } apply functor_id. Qed. Lemma comp_fmonoidal_unit_inv_laws : is_inverse_in_precat (fmonoidal_preservesunit (comp_fmonoidal_lax Fm Gm)) comp_fmnoidal_unit_inv. Proof. unfold comp_fmnoidal_unit_inv. split. - cbn. etrans. { rewrite !assoc'. apply maponpaths. rewrite assoc. apply cancel_postcomposition. rewrite <- functor_comp. apply maponpaths. apply (pr12 (fmonoidal_preservesunitstrongly Fm)). } rewrite functor_id. rewrite id_left. apply (pr12 (fmonoidal_preservesunitstrongly Gm)). - cbn. etrans. { rewrite !assoc'. apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply (pr22 (fmonoidal_preservesunitstrongly Gm)). } rewrite id_left. rewrite <- functor_comp. etrans. { apply maponpaths. apply (pr22 (fmonoidal_preservesunitstrongly Fm)). } apply functor_id. Qed. Definition comp_fmonoidal_stronglaws : fmonoidal_stronglaws (fmonoidal_preservestensordata (comp_fmonoidal_lax Fm Gm)) (fmonoidal_preservesunit (comp_fmonoidal_lax Fm Gm)). Proof. split. - intros x y. use make_is_z_isomorphism. + exact (comp_fmonoidal_tensor_inv x y). + exact (comp_fmonoidal_tensor_inv_laws x y). - use make_is_z_isomorphism. + exact comp_fmnoidal_unit_inv. + exact comp_fmonoidal_unit_inv_laws. Defined. Definition comp_fmonoidal : fmonoidal M O (F ∙ G) := comp_fmonoidal_lax Fm Gm ,, comp_fmonoidal_stronglaws. End CompStrongMonoidal. Proposition is_symmetric_monoidal_comp {C D E : category} {M : monoidal C} {N : monoidal D} {O : monoidal E} {HM : symmetric M} {HN : symmetric N} {HO : symmetric O} {F : C ⟶ D} {G : D ⟶ E} {HF : fmonoidal_lax M N F} {HG : fmonoidal_lax N O G} (HHF : is_symmetric_monoidal_functor HM HN HF) (HHG : is_symmetric_monoidal_functor HN HO HG) : is_symmetric_monoidal_functor HM HO (comp_fmonoidal_lax HF HG). Proof. intros x y. cbn. rewrite !assoc. etrans. { apply maponpaths_2. apply HHG. } rewrite !assoc'. etrans. { apply maponpaths. rewrite <- functor_comp. apply maponpaths. apply HHF. } rewrite functor_comp. apply idpath. Qed. End MonoidalFunctors. (** 7. Monoidal natural transformations *) Section MonoidalNaturalTransformations. Context {C D : category} {M : monoidal C} {N : monoidal D} {F G : functor C D} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G) (α : F ⟹ G). Definition is_mon_nat_trans_tensorlaw : UU := ∏ (a a' : C), fmonoidal_preservestensordata Fm a a' · α (a ⊗_{M} a') = α a ⊗^{N} α a' · fmonoidal_preservestensordata Gm a a'. Definition is_mon_nat_trans_unitlaw : UU := fmonoidal_preservesunit Fm · α I_{M} = fmonoidal_preservesunit Gm. Definition is_mon_nat_trans : UU := is_mon_nat_trans_tensorlaw × is_mon_nat_trans_unitlaw. Lemma isaprop_is_mon_nat_trans : isaprop is_mon_nat_trans. Proof. apply isapropdirprod. - apply impred; intro a; apply impred; intro a'. apply D. - apply D. Qed. End MonoidalNaturalTransformations. Section SomeMonoidalNaturalTransformations. Lemma is_mon_nat_trans_identity {C D : category} {M : monoidal C} {N : monoidal D} {F : functor C D} (Fm : fmonoidal_lax M N F) : is_mon_nat_trans Fm Fm (nat_trans_id _). Proof. split; red; cbn; unfold fmonoidal_preservestensordata, fmonoidal_preservesunit; intros. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_id. - cbn in *. apply (bifunctor_leftid N). - cbn in *. apply (bifunctor_rightid N). } rewrite id_left. apply id_right. - apply id_right. Qed. Lemma is_mon_nat_trans_comp {C D : category} {M : monoidal C} {N : monoidal D} {F G H : functor C D} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G) (Hm : fmonoidal_lax M N H) (α : F ⟹ G) (β : G ⟹ H) : is_mon_nat_trans Fm Gm α -> is_mon_nat_trans Gm Hm β -> is_mon_nat_trans Fm Hm (nat_trans_comp _ _ _ α β). Proof. intros Hα Hβ. split; red; cbn; unfold fmonoidal_preservestensordata, fmonoidal_preservesunit; intros. - etrans. 2: { apply cancel_postcomposition. apply pathsinv0, bifunctor_distributes_over_comp. - cbn in *. apply (bifunctor_leftcomp N). - cbn in *. apply (bifunctor_rightcomp N). - cbn in *. apply (bifunctor_equalwhiskers N). } rewrite assoc. etrans. { apply cancel_postcomposition. apply (pr1 Hα a a'). } repeat rewrite assoc'. apply maponpaths. apply (pr1 Hβ). - rewrite assoc. etrans. { apply cancel_postcomposition. apply (pr2 Hα). } apply (pr2 Hβ). Qed. End SomeMonoidalNaturalTransformations. Proposition is_mon_nat_trans_prewhisker {C₁ C₂ C₃ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {M₃ : monoidal C₃} {F : C₁ ⟶ C₂} (HF : fmonoidal_lax M₁ M₂ F) {G₁ G₂ : C₂ ⟶ C₃} {HG₁ : fmonoidal_lax M₂ M₃ G₁} {HG₂ : fmonoidal_lax M₂ M₃ G₂} {τ : G₁ ⟹ G₂} (Hτ : is_mon_nat_trans HG₁ HG₂ τ) : is_mon_nat_trans (comp_fmonoidal_lax HF HG₁) (comp_fmonoidal_lax HF HG₂) (pre_whisker F τ). Proof. split. - intros x y ; cbn. unfold fmonoidal_preservestensordata. assert (aux := pr1 Hτ (F x) (F y)). unfold fmonoidal_preservestensordata in aux. etrans. 2: { rewrite assoc. apply cancel_postcomposition. exact aux. } clear aux. repeat rewrite assoc'. apply maponpaths. apply nat_trans_ax. - unfold is_mon_nat_trans_unitlaw ; cbn. unfold fmonoidal_preservesunit. assert (aux := pr2 Hτ). red in aux. unfold fmonoidal_preservesunit in aux. rewrite <- aux. repeat rewrite assoc'. apply maponpaths. apply nat_trans_ax. Qed. Proposition is_mon_nat_trans_postwhisker {C₁ C₂ C₃ : category} {M₁ : monoidal C₁} {M₂ : monoidal C₂} {M₃ : monoidal C₃} {F₁ F₂ : C₁ ⟶ C₂} {HF₁ : fmonoidal_lax M₁ M₂ F₁} {HF₂ : fmonoidal_lax M₁ M₂ F₂} {τ : F₁ ⟹ F₂} (Hτ : is_mon_nat_trans HF₁ HF₂ τ) {G : C₂ ⟶ C₃} (HG : fmonoidal_lax M₂ M₃ G) : is_mon_nat_trans (comp_fmonoidal_lax HF₁ HG) (comp_fmonoidal_lax HF₂ HG) (post_whisker τ G). Proof. split. - intros x y ; cbn. unfold fmonoidal_preservestensordata. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0, functor_comp. } etrans. { do 2 apply maponpaths. apply (pr1 Hτ). } unfold fmonoidal_preservestensordata. rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, preservestensor_is_nattrans_full. + apply (fmonoidal_preservestensornatleft HG). + apply (fmonoidal_preservestensornatright HG). - unfold is_mon_nat_trans_unitlaw ; cbn. unfold fmonoidal_preservesunit. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. apply (pr2 Hτ). Qed. (** 8. Inverses of monoidal natural transformations *) Section InverseMonoidalNaturalTransformation. Context {C D : category} {M : monoidal C} {N : monoidal D} {F G : functor C D} (Fm : fmonoidal_lax M N F) (Gm : fmonoidal_lax M N G) (α : F ⟹ G). Lemma is_mon_nat_trans_pointwise_inverse (isnziα : is_nat_z_iso α) : is_mon_nat_trans Fm Gm α -> is_mon_nat_trans Gm Fm (nat_z_iso_inv (α,,isnziα)). Proof. intro ismnt. split. - intros x y. cbn. unfold fmonoidal_preservestensordata. set (aux := (_,, is_z_iso_bifunctor_z_iso N _ _ (isnziα x) (isnziα y)) : z_iso _ _). apply pathsinv0, (z_iso_inv_on_right _ _ _ aux). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (_,,isnziα (x ⊗_{ M} y))). cbn. apply (!(pr1 ismnt x y)). - cbn. apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (_,,isnziα I_{M})). apply (!(pr2 ismnt)). Qed. End InverseMonoidalNaturalTransformation. Local Open Scope moncat. (** 9. Bundled versions *) Definition lax_monoidal_functor (V₁ V₂ : monoidal_cat) : UU := ∑ (F : V₁ ⟶ V₂), fmonoidal_lax V₁ V₂ F. Coercion lax_monoidal_functor_to_functor {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : V₁ ⟶ V₂ := pr1 F. Coercion lax_monoidal_functor_to_fmonoidal_lax {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : fmonoidal_lax V₁ V₂ F := pr2 F. Definition symmetric_lax_monoidal_functor (V₁ V₂ : sym_monoidal_cat) : UU := ∑ (F : lax_monoidal_functor V₁ V₂), is_symmetric_monoidal_functor (pr2 V₁) (pr2 V₂) (pr2 F). Coercion symmetric_lax_monoidal_functor_to_lax_monoidal {V₁ V₂ : sym_monoidal_cat} (F : symmetric_lax_monoidal_functor V₁ V₂) : lax_monoidal_functor V₁ V₂ := pr1 F. Definition strong_monoidal_functor (V₁ V₂ : monoidal_cat) : UU := ∑ (F : V₁ ⟶ V₂), fmonoidal V₁ V₂ F. Coercion strong_monoidal_functor_to_lax_monoidal_functor {V₁ V₂ : monoidal_cat} (F : strong_monoidal_functor V₁ V₂) : lax_monoidal_functor V₁ V₂ := pr1 F ,, pr12 F. Definition symmetric_strong_monoidal_functor (V₁ V₂ : sym_monoidal_cat) : UU := ∑ (F : strong_monoidal_functor V₁ V₂), is_symmetric_monoidal_functor (pr2 V₁) (pr2 V₂) (pr2 F). Coercion symmetric_strong_monoidal_functor_to_strong_monoidal {V₁ V₂ : sym_monoidal_cat} (F : symmetric_strong_monoidal_functor V₁ V₂) : strong_monoidal_functor V₁ V₂ := pr1 F. Coercion symmetric_strong_monoidal_functor_to_lax_symmetric {V₁ V₂ : sym_monoidal_cat} (F : symmetric_strong_monoidal_functor V₁ V₂) : symmetric_lax_monoidal_functor V₁ V₂ := (pr11 F ,, pr121 F) ,, pr2 F. Definition mon_functor_unit {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : I_{V₂} --> F (I_{V₁}) := pr212 F. Definition mon_functor_tensor {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) (x y : V₁) : F x ⊗ F y --> F(x ⊗ y) := pr112 F x y. Section MonoidalFunctorAccessors. Context {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂). Definition tensor_mon_functor_tensor {x₁ x₂ y₁ y₂ : V₁} (f : x₁ --> x₂) (g : y₁ --> y₂) : #F f #⊗ #F g · mon_functor_tensor F x₂ y₂ = mon_functor_tensor F x₁ y₁ · #F (f #⊗ g). Proof. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite !assoc'. etrans. { apply maponpaths. apply (fmonoidal_preservestensornatleft (pr2 F)). } rewrite !assoc. etrans. { apply maponpaths_2. apply (fmonoidal_preservestensornatright (pr2 F)). } rewrite !assoc'. apply maponpaths. rewrite <- functor_comp. apply idpath. Qed. Definition mon_functor_lassociator (x y z : V₁) : mon_functor_tensor F x y #⊗ identity (F z) · mon_functor_tensor F (x ⊗ y) z · #F (mon_lassociator x y z) = mon_lassociator (F x) (F y) (F z) · identity (F x) #⊗ mon_functor_tensor F y z · mon_functor_tensor F x (y ⊗ z). Proof. refine (_ @ fmonoidal_preservesassociativity (pr2 F) x y z @ _). - apply maponpaths_2. apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V₂). - apply maponpaths_2. apply maponpaths. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid V₂). Qed. Definition mon_functor_rassociator (x y z : V₁) : mon_rassociator (F x) (F y) (F z) · mon_functor_tensor F x y #⊗ identity (F z) · mon_functor_tensor F (x ⊗ y) z = identity (F x) #⊗ mon_functor_tensor F y z · mon_functor_tensor F x (y ⊗ z) · #F (mon_rassociator x y z). Proof. refine (!_). etrans. { apply maponpaths_2. refine (!(id_left _) @ _). etrans. { apply maponpaths_2. refine (!_). apply mon_rassociator_lassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. refine (!_). apply mon_functor_lassociator. } rewrite !assoc'. do 2 apply maponpaths. refine (_ @ id_right _). apply maponpaths. refine (!(functor_comp _ _ _) @ _ @ functor_id _ _). apply maponpaths. apply mon_lassociator_rassociator. Qed. Definition mon_functor_lunitor (x : V₁) : mon_lunitor (F x) = mon_functor_unit F #⊗ identity (F x) · mon_functor_tensor F (I_{V₁}) x · #F (mon_lunitor x). Proof. refine (!(fmonoidal_preservesleftunitality (pr2 F) x) @ _). do 2 apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply (bifunctor_leftid V₂). Qed. Definition mon_functor_linvunitor (x : V₁) : #F (mon_linvunitor x) = mon_linvunitor (F x) · mon_functor_unit F #⊗ identity (F x) · mon_functor_tensor F (I_{V₁}) x. Proof. refine (!(id_left _) @ _). etrans. { apply maponpaths_2. refine (!_). apply mon_linvunitor_lunitor. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply mon_functor_lunitor. } rewrite !assoc'. apply maponpaths. refine (_ @ id_right _). apply maponpaths. refine (!(functor_comp _ _ _) @ _ @ functor_id _ _). apply maponpaths. apply mon_lunitor_linvunitor. Qed. Definition mon_functor_runitor (x : V₁) : mon_runitor (F x) = identity (F x) #⊗ mon_functor_unit F · mon_functor_tensor F x (I_{V₁}) · #F (mon_runitor x). Proof. refine (!(fmonoidal_preservesrightunitality (pr2 F) x) @ _). do 2 apply maponpaths_2. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid V₂). Qed. Definition mon_functor_rinvunitor (x : V₁) : #F (mon_rinvunitor x) = mon_rinvunitor (F x) · identity (F x) #⊗ mon_functor_unit F · mon_functor_tensor F x (I_{V₁}). Proof. refine (!(id_left _) @ _). etrans. { apply maponpaths_2. refine (!_). apply mon_rinvunitor_runitor. } rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply mon_functor_runitor. } rewrite !assoc'. apply maponpaths. refine (_ @ id_right _). apply maponpaths. refine (!(functor_comp _ _ _) @ _ @ functor_id _ _). apply maponpaths. apply mon_runitor_rinvunitor. Qed. End MonoidalFunctorAccessors. Section StrongMonoidalFunctorAccessors. Context {V₁ V₂ : monoidal_cat} (F : strong_monoidal_functor V₁ V₂). Definition strong_functor_unit_inv : F (I_{V₁}) --> I_{V₂}. Proof. exact (inv_from_z_iso (_ ,, fmonoidal_preservesunitstrongly (pr2 F))). Defined. Definition strong_functor_unit_inv_unit : strong_functor_unit_inv · mon_functor_unit F = identity _. Proof. apply z_iso_after_z_iso_inv. Qed. Definition strong_functor_unit_unit_inv : mon_functor_unit F · strong_functor_unit_inv = identity _. Proof. apply (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservesunitstrongly (pr2 F))). Qed. Definition strong_functor_tensor_inv (x y : V₁) : F(x ⊗ y) --> F x ⊗ F y. Proof. exact (inv_from_z_iso (_ ,, fmonoidal_preservestensorstrongly (pr2 F) x y)). Defined. Definition strong_functor_tensor_inv_tensor (x y : V₁) : strong_functor_tensor_inv x y · mon_functor_tensor F x y = identity _. Proof. apply z_iso_after_z_iso_inv. Qed. Definition strong_functor_tensor_tensor_inv (x y : V₁) : mon_functor_tensor F x y · strong_functor_tensor_inv x y = identity _. Proof. apply (z_iso_inv_after_z_iso (_ ,, fmonoidal_preservestensorstrongly (pr2 F) x y)). Qed. Definition tensor_strong_functor_tensor_inv {x₁ x₂ y₁ y₂ : V₁} (f : x₁ --> x₂) (g : y₁ --> y₂) : strong_functor_tensor_inv x₁ y₁ · #F f #⊗ #F g = #F (f #⊗ g) · strong_functor_tensor_inv x₂ y₂. Proof. use z_iso_inv_on_right ; cbn. rewrite !assoc. use z_iso_inv_on_left ; cbn. refine (!_). apply (tensor_mon_functor_tensor F). Qed. End StrongMonoidalFunctorAccessors. Proposition symmetric_lax_monoidal_sym_mon_braiding {V₁ V₂ : sym_monoidal_cat} (F : symmetric_lax_monoidal_functor V₁ V₂) (x y : V₁) : sym_mon_braiding V₂ (F x) (F y) · mon_functor_tensor F y x = mon_functor_tensor F x y · #F (sym_mon_braiding V₁ x y). Proof. exact (pr2 F x y). Qed. (** 10. Builders for the bundled versions *) Definition lax_monoidal_functor_laws {V₁ V₂ : monoidal_cat} (F : V₁ ⟶ V₂) (μ : ∏ (x y : V₁), F x ⊗ F y --> F(x ⊗ y)) (η : I_{V₂} --> F(I_{V₁})) : UU := (∏ (x₁ x₂ y₁ y₂ : V₁) (f : x₁ --> x₂) (g : y₁ --> y₂), #F f #⊗ #F g · μ x₂ y₂ = μ x₁ y₁ · #F(f #⊗ g)) × (∏ (x : V₁), η #⊗ identity _ · μ (I_{V₁}) x · #F (mon_lunitor x) = mon_lunitor (F x)) × (∏ (x : V₁), identity _ #⊗ η · μ x (I_{V₁}) · #F (mon_runitor x) = mon_runitor (F x)) × (∏ (x y z : V₁), (μ x y #⊗ identity _) · μ (x ⊗ y) z · #F(mon_lassociator x y z) = mon_lassociator (F x) (F y) (F z) · (identity _ #⊗ μ y z) · μ x (y ⊗ z)). Proposition lax_monoidal_functor_laws_to_monoidal_laws {V₁ V₂ : monoidal_cat} {F : V₁ ⟶ V₂} {μ : ∏ (x y : V₁), F x ⊗ F y --> F(x ⊗ y)} {η : I_{V₂} --> F(I_{V₁})} (HF : lax_monoidal_functor_laws F μ η) : fmonoidal_laxlaws (μ,, η). Proof. repeat split. - intros x y₁ y₂ g ; cbn. refine (_ @ pr1 HF _ _ _ _ (identity _) g @ _). + apply maponpaths_2. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. rewrite functor_id. refine (!_). apply (bifunctor_rightid (pr2 V₂)). + do 2 apply maponpaths. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (_ @ id_left _). apply maponpaths_2. apply (bifunctor_rightid (pr2 V₁)). - intros x₁ x₂ y f ; cbn. refine (_ @ pr1 HF _ _ _ _ f (identity _) @ _). + apply maponpaths_2. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. rewrite functor_id. refine (!_). apply (bifunctor_leftid (pr2 V₂)). + do 2 apply maponpaths. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid (pr2 V₁)). - intros x y z ; cbn. refine (_ @ pr222 HF x y z @ _). + do 2 apply maponpaths_2. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply (bifunctor_leftid (pr2 V₂)). + apply maponpaths_2. apply maponpaths. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (_ @ id_left _). apply maponpaths_2. apply (bifunctor_rightid (pr2 V₂)). - intros x ; cbn. refine (_ @ pr12 HF x). do 2 apply maponpaths_2. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (!(id_right _) @ _). apply maponpaths. refine (!_). apply (bifunctor_leftid (pr2 V₂)). - intros x ; cbn. refine (_ @ pr122 HF x). do 2 apply maponpaths_2. unfold monoidal_cat_tensor_mor, functoronmorphisms1. refine (!(id_left _) @ _). apply maponpaths_2. refine (!_). apply (bifunctor_rightid (pr2 V₂)). Qed. Definition make_lax_monoidal_functor {V₁ V₂ : monoidal_cat} (F : V₁ ⟶ V₂) (μ : ∏ (x y : V₁), F x ⊗ F y --> F(x ⊗ y)) (η : I_{V₂} --> F(I_{V₁})) (HF : lax_monoidal_functor_laws F μ η) : lax_monoidal_functor V₁ V₂ := F ,, (μ ,, η) ,, lax_monoidal_functor_laws_to_monoidal_laws HF. Definition make_strong_monoidal_functor {V₁ V₂ : monoidal_cat} (F : lax_monoidal_functor V₁ V₂) (Hμ : ∏ (x y : V₁), is_z_isomorphism (mon_functor_tensor F x y)) (Hη : is_z_isomorphism (mon_functor_unit F)) : strong_monoidal_functor V₁ V₂ := pr1 F ,, pr2 F ,, Hμ ,, Hη. Definition symmetric_monoidal_functor_laws {V₁ V₂ : sym_monoidal_cat} (F : lax_monoidal_functor V₁ V₂) : UU := ∏ (x y : V₁), sym_mon_braiding V₂ (F x) (F y) · mon_functor_tensor F y x = mon_functor_tensor F x y · #F(sym_mon_braiding V₁ x y). Definition make_symmetric_lax_monoidal_functor {V₁ V₂ : sym_monoidal_cat} (F : lax_monoidal_functor V₁ V₂) (HF : symmetric_monoidal_functor_laws F) : symmetric_lax_monoidal_functor V₁ V₂ := F ,, HF. Definition make_symmetric_strong_monoidal_functor {V₁ V₂ : sym_monoidal_cat} (F : strong_monoidal_functor V₁ V₂) (HF : symmetric_monoidal_functor_laws F) : symmetric_strong_monoidal_functor V₁ V₂ := F ,, HF. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/000077500000000000000000000000001451125700300243335ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/LiftedAssociator.v000066400000000000000000000655141451125700300277740ustar00rootroot00000000000000(* In LiftedTensor.v and LiftedTensor.v, we have shown that given a category C equipped with a binary operation T and an object I (called the tensor and unit resp.), then, this structures 'transport' to a weakly equivalent univalent category D, by a weak equivalence H:C->D, making this univalent category D with a tensor and unit, the free univalent category equipped with a tensor and a unit. In this file, we show that if we equip (C,T) with an associator, then 1: the associator also transports to D. 2: H preserves the associator as a monoidal functor preserves the associator. 3: H makes D the free univalent category equipped with tensor, unit and the associator. More details about the universality and the Rezk-completion can be found in LiftedMonoidal.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecompEquivalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensor. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensorUnit. Local Open Scope mor_disp. Local Open Scope cat. Section RezkAssociator. Context {C D : category} {H : functor C D} (Duniv : is_univalent D) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (α : associator TC). Definition DDDuniv : is_univalent ((D ⊠ D) ⊠ D). Proof. apply is_univalent_category_binproduct. 2: exact Duniv. apply is_univalent_category_binproduct. exact Duniv. exact Duniv. Qed. Let TD := TransportedTensor Duniv H_eso H_ff TC. Local Notation HH := (pair_functor H H). Let HH_eso := pair_functor_eso H H H_eso H_eso. Let HH_ff := pair_functor_ff H H H_ff H_ff. Local Notation HHH := (pair_functor HH H). Let HHH_eso := pair_functor_eso HH H HH_eso H_eso. Let HHH_ff := pair_functor_ff HH H HH_ff H_ff. Local Notation HHH' := (pair_functor H HH). Let HHH'_eso := pair_functor_eso _ _ H_eso HH_eso. Let HHH'_ff := pair_functor_ff _ _ H_ff HH_ff. Lemma TransportedAssocLeft : nat_z_iso (HHH ∙ assoc_left TD) (assoc_left TC ∙ H). Proof. use nat_z_iso_comp. 3: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 3: { apply pre_whisker_nat_z_iso. apply ((TransportedTensorComm Duniv H_eso H_ff _)). } use nat_z_iso_comp. 3: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use (post_whisker_nat_z_iso _ TD). use nat_z_iso_comp. 3: apply PrecompEquivalence.nat_z_iso_pair. use nat_z_iso_comp. 2: apply pair_functor_composite. use pair_nat_z_iso. - apply TransportedTensorComm. - apply functor_commutes_with_id. Defined. Lemma TransportedAssocLeftOnOb (x y z : C) : TransportedAssocLeft ((x,y),z) = # TD (TransportedTensorComm Duniv H_eso H_ff TC (x,y) #, identity (H z)) · (TransportedTensorComm Duniv H_eso H_ff TC (TC (x,y) , z)). Proof. cbn. rewrite ! id_left. rewrite ! id_right. apply idpath. Qed. Lemma unassoc_commutes : nat_z_iso (HHH ∙ (precategory_binproduct_unassoc D D D)) ((precategory_binproduct_unassoc C C C) ∙ (pair_functor H HH)). Proof. use make_nat_z_iso. - use make_nat_trans. + intro ; use catbinprodmor ; apply identity. + intro ; intros. use total2_paths_f. * exact (id_right _ @ ! id_left _). * abstract (rewrite transportf_const ; exact (id_right _ @ ! id_left _)). - intro. use tpair. * use catbinprodmor ; apply identity. * abstract (split ; (use total2_paths_f ; [ apply id_right | rewrite transportf_const ; apply id_right ])). Defined. Lemma TransportedAssocRight : nat_z_iso (HHH ∙ assoc_right TD) (assoc_right TC ∙ H). Proof. (* This commuting diagram can be split in 3 commuting diagrams stacked together *) (* Step 1: The top commuting diagram is unassoc_commutes *) use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 2: { use post_whisker_nat_z_iso. 2: exact unassoc_commutes. } use nat_z_iso_comp. 2: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use nat_z_iso_comp. 3: apply nat_z_iso_functor_comp_assoc. apply pre_whisker_nat_z_iso. (* Step 2: The lowest commuting diagram is the tensor preserving commuting one *) use nat_z_iso_comp. 3: apply nat_z_iso_functor_comp_assoc. use nat_z_iso_comp. 3: { apply pre_whisker_nat_z_iso. apply TransportedTensorComm. } use nat_z_iso_comp. 3: apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). use nat_z_iso_comp. 2: apply nat_z_iso_functor_comp_assoc. apply post_whisker_nat_z_iso. (* Step 3: The middle commuting square is the tensor preserving commuting one but tensored with the identity functor on the left *) use product_of_commuting_squares. { apply (make_nat_z_iso _ _ _ (is_nat_z_iso_nat_trans_id H)). } apply TransportedTensorComm. Defined. Lemma TransportedAssocRightOnOb (x y z : C) : TransportedAssocRight ((x,y),z) = # TD (# H (id x) #, TransportedTensorComm Duniv H_eso H_ff TC (y, z)) · TransportedTensorComm Duniv H_eso H_ff TC (x, TC (y,z)). Proof. cbn. rewrite ! id_left. rewrite ! id_right. rewrite ! functor_id. rewrite ! assoc. apply maponpaths_2. fold (TransportedTensor Duniv H_eso H_ff). etrans. { apply (! functor_comp TD _ _). } apply maponpaths. rewrite <- binprod_comp. rewrite id_right. apply maponpaths. etrans. { apply maponpaths_2. apply (functor_id TD). } apply id_left. Qed. Lemma TransportedAssocRightInvOnOb (x y z : C) : nat_z_iso_inv TransportedAssocRight ((x,y),z) = nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x, TC (y,z)) · # TD (# H (id x) #, (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (y, z))). Proof. use (z_iso_inv_to_left _ _ _ (_,,pr2 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y,z)))). use (z_iso_inv_to_right _ _ _ _ (_,, pr2 (nat_z_iso_inv TransportedAssocRight) ((x, y), z))). set (t := TransportedAssocRightOnOb x y z). etrans. 2: { apply maponpaths. apply (! t). } etrans. 2: { rewrite assoc. apply maponpaths_2. apply (functor_comp TD). } etrans. 2: { apply maponpaths_2. apply maponpaths. apply binprod_comp. } etrans. 2: { apply maponpaths_2. apply maponpaths. rewrite (functor_id H). rewrite id_right. apply maponpaths. apply (! pr22 ((pr2 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z))). } etrans. 2: { apply maponpaths_2. rewrite binprod_id. apply (! functor_id TD _). } apply (! id_left _). Qed. Definition TransportedAssociator : associator TD. Proof. use (lift_nat_z_iso_along (_,,Duniv) HHH HHH_eso HHH_ff). use nat_z_iso_comp. 3: apply (nat_z_iso_inv (TransportedAssocRight)). use nat_z_iso_comp. 2: exact TransportedAssocLeft. exact (post_whisker_nat_z_iso α H). Defined. Let αD := TransportedAssociator. Definition TransportedAssociatorEq : pre_whisker HHH TransportedAssociator = nat_z_iso_comp (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H)) (nat_z_iso_inv (TransportedAssocRight)). Proof. set (t := lift_nat_trans_along_comm (_,,Duniv) _ HHH_eso HHH_ff (nat_z_iso_comp TransportedAssocLeft (nat_z_iso_comp (post_whisker_nat_z_iso α H) (nat_z_iso_inv TransportedAssocRight) ) )). refine (_ @ t @ _). clear t. - apply maponpaths. apply (maponpaths (lift_nat_trans_along (D,, Duniv) HHH HHH_eso HHH_ff)). apply nat_trans_comp_assoc'. apply homset_property. - exact (nat_trans_comp_assoc (homset_property _) _ _ _ _ (pr1 TransportedAssocLeft) (post_whisker_nat_z_iso α H) (nat_z_iso_inv TransportedAssocRight)). Qed. Definition TransportedAssociatorOnOb : ∏ x : (C ⊠ C) ⊠ C, αD (HHH x) = TransportedAssocLeft x · #H (α x) · nat_z_iso_inv TransportedAssocRight x. Proof. exact (λ x, toforallpaths _ _ _ (base_paths _ _ TransportedAssociatorEq) x). Qed. Definition assoc_left_tensor_l : ∏ x1 x2 x3 x4 : C, D⟦assoc_left TD ((TD (H x1, H x2), H x3), H x4) , H (assoc_left TC ((TC (x1, x2), x3), x4))⟧. Proof. do 4 intro. use (_ · _). 3: apply TransportedAssocLeft. use (# TD). use catbinprodmor. 2: apply identity. use (# TD). use catbinprodmor. 1: exact ((TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2)). apply identity. Defined. Definition assoc_left_tensor_m : ∏ x1 x2 x3 x4 : C, D ⟦assoc_left TD ((H x1, TD (H x2, H x3)), H x4) , H (assoc_left TC ((x1, TC (x2, x3)), x4))⟧. Proof. do 4 intro. use (_ · _). 3: apply TransportedAssocLeft. use (# TD). use catbinprodmor. 2: apply identity. apply (#TD). use catbinprodmor. 1: apply identity. apply ((TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3)). Defined. Definition assoc_left_tensor_r : ∏ x1 x2 x3 x4 : C, D ⟦assoc_left TD ((H x1, H x2), TD (H x3, H x4)) , H (assoc_left TC ((x1, x2), TC (x3, x4))) ⟧. Proof. do 4 intro. use (_ · _). 3: apply TransportedAssocLeft. use (# TD). use catbinprodmor. - apply identity. - exact ((TransportedTensorComm Duniv H_eso H_ff TC) (x3,x4)). Defined. Definition assoc_right_tensor_l : ∏ x1 x2 x3 x4 : C, D⟦ H (assoc_right TC ((TC (x1, x2), x3), x4)) , assoc_right TD ((TD (H x1, H x2), H x3), H x4)⟧. Proof. do 4 intro. use (_ · _). 2: apply TransportedAssocRight. use (# TD). use catbinprodmor. 2: apply identity. exact (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2)). Defined. Definition assoc_right_tensor_m : ∏ x1 x2 x3 x4 : C, D⟦H (assoc_right TC ((x1, TC (x2, x3)), x4)) , assoc_right TD ((H x1, TD (H x2, H x3)), H x4)⟧. Proof. do 4 intro. use (_ · _). 3: { use (# (assoc_right TD)). 2: { use catbinprodmor. 4: apply identity. 2: { use catbinprodmor. 3: apply identity. 2: apply (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3)). } } } exact (nat_z_iso_inv TransportedAssocRight ((x1,TC (x2,x3)),x4)). Defined. Definition assoc_right_tensor_r : ∏ x1 x2 x3 x4 : C, D⟦H (assoc_right TC ((x1, x2), TC (x3, x4))) , assoc_right TD ((H x1, H x2), TD (H x3, H x4)) ⟧. Proof. do 4 intro. use (_ · _). 2: apply (nat_z_iso_inv TransportedAssocRight). use (# TD). use catbinprodmor. - apply identity. - use (# TD). use catbinprodmor. + apply identity. + apply TransportedTensorComm. Defined. Lemma TransportedAssociator_tensor_l_on_ob : ∏ x1 x2 x3 x4 : C, αD ((TD (H x1, H x2), H x3), H x4) = assoc_left_tensor_l x1 x2 x3 x4 · #H (α ((TC (x1,x2) , x3),x4)) · assoc_right_tensor_l x1 x2 x3 x4. Proof. do 4 intro. unfold assoc_left_tensor_l. unfold assoc_right_tensor_l. etrans. 2: { rewrite assoc. apply maponpaths_2. do 2 rewrite assoc'. apply maponpaths. rewrite assoc. exact (TransportedAssociatorOnOb ((TC (x1,x2),x3),x4)). } etrans. 2: { apply maponpaths_2. exact (! pr21 αD _ _ ((TransportedTensorComm Duniv H_eso H_ff TC (x1, x2) #, id H (pr21 ((TC (x1, x2), x3), x4))) #, id functor_identity D (pr2 (HHH ((TC (x1, x2), x3), x4))))). } etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp TD). apply maponpaths. etrans. 2: apply binprod_comp. etrans. 2: { apply maponpaths. etrans. 2: apply maponpaths_2, maponpaths, (! binprod_id _ _). rewrite functor_id. apply (! id_left _). } apply maponpaths_2. exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x1,x2))). } etrans. 2: { apply maponpaths. rewrite binprod_id. apply (! functor_id TD _). } apply (! id_right _). Qed. Lemma TransportedAssociator_tensor_m_on_ob : ∏ x1 x2 x3 x4 : C, αD ((H x1, TD (H x2, H x3)), H x4) = assoc_left_tensor_m x1 x2 x3 x4 · #H (α ((x1, TC (x2,x3)),x4)) · assoc_right_tensor_m x1 x2 x3 x4. Proof. do 4 intro. unfold assoc_left_tensor_m. unfold assoc_right_tensor_m. etrans. 2: { rewrite assoc. apply maponpaths_2. do 2 rewrite assoc'. apply maponpaths. rewrite assoc. exact (TransportedAssociatorOnOb ((x1, TC (x2,x3)),x4)). } etrans. 2: { apply maponpaths_2. exact (! pr21 αD _ _ ((id H (pr11 ((x1, TC (x2, x3)), x4)) #, TransportedTensorComm Duniv H_eso H_ff TC (x2, x3)) #, id functor_identity D (pr2 (HHH ((x1, TC (x2, x3)), x4))))). } etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp TD). etrans. 2: apply maponpaths, binprod_comp. (* simpl. *) rewrite id_left. do 2 apply maponpaths. etrans. 2: apply (functor_comp TD). apply maponpaths. etrans. 2: apply binprod_comp. apply maponpaths_2. exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x2,x3))). } etrans. 2: { apply maponpaths. rewrite id_right. rewrite (functor_id TD). simpl. rewrite binprod_id. apply (! functor_id TD _). } apply (! id_right _). Qed. Lemma TransportedAssociator_tensor_r_on_ob : ∏ x1 x2 x3 x4 : C, αD ((H x1, H x2), TD (H x3, H x4)) = assoc_left_tensor_r x1 x2 x3 x4 · #H (α ((x1,x2) , TC (x3,x4))) · assoc_right_tensor_r x1 x2 x3 x4. Proof. do 4 intro. unfold assoc_left_tensor_r. unfold assoc_right_tensor_r. etrans. 2: { rewrite assoc. apply maponpaths_2. do 2 rewrite assoc'. apply maponpaths. rewrite assoc. exact (TransportedAssociatorOnOb (((x1,x2), TC (x3,x4)))). } etrans. 2: { apply maponpaths_2. rewrite <- (functor_id TD). exact (! pr21 αD _ _ (id (pr1 (HHH ((x1, x2), TC (x3, x4)))) #, TransportedTensorComm Duniv H_eso H_ff TC (x3, x4))). } etrans. 2: { rewrite assoc'. apply maponpaths. etrans. 2: apply (functor_comp TD). etrans. 2: apply maponpaths, binprod_comp. (* simpl. *) rewrite id_left. do 2 apply maponpaths. etrans. 2: apply (functor_comp TD). apply maponpaths. etrans. 2: apply binprod_comp. apply maponpaths. exact (! pr12 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x3,x4))). } etrans. 2: { apply maponpaths. rewrite id_right. rewrite (functor_id TD). simpl. rewrite binprod_id. apply (! functor_id TD _). } apply (! id_right _). Qed. Context (I : C). Definition H_pα : (functor_ass_disp_cat (IC := I) α αD) (H ,, (pr1 (TransportedTensorComm Duniv H_eso H_ff TC) ,, identity _)). Proof. intros x y z. unfold αD. unfold TransportedAssociator. etrans. { apply maponpaths_2. exact (! TransportedAssocLeftOnOb x y z). } assert (p1' : (# TD (id pr1 H x #, (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z)) · (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y, z))) = TransportedAssocRight ((x,y),z)). { rewrite <- (functor_id H). exact (! TransportedAssocRightOnOb x y z). } assert (p1 : (nat_z_iso_inv TransportedAssocRight) ((x,y),z) · (# TD (id pr1 H x #, (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (y, z)) · (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (x, TC (y, z))) = identity _). { use (z_iso_inv_on_right _ _ _ (_,,pr2 TransportedAssocRight ((x,y),z))). rewrite id_right. exact p1'. } set (cc := lift_nat_z_iso_along (D,, Duniv) HHH HHH_eso HHH_ff (nat_z_iso_comp (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H)) (nat_z_iso_inv TransportedAssocRight))). set (cc1 := (post_whisker_nat_z_iso α H)). set (cc0 := TransportedAssocLeft). set (cc2 := (nat_z_iso_inv TransportedAssocRight)). set (dd := nat_z_iso_comp cc0 (nat_z_iso_comp cc1 cc2)). assert (p2' : dd = pre_whisker_nat_z_iso HHH cc). { use total2_paths_f. 2: { apply isaprop_is_nat_z_iso. } etrans. { apply (! lift_nat_trans_along_comm (_,,Duniv) _ HHH_eso HHH_ff _). } apply (maponpaths (pre_whisker HHH)). apply (maponpaths (lift_nat_trans_along (D,, Duniv) HHH HHH_eso HHH_ff)). apply nat_trans_comp_assoc. apply homset_property. } set (cc' := lift_nat_z_iso_along (D,, Duniv) HHH HHH_eso HHH_ff (nat_z_iso_comp (nat_z_iso_comp TransportedAssocLeft (post_whisker_nat_z_iso α H)) (nat_z_iso_inv TransportedAssocRight)) (HHH ((x,y),z))). set (cc1' := (post_whisker_nat_z_iso α H) ((x,y),z)). set (cc0' := TransportedAssocLeft ((x,y),z)). set (cc2' := (nat_z_iso_inv TransportedAssocRight) ((x,y),z)). assert (p2 : cc0' · cc1' · cc2' = cc'). { set (q := toforallpaths _ _ _ (base_paths _ _ (base_paths _ _ p2')) ((x,y),z)). refine (_ @ q). apply assoc'. } etrans. 2: { do 2 apply maponpaths_2. exact p2. } clear p2. unfold cc0', cc1', cc2'. clear cc0' cc1' cc2'. rewrite ! assoc'. apply maponpaths. etrans. 2: { apply maponpaths. exact (! p1). } apply (! id_right _). Qed. Context {E : category} (Euniv : is_univalent E) (TE : functor (E ⊠ E) E) (αE : associator TE). Context (IE : E). Definition precompA : disp_functor (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE) (functor_ass_disp_cat αD αE) (functor_ass_disp_cat α αE). Proof. use tpair. - use tpair. 2: intro ; intros ; exact tt. exact (λ G GG, functor_ass_composition H_pα GG). - split ; intro ; intros ; apply isapropunit. Qed. Lemma precompA_ff : disp_functor_ff precompA. Proof. intro ; intros. apply isweqinclandsurj. - do 3 intro. assert (p : isaset ( hfiber (λ ff : unit, ♯ precompA ff) y0)). { use isaset_hfiber ; use isasetaprop ; apply isapropunit. } use tpair. + use total2_paths_f. { apply isapropunit. } use proofirrelevance. use hlevelntosn. apply isapropunit. + intro ; apply p. - intro ; intros. apply hinhpr. exists tt. apply isapropunit. Qed. Lemma lift_preserves_associator {G : functor_tensorunit_cat (TransportedTensor Duniv H_eso H_ff TC) TE (H I) IE} ( GG : functor_ass_disp_cat α αE (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE G)) : functor_ass_disp_cat αD αE G. Proof. intros d1 d2 d3. use factor_through_squash. { exact (∑ a : C, z_iso (H a) d1). } { apply homset_property. } 2: exact (H_eso d1). intros [c1 i1]. induction (isotoid _ Duniv i1). clear i1. use factor_through_squash. { exact (∑ a : C, z_iso (H a) d2). } { apply homset_property. } 2: exact (H_eso d2). intros [c2 i2]. induction (isotoid _ Duniv i2). clear i2. use factor_through_squash. { exact (∑ a : C, z_iso (H a) d3). } { apply homset_property. } 2: exact (H_eso d3). intros [c3 i3]. induction (isotoid _ Duniv i3). clear i3. etrans. { do 2 apply maponpaths. exact (TransportedAssociatorOnOb ((c1,c2), c3)). } rewrite TransportedAssocLeftOnOb. rewrite TransportedAssocRightInvOnOb. set (t := GG c1 c2 c3). set (ptG := pr112 G). set (ptH := pr1 (TransportedTensorComm Duniv H_eso H_ff TC)). set (pt_GH := (pr112 (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE G))). transparent assert (m : (E⟦ pr11 G (H (TC (c1, TC (c2,, c3)))) , (pr11 G) (TD (H c1, TD (H c2,, H c3)))⟧)). { apply #(pr11 G). refine (_ · _). - apply (TransportedTensorComm Duniv H_eso H_ff). - apply (#TD). use catbinprodmor. + apply identity. + apply (TransportedTensorComm Duniv H_eso H_ff). } set (tt := cancel_postcomposition _ _ m t : # TE (pt_GH (c1, c2) #, id pr11 G (H c3)) · pt_GH (TC (c1, c2), c3) · # (functor_composite H (pr1 G)) (α ((c1, c2), c3)) · m = αE ((pr11 G (H ( c1)), (pr11 G (H (c2)))), (pr11 G (H (c3)))) · # TE (id pr11 G (H (c1)) #, pt_GH (c2, c3)) · pt_GH (c1, TC (c2,c3)) · m). set (ptF := (TransportedTensorComm Duniv H_eso H_ff TC)). assert (pp : pt_GH (c1, c2) = ptG (H c1, H c2) · #(pr11 G) (ptH (c1,c2))). { apply idpath. } refine (_ @ tt @ _) ; unfold m ; clear tt. + rewrite pp. rewrite ! (functor_comp (pr1 G)). assert (qq : pt_GH (TC (c1, c2), c3) = ptG (H (TC (c1,c2)), H c3) · #(pr11 G) (ptH (TC (c1,c2),c3))). { apply idpath. } rewrite qq. fold ptF. rewrite <- (id_right (id (pr11 G) (H c3))). rewrite binprod_comp. rewrite (functor_comp TE _ _). rewrite ! assoc'. apply maponpaths. rewrite ! assoc. rewrite (functor_id H). do 4 apply maponpaths_2. rewrite <- (functor_id (pr1 G)). exact (! pr212 G _ _ (ptF (c1, c2) #, id H c3)). + rewrite ! assoc'. apply maponpaths. assert (qq' : (pt_GH (c1, TC (c2, c3)) = ptG (H c1, H (TC (c2,c3))) · #(pr11 G) (ptH (c1, TC (c2,c3))))). { apply idpath. } rewrite qq'. fold ptF. assert (qq'' : pt_GH (c2, c3) = ptG (H c2, H c3) · #(pr11 G) (ptH (c2,c3))). { apply idpath. } rewrite qq''. rewrite (! id_right (id (pr11 G) (H c1))). rewrite binprod_comp. rewrite (functor_comp TE _ _). rewrite ! assoc'. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite (functor_comp (pr1 G)). rewrite assoc. apply maponpaths_2. rewrite <- (functor_comp (pr1 G) (ptH (c1, TC (c2, c3)))). etrans. { apply maponpaths. apply (pr12 (pr2 ptF (c1, TC (c2,c3)))). } apply (functor_id (pr1 G)). } rewrite id_left. etrans. { apply maponpaths. apply (! pr212 G _ _ ((id H c1 #, pr1 (pr2 ptF (c2,, c3))))). } unfold functor_tensor_map_dom. unfold functor_composite. simpl. rewrite <- (functor_id (pr1 G)). rewrite assoc. rewrite <- (functor_comp TE). rewrite <- binprod_comp. rewrite (functor_id (pr1 G)). rewrite id_right. rewrite <- (functor_id (pr1 G)). rewrite <- (functor_comp (pr1 G)). etrans. { apply maponpaths_2. do 3 apply maponpaths. apply (pr12 (pr2 ptF (c2,c3))). } etrans. { apply maponpaths_2. do 2 rewrite (functor_id (pr1 G)). apply (functor_id TE). } apply id_left. Qed. Lemma precompA_eso : disp_functor_disp_ess_split_surj precompA. Proof. intros G GG. exists (lift_preserves_associator GG). refine (tt,,tt,,_). split ; apply isapropunit. Qed. Definition precomp_associator_is_ff : fully_faithful (total_functor precompA). Proof. use disp_functor_ff_to_total_ff. - apply (precomp_tensorunit_is_ff Duniv Euniv). - exact precompA_ff. Qed. Definition precomp_associator_is_eso : essentially_surjective (total_functor precompA). Proof. use disp_functor_eso_to_total_eso. - apply (precomp_tensorunit_is_eso Duniv Euniv). - exact precompA_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_tensorunit_disp_cat_is_univalent. Qed. Definition precomp_associator_adj_equiv : adj_equivalence_of_cats (total_functor precompA). Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. + apply is_univalent_total_category. * apply (is_univalent_functor_category _ _ Euniv). * apply is_disp_univalent_functor_tensorunit_disp_cat. + apply functor_ass_disp_cat_is_univalent. - exact precomp_associator_is_ff. - exact precomp_associator_is_eso. Defined. Definition precomp_associator_catiso : catiso (total_category (functor_ass_disp_cat (IC := H I) (ID := IE) TransportedAssociator αE)) (total_category (functor_ass_disp_cat (IC := I) (ID := IE) α αE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_associator_adj_equiv _ _). - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_ass_disp_cat_is_univalent. - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_ass_disp_cat_is_univalent. Defined. End RezkAssociator. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/LiftedMonoidal.v000066400000000000000000000660141451125700300274230ustar00rootroot00000000000000(* In this file we conclude that any monoidal category has a "Monoidal Rezk-completion". More precisely: Let (C,T,I,lu,ru,α) be a monoidal category. Then, there is a univalent monoidal category (D,TD,ID,luD,ruD,αD) which is the free univalent monoidal category/replacement of (C,T,I,lu,ru,α), i.e. There is a strong monoidal functor H: (C,T,I,lu,ru,α) → (D,TD,ID,luD,ruD,αD) such that for any univalent monoidal category (E,TE,IE,luE,ruE,αD), there is an (adjoint) equivalence of categories between (lax-)monoidal functor categories: H · (-) : LaxMon(D,E) → LaxMon(C,E). In order to show this, we assume that the underlying category, i.e. C, has a Rezk-completion. However, the specific constructions of the Rezk-completion of (ordinary) categories has some issues: 1. The copresheaf construction increases the universe level 2. The inductive definition, as the name suggests, uses inductive types, which is not directly allowed in UniMath. In order to solve this issue, we are given a univalent category D and a weak equivalence H:C->D Remark: That H might be choosen to be a weak equivalence is motivated by the copresheaf construction. We explicitely use that H is a weak equivalence (as seen in LiftedTensor.v) because in order to show the adjoint equivalence of the corresponding monoidal functor categories, we use that the functor categories are univalent and hence it suffices to show that precomposition with H is a weak equivalence which reduces to H being an equivalence. Notice that by the universal property of the Rezk-completion, both D and H are unique (at first sight up to isomorphism, but even up to equality since the bicategory of univalent categories is univalent. Then, using the universal property of D as the Rezk-completion of C (i.e. the free univalent category of C), that D can be equipped with a monoidal structure such that H becomes a strong monoidal functor. By the universal property of (D,H) we have an (adjoint) equivalence of categories H · (-) : [D,E] → [C,E] (for any univalent category E). We show that this equivalence of categories lifts to (lax-)monoidal functors. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecompEquivalence. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensor. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensorUnit. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedUnitors. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedAssociator. Local Open Scope cat. Section RezkMonoidal. Context {C D : category} {H : functor C D} (Duniv : is_univalent D) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (I : C) (lu : left_unitor TC I) (ru : right_unitor TC I) (α : associator TC) (tri : triangle_eq TC I lu ru α) (pent : pentagon_eq TC α). Let TD := TransportedTensor Duniv H_eso H_ff TC. Let ID := (H I). Let luD := TransportedLeftUnitor Duniv H_eso H_ff _ _ lu. Let ruD := TransportedRightUnitor Duniv H_eso H_ff _ _ ru. Let αD := TransportedAssociator Duniv H_eso H_ff _ α. Lemma TransportedTriangleEq : triangle_eq TD (H I) luD ruD αD. Proof. intros y1 y2. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y1). } { apply homset_property. } 2: exact (H_eso y1). intros [x1 xx1]. induction (isotoid _ Duniv xx1). clear xx1. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y2). } { apply homset_property. } 2: exact (H_eso y2). intros [x2 xx2]. induction (isotoid _ Duniv xx2). clear xx2. etrans. { apply maponpaths. apply maponpaths_2. exact (TransportedRightUnitorOnOb Duniv H_eso H_ff TC I ru x1). } etrans. 2: { do 3 apply maponpaths. exact (! TransportedLeftUnitorOnOb Duniv H_eso H_ff TC I lu x2). } etrans. 2: { apply maponpaths_2. exact (! TransportedAssociatorOnOb Duniv H_eso H_ff TC α ((x1,I),x2)). } rewrite (! id_right (id H x2)). rewrite (! id_right (id H x1)). do 2 rewrite binprod_comp. rewrite (functor_comp TD). rewrite <- functor_id. assert (p0 : #TD (#H (ru x1) #, #H (id x2)) = (pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (I_posttensor TC I x1, x2) · # (TC ∙ H) (ru x1 #, id x2) · (pr1 (pr2 (TransportedTensorComm Duniv H_eso H_ff TC) (x1, x2)))). { apply pathsinv0. use (z_iso_inv_to_right _ _ _ _ (_,,(pr2 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (x1, x2)))). exact (! pr21 (TransportedTensorComm Duniv H_eso H_ff TC) _ _ (ru x1 #, id x2)). } etrans. { apply maponpaths. exact p0. } clear p0. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. exact (maponpaths #H (tri x1 x2)). } rewrite (functor_comp H). assert (p0 : # TD (LiftPreservesPostTensor Duniv H_eso H_ff TC I x1 #, # H (id x2)) · ((pr11 (TransportedTensorComm Duniv H_eso H_ff TC)) (I_posttensor TC I x1, x2)) = TransportedAssocLeft Duniv H_eso H_ff TC ((x1, I), x2)). { symmetry. refine (TransportedAssocLeftOnOb Duniv H_eso H_ff TC x1 I x2 @ _). apply maponpaths_2. unfold LiftPreservesPostTensor. rewrite functor_id. apply maponpaths. apply maponpaths_2. unfold TransportedTensorComm. simpl. rewrite ! id_left. rewrite ! id_right. rewrite (functor_id (lift_functor_along (D,, Duniv) (pair_functor H H) (pair_functor_eso H H H_eso H_eso) (pair_functor_ff H H H_ff H_ff) (TC ∙ H))). rewrite functor_id. rewrite id_right. apply (! id_left _). } rewrite ! assoc. etrans. { do 3 apply maponpaths_2. exact p0. } clear p0. rewrite ! assoc'. do 2 apply maponpaths. rewrite functor_comp. etrans. { apply (pr21 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC))). } rewrite assoc. rewrite <- functor_id. apply maponpaths_2. assert (p0 : LiftPreservesPretensor Duniv H_eso H_ff TC I x2 = (TransportedTensorComm Duniv H_eso H_ff TC) (I,x2)). { simpl. rewrite ! functor_id. rewrite ! id_left. rewrite ! id_right. etrans. { apply maponpaths_2. apply functor_id. } apply id_left. } rewrite p0. clear p0. set (i := pr2 (nat_z_iso_inv ((TransportedAssocRight Duniv H_eso H_ff TC))) ((x1, I), x2)). use (z_iso_inv_to_left _ _ _ (_,,i)). set (j := pr2 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (x1, I_pretensor TC I x2)). use (z_iso_inv_to_right _ _ _ _ (_,,j)). exact (TransportedAssocRightOnOb Duniv H_eso H_ff TC x1 I x2). Qed. Lemma TransportedPentagonEq : pentagon_eq TD αD. Proof. intros y1 y2 y3 y4. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y1). } { apply homset_property. } 2: exact (H_eso y1). intros [x1 xx1]. induction (isotoid _ Duniv xx1). clear xx1. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y2). } { apply homset_property. } 2: exact (H_eso y2). intros [x2 xx2]. induction (isotoid _ Duniv xx2). clear xx2. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y3). } { apply homset_property. } 2: exact (H_eso y3). intros [x3 xx3]. induction (isotoid _ Duniv xx3). clear xx3. use factor_through_squash. { exact (∑ a : C, z_iso (H a) y4). } { apply homset_property. } 2: exact (H_eso y4). intros [x4 xx4]. induction (isotoid _ Duniv xx4). clear xx4. set (pentH := maponpaths #H (pent x1 x2 x3 x4)). rewrite ! functor_comp in pentH. set (tαD := TransportedAssociatorOnOb Duniv H_eso H_ff TC α). etrans. { apply maponpaths. apply TransportedAssociator_tensor_r_on_ob. } etrans. { apply maponpaths_2. apply TransportedAssociator_tensor_l_on_ob. } assert (p0 : assoc_right_tensor_l Duniv H_eso H_ff TC x1 x2 x3 x4 · assoc_left_tensor_r Duniv H_eso H_ff TC x1 x2 x3 x4 = identity _). { unfold assoc_right_tensor_l, assoc_left_tensor_r. rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply (! functor_comp TD _ _). } etrans. { apply maponpaths_2. do 2 apply maponpaths. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). } etrans. { apply maponpaths_2. do 2 apply maponpaths. rewrite id_right. rewrite id_left. apply idpath. } etrans. { do 2 apply maponpaths_2. exact (TransportedAssocRightInvOnOb Duniv H_eso H_ff TC (TC (x1,x2)) x3 x4). } etrans. { apply maponpaths. exact (TransportedAssocLeftOnOb Duniv H_eso H_ff TC x1 x2 (TC (x3,x4))). } etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. apply (! functor_comp TD _ _). apply maponpaths. etrans. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). rewrite functor_id. rewrite id_left. apply maponpaths. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } etrans. { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. etrans. apply (! functor_comp TD _ _). apply maponpaths. etrans. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). rewrite id_right. apply maponpaths_2. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } rewrite binprod_id. rewrite functor_id. rewrite id_right. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } etrans. { rewrite assoc'. apply maponpaths. do 2 rewrite assoc. do 2 apply maponpaths_2. exact p0. } clear p0. rewrite id_left. etrans. { rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. exact pentH. } etrans. 2: { do 2 apply maponpaths_2. apply maponpaths. apply maponpaths_2. exact (! tαD ((x1,x2),x3)). } etrans. 2: { do 3 apply maponpaths. exact (! tαD ((x2,x3),x4)). } etrans. 2: { apply maponpaths_2. apply maponpaths. exact (! TransportedAssociator_tensor_m_on_ob _ _ _ _ _ x1 x2 x3 x4). } etrans. 2: { apply maponpaths_2. rewrite <- (id_right (id H x4)). rewrite binprod_comp. rewrite (functor_comp TD). rewrite <- (id_right (id H x4)). rewrite binprod_comp. rewrite (functor_comp TD). rewrite id_right. rewrite assoc. apply maponpaths_2. rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. assert (p : # TD (nat_z_iso_inv (TransportedAssocRight Duniv H_eso H_ff TC) ((x1, x2), x3) #, id H x4) · assoc_left_tensor_m Duniv H_eso H_ff TC x1 x2 x3 x4 = TransportedTensorComm Duniv H_eso H_ff TC (TC (x1,(TC (x2,x3))),x4)). { rewrite TransportedAssocRightInvOnOb. unfold assoc_left_tensor_m. rewrite assoc. etrans. apply maponpaths_2, (! functor_comp TD _ _). unfold TransportedAssocLeft. simpl. do 2 rewrite id_right. rewrite ! assoc. etrans. 2: apply id_left. apply maponpaths_2. rewrite id_right. fold TD. set (ptH := (TransportedTensorComm Duniv H_eso H_ff TC)). etrans. apply (! functor_comp TD _ _). rewrite <- (functor_id TD). apply maponpaths. rewrite (id_left (C := D ⊠ D)). rewrite (id_right (C := D ⊠ D)). etrans. { rewrite assoc'. apply maponpaths. apply binprod_comp. } etrans. { apply maponpaths_2. rewrite <- (id_left (id H x4)). apply binprod_comp. } rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite <- binprod_comp. rewrite id_left. simpl. apply maponpaths_2. rewrite <- (functor_comp TD). apply maponpaths. rewrite <- binprod_comp. rewrite id_right. rewrite functor_id. apply maponpaths. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } rewrite binprod_id. rewrite (functor_id TD). rewrite binprod_id. rewrite id_right. simpl. etrans. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). rewrite id_right. etrans. { apply maponpaths_2. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } apply binprod_id. } exact (! p). } etrans. 2: { rewrite assoc'. apply maponpaths. rewrite <- (id_left (id H x1)). etrans. 2: { apply maponpaths. rewrite binprod_comp. apply (! functor_comp TD _ _). } rewrite assoc. apply maponpaths_2. rewrite <- (id_left (id H x1)). rewrite binprod_comp. rewrite functor_comp. rewrite assoc. apply maponpaths_2. assert (p : assoc_right_tensor_m Duniv H_eso H_ff TC x1 x2 x3 x4 · # TD (id H x1 #, TransportedAssocLeft Duniv H_eso H_ff TC ((x2, x3), x4)) = nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC) (x1 , TC (TC (x2,x3), x4))). { rewrite TransportedAssocLeftOnOb. unfold assoc_right_tensor_m. rewrite TransportedAssocRightInvOnOb. rewrite ! assoc'. etrans. 2: apply id_right. apply maponpaths. simpl. etrans. { apply maponpaths. rewrite <- (functor_comp TD). apply maponpaths. rewrite <- binprod_comp. apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite <- (functor_comp TD). apply maponpaths. etrans. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). apply maponpaths_2. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } rewrite ! id_left. rewrite binprod_id. rewrite (functor_id TD). rewrite <- (id_left (id H x1)). rewrite binprod_comp. rewrite (functor_comp TD). rewrite binprod_id. rewrite (functor_id TD). rewrite id_left. rewrite <- (functor_comp TD). rewrite <- (functor_id TD). apply maponpaths. rewrite <- binprod_comp. rewrite id_right. rewrite functor_id. etrans. apply maponpaths, (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). apply binprod_id. } exact (! p). } unfold assoc_left_tensor_l. rewrite TransportedAssocLeftOnOb. rewrite ! assoc'. etrans. 2: { apply maponpaths_2. rewrite <- (id_right (id H x4)). rewrite binprod_comp. apply (! functor_comp TD _ _). } rewrite assoc'. apply maponpaths. etrans. { apply maponpaths_2. exact (TransportedAssocLeftOnOb Duniv H_eso H_ff TC (TC (x1,x2)) x3 x4). } rewrite assoc'. apply maponpaths. rewrite assoc. etrans. { apply maponpaths_2. exact (! pr21 (TransportedTensorComm Duniv H_eso H_ff TC) _ _ (α ((x1,x2),x3) #, id x4)). } rewrite ! assoc'. rewrite <- functor_id. do 3 apply maponpaths. unfold assoc_right_tensor_r. etrans. 2: { rewrite assoc. apply maponpaths_2. rewrite <- (functor_id H). exact (pr21 (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) _ _ (id x1 #, α ((x2,x3),x4))). } rewrite ! assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply (TransportedAssocRightInvOnOb Duniv H_eso H_ff TC). } rewrite ! assoc'. apply maponpaths. etrans. apply (! functor_comp TD _ _). apply maponpaths. rewrite functor_id. etrans. apply (! binprod_comp _ _ _ _ _ _ _ _ _ _). rewrite id_left. apply maponpaths. refine (_ @ ! TransportedAssocRightInvOnOb Duniv H_eso H_ff TC _ _ _). do 2 apply maponpaths. apply maponpaths_2. apply (! functor_id _ _). Qed. Definition TransportedMonoidal : monoidal_cat := D ,, TD ,, H I ,, luD ,, ruD ,, αD ,, TransportedTriangleEq ,, TransportedPentagonEq. Definition H_monoidal : functor_monoidal_cat lu luD ru ruD α αD. Proof. exists (H,, pr1 (TransportedTensorComm Duniv H_eso H_ff TC),, id H I). split. - split. + exact (H_plu Duniv H_eso H_ff TC I lu). + exact (H_pru Duniv H_eso H_ff TC I ru). - exact (H_pα Duniv H_eso H_ff TC α I). Defined. Definition H_strong_monoidal : strong_functor_monoidal_cat lu luD ru ruD α αD. Proof. exists H_monoidal. split. - apply (TransportedTensorComm Duniv H_eso H_ff TC). - apply identity_is_z_iso. Defined. Context {E : category} (Euniv : is_univalent E) (TE : functor (E ⊠ E) E) (IE : E) (luE : left_unitor TE IE) (ruE : right_unitor TE IE) (αE : associator TE). Definition precompMonoidal : disp_functor (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE) (functor_monoidal_disp_cat luD luE ruD ruE αD αE) (functor_monoidal_disp_cat lu luE ru ruE α αE). Proof. apply disp_prod_functor_over_fixed_base. - apply disp_prod_functor_over_fixed_base. + apply precompLU. + apply precompRU. - apply precompA. Defined. Definition precompStrongMonoidal : disp_functor (total_functor precompMonoidal) (functor_strong_monoidal_disp_cat luD luE ruD ruE αD αE) (functor_strong_monoidal_disp_cat lu luE ru ruE α αE). Proof. use tpair. - exists (λ F pFi, strong_functor_composition (pr2 H_strong_monoidal) pFi). intro ; intros ; exact tt. - abstract (split ; intro ; intros ; apply isapropunit). Defined. Definition precompMonoidal_ff : disp_functor_ff precompMonoidal. Proof. apply disp_prod_functor_over_fixed_base_ff. - apply disp_prod_functor_over_fixed_base_ff. + apply precompLU_ff. + apply precompRU_ff. - apply precompA_ff. Qed. Definition precompStrongMonoidal_ff : disp_functor_ff precompStrongMonoidal. Proof. intro ; intros. apply isweqcontrtounit. apply iscontrunit. Qed. Definition precompMonoidal_eso : disp_functor_disp_ess_split_surj precompMonoidal. Proof. apply disp_prod_functor_over_fixed_base_eso. - apply disp_prod_functor_over_fixed_base_eso. + apply precompLU_eso. + apply precompRU_eso. - apply precompA_eso. (* exact Euniv. *) Qed. Definition precompStrongMonoidal_eso : disp_functor_disp_ess_split_surj precompStrongMonoidal. Proof. intro ; intros. use tpair. - use tpair. + transparent assert (i : (nat_z_iso (functor_tensor_map_dom TE (pr11 x)) (functor_tensor_map_codom (TransportedTensor Duniv H_eso H_ff TC) (pr11 x)))). { use (lift_nat_z_iso_along (_,,Euniv) _ (pair_functor_eso _ _ H_eso H_eso) (pair_functor_ff _ _ H_ff H_ff)). use (nat_z_iso_comp (make_nat_z_iso _ _ _ (pr1 xx)) _). exact (post_whisker_nat_z_iso (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (pr11 x)). } assert (p : pr1 i = pr121 x). { use (lift_nat_trans_eq_along (_,,Euniv) _ (pair_functor_eso _ _ H_eso H_eso) (pair_functor_ff _ _ H_ff H_ff)). etrans. { apply lift_nat_trans_along_comm. } refine (idpath (nat_trans_comp _ _ _ (pr121 (total_functor precompMonoidal x)) (post_whisker (nat_z_iso_inv (TransportedTensorComm Duniv H_eso H_ff TC)) (pr11 x))) @ _). use nat_trans_eq. { apply homset_property. } intro cc. simpl. rewrite assoc'. rewrite <- (functor_comp (pr11 x)). etrans. { do 2 apply maponpaths. apply (pr2 (TransportedTensorComm Duniv H_eso H_ff TC)). } rewrite (functor_id (pr11 x)). apply id_right. } rewrite <- p. exact (pr2 i). + set (a := pr2 xx). simpl in a. rewrite (functor_id (pr11 x)) in a. rewrite id_right in a. exact a. - refine (tt ,, tt ,, _). split ; apply isapropunit. Qed. Definition precomp_monoidal_is_ff : fully_faithful (total_functor precompMonoidal). Proof. use disp_functor_ff_to_total_ff. - apply (precomp_tensorunit_is_ff Duniv Euniv). - exact precompMonoidal_ff. Qed. Definition precomp_strongmonoidal_is_ff : fully_faithful (total_functor precompStrongMonoidal). Proof. use disp_functor_ff_to_total_ff. - apply precomp_monoidal_is_ff. - exact precompStrongMonoidal_ff. Qed. Lemma is_univalent_LaxMonoidalFunctorCategory : is_univalent (total_category (functor_monoidal_disp_cat luD luE ruD ruE αD αE)). Proof. apply is_univalent_total_category. - apply is_univalent_total_category. + apply (is_univalent_functor_category _ _ Euniv). + apply is_disp_univalent_functor_tensorunit_disp_cat. - apply Constructions.dirprod_disp_cat_is_univalent. { apply Constructions.dirprod_disp_cat_is_univalent. apply functor_lu_disp_cat_is_univalent. apply functor_ru_disp_cat_is_univalent. } apply functor_ass_disp_cat_is_univalent. Qed. Lemma is_univalent_LaxMonoidalFunctorCategory' : is_univalent (total_category (functor_monoidal_disp_cat lu luE ru ruE α αE)). Proof. apply is_univalent_total_category. - apply is_univalent_total_category. + apply (is_univalent_functor_category _ _ Euniv). + apply functor_tensorunit_disp_cat_is_univalent. - apply Constructions.dirprod_disp_cat_is_univalent. { apply Constructions.dirprod_disp_cat_is_univalent. apply functor_lu_disp_cat_is_univalent. apply functor_ru_disp_cat_is_univalent. } apply functor_ass_disp_cat_is_univalent. Qed. Lemma is_univalent_StrongMonoidalFunctorCategory : is_univalent (total_category (functor_strong_monoidal_disp_cat luD luE ruD ruE αD αE)). Proof. apply is_univalent_total_category. - apply is_univalent_LaxMonoidalFunctorCategory. - apply Constructions.disp_full_sub_univalent. intro ; apply isapropdirprod. apply isaprop_is_nat_z_iso. apply isaprop_is_z_isomorphism. Qed. Definition precomp_monoidal_is_eso : essentially_surjective (total_functor precompMonoidal). Proof. use disp_functor_eso_to_total_eso. - apply (precomp_tensorunit_is_eso Duniv Euniv). - exact precompMonoidal_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_tensorunit_disp_cat_is_univalent. Qed. Definition precomp_strongmonoidal_is_eso : essentially_surjective (total_functor precompStrongMonoidal). Proof. use disp_functor_eso_to_total_eso. - apply precomp_monoidal_is_eso. - exact precompStrongMonoidal_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_LaxMonoidalFunctorCategory'. Qed. Definition precomp_monoidal_adj_equiv : adj_equivalence_of_cats (total_functor precompMonoidal). Proof. apply rad_equivalence_of_cats. - apply is_univalent_LaxMonoidalFunctorCategory. - exact precomp_monoidal_is_ff. - exact precomp_monoidal_is_eso. Defined. Definition precomp_monoidal_catiso : catiso (total_category (functor_monoidal_disp_cat (TransportedLeftUnitor Duniv H_eso H_ff TC I lu) luE (TransportedRightUnitor Duniv H_eso H_ff TC I ru) ruE (TransportedAssociator Duniv H_eso H_ff TC α) αE )) (total_category (functor_monoidal_disp_cat lu luE ru ruE α αE )). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_monoidal_adj_equiv _ _). - apply is_univalent_LaxMonoidalFunctorCategory. - apply is_univalent_LaxMonoidalFunctorCategory'. Defined. Definition precomp_strongmonoidal_adj_equiv : adj_equivalence_of_cats (total_functor precompStrongMonoidal). Proof. apply rad_equivalence_of_cats. - apply is_univalent_StrongMonoidalFunctorCategory. - exact precomp_strongmonoidal_is_ff. - exact precomp_strongmonoidal_is_eso. Defined. Definition precomp_strongmonoidal_catiso : catiso (total_category (functor_strong_monoidal_disp_cat (TransportedLeftUnitor Duniv H_eso H_ff TC I lu) luE (TransportedRightUnitor Duniv H_eso H_ff TC I ru) ruE (TransportedAssociator Duniv H_eso H_ff TC α) αE )) (total_category (functor_strong_monoidal_disp_cat lu luE ru ruE α αE )). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_strongmonoidal_adj_equiv _ _). - apply is_univalent_StrongMonoidalFunctorCategory. - apply is_univalent_total_category. + apply is_univalent_LaxMonoidalFunctorCategory'. + apply Constructions.disp_full_sub_univalent. intro ; apply isapropdirprod. * apply NaturalTransformations.isaprop_is_nat_z_iso. * apply Isos.isaprop_is_z_isomorphism. Defined. End RezkMonoidal. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/LiftedTensor.v000066400000000000000000000260021451125700300271240ustar00rootroot00000000000000(* This file is the first file with the purpose of showing that any monoidal category admits a 'Monoidal Rezk-completion'. More precisely: Assume that a category C is weakly equivalent to a univalent category D, by a functor H : C → D. Then, given a product/tensor T : C ⊠ C → C, we construct a product TD on D such that H preserves the product in a 'strong sense'. Then, we show that (D,TD) is universal along univalent categories with a product in the sense that (D,TD) is the free univalent category equipped with a tensor of (C,T). A more detailled explanation of the universality and the Rezk-completion is in LiftedMonoidal.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecompEquivalence. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Local Open Scope mor_disp. Local Open Scope cat. Section TensorRezk. Context {C D E : category} {H : functor C D} (Duniv : is_univalent D) (Euniv : is_univalent E) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (TE : functor (E ⊠ E) E). Local Notation HH := (pair_functor H H). Let HH_eso := pair_functor_eso H H H_eso H_eso. Let HH_ff := pair_functor_ff H H H_ff H_ff. Definition TransportedTensor : functor (D ⊠ D) D := lift_functor_along (_,,Duniv) HH HH_eso HH_ff (functor_composite TC H). Definition TransportedTensorComm : nat_z_iso (HH ∙ TransportedTensor) (functor_composite TC H) := lift_functor_along_comm (_,,Duniv) HH HH_eso HH_ff (functor_composite TC H). Let TD := TransportedTensor. Definition precompT_data : disp_functor_data (pre_composition_functor _ _ E H) (functor_tensor_disp_cat TD TE) (functor_tensor_disp_cat TC TE). Proof. exists (λ G GG, functor_tensor_composition (pr1 (TransportedTensorComm)) GG). intros G1 G2 GG1 GG2 β ββ. intros x y. simpl. rewrite assoc. etrans. { apply maponpaths_2 ; exact (ββ (H x) (H y)). } do 2 rewrite assoc'. apply maponpaths. exact (! pr2 β _ _ (pr1 (pr1 (TransportedTensorComm)) (x, y))). Defined. Definition HT : disp_functor (pre_composition_functor _ _ E H) (functor_tensor_disp_cat TD TE) (functor_tensor_disp_cat TC TE). Proof. exists precompT_data. abstract (split ; intro ; intros ; apply isaprop_is_nat_trans_tensor). Defined. Definition lifted_functor_tensor {G : D ⟶ E} (HGG : functor_tensor TC TE (functor_compose H G)) : functor_tensor TD TE G. Proof. use (lift_nat_trans_along (_,,Euniv) _ HH_eso HH_ff). use (nat_trans_comp _ _ _ HGG _). exact (post_whisker (nat_z_iso_inv TransportedTensorComm) G). Defined. Definition HT_eso : disp_functor_disp_ess_split_surj HT. Proof. intros G HGG. exists (lifted_functor_tensor HGG). use Isos.make_z_iso_disp. - intros c1 c2. simpl. rewrite id_right. rewrite (functor_id TE). rewrite id_left. (* In order to use lift_nat_along_comm, we need β to be of type HH · _ -> HH · _, the domain of β is not definitially of this form, hence, I have to do a manual 'casting' *) set (β := nat_trans_comp (functor_tensor_map_dom TE (functor_compose H G)) (functor_tensor_map_codom TC (functor_compose H G)) (HH ∙ functor_tensor_map_codom TD G) HGG (post_whisker (nat_z_iso_inv TransportedTensorComm) G ) : (nat_trans (HH ∙ ((pair_functor G G) ∙ TE)) ( HH ∙ functor_tensor_map_codom TD G)) ). set (p := toforallpaths _ _ _ (base_paths _ _ (lift_nat_trans_along_comm (_,,Euniv) _ HH_eso HH_ff β)) (c1,c2)). etrans. 2: { apply maponpaths_2. exact (! p). } clear p. unfold β. unfold nat_trans_comp. unfold pr1. rewrite assoc'. etrans. 2: { apply maponpaths. apply (functor_comp G). } etrans. 2: { do 2 apply maponpaths. apply (! pr22 (pr2 (TransportedTensorComm) (c1,c2))). } rewrite functor_id. apply (! id_right _). - use tpair. 2: { split ; apply isaprop_is_nat_trans_tensor. } intros c1 c2. simpl. rewrite id_right. rewrite (functor_id TE). rewrite id_left. unfold lifted_functor_tensor. set (β := nat_trans_comp (functor_tensor_map_dom TE (functor_compose H G)) (functor_tensor_map_codom TC (functor_compose H G)) (HH ∙ functor_tensor_map_codom TD G) HGG (post_whisker (nat_z_iso_inv TransportedTensorComm) G ) : (nat_trans (HH ∙ ((pair_functor G G) ∙ TE)) ( HH ∙ functor_tensor_map_codom TD G)) ). set (p := toforallpaths _ _ _ (base_paths _ _ (lift_nat_trans_along_comm (_,,Euniv) _ HH_eso HH_ff β)) (c1,c2)). etrans. { apply maponpaths_2. exact p. } clear p. unfold β. unfold nat_trans_comp. unfold pr1. rewrite assoc'. etrans. { apply maponpaths. apply (! functor_comp G _ _). } etrans. { do 2 apply maponpaths. apply (pr22 (pr2 (TransportedTensorComm) (c1,c2))). } rewrite functor_id. apply id_right. Qed. Definition HT_is_faithful {G1 G2 : [D, E]} (GG1 : functor_tensor_disp_cat TD TE G1) (GG2 : functor_tensor_disp_cat TD TE G2) (β : [D, E] ⟦ G1, G2 ⟧) : isincl (λ ff : GG1 -->[ β] GG2, ♯ HT ff). Proof. do 3 intro. assert (p : isaset ( hfiber (λ ff : GG1 -->[ β] GG2, ♯ HT ff) y)). { use isaset_hfiber ; use isasetaprop ; apply isaprop_is_nat_trans_tensor. } use tpair. + use total2_paths_f. { apply isaprop_is_nat_trans_tensor. } use proofirrelevance. use hlevelntosn. apply isaprop_is_nat_trans_tensor. + intro ; apply p. Qed. Definition HT_is_full {G1 G2 : [D, E]} (GG1 : functor_tensor_disp_cat TD TE G1) (GG2 : functor_tensor_disp_cat TD TE G2) (β : [D, E] ⟦ G1, G2 ⟧) : issurjective (λ ff : GG1 -->[ β] GG2, ♯ HT ff). Proof. intro βHH. apply hinhpr. use tpair. 2: apply isaprop_is_nat_trans_tensor. use is_nat_trans_tensor_to_characterization. use (lift_nat_trans_eq_along (_,,Euniv) _ HH_eso HH_ff). use nat_trans_eq. { apply homset_property. } intro cc. set (t := βHH (pr1 cc) (pr2 cc)). simpl. transparent assert ( ff : (E ⟦ functor_tensor_map_codom TC (pre_composition_functor C D E H G2) (pr1 cc, pr2 cc), functor_tensor_map_codom TD G2 (H (pr1 cc), H (pr2 cc)) ⟧) ). { apply #(pr1 G2). exact (pr1 (pr2 TransportedTensorComm (pr1 cc, pr2 cc))). } assert (p : pr1 GG2 (H (pr1 cc), H (pr2 cc)) = (pr1 (HT G2 GG2) (pr1 cc, pr2 cc)) · ff). { etrans. 2: { simpl. rewrite assoc'. apply maponpaths. unfold ff. rewrite <- (functor_comp G2). apply maponpaths. simpl. apply (! pr12 (pr2 TransportedTensorComm _)). } rewrite (functor_id G2). apply (! id_right _). } etrans. { apply maponpaths ; exact p. } clear p. rewrite assoc. etrans. { apply maponpaths_2 ; exact t. } clear t. simpl. do 2 rewrite assoc'. apply maponpaths. unfold ff. set (q := pr2 β _ _ (pr1 (pr2 TransportedTensorComm (pr1 cc, pr2 cc)))). etrans. { apply maponpaths. exact (! q). } clear q. rewrite assoc. rewrite <- (functor_comp G1). etrans. { apply maponpaths_2. apply maponpaths. apply (pr2 TransportedTensorComm). } rewrite functor_id. apply id_left. Qed. Definition HT_ff : disp_functor_ff HT. Proof. intro ; intros. apply isweqinclandsurj. - apply HT_is_faithful. - apply HT_is_full. Qed. Definition precomp_tensor_is_ff : fully_faithful (total_functor HT). Proof. use disp_functor_ff_to_total_ff. - apply precomp_fully_faithful.pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful. + exact H_eso. + exact H_ff. - exact HT_ff. Qed. Definition precomp_tensor_is_eso : essentially_surjective (total_functor HT). Proof. use disp_functor_eso_to_total_eso. - apply precomp_ess_surj.pre_composition_essentially_surjective. + exact Euniv. + exact H_eso. + exact H_ff. - exact HT_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_functor_category. exact Euniv. Qed. Definition precomp_tensor_adj_equiv : adj_equivalence_of_cats (total_functor HT). Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_tensor_disp_cat_is_univalent. - exact precomp_tensor_is_ff. - exact precomp_tensor_is_eso. Defined. Definition precomp_tensor_catiso : catiso (total_category (functor_tensor_disp_cat TransportedTensor TE)) (total_category (functor_tensor_disp_cat TC TE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_tensor_adj_equiv _ _). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensor_disp_cat_is_univalent _ _)). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensor_disp_cat_is_univalent _ _)). Defined. End TensorRezk. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/LiftedTensorUnit.v000066400000000000000000000227601451125700300277730ustar00rootroot00000000000000(* This file is the second file with the purpose of showing that any monoidal category admits a 'Monoidal Rezk-completion'. More precisely: Assume that a category C is weakly equivalent to a univalent category D, by a functor H : C → D. In the first section, we show that a fixed object I of C, we show that (D, (H I)) is the free univalent category equipped with an object for (C,I). In LiftedTensor.v, we have showed that if C is equipped with a tensor, then it admits a free univalent category equipped with a tensor. In the second section of this file, we combine these results to show that a category equipped with a tensor and a fixed object admits a free univalent category equipped with a tensor and unit. A more detailled explanation of the universality and the Rezk-completion is in LiftedMonoidal.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensor. Local Open Scope mor_disp. Local Open Scope cat. Section LiftedUnit. Context {C D E : category} {H : functor C D} (Duniv : is_univalent D) (Euniv : is_univalent E) (H_eso : essentially_surjective H) (H_ff : fully_faithful H) (I : C) (IE : E). Definition ID : D := H I. Definition precompU_data : disp_functor_data (pre_composition_functor _ _ E H) (functor_unit_disp_cat ID IE) (functor_unit_disp_cat I IE). Proof. exists (λ G GG, GG · #(pr1 G) (identity _)). intros G1 G2 GG1 GG2 β ββ. simpl. unfold is_nat_trans_unit. simpl. rewrite (functor_id G1). rewrite id_right. rewrite (functor_id G2). refine (ββ @ _). apply (! id_right _). Defined. Definition HU : disp_functor (pre_composition_functor _ _ E H) (functor_unit_disp_cat ID IE) (functor_unit_disp_cat I IE). Proof. exists precompU_data. abstract (split ; intro ; intros ; apply homset_property). Defined. Definition HU_eso : disp_functor_disp_ess_split_surj HU. Proof. intros G HGG. exists HGG. use Isos.make_z_iso_disp. - simpl. unfold is_nat_trans_unit. rewrite id_right. rewrite (functor_id G). apply id_right. - use tpair. + simpl. unfold is_nat_trans_unit. rewrite id_right. rewrite (functor_id G). apply (! id_right _). + split ; apply homset_property. Qed. Definition HU_is_faithful {G1 G2 : [D, E]} (GG1 : functor_unit_disp_cat ID IE G1) (GG2 : functor_unit_disp_cat ID IE G2) (β : [D, E] ⟦ G1, G2 ⟧) : isincl (λ ff : GG1 -->[ β] GG2, ♯ HU ff). Proof. do 3 intro. assert (p : isaset ( hfiber (λ ff : GG1 -->[ β] GG2, ♯ HU ff) y)). { use isaset_hfiber ; use isasetaprop ; apply homset_property. } use tpair. + use total2_paths_f. { apply homset_property. } use proofirrelevance. use hlevelntosn. apply homset_property. + intro ; apply p. Qed. Definition HU_is_full {G1 G2 : [D, E]} (GG1 : functor_unit_disp_cat ID IE G1) (GG2 : functor_unit_disp_cat ID IE G2) (β : [D, E] ⟦ G1, G2 ⟧) : issurjective (λ ff : GG1 -->[ β] GG2, ♯ HU ff). Proof. intro βHH. apply hinhpr. use tpair. 2: apply homset_property. simpl in βHH. unfold is_nat_trans_unit in βHH. simpl in βHH. rewrite (functor_id G1) in βHH. rewrite (functor_id G2) in βHH. do 2 rewrite id_right in βHH. exact βHH. Qed. Definition HU_ff : disp_functor_ff HU. Proof. intro ; intros. apply isweqinclandsurj. - apply HU_is_faithful. - apply HU_is_full. Qed. Definition precomp_unit_is_ff : fully_faithful (total_functor HU). Proof. use disp_functor_ff_to_total_ff. - apply precomp_fully_faithful.pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful. + exact H_eso. + exact H_ff. - exact HU_ff. Qed. Definition precomp_unit_is_eso : essentially_surjective (total_functor HU). Proof. use disp_functor_eso_to_total_eso. - apply precomp_ess_surj.pre_composition_essentially_surjective. + exact Euniv. + exact H_eso. + exact H_ff. - exact HU_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_functor_category. exact Euniv. Qed. Definition precomp_unit_adj_equiv : adj_equivalence_of_cats (total_functor HU). Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_unit_disp_cat_is_univalent. - exact precomp_unit_is_ff. - exact precomp_unit_is_eso. Defined. Definition precomp_unit_catiso : catiso (total_category (functor_unit_disp_cat (H I) IE)) (total_category (functor_unit_disp_cat I IE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_unit_adj_equiv). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_unit_disp_cat_is_univalent _ _)). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_unit_disp_cat_is_univalent _ _)). Defined. End LiftedUnit. Section LiftedTensorUnit. Context {C D E : category} {H : functor C D} (Duniv : is_univalent D) (Euniv : is_univalent E) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (I : C) (TE : functor (E ⊠ E) E) (IE : E). Let TD := TransportedTensor Duniv H_eso H_ff TC. Let ID := H I. Definition precomp_tensorunit_disp_functor : disp_functor (pre_composition_functor C D E H) (MonoidalFunctorCategory.functor_tensorunit_disp_cat TD TE ID IE) (MonoidalFunctorCategory.functor_tensorunit_disp_cat TC TE I IE) := disp_prod_functor_over_fixed_base (HT Duniv H_eso H_ff TC TE) (HU I IE). Definition precomp_tensorunit_functor : functor (MonoidalFunctorCategory.functor_tensorunit_cat TD TE ID IE) (MonoidalFunctorCategory.functor_tensorunit_cat TC TE I IE). Proof. use total_functor. { exact (pre_composition_functor _ _ E H). } exact precomp_tensorunit_disp_functor. Defined. Lemma is_disp_univalent_functor_tensorunit_disp_cat : Univalence.is_univalent_disp (MonoidalFunctorCategory.functor_tensorunit_disp_cat TD TE ID IE). Proof. apply Constructions.dirprod_disp_cat_is_univalent. - apply functor_tensor_disp_cat_is_univalent. - apply functor_unit_disp_cat_is_univalent. Qed. Lemma precomp_tensorunit_is_ff : fully_faithful precomp_tensorunit_functor. Proof. apply disp_functor_ff_to_total_ff. { apply precomp_fully_faithful.pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful. - exact H_eso. - exact H_ff. } apply disp_prod_functor_over_fixed_base_ff. - exact (HT_ff Duniv Euniv H_eso H_ff TC TE). - exact (HU_ff I IE). Qed. Lemma precomp_tensorunit_is_eso : essentially_surjective precomp_tensorunit_functor. Proof. apply disp_functor_eso_to_total_eso. { apply precomp_ess_surj.pre_composition_essentially_surjective. - exact Euniv. - exact H_eso. - exact H_ff. } apply disp_prod_functor_over_fixed_base_eso. - exact (HT_eso Duniv Euniv H_eso H_ff TC TE). - exact (HU_eso I IE). - use Fibrations.iso_cleaving_category. apply is_univalent_functor_category. exact Euniv. Qed. Definition precomp_tensorunit_adj_equiv : adj_equivalence_of_cats precomp_tensorunit_functor. Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. { apply is_univalent_functor_category, Euniv. } exact is_disp_univalent_functor_tensorunit_disp_cat. - exact precomp_tensorunit_is_ff. - exact precomp_tensorunit_is_eso. Defined. Definition precomp_tensorunit_catiso : catiso (total_category (functor_tensorunit_disp_cat TD TE (H I) IE)) (total_category (functor_tensorunit_disp_cat TC TE I IE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_tensorunit_adj_equiv _ _). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). Defined. End LiftedTensorUnit. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/LiftedUnitors.v000066400000000000000000000402561451125700300273240ustar00rootroot00000000000000(* In LiftedTensor.v and LiftedTensor.v, we have shown that given a category C equipped with a binary operation T and an object I (called the tensor and unit resp.), then, this structures 'transport' to a weakly equivalent univalent category D, by a weak equivalence H:C->D, making this univalent category D with a tensor and unit, the free univalent category equipped with a tensor and a unit. In this file, we show that if we equip (C,T,I) with a left and/or right unitor, then 1: the unitor(s) also transports to D. 2: H preserves the unitor(s) as a monoidal functor preserves the unitor(s). 3: H makes D the free univalent category equipped with tensor, unit and the unitors. More details about the universality and the Rezk-completion can be found in LiftedMonoidal.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecompEquivalence. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensor. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedTensorUnit. Local Open Scope mor_disp. Local Open Scope cat. Section RezkLeftUnitor. Context {C D : category} {H : functor C D} (Duniv : is_univalent D) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (I : C) (lu : left_unitor TC I). Let TD := TransportedTensor Duniv H_eso H_ff TC. Local Notation HH := (pair_functor H H). Let HH_eso := pair_functor_eso H H H_eso H_eso. Let HH_ff := pair_functor_ff H H H_ff H_ff. Lemma LiftPreservesPretensor : nat_z_iso (H ∙ I_pretensor TD (H I)) (I_pretensor TC I ∙ H). Proof. use nat_z_iso_comp. 2: { apply pre_whisker_nat_z_iso. apply tensor_after_pair_with_object_left. } use nat_z_iso_comp. 3: { apply nat_z_iso_inv. use post_whisker_nat_z_iso. 2: apply tensor_after_pair_with_object_left. } use nat_z_iso_comp. 3: { apply nat_z_iso_functor_comp_assoc. } use nat_z_iso_comp. 3: { apply pre_whisker_nat_z_iso. exact (TransportedTensorComm Duniv H_eso H_ff TC). } use nat_z_iso_comp. 2: { apply nat_z_iso_functor_comp_assoc. } use nat_z_iso_comp. 3: { apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). } apply post_whisker_nat_z_iso. apply PairingWithObjectCommutesLeft. Defined. Definition TransportedLeftUnitor : left_unitor TD (H I). Proof. use (lift_nat_z_iso_along (_,,Duniv) H H_eso H_ff). use nat_z_iso_comp. 2: exact LiftPreservesPretensor. exact (post_whisker_nat_z_iso lu H). Defined. Let luD := TransportedLeftUnitor. (* The following definition relates the transported left unitor with the left unitor on C. In particular, this shows that H preserves the left unitor *) Definition TransportedLeftUnitorEq : pre_whisker H TransportedLeftUnitor = nat_z_iso_comp LiftPreservesPretensor (post_whisker_nat_z_iso lu H). Proof. set (t := lift_nat_trans_along_comm (_,,Duniv) _ H_eso H_ff (nat_z_iso_comp LiftPreservesPretensor (nat_z_iso_comp (post_whisker_nat_z_iso lu H) (nat_z_iso_inv (functor_commutes_with_id H)) ) ) ). refine (_ @ t @ _). - apply maponpaths. apply (maponpaths ( lift_nat_trans_along (D,, Duniv) H H_eso H_ff)). do 2 apply maponpaths. use total2_paths_f. 2: apply isaprop_is_nat_z_iso. use nat_trans_eq. { apply homset_property. } intro. apply (! id_right _). - do 2 apply maponpaths. use total2_paths_f. 2: { apply isaprop_is_nat_z_iso. } use nat_trans_eq. { apply homset_property. } intro. apply id_right. Qed. Definition H_plu : (functor_lu_disp_cat lu luD) (H ,, (pr1 (TransportedTensorComm Duniv H_eso H_ff TC) ,, identity _)). Proof. intro c. set (t := toforallpaths _ _ _ (base_paths _ _ TransportedLeftUnitorEq) c). refine (t @ _). clear t. etrans. 2: { do 2 apply maponpaths_2. exact (! functor_id TD (H I , H c)). } rewrite id_left. simpl. rewrite ! id_left. rewrite functor_id. rewrite ! id_right. rewrite (functor_id (lift_functor_along (D,, Duniv) HH HH_eso HH_ff (TC ∙ H))). rewrite id_left. apply idpath. Qed. Lemma TransportedLeftUnitorOnOb (c : C) : TransportedLeftUnitor (H c) = (LiftPreservesPretensor c) · #H (lu c). Proof. exact (toforallpaths _ _ _ (base_paths _ _ TransportedLeftUnitorEq) c). Qed. Context {E : category} (Euniv : is_univalent E) (TE : functor (E ⊠ E) E) (IE : E) (luE : left_unitor TE IE). Definition precompLU : disp_functor (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE) (functor_lu_disp_cat luD luE) (functor_lu_disp_cat lu luE). Proof. use tpair. - use tpair. 2: intro ; intros ; exact tt. exact (λ G GG, functor_lu_composition H_plu GG). - split ; intro ; intros ; apply isapropunit. Qed. Lemma precompLU_ff : disp_functor_ff precompLU. Proof. intro ; intros. apply isweqinclandsurj. - do 3 intro. assert (p : isaset ( hfiber (λ ff : unit, ♯ precompLU ff) y0)). { use isaset_hfiber ; use isasetaprop ; apply isapropunit. } use tpair. + use total2_paths_f. { apply isapropunit. } use proofirrelevance. use hlevelntosn. apply isapropunit. + intro ; apply p. - intro ; intros. apply hinhpr. exists tt. apply isapropunit. Qed. Lemma precompLU_eso : disp_functor_disp_ess_split_surj precompLU. Proof. intros G GG. use tpair. - intro d. use factor_through_squash. { exact (∑ a : C, z_iso (H a) d). } { apply homset_property. } 2: exact (H_eso d). intro cd. induction (isotoid _ Duniv (pr2 cd)). refine (GG (pr1 cd) @ _). simpl. rewrite (functor_id (pr1 G)). rewrite id_right. do 3 rewrite assoc'. do 2 apply maponpaths. rewrite <- (functor_comp (pr1 G)). apply maponpaths. simpl. refine (_ @ ! TransportedLeftUnitorOnOb (pr1 cd)). apply maponpaths_2. unfold LiftPreservesPretensor. simpl. rewrite ! id_left. rewrite ! id_right. rewrite (functor_id H). rewrite id_right. etrans. 2: { apply maponpaths_2. apply (! functor_id _ _). } apply (! id_left _). - exists tt. exists tt. split ; apply isapropunit. Qed. Definition precomp_lunitor_is_ff : fully_faithful (total_functor precompLU). Proof. use disp_functor_ff_to_total_ff. - apply (precomp_tensorunit_is_ff Duniv Euniv). - exact precompLU_ff. Qed. Definition precomp_lunitor_is_eso : essentially_surjective (total_functor precompLU). Proof. use disp_functor_eso_to_total_eso. - apply (precomp_tensorunit_is_eso Duniv Euniv). - exact precompLU_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_tensorunit_disp_cat_is_univalent. Qed. Definition precomp_lunitor_adj_equiv : adj_equivalence_of_cats (total_functor precompLU). Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. + apply is_univalent_total_category. * apply (is_univalent_functor_category _ _ Euniv). * apply is_disp_univalent_functor_tensorunit_disp_cat. + apply functor_lu_disp_cat_is_univalent. - exact precomp_lunitor_is_ff. - exact precomp_lunitor_is_eso. Defined. Definition precomp_lunitor_catiso : catiso (total_category (functor_lu_disp_cat TransportedLeftUnitor luE)) (total_category (functor_lu_disp_cat lu luE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_lunitor_adj_equiv _ _). - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_lu_disp_cat_is_univalent. - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_lu_disp_cat_is_univalent. Defined. End RezkLeftUnitor. Section RezkRightUnitor. Context {C D : category} {H : functor C D} (Duniv : is_univalent D) (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Context (TC : functor (C ⊠ C) C) (I : C) (ru : right_unitor TC I). Let TD := TransportedTensor Duniv H_eso H_ff TC. Local Notation HH := (pair_functor H H). Let HH_eso := pair_functor_eso H H H_eso H_eso. Let HH_ff := pair_functor_ff H H H_ff H_ff. Lemma LiftPreservesPostTensor : nat_z_iso (H ∙ I_posttensor TD (H I)) (I_posttensor TC I ∙ H). Proof. use nat_z_iso_comp. 2: { apply pre_whisker_nat_z_iso. apply tensor_after_pair_with_object_right. } use nat_z_iso_comp. 3: { apply nat_z_iso_inv. use post_whisker_nat_z_iso. 2: apply tensor_after_pair_with_object_right. } use nat_z_iso_comp. 3: { apply nat_z_iso_functor_comp_assoc. } use nat_z_iso_comp. 3: { apply pre_whisker_nat_z_iso. exact (TransportedTensorComm Duniv H_eso H_ff TC). } use nat_z_iso_comp. 2: { apply nat_z_iso_functor_comp_assoc. } use nat_z_iso_comp. 3: { apply (nat_z_iso_inv (nat_z_iso_functor_comp_assoc _ _ _)). } apply post_whisker_nat_z_iso. apply PairingWithObjectCommutesRight. Defined. Definition TransportedRightUnitor : right_unitor TD (H I). Proof. use (lift_nat_z_iso_along (_,,Duniv) H H_eso H_ff). use nat_z_iso_comp. 2: exact LiftPreservesPostTensor. exact (post_whisker_nat_z_iso ru H). Defined. Let ruD := TransportedRightUnitor. Definition TransportedRightUnitorEq : pre_whisker H TransportedRightUnitor = nat_trans_comp _ _ _ LiftPreservesPostTensor (post_whisker_nat_z_iso ru H). Proof. unfold TransportedRightUnitor. etrans. 2: { apply (lift_nat_trans_along_comm (_,,Duniv) _ H_eso H_ff). } apply maponpaths. apply (maponpaths ( lift_nat_trans_along (D,, Duniv) H H_eso H_ff)). use nat_trans_eq. { apply homset_property. } intro ; apply idpath. Qed. Definition H_pru : (functor_ru_disp_cat ru ruD) (H ,, (pr1 (TransportedTensorComm Duniv H_eso H_ff TC) ,, identity _)). Proof. intro c. set (t := toforallpaths _ _ _ (base_paths _ _ TransportedRightUnitorEq) c). refine (t @ _). clear t. etrans. 2: { do 2 apply maponpaths_2. exact (! functor_id TD (H c , H I)). } rewrite id_left. simpl. rewrite ! id_left. rewrite functor_id. rewrite ! id_right. rewrite (functor_id (lift_functor_along (D,, Duniv) HH HH_eso HH_ff (TC ∙ H))). rewrite id_left. apply idpath. Qed. Lemma TransportedRightUnitorOnOb (c : C) : TransportedRightUnitor (H c) = (LiftPreservesPostTensor c) · #H (ru c). Proof. exact (toforallpaths _ _ _ (base_paths _ _ TransportedRightUnitorEq) c). Qed. Context {E : category} (Euniv : is_univalent E) (TE : functor (E ⊠ E) E) (IE : E) (ruE : right_unitor TE IE). Definition precompRU : disp_functor (precomp_tensorunit_functor Duniv H_eso H_ff TC I TE IE) (functor_ru_disp_cat ruD ruE) (functor_ru_disp_cat ru ruE). Proof. use tpair. - use tpair. 2: intro ; intros ; exact tt. exact (λ G GG, functor_ru_composition H_pru GG). - split ; intro ; intros ; apply isapropunit. Qed. Lemma precompRU_ff : disp_functor_ff precompRU. Proof. intro ; intros. apply isweqinclandsurj. - do 3 intro. assert (p : isaset ( hfiber (λ ff : unit, ♯ precompRU ff) y0)). { use isaset_hfiber ; use isasetaprop ; apply isapropunit. } use tpair. + use total2_paths_f. { apply isapropunit. } use proofirrelevance. use hlevelntosn. apply isapropunit. + intro ; apply p. - intro ; intros. apply hinhpr. exists tt. apply isapropunit. Qed. Lemma precompRU_eso : disp_functor_disp_ess_split_surj precompRU. Proof. intros G GG. use tpair. - intro d. use factor_through_squash. { exact (∑ a : C, z_iso (H a) d). } { apply homset_property. } 2: exact (H_eso d). intro cd. induction (isotoid _ Duniv (pr2 cd)). refine (GG (pr1 cd) @ _). simpl. rewrite (functor_id (pr1 G)). rewrite id_right. do 3 rewrite assoc'. do 2 apply maponpaths. rewrite <- (functor_comp (pr1 G)). apply maponpaths. simpl. refine (_ @ ! TransportedRightUnitorOnOb (pr1 cd)). apply maponpaths_2. unfold LiftPreservesPostTensor. simpl. rewrite ! id_left. rewrite ! id_right. rewrite (functor_id H). rewrite id_right. etrans. 2: { apply maponpaths_2. apply (! functor_id _ _). } apply (! id_left _). - exists tt. exists tt. split ; apply isapropunit. Qed. Definition precomp_runitor_is_ff : fully_faithful (total_functor precompRU). Proof. use disp_functor_ff_to_total_ff. - apply (precomp_tensorunit_is_ff Duniv Euniv). - exact precompRU_ff. Qed. Definition precomp_runitor_is_eso : essentially_surjective (total_functor precompRU). Proof. use disp_functor_eso_to_total_eso. - apply (precomp_tensorunit_is_eso Duniv Euniv). - exact precompRU_eso. - use Fibrations.iso_cleaving_category. apply is_univalent_total_category. + apply is_univalent_functor_category. exact Euniv. + apply functor_tensorunit_disp_cat_is_univalent. Qed. Definition precomp_runitor_adj_equiv : adj_equivalence_of_cats (total_functor precompRU). Proof. apply rad_equivalence_of_cats. - apply is_univalent_total_category. + apply is_univalent_total_category. * apply (is_univalent_functor_category _ _ Euniv). * apply is_disp_univalent_functor_tensorunit_disp_cat. + apply functor_ru_disp_cat_is_univalent. - exact precomp_runitor_is_ff. - exact precomp_runitor_is_eso. Defined. Definition precomp_runitor_catiso : catiso (total_category (functor_ru_disp_cat TransportedRightUnitor ruE)) (total_category (functor_ru_disp_cat ru ruE)). Proof. use (adj_equivalence_of_cats_to_cat_iso precomp_runitor_adj_equiv _ _). - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_ru_disp_cat_is_univalent. - apply is_univalent_total_category. + apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensorunit_disp_cat_is_univalent _ _ _ _)). + apply functor_ru_disp_cat_is_univalent. Defined. End RezkRightUnitor. UniMath-20231010/UniMath/CategoryTheory/Monoidal/RezkCompletion/MonoidalRezkCompletion.v000066400000000000000000000105071451125700300311550ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.RezkCompletion.LiftedMonoidal. Require Import UniMath.CategoryTheory.rezk_completion. Local Open Scope cat. Section MonoidalRezkCompletion. Context (M : monoidal_cat) {D : univalent_category} {H : functor M D} (H_eso : essentially_surjective H) (H_ff : fully_faithful H). Definition RezkCompletion_monoidal_cat : monoidal_cat := TransportedMonoidal (univalent_category_is_univalent D) H_eso H_ff _ _ _ _ _ (monoidal_cat_triangle_eq M) (monoidal_cat_pentagon_eq M). Definition RezkCompletion_monoidal_functor : functor_monoidal_cat (monoidal_cat_left_unitor M) (monoidal_cat_left_unitor RezkCompletion_monoidal_cat) (monoidal_cat_right_unitor M) (monoidal_cat_right_unitor RezkCompletion_monoidal_cat) (monoidal_cat_associator M) (monoidal_cat_associator RezkCompletion_monoidal_cat) := H_monoidal (univalent_category_is_univalent D) H_eso H_ff _ _ (monoidal_cat_left_unitor M) (monoidal_cat_right_unitor M) (monoidal_cat_associator M). Definition RezkCompletion_monoidal_universalproperty : ∏ (E : monoidal_cat) (Euniv : is_univalent E), adj_equivalence_of_cats (total_functor (precompMonoidal (univalent_category_is_univalent D) H_eso H_ff _ _ (monoidal_cat_left_unitor M) (monoidal_cat_right_unitor M) (monoidal_cat_associator M) _ _ (monoidal_cat_left_unitor E) (monoidal_cat_right_unitor E) (monoidal_cat_associator E))) := λ E Euniv, precomp_monoidal_adj_equiv (univalent_category_is_univalent D) H_eso H_ff _ _ (monoidal_cat_left_unitor M) (monoidal_cat_right_unitor M) (monoidal_cat_associator M) Euniv _ _ (monoidal_cat_left_unitor E) (monoidal_cat_right_unitor E) (monoidal_cat_associator E). End MonoidalRezkCompletion. Section MonoidalRezkCompletionUsingRepresentableCopresheaves. Context {M : monoidal_cat}. Definition Copresheaf_RezkCompletion_monoidal_cat : monoidal_cat := RezkCompletion_monoidal_cat M (Rezk_eta_essentially_surjective M) (Rezk_eta_fully_faithful M). Definition Copresheaf_RezkCompletion_monoidal_functor : functor_monoidal_cat (monoidal_cat_left_unitor M) (monoidal_cat_left_unitor Copresheaf_RezkCompletion_monoidal_cat) (monoidal_cat_right_unitor M) (monoidal_cat_right_unitor Copresheaf_RezkCompletion_monoidal_cat) (monoidal_cat_associator M) (monoidal_cat_associator Copresheaf_RezkCompletion_monoidal_cat) := RezkCompletion_monoidal_functor M (Rezk_eta_essentially_surjective M) (Rezk_eta_fully_faithful M). Definition Copresheaf_RezkCompletion_monoidal_universalproperty : ∏ (E : monoidal_cat) (Euniv : is_univalent E), adj_equivalence_of_cats (total_functor (precompMonoidal (univalent_category_is_univalent (Rezk_completion M)) (Rezk_eta_essentially_surjective M) (Rezk_eta_fully_faithful M) _ _ (monoidal_cat_left_unitor M) (monoidal_cat_right_unitor M) (monoidal_cat_associator M) _ _ (monoidal_cat_left_unitor E) (monoidal_cat_right_unitor E) (monoidal_cat_associator E))) := λ E Euniv, RezkCompletion_monoidal_universalproperty M (Rezk_eta_essentially_surjective M) (Rezk_eta_fully_faithful M) E Euniv. End MonoidalRezkCompletionUsingRepresentableCopresheaves. UniMath-20231010/UniMath/CategoryTheory/Monoidal/StrongMonad.v000066400000000000000000000103471451125700300240150ustar00rootroot00000000000000(******************************************************************** Strong monads In this file, we define the notion of strong monad on a monoidal category. ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section LeftStrength. Context {V : monoidal_cat}. Definition left_strength_data (F : V ⟶ V) : UU := ∏ (x y : V), x ⊗ F y --> F(x ⊗ y). Definition left_strength_laws {F : V ⟶ V} (tF : left_strength_data F) : UU := (∏ (x₁ x₂ y₁ y₂ : V) (f : x₁ --> x₂) (g : y₁ --> y₂), f #⊗ #F g· tF x₂ y₂ = tF x₁ y₁ · #F(f #⊗ g)) × (∏ (x : V), tF I_{V} x · #F(mon_lunitor x) = mon_lunitor (F x)) × (∏ (x y z : V), tF (x ⊗ y) z · #F(mon_lassociator x y z) = mon_lassociator x y (F z) · identity x #⊗ tF y z · tF x (y ⊗ z)). Proposition isaprop_left_strength_laws {F : V ⟶ V} (tF : left_strength_data F) : isaprop (left_strength_laws tF). Proof. repeat (use isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property. Qed. Definition left_strength (F : V ⟶ V) : UU := ∑ (tF : left_strength_data F), left_strength_laws tF. Definition left_strength_to_data {F : V ⟶ V} (tF : left_strength F) (x y : V) : x ⊗ F y --> F(x ⊗ y) := pr1 tF x y. Coercion left_strength_to_data : left_strength >-> Funclass. Section LeftStrengthLaws. Context {F : V ⟶ V} (tF : left_strength F). Proposition left_strength_natural {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ #F g· tF x₂ y₂ = tF x₁ y₁ · #F(f #⊗ g). Proof. exact (pr12 tF x₁ x₂ y₁ y₂ f g). Qed. Proposition left_strength_mon_lunitor (x : V) : tF I_{V} x · #F(mon_lunitor x) = mon_lunitor (F x). Proof. exact (pr122 tF x). Qed. Proposition left_strength_mon_lassociator (x y z : V) : tF (x ⊗ y) z · #F(mon_lassociator x y z) = mon_lassociator x y (F z) · identity x #⊗ tF y z · tF x (y ⊗ z). Proof. exact (pr222 tF x y z). Qed. End LeftStrengthLaws. Definition left_strong_monad_laws {M : Monad V} (tM : left_strength M) : UU := (∏ (x y : V), identity x #⊗ η M y · tM x y = η M (x ⊗ y)) × (∏ (x y : V), identity x #⊗ μ M y · tM x y = tM x (M y) · #M (tM x y) · μ M (x ⊗ y)). Proposition isaprop_left_strong_monad_laws {M : Monad V} (tM : left_strength M) : isaprop (left_strong_monad_laws tM). Proof. use isapropdirprod ; repeat (use impred ; intro) ; apply homset_property. Qed. Definition left_strong_monad (M : Monad V) : UU := ∑ (tM : left_strength M), left_strong_monad_laws tM. Coercion left_strong_monad_strength {M : Monad V} (tM : left_strong_monad M) : left_strength M := pr1 tM. Section LeftStrongMonadLaws. Context {M : Monad V} (tM : left_strong_monad M). Proposition left_strong_monad_unit (x y : V) : identity x #⊗ η M y · tM x y = η M (x ⊗ y). Proof. exact (pr12 tM x y). Qed. Proposition left_strong_monad_mu (x y : V) : identity x #⊗ μ M y · tM x y = tM x (M y) · #M (tM x y) · μ M (x ⊗ y). Proof. exact (pr22 tM x y). Qed. End LeftStrongMonadLaws. End LeftStrength. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Structure/000077500000000000000000000000001451125700300233665ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Monoidal/Structure/Cartesian.v000066400000000000000000000326751451125700300255030ustar00rootroot00000000000000(********************************************************************************* Cartesian and cocartesian monoidal categories In this file, we discuss several variations of cartesian monoidal categories. We also prove some properties about them. Contents 1. Cartesan monoidal categories 2. Cartesian monoidal categories are symmetric 3. Cocartesian monoidal categories *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Import BifunctorNotations. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Cartesan monoidal categories *) Definition is_semicartesian {C : category} (M : monoidal C) : UU := isTerminal C (I_{M}). Section ProjectionsSemiCartesian. Context {M : monoidal_cat} (HM : is_semicartesian M). Definition semi_cart_to_unit (x : M) : x --> I_{M} := TerminalArrow (I_{M} ,, HM) x. Proposition semi_cart_to_unit_eq {x : M} (f g : x --> I_{M}) : f = g. Proof. exact (@TerminalArrowEq _ (I_{M} ,, HM) x f g). Qed. Definition semi_cart_tensor_pr1 (x y : M) : x ⊗ y --> x := identity _ #⊗ semi_cart_to_unit y · mon_runitor x. Definition semi_cart_tensor_pr2 (x y : M) : x ⊗ y --> y := semi_cart_to_unit x #⊗ identity _ · mon_lunitor y. End ProjectionsSemiCartesian. Definition tensor_isBinProduct {M : monoidal_cat} (HM : is_semicartesian M) : UU := ∏ (x y : M), isBinProduct _ _ _ _ (semi_cart_tensor_pr1 HM x y) (semi_cart_tensor_pr2 HM x y). Definition is_cartesian (M : monoidal_cat) : UU := ∑ (HM : is_semicartesian M), tensor_isBinProduct HM. Coercion is_cartesian_to_semicartesian {M : monoidal_cat} (M_cart : is_cartesian M) : is_semicartesian M := pr1 M_cart. Definition is_cartesian_BinProduct {M : monoidal_cat} (M_cart : is_cartesian M) (x y : M) : BinProduct M x y := make_BinProduct _ _ _ _ _ _ (pr2 M_cart x y). (** 2. Cartesian monoidal categories are symmetric *) Section CartesianSymmetric. Context {M : monoidal_cat} (M_cart : is_cartesian M). Definition cartesian_to_braiding_data : braiding_data M. Proof. intros x y. use (BinProductArrow _ (is_cartesian_BinProduct M_cart y x)). - apply (semi_cart_tensor_pr2 M_cart). - apply (semi_cart_tensor_pr1 M_cart). Defined. Proposition cartesian_to_braiding_data_pr1 (x y : M) : cartesian_to_braiding_data x y · semi_cart_tensor_pr1 (pr1 M_cart) y x = semi_cart_tensor_pr2 M_cart x y. Proof. apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct M_cart y x)). Qed. Proposition cartesian_to_braiding_data_pr2 (x y : M) : cartesian_to_braiding_data x y · semi_cart_tensor_pr2 (pr1 M_cart) y x = semi_cart_tensor_pr1 M_cart x y. Proof. apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct M_cart y x)). Qed. Proposition cartesian_tensor_pr1 {x₁ x₂ y₁ y₂ : M} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g · semi_cart_tensor_pr1 M_cart x₂ y₂ = semi_cart_tensor_pr1 M_cart x₁ y₁ · f. Proof. unfold semi_cart_tensor_pr1. rewrite !assoc'. rewrite <- tensor_runitor. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite !id_left, !id_right. apply maponpaths. apply (semi_cart_to_unit_eq M_cart). Qed. Proposition cartesian_tensor_pr2 {x₁ x₂ y₁ y₂ : M} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g · semi_cart_tensor_pr2 M_cart x₂ y₂ = semi_cart_tensor_pr2 M_cart x₁ y₁ · g. Proof. unfold semi_cart_tensor_pr2. rewrite !assoc'. rewrite <- tensor_lunitor. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite !id_left, !id_right. apply maponpaths_2. apply (semi_cart_to_unit_eq M_cart). Qed. Proposition cartesian_tensor_mor {x₁ x₂ y₁ y₂ : M} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g = BinProductOfArrows _ (is_cartesian_BinProduct M_cart x₂ y₂) (is_cartesian_BinProduct M_cart x₁ y₁) f g. Proof. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)). - refine (!_). etrans. { apply (BinProductOfArrowsPr1 _ (is_cartesian_BinProduct M_cart x₂ y₂) (is_cartesian_BinProduct M_cart x₁ y₁)). } cbn. rewrite cartesian_tensor_pr1. apply idpath. - refine (!_). etrans. { apply (BinProductOfArrowsPr2 _ (is_cartesian_BinProduct M_cart x₂ y₂) (is_cartesian_BinProduct M_cart x₁ y₁)). } cbn. rewrite cartesian_tensor_pr2. apply idpath. Qed. Proposition mon_lunitor_pr1 (x y : M) : mon_lunitor (x ⊗ y) · semi_cart_tensor_pr1 M_cart _ _ = identity _ #⊗ semi_cart_tensor_pr1 M_cart _ _ · mon_lunitor x. Proof. rewrite tensor_lunitor. apply idpath. Qed. Proposition mon_lunitor_pr2 (x y : M) : mon_lunitor (x ⊗ y) · semi_cart_tensor_pr2 M_cart _ _ = identity _ #⊗ semi_cart_tensor_pr2 M_cart _ _ · mon_lunitor y. Proof. rewrite tensor_lunitor. apply idpath. Qed. Proposition mon_runitor_pr1 (x y : M) : mon_runitor (x ⊗ y) · semi_cart_tensor_pr1 M_cart _ _ = semi_cart_tensor_pr1 M_cart _ _ #⊗ identity _ · mon_runitor x. Proof. rewrite tensor_runitor. apply idpath. Qed. Proposition mon_runitor_pr2 (x y : M) : mon_runitor (x ⊗ y) · semi_cart_tensor_pr2 M_cart _ _ = semi_cart_tensor_pr2 M_cart _ _ #⊗ identity _ · mon_runitor y. Proof. rewrite tensor_runitor. apply idpath. Qed. Proposition mon_lassociator_pr1 (x y z : M) : mon_lassociator x y z · semi_cart_tensor_pr1 M_cart _ _ = semi_cart_tensor_pr1 M_cart _ _ · semi_cart_tensor_pr1 M_cart _ _. Proof. unfold semi_cart_tensor_pr1. rewrite !assoc. apply maponpaths_2. refine (_ @ id_left _). rewrite <- mon_lassociator_rassociator. rewrite !assoc'. apply maponpaths. refine (!_). rewrite !assoc. rewrite <- tensor_id_id. rewrite <- tensor_rassociator. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_runitor_triangle. apply idpath. } rewrite <- !tensor_comp_id_l. apply maponpaths. apply (semi_cart_to_unit_eq M_cart). Qed. Proposition mon_lassociator_pr2 (x y z : M) : mon_lassociator x y z · semi_cart_tensor_pr2 M_cart x (y ⊗ z) = semi_cart_tensor_pr2 M_cart x y #⊗ identity _. Proof. unfold semi_cart_tensor_pr2. rewrite <- tensor_id_id. rewrite !assoc. rewrite <- tensor_lassociator. rewrite !assoc'. rewrite mon_lunitor_triangle. rewrite !tensor_comp_id_r. apply idpath. Qed. Proposition cartesian_to_symmetric_laws : sym_mon_cat_laws_tensored M cartesian_to_braiding_data. Proof. repeat split. - intros x y. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart x y)). + rewrite !assoc' ; cbn. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr1. } rewrite id_left. apply cartesian_to_braiding_data_pr2. + rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr2. } rewrite id_left. apply cartesian_to_braiding_data_pr1. - intros x₁ x₂ y₁ y₂ f g. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)). + rewrite !assoc' ; cbn. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr1. } rewrite cartesian_tensor_pr2. rewrite cartesian_tensor_pr1. rewrite !assoc. apply maponpaths_2. refine (!_). apply cartesian_to_braiding_data_pr1. + rewrite !assoc' ; cbn. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr2. } rewrite cartesian_tensor_pr2. rewrite cartesian_tensor_pr1. rewrite !assoc. apply maponpaths_2. refine (!_). apply cartesian_to_braiding_data_pr2. - intros x y z. use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)) ; cbn. + rewrite !assoc'. rewrite cartesian_tensor_pr1. rewrite id_right. rewrite !mon_lassociator_pr1. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_to_braiding_data_pr1. } refine (!_). rewrite !assoc. rewrite cartesian_tensor_pr1. rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr1. } rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr1. apply idpath. + rewrite !assoc'. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr2. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite mon_lassociator_pr2. rewrite !assoc. rewrite <- tensor_comp_id_r. refine (!_). etrans. { do 2 apply maponpaths_2. apply cartesian_to_braiding_data_pr2. } use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)) ; cbn. * rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr1. } rewrite cartesian_tensor_pr2. rewrite id_right. rewrite cartesian_tensor_pr1. refine (!_). etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply cartesian_to_braiding_data_pr1. } rewrite !assoc. rewrite mon_lassociator_pr2. rewrite cartesian_tensor_pr2. rewrite id_right. apply idpath. * rewrite !assoc'. etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr2. } rewrite cartesian_tensor_pr2. rewrite id_right. rewrite cartesian_tensor_pr1. refine (!_). etrans. { apply maponpaths. apply cartesian_to_braiding_data_pr2. } rewrite mon_lassociator_pr1. apply idpath. Qed. Definition cartesian_to_symmetric : symmetric M. Proof. use make_symmetric. - exact cartesian_to_braiding_data. - exact cartesian_to_symmetric_laws. Defined. End CartesianSymmetric. (** 3. Cocartesian monoidal categories *) Definition is_semicocartesian {C : category} (M : monoidal C) : UU := isInitial C (I_{M}). Section ProjectionsSemiCocartesian. Context {M : monoidal_cat} (HM : is_semicocartesian M). Definition semi_cocart_to_unit (x : M) : I_{M} --> x := InitialArrow (I_{M} ,, HM) x. Proposition semi_cocart_from_unit_eq {x : M} (f g : I_{M} --> x) : f = g. Proof. exact (@InitialArrowEq _ (I_{M} ,, HM) x f g). Qed. Definition semi_cocart_tensor_inl (x y : M) : x --> x ⊗ y := mon_rinvunitor x · identity _ #⊗ semi_cocart_to_unit y. Definition semi_cocart_tensor_inr (x y : M) : y --> x ⊗ y := mon_linvunitor y · semi_cocart_to_unit x #⊗ identity _. End ProjectionsSemiCocartesian. Definition tensor_isBinCoproduct {M : monoidal_cat} (HM : is_semicocartesian M) : UU := ∏ (x y : M), isBinCoproduct _ _ _ _ (semi_cocart_tensor_inl HM x y) (semi_cocart_tensor_inr HM x y). Definition is_cocartesian (M : monoidal_cat) : UU := ∑ (HM : is_semicocartesian M), tensor_isBinCoproduct HM. Coercion is_cocartesian_to_semicocartesian {M : monoidal_cat} (M_cocart : is_cocartesian M) : is_semicocartesian M := pr1 M_cocart. Definition is_cartesian_BinCoproduct {M : monoidal_cat} (M_cocart : is_cocartesian M) (x y : M) : BinCoproduct x y := make_BinCoproduct _ _ _ _ _ _ (pr2 M_cocart x y). UniMath-20231010/UniMath/CategoryTheory/Monoidal/Structure/Closed.v000066400000000000000000000714731451125700300250020ustar00rootroot00000000000000(********************************************************************************* Closed monoidal categories A closed monoidal category is one for which tensoring with a fixed object has a right adjoint. Depending on whether the monoidal category is symmetric or not, there are different variations of this definition. If the monoidal category is not symmetric, then there are two variations, namely left closed and right closed, and their difference is whether we look at an adjoint for tensoring with an object on the left or on the right. For symmetric monoidal categories, these two definitions coincide. We also define accessors and a builder for symmetric monoidal categories. They are based on having lambda abstraction and application with the usual beta and eta laws. In addition, we define some standard functions and we prove some laws about them. Contents 1. Basic definitions 2. Accessors for symmetric monoidal categories 3. Standard functions *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. (** 1. Basic definitions *) Section ClosedMonoidalCategories. (** the choice of "left closed" for this definition follows the convention at https://ncatlab.org/nlab/show/closed+monoidal+category, but it is called "right closed" at https://en.wikipedia.org/wiki/Closed_monoidal_category *) Definition monoidal_leftclosed {C : category} (M : monoidal C) : UU := ∏ X : C, ∑ homX : functor C C, are_adjoints (rightwhiskering_functor M X) homX. Definition monoidal_leftclosed_exp {C : category} {M : monoidal C} (LC : monoidal_leftclosed M) : C -> functor C C := λ X, pr1 (LC X). Definition monoidal_rightclosed {C : category} (M : monoidal C) : UU := ∏ X : C, ∑ homX : functor C C, are_adjoints (leftwhiskering_functor M X) homX. Definition monoidal_biclosed {C : category} (M : monoidal C) : UU := monoidal_leftclosed M × monoidal_rightclosed M. Lemma adj_closed_under_nat_z_iso {C D : category} {F1 F2 : functor C D} (α : nat_z_iso F1 F2) (G : functor D C) : are_adjoints F2 G -> are_adjoints F1 G. Proof. intro adj. simple refine (are_adjoints_closed_under_iso F2 F1 G _ adj). apply z_iso_inv. apply z_iso_is_nat_z_iso. assumption. Defined. Lemma leftclosed_symmetric_is_rightclosed {C : category} (M : monoidal C) : symmetric M -> monoidal_leftclosed M -> monoidal_rightclosed M. Proof. intros B LC. intro x. exists (monoidal_leftclosed_exp LC x). apply (adj_closed_under_nat_z_iso (F2 := rightwhiskering_functor M x)). - apply symmetric_whiskers_swap_nat_z_iso. exact B. - exact (pr2 (LC x)). Defined. Lemma leftclosed_symmetric_is_biclosed {C : category} (M : monoidal C) : symmetric M -> monoidal_leftclosed M -> monoidal_biclosed M. Proof. exact (λ S LC, LC ,, leftclosed_symmetric_is_rightclosed M S LC). Defined. End ClosedMonoidalCategories. (** 2. Accessors for symmetric monoidal categories *) Definition sym_mon_closed_cat : UU := ∑ (V : sym_monoidal_cat), monoidal_leftclosed V. Coercion sym_monoidal_closed_cat_to_sym_monoidal_cat (V : sym_mon_closed_cat) : sym_monoidal_cat := pr1 V. Section Builder. Context (V : sym_monoidal_cat) (HomV : V → V → V) (eval : ∏ (x y : V), HomV x y ⊗ x --> y) (lam : ∏ (x y z : V) (f : z ⊗ x --> y), z --> HomV x y) (betaEq : ∏ (x y z : V) (f : z ⊗ x --> y), lam x y z f #⊗ identity x · eval x y = f) (etaEq : ∏ (x y z : V) (g : z --> HomV x y), g = lam x y z (g #⊗ identity _ · eval x y)). Definition make_left_closed_universal (x y : V) : is_universal_arrow_from (rightwhiskering_functor V x) y (HomV x y) (eval x y). Proof. intros z f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; refine (etaEq _ _ _ _ @ _ @ !(etaEq _ _ _ _)) ; apply maponpaths ; refine (_ @ !(pr2 φ₁) @ pr2 φ₂ @ !_) ; apply maponpaths_2 ; refine (_ @ id_right _) ; unfold rightwhiskering_on_morphisms ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; apply maponpaths ; apply (bifunctor_leftid V)). - simple refine (_ ,, _). + exact (lam x y z f). + abstract (refine (!(betaEq x y z f) @ _) ; cbn ; apply maponpaths_2 ; refine (_ @ id_right _) ; unfold rightwhiskering_on_morphisms ; unfold monoidal_cat_tensor_mor ; unfold functoronmorphisms1 ; apply maponpaths ; apply (bifunctor_leftid V)). Defined. Definition make_monoidal_leftclosed : monoidal_leftclosed V. Proof. intros x. pose (right_adjoint_from_partial (rightwhiskering_functor V x) (HomV x) (eval x) (make_left_closed_universal x)) as A. exists (Core.G _ _ _ (make_left_closed_universal x)). exact (pr2 A). Defined. Definition make_sym_mon_closed_cat : sym_mon_closed_cat := V ,, make_monoidal_leftclosed. End Builder. Definition internal_hom {V : sym_mon_closed_cat} (x y : V) : V := pr1 (pr2 V x) y. Notation "x ⊸ y" := (internal_hom x y) (at level 45, right associativity) : moncat. (* \-o or \r-o *) Section Accessors. Context {V : sym_mon_closed_cat}. Definition internal_eval (x y : V) : (x ⊸ y) ⊗ x --> y := counit_from_are_adjoints (pr2 (pr2 V x)) y. Definition internal_lam {x y z : V} (f : x ⊗ y --> z) : x --> y ⊸ z := unit_from_are_adjoints (pr2 (pr2 V y)) x · #(pr1 (pr2 V y)) f. Proposition internal_beta {x y z : V} (f : z ⊗ x --> y) : internal_lam f #⊗ identity x · internal_eval x y = f. Proof. unfold internal_lam. rewrite tensor_comp_r_id_l. rewrite !assoc'. unfold internal_eval. etrans. { apply maponpaths. pose (nat_trans_ax (counit_from_are_adjoints (pr2 (pr2 V x))) _ _ f) as p. refine (_ @ p). apply maponpaths_2. cbn. unfold rightwhiskering_on_morphisms. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). } cbn. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. refine (_ @ triangle_id_left_ad (pr2 (pr2 V x)) _). apply maponpaths_2. cbn. unfold rightwhiskering_on_morphisms. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). Qed. Proposition internal_eta {x y z : V} (f : z --> x ⊸ y) : f = internal_lam (f #⊗ identity _ · internal_eval x y). Proof. unfold internal_lam. unfold internal_eval. refine (!_). rewrite functor_comp. rewrite !assoc. etrans. { apply maponpaths_2. pose (nat_trans_ax (unit_from_are_adjoints (pr2 (pr2 V x))) _ _ f) as p. cbn in p. refine (_ @ !p). do 2 apply maponpaths. unfold rightwhiskering_on_morphisms. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. refine (_ @ id_right _). apply maponpaths. apply (bifunctor_leftid V). } refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. exact (triangle_id_right_ad (pr2 (pr2 V x)) _). Qed. End Accessors. Definition sym_mon_closed_left_tensor_left_adjoint_universal (V : sym_mon_closed_cat) (x y : V) : is_universal_arrow_from (monoidal_left_tensor x) y (x ⊸ y) (sym_mon_braiding V x (x ⊸ y) · internal_eval x y). Proof. intros z f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; refine (internal_eta _ @ _ @ !(internal_eta _)) ; apply maponpaths ; refine (!(id_left _) @ _ @ id_left _) ; rewrite <- !sym_mon_braiding_inv ; rewrite !assoc' ; apply maponpaths ; rewrite !assoc ; rewrite <- !tensor_sym_mon_braiding ; rewrite !assoc' ; exact (!(pr2 φ₁) @ pr2 φ₂)). - refine (internal_lam (sym_mon_braiding V z x · f) ,, _). abstract (cbn -[sym_mon_braiding] ; rewrite !assoc ; rewrite tensor_sym_mon_braiding ; rewrite !assoc' ; rewrite internal_beta ; rewrite !assoc ; rewrite sym_mon_braiding_inv ; rewrite id_left ; apply idpath). Defined. Definition sym_mon_closed_left_tensor_left_adjoint (V : sym_mon_closed_cat) (x : V) : is_left_adjoint (monoidal_left_tensor x). Proof. use left_adjoint_from_partial. - exact (λ y, x ⊸ y). - exact (λ y, sym_mon_braiding V _ _ · internal_eval _ _). - exact (sym_mon_closed_left_tensor_left_adjoint_universal V x). Defined. Definition sym_mon_closed_left_tensor_right_adjoint_universal (V : sym_mon_closed_cat) (x y : V) : is_universal_arrow_from (monoidal_right_tensor x) y (x ⊸ y) (internal_eval x y). Proof. intros z f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; refine (internal_eta _ @ _ @ !(internal_eta _)) ; apply maponpaths ; exact (!(pr2 φ₁) @ pr2 φ₂)). - refine (internal_lam f ,, _). abstract (cbn ; rewrite internal_beta ; apply idpath). Defined. Definition sym_mon_closed_right_tensor_left_adjoint (V : sym_mon_closed_cat) (x : V) : is_left_adjoint (monoidal_right_tensor x). Proof. use left_adjoint_from_partial. - exact (λ y, x ⊸ y). - exact (λ y, internal_eval _ _). - exact (sym_mon_closed_left_tensor_right_adjoint_universal V x). Defined. (** 3. Standard functions *) Section StandardFunctions. Context {V : sym_mon_closed_cat}. Definition internal_id (x : V) : I_{V} --> x ⊸ x := internal_lam (mon_lunitor _). Definition internal_comp (x y z : V) : (y ⊸ z) ⊗ (x ⊸ y) --> x ⊸ z := internal_lam (mon_lassociator _ _ _ · identity _ #⊗ internal_eval x y · internal_eval y z). Definition internal_from_arr {x y : V} (f : x --> y) : I_{V} --> x ⊸ y := internal_lam (mon_lunitor x · f). Definition internal_to_arr {x y : V} (f : I_{V} --> x ⊸ y) : x --> y := mon_linvunitor x · f #⊗ identity x · internal_eval x y. Definition internal_pair (x y : V) : x --> y ⊸ x ⊗ y := internal_lam (identity _). Definition internal_swap_arg (v₁ v₂ w : V) : v₁ ⊸ w ⊸ v₂ --> w ⊸ v₁ ⊸ v₂ := internal_lam (internal_lam (mon_lassociator _ _ _ · identity _ #⊗ sym_mon_braiding _ _ _ · mon_rassociator _ _ _ · internal_eval _ _ #⊗ identity _ · internal_eval _ _)). Definition internal_curry (v₁ v₂ v₃ : V) : v₁ ⊗ v₂ ⊸ v₃ --> v₁ ⊸ v₂ ⊸ v₃ := internal_lam (internal_lam (mon_lassociator _ _ _ · internal_eval _ _)). Definition internal_uncurry (v₁ v₂ v₃ : V) : v₁ ⊸ v₂ ⊸ v₃ --> v₁ ⊗ v₂ ⊸ v₃ := internal_lam (mon_rassociator _ _ _ · internal_eval _ _ #⊗ identity _ · internal_eval _ _). Definition internal_precomp {x₁ x₂ : V} (f : x₁ --> x₂) (y : V) : x₂ ⊸ y --> x₁ ⊸ y := internal_lam (identity _ #⊗ f · internal_eval _ _). Definition internal_postcomp (x : V) {y₁ y₂ : V} (g : y₁ --> y₂) : x ⊸ y₁ --> x ⊸ y₂ := internal_lam (internal_eval _ _ · g). Definition internal_pre_post_comp {x₁ x₂ : V} (f : x₁ --> x₂) {y₁ y₂ : V} (g : y₁ --> y₂) : x₂ ⊸ y₁ --> x₁ ⊸ y₂ := internal_lam (identity _ #⊗ f · internal_eval _ _ · g). Proposition internal_funext (w x y : V) (f g : w --> x ⊸ y) (p : ∏ (a : V) (h : a --> x), f #⊗ h · internal_eval x y = g #⊗ h · internal_eval x y) : f = g. Proof. refine (internal_eta f @ _ @ !(internal_eta g)). apply maponpaths. exact (p x (identity x)). Qed. Proposition internal_id_left (x y : V) : mon_lunitor _ = internal_id y #⊗ identity _ · internal_comp x y y. Proof. use internal_funext. intros w h. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite tensor_split. rewrite !assoc'. apply maponpaths. unfold internal_id. apply internal_beta. } rewrite tensor_lunitor. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lunitor. rewrite !assoc. rewrite mon_lunitor_triangle. rewrite <- tensor_split'. apply idpath. Qed. Proposition internal_id_right (x y : V) : mon_runitor _ = identity _ #⊗ internal_id x · internal_comp x x y. Proof. use internal_funext. intros w h. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. apply maponpaths_2. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite <- tensor_comp_mor. rewrite id_right. apply maponpaths. rewrite tensor_split. rewrite !assoc'. apply maponpaths. unfold internal_id. apply internal_beta. } rewrite tensor_lunitor. rewrite tensor_comp_id_l. rewrite !assoc. rewrite <- mon_triangle. rewrite <- tensor_split'. apply idpath. Qed. Proposition internal_assoc (w x y z : V) : (internal_comp x y z #⊗ identity _) · internal_comp w x z = mon_lassociator _ _ _ · (identity _ #⊗ internal_comp w x y) · internal_comp w y z. Proof. use internal_funext. intros a h. etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. apply internal_beta. } etrans. { rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. apply maponpaths. apply internal_beta. } refine (!_). etrans. { rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. apply internal_beta. } rewrite !assoc. apply maponpaths_2. etrans. { rewrite !assoc'. rewrite tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. rewrite <- tensor_comp_id_l. do 2 apply maponpaths. apply internal_beta. } rewrite !tensor_comp_id_l. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !tensor_comp_id_l. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite mon_lassociator_lassociator. rewrite !assoc'. rewrite <- tensor_comp_id_l. rewrite <- tensor_lassociator. rewrite tensor_comp_id_l. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_comp_mor. rewrite id_left. rewrite !tensor_id_id. rewrite id_right. apply idpath. Qed. Proposition internal_from_to_arr {x y : V} (f : I_{V} --> x ⊸ y) : internal_from_arr (internal_to_arr f) = f. Proof. unfold internal_from_arr, internal_to_arr. rewrite !assoc. rewrite mon_lunitor_linvunitor. rewrite id_left. exact (!(internal_eta f)). Qed. Proposition internal_to_from_arr {x y : V} (f : x --> y) : internal_to_arr (internal_from_arr f) = f. Proof. unfold internal_from_arr, internal_to_arr. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite mon_linvunitor_lunitor. apply id_left. Qed. Proposition internal_to_arr_id (x : V) : internal_to_arr (internal_id x) = identity x. Proof. unfold internal_to_arr. rewrite !assoc'. unfold internal_id. rewrite internal_beta. apply mon_linvunitor_lunitor. Qed. Proposition internal_to_arr_comp {x y z : V} (f : x --> y) (g : y --> z) : f · g = internal_to_arr (mon_linvunitor I_{V} · internal_from_arr g #⊗ internal_from_arr f · internal_comp x y z). Proof. unfold internal_to_arr. rewrite tensor_comp_id_r. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. rewrite tensor_comp_id_r. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. unfold internal_from_arr. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lunitor. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_triangle. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite mon_linvunitor_lunitor. rewrite tensor_id_id. apply id_left. } apply mon_linvunitor_lunitor. Qed. Proposition internal_eval_natural (x : V) {y₁ y₂ : V} (f : y₁ --> y₂) : internal_eval x y₁ · f = internal_lam (internal_eval _ _ · f) #⊗ identity x · internal_eval x y₂. Proof. rewrite internal_beta. apply idpath. Qed. Proposition internal_pair_natural {x₁ x₂ : V} (y : V) (f : x₁ --> x₂) : f · internal_pair x₂ y = internal_pair x₁ y · internal_lam (internal_eval _ _ · f #⊗ identity _). Proof. use internal_funext. intros w h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_pair. rewrite !internal_beta. rewrite !assoc. rewrite id_right. refine (!_). etrans. { apply maponpaths_2. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply id_right. } rewrite <- tensor_split. apply idpath. Qed. Proposition internal_lam_natural {x₁ x₂ y z : V} (f : x₁ --> x₂) (g : x₂ ⊗ y --> z) : f · internal_lam g = internal_lam (f #⊗ identity y · g). Proof. use internal_funext. intros w h. etrans. { rewrite tensor_split. rewrite tensor_comp_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split. apply idpath. } refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split. apply idpath. } apply idpath. Qed. Proposition internal_pair_eval (x y : V) : (internal_pair x y) #⊗ identity y · internal_eval y (x ⊗ y) = identity (x ⊗ y). Proof. unfold internal_pair. rewrite internal_beta. apply idpath. Qed. Proposition internal_eval_pair (x y : V) : internal_pair (x ⊸ y) x · internal_lam (internal_eval _ _ · internal_eval _ _) = identity (x ⊸ y). Proof. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. etrans. { rewrite !assoc. apply maponpaths_2. rewrite tensor_split. rewrite !assoc'. unfold internal_pair. rewrite internal_beta. apply id_right. } apply idpath. Qed. Proposition internal_curry_uncurry (v₁ v₂ v₃ : V) : internal_curry v₁ v₂ v₃ · internal_uncurry v₁ v₂ v₃ = identity _. Proof. use internal_funext. intros w h. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_uncurry. rewrite internal_beta. rewrite tensor_split. rewrite <- tensor_id_id. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_rassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_r. unfold internal_curry. rewrite !internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite mon_rassociator_lassociator. apply id_right. Qed. Proposition internal_uncurry_curry (v₁ v₂ v₃ : V) : internal_uncurry v₁ v₂ v₃ · internal_curry v₁ v₂ v₃ = identity _. Proof. use internal_funext. intros w₁ h₁. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_curry. rewrite internal_beta. use internal_funext. intros w₂ h₂. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite tensor_split. rewrite !assoc'. unfold internal_uncurry. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_lassociator. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lassociator_rassociator. apply id_left. } rewrite <- !tensor_comp_mor. rewrite id_right. apply idpath. Qed. Definition internal_hom_equiv (x y z : V) : (x --> y ⊸ z) ≃ (x ⊗ y --> z). Proof. use weq_iso. - exact (λ f, f #⊗ identity y · internal_eval y z). - exact (λ f, internal_lam f). - abstract (intro f ; cbn ; use internal_funext ; intros w h ; rewrite tensor_split ; rewrite !assoc' ; rewrite internal_beta ; rewrite !assoc ; rewrite <- tensor_split ; apply idpath). - abstract (intro f ; cbn ; apply internal_beta). Defined. Proposition internal_precomp_id (x y : V) : internal_precomp (identity x) y = identity _. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite assoc'. unfold internal_precomp. rewrite internal_beta. rewrite tensor_id_id. rewrite id_left. apply idpath. Qed. Proposition internal_precomp_comp {x₁ x₂ x₃ : V} (f₁ : x₁ --> x₂) (f₂ : x₂ --> x₃) (y : V) : internal_precomp (f₁ · f₂) y = internal_precomp f₂ y · internal_precomp f₁ y. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_precomp. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_comp_id_l. apply idpath. Qed. Proposition internal_postcomp_id (x y : V) : internal_postcomp x (identity y) = identity _. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite assoc'. unfold internal_postcomp. rewrite internal_beta. rewrite id_right. apply idpath. Qed. Proposition internal_postcomp_comp (x : V) {y₁ y₂ y₃ : V} (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) : internal_postcomp x (g₁ · g₂) = internal_postcomp x g₁ · internal_postcomp x g₂. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_postcomp. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite internal_beta. apply idpath. Qed. Proposition internal_pre_post_comp_as_pre_post_comp {x₁ x₂ : V} (f : x₁ --> x₂) {y₁ y₂ : V} (g : y₁ --> y₂) : internal_pre_post_comp f g = internal_precomp f y₁ · internal_postcomp x₁ g. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_precomp, internal_postcomp, internal_pre_post_comp. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite internal_beta. apply idpath. Qed. Proposition internal_pre_post_comp_as_post_pre_comp {x₁ x₂ : V} (f : x₁ --> x₂) {y₁ y₂ : V} (g : y₁ --> y₂) : internal_pre_post_comp f g = internal_postcomp x₂ g · internal_precomp f y₂. Proof. use internal_funext. intros a h. rewrite tensor_split. rewrite tensor_comp_r_id_r. rewrite !assoc'. unfold internal_precomp, internal_postcomp, internal_pre_post_comp. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. Qed. Proposition internal_pre_post_comp_id (x y : V) : internal_pre_post_comp (identity x) (identity y) = identity _. Proof. rewrite internal_pre_post_comp_as_pre_post_comp. rewrite internal_precomp_id. rewrite internal_postcomp_id. rewrite id_left. apply idpath. Qed. Proposition internal_pre_post_comp_comp {x₁ x₂ x₃ : V} (f₁ : x₁ --> x₂) (f₂ : x₂ --> x₃) {y₁ y₂ y₃ : V} (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) : internal_pre_post_comp (f₁ · f₂) (g₁ · g₂) = internal_pre_post_comp f₂ g₁ · internal_pre_post_comp f₁ g₂. Proof. rewrite !internal_pre_post_comp_as_pre_post_comp. rewrite internal_precomp_comp. rewrite internal_postcomp_comp. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite <- internal_pre_post_comp_as_pre_post_comp. rewrite <- internal_pre_post_comp_as_post_pre_comp. apply idpath. Qed. End StandardFunctions. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Structure/Symmetric.v000066400000000000000000000567221451125700300255450ustar00rootroot00000000000000(********************************************************************************* Braided and symmetric monoidal categories Braided and symmetric monoidal categories are classes of monoidal categories in which tensoring is commutative in a coherent way. Contents 1. Braided monoidal categories 2. Symmetric monoidal categories 3. Accessors for symmetric monoidal categories Note: after refactoring on March 10, 2023, the prior Git history of this development is found via git log -- UniMath/CategoryTheory/Monoidal/BraidedMonoidalCategoriesWhiskered.v *********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Local Open Scope cat. Local Open Scope moncat. Import BifunctorNotations. Import MonoidalNotations. Section BraidedSymmetricMonoidalCategories. (** 1. Braided monoidal categories *) Definition braiding_data {C : category} (M : monoidal C) : UU := ∏ x y : C, C⟦x ⊗_{M} y, y ⊗_{M} x⟧. Definition braiding_law_naturality_left {C : category} {M : monoidal C} (B : braiding_data M) : UU := ∏ (x y1 y2 : C) (g : C⟦y1, y2⟧), (B x y1) · (g ⊗^{M}_{r} x) = (x ⊗^{M}_{l} g) · (B x y2). Definition braiding_law_naturality_right {C : category} {M : monoidal C} (B : braiding_data M) : UU := ∏ (x1 x2 y : C) (f : C⟦x1, x2⟧), (B x1 y) · (y ⊗^{M}_{l} f) = (f ⊗^{M}_{r} y) · (B x2 y). Definition braiding_law_naturality {C : category} {M : monoidal C} (B : braiding_data M) : UU := braiding_law_naturality_left B × braiding_law_naturality_right B. Definition braiding_iso {C : category} {M : monoidal C} (B1 B2 : braiding_data M) : UU := ∏ (x y : C), is_inverse_in_precat (B1 x y) (B2 y x). Definition braiding_law_hexagon1 {C : category} {M : monoidal C} (B : braiding_data M) : UU := ∏ (x y z : C), α^{M}_{x,y,z} · (B x (y⊗_{M} z)) · α^{M}_{y,z,x} = ((B x y) ⊗^{M}_{r} z) · α^{M}_{y,x,z} · (y ⊗^{M}_{l} (B x z)). Definition braiding_law_hexagon2 {C : category} {M : monoidal C} (B : braiding_data M) : UU := ∏ (x y z : C), αinv^{M}_{x,y,z} · (B (x⊗_{M} y) z) · αinv^{M}_{z,x,y} = (x ⊗^{M}_{l} (B y z)) · αinv^{M}_{x,z,y} · ((B x z) ⊗^{M}_{r} y). Definition braiding_law_hexagon {C : category} {M : monoidal C} (B : braiding_data M) : UU := braiding_law_hexagon1 B × braiding_law_hexagon2 B. Definition braiding_laws {C : category} {M : monoidal C} (B Binv : braiding_data M) : UU := braiding_law_naturality B × braiding_iso B Binv × braiding_law_hexagon B. (** the following is done for the situation of symmetric monoidal categories only *) Definition braiding_laws_one_hexagon {C : category} {M : monoidal C} (B : braiding_data M) : UU := braiding_law_naturality B × braiding_iso B B × braiding_law_hexagon1 B. (* Definition braiding_laws_to_braiding_laws_one_hexagon {C : category} {M : monoidal C} (B : braiding_data M) : braiding_laws B B -> braiding_laws_one_hexagon B. Proof. intro Hyp. split3. - exact (pr1 Hyp). - exact (pr12 Hyp). - exact (pr122 Hyp). Defined. Coercion braiding_laws_to_braiding_laws_one_hexagon : braiding_laws >-> braiding_laws_one_hexagon. *) Definition braiding_laws_one_hexagon_braiding_z_iso {C : category} {M : monoidal C} {B : braiding_data M} (H : braiding_laws_one_hexagon B) (x y : C) : z_iso (x ⊗_{M} y) (y ⊗_{M} x). Proof. use make_z_iso. - exact (B x y). - exact (B y x). - abstract (split ; apply H). Defined. Proposition braiding_laws_one_hexagon_to_braiding_laws {C : category} {M : monoidal C} {B : braiding_data M} (H : braiding_laws_one_hexagon B) : braiding_laws B B. Proof. split4. - split. + exact (pr11 H). + exact (pr21 H). - exact (pr12 H). - exact (pr22 H). - intros x y z. pose (pr22 H z x y). rewrite !assoc'. use (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)). cbn. use (z_iso_inv_on_right _ _ _ (braiding_laws_one_hexagon_braiding_z_iso H _ _)). cbn. refine (!(id_right _) @ _). use (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)). cbn. rewrite !assoc. rewrite p. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. refine (!(bifunctor_leftcomp M _ _ _ _ (B z y) (B y z)) @ _). etrans. { apply maponpaths. apply H. } apply (bifunctor_leftid M). } rewrite id_left. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (monoidal_associatorisolaw M). } rewrite id_left. refine (!(bifunctor_rightcomp M _ _ _ _ (B z x) (B x z)) @ _). etrans. { apply maponpaths. apply H. } apply (bifunctor_rightid M). Qed. Lemma isaprop_braiding_laws {C : category} {M : monoidal C} (B Binv : braiding_data M) : isaprop (braiding_laws B Binv). Proof. repeat (apply isapropdirprod) ; repeat (apply impred_isaprop ; intro) ; try (apply homset_property). apply isapropdirprod ; apply homset_property. Qed. Definition braiding {C : category} (M : monoidal C) : UU := ∑ B Binv : braiding_data M, braiding_laws B Binv. Definition monoidal_braiding_data {C : category} {M : monoidal C} (B : braiding M) : braiding_data M := pr1 B. Coercion monoidal_braiding_data : braiding >-> braiding_data. Definition monoidal_braiding_data_inv {C : category} {M : monoidal C} (B : braiding M) : braiding_data M := pr12 B. Definition monoidal_braiding_laws {C : category} {M : monoidal C} (B : braiding M) : braiding_laws (monoidal_braiding_data B) (monoidal_braiding_data_inv B) := pr22 B. Definition monoidal_braiding_inverses {C : category} {M : monoidal C} (B : braiding M) : braiding_iso (monoidal_braiding_data B) (monoidal_braiding_data_inv B) := pr12 (monoidal_braiding_laws B). Definition monoidal_braiding_naturality {C : category} {M : monoidal C} (B : braiding M) : braiding_law_naturality (monoidal_braiding_data B) := pr1 (monoidal_braiding_laws B). Definition monoidal_braiding_naturality_right {C : category} {M : monoidal C} (B : braiding M) : braiding_law_naturality_right (monoidal_braiding_data B) := pr2 (monoidal_braiding_naturality B) . Definition monoidal_braiding_naturality_left {C : category} {M : monoidal C} (B : braiding M) : braiding_law_naturality_left (monoidal_braiding_data B) := pr1 (monoidal_braiding_naturality B) . (** 2. Symmetric monoidal categories *) Definition symmetric {C : category} (M : monoidal C) : UU := ∑ (B : braiding_data M), braiding_laws B B. Definition symmetric_to_braiding {C : category} {M : monoidal C} (B : symmetric M) : braiding M. (* := (pr1 B,, (pr1 B ,, pr2 B)). *) Proof. exists (pr1 B). exists (pr1 B). exact (pr2 B). Defined. Coercion symmetric_to_braiding : symmetric >-> braiding. Definition symmetric_whiskers_swap_nat_trans_data {C : category} {M : monoidal C} (B : symmetric M) (x : C) : nat_trans_data (leftwhiskering_functor M x) (rightwhiskering_functor M x) := λ y, (monoidal_braiding_data B) x y. Lemma symmetric_whiskers_swap_is_nat_trans {C : category} {M : monoidal C} (B : symmetric M) (x : C) : is_nat_trans _ _ (symmetric_whiskers_swap_nat_trans_data B x). Proof. intros y1 y2 g. exact (! monoidal_braiding_naturality_left B x y1 y2 g). Qed. Definition symmetric_whiskers_swap_nat_trans {C : category} {M : monoidal C} (B : symmetric M) (x : C) : nat_trans (leftwhiskering_functor M x) (rightwhiskering_functor M x) := symmetric_whiskers_swap_nat_trans_data B x ,, symmetric_whiskers_swap_is_nat_trans B x. Lemma symmetric_whiskers_swap_is_nat_iso {C : category} {M : monoidal C} (B : symmetric M) (x : C) : is_nat_z_iso (symmetric_whiskers_swap_nat_trans B x). Proof. intro y. exists ((monoidal_braiding_data B) y x). split ; apply monoidal_braiding_inverses. Defined. Definition symmetric_whiskers_swap_nat_z_iso {C : category} {M : monoidal C} (B : symmetric M) (x : C) : nat_z_iso _ _ := symmetric_whiskers_swap_nat_trans B x,, symmetric_whiskers_swap_is_nat_iso B x. End BraidedSymmetricMonoidalCategories. (** 3. Accessors for symmetric monoidal categories *) Definition sym_monoidal_cat : UU := ∑ (V : monoidal_cat), symmetric V. Coercion sym_monoidal_cat_to_monoidal_cat (V : sym_monoidal_cat) : monoidal_cat := pr1 V. Coercion sym_monoidal_cat_to_symmetric (V : sym_monoidal_cat) : symmetric V := pr2 V. Definition sym_mon_cat_laws_tensored (V : monoidal_cat) (c : ∏ (x y : V), x ⊗ y --> y ⊗ x) : UU := (∏ (x y : V), c x y · c y x = identity _) × (∏ (x₁ x₂ y₁ y₂ : V) (f : x₁ --> x₂) (g : y₁ --> y₂), f #⊗ g · c x₂ y₂ = c x₁ y₁ · g #⊗ f) × (∏ (x y z : V), mon_lassociator x y z · c x (y ⊗ z) · mon_lassociator y z x = c x y #⊗ identity z · mon_lassociator y x z · identity y #⊗ c x z). Section BuilderTensored. Context (V : monoidal_cat) (c : ∏ (x y : V), x ⊗ y --> y ⊗ x) (Hc : sym_mon_cat_laws_tensored V c). Definition make_braiding_laws : braiding_laws c c. Proof. use braiding_laws_one_hexagon_to_braiding_laws. repeat split. - intros x y₁ y₂ g. pose (pr12 Hc x x y₁ y₂ (identity x) g). unfold monoidal_cat_tensor_mor in p. unfold functoronmorphisms1 in p. rewrite (bifunctor_leftid V) in p. rewrite (bifunctor_rightid V) in p. rewrite id_left, id_right in p. exact (!p). - intros x₁ x₂ y f. pose (pr12 Hc x₁ x₂ y y f (identity y)). unfold monoidal_cat_tensor_mor in p. unfold functoronmorphisms1 in p. rewrite (bifunctor_leftid V) in p. rewrite (bifunctor_rightid V) in p. rewrite id_left, id_right in p. exact (!p). - exact (pr1 Hc x y). - exact (pr1 Hc y x). - intros x y z. pose (pr22 Hc x y z). refine (p @ _). rewrite !assoc'. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite (bifunctor_leftid V). rewrite (bifunctor_rightid V). rewrite id_left, id_right. apply idpath. Qed. Definition make_symmetric : symmetric V. Proof. refine (c ,, _). exact make_braiding_laws. Defined. End BuilderTensored. Section Accessors. Context (V : sym_monoidal_cat). Definition sym_mon_braiding (x y : V) : x ⊗ y --> y ⊗ x := monoidal_braiding_data (pr2 V) x y. Proposition sym_mon_braiding_inv (x y : V) : sym_mon_braiding x y · sym_mon_braiding y x = identity _. Proof. exact (pr1 (pr1 (pr222 V) x y)). Qed. Definition is_z_isomorphism_sym_mon_braiding (x y : V) : is_z_isomorphism (sym_mon_braiding x y). Proof. use make_is_z_isomorphism. - exact (sym_mon_braiding y x). - abstract (split ; apply sym_mon_braiding_inv). Defined. Definition sym_mon_braiding_z_iso (x y : V) : z_iso (x ⊗ y) (y ⊗ x) := sym_mon_braiding x y ,, is_z_isomorphism_sym_mon_braiding x y. Proposition tensor_sym_mon_braiding {x₁ x₂ y₁ y₂ : V} (f : x₁ --> x₂) (g : y₁ --> y₂) : f #⊗ g · sym_mon_braiding x₂ y₂ = sym_mon_braiding x₁ y₁ · g #⊗ f. Proof. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (pr1 (pr122 V) x₂ y₁ y₂ g). } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (pr2 (pr122 V) x₁ x₂ y₁ f). } rewrite !assoc'. apply maponpaths. refine (!_). use (bifunctor_equalwhiskers V). Qed. Proposition sym_mon_hexagon_lassociator (x y z : V) : mon_lassociator x y z · sym_mon_braiding x (y ⊗ z) · mon_lassociator y z x = sym_mon_braiding x y #⊗ identity z · mon_lassociator y x z · identity y #⊗ sym_mon_braiding x z. Proof. pose (pr12 (pr222 V) x y z) as p. refine (p @ _). rewrite !assoc'. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite (bifunctor_leftid V). rewrite (bifunctor_rightid V). rewrite id_left, id_right. apply idpath. Qed. Proposition sym_mon_hexagon_lassociator1 (x y1 y2 z : V) : mon_lassociator x (y1 ⊗ y2) z · x ⊗^{ V}_{l} (mon_lassociator y1 y2 z · y1 ⊗^{ V}_{l} sym_mon_braiding y2 z) · mon_rassociator x y1 (z ⊗ y2) = mon_rassociator x y1 y2 ⊗^{ V}_{r} z · mon_lassociator (x ⊗ y1) y2 z · (x ⊗ y1) ⊗^{ V}_{l} sym_mon_braiding y2 z. Proof. apply pathsinv0. use (z_iso_inv_on_left _ _ _ _ (mon_lassociator _ _ _ ,, mon_rassociator _ _ _ ,, _)). { apply monoidal_associatorisolaw. } cbn. etrans. 2: { rewrite assoc'. apply maponpaths. apply monoidal_associatornatleft. } rewrite (bifunctor_leftcomp V). rewrite ! assoc. apply maponpaths_2. etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, mon_lassociator_lassociator. } rewrite ! assoc. rewrite <- (when_bifunctor_becomes_leftwhiskering V). apply maponpaths_2. rewrite <- (when_bifunctor_becomes_rightwhiskering V). etrans. 2: { apply maponpaths_2. apply tensor_comp_id_r. } rewrite mon_rassociator_lassociator. rewrite tensor_id_id. exact (! id_left _). Qed. (** a sanity check *) Lemma sym_mon_cat_laws_tensored_from_sym_mon : sym_mon_cat_laws_tensored V sym_mon_braiding. Proof. repeat split. - apply sym_mon_braiding_inv. - intros; apply tensor_sym_mon_braiding. - apply sym_mon_hexagon_lassociator. Qed. Proposition sym_mon_tensor_lassociator (x y z : V) : sym_mon_braiding x (y ⊗ z) = mon_rassociator x y z · sym_mon_braiding x y #⊗ identity z · mon_lassociator y x z · identity y #⊗ sym_mon_braiding x z · mon_rassociator y z x. Proof. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- sym_mon_hexagon_lassociator. rewrite !assoc'. rewrite mon_lassociator_rassociator. rewrite id_right. apply idpath. } rewrite !assoc. rewrite mon_rassociator_lassociator. apply id_left. Qed. Proposition sym_mon_tensor_lassociator0 (x y z : V) : sym_mon_braiding x (y ⊗ z) · mon_lassociator y z x = mon_rassociator x y z · sym_mon_braiding x y #⊗ identity z · mon_lassociator y x z · identity y #⊗ sym_mon_braiding x z. Proof. rewrite sym_mon_tensor_lassociator. rewrite ! assoc'. rewrite mon_rassociator_lassociator. now rewrite id_right. Qed. Proposition sym_mon_tensor_lassociator' (x y z : V) : sym_mon_braiding x y #⊗ identity z = mon_lassociator x y z · sym_mon_braiding x (y ⊗ z) · mon_lassociator y z x · identity y #⊗ sym_mon_braiding z x · mon_rassociator y x z. Proof. rewrite (sym_mon_hexagon_lassociator x y z). rewrite !assoc'. refine (!(id_right _) @ _). apply maponpaths. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite sym_mon_braiding_inv. rewrite tensor_id_id. apply id_left. } apply mon_lassociator_rassociator. Qed. Lemma sym_mon_tensor_lassociator1 (x y z : V) : mon_lassociator y x z · y ⊗^{V}_{l} sym_mon_braiding x z = sym_mon_braiding y x ⊗^{V}_{r} z · mon_lassociator x y z · sym_mon_braiding x (y ⊗ z) · mon_lassociator y z x. Proof. apply pathsinv0. etrans. { rewrite assoc'. apply maponpaths. exact (sym_mon_tensor_lassociator0 x y z). } etrans. { rewrite ! assoc. do 3 apply maponpaths_2. rewrite assoc'. apply maponpaths. apply mon_lassociator_rassociator. } rewrite id_right. rewrite <- (when_bifunctor_becomes_leftwhiskering V). rewrite <- (when_bifunctor_becomes_rightwhiskering V). etrans. { do 2 apply maponpaths_2. rewrite (when_bifunctor_becomes_rightwhiskering V). apply maponpaths. apply (when_bifunctor_becomes_rightwhiskering V). } etrans. { do 2 apply maponpaths_2. apply pathsinv0, (bifunctor_rightcomp V). } rewrite sym_mon_braiding_inv. rewrite bifunctor_rightid. now rewrite id_left. Qed. Proposition sym_mon_hexagon_rassociator (x y z : V) : mon_rassociator x y z · sym_mon_braiding (x ⊗ y) z · mon_rassociator z x y = identity x #⊗ sym_mon_braiding y z · mon_rassociator x z y · sym_mon_braiding x z #⊗ identity y. Proof. pose (pr22 (pr222 V) x y z) as p. refine (p @ _). rewrite !assoc'. unfold monoidal_cat_tensor_mor. unfold functoronmorphisms1. rewrite (bifunctor_leftid V). rewrite (bifunctor_rightid V). rewrite id_left, id_right. apply idpath. Qed. Proposition sym_mon_tensor_rassociator (x y z : V) : sym_mon_braiding (x ⊗ y) z = mon_lassociator x y z · identity x #⊗ sym_mon_braiding y z · mon_rassociator x z y · sym_mon_braiding x z #⊗ identity y · mon_lassociator z x y. Proof. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- sym_mon_hexagon_rassociator. rewrite !assoc'. rewrite mon_rassociator_lassociator. rewrite id_right. apply idpath. } rewrite !assoc. rewrite mon_lassociator_rassociator. apply id_left. Qed. Proposition sym_mon_hexagon_rassociator0 (x y z : V) : sym_mon_braiding (x ⊗ y) z · mon_rassociator z x y · sym_mon_braiding _ _ ⊗^{V}_{r} y · mon_lassociator _ _ _ = mon_lassociator x y z · x ⊗^{V}_{l} sym_mon_braiding y z. Proof. rewrite sym_mon_tensor_rassociator. rewrite ! assoc'. etrans. { do 4 apply maponpaths. rewrite assoc. now rewrite mon_lassociator_rassociator. } rewrite id_left. apply maponpaths. etrans. { do 2 apply maponpaths. rewrite assoc. do 2 apply maponpaths_2. apply (when_bifunctor_becomes_rightwhiskering V). } etrans. { do 2 apply maponpaths. apply maponpaths_2. apply pathsinv0, (bifunctor_rightcomp V). } rewrite sym_mon_braiding_inv. rewrite (bifunctor_rightid V). rewrite id_left. rewrite mon_rassociator_lassociator. rewrite id_right. apply (when_bifunctor_becomes_leftwhiskering V). Qed. Proposition sym_mon_hexagon_rassociator1 (x y z : V) : sym_mon_braiding (x ⊗ y) z · mon_rassociator z x y · sym_mon_braiding z x ⊗^{ V}_{r} y = mon_lassociator x y z · x ⊗^{ V}_{l} sym_mon_braiding y z · mon_rassociator x z y. Proof. etrans. 2: { apply maponpaths_2. apply sym_mon_hexagon_rassociator0. } etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, mon_lassociator_rassociator. } rewrite ! assoc'. now rewrite id_right. Qed. Proposition sym_mon_braiding_lunitor (x : V) : sym_mon_braiding x (I_{V}) · mon_lunitor x = mon_runitor x. Proof. refine (!(id_right _) @ _ @ id_left _). rewrite <- mon_rinvunitor_runitor. rewrite !assoc. apply maponpaths_2. rewrite tensor_rinvunitor. rewrite tensor_comp_id_r. rewrite sym_mon_tensor_lassociator'. rewrite !assoc'. rewrite <- mon_lunitor_triangle. etrans. { do 5 apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. apply id_left. } rewrite <- mon_rinvunitor_triangle. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. apply idpath. } rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. refine (_ @ sym_mon_braiding_inv _ _). apply maponpaths. rewrite tensor_lunitor. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. rewrite mon_lunitor_triangle. rewrite <- tensor_comp_id_r. rewrite mon_lunitor_I_mon_runitor_I. rewrite mon_rinvunitor_runitor. apply tensor_id_id. Qed. Proposition sym_mon_braiding_runitor (x : V) : sym_mon_braiding (I_{V}) x · mon_runitor x = mon_lunitor x. Proof. rewrite <- sym_mon_braiding_lunitor. rewrite !assoc. rewrite sym_mon_braiding_inv. apply id_left. Qed. Proposition sym_mon_braiding_rinvunitor (x : V) : mon_rinvunitor x · sym_mon_braiding x (I_{V}) = mon_linvunitor x. Proof. refine (!(id_right _) @ _ @ id_left _). rewrite <- mon_lunitor_linvunitor. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite sym_mon_braiding_lunitor. apply mon_rinvunitor_runitor. Qed. Proposition sym_mon_braiding_linvunitor (x : V) : mon_linvunitor x · sym_mon_braiding (I_{V}) x = mon_rinvunitor x. Proof. refine (!(id_right _) @ _ @ id_left _). rewrite <- mon_runitor_rinvunitor. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite sym_mon_braiding_runitor. apply mon_linvunitor_lunitor. Qed. Proposition sym_mon_braiding_id : sym_mon_braiding I_{V} I_{V} = identity (I_{V} ⊗ I_{V}). Proof. refine (_ @ mon_runitor_rinvunitor _). rewrite <- sym_mon_braiding_lunitor. rewrite !assoc'. rewrite mon_lunitor_I_mon_runitor_I. rewrite mon_runitor_rinvunitor. rewrite id_right. apply idpath. Qed. End Accessors. UniMath-20231010/UniMath/CategoryTheory/Monoidal/Structure/SymmetricDiagonal.v000066400000000000000000001346431451125700300272030ustar00rootroot00000000000000(* This file contains certain (coherence) properties involving the braiding, of a fixed symmetric monoidal category. . Remark: There are numerous proofs that could profit from an implementation of coherence theorems for monoidal categories. However, the basic situation of pure monoidal categories where equality of morphisms (built only from identities and the monoidal isos) can be seen from their types would only help to a small extent. Some of those situations are marked in the proofs below. Symmetric monoidal categories do not have such a simple coherence theorem. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Local Open Scope cat. Local Open Scope moncat. Import MonoidalNotations. Section Swapping. Context (V : sym_monoidal_cat). Definition inner_swap (x y z w : V) : V⟦(x ⊗ y) ⊗ (z ⊗ w), (x ⊗ z) ⊗ (y ⊗ w)⟧. Proof. refine (mon_lassociator _ _ _ · _). refine (_ · mon_rassociator _ _ _). refine (x ⊗^{V}_{l} _). refine (mon_rassociator _ _ _ · _). refine (_ · mon_lassociator _ _ _). exact (sym_mon_braiding V y z ⊗^{V}_{r} w). Defined. Definition inner_swap' (x y z w : V) : V⟦(x ⊗ y) ⊗ (z ⊗ w), (x ⊗ z) ⊗ (y ⊗ w)⟧. Proof. refine (mon_lassociator _ _ _ · _). refine (_ · mon_rassociator _ _ _). refine (x ⊗^{V}_{l} _). exact (sym_mon_braiding _ _ _ · mon_lassociator _ _ _ · _ ⊗^{V}_{l} sym_mon_braiding _ _ _). Defined. Definition inner_swap'' (x y z w : V) : V⟦(x ⊗ y) ⊗ (z ⊗ w), (x ⊗ z) ⊗ (y ⊗ w)⟧. Proof. refine (mon_lassociator _ _ _ · _). refine (x ⊗^{V}_{l} _ · _). - exact (sym_mon_braiding _ _ _ · mon_lassociator _ _ _). - exact (mon_rassociator x z (w ⊗ y) · (x ⊗ z) ⊗^{V}_{l} sym_mon_braiding _ w y). Defined. Definition inner_swap''' (x y z w : V) : V⟦(x ⊗ y) ⊗ (z ⊗ w), (x ⊗ z) ⊗ (y ⊗ w)⟧. Proof. refine (sym_mon_braiding _ _ _ ⊗^{V}_{r} _ · mon_lassociator _ _ _ · sym_mon_braiding _ _ (_ ⊗ _) · _). refine (_ · _ ⊗^{V}_{l} sym_mon_braiding _ _ _). refine (_ · mon_rassociator _ _ _). refine (_ · x ⊗^{V}_{l} mon_lassociator _ _ _). apply mon_lassociator. Defined. Lemma sym_monoidal_braiding_hexagon1_variant (y z w : V) : mon_rassociator y z w · (sym_mon_braiding _ y z ⊗^{V}_{r} w · mon_lassociator z y w) = sym_mon_braiding _ _ _ · mon_lassociator _ _ _ · _ ⊗^{V}_{l} sym_mon_braiding _ _ _. Proof. rewrite assoc. apply pathsinv0. use (z_iso_inv_to_right _ _ _ _ (_ ,, _)). { use (is_z_iso_leftwhiskering_z_iso V). apply is_z_isomorphism_sym_mon_braiding. } cbn. rewrite ! assoc'. etrans. 2: { apply maponpaths. rewrite assoc. refine (sym_mon_hexagon_lassociator V _ _ _ @ _). rewrite <- (when_bifunctor_becomes_rightwhiskering V). now rewrite <- (when_bifunctor_becomes_leftwhiskering V). } rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, monoidal_associatorisolaw. } now rewrite id_left. Qed. Lemma inner_swap_characterization01 (x y z w : V) : inner_swap x y z w = inner_swap' x y z w. Proof. unfold inner_swap, inner_swap'. apply maponpaths. apply maponpaths_2. apply maponpaths. apply sym_monoidal_braiding_hexagon1_variant. Qed. Lemma inner_swap_characterization12 (x y z w : V) : inner_swap' x y z w = inner_swap'' x y z w. Proof. unfold inner_swap', inner_swap''. apply maponpaths. rewrite ! (bifunctor_leftcomp V). rewrite ! assoc'. do 2 apply maponpaths. apply monoidal_associatorinvnatleft. Qed. Lemma inner_swap_characterization02 (x y z w : V) : inner_swap x y z w = inner_swap'' x y z w. Proof. refine (inner_swap_characterization01 _ _ _ _ @ _). apply inner_swap_characterization12. Qed. Lemma inner_swap_characterization23 (x y z w : V) : inner_swap'' x y z w = inner_swap''' x y z w. Proof. unfold inner_swap'', inner_swap'''. rewrite ! assoc. do 2 apply maponpaths_2. rewrite ! (bifunctor_leftcomp V). rewrite ! assoc. apply maponpaths_2. apply sym_mon_tensor_lassociator1. Qed. Lemma inner_swap_characterization03 (x y z w : V) : inner_swap x y z w = inner_swap''' x y z w. Proof. etrans. { apply inner_swap_characterization02. } apply inner_swap_characterization23. Qed. Lemma naturality_inner_swap {x y z w : V} {x' y' z' w' : V} (fx : V⟦x,x'⟧) (fy : V⟦y,y'⟧) (fz : V⟦z,z'⟧) (fw : V⟦w,w'⟧) : inner_swap x y z w · ((fx #⊗ fz) #⊗ (fy #⊗ fw)) = ((fx #⊗ fy) #⊗ (fz #⊗ fw)) · inner_swap _ _ _ _. Proof. unfold inner_swap. etrans. { rewrite ! assoc'. do 2 apply maponpaths. apply pathsinv0. exact (monoidal_associatorinv_nat2 V fx fz (fy #⊗ fw)). } rewrite ! assoc. apply maponpaths_2. etrans. 2: { apply maponpaths_2. apply associator_nat2. } rewrite ! assoc'. apply maponpaths. etrans. { apply maponpaths_2. apply maponpaths. apply (sym_monoidal_braiding_hexagon1_variant y z w). } rewrite <- ! (when_bifunctor_becomes_leftwhiskering V). refine (! tensor_comp_mor _ _ _ _ @ _). refine (_ @ tensor_comp_mor _ _ _ _ ). rewrite id_left, id_right. apply maponpaths. etrans. 2: { apply maponpaths. exact (! sym_monoidal_braiding_hexagon1_variant y' z' w'). } rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, tensor_sym_mon_braiding. } rewrite ! assoc'. apply maponpaths. unfold monoidal_cat_tensor_mor. cbn. rewrite ! assoc. etrans. 2: { apply maponpaths_2. apply associator_nat2. } rewrite ! assoc'. apply maponpaths. refine (! tensor_comp_mor _ _ _ _ @ _). rewrite id_left. etrans. { apply maponpaths. apply pathsinv0, tensor_sym_mon_braiding. } cbn. rewrite <- (when_bifunctor_becomes_leftwhiskering V). refine (_ @ tensor_comp_mor _ _ _ _). apply maponpaths_2. apply pathsinv0, id_right. Qed. Lemma inner_swap_along_unit (x y : V) : inner_swap x I_{V} I_{V} y = identity _. Proof. unfold inner_swap. rewrite sym_mon_braiding_id. rewrite (bifunctor_rightid V). rewrite id_left. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. apply monoidal_associatorisolaw. } rewrite (bifunctor_leftid V). rewrite id_left. apply monoidal_associatorisolaw. Qed. Lemma inner_swap_inv (x y z w : V) : inner_swap x y z w · inner_swap x z y w = identity _. Proof. unfold inner_swap. apply pathsinv0. rewrite ! assoc'. use (z_iso_inv_to_left _ _ _ (_ ,, _)). { apply (_ ,, monoidal_associatorisolaw V _ _ _). } cbn. rewrite ! assoc. use (z_iso_inv_on_left _ _ _ _ (mon_lassociator _ _ _ ,, mon_rassociator _ _ _ ,, _)). { apply (_ ,, monoidal_associatorisolaw _ _ _ _). } cbn. rewrite id_right. etrans. 2: { apply pathsinv0. apply monoidal_associatorisolaw. } cbn. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply monoidal_associatorisolaw. } rewrite id_right. refine (! bifunctor_leftcomp V _ _ _ _ _ _ @ _). etrans. { apply maponpaths. rewrite assoc'. apply maponpaths. rewrite ! assoc. do 2 apply maponpaths_2. apply monoidal_associatorisolaw. } rewrite id_left. etrans. { apply maponpaths. rewrite assoc. apply maponpaths_2. rewrite assoc'. apply maponpaths. refine (! bifunctor_rightcomp V _ _ _ _ _ _ @ _). apply maponpaths. apply (monoidal_braiding_inverses V). } rewrite (bifunctor_rightid V). rewrite id_right. etrans. { apply maponpaths. apply monoidal_associatorisolaw. } apply (bifunctor_leftid V). Qed. Lemma inner_swap_is_z_isomorphism (x y z w : V) : is_z_isomorphism (inner_swap x y z w). Proof. use make_is_z_isomorphism. - apply inner_swap. - split ; apply inner_swap_inv. Defined. Lemma inner_swap_composite_second_arg (x y1 y2 z w : V) : mon_lassociator _ _ _ #⊗ (identity _) · inner_swap x (y1 ⊗ y2) z w · (identity _) #⊗ mon_lassociator _ _ _ = inner_swap (x ⊗ y1) y2 z w · mon_lassociator _ _ _ · inner_swap x y1 z (y2 ⊗ w). Proof. unfold inner_swap. rewrite sym_mon_tensor_rassociator. (** uses the hexagon law *) rewrite !tensor_mor_left. rewrite !tensor_comp_id_l. rewrite !tensor_mor_right. rewrite !tensor_comp_id_r. rewrite !tensor_comp_id_l. rewrite !assoc. etrans. 2: { do 2 apply maponpaths_2. rewrite !assoc'. do 9 apply maponpaths. rewrite <- tensor_id_id. assert (aux := tensor_lassociator (sym_mon_braiding V y1 z) (identity y2) (identity w)). apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso V _ _ _)) in aux. cbn in aux. exact aux. } rewrite !tensor_comp_id_l. rewrite !assoc. assert (cohe1 : identity x #⊗ (mon_lassociator z y1 y2 #⊗ identity w) · identity x #⊗ mon_lassociator z (y1 ⊗ y2) w · mon_rassociator x z (y1 ⊗ y2 ⊗ w) · identity (x ⊗ z) #⊗ mon_lassociator y1 y2 w = identity x #⊗ mon_lassociator (z ⊗ y1) y2 w · identity x #⊗ mon_lassociator z y1 (y2 ⊗ w) · mon_rassociator x z (y1 ⊗ (y2 ⊗ w))). { (** the goal is an instance of coherence for monoidal categories *) refine (!_). etrans. { rewrite <- tensor_comp_id_l. rewrite mon_lassociator_lassociator. rewrite !tensor_comp_id_l. apply idpath. } rewrite !assoc'. do 2 apply maponpaths. rewrite tensor_rassociator. rewrite tensor_id_id. apply idpath. } etrans. { rewrite !assoc'. do 7 apply maponpaths. rewrite !assoc. exact cohe1. } rewrite !assoc. do 3 apply maponpaths_2. etrans. 2: { do 7 apply maponpaths_2. rewrite assoc'. do 2 apply maponpaths. rewrite <- tensor_id_id. etrans. 2: { assert (aux := tensor_lassociator (identity x) (identity y1) (sym_mon_braiding V y2 z #⊗ identity w)). apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso V _ _ _)), pathsinv0 in aux. cbn in aux. exact aux. } apply maponpaths_2. do 2 apply maponpaths. assert (aux := tensor_lassociator (identity y1) (sym_mon_braiding V y2 z) (identity w)). apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso V _ _ _)) in aux. cbn in aux. exact aux. } rewrite !tensor_comp_id_l. rewrite !assoc. change ((pr12 V) y2 z) with (sym_mon_braiding V y2 z). assert (cohe2 : mon_lassociator x y1 y2 #⊗ identity (z ⊗ w) · mon_lassociator x (y1 ⊗ y2) (z ⊗ w) · identity x #⊗ mon_rassociator (y1 ⊗ y2) z w · identity x #⊗ (mon_lassociator y1 y2 z #⊗ identity w) = mon_lassociator (x ⊗ y1) y2 (z ⊗ w) · identity (x ⊗ y1) #⊗ mon_rassociator y2 z w · mon_lassociator x y1 (y2 ⊗ z ⊗ w) · identity x #⊗ αinv^{ V }_{ y1, y2 ⊗ z, w}). { (** the goal is an instance of coherence for monoidal categories *) refine (!_). etrans. { apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc. rewrite mon_lassociator_lassociator. apply idpath. } rewrite !assoc'. do 2 apply maponpaths. rewrite <- !tensor_comp_id_l. apply maponpaths. refine ((!id_left _) @ _). rewrite <- mon_rassociator_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite mon_lassociator_lassociator. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. rewrite mon_lassociator_rassociator. rewrite tensor_id_id. apply id_left. } apply mon_lassociator_rassociator. } etrans. { do 3 apply maponpaths_2. exact cohe2. } rewrite !assoc'. do 5 apply maponpaths. rewrite !assoc. apply maponpaths_2. (** the goal is an instance of coherence for monoidal categories *) refine (!_). etrans. { rewrite !assoc'. do 3 apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_id_id. rewrite tensor_lassociator. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. apply mon_rassociator_lassociator. } rewrite id_left. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. refine (!_). apply tensor_comp_id_l. } refine (!_). apply tensor_comp_id_l. } refine (!(tensor_comp_id_l _ _) @ _). apply maponpaths. etrans. { do 2 apply maponpaths. apply mon_rassociator_rassociator. } etrans. { apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. refine (!_). apply tensor_comp_id_l. } rewrite mon_lassociator_rassociator. rewrite tensor_id_id. rewrite id_left. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_lassociator_rassociator. } apply id_left. Qed. Lemma inner_swap_composite_third_arg (x y z1 z2 w : V) : (identity _) #⊗ mon_rassociator _ _ _ · inner_swap x y (z1 ⊗ z2) w · mon_rassociator _ _ _ #⊗ (identity _) = inner_swap x y z1 (z2 ⊗ w) · mon_rassociator _ _ _ · inner_swap (x ⊗ z1) y z2 w. Proof. refine (!(id_right _) @ _). rewrite <- inner_swap_inv. rewrite !assoc. apply maponpaths_2. refine (!(id_right _) @ _). rewrite <- mon_lassociator_rassociator. rewrite !assoc. apply maponpaths_2. refine (!(id_right _) @ _). rewrite <- inner_swap_inv. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite !assoc'. etrans. { do 3 apply maponpaths. rewrite !assoc. refine (!_). apply inner_swap_composite_second_arg. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite mon_rassociator_lassociator. rewrite tensor_id_id. rewrite id_left. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite inner_swap_inv. apply id_left. } rewrite <- tensor_comp_id_l. rewrite mon_rassociator_lassociator. rewrite tensor_id_id. apply idpath. Qed. (** the proof is essentially by turning around all morphisms in the previous lemma *) Lemma mon_lassociator_inner_swap (x y z w : V) : mon_lassociator _ _ _ · inner_swap x y z w · mon_lassociator _ _ _ = mon_lassociator _ _ _ #⊗ (identity _ ) · mon_lassociator _ _ _ · (identity _ ) #⊗ (sym_mon_braiding V y z #⊗ (identity _ ) · mon_lassociator _ _ _). Proof. unfold inner_swap. rewrite !assoc. rewrite mon_lassociator_lassociator. rewrite !assoc'. do 2 apply maponpaths. etrans. { do 2 apply maponpaths. apply mon_rassociator_lassociator. } rewrite id_right. rewrite tensor_mor_left. rewrite <- tensor_comp_id_l. apply maponpaths. etrans. { rewrite !assoc. do 2 apply maponpaths_2. apply mon_lassociator_rassociator. } rewrite id_left. rewrite tensor_mor_right. apply idpath. Qed. Lemma mon_rassociator_inner_swap (x y z w : V) : mon_rassociator _ _ _ · inner_swap x y z w · mon_rassociator _ _ _ = (identity _ ) #⊗ mon_rassociator _ _ _ · mon_rassociator _ _ _ · ((identity _ ) #⊗ (sym_mon_braiding V y z) · mon_rassociator _ _ _) #⊗ (identity _ ). Proof. unfold inner_swap. rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. rewrite !assoc'. rewrite tensor_mor_left. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. etrans. { apply maponpaths. apply mon_rassociator_rassociator. } rewrite tensor_comp_id_r. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_comp_id_l. etrans. { rewrite assoc'. apply maponpaths_2. do 2 apply maponpaths. apply mon_lassociator_rassociator. } rewrite id_right. rewrite tensor_mor_right. apply tensor_rassociator. Qed. (** should go upstream *) Lemma mon_lunitor_triangle_transposed (x : V) : mon_lunitor (monoidal_unit V ⊗_{V} x) = mon_rassociator I_{V} I_{V} x · mon_lunitor I_{V} ⊗^{V}_{r} x. Proof. rewrite <- (when_bifunctor_becomes_rightwhiskering V). etrans. 2: { apply maponpaths, mon_lunitor_triangle. } rewrite assoc. refine (! id_left _ @ _). apply maponpaths_2. apply pathsinv0. apply monoidal_associatorisolaw. Qed. (** should go upstream *) Lemma leftwhisker_of_lunitor_with_unit (x : V) : monoidal_unit V ⊗^{V}_{l} lu^{V}_{x} = lu^{V}_{monoidal_unit V ⊗ x}. Proof. refine (_ @ ! mon_lunitor_triangle_transposed x). use (z_iso_inv_to_left _ _ _ (mon_rassociator _ _ _ ,, mon_lassociator _ _ _ ,, _)). { split ; apply monoidal_associatorisolaw. } refine (monoidal_triangleidentity _ _ _ @ _). apply maponpaths. apply pathsinv0, unitors_coincide_on_unit. Qed. (** should go upstream *) Lemma whiskering_on_both_sides_with_lunitor_left_unit (x y : V) : monoidal_unit V ⊗^{V}_{l} (mon_lunitor x ⊗^{V}_{r} y) = monoidal_unit V ⊗^{V}_{l} mon_lassociator _ _ _ · (mon_rassociator _ _ (x ⊗ y) · mon_lunitor _ ⊗^{V}_{r} (x ⊗ y)). Proof. refine (Categories.right_whisker_with_lunitor' _ _ _ @ _). rewrite (bifunctor_leftcomp V). apply maponpaths. refine (_ @ mon_lunitor_triangle_transposed _). exact (leftwhisker_of_lunitor_with_unit (x ⊗ y)). Qed. Lemma precompose_inner_swap_with_lunitors_on_right (x y : V) : inner_swap (monoidal_unit V) x (monoidal_unit V) y · mon_lunitor (monoidal_unit V) ⊗^{V}_{r} (x ⊗ y) · mon_lunitor (x ⊗ y) = (mon_lunitor x #⊗ mon_lunitor y). Proof. unfold inner_swap. rewrite ! (bifunctor_leftcomp V). etrans. { apply maponpaths_2. rewrite ! assoc'. do 2 apply maponpaths. refine (_ @ idpath (monoidal_unit V ⊗^{V}_{l} (mon_runitor x ⊗^{V}_{r} y))). apply pathsinv0. use (z_iso_inv_to_left _ _ _ (_ ,, _)). { use is_z_iso_leftwhiskering_z_iso. use (is_z_iso_rightwhiskering_z_iso V). apply (_ ,, monoidal_braiding_inverses V _ _). } cbn. rewrite <- (bifunctor_leftcomp V). etrans. { apply maponpaths. refine (! bifunctor_rightcomp V _ _ _ _ _ _ @ _). apply maponpaths. apply sym_mon_braiding_runitor. } apply whiskering_on_both_sides_with_lunitor_left_unit. } rewrite <- (bifunctor_leftcomp V). etrans. { apply maponpaths_2. do 2 apply maponpaths. etrans. { apply maponpaths. refine (_ @ mon_triangle x y). apply pathsinv0, (when_bifunctor_becomes_rightwhiskering V). } rewrite assoc. apply maponpaths_2. apply monoidal_associatorisolaw. } rewrite id_left. unfold monoidal_cat_tensor_mor. cbn. etrans. { rewrite assoc'. apply maponpaths. refine (_ @ tensor_lunitor (identity x #⊗ mon_lunitor y)). now rewrite <- (when_bifunctor_becomes_leftwhiskering V). } rewrite assoc. etrans. { apply maponpaths_2. apply mon_lunitor_triangle. } apply pathsinv0, tensor_split'. Qed. Lemma precompose_inner_swap_with_lunitors_and_runitor (x y : V) : inner_swap x (monoidal_unit V) y (monoidal_unit V) · (x ⊗ y) ⊗^{V}_{l} mon_lunitor (monoidal_unit V) · mon_runitor (x ⊗ y) = (mon_runitor x #⊗ mon_runitor y). Proof. unfold inner_swap. rewrite ! (bifunctor_leftcomp V). etrans. { apply maponpaths_2. rewrite ! assoc'. do 2 apply maponpaths. refine (_ @ idpath (x ⊗^{V}_{l} (mon_lunitor y ⊗^{V}_{r} monoidal_unit V) · mon_rassociator _ _ _)). apply pathsinv0. use (z_iso_inv_to_left _ _ _ (_ ,, _)). { use is_z_iso_leftwhiskering_z_iso. use (is_z_iso_rightwhiskering_z_iso V). apply (_ ,, monoidal_braiding_inverses V _ _). } cbn. rewrite ! assoc. rewrite <- (bifunctor_leftcomp V). etrans. { apply maponpaths_2. apply maponpaths. refine (! bifunctor_rightcomp V _ _ _ _ _ _ @ _). apply maponpaths. apply sym_mon_braiding_lunitor. } etrans. { apply maponpaths_2. apply maponpaths. refine (_ @ mon_triangle _ _). apply pathsinv0. apply (when_bifunctor_becomes_rightwhiskering V). } cbn. rewrite (bifunctor_leftcomp V). rewrite ! assoc'. apply maponpaths. unfold monoidal_cat_tensor_mor. cbn. rewrite (when_bifunctor_becomes_leftwhiskering V). apply (monoidal_associatorinvnatleft V). } rewrite ! assoc'. etrans. { do 3 apply maponpaths. apply mon_runitor_triangle. } unfold monoidal_cat_tensor_mor. cbn. unfold functoronmorphisms1. unfold monoidal_cat_tensor_pt. cbn. rewrite ! assoc. apply maponpaths_2. rewrite (bifunctor_rightid V). rewrite id_right. rewrite assoc'. rewrite <- (bifunctor_leftcomp V). etrans. 2: { refine (! mon_triangle _ _ @ _). apply (when_bifunctor_becomes_rightwhiskering V). } apply maponpaths. rewrite <- (when_bifunctor_becomes_leftwhiskering V). apply maponpaths. use (z_iso_inv_on_right _ _ _ (mon_lassociator _ _ _ ,, _ ,, _)). { apply monoidal_associatorisolaw. } cbn. rewrite <- (when_bifunctor_becomes_rightwhiskering V). apply (! mon_lunitor_triangle _ _). Qed. Lemma inner_swap_hexagon (x1 x2 y1 y2 z1 z2 : V) : inner_swap (x1 ⊗ x2) y1 (y2 ⊗ z1) z2 · (inner_swap x1 x2 y2 z1 ⊗^{V}_{r} (y1 ⊗ z2) · mon_lassociator _ _ _) = (mon_lassociator _ _ _ #⊗ mon_lassociator _ _ _) · (inner_swap x1 (x2 ⊗ y1) y2 (z1 ⊗ z2) · (x1 ⊗ y2) ⊗^{V}_{l} inner_swap x2 y1 z1 z2). Proof. rewrite tensor_split. rewrite <- tensor_mor_left. rewrite !assoc'. set (auxiso := functor_on_z_iso (leftwhiskering_functor V (x1 ⊗ x2 ⊗ y1)) (z_iso_from_associator_iso V y2 z1 z2)). apply (z_iso_inv_to_left _ _ _ auxiso). cbn. clear auxiso. etrans. { rewrite assoc. apply maponpaths_2. assert (auxH := inner_swap_composite_third_arg (x1 ⊗ x2) y1 y2 z1 z2). rewrite <- tensor_mor_right in auxH. set (auxiso1 := functor_on_z_iso (rightwhiskering_functor V (y1 ⊗ z2)) (z_iso_from_associator_iso V (x1 ⊗ x2) y2 z1)). apply pathsinv0, (z_iso_inv_to_right _ _ _ _ auxiso1), pathsinv0 in auxH. rewrite tensor_mor_left. cbn in auxH. exact auxH. } etrans. 2: { rewrite assoc. apply maponpaths_2. assert (auxH := inner_swap_composite_second_arg x1 x2 y1 y2 (z1 ⊗ z2)). rewrite <- tensor_mor_left in auxH. set (auxiso1 := functor_on_z_iso (leftwhiskering_functor V (x1 ⊗ y2)) (z_iso_from_associator_iso V x2 y1 (z1 ⊗ z2))). apply pathsinv0, (z_iso_inv_on_left _ _ _ _ auxiso1), pathsinv0 in auxH. cbn in auxH. rewrite tensor_mor_left in auxH. exact auxH. } rewrite !assoc'. apply maponpaths. etrans. 2: { rewrite !assoc. do 2 apply maponpaths_2. assert (auxH := mon_lassociator_inner_swap x1 x2 y2 (y1 ⊗ (z1 ⊗ z2))). apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso V _ _ _)), pathsinv0 in auxH. cbn in auxH. exact auxH. } etrans. { rewrite !assoc. do 3 apply maponpaths_2. assert (auxH := mon_rassociator_inner_swap ((x1 ⊗ x2) ⊗ y2) y1 z1 z2). apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (z_iso_from_associator_iso V _ _ _)), pathsinv0 in auxH. cbn in auxH. exact auxH. } rewrite ! tensor_mor_left. rewrite ! tensor_mor_right. rewrite tensor_comp_id_l. rewrite tensor_comp_id_r. etrans. { apply maponpaths_2. rewrite !assoc'. do 5 apply maponpaths. etrans. { apply pathsinv0, tensor_comp_id_r. } apply maponpaths_2. assert (auxH := mon_lassociator_inner_swap x1 x2 y2 z1). apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso V _ _ _)) in auxH. cbn in auxH. exact auxH. } etrans. 2: { rewrite !assoc'. do 5 apply maponpaths. etrans. 2: { apply tensor_comp_id_l. } apply maponpaths. assert (auxH := mon_rassociator_inner_swap x2 y1 z1 z2). apply pathsinv0, (z_iso_inv_to_right _ _ _ _ (z_iso_from_associator_iso V _ _ _)) in auxH. cbn in auxH. exact auxH. } change ((pr12 V) x2 y2) with (sym_mon_braiding V x2 y2). change ((pr12 V) y1 z1) with (sym_mon_braiding V y1 z1). (** now on each side the same uses of [sym_mon_braiding] and otherwise only associators and whiskering *) etrans. { rewrite !assoc'. apply maponpaths. rewrite !assoc. do 4 apply maponpaths_2. apply pathsinv0, tensor_rassociator. } rewrite !assoc. rewrite <- tensor_comp_id_l. etrans. 2: { rewrite !assoc'. apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. apply tensor_lassociator. } rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite !assoc'. transparent assert (auxiso : (z_iso (x1 ⊗ x2 ⊗ y2 ⊗ (y1 ⊗ (z1 ⊗ z2))) (x1 ⊗ x2 ⊗ y2 ⊗ (z1 ⊗ y1 ⊗ z2)))). { apply (functor_on_z_iso (leftwhiskering_functor V _)). use z_iso_comp. 2: { apply z_iso_inv. exact (z_iso_from_associator_iso V _ _ _). } apply (functor_on_z_iso (rightwhiskering_functor V _)). apply sym_mon_braiding_z_iso. } rewrite <- tensor_mor_left. rewrite <- tensor_mor_right. apply pathsinv0, (z_iso_inv_to_left _ _ _ auxiso), pathsinv0. cbn. clear auxiso. etrans. 2: { rewrite !assoc. do 4 apply maponpaths_2. rewrite tensor_mor_left. apply tensor_swap. } rewrite !assoc'. transparent assert (auxiso : (z_iso (x1 ⊗ x2 ⊗ y2 ⊗ (z1 ⊗ y1 ⊗ z2)) (x1 ⊗ y2 ⊗_{ pr1 V} x2 ⊗ (z1 ⊗ y1 ⊗ z2)))). { apply (functor_on_z_iso (rightwhiskering_functor V _)). use z_iso_comp. 2: { exact (z_iso_from_associator_iso V _ _ _). } apply (functor_on_z_iso (leftwhiskering_functor V _)). apply sym_mon_braiding_z_iso. } apply pathsinv0. rewrite <- tensor_mor_left. rewrite <- tensor_mor_right. apply pathsinv0, (z_iso_inv_to_left _ _ _ auxiso). cbn. clear auxiso. change ((pr12 V) x2 y2) with (sym_mon_braiding V x2 y2). change ((pr12 V) y2 x2) with (sym_mon_braiding V y2 x2). change ((pr12 V) y1 z1) with (sym_mon_braiding V y1 z1). change ((pr12 V) z1 y1) with (sym_mon_braiding V z1 y1). (** on each side, [sym_mon_braiding] appears as one pair of inverses, so both sides are now independent, so they have both to be equal to a canonical braiding-free expression *) rewrite tensor_mor_left. rewrite !tensor_mor_right. (* show_id_type. *) transparent assert (middle : (V ⟦ x1 ⊗ (y2 ⊗ x2) ⊗ (z1 ⊗ y1 ⊗ z2), x1 ⊗ y2 ⊗ (x2 ⊗ z1 ⊗ (y1 ⊗ z2)) ⟧)). { refine (_ #⊗ _ · _). - apply mon_rassociator. - apply mon_lassociator. - refine (mon_lassociator _ _ _ · _). refine ((identity (x1 ⊗ y2)) #⊗ _). apply mon_rassociator. } intermediate_path middle; [| apply pathsinv0]. - rewrite tensor_comp_id_l. rewrite tensor_comp_id_r. rewrite !assoc'. match goal with | [|- ?s · _ = _ ] => set (symyx := s) end. etrans. { do 5 apply maponpaths. apply maponpaths_2. etrans. { apply maponpaths_2. apply maponpaths. rewrite assoc. apply maponpaths_2. apply pathsinv0, tensor_lassociator. } rewrite !tensor_comp_id_r. rewrite !assoc'. apply maponpaths. apply maponpaths_2. refine (!(id_right _) @ _). etrans. { apply maponpaths. apply pathsinv0, mon_lassociator_rassociator. } rewrite assoc. apply maponpaths_2. etrans. { apply tensor_lassociator. } rewrite tensor_id_id. apply maponpaths. assert (auxH := tensor_swap (identity x1 #⊗ sym_mon_braiding V x2 y2) (mon_lassociator z1 y1 z2)). do 3 rewrite <- tensor_mor_left in auxH. transparent assert (auxiso : (z_iso ((x1 ⊗ (x2 ⊗ y2)) ⊗_{ V} (z1 ⊗ y1 ⊗ z2)) ((x1 ⊗ (x2 ⊗ y2)) ⊗_{ V} (z1 ⊗ (y1 ⊗ z2))))). { apply (functor_on_z_iso (leftwhiskering_functor V _)). exact (z_iso_from_associator_iso V _ _ _). } apply (z_iso_inv_on_right _ _ _ auxiso) in auxH. cbn in auxH. clear auxiso. rewrite ! tensor_mor_left in auxH. apply (!auxH). } change ((pr12 V) x2 y2) with (sym_mon_braiding V x2 y2). rewrite !assoc. match goal with | [|- _ · ?s · _ · _ · _ · _ · _ · _ = _ ] => set (symxy := s) end. etrans. { do 7 apply maponpaths_2. rewrite !assoc'. apply maponpaths. (* show_id_type. *) intermediate_path (identity ((x1 ⊗ (x2 ⊗ y2)) ⊗ (z1 ⊗ y1 ⊗ z2))). - (** the goal is an instance of coherence for monoidal categories *) etrans. { do 3 apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. apply mon_lassociator_lassociator. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite mon_rassociator_lassociator. rewrite tensor_id_id. rewrite id_left. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_rassociator_lassociator. rewrite id_left. apply idpath. } rewrite tensor_id_id. rewrite <- tensor_comp_mor. rewrite id_left, id_right. etrans. { apply maponpaths. refine (!_). apply tensor_comp_mor. } refine (!(tensor_comp_mor _ _ _ _) @ _). rewrite id_right, id_left. etrans. { apply maponpaths. apply mon_lassociator_rassociator. } refine (_ @ tensor_id_id _ _). apply maponpaths_2. apply mon_rassociator_lassociator. - apply idpath. } rewrite id_right. etrans. { do 6 apply maponpaths_2. etrans. { apply pathsinv0, tensor_comp_id_r. } apply maponpaths_2. etrans. { apply pathsinv0, tensor_comp_id_l. } apply maponpaths. apply sym_mon_braiding_inv. } do 2 rewrite tensor_id_id. rewrite id_left. unfold middle. (** the goal is an instance of coherence for monoidal categories *) refine (!_). etrans. { apply maponpaths_2. apply tensor_split. } rewrite !assoc'. apply maponpaths. refine (!_). refine (!(id_left _) @ _). rewrite <- mon_lassociator_rassociator. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_rassociator_rassociator. rewrite !assoc'. do 2 apply maponpaths. rewrite !assoc. rewrite <- !tensor_comp_id_r. rewrite mon_rassociator_lassociator. rewrite id_left. rewrite !tensor_comp_id_r. apply idpath. } etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite <- tensor_rassociator. apply idpath. } rewrite !assoc'. etrans. { do 3 apply maponpaths. refine (!(id_left _) @ _). rewrite <- tensor_id_id. rewrite <- mon_lassociator_rassociator. rewrite tensor_comp_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. refine (!_). apply mon_rassociator_rassociator. } rewrite !assoc'. rewrite mon_rassociator_lassociator. rewrite id_right. refine (_ @ id_right _). rewrite <- mon_lassociator_rassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. rewrite <- tensor_id_id. apply tensor_lassociator. } etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lassociator_lassociator. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_id_r. rewrite mon_rassociator_lassociator. rewrite tensor_id_id. rewrite id_left. rewrite !assoc'. apply maponpaths. rewrite <- !tensor_comp_id_l. apply maponpaths. refine (!(id_left _) @ _). rewrite <- mon_rassociator_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite mon_lassociator_lassociator. rewrite !assoc'. apply maponpaths. rewrite <- tensor_comp_id_l. rewrite mon_lassociator_rassociator. rewrite tensor_id_id. apply id_right. - rewrite tensor_comp_id_l. rewrite tensor_comp_id_r. rewrite assoc'. match goal with | [|- ?s · _ = _ ] => set (symzy := s) end. etrans. { do 5 apply maponpaths. etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply pathsinv0, tensor_rassociator. } rewrite !tensor_comp_id_l. rewrite !assoc'. apply maponpaths. apply maponpaths_2. refine (!(id_right _) @ _). etrans. { apply maponpaths. apply pathsinv0, mon_rassociator_lassociator. } rewrite assoc. apply maponpaths_2. etrans. { apply tensor_rassociator. } rewrite tensor_id_id. apply maponpaths. assert (auxH := tensor_swap (mon_lassociator x1 y2 x2) (sym_mon_braiding V y1 z1 #⊗ identity z2) ). do 3 rewrite <- tensor_mor_right in auxH. transparent assert (auxiso : (z_iso ((x1 ⊗ y2 ⊗ x2) ⊗_{ V} (z1 ⊗ y1 ⊗ z2)) ((x1 ⊗ (y2 ⊗ x2)) ⊗_{ V} (z1 ⊗ y1 ⊗ z2)))). { apply (functor_on_z_iso (rightwhiskering_functor V _)). exact (z_iso_from_associator_iso V _ _ _). } apply (z_iso_inv_on_left _ _ _ _ auxiso) in auxH. cbn in auxH. clear auxiso. rewrite tensor_mor_right in auxH. exact auxH. } change ((pr12 V) y1 z1) with (sym_mon_braiding V y1 z1). rewrite !assoc. match goal with | [|- _ · ?s · _ · _ · _ · _ · _ = _ ] => set (symyz := s) end. etrans. { do 6 apply maponpaths_2. rewrite !assoc'. apply maponpaths. (* show_id_type. *) intermediate_path (identity (x1 ⊗ (y2 ⊗ x2) ⊗ (y1 ⊗ z1 ⊗ z2))). - (** the goal is an instance of coherence for monoidal categories *) etrans. { do 3 apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths. apply maponpaths_2. exact (!(tensor_id_id _ _)). } refine (!_). apply tensor_rassociator. } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. apply mon_rassociator_rassociator. } rewrite !assoc'. rewrite tensor_mor_right. rewrite <- tensor_comp_id_r. rewrite mon_rassociator_lassociator. rewrite tensor_id_id. rewrite id_right. apply idpath. } refine (_ @ mon_lassociator_rassociator _ _ _). rewrite !assoc. apply maponpaths_2. etrans. { do 3 apply maponpaths_2. rewrite <- tensor_id_id. rewrite tensor_lassociator. apply idpath. } rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. rewrite <- !tensor_comp_id_l. refine (_ @ tensor_id_id _ _). apply maponpaths. refine (_ @ mon_lassociator_rassociator _ _ _). rewrite !assoc. apply maponpaths_2. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. rewrite <- !tensor_id_id. rewrite <- !tensor_comp_id_l. do 2 apply maponpaths. rewrite !tensor_id_id. apply mon_lassociator_rassociator. - apply idpath. } rewrite id_right. etrans. { do 5 apply maponpaths_2. etrans. { apply pathsinv0, tensor_comp_id_l. } apply maponpaths. etrans. { apply pathsinv0, tensor_comp_id_r. } apply maponpaths_2. apply sym_mon_braiding_inv. } do 2 rewrite tensor_id_id. rewrite id_left. unfold middle. (** the goal is an instance of coherence for monoidal categories *) refine (!_). etrans. { apply maponpaths_2. rewrite tensor_split'. apply idpath. } rewrite tensor_mor_right. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite <- !tensor_comp_id_l. apply maponpaths. refine (_ @ id_right _). rewrite <- mon_lassociator_rassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. refine (!_). etrans. { do 2 apply maponpaths. apply mon_lassociator_lassociator. } rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. refine (_ @ mon_rassociator_lassociator _ _ _). apply maponpaths_2. refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. rewrite <- tensor_id_id. rewrite <- tensor_comp_id_r. rewrite mon_rassociator_lassociator. apply idpath. Qed. Lemma inner_swap_hexagon_2 (x y : V) : inner_swap (x ⊗ x) x (y ⊗ y) y · (inner_swap x x y y ⊗^{V}_{r} (x ⊗ y) · mon_lassociator _ _ _) = mon_lassociator _ _ _ #⊗ mon_lassociator _ _ _ · (inner_swap x (x ⊗ x) y (y ⊗ y) · (x ⊗ y) ⊗^{V}_{l} inner_swap x x y y). Proof. apply inner_swap_hexagon. Qed. Lemma inner_swap_hexagon' (x1 x2 y1 y2 z1 z2 : V) : inner_swap x1 x2 y1 y2 #⊗ identity (z1 ⊗ z2) · inner_swap (x1 ⊗ y1) (x2 ⊗ y2) z1 z2 · mon_lassociator _ _ _ #⊗ mon_lassociator _ _ _ = mon_lassociator _ _ _ · identity (x1 ⊗ x2) #⊗ inner_swap y1 y2 z1 z2 · inner_swap x1 x2 (y1 ⊗ z1) (y2 ⊗ z2). Proof. refine (!(id_right _) @ _). rewrite <- inner_swap_inv. rewrite !assoc. apply maponpaths_2. refine (!(id_right _) @ _). etrans. { apply maponpaths. rewrite <- tensor_id_id. rewrite <- inner_swap_inv. rewrite tensor_comp_id_l. apply idpath. } rewrite !assoc. apply maponpaths_2. etrans. { rewrite !assoc'. do 2 apply maponpaths. rewrite <- tensor_mor_left. refine (!_). apply inner_swap_hexagon. } rewrite tensor_mor_right. etrans. { apply maponpaths. rewrite !assoc. rewrite inner_swap_inv. rewrite id_left. apply idpath. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply tensor_comp_id_r. } rewrite inner_swap_inv. rewrite tensor_id_id. apply id_left. Qed. Lemma inner_swap_hexagon'_3 (x y z : V) : inner_swap x x y y #⊗ identity (z ⊗ z) · inner_swap (x ⊗ y) (x ⊗ y) z z · mon_lassociator _ _ _ #⊗ mon_lassociator _ _ _ = mon_lassociator _ _ _ · identity (x ⊗_ x) #⊗ inner_swap y y z z · inner_swap x x (y ⊗ z) (y ⊗ z). Proof. apply inner_swap_hexagon'. Qed. Lemma inner_swap_hexagoninv' (x y z : V) : identity (x ⊗ x) #⊗ inner_swap y y z z · inner_swap x x (y ⊗ z) (y ⊗ z) · mon_rassociator _ _ _ #⊗ mon_rassociator _ _ _ = mon_rassociator _ _ _ · inner_swap x x y y #⊗ identity (z ⊗ z) · inner_swap (x ⊗ y) (x ⊗ y) z z. Proof. set (t := inner_swap_hexagon' x x y y z z). apply pathsinv0. use (z_iso_inv_on_left _ _ _ _ (mon_lassociator _ _ _ #⊗ mon_lassociator _ _ _,, mon_rassociator _ _ _ #⊗ mon_rassociator _ _ _ ,, _)). { apply (pr2 (is_z_iso_bifunctor_z_iso V (mon_lassociator _ _ _) (mon_lassociator _ _ _) (_ ,, monoidal_associatorisolaw V _ _ _) (_ ,, monoidal_associatorisolaw V _ _ _))). } cbn. etrans. 2: { rewrite ! assoc'. apply maponpaths. rewrite assoc. apply (! t). } etrans. 2: { rewrite ! assoc. do 2 apply maponpaths_2. apply pathsinv0. apply mon_rassociator_lassociator. } now rewrite id_left. Qed. Lemma inner_swap_commute_with_swap (x1 x2 y1 y2 : V) : inner_swap x1 x2 y1 y2 · sym_mon_braiding _ x1 y1 #⊗ sym_mon_braiding _ x2 y2 = sym_mon_braiding _ (x1 ⊗ x2) (y1 ⊗ y2) · inner_swap y1 y2 x1 x2. Proof. unfold inner_swap. rewrite ! assoc. etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, sym_mon_tensor_lassociator0. } unfold monoidal_cat_tensor_mor, mon_lassociator, mon_rassociator. cbn. etrans. 2: { apply maponpaths_2. rewrite assoc'. apply maponpaths. rewrite (when_bifunctor_becomes_leftwhiskering V). etrans. 2: apply (bifunctor_leftcomp V y1). apply maponpaths. rewrite ! assoc. apply pathsinv0. apply sym_mon_hexagon_rassociator0. } etrans. 2: { rewrite ! assoc'. do 2 apply maponpaths. refine (! sym_mon_hexagon_lassociator1 _ _ _ _ _ @ _). now rewrite ! assoc'. } unfold functoronmorphisms1. rewrite ! assoc. apply maponpaths_2. unfold monoidal_cat_tensor_pt. cbn. rewrite ! assoc'. apply pathsinv0. use (z_iso_inv_on_right _ _ _ (mon_lassociator _ _ _ ,, mon_rassociator _ _ _ ,, _)). { apply monoidal_associatorisolaw. } cbn. rewrite (bifunctor_leftcomp V). rewrite ! assoc. etrans. 2: { do 3 apply maponpaths_2. apply pathsinv0. apply mon_lassociator_lassociator'. } rewrite (bifunctor_leftid V). rewrite id_right. apply pathsinv0. use (z_iso_inv_to_right _ _ _ _ (_ ,, _)). { use (is_z_iso_rightwhiskering_z_iso V). refine (_ ,, _). apply (_ ,, monoidal_braiding_inverses V). } cbn. etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, monoidal_associatornatright. } etrans. 2: { rewrite assoc. apply maponpaths_2. rewrite <- ! (bifunctor_rightcomp V). apply maponpaths. apply pathsinv0, sym_mon_hexagon_rassociator1. } rewrite ! (bifunctor_rightcomp V). rewrite ! assoc'. apply maponpaths. rewrite ! assoc. rewrite (bifunctor_leftcomp V). rewrite assoc. unfold sym_mon_braiding, mon_lassociator, monoidal_cat_tensor_pt. cbn. rewrite (monoidal_associatornatleftright V). rewrite ! assoc'. apply maponpaths. rewrite assoc. apply pathsinv0. use (z_iso_inv_on_left _ _ _ _ (mon_lassociator _ _ _ ,, mon_rassociator _ _ _ ,, _)). { apply monoidal_associatorisolaw. } cbn. rewrite assoc'. etrans. 2: { apply maponpaths. apply pathsinv0, mon_lassociator_lassociator. } unfold monoidal_cat_tensor_mor. unfold mon_lassociator. unfold mon_rassociator. unfold monoidal_cat_tensor_pt. cbn. rewrite ! assoc. rewrite (when_bifunctor_becomes_rightwhiskering V). rewrite <- (bifunctor_rightcomp V). etrans. 2: { do 2 apply maponpaths_2. apply maponpaths. apply pathsinv0, (monoidal_associatorisolaw V). } rewrite (bifunctor_rightid V). rewrite id_left. now rewrite (when_bifunctor_becomes_leftwhiskering V). Qed. End Swapping. UniMath-20231010/UniMath/CategoryTheory/Monoidal/WhiskeredBifunctors.v000066400000000000000000000723361451125700300255540ustar00rootroot00000000000000(* Require Export UniMath.Tactics.EnsureStructuredProofs. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. (** This import is included because in the end we want to show that bifunctors are equivalent to functors coming out of a product category *) Require Import UniMath.CategoryTheory.PrecategoryBinProduct. (** the following are needed for the connection with functors into the functor category *) Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. (** the following are needed for the distribution of (binary) coproducts *) Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.ProductCategory. Open Scope cat. Section Bifunctor. Context {A B C : category}. Definition bifunctor_data : UU := ∑ (F : A -> B -> C), (∏ (a : A) (b1 b2 : B), B⟦b1, b2⟧ → C⟦F a b1, F a b2⟧) × (* left whiskering *) (∏ (b : B) (a1 a2 : A), A⟦a1, a2⟧ → C⟦F a1 b, F a2 b⟧). (* right whiskering *) Definition make_bifunctor_data (F : A -> B -> C) (lw : ∏ (a : A) (b1 b2 : B), B⟦b1, b2⟧ → C⟦F a b1, F a b2⟧) (rw : ∏ (b : B) (a1 a2 : A), A⟦a1, a2⟧ → C⟦F a1 b, F a2 b⟧) : bifunctor_data := (F,,lw,,rw). Definition bifunctor_on_objects (F : bifunctor_data) : A → B → C := pr1 F. Local Notation "a ⊗_{ F } b" := (bifunctor_on_objects F a b) (at level 31). Definition leftwhiskering_on_morphisms (F : bifunctor_data) : ∏ (a : A) (b1 b2 : B), B⟦b1, b2⟧ → C⟦a ⊗_{F} b1, a ⊗_{F} b2⟧ := pr1 (pr2 F). Local Notation "a ⊗^{ F }_{l} g" := (leftwhiskering_on_morphisms F a _ _ g) (at level 31). Definition rightwhiskering_on_morphisms (F : bifunctor_data) : ∏ (b : B) (a1 a2 : A), A⟦a1, a2⟧ → C⟦a1 ⊗_{F} b, a2 ⊗_{F} b⟧ := pr2 (pr2 F). Local Notation "f ⊗^{ F }_{r} b" := (rightwhiskering_on_morphisms F b _ _ f) (at level 31). Definition bifunctor_leftidax (F : bifunctor_data) := ∏ (a : A) (b : B), a ⊗^{F}_{l} (identity b) = identity (a ⊗_{F} b). Definition bifunctor_rightidax (F : bifunctor_data) := ∏ (b : B) (a : A), (identity a) ⊗^{F}_{r} b = identity (a ⊗_{F} b). Definition bifunctor_leftcompax (F : bifunctor_data) := ∏ (a : A) (b1 b2 b3 : B) (g1 : B⟦b1,b2⟧) (g2 : B⟦b2,b3⟧), a ⊗^{F}_{l} (g1 · g2) = (a ⊗^{F}_{l} g1) · (a ⊗^{F}_{l} g2). Definition bifunctor_rightcompax (F : bifunctor_data) := ∏ (b : B) (a1 a2 a3 : A) (f1 : A⟦a1,a2⟧) (f2 : A⟦a2,a3⟧), (f1 · f2) ⊗^{F}_{r} b = (f1 ⊗^{F}_{r} b) · (f2 ⊗^{F}_{r} b). Lemma leftwhiskering_functor_pre (F : bifunctor_data) (bli : bifunctor_leftidax F) (blc : bifunctor_leftcompax F) (a : A): functor B C. Proof. use make_functor. - use tpair. + intro b. exact (a ⊗_{F} b). + intros b1 b2 g. exact (a ⊗^{F}_{l} g). - use tpair. + intros b. exact (bli a b). + intros b1 b2 b3 g2 g3. cbn. exact (blc a b1 b2 b3 g2 g3). Defined. Lemma rightwhiskering_functor_pre (F : bifunctor_data) (bri : bifunctor_rightidax F) (brc : bifunctor_rightcompax F) (b : B) : functor A C. Proof. use make_functor. - use tpair. + intro a. exact (a ⊗_{F} b). + intros a1 a2 f. exact (f ⊗^{F}_{r} b). - use tpair. + intros a. exact (bri b a). + intros a1 a2 a3 f2 f3. cbn. exact (brc b a1 a2 a3 f2 f3). Defined. Definition functoronmorphisms1 (F : bifunctor_data) {a1 a2 : A} {b1 b2 : B} (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧) : C⟦a1 ⊗_{F} b1, a2 ⊗_{F} b2⟧ := (f ⊗^{F}_{r} b1) · (a2 ⊗^{F}_{l} g). Local Notation "f ⊗^{ F } g" := (functoronmorphisms1 F f g) (at level 31). Definition functoronmorphisms2 (F : bifunctor_data) {a1 a2 : A} {b1 b2 : B} (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧) : C⟦a1 ⊗_{F} b1, a2 ⊗_{F} b2⟧ := (a1 ⊗^{F}_{l} g) · (f ⊗^{F}_{r} b2). Local Notation "f ⊗^{ F }_{2} g" := (functoronmorphisms2 F f g) (at level 31). Definition functoronmorphisms_are_equal (F : bifunctor_data) := ∏ (a1 a2 : A) (b1 b2 : B) (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧), f ⊗^{F} g = f ⊗^{F}_{2} g. Lemma whiskerscommutes (F : bifunctor_data) (fmae : functoronmorphisms_are_equal F) {a1 a2 : A} {b1 b2 : B} (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧) : (f ⊗^{F}_{r} b1)·(a2 ⊗^{F}_{l} g) = (a1 ⊗^{F}_{l} g)·(f ⊗^{F}_{r} b2). Proof. exact (fmae _ _ _ _ f g). Qed. Definition is_bifunctor (F : bifunctor_data) : UU := (bifunctor_leftidax F) × (bifunctor_rightidax F) × (bifunctor_leftcompax F) × (bifunctor_rightcompax F) × (functoronmorphisms_are_equal F). Lemma isaprop_is_bifunctor (F : bifunctor_data) : isaprop (is_bifunctor F). Proof. repeat (apply isapropdirprod) ; try (repeat (apply impred_isaprop ; intro) ; apply homset_property). Qed. Lemma bifunctor_distributes_over_id {F : bifunctor_data} (bli : bifunctor_leftidax F) (bri : bifunctor_rightidax F) (a : A) (b : B) : (identity a) ⊗^{F} (identity b) = identity (a ⊗_{F} b). Proof. unfold functoronmorphisms1. rewrite bri. rewrite bli. apply id_left. Qed. Lemma bifunctor_distributes_over_comp {F : bifunctor_data} (blc : bifunctor_leftcompax F) (brc : bifunctor_rightcompax F) (fmae : functoronmorphisms_are_equal F) {a1 a2 a3 : A} {b1 b2 b3 : B} (f1 : A⟦a1,a2⟧) (f2 : A⟦a2,a3⟧) (g1 : B⟦b1,b2⟧) (g2 : B⟦b2,b3⟧) : (f1 · f2) ⊗^{F} (g1 · g2) = (f1 ⊗^{F} g1) · (f2 ⊗^{F} g2). Proof. unfold functoronmorphisms1. rewrite brc. rewrite blc. rewrite assoc. rewrite assoc. apply cancel_postcomposition. rewrite assoc'. rewrite (whiskerscommutes _ fmae f2 g1). apply assoc. Qed. Definition bifunctor : UU := ∑ (F : bifunctor_data), is_bifunctor F. Definition make_bifunctor (F : bifunctor_data) (H : is_bifunctor F) : bifunctor := (F,,H). Definition bifunctordata_from_bifunctor (F : bifunctor) : bifunctor_data := pr1 F. Coercion bifunctordata_from_bifunctor : bifunctor >-> bifunctor_data. Definition isbifunctor_from_bifunctor (F : bifunctor) : is_bifunctor F := pr2 F. Definition bifunctor_leftid (F : bifunctor) : bifunctor_leftidax F := pr1 (isbifunctor_from_bifunctor F). Definition bifunctor_rightid (F : bifunctor) : bifunctor_rightidax F := pr1 (pr2 (isbifunctor_from_bifunctor F)). Definition bifunctor_leftcomp (F : bifunctor) : bifunctor_leftcompax F := pr1 (pr2 (pr2 ((isbifunctor_from_bifunctor F)))). Definition bifunctor_rightcomp (F : bifunctor) : bifunctor_rightcompax F := pr1 (pr2 (pr2 (pr2 (isbifunctor_from_bifunctor F)))). Definition bifunctor_equalwhiskers (F : bifunctor) : functoronmorphisms_are_equal F := pr2 (pr2 (pr2 (pr2 (isbifunctor_from_bifunctor F)))). Definition leftwhiskering_functor (F : bifunctor) (a : A) : functor B C := leftwhiskering_functor_pre F (bifunctor_leftid F) (bifunctor_leftcomp F) a. Definition rightwhiskering_functor (F : bifunctor) (b : B) : functor A C := rightwhiskering_functor_pre F (bifunctor_rightid F) (bifunctor_rightcomp F) b. Lemma when_bifunctor_becomes_leftwhiskering (F : bifunctor) (a : A) {b1 b2 : B} (g: B⟦b1, b2⟧): identity a ⊗^{ F } g = a ⊗^{F}_{l} g. Proof. unfold functoronmorphisms1. rewrite bifunctor_rightid. apply id_left. Qed. Lemma when_bifunctor_becomes_rightwhiskering (F : bifunctor) {a1 a2 : A} (b : B) (f: A⟦a1, a2⟧): f ⊗^{ F } identity b = f ⊗^{F}_{r} b. Proof. unfold functoronmorphisms1. rewrite bifunctor_leftid. apply id_right. Qed. Definition is_z_iso_bifunctor_z_iso (F : bifunctor) {a1 a2 : A} {b1 b2 : B} (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧) (f_is_z_iso : is_z_isomorphism f) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (f ⊗^{ F } g). Proof. use tpair. - exact (is_z_isomorphism_mor f_is_z_iso ⊗^{ F } is_z_isomorphism_mor g_is_z_iso). - split. + etrans. { apply pathsinv0, bifunctor_distributes_over_comp. - apply bifunctor_leftcomp. - apply bifunctor_rightcomp. - apply bifunctor_equalwhiskers. } unfold is_z_isomorphism_mor. rewrite (pr12 f_is_z_iso). rewrite (pr12 g_is_z_iso). apply bifunctor_distributes_over_id. * apply bifunctor_leftid. * apply bifunctor_rightid. + etrans. { apply pathsinv0, bifunctor_distributes_over_comp. - apply bifunctor_leftcomp. - apply bifunctor_rightcomp. - apply bifunctor_equalwhiskers. } unfold is_z_isomorphism_mor. rewrite (pr22 f_is_z_iso). rewrite (pr22 g_is_z_iso). apply bifunctor_distributes_over_id. * apply bifunctor_leftid. * apply bifunctor_rightid. Defined. Definition is_z_iso_leftwhiskering_z_iso (F : bifunctor) (a : A) {b1 b2 : B} (g : B⟦b1,b2⟧) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (a ⊗^{ F }_{l} g) := pr2 (functor_on_z_iso (leftwhiskering_functor F a) (g,,g_is_z_iso)). Definition is_z_iso_rightwhiskering_z_iso (F : bifunctor) {a1 a2 : A} (b : B) (f : A⟦a1,a2⟧) (f_is_z_iso : is_z_isomorphism f) : is_z_isomorphism (f ⊗^{ F }_{r} b) := pr2 (functor_on_z_iso (rightwhiskering_functor F b) (f,,f_is_z_iso)). End Bifunctor. Arguments bifunctor_data : clear implicits. Arguments bifunctor : clear implicits. Module BifunctorNotations. Notation "a ⊗_{ F } b" := (bifunctor_on_objects F a b) (at level 31). Notation "a ⊗^{ F }_{l} g" := (leftwhiskering_on_morphisms F a _ _ g) (at level 31). Notation "f ⊗^{ F }_{r} b" := (rightwhiskering_on_morphisms F b _ _ f) (at level 31). Notation "f ⊗^{ F } g" := (functoronmorphisms1 F f g) (at level 31). End BifunctorNotations. Section Bifunctors. Import BifunctorNotations. Lemma compose_bifunctor_with_functor_data {A B C D : category} (F : bifunctor A B C) (G : functor C D) : bifunctor_data A B D. Proof. use make_bifunctor_data. - intros a b. exact (G (a ⊗_{F} b)). - intros a b1 b2 g. exact (#G (a ⊗^{F}_{l} g)). - intros a b1 b2 f. exact (#G (f ⊗^{F}_{r} a)). Defined. Lemma composition_bifunctor_with_functor_isbifunctor {A B C D : category} (F : bifunctor A B C) (G : functor C D) : is_bifunctor (compose_bifunctor_with_functor_data F G). Proof. repeat split. - intros a b. cbn. rewrite bifunctor_leftid. exact (functor_id G (a ⊗_{F} b)). - intros a b. cbn. rewrite bifunctor_rightid. apply functor_id. - intros a b1 b2 b3 g1 g2. cbn. rewrite bifunctor_leftcomp. apply functor_comp. - intros b a1 a2 a3 f1 f2. cbn. rewrite bifunctor_rightcomp. apply functor_comp. - intros a1 a2 b1 b2 f g. unfold compose_bifunctor_with_functor_data. etrans. { apply pathsinv0, functor_comp. } rewrite whiskerscommutes. + apply functor_comp. + apply bifunctor_equalwhiskers. Qed. Definition compose_bifunctor_with_functor {A B C D : category} (F : bifunctor A B C) (G : functor C D) : bifunctor A B D := (compose_bifunctor_with_functor_data F G ,, composition_bifunctor_with_functor_isbifunctor F G). Lemma compose_functor_with_bifunctor_data {A B A' B' C : category} (F : functor A A') (G : functor B B') (H : bifunctor A' B' C) : bifunctor_data A B C. Proof. use make_bifunctor_data. - intros a b. exact ((F a) ⊗_{H} (G b)). - intros a b1 b2 g. exact ((F a) ⊗^{H}_{l} (#G g)). - intros b a1 a2 f. exact ((#F f) ⊗^{H}_{r} (G b)). Defined. Lemma composition_functor_with_bifunctor_isbifunctor {A B A' B' C : category} (F : functor A A') (G : functor B B') (H : bifunctor A' B' C) : is_bifunctor (compose_functor_with_bifunctor_data F G H). Proof. repeat split. - intros a b. cbn. rewrite functor_id. apply bifunctor_leftid. - intros a b. cbn. rewrite functor_id. apply bifunctor_rightid. - intros a b1 b2 b3 g1 g2. cbn. rewrite functor_comp. apply bifunctor_leftcomp. - intros b a1 a2 a3 f1 f2. cbn. rewrite functor_comp. apply bifunctor_rightcomp. - intros a1 a2 b1 b2 f g. apply (whiskerscommutes H (bifunctor_equalwhiskers H)). Qed. Definition compose_functor_with_bifunctor {A B A' B' C : category} (F : functor A A') (G : functor B B') (H : bifunctor A' B' C) : bifunctor A B C := (compose_functor_with_bifunctor_data F G H ,, composition_functor_with_bifunctor_isbifunctor F G H). End Bifunctors. Section WhiskeredBinaturaltransformation. Import BifunctorNotations. Context {A B C : category}. Definition binat_trans_data (F G : bifunctor_data A B C) : UU := ∏ (a : A) (b : B), C⟦a ⊗_{F} b, a ⊗_{G} b⟧. Definition make_binat_trans_data {F G : bifunctor_data A B C} (α : ∏ (a : A) (b : B), C⟦a ⊗_{F} b, a ⊗_{G} b⟧) : binat_trans_data F G := α. Definition is_binat_trans {F G : bifunctor_data A B C} (α : binat_trans_data F G) := (∏ (a : A) (b1 b2 : B) (g : B⟦b1,b2⟧), (a ⊗^{ F}_{l} g) · (α a b2) = (α a b1) · (a ⊗^{ G}_{l} g)) × (∏ (a1 a2 : A) (b : B) (f : A⟦a1,a2⟧), (f ⊗^{ F}_{r} b) · (α a2 b) = (α a1 b) · (f ⊗^{ G}_{r} b)). Lemma full_naturality_condition {F G : bifunctor_data A B C} {α : binat_trans_data F G} (αn : is_binat_trans α) {a1 a2 : A} {b1 b2 : B} (f : A⟦a1,a2⟧) (g : B⟦b1,b2⟧) : (f ⊗^{F} g)·(α a2 b2) = (α a1 b1)·(f ⊗^{G} g). Proof. unfold functoronmorphisms1. rewrite assoc'. rewrite (pr1 αn a2 _ _ g). rewrite assoc. rewrite (pr2 αn a1 a2 b1 f). apply assoc'. Qed. Definition binat_trans (F G : bifunctor_data A B C) : UU := ∑ (α : binat_trans_data F G), is_binat_trans α. Definition binattransdata_from_binattrans {F G : bifunctor_data A B C} (α : binat_trans F G) : binat_trans_data F G := pr1 α. (* Something like this is done in Core.NaturalTransformation, but I don't really know what this funclass is, I inserted this to use (α x y) without having to project, it would be good to have some explanation, also I don't understand why making a coercion for binattransdata_from_binattrans is not sufficient since I already have a identity coercion for binat_trans_data. *) Definition binattransdata_from_binattrans_funclass {F G : bifunctor_data A B C} (α : binat_trans F G) : ∏ (a : A) (b : B), C⟦a ⊗_{F} b, a ⊗_{G} b⟧ := pr1 α. Coercion binattransdata_from_binattrans_funclass : binat_trans >-> Funclass. Definition make_binat_trans {F G : bifunctor_data A B C} (α : binat_trans_data F G) (H : is_binat_trans α) : binat_trans F G := (α,,H). Definition is_binatiso {F G : bifunctor_data A B C} (α : binat_trans F G) := ∏ (a : A) (b : B), is_z_isomorphism (pr1 α a b). Definition inv_from_binatiso {F G : bifunctor_data A B C} {α : binat_trans F G} (isiso: is_binatiso α) : binat_trans_data G F := fun a b => pr1 (isiso a b). Lemma is_binat_trans_inv_from_binatiso {F G : bifunctor_data A B C} {α : binat_trans F G} (isiso: is_binatiso α) : is_binat_trans (inv_from_binatiso isiso). Proof. split. - intros ? ? ? ?. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (α a b1 ,, isiso a b1)). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (α a b2 ,, isiso a b2)). apply pathsinv0, (pr12 α). - intros ? ? ? ?. apply pathsinv0. apply (z_iso_inv_on_right _ _ _ (α a1 b ,, isiso a1 b)). rewrite assoc. apply (z_iso_inv_on_left _ _ _ _ (α a2 b ,, isiso a2 b)). apply pathsinv0, (pr22 α). Qed. Definition inv_binattrans_from_binatiso {F G : bifunctor_data A B C} {α : binat_trans F G} (isiso: is_binatiso α) : binat_trans G F := inv_from_binatiso isiso,, is_binat_trans_inv_from_binatiso isiso. End WhiskeredBinaturaltransformation. Section FunctorsFromProductCategory. Import BifunctorNotations. (* This notation comes from Precategorybinproduct. *) Local Notation "C × D" := (category_binproduct C D) (at level 75, right associativity). Definition bifunctor_to_functorfromproductcat_data {C D E : category} (F : bifunctor C D E) : functor_data (C × D) E. Proof. exists (λ cd, (pr1 cd) ⊗_{F} (pr2 cd)). exact (λ _ _ fg, (pr1 fg) ⊗^{F} (pr2 fg)). Defined. Definition bifunctor_to_functorfromproductcat_laws {C D E : category} (F : bifunctor C D E) : is_functor (bifunctor_to_functorfromproductcat_data F). Proof. split. - intro ; apply bifunctor_distributes_over_id. + exact (bifunctor_leftid F). + exact (bifunctor_rightid F). - intro ; intros ; apply bifunctor_distributes_over_comp. + exact (bifunctor_leftcomp F). + exact (bifunctor_rightcomp F). + exact (bifunctor_equalwhiskers F). Qed. Definition bifunctor_to_functorfromproductcat {C D E : category} (F : bifunctor C D E) : functor (C × D) E := bifunctor_to_functorfromproductcat_data F ,, bifunctor_to_functorfromproductcat_laws F. Definition bifunctor_from_functorfromproductcat_data {C D E : category} (F : functor (C × D) E) : bifunctor_data C D E. Proof. exists (λ c d, F (c,,d)). exists (λ c _ _ g, #F (catbinprodmor (identity c) g)). exact (λ d _ _ f, #F (catbinprodmor f (identity d))). Defined. Definition bifunctor_from_functorfromproductcat_laws {C D E : category} (F : functor (C × D) E) : is_bifunctor (bifunctor_from_functorfromproductcat_data F). Proof. repeat split. - exact (λ c d, functor_id F (c ,, d)). - exact (λ c d, functor_id F (d ,, c)). - intros c d1 d2 d3 g1 g2. refine (_ @ functor_comp F (catbinprodmor (identity c) g1) (catbinprodmor (identity c) g2)). cbn. etrans. { apply maponpaths. apply maponpaths_2. apply (! id_left _). } apply maponpaths. apply binprod_comp. - intros d c1 c2 c3 f1 f2. refine (_ @ functor_comp F (catbinprodmor f1 (identity d)) (catbinprodmor f2 (identity d))). cbn. etrans. { do 2 apply maponpaths. apply (! id_left _). } apply maponpaths. apply binprod_comp. - intro ; intros. unfold functoronmorphisms1. unfold functoronmorphisms2. cbn. etrans. { apply (! functor_comp _ _ _). } etrans. { apply maponpaths ; apply (binprod_comp). } etrans. 2: { apply functor_comp. } etrans. 2: { apply maponpaths ; apply binprod_comp. } apply maponpaths. etrans. { apply (! binprod_comp _ _ _ _ _ _ f (identity a2) (identity b1) g). } etrans. { apply maponpaths_2 ; apply id_right. } etrans. 2: { apply maponpaths_2 ; apply (! id_left _). } apply maponpaths. exact (id_left _ @ ! id_right _). Qed. Definition bifunctor_from_functorfromproductcat {C D E : category} (F : functor (C × D) E) : bifunctor C D E := bifunctor_from_functorfromproductcat_data F ,, bifunctor_from_functorfromproductcat_laws F. Lemma bifunctor_to_functor_to_bifunctor_data {C D E : category} (F : bifunctor C D E) : pr1 (bifunctor_from_functorfromproductcat (bifunctor_to_functorfromproductcat F)) = pr1 F. Proof. repeat (use total2_paths_f). - apply idpath. - repeat (apply funextsec ; intro). apply when_bifunctor_becomes_leftwhiskering. - repeat (apply funextsec ; intro). etrans. { rewrite transportf_const. apply when_bifunctor_becomes_rightwhiskering. } apply idpath. Qed. Lemma bifunctor_to_functor_to_bifunctor {C D E : category} (F : bifunctor C D E) : bifunctor_from_functorfromproductcat (bifunctor_to_functorfromproductcat F) = F. Proof. use total2_paths_f. { apply bifunctor_to_functor_to_bifunctor_data. } apply isaprop_is_bifunctor. Qed. Lemma functor_to_bifunctor_to_functor {C D E : category} (F : functor (C × D) E) : bifunctor_to_functorfromproductcat (bifunctor_from_functorfromproductcat F) = F. Proof. apply (functor_eq _ _ (homset_property _)). use total2_paths_f. - apply idpath. - etrans. { rewrite idpath_transportf. apply idpath. } repeat (apply funextsec ; intro). etrans. { apply (! functor_comp _ _ _). } apply maponpaths. etrans. { apply binprod_comp. } cbn. etrans. { apply maponpaths ; apply id_left. } etrans. { apply maponpaths_2 ; apply id_right. } apply idpath. Qed. Lemma bifunctor_equiv_functorfromproductcat (C D E : category) : bifunctor C D E ≃ functor (category_binproduct C D) E. Proof. use weq_iso. { apply bifunctor_to_functorfromproductcat. } { apply bifunctor_from_functorfromproductcat. } { intro ; apply bifunctor_to_functor_to_bifunctor. } intro ; apply functor_to_bifunctor_to_functor. Defined. End FunctorsFromProductCategory. Section FunctorsIntoEndofunctorCategory. Import BifunctorNotations. Definition bifunctor_to_functorintoendofunctorcat_data {C D E : category} (F : bifunctor C D E) : functor_data C [D,E]. Proof. use make_functor_data. - exact (λ c, leftwhiskering_functor F c). - intros c1 c2 f. exists (λ d, f ⊗^{F}_{r} d). abstract (exact (λ d1 d2 g, ! bifunctor_equalwhiskers F c1 c2 d1 d2 f g)). (** abstract needs [apply E] in [bifunctor_from_to] *) Defined. Lemma bifunctor_to_functorintoendofunctorcat_data_is_functor {C D E : category} (F : bifunctor C D E) : is_functor (bifunctor_to_functorintoendofunctorcat_data F). Proof. use tpair. + intro c. use nat_trans_eq. { apply homset_property. } intro ; apply bifunctor_rightid. + intros c1 c2 c3 f g. use nat_trans_eq. { apply homset_property. } intro ; apply bifunctor_rightcomp. Qed. Definition bifunctor_to_functorintoendofunctorcat {C D E : category} (F : bifunctor C D E) : functor C [D,E] := _,,bifunctor_to_functorintoendofunctorcat_data_is_functor F. Definition bifunctor_data_from_functorintoendofunctorcat {C D E : category} (F : functor C [D,E]) : bifunctor_data C D E. Proof. exists (λ c d, pr1 (F c) d). exists (λ c d1 d2 g, #(pr1 (F c)) g). exact (λ d c1 c2 f, pr1 (#F f) d). Defined. Definition bifunctor_data_from_functorintoendofunctorcat_is_bifunctor {C D E : category} (F : functor C [D,E]) : is_bifunctor (bifunctor_data_from_functorintoendofunctorcat F). Proof. repeat (use tpair). + intro ; intro ; apply functor_id. + abstract (exact (λ d c, eqtohomot (maponpaths pr1 (functor_id F c)) d)). + intro ; intros ; apply functor_comp. + abstract (intro ; intros; exact (eqtohomot (maponpaths pr1 (functor_comp F f1 f2)) b)). + abstract (intro ; intros; exact (! pr2 (#F f) b1 b2 g)). Defined. (** needs to be defined for [bifunctor_from_to] *) Definition bifunctor_from_functorintoendofunctorcat {C D E : category} (F : functor C [D,E]) : bifunctor C D E := _,,bifunctor_data_from_functorintoendofunctorcat_is_bifunctor F. Lemma bifunctor_to_from {C D E : category} (F : bifunctor C D E) : bifunctor_from_functorintoendofunctorcat (bifunctor_to_functorintoendofunctorcat F) = F. Proof. use total2_paths_f. 2: { apply isaprop_is_bifunctor. } apply idpath. Qed. Lemma bifunctor_from_to {C D E : category} (F : functor C [D,E]) : bifunctor_to_functorintoendofunctorcat (bifunctor_from_functorintoendofunctorcat F) = F. Proof. use functor_eq. { apply homset_property. } use total2_paths_f. { cbn. apply idpath. } cbn. repeat (apply funextsec ; intro). use total2_paths_f. { apply idpath. } repeat (apply funextsec ; intro). apply E. (* more precisely, it could be: apply pathsinv0inv0. *) Qed. Lemma bifunctor_equiv_functorintoendofunctorcat (C D E : category) : bifunctor C D E ≃ functor C [D,E]. Proof. use weq_iso. { apply bifunctor_to_functorintoendofunctorcat. } { apply bifunctor_from_functorintoendofunctorcat. } { intro ; apply bifunctor_to_from. } { intro ; apply bifunctor_from_to. } Defined. End FunctorsIntoEndofunctorCategory. Section DistributionOfBinaryCoproducts. Import BifunctorNotations. Context {A C D : category} (BCPC : BinCoproducts C) (BCPD : BinCoproducts D) (F : bifunctor A C D). Definition bifunctor_bincoprod_antidistributor (a : A) (c c' : C) := bincoprod_antidistributor BCPC BCPD (leftwhiskering_functor F a) c c'. Lemma bincoprod_antidistributor_nat_left (a : A) (cc'1 cc'2 : category_binproduct C C) (g : category_binproduct C C ⟦ cc'1, cc'2 ⟧) : bifunctor_bincoprod_antidistributor a (pr1 cc'1) (pr2 cc'1) · a ⊗^{F}_{l} #(bincoproduct_functor BCPC) g = #(bincoproduct_functor BCPD) (#(pair_functor (leftwhiskering_functor F a) (leftwhiskering_functor F a)) g) · bifunctor_bincoprod_antidistributor a (pr1 cc'2) (pr2 cc'2). Proof. apply bincoprod_antidistributor_nat. Qed. Lemma bincoprod_antidistributor_nat_right (a1 a2 : A) (cc' : category_binproduct C C) (f : A ⟦ a1, a2 ⟧) : bifunctor_bincoprod_antidistributor a1 (pr1 cc') (pr2 cc') · f ⊗^{F}_{r} bincoproduct_functor BCPC cc' = #(bincoproduct_functor BCPD) (catbinprodmor (f ⊗^{F}_{r} (pr1 cc')) (f ⊗^{F}_{r} (pr2 cc'))) · bifunctor_bincoprod_antidistributor a2 (pr1 cc') (pr2 cc'). Proof. etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } apply maponpaths_12. - etrans. { apply pathsinv0, bifunctor_equalwhiskers. } apply idpath. - etrans. { apply pathsinv0, bifunctor_equalwhiskers. } apply idpath. Qed. Definition bifunctor_bincoprod_distributor_data : UU := ∏ (a : A), bincoprod_distributor_data BCPC BCPD (leftwhiskering_functor F a). Identity Coercion bifunctor_bincoprod_distributor_data_funclass: bifunctor_bincoprod_distributor_data >-> Funclass. Definition bifunctor_bincoprod_distributor_iso_law (δ : bifunctor_bincoprod_distributor_data) : UU := ∏ (a : A), bincoprod_distributor_iso_law BCPC BCPD (leftwhiskering_functor F a) (δ a). Definition bifunctor_bincoprod_distributor : UU := ∑ δ : bifunctor_bincoprod_distributor_data, bifunctor_bincoprod_distributor_iso_law δ. Definition bifunctor_bincoprod_distributor_to_data (δ : bifunctor_bincoprod_distributor) : bifunctor_bincoprod_distributor_data := pr1 δ. Coercion bifunctor_bincoprod_distributor_to_data : bifunctor_bincoprod_distributor >-> bifunctor_bincoprod_distributor_data. End DistributionOfBinaryCoproducts. Section DistributionOfCoproducts. Import BifunctorNotations. Context {I : UU} {A C D : category} (CPC : Coproducts I C) (CPD : Coproducts I D) (F : bifunctor A C D). Definition bifunctor_coprod_antidistributor (a : A) (cs : power_category I C) := coprod_antidistributor CPC CPD (leftwhiskering_functor F a) cs. Lemma coprod_antidistributor_nat_left (a : A) (cs1 cs2 : power_category I C) (g : power_category I C ⟦ cs1, cs2 ⟧) : bifunctor_coprod_antidistributor a cs1 · a ⊗^{F}_{l} #(coproduct_functor I CPC) g = #(coproduct_functor I CPD) (#(family_functor I (fun _ => leftwhiskering_functor F a)) g) · bifunctor_coprod_antidistributor a cs2. Proof. etrans. { apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithCoproductArrow. } apply maponpaths. apply funextsec; intro i. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor F a)). } etrans. 2: { cbn. apply (functor_comp (leftwhiskering_functor F a)). } apply maponpaths. apply CoproductInCommutes. Qed. Lemma coprod_antidistributor_nat_right (a1 a2 : A) (cs : power_category I C) (f : A ⟦ a1, a2 ⟧) : bifunctor_coprod_antidistributor a1 cs · f ⊗^{F}_{r} coproduct_functor I CPC cs = #(coproduct_functor I CPD) (fun i => f ⊗^{F}_{r} (cs i)) · bifunctor_coprod_antidistributor a2 cs. Proof. etrans. { apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithCoproductArrow. } apply maponpaths; apply funextsec; intro i. etrans. { apply pathsinv0, bifunctor_equalwhiskers. } apply idpath. Qed. Definition bifunctor_coprod_distributor_data : UU := ∏ (a : A), coprod_distributor_data CPC CPD (leftwhiskering_functor F a). Identity Coercion bifunctor_coprod_distributor_data_funclass: bifunctor_coprod_distributor_data >-> Funclass. Definition bifunctor_coprod_distributor_iso_law (δ : bifunctor_coprod_distributor_data) : UU := ∏ (a : A), coprod_distributor_iso_law CPC CPD (leftwhiskering_functor F a) (δ a). Definition bifunctor_coprod_distributor : UU := ∑ δ : bifunctor_coprod_distributor_data, bifunctor_coprod_distributor_iso_law δ. Definition bifunctor_coprod_distributor_to_data (δ : bifunctor_coprod_distributor) : bifunctor_coprod_distributor_data := pr1 δ. Coercion bifunctor_coprod_distributor_to_data : bifunctor_coprod_distributor >-> bifunctor_coprod_distributor_data. End DistributionOfCoproducts. UniMath-20231010/UniMath/CategoryTheory/Morphisms.v000066400000000000000000000256041451125700300220030ustar00rootroot00000000000000(** * Some general constructions *) (** ** Contensts - Pair of morphisms - Short exact sequence data *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.Opp. (** * Pair of morphisms *) Section def_morphismpair. Context {C : precategory}. (** ** Morphism **) Definition Morphism : UU := ∑ (a b : C), a --> b. Definition make_Morphism {a b : C} (f : a --> b) : Morphism := (a,,(b,,f)). Definition Source (M : Morphism) : ob C := pr1 M. Definition Target (M : Morphism) : ob C := pr1 (pr2 M). Definition MorphismMor (M : Morphism) : C⟦Source M, Target M⟧ := pr2 (pr2 M). Coercion MorphismMor : Morphism >-> precategory_morphisms. (** ** MorphismPair **) Definition MorphismPair : UU := ∑ (a b c : C), (a --> b × b --> c). Definition make_MorphismPair {a b c : C} (f : a --> b) (g : b --> c) : MorphismPair. Proof. use tpair. - exact a. - use tpair. + exact b. + use tpair. * exact c. * use make_dirprod. -- exact f. -- exact g. Defined. (** Accessor function *) Definition Ob1 (MP : MorphismPair) : ob C := pr1 MP. Definition Ob2 (MP : MorphismPair) : ob C := pr1 (pr2 MP). Definition Ob3 (MP : MorphismPair) : ob C := pr1 (pr2 (pr2 MP)). Definition Mor1 (MP : MorphismPair) : C⟦Ob1 MP, Ob2 MP⟧ := dirprod_pr1 (pr2 (pr2 (pr2 MP))). Definition Mor2 (MP : MorphismPair) : C⟦Ob2 MP, Ob3 MP⟧ := dirprod_pr2 (pr2 (pr2 (pr2 MP))). (** Morphism of morphism pairs *) Definition MPMorMors (MP1 MP2 : MorphismPair) : UU := (Ob1 MP1 --> Ob1 MP2) × (Ob2 MP1 --> Ob2 MP2) × (Ob3 MP1 --> Ob3 MP2). Definition make_MPMorMors {MP1 MP2 : MorphismPair} (f1 : Ob1 MP1 --> Ob1 MP2) (f2 : Ob2 MP1 --> Ob2 MP2) (f3 : Ob3 MP1 --> Ob3 MP2) : MPMorMors MP1 MP2 := (f1,,(f2,,f3)). Definition MPMor1 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob1 MP1 --> Ob1 MP2 := dirprod_pr1 MPM. Definition MPMor2 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob2 MP1 --> Ob2 MP2 := dirprod_pr1 (dirprod_pr2 MPM). Definition MPMor3 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob3 MP1 --> Ob3 MP2 := dirprod_pr2 (dirprod_pr2 MPM). Definition MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : UU := (MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM) × (MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM). Definition make_MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) (H1 : MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM) (H2 : MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM) : MPMorComms MPM := (H1,,H2). Definition MPComm1 {MP1 MP2 : MorphismPair} {MPM : MPMorMors MP1 MP2} (MPMC : MPMorComms MPM) : MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM := dirprod_pr1 MPMC. Definition MPComm2 {MP1 MP2 : MorphismPair} {MPM : MPMorMors MP1 MP2} (MPMC : MPMorComms MPM) : MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM := dirprod_pr2 MPMC. Definition MPMor (MP1 MP2 : MorphismPair) : UU := ∑ MPM : MPMorMors MP1 MP2, MPMorComms MPM. Definition make_MPMor {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) (MPMC : MPMorComms MPM) : MPMor MP1 MP2 := (MPM,,MPMC). Definition MPMor_MPMorMors {MP1 MP2 : MorphismPair} (MPM : MPMor MP1 MP2) : MPMorMors MP1 MP2 := pr1 MPM. Coercion MPMor_MPMorMors : MPMor >-> MPMorMors. Definition MPMor_MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMor MP1 MP2) : MPMorComms MPM := pr2 MPM. Coercion MPMor_MPMorComms : MPMor >-> MPMorComms. Lemma reverseCommIsoSquare {M : precategory} {P Q P' Q':M} (f:P'-->P) (g:Q'-->Q) (i:z_iso P' Q') (j:z_iso P Q) : i · g = f · j -> z_iso_inv i · f = g · z_iso_inv j. Proof. intros l. refine (! id_right _ @ _). refine (maponpaths _ (! is_inverse_in_precat1 (z_iso_is_inverse_in_precat j)) @ _). refine (! assoc (z_iso_inv i) _ _ @ _). refine (maponpaths _ (assoc f _ _) @ _). refine (maponpaths (precomp_with (z_iso_inv i)) (maponpaths (postcomp_with (inv_from_z_iso j)) (!l)) @ _); unfold precomp_with, postcomp_with. refine (maponpaths _ (! assoc _ _ _) @ _). refine (assoc _ _ _ @ _). refine (maponpaths (postcomp_with (g · inv_from_z_iso j)) (is_inverse_in_precat2 (z_iso_is_inverse_in_precat i)) @ _); unfold postcomp_with. exact (id_left _). Qed. Lemma reverseCommIsoSquare' {M : precategory} {P Q P' Q':M} (f:P'-->P) (g:Q'-->Q) (i:z_iso P' Q') (j:z_iso P Q) : f · j = i · g -> g · z_iso_inv j = z_iso_inv i · f. Proof. intros l. refine (! _). apply reverseCommIsoSquare. refine (! _). exact l. Qed. Definition MorphismPairMap (P Q : MorphismPair) := ∑ (f : Ob1 P --> Ob1 Q) (g : Ob2 P --> Ob2 Q) (h : Ob3 P --> Ob3 Q), f · Mor1 Q = Mor1 P · g × g · Mor2 Q = Mor2 P · h. Definition Map1 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob1 P --> Ob1 Q := pr1 f. Definition Map2 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob2 P --> Ob2 Q := pr1 (pr2 f). Definition Map3 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob3 P --> Ob3 Q := pr1 (pr2 (pr2 f)). Definition MorphismPairIsomorphism (P Q : MorphismPair) := ∑ (f : z_iso (Ob1 P) (Ob1 Q)) (g : z_iso (Ob2 P) (Ob2 Q)) (h : z_iso (Ob3 P) (Ob3 Q)), ( f · Mor1 Q = Mor1 P · g × Mor1 P · g = f · Mor1 Q ) × ( g · Mor2 Q = Mor2 P · h × Mor2 P · h = g · Mor2 Q ). Definition InverseMorphismPairIsomorphism {P Q : MorphismPair} : MorphismPairIsomorphism P Q -> MorphismPairIsomorphism Q P. Proof. intros f. exists (z_iso_inv (pr1 f)). exists (z_iso_inv (pr12 f)). exists (z_iso_inv (pr122 f)). split. - split. + apply reverseCommIsoSquare. exact (pr11 (pr222 f)). + apply reverseCommIsoSquare'. exact (pr21 (pr222 f)). - split. + apply reverseCommIsoSquare. exact (pr12 (pr222 f)). + apply reverseCommIsoSquare'. exact (pr22 (pr222 f)). Defined. Definition make_MorphismPairIsomorphism (P Q : MorphismPair) (f : z_iso (Ob1 P) (Ob1 Q)) (g : z_iso (Ob2 P) (Ob2 Q)) (h : z_iso (Ob3 P) (Ob3 Q)) : f · Mor1 Q = Mor1 P · g -> g · Mor2 Q = Mor2 P · h -> MorphismPairIsomorphism P Q := λ r s, (f,,g,,h,,(r,,!r),,(s,,!s)). End def_morphismpair. Arguments MorphismPair : clear implicits. (** * MorphismPair and opposite categories *) Section MorphismPair_opp. Definition MorphismPair_opp {C : precategory} (MP : @MorphismPair C) : @MorphismPair (opp_precat C). Proof. use make_MorphismPair. - exact (Ob3 MP). - exact (Ob2 MP). - exact (Ob1 MP). - exact (Mor2 MP). - exact (Mor1 MP). Defined. Definition opp_MorphismPair {C : precategory} (MP : @MorphismPair (opp_precat C)) : @MorphismPair C. Proof. exact (MorphismPair_opp MP). Defined. Definition applyFunctorToPair {M N:precategory} : (M⟶N) -> @MorphismPair M -> @MorphismPair N := λ F P, make_MorphismPair (# F (Mor1 P)) (# F (Mor2 P)). Definition applyFunctorToPairIsomorphism {M N:precategory} (F : M⟶N) (P Q : @MorphismPair M) : MorphismPairIsomorphism P Q -> MorphismPairIsomorphism (applyFunctorToPair F P) (applyFunctorToPair F Q). Proof. intros [i1 [i2 [i3 [[d d'][e e']]]]]. exists (functor_on_z_iso F i1). exists (functor_on_z_iso F i2). exists (functor_on_z_iso F i3). repeat split. - refine (! _ @ (maponpaths (# F) d ) @ _);apply functor_comp. - refine (! _ @ (maponpaths (# F) d') @ _);apply functor_comp. - refine (! _ @ (maponpaths (# F) e ) @ _);apply functor_comp. - refine (! _ @ (maponpaths (# F) e') @ _);apply functor_comp. Defined. Definition opp_MorphismPairIsomorphism {M:precategory} {P Q: @MorphismPair M} : MorphismPairIsomorphism P Q -> MorphismPairIsomorphism (MorphismPair_opp Q) (MorphismPair_opp P) := λ f, opp_z_iso (pr122 f),, opp_z_iso (pr12 f),, opp_z_iso (pr1 f),, (pr22 (pr222 f),,pr12 (pr222 f)),, (pr21 (pr222 f),,pr11 (pr222 f)). End MorphismPair_opp. (** * ShortShortExactData *) Section def_shortshortexactdata. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. (** ** Data for [ShortShortExact] A pair of morphism such that composition of the morphisms is the zero morphism. *) Definition ShortShortExactData : UU := ∑ MP : MorphismPair C, Mor1 MP · Mor2 MP = ZeroArrow Z _ _. Definition make_ShortShortExactData (MP : MorphismPair C) (H : Mor1 MP · Mor2 MP = ZeroArrow Z _ _) : ShortShortExactData := tpair _ MP H. (** Accessor functions *) Definition ShortShortExactData_MorphismPair (SSED : ShortShortExactData) : MorphismPair C := pr1 SSED. Coercion ShortShortExactData_MorphismPair : ShortShortExactData >-> MorphismPair. Definition ShortShortExactData_Eq (SSED : ShortShortExactData) : (Mor1 SSED) · (Mor2 SSED) = ZeroArrow Z _ _ := pr2 SSED. End def_shortshortexactdata. Arguments make_ShortShortExactData [C] _ _ _. Arguments ShortShortExactData_Eq [C] _ _. (** * ShortShortExactData and opposite categories *) Section shortshortexactdata_opp. Lemma opp_ShortShortExactData_Eq {C : category} {Z : Zero C} (SSED : ShortShortExactData (op_category C) (Zero_opp C Z)) : Mor1 (opp_MorphismPair SSED) · Mor2 (opp_MorphismPair SSED) = ZeroArrow Z (Ob1 (opp_MorphismPair SSED)) (Ob3 (opp_MorphismPair SSED)). Proof. use (pathscomp0 (@ShortShortExactData_Eq (op_category C) (Zero_opp C Z) SSED)). rewrite <- ZeroArrow_opp. apply idpath. Qed. Definition opp_ShortShortExactData {C : category} {Z : Zero C} (SSED : ShortShortExactData (op_category C) (Zero_opp C Z)) : ShortShortExactData C Z. Proof. use make_ShortShortExactData. - exact (opp_MorphismPair SSED). - exact (opp_ShortShortExactData_Eq SSED). Defined. Lemma ShortShortExactData_opp_Eq {C : category} {Z : Zero C} (SSED : ShortShortExactData C Z) : Mor1 (MorphismPair_opp SSED) · Mor2 (MorphismPair_opp SSED) = ZeroArrow (Zero_opp C Z) (Ob1 (MorphismPair_opp SSED)) (Ob3 (MorphismPair_opp SSED)). Proof. use (pathscomp0 (@ShortShortExactData_Eq C Z SSED)). rewrite <- ZeroArrow_opp. apply idpath. Qed. Definition ShortShortExactData_opp {C : category} {Z : Zero C} (SSED : ShortShortExactData C Z) : ShortShortExactData (op_category C) (Zero_opp C Z). Proof. use make_ShortShortExactData. - exact (MorphismPair_opp SSED). - exact (ShortShortExactData_opp_Eq SSED). Defined. End shortshortexactdata_opp. UniMath-20231010/UniMath/CategoryTheory/NNO.v000066400000000000000000000024161451125700300204500ustar00rootroot00000000000000(** Definition natural number objects (NNO's) This is related to the initial algebra definition in FunctorAlgebras.v Written by: Anders Mörtberg, 2018 *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Section nno. Context {C : category} (TC : Terminal C). Local Notation "1" := TC. Definition isNNO (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧) : hProp. Proof. use tpair. - exact (∏ (a : C) (q : C ⟦ 1, a ⟧) (f : C ⟦ a, a ⟧), ∃! u : C ⟦ n, a ⟧, (z · u = q) × (s · u = u · f)). - abstract (repeat (apply impred_isaprop; intros); apply isapropiscontr). Defined. Definition NNO : UU := ∑ (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧), isNNO n z s. Definition NNObject (n : NNO) : C := pr1 n. Coercion NNObject : NNO >-> ob. Definition zeroNNO (n : NNO) : C ⟦1,n⟧ := pr1 (pr2 n). Definition sucNNO (n : NNO) : C ⟦n,n⟧ := pr1 (pr2 (pr2 n)). Lemma isNNO_NNO (n : NNO) : isNNO n (zeroNNO n) (sucNNO n). Proof. exact (pr2 (pr2 (pr2 n))). Qed. Definition make_NNO (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧) (h : isNNO n z s) : NNO := (n,,z,,s,,h). Definition hasNNO : hProp := ∥ NNO ∥. End nno. UniMath-20231010/UniMath/CategoryTheory/OppositeCategory/000077500000000000000000000000001451125700300231245ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/OppositeCategory/Core.v000066400000000000000000000011551451125700300242050ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Definition opp_cat (C : category) : category. Proof. exists (opp_precat C). apply has_homsets_op. Defined. Notation " C ^opp" := (opp_cat C) (at level 31). (* functor_opp is defined as a functor between precategories, so in order to avoid always explicit casting, the following is introduced: *) Definition functor_op {C D : category} (F : functor C D) : functor (opp_cat C) (opp_cat D) := functor_opp F. UniMath-20231010/UniMath/CategoryTheory/OppositeCategory/LimitsAsColimits.v000066400000000000000000000112261451125700300265460ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.limits.cones. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Cochains. Section ColimitsAsLimits. Definition graph_op (g : graph) : graph. Proof. exists (pr1 g). exact (λ v1 v2, pr2 g v2 v1). Defined. Definition edge_op {g : graph} {v w : pr1 g} (e : pr2 g v w) : pr2 (graph_op g) w v := e. Definition diagram_op {C : category} {g : graph} (d : diagram g C) : diagram (graph_op g) (opp_cat C). Proof. exists (λ v, pr1 d v). exact (λ v1 v2 e, pr2 d v2 v1 (edge_op e)). Defined. Definition cone_op {C : category} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) : cocone (diagram_op d) c. Proof. exists (λ v, pr1 cc v). exact (λ v w e, pr2 cc w v e). Defined. Definition cocone_op {C : category} {g : graph} {d : diagram g C} {c : C} (cc : cocone d c) : cone (diagram_op d) c. Proof. exists (λ v, pr1 cc v). exact (λ v w e, pr2 cc w v e). Defined. Definition iscolimcocone_op {C : category} {g : graph} {d : diagram g C} {c : C} {cc : cocone d c} (cc_lim : isColimCocone d c cc) : isLimCone (diagram_op d) c (cocone_op cc). Proof. intros c0 cc0. apply (cc_lim c0 (cone_op cc0)). Defined. Definition islimcone_op {C : category} {g : graph} {d : diagram g C} {c : C} {cc : cone d c} (cc_lim : isLimCone d c cc) : isColimCocone (diagram_op d) c (cone_op cc). Proof. intros c0 cc0. apply (cc_lim c0 (cocone_op cc0)). Defined. Definition LimCone_op {C : category} {g : graph} {d : diagram g C} (cc : LimCone d) : ColimCocone (diagram_op d). Proof. exists (pr1 (pr1 cc) ,, cone_op (pr2 (pr1 cc))). exact (islimcone_op (pr2 cc)). Defined. Definition chain_op {C : category} (ch : chain C) : cochain (opp_cat C). Proof. exists (λ v, pr1 ch v). exact (λ v w e, pr2 ch w v (edge_op e)). Defined. Definition cochain_op {C : category} (ch : cochain C) : chain (opp_cat C). Proof. exists (λ v, pr1 ch v). exact (λ v w e, pr2 ch w v (edge_op e)). Defined. Definition islimcone_chain_op {C : category} {g : chain C} {c : C} {cc : cone g c} (cc_lim : isLimCone g c cc) : isColimCocone (chain_op g) c (cone_op cc). Proof. apply (islimcone_op cc_lim). Defined. Definition islimcone_cochain_op {C : category} {g : cochain C} {c : C} {cc : cone g c} (cc_lim : isLimCone g c cc) : isColimCocone (cochain_op g) c (cone_op cc). Proof. apply (islimcone_op cc_lim). Defined. Definition iscolimcocone_chain_op {C : category} {g : chain C} {c : C} {cc : cocone g c} (cc_lim : isColimCocone g c cc) : isLimCone (chain_op g) c (cocone_op cc). Proof. apply (iscolimcocone_op cc_lim). Defined. Definition is_omega_cont_op {C D : category} {F : functor C D} (oc : is_omega_cont F) : is_omega_cocont (functor_op F). Proof. intros ch c cc. set (t := oc (chain_op ch) c (cocone_op cc)). intro col. set (tt := iscolimcocone_chain_op col). intros c0 cc0. apply (t tt c0 (cocone_op cc0)). Defined. Definition is_omega_cocont_op {C D : category} {F : functor C D} (oc : is_omega_cocont F) : is_omega_cont (functor_op F). Proof. intros ch c cc. set (t := oc (cochain_op ch) c (cone_op cc)). intro lm. set (tt := islimcone_cochain_op lm). intros c0 cc0. apply (t tt c0 (cone_op cc0)). Defined. Definition is_cont_op {C D : category} {F : functor C D} (oc : is_cont F) : is_cocont (functor_op F). Proof. intros g d c cc. set (t := oc _ _ c (cocone_op cc)). intro lm. set (tt := iscolimcocone_op lm). intros c0 cc0. apply (t tt c0 (cocone_op cc0)). Defined. Definition is_cocont_op {C D : category} {F : functor C D} (oc : is_cocont F) : is_cont (functor_op F). Proof. intros g d c cc. set (t := oc _ _ c (cone_op cc)). intro lm. set (tt := islimcone_op lm). intros c0 cc0. apply (t tt c0 (cone_op cc0)). Defined. End ColimitsAsLimits. UniMath-20231010/UniMath/CategoryTheory/OppositeCategory/OppositeAdjunction.v000066400000000000000000000040461451125700300271400ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Section OppositeAdjunction. Context {C D : category} {F : functor C D} {G : functor D C} (a : are_adjoints F G). Local Definition a_adjunction : adjunction C D := make_adjunction _ (pr2 a). Definition adjunction_data_opposite : adjunction_data (opp_cat D) (opp_cat C). Proof. refine (functor_op G ,, functor_op F ,, _ ,, _). - exists (λ d, counit_from_are_adjoints a d). exact (λ d1 d2 f, ! pr2 (counit_from_are_adjoints a) d2 d1 f). - exists (λ d, unit_from_are_adjoints a d). exact (λ d1 d2 f, ! pr2 (unit_from_are_adjoints a) d2 d1 f). Defined. Definition form_adjunction'_opposite : form_adjunction' adjunction_data_opposite. Proof. exists (λ d, triangle_2_statement_from_adjunction a_adjunction d). exact (λ c, triangle_1_statement_from_adjunction a_adjunction c). Qed. Definition adjunction_opposite : adjunction (opp_cat D) (opp_cat C). Proof. exists adjunction_data_opposite. exact form_adjunction'_opposite. Defined. Definition are_adjoints_opposite : are_adjoints (functor_op G) (functor_op F) := are_adjoints_from_adjunction adjunction_opposite. End OppositeAdjunction. Lemma is_right_adjoint_opposite {C D : category} (F : functor C D) : is_left_adjoint F -> is_right_adjoint (functor_op F). Proof. intro ila. set (adj := make_adjunction _ (pr22 ila)). exists (functor_op (pr121 adj)). exact (are_adjoints_opposite adj). Defined. Lemma is_right_adjoint_opposite' {C D : category} (F : functor C D) : is_left_adjoint (functor_op F) -> is_right_adjoint F. Proof. intro ila. apply (is_right_adjoint_opposite (functor_op F) ila). Defined. UniMath-20231010/UniMath/CategoryTheory/OppositeCategory/OppositeOfFunctorCategory.v000066400000000000000000000250271451125700300304470ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Section OppositeOfFunctorCatToFunctorCatOfOpposite. Context (C D : category). Definition opfunctorcat_to_functorcatofoppcats_data : functor_data ([C,D]^opp) ([C^opp,D^opp]). Proof. use make_functor_data. - intro F. use make_functor. + exists (λ c, (pr1 F) c). exact (λ c1 c2 f, #(pr1 F) f). + abstract (split ; intro ; intros ; cbn ; [ apply functor_id | apply functor_comp ]). - intros F G α. exists (λ c, pr1 α c). intros c1 c2 f. exact (! pr2 α c2 c1 f). Defined. Definition opfunctorcat_to_functorcatofoppcats_is_functor : is_functor opfunctorcat_to_functorcatofoppcats_data. Proof. split ; intro ; intros ; (apply nat_trans_eq ; [ apply homset_property | intro ; apply idpath ]). Qed. Definition opfunctorcat_to_functorcatofoppcats : functor ([C,D]^opp) ([C^opp,D^opp]) := opfunctorcat_to_functorcatofoppcats_data ,, opfunctorcat_to_functorcatofoppcats_is_functor. End OppositeOfFunctorCatToFunctorCatOfOpposite. Section OppositeOfFunctorCatFromFunctorCatOfOpposite. Context (C D : category). Definition opfunctorcat_from_functorcatofoppcats_data : functor_data ([C^opp,D^opp]) ([C,D]^opp). Proof. use make_functor_data. - intro F. use make_functor. + exists (λ c, (pr1 F) c). exact (λ c1 c2 f, #(pr1 F) f). + abstract (split ; intro ; intros ; cbn ; [ apply (functor_id F) | apply (functor_comp F) ]). - intros F G α. exists (λ c, pr1 α c). intros c1 c2 f. exact (! pr2 α c2 c1 f). Defined. Definition opfunctorcat_from_functorcatofoppcats_is_functor : is_functor opfunctorcat_from_functorcatofoppcats_data. Proof. split ; intro ; intros ; (apply nat_trans_eq ; [ apply homset_property | intro ; apply idpath ]). Qed. Definition opfunctorcat_from_functorcatofoppcats : functor ([C^opp,D^opp]) ([C,D]^opp) := opfunctorcat_from_functorcatofoppcats_data ,, opfunctorcat_from_functorcatofoppcats_is_functor. End OppositeOfFunctorCatFromFunctorCatOfOpposite. Section UnitCounit. Context (C D : category). Lemma counit_opfunctorcat_functorcatofoppcats : nat_trans (functor_composite (opfunctorcat_to_functorcatofoppcats C D) (opfunctorcat_from_functorcatofoppcats C D) ) (functor_identity ([C, D]^opp)). Proof. use make_nat_trans. - intro. use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; cbn ; apply (id_right _ @ ! id_left _)). - abstract ( intro ; intros ; use nat_trans_eq ; [ apply homset_property | intro ; simpl ; apply (id_left _ @ ! id_right _) ]). Defined. Lemma unit_opfunctorcat_functorcatofoppcats : nat_trans (functor_identity [C^opp , D^opp]) (functor_composite (opfunctorcat_from_functorcatofoppcats C D) (opfunctorcat_to_functorcatofoppcats C D) ). Proof. use make_nat_trans. - intro. use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; cbn ; apply (id_left _ @ ! id_right _)). - abstract ( intro ; intros ; use nat_trans_eq ; [ apply homset_property | intro ; simpl ; apply (id_left _ @ ! id_right _) ]). Defined. End UnitCounit. Section OppositeOfFunctorCatEquivFunctorCatOfOpposite. Context (C D : category). Definition opfunctorcat_adjdata_functorcatofoppcats : adjunction_data [C ^opp, D ^opp] ([C, D] ^opp). Proof. use make_adjunction_data. - exact (opfunctorcat_from_functorcatofoppcats C D). - exact (opfunctorcat_to_functorcatofoppcats C D). - exact (unit_opfunctorcat_functorcatofoppcats C D). - exact (counit_opfunctorcat_functorcatofoppcats C D). Defined. Lemma opfunctorcat_adjdata_functorcatofoppcats_form_adjunction : form_adjunction (opfunctorcat_from_functorcatofoppcats C D) (opfunctorcat_to_functorcatofoppcats C D) (unit_opfunctorcat_functorcatofoppcats C D) (counit_opfunctorcat_functorcatofoppcats C D). Proof. split. - intro. use nat_trans_eq. { apply homset_property. } intro ; apply id_left. - intro. use nat_trans_eq. { apply homset_property. } intro ; apply id_left. Qed. Definition is_left_adjoint_opfunctorcat_from_functorcatofoppcats : is_left_adjoint (opfunctorcat_from_functorcatofoppcats C D). Proof. exists (opfunctorcat_to_functorcatofoppcats C D). unfold are_adjoints. use tpair. - exists (unit_opfunctorcat_functorcatofoppcats C D). exact (counit_opfunctorcat_functorcatofoppcats C D). - exact opfunctorcat_adjdata_functorcatofoppcats_form_adjunction. Defined. Definition opfunctorcat_functorcatofoppcats_formequivalence : forms_equivalence opfunctorcat_adjdata_functorcatofoppcats. Proof. split. - intro. use make_is_z_isomorphism. + use make_nat_trans. * intro ; apply identity. * abstract (intro ; intros ; cbn ; apply (id_left _ @ ! id_right _)). + split ; (apply nat_trans_eq ; [ apply homset_property | intro ; apply id_right ]). - intro. use make_is_z_isomorphism. + use make_nat_trans. * intro ; apply identity. * abstract (intro ; intros ; cbn ; apply (id_right _ @ ! id_left _)). + split ; (apply nat_trans_eq ; [ apply homset_property | intro ; apply id_right ]). Defined. Definition opfunctorcat_equiv_functorcatofoppcats : equivalence_of_cats [C^opp,D^opp] ([C,D]^opp). Proof. use make_equivalence_of_cats. - exact opfunctorcat_adjdata_functorcatofoppcats. - exact opfunctorcat_functorcatofoppcats_formequivalence. Defined. Definition opfunctorcat_adjequiv_functorcatofoppcats : adj_equivalence_of_cats (opfunctorcat_from_functorcatofoppcats C D). Proof. exists is_left_adjoint_opfunctorcat_from_functorcatofoppcats. exact opfunctorcat_functorcatofoppcats_formequivalence. Defined. End OppositeOfFunctorCatEquivFunctorCatOfOpposite. Section PrecompositionFunctorOfOppositeFunctor. Context {A B : category} (C : category) (F : functor A B). (* In the following lemma we show that the following diagram commutes (up to a natural isomorphism): [B, C] ^opp ⟶ [A, C] ^opp | | | | [B^opp, C^opp] ⟶ [A^opp, C^opp] *) Definition functor_op_of_precomp_functor_factorizes_through_functorcatofopp_as_nat_trans : nat_trans (functor_op (pre_composition_functor A B C F)) (functor_composite (opfunctorcat_to_functorcatofoppcats B C) (functor_composite (pre_composition_functor _ _ _ (functor_op F)) (opfunctorcat_from_functorcatofoppcats A C)) ). Proof. use make_nat_trans. - intro. use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; apply (id_right _ @ ! id_left _)). - abstract (intro ; intros ; use nat_trans_eq ; [ apply homset_property | intro ; apply (id_left _ @ ! id_right _)]). Defined. Lemma functor_op_of_precomp_functor_factorizes_through_functorcatofopp_is_nat_z_iso : is_nat_z_iso functor_op_of_precomp_functor_factorizes_through_functorcatofopp_as_nat_trans. Proof. intro G. use make_is_z_isomorphism. - use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; apply (id_right _ @ ! id_left _)). - abstract (split ; (use nat_trans_eq ; [ apply homset_property | intro ; apply id_right ])). Defined. Definition functor_op_of_precomp_functor_factorizes_through_functorcatofopp_nat_z_iso : nat_z_iso (functor_op (pre_composition_functor A B C F)) (functor_composite (opfunctorcat_to_functorcatofoppcats B C) (functor_composite (pre_composition_functor _ _ _ (functor_op F)) (opfunctorcat_from_functorcatofoppcats A C)) ) := make_nat_z_iso _ _ _ (functor_op_of_precomp_functor_factorizes_through_functorcatofopp_is_nat_z_iso). End PrecompositionFunctorOfOppositeFunctor. Section PostcompositionFunctorOfOppositeFunctor. Context {B C : category} (A : category) (F : functor B C). Definition functor_op_of_postcomp_functor_factorizes_through_functorcatofopp_as_nat_trans : nat_trans (functor_op (post_composition_functor A B C F)) (functor_composite (opfunctorcat_to_functorcatofoppcats A B) (functor_composite (post_composition_functor _ _ _ (functor_op F)) (opfunctorcat_from_functorcatofoppcats A C)) ). Proof. use make_nat_trans. - intro. use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; apply (id_right _ @ ! id_left _)). - abstract (intro ; intros ; use nat_trans_eq ; [ apply homset_property | intro ; apply (id_left _ @ ! id_right _)]). Defined. Lemma functor_op_of_postcomp_functor_factorizes_through_functorcatofopp_is_nat_z_iso : is_nat_z_iso functor_op_of_postcomp_functor_factorizes_through_functorcatofopp_as_nat_trans. Proof. intro G. use make_is_z_isomorphism. - use make_nat_trans. + intro ; apply identity. + abstract (intro ; intros ; apply (id_right _ @ ! id_left _)). - abstract (split ; (use nat_trans_eq ; [ apply homset_property | intro ; apply id_right ])). Defined. Definition functor_op_of_postcomp_functor_factorizes_through_functorcatofopp_nat_z_iso : nat_z_iso (functor_op (post_composition_functor A B C F)) (functor_composite (opfunctorcat_to_functorcatofoppcats A B) (functor_composite (post_composition_functor _ _ _ (functor_op F)) (opfunctorcat_from_functorcatofoppcats A C)) ) := make_nat_z_iso _ _ _ (functor_op_of_postcomp_functor_factorizes_through_functorcatofopp_is_nat_z_iso). End PostcompositionFunctorOfOppositeFunctor. UniMath-20231010/UniMath/CategoryTheory/PointedFunctors.v000066400000000000000000000074401451125700300231460ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of category of pointed endofunctors - Forgetful functor to category of endofunctors ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Section def_ptd. Context (C : category). Definition ptd_obj : UU := ∑ F : functor C C, functor_identity C ⟹ F. Coercion functor_from_ptd_obj (F : ptd_obj) : functor C C := pr1 F. Definition ptd_pt (F : ptd_obj) : functor_identity C ⟹ F := pr2 F. Definition is_ptd_mor {F G : ptd_obj}(α: F ⟹ G) : UU := ∏ c : C, ptd_pt F c · α c = ptd_pt G c. Definition ptd_mor (F G : ptd_obj) : UU := ∑ α : F ⟹ G, is_ptd_mor α. Coercion nat_trans_from_ptd_mor {F G : ptd_obj} (a : ptd_mor F G) : nat_trans F G := pr1 a. Lemma eq_ptd_mor {F G : ptd_obj} (a b : ptd_mor F G) : a = b ≃ (a : F ⟹ G) = b. Proof. apply subtypeInjectivity. intro x. apply impred; intro. apply homset_property. Defined. Definition ptd_mor_commutes {F G : ptd_obj} (α : ptd_mor F G) : ∏ c : C, ptd_pt F c · α c = ptd_pt G c. Proof. exact (pr2 α). Qed. Definition ptd_id (F : ptd_obj) : ptd_mor F F. Proof. exists (nat_trans_id _ ). abstract ( intro c; apply id_right) . Defined. Definition ptd_comp {F F' F'' : ptd_obj} (α : ptd_mor F F') (α' : ptd_mor F' F'') : ptd_mor F F''. Proof. exists (nat_trans_comp _ _ _ α α'). abstract ( intro c; simpl; rewrite assoc ; set (H:=ptd_mor_commutes α c); simpl in H; rewrite H; clear H ; set (H:=ptd_mor_commutes α' c); simpl in H; rewrite H; clear H ; apply idpath ). Defined. Definition ptd_ob_mor : precategory_ob_mor. Proof. exists ptd_obj. exact ptd_mor. Defined. Definition ptd_precategory_data : precategory_data. Proof. exists ptd_ob_mor. exists ptd_id. exact @ptd_comp. Defined. Lemma is_precategory_ptd : is_precategory ptd_precategory_data. Proof. repeat split; simpl; intros. - apply (invmap (eq_ptd_mor _ _ )). apply (@id_left (functor_category C C)). - apply (invmap (eq_ptd_mor _ _ )). apply (@id_right (functor_category _ _)). - apply (invmap (eq_ptd_mor _ _ )). apply (@assoc (functor_category _ _)). - apply (invmap (eq_ptd_mor _ _ )). apply (@assoc' (functor_category _ _)). Qed. Definition precategory_Ptd : precategory := tpair _ _ is_precategory_ptd. Lemma has_homsets_precategory_Ptd: has_homsets precategory_Ptd. Proof. red. intros F G. red. intros a b. apply (isofhlevelweqb 1 (eq_ptd_mor a b)). apply (homset_property (functor_category C C)). Qed. Definition category_Ptd : category := precategory_Ptd ,, has_homsets_precategory_Ptd. Definition id_Ptd : category_Ptd. Proof. exists (functor_identity _). exact (nat_trans_id _ ). Defined. Lemma eq_ptd_mor_cat {F G : category_Ptd} (a b : F --> G) : a = b ≃ (a : ptd_mor F G) = b. Proof. use tpair. intro H. exact H. apply idisweq. Defined. (** Forgetful functor to functor category *) Definition ptd_forget_data : functor_data category_Ptd [C, C]. Proof. exists (λ a, pr1 a). exact (λ a b f, pr1 f). Defined. Lemma is_functor_ptd_forget : is_functor ptd_forget_data. Proof. split; intros; red; intros; apply idpath. Qed. Definition functor_ptd_forget : functor category_Ptd [C, C] := tpair _ _ is_functor_ptd_forget. End def_ptd. Arguments eq_ptd_mor { _ } _ { _ _ } . UniMath-20231010/UniMath/CategoryTheory/PointedFunctorsComposition.v000066400000000000000000000034271451125700300253730ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of composition of pointed functors ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.HorizontalComposition. Section def_ptd. Variable C : category. Definition ptd_composite (Z Z' : ptd_obj C) : category_Ptd C. Proof. exists (functor_composite Z Z'). apply (horcomp (ptd_pt _ Z) (ptd_pt _ Z')). Defined. Definition ptd_compose (Z Z' : ptd_obj C) : category_Ptd C. Proof. exists (functor_compose (pr1 Z:[C, C]) (pr1 Z':[C, C])). apply (# (functorial_composition _ _ _) (((ptd_pt _ Z: [C, C]⟦functor_identity C,pr1 Z⟧) ,, (ptd_pt _ Z': [C, C]⟦functor_identity C,pr1 Z'⟧)) : category_binproduct [C, C] [C, C] ⟦(functor_identity C,,functor_identity C),(pr1 Z,,pr1 Z')⟧)). Defined. Lemma ptd_composite_compose (Z Z' : ptd_obj C): ptd_composite Z Z' = ptd_compose Z Z'. Proof. use total2_paths_f. - apply idpath. - cbn. rewrite (@horcomp_post_pre _ _ C). apply (nat_trans_eq (homset_property C)). intro c. apply idpath. Qed. End def_ptd. UniMath-20231010/UniMath/CategoryTheory/PowerObject.v000066400000000000000000000264041451125700300222440ustar00rootroot00000000000000(** ** Following Saunders Mac Lane & Ieke Moerdijk Sheaves in Geometry and Logic - A First Introduction to Topos theory. Chapter IV.1 Contents : - The definition of [PowerObject]; - The derivation of [PowerObject] from [Exponentials]; - The definition of [PowerObject_functor]; - The derivation of [PowerObject_nat_z_iso], the natural (in a and b) (z-)isomorphism from Hom(b x a , Omega) to Hom(a,P b) (Omega is a subobject classifier) induced by the Power Object P; - The derivation of [PowerObject_charname_nat_z_iso], the natural (z-)isomorphism from Hom(- , Omega) to Hom(1,P(-)) obtained from the one above choosing a = T (T is the Terminal Object); *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.SubobjectClassifier. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. Section PowerObject_def. Context {C:category} {T:Terminal C} (Prod : BinProducts C) (O : subobject_classifier T). Local Notation "c 'x' d" := (BinProductObject C (Prod c d))(at level 5). Local Notation "f ⨱ g" := (BinProductOfArrows _ (Prod _ _) (Prod _ _) f g) (at level 10). Definition is_PowerObject (P : ob C -> ob C) (inmap : ∏ (b:C), C ⟦b x (P b), O⟧ ):= ∏ (a b:C) (f : C ⟦b x a, O⟧), ∃! g : C ⟦a, P b⟧, f = identity b ⨱ g·(inmap b). Definition PowerObject := ∑ (P : ob C -> ob C) (inmap : ∏ (b:C), C ⟦b x (P b), O⟧ ), is_PowerObject P inmap. Definition make_PowerObject (P : ob C -> ob C) (inmap : ∏ (b:C), C ⟦b x (P b), O⟧ ) (is : is_PowerObject P inmap) : PowerObject. Proof. use tpair. + exact P. + use tpair. - exact inmap. - exact is. Defined. End PowerObject_def. Section PowerObject_from_exponentials. Context {C:category} {T:Terminal C} (Prod : BinProducts C) (Ω : subobject_classifier T) (Exp : Exponentials Prod). Let ExpFun (c:C) := right_adjoint (Exp c). Let ExpEv (c:C) := counit_from_left_adjoint (Exp c). Let ExpUnit (c:C) := unit_from_left_adjoint (Exp c). Let ExpAdj (c:C) := pr2 (Exp c). Definition PowerObject_from_exponentials : PowerObject Prod Ω. Proof. use make_PowerObject. + intro b. exact (ExpFun b Ω). + intro b. use (ExpEv b). + (*This proof should be generalized to any adjunction, it would essentialy be the inverse result of [[right_adjoint_from_partial]]*) intros c b f. use make_iscontr. - split with (φ_adj (ExpAdj b) f). use pathsinv0. use (pathscomp0 (b:=(φ_adj_inv (ExpAdj b) (φ_adj (ExpAdj b) f)))). * apply idpath. * use φ_adj_inv_after_φ_adj. - intros (t,tis). use subtypePath. * intro. use homset_property. * use (invmaponpathsweq (invweq (adjunction_hom_weq (ExpAdj b) c Ω))). cbn. rewrite φ_adj_inv_after_φ_adj. use pathsinv0. use tis. Defined. End PowerObject_from_exponentials. Section ContextAndNotaions. Context {C:category} {T:Terminal C} {Prod : BinProducts C} {Ω : subobject_classifier T} (P: PowerObject Prod Ω). Local Notation "c ⨉ d" := (BinProductObject C (Prod c d))(at level 5). (*\bigtimes*) Local Notation "f ⨱ g" := (BinProductOfArrows _ (Prod _ _) (Prod _ _) f g) (at level 10). (*\timesbar*) Section PowerObject_accessor. Definition PowerObject_on_ob : C -> C := pr1 P. Definition PowerObject_inPred : ∏ a : C, C ⟦(a ⨉ (PowerObject_on_ob a)), Ω⟧ := pr1 (pr2 P). Definition PowerObject_property {a b : C} : ∏ f : C ⟦ b ⨉ a, Ω ⟧, ∃! g : C ⟦ a, PowerObject_on_ob b ⟧, f = (identity b) ⨱ g · PowerObject_inPred b := (pr2 (pr2 P)) a b. Definition PowerObject_transpose {a b : C} (f : C ⟦ b ⨉ a , Ω⟧) : C ⟦a , (PowerObject_on_ob b)⟧ := pr1 ( iscontrpr1 ((pr2 (pr2 P)) a b f)). Definition PowerObject_transpose_tri {a b : C} (f : C ⟦ b ⨉ a , Ω⟧) : f = (identity b) ⨱ (PowerObject_transpose f)· PowerObject_inPred b := pr2 (iscontrpr1 ((pr2 (pr2 P)) a b f)). End PowerObject_accessor. Section PowerObject_transpose_lemma. Proposition PowerObject_transpose_precomp {a' a b: C} (g : C ⟦a', a⟧)(f : C ⟦(b ⨉ a), Ω⟧ ) : PowerObject_transpose (identity b ⨱ g · f) = g · (PowerObject_transpose f). Proof. apply pathsinv0. use path_to_ctr. use pathsinv0. rewrite <-BinProductOfArrows_idxcomp. rewrite !assoc'. use cancel_precomposition. use pathsinv0. use (PowerObject_transpose_tri). Defined. End PowerObject_transpose_lemma. Section PowerObject_functor. Let construction {c b : C} (h : C ⟦b,c⟧):= h ⨱ (identity (PowerObject_on_ob c))·(PowerObject_inPred c). (* The PowerObject P induces a functor which maps object with PowerObject_on_ob and, given a morphism h, Ph is defined as the only morphism which makes the following diagram commute << h x id b x Pc --------> c x Pc | | id x Ph | | inPred c v v b x Pb --------> O inPred b >> construction produces the upper composition *) Definition PowerObject_functor_data : functor_data C^op C. Proof. use make_functor_data. - exact (PowerObject_on_ob). - intros c b h. use PowerObject_transpose. exact (construction h). Defined. Theorem PowerObject_functor_isfunctor : is_functor PowerObject_functor_data. Proof. split. + intro b. use pathsinv0. use path_to_ctr. apply idpath. + unfold functor_compax. intros c b a h h'. cbn in c, b, a, h, h'. cbn. use pathsinv0. use path_to_ctr. cbn. unfold construction. rewrite <-BinProductOfArrows_idxcomp, <-(BinProductOfArrows_compxid), assoc'. fold (construction h). rewrite (PowerObject_transpose_tri (construction h)), assoc. rewrite BinProductOfArrows_comp, (id_right h'), <-(id_left h'), (id_left (PowerObject_transpose _)), <-(id_right (PowerObject_transpose _)), <-BinProductOfArrows_comp, !assoc', id_left, id_right. fold (construction h'). rewrite (PowerObject_transpose_tri (construction h')), !assoc. rewrite <-(PowerObject_transpose_tri (construction h')), <-(PowerObject_transpose_tri (construction h)). apply idpath. Qed. Definition PowerObject_functor : functor C^op C. Proof. use make_functor. + exact PowerObject_functor_data. + exact PowerObject_functor_isfunctor. Defined. End PowerObject_functor. (* In this section we show the natural isomorphis from Hom ( -- x - , Ω) to Hom ( - , P(--) )*) Section PowerObject_nat_z_iso. (*The functor Hom ( -- x - , Ω)*) Definition HomxO : functor (category_binproduct C^op C^op) hset_category :=( binswap_pair_functor ∙ category_op_binproduct ∙ (functor_opp (binproduct_functor Prod)) ∙ (contra_homSet_functor Ω)). (*The functor Hom ( - , P(--) )*) Definition HomP : functor (category_binproduct C^op C^op) hset_category :=( pair_functor (functor_identity C^op) (PowerObject_functor) ∙ homSet_functor). Definition PowerObject_nt_data : nat_trans_data HomxO HomP. Proof. intro ab. exact PowerObject_transpose. Defined. Theorem PowerObject_nt_is_nat_trans : is_nat_trans HomxO HomP PowerObject_nt_data. Proof. intros (a,b) (a',b') (a'a,b'b). cbn in a'a, b'b. use funextfun. intro f. apply pathsinv0. use path_to_ctr. cbn. rewrite id_right. rewrite <-BinProductOfArrows_idxcomp, !assoc'. rewrite <-(PowerObject_transpose_tri). rewrite !assoc, BinProductOfArrows_comp, id_left, id_right. rewrite (PowerObject_transpose_tri f), assoc, BinProductOfArrows_comp, id_right, <-(PowerObject_transpose_tri f). cbn. apply idpath. Qed. Definition PowerObject_nattrans : nat_trans HomxO HomP. Proof. use make_nat_trans. + exact PowerObject_nt_data. + exact PowerObject_nt_is_nat_trans. Defined. Theorem PowerObject_nt_is_nat_z_iso : is_nat_z_iso PowerObject_nattrans. Proof. intros (a,b). cbn. use make_is_z_isomorphism. + intro g. exact ((identity b) ⨱ g · (PowerObject_inPred b)). + cbn. use make_is_inverse_in_precat. - use funextfun. intros f. cbn. use pathsinv0. use PowerObject_transpose_tri. - use funextfun. intros g. use pathsinv0. use path_to_ctr. apply idpath. Defined. Definition PowerObject_nat_z_iso : nat_z_iso HomxO HomP. Proof. use make_nat_z_iso. + exact PowerObject_nattrans. + exact PowerObject_nt_is_nat_z_iso. Defined. (*in particolar, fixing (-) = T, we also get a natural isomorphism from from Hom(-,Ω) to Hom(T,P(-))*) (*The natural transformation from (-)xT to (-) , with T the constant (terminal) functor*) Definition idxT_nattrans := binproduct_nat_trans_pr1 C C Prod (functor_identity C) (constant_functor C C T). Theorem idxT_is_nat_z_iso : is_nat_z_iso idxT_nattrans. Proof. intro c. use (terminal_binprod_unit_r_z T Prod). Defined. Definition idxT_nat_z_iso := (make_nat_z_iso _ _ (idxT_nattrans) (idxT_is_nat_z_iso)). (*The natural transformation from (-)^op to ((-)xT)^op*) Definition idxT_nat_inopp := op_nt idxT_nat_z_iso. (*The natural transformation from Hom(-,Ω) to Hom( ((-)xT) , O ) *) Definition idxT_whiskered_nat := post_whisker (idxT_nat_inopp) (contra_homSet_functor Ω). (*The natural iso from Hom( - x T , Ω ) to Hom( T , P(-) ), with T terminal object*) Definition PowerObject_nat_z_iso_Tfixed := nat_z_iso_fix_fst_arg C^op C^op hset_category _ _ PowerObject_nat_z_iso T. (*composition yelds the nt from Hom(-,Ω) to Hom( T , P(-) )*) Definition PowerObject_charname_nattrans := nat_trans_comp _ _ _ idxT_whiskered_nat PowerObject_nat_z_iso_Tfixed. Definition PowerObject_charname_is_nat_z_iso : is_nat_z_iso PowerObject_charname_nattrans. Proof. intro c. use is_z_iso_comp_of_is_z_isos. + generalize c. use post_whisker_z_iso_is_z_iso. use op_nt_is_z_iso. use pr2_nat_z_iso. + generalize c. use (pr2_nat_z_iso PowerObject_nat_z_iso_Tfixed). Defined. Definition PowerObject_charname_nat_z_iso : nat_z_iso (contra_homSet_functor Ω) (functor_fix_fst_arg C^op C^op hset_category HomP T). Proof. use make_nat_z_iso. + exact PowerObject_charname_nattrans. + exact PowerObject_charname_is_nat_z_iso. Defined. Definition PowerObject_charname_nat_z_iso_tri {b : C} (f : C ⟦ b , Ω ⟧) : (identity b) ⨱ (PowerObject_charname_nat_z_iso b f)· PowerObject_inPred b = (BinProductPr1 C (Prod b T) · f). Proof. rewrite (PowerObject_transpose_tri). cbn. rewrite id_right. apply idpath. Defined. End PowerObject_nat_z_iso. End ContextAndNotaions. UniMath-20231010/UniMath/CategoryTheory/PreAdditive.v000066400000000000000000001301141451125700300222130ustar00rootroot00000000000000(** * Definition of preadditive categories. *) (** ** Contents - Definition of preadditive categories [PreAdditive] - Zero and unit element coincide - Composition and inverses - KernelIn, CokernelOut, and binary operations - Quotient of PreAdditive *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Import AddNotation. Local Open Scope addmonoid_scope. (** * Definition of a PreAdditive precategory A preadditive precategory is a precategory such that the sets of morphisms are abelian groups and pre- and postcomposing with a morphisms is a monoidfun of the abelian groups. *) Section def_preadditive. (** In preadditive category precomposition and postcomposition for any morphism yields a morphism of abelian groups. Classically one says that composition is bilinear with respect to the abelian groups? *) Definition isPreAdditive (PA : categoryWithAbgrops) : UU := (∏ (x y z : PA) (f : x --> y), ismonoidfun (to_premor z f)) × (∏ (x y z : PA) (f : y --> z), ismonoidfun (to_postmor x f)). Definition make_isPreAdditive (PA : categoryWithAbgrops) (H1 : ∏ (x y z : PA) (f : x --> y), ismonoidfun (to_premor z f)) (H2 : ∏ (x y z : PA) (f : y --> z), ismonoidfun (to_postmor x f)) : isPreAdditive PA. Proof. exact (H1,,H2). Defined. Definition make_isPreAdditive' (PA : categoryWithAbgrops) (H1 : ∏ (x y z : PA) (f : x --> y) (g h : y --> z), f · (to_binop _ _ g h) = to_binop _ _ (f · g) (f · h)) (H1' : ∏ (x y z : PA) (f : x --> y), to_premor z f (to_unel y z) = to_unel x z) (H2 : ∏ (x y z : PA) (f : y --> z) (g h : x --> y), (to_binop _ _ g h) · f = to_binop _ _ (g · f) (h · f)) (H2' : ∏ (x y z : PA) (f : y --> z), to_premor z (to_unel x y) f = to_unel x z): isPreAdditive PA. Proof. use make_isPreAdditive. - intros x y z f. use tpair. + intros g h. exact (H1 x y z f g h). + exact (H1' x y z f). - intros x y z f. use tpair. + intros g h. exact (H2 x y z f g h). + exact (H2' x y z f). Qed. Definition to_premor_monoid {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) : ∏ (x y z : PWA) (f : x --> y), ismonoidfun (to_premor z f) := dirprod_pr1 iPA. Definition to_postmor_monoid {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) : ∏ (x y z : PWA) (f : y --> z), ismonoidfun (to_postmor x f) := dirprod_pr2 iPA. Definition to_premor_monoidfun {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) (x y z : PWA) (f : x --> y) : monoidfun (to_abgr y z) (to_abgr x z) := monoidfunconstr (to_premor_monoid iPA x y z f). Definition to_postmor_monoidfun {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) (x y z : PWA) (f : y --> z) : monoidfun (to_abgr x y) (to_abgr x z) := monoidfunconstr (to_postmor_monoid iPA x y z f). (** Definition of preadditive categories *) Definition PreAdditive : UU := ∑ PA : categoryWithAbgrops, isPreAdditive PA. Definition PreAdditive_categoryWithAbgrops (A : PreAdditive) : categoryWithAbgrops := pr1 A. Coercion PreAdditive_categoryWithAbgrops : PreAdditive >-> categoryWithAbgrops. Definition make_PreAdditive (PA : categoryWithAbgrops) (H : isPreAdditive PA) : PreAdditive. Proof. exact (tpair _ PA H). Defined. Definition PreAdditive_isPreAdditive (A : PreAdditive) : isPreAdditive A := pr2 A. Coercion PreAdditive_isPreAdditive : PreAdditive >-> isPreAdditive. Variable A : PreAdditive. (** The following give that premor and postmor are linear. *) Definition to_premor_linear {x y : A} (z : A) (f : x --> y) : isbinopfun (to_premor z f) := dirprod_pr1 (to_premor_monoid A x y z f). Definition to_postmor_linear (x : A) {y z : A} (f : y --> z) : isbinopfun (to_postmor x f) := dirprod_pr1 (to_postmor_monoid A x y z f). (** Following versions are useful when one wants to rewrite equations *) Lemma to_premor_linear' {x y z : A} (f : x --> y) (g h : y --> z) : f · (to_binop y z g h) = to_binop x z (f · g) (f · h). Proof. apply to_premor_linear. Qed. Lemma to_postmor_linear' {x y z : A} (g h : x --> y) (f : y --> z) : (to_binop x y g h) · f = to_binop x z (g · f) (h · f). Proof. apply to_postmor_linear. Qed. (** The following says that composing with zero object yields a zero object. *) Definition to_premor_unel {x y : A} (z : A) (f : x --> y) : to_premor z f 1%multmonoid = 1%multmonoid := dirprod_pr2 (to_premor_monoid A x y z f). Definition to_postmor_unel (x : A) {y z : A} (f : y --> z) : to_postmor x f 1%multmonoid = 1%multmonoid := dirprod_pr2 (to_postmor_monoid A x y z f). (** Following versions are useful when one wants to rewrite equations *) Lemma to_premor_unel' {x y : A} (z : A) (f : x --> y) : f · (to_unel y z) = to_unel x z. Proof. apply to_premor_unel. Qed. Lemma to_postmor_unel' (x : A) {y z : A} (f : y --> z) : (to_unel x y) · f = to_unel x z. Proof. apply to_postmor_unel. Qed. End def_preadditive. Arguments to_premor_linear [A] [x] [y] _ _ _ _. Arguments to_postmor_linear [A] _ [y] [z] _ _ _. Arguments to_premor_linear' [A] [x] [y] [z] _ _ _. Arguments to_postmor_linear' [A] [x] [y] [z] _ _ _. (** * Zero and unit In the following section we prove that if a preadditive category has a zero object, then in a homset the unit element is given by the zero arrow *) Section preadditive_with_zero. Variable A : PreAdditive. (** Proof that the zero arrow and the unit element coincide *) Lemma PreAdditive_unel_zero (Z : Zero A) (x y : A) : to_unel x y = ZeroArrow Z x y. Proof. unfold ZeroArrow. rewrite <- (id_left (ZeroArrowFrom y)). assert (X : identity Z = to_unel Z Z). { apply ZeroEndo_is_identity. } rewrite -> X. clear X. set (Y := to_postmor_unel A Z (@ZeroArrowFrom A Z y)). unfold to_postmor in Y. unfold to_unel. rewrite Y. clear Y. set (Y' := to_premor_unel A y (@ZeroArrowTo A Z x)). unfold to_premor in Y'. rewrite Y'. clear Y'. apply idpath. Qed. Lemma to_lunax'' {Z : Zero A} (x y : A) (f : x --> y) : to_binop x y (ZeroArrow Z x y) f = f. Proof. rewrite <- to_lunax'. apply maponpaths_2, pathsinv0, PreAdditive_unel_zero. Qed. Lemma to_runax'' {Z : Zero A} (x y : A) (f : x --> y) : to_binop x y f (ZeroArrow Z x y) = f. Proof. rewrite <- to_runax'. apply maponpaths, pathsinv0, PreAdditive_unel_zero. Qed. Lemma to_linvax' {Z : Zero A} {x y : A} (f : A⟦x, y⟧) : to_binop x y (to_inv f) f = ZeroArrow Z x y. Proof. rewrite linvax. apply PreAdditive_unel_zero. Qed. Lemma to_rinvax' {Z : Zero A} {x y : A} (f : A⟦x, y⟧) : to_binop x y f (to_inv f) = ZeroArrow Z x y. Proof. rewrite rinvax. apply PreAdditive_unel_zero. Qed. Lemma to_inv_zero {Z : Zero A} {x y : A} : to_inv (ZeroArrow Z x y) = ZeroArrow Z x y. Proof. rewrite <- PreAdditive_unel_zero. apply to_inv_unel. Qed. End preadditive_with_zero. (** * Inverses and composition Some equations on inverses in PreAdditive categories *) Section preadditive_inv_comp. Variable A : PreAdditive. Lemma PreAdditive_invlcomp {x y z : A} (f : A⟦x, y⟧) (g : A⟦y, z⟧) : (to_inv (f · g)) = (to_inv f) · g. Proof. use (grrcan (to_abgr x z) (f · g)). unfold to_inv at 1. rewrite grlinvax. use (pathscomp0 _ (to_postmor_linear' (to_inv f) f g)). rewrite linvax. rewrite to_postmor_unel'. unfold to_unel. apply idpath. Qed. Lemma PreAdditive_invrcomp {x y z : A} (f : A⟦x, y⟧) (g : A⟦y, z⟧) : (to_inv (f · g)) = f · (to_inv g). Proof. use (grrcan (to_abgr x z) (f · g)). unfold to_inv at 1. rewrite grlinvax. use (pathscomp0 _ (to_premor_linear' f (to_inv g) g)). rewrite linvax. rewrite to_premor_unel'. unfold to_unel. apply idpath. Qed. Lemma PreAdditive_cancel_inv {x y : A} (f g : A⟦x, y⟧) (H : (to_inv f) = (to_inv g)) : f = g. Proof. apply (grinvmaponpathsinv (to_abgr x y) H). Qed. End preadditive_inv_comp. (** * KernelIn, CokernelOut, and Binary Operations *) (** ** Introduction In this section we show that binop commutes with KernelIn and CokernelOut in a PreAdditive category. [KernelInOp] proves commutativity for KernelIn and [CokernelOutOp] proves commutativity for CokernelOut. *) Section def_additive_kernel_cokernel. Variable A : PreAdditive. Variable Z : Zero A. Local Lemma KernelInOp_Eq {x y z : A} (f1 f2 : A⟦x, y⟧) (g : A⟦y, z⟧) (H1 : f1 · g = ZeroArrow Z _ _) (H2 : f2 · g = ZeroArrow Z _ _) : (to_binop _ _ f1 f2 · g = ZeroArrow Z _ _). Proof. rewrite to_postmor_linear'. rewrite H1. rewrite H2. rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. apply idpath. Qed. Lemma KernelInOp {x y z : A} (f1 f2 : A⟦x, y⟧) (g : A⟦y, z⟧) (K : Kernel Z g) (H1 : f1 · g = ZeroArrow Z _ _) (H2 : f2 · g = ZeroArrow Z _ _) : KernelIn Z K _ (to_binop _ _ f1 f2) (KernelInOp_Eq f1 f2 g H1 H2) = to_binop _ _ (KernelIn Z K _ f1 H1) (KernelIn Z K _ f2 H2). Proof. use KernelInsEq. rewrite KernelCommutes. rewrite (to_postmor_linear' (A:=A)). rewrite KernelCommutes. rewrite KernelCommutes. apply idpath. Qed. Local Lemma CokernelOutOp_Eq {x y z : A} (f1 f2 : A⟦y, z⟧) (g : A⟦x, y⟧) (H1 : g · f1 = ZeroArrow Z _ _) (H2 : g · f2 = ZeroArrow Z _ _) : g · (to_binop _ _ f1 f2) = ZeroArrow Z _ _. Proof. rewrite to_premor_linear'. rewrite H1. rewrite H2. rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. apply idpath. Qed. Lemma CokernelOutOp {x y z : A} (f1 f2 : A⟦y, z⟧) (g : A⟦x, y⟧) (CK : Cokernel Z g) (H1 : g · f1 = ZeroArrow Z _ _) (H2 : g · f2 = ZeroArrow Z _ _) : CokernelOut Z CK _ (to_binop _ _ f1 f2) (CokernelOutOp_Eq f1 f2 g H1 H2) = to_binop _ _ (CokernelOut Z CK _ f1 H1) (CokernelOut Z CK _ f2 H2). Proof. use CokernelOutsEq. rewrite CokernelCommutes. rewrite to_premor_linear'. rewrite CokernelCommutes. rewrite CokernelCommutes. apply idpath. Qed. End def_additive_kernel_cokernel. Section monics_and_epis_in_preadditive. Variable PA : PreAdditive. Lemma to_inv_isMonic {x y : PA} (f : x --> y) (isM : isMonic f) : isMonic (to_inv f). Proof. use make_isMonic. intros x0 g h X. rewrite <- (PreAdditive_invrcomp PA) in X. rewrite <- (PreAdditive_invrcomp PA) in X. apply cancel_inv in X. use isM. exact X. Qed. Lemma to_inv_isEpi {x y : PA} (f : x --> y) (isE : isEpi f) : isEpi (to_inv f). Proof. use make_isEpi. intros x0 g h X. rewrite <- PreAdditive_invlcomp in X. rewrite <- PreAdditive_invlcomp in X. apply cancel_inv in X. use isE. exact X. Qed. End monics_and_epis_in_preadditive. (** * Quotient of homsets Suppose you have a subgroup for each set of morphisms such that pre- and postcompositions map morphisms in a subgroup to another subgroup. Then one can form a new Preadditive category by taking the same objects and morphisms as elements of the quotient groups. We call this [PreAdditiveQuot]. An example of this construction is when one wants to form the naive homotopy category from a category of complexes. *) Section preadditive_quotient. Variable PA : PreAdditive. Local Opaque ishinh. (** For every set morphisms we have a subgroup. *) Definition PreAdditiveSubabgrs : UU := ∏ (x y : ob PA), @subabgr (to_abgr x y). Hypothesis PAS : PreAdditiveSubabgrs. (** Pre- and postcomposing with an element in the subgroups gives an element of a subgroup. This is important since we want pre- and postcomposition with unit element to be the unit element in the new precategory. *) Definition PreAdditiveComps : UU := ∏ (x y : ob PA), (∏ (z : ob PA) (f : x --> y) (inf : pr1submonoid (@to_abgr PA x y) (PAS x y) f) (g : y --> z), pr1submonoid (@to_abgr PA x z) (PAS x z) (f · g)) × (∏ (z : ob PA) (f : x --> y) (g : y --> z) (ing : pr1submonoid (@to_abgr PA y z) (PAS y z) g), pr1submonoid (@to_abgr PA x z) (PAS x z) (f · g)). Hypothesis PAC : PreAdditiveComps. (** ** Here are some random results copied from category_abgr.v. Theses should be deleted, removed, renamed, generalized, or ...*) (** The hProp which tells if two elements of A belong to the same equivalence class in A/B *) Definition subgrhrel_hprop {A : gr} (B : @subgr A) (a1 a2 : A) : hProp := hexists (λ b : B, pr1 b = (a1 * grinv A a2)%multmonoid). (** Construct a relation using the above hProp *) Definition subgrhrel {A : gr} (B : @subgr A) : @hrel A := (λ a1 : A, λ a2 : A, (subgrhrel_hprop B a1 a2)). (** Let B be a subgroup of A. Then the canonical map A -> A/B is a monoidfun. *) Local Lemma abgrquotpr_ismonoidfun {A : abgr} (H : @binopeqrel A) : @ismonoidfun A (abgrquot H) (λ a : A, setquotpr H a). Proof. split. - split. - apply idpath. Qed. Local Lemma funeqpaths {X Y : UU} {f g : X -> Y} (e : f = g) : ∏ (x : X), f x = g x. Proof. induction e. intros x. apply idpath. Qed. Local Definition abgrquotpr_monoidfun {A : abgr} (H : @binopeqrel A) : monoidfun A (abgrquot H) := monoidfunconstr (abgrquotpr_ismonoidfun H). Local Lemma monoidfun_inv {A B : abgr} (f : monoidfun A B) (a : A) : f (grinv A a) = grinv B (f a). Proof. apply (grlcan B (f a)). rewrite (grrinvax B). use (pathscomp0 (pathsinv0 (((pr1 (pr2 f)) a (grinv A a))))). rewrite (grrinvax A). apply (pr2 (pr2 f)). Qed. (** The relation we defined is an equivalence relation *) Lemma iseqrel_subgrhrel (A : gr) (B : @subgr A) : iseqrel (subgrhrel B). Proof. unfold subgrhrel. unfold subgrhrel_hprop. use iseqrelconstr. (* istrans *) - intros x1 x2 x3 y1 y2. cbn in *. unfold ishinh_UU in *. use (squash_to_prop y1 (propproperty _)). intros Y1. clear y1. use (squash_to_prop y2 (propproperty _)). intros Y2. clear y2. use hinhpr. induction Y1 as [t p]. induction Y2 as [t0 p0]. use tpair. + use tpair. * exact (op (pr1 t) (pr1 t0)). * exact (pr2subsetswithbinop B t t0). + cbn. rewrite p. rewrite p0. rewrite <- (assocax A). apply maponpaths_2. rewrite assocax. rewrite grlinvax. rewrite runax. apply idpath. (* isrefl *) - intros x. use hinhpr. use tpair. + exact (unel B). + cbn. apply pathsinv0. apply (grrinvax A). (* issymm *) - intros x y. cbn. unfold ishinh_UU. intros H. use (squash_to_prop H (propproperty _)). intros H'. clear H. use hinhpr. induction H' as [t p]. use tpair. + exact (grinv B t). + cbn. rewrite p. clear p. rewrite grinvop. rewrite grinvinv. apply idpath. Qed. (** The relation we defined respects binary operations. Note that we use commax, thus the proof does not work for nonabelian groups. *) Lemma isbinopeqrel_subgr_eqrel {A : abgr} (B : @subabgr A) : isbinophrel (make_eqrel (subgrhrel B) (iseqrel_subgrhrel A B)). Proof. use isbinophrelif. - apply (pr2 (pr2 A)). - intros a b c X. cbn in *. unfold ishinh_UU in *. use (squash_to_prop X (propproperty _)). intros X''. use hinhpr. use tpair. + exact (pr1 X''). + cbn. set (tmp := pr2 X''). cbn in tmp. rewrite tmp. clear tmp. clear X''. rewrite grinvop. rewrite (commax A c). rewrite (assocax A). rewrite (commax A c). rewrite (assocax A). rewrite grlinvax. rewrite runax. apply idpath. Qed. (** Thus the relation is a binopeqrel *) Lemma binopeqrel_subgr_eqrel {A : abgr} (B : @subabgr A) : @binopeqrel A. Proof. use make_binopeqrel. - exact (make_eqrel _ (iseqrel_subgrhrel A B)). - exact (isbinopeqrel_subgr_eqrel B). Defined. (** These are the homsets in our new category. *) Definition subabgr_quot {A : abgr} (B : @subabgr A) : abgr := abgrquot (binopeqrel_subgr_eqrel B). Definition Quotcategory_homsets (c d : ob PA) : abgr := subabgr_quot (PAS c d). Definition Quotcategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) (ob PA) (λ A B : ob PA, Quotcategory_homsets A B). Lemma Quotcategory_surj {c d : Quotcategory_ob_mor} (f : Quotcategory_ob_mor⟦c, d⟧) : ∥ hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS c d))) f ∥. Proof. use issurjsetquotpr. Qed. (** ** Composition of morphisms *) (** *** Some lemmas *) (** If images of f1 and f2 are equal, then f * inv f2 is mapped to unit. *) Local Lemma abgrquotpr_rels_to_unel {A : abgr} {f1 f2 : A} {H : @binopeqrel A} {f : abgrquot H} (e1 : setquotpr H f1 = f) (e2 : setquotpr H f2 = f) : setquotpr H (f1 * grinv A f2)%multmonoid = setquotpr H 1%multmonoid. Proof. rewrite <- e2 in e1. clear e2. apply (maponpaths (λ f : _, (f * (@grinv (abgrquot H) (setquotpr H f2)))%multmonoid)) in e1. rewrite grrinvax in e1. apply e1. Qed. (** Equality on relation to refl *) Local Lemma abgrquotpr_rel_to_refl {A : abgr} {H : @binopeqrel A} {f g : A} (e : H g g = H f g) : H f g. Proof. induction e. apply eqrelrefl. Qed. Lemma abgrquotpr_rel_paths {A : abgr} {H : @binopeqrel A} {f g : A} (e : setquotpr H f = setquotpr H g) : H f g. Proof. exact (abgrquotpr_rel_to_refl (! (funeqpaths (base_paths _ _ e)) g)). Qed. Lemma abgrquotpr_rel_image {A : abgr} {H : @binopeqrel A} {f g : A} (e : H f g) : setquotpr H f = setquotpr H g. Proof. apply iscompsetquotpr. exact e. Qed. (** *** Morphisms to elements of groups *) Local Lemma mor_to_elem {a b : PA} (f : PA⟦a, b⟧) (H : pr1 (PAS a b) f) : carrier (pr1 (PAS a b)). Proof. use tpair. - exact f. - exact H. Defined. Local Lemma to_inv_elem {a b : PA} (f : PA⟦a, b⟧) (H : pr1 (PAS a b) f) : carrier (pr1 (PAS a b)). Proof. use tpair. - exact (@grinv (to_abgr a b) f). - apply (pr2 (pr2 (PAS a b))). exact H. Defined. Local Lemma to_op_elem {A B : PA} (f g : PA⟦A, B⟧) (H1 : pr1 (PAS A B) f) (H2 : pr1 (PAS A B) g) : pr1 (PAS A B) (to_binop A B f g). Proof. set (tmp := pr1 (pr1 (pr2 (PAS A B)))). cbn in tmp. unfold issubsetwithbinop in tmp. set (a := mor_to_elem f H1). set (a' := mor_to_elem g H2). apply (tmp a a'). Qed. (** *** Composition of morphisms in the quotient precategory *) (** **** Structure for composition *) Definition QuotcategoryComp {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) : UU := ∑ h : Quotcategory_ob_mor⟦A, C⟧, (∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = h). Definition make_QuotcategoryComp {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧} {g : Quotcategory_ob_mor⟦B, C⟧} (h : Quotcategory_ob_mor⟦A, C⟧) (H : ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = h) : QuotcategoryComp f g := tpair _ h H. Definition QuotcategoryCompMor {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧} {g : Quotcategory_ob_mor⟦B, C⟧} (QPC : QuotcategoryComp f g) : Quotcategory_ob_mor⟦A, C⟧ := pr1 QPC. Definition QuotcategoryCompEq {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧} {g : Quotcategory_ob_mor⟦B, C⟧} (QPC : QuotcategoryComp f g) : ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = QuotcategoryCompMor QPC := pr2 QPC. (** **** Composition for quotient category *) Local Lemma Quotcategory_comp_iscontr_PAS_eq {A : abgr} {a b c : A} (e : a = (b * (grinv A c))%multmonoid) : b = (a * c)%multmonoid. Proof. rewrite e. rewrite assocax. rewrite grlinvax. rewrite runax. apply idpath. Qed. Lemma Quotcategory_comp_iscontr_PAS {A B C : PA} {t : pr1 (PAS A B)} {t' : pr1 (PAS B C)} {f1 f'1 : PA⟦A, B⟧} {g1 g'1 : PA⟦B, C⟧} (p : pr1 t = to_binop A B f'1 (grinv (to_abgr A B) f1)) (p' : pr1 t' = to_binop B C g'1 (grinv (to_abgr B C) g1)) : pr1 (PAS A C) (to_binop A C (f1 · g1) (grinv (to_abgr A C) (f'1 · g'1))). Proof. set (e1 := Quotcategory_comp_iscontr_PAS_eq p). set (e2 := Quotcategory_comp_iscontr_PAS_eq p'). rewrite e1. rewrite e2. clear e1 e2 p p'. cbn. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. set (ac := assocax (to_abgr A C)). unfold isassoc in ac. cbn in ac. set (comm := commax (to_abgr A C)). unfold iscomm in comm. cbn in comm. rewrite (comm _ (f1 · g1)). rewrite <- (ac _ (f1 · g1) _). rewrite (comm _ (f1 · g1)). rewrite ac. rewrite ac. set (i := grinvop (to_abgr A C)). cbn in i. rewrite i. repeat rewrite <- ac. rewrite comm. rewrite <- ac. set (il := linvax _ (f1 · g1)). unfold to_inv in il. rewrite il. clear il. set (lu := to_lunax A C). unfold islunit in lu. cbn in lu. unfold to_unel. rewrite lu. set (tmp := pr2 (pr2 (PAS A C))). cbn in tmp. apply tmp. clear tmp. use to_op_elem. - use to_op_elem. + apply (dirprod_pr1 (PAC A B) C (pr1 t) (pr2 t) (pr1 t')). + apply (dirprod_pr2 (PAC A B) C f1 (pr1 t') (pr2 t')). - apply (dirprod_pr1 (PAC A B) C (pr1 t) (pr2 t) g1). Qed. Local Lemma Quotcategory_comp_iscontr_eq {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) (f'1 : PA ⟦ A, B ⟧) (f''1 : setquotpr _ f'1 = f) (g'1 : PA ⟦ B, C ⟧) (g''1 : setquotpr _ g'1 = g) : ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = setquotpr (binopeqrel_subgr_eqrel (PAS A C)) (f'1 · g'1). Proof. intros f1 Hf g1 Hg. cbn. apply (iscompsetquotpr (make_eqrel _ (iseqrel_subgrhrel (to_abgr A C) (PAS A C)))). set (HH := @abgrquotpr_rels_to_unel (to_abgr A B) f'1 f1 (binopeqrel_subgr_eqrel (PAS A B)) f f''1 Hf). set (HH' := @abgrquotpr_rels_to_unel (to_abgr B C) g'1 g1 (binopeqrel_subgr_eqrel (PAS B C)) g g''1 Hg). apply abgrquotpr_rel_paths in HH. apply abgrquotpr_rel_paths in HH'. use (squash_to_prop HH). apply propproperty. intros HHH. clear HH. use (squash_to_prop HH'). apply propproperty. intros HHH'. clear HH'. cbn in HHH. cbn in HHH'. induction HHH as [t p]. induction HHH' as [t' p']. rewrite grinvunel in p. rewrite grinvunel in p'. set (tmp := to_runax A B). unfold isrunit in tmp. cbn in tmp. rewrite tmp in p. clear tmp. set (tmp := to_runax B C). unfold isrunit in tmp. cbn in tmp. rewrite tmp in p'. clear tmp. use hinhpr. use tpair. + use tpair. * exact (to_binop A C (f1 · g1) (grinv (to_abgr A C) (f'1 · g'1))). * apply (Quotcategory_comp_iscontr_PAS p p'). + apply idpath. Qed. Local Lemma QuotPrecatetgory_comp_iscontr_univ {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) (f' : hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f) (g' : hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g) : ∏ t : QuotcategoryComp f g, t = make_QuotcategoryComp (setquotpr (binopeqrel_subgr_eqrel (PAS A C)) (hfiberpr1 _ _ f' · hfiberpr1 _ _ g')) (Quotcategory_comp_iscontr_eq f g (hfiberpr1 (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f f') (hfiberpr2 (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f f') (hfiberpr1 (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g g') (hfiberpr2 (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g g')). Proof. intros t. use total2_paths_f. - exact (! (pr2 t (hfiberpr1 _ _ f') (hfiberpr2 _ _ f') (hfiberpr1 _ _ g') (hfiberpr2 _ _ g'))). - apply proofirrelevance. apply impred. intros t'. apply impred. intros H. apply impred. intros t0. apply impred. intros H0. apply isasetsetquot. Qed. Lemma Quotcategory_comp_iscontr {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) : iscontr (QuotcategoryComp f g). Proof. use (squash_to_prop (Quotcategory_surj f) (isapropiscontr _)). intros f'. use (squash_to_prop (Quotcategory_surj g) (isapropiscontr _)). intros g'. use make_iscontr. - use make_QuotcategoryComp. + exact (setquotpr (binopeqrel_subgr_eqrel (PAS A C)) ((hfiberpr1 _ _ f') · (hfiberpr1 _ _ g'))). + exact (Quotcategory_comp_iscontr_eq f g (hfiberpr1 _ _ f') (hfiberpr2 _ _ f') (hfiberpr1 _ _ g') (hfiberpr2 _ _ g')). - exact (QuotPrecatetgory_comp_iscontr_univ f g f' g'). Defined. Definition Quotcategory_comp {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) : Quotcategory_ob_mor⟦A, C⟧. Proof. exact (QuotcategoryCompMor (iscontrpr1 (Quotcategory_comp_iscontr f g))). Defined. Definition to_quot_mor {x y : ob PA} (f : PA⟦x, y⟧) : Quotcategory_ob_mor⟦x, y⟧. Proof. use setquotpr. exact f. Defined. (** ** Some equations on linearity, compositions, and binops *) Lemma Quotcategory_comp_linear {x y z : ob PA} (f : PA⟦x, y⟧) (g : PA⟦y, z⟧) : Quotcategory_comp (to_quot_mor f) (to_quot_mor g) = to_quot_mor (f · g). Proof. unfold to_quot_mor. unfold Quotcategory_comp. apply pathsinv0. use (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) g)))). - apply idpath. - apply idpath. Qed. (** Pre- and postcomposition respect binop. *) Local Lemma Quotcategory_premor {x y z : PA} (f : PA⟦x, y⟧) (g h : PA⟦y, z⟧) : Quotcategory_comp (to_quot_mor f) ((to_quot_mor g * to_quot_mor h)%multmonoid) = ((Quotcategory_comp (to_quot_mor f) (to_quot_mor g)) * (Quotcategory_comp (to_quot_mor f) (to_quot_mor h)))%multmonoid. Proof. Local Opaque binopeqrel_subgr_eqrel isabgrquot setquotfun2 Quotcategory_comp. apply pathsinv0. cbn. eapply pathscomp0. - rewrite Quotcategory_comp_linear. rewrite Quotcategory_comp_linear. use setquotfun2comm. - apply pathsinv0. unfold to_quot_mor. set (tmp := setquotfun2comm (binopeqrel_subgr_eqrel (PAS y z)) (binopeqrel_subgr_eqrel (PAS y z)) (to_binop y z) (iscompbinoptransrel (binopeqrel_subgr_eqrel (PAS y z)) (eqreltrans (binopeqrel_subgr_eqrel (PAS y z))) (pr2 (binopeqrel_subgr_eqrel (PAS y z))))). rewrite tmp. clear tmp. rewrite <- to_premor_linear'. apply pathsinv0. Local Transparent Quotcategory_comp. unfold Quotcategory_comp. apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (to_binop y z g h))))). + apply idpath. + apply idpath. Qed. Local Lemma Quotcategory_postmor {x y z : PA} (f : PA⟦y, z⟧) (g h : PA⟦x, y⟧) : Quotcategory_comp (to_quot_mor g * to_quot_mor h)%multmonoid (to_quot_mor f) = ((Quotcategory_comp (to_quot_mor g) (to_quot_mor f)) * (Quotcategory_comp (to_quot_mor h) (to_quot_mor f)))%multmonoid. Proof. Local Opaque Quotcategory_comp. apply pathsinv0. cbn. eapply pathscomp0. - rewrite Quotcategory_comp_linear. rewrite Quotcategory_comp_linear. use setquotfun2comm. - unfold to_quot_mor. rewrite setquotfun2comm. Local Transparent Quotcategory_comp. unfold Quotcategory_comp. rewrite <- to_postmor_linear'. apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_binop x y g h)) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f)))). + apply idpath. + apply idpath. Qed. (** Composing with the unit element gives the unit element. *) Local Lemma quot_comp_unel_left {x y z : PA} (f : PA⟦x, y⟧) : Quotcategory_comp (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (@to_unel PA y z)) = (setquotpr (binopeqrel_subgr_eqrel (PAS x z)) (@to_unel PA x z)). Proof. rewrite <- (to_premor_unel' _ _ f). apply pathsinv0. unfold Quotcategory_comp. apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (to_unel y z))))). - apply idpath. - apply idpath. Qed. Local Lemma quot_comp_unel_right {x y z : PA} (f : PA⟦y, z⟧) : Quotcategory_comp (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_unel x y)) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f) = (setquotpr (binopeqrel_subgr_eqrel (PAS x z)) (to_unel x z)). Proof. rewrite <- (to_postmor_unel' _ _ f). apply pathsinv0. unfold Quotcategory_comp. apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_unel x y)) (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f)))). - apply idpath. - apply idpath. Qed. (** ** Construction of the Quotcategory *) Definition Quotcategory_data : precategory_data := make_precategory_data Quotcategory_ob_mor (λ (A : ob PA), setquotpr (binopeqrel_subgr_eqrel (PAS A A)) (identity A)) (fun (A B C : ob PA) (f : Quotcategory_ob_mor⟦A, B⟧) (g : Quotcategory_ob_mor⟦B, C⟧) => Quotcategory_comp f g). (** The following two lemmas are used to show associaticity of composition in Quotcategory. *) Local Lemma Quot_assoc1 {a b c d : Quotcategory_data} (f : Quotcategory_data ⟦a, b⟧) (g : Quotcategory_data ⟦b, c⟧) (h : Quotcategory_data ⟦c, d⟧) (f1 : PA⟦a, b⟧) (f2 : setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1 = f) (g1 : PA⟦b, c⟧) (g2 : setquotpr (binopeqrel_subgr_eqrel (PAS b c)) g1 = g) (h1 : PA⟦c, d⟧) (h2 : setquotpr (binopeqrel_subgr_eqrel (PAS c d)) h1 = h) : Quotcategory_comp f (Quotcategory_comp g h) = setquotpr (binopeqrel_subgr_eqrel (PAS a d)) (f1 · (g1 · h1)). Proof. apply pathsinv0. set (ic2 := Quotcategory_comp_iscontr g h). set (ic3 := Quotcategory_comp_iscontr f (pr1 (pr1 ic2))). set (tmp := pr2 (pr1 ic3)). cbn beta in tmp. unfold Quotcategory_comp. fold ic2. fold ic3. use tmp. - exact f2. - use (pr2 (pr1 ic2)). + exact g2. + exact h2. Qed. Local Lemma Quot_assoc2 {a b c d : Quotcategory_data} (f : Quotcategory_data ⟦a, b⟧) (g : Quotcategory_data ⟦b, c⟧) (h : Quotcategory_data ⟦c, d⟧) (f1 : PA⟦a, b⟧) (f2 : setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1 = f) (g1 : PA⟦b, c⟧) (g2 : setquotpr (binopeqrel_subgr_eqrel (PAS b c)) g1 = g) (h1 : PA⟦c, d⟧) (h2 : setquotpr (binopeqrel_subgr_eqrel (PAS c d)) h1 = h) : setquotpr (binopeqrel_subgr_eqrel (PAS a d)) ((f1 · g1) · h1) = Quotcategory_comp (Quotcategory_comp f g) h. Proof. set (ic1 := Quotcategory_comp_iscontr f g). set (ic4 := Quotcategory_comp_iscontr (pr1 (pr1 ic1)) h). set (tmp := pr2 (pr1 ic4)). cbn beta in tmp. unfold Quotcategory_comp. fold ic1. fold ic4. use tmp. - use (pr2 (pr1 ic1)). + exact f2. + exact g2. - exact h2. Qed. (** Quotcategory is a precategory *) Lemma is_precategory_Quotcategory_data : is_precategory Quotcategory_data. Proof. split. - split. (* id left *) + intros a b f. apply pathsinv0. cbn. unfold Quotcategory_comp. set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f). use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''. induction f' as [f1 f2]. rewrite <- f2. cbn in f1, a, b. eapply pathscomp0. * apply maponpaths. exact (! (id_left f1)). * apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS a a)) (@identity PA a)) (setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1)))). -- apply idpath. -- apply idpath. (* id right *) + intros a b f. apply pathsinv0. cbn. unfold Quotcategory_comp. set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f). use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''. induction f' as [f1 f2]. rewrite <- f2. cbn in f1, a, b. eapply pathscomp0. * apply maponpaths. exact (! (id_right f1)). * apply (pr2 (pr1 (Quotcategory_comp_iscontr (setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1) (setquotpr (binopeqrel_subgr_eqrel (PAS b b)) (@identity PA b))))). -- apply idpath. -- apply idpath. (* assoc *) - split. + intros a b c d f g h. cbn. set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f). use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''. set (g'' := @issurjsetquotpr (to_abgr b c) (binopeqrel_subgr_eqrel (PAS b c)) g). use (squash_to_prop g''). apply isasetsetquot. intros g'. clear g''. set (h'' := @issurjsetquotpr (to_abgr c d) (binopeqrel_subgr_eqrel (PAS c d)) h). use (squash_to_prop h''). apply isasetsetquot. intros h'. clear h''. induction f' as [f1 f2]. induction g' as [g1 g2]. induction h' as [h1 h2]. cbn in f1, g1, h1. rewrite (Quot_assoc1 f g h f1 f2 g1 g2 h1 h2). rewrite <- (Quot_assoc2 f g h f1 f2 g1 g2 h1 h2). rewrite assoc. apply idpath. + intros a b c d f g h. cbn. set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f). use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''. set (g'' := @issurjsetquotpr (to_abgr b c) (binopeqrel_subgr_eqrel (PAS b c)) g). use (squash_to_prop g''). apply isasetsetquot. intros g'. clear g''. set (h'' := @issurjsetquotpr (to_abgr c d) (binopeqrel_subgr_eqrel (PAS c d)) h). use (squash_to_prop h''). apply isasetsetquot. intros h'. clear h''. induction f' as [f1 f2]. induction g' as [g1 g2]. induction h' as [h1 h2]. cbn in f1, g1, h1. rewrite (Quot_assoc1 f g h f1 f2 g1 g2 h1 h2). rewrite <- (Quot_assoc2 f g h f1 f2 g1 g2 h1 h2). rewrite assoc'. apply idpath. Defined. Definition Quotprecategory : precategory := tpair _ _ is_precategory_Quotcategory_data. Lemma has_homsets_Quotcategory : has_homsets Quotprecategory. Proof. intros a b. apply isasetsetquot. Qed. Definition Quotcategory : category := make_category Quotprecategory has_homsets_Quotcategory. (** ** Quotient precategory of PreAdditive is PreAdditive *) Definition Quotcategory_binops : precategoryWithBinOps. Proof. use make_precategoryWithBinOps. - exact Quotcategory. - intros x y. exact (@op (subabgr_quot (PAS x y))). Defined. Unset Kernel Term Sharing. Definition Quotcategory_abgrops : categoryWithAbgrops. Proof. use make_categoryWithAbgrops. - exact Quotcategory_binops. - intros x y. exact (pr2 (subabgr_quot (PAS x y))). Defined. Set Kernel Term Sharing. Local Lemma quot_unel {x y : PA} : setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (@to_unel PA x y) = unel (@to_abgr Quotcategory_abgrops x y). Proof. apply idpath. Qed. Local Opaque to_abgr. Local Lemma PreAdditive_pre_linear (x y z : ob Quotcategory_abgrops) (f : Quotcategory_abgrops⟦x, y⟧) (g h : Quotcategory_abgrops ⟦y, z⟧): f · to_binop y z g h = to_binop x z (f · g) (f · h). Proof. use (squash_to_prop (Quotcategory_surj f)). apply to_has_homsets. intros f'. use (squash_to_prop (Quotcategory_surj g)). apply to_has_homsets. intros g'. use (squash_to_prop (Quotcategory_surj h)). apply to_has_homsets. intros h'. rewrite <- (hfiberpr2 _ _ f'). rewrite <- (hfiberpr2 _ _ g'). rewrite <- (hfiberpr2 _ _ h'). exact (Quotcategory_premor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g') (hfiberpr1 _ _ h')). Qed. Local Lemma PreAdditive_pre_unel (x y z : ob Quotcategory_abgrops) (f : Quotcategory_abgrops⟦x, y⟧) : f · (@to_unel Quotcategory_abgrops y z) = @to_unel Quotcategory_abgrops x z. Proof. use (squash_to_prop (Quotcategory_surj f)). apply (@to_has_homsets Quotcategory_abgrops). intros f'. rewrite <- (hfiberpr2 _ _ f'). exact (@quot_comp_unel_left x y z (hfiberpr1 _ _ f')). Qed. Local Lemma PreAdditive_post_linear (x y z : ob Quotcategory_abgrops) (f : Quotcategory_abgrops⟦y, z⟧) (g h : Quotcategory_abgrops ⟦x, y⟧): to_binop x y g h · f = to_binop x z (g · f) (h · f). Proof. use (squash_to_prop (Quotcategory_surj f)). apply to_has_homsets. intros f'. use (squash_to_prop (Quotcategory_surj g)). apply to_has_homsets. intros g'. use (squash_to_prop (Quotcategory_surj h)). apply to_has_homsets. intros h'. rewrite <- (hfiberpr2 _ _ f'). rewrite <- (hfiberpr2 _ _ g'). rewrite <- (hfiberpr2 _ _ h'). exact (Quotcategory_postmor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g') (hfiberpr1 _ _ h')). Qed. Local Lemma PreAdditive_post_unel (x y z : ob Quotcategory_abgrops) (f : Quotcategory_abgrops⟦y, z⟧) : (@to_unel Quotcategory_abgrops x y) · f = @to_unel Quotcategory_abgrops x z. Proof. use (squash_to_prop (Quotcategory_surj f)). apply (@to_has_homsets Quotcategory_abgrops). intros f'. rewrite <- (hfiberpr2 _ _ f'). exact (@quot_comp_unel_right x y z (hfiberpr1 _ _ f')). Qed. Lemma Quotcategory_isPreAdditive : isPreAdditive Quotcategory_abgrops. Proof. use make_isPreAdditive'. - intros x y z f g h. exact (PreAdditive_pre_linear x y z f g h). - intros x y z f. exact (PreAdditive_pre_unel x y z f). - intros x y z f g h. exact (PreAdditive_post_linear x y z f g h). - intros x y z f. exact (PreAdditive_post_unel x y z f). Qed. Definition Quotcategory_PreAdditive : PreAdditive. Proof. use make_PreAdditive. - exact Quotcategory_abgrops. - exact Quotcategory_isPreAdditive. Defined. Lemma setquotpr_linear {x y : PA} (f g : PA⟦x, y⟧) : to_quot_mor (@to_binop PA _ _ f g) = @to_binop Quotcategory_PreAdditive _ _ (to_quot_mor f) (to_quot_mor g). Proof. exact (pr1 (abgrquotpr_ismonoidfun (binopeqrel_subgr_eqrel (PAS x y))) f g). Qed. Lemma comp_eq {x y z : PA} (f : Quotcategory_PreAdditive⟦x, y⟧) (g : Quotcategory_PreAdditive⟦y, z⟧) : Quotcategory_comp f g = f · g. Proof. apply idpath. Qed. (** ** The canonical functor to Quotcategory *) (** This functor is identity on objects and sends morphisms to the equivalence class they represent. *) Definition QuotcategoryFunctor_data : functor_data PA Quotcategory_PreAdditive. Proof. use tpair. - intros X. exact X. - intros X Y f. exact (setquotpr (binopeqrel_subgr_eqrel (PAS X Y)) f). Defined. Local Lemma QuotcategoryFunctor_isfunctor : is_functor QuotcategoryFunctor_data. Proof. split. - intros X. apply idpath. - intros x Y Z f g. exact (! (Quotcategory_comp_linear f g)). Qed. Definition QuotcategoryFunctor : functor PA Quotcategory_PreAdditive. Proof. use tpair. - exact QuotcategoryFunctor_data. - exact QuotcategoryFunctor_isfunctor. Defined. (** ** If PA has a zero object, then so does Quotcategory of PA *) Variable Z : Zero PA. Lemma Quotcategory_isZero : isZero (C:=Quotcategory) Z. Proof. use make_isZero. - intros a. use tpair. + exact (to_quot_mor (@ZeroArrowFrom PA Z a)). + cbn beta. intros t. set (t'1 := @issurjsetquotpr (to_abgr Z a) (binopeqrel_subgr_eqrel (PAS Z a)) t). use (squash_to_prop t'1). apply has_homsets_Quotcategory. intros t1. clear t'1. induction t1 as [t1 t2]. rewrite <- t2. unfold to_quot_mor. apply maponpaths. apply ArrowsFromZero. - intros a. use tpair. + exact (to_quot_mor (@ZeroArrowTo PA Z a)). + cbn beta. intros t. set (t'1 := @issurjsetquotpr (to_abgr a Z) (binopeqrel_subgr_eqrel (PAS a Z)) t). use (squash_to_prop t'1). apply has_homsets_Quotcategory. intros t1. clear t'1. induction t1 as [t1 t2]. rewrite <- t2. unfold to_quot_mor. apply maponpaths. apply ArrowsToZero. Qed. Definition Quotcategory_Zero : @Zero Quotcategory. Proof. use make_Zero. - exact Z. - exact Quotcategory_isZero. Defined. End preadditive_quotient. Definition oppositePreAdditive (M : PreAdditive) : PreAdditive. Proof. exists (oppositeCategoryWithAbgrops M). split. - exact (λ a b c f, @to_postmor_monoid (pr1 M) (pr2 M) (rm_opp_ob c) (rm_opp_ob b) (rm_opp_ob a) (rm_opp_mor f)). - exact (λ a b c f, @to_premor_monoid (pr1 M) (pr2 M) (rm_opp_ob c) (rm_opp_ob b) (rm_opp_ob a) (rm_opp_mor f)). Defined. Definition induced_PreAdditive (M : PreAdditive) {X:Type} (j : X -> ob M) : PreAdditive. Proof. exists (induced_categoryWithAbgrops M j). split. - exact (λ a b c, @to_premor_monoid (pr1 M) (pr2 M) (j a) (j b) (j c)). - exact (λ a b c, @to_postmor_monoid (pr1 M) (pr2 M) (j a) (j b) (j c)). Defined. Lemma induced_opposite_PreAdditive {M:PreAdditive} {X:Type} (j : X -> ob M) : oppositePreAdditive (induced_PreAdditive M j) = induced_PreAdditive (oppositePreAdditive M) (λ a, opp_ob (j a)). Proof. intros. compute. (* the following line bogs down without this one *) apply idpath. (* but the computation may make this proof fragile *) Defined. Section RewritingAids. Local Open Scope abgrcat. Lemma zeroLeft {M:PreAdditive} {a b c : M} (f : b --> c) : ((0 : a --> b) · f = 0)%abgrcat. Proof. apply to_postmor_unel'. Defined. Lemma zeroRight {M:PreAdditive} {a b c : M} (f : a --> b) : f · (0 : b --> c) = 0. Proof. apply to_premor_unel'. Defined. Definition leftCompIsHomo {M:PreAdditive} {a b : M} (f : a --> b) (c:M) : ismonoidfun (to_premor c f) := @to_premor_monoid _ M _ _ _ _. Definition rightCompIsHomo {M:PreAdditive} {b c : M} (a:M) (f : b --> c) : ismonoidfun (to_postmor a f) := @to_postmor_monoid _ M _ _ _ _. Definition leftCompHomo {M:PreAdditive} {a b : M} (f : a --> b) (c:M) : monoidfun (b-->c) (a-->c) := to_premor c f,, to_premor_monoid M _ _ _ f. Definition rightCompHomo {M:PreAdditive} {b c : M} (a:M) (f : b --> c) : monoidfun (a-->b) (a-->c) := to_postmor a f,, to_postmor_monoid M _ _ _ f. Lemma rightDistribute {M:PreAdditive} {a b c : M} (f : a --> b) (g h : b --> c) : f · (g + h) = f · g + f · h. Proof. apply leftCompIsHomo. Qed. Lemma leftDistribute {M:PreAdditive} {a b c : M} (f g : a --> b) (h : b --> c) : (f + g) · h = f · h + g · h. Proof. apply rightCompIsHomo. Qed. Lemma rightMinus {M:PreAdditive} {a b c : M} (f : a --> b) (g : b --> c) : f · (- g) = - (f·g). Proof. exact (monoidfuninvtoinv (leftCompHomo f c) g). Qed. Lemma leftMinus {M:PreAdditive} {a b c : M} (f : a --> b) (g : b --> c) : (- f) · g = - (f·g). Proof. exact (monoidfuninvtoinv (rightCompHomo a g) f). Qed. End RewritingAids. UniMath-20231010/UniMath/CategoryTheory/PrecategoriesWithAbgrops.v000066400000000000000000000225741451125700300247730ustar00rootroot00000000000000(** ** Precategories with homsets abelian groups (abgrops). *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Core.Functors. Section def_precategory_with_abgrops. (** Definition of precategories such that homsets are abgrops. *) Definition categoryWithAbgropsData (PB : precategoryWithBinOps) : UU := ∏ (x y : PB), @isabgrop (make_hSet (PB⟦x,y⟧) (homset_property PB x y)) (@to_binop _ x y). Definition make_categoryWithAbgropsData {PB : precategoryWithBinOps} (H : ∏ (x y : PB), @isabgrop (make_hSet (PB⟦x,y⟧) (homset_property _ x y)) (@to_binop _ x y)) : categoryWithAbgropsData PB := H. Definition categoryWithAbgrops : UU := ∑ PA : precategoryWithBinOps, categoryWithAbgropsData PA. Definition categoryWithAbgrops_precategoryWithBinOps (PB : categoryWithAbgrops) : precategoryWithBinOps := (pr1 PB). Coercion categoryWithAbgrops_precategoryWithBinOps : categoryWithAbgrops >-> precategoryWithBinOps. Definition make_categoryWithAbgrops (PB : precategoryWithBinOps) (H : categoryWithAbgropsData PB) : categoryWithAbgrops. Proof. exact (tpair _ PB H). Defined. Variable PA : categoryWithAbgrops. (** Definitions to access the structure of a precategory with abelian groups. *) Definition to_has_homsets : has_homsets PA := (pr1 PA). Definition to_homset (x y : PA) : hSet := make_hSet (PA⟦x, y⟧) (to_has_homsets x y). Definition to_setwithbinop (x y : PA) := make_setwithbinop (to_homset x y) (to_binop x y). Definition to_isabgrop (x y : PA) := (pr2 PA) x y. Definition to_abgr (x y : PA) : abgr := make_abgr (to_setwithbinop x y) (to_isabgrop x y). Definition to_unel (x y : PA) := unel (to_abgr x y). Definition to_lunax (x y : PA) := lunax (to_abgr x y). Definition to_lunax' (x y : PA) (f : x --> y) : to_binop x y (to_unel x y) f = f. Proof. apply to_lunax. Qed. Definition to_runax (x y : PA) : isrunit op 1%multmonoid := runax (to_abgr x y). Definition to_runax' (x y : PA) (f : x --> y) : to_binop x y f (to_unel x y) = f. Proof. apply to_runax. Qed. Definition to_inv {x y : PA} : PA⟦x, y⟧ -> PA⟦x, y⟧ := grinv (to_abgr x y). Definition to_commax (x y : PA) := commax (to_abgr x y). Definition to_commax' {x y : ob PA} (f g : x --> y) : to_binop x y f g = to_binop x y g f. Proof. apply to_commax. Qed. (** The following definition gives maps between abgrops homsets by precomposing and postcomposing with a morphism. Note that we have not required these to be abelian group morphisms of abelian groups. *) Definition to_premor {x y : PA} (z : PA) (f : x --> y) : to_abgr y z -> to_abgr x z := fun (g : (to_abgr y z)) => f · g. Definition to_postmor (x : PA) {y z : PA} (f : y --> z) : to_abgr x y -> to_abgr x z := fun (g : (to_abgr x y)) => g · f. (** Some equations on inverses *) Lemma inv_inv_eq {x y : PA} (f : PA⟦x, y⟧) : to_inv (to_inv f) = f. Proof. unfold to_inv. apply (grinvinv (to_abgr x y) f). Qed. Lemma cancel_inv {x y : PA} (f g : PA⟦x, y⟧) (H : (to_inv f) = (to_inv g)) : f = g. Proof. apply (grinvmaponpathsinv (to_abgr x y) H). Qed. Lemma to_inv_unel {x y : PA} : to_inv (to_unel x y) = to_unel x y. Proof. unfold to_unel. set (tmp := grinvunel (to_abgr x y)). cbn in tmp. unfold to_inv. apply tmp. Qed. Lemma linvax {x y : PA} (f : PA⟦x, y⟧) : to_binop x y (to_inv f) f = to_unel x y. Proof. apply (grlinvax (to_abgr x y)). Qed. Lemma rinvax {x y : PA} (f : PA⟦x, y⟧) : to_binop x y f (to_inv f) = to_unel x y. Proof. apply (grrinvax (to_abgr x y)). Qed. Lemma to_lcan {x y : PA} {f g : PA⟦x, y⟧} (h : PA⟦x, y⟧) : to_binop x y h f = to_binop x y h g -> f = g. Proof. intros H. apply (grlcan (to_abgr x y) h H). Qed. Lemma to_rcan {x y : PA} {f g : PA⟦x, y⟧} (h : PA⟦x, y⟧) : to_binop x y f h = to_binop x y g h -> f = g. Proof. intros H. apply (grrcan (to_abgr x y) h H). Qed. Lemma to_lrw {x y : PA} (f g h : PA⟦x, y⟧) (e : f = g) : to_binop x y f h = to_binop x y g h. Proof. induction e. apply idpath. Qed. Lemma to_rrw {x y : PA} (f g h : PA⟦x, y⟧) (e : g = h) : to_binop x y f g = to_binop x y f h. Proof. apply maponpaths. exact e. Qed. Lemma to_assoc {x y : PA} (f g h : PA⟦x, y⟧) : to_binop _ _ (to_binop _ _ f g) h = to_binop _ _ f (to_binop _ _ g h). Proof. apply (assocax (to_abgr x y)). Qed. Lemma to_binop_inv_inv {x y : PA} (f g : PA⟦x, y⟧) : to_binop _ _ (to_inv f) (to_inv g) = to_inv (to_binop _ _ f g). Proof. apply (to_rcan g). rewrite to_assoc. rewrite linvax. rewrite to_runax'. apply (to_rcan f). rewrite to_assoc. rewrite linvax. cbn. rewrite <- (linvax (to_binop x y f g)). apply maponpaths. apply to_commax'. Qed. Lemma to_binop_inv_comm_1 {x y : PA} (f g : PA⟦x, y⟧) : to_binop _ _ (to_inv f) g = to_inv (to_binop _ _ f (to_inv g)). Proof. apply (to_rcan (to_binop x y f (to_inv g))). rewrite linvax. rewrite (to_commax' f). rewrite to_assoc. rewrite <- (to_assoc g). rewrite rinvax. rewrite to_lunax'. rewrite linvax. apply idpath. Qed. Lemma to_binop_inv_comm_2 {x y : PA} (f g : PA⟦x, y⟧) : to_binop _ _ f (to_inv g) = to_inv (to_binop _ _ (to_inv f) g). Proof. rewrite to_commax'. rewrite (to_commax' _ g). apply to_binop_inv_comm_1. Qed. End def_precategory_with_abgrops. Arguments to_has_homsets [PA] _ _ _ _ _ _. Arguments to_homset [PA] _ _. Arguments to_setwithbinop [PA] _ _. Arguments to_isabgrop [PA] _ _. Arguments to_abgr [PA] _ _. Arguments to_unel [PA] _ _. Arguments to_lunax [PA] _ _ _. Arguments to_runax [PA] _ _ _. Arguments to_premor [PA] [x] [y] _ _ _. Arguments to_postmor [PA] _ [y] [z] _ _. Arguments to_inv [PA] [x] [y] _. Arguments inv_inv_eq [PA] [x] [y] _. Arguments cancel_inv [PA] [x] [y] _ _ _. Declare Scope abgrcat. Delimit Scope abgrcat with abgrcat. Notation "b <-- a" := (to_abgr a b) : abgrcat. Notation "a --> b" := (to_abgr a b) : abgrcat. Notation "1" := (@identity (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _) : abgrcat. Notation "0" := (unel (grtomonoid (abgrtogr _))) : abgrcat. Notation "0" := (unel (grtomonoid (abgrtogr (to_abgr _ _)))) : abgrcat. Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f g) : abgrcat. Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f g) : abgrcat. Notation " - g" := (@grinv (abgrtogr _) g) : abgrcat. Notation " - g" := (@grinv (abgrtogr (to_abgr _ _)) g) : abgrcat. Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat. Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat. Notation "g ∘ f" := (@compose (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _ _ _ f g) : abgrcat. Notation "f · g" := (@compose (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _ _ _ f g) : abgrcat. Notation "f = g" := (@eqset (pr1setwithbinop (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _))))) f g) : abgrcat. Section transport_morphisms. Variable PA : categoryWithAbgrops. Lemma transport_target_to_inv {x y z : ob PA} (f : x --> y) (e : y = z) : to_inv (transportf (precategory_morphisms x) e f) = transportf (precategory_morphisms x) e (to_inv f). Proof. induction e. apply idpath. Qed. Lemma transport_source_to_inv {x y z : ob PA} (f : y --> z) (e : y = x) : to_inv (transportf (λ x' : ob PA, precategory_morphisms x' z) e f) = transportf (λ x' : ob PA, precategory_morphisms x' z) e (to_inv f). Proof. induction e. apply idpath. Qed. Lemma transport_target_to_binop {x y z : ob PA} (f g : x --> y) (e : y = z) : to_binop _ _ (transportf (precategory_morphisms x) e f) (transportf (precategory_morphisms x) e g) = transportf (precategory_morphisms x) e (to_binop _ _ f g). Proof. induction e. apply idpath. Qed. Lemma transport_source_to_binop {x y z : ob PA} (f g : y --> z) (e : y = x) : to_binop _ _ (transportf (λ x' : ob PA, precategory_morphisms x' z) e f) (transportf (λ x' : ob PA, precategory_morphisms x' z) e g) = transportf (λ x' : ob PA, precategory_morphisms x' z) e (to_binop _ _ f g). Proof. induction e. apply idpath. Qed. End transport_morphisms. Definition oppositeCategoryWithAbgrops (M : categoryWithAbgrops) : categoryWithAbgrops. Proof. use tpair. - exact (oppositePrecategoryWithBinOps M). - exact (λ a b, @to_isabgrop M (rm_opp_ob b) (rm_opp_ob a)). Defined. Definition induced_categoryWithAbgrops (M : categoryWithAbgrops) {X:Type} (j : X -> ob M) : categoryWithAbgrops. Proof. use tpair. - exact (induced_precategoryWithBinOps M j). - exact (λ a b, @to_isabgrop M (j a) (j b)). Defined. UniMath-20231010/UniMath/CategoryTheory/PrecategoryBinProduct.v000066400000000000000000001271511451125700300243000ustar00rootroot00000000000000(** * Binary product of (pre)categories Benedikt Ahrens, Ralph Matthes, Peter LeFanu Lumsdaine SubstitutionSystems 2015 For the general case, see [product_precategory]. See [unit_category] for the unit category, which is the unit under cartesian product up to isomorphism. *) (** ** Contents : - Definition of the cartesian product of two precategories - From a functor on a product of precategories to a functor on one of the categories by fixing the argument in the other component - From a functor on a product of precategories to a nat. transformation on one of the categories by fixing the morphism argument in the other component - Definition of the associator functors - Definition of the pair of two functors: A × C → B × D given A → B and C → D - Definition of the diagonal functor [bindelta_functor]. - Definition of post-whiskering with parameter (with a functor on a product of precategories where one argument is seen as parameter) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Definition precategory_binproduct_mor (C D : precategory_ob_mor) (cd cd' : C × D) := pr1 cd --> pr1 cd' × pr2 cd --> pr2 cd'. Definition precategory_binproduct_ob_mor (C D : precategory_ob_mor) : precategory_ob_mor := tpair _ _ (precategory_binproduct_mor C D). Definition precategory_binproduct_data (C D : precategory_data) : precategory_data. Proof. exists (precategory_binproduct_ob_mor C D). split. - intro cd. exact (make_dirprod (identity (pr1 cd)) (identity (pr2 cd))). - intros cd cd' cd'' fg fg'. exact (make_dirprod (pr1 fg · pr1 fg') (pr2 fg · pr2 fg')). Defined. Section precategory_binproduct. Variables C D : precategory. Lemma is_precategory_precategory_binproduct_data : is_precategory (precategory_binproduct_data C D). Proof. repeat split; intros. - apply dirprodeq; apply id_left. - apply dirprodeq; apply id_right. - apply dirprodeq; apply assoc. - apply dirprodeq; apply assoc'. Defined. (** needed for the op-related goal below *) Definition precategory_binproduct : precategory := tpair _ _ is_precategory_precategory_binproduct_data. Definition has_homsets_precategory_binproduct (hsC : has_homsets C) (hsD : has_homsets D) : has_homsets precategory_binproduct. Proof. intros a b. apply isasetdirprod. - apply hsC. - apply hsD. Qed. End precategory_binproduct. Definition category_binproduct (C D : category) : category := make_category (precategory_binproduct C D) (has_homsets_precategory_binproduct C D C D). Definition ob1 {C D} (x : category_binproduct C D) : C := pr1 x. Definition ob2 {C D} (x : category_binproduct C D) : D := pr2 x. Definition mor1 {C D} (x x' : category_binproduct C D) (f : _ ⟦x, x'⟧) : _ ⟦ob1 x, ob1 x'⟧ := pr1 f. Definition mor2 {C D} (x x' : category_binproduct C D) (f : _ ⟦x, x'⟧) : _ ⟦ob2 x, ob2 x'⟧ := pr2 f. Arguments ob1 { _ _ } _ . Arguments ob2 { _ _ } _ . Arguments mor1 { _ _ _ _ } _ . Arguments mor2 { _ _ _ _ } _ . Local Notation "C × D" := (category_binproduct C D) (at level 75, right associativity). (** Objects and morphisms in the product precategory of two precategories *) Definition make_catbinprod {C D : category} (X : C) (Y : D) : category_binproduct C D := make_dirprod X Y. Local Notation "A ⊗ B" := (make_catbinprod A B). Local Notation "( A , B )" := (make_catbinprod A B). Definition catbinprodmor {C D : category} {X X' : C} {Z Z' : D} (α : X --> X') (β : Z --> Z') : X ⊗ Z --> X' ⊗ Z' := make_dirprod α β. Local Notation "( f #, g )" := (catbinprodmor f g). (* Some useful facts about product precategories *) Lemma binprod_id {C D : category} (c : C) (d : D) : (identity c #, identity d) = identity (c, d). Proof. apply idpath. Defined. (** this seems useful since one often has to tell Coq explicitly to make that conversion *) Lemma binprod_comp {C D : category} (c c' c'' : C) (d d' d'' : D) (f : c --> c') (f' : c' --> c'') (g : d --> d') (g' : d' --> d'') : (f · f' #, g · g') = (f #, g) · (f' #, g'). Proof. apply idpath. Defined. (** idem concerning Defined vs. Qed *) Lemma is_z_iso_binprod_z_iso_aux {C D : category} {c c' : C} {d d' : D} {f : c --> c'} {g : d --> d'} (f_is_iso : is_z_isomorphism f) (g_is_iso : is_z_isomorphism g) : is_inverse_in_precat (f #, g) (inv_from_z_iso (make_z_iso' f f_is_iso) #, inv_from_z_iso (make_z_iso' g g_is_iso)). Proof. apply make_dirprod. - transitivity ((make_z_iso' f f_is_iso) · (inv_from_z_iso (make_z_iso' f f_is_iso)) #, (make_z_iso' g g_is_iso) · (inv_from_z_iso (make_z_iso' g g_is_iso))). + symmetry. apply binprod_comp. + rewrite 2 z_iso_inv_after_z_iso. apply binprod_id. - transitivity ((inv_from_z_iso (make_z_iso' f f_is_iso)) · (make_z_iso' f f_is_iso) #, (inv_from_z_iso (make_z_iso' g g_is_iso)) · (make_z_iso' g g_is_iso)). + symmetry. apply binprod_comp. + rewrite 2 z_iso_after_z_iso_inv. apply binprod_id. Qed. Definition is_z_iso_binprod_z_iso {C D : category} {c c' : C} {d d' : D} {f : c --> c'} {g : d --> d'} (f_is_iso : is_z_isomorphism f) (g_is_iso : is_z_isomorphism g) : is_z_isomorphism (f #, g). Proof. exists (inv_from_z_iso (make_z_iso' f f_is_iso) #, inv_from_z_iso (make_z_iso' g g_is_iso)). apply is_z_iso_binprod_z_iso_aux. Defined. (** Isos in product precategories *) Definition precatbinprod_z_iso {C D : category} {X X' : C} {Z Z' : D} (α : z_iso X X') (β : z_iso Z Z') : z_iso (X ⊗ Z) (X' ⊗ Z'). Proof. set (f := catbinprodmor α β). set (g := catbinprodmor (z_iso_inv_from_z_iso α) (z_iso_inv_from_z_iso β)). exists f. exists g. split. - apply pathsdirprod; apply z_iso_inv_after_z_iso. - apply pathsdirprod; apply z_iso_after_z_iso_inv. Defined. Definition precatbinprod_z_iso_inv {C D : category} {X X' : C} {Z Z' : D} (α : z_iso X X') (β : z_iso Z Z') : precatbinprod_z_iso (z_iso_inv_from_z_iso α) (z_iso_inv_from_z_iso β) = z_iso_inv_from_z_iso (precatbinprod_z_iso α β). Proof. apply inv_z_iso_unique. split; apply z_iso_inv_after_z_iso. Defined. (* Definition is_z_iso_binprod_z_iso {C D : category} {c c' : C} {d d' : D} {f : c --> c'} {g : d --> d'} (f_is_z_iso : is_z_isomorphism f) (g_is_z_iso : is_z_isomorphism g) : is_z_isomorphism (f #, g). Proof. red. exists (is_z_isomorphism_mor f_is_z_iso,,is_z_isomorphism_mor g_is_z_iso). red. split; apply dirprodeq; cbn. - apply (pr1 (pr2 f_is_z_iso)). - apply (pr1 (pr2 g_is_z_iso)). - apply (pr2 (pr2 f_is_z_iso)). - apply (pr2 (pr2 g_is_z_iso)). Defined. Definition precatbinprod_z_iso {C D : category} {X X' : C} {Z Z' : D} (α : z_iso X X') (β : z_iso Z Z') : z_iso (X ⊗ Z) (X' ⊗ Z') := (pr1 α,, pr1 β) ,, is_z_iso_binprod_z_iso (pr2 α)(pr2 β). *) (** Associativity functors *) Section assoc. Definition precategory_binproduct_assoc_data (C0 C1 C2 : precategory_data) : functor_data (precategory_binproduct_data C0 (precategory_binproduct_data C1 C2)) (precategory_binproduct_data (precategory_binproduct_data C0 C1) C2). Proof. use tpair. - intros c. exact (tpair _ (tpair _ (pr1 c) (pr1 (pr2 c))) (pr2 (pr2 c))). - intros a b c. exact (tpair _ (tpair _ (pr1 c) (pr1 (pr2 c))) (pr2 (pr2 c))). Defined. Definition precategory_binproduct_assoc (C0 C1 C2 : category) : (C0 × (C1 × C2)) ⟶ ((C0 × C1) × C2). Proof. exists (precategory_binproduct_assoc_data _ _ _). abstract ( split; [ intros c; apply idpath | intros c0 c1 c2 f g; apply idpath] ). Defined. Definition precategory_binproduct_unassoc_data (C0 C1 C2 : precategory_data) : functor_data (precategory_binproduct_data (precategory_binproduct_data C0 C1) C2) (precategory_binproduct_data C0 (precategory_binproduct_data C1 C2)). Proof. use tpair. - intros c. exact (tpair _ (pr1 (pr1 c)) (tpair _ (pr2 (pr1 c)) (pr2 c))). - intros a b c. exact (tpair _ (pr1 (pr1 c)) (tpair _ (pr2 (pr1 c)) (pr2 c))). Defined. Definition precategory_binproduct_unassoc (C0 C1 C2 : category) : ((C0 × C1) × C2) ⟶ (C0 × (C1 × C2)). Proof. exists (precategory_binproduct_unassoc_data _ _ _). abstract ( split; [ intros c; apply idpath | intros c0 c1 c2 f g; apply idpath] ). Defined. End assoc. (** Fixing one argument of C × D -> E results in a functor *) Section functor_fix_fst_arg. Variable C D E : precategory. Variable F : functor (precategory_binproduct C D) E. Variable c : C. Definition functor_fix_fst_arg_ob (d: D) : E := F (tpair _ c d). Definition functor_fix_fst_arg_mor (d d' : D) (f : d --> d') : functor_fix_fst_arg_ob d --> functor_fix_fst_arg_ob d'. Proof. apply (#F). exact (make_dirprod (identity c) f). Defined. Definition functor_fix_fst_arg_data : functor_data D E := tpair _ functor_fix_fst_arg_ob functor_fix_fst_arg_mor. Lemma is_functor_functor_fix_fst_arg_data: is_functor functor_fix_fst_arg_data. Proof. red. split; red. + intros d. unfold functor_fix_fst_arg_data; simpl. unfold functor_fix_fst_arg_mor; simpl. unfold functor_fix_fst_arg_ob; simpl. assert (functor_id_inst := functor_id F). rewrite <- functor_id_inst. apply maponpaths. apply idpath. + intros d d' d'' f g. unfold functor_fix_fst_arg_data; simpl. unfold functor_fix_fst_arg_mor; simpl. assert (functor_comp_inst := @functor_comp _ _ F (make_dirprod c d) (make_dirprod c d') (make_dirprod c d'')). rewrite <- functor_comp_inst. apply maponpaths. unfold compose at 2. unfold precategory_binproduct; simpl. rewrite id_left. apply idpath. Qed. Definition functor_fix_fst_arg : D ⟶ E := tpair _ functor_fix_fst_arg_data is_functor_functor_fix_fst_arg_data. End functor_fix_fst_arg. Section nat_trans_from_functor_fix_fst_morphism_arg. Variable C D E : category. Variable F : (C × D) ⟶ E. Variable c c' : C. Variable g: c --> c'. Definition nat_trans_from_functor_fix_fst_morphism_arg_data (d: D): functor_fix_fst_arg C D E F c d --> functor_fix_fst_arg C D E F c' d. Proof. apply (#F). exact (make_dirprod g (identity d)). Defined. Lemma nat_trans_from_functor_fix_fst_morphism_arg_ax: is_nat_trans _ _ nat_trans_from_functor_fix_fst_morphism_arg_data. Proof. red. intros d d' f. unfold nat_trans_from_functor_fix_fst_morphism_arg_data. unfold functor_fix_fst_arg; cbn. unfold functor_fix_fst_arg_mor; simpl. eapply pathscomp0. 2: { apply functor_comp. } apply pathsinv0. eapply pathscomp0. 2: { apply functor_comp. } apply maponpaths. unfold compose. cbn. do 2 rewrite id_left. do 2 rewrite id_right. apply idpath. Qed. Definition nat_trans_from_functor_fix_fst_morphism_arg: functor_fix_fst_arg C D E F c ⟹ functor_fix_fst_arg C D E F c'. Proof. use tpair. - intro d. apply nat_trans_from_functor_fix_fst_morphism_arg_data. - cbn. exact nat_trans_from_functor_fix_fst_morphism_arg_ax. Defined. End nat_trans_from_functor_fix_fst_morphism_arg. Section nat_trans_fix_fst_arg. Variable C D E : category. Variable F F' : (C × D) ⟶ E. Variable α : F ⟹ F'. Variable c : C. Definition nat_trans_fix_fst_arg_data (d: D): functor_fix_fst_arg C D E F c d --> functor_fix_fst_arg C D E F' c d := α (tpair _ c d). Lemma nat_trans_fix_fst_arg_ax: is_nat_trans _ _ nat_trans_fix_fst_arg_data. Proof. red. intros d d' f. unfold nat_trans_fix_fst_arg_data, functor_fix_fst_arg; simpl. unfold functor_fix_fst_arg_mor; simpl. assert (nat_trans_ax_inst := nat_trans_ax α). apply nat_trans_ax_inst. Qed. Definition nat_trans_fix_fst_arg: functor_fix_fst_arg C D E F c ⟹ functor_fix_fst_arg C D E F' c := tpair _ nat_trans_fix_fst_arg_data nat_trans_fix_fst_arg_ax. End nat_trans_fix_fst_arg. Section nat_z_iso_fix_fst_arg. Variable C D E : category. Variable F F' : (C × D) ⟶ E. Variable α : nat_z_iso F F'. Variable c : C. Let nattrans := (nat_trans_fix_fst_arg _ _ _ _ _ α c). Lemma nat_z_iso_fix_fst_arg_ax: is_nat_z_iso (nat_trans_fix_fst_arg _ _ _ _ _ α c). Proof. intro d. use (pr2_nat_z_iso α). Defined. Definition nat_z_iso_fix_fst_arg: nat_z_iso (functor_fix_fst_arg C D E F c) (functor_fix_fst_arg C D E F' c) := make_nat_z_iso _ _ nattrans nat_z_iso_fix_fst_arg_ax. End nat_z_iso_fix_fst_arg. Section functor_fix_snd_arg. Variable C D E : precategory. Variable F : functor (precategory_binproduct C D) E. Variable d : D. Definition functor_fix_snd_arg_ob (c: C): E := F (tpair _ c d). Definition functor_fix_snd_arg_mor (c c': C)(f: c --> c'): functor_fix_snd_arg_ob c --> functor_fix_snd_arg_ob c'. Proof. apply (#F). exact (make_dirprod f (identity d)). Defined. Definition functor_fix_snd_arg_data : functor_data C E := tpair _ functor_fix_snd_arg_ob functor_fix_snd_arg_mor. Lemma is_functor_functor_fix_snd_arg_data: is_functor functor_fix_snd_arg_data. Proof. split. + intros c. unfold functor_fix_snd_arg_data; simpl. unfold functor_fix_snd_arg_mor; simpl. unfold functor_fix_snd_arg_ob; simpl. assert (functor_id_inst := functor_id F). rewrite <- functor_id_inst. apply maponpaths. apply idpath. + intros c c' c'' f g. unfold functor_fix_snd_arg_data; simpl. unfold functor_fix_snd_arg_mor; simpl. assert (functor_comp_inst := @functor_comp _ _ F (make_dirprod c d) (make_dirprod c' d) (make_dirprod c'' d)). rewrite <- functor_comp_inst. apply maponpaths. unfold compose at 2. unfold precategory_binproduct; simpl. rewrite id_left. apply idpath. Qed. Definition functor_fix_snd_arg: C ⟶ E. Proof. exists functor_fix_snd_arg_data. exact is_functor_functor_fix_snd_arg_data. Defined. End functor_fix_snd_arg. Section nat_trans_from_functor_fix_snd_morphism_arg. Variable C D E : category. Variable F : (C × D) ⟶ E. Variable d d' : D. Variable f: d --> d'. Definition nat_trans_from_functor_fix_snd_morphism_arg_data (c: C): functor_fix_snd_arg C D E F d c --> functor_fix_snd_arg C D E F d' c. Proof. apply (#F). exact (make_dirprod (identity c) f). Defined. Lemma nat_trans_from_functor_fix_snd_morphism_arg_ax: is_nat_trans _ _ nat_trans_from_functor_fix_snd_morphism_arg_data. Proof. red. intros c c' g. unfold nat_trans_from_functor_fix_snd_morphism_arg_data. unfold functor_fix_snd_arg; cbn. unfold functor_fix_snd_arg_mor; simpl. eapply pathscomp0. 2: { apply functor_comp. } apply pathsinv0. eapply pathscomp0. 2: { apply functor_comp. } apply maponpaths. unfold compose. cbn. do 2 rewrite id_left. do 2 rewrite id_right. apply idpath. Qed. Definition nat_trans_from_functor_fix_snd_morphism_arg: functor_fix_snd_arg C D E F d ⟹ functor_fix_snd_arg C D E F d'. Proof. use tpair. - intro c. apply nat_trans_from_functor_fix_snd_morphism_arg_data. - cbn. exact nat_trans_from_functor_fix_snd_morphism_arg_ax. Defined. End nat_trans_from_functor_fix_snd_morphism_arg. Section nat_trans_fix_snd_arg. Variable C D E : category. Variable F F': (C × D) ⟶ E. Variable α: F ⟹ F'. Variable d: D. Definition nat_trans_fix_snd_arg_data (c:C): functor_fix_snd_arg C D E F d c --> functor_fix_snd_arg C D E F' d c := α (tpair _ c d). Lemma nat_trans_fix_snd_arg_ax: is_nat_trans _ _ nat_trans_fix_snd_arg_data. Proof. red. intros c c' f. unfold nat_trans_fix_snd_arg_data, functor_fix_snd_arg; simpl. unfold functor_fix_snd_arg_mor; simpl. assert (nat_trans_ax_inst := nat_trans_ax α). apply nat_trans_ax_inst. Qed. Definition nat_trans_fix_snd_arg: functor_fix_snd_arg C D E F d ⟹ functor_fix_snd_arg C D E F' d := tpair _ nat_trans_fix_snd_arg_data nat_trans_fix_snd_arg_ax. End nat_trans_fix_snd_arg. (* Define pairs of functors and functors from pr1 and pr2 *) Section functors. Definition pair_functor_data {A B C D : category} (F : A ⟶ C) (G : B ⟶ D) : functor_data (A × B) (C × D). Proof. use tpair. - intro x; apply (make_catbinprod (F (pr1 x)) (G (pr2 x))). - intros x y f; simpl; apply (catbinprodmor (# F (pr1 f)) (# G (pr2 f))). Defined. Definition pair_functor {A B C D : category} (F : A ⟶ C) (G : B ⟶ D) : (A × B) ⟶ (C × D). Proof. apply (tpair _ (pair_functor_data F G)). abstract (split; [ intro x; simpl; rewrite !functor_id; apply idpath | intros x y z f g; simpl; rewrite !functor_comp; apply idpath]). Defined. Definition pr1_functor_data (A B : category) : functor_data (A × B) A. Proof. use tpair. - intro x; apply (pr1 x). - intros x y f; simpl; apply (pr1 f). Defined. Definition pr1_functor (A B : category) : (A × B) ⟶ A. Proof. apply (tpair _ (pr1_functor_data A B)). abstract (split; [ intro x; apply idpath | intros x y z f g; apply idpath ]). Defined. Definition pr2_functor_data (A B : category) : functor_data (A × B) B. Proof. use tpair. - intro x; apply (pr2 x). - intros x y f; simpl; apply (pr2 f). Defined. Definition pr2_functor (A B : category) : (A × B) ⟶ B. Proof. apply (tpair _ (pr2_functor_data A B)). abstract (split; [ intro x; apply idpath | intros x y z f g; apply idpath ]). Defined. Definition bindelta_functor_data (C : category) : functor_data C (C × C). Proof. use tpair. - intro x; apply (make_catbinprod x x). - intros x y f; simpl; apply (catbinprodmor f f). Defined. (* The diagonal functor Δ *) Definition bindelta_functor (C : category) : C ⟶ (C × C). Proof. apply (tpair _ (bindelta_functor_data C)). abstract (split; [ intro x; apply idpath | intros x y z f g; apply idpath ]). Defined. Definition bindelta_pair_functor_data (C D E : category) (F : C ⟶ D) (G : C ⟶ E) : functor_data C (category_binproduct D E). Proof. use tpair. - intro c. apply (make_catbinprod (F c) (G c)). - intros x y f. simpl. apply (catbinprodmor (# F f) (# G f)). Defined. Lemma is_functor_bindelta_pair_functor_data (C D E : category) (F : C ⟶ D) (G : C ⟶ E) : is_functor (bindelta_pair_functor_data _ _ _ F G). Proof. split. - intro c. simpl. rewrite functor_id. rewrite functor_id. apply idpath. - intros c c' c'' f g. simpl. rewrite functor_comp. rewrite functor_comp. apply idpath. Qed. Definition bindelta_pair_functor {C D E : category} (F : C ⟶ D) (G : C ⟶ E) : C ⟶ (D × E). Proof. apply (tpair _ (bindelta_pair_functor_data C D E F G)). apply is_functor_bindelta_pair_functor_data. Defined. Definition bindelta_pair_functor_alt {C D E : category} (F : C ⟶ D) (G : C ⟶ E) : C ⟶ (D × E) := functor_composite (bindelta_functor C) (pair_functor F G). Lemma bindelta_pair_functor_alt_eq_bindelta_pair_functor {C D E : category} (F : C ⟶ D) (G : C ⟶ E) : bindelta_pair_functor_alt F G = bindelta_pair_functor F G. Proof. apply functor_eq. - apply (D × E). - apply idpath. Qed. (** Projections of `bindelta_pair_functor` *) Definition bindelta_pair_pr1_data {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : nat_trans_data (bindelta_pair_functor F G ∙ pr1_functor _ _) F := λ _, identity _. Definition bindelta_pair_pr1_is_nat_trans {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : is_nat_trans _ _ (bindelta_pair_pr1_data F G). Proof. intros x y f ; cbn ; unfold bindelta_pair_pr1_data. rewrite id_left, id_right. apply idpath. Qed. Definition bindelta_pair_pr1 {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : bindelta_pair_functor F G ∙ pr1_functor _ _ ⟹ F. Proof. use make_nat_trans. - exact (bindelta_pair_pr1_data F G). - exact (bindelta_pair_pr1_is_nat_trans F G). Defined. Definition bindelta_pair_pr1_z_iso {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : nat_z_iso (bindelta_pair_functor F G ∙ pr1_functor _ _) F. Proof. use make_nat_z_iso. - exact (bindelta_pair_pr1 F G). - intro. apply identity_is_z_iso. Defined. Definition bindelta_pair_pr2_data {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : nat_trans_data (bindelta_pair_functor F G ∙ pr2_functor _ _) G := λ _, identity _. Definition bindelta_pair_pr2_is_nat_trans {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : is_nat_trans _ _ (bindelta_pair_pr2_data F G). Proof. intros x y f ; cbn ; unfold bindelta_pair_pr1_data. rewrite id_left, id_right. apply idpath. Qed. Definition bindelta_pair_pr2 {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : bindelta_pair_functor F G ∙ pr2_functor _ _ ⟹ G. Proof. use make_nat_trans. - exact (bindelta_pair_pr2_data F G). - exact (bindelta_pair_pr2_is_nat_trans F G). Defined. Definition bindelta_pair_pr2_z_iso {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₁ ⟶ C₃) : nat_z_iso (bindelta_pair_functor F G ∙ pr2_functor _ _) G. Proof. use make_nat_z_iso. - exact (bindelta_pair_pr2 F G). - intro. apply identity_is_z_iso. Defined. (* A swapping functor σ : C × D → D × C. *) Definition binswap_pair_functor {C D : category} : (C × D) ⟶ (D × C) := bindelta_functor (C × D) ∙ pair_functor (pr2_functor C D) (pr1_functor C D). (* Reversing the order of three arguments *) Definition reverse_three_args {C D E : category} : ((C × D) × E) ⟶ ((E × D) × C). Proof. use (functor_composite (precategory_binproduct_unassoc _ _ _)). use (functor_composite binswap_pair_functor). exact (pair_functor binswap_pair_functor (functor_identity _)). Defined. Lemma reverse_three_args_ok {C D E : category} : functor_on_objects (reverse_three_args(C:=C)(D:=D)(E:=E)) = λ c, ((pr2 c, pr2 (pr1 c)), pr1 (pr1 c)). Proof. apply idpath. Qed. Lemma reverse_three_args_idempotent {C D E : category} : functor_composite (reverse_three_args(C:=C)(D:=D)(E:=E))(reverse_three_args(C:=E)(D:=D)(E:=C)) = functor_identity _. Proof. apply functor_eq. - repeat (apply has_homsets_precategory_binproduct; try apply homset_property). - use functor_data_eq. + cbn. intro cde. apply idpath. + intros cde1 cde2 f. cbn. apply idpath. Qed. End functors. Section whiskering. (** Postwhiskering with parameter *) Definition nat_trans_data_post_whisker_fst_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (P × C) ⟶ D): nat_trans_data (functor_composite (pair_functor (functor_identity _) G) K) (functor_composite (pair_functor (functor_identity _) H) K) := λ pb : P × B, #K ((identity (ob1 pb),, γ (ob2 pb)): (P × C)⟦ob1 pb,, G(ob2 pb), ob1 pb,, H(ob2 pb)⟧). Lemma is_nat_trans_post_whisker_fst_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (P × C) ⟶ D): is_nat_trans _ _ (nat_trans_data_post_whisker_fst_param γ K). Proof. intros pb pb' f. cbn. unfold nat_trans_data_post_whisker_fst_param. eapply pathscomp0. 2: { apply functor_comp. } eapply pathscomp0. { apply pathsinv0. apply functor_comp. } apply maponpaths. unfold compose; cbn. rewrite id_left. rewrite id_right. apply maponpaths. apply (nat_trans_ax γ). Qed. Definition post_whisker_fst_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (P × C) ⟶ D): (functor_composite (pair_functor (functor_identity _) G) K) ⟹ (functor_composite (pair_functor (functor_identity _) H) K) := make_nat_trans _ _ _ (is_nat_trans_post_whisker_fst_param γ K). Definition nat_trans_data_post_whisker_snd_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (C × P) ⟶ D): nat_trans_data (functor_composite (pair_functor G (functor_identity _)) K) (functor_composite (pair_functor H (functor_identity _)) K) := λ bp : B × P, #K ((γ (ob1 bp),, identity (ob2 bp)): (C × P)⟦G(ob1 bp),, ob2 bp, H(ob1 bp),, ob2 bp⟧). Lemma is_nat_trans_post_whisker_snd_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (C × P) ⟶ D): is_nat_trans _ _ (nat_trans_data_post_whisker_snd_param γ K). Proof. intros bp bp' f. cbn. unfold nat_trans_data_post_whisker_snd_param. eapply pathscomp0. 2: { apply functor_comp. } eapply pathscomp0. { apply pathsinv0. apply functor_comp. } apply maponpaths. unfold compose; cbn. rewrite id_left. rewrite id_right. apply (maponpaths (λ x, make_dirprod x (pr2 f))). apply (nat_trans_ax γ). Qed. Definition post_whisker_snd_param {B C D P: category} {G H : B ⟶ C} (γ : G ⟹ H) (K : (C × P) ⟶ D): (functor_composite (pair_functor G (functor_identity _)) K) ⟹ (functor_composite (pair_functor H (functor_identity _)) K) := make_nat_trans _ _ _ (is_nat_trans_post_whisker_snd_param γ K). End whiskering. Section Currying. (** we will "Curry away" the first argument - for our intended use with actions *) Context (C D E : category). Section Def_Curry_Ob. Context (F: (C × D) ⟶ E). Definition curry_functor_data: functor_data D [C, E]. Proof. use make_functor_data. - intro d. exact (functor_fix_snd_arg C D E F d). - intros d d' f. exact (nat_trans_from_functor_fix_snd_morphism_arg C D E F d d' f). Defined. Lemma curry_functor_data_is_functor: is_functor curry_functor_data. Proof. split. - intro d. apply (nat_trans_eq E). intro c. cbn. unfold nat_trans_from_functor_fix_snd_morphism_arg_data. etrans. { apply maponpaths. apply binprod_id. } apply functor_id. - intros d1 d2 d3 f g. apply (nat_trans_eq E). intro c. cbn. unfold nat_trans_from_functor_fix_snd_morphism_arg_data. etrans. 2: { apply functor_comp. } apply maponpaths. apply dirprodeq; cbn. + apply pathsinv0. apply id_left. + apply idpath. Qed. Definition curry_functor: D ⟶ [C, E] := make_functor curry_functor_data curry_functor_data_is_functor. End Def_Curry_Ob. Section Def_Curry_Mor. Context {F G: (C × D) ⟶ E} (α: F ⟹ G). Definition curry_nattrans : curry_functor F ⟹ curry_functor G. Proof. use make_nat_trans. - intro d. exact (nat_trans_fix_snd_arg _ _ _ _ _ α d). - intros d d' f. apply nat_trans_eq; try exact E. intro c. cbn. unfold nat_trans_from_functor_fix_snd_morphism_arg_data, nat_trans_fix_snd_arg_data. apply nat_trans_ax. Defined. End Def_Curry_Mor. Section Def_Uncurry_Ob. Context (G: D ⟶ [C, E]). Definition uncurry_functor_data: functor_data (C × D) E. Proof. use make_functor_data. - intro cd. induction cd as [c d]. exact (pr1 (G d) c). - intros cd cd' ff'. induction cd as [c d]. induction cd' as [c' d']. induction ff' as [f f']. cbn in *. exact (#(G d: functor C E) f · pr1 (#G f') c'). Defined. Lemma uncurry_functor_data_is_functor: is_functor uncurry_functor_data. Proof. split. - intro cd. induction cd as [c d]. cbn. rewrite functor_id. rewrite id_left. assert (H := functor_id G d). apply (maponpaths (fun f => pr1 f c)) in H. exact H. - intros cd1 cd2 cd3 ff' gg'. induction cd1 as [c1 d1]. induction cd2 as [c2 d2]. induction cd3 as [c3 d3]. induction ff' as [f f']. induction gg' as [g g']. cbn in *. rewrite functor_comp. assert (H := functor_comp G f' g'). apply (maponpaths (fun f => pr1 f c3)) in H. etrans. { apply maponpaths. exact H. } cbn. repeat rewrite assoc. apply cancel_postcomposition. repeat rewrite <- assoc. apply maponpaths. apply nat_trans_ax. Qed. Definition uncurry_functor: (C × D) ⟶ E := make_functor uncurry_functor_data uncurry_functor_data_is_functor. End Def_Uncurry_Ob. Section Def_Uncurry_Mor. Context {F G: D ⟶ [C, E]} (α: F ⟹ G). Definition uncurry_nattrans : uncurry_functor F ⟹ uncurry_functor G. Proof. use make_nat_trans. - intro cd. cbn. exact (pr1 (α (pr2 cd)) (pr1 cd)). - intros cd cd' fg. induction cd as [c d]. induction cd' as [c' d']. induction fg as [f g]. cbn in *. assert (aux := nat_trans_ax α d d' g). apply (maponpaths pr1) in aux. apply toforallpaths in aux. assert (auxinst := aux c'). rewrite <- assoc. etrans. { apply maponpaths. exact auxinst. } clear aux auxinst. cbn. do 2 rewrite assoc. apply cancel_postcomposition. apply nat_trans_ax. Defined. End Def_Uncurry_Mor. Lemma uncurry_after_curry (F: (C × D) ⟶ E): uncurry_functor (curry_functor F) = F. Proof. apply functor_eq. { exact E. } (* UniMath.MoreFoundations.Tactics.show_id_type. *) use functor_data_eq. - intro cd; apply idpath. - cbn. intros cd cd' ff'. induction cd as [c d]. induction cd' as [c' d']. induction ff' as [f f']. cbn in *. unfold functor_fix_snd_arg_mor, nat_trans_from_functor_fix_snd_morphism_arg_data. etrans. { apply pathsinv0. apply functor_comp. } unfold compose. cbn. rewrite id_left, id_right. apply idpath. Qed. Lemma curry_after_uncurry_pointwise (G: D ⟶ [C, E]) (d: D) : pr1 (curry_functor (uncurry_functor G)) d = pr1 G d. Proof. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply functor_eq. { exact E. } use functor_data_eq. - intro c. apply idpath. - cbn. intros c c' f. assert (H := functor_id G d). apply (maponpaths (fun f => pr1 f c')) in H. etrans. { apply maponpaths. exact H. } apply id_right. Qed. End Currying. Section Evaluation. (** functor evaluation is the pointwise counit of the biadjunction behind currying and uncurrying for the indended use, we need to switch the order of arguments *) Context {C D : category}. Definition evaluation_functor: ([C, D] × C) ⟶ D. Proof. apply (functor_composite (@binswap_pair_functor _ _)). apply (uncurry_functor). exact (functor_identity _). Defined. Goal ∏ (F: C ⟶ D) (c: C), evaluation_functor (F ,, c) = F c. Proof. intros. apply idpath. Qed. End Evaluation. Section EvaluationNatTrans. Context {C D₁ D₂ : category} (F G : D₁ ⟶ functor_category C D₂) (α : bindelta_pair_functor (pr1_functor D₁ C ∙ F) (pr2_functor D₁ C ∙ functor_identity C) ∙ bindelta_functor (category_binproduct [C, D₂] C) ∙ pair_functor (pr2_functor [C, D₂] C) (pr1_functor [C, D₂] C) ∙ uncurry_functor _ _ _ (functor_identity _) ⟹ bindelta_pair_functor (pr1_functor D₁ C ∙ G) (pr2_functor D₁ C ∙ functor_identity C) ∙ bindelta_functor (category_binproduct [C, D₂] C) ∙ pair_functor (pr2_functor [C, D₂] C) (pr1_functor [C, D₂] C) ∙ uncurry_functor _ _ _ (functor_identity _)). Definition evaluation_nat_trans_data_point (x : D₁) : nat_trans_data (F x : _ ⟶ _) (G x : _ ⟶ _) := λ y, α (x ,, y). Definition evaluation_nat_trans_data_point_is_nat_trans (x : D₁) : is_nat_trans _ _ (evaluation_nat_trans_data_point x). Proof. intros y₁ y₂ g ; unfold evaluation_nat_trans_data_point ; cbn. pose (nat_trans_ax α (x ,, y₁) (x ,, y₂) (identity _ ,, g)) as p. cbn in p. rewrite (functor_id F), (functor_id G) in p. rewrite !id_right in p. exact p. Qed. Definition evaluation_nat_trans_data : nat_trans_data F G. Proof. intro x. use make_nat_trans. - exact (evaluation_nat_trans_data_point x). - exact (evaluation_nat_trans_data_point_is_nat_trans x). Defined. Definition evaluation_nat_trans_is_nat_trans : is_nat_trans _ _ evaluation_nat_trans_data. Proof. intros x₁ x₂ f. use nat_trans_eq. { apply homset_property. } intros y ; cbn. pose (nat_trans_ax α (x₁ ,, y) (x₂ ,, y) (f ,, identity _)) as p. cbn in p. rewrite (functor_id (F _)), (functor_id (G _)) in p. rewrite !id_left in p. exact p. Qed. Definition evaluation_nat_trans : F ⟹ G. Proof. use make_nat_trans. - exact evaluation_nat_trans_data. - exact evaluation_nat_trans_is_nat_trans. Defined. End EvaluationNatTrans. (** Currying but with the product in a different order *) Section CurryFunctor. Context {C D₁ D₂ : category} (F : category_binproduct D₁ C ⟶ D₂). Definition curry_functor'_point_data (x : D₁) : functor_data C D₂. Proof. use make_functor_data. - exact (λ y, F (x ,, y)). - refine (λ y₁ y₂ g, #F (_ ,, _)). + exact (identity x). + exact g. Defined. Definition curry_functor'_point_is_functor (x : D₁) : is_functor (curry_functor'_point_data x). Proof. split. - intro y ; cbn. apply (functor_id F). - intros y₁ y₂ y₃ g₁ g₂ ; cbn. refine (_ @ functor_comp F _ _) ; cbn. rewrite id_left. apply idpath. Qed. Definition curry_functor'_point (x : D₁) : C ⟶ D₂. Proof. use make_functor. - exact (curry_functor'_point_data x). - exact (curry_functor'_point_is_functor x). Defined. Definition curry_functor'_mor {x₁ x₂ : D₁} (f : x₁ --> x₂) : curry_functor'_point x₁ ⟹ curry_functor'_point x₂. Proof. use make_nat_trans. - refine (λ y, #F (_ ,, _)). + exact f. + exact (identity y). - abstract (intros y₁ y₂ g ; cbn ; rewrite <- !(functor_comp F) ; cbn ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition curry_functor'_data : functor_data D₁ (functor_precategory_data C D₂). Proof. use make_functor_data. - exact curry_functor'_point. - exact @curry_functor'_mor. Defined. Definition curry_functor'_is_functor : is_functor curry_functor'_data. Proof. split. - intro x. use nat_trans_eq. { apply homset_property. } intro y ; cbn. apply (functor_id F). - intros x₁ x₂ x₃ f₁ f₂. use nat_trans_eq. { apply homset_property. } intro y ; cbn. refine (_ @ functor_comp F _ _). cbn. rewrite id_left. apply idpath. Qed. Definition curry_functor' : D₁ ⟶ functor_category C D₂. Proof. use make_functor. - exact curry_functor'_data. - exact curry_functor'_is_functor. Defined. Definition evaluate_curry_functor' : bindelta_pair_functor (pr1_functor D₁ C ∙ curry_functor') (pr2_functor D₁ C ∙ functor_identity _) ∙ evaluation_functor ⟹ F. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x₁ x₂ f ; cbn ; rewrite <- !(functor_comp F) ; cbn ; rewrite !id_left, !id_right ; apply idpath). Defined. Definition evaluate_curry_functor'_nat_z_iso : nat_z_iso (bindelta_pair_functor (pr1_functor D₁ C ∙ curry_functor') (pr2_functor D₁ C ∙ functor_identity _) ∙ evaluation_functor) F. Proof. use make_nat_z_iso. - exact evaluate_curry_functor'. - intro x. apply identity_is_z_iso. Defined. End CurryFunctor. Section Coevaluation. (** for completeness, we also define the pointwise unit of that biadjunction *) Context {C D : category}. Definition coevaluation_functor: C ⟶ [D, C × D]. Proof. apply curry_functor. apply binswap_pair_functor. Defined. End Coevaluation. Section CategoryBinproductIsoWeq. Context {C D : category} (x y : category_binproduct C D). Definition category_binproduct_z_iso_map : z_iso (pr1 x) (pr1 y) × z_iso (pr2 x) (pr2 y) → z_iso x y. Proof. intros i. simple refine ((pr11 i ,, pr12 i) ,, _). apply is_z_iso_binprod_z_iso. - exact (pr21 i). - exact (pr22 i). Defined. Definition category_binproduct_z_iso_inv : z_iso x y → z_iso (pr1 x) (pr1 y) × z_iso (pr2 x) (pr2 y) := λ i, functor_on_z_iso (pr1_functor C D) i ,, functor_on_z_iso (pr2_functor C D) i. Definition category_binproduct_z_iso_weq : z_iso (pr1 x) (pr1 y) × z_iso (pr2 x) (pr2 y) ≃ z_iso x y. Proof. use make_weq. - exact category_binproduct_z_iso_map. - use isweq_iso. + exact category_binproduct_z_iso_inv. + abstract (intros i ; use pathsdirprod ; (use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ]) ; apply idpath). + abstract (intros i ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. (* Definition category_binproduct_iso_map : iso (pr1 x) (pr1 y) × iso (pr2 x) (pr2 y) → iso x y. Proof. intros i. simple refine ((pr11 i ,, pr12 i) ,, _). apply is_iso_binprod_iso. - exact (pr21 i). - exact (pr22 i). Defined. Definition category_binproduct_iso_inv : iso x y → iso (pr1 x) (pr1 y) × iso (pr2 x) (pr2 y) := λ i, functor_on_iso (pr1_functor C D) i ,, functor_on_iso (pr2_functor C D) i. Definition category_binproduct_iso_weq : iso (pr1 x) (pr1 y) × iso (pr2 x) (pr2 y) ≃ iso x y. Proof. use make_weq. - exact category_binproduct_iso_map. - use isweq_iso. + exact category_binproduct_iso_inv. + abstract (intros i ; use pathsdirprod ; (use subtypePath ; [ intro ; apply isaprop_is_iso | ]) ; apply idpath). + abstract (intros i ; use subtypePath ; [ intro ; apply isaprop_is_iso | ] ; apply idpath). Defined. *) End CategoryBinproductIsoWeq. Section Univalence. Context {C D : category} (HC : is_univalent C) (HD : is_univalent D). Definition is_univalent_category_binproduct : is_univalent (category_binproduct C D). Proof. intros x y. use weqhomot. - exact (category_binproduct_z_iso_weq x y ∘ weqdirprodf (make_weq _ (HC _ _)) (make_weq _ (HD _ _)) ∘ pathsdirprodweq)%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; cbn ; apply idpath). Defined. End Univalence. Definition univalent_category_binproduct (C₁ C₂ : univalent_category) : univalent_category. Proof. use make_univalent_category. - exact (category_binproduct C₁ C₂). - use is_univalent_category_binproduct. + exact (pr2 C₁). + exact (pr2 C₂). Defined. Definition product_of_commuting_squares {C1 C2 C3 C4 : category} {D1 D2 D3 D4 : category} {F1 : functor C1 C2} {F2 : functor C2 C4} {F1' : functor C1 C3} {F2' : functor C3 C4} {G1 : functor D1 D2} {G2 : functor D2 D4} {G1' : functor D1 D3} {G2' : functor D3 D4} (α : nat_z_iso (F1 ∙ F2) (F1' ∙ F2')) (β : nat_z_iso (G1 ∙ G2) (G1' ∙ G2')) : nat_z_iso (pair_functor F1 G1 ∙ pair_functor F2 G2) (pair_functor F1' G1' ∙ pair_functor F2' G2'). Proof. use make_nat_z_iso. - use make_nat_trans. + intro. use catbinprodmor. * apply α. * apply β. + abstract (intro ; intros ; use total2_paths_f ; [ apply (pr21 α) | rewrite transportf_const ; apply (pr21 β) ]). - intro. use is_z_iso_binprod_z_iso. + apply (pr2 α (pr1 _)). + apply (pr2 β (pr2 _)). Defined. Section PairingWithAnObject. Definition pair_with_object_left_data {C : category} (I : C) : functor_data C (C × C). Proof. exists (λ x, (I,x)). exact (λ x y f, (identity I #, f)). Defined. Definition pair_with_object_left_is_functor {C : category} (I : C) : is_functor (pair_with_object_left_data I). Proof. split ; intro ; intros ; simpl. - apply idpath. - etrans. 2: { apply binprod_comp. } apply maponpaths_2. apply (! id_right _). Qed. Definition pair_with_object_left {C : category} (I : C) : functor C (C × C) := pair_with_object_left_data I ,, pair_with_object_left_is_functor I. Definition pair_with_object_right_data {C : category} (I : C) : functor_data C (C × C). Proof. exists (λ x, (x,I)). exact (λ x y f, (f #, identity I)). Defined. Definition pair_with_object_right_is_functor {C : category} (I : C) : is_functor (pair_with_object_right_data I). Proof. split ; intro ; intros ; simpl. - apply idpath. - etrans. 2: { apply binprod_comp. } apply maponpaths. apply (! id_right _). Qed. Definition pair_with_object_right {C : category} (I : C) : functor C (C × C) := pair_with_object_right_data I ,, pair_with_object_right_is_functor I. Lemma PairingWithObjectCommutesLeft {C D : category} (H : functor C D) (I : C) : nat_z_iso (H ∙ pair_with_object_left (H I)) (pair_with_object_left I ∙ (pair_functor H H)). Proof. use make_nat_z_iso. - exists (λ _, identity (H I, H _)). abstract ( intro ; intros ; refine (id_right (identity (H I) #, # H f) @ _) ; refine (_ @ ! id_left (# H (identity I) #, # H f)) ; apply maponpaths_2 ; apply (! functor_id H _)). - intro. exists (identity _). abstract (split ; apply (id_right (identity (H I, H _)))). Defined. Lemma PairingWithObjectCommutesRight {C D : category} (H : functor C D) (I : C) : nat_z_iso (H ∙ pair_with_object_right (H I)) (pair_with_object_right I ∙ (pair_functor H H)). Proof. use make_nat_z_iso. - exists (λ _, identity (H _, H I)). abstract ( intro ; intros ; refine (id_right (# H f #, identity (H I)) @ _) ; refine (_ @ ! id_left (# H f #, # H (identity I))) ; apply maponpaths ; apply (! functor_id H _)). - intro. exists (identity _). abstract (split ; apply (id_right (identity (H _, H I)))). Defined. Definition tensor_after_pair_with_object_left {C : category} (T : functor (C × C) C) (I : C) : nat_z_iso (functor_fix_fst_arg _ _ _ T I) (functor_composite (pair_with_object_left I) T). Proof. use make_nat_z_iso. - exists (λ _, identity _). abstract (intro ; intros ; exact (id_right _ @ ! id_left _)). - intro x. exists (identity _). abstract (split ; apply id_right). Defined. Definition tensor_after_pair_with_object_right {C : category} (T : functor (C × C) C) (I : C) : nat_z_iso (functor_fix_snd_arg _ _ _ T I) (functor_composite (pair_with_object_right I) T). Proof. use make_nat_z_iso. - exists (λ _, identity _). abstract (intro ; intros ; exact (id_right _ @ ! id_left _)). - intro x. exists (identity _). abstract (split ; apply id_right). Defined. End PairingWithAnObject. Definition category_op_binproduct {C D:category}: ((C^op) × (D^op)) ⟶ (C × D)^op. Proof. use make_functor. + use make_functor_data. - use idfun. - intros (c,d) (c',d'). use idfun. + split. - intro. apply idpath. - repeat intro. apply idpath. Defined. (** Taking the diagonal is a pseudofunctor *) Definition pair_nat_trans {C₁ C₂ C₁' C₂' : category} {F₁ F₂ : C₁ ⟶ C₁'} {G₁ G₂ : C₂ ⟶ C₂'} (τ : F₁ ⟹ F₂) (θ : G₁ ⟹ G₂) : pair_functor F₁ G₁ ⟹ pair_functor F₂ G₂. Proof. use make_nat_trans. - exact (λ x, τ (pr1 x) ,, θ (pr2 x)). - abstract (intros x y f ; cbn ; use pathsdirprod ; apply nat_trans_ax). Defined. UniMath-20231010/UniMath/CategoryTheory/PrecompEquivalence.v000066400000000000000000000414221451125700300236050ustar00rootroot00000000000000(**************************************************************** In this file, we combine the facts from `precomp_ess_surj.v` and `precomp_fully_faithful.v`. We show that if we have a fully faithful and essential surjective functor `F : C₁ ⟶ C₂` and a univalent category `D`, then we have an adjoint equivalence between `[ C₂ , D ]` and `[ C₁ , D ]` (the functor is given by precomposition). We also give some functions to use this adjoint equivalence. ****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.precomp_ess_surj. Require Import UniMath.CategoryTheory.precomp_fully_faithful. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Section PrecompEquivalence. Context {C₁ C₂ : category} (D : univalent_category) (F : C₁ ⟶ C₂) (HF₁ : essentially_surjective F) (HF₂ : fully_faithful F). Definition precomp_adjoint_equivalence : adj_equivalence_of_cats (pre_composition_functor C₁ C₂ (pr1 D) F). Proof. use rad_equivalence_of_cats. - apply is_univalent_functor_category. exact (pr2 D). - exact (pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful C₁ C₂ D F HF₁ HF₂). - exact (pre_composition_essentially_surjective C₁ C₂ D (pr2 D) F HF₁ HF₂). Defined. Let L : [ C₂ , D ] ⟶ [ C₁ , D ] := pre_composition_functor C₁ C₂ (pr1 D) F. Let R : [ C₁ , D ] ⟶ [ C₂ , D ] := right_adjoint precomp_adjoint_equivalence. Let ε : nat_z_iso (R ∙ L) (functor_identity _) := counit_nat_z_iso_from_adj_equivalence_of_cats precomp_adjoint_equivalence. Let η : nat_z_iso (functor_identity _) (L ∙ R) := unit_nat_z_iso_from_adj_equivalence_of_cats precomp_adjoint_equivalence. Definition lift_functor_along (G : C₁ ⟶ D) : C₂ ⟶ D := R G. Definition lift_functor_along_comm (G : C₁ ⟶ D) : nat_z_iso (F ∙ lift_functor_along G) G := nat_z_iso_from_z_iso _ (nat_z_iso_pointwise_z_iso ε G). Definition lift_nat_trans_along {G₁ G₂ : C₂ ⟶ D} (α : F ∙ G₁ ⟹ F ∙ G₂) : G₁ ⟹ G₂. Proof. exact (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ precomp_adjoint_equivalence G₁ G₂)) α). Defined. Definition lift_nat_trans_along_comm {G₁ G₂ : C₂ ⟶ D} (α : F ∙ G₁ ⟹ F ∙ G₂) : pre_whisker F (lift_nat_trans_along α) = α. Proof. exact (homotweqinvweq (make_weq _ (fully_faithful_from_equivalence _ _ _ precomp_adjoint_equivalence G₁ G₂)) α). Qed. Definition lift_nat_trans_eq_along {G₁ G₂ : C₂ ⟶ D} {β₁ β₂ : G₁ ⟹ G₂} (p : pre_whisker F β₁ = pre_whisker F β₂) : β₁ = β₂. Proof. exact (maponpaths pr1 (proofirrelevance _ (pr2 (fully_faithful_implies_full_and_faithful _ _ _ (fully_faithful_from_equivalence _ _ _ precomp_adjoint_equivalence)) G₁ G₂ (pre_whisker F β₂)) (β₁ ,, p) (β₂ ,, idpath _))). Qed. Definition lift_nat_z_iso_along {G₁ G₂ : C₂ ⟶ D} (α : nat_z_iso (F ∙ G₁) (F ∙ G₂)) : nat_z_iso G₁ G₂. Proof. exists (lift_nat_trans_along α). use is_functor_z_iso_pointwise_if_z_iso. { apply homset_property. } set (β := (z_iso_from_nat_z_iso (homset_property _) α)). set (ff_precomp := (fully_faithful_from_equivalence [C₂, pr1 D] [C₁, pr1 D] (pre_composition_functor C₁ C₂ (pr1 D) F) precomp_adjoint_equivalence)). exact (fully_faithful_reflects_iso_proof [C₂, pr1 D] [C₁, pr1 D] (pre_composition_functor _ _ D F) ff_precomp _ _ β ). Defined. End PrecompEquivalence. Section WeakEquivalenceProperties. Lemma iscontr_prod (A B : UU) : iscontr A -> iscontr B -> iscontr (A × B). Proof. intros p q. exists (pr1 p ,, pr1 q). intro t. use total2_paths_f. { apply (pr2 p). } rewrite transportf_const. apply (pr2 q). Qed. Context {C1 C2 D1 D2 : category} (F : functor C1 C2) (G : functor D1 D2). Definition pair_functor_ff (F_ff : fully_faithful F) (G_ff : fully_faithful G) : fully_faithful (pair_functor F G). Proof. intros cd cd' cd2. assert (hfiberprod : hfiber # (pair_functor F G) cd2 ≃ (hfiber # F (pr1 cd2) × hfiber # G (pr2 cd2))). { use weq_iso. - intro x. use tpair. + exists (pr11 x). exact (maponpaths pr1 (pr2 x)). + exists (pr21 x). etrans. 2: { apply maponpaths. apply x. } apply idpath. - intro xy. exists (catbinprodmor (pr11 xy) (pr12 xy)). use total2_paths_f. + exact (pr21 xy). + etrans. { exact (toforallpaths _ _ _ (transportf_const (pr21 xy) ( D2 ⟦ pr2 (pair_functor F G cd), pr2 (pair_functor F G cd') ⟧)) (pr2 (# (pair_functor F G) (catbinprodmor (pr11 xy) (pr12 xy))))). } exact (pr22 xy). - intro. use total2_paths_f. + apply idpath. + apply homset_property. - intro. use total2_paths_f. + use total2_paths_f. * apply idpath. * apply homset_property. + use total2_paths_f. * cbn. etrans. { apply maponpaths. rewrite transportf_const. apply idpath. } apply idpath. * apply homset_property. } use iscontrweqb'. 3: { apply hfiberprod. } apply iscontr_prod. - apply (F_ff (pr1 cd) (pr1 cd') (pr1 cd2)). - apply (G_ff (pr2 cd) (pr2 cd') (pr2 cd2)). Qed. Definition pair_functor_eso (F_eso : essentially_surjective F) (G_eso : essentially_surjective G) : essentially_surjective (pair_functor F G). Proof. intro cd2. use (factor_through_squash _ _ (F_eso (pr1 cd2))). { apply ishinh. } intro d1. use (factor_through_squash _ _ (G_eso (pr2 cd2))). { apply ishinh. } intro d2. apply hinhpr. exists (pr1 d1 ,, pr1 d2). use precatbinprod_z_iso. - exact (pr2 d1). - exact (pr2 d2). Qed. End WeakEquivalenceProperties. Section LiftedFunctorsIdentity. Definition lift_functor_along_id {C : category} (D : univalent_category) {F : functor C D} (F_eso : essentially_surjective F) (F_ff : fully_faithful F) : nat_z_iso (lift_functor_along D F F_eso F_ff (functor_identity C ∙ F)) (functor_identity D). Proof. use (lift_nat_z_iso_along D F F_eso F_ff). use nat_z_iso_comp. 2: apply lift_functor_along_comm. use make_nat_z_iso. - use make_nat_trans. { exact (λ _, identity _). } abstract (intro ; intros ; exact (id_right _ @ ! id_left _)). - intro. exists (identity _). abstract (split ; apply id_right). Defined. End LiftedFunctorsIdentity. Section LiftedFunctorsComposition. Context {C1 C2 C3 D1 : category} (D2 D3 : univalent_category) {F1 : functor C1 D1} {F2 : functor C2 D2} (F3 : functor C3 D3) (F1_eso : essentially_surjective F1) (F1_ff : fully_faithful F1) (F2_eso : essentially_surjective F2) (F2_ff : fully_faithful F2). Definition lift_functor_along_comp (G1 : functor C1 C2) (G2 : functor C2 C3) : nat_z_iso (lift_functor_along D3 F1 F1_eso F1_ff ((G1 ∙ G2) ∙ F3)) (lift_functor_along D2 F1 F1_eso F1_ff (G1 ∙ F2) ∙ lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3)). Proof. use (lift_nat_z_iso_along D3 F1 F1_eso F1_ff). set (l := lift_functor_along_comm D3 F2 F2_eso F2_ff (G2 ∙ F3)). set (l2_i := pre_whisker_on_nat_z_iso G1 (pr1 l) (pr2 l)). set (u := lift_functor_along_comm D2 F1 F1_eso F1_ff (G1 ∙ F2)). set (u2_i := post_whisker_z_iso_is_z_iso (pr1 u) (lift_functor_along D3 F2 F2_eso F2_ff ((G2 ∙ F3))) (pr2 u) ). transparent assert ( l2 : (nat_z_iso (functor_composite G1 (F2 ∙ lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3))) (functor_composite G1 (G2 ∙ F3)))). { use make_nat_z_iso. 2: exact l2_i. } transparent assert (u2 : (nat_z_iso (functor_composite (F1 ∙ lift_functor_along D2 F1 F1_eso F1_ff (G1 ∙ F2)) (lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3))) (functor_composite (G1 ∙ F2) (lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3))))). { use make_nat_z_iso. 2: exact u2_i. } use nat_z_iso_comp. 2: { apply lift_functor_along_comm. } use nat_z_iso_comp. 2: { exact (nat_z_iso_inv l2). } exact (nat_z_iso_inv u2). Defined. End LiftedFunctorsComposition. Section LiftedFunctorsPairFunctor. Lemma nat_z_iso_pair {C1 C2 D1 D2 E1 E2 : category} (F1 : functor C1 D1) (F2 : functor D1 E1) (G1 : functor C2 D2) (G2 : functor D2 E2) : nat_z_iso (pair_functor (F1 ∙ F2) (G1 ∙ G2)) (pair_functor F1 G1 ∙ pair_functor F2 G2). Proof. use make_nat_z_iso. - use make_nat_trans. + intro ; apply catbinprodmor ; apply identity. + abstract (intro ; intros ; use total2_paths_f ; [ exact (id_right _ @ ! id_left _) | rewrite transportf_const ; exact (id_right _ @ ! id_left _) ]). - intro. use make_is_z_isomorphism. + apply catbinprodmor ; apply identity. + abstract (split ; (use total2_paths_f ; [ apply id_right | rewrite transportf_const ; apply id_right ])). Defined. Lemma nat_z_iso_between_pair {C1 C2 D1 D2 : category} {F1 F1' : functor C1 D1} {G1 G1' : functor C2 D2} (α : nat_z_iso F1 F1') (β : nat_z_iso G1 G1') : nat_z_iso (pair_functor F1 G1) (pair_functor F1' G1'). Proof. use make_nat_z_iso. - use make_nat_trans. + intro ; apply catbinprodmor ; [apply α | apply β]. + abstract (intro ; intros ; use total2_paths_f ; [apply (pr1 α) | rewrite transportf_const ; apply (pr1 β)]). - intro. use tpair. + apply catbinprodmor ; [apply (pr2 α) | apply (pr2 β)]. + abstract (split ; (use total2_paths_f ; [apply (pr2 α) | rewrite transportf_const ; apply (pr2 β)])). Defined. Context {C1 C2 C1' C2' D1 D2 : category} (D1' D2' : univalent_category) {F1 : functor C1 D1} {F2 : functor C2 D2} (F1' : functor C1' D1') (F2' : functor C2' D2') (F1_eso : essentially_surjective F1) (F2_eso : essentially_surjective F2) (F1_ff : fully_faithful F1) (F2_ff : fully_faithful F2). Let FF := pair_functor F1 F2. Let FF' := pair_functor F1' F2'. Let FF_eso := pair_functor_eso _ _ F1_eso F2_eso. Let FF_ff := pair_functor_ff _ _ F1_ff F2_ff. Let DD' := (_ ,, is_univalent_category_binproduct (pr2 D1') (pr2 D2')) : univalent_category. Definition lift_functor_along_pair (H1 : functor C1 C1') (H2 : functor C2 C2') : nat_z_iso (lift_functor_along DD' FF FF_eso FF_ff (pair_functor H1 H2 ∙ pair_functor F1' F2')) (pair_functor (lift_functor_along D1' F1 F1_eso F1_ff (H1 ∙ F1')) (lift_functor_along D2' F2 F2_eso F2_ff (H2 ∙ F2'))). Proof. use (lift_nat_z_iso_along DD' FF FF_eso FF_ff). set (l := lift_functor_along_comm DD' FF FF_eso FF_ff (pair_functor H1 H2 ∙ pair_functor F1' F2')). use nat_z_iso_comp. 2: { exact l. } use nat_z_iso_comp. 3: { apply nat_z_iso_pair. } use nat_z_iso_comp. 2: { apply (nat_z_iso_inv (nat_z_iso_pair _ _ _ _)). } use nat_z_iso_between_pair ; apply (nat_z_iso_inv (lift_functor_along_comm _ _ _ _ _)). Defined. End LiftedFunctorsPairFunctor. Section LiftedFunctorsProperties. Lemma post_whisker_nat_z_iso {C D E : category} {F1 F2 : functor C D} (α : nat_z_iso F1 F2) (G : functor D E) : nat_z_iso (F1 ∙ G) (F2 ∙ G). Proof. use make_nat_z_iso. 2: { exact (post_whisker_z_iso_is_z_iso α G (pr2 α)). } Defined. Context {C : category} (D : univalent_category) (F1 : functor C D) (F1_eso : essentially_surjective F1) (F1_ff : fully_faithful F1). Let FF := pair_functor F1 F1. Let FF_ff := pair_functor_ff _ _ F1_ff F1_ff. Let FF_eso := pair_functor_eso _ _ F1_eso F1_eso. Let FFF := pair_functor FF F1. Let FFF_ff := pair_functor_ff _ _ FF_ff F1_ff. Let FFF_eso := pair_functor_eso _ _ FF_eso F1_eso. Let FFF' := pair_functor F1 FF. Let FFF'_ff := pair_functor_ff _ _ F1_ff FF_ff. Let FFF'_eso := pair_functor_eso _ _ F1_eso FF_eso. Let DD := (_ ,, is_univalent_category_binproduct (pr2 D) (pr2 D)) : univalent_category. Let DDD := (_ ,, is_univalent_category_binproduct (pr2 DD) (pr2 D)) : univalent_category. Let DDD' := (_ ,, is_univalent_category_binproduct (pr2 D) (pr2 DD)) : univalent_category. Lemma lift_functor_along_comm_prod (H : functor (category_binproduct C C) C) : nat_z_iso (lift_functor_along D FFF FFF_eso FFF_ff ((pair_functor H (functor_identity C) ∙ H) ∙ F1)) (pair_functor (lift_functor_along D FF FF_eso FF_ff (functor_composite H F1) ) (functor_identity D) ∙ (lift_functor_along D FF FF_eso FF_ff (functor_composite H F1)) ) . Proof. use nat_z_iso_comp. 2: { exact (lift_functor_along_comp DD D F1 FFF_eso FFF_ff FF_eso FF_ff (pair_functor H (functor_identity C)) H). } apply post_whisker_nat_z_iso. use nat_z_iso_comp. 2 : { apply lift_functor_along_pair. } use nat_z_iso_between_pair. - use make_nat_z_iso. 2: apply is_nat_z_iso_nat_trans_id. - apply lift_functor_along_id. Defined. Lemma lift_functor_along_comm_prod' (H : functor (category_binproduct C C) C) : nat_z_iso (lift_functor_along D FFF' FFF'_eso FFF'_ff ((pair_functor (functor_identity C) H ∙ H) ∙ F1)) (pair_functor (functor_identity D) (lift_functor_along D FF FF_eso FF_ff (functor_composite H F1) ) ∙ (lift_functor_along D FF FF_eso FF_ff (functor_composite H F1)) ) . Proof. use nat_z_iso_comp. 2: { exact (lift_functor_along_comp DD D F1 FFF'_eso FFF'_ff FF_eso FF_ff (pair_functor (functor_identity C) H) H). } apply post_whisker_nat_z_iso. use nat_z_iso_comp. 2 : { apply lift_functor_along_pair. } use nat_z_iso_between_pair. - apply lift_functor_along_id. - use make_nat_z_iso. 2: apply is_nat_z_iso_nat_trans_id. Defined. End LiftedFunctorsProperties. UniMath-20231010/UniMath/CategoryTheory/Presheaf.v000066400000000000000000000314611451125700300215550ustar00rootroot00000000000000(** **************************************************************************** Theory about set-valued presheaves. We write PreShv C for [C^op,HSET]. Contents: - Limits ([Lims_PreShv_of_shape]) - Colimits ([Colims_PreShv_of_shape]) - Binary products ([BinProducts_PreShv]) - Indexed products ([Products_PreShv]) - Binary coproducts ([BinCoproducts_PreShv]) - Indexed coproducts ([Coproducts_PreShv]) - Initial object ([Initial_PreShv]) - Terminal object ([Terminal_PreShv]) - Pullbacks ([Pullbacks_PreShv]) - Exponentials ([Exponentials_PreShv]) - Constant presheaf ([constant_PreShv]) - Definition of the subobject classifier (without proof) ([Ω_PreShv], [Ω_mor]) - Proof that [Ω_PreShv] is a bounded lattice object ([Ω_PreShv_lattice], [Ω_PreShv_bounded_lattice]) - Construction of isomorphisms of functors between presheaf categories ([make_PreShv_functor_iso]) Written by: Anders Mörtberg, 2017-2019 ********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Algebra.Monoids. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.LatticeObject. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.pullbacks. Local Open Scope cat. Notation "'PreShv' C" := [C^op, HSET] (at level 4) : cat. Section basics. Lemma transportf_PreShv {C : category} (F : PreShv C) {x y z : C} (e : x = y) (f : C⟦x,z⟧) (u : ((F : functor _ _) z : hSet)) : transportf (λ x, pr1 (pr1 F x)) e (# (pr1 F) f u) = # (pr1 F) (transportf (@precategory_morphisms C^op z) e f) u. Proof. now induction e. Qed. End basics. (** Various limits and colimits in PreShv C *) Section limits. Context {C : category}. (* This should be only small limits *) (* Lemma Lims_PreShv : Lims (PreShv C). *) (* Proof. *) (* now apply LimsFunctorCategory, LimsHSET. *) (* Defined. *) Lemma Lims_PreShv_of_shape (g : graph) : Lims_of_shape g (PreShv C). Proof. now apply LimsFunctorCategory_of_shape, LimsHSET_of_shape. Defined. (* This should be only small colimits *) (* Lemma Colims_PreShv : Colims (PreShv C). *) (* Proof. *) (* now apply ColimsFunctorCategory, ColimsHSET. *) (* Defined. *) Lemma Colims_PreShv_of_shape (g : graph) : Colims_of_shape g (PreShv C). Proof. now apply ColimsFunctorCategory_of_shape, ColimsHSET_of_shape. Defined. Lemma BinProducts_PreShv : BinProducts (PreShv C). Proof. now apply BinProducts_functor_precat, BinProductsHSET. Defined. Lemma Products_PreShv I : Products I (PreShv C). Proof. now apply Products_functor_precat, ProductsHSET. Defined. Lemma BinCoproducts_PreShv : BinCoproducts (PreShv C). Proof. now apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Lemma Coproducts_PreShv I (HI : isaset I) : Coproducts I (PreShv C). Proof. now apply Coproducts_functor_precat, CoproductsHSET, HI. Defined. Lemma Initial_PreShv : Initial (PreShv C). Proof. now apply Initial_functor_precat, InitialHSET. Defined. Lemma Terminal_PreShv : Terminal (PreShv C). Proof. now apply Terminal_functor_precat, TerminalHSET. Defined. Lemma Pullbacks_PreShv : Pullbacks (PreShv C). Proof. now apply FunctorcategoryPullbacks, PullbacksHSET. Defined. Lemma Exponentials_PreShv : Exponentials BinProducts_PreShv. Proof. now apply Exponentials_functor_HSET. Defined. End limits. (** * Define some standard presheaves *) Section presheaves. Context {C : category}. Definition constant_PreShv (A : HSET) : PreShv C. Proof. use make_functor. + use tpair. - intros _; apply A. - cbn. intros a b f. apply idfun. + now split. Defined. Definition empty_PreShv : PreShv C := constant_PreShv emptyHSET. End presheaves. (** * Definition of the subobject classifier in a presheaf. *) (** See: "Sheaves in Geometry and Logic" by Mac Lane and Moerdijk (page 37) *) (* TODO: Prove that Ω actually is the subobject classifier *) Section Ω_PreShv. Context {C : category}. Definition sieve_def (c : C) : UU. Proof. use total2. - apply (hsubtype (∑ (x : C),C⟦x,c⟧)). - intros S. apply (∏ (s1 : ∑ (x : C),C⟦x,c⟧), S s1 → ∏ y (f : C⟦y,pr1 s1⟧), S (y,, f · pr2 s1)). Defined. Lemma isaset_sieve (c : C) : isaset (sieve_def c). Proof. use isaset_total2. - apply isasethsubtype. - intros S; repeat (apply impred_isaset; intro); apply isasetaprop, propproperty. Qed. (* If I use HSET here the coercion isn't triggered later and I need to insert pr1 explicitly *) Definition sieve (c : C) : hSet := (sieve_def c,,isaset_sieve c). Definition pr1sieve {c : C} : sieve_def c → hsubtype _ := @pr1 _ _. Coercion pr1sieve : sieve_def >-> hsubtype. Lemma sieve_eq (c : C) (s t : sieve c) (H : pr1 s = pr1 t) : s = t. Proof. apply subtypePath; [|apply H]. now intros x; repeat (apply impred; intros); apply propproperty. Qed. Definition maximal_sieve (c : C) : sieve c. Proof. use tpair. - intro S; apply htrue. - cbn. intros; apply tt. Defined. Definition empty_sieve (c : C) : sieve c. Proof. use tpair. - intros S; apply hfalse. - intros f S y g; apply S. Defined. Definition intersection_sieve (c : C) : binop (sieve c). Proof. simpl; intros S1 S2. use tpair. - intros f. apply (S1 f ∧ S2 f). - simpl; intros f S f'. split. + apply (pr2 S1 _ (pr1 S)). + apply (pr2 S2 _ (pr2 S)). Defined. Definition union_sieve (c : C) : binop (sieve c). Proof. simpl; intros S1 S2. use tpair. - intros f. apply (S1 f ∨ S2 f). - intros f S y f'; simpl in S; apply S; clear S; intro S. apply hinhpr. induction S as [S|S]. + apply ii1, (pr2 S1 _ S). + apply ii2, (pr2 S2 _ S). Defined. Definition sieve_lattice (c : C) : lattice (sieve c). Proof. use make_lattice. - apply intersection_sieve. - apply union_sieve. - repeat split; intros S1; intros; apply sieve_eq, funextsec; intro f; simpl. + apply (isassoc_Lmin hProp_lattice). + apply (iscomm_Lmin hProp_lattice). + apply (isassoc_Lmax hProp_lattice). + apply (iscomm_Lmax hProp_lattice). + apply (Lmin_absorb hProp_lattice). + apply (Lmax_absorb hProp_lattice). Defined. Definition sieve_bounded_lattice (c : C) : bounded_lattice (sieve c). Proof. use make_bounded_lattice. - apply sieve_lattice. - apply empty_sieve. - apply maximal_sieve. - split; intros S; apply sieve_eq, funextsec; intro f; simpl. + apply (islunit_Lmax_Lbot hProp_bounded_lattice). + apply (islunit_Lmin_Ltop hProp_bounded_lattice). Defined. Definition sieve_mor a b (f : C⟦b,a⟧) : sieve a → sieve b. Proof. simpl; intros S. use tpair. - intros g. apply (S (pr1 g,,pr2 g · f)). - abstract (intros g H y h; simpl; rewrite <- assoc; apply (pr2 S (pr1 g,,pr2 g · f)), H). Defined. Local Definition Ω_PreShv_data : functor_data C^op HSET := (sieve,,sieve_mor). Local Lemma is_functor_Ω_PreShv_data : is_functor Ω_PreShv_data. Proof. split. - intros x; apply funextfun; intros [S hS]; simpl. apply subtypePath; simpl. + intros X; repeat (apply impred; intro); apply propproperty. + now apply funextsec; intro; rewrite id_right. - intros x y z f g; apply funextfun; intros [S hS]; simpl. apply subtypePath; simpl. + intros X; repeat (apply impred; intro); apply propproperty. + now repeat (apply funextsec; intro); rewrite <- assoc. Qed. Definition Ω_PreShv : PreShv C := (Ω_PreShv_data,,is_functor_Ω_PreShv_data). Definition Ω_mor : (PreShv C)⟦Terminal_PreShv,Ω_PreShv⟧. Proof. use make_nat_trans. - red; simpl; apply (λ c _, maximal_sieve c). - intros x y f; simpl in *; apply funextfun; cbn; intros _. apply sieve_eq; simpl. now repeat (apply funextsec; intros). Defined. Lemma isMonic_Ω_mor : isMonic Ω_mor. Proof. now apply from_terminal_isMonic. Qed. Local Notation "c ⊗ d" := (BinProductObject _ (BinProducts_PreShv c d)) : cat. Definition Ω_PreShv_meet : PreShv(C)⟦Ω_PreShv ⊗ Ω_PreShv,Ω_PreShv⟧. Proof. use make_nat_trans. + intros c S1S2. apply (intersection_sieve c (pr1 S1S2) (pr2 S1S2)). + intros x y f. apply funextsec; cbn; intros [S1 S2]. now apply sieve_eq. Defined. Definition Ω_PreShv_join : PreShv(C)⟦Ω_PreShv ⊗ Ω_PreShv,Ω_PreShv⟧. Proof. use make_nat_trans. + intros c S1S2. apply (union_sieve c (pr1 S1S2) (pr2 S1S2)). + intros x y f. apply funextsec; cbn; intros [S1 S2]. now apply sieve_eq. Defined. Definition Ω_PreShv_lattice : latticeob BinProducts_PreShv Ω_PreShv. Proof. use make_latticeob. + apply Ω_PreShv_meet. + apply Ω_PreShv_join. + repeat split; apply (nat_trans_eq has_homsets_HSET); intro c; apply funextsec; intros S; simpl. - apply (isassoc_Lmin (sieve_lattice c)). - apply (iscomm_Lmin (sieve_lattice c)). - apply (isassoc_Lmax (sieve_lattice c)). - apply (iscomm_Lmax (sieve_lattice c)). - apply (Lmin_absorb (sieve_lattice c)). - apply (Lmax_absorb (sieve_lattice c)). Defined. Definition Ω_PreShv_bottom : PreShv(C)⟦Terminal_PreShv,Ω_PreShv⟧. Proof. use make_nat_trans. + intros c _; apply empty_sieve. + now intros x y f; apply funextsec; intros []; apply sieve_eq. Defined. Definition Ω_PreShv_top : PreShv(C)⟦Terminal_PreShv,Ω_PreShv⟧. Proof. use make_nat_trans. + intros c _; apply maximal_sieve. + now intros x y f; apply funextsec; intros []; apply sieve_eq. Defined. Definition Ω_PreShv_bounded_lattice : bounded_latticeob BinProducts_PreShv Terminal_PreShv Ω_PreShv. Proof. use make_bounded_latticeob. - exact Ω_PreShv_lattice. - exact Ω_PreShv_bottom. - exact Ω_PreShv_top. - split; apply (nat_trans_eq has_homsets_HSET); intro c; apply funextsec; cbn; intros S. + apply (islunit_Lmax_Lbot (sieve_bounded_lattice c)). + apply (islunit_Lmin_Ltop (sieve_bounded_lattice c)). Defined. End Ω_PreShv. (** Construction of isomorphisms of functors between presheaf categories *) Section iso_presheaf. Context {C : category}. Local Definition make_PreShv_functor_z_iso_helper (F G : functor (PreShv C) (PreShv C)) (set_iso : ∏ X c, z_iso (pr1 (F X) c) (pr1 (G X) c)) (nat_in_c : ∏ X, is_nat_trans _ _ (λ c, set_iso X c)) (nat_in_X : is_nat_trans F G (λ X, make_nat_trans _ _ _ (nat_in_c X))) : [PreShv C, PreShv C] ⟦ F, G ⟧. Proof. use make_nat_trans. + intros X. use make_nat_trans. * intros c. exact (set_iso X c). * use nat_in_c. + exact nat_in_X. Defined. Lemma make_PreShv_functor_z_iso (F G : functor (PreShv C) (PreShv C)) (set_iso : ∏ X c, z_iso (pr1 (F X) c) (pr1 (G X) c)) (nat_in_c : ∏ X, is_nat_trans _ _ (λ c, set_iso X c)) (nat_in_X : is_nat_trans F G (λ X, make_nat_trans _ _ _ (nat_in_c X))) : @z_iso [PreShv C, PreShv C] F G. Proof. exists (make_PreShv_functor_z_iso_helper F G set_iso nat_in_c nat_in_X). use make_is_z_isomorphism. + use make_PreShv_functor_z_iso_helper. * intros X c. exact (z_iso_inv_from_z_iso (set_iso X c)). * abstract (intros X c y f; apply pathsinv0, z_iso_inv_on_left; rewrite <- assoc; now apply pathsinv0, z_iso_inv_on_right, (nat_in_c X)). * abstract (intros X Y α; apply nat_trans_eq; [ apply homset_property|]; intro x; simpl; apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (set_iso Y x)); rewrite <- assoc; apply pathsinv0, (z_iso_inv_on_right (C:=HSET)); exact (eqtohomot (maponpaths pr1 (nat_in_X X Y α)) x)). + abstract (use make_is_inverse_in_precat; [ apply nat_trans_eq; [ apply homset_property |]; intro X; apply nat_trans_eq; [ apply homset_property |]; intro x; exact (z_iso_inv_after_z_iso (set_iso X x)) | apply nat_trans_eq; [ apply homset_property |]; intro X; apply nat_trans_eq; [ apply homset_property |]; intro x; apply funextsec; intros y; exact (eqtohomot (z_iso_after_z_iso_inv (set_iso X x)) y) ]). Defined. End iso_presheaf. UniMath-20231010/UniMath/CategoryTheory/ProductCategory.v000066400000000000000000000132351451125700300231350ustar00rootroot00000000000000 (** ********************************************************** Anders Mörtberg 2016 For a specialization to binary products, see [precategory_binproduct]. Contents: - Definition of the general product category ([product_precategory]) - Functors - Families of functors ([family_functor]) - Projections ([pr_functor]) - Delta functor ([delta_functor]) - Tuple functor ([tuple_functor]) - Equivalence between functors into components and functors into product ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Section dep_product_precategory. Context {I : UU} (C : I -> category). Definition product_precategory_ob_mor : precategory_ob_mor. Proof. use tpair. - apply (∏ (i : I), ob (C i)). - intros f g. apply (∏ i, f i --> g i). Defined. Definition product_precategory_data : precategory_data. Proof. exists product_precategory_ob_mor. split. - intros f i; simpl in *. apply (identity (f i)). - intros a b c f g i; simpl in *. exact (f i · g i). Defined. Lemma is_precategory_product_precategory_data : is_precategory product_precategory_data. Proof. repeat split; intros; apply funextsec; intro i. - apply id_left. - apply id_right. - apply assoc. - apply assoc'. Defined. (** needed for the op-related goal below *) Definition product_precategory : precategory := tpair _ _ is_precategory_product_precategory_data. Definition has_homsets_product_precategory : has_homsets product_precategory. Proof. intros ? ?; simpl. apply impred_isaset; intro; apply C. Qed. Definition product_category' : category := make_category _ has_homsets_product_precategory. End dep_product_precategory. (** The product of categories is again a category. *) Definition product_category {I : UU} (C : I -> category) : category. use make_category. - exact (product_precategory C). - apply has_homsets_product_precategory. Defined. Section power_precategory. Context (I : UU) (C : category). Definition power_category : category := @product_category I (λ _, C). End power_precategory. (** ** Functors *) (* TODO: Some of the functors in this section can be defined in terms of each other *) Section functors. (** *** Families of functors ([family_functor]) *) Definition family_functor_data (I : UU) {A B : I -> category} (F : ∏ (i : I), (A i) ⟶ (B i)) : functor_data (product_category A) (product_category B). Proof. use tpair. - intros a i; apply (F i (a i)). - intros a b f i; apply (# (F i) (f i)). Defined. Definition family_functor (I : UU) {A B : I -> category} (F : ∏ (i : I), (A i) ⟶ (B i)) : (product_category A) ⟶ (product_category B). Proof. apply (tpair _ (family_functor_data I F)). abstract (split; [ intro x; apply funextsec; intro i; simpl; apply functor_id | intros x y z f g; apply funextsec; intro i; apply functor_comp]). Defined. (** *** Projections ([pr_functor]) *) Definition pr_functor_data (I : UU) (C : I -> category) (i : I) : functor_data (product_category C) (C i). Proof. use tpair. - intro a; apply (a i). - intros x y f; simpl; apply (f i). Defined. Definition pr_functor (I : UU) (C : I -> category) (i : I) : (product_category C) ⟶ (C i). Proof. apply (tpair _ (pr_functor_data I C i)). abstract (split; intros x *; apply idpath). Defined. (** *** Delta functor ([delta_functor]) *) Definition delta_functor_data (I : UU) (C : category) : functor_data C (power_category I C). Proof. use tpair. - intros x i; apply x. - intros x y f i; simpl; apply f. Defined. Definition delta_functor (I : UU) (C : category) : C ⟶ (power_category I C). Proof. apply (tpair _ (delta_functor_data I C)). abstract (split; intros x *; apply idpath). Defined. (** *** Tuple functor ([tuple_functor]) *) Definition tuple_functor_data {I : UU} {A : category} {B : I → category} (F : ∏ i, A ⟶ (B i)) : functor_data A (product_category B). Proof. use tpair. - intros a i; exact (F i a). - intros a b f i; exact (# (F i) f). Defined. Lemma tuple_functor_axioms {I : UU} {A : category} {B : I → category} (F : ∏ i, A ⟶ (B i)) : is_functor (tuple_functor_data F). Proof. split. - intros a. apply funextsec; intro i. apply functor_id. - intros ? ? ? ? ?. apply funextsec; intro i. apply functor_comp. Qed. Definition tuple_functor {I : UU} {A : category} {B : I → category} (F : ∏ i, A ⟶ (B i)) : A ⟶ (product_category B) := (tuple_functor_data F,, tuple_functor_axioms F). Lemma pr_tuple_functor {I : UU} {A : category} (B : I → category) (F : ∏ i, A ⟶ (B i)) (i : I) : tuple_functor F ∙ pr_functor I B i = F i. Proof. apply functor_eq. apply (B i). apply idpath. Qed. End functors. (** ** Equivalence between functors into components and functors into product *) (** This is a phrasing of the universal property of the product, compare to [weqfuntoprodtoprod]. *) Lemma functor_into_product_weq {I : UU} {A : category} {B : I → category} : A ⟶ (product_category B) ≃ (∏ i : I, A ⟶ (B i)). Proof. use weq_iso. - intros ? i. (** Compose A ⟶ product_precategory I B ⟶ B i *) apply (functor_composite (C' := product_precategory B)). + assumption. + exact (pr_functor _ _ i). - exact tuple_functor. - intro y. apply functor_eq; [apply homset_property|]. reflexivity. - intro f; cbn. apply funextsec; intro i. apply functor_eq; [exact (homset_property (B i))|]. reflexivity. Defined. UniMath-20231010/UniMath/CategoryTheory/Profunctors/000077500000000000000000000000001451125700300221505ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Profunctors/Core.v000066400000000000000000000244041451125700300232330ustar00rootroot00000000000000(** * Profunctors *) (** Set-valued profunctors *) (** References: - https://link.springer.com/content/pdf/10.1007/BFb0060443.pdf - https://bartoszmilewski.com/2017/03/29/ends-and-coends/ *) (** ** Contents - Definition - Dinatural transformations - Dinatural transformation from a natural transformation - (Co)ends - Wedges - Ends - Accessors/coercions - Cowedges - Coends *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. (** ** Definition *) (** A profunctor (or distributor) [C ↛ D] is a functor [D^op × C → HSET]. *) Definition profunctor (C D : category) : UU := functor (category_binproduct (op_category D) C) HSET_univalent_category. Identity Coercion profunctor_coercion : profunctor >-> functor. Infix "↛" := profunctor (at level 99, only parsing) : cat. (* \nrightarrow *) Local Notation "A ⊗ B" := (make_catbinprod A B). Local Open Scope cat. (** Map over the first argument contravariantly. Inspired by Data.Profunctor in Haskell. *) Definition lmap {C D : category} (F : C ↛ D) {a : ob C} {b b' : ob D} (g : b' --> b) : F (op_ob b ⊗ a) --> F (op_ob b' ⊗ a). Proof. refine (# F _ · _). - use catbinprodmor. + exact (op_ob b'). + exact a. + exact g. + apply identity. - apply identity. Defined. (** Map over the second argument covariantly. Inspired by Data.Profunctor in Haskell. *) Definition rmap {C D : category} (F : C ↛ D) {a a' : ob C} {b : ob D} (f : a --> a') : F (op_ob b ⊗ a) --> F (op_ob b ⊗ a'). Proof. refine (_ · # F _). - apply identity. - use catbinprodmor. * apply identity. * exact f. Defined. (** Laws for `rmap` and `lmap` *) Definition lmap_id {C₁ C₂ : category} (P : profunctor C₁ C₂) {x : C₁} {y : C₂} (z : P (y ,, x) : hSet) : lmap P (identity y) z = z. Proof. exact (eqtohomot (functor_id P (y ,, x)) z). Qed. Definition rmap_id {C₁ C₂ : category} (P : profunctor C₁ C₂) {x : C₁} {y : C₂} (z : P (y ,, x) : hSet) : rmap P (identity x) z = z. Proof. exact (eqtohomot (functor_id P (y ,, x)) z). Qed. Definition lmap_comp {C₁ C₂ : category} (P : profunctor C₁ C₂) {x : C₁} {y₁ y₂ y₃ : C₂} (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) (z : P (y₃ ,, x) : hSet) : lmap P (g₁ · g₂) z = lmap P g₁ (lmap P g₂ z). Proof. pose (eqtohomot (@functor_comp _ _ P (y₃ ,, x) (y₂ ,, x) (y₁ ,, x) (g₂ ,, identity _) (g₁ ,, identity _)) z) as p. cbn in p. refine (_ @ p). unfold lmap. cbn. refine (maponpaths (λ w, #P (_ ,, w) z) _). refine (!_). cbn. apply id_left. Qed. Definition rmap_comp {C₁ C₂ : category} (P : profunctor C₁ C₂) {x₁ x₂ x₃ : C₁} {y : C₂} (f₁ : x₁ --> x₂) (f₂ : x₂ --> x₃) (z : P (y ,, x₁) : hSet) : rmap P (f₁ · f₂) z = rmap P f₂ (rmap P f₁ z). Proof. pose (eqtohomot (@functor_comp _ _ P (y ,, x₁) (y ,, x₂) (y ,, x₃) (identity _ ,, f₁) (identity _ ,, f₂)) z) as p. cbn in p. refine (_ @ p). unfold rmap. cbn. refine (maponpaths (λ w, #P (w ,, _) z) _). refine (!_). cbn. apply id_left. Qed. Definition lmap_rmap {C₁ C₂ : category} (P : profunctor C₁ C₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} (f : x₁ --> x₂) (g : y₂ --> y₁) (z : P (y₁ ,, x₁) : hSet) : lmap P g (rmap P f z) = rmap P f (lmap P g z). Proof. pose (eqtohomot (@functor_comp _ _ P (y₁ ,, x₁) (y₂ ,, x₁) (y₂ ,, x₂) (g ,, identity _) (identity _ ,, f)) z) as p. refine (_ @ p) ; clear p. pose (eqtohomot (@functor_comp _ _ P (y₁ ,, x₁) (y₁ ,, x₂) (y₂ ,, x₂) (identity _ ,, f) (g ,, identity _)) z) as p. refine (!p @ _). cbn. rewrite !id_left, !id_right. apply idpath. Qed. Definition rmap_lmap {C₁ C₂ : category} (P : profunctor C₁ C₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} (f : x₁ --> x₂) (g : y₂ --> y₁) (z : P (y₁ ,, x₁) : hSet) : rmap P f (lmap P g z) = lmap P g (rmap P f z). Proof. rewrite lmap_rmap. apply idpath. Qed. (** ** Dinatural transformations *) Section Dinatural. Context {C : category}. Definition dinatural_transformation_data (f : C ↛ C) (g : C ↛ C) : UU := ∏ a : C, f (a ⊗ a) --> g (a ⊗ a). Definition is_dinatural {F : C ↛ C} {G : C ↛ C} (data : dinatural_transformation_data F G) : hProp. Proof. use make_hProp. - exact (∏ (a b : ob C) (f : a --> b), lmap F f · data a · rmap G f = rmap F f · data b · lmap G f). - abstract (do 3 (apply impred; intro); apply homset_property). Defined. Definition dinatural_transformation (f : C ↛ C) (g : C ↛ C) : UU := ∑ d : dinatural_transformation_data f g, is_dinatural d. (** The second projection is made opaque for efficiency. Nothing is lost because it's an [hProp]. *) Definition make_dinatural_transformation {F : C ↛ C} {G : C ↛ C} (data : dinatural_transformation_data F G) (is_dinat : is_dinatural data) : dinatural_transformation F G. Proof. use tpair. - assumption. - abstract assumption. Defined. Section Accessors. Context {f : C ↛ C} {g : C ↛ C} (d : dinatural_transformation f g). Definition dinatural_transformation_get_data : ∏ a : C, f (a ⊗ a) --> g (a ⊗ a) := pr1 d. Definition dinatural_transformation_is_dinatural : is_dinatural dinatural_transformation_get_data := pr2 d. End Accessors. Coercion dinatural_transformation_get_data : dinatural_transformation >-> Funclass. (** See below for the non-local notation *) Local Notation "F ⇏ G" := (dinatural_transformation F G) (at level 39) : cat. (** *** Dinatural transformation from a natural transformation *) Lemma nat_trans_to_dinatural_transformation {f : C ↛ C} {g : C ↛ C} (alpha : nat_trans f g) : f ⇏ g. Proof. use make_dinatural_transformation. - intro; apply alpha. - intros a b h. (** Have: << F (i, j) F(a, b) --------> F(c, d) | | | alpha a b | alpha c d V V G(a, b) --------> G(c, d) G (i, j) >> Want: << F(a, a) -- alpha --> G(a, a) lmap / \ rmap F(b, a) G(a, b) rmap \ / lmap F(b, b) -- alpha --> G(b, b) >> *) unfold lmap, rmap. do 2 rewrite id_left. do 2 rewrite id_right. refine (maponpaths (fun z => z · _) (pr2 alpha _ _ _) @ _). refine (_ @ maponpaths (fun z => _ · z) (pr2 alpha _ _ _)). refine (!assoc _ _ _ @ _). refine (_ @ !assoc _ _ _). refine (!maponpaths (fun z => _ · z) (functor_comp g _ _) @ _). refine (_ @ maponpaths (fun z => z · _) (functor_comp f _ _)). unfold compose at 2; simpl. unfold compose at 5; simpl. rewrite id_left. rewrite id_right. cbn. rewrite id_right. rewrite id_left. symmetry. apply (pr2 alpha). Qed. End Dinatural. Notation "F ⇏ G" := (dinatural_transformation F G) (at level 39) : cat. (** ** (Co)ends *) Section Ends. Context {C : category} (F : C ↛ C). (** *** Wedges *) (** Wedge diagram: << w -----> F(a, a) | | | F(f, id) | F(id, f) V V F(b, b) --> F(a, b) >> *) Definition is_wedge (w : ob HSET_univalent_category) (pi : ∏ a : ob C, w --> F (a ⊗ a)) : hProp. Proof. use make_hProp. - exact (∏ (a b : ob C) (f : a --> b), pi a · rmap F f = pi b · lmap F f). - abstract (do 3 (apply impred; intro); apply homset_property). Defined. (** Following the convention for limits, the tip is explicit in the type. *) Definition wedge (w : ob HSET_univalent_category) : UU := ∑ pi : (∏ a : ob C, w --> F (a ⊗ a)), is_wedge w pi. Definition make_wedge (w : hSet) (pi : (∏ a : ob C, (w : ob HSET_univalent_category) --> F (a ⊗ a))) : (∏ (a b : ob C) (f : a --> b), pi a · rmap F f = pi b · lmap F f) -> wedge w. Proof. intro. use tpair. - assumption. - abstract assumption. Qed. Definition wedge_pr (w : ob HSET_univalent_category) (W : wedge w) : ∏ a : ob C, w --> F (a ⊗ a) := (pr1 W). Coercion wedge_pr : wedge >-> Funclass. (** *** Ends *) Definition is_end (w : ob HSET_univalent_category) (W : wedge w) : hProp. Proof. use make_hProp. - exact (∏ v (V : wedge v), iscontr (∑ f : v --> w, ∏ a, f · W a = V a)). - abstract (do 2 (apply impred; intro); apply isapropiscontr). Qed. (** This must be capitalized because 'end' is a Coq keyword. It also matches the convention for limits. *) Definition End : UU := ∑ w W, is_end w W. (** **** Accessors/coercions *) Definition end_ob (e : End) : ob HSET_univalent_category := pr1 e. Coercion end_ob : End >-> ob. Definition end_wedge (e : End) : wedge e := pr1 (pr2 e). Coercion end_wedge : End >-> wedge. (** *** Cowedges *) (** *** Coends *) End Ends. Notation "∫↓ F" := (End F) (at level 40) : cat. (* Notation "∫↑ F" := (Coend F) (at level 40) : cat. *) UniMath-20231010/UniMath/CategoryTheory/PseudoElements.v000066400000000000000000000615301451125700300227540ustar00rootroot00000000000000(** * Pseudo elements *) (** ** Contents - Pseudo elements - Definition of pseudo elements - Basics of pseudo elements - Criteria for Zero, isMonic, isEpi, isExact, Minus, and Pullback using pseudo elements *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AbelianPushoutPullback. Require Import UniMath.CategoryTheory.ShortExactSequences. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. (** ** Introduction We define pseudo elements which are used in diagram lemmas in homological algebra. A pseudo element of an object x of an abelian category A is a morphism from some object y to x. Two pseudo elements f_1 : y_1 --> x, f_2 : y_2 --> x are pseudo equal if there is an object y_3 and epimorphisms p : y_3 --> y_1 and q : y_3 --> y_2 such that the following diagram is commutative y_3 --p--> y_1 q | f_1 | y_2 -f_2-> x Pseudo elements are defined in [PseudoElem]. In [PseudoEq_iseqrel] we prove that pseudo equality is an equivalence relation. Here are the results we prove about pseudo elements : - Let f_1 : x_1 --> y and f_2 : x_2 --> y be ZeroArrows. As pseudo elements they are pseudo equal, [PEq_Zeros']. - A morphism f : x --> y is a ZeroArrow if and only if for all pseudo elements g : x' --> x of x the composite g · f is pseudo equal to ZeroArrow, [PEq_ZeroArrow]. - A morphism f : x --> y is Monic if and only is for all pseudo elements a : a' -> x of x, the composite a' -> x is ZeroArrow, [PEq_isMonic]. - A morphism f : x --> y is Monic if and only is for all pseudo elements a_1 : a_1' --> x and a_2 : a_2' --> x, pseudo equality of a_1' · f and a_2' · f implies that a_1' and a_2' are pseudo equal, [PEq_isMonic'] - A morphism f : x --> y is Epi if and only if for all pseudo elements b : b' --> y of y there exists a pseudo element a : a' --> x of x such that a · f is pseudo equal to b, [PEq_isEpi]. - A pair of morphisms f : x --> y, g : y --> z is exact if and only if the composite is ZeroArrow and for all pseudo elements b : b' --> y such that b · g is pseudo equal to PZero, there exists a pseudo element a : a' --> x of x such that a · f is pseudo equal to b, [PEq_isExact]. - Let f : x --> y be a morphism, and a_1 : a_1' --> x and a_2 : a_2' --> x two pseudo elements of x such that a_1 · f and a_2 · f are pseudo equal. Then there exists a pseudo element a_3 : a_3' --> x of x such that a_3 · f is pseudo equal to PZero, and for all morphisms g : x --> z such that a_1 · g is pseudo equal to PZero, we have that a_2 · g and a_3 · g are pseudo equal, [PEq_Diff]. - Let f : x --> z and g : y --> z be morphisms and let a : a' --> x and b : b' --> y be pseudo elements of x and y, respectively. Then there exists a pseudo element d : d' --> Pb, where Pb is a pullback of f and g, such that d · pr1 is pseudo equal to f and d · pr2 is pseudo equal to g, [PEq_Pullback]. *) Section def_pseudo_element. Context {A : AbelianPreCat}. Local Opaque Abelian.Pullbacks. (** ** Definition of pseudo elements *) Definition PseudoElem (c : A) : UU := ∑ d : A, d --> c. Definition make_PseudoElem {c d : A} (f : d --> c) : PseudoElem c := tpair _ d f. Definition PseudoOb {c : A} (P : PseudoElem c) : ob A := pr1 P. Definition PseudoMor {c : A} (P : PseudoElem c) : A⟦PseudoOb P, c⟧ := pr2 P. Coercion PseudoMor : PseudoElem >-> precategory_morphisms. Definition PseudoIm {c d : A} (P : PseudoElem c) (f : c --> d) : PseudoElem d := make_PseudoElem (P · f). (** Pseudo equality *) Definition PEq {c : A} (PE1 PE2 : PseudoElem c) : UU := ∑ (Y : ob A) (E1 : Epi A Y (PseudoOb PE2)) (E2 : Epi A Y (PseudoOb PE1)), E1 · PE2 = E2 · PE1. Definition make_PEq {c : A} (PE1 PE2 : PseudoElem c) {Y : ob A} (E1 : Epi A Y (PseudoOb PE2)) (E2 : Epi A Y (PseudoOb PE1)) (H : E1 · PE2 = E2 · PE1) : PEq PE1 PE2 := (Y,,(E1,,(E2,,H))). Definition PEqOb {c : A} {PE1 PE2 : PseudoElem c} (PE : PEq PE1 PE2) : ob A := pr1 PE. Definition PEqEpi1 {c : A} {PE1 PE2 : PseudoElem c} (PE : PEq PE1 PE2) : Epi A (PEqOb PE) (PseudoOb PE2) := pr1 (pr2 PE). Definition PEqEpi2 {c : A} {PE1 PE2 : PseudoElem c} (PE : PEq PE1 PE2) : Epi A (PEqOb PE) (PseudoOb PE1) := pr1 (pr2 (pr2 PE)). Definition PEqEq {c : A} {PE1 PE2 : PseudoElem c} (PE : PEq PE1 PE2) : (PEqEpi1 PE) · PE2 = (PEqEpi2 PE) · PE1 := pr2 (pr2 (pr2 PE)). Definition PEq_hrel {c : A} : hrel (PseudoElem c) := λ (PE1 PE2 : PseudoElem c), ∥ PEq PE1 PE2 ∥. Definition PEq_precomp_Epi {c d : A} (P : PseudoElem c) (E : Epi A d (PseudoOb P)) : PEq P (make_PseudoElem (E · P)). Proof. use make_PEq. - exact d. - exact (identity_Epi _). - exact E. - apply id_left. Defined. Local Lemma PEq_trans_eq {c : ob A} {E1 E2 E3 : PseudoElem c} (P1 : PEq E1 E2) (P2 : PEq E2 E3) : let Pb := Abelian.Pullbacks A _ _ _ (PEqEpi1 P1) (PEqEpi2 P2) in PullbackPr2 Pb · PEqEpi1 P2 · E3 = PullbackPr1 Pb · PEqEpi2 P1 · E1. Proof. intros Pb. rewrite <- assoc. rewrite <- assoc. rewrite (PEqEq P2). rewrite <- (PEqEq P1). rewrite assoc. rewrite assoc. apply cancel_postcomposition. apply pathsinv0. exact (PullbackSqrCommutes Pb). Qed. Definition PEq_trans {c : ob A} {E1 E2 E3 : PseudoElem c} (P1 : PEq E1 E2) (P2 : PEq E2 E3) : PEq E1 E3. Proof. set (Pb := Abelian.Pullbacks A _ _ _ (PEqEpi1 P1) (PEqEpi2 P2)). use make_PEq. * exact Pb. * use make_Epi. -- exact (PullbackPr2 Pb · PEqEpi1 P2). -- use isEpi_comp. ++ use AbelianPullbackEpi2. ++ apply EpiisEpi. * use make_Epi. -- exact (PullbackPr1 Pb · PEqEpi2 P1). -- use isEpi_comp. ++ use AbelianPullbackEpi1. ++ apply EpiisEpi. * cbn. exact (PEq_trans_eq P1 P2). Defined. Lemma PEq_istrans (c : ob A) : istrans (@PEq_hrel c). Proof. intros E1 E2 E3 H1 H2. use (squash_to_prop H1 (propproperty _)). intros X1. use (squash_to_prop H2 (propproperty _)). intros X2. intros P X3. apply X3. clear P X3. exact (PEq_trans X1 X2). Qed. Definition PEq_refl {c : ob A} (E1 : PseudoElem c) : PEq E1 E1. Proof. use make_PEq. - exact (PseudoOb E1). - use identity_Epi. - use identity_Epi. - apply idpath. Defined. Lemma PEq_isrefl (c : ob A) : isrefl (@PEq_hrel c). Proof. intros E1. intros P X. apply X. clear X P. exact (PEq_refl E1). Qed. Definition PEq_symm {c : ob A} {E1 E2 : PseudoElem c} (P1 : PEq E1 E2) : PEq E2 E1. Proof. use make_PEq. - exact (PEqOb P1). - exact (PEqEpi2 P1). - exact (PEqEpi1 P1). - exact (! (PEqEq P1)). Defined. Lemma PEq_issymm (c : ob A) : issymm (@PEq_hrel c). Proof. intros E1 E2 H1. use (squash_to_prop H1 (propproperty _)). intros X1. intros P X. apply X. clear X P. exact (PEq_symm X1). Qed. Lemma PseudoEq_iseqrel (c : A) : iseqrel (@PEq_hrel c). Proof. split. - split. + exact (PEq_istrans c). + exact (PEq_isrefl c). - exact (PEq_issymm c). Qed. (** *** Pseudo fiber *) Definition PFiber {c d : ob A} (f : c --> d) (b : PseudoElem d) : UU := ∑ (a : PseudoElem c), PEq (PseudoIm a f) b. Definition make_PFiber {c d : ob A} (f : c --> d) (b : PseudoElem d) (a : PseudoElem c) (H : PEq (PseudoIm a f) b) : PFiber f b := tpair _ a H. Definition PFiber_Elem {c d : ob A} {f : c --> d} {b : PseudoElem d} (P : PFiber f b) : PseudoElem c := pr1 P. Coercion PFiber_Elem : PFiber >-> PseudoElem. Definition PFiber_Eq {c d : ob A} {f : c --> d} {b : PseudoElem d} (P : PFiber f b) : PEq (PseudoIm P f) b := pr2 P. (** ** Basics of pseudo elements *) Lemma PEq_to_hrel {c : A} (P1 P2 : PseudoElem c) (H : PEq P1 P2) : PEq_hrel P1 P2. Proof. intros P X. apply X. exact H. Qed. Local Lemma PEq_Im_Eq {c d : A} (P1 P2 : PseudoElem c) (f : c --> d) (H : PEq P1 P2): PEqEpi1 H · (P2 · f) = PEqEpi2 H · (P1 · f). Proof. rewrite assoc. rewrite assoc. apply cancel_postcomposition. exact (PEqEq H). Qed. Definition PEq_Im {c d : A} (P1 P2 : PseudoElem c) (f : c --> d) (H : PEq P1 P2) : PEq (PseudoIm P1 f) (PseudoIm P2 f). Proof. use make_PEq. - exact (PEqOb H). - exact (PEqEpi1 H). - exact (PEqEpi2 H). - exact (PEq_Im_Eq P1 P2 f H). Defined. Local Lemma PEq_Comp_Eq {c d1 d2 : A} (P : PseudoElem c) (f : c --> d1) (g : d1 --> d2) : identity (PseudoOb P) · (P · (f · g)) = identity (PseudoOb P) · (P · f · g). Proof. rewrite id_left. rewrite id_left. apply assoc. Qed. Definition PEq_Comp {c d1 d2 : A} (P : PseudoElem c) (f : c --> d1) (g : d1 --> d2) : PEq (PseudoIm (PseudoIm P f) g) (PseudoIm P (f · g)). Proof. use make_PEq. - exact (PseudoOb P). - use identity_Epi. - use identity_Epi. - exact (PEq_Comp_Eq P f g). Qed. Definition PEq_Im_Paths {x y : A} (P : PseudoElem x) {f g : x --> y} (H : f = g) : PEq (PseudoIm P f) (PseudoIm P g). Proof. induction H. apply PEq_refl. Qed. Definition PEq_Im_Comm {x y z w : A} (P : PseudoElem x) {f : x --> y} {g : y --> w} {h : x --> z} {k : z --> w} (H : f · g = h · k) : PEq (PseudoIm (PseudoIm P f) g) (PseudoIm (PseudoIm P h) k). Proof. use (PEq_trans (PEq_Comp P f g)). use (PEq_trans _ (PEq_symm (PEq_Comp P h k))). use PEq_Im_Paths. exact H. Qed. Definition PZero {c : A} (d : A) : PseudoElem c := make_PseudoElem (ZeroArrow (to_Zero A) d c). Lemma PEq_Zero_Eq' {c : A} (d : A) (PE : PseudoElem c) : PEq PE (PZero d) -> (PE : A⟦_,_⟧ ) = ZeroArrow (to_Zero A) _ _. Proof. intros X1. set (tmp := PEqEq X1). cbn in tmp. rewrite ZeroArrow_comp_right in tmp. use (EpiisEpi _ (PEqEpi2 X1)). rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_right. apply idpath. Qed. Lemma PEq_Zero_Eq {c : A} (PE : PseudoElem c) : PEq_hrel PE (PZero (PseudoOb PE)) -> (PE : A⟦_,_⟧ ) = ZeroArrow (to_Zero A) _ _. Proof. intros H1. use (squash_to_prop H1). apply homset_property. intros X1. exact (PEq_Zero_Eq' _ PE X1). Qed. Definition PEq_Zeros' {c : A} (d1 d2 : A) : @PEq c (PZero d1) (PZero d2). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) d1 d2). use make_PEq. - exact DS. - use (make_Epi _ _ (to_Pr2_isEpi _ DS)). - use (make_Epi _ _ (to_Pr1_isEpi _ DS)). - cbn. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Defined. Lemma PEq_Zeros {c : A} (d1 d2 : A) : @PEq_hrel c (PZero d1) (PZero d2). Proof. intros P X. apply X. clear P X. exact (PEq_Zeros' _ _). Qed. Definition PEq_ZeroIm (c d1 d2 d3 : A) (f : d1 --> d2) : PEq (PseudoIm (PZero c) f) (PZero d3). Proof. use (PEq_trans _ (PEq_Zeros' c d3)). use make_PEq. - exact c. - exact (identity_Epi _). - exact (identity_Epi _). - cbn. rewrite ZeroArrow_comp_left. apply idpath. Qed. Local Lemma PEq_Eq_Zero_Eq {c : A} (PE : PseudoElem c) (H : (PE : A⟦_, c⟧) = ZeroArrow (to_Zero A) _ _) : identity (PseudoOb PE) · ZeroArrow (to_Zero A) (PseudoOb PE) c = identity (PseudoOb PE) · PE. Proof. rewrite id_left. rewrite id_left. apply pathsinv0. exact H. Qed. Lemma PEq_Eq_Zero {c : A} (PE : PseudoElem c) : (PE : A⟦_, c⟧) = ZeroArrow (to_Zero A) _ _ -> PEq PE (PZero (PseudoOb PE)). Proof. intros H. use make_PEq. - exact (PseudoOb PE). - use identity_Epi. - use identity_Epi. - exact (PEq_Eq_Zero_Eq PE H). Qed. (** ** Pseudo element criterias *) (** *** Zero criteria *) Lemma PEq_ZeroArrow {c d : ob A} (f : c --> d) : f = ZeroArrow (to_Zero A) _ _ <-> (∏ (a : PseudoElem c), a · f = ZeroArrow (to_Zero A) _ _). Proof. split. - intros H. intros a. rewrite H. apply ZeroArrow_comp_right. - intros H. set (tmp := H (make_PseudoElem (identity c))). cbn in tmp. rewrite <- tmp. rewrite id_left. apply idpath. Qed. (** *** isMonic criteria *) Lemma PEq_isMonic {c d : ob A} (f : c --> d) : isMonic f <-> (∏ (d' : ob A) (a : PseudoElem c), PEq (PseudoIm a f) (PZero d') -> ZeroArrow (to_Zero A) _ _ = a). Proof. split. - intros isM. intros d' a X. use isM. rewrite ZeroArrow_comp_left. set (tmp := PseudoIm a f). apply pathsinv0. use (PEq_Zero_Eq tmp). unfold tmp. clear tmp. use (PEq_istrans _ _ (PZero d')). + exact (PEq_to_hrel _ _ X). + use PEq_Zeros. - intros X. use (to_isMonic (AbelianToAdditive A)). intros z g H. exact (! ( X z (make_PseudoElem g) (PEq_Eq_Zero (PseudoIm (make_PseudoElem g) f) H))). Qed. Lemma PEq_isMonic' {c d : ob A} (f : c --> d) : isMonic f <-> (∏ (a a' : PseudoElem c), PEq (PseudoIm a f) (PseudoIm a' f) -> PEq a a'). Proof. split. - intros isM. intros a a' X. use make_PEq. + exact (PEqOb X). + exact (PEqEpi1 X). + exact (PEqEpi2 X). + apply isM. set (tmp := PEqEq X). cbn in tmp. rewrite assoc in tmp. rewrite assoc in tmp. apply tmp. - intros X. use (dirprod_pr2 (PEq_isMonic f)). intros d' a X0. apply pathsinv0. use PEq_Zero_Eq'. + exact (PseudoOb a). + use (X a (PZero (PseudoOb a))). use (PEq_trans X0). use PEq_symm. use PEq_ZeroIm. Qed. (** *** isEpi criteria *) Lemma PEq_isEpi {c d : ob A} (f : c --> d) : isEpi f <-> (∏ (b : PseudoElem d), PFiber f b). Proof. split. - intros isE b. set (E := make_Epi _ _ isE). set (Pb := Abelian.Pullbacks A _ _ _ E b). set (isEpi1 := AbelianPullbackEpi2 E b Pb). set (E2 := make_Epi A _ isEpi1). use (make_PFiber _ _ (make_PseudoElem (PullbackPr1 Pb))). use make_PEq. + exact Pb. + exact E2. + use identity_Epi. + cbn. rewrite id_left. exact (! PullbackSqrCommutes Pb). - intros H. set (fib := H (make_PseudoElem (identity _))). set (P1 := PFiber_Elem fib). set (e := PEqEq (PFiber_Eq fib)). use isEpi_precomp. + exact (PEqOb (PFiber_Eq fib)). + exact (PEqEpi2 (PFiber_Eq fib) · P1). + cbn in e. rewrite id_right in e. rewrite assoc in e. use (isEpi_path A _ _ e). apply EpiisEpi. Qed. (** *** isExact criteria *) Lemma PEq_isExact {x y z : ob A} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _) : isExact A f g H <-> ∏ (b : PseudoElem y) (H : b · g = ZeroArrow (to_Zero A) _ _), PFiber f b. Proof. split. - intros isK b H'. unfold isExact in isK. set (K := make_Kernel _ _ _ _ isK). set (KI := KernelIn _ K (PseudoOb b) b H'). set (Pb := Abelian.Pullbacks A _ _ _ (factorization1_epi A f) KI). use make_PFiber. + exact (make_PseudoElem (PullbackPr1 Pb)). + use make_PEq. * exact Pb. * exact (make_Epi _ _ (AbelianPullbackEpi2 (factorization1_epi A f) KI Pb)). * use identity_Epi. * cbn. rewrite id_left. apply pathsinv0. set (tmp := PullbackSqrCommutes Pb). set (tmp' := factorization1 f). apply (maponpaths (λ gg : _, gg · (factorization1_monic A f))) in tmp. rewrite <- assoc in tmp. rewrite <- tmp' in tmp. clear tmp'. use (pathscomp0 tmp). clear tmp. rewrite <- assoc. apply cancel_precomposition. use (KernelCommutes (to_Zero A) K). - intros X. set (fac := factorization1 f). use make_isKernel. + intros w h H'. set (P := X (make_PseudoElem h) H'). set (PE := PFiber_Eq P). set (Pb := Abelian.Pullbacks A _ _ _ h (factorization1_monic A f)). set (isM := MonicPullbackisMonic' _ _ _ Pb). assert (i : is_z_isomorphism (PullbackPr1 Pb)). { use monic_epi_is_iso. - exact isM. - assert (ee : PEqEpi1 PE · h = PEqEpi2 PE · P · factorization1_epi A f · factorization1_monic A f). { cbn. set (ee := PEqEq PE). cbn in ee. rewrite ee. rewrite assoc. rewrite <- (assoc _ _ (KernelArrow (Abelian.Image f))). apply cancel_precomposition. exact fac. } set (tmp := PullbackArrow Pb _ (PEqEpi1 PE) ((PEqEpi2 PE) · (PFiber_Elem P) · (factorization1_epi A f)) ee). set (t := PullbackArrow_PullbackPr1 Pb _ (PEqEpi1 PE) ((PEqEpi2 PE) · (PFiber_Elem P) · (factorization1_epi A f)) ee). use (isEpi_precomp _ tmp). unfold tmp. use (isEpi_path _ _ _ (! t)). apply EpiisEpi. } set (q := PullbackSqrCommutes Pb). assert (e1 : h = (inv_from_iso (make_iso _ (is_iso_qinv _ _ i))) · PullbackPr2 Pb · factorization1_monic A f). { rewrite <- assoc. rewrite <- q. rewrite assoc. set (tmp := iso_after_iso_inv (make_iso _ (is_iso_qinv _ _ i))). cbn in tmp. cbn. rewrite tmp. rewrite id_left. apply idpath. } use unique_exists. * exact (inv_from_iso (make_iso (PullbackPr1 Pb) (is_iso_qinv _ _ i)) · PullbackPr2 Pb). * cbn. cbn in e1. rewrite <- e1. apply idpath. * intros y0. apply homset_property. * intros y0 XX. cbn in XX. use (KernelArrowisMonic (to_Zero A) (Abelian.Image f)). rewrite XX. apply e1. Qed. (** *** Difference criteria *) (** **** Data for Difference *) Definition PDiff {x y : ob A} {a a' : PseudoElem x} (f : x --> y) (H : PEq (PseudoIm a f) (PseudoIm a' f)) : UU := ∑ (a'' : PseudoElem x) (H' : a'' · f = ZeroArrow (to_Zero A) _ _), ∏ (z : ob A) (g : x --> z), a · g = ZeroArrow (to_Zero A) _ _ -> PEq (PseudoIm a' g) (PseudoIm a'' g). Definition make_PDiff {x y : ob A} {a a' : PseudoElem x} (f : x --> y) (H : PEq (PseudoIm a f) (PseudoIm a' f)) (a'' : PseudoElem x) (H' : a'' · f = ZeroArrow (to_Zero A) _ _) (H'' : ∏ (z : ob A) (g : x --> z), a · g = ZeroArrow (to_Zero A) _ _ -> PEq (PseudoIm a' g) (PseudoIm a'' g)) : PDiff f H := (a'',,(H',,H'')). Definition PDiffElem {x y : ob A} {a a' : PseudoElem x} {f : x --> y} {H : PEq (PseudoIm a f) (PseudoIm a' f)} (PD : PDiff f H) : PseudoElem x := pr1 PD. Coercion PDiffElem : PDiff >-> PseudoElem. Definition PDiffIm {x y : ob A} {a a' : PseudoElem x} {f : x --> y} {H : PEq (PseudoIm a f) (PseudoIm a' f)} (PD : PDiff f H) : PD · f = ZeroArrow (to_Zero A) _ _ := pr1 (pr2 PD). Definition PDiffEq {x y : ob A} {a a' : PseudoElem x} {f : x --> y} {H : PEq (PseudoIm a f) (PseudoIm a' f)} (PD : PDiff f H) : ∏ (z : ob A) (g : x --> z), a · g = ZeroArrow (to_Zero A) _ _ -> PEq (PseudoIm a' g) (PseudoIm PD g) := pr2 (pr2 PD). (** **** Difference criteria *) Local Opaque to_binop to_inv. Local Lemma PEq_Diff_Eq1 {x y : ob A} {a a' : PseudoElem x} (f : x --> y) (H : PEq (PseudoIm a f) (PseudoIm a' f)) : let PA := (AbelianToAdditive A) : PreAdditive in @to_binop PA _ _ (PEqEpi2 H · a) (PEqEpi1 H · @to_inv PA _ _ a') · f = ZeroArrow (to_Zero A) _ _. Proof. intros PA. set (tmp := PEqEq H). cbn in tmp. set (tmp' := @to_postmor_linear' PA _ _ _ (PEqEpi2 H · a) (PEqEpi1 H · @to_inv PA _ _ a') f). use (pathscomp0 tmp'). clear tmp'. rewrite assoc in tmp. rewrite assoc in tmp. cbn in tmp. cbn. rewrite <- tmp. clear tmp. set (tmp' := @to_postmor_linear' PA _ _ _ (PEqEpi1 H · a') (PEqEpi1 H · @to_inv PA _ _ a') f). use (pathscomp0 (! tmp')). clear tmp'. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ f). apply cancel_postcomposition. set (tmp' := @to_premor_linear' PA _ _ _ (PEqEpi1 H) a' (@to_inv PA _ _ a')). use (pathscomp0 (! tmp')). clear tmp'. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (PEqEpi1 H)). apply cancel_precomposition. use (@to_rinvax' PA). Qed. Local Lemma PEq_Diff_Eq2 {x y : ob A} {a a' : PseudoElem x} (f : x --> y) (H : PEq (PseudoIm a f) (PseudoIm a' f)) {z0 : A} {g : A ⟦ x, z0 ⟧} (X : a · g = ZeroArrow (to_Zero A) (PseudoOb a) z0) : let PA := (AbelianToAdditive A) : PreAdditive in identity (PEqOb H) · (@to_binop PA (PEqOb H) x (PEqEpi2 H · a) (PEqEpi1 H · @to_inv PA _ _ a') · g) = @to_inv PA _ _ (PEqEpi1 H) · (a' · g). Proof. intros PA. rewrite id_left. cbn. set (tmp := PEqEq H). cbn in tmp. set (tmp' := @to_postmor_linear' PA _ _ _ (PEqEpi2 H · a) (PEqEpi1 H · @to_inv PA _ _ a') g). use (pathscomp0 tmp'). clear tmp'. rewrite <- assoc. cbn. rewrite X. rewrite ZeroArrow_comp_right. rewrite (@to_lunax'' PA). rewrite assoc. apply cancel_postcomposition. rewrite <- (@PreAdditive_invlcomp PA). rewrite <- (@PreAdditive_invrcomp PA). apply idpath. Qed. Definition PEq_Diff {x y : ob A} {a a' : PseudoElem x} (f : x --> y) (H : PEq (PseudoIm a f) (PseudoIm a' f)) : PDiff f H. Proof. set (PA := (AbelianToAdditive A) : PreAdditive). use make_PDiff. - exact (make_PseudoElem (@to_binop PA _ _ (PEqEpi2 H · a) (PEqEpi1 H · (@to_inv (AbelianToAdditive A) _ _ a')))). - exact (PEq_Diff_Eq1 f H). - intros z0 g X. use (make_PEq _ _ (identity_Epi _)). + cbn. exact (make_Epi _ _ (to_inv_isEpi PA _ (EpiisEpi PA (PEqEpi1 H)))). + cbn. exact (PEq_Diff_Eq2 f H X). Defined. (** *** Pullback using pseudo elements *) Local Lemma PEq_Pullback_Eq {x y z : ob A} (f : x --> z) (g : y --> z) (Pb : Pullback f g) (a : PseudoElem x) (b : PseudoElem y) (H : PEq (PseudoIm a f) (PseudoIm b g)) : PEqEpi2 H · a · f = PEqEpi1 H · b · g. Proof. rewrite <- assoc. rewrite <- assoc. apply pathsinv0. exact (PEqEq H). Qed. Local Lemma PEq_Pullback_Eq1 {x y z : ob A} (f : x --> z) (g : y --> z) (Pb : Pullback f g) (a : PseudoElem x) (b : PseudoElem y) (H : PEq (PseudoIm a f) (PseudoIm b g)) : PEqEpi2 H · a = (identity (PEqOb H)) · ((PullbackArrow Pb (PEqOb H) (PEqEpi2 H · a) (PEqEpi1 H · b) (PEq_Pullback_Eq f g Pb a b H)) · PullbackPr1 Pb). Proof. rewrite id_left. use (! (PullbackArrow_PullbackPr1 Pb _ (PEqEpi2 H · a) (PEqEpi1 H · b) (PEq_Pullback_Eq f g Pb a b H))). Qed. Local Lemma PEq_Pullback_Eq2 {x y z : ob A} (f : x --> z) (g : y --> z) (Pb : Pullback f g) (a : PseudoElem x) (b : PseudoElem y) (H : PEq (PseudoIm a f) (PseudoIm b g)) : PEqEpi1 H · b = (identity (PEqOb H)) · ((PullbackArrow Pb (PEqOb H) (PEqEpi2 H · a) (PEqEpi1 H · b) (PEq_Pullback_Eq f g Pb a b H)) · (PullbackPr2 Pb)). Proof. rewrite id_left. use (! (PullbackArrow_PullbackPr2 Pb _ (PEqEpi2 H · a) (PEqEpi1 H · b) (PEq_Pullback_Eq f g Pb a b H))). Qed. Definition PEq_Pullback {x y z : ob A} (f : x --> z) (g : y --> z) (Pb : Pullback f g) (a : PseudoElem x) (b : PseudoElem y) (H : PEq (PseudoIm a f) (PseudoIm b g)) : ∑ (d : PseudoElem Pb), (PEq (PseudoIm d (PullbackPr1 Pb)) a) × (PEq (PseudoIm d (PullbackPr2 Pb))) b. Proof. set (mor1 := PEqEpi1 H · b). set (mor2 := PEqEpi2 H · a). use tpair. - exact (make_PseudoElem (PullbackArrow Pb _ mor2 mor1 (PEq_Pullback_Eq f g Pb a b H))). - cbn. split. + use make_PEq. * exact (PEqOb H). * exact (PEqEpi2 H). * exact (identity_Epi _). * exact (PEq_Pullback_Eq1 f g Pb a b H). + use make_PEq. * exact (PEqOb H). * exact (PEqEpi1 H). * exact (identity_Epi _). * exact (PEq_Pullback_Eq2 f g Pb a b H). Defined. End def_pseudo_element. UniMath-20231010/UniMath/CategoryTheory/Quotobjects.v000066400000000000000000000027761451125700300223310ustar00rootroot00000000000000(** * Quotobjects *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Local Open Scope cat. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.UnderCategories. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.limits.pushouts. (** * Definition of quotient objects *) Section def_quotobjects. Variable C : category. Definition Quotobjectscategory (c : C) : UU := Undercategory (subprecategory_of_epis C) (has_homsets_subprecategory_of_epis C) (subprecategory_of_epis_ob C c). (** Construction of a quotient object from an epi *) Definition Quotobjectscategory_ob {c c' : C} (h : C⟦c, c'⟧) (isE : isEpi h) : Quotobjectscategory c := tpair _ (subprecategory_of_epis_ob C c') (tpair _ h isE). Hypothesis hpo : @Pushouts C. (** Given any quotient object Q of c and a morphism h : c -> c', by taking then pushout of Q by h we obtain a quotient object of c'. *) Definition PushoutQuotobject {c : C} (Q : Quotobjectscategory c) {c' : C} (h : C⟦c, c'⟧) : Quotobjectscategory c'. Proof. set (po := hpo _ _ _ h (pr1 (pr2 Q))). use Quotobjectscategory_ob. - exact po. - exact (limits.pushouts.PushoutIn1 po). - use EpiPushoutisEpi'. Defined. End def_quotobjects. UniMath-20231010/UniMath/CategoryTheory/README.md000066400000000000000000000146041451125700300211100ustar00rootroot00000000000000Category Theory =============== This evolved from the package "Rezk Completion" whose authors are: Benedikt Ahrens, Chris Kapulkin, Mike Shulman Hence, this Coq library in particular mechanizes the Rezk completion as described in http://arxiv.org/abs/1303.0584. It was written by Benedikt Ahrens, Chris Kapulkin and Mike Shulman. It builds upon V. Voevodsky's Foundations library, available on http://arxiv.org/abs/1401.0053. For any question about this library, send an email to Benedikt Ahrens. ## Terminology The terminology in this package differs from that of [the HoTT book](https://homotopytypetheory.org/book/). The following table offers a comparison. | UniMath | HoTT Book | Ob C | Hom_C | Univalence | |------------------------------|-----------------|------|-------|------------| | Precategory | n/a | Type | Type | No | | Category | Precategory | Type | Set | No | | Univalent/saturated category | Category | Type | Set | Yes | | Set category | Strict category | Set | Set | No | ## Contents ### The files containing the formalization of the Rezk Completion: * *precategories.v* * precategories * isomorphisms in precategories * *functor_categories.v* * functors and natural transformations * various properties of functors * the functor precategory is a category if the target category is * *sub_precategories.v* * sub-precategories * image factorization of a functor * a full subprecategory of a category is a category * *equivalences.v* * definition of adjunction * adjoint equivalence of precategories * proof that an adjoint equivalence of categories yields a weak equivalence of objects * a fully faithful and essentially surjective functor induces equivalence of precategories if its source is a category * *HLevel_n_is_of_hlevel_Sn.v* --- the type of types of hlevel n is itself of hlevel n+1 * *category_hset.v* * definition of the precategory of sets * proof that it is a category * *yoneda.v* * definition of Yoneda embedding * proof that it is fully faithful * *whiskering.v* * definition of whiskering * *precomp_fully_faithful.v* * precomposition with a fully faithful and essentially surjective functor yields a fully faithful functor * *precomp_ess_surj.v* * precomposition with a fully faithful and essentially surjective functor yields an essentially surjective functor * *rezk_completion.v* * put the previous files together and exhibit the Rezk completion ### many more files that were not needed for the Rezk completion and that go beyond the former package "Rezk Completion"; they have various authors (see the files individually that are given in alphabetic order): * *AbelianToAdditive.v* --- AbelianPreCat is Additive * *Abelian.v* --- abelian categories * *AdditiveFunctors.v* * *Additive.v* --- additive categories * *AdjunctionHomTypesWeq.v* * Derivation of the data of an adjunction in terms of equivalence of hom-types from the definition of adjunction in terms of unit and counit * *category_abgr.v* --- category of abelian groups * *category_binops.v* --- category of sets with binary operations * *category_hset_structures.v* --- limits, colimits and exponentials in HSET * *catiso.v* --- isomorphism of (pre)categories * *CocontFunctors.v* --- theory about (omega-)cocontinuous functors * *CohomologyComplex.v* --- cohomology of complexes * *CommaCategories.v* --- special comma categories (c ↓ K) * *Complexes.v*c --- category of complexes over an additive category * *covyoneda.v* --- covariant Yoneda functor * *EndofunctorsMonoidal.v* * Definition of the (weak) monoidal structure on endofunctors * *Epis.v* * *EquivalencesExamples.v* --- some adjunctions * binary delta_functor is left adjoint to binproduct_functor * general delta functor is left adjoint to the general product functor * bincoproduct_functor is left adjoint to the binary delta functor * general coproduct functor is left adjoint to the general delta functor * swapping of arguments in functor categories * *equivalences_lemmas.v* * definition of adjunction * definition of equivalence of precategories * some results * *exponentials.v* * *FunctorAlgebras.v* --- algebras of an endofunctor, Lambek's lemma * *GrothendieckTopos.v* * *Groupoids.v* --- Basic definitions of groupoids and discrete categories * *HorizontalComposition.v* * Definition of horizontal composition for natural transformations * *LocalizingClass.v* --- localizing class and localization of categories * *Monics.v* --- monics, their subcategory and their construction in functor categories * *Morphisms.v* *pair of morphisms* *short exact sequence data* * *opp_precat.v* --- opposite pre-category * *PointedFunctors.v* * Definition of precategory of pointed endofunctors * Forgetful functor to precategory of endofunctors * *PointedFunctorsComposition.v* * Definition of composition of pointed functors * *PreAdditive.v* --- preadditive categories * *PrecategoriesWithAbgrops.v* --- precategories whose homsets are abelian groups * *precategoriesWithBinOps.v* --- precategories such that spaces of morphisms have a binary operation * *PrecategoryBinProduct.v* * Definition of the cartesian product of two precategories * From a functor on a product of precategories to a functor on one of the categories by fixing the argument in the other component * *ProductPrecategory.v* --- general product category, not just binary product * *Quotobjects.v* --- quotient objects * *RightKanExtension.v* * Definition of global right Kan extension as right adjoint to precomposition * *ShortExactSequences.v* * *slicecat.v* --- slice precategories and colimits therein * *Subobjects.v* * *total2_paths.v* --- paths in total spaces are equivalent to pairs of paths (for fibrations over the universe) * *UnderPrecategories.v* * *UnicodeNotations.v* --- very few notations: -->, ;;, #F, C ⟦ a , b ⟧ ### The subdirectories * *limits* * definition of some limits and colimits * proof that they are unique in categories * with subdirectories cats and graphs * *bicategories* by Mitchell Riley * with 6 .v files there: notations.v, bicategory.v, Cat.v, internal_equivalence.v, prebicategory.v, whiskering.v * *Inductives* by Anders Mörtberg * with three case studies: Lists.v, Trees.v, LambdaCalculus.v * *Monads* --- developments about monads (incl. relative monads, modules for monads), see its own docUniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/000077500000000000000000000000001451125700300241435ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/Bifunctor.v000066400000000000000000000255631451125700300263000ustar00rootroot00000000000000Require Import UniMath.Foundations.Preamble. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.RepresentableFunctors.Precategories. Require Import UniMath.MoreFoundations.Tactics. Require Export UniMath.CategoryTheory.opp_precat UniMath.CategoryTheory.yoneda UniMath.CategoryTheory.categories.HSET.Core. Local Open Scope cat. (** bifunctor commutativity *) Definition comm_functor_data {I A B : category} : [I, [A, B] ] -> A -> functor_data I B := λ D a, functor_data_constr I B (λ i, D ◾ i ◾ a) (λ i j e, D ▭ e ◽ a). Lemma isfunctor_comm_functor_data {I A B : category} : ∏ (D:[I,[A,B]]) (a:A), is_functor (comm_functor_data D a). Proof. split. { unfold functor_idax. intro i; simpl. unfold functor_mor_application. now rewrite functor_id. } { intros i j k f g; simpl. unfold functor_mor_application. now rewrite functor_comp. } Qed. Definition comm_functor {I A B : category} : [I, [A, B] ] -> A -> [I,B]. Proof. intros D a. exists (comm_functor_data D a). exact (isfunctor_comm_functor_data D a). Defined. Definition comm_functor_data_2 (I A B:category) : functor_data [I,[A,B]] [A,[I,B]]. Proof. unshelve refine (_,,_). { intros D. unshelve refine (_,,_). { unshelve refine (_,,_). { intros a. exact (comm_functor D a). } intros a a' f; simpl. unshelve refine (_,,_). { simpl; intro i. exact (D ◾ i ▭ f). } { intros i j r; simpl; eqn_logic. } } { split; [ intros a; simpl; apply nat_trans_eq; [ apply homset_property | intros i; simpl; apply functor_id ] | intros a b g r s; simpl; apply nat_trans_eq; [ apply homset_property | simpl; intros i; apply functor_comp ] ]. } } { intros D D' p. simpl. unshelve refine (_,,_). { intros a. simpl. unshelve refine (_,,_). { exact (λ i, p ◽ i ◽ a). } { exact (λ i j e, maponpaths (λ v, v ◽ a) (nat_trans_ax p _ _ e)). } } { intros a b f; apply nat_trans_eq; [ apply homset_property | intros i; simpl; apply nat_trans_ax]. } } Defined. Definition isfunctor_comm_functor_data_2 {I A B:category} : is_functor (comm_functor_data_2 I A B). Proof. split. { intros D. simpl. apply nat_trans_eq. { exact (homset_property [I,B]). } simpl; intros a. apply nat_trans_eq. { apply homset_property. } reflexivity. } { intros D D' D'' p q; simpl. apply nat_trans_eq. exact (homset_property [I,B]). intros a; simpl. apply nat_trans_eq. { apply homset_property. } intros i; simpl. eqn_logic. } Qed. Definition bifunctor_comm (A B C:category) : [A,[B,C]] ⟶ [B,[A,C]]. Proof. exists (comm_functor_data_2 A B C). apply isfunctor_comm_functor_data_2. Defined. Lemma transportOverSet {X:UU} {Y:X->UU} (i:isaset X) {x:X} (e:x=x) {y y':Y x} : transportf Y e y = y. Proof. exact ((transportf (λ k, transportf Y k y = y) (pr1 (i x x (idpath x) e))) (idpath y)). Defined. Lemma comm_comm_iso_id (A B C:category) : Precategories.nat_iso (bifunctor_comm A B C ∙ bifunctor_comm B A C) (functor_identity _). Proof. intros. unshelve refine (makeNatiso _ _). { intro F. { unshelve refine (makeNatiso _ _). { intro a. unshelve refine (makeNatiso _ _). { intro b. exact (identity_z_iso _). } { abstract (intros b b' f; simpl; rewrite id_right, id_left; reflexivity) using _L_. } } abstract (intros a a' f; apply nat_trans_eq; [ apply homset_property | intro b; simpl; now rewrite id_left, id_right]) using _M_. } } { abstract (intros F F' p; simpl; apply nat_trans_eq; [ exact (homset_property [B,C]) | intro a; apply nat_trans_eq; [ apply homset_property | intro b; simpl; now rewrite id_right, id_left]]) using _N_. } Defined. Lemma transport_along_funextsec {X:UU} {Y:X->UU} {f g:∏ x, Y x} (e:f~g) (x:X) : transportf _ (funextsec _ _ _ e) (f x) = g x. Proof. now induction (funextsec _ _ _ e). Defined. Definition Functor_eq_map {A B: category} (F G:[A,B]) : F = G -> ∑ (ob : ∏ a, F ◾ a = G ◾ a), ∏ a a' f, transportf (λ k, k --> G ◾ a') (ob a) (transportf (λ k, F ◾ a --> k) (ob a') (F ▭ f)) = G ▭ f. Proof. intros e. unshelve refine (_,,_). - intros a. induction e. reflexivity. - intros a a' f; simpl. induction e; simpl. reflexivity. Defined. Section Working. Lemma Functor_eq_map_isweq {A B: category} {F G:[A,B]} : isweq (Functor_eq_map F G). Proof. (* should be provable using the ideas in isweqtoforallpaths *) Abort. Hypothesis Functor_eq_map_isweq : ∏ (A B: category) (F G:[A,B]), isweq (Functor_eq_map F G). Arguments Functor_eq_map_isweq {_ _ _ _} _. Lemma Functor_eq_weq {A B: category} (F G:[A,B]) : F = G ≃ ∑ (ob : ∏ a, F ◾ a = G ◾ a), ∏ a a' f, transportf (λ k, k --> G ◾ a') (ob a) (transportf (λ k, F ◾ a --> k) (ob a') (F ▭ f)) = G ▭ f. Proof. exact (make_weq _ Functor_eq_map_isweq). Defined. Lemma Functor_eq {A B: category} {F G:[A,B]} (ob : ∏ a, F ◾ a = G ◾ a) (mor : ∏ a a' f, transportf (λ k, k --> G ◾ a') (ob a) (transportf (λ k, F ◾ a --> k) (ob a') (F ▭ f)) = G ▭ f) : F = G. Proof. apply (invmap (Functor_eq_weq F G)). exists ob. exact mor. Defined. Lemma comm_comm_eq_id (A B C:category) : bifunctor_comm A B C ∙ bifunctor_comm B A C = functor_identity _. Proof. intros. unshelve refine (Functor_eq _ _). { intro F. change (functor_identity [A, [B, C]] ◾ F) with F. unshelve refine (Functor_eq _ _). { intro a. unshelve refine (Functor_eq _ _); reflexivity. } { intros a a' f; simpl. (* how does one deal with such transports in Coq? *) Abort. End Working. (** bifunctors related to representable functors *) Definition θ_1 {B C:category} (F : [B, C]) (X : [B, [C^op, HSET]]) : hSet := (∏ b, F ◾ b ⇒ X ◾ b) % set. Definition θ_2 {B C:category} (F : [B, C]) (X : [B, [C^op, HSET]]) (x : θ_1 F X) : hSet := hProp_to_hSet (∀ (b' b:B) (f:b'-->b), (x b ⟲ F ▭ f = X ▭ f ⟳ x b' )) % logic. Definition θ {B C:category} (F : [B, C]) (X : [B, [C^op, HSET]]) : hSet := ( ∑ x : θ_1 F X, θ_2 F X x ) % set. Local Notation "F ⟹ X" := (θ F X) (at level 39) : cat. (* to input: type "\==>" with Agda input method *) Definition θ_subset {B C:category} {F : [B, C]} {X : [B, [C^op, HSET]]} (t u : F ⟹ X) : pr1 t = pr1 u -> t = u. Proof. apply subtypePath. intros x. apply impred; intro b;apply impred; intro b'; apply impred; intro f. apply setproperty. Defined. Definition θ_map_1 {B C:category} {F' F:[B, C]} {X : [B, [C^op, HSET]]} : F' --> F -> F ⟹ X -> θ_1 F' X := λ p xe b, pr1 xe b ⟲ p ◽ b. Definition θ_map_2 {B C:category} {F' F:[B, C]} {X : [B, [C^op, HSET]]} (p : F' --> F) (xe : F ⟹ X) : θ_2 F' X (θ_map_1 p xe). Proof. induction xe as [x e]. unfold θ_map_1; unfold θ_1 in x; unfold θ_2 in e. intros b' b f; simpl. rewrite <- arrow_mor_mor_assoc. rewrite nattrans_naturality. rewrite arrow_mor_mor_assoc. rewrite e. rewrite nattrans_arrow_mor_assoc. reflexivity. Qed. Definition θ_map {B C:category} {F' F:[B, C]} {X : [B, [C^op, HSET]]} : F' --> F -> F ⟹ X -> F' ⟹ X := λ p xe, θ_map_1 p xe ,, θ_map_2 p xe. Notation "xe ⟲⟲ p" := (θ_map p xe) (at level 50, left associativity) : cat. Definition φ_map_1 {B C:category} {F:[B, C]} {X' X: [B, [C^op, HSET]]} : F ⟹ X -> X --> X' -> θ_1 F X' := λ x p b, p ◽ b ⟳ pr1 x b. Definition φ_map_2 {B C:category} {F:[B, C]} {X' X: [B, [C^op, HSET]]} (x : F ⟹ X) (p : X --> X') : θ_2 F X' (φ_map_1 x p). Proof. induction x as [x e]. unfold φ_map_1; unfold θ_1 in x; unfold θ_2 in e; unfold θ_2. intros b b' f; simpl. rewrite <- nattrans_arrow_mor_assoc. rewrite e. rewrite 2? nattrans_nattrans_arrow_assoc. exact (maponpaths (λ k, k ⟳ x b) (nattrans_naturality p f)). Qed. Definition φ_map {B C:category} {F:[B, C]} {X' X: [B, [C^op, HSET]]} : F ⟹ X -> X --> X' -> F ⟹ X' := λ x p, φ_map_1 x p,, φ_map_2 x p. Definition bifunctor_assoc {B C:category} : [B, [C^op,HSET]] ⟶ [[B,C]^op,HSET]. Proof. unshelve refine (makeFunctor _ _ _ _). { intros X. unshelve refine (makeFunctor_op _ _ _ _). { intro F. exact (F ⟹ X). } { intros F' F p xe. exact (xe ⟲⟲ p). } { abstract ( intros F; apply funextsec; intro xe; apply θ_subset; simpl; apply funextsec; intro b; apply arrow_mor_id) using _K_. } { abstract ( intros F F' F'' p q; simpl; apply funextsec; intro xe; apply θ_subset; simpl; apply funextsec; intro b; unfold θ_map_1; exact (arrow_mor_mor_assoc _ _ _)) using _L_. } } { intros X Y p. simpl. unshelve refine (_,,_). { intros F. simpl. intro x. exact (φ_map x p). } { abstract ( intros F G q; simpl in F, G; simpl; apply funextsec; intro w; unshelve refine (total2_paths2_f _ _); [ apply funextsec; intro b; unfold φ_map, φ_map_1, θ_map_1; simpl; unfold θ_map_1; simpl; apply nattrans_arrow_mor_assoc | apply funextsec; intro b; apply funextsec; intro b'; apply funextsec; intro b''; apply setproperty ]) using _L_. } } { abstract( simpl; intro F; apply nat_trans_eq; [ exact (homset_property HSET) | intro G; simpl; unfold φ_map; simpl; unfold φ_map_1; simpl; apply funextsec; intro w; simpl; unshelve refine (total2_paths_f _ _); [ simpl; apply funextsec; intro b; reflexivity | apply funextsec; intro b; apply funextsec; intro b'; apply funextsec; intro f; simpl; apply setproperty] ]) using _L_. } { abstract (intros F F' F'' p q; simpl; apply nat_trans_eq; [ exact (homset_property HSET) | intro G; simpl; apply funextsec; intro w; unshelve refine (total2_paths2_f _ _); [ unfold φ_map, φ_map_1; simpl; apply funextsec; intro b; apply pathsinv0, nattrans_nattrans_arrow_assoc | apply funextsec; intro b; apply funextsec; intro b'; apply funextsec; intro f; apply setproperty ]]) using _L_. } Defined. (* *) UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/DirectSum.v000066400000000000000000000075541451125700300262440ustar00rootroot00000000000000(** *** direct sums Recall that X is a family of objects in a category, and the map from the sum to the product is an isomorphism, then the sum is called a direct sum. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.Foundations.Sets UniMath.Combinatorics.FiniteSets UniMath.CategoryTheory.RepresentableFunctors.Representation UniMath.CategoryTheory.RepresentableFunctors.Precategories. Require UniMath.CategoryTheory.RepresentableFunctors.RawMatrix. Local Open Scope cat. Definition identity_matrix {C:category} (h:ZeroMaps C) {I} (d:I -> ob C) (dec : isdeceq I) : ∏ i j, Hom C (d j) (d i). Proof. intros. induction (dec i j) as [ eq | ne ]. { induction eq. apply identity. } { apply h. } Defined. Definition identity_map {C:category} (h:ZeroMaps C) {I} {d:I -> ob C} (dec : isdeceq I) (B:Sum d) (D:Product d) : Hom C (universalObject B) (universalObject D). Proof. intros. apply RawMatrix.from_matrix. apply identity_matrix. - assumption. - assumption. Defined. (* Record DirectSum {C:category} (h:ZeroMaps C) I (dec : isdeceq I) (c : I -> ob C) := *) (* make_DirectSum { *) (* ds : C; *) (* ds_pr : ∏ i, Hom C ds (c i); *) (* ds_in : ∏ i, Hom C (c i) ds; *) (* ds_id : ∏ i j, ds_pr i ∘ ds_in j = identity_matrix h c dec i j; *) (* ds_isprod : ∏ c, isweq (λ f : Hom C c ds, λ i, ds_pr i ∘ f); *) (* ds_issum : ∏ c, isweq (λ f : Hom C ds c, λ i, f ∘ ds_in i) }. *) Section A. Context {C:category} (h:ZeroMaps C) I (dec : isdeceq I) (c : I -> ob C). Definition DirectSum : Type := (* *) ∑ (ds : C) (ds_pr : ∏ i, Hom C ds (c i)) (ds_in : ∏ i, Hom C (c i) ds) (ds_id : ∏ i j, ds_pr i ∘ ds_in j = identity_matrix h c dec i j) (ds_isprod : ∏ c, isweq (λ f : Hom C c ds, λ i, ds_pr i ∘ f)), (* ds_issum : *) ∏ c, isweq (λ f : Hom C ds c, λ i, f ∘ ds_in i). Definition ds (x:DirectSum) := pr1 x. Definition ds_pr (x:DirectSum) := pr12 x. Definition ds_in (x:DirectSum) := pr122 x. Definition ds_id (x:DirectSum) := pr122 (pr2 x). Definition ds_isprod (x:DirectSum) := pr122 (pr22 x). Definition ds_issum (x:DirectSum) := pr222 (pr22 x). Definition make_DirectSum ds ds_pr ds_in ds_id ds_isprod ds_issum : DirectSum := ds,, ds_pr,, ds_in,, ds_id,, ds_isprod,, ds_issum. End A. Definition toDirectSum {C:category} (h:ZeroMaps C) {I} (dec : isdeceq I) (d:I -> ob C) (B:Sum d) (D:Product d) (is: is_iso (identity_map h dec B D)) : DirectSum h I dec d. Proof. intros. set (id := identity_map h dec B D). refine (make_DirectSum h I dec d (universalObject D) (λ i, pr_ D i) (λ i, id ∘ in_ B i) _ _ _). { intros. exact (RawMatrix.from_matrix_entry_assoc D B (identity_matrix h d dec) i j). } { intros. exact (pr2 (universalProperty D c)). } { intros. assert (b : (λ (f : Hom C (universalObject D) c) (i : I), (f ∘ id) ∘ in_ B i) = (λ (f : Hom C (universalObject D) c) (i : I), f ∘ (id ∘ in_ B i))). { apply funextsec; intros f. apply funextsec; intros i. apply assoc. } destruct b. exact (twooutof3c (λ f, f ∘ id) (λ g i, g ∘ in_ B i) (iso_comp_right_isweq (id,,is) c) (pr2 (universalProperty B c))). } Defined. Definition FiniteDirectSums (C:category) := ∑ h : ZeroMaps C, ∏ I : FiniteSet, ∏ d : I -> ob C, DirectSum h I (isfinite_isdeceq I (pr2 I)) d. UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/Precategories.v000066400000000000000000000443231451125700300271340ustar00rootroot00000000000000(* -*- coding: utf-8 -*- *) Require Export UniMath.CategoryTheory.Core.Categories. (* export its coercions, especially *) Require Export UniMath.CategoryTheory.Core.Isos. (* export its coercions, especially *) Require Export UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.Core.NaturalTransformations. Require Export UniMath.CategoryTheory.Core.Univalence. Require Export UniMath.CategoryTheory.opp_precat UniMath.CategoryTheory.yoneda UniMath.CategoryTheory.categories.HSET.Core UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Export UniMath.Foundations.Preamble. Require Export UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Local Open Scope cat. Notation "a <-- b" := (@precategory_morphisms (opp_precat _) a b) : cat. Definition src {C:precategory} {a b:C} (f:a-->b) : C := a. Definition tar {C:precategory} {a b:C} (f:a-->b) : C := b. Definition hom (C:precategory_data) : ob C -> ob C -> UU := λ c c', c --> c'. Definition Hom (C : category) : ob C -> ob C -> hSet := λ c c', make_hSet (c --> c') (homset_property C _ _ ). Ltac eqn_logic := abstract ( repeat ( try reflexivity; try intro; try split; try apply id_right; try apply id_left; try apply assoc; try apply funextsec; try apply homset_property; try apply isasetunit; try apply isapropunit; try refine (two_arg_paths_f _ _); try refine (total2_paths_f _ _); try refine (nat_trans_ax _ _ _ _); try refine (! nat_trans_ax _ _ _ _); try apply functor_id; try apply functor_comp; try apply isaprop_is_nat_trans )) using _L_. Ltac set_logic := abstract (repeat ( try intro; try apply isaset_total2; try apply isasetdirprod; try apply homset_property; try apply impred_isaset; try apply isasetaprop)) using _M_. Notation "[ C , D ]" := (functor_category C D) : cat. Definition oppositecategory (C : category) : category. Proof. exists (opp_precat C). unfold category in C. exact (λ a b, pr2 C b a). Defined. Notation "C '^op'" := (oppositecategory C) (at level 3, format "C ^op") : cat. (* this overwrites the previous definition *) Definition precategory_obmor (C:precategory) : precategory_ob_mor := precategory_ob_mor_from_precategory_data ( precategory_data_from_precategory C). Definition Functor_obmor {C D} (F:functor C D) := pr1 F. Definition Functor_obj {C D} (F:functor C D) := pr1 (pr1 F). Definition Functor_mor {C D} (F:functor C D) := pr2 (pr1 F). Definition Functor_identity {C D} (F:functor C D) := functor_id F. Definition Functor_compose {C D} (F:functor C D) := @functor_comp _ _ F. Definition theUnivalenceProperty (C: univalent_category) := pr2 C : is_univalent C. (** embeddings and isomorphism of categories *) Definition categoryEmbedding (B C : category) := ∑ F:[B,C], fully_faithful F. Definition embeddingToFunctor (B C : category) : categoryEmbedding B C -> B ⟶ C := pr1. Coercion embeddingToFunctor : categoryEmbedding >-> functor. Definition categoryIsomorphism (B C : category) := ∑ F:categoryEmbedding B C, isweq ((pr1 F : B ⟶ C) : ob B -> ob C). Definition isomorphismToEmbedding (B C:category) : categoryIsomorphism B C -> categoryEmbedding B C := pr1. Coercion isomorphismToEmbedding : categoryIsomorphism >-> categoryEmbedding. Definition isomorphismOnMor {B C:category} (F:categoryIsomorphism B C) (b b':B) : Hom B b b' ≃ Hom C (F b) (F b') := make_weq _ (pr2 (pr1 F) b b'). (** *** make a precategory *) Definition makecategory_ob_mor (obj : UU) (mor : obj -> obj -> UU) : precategory_ob_mor := make_precategory_ob_mor obj (λ i j:obj, mor i j). Definition makecategory_data (obj : UU) (mor : obj -> obj -> UU) (identity : ∏ i, mor i i) (compose : ∏ i j k (f:mor i j) (g:mor j k), mor i k) : precategory_data := make_precategory_data (makecategory_ob_mor obj mor) identity compose. Definition makeFunctor {C D:category} (obj : C -> D) (mor : ∏ c c' : C, c --> c' -> obj c --> obj c') (identity : ∏ c, mor c c (identity c) = identity (obj c)) (compax : ∏ (a b c : C) (f : a --> b) (g : b --> c), mor a c (g ∘ f) = mor b c g ∘ mor a b f) : C ⟶ D := (obj,, mor),, identity,, compax. (** notation for dealing with functors, natural transformations, etc. *) Definition functor_object_application {B C:category} (F : [B,C]) (b:B) : C := (F:_⟶_) b. Notation "F ◾ b" := (functor_object_application F b) : cat. (* \sqb3 *) Definition functor_mor_application {B C:category} {b b':B} (F:[B,C]) : b --> b' -> F ◾ b --> F ◾ b' := λ f, # (F:_⟶_) f. Notation "F ▭ f" := (functor_mor_application F f) : cat. Definition arrow {C:category} (c : C) (X : [C^op,HSET]) : hSet := X ◾ c. Notation "c ⇒ X" := (arrow c X) : cat. (* \r= *) Definition arrow' {C:category} (c : C) (X : [C^op^op,HSET]) : hSet := X ◾ c. Notation "X ⇐ c" := (arrow' c X) : cat. (* \l= *) Definition arrow_morphism_composition {C:category} {c' c:C} {X:[C^op,HSET]} : c'-->c -> c⇒X -> c'⇒X := λ f x, # (X:_⟶_) f x. Notation "x ⟲ f" := (arrow_morphism_composition f x) (at level 50, left associativity) : cat. (* ⟲ agda-input \l C-N C-N C-N 2 the first time, \l the second time *) (* motivation for the notation: the morphisms of C act on the right of the elements of X *) Definition nattrans_arrow_composition {C:category} {X X':[C^op,HSET]} {c:C} : c⇒X -> X-->X' -> c⇒X' := λ x q, (q:_ ⟹ _) c (x:(X:_⟶_) c:hSet). Notation "q ⟳ x" := (nattrans_arrow_composition x q) (at level 50, left associativity) : cat. (* ⟳ agda-input \r C-N C-N C-N 3 the first time, \r the second time *) (* motivation for the notation: the natural transformations between functors act on the left of the elements of the functors *) Definition nattrans_object_application {B C:category} {F F' : [B,C]} (b:B) : F --> F' -> F ◾ b --> F' ◾ b := λ p, (p:_ ⟹ _) b. Notation "p ◽ b" := (nattrans_object_application b p) : cat. (* agda input : \sqw3 *) Definition arrow_mor_id {C:category} {c:C} {X:[C^op,HSET]} (x:c⇒X) : x ⟲ identity c = x := eqtohomot (functor_id X c) x. Definition arrow_mor_mor_assoc {C:category} {c c' c'':C} {X:[C^op,HSET]} (g:c''-->c') (f:c'-->c) (x:c⇒X) : x ⟲ (f ∘ g) = (x ⟲ f) ⟲ g := eqtohomot (functor_comp X f g) x. Definition nattrans_naturality {B C:category} {F F':[B, C]} {b b':B} (p : F --> F') (f : b --> b') : p ◽ b' ∘ F ▭ f = F' ▭ f ∘ p ◽ b := nat_trans_ax p _ _ f. Definition comp_func_on_mor {A B C:category} (F:[A,B]) (G:[B,C]) {a a':A} (f:a-->a') : F ∙ G ▭ f = G ▭ (F ▭ f). Proof. reflexivity. Defined. Definition nattrans_arrow_mor_assoc {C:category} {c' c:C} {X X':[C^op,HSET]} (g:c'-->c) (x:c⇒X) (p:X-->X') : p ⟳ (x ⟲ g) = (p ⟳ x) ⟲ g := eqtohomot (nat_trans_ax p _ _ g) x. Definition nattrans_arrow_id {C:category} {c:C} {X:[C^op,HSET]} (x:c⇒X) : nat_trans_id _ ⟳ x = x := idpath _. Definition nattrans_nattrans_arrow_assoc {C:category} {c:C} {X X' X'':[C^op,HSET]} (x:c⇒X) (p:X-->X') (q:X'-->X'') : q ⟳ (p ⟳ x) = (q ∘ p) ⟳ x := idpath _. Definition nattrans_nattrans_object_assoc {A B C:category} (F:[A,B]) (G:[B, C]) {a a' : A} (f : a --> a') : F ∙ G ▭ f = G ▭ (F ▭ f) := idpath _. Lemma functor_on_id {B C:category} (F:[B,C]) (b:B) : F ▭ identity b = identity (F ◾ b). Proof. exact (functor_id F b). Defined. Lemma functor_on_comp {B C:category} (F:[B,C]) {b b' b'':B} (g:b'-->b'') (f:b-->b') : F ▭ (g ∘ f) = F ▭ g ∘ F ▭ f. Proof. exact (functor_comp F f g). Defined. (* *) (** natural transformations and isomorphisms *) Definition nat_iso {B C:category} (F G:[B,C]) := z_iso F G. Definition makeNattrans {C D:category} {F G:[C,D]} (mor : ∏ x : C, F ◾ x --> G ◾ x) (eqn : ∏ c c' f, mor c' ∘ F ▭ f = G ▭ f ∘ mor c) : F --> G := (mor,,eqn). Definition makeNattrans_op {C D:category} {F G:[C^op,D]} (mor : ∏ x : C, F ◾ x --> G ◾ x) (eqn : ∏ c c' f, mor c' ∘ F ▭ f = G ▭ f ∘ mor c) : F --> G := (mor,,eqn). Definition makeNatiso {C D:category} {F G:[C,D]} (mor : ∏ x : C, z_iso (F ◾ x) (G ◾ x)) (eqn : ∏ c c' f, mor c' ∘ F ▭ f = G ▭ f ∘ mor c) : nat_iso F G. Proof. refine (makeNattrans mor eqn,,_). apply nat_trafo_z_iso_if_pointwise_z_iso; intro c. apply pr2. Defined. Definition makeNatiso_op {C D:category} {F G:[C^op,D]} (mor : ∏ x : C, z_iso (F ◾ x) (G ◾ x)) (eqn : ∏ c c' f, mor c' ∘ F ▭ f = G ▭ f ∘ mor c) : nat_iso F G. Proof. refine (makeNattrans_op mor eqn,,_). apply nat_trafo_z_iso_if_pointwise_z_iso; intro c. apply pr2. Defined. Lemma move_inv {C:category} {a a' b' b:C} {f : a --> b} {f' : a' --> b'} {i : a --> a'} {i' : a' --> a} {j : b --> b'} {j' : b' --> b} : is_inverse_in_precat i i' -> is_inverse_in_precat j j' -> j ∘ f = f' ∘ i -> j' ∘ f' = f ∘ i'. Proof. intros I J r. rewrite <- id_right. rewrite (! pr1 J). rewrite assoc. apply (maponpaths (λ k, j' ∘ k)). rewrite <- assoc. rewrite r. rewrite assoc. rewrite (pr2 I). rewrite id_left. reflexivity. Defined. Lemma weq_iff_z_iso_SET {X Y:HSET} (f:X-->Y) : is_z_isomorphism f <-> isweq f. Proof. split. - intro i. set (F := make_z_iso' f i). refine (isweq_iso f (inv_from_z_iso F) (λ x, eqtohomot (z_iso_inv_after_z_iso F) x) (λ y, eqtohomot (z_iso_after_z_iso_inv F) y)). - intro i. apply (hset_equiv_is_z_iso X Y (_,,i)). Defined. Lemma weq_to_iso_SET {X Y:HSET} : z_iso X Y ≃ ((X:hSet) ≃ (Y:hSet)). (* same as hset_iso_equiv_weq? -- this identifier does no longer exist *) Proof. intros. apply weqfibtototal; intro f. apply weqiff. - apply weq_iff_z_iso_SET. - apply isaprop_is_z_isomorphism. - apply isapropisweq. Defined. (* opposite categories *) Definition functor_to_opp_opp {C:category} : C ⟶ C^op^op := makeFunctor (λ c,c) (λ a b f,f) (λ c, idpath _) (λ a b c f g, idpath _). Definition makeFunctor_op {C D:category} (obj : ob C -> ob D) (mor : ∏ a b : C, b --> a -> obj a --> obj b) (identity : ∏ c, mor c c (identity c) = identity (obj c)) (compax : ∏ (a b c : C) (f : b --> a) (g : c --> b), mor a c (f ∘ g) = mor b c g ∘ mor a b f) : C^op ⟶ D := (obj,, mor),, identity,, compax. Definition opp_ob {C:category} : ob C -> ob C^op := λ c, c. Definition rm_opp_ob {C:category} : ob C^op -> ob C := λ c, c. Definition opp_mor {C:category} {b c:C} : Hom C b c -> Hom C^op c b := λ f, f. Definition rm_opp_mor {C:category} {b c:C} : Hom C^op b c -> Hom C c b := λ f, f. Definition opp_mor_eq {C:category} {a b:C} (f g:a --> b) : opp_mor f = opp_mor g -> f = g := idfun _. Lemma opp_opp_precat_ob_mor (C : precategory_ob_mor) : C = opp_precat_ob_mor (opp_precat_ob_mor C). Proof. induction C as [ob mor]. reflexivity. Defined. Lemma opp_opp_precat_ob_mor_compute (C : precategory_ob_mor) : idpath _ = maponpaths precategory_id_comp (opp_opp_precat_ob_mor C). Proof. induction C as [ob mor]. reflexivity. Defined. Lemma opp_opp_precat_data (C : precategory_data) : C = opp_precat_data (opp_precat_data C). Proof. induction C as [[ob mor] [id co]]. reflexivity. Defined. Lemma opp_opp_precat (C:category) : C = C^op^op. Proof. apply category_eq. (* we need both associativity axioms to avoid this *) reflexivity. Qed. Definition functorOp {B C : category} : [B, C] ^op ⟶ [B ^op, C ^op]. Proof. unshelve refine (makeFunctor _ _ _ _). { exact functor_opp. } { intros H I p. exists (λ b, pr1 p b). abstract (intros b b' f; simpl; exact (! nat_trans_ax p _ _ f)) using _L_. } { abstract (intros H; now apply (nat_trans_eq (homset_property _))). } { abstract (intros H J K p q; now apply (nat_trans_eq (homset_property _))). } Defined. Definition functorOp' {B C:category} : [B,C] ⟶ [B^op,C^op]^op. Proof. exact (functorOp functorOp). Defined. Definition functorRmOp {B C : category} : [B ^op, C ^op] ⟶ [B, C] ^op. Proof. unshelve refine (makeFunctor _ _ _ _). { exact functor_opp. } { intros H I p. exists (λ b, pr1 p b). abstract (intros b b' f; simpl; exact (! nat_trans_ax p _ _ f)) using _L_. } { abstract (intros H; now apply (nat_trans_eq (homset_property _))) using _L_. } { abstract (intros H J K p q; now apply (nat_trans_eq (homset_property _))). } Defined. Definition functorMvOp {B C:category} : [B,C^op] ⟶ [B^op,C]^op. Proof. unshelve refine (makeFunctor _ _ _ _). { exact functor_opp. } { intros H I p. exists (λ b, pr1 p b). abstract (intros b b' f; simpl; exact (! nat_trans_ax p _ _ f)) using _L_. } { abstract (intros H; now apply (nat_trans_eq (homset_property _))). } { abstract (intros H J K p q; now apply (nat_trans_eq (homset_property _))). } Defined. Lemma functorOpIso {B C:category} : categoryIsomorphism [B, C]^op [B^op, C^op]. Proof. unshelve refine (_,,_). { unshelve refine (_,,_). { exact functorOp. } { intros H H'. unshelve refine (isweq_iso _ _ _ _). { simpl. intros p. unshelve refine (makeNattrans _ _). { intros b. exact (pr1 p b). } { abstract (intros b b' f; simpl; exact (!nat_trans_ax p _ _ f)) using _L_. } } { abstract (intro p; apply nat_trans_eq; [ apply homset_property | intro b; reflexivity ]) using _L_. } { abstract (intro p; apply nat_trans_eq; [ apply homset_property | intro b; reflexivity ]) using _L_. }}} { simpl. unshelve refine (isweq_iso _ _ _ _). { exact (functor_opp : B^op ⟶ C^op -> B ⟶ C). } { abstract (intros H; simpl; apply (functor_eq _ _ (homset_property C)); unshelve refine (total2_paths_f _ _); reflexivity) using _L_. } { abstract (intros H; simpl; apply functor_eq; [ exact (homset_property C^op) | unshelve refine (total2_paths_f _ _); reflexivity]). } } Defined. Definition functorOpEmb {B C:category} : categoryEmbedding [B, C]^op [B^op, C^op] := pr1 functorOpIso. Lemma functor_op_rm_op_eq {C D:category} (F : C^op ⟶ D^op) : functorOp (functorRmOp F) = F. Proof. apply functor_eq. { apply homset_property. } unshelve refine (total2_paths_f _ _); reflexivity. Qed. Lemma functor_rm_op_op_eq {C D:category} (F : C ⟶ D) : functorRmOp (functorOp F) = F. Proof. apply functor_eq. { apply homset_property. } unshelve refine (total2_paths_f _ _); reflexivity. Qed. Lemma functor_op_op_eq {C D:category} (F : C ⟶ D) : functorOp (functorOp F) = F. Proof. apply functor_eq. { apply homset_property. } unshelve refine (total2_paths_f _ _); reflexivity. Qed. (* new categories from old *) Definition categoryWithStructure (C:category) (P:ob C -> UU) : category. Proof. use makecategory. (* add a new component to each object: *) - exact (∑ c:C, P c). (* the homsets ignore the extra structure: *) - intros x y. exact (pr1 x --> pr1 y). (* the rest is the same: *) - intros. apply homset_property. - intros x. apply identity. - intros x y z f g. exact (g ∘ f). - intros. apply id_left. - intros. apply id_right. - intros. apply assoc. - intros. apply assoc'. Defined. Definition functorWithStructures {C:category} {P Q:ob C -> UU} (F : ∏ c, P c -> Q c) : categoryWithStructure C P ⟶ categoryWithStructure C Q. Proof. unshelve refine (makeFunctor _ _ _ _). (* transport the structure: *) - exact (λ c, (pr1 c,, F (pr1 c) (pr2 c))). (* the rest is the same: *) - intros c c' f. exact f. - reflexivity. - reflexivity. Defined. Definition addStructure {B C:category} {P:ob C -> UU} (F:B⟶C) (h : ∏ b, P(F b)) : B ⟶ categoryWithStructure C P. Proof. unshelve refine (makeFunctor _ _ _ _). - intros b. exact (F b,,h b). - intros b b' f. exact (# F f). - abstract (intros b; simpl; apply functor_id) using _L_. - abstract (intros b b' b'' f g; simpl; apply functor_comp) using _L_. Defined. Lemma identityFunction : ∏ (T:HSET) (f:T-->T) (t:T:hSet), f = identity T -> f t = t. Proof. intros ? ? ? e. exact (eqtohomot e t). Defined. Lemma identityFunction' : ∏ (T:HSET) (t:T:hSet), identity T t = t. Proof. reflexivity. Defined. (* *) Lemma functor_identity_object {C:category} (c:C) : functor_identity C ◾ c = c. Proof. reflexivity. Defined. Lemma functor_identity_arrow {C:category} {c c':C} (f:c-->c') : functor_identity C ▭ f = f. Proof. reflexivity. Defined. Definition constantFunctor (C:category) {D:category} (d:D) : [C,D]. Proof. unshelve refine (makeFunctor _ _ _ _). - exact (λ _, d). - intros c c' f; simpl. exact (identity d). - intros c; simpl. reflexivity. - abstract (simpl; intros a b c f g; apply pathsinv0, id_left) using _L_. Defined. (* *) Definition functor_composite_functor {A B C:category} (F:A⟶B) : [B,C] ⟶ [A,C]. Proof. unshelve refine (makeFunctor _ _ _ _). - exact (λ G, F ∙ G). - intros G G' p; simpl. unshelve refine (@makeNattrans A C (F ∙ G) (F ∙ G') (λ a, p ◽ (F ◾ a)) _). abstract ( intros a a' f; rewrite 2? nattrans_nattrans_object_assoc; exact (nattrans_naturality p (F ▭ f))) using _L_. - abstract ( intros G; now apply (nat_trans_eq (homset_property C))) using _M_. - abstract ( intros G G' G'' p q; now apply (nat_trans_eq (homset_property C))) using _N_. Defined. (* zero maps, definition: *) Definition ZeroMaps (C:category) := ∑ (zero : ∏ a b:C, a --> b), (∏ a b c, ∏ f:b --> c, f ∘ zero a b = zero a c) × (∏ a b c, ∏ f:c --> b, zero b a ∘ f = zero c a). Definition is {C:category} (zero: ZeroMaps C) {a b:C} (f:a-->b) := f = pr1 zero _ _. Definition ZeroMaps_opp (C:category) : ZeroMaps C -> ZeroMaps C^op := λ z, (λ a b, pr1 z b a) ,, pr2 (pr2 z) ,, pr1 (pr2 z). Definition ZeroMaps_opp_opp (C:category) (zero:ZeroMaps C) : ZeroMaps_opp C^op (ZeroMaps_opp C zero) = zero. Proof. unshelve refine (total2_paths_f _ _). - reflexivity. - unshelve refine (total2_paths_f _ _); reflexivity. Defined. (* *) UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/README.md000066400000000000000000000013601451125700300254220ustar00rootroot00000000000000Representable Functors ====================== In this subdirectory is a unified approach to the notions of category theory satisfying universal properties via representable functors. The idea is that uniqueness up to isomorphism of two objects satisfying the same universal property should always be drawn as a direct corollary of the uniqueness of representations of a representable functor. These files were originally in the Ktheory package and were written by Dan Grayson. Overview of contents ==================== ## Precategories.v easy lemmas about precategories, could be moved up ## Representation.v Representation.Data is a representation of a functor C ==> Set. This is used in other files for defining various limits and colimits. UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/RawMatrix.v000066400000000000000000000063451451125700300262600ustar00rootroot00000000000000(** ** raw matrices Raw matrices of a map are formed from a product decomposition of the target or from a sum decomposition of the source. We call them "raw" to distinguish them from matrices formed from direct sum decompositions. *) Require Import UniMath.Foundations.Sets UniMath.CategoryTheory.Core.Categories UniMath.CategoryTheory.Core.Isos UniMath.CategoryTheory.Core.Functors UniMath.CategoryTheory.Core.NaturalTransformations UniMath.CategoryTheory.RepresentableFunctors.Representation UniMath.CategoryTheory.RepresentableFunctors.Precategories. Local Open Scope cat. Definition to_row {C:category} {I} {b:I -> ob C} (B:Sum b) {d:ob C} : (Hom C (universalObject B) d) ≃ (∏ j, Hom C (b j) d). Proof. intros. exact (universalProperty B d). Defined. Definition from_row {C:category} {I} {b:I -> ob C} (B:Sum b) {d:ob C} : (∏ j, Hom C (b j) d) ≃ (Hom C (universalObject B) d). Proof. intros. apply invweq. apply to_row. Defined. Lemma from_row_entry {C:category} {I} {b:I -> ob C} (B:Sum b) {d:ob C} (f : ∏ j, Hom C (b j) d) : ∏ j, from_row B f ∘ opp_mor (universalElement B j) = f j. Proof. intros. exact (eqtohomot (homotweqinvweq (to_row B) f) j). Qed. Definition to_col {C:category} {I} {d:I -> ob C} (D:Product d) {b:ob C} : (Hom C b (universalObject D)) ≃ (∏ i, Hom C b (d i)). Proof. intros. exact (universalProperty D b). Defined. Definition from_col {C:category} {I} {d:I -> ob C} (D:Product d) {b:ob C} : (∏ i, Hom C b (d i)) ≃ (Hom C b (universalObject D)). Proof. intros. apply invweq. apply to_col. Defined. Lemma from_col_entry {C:category} {I} {b:I -> ob C} (D:Product b) {d:ob C} (f : ∏ i, Hom C d (b i)) : ∏ i, universalElement D i ∘ from_col D f = f i. Proof. intros. apply (eqtohomot (homotweqinvweq (to_col D) f ) i). Qed. Definition to_matrix {C:category} {I} {d:I -> ob C} (D:Product d) {J} {b:J -> ob C} (B:Sum b) : (Hom C (universalObject B) (universalObject D)) ≃ (∏ i j, Hom C (b j) (d i)). Proof. intros. apply @weqcomp with (Y := ∏ i, Hom C (universalObject B) (d i)). { apply to_col. } { apply weqonsecfibers; intro i. apply to_row. } Defined. Definition from_matrix {C:category} {I} {d:I -> ob C} (D:Product d) {J} {b:J -> ob C} (B:Sum b) : weq (∏ i j, Hom C (b j) (d i)) (Hom C (universalObject B) (universalObject D)). Proof. intros. apply invweq. apply to_matrix. Defined. Lemma from_matrix_entry {C:category} {I} {d:I -> ob C} (D:Product d) {J} {b:J -> ob C} (B:Sum b) (f : ∏ i j, Hom C (b j) (d i)) : ∏ i j, (universalElement D i ∘ from_matrix D B f) ∘ opp_mor (universalElement B j) = f i j. Proof. intros. exact (eqtohomot (eqtohomot (homotweqinvweq (to_matrix D B) f) i) j). Qed. Lemma from_matrix_entry_assoc {C:category} {I} {d:I -> ob C} (D:Product d) {J} {b:J -> ob C} (B:Sum b) (f : ∏ i j, Hom C (b j) (d i)) : ∏ i j, universalElement D i ∘ (from_matrix D B f ∘ opp_mor(universalElement B j)) = f i j. Proof. intros. rewrite <- assoc. exact (from_matrix_entry D B f i j). Qed. UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/Representation.v000066400000000000000000001154441451125700300273450ustar00rootroot00000000000000Require Import UniMath.Foundations.Preamble. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.opp_precat UniMath.CategoryTheory.yoneda UniMath.CategoryTheory.categories.HSET.Core UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.RepresentableFunctors.Bifunctor UniMath.CategoryTheory.RepresentableFunctors.Precategories. Require Import UniMath.MoreFoundations.Tactics. Local Open Scope cat. Local Open Scope Cat. Definition isUniversal {C:category} {X:[C^op,HSET]} {c:C} (x:c ⇒ X) := ∏ (c':C), isweq (λ f : c' --> c, x ⟲ f). Definition Universal {C:category} (X:[C^op,HSET]) (c:C) := ∑ (x:c ⇒ X), isUniversal x. Lemma z_iso_Universal_weq {C:category} {X Y:[C^op,HSET]} (c:C) : z_iso X Y -> Universal X c ≃ Universal Y c. Proof. intro i. set (I := (functor_z_iso_pointwise_if_z_iso C^op HSET (homset_property HSET) X Y (pr1 i) (pr2 i))). unshelve refine (weqbandf _ _ _ _). - apply hset_z_iso_equiv_weq. unfold arrow, functor_object_application. exact (I c). - simpl; intros x. apply weqonsecfibers; intro b. apply weqiff. + unshelve refine (twooutof3c_iff_1_homot _ _ _ _ _). * exact (pr1 i ◽ opp_ob b). * intro f; simpl. exact (eqtohomot (nat_trans_ax (pr1 i) _ _ f) x). * exact (hset_z_iso_is_equiv _ _ (I b)). + apply isapropisweq. + apply isapropisweq. Defined. Definition Representation {C:category} (X:[C^op,HSET]) : UU := ∑ (c:C), Universal X c. Definition isRepresentable {C:category} (X:[C^op,HSET]) := ∥ Representation X ∥. Lemma isaprop_Representation {C: univalent_category} (X:[C^op,HSET]) : isaprop (@Representation C X). Proof. Abort. Definition z_iso_Representation_weq {C:category} {X Y:[C^op,HSET]} : z_iso X Y -> Representation X ≃ Representation Y. Proof. intros i. apply weqfibtototal; intro c. apply z_iso_Universal_weq; assumption. Defined. (* categories of functors with representations *) Definition RepresentedFunctor (C:category) : category := categoryWithStructure [C^op,HSET] Representation. Definition toRepresentation {C:category} (X : RepresentedFunctor C) : Representation (pr1 X) := pr2 X. Definition RepresentableFunctor (C:category) : category := categoryWithStructure [C^op,HSET] isRepresentable. Definition toRepresentableFunctor {C:category} : RepresentedFunctor C ⟶ RepresentableFunctor C := functorWithStructures (λ c, hinhpr). (* make a representation of a functor *) Definition makeRepresentation {C:category} {c:C} {X:[C^op,HSET]} (x:c ⇒ X) : (∏ (c':C), UniqueConstruction (λ f : c' --> c, x ⟲ f)) -> Representation X. Proof. intros bij. exists c. exists x. intros c'. apply set_bijection_to_weq. - exact (bij c'). - apply setproperty. Defined. (* universal aspects of represented functors *) Definition universalObject {C:category} {X:[C^op,HSET]} (r:Representation X) : C := pr1 r. Definition universalElement {C:category} {X:[C^op,HSET]} (r:Representation X) : universalObject r ⇒ X := pr1 (pr2 r). Coercion universalElement : Representation >-> pr1hSet. Definition universalProperty {C:category} {X:[C^op,HSET]} (r:Representation X) (c:C) : c --> universalObject r ≃ (c ⇒ X) := make_weq (λ f : c --> universalObject r, r ⟲ f) (pr2 (pr2 r) c). Definition universalMap {C:category} {X:[C^op,HSET]} (r:Representation X) {c:C} : c ⇒ X -> c --> universalObject r := invmap (universalProperty _ _). Notation "r \\ x" := (universalMap r x) (at level 50, left associativity) : cat. Definition universalMap' {C:category} {X:[C^op^op,HSET]} (r:Representation X) {c:C} : X ⇐ c -> c <-- universalObject r := invmap (universalProperty _ _). Notation "x // r" := (universalMap' r x) (at level 50, left associativity) : cat. Definition universalMapProperty {C:category} {X:[C^op,HSET]} (r:Representation X) {c:C} (x : c ⇒ X) : r ⟲ (r \\ x) = x := homotweqinvweq (universalProperty r c) x. Definition mapUniqueness {C:category} (X:[C^op,HSET]) (r : Representation X) (c:C) (f g: c --> universalObject r) : r ⟲ f = r ⟲ g -> f = g := invmaponpathsweq (universalProperty _ _) _ _. Definition universalMapUniqueness {C:category} {X:[C^op,HSET]} {r:Representation X} {c:C} (x : c ⇒ X) (f : c --> universalObject r) : r ⟲ f = x -> f = r \\ x := pathsweq1 (universalProperty r c) f x. Definition universalMapIdentity {C:category} {X:[C^op,HSET]} (r:Representation X) : r \\ r = identity _. Proof. apply pathsinv0. apply universalMapUniqueness. apply arrow_mor_id. Qed. Definition universalMapUniqueness' {C:category} {X:[C^op,HSET]} {r:Representation X} {c:C} (x : c ⇒ X) (f : c --> universalObject r) : f = r \\ x -> r ⟲ f = x := pathsweq1' (universalProperty r c) f x. Lemma univ_arrow_mor_assoc {C:category} {a b:C} {Z:[C^op,HSET]} (f : a --> b) (z : b ⇒ Z) (t : Representation Z) : (t \\ z) ∘ f = t \\ (z ⟲ f). Proof. apply universalMapUniqueness. unshelve refine (arrow_mor_mor_assoc _ _ _ @ _). apply maponpaths. apply universalMapProperty. Qed. (* *) Lemma uOF_identity {C:category} {X:[C^op,HSET]} (r:Representation X) : r \\ (identity X ⟳ r) = identity _. Proof. unfold nat_trans_id; simpl. unshelve refine (transportb (λ k, _ \\ k = _) (identityFunction' _ _) _). apply universalMapIdentity. Qed. Lemma uOF_comp {C:category} {X Y Z:[C^op,HSET]} (r:Representation X) (s:Representation Y) (t:Representation Z) (p:X-->Y) (q:Y-->Z) : t \\ ((q ∘ p) ⟳ r) = (t \\ (q ⟳ s)) ∘ (s \\ (p ⟳ r)). Proof. unshelve refine (transportf (λ k, _ \\ k = _) (nattrans_nattrans_arrow_assoc _ _ _) _). unshelve refine (_ @ !univ_arrow_mor_assoc _ _ _). apply maponpaths. unshelve refine (_ @ nattrans_arrow_mor_assoc _ _ _). apply (maponpaths (λ k, q ⟳ k)). apply pathsinv0. apply universalMapProperty. Qed. Definition universalObjectFunctor (C:category) : RepresentedFunctor C ⟶ C. Proof. unshelve refine (makeFunctor _ _ _ _). - intro X. exact (universalObject (pr2 X)). - intros X Y p; simpl. exact (pr2 Y \\ (p ⟳ pr2 X)). - intros X; simpl. apply uOF_identity. - intros X Y Z p q; simpl. apply uOF_comp. Defined. Definition universalObjectFunctor_on_map (C:category) {X Y:RepresentedFunctor C} (p:X-->Y) : universalObjectFunctor C ▭ p = pr2 Y \\ (p ⟳ pr2 X). Proof. reflexivity. Defined. Lemma universalObjectFunctor_comm (C:category) {X Y:RepresentedFunctor C} (p:X-->Y) : p ⟳ universalElement (pr2 X) = universalElement (pr2 Y) ⟲ universalObjectFunctor C ▭ p. Proof. change (universalObjectFunctor C ▭ p) with (pr2 Y \\ (p ⟳ pr2 X)). apply pathsinv0, universalMapProperty. Defined. (** transferring universal properties between isomorphic objects *) Definition isUniversal_isom {C:category} {X:[C^op,HSET]} {c c':C} (x:c ⇒ X) (f : z_iso c' c) : isUniversal x <-> isUniversal (x ⟲ f). Proof. Abort. (** transferring representability via embeddings and isomorphisms of categories *) Definition embeddingRepresentability {C D:category} {X:[C^op,HSET]} {Y:[D^op,HSET]} (s:Representation Y) (i:categoryEmbedding C D) : z_iso (Y □ functorOp (opp_ob (pr1 i))) X -> (∑ c, i c = universalObject s) -> Representation X. Proof. intros j ce. apply (z_iso_Representation_weq j). exists (pr1 ce). exists (transportf (λ d, Y ◾ d : hSet) (!pr2 ce) s). intro c'. apply (twooutof3c (# i) (λ g, _ ⟲ g)). - apply (pr2 i). - induction (! pr2 ce). exact (weqproperty (universalProperty _ _)). Defined. Definition isomorphismRepresentability {C D:category} {X:[C^op,HSET]} {Y:[D^op,HSET]} (s:Representation Y) (i:categoryIsomorphism C D) : z_iso (Y □ functorOp (opp_ob (pr1 (pr1 i)))) X -> Representation X := λ j, embeddingRepresentability s i j (iscontrpr1 (pr2 i (universalObject s))). (*** Some standard functors to consider representing *) (** the functor represented by an object *) Definition Hom1 {C:category} (c:C) : [C^op,HSET]. Proof. unshelve refine (makeFunctor_op _ _ _ _). - intro b. exact (Hom C b c). - intros b a f g; simpl. exact (g ∘ f). - abstract (intros b; simpl; apply funextsec; intro g; apply id_left) using _L_. - abstract (intros i j k f g; simpl; apply funextsec; intro h; rewrite <- assoc; reflexivity) using _L_. Defined. Lemma Hom1_Representation {C:category} (c:C) : Representation (Hom1 c). Proof. exists c. exists (identity c). intro b. apply (isweqhomot (idweq _)). - abstract (intro f; unfold arrow_morphism_composition; unfold Hom1; simpl; apply pathsinv0, id_right) using _R_. - abstract (apply weqproperty) using _T_. Defined. (** maps from Hom1 to functors *) Lemma compose_SET {X Y Z:HSET} (f:X-->Y) (g:Y-->Z) : g∘f = λ x, g(f x). Proof. reflexivity. Defined. Definition element_to_nattrans {C:category} (X:[C^op,HSET]) (c:C) : c ⇒ X -> Hom1 c --> X. Proof. intros x. unshelve refine (makeNattrans_op _ _). - unfold Hom1; simpl; intros b f. exact (x ⟲ f). - abstract (intros a b f; apply funextsec; intro g; apply arrow_mor_mor_assoc) using _L_. Defined. (** representable functors are isomorphic to one represented by an object *) Theorem Representation_to_z_iso {C:category} (X:[C^op,HSET]) (r:Representation X) : z_iso (Hom1 (universalObject r)) X. Proof. refine (z_iso_from_nat_z_iso _ ((element_to_nattrans X (universalObject r) (universalElement r)),,_)). intro b. apply (pr2 (weq_iff_z_iso_SET _)). exact (pr2 (pr2 r) b). Defined. (** initial and final objects and zero maps *) Definition UnitFunctor (C:category) : [C,SET]. unshelve refine (_,,_). { exists (λ c, unitset). exact (λ a b f t, t). } { split. { intros a. reflexivity. } { intros a b c f g. reflexivity. } } Defined. Definition TerminalObject (C:category) := Representation (UnitFunctor C^op). Definition terminalObject {C} (t:TerminalObject C) : ob C := universalObject t. Definition terminalArrow {C} (t:TerminalObject C) (c:ob C) : Hom C c (terminalObject t) := t \\ tt. Definition InitialObject (C:category) := TerminalObject C^op. Definition initialObject {C} (i:InitialObject C) : ob C := universalObject i. Definition initialArrow {C} (i:InitialObject C) (c:ob C) : Hom C (initialObject i) c := rm_opp_mor (tt // i). Definition init_to_opp {C:category} : InitialObject C -> TerminalObject C^op := λ i, i. Definition term_to_opp {C:category} : TerminalObject C -> InitialObject C^op. Proof. intros. unfold InitialObject. now induction (opp_opp_precat C). Defined. (** zero objects, as an alternative to ZeroObject.v *) Definition ZeroObject (C:category) := ∑ z:ob C, Universal (UnitFunctor C^op) z × Universal (UnitFunctor C^op^op) z. Definition zero_to_terminal (C:category) : ZeroObject C -> TerminalObject C := λ z, pr1 z ,, pr1 (pr2 z). Definition zero_to_initial (C:category) : ZeroObject C -> InitialObject C := λ z, pr1 z ,, pr2 (pr2 z). Definition zero_opp (C:category) : ZeroObject C -> ZeroObject C^op. Proof. intro z. induction z as [z k]. exists z. induction (opp_opp_precat C). exact (pr2 k,,pr1 k). Defined. Definition hasZeroObject (C:category) := ∥ ZeroObject C ∥. Definition haszero_opp (C:category) : hasZeroObject C -> hasZeroObject C^op := hinhfun (zero_opp C). Definition zeroMap' (C:category) (a b:ob C) (o:ZeroObject C) : Hom C a b := (zero_to_initial C o \\ tt) ∘ (zero_to_terminal C o \\ tt). Lemma zero_eq_zero_opp (C:category) (a b:ob C) (o:ZeroObject C) : zeroMap' C^op (opp_ob b) (opp_ob a) (zero_opp C o) = opp_mor (zeroMap' C a b o). Proof. intros. try reflexivity. Abort. (** binary products and coproducts *) Definition HomPair {C:category} (a b:C) : [C^op,SET]. Proof. unshelve refine (makeFunctor_op _ _ _ _). - intro c. exact (Hom C c a × Hom C c b) % set. - simpl. intros c d f x. exact (pr1 x ∘ f ,, pr2 x ∘ f). - abstract (simpl; intro c; apply funextsec; intro x; apply dirprodeq; apply id_left) using _B_. - abstract (simpl; intros c d e f g; apply funextsec; intro x; apply dirprodeq; apply pathsinv0, assoc) using _C_. Defined. Definition HomPair_1 {C:category} (a b c:C) : (((HomPair a b : C^op ⟶ SET) c : hSet) -> Hom C c a) := pr1. Definition HomPair_2 {C:category} (a b c:C) : (((HomPair a b : C^op ⟶ SET) c : hSet) -> Hom C c b) := pr2. Definition BinaryProduct {C:category} (a b:C) := Representation (HomPair a b). Definition BinaryProducts (C:category) := ∏ (a b:C), BinaryProduct a b. Definition pr_1 {C:category} {a b:C} (prod : BinaryProduct a b) : universalObject prod --> a := pr1 (universalElement prod). Definition pr_2 {C:category} {a b:C} (prod : BinaryProduct a b) : universalObject prod --> b := pr2 (universalElement prod). Definition binaryProductMap {C:category} {a b:C} (prod : BinaryProduct a b) {c:C} : c --> a -> c --> b -> c --> universalObject prod := λ f g, prod \\ (f,,g). Definition binaryProduct_pr_1_eqn {C:category} {a b:C} (prod : BinaryProduct a b) {c:C} (f : c --> a) (g : c --> b) : pr_1 prod ∘ binaryProductMap prod f g = f := maponpaths (HomPair_1 a b (opp_ob c)) (pr2 (pr1 (pr2 (pr2 prod) c (f,,g)))). Definition binaryProduct_pr_2_eqn {C:category} {a b:C} (prod : BinaryProduct a b) {c:C} (f : c --> a) (g : c --> b) : pr_2 prod ∘ binaryProductMap prod f g = g := maponpaths (HomPair_2 a b (opp_ob c)) (pr2 (pr1 (pr2 (pr2 prod) c (f,,g)))). Lemma binaryProductMapUniqueness {C:category} {a b:C} (prod : BinaryProduct a b) {c:C} (f g : Hom C c (universalObject prod)) : pr_1 prod ∘ f = pr_1 prod ∘ g -> pr_2 prod ∘ f = pr_2 prod ∘ g -> f = g. Proof. intros r s. apply mapUniqueness. apply dirprodeq. exact r. exact s. Defined. Definition binaryProductMap_2 {C:category} {a b a' b':C} (prod : BinaryProduct a b) (prod' : BinaryProduct a' b') (f : a --> a') (g : b --> b') : rm_opp_ob (universalObject prod) --> rm_opp_ob (universalObject prod'). Proof. unshelve refine (binaryProductMap _ _ _). { exact (f ∘ pr_1 prod). } { exact (g ∘ pr_2 prod). } Defined. Definition BinarySum {C:category} (a b:C) := BinaryProduct (opp_ob a) (opp_ob b). Definition BinarySums (C:category) := ∏ (a b:C), BinarySum a b. Lemma binarySumsToProducts {C:category} : BinarySums C -> BinaryProducts C^op. Proof. intros sum. exact sum. Defined. Lemma binaryProductToSums {C:category} : BinaryProducts C -> BinarySums C^op. Proof. intro prod. exact prod. Defined. Definition in_1 {C:category} {a b:C} (sum : BinarySum a b) : Hom C a (universalObject sum) := pr_1 sum. Definition in_2 {C:category} {a b:C} (sum : BinarySum a b) : Hom C b (universalObject sum) := pr_2 sum. Definition binarySumProperty {C:category} {a b c:C} (f:a-->c) (g:b-->c) := isUniversal ((f ,, g) : HomPair (opp_ob a) (opp_ob b) ◾ c : hSet). Definition binarySumMap {C:category} {a b:C} (sum : BinarySum a b) {c:C} : a --> c -> b --> c -> rm_opp_ob (universalObject sum) --> c := λ f g, rm_opp_mor (sum \\ (opp_mor f,,opp_mor g)). Definition binarySum_in_1_eqn {C:category} {a b:C} (sum : BinarySum a b) {c:C} (f : a --> c) (g : b --> c) : binarySumMap sum f g ∘ in_1 sum = f := maponpaths (HomPair_1 (opp_ob a) (opp_ob b) c) ((pr2 (pr1 (pr2 (pr2 sum) c (f,,g))))). Definition binarySum_in_2_eqn {C:category} {a b:C} (sum : BinarySum a b) {c:C} (f : a --> c) (g : b --> c) : binarySumMap sum f g ∘ in_2 sum = g := maponpaths (HomPair_2 (opp_ob a) (opp_ob b) c) ((pr2 (pr1 (pr2 (pr2 sum) c (f,,g))))). Lemma binarySumMapUniqueness {C:category} {a b:C} (sum : BinarySum a b) {c:C} (f g : Hom C (rm_opp_ob (universalObject sum)) c) : f ∘ in_1 sum = g ∘ in_1 sum -> f ∘ in_2 sum = g ∘ in_2 sum -> f = g. Proof. intros r s. apply opp_mor_eq, mapUniqueness, dirprodeq; assumption. Defined. Definition binarySumMap_2 {C:category} {a b a' b':C} (sum : BinarySum a b) (sum' : BinarySum a' b') (f : a --> a') (g : b --> b') : rm_opp_ob (universalObject sum) --> rm_opp_ob (universalObject sum'). Proof. unshelve refine (binarySumMap _ _ _). { exact (in_1 sum' ∘ f). } { exact (in_2 sum' ∘ g). } Defined. (** products and coproducts *) Definition HomFamily (C:category) {I} (c:I -> ob C) : C^op ⟶ SET. Proof. unshelve refine (_,,_). - unshelve refine (_,,_). + intros x. exact (∏ i, Hom C x (c i)) % set. + intros x y f p i; simpl; simpl in p. exact (compose (C:=C) f (p i)). - abstract (split; [ intros a; apply funextsec; intros f; apply funextsec; intros i; simpl; apply id_left | intros x y z p q; apply funextsec; intros f; apply funextsec; intros i; simpl; apply pathsinv0, assoc]) using _L_. Defined. Definition Product {C:category} {I} (c:I -> ob C) := Representation (HomFamily C c). Definition pr_ {C:category} {I} {c:I -> ob C} (prod : Product c) (i:I) : universalObject prod --> c i := universalElement prod i. Definition productMapExistence {C:category} {I} {c:I -> ob C} (prod : Product c) {a:C} : (∏ i, Hom C a (c i)) -> Hom C a (universalObject prod) := λ f, prod \\ f. Lemma productMapUniqueness {C:category} {I} {c:I -> ob C} (prod : Product c) {a:C} (f g : Hom C a (universalObject prod)) : (∏ i, pr_ prod i ∘ f = pr_ prod i ∘ g) -> f = g. Proof. intro e. apply mapUniqueness. apply funextsec; intro i. apply e. Defined. Definition Sum {C:category} {I} (c:I -> ob C) := Representation (HomFamily C^op c). Definition in_ {C:category} {I} {c:I -> ob C} (sum : Sum c) (i:I) : c i --> universalObject sum := rm_opp_mor (universalElement sum i). Definition sumMapExistence {C:category} {I} {c:I -> ob C} (sum : Sum c) {a:C} : (∏ i, Hom C (c i) a) -> Hom C (universalObject sum) a := λ f, f // sum. Lemma sumMapUniqueness {C:category} {I} {c:I -> ob C} (sum : Sum c) {a:C} (f g : Hom C (universalObject sum) a) : (∏ i, f ∘ in_ sum i = g ∘ in_ sum i) -> f = g. Proof. intro e. apply opp_mor_eq, mapUniqueness. apply funextsec; intro i. apply e. Defined. (** equalizers and coequalizers *) Definition Equalization {C:category} {c d:C} (f g:c-->d) : C^op ⟶ SET. Proof. unshelve refine (makeFunctor_op _ _ _ _). - intro b. unshelve refine (_,,_). + exact (∑ p:b --> c, f∘p = g∘p). + abstract (apply isaset_total2; [ apply homset_property | intro; apply isasetaprop; apply homset_property]) using _L_. - intros b a e w; simpl in *. exists (pr1 w ∘ e). abstract (rewrite <- 2? assoc; apply maponpaths; exact (pr2 w)) using _M_. - abstract ( intros b; apply funextsec; intro w; apply subtypePath; [ intro; apply homset_property | simpl; apply id_left]) using _N_. - abstract ( intros a'' a' a r s; apply funextsec; intro w; apply subtypePath; [ intro; apply homset_property | apply pathsinv0, assoc ]) using _O_. Defined. Definition Equalizer {C:category} {c d:C} (f g:c-->d) := Representation (Equalization f g). Definition equalizerMap {C:category} {c d:C} {f g:c-->d} (eq : Equalizer f g) : universalObject eq --> c := pr1 (universalElement eq). Definition equalizerEquation {C:category} {c d:C} {f g:c-->d} (eq : Equalizer f g) : f ∘ equalizerMap eq = g ∘ equalizerMap eq := pr2 (universalElement eq). Definition Coequalizer {C:category} {c d:C} (f g:c-->d) := Representation (Equalization (opp_mor f) (opp_mor g)). Definition coequalizerMap {C:category} {c d:C} {f g:c-->d} (coeq : Coequalizer f g) : d --> universalObject coeq := pr1 (universalElement coeq). Definition coequalizerEquation {C:category} {c d:C} {f g:c-->d} (coeq : Coequalizer f g) : coequalizerMap coeq ∘ f = coequalizerMap coeq ∘ g := pr2 (universalElement coeq). (** pullbacks and pushouts *) Definition PullbackCone {C:category} {a b c:C} (f:a-->c) (g:b-->c) : C^op ⟶ SET. Proof. intros. unshelve refine (makeFunctor_op _ _ _ _). - intros t. unshelve refine (_,,_). + exact (∑ (p: t --> a × t --> b), f ∘ pr1 p = g ∘ pr2 p). + abstract (apply isaset_total2; [ apply isasetdirprod; apply homset_property | intro; apply isasetaprop; apply homset_property]) using _L_. - intros t u p w; simpl in *. exists (pr1 (pr1 w) ∘ p,, pr2 (pr1 w) ∘ p). abstract ( simpl; rewrite <- 2? assoc; apply maponpaths; exact (pr2 w)) using _M_. - abstract (intros t; simpl; apply funextsec; intro w; induction w as [w eq]; induction w as [p q]; simpl in *; unshelve refine (two_arg_paths_f _ _); [ rewrite 2? id_left; reflexivity | apply proofirrelevance; apply homset_property]) using _N_. - abstract ( intros r s t p q; simpl in *; apply funextsec; intro w; unshelve refine (total2_paths2_f _ _); [ simpl; rewrite 2? assoc; reflexivity | apply proofirrelevance; apply homset_property]) using _P_. Defined. Definition Pullback {C:category} {a b c:C} (f:a-->c) (g:b-->c) := Representation (PullbackCone f g). Definition pb_1 {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) : universalObject pb --> a := pr1 (pr1 (universalElement pb)). Definition pb_2 {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) : universalObject pb --> b := pr2 (pr1 (universalElement pb)). Definition pb_eqn {C:category} {a b c:C} {f:a-->c} {g:b-->c} (pb : Pullback f g) : f ∘ pb_1 pb = g ∘ pb_2 pb := pr2 (universalElement pb). Definition Pushout {C:category} {a b c:C} (f:a-->b) (g:a-->c) := Representation (PullbackCone (opp_mor f) (opp_mor g)). Definition po_1 {C:category} {a b c:C} {f:a-->b} {g:a-->c} (po : Pushout f g) : b --> universalObject po := pr1 (pr1 (universalElement po)). Definition po_2 {C:category} {a b c:C} {f:a-->b} {g:a-->c} (po : Pushout f g) : c --> universalObject po := pr2 (pr1 (universalElement po)). Definition po_eqn {C:category} {a b c:C} {f:a-->c} {g:a-->c} (po : Pushout f g) : po_1 po ∘ f = po_2 po ∘ g := pr2 (universalElement po). (** kernels and cokernels *) Definition Annihilator (C:category) (zero:ZeroMaps C) {c d:C} (f:c --> d) : C^op ⟶ SET. Proof. unshelve refine (_,,_). { unshelve refine (_,,_). { intro b. exists (∑ g:Hom C b c, f ∘ g = pr1 zero b d). abstract (apply isaset_total2; [ apply setproperty | intro g; apply isasetaprop; apply homset_property ]) using _L_. } { intros a b p ge; simpl. exists (pr1 ge ∘ opp_mor p). { abstract ( unshelve refine (! assoc _ _ _ @ _); rewrite (pr2 ge); apply (pr2 (pr2 zero) _ _ _ _)) using _M_. } } } { abstract (split; [ intros x; apply funextsec; intros [r rf0]; apply subtypePath; [ intro; apply homset_property | simpl; unfold opp_mor; apply id_left ] | intros w x y t u; apply funextsec; intros [r rf0]; apply subtypePath; [ intro; apply homset_property | simpl; unfold opp_mor; apply pathsinv0, assoc ] ]) using _N_. } Defined. Definition Kernel {C:category} (zero:ZeroMaps C) {c d:ob C} (f:c --> d) := Representation (Annihilator C zero f). Definition Cokernel {C:category} (zero:ZeroMaps C) {c d:ob C} (f:c --> d) := Representation (Annihilator C^op (ZeroMaps_opp C zero) f). Definition kernelMap {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d} (r : Kernel zero f) : universalObject r --> c := pr1 (universalElement r). Definition kernelEquation {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d} (ker : Kernel zero f) : f ∘ kernelMap ker = pr1 zero _ _ := pr2 (universalElement ker). Definition cokernelMap {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d} (r : Cokernel zero f) : d --> universalObject r := pr1 (universalElement r). Definition cokernelEquation {C:category} {zero:ZeroMaps C} {c d:ob C} {f:c --> d} (coker : Cokernel zero f) : cokernelMap coker ∘ f = pr1 zero _ _ := pr2 (universalElement coker). (** fibers of maps between functors *) Definition fiber {C:category} {X Y:[C^op,SET]} (p : X --> Y) {c:C} (y : c ⇒ Y) : C^op ⟶ SET. Proof. unshelve refine (makeFunctor_op _ _ _ _). - intro b. exists (∑ fx : (b --> c) × (b ⇒ X), p ⟳ pr2 fx = y ⟲ pr1 fx). abstract (apply isaset_total2; [ apply isaset_dirprod, setproperty; apply homset_property | intros [f x]; apply isasetaprop; apply setproperty ]) using _K_. - simpl; intros b b' g fxe. exists (pr1 (pr1 fxe) ∘ g,, pr2 (pr1 fxe) ⟲ g). abstract (simpl; rewrite nattrans_arrow_mor_assoc, arrow_mor_mor_assoc; apply maponpaths; exact (pr2 fxe)) using _M_. - abstract (intro b; apply funextsec; intro w; induction w as [w e]; induction w as [f x]; simpl; unshelve refine (two_arg_paths_f _ _); [ apply dirprodeq; [ apply id_left | apply arrow_mor_id ] | apply setproperty]) using _R_. - abstract (intros b b' b'' g g''; apply funextsec; intro w; induction w as [w e]; induction w as [f x]; simpl; unshelve refine (total2_paths2_f _ _); [ apply dirprodeq; [ apply pathsinv0, assoc | apply arrow_mor_mor_assoc ] | apply setproperty ]) using _T_. Defined. (* this is representability of a map between two functors, in the sense of Grothendieck. See EGA Chapter 0. *) Definition Representation_Map {C:category} {X Y:[C^op,SET]} (p : X --> Y) := ∏ (c : C) (y : c ⇒ Y), Representation (fiber p y). Definition isRepresentable_Map {C:category} {X Y:[C^op,SET]} (p : X --> Y) := ∏ (c : C) (y : c ⇒ Y), isRepresentable (fiber p y). (** limits and colimits *) Definition cone {I C:category} (c:C) (D: [I,C]) : UU := ∑ (φ : ∏ i, Hom C c (D ◾ i)), ∏ i j (e : i --> j), D ▭ e ∘ φ i = φ j. Lemma cone_eq {C I:category} (c:C^op) (D: I⟶C) (p q:cone (C:=C) c D) : pr1 p ~ pr1 q -> p = q. Proof. intros h. apply subtypePath. { intro r. apply impred_isaprop; intro i; apply impred_isaprop; intro j; apply impred_isaprop; intro e. apply homset_property. } apply funextsec; intro i; apply h. Qed. Definition cone_functor {I C:category} : [I,C] ⟶ [C^op,SET]. Proof. intros. unshelve refine (_,,_). { unshelve refine (_,,_). { intros D. unshelve refine (_,,_). { unshelve refine (_,,_). - intro c. exists (cone (C:=C) c D). abstract ( apply isaset_total2; [ apply impred_isaset; intro i; apply homset_property | intros φ; apply impred_isaset; intro i; apply impred_isaset; intro j; apply impred_isaset; intro e; apply isasetaprop; apply homset_property]) using LLL. - simpl; intros a b f φ. exists (λ i, pr1 φ i ∘ f). abstract ( intros i j e; simpl; rewrite <- assoc; apply maponpaths; apply (pr2 φ)) using _M_. } { abstract (split; [ intro c; simpl; apply funextsec; intro p; apply cone_eq; intro i; simpl; apply id_left | intros a b c f g; simpl; apply funextsec; intro p; apply cone_eq; simpl; intro i; apply pathsinv0, assoc ]) using _N_. } } { intros D D' f; simpl. unshelve refine (_,,_). - simpl. unfold cone. intros c φ. unshelve refine (_,,_). + intros i. exact (pr1 f i ∘ pr1 φ i). + abstract ( simpl; intros i j e; assert (L := pr2 φ i j e); simpl in L; rewrite <- L; rewrite <- assoc; rewrite <- assoc; apply maponpaths; apply pathsinv0; apply nat_trans_ax) using _P_. - abstract (intros a b g; simpl; apply funextsec; intro p; apply cone_eq; intro i; simpl; apply pathsinv0, assoc) using _Q_. } } { abstract (split; [ intros D; simpl; apply nat_trans_eq; [ exact (homset_property SET) | intros c; apply funextsec; intro φ; simpl; apply cone_eq; intro i; apply id_right] | intros D D' D'' p q; apply nat_trans_eq; [ apply homset_property | intro c; apply funextsec; intro K; apply cone_eq; intros i; apply assoc ]]). } Defined. Definition cocone_functor {I C:category} : [I,C]^op ⟶ [C^op^op,SET] := cone_functor □ functorOp. Definition Limit {C I:category} (D: I⟶C) := Representation (cone_functor D). Definition Colimit {C I:category} (D: I⟶C) := Representation (cocone_functor D). Definition proj_ {C I:category} {D: I⟶C} (lim:Limit D) (i:I) : universalObject lim --> D i. Proof. intros. exact ((pr1 (universalElement lim) i)). Defined. Definition inj_ {C I:category} {D: I⟶C} (colim:Colimit D) (i:I) : D i --> universalObject colim. Proof. intros. exact ((pr1 (universalElement colim) i)). Defined. Definition proj_comm {C I:category} {D: I⟶C} (lim:Limit D) {i j:I} (f:i-->j) : # D f ∘ proj_ lim i = proj_ lim j. Proof. intros. exact (pr2 (universalElement lim) _ _ f). Defined. Definition inj_comm {C I:category} {D: I⟶C} (colim:Colimit D) {i j:I} (f:i-->j) : inj_ colim j ∘ # D f = inj_ colim i. Proof. intros. exact (pr2 (universalElement colim) _ _ f). Defined. Definition Limits (C:category) := ∏ (I:category) (D: I⟶C), Limit D. Definition Colimits (C:category) := ∏ (I:category) (D: I⟶C), Colimit D. Definition lim_functor (C:category) (lim:Limits C) (I:category) : [I,C] ⟶ C := universalObjectFunctor C □ addStructure cone_functor (lim I). Definition colim_functor (C:category) (colim:Colimits C) (I:category) : [I,C] ⟶ C := functorRmOp ( universalObjectFunctor C^op □ addStructure cocone_functor (colim I)). Lemma bifunctor_assoc_repn {B C:category} (X : [B, [C^op,SET]]) : (∏ b, Representation (X ◾ b)) -> Representation (bifunctor_assoc X). Proof. intro r. set (X' := addStructure X r). change (categoryWithStructure [C ^op, SET] Representation) with (RepresentedFunctor C) in X'. set (F := universalObjectFunctor C □ X'). exists F. unshelve refine (_,,_). { unshelve refine (_,,_). { intro b. exact (universalElement (r b)). } { abstract (intros b b' f; exact (!universalObjectFunctor_comm C (X' ▭ f))) using _K_. } } { intro F'. apply UniqueConstruction_to_weq. split. { intro x'. unfold arrow in x'. unshelve refine (_,,_). { unshelve refine (makeNattrans _ _). { intro b. exact (r b \\ pr1 x' b). } { abstract (intros b b' f; simpl; unshelve refine (univ_arrow_mor_assoc (F' ▭ f) (pr1 x' b') (r b') @ _); intermediate_path (r b' \\ (X ▭ f ⟳ pr1 x' b)); [ apply maponpaths, (pr2 x' b b' f) | unfold F; rewrite comp_func_on_mor; rewrite (universalObjectFunctor_on_map C (X' ▭ f)); change (pr2 (X' ◾ b')) with (r b'); change (pr2 (X' ◾ b)) with (r b); change (X' ▭ f) with (X ▭ f); unshelve refine (_ @ !univ_arrow_mor_assoc _ _ _); apply maponpaths; rewrite <- nattrans_arrow_mor_assoc; apply (maponpaths (λ k, X ▭ f ⟳ k)); apply pathsinv0; exact (universalMapProperty (r b) (pr1 x' b)) ]) using _R_. } } { abstract (unshelve refine (total2_paths_f _ _); [ simpl; apply funextsec; intro b; unshelve refine (universalMapProperty _ _) | apply funextsec; intro b; apply funextsec; intro b'; apply funextsec; intro f; simpl; apply setproperty ] ) using _L_. } } { abstract (intros p q e; apply nat_trans_eq; [ apply homset_property | intros b; apply (mapUniqueness _ (r b) _ (p ◽ b) (q ◽ b)); exact (maponpaths (λ k, pr1 k b) e)]) using _M_. } } Defined. Theorem functorcategoryTerminalObject (B C:category) : TerminalObject C -> TerminalObject [B,C]. Proof. intro t. apply (@z_iso_Representation_weq _ (bifunctor_assoc (constantFunctor B (UnitFunctor C^op)))). { unshelve refine (makeNatiso _ _). { intros F. apply hset_equiv_z_iso. unfold bifunctor_assoc; simpl. unshelve refine (weq_iso _ _ _ _). - intros _. exact tt. - intros x. unshelve refine (_,,_). + unfold θ_1; simpl. intro b. exact tt. + eqn_logic. - simpl. intros w. apply subtypePath. { intros f. apply impred; intro b; apply impred; intro b'; apply impred; intro g. apply isasetunit. } apply funextfun; intro b. apply isapropunit. - eqn_logic. } { eqn_logic. } } { apply bifunctor_assoc_repn; intro b. exact t. } Defined. Goal ∏ B C t b, universalObject(functorcategoryTerminalObject B C t) ◾ b = universalObject t. reflexivity. Defined. Definition binaryProductFunctor {B C:category} (F G:[B,C]) : [B,[C^op,SET]]. Proof. unshelve refine (makeFunctor _ _ _ _). - intro b. exact (HomPair (F ◾ b) (G ◾ b)). - intros b b' f. unshelve refine (makeNattrans_op _ _). + intros c w. exact (F ▭ f ∘ pr1 w ,, G ▭ f ∘ pr2 w). + abstract (intros c c' g; simpl; apply funextsec; intro v; apply dirprodeq; ( simpl; apply pathsinv0, assoc )) using _L_. - abstract (intro b; apply nat_trans_eq; [ apply homset_property | intro c; simpl; apply funextsec; intro v; apply dirprodeq; ( simpl; rewrite functor_on_id; rewrite id_right; reflexivity )]) using _L_. - abstract (intros b b' b'' f g; apply nat_trans_eq; [ apply homset_property | intro c; apply funextsec; intro w; apply dirprodeq ; ( simpl; rewrite functor_on_comp; rewrite assoc; reflexivity) ]) using _L_. Defined. Lemma BinaryProductFunctorAssoc {B C : category} (prod : BinaryProducts C) (F G : [B, C]) : z_iso (bifunctor_assoc (binaryProductFunctor F G)) (HomPair F G). Proof. unshelve refine (makeNatiso (C := [B, C]^op) _ _). { intro H. apply hset_equiv_z_iso. unshelve refine (weq_iso _ _ _ _). { intros w. unshelve refine (_,,_). { unshelve refine (makeNattrans _ _). { intro b. exact (pr1 (pr1 w b)). } { abstract (intros b b' f; exact (maponpaths dirprod_pr1 (pr2 w b b' f))) using _L_. } } { unshelve refine (makeNattrans _ _). { intro b. exact (pr2 (pr1 w b)). } { abstract (intros b b' f; exact (maponpaths dirprod_pr2 (pr2 w b b' f))) using _L_. } } } { simpl. intros pq. unshelve refine (_,,_). { intros b. exact (pr1 pq b ,, pr2 pq b). } { abstract (intros b b' f; simpl; apply dirprodeq; ( simpl; apply nattrans_naturality )) using _L_. } } { abstract (intros w; unshelve refine (total2_paths_f _ _); [ apply funextsec; intro b; apply pathsinv0; reflexivity | (apply funextsec; intro b; apply funextsec; intro b'; apply funextsec; intro f; apply isaset_dirprod; apply homset_property) ]) using _M_. } { abstract (intros pq; apply dirprodeq; ( apply nat_trans_eq; [ apply homset_property | intro b; reflexivity ] )) using _L_. } } { abstract (intros H H' p; apply funextsec; intros v; apply dirprodeq; ( simpl; apply nat_trans_eq; [ apply homset_property | intros b; unfold makeNattrans; simpl; reflexivity ] )) using _L_. } Defined. Theorem functorBinaryProduct {B C:category} : BinaryProducts C -> BinaryProducts [B,C]. Proof. intros prod F G. unshelve refine (z_iso_Representation_weq _ _). { exact (bifunctor_assoc (binaryProductFunctor F G)). } { now apply BinaryProductFunctorAssoc. } { apply bifunctor_assoc_repn. intro b. apply prod. } Defined. Lemma functorBinaryProduct_eqn {B C:category} (prod : BinaryProducts C) (F G : [B,C]) (b:B) : universalObject (functorBinaryProduct prod F G) ◾ b = universalObject (prod (F ◾ b) (G ◾ b)). Proof. reflexivity. Defined. Lemma functorBinaryProduct_map_eqn {B C:category} (prod : BinaryProducts C) (F G F' G' : [B,C]) (p:F-->F') (q:G-->G') (b:B) : binaryProductMap_2 (functorBinaryProduct prod F G) (functorBinaryProduct prod F' G') p q ◽ b = binaryProductMap_2 (prod (F ◾ b) (G ◾ b)) (prod (F' ◾ b) (G' ◾ b)) (p ◽ b) (q ◽ b). Proof. reflexivity. Defined. Lemma HomPairOp {B C : category} (F G : [B, C]) : z_iso (HomPair (functorOp F) (functorOp G) □ functorOp') (HomPair (opp_ob F) (opp_ob G)). (* This should be replaced by a general statement where [B,C]^op and [B^op,C^op] are replaced by arbitrary isomorphic categories. And there should be lemmas saying that having binary sums or products is preserved by isomorphisms of categories. *) Proof. unshelve refine (makeNatiso _ _). { intros H. apply hset_equiv_z_iso. apply weqdirprodf; exact (invweq (isomorphismOnMor functorOpIso H _)). } { abstract (intros H J p; apply funextsec; intro w; apply dirprodeq; ( apply nat_trans_eq; [ apply homset_property | reflexivity ] )). } Defined. Theorem functorBinarySum {B C:category} : BinarySums C -> BinarySums [B,C]. Proof. intros sum F G. exact (isomorphismRepresentability (functorBinaryProduct (binarySumsToProducts sum) (functorOp F) (functorOp G)) functorOpIso (HomPairOp F G)). Defined. Lemma functorBinarySum_eqn {B C:category} (sum : BinarySums C) (F G : [B,C]) (b:B) : universalObject (functorBinarySum sum F G) ◾ b = universalObject (sum (F ◾ b) (G ◾ b)). Proof. reflexivity. Defined. Lemma functorBinarySum_map_eqn {B C:category} (sum : BinarySums C) (F G F' G' : [B,C]) (p:F-->F') (q:G-->G') (b:B) : binarySumMap_2 (functorBinarySum sum F G) (functorBinarySum sum F' G') p q ◽ b = binarySumMap_2 (sum (F ◾ b) (G ◾ b)) (sum (F' ◾ b) (G' ◾ b)) (p ◽ b) (q ◽ b). Proof. try reflexivity. (* This failure might be what prevents using this framework with SubstitutionSystems on the branch "colimits". Since [functorBinaryProduct_map_eqn] admits a trivial proof, that's an argument for replacing the proof of functorBinarySum by one that's parallel to the proof of functorBinaryProduct, rather than deducing it as a corollary. Maybe then we could also write [universalObject sum] instead of [rm_opp_ob (universalObject sum)] *) Abort. Theorem functorLimits (B C:category) : Limits C -> Limits [B,C]. Proof. intros lim I D. unfold Limits, Limit in lim. set (D' := bifunctor_comm _ _ _ D). assert (M := bifunctor_assoc_repn (cone_functor □ D') (λ b, lim I (D' ◾ b))); clear lim. exists (universalObject M). unfold Representation in M. Abort. Theorem functorColimits (B C:category) : Colimits C -> Colimits [B,C]. Proof. Abort. (* --- *) UniMath-20231010/UniMath/CategoryTheory/RepresentableFunctors/Test.v000066400000000000000000000145101451125700300252520ustar00rootroot00000000000000(** testing whether our way of doing coproducts fits with SubstitutionSystems *) (** ****************************************** Benedikt Ahrens, March 2015 *********************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.RepresentableFunctors.Representation. Require UniMath.CategoryTheory.RepresentableFunctors.Precategories. Section interface. Variable C : category. Definition isCoproductCocone (a b co : C) (ia : a --> co) (ib : b --> co) := binarySumProperty ia ib. Definition make_isCoproductCocone (a b co : C) (ia : a --> co) (ib : b --> co) : (∏ (c : C) (f : a --> c) (g : b --> c), ∃! k : C ⟦co, c⟧, ia · k = f × ib · k = g) -> isCoproductCocone a b co ia ib. Proof. intros u c fg. refine (iscontrweqf _ (u c (pr1 fg) (pr2 fg))). apply weqfibtototal. intro d. apply weqiff. { split. { intros ee. apply dirprodeq. { simpl. exact (pr1 ee). } { simpl. exact (pr2 ee). } } { intros ee. split. { simpl. exact (maponpaths (HomPair_1 _ _ _) ee). } { simpl. exact (maponpaths (HomPair_2 _ _ _) ee). } } } { apply isapropdirprod; apply (homset_property C). } { apply setproperty. } Defined. Definition CoproductCocone (a b : C) := BinarySum a b. Definition make_CoproductCocone (a b : C) : ∏ (c : C) (f : a --> c) (g : b --> c), isCoproductCocone _ _ _ f g -> CoproductCocone a b := λ c f g i, c,,(f,,g),,i. Definition Coproducts := BinarySums C. Definition hasCoproducts (C:category) := ∏ (a b:C), ∥ BinarySum a b ∥. Definition CoproductObject {a b : C} (CC : CoproductCocone a b) : C := universalObject CC. Definition CoproductIn1 {a b : C} (CC : CoproductCocone a b): a --> CoproductObject CC := in_1 CC. Definition CoproductIn2 {a b : C} (CC : CoproductCocone a b) : b --> CoproductObject CC := in_2 CC. Definition CoproductArrow {a b : C} (CC : CoproductCocone a b) {c : C} (f : a --> c) (g : b --> c) : CoproductObject CC --> c := binarySumMap CC f g. Lemma CoproductIn1Commutes (a b : C) (CC : CoproductCocone a b): ∏ (c : C) (f : a --> c) g, CoproductIn1 CC · CoproductArrow CC f g = f. Proof. intros c f g. exact (binarySum_in_1_eqn CC f g). Qed. Lemma CoproductIn2Commutes (a b : C) (CC : CoproductCocone a b): ∏ (c : C) (f : a --> c) g, CoproductIn2 CC · CoproductArrow CC f g = g. Proof. intros c f g. exact (binarySum_in_2_eqn CC f g). Qed. Lemma CoproductArrowUnique (a b : C) (CC : CoproductCocone a b) (x : C) (f : a --> x) (g : b --> x) (k : CoproductObject CC --> x) : CoproductIn1 CC · k = f -> CoproductIn2 CC · k = g -> k = CoproductArrow CC f g. Proof. intros u v. apply binarySumMapUniqueness. { refine (u @ _). apply pathsinv0, CoproductIn1Commutes. } { refine (v @ _). apply pathsinv0, CoproductIn2Commutes. } Qed. Lemma CoproductArrowEta (a b : C) (CC : CoproductCocone a b) (x : C) (f : CoproductObject CC --> x) : f = CoproductArrow CC (CoproductIn1 CC · f) (CoproductIn2 CC · f). Proof. apply CoproductArrowUnique; apply idpath. Qed. Definition CoproductOfArrows {a b : C} (CCab : CoproductCocone a b) {c d : C} (CCcd : CoproductCocone c d) (f : a --> c) (g : b --> d) : CoproductObject CCab --> CoproductObject CCcd := CoproductArrow CCab (f · CoproductIn1 CCcd) (g · CoproductIn2 CCcd). Lemma CoproductOfArrowsIn1 {a b : C} (CCab : CoproductCocone a b) {c d : C} (CCcd : CoproductCocone c d) (f : a --> c) (g : b --> d) : CoproductIn1 CCab · CoproductOfArrows CCab CCcd f g = f · CoproductIn1 CCcd. Proof. unfold CoproductOfArrows. apply CoproductIn1Commutes. Qed. Lemma CoproductOfArrowsIn2 {a b : C} (CCab : CoproductCocone a b) {c d : C} (CCcd : CoproductCocone c d) (f : a --> c) (g : b --> d) : CoproductIn2 CCab · CoproductOfArrows CCab CCcd f g = g · CoproductIn2 CCcd. Proof. unfold CoproductOfArrows. apply CoproductIn2Commutes. Qed. Lemma precompWithCoproductArrow {a b : C} (CCab : CoproductCocone a b) {c d : C} (CCcd : CoproductCocone c d) (f : a --> c) (g : b --> d) {x : C} (k : c --> x) (h : d --> x) : CoproductOfArrows CCab CCcd f g · CoproductArrow CCcd k h = CoproductArrow CCab (f · k) (g · h). Proof. apply CoproductArrowUnique. - rewrite assoc. rewrite CoproductOfArrowsIn1. rewrite <- assoc, CoproductIn1Commutes. apply idpath. - rewrite assoc, CoproductOfArrowsIn2. rewrite <- assoc, CoproductIn2Commutes. apply idpath. Qed. Lemma postcompWithCoproductArrow {a b : C} (CCab : CoproductCocone a b) {c : C} (f : a --> c) (g : b --> c) {x : C} (k : c --> x) : CoproductArrow CCab f g · k = CoproductArrow CCab (f · k) (g · k). Proof. apply CoproductArrowUnique. - rewrite assoc, CoproductIn1Commutes; apply idpath. - rewrite assoc, CoproductIn2Commutes; apply idpath. Qed. Section coproduct_unique. Hypothesis H : is_univalent C. Variables a b : C. Definition from_Coproduct_to_Coproduct (CC CC' : CoproductCocone a b) : CoproductObject CC --> CoproductObject CC'. Proof. apply (CoproductArrow CC (CoproductIn1 _ ) (CoproductIn2 _ )). Defined. Lemma Coproduct_endo_is_identity (CC : CoproductCocone a b) (k : CoproductObject CC --> CoproductObject CC) (H1 : CoproductIn1 CC · k = CoproductIn1 CC) (H2 : CoproductIn2 CC · k = CoproductIn2 CC) : identity _ = k. Proof. (* apply pathsinv0. *) (* apply colim_endo_is_identity. *) (* intro u; induction u; simpl; assumption. *) (* Defined. *) Abort. End coproduct_unique. End interface. Section def_functor_pointwise_coprod. Variable C D : category. Variable HD : Coproducts D. Definition hsD := homset_property D. Section coproduct_functor. Variables F G : functor C D. Definition Coproducts_functor_precat : Coproducts (functor_category C D). Proof. apply functorBinarySum. exact HD. Defined. Definition coproduct_functor : functor C D := universalObject (functorBinarySum HD F G). End coproduct_functor. End def_functor_pointwise_coprod.UniMath-20231010/UniMath/CategoryTheory/RezkCompletion.v000066400000000000000000000007271451125700300227660ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section DefinitionRezkCompletion. Definition RezkCat : UU := ∏ C : category, ∑ D : univalent_category, ∑ H : functor C D, essentially_surjective H × fully_faithful H. End DefinitionRezkCompletion. UniMath-20231010/UniMath/CategoryTheory/RightKanExtension.v000066400000000000000000000166661451125700300234360ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 Extended by: Anders Mörtberg, 2016 ************************************************************) (** ********************************************************** Contents: - Definition of global right Kan extension as right adjoint to precomposition - Construction of right Kan extensions when the target category has limits ([RightKanExtension_from_limits]) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.CommaCategories. Local Open Scope cat. (** * Definition of global right Kan extension as right adjoint to precomposition *) Section RightKanExtension. Context (C D : category) (F : functor C D) (E : category). Let PrecompWithF : [D, E] ⟶ [C, E] := pre_composition_functor C D E F. Definition GlobalRightKanExtensionExists : UU := is_left_adjoint PrecompWithF. Definition GlobalRan (H : GlobalRightKanExtensionExists) : [C, E] ⟶ [D, E] := right_adjoint H. End RightKanExtension. (** * Construction of right Kan extensions when the target category has limits *) Section RightKanExtensionFromLims. Context (M C A : category) (K : functor M C) (LA : Lims A). Local Notation "c ↓ K" := (cComma _ _ K c) (at level 30). Section fix_T. Variable (T : functor M A). Local Definition Q (c : C) : functor (c ↓ K) M := cComma_pr1 _ _ K c. Local Definition QT (c : C) : diagram (c ↓ K) A := diagram_from_functor _ _ (functor_composite (Q c) T). Local Definition R (c : C) : A := lim (LA _ (QT c)). Local Definition lambda (c : C) : cone (QT c) (R c) := limCone (LA _ (QT c)). Local Definition Rmor_cone (c c' : C) (g : C⟦c,c'⟧) : cone (QT c') (R c). Proof. use make_cone. - intro m1f1. transparent assert (m1gf1 : (c ↓ K)). { use tpair. + apply (pr1 m1f1). + apply (g · pr2 m1f1). } exact (coneOut (lambda c) m1gf1). - intros x y f; simpl in *. transparent assert (e : ((c ↓ K) ⟦ pr1 x,, g · pr2 x, pr1 y,, g · pr2 y ⟧)). { use tpair. + exact (pr1 f). + change (g · pr2 x · # K (pr1 f) = g · pr2 y). rewrite <- assoc. rewrite (pr2 f). apply idpath. } exact (coneOutCommutes (lambda c) _ _ e). Defined. Local Definition Rmor (c c' : C) (g : C⟦c,c'⟧) : A⟦R c,R c'⟧ := limArrow (LA (c' ↓ K) (QT c')) (R c) (Rmor_cone c c' g). Local Definition R_data : functor_data C A := R,,Rmor. Local Lemma R_is_functor : is_functor R_data. Proof. split. - intros c; simpl. apply pathsinv0, limArrowUnique. intro c'; simpl; rewrite !id_left. now destruct c'. - intros c c' c'' f f'; simpl. apply pathsinv0, limArrowUnique; intros x; simpl. rewrite <- assoc; eapply pathscomp0. apply maponpaths, (limArrowCommutes _ _ (Rmor_cone c' c'' f')). eapply pathscomp0. apply (limArrowCommutes _ _ (Rmor_cone c c' f) (pr1 x,,f' · pr2 x)). destruct x. now rewrite <- assoc. Qed. Local Definition R_functor : functor C A := tpair _ R_data R_is_functor. Local Definition eps_n (n : M) : A⟦R_functor (K n),T n⟧ := coneOut (lambda (K n)) (n,,identity (K n)). Local Definition Kid n : K n ↓ K := (n,, identity (K n)). Local Lemma eps_is_nat_trans : is_nat_trans (functor_composite_data K R_data) T eps_n. Proof. intros n n' h; simpl. eapply pathscomp0. apply (limArrowCommutes (LA (K n' ↓ K) (QT (K n'))) (R (K n)) (Rmor_cone (K n) (K n') (# K h)) (Kid n')). unfold eps_n; simpl. transparent assert (v : (K n ↓ K)). { apply (n',, # K h · identity (K n')). } transparent assert (e : (K n ↓ K ⟦ Kid n, v ⟧)). { use tpair. + apply h. + abstract (cbn ; now rewrite id_left, id_right). } now apply pathsinv0; eapply pathscomp0; [apply (coneOutCommutes (lambda (K n)) _ _ e)|]. Qed. Local Definition eps : [M, A]⟦functor_composite K R_functor, T⟧ := tpair _ eps_n eps_is_nat_trans. End fix_T. (** Construction of right Kan extensions based on MacLane, CWM, X.3 (p. 233) *) Lemma RightKanExtension_from_limits : GlobalRightKanExtensionExists _ _ K A. Proof. unfold GlobalRightKanExtensionExists. use left_adjoint_from_partial. - apply R_functor. - apply eps. - intros T S α; simpl in *. transparent assert (cc : (∏ c, cone (QT T c) (S c))). { intro c. use make_cone. + intro mf; apply (# S (pr2 mf) · α (pr1 mf)). + abstract (intros fm fm' h; simpl; rewrite <- assoc; eapply pathscomp0; [apply maponpaths, (pathsinv0 (nat_trans_ax α _ _ (pr1 h)))|]; simpl; rewrite assoc, <- functor_comp; apply cancel_postcomposition, maponpaths, (pr2 h)). } transparent assert (σ : (∏ c, A ⟦ S c, R T c ⟧)). { intro c; apply (limArrow _ _ (cc c)). } set (lambda' := λ c' mf', limOut (LA (c' ↓ K) (QT T c')) mf'). (* this is the conclusion from the big diagram (8) in MacLane's proof *) assert (H : ∏ c c' (g : C ⟦ c, c' ⟧) (mf' : c' ↓ K), # S g · σ c' · lambda' _ mf' = σ c · Rmor T c c' g · lambda' _ mf'). { intros c c' g mf'. rewrite <- !assoc. apply pathsinv0; eapply pathscomp0. apply maponpaths, (limArrowCommutes _ _ (Rmor_cone T c c' g) mf'). apply pathsinv0; eapply pathscomp0. eapply maponpaths, (limArrowCommutes _ _ (cc c') mf'). simpl; rewrite assoc, <- functor_comp. set (mf := tpair _ (pr1 mf') (g · pr2 mf') : c ↓ K). apply pathsinv0. exact (limArrowCommutes (LA (c ↓ K) (QT T c)) (S c) (cc c) mf). } assert (is_nat_trans_σ : is_nat_trans S (R_data T) σ). { intros c c' g; simpl. transparent assert (ccc : (cone (QT T c') (S c))). { use make_cone. - intro mf'; apply (σ c · Rmor T c c' g · limOut (LA (c' ↓ K) (QT T c')) mf'). - abstract (intros u v e; simpl; rewrite <- !assoc; apply maponpaths, maponpaths, (limOutCommutes (LA (c' ↓ K) (QT T c')) u v e)). } rewrite (limArrowUnique (LA (c' ↓ K) (QT T c')) _ ccc (# S g · σ c') (H _ _ _)). now apply pathsinv0, limArrowUnique. } use tpair. + apply (tpair _ (tpair _ σ is_nat_trans_σ)). apply nat_trans_eq; [apply homset_property | intro n; cbn]. generalize (limArrowCommutes (LA (K n ↓ K) (QT T (K n))) _ (cc _) (Kid n)); simpl. now rewrite functor_id, id_left. + intro x. apply subtypePath; [intros xx; apply (isaset_nat_trans (homset_property A))|]. apply subtypePath; [intros xx; apply (isaprop_is_nat_trans _ _ (homset_property A))|]; simpl. apply funextsec; intro c. apply limArrowUnique; intro u; simpl. destruct x as [t p]; simpl. assert (temp : α (pr1 u) = nat_trans_comp _ _ T (pre_whisker K t) (eps T) (pr1 u)). now rewrite p. rewrite temp; simpl. destruct u as [n g]; simpl in *. apply pathsinv0; eapply pathscomp0; [rewrite assoc; apply cancel_postcomposition, (nat_trans_ax t _ _ g)|]. rewrite <- !assoc; apply maponpaths. generalize (limArrowCommutes (LA (K n ↓ K) _) _ (Rmor_cone T c (K n) g) (Kid n)). now simpl; rewrite id_right. Defined. End RightKanExtensionFromLims. UniMath-20231010/UniMath/CategoryTheory/SetValuedFunctors.v000066400000000000000000000152511451125700300234370ustar00rootroot00000000000000(** Facts about set valued functors - epimorphic natural transformations are pointwise epimorphic - epimorphic natural transformations enjoy a universal property similar to surjections [univ_surj_nt] - Definition of a quotient functor Ambroise LAFONT January 2017 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.EpiFacts. Require Import UniMath.CategoryTheory.limits.coequalizers. Local Open Scope cat. Lemma is_pointwise_epi_from_set_nat_trans_epi (C:category) (F G : functor C hset_precategory) (f:nat_trans F G) (h:isEpi (C:=functor_category C HSET) f) : ∏ (x:C), isEpi (f x). Proof. apply (Pushouts_pw_epi (D:=hset_category)). apply PushoutsHSET_from_Colims. apply h. Qed. (** Let p be an epimorphic natural transformation where the target category is HSET Given the following diagram : << f A ---> C | | p | v B >> there exists a unique natural transformation from B to C that makes the diagram commute provided that for any set X, any x,y in X, if [p x = p y] then [f x = f y] This property comes from the fact that p is an effective epimorphism. *) Section LiftEpiNatTrans. Context {CC:category}. Local Notation C_SET := (functor_category CC HSET). Context {A B C:functor CC HSET} (p:nat_trans A B) (f:nat_trans A C). Hypothesis (comp_epi: ∏ (X:CC) (x y: pr1hSet (A X)), p X x = p X y -> f X x = f X y). Hypothesis (surjectivep : isEpi (C:=C_SET) p). Lemma EffectiveEpis_Functor_HSET : EpisAreEffective C_SET. Proof. intros F G m isepim. apply (isEffectivePw (D:=hset_category)). intro x. apply EffectiveEpis_HSET. apply (Pushouts_pw_epi (D:=hset_category) PushoutsHSET_from_Colims). assumption. Qed. Definition univ_surj_nt : nat_trans B C. Proof. apply EffectiveEpis_Functor_HSET in surjectivep. red in surjectivep. set (coeq := limits.coequalizers.make_Coequalizer _ _ _ _ (pr2 surjectivep)). apply (limits.coequalizers.CoequalizerOut coeq _ f). abstract( apply (nat_trans_eq (has_homsets_HSET)); intro c; apply funextfun; intro x; apply comp_epi; assert (hcommut := limits.pullbacks.PullbackSqrCommutes (pr1 surjectivep)); eapply nat_trans_eq_pointwise in hcommut; apply toforallpaths in hcommut; apply hcommut). Defined. Lemma univ_surj_nt_ax : nat_trans_comp _ _ _ p univ_surj_nt = f . Proof. unfold univ_surj_nt; cbn. set (coeq := make_Coequalizer _ _ _ _ _). apply (CoequalizerCommutes coeq). Qed. Lemma univ_surj_nt_ax_pw x : p x · univ_surj_nt x = f x . Proof. now rewrite <- univ_surj_nt_ax. Qed. Lemma univ_surj_nt_ax_pw_pw x c : (p x · univ_surj_nt x) c = f x c. Proof. now rewrite <- univ_surj_nt_ax. Qed. Lemma univ_surj_nt_unique : ∏ g (H : nat_trans_comp _ _ _ p g = f) b, g b = univ_surj_nt b. Proof. intros g hg b. apply nat_trans_eq_pointwise. unfold univ_surj_nt. set (coeq := make_Coequalizer _ _ _ _ _). use (isCoequalizerOutUnique _ _ _ _ (isCoequalizer_Coequalizer coeq)). apply hg. Qed. End LiftEpiNatTrans. (** Quotient functors . Let C be a category Let R be a functor from C to Set. Let X be an object of C Let tilde a family of equivalence relations on RX satisfying if [x tilde y] and [f : X -> Y], then [f(x) tilde f(y)]. Then we can define [R'] as a functor which to any X associates [R'X = RX mod tilde] Moreover, there is an epimorphism [pr_quot_functor : R -> R'] *) Section QuotientFunctor. Context {D:category}. Variable (R:functor D HSET). (** This is [tilde] *) Variable (hequiv : ∏ (d:D),eqrel (pr1hSet (R d))). (** The relations satisfied by [hequiv (tilde)] *) Hypothesis (congru: ∏ (x y:D) (f:D⟦ x, y⟧), iscomprelrelfun (hequiv x) (hequiv y) (#R f)). (** Definition of the quotient functor *) (* not using setquotinset directly because as isasetsetquot is not opaque it would make computation slow in some cases (see issue 548) *) Definition quot_functor_ob (d:D) :hSet. Proof. use tpair. - apply (setquot (hequiv d)). - abstract (apply isasetsetquot). Defined. Definition quot_functor_mor (d d' : D) (f : D ⟦d, d'⟧) : HSET ⟦quot_functor_ob d, quot_functor_ob d' ⟧ := setquotfun (hequiv d) (hequiv d') (#R f) (congru d d' f). Definition quot_functor_data : functor_data D HSET := tpair _ _ quot_functor_mor. Lemma is_functor_quot_functor_data : is_functor quot_functor_data. Proof. split. - intros a; simpl. apply funextfun. intro c. apply (surjectionisepitosets (setquotpr _)); [now apply issurjsetquotpr | apply isasetsetquot|]. intro x; cbn. now rewrite (functor_id R). - intros a b c f g; simpl. apply funextfun; intro x. apply (surjectionisepitosets (setquotpr _)); [now apply issurjsetquotpr | apply isasetsetquot|]. intro y; cbn. now rewrite (functor_comp R). Qed. Definition quot_functor : functor D HSET := tpair _ _ is_functor_quot_functor_data. Definition pr_quot_functor_data : ∏ x , HSET ⟦R x, quot_functor x⟧ := λ x a, setquotpr _ a. Lemma is_nat_trans_pr_quot_functor : is_nat_trans _ _ pr_quot_functor_data. Proof. red; intros; apply idpath. Qed. Definition pr_quot_functor : (nat_trans R quot_functor) := (_ ,, is_nat_trans_pr_quot_functor). Lemma isEpi_pw_pr_quot_functor : ∏ x, isEpi (pr_quot_functor x). Proof. intros a z f g eqfg. apply funextfun. intro x. eapply surjectionisepitosets. apply issurjsetquotpr. apply setproperty. intro u. apply toforallpaths in eqfg. apply eqfg. Qed. Lemma isEpi_pr_quot_functor : isEpi (C:=functor_precategory _ _ has_homsets_HSET) pr_quot_functor. Proof. apply is_nat_trans_epi_from_pointwise_epis. apply isEpi_pw_pr_quot_functor. Qed. Lemma weqpathsinpr_quot_functor X x y : hequiv X x y ≃ pr_quot_functor X x = pr_quot_functor X y. Proof. apply (weqpathsinsetquot (hequiv X)). Qed. End QuotientFunctor. UniMath-20231010/UniMath/CategoryTheory/ShortExactSequences.v000066400000000000000000001240201451125700300237520ustar00rootroot00000000000000(** * Short exact sequences *) (** ** Contents - Definitions - ShortShortExact sequences - Remark on monics, epis, kernels, and cokernels - LeftShortExact sequences - RightShortExact sequences - ShortExact sequences - Opposite category and (short/left/right)exacts - A criteria for ShortShortExact - Cokernel from ShortShortExact - isCoequalizer to ShortShortExact - Correspondence between ShortExact and ShortShortExact - ShortExact from ShortShortExact - ShortShortExact criteria *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.Opp. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Local Open Scope cat. (** * Introduction Short exact sequences consist of three objects and two morphisms such that the first morphism is a monic, the second morphism is an epi, and an image of the first morphism gives a kernel of the second morphism. These sequences are classically denoted by a diagram 0 -> A -> B -> C -> 0 We call such diagrams [ShortExact]. To define short exact sequences we first define short short exact sequences, [ShortShortExact], left short exact sequences, [LeftShortExact], and right short exact sequences, [RightShortExact]. These correspond to the diagrams A -> B -> C, 0 -> A -> B -> C, and, A -> B -> C -> 0, respectively. The definition of [ShortShortExact] says that the image of A -> B is the kernel of B -> C. This is equivalent to saying that the coimage of B -> C is the cokernel of A -> B. We prove this correspondence in the Section [shortshortexact_coequalizer]. Next, in the section [shortexact_correspondence] we prove a correspondence between [ShortShortExact] and [ShortExact] by using the factorization formula for morphisms in abelian precategories. We construct [ShortExact] from [ShortShortExact] and we give a criteria to construct [ShortShortExact] from properties similar to [ShortExact]. *) (** * Definition of short exact sequences *) Section def_shortexactseqs. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** Image of the first morphism and equality of morphisms associated to it. *) Definition Image (SSED : ShortShortExactData A (to_Zero A)) : Kernel (to_Zero A) (CokernelArrow (Abelian.Cokernel (Mor1 SSED))) := Image (Mor1 SSED). Lemma isExact_Eq {x y z : ob A} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _) : KernelArrow (Abelian.Image f) · g = ZeroArrow (to_Zero A) _ _. Proof. unfold Abelian.Image. set (fact := factorization1 f). unfold factorization1_monic in fact. cbn in fact. apply (factorization1_is_epi f). rewrite ZeroArrow_comp_right. rewrite assoc. rewrite fact in H. clear fact. exact H. Qed. Definition isExact {x y z : ob A} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _) : UU := isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) g (isExact_Eq f g H). Lemma Image_Eq (SSED : ShortShortExactData A (to_Zero A)) : (KernelArrow (Image SSED)) · (Mor2 SSED) = ZeroArrow (to_Zero A) _ _. Proof. exact (isExact_Eq (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)). Defined. (** Coimage of the second morphism and equality of morphisms associated to it. *) Definition CoImage (SSED : ShortShortExactData A (to_Zero A)) : Cokernel (to_Zero A) (KernelArrow (Abelian.Kernel (Mor2 SSED))) := CoImage (Mor2 SSED). Lemma isExact'_Eq {x y z : ob A} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _) : f · CokernelArrow (Abelian.CoImage g) = ZeroArrow (to_Zero A) _ _. Proof. unfold Abelian.CoImage. set (fact := factorization2 g). unfold factorization2_epi in fact. cbn in fact. unfold Abelian.CoImage in fact. apply (factorization2_is_monic g). rewrite ZeroArrow_comp_left. rewrite <- assoc. apply (maponpaths (λ gg : _, f · gg)) in fact. use (pathscomp0 (! fact)). exact H. Qed. Definition isExact' {x y z : ob A} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _) : UU := isCokernel (to_Zero A) f (CokernelArrow (Abelian.CoImage g)) (isExact'_Eq f g H). Lemma CoImage_Eq (SSED : ShortShortExactData A (to_Zero A)) : (Mor1 SSED) · (CokernelArrow (CoImage SSED)) = ZeroArrow (to_Zero A) _ _. Proof. exact (isExact'_Eq (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)). Defined. (** ** Transform isExact to isExact' and isExact' to isExact *) Local Lemma isExact_to_isExact'_Eq {x y z : ob A} {f : x --> y} {g : y --> z} {H' : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact f g H') (w0 : A) (h : A ⟦y, w0⟧) (H : f · h = ZeroArrow (to_Zero A) _ _) : KernelArrow (Abelian.Kernel g) · h = ZeroArrow (to_Zero A) (Abelian.Kernel g) w0. Proof. unfold isExact in iE. set (K := make_Kernel _ _ _ _ iE). set (i := iso_from_Kernel_to_Kernel (to_Zero A) K (Abelian.Kernel g)). use (is_iso_isEpi A i (pr2 i)). rewrite ZeroArrow_comp_right. rewrite assoc. cbn. unfold from_Kernel_to_Kernel. rewrite KernelCommutes. use (factorization1_is_epi f). cbn. set (tmp := factorization1 f). unfold factorization1_epi in tmp. unfold factorization1_monic in tmp. cbn in tmp. rewrite assoc. rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_right. exact H. Qed. Lemma isExact_to_isExact' {x y z : ob A} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact f g H) : isExact' f g H. Proof. unfold isExact in iE. unfold isExact'. use make_isCokernel. intros w0 h H'. use unique_exists. (* Construction of the morphism *) - use CokernelOut. + exact h. + cbn. exact (isExact_to_isExact'_Eq iE w0 h H'). (* Commutativity *) - apply CokernelCommutes. (* Equality on equalities of morphisms *) - intros y'. apply hs. (* Uniqueness *) - intros y' T. cbn in T. apply CokernelOutsEq. rewrite T. apply pathsinv0. apply CokernelCommutes. Qed. Local Lemma isExact'_to_isExact_Eq {x y z : ob A} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact' f g H) {w0 : ob A} (h : A⟦ w0, y ⟧) (H' : h · g = ZeroArrow (to_Zero A) w0 z) : h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) w0 (Abelian.Cokernel f). Proof. unfold isExact' in iE. set (CK := make_Cokernel _ _ _ _ iE). set (i := iso_from_Cokernel_to_Cokernel (to_Zero A) (Abelian.Cokernel f) CK). use (is_iso_isMonic A i (pr2 i)). rewrite ZeroArrow_comp_left. rewrite <- assoc. cbn. unfold from_Cokernel_to_Cokernel. rewrite CokernelCommutes. use (factorization2_is_monic g). cbn. set (tmp := factorization2 g). unfold factorization2_monic in tmp. unfold factorization2_epi in tmp. cbn in tmp. rewrite <- assoc. rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_left. exact H'. Qed. Lemma isExact'_to_isExact {x y z : ob A} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact' f g H) : isExact f g H. Proof. unfold isExact' in iE. unfold isExact. use make_isKernel. intros w0 h H'. use unique_exists. (* Construction of the morphism *) - use KernelIn. + exact h. + cbn. exact (isExact'_to_isExact_Eq iE h H'). (* Commutativity *) - apply KernelCommutes. (* Equality on equalities of morphisms *) - intros y'. apply hs. (* Uniqueness *) - intros y' T. cbn in T. apply KernelInsEq. rewrite T. apply pathsinv0. apply KernelCommutes. Qed. Lemma isExactisMonic {x y : ob A} {f : x --> y} (isM : isMonic f) (H : ZeroArrow (to_Zero A) (to_Zero A) x · f = ZeroArrow (to_Zero A) (to_Zero A) y) : isExact (ZeroArrow (to_Zero A) (to_Zero A) x) f H. Proof. unfold isExact. use make_isKernel. - intros w h H'. use unique_exists. + use KernelIn. * exact h. * rewrite <- (ZeroArrow_comp_left _ _ _ _ _ f) in H'. apply isM in H'. rewrite H'. apply ZeroArrow_comp_left. + cbn. use KernelCommutes. + intros y'. apply hs. + intros y' X. cbn in X. cbn. use (KernelArrowisMonic (to_Zero A) (Abelian.Image (ZeroArrow (to_Zero A) (to_Zero A) x))). rewrite X. apply pathsinv0. use KernelCommutes. Qed. Lemma isExactisEpi {x y : ob A} {f : x --> y} (isE : isEpi f) (H : f · ZeroArrow (to_Zero A) y (to_Zero A) = ZeroArrow (to_Zero A) x (to_Zero A)) : isExact f (ZeroArrow (to_Zero A) y (to_Zero A)) H. Proof. unfold isExact. use make_isKernel. - intros w h H'. use unique_exists. + use KernelIn. * exact h. * rewrite <- (ZeroArrow_comp_right _ _ _ _ _ h). apply cancel_precomposition. apply isE. rewrite CokernelCompZero. rewrite ZeroArrow_comp_right. apply idpath. + cbn. use KernelCommutes. + intros y'. apply hs. + intros y' X. cbn. cbn in X. use (KernelArrowisMonic (to_Zero A) (Abelian.Image f)). rewrite X. apply pathsinv0. use KernelCommutes. Qed. (** ** [Short Short Exact] [ShortShortData] such that the image of the first morphism is the kernel of the second morphism. Informally, an exact sequence A -> B -> C *) Definition ShortShortExact : UU := ∑ SSED : ShortShortExactData A (to_Zero A), isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED). Definition make_ShortShortExact (SSED : ShortShortExactData A (to_Zero A)) (H : isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED)) : ShortShortExact := tpair _ SSED H. (** Accessor functions *) Definition ShortShortExact_ShortShortExactData (SSE : ShortShortExact) : ShortShortExactData A (to_Zero A) := pr1 SSE. Coercion ShortShortExact_ShortShortExactData : ShortShortExact >-> ShortShortExactData. Definition ShortShortExact_isKernel (SSE : ShortShortExact) : isKernel (to_Zero A) (KernelArrow (Image SSE)) (Mor2 SSE) (Image_Eq SSE) := pr2 SSE. Definition ShortShortExact_Kernel (SSE : ShortShortExact) : Kernel (to_Zero A) (Mor2 SSE) := make_Kernel (to_Zero A) (KernelArrow (Image SSE)) (Mor2 SSE) (Image_Eq SSE) (ShortShortExact_isKernel SSE). (** ** Remark In Abelian.v we have already shown that a morphism is a monic if and only if its kernel is zero, and dually is an epi if and only if its cokernel is zero. See the results - Abelian_MonicKernelZero_isEqualizer, Abelian_MonicKernelZero - Abelian_EpiCokernelZero_isCoequalizer, Abelian_EpiCokernelZero - Abelian_KernelZeroisMonic, Abelian_KernelZeroMonic - Abelian_CokernelZeroisEpi, Abelian_CokernelZeroEpi in CategoryTheory/Abelian.v. Thus, to define short exact sequeces, it suffices to assume that the first morphism is a monic and the second morphism is an epi. Similarly for left short exact and right short exact. *) (** ** [LeftShortExact] [ShortShortExact] such that the first morphism is a monic. Informally, an exact sequence 0 -> A -> B -> C *) Definition LeftShortExact : UU := ∑ SSE : ShortShortExact, isMonic (Mor1 SSE). Definition make_LeftShortExact (SSE : ShortShortExact) (isM : isMonic (Mor1 SSE)) : LeftShortExact := tpair _ SSE isM. (** Accessor functions *) Definition LeftShortExact_ShortShortExact (LSE : LeftShortExact) : ShortShortExact := pr1 LSE. Coercion LeftShortExact_ShortShortExact : LeftShortExact >-> ShortShortExact. Definition isMonic (LSE : LeftShortExact) : isMonic (Mor1 LSE) := pr2 LSE. (** ** [RightShortExact] [ShortShortExact] such that the second morphism is an epi. Informally, an exact sequece A -> B -> C -> 0 *) Definition RightShortExact : UU := ∑ SSE : ShortShortExact, isEpi (Mor2 SSE). Definition make_RightShortExact (SSE : ShortShortExact) (isE : isEpi (Mor2 SSE)) : RightShortExact := tpair _ SSE isE. (** Accessor functions *) Definition RightShortExact_ShortShortExact (RSE : RightShortExact) : ShortShortExact := pr1 RSE. Coercion RightShortExact_ShortShortExact : RightShortExact >-> ShortShortExact. Definition isEpi (RSE : RightShortExact) : isEpi (Mor2 RSE) := pr2 RSE. (** ** [ShortExact] [ShortShortExact] such that the first morphism is monic and the second morphism is an epi. Informally, an exact sequece 0 -> A -> B -> C -> 0 *) Definition ShortExact : UU := ∑ SSE : ShortShortExact, Monics.isMonic (Mor1 SSE) × Epis.isEpi (Mor2 SSE). Definition make_ShortExact (SSE : ShortShortExact) (isM : Monics.isMonic (Mor1 SSE)) (isE : Epis.isEpi (Mor2 SSE)) : ShortExact := (SSE,,(isM,,isE)). (** [LeftShortExact] and [RightShortExact] from [ShortExact] *) Definition ShortExact_LeftShortExact (SE : ShortExact) : LeftShortExact. Proof. use make_LeftShortExact. - exact (pr1 SE). - exact (dirprod_pr1 (pr2 SE)). Defined. Coercion ShortExact_LeftShortExact : ShortExact >-> LeftShortExact. Definition ShortExact_RightShortExact (SE : ShortExact) : RightShortExact. Proof. use make_RightShortExact. - exact (pr1 SE). - exact (dirprod_pr2 (pr2 SE)). Defined. Coercion ShortExact_RightShortExact : ShortExact >-> RightShortExact. End def_shortexactseqs. Arguments Image [A] _. Arguments Image_Eq [A] _. Arguments CoImage [A] _. Arguments CoImage_Eq [A] _. Arguments make_ShortShortExact [A] _ _. Arguments ShortShortExact_isKernel [A] _ _ _ _. Arguments ShortShortExact_Kernel [A] _. Arguments make_LeftShortExact [A] _ _. Arguments isMonic [A] _ _ _ _ _. Arguments make_RightShortExact [A] _ _ . Arguments isEpi [A] _ _ _ _ _ . Arguments make_ShortShortExact [A] _ _. (** * [ShortShortExact] criteria In this section we show that for [ShortShortExact] a coimage of the second morphism is a cokernel of the first morphism and give a way to construct [ShortShortExact] from certain isCokernel. *) Section shortshortexact_cokernel. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** [ShortShortExact] implies isCoequalizer. Note that in the definition of [ShortShortExact] we use isEqualizer to say that an image of the first morphism is a kernel of the second morphism. We show that also the coimage of the second morphism is a cokernel of the first morphism. Informally, this follows directly from the fact that the opposite category of an abelian category is an abelian category and that taking the opposite category twice, we get the same category. *) Local Lemma ShortShortExact_isCokernel_eq1 (SSE : ShortShortExact A) (w0 : A) (h : A ⟦Ob2 SSE, w0⟧) (H : Mor1 SSE · h = ZeroArrow (to_Zero A) _ _) : (KernelArrow (ShortShortExact_Kernel SSE)) · h = ZeroArrow (to_Zero A) _ _. Proof. apply (factorization1_is_epi (Mor1 SSE)). set (tmp := factorization1 (Mor1 SSE)). unfold factorization1_epi in tmp. unfold factorization1_monic in tmp. cbn in tmp. rewrite assoc. unfold ShortShortExact_Kernel. cbn. unfold Image. rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_right. exact H. Qed. Local Lemma ShortShortExact_isCokernel_eq2 (SSE : ShortShortExact A) (w0 : A) (h : A ⟦Ob2 SSE, w0⟧) (H : Mor1 SSE · h = ZeroArrow (to_Zero A) _ _) : KernelArrow (Abelian.Kernel (Mor2 SSE)) · h = ZeroArrow (to_Zero A) _ _. Proof. set (i := iso_from_Kernel_to_Kernel (to_Zero A) (ShortShortExact_Kernel SSE) (Abelian.Kernel (Mor2 SSE))). set (epi := is_iso_Epi A i (pr2 i)). apply (pr2 epi). cbn. rewrite ZeroArrow_comp_right. rewrite assoc. unfold from_Kernel_to_Kernel. rewrite KernelCommutes. apply (ShortShortExact_isCokernel_eq1 SSE w0 h H). Qed. Local Lemma ShortShortExact_isCokernel (SSE : ShortShortExact A) : isCokernel (to_Zero A) (Mor1 SSE) (CokernelArrow (CoImage SSE)) (CoImage_Eq SSE). Proof. use make_isCokernel. intros w0 h H'. use unique_exists. (* Construction of the morphism *) - exact (CokernelOut (to_Zero A) (CoImage SSE) w0 h (ShortShortExact_isCokernel_eq2 SSE w0 h H')). (* Commutativity *) - apply CokernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. apply CokernelOutsEq. rewrite T. apply pathsinv0. apply CokernelCommutes. Qed. Definition ShortShortExact_Cokernel (SSE : ShortShortExact A) : Cokernel (to_Zero A) (Mor1 SSE) := make_Cokernel (to_Zero A) (Mor1 SSE) (CokernelArrow (CoImage SSE)) (CoImage_Eq SSE) (ShortShortExact_isCokernel SSE). (** ** From isCokernel to [ShortShortExact] We show that we can construct [ShortShortExact] from the isCokernel property proved above. *) Local Lemma ShortShortExact_from_isCokernel_eq1 (SSED : ShortShortExactData A (to_Zero A)) (w : A) (h : A ⟦w, Ob2 SSED⟧) (H : (h · (CokernelArrow (Abelian.CoImage (Mor2 SSED)))) = ZeroArrow (to_Zero A) _ _) (H' : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) : h · CokernelArrow (Abelian.Cokernel (Mor1 SSED)) = ZeroArrow (to_Zero A) _ _. Proof. set (coker := make_Cokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED) H'). set (i := iso_from_Cokernel_to_Cokernel (to_Zero A) (Abelian.Cokernel (Mor1 SSED)) coker). set (isM := is_iso_Monic A i (pr2 i)). apply (pr2 isM). cbn. rewrite ZeroArrow_comp_left. rewrite <- assoc. unfold from_Cokernel_to_Cokernel. rewrite CokernelCommutes. unfold coker. cbn. unfold CoImage. exact H. Qed. Local Lemma ShortShortExact_from_isCokernel_eq2 (SSED : ShortShortExactData A (to_Zero A)) (w : A) (h : A ⟦w, Ob2 SSED⟧) (H : h · Mor2 SSED = ZeroArrow (to_Zero A) _ _) (H' : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) : h · CokernelArrow (Abelian.CoImage (Mor2 SSED)) = ZeroArrow (to_Zero A) _ _. Proof. apply (factorization2_is_monic (Mor2 SSED)). set (tmp := factorization2 (Mor2 SSED)). unfold factorization2_epi in tmp. unfold factorization2_monic in tmp. cbn in tmp. rewrite <- assoc. rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_left. exact H. Qed. Lemma ShortShortExact_from_isCokernel_isKernel (SSED : ShortShortExactData A (to_Zero A)) (H : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) : isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED). Proof. use make_isKernel. intros w h H'. use unique_exists. (* Construction of the morphism *) - apply (KernelIn (to_Zero A) (Image SSED) w h (ShortShortExact_from_isCokernel_eq1 SSED w h (ShortShortExact_from_isCokernel_eq2 SSED w h H' H) H)). (* Commutativity *) - apply KernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. apply KernelInsEq. rewrite T. apply pathsinv0. apply KernelCommutes. Qed. Definition ShortShortExact_from_isCokernel (SSED : ShortShortExactData A (to_Zero A)) (H : isCokernel (to_Zero A) (Mor1 SSED) (CokernelArrow (CoImage SSED)) (CoImage_Eq SSED)) : ShortShortExact A := make_ShortShortExact SSED (ShortShortExact_from_isCokernel_isKernel SSED H). End shortshortexact_cokernel. Arguments ShortShortExact_Cokernel [A] _ . Arguments ShortShortExact_from_isCokernel [A] _ _. (** * Correspondence of shortexact in A an A^op *) Section shortexact_opp. Local Opaque ZeroArrow isKernel isCokernel. Lemma isExact_opp_Eq {A : AbelianPreCat} {x y z : ob A} {f : x --> y} {g : y --> z} (H : f · g = ZeroArrow (to_Zero A) _ _) : (g : (Abelian_opp A)⟦_, _⟧) · (f : (Abelian_opp A)⟦_, _⟧) = @ZeroArrow (Abelian_opp A) (Zero_opp A (to_Zero A)) _ _. Proof. cbn. use (pathscomp0 H). use ZeroArrow_opp. Qed. Unset Kernel Term Sharing. Lemma isExact_opp {A : AbelianPreCat} {x y z : ob A} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow (to_Zero A) _ _} (iE : isExact A f g H) : isExact (Abelian_opp A) g f (isExact_opp_Eq H). Proof. unfold isExact. use isKernel_opp. - exact (to_Zero A). - exact (isExact'_Eq A f g H). - exact (isExact_to_isExact' A iE). Qed. Set Kernel Term Sharing. Definition ShortShortExact_opp {A : AbelianPreCat} (SSE : ShortShortExact A) : ShortShortExact (Abelian_opp A). Proof. use make_ShortShortExact. - exact (ShortShortExactData_opp SSE). - cbn. use isKernel_opp. + exact (to_Zero A). + exact (CoImage_Eq SSE). + exact (CokernelisCokernel (to_Zero A) (ShortShortExact_Cokernel SSE)). Defined. Unset Kernel Term Sharing. Local Lemma opp_ShortShortExact_isKernel {A : AbelianPreCat} (SSE : ShortShortExact (Abelian_opp A)) : isKernel (to_Zero A) (KernelArrow (Image (opp_ShortShortExactData SSE))) (Mor2 (opp_ShortShortExactData SSE)) (Image_Eq (opp_ShortShortExactData SSE)). Proof. cbn. use opp_isKernel. - exact (Zero_opp A (to_Zero A)). - exact (CoImage_Eq SSE). - exact (@CokernelisCokernel (Abelian_opp A) (Zero_opp A (to_Zero A)) _ _ _ (ShortShortExact_Cokernel SSE)). Qed. Set Kernel Term Sharing. Definition opp_ShortShortExact {A : AbelianPreCat} (SSE : ShortShortExact (Abelian_opp A)) : ShortShortExact A. Proof. use make_ShortShortExact. - exact (opp_ShortShortExactData SSE). - exact (opp_ShortShortExact_isKernel SSE). Defined. Definition LeftShortExact_opp {A : AbelianPreCat} (LSE : LeftShortExact A) : RightShortExact (Abelian_opp A). Proof. use make_RightShortExact. - exact (ShortShortExact_opp LSE). - use isMonic_opp. exact (isMonic LSE). Defined. Definition opp_LeftShortExact {A : AbelianPreCat} (LSE : LeftShortExact (Abelian_opp A)) : RightShortExact A. Proof. use make_RightShortExact. - exact (opp_ShortShortExact LSE). - use opp_isMonic. exact (isMonic LSE). Defined. Definition RightShortExact_opp {A : AbelianPreCat} (RSE : RightShortExact A) : LeftShortExact (Abelian_opp A). Proof. use make_LeftShortExact. - exact (ShortShortExact_opp RSE). - use isEpi_opp. exact (isEpi RSE). Defined. Definition opp_RightShortExact {A : AbelianPreCat} (RSE : RightShortExact (Abelian_opp A)) : LeftShortExact A. Proof. use make_LeftShortExact. - exact (opp_ShortShortExact RSE). - use opp_isEpi. exact (isEpi RSE). Defined. Definition ShortExact_opp {A : AbelianPreCat} (SE : ShortExact A) : ShortExact (Abelian_opp A). Proof. use make_ShortExact. - exact (ShortShortExact_opp SE). - use isEpi_opp. exact (isEpi SE). - use isMonic_opp. exact (isMonic SE). Defined. Definition opp_ShortExact {A : AbelianPreCat} (SE : ShortExact (Abelian_opp A)) : ShortExact A. Proof. use make_ShortExact. - exact (opp_ShortShortExact SE). - use opp_isEpi. exact (isEpi SE). - use opp_isMonic. exact (isMonic SE). Defined. End shortexact_opp. (** * [LeftShortExact] and [RightShortExact] from a [ShortShortExact] with extra properties *) Section shortshortexact_to_leftshortexact. Variable A : AbelianPreCat. Definition LeftShortExact_from_ShortShortExact (SSE : ShortShortExact A) (isK : isKernel (to_Zero A) (Mor1 SSE) (Mor2 SSE) (ShortShortExactData_Eq (to_Zero A) SSE)) : LeftShortExact A. Proof. use make_LeftShortExact. - exact SSE. - exact (KernelArrowisMonic _ (make_Kernel _ _ _ _ isK)). Defined. Definition RightShortExact_from_ShortShortExact (SSE : ShortShortExact A) (isCK : isCokernel (to_Zero A) (Mor1 SSE) (Mor2 SSE) (ShortShortExactData_Eq (to_Zero A) SSE)) : RightShortExact A. Proof. use make_RightShortExact. - exact SSE. - exact (CokernelArrowisEpi _ (make_Cokernel _ _ _ _ isCK)). Defined. End shortshortexact_to_leftshortexact. (** * Correspondence between [ShortShortExact] and [ShortExact] In this section we prove correspondence between [ShortShortExact] and [ShortExact]. *) Section shortexact_correspondence. Variable A : AbelianPreCat. (** ** Construction of [ShortExact] from [ShortShortExact] By using the factorization property of morphisms in abelian categories, we show that we can construct a [ShortExact] from [ShortShortExact] in a canonical way. More precisely, such [ShortExact] is given by taking the first morphism to be the image of the first morphism of the [ShortShortExact] and the second morphism to be the coimage of the second morphism of the [ShortShortExact]. *) Local Lemma ShortExact_from_ShortShortExact_eq (SSE : ShortShortExact A) : (KernelArrow (Abelian.Image (Mor1 SSE))) · (CokernelArrow (Abelian.CoImage (Mor2 SSE))) = ZeroArrow (to_Zero A) _ _. Proof. (* Work on mor1 using factorization *) apply (factorization1_is_epi (Mor1 SSE)). rewrite assoc. set (fact := factorization1 (Mor1 SSE)). rewrite ZeroArrow_comp_right. unfold factorization1_monic in fact. cbn in fact. rewrite <- fact. clear fact. (* Work on mor2 using factorization *) apply (factorization2_is_monic (Mor2 SSE)). rewrite <- assoc. set (fact := factorization2 (Mor2 SSE)). unfold factorization2_epi in fact. cbn in fact. rewrite <- fact. clear fact. rewrite ZeroArrow_comp_left. (* Follows now from the Eq *) apply (ShortShortExactData_Eq (to_Zero A) SSE). Qed. Local Lemma ShortExact_ShortShortExact_isKernel_Eq (SSE : ShortShortExact A) (w : A) (h : A ⟦w, Ob2 SSE⟧) (H' : h · CokernelArrow (Abelian.CoImage (Mor2 SSE)) = ZeroArrow (to_Zero A) _ _) : let Im := Abelian.Image (Mor1 SSE) in h · (CokernelArrow (Abelian.Cokernel (KernelArrow Im))) = ZeroArrow (to_Zero A) _ _. Proof. cbn zeta. assert (X : h · Mor2 SSE = ZeroArrow (to_Zero A) _ _). { rewrite (factorization2 (Mor2 SSE)). unfold factorization2_epi. cbn. set (tmp := factorization2_monic A (Mor2 SSE)). apply (maponpaths (λ h' : _, h' · tmp)) in H'. unfold tmp in H'. clear tmp. rewrite ZeroArrow_comp_left in H'. rewrite <- assoc in H'. unfold factorization2_monic in H'. cbn in H'. exact H'. } set (comm1 := KernelCommutes (to_Zero A) (Abelian.Kernel (Mor2 SSE)) w h X). set (ker := ShortShortExact_Kernel SSE). set (tmp := Abelian.Kernel (Mor2 SSE)). set (tmp_eq := (KernelCompZero (to_Zero A) tmp)). set (comm2 := KernelCommutes (to_Zero A) ker tmp (KernelArrow tmp) tmp_eq). unfold tmp in comm2. rewrite <- comm2 in comm1. clear comm2. rewrite <- comm1. rewrite <- assoc. rewrite <- assoc. rewrite CokernelCompZero. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Qed. Local Lemma ShortExact_ShortShortExact_isKernel (SSE : ShortShortExact A) : let Im := Abelian.Image (Mor1 SSE) in let CoIm := Abelian.CoImage (Mor2 SSE) in let MP := make_MorphismPair (KernelArrow Im) (CokernelArrow CoIm) in let SSED := make_ShortShortExactData (to_Zero A) MP (ShortExact_from_ShortShortExact_eq SSE) in isKernel (to_Zero A) (KernelArrow (Image SSED)) (CokernelArrow CoIm) (Image_Eq SSED). Proof. intros Im CoIm MP SSED. use make_isKernel. intros w h H'. use unique_exists. (* Construction of the morphism *) - use KernelIn. + exact h. + apply (ShortExact_ShortShortExact_isKernel_Eq SSE w h H'). (* Commutativity *) - apply KernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply homset_property. (* Uniqueness *) - intros y T. cbn in T. apply KernelInsEq. use (pathscomp0 T). apply pathsinv0. apply KernelCommutes. Qed. Definition ShortExact_from_ShortShortExact (SSE : ShortShortExact A) : ShortExact A. Proof. use make_ShortExact. - use make_ShortShortExact. + use make_ShortShortExactData. * use make_MorphismPair. -- exact (Abelian.Image (Mor1 SSE)). -- exact (Ob2 SSE). -- exact (Abelian.CoImage (Mor2 SSE)). -- exact (KernelArrow (Abelian.Image (Mor1 SSE))). -- exact (CokernelArrow (Abelian.CoImage (Mor2 SSE))). * exact (ShortExact_from_ShortShortExact_eq SSE). + exact (ShortExact_ShortShortExact_isKernel SSE). - exact (KernelArrowisMonic (to_Zero A) _). - exact (CokernelArrowisEpi (to_Zero A) _). Defined. (** ** [ShortShortExact] from data of [ShortExact] We construct a [ShortShortExact] from data corresponding to [ShortExact]. For a more precise statement, see the comment above [ShortShortExact_from_isShortExact]. *) Local Lemma ShortShortExact_from_isSortExact_eq {a b c : A} (f : a --> b) (g : b --> c) (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) = ZeroArrow (to_Zero A) _ _) (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) (CokernelArrow (Abelian.CoImage g)) H) : f · g = ZeroArrow (to_Zero A) _ _. Proof. set (tmp := maponpaths (λ h : _, CokernelArrow (Abelian.CoImage f) · (CoIm_to_Im f) · h) H). cbn in tmp. rewrite ZeroArrow_comp_right in tmp. apply (maponpaths (λ h : _, h · (CoIm_to_Im g) · ((KernelArrow (Abelian.Image g))))) in tmp. rewrite ZeroArrow_comp_left in tmp. rewrite assoc in tmp. (* Work on f in tmp *) set (fact := factorization2 f). unfold factorization2_epi in fact. cbn in fact. rewrite assoc in fact. rewrite <- fact in tmp. clear fact. (* Work of g in tmp *) set (fact := factorization1 g). unfold factorization2_monic in fact. cbn in fact. rewrite <- assoc in tmp. rewrite <- assoc in tmp. rewrite <- assoc in fact. rewrite <- fact in tmp. clear fact. (* Follows from tmp *) rewrite ZeroArrow_comp_left in tmp. exact tmp. Qed. Local Lemma ShortShortExact_from_isShortExact_isKernel_eq {a b c : A} (f : a --> b) (g : b --> c) (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) = ZeroArrow (to_Zero A) _ _) (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) (CokernelArrow (Abelian.CoImage g)) H) (w : A) (h : A ⟦w, b⟧) (H' : h · g = ZeroArrow (to_Zero A) w c) : h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) w (Abelian.Cokernel f). Proof. set (ker := make_Kernel (to_Zero A) (KernelArrow (Abelian.Image f)) (CokernelArrow (Abelian.CoImage g)) H isEq). (* Rewrite g in H' *) set (fact := factorization2 g). unfold factorization2_epi in fact. cbn in fact. rewrite fact in H'. clear fact. (* Use commutativity of ker *) rewrite assoc in H'. assert (X : h · CokernelArrow (Abelian.CoImage g) = ZeroArrow (to_Zero A) _ _). { apply (factorization2_is_monic g). rewrite ZeroArrow_comp_left. apply H'. } set (comm1 := KernelCommutes (to_Zero A) ker w h X). unfold ker in comm1. cbn in comm1. rewrite <- comm1. clear comm1. (* Follows from KernelCompZero *) unfold Image. rewrite <- assoc. rewrite KernelCompZero. apply ZeroArrow_comp_right. Qed. Local Lemma ShortShortExact_from_isShortExact_isKernel {a b c : A} (f : a --> b) (g : b --> c) (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) = ZeroArrow (to_Zero A) _ _) (isK : isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) (CokernelArrow (Abelian.CoImage g)) H) : let SSED := make_ShortShortExactData (to_Zero A) (make_MorphismPair f g) (ShortShortExact_from_isSortExact_eq f g H isK) in isKernel (to_Zero A) (KernelArrow (Image SSED)) g (Image_Eq SSED). Proof. intros SSED. use make_isKernel. intros w h H'. use unique_exists. (* Construction of the arrow *) - use KernelIn. + exact h. + exact (ShortShortExact_from_isShortExact_isKernel_eq f g H isK w h H'). (* Comutativity *) - apply KernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply homset_property. (* Uniqueness *) - intros y T. apply KernelInsEq. rewrite T. apply pathsinv0. apply KernelCommutes. Qed. (** To see how the assumptions correspond to [ShortExact] note that every kernel is a monic and every cokernel is an epi. Also, the assumption H says that an image of f is the kernel of a coimage of g. In abelian categories every monic is the kernel of its cokernel, and thus one can show that in isE the kernelarrow can be "replaced" by the kernelarrow of the image of the kernelarrow. Thus the assumptions are similar to assumptions of [ShortExact]. *) Definition ShortShortExact_from_isShortExact {a b c : A} (f : a --> b) (g : b --> c) (H : (KernelArrow (Abelian.Image f)) · (CokernelArrow (Abelian.CoImage g)) = ZeroArrow (to_Zero A) _ _) (isEq : isKernel (to_Zero A) (KernelArrow (Abelian.Image f)) (CokernelArrow (Abelian.CoImage g)) H) : ShortShortExact A. Proof. use make_ShortShortExact. - use make_ShortShortExactData. + use make_MorphismPair. * exact a. * exact b. * exact c. * exact f. * exact g. + exact (ShortShortExact_from_isSortExact_eq f g H isEq). - exact (ShortShortExact_from_isShortExact_isKernel f g H isEq). Defined. End shortexact_correspondence. Arguments ShortExact_from_ShortShortExact [A] _ . Arguments ShortShortExact_from_isShortExact [A] _ _ _ _ _ _ _ . (** * [ShortShortExact] from isKernel and isCokernel *) (** ** Introduction In this section we construct [ShortShortExact] from a pair of morphisms where the first morphism is the kernel of the second morphisms and where the second morphism is the cokernel of the first morphism. *) Section shortshortexact_iskernel_iscokernel. Variable A : AbelianPreCat. Lemma make_ShortShortExact_isKernel_isKernel (SSED : ShortShortExactData A (to_Zero A)) (H : isKernel (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) : isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED). Proof. set (K := make_Kernel _ _ _ _ H). set (e1 := factorization1 (Mor1 SSED)). cbn in e1. unfold Image. assert (e : is_z_isomorphism (CokernelArrow (Abelian.CoImage (Mor1 SSED)) · CoIm_to_Im (Mor1 SSED))). { use monic_epi_is_iso. - use isMonic_postcomp. + exact (Ob2 SSED). + exact (KernelArrow (Abelian.Image (Mor1 SSED))). + rewrite <- e1. use (KernelArrowisMonic (to_Zero A) K). - exact (factorization1_is_epi (Mor1 SSED)). } use Kernel_up_to_iso_isKernel. + exact K. + exact (z_iso_inv (make_z_iso _ _ e)). + apply (maponpaths (λ g : _, (inv_from_z_iso (make_z_iso _ _ e)) · g)) in e1. use (pathscomp0 _ (! e1)). clear e1. rewrite assoc. cbn. rewrite (is_inverse_in_precat2 e). rewrite id_left. apply idpath. Qed. Definition make_ShortShortExact_isKernel (SSED : ShortShortExactData A (to_Zero A)) (H : isKernel (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) : ShortShortExact A. Proof. use make_ShortShortExact. - exact SSED. - exact (make_ShortShortExact_isKernel_isKernel SSED H). Defined. Lemma make_ShortShortExact_isCokernel_isKernel (SSED : ShortShortExactData A (to_Zero A)) (H : isCokernel (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) : isKernel (to_Zero A) (KernelArrow (Image SSED)) (Mor2 SSED) (Image_Eq SSED). Proof. use ShortShortExact_from_isCokernel_isKernel. set (CK := make_Cokernel _ _ _ _ H). set (e1 := factorization2 (Mor2 SSED)). cbn in e1. unfold CoImage. assert (e : is_z_isomorphism (CoIm_to_Im (Mor2 SSED) · KernelArrow (Abelian.Image (Mor2 SSED)))). { use monic_epi_is_iso. - exact (factorization2_is_monic (Mor2 SSED)). - use isEpi_precomp. + exact (Ob2 SSED). + exact (CokernelArrow (Abelian.CoImage (Mor2 SSED))). + rewrite <- e1. use (CokernelArrowisEpi (to_Zero A) CK). } use Cokernel_up_to_iso_isCokernel. + exact CK. + exact (z_iso_inv (make_z_iso _ _ e)). + apply (maponpaths (λ g : _, g · (inv_from_z_iso (make_z_iso _ _ e)))) in e1. use (pathscomp0 _ (! e1)). clear e1. rewrite <- assoc. cbn. rewrite (is_inverse_in_precat1 e). rewrite id_right. apply idpath. Qed. Definition make_ShortShortExact_isCokernel (SSED : ShortShortExactData A (to_Zero A)) (H : isCokernel (to_Zero A) (Mor1 SSED) (Mor2 SSED) (ShortShortExactData_Eq (to_Zero A) SSED)) : ShortShortExact A. Proof. use make_ShortShortExact. - exact SSED. - exact (make_ShortShortExact_isCokernel_isKernel SSED H). Defined. End shortshortexact_iskernel_iscokernel. (** * [LeftShortExact] (resp. [RightShortExact]) construction for derived functors *) (** ** Introduction Let f : A --> B and g : A --> C be morphisms. In this section we construct a right short exact sequence of the form A --(f · i_1 - g · i_2)--> B ⊕ C --> W --> 0 where B ⊕ C --> W is the coequalizer of f · i_1 and g · i_2. Similarly for left short exact sequences and equalizers. *) Section left_right_shortexact_and_pullbacks_pushouts. Variable A : AbelianPreCat. Local Opaque Abelian.Equalizer. Local Opaque Abelian.Coequalizer. Local Opaque to_BinDirectSums. Local Opaque to_binop to_inv. (** ** [LeftShortExact] containing an equalizer *) Definition LeftShortExact_Equalizer_ShortShortExactData {x1 x2 y : ob A} (f : x1 --> y) (g : x2 --> y) : ShortShortExactData A (to_Zero A). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) x1 x2). set (E := Abelian.Equalizer A (to_Pr1 DS · f) (to_Pr2 DS · g)). set (PA := (AbelianToAdditive A) : PreAdditive). use make_ShortShortExactData. - use make_MorphismPair. + exact E. + exact DS. + exact y. + exact (EqualizerArrow E). + use (@to_binop PA). * exact (to_Pr1 DS · f). * exact (@to_inv PA _ _ (to_Pr2 DS · g)). - cbn. exact (AdditiveEqualizerToKernel_eq1 (AbelianToAdditive A) _ _ E). Defined. Definition LeftShortExact_Equalizer_ShortShortExact {x1 x2 y : ob A} (f : x1 --> y) (g : x2 --> y) : ShortShortExact A. Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) x1 x2). set (E := Abelian.Equalizer A (to_Pr1 DS · f) (to_Pr2 DS · g)). use make_ShortShortExact. - exact (LeftShortExact_Equalizer_ShortShortExactData f g). - cbn. cbn in E. fold DS. fold E. use make_ShortShortExact_isKernel_isKernel. exact (AdditiveEqualizerToKernel_isKernel (AbelianToAdditive A) _ _ E). Defined. Definition LeftShortExact_Equalizer {x1 x2 y : ob A} (f : x1 --> y) (g : x2 --> y) : LeftShortExact A. Proof. use make_LeftShortExact. - exact (LeftShortExact_Equalizer_ShortShortExact f g). - use EqualizerArrowisMonic. Defined. (** ** [RightShortExact] containing a coequalizer *) Definition RightShortExact_Coequalizer_ShortShortExactData {x y1 y2 : ob A} (f : x --> y1) (g : x --> y2) : ShortShortExactData A (to_Zero A). Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) y1 y2). set (CE := Abelian.Coequalizer A (f · to_In1 DS) (g · to_In2 DS)). set (PA := (AbelianToAdditive A) : PreAdditive). use make_ShortShortExactData. - use make_MorphismPair. + exact x. + exact DS. + exact CE. + use (@to_binop PA). * exact (f · to_In1 DS). * exact (@to_inv PA _ _ (g · to_In2 DS)). + exact (CoequalizerArrow CE). - cbn. exact (AdditiveCoequalizerToCokernel_eq1 (AbelianToAdditive A) _ _ CE). Defined. Definition RightShortExact_Coequalizer_ShortShortExact {x y1 y2 : ob A} (f : x --> y1) (g : x --> y2) : ShortShortExact A. Proof. set (DS := to_BinDirectSums (AbelianToAdditive A) y1 y2). set (CE := Abelian.Coequalizer A (f · to_In1 DS) (g · to_In2 DS)). use make_ShortShortExact. - exact (RightShortExact_Coequalizer_ShortShortExactData f g). - cbn. cbn in CE. fold DS. fold CE. use make_ShortShortExact_isCokernel_isKernel. exact (AdditiveCoequalizerToCokernel_isCokernel (AbelianToAdditive A) _ _ CE). Defined. Definition RightShortExact_Coequalizer {x y1 y2 : ob A} (f : x --> y1) (g : x --> y2) : RightShortExact A. Proof. use make_RightShortExact. - exact (RightShortExact_Coequalizer_ShortShortExact f g). - use CoequalizerArrowisEpi. Defined. End left_right_shortexact_and_pullbacks_pushouts. UniMath-20231010/UniMath/CategoryTheory/SimplicialSets.v000066400000000000000000000053671451125700300227530ustar00rootroot00000000000000(** * Homotopy theory of simplicial sets. Vladimir Voevodsky started on Nov. 22, 2014 (with Alexander Vishik) *) (* Preamble *) Require Import UniMath.MoreFoundations.Tactics. Require Export UniMath.Combinatorics.FiniteSets. (* Require Export UniMath.Combinatorics.OrderedSets. *) Require Export UniMath.CategoryTheory.Core.Categories. Require Export UniMath.CategoryTheory.Core.Functors. Require Export UniMath.CategoryTheory.FunctorCategory. Require Export UniMath.CategoryTheory.categories.HSET.Core. Require Export UniMath.CategoryTheory.categories.HSET.Univalence. Require Export UniMath.CategoryTheory.opp_precat. (* To upstream files *) (* The pre-category data for the category Delta *) Local Open Scope stn. Definition monfunstn ( n m : nat ) : UU := ∑ f : ⟦ n ⟧ -> ⟦ m ⟧, ∏ (x y: ⟦n⟧), x ≤ y -> f x ≤ f y. Definition make_monfunstn { m n : nat } f is := (f,,is) : monfunstn m n. Definition monfunstnpr1 {n m : nat} : monfunstn n m -> ⟦ n ⟧ -> ⟦ m ⟧ := pr1. Lemma monfunstnpr1_isInjective {m n} (f g : monfunstn m n) : monfunstnpr1 f = monfunstnpr1 g -> f = g. Proof. intros e. apply subtypePath. { intros h. apply impred; intro i. apply impred; intro j. apply impred; intro l. apply propproperty. } exact e. Defined. Coercion monfunstnpr1 : monfunstn >-> Funclass . Lemma isasetmonfunstn n m : isaset ( monfunstn n m ) . Proof. intros . apply ( isofhleveltotal2 2 ) . { apply impred. intro t. apply isasetstn. } intro f. apply impred; intro i. apply impred; intro j. apply impred; intro l. apply isasetaprop, propproperty. Defined. Definition monfunstnid n : monfunstn n n := make_monfunstn (idfun _) (λ x y is, is). Definition monfunstncomp { n m k : nat } ( f : monfunstn n m ) ( g : monfunstn m k ) : monfunstn n k . Proof. intros . exists ( g ∘ f ) . intros i j l. unfold funcomp. apply ( pr2 g ). apply ( pr2 f ) . assumption. Defined. Definition precatDelta : precategory . Proof. use tpair. { use tpair. { exists nat. intros m n. exact (monfunstn (S m) (S n)). } { split. { intros m. apply monfunstnid. } { intros l m n f g. exact (monfunstncomp f g). } } } apply is_precategory_one_assoc_to_two. simpl. split. { simpl. split. { intros m n f. now apply monfunstnpr1_isInjective. } { intros m n f. now apply monfunstnpr1_isInjective. } } { simpl. intros m n o p f g h. now apply monfunstnpr1_isInjective. } Defined. Local Open Scope cat. Definition has_homsets_precatDelta : has_homsets precatDelta. Proof. intros a b. cbn. apply isasetmonfunstn. Qed. Definition catDelta : category := make_category precatDelta has_homsets_precatDelta. Definition sSet := functor_category catDelta^op category_HSET. (* V.V. with Sasha Vishik, Nov. 23, 2014 *) (* End of file *) UniMath-20231010/UniMath/CategoryTheory/SkewMonoidal/000077500000000000000000000000001451125700300222205ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/SkewMonoidal/CategoriesOfMonoids.v000066400000000000000000000127071451125700300263210ustar00rootroot00000000000000(** Categories of skew monoids for skew monoidal categories Ambroise LAFONT 2020 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.SkewMonoidal.SkewMonoidalCategories. Local Open Scope cat. Section Precategory_of_SkewMonoids. Context (V : skewmonoidal_category). Notation tensor := (skewmonoidal_tensor V). Notation I := (skewmonoidal_I V). Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Notation "( c , d )" := (make_catbinprod c d). Notation "( f #, g )" := (catbinprodmor f g). Notation "X ⊗ Y" := (tensor (X , Y)). Notation "f #⊗ g" := (functor_on_morphisms (functor_data_from_functor _ _ tensor) (f #, g)) (at level 31). Notation α' := (skewmonoidal_assoc (data_from_skewmonoidal V)). Notation λ' := (skewmonoidal_unitl (data_from_skewmonoidal V)). Notation ρ' := (skewmonoidal_unitr (data_from_skewmonoidal V)). Definition skewMonoid_data : UU := ∑ X : V, (X ⊗ X --> X) × (I --> X). Coercion sm_ob (X : skewMonoid_data) : V := pr1 X. Definition sm_unit (X : skewMonoid_data) : I --> X := pr2 (pr2 X). Definition sm_mult (X : skewMonoid_data) : X ⊗ X --> X := pr1 (pr2 X). Local Notation η := sm_unit. Local Notation μ := sm_mult. Definition skewMonoid_laws (X : skewMonoid_data) : UU := (μ X #⊗ identity X · μ X = α' X X X · identity X #⊗ μ X · μ X) × (* Pentagon diagram *) (η X #⊗ identity X · μ X = λ' X) × (ρ' X · identity X #⊗ η X · μ X = identity _). (* Unitor diagrams *) Definition skewMonoid : UU := ∑ (X : skewMonoid_data), skewMonoid_laws X. Coercion skewMonoid_to_data (X : skewMonoid) : skewMonoid_data := pr1 X. Definition skewMonoid_pentagon (X : skewMonoid) : μ X #⊗ identity X · μ X = α' X X X · identity X #⊗ μ X · μ X := pr1 (pr2 X). Definition skewMonoid_unitl (X : skewMonoid) : ( η X #⊗ identity X · μ X = λ' X) := pr1 (pr2 (pr2 X)). Definition skewMonoid_unitr (X : skewMonoid) : ( ρ' X · identity X #⊗ η X · μ X = identity _) := pr2 (pr2 (pr2 X)). Definition skewMonoid_Mor_laws {T T' : skewMonoid_data} (α : V ⟦T , T'⟧) : UU := (μ T · α = α #⊗ α · μ T') × η T · α = η T'. Lemma isaprop_skewMonoid_Mor_laws (T T' : skewMonoid_data ) (α : V ⟦ T , T' ⟧) : isaprop (skewMonoid_Mor_laws α). Proof. apply isapropdirprod; apply homset_property. Qed. Definition skewMonoid_Mor (T T' : skewMonoid_data) : UU := ∑ α , @skewMonoid_Mor_laws T T' α. Coercion mor_from_monoid_mor (T T' : skewMonoid_data) (s : skewMonoid_Mor T T') : V ⟦ T , T' ⟧ := pr1 s. Definition skewMonoid_Mor_η {T T' : skewMonoid_data } (α : skewMonoid_Mor T T') : η T · α = η T' := pr2 (pr2 α). Definition skewMonoid_Mor_μ {T T' : skewMonoid_data } (α : skewMonoid_Mor T T') : μ T · α = α #⊗ α · μ T' := pr1 (pr2 α). Lemma skewMonoid_identity_laws (T : skewMonoid_data ) : skewMonoid_Mor_laws (identity T). Proof. split; simpl. - rewrite id_right. etrans;[apply pathsinv0, id_left|]. apply cancel_postcomposition. apply pathsinv0. apply (functor_id tensor). - apply id_right. Qed. Definition skewMonoid_identity (T : skewMonoid_data) : skewMonoid_Mor T T := tpair _ _ (skewMonoid_identity_laws T). Lemma skewMonoid_composition_laws {T T' T'' : skewMonoid_data } (α : skewMonoid_Mor T T') (α' : skewMonoid_Mor T' T'') : skewMonoid_Mor_laws (α · α'). Proof. split; intros; simpl. - rewrite assoc. set (H:=skewMonoid_Mor_μ α ); simpl in H. rewrite H; clear H; rewrite <- !assoc. set (H:=skewMonoid_Mor_μ α' ); simpl in H. etrans;[apply cancel_precomposition,H|]. clear H. etrans;[apply assoc|]. apply cancel_postcomposition. apply pathsinv0. apply (functor_comp tensor (_ #, _) (_ #, _)). - rewrite assoc. eapply pathscomp0; [apply cancel_postcomposition, skewMonoid_Mor_η|]. apply skewMonoid_Mor_η. Qed. Definition skewMonoid_composition {T T' T'' : skewMonoid_data } (α : skewMonoid_Mor T T') (α' : skewMonoid_Mor T' T'') : skewMonoid_Mor T T'' := tpair _ _ (skewMonoid_composition_laws α α'). Definition skewMonoid_Mor_equiv {T T' : skewMonoid_data } (α β : skewMonoid_Mor T T') : α = β ≃ (pr1 α = pr1 β). Proof. apply subtypeInjectivity; intro a. apply isaprop_skewMonoid_Mor_laws. Defined. Definition precategory_skewMonoid_ob_mor : precategory_ob_mor := make_precategory_ob_mor skewMonoid (λ T T' : skewMonoid , skewMonoid_Mor T T'). Definition precategory_skewMonoid_data : precategory_data. Proof. exists (precategory_skewMonoid_ob_mor). exists (fun (T : skewMonoid) => skewMonoid_identity T). exact (fun (A B C : skewMonoid) => @skewMonoid_composition A B C ). Defined. Lemma precategory_skewMonoid_axioms : is_precategory precategory_skewMonoid_data. Proof. repeat split; simpl; intros. - apply (invmap (skewMonoid_Mor_equiv _ _ )). apply id_left. - apply (invmap (skewMonoid_Mor_equiv _ _ )). apply id_right. - apply (invmap (skewMonoid_Mor_equiv _ _ )). apply assoc. - apply (invmap (skewMonoid_Mor_equiv _ _ )). apply assoc'. Qed. Definition precategory_skewMonoid : precategory := tpair _ _ precategory_skewMonoid_axioms. End Precategory_of_SkewMonoids. UniMath-20231010/UniMath/CategoryTheory/SkewMonoidal/SkewMonoidalCategories.v000066400000000000000000000130101451125700300270040ustar00rootroot00000000000000(** Skew-Monoidal categories Ambroise LAFONT 2020 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Local Notation "'id' X" := (identity X) (at level 30). Local Notation "C ⊠ D" := (category_binproduct C D) (at level 38). Local Notation "( c , d )" := (make_catbinprod c d). Local Notation "( f #, g )" := (catbinprodmor f g). Local Notation φ₁ := (functor_fix_fst_arg _ _ _). Local Notation φ₂ := (functor_fix_snd_arg _ _ _). Local Declare Scope functor_scope. Local Infix "×" := pair_functor : functor_scope . Delimit Scope functor_scope with F. Definition skewmonoidal_data : UU := ∑ (V : category)(tensor : V ⊠ V ⟶ V) (I : V), (* left unitor *) φ₁ tensor I ⟹ functor_identity V × (* right unitor *) functor_identity V ⟹ φ₂ tensor I × (* associator *) (tensor × (functor_identity _))%F ∙ tensor ⟹ (precategory_binproduct_unassoc _ _ _) ∙ (functor_identity V × tensor)%F ∙ tensor . Coercion cat_from_skewmonoidal (V : skewmonoidal_data) : category := pr1 V. Definition skewmonoidal_tensor (V : skewmonoidal_data) : V ⊠ V ⟶ V := pr1 (pr2 V). Definition skewmonoidal_I (V : skewmonoidal_data) : V := pr1 (pr2 (pr2 V)). Local Notation tensor := (skewmonoidal_tensor _). Local Notation I := (skewmonoidal_I _). Local Notation "X ⊗ Y" := (tensor (X, Y)). Notation "f #⊗ g" := (functor_on_morphisms (functor_data_from_functor _ _ tensor) (f #, g)) (at level 31). Local Notation nts := (pr2 (pr2 (_ : skewmonoidal_data))) . Definition skewmonoidal_unitl_nt (V : skewmonoidal_data) : φ₁ tensor I ⟹ functor_identity V := pr1 (pr2 nts). Definition skewmonoidal_unitl (V : skewmonoidal_data) (x : V) : I ⊗ x --> x := skewmonoidal_unitl_nt V x. Local Notation λ' := (skewmonoidal_unitl _). Definition skewmonoidal_unitl_ax (V : skewmonoidal_data) {x y : V} (f : x --> y) : (identity I) #⊗ f · λ' y = λ' x · f := nat_trans_ax (skewmonoidal_unitl_nt V) _ _ f. Definition skewmonoidal_unitr_nt (V : skewmonoidal_data) : functor_identity V ⟹ φ₂ tensor I := pr1 (pr2 (pr2 nts)). Definition skewmonoidal_unitr (V : skewmonoidal_data) (x : V) : x --> x ⊗ I := skewmonoidal_unitr_nt V x. Local Notation ρ' := (skewmonoidal_unitr _). Definition skewmonoidal_unitr_ax (V : skewmonoidal_data) {x y : V} (f : x --> y) : f · ρ' y = ρ' x · f #⊗ identity I := nat_trans_ax (skewmonoidal_unitr_nt V) _ _ f. Definition skewmonoidal_assoc_nt (V : skewmonoidal_data) : (tensor × (functor_identity _))%F ∙ tensor ⟹ (precategory_binproduct_unassoc _ _ _) ∙ (functor_identity V × tensor)%F ∙ tensor := pr2 (pr2 (pr2 nts)). Definition skewmonoidal_assoc (V : skewmonoidal_data) (x y z : V) : x ⊗ y ⊗ z --> x ⊗ (y ⊗ z) := skewmonoidal_assoc_nt V ((x , y) , z). Local Notation α' := (skewmonoidal_assoc _). Definition skewmonoidal_assoc_ax (V : skewmonoidal_data) {x x' y y' z z' : V} (f : x --> x')(g : y --> y')(h : z --> z') : ((f #⊗ g) #⊗ h) · α' x' y' z' = α' x y z · (f #⊗ (g #⊗ h)) := nat_trans_ax (skewmonoidal_assoc_nt V) _ _ ((f #, g) #, h). Definition skewmonoidal_category : UU := ∑ (V : skewmonoidal_data), ρ' I · λ' I = identity (C := V) I × (∏ (a b : V), ρ' a #⊗ id b · α' a I b · id a #⊗ λ' b = id (a ⊗ b)) × (∏ (a b : V), α' I a b · λ' (a ⊗ b) = λ' a #⊗ id b) × (∏ (a b : V), ρ' (a⊗b) · α' a b I = id a #⊗ ρ' b) × (∏ (a b c d : V), α' (a ⊗ b) c d · α' a b (c ⊗ d) = α' a b c #⊗ id d · α' a (b ⊗ c) d · id a #⊗ α' b c d). Coercion data_from_skewmonoidal (V : skewmonoidal_category) : skewmonoidal_data := pr1 V. Local Notation eq := (pr2 (_ : skewmonoidal_category)). Definition skewmonoidal_rho_lambda_eq (V : skewmonoidal_category) : ρ' I · λ' I = identity (C := V) I := pr1 eq. Definition skewmonoidal_triangle_eq (V : skewmonoidal_category) : ∏ (a b : V), ρ' a #⊗ id b · α' a I b · id a #⊗ λ' b = id (a ⊗ b) := pr1 (pr2 eq). Definition skewmonoidal_alpha_lambda_eq (V : skewmonoidal_category) : ∏ (a b : V), α' I a b · λ' (a ⊗ b) = λ' a #⊗ id b := pr1 (pr2 (pr2 eq)). Definition skewmonoidal_rho_alpha_eq (V : skewmonoidal_category) : ∏ (a b : V), ρ' (a⊗b) · α' a b I = id a #⊗ ρ' b := pr1 (pr2 (pr2 (pr2 eq))). Definition skewmonoidal_pentagon_eq (V : skewmonoidal_category) : ∏ (a b c d : V), α' (a ⊗ b) c d · α' a b (c ⊗ d) = α' a b c #⊗ id d · α' a (b ⊗ c) d · id a #⊗ α' b c d := (pr2 (pr2 (pr2 (pr2 eq)))). Lemma I_mult_laws (V : skewmonoidal_category) (X : V) : α' I I X · identity (C := V) I #⊗ λ' X · λ' X = λ' I #⊗ identity X · λ' X. Proof. etrans. { etrans;[apply pathsinv0,assoc|]. apply cancel_precomposition. apply skewmonoidal_unitl_ax. } rewrite assoc. apply cancel_postcomposition. apply skewmonoidal_alpha_lambda_eq. Qed. UniMath-20231010/UniMath/CategoryTheory/SplitMonicsAndEpis.v000066400000000000000000000214011451125700300235210ustar00rootroot00000000000000(** * Split monics, split epis *) (** ** Contents - Split monics - Split epis *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Local Open Scope cat. (** ** Split monomorphisms *) (** The naïve translation of the definition of split monomorphisms into type theory is stronger than the classical definition. However, we can recover the classical definition using truncation ([is_merely_split_monic]). We explore both definitions below. *) Section SplitMonic. Context {C : category} {A B : ob C}. (** A choice of a section for the given morphism *) Definition is_split_monic (m : A --> B) : UU := ∑ r : B --> A, is_retraction m r. Definition split_monic : UU := ∑ m : A --> B, is_split_monic m. Lemma split_monic_is_monic (m : A --> B) : is_split_monic m -> isMonic m. Proof. intros is_split. apply (isMonic_postcomp _ m (pr1 is_split)). apply (transportf _ (!pr2 is_split)). apply identity_isMonic. Qed. (** We provide a coercion to [Monic C A B], rather than [A --> B], as it is more generally useful ([Monic C A B] coerces to [A --> B]). *) Definition split_monic_to_monic (m : split_monic) : Monic C A B. Proof. use make_Monic. - exact (pr1 m). - abstract (apply split_monic_is_monic; exact (pr2 m)). Defined. Coercion split_monic_to_monic : split_monic >-> Monic. (** The chosen section is not necessarily unique *) Lemma isaset_is_split_monic (m : A --> B) : has_homsets C -> isaset (is_split_monic m). Proof. intro; apply isaset_total2; [auto|]. intros. apply hlevelntosn; apply isaprop_is_retraction. assumption. Qed. (** Now, for the "more classical" definition *) Definition is_merely_split_monic (m : A --> B) : hProp. Proof. use make_hProp. - exact (∥ ∑ r : B --> A, is_retraction m r ∥). - apply isapropishinh. Defined. Definition merely_split_monic : UU := ∑ m : A --> B, is_merely_split_monic m. (** Since coercing this to a [Monic] requires an extra hypothesis (that [C]) has homsets, we just coerce to an arrow instead. *) Definition merely_split_monic_to_morphism (m : merely_split_monic) : A --> B := pr1 m. Coercion merely_split_monic_to_morphism : merely_split_monic >-> precategory_morphisms. Lemma isaset_merely_split_monic (m : A --> B) : has_homsets C -> isaset merely_split_monic. Proof. intro. apply isaset_total2; [auto|]. intro; apply hlevelntosn, propproperty. Qed. (** For the purposes of proving a proposition, we can assume a merely split monic has a chosen section. *) Lemma merely_split_monic_to_split_monic {X : UU} (m : A --> B) : isaprop X -> (is_split_monic m -> X) -> is_merely_split_monic m -> X. Proof. intros isx impl mere. refine (factor_through_squash isx _ mere). assumption. Qed. (** Note that this requires that [C] has homsets, in contrast to the above statement for "non-mere" monics. *) Lemma merely_split_monic_is_monic (m : A --> B) : has_homsets C -> is_merely_split_monic m -> isMonic m. Proof. intros H. apply merely_split_monic_to_split_monic. - apply isapropisMonic; auto. - apply split_monic_is_monic. Qed. Definition merely_split_monic_to_monic {hsC : has_homsets C} : merely_split_monic -> Monic C A B. Proof. intros m. use make_Monic. - exact (pr1 m). - abstract (apply merely_split_monic_is_monic; [auto|]; exact (pr2 m)). Qed. (** Equivalent definitions *) (** For the truncated version, this is an equivalence (see below). However, in general, choosing a section is stronger. *) Lemma is_split_monic_to_precomp_is_surjection (m : A --> B) : is_split_monic m -> ∏ c : ob C, issurjective (@precomp_with _ _ _ m c). Proof. intros is_split c f. apply hinhpr. unfold hfiber, precomp_with. exists (pr1 is_split · f). refine (assoc _ _ _ @ _). refine (maponpaths (fun z => z · _) (pr2 is_split) @ _). apply id_left. Qed. Lemma is_merely_split_monic_weq_precomp_is_surjection (m : A --> B) : is_merely_split_monic m <-> ∏ c : ob C, issurjective (@precomp_with _ _ _ m c). Proof. unfold is_split_monic. split. - intros is_split ?. apply (merely_split_monic_to_split_monic m). + apply isapropissurjective. + intro; apply is_split_monic_to_precomp_is_surjection. assumption. + assumption. - intros is_surjective. specialize (is_surjective _ (identity _)). refine (factor_through_squash _ _ is_surjective). + apply propproperty. + intro fib. apply hinhpr. exists (pr1 fib). apply (pr2 fib). Qed. End SplitMonic. Arguments split_monic {_} _ _. Arguments merely_split_monic {_} _ _. (** Functors preserve merely split monomorphisms *) Lemma functor_preserves_merely_split_monic {C D : category} (F : functor C D) {A B : ob C} (f : C⟦A,B⟧) : is_merely_split_monic f -> is_merely_split_monic (# F f). Proof. apply hinhfun. intro hf. exists (#F (pr1 hf)). unfold is_retraction. now rewrite <- functor_id, <- (pr2 hf), <- functor_comp. Qed. (** Functors preserve split monomorphisms *) Lemma functor_preserves_split_monic {C D : category} (F : functor C D) {A B : ob C} (f : C⟦A,B⟧) : is_split_monic f -> is_split_monic (# F f). Proof. intro hf. exists (#F (pr1 hf)). unfold is_retraction. now rewrite <- functor_id, <- (pr2 hf), <- functor_comp. Qed. (** An epic split monic is an iso. *) Lemma merely_split_monic_is_epi_to_is_z_iso {C : category} {A B : ob C} (m : A --> B) : is_merely_split_monic m -> isEpi m -> is_z_isomorphism m. Proof. intros is_monic is_epi. apply is_z_iso_from_is_iso. (* such an operation should rather be avoided *) intro c. apply isweqinclandsurj. - apply precomp_with_epi_isincl; assumption. - apply is_merely_split_monic_weq_precomp_is_surjection. assumption. Qed. (** Definition of a split epimorphism. It is a morphism f such that there exists a morphism g that satisfies f ∘ g = id *) Section SplitEpis. Context {C : precategory} {A B : ob C}. (** An epi with a chosen retraction *) Definition is_split_epi (f : C⟦A,B⟧) := ∑ (g : C⟦B,A⟧), is_retraction g f. Definition split_epi : UU := ∑ f : A --> B, is_split_epi f. Lemma split_epi_is_epi (f : A --> B) : is_split_epi f -> isEpi f. Proof. intros is_split. apply (isEpi_precomp _ (pr1 is_split) f). apply (transportf _ (!pr2 is_split)). apply identity_isEpi. Qed. Definition split_epi_to_epi (f : split_epi) : Epi C A B. Proof. use make_Epi. - exact (pr1 f). - abstract (apply split_epi_is_epi; exact (pr2 f)). Defined. Definition is_merely_split_epi (f : A --> B) := ∥ ∑ (g : C⟦B,A⟧), g · f = identity B ∥. Definition merely_split_epi : UU := ∑ (f : A --> B), is_merely_split_epi f. Lemma isaset_merely_split_epi : has_homsets C -> isaset merely_split_epi. Proof. intro. apply isaset_total2; [auto|]. intro. apply hlevelntosn, isapropishinh. Qed. (** For the purposes of proving a proposition, we can assume a merely split epi has a chosen retraction. *) Lemma merely_split_epi_to_split_epi {X : UU} (m : A --> B) : isaprop X -> (is_split_epi m -> X) -> is_merely_split_epi m -> X. Proof. intros isx impl mere. refine (factor_through_squash isx _ mere). assumption. Qed. Lemma merely_split_epi_is_epi (f : A --> B) : has_homsets C -> is_merely_split_epi f -> isEpi f. Proof. intros H. apply merely_split_epi_to_split_epi. - apply isapropisEpi; auto. - apply split_epi_is_epi. Qed. End SplitEpis. (** Functors preserve merely split epimorphisms *) Lemma functor_preserves_merely_split_epi {C D : precategory} (F : functor C D) {A B : ob C} (f : C⟦A,B⟧) : is_merely_split_epi f -> is_merely_split_epi (# F f). Proof. apply hinhfun. intro hf. exists (#F (pr1 hf)). now rewrite <-functor_id,<- (pr2 hf), <- functor_comp. Qed. (** Functors preserve split epimorphisms *) Lemma functor_preserves_split_epi {C D : precategory} (F : functor C D) {A B : ob C} (f : C⟦A,B⟧) : is_split_epi f -> is_split_epi (# F f). Proof. intro hf. exists (#F (pr1 hf)). unfold is_retraction. now rewrite <- functor_id, <- (pr2 hf), <- functor_comp. Qed. Definition epis_are_split (C : precategory) := ∏ (A B : C) (f : C⟦A,B⟧), isEpi f -> is_merely_split_epi f. Arguments split_epi {_} _ _. Arguments merely_split_epi {_} _ _. UniMath-20231010/UniMath/CategoryTheory/Subcategory/000077500000000000000000000000001451125700300221135ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/Subcategory/Core.v000066400000000000000000000221111451125700300231670ustar00rootroot00000000000000(** ** Sub(pre)categories Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) Reorganized and expanded: Langston Barrett (@siddharthist) (March 2018) *) (** ** Contents : - Subprecategories - A sub-precategory forms a precategory ([carrier_of_sub_precategory]) - (Inclusion) functor from a sub-precategory to the ambient precategory ([sub_precategory_inclusion]) - Subcategories ([subcategory]) - Restriction of a functor to a subcategory *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. (** ** Definitions *) (** A sub-precategory is specified through a predicate on objects and a dependent predicate on morphisms which is compatible with identity and composition *) Definition is_sub_precategory {C : category} (C' : hsubtype C) (Cmor' : ∏ a b : C, hsubtype (a --> b)) := (∏ a : C, C' a -> Cmor' _ _ (identity a)) × (∏ (a b c : C) (f: a --> b) (g : b --> c), Cmor' _ _ f -> Cmor' _ _ g -> Cmor' _ _ (f · g)). Definition sub_precategories (C : category) := total2 (fun C' : (hsubtype (ob C)) × (∏ a b:ob C, hsubtype (a --> b)) => is_sub_precategory (pr1 C') (pr2 C')). (** We have a coercion [carrier] turning every predicate [P] on a type [A] into the total space [ { a : A & P a} ]. For later, we define some projections with the appropriate type, also to avoid confusion with the aforementioned coercion. *) Definition sub_precategory_predicate_objects {C : category} (C': sub_precategories C): hsubtype (ob C) := pr1 (pr1 C'). Definition sub_ob {C : category}(C': sub_precategories C): UU := (*carrier*) (sub_precategory_predicate_objects C'). Definition sub_precategory_predicate_morphisms {C : category} (C':sub_precategories C) (a b : C) : hsubtype (a --> b) := pr2 (pr1 C') a b. Definition sub_precategory_morphisms {C : category}(C':sub_precategories C) (a b : C) : UU := sub_precategory_predicate_morphisms C' a b. (** Projections for compatibility of the predicate with identity and composition. *) Definition sub_precategory_id (C : category) (C':sub_precategories C) : ∏ a : ob C, sub_precategory_predicate_objects C' a -> sub_precategory_predicate_morphisms C' _ _ (identity a) := dirprod_pr1 (pr2 C'). Definition sub_precategory_comp (C : category) (C':sub_precategories C) : ∏ (a b c: ob C) (f: a --> b) (g : b --> c), sub_precategory_predicate_morphisms C' _ _ f -> sub_precategory_predicate_morphisms C' _ _ g -> sub_precategory_predicate_morphisms C' _ _ (f · g) := dirprod_pr2 (pr2 C'). (** An object of a subprecategory is an object of the original precategory. *) Definition precategory_object_from_sub_precategory_object (C:category) (C':sub_precategories C) (a : sub_ob C') : ob C := pr1 a. Coercion precategory_object_from_sub_precategory_object : sub_ob >-> ob. (** A morphism of a subprecategory is also a morphism of the original precategory. *) Definition precategory_morphism_from_sub_precategory_morphism (C:category) (C':sub_precategories C) (a b : ob C) (f : sub_precategory_morphisms C' a b) : a --> b := pr1 f . Coercion precategory_morphism_from_sub_precategory_morphism : sub_precategory_morphisms >-> precategory_morphisms. (** *** A sub-precategory forms a precategory. *) Definition sub_precategory_ob_mor (C : category)(C':sub_precategories C) : precategory_ob_mor. Proof. exists (sub_ob C'). exact (λ a b, @sub_precategory_morphisms _ C' a b). Defined. (* Coercion sub_precategory_ob_mor : sub_precategories >-> precategory_ob_mor. *) Definition sub_precategory_data (C : category)(C':sub_precategories C) : precategory_data. Proof. exists (sub_precategory_ob_mor C C'). split. intro c. exists (identity (C:=C) (pr1 c)). apply sub_precategory_id. apply (pr2 c). intros a b c f g. exists (compose (pr1 f) (pr1 g)). apply sub_precategory_comp. apply (pr2 f). apply (pr2 g). Defined. (** A useful lemma for equality in the sub-precategory. *) Lemma eq_in_sub_precategory (C : category)(C':sub_precategories C) (a b : sub_ob C') (f g : sub_precategory_morphisms C' a b) : pr1 f = pr1 g -> f = g. Proof. intro H. apply (total2_paths_f H). apply proofirrelevance. apply pr2. Qed. (* Lemma eq_in_sub_precategory2 (C : precategory)(C':sub_precategories C) (a b : sub_ob C') (f g : a --> b) (pf : sub_precategory_predicate_morphisms C' _ _ f) (pg : sub_precategory_predicate_morphisms C' _ _ g): f = g -> (tpair (λ f, sub_precategory_predicate_morphisms _ _ _ f) f pf) = (tpair (λ f, sub_precategory_predicate_morphisms _ _ _ f) g pg). Proof. intro H. apply (two_arg_paths_f H). destruct H. apply (two_arg_paths_f (idpath _ )). *) Definition is_precategory_sub_precategory (C : category)(C':sub_precategories C) : is_precategory (sub_precategory_data C C'). Proof. repeat split; simpl; intros. unfold sub_precategory_comp; apply eq_in_sub_precategory; simpl; apply id_left. apply eq_in_sub_precategory. simpl. apply id_right. apply eq_in_sub_precategory. cbn. apply assoc. apply eq_in_sub_precategory. cbn. apply assoc'. Defined. Definition carrier_of_sub_precategory (C : category)(C':sub_precategories C) : precategory := tpair _ _ (is_precategory_sub_precategory C C'). Definition has_homsets_carrier_of_subcategory (C : category) (C' : sub_precategories C) : has_homsets (carrier_of_sub_precategory C C'). Proof. intros a b. cbn. apply (isofhleveltotal2 2). - apply C. - intro f. apply hlevelntosn. apply propproperty. Qed. Definition carrier_of_sub_category (C : category) (C' : sub_precategories C) : category := make_category _ (has_homsets_carrier_of_subcategory C C'). Coercion carrier_of_sub_category : sub_precategories >-> category. (** An object satisfying the predicate is an object of the subprecategory *) Definition precategory_object_in_subcat {C : category} {C':sub_precategories C} (a : ob C) (p : sub_precategory_predicate_objects C' a) : ob C' := tpair _ a p. (** A morphism satisfying the predicate is a morphism of the subprecategory *) Definition precategory_morphisms_in_subcat {C : category} {C':sub_precategories C} {a b : ob C'}(f : pr1 a --> pr1 b) (p : sub_precategory_predicate_morphisms C' (pr1 a) (pr1 b) (f)) : precategory_morphisms (C:=C') a b := tpair _ f p. (** A (z-)isomorphism of a subprecategory is also a (z-)isomorphism of the original precategory. *) Lemma is_z_iso_from_is_z_iso_in_subcategory (C:category) (C':sub_precategories C) (a b : C') (f : C'⟦ a , b ⟧) (H: is_z_isomorphism f) : is_z_isomorphism (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f). Proof. induction H as (g,(gl,gr)). induction g as (g_und,?). use make_is_z_isomorphism. + exact g_und. + split. - exact (maponpaths pr1 gl). - exact (maponpaths pr1 gr). Defined. (** *** (Inclusion) functor from a sub-precategory to the ambient precategory *) Definition sub_precategory_inclusion_data (C : category) (C':sub_precategories C): functor_data C' C. Proof. exists (@pr1 _ _ ). intros a b. exact (@pr1 _ _ ). Defined. Definition is_functor_sub_precategory_inclusion (C : category) (C':sub_precategories C) : is_functor (sub_precategory_inclusion_data C C'). Proof. split; simpl. unfold functor_idax . intros. apply (idpath _ ). unfold functor_compax . intros. apply (idpath _ ). Qed. Definition sub_precategory_inclusion (C : category) (C' : sub_precategories C) : functor C' C := tpair _ _ (is_functor_sub_precategory_inclusion C C'). (** ** Subcategories *) (** The hom-types of a subprecategory are sets if the hom-types of the original category are. *) Lemma is_set_sub_precategory_morphisms {C : category} (C' : sub_precategories C) (a b : ob C) : isaset (sub_precategory_morphisms C' a b). Proof. apply isofhlevel_hsubtype, C. Defined. Definition sub_precategory_morphisms_set {C : category} (C':sub_precategories C) (a b : ob C) : hSet := tpair _ (sub_precategory_morphisms C' a b) (is_set_sub_precategory_morphisms C' a b). Definition subcategory (C : category) (C' : sub_precategories C) : category. Proof. use make_category. - exact (carrier_of_sub_precategory C C'). - intros ? ?. apply is_set_sub_precategory_morphisms. Defined. (** ** Restriction of a functor to a subcategory *) Definition restrict_functor_to_sub_precategory {C D : category} (C' : sub_precategories C) (F : functor C D) : functor C' D. Proof. use make_functor. - use make_functor_data. + exact (F ∘ precategory_object_from_sub_precategory_object _ C')%functions. + intros ? ?. apply (# F ∘ precategory_morphism_from_sub_precategory_morphism _ C' _ _)%functions. - use make_dirprod. + intro; apply (functor_id F). + intros ? ? ? ? ?; apply (functor_comp F). Defined. UniMath-20231010/UniMath/CategoryTheory/Subcategory/Full.v000066400000000000000000000403671451125700300232160ustar00rootroot00000000000000(** ** Full sub(pre)categories Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013) Reorganized: Langston Barrett (@siddharthist) (March 2018) *) (** ** Contents Image of a functor, full subcat specified by a functor The inclusion of a full subcategory is fully faithful Fullness Faithfulness Subcategories, back to Inclusion functor Full image of a functor Factorization of a functor via its full image This factorization is fully faithful if the functor is [functor_full_img_fully_faithful_if_fun_is] Isos in full subcategory are equiv to isos in the precategory Full subcategory of a univalent_category is a univalent_category [is_univalent_full_sub_category] *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Local Open Scope cat. (** A full subcategory has the true predicate on morphisms *) Lemma is_sub_precategory_full (C : category) (C':hsubtype (ob C)) : is_sub_precategory C' (λ a b, λ f, htrue). Proof. split; intros; exact tt. Defined. Definition full_sub_precategory {C : category} (C': hsubtype (ob C)) : sub_precategories C := tpair _ (make_dirprod C' (λ a b f, htrue)) (is_sub_precategory_full C C'). (** Any morphism between appropriate objects is a morphism of the full subprecategory *) Definition morphism_in_full_subcat {C : category} {C' : hsubtype (ob C)} {a b : ob (full_sub_precategory C')} (f : pr1 a --> pr1 b) : precategory_morphisms a b := precategory_morphisms_in_subcat f tt. Lemma has_homsets_full_sub_precategory (C : category) (C':hsubtype (ob C)) : has_homsets (full_sub_precategory C'). Proof. intros H x y. apply is_set_sub_precategory_morphisms. Qed. Definition full_sub_category (C : category) (C':hsubtype (ob C)) : category := make_category _ (has_homsets_full_sub_precategory C C'). Definition full_sub_category_pr_data {C : category} (C': hsubtype (ob C)) : functor_data (full_sub_category C C') C. Proof. use make_functor_data. - exact (λ h, pr1 h). - exact (λ h₁ h₂ α, pr1 α). Defined. Definition full_sub_category_pr_is_functor {C : category} (C': hsubtype (ob C)) : is_functor (full_sub_category_pr_data C'). Proof. split. - intro x ; cbn. apply idpath. - intros x y z f g ; cbn. apply idpath. Qed. Definition full_sub_category_pr {C : category} (C': hsubtype (ob C)) : full_sub_category C C' ⟶ C. Proof. use make_functor. - exact (full_sub_category_pr_data C'). - exact (full_sub_category_pr_is_functor C'). Defined. (** ** The inclusion of a full subcategory is fully faithful *) Section FullyFaithful. Context (C : category) (C' : hsubtype (ob C)). (** *** Fullness *) Lemma full_sub_precategory_inclusion : full (sub_precategory_inclusion C (full_sub_precategory C')). Proof. intros a b f. apply hinhpr. unfold hfiber. exists (f,, tt). reflexivity. Defined. (** *** Faithfulness *) Lemma faithful_sub_precategory_inclusion : faithful (sub_precategory_inclusion C (full_sub_precategory C')). Proof. intros a b; cbn. apply isinclpr1. intro; apply isapropunit. Defined. Lemma fully_faithful_sub_precategory_inclusion : fully_faithful (sub_precategory_inclusion C (full_sub_precategory C')). Proof. apply full_and_faithful_implies_fully_faithful. split. - apply full_sub_precategory_inclusion. - apply faithful_sub_precategory_inclusion. Defined. End FullyFaithful. (** ** The (full) image of a functor *) Definition full_img_sub_precategory {C D : category}(F : functor C D) : sub_precategories D := full_sub_precategory (sub_img_functor F). Lemma has_homsets_full_img_sub_precategory {C : category} {D : category} (F : functor C D) : has_homsets (full_img_sub_precategory F). Proof. apply has_homsets_full_sub_precategory. Qed. (** ** Given a functor F : C -> D, we obtain a functor F : C -> Img(F) *) Definition full_img_functor_obj {C D : category}(F : functor C D) : ob C -> ob (full_img_sub_precategory F). Proof. intro c. exists (F c). intros a b. apply b. exists c. apply identity_z_iso. Defined. Definition full_img_functor_data {C D : category}(F : functor C D) : functor_data C (full_img_sub_precategory F). Proof. exists (full_img_functor_obj F). intros a b f. exists (#F f). exact tt. Defined. Lemma is_functor_full_img (C D: category) (F : functor C D) : is_functor (full_img_functor_data F). Proof. split. intro a; simpl. apply subtypePath. intro; apply pr2. apply functor_id. intros a b c f g. set ( H := eq_in_sub_precategory D (full_img_sub_precategory F)). apply (H (full_img_functor_obj F a)(full_img_functor_obj F c)). simpl; apply functor_comp. Qed. Definition functor_full_img {C D: category} (F : functor C D) : functor C (full_img_sub_precategory F) := tpair _ _ (is_functor_full_img C D F). (** *** Morphisms in the full subprecat are equiv to morphisms in the precategory *) (** does of course not need the univalent_category hypothesis *) Definition hom_in_subcat_from_hom_in_precat (C : category) (C' : hsubtype (ob C)) (a b : ob (full_sub_precategory C')) (f : pr1 a --> pr1 b) : a --> b := tpair _ f tt. Definition hom_in_precat_from_hom_in_full_subcat (C : category) (C' : hsubtype (ob C)) (a b : ob (full_sub_precategory C')) : a --> b -> pr1 a --> pr1 b := @pr1 _ _ . Lemma isweq_hom_in_precat_from_hom_in_full_subcat (C : category) (C' : hsubtype (ob C)) (a b : ob (full_sub_precategory C')): isweq (hom_in_precat_from_hom_in_full_subcat _ _ a b). Proof. apply (isweq_iso _ (hom_in_subcat_from_hom_in_precat _ _ a b)). intro f. destruct f. simpl. apply eq_in_sub_precategory. apply idpath. intros. apply idpath. Defined. Lemma isweq_hom_in_subcat_from_hom_in_precat (C : category) (C' : hsubtype (ob C)) (a b : ob (full_sub_precategory C')): isweq (hom_in_subcat_from_hom_in_precat _ _ a b). Proof. apply (isweq_iso _ (hom_in_precat_from_hom_in_full_subcat _ _ a b)). intro f. intros. apply idpath. intro f. destruct f. simpl. apply eq_in_sub_precategory. apply idpath. Defined. Definition weq_hom_in_subcat_from_hom_in_precat (C : category) (C' : hsubtype (ob C)) (a b : ob (full_sub_precategory C')): (pr1 a --> pr1 b) ≃ (a-->b) := tpair _ _ (isweq_hom_in_subcat_from_hom_in_precat C C' a b). Lemma image_is_in_image (C D : precategory) (F : functor C D) (a : ob C): is_in_img_functor F (F a). Proof. apply hinhpr. exists a. apply identity_z_iso. Defined. Lemma functor_full_img_fully_faithful_if_fun_is (C D : category) (F : functor C D) (H : fully_faithful F) : fully_faithful (functor_full_img F). Proof. unfold fully_faithful in *. intros a b. set (H' := weq_hom_in_subcat_from_hom_in_precat). set (H'' := H' D (is_in_img_functor F)). set (Fa := tpair (λ a : ob D, is_in_img_functor F a) (F a) (image_is_in_image _ _ F a)). set (Fb := tpair (λ a : ob D, is_in_img_functor F a) (F b) (image_is_in_image _ _ F b)). set (H3 := (H'' Fa Fb)). assert (H2 : functor_on_morphisms (functor_full_img F) (a:=a) (b:=b) = funcomp (functor_on_morphisms F (a:=a) (b:=b)) ((H3))). apply funextsec. intro f. apply idpath. rewrite H2. apply (twooutof3c #F H3). apply H. apply pr2. Qed. (** *** Image factorization C -> Img(F) -> D *) Local Lemma functor_full_img_factorization_ob (C D: category) (F : functor C D): functor_on_objects F = functor_on_objects (functor_composite (functor_full_img F) (sub_precategory_inclusion D _)). Proof. reflexivity. Defined. (** works up to eta conversion *) (* Lemma functor_full_img_factorization (C D: precategory) (F : functor C D) : F = functor_composite _ _ _ (functor_full_img F) (sub_precategory_inclusion D _). Proof. apply functor_eq. About functor_full_img_factorization_ob. set (H := functor_full_img_factorization_ob C D F). simpl in *. destruct F as [F Fax]. simpl. destruct F as [Fob Fmor]; simpl in *. apply (two_arg_paths_f (H)). unfold functor_full_img_factorization_ob in H. simpl in *. apply dep_funextfun. intro a. apply dep_funextfun. intro b. apply funextfun. intro f. generalize Fmor. clear Fax. assert (H' : Fob = (λ a : ob C, Fob a)). apply H. generalize dependent a . generalize dependent b. clear Fmor. generalize H. clear H. intro H. clear H'. destruct H. tion H. induction H'. induction H'. clear H. *) (** ** Any full subprecategory of a univalent_category is a univalent_category. *) Section full_sub_cat. Variable C : category. Variable C' : hsubtype (ob C). (** *** Isos in the full subcategory are equivalent to isos in the precategory *) Lemma iso_in_subcat_is_iso_in_precat (a b : ob (full_sub_category C C')) (f : z_iso a b): is_z_isomorphism (C:=C) (a:=pr1 a) (b:=pr1 b) (pr1 (pr1 f)). Proof. exists (pr1 (inv_from_z_iso f)). split; simpl. - set (T:=z_iso_inv_after_z_iso f). apply (base_paths _ _ T). - set (T:=z_iso_after_z_iso_inv f). apply (base_paths _ _ T). Defined. Lemma iso_in_precat_is_iso_in_subcat (a b : ob (full_sub_category C C')) (f : z_iso (pr1 a) (pr1 b)) : is_z_isomorphism (C:=full_sub_category C C') (precategory_morphisms_in_subcat f tt). Proof. exists (precategory_morphisms_in_subcat (inv_from_z_iso f) tt). split; simpl. - apply eq_in_sub_precategory; simpl. apply z_iso_inv_after_z_iso. - apply eq_in_sub_precategory; simpl. apply z_iso_after_z_iso_inv. Qed. Definition iso_from_iso_in_sub (a b : ob (full_sub_category C C')) (f : z_iso a b) : z_iso (pr1 a) (pr1 b) := tpair _ _ (iso_in_subcat_is_iso_in_precat a b f). Definition iso_in_sub_from_iso (a b : ob (full_sub_category C C')) (f : z_iso (pr1 a) (pr1 b)) : z_iso a b := tpair _ _ (iso_in_precat_is_iso_in_subcat a b f). Lemma isweq_iso_from_iso_in_sub (a b : ob (full_sub_category C C')): isweq (iso_from_iso_in_sub a b). Proof. apply (isweq_iso _ (iso_in_sub_from_iso a b)). - intro f. apply z_iso_eq; simpl. apply eq_in_sub_precategory, idpath. - intro f; apply z_iso_eq, idpath. Defined. Lemma isweq_iso_in_sub_from_iso (a b : ob (full_sub_category C C')): isweq (iso_in_sub_from_iso a b). Proof. apply (isweq_iso _ (iso_from_iso_in_sub a b)). intro f; apply z_iso_eq, idpath. intro f; apply z_iso_eq; simpl. apply eq_in_sub_precategory, idpath. Defined. (** *** From Identity in the subcategory to isos in the category *) (** This gives a weak equivalence *) Definition Id_in_sub_to_iso (a b : ob (full_sub_category C C')): a = b -> z_iso (pr1 a) (pr1 b) := funcomp (@idtoiso _ a b) (iso_from_iso_in_sub a b). Lemma Id_in_sub_to_iso_equal_iso (a b : ob (full_sub_category C C')) : Id_in_sub_to_iso a b = funcomp (total2_paths_hProp_equiv C' a b) (@idtoiso _ (pr1 a) (pr1 b)). Proof. apply funextfun. intro p. destruct p. apply z_iso_eq. simpl; apply idpath. Qed. Lemma isweq_Id_in_sub_to_iso (a b : ob (full_sub_category C C')) (H : is_univalent C) : isweq (Id_in_sub_to_iso a b). Proof. rewrite Id_in_sub_to_iso_equal_iso. apply (twooutof3c _ idtoiso). apply pr2. apply H. Defined. (** *** Decomp of map from id in the subcat to isos in the subcat via isos in ambient precat *) Lemma precat_paths_in_sub_as_3_maps (a b : ob (full_sub_category C C')): @idtoiso _ a b = funcomp (Id_in_sub_to_iso a b) (iso_in_sub_from_iso a b). Proof. apply funextfun. intro p; destruct p. apply z_iso_eq; simpl. unfold precategory_morphisms_in_subcat. apply eq_in_sub_precategory, idpath. Qed. (** *** The aforementioned decomposed map is a weak equivalence *) Lemma isweq_sub_precat_paths_to_iso (a b : ob (full_sub_category C C')) (H : is_univalent C) : isweq (@idtoiso _ a b). Proof. rewrite precat_paths_in_sub_as_3_maps. match goal with |- isweq (funcomp ?f ?g) => apply (twooutof3c f g) end. - apply isweq_Id_in_sub_to_iso; assumption. - apply isweq_iso_in_sub_from_iso. Defined. (** ** Proof of the targeted theorem: full subcats of cats are cats *) Lemma is_univalent_full_sub_category (H : is_univalent C) : is_univalent (full_sub_category C C'). Proof. unfold is_univalent. intros; apply isweq_sub_precat_paths_to_iso; assumption. Defined. End full_sub_cat. (** The carrier of a subcategory of a univalent category is itself univalent. *) Definition subcategory_univalent (C : univalent_category) (C' : hsubtype (ob C)) : univalent_category. Proof. use make_univalent_category. - exact (subcategory C (full_sub_precategory C')). - apply is_univalent_full_sub_category, univalent_category_is_univalent. Defined. Definition univalent_image {C₁ C₂ : univalent_category} (F : C₁ ⟶ C₂) : univalent_category. Proof. use make_univalent_category. - exact (full_img_sub_precategory F). - use is_univalent_full_sub_category. exact (pr2 C₂). Defined. Lemma functor_full_img_essentially_surjective (A B : category) (F : functor A B) : essentially_surjective (functor_full_img F). Proof. intro b. use (pr2 b). intros [c h] q Hq. apply Hq. exists c. apply iso_in_sub_from_iso. apply h. Qed. (** Commuting triangle for factorization *) Definition full_image_inclusion_commute {C₁ C₂ : category} (F : C₁ ⟶ C₂) : functor_full_img F ∙ sub_precategory_inclusion C₂ (full_img_sub_precategory F) ⟹ F. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition full_image_inclusion_commute_nat_iso {C₁ C₂ : category} (F : C₁ ⟶ C₂) : nat_z_iso (functor_full_img F ∙ sub_precategory_inclusion C₂ (full_img_sub_precategory F)) F. Proof. use make_nat_z_iso. - exact (full_image_inclusion_commute F). - intro. apply identity_is_z_iso. Defined. (** Isos in full subcategory *) Definition is_iso_full_sub {C : category} {P : hsubtype C} {x y : full_sub_category C P} {f : x --> y} (Hf : is_z_isomorphism (pr1 f)) : is_z_isomorphism f. Proof. exists (inv_from_z_iso (_,,Hf) ,, tt). split. + abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; exact (z_iso_inv_after_z_iso (_,,Hf))). + abstract (use subtypePath ; [ intro ; apply isapropunit | ] ; exact (z_iso_after_z_iso_inv (_,,Hf))). Defined. (** Functors between full subcategories *) Definition full_sub_category_functor_data {C₁ C₂ : category} {P : hsubtype C₁} {Q : hsubtype C₂} {F : C₁ ⟶ C₂} (HF : ∏ (x : C₁), P x → Q (F x)) : functor_data (full_sub_category C₁ P) (full_sub_category C₂ Q). Proof. use make_functor_data. - exact (λ x, F (pr1 x) ,, HF (pr1 x) (pr2 x)). - exact (λ x y f, #F (pr1 f) ,, tt). Defined. Definition full_sub_category_is_functor {C₁ C₂ : category} {P : hsubtype C₁} {Q : hsubtype C₂} {F : C₁ ⟶ C₂} (HF : ∏ (x : C₁), P x → Q (F x)) : is_functor (full_sub_category_functor_data HF). Proof. split ; intro ; intros ; cbn ; (use subtypePath ; [ intro ; apply isapropunit | ]). - apply functor_id. - apply functor_comp. Qed. Definition full_sub_category_functor {C₁ C₂ : category} (P : hsubtype C₁) (Q : hsubtype C₂) (F : C₁ ⟶ C₂) (HF : ∏ (x : C₁), P x → Q (F x)) : full_sub_category C₁ P ⟶ full_sub_category C₂ Q. Proof. use make_functor. - exact (full_sub_category_functor_data HF). - exact (full_sub_category_is_functor HF). Defined. UniMath-20231010/UniMath/CategoryTheory/Subcategory/FullEquivalences.v000066400000000000000000000067341451125700300255630ustar00rootroot00000000000000Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Local Open Scope cat. (** Equivalences between full subcategories *) Section EquivalenceFullSub. Context {C₁ C₂ : category} {P : hsubtype C₁} {Q : hsubtype C₂} (L : C₁ ⟶ C₂) (L_equiv : adj_equivalence_of_cats L) (HL : ∏ (x : C₁), P x → Q (L x)) (HR : ∏ (x : C₂), Q x → P (right_adjoint L_equiv x)). Let L' : full_sub_category C₁ P ⟶ full_sub_category C₂ Q := full_sub_category_functor P Q L HL. Let R' : full_sub_category C₂ Q ⟶ full_sub_category C₁ P := full_sub_category_functor Q P _ HR. Definition full_sub_category_equivalence_unit_data : nat_trans_data (functor_identity (full_sub_category C₁ P)) (L' ∙ R') := λ y, unit_from_left_adjoint L_equiv (pr1 y) ,, tt. Definition full_sub_category_equivalence_unit_is_nat_trans : is_nat_trans _ _ full_sub_category_equivalence_unit_data. Proof. intros y₁ y₂ f ; cbn. use subtypePath. { intro. apply isapropunit. } cbn. apply (nat_trans_ax (unit_from_left_adjoint L_equiv)). Qed. Definition full_sub_category_equivalence_unit : functor_identity _ ⟹ L' ∙ R'. Proof. use make_nat_trans. - exact full_sub_category_equivalence_unit_data. - exact full_sub_category_equivalence_unit_is_nat_trans. Defined. Definition full_sub_category_equivalence_counit_data : nat_trans_data (R' ∙ L') (functor_identity _) := λ y, counit_from_left_adjoint L_equiv (pr1 y) ,, tt. Definition full_sub_category_equivalence_counit_is_nat_trans : is_nat_trans _ _ full_sub_category_equivalence_counit_data. Proof. intros y₁ y₂ f ; cbn. use subtypePath. { intro. apply isapropunit. } cbn. apply (nat_trans_ax (counit_from_left_adjoint L_equiv)). Qed. Definition full_sub_category_equivalence_counit : R' ∙ L' ⟹ functor_identity _. Proof. use make_nat_trans. - exact full_sub_category_equivalence_counit_data. - exact full_sub_category_equivalence_counit_is_nat_trans. Defined. Definition full_sub_category_equivalence : equivalence_of_cats (full_sub_category C₁ P) (full_sub_category C₂ Q). Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact L'. + exact R'. + exact full_sub_category_equivalence_unit. + exact full_sub_category_equivalence_counit. - split. + intro. apply is_iso_full_sub. apply unit_nat_z_iso_from_adj_equivalence_of_cats. + intro. apply is_iso_full_sub. apply counit_nat_z_iso_from_adj_equivalence_of_cats. Defined. Definition full_sub_category_adj_equivalence : adj_equivalence_of_cats (full_sub_category_functor P Q L HL) := adjointification full_sub_category_equivalence. End EquivalenceFullSub. UniMath-20231010/UniMath/CategoryTheory/Subcategory/Limits.v000066400000000000000000000206621451125700300235510ustar00rootroot00000000000000(** ** (Co)limits in full subprecategories If * C has (co)limits of shape F, * C' : ob C → UU is a proposition on the objects of C, and * C' is closed under the formation of (co)limits of shape F, then the full subcategory on C'-objects has (co)limits of shape F. Such proofs are mostly just a lot of insertions of * [precategory_object_from_sub_precategory_object] * [precategory_morphism_from_sub_precategory_morphism] and their "inverses" * [precategory_morphisms_in_subcat] * [precategory_object_in_subcat]. Author: Langston Barrett (@siddharthist) (March 2018) *) (** ** Contents - Limits - Binary products - Colimits *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Local Open Scope cat. (** ** The subcategory inclusion reflects limits *) Corollary reflects_all_limits_sub_precategory_inclusion {C : category} (C' : hsubtype (ob C)) : reflects_all_limits (sub_precategory_inclusion C (full_sub_precategory C')). Proof. apply fully_faithful_reflects_all_limits. apply fully_faithful_sub_precategory_inclusion. Defined. Section Limits. (** ** Limits *) (** *** Terminal objects *) (** As long as the predicate holds for the terminal object, it's terminal in the full subcategory. *) Lemma terminal_in_full_subcategory {C : category} (C' : hsubtype (ob C)) (TC : Terminal C) (TC' : C' (TerminalObject TC)) : Terminal (full_sub_precategory C'). Proof. use tpair. - use precategory_object_in_subcat. + exact (TerminalObject TC). + assumption. - cbn. intros X. use make_iscontr. + use morphism_in_full_subcat. apply TerminalArrow. + intro; apply eq_in_sub_precategory; cbn. apply TerminalArrowUnique. Defined. (** *** Binary products *) Lemma bin_products_in_full_subcategory {C : category} (C' : hsubtype (ob C)) (BPC : BinProducts C) (all : ∏ c1 c2 : ob C, C' c1 -> C' c2 -> C' (BinProductObject _ (BPC c1 c2))) : BinProducts (full_sub_precategory C'). Proof. intros c1' c2'. pose (c1'_in_C := (precategory_object_from_sub_precategory_object _ _ c1')). pose (c2'_in_C := (precategory_object_from_sub_precategory_object _ _ c2')). use tpair; [use tpair|]; [|use make_dirprod|]. - use precategory_object_in_subcat. + apply (BinProductObject _ (BPC c1'_in_C c2'_in_C)). + apply all. * exact (pr2 c1'). * exact (pr2 c2'). - use morphism_in_full_subcat; apply BinProductPr1. - use morphism_in_full_subcat; apply BinProductPr2. - cbn. unfold isBinProduct. intros bp' f g. use tpair. + use tpair. * use precategory_morphisms_in_subcat; [apply BinProductArrow|exact tt]; apply (precategory_morphism_from_sub_precategory_morphism _ (full_sub_precategory C')); assumption. * cbn. use make_dirprod; apply eq_in_sub_precategory. { apply BinProductPr1Commutes. } { apply BinProductPr2Commutes. } + intros otherarrow. (** This is where we use the condition that C has homsets. *) apply subtypePath. { intro. apply isapropdirprod; apply is_set_sub_precategory_morphisms. } { apply eq_in_sub_precategory. cbn. apply BinProductArrowUnique. - exact (maponpaths pr1 (dirprod_pr1 (pr2 otherarrow))). - exact (maponpaths pr1 (dirprod_pr2 (pr2 otherarrow))). } Defined. (** *** General limits *) (** Lift a diagram from a full subcategory into the parent category *) Definition lift_diagram_full_subcategory {C : category} {C' : hsubtype (ob C)} {g : graph} (d : diagram g (full_sub_precategory C')) : diagram g C. Proof. use tpair. - intros v. apply (precategory_object_from_sub_precategory_object _ (full_sub_precategory C')). exact (dob d v). - intros u v e. apply (precategory_morphism_from_sub_precategory_morphism _ (full_sub_precategory C')). exact (dmor d e). Defined. (** Equivalence between cones in the parent category and those in the subcategory *) Definition cone_in_full_subcategory {C : category} {g : graph} (C' : hsubtype (ob C)) {d : diagram g (full_sub_precategory C')} (c : ob C) (tip : C' c) : cone (lift_diagram_full_subcategory d) c ≃ cone d (c,, tip). Proof. unfold cone. use weqbandf. - apply weqonsecfibers; intros x. cbn beta. (** The following line works because of the computational behavior of [lift_diagram_full_subcategory], namely: << (∏ v : vertex g, C' (dob (lift_diagram_full_subcategory d) v)) → C' c → ∏ v : vertex g, pr1 (dob d v) = dob (lift_diagram_full_subcategory d) v >> *) apply (@weq_hom_in_subcat_from_hom_in_precat C C' (c,, tip) (dob d x)). - intro legs. cbn beta. apply weqonsecfibers; intros u; apply weqonsecfibers; intros v; apply weqonsecfibers; intros e. cbn. apply invweq. refine (subtypeInjectivity _ _ _ _). intro; apply propproperty. Defined. (** A full subcategory has a limit of a given shape if the proposition holds for the tip of the lifted limit diagram in the parent category. *) Lemma lim_cone_in_full_subcategory {C : category} (C' : hsubtype (ob C)) {g : graph} {d : diagram g (full_sub_precategory C')} (LC : Lims_of_shape g C) : C' (lim (LC (lift_diagram_full_subcategory d))) -> LimCone d. Proof. intro. pose (Z := LC (lift_diagram_full_subcategory d)). unfold LimCone. use tpair. - use tpair. + use precategory_object_in_subcat. * eapply lim; eassumption. * assumption. + apply cone_in_full_subcategory, limCone. - apply (reflects_all_limits_sub_precategory_inclusion C' g d). apply (pr2 Z). Qed. (** ** Colimits *) (** *** Initial objects *) (** As long as the predicate holds for the initial object, it's initial in the full subcategory. *) Lemma initial_in_full_subcategory {C : category} (C' : hsubtype (ob C)) (IC : Initial C) (IC' : C' (InitialObject IC)) : Initial (full_sub_precategory C'). Proof. use tpair. - use precategory_object_in_subcat. + exact (InitialObject IC). + assumption. - cbn. intros X. use make_iscontr. + use morphism_in_full_subcat. apply InitialArrow. + intro; apply eq_in_sub_precategory; cbn. apply InitialArrowUnique. Defined. (** *** Binary coproducts *) Lemma bin_coproducts_in_full_subcategory {C : category} (C' : hsubtype (ob C)) (BPC : BinCoproducts C) (all : ∏ c1 c2 : ob C, C' c1 -> C' c2 -> C' (BinCoproductObject (BPC c1 c2))) : BinCoproducts (full_sub_precategory C'). Proof. intros c1' c2'. pose (c1'_in_C := (precategory_object_from_sub_precategory_object _ _ c1')). pose (c2'_in_C := (precategory_object_from_sub_precategory_object _ _ c2')). use tpair; [use tpair|]; [|use make_dirprod|]. - use precategory_object_in_subcat. + apply (BinCoproductObject (BPC c1'_in_C c2'_in_C)). + apply all. * exact (pr2 c1'). * exact (pr2 c2'). - use morphism_in_full_subcat; apply BinCoproductIn1. - use morphism_in_full_subcat; apply BinCoproductIn2. - cbn. unfold isBinCoproduct. intros bp' f g. use tpair. + use tpair. * use precategory_morphisms_in_subcat; [apply BinCoproductArrow|exact tt]; apply (precategory_morphism_from_sub_precategory_morphism _ (full_sub_precategory C')); assumption. * cbn. use make_dirprod; apply eq_in_sub_precategory. { apply BinCoproductIn1Commutes. } { apply BinCoproductIn2Commutes. } + intros otherarrow. (** This is where we use the condition that C has homsets. *) apply subtypePath. { intro. apply isapropdirprod; apply is_set_sub_precategory_morphisms. } { apply eq_in_sub_precategory. cbn. apply BinCoproductArrowUnique. - exact (maponpaths pr1 (dirprod_pr1 (pr2 otherarrow))). - exact (maponpaths pr1 (dirprod_pr2 (pr2 otherarrow))). } Defined. End Limits. UniMath-20231010/UniMath/CategoryTheory/Subcategory/Reflective.v000066400000000000000000000035121451125700300243730ustar00rootroot00000000000000(** * Reflective subcategories *) (** ** Contents - Definition *) Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Adjunctions.Core. Section Def. Context {C : category}. Definition is_reflective (D : hsubtype C) := is_right_adjoint (sub_precategory_inclusion C (full_sub_precategory D)). Definition reflective_subcategory : UU := ∑ D : hsubtype C, is_reflective D. Definition reflective_subcategory_to_hsubtype (D : reflective_subcategory) : hsubtype C := pr1 D. Coercion reflective_subcategory_to_hsubtype : reflective_subcategory >-> hsubtype. Definition reflective_subcategory_to_precategory : reflective_subcategory -> precategory. intro D; exact (full_sub_precategory D). Defined. Coercion reflective_subcategory_to_precategory : reflective_subcategory >-> precategory. Definition localization (R : reflective_subcategory) : functor C (full_sub_precategory R) := left_adjoint (pr2 R). End Def. Arguments reflective_subcategory _ : clear implicits. Lemma localization_is_idempotent {C : category} (R : reflective_subcategory C) (d : ob R) : z_iso (localization R (precategory_object_from_sub_precategory_object _ _ d)) d. Proof. exists ((counit_from_left_adjoint (pr2 (pr2 R))) d). abstract ( apply (@counit_is_z_iso_if_right_adjoint_is_fully_faithful C (subcategory C (full_sub_precategory R)) _ _ (pr2 (pr2 R))), fully_faithful_sub_precategory_inclusion). Defined. UniMath-20231010/UniMath/CategoryTheory/SubobjectClassifier.v000066400000000000000000000257071451125700300237530ustar00rootroot00000000000000(** * Subobject classifiers *) (** ** Contents - Definition - Accessors - Proof that a category with a subobject classifier is balanced ([subobject_classifier_balanced]) - Derivation of [SubobjectClassifier_nat_z_iso], the natural (z-)isomorphism between the subobject functor and Hom(-,O) induced by a subobject classifier *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartB. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.Subobjects. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Subcategory.Core. Local Open Scope cat. (** ** Definition *) Definition subobject_classifier {C : category} (T : Terminal C) : UU := ∑ (O : ob C) (true : C⟦T, O⟧), ∏ (X Y : ob C) (m : Monic _ X Y), ∃! chi : C⟦Y, O⟧, ∑ (H : m · chi = TerminalArrow _ _ · true), isPullback H. Definition make_subobject_classifier {C : category} {T : Terminal C} (O : ob C) (true : C⟦T, O⟧) : (∏ (X Y : ob C) (m : Monic _ X Y), iscontr (∑ (chi : C⟦Y, O⟧) (H : m · chi = TerminalArrow _ _ · true), isPullback H)) -> subobject_classifier T. Proof. intros. use tpair; [exact O|]. use tpair; [exact true|]. assumption. Qed. (** ** Accessors *) Section Accessors. Context {C : category} {T : Terminal C} (O : subobject_classifier T). Definition subobject_classifier_object : ob C := pr1 O. (** [true] is monic. We only export the accessor for it them as a [Monic] (rather than the a morphism), as it's strictly more useful. *) Definition true' : C⟦T, subobject_classifier_object⟧ := pr1 (pr2 O). Local Lemma true_is_monic : isMonic true'. Proof. apply from_terminal_isMonic. Qed. Definition true : Monic _ T subobject_classifier_object := make_Monic _ true' true_is_monic. Definition subobject_classifier_universal_property {X Y} (m : Monic _ X Y) : iscontr (∑ (chi : C⟦Y, subobject_classifier_object⟧) (H : m · chi = TerminalArrow _ _ · true'), isPullback H) := pr2 (pr2 O) X Y m. Definition characteristic_morphism {X Y} (m : Monic _ X Y) : C⟦Y, subobject_classifier_object⟧ := pr1 (iscontrpr1 (subobject_classifier_universal_property m)). Definition subobject_classifier_square_commutes {X Y} (m : Monic _ X Y) : m · characteristic_morphism m = TerminalArrow _ _ · true := pr1 (pr2 (iscontrpr1 (subobject_classifier_universal_property m))). Definition subobject_classifier_pullback {X Y} (m : Monic _ X Y) : Pullback (characteristic_morphism m) true. Proof. use make_Pullback. - exact X. - exact m. - apply TerminalArrow. - apply subobject_classifier_square_commutes. - apply (pr2 (pr2 (iscontrpr1 (subobject_classifier_universal_property m)))). Defined. Definition subobject_classifier_pullback_sym {X Y} (m : Monic _ X Y) : Pullback true (characteristic_morphism m). Proof. refine (@switchPullback C _ _ _ _ _ (subobject_classifier_pullback m)). Defined. End Accessors. Coercion subobject_classifier_object : subobject_classifier >-> ob. Coercion true : subobject_classifier >-> Monic. (** The arrow Goldblatt calls [true! := (! : X -> T) · true] *) Definition const_true {C : category} {T : Terminal C} (X : ob C) (O : subobject_classifier T) : X --> subobject_classifier_object O := TerminalArrow T X · true O. (*A category with subobjectclassifier is balanced: if a morphism is mono and epi then it is iso*) Section balanced. Context {C : category} {T : Terminal C} (O : subobject_classifier T) {c' c : C} (f : C⟦ c' , c ⟧) (f_isM : isMonic f) (f_isE : isEpi f). Local Definition f_asMonic := make_Monic _ f f_isM. Local Definition f_asEqualizer : Equalizer (characteristic_morphism O f_asMonic) (TerminalArrow T c · (true O)). Proof. use (make_Equalizer _ _ f_asMonic). + rewrite subobject_classifier_square_commutes, assoc. use cancel_postcomposition. use TerminalArrowEq. + use make_isEqualizer. intros x h q. use unique_exists. - assert (p : c' = PullbackObject (subobject_classifier_pullback O f_asMonic)). { apply idpath. } rewrite p. use (PullbackArrow _ _ h (TerminalArrow T x)). rewrite q, assoc. use cancel_postcomposition. use TerminalArrowUnique. - simpl. assert (p : f = PullbackPr1 (subobject_classifier_pullback O f_asMonic)). { apply idpath. } rewrite p. use (PullbackArrow_PullbackPr1 ((subobject_classifier_pullback O f_asMonic))). - intro t. use homset_property. - intros t t_tri. simpl. use (PullbackArrowUnique' _ _ _ (subobject_classifier_pullback O f_asMonic)). * exact t_tri. * use TerminalArrowUnique. Defined. Local Lemma path_from_fepi : (characteristic_morphism O f_asMonic) = (TerminalArrow T c · (true O)). Proof. use f_isE. assert (p : f = f_asMonic). {apply idpath. } rewrite p. rewrite (subobject_classifier_square_commutes O f_asMonic). rewrite assoc. use cancel_postcomposition. use TerminalArrowEq. Qed. Theorem subobject_classifier_balanced : (is_z_isomorphism f). Proof. assert (p : f = EqualizerArrow (f_asEqualizer)). { apply idpath. } rewrite p. use (z_iso_Equalizer_of_same_map f_asEqualizer). exact path_from_fepi. Defined. End balanced. (*Given a subobject_classifier O there is a nat_z_iso between the subobject functor and Hom(-,O)*) Section subobject_classifier_natziso. Context {C:category} {T:Terminal C} (PB : Pullbacks C) (O : subobject_classifier T). Definition SubobjectClassifier_nt_data : nat_trans_data (SubObj_Functor C PB) (contra_homSet_functor O). Proof. intros c S. cbn in c. change (pr1hSet (SubObj c)) in S. cbn. use (squash_to_set (X:=(pr1setquot (z_iso_eqrel (C:=Subobjectscategory c)) S))). + use homset_property. + intro m. exact (characteristic_morphism O (Subobject_Monic (pr1carrier _ m))). + intros m m'. cbn. assert (ej : (z_iso_eqrel (C:=Subobjectscategory c)) (pr1carrier _ m') (pr1carrier _ m)). { use (invweq (weqpathsinsetquot _ _ _)). use (pathscomp0 (b:=S)). * use (setquotl0 (z_iso_eqrel (C:=Subobjectscategory c))). * use pathsinv0. use (setquotl0 (z_iso_eqrel (C:=Subobjectscategory c))). } use (squash_to_prop ej). - use homset_property. - intro j. use path_to_ctr. cbn. transparent assert (pb_aux : (Pullback ((identity c)·(characteristic_morphism O (Subobject_Monic (pr1carrier _ m)))) (true' O))). { use (Pullback_z_iso_of_morphisms). * exact (subobject_classifier_pullback O (Subobject_Monic (pr1carrier _ m))). * exact (Subobject_dom (pr1carrier _ m')). * exact (z_iso_from_z_iso_in_Subobjectcategory j). * exact (Subobject_mor (pr1carrier _ m')). * exact (identity_is_z_iso c). * use z_iso_is_z_isomorphism. * rewrite id_right. use (Subobjectmor_tri j). } use (isPullback_mor_paths' _ _ _ _ _ (isPullback_Pullback pb_aux)). * rewrite id_left. apply idpath. * apply idpath. * apply idpath. * use TerminalArrowUnique. + exact (eqax0 (SubObj_iseqc S)). Defined. Lemma SubobjectClassifier_nt_is : is_nat_trans (SubObj_Functor C PB) (contra_homSet_functor O) SubobjectClassifier_nt_data. Proof. intros c c' f. cbn in c, c', f. use funextfun. intro S. use (squash_to_prop (X := pr1setquot _ S)). + exact (eqax0 (SubObj_iseqc S)). + use homset_property. + intro m. induction (setquotl0 _ _ m). cbn. rewrite id_right. use pathsinv0. use path_to_ctr. set (pbr := subobject_classifier_pullback O (Subobject_Monic (pr1carrier _ m))). cbn. set (pbl := PB c c' (Subobject_dom (pr1carrier _ m)) f (Subobject_mor (pr1carrier _ m))). transparent assert (pb_glued : (Pullback (f·(characteristic_morphism O (Subobject_Monic (pr1carrier _ m)))) O)). { use make_Pullback. - exact pbl. - exact (PullbackPr1 pbl). - exact ((PullbackPr2 pbl)·(PullbackPr2 pbr)). - use glueSquares. * exact (PullbackPr1 pbr). * exact (PullbackSqrCommutes pbr). * exact (PullbackSqrCommutes pbl). - use (isPullbackGluedSquare (isPullback_Pullback pbr) (isPullback_Pullback pbl)). } use (isPullback_mor_paths' _ _ _ _ _ (isPullback_Pullback pb_glued)). - apply idpath. - apply idpath. - apply idpath. - use TerminalArrowUnique. Defined. Definition SubobjectClassifier_nat_trans : nat_trans (SubObj_Functor C PB) (contra_homSet_functor O). Proof. use make_nat_trans. + exact SubobjectClassifier_nt_data. + exact SubobjectClassifier_nt_is. Defined. Lemma SubobjectClassifier_nt_is_nat_z_iso : is_nat_z_iso SubobjectClassifier_nat_trans. Proof. intros c. use make_is_z_isomorphism. + intro phi. cbn in c, phi. use setquotpr. use (PullbackSubobject PB _ phi). use (Subobjectscategory_ob (true O)). apply from_terminal_isMonic. + use make_is_inverse_in_precat. - use funextfun. intro S. use (squash_to_prop (X:= pr1setquot _ S) ((eqax0 (SubObj_iseqc S)))). { use isasetsetquot. } intro m. induction (setquotl0 _ _ m). use weqpathsinsetquot. use hinhpr. cbn. set (pbc := subobject_classifier_pullback O ((Subobject_Monic (pr1carrier _ m)))). set (PBc := PB _ _ _ (characteristic_morphism O (Subobject_Monic (pr1carrier _ m))) O). induction (pullbackiso _ PBc pbc) as (PBpb_z_iso,(PBpb_z_iso1,PBpb_z_iso2)). use make_z_iso_in_Subobjectscategory. * cbn. exact PBpb_z_iso. * use z_iso_is_z_isomorphism. * apply pathsinv0. exact PBpb_z_iso1. - use funextfun. intro phi. cbn. apply pathsinv0. use path_to_ctr. cbn. set (pb := PB O c T phi (true' O)). use (isPullback_mor_paths' _ _ _ _ _ (isPullback_Pullback pb)). * apply idpath. * apply idpath. * apply idpath. * use TerminalArrowUnique. Defined. Definition SubobjectClassifier_nat_z_iso : nat_z_iso (SubObj_Functor C PB) (contra_homSet_functor O). Proof. use make_nat_z_iso. + exact SubobjectClassifier_nat_trans. + exact SubobjectClassifier_nt_is_nat_z_iso. Defined. End subobject_classifier_natziso. UniMath-20231010/UniMath/CategoryTheory/Subobjects.v000066400000000000000000000300231451125700300221140ustar00rootroot00000000000000(** ************************************************************************* Definition and theory about subobjects of an object c Contents: - Category of subobjects (monos) of c ([Subobjectscategory]) - Set of subobjects as equivalence classes of monos ([SubObj]) - Proof that the set of subobjects of an object is a poset ([SubObjPoset]) - The definition of the functor from C^op to hset_category which maps c to the set of the subobject (module z_isomorphism) of c and maps morphism "by pullback" ([SubObj_Functor]) Written by: Tomi Pannila and Anders Mörtberg, 2016-2017 *****************************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. (** * Definition of the category of subobjects (monos) of c *) Section def_subobjects. Context {C : category}. Definition Subobjectscategory (c : C) : category := slice_cat (subcategory_of_monics C) (subprecategory_of_monics_ob C c). Lemma has_homsets_Subobjectscategory (c : C) : has_homsets (Subobjectscategory c). Proof. apply has_homsets_slice_precat. Qed. (** Construction of a subobject from a monic *) Definition Subobjectscategory_ob {c c' : C} (h : C⟦c', c⟧) (isM : isMonic h) : Subobjectscategory c := (subprecategory_of_monics_ob C c',,(h,,isM)). (** Accessor for an object of Subobjectscategory*) Section obAccessor. Context {c:C} (S : Subobjectscategory c). Definition Subobject_dom : C := pr1 (pr1 S). Definition Subobject_Monic := pr2 S. Definition Subobject_mor : C⟦ Subobject_dom , c ⟧ := pr1 (pr2 S). Definition Subobject_isM : isMonic(Subobject_mor) := pr2 (pr2 S). End obAccessor. (** Accessor for a morphism of Subobjectscategory*) Section morAccessor. Context {c:C} {S S' : Subobjectscategory c} (h : S --> S'). Definition Subobjectmor_Cmor : C⟦ Subobject_dom S, Subobject_dom S' ⟧ := pr1 (pr1 h). Definition Subobjectmor_isM : isMonic(Subobjectmor_Cmor) := pr2 (pr1 h). Definition Subobjectmor_tri := maponpaths (pr1) (pr2 h). End morAccessor. (** Given any subobject S of c and a morphism h : c' -> c, by taking then pullback of S by h we obtain a subobject of c'. *) Definition PullbackSubobject (PB : Pullbacks C) {c : C} (S : Subobjectscategory c) {c' : C} (h : C⟦c', c⟧) : Subobjectscategory c'. Proof. set (pb := PB _ _ _ h (Subobject_mor S)). use Subobjectscategory_ob. - exact pb. - exact (PullbackPr1 pb). - use MonicPullbackisMonic'. Defined. (*a z_iso in Subobjectscategory can be obtained by a z_iso on the underlying category C which makes the triangle commute*) Definition make_z_iso_in_Subobjectscategory {c : C} {S S' : Subobjectscategory c} (h : C ⟦Subobject_dom S ,Subobject_dom S'⟧) (is_z_iso : is_z_isomorphism h) (tri : Subobject_mor S = h · Subobject_mor S') : z_iso S S'. Proof. use make_z_iso'. + use tpair. - use precategory_morphisms_in_subcat. * exact h. * use is_iso_isMonic. exact is_z_iso. - use eq_in_sub_precategory. exact tri. + use z_iso_to_slice_precat_z_iso. use is_z_iso_in_subcategory_of_monics_weq. exact is_z_iso. Defined. (** a z_iso is Subobjectcategory gives, in particular, a z_iso of C between domains*) Definition z_iso_from_z_iso_in_Subobjectcategory {c : C} {S S' : Subobjectscategory c} (h : z_iso S S') : (z_iso (Subobject_dom S) (Subobject_dom S')). Proof. use make_z_iso. + exact (Subobjectmor_Cmor h). + exact (Subobjectmor_Cmor (inv_from_z_iso h)). + induction h as (h, (g,(hg,gh))). use make_is_inverse_in_precat. - exact (maponpaths Subobjectmor_Cmor hg). - exact (maponpaths Subobjectmor_Cmor gh). Defined. End def_subobjects. (** * Definition of subobjects as equivalence classes of monos *) Section subobj. Context {C : category}. (** Equivalence classes of subobjects defined by identifying monos into c with isomorphic source *) Definition SubObj (c : C) : hSet := make_hSet (setquot (z_iso_eqrel (C:=Subobjectscategory c))) (isasetsetquot _). Definition SubObj_iseqc {c:C} (S : SubObj c) := pr2 S. Definition PullbackSubObj (PB : Pullbacks C) {c : C} (S : SubObj c) {c' : C} (h : C⟦c', c⟧) : SubObj c'. Proof. use (setquotfun (z_iso_eqrel (C:=Subobjectscategory c))). + intro s. use (PullbackSubobject PB s h). + intros u v. use hinhfun. intro uv. use make_z_iso_in_Subobjectscategory. - use (iso_between_pullbacks (PullbackSqrCommutes (PB _ _ _ h (Subobject_mor u))) (PullbackSqrCommutes (PB _ _ _ h (Subobject_mor v))) (isPullback_Pullback (PB _ _ _ h (Subobject_mor u))) (isPullback_Pullback (PB _ _ _ h (Subobject_mor v))) ). * exact (identity_z_iso c'). * use z_iso_from_z_iso_in_Subobjectcategory. exact uv. * exact (identity_z_iso c). * rewrite id_left, id_right. apply idpath. * rewrite id_right. apply pathsinv0. use Subobjectmor_tri. - use z_iso_is_z_isomorphism. - rewrite <-(id_right (Subobject_mor _)). use pathsinv0. use PullbackArrow_PullbackPr1. + exact S. Defined. (* For f and g monics into c: f <= g := ∃ h, f = h · g *) Definition monorel (c : C) : hrel (Subobjectscategory c) := λ f g, ∃ h, pr1 (pr2 f) = h · pr1 (pr2 g). Lemma isrefl_monorel (c : C) : isrefl (monorel c). Proof. intros x; apply hinhpr. exists (pr1 (pr1 (identity x))). now rewrite id_left. Qed. Lemma istrans_monorel (c : C) : istrans (monorel c). Proof. intros x y z h1. apply hinhuniv; intros h2; generalize h1; clear h1. apply hinhuniv; intros h1; apply hinhpr. exists (pr1 h1 · pr1 h2). now rewrite <- assoc, <- (pr2 h2), <- (pr2 h1). Qed. Lemma ispreorder_monorel c : ispreorder (monorel c). Proof. exact (istrans_monorel c,,isrefl_monorel c). Qed. Lemma are_z_isomorphic_monorel {c : C} {x1 y1 x2 y2 : Subobjectscategory c} (h1 : are_z_isomorphic x1 y1) (h2 : are_z_isomorphic x2 y2) : monorel c x1 x2 → monorel c y1 y2. Proof. apply hinhuniv; intros f. change (ishinh_UU (z_iso x1 y1)) in h1. change (ishinh_UU (z_iso x2 y2)) in h2. apply h1; clear h1; intro h1. apply h2; clear h2; intro h2. intros P H; apply H; clear P H. set (h1_inv := inv_from_z_iso h1). set (Hh1 := z_iso_after_z_iso_inv h1). exists (pr1 (pr1 h1_inv) · pr1 f · pr1 (pr1 (pr1 h2))). set (Htemp := maponpaths pr1 (pr2 (pr1 h2))). apply pathsinv0; simpl in *. rewrite <-!assoc, <- Htemp. intermediate_path (pr1 (pr1 h1_inv) · pr1 (pr2 x1)). { apply maponpaths, pathsinv0, (pr2 f). } etrans; [ apply maponpaths, (maponpaths pr1 (pr2 (pr1 h1))) |]; simpl. rewrite assoc. etrans; [ eapply cancel_postcomposition, (maponpaths pr1 (maponpaths pr1 Hh1)) |]. apply id_left. Qed. (** Construct a quotient relation on the Subobjects from the relation on monos *) Definition SubObj_rel (c : C) : hrel (pr1 (SubObj c)). Proof. use quotrel. - apply monorel. - intros x1 y1 x2 y2 h1 h2. apply hPropUnivalence. + apply (are_z_isomorphic_monorel h1 h2). + apply (are_z_isomorphic_monorel (eqrelsymm (z_iso_eqrel) _ _ h1) (eqrelsymm (z_iso_eqrel) _ _ h2)). Defined. Lemma istrans_SubObj_rel (c : C) : istrans (SubObj_rel c). Proof. apply istransquotrel, istrans_monorel. Qed. Lemma isrefl_SubObj_rel (c : C) : isrefl (SubObj_rel c). Proof. apply isreflquotrel, isrefl_monorel. Qed. Lemma ispreorder_SubObj_rel (c : C) : ispreorder (SubObj_rel c). Proof. exact (istrans_SubObj_rel c,,isrefl_SubObj_rel c). Qed. Lemma isantisymm_SubObj_rel (c : C) : isantisymm (SubObj_rel c). Proof. unfold isantisymm; simpl. assert (int : ∏ x1 x2, isaprop (SubObj_rel c x1 x2 → SubObj_rel c x2 x1 -> x1 = x2)). { intros x1 x2. repeat (apply impred; intro). apply (isasetsetquot _ x1 x2). } apply (setquotuniv2prop _ (λ x1 x2, make_hProp _ (int x1 x2))). intros x y h1 h2. simpl in *. (* This is slow *) apply (iscompsetquotpr (z_iso_eqrel (C:=Subobjectscategory c))). generalize h1; clear h1; apply hinhuniv; intros [h1 Hh1]. generalize h2; clear h2; apply hinhuniv; intros [h2 Hh2]. apply hinhpr, (invmap (weq_z_iso _ (subprecategory_of_monics_ob C c) _ _)). induction x as [[x []] [fx Hfx]]. induction y as [[y []] [fy Hfy]]. simpl in *. assert (mon_h1 : isMonic h1). { apply (isMonic_postcomp _ h1 fy); rewrite <- Hh1; apply Hfx. } assert (mon_h2 : isMonic h2). { apply (isMonic_postcomp _ h2 fx); rewrite <- Hh2; apply Hfy. } use tpair. - exists (h1,,mon_h1). exists (h2,,mon_h2). split; apply subtypePath. + intros xx. apply isapropisMonic. + simpl; apply Hfx. now rewrite <- assoc, <- Hh2, <- Hh1, id_left. + intros xx. apply isapropisMonic. + simpl; apply Hfy. now rewrite <- assoc, <- Hh1, <- Hh2, id_left. - apply subtypePath; simpl; try apply Hh1. now intros xx; apply isapropisMonic. Qed. Definition SubObjPoset (c : C) : Poset := (SubObj c,,SubObj_rel c,,ispreorder_SubObj_rel c,,isantisymm_SubObj_rel c). End subobj. (*Definition of the functor C^op -> HSET which maps c on SubObj c and maps morphism "by pullback"*) Section SubObj_functor. Context (C : category) (PB : Pullbacks C). Definition SubObj_Functor_data : functor_data (op_cat C) hset_category. Proof. use make_functor_data. + intro c. cbn in c. exact (SubObj c). + intros c c' f Sm. use PullbackSubObj. - exact PB. - exact c. - exact Sm. - exact f. Defined. Theorem SubObj_Functor_isfunctor : is_functor (SubObj_Functor_data). Proof. split. + intro c. cbn in c. use funextfun. intro S. change (pr1hSet (SubObj c)) in S. use (squash_to_prop (X:=pr1setquot _ S)). { exact (eqax0 (SubObj_iseqc S)). } { use isasetsetquot. } intro m. induction (setquotl0 _ S m). cbn. use (weqpathsinsetquot (z_iso_eqrel (C:=Subobjectscategory c))). use hinhpr. use make_z_iso_in_Subobjectscategory. - use PullbackPr2. - use Pullback_of_z_iso'. exact (identity_is_z_iso c). - cbn. rewrite <- PullbackSqrCommutes, id_right. apply idpath. + intros c c' c'' f f'. cbn in c, c', c'', f, f'. use funextfun. intro S. use (squash_to_prop (X:=pr1setquot _ S)). { exact (eqax0 (SubObj_iseqc S)). } { use isasetsetquot. } intro m. induction (setquotl0 _ S m). use weqpathsinsetquot. use hinhpr. induction m as (m,Sm). cbn. set (pb := (PB _ _ _ f ((Subobject_mor m)))). set (pbpb := PB _ _ _ f' (PullbackPr1 pb)). transparent assert (pb_glued : (Pullback (f'·f) (Subobject_mor m))). { use make_Pullback. - exact pbpb. - exact (PullbackPr1 pbpb). - exact ((PullbackPr2 pbpb)·(PullbackPr2 pb)). - use glueSquares. * exact (PullbackPr1 pb). * use PullbackSqrCommutes. * use PullbackSqrCommutes. - use (isPullbackGluedSquare (isPullback_Pullback pb) (isPullback_Pullback pbpb)). } use make_z_iso_in_Subobjectscategory. - cbn. fold pb. fold pbpb. assert (H : PullbackObject pb_glued = PullbackObject pbpb). { apply idpath. } induction H. use z_iso_from_Pullback_to_Pullback. - use z_iso_is_z_isomorphism. - cbn. fold pb. fold pbpb. assert (H : PullbackPr1 pb_glued = PullbackPr1 pbpb). { apply idpath. } induction H. apply pathsinv0. use (PullbackArrow_PullbackPr1 pb_glued). Defined. Definition SubObj_Functor : C^op ⟶ hset_category. Proof. use make_functor. + exact SubObj_Functor_data. + exact SubObj_Functor_isfunctor. Defined. End SubObj_functor. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/000077500000000000000000000000001451125700300240205ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Discrete.v000066400000000000000000000107721451125700300257600ustar00rootroot00000000000000(********************************************************************************** Discrete two-sided displayed categories Discreteness for two-sided displayed categories is defined in much the same way as for categories and displayed categories. We require univalence, and that all morphisms are equal and invertible. Note that from this, one can conclude that the displayed objects actually form a set. **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Profunctors.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Local Open Scope cat. Definition isaprop_disp_twosided_mor {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (fg fg' : xy₁ -->[ f ][ g ] xy₂), fg = fg'. Definition all_disp_mor_iso {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (Hf : is_z_isomorphism f) (Hg : is_z_isomorphism g) (fg : xy₁ -->[ f ][ g ] xy₂), is_iso_twosided_disp Hf Hg fg. Definition sym_mor_twosided_disp_cat {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (Hf : is_z_isomorphism f) (Hg : is_z_isomorphism g) (fg : xy₁ -->[ f ][ g ] xy₂), xy₂ -->[ inv_from_z_iso (f ,, Hf) ][ inv_from_z_iso (g ,, Hg) ] xy₁. Definition all_disp_mor_iso_from_prop {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD₁ : isaprop_disp_twosided_mor D) (HD₂ : sym_mor_twosided_disp_cat D) : all_disp_mor_iso D. Proof. intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg. simple refine (_ ,, _ ,, _). - apply HD₂. exact fg. - apply HD₁. - apply HD₁. Defined. Definition discrete_twosided_disp_cat {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : UU := isaprop_disp_twosided_mor D × all_disp_mor_iso D × is_univalent_twosided_disp_cat D. Definition make_discrete_twosided_disp_cat {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD₁ : isaprop_disp_twosided_mor D) (HD₂ : sym_mor_twosided_disp_cat D) (HD₃ : is_univalent_twosided_disp_cat D) : discrete_twosided_disp_cat D. Proof. simple refine (_ ,, _ ,, _). - exact HD₁. - apply all_disp_mor_iso_from_prop. + exact HD₁. + exact HD₂. - exact HD₃. Defined. Definition isaset_discrete_twosided_cat_ob {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : discrete_twosided_disp_cat D) (x : C₁) (y : C₂) : isaset (D x y). Proof. pose (HD₁ := pr1 HD). pose (HD₂ := pr22 HD). intros xy₁ xy₂. use (isofhlevelweqb _ (_ ,, HD₂ x x y y (idpath x) (idpath y) xy₁ xy₂)). use isaproptotal2. - intro. apply isaprop_is_iso_twosided_disp. - intros. apply HD₁. Qed. Definition mortoid_discrete_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : discrete_twosided_disp_cat D) {x : C₁} {y : C₂} (xy₁ xy₂ : D x y) (r : xy₁ -->[ identity x ][ identity y ] xy₂) : xy₁ = xy₂. Proof. use (isotoid_twosided_disp (pr22 HD) (idpath _) (idpath _) xy₁ xy₂). simple refine (r ,, _). apply HD. Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/DisplayedFunctor.v000066400000000000000000000525201451125700300274720ustar00rootroot00000000000000(********************************************************************************** Functors of two-sided displayed categories We define functors of two-sided displayed categories and we show that every such functor gives rise to a functor between the total categories. In addition, we give examples of such functors, namely the identity and composition. We also show that if the target two-sided displayed category is discrete, then the type of functors between them forms a set. Contents 1. Functors of two-sided displayed categories 2. Some laws 3. The total functor 4. The identity 5. Composition 6. Functors between discrete two-sided displayed categories form a set 7. Two-sided displayed functors versus displayed functors **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Local Open Scope cat. (** 1. Functors of two-sided displayed categories *) Section DisplayedFunctor. Context {C₁ C₁' C₂ C₂' : category} (F : C₁ ⟶ C₁') (G : C₂ ⟶ C₂') (D₁ : twosided_disp_cat C₁ C₂) (D₂ : twosided_disp_cat C₁' C₂'). Definition twosided_disp_functor_data : UU := ∑ (FGob : ∏ (x : C₁) (y : C₂), D₁ x y → D₂ (F x) (G y)), ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D₁ x₁ y₁) (xy₂ : D₁ x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (fg : xy₁ -->[ f ][ g ] xy₂), FGob _ _ xy₁ -->[ #F f ][ #G g] FGob _ _ xy₂. Definition twosided_disp_functor_data_ob (FG : twosided_disp_functor_data) {x : C₁} {y : C₂} (xy : D₁ x y) : D₂ (F x) (G y) := pr1 FG x y xy. Coercion twosided_disp_functor_data_ob : twosided_disp_functor_data >-> Funclass. Definition twosided_disp_functor_data_mor (FG : twosided_disp_functor_data) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : FG _ _ xy₁ -->[ #F f ][ #G g] FG _ _ xy₂ := pr2 FG _ _ _ _ _ _ _ _ fg. Local Notation "'#2' F" := (twosided_disp_functor_data_mor F) (at level 10). Definition twosided_disp_functor_id_law (FG : twosided_disp_functor_data) : UU := ∏ (x : C₁) (y : C₂) (xy : D₁ x y), #2 FG (id_two_disp xy) = transportb_disp_mor2 (functor_id F x) (functor_id G y) (id_two_disp (FG _ _ xy)). Definition twosided_disp_functor_comp_law (FG : twosided_disp_functor_data) : UU := ∏ (x₁ x₂ x₃ : C₁) (y₁ y₂ y₃ : C₂) (xy₁ : D₁ x₁ y₁) (xy₂ : D₁ x₂ y₂) (xy₃ : D₁ x₃ y₃) (f₁ : x₁ --> x₂) (g₁ : y₁ --> y₂) (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (f₂ : x₂ --> x₃) (g₂ : y₂ --> y₃) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃), #2 FG (fg₁ ;;2 fg₂) = transportb_disp_mor2 (functor_comp F f₁ f₂) (functor_comp G g₁ g₂) (#2 FG fg₁ ;;2 #2 FG fg₂). Definition twosided_disp_functor_laws (FG : twosided_disp_functor_data) : UU := twosided_disp_functor_id_law FG × twosided_disp_functor_comp_law FG. Proposition isaprop_twosided_disp_functor_laws (FG : twosided_disp_functor_data) : isaprop (twosided_disp_functor_laws FG). Proof. use isapropdirprod ; repeat (use impred ; intro) ; apply isaset_disp_mor. Qed. Definition twosided_disp_functor : UU := ∑ (FG : twosided_disp_functor_data), twosided_disp_functor_laws FG. Coercion twosided_disp_functor_to_data (FG : twosided_disp_functor) : twosided_disp_functor_data := pr1 FG. Definition twosided_disp_functor_id (FG : twosided_disp_functor) {x : C₁} {y : C₂} (xy : D₁ x y) : #2 FG (id_two_disp xy) = transportb_disp_mor2 (functor_id F x) (functor_id G y) (id_two_disp (FG _ _ xy)) := pr12 FG x y xy. Definition twosided_disp_functor_id_alt (FG : twosided_disp_functor) {x : C₁} {y : C₂} (xy : D₁ x y) : id_two_disp (FG _ _ xy) = transportf_disp_mor2 (functor_id F x) (functor_id G y) (#2 FG (id_two_disp xy)). Proof. rewrite twosided_disp_functor_id. rewrite transportfb_disp_mor2. apply idpath. Qed. Definition twosided_disp_functor_comp (FG : twosided_disp_functor) {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {xy₃ : D₁ x₃ y₃} {f₁ : x₁ --> x₂} {g₁ : y₁ --> y₂} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) {f₂ : x₂ --> x₃} {g₂ : y₂ --> y₃} (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : #2 FG (fg₁ ;;2 fg₂) = transportb_disp_mor2 (functor_comp F f₁ f₂) (functor_comp G g₁ g₂) (#2 FG fg₁ ;;2 #2 FG fg₂) := pr22 FG _ _ _ _ _ _ _ _ _ _ _ fg₁ _ _ fg₂. Definition twosided_disp_functor_comp_alt (FG : twosided_disp_functor) {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {xy₃ : D₁ x₃ y₃} {f₁ : x₁ --> x₂} {g₁ : y₁ --> y₂} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) {f₂ : x₂ --> x₃} {g₂ : y₂ --> y₃} (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : #2 FG fg₁ ;;2 #2 FG fg₂ = transportf_disp_mor2 (functor_comp F f₁ f₂) (functor_comp G g₁ g₂) (#2 FG (fg₁ ;;2 fg₂)). Proof. rewrite twosided_disp_functor_comp. rewrite transportfb_disp_mor2. apply idpath. Qed. End DisplayedFunctor. Arguments twosided_disp_functor_data_mor {C₁ C₁' C₂ C₂' F G D₁ D₂} FG {x₁ x₂ y₁ y₂ xy₁ xy₂ f g} fg. Notation "'#2' F" := (twosided_disp_functor_data_mor F) (at level 10) : cat. (** 2. Some laws *) Definition transportb_twosided_disp_functor_left {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f f' : x₁ --> x₂} (p : f = f') {g : y₁ --> y₂} (fg : xy₁ -->[ f' ][ g ] xy₂) : #2 FG (transportb (λ z, xy₁ -->[ z ][ g ] xy₂) p fg) = transportb (λ z, FG _ _ xy₁ -->[ z ][ _ ] FG _ _ xy₂) (maponpaths (λ z, #F z) p) (#2 FG fg). Proof. induction p. apply idpath. Qed. Definition transportb_twosided_disp_functor_right {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f : x₁ --> x₂} {g g' : y₁ --> y₂} (p : g = g') (fg : xy₁ -->[ f ][ g' ] xy₂) : #2 FG (transportb (λ z, xy₁ -->[ f ][ z ] xy₂) p fg) = transportb (λ z, FG _ _ xy₁ -->[ _ ][ z ] FG _ _ xy₂) (maponpaths (λ z, #G z) p) (#2 FG fg). Proof. induction p. apply idpath. Qed. Definition transportf_twosided_disp_functor_left {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f f' : x₁ --> x₂} (p : f' = f) {g : y₁ --> y₂} (fg : xy₁ -->[ f' ][ g ] xy₂) : #2 FG (transportf (λ z, xy₁ -->[ z ][ g ] xy₂) p fg) = transportf (λ z, FG _ _ xy₁ -->[ z ][ _ ] FG _ _ xy₂) (maponpaths (λ z, #F z) p) (#2 FG fg). Proof. induction p. apply idpath. Qed. Definition transportf_twosided_disp_functor_right {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f : x₁ --> x₂} {g g' : y₁ --> y₂} (p : g' = g) (fg : xy₁ -->[ f ][ g' ] xy₂) : #2 FG (transportf (λ z, xy₁ -->[ f ][ z ] xy₂) p fg) = transportf (λ z, FG _ _ xy₁ -->[ _ ][ z ] FG _ _ xy₂) (maponpaths (λ z, #G z) p) (#2 FG fg). Proof. induction p. apply idpath. Qed. Definition transportf_twosided_disp_functor {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f f' : x₁ --> x₂} (p : f = f') {g g' : y₁ --> y₂} (q : g = g') (fg : xy₁ -->[ f ][ g ] xy₂) : #2 FG (transportf_disp_mor2 p q fg) = transportf_disp_mor2 (maponpaths (λ z, #F z) p) (maponpaths (λ z, #G z) q) (#2 FG fg). Proof. induction p, q. apply idpath. Qed. Definition transportb_twosided_disp_functor {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D₁ x₁ y₁} {xy₂ : D₁ x₂ y₂} {f f' : x₁ --> x₂} (p : f = f') {g g' : y₁ --> y₂} (q : g = g') (fg : xy₁ -->[ f' ][ g' ] xy₂) : #2 FG (transportb_disp_mor2 p q fg) = transportb_disp_mor2 (maponpaths (λ z, #F z) p) (maponpaths (λ z, #G z) q) (#2 FG fg). Proof. induction p, q. apply idpath. Qed. (** 3. The total functor *) Section TotalFunctor. Context {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂). Definition total_twosided_disp_functor_data : functor_data (total_twosided_disp_category D₁) (total_twosided_disp_category D₂). Proof. use make_functor_data. - exact (λ xy, F (pr1 xy) ,, G (pr12 xy) ,, FG _ _ (pr22 xy)). - exact (λ xy₁ xy₂ fg, #F (pr1 fg) ,, #G (pr12 fg) ,, #2 FG (pr22 fg)). Defined. Definition total_twosided_disp_functor_is_functor : is_functor total_twosided_disp_functor_data. Proof. split. - intro ; intros ; cbn. use total2_paths_2_b. + apply functor_id. + apply functor_id. + apply twosided_disp_functor_id. - intro ; intros ; cbn. use total2_paths_2_b. + apply functor_comp. + apply functor_comp. + apply twosided_disp_functor_comp. Qed. Definition total_twosided_disp_functor : total_twosided_disp_category D₁ ⟶ total_twosided_disp_category D₂. Proof. use make_functor. - exact total_twosided_disp_functor_data. - exact total_twosided_disp_functor_is_functor. Defined. End TotalFunctor. (** 4. The identity *) Section IdFunctor. Context {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂). Definition twosided_disp_functor_identity_data : twosided_disp_functor_data (functor_identity C₁) (functor_identity C₂) D D. Proof. simple refine (_ ,, _). - exact (λ x y xy, xy). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg, fg). Defined. Definition twosided_disp_functor_identity_laws : twosided_disp_functor_laws _ _ _ _ twosided_disp_functor_identity_data. Proof. split. - intros x y xy ; cbn. apply idpath. - intros x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ g₁ fg₁ f₂ g₂ fg₂ ; cbn. apply idpath. Qed. Definition twosided_disp_functor_identity : twosided_disp_functor (functor_identity C₁) (functor_identity C₂) D D. Proof. simple refine (_ ,, _). - exact twosided_disp_functor_identity_data. - exact twosided_disp_functor_identity_laws. Defined. End IdFunctor. (** 5. Composition *) Section CompFunctor. Context {C₁ C₁' C₁'' C₂ C₂' C₂'' : category} {F : C₁ ⟶ C₁'} {F' : C₁' ⟶ C₁''} {G : C₂ ⟶ C₂'} {G' : C₂' ⟶ C₂''} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {D'' : twosided_disp_cat C₁'' C₂''} (FG : twosided_disp_functor F G D D') (FG' : twosided_disp_functor F' G' D' D''). Definition comp_twosided_disp_functor_data : twosided_disp_functor_data (F ∙ F') (G ∙ G') D D''. Proof. simple refine (_ ,, _). - exact (λ x y xy, FG' _ _ (FG _ _ xy)). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg, #2 FG' (#2 FG fg)). Defined. Definition comp_twosided_disp_functor_laws : twosided_disp_functor_laws _ _ _ _ comp_twosided_disp_functor_data. Proof. split. - intro ; intros ; cbn. rewrite twosided_disp_functor_id. rewrite transportb_twosided_disp_functor. rewrite twosided_disp_functor_id. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. - intro ; intros ; cbn. rewrite twosided_disp_functor_comp. rewrite transportb_twosided_disp_functor. rewrite twosided_disp_functor_comp. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. Qed. Definition comp_twosided_disp_functor : twosided_disp_functor (F ∙ F') (G ∙ G') D D''. Proof. simple refine (_ ,, _). - exact comp_twosided_disp_functor_data. - exact comp_twosided_disp_functor_laws. Defined. End CompFunctor. (** 6. Functors between discrete two-sided displayed categories form a set *) Definition isaset_twosided_disp_functor_to_discrete {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} (D₁ : twosided_disp_cat C₁ C₂) {D₂ : twosided_disp_cat C₁' C₂'} (HD : discrete_twosided_disp_cat D₂) : isaset (twosided_disp_functor F G D₁ D₂). Proof. use isaset_total2. - use isaset_total2. + repeat (use impred_isaset ; intro). apply isaset_discrete_twosided_cat_ob. exact HD. + intro. repeat (use impred_isaset ; intro). apply isaset_disp_mor. - intro. apply isasetaprop. apply isaprop_twosided_disp_functor_laws. Qed. (** 7. Two-sided displayed functors versus displayed functors *) Section ToDispFunctor. Context {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D₁ D₂). Definition two_sided_disp_functor_to_disp_functor_data : disp_functor_data (pair_functor F G) (twosided_disp_cat_to_disp_cat _ _ D₁) (twosided_disp_cat_to_disp_cat _ _ D₂). Proof. simple refine (_ ,, _). - exact (λ xy, FG (pr1 xy) (pr2 xy)). - exact (λ x₁ x₂ xx₁ xx₂ f ff, #2 FG ff). Defined. Proposition two_sided_disp_functor_to_disp_functor_axioms : disp_functor_axioms two_sided_disp_functor_to_disp_functor_data. Proof. split. - intros x xx ; cbn. rewrite twosided_disp_functor_id. unfold transportb_disp_mor2, transportf_disp_mor2. rewrite twosided_prod_transport. unfold transportb. apply maponpaths_2. apply isasetdirprod ; apply homset_property. - intros x y z xx yy zz f g ff gg ; cbn. rewrite twosided_disp_functor_comp. unfold transportb_disp_mor2, transportf_disp_mor2. rewrite twosided_prod_transport. unfold transportb. apply maponpaths_2. apply isasetdirprod ; apply homset_property. Qed. Definition two_sided_disp_functor_to_disp_functor : disp_functor (pair_functor F G) (twosided_disp_cat_to_disp_cat _ _ D₁) (twosided_disp_cat_to_disp_cat _ _ D₂). Proof. simple refine (_ ,, _). - exact two_sided_disp_functor_to_disp_functor_data. - exact two_sided_disp_functor_to_disp_functor_axioms. Defined. End ToDispFunctor. Section FromDispFunctor. Context {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D₁ : twosided_disp_cat C₁ C₂} {D₂ : twosided_disp_cat C₁' C₂'} (FG : disp_functor (pair_functor F G) (twosided_disp_cat_to_disp_cat _ _ D₁) (twosided_disp_cat_to_disp_cat _ _ D₂)). Definition disp_functor_to_two_sided_disp_functor_data : twosided_disp_functor_data F G D₁ D₂. Proof. simple refine (_ ,, _). - exact (λ x y xy, FG (x ,, y) xy). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg, @disp_functor_on_morphisms _ _ _ _ _ FG (x₁ ,, y₁) (x₂ ,, y₂) xy₁ xy₂ (f ,, g) fg). Defined. Proposition disp_functor_to_two_sided_disp_functor_axioms : twosided_disp_functor_laws F G D₁ D₂ disp_functor_to_two_sided_disp_functor_data. Proof. split. - intros x y xy ; cbn. etrans. { exact (@disp_functor_id _ _ _ _ _ FG (x ,, y) xy). } unfold transportb_disp_mor2, transportf_disp_mor2. rewrite twosided_prod_transport. unfold transportb. apply maponpaths_2. apply isasetdirprod ; apply homset_property. - intros x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ g₁ fg₁ f₂ g₂ fg₂ ; cbn. etrans. { exact (@disp_functor_comp _ _ _ _ _ FG (x₁ ,, y₁) (x₂ ,, y₂) (x₃ ,, y₃) xy₁ xy₂ xy₃ (f₁ ,, g₁) (f₂ ,, g₂) fg₁ fg₂). } unfold transportb_disp_mor2, transportf_disp_mor2. rewrite twosided_prod_transport. unfold transportb. apply maponpaths_2. apply isasetdirprod ; apply homset_property. Qed. Definition disp_functor_to_two_sided_disp_functor : twosided_disp_functor F G D₁ D₂. Proof. simple refine (_ ,, _). - exact disp_functor_to_two_sided_disp_functor_data. - exact disp_functor_to_two_sided_disp_functor_axioms. Defined. End FromDispFunctor. Definition two_sided_disp_functor_weq_disp_functor {C₁ C₁' C₂ C₂' : category} (F : C₁ ⟶ C₁') (G : C₂ ⟶ C₂') (D₁ : twosided_disp_cat C₁ C₂) (D₂ : twosided_disp_cat C₁' C₂') : twosided_disp_functor F G D₁ D₂ ≃ disp_functor (pair_functor F G) (twosided_disp_cat_to_disp_cat _ _ D₁) (twosided_disp_cat_to_disp_cat _ _ D₂). Proof. use weq_iso. - exact two_sided_disp_functor_to_disp_functor. - exact disp_functor_to_two_sided_disp_functor. - abstract (intros FG ; use subtypePath ; [ intro ; apply isaprop_twosided_disp_functor_laws | ] ; apply idpath). - abstract (intros FG ; use subtypePath ; [ intro ; apply isaprop_disp_functor_axioms | ] ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/DisplayedNatTrans.v000066400000000000000000000423161451125700300276060ustar00rootroot00000000000000(********************************************************************************** Natural transformations of two-sided displayed categories We define natural transformations between functors on two-sided diplayed categories. In addition, we prove an equality principle (if two such natural transformations are pointwise equal, then they are actually equal), and we give the necessary constructions. Contents 1. Natural transformations of two-sided displayed categories 2. Equality principle 3. The total natural transformation 4. The identity transformation 5. Composition of transformations 6. Prewhiskering 7. Postwhiskering 8. Displayed two-sided natural transformations versus one-sided ones **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Functors. Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Local Open Scope cat. (** 1. Natural transformations of two-sided displayed categories *) Section DisplayedNatTrans. Context {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} (τ : F ⟹ F') {G G' : C₂ ⟶ C₂'} (θ : G ⟹ G') {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor_data F G D D') (FG' : twosided_disp_functor_data F' G' D D'). Definition twosided_disp_nat_trans_data : UU := ∏ (x : C₁) (y : C₂) (xy : D x y), FG _ _ xy -->[ τ x ][ θ y ] FG' _ _ xy. Definition twosided_disp_nat_trans_laws (τθ : twosided_disp_nat_trans_data) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (fg : xy₁ -->[ f ][ g ] xy₂), #2 FG fg ;;2 τθ _ _ xy₂ = transportb_disp_mor2 (nat_trans_ax τ _ _ f) (nat_trans_ax θ _ _ g) (τθ _ _ xy₁ ;;2 #2 FG' fg). Definition twosided_disp_nat_trans : UU := ∑ (τθ : twosided_disp_nat_trans_data), twosided_disp_nat_trans_laws τθ. Definition twosided_disp_nat_trans_ob (τθ : twosided_disp_nat_trans) {x : C₁} {y : C₂} (xy : D x y) : FG _ _ xy -->[ τ x ][ θ y ] FG' _ _ xy := pr1 τθ x y xy. Coercion twosided_disp_nat_trans_ob : twosided_disp_nat_trans >-> Funclass. Proposition twosided_disp_nat_trans_ax (τθ : twosided_disp_nat_trans) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : #2 FG fg ;;2 τθ _ _ xy₂ = transportb_disp_mor2 (nat_trans_ax τ _ _ f) (nat_trans_ax θ _ _ g) (τθ _ _ xy₁ ;;2 #2 FG' fg). Proof. apply (pr2 τθ). Qed. Proposition isaprop_twosided_disp_nat_trans_laws (τθ : twosided_disp_nat_trans_data) : isaprop (twosided_disp_nat_trans_laws τθ). Proof. repeat (use impred ; intro). apply D'. Qed. Proposition isaset_twosided_disp_nat_trans : isaset twosided_disp_nat_trans. Proof. use isaset_total2. - use impred_isaset ; intro x. use impred_isaset ; intro y. use impred_isaset ; intro xy. apply D'. - intro. apply isasetaprop. exact (isaprop_twosided_disp_nat_trans_laws _). Qed. End DisplayedNatTrans. (** 2. Equality principle *) Definition eq_twosided_disp_nat_trans {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {G G' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {FG : twosided_disp_functor_data F G D D'} {FG' : twosided_disp_functor_data F' G' D D'} {τθ τθ' : twosided_disp_nat_trans τ θ FG FG'} (p : ∏ (x : C₁) (y : C₂) (xy : D x y), τθ x y xy = τθ' x y xy) : τθ = τθ'. Proof. use subtypePath. { intro. repeat (use impred ; intro). apply isaset_disp_mor. } use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro xy. apply p. Qed. (** 3. The total natural transformation *) Section TotalNatTrans. Context {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {G G' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {FG : twosided_disp_functor F G D D'} {FG' : twosided_disp_functor F' G' D D'} (τθ : twosided_disp_nat_trans τ θ FG FG'). Definition total_twosided_disp_nat_trans_data : nat_trans_data (total_twosided_disp_functor FG) (total_twosided_disp_functor FG') := λ x, τ (pr1 x) ,, θ (pr12 x) ,, τθ _ _ (pr22 x). Definition total_twosided_disp_nat_trans_laws : is_nat_trans _ _ total_twosided_disp_nat_trans_data. Proof. intros x y f. use total2_paths_2_b. - apply nat_trans_ax. - apply nat_trans_ax. - apply τθ. Qed. Definition total_twosided_disp_nat_trans : total_twosided_disp_functor FG ⟹ total_twosided_disp_functor FG'. Proof. use make_nat_trans. - exact total_twosided_disp_nat_trans_data. - exact total_twosided_disp_nat_trans_laws. Defined. End TotalNatTrans. (** 4. The identity transformation *) Section IdNatTrans. Context {C₁ C₁' C₂ C₂' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D D'). Definition id_twosided_disp_nat_trans_data : twosided_disp_nat_trans_data (nat_trans_id F) (nat_trans_id G) FG FG := λ x y xy, id_two_disp _. Arguments id_twosided_disp_nat_trans_data /. Definition id_twosided_disp_nat_trans_laws : twosided_disp_nat_trans_laws _ _ _ _ id_twosided_disp_nat_trans_data. Proof. intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn. rewrite id_two_disp_right, id_two_disp_left. rewrite transport_b_b_disp_mor2. use transportb_disp_mor2_eq. apply idpath. Qed. Definition id_twosided_disp_nat_trans : twosided_disp_nat_trans (nat_trans_id F) (nat_trans_id G) FG FG. Proof. simple refine (_ ,, _). - exact id_twosided_disp_nat_trans_data. - exact id_twosided_disp_nat_trans_laws. Defined. End IdNatTrans. Arguments id_twosided_disp_nat_trans_data {C₁ C₁' C₂ C₂' F G D D'} FG /. Arguments id_twosided_disp_nat_trans {C₁ C₁' C₂ C₂' F G D D'} FG /. (** 5. Composition of transformations *) Section CompNatTrans. Context {C₁ C₁' C₂ C₂' : category} {F F' F'' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {τ' : F' ⟹ F''} {G G' G'' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {θ' : G' ⟹ G''} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {FG : twosided_disp_functor F G D D'} {FG' : twosided_disp_functor F' G' D D'} {FG'' : twosided_disp_functor F'' G'' D D'} (τθ : twosided_disp_nat_trans τ θ FG FG') (τθ' : twosided_disp_nat_trans τ' θ' FG' FG''). Definition comp_twosided_disp_nat_trans_data : twosided_disp_nat_trans_data (nat_trans_comp _ _ _ τ τ') (nat_trans_comp _ _ _ θ θ') FG FG'' := λ x y xy, τθ _ _ xy ;;2 τθ' _ _ xy. Arguments comp_twosided_disp_nat_trans_data /. Definition comp_twosided_disp_nat_trans_laws : twosided_disp_nat_trans_laws _ _ _ _ comp_twosided_disp_nat_trans_data. Proof. intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn. rewrite assoc_two_disp. rewrite (pr2 τθ). rewrite two_disp_pre_whisker_b. rewrite transport_b_b_disp_mor2. rewrite assoc_two_disp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (pr2 τθ'). rewrite two_disp_post_whisker_b. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Definition comp_twosided_disp_nat_trans : twosided_disp_nat_trans (nat_trans_comp _ _ _ τ τ') (nat_trans_comp _ _ _ θ θ') FG FG''. Proof. simple refine (_ ,, _). - exact comp_twosided_disp_nat_trans_data. - exact comp_twosided_disp_nat_trans_laws. Defined. End CompNatTrans. Arguments comp_twosided_disp_nat_trans_data {C₁ C₁' C₂ C₂' F F' F'' τ τ' G G' G'' θ θ' D D' FG FG' FG''} _ _ /. Arguments comp_twosided_disp_nat_trans {C₁ C₁' C₂ C₂' F F' F'' τ τ' G G' G'' θ θ' D D' FG FG' FG''} _ _ /. (** 6. Prewhiskering *) Section Prewhisker. Context {C₁ C₁' C₁'' C₂ C₂' C₂'' : category} {F : C₁ ⟶ C₁'} {G : C₂ ⟶ C₂'} {H H' : C₁' ⟶ C₁''} {τ : H ⟹ H'} {K K' : C₂' ⟶ C₂''} {θ : K ⟹ K'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {D'' : twosided_disp_cat C₁'' C₂''} (FG : twosided_disp_functor F G D D') {HK : twosided_disp_functor H K D' D''} {HK' : twosided_disp_functor H' K' D' D''} (τθ : twosided_disp_nat_trans τ θ HK HK'). Definition pre_whisker_twosided_disp_nat_trans_data : twosided_disp_nat_trans_data (pre_whisker F τ : F ∙ H ⟹ F ∙ H') (pre_whisker G θ : G ∙ K ⟹ G ∙ K') (comp_twosided_disp_functor FG HK) (comp_twosided_disp_functor FG HK') := λ x y xy, τθ _ _ (FG _ _ xy). Arguments pre_whisker_twosided_disp_nat_trans_data /. Definition pre_whisker_twosided_disp_nat_trans_laws : twosided_disp_nat_trans_laws _ _ _ _ pre_whisker_twosided_disp_nat_trans_data. Proof. intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn. rewrite (pr2 τθ). use transportf_disp_mor2_eq. apply idpath. Qed. Definition pre_whisker_twosided_disp_nat_trans : twosided_disp_nat_trans (pre_whisker F τ : F ∙ H ⟹ F ∙ H') (pre_whisker G θ : G ∙ K ⟹ G ∙ K') (comp_twosided_disp_functor FG HK) (comp_twosided_disp_functor FG HK'). Proof. simple refine (_ ,, _). - exact pre_whisker_twosided_disp_nat_trans_data. - exact pre_whisker_twosided_disp_nat_trans_laws. Defined. End Prewhisker. Arguments pre_whisker_twosided_disp_nat_trans_data {C₁ C₁' C₁'' C₂ C₂' C₂'' F G H H' τ K K' θ D D' D''} FG {HK HK'} _ /. Arguments pre_whisker_twosided_disp_nat_trans {C₁ C₁' C₁'' C₂ C₂' C₂'' F G H H' τ K K' θ D D' D''} FG {HK HK'} _ /. (** 7. Postwhiskering *) Section Postwhisker. Context {C₁ C₁' C₁'' C₂ C₂' C₂'' : category} {F F' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {G G' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {H : C₁' ⟶ C₁''} {K : C₂' ⟶ C₂''} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {D'' : twosided_disp_cat C₁'' C₂''} (FG : twosided_disp_functor F G D D') (FG' : twosided_disp_functor F' G' D D') {HK : twosided_disp_functor H K D' D''} (τθ : twosided_disp_nat_trans τ θ FG FG'). Definition post_whisker_twosided_disp_nat_trans_data : twosided_disp_nat_trans_data (post_whisker τ H : F ∙ H ⟹ F' ∙ H) (post_whisker θ K : G ∙ K ⟹ G' ∙ K) (comp_twosided_disp_functor FG HK) (comp_twosided_disp_functor FG' HK) := λ x y xy, #2 HK (τθ _ _ xy). Arguments post_whisker_twosided_disp_nat_trans_data /. Definition post_whisker_twosided_disp_nat_trans_laws : twosided_disp_nat_trans_laws _ _ _ _ post_whisker_twosided_disp_nat_trans_data. Proof. intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn. rewrite !twosided_disp_functor_comp_alt. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. rewrite (pr2 τθ). rewrite transportb_twosided_disp_functor. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. use transportf_disp_mor2_eq. apply idpath. Qed. Definition post_whisker_twosided_disp_nat_trans : twosided_disp_nat_trans (post_whisker τ H : F ∙ H ⟹ F' ∙ H) (post_whisker θ K : G ∙ K ⟹ G' ∙ K) (comp_twosided_disp_functor FG HK) (comp_twosided_disp_functor FG' HK). Proof. simple refine (_ ,, _). - exact post_whisker_twosided_disp_nat_trans_data. - exact post_whisker_twosided_disp_nat_trans_laws. Defined. End Postwhisker. Arguments post_whisker_twosided_disp_nat_trans_data {C₁ C₁' C₁'' C₂ C₂' C₂'' F F' τ G G' θ H K D D' D'' FG FG'} HK _ /. Arguments post_whisker_twosided_disp_nat_trans {C₁ C₁' C₁'' C₂ C₂' C₂'' F F' τ G G' θ H K D D' D'' FG FG'} HK _ /. (** 8. Displayed two-sided natural transformations versus one-sided ones *) Definition twosided_disp_nat_trans_to_disp_nat_trans {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {G G' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {FG : twosided_disp_functor F G D D'} {FG' : twosided_disp_functor F' G' D D'} (τθ : twosided_disp_nat_trans τ θ FG FG') : disp_nat_trans (pair_nat_trans τ θ) (two_sided_disp_functor_to_disp_functor FG) (two_sided_disp_functor_to_disp_functor FG'). Proof. refine ((λ x xx, τθ (pr1 x) (pr2 x) xx) ,, _). abstract (intros x y xx yy f ff ; cbn ; rewrite twosided_disp_nat_trans_ax ; unfold transportb_disp_mor2, transportf_disp_mor2 ; rewrite twosided_prod_transport ; unfold transportb ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition twosided_disp_nat_trans_from_disp_nat_trans {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} {τ : F ⟹ F'} {G G' : C₂ ⟶ C₂'} {θ : G ⟹ G'} {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} {FG : twosided_disp_functor F G D D'} {FG' : twosided_disp_functor F' G' D D'} (τθ : disp_nat_trans (pair_nat_trans τ θ) (two_sided_disp_functor_to_disp_functor FG) (two_sided_disp_functor_to_disp_functor FG')) : twosided_disp_nat_trans τ θ FG FG'. Proof. refine ((λ x y xy, τθ (x ,, y) xy) ,, _). abstract (intros x₁ x₂ y₁ y₂ f g xy₁ xy₂ fg ; cbn ; pose (@disp_nat_trans_ax _ _ _ _ _ _ _ _ _ τθ (x₁ ,, y₁) (x₂ ,, y₂) (f ,, g) xy₁ xy₂ fg) as p ; cbn in p ; rewrite p ; unfold transportb_disp_mor2, transportf_disp_mor2 ; rewrite twosided_prod_transport ; unfold transportb ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition twosided_disp_nat_trans_weq_disp_nat_trans {C₁ C₁' C₂ C₂' : category} {F F' : C₁ ⟶ C₁'} (τ : F ⟹ F') {G G' : C₂ ⟶ C₂'} (θ : G ⟹ G') {D : twosided_disp_cat C₁ C₂} {D' : twosided_disp_cat C₁' C₂'} (FG : twosided_disp_functor F G D D') (FG' : twosided_disp_functor F' G' D D') : twosided_disp_nat_trans τ θ FG FG' ≃ disp_nat_trans (pair_nat_trans τ θ) (two_sided_disp_functor_to_disp_functor FG) (two_sided_disp_functor_to_disp_functor FG'). Proof. use weq_iso. - exact twosided_disp_nat_trans_to_disp_nat_trans. - exact twosided_disp_nat_trans_from_disp_nat_trans. - abstract (intros τθ ; use subtypePath ; [ intro ; apply isaprop_twosided_disp_nat_trans_laws | ] ; apply idpath). - abstract (intros τθ ; use subtypePath ; [ intro ; apply isaprop_disp_nat_trans_axioms | ] ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/000077500000000000000000000000001451125700300255765ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Arrow.v000066400000000000000000000162701451125700300270650ustar00rootroot00000000000000(********************************************************************************** The arrow category Contents 1. Definition via two-sided displayed categories 2. Discreteness and univalence 3. It is a two-sided fibration **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Local Open Scope cat. Section ArrowTwoSidedDispCat. Context (C : category). (** 1. Definition via two-sided displayed categories *) Definition arrow_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C C. Proof. simple refine (_ ,, _). - exact (λ x y, x --> y). - exact (λ x₁ x₂ y₁ y₂ h₁ h₂ f g, f · h₂ = h₁ · g). Defined. Definition arrow_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp arrow_twosided_disp_cat_ob_mor. Proof. split. - intros x y xy ; cbn. rewrite id_left, id_right. apply idpath. - intros x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ p q ; cbn in *. rewrite assoc'. rewrite q. rewrite !assoc. apply maponpaths_2. exact p. Qed. Definition arrow_twosided_disp_cat_data : twosided_disp_cat_data C C. Proof. simple refine (_ ,, _). - exact arrow_twosided_disp_cat_ob_mor. - exact arrow_twosided_disp_cat_id_comp. Defined. Definition isaprop_arrow_twosided_mor {x₁ x₂ : C} {y₁ y₂ : C} (xy₁ : arrow_twosided_disp_cat_data x₁ y₁) (xy₂ : arrow_twosided_disp_cat_data x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) : isaprop (xy₁ -->[ f ][ g ] xy₂). Proof. apply homset_property. Qed. Definition arrow_twosided_disp_cat_axioms : twosided_disp_cat_axioms arrow_twosided_disp_cat_data. Proof. repeat split. - intro ; intros. apply isaprop_arrow_twosided_mor. - intro ; intros. apply isaprop_arrow_twosided_mor. - intro ; intros. apply isaprop_arrow_twosided_mor. - intro ; intros. apply isasetaprop. apply isaprop_arrow_twosided_mor. Qed. Definition arrow_twosided_disp_cat : twosided_disp_cat C C. Proof. simple refine (_ ,, _). - exact arrow_twosided_disp_cat_data. - exact arrow_twosided_disp_cat_axioms. Defined. (** 2. Discreteness and univalence *) Definition arrow_twosided_disp_cat_is_iso : all_disp_mor_iso arrow_twosided_disp_cat. Proof. intro ; intros. simple refine (_ ,, _ ,, _) ; cbn in *. - use z_iso_inv_on_right. rewrite assoc. use z_iso_inv_on_left ; cbn. exact fg. - apply isaprop_arrow_twosided_mor. - apply isaprop_arrow_twosided_mor. Qed. Definition is_univalent_arrow_twosided_disp_cat : is_univalent_twosided_disp_cat arrow_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. pose (p := pr1 f) ; cbn in p. rewrite id_left, id_right in p. exact (!p). - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply homset_property. Qed. Definition discrete_arrow_twosided_disp_cat : discrete_twosided_disp_cat arrow_twosided_disp_cat. Proof. repeat split. - intro ; intros. apply homset_property. - exact arrow_twosided_disp_cat_is_iso. - exact is_univalent_arrow_twosided_disp_cat. Qed. (** 3. It is a two-sided fibration *) Definition arrow_twosided_opcleaving : twosided_opcleaving arrow_twosided_disp_cat. Proof. intros x₁ x₂ x₃ f g ; cbn in *. simple refine (f · g ,, _ ,, _) ; cbn. - apply id_left. - intros x₄ x₅ h k l p. use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaset_disp_mor. } apply isaprop_arrow_twosided_mor. + simple refine (_ ,, _). * cbn in *. rewrite id_left, assoc in p. exact p. * apply isaprop_arrow_twosided_mor. Qed. Definition arrow_twosided_cleaving : twosided_cleaving arrow_twosided_disp_cat. Proof. intros x₁ x₂ x₃ f g ; cbn in *. simple refine (g · f ,, _ ,, _) ; cbn. - rewrite id_right. apply idpath. - intros x₄ x₅ h k l p. use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaset_disp_mor. } apply isaprop_arrow_twosided_mor. + cbn in *. simple refine (_ ,, _). * rewrite id_right, assoc' in p. exact p. * apply isaprop_arrow_twosided_mor. Qed. Definition arrow_twosided_fibration : twosided_fibration arrow_twosided_disp_cat. Proof. simple refine (_ ,, _ ,, _). - exact arrow_twosided_opcleaving. - exact arrow_twosided_cleaving. - intro ; intros. apply arrow_twosided_disp_cat_is_iso. Defined. End ArrowTwoSidedDispCat. Section ArrowTwoSidedDispCatFunctor. Context {C : category} (D : discrete_twosided_fibration C C) (idD : ∏ (x : C), D x x) (f_idD : ∏ (x₁ x₂ : C) (f : x₁ --> x₂), idD x₁ -->[ f ][ f ] idD x₂). Definition arrow_to_discrete_twosided_fibration_data : twosided_disp_functor_data (functor_identity C) (functor_identity C) (arrow_twosided_disp_cat C) D. Proof. simple refine (_ ,, _). - exact (λ x y f, discrete_twosided_cleaving_ob _ (pr122 D) (idD y) f). - cbn ; intros x₁ x₂ y₁ y₂ g₁ g₂ f₁ f₂ p. use discrete_twosided_cleaving_cartesian. refine (transportb (λ z, _ -->[ z ][ _ ] _) p (transportb (λ z, _ -->[ _ ][ z ] _) (id_right _ @ !(id_left _)) (discrete_twosided_cleaving_mor (pr1 D) (pr122 D) (idD y₁) g₁ ;;2 _))). apply f_idD. Defined. Definition arrow_to_discrete_twosided_fibration_laws : twosided_disp_functor_laws _ _ _ _ arrow_to_discrete_twosided_fibration_data. Proof. split ; intro ; intros ; apply D. Qed. Definition arrow_to_discrete_twosided_fibration : twosided_disp_functor (functor_identity C) (functor_identity C) (arrow_twosided_disp_cat C) D. Proof. simple refine (_ ,, _). - exact arrow_to_discrete_twosided_fibration_data. - exact arrow_to_discrete_twosided_fibration_laws. Defined. End ArrowTwoSidedDispCatFunctor. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Bimodules.v000066400000000000000000000152541451125700300277170ustar00rootroot00000000000000(********************************************************************************** The category of bimodules Let `R₁` and `R₂` be rings. A bimodule `B` from `R₁` to `R₂` is an abelian group together with a linear biaction of `R₁` and `R₂` on `B`. In this file, we define the category of bimodules using two-sided displayed categories. Contents 1. Definition via two-sided displayed categories 2. Univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Groups. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.abgrs. Require Import UniMath.CategoryTheory.categories.commrings. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat. Local Open Scope cat. (** 1. Definition via two-sided displayed categories *) Definition bimodule_abgr : twosided_disp_cat commring_category commring_category := constant_twosided_disp_cat _ _ abgr_category. Definition action_on_bimodule_ob_mor : disp_cat_ob_mor (total_twosided_disp_category bimodule_abgr). Proof. simple refine (_ ,, _). - exact (λ B, let R₁ := (pr1 B : commring) in let G := (pr22 B : abgr) in let R₂ := (pr12 B : commring) in R₁ → G → R₂ → G). - cbn. exact (λ B₁ B₂, let R₁ := (pr1 B₁ : commring) in let G := (pr22 B₁ : abgr) in let R₂ := (pr12 B₁ : commring) in let S₁ := (pr1 B₂ : commring) in let H := (pr22 B₂ : abgr) in let S₂ := (pr12 B₂ : commring) in λ (μ₁ : R₁ → G → R₂ → G) (μ₂ : S₁ → H → S₂ → H) f, let f₁ := (pr1 f : R₁ → S₁) in let f₂ := (pr12 f : R₂ → S₂) in let g := (pr22 f : G → H) in ∏ (x : R₁) (y : G) (z : R₂), g (μ₁ x y z) = μ₂ (f₁ x) (g y) (f₂ z)). Defined. Definition action_on_bimodule_id_comp : disp_cat_id_comp (total_twosided_disp_category bimodule_abgr) action_on_bimodule_ob_mor. Proof. split. - intros B μ x y z ; cbn in *. apply idpath. - intros B₁ B₂ B₃ f g μ₁ μ₂ μ₃ p q x y z ; cbn in *. rewrite p. rewrite q. apply idpath. Qed. Definition action_on_bimodule_data : disp_cat_data (total_twosided_disp_category bimodule_abgr). Proof. simple refine (_ ,, _). - exact action_on_bimodule_ob_mor. - exact action_on_bimodule_id_comp. Defined. Definition action_on_bimodule_axioms : disp_cat_axioms (total_twosided_disp_category bimodule_abgr) action_on_bimodule_data. Proof. repeat split. - intros B₁ B₂ ; intros. repeat (use funextsec ; intro). apply (pr11 (pr22 B₂)). - intros B₁ B₂ ; intros. repeat (use funextsec ; intro). apply (pr11 (pr22 B₂)). - intros B₁ B₂ B₃ B₄ ; intros. repeat (use funextsec ; intro). apply (pr11 (pr22 B₄)). - intros B₁ B₂ ; intros. apply isasetaprop. repeat (use impred ; intro). apply (pr11 (pr22 B₂)). Qed. Definition action_on_bimodule : disp_cat (total_twosided_disp_category bimodule_abgr). Proof. simple refine (_ ,, _). - exact action_on_bimodule_data. - exact action_on_bimodule_axioms. Defined. Definition bimodule_action : twosided_disp_cat commring_category commring_category := sigma_twosided_disp_cat _ action_on_bimodule. Definition bimodule_laws {R S : commring} {G : abgr} (μ : R → G → S → G) : UU := (∏ (x : G), μ 1 x 1 = x)%ring × (∏ (r₁ r₂ : R) (s₁ s₂ : S) (x : G), μ (r₁ * r₂)%ring x (s₁ * s₂)%ring = μ r₁ (μ r₂ x s₁) s₂) × (∏ (r₁ r₂ : R) (s : S) (x : G), op (μ r₁ x s) (μ r₂ x s) = μ (r₁ + r₂)%ring x s) × (∏ (r : R) (s : S) (x₁ x₂ : G), op (μ r x₁ s) (μ r x₂ s) = μ r (op x₁ x₂) s) × (∏ (r : R) (s₁ s₂ : S) (x : G), op (μ r x s₁) (μ r x s₂) = μ r x (s₁ + s₂)%ring). Definition isaprop_bimodule_laws {R S : commring} {G : abgr} (μ : R → G → S → G) : isaprop (bimodule_laws μ). Proof. repeat (apply isapropdirprod) ; repeat (apply impred ; intro) ; apply (pr11 G). Qed. Definition disp_cat_bimodule_laws : disp_cat (total_twosided_disp_category bimodule_action). Proof. use disp_full_sub. exact (λ X, bimodule_laws (pr222 X)). Defined. Definition bimodule_twosided_disp_cat : twosided_disp_cat commring_category commring_category := sigma_twosided_disp_cat _ disp_cat_bimodule_laws. (** 2. Univalence *) Definition is_univalent_action_on_bimodule : is_univalent_disp action_on_bimodule. Proof. intros B₁ B₂ p μ₁ μ₂. induction p. use isweqimplimpl. - cbn ; intro f. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro z. exact (pr1 f x y z). - cbn in * ; repeat (use funspace_isaset). apply (pr11 (pr22 B₁)). - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. repeat (use funextsec ; intro). apply (pr11 (pr22 B₁)). Qed. Definition is_univalent_disp_cat_bimodule_laws : is_univalent_disp disp_cat_bimodule_laws. Proof. use disp_full_sub_univalent. intro. apply isaprop_bimodule_laws. Defined. Definition is_univalent_bimodule_twosided_disp_cat : is_univalent_twosided_disp_cat bimodule_twosided_disp_cat. Proof. use is_univalent_sigma_of_twosided_disp_cat. - use is_univalent_sigma_of_twosided_disp_cat. + use is_univalent_constant_twosided_disp_cat. exact abgr_category_is_univalent. + exact is_univalent_action_on_bimodule. - exact is_univalent_disp_cat_bimodule_laws. Qed. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Comma.v000066400000000000000000000146211451125700300270250ustar00rootroot00000000000000(********************************************************************************** The comma category Contents 1. Definition via two-sided displayed categories 2. Discreteness and univalence 3. It is a two-sided fibration 4. The representable profunctors **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Local Open Scope cat. Section CommaTwoSidedDispCat. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃). (** 1. Definition via two-sided displayed categories *) Definition comma_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, F x --> G y). - exact (λ x₁ x₂ y₁ y₂ h₁ h₂ f g, #F f · h₂ = h₁ · #G g). Defined. Definition comma_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp comma_twosided_disp_cat_ob_mor. Proof. split. - intros x y xy ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - intros x₁ x₂ x₃ y₁ y₂ y₃ h₁ h₂ h₃ f₁ f₂ g₁ g₂ hh₁ hh₂ ; cbn in *. rewrite !functor_comp. rewrite !assoc'. rewrite hh₂. rewrite !assoc. apply maponpaths_2. exact hh₁. Qed. Definition comma_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact comma_twosided_disp_cat_ob_mor. - exact comma_twosided_disp_cat_id_comp. Defined. Definition isaprop_comma_twosided_mor {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy₁ : comma_twosided_disp_cat_data x₁ y₁) (xy₂ : comma_twosided_disp_cat_data x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) : isaprop (xy₁ -->[ f ][ g ] xy₂). Proof. apply homset_property. Qed. Definition comma_twosided_disp_cat_axioms : twosided_disp_cat_axioms comma_twosided_disp_cat_data. Proof. repeat split. - intro ; intros. apply isaprop_comma_twosided_mor. - intro ; intros. apply isaprop_comma_twosided_mor. - intro ; intros. apply isaprop_comma_twosided_mor. - intro ; intros. apply isasetaprop. apply isaprop_comma_twosided_mor. Qed. Definition comma_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact comma_twosided_disp_cat_data. - exact comma_twosided_disp_cat_axioms. Defined. (** 2. Discreteness and univalence *) Definition comma_twosided_disp_cat_is_iso : all_disp_mor_iso comma_twosided_disp_cat. Proof. intro ; intros. simple refine (_ ,, _ ,, _) ; cbn in *. - rewrite !functor_on_inv_from_z_iso. use z_iso_inv_on_right. rewrite assoc. use z_iso_inv_on_left ; cbn. exact fg. - apply isaprop_comma_twosided_mor. - apply isaprop_comma_twosided_mor. Qed. Definition is_univalent_comma_twosided_disp_cat : is_univalent_twosided_disp_cat comma_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. pose (p := pr1 f) ; cbn in p. rewrite !functor_id in p. rewrite id_left, id_right in p. exact (!p). - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply homset_property. Qed. Definition discrete_comma_twosided_disp_cat : discrete_twosided_disp_cat comma_twosided_disp_cat. Proof. repeat split. - intro ; intros. apply homset_property. - exact comma_twosided_disp_cat_is_iso. - exact is_univalent_comma_twosided_disp_cat. Qed. (** 3. It is a two-sided fibration *) Definition comma_twosided_opcleaving : twosided_opcleaving comma_twosided_disp_cat. Proof. intros x₁ x₂ x₃ f g ; cbn in *. simple refine (f · #G g ,, _ ,, _) ; cbn. - rewrite functor_id. rewrite id_left. apply idpath. - intros x₄ x₅ h k l p. use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaset_disp_mor. } apply isaprop_comma_twosided_mor. + cbn in *. simple refine (_ ,, _). * rewrite id_left, functor_comp, assoc in p. exact p. * apply isaprop_comma_twosided_mor. Qed. Definition comma_twosided_cleaving : twosided_cleaving comma_twosided_disp_cat. Proof. intros x₁ x₂ x₃ f g ; cbn in *. simple refine (#F g · f ,, _ ,, _) ; cbn. - rewrite functor_id. rewrite id_right. apply idpath. - intros x₄ x₅ h k l p. use iscontraprop1. + use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isaset_disp_mor. } apply isaprop_comma_twosided_mor. + cbn in *. simple refine (_ ,, _). * rewrite id_right, functor_comp, assoc' in p. exact p. * apply isaprop_comma_twosided_mor. Qed. Definition comma_twosided_fibration : twosided_fibration comma_twosided_disp_cat. Proof. simple refine (_ ,, _ ,, _). - exact comma_twosided_opcleaving. - exact comma_twosided_cleaving. - intro ; intros. apply comma_twosided_disp_cat_is_iso. Defined. End CommaTwoSidedDispCat. (** 4. The representable profunctors *) Definition left_repr_twosided_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) : twosided_disp_cat C₁ C₂ := comma_twosided_disp_cat F (functor_identity _). Definition right_repr_twosided_disp_cat {C₁ C₂ : category} (F : C₁ ⟶ C₂) : twosided_disp_cat C₂ C₁ := comma_twosided_disp_cat (functor_identity _) F. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Constant.v000066400000000000000000000144121451125700300275600ustar00rootroot00000000000000(********************************************************************************** The constant two-sided displayed category Given categories `C₁, C₂, D`, we define the constant two-sided displayed category over `C₁` and `C₂` as follows: the displayed objects are objects in `D` while the displayed morphisms are morphisms in `D`. Contents 1. Definition via two-sided displayed categories 2. Isomorphisms 3. Univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Local Open Scope cat. Section ConstantTwoSidedDispCat. Context (C₁ C₂ D : category). (** 1. Definition via two-sided displayed categories *) Definition constant_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ _ _, D). - exact (λ _ _ _ _ z₁ z₂ _ _, z₁ --> z₂). Defined. Definition constant_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp constant_twosided_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ _ _ _, identity _). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂, h₁ · h₂). Defined. Definition constant_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact constant_twosided_disp_cat_ob_mor. - exact constant_twosided_disp_cat_id_comp. Defined. Definition constant_twosided_disp_cat_axioms : twosided_disp_cat_axioms constant_twosided_disp_cat_data. Proof. repeat split. - intro ; intros ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn in *. rewrite !transportf_const ; cbn. apply id_left. - intro ; intros ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn in *. rewrite !transportf_const ; cbn. apply id_right. - intro ; intros ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn in *. rewrite !transportf_const ; cbn. apply assoc. - intro ; intros. apply homset_property. Qed. Definition constant_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact constant_twosided_disp_cat_data. - exact constant_twosided_disp_cat_axioms. Defined. (** 2. Isomorphisms *) Definition to_is_twosided_disp_cat_iso_constant (x : C₁) (y : C₂) {z₁ z₂ : D} (f : z₁ --> z₂) (Hf : is_z_isomorphism f) : @is_iso_twosided_disp _ _ constant_twosided_disp_cat _ _ _ _ _ _ _ _ (identity_is_z_iso x) (identity_is_z_iso y) f. Proof. pose (f_iso := (f ,, Hf) : z_iso _ _). simple refine (_ ,, _ ,, _). - exact (inv_from_z_iso f_iso). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_const ; apply Hf). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_const ; apply Hf). Defined. Definition z_iso_to_twosided_disp_cat_iso (x : C₁) (y : C₂) {z₁ z₂ : D} (f : z_iso z₁ z₂) : @iso_twosided_disp _ _ constant_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) z₁ z₂. Proof. simple refine (_ ,, _). - exact (pr1 f). - apply to_is_twosided_disp_cat_iso_constant. exact (pr2 f). Defined. Definition twosided_disp_cat_iso_to_z_iso (x : C₁) (y : C₂) {z₁ z₂ : D} (f : @iso_twosided_disp _ _ constant_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) z₁ z₂) : z_iso z₁ z₂. Proof. use make_z_iso. - exact (pr1 f). - exact (pr12 f). - split. + abstract (pose (p := pr122 f) ; cbn in p ; unfold transportb_disp_mor2, transportf_disp_mor2 in p ; cbn in p ; rewrite !transportf_const in p ; exact p). + abstract (pose (p := pr222 f) ; cbn in p ; unfold transportb_disp_mor2, transportf_disp_mor2 in p ; cbn in p ; rewrite !transportf_const in p ; exact p). Defined. Definition z_iso_weq_twosided_disp_cat_iso (x : C₁) (y : C₂) (z₁ z₂ : D) : z_iso z₁ z₂ ≃ @iso_twosided_disp _ _ constant_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) z₁ z₂. Proof. use make_weq. - exact (z_iso_to_twosided_disp_cat_iso x y). - use isweq_iso. + exact (twosided_disp_cat_iso_to_z_iso x y). + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; cbn ; apply idpath). + abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). Defined. (** 3. Univalence *) Definition is_univalent_constant_twosided_disp_cat (HD : is_univalent D) : is_univalent_twosided_disp_cat constant_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ z₁ z₂. induction p₁, p₂. use weqhomot. - exact (z_iso_weq_twosided_disp_cat_iso x₁ y₁ z₁ z₂ ∘ make_weq _ (HD z₁ z₂))%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). Defined. End ConstantTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/DispCatOnTwoSidedDispCat.v000066400000000000000000000531511451125700300325310ustar00rootroot00000000000000(********************************************************************************** Composing a two-sided displayed category with a displayed category We show how to compose a two-sided displayed category with a displayed category. The idea is basically as follows: a two-sided displayed category represents a span and a displayed category represents a functor. Both legs of the span get composed with this functor to obtain a new span. More precisely, we have a two-sided displayed category and a displayed category over the total category of that two-sided displayed category. This displayed category represents structures/properties to be added to our two-sided displayed category. We then form a new two-sided displayed category by taking sigma-types. Contents 1. The definition 2. Isomorphisms 3. Univalence and discreteness **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Local Open Scope cat. Definition transportf_hset_eq {X : UU} {Y : X → UU} (Xisaset : isaset X) {x₁ x₂ : X} (p q : x₁ = x₂) (y : Y x₁) : transportf Y p y = transportf Y q y. Proof. apply maponpaths_2. apply Xisaset. Qed. Section DispCatOnTwoSidedDispCat. Context {C₁ C₂ : category} (D₁ : twosided_disp_cat C₁ C₂) (D₂ : disp_cat (total_twosided_disp_category D₁)). (** 1. The definition *) Definition sigma_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, ∑ (xy : D₁ x y), D₂ (x ,, y ,, xy)). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g, ∑ (fg : pr1 xy₁ -->[ f ][ g ] pr1 xy₂), pr2 xy₁ -->[ f ,, g ,, fg ] pr2 xy₂). Defined. Definition sigma_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp sigma_twosided_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - simple refine (λ x y xy, id_two_disp (pr1 xy) ,, _). apply (@id_disp (total_twosided_disp_category D₁) D₂). - exact (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂, pr1 fg₁ ;;2 pr1 fg₂ ,, (pr2 fg₁ ;; pr2 fg₂)%mor_disp). Defined. Definition sigma_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact sigma_twosided_disp_cat_ob_mor. - exact sigma_twosided_disp_cat_id_comp. Defined. Definition sigma_twosided_disp_cat_mor_eq {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {xy₁ : sigma_twosided_disp_cat_data x₁ y₁} {xy₂ : sigma_twosided_disp_cat_data x₂ y₂} (fg₁ : xy₁ -->[ f ][ g ] xy₂) (fg₂ : xy₁ -->[ f ][ g ] xy₂) (p : pr1 fg₁ = pr1 fg₂) (q : transportf (λ z, pr2 xy₁ -->[ z ] pr2 xy₂) (maponpaths (λ z, f ,, g ,, z) p) (pr2 fg₁) = pr2 fg₂) : fg₁ = fg₂. Proof. induction fg₁ as [ fg₁ fg₁' ]. induction fg₂ as [ fg₂ fg₂' ]. cbn in *. induction p. cbn in q. induction q. apply idpath. Qed. Section SigmaLeft. Context {x₁ x₂ : C₁} {f : x₁ --> x₂} {y₁ y₂ : C₂} {g₁ g₂ : y₁ --> y₂} (p : g₂ = g₁) {xy₁ : sigma_twosided_disp_cat_data x₁ y₁} {xy₂ : sigma_twosided_disp_cat_data x₂ y₂} (fg : xy₁ -->[ f ][ g₂ ] xy₂). Let q₁ : total_twosided_disp_category D₁ := x₁ ,, y₁ ,, pr1 xy₁. Let q₂ : total_twosided_disp_category D₁ := x₂ ,, y₂ ,, pr1 xy₂. Let h₁ : q₁ --> q₂ := f ,, g₂ ,, pr1 fg. Let h₂ : q₁ --> q₂ := f ,, g₁ ,, transportf (λ z, _ -->[ f ][ z ] _) p (pr1 fg). Definition sigma_transportf_left_path : h₁ = h₂. Proof. induction p. apply idpath. Defined. End SigmaLeft. Definition sigma_transportf_left {x₁ x₂ : C₁} {f : x₁ --> x₂} {y₁ y₂ : C₂} {g₁ g₂ : y₁ --> y₂} (p : g₂ = g₁) {xy₁ : sigma_twosided_disp_cat_data x₁ y₁} {xy₂ : sigma_twosided_disp_cat_data x₂ y₂} (fg : xy₁ -->[ f ][ g₂ ] xy₂) : transportf (λ z, xy₁ -->[ f ][ z ] xy₂) p fg = transportf (λ z, _ -->[ f ][ z ] _) p (pr1 fg) ,, transportf (λ z, @mor_disp _ D₂ _ _ (pr2 xy₁) (pr2 xy₂) z) (sigma_transportf_left_path p fg) (pr2 fg). Proof. induction p ; cbn. apply idpath. Qed. Section SigmaRight. Context {x₁ x₂ : C₁} {f₁ f₂ : x₁ --> x₂} (p : f₂ = f₁) {y₁ y₂ : C₂} {g : y₁ --> y₂} {xy₁ : sigma_twosided_disp_cat_data x₁ y₁} {xy₂ : sigma_twosided_disp_cat_data x₂ y₂} (fg : xy₁ -->[ f₂ ][ g ] xy₂). Let q₁ : total_twosided_disp_category D₁ := x₁ ,, y₁ ,, pr1 xy₁. Let q₂ : total_twosided_disp_category D₁ := x₂ ,, y₂ ,, pr1 xy₂. Let h₁ : q₁ --> q₂ := f₂ ,, g ,, pr1 fg. Let h₂ : q₁ --> q₂ := f₁ ,, g ,, transportf (λ z, _ -->[ z ][ g ] _) p (pr1 fg). Definition sigma_transportf_right_path : h₁ = h₂. Proof. induction p. apply idpath. Defined. End SigmaRight. Definition sigma_transportf_right {x₁ x₂ : C₁} {f₁ f₂ : x₁ --> x₂} (p : f₂ = f₁) {y₁ y₂ : C₂} {g : y₁ --> y₂} {xy₁ : sigma_twosided_disp_cat_data x₁ y₁} {xy₂ : sigma_twosided_disp_cat_data x₂ y₂} (fg : xy₁ -->[ f₂ ][ g ] xy₂) : transportf (λ z, xy₁ -->[ z ][ g ] xy₂) p fg = transportf (λ z, _ -->[ z ][ g ] _) p (pr1 fg) ,, transportf (λ z, @mor_disp _ D₂ _ _ (pr2 xy₁) (pr2 xy₂) z) (sigma_transportf_right_path p fg) (pr2 fg). Proof. induction p ; cbn. apply idpath. Qed. Definition sigma_twosided_disp_cat_axioms : twosided_disp_cat_axioms sigma_twosided_disp_cat_data. Proof. repeat split. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg. unfold transportb_disp_mor2, transportf_disp_mor2. rewrite sigma_transportf_left. rewrite sigma_transportf_right. use sigma_twosided_disp_cat_mor_eq. + apply id_two_disp_left. + cbn. unfold twosided_disp_cat_ob_mor_to_mor. etrans. { apply maponpaths. exact (@id_left_disp _ D₂ _ _ _ _ _ (pr2 fg)). } unfold transportb. rewrite !transport_f_f. apply transportf_hset_eq. apply (total_twosided_disp_category D₁). - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg. unfold transportb_disp_mor2, transportf_disp_mor2. rewrite sigma_transportf_left. rewrite sigma_transportf_right. use sigma_twosided_disp_cat_mor_eq. + apply id_two_disp_right. + cbn. unfold twosided_disp_cat_ob_mor_to_mor. etrans. { apply maponpaths. exact (@id_right_disp _ D₂ _ _ _ _ _ (pr2 fg)). } unfold transportb. rewrite !transport_f_f. apply transportf_hset_eq. apply (total_twosided_disp_category D₁). - intros x₁ x₂ x₃ x₄ y₁ y₂ y₃ y₄ xy₁ xy₂ xy₃ xy₄ f₁ f₂ f₃ g₁ g₂ g₃ fg₁ fg₂ fg₃. unfold transportb_disp_mor2, transportf_disp_mor2. rewrite sigma_transportf_left. rewrite sigma_transportf_right. use sigma_twosided_disp_cat_mor_eq. + apply assoc_two_disp. + cbn. unfold twosided_disp_cat_ob_mor_to_mor. etrans. { apply maponpaths. apply (@assoc_disp _ D₂ _ _ _ _ _ _ _ _ _ _ _ (pr2 fg₁) (pr2 fg₂) (pr2 fg₃)). } unfold transportb. rewrite !transport_f_f. apply transportf_hset_eq. apply (total_twosided_disp_category D₁). - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g. use isaset_total2. + apply isaset_disp_mor. + intro. apply homsets_disp. Qed. Definition sigma_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact sigma_twosided_disp_cat_data. - exact sigma_twosided_disp_cat_axioms. Defined. Definition sigma_mor_eq {x : C₁} {y : C₂} {xy : sigma_twosided_disp_cat x y} {f : x --> x} {g : y --> y} {fg₁ fg₂ : xy -->[ f ][ g ] xy} (p : fg₁ = fg₂) : pr2 fg₁ = transportb (λ z, _ -->[ z ] _) (maponpaths _ (maponpaths (λ z, _ ,, z) (maponpaths pr1 p))) (pr2 fg₂). Proof. induction p. apply idpath. Qed. (** 2. Isomorphisms *) Definition to_iso_sigma_of_twosided_disp_cat {x : C₁} {y : C₂} {xy₁ : sigma_twosided_disp_cat x y} {xy₂ : sigma_twosided_disp_cat x y} (f : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) (pr1 xy₁) (pr1 xy₂)) (g : z_iso_disp (make_z_iso_total_twosided_disp_cat _ f) (pr2 xy₁) (pr2 xy₂)) : @iso_twosided_disp _ _ sigma_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 f ,, pr1 g). - exact (pr12 f ,, inv_mor_disp_from_z_iso g). - abstract (unfold transportb_disp_mor2, transportf_disp_mor2 ; rewrite sigma_transportf_left ; rewrite sigma_transportf_right ; use sigma_twosided_disp_cat_mor_eq ; [ exact (pr122 f) | ] ; etrans ; [ apply maponpaths ; exact (inv_mor_after_z_iso_disp g) | ] ; unfold transportb ; cbn ; rewrite !transport_f_f ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). - abstract (unfold transportb_disp_mor2, transportf_disp_mor2 ; rewrite sigma_transportf_left ; rewrite sigma_transportf_right ; use sigma_twosided_disp_cat_mor_eq ; [ exact (pr222 f) | ] ; etrans ; [ apply maponpaths ; exact (z_iso_disp_after_inv_mor g) | ] ; unfold transportb ; cbn ; rewrite !transport_f_f ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). Defined. Section FromSigmaIso. Context {x : C₁} {y : C₂} {xy₁ : sigma_twosided_disp_cat x y} {xy₂ : sigma_twosided_disp_cat x y} (f : @iso_twosided_disp _ _ sigma_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) xy₁ xy₂). Let h : pr1 xy₁ -->[ identity_z_iso x ][ identity_z_iso y] pr1 xy₂ := pr11 f. Let hinv : pr1 xy₂ -->[ identity_z_iso x ][ identity_z_iso y] pr1 xy₁ := pr112 f. Local Lemma from_iso_sigma_of_twosided_disp_cat_inv₁ : h ;;2 hinv = transportb (λ z, _ -->[ z ][ identity _ · identity _] _) (z_iso_inv_after_z_iso (identity_z_iso _)) (transportb (λ z, _ -->[ identity x ][ z ] _) (z_iso_inv_after_z_iso (identity_z_iso _)) (id_two_disp _)). Proof. refine (maponpaths pr1 (pr122 f) @ _). unfold transportb_disp_mor2, transportf_disp_mor2. rewrite sigma_transportf_left. rewrite sigma_transportf_right. apply idpath. Qed. Local Lemma from_iso_sigma_of_twosided_disp_cat_inv₂ : hinv ;;2 h = transportb (λ z, _ -->[ z ][ identity _ · identity _] _) (z_iso_inv_after_z_iso (identity_z_iso _)) (transportb (λ z, _ -->[ identity x ][ z ] _) (z_iso_inv_after_z_iso (identity_z_iso _)) (id_two_disp _)). Proof. refine (maponpaths pr1 (pr222 f) @ _). unfold transportb_disp_mor2, transportf_disp_mor2. rewrite sigma_transportf_left. rewrite sigma_transportf_right. apply idpath. Qed. Definition from_iso_sigma_of_twosided_disp_cat_pr1 : @iso_twosided_disp _ _ D₁ _ _ _ _ (identity_z_iso x) (identity_z_iso y) (pr1 xy₁) (pr1 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact h. - exact hinv. - exact from_iso_sigma_of_twosided_disp_cat_inv₁. - exact from_iso_sigma_of_twosided_disp_cat_inv₂. Defined. Local Arguments transportf {_} _ {_ _ _} _. Definition from_iso_sigma_of_twosided_disp_cat_pr2 : z_iso_disp (make_z_iso_total_twosided_disp_cat D₁ from_iso_sigma_of_twosided_disp_cat_pr1) (pr2 xy₁) (pr2 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr21 f). - exact (pr212 f). - abstract (assert (p := pr222 f @ maponpaths _ (sigma_transportf_left _ _) @ sigma_transportf_right _ _) ; cbn in p ; rewrite transport_f_f in p ; refine (sigma_mor_eq p @ _) ; cbn ; unfold transportb ; rewrite transport_f_f ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). - abstract (assert (p := pr122 f @ maponpaths _ (sigma_transportf_left _ _) @ sigma_transportf_right _ _) ; cbn in p ; rewrite transport_f_f in p ; refine (sigma_mor_eq p @ _) ; cbn ; unfold transportb ; rewrite transport_f_f ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). Defined. End FromSigmaIso. Definition weq_iso_sigma_of_twosided_disp_cat_help_eq {x : C₁} {y : C₂} {xy₁ : sigma_twosided_disp_cat x y} {xy₂ : sigma_twosided_disp_cat x y} (h₁ h₂ : ∑ (f : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) (pr1 xy₁) (pr1 xy₂)), z_iso_disp (make_z_iso_total_twosided_disp_cat _ f) (pr2 xy₁) (pr2 xy₂)) (p : pr11 h₁ = pr11 h₂) (q : pr12 h₁ = transportb (λ z, pr2 xy₁ -->[ z ] pr2 xy₂) (maponpaths (λ (z : pr1 xy₁ -->[ identity _ ][ identity _ ] pr1 xy₂), _ ,, _ ,, z) p) (pr12 h₂)) : h₁ = h₂. Proof. induction h₁ as [ h₁ k₁ ]. induction h₁ as [ h₁ Hh₁ ]. induction k₁ as [ k₁ Hk₁ ]. induction h₂ as [ h₂ k₂ ]. induction h₂ as [ h₂ Hh₂ ]. induction k₂ as [ k₂ Hk₂ ]. cbn in *. induction p. cbn in q. induction q. assert (Hh₁ = Hh₂) as p. { apply isaprop_is_iso_twosided_disp. } induction p. do 2 apply maponpaths. apply (@isaprop_is_z_iso_disp _ D₂). Qed. Definition weq_iso_sigma_of_twosided_disp_cat {x : C₁} {y : C₂} (xy₁ : sigma_twosided_disp_cat x y) (xy₂ : sigma_twosided_disp_cat x y) : (∑ (f : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) (pr1 xy₁) (pr1 xy₂)), z_iso_disp (make_z_iso_total_twosided_disp_cat _ f) (pr2 xy₁) (pr2 xy₂)) ≃ @iso_twosided_disp _ _ sigma_twosided_disp_cat _ _ _ _ (identity_z_iso x) (identity_z_iso y) xy₁ xy₂. Proof. use weq_iso. - exact (λ f, to_iso_sigma_of_twosided_disp_cat (pr1 f) (pr2 f)). - intro f. simple refine (_ ,, _). + exact (from_iso_sigma_of_twosided_disp_cat_pr1 f). + exact (from_iso_sigma_of_twosided_disp_cat_pr2 f). - intro f. use weq_iso_sigma_of_twosided_disp_cat_help_eq ; apply idpath. - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 3. Univalence and discreteness *) Definition is_univalent_sigma_of_twosided_disp_cat_help (HD₂ : is_univalent_disp D₂) {x₁ : C₁} {y₁ : C₂} (xy₁ xy₂ : sigma_twosided_disp_cat x₁ y₁) (p : pr1 xy₁ = pr1 xy₂) : (transportf (λ z, D₂ (x₁ ,, y₁ ,, z)) p (pr2 xy₁) = pr2 xy₂) ≃ z_iso_disp (@make_z_iso_total_twosided_disp_cat _ _ D₁ _ _ _ _ _ _ _ _ (idtoiso_twosided_disp (idpath _) (idpath _) _ _ p)) (pr2 xy₁) (pr2 xy₂). Proof. induction xy₁ as [ z₁ z₂ ]. induction xy₂ as [ z₃ z₄ ]. cbn in *. induction p ; cbn. refine (_ ∘ (_ ,, HD₂ _ _ (idpath _) z₂ z₄))%weq. use weq_iso. - intro f. simple refine (pr1 f ,, pr12 f ,, _ ,, _). + abstract (refine (pr122 f @ _) ; apply transportf_hset_eq ; apply homset_property). + abstract (refine (pr222 f @ _) ; apply transportf_hset_eq ; apply homset_property). - intro f. simple refine (pr1 f ,, pr12 f ,, _ ,, _). + abstract (refine (pr122 f @ _) ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). + abstract (refine (pr222 f @ _) ; apply transportf_hset_eq ; apply (total_twosided_disp_category D₁)). - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). - abstract (intro f ; use subtypePath ; [ intro ; apply (@isaprop_is_z_iso_disp _ D₂) | ] ; apply idpath). Defined. Definition is_univalent_sigma_of_twosided_disp_cat (HD₁ : is_univalent_twosided_disp_cat D₁) (HD₂ : is_univalent_disp D₂) : is_univalent_twosided_disp_cat sigma_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂. use weqhomot. - exact (weq_iso_sigma_of_twosided_disp_cat _ _ ∘ weqtotal2 (make_weq _ (HD₁ x₁ x₁ y₁ y₁ (idpath _) (idpath _) (pr1 xy₁) (pr1 xy₂))) (is_univalent_sigma_of_twosided_disp_cat_help HD₂ xy₁ xy₂) ∘ total2_paths_equiv _ _ _)%weq. - intro p. induction p. use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn. apply idpath. Defined. Definition isaprop_disp_twosided_mor_sigma_twosided_disp_cat (HD₁ : isaprop_disp_twosided_mor D₁) (HD₂ : locally_propositional D₂) : isaprop_disp_twosided_mor sigma_twosided_disp_cat. Proof. intro ; intros. use total2_paths_f. - apply HD₁. - apply HD₂. Qed. Definition discrete_sigma_twosided_disp_cat (HD₁ : discrete_twosided_disp_cat D₁) (HD₂ : is_univalent_disp D₂) (HD₃ : locally_propositional D₂) (HD₄ : groupoidal_disp_cat D₂) : discrete_twosided_disp_cat sigma_twosided_disp_cat. Proof. use make_discrete_twosided_disp_cat. - use isaprop_disp_twosided_mor_sigma_twosided_disp_cat. + apply HD₁. + exact HD₃. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg ; cbn. simple refine (_ ,, _). + apply HD₁. exact (pr1 fg). + cbn. pose (h := @make_z_iso_total_twosided_disp_cat _ _ D₁ x₁ x₂ y₁ y₂ (pr1 xy₁) (pr1 xy₂) (f ,, Hf) (g ,, Hg) (pr1 fg ,, pr12 HD₁ _ _ _ _ _ _ _ _ _ _ _)). apply (HD₄ _ _ h (pr2 h)). apply fg. - use is_univalent_sigma_of_twosided_disp_cat. + apply HD₁. + exact HD₂. Qed. End DispCatOnTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/FiberwiseProduct.v000066400000000000000000000277161451125700300312620ustar00rootroot00000000000000(********************************************************************************** The fiberwise product of two-sided displayed categories If we have two two-sided displayed categories over the same `C₁` and `C₂`, then we can form their product to obtain a new two-sided displayed category over `C₁` and `C₂`. Contents 1. The definition 2. Isomorphisms 3. Univalence and discreteness **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Local Open Scope cat. Definition transportf_dirprod_fam {X : UU} {Y₁ Y₂ : X → UU} {x₁ x₂ : X} (p : x₁ = x₂) (y : Y₁ x₁ × Y₂ x₁) : transportf (λ x, Y₁ x × Y₂ x) p y = transportf Y₁ p (pr1 y) ,, transportf Y₂ p (pr2 y). Proof. induction p. apply idpath. Defined. Section FiberwiseProduct. Context {C₁ C₂ : category} (D₁ D₂ : twosided_disp_cat C₁ C₂). (** 1. The definition *) Definition prod_of_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, D₁ x y × D₂ x y). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g, pr1 xy₁ -->[ f ][ g ] pr1 xy₂ × pr2 xy₁ -->[ f ][ g ] pr2 xy₂). Defined. Definition prod_of_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp prod_of_twosided_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ x y xy, id_two_disp (pr1 xy) ,, id_two_disp (pr2 xy)). - exact (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂, (pr1 fg₁ ;;2 pr1 fg₂) ,, (pr2 fg₁ ;;2 pr2 fg₂)). Defined. Definition prod_of_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact prod_of_twosided_disp_cat_ob_mor. - exact prod_of_twosided_disp_cat_id_comp. Defined. Definition prod_of_twosided_disp_cat_axioms : twosided_disp_cat_axioms prod_of_twosided_disp_cat_data. Proof. repeat split. - intro ; intros ; cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_dirprod_fam. rewrite transportf_dirprod_fam. use dirprod_paths ; apply id_two_disp_left. - intro ; intros ; cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_dirprod_fam. rewrite transportf_dirprod_fam. use dirprod_paths ; apply id_two_disp_right. - intro ; intros ; cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_dirprod_fam. rewrite transportf_dirprod_fam. use dirprod_paths ; apply assoc_two_disp. - intro ; intros. apply isasetdirprod ; apply isaset_disp_mor. Qed. Definition prod_of_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact prod_of_twosided_disp_cat_data. - exact prod_of_twosided_disp_cat_axioms. Defined. (** 2. Isomorphisms *) Definition make_is_iso_prod_of_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} (Hf : is_z_isomorphism f) {g : y₁ --> y₂} (Hg : is_z_isomorphism g) {xy₁₁ : D₁ x₁ y₁} {xy₁₂ : D₂ x₁ y₁} {xy₂₁ : D₁ x₂ y₂} {xy₂₂ : D₂ x₂ y₂} (fg₁ : xy₁₁ -->[ f ][ g ] xy₂₁) (Hfg₁ : is_iso_twosided_disp Hf Hg fg₁) (fg₂ : xy₁₂ -->[ f ][ g ] xy₂₂) (Hfg₂ : is_iso_twosided_disp Hf Hg fg₂) : @is_iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂) f g Hf Hg (fg₁ ,, fg₂). Proof. simple refine ((_ ,, _) ,, _ ,, _). - exact (pr1 Hfg₁). - exact (pr1 Hfg₂). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; use pathsdirprod ; [ apply Hfg₁ | apply Hfg₂ ]). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; use pathsdirprod ; [ apply Hfg₁ | apply Hfg₂ ]). Defined. Definition isaprop_disp_twosided_mor_prod_of_twosided_disp_cat (HD₁ : isaprop_disp_twosided_mor D₁) (HD₂ : isaprop_disp_twosided_mor D₂) : isaprop_disp_twosided_mor prod_of_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg fg'. apply pathsdirprod. - apply HD₁. - apply HD₂. Qed. Definition make_iso_prod_of_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁₁ : D₁ x₁ y₁} {xy₁₂ : D₂ x₁ y₁} {xy₂₁ : D₁ x₂ y₂} {xy₂₂ : D₂ x₂ y₂} (fg : iso_twosided_disp f g xy₁₁ xy₂₁ × iso_twosided_disp f g xy₁₂ xy₂₂) : @iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ f g (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂). Proof. simple refine ((_ ,, _) ,, _). - exact (pr11 fg). - exact (pr12 fg). - use make_is_iso_prod_of_twosided_disp_cat. + exact (pr21 fg). + exact (pr22 fg). Defined. Definition iso_prod_of_twosided_disp_cat_pr1 {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁₁ : D₁ x₁ y₁} {xy₁₂ : D₂ x₁ y₁} {xy₂₁ : D₁ x₂ y₂} {xy₂₂ : D₂ x₂ y₂} (fg : @iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ f g (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂)) : iso_twosided_disp f g xy₁₁ xy₂₁. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr11 fg). - exact (pr112 fg). - abstract (refine (maponpaths dirprod_pr1 (pr122 fg) @ _) ; cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; apply idpath). - abstract (refine (maponpaths dirprod_pr1 (pr222 fg) @ _) ; cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; apply idpath). Defined. Definition iso_prod_of_twosided_disp_cat_pr2 {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁₁ : D₁ x₁ y₁} {xy₁₂ : D₂ x₁ y₁} {xy₂₁ : D₁ x₂ y₂} {xy₂₂ : D₂ x₂ y₂} (fg : @iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ f g (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂)) : iso_twosided_disp f g xy₁₂ xy₂₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr21 fg). - exact (pr212 fg). - abstract (refine (maponpaths dirprod_pr2 (pr122 fg) @ _) ; cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; apply idpath). - abstract (refine (maponpaths dirprod_pr2 (pr222 fg) @ _) ; cbn ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite !transportf_dirprod_fam ; apply idpath). Defined. Definition from_iso_prod_of_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁₁ : D₁ x₁ y₁} {xy₁₂ : D₂ x₁ y₁} {xy₂₁ : D₁ x₂ y₂} {xy₂₂ : D₂ x₂ y₂} (fg : @iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ f g (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂)) : iso_twosided_disp f g xy₁₁ xy₂₁ × iso_twosided_disp f g xy₁₂ xy₂₂ := iso_prod_of_twosided_disp_cat_pr1 fg ,, iso_prod_of_twosided_disp_cat_pr2 fg. Definition weq_iso_prod_of_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} (xy₁₁ : D₁ x₁ y₁) (xy₁₂ : D₂ x₁ y₁) (xy₂₁ : D₁ x₂ y₂) (xy₂₂ : D₂ x₂ y₂) :(iso_twosided_disp f g xy₁₁ xy₂₁ × iso_twosided_disp f g xy₁₂ xy₂₂) ≃ @iso_twosided_disp _ _ prod_of_twosided_disp_cat _ _ _ _ f g (xy₁₁ ,, xy₁₂) (xy₂₁ ,, xy₂₂). Proof. use weq_iso. - exact make_iso_prod_of_twosided_disp_cat. - exact from_iso_prod_of_twosided_disp_cat. - abstract (intro fg ; use pathsdirprod ; (use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath)). - abstract (intro fg ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 3. Univalence and discreteness *) Definition prod_twosided_disp_cat_all_disp_mor_iso (HD₁ : all_disp_mor_iso D₁) (HD₂ : all_disp_mor_iso D₂) : all_disp_mor_iso prod_of_twosided_disp_cat. Proof. intro ; intros. use make_is_iso_prod_of_twosided_disp_cat. - apply HD₁. - apply HD₂. Defined. Definition is_univalent_prod_of_twosided_disp_cat (HD₁ : is_univalent_twosided_disp_cat D₁) (HD₂ : is_univalent_twosided_disp_cat D₂) : is_univalent_twosided_disp_cat prod_of_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use weqhomot. - exact (weq_iso_prod_of_twosided_disp_cat _ _ _ _ ∘ weqdirprodf (_ ,, HD₁ x₁ x₁ y₁ y₁ (idpath _) (idpath _) _ _) (_ ,, HD₂ x₁ x₁ y₁ y₁ (idpath _) (idpath _) _ _) ∘ pathsdirprodweq)%weq. - abstract (intro p ; induction p ; cbn ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. Definition discrete_prod_twosided_disp_cat (HD₁ : discrete_twosided_disp_cat D₁) (HD₂ : discrete_twosided_disp_cat D₂) : discrete_twosided_disp_cat prod_of_twosided_disp_cat. Proof. repeat split. - use isaprop_disp_twosided_mor_prod_of_twosided_disp_cat. + apply HD₁. + apply HD₂. - use prod_twosided_disp_cat_all_disp_mor_iso. + apply HD₁. + apply HD₂. - use is_univalent_prod_of_twosided_disp_cat. + apply HD₁. + apply HD₂. Qed. End FiberwiseProduct. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/IsoComma.v000066400000000000000000000107531451125700300275020ustar00rootroot00000000000000(********************************************************************************** The iso-comma category Contents 1. Definition via two-sided displayed categories 2. Discreteness and univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Local Open Scope cat. Section IsoCommaTwoSidedDispCat. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃). (** 1. Definition via two-sided displayed categories *) Definition iso_comma_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, z_iso (F x) (G y)). - exact (λ x₁ x₂ y₁ y₂ h₁ h₂ f g, #F f · h₂ = h₁ · #G g). Defined. Definition iso_comma_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp iso_comma_twosided_disp_cat_ob_mor. Proof. split. - intros x y xy ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - intros x₁ x₂ x₃ y₁ y₂ y₃ h₁ h₂ h₃ f₁ f₂ g₁ g₂ hh₁ hh₂ ; cbn in *. rewrite !functor_comp. rewrite !assoc'. rewrite hh₂. rewrite !assoc. apply maponpaths_2. exact hh₁. Qed. Definition iso_comma_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact iso_comma_twosided_disp_cat_ob_mor. - exact iso_comma_twosided_disp_cat_id_comp. Defined. Definition isaprop_iso_comma_twosided_mor {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy₁ : iso_comma_twosided_disp_cat_data x₁ y₁) (xy₂ : iso_comma_twosided_disp_cat_data x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) : isaprop (xy₁ -->[ f ][ g ] xy₂). Proof. apply homset_property. Qed. Definition iso_comma_twosided_disp_cat_axioms : twosided_disp_cat_axioms iso_comma_twosided_disp_cat_data. Proof. repeat split. - intro ; intros. apply isaprop_iso_comma_twosided_mor. - intro ; intros. apply isaprop_iso_comma_twosided_mor. - intro ; intros. apply isaprop_iso_comma_twosided_mor. - intro ; intros. apply isasetaprop. apply isaprop_iso_comma_twosided_mor. Qed. Definition iso_comma_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact iso_comma_twosided_disp_cat_data. - exact iso_comma_twosided_disp_cat_axioms. Defined. (** 2. Discreteness and univalence *) Definition iso_comma_twosided_disp_cat_is_iso : all_disp_mor_iso iso_comma_twosided_disp_cat. Proof. intro ; intros. simple refine (_ ,, _ ,, _) ; cbn in *. - rewrite !functor_on_inv_from_z_iso. use z_iso_inv_on_right. rewrite assoc. use z_iso_inv_on_left ; cbn. exact fg. - apply isaprop_iso_comma_twosided_mor. - apply isaprop_iso_comma_twosided_mor. Qed. Definition is_univalent_iso_comma_twosided_disp_cat : is_univalent_twosided_disp_cat iso_comma_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. pose (p := pr1 f) ; cbn in p. rewrite !functor_id in p. rewrite id_left, id_right in p. use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ]. exact (!p). - apply isaset_z_iso. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply homset_property. Qed. Definition discrete_iso_comma_twosided_disp_cat : discrete_twosided_disp_cat iso_comma_twosided_disp_cat. Proof. repeat split. - intro ; intros. apply homset_property. - exact iso_comma_twosided_disp_cat_is_iso. - exact is_univalent_iso_comma_twosided_disp_cat. Qed. End IsoCommaTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Lenses.v000066400000000000000000000472311451125700300272250ustar00rootroot00000000000000(********************************************************************************** The two-sided displayed category of lenses Reference for lenses: https://ncatlab.org/nlab/show/lens+%28in+computer+science%29 We define the two-sided displayed category of lenses. Contents 1. Definition via two-sided displayed categories 2. Discreteness and univalence 3. Builders and accessors 4. Identity and composition of lenses **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.FiberwiseProduct. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat. Local Open Scope cat. Section Lenses. Context (C : category) (prodC : BinProducts C). (** 1. Definition via two-sided displayed categories *) Definition twosided_disp_cat_of_lenses_get_ob_mor : twosided_disp_cat_ob_mor C C. Proof. simple refine (_ ,, _). - exact (λ s v, s --> v). - exact (λ s₁ s₂ v₁ v₂ g₁ g₂ f₁ f₂, g₁ · f₂ = f₁ · g₂). Defined. Definition twosided_disp_cat_of_lenses_get_id_comp : twosided_disp_cat_id_comp twosided_disp_cat_of_lenses_get_ob_mor. Proof. split. - intros s v g ; cbn. rewrite id_left, id_right. apply idpath. - intros s₁ s₂ s₃ v₁ v₂ v₃ g₁ g₂ g₃ f₁ f₂ h₁ h₂ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. apply idpath. Qed. Definition twosided_disp_cat_of_lenses_get_data : twosided_disp_cat_data C C. Proof. simple refine (_ ,, _). - exact twosided_disp_cat_of_lenses_get_ob_mor. - exact twosided_disp_cat_of_lenses_get_id_comp. Defined. Definition twosided_disp_cat_of_lenses_get_axioms : twosided_disp_cat_axioms twosided_disp_cat_of_lenses_get_data. Proof. repeat split ; intro ; intros. - apply homset_property. - apply homset_property. - apply homset_property. - apply isasetaprop. apply homset_property. Qed. Definition twosided_disp_cat_of_lenses_get : twosided_disp_cat C C. Proof. simple refine (_ ,, _). - exact twosided_disp_cat_of_lenses_get_data. - exact twosided_disp_cat_of_lenses_get_axioms. Defined. Definition twosided_disp_cat_of_lenses_put_ob_mor : twosided_disp_cat_ob_mor C C. Proof. simple refine (_ ,, _). - exact (λ s v, BinProductObject _ (prodC v s) --> s). - exact (λ s₁ s₂ v₁ v₂ g₁ g₂ f₁ f₂, g₁ · f₁ = BinProductOfArrows _ _ _ f₂ f₁ · g₂). Defined. Definition twosided_disp_cat_of_lenses_put_id_comp : twosided_disp_cat_id_comp twosided_disp_cat_of_lenses_put_ob_mor. Proof. split. - intros s v g ; cbn. rewrite id_right. assert (BinProductOfArrows C (prodC v s) (prodC v s) (identity v) (identity s) = identity _) as p. { refine (!_). use BinProductArrowUnique ; rewrite id_left, id_right ; apply idpath. } rewrite p. rewrite id_left. apply idpath. - intros s₁ s₂ s₃ v₁ v₂ v₃ g₁ g₂ g₃ f₁ f₂ h₁ h₂ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. rewrite !assoc. rewrite BinProductOfArrows_comp. apply idpath. Qed. Definition twosided_disp_cat_of_lenses_put_data : twosided_disp_cat_data C C. Proof. simple refine (_ ,, _). - exact twosided_disp_cat_of_lenses_put_ob_mor. - exact twosided_disp_cat_of_lenses_put_id_comp. Defined. Definition twosided_disp_cat_of_lenses_put_axioms : twosided_disp_cat_axioms twosided_disp_cat_of_lenses_put_data. Proof. repeat split ; intro ; intros. - apply homset_property. - apply homset_property. - apply homset_property. - apply isasetaprop. apply homset_property. Qed. Definition twosided_disp_cat_of_lenses_put : twosided_disp_cat C C. Proof. simple refine (_ ,, _). - exact twosided_disp_cat_of_lenses_put_data. - exact twosided_disp_cat_of_lenses_put_axioms. Defined. Definition twosided_disp_cat_of_lawless_lenses : twosided_disp_cat C C := prod_of_twosided_disp_cat twosided_disp_cat_of_lenses_get twosided_disp_cat_of_lenses_put. Definition lenses_laws {s v : C} (l : twosided_disp_cat_of_lawless_lenses s v) : UU := let g := pr1 l in let p := pr2 l in (p · g = BinProductPr1 _ _) × (BinProductArrow _ _ g (identity s) · p = identity s) × (BinProductOfArrows _ (prodC v _) (prodC _ _) (identity v) p · p = BinProductArrow _ _ (BinProductPr1 _ _) (BinProductPr2 _ _ · BinProductPr2 _ _) · p). Definition disp_cat_of_lenses_laws : disp_cat (total_twosided_disp_category twosided_disp_cat_of_lawless_lenses). Proof. use (disp_full_sub). exact (λ x, lenses_laws (pr22 x)). Defined. Definition twosided_disp_cat_of_lenses : twosided_disp_cat C C := sigma_twosided_disp_cat twosided_disp_cat_of_lawless_lenses disp_cat_of_lenses_laws. (** 2. Discreteness and univalence *) Definition lenses_get_twosided_disp_cat_is_iso : all_disp_mor_iso twosided_disp_cat_of_lenses_get. Proof. intro ; intros. simple refine (_ ,, _ ,, _) ; cbn in *. - refine (!_). use z_iso_inv_on_right. rewrite assoc. use z_iso_inv_on_left ; cbn. exact (!fg). - apply homset_property. - apply homset_property. Qed. Definition is_univalent_lenses_get_twosided_disp_cat : is_univalent_twosided_disp_cat twosided_disp_cat_of_lenses_get. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. pose (p := pr1 f) ; cbn in p. rewrite id_left, id_right in p. exact p. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply homset_property. Qed. Definition discrete_lenses_get_twosided_disp_cat : discrete_twosided_disp_cat twosided_disp_cat_of_lenses_get. Proof. repeat split. - intro ; intros. apply homset_property. - exact lenses_get_twosided_disp_cat_is_iso. - exact is_univalent_lenses_get_twosided_disp_cat. Qed. Definition lenses_put_twosided_disp_cat_is_iso : all_disp_mor_iso twosided_disp_cat_of_lenses_put. Proof. intro ; intros. simple refine (_ ,, _ ,, _) ; cbn in *. - refine (!_). use z_iso_inv_on_left ; cbn. rewrite !assoc'. rewrite fg. rewrite !assoc. refine (!(id_left _) @ _). apply maponpaths_2. rewrite BinProductOfArrows_comp. rewrite !z_iso_after_z_iso_inv. use BinProductArrowUnique ; rewrite id_left, id_right ; apply idpath. - apply homset_property. - apply homset_property. Qed. Definition is_univalent_lenses_put_twosided_disp_cat : is_univalent_twosided_disp_cat twosided_disp_cat_of_lenses_put. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. pose (p := pr1 f) ; cbn in p. rewrite id_right in p. refine (p @ _ @ id_left _). apply maponpaths_2. refine (!_). use BinProductArrowUnique ; rewrite id_left, id_right ; apply idpath. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply homset_property. Qed. Definition discrete_lenses_put_twosided_disp_cat : discrete_twosided_disp_cat twosided_disp_cat_of_lenses_put. Proof. repeat split. - intro ; intros. apply homset_property. - exact lenses_put_twosided_disp_cat_is_iso. - exact is_univalent_lenses_put_twosided_disp_cat. Qed. Definition is_univalent_lenses_twosided_disp_cat : is_univalent_twosided_disp_cat twosided_disp_cat_of_lenses. Proof. use is_univalent_sigma_of_twosided_disp_cat. - use is_univalent_prod_of_twosided_disp_cat. + exact is_univalent_lenses_get_twosided_disp_cat. + exact is_univalent_lenses_put_twosided_disp_cat. - abstract (use disp_full_sub_univalent ; intro x ; repeat (apply isapropdirprod) ; apply homset_property). Defined. Definition discrete_lenses_twosided_disp_cat : discrete_twosided_disp_cat twosided_disp_cat_of_lenses. Proof. use discrete_sigma_twosided_disp_cat. - use discrete_prod_twosided_disp_cat. + exact discrete_lenses_get_twosided_disp_cat. + exact discrete_lenses_put_twosided_disp_cat. - abstract (use disp_full_sub_univalent ; intro x ; repeat (apply isapropdirprod) ; apply homset_property). - intro ; intros. apply isapropunit. - abstract (intro ; intros ; simple refine (tt ,, _ ,, _) ; apply isapropunit). Defined. (** 3. Builders and accessors *) Definition lens (s v : C) : UU := twosided_disp_cat_of_lenses s v. Definition lens_data (s v : C) : UU := s --> v × prodC v s --> s. Definition make_lens_data {s v : C} (get : s --> v) (put : prodC v s --> s) : lens_data s v := get ,, put. Coercion lens_to_data {s v : C} (l : lens s v) : lens_data s v := pr1 l. Definition lens_get {s v : C} (l : lens_data s v) : s --> v := pr1 l. Definition lens_put {s v : C} (l : lens_data s v) : prodC v s --> s := pr2 l. Proposition lens_put_get {s v : C} (l : lens s v) : lens_put l · lens_get l = BinProductPr1 _ _. Proof. exact (pr12 l). Qed. Proposition lens_get_put {s v : C} (l : lens s v) : BinProductArrow _ _ (lens_get l) (identity s) · lens_put l = identity s. Proof. exact (pr122 l). Qed. Proposition lens_put_put {s v : C} (l : lens s v) : BinProductOfArrows _ (prodC v _) (prodC _ _) (identity v) (lens_put l) · lens_put l = BinProductArrow _ _ (BinProductPr1 _ _) (BinProductPr2 _ _ · BinProductPr2 _ _) · lens_put l. Proof. exact (pr222 l). Qed. Definition make_lens {s v : C} (l : lens_data s v) (Hl : lenses_laws l) : lens s v. Proof. simple refine (_ ,, _). - exact l. - exact Hl. Defined. Definition lens_mor {s₁ s₂ v₁ v₂ : C} (l₁ : lens s₁ v₁) (l₂ : lens s₂ v₂) (f : s₁ --> s₂) (g : v₁ --> v₂) : UU := l₁ -->[ f ][ g ] l₂. Definition make_lens_mor {s₁ s₂ v₁ v₂ : C} {l₁ : lens s₁ v₁} {l₂ : lens s₂ v₂} {f : s₁ --> s₂} {g : v₁ --> v₂} (p_get : lens_get l₁ · g = f · lens_get l₂) (p_put : lens_put l₁ · f = BinProductOfArrows C (prodC v₂ s₂) (prodC v₁ s₁) g f · lens_put l₂) : lens_mor l₁ l₂ f g := (p_get ,, p_put) ,, tt. Proposition lens_mor_get {s₁ s₂ v₁ v₂ : C} {l₁ : lens s₁ v₁} {l₂ : lens s₂ v₂} {f : s₁ --> s₂} {g : v₁ --> v₂} (fg : lens_mor l₁ l₂ f g) : lens_get l₁ · g = f · lens_get l₂. Proof. exact (pr11 fg). Qed. Proposition lens_mor_put {s₁ s₂ v₁ v₂ : C} {l₁ : lens s₁ v₁} {l₂ : lens s₂ v₂} {f : s₁ --> s₂} {g : v₁ --> v₂} (fg : lens_mor l₁ l₂ f g) : lens_put l₁ · f = BinProductOfArrows C (prodC v₂ s₂) (prodC v₁ s₁) g f · lens_put l₂. Proof. exact (pr21 fg). Qed. (** 4. Identity and composition of lenses *) Definition identity_lens_data (x : C) : lens_data x x. Proof. use make_lens_data. - exact (identity x). - exact (BinProductPr1 _ _). Defined. Proposition identity_lens_laws (x : C) : lenses_laws (identity_lens_data x). Proof. repeat split ; cbn. - apply id_right. - apply BinProductPr1Commutes. - rewrite BinProductOfArrowsPr1. rewrite id_right. rewrite BinProductPr1Commutes. apply idpath. Qed. Definition identity_lens (x : C) : lens x x. Proof. use make_lens. - exact (identity_lens_data x). - exact (identity_lens_laws x). Defined. Proposition identity_lens_mor {x y : C} (f : x --> y) : lens_mor (identity_lens x) (identity_lens y) f f. Proof. use make_lens_mor ; cbn. - rewrite id_left, id_right. apply idpath. - rewrite BinProductOfArrowsPr1. apply idpath. Qed. Definition comp_lens_data {x y z : C} (l₁ : lens x y) (l₂ : lens y z) : lens_data x z. Proof. use make_lens_data. - exact (lens_get l₁ · lens_get l₂). - exact (BinProductArrow _ _ (identity _) (BinProductPr2 _ _) · BinProductOfArrows _ (prodC _ _) (prodC _ _) (BinProductOfArrows _ (prodC _ _) (prodC _ _) (identity _) (lens_get l₁) · lens_put l₂) (identity _) · lens_put l₁). Defined. Proposition comp_lens_laws {x y z : C} (l₁ : lens x y) (l₂ : lens y z) : lenses_laws (comp_lens_data l₁ l₂). Proof. repeat split ; cbn. - rewrite !assoc'. etrans. { do 2 apply maponpaths. rewrite !assoc. rewrite lens_put_get. apply idpath. } etrans. { apply maponpaths. rewrite !assoc. rewrite BinProductOfArrowsPr1. rewrite !assoc'. rewrite lens_put_get. apply idpath. } rewrite !assoc. rewrite !BinProductPr1Commutes. rewrite id_left. rewrite BinProductOfArrowsPr1. rewrite id_right. apply idpath. - rewrite !assoc. etrans. { apply maponpaths_2. rewrite !assoc'. rewrite !postcompWithBinProductArrow. rewrite id_right. rewrite precompWithBinProductArrow. rewrite BinProductPr2Commutes. apply idpath. } refine (_ @ lens_get_put l₁). do 2 apply maponpaths_2. refine (_ @ id_right _). rewrite <- (lens_get_put l₂). rewrite !assoc. apply maponpaths_2. rewrite !precompWithBinProductArrow. rewrite id_right. rewrite id_right. rewrite postcompWithBinProductArrow. rewrite id_left, id_right. apply idpath. - pose (p₁ := lens_put_get l₁). pose (p₂ := lens_put_put l₂). pose (p₃ := lens_put_put l₁). etrans. { rewrite !assoc. apply maponpaths_2. rewrite !postcompWithBinProductArrow. rewrite precompWithBinProductArrow. rewrite !postcompWithBinProductArrow. rewrite !id_left. rewrite !id_right. rewrite BinProductOfArrowsPr2. rewrite !assoc. rewrite precompWithBinProductArrow. apply maponpaths_2. rewrite BinProductOfArrows_comp. rewrite id_left. rewrite !assoc'. rewrite p₁. rewrite BinProductPr1Commutes. etrans. { do 2 apply maponpaths_2. exact (!(id_left _)). } rewrite <- BinProductOfArrows_comp. rewrite !assoc'. rewrite p₂. rewrite !assoc. rewrite precompWithBinProductArrow. rewrite BinProductOfArrowsPr1. rewrite id_right. rewrite !assoc. rewrite !BinProductOfArrowsPr2. rewrite !assoc'. rewrite BinProductOfArrowsPr2. apply idpath. } clear p₁ p₂. etrans. { etrans. { do 2 apply maponpaths_2. exact (!(id_right _)). } etrans. { apply maponpaths_2. refine (!_). apply (postcompWithBinProductArrow _ (prodC _ _) (prodC _ _)). } rewrite !assoc'. rewrite p₃. rewrite !assoc. rewrite precompWithBinProductArrow. rewrite !assoc. rewrite !BinProductPr1Commutes. rewrite !BinProductPr2Commutes. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !precompWithBinProductArrow. rewrite !postcompWithBinProductArrow. rewrite !id_right. rewrite !BinProductPr2Commutes. apply maponpaths_2. rewrite !assoc. apply maponpaths_2. rewrite !postcompWithBinProductArrow. rewrite id_right. apply idpath. Qed. Definition comp_lens {x y z : C} (l₁ : lens x y) (l₂ : lens y z) : lens x z. Proof. use make_lens. - exact (comp_lens_data l₁ l₂). - exact (comp_lens_laws l₁ l₂). Defined. Proposition comp_lens_mor {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {l₁ : lens x₁ y₁} {l₂ : lens y₁ z₁} {l₃ : lens x₂ y₂} {l₄ : lens y₂ z₂} (φ : lens_mor l₁ l₃ v₁ v₂) (ψ : lens_mor l₂ l₄ v₂ v₃) : lens_mor (comp_lens l₁ l₂) (comp_lens l₃ l₄) v₁ v₃. Proof. use make_lens_mor ; cbn. - rewrite !assoc'. rewrite (lens_mor_get ψ). rewrite !assoc. rewrite (lens_mor_get φ). apply idpath. - rewrite !assoc'. rewrite (lens_mor_put φ). rewrite !assoc. apply maponpaths_2. rewrite !postcompWithBinProductArrow. rewrite !precompWithBinProductArrow. rewrite !postcompWithBinProductArrow. rewrite !id_right. rewrite BinProductOfArrowsPr2. apply maponpaths_2. rewrite !assoc'. rewrite (lens_mor_put ψ). rewrite !assoc. apply maponpaths_2. rewrite id_left. rewrite !BinProductOfArrows_comp. rewrite id_left, id_right. apply maponpaths. rewrite (lens_mor_get φ). apply idpath. Qed. End Lenses. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/ProdOfTwosidedDispCat.v000066400000000000000000000340331451125700300321340ustar00rootroot00000000000000(************************************************************************************ The product of 2-sided displayed categories Suppose that we have a 2-sided displayed category `D₁` from `C₁` to `C₃` and a 2-sided displayed category `D₂` from `C₂` to `C₄`. Then we obtain a 2-sided displayed category from `category_binproduct C₁ C₂` to `category_binproduct C₃ C₄`. The displayed objects and displayed morphisms are pairs of displayed objects and of displayed morphisms respectively. Contents 1. The definition of the product of 2-sided displayed categories 2. Isos in the product 3. The univalence of the product ************************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Local Open Scope cat. Section ProdTwoSidedDispCat. Context {C₁ C₂ C₃ C₄ : category} (D₁ : twosided_disp_cat C₁ C₃) (D₂ : twosided_disp_cat C₂ C₄). (** 1. The definition of the product of 2-sided displayed categories *) Definition twosided_disp_cat_product_ob_mor : twosided_disp_cat_ob_mor (category_binproduct C₁ C₂) (category_binproduct C₃ C₄). Proof. simple refine (_ ,, _). - exact (λ wx yz, D₁ (pr1 wx) (pr1 yz) × D₂ (pr2 wx) (pr2 yz)). - exact (λ wx₁ wx₂ yz₁ yz₂ d₁ d₂ fg hk, pr1 d₁ -->[ pr1 fg ][ pr1 hk ] pr1 d₂ × pr2 d₁ -->[ pr2 fg ][ pr2 hk ] pr2 d₂). Defined. Definition twosided_disp_cat_product_id_comp : twosided_disp_cat_id_comp twosided_disp_cat_product_ob_mor. Proof. simple refine (_ ,, _). - exact (λ wx yz d, id_two_disp (pr1 d) ,, id_two_disp (pr2 d)). - exact (λ wx₁ wx₂ wx₃ yz₁ yz₂ yz₃ d₁ d₂ d₃ fg₁ fg₂ hk₁ hk₂ φ ψ, pr1 φ ;;2 pr1 ψ ,, pr2 φ ;;2 pr2 ψ). Defined. Definition twosided_disp_cat_product_data : twosided_disp_cat_data (category_binproduct C₁ C₂) (category_binproduct C₃ C₄). Proof. simple refine (_ ,, _). - exact twosided_disp_cat_product_ob_mor. - exact twosided_disp_cat_product_id_comp. Defined. Proposition transportf_twosided_disp_cat_product {wx₁ wx₂ : category_binproduct C₁ C₂} {yz₁ yz₂ : category_binproduct C₃ C₄} {d₁ : twosided_disp_cat_product_data wx₁ yz₁} {d₂ : twosided_disp_cat_product_data wx₂ yz₂} {fg fg' : wx₁ --> wx₂} (p : fg' = fg) {hk hk' : yz₁ --> yz₂} (q : hk' = hk) (φ : d₁ -->[ fg' ][ hk' ] d₂) : transportf_disp_mor2 p q φ = transportf_disp_mor2 (maponpaths pr1 p) (maponpaths pr1 q) (pr1 φ) ,, transportf_disp_mor2 (maponpaths dirprod_pr2 p) (maponpaths dirprod_pr2 q) (pr2 φ). Proof. induction p, q ; cbn. apply idpath. Qed. Proposition transportb_twosided_disp_cat_product {wx₁ wx₂ : category_binproduct C₁ C₂} {yz₁ yz₂ : category_binproduct C₃ C₄} {d₁ : twosided_disp_cat_product_data wx₁ yz₁} {d₂ : twosided_disp_cat_product_data wx₂ yz₂} {fg fg' : wx₁ --> wx₂} (p : fg = fg') {hk hk' : yz₁ --> yz₂} (q : hk = hk') (φ : d₁ -->[ fg' ][ hk' ] d₂) : transportb_disp_mor2 p q φ = transportb_disp_mor2 (maponpaths pr1 p) (maponpaths pr1 q) (pr1 φ) ,, transportb_disp_mor2 (maponpaths dirprod_pr2 p) (maponpaths dirprod_pr2 q) (pr2 φ). Proof. induction p, q ; cbn. apply idpath. Qed. Proposition twosided_disp_cat_product_axioms : twosided_disp_cat_axioms twosided_disp_cat_product_data. Proof. repeat split. - intro ; intros. rewrite transportb_twosided_disp_cat_product. use pathsdirprod. + refine (id_two_disp_left _ @ _). apply transportb_disp_mor2_eq. apply idpath. + refine (id_two_disp_left _ @ _). apply transportb_disp_mor2_eq. apply idpath. - intro ; intros. rewrite transportb_twosided_disp_cat_product. use pathsdirprod. + refine (id_two_disp_right _ @ _). apply transportb_disp_mor2_eq. apply idpath. + refine (id_two_disp_right _ @ _). apply transportb_disp_mor2_eq. apply idpath. - intro ; intros. rewrite transportb_twosided_disp_cat_product. use pathsdirprod. + refine (assoc_two_disp _ _ _ @ _). apply transportb_disp_mor2_eq. apply idpath. + refine (assoc_two_disp _ _ _ @ _). apply transportb_disp_mor2_eq. apply idpath. - intro ; intros. apply isaset_dirprod. + apply isaset_disp_mor. + apply isaset_disp_mor. Qed. Definition twosided_disp_cat_product : twosided_disp_cat (category_binproduct C₁ C₂) (category_binproduct C₃ C₄). Proof. simple refine (_ ,, _). - exact twosided_disp_cat_product_data. - exact twosided_disp_cat_product_axioms. Defined. (** 2. Isos in the product *) Definition is_isotwosided_disp_twosided_disp_cat_product {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} {fg : pr1 d₁ -->[ identity _ ][ identity _ ] pr1 d₂} (Hfg : is_iso_twosided_disp (identity_is_z_iso (pr1 wx)) (identity_is_z_iso (pr1 yz)) fg) {hk : pr2 d₁ -->[ identity _ ][ identity _ ] pr2 d₂} (Hhk : is_iso_twosided_disp (identity_is_z_iso (pr2 wx)) (identity_is_z_iso (pr2 yz)) hk) : @is_iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ _ _ _ _ (identity_is_z_iso wx) (identity_is_z_iso yz) (fg ,, hk). Proof. simple refine (_ ,, _ ,, _). - exact (iso_inv_twosided_disp Hfg ,, iso_inv_twosided_disp Hhk). - abstract (cbn ; rewrite transportb_twosided_disp_cat_product ; use dirprodeq ; cbn ; [ refine (inv_after_iso_twosided_disp Hfg @ _) | refine (inv_after_iso_twosided_disp Hhk @ _) ] ; use transportb_disp_mor2_eq ; apply idpath). - abstract (cbn ; rewrite transportb_twosided_disp_cat_product ; use dirprodeq ; cbn ; [ refine (iso_after_inv_twosided_disp Hfg @ _) | refine (iso_after_inv_twosided_disp Hhk @ _) ] ; use transportb_disp_mor2_eq ; apply idpath). Defined. Definition twosided_disp_cat_product_iso_weq_map {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} (fg : iso_twosided_disp (identity_z_iso (pr1 wx)) (identity_z_iso (pr1 yz)) (pr1 d₁) (pr1 d₂)) (hk : iso_twosided_disp (identity_z_iso (pr2 wx)) (identity_z_iso (pr2 yz)) (pr2 d₁) (pr2 d₂)) : @iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ (identity_z_iso wx) (identity_z_iso yz) d₁ d₂. Proof. use make_iso_twosided_disp. - exact (pr1 fg ,, pr1 hk). - apply is_isotwosided_disp_twosided_disp_cat_product. + apply fg. + apply hk. Defined. Definition is_twosided_disp_cat_iso_pr1 {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} (φ : d₁ -->[ identity _ ][ identity _ ] d₂) (Hφ : @is_iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ _ _ _ _ (identity_is_z_iso _) (identity_is_z_iso _) φ) : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr1 φ). Proof. simple refine (_ ,, _ ,, _). - exact (pr1 (iso_inv_twosided_disp Hφ)). - abstract (refine (maponpaths pr1 (inv_after_iso_twosided_disp Hφ) @ _) ; rewrite transportb_twosided_disp_cat_product ; cbn ; use transportb_disp_mor2_eq ; apply idpath). - abstract (refine (maponpaths pr1 (iso_after_inv_twosided_disp Hφ) @ _) ; rewrite transportb_twosided_disp_cat_product ; cbn ; use transportb_disp_mor2_eq ; apply idpath). Defined. Definition twosided_disp_cat_product_iso_weq_inv_pr1 {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} (φ : @iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ (identity_z_iso wx) (identity_z_iso yz) d₁ d₂) : iso_twosided_disp (identity_z_iso (pr1 wx)) (identity_z_iso (pr1 yz)) (pr1 d₁) (pr1 d₂). Proof. use make_iso_twosided_disp. - exact (pr11 φ). - apply is_twosided_disp_cat_iso_pr1. apply φ. Defined. Definition is_twosided_disp_cat_iso_pr2 {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} (φ : d₁ -->[ identity _ ][ identity _ ] d₂) (Hφ : @is_iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ _ _ _ _ (identity_is_z_iso _) (identity_is_z_iso _) φ) : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (pr2 φ). Proof. simple refine (_ ,, _ ,, _). - exact (pr2 (iso_inv_twosided_disp Hφ)). - abstract (refine (maponpaths dirprod_pr2 (inv_after_iso_twosided_disp Hφ) @ _) ; rewrite transportb_twosided_disp_cat_product ; cbn ; use transportb_disp_mor2_eq ; apply idpath). - abstract (refine (maponpaths dirprod_pr2 (iso_after_inv_twosided_disp Hφ) @ _) ; rewrite transportb_twosided_disp_cat_product ; cbn ; use transportb_disp_mor2_eq ; apply idpath). Defined. Definition twosided_disp_cat_product_iso_weq_inv_pr2 {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} {d₁ d₂ : twosided_disp_cat_product_data wx yz} (φ : @iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ (identity_z_iso wx) (identity_z_iso yz) d₁ d₂) : iso_twosided_disp (identity_z_iso (pr2 wx)) (identity_z_iso (pr2 yz)) (pr2 d₁) (pr2 d₂). Proof. use make_iso_twosided_disp. - exact (pr21 φ). - apply is_twosided_disp_cat_iso_pr2. apply φ. Defined. Definition twosided_disp_cat_product_iso_weq {wx : category_binproduct C₁ C₂} {yz : category_binproduct C₃ C₄} (d₁ d₂ : twosided_disp_cat_product_data wx yz) : iso_twosided_disp (identity_z_iso (pr1 wx)) (identity_z_iso (pr1 yz)) (pr1 d₁) (pr1 d₂) × iso_twosided_disp (identity_z_iso (pr2 wx)) (identity_z_iso (pr2 yz)) (pr2 d₁) (pr2 d₂) ≃ @iso_twosided_disp _ _ twosided_disp_cat_product _ _ _ _ (identity_z_iso wx) (identity_z_iso yz) d₁ d₂. Proof. use weq_iso. - exact (λ fghk, twosided_disp_cat_product_iso_weq_map (pr1 fghk) (pr2 fghk)). - exact (λ φ, twosided_disp_cat_product_iso_weq_inv_pr1 φ ,, twosided_disp_cat_product_iso_weq_inv_pr2 φ). - abstract (intros fghk ; use dirprodeq ; (use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ]) ; apply idpath). - abstract (intros φ ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 3. The univalence of the product *) Proposition is_univalent_twosided_disp_cat_product (HD₁ : is_univalent_twosided_disp_cat D₁) (HD₂ : is_univalent_twosided_disp_cat D₂) : is_univalent_twosided_disp_cat twosided_disp_cat_product. Proof. intros wx₁ wx₂ yz₁ yz₂ p q d₁ d₂. induction p, q. use weqhomot. - exact (twosided_disp_cat_product_iso_weq d₁ d₂ ∘ weqdirprodf (make_weq _ (HD₁ _ _ _ _ (idpath (pr1 wx₁)) (idpath (pr1 yz₁)) (pr1 d₁) (pr1 d₂))) (make_weq _ (HD₂ _ _ _ _ (idpath (pr2 wx₁)) (idpath (pr2 yz₁)) (pr2 d₁) (pr2 d₂))) ∘ pathsdirprodweq)%weq. - abstract (intro p ; cbn in p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. End ProdTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Product.v000066400000000000000000000064531451125700300274150ustar00rootroot00000000000000(********************************************************************************** The product via two-sided displayed categories By taking the displayed objects and displayed morphisms to be inhabitants of the unit type, we obtain the product of two categories. Contents 1. Definition via two-sided displayed categories 2. Discreteness and univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Local Open Scope cat. Section ProductTwoSidedDispCat. Context (C₁ C₂ : category). (** 1. Definition via two-sided displayed categories *) Definition prod_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ _ _, unit). - exact (λ _ _ _ _ _ _ _ _, unit). Defined. Definition prod_twosided_disp_cat_id_mor : twosided_disp_cat_id_comp prod_twosided_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ _ _ _, tt). - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt). Defined. Definition prod_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact prod_twosided_disp_cat_ob_mor. - exact prod_twosided_disp_cat_id_mor. Defined. Definition prod_twosided_disp_cat_axioms : twosided_disp_cat_axioms prod_twosided_disp_cat_data. Proof. repeat split ; intro ; intros. - apply isapropunit. - apply isapropunit. - apply isapropunit. - apply isasetunit. Qed. Definition prod_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact prod_twosided_disp_cat_data. - exact prod_twosided_disp_cat_axioms. Defined. (** 2. Discreteness and univalence *) Definition constant_twosided_disp_cat_is_iso : all_disp_mor_iso prod_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg. simple refine (_ ,, _ ,, _). - exact tt. - apply isapropunit. - apply isapropunit. Defined. Definition is_univalent_prod_twosided_disp_cat : is_univalent_twosided_disp_cat prod_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂. induction p₁, p₂ ; cbn. use isweqimplimpl. - intros f. apply isapropunit. - apply isasetunit. - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intros. apply isapropunit. Qed. Definition discrete_prod_twosided_disp_cat : discrete_twosided_disp_cat prod_twosided_disp_cat. Proof. repeat split. - intro ; intros. apply isapropunit. - exact constant_twosided_disp_cat_is_iso. - exact is_univalent_prod_twosided_disp_cat. Qed. End ProductTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Profunctor.v000066400000000000000000000140151451125700300301270ustar00rootroot00000000000000(********************************************************************************** Every profunctor gives rise to a discrete two-sided fibration Contents 1. Definition 2. Univalence and discreteness 3. The two-sided fibration **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.Profunctors.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Local Open Scope cat. Section ProfunctorToTwosidedDispCat. Context {C₁ C₂ : category} (P : profunctor C₁ C₂). (** 1. Definition *) Definition profunctor_to_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₂ C₁. Proof. simple refine (_ ,, _). - exact (λ x y, P (x ,, y) : hSet). - exact (λ x₁ x₂ y₁ y₂ z₁ z₂ f g, rmap P g z₁ = lmap P f z₂). Defined. Definition profunctor_to_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp profunctor_to_twosided_disp_cat_ob_mor. Proof. split. - intros x y xy ; cbn -[lmap rmap]. rewrite lmap_id, rmap_id. apply idpath. - intros x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂ ; cbn -[lmap rmap] in *. rewrite lmap_comp, rmap_comp. rewrite fg₁. rewrite rmap_lmap. rewrite fg₂. apply idpath. Qed. Definition profunctor_to_twosided_disp_cat_data : twosided_disp_cat_data C₂ C₁. Proof. simple refine (_ ,, _). - exact profunctor_to_twosided_disp_cat_ob_mor. - exact profunctor_to_twosided_disp_cat_id_comp. Defined. Definition isaprop_profunctor_to_twosided_mor {x₁ x₂ : C₁} (f : x₁ --> x₂) {y₁ y₂ : C₂} (g : y₁ --> y₂) (xy₁ : profunctor_to_twosided_disp_cat_data y₁ x₁) (xy₂ : profunctor_to_twosided_disp_cat_data y₂ x₂) (fg fg' : xy₁ -->[ g ][ f ] xy₂) : fg = fg'. Proof. apply (P (y₁ ,, x₂)). Qed. Definition profunctor_to_twosided_disp_cat_axioms : twosided_disp_cat_axioms profunctor_to_twosided_disp_cat_data. Proof. repeat split ; intro ; intros ; try (apply isaprop_profunctor_to_twosided_mor). apply isasetaprop. use invproofirrelevance. intro ; intro. apply isaprop_profunctor_to_twosided_mor. Qed. Definition profunctor_to_twosided_disp_cat : twosided_disp_cat C₂ C₁. Proof. simple refine (_ ,, _). - exact profunctor_to_twosided_disp_cat_data. - exact profunctor_to_twosided_disp_cat_axioms. Defined. (** 2. Univalence and discreteness *) Definition univalent_profunctor_to_twosided_disp_cat : is_univalent_twosided_disp_cat profunctor_to_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p q xy₁ xy₂. induction p ; induction q. use isweqimplimpl. - cbn. intro z. pose (p := pr1 z) ; cbn -[lmap rmap] in p. rewrite lmap_id, rmap_id in p. exact p. - apply (P (x₁ ,, y₁)). - use isaproptotal2. + intro. apply isaprop_is_iso_twosided_disp. + intro ; intros. apply isaprop_profunctor_to_twosided_mor. Qed. Definition discrete_profunctor_to_twosided_disp_cat : discrete_twosided_disp_cat profunctor_to_twosided_disp_cat. Proof. use make_discrete_twosided_disp_cat. repeat split. - intro ; intros. apply isaprop_profunctor_to_twosided_mor. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg p ; cbn -[lmap rmap] in *. pose (q := maponpaths (rmap P (inv_from_z_iso (g,, Hg))) p). cbn -[rmap lmap]. rewrite <- rmap_comp in q. assert (xy₁ = rmap P (inv_from_z_iso (g,, Hg)) (lmap P f xy₂)) as r. { refine (_ @ q). refine (!(rmap_id P xy₁) @ _). apply maponpaths_2. exact (!(z_iso_inv_after_z_iso (_ ,, Hg))). } rewrite r. rewrite rmap_lmap. rewrite <- lmap_comp. refine (!(lmap_id P _) @ _). apply maponpaths_2. exact (!(z_iso_after_z_iso_inv (_ ,, Hf))). - exact univalent_profunctor_to_twosided_disp_cat. Qed. (** 3. The two-sided fibration *) Definition profunctor_to_discrete_twosided_fibration : discrete_twosided_fibration C₂ C₁. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact profunctor_to_twosided_disp_cat. - exact discrete_profunctor_to_twosided_disp_cat. - intros x₁ x₂ y xy₂ f. simple refine (_ ,, _ ,, _). + exact (lmap P f xy₂). + abstract (cbn -[lmap rmap] ; rewrite rmap_id ; apply idpath). + abstract (cbn ; intro ; intros ; cbn -[lmap rmap] in * ; rewrite id_right in fg' ; rewrite fg' ; rewrite lmap_comp ; apply idpath). - intros y x₁ x₂ xy₂ f. simple refine (_ ,, _ ,, _). + exact (rmap P f xy₂). + abstract (cbn -[lmap rmap] ; rewrite lmap_id ; apply idpath). + abstract (cbn ; intro ; intros ; cbn -[lmap rmap] in * ; rewrite id_left in fg' ; rewrite <- fg' ; rewrite rmap_comp ; apply idpath). Defined. End ProfunctorToTwosidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Reindex.v000066400000000000000000000540551451125700300273740ustar00rootroot00000000000000(********************************************************************************** Reindexing two-sided displayed categories Suppose, we have a two-sided displayed category `D` over `C₁'` and `C₂'`. Suppose that we also have functors `F : C₁ ⟶ C₁'` and `G : C₂ ⟶ C₂'`. Then we can construct a two-sided displayed category over `C₁` and `C₂`. Contents 1. Transport lemmas 2. The definition 3. Isomorphisms 4. The univalence 5. Discreteness **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Local Open Scope cat. Section Reindexing. Context {C₁ C₁' C₂ C₂' : category} (F : C₁ ⟶ C₁') (G : C₂ ⟶ C₂') (D : twosided_disp_cat C₁' C₂'). (** 1. Transport lemmas *) Definition twosided_prod_transport_reindex {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D (F x₁) (G y₁)} {xy₂ : D (F x₂) (G y₂)} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ #F f₁ ][ #G g₁ ] xy₂) (p : f₁ = f₂) (q : g₁ = g₂) : transportf (λ z, _ -->[ #F z ][ _ ] _) p (transportf (λ z, _ -->[ _ ][ #G z ] _) q fg) = transportf (λ z, _ -->[ pr1 z ][ dirprod_pr2 z ] _) (pathsdirprod (maponpaths (λ z, #F z) p) (maponpaths (λ z, #G z) q)) fg. Proof. induction p ; induction q. apply idpath. Qed. Definition twosided_prod_transport_alt {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D (F x₁) (G y₁)} {xy₂ : D (F x₂) (G y₂)} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ #F f₁ ][ #G g₁ ] xy₂) (p : f₁ = f₂) (q : g₁ = g₂) : transportf (λ z, _ -->[ _ ][ #G z ] _) q (transportf (λ z, _ -->[ #F z ][ _ ] _) p fg) = transportf (λ z, _ -->[ pr1 z ][ dirprod_pr2 z ] _) (pathsdirprod (maponpaths (λ z, #F z) p) (maponpaths (λ z, #G z) q)) fg. Proof. induction p ; induction q. apply idpath. Qed. (** 2. The definition *) Definition reindex_twosided_disp_cat_ob_mor : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, D (F x) (G y)). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g, xy₁ -->[ #F f ][ #G g ] xy₂). Defined. Definition reindex_twosided_disp_cat_id_comp : twosided_disp_cat_id_comp reindex_twosided_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ x y xy, transportb (λ z, _ -->[ z ][ _] _) (functor_id _ _) (transportb (λ z, _ -->[ _ ][ z ] _) (functor_id _ _) (id_two_disp _))). - exact (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂, transportb (λ z, _ -->[ z ][ _] _) (functor_comp _ _ _) (transportb (λ z, _ -->[ _ ][ z ] _) (functor_comp _ _ _) (fg₁ ;;2 fg₂))). Defined. Definition reindex_twosided_disp_cat_data : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact reindex_twosided_disp_cat_ob_mor. - exact reindex_twosided_disp_cat_id_comp. Defined. Definition reindex_twosided_disp_cat_axioms : twosided_disp_cat_axioms reindex_twosided_disp_cat_data. Proof. repeat split. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg ; cbn. unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. rewrite two_disp_pre_whisker_left. rewrite two_disp_pre_whisker_right. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. apply id_two_disp_left. } unfold transportb. apply maponpaths. apply twosided_prod_transport. } rewrite !transport_f_f. rewrite twosided_prod_transport_reindex. apply maponpaths_2. apply isaset_dirprod ; apply homset_property. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg ; cbn. unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. rewrite two_disp_post_whisker_left. rewrite two_disp_post_whisker_right. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. apply id_two_disp_right. } unfold transportb. apply maponpaths. apply twosided_prod_transport. } rewrite !transport_f_f. rewrite twosided_prod_transport_reindex. apply maponpaths_2. apply isaset_dirprod ; apply homset_property. - intros x₁ x₂ x₃ x₄ y₁ y₂ y₃ y₄ xy₁ xy₂ xy₃ xy₄ f₁ f₂ f₃ g₁ g₂ g₃ fg₁ fg₂ fg₃. cbn. unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. rewrite two_disp_post_whisker_left. rewrite two_disp_post_whisker_right. etrans. { apply twosided_prod_transport. } etrans. { apply maponpaths. apply assoc_two_disp. } unfold transportb. apply maponpaths. apply twosided_prod_transport. } rewrite !transport_f_f. refine (!_). etrans. { do 2 apply maponpaths. etrans. { apply twosided_prod_transport. } apply maponpaths. rewrite two_disp_pre_whisker_left. rewrite two_disp_pre_whisker_right. apply twosided_prod_transport. } rewrite !twosided_prod_transport_reindex. rewrite !transport_f_f. apply maponpaths_2. apply isaset_dirprod ; apply homset_property. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g. apply isaset_disp_mor. Qed. Definition reindex_twosided_disp_cat : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact reindex_twosided_disp_cat_data. - exact reindex_twosided_disp_cat_axioms. Defined. (** 3. Isomorphisms *) Section MakeReindexIso. Context {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} (Hf : is_z_isomorphism f) {g : y₁ --> y₂} (Hg : is_z_isomorphism g) {xy₁ : D (F x₁) (G y₁)} {xy₂ : D (F x₂) (G y₂)} {fg : xy₁ -->[ #F f ][ #G g ] xy₂} (Hfg : is_iso_twosided_disp (functor_on_is_z_isomorphism F Hf) (functor_on_is_z_isomorphism G Hg) fg). Definition is_iso_reindex_twosided_disp_cat : @is_iso_twosided_disp _ _ reindex_twosided_disp_cat _ _ _ _ _ _ _ _ Hf Hg fg. Proof. simple refine (_ ,, _ ,, _). - exact (iso_inv_twosided_disp Hfg). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; exact (inv_after_iso_twosided_disp Hfg) | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ do 2 apply maponpaths ; apply twosided_prod_transport | ] ; etrans ; [ apply twosided_prod_transport_reindex | ] ; rewrite transport_f_f ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). - abstract (cbn ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; exact (iso_after_inv_twosided_disp Hfg) | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ do 2 apply maponpaths ; apply twosided_prod_transport | ] ; etrans ; [ apply twosided_prod_transport_reindex | ] ; rewrite transport_f_f ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). Defined. Definition iso_reindex_twosided_disp_cat : @iso_twosided_disp _ _ reindex_twosided_disp_cat _ _ _ _ (f ,, Hf) (g ,, Hg) xy₁ xy₂ := (fg ,, is_iso_reindex_twosided_disp_cat). End MakeReindexIso. Section FromReindexIso. Context {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} (Hf : is_z_isomorphism f) {g : y₁ --> y₂} (Hg : is_z_isomorphism g) {xy₁ : D (F x₁) (G y₁)} {xy₂ : D (F x₂) (G y₂)} {fg : xy₁ -->[ #F f ][ #G g ] xy₂} (Hfg : @is_iso_twosided_disp _ _ reindex_twosided_disp_cat _ _ _ _ _ _ _ _ Hf Hg fg). Definition from_is_iso_reindex_twosided_disp_cat : is_iso_twosided_disp (functor_on_is_z_isomorphism F Hf) (functor_on_is_z_isomorphism G Hg) fg. Proof. simple refine (_ ,, _ ,, _). - exact (iso_inv_twosided_disp Hfg). - abstract (cbn ; unfold transportb ; pose (p := inv_after_iso_twosided_disp Hfg) ; cbn in p ; rewrite twosided_prod_transportb in p ; pose (@transportf_transpose_right _ (λ z, _ -->[ pr1 z ][ dirprod_pr2 z ] _) _ _ (pathsdirprod _ _) _ _ p) as p' ; refine (p' @ _) ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn ; rewrite twosided_prod_transport_reindex ; rewrite !twosided_prod_transport ; rewrite !transport_f_f ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). - abstract (cbn ; unfold transportb ; pose (p := iso_after_inv_twosided_disp Hfg) ; cbn in p ; rewrite twosided_prod_transportb in p ; pose (@transportf_transpose_right _ (λ z, _ -->[ pr1 z ][ dirprod_pr2 z ] _) _ _ (pathsdirprod _ _) _ _ p) as p' ; refine (p' @ _) ; unfold transportb_disp_mor2, transportf_disp_mor2, transportb ; cbn ; rewrite twosided_prod_transport_reindex ; rewrite !twosided_prod_transport ; rewrite !transport_f_f ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). Defined. Definition iso_from_is_iso_reindex_twosided_disp_cat : @iso_twosided_disp _ _ D _ _ _ _ (#F f ,, functor_on_is_z_isomorphism F Hf) (#G g ,, functor_on_is_z_isomorphism G Hg) xy₁ xy₂ := (fg ,, from_is_iso_reindex_twosided_disp_cat). End FromReindexIso. Definition iso_weq_reindex_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : x₁ --> x₂} (Hf : is_z_isomorphism f) {g : y₁ --> y₂} (Hg : is_z_isomorphism g) (xy₁ : D (F x₁) (G y₁)) (xy₂ : D (F x₂) (G y₂)) : @iso_twosided_disp _ _ D _ _ _ _ (#F f ,, functor_on_is_z_isomorphism F Hf) (#G g ,, functor_on_is_z_isomorphism G Hg) xy₁ xy₂ ≃ @iso_twosided_disp _ _ reindex_twosided_disp_cat _ _ _ _ (f ,, Hf) (g ,, Hg) xy₁ xy₂. Proof. use weq_iso. - exact (λ fg, iso_reindex_twosided_disp_cat Hf Hg (pr2 fg)). - exact (λ fg, iso_from_is_iso_reindex_twosided_disp_cat Hf Hg (pr2 fg)). - abstract (intro fg ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). - abstract (intro fg ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. Definition is_univalent_reindex_twosided_disp_cat_help_to {x₁ : C₁} {y₁ : C₂} (xy₁ xy₂ : reindex_twosided_disp_cat x₁ y₁) (fg : iso_twosided_disp (identity_z_iso (F x₁)) (identity_z_iso (G y₁)) xy₁ xy₂) : iso_twosided_disp (_ ,, functor_on_is_z_isomorphism F (identity_is_z_iso x₁)) (_ ,, functor_on_is_z_isomorphism G (identity_is_z_iso y₁)) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (transportb (λ z, _ -->[ z ][ _] _) (functor_id _ _) (transportb (λ z, _ -->[ _ ][ z ] _) (functor_id _ _) (pr1 fg))). - exact (transportb (λ z, _ -->[ z ][ _] _) (functor_id _ _) (transportb (λ z, _ -->[ _ ][ z ] _) (functor_id _ _) (iso_inv_twosided_disp (pr2 fg)))). - abstract (cbn ; unfold transportb ; rewrite two_disp_pre_whisker_left ; rewrite two_disp_pre_whisker_right ; rewrite two_disp_post_whisker_left ; rewrite two_disp_post_whisker_right ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; etrans ; [ apply maponpaths ;apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ; unfold transportb ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ apply twosided_prod_transport | ] ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). - abstract (cbn ; unfold transportb ; rewrite two_disp_pre_whisker_left ; rewrite two_disp_pre_whisker_right ; rewrite two_disp_post_whisker_left ; rewrite two_disp_post_whisker_right ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; etrans ; [ apply maponpaths ;apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ; unfold transportb ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ apply twosided_prod_transport | ] ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. (** 4. The univalence *) Definition is_univalent_reindex_twosided_disp_cat_help_from {x₁ : C₁} {y₁ : C₂} (xy₁ xy₂ : reindex_twosided_disp_cat x₁ y₁) (fg : iso_twosided_disp (_ ,, functor_on_is_z_isomorphism F (identity_is_z_iso x₁)) (_ ,, functor_on_is_z_isomorphism G (identity_is_z_iso y₁)) xy₁ xy₂) : iso_twosided_disp (identity_z_iso (F x₁)) (identity_z_iso (G y₁)) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (transportf (λ z, _ -->[ z ][ _] _) (functor_id _ _) (transportf (λ z, _ -->[ _ ][ z ] _) (functor_id _ _) (pr1 fg))). - exact (transportf (λ z, _ -->[ z ][ _] _) (functor_id _ _) (transportf (λ z, _ -->[ _ ][ z ] _) (functor_id _ _) (iso_inv_twosided_disp (pr2 fg)))). - abstract (cbn ; rewrite two_disp_pre_whisker_left ; rewrite two_disp_pre_whisker_right ; rewrite two_disp_post_whisker_left ; rewrite two_disp_post_whisker_right ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; etrans ; [ apply maponpaths ;apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ; unfold transportb ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ apply twosided_prod_transport | ] ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). - abstract (cbn ; unfold transportb ; rewrite two_disp_pre_whisker_left ; rewrite two_disp_pre_whisker_right ; rewrite two_disp_post_whisker_left ; rewrite two_disp_post_whisker_right ; etrans ; [ apply twosided_prod_transport | ] ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; etrans ; [ apply maponpaths ;apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ; unfold transportb ; etrans ; [ apply maponpaths ; apply twosided_prod_transport | ] ; rewrite transport_f_f ; refine (!_) ; etrans ; [ apply twosided_prod_transport | ] ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition is_univalent_reindex_twosided_disp_cat_help_weq {x₁ : C₁} {y₁ : C₂} (xy₁ xy₂ : reindex_twosided_disp_cat x₁ y₁) : iso_twosided_disp (identity_z_iso (F x₁)) (identity_z_iso (G y₁)) xy₁ xy₂ ≃ iso_twosided_disp (_ ,, functor_on_is_z_isomorphism F (identity_is_z_iso x₁)) (_ ,, functor_on_is_z_isomorphism G (identity_is_z_iso y₁)) xy₁ xy₂. Proof. use weq_iso. - exact (is_univalent_reindex_twosided_disp_cat_help_to xy₁ xy₂). - exact (is_univalent_reindex_twosided_disp_cat_help_from xy₁ xy₂). - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn in * ; unfold transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; refine (_ @ @idpath_transportf _ (λ z, xy₁ -->[ pr1 z ][ dirprod_pr2 z ] xy₂) (_ ,, _) (pr1 f)) ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn in * ; unfold transportb ; rewrite !twosided_prod_transport ; rewrite transport_f_f ; refine (_ @ @idpath_transportf _ (λ z, xy₁ -->[ pr1 z ][ dirprod_pr2 z ] xy₂) (_ ,, _) (pr1 f)) ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition is_univalent_reindex_twosided_disp_cat (HD : is_univalent_twosided_disp_cat D) : is_univalent_twosided_disp_cat reindex_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ p q xy₁ xy₂. induction p ; induction q. use weqhomot. - exact (iso_weq_reindex_twosided_disp_cat _ _ xy₁ xy₂ ∘ is_univalent_reindex_twosided_disp_cat_help_weq xy₁ xy₂ ∘ make_weq _ (HD _ _ _ _ (idpath _) (idpath _) xy₁ xy₂))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 5. Discreteness *) Definition isaprop_disp_twosided_mor_reindex_twosided_disp_cat (HD₁ : isaprop_disp_twosided_mor D) : isaprop_disp_twosided_mor reindex_twosided_disp_cat. Proof. intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg fg'. apply HD₁. Qed. Definition all_disp_mor_iso_reindex_twosided_disp_cat (HD : all_disp_mor_iso D) : all_disp_mor_iso reindex_twosided_disp_cat. Proof. intro ; intros. apply is_iso_reindex_twosided_disp_cat. apply HD. Qed. Definition discrete_reindex_twosided_disp_cat (HD : discrete_twosided_disp_cat D) : discrete_twosided_disp_cat reindex_twosided_disp_cat. Proof. repeat split. - apply isaprop_disp_twosided_mor_reindex_twosided_disp_cat. apply HD. - apply all_disp_mor_iso_reindex_twosided_disp_cat. apply HD. - apply is_univalent_reindex_twosided_disp_cat. apply HD. Defined. End Reindexing. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Relations.v000066400000000000000000000350701451125700300277320ustar00rootroot00000000000000(********************************************************************************** The two-sided displayed category of relations We define two two-sided displayed categories of relations of sets. The first one has as displayed objects relations that are valued in `hProp`, while the second one, is about relations that are valued in `hSet`. Relations valued in `hSet` are also known as pseudo relations. Contents 1. Relations in `hProp` 1.1. The definition 1.2. Isomorphisms 1.3. Univalence 2. Relations in `hSet` 2.1. The definition 2.2. Isomorphisms 2.3. Univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Local Open Scope cat. Definition to_rel_weq {X Y : UU} {R₁ R₂ : X → Y → hProp} (p : R₁ = R₂) : ((∏ (x : X) (y : Y), R₁ x y → R₂ x y) × ∏ (x : X) (y : Y), R₂ x y → R₁ x y). Proof. induction p. split. - exact (λ _ _ r, r). - exact (λ _ _ r, r). Defined. Definition hProp_weq (X Y : hProp) : (X ≃ Y) ≃ ((X → Y) × (Y → X)). Proof. use weq_iso. - exact (λ w, pr1 w ,, invmap w). - exact (λ f, weqimplimpl (pr1 f) (pr2 f) (pr2 X) (pr2 Y)). - abstract (intro w ; cbn ; use subtypePath ; [ intro ; apply isapropisweq | ] ; cbn ; apply idpath). - abstract (intro w ; apply idpath). Defined. Definition rel_weq {X Y : UU} (R₁ R₂ : X → Y → hProp) : (R₁ = R₂) ≃ ∏ (x : X) (y : Y), (R₁ x y → R₂ x y) × (R₂ x y → R₁ x y) := (weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, hProp_weq _ _ ∘ UA_for_HLevels _ _ _)) ∘ weqonsecfibers _ _ (λ x, invweq (weqfunextsec (λ _, hProp) (R₁ x) (R₂ x))) ∘ invweq (weqfunextsec (λ _, Y → hProp) R₁ R₂))%weq. Definition set_rel_weq {X Y : UU} (R₁ R₂ : X → Y → hSet) : (R₁ = R₂) ≃ ∏ (x : X) (y : Y), R₁ x y ≃ R₂ x y := (weqonsecfibers _ _ (λ x, weqonsecfibers _ _ (λ y, UA_for_HLevels 2 _ _) ∘ invweq (weqfunextsec (λ _, hSet) (R₁ x) (R₂ x))) ∘ invweq (weqfunextsec (λ _, Y → hSet) R₁ R₂))%weq. (** 1. Relations in `hProp` *) (** 1.1. The definition *) Definition rel_disp_cat_ob_mor : twosided_disp_cat_ob_mor SET SET. Proof. simple refine (_ ,, _). - exact (λ (X : hSet) (Y : hSet), X → Y → hProp). - exact (λ (X₁ : hSet) X₂ (Y₁ : hSet) Y₂ R₁ R₂ f g, ∏ (x : X₁) (y : Y₁), R₁ x y → R₂ (f x) (g y)). Defined. Definition rel_disp_cat_id_comp : twosided_disp_cat_id_comp rel_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ X Y R x y r, r). - exact (λ X₁ X₂ X₃ Y₁ Y₂ Y₃ R₁ R₂ R₃ f₁ f₂ g₁ g₂ α β x y r, β _ _ (α _ _ r)). Defined. Definition rel_disp_cat_data : twosided_disp_cat_data SET SET. Proof. simple refine (_ ,, _). - exact rel_disp_cat_ob_mor. - exact rel_disp_cat_id_comp. Defined. Definition rel_disp_cat_axioms : twosided_disp_cat_axioms rel_disp_cat_data. Proof. repeat split. - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g α. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. apply R₂. - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g α. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. apply R₂. - intros X₁ X₂ X₃ X₄ Y₁ Y₂ Y₃ Y₄ R₁ R₂ R₃ R₄ f₁ f₂ f₃ g₁ g₂ g α β γ. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. apply R₄. - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g ; cbn. use impred_isaset ; intro x. use impred_isaset ; intro y. use impred_isaset ; intro r. apply isasetaprop. apply R₂. Qed. Definition rel_disp_cat : twosided_disp_cat SET SET. Proof. simple refine (_ ,, _). - exact rel_disp_cat_data. - exact rel_disp_cat_axioms. Defined. (** 1.2. Isomoprhisms *) Definition to_iso_rel_disp_cat {X Y : SET} (R₁ R₂ : rel_disp_cat X Y) (f : ∏ (x : pr1 X) (y : pr1 Y), (R₁ x y → R₂ x y) × (R₂ x y → R₁ x y)) : iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂. Proof. simple refine ((λ x y, pr1 (f x y)) ,, (λ x y, pr2 (f x y)) ,, _ ,, _). - abstract (cbn ; use funextsec ; intro x ; use funextsec ; intro y ; use funextsec ; intro r ; apply R₁). - abstract (cbn ; use funextsec ; intro x ; use funextsec ; intro y ; use funextsec ; intro r ; apply R₂). Defined. Definition from_iso_rel_disp_cat {X Y : SET} (R₁ R₂ : rel_disp_cat X Y) (f : iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂) : ∏ (x : pr1 X) (y : pr1 Y), (R₁ x y → R₂ x y) × (R₂ x y → R₁ x y) := λ x y, pr1 f x y ,, pr12 f x y. Definition iso_rel_disp_cat {X Y : SET} (R₁ R₂ : rel_disp_cat X Y) : (∏ (x : pr1 X) (y : pr1 Y), (R₁ x y → R₂ x y) × (R₂ x y → R₁ x y)) ≃ iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂. Proof. use make_weq. - exact (to_iso_rel_disp_cat R₁ R₂). - use isweq_iso. + exact (from_iso_rel_disp_cat R₁ R₂). + abstract (intros f ; apply idpath). + abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 1.3. Univalence *) Definition is_univalent_rel_twosided_disp_cat : is_univalent_twosided_disp_cat rel_disp_cat. Proof. intros X₁ X₂ Y₁ Y₂ p₁ p₂ R₁ R₂. induction p₁, p₂ ; cbn. use weqhomot. - exact (iso_rel_disp_cat R₁ R₂ ∘ rel_weq R₁ R₂)%weq. - abstract (intros p ; induction p ; cbn ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). Defined. (** 2. Relations in `hSet` *) (** 2.1. The definition *) Definition set_rel_disp_cat_ob_mor : twosided_disp_cat_ob_mor SET SET. Proof. simple refine (_ ,, _). - exact (λ (X : hSet) (Y : hSet), X → Y → hSet). - exact (λ (X₁ : hSet) X₂ (Y₁ : hSet) Y₂ R₁ R₂ f g, ∏ (x : X₁) (y : Y₁), R₁ x y → R₂ (f x) (g y)). Defined. Definition set_rel_disp_cat_id_comp : twosided_disp_cat_id_comp set_rel_disp_cat_ob_mor. Proof. simple refine (_ ,, _). - exact (λ X Y R x y r, r). - exact (λ X₁ X₂ X₃ Y₁ Y₂ Y₃ R₁ R₂ R₃ f₁ f₂ g₁ g₂ α β x y r, β _ _ (α _ _ r)). Defined. Definition set_rel_disp_cat_data : twosided_disp_cat_data SET SET. Proof. simple refine (_ ,, _). - exact set_rel_disp_cat_ob_mor. - exact set_rel_disp_cat_id_comp. Defined. Definition transportf_set_rel {X₁ X₂ Y₁ Y₂ : UU} (R₁ : X₁ → Y₁ → hSet) (R₂ : X₂ → Y₂ → hSet) {f₁ f₂ : X₁ → X₂} (p : f₂ = f₁) {g₁ g₂ : Y₁ → Y₂} (q : g₂ = g₁) (α : ∏ (x : X₁) (y : Y₁), R₁ x y → R₂ (f₂ x) (g₂ y)) {a : X₁} {b : Y₁} (r : R₁ a b) : transportf (λ (h : X₁ → X₂), ∏ (x : X₁) (y : Y₁), R₁ x y → R₂ (h x) (g₁ y)) p (transportf (λ (h : Y₁ → Y₂), ∏ (x : X₁) (y : Y₁), R₁ x y → R₂ (f₂ x) (h y)) q α) a b r = transportf (λ z, R₂ z _) (eqtohomot p _) (transportf (λ z, R₂ _ z) (eqtohomot q _) (α a b r)). Proof. induction p, q. cbn. apply idpath. Qed. Definition transportf_id_left {X Y : hSet} (f : SET ⟦ X , Y ⟧) (P : Y → UU) (x : X) (p : P (f x)) : transportf P (eqtohomot (!(id_left f)) x) p = p. Proof. refine (_ @ idpath_transportf _ _). apply maponpaths_2. apply Y. Qed. Definition transportf_id_right {X Y : hSet} (f : SET ⟦ X , Y ⟧) (P : Y → UU) (x : X) (p : P (f x)) : transportf P (eqtohomot (!(id_right f)) x) p = p. Proof. refine (_ @ idpath_transportf _ _). apply maponpaths_2. apply Y. Qed. Definition transportf_assoc {W X Y Z : hSet} (f : SET ⟦ W , X ⟧) (g : SET ⟦ X , Y ⟧) (h : SET ⟦ Y , Z ⟧) (P : Z → UU) (w : W) (p : P (h(g(f w)))) : transportf P (eqtohomot (!(assoc f g h)) w) p = p. Proof. refine (_ @ idpath_transportf _ _). apply maponpaths_2. apply Z. Qed. Definition set_rel_disp_cat_axioms : twosided_disp_cat_axioms set_rel_disp_cat_data. Proof. repeat split. - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g α. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_set_rel. rewrite (transportf_id_left f). rewrite (transportf_id_left g). apply idpath. - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g α. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_set_rel. rewrite (transportf_id_right f). rewrite (transportf_id_right g). apply idpath. - intros X₁ X₂ X₃ X₄ Y₁ Y₂ Y₃ Y₄ R₁ R₂ R₃ R₄ f₁ f₂ f₃ g₁ g₂ g₃ α β γ. use funextsec ; intro x. use funextsec ; intro y. use funextsec ; intro r. cbn. unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn. rewrite transportf_set_rel. refine (!_). etrans. { apply maponpaths. apply (transportf_assoc g₁ g₂ g₃ (λ z, R₄ (f₃ (f₂ (f₁ x))) z)). } apply (transportf_assoc f₁ f₂ f₃ (λ z, R₄ z (g₃ (g₂ (g₁ y))))). - intros X₁ X₂ Y₁ Y₂ R₁ R₂ f g ; cbn. use impred_isaset ; intro x. use impred_isaset ; intro y. use impred_isaset ; intro r. apply R₂. Qed. Definition set_rel_disp_cat : twosided_disp_cat SET SET. Proof. simple refine (_ ,, _). - exact set_rel_disp_cat_data. - exact set_rel_disp_cat_axioms. Defined. (** 2.2. Isomorphisms *) Definition to_iso_set_rel_disp_cat {X Y : SET} (R₁ R₂ : set_rel_disp_cat X Y) (f : ∏ (x : pr1 X) (y : pr1 Y), R₁ x y ≃ R₂ x y) : iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (λ x y, f x y). - exact (λ x y, invmap (f x y)). - abstract (cbn ; use funextsec ; intro x ; use funextsec ; intro y ; use funextsec ; intro r ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite transportf_set_rel ; refine (!_) ; do 2 (refine (transportf_id_left _ _ _ _ @ _)) ; exact (!(homotinvweqweq (f x y) r))). - abstract (cbn ; use funextsec ; intro x ; use funextsec ; intro y ; use funextsec ; intro r ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite transportf_set_rel ; refine (!_) ; do 2 (refine (transportf_id_left _ _ _ _ @ _)) ; exact (!(homotweqinvweq (f x y) r))). Defined. Definition from_iso_set_rel_disp_cat {X Y : SET} (R₁ R₂ : set_rel_disp_cat X Y) (f : iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂) (x : pr1 X) (y : pr1 Y) : R₁ x y ≃ R₂ x y. Proof. use weq_iso. - exact (pr1 f x y). - exact (pr12 f x y). - abstract (intros r ; pose (p := eqtohomot (eqtohomot (eqtohomot (pr122 f) x) y) r) ; refine (p @ _) ; cbn ; clear p ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite transportf_set_rel ; do 2 (refine (transportf_id_left _ _ _ _ @ _)) ; apply idpath). - abstract (intros r ; pose (p := eqtohomot (eqtohomot (eqtohomot (pr222 f) x) y) r) ; refine (p @ _) ; cbn ; clear p ; unfold transportb_disp_mor2, transportf_disp_mor2 ; cbn ; rewrite transportf_set_rel ; do 2 (refine (transportf_id_left _ _ _ _ @ _)) ; apply idpath). Defined. Definition iso_set_rel_disp_cat {X Y : SET} (R₁ R₂ : set_rel_disp_cat X Y) : (∏ (x : pr1 X) (y : pr1 Y), R₁ x y ≃ R₂ x y) ≃ iso_twosided_disp (identity_z_iso X) (identity_z_iso Y) R₁ R₂. Proof. use weq_iso. - exact (to_iso_set_rel_disp_cat R₁ R₂). - exact (from_iso_set_rel_disp_cat R₁ R₂). - abstract (intros f ; use funextsec ; intro x ; use funextsec ; intro y ; use subtypePath ; [ intro ; apply isapropisweq | ] ; apply idpath). - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). Defined. (** 2.3. Univalence *) Definition is_univalent_set_rel_twosided_disp_cat : is_univalent_twosided_disp_cat set_rel_disp_cat. Proof. intros X₁ X₂ Y₁ Y₂ p₁ p₂ R₁ R₂. induction p₁, p₂ ; cbn. use weqhomot. - exact (iso_set_rel_disp_cat R₁ R₂ ∘ set_rel_weq R₁ R₂)%weq. - abstract (intros p ; induction p ; cbn ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/Spans.v000066400000000000000000000600251451125700300270540ustar00rootroot00000000000000(********************************************************************************** The two-sided displayed category of spans A span in a category `C` is a diagram `x₁ <-- y --> x₂`. We construct a two-sided displayed category whose displayed objects are spans. We also give the spans that are necessary to construct the double category of spans. Contents 1. The definition 2. The univalence 3. Builders and accessors 4. Isomorphisms of spans 5. The identity spans 6. The composition of spans 7. The left unitor of spans 8. The right unitor of spans 9. The associator of spans **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat. Local Open Scope cat. Section Spans. Context (C : category). (** * 1. The definition *) Definition spans_ob : twosided_disp_cat C C := constant_twosided_disp_cat C C C. Definition spans_mor_left_ob_mor : disp_cat_ob_mor (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact (λ xyz, pr22 xyz --> pr1 xyz). - exact (λ xyz₁ xyz₂ l₁ l₂ fgh, l₁ · pr1 fgh = pr22 fgh · l₂). Defined. Definition spans_mor_left_id_comp : disp_cat_id_comp (total_twosided_disp_category spans_ob) spans_mor_left_ob_mor. Proof. split. - intros xyz fgh ; cbn. rewrite id_left, id_right. apply idpath. - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. apply idpath. Qed. Definition spans_mor_left_data : disp_cat_data (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact spans_mor_left_ob_mor. - exact spans_mor_left_id_comp. Defined. Definition spans_mor_left_axioms : disp_cat_axioms (total_twosided_disp_category spans_ob) spans_mor_left_data. Proof. repeat split. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply isasetaprop. apply homset_property. Qed. Definition spans_mor_left : disp_cat (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact spans_mor_left_data. - exact spans_mor_left_axioms. Defined. Definition spans_mor_right_ob_mor : disp_cat_ob_mor (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact (λ xyz, pr22 xyz --> pr12 xyz). - exact (λ xyz₁ xyz₂ l₁ l₂ fgh, l₁ · pr12 fgh = pr22 fgh · l₂). Defined. Definition spans_mor_right_id_comp : disp_cat_id_comp (total_twosided_disp_category spans_ob) spans_mor_right_ob_mor. Proof. split. - intros xyz fgh ; cbn. rewrite id_left, id_right. apply idpath. - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. apply idpath. Qed. Definition spans_mor_right_data : disp_cat_data (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact spans_mor_right_ob_mor. - exact spans_mor_right_id_comp. Defined. Definition spans_mor_right_axioms : disp_cat_axioms (total_twosided_disp_category spans_ob) spans_mor_right_data. Proof. repeat split. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply isasetaprop. apply homset_property. Qed. Definition spans_mor_right : disp_cat (total_twosided_disp_category spans_ob). Proof. simple refine (_ ,, _). - exact spans_mor_right_data. - exact spans_mor_right_axioms. Defined. Definition spans_mors : disp_cat (total_twosided_disp_category spans_ob) := dirprod_disp_cat spans_mor_left spans_mor_right. Definition twosided_disp_cat_of_spans : twosided_disp_cat C C := sigma_twosided_disp_cat _ spans_mors. (** * 2. The univalence *) Definition is_univalent_disp_spans_mor_left : is_univalent_disp spans_mor_left. Proof. intros x y p l₁ l₂. induction p. use isweqimplimpl. - intro f ; cbn in *. pose (p := pr1 f) ; cbn in p. rewrite id_left, id_right in p. exact p. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_disp_spans_mor_right : is_univalent_disp spans_mor_right. Proof. intros x y p l₁ l₂. induction p. use isweqimplimpl. - intro f ; cbn in *. pose (p := pr1 f) ; cbn in p. rewrite id_left, id_right in p. exact p. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_spans_twosided_disp_cat (HC : is_univalent C) : is_univalent_twosided_disp_cat twosided_disp_cat_of_spans. Proof. use is_univalent_sigma_of_twosided_disp_cat. - use is_univalent_constant_twosided_disp_cat. exact HC. - use dirprod_disp_cat_is_univalent. + exact is_univalent_disp_spans_mor_left. + exact is_univalent_disp_spans_mor_right. Defined. (** * 3. Builders and accessors *) Definition span (a b : C) : UU := twosided_disp_cat_of_spans a b. Definition make_span {a b x : C} (l : x --> a) (r : x --> b) : span a b := x ,, l ,, r. Definition ob_of_span {a b : C} (s : span a b) : C := pr1 s. Definition mor_left_of_span {a b : C} (s : span a b) : ob_of_span s --> a := pr12 s. Definition mor_right_of_span {a b : C} (s : span a b) : ob_of_span s --> b := pr22 s. Definition span_sqr {a₁ a₂ b₁ b₂ : C} (f : a₁ --> a₂) (g : b₁ --> b₂) (s₁ : span a₁ b₁) (s₂ : span a₂ b₂) : UU := s₁ -->[ f ][ g ] s₂. Definition span_laws {a₁ a₂ b₁ b₂ : C} (f : a₁ --> a₂) (g : b₁ --> b₂) (s₁ : span a₁ b₁) (s₂ : span a₂ b₂) (φ : ob_of_span s₁ --> ob_of_span s₂) : UU := (mor_left_of_span s₁ · f = φ · mor_left_of_span s₂) × (mor_right_of_span s₁ · g = φ · mor_right_of_span s₂). Definition make_span_sqr {a₁ a₂ b₁ b₂ : C} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (φ : ob_of_span s₁ --> ob_of_span s₂) (Hφ : span_laws f g _ _ φ) : span_sqr f g s₁ s₂ := φ ,, Hφ. Definition span_sqr_ob_mor {a₁ a₂ b₁ b₂ : C} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq : span_sqr f g s₁ s₂) : ob_of_span s₁ --> ob_of_span s₂ := pr1 sq. Proposition span_sqr_mor_left {a₁ a₂ b₁ b₂ : C} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq : span_sqr f g s₁ s₂) : mor_left_of_span s₁ · f = span_sqr_ob_mor sq · mor_left_of_span s₂. Proof. exact (pr12 sq). Qed. Proposition span_sqr_mor_right {a₁ a₂ b₁ b₂ : C} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq : span_sqr f g s₁ s₂) : mor_right_of_span s₁ · g = span_sqr_ob_mor sq · mor_right_of_span s₂. Proof. exact (pr22 sq). Qed. Proposition span_sqr_eq {a₁ a₂ b₁ b₂ : C} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq₁ sq₂ : span_sqr f g s₁ s₂) (p : span_sqr_ob_mor sq₁ = span_sqr_ob_mor sq₂) : sq₁ = sq₂. Proof. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } exact p. Qed. (** * 4. Isomorphisms of spans *) Proposition transportf_disp_mor2_span {a₁ a₂ b₁ b₂ : C} {f f' : a₁ --> a₂} (p : f = f') {g g' : b₁ --> b₂} (q : g = g') {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq : span_sqr f g s₁ s₂) : span_sqr_ob_mor (transportf_disp_mor2 p q sq) = span_sqr_ob_mor sq. Proof. induction p, q ; cbn. apply idpath. Qed. Proposition transportb_disp_mor2_span {a₁ a₂ b₁ b₂ : C} {f f' : a₁ --> a₂} (p : f' = f) {g g' : b₁ --> b₂} (q : g' = g) {s₁ : span a₁ b₁} {s₂ : span a₂ b₂} (sq : span_sqr f g s₁ s₂) : span_sqr_ob_mor (transportb_disp_mor2 p q sq) = span_sqr_ob_mor sq. Proof. apply transportf_disp_mor2_span. Qed. Section IsoSpan. Context {a b : C} {s₁ : span a b} {s₂ : span a b} (sq : span_sqr (identity _) (identity _) s₁ s₂) (Hsq : is_z_isomorphism (span_sqr_ob_mor sq)). Let i : z_iso (ob_of_span s₁) (ob_of_span s₂) := make_z_iso _ _ Hsq. Proposition is_iso_twosided_disp_span_sqr_inv_laws : span_laws (identity a) (identity b) s₂ s₁ (inv_from_z_iso i). Proof. split. - rewrite id_right. refine (!_). use z_iso_inv_on_right. refine (_ @ span_sqr_mor_left sq). rewrite id_right. apply idpath. - rewrite id_right. refine (!_). use z_iso_inv_on_right. refine (_ @ span_sqr_mor_right sq). rewrite id_right. apply idpath. Qed. Definition is_iso_twosided_disp_span_sqr_inv : span_sqr (identity _) (identity _) s₂ s₁. Proof. use make_span_sqr. - exact (inv_from_z_iso i). - exact is_iso_twosided_disp_span_sqr_inv_laws. Defined. Definition is_iso_twosided_disp_span_sqr : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) sq. Proof. simple refine (_ ,, _ ,, _). - exact is_iso_twosided_disp_span_sqr_inv. - abstract (use span_sqr_eq ; rewrite transportb_disp_mor2_span ; cbn ; exact (z_iso_inv_after_z_iso i)). - abstract (use span_sqr_eq ; rewrite transportb_disp_mor2_span ; cbn ; exact (z_iso_after_z_iso_inv i)). Defined. End IsoSpan. (** * 5. The identity spans *) Definition id_span (a : C) : span a a. Proof. use make_span. - exact a. - exact (identity _). - exact (identity _). Defined. Proposition id_span_mor_laws {x y : C} (f : x --> y) : span_laws f f (id_span x) (id_span y) f. Proof. split ; cbn. - rewrite id_left, id_right. apply idpath. - rewrite id_left, id_right. apply idpath. Qed. Definition id_span_mor {x y : C} (f : x --> y) : span_sqr f f (id_span x) (id_span y). Proof. use make_span_sqr. - exact f. - apply id_span_mor_laws. Defined. Context (PC : Pullbacks C). (** * 6. The composition of spans *) Section CompSpan. Context {x y z : C} (s : span x y) (t : span y z). Definition comp_span_Pullback : Pullback (mor_right_of_span s) (mor_left_of_span t) := PC _ _ _ (mor_right_of_span s) (mor_left_of_span t). Definition comp_span : span x z. Proof. use make_span. - exact comp_span_Pullback. - exact (PullbackPr1 _ · mor_left_of_span s). - exact (PullbackPr2 _ · mor_right_of_span t). Defined. End CompSpan. Section CompSpanMor. Context {x₁ x₂ y₁ y₂ z₁ z₂ : C} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {h₁ : span x₁ y₁} {h₂ : span y₁ z₁} {k₁ : span x₂ y₂} {k₂ : span y₂ z₂} (s₁ : span_sqr v₁ v₂ h₁ k₁) (s₂ : span_sqr v₂ v₃ h₂ k₂). Definition mor_of_comp_span_mor : comp_span_Pullback h₁ h₂ --> comp_span_Pullback k₁ k₂. Proof. use PullbackArrow. - exact (PullbackPr1 _ · span_sqr_ob_mor s₁). - exact (PullbackPr2 _ · span_sqr_ob_mor s₂). - abstract (rewrite !assoc' ; rewrite <- span_sqr_mor_left, <- span_sqr_mor_right ; rewrite !assoc ; apply maponpaths_2 ; apply PullbackSqrCommutes). Defined. Proposition comp_span_mor_laws : span_laws v₁ v₃ (comp_span h₁ h₂) (comp_span k₁ k₂) mor_of_comp_span_mor. Proof. split ; cbn. - unfold mor_of_comp_span_mor. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. rewrite !assoc'. apply maponpaths. apply span_sqr_mor_left. - unfold mor_of_comp_span_mor. rewrite !assoc. rewrite PullbackArrow_PullbackPr2. rewrite !assoc'. apply maponpaths. apply span_sqr_mor_right. Qed. Definition comp_span_mor : span_sqr v₁ v₃ (comp_span h₁ h₂) (comp_span k₁ k₂). Proof. use make_span_sqr. - exact mor_of_comp_span_mor. - exact comp_span_mor_laws. Defined. End CompSpanMor. (** * 7. The left unitor of spans *) Section SpanLunitor. Context {x y : C} (h : span x y). Definition span_lunitor_mor : comp_span_Pullback (id_span x) h --> ob_of_span h := PullbackPr2 _. Definition span_linvunitor : ob_of_span h --> comp_span_Pullback (id_span x) h. Proof. use PullbackArrow. - exact (mor_left_of_span h). - exact (identity _). - abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Proposition is_z_iso_span_lunitor_mor_eqs : is_inverse_in_precat span_lunitor_mor span_linvunitor. Proof. split ; unfold span_lunitor_mor, span_linvunitor ; cbn. - use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite !assoc'. rewrite PullbackArrow_PullbackPr1. rewrite id_left. rewrite <- PullbackSqrCommutes. apply id_right. + rewrite !assoc'. rewrite PullbackArrow_PullbackPr2. rewrite id_left, id_right. apply idpath. - apply PullbackArrow_PullbackPr2. Qed. Definition is_z_iso_span_lunitor_mor : is_z_isomorphism span_lunitor_mor. Proof. use make_is_z_isomorphism. - exact span_linvunitor. - exact is_z_iso_span_lunitor_mor_eqs. Defined. Proposition span_lunitor_laws : span_laws (identity x) (identity y) (comp_span (id_span x) h) h span_lunitor_mor. Proof. split ; cbn ; unfold span_lunitor_mor. - rewrite !id_right. rewrite <- PullbackSqrCommutes ; cbn. rewrite id_right. apply idpath. - rewrite id_right. apply idpath. Qed. Definition span_lunitor : span_sqr (identity _) (identity _) (comp_span (id_span _) h) h. Proof. use make_span_sqr. - exact span_lunitor_mor. - exact span_lunitor_laws. Defined. End SpanLunitor. (** * 8. The right unitor of spans *) Section SpanRunitor. Context {x y : C} (h : span x y). Definition span_runitor_mor : comp_span_Pullback h (id_span y) --> ob_of_span h := PullbackPr1 _. Definition span_rinvunitor : ob_of_span h --> comp_span_Pullback h (id_span y). Proof. use PullbackArrow. - exact (identity _). - exact (mor_right_of_span h). - abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Proposition is_z_iso_span_runitor_mor_eqs : is_inverse_in_precat span_runitor_mor span_rinvunitor. Proof. split ; unfold span_runitor_mor, span_rinvunitor ; cbn. - use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite !assoc'. rewrite PullbackArrow_PullbackPr1. rewrite id_left. apply id_right. + rewrite !assoc'. rewrite PullbackArrow_PullbackPr2. rewrite id_left. rewrite PullbackSqrCommutes. apply id_right. - apply PullbackArrow_PullbackPr1. Qed. Definition is_z_iso_span_runitor_mor : is_z_isomorphism span_runitor_mor. Proof. use make_is_z_isomorphism. - exact span_rinvunitor. - exact is_z_iso_span_runitor_mor_eqs. Defined. Proposition span_runitor_laws : span_laws (identity x) (identity y) (comp_span h (id_span y)) h span_runitor_mor. Proof. split ; cbn ; unfold span_runitor_mor. - rewrite id_right. apply idpath. - rewrite !id_right. rewrite PullbackSqrCommutes ; cbn. rewrite id_right. apply idpath. Qed. Definition span_runitor : span_sqr (identity _) (identity _) (comp_span h (id_span _)) h. Proof. use make_span_sqr. - exact span_runitor_mor. - exact span_runitor_laws. Defined. End SpanRunitor. (** * 9. The associator of spans *) Section SpanAssociator. Context {w x y z : C} (h₁ : span w x) (h₂ : span x y) (h₃ : span y z). Definition span_associator_mor : comp_span_Pullback h₁ (comp_span h₂ h₃) --> comp_span_Pullback (comp_span h₁ h₂) h₃. Proof. use PullbackArrow. - use PullbackArrow. + exact (PullbackPr1 _). + exact (PullbackPr2 _ · PullbackPr1 _). + abstract (rewrite !assoc' ; rewrite PullbackSqrCommutes ; apply idpath). - exact (PullbackPr2 _ · PullbackPr2 _). - abstract (cbn ; rewrite !assoc ; rewrite PullbackArrow_PullbackPr2 ; rewrite !assoc' ; rewrite PullbackSqrCommutes ; apply idpath). Defined. Definition span_associator_mor_inv : comp_span_Pullback (comp_span h₁ h₂) h₃ --> comp_span_Pullback h₁ (comp_span h₂ h₃). Proof. use PullbackArrow. - exact (PullbackPr1 _ · PullbackPr1 _). - use PullbackArrow. + exact (PullbackPr1 _ · PullbackPr2 _). + exact (PullbackPr2 _). + abstract (rewrite !assoc' ; rewrite PullbackSqrCommutes ; apply idpath). - abstract (cbn ; rewrite !assoc ; rewrite PullbackArrow_PullbackPr1 ; rewrite !assoc' ; rewrite PullbackSqrCommutes ; apply idpath). Defined. Proposition is_iso_span_associator_mor_eq : is_inverse_in_precat span_associator_mor span_associator_mor_inv. Proof. split. - use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite id_left. unfold span_associator_mor_inv. rewrite !assoc'. rewrite PullbackArrow_PullbackPr1. unfold span_associator_mor. rewrite !assoc. rewrite !PullbackArrow_PullbackPr1. apply idpath. + rewrite id_left. unfold span_associator_mor_inv. rewrite !assoc'. rewrite PullbackArrow_PullbackPr2. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. * rewrite !assoc'. rewrite PullbackArrow_PullbackPr1. unfold span_associator_mor. rewrite !assoc. rewrite PullbackArrow_PullbackPr1. rewrite PullbackArrow_PullbackPr2. apply idpath. * rewrite !assoc'. unfold span_associator_mor. rewrite !PullbackArrow_PullbackPr2. apply idpath. - use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. + rewrite id_left. unfold span_associator_mor. rewrite !assoc'. rewrite PullbackArrow_PullbackPr1. use (MorphismsIntoPullbackEqual (isPullback_Pullback (PC _ _ _ _ _))) ; cbn. * rewrite !assoc'. rewrite !PullbackArrow_PullbackPr1. unfold span_associator_mor_inv. rewrite PullbackArrow_PullbackPr1. apply idpath. * rewrite !assoc'. rewrite !PullbackArrow_PullbackPr2. unfold span_associator_mor_inv. rewrite !assoc. rewrite PullbackArrow_PullbackPr2. rewrite PullbackArrow_PullbackPr1. apply idpath. + rewrite !assoc'. unfold span_associator_mor. rewrite PullbackArrow_PullbackPr2. unfold span_associator_mor_inv. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. rewrite id_left. apply idpath. Qed. Definition is_z_iso_span_associator_mor : is_z_isomorphism span_associator_mor. Proof. use make_is_z_isomorphism. - exact span_associator_mor_inv. - exact is_iso_span_associator_mor_eq. Defined. Proposition span_associator_laws : span_laws (identity _) (identity _) (comp_span h₁ (comp_span h₂ h₃)) (comp_span (comp_span h₁ h₂) h₃) span_associator_mor. Proof. split ; cbn. - rewrite id_right. unfold span_associator_mor. rewrite !assoc. rewrite !PullbackArrow_PullbackPr1. apply idpath. - rewrite id_right. unfold span_associator_mor. rewrite !assoc. rewrite !PullbackArrow_PullbackPr2. apply idpath. Qed. Definition span_associator : span_sqr (identity _) (identity _) (comp_span h₁ (comp_span h₂ h₃)) (comp_span (comp_span h₁ h₂) h₃). Proof. use make_span_sqr. - exact span_associator_mor. - exact span_associator_laws. Defined. End SpanAssociator. End Spans. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Examples/StructuredCospans.v000066400000000000000000001006051451125700300314620ustar00rootroot00000000000000(********************************************************************************** Structured cospans In this file, we define the 2-sided displayed category of structured cospans. Our definition is based on Theorem 3.1 in Structured Versus Decorated Cospans by Baez, Courser, and Vasilakopoulou. Note that even though they define a monoidal double category, the definition in this file only consists of the horizontal and vertical morphisms, and the squares. For that reason, we don't need to assume the existence of pushouts in any of the involved categories and we also don't need to assume that the functor `L` preserves pushouts, We also prove that the obtained 2-sided displayed category is univalent. Fix categories `A` and `X` and a functor `A ⟶ X`. The construction of the 2-sided displayed category is done in multiple steps. In this 2-sided displayed category, the objects describe what a structured cospan between objects `a` and `b` in `A`. Such a cospan consists of an object `x` in `X` and morphisms `L a --> x` and `L b --> x`. Each part of this definition is put in its own 2-sided displayed category: - We add the object `x` in [struct_cospans_ob] - The morphism `L a --> x` is added in [struct_cospans_mor_left], which is a displayed category on the total category of [struct_cospans_ob]. - The morphism `L b --> x` is added in [struct_cospans_mor_right], which is a displayed category on the total category of [struct_cospans_ob]. Combining these together by taking products and a sigma, we obtain the 2-sided displayed category of structured cospans. We also characterize global isomorphism squares (i.e., those squares of which the vertical sides are identities) of structured cospans. In addition, we give some standard structured cospans. Furthermore, we define an action of functors on structured cospans, and we show that this gives rise to a functor between 2-sided displayed categories. Contents 1. The 2-sided displayed category of structured cospans 2. Builders and accessors for structured cospans 3. The univalence of the 2-sided displayed category of structured cospans 4. Isos of structured cospans 5. The identity structured cospans 6. The composition of structured cospans 7. The left unitor of structured cospans 8. The right unitor of structured cospans 9. The associator of structured cospans 10. Functors on structured cospans **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat. Local Open Scope cat. Section StructuredCospans. Context {A X : category} (L : A ⟶ X). (** 1. The 2-sided displayed category of structured cospans *) Definition struct_cospans_ob : twosided_disp_cat A A := constant_twosided_disp_cat A A X. Definition struct_cospans_mor_left_ob_mor : disp_cat_ob_mor (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact (λ xyz, L (pr1 xyz) --> pr22 xyz). - exact (λ xyz₁ xyz₂ l₁ l₂ fgh, l₁ · pr22 fgh = #L (pr1 fgh) · l₂). Defined. Definition struct_cospans_mor_left_id_comp : disp_cat_id_comp _ struct_cospans_mor_left_ob_mor. Proof. split. - intros xyz fgh ; cbn. rewrite id_right. rewrite functor_id, id_left. apply idpath. - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. rewrite !assoc. rewrite <- functor_comp. apply idpath. Qed. Definition struct_cospans_mor_left_data : disp_cat_data (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact struct_cospans_mor_left_ob_mor. - exact struct_cospans_mor_left_id_comp. Defined. Definition struct_cospans_mor_left_axioms : disp_cat_axioms _ struct_cospans_mor_left_data. Proof. repeat split. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply isasetaprop. apply homset_property. Qed. Definition struct_cospans_mor_left : disp_cat (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact struct_cospans_mor_left_data. - exact struct_cospans_mor_left_axioms. Defined. Definition struct_cospans_mor_right_ob_mor : disp_cat_ob_mor (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact (λ xyz, L(pr12 xyz) --> pr22 xyz). - exact (λ xyz₁ xyz₂ l₁ l₂ fgh, l₁ · pr22 fgh = #L(pr12 fgh) · l₂). Defined. Definition struct_cospans_mor_right_id_comp : disp_cat_id_comp (total_twosided_disp_category struct_cospans_ob) struct_cospans_mor_right_ob_mor. Proof. split. - intros xyz fgh ; cbn. rewrite id_right. rewrite functor_id, id_left. apply idpath. - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *. rewrite !assoc. rewrite p₁. rewrite !assoc'. rewrite p₂. rewrite !assoc. rewrite <- functor_comp. apply idpath. Qed. Definition struct_cospans_mor_right_data : disp_cat_data (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact struct_cospans_mor_right_ob_mor. - exact struct_cospans_mor_right_id_comp. Defined. Definition struct_cospans_mor_right_axioms : disp_cat_axioms _ struct_cospans_mor_right_data. Proof. repeat split. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply homset_property. - intro ; intros. apply isasetaprop. apply homset_property. Qed. Definition struct_cospans_mor_right : disp_cat (total_twosided_disp_category struct_cospans_ob). Proof. simple refine (_ ,, _). - exact struct_cospans_mor_right_data. - exact struct_cospans_mor_right_axioms. Defined. Definition struct_cospans_mors : disp_cat (total_twosided_disp_category struct_cospans_ob) := dirprod_disp_cat struct_cospans_mor_left struct_cospans_mor_right. Definition twosided_disp_cat_of_struct_cospans : twosided_disp_cat A A := sigma_twosided_disp_cat _ struct_cospans_mors. (** 2. Builders and accessors for structured cospans *) Definition struct_cospan (a b : A) : UU := twosided_disp_cat_of_struct_cospans a b. Definition make_struct_cospan {a b : A} (x : X) (l : L a --> x) (r : L b --> x) : struct_cospan a b := x ,, l ,, r. Definition ob_of_struct_cospan {a b : A} (s : struct_cospan a b) : X := pr1 s. Definition mor_left_of_struct_cospan {a b : A} (s : struct_cospan a b) : L a --> ob_of_struct_cospan s := pr12 s. Definition mor_right_of_struct_cospan {a b : A} (s : struct_cospan a b) : L b --> ob_of_struct_cospan s := pr22 s. Definition struct_cospan_sqr {a₁ a₂ b₁ b₂ : A} (f : a₁ --> a₂) (g : b₁ --> b₂) (s₁ : struct_cospan a₁ b₁) (s₂ : struct_cospan a₂ b₂) : UU := s₁ -->[ f ][ g ] s₂. Definition struct_cospan_laws {a₁ a₂ b₁ b₂ : A} (f : a₁ --> a₂) (g : b₁ --> b₂) (s₁ : struct_cospan a₁ b₁) (s₂ : struct_cospan a₂ b₂) (φ : ob_of_struct_cospan s₁ --> ob_of_struct_cospan s₂) : UU := (mor_left_of_struct_cospan s₁ · φ = #L f · mor_left_of_struct_cospan s₂) × (mor_right_of_struct_cospan s₁ · φ = #L g · mor_right_of_struct_cospan s₂). Definition make_struct_cospan_sqr {a₁ a₂ b₁ b₂ : A} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (φ : ob_of_struct_cospan s₁ --> ob_of_struct_cospan s₂) (Hφ : struct_cospan_laws f g _ _ φ) : struct_cospan_sqr f g s₁ s₂ := φ ,, pr1 Hφ ,, pr2 Hφ. Definition struct_cospan_sqr_ob_mor {a₁ a₂ b₁ b₂ : A} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq : struct_cospan_sqr f g s₁ s₂) : ob_of_struct_cospan s₁ --> ob_of_struct_cospan s₂ := pr1 sq. Proposition struct_cospan_sqr_mor_left {a₁ a₂ b₁ b₂ : A} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq : struct_cospan_sqr f g s₁ s₂) : mor_left_of_struct_cospan s₁ · struct_cospan_sqr_ob_mor sq = #L f · mor_left_of_struct_cospan s₂. Proof. exact (pr12 sq). Qed. Proposition struct_cospan_sqr_mor_right {a₁ a₂ b₁ b₂ : A} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq : struct_cospan_sqr f g s₁ s₂) : mor_right_of_struct_cospan s₁ · struct_cospan_sqr_ob_mor sq = #L g · mor_right_of_struct_cospan s₂. Proof. exact (pr22 sq). Qed. Proposition struct_cospan_sqr_eq {a₁ a₂ b₁ b₂ : A} {f : a₁ --> a₂} {g : b₁ --> b₂} {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq₁ sq₂ : struct_cospan_sqr f g s₁ s₂) (p : struct_cospan_sqr_ob_mor sq₁ = struct_cospan_sqr_ob_mor sq₂) : sq₁ = sq₂. Proof. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } exact p. Qed. (** 3. The univalence of the 2-sided displayed category of structured cospans *) Definition is_univalent_disp_struct_cospans_mor_left : is_univalent_disp struct_cospans_mor_left. Proof. intros x y p l₁ l₂. induction p. use isweqimplimpl. - intro f ; cbn in *. pose (p := pr1 f) ; cbn in p. rewrite functor_id, id_left, id_right in p. exact p. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_disp_struct_cospans_mor_right : is_univalent_disp struct_cospans_mor_right. Proof. intros x y p l₁ l₂. induction p. use isweqimplimpl. - intro f ; cbn in *. pose (p := pr1 f) ; cbn in p. rewrite functor_id, id_left, id_right in p. exact p. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition is_univalent_struct_cospans_twosided_disp_cat (HX : is_univalent X) : is_univalent_twosided_disp_cat twosided_disp_cat_of_struct_cospans. Proof. use is_univalent_sigma_of_twosided_disp_cat. - use is_univalent_constant_twosided_disp_cat. exact HX. - use dirprod_disp_cat_is_univalent. + exact is_univalent_disp_struct_cospans_mor_left. + exact is_univalent_disp_struct_cospans_mor_right. Defined. (** 4. Isos of structured cospans *) Proposition transportf_disp_mor2_struct_cospan {a₁ a₂ b₁ b₂ : A} {f f' : a₁ --> a₂} (p : f = f') {g g' : b₁ --> b₂} (q : g = g') {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq : struct_cospan_sqr f g s₁ s₂) : struct_cospan_sqr_ob_mor (transportf_disp_mor2 p q sq) = struct_cospan_sqr_ob_mor sq. Proof. induction p, q ; cbn. apply idpath. Qed. Proposition transportb_disp_mor2_struct_cospan {a₁ a₂ b₁ b₂ : A} {f f' : a₁ --> a₂} (p : f' = f) {g g' : b₁ --> b₂} (q : g' = g) {s₁ : struct_cospan a₁ b₁} {s₂ : struct_cospan a₂ b₂} (sq : struct_cospan_sqr f g s₁ s₂) : struct_cospan_sqr_ob_mor (transportb_disp_mor2 p q sq) = struct_cospan_sqr_ob_mor sq. Proof. apply transportf_disp_mor2_struct_cospan. Qed. Section IsoStructCospan. Context {a b : A} {s₁ : struct_cospan a b} {s₂ : struct_cospan a b} (sq : struct_cospan_sqr (identity _) (identity _) s₁ s₂) (Hsq : is_z_isomorphism (struct_cospan_sqr_ob_mor sq)). Let i : z_iso (ob_of_struct_cospan s₁) (ob_of_struct_cospan s₂) := make_z_iso _ _ Hsq. Proposition is_iso_twosided_disp_struct_cospan_sqr_inv_laws : struct_cospan_laws (identity a) (identity b) s₂ s₁ (inv_from_z_iso i). Proof. split. - rewrite functor_id, id_left. refine (!_). use z_iso_inv_on_left. refine (_ @ !(struct_cospan_sqr_mor_left sq)). rewrite functor_id, id_left. apply idpath. - rewrite functor_id, id_left. refine (!_). use z_iso_inv_on_left. refine (_ @ !(struct_cospan_sqr_mor_right sq)). rewrite functor_id, id_left. apply idpath. Qed. Definition is_iso_twosided_disp_struct_cospan_sqr_inv : struct_cospan_sqr (identity _) (identity _) s₂ s₁. Proof. use make_struct_cospan_sqr. - exact (inv_from_z_iso i). - exact is_iso_twosided_disp_struct_cospan_sqr_inv_laws. Defined. Definition is_iso_twosided_disp_struct_cospan_sqr : is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) sq. Proof. simple refine (_ ,, _ ,, _). - exact is_iso_twosided_disp_struct_cospan_sqr_inv. - abstract (use struct_cospan_sqr_eq ; rewrite transportb_disp_mor2_struct_cospan ; cbn ; exact (z_iso_inv_after_z_iso i)). - abstract (use struct_cospan_sqr_eq ; rewrite transportb_disp_mor2_struct_cospan ; cbn ; exact (z_iso_after_z_iso_inv i)). Defined. End IsoStructCospan. End StructuredCospans. Section StandardCospans. Context {A X : category} (L : A ⟶ X). (** 5. The identity structured cospans *) Definition id_struct_cospan (a : A) : struct_cospan L a a. Proof. use make_struct_cospan. - exact (L a). - exact (identity _). - exact (identity _). Defined. Proposition id_struct_cospan_mor_laws {x y : A} (f : x --> y) : struct_cospan_laws L f f (id_struct_cospan x) (id_struct_cospan y) (# L f). Proof. split ; cbn. - rewrite id_left, id_right. apply idpath. - rewrite id_left, id_right. apply idpath. Qed. Definition id_struct_cospan_mor {x y : A} (f : x --> y) : struct_cospan_sqr L f f (id_struct_cospan x) (id_struct_cospan y). Proof. use make_struct_cospan_sqr. - exact (#L f). - apply id_struct_cospan_mor_laws. Defined. Context (PX : Pushouts X). (** 6. The composition of structured cospans *) Section CompCospan. Context {x y z : A} (s : struct_cospan L x y) (t : struct_cospan L y z). Definition comp_struct_cospan_Pushout : Pushout (mor_right_of_struct_cospan L s) (mor_left_of_struct_cospan L t) := PX _ _ _ (mor_right_of_struct_cospan L s) (mor_left_of_struct_cospan L t). Definition comp_struct_cospan : struct_cospan L x z. Proof. use make_struct_cospan. - exact comp_struct_cospan_Pushout. - exact (mor_left_of_struct_cospan L s · PushoutIn1 _). - exact (mor_right_of_struct_cospan L t · PushoutIn2 _). Defined. End CompCospan. Section CompCospanMor. Context {x₁ x₂ y₁ y₂ z₁ z₂ : A} {v₁ : x₁ --> x₂} {v₂ : y₁ --> y₂} {v₃ : z₁ --> z₂} {h₁ : struct_cospan L x₁ y₁} {h₂ : struct_cospan L y₁ z₁} {k₁ : struct_cospan L x₂ y₂} {k₂ : struct_cospan L y₂ z₂} (s₁ : struct_cospan_sqr L v₁ v₂ h₁ k₁) (s₂ : struct_cospan_sqr L v₂ v₃ h₂ k₂). Definition mor_of_comp_struct_cospan_mor : comp_struct_cospan_Pushout h₁ h₂ --> comp_struct_cospan_Pushout k₁ k₂. Proof. use PushoutArrow. - exact (struct_cospan_sqr_ob_mor _ s₁ · PushoutIn1 _). - exact (struct_cospan_sqr_ob_mor _ s₂ · PushoutIn2 _). - abstract (rewrite !assoc ; rewrite struct_cospan_sqr_mor_right ; rewrite struct_cospan_sqr_mor_left ; rewrite !assoc' ; apply maponpaths ; apply PushoutSqrCommutes). Defined. Proposition comp_struct_cospan_mor_laws : struct_cospan_laws L v₁ v₃ (comp_struct_cospan h₁ h₂) (comp_struct_cospan k₁ k₂) mor_of_comp_struct_cospan_mor. Proof. split ; cbn. - unfold mor_of_comp_struct_cospan_mor. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. rewrite !assoc. apply maponpaths_2. apply struct_cospan_sqr_mor_left. - unfold mor_of_comp_struct_cospan_mor. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. rewrite !assoc. apply maponpaths_2. apply struct_cospan_sqr_mor_right. Qed. Definition comp_struct_cospan_mor : struct_cospan_sqr L v₁ v₃ (comp_struct_cospan h₁ h₂) (comp_struct_cospan k₁ k₂). Proof. use make_struct_cospan_sqr. - exact mor_of_comp_struct_cospan_mor. - exact comp_struct_cospan_mor_laws. Defined. End CompCospanMor. (** 7. The left unitor of structured cospans *) Section CospanLunitor. Context {x y : A} (h : struct_cospan L x y). Definition struct_cospan_lunitor_mor : comp_struct_cospan_Pushout (id_struct_cospan x) h --> ob_of_struct_cospan L h. Proof. use PushoutArrow. - exact (mor_left_of_struct_cospan L h). - exact (identity _). - abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Proposition is_z_iso_struct_cospan_lunitor_mor_eqs : is_inverse_in_precat struct_cospan_lunitor_mor (PushoutIn2 (comp_struct_cospan_Pushout (id_struct_cospan x) h)). Proof. split. - unfold struct_cospan_lunitor_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite <- PushoutSqrCommutes. rewrite id_left, id_right. apply idpath. + rewrite !assoc. rewrite PushoutArrow_PushoutIn2. rewrite id_left, id_right. apply idpath. - unfold struct_cospan_lunitor_mor. rewrite PushoutArrow_PushoutIn2. apply idpath. Qed. Definition is_z_iso_struct_cospan_lunitor_mor : is_z_isomorphism struct_cospan_lunitor_mor. Proof. use make_is_z_isomorphism. - exact (PushoutIn2 _). - exact is_z_iso_struct_cospan_lunitor_mor_eqs. Defined. Proposition struct_cospan_lunitor_laws : struct_cospan_laws L (identity x) (identity y) (comp_struct_cospan (id_struct_cospan x) h) h struct_cospan_lunitor_mor. Proof. split ; cbn ; unfold struct_cospan_lunitor_mor. - rewrite functor_id. rewrite !id_left. rewrite PushoutArrow_PushoutIn1. apply idpath. - rewrite functor_id. rewrite id_left. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. rewrite id_right. apply idpath. Qed. Definition struct_cospan_lunitor : struct_cospan_sqr L (identity _) (identity _) (comp_struct_cospan (id_struct_cospan _) h) h. Proof. use make_struct_cospan_sqr. - exact struct_cospan_lunitor_mor. - exact struct_cospan_lunitor_laws. Defined. End CospanLunitor. (** 8. The right unitor of structured cospans *) Section CospanRunitor. Context {x y : A} (h : struct_cospan L x y). Definition struct_cospan_runitor_mor : comp_struct_cospan_Pushout h (id_struct_cospan y) --> ob_of_struct_cospan L h. Proof. use PushoutArrow. - exact (identity _). - exact (mor_right_of_struct_cospan L h). - abstract (cbn ; rewrite id_left, id_right ; apply idpath). Defined. Proposition is_z_iso_struct_cospan_runitor_mor_eqs : is_inverse_in_precat struct_cospan_runitor_mor (PushoutIn1 (comp_struct_cospan_Pushout h (id_struct_cospan y))). Proof. split. - unfold struct_cospan_runitor_mor. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite !assoc. rewrite PushoutArrow_PushoutIn1. rewrite id_left, id_right. apply idpath. + rewrite !assoc. rewrite PushoutArrow_PushoutIn2. rewrite PushoutSqrCommutes. rewrite id_left, id_right. apply idpath. - unfold struct_cospan_runitor_mor. rewrite PushoutArrow_PushoutIn1. apply idpath. Qed. Definition is_z_iso_struct_cospan_runitor_mor : is_z_isomorphism struct_cospan_runitor_mor. Proof. use make_is_z_isomorphism. - exact (PushoutIn1 _). - exact is_z_iso_struct_cospan_runitor_mor_eqs. Defined. Proposition struct_cospan_runitor_laws : struct_cospan_laws L (identity x) (identity y) (comp_struct_cospan h (id_struct_cospan y)) h struct_cospan_runitor_mor. Proof. split ; cbn ; unfold struct_cospan_runitor_mor. - rewrite functor_id. rewrite id_left. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. rewrite id_right. apply idpath. - rewrite functor_id. rewrite !id_left. rewrite PushoutArrow_PushoutIn2. apply idpath. Qed. Definition struct_cospan_runitor : struct_cospan_sqr L (identity _) (identity _) (comp_struct_cospan h (id_struct_cospan _)) h. Proof. use make_struct_cospan_sqr. - exact struct_cospan_runitor_mor. - exact struct_cospan_runitor_laws. Defined. End CospanRunitor. (** 9. The associator of structured cospans *) Section CospanAssociator. Context {w x y z : A} (h₁ : struct_cospan L w x) (h₂ : struct_cospan L x y) (h₃ : struct_cospan L y z). Definition struct_cospan_associator_mor : comp_struct_cospan_Pushout h₁ (comp_struct_cospan h₂ h₃) --> comp_struct_cospan_Pushout (comp_struct_cospan h₁ h₂) h₃. Proof. use PushoutArrow. - exact (PushoutIn1 _ · PushoutIn1 _). - use PushoutArrow. + exact (PushoutIn2 _ · PushoutIn1 _). + exact (PushoutIn2 _). + abstract (rewrite !assoc ; rewrite PushoutSqrCommutes ; apply idpath). - abstract (cbn ; rewrite !assoc' ; rewrite PushoutArrow_PushoutIn1 ; rewrite !assoc ; rewrite PushoutSqrCommutes ; apply idpath). Defined. Definition struct_cospan_associator_mor_inv : comp_struct_cospan_Pushout (comp_struct_cospan h₁ h₂) h₃ --> comp_struct_cospan_Pushout h₁ (comp_struct_cospan h₂ h₃). Proof. use PushoutArrow. - use PushoutArrow. + exact (PushoutIn1 _). + exact (PushoutIn1 _ · PushoutIn2 _). + abstract (rewrite !assoc ; rewrite PushoutSqrCommutes ; apply idpath). - exact (PushoutIn2 _ · PushoutIn2 _). - abstract (cbn ; rewrite !assoc' ; rewrite PushoutArrow_PushoutIn2 ; rewrite !assoc ; rewrite PushoutSqrCommutes ; apply idpath). Defined. Proposition is_iso_struct_cospan_associator_mor_eq : is_inverse_in_precat struct_cospan_associator_mor struct_cospan_associator_mor_inv. Proof. split. - use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite id_right. unfold struct_cospan_associator_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. unfold struct_cospan_associator_mor_inv. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. apply idpath. + rewrite id_right. unfold struct_cospan_associator_mor. rewrite !assoc. rewrite PushoutArrow_PushoutIn2. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. * rewrite !assoc. rewrite PushoutArrow_PushoutIn1. unfold struct_cospan_associator_mor_inv. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn1. rewrite !PushoutArrow_PushoutIn2. apply idpath. * rewrite !assoc. rewrite PushoutArrow_PushoutIn2. unfold struct_cospan_associator_mor_inv. rewrite !PushoutArrow_PushoutIn2. apply idpath. - use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. + rewrite id_right. unfold struct_cospan_associator_mor_inv. rewrite !assoc. rewrite PushoutArrow_PushoutIn1. use (MorphismsOutofPushoutEqual (isPushout_Pushout (PX _ _ _ _ _))) ; cbn. * rewrite !assoc. rewrite PushoutArrow_PushoutIn1. unfold struct_cospan_associator_mor. rewrite !PushoutArrow_PushoutIn1. apply idpath. * rewrite !assoc. rewrite PushoutArrow_PushoutIn2. unfold struct_cospan_associator_mor. rewrite !assoc'. rewrite PushoutArrow_PushoutIn2. rewrite PushoutArrow_PushoutIn1. apply idpath. + rewrite id_right. unfold struct_cospan_associator_mor_inv. rewrite !assoc. rewrite PushoutArrow_PushoutIn2. unfold struct_cospan_associator_mor. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn2. apply idpath. Qed. Definition is_z_iso_struct_cospan_associator_mor : is_z_isomorphism struct_cospan_associator_mor. Proof. use make_is_z_isomorphism. - exact struct_cospan_associator_mor_inv. - exact is_iso_struct_cospan_associator_mor_eq. Defined. Proposition struct_cospan_associator_laws : struct_cospan_laws L (identity _) (identity _) (comp_struct_cospan h₁ (comp_struct_cospan h₂ h₃)) (comp_struct_cospan (comp_struct_cospan h₁ h₂) h₃) struct_cospan_associator_mor. Proof. split ; cbn. - rewrite functor_id, id_left. unfold struct_cospan_associator_mor. rewrite !assoc'. rewrite PushoutArrow_PushoutIn1. apply idpath. - rewrite functor_id, id_left. unfold struct_cospan_associator_mor. rewrite !assoc'. rewrite !PushoutArrow_PushoutIn2. apply idpath. Qed. Definition struct_cospan_associator : struct_cospan_sqr L (identity _) (identity _) (comp_struct_cospan h₁ (comp_struct_cospan h₂ h₃)) (comp_struct_cospan (comp_struct_cospan h₁ h₂) h₃). Proof. use make_struct_cospan_sqr. - exact struct_cospan_associator_mor. - exact struct_cospan_associator_laws. Defined. End CospanAssociator. End StandardCospans. (** 10. Functors on structured cospans *) Section FunctorOnCospans. Context {A₁ A₂ X₁ X₂ : category} {L₁ : A₁ ⟶ X₁} {L₂ : A₂ ⟶ X₂} {FA : A₁ ⟶ A₂} {FX : X₁ ⟶ X₂} (α : FA ∙ L₂ ⟹ L₁ ∙ FX). Definition functor_on_struct_cospan {x y : A₁} (f : struct_cospan L₁ x y) : struct_cospan L₂ (FA x) (FA y). Proof. use make_struct_cospan. - exact (FX (ob_of_struct_cospan _ f)). - exact (α x · #FX (mor_left_of_struct_cospan _ f)). - exact (α y · #FX (mor_right_of_struct_cospan _ f)). Defined. Definition functor_on_struct_cospan_sqr {x₁ x₂ y₁ y₂ : A₁} {f₁ : struct_cospan L₁ x₁ y₁} {f₂ : struct_cospan L₁ x₂ y₂} {vx : x₁ --> x₂} {vy : y₁ --> y₂} (sq : struct_cospan_sqr L₁ vx vy f₁ f₂) : struct_cospan_sqr L₂ (#FA vx) (#FA vy) (functor_on_struct_cospan f₁) (functor_on_struct_cospan f₂). Proof. use make_struct_cospan_sqr. - exact (#FX (struct_cospan_sqr_ob_mor _ sq)). - abstract (split ; cbn ; [ rewrite !assoc' ; rewrite <- functor_comp ; rewrite struct_cospan_sqr_mor_left ; rewrite functor_comp ; rewrite !assoc ; apply maponpaths_2 ; exact (!(nat_trans_ax α _ _ vx)) | rewrite !assoc' ; rewrite <- functor_comp ; rewrite struct_cospan_sqr_mor_right ; rewrite functor_comp ; rewrite !assoc ; apply maponpaths_2 ; exact (!(nat_trans_ax α _ _ vy)) ]). Defined. Definition twosided_disp_cat_of_struct_cospans_functor_data : twosided_disp_functor_data FA FA (twosided_disp_cat_of_struct_cospans L₁) (twosided_disp_cat_of_struct_cospans L₂). Proof. simple refine (_ ,, _). - exact (λ x y f, functor_on_struct_cospan f). - exact (λ _ _ _ _ _ _ _ _ sq, functor_on_struct_cospan_sqr sq). Defined. Proposition twosided_disp_cat_of_struct_cospans_functor_laws : twosided_disp_functor_laws FA FA (twosided_disp_cat_of_struct_cospans L₁) (twosided_disp_cat_of_struct_cospans L₂) twosided_disp_cat_of_struct_cospans_functor_data. Proof. split. - intros x y f. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. apply functor_id. - intro ; intros. use struct_cospan_sqr_eq. rewrite transportb_disp_mor2_struct_cospan ; cbn. apply functor_comp. Qed. Definition twosided_disp_cat_of_struct_cospans_functor : twosided_disp_functor FA FA (twosided_disp_cat_of_struct_cospans L₁) (twosided_disp_cat_of_struct_cospans L₂). Proof. simple refine (_ ,, _). - exact twosided_disp_cat_of_struct_cospans_functor_data. - exact twosided_disp_cat_of_struct_cospans_functor_laws. Defined. End FunctorOnCospans. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Fiber.v000066400000000000000000000333561451125700300252500ustar00rootroot00000000000000(********************************************************************************** Fibers of two-sided displayed categories and two-sided fibrations In this file, we construct the fiber of two-sided displayed categories. Note that the constructions are similar to those for displayed categories. Again, we look at objects over given objects in the base and the morphisms are displayed morphisms over the identity. The difference is that we have to take the two-sidedness into account. We also show that if we have a discrete two-sided fibration, then every morphism in the base gives rise to a function between the fibers. Using that, we conclude that every discrete two-sided fibration gives rise to a profunctor. Contents 1. Fiber set of a discrete two-sided fibration 2. Fiber category of a two-sided fibration 2.1. Definition of the fiber category 2.2. Isos in the fiber 2.3. Univalence of the fiber 3. Fiber functor in a two-sided fibration **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.Profunctors.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration. Local Open Scope cat. (** 1. Fiber set of a discrete two-sided fibration *) Definition fiber_hset_twosided_disp_cat {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : discrete_twosided_disp_cat D) (x : C₁) (y : C₂) : hSet. Proof. use make_hSet. - exact (D x y). - exact (isaset_discrete_twosided_cat_ob HD x y). Defined. (** 2. Fiber category of a two-sided fibration *) Section FiberCat. Context {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) (x : C₁) (y : C₂). (** 2.1. Definition of the fiber category *) Definition fiber_twosided_disp_precat_ob_mor : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact (D x y). - exact (λ xy₁ xy₂, xy₁ -->[ identity x ][ identity y ] xy₂). Defined. Definition fiber_twosided_disp_precat_data : precategory_data. Proof. use make_precategory_data. - exact fiber_twosided_disp_precat_ob_mor. - exact (λ xy, id_two_disp xy). - exact (λ _ _ _ f g, transportf (λ z, _ -->[ z ][ _ ] _) (id_left _) (transportf (λ z, _ -->[ _ ][ z ] _) (id_left _) (f ;;2 g))). Defined. Definition fiber_twosided_disp_is_precategory : is_precategory fiber_twosided_disp_precat_data. Proof. use is_precategory_one_assoc_to_two. repeat split. - intros xy₁ xy₂ f ; cbn. rewrite id_two_disp_left. unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_prod_transport. rewrite transport_f_f. use (transportf_set (λ z, xy₁ -->[ pr1 z ][ dirprod_pr2 z ] xy₂) (pathsdirprod _ _ @ pathsdirprod _ _)). apply isasetdirprod ; apply homset_property. - intros xy₁ xy₂ f ; cbn. rewrite id_two_disp_right. unfold transportb, transportb_disp_mor2, transportf_disp_mor2. rewrite !twosided_prod_transport. rewrite transport_f_f. use (transportf_set (λ z, xy₁ -->[ pr1 z ][ dirprod_pr2 z ] xy₂) (pathsdirprod _ _ @ pathsdirprod _ _)). apply isasetdirprod ; apply homset_property. - intros xy₁ xy₂ xy₃ xy₄ f g h ; cbn. rewrite two_disp_post_whisker_left. rewrite two_disp_post_whisker_right. rewrite two_disp_pre_whisker_left. rewrite two_disp_pre_whisker_right. rewrite assoc_two_disp. unfold transportb, transportb_disp_mor2, transportf_disp_mor2. rewrite !twosided_prod_transport. rewrite !transport_f_f. apply maponpaths_2. apply isasetdirprod ; apply homset_property. Qed. Definition fiber_twosided_disp_precat : precategory. Proof. use make_precategory. - exact fiber_twosided_disp_precat_data. - exact fiber_twosided_disp_is_precategory. Defined. Definition fiber_twosided_disp_cat : category. Proof. use make_category. - exact fiber_twosided_disp_precat. - intros xy₁ xy₂ ; cbn. apply isaset_disp_mor. Defined. (** 2.2. Isos in the fiber *) Definition make_z_iso_in_fiber {xy₁ xy₂ : fiber_twosided_disp_cat} (f : z_iso xy₁ xy₂) : iso_twosided_disp (idtoiso (idpath x)) (idtoiso (idpath y)) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 f). - exact (inv_from_z_iso f). - abstract (cbn ; pose (p := z_iso_inv_after_z_iso f) ; cbn in p ; rewrite <- p ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_swap_transport ; refine (!_) ; refine (transportbfinv (λ z, _ -->[ z ][ _ ] _) _ _ @ _) ; exact (transportbfinv (λ z, _ -->[ _ ][ z ] _) _ _)). - abstract (cbn ; pose (p := z_iso_after_z_iso_inv f) ; cbn in p ; rewrite <- p ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_swap_transport ; refine (!_) ; refine (transportbfinv (λ z, _ -->[ z ][ _ ] _) _ _ @ _) ; exact (transportbfinv (λ z, _ -->[ _ ][ z ] _) _ _)). Defined. Definition from_z_iso_in_fiber {xy₁ xy₂ : fiber_twosided_disp_cat} (f : iso_twosided_disp (idtoiso (idpath x)) (idtoiso (idpath y)) xy₁ xy₂) : z_iso xy₁ xy₂. Proof. use make_z_iso. - exact (pr1 f). - exact (iso_inv_twosided_disp (pr2 f)). - split. + abstract (cbn ; pose (p := inv_after_iso_twosided_disp (pr2 f)) ; cbn in p ; rewrite p ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_swap_transport ; refine (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _ @ _) ; exact (transportfbinv (λ z, _ -->[ _ ][ z ] _) _ _)). + abstract (cbn ; pose (p := iso_after_inv_twosided_disp (pr2 f)) ; cbn in p ; rewrite p ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_swap_transport ; refine (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _ @ _) ; exact (transportfbinv (λ z, _ -->[ _ ][ z ] _) _ _)). Defined. Definition z_iso_in_fiber (xy₁ xy₂ : fiber_twosided_disp_cat) : iso_twosided_disp (idtoiso (idpath x)) (idtoiso (idpath y)) xy₁ xy₂ ≃ z_iso xy₁ xy₂. Proof. use weq_iso. - exact from_z_iso_in_fiber. - exact make_z_iso_in_fiber. - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. (** 2.3. Univalence of the fiber *) Definition is_univalent_fiber_twosided_disp_cat (HD : is_univalent_twosided_disp_cat D) : is_univalent fiber_twosided_disp_cat. Proof. intros xy₁ xy₂. use weqhomot. - exact (z_iso_in_fiber xy₁ xy₂ ∘ make_weq _ (HD x x y y (idpath _) (idpath _) xy₁ xy₂))%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. End FiberCat. (** 3. Fiber functor in a two-sided fibration *) Section TwoSidedDiscreteFibrationToProfunctor. Context {C₁ C₂ : category} (D : discrete_twosided_fibration C₁ C₂). Let HD : discrete_twosided_disp_cat D := pr12 D. Let HD' : is_discrete_twosided_fibration (pr12 D) := pr22 D. Definition fiber_fun_hset_twosided_disp_cat {x₁ x₂ : C₁} (f : x₁ --> x₂) {y₁ y₂ : C₂} (g : y₂ --> y₁) : fiber_hset_twosided_disp_cat HD x₂ y₂ → fiber_hset_twosided_disp_cat HD x₁ y₁ := λ xy, discrete_twosided_opcleaving_ob _ (pr2 HD') (discrete_twosided_cleaving_ob _ (pr1 HD') xy f) g. Definition discrete_twosided_fibration_to_profunctor_data : functor_data (category_binproduct C₁^op C₂) HSET. Proof. use make_functor_data. - exact (λ xy, fiber_hset_twosided_disp_cat HD (pr1 xy) (pr2 xy)). - exact (λ _ _ fg, fiber_fun_hset_twosided_disp_cat (pr1 fg) (pr2 fg)). Defined. Definition fiber_fun_hset_twosided_disp_cat_id_map {x : C₁} {y : C₂} (xy : fiber_hset_twosided_disp_cat HD x y) : fiber_fun_hset_twosided_disp_cat (identity x) (identity y) xy -->[ identity _ ][ identity _ ] xy. Proof. unfold fiber_fun_hset_twosided_disp_cat. use discrete_twosided_opcleaving_opcartesian. refine (transportb (λ z, _ -->[ z ][ _ ] _) _ (transportb (λ z, _ -->[ _ ][ z ] _) _ (discrete_twosided_cleaving_mor _ (pr1 HD') xy (identity x)))). - exact (id_right _). - exact (id_right _). Defined. Definition fiber_fun_hset_twosided_disp_cat_id {x : C₁} {y : C₂} (xy : fiber_hset_twosided_disp_cat HD x y) : fiber_fun_hset_twosided_disp_cat (identity x) (identity y) xy = xy. Proof. use (mortoid_discrete_twosided_disp HD). exact (fiber_fun_hset_twosided_disp_cat_id_map xy). Qed. Definition fiber_fun_hset_twosided_disp_cat_comp_map {x₁ x₂ x₃ : C₁} (f₁ : x₃ --> x₂) (f₂ : x₂ --> x₁) {y₁ y₂ y₃ : C₂} (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) (xy : fiber_hset_twosided_disp_cat HD x₁ y₁) : fiber_fun_hset_twosided_disp_cat (f₁ · f₂) (g₁ · g₂) xy -->[ identity _ ][ identity _ ] fiber_fun_hset_twosided_disp_cat f₁ g₂ (fiber_fun_hset_twosided_disp_cat f₂ g₁ xy). Proof. unfold fiber_fun_hset_twosided_disp_cat. use discrete_twosided_opcleaving_opcartesian. pose (h₁ := discrete_twosided_opcleaving_mor _ (pr2 HD') (discrete_twosided_cleaving_ob (pr1 D) (pr1 HD') (discrete_twosided_opcleaving_ob (pr1 D) (pr2 HD') (discrete_twosided_cleaving_ob (pr1 D) (pr1 HD') xy f₂) g₁) f₁) g₂). refine (transportb (λ z, _ -->[ _ ][ z ] _) (id_right _) (_ ;;2 h₁)). use discrete_twosided_cleaving_cartesian. pose (h₂ := discrete_twosided_opcleaving_mor _ (pr2 HD') (discrete_twosided_cleaving_ob (pr1 D) (pr1 HD') xy f₂) g₁). refine (transportb (λ z, _ -->[ z ][ _ ] _) (id_left _ @ !(id_right _)) (transportb (λ z, _ -->[ _ ][ z ] _) (id_right _ @ !(id_left _)) (_ ;;2 h₂))). use discrete_twosided_cleaving_cartesian. pose (h₃ := discrete_twosided_cleaving_mor _ (pr1 HD') xy (f₁ · f₂)). exact (transportb (λ z, _ -->[ _ ][ z ] _) (id_right _) h₃). Defined. Definition fiber_fun_hset_twosided_disp_cat_comp {x₁ x₂ x₃ : C₁} (f₁ : x₃ --> x₂) (f₂ : x₂ --> x₁) {y₁ y₂ y₃ : C₂} (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) (xy : fiber_hset_twosided_disp_cat HD x₁ y₁) : fiber_fun_hset_twosided_disp_cat (f₁ · f₂) (g₁ · g₂) xy = fiber_fun_hset_twosided_disp_cat f₁ g₂ (fiber_fun_hset_twosided_disp_cat f₂ g₁ xy). Proof. use (mortoid_discrete_twosided_disp HD). exact (fiber_fun_hset_twosided_disp_cat_comp_map f₁ f₂ g₁ g₂ xy). Qed. Definition discrete_twosided_fibration_to_profunctor_is_functor : is_functor discrete_twosided_fibration_to_profunctor_data. Proof. repeat split. - intros z. use funextsec. exact fiber_fun_hset_twosided_disp_cat_id. - intros z₁ z₂ z₃ f g. use funextsec. exact (fiber_fun_hset_twosided_disp_cat_comp _ _ _ _). Qed. Definition discrete_twosided_fibration_to_profunctor : profunctor C₂ C₁. Proof. use make_functor. - exact discrete_twosided_fibration_to_profunctor_data. - exact discrete_twosided_fibration_to_profunctor_is_functor. Defined. End TwoSidedDiscreteFibrationToProfunctor. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Isos.v000066400000000000000000000277001451125700300251320ustar00rootroot00000000000000(********************************************************************************** Isos in two-sided displayed categories We define isomorphisms in two-sided displayed categories. Contents 1. Isos in two-sided displayed categories 2. Accessors for isos 3. Derived laws 4. Being an iso is a proposition 5. The identity iso 6. Equivalence with isos in the corresponding displayed category **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Local Open Scope cat. (** 1. Isos in two-sided displayed categories *) Definition is_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (Hf : is_z_isomorphism f) (Hg : is_z_isomorphism g) (fg : xy₁ -->[ f ][ g ] xy₂) : UU := let f_z_iso : z_iso x₁ x₂ := f ,, Hf in let g_z_iso : z_iso y₁ y₂ := g ,, Hg in ∑ (gf : xy₂ -->[ inv_from_z_iso f_z_iso ][ inv_from_z_iso g_z_iso ] xy₁), (fg ;;2 gf = transportb_disp_mor2 (z_iso_inv_after_z_iso f_z_iso) (z_iso_inv_after_z_iso g_z_iso) (id_two_disp _)) × (gf ;;2 fg = transportb_disp_mor2 (z_iso_after_z_iso_inv f_z_iso) (z_iso_after_z_iso_inv g_z_iso) (id_two_disp _)). Definition iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} (f : z_iso x₁ x₂) (g : z_iso y₁ y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) : UU := ∑ (fg : xy₁ -->[ f ][ g ] xy₂), is_iso_twosided_disp (pr2 f) (pr2 g) fg. Coercion iso_twosided_disp_to_mor {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} (fg : iso_twosided_disp f g xy₁ xy₂) : xy₁ -->[ f ][ g ] xy₂ := pr1 fg. (** 2. Accessors for isos *) Definition iso_inv_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {Hf : is_z_isomorphism f} {Hg : is_z_isomorphism g} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : is_iso_twosided_disp Hf Hg fg) : xy₂ -->[ inv_from_z_iso (f ,, Hf) ][ inv_from_z_iso (g ,, Hg) ] xy₁ := pr1 Hfg. Definition inv_after_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {Hf : is_z_isomorphism f} {Hg : is_z_isomorphism g} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : is_iso_twosided_disp Hf Hg fg) : fg ;;2 iso_inv_twosided_disp Hfg = transportb_disp_mor2 (z_iso_inv_after_z_iso (f ,, Hf)) (z_iso_inv_after_z_iso (g ,, Hg)) (id_two_disp _) := pr12 Hfg. Definition iso_after_inv_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {Hf : is_z_isomorphism f} {Hg : is_z_isomorphism g} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : is_iso_twosided_disp Hf Hg fg) : iso_inv_twosided_disp Hfg ;;2 fg = transportb_disp_mor2 (z_iso_after_z_iso_inv (f ,, Hf)) (z_iso_after_z_iso_inv (g ,, Hg)) (id_two_disp _) := pr22 Hfg. Definition make_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} (fg : xy₁ -->[ f ][ g ] xy₂) (Hfg : is_iso_twosided_disp (pr2 f) (pr2 g) fg) : iso_twosided_disp f g xy₁ xy₂ := fg ,, Hfg. (** 3. Derived laws *) Definition inv_after_iso_twosided_disp_alt {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {Hf : is_z_isomorphism f} {Hg : is_z_isomorphism g} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : is_iso_twosided_disp Hf Hg fg) : id_two_disp _ = transportf_disp_mor2 (z_iso_inv_after_z_iso (f ,, Hf)) (z_iso_inv_after_z_iso (g ,, Hg)) (fg ;;2 iso_inv_twosided_disp Hfg). Proof. use (@transportf_transpose_right _ (λ z, _ -->[ z ][ _ ] _)). use (@transportf_transpose_right _ (λ z, _ -->[ _ ][ z ] _)). refine (!_). etrans. { apply inv_after_iso_twosided_disp. } refine (!_). apply twosided_swap_transport. Qed. Definition iso_after_inv_twosided_disp_alt {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {Hf : is_z_isomorphism f} {Hg : is_z_isomorphism g} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : is_iso_twosided_disp Hf Hg fg) : id_two_disp _ = transportf_disp_mor2 (z_iso_after_z_iso_inv (f ,, Hf)) (z_iso_after_z_iso_inv (g ,, Hg)) (iso_inv_twosided_disp Hfg ;;2 fg). Proof. use (@transportf_transpose_right _ (λ z, _ -->[ z ][ _ ] _)). use (@transportf_transpose_right _ (λ z, _ -->[ _ ][ z ] _)). refine (!_). etrans. { apply iso_after_inv_twosided_disp. } refine (!_). apply twosided_swap_transport. Qed. (** 4. Being an iso is a proposition *) Definition isaprop_is_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (Hf : is_z_isomorphism f) (Hg : is_z_isomorphism g) (fg : xy₁ -->[ f ][ g ] xy₂) : isaprop (is_iso_twosided_disp Hf Hg fg). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use isapropdirprod ; apply isaset_disp_mor. } etrans. { apply id_two_disp_right_alt. } etrans. { do 2 apply maponpaths. exact (inv_after_iso_twosided_disp_alt φ₂). } rewrite two_disp_post_whisker_f. rewrite transport_f_f_disp_mor2. rewrite assoc_two_disp. etrans. { apply transport_f_f_disp_mor2. } etrans. { apply maponpaths. apply maponpaths_2. apply (iso_after_inv_twosided_disp φ₁). } unfold transportb_disp_mor2. rewrite two_disp_pre_whisker_f. rewrite transport_f_f_disp_mor2. rewrite id_two_disp_left. unfold transportb_disp_mor2. rewrite transport_f_f_disp_mor2. unfold iso_inv_twosided_disp. apply transportf_disp_mor2_idpath. Qed. Proposition isaset_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} (f : z_iso x₁ x₂) (g : z_iso y₁ y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) : isaset (iso_twosided_disp f g xy₁ xy₂). Proof. use isaset_total2. - apply isaset_disp_mor. - intro. apply isasetaprop. apply isaprop_is_iso_twosided_disp. Qed. (** 5. The identity iso *) Definition id_is_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x : C₁} {y : C₂} (xy : D x y) : is_iso_twosided_disp (identity_is_z_iso x) (identity_is_z_iso y) (id_two_disp xy). Proof. simple refine (_ ,, _ ,, _). - apply id_two_disp. - apply id_two_disp_left. - apply id_two_disp_left. Defined. Definition id_iso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x : C₁} {y : C₂} (xy : D x y) : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) xy xy. Proof. use make_iso_twosided_disp. - apply id_two_disp. - exact (id_is_iso_twosided_disp xy). Defined. (** 6. Equivalence with isos in the corresponding displayed category *) Definition iso_twosided_disp_to_z_iso_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x : C₁} {y : C₂} {xx yy : D x y} (ff : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) xx yy) : @z_iso_disp _ (twosided_disp_cat_to_disp_cat _ _ D) (x ,, y) (x ,, y) (identity_z_iso _) xx yy. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 ff). - exact (iso_inv_twosided_disp (pr2 ff)). - abstract (refine (iso_after_inv_twosided_disp (pr2 ff) @ _) ; cbn ; refine (!_) ; apply transportb_dirprodeq). - abstract (refine (inv_after_iso_twosided_disp (pr2 ff) @ _) ; cbn ; refine (!_) ; apply transportb_dirprodeq). Defined. Definition iso_twosided_disp_from_z_iso_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x : C₁} {y : C₂} {xx yy : D x y} (ff : @z_iso_disp _ (twosided_disp_cat_to_disp_cat _ _ D) (x ,, y) (x ,, y) (identity_z_iso _) xx yy) : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) xx yy. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 ff). - exact (inv_mor_disp_from_z_iso ff). - abstract (refine (inv_mor_after_z_iso_disp ff @ _) ; refine (_ @ !twosided_prod_transport _ _ _) ; unfold transportb ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). - abstract (refine (z_iso_disp_after_inv_mor ff @ _) ; refine (_ @ !twosided_prod_transport _ _ _) ; unfold transportb ; apply maponpaths_2 ; apply isasetdirprod ; apply homset_property). Defined. Definition iso_twosided_disp_weq_z_iso_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x : C₁} {y : C₂} (xx yy : D x y) : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) xx yy ≃ @z_iso_disp _ (twosided_disp_cat_to_disp_cat _ _ D) (x ,, y) (x ,, y) (identity_z_iso _) xx yy. Proof. use weq_iso. - exact iso_twosided_disp_to_z_iso_disp. - exact iso_twosided_disp_from_z_iso_disp. - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; apply idpath). - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Total.v000066400000000000000000000741531451125700300253040ustar00rootroot00000000000000(********************************************************************************** Total categories We prove that every two-sided displayed category gives rise to a span of categories. More specifically, every two-sided displayed category `D` over `C₁` and `C₂` gives rise to a total category `∫ D`, a first projection `∫ D ⟶ C₁`, and a second projection `∫ D ⟶ C₂`. In addition, the univalence of `∫ D` follows from the displayed univalence of `D` and the univalence of both `C₁` and `D₂`. Note that we can also construct total displayed categories from a two-sided displayed category. More specifically, if we have a two-sided displayed category `D` over `C₁` and `C₂`, then we get the left total displayed category over `C₂` and the right total displayed category over `C₁`. Univalence of those displayed categories follows from the univalence of `D`. Contents 1. Total category 1.1. Definition 1.2. First and second projection 1.3. Isos in the total category 1.4. Univalence of the total category 2. Left total displayed category 2.1. Definition 2.2. Isomorphisms 2.3. The univalence 3. Right total displayed category 3.1. Definition 3.2. Isomorphisms 3.3. The univalence **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Local Open Scope cat. Definition transportb_total2 {X Y : UU} (Z : X → Y → UU) {x₁ x₂ : X} (p : x₁ = x₂) (yz : ∑ (y : Y), Z x₂ y) : transportb (λ (x : X), ∑ (y : Y), Z x y) p yz = pr1 yz ,, transportb (λ x, Z x (pr1 yz)) p (pr2 yz). Proof. induction p ; cbn. apply idpath. Defined. Section TotalOfTwoSidedDispCat. Context {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂). (** 1. Total category *) (** 1.1. Definition *) Definition total_twosided_disp_precategory_ob_mor : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact (∑ (x : C₁) (y : C₂), D x y). - exact (λ xy₁ xy₂, ∑ (f : pr1 xy₁ --> pr1 xy₂) (g : pr12 xy₁ --> pr12 xy₂), pr22 xy₁ -->[ f ][ g ] pr22 xy₂). Defined. Definition total_twosided_disp_precategory_data : precategory_data. Proof. use make_precategory_data. - exact total_twosided_disp_precategory_ob_mor. - exact (λ xy, identity (pr1 xy) ,, identity (pr12 xy) ,, id_two_disp (pr22 xy)). - exact (λ xy₁ xy₂ xy₃ fg₁ fg₂, pr1 fg₁ · pr1 fg₂ ,, pr12 fg₁ · pr12 fg₂ ,, pr22 fg₁ ;;2 pr22 fg₂). Defined. Definition total_twosided_disp_is_precategory : is_precategory total_twosided_disp_precategory_data. Proof. use make_is_precategory_one_assoc. - intros xy₁ xy₂ fg. use total2_paths_2_b. + apply id_left. + apply id_left. + apply id_two_disp_left. - intros xy₁ xy₂ fg. use total2_paths_2_b. + apply id_right. + apply id_right. + apply id_two_disp_right. - intros xy₁ xy₂ xy₃ xy₄ fg₁ fg₂ fg₃. use total2_paths_2_b. + apply assoc. + apply assoc. + apply assoc_two_disp. Qed. Definition total_twosided_disp_precategory : precategory. Proof. use make_precategory. - exact total_twosided_disp_precategory_data. - exact total_twosided_disp_is_precategory. Defined. Definition has_homsets_total_twosided_disp_category : has_homsets total_twosided_disp_precategory_ob_mor. Proof. intros xy₁ xy₂. apply isaset_total2. - apply homset_property. - intro. apply isaset_total2. + apply homset_property. + intro. apply isaset_disp_mor. Defined. Definition total_twosided_disp_category : category. Proof. use make_category. - exact total_twosided_disp_precategory. - exact has_homsets_total_twosided_disp_category. Defined. Definition from_eq_total {x₁ x₂ : total_twosided_disp_category} {f g : x₁ --> x₂} (p : f = g) : pr22 f = transportb (λ z, _ -->[ z ][ _ ] _) (maponpaths (λ z, pr1 z) p) (transportb (λ z, _ -->[ _ ][ z ] _) (maponpaths (λ z, pr12 z) p) (pr22 g)). Proof. induction p. apply idpath. Qed. (** 1.2. First and second projection *) Definition twosided_disp_category_pr1_data : functor_data total_twosided_disp_category C₁. Proof. use make_functor_data. - exact (λ xy, pr1 xy). - exact (λ xy₁ xy₂ fg, pr1 fg). Defined. Definition twosided_disp_category_pr1_is_functor : is_functor twosided_disp_category_pr1_data. Proof. refine (_ ,, _) ; intro ; intros ; cbn. - apply idpath. - apply idpath. Qed. Definition twosided_disp_category_pr1 : total_twosided_disp_category ⟶ C₁. Proof. use make_functor. - exact twosided_disp_category_pr1_data. - exact twosided_disp_category_pr1_is_functor. Defined. Definition twosided_disp_category_pr2_data : functor_data total_twosided_disp_category C₂. Proof. use make_functor_data. - exact (λ xy, pr12 xy). - exact (λ xy₁ xy₂ fg, pr12 fg). Defined. Definition twosided_disp_category_pr2_is_functor : is_functor twosided_disp_category_pr2_data. Proof. refine (_ ,, _) ; intro ; intros ; cbn. - apply idpath. - apply idpath. Qed. Definition twosided_disp_category_pr2 : total_twosided_disp_category ⟶ C₂. Proof. use make_functor. - exact twosided_disp_category_pr2_data. - exact twosided_disp_category_pr2_is_functor. Defined. (** 1.3. Isos in the total category *) Section IsoTotal. Context {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {Hf : is_z_isomorphism f} {g : y₁ --> y₂} {Hg : is_z_isomorphism g} (fg : xy₁ -->[ f ][ g ] xy₂) (Hfg : is_iso_twosided_disp Hf Hg fg). Let total_fg : total_twosided_disp_category ⟦ (x₁ ,, y₁ ,, xy₁) , (x₂ ,, y₂ ,, xy₂) ⟧ := f ,, g ,, fg. Let f_z_iso : z_iso x₁ x₂ := f ,, Hf. Let g_z_iso : z_iso y₁ y₂ := g ,, Hg. Definition is_z_iso_total_twosided_disp_cat_inv : total_twosided_disp_category ⟦ (x₂ ,, y₂ ,, xy₂) , (x₁ ,, y₁ ,, xy₁) ⟧ := inv_from_z_iso f_z_iso ,, inv_from_z_iso g_z_iso ,, iso_inv_twosided_disp Hfg. Definition is_z_iso_total_twosided_disp_cat_inv_right : total_fg · is_z_iso_total_twosided_disp_cat_inv = identity _. Proof. use total2_paths_2_b ; cbn. - apply (z_iso_inv_after_z_iso f_z_iso). - apply (z_iso_inv_after_z_iso g_z_iso). - apply inv_after_iso_twosided_disp. Qed. Definition is_z_iso_total_twosided_disp_cat_inv_left : is_z_iso_total_twosided_disp_cat_inv · total_fg = identity _. Proof. use total2_paths_2_b ; cbn. - apply (z_iso_after_z_iso_inv f_z_iso). - apply (z_iso_after_z_iso_inv g_z_iso). - apply iso_after_inv_twosided_disp. Qed. Definition is_z_iso_total_twosided_disp_cat : is_z_isomorphism total_fg. Proof. simple refine (is_z_iso_total_twosided_disp_cat_inv ,, _ ,, _). - apply is_z_iso_total_twosided_disp_cat_inv_right. - apply is_z_iso_total_twosided_disp_cat_inv_left. Defined. End IsoTotal. Definition make_z_iso_total_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : z_iso x₁ x₂} {g : z_iso y₁ y₂} (fg : iso_twosided_disp f g xy₁ xy₂) : @z_iso total_twosided_disp_category (x₁ ,, y₁ ,, xy₁) (x₂ ,, y₂ ,, xy₂). Proof. simple refine (_ ,, _). - exact (pr1 f ,, pr1 g ,, pr1 fg). - use is_z_iso_total_twosided_disp_cat. + exact (pr2 f). + exact (pr2 g). + exact (pr2 fg). Defined. Section FromIsoTotal. Context {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} (f : @z_iso total_twosided_disp_category (x₁ ,, y₁ ,, xy₁) (x₂ ,, y₂ ,, xy₂)). Definition from_iso_total_twosided_disp_cat_pr1 : z_iso x₁ x₂. Proof. use make_z_iso. - exact (pr11 f). - exact (pr1 (inv_from_z_iso f)). - split. + exact (maponpaths pr1 (z_iso_inv_after_z_iso f)). + exact (maponpaths pr1 (z_iso_after_z_iso_inv f)). Defined. Definition from_iso_total_twosided_disp_cat_pr12 : z_iso y₁ y₂. Proof. use make_z_iso. - exact (pr121 f). - exact (pr12 (inv_from_z_iso f)). - split. + exact (maponpaths (λ z, pr12 z) (z_iso_inv_after_z_iso f)). + exact (maponpaths (λ z, pr12 z) (z_iso_after_z_iso_inv f)). Defined. Definition from_iso_total_twosided_disp_cat_pr22 : iso_twosided_disp from_iso_total_twosided_disp_cat_pr1 from_iso_total_twosided_disp_cat_pr12 xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr221 f). - exact (pr22 (inv_from_z_iso f)). - exact (from_eq_total (z_iso_inv_after_z_iso f)). - exact (from_eq_total (z_iso_after_z_iso_inv f)). Defined. Definition from_iso_total_twosided_disp_cat : ∑ (f : z_iso x₁ x₂) (g : z_iso y₁ y₂), iso_twosided_disp f g xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _). - exact from_iso_total_twosided_disp_cat_pr1. - exact from_iso_total_twosided_disp_cat_pr12. - exact from_iso_total_twosided_disp_cat_pr22. Defined. End FromIsoTotal. Definition weq_z_iso_total_twosided_disp_cat_help_eq {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {fg₁ fg₂ : ∑ (f : z_iso x₁ x₂) (g : z_iso y₁ y₂), iso_twosided_disp f g xy₁ xy₂} (p : pr11 fg₁ = pr11 fg₂) (q : pr112 fg₁ = pr112 fg₂) (r : pr122 fg₁ = transportb (λ z, _ -->[ z ][ _ ] _) p (transportb (λ z, _ -->[ _ ][ z ] _) q (pr122 fg₂))) : fg₁ = fg₂. Proof. induction fg₁ as [ f₁ fg₁ ]. induction fg₁ as [ g₁ fg₁ ]. induction f₁ as [ f₁ Hf₁ ]. induction g₁ as [ g₁ Hg₁ ]. induction fg₁ as [ fg₁ Hfg₁ ]. induction fg₂ as [ f₂ fg₂ ]. induction fg₂ as [ g₂ fg₂ ]. induction f₂ as [ f₂ Hf₂ ]. induction g₂ as [ g₂ Hg₂ ]. induction fg₂ as [ fg₂ Hfg₂ ]. cbn in *. induction p ; induction q ; cbn in *. induction r. assert (p : Hf₁ = Hf₂) by apply isaprop_is_z_isomorphism. induction p. apply maponpaths. assert (p : Hg₁ = Hg₂) by apply isaprop_is_z_isomorphism. induction p. do 2 apply maponpaths. apply isaprop_is_iso_twosided_disp. Qed. Definition weq_z_iso_total_twosided_disp_cat {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) : (∑ (f : z_iso x₁ x₂) (g : z_iso y₁ y₂), iso_twosided_disp f g xy₁ xy₂) ≃ (@z_iso total_twosided_disp_category (x₁ ,, y₁ ,, xy₁) (x₂ ,, y₂ ,, xy₂)). Proof. use weq_iso. - exact (λ fg, make_z_iso_total_twosided_disp_cat (pr22 fg)). - exact from_iso_total_twosided_disp_cat. - abstract (intros f ; use weq_z_iso_total_twosided_disp_cat_help_eq ; apply idpath). - abstract (intros f ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Defined. (** 1.4. Univalence of the total category *) Definition is_univalent_total_twosided_disp_category (HC₁ : is_univalent C₁) (HC₂ : is_univalent C₂) (HD : is_univalent_twosided_disp_cat D) : is_univalent total_twosided_disp_category. Proof. intros x y. use weqhomot. - refine (weq_z_iso_total_twosided_disp_cat _ _ ∘ weqtotal2 (_ ,, HC₁ _ _) (λ p, weqtotal2 (_ ,, HC₂ _ _) (λ q, (_ ,, HD _ _ _ _ p q _ _)) ∘ _ ∘ total2_paths_equiv _ _ _) ∘ total2_paths_equiv _ _ _)%weq ; cbn. induction x, y. cbn in *. induction p. exact (idweq _). - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ; apply idpath). Qed. (** 2. Left total displayed category *) (** 2.1. Definition *) Definition left_total_of_twosided_disp_cat_ob_mor : disp_cat_ob_mor C₂. Proof. simple refine (_ ,, _). - exact (λ y, ∑ (x : C₁), D x y). - exact (λ y₁ y₂ xy₁ xy₂ g, ∑ (f : pr1 xy₁ --> pr1 xy₂), pr2 xy₁ -->[ f ][ g ] pr2 xy₂). Defined. Definition left_total_of_twosided_disp_cat_id_comp : disp_cat_id_comp C₂ left_total_of_twosided_disp_cat_ob_mor. Proof. split. - exact (λ y xy, identity (pr1 xy) ,, id_two_disp (pr2 xy)). - exact (λ y₁ y₂ y₃ g₁ g₂ xy₁ xy₂ xy₃ fg₁ fg₂, pr1 fg₁ · pr1 fg₂ ,, (pr2 fg₁ ;;2 pr2 fg₂)). Defined. Definition left_total_of_twosided_disp_cat_data : disp_cat_data C₂. Proof. simple refine (_ ,, _). - exact left_total_of_twosided_disp_cat_ob_mor. - exact left_total_of_twosided_disp_cat_id_comp. Defined. Definition left_total_of_twosided_disp_cat_axioms : disp_cat_axioms C₂ left_total_of_twosided_disp_cat_data. Proof. repeat split. - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply id_left. + cbn. rewrite id_two_disp_left. unfold transportb_disp_mor2, transportf_disp_mor2. apply (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _). - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply id_right. + cbn. rewrite id_two_disp_right. apply (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _). - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply assoc. + cbn. rewrite assoc_two_disp. apply (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _). - intros. apply isaset_total2. + apply homset_property. + intro. apply isaset_disp_mor. Qed. Definition left_total_of_twosided_disp_cat : disp_cat C₂. Proof. simple refine (_ ,, _). - exact left_total_of_twosided_disp_cat_data. - exact left_total_of_twosided_disp_cat_axioms. Defined. (** 2.2. Isomorphisms *) Definition make_iso_left_total_of_twosided_disp_cat {y : C₂} {xy₁ xy₂ : left_total_of_twosided_disp_cat y} (f : z_iso (pr1 xy₁) (pr1 xy₂)) (fg : iso_twosided_disp f (identity_z_iso _) (pr2 xy₁) (pr2 xy₂)) : z_iso_disp (identity_z_iso _) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 f ,, pr1 fg). - exact (pr12 f ,, pr12 fg). - abstract (unfold mor_disp ; cbn ; rewrite transportb_total2 ; cbn ; use total2_paths_f ; [ apply z_iso_after_z_iso_inv | ] ; cbn ; etrans ; [ apply maponpaths ; apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ; apply (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _)). - abstract (unfold mor_disp ; cbn ; rewrite transportb_total2 ; cbn ; use total2_paths_f ; [ apply z_iso_inv_after_z_iso | ] ; cbn ; etrans ; [ apply maponpaths ; apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ; apply (transportfbinv (λ z, _ -->[ z ][ _ ] _) _ _)). Defined. Definition from_iso_left_total_of_twosided_disp_cat_pr1 {y : C₂} {xy₁ xy₂ : left_total_of_twosided_disp_cat y} (f : z_iso_disp (identity_z_iso _) xy₁ xy₂) : z_iso (pr1 xy₁) (pr1 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr11 f). - exact (pr112 f). - abstract (refine (maponpaths pr1 (inv_mor_after_z_iso_disp f) @ _) ; unfold mor_disp ; cbn ; rewrite transportb_total2 ; apply idpath). - abstract (refine (maponpaths pr1 (z_iso_disp_after_inv_mor f) @ _) ; unfold mor_disp ; cbn ; rewrite transportb_total2 ; apply idpath). Defined. Definition from_iso_left_total_of_twosided_disp_cat_pr2 {y : C₂} {xy₁ xy₂ : left_total_of_twosided_disp_cat y} (f : z_iso_disp (identity_z_iso _) xy₁ xy₂) : iso_twosided_disp (from_iso_left_total_of_twosided_disp_cat_pr1 f) (identity_z_iso _) (pr2 xy₁) (pr2 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr21 f). - exact (pr212 f). - abstract (pose (p := inv_mor_after_z_iso_disp f) ; unfold mor_disp in p ; cbn in p ; rewrite transportb_total2 in p ; refine (!(fiber_paths (!p)) @ _) ; cbn ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). - abstract (pose (p := z_iso_disp_after_inv_mor f) ; unfold mor_disp in p ; cbn in p ; rewrite transportb_total2 in p ; refine (!(fiber_paths (!p)) @ _) ; cbn ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). Defined. Definition weq_iso_left_total_of_twosided_disp_cat_eq_help {y : C₂} {xy₁ xy₂ : left_total_of_twosided_disp_cat y} {fg₁ fg₂ : ∑ (f : z_iso (pr1 xy₁) (pr1 xy₂)), iso_twosided_disp f (identity_z_iso _) (pr2 xy₁) (pr2 xy₂)} (p : pr11 fg₁ = pr11 fg₂) (q : pr12 fg₁ = transportb (λ z, _ -->[ z ][ _ ] _) p (pr12 fg₂)) : fg₁ = fg₂. Proof. induction fg₁ as [ f₁ fg₁ ]. induction f₁ as [ f₁ Hf₁ ]. induction fg₁ as [ fg₁ Hfg₁ ]. induction fg₂ as [ f₂ fg₂ ]. induction f₂ as [ f₂ Hf₂ ]. induction fg₂ as [ fg₂ Hfg₂ ]. cbn in *. induction p ; cbn in *. induction q. assert (Hf₁ = Hf₂) as p by apply isaprop_is_z_isomorphism. induction p. do 2 apply maponpaths. apply isaprop_is_iso_twosided_disp. Qed. Definition weq_iso_left_total_of_twosided_disp_cat {y : C₂} (xy₁ xy₂ : left_total_of_twosided_disp_cat y) : (∑ (f : z_iso (pr1 xy₁) (pr1 xy₂)), iso_twosided_disp f (identity_z_iso _) (pr2 xy₁) (pr2 xy₂)) ≃ z_iso_disp (identity_z_iso _) xy₁ xy₂. Proof. use weq_iso. - exact (λ f, make_iso_left_total_of_twosided_disp_cat (pr1 f) (pr2 f)). - exact (λ f, from_iso_left_total_of_twosided_disp_cat_pr1 f ,, from_iso_left_total_of_twosided_disp_cat_pr2 f). - abstract (intro f ; cbn ; use weq_iso_left_total_of_twosided_disp_cat_eq_help ; apply idpath). - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. (** 2.3. The univalence *) Definition is_univalent_left_total_of_twosided_disp_cat (HC₁ : is_univalent C₁) (HD : is_univalent_twosided_disp_cat D) : is_univalent_disp left_total_of_twosided_disp_cat. Proof. intros y₁ y₂ p xy₁ xy₂. induction p. use weqhomot. - exact (weq_iso_left_total_of_twosided_disp_cat xy₁ xy₂ ∘ weqtotal2 (_ ,, HC₁ _ _) (λ p, (_ ,, HD _ _ _ _ p (idpath _) (pr2 xy₁) (pr2 xy₂))) ∘ total2_paths_equiv _ _ _)%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; cbn ; apply idpath). Defined. (** 3. Right total displayed category *) (** 3.1. Definition *) Definition right_total_of_twosided_disp_cat_ob_mor : disp_cat_ob_mor C₁. Proof. simple refine (_ ,, _). - exact (λ x, ∑ (y : C₂), D x y). - exact (λ x₁ x₂ xy₁ xy₂ f, ∑ (g : pr1 xy₁ --> pr1 xy₂), pr2 xy₁ -->[ f ][ g ] pr2 xy₂). Defined. Definition right_total_of_twosided_disp_cat_id_comp : disp_cat_id_comp C₁ right_total_of_twosided_disp_cat_ob_mor. Proof. split. - exact (λ x xy, identity (pr1 xy) ,, id_two_disp (pr2 xy)). - exact (λ x₁ x₂ x₃ f₁ f₂ xy₁ xy₂ xy₃ fg₁ fg₂, pr1 fg₁ · pr1 fg₂ ,, (pr2 fg₁ ;;2 pr2 fg₂)). Defined. Definition right_total_of_twosided_disp_cat_data : disp_cat_data C₁. Proof. simple refine (_ ,, _). - exact right_total_of_twosided_disp_cat_ob_mor. - exact right_total_of_twosided_disp_cat_id_comp. Defined. Definition right_total_of_twosided_disp_cat_axioms : disp_cat_axioms C₁ right_total_of_twosided_disp_cat_data. Proof. repeat split. - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply id_left. + cbn. rewrite id_two_disp_left. unfold transportb, transportb_disp_mor2, transportf_disp_mor2. rewrite <- twosided_swap_transport. apply transportfbinv. - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply id_right. + cbn. rewrite id_two_disp_right. unfold transportb, transportb_disp_mor2, transportf_disp_mor2. rewrite <- twosided_swap_transport. apply transportfbinv. - intro ; intros. unfold mor_disp ; cbn. rewrite transportb_total2. use total2_paths_f. + apply assoc. + cbn. rewrite assoc_two_disp. unfold transportb, transportb_disp_mor2, transportf_disp_mor2. rewrite <- twosided_swap_transport. apply transportfbinv. - intros. apply isaset_total2. + apply homset_property. + intro. apply isaset_disp_mor. Qed. Definition right_total_of_twosided_disp_cat : disp_cat C₁. Proof. simple refine (_ ,, _). - exact right_total_of_twosided_disp_cat_data. - exact right_total_of_twosided_disp_cat_axioms. Defined. (** 3.2. Isomorphisms *) Definition make_iso_right_total_of_twosided_disp_cat {x : C₁} {xy₁ xy₂ : right_total_of_twosided_disp_cat x} (g : z_iso (pr1 xy₁) (pr1 xy₂)) (fg : iso_twosided_disp (identity_z_iso _) g (pr2 xy₁) (pr2 xy₂)) : z_iso_disp (identity_z_iso _) xy₁ xy₂. Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr1 g ,, pr1 fg). - exact (pr12 g ,, pr12 fg). - abstract (unfold mor_disp ; cbn ; rewrite transportb_total2 ; cbn ; use total2_paths_f ; [ apply z_iso_after_z_iso_inv | ] ; cbn ; etrans ; [ apply maponpaths ; apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite <- twosided_swap_transport ; apply transportfbinv). - abstract (unfold mor_disp ; cbn ; rewrite transportb_total2 ; cbn ; use total2_paths_f ; [ apply z_iso_inv_after_z_iso | ] ; cbn ; etrans ; [ apply maponpaths ; apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite <- twosided_swap_transport ; apply transportfbinv). Defined. Definition from_iso_right_total_of_twosided_disp_cat_pr1 {x : C₁} {xy₁ xy₂ : right_total_of_twosided_disp_cat x} (g : z_iso_disp (identity_z_iso _) xy₁ xy₂) : z_iso (pr1 xy₁) (pr1 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr11 g). - exact (pr112 g). - abstract (refine (maponpaths pr1 (inv_mor_after_z_iso_disp g) @ _) ; unfold mor_disp ; cbn ; rewrite transportb_total2 ; apply idpath). - abstract (refine (maponpaths pr1 (z_iso_disp_after_inv_mor g) @ _) ; unfold mor_disp ; cbn ; rewrite transportb_total2 ; apply idpath). Defined. Definition from_iso_right_total_of_twosided_disp_cat_pr2 {x : C₁} {xy₁ xy₂ : right_total_of_twosided_disp_cat x} (g : z_iso_disp (identity_z_iso _) xy₁ xy₂) : iso_twosided_disp (identity_z_iso _) (from_iso_right_total_of_twosided_disp_cat_pr1 g) (pr2 xy₁) (pr2 xy₂). Proof. simple refine (_ ,, _ ,, _ ,, _). - exact (pr21 g). - exact (pr212 g). - abstract (pose (p := inv_mor_after_z_iso_disp g) ; unfold mor_disp in p ; cbn in p ; rewrite transportb_total2 in p ; refine (!(fiber_paths (!p)) @ _) ; cbn ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite twosided_swap_transport ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). - abstract (pose (p := z_iso_disp_after_inv_mor g) ; unfold mor_disp in p ; cbn in p ; rewrite transportb_total2 in p ; refine (!(fiber_paths (!p)) @ _) ; cbn ; unfold transportb, transportb_disp_mor2, transportf_disp_mor2 ; rewrite twosided_swap_transport ; rewrite !twosided_prod_transport ; apply maponpaths_2 ; apply isaset_dirprod ; apply homset_property). Defined. Definition weq_iso_right_total_of_twosided_disp_cat_eq_help {x : C₁} {xy₁ xy₂ : right_total_of_twosided_disp_cat x} {fg₁ fg₂ : ∑ (g : z_iso (pr1 xy₁) (pr1 xy₂)), iso_twosided_disp (identity_z_iso _) g (pr2 xy₁) (pr2 xy₂)} (p : pr11 fg₁ = pr11 fg₂) (q : pr12 fg₁ = transportb (λ z, _ -->[ _ ][ z ] _) p (pr12 fg₂)) : fg₁ = fg₂. Proof. induction fg₁ as [ f₁ fg₁ ]. induction f₁ as [ f₁ Hf₁ ]. induction fg₁ as [ fg₁ Hfg₁ ]. induction fg₂ as [ f₂ fg₂ ]. induction f₂ as [ f₂ Hf₂ ]. induction fg₂ as [ fg₂ Hfg₂ ]. cbn in *. induction p ; cbn in *. induction q. assert (Hf₁ = Hf₂) as p by apply isaprop_is_z_isomorphism. induction p. do 2 apply maponpaths. apply isaprop_is_iso_twosided_disp. Qed. Definition weq_iso_right_total_of_twosided_disp_cat {x : C₁} (xy₁ xy₂ : right_total_of_twosided_disp_cat x) : (∑ (g : z_iso (pr1 xy₁) (pr1 xy₂)), iso_twosided_disp (identity_z_iso _) g (pr2 xy₁) (pr2 xy₂)) ≃ z_iso_disp (identity_z_iso _) xy₁ xy₂. Proof. use weq_iso. - exact (λ f, make_iso_right_total_of_twosided_disp_cat (pr1 f) (pr2 f)). - exact (λ f, from_iso_right_total_of_twosided_disp_cat_pr1 f ,, from_iso_right_total_of_twosided_disp_cat_pr2 f). - abstract (intro f ; cbn ; use weq_iso_right_total_of_twosided_disp_cat_eq_help ; apply idpath). - abstract (intro f ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; apply idpath). Defined. (** 3.3. The univalence *) Definition is_univalent_right_total_of_twosided_disp_cat (HC₂ : is_univalent C₂) (HD : is_univalent_twosided_disp_cat D) : is_univalent_disp right_total_of_twosided_disp_cat. Proof. intros y₁ y₂ p xy₁ xy₂. induction p. use weqhomot. - exact (weq_iso_right_total_of_twosided_disp_cat xy₁ xy₂ ∘ weqtotal2 (_ ,, HC₂ _ _) (λ q, (_ ,, HD _ _ _ _ (idpath _) q (pr2 xy₁) (pr2 xy₂))) ∘ total2_paths_equiv _ _ _)%weq. - abstract (intro p ; induction p ; use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ; cbn ; apply idpath). Defined. End TotalOfTwoSidedDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/TwoSidedDispCat.v000066400000000000000000001057241451125700300272120ustar00rootroot00000000000000(********************************************************************************** Two-sided displayed categories In this file, we define two-sided displayed categories. These are rather similar to displayed categories, but they are displayed over 2 categories instead of just one. More specifically, given two categories `C₁` and `C₂` a two-sided displayed category `D` over `C₁` and `C₂` has displayed objects `xy` over every `x : C₁` and `y : C₂`. For morphisms `f : C₁ ⟦ x₁ , x₂ ⟧`, `g : C₂ ⟦ y₁ , y₂ ⟧` and displayed objects `xy₁ : D x₁ y₁` and `xy₂ : D x₂ y₂`, we have a set of displayed morhisms. Contents 1.1. Definition of two-sided displayed categories 1.2. Derived laws 2. Two-sided displayed categories are displayed categories over the product **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Definition total2_paths_2_b {X Y : UU} (Z : X → Y → UU) {x₁ x₂ : X} (p : x₁ = x₂) {y₁ y₂ : Y} (q : y₁ = y₂) {z₁ : Z x₁ y₁} {z₂ : Z x₂ y₂} (r : z₁ = transportb (λ w, Z w _) p (transportb (λ w, Z _ w) q z₂)) : (x₁ ,, y₁ ,, z₁ : ∑ (x : X) (y : Y), Z x y) = (x₂ ,, y₂ ,, z₂ : ∑ (x : X) (y : Y), Z x y). Proof. induction p, q ; cbn in *. induction r. apply idpath. Defined. Definition transportb_dirprodeq {X Y : UU} (Z : X → Y → UU) {x₁ x₂ : X} (p : x₁ = x₂) {y₁ y₂ : Y} (q : y₁ = y₂) (z : Z x₂ y₂) : transportb (λ (w : X × Y), Z (pr1 w) (pr2 w)) (dirprodeq _ _ (x₁ ,, y₁) (x₂ ,, y₂) p q) z = transportb (λ w, Z w _) p (transportb (λ w, Z _ w) q z). Proof. induction p, q. apply idpath. Defined. Definition transportb_dirprodeq' {X Y : UU} (Z : X × Y → UU) {x₁ x₂ : X} (p : x₁ = x₂) {y₁ y₂ : Y} (q : y₁ = y₂) (z : Z (x₂ ,, y₂)) : transportb (λ (w : X × Y), Z w) (dirprodeq _ _ (x₁ ,, y₁) (x₂ ,, y₂) p q) z = transportb (λ w, Z (w ,, _)) p (transportb (λ w, Z (_ ,, w)) q z). Proof. induction p, q. apply idpath. Defined. Section TwoSidedDispCat. Context {C₁ C₂ : category}. (** 1.1. Definition of two-sided displayed categories *) Definition twosided_disp_cat_ob_mor : UU := ∑ (D : C₁ → C₂ → UU), ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂), D x₁ y₁ → D x₂ y₂ → x₁ --> x₂ → y₁ --> y₂ → UU. Definition twosided_disp_cat_ob_mor_to_ob {D : twosided_disp_cat_ob_mor} (x : C₁) (y : C₂) : UU := pr1 D x y. Coercion twosided_disp_cat_ob_mor_to_ob : twosided_disp_cat_ob_mor >-> Funclass. Definition twosided_disp_cat_ob_mor_to_mor {D : twosided_disp_cat_ob_mor} {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) : UU := pr2 D x₁ x₂ y₁ y₂ xy₁ xy₂ f g. Local Notation "xy₁ -->[ f ][ g ] xy₂" := (twosided_disp_cat_ob_mor_to_mor xy₁ xy₂ f g) (at level 50, left associativity, xy₂ at next level). Definition twosided_disp_cat_id (D : twosided_disp_cat_ob_mor) : UU := ∏ (x : C₁) (y : C₂) (xy : D x y), xy -->[ identity x ][ identity y ] xy. Definition twosided_disp_cat_comp (D : twosided_disp_cat_ob_mor) : UU := ∏ (x₁ x₂ x₃ : C₁) (y₁ y₂ y₃ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (xy₃ : D x₃ y₃) (f₁ : x₁ --> x₂) (f₂ : x₂ --> x₃) (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃), xy₁ -->[ f₁ ][ g₁ ] xy₂ → xy₂ -->[ f₂ ][ g₂ ] xy₃ → xy₁ -->[ f₁ · f₂ ][ g₁ · g₂ ] xy₃. Definition twosided_disp_cat_id_comp (D : twosided_disp_cat_ob_mor) : UU := twosided_disp_cat_id D × twosided_disp_cat_comp D. Definition twosided_disp_cat_data : UU := ∑ (D : twosided_disp_cat_ob_mor), twosided_disp_cat_id_comp D. Coercion twosided_disp_cat_data_to_twosided_disp_cat_ob_mor (D : twosided_disp_cat_data) : twosided_disp_cat_ob_mor := pr1 D. Definition id_two_disp {D : twosided_disp_cat_data} {x : C₁} {y : C₂} (xy : D x y) : xy -->[ identity x ][ identity y ] xy := pr12 D x y xy. Definition comp_two_disp {D : twosided_disp_cat_data} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ : x₂ --> x₃} {g₁ : y₁ --> y₂} {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : xy₁ -->[ f₁ · f₂ ][ g₁ · g₂ ] xy₃ := pr22 D _ _ _ _ _ _ _ _ _ _ _ _ _ fg₁ fg₂. Local Notation "fg₁ ;;2 fg₂" := (comp_two_disp fg₁ fg₂) (at level 50, left associativity, format "fg₁ ;;2 fg₂"). Definition transportf_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) {g₁ g₂ : y₁ --> y₂} (q : g₁ = g₂) (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) : xy₁ -->[ f₂ ][ g₂ ] xy₂ := transportf (λ z, _ -->[ z ][ _ ] _) p (transportf (λ z, _ -->[ _ ][ z ] _) q fg). Definition transportb_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) {g₁ g₂ : y₁ --> y₂} (q : g₁ = g₂) (fg : xy₁ -->[ f₂ ][ g₂ ] xy₂) : xy₁ -->[ f₁ ][ g₁ ] xy₂ := transportf_disp_mor2 (!p) (!q) fg. Proposition transport_f_f_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ f₃ : x₁ --> x₂} (p₁ : f₁ = f₂) (p₂ : f₂ = f₃) {g₁ g₂ g₃ : y₁ --> y₂} (q₁ : g₁ = g₂) (q₂ : g₂ = g₃) (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) : transportf_disp_mor2 p₂ q₂ (transportf_disp_mor2 p₁ q₁ fg) = transportf_disp_mor2 (p₁ @ p₂) (q₁ @ q₂) fg. Proof. induction p₁, p₂, q₁, q₂ ; cbn. apply idpath. Qed. Proposition transportfb_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) {g₁ g₂ : y₁ --> y₂} (q : g₁ = g₂) (fg : xy₁ -->[ f₂ ][ g₂ ] xy₂) : transportf_disp_mor2 p q (transportb_disp_mor2 p q fg) = fg. Proof. induction p, q ; cbn. apply idpath. Qed. Proposition transport_b_b_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ f₃ : x₁ --> x₂} (p₁ : f₂ = f₁) (p₂ : f₃ = f₂) {g₁ g₂ g₃ : y₁ --> y₂} (q₁ : g₂ = g₁) (q₂ : g₃ = g₂) (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) : transportb_disp_mor2 p₂ q₂ (transportb_disp_mor2 p₁ q₁ fg) = transportb_disp_mor2 (p₂ @ p₁) (q₂ @ q₁) fg. Proof. induction p₁, p₂, q₁, q₂ ; cbn. apply idpath. Qed. Proposition transportbf_disp_mor2 {D : twosided_disp_cat_data} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} (p : f₁ = f₂) {g₁ g₂ : y₁ --> y₂} (q : g₁ = g₂) (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) : transportb_disp_mor2 p q (transportf_disp_mor2 p q fg) = fg. Proof. induction p, q ; cbn. apply idpath. Qed. Definition id_two_disp_left_law (D : twosided_disp_cat_data) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (fg : xy₁ -->[ f ][ g ] xy₂), id_two_disp xy₁ ;;2 fg = transportb_disp_mor2 (id_left _) (id_left _) fg. Definition id_two_disp_right_law (D : twosided_disp_cat_data) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) (fg : xy₁ -->[ f ][ g ] xy₂), fg ;;2 id_two_disp xy₂ = transportb_disp_mor2 (id_right _) (id_right _) fg. Definition assoc_two_disp_law (D : twosided_disp_cat_data) : UU := ∏ (x₁ x₂ x₃ x₄ : C₁) (y₁ y₂ y₃ y₄ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (xy₃ : D x₃ y₃) (xy₄ : D x₄ y₄) (f₁ : x₁ --> x₂) (f₂ : x₂ --> x₃) (f₃ : x₃ --> x₄) (g₁ : y₁ --> y₂) (g₂ : y₂ --> y₃) (g₃ : y₃ --> y₄) (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) (fg₃ : xy₃ -->[ f₃ ][ g₃ ] xy₄), (fg₁ ;;2 (fg₂ ;;2 fg₃)) = transportb_disp_mor2 (assoc _ _ _) (assoc _ _ _) ((fg₁ ;;2 fg₂) ;;2 fg₃). Definition isaset_disp_mor_law (D : twosided_disp_cat_data) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂), isaset (xy₁ -->[ f ][ g ] xy₂). Definition twosided_disp_cat_axioms (D : twosided_disp_cat_data) : UU := id_two_disp_left_law D × id_two_disp_right_law D × assoc_two_disp_law D × isaset_disp_mor_law D. Definition isaprop_twosided_disp_cat_axioms (D : twosided_disp_cat_data) : isaprop (twosided_disp_cat_axioms D). Proof. use invproofirrelevance. intros φ₁ φ₂. repeat (use pathsdirprod). - do 9 (use funextsec ; intro). apply (pr222 φ₂). - do 9 (use funextsec ; intro). apply (pr222 φ₂). - do 21 (use funextsec ; intro). apply (pr222 φ₂). - do 8 (use funextsec ; intro). apply isapropisaset. Qed. Definition twosided_disp_cat : UU := ∑ (D : twosided_disp_cat_data), twosided_disp_cat_axioms D. Coercion twosided_disp_cat_to_twosided_disp_cat_data (D : twosided_disp_cat) : twosided_disp_cat_data := pr1 D. Definition id_two_disp_left {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : id_two_disp xy₁ ;;2 fg = transportb_disp_mor2 (id_left _) (id_left _) fg. Proof. exact (pr12 D _ _ _ _ _ _ _ _ fg). Defined. Definition id_two_disp_right {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : fg ;;2 id_two_disp xy₂ = transportb_disp_mor2 (id_right _) (id_right _) fg. Proof. exact (pr122 D _ _ _ _ _ _ _ _ fg). Defined. Definition assoc_two_disp {D : twosided_disp_cat} {x₁ x₂ x₃ x₄ : C₁} {y₁ y₂ y₃ y₄ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {xy₄ : D x₄ y₄} {f₁ : x₁ --> x₂} {f₂ : x₂ --> x₃} {f₃ : x₃ --> x₄} {g₁ : y₁ --> y₂} {g₂ : y₂ --> y₃} {g₃ : y₃ --> y₄} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) (fg₃ : xy₃ -->[ f₃ ][ g₃ ] xy₄) : (fg₁ ;;2 (fg₂ ;;2 fg₃)) = transportb_disp_mor2 (assoc _ _ _) (assoc _ _ _) ((fg₁ ;;2 fg₂) ;;2 fg₃). Proof. exact (pr1 (pr222 D) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ fg₁ fg₂ fg₃). Defined. Definition isaset_disp_mor {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (f : x₁ --> x₂) (g : y₁ --> y₂) : isaset (xy₁ -->[ f ][ g ] xy₂). Proof. exact (pr2 (pr222 D) _ _ _ _ xy₁ xy₂ f g). Defined. (** 1.2. Derived laws *) Definition twosided_swap_transport {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) (p : f₁ = f₂) (q : g₁ = g₂) : transportf (λ z, _ -->[ _ ][ z ] _) q (transportf (λ z, _ -->[ z ][ _ ] _) p fg) = transportf (λ z, _ -->[ z ][ _ ] _) p (transportf (λ z, _ -->[ _ ][ z ] _) q fg). Proof. induction p, q. apply idpath. Qed. Definition twosided_prod_transport {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) (p : f₁ = f₂) (q : g₁ = g₂) : transportf (λ z, _ -->[ z ][ _ ] _) p (transportf (λ z, _ -->[ _ ][ z ] _) q fg) = transportf (λ z, _ -->[ pr1 z ][ pr2 z ] _) (pathsdirprod p q) fg. Proof. induction p ; induction q. apply idpath. Qed. Definition twosided_prod_transport_alt {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) (p : f₁ = f₂) (q : g₁ = g₂) : transportf (λ z, _ -->[ _ ][ z ] _) q (transportf (λ z, _ -->[ z ][ _ ] _) p fg) = transportf (λ z, _ -->[ pr1 z ][ pr2 z ] _) (pathsdirprod p q) fg. Proof. induction p ; induction q. apply idpath. Qed. Definition twosided_prod_transportb {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) (p : f₂ = f₁) (q : g₂ = g₁) : transportb (λ z, _ -->[ z ][ _ ] _) p (transportb (λ z, _ -->[ _ ][ z ] _) q fg) = transportb (λ z, _ -->[ pr1 z ][ pr2 z ] _) (pathsdirprod p q) fg. Proof. induction p ; induction q. apply idpath. Qed. Definition twosided_prod_transportb_alt {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f₁ f₂ : x₁ --> x₂} {g₁ g₂ : y₁ --> y₂} (fg : xy₁ -->[ f₁ ][ g₁ ] xy₂) (p : f₂ = f₁) (q : g₂ = g₁) : transportb (λ z, _ -->[ _ ][ z ] _) q (transportb (λ z, _ -->[ z ][ _ ] _) p fg) = transportb (λ z, _ -->[ pr1 z ][ pr2 z ] _) (pathsdirprod p q) fg. Proof. induction p ; induction q. apply idpath. Qed. Definition id_two_disp_left_alt {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : fg = transportf_disp_mor2 (id_left _) (id_left _) (id_two_disp xy₁ ;;2 fg). Proof. rewrite id_two_disp_left. rewrite transportfb_disp_mor2. apply idpath. Qed. Definition id_two_disp_right_alt {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : fg = transportf_disp_mor2 (id_right _) (id_right _) (fg ;;2 id_two_disp xy₂). Proof. rewrite id_two_disp_right. rewrite transportfb_disp_mor2. apply idpath. Qed. Definition assoc_two_disp_alt {D : twosided_disp_cat} {x₁ x₂ x₃ x₄ : C₁} {y₁ y₂ y₃ y₄ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {xy₄ : D x₄ y₄} {f₁ : x₁ --> x₂} {f₂ : x₂ --> x₃} {f₃ : x₃ --> x₄} {g₁ : y₁ --> y₂} {g₂ : y₂ --> y₃} {g₃ : y₃ --> y₄} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) (fg₃ : xy₃ -->[ f₃ ][ g₃ ] xy₄) : ((fg₁ ;;2 fg₂) ;;2 fg₃) = transportf_disp_mor2 (assoc _ _ _) (assoc _ _ _) (fg₁ ;;2 (fg₂ ;;2 fg₃)). Proof. rewrite assoc_two_disp. rewrite transportfb_disp_mor2. apply idpath. Qed. Definition two_disp_post_whisker_left {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ f₂' : x₂ --> x₃} (p : f₂' = f₂) {g₁ : y₁ --> y₂} {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂' ][ g₂ ] xy₃) : fg₁ ;;2 transportf (λ z, _ -->[ z ][ _ ] _) p fg₂ = transportf (λ z, _ -->[ z ][ _ ] _) (maponpaths (λ z, _ · z) p) (fg₁ ;;2 fg₂). Proof. induction p ; cbn. apply idpath. Qed. Definition two_disp_post_whisker_right {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ : x₂ --> x₃} {g₁ : y₁ --> y₂} {g₂ g₂' : y₂ --> y₃} (p : g₂' = g₂) (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂' ] xy₃) : fg₁ ;;2 transportf (λ z, _ -->[ _ ][ z ] _) p fg₂ = transportf (λ z, _ -->[ _ ][ z ] _) (maponpaths (λ z, _ · z) p) (fg₁ ;;2 fg₂). Proof. induction p ; cbn. apply idpath. Qed. Definition two_disp_post_whisker_f {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ f₂' : x₂ --> x₃} (p : f₂' = f₂) {g₁ : y₁ --> y₂} {g₂ g₂' : y₂ --> y₃} (q : g₂' = g₂) (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂' ][ g₂' ] xy₃) : fg₁ ;;2 transportf_disp_mor2 p q fg₂ = transportf_disp_mor2 (maponpaths (λ z, _ · z) p) (maponpaths (λ z, _ · z) q) (fg₁ ;;2 fg₂). Proof. induction p, q ; cbn. apply idpath. Qed. Definition two_disp_post_whisker_b {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ f₂' : x₂ --> x₃} (p : f₂ = f₂') {g₁ : y₁ --> y₂} {g₂ g₂' : y₂ --> y₃} (q : g₂ = g₂') (fg₁ : xy₁ -->[ f₁ ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂' ][ g₂' ] xy₃) : fg₁ ;;2 transportb_disp_mor2 p q fg₂ = transportb_disp_mor2 (maponpaths (λ z, _ · z) p) (maponpaths (λ z, _ · z) q) (fg₁ ;;2 fg₂). Proof. induction p, q ; cbn. apply idpath. Qed. Definition two_disp_pre_whisker_left {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ f₁' : x₁ --> x₂} (p : f₁' = f₁) {f₂ : x₂ --> x₃} {g₁ : y₁ --> y₂} {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁' ][ g₁ ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : transportf (λ z, _ -->[ z ][ _ ] _) p fg₁ ;;2 fg₂ = transportf (λ z, _ -->[ z ][ _ ] _) (maponpaths (λ z, z · _) p) (fg₁ ;;2 fg₂). Proof. induction p ; cbn. apply idpath. Qed. Definition two_disp_pre_whisker_right {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ : x₁ --> x₂} {f₂ : x₂ --> x₃} {g₁ g₁' : y₁ --> y₂} (p : g₁' = g₁) {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁ ][ g₁' ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : transportf (λ z, _ -->[ _ ][ z ] _) p fg₁ ;;2 fg₂ = transportf (λ z, _ -->[ _ ][ z ] _) (maponpaths (λ z, z · _) p) (fg₁ ;;2 fg₂). Proof. induction p ; cbn. apply idpath. Qed. Definition two_disp_pre_whisker_f {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ f₁' : x₁ --> x₂} (p : f₁' = f₁) {f₂ : x₂ --> x₃} {g₁ g₁' : y₁ --> y₂} (q : g₁' = g₁) {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁' ][ g₁' ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : transportf_disp_mor2 p q fg₁ ;;2 fg₂ = transportf_disp_mor2 (maponpaths (λ z, z · _) p) (maponpaths (λ z, z · _) q) (fg₁ ;;2 fg₂). Proof. induction p, q ; cbn. apply idpath. Qed. Definition two_disp_pre_whisker_b {D : twosided_disp_cat} {x₁ x₂ x₃ : C₁} {y₁ y₂ y₃ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {xy₃ : D x₃ y₃} {f₁ f₁' : x₁ --> x₂} (p : f₁ = f₁') {f₂ : x₂ --> x₃} {g₁ g₁' : y₁ --> y₂} (q : g₁ = g₁') {g₂ : y₂ --> y₃} (fg₁ : xy₁ -->[ f₁' ][ g₁' ] xy₂) (fg₂ : xy₂ -->[ f₂ ][ g₂ ] xy₃) : transportb_disp_mor2 p q fg₁ ;;2 fg₂ = transportb_disp_mor2 (maponpaths (λ z, z · _) p) (maponpaths (λ z, z · _) q) (fg₁ ;;2 fg₂). Proof. induction p, q ; cbn. apply idpath. Qed. Proposition transportf_disp_mor2_idpath {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} (p : f = f) {g : y₁ --> y₂} (q : g = g) (fg : xy₁ -->[ f ][ g ] xy₂) : transportf_disp_mor2 p q fg = fg. Proof. assert (p = idpath _) as h₁. { apply homset_property. } assert (q = idpath _) as h₂. { apply homset_property. } rewrite h₁, h₂ ; cbn. apply idpath. Qed. Proposition transportb_disp_mor2_idpath {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} (p : f = f) {g : y₁ --> y₂} (q : g = g) (fg : xy₁ -->[ f ][ g ] xy₂) : transportb_disp_mor2 p q fg = fg. Proof. apply transportf_disp_mor2_idpath. Qed. Proposition transportf_disp_mor2_eq {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f f' : x₁ --> x₂} {p p' : f = f'} {g g' : y₁ --> y₂} {q q' : g = g'} {fg fg' : xy₁ -->[ f ][ g ] xy₂} (s : fg = fg') : transportf_disp_mor2 p q fg = transportf_disp_mor2 p' q' fg'. Proof. assert (p = p') as h₁. { apply homset_property. } assert (q = q') as h₂. { apply homset_property. } rewrite h₁, h₂, s. apply idpath. Qed. Proposition transportb_disp_mor2_eq {D : twosided_disp_cat} {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f f' : x₁ --> x₂} {p p' : f' = f} {g g' : y₁ --> y₂} {q q' : g' = g} {fg fg' : xy₁ -->[ f ][ g ] xy₂} (s : fg = fg') : transportb_disp_mor2 p q fg = transportb_disp_mor2 p' q' fg'. Proof. assert (p = p') as h₁. { apply homset_property. } assert (q = q') as h₂. { apply homset_property. } rewrite h₁, h₂, s. apply idpath. Qed. End TwoSidedDispCat. Arguments twosided_disp_cat_ob_mor _ _ : clear implicits. Arguments twosided_disp_cat_data _ _ : clear implicits. Arguments twosided_disp_cat _ _ : clear implicits. Notation "xy₁ -->[ f ][ g ] xy₂" := (twosided_disp_cat_ob_mor_to_mor xy₁ xy₂ f g) (at level 50, left associativity, xy₂ at next level) : cat. Notation "fg₁ ;;2 fg₂" := (comp_two_disp fg₁ fg₂) (at level 50, left associativity, format "fg₁ ;;2 fg₂") : cat. Notation "'trf₂' fg" := (transportf_disp_mor2 _ _ fg) (at level 50, only printing). Notation "'trb₂' fg" := (transportb_disp_mor2 _ _ fg) (at level 50, only printing). (** 2. Two-sided displayed categories are displayed categories over the product *) Section TwoSidedDispCatVersusDispCat. Context (C₁ C₂ : category). Definition twosided_disp_cat_to_disp_cat_ob_mor (D : twosided_disp_cat C₁ C₂) : disp_cat_ob_mor (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact (λ xy, D (pr1 xy) (pr2 xy)). - exact (λ xy₁ xy₂ z₁ z₂ fg, z₁ -->[ pr1 fg ][ pr2 fg ] z₂). Defined. Definition twosided_disp_cat_to_disp_cat_id_comp (D : twosided_disp_cat C₁ C₂) : disp_cat_id_comp (category_binproduct C₁ C₂) (twosided_disp_cat_to_disp_cat_ob_mor D). Proof. simple refine (_ ,, _). - exact (λ xy z, id_two_disp z). - exact (λ xy₁ xy₂ xy₃ fg₁ fg₂ z₁ z₂ z₃ h₁ h₂, h₁ ;;2 h₂). Defined. Definition twosided_disp_cat_to_disp_cat_data (D : twosided_disp_cat C₁ C₂) : disp_cat_data (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact (twosided_disp_cat_to_disp_cat_ob_mor D). - exact (twosided_disp_cat_to_disp_cat_id_comp D). Defined. Definition twosided_disp_cat_to_disp_cat_axioms (D : twosided_disp_cat C₁ C₂) : disp_cat_axioms (category_binproduct C₁ C₂) (twosided_disp_cat_to_disp_cat_data D). Proof. repeat split. - intros x y f g xx yy ; cbn in *. refine (id_two_disp_left _ @ _). refine (!_). apply transportb_dirprodeq. - intros x y f g xx yy ; cbn in *. refine (id_two_disp_right _ @ _). refine (!_). apply transportb_dirprodeq. - intros w x y z f g h ww xx yy zz ff gg hh ; cbn in *. refine (assoc_two_disp _ _ _ @ _). refine (!_). apply transportb_dirprodeq. - intros x y f xx yy ; cbn in *. apply isaset_disp_mor. Qed. Definition twosided_disp_cat_to_disp_cat (D : twosided_disp_cat C₁ C₂) : disp_cat (category_binproduct C₁ C₂). Proof. simple refine (_ ,, _). - exact (twosided_disp_cat_to_disp_cat_data D). - exact (twosided_disp_cat_to_disp_cat_axioms D). Defined. Definition disp_cat_to_twosided_disp_cat_ob_mor (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat_ob_mor C₁ C₂. Proof. simple refine (_ ,, _). - exact (λ x y, D (x ,, y)). - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g, xy₁ -->[ f ,, g ] xy₂). Defined. Definition disp_cat_to_twosided_disp_cat_id_comp (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat_id_comp (disp_cat_to_twosided_disp_cat_ob_mor D). Proof. split. - exact (λ x y xy, id_disp _). - refine (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂, _). cbn in *. exact (fg₁ ;; fg₂)%mor_disp. Defined. Definition disp_cat_to_twosided_disp_cat_data (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat_data C₁ C₂. Proof. simple refine (_ ,, _). - exact (disp_cat_to_twosided_disp_cat_ob_mor D). - exact (disp_cat_to_twosided_disp_cat_id_comp D). Defined. Definition disp_cat_to_twosided_disp_cat_axioms (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat_axioms (disp_cat_to_twosided_disp_cat_data D). Proof. repeat split. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg ; cbn in *. refine (id_left_disp fg @ _). apply transportb_dirprodeq'. - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg ; cbn in *. refine (id_right_disp fg @ _). apply transportb_dirprodeq'. - intros x₁ x₂ x₃ x₄ y₁ y₂ y₃ y₄ xy₁ xy₂ xy₃ xy₄ f₁ f₂ f₃ g₁ g₂ g₃ fg₁ fg₂ fg₃. cbn in *. refine (assoc_disp fg₁ fg₂ fg₃ @ _). apply transportb_dirprodeq'. - intro ; intros. apply D. Qed. Definition disp_cat_to_twosided_disp_cat (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat C₁ C₂. Proof. simple refine (_ ,, _). - exact (disp_cat_to_twosided_disp_cat_data D). - exact (disp_cat_to_twosided_disp_cat_axioms D). Defined. Definition two_sided_disp_cat_weq_disp_cat_inv_left (D : twosided_disp_cat C₁ C₂) : disp_cat_to_twosided_disp_cat (twosided_disp_cat_to_disp_cat D) = D. Proof. use subtypePath. { intro. apply isaprop_twosided_disp_cat_axioms. } apply idpath. Qed. Definition two_sided_disp_cat_weq_disp_cat_inv_right (D : disp_cat (category_binproduct C₁ C₂)) : twosided_disp_cat_to_disp_cat (disp_cat_to_twosided_disp_cat D) = D. Proof. use subtypePath. { intro. apply isaprop_disp_cat_axioms. } apply idpath. Qed. Definition two_sided_disp_cat_weq_disp_cat : twosided_disp_cat C₁ C₂ ≃ disp_cat (category_binproduct C₁ C₂). Proof. use weq_iso. - exact twosided_disp_cat_to_disp_cat. - exact disp_cat_to_twosided_disp_cat. - exact two_sided_disp_cat_weq_disp_cat_inv_left. - exact two_sided_disp_cat_weq_disp_cat_inv_right. Defined. End TwoSidedDispCatVersusDispCat. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/TwoSidedFibration.v000066400000000000000000000413661451125700300276010ustar00rootroot00000000000000(********************************************************************************** Two-sided fibrations In this file, we study two-sided fibrations and we use two-sided displayed categories to define them. Note that the 'two-sided' in the name 'two-sided displayed categories' is taken from two-sided fibrations, and defining two-sided fibrations is one of the main goal. Our definition is based on Definition 2.3.4 in https://arxiv.org/pdf/1806.06129.pdf Let's say we have the span `C₁ ⟵ D ⟶ C₂`. In the definition by Loregian and Riehl, the functor `D ⟶ C₂` has a cleaving and the functor `D ⟶ C₁` has an opcleaving. However, in our definition, it is the other way around. For us, the functor `D ⟶ C₁` has a cleaving and `D ⟶ C₂` has an opcleaving. This change has minor consequence. For example, if we consider the arrow category on a category `C`, then we have a two-sided fibration `C ⟵ Arr(C) ⟶ C` where the left functor is the domain and the right functor is the codomain. In the definition by Loregian and Riehl, this would be the other way around. If we would use their definition in our setting, then we would need to reveres the arrows when defining the arrow category. Contents 1. Opcartesian morphisms 2. Cartesian morphisms 3. Cleavings 4. Two-sided fibrations **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete. Local Open Scope cat. Section TwoSidedFibration. Context {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂). (** 1. Opcartesian morphisms *) Definition twosided_opcartesian {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : UU := ∏ (x₃ : C₁) (y₃ : C₂) (xy₃ : D x₃ y₃) (f' : x₂ --> x₃) (g' : y₂ --> y₃) (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃), ∃! (ℓ : xy₂ -->[ f' ][ g' ] xy₃), fg ;;2 ℓ = fg'. Definition twosided_opcartesian_factorisation {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (H : twosided_opcartesian fg) {x₃ : C₁} {y₃ : C₂} {xy₃ : D x₃ y₃} {f' : x₂ --> x₃} {g' : y₂ --> y₃} (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃) : xy₂ -->[ f' ][ g' ] xy₃ := pr11 (H _ _ _ _ _ fg'). Definition twosided_opcartesian_factorisation_commutes {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (H : twosided_opcartesian fg) {x₃ : C₁} {y₃ : C₂} {xy₃ : D x₃ y₃} {f' : x₂ --> x₃} {g' : y₂ --> y₃} (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃) : fg ;;2 twosided_opcartesian_factorisation H fg' = fg' := pr21 (H _ _ _ _ _ fg'). (** 2. Cartesian morphisms *) Definition twosided_cartesian {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : UU := ∏ (x₀ : C₁) (y₀ : C₂) (xy₀ : D x₀ y₀) (f' : x₀ --> x₁) (g' : y₀ --> y₁) (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂), ∃! (ℓ : xy₀ -->[ f' ][ g' ] xy₁), ℓ ;;2 fg = fg'. Definition twosided_cartesian_factorisation {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (H : twosided_cartesian fg) {x₀ : C₁} {y₀ : C₂} {xy₀ : D x₀ y₀} {f' : x₀ --> x₁} {g' : y₀ --> y₁} (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂) : xy₀ -->[ f' ][ g' ] xy₁ := pr11 (H _ _ _ _ _ fg'). Definition twosided_cartesian_factorisation_commutes {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (H : twosided_cartesian fg) {x₀ : C₁} {y₀ : C₂} {xy₀ : D x₀ y₀} {f' : x₀ --> x₁} {g' : y₀ --> y₁} (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂) : twosided_cartesian_factorisation H fg' ;;2 fg = fg' := pr21 (H _ _ _ _ _ fg'). (** 3. Cleavings *) Definition twosided_opcleaving : UU := ∏ (x : C₁) (y₁ y₂ : C₂) (xy₁ : D x y₁) (g : y₁ --> y₂), ∑ (xy₂ : D x y₂) (ℓ : xy₁ -->[ identity _ ][ g ] xy₂), twosided_opcartesian ℓ. Definition twosided_opcleaving_ob (H : twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : D x y₂ := pr1 (H x y₁ y₂ xy₁ g). Definition twosided_opcleaving_mor (H : twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : xy₁ -->[ identity _ ][ g ] twosided_opcleaving_ob H xy₁ g := pr12 (H x y₁ y₂ xy₁ g). Definition twosided_opcleaving_opcartesian (H : twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : twosided_opcartesian (twosided_opcleaving_mor H xy₁ g) := pr22 (H x y₁ y₂ xy₁ g). Definition twosided_cleaving : UU := ∏ (x₁ x₂ : C₁) (y : C₂) (xy₂ : D x₂ y) (f : x₁ --> x₂), ∑ (xy₁ : D x₁ y) (ℓ : xy₁ -->[ f ][ identity _ ] xy₂), twosided_cartesian ℓ. Definition twosided_cleaving_ob (H : twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : D x₁ y := pr1 (H x₁ x₂ y xy₂ f). Definition twosided_cleaving_mor (H : twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂ := pr12 (H x₁ x₂ y xy₂ f). Definition twosided_cleaving_cartesian (H : twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : twosided_cartesian (twosided_cleaving_mor H xy₂ f) := pr22 (H x₁ x₂ y xy₂ f). Definition twosided_commute (H₁ : twosided_opcleaving) (H₂ : twosided_cleaving) {x₁ x₂ : C₁} {y₁ y₂ : C₂} (xy : D x₂ y₁) (f : x₁ --> x₂) (g : y₁ --> y₂) : twosided_opcleaving_ob H₁ (twosided_cleaving_ob H₂ xy f) g -->[ identity _ ][ identity _ ] twosided_cleaving_ob H₂ (twosided_opcleaving_ob H₁ xy g) f. Proof. use (twosided_opcartesian_factorisation (twosided_opcleaving_opcartesian H₁ _ g)). use (twosided_cartesian_factorisation (twosided_cleaving_cartesian H₂ _ f)). refine (transportb (λ z, _ -->[ z ][ _ ] _) _ (transportb (λ z, _ -->[ _ ][ z ] _) _ (twosided_cleaving_mor H₂ xy f ;;2 twosided_opcleaving_mor H₁ xy g))). - abstract (rewrite !id_left, !id_right ; apply idpath). - abstract (rewrite !id_left, !id_right ; apply idpath). Defined. Definition is_iso_twosided_commute (H₁ : twosided_opcleaving) (H₂ : twosided_cleaving) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (xy : D x₂ y₁) (f : x₁ --> x₂) (g : y₁ --> y₂), is_iso_twosided_disp (identity_is_z_iso _) (identity_is_z_iso _) (twosided_commute H₁ H₂ xy f g). (** 4. Two-sided fibrations *) Definition twosided_fibration : UU := ∑ (H₁ : twosided_opcleaving) (H₂ : twosided_cleaving), is_iso_twosided_commute H₁ H₂. End TwoSidedFibration. (** 5. Discrete two-sided fibrations *) Section DiscreteTwoSidedFibration. Context {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂). Definition discrete_twosided_opcartesian {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : UU := ∏ (x₃ : C₁) (y₃ : C₂) (xy₃ : D x₃ y₃) (f' : x₂ --> x₃) (g' : y₂ --> y₃) (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃), xy₂ -->[ f' ][ g' ] xy₃. Definition discrete_twosided_opcartesian_is_opcartesian (HD : discrete_twosided_disp_cat D) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : discrete_twosided_opcartesian fg) : twosided_opcartesian D fg. Proof. intros x₃ y₃ xy₃ f' g' fg'. use iscontraprop1. - abstract (use invproofirrelevance ; intro ; intros ; use subtypePath ; [ intro ; apply isaset_disp_mor | ] ; apply HD). - simple refine (_ ,, _). + apply Hfg. exact fg'. + apply HD. Defined. Definition discrete_twosided_cartesian {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} (fg : xy₁ -->[ f ][ g ] xy₂) : UU := ∏ (x₀ : C₁) (y₀ : C₂) (xy₀ : D x₀ y₀) (f' : x₀ --> x₁) (g' : y₀ --> y₁) (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂), xy₀ -->[ f' ][ g' ] xy₁. Definition discrete_twosided_cartesian_is_cartesian (HD : discrete_twosided_disp_cat D) {x₁ x₂ : C₁} {y₁ y₂ : C₂} {xy₁ : D x₁ y₁} {xy₂ : D x₂ y₂} {f : x₁ --> x₂} {g : y₁ --> y₂} {fg : xy₁ -->[ f ][ g ] xy₂} (Hfg : discrete_twosided_cartesian fg) : twosided_cartesian D fg. Proof. intros x₃ y₃ xy₃ f' g' fg'. use iscontraprop1. - abstract (use invproofirrelevance ; intro ; intros ; use subtypePath ; [ intro ; apply isaset_disp_mor | ] ; apply HD). - simple refine (_ ,, _). + apply Hfg. exact fg'. + apply HD. Defined. Definition discrete_twosided_opcleaving : UU := ∏ (x : C₁) (y₁ y₂ : C₂) (xy₁ : D x y₁) (g : y₁ --> y₂), ∑ (xy₂ : D x y₂) (ℓ : xy₁ -->[ identity _ ][ g ] xy₂), discrete_twosided_opcartesian ℓ. Definition discrete_twosided_opcleaving_ob (H : discrete_twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : D x y₂ := pr1 (H x y₁ y₂ xy₁ g). Definition discrete_twosided_opcleaving_mor (H : discrete_twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : xy₁ -->[ identity _ ][ g ] discrete_twosided_opcleaving_ob H xy₁ g := pr12 (H x y₁ y₂ xy₁ g). Definition discrete_twosided_opcleaving_opcartesian (H : discrete_twosided_opcleaving) {x : C₁} {y₁ y₂ : C₂} (xy₁ : D x y₁) (g : y₁ --> y₂) : discrete_twosided_opcartesian (discrete_twosided_opcleaving_mor H xy₁ g) := pr22 (H x y₁ y₂ xy₁ g). Definition discrete_twosided_disp_cat_to_opcleaving (HD : discrete_twosided_disp_cat D) (HD' : discrete_twosided_opcleaving) : twosided_opcleaving D. Proof. intros x y₁ y₂ xy₁ g. simple refine (_ ,, _ ,, _). - exact (pr1 (HD' x y₁ y₂ xy₁ g)). - exact (pr12 (HD' x y₁ y₂ xy₁ g)). - apply (discrete_twosided_opcartesian_is_opcartesian HD). exact (pr22 (HD' x y₁ y₂ xy₁ g)). Defined. Definition discrete_twosided_cleaving : UU := ∏ (x₁ x₂ : C₁) (y : C₂) (xy₂ : D x₂ y) (f : x₁ --> x₂), ∑ (xy₁ : D x₁ y) (ℓ : xy₁ -->[ f ][ identity _ ] xy₂), discrete_twosided_cartesian ℓ. Definition discrete_twosided_cleaving_ob (H : discrete_twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : D x₁ y := pr1 (H x₁ x₂ y xy₂ f). Definition discrete_twosided_cleaving_mor (H : discrete_twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : discrete_twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂ := pr12 (H x₁ x₂ y xy₂ f). Definition discrete_twosided_cleaving_cartesian (H : discrete_twosided_cleaving) {x₁ x₂ : C₁} {y : C₂} (xy₂ : D x₂ y) (f : x₁ --> x₂) : discrete_twosided_cartesian (discrete_twosided_cleaving_mor H xy₂ f) := pr22 (H x₁ x₂ y xy₂ f). Definition discrete_twosided_disp_cat_to_cleaving (HD : discrete_twosided_disp_cat D) (HD' : discrete_twosided_cleaving) : twosided_cleaving D. Proof. intros x y₁ y₂ xy₁ g. simple refine (_ ,, _ ,, _). - exact (pr1 (HD' x y₁ y₂ xy₁ g)). - exact (pr12 (HD' x y₁ y₂ xy₁ g)). - apply (discrete_twosided_cartesian_is_cartesian HD). exact (pr22 (HD' x y₁ y₂ xy₁ g)). Defined. End DiscreteTwoSidedFibration. Definition is_discrete_twosided_fibration {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : discrete_twosided_disp_cat D) : UU := discrete_twosided_cleaving D × discrete_twosided_opcleaving D. Definition discrete_twosided_fibration (C₁ C₂ : category) : UU := ∑ (D : twosided_disp_cat C₁ C₂) (HD : discrete_twosided_disp_cat D), is_discrete_twosided_fibration HD. Coercion discrete_twosided_fibration_to_twosided_disp_cat {C₁ C₂ : category} (D : discrete_twosided_fibration C₁ C₂) : twosided_disp_cat C₁ C₂ := pr1 D. Definition discrete_twosided_disp_cat_is_fibration {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : discrete_twosided_disp_cat D) (HD' : is_discrete_twosided_fibration HD) : twosided_fibration D. Proof. simple refine (_ ,, _ ,, _). - apply discrete_twosided_disp_cat_to_opcleaving. + exact HD. + apply HD'. - apply discrete_twosided_disp_cat_to_cleaving. + exact HD. + apply HD'. - cbn. unfold is_iso_twosided_commute. intro ; intros. apply HD. Defined. UniMath-20231010/UniMath/CategoryTheory/TwoSidedDisplayedCats/Univalence.v000066400000000000000000000116301451125700300263010ustar00rootroot00000000000000(********************************************************************************** Univalence two-sided displayed categories We define univalent two-sided displayed categories. To do so, we first define the map that sends identities to isomorphisms. Univalence is then expressed the usual way. Contents 1. Univalence for two-sided displayed categories 2. Equivalence with univalent displayed categories **********************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat. Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos. Local Open Scope cat. (** 1. Univalence for two-sided displayed categories *) Definition idtoiso_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} {x₁ x₂ : C₁} {y₁ y₂ : C₂} (p : x₁ = x₂) (q : y₁ = y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (r : transportf (λ z, D z _) p (transportf (λ z, D _ z) q xy₁) = xy₂) : iso_twosided_disp (idtoiso p) (idtoiso q) xy₁ xy₂. Proof. induction p. induction q. induction r. apply id_iso_twosided_disp. Defined. Definition is_univalent_twosided_disp_cat {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : UU := ∏ (x₁ x₂ : C₁) (y₁ y₂ : C₂) (p : x₁ = x₂) (q : y₁ = y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂), isweq (idtoiso_twosided_disp p q xy₁ xy₂). Definition isaprop_is_univalent_twosided_disp_cat {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : isaprop (is_univalent_twosided_disp_cat D). Proof. do 8 (use impred ; intro). apply isapropisweq. Qed. Definition isotoid_twosided_disp {C₁ C₂ : category} {D : twosided_disp_cat C₁ C₂} (HD : is_univalent_twosided_disp_cat D) {x₁ x₂ : C₁} {y₁ y₂ : C₂} (p : x₁ = x₂) (q : y₁ = y₂) (xy₁ : D x₁ y₁) (xy₂ : D x₂ y₂) (r : iso_twosided_disp (idtoiso p) (idtoiso q) xy₁ xy₂) : transportf (λ z, D z _) p (transportf (λ z, D _ z) q xy₁) = xy₂ := invmap (_ ,, HD x₁ x₂ y₁ y₂ p q xy₁ xy₂) r. Definition univalent_twosided_disp_cat (C₁ C₂ : category) : UU := ∑ (D : twosided_disp_cat C₁ C₂), is_univalent_twosided_disp_cat D. Coercion univalent_twosided_disp_cat_to_twosided_disp_cat {C₁ C₂ : category} (D : univalent_twosided_disp_cat C₁ C₂) : twosided_disp_cat C₁ C₂ := pr1 D. Proposition is_univalent_univalent_twosided_disp_cat {C₁ C₂ : category} (D : univalent_twosided_disp_cat C₁ C₂) : is_univalent_twosided_disp_cat D. Proof. exact (pr2 D). Qed. (** 2. Equivalence with univalent displayed categories *) Definition is_univalent_twosided_disp_cat_weq_is_univalent_disp_cat {C₁ C₂ : category} (D : twosided_disp_cat C₁ C₂) : is_univalent_twosided_disp_cat D ≃ is_univalent_disp (two_sided_disp_cat_weq_disp_cat C₁ C₂ D). Proof. use weqimplimpl. - intros H. use is_univalent_disp_from_fibers. intros x xx yy. use weqhomot. + exact (iso_twosided_disp_weq_z_iso_disp xx yy ∘ make_weq _ (H _ _ _ _ (idpath _) (idpath _) xx yy))%weq. + intros p. induction p. use subtypePath. { intro. apply isaprop_is_z_iso_disp. } apply idpath. - intros H x₁ x₂ y₁ y₂ p q xy₁ xy₂. induction p, q. use weqhomot. + exact (invweq (iso_twosided_disp_weq_z_iso_disp xy₁ xy₂) ∘ make_weq _ (H (x₁ ,, y₁) (x₁ ,, y₁) (idpath _) xy₁ xy₂))%weq. + intros p. induction p. use subtypePath. { intro. apply isaprop_is_iso_twosided_disp. } apply idpath. - apply isaprop_is_univalent_twosided_disp_cat. - apply isaprop_is_univalent_disp. Qed. Definition univalent_twosided_disp_cat_weq_univalent_disp_cat (C₁ C₂ : category) : univalent_twosided_disp_cat C₁ C₂ ≃ disp_univalent_category (category_binproduct C₁ C₂). Proof. use weqtotal2. - exact (two_sided_disp_cat_weq_disp_cat C₁ C₂). - exact (λ D, is_univalent_twosided_disp_cat_weq_is_univalent_disp_cat D). Defined. UniMath-20231010/UniMath/CategoryTheory/UnderCategories.v000066400000000000000000000120661451125700300231030ustar00rootroot00000000000000(** Undercategories *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Section def_underprecategories. Variable C : precategory. Hypothesis hs : has_homsets C. Variable c : ob C. (* Objects *) Definition Under_ob : UU := ∑ d, C⟦c, d⟧. Definition make_Under_ob {d : ob C} (f : C⟦c, d⟧) : Under_ob := tpair _ d f. (* Accessor functions *) Definition Under_ob_cod (X : Under_ob) : ob C := pr1 X. Definition Under_ob_mor (X : Under_ob) : C⟦c, Under_ob_cod X⟧ := pr2 X. (* Morphisms *) Definition Under_mor (X Y : Under_ob) : UU := ∑ f : C⟦Under_ob_cod X, Under_ob_cod Y⟧, Under_ob_mor X · f = Under_ob_mor Y. Definition make_Under_mor (X Y : Under_ob) (f : C⟦Under_ob_cod X, Under_ob_cod Y⟧) (H : Under_ob_mor X · f = Under_ob_mor Y) : Under_mor X Y := tpair _ f H. (* Accessor functions *) Definition Under_mor_mor {X Y : Under_ob} (M : Under_mor X Y) : C⟦Under_ob_cod X, Under_ob_cod Y⟧ := pr1 M. Definition Under_mor_eq {X Y : Under_ob} (M : Under_mor X Y) : Under_ob_mor X · Under_mor_mor M = Under_ob_mor Y := pr2 M. (* An undercategory has_homsets *) Definition isaset_Under_mor (X Y : Under_ob) : isaset (Under_mor X Y). Proof. apply (isofhleveltotal2 2). - apply hs. - intros x. apply hlevelntosn. apply hs. Qed. Definition Under_mor_equality (X Y : Under_ob) (f f' : Under_mor X Y) : pr1 f = pr1 f' -> f = f'. Proof. intro H. apply subtypePath. intro x. apply hs. exact H. Qed. Definition Under_id (X : Under_ob) : Under_mor X X := make_Under_mor X X (identity _) (id_right _ ). Local Lemma Under_comp_eq {X Y Z : Under_ob} (f : Under_mor X Y) (g : Under_mor Y Z) : Under_ob_mor X · (Under_mor_mor f · Under_mor_mor g) = Under_ob_mor Z. Proof. rewrite assoc. rewrite (Under_mor_eq f). exact (Under_mor_eq g). Qed. Definition Under_comp (X Y Z : Under_ob) : Under_mor X Y -> Under_mor Y Z -> Under_mor X Z. Proof. intros f g. exact (make_Under_mor X Z (Under_mor_mor f · Under_mor_mor g) (Under_comp_eq f g)). Defined. Definition Undercategory_ob_mor : precategory_ob_mor. Proof. exists Under_ob. exact Under_mor. Defined. Definition Undercategory_data : precategory_data. Proof. exists Undercategory_ob_mor. split. - exact Under_id. - exact Under_comp. Defined. Definition is_precategory_Undercategory_data : is_precategory Undercategory_data. Proof. repeat split. - intros. apply Under_mor_equality. apply id_left. - intros. apply Under_mor_equality. apply id_right. - intros. apply Under_mor_equality. apply assoc. - intros. apply Under_mor_equality. apply assoc'. Defined. Definition Undercategory : precategory. Proof. exists Undercategory_data. exact is_precategory_Undercategory_data. Defined. Lemma has_homsets_Under : has_homsets Undercategory. Proof. intros X Y. apply (isaset_Under_mor X Y). Qed. End def_underprecategories. (** * Morphism of tips induces a functor *) Section undercategories_morphisms. Variable C : precategory. Hypothesis hs : has_homsets C. Local Notation "c / C" := (@Undercategory C hs c). Definition Under_precategories_mor_ob {c c' : C} (h : C⟦c, c'⟧) : c' / C → c / C. Proof. intro af. exists (pr1 af). exact (h · pr2 af). Defined. Local Lemma Under_precategories_mor_mor_eq {c c' : C} (h : C⟦c, c'⟧) (af af' : c' / C) (g : (c' / C)⟦af, af'⟧) : (Under_ob_mor C c (Under_precategories_mor_ob h af)) · (Under_mor_mor C c' g) = (Under_ob_mor C c (Under_precategories_mor_ob h af')). Proof. cbn. rewrite <- assoc. apply cancel_precomposition. set (tmp := Under_mor_eq C c' g). unfold Under_mor_mor. unfold Under_mor_mor, Under_ob_mor in tmp. exact tmp. Qed. Definition Under_precategories_mor_mor {c c' : C} (h : C⟦c, c'⟧) (af af' : c' / C) (g : (c' / C)⟦af, af'⟧) : (c / C) ⟦Under_precategories_mor_ob h af, Under_precategories_mor_ob h af'⟧. Proof. exists (Under_mor_mor C c' g). exact (Under_precategories_mor_mor_eq h af af' g). Defined. Definition Under_precategories_mor_functor_data {c c' : C} (h : C⟦c, c'⟧) : functor_data (c' / C) (c / C). Proof. exists (Under_precategories_mor_ob h). exact (Under_precategories_mor_mor h). Defined. Lemma is_functor_Under_mor_functor_data {c c' : C} (h : C⟦c, c'⟧) : is_functor (Under_precategories_mor_functor_data h). Proof. split. - intro. apply (Under_mor_equality _ hs). apply idpath. - intros ? ? ? ? ?. apply (Under_mor_equality _ hs). apply idpath. Defined. Definition functor_Under_precategories_mor {c c' : C} (h : C⟦c, c'⟧) : functor _ _ := tpair _ _ (is_functor_Under_mor_functor_data h). End undercategories_morphisms. UniMath-20231010/UniMath/CategoryTheory/UnitorsAndAssociatorsForEndofunctors.v000066400000000000000000000173111451125700300273600ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes 2015 Modified by: Anders Mörtberg, 2016 Ralph Matthes, 2017 ************************************************************) (** ********************************************************** Contents : - Definition of the (weak) monoidal structure on endofunctors (however, the definitions are not confined to endofunctors) Here, we only give the unitors and associators and do not build a monoidal category (anyway, this is not possible since we are not considering only endofunctors). ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. (** There is a monoidal structure on endofunctors, given by composition. While this is considered to be strict in set-theoretic category theory, it ain't strict in type theory with respect to convertibility. So we consider it to be a weak monoidal structure instead. However, pointwise, it suffices to take the identity for all those natural transformations (the identity is also behind the definition of nat_trans_functor_assoc). To understand the need for this structure even better, notice that the proofs of functor axioms for one composition in the unitality and associativity properties are slightly different from the proofs for the other and because of it the composition of functors is not strictly unital or associative. However, these proofs are not used in the definition of natural transformations, to be precise only functor_data is used, and the composition of functor_data is strictly unital and associative. *) Section Monoidal_Structure_on_Endofunctors. (** while this is normally used for endofunctors, it can be done more generally, but already for endofunctors, this is crucial for the development of substitution systems *) Context {C D : precategory}. Goal ∏ X Y : C ⟶ D, functor_composite X (functor_identity D) ⟹ Y = (X ⟹ Y). Proof. intros X Y. apply idpath. Qed. (** this also holds in the target but is not needed here *) Goal ∏ X Y : C ⟶ D, Y ⟹ functor_composite X (functor_identity D) = (Y ⟹ X). Proof. intros X Y. apply idpath. Qed. Goal ∏ X : C ⟶ D, functor_composite (functor_identity C) X = X. Proof. intros. apply idpath. Qed. (** trivially, this observed convertibility implies the following three convertibilities *) Goal ∏ X Y : C ⟶ D, functor_composite (functor_identity C) X ⟹ Y = (X ⟹ Y). Proof. intros X Y. apply idpath. Qed. (** again, this also holds in the target but is not needed here *) Goal ∏ X Y : C ⟶ D, Y ⟹ functor_composite (functor_identity C) X = (Y ⟹ X). Proof. intros X Y. apply idpath. Qed. Goal ∏ (E: precategory)(hs: has_homsets D)(H: functor [C,D,hs] E) (X: C ⟶ D), H(functor_composite (functor_identity C) X) = H X. Proof. intros. apply idpath. Qed. (** end of implied convertibilities *) (** the last convertibility fails for the composition with the identity as second argument *) Goal ∏ (E: precategory)(hs: has_homsets D)(H: functor [C,D,hs] E) (X: C ⟶ D), H(functor_composite X (functor_identity D)) = H X. Proof. intros. Fail (apply idpath). Abort. (** in particular, there is no convertibility between the arguments to [H] *) Definition ρ_functors (X : functor C D) : nat_trans (functor_composite X (functor_identity D)) X := nat_trans_id X. Definition ρ_functors_inv (X : functor C D) : nat_trans X (functor_composite X (functor_identity D)) := nat_trans_id X. Definition λ_functors (X : functor C D) : nat_trans (functor_composite (functor_identity C) X) X := nat_trans_id X. Definition λ_functors_inv (X : functor C D) : nat_trans X (functor_composite (functor_identity C) X) := nat_trans_id X. Context {E F: precategory}. Goal ∏ (X : functor C D)(Y : functor D E)(Z : functor E F) (U: functor C F), (functor_composite (functor_composite X Y) Z) ⟹ U = (functor_composite X (functor_composite Y Z)) ⟹ U. Proof. intros. apply idpath. Qed. Goal ∏ (X : functor C D)(Y : functor D E)(Z : functor E F) (U: functor C F), U ⟹ (functor_composite (functor_composite X Y) Z) = U ⟹ (functor_composite X (functor_composite Y Z)). Proof. intros. apply idpath. Qed. Definition α_functors (X : functor C D)(Y : functor D E)(Z : functor E F) : nat_trans (functor_composite (functor_composite X Y) Z) (functor_composite X (functor_composite Y Z)) := nat_trans_id ((X ∙ Y) ∙ Z). Definition α_functors_inv (X : functor C D)(Y : functor D E)(Z : functor E F) : nat_trans (functor_composite X (functor_composite Y Z)) (functor_composite (functor_composite X Y) Z) := nat_trans_id ((X ∙ Y) ∙ Z). Lemma α_functors_pointwise_is_z_iso (hsF: has_homsets F)(X : functor C D)(Y : functor D E)(Z : functor E F) : is_z_isomorphism(C:= functor_precategory C F hsF) (α_functors X Y Z). Proof. exists (α_functors_inv X Y Z). split; apply nat_trans_eq; try assumption; intro c; apply id_left. Defined. (** as a motivation, we show here that, propositionally, the functors in source and target of these are equal, for each of the three pairs of functors; the extra assumption on having homsets is only used in order to have simple proofs, it is not necessary, as shown below *) Local Lemma motivation_ρ_functors (hsD : has_homsets D)(X : functor C D) : functor_composite X (functor_identity D) = X. Proof. now apply (functor_eq _ _ hsD); induction X as [data laws]; induction data as [onobs onmorphs]. Qed. Local Lemma motivation_λ_functors (hsD : has_homsets D)(X : functor C D) : functor_composite (functor_identity C) X = X. Proof. now apply (functor_eq _ _ hsD); induction X as [data laws]; induction data as [onobs onmorphs]. Qed. Local Lemma motivation_α_functors (hsF : has_homsets F)(X : functor C D)(Y : functor D E)(Z : functor E F) : functor_composite (functor_composite X Y) Z = functor_composite X (functor_composite Y Z). Proof. now apply (functor_eq _ _ hsF); induction X as [data laws]; induction data as [onobs onmorphs]. Qed. (** these laws do not help in type-checking definitions which is why the transformations further above are needed *) (** now we get rid of the homset assumptions by using results of Section "functor_equalities" in UniMath.CategoryTheory.Core.Functors.v *) Local Lemma motivation_ρ_functors_stronger (X : functor C D) : functor_composite X (functor_identity D) = X. Proof. apply functor_identity_right. Qed. Local Lemma motivation_λ_functors_stronger (X : functor C D) : functor_composite (functor_identity C) X = X. Proof. apply functor_identity_left. Qed. Local Lemma motivation_α_functors_stronger (X : functor C D)(Y : functor D E)(Z : functor E F) : functor_composite (functor_composite X Y) Z = functor_composite X (functor_composite Y Z). Proof. apply functor_assoc. Qed. End Monoidal_Structure_on_Endofunctors. (* Section InFunctorCategories. Context {C D E F : category}. Definition α_functors_funcat (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : [C, F] ⟦functor_compose (functor_compose X Y) Z, functor_compose X (functor_compose Y Z)⟧ := nat_trans_id ((X ∙ Y) ∙ Z). Definition α_functors_funcat_inv (X : [C, D]) (Y : [D, E]) (Z : [E, F]) : [C, F] ⟦functor_compose X (functor_compose Y Z), functor_compose (functor_compose X Y) Z⟧ := nat_trans_id ((X ∙ Y) ∙ Z). End InFunctorCategories. *) UniMath-20231010/UniMath/CategoryTheory/WeakEquivalences.v000066400000000000000000000105561451125700300232560ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecompEquivalence. Local Open Scope cat. Section WeakEquivalences. Definition is_weak_equiv {C D : category} (H : functor C D) : UU := essentially_surjective H × fully_faithful H. Definition eso_from_weak_equiv {C D : category} (F : C ⟶ D) : is_weak_equiv F → essentially_surjective F := pr1. Definition ff_from_weak_equiv {C D : category} (F : C ⟶ D) : is_weak_equiv F → fully_faithful F := pr2. Lemma isaprop_is_weak_equiv {C D : category} (H : functor C D) : isaprop (is_weak_equiv H). Proof. apply isapropdirprod. - apply isaprop_essentially_surjective. - apply isaprop_fully_faithful. Qed. Lemma id_is_weak_equiv (C : category) : is_weak_equiv (functor_identity C). Proof. split. - apply identity_functor_is_essentially_surjective. - apply identity_functor_is_fully_faithful. Qed. Definition comp_is_weak_equiv {C D E : category} (H : C ⟶ D) (I : D ⟶ E) : is_weak_equiv H → is_weak_equiv I → is_weak_equiv (H ∙ I). Proof. intros Hw Iw. split. - exact (comp_essentially_surjective _ (eso_from_weak_equiv _ Hw) _ (eso_from_weak_equiv _ Iw)). - exact (comp_ff_is_ff _ _ _ _ (ff_from_weak_equiv _ Hw) _ (ff_from_weak_equiv _ Iw)). Qed. Definition weak_equiv (C D : category) : UU := ∑ H : C ⟶ D, is_weak_equiv H. End WeakEquivalences. Section WeakEquivalenceInducesIsoOnUnivalentFunctorCategories. Context {C D : category} (H : C ⟶ D) (Hw : is_weak_equiv H). Definition precomp_is_iso : ∏ E : univalent_category, is_catiso (pre_composition_functor _ _ E H). Proof. intro E. transparent assert (a : (Core.adj_equivalence_of_cats (pre_composition_functor _ _ (pr1 E) H))). { apply precomp_adjoint_equivalence ; apply Hw. } use (pr2 (adj_equivalence_of_cats_to_cat_iso a _ _)) ; apply is_univalent_functor_category ; apply E. Defined. Definition precomp_is_equality : ∏ E : univalent_category, [D, E] = [C, E]. Proof. intro E. apply catiso_to_category_path. exact (_ ,, precomp_is_iso E). Defined. End WeakEquivalenceInducesIsoOnUnivalentFunctorCategories. Section WeakEquivalencePreservations. Definition weak_equiv_preserves_chosen_terminal {C D : category} (F : C ⟶ D) : is_weak_equiv F → ∏ t : Terminal C, preserves_chosen_terminal t F. Proof. intros Fw [x x_is_t] y'. use (factor_through_squash (isapropiscontr _) _ (eso_from_weak_equiv _ Fw y')). intros [y yi]. apply (iscontrweqb' (x_is_t y)). refine (invweq (_ ,, ff_from_weak_equiv _ Fw y x) ∘ _)%weq. apply z_iso_comp_right_weq. exact yi. Qed. Definition weak_equiv_preserves_terminal {C D : category} (F : C ⟶ D) : is_weak_equiv F → preserves_terminal F. Proof. intros Fw ? x_is_t. apply (preserves_terminal_if_preserves_chosen (_,,x_is_t)). - apply weak_equiv_preserves_chosen_terminal. exact Fw. - exact x_is_t. Qed. Definition weak_equiv_preserves_chosen_terminal_eq {C D : category} (F : C ⟶ D) : is_weak_equiv F → is_univalent D → ∏ t1 t2, preserves_chosen_terminal_eq F t1 t2. Proof. intros Fw Duniv t1 t2. apply hinhpr. apply Duniv. set (Ft1_t := weak_equiv_preserves_terminal _ Fw _ (pr2 t1)). exact (z_iso_Terminals (_ ,, Ft1_t) t2). Qed. End WeakEquivalencePreservations. Section WeakEquivalenceReflections. Lemma weak_equiv_reflects_terminal {C D : category} (F : C ⟶ D) : is_weak_equiv F → ∏ c : C, isTerminal _ (F c) → isTerminal _ c. Proof. intros Fw c Fc_term c'. apply (iscontrweqb' (Fc_term (F c'))). apply ((_ ,, ff_from_weak_equiv _ Fw _ _))%weq. Qed. End WeakEquivalenceReflections. UniMath-20231010/UniMath/CategoryTheory/YonedaBinproducts.v000066400000000000000000000070121451125700300234470ustar00rootroot00000000000000(** **************************************************************************** Yoneda commutes with binary products up to iso ([iso_yoneda_binproducts]). Written by: Elisabeth Bonnevier, 2019 ********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.Presheaf. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.yoneda. Local Open Scope cat. Section iso_yoneda_binproducts. Context {C : category} (PC : BinProducts C) (X Y : C). Let yon : C ⟶ [C^op, HSET] := yoneda C. (** First we create a natural transformation from Yon(X × Y) to Yon(X) × Yon(Y). *) Definition yon_binprod_nat_trans_data : nat_trans_data (pr1 (yon (BinProductObject _ (PC X Y)))) (pr1 (BinProductObject _ (BinProducts_PreShv (yon X) (yon Y)))). Proof. intros Z f. split; [exact (f · BinProductPr1 _ _) | exact (f · BinProductPr2 _ _)]. Defined. Lemma is_nat_trans_yon_binprod : is_nat_trans _ _ yon_binprod_nat_trans_data. Proof. intros Z W f. use funextfun; intro g. now apply dirprodeq; use assoc'. Qed. Definition yon_binprod_nat_trans : nat_trans (pr1 (yon (BinProductObject _ (_ X Y)))) (pr1 (BinProductObject _ (BinProducts_PreShv (yon X) (yon Y)))) := make_nat_trans _ _ _ is_nat_trans_yon_binprod. (** Second, we create a natural transformation from Yon(X) × Yon(Y) to Yon(X × Y). *) Definition yon_binprod_inv_nat_trans_data : nat_trans_data (pr1 (BinProductObject _ (BinProducts_PreShv (yon X) (yon Y)))) (pr1 (yon (BinProductObject _ (PC X Y)))). Proof. intros Z [f1 f2]. exact (BinProductArrow _ (PC X Y) f1 f2). Defined. Lemma is_nat_trans_yon_binprod_inv : is_nat_trans _ _ yon_binprod_inv_nat_trans_data. Proof. unfold yon_binprod_inv_nat_trans_data. intros Z W f. use funextfun; intros [g1 g2]; cbn. use BinProductArrowsEq; rewrite <- assoc. - now rewrite !BinProductPr1Commutes. - now rewrite !BinProductPr2Commutes. Qed. Definition yon_binprod_inv_nat_trans : nat_trans (pr1 (BinProductObject _ (BinProducts_PreShv (yon X) (yon Y)))) (pr1 (yon (BinProductObject _ (_ X Y)))) := make_nat_trans _ _ _ is_nat_trans_yon_binprod_inv. (** We now show that the first transformation is an isomorphism by showing that the second transformation is its inverse. *) Lemma yon_binprod_is_iso : @is_iso [C^op, HSET, has_homsets_HSET] _ _ yon_binprod_nat_trans. Proof. use is_iso_from_is_z_iso. exists yon_binprod_inv_nat_trans. split; apply (nat_trans_eq has_homsets_HSET); intro Z; use funextfun; intro f. - cbn; unfold yon_binprod_nat_trans_data, yon_binprod_inv_nat_trans_data. now rewrite <- (BinProductArrowEta _ _ _ _ _ _). - use dirprodeq; cbn; unfold yon_binprod_inv_nat_trans_data; [use BinProductPr1Commutes | use BinProductPr2Commutes]. Qed. (** The functors Yon(X × Y) and Yon(X) × Yon(Y) are isomorphic. *) Lemma iso_yoneda_binproducts : iso (yon (BinProductObject _ (PC X Y))) (BinProductObject (PreShv _) (BinProducts_PreShv (yon X) (yon Y))). Proof. use make_iso. - use yon_binprod_nat_trans. - use yon_binprod_is_iso. Defined. End iso_yoneda_binproducts. UniMath-20231010/UniMath/CategoryTheory/ZigZag.v000066400000000000000000000167341451125700300212210ustar00rootroot00000000000000(********************************************************************* Zig-zags in categories A zig-zag in a category is a finite chain of morphisms like this x1 --> x2 <-- x3 --> x4 <-- x5 In this file, we define the notion of zig-zags and a number of operations on them. Contents: 1. Definition of zig-zags 2. Constructors for zig-zags 3. Action of functors on zig-zags 4. Appending zig-zags 5. Reversing zig-zags 6. Zig-zags in groupoids give morphisms 7. Examples of zig-zag notation *********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Groupoids. Local Open Scope cat. (** 1. Definition of zig-zags *) Definition zig_zag_of_length {C : category} (n : ℕ) : ∏ (x y : C), UU. Proof. induction n as [ | n IHn ]. - exact (λ x y, z_iso x y). - exact (λ x y, ∑ (z : C), ((x --> z) ⨿ (z --> x)) × IHn z y). Defined. Definition zig_zag {C : category} (x y : C) : UU := ∑ (n : ℕ), zig_zag_of_length n x y. Definition length_of_zig_zag {C : category} {x y : C} (gs : zig_zag x y) : ℕ := pr1 gs. (** 2. Constructors for zig-zags *) Definition empty_zig_zag {C : category} (x : C) : zig_zag x x := 0 ,, identity_z_iso x. Notation "x ■" := (empty_zig_zag x) (at level 40) : cat. Definition left_cons_zig_zag {C : category} {x z y : C} (f : x --> z) (gs : zig_zag z y) : zig_zag x y := 1 + length_of_zig_zag gs ,, (z ,, (inl f ,, pr2 gs)). Notation "x -[ f ]-> gs" := (@left_cons_zig_zag _ x _ _ f gs) (at level 41, right associativity) : cat. Definition right_cons_zig_zag {C : category} {x z y : C} (f : z --> x) (gs : zig_zag z y) : zig_zag x y := 1 + length_of_zig_zag gs ,, (z ,, (inr f ,, pr2 gs)). Notation "x <-[ f ]- gs" := (@right_cons_zig_zag _ x _ _ f gs) (at level 41, right associativity) : cat. (** 3. Action of functors on zig-zags *) Definition functor_on_zig_zag_of_length {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x y : C₁} {n : ℕ} (gs : zig_zag_of_length n x y) : zig_zag_of_length n (F x) (F y). Proof. revert x y gs. induction n as [ | n IHn ]. - intros x y gs. exact (functor_on_z_iso F gs). - intros x y gs. induction gs as [ z gs ]. induction gs as [ g gs ]. induction g as [ g | g ]. + exact (F z ,, inl (#F g) ,, IHn _ _ gs). + exact (F z ,, inr (#F g) ,, IHn _ _ gs). Defined. Definition functor_on_zig_zag {C₁ C₂ : category} (F : C₁ ⟶ C₂) {x y : C₁} (gs : zig_zag x y) : zig_zag (F x) (F y) := length_of_zig_zag gs ,, functor_on_zig_zag_of_length F (pr2 gs). (** 4. Appending zig-zags *) Definition precomp_z_iso_zig_zag_of_length {C : category} {n : ℕ} {x y z : C} (fs : zig_zag_of_length n y z) (i : z_iso x y) : zig_zag_of_length n x z. Proof. revert x y z fs i. induction n as [ | n IHn ]. - intros x y z fs i. exact (z_iso_comp i fs). - intros x y z fs i. induction fs as [ w fs ]. induction fs as [ f fs ]. induction f as [ f | f ]. + exact (w ,, inl (i · f) ,, fs). + exact (w ,, inr (f · inv_from_z_iso i) ,, fs). Defined. Definition append_zig_zag_of_length {C : category} {n m : ℕ} {x y z : C} (fs : zig_zag_of_length n x y) (gs : zig_zag_of_length m y z) : zig_zag_of_length (n + m) x z. Proof. revert x y z fs gs. induction n as [ | n IHn ]. - intros x y z fs gs. exact (precomp_z_iso_zig_zag_of_length gs fs). - intros x y z fs gs. induction fs as [ w fs ]. induction fs as [ f fs ]. induction f as [ f | f ]. + exact (w ,, inl f ,, IHn w y z fs gs). + exact (w ,, inr f ,, IHn w y z fs gs). Defined. Definition append_zig_zag {C : category} {x y z : C} (fs : zig_zag x y) (gs : zig_zag y z) : zig_zag x z := length_of_zig_zag fs + length_of_zig_zag gs ,, append_zig_zag_of_length (pr2 fs) (pr2 gs). (** 5. Reversing zig-zags *) Definition post_cons_left_zig_zag_of_length {C : category} {n : ℕ} {x y z : C} (gs : zig_zag_of_length n x y) (f : y --> z) : zig_zag_of_length (S n) x z. Proof. revert x y z gs f. induction n as [ | n IHn ]. - intros x y z gs f. exact (z ,, inl (pr1 gs · f) ,, identity_z_iso z). - intros x y z gs f. induction gs as [ w gs ]. induction gs as [ g gs ]. induction g as [ g | g ]. + exact (w ,, inl g ,, IHn _ _ _ gs f). + exact (w ,, inr g ,, IHn _ _ _ gs f). Defined. Definition post_cons_right_zig_zag_of_length {C : category} {n : ℕ} {x y z : C} (gs : zig_zag_of_length n x y) (f : z --> y) : zig_zag_of_length (S n) x z. Proof. revert x y z gs f. induction n as [ | n IHn ]. - intros x y z gs f. exact (z ,, inr (f · inv_from_z_iso gs) ,, identity_z_iso z). - intros x y z gs f. induction gs as [ w gs ]. induction gs as [ g gs ]. induction g as [ g | g ]. + exact (w ,, inl g ,, IHn _ _ _ gs f). + exact (w ,, inr g ,, IHn _ _ _ gs f). Defined. Definition reverse_zig_zag_of_length {C : category} {n : ℕ} {x y : C} (gs : zig_zag_of_length n x y) : zig_zag_of_length n y x. Proof. revert x y gs. induction n as [ | n IHn ]. - intros x y gs. exact (z_iso_inv gs). - intros x y gs. induction gs as [ z gs ]. induction gs as [ g gs ]. induction g as [ g | g ]. + exact (post_cons_right_zig_zag_of_length (IHn _ _ gs) g). + exact (post_cons_left_zig_zag_of_length (IHn _ _ gs) g). Defined. Definition reverse_zig_zag {C : category} {x y : C} (gs : zig_zag x y) : zig_zag y x := length_of_zig_zag gs ,, reverse_zig_zag_of_length (pr2 gs). (** 6. Zig-zags in groupoids give morphisms *) Definition zig_zag_of_length_in_grpd_to_mor {G : groupoid} {n : ℕ} {x y : G} (gs : zig_zag_of_length n x y) : x --> y. Proof. revert x y gs. induction n as [ | n IHn ]. - intros x y gs. exact (pr1 gs). - intros x y gs. induction gs as [ z gs ]. induction gs as [ g gs ]. induction g as [ g | g ]. + exact (g · IHn _ _ gs). + exact (inv_from_z_iso (g ,, pr2 G _ _ _) · IHn _ _ gs). Defined. Definition zig_zag_in_grpd_to_mor {G : groupoid} {x y : G} (gs : zig_zag x y) : x --> y := zig_zag_of_length_in_grpd_to_mor (pr2 gs). (** 7. Examples of zig-zag notation *) Local Example zig_zag_notation_1 {C : category} {w x y z : C} (f : w --> x) (g : y --> x) (h : y --> z) : zig_zag w z := w -[ f ]-> x <-[ g ]- y -[ h ]-> z ■. Local Example zig_zag_notation_2 {C : category} {w x y z : C} (f : w --> x) (g : x --> y) (h : z --> y) : zig_zag w z := w -[ f ]-> x -[ g ]-> y <-[ h ]- z ■. UniMath-20231010/UniMath/CategoryTheory/categories/000077500000000000000000000000001451125700300217515ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/categories/CGraph.v000066400000000000000000000057671451125700300233230ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Category of correspondence graphs Marco Maggesi June 2019 ********************************************************************************* *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.Combinatorics.CGraph. Local Open Scope cat. (** ** Precategory of precgraphs. *) Definition precgraph_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor precgraph cgraph_mor. Definition precgraph_precategory_data : precategory_data := make_precategory_data precgraph_precategory_ob_mor cgraph_mor_id (@cgraph_mor_comp). Lemma is_precategory_precgraph : is_precategory precgraph_precategory_data. Proof. apply is_precategory_one_assoc_to_two. apply make_dirprod. repeat apply make_dirprod; cbn. - exact @cgraph_mor_id_left. - exact @cgraph_mor_id_right. - apply @cgraph_mor_comp_assoc. Qed. Definition precgraph_category : precategory := make_precategory precgraph_precategory_data is_precategory_precgraph. (** ** Category of cgraphs. *) Definition cgraph_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor cgraph cgraph_mor. Definition cgraph_precategory_data : precategory_data := make_precategory_data cgraph_precategory_ob_mor (λ G : cgraph, cgraph_mor_id G) (λ G H K : cgraph, @cgraph_mor_comp G H K). Lemma is_precategory_cgraph : is_precategory cgraph_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat apply make_dirprod; cbn. - exact @cgraph_mor_id_left. - exact @cgraph_mor_id_right. - exact @cgraph_mor_comp_assoc. Qed. Definition cgraph_precategory : precategory := make_precategory cgraph_precategory_data is_precategory_cgraph. Lemma has_homsets_graph : has_homsets cgraph_precategory_ob_mor. Proof. intros G H. apply isaset_cgraph_mor. - exact (isaset_node H). - exact (isaset_arc H). Defined. Definition cgraph_category : precategory := make_precategory cgraph_precategory_data is_precategory_cgraph. (** ** Forgetful functor. *) Definition cgraph_forget_map (G : cgraph) : hSet := make_hSet (node G) (isaset_node G). Definition cgraph_forget_data : functor_data cgraph_precategory_ob_mor hset_precategory_ob_mor := @make_functor_data cgraph_category HSET cgraph_forget_map (λ G H : cgraph, onnode). Lemma is_functor_cgraph_forget : @is_functor cgraph_precategory hset_precategory cgraph_forget_data. Proof. apply make_dirprod. - intro x. cbn. apply idpath. - intros x y z. cbn. intros f g. apply idpath. Qed. Definition cgraph_forget : cgraph_category ⟶ HSET := @make_functor cgraph_precategory hset_precategory cgraph_forget_data is_functor_cgraph_forget. UniMath-20231010/UniMath/CategoryTheory/categories/CartesianCubicalSets.v000066400000000000000000000136511451125700300262010ustar00rootroot00000000000000(** **************************************************************************** We define the cartesian cubical sets and show that the interval satisfies axioms B1, B2 and B3 in: A Survey of Constructive Presheaf Models of Univalence (2018), Thierry Coquand https://dl.acm.org/doi/abs/10.1145/3242953.3242962 Contents: - Cartesian cube category ([cartesian_cube_category]) - Binary products in the cartesian cube category ([cartesian_cube_category_binproducts]) - The empty set is a terminal object in the cartesian cube category ([empty_is_terminal_cartesian_cube_category]) - The interval in cartesian cubical sets has two distinct elements (axiom B1) ([interval_cartesian_cubical_sets_two_elements]) - The interval in cartesian cubical sets has decidable equality (axiom B2) ([interval_cartesian_cubical_sets_dec_eq]) - The interval in cartesian cubical sets is tiny (axiom B3) ([interval_cartesian_cubical_sets_is_tiny]) Written by: Elisabeth Bonnevier, 2019 ********************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Presheaf. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.ExponentiationLeftAdjoint. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Local Open Scope stn. (** The cartesian cube category. *) Definition cartesian_cube_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor nat (λ m n : nat, ⟦n⟧ → ⟦m⟧ ⨿ ⟦2⟧). Definition cartesian_cube_precategory_data : precategory_data. Proof. exists cartesian_cube_precategory_ob_mor. split. - intro n. exact (λ i : ⟦n⟧, inl i). - intros l m n f g i. induction (g i) as [j1 | j2]. + exact (f j1). + exact (inr j2). Defined. Definition cartesian_cube_precategory : precategory. Proof. exists cartesian_cube_precategory_data. use make_is_precategory_one_assoc. - intros m n f. apply funextfun; intro i. cbn. now induction (f i). - intros m n g. apply idpath. - intros k l m n f g h. apply funextfun; intro i. cbn. now induction (h i). Defined. Definition cartesian_cube_category : category. Proof. exists cartesian_cube_precategory. intros m n. apply funspace_isaset, isfinite_isaset. apply isfinitecoprod; apply isfinitestn. Defined. (** Binary products in the cartesian cube category. The product ⟦m⟧ × ⟦n⟧ is the sum ⟦m + n⟧. *) Definition cartesian_cube_category_binproducts : BinProducts cartesian_cube_category. Proof. intros m n. use make_BinProduct. - exact (m + n). - exact (λ i : ⟦m⟧, inl (stn_left _ _ i)). - exact (λ i : ⟦n⟧, inl (stn_right _ _ i)). - use make_isBinProduct. + intros l f g. use unique_exists. * intro i. induction (weqfromcoprodofstn_invmap _ _ i) as [x1 | x2]; [exact (f x1) | exact (g x2)]. * cbn. split; apply funextfun; intro i. -- assert (H : weqfromcoprodofstn_invmap _ _ (stn_left m n i) = inl i). { now rewrite <- weqfromcoprodofstn_eq1. } now rewrite H. -- assert (H : weqfromcoprodofstn_invmap _ _ (stn_right m n i) = inr i). { now rewrite <- weqfromcoprodofstn_eq1. } now rewrite H. * intro h. now apply isapropdirprod; apply homset_property. * intros h [H1 H2]. apply funextfun; intros i. rewrite <- (maponpaths h (weqfromcoprodofstn_eq2 _ _ i)). induction (weqfromcoprodofstn_invmap _ _ i) as [x1 | x2]; [now rewrite <- H1 | now rewrite <- H2]. Defined. (** The empty set is terminal in the cartesian cube category. *) Lemma empty_is_terminal_cartesian_cube_category : Terminal cartesian_cube_category. Proof. exists 0. intro n. apply iscontrfunfromempty2. use weqstn0toempty. Defined. Local Close Scope stn. Local Open Scope cat. (** Cartesian cubical sets *) Definition cartesian_cubical_sets : category := PreShv cartesian_cube_category. Local Definition I : cartesian_cubical_sets := yoneda cartesian_cube_category 1. (** The interval in cartesian cubical sets has two distinct elements *) Lemma interval_cartesian_cubical_sets_two_elements : ∏ n : cartesian_cube_category, ∑ f g : ((I : functor _ _) n : hSet), f != g. Proof. intro n. exists (λ _ : stn 1, @inr (stn n) (stn 2) (make_stn 2 0 (idpath _))). exists (λ _ : stn 1, @inr (stn n) (stn 2) (make_stn 2 1 (idpath _))). intro p. apply toforallpaths in p. set (e := p (make_stn 1 0 (idpath _))). apply ii2_injectivity in e. apply (maponpaths pr1) in e. apply (negpaths0sx 0 e). Defined. (** The interval in cartesian cubical sets has decidable equality *) Lemma interval_cartesian_cubical_sets_dec_eq : ∏ (n : cartesian_cube_category), isdeceq ((I : functor _ _) n : hSet). Proof. intro n. use isdeceqweqb. - exact (stn ((n+2) * 1)). - use weqcomp. + exact ((stn 1) → (stn (n+2))). + apply weqffun, weqfromcoprodofstn. + apply weqfromfunstntostn. - apply isdeceqstn. Defined. Definition cartesian_cubical_sets_exponentials : Exponentials (@BinProducts_PreShv cartesian_cube_category). Proof. apply Exponentials_functor_HSET. Defined. Local Definition exp_I : cartesian_cubical_sets ⟶ cartesian_cubical_sets := pr1 (cartesian_cubical_sets_exponentials I). (** The interval in cartesian cubical sets is tiny *) Theorem interval_cartesian_cubical_sets_is_tiny : is_left_adjoint exp_I. Proof. use is_left_adjoint_exp_yoneda. apply cartesian_cube_category_binproducts. Defined. Local Close Scope cat. UniMath-20231010/UniMath/CategoryTheory/categories/CatIsoInserter.v000066400000000000000000000223351451125700300250430ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Section CatIsoInserter. Context {C₁ C₂ : category} (F G : C₁ ⟶ C₂). Definition cat_iso_inserter_disp_cat_ob_mor : disp_cat_ob_mor C₁. Proof. simple refine (_ ,, _). - exact (λ x, z_iso (F x) (G x)). - exact (λ x y hx hy f, hx · #G f = #F f · hy). Defined. Definition cat_iso_inserter_disp_cat_id_comp : disp_cat_id_comp C₁ cat_iso_inserter_disp_cat_ob_mor. Proof. split. - intros x hx ; cbn. rewrite !functor_id. rewrite id_left, id_right. apply idpath. - intros x y z f g hx hy hz hf hg ; cbn in *. rewrite !functor_comp. rewrite !assoc. rewrite hf. rewrite !assoc'. rewrite hg. apply idpath. Qed. Definition cat_iso_inserter_disp_cat_data : disp_cat_data C₁. Proof. simple refine (_ ,, _). - exact cat_iso_inserter_disp_cat_ob_mor. - exact cat_iso_inserter_disp_cat_id_comp. Defined. Definition cat_iso_inserter_disp_cat_axioms : disp_cat_axioms C₁ cat_iso_inserter_disp_cat_data. Proof. repeat split ; intros ; try (apply homset_property). apply isasetaprop. apply homset_property. Qed. Definition cat_iso_inserter_disp_cat : disp_cat C₁. Proof. simple refine (_ ,, _). - exact cat_iso_inserter_disp_cat_data. - exact cat_iso_inserter_disp_cat_axioms. Defined. Definition is_z_iso_disp_cat_iso_inserter {x y : C₁} {f : x --> y} (Hf : is_z_isomorphism f) {hx : cat_iso_inserter_disp_cat x} {hy : cat_iso_inserter_disp_cat y} (hf : hx -->[ f ] hy) : is_z_iso_disp (make_z_iso' f Hf) hf. Proof. simple refine (_ ,, (_ ,, _)) ; cbn in *. - rewrite !functor_on_inv_from_z_iso. refine (!_). use z_iso_inv_on_left. refine (!_). rewrite !assoc'. use z_iso_inv_on_right. exact hf. - apply homset_property. - apply homset_property. Qed. Definition is_univalent_cat_iso_inserter_disp_cat : is_univalent_disp cat_iso_inserter_disp_cat. Proof. intros x y e hx hy ; induction e. use isweqimplimpl. - intro i. use z_iso_eq. refine (_ @ pr1 i @ _) ; cbn. + rewrite functor_id. rewrite id_right. apply idpath. + rewrite functor_id. apply id_left. - use isaset_z_iso. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition cat_iso_inserter : category := total_category cat_iso_inserter_disp_cat. Definition is_univalent_cat_iso_inserter (H₁ : is_univalent C₁) : is_univalent cat_iso_inserter. Proof. use is_univalent_total_category. - exact H₁. - apply is_univalent_cat_iso_inserter_disp_cat. Defined. Definition make_cat_iso_inserter (x : C₁) (f : z_iso (F x) (G x)) : cat_iso_inserter := x ,, f. Definition cat_iso_inserter_mor_path {x y : cat_iso_inserter} (f : pr1 x --> pr1 y) : UU := pr12 x · # G f = # F f · pr12 y. Definition make_cat_iso_inserter_mor {x y : cat_iso_inserter} (f : pr1 x --> pr1 y) (p : cat_iso_inserter_mor_path f) : x --> y := f ,, p. Definition cat_iso_inserter_pr1 : cat_iso_inserter ⟶ C₁ := pr1_category _. End CatIsoInserter. Definition univalent_cat_iso_inserter {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : univalent_category. Proof. use make_univalent_category. - exact (cat_iso_inserter F G). - apply is_univalent_cat_iso_inserter. exact (pr2 C₁). Defined. Definition eq_cat_iso_inserter {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : cat_iso_inserter F G} {f g : x --> y} (p : pr1 f = pr1 g) : f = g. Proof. use subtypePath. { intro. apply homset_property. } exact p. Qed. Definition is_z_iso_cat_iso_inserter {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : cat_iso_inserter F G} (f : x --> y) (Hf : is_z_isomorphism (pr1 f)) : is_z_isomorphism f. Proof. use is_z_iso_total. - exact Hf. - apply is_z_iso_disp_cat_iso_inserter. Defined. Definition z_iso_cat_iso_inserter {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : cat_iso_inserter F G} (f : x --> y) (Hf : is_z_isomorphism (pr1 f)) : z_iso x y. Proof. use make_z_iso'. - exact f. - apply is_z_iso_cat_iso_inserter. exact Hf. Defined. Definition from_is_z_iso_cat_iso_inserter {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : cat_iso_inserter F G} (f : x --> y) (Hf : is_z_isomorphism f) : is_z_isomorphism (pr1 f) := pr2 (functor_on_z_iso (cat_iso_inserter_pr1 F G) (make_z_iso' _ Hf)). Definition from_z_iso_cat_iso_inserter {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : cat_iso_inserter F G} (f : z_iso x y) : z_iso (pr1 x) (pr1 y) := functor_on_z_iso (cat_iso_inserter_pr1 F G) f. Definition cat_iso_inserter_nat_trans_data {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : nat_trans_data (cat_iso_inserter_pr1 F G ∙ F) (cat_iso_inserter_pr1 F G ∙ G) := λ x, pr12 x. Definition cat_iso_inserter_nat_trans_is_nat_trans {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : is_nat_trans _ _ (cat_iso_inserter_nat_trans_data F G). Proof. intros x y f. exact (!(pr2 f)). Qed. Definition cat_iso_inserter_nat_trans {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : cat_iso_inserter_pr1 F G ∙ F ⟹ cat_iso_inserter_pr1 F G ∙ G. Proof. use make_nat_trans. - exact (cat_iso_inserter_nat_trans_data F G). - exact (cat_iso_inserter_nat_trans_is_nat_trans F G). Defined. Definition cat_iso_inserter_nat_iso {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : nat_z_iso (cat_iso_inserter_pr1 F G ∙ F) (cat_iso_inserter_pr1 F G ∙ G). Proof. use make_nat_z_iso. - exact (cat_iso_inserter_nat_trans F G). - intro x. apply z_iso_is_z_isomorphism. Defined. Section CatIsoInserterFunctor. Context {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (H : C₁ ⟶ C₂) (α : nat_z_iso (H ∙ F) (H ∙ G)). Definition functor_to_cat_iso_inserter_data : functor_data C₁ (cat_iso_inserter F G). Proof. use make_functor_data. - exact (λ x, H x ,, nat_z_iso_pointwise_z_iso α x). - refine (λ x y f, # H f ,, _). abstract (cbn ; exact (!(nat_trans_ax α _ _ f))). Defined. Definition functor_to_cat_iso_inserter_is_functor : is_functor functor_to_cat_iso_inserter_data. Proof. split. - intros x. use eq_cat_iso_inserter ; cbn. apply functor_id. - intros x y z f g. use eq_cat_iso_inserter ; cbn. apply functor_comp. Qed. Definition functor_to_cat_iso_inserter : C₁ ⟶ cat_iso_inserter F G. Proof. use make_functor. - exact functor_to_cat_iso_inserter_data. - exact functor_to_cat_iso_inserter_is_functor. Defined. Definition functor_to_cat_iso_inserter_pr1 : functor_to_cat_iso_inserter ∙ cat_iso_inserter_pr1 F G ⟹ H. Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition functor_to_cat_iso_inserter_pr1_nat_z_iso : nat_z_iso (functor_to_cat_iso_inserter ∙ cat_iso_inserter_pr1 F G) H. Proof. use make_nat_z_iso. - exact functor_to_cat_iso_inserter_pr1. - intro x. apply is_z_isomorphism_identity. Defined. End CatIsoInserterFunctor. Definition nat_trans_to_cat_iso_inserter {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} {H₁ H₂ : C₁ ⟶ cat_iso_inserter F G} (α : H₁ ∙ cat_iso_inserter_pr1 F G ⟹ H₂ ∙ cat_iso_inserter_pr1 F G) (p : ∏ (x : C₁), pr12 (H₁ x) · # G (α x) = # F (α x) · pr12 (H₂ x)) : H₁ ⟹ H₂. Proof. use make_nat_trans. - exact (λ x, α x ,, p x). - abstract (intros x y f ; use eq_cat_iso_inserter ; cbn ; exact (nat_trans_ax α _ _ f)). Defined. UniMath-20231010/UniMath/CategoryTheory/categories/CategoryOfSetCategories.v000066400000000000000000000047121451125700300266700ustar00rootroot00000000000000(****************************************************************************************** The category of strict categories Strict categories are the categories in which the type of objects forms a set. As such, the type of functors between them is a set as well, and this allows us to construct a category whose objects are strict categories and whose morphisms are functors. ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Definition precat_ob_mor_of_setcategory : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact setcategory. - exact (λ C₁ C₂, C₁ ⟶ C₂). Defined. Definition precat_data_of_setcategory : precategory_data. Proof. use make_precategory_data. - exact precat_ob_mor_of_setcategory. - exact (λ C, functor_identity _). - exact (λ C₁ C₂ C₃ F G, F ∙ G). Defined. Definition is_precategory_of_setcategory : is_precategory precat_data_of_setcategory. Proof. use make_is_precategory_one_assoc. - intros C₁ C₂ F. use functor_eq. { apply homset_property. } use functor_data_eq ; cbn. + intro ; apply idpath. + intros x y f ; cbn. apply idpath. - intros C₁ C₂ F. use functor_eq. { apply homset_property. } use functor_data_eq ; cbn. + intro ; apply idpath. + intros x y f ; cbn. apply idpath. - intros C₁ C₂ C₃ C₄ F G H. use functor_eq. { apply homset_property. } use functor_data_eq ; cbn. + intro ; apply idpath. + intros x y f ; cbn. apply idpath. Qed. Definition precat_of_setcategory : precategory. Proof. use make_precategory. - exact precat_data_of_setcategory. - exact is_precategory_of_setcategory. Defined. Definition has_homsets_cat_of_setcategory : has_homsets precat_of_setcategory. Proof. intros C₁ C₂. use functor_isaset. - apply homset_property. - apply C₂. Qed. Definition cat_of_setcategory : category. Proof. use make_category. - exact precat_of_setcategory. - exact has_homsets_cat_of_setcategory. Defined. UniMath-20231010/UniMath/CategoryTheory/categories/CoEilenbergMoore.v000066400000000000000000000212711451125700300253230ustar00rootroot00000000000000(****************************************************************************** The Eilenberg-Moore category dualized (after the file [EilenbergMoore.v]) We define Eilenberg-Moore categories of comonads. The construction in this file uses dialgebras and full subcategories which makes it easy to prove univalence. Contents 1. The definition 2. The univalence 3. Constructors and projections 4. The universal property 4.1 The cone 4.2 The universal property for functors 4.3 The universal property for natural transformations ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Monads.Comonads. Local Open Scope cat. Section CoEilenbergMooreCategory. Context {C : category} (m : Comonad C). (** 1. The definition *) Definition co_eilenberg_moore_cat_pred (f : dialgebra (functor_identity C) m) : hProp. Proof. use make_hProp. - exact (pr2 f · ε m _ = identity _ × pr2 f · δ m (pr1 f) = pr2 f · # m (pr2 f)). - apply isapropdirprod ; apply homset_property. Defined. Definition co_eilenberg_moore_cat : category := full_sub_category (dialgebra (functor_identity _) m) co_eilenberg_moore_cat_pred. (** 2. The univalence *) Definition is_univalent_co_eilenberg_moore_cat (HC : is_univalent C) : is_univalent co_eilenberg_moore_cat. Proof. apply is_univalent_full_sub_category. apply is_univalent_dialgebra. exact HC. Defined. (** 3. Constructors and projections *) Definition make_ob_co_eilenberg_moore (x : C) (f : x --> m x) (p : f · ε m x = identity x) (q : f · δ m x = f · # m f) : co_eilenberg_moore_cat := (x ,, _) ,, (p ,, q). Definition make_mor_co_eilenberg_moore {x y : co_eilenberg_moore_cat} (f : pr11 x --> pr11 y) (p : pr21 x · # m f = f · pr21 y) : x --> y := (f ,, p) ,, tt. Definition eq_mor_co_eilenberg_moore {x y : co_eilenberg_moore_cat} (f g : x --> y) (p : pr11 f = pr11 g) : f = g. Proof. use subtypePath. { intro ; apply isapropunit. } use subtypePath. { intro ; apply homset_property. } exact p. Qed. Definition is_z_iso_co_eilenberg_moore {x y : co_eilenberg_moore_cat} (f : x --> y) (Hf : is_z_isomorphism (pr11 f)) : is_z_isomorphism f. Proof. pose (H := make_z_iso _ _ Hf). use make_is_z_isomorphism. - use make_mor_co_eilenberg_moore. + exact (inv_from_z_iso H). + apply (is_z_iso_disp_dialgebra _ _ Hf (pr21 f)). - split. + abstract (use eq_mor_co_eilenberg_moore ; cbn ; apply (z_iso_inv_after_z_iso H)). + abstract (use eq_mor_co_eilenberg_moore ; cbn ; apply (z_iso_after_z_iso_inv H)). Defined. End CoEilenbergMooreCategory. Definition co_eilenberg_moore_univalent_cat (C : univalent_category) (m : Comonad C) : univalent_category. Proof. use make_univalent_category. - exact (co_eilenberg_moore_cat m). - exact (is_univalent_co_eilenberg_moore_cat m (pr2 C)). Defined. Definition ob_of_co_eilenberg_moore_ob {C : category} {m : Comonad C} (h : co_eilenberg_moore_cat m) : C := pr11 h. Definition mor_of_co_eilenberg_moore_ob {C : category} {m : Comonad C} (h : co_eilenberg_moore_cat m) : ob_of_co_eilenberg_moore_ob h --> m (ob_of_co_eilenberg_moore_ob h) := pr21 h. Definition co_eilenberg_moore_ob_unit {C : category} {m : Comonad C} (h : co_eilenberg_moore_cat m) : mor_of_co_eilenberg_moore_ob h · ε m (ob_of_co_eilenberg_moore_ob h) = identity _ := pr12 h. Definition co_eilenberg_moore_ob_mult {C : category} {m : Comonad C} (h : co_eilenberg_moore_cat m) : mor_of_co_eilenberg_moore_ob h · δ m _ = mor_of_co_eilenberg_moore_ob h · # m (mor_of_co_eilenberg_moore_ob h) := pr22 h. Definition mor_of_co_eilenberg_moore_mor {C : category} {m : Comonad C} {x y : co_eilenberg_moore_cat m} (f : x --> y) : ob_of_co_eilenberg_moore_ob x --> ob_of_co_eilenberg_moore_ob y := pr11 f. Definition eq_of_co_eilenberg_moore_mor {C : category} {m : Comonad C} {x y : co_eilenberg_moore_cat m} (f : x --> y) : mor_of_co_eilenberg_moore_ob x · # m (pr11 f) = pr11 f · mor_of_co_eilenberg_moore_ob y := pr21 f. (** 4. The universal property *) (** 4.1 The cone *) Definition co_eilenberg_moore_pr {C : category} (m : Comonad C) : co_eilenberg_moore_cat m ⟶ C. Proof. refine (functor_composite _ _). - apply full_sub_category_pr. - apply dialgebra_pr1. Defined. Definition co_eilenberg_moore_nat_trans {C : category} (m : Comonad C) : functor_identity _ ∙ co_eilenberg_moore_pr m ⟹ co_eilenberg_moore_pr m ∙ m. Proof. use make_nat_trans. - exact (λ f, mor_of_co_eilenberg_moore_ob f). - abstract (intros f₁ f₂ α ; cbn ; exact (!(eq_of_co_eilenberg_moore_mor α))). Defined. (** 4.2 The universal property for functors *) Section CoEilenbergMooreUMP1. Context {C₁ C₂ : category} (m : Comonad C₂) (F : C₁ ⟶ C₂) (α : functor_identity _ ∙ F ⟹ F ∙ m) (αε : ∏ (x : C₁), α x · ε m (F x) = identity _) (αδ : ∏ (x : C₁), α x · # m (α x) = α x · δ m (F x)). Definition functor_to_co_eilenberg_moore_cat_data : functor_data C₁ (co_eilenberg_moore_cat m). Proof. use make_functor_data. - intro x. use make_ob_co_eilenberg_moore. + exact (F x). + exact (α x). + exact (αε x). + exact (!(αδ x)). - intros x y f. use make_mor_co_eilenberg_moore. + exact (#F f). + exact (!(nat_trans_ax α _ _ f)). Defined. Definition functor_to_co_eilenberg_moore_is_functor : is_functor functor_to_co_eilenberg_moore_cat_data. Proof. split. - intro x. use eq_mor_co_eilenberg_moore ; cbn. apply functor_id. - intros x y z f g. use eq_mor_co_eilenberg_moore ; cbn. apply functor_comp. Qed. Definition functor_to_co_eilenberg_moore_cat : C₁ ⟶ co_eilenberg_moore_cat m. Proof. use make_functor. - exact functor_to_co_eilenberg_moore_cat_data. - exact functor_to_co_eilenberg_moore_is_functor. Defined. Definition functor_to_co_eilenberg_moore_cat_pr : functor_to_co_eilenberg_moore_cat ∙ co_eilenberg_moore_pr m ⟹ F. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition functor_to_co_eilenberg_moore_cat_pr_is_nat_z_iso : is_nat_z_iso functor_to_co_eilenberg_moore_cat_pr. Proof. intro. apply identity_is_z_iso. Defined. Definition functor_to_co_eilenberg_moore_cat_pr_nat_z_iso : nat_z_iso (functor_to_co_eilenberg_moore_cat ∙ co_eilenberg_moore_pr m) F. Proof. use make_nat_z_iso. - exact functor_to_co_eilenberg_moore_cat_pr. - exact functor_to_co_eilenberg_moore_cat_pr_is_nat_z_iso. Defined. End CoEilenbergMooreUMP1. (** 4.3 The universal property for natural transformations *) Definition nat_trans_to_co_eilenberg_moore_cat {C₁ C₂ : category} (m : Comonad C₂) (F₁ F₂ : C₁ ⟶ co_eilenberg_moore_cat m) (α : F₁ ∙ co_eilenberg_moore_pr m ⟹ F₂ ∙ co_eilenberg_moore_pr m) (p : ∏ (x : C₁), mor_of_co_eilenberg_moore_ob (F₁ x) · # m (α x) = α x · mor_of_co_eilenberg_moore_ob (F₂ x)) : F₁ ⟹ F₂. Proof. use make_nat_trans. - intro x. use make_mor_co_eilenberg_moore. + exact (α x). + exact (p x). - abstract (intros x y f ; use eq_mor_co_eilenberg_moore ; cbn ; exact (nat_trans_ax α _ _ f)). Defined. UniMath-20231010/UniMath/CategoryTheory/categories/Dialgebras.v000066400000000000000000000672241451125700300242100ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Projection. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Local Open Scope cat. Section Dialgebra. Context {C₁ C₂ : category} (F G : C₁ ⟶ C₂). Definition dialgebra_disp_cat : disp_cat C₁. Proof. use disp_struct. - exact (λ x, F x --> G x). - exact (λ x y hx hy f, hx · #G f = #F f · hy). - intros. apply C₂. - abstract (intros x hx ; cbn; rewrite !functor_id; rewrite id_left, id_right; apply idpath). - abstract (intros x y z f g hx hy hz hf hg ; cbn in *; rewrite !functor_comp; rewrite !assoc; rewrite hf; rewrite !assoc'; rewrite hg; apply idpath). Defined. Lemma is_locally_propositional_dialgebra_disp_cat : locally_propositional dialgebra_disp_cat. Proof. red; intros; apply C₂. Qed. Definition is_z_iso_disp_dialgebra {x y : C₁} {f : x --> y} (Hf : is_z_isomorphism f) {hx : dialgebra_disp_cat x} {hy : dialgebra_disp_cat y} (hf : hx -->[ f ] hy) : is_z_iso_disp (make_z_iso' f Hf) hf. Proof. simple refine (_ ,, (_ ,, _)) ; cbn in *. - rewrite !functor_on_inv_from_z_iso. refine (!_). use z_iso_inv_on_left. refine (!_). rewrite !assoc'. use z_iso_inv_on_right. exact hf. - apply homset_property. - apply homset_property. Qed. Corollary groupoidal_dialgebra_disp_cat : groupoidal_disp_cat dialgebra_disp_cat. Proof. intro; intros; apply is_z_iso_disp_dialgebra. Defined. Definition is_univalent_dialgebra_disp_cat : is_univalent_disp dialgebra_disp_cat. Proof. intros x y e hx hy ; induction e. use isweqimplimpl. - intro i. refine (_ @ pr1 i @ _) ; cbn. + rewrite functor_id. rewrite id_right. apply idpath. + rewrite functor_id. apply id_left. - apply homset_property. - use isaproptotal2. + intro. apply isaprop_is_z_iso_disp. + intros. apply homset_property. Qed. Definition dialgebra : category := total_category dialgebra_disp_cat. Definition is_univalent_dialgebra (H₁ : is_univalent C₁) : is_univalent dialgebra. Proof. use is_univalent_total_category. - exact H₁. - apply is_univalent_dialgebra_disp_cat. Defined. Definition make_dialgebra (x : C₁) (f : F x --> G x) : dialgebra := x ,, f. Definition dialgebra_mor_path {x y : dialgebra} (f : pr1 x --> pr1 y) : UU := pr2 x · # G f = # F f · pr2 y. Definition make_dialgebra_mor {x y : dialgebra} (f : pr1 x --> pr1 y) (p : dialgebra_mor_path f) : x --> y := f ,, p. Definition dialgebra_pr1 : dialgebra ⟶ C₁ := pr1_category _. (** Equivalence between nat. transformations and functors into the dialgebras This is a simplification of the exercise 4 on p.47 in the 2nd edition of MacLane's book. Appears in a less streamlined form in the CPP'22 paper by Ahrens, Matthes and Mörtberg. *) (** This direction could also be spelt out more elementarily without sections. *) Definition nat_trans_to_section (η: F ⟹ G): @section_disp C₁ dialgebra_disp_cat. Proof. use tpair. - use tpair. + intro c. exact (η c). + intros c c' f. red. unfold dialgebra_disp_cat. hnf. apply pathsinv0, nat_trans_ax. - split. + intro c. apply C₂. + intros c1 c2 c3 f f'. apply C₂. Defined. Definition nat_trans_to_functor (η: F ⟹ G): C₁ ⟶ dialgebra := @section_functor C₁ dialgebra_disp_cat (nat_trans_to_section η). Definition nat_trans_to_functor_cor (η: F ⟹ G): functor_composite (nat_trans_to_functor η) dialgebra_pr1 = functor_identity C₁. Proof. apply from_section_functor. Defined. (** the backwards direction essentially uses the sections - already for the statements *) Definition section_to_nat_trans: @section_disp C₁ dialgebra_disp_cat -> F ⟹ G. Proof. intro sd. induction sd as [[sdob sdmor] [sdid sdcomp]]. use make_nat_trans. - intro c. exact (sdob c). - intros c c' f. apply pathsinv0. exact (sdmor c c' f). Defined. Local Lemma roundtrip1_with_sections (η: F ⟹ G): section_to_nat_trans (nat_trans_to_section η) = η. Proof. apply nat_trans_eq; [ apply C₂ |]. intro c. apply idpath. Qed. Local Lemma roundtrip2_with_sections (sd: @section_disp C₁ dialgebra_disp_cat): nat_trans_to_section (section_to_nat_trans sd) = sd. Proof. induction sd as [[sdob sdmor] [sdid sdcomp]]. unfold nat_trans_to_section, section_to_nat_trans. cbn. use total2_paths_f; simpl. - use total2_paths_f; simpl. + apply idpath. + cbn. do 3 (apply funextsec; intro). apply pathsinv0inv0. - match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + apply impred. intro c. apply hlevelntosn. apply C₂. + do 5 (apply impred; intro). apply hlevelntosn. apply C₂. Qed. End Dialgebra. Definition univalent_dialgebra {C₁ C₂ : univalent_category} (F G : C₁ ⟶ C₂) : univalent_category. Proof. use make_univalent_category. - exact (dialgebra F G). - apply is_univalent_dialgebra. exact (pr2 C₁). Defined. Definition eq_dialgebra {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : dialgebra F G} {f g : x --> y} (p : pr1 f = pr1 g) : f = g. Proof. use subtypePath. { intro. apply homset_property. } exact p. Qed. Definition is_z_iso_dialgebra {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : dialgebra F G} (f : x --> y) (Hf : is_z_isomorphism (pr1 f)) : is_z_isomorphism f. Proof. use is_z_iso_total. - exact Hf. - apply is_z_iso_disp_dialgebra. Defined. Definition z_iso_dialgebra {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : dialgebra F G} (f : x --> y) (Hf : is_z_isomorphism (pr1 f)) : z_iso x y. Proof. use make_z_iso'. - exact f. - apply is_z_iso_dialgebra. exact Hf. Defined. Definition from_is_z_iso_dialgebra {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : dialgebra F G} (f : x --> y) (Hf : is_z_isomorphism f) : is_z_isomorphism (pr1 f) := pr2 (functor_on_z_iso (dialgebra_pr1 F G) (make_z_iso' _ Hf)). Definition from_z_iso_dialgebra {C₁ C₂ : category} {F G : C₁ ⟶ C₂} {x y : dialgebra F G} (f : z_iso x y) : z_iso (pr1 x) (pr1 y) := functor_on_z_iso (dialgebra_pr1 F G) f. Definition dialgebra_nat_trans_data {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : nat_trans_data (dialgebra_pr1 F G ∙ F) (dialgebra_pr1 F G ∙ G) := λ x, pr2 x. Definition dialgebra_nat_trans_is_nat_trans {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : is_nat_trans _ _ (dialgebra_nat_trans_data F G). Proof. intros x y f. exact (!(pr2 f)). Qed. Definition dialgebra_nat_trans {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : dialgebra_pr1 F G ∙ F ⟹ dialgebra_pr1 F G ∙ G. Proof. use make_nat_trans. - exact (dialgebra_nat_trans_data F G). - exact (dialgebra_nat_trans_is_nat_trans F G). Defined. Definition nat_trans_to_dialgebra_lifting {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : functor_lifting (dialgebra_disp_cat F G) K. Proof. use tpair. - use tpair. + exact (λ x, α x). + intros x y f. exact (!(nat_trans_ax α _ _ f)). - split; intros; apply C₃. Defined. Definition nat_trans_to_dialgebra {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : C₁ ⟶ dialgebra F G := lifted_functor (nat_trans_to_dialgebra_lifting K α). (** [nat_trans_to_functor] above is essentially a specialization of this construction *) Definition nat_trans_to_dialgebra_pr1 {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : nat_trans_to_dialgebra K α ∙ dialgebra_pr1 F G ⟹ K. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition nat_trans_to_dialgebra_pr1_nat_z_iso {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : nat_z_iso (nat_trans_to_dialgebra K α ∙ dialgebra_pr1 F G) K. Proof. use make_nat_z_iso. - exact (nat_trans_to_dialgebra_pr1 K α). - intro. apply identity_is_z_iso. Defined. (** a more generic way of obtaining it: *) Definition nat_trans_to_dialgebra_pr1_alt_nat_z_iso {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : nat_z_iso (nat_trans_to_dialgebra K α ∙ dialgebra_pr1 F G) K. Proof. apply (nat_z_iso_from_z_iso C₂). exact (idtoiso (C:=[C₁, C₂]) (from_lifted_functor (nat_trans_to_dialgebra_lifting K α))). Defined. Definition nat_trans_to_dialgebra_pr1_alt {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : nat_trans_to_dialgebra K α ∙ dialgebra_pr1 F G ⟹ K. Proof. exact (nat_trans_to_dialgebra_pr1_alt_nat_z_iso K α). Defined. Definition dialgebra_lifting_to_nat_trans {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) : functor_lifting (dialgebra_disp_cat F G) K -> K ∙ F ⟹ K ∙ G. Proof. intro fl. induction fl as [[sdob sdmor] _]. use make_nat_trans. - intro c. exact (sdob c). - intros c c' f. apply pathsinv0. exact (sdmor c c' f). Defined. (** [section_to_nat_trans] above is essentially a specialization of this construction *) (** we obtain [dialgebra_nat_trans] as an instance of this construction *) Definition dialgebra_nat_trans_alt {C₁ C₂ : category} (F G : C₁ ⟶ C₂) : dialgebra_pr1 F G ∙ F ⟹ dialgebra_pr1 F G ∙ G. Proof. apply dialgebra_lifting_to_nat_trans. use tpair. - use tpair. + exact (λ x, pr2 x). + intros x y f. cbn. exact (pr2 f). - split; intros; apply C₂. Defined. Local Lemma roundtrip1_with_liftings {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (α : K ∙ F ⟹ K ∙ G) : dialgebra_lifting_to_nat_trans K (nat_trans_to_dialgebra_lifting K α) = α. Proof. apply nat_trans_eq; [ apply C₃ |]. intro c. apply idpath. Qed. Local Lemma roundtrip2_with_liftings {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K : C₁ ⟶ C₂) (fl : functor_lifting (dialgebra_disp_cat F G) K) : nat_trans_to_dialgebra_lifting K (dialgebra_lifting_to_nat_trans K fl) = fl. Proof. induction fl as [[sdob sdmor] [sdid sdcomp]]. unfold nat_trans_to_dialgebra_lifting, dialgebra_lifting_to_nat_trans. cbn. use total2_paths_f; simpl. - use total2_paths_f; simpl. + apply idpath. + cbn. do 3 (apply funextsec; intro). apply pathsinv0inv0. - match goal with |- @paths ?ID _ _ => set (goaltype := ID); simpl in goaltype end. assert (Hprop: isaprop goaltype). 2: { apply Hprop. } apply isapropdirprod. + apply impred. intro c. apply hlevelntosn. apply C₃. + do 5 (apply impred; intro). apply hlevelntosn. apply C₃. Qed. Definition build_nat_trans_to_dialgebra {C₁ C₂ C₃ : category} {F G : C₂ ⟶ C₃} (K₁ K₂ : C₁ ⟶ dialgebra F G) (α : K₁ ∙ dialgebra_pr1 F G ⟹ K₂ ∙ dialgebra_pr1 F G) (p : ∏ (x : C₁), pr2 (K₁ x) · # G (α x) = # F (α x) · pr2 (K₂ x)) : K₁ ⟹ K₂. Proof. use make_nat_trans. - exact (λ x, α x ,, p x). - abstract (intros x₁ x₂ f ; use eq_dialgebra ; exact (nat_trans_ax α _ _ f)). Defined. Section DialgebraEquivalence. Context {C₁ C₁' C₂ C₂' : category} {F G : C₁ ⟶ C₁'} {F' G' : C₂ ⟶ C₂'} {L : C₁ ⟶ C₂} (HL : adj_equivalence_of_cats L) {L' : C₁' ⟶ C₂'} (HL' : adj_equivalence_of_cats L') (α : nat_z_iso (L ∙ F') (F ∙ L')) (β : nat_z_iso (L ∙ G') (G ∙ L')). Let R : C₂ ⟶ C₁ := right_adjoint HL. Let R' : C₂' ⟶ C₁' := right_adjoint HL'. Let η : nat_z_iso (functor_identity _) (L ∙ R) := unit_nat_z_iso_from_adj_equivalence_of_cats HL. Let η' : nat_z_iso (functor_identity _) (L' ∙ R') := unit_nat_z_iso_from_adj_equivalence_of_cats HL'. Let ε : nat_z_iso (R ∙ L) (functor_identity _) := counit_nat_z_iso_from_adj_equivalence_of_cats HL. Let ε' : nat_z_iso (R' ∙ L') (functor_identity _) := counit_nat_z_iso_from_adj_equivalence_of_cats HL'. Let ηinv : nat_z_iso (L ∙ R) (functor_identity _) := nat_z_iso_inv η. Let ηinv' : nat_z_iso (L' ∙ R') (functor_identity _) := nat_z_iso_inv η'. Let εinv : nat_z_iso (functor_identity _) (R ∙ L) := nat_z_iso_inv ε. Let εinv' : nat_z_iso (functor_identity _) (R' ∙ L') := nat_z_iso_inv ε'. Let αinv : nat_z_iso (F ∙ L') (L ∙ F') := nat_z_iso_inv α. Let βinv : nat_z_iso (G ∙ L') (L ∙ G') := nat_z_iso_inv β. Definition dialgebra_equivalence_nat_trans_data : nat_trans_data (dialgebra_pr1 F G ∙ L ∙ F') (dialgebra_pr1 F G ∙ L ∙ G') := λ x, α (pr1 x) · #L' (pr2 x) · βinv (pr1 x). Definition dialgebra_equivalence_is_nat_trans : is_nat_trans _ _ dialgebra_equivalence_nat_trans_data. Proof. intros x y f ; cbn. unfold dialgebra_equivalence_nat_trans_data. rewrite !assoc. etrans. { do 2 apply maponpaths_2. apply (nat_trans_ax α). } rewrite !assoc'. apply maponpaths. cbn. rewrite !assoc. rewrite <- (functor_comp L'). etrans. { apply maponpaths_2. apply maponpaths. exact (!(pr2 f)). } rewrite (functor_comp L'). rewrite !assoc'. apply maponpaths. apply (nat_trans_ax βinv). Qed. Definition dialgebra_equivalence_nat_trans : dialgebra_pr1 F G ∙ L ∙ F' ⟹ dialgebra_pr1 F G ∙ L ∙ G'. Proof. use make_nat_trans. - exact dialgebra_equivalence_nat_trans_data. - exact dialgebra_equivalence_is_nat_trans. Defined. Definition dialgebra_equivalence_of_cats_functor : dialgebra F G ⟶ dialgebra F' G' := nat_trans_to_dialgebra (dialgebra_pr1 _ _ ∙ L) dialgebra_equivalence_nat_trans. Definition dialgebra_equivalence_of_cats_inv_nat_trans_data : nat_trans_data (dialgebra_pr1 F' G' ∙ R ∙ F) (dialgebra_pr1 F' G' ∙ R ∙ G) := λ x, η' (F (R (pr1 x))) · #R' (αinv _ · #F' (ε _) · pr2 x · #G' (εinv _) · β _) · ηinv' _. Definition dialgebra_equivalence_of_cats_inv_is_nat_trans : is_nat_trans _ _ dialgebra_equivalence_of_cats_inv_nat_trans_data. Proof. intros x₁ x₂ f. cbn -[η] ; unfold dialgebra_equivalence_of_cats_inv_nat_trans_data. rewrite !functor_comp. rewrite !assoc. etrans. { do 6 apply maponpaths_2. apply (nat_trans_ax η'). } rewrite !assoc'. apply maponpaths. cbn -[η αinv εinv ε ηinv']. rewrite !assoc. etrans. { do 5 apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply (nat_trans_ax αinv). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. cbn -[η αinv εinv ε ηinv']. rewrite !assoc. etrans. { do 4 apply maponpaths_2. rewrite <- !functor_comp. do 2 apply maponpaths. apply (nat_trans_ax ε). } rewrite !functor_comp. rewrite !assoc'. apply maponpaths. cbn -[η αinv εinv ηinv']. rewrite !assoc. etrans. { do 3 apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. exact (!(pr2 f)). } rewrite !functor_comp. rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { do 2 apply maponpaths_2. rewrite <- !functor_comp. do 2 apply maponpaths. apply (nat_trans_ax εinv). } rewrite !functor_comp. rewrite !assoc'. apply maponpaths. cbn -[η αinv εinv ηinv']. rewrite !assoc. etrans. { apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply (nat_trans_ax β). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. apply (nat_trans_ax ηinv'). Qed. Definition dialgebra_equivalence_of_cats_inv_nat_trans : dialgebra_pr1 F' G' ∙ R ∙ F ⟹ dialgebra_pr1 F' G' ∙ R ∙ G. Proof. use make_nat_trans. - exact dialgebra_equivalence_of_cats_inv_nat_trans_data. - exact dialgebra_equivalence_of_cats_inv_is_nat_trans. Defined. Definition dialgebra_equivalence_of_cats_inv_functor : dialgebra F' G' ⟶ dialgebra F G := nat_trans_to_dialgebra (dialgebra_pr1 _ _ ∙ R) dialgebra_equivalence_of_cats_inv_nat_trans. Definition dialgebra_equivalence_of_cats_unit_data_path (x : dialgebra F G) : @dialgebra_mor_path _ _ _ _ _ ((dialgebra_equivalence_of_cats_functor ∙ dialgebra_equivalence_of_cats_inv_functor) x) (η (pr1 x)). Proof. unfold dialgebra_mor_path. cbn -[η] ; unfold dialgebra_equivalence_of_cats_inv_nat_trans_data. unfold dialgebra_equivalence_nat_trans_data. cbn -[η ε η' ε' ηinv εinv ηinv' εinv' αinv βinv]. rewrite !assoc'. refine (!_). assert (H₁ : εinv (L (pr1 x)) = #L (η (pr1 x))). { refine (!(id_left _) @ _). refine (!_). apply (z_iso_inv_on_left _ _ _ _ (_,,dirprod_pr2 (pr2 HL) (L (pr1 x)))). exact (!(triangle_id_left_ad (pr21 HL) (pr1 x))). } etrans. { do 2 apply maponpaths. apply maponpaths_2. do 5 apply maponpaths. etrans. { apply maponpaths. apply maponpaths_2. apply maponpaths. exact H₁. } etrans. { apply maponpaths. apply (nat_trans_ax β). } cbn. rewrite !assoc. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,pr2 β (pr1 x))). } apply id_left. } clear H₁. assert (H₂ : ε (L (pr1 x)) = #L (ηinv (pr1 x))). { cbn -[ε]. etrans. 2: { apply pathsinv0, (functor_on_inv_from_z_iso L (_,,dirprod_pr1 (pr2 HL) (pr1 x))). } refine (_ @ id_right _). refine (!_). apply z_iso_inv_on_right. exact (!(triangle_id_left_ad (pr21 HL) (pr1 x))). } etrans. { do 2 apply maponpaths. apply maponpaths_2. apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. etrans. { apply maponpaths_2. do 2 apply maponpaths. exact H₂. } rewrite assoc'. etrans. { apply maponpaths. apply (nat_trans_ax α). } rewrite !assoc. cbn -[ηinv]. etrans. { apply cancel_postcomposition. apply (z_iso_after_z_iso_inv (_,,pr2 α (R (L (pr1 x))))). } apply id_left. } rewrite !functor_comp. etrans. { apply maponpaths. rewrite !assoc. do 3 apply maponpaths_2. apply (!(nat_trans_ax η' _ _ _)). } cbn -[η ε η' ε' ηinv εinv ηinv' εinv']. rewrite !assoc. rewrite <- functor_comp. etrans. { do 3 apply maponpaths_2. cbn -[η η']. etrans. { apply maponpaths_2. apply maponpaths. exact (z_iso_inv_after_z_iso (make_z_iso' _ _)). } rewrite functor_id. apply id_left. } etrans. { do 2 apply maponpaths_2. refine (!_). apply (nat_trans_ax η'). } rewrite !assoc'. apply maponpaths. rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax η'). } rewrite !assoc'. etrans. { apply maponpaths. cbn -[η']. exact (z_iso_inv_after_z_iso (make_z_iso' _ _)). } apply id_right. Qed. Definition dialgebra_equivalence_of_cats_unit_data : nat_trans_data (functor_identity _) (dialgebra_equivalence_of_cats_functor ∙ dialgebra_equivalence_of_cats_inv_functor). Proof. simple refine (λ x, make_dialgebra_mor _ _ _ _). - exact (η (pr1 x)). - exact (dialgebra_equivalence_of_cats_unit_data_path x). Defined. Definition dialgebra_equivalence_of_cats_unit_is_nat_trans : is_nat_trans _ _ dialgebra_equivalence_of_cats_unit_data. Proof. intros x₁ x₂ f. use eq_dialgebra ; cbn. apply (nat_trans_ax η). Qed. Definition dialgebra_equivalence_of_cats_unit : functor_identity _ ⟹ dialgebra_equivalence_of_cats_functor ∙ dialgebra_equivalence_of_cats_inv_functor. Proof. use make_nat_trans. - exact dialgebra_equivalence_of_cats_unit_data. - exact dialgebra_equivalence_of_cats_unit_is_nat_trans. Defined. Definition dialgebra_equivalence_of_cats_counit_path (x : dialgebra F' G') : @dialgebra_mor_path _ _ _ _ ((dialgebra_equivalence_of_cats_inv_functor ∙ dialgebra_equivalence_of_cats_functor) x) _ (ε (pr1 x)). Proof. unfold dialgebra_mor_path. cbn -[ε] ; unfold dialgebra_equivalence_of_cats_inv_nat_trans_data. unfold dialgebra_equivalence_nat_trans_data. cbn -[η ε η' ε' ηinv εinv ηinv' εinv' αinv βinv]. rewrite !(functor_comp L'). rewrite !assoc'. assert (# L' (ηinv' (G (R (pr1 x)))) = ε' (L' (G (R (pr1 x))))) as H₁. { refine (!(id_right _) @ !_). unfold ηinv' ; cbn -[η' ε']. etrans. 2: { apply cancel_postcomposition, pathsinv0, (functor_on_inv_from_z_iso L' (_,,pr2 η' (G (R (pr1 x))))). } refine (!_). use z_iso_inv_on_right. exact (!(triangle_id_left_ad (pr21 HL') (G (R (pr1 x))))). } etrans. { do 3 apply maponpaths. apply maponpaths_2. exact H₁. } clear H₁. etrans. { do 2 apply maponpaths. rewrite !assoc. do 2 apply maponpaths_2. apply (nat_trans_ax ε'). } cbn -[η ε η' ε' ηinv εinv ηinv' εinv' αinv βinv]. etrans. { apply maponpaths. rewrite !assoc. do 7 apply maponpaths_2. exact (triangle_id_left_ad (pr21 HL') (F (R (pr1 x)))). } rewrite id_left. rewrite !assoc. etrans. { do 6 apply maponpaths_2. apply (z_iso_inv_after_z_iso (make_z_iso' _ _)). } rewrite id_left. rewrite !assoc'. apply maponpaths. refine (_ @ id_right _). apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. apply (z_iso_inv_after_z_iso (make_z_iso' _ _)). } rewrite id_left. rewrite <- functor_comp. etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (make_z_iso' _ _)). } apply functor_id. Qed. Definition dialgebra_equivalence_of_cats_counit_data : nat_trans_data (dialgebra_equivalence_of_cats_inv_functor ∙ dialgebra_equivalence_of_cats_functor) (functor_identity _). Proof. simple refine (λ x, make_dialgebra_mor _ _ _ _). - exact (ε (pr1 x)). - exact (dialgebra_equivalence_of_cats_counit_path x). Defined. Definition dialgebra_equivalence_of_cats_counit_is_nat_trans : is_nat_trans _ _ dialgebra_equivalence_of_cats_counit_data. Proof. intros x₁ x₂ f. use eq_dialgebra ; cbn. apply (nat_trans_ax ε). Qed. Definition dialgebra_equivalence_of_cats_counit : dialgebra_equivalence_of_cats_inv_functor ∙ dialgebra_equivalence_of_cats_functor ⟹ functor_identity _. Proof. use make_nat_trans. - exact dialgebra_equivalence_of_cats_counit_data. - exact dialgebra_equivalence_of_cats_counit_is_nat_trans. Defined. Definition dialgebra_equivalence_of_cats_unit_is_nat_z_iso : is_nat_z_iso dialgebra_equivalence_of_cats_unit. Proof. intro x. use is_z_iso_dialgebra. apply η. Defined. Definition dialgebra_equivalence_of_cats_counit_is_nat_z_iso : is_nat_z_iso dialgebra_equivalence_of_cats_counit. Proof. intro x. use is_z_iso_dialgebra. apply ε. Defined. Definition dialgebra_equivalence_of_cats : equivalence_of_cats (dialgebra F G) (dialgebra F' G'). Proof. use make_equivalence_of_cats. - use make_adjunction_data. + exact dialgebra_equivalence_of_cats_functor. + exact dialgebra_equivalence_of_cats_inv_functor. + exact dialgebra_equivalence_of_cats_unit. + exact dialgebra_equivalence_of_cats_counit. - split. + exact dialgebra_equivalence_of_cats_unit_is_nat_z_iso. + exact dialgebra_equivalence_of_cats_counit_is_nat_z_iso. Defined. Definition dialgebra_adj_equivalence_of_cats : adj_equivalence_of_cats dialgebra_equivalence_of_cats_functor := adjointification dialgebra_equivalence_of_cats. End DialgebraEquivalence. Section DiAlgebraCoercions. Context {C₁ C₂ : category} {F G : C₁ ⟶ C₂}. Definition dialgebra_carrier (x : dialgebra F G) : ob C₁ := pr1 x. Definition dialgebra_map (x : dialgebra F G) : C₂⟦F (dialgebra_carrier x), G (dialgebra_carrier x)⟧ := pr2 x. Definition mor_from_dialgebra_mor {x y : dialgebra F G} (f : (dialgebra F G)⟦x,y⟧) : C₁ ⟦ dialgebra_carrier x, dialgebra_carrier y ⟧ := pr1 f. Lemma dialgebra_mor_commutes {x y : dialgebra F G} (f : (dialgebra F G)⟦x,y⟧) : (dialgebra_map x) · # G (mor_from_dialgebra_mor f) = # F (mor_from_dialgebra_mor f) · (dialgebra_map y). Proof. exact (pr2 f). Qed. End DiAlgebraCoercions. Section AlgebrasAndCoalgebras. Definition FunctorAlg {C : category} (F : functor C C) : category := dialgebra F (functor_identity C). Definition CoAlg_category {C : category} (F : functor C C) : category := dialgebra (functor_identity C) F. End AlgebrasAndCoalgebras. UniMath-20231010/UniMath/CategoryTheory/categories/EilenbergMoore.v000066400000000000000000000207201451125700300250370ustar00rootroot00000000000000(****************************************************************************** The Eilenberg-Moore category We define Eilenberg-Moore categories of monads. Note: a direct definition is given in Monads/MonadAlgebras.v. The construction in this file reuses other notions (dialgebras and full subcategories) and that makes it easier to prove univalence. Contents 1. The definition 2. The univalence 3. Constructors and projections 4. The universal property 4.1 The cone 4.2 The universal property for functors 4.3 The universal property for natural transformations ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Section EilenbergMooreCategory. Context {C : category} (m : Monad C). (** 1. The definition *) Definition eilenberg_moore_cat_pred (f : dialgebra m (functor_identity C)) : hProp. Proof. use make_hProp. - exact (η m _ · pr2 f = identity _ × μ m (pr1 f) · pr2 f = # m (pr2 f) · pr2 f). - apply isapropdirprod ; apply homset_property. Defined. Definition eilenberg_moore_cat : category := full_sub_category (dialgebra m (functor_identity _)) eilenberg_moore_cat_pred. (** 2. The univalence *) Definition is_univalent_eilenberg_moore_cat (HC : is_univalent C) : is_univalent eilenberg_moore_cat. Proof. apply is_univalent_full_sub_category. apply is_univalent_dialgebra. exact HC. Defined. (** 3. Constructors and projections *) Definition make_ob_eilenberg_moore (x : C) (f : m x --> x) (p : η m x · f = identity x) (q : μ m x · f = # m f · f) : eilenberg_moore_cat := (x ,, _) ,, (p ,, q). Definition make_mor_eilenberg_moore {x y : eilenberg_moore_cat} (f : pr11 x --> pr11 y) (p : pr21 x · f = # m f · pr21 y) : x --> y := (f ,, p) ,, tt. Definition eq_mor_eilenberg_moore {x y : eilenberg_moore_cat} (f g : x --> y) (p : pr11 f = pr11 g) : f = g. Proof. use subtypePath. { intro ; apply isapropunit. } use subtypePath. { intro ; apply homset_property. } exact p. Qed. Definition is_z_iso_eilenberg_moore {x y : eilenberg_moore_cat} (f : x --> y) (Hf : is_z_isomorphism (pr11 f)) : is_z_isomorphism f. Proof. pose (H := make_z_iso _ _ Hf). use make_is_z_isomorphism. - use make_mor_eilenberg_moore. + exact (inv_from_z_iso H). + apply (is_z_iso_disp_dialgebra _ _ Hf (pr21 f)). - split. + abstract (use eq_mor_eilenberg_moore ; cbn ; apply (z_iso_inv_after_z_iso H)). + abstract (use eq_mor_eilenberg_moore ; cbn ; apply (z_iso_after_z_iso_inv H)). Defined. End EilenbergMooreCategory. Definition eilenberg_moore_univalent_cat (C : univalent_category) (m : Monad C) : univalent_category. Proof. use make_univalent_category. - exact (eilenberg_moore_cat m). - exact (is_univalent_eilenberg_moore_cat m (pr2 C)). Defined. Definition ob_of_eilenberg_moore_ob {C : category} {m : Monad C} (h : eilenberg_moore_cat m) : C := pr11 h. Definition mor_of_eilenberg_moore_ob {C : category} {m : Monad C} (h : eilenberg_moore_cat m) : m (ob_of_eilenberg_moore_ob h) --> ob_of_eilenberg_moore_ob h := pr21 h. Definition eilenberg_moore_ob_unit {C : category} {m : Monad C} (h : eilenberg_moore_cat m) : η m (ob_of_eilenberg_moore_ob h) · mor_of_eilenberg_moore_ob h = identity _ := pr12 h. Definition eilenberg_moore_ob_mult {C : category} {m : Monad C} (h : eilenberg_moore_cat m) : μ m _ · mor_of_eilenberg_moore_ob h = # m (mor_of_eilenberg_moore_ob h) · mor_of_eilenberg_moore_ob h := pr22 h. Definition mor_of_eilenberg_moore_mor {C : category} {m : Monad C} {x y : eilenberg_moore_cat m} (f : x --> y) : ob_of_eilenberg_moore_ob x --> ob_of_eilenberg_moore_ob y := pr11 f. Definition eq_of_eilenberg_moore_mor {C : category} {m : Monad C} {x y : eilenberg_moore_cat m} (f : x --> y) : mor_of_eilenberg_moore_ob x · pr11 f = # m (pr11 f) · mor_of_eilenberg_moore_ob y := pr21 f. (** 4. The universal property *) (** 4.1 The cone *) Definition eilenberg_moore_pr {C : category} (m : Monad C) : eilenberg_moore_cat m ⟶ C. Proof. refine (functor_composite _ _). - apply full_sub_category_pr. - apply dialgebra_pr1. Defined. Definition eilenberg_moore_nat_trans {C : category} (m : Monad C) : eilenberg_moore_pr m ∙ m ⟹ functor_identity _ ∙ eilenberg_moore_pr m. Proof. use make_nat_trans. - exact (λ f, mor_of_eilenberg_moore_ob f). - abstract (intros f₁ f₂ α ; cbn ; exact (!(eq_of_eilenberg_moore_mor α))). Defined. (** 4.2 The universal property for functors *) Section EilenbergMooreUMP1. Context {C₁ C₂ : category} (m : Monad C₂) (F : C₁ ⟶ C₂) (α : F ∙ m ⟹ functor_identity _ ∙ F) (αη : ∏ (x : C₁), η m (F x) · α x = identity _) (αμ : ∏ (x : C₁), # m (α x) · α x = μ m (F x) · α x). Definition functor_to_eilenberg_moore_cat_data : functor_data C₁ (eilenberg_moore_cat m). Proof. use make_functor_data. - intro x. use make_ob_eilenberg_moore. + exact (F x). + exact (α x). + exact (αη x). + exact (!(αμ x)). - intros x y f. use make_mor_eilenberg_moore. + exact (#F f). + exact (!(nat_trans_ax α _ _ f)). Defined. Definition functor_to_eilenberg_moore_is_functor : is_functor functor_to_eilenberg_moore_cat_data. Proof. split. - intro x. use eq_mor_eilenberg_moore ; cbn. apply functor_id. - intros x y z f g. use eq_mor_eilenberg_moore ; cbn. apply functor_comp. Qed. Definition functor_to_eilenberg_moore_cat : C₁ ⟶ eilenberg_moore_cat m. Proof. use make_functor. - exact functor_to_eilenberg_moore_cat_data. - exact functor_to_eilenberg_moore_is_functor. Defined. Definition functor_to_eilenberg_moore_cat_pr : functor_to_eilenberg_moore_cat ∙ eilenberg_moore_pr m ⟹ F. Proof. use make_nat_trans. - exact (λ _, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition functor_to_eilenberg_moore_cat_pr_is_nat_z_iso : is_nat_z_iso functor_to_eilenberg_moore_cat_pr. Proof. intro. apply identity_is_z_iso. Defined. Definition functor_to_eilenberg_moore_cat_pr_nat_z_iso : nat_z_iso (functor_to_eilenberg_moore_cat ∙ eilenberg_moore_pr m) F. Proof. use make_nat_z_iso. - exact functor_to_eilenberg_moore_cat_pr. - exact functor_to_eilenberg_moore_cat_pr_is_nat_z_iso. Defined. End EilenbergMooreUMP1. (** 4.3 The universal property for natural transformations *) Definition nat_trans_to_eilenberg_moore_cat {C₁ C₂ : category} (m : Monad C₂) (F₁ F₂ : C₁ ⟶ eilenberg_moore_cat m) (α : F₁ ∙ eilenberg_moore_pr m ⟹ F₂ ∙ eilenberg_moore_pr m) (p : ∏ (x : C₁), mor_of_eilenberg_moore_ob (F₁ x) · α x = # m (α x) · mor_of_eilenberg_moore_ob (F₂ x)) : F₁ ⟹ F₂. Proof. use make_nat_trans. - intro x. use make_mor_eilenberg_moore. + exact (α x). + exact (p x). - abstract (intros x y f ; use eq_mor_eilenberg_moore ; cbn ; exact (nat_trans_ax α _ _ f)). Defined. UniMath-20231010/UniMath/CategoryTheory/categories/FinSet.v000066400000000000000000000051571451125700300233400ustar00rootroot00000000000000(** * The category of finite sets Author: Langston Barrett (@siddharthist) *) (** ** Contents: - The univalent category [FinSet] of finite sets/types - (Co)limits - Colimits - Binary coproducts - Limits - Binary products *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Combinatorics.FiniteSets. (* Basics *) Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. (* HSET *) Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. (* Lemmas about forming (full) subcategories *) Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. (* Limits *) Require Import UniMath.CategoryTheory.Subcategory.Limits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Local Open Scope cat. Local Open Scope functions. (** ** The univalent category [FinSet] of finite sets/types *) (** This could be defined in three ways: 1. as a subcategory of [type_precat], 2. as a subcategory of [HSET] (see [isfinite_isaset]), or 3. as a regular precategory. We choose the second due to the ability to inherit many structures from [HSET]. *) Definition finite_subtype : hsubtype (ob HSET) := isfinite ∘ pr1hSet. Definition FinSet : univalent_category := subcategory_univalent HSET_univalent_category finite_subtype. (** ** (Co)limits *) (** *** Colimits *) (** **** Binary coproducts *) (** The coproduct of finite sets is finite, so the predicate "is finite" is closed under the formation of coproducts. Therefore, FinSet inherits coproducts from HSET. *) Definition BinCoproductsFinSet : BinCoproducts FinSet. Proof. apply (@bin_coproducts_in_full_subcategory HSET_univalent_category finite_subtype BinCoproductsHSET). intros; apply isfinitecoprod; assumption. Defined. (** *** Limits *) (** **** Binary products *) (** The product of finite sets is finite, so the predicate "is finite" is closed under the formation of products. Therefore, FinSet inherits products from HSET. *) Definition BinProductsFinSet : BinProducts FinSet. Proof. apply (@bin_products_in_full_subcategory HSET_univalent_category finite_subtype BinProductsHSET). intros; apply isfinitedirprod; assumption. Defined.UniMath-20231010/UniMath/CategoryTheory/categories/Graph.v000066400000000000000000000054611451125700300232070ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategory of graphs Benedikt Ahrens, Marco Maggesi May 2018 Revised June 2019 ********************************************************************************* *) Require Import UniMath.Foundations.PartB. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Combinatorics.Graph. (** NB: pregraph is the same as precategory_ob_mor. *) Require UniMath.CategoryTheory.Core.Univalence. (* double_transport *) Require UniMath.CategoryTheory.Core.Functors. (* functor_data_eq *) (** Should be moved in Combinatorics/Graph.v, but it depends on code from CategoryTheory for now. *) Definition graph_mor_eq {G H : pregraph} (p q : graph_mor G H) (e₀ : ∏ x : vertex G, onvertex p x = onvertex q x) (e₁ : ∏ x y (f : edge G x y), UniMath.CategoryTheory.Core.Univalence.double_transport (e₀ x) (e₀ y) (onedge p f) = onedge q f) : p = q := UniMath.CategoryTheory.Core.Functors.functor_data_eq G H p q e₀ e₁. Lemma isaprop_has_edgesets (G : pregraph) : isaprop (has_edgesets G). Proof. apply UniMath.CategoryTheory.Core.Categories.isaprop_has_homsets. Qed. (** ** Precategory of pregraphs. *) Definition pregraph_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor pregraph graph_mor. Definition pregraph_precategory_data : precategory_data := make_precategory_data pregraph_precategory_ob_mor graph_mor_id (@graph_mor_comp). Lemma is_precategory_pregraph : is_precategory pregraph_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat apply make_dirprod; cbn. - exact @graph_mor_id_left. - exact @graph_mor_id_right. - apply @graph_mor_comp_assoc. Qed. Definition pregraph_category : precategory := make_precategory pregraph_precategory_data is_precategory_pregraph. (** ** Category of graphs. *) Definition graph_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor graph graph_mor. Definition graph_precategory_data : precategory_data := make_precategory_data graph_precategory_ob_mor (λ G : graph, graph_mor_id G) (λ G H K : graph, graph_mor_comp). Lemma is_precategory_graph : is_precategory graph_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat apply make_dirprod; cbn. - exact @graph_mor_id_left. - exact @graph_mor_id_right. - exact @graph_mor_comp_assoc. Qed. Definition graph_precategory : precategory := make_precategory graph_precategory_data is_precategory_graph. Lemma has_homsets_graph : has_homsets graph_precategory_ob_mor. Proof. intros G H. apply isaset_graph_mor. - exact (isaset_vertex H). - exact (isaset_edge H). Defined. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/000077500000000000000000000000001451125700300225145ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/categories/HSET/All.v000066400000000000000000000007051451125700300234150ustar00rootroot00000000000000Require Export UniMath.CategoryTheory.categories.HSET.Core. Require Export UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Export UniMath.CategoryTheory.categories.HSET.Univalence. Require Export UniMath.CategoryTheory.categories.HSET.Limits. Require Export UniMath.CategoryTheory.categories.HSET.Colimits. Require Export UniMath.CategoryTheory.categories.HSET.Structures. Require Export UniMath.CategoryTheory.categories.HSET.SliceFamEquiv. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Colimits.v000066400000000000000000000324041451125700300244710ustar00rootroot00000000000000(** * Colimits in [HSET] *) (** ** Contents - Minimal equivalence relations - General colimits [ColimsHSET] - Binary coproducs [BinCoproductsHSET] - General indexed coproducs [CoproductsHSET] - Binary coproducts from colimits [BinCoproductsHSET_from_Colims] - Pushouts from colimits [PushoutsHSET_from_Colims] - Initial object [InitialHSET] - Initial object from colimits [InitialHSET_from_Colims] - Every set is the colimit of its finite subsets [is_colimit_finite_subsets_cocone] Written by: Benedikt Ahrens, Anders Mörtberg October 2015 - January 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. (* flip *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.pushouts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.categories.HSET.Core. (* For colimits of finite subsets. *) Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.MoreFoundations.Subtypes. Local Open Scope cat. (** ** General colimits [ColimsHSET] *) Section colimits. Variable g : graph. Variable D : diagram g HSET. Local Definition cobase : UU := ∑ j : vertex g, pr1hSet (dob D j). (* Theory about hprop is in UniMath.Foundations.Propositions *) Local Definition rel0 : hrel cobase := λ (ia jb : cobase), ∥(∑ f : edge (pr1 ia) (pr1 jb), dmor D f (pr2 ia) = pr2 jb)∥. Local Definition rel : hrel cobase := eqrel_from_hrel rel0. Lemma iseqrel_rel : iseqrel rel. Proof. now apply iseqrel_eqrel_from_hrel. Qed. Local Definition eqr : eqrel cobase := make_eqrel _ iseqrel_rel. (* Defined in UniMath.Foundations.Sets *) Definition colimHSET : HSET := make_hSet (setquot eqr) (isasetsetquot _). (* (X,~) | \ | \ | \ setquotpr | \ | \ | \ | \ V V X/~ ----------> (Y,=) *) Local Definition injections j : HSET ⟦dob D j, colimHSET⟧. Proof. intros Fj; apply (setquotpr _). exact (j,,Fj). Defined. (* Define the morphism out of the colimit *) Section from_colim. Variables (c : HSET) (cc : cocone D c). Local Definition from_cobase : cobase -> pr1hSet c. Proof. now intro iA; apply (coconeIn cc (pr1 iA) (pr2 iA)). Defined. Local Definition from_cobase_rel : hrel cobase. Proof. intros x x'; exists (from_cobase x = from_cobase x'). now apply setproperty. Defined. Local Definition from_cobase_eqrel : eqrel cobase. Proof. exists from_cobase_rel. abstract ( repeat split; [ intros x y z H1 H2 ; exact (pathscomp0 H1 H2) | intros x y H; exact (pathsinv0 H) ]). Defined. Lemma rel0_impl a b (Hab : rel0 a b) : from_cobase_eqrel a b. Proof. use Hab. clear Hab. intro H; simpl. destruct H as [f Hf]. generalize (toforallpaths _ _ _ (coconeInCommutes cc (pr1 a) (pr1 b) f) (pr2 a)). unfold compose, from_cobase; simpl; intro H. rewrite <- H. rewrite <- Hf. apply idpath. Qed. Lemma rel_impl a b (Hab : rel a b) : from_cobase_eqrel a b. Proof. now apply (@minimal_eqrel_from_hrel _ rel0); [apply rel0_impl|]. Qed. Lemma iscomprel_from_base : iscomprelfun rel from_cobase. Proof. now intros a b; apply rel_impl. Qed. Definition from_colimHSET : HSET ⟦colimHSET, c⟧. Proof. now simpl; apply (setquotuniv _ _ from_cobase iscomprel_from_base). Defined. End from_colim. Definition colimCoconeHSET : cocone D colimHSET. Proof. use make_cocone. - now apply injections. - abstract (intros u v e; apply funextfun; intros Fi; simpl; unfold compose, injections; simpl; apply (weqpathsinsetquot eqr), (eqrelsymm eqr), eqrel_impl, hinhpr; simpl; now exists e). Defined. Definition ColimHSETArrow (c : HSET) (cc : cocone D c) : ∑ x : HSET ⟦ colimHSET, c ⟧, ∏ v : vertex g, injections v · x = coconeIn cc v. Proof. exists (from_colimHSET _ cc). abstract (intro i; simpl; unfold injections, compose, from_colimHSET; simpl; apply funextfun; intro Fi; now rewrite (setquotunivcomm eqr)). Defined. Definition ColimCoconeHSET : ColimCocone D. Proof. apply (make_ColimCocone _ colimHSET colimCoconeHSET); intros c cc. exists (ColimHSETArrow _ cc). abstract (intro f; apply subtypePath; [ intro; now apply impred; intro i; apply has_homsets_HSET | apply funextfun; intro x; simpl; apply (surjectionisepitosets (setquotpr eqr)); [now apply issurjsetquotpr | now apply pr2 | ]; intro y; destruct y as [u fu]; destruct f as [f Hf]; now apply (toforallpaths _ _ _ (Hf u) fu)]). Defined. End colimits. Opaque from_colimHSET. Lemma ColimsHSET : Colims HSET. Proof. now intros g d; apply ColimCoconeHSET. Defined. Lemma ColimsHSET_of_shape (g : graph) : Colims_of_shape g HSET. Proof. now intros d; apply ColimCoconeHSET. Defined. (** ** Binary coproducs [BinCoproductsHSET] *) (* rules for coproducts in HSET *) Lemma BinCoproductIn1CommutesHSET (A B : HSET) (CC : BinCoproduct A B)(C : HSET) (f : A --> C)(g: B --> C) (a:pr1 A): BinCoproductArrow CC f g (BinCoproductIn1 CC a) = f a. Proof. set (H1 := BinCoproductIn1Commutes _ _ _ CC _ f g). apply toforallpaths in H1. now apply H1. Qed. Lemma BinCoproductIn2CommutesHSET (A B : HSET) (CC : BinCoproduct A B)(C : HSET) (f : A --> C)(g: B --> C) (b:pr1 B): BinCoproductArrow CC f g (BinCoproductIn2 CC b) = g b. Proof. set (H1 := BinCoproductIn2Commutes _ _ _ CC _ f g). apply toforallpaths in H1. now apply H1. Qed. Lemma postcompWithBinCoproductArrowHSET {A B : HSET} (CCAB : BinCoproduct A B) {C : HSET} (f : A --> C) (g : B --> C) {X : HSET} (k : C --> X) z: k (BinCoproductArrow CCAB f g z) = BinCoproductArrow CCAB (f · k) (g · k) z. Proof. set (H1 := postcompWithBinCoproductArrow _ CCAB f g k). apply toforallpaths in H1. now apply H1. Qed. (* Direct construction of binary coproducts in HSET *) Lemma BinCoproductsHSET : BinCoproducts HSET. Proof. intros A B. use make_BinCoproduct. - apply (setcoprod A B). - simpl in *; apply ii1. - simpl in *; intros x; apply (ii2 x). - apply (make_isBinCoproduct _ HSET). intros C f g; simpl in *. use tpair. * exists (sumofmaps f g); abstract (split; apply idpath). * abstract (intros h; apply subtypePath; [ intros x; apply isapropdirprod; apply has_homsets_HSET | destruct h as [t [ht1 ht2]]; simpl; apply funextfun; intro x; rewrite <- ht2, <- ht1; unfold compose; simpl; case x; intros; apply idpath]). Defined. (** ** General indexed coproducs [CoproductsHSET] *) Lemma CoproductsHSET (I : UU) (HI : isaset I) : Coproducts I HSET. Proof. intros A. use make_Coproduct. - exists (∑ i, pr1 (A i)). apply (isaset_total2 _ HI); intro i; apply setproperty. - simpl; apply tpair. - apply (make_isCoproduct _ _ HSET). intros C f; simpl in *. use tpair. * exists (λ X, f (pr1 X) (pr2 X)); abstract (intro i; apply idpath). * abstract (intros h; apply subtypePath; simpl; [ intro; apply impred; intro; apply has_homsets_HSET | destruct h as [t ht]; simpl; apply funextfun; intro x; rewrite <- ht; destruct x; apply idpath]). Defined. (** *** Binary coproducts from colimits [BinCoproductsHSET_from_Colims] *) Require UniMath.CategoryTheory.limits.graphs.bincoproducts. Lemma BinCoproductsHSET_from_Colims : graphs.bincoproducts.BinCoproducts HSET. Proof. now apply bincoproducts.BinCoproducts_from_Colims, ColimsHSET_of_shape. Defined. (** *** Pushouts from colimits [PushoutsHSET_from_Colims] *) Lemma PushoutsHSET_from_Colims : graphs.pushouts.Pushouts HSET. Proof. red; intros; apply ColimsHSET_of_shape. Qed. (** ** Initial object [InitialHSET] *) Lemma InitialHSET : Initial HSET. Proof. apply (make_Initial emptyHSET). apply make_isInitial; intro a. use tpair. - simpl; intro e; induction e. - abstract (intro f; apply funextfun; intro e; induction e). Defined. (** *** Initial object from colimits [InitialHSET_from_Colims] *) Require UniMath.CategoryTheory.limits.graphs.initial. Lemma InitialHSET_from_Colims : graphs.initial.Initial HSET. Proof. apply initial.Initial_from_Colims, ColimsHSET_of_shape. Defined. Section finite_subsets. (* This section proves that every set is the colimit of its finite subsets by showing that it satisfies the universal property. *) Local Open Scope subtype. Local Open Scope logic. Definition finite_subsets_graph (X : hSet) : graph. Proof. use make_graph. - exact(finite_subset X). - exact(λ (A B : finite_subset X), A ⊆ B). Defined. Definition finite_subsets_diagram (X : hSet) : diagram (finite_subsets_graph X) HSET. Proof. use make_diagram. - exact(λ (A : finite_subset X), carrier_subset A). - exact(λ (A B : finite_subset X) (E : A ⊆ B), subtype_inc E). Defined. (* Construct the cocone with apex X over the finite subsets diagram with injections taken to be the projections from the carriers of the subsets. *) Definition finite_subsets_cocone (X : hSet) : cocone (finite_subsets_diagram X) X. Proof. use make_cocone. - exact(λ (A : finite_subset X), pr1carrier A). - red ; intros ; apply idpath. Defined. (* Every set is the colimit of its finite subsets. *) Definition is_colimit_finite_subsets_cocone (X : hSet) : isColimCocone (finite_subsets_diagram X) X (finite_subsets_cocone X). Proof. set (D := finite_subsets_diagram X). intros Y CC. (* Construct the unique cocone morphism X --> Y by mapping x : X to whatever coconeIn CC maps the unique inhabitant of {x} to. *) use unique_exists. - exact(λ (x : X), coconeIn CC (finite_singleton x) singleton_point). - intros A. apply funextfun ; intro a. (* {a} ⊆ A *) set (a_in_A := finite_singleton_is_in (A : finite_subset X) a). (* {a} -⊆-> A ---> Y commutes with {a} -(inj)-> Y by the cocone property of CC. *) assert(p : dmor D a_in_A · coconeIn CC A = coconeIn CC (finite_singleton (pr1 a))) by apply coconeInCommutes. apply(eqtohomot (!p)). - intro ; apply isaprop_is_cocone_mor. - intros f fmor. apply funextfun ; intro x. exact(eqtohomot (fmor (finite_singleton x)) singleton_point). Defined. End finite_subsets. (** Concrete construction of coequalizers of sets *) Section HSETCoequalizer. Context {X Y : hSet} (f g : X → Y). Definition coequalizer_eqrel : eqrel Y. Proof. use make_eqrel. - exact (eqrel_from_hrel (λ y₁ y₂, ∃ (x : X) , f x = y₁ × g x = y₂)). - apply iseqrel_eqrel_from_hrel. Defined. Definition coequalizer_hSet : hSet := setquotinset coequalizer_eqrel. Definition coequalizer_map_hSet : Y → coequalizer_hSet := setquotpr coequalizer_eqrel. Proposition coequalizer_eq_hSet (x : X) : coequalizer_map_hSet (f x) = coequalizer_map_hSet (g x). Proof. apply iscompsetquotpr. use eqrel_impl. apply hinhpr. exists x. split. - apply idpath. - apply idpath. Qed. Lemma coequalizer_out_hSet_equality (Z : hSet) (h : Y → Z) (p : ∏ (x : X), h(f x) = h(g x)) : iscomprelfun coequalizer_eqrel h. Proof. intros y₁ y₂ q. cbn in *. use (q (make_eqrel (λ y₁ y₂, make_hProp (h y₁ = h y₂) _) _)). - apply setproperty. - repeat split. + exact (λ _ _ _ r₁ r₂, r₁ @ r₂). + exact (λ _ _ r, !r). - intros x y ; cbn. use factor_through_squash. { apply setproperty. } intros r. rewrite <- (pr12 r). rewrite <- (pr22 r). apply p. Qed. Definition coequalizer_out_hSet {Z : hSet} (h : Y → Z) (p : ∏ (x : X), h(f x) = h(g x)) : coequalizer_hSet → Z. Proof. use setquotuniv. - exact h. - exact (coequalizer_out_hSet_equality Z h p). Defined. End HSETCoequalizer. Definition Coequalizers_HSET : Coequalizers HSET. Proof. intros X Y f g. use make_Coequalizer. - exact (coequalizer_hSet f g). - exact (coequalizer_map_hSet f g). - abstract (use funextsec ; intro x ; cbn ; exact (coequalizer_eq_hSet f g x)). - intros Z h p. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use funextsec ; use setquotunivprop' ; [ intro ; apply setproperty | ] ; intro x ; cbn ; exact (eqtohomot (pr2 φ₁ @ !(pr2 φ₂)) x)). + simple refine (_ ,, _). * exact (coequalizer_out_hSet f g h (eqtohomot p)). * abstract (apply idpath). Defined. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Core.v000066400000000000000000000064201451125700300235750ustar00rootroot00000000000000(** * Category of [hSet]s Started by: Benedikt Ahrens, Chris Kapulkin, Mike Shulman January 2013 Extended by: Anders Mörtberg (October 2015) *) (** ** Contents: - Category [HSET] of [hSet]s ([hset_category]) - Some particular HSETs - Hom functors *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Foundations.HLevels. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. (** ** Category HSET of [hSet]s ([hset_category]) *) Section HSET_precategory. Definition hset_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor hSet (λ A B : hSet, A -> B). Definition hset_precategory_data : precategory_data := make_precategory_data hset_precategory_ob_mor (fun (A:hSet) (x : A) => x) (fun (A B C : hSet) (f : A -> B) (g : B -> C) (x : A) => g (f x)). Lemma is_precategory_hset_precategory_data : is_precategory hset_precategory_data. Proof. repeat split. Qed. Definition hset_precategory : precategory := tpair _ _ is_precategory_hset_precategory_data. Local Notation "'HSET'" := hset_precategory : cat. Lemma has_homsets_HSET : has_homsets HSET. Proof. intros a b; apply isaset_set_fun_space. Qed. (* Canonical Structure hset_precategory. :-) *) Definition hset_category : category := (HSET ,, has_homsets_HSET). End HSET_precategory. Notation "'HSET'" := hset_category : cat. Notation "'SET'" := hset_category : cat. (** ** Some particular HSETs *) Definition emptyHSET : HSET. Proof. exists empty. abstract (apply isasetempty). Defined. Definition unitHSET : HSET. Proof. exists unit. abstract (apply isasetunit). Defined. Definition natHSET : HSET. Proof. exists nat. abstract (apply isasetnat). Defined. (*Definition of HomFunctor for categories, analagous definition for precategories is in ../Type/Core*) Section HomSetFunctors. Context {C : category}. Definition homSet_functor_data : functor_data (category_binproduct (C^op) C) hset_category. Proof. use make_functor_data. + intros pair. induction pair as (p1, p2). use make_hSet. - exact (C ⟦ p1, p2 ⟧). - use (homset_property C). + intros x y fg h. induction fg as (fg1, fg2). cbn in fg1. exact (fg1 · h · fg2). Defined. Lemma is_functor_homSet_functor_type : is_functor homSet_functor_data. Proof. use make_dirprod. - intro; cbn. apply funextsec; intro. refine (id_right _ @ _). apply id_left. - repeat intro. apply funextsec; intro; cbn. do 3 rewrite assoc. reflexivity. Defined. Definition homSet_functor : functor (category_binproduct (C^op) C) hset_category := make_functor _ is_functor_homSet_functor_type. Context (c : C). Definition cov_homSet_functor : functor C hset_category := functor_fix_fst_arg (C^op) _ _ homSet_functor c. Definition contra_homSet_functor : functor (C^op) hset_category := functor_fix_snd_arg (C^op) _ _ homSet_functor c. End HomSetFunctors.UniMath-20231010/UniMath/CategoryTheory/categories/HSET/FilteredColimits.v000066400000000000000000000344111451125700300261500ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.QuotientSet. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.Filtered. Require Import UniMath.CategoryTheory.limits.StandardDiagrams. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.Combinatorics.KFiniteTypes. Require Import UniMath.Combinatorics.KFiniteSubtypes. (** * Filtered Colimits of Sets. 1. Filtered colimits as set quotients. 2. The category of K-finite subsets of a set is filtered. [is_filtered_kfinite_subsets]. 3. Every set is the filtered colimit of its K-finite subsets. [is_colimit_kfinite_subsets] 4. Compact sets are K-finite. [iskfinite_compact_SET] *) Local Open Scope cat. Local Open Scope subtype. (** Given a filtered category J and a diagram F : J -> SET the colimit of F can be constructed as a quotient of the disjoint union, ∐ⱼF(j)/~, where (j₁, x) ~ (j₂, y) if there is some i ∈ J and edges u : j₁ -> i, v : j₂ -> i (in J) such that F(u) x = F(v) y. See [filtered_cobase_rel]. *) Section filtered_colimits_in_SET. (** 1. Filtered colimits as set quotients. *) Variable J : category. Variable Jfiltered : is_filtered J. Variable F : functor J SET. Let d := (pr1 F) : diagram J SET. (* This follows the same basic structure used in HSET.Colimits *) Definition cobase : UU := ∑ (j : vertex J), (dob d j : hSet). Local Definition cobasepr1 : cobase -> vertex J := pr1. Local Coercion cobasepr1 : cobase >-> vertex. Local Definition cobasept : ∏ (a : cobase), (dob d a) : hSet := pr2. Local Coercion cobasept : cobase >-> pr1hSet. Definition filtered_cobase_rel : hrel cobase := λ (a b : cobase), ∥ ∑ (c : J) (fia : edge a c) (fib : edge b c), (dmor d fia) a = (dmor d fib) b ∥. Definition filtered_rel : hrel cobase := eqrel_from_hrel filtered_cobase_rel. Definition filtered_eqrel : eqrel cobase. Proof. use make_eqrel. - exact(eqrel_from_hrel filtered_cobase_rel). - apply iseqrel_eqrel_from_hrel. Defined. (* TODO: Redo this but using setquot2 instead. *) Definition FilteredColimitSET : SET := make_hSet (setquot filtered_eqrel) (isasetsetquot filtered_eqrel). (* Define the injections from the diagram into the colimit. *) Definition inject (j : vertex J) : SET⟦dob d j, FilteredColimitSET⟧ := λ (dj : dob d j : hSet), setquotpr filtered_eqrel (j ,, dj). (* They satisfy the cocone property. This is where we use the assumption that J is filtered. *) Lemma filtered_forms_cocone : forms_cocone d inject. Proof. intros u v e. apply funextfun; intros x. apply(weqpathsinsetquot filtered_eqrel). apply eqrel_impl. (* Here ↓ is Jfiltered used. *) use(hinhfun _ (Jfiltered _ (make_interval_diagram u v e) (is_finite_graph_interval))). intros P; destruct P as [apex cc]; cbn. exists apex. exists (coconeIn cc false). exists (coconeIn cc true). (* This is to convince Coq that we can use eqtohomot. *) change (dmor d (coconeIn cc false) (dmor d e x)) with ((dmor d e · (dmor d (coconeIn cc false))) x). use(eqtohomot _ x). etrans; [apply(!functor_comp F e (coconeIn cc false)) |]; apply maponpaths. exact(coconeInCommutes cc true false tt). Qed. Definition filtered_cocone : cocone d FilteredColimitSET. Proof. use make_cocone. - exact inject. - exact filtered_forms_cocone. Defined. Definition from_cobase {Y : SET} (cc : cocone d Y) : cobase -> Y : hSet := λ (a : cobase), coconeIn cc a a. Definition from_cobase_hrel {Y : SET} (cc : cocone d Y) : hrel cobase. Proof. intros a b. use make_hProp. - exact(from_cobase cc a = from_cobase cc b). - apply setproperty. Defined. Definition from_cobase_eqrel {Y : SET} (cc : cocone d Y) : eqrel cobase. Proof. use make_eqrel. - exact(from_cobase_hrel cc). - abstract(repeat split; red; intros *; [apply pathscomp0 | apply pathsinv0]). Defined. Definition filtered_cobase_rel_impl {Y : SET} (cc : cocone d Y) (a b : cobase) (Rab : filtered_cobase_rel a b) : from_cobase_eqrel cc a b. Proof. use Rab; intros h. etrans; [refine(!eqtohomot (coconeInCommutes cc _ _ _) a); exact(pr12 h) |]. etrans; [| refine(eqtohomot (coconeInCommutes cc _ _ _) b); exact(pr122 h)]. apply(maponpaths _ (pr222 h)). Defined. Definition filtered_rel_impl {Y : SET} (cc : cocone d Y) (a b : cobase) (Rab : filtered_rel a b) : from_cobase_eqrel cc a b. Proof. now apply(minimal_eqrel_from_hrel filtered_cobase_rel); [apply filtered_cobase_rel_impl |]. Defined. Definition iscomprelfun_from_cobase {Y : SET} (cc : cocone d Y) : iscomprelfun filtered_rel (from_cobase cc). Proof. red; intros *. apply filtered_rel_impl. Defined. Definition filtered_cocone_morphism {Y : SET} (cc : cocone d Y) : SET⟦FilteredColimitSET, Y⟧. Proof. use setquotuniv. - exact(from_cobase cc). - exact(iscomprelfun_from_cobase cc). Defined. Lemma is_cocone_mor_filtered_cocone_morphism {Y : SET} (cc : cocone d Y) : is_cocone_mor (filtered_cocone) cc (filtered_cocone_morphism cc). Proof. intro; apply idpath. Qed. Lemma is_unique_filtered_cocone_morphism {Y : SET} (cc : cocone d Y) (f : SET⟦FilteredColimitSET, Y⟧) (fmor : is_cocone_mor filtered_cocone cc f) : f = filtered_cocone_morphism cc. Proof. apply funextfun; intro x. apply(surjectionisepitosets (setquotpr filtered_eqrel)). - apply issurjsetquotpr. - apply setproperty. - intro b. exact(eqtohomot (fmor b) b). Qed. Definition FilteredColimCoconeSET : ColimCocone d. Proof. use make_ColimCocone. - exact FilteredColimitSET. - exact filtered_cocone. - intros Y cc. use unique_exists. + exact(filtered_cocone_morphism cc). + exact(is_cocone_mor_filtered_cocone_morphism cc). + exact(isaprop_is_cocone_mor filtered_cocone cc). + exact(is_unique_filtered_cocone_morphism cc). Defined. End filtered_colimits_in_SET. Section category_of_kfinite_subsets. (** 2. The category of K-finite subsets of a set, with subset inclusions as morphisms. - [kfinite_subsets_category] - [is_filtered_kfinite_subsets] *) Definition kfinite_subsets_ob_mor (X : hSet) : precategory_ob_mor. Proof. (* we are actually taking the K-finite sub/types/ as objects and subtype-containment as morphisms between them. But the corresponding carriers really are sets, thanks to isaset_carrier_subset. *) use make_precategory_ob_mor. - exact(kfinite_subtype X). - exact(subtype_containedIn). (* ⊆ *) Defined. Definition kfinite_subsets_precategory_data (X : hSet) : precategory_data. Proof. use make_precategory_data. - exact(kfinite_subsets_ob_mor X). - intro; apply subtype_containment_isrefl. - intros *; apply subtype_containment_istrans. Defined. Definition kfinite_subsets_precategory (X : hSet) : precategory. Proof. use make_precategory. - exact(kfinite_subsets_precategory_data X). - repeat split. (* Solves everything by applying idpath. *) Defined. Lemma has_homsets_kfinite_subsets (X : hSet) : has_homsets (kfinite_subsets_precategory X). Proof. red; intros. apply isasetaprop. apply propproperty. Qed. Definition kfinite_subsets_category (X : hSet) : category. Proof. use make_category. - exact(kfinite_subsets_precategory X). - exact(has_homsets_kfinite_subsets X). Defined. Lemma is_filtered_kfinite_subsets (X : hSet) : is_filtered (kfinite_subsets_category X). Proof. intros g d gfinite. apply hinhpr. simple refine(_ ,, _). - exact(kfinite_subtype_union (dob d) (finite_vertexset gfinite)). - use make_cocone. + apply subtype_union_containedIn. + abstract(red; intros ; apply funextsec; intro ; apply funextsec; intro ; apply squash_path). Qed. (* Define the functor from kfinite_subsets_category X into SET sending each subtype to its carrier set and each ⊆ to the inclusion between carriers. *) Definition kfinite_subsets_functor_data (X : hSet) : functor_data (kfinite_subsets_category X) SET. Proof. use make_functor_data. - exact(λ (A : kfinite_subtype X), carrier_subset A). - exact(λ _ _ E, subtype_inc E). Defined. Definition kfinite_subsets_functor (X : hSet) : functor (kfinite_subsets_category X) SET. Proof. use make_functor. - exact(kfinite_subsets_functor_data X). - abstract(split; (red; intros; apply idpath)). Defined. End category_of_kfinite_subsets. Section colimit_of_kfinite_subsets. (** 3. Proof that every set is the filtered colimit of its K-finite subsets. *) Variable X : hSet. Let d := kfinite_subsets_functor_data X. (* The diagram of kfinite subsets. *) Definition kfinite_subsets_cocone : cocone d X. Proof. use make_cocone. - exact(λ (A : kfinite_subtype X), pr1). - abstract(red; intros; apply idpath). Defined. Definition is_colimit_kfinite_subsets : isColimCocone d X kfinite_subsets_cocone. Proof. intros Y cc. use unique_exists. - intro x. exact(coconeIn cc (kfinite_subtype_singleton x) singleton_point). - abstract(intro A; apply funextfun; intro x; set (commutes := coconeInCommutes cc (kfinite_subtype_singleton (pr1 x)) A (singleton_is_in _ x)); apply(eqtohomot (!commutes))). - intro; apply isaprop_is_cocone_mor. - abstract(intros f fmor; apply funextfun; intro x; exact(eqtohomot (fmor (kfinite_subtype_singleton x)) singleton_point)). Defined. End colimit_of_kfinite_subsets. Section compact_sets_are_kfinite. (** 4. Compact sets are K-finite. *) Variable X : SET. (* We can always map the kfinite_subsets_cocone to a cocone with apex Hom(X, X) over Hom(X, -) applied to the kfinite_subsets-diagram. In general this will not be a colimit, but if X is compact it will be. *) Local Definition homD := (mapdiagram (hom X) (kfinite_subsets_functor_data X)). Local Definition homcocone : cocone homD (hom X X). Proof. apply mapcocone. exact(kfinite_subsets_cocone X). Defined. Definition is_colimit_homcocone (comp : is_compact X) : isColimCocone homD (hom X X) homcocone. Proof. use comp. - exact(is_filtered_kfinite_subsets X). - exact(is_colimit_kfinite_subsets X). Defined. (* If X is compact then Hom(X, X) is a colimit. We call it homXX here. *) Local Definition homXX (comp : is_compact X) : ColimCocone homD. Proof. use make_ColimCocone. - exact(hom X X). - exact homcocone. - exact(is_colimit_homcocone comp). Defined. (* Define filtCC to be the filtered colimit (defined as a set quotient above) of hom(X, -) applied to the diagram of K-finite subsets. The idea is to use that the canonical cocone morphism φ : colim filtCC --> (hom X X) is an isomorphism when X is compact, together with the explicit construction of filtered colimits of sets to conclude that there is some K-finite subset Xᵢ ⊆ X where the inclusion Xᵢ --> X is surjective. *) Local Definition filtCC := FilteredColimCoconeSET (kfinite_subsets_category X) (is_filtered_kfinite_subsets X) ((kfinite_subsets_functor X) ∙ (hom X)). Local Definition φ : colim filtCC --> (hom X X). Proof. use colimArrow. exact homcocone. Defined. Local Definition φiso (comp : is_compact X) : is_z_isomorphism φ. Proof. use isColim_is_z_iso. use comp. - exact(is_filtered_kfinite_subsets X). - exact(is_colimit_kfinite_subsets X). Qed. (* Proof idea: take (identity X) ∈ Hom(X, X). The image φinv(identity X) ∈ filtCC can be deconstructed as an element in the cobase of the diagram of the hom-mapped diagram of K-finite subsets, i.e. it is represented by some function (f : X --> Xᵢ) for some K-finite subset of X. Then prove that the inclusion Xᵢ ⊆ X is a surjection by applying f to the fibers and use commutativity of the cocone morphism φ. *) Lemma iskfinite_compact_SET (comp : is_compact X) : iskfinite (X : hSet). Proof. set(φinv := is_z_isomorphism_mor (φiso comp)). set(idX := φinv (identity X)). (* identity X : X --> X *) set(idxx := pr12 idX). use(hinhuniv _ idxx). intros cob. (* cob = (xᵢ , f) *) (* xᵢ is a K-finite subset of X such that colimIn filtCC xᵢ f = φinv (identity X) *) set(xᵢ := pr11 cob : kfinite_subtype (X : hSet)). set(f := pr21 cob : _ --> _). (* X -> xᵢ *) (* (coconeIn (kfinite_subsets_cocone X) xᵢ) ≡ pr1 : carrier_subset xᵢ -> X. *) apply(iskfinite_from_surjection (coconeIn (kfinite_subsets_cocone X) xᵢ)). - intro y; apply hinhpr. use make_hfiber. + exact(f y). + enough (Q : colimIn (homXX comp) xᵢ f = identity X) by exact(eqtohomot Q y). (* To prove Q observe that colimIn (homXX comp) xᵢ commutes with colimIn filtCC xᵢ · φ by the colimArrow property. *) assert (z : colimIn filtCC xᵢ · φ = colimIn (homXX comp) xᵢ) by apply colimArrowCommutes. apply(pathscomp0 (eqtohomot (!z) f)). change ((colimIn filtCC xᵢ · φ) f) with (φ (colimIn filtCC xᵢ f)). (* f is in the same equivalence class in filtCC as idX ≡ φinv (identity X). *) etrans. { apply maponpaths; exact(setquotl0 _ idX cob). } (* so φ (φinv (identity X)) = identity X. *) exact(eqtohomot (is_inverse_in_precat2 (φiso comp)) (identity X)). - exact(kfinite_subtype_property xᵢ). Qed. End compact_sets_are_kfinite. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Limits.v000066400000000000000000000265771451125700300241650ustar00rootroot00000000000000(** * Limits in [HSET] *) (** ** Contents - General limits ([LimsHSET]) - Alternate definition using cats/limits - Binary products ([BinProductsHSET]) - General indexed products ([ProductsHSET]) - Terminal object ([TerminalHSET]) - Terminal object from general limits ([TerminalHSET_from_Lims]) - Pullbacks ([PullbacksHSET]) - Pullbacks from general limits ([PullbacksHSET_from_Lims]) - Pullbacks of arrows from [unit] as inverse images - Equalizers from general limits ([EqualizersHSET_from_Lims]) Written by: Benedikt Ahrens, Anders Mörtberg October 2015 - January 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. (* flip *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.WeakEquivalences. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.pullbacks. Require Import UniMath.CategoryTheory.limits.graphs.equalizers. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.categories.HSET.Core. Local Open Scope cat. (** ** General limits *) Section limits. Variable g : graph. Variable D : diagram g HSET. Definition limset_UU : UU := ∑ (f : ∏ u : vertex g, pr1hSet (dob D u)), ∏ u v (e : edge u v), dmor D e (f u) = f v. Definition limset : HSET. Proof. exists limset_UU. apply (isofhleveltotal2 2); [ apply impred; intro; apply pr2 | intro f; repeat (apply impred; intro); apply isasetaprop, setproperty ]. Defined. Lemma LimConeHSET : LimCone D. Proof. use make_LimCone. - apply limset. - exists (λ u f, pr1 f u). abstract (intros u v e; simpl; apply funextfun; intro f; simpl; apply (pr2 f)). - intros X CC. use tpair. + use tpair. * intro x; exists (λ u, coneOut CC u x). abstract (intros u v e; apply (toforallpaths _ _ _ (coneOutCommutes CC _ _ e))). * abstract (intro v; apply idpath). + abstract (intros [t p]; apply subtypePath; [ intro; apply impred; intro; apply isaset_set_fun_space | apply funextfun; intro; apply subtypePath]; [ intro; repeat (apply impred; intro); apply setproperty | apply funextsec; intro u; apply (toforallpaths _ _ _ (p u))]). Defined. End limits. Lemma LimsHSET : Lims HSET. Proof. now intros g d; apply LimConeHSET. Defined. Lemma LimsHSET_of_shape (g : graph) : Lims_of_shape g HSET. Proof. now intros d; apply LimConeHSET. Defined. (** *** Alternate definition using cats/limits *) Require UniMath.CategoryTheory.limits.cats.limits. Section cats_limits. Variable J : precategory. Variable D : functor J HSET. Definition cats_limset_UU : UU := ∑ (f : ∏ u, pr1hSet (D u)), ∏ u v (e : J⟦u,v⟧), # D e (f u) = f v. Definition cats_limset : HSET. Proof. exists cats_limset_UU. apply (isofhleveltotal2 2); [ apply impred; intro; apply pr2 | intro f; repeat (apply impred; intro); apply isasetaprop, setproperty ]. Defined. Lemma cats_LimConeHSET : cats.limits.LimCone D. Proof. use make_LimCone. - apply cats_limset. - exists (λ u f, pr1 f u). abstract (intros u v e; apply funextfun; intro f; apply (pr2 f)). - intros X CC. use tpair. + use tpair. * intro x; exists (λ u, coneOut CC u x). abstract (intros u v e; apply (toforallpaths _ _ _ (coneOutCommutes CC _ _ e))). * abstract (intro v; apply idpath). + abstract (intros [t p]; apply subtypePath; [ intro; apply impred; intro; apply isaset_set_fun_space | apply funextfun; intro x; apply subtypePath]; [ intro; repeat (apply impred; intro); apply setproperty | simpl; apply funextsec; intro u; apply (toforallpaths _ _ _ (p u))]). Defined. End cats_limits. Lemma cats_LimsHSET : cats.limits.Lims HSET. Proof. now intros g d; apply cats_LimConeHSET. Defined. Lemma cats_LimsHSET_of_shape (g : category) : cats.limits.Lims_of_shape g HSET. Proof. now intros d; apply cats_LimConeHSET. Defined. (** ** Binary products ([BinProductsHSET]) *) Lemma BinProductsHSET : BinProducts HSET. Proof. intros A B. use make_BinProduct. - apply (A × B)%set. - simpl in *; apply pr1. - simpl in *; intros x; apply (pr2 x). - apply make_isBinProduct. intros C f g; use tpair. * exists (prodtofuntoprod (f,,g)); abstract (split; apply idpath). * abstract (intros [t [ht1 ht2]]; apply subtypePath; [ intros x; apply isapropdirprod; apply has_homsets_HSET | now apply funextfun; intro x; rewrite <- ht2, <- ht1 ]). Defined. Require UniMath.CategoryTheory.limits.graphs.binproducts. (** *** Binary products from limits ([BinProductsHSET_from_Lims]) *) Lemma BinProductsHSET_from_Lims : graphs.binproducts.BinProducts HSET. Proof. now apply binproducts.BinProducts_from_Lims, LimsHSET_of_shape. Defined. (** ** General indexed products ([ProductsHSET]) *) Lemma ProductsHSET (I : UU) : Products I HSET. Proof. intros A. use make_Product. - exists (∏ i, pr1 (A i)); apply isaset_forall_hSet. - simpl; intros i f; apply (f i). - apply make_isProduct; try apply homset_property. intros C f; simpl in *. use tpair. * exists (λ c i, f i c); intro i; apply idpath. * abstract (intros h; apply subtypePath; simpl; [ intro; apply impred; intro; apply has_homsets_HSET | destruct h as [t ht]; simpl; apply funextfun; intro x; apply funextsec; intro i; rewrite <- ht; apply idpath ]). Defined. (** ** Terminal object [TerminalHSET] *) Lemma TerminalHSET : Terminal HSET. Proof. apply (make_Terminal unitHSET). apply make_isTerminal; intro a. exists (λ _, tt). abstract (simpl; intro f; apply funextfun; intro x; case (f x); apply idpath). Defined. (** *** Terminal object from general limits [TerminalHSET_from_Lims] *) Require UniMath.CategoryTheory.limits.graphs.terminal. Lemma TerminalHSET_from_Lims : graphs.terminal.Terminal HSET. Proof. now apply terminal.Terminal_from_Lims, LimsHSET_of_shape. Defined. (** ** Pullbacks [PullbacksHSET] *) Definition PullbackHSET_ob {A B C : HSET} (f : HSET⟦B,A⟧) (g : HSET⟦C,A⟧) : HSET. Proof. exists (∑ (xy : setdirprod B C), f (pr1 xy) = g (pr2 xy)). abstract (apply isaset_total2; [ apply isasetdirprod; apply setproperty | intros xy; apply isasetaprop, setproperty ]). Defined. Lemma PullbacksHSET : Pullbacks HSET. Proof. intros A B C f g. use make_Pullback. + apply (PullbackHSET_ob f g). + intros xy; apply (pr1 (pr1 xy)). + intros xy; apply (pr2 (pr1 xy)). + abstract (apply funextsec; intros [[x y] Hxy]; apply Hxy). + use make_isPullback. intros X f1 f2 Hf12; cbn. use unique_exists. - intros x. exists (f1 x,,f2 x); abstract (apply (toforallpaths _ _ _ Hf12)). - abstract (now split). - abstract (now intros h; apply isapropdirprod; apply has_homsets_HSET). - abstract (intros h [H1 H2]; apply funextsec; intro x; apply subtypePath; [intros H; apply setproperty|]; simpl; now rewrite <- (toforallpaths _ _ _ H1 x), <- (toforallpaths _ _ _ H2 x)). Defined. (** *** Pullbacks from general limits [PullbacksHSET_from_Lims] *) Require UniMath.CategoryTheory.limits.graphs.pullbacks. Lemma PullbacksHSET_from_Lims : graphs.pullbacks.Pullbacks HSET. Proof. apply (graphs.pullbacks.Pullbacks_from_Lims HSET LimsHSET). Defined. (** *** Pullbacks of arrows from [unit] as inverse images *) (** The set [hfiber f y] is a pullback of a diagram involving an arrow from [TerminalHSET], i.e. [unit]. In particular, A pullback diagram of shape << Z --- ! --> unit | | | | y V V X --- f --> Y >> makes [Z] (isomorphic to) the inverse image of a point [y : Y] under [f]. *) (** A translation of [weqfunfromunit] into the language of category theory, to make the statement of the next lemmas more concise. *) Lemma weqfunfromunit_HSET (X : hSet) : HSET⟦TerminalHSET, X⟧ ≃ X. Proof. apply weqfunfromunit. Defined. Local Lemma tosecoverunit_compute {X : UU} {x : X} : ∏ t, tosecoverunit (λ _ : unit, X) x t = x. Proof. abstract (induction t; reflexivity). Qed. Lemma hfiber_is_pullback {X Y : hSet} (f : HSET⟦X, Y⟧) (y : Y) (y' := invweq (weqfunfromunit_HSET _) y) : ∑ H, @isPullback _ _ _ _ _ f y' (hfiberpr1 f y : HSET⟦hfiber_hSet f y , X⟧) (TerminalArrow TerminalHSET _) H. Proof. use tpair. - apply funextfun; intro. apply hfiberpr2. - intros pb pbpr1 pbpr2 pbH. (** First, simplify what we have to prove. Part of the condition is trivial. *) use iscontrweqb. + exact (∑ hk : HSET ⟦ pb, hfiber_hSet f y ⟧, hk · hfiberpr1 f y = pbpr1). + apply weqfibtototal; intro. apply invweq. apply dirprod_with_contr_r. use make_iscontr. * apply isapropifcontr. apply TerminalHSET. * intro; apply proofirrelevance; apply homset_property. + unfold hfiber_hSet, hfiber; cbn. use make_iscontr. * use tpair. intros pb0. use tpair. -- exact (pbpr1 pb0). -- cbn. apply toforallpaths in pbH. specialize (pbH pb0); cbn in pbH. refine (pbH @ _). apply tosecoverunit_compute. -- apply idpath. * intros t. apply subtypePath. -- intro; apply has_homsets_HSET. -- cbn. apply funextfun; intro; cbn. apply subtypePath. ++ intro; apply setproperty. ++ apply (toforallpaths _ _ _ (pr2 t)). Defined. (** ** Equalizers from general limits [EqualizersHSET_from_Lims] *) Require UniMath.CategoryTheory.limits.graphs.equalizers. Lemma EqualizersHSET_from_Lims : graphs.equalizers.Equalizers HSET. Proof. apply (graphs.equalizers.Equalizers_from_Lims HSET LimsHSET). Defined. (** HSET Pullbacks and Equalizers from limits to direct definition *) Section HSET_Structures. Definition HSET_Pullbacks : @limits.pullbacks.Pullbacks HSET := equiv_Pullbacks_2 HSET PullbacksHSET_from_Lims. Definition HSET_Equalizers: @limits.equalizers.Equalizers HSET := equiv_Equalizers2 HSET EqualizersHSET_from_Lims. End HSET_Structures. (** Concrete construction of equalizers of sets *) Definition Equalizers_in_HSET : Equalizers HSET. Proof. intros X Y f g ; cbn in *. simple refine ((_ ,, _) ,, _ ,, _). - exact (∑ (x : X), hProp_to_hSet (eqset (f x) (g x)))%set. - exact (λ x, pr1 x). - abstract (use funextsec ; intro z ; cbn ; exact (pr2 z)). - intros W h p. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use funextsec ; intro w ; use subtypePath ; [ intro ; apply setproperty | ] ; exact (eqtohomot (pr2 φ₁ @ !(pr2 φ₂)) w)). + simple refine (_ ,, _). * exact (λ w, h w ,, eqtohomot p w). * apply idpath. Defined. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/MonoEpiIso.v000066400000000000000000000130611451125700300247250ustar00rootroot00000000000000(** * Characterizations of monos, epis, and isos in [HSET] *) (** ** Contents - Points as global elements - Monomorphisms are exactly injective functions [MonosAreInjective_HSET] - Epimorphisms are exactly surjective functions [EpisAreSurjective_HSET] - Equivalence between isomorphisms and weak equivalences *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.categories.HSET.Core. Local Open Scope cat. Local Notation "'HSET'" := hset_category. (** ** Points as global elements *) (** See https://ncatlab.org/nlab/show/global+element *) Local Definition global_element_HSET {A : hSet} (a : A) : HSET⟦unitset, A⟧ := invweq (weqfunfromunit A) a. (** TODO: I think there is a name in UniMath for the constant function at [a], what is it? *) Local Definition global_element_HSET_paths_weq {A : hSet} (x y : A) : (x = y) ≃ (global_element_HSET x = global_element_HSET y). Proof. apply weqonpaths. Qed. Local Definition global_element_HSET_comp {A B : hSet} (f : HSET⟦A, B⟧) (x : A) : global_element_HSET x · f = global_element_HSET (f x). Proof. abstract (apply funextfun; intro z; induction z; reflexivity). Qed. Local Definition global_element_HSET_fun_weq {A B : hSet} (f : HSET⟦A, B⟧) (x y : A) : (f x = f y) ≃ (global_element_HSET x · f = global_element_HSET y · f). Proof. abstract (do 2 rewrite global_element_HSET_comp; apply global_element_HSET_paths_weq). Qed. (** ** Monomorphisms are exactly injective functions [MonosAreInjective_HSET] *) Lemma MonosAreInjective_HSET {A B : HSET} (f: HSET ⟦ A, B ⟧) : isMonic f ≃ isInjective f. Proof. apply weqimplimpl. - intro isM. apply incl_injectivity; intros b. apply invproofirrelevance; intros a1 a2. apply subtypePath; [intro; apply setproperty|]. apply global_element_HSET_paths_weq. apply isM. apply funextsec; intro t. abstract (induction t; exact (pr2 a1 @ ! pr2 a2)). - intro isI. unfold isMonic. intros ? ? ? eq. apply funextfun; intro. apply (invweq (Injectivity _ isI _ _)). apply toforallpaths in eq. apply eq. - apply isapropisMonic. - apply isaprop_isInjective. Qed. (** ** Epimorphisms are exactly surjective functions [EpisAreSurjective_HSET] *) Lemma EpisAreSurjective_HSET {A B : HSET} (f: HSET ⟦ A, B ⟧) : isEpi f ≃ issurjective f. Proof. apply weqimplimpl. - intro epif. apply epiissurjectiontosets; [apply setproperty|]. intros ? ? ? ?. apply toforallpaths. apply epif. now apply funextfun. - intros is_surj_f. intros C g h H. apply funextfun; intro. (** Get the point [x'] in the fiber above [x] *) specialize (is_surj_f x). apply (squash_to_prop is_surj_f); [apply setproperty|]. intro x'. (** Replace [x] with [f x'] *) refine (!maponpaths _ (hfiberpr2 _ _ x') @ _). refine (_ @ maponpaths _ (hfiberpr2 _ _ x')). apply toforallpaths in H. apply H. - apply isapropisEpi. apply has_homsets_HSET. - apply isapropissurjective. Qed. (** ** Equivalence between isomorphisms and weak equivalences of two [hSet]s. *) (** Given an iso, we construct a weak equivalence. This is basically unpacking and packing again. *) Lemma hset_z_iso_is_equiv (A B : ob HSET) (f : z_iso A B) : isweq (pr1 f). Proof. apply (isweq_iso _ (inv_from_z_iso f)). - intro x. set (T:=z_iso_inv_after_z_iso f). set (T':=toforallpaths _ _ _ T). apply T'. - intro x. apply (toforallpaths _ _ _ (z_iso_after_z_iso_inv f)). Defined. Lemma hset_z_iso_equiv (A B : ob HSET) : z_iso A B -> (pr1 A) ≃ (pr1 B). Proof. intro f. exists (pr1 f). apply hset_z_iso_is_equiv. Defined. (** Given a weak equivalence, we construct an iso. Again mostly unwrapping and packing. *) Lemma hset_equiv_is_z_iso (A B : hSet) (f : (pr1 A) ≃ (pr1 B)) : is_z_isomorphism (C:=HSET) (pr1 f). Proof. exists (invmap f). split; simpl. - apply funextfun; intro x; simpl in *. unfold compose, identity; simpl. apply homotinvweqweq. - apply funextfun; intro x; simpl in *. unfold compose, identity; simpl. apply homotweqinvweq. Defined. Lemma hset_equiv_z_iso (A B : ob HSET) : (pr1 A) ≃ (pr1 B) -> z_iso A B. Proof. intro f. simpl in *. exists (pr1 f). apply hset_equiv_is_z_iso. Defined. (** Both maps defined above are weak equivalences. *) Lemma hset_z_iso_equiv_is_equiv (A B : ob HSET) : isweq (hset_z_iso_equiv A B). Proof. apply (isweq_iso _ (hset_equiv_z_iso A B)). intro; apply z_iso_eq. - reflexivity. - intro; apply subtypePath. + intro; apply isapropisweq. + reflexivity. Qed. Definition hset_z_iso_equiv_weq (A B : ob HSET) : (z_iso A B) ≃ ((pr1 A) ≃ (pr1 B)). Proof. exists (hset_z_iso_equiv A B). apply hset_z_iso_equiv_is_equiv. Defined. Lemma hset_equiv_z_iso_is_equiv (A B : ob HSET) : isweq (hset_equiv_z_iso A B). Proof. apply (isweq_iso _ (hset_z_iso_equiv A B)). { intro f. apply subtypePath. { intro; apply isapropisweq. } reflexivity. } intro; apply z_iso_eq. reflexivity. Qed. Definition hset_equiv_weq_z_iso (A B : ob HSET) : (pr1 A ≃ pr1 B) ≃ z_iso A B. Proof. exists (hset_equiv_z_iso A B). apply hset_equiv_z_iso_is_equiv. Defined. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Slice.v000066400000000000000000000200351451125700300237420ustar00rootroot00000000000000(** * Slices of [HSET] *) (** ** Contents - Locally cartesian closed structure - Terminal object ([Terminal_HSET_slice]) - Binary products ([BinProducts_HSET_slice]) - General indexed products ([Products_HSET_slice]) - Exponentials ([Exponentials_HSET_slice]) - Colimits - Binary coproducts ([BinCoproducts_HSET_slice]) - The forgetful functor [HSET/X --> HSET] is a left adjoint ([is_left_adjoint_slicecat_to_cat]) Written by: Benedikt Ahrens, Anders Mörtberg October 2015 - January 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. (* flip *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.covyoneda. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Local Open Scope cat. (** ** Locally cartesian closed structure *) Section set_slicecat. Local Notation "HSET / X" := (slice_cat HSET X) (only parsing). (** *** Terminal object ([Terminal_HSET_slice]) *) Lemma Terminal_HSET_slice X : Terminal (SET / X). Proof. now apply Terminal_slice_precat. Defined. (** *** Binary products ([BinProducts_HSET_slice]) *) Lemma BinProducts_HSET_slice X : BinProducts (HSET / X). Proof. now apply BinProducts_slice_precat, PullbacksHSET. Defined. (** *** General indexed products ([Products_HSET_slice]) *) Section products_set_slice. (* The following is an experiment which computes what the product in Set/X should be from the one in [X,Set] using the equivalence between Set/X and [X,Set] *) (* Require Import UniMath.CategoryTheory.categories.HSET.SliceFamEquiv. *) (* Lemma Products_HSET_slice I X : Products I (HSET / X). *) (* Proof. *) (* intros F. *) (* set (foo1 := Products_functor_precat I (discrete_precategory (pr1 X)) HSET (ProductsHSET I) has_homsets_HSET). *) (* set (XHSET := [discrete_precategory (pr1 X), HSET, has_homsets_HSET]). *) (* set (G := λ i, slice_to_fam X (F i) : XHSET). *) (* set (foo2 := ProductObject I XHSET (foo1 G)). *) (* set (goal := pr1 (pr1 (fam_to_slice _ foo2))). *) (* cbn in goal. *) (** Products in Set/X *) Lemma Products_HSET_slice I X : Products I (HSET / X). Proof. intros F. use make_Product. + use tpair. - exists (∑ x : pr1 X, ∏ i : I, hfiber_hSet (pr2 (F i)) x). abstract (apply isaset_total2; [apply setproperty|]; now intros x; apply impred_isaset; intro i; apply setproperty). - cbn. apply pr1. + intros i. use tpair. - intros H; apply (pr1 (pr2 H i)). - abstract (now apply funextsec; intros H; apply (!pr2 (pr2 H i))). + intros f H. use unique_exists. - use tpair; simpl. * intros x. exists (pr2 f x). intros i. exists (pr1 (H i) x). abstract (exact (!toforallpaths _ _ _ (pr2 (H i)) x)). * abstract (now apply funextsec). - abstract (now intros i; apply eq_mor_slicecat, funextsec). - abstract (now intros g; apply impred_isaprop; intro i; apply has_homsets_slice_precat). - abstract(simpl; intros [y1 y2] Hy; apply eq_mor_slicecat, funextsec; intro x; use total2_paths_f; [apply (toforallpaths _ _ _ (!y2) x)|]; apply funextsec; intro i; apply subtypePath; [intros w; apply setproperty|]; destruct f as [f Hf]; unfold hfiber; rewrite transportf_sec_constant, transportf_total2; simpl; rewrite transportf_const; now rewrite <- Hy). Defined. End products_set_slice. (** *** Exponentials ([Exponentials_HSET_slice]) *) (** Direct proof that HSET/X has exponentials using explicit formula in example 2.2 of: https://ncatlab.org/nlab/show/locally+cartesian+closed+category#in_category_theory *) Definition hfiber_fun (X : HSET) (f : HSET / X) : HSET / X → HSET / X. Proof. intros g. use tpair. - exists (∑ x, HSET⟦hfiber_hSet (pr2 f) x,hfiber_hSet (pr2 g) x⟧). abstract (apply isaset_total2; [ apply setproperty | intros x; apply has_homsets_HSET ]). - cbn. now apply pr1. Defined. Definition hfiber_functor (X : HSET) (f : HSET / X) : functor (HSET / X) (HSET / X). Proof. use make_functor. + use tpair. * apply (hfiber_fun _ f). * cbn. intros a b g. { use tpair; simpl. - intros h. exists (pr1 h). intros fx. use tpair. * exact (pr1 g (pr1 (pr2 h fx))). * abstract (etrans; [ apply (!toforallpaths _ _ _ (pr2 g) (pr1 (pr2 h fx)))|]; apply (pr2 (pr2 h fx))). - abstract (now apply funextsec). } + split. - intros x; apply (eq_mor_slicecat HSET); simpl. apply funextsec; intros [y hy]. use total2_paths_f; [ apply idpath |]. apply funextsec; intros w; apply subtypePath; [|apply idpath]. now intros XX; apply setproperty. - intros x y z g h; apply (eq_mor_slicecat HSET); simpl. apply funextsec; intros [w hw]. use total2_paths_f; [ apply idpath |]. apply funextsec; intros w'. apply subtypePath; [|apply idpath]. now intros XX; apply setproperty. Defined. Local Definition eta X (f : HSET / X) : nat_trans (functor_identity (HSET / X)) (functor_composite (constprod_functor1 (BinProducts_HSET_slice X) f) (hfiber_functor X f)). Proof. use make_nat_trans. + intros g; simpl. use tpair. * intros y; simpl. exists (pr2 g y); intros fgy. exists ((pr1 fgy,,y),,(pr2 fgy)). abstract (now apply (pr2 fgy)). * abstract (now apply funextsec). + intros [g Hg] [h Hh] [w Hw]. apply (eq_mor_slicecat HSET), funextsec; intro x1. apply (two_arg_paths_f (!toforallpaths _ _ _ Hw x1)), funextsec; intro y. repeat (apply subtypePath; [intros x; apply setproperty|]); cbn in *. now induction (! toforallpaths _ _ (λ x : g, Hh (w x)) _ _). Defined. Local Definition eps X (f : HSET / X) : nat_trans (functor_composite (hfiber_functor X f) (constprod_functor1 (BinProducts_HSET_slice X) f)) (functor_identity (HSET / X)). Proof. use make_nat_trans. + intros g; simpl. use tpair. * intros H; apply (pr1 ((pr2 (pr2 (pr1 H))) (pr1 (pr1 H),,pr2 H))). * abstract (cbn; apply funextsec; intros [[x1 [x2 x3]] x4]; simpl in *; now rewrite (pr2 (x3 (x1,,x4))), x4). + intros g h w; simpl. apply (eq_mor_slicecat HSET), funextsec; intro x1; cbn. now repeat apply maponpaths; apply setproperty. Defined. Lemma Exponentials_HSET_slice (X : HSET) : Exponentials (BinProducts_HSET_slice X). Proof. intros f. exists (hfiber_functor _ f). use make_are_adjoints. - apply eta. - apply eps. - split. + intros x; apply eq_mor_slicecat, funextsec; intro x1. now apply subtypePath; [intro y; apply setproperty|]; reflexivity. + intros x; apply eq_mor_slicecat, funextsec; intro x1; simpl. use total2_paths_f; [apply idpath|]; cbn. apply funextsec; intro y. use subtypePath. * intro z; apply setproperty. * simpl. apply maponpaths. apply maponpaths. reflexivity. Defined. (** ** Colimits *) (** *** Binary coproducts ([BinCoproducts_HSET_slice]) *) Lemma BinCoproducts_HSET_slice X : BinCoproducts (HSET / X). Proof. now apply BinCoproducts_slice_precat, BinCoproductsHSET. Defined. (** ** The forgetful functor [HSET/X --> HSET] is a left adjoint *) Lemma is_left_adjoint_slicecat_to_cat_HSET (X : HSET) : is_left_adjoint (slicecat_to_cat HSET X). Proof. apply is_left_adjoint_slicecat_to_cat, BinProductsHSET. Defined. End set_slicecat. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/SliceFamEquiv.v000066400000000000000000000210211451125700300253740ustar00rootroot00000000000000(** ********************************************************** Matthew Weaver, 2016 *************************************************************) (** ********************************************************** Contents: - Proof that Set / X and Set ^ X are equivalent as categories ************************************************************) Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.categories.StandardCategories. Local Open Scope cat. Section set_slice_fam_equiv. Variable X : hSet. Local Definition slice (A : hSet) : category := slice_cat HSET A. Local Definition discrete (A : hSet) : discrete_category := discrete_category_hset A. Local Definition discrete_has_homsets (A : hSet) : has_homsets (discrete_category_hset A) := homset_property _. Local Definition fam (A : hSet) : category := functor_category (discrete A) HSET. Local Definition make_fam (f : X → hSet) : functor (discrete X) HSET := functor_path_pregroupoid _ (f : X → ob HSET). Definition slice_to_fam_fun (a : slice X) : fam X := make_fam (λ x : X, hfiber_hSet (pr2 a) x). Local Notation s_to_f := slice_to_fam_fun. Definition slice_to_fam_mor_fun {a b : slice X} (f : a --> b) (x : X) : (s_to_f a : functor (discrete X) HSET) x --> (s_to_f b : functor (discrete X) HSET) x := λ p, hfibersgftog (pr1 f) (pr2 b) _ (transportf (λ p, hfiber p x) (pr2 f) p). Definition is_nat_trans_slice_to_fam_mor {a b : slice X} (f : a --> b) : is_nat_trans (s_to_f a : functor (discrete X) HSET) (s_to_f b : functor (discrete X) HSET) (slice_to_fam_mor_fun f) := is_nat_trans_discrete_precategory (slice_to_fam_mor_fun f). Definition slice_to_fam_mor {a b : slice X} (f : a --> b) : s_to_f a --> s_to_f b := (slice_to_fam_mor_fun f) ,, (is_nat_trans_slice_to_fam_mor f). Definition slice_to_fam_data : functor_data (slice X) (fam X) := functor_data_constr _ _ slice_to_fam_fun (@slice_to_fam_mor). Lemma is_functor_slice_to_fam : is_functor slice_to_fam_data. Proof. split; [ intro a | intros a b c f g]; apply (nat_trans_eq has_homsets_HSET); intro x; apply funextsec; intro p; apply (invmaponpathsincl pr1); simpl; try (apply isofhlevelfpr1; intro; apply setproperty); repeat (unfold hfiber; rewrite transportf_total2; simpl); repeat (rewrite transportf_const); reflexivity. Qed. Definition slice_to_fam : functor (slice X) (fam X) := slice_to_fam_data ,, is_functor_slice_to_fam. Definition fam_to_slice_fun (f : fam X) : slice X := (total2_hSet (pr1 f)) ,, pr1. Local Notation f_to_s := fam_to_slice_fun. Definition fam_to_slice_mor {a b : fam X} (f : a --> b) : f_to_s a --> f_to_s b := (λ h, pr1 h ,, (pr1 f) (pr1 h) (pr2 h)) ,, (idpath (pr2 (f_to_s a))). Definition fam_to_slice_data : functor_data (fam X) (slice X) := functor_data_constr _ _ fam_to_slice_fun (@fam_to_slice_mor). Theorem is_functor_fam_to_slice : is_functor fam_to_slice_data. Proof. split; [intro f | intros f f' f'' F F']; apply eq_mor_slicecat. + apply funextsec. intro p. reflexivity. + reflexivity. Qed. Definition fam_to_slice : functor (fam X) (slice X) := fam_to_slice_data ,, is_functor_fam_to_slice. Definition slice_counit_fun (f : slice X) : (functor_composite_data slice_to_fam_data fam_to_slice_data) f --> (functor_identity_data _) f. Proof. exists (fun h : (∑ x : X, hfiber (pr2 f) x) => pr1 (pr2 h)). simpl. apply funextsec. intro p. exact (!pr2 (pr2 p)). Defined. Definition is_nat_trans_slice_counit : is_nat_trans _ _ slice_counit_fun. Proof. intros f f' F. apply eq_mor_slicecat. unfold slice_counit_fun. simpl. unfold compose. simpl. apply funextsec. intro p. unfold hfiber. rewrite transportf_total2. simpl. rewrite transportf_const. reflexivity. Qed. Definition slice_counit : nat_trans (functor_composite slice_to_fam fam_to_slice) (functor_identity (slice X)) := slice_counit_fun ,, is_nat_trans_slice_counit. Definition slice_all_z_iso : forall x : slice X, is_z_isomorphism (slice_counit x). Proof. intro x. apply z_iso_to_slice_precat_z_iso. simpl. change (fun h : total2 (λ x' : X, hfiber (@pr2 _ (λ a : hSet, forall _ : a, X) x) x') => pr1 (pr2 h)) with (fromcoconusf (pr2 x)). exact (hset_equiv_is_z_iso (make_hSet (coconusf (pr2 x)) (isaset_total2_hSet X (λ y, (hfiber_hSet (pr2 x) y)))) _ (weqfromcoconusf (pr2 x))). Qed. Definition slice_unit := pr1 (nat_trafo_z_iso_if_pointwise_z_iso (has_homsets_slice_precat HSET X) slice_counit slice_all_z_iso). Definition fam_unit_fun_fun (f : fam X) (x : X) : (pr1 ((functor_identity_data _) f)) x --> (pr1 ((functor_composite_data fam_to_slice_data slice_to_fam_data) f)) x := λ a, ((x ,, a) ,, idpath x). Definition is_nat_trans_fam_unit_fun (f : fam X) : is_nat_trans (pr1 ((functor_identity_data _) f)) (pr1 ((functor_composite_data fam_to_slice_data slice_to_fam_data) f)) (fam_unit_fun_fun f) := is_nat_trans_discrete_precategory (fam_unit_fun_fun f). Definition fam_unit_fun (f : fam X) : (functor_identity_data _) f --> (functor_composite_data fam_to_slice_data slice_to_fam_data) f := (fam_unit_fun_fun f) ,, (is_nat_trans_fam_unit_fun f). Definition is_nat_trans_fam_unit : is_nat_trans _ _ fam_unit_fun. Proof. intros f f' F. apply (nat_trans_eq has_homsets_HSET). intro x. apply funextsec. intro a. apply (invmaponpathsincl pr1). + apply isofhlevelfpr1. intro. apply setproperty. + reflexivity. Qed. Definition fam_unit : nat_trans (functor_identity (fam X)) (functor_composite fam_to_slice slice_to_fam) := fam_unit_fun ,, is_nat_trans_fam_unit. Lemma fam_z_iso (F : fam X) : z_iso ((functor_identity (fam X)) F) ((functor_composite fam_to_slice slice_to_fam) F). Proof. apply (z_iso_from_nat_z_iso has_homsets_HSET). exists ((pr1 fam_unit) F). intro x. exact (hset_equiv_is_z_iso ((pr1 F) x) (make_hSet (hfiber pr1 x) (isaset_hfiber pr1 x (isaset_total2_hSet X (λ x, (pr1 F) x)) (pr2 X))) (ezweqpr1 (funcomp (pr1 (pr1 F)) pr1) x)). Defined. Definition fam_all_z_iso (F : fam X) : is_z_isomorphism (fam_unit F) := pr2 (fam_z_iso F). Definition fam_counit := pr1 (nat_trafo_z_iso_if_pointwise_z_iso (functor_category_has_homsets _ _ has_homsets_HSET) fam_unit fam_all_z_iso). Lemma slice_fam_form_adj : form_adjunction fam_to_slice slice_to_fam fam_unit slice_counit. Proof. unfold form_adjunction. split. + intro f. apply eq_mor_slicecat. apply funextsec. intro x. reflexivity. + intro F. apply (nat_trans_eq has_homsets_HSET). intro x. apply funextsec. intro f. apply (invmaponpathsincl pr1). - apply isofhlevelfpr1. intro. apply setproperty. - simpl. unfold hfiber. rewrite transportf_total2. simpl. rewrite transportf_const. reflexivity. Defined. Definition are_adjoints_slice_fam : are_adjoints _ _ := (fam_unit ,, slice_counit) ,, slice_fam_form_adj. Definition set_slice_fam_equiv : adj_equivalence_of_cats fam_to_slice := (slice_to_fam ,, are_adjoints_slice_fam) ,, (fam_all_z_iso ,, slice_all_z_iso) . End set_slice_fam_equiv. UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Structures.v000066400000000000000000000502441451125700300250730ustar00rootroot00000000000000(** * Other structures in [HSET] *) (** ** Contents - Natural numbers object ([NNO_HSET]) - Exponentials ([Exponentials_HSET]) - Construction of exponentials for functors into HSET ([Exponentials_functor_HSET]) - Kernel pairs ([kernel_pair_HSET]) - Effective epis ([EffectiveEpis_HSET]) - Split epis with axiom of choice ([SplitEpis_HSET]) - Forgetful [functor] to [type_precat] - HSET is a topos [Topos_Structure_HSET] Written by: Benedikt Ahrens, Anders Mörtberg October 2015 - January 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. (* flip *) Require Import UniMath.MoreFoundations.Sets. (* hProp_set *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.NNO. Require Import UniMath.CategoryTheory.SubobjectClassifier. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.CategoryTheory.categories.Type.MonoEpiIso. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.covyoneda. Require Import UniMath.CategoryTheory.EpiFacts. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.SplitMonicsAndEpis. Require Import UniMath.CategoryTheory.ElementaryTopos. Require Import UniMath.CategoryTheory.PowerObject. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Local Open Scope cat. (** ** Natural numbers object ([NNO_HSET]) *) Lemma isNNO_nat : isNNO TerminalHSET natHSET (λ _, 0) S. Proof. intros X z s. use unique_exists. + intros n. induction n as [|_ n]. * exact (z tt). * exact (s n). + now split; apply funextfun; intros []. + now intros; apply isapropdirprod; apply homset_property. + intros q [hq1 hq2]. apply funextfun; intros n. induction n as [|n IH]. * now rewrite <- hq1. * cbn in *; now rewrite (toforallpaths _ _ _ hq2 n), IH. Qed. Definition NNO_HSET : NNO TerminalHSET. Proof. use make_NNO. - exact natHSET. - exact (λ _, 0). - exact S. - exact isNNO_nat. Defined. (** ** Exponentials ([Exponentials_HSET]) *) Section exponentials. (** Define the functor: A -> _^A *) Definition exponential_functor (A : HSET) : functor HSET HSET. Proof. use make_functor. + exists (funset (A : hSet)); simpl. intros b c f g; apply (λ x, f (g x)). + abstract (use tpair; [ intro x; now (repeat apply funextfun; intro) | intros x y z f g; now (repeat apply funextfun; intro)]). Defined. (** This checks that if we use constprod_functor2 the flip is not necessary *) Lemma are_adjoints_constprod_functor2 A : are_adjoints (constprod_functor2 BinProductsHSET A) (exponential_functor A). Proof. use tpair. - use tpair. + use tpair. * intro x; simpl; apply make_dirprod. * abstract (intros x y f; apply idpath). + use tpair. * intros X fx; apply (pr1 fx (pr2 fx)). * abstract (intros x y f; apply idpath). - abstract (use tpair; [ intro x; simpl; apply funextfun; intro ax; apply idpath | intro b; apply funextfun; intro f; apply idpath]). Defined. Lemma Exponentials_HSET : Exponentials BinProductsHSET. Proof. intro a. exists (exponential_functor a). use tpair. - use tpair. + use tpair. * intro x; simpl; apply flip, make_dirprod. * abstract (intros x y f; apply idpath). + use tpair. * intros x xf; simpl in *; apply (pr2 xf (pr1 xf)). * abstract (intros x y f; apply idpath). - abstract (use tpair; [ now intro x; simpl; apply funextfun; intro ax; apply idpath | now intro b; apply funextfun; intro f]). Defined. End exponentials. (** ** Construction of exponentials for functors into HSET *) (** This section defines exponential in [C,HSET] following a slight variation of Moerdijk-MacLane (p. 46, Prop. 1). The formula for [C,Set] is G^F(f)=Hom(Hom(f,−)×id(F),G) taken from: http://mathoverflow.net/questions/104152/exponentials-in-functor-categories *) Section exponentials_functor_cat. Context (C : category). Let CP := BinProducts_functor_precat C _ BinProductsHSET. Let cy := covyoneda C. (* Defined Q^P *) Local Definition exponential_functor_cat (P Q : functor C HSET) : functor C HSET. Proof. use tpair. - use tpair. + intro c. use make_hSet. * apply (nat_trans (BinProduct_of_functors C _ BinProductsHSET (cy c) P) Q). * abstract (apply (isaset_nat_trans has_homsets_HSET)). + simpl; intros a b f alpha. apply (BinProductOfArrows _ (CP (cy a) P) (CP (cy b) P) (# cy f) (identity _) · alpha). - abstract ( split; [ intros c; simpl; apply funextsec; intro a; apply (nat_trans_eq has_homsets_HSET); cbn; unfold prodtofuntoprod; intro x; apply funextsec; intro f; destruct f as [cx Px]; simpl; unfold covyoneda_morphisms_data; now rewrite id_left | intros a b c f g; simpl; apply funextsec; intro alpha; apply (nat_trans_eq has_homsets_HSET); cbn; unfold prodtofuntoprod; intro x; apply funextsec; intro h; destruct h as [cx pcx]; simpl; unfold covyoneda_morphisms_data; now rewrite assoc ]). Defined. Local Definition eval (P Q : functor C HSET) : nat_trans (BinProductObject _ (CP P (exponential_functor_cat P Q)) : functor _ _) Q. Proof. use tpair. - intros c ytheta; set (y := pr1 ytheta); set (theta := pr2 ytheta); simpl in *. use (theta c). exact (identity c,,y). - abstract ( intros c c' f; simpl; apply funextfun; intros ytheta; destruct ytheta as [y theta]; cbn; unfold prodtofuntoprod; unfold covyoneda_morphisms_data; assert (X := nat_trans_ax theta); assert (Y := toforallpaths _ _ _ (X c c' f) (identity c,, y)); eapply pathscomp0; [|apply Y]; cbn; unfold prodtofuntoprod; cbn; now rewrite id_right, id_left). Defined. (* This could be made nicer without the big abstract blocks... *) Lemma Exponentials_functor_HSET : Exponentials CP. Proof. intro P. use left_adjoint_from_partial. - apply (exponential_functor_cat P). - intro Q; simpl; apply eval. - intros Q R φ; simpl in *. use tpair. + use tpair. * { use make_nat_trans. - intros c u; simpl. use make_nat_trans. + simpl; intros d fx. apply (φ d (make_dirprod (pr2 fx) (# R (pr1 fx) u))). + intros a b f; simpl; cbn; unfold prodtofuntoprod. apply funextsec; intro x. etrans; [|apply (toforallpaths _ _ _ (nat_trans_ax φ _ _ f) (make_dirprod (pr2 x) (# R (pr1 x) u)))]; cbn. repeat (apply maponpaths). assert (H : # R (pr1 x · f) = # R (pr1 x) · #R f). { apply functor_comp. } unfold prodtofuntoprod. simpl (pr1 _); simpl (pr2 _). apply maponpaths. apply (eqtohomot H u). - intros a b f; cbn. apply funextsec; intros x; cbn. apply subtypePath; [intros xx; apply (isaprop_is_nat_trans _ _ has_homsets_HSET)|]. apply funextsec; intro y; apply funextsec; intro z; cbn. repeat apply maponpaths; unfold covyoneda_morphisms_data. assert (H : # R (f · pr1 z) = # R f · # R (pr1 z)). { apply functor_comp. } apply pathsinv0. now etrans; [apply (toforallpaths _ _ _ H x)|]. } * abstract ( apply (nat_trans_eq has_homsets_HSET); cbn; intro x; apply funextsec; intro p; apply maponpaths; assert (H : # R (identity x) = identity (R x)); [apply functor_id|]; induction p as [t p]; apply maponpaths; simpl; now apply pathsinv0; eapply pathscomp0; [apply (toforallpaths _ _ _ H p)|]). + abstract ( intros [t p]; apply subtypePath; simpl; [intros x; apply (isaset_nat_trans has_homsets_HSET)|]; apply (nat_trans_eq has_homsets_HSET); intros c; apply funextsec; intro rc; apply subtypePath; [intro x; apply (isaprop_is_nat_trans _ _ has_homsets_HSET)|]; simpl; rewrite p; cbn; clear p; apply funextsec; intro d; cbn; apply funextsec; intros [t0 pd]; simpl; assert (HH := toforallpaths _ _ _ (nat_trans_ax t c d t0) rc); cbn in HH; rewrite HH; cbn; unfold covyoneda_morphisms_data; unfold prodtofuntoprod; cbn; now rewrite id_right). Defined. End exponentials_functor_cat. (** ** Kernel pairs ([kernel_pair_HSET]) *) (* proof by Peter, copied from TypeTheory.Auxiliary.Auxiliary *) Lemma pullback_HSET_univprop_elements {P A B C : HSET} {p1 : HSET ⟦ P, A ⟧} {p2 : HSET ⟦ P, B ⟧} {f : HSET ⟦ A, C ⟧} {g : HSET ⟦ B, C ⟧} (ep : p1 · f = p2 · g) (pb : isPullback ep) : (∏ a b (e : f a = g b), ∃! ab, p1 ab = a × p2 ab = b). Proof. intros a b e. set (Pb := (make_Pullback _ pb)). apply iscontraprop1. - apply invproofirrelevance; intros [ab [ea eb]] [ab' [ea' eb']]. apply subtypePath; simpl. intros x; apply isapropdirprod; apply setproperty. use (@toforallpaths unitset _ (λ _, ab) (λ _, ab') _ tt). use (MorphismsIntoPullbackEqual pb); apply funextsec; intros []; cbn; (eapply @pathscomp0; [ eassumption | apply pathsinv0; eassumption]). - use (_,,_). use (_ tt). use (PullbackArrow Pb (unitset : HSET) (λ _, a) (λ _, b)). apply funextsec; intro; exact e. simpl; split. + generalize tt; apply toforallpaths. apply (PullbackArrow_PullbackPr1 Pb unitset). + generalize tt; apply toforallpaths. apply (PullbackArrow_PullbackPr2 Pb unitset). Defined. Section kernel_pair_Set. Context {A B: HSET}. Variable (f: HSET ⟦A,B⟧). Definition kernel_pair_HSET : kernel_pair f. red. apply PullbacksHSET. Defined. Local Notation g := kernel_pair_HSET. (** Formulation in the categorical language of the universal property enjoyed by surjections (univ_surj) *) Lemma isCoeqKernelPairSet (hf: issurjective f) : isCoequalizer _ _ _ (PullbackSqrCommutes g). Proof. intros. red. intros C u equ. assert (hcompat : ∏ x y : pr1 A, f x = f y → u x = u y). { intros x y eqfxy. assert (hpb:=pullback_HSET_univprop_elements (PullbackSqrCommutes g) (isPullback_Pullback g) x y eqfxy). assert( hpb' := pr2 (pr1 hpb)); simpl in hpb'. etrans. eapply pathsinv0. apply maponpaths. exact (pr1 hpb'). eapply pathscomp0. apply toforallpaths in equ. apply equ. cbn. apply maponpaths. exact (pr2 hpb'). } use (unique_exists (univ_surj (setproperty C) _ _ _ hf)). - exact u. - exact hcompat. - simpl. apply funextfun. intro. apply univ_surj_ax. - intro. apply has_homsets_HSET. - intros ??; simpl. apply funextfun. use univ_surj_unique. simpl in X. apply toforallpaths in X. exact X. Qed. End kernel_pair_Set. (** ** Effective epis ([EffectiveEpis_HSET]) *) Lemma EffectiveEpis_HSET : EpisAreEffective HSET. Proof. red. clear. intros A B f epif. exists (kernel_pair_HSET f). apply isCoeqKernelPairSet. now apply EpisAreSurjective_HSET. Qed. (** ** Split epis with axiom of choice ([SplitEpis_HSET]) *) Lemma SplitEpis_HSET : AxiomOfChoice_surj -> epis_are_split HSET. Proof. intros axC A B f epif. apply EpisAreSurjective_HSET,axC in epif. unshelve eapply (hinhfun _ epif). intro h. exists (pr1 h). apply funextfun. exact (pr2 h). Qed. (** ** Forgetful [functor] to [type_precat] *) Definition forgetful_HSET : functor HSET type_precat. Proof. use make_functor. - use make_functor_data. + exact pr1. + exact (λ _ _, idfun _). - split. + intro; apply idpath. + intros ? ? ? ? ?; apply idpath. Defined. (** This functor is conservative; it reflects isomorphisms. *) (** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! This statement seems problematic. This conservativity statement is for precategories, but now it is only for categories in the library !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Lemma conservative_forgetful_HSET : conservative forgetful_HSET. Proof. unfold conservative. intros a b f is_iso_forget_f. refine (hset_equiv_is_iso a b (make_weq f _)). apply (type_iso_is_equiv _ _ (make_iso _ is_iso_forget_f)). Defined. *) (** ** Subobject classifier *) Lemma isaprop_hfiber_monic {A B : hSet} (f : HSET⟦A, B⟧) (isM : isMonic f) : isPredicate (hfiber f). Proof. intro; apply incl_injectivity, MonosAreInjective_HSET; assumption. Qed. Local Definition const_htrue {X : hSet} : HSET⟦X, hProp_set⟧ := (fun _ => htrue : hProp_set). Local Lemma hProp_eq_unit (p : hProp) : p -> p = htrue. Proof. intro pp. apply weqtopathshProp, weqimplimpl. - intro; exact tt. - intro; assumption. - apply propproperty. - apply propproperty. Qed. (** Existence of the pullback square << X -------> TerminalHSET V V m | | true V ∃! V Y - - - - -> hProp >> Uniqueness proven below. *) Definition subobject_classifier_HSET_pullback {X Y : HSET} (m : Monic HSET X Y) : ∑ (chi : HSET ⟦ Y, hProp_set ⟧) (H : m · chi = TerminalArrow TerminalHSET X · const_htrue), isPullback H. Proof. exists (fun z => (hfiber (pr1 m) z,, isaprop_hfiber_monic (pr1 m) (pr2 m) z)). use tpair. + apply funextfun; intro. apply hProp_eq_unit; cbn. use make_hfiber. * assumption. * apply idpath. + (** The aforementioned square is a pullback *) cbn beta. unfold isPullback; cbn. intros Z f g H. use make_iscontr. * use tpair. -- (** The hypothesis H states that that each [f x] is in the image of [m], and since [m] is monic (injective), this assignment extends to a map [Z -> X] defined by [z ↦ m^-1 (f z)]. *) intro z. eapply hfiberpr1. eapply eqweqmap. ++ apply pathsinv0. apply (maponpaths pr1 (toforallpaths _ _ _ H z)). ++ exact tt. -- split. ++ (** The first triangle commutes by definition of the above map: [m] sends the preimage [m^-1 (f z)] to [f z]. *) apply funextfun; intro z; cbn. apply hfiberpr2. ++ (** All maps to the terminal object are equal *) apply proofirrelevance, impred. intro; apply isapropunit. * intro t. apply subtypePath. -- intro. apply isapropdirprod. ++ apply funspace_isaset, setproperty. ++ apply funspace_isaset, isasetunit. -- cbn. apply funextsec; intro; cbn. (** Precompose with [m] and use the commutative square *) apply (invweq (make_weq _ (MonosAreInjective_HSET m (MonicisMonic _ m) _ _))). eapply pathscomp0. ++ apply (toforallpaths _ _ _ (pr1 (pr2 t))). ++ apply pathsinv0. apply hfiberpr2. Defined. (** For any subset [s : Y -> hProp], the carrier [∑ y : Y, s y] is a pullback of [s] with the constantly-true arrow. *) Lemma carrier_Pullback {Y : HSET} (chi : HSET ⟦ Y, hProp_set ⟧) : Pullback chi (@const_htrue unitHSET). Proof. use make_Pullback. - exact (carrier_subset chi). - exact (pr1carrier _). - exact (TerminalArrow TerminalHSET _). - apply funextfun; intro yy. apply hProp_eq_unit; cbn. apply (pr2 yy). - cbn. intros pb' h k H. use make_iscontr. + use tpair. * intro p. use tpair. -- exact (h p). -- apply toforallpaths in H; cbn. specialize (H p); cbn in H. abstract (rewrite H; exact tt). * split; [apply idpath|]. apply proofirrelevance, hlevelntosn, iscontrfuntounit. + intro t. apply subtypePath; [intro; apply isapropdirprod; apply isaset_set_fun_space|]. apply funextfun; intro. apply subtypePath; [intro; apply propproperty|]. refine (_ @ toforallpaths _ _ _ (pr1 (pr2 t)) x). apply idpath. Defined. Lemma hfiber_in_hfiber : ∏ Z W (g : Z -> W) (w : W) (z : hfiber g w), hfiber g (g (hfiberpr1 _ _ z)). Proof. intros. use make_hfiber. - exact (hfiberpr1 _ _ z). - apply idpath. Defined. Definition subobject_classifier_HSET : subobject_classifier TerminalHSET. Proof. exists hProp_set. exists const_htrue. intros ? ? m. use make_iscontr. - (** The image of m *) apply subobject_classifier_HSET_pullback. - intro O'. apply subtypePath. + intro. apply Propositions.isaproptotal2. * intro; apply isaprop_isPullback. * intros; apply proofirrelevance, homset_property. + (** If the following is a pullback square, << X ------- ! ---> unit | | | | V V Y -- pr1 O' --> hProp >> then [pr1 O' = hfiber m]. *) assert (eq : m · pr1 O' ~ m · (fun z => (hfiber (pr1 m) z,, isaprop_hfiber_monic (pr1 m) (pr2 m) z : pr1hSet hProp_set))). { apply toforallpaths. refine (pr1 (pr2 O') @ _). apply (!pr1 (pr2 (subobject_classifier_HSET_pullback m))). } apply funextfun; intro y. apply weqtopathshProp, weqimplimpl. * intro isO. (** We know that [carrier (pr1 O')] is a pullback of [pr1 O'] and [const_htrue]. By hypothesis, X is as well. Thus, we have a canonical isomorphism [carrier (pr1 O') -> X], which commutes with the pullback projections. In particular, the following triangle commutes (where [m] is, by hypothesis, the first pullback projection of X): << ∃! carrier (pr1 O') ---> X \ | pr1carrier \ | m \ V Y >> *) pose (PBO' := make_Pullback (pr1 (pr2 O')) (pr2 (pr2 O'))). pose (PBC := carrier_Pullback (pr1 O')). pose (pbiso := pullbackiso _ PBC PBO'). use make_hfiber. -- exact (morphism_from_z_iso _ _ (pr1 pbiso) (y,, isO)). -- change (pr1 m (morphism_from_z_iso _ _ (pr1 pbiso) (y,, isO))) with (((pr1 pbiso) · pr1 m) (y,, isO)). change (pr1 m) with (PullbackPr1 PBO'). pose (pr1 (pr2 pbiso)) as p. exact (maponpaths (λ z, z _) p). * intros fib. apply (eqweqmap (maponpaths pr1 (maponpaths (pr1 O') (pr2 fib)))). apply (eqweqmap (maponpaths pr1 (eq (hfiberpr1 _ _ fib)))). apply hfiber_in_hfiber. * apply propproperty. * apply propproperty. Defined. Definition Topos_Structure_HSET : Topos_Structure HSET. Proof. use make_Topos_Structure. + exact PullbacksHSET. + exact TerminalHSET. + exact subobject_classifier_HSET. + use PowerObject_from_exponentials. assert (p : (BinProductsFromPullbacks PullbacksHSET TerminalHSET) = BinProductsHSET). { use proofirrelevance. use impredtwice. repeat intro. use isaprop_BinProduct. use is_univalent_HSET. } rewrite p. use Exponentials_HSET. Defined.UniMath-20231010/UniMath/CategoryTheory/categories/HSET/Univalence.v000066400000000000000000000033641451125700300250020ustar00rootroot00000000000000(** * HSET is a univalent_category ([is_univalent_HSET]) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.HLevels. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Local Open Scope cat. (** ** HSET is a univalent_category. *) Definition hset_id_weq_z_iso (A B : ob HSET) : (A = B) ≃ (z_iso A B) := weqcomp (UA_for_HLevels 2 A B) (hset_equiv_weq_z_iso A B). (** The map [precat_paths_to_iso] for which we need to show [isweq] is actually equal to the carrier of the weak equivalence we constructed above. We use this fact to show that that [precat_paths_to_iso] is an equivalence. *) Lemma hset_id_weq_iso_is (A B : ob HSET): @idtoiso _ A B = pr1 (hset_id_weq_z_iso A B). Proof. apply funextfun. intro p; elim p. apply z_iso_eq; simpl. - apply funextfun; intro x; destruct A. apply idpath. Defined. Lemma is_weq_precat_paths_to_iso_hset (A B : ob HSET): isweq (@idtoiso _ A B). Proof. rewrite hset_id_weq_iso_is. apply (pr2 (hset_id_weq_z_iso A B)). Defined. Definition category_HSET : category := make_category HSET has_homsets_HSET. Lemma is_univalent_HSET : is_univalent category_HSET. Proof. intros a b. apply (is_weq_precat_paths_to_iso_hset a b). Defined. Definition HSET_univalent_category : univalent_category := _ ,, is_univalent_HSET. UniMath-20231010/UniMath/CategoryTheory/categories/KleisliCategory.v000066400000000000000000000464271451125700300252470ustar00rootroot00000000000000(******************************************************************** The Kleisli category The usual definition of the Kleisli category (given in the file `Monads.KleisliCategory.v` does not give rise to a univalent category. In this file, we give an alternative definition of the Kleisli category in such a way that we do get a univalent category. This definition can be found here: https://ncatlab.org/nlab/show/Kleisli+category#in_terms_of_free_algebras We also prove its universal property. Note: to prove its universal property, we use that the usual definition of the Kleisli category (which is not necessarily univalent), satisfies the universal property. We also use that we have a weak equivalence between these two categories. Contents 1. The free algebra functor 2. The univalent Kleisli category 3. The weak equivalence 4. The universal property ********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.Monads.KleisliCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecompEquivalence. Local Open Scope cat. (** 1. The free algebra functor *) Section FreeAlgebraFunctor. Context {C : category} (m : Monad C). Definition free_alg_em_data : functor_data C (eilenberg_moore_cat m). Proof. use make_functor_data. - refine (λ x, make_ob_eilenberg_moore m (m x) (μ m x) _ _). + apply Monad_law1. + refine (!_). apply Monad_law3. - simple refine (λ x y f, make_mor_eilenberg_moore _ _ _). + exact (#m f). + exact (!(nat_trans_ax (μ m) _ _ f)). Defined. Definition free_alg_em_is_functor : is_functor free_alg_em_data. Proof. split. - intro x. use eq_mor_eilenberg_moore ; cbn. apply functor_id. - intros x y z f g. use eq_mor_eilenberg_moore ; cbn. apply functor_comp. Qed. Definition free_alg_em : C ⟶ eilenberg_moore_cat m. Proof. use make_functor. - exact free_alg_em_data. - exact free_alg_em_is_functor. Defined. End FreeAlgebraFunctor. (** 2. The univalent Kleisli category *) Definition kleisli_cat {C : category} (m : Monad C) : category := full_img_sub_precategory (free_alg_em m). Definition univalent_kleisli_cat {C : univalent_category} (m : Monad C) : univalent_category := @univalent_image C (eilenberg_moore_univalent_cat C m) (free_alg_em m). Definition is_z_iso_kleisli_cat {C : category} (m : Monad C) {x₁ x₂ : kleisli_cat m} {f : x₁ --> x₂} (Hf : is_z_isomorphism (pr111 f)) : is_z_isomorphism f. Proof. use is_iso_full_sub. use is_z_iso_eilenberg_moore. exact Hf. Defined. Definition z_iso_kleisli_cat {C : category} (m : Monad C) {x₁ x₂ : kleisli_cat m} (f : z_iso (pr1 x₁) (pr1 x₂)) : z_iso x₁ x₂. Proof. simple refine (_ ,, _). - exact (pr1 f ,, tt). - use is_iso_full_sub. exact (pr2 f). Defined. Definition from_z_iso_kleisli_cat {C : category} (m : Monad C) {x₁ x₂ : kleisli_cat m} (f : z_iso x₁ x₂) : z_iso (pr111 x₁) (pr111 x₂). Proof. use make_z_iso. - exact (pr1 (pr111 f)). - exact (pr111 (inv_from_z_iso f)). - split. + exact (maponpaths (λ z, pr111 z) (z_iso_inv_after_z_iso f)). + exact (maponpaths (λ z, pr111 z) (z_iso_after_z_iso_inv f)). Defined. Definition eq_mor_kleisli_cat {C : category} (m : Monad C) {x₁ x₂ : kleisli_cat m} {f₁ f₂ : x₁ --> x₂} (p : pr111 f₁ = pr111 f₂) : f₁ = f₂. Proof. use subtypePath. { intro. apply isapropunit. } use eq_mor_eilenberg_moore. exact p. Qed. Definition kleisli_incl {C : category} (m : Monad C) : C ⟶ kleisli_cat m := functor_full_img _. Definition kleisli_nat_trans {C : category} (m : Monad C) : m ∙ kleisli_incl m ⟹ kleisli_incl m. Proof. use make_nat_trans. - intro x. simple refine (_ ,, tt). use make_mor_eilenberg_moore ; cbn. + exact (μ m x). + abstract (refine (!_) ; apply Monad_law3). - abstract (intros x y f ; use eq_mor_kleisli_cat ; cbn ; apply (nat_trans_ax (μ m))). Defined. (** 3. The weak equivalence *) Definition functor_to_kleisli_cat_data {C : category} (m : Monad C) : functor_data (Kleisli_cat_monad m) (kleisli_cat m). Proof. use make_functor_data. - refine (λ x, free_alg_em m x ,, hinhpr (x ,, _)). apply identity_z_iso. - refine (λ x y f, _ ,, tt). use make_mor_eilenberg_moore. + exact (# m f · μ m y). + abstract (cbn ; rewrite !assoc ; refine (maponpaths (λ z, z · _) (!(nat_trans_ax (μ m) _ _ f)) @ _) ; cbn ; rewrite !functor_comp ; rewrite !assoc' ; apply maponpaths ; refine (!_) ; apply Monad_law3). Defined. Definition functor_to_kleisli_cat_is_functor {C : category} (m : Monad C) : is_functor (functor_to_kleisli_cat_data m). Proof. split. - intro x. use eq_mor_kleisli_cat. cbn. apply Monad_law2. - intros x y z f g. use eq_mor_kleisli_cat. cbn ; unfold bind. rewrite !functor_comp. rewrite !assoc'. apply maponpaths. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (μ m)). } cbn. rewrite !assoc'. apply maponpaths. refine (!_). apply Monad_law3. Qed. Definition functor_to_kleisli_cat {C : category} (m : Monad C) : Kleisli_cat_monad m ⟶ kleisli_cat m. Proof. use make_functor. - exact (functor_to_kleisli_cat_data m). - exact (functor_to_kleisli_cat_is_functor m). Defined. Definition functor_to_kleisli_cat_incl_nat_trans {C : category} (m : Monad C) : kleisli_incl m ⟹ Left_Kleisli_functor m ∙ functor_to_kleisli_cat m. Proof. use make_nat_trans. - refine (λ x, make_mor_eilenberg_moore _ (identity _) _ ,, tt). abstract (cbn ; rewrite functor_id, id_left, id_right ; apply idpath). - abstract (intros x y f ; use eq_mor_kleisli_cat ; cbn ; rewrite id_left, id_right ; rewrite functor_comp ; rewrite !assoc' ; refine (!_) ; refine (_ @ id_right _) ; apply maponpaths ; apply Monad_law2). Defined. Definition functor_to_kleisli_cat_incl_nat_z_iso {C : category} (m : Monad C) : nat_z_iso (kleisli_incl m) (Left_Kleisli_functor m ∙ functor_to_kleisli_cat m). Proof. use make_nat_z_iso. - exact (functor_to_kleisli_cat_incl_nat_trans m). - intro. use is_z_iso_kleisli_cat. apply is_z_isomorphism_identity. Defined. Definition full_functor_to_kleisli_cat {C : category} (m : Monad C) : full (functor_to_kleisli_cat m). Proof. intros x y f. apply hinhpr. simple refine (_ ,, _). - exact (η m x · pr111 f). - use eq_mor_kleisli_cat. cbn. rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. exact (!(pr211 f)). } cbn. rewrite !assoc. etrans. { apply maponpaths_2. apply Monad_law2. } apply id_left. Qed. Definition faithful_functor_to_kleisli_cat {C : category} (m : Monad C) : faithful (functor_to_kleisli_cat m). Proof. intros x y f. use invproofirrelevance. intros ψ₁ ψ₂. use subtypePath. { intro. apply homset_property. } pose (pr2 ψ₁ @ !(pr2 ψ₂)) as p. cbn in p. pose (maponpaths (λ z, η m _ · pr111 z) p) as q. cbn in q. rewrite !assoc in q. refine (_ @ q @ _). - refine (!_). etrans. { apply maponpaths_2. exact (!(nat_trans_ax (η m) _ _ (pr1 ψ₁))). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply Monad_law1. } apply id_right. - etrans. { apply maponpaths_2. exact (!(nat_trans_ax (η m) _ _ (pr1 ψ₂))). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply Monad_law1. } apply id_right. Qed. Definition fully_faithful_functor_to_kleisli_cat {C : category} (m : Monad C) : fully_faithful (functor_to_kleisli_cat m). Proof. use full_and_faithful_implies_fully_faithful. split. - exact (full_functor_to_kleisli_cat m). - exact (faithful_functor_to_kleisli_cat m). Defined. Definition essentially_surjective_functor_to_kleisli_cat {C : category} (m : Monad C) : essentially_surjective (functor_to_kleisli_cat m). Proof. intro x. induction x as [ x Hx ]. revert Hx. use factor_dep_through_squash. - intro. apply isapropishinh. - intros Hx. apply hinhpr. refine (pr1 Hx ,, _). use z_iso_kleisli_cat. exact (pr2 Hx). Defined. (** 4. The universal property *) Section KleisliUMP1. Context {C₁ C₂ : univalent_category} (m : Monad C₁) (F : C₁ ⟶ C₂) (γ : m ∙ F ⟹ F) (p₁ : ∏ (x : C₁), #F (η m x) · γ x = identity _) (p₂ : ∏ (x : C₁), γ _ · γ x = #F (μ m x) · γ x). Definition functor_from_univalent_kleisli_cat : kleisli_cat m ⟶ C₂ := lift_functor_along C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (functor_from_kleisli_cat_monad m F γ p₁ p₂). Definition functor_from_univalent_kleisli_cat_nat_trans : kleisli_incl m ∙ functor_from_univalent_kleisli_cat ⟹ F := nat_trans_comp _ _ _ (nat_trans_comp _ _ _ (post_whisker (functor_to_kleisli_cat_incl_nat_z_iso m) functor_from_univalent_kleisli_cat) (pre_whisker _ (lift_functor_along_comm C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (functor_from_kleisli_cat_monad m F γ p₁ p₂)))) (functor_from_kleisli_cat_monad_nat_trans m F γ p₁ p₂). Definition functor_from_univalent_kleisli_cat_nat_trans_is_z_iso : is_nat_z_iso functor_from_univalent_kleisli_cat_nat_trans. Proof. unfold functor_from_univalent_kleisli_cat_nat_trans. use (@is_nat_z_iso_comp _ _ _ _ _ _ (functor_from_kleisli_cat_monad_nat_trans m F γ p₁ p₂)). - use (@is_nat_z_iso_comp _ _ _ (Left_Kleisli_functor m ∙ functor_to_kleisli_cat m ∙ functor_from_univalent_kleisli_cat)). + use post_whisker_z_iso_is_z_iso. apply (functor_to_kleisli_cat_incl_nat_z_iso m). + use (pre_whisker_on_nat_z_iso (Left_Kleisli_functor m) (lift_functor_along_comm C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (functor_from_kleisli_cat_monad m F γ p₁ p₂))). apply (lift_functor_along_comm C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (functor_from_kleisli_cat_monad m F γ p₁ p₂)). - apply functor_from_kleisli_cat_monad_nat_trans_is_z_iso. Defined. Definition functor_from_univalent_kleisli_cat_eq (x : C₁) : functor_from_univalent_kleisli_cat_nat_trans (m x) · γ x = # functor_from_univalent_kleisli_cat (kleisli_nat_trans m x) · functor_from_univalent_kleisli_cat_nat_trans x. Proof. cbn -[lift_functor_along_comm functor_from_univalent_kleisli_cat]. etrans. { apply maponpaths_2. apply id_right. } etrans. { do 2 apply maponpaths_2. refine (_ @ functor_id _ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } etrans. { apply maponpaths_2. apply id_left. } refine (!_). etrans. { apply maponpaths. refine (id_right _ @ _). etrans. { apply maponpaths_2. refine (_ @ functor_id _ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } apply id_left. } pose (nat_trans_ax (lift_functor_along_comm C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (functor_from_kleisli_cat_monad m F γ p₁ p₂)) (m x) x (kleisli_monad_nat_trans m x)) as p. refine (_ @ p @ _). - apply maponpaths_2. refine (maponpaths (λ z, # _ z) _). use eq_mor_kleisli_cat. cbn. rewrite functor_id, id_left. apply idpath. - apply maponpaths. cbn. rewrite functor_id, id_left. apply idpath. Qed. End KleisliUMP1. Section KleisliUMP2. Context {C₁ C₂ : univalent_category} (m : Monad C₁) {G₁ G₂ : kleisli_cat m ⟶ C₂} (α : kleisli_incl m ∙ G₁ ⟹ kleisli_incl m ∙ G₂) (p : ∏ (x : C₁), #G₁ (kleisli_nat_trans m x) · α x = α (m x) · # G₂ (kleisli_nat_trans m x)). Definition nat_trans_from_univalent_kleisli_cat_help : Left_Kleisli_functor m ∙ (functor_to_kleisli_cat m ∙ G₁) ⟹ Left_Kleisli_functor m ∙ (functor_to_kleisli_cat m ∙ G₂) := nat_trans_comp _ _ _ (nat_trans_comp _ _ _ (post_whisker (nat_z_iso_inv (functor_to_kleisli_cat_incl_nat_z_iso m)) _) α) (post_whisker (functor_to_kleisli_cat_incl_nat_z_iso m) _). Definition nat_trans_from_univalent_kleisli_cat_help_eq (x : C₁) : # (functor_to_kleisli_cat m ∙ G₁) (kleisli_monad_nat_trans m x) · nat_trans_from_univalent_kleisli_cat_help x = nat_trans_from_univalent_kleisli_cat_help (m x) · # (functor_to_kleisli_cat m ∙ G₂) (kleisli_monad_nat_trans m x). Proof. refine (_ @ p x @ _). - cbn. rewrite !assoc. rewrite <- (functor_comp G₁). etrans. { apply maponpaths. refine (_ @ functor_id G₂ _). apply maponpaths. use subtypePath ; [ intro ; apply isapropunit | ]. use eq_mor_eilenberg_moore. apply idpath. } rewrite id_right. apply maponpaths_2. apply maponpaths. use eq_mor_kleisli_cat. cbn. rewrite functor_id. rewrite id_left, id_right. apply idpath. - cbn. rewrite !assoc'. refine (!_). etrans. { apply maponpaths_2. refine (_ @ functor_id G₁ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } rewrite id_left. rewrite <- (functor_comp G₂). do 2 apply maponpaths. use eq_mor_kleisli_cat. cbn. rewrite functor_id. rewrite !id_left. apply idpath. Qed. Definition nat_trans_from_univalent_kleisli_cat : G₁ ⟹ G₂ := lift_nat_trans_along C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (nat_trans_from_kleisli_cat_monad m nat_trans_from_univalent_kleisli_cat_help nat_trans_from_univalent_kleisli_cat_help_eq). Definition pre_whisker_nat_trans_from_univalent_kleisli_cat : pre_whisker _ nat_trans_from_univalent_kleisli_cat = α. Proof. use nat_trans_eq. { apply homset_property. } intro x. pose (nat_trans_eq_pointwise (lift_nat_trans_along_comm C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m) (nat_trans_from_kleisli_cat_monad m nat_trans_from_univalent_kleisli_cat_help nat_trans_from_univalent_kleisli_cat_help_eq)) x) as q. refine (q @ _). cbn. etrans. { apply maponpaths. refine (_ @ functor_id G₂ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } refine (id_right _ @ _). etrans. { apply maponpaths_2. refine (_ @ functor_id G₁ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } apply id_left. Qed. Definition nat_trans_from_univalent_kleisli_cat_unique {β₁ β₂ : G₁ ⟹ G₂} (q₁ : pre_whisker _ β₁ = α) (q₂ : pre_whisker _ β₂ = α) : β₁ = β₂. Proof. use (lift_nat_trans_eq_along C₂ (functor_to_kleisli_cat m) (essentially_surjective_functor_to_kleisli_cat m) (fully_faithful_functor_to_kleisli_cat m)). use (@nat_trans_from_kleisli_cat_monad_unique _ _ m (functor_to_kleisli_cat m ∙ G₁) (functor_to_kleisli_cat m ∙ G₂)). - exact nat_trans_from_univalent_kleisli_cat_help. - use nat_trans_eq. { apply homset_property. } intro ; cbn. refine (nat_trans_eq_pointwise q₁ _ @ _). refine (!_). etrans. { apply maponpaths. refine (_ @ functor_id G₂ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } refine (id_right _ @ _). etrans. { apply maponpaths_2. refine (_ @ functor_id G₁ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } apply id_left. - use nat_trans_eq. { apply homset_property. } intro ; cbn. refine (nat_trans_eq_pointwise q₂ _ @ _). refine (!_). etrans. { apply maponpaths. refine (_ @ functor_id G₂ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } refine (id_right _ @ _). etrans. { apply maponpaths_2. refine (_ @ functor_id G₁ _). apply maponpaths. use eq_mor_kleisli_cat. apply idpath. } apply id_left. Qed. End KleisliUMP2. UniMath-20231010/UniMath/CategoryTheory/categories/Relations.v000066400000000000000000000322251451125700300241040ustar00rootroot00000000000000(* The category REL of (homotopy) relations: 1. The objects are sets 2. The morphisms are relations of sets Furthermore, we show that REL is univalent. Because any invertible relation is a function, this reduces to using that SET is univalent. Therefore, we show that 1: The isomorphisms in REL are equivalent to the isomorphisms in SET 2: Idtoiso_REL factors through Idtoiso_HSET *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.HSET.All. Local Open Scope cat. Section Relations. Definition bin_hrel (X Y : hSet) : UU := X -> Y -> hProp. Identity Coercion idbin_hrel : bin_hrel >-> Funclass. Definition REL_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor hSet bin_hrel. Definition REL_precategory_id_comp : precategory_id_comp REL_precategory_ob_mor. Proof. exists (λ _ x1 x2, eqset x1 x2). exact (λ X Y Z r1 r2 x z, ∃ y : pr1 Y, r1 x y × r2 y z). Defined. Definition REL_precategory_data : precategory_data. Proof. exists REL_precategory_ob_mor. exact REL_precategory_id_comp. Defined. Lemma REL_is_precategory : is_precategory REL_precategory_data. Proof. repeat split ; intro ; intros ; repeat (apply funextsec ; intro) ; use hPropUnivalence. - intro p. use (factor_through_squash_hProp (f _ _) _ p). clear p ; intro p. induction (! pr12 p). exact (pr22 p). - intro p. apply hinhpr. exact (x ,, idpath _ ,, p). - intro p. use (factor_through_squash_hProp (f _ _) _ p). clear p ; intro p. induction (pr22 p). exact (pr12 p). - intro p. apply hinhpr. exact (x0 ,, p ,, idpath _). - intro p. use (factor_through_squash_hProp ((f · g · h) x x0) _ p). clear p ; intro p. use (factor_through_squash_hProp ((f · g · h) x x0) _ (pr22 p)). intro q. apply hinhpr. exists (pr1 q). split. + apply hinhpr. exact (pr1 p ,, pr12 p ,, pr12 q). + exact (pr22 q). - intro p. use (factor_through_squash_hProp ((f · (g · h)) x x0) _ p). + clear p ; intro p. use (factor_through_squash_hProp ((f · (g · h)) x x0) _ (pr12 p)). intro q. apply hinhpr. exists (pr1 q). split. * exact (pr12 q). * apply hinhpr. exact (pr1 p,, pr22 q ,, pr22 p). - intro p. use (factor_through_squash_hProp ((f · (g · h)) x x0) _ p). + clear p ; intro p. use (factor_through_squash_hProp ((f · (g · h)) x x0) _ (pr12 p)). intro q. apply hinhpr. exists (pr1 q). split. * exact (pr12 q). * apply hinhpr. exact (pr1 p,, pr22 q ,, pr22 p). - intro p. use (factor_through_squash_hProp ((f · g · h) x x0) _ p). + clear p ; intro p. use (factor_through_squash_hProp _ _ (pr22 p)). intro q. apply hinhpr. exists (pr1 q). split. * apply hinhpr. exact (pr1 p ,, pr12 p ,, pr12 q). * exact (pr22 q). Qed. Definition REL_precategory : precategory := _ ,, REL_is_precategory. Lemma REL_precategory_has_homsets : has_homsets REL_precategory. Proof. exact (λ _ _, isaset_set_fun_space (pr1 _) (_ ,, isaset_set_fun_space _ (_ ,, isasethProp))). Qed. Definition REL : category := REL_precategory ,, REL_precategory_has_homsets. End Relations. Section SET_as_full_sub_of_REL. Definition function_to_bin_hrel {X Y : hSet} (f : X -> Y) : bin_hrel X Y := λ x y, eqset (f x) y. Lemma invertiblefunction_to_invertiblerelation_laws {X Y : hSet} {f : X → Y} (i : is_z_isomorphism (C := HSET) f) : (function_to_bin_hrel f : REL⟦_,_⟧) · function_to_bin_hrel (pr1 i) = identity (C := REL) X. Proof. apply funextsec ; intro x1. apply funextsec ; intro x2. use hPropUnivalence. + intro q. use (factor_through_squash_hProp (eqset x1 x2) _ q). clear q ; intro q. refine (! eqtohomot (pr12 i) x1 @ _ @ pr22 q). apply (maponpaths (pr1 i)). exact (pr12 q). + intro p ; induction p. apply hinhpr. exact (f x1 ,, idpath _ ,, eqtohomot (pr12 i) x1). Qed. Definition invertiblefunction_to_invertiblerelation {X Y : hSet} {f : X -> Y} (i : is_z_isomorphism (C := HSET) f) : is_z_isomorphism (C := REL) (function_to_bin_hrel f). Proof. apply (make_is_z_isomorphism (C := REL) _ (function_to_bin_hrel (pr1 i))). split. - exact (invertiblefunction_to_invertiblerelation_laws i). - exact (invertiblefunction_to_invertiblerelation_laws (is_z_iso_inv_from_z_iso ((_ ,, i) : z_iso (C := HSET) _ _))). Defined. Definition z_iso_in_SET_to_z_iso_in_REL {X Y : HSET} (i : z_iso (C := HSET) X Y) : z_iso (C := REL) X Y := _ ,, invertiblefunction_to_invertiblerelation (pr2 i). End SET_as_full_sub_of_REL. Section Isos. Lemma inverse_swap_relation {X Y : hSet} {r : bin_hrel X Y} (i : is_z_isomorphism (C := REL) r) : ∏ (x : X) (y : Y), r x y -> pr1 i y x. Proof. intros x y p. set (t := eqtohomot (eqtohomot (pr12 i) x) x). set (q := path_to_fun (X := eqset x x) (! (base_paths _ _ t)) (idpath x)). use (factor_through_squash_hProp _ _ q). clear q ; intro q. assert (q0 : pr1 q = y). { set (ty := eqtohomot (eqtohomot (pr22 i) (pr1 q)) y). use (path_to_fun (base_paths _ _ ty)). apply hinhpr. exists x. split. - exact (pr22 q). - exact p. } induction q0. exact (pr22 q). Qed. Lemma inverse_swap_relation_iff {X Y : hSet} {r : bin_hrel X Y} (i : is_z_isomorphism (C := REL) r) : ∏ (x : X) (y : Y), r x y <-> pr1 i y x. Proof. intros x y. split. - exact (inverse_swap_relation i x y). - exact (inverse_swap_relation (pr2 (z_iso_inv ((r,,i) : z_iso (C := REL) _ _))) y x). Qed. Definition invertible_relation_is_functional {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : ∏ (x : X) (y1 y2 : Y), r x y1 -> r x y2 -> y1 = y2. Proof. intros x y1 y2 r1 r2. set (q' := base_paths _ _ (eqtohomot (eqtohomot (pr22 p) y1) y2)). apply (path_to_fun q'). apply hinhpr. exists x. split. 2: exact r2. exact (inverse_swap_relation p _ _ r1). Qed. Definition bin_hrel_is_z_iso_to_image_isaprop {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : ∏ x : X, isaprop (∑ y : Y, r x y). Proof. intros x. apply isaproptotal2. - intro ; apply r. - intros y1 y2. apply invertible_relation_is_functional. exact p. Qed. Definition bin_hrel_is_z_iso_to_image {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : ∏ x : X, ∑ y : Y, r x y. Proof. intro x. set (q := pr12 p). set (q' := base_paths _ _ (!(eqtohomot ((eqtohomot q) x) x))). set (y := path_to_fun q' (idpath _)). use (factor_through_squash_hProp (_ ,, bin_hrel_is_z_iso_to_image_isaprop p x) _ y). intro v. exact (pr1 v ,, pr12 v). Defined. Definition bin_hrel_is_z_iso_to_function {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : X -> Y := λ x, pr1 (bin_hrel_is_z_iso_to_image p x). Definition is_z_iso_in_REL_to_unique_image {X Y : hSet} (r : bin_hrel X Y) : is_z_isomorphism (C := REL) r -> (∏ x: X, ∃! y : Y, r x y). Proof. intro i. intro x. exists (bin_hrel_is_z_iso_to_image i x). intro. apply (bin_hrel_is_z_iso_to_image_isaprop i x). Defined. Definition unique_image_to_inverse_law_in_REL {X Y : hSet} {r : bin_hrel X Y} (py : (∏ y : Y, ∃! x : X, r x y)) (px : ∏ x: X, ∃! y : Y, r x y) (x1 x2 : X) : (∃ y : pr1 Y, r x1 y × r x2 y) = eqset x1 x2. Proof. apply hPropUnivalence. + intro q. use (factor_through_squash_hProp _ _ q). clear q ; intros [y q]. refine (base_paths _ _ (pr2 (py y) (x1 ,, pr1 q)) @ _). exact (! base_paths _ _ (pr2 (py y) (x2 ,, pr2 q))). + intro q. induction q. apply hinhpr. exists (pr11 (px x1)). split ; apply (pr21 (px x1)). Qed. Definition unique_image_to_is_z_iso_in_REL {X Y : hSet} (r : bin_hrel X Y) : (∏ x: X, ∃! y : Y, r x y) × (∏ y : Y, ∃! x : X, r x y) -> is_z_isomorphism (C := REL) r. Proof. intros [px py]. exists (λ y x, r x y). split ; repeat (apply funextsec ; intro). - apply (unique_image_to_inverse_law_in_REL py px). - apply (unique_image_to_inverse_law_in_REL px py). Defined. Local Lemma exists_unique_function {X : UU} (P Q : X -> hProp) : (∏ x : X, P x <-> Q x) -> (∃! x : X, P x) -> (∃! x : X, Q x). Proof. intros a [x p]. exists (pr1 x ,, pr1 (a (pr1 x)) (pr2 x)). intro t. use total2_paths_f. - use (base_paths _ _ (p (pr1 t ,, _))). exact (pr2 (a (pr1 t)) (pr2 t)). - apply (pr2 (Q _)). Qed. Definition is_z_iso_in_REL_simplified {X Y : hSet} (r : bin_hrel X Y) : is_z_isomorphism (C := REL) r <-> (∏ x: X, ∃! y : Y, r x y) × (∏ y : Y, ∃! x : X, r x y). Proof. split. - intro i. split. + exact (is_z_iso_in_REL_to_unique_image _ i). + intro y. set (j := pr2 (z_iso_inv ((r ,, i) : z_iso (C := REL) _ _))). set (P := λ x : X, inv_from_z_iso ((r,, i) : z_iso (C := REL) _ _) y x). set (Q := λ x : X, r x y). set (p := is_z_iso_in_REL_to_unique_image _ j y). use (exists_unique_function P Q _ p). intro x. exact (inverse_swap_relation_iff j y x). - apply unique_image_to_is_z_iso_in_REL. Qed. Definition bin_hrel_is_z_iso_to_equality_inverse_law {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : ∏ x : X, pr1 (bin_hrel_is_z_iso_to_image (is_z_iso_inv_from_z_iso (r,, p : z_iso (C := REL) X Y)) (pr1 (bin_hrel_is_z_iso_to_image p x))) = x. Proof. intro x. use (invertible_relation_is_functional (pr2 (z_iso_inv ((r,,p) : z_iso (C := REL) X Y)))). - exact (bin_hrel_is_z_iso_to_function p x). - exact (pr2 (bin_hrel_is_z_iso_to_image (is_z_iso_inv_from_z_iso ((r,, p) : z_iso (C := REL) _ _)) (pr1 (bin_hrel_is_z_iso_to_image p x)))). - apply inverse_swap_relation_iff. exact (pr2 (bin_hrel_is_z_iso_to_image p x)). Qed. Definition bin_hrel_is_z_iso_to_equality {X Y : hSet} {r : bin_hrel X Y} (p : is_z_isomorphism (C := REL) r) : z_iso (C := HSET) X Y. Proof. set (j := (r ,, p : z_iso (C := REL) X Y)). set (i := is_z_iso_inv_from_z_iso j). use make_z_iso. - exact (bin_hrel_is_z_iso_to_function p). - exact (bin_hrel_is_z_iso_to_function i). - abstract (split ; (apply funextsec ; intro) ; [ apply bin_hrel_is_z_iso_to_equality_inverse_law | apply (bin_hrel_is_z_iso_to_equality_inverse_law i)]). Defined. Lemma bin_hrel_z_iso_equiv_hset_z_iso_law {X Y : hSet} (i : z_iso (C := HSET) X Y) : bin_hrel_is_z_iso_to_function (invertiblefunction_to_invertiblerelation (pr2 i)) = pr1 i. Proof. apply funextsec ; intro x. exact (base_paths _ _ (pr1 (bin_hrel_is_z_iso_to_image_isaprop (invertiblefunction_to_invertiblerelation (pr2 i)) x (bin_hrel_is_z_iso_to_image (invertiblefunction_to_invertiblerelation (pr2 i)) x) (pr1 i x ,, idpath _)))). Qed. Lemma bin_hrel_z_iso_equiv_hset_z_iso_law' {X Y : hSet} (i : z_iso (C := REL) X Y) : function_to_bin_hrel (bin_hrel_is_z_iso_to_function (pr2 i)) = pr1 i. Proof. apply funextsec ; intro x. apply funextsec ; intro y. set (q := bin_hrel_is_z_iso_to_image_isaprop (pr2 i) x (bin_hrel_is_z_iso_to_image (pr2 i) x)). apply hPropUnivalence. - intro p. induction p. exact (pr2 (bin_hrel_is_z_iso_to_image (pr2 i) x)). - intro p. set (c := bin_hrel_is_z_iso_to_image_isaprop (pr2 i) x (bin_hrel_is_z_iso_to_image (pr2 i) x) (y,,p)). exact (base_paths _ _ (pr1 c)). Qed. Definition bin_hrel_z_iso_equiv_hset_z_iso (X Y : hSet) : z_iso (C := HSET) X Y ≃ z_iso (C := REL) X Y. Proof. use weq_iso. - exact (λ i, z_iso_in_SET_to_z_iso_in_REL i). - exact (λ i, bin_hrel_is_z_iso_to_equality (pr2 i)). - intro ; apply z_iso_eq, bin_hrel_z_iso_equiv_hset_z_iso_law. - intro ; apply z_iso_eq, bin_hrel_z_iso_equiv_hset_z_iso_law'. Defined. End Isos. Section Univalence. Lemma is_univalent_REL : is_univalent REL. Proof. intros X Y. use weqhomot. - exact (bin_hrel_z_iso_equiv_hset_z_iso X Y ∘ make_weq _ (is_univalent_HSET X Y))%weq. - intro p ; induction p. use (z_iso_eq (C := REL)). do 2 (apply funextsec ; intro). apply idpath. Qed. End Univalence. UniMath-20231010/UniMath/CategoryTheory/categories/StandardCategories.v000066400000000000000000000373211451125700300257140ustar00rootroot00000000000000(** * Standard categories *) (** ** Contents: - The path groupoid ([path_groupoid]) - Discrete categories - Characterization of discrete categories - The discrete univalent_category on n objects ([cat_n]) - The category with one object ([unit_category]) - The category with no objects ([empty_category]) - The directed interval *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.catiso. Local Open Scope cat. Definition compose' { C:precategory_data } { a b c:ob C } (g:b --> c) (f:a --> b) : a --> c. Proof. intros. exact (compose f g). Defined. (** ** The path/fundamental groupoid of a type *) (** The pregroupoid with points in X as objects and paths as morphisms *) Definition path_pregroupoid (X:UU) (iobj : isofhlevel 3 X) : pregroupoid. use make_pregroupoid. - use tpair. { use make_precategory_one_assoc; use tpair. + exact (X,, λ x y, x = y). + use make_dirprod. * exact (λ _, idpath _). * intros a b c; exact pathscomp0. + use make_dirprod. * reflexivity. * intros; apply pathscomp0rid. + intros ? ? ? ? ? ?; apply path_assoc. } intros ? ? ? ? ? ?. apply iobj. - intros x y path. exists (!path). split. + apply pathsinv0r. + apply pathsinv0l. Defined. (** If X [isofhlevel] 3, then in particular, its path types are sets *) Definition has_homsets_path_pregroupoid {X : UU} (iobj : isofhlevel 3 X) : has_homsets (path_pregroupoid X iobj). Proof. apply homset_property. Defined. Definition path_groupoid (X : UU) (iobj : isofhlevel 3 X) : groupoid. Proof. use make_groupoid. - use make_category. + exact (path_pregroupoid X iobj). + apply (has_homsets_path_pregroupoid); assumption. - apply (pregroupoid_is_pregroupoid (path_pregroupoid X iobj)). Defined. (** In this case, the path pregroupoid is further univalent. *) Lemma is_univalent_path_pregroupoid (X : UU) (iobj : isofhlevel 3 X) : is_univalent_pregroupoid (path_pregroupoid X iobj). Proof. split. - intros a b. assert (k : idfun (a = b) ~ idtomor a b). { intro p; destruct p; reflexivity. } apply (isweqhomot _ _ k). apply idisweq. - apply has_homsets_path_pregroupoid; assumption. Defined. Lemma is_univalent_path_groupoid (X:UU) (i : isofhlevel 3 X) : is_univalent (path_groupoid X i). Proof. apply is_univalent_pregroupoid_is_univalent, is_univalent_path_pregroupoid; assumption. Defined. Definition path_univalent_groupoid {X : UU} (i3 : isofhlevel 3 X) : univalent_groupoid. Proof. use make_univalent_groupoid. - exact (make_univalent_category _ (is_univalent_path_groupoid X i3)). - apply (groupoid_is_pregroupoid _). Defined. Definition path_groupoid_hset (X : hSet) : univalent_groupoid := (path_univalent_groupoid (isofhlevelssnset 1 _ (setproperty X))). (** When X is a set, its path pregroupoid is the discrete category on its elements. *) Definition path_groupoid_hset_is_discrete (X : hSet) : is_discrete (path_groupoid_hset X). Proof. split; split. - apply setproperty. - apply homset_property. - apply pregroupoid_is_pregroupoid. - apply univalent_category_is_univalent. Defined. Definition discrete_category_hset (X : hSet) : discrete_category := make_discrete_category (path_groupoid_hset X) (path_groupoid_hset_is_discrete X). (** To define a functor out of a path pregroupoid, it suffices to give its values on objects. Compare to [functor_discrete_categories]. *) Lemma functor_path_pregroupoid {X : UU} {D : category} (i : isofhlevel 3 X) (f : X → ob D) : functor (path_pregroupoid X i) D. Proof. use make_functor. - use make_functor_data. + apply f. + intros a b aeqb. exact (transportf (λ z, D ⟦ f a, z ⟧) (maponpaths f aeqb) (identity _)). - split. + intro; reflexivity. + intros a b c g h; cbn. refine (maponpaths (λ p, transportf _ p _) (maponpathscomp0 _ _ _) @ _). refine (!transport_f_f _ (maponpaths f g) (maponpaths f h) _ @ _). abstract (induction h; cbn; apply pathsinv0; apply id_right). Defined. (** A natural transformation of functors out of a path groupoid is given by any family of morphisms *) Definition is_nat_trans_discrete_precategory {X : UU} {i : isofhlevel 3 X} {D : category} {f g : functor_category (path_pregroupoid X i) D} (F : ∏ x : X, (pr1 f) x --> (pr1 g) x) : is_nat_trans (pr1 f) (pr1 g) F. Proof. intros x y h; cbn in h. induction h. change (idpath x) with (identity x). assert (k := ! functor_id f x). unfold functor_data_from_functor in k. induction k. assert (k := ! functor_id g x). unfold functor_data_from_functor in k. induction k. intermediate_path (F x). - apply id_left. - apply pathsinv0. apply id_right. Qed. Definition nat_trans_functor_path_pregroupoid {X : UU} {i : isofhlevel 3 X} {D : category} {F G : functor (path_pregroupoid X i) D} (ϕ : ∏ x : X, F x --> G x) : nat_trans F G. Proof. use make_nat_trans. - intros z; apply (ϕ z). - apply (is_nat_trans_discrete_precategory). Defined. (** *** Characterization of discrete categories *) (** Discrete categories are isomorphic to the path groupoid on their set of objects. This is analogous to the statement that any skeletal groupoid is discrete. *) Lemma discrete_category_iso_path_groupoid (C : discrete_category) : catiso C (discrete_category_hset (setcategory_objects_set (_,, discrete_category_is_setcategory C))). Proof. use tpair. - use make_functor. + use make_functor_data. * exact (idfun _). * intros a b f. apply isotoid. -- apply univalent_category_is_univalent. -- exact (@pregroupoid_hom_weq_iso C _ _ f). + use make_dirprod. * intro; apply setproperty. * intros ? ? ? ? ?; apply setproperty. - use make_dirprod. + intros a b. use isweq_iso. * intros f. apply idtoiso. assumption. * intro; apply discrete_category_hom_prop. * intro; apply setproperty. + apply idisweq. Defined. (** ** The discrete univalent_category on n objects ([cat_n]) *) Require Import UniMath.Combinatorics.StandardFiniteSets. Definition cat_n (n:nat): univalent_groupoid. apply path_groupoid_hset; use make_hSet. - exact (stn n). - apply isasetstn. Defined. Lemma is_discrete_cat_n (n : nat) : is_discrete (cat_n n). Proof. apply path_groupoid_hset_is_discrete. Defined. (** ** The category with one object ([unit_category]) *) Definition unit_category : univalent_category. Proof. use path_univalent_groupoid. - exact unit. - do 2 (apply hlevelntosn). apply isapropunit. Defined. Section FunctorToUnit. Context (A : precategory). Definition functor_to_unit_data : functor_data A unit_category. Proof. use make_functor_data. - exact tounit. - exact (λ _ _ _, idpath _ ). Defined. Definition is_functor_to_unit : is_functor functor_to_unit_data. Proof. split. - intro. apply idpath. - intros ? ? ? ? ?; apply idpath. Qed. Definition functor_to_unit : functor A _ := make_functor _ is_functor_to_unit. Lemma iscontr_functor_to_unit : iscontr (functor A unit_category). Proof. use make_iscontr. - exact functor_to_unit. - intro F. apply functor_eq. + apply (homset_property unit_category). + use total2_paths_f. * apply funextsec. intro. cbn. apply proofirrelevance. apply isapropunit. * do 3 (apply funextsec; intro). apply proofirrelevance. simpl. apply hlevelntosn. apply isapropunit. Qed. End FunctorToUnit. (** Functors from the unit category *) Definition functor_from_unit_data {C : category} (x : C) : functor_data unit_category C. Proof. use make_functor_data. - exact (λ _, x). - exact (λ _ _ _, identity _). Defined. Definition functor_from_unit_is_functor {C : category} (x : C) : is_functor (functor_from_unit_data x). Proof. split. - intro ; apply idpath. - intro ; intros ; cbn. rewrite id_left. apply idpath. Qed. Definition functor_from_unit {C : category} (x : C) : unit_category ⟶ C. Proof. use make_functor. - exact (functor_from_unit_data x). - exact (functor_from_unit_is_functor x). Defined. Definition nat_trans_from_unit_is_nat_trans {C : category} {x y : C} (f : x --> y) : is_nat_trans (functor_from_unit x) (functor_from_unit y) (λ _, f). Proof. intro ; intros ; cbn. rewrite id_left, id_right. apply idpath. Qed. Definition nat_trans_from_unit {C : category} {x y : C} (f : x --> y) : functor_from_unit x ⟹ functor_from_unit y. Proof. use make_nat_trans. - exact (λ _, f). - exact (nat_trans_from_unit_is_nat_trans f). Defined. Definition unit_category_nat_trans {C : category} (F G : C ⟶ unit_category) : F ⟹ G. Proof. use make_nat_trans. - exact (λ _, pr1 (isapropunit _ _)). - abstract (intro ; intros ; apply isasetunit). Defined. Lemma nat_trans_to_unit_eq {X : category} (F G : X ⟶ unit_category) (α β : F ⟹ G) : α = β. Proof. apply nat_trans_eq. - apply homset_property. - intro z. apply isasetunit. Qed. (** Morphisms are the same as certain natural transformations *) Definition nat_trans_from_unit_weq_morphisms {C : category} (x y : C) : x --> y ≃ (functor_from_unit x ⟹ functor_from_unit y). Proof. use make_weq. - exact nat_trans_from_unit. - use isweq_iso. + exact (λ n, n tt). + abstract (intro f ; apply idpath). + abstract (intros n ; use nat_trans_eq ; [ apply homset_property | ] ; intro z ; cbn ; induction z ; apply idpath). Defined. (** ** The category with no objects ([empty_category]) *) Definition empty_category : univalent_category. Proof. use path_univalent_groupoid. - exact empty. - do 2 (apply hlevelntosn). apply isapropempty. Defined. Section FunctorFromEmpty. Context (A : precategory). Definition functor_from_empty_data : functor_data empty_category A. Proof. use make_functor_data. - exact fromempty. - intros empt ?; induction empt. Defined. Definition is_functor_from_empty : is_functor functor_from_empty_data. Proof. use tpair; intro a; induction a. Defined. Definition functor_from_empty : functor empty_category A := make_functor _ is_functor_from_empty. (** Compare to [isaprop_is_functor]. For a functor from the empty_category, it's not necessary that the codomain has homsets. *) Lemma isaprop_is_functor_from_empty (F : functor_data empty_category A) : isaprop (is_functor F). Proof. apply isapropdirprod. - unfold functor_idax. apply impred; intro e; induction e. - unfold functor_compax. apply impred; intro e; induction e. Defined. Lemma iscontr_functor_from_empty : iscontr (functor empty_category A). Proof. use make_iscontr. - exact functor_from_empty. - intro F. use total2_paths_f. + use total2_paths_f; apply funextsec; intro empt; induction empt. + apply proofirrelevance, isaprop_is_functor_from_empty. Defined. End FunctorFromEmpty. (** Natural transformations for the empty category *) Definition nat_trans_from_empty {C : category} (F G : empty_category ⟶ C) : nat_trans F G. Proof. use make_nat_trans. - exact (λ z, fromempty z). - exact (λ z, fromempty z). Defined. Definition nat_trans_to_empty {C₁ C₂ : category} (F : C₁ ⟶ empty_category) (G : empty_category ⟶ C₂) (H : C₁ ⟶ C₂) : H ⟹ F ∙ G. Proof. use make_nat_trans. - exact (λ x, fromempty (F x)). - exact (λ x y f, fromempty (F x)). Defined. Definition nat_trans_to_empty_is_nat_z_iso {C₁ C₂ : category} (F : C₁ ⟶ empty_category) (G : empty_category ⟶ C₂) (H : C₁ ⟶ C₂) : is_nat_z_iso (nat_trans_to_empty F G H). Proof. intro x. exact (fromempty (F x)). Defined. (* Directed interval category *) Definition directed_interval_precategory_ob_mor : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact bool. - intros x y. induction x ; induction y. + exact unit. + exact unit. + exact empty. + exact unit. Defined. Definition directed_interval_precategory_data : precategory_data. Proof. use make_precategory_data. - exact directed_interval_precategory_ob_mor. - intro x. induction x. + exact tt. + exact tt. - intros x y z f g. induction x ; induction y ; induction z ; cbn in *. + exact tt. + exact tt. + exact tt. + exact tt. + exact f. + exact tt. + exact g. + exact tt. Defined. Definition directed_interval_precategory_is_precategory : is_precategory directed_interval_precategory_data. Proof. use make_is_precategory_one_assoc. - intros x y f. induction x ; induction y ; cbn in *. + apply isapropunit. + apply isapropunit. + exact (fromempty f). + apply isapropunit. - intros x y f. induction x ; induction y ; cbn in *. + apply isapropunit. + apply isapropunit. + exact (fromempty f). + apply isapropunit. - intros w x y z f g h. induction w ; induction x ; induction y ; induction z ; cbn in * ; try (apply idpath). exact (fromempty f). Qed. Definition directed_interval_precategory : precategory. Proof. use make_precategory. - exact directed_interval_precategory_data. - exact directed_interval_precategory_is_precategory. Defined. Definition directed_interval_category_has_homprops (x y : directed_interval_precategory_ob_mor) : isaprop (x --> y). Proof. induction x ; induction y. - apply isapropunit. - apply isapropunit. - apply isapropempty. - apply isapropunit. Qed. Definition directed_interval_category_has_homsets : has_homsets directed_interval_precategory_ob_mor. Proof. intros x y. apply isasetaprop. exact (directed_interval_category_has_homprops x y). Qed. Definition directed_interval_category : category. Proof. use make_category. - exact directed_interval_precategory. - exact directed_interval_category_has_homsets. Defined. Definition is_univalent_directed_interval : is_univalent directed_interval_category. Proof. intros x y. use isweqimplimpl. - intro f. induction x ; induction y ; cbn in *. + apply idpath. + apply (fromempty (inv_from_z_iso f)). + apply (fromempty (pr1 f)). + apply idpath. - apply isasetbool. - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)). + apply directed_interval_category_has_homprops. + intro. apply isaprop_is_z_isomorphism. Qed. Definition directed_interval : univalent_category. Proof. use make_univalent_category. - exact directed_interval_category. - exact is_univalent_directed_interval. Defined. UniMath-20231010/UniMath/CategoryTheory/categories/Type/000077500000000000000000000000001451125700300226725ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/categories/Type/Colimits.v000066400000000000000000000022141451125700300246430ustar00rootroot00000000000000(** * Colimits in the precategory of types Author: Langston Barrett (@siddharthist), Feb 2018 *) (** ** Contents: - Initial object ([InitialType]) - Binary coproducts ([BinCoproductsType]) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.categories.Type.Core. (** ** Initial object ([InitialType]) *) (** The [empty] type is an initial object for the precategory of types. *) Lemma InitialType : Initial type_precat. Proof. apply (make_Initial (empty : ob type_precat)). exact iscontrfunfromempty. Defined. (* (** ** Binary coproducts ([BinCoproductsType]) *) (** The precategory of types has binary coproducts. *) Lemma BinCoproductsType : BinCoproducts type_precat. Proof. intros X Y. use tpair. - exact (coprod X Y,, inl,, inr). - apply isBinCoproduct'_to_isBinCoproduct. intro Z; apply (weqfunfromcoprodtoprod X Y Z). Defined. *) UniMath-20231010/UniMath/CategoryTheory/categories/Type/Core.v000066400000000000000000000046421451125700300237570ustar00rootroot00000000000000(** * The precategory of types This file defines the precategory of types in a fixed universe ([type_precat]) and shows that it has some limits and exponentials. Author: Langston Barrett (@siddharthist), Feb 2018 *) (** ** Contents: - The precategory of types (of a fixed universe) ([type_precat]) - Hom functors - As a bifunctor ([hom_functor]) - Covariant ([cov_hom_functor]) - Contravariant ([contra_hom_functor]) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.PartA. (* Basic category theory *) Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. (* Hom functors *) Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Local Open Scope cat. Local Open Scope functions. (** ** The precategory of types of a fixed universe *) Definition type_precat : precategory. Proof. use make_precategory. - use tpair; use tpair. + exact UU. + exact (λ X Y, X -> Y). + exact (λ X, idfun X). + exact (λ X Y Z f g, funcomp f g). - repeat split; intros; apply idpath. Defined. (** ** Hom functors *) Section HomFunctors. Context {C : precategory}. (** ** As a bifunctor [hom_functor] *) Definition hom_functor_data : functor_data (precategory_binproduct (opp_precat C) C) type_precat. Proof. use make_functor_data. - intros pair; exact (C ⟦ pr1 pair, pr2 pair ⟧). - intros x y fg h. refine (_ · h · _). + exact (pr1 fg). + exact (pr2 fg). Defined. Lemma is_functor_hom_functor_type : is_functor hom_functor_data. Proof. use make_dirprod. - intro; cbn. apply funextsec; intro. refine (id_right _ @ _). apply id_left. - intros ? ? ? ? ?. apply funextsec; intro; cbn. abstract (do 3 rewrite assoc; reflexivity). Defined. Definition hom_functor : functor (precategory_binproduct (opp_precat C) C) type_precat := make_functor _ is_functor_hom_functor_type. Context (c : C). (** ** Covariant [cov_hom_functor] *) Definition cov_hom_functor : functor C type_precat := functor_fix_fst_arg (opp_precat C) _ _ hom_functor c. (** ** Contravariant [contra_hom_functor] *) Definition contra_hom_functor : functor (opp_precat C) type_precat := functor_fix_snd_arg (opp_precat C) _ _ hom_functor c. End HomFunctors. UniMath-20231010/UniMath/CategoryTheory/categories/Type/Limits.v000066400000000000000000000022011451125700300243150ustar00rootroot00000000000000(** * Limits in the precategory of types Author: Langston Barrett (@siddharthist), Feb 2018 *) (** ** Contents: - Terminal object ([TerminalType]) - Binary products ([BinProductsType]) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.categories.Type.Core. (** ** Terminal object ([TerminalType]) *) (** The [unit] type is a terminal object for the precategory of types. *) Lemma TerminalType : Terminal type_precat. Proof. apply (make_Terminal (unit : ob type_precat)). exact iscontrfuntounit. Defined. (* (** ** Binary products ([BinProductsType]) *) (** The precategory of types has binary products. *) Lemma BinProductsType : BinProducts type_precat. Proof. intros X Y. use tpair. - exact ((X × Y),, dirprod_pr1,, dirprod_pr2). - apply isBinProduct'_to_isBinProduct. intro; apply (weqfuntoprodtoprod _ X Y). Defined. *) UniMath-20231010/UniMath/CategoryTheory/categories/Type/MonoEpiIso.v000066400000000000000000000062011451125700300251010ustar00rootroot00000000000000(** * Characterizations of monos, epis, and isos in [type_precat] *) (** ** Contents - Injective functions are monic [InjectivesAreMonic_type] - Isomorphisms and weak equivalences *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.categories.Type.Core. Local Open Scope cat. (** ** Injective functions are monic [InjectivesAreMonic_type] *) (* Lemma InjectivesAreMonic_type {A B : UU} (f: type_precat⟦ A, B ⟧) : isInjective f -> isMonic f. Proof. intro isI. unfold isMonic. intros ? ? ? eq. apply funextfun; intro. apply (invweq (Injectivity _ isI _ _)). apply toforallpaths in eq. apply eq. Qed. (** ** Isomorphisms and weak equivalences *) (** The following are mostly copied verbatim from [CategoryTheory.categories.TYPE.MonoEpiIso]. *) Lemma type_iso_is_equiv (A B : ob type_precat) (f : iso A B) : isweq (pr1 f). Proof. apply (isweq_iso _ (inv_from_iso f)). - intro x. set (T:=iso_inv_after_iso f). set (T':=toforallpaths _ _ _ T). apply T'. - intro x. apply (toforallpaths _ _ _ (iso_after_iso_inv f)). Defined. Lemma type_iso_equiv (A B : ob type_precat) : iso A B -> A ≃ B. Proof. intro f; use make_weq; [exact (pr1 f)|apply type_iso_is_equiv]. Defined. (** Given a weak equivalence, we construct an iso. Again mostly unwrapping and packing. *) Lemma type_equiv_is_iso (A B : ob type_precat) (f : A ≃ B) : is_iso (C := type_precat) (pr1 f). Proof. apply (is_iso_qinv (C := type_precat) _ (invmap f)). split; simpl. - apply funextfun; intro; simpl in *. unfold compose, identity; simpl. apply homotinvweqweq. - apply funextfun; intro; simpl in *. unfold compose, identity; simpl. apply homotweqinvweq. Defined. Lemma type_precat_equiv_iso (A B : ob type_precat) : A ≃ B -> iso A B. Proof. intro f. use make_iso. - exact (pr1 f). - apply type_equiv_is_iso. Defined. (** Both maps defined above are weak equivalences. *) Lemma type_iso_equiv_is_equiv (A B : ob type_precat) : isweq (type_iso_equiv A B). Proof. apply (isweq_iso _ (type_precat_equiv_iso A B)). intro; apply eq_iso. - reflexivity. - intro; apply subtypePath. + intro; apply isapropisweq. + reflexivity. Qed. Definition type_iso_equiv_weq (A B : ob type_precat) : (iso A B) ≃ (A ≃ B). Proof. exists (type_iso_equiv A B). apply type_iso_equiv_is_equiv. Defined. Lemma type_equiv_iso_is_equiv (A B : ob type_precat) : isweq (type_precat_equiv_iso A B). Proof. apply (isweq_iso _ (type_iso_equiv A B)). { intro f. apply subtypePath. { intro; apply isapropisweq. } reflexivity. } intro; apply eq_iso. reflexivity. Qed. Definition type_equiv_weq_iso (A B : ob type_precat) : (A ≃ B) ≃ iso A B. Proof. exists (type_precat_equiv_iso A B). apply type_equiv_iso_is_equiv. Defined. *) UniMath-20231010/UniMath/CategoryTheory/categories/Type/Structures.v000066400000000000000000000043621451125700300252510ustar00rootroot00000000000000(** * Other structures in [type_precat] *) (** ** Contents - Exponentials ([Exponentials_Type]) - The exponential functor y ↦ yˣ ([exp_functor]) - Exponentials ([ExponentialsType]) *) Require Import UniMath.Foundations.PartA. Require Import UniMath.MoreFoundations.PartA. (* Basic category theory *) Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. (* Exponentials *) Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.CategoryTheory.categories.Type.Limits. (** ** Exponentials *) (** *** Exponential functor *) Section ExponentialFunctor. Context (A : UU). (** This is the object we're ×-ing and ^-ing with *) (** To show that [type_precat] has exponentials, we need a right adjoint to the functor Y ↦ X × Y for fixed Y. *) Local Definition exp_functor_ob (X : UU) : UU := A -> X. Local Definition exp_functor_arr (X Y : UU) (f : X -> Y) : (A -> X) -> (A -> Y) := λ g, f ∘ g. Local Definition exp_functor_data : functor_data type_precat type_precat := functor_data_constr _ _ (exp_functor_ob : type_precat → type_precat) (@exp_functor_arr). Lemma exp_functor_is_functor : is_functor exp_functor_data. Proof. use make_dirprod. - intro; reflexivity. - intros ? ? ? ? ?; reflexivity. Defined. Definition exp_functor : functor type_precat type_precat := make_functor exp_functor_data exp_functor_is_functor. End ExponentialFunctor. (* Lemma ExponentialsType : Exponentials BinProductsType. Proof. intro X. unfold is_exponentiable. unfold is_left_adjoint. refine (exp_functor X,, _). unfold are_adjoints. use tpair. - use make_dirprod. + use make_nat_trans. * intro Y; cbn. unfold exp_functor_ob. exact (flip make_dirprod). * intros ? ? ?; reflexivity. + use make_nat_trans. * intro Y; cbn. unfold exp_functor_ob. exact (λ pair, (pr2 pair) (pr1 pair)). * intros ? ? ?; reflexivity. - use make_form_adjunction; reflexivity. Defined. *) UniMath-20231010/UniMath/CategoryTheory/categories/Type/Univalence.v000066400000000000000000000022731451125700300251560ustar00rootroot00000000000000(** * Near-univalence of [type_precat] *) (** The precategory of types is not quite univalent - it doesn't have hom-sets. However, it is the case that [idtoiso] is a weak equivalence. Much of this material is copied near-verbatim from the results for sets. *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.CategoryTheory.categories.Type.MonoEpiIso. Local Open Scope cat. (* Definition type_id_weq_iso (A B : ob type_precat) : (A = B) ≃ (iso A B) := weqcomp (univalence _ _) (type_equiv_weq_iso A B). Lemma type_id_weq_iso_is (A B : ob type_precat): @idtoiso _ A B = pr1 (type_id_weq_iso A B). Proof. apply funextfun. intro p; elim p. apply eq_iso; simpl. - apply funextfun; intro. apply idpath. Defined. Lemma type_is_weq_idtoiso (A B : ob type_precat): isweq (@idtoiso _ A B). Proof. rewrite type_id_weq_iso_is. apply (pr2 (type_id_weq_iso A B)). Defined. *) UniMath-20231010/UniMath/CategoryTheory/categories/Universal_Algebra/000077500000000000000000000000001451125700300253365ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/categories/Universal_Algebra/Algebras.v000066400000000000000000000134531451125700300272530ustar00rootroot00000000000000(** * The univalent category of algebras over a signature. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (** We use display categories to define the category of algebras and prove its univalence. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.Algebra.Universal.TermAlgebras. Section Algebras. Local Open Scope sorted_scope. Context (σ : signature). Definition shSet_precategory_ob_mor : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact (shSet (sorts σ)). - intros F G. exact (F s→ G). Defined. Definition shSet_precategory_data : precategory_data. Proof. use make_precategory_data. - exact shSet_precategory_ob_mor. - intro C. simpl. apply idsfun. - simpl. intros F G H. intros f g. exact (g s∘ f). Defined. Definition is_precategory_shSet_precategory_data : is_precategory shSet_precategory_data. Proof. repeat split. Defined. Definition shSet_precategory : precategory. Proof. use make_precategory. - apply shSet_precategory_data. - apply is_precategory_shSet_precategory_data. Defined. Definition has_homsets_shSet_precategory : has_homsets shSet_precategory. Proof. intros F G. simpl. use isaset_set_sfun_space. Defined. Definition shSet_category : category := (shSet_precategory ,, has_homsets_shSet_precategory). Definition algebras_disp : disp_cat shSet_category. Proof. use disp_cat_from_SIP_data. simpl. - intro A. exact (∏ nm: names σ, A⋆ (arity nm) → A (sort nm)). - simpl. intros A B asA asB f. exact (@ishom σ (make_algebra A asA) (make_algebra B asB) f). - simpl. intros A B asA asB f opA opB. apply isapropishom. - cbn. intros A asA. apply ishomid. - cbn. intros A B C opA opB opC. intros f g ishomf ishomg. exact (ishomcomp (make_hom ishomf) (make_hom ishomg)). Defined. Lemma is_univalent_algebras_disp : is_univalent_disp algebras_disp. Proof. use is_univalent_disp_from_SIP_data. - intro A. cbn. use impred_isaset. intro nm. cbn. use isaset_set_fun_space. - cbn. intros A op1 op2 ishomid1 _. use funextsec. intro nm. use funextfun. intro vec. unfold ishom in *. cbn in *. set (H1:= ishomid1 nm vec). rewrite staridfun in H1. apply H1. Qed. Local Open Scope cat. (** Here follows the proof that [shSet_category] is univalent. The proof is obtained by following the example of the proof of univalence of the functor category. *) Lemma shSet_iso_fiber {A B : shSet_category} (i : z_iso A B): ∏ s, @z_iso HSET (A s) (B s). Proof. intro s. induction i as [i [i' [p q]]]. simpl in *. use make_z_iso. - exact (i s). - exact (i' s). - split. + exact (eqtohomot p s). + exact (eqtohomot q s). Defined. Definition shSet_eq_from_shSet_z_iso (F G : shSet_category) (i : z_iso F G) : F = G. Proof. apply funextsec. intro s. apply (isotoid HSET is_univalent_HSET). apply shSet_iso_fiber. assumption. Defined. Lemma idtoiso_shSet_category_compute_pointwise {F G : shSet_category} (p : F = G) (s: sorts σ) : shSet_iso_fiber (idtoiso p) s = idtoiso(C:=HSET) (toforallpaths (λ _ , hSet) F G p s). Proof. induction p. apply z_iso_eq. apply idpath. Qed. Lemma shSet_eq_from_shSet_z_iso_idtoiso (F G : shSet_category) (p : F = G) : shSet_eq_from_shSet_z_iso F G (idtoiso p) = p. Proof. unfold shSet_eq_from_shSet_z_iso. apply (invmaponpathsweq (weqtoforallpaths _ _ _ )). simpl (pr1weq (weqtoforallpaths (λ _ : sorts σ, hSet) F G)). rewrite (toforallpaths_funextsec). apply funextsec. intro a. rewrite idtoiso_shSet_category_compute_pointwise. rewrite isotoid_idtoiso. apply idpath. Defined. Lemma idtoiso_shSet_eq_from_shSet_z_iso (F G : shSet_category) (i : z_iso F G) : idtoiso (shSet_eq_from_shSet_z_iso F G i) = i. Proof. apply z_iso_eq. apply funextsec. intro s. unfold shSet_eq_from_shSet_z_iso. assert (H' := idtoiso_shSet_category_compute_pointwise (shSet_eq_from_shSet_z_iso F G i) s). simpl in *. assert (H2 := maponpaths (@pr1 _ _ ) H'). simpl in H2. etrans. { apply H2. } intermediate_path (pr1 (idtoiso (isotoid HSET is_univalent_HSET (shSet_iso_fiber i s)))). - apply maponpaths. apply maponpaths. unfold shSet_eq_from_shSet_z_iso. rewrite toforallpaths_funextsec. apply idpath. - rewrite idtoiso_isotoid. apply idpath. Qed. Definition is_univalent_shSet_category : is_univalent shSet_category. Proof. intros F G. apply (isweq_iso _ (shSet_eq_from_shSet_z_iso F G)). - apply shSet_eq_from_shSet_z_iso_idtoiso. - apply idtoiso_shSet_eq_from_shSet_z_iso. Defined. Definition category_algebras : category := total_category algebras_disp. Lemma is_univalent_category_algebras : is_univalent category_algebras. Proof. exact (@is_univalent_total_category shSet_category algebras_disp is_univalent_shSet_category is_univalent_algebras_disp). Qed. Lemma isinitial_termalgebra : Initial (category_algebras). Proof. exact (term_algebra σ ,, iscontrhomsfromgterm). Defined. End Algebras. UniMath-20231010/UniMath/CategoryTheory/categories/Universal_Algebra/EqAlgebras.v000066400000000000000000000061211451125700300275330ustar00rootroot00000000000000(** * The univalent category of equational algebras over an equational specification. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Isos. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.Algebra.Universal.EqAlgebras. Require Import UniMath.CategoryTheory.categories.Universal_Algebra.Algebras. Context (σ : eqspec). Local Open Scope sorted_scope. Definition eqalg_disp : disp_cat (category_algebras σ). Proof. use disp_full_sub. exact (λ A, is_eqalgebra A). Defined. Lemma is_univalent_eqalg_disp : is_univalent_disp eqalg_disp. Proof. use disp_full_sub_univalent. intros A isT isT'. use impred_isaprop. intro eq. use impred_isaprop. intros α p p'. apply (pr1 A). Qed. Definition category_eqalgebras : category := total_category eqalg_disp. Lemma is_univalent_category_eqalgebras : is_univalent category_eqalgebras. Proof. exact (@is_univalent_total_category (category_algebras σ) eqalg_disp (is_univalent_category_algebras σ) is_univalent_eqalg_disp). Qed. (* Alternative version, kept here for comparison purposes. *) (* Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Definition eqalg_disp : disp_cat (shSet_category σ). Proof. use disp_cat_from_SIP_data. - cbn; intro A. exact (∑ ops: (∏ nm: names σ, A⋆ (arity nm) → A (sort nm)), (∏ e : equations σ, holds (make_algebra A ops) (geteq e))). - cbn. intros a b [opa iseqa] [opb iseqb] f. exact (@ishom σ (make_algebra a opa) (make_algebra b opb) f). - intros. apply isapropishom. - cbn. intros. apply ishomid. - cbn. intros A B C prpA prpB prpC. intros f g ishomf ishomg. exact (ishomcomp (make_hom ishomf) (make_hom ishomg)). Defined. Lemma is_univalent_eqalg_disp : is_univalent_disp eqalg_disp. Proof. use is_univalent_disp_from_SIP_data. - cbn; intro A. apply isaset_total2. * apply impred_isaset. cbn; intro nm; use isaset_set_fun_space. * cbn; intros. apply impred_isaset. cbn; intro sys. apply impred_isaset; cbn. intro t. apply isasetaprop. apply A. - cbn; intros A [opA iseqA][op'A iseq'A]. intros i i'. use total2_paths2_f. * use funextsec. intro nm. use funextfun. intro v. unfold ishom in *. cbn in *. set (H1 := i nm v). eapply pathscomp0. exact H1. apply maponpaths. apply staridfun. * cbn. apply funextsec; cbn; intro e. apply funextsec; intro f. apply A. Qed. Definition category_eqalgebras : category := total_category eqalg_disp. Lemma is_univalent_category_eqalgebras : is_univalent category_eqalgebras. Proof. exact (@is_univalent_total_category (shSet_category σ) eqalg_disp (is_univalent_shSet_category σ) is_univalent_eqalg_disp). Qed. *) UniMath-20231010/UniMath/CategoryTheory/categories/abgrs.v000066400000000000000000001735711451125700300232540ustar00rootroot00000000000000(** * Category of abelian groups *) (** ** Contents - Precategory of abelian groups - Category of abelian groups - Zero object and Zero arrow - Zero object - Zero arrow - Category of abelian groups is preadditive - Category of abelian groups is additive - Kernels and Cokernels - Kernels - Cokernels - Monics are inclusions and Epis are surjections - Epis are surjections - Monics are inclusions - Monics are kernels of their cokernels and epis are cokernels of their kernels - Monics are Kernels - Epis are Cokernels - The category of abelian groups is an abelian category - Corollaries to additive categories *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Local Open Scope cat. (** * Precategory of abelian groups - Objects are abelian groups, [abgr]. - Morphisms are monoidfuns, [monoidfun]. *) Section def_abgr_precategory. (** ** precategory_data *) Definition abgr_fun_space (A B : abgr) : hSet := make_hSet (monoidfun A B) (isasetmonoidfun A B). Definition abgr_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) abgr (λ A B : abgr, abgr_fun_space A B). Definition abgr_precategory_data : precategory_data := make_precategory_data abgr_precategory_ob_mor (λ (A : abgr), ((idmonoidiso A) : monoidfun A A)) (fun (A B C : abgr) (f : monoidfun A B) (g : monoidfun B C) => monoidfuncomp f g). (** ** is_precategory *) Lemma is_precategory_abgr_precategory_data : is_precategory abgr_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use monoidfunidleft. - intros a b f. use monoidfunidright. - intros a b c d f g h. use monoidfunassoc. Qed. (** ** precategory and category *) Definition abgr_precategory : precategory := make_precategory abgr_precategory_data is_precategory_abgr_precategory_data. Lemma has_homsets_abgr : has_homsets abgr_precategory. Proof. intros a b. use isasetmonoidfun. Qed. Definition abgr_category : category := make_category abgr_precategory has_homsets_abgr. End def_abgr_precategory. (** * Category of abelian groups - (monoidiso X Y) ≃ (iso X Y) - Category of abelian groups *) Section def_abgr_category. (** ** (monoidiso X Y) ≃ (z_iso X Y) *) Lemma abgr_z_iso_is_equiv (A B : ob abgr_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1monoidfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropismonoidfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropismonoidfun. Qed. Lemma abgr_z_iso_equiv (X Y : ob abgr_category) : z_iso X Y -> monoidiso (X : abgr) (Y : abgr). Proof. intro f. use make_monoidiso. - exact (make_weq (pr1 (pr1 f)) (abgr_z_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma abgr_equiv_is_z_iso (X Y : ob abgr_category) (f : monoidiso (X : abgr) (Y : abgr)) : @is_z_isomorphism abgr_category X Y (monoidfunconstr (pr2 f)). Proof. exists (monoidfunconstr (pr2 (invmonoidiso f))). split. - use monoidfun_paths. use funextfun. intros x. use homotinvweqweq. - use monoidfun_paths. use funextfun. intros y. use homotweqinvweq. Qed. Definition abgr_equiv_z_iso (X Y : ob abgr_category) (f : monoidiso (X : abgr) (Y : abgr)) : z_iso X Y := @make_z_iso' abgr_category X Y (monoidfunconstr (pr2 f)) (abgr_equiv_is_z_iso X Y f). Lemma abgr_z_iso_equiv_is_equiv (X Y : abgr_category) : isweq (abgr_z_iso_equiv X Y). Proof. use isweq_iso. - exact (abgr_equiv_z_iso X Y). - intros x. use z_iso_eq. use monoidfun_paths. use idpath. - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Qed. Definition abgr_z_iso_equiv_weq (X Y : ob abgr_category) : weq (z_iso X Y) (monoidiso (X : abgr) (Y : abgr)). Proof. use make_weq. - exact (abgr_z_iso_equiv X Y). - exact (abgr_z_iso_equiv_is_equiv X Y). Defined. Lemma abgr_equiv_z_iso_is_equiv (X Y : ob abgr_category) : isweq (abgr_equiv_z_iso X Y). Proof. use isweq_iso. - exact (abgr_z_iso_equiv X Y). - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. use z_iso_eq. use monoidfun_paths. use idpath. Qed. Definition abgr_equiv_weq_z_iso (X Y : ob abgr_category) : (monoidiso (X : abgr) (Y : abgr)) ≃ (z_iso X Y). Proof. use make_weq. - exact (abgr_equiv_z_iso X Y). - exact (abgr_equiv_z_iso_is_equiv X Y). Defined. (** ** Category of abelian groups *) Definition abgr_category_isweq (a b : ob abgr_category) : isweq (λ p : a = b, idtoiso p). Proof. use (@isweqhomot (a = b) (z_iso a b) (pr1weq (weqcomp (abgr_univalence a b) (abgr_equiv_weq_z_iso a b))) _ _ (weqproperty (weqcomp (abgr_univalence a b) (abgr_equiv_weq_z_iso a b)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use total2_paths_f. + use idpath. + use proofirrelevance. use isapropismonoidfun. - use proofirrelevance. use isaprop_is_z_isomorphism. Qed. Definition abgr_category_is_univalent : is_univalent abgr_category. Proof. intros a b. exact (abgr_category_isweq a b). Defined. Definition abgr_univalent_category : univalent_category := make_univalent_category abgr_category abgr_category_is_univalent. End def_abgr_category. (** * Zero object and Zero arrow - Zero object is the abelian group which consists of one element, the unit element. - The unique morphism to zero object maps every element to the unit element. - The unique morphism from the zero object maps unit to unit. - The unique morphisms which factors through zero object maps every element to the unit element. - Computations on zero object *) Section def_abgr_zero. (** ** Zero in abelian category *) Lemma isconnectedfromunitabgr (a : abgr_category) (t : abgr_category ⟦unitabgr, a⟧): (t : monoidfun unitabgr (a : abgr)) = abgrfunfromunit (a : abgr). Proof. use monoidfun_paths. use funextfun. intros x. use (pathscomp0 _ (monoidfununel t)). use maponpaths. use isProofIrrelevantUnit. Qed. Lemma isconnectedtounitabgr (a : abgr_category) (t : abgr_category ⟦a, unitabgr⟧): (t : monoidfun (a : abgr) unitabgr) = abgrfuntounit a. Proof. use monoidfun_paths. use funextfun. intros x. use isProofIrrelevantUnit. Qed. Definition abgr_isZero : @isZero abgr_category unitabgr. Proof. use make_isZero. - intros a. use make_iscontr. + exact (abgrfunfromunit a). + intros t. exact (isconnectedfromunitabgr a t). - intros a. use make_iscontr. + exact (abgrfuntounit a). + intros t. exact (isconnectedtounitabgr a t). Defined. Definition abgr_Zero : Zero abgr_category := @make_Zero abgr_category unitabgr abgr_isZero. (** ** Computations on zero object *) Lemma abgr_Zero_comp : ZeroObject (abgr_Zero) = unitabgr. Proof. use idpath. Qed. Lemma abgr_Zero_from_comp (A : abgr) : @ZeroArrowFrom abgr_category abgr_Zero A = abgrfunfromunit A. Proof. use idpath. Qed. Lemma abgr_Zero_to_comp (A : abgr) : @ZeroArrowTo abgr_category abgr_Zero A = abgrfuntounit A. Proof. use idpath. Qed. Lemma abgr_Zero_arrow_comp (A B : abgr) : @ZeroArrow abgr_category abgr_Zero A B = unelabgrfun A B. Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. End def_abgr_zero. (** * Preadditive structure on the category of abelian groups - Binary operation on homsets. - Abelian group structure on homsets - PreAdditive structure on the category of abelian groups *) Section abgr_preadditive. (** ** Binary operations on homsets Let f, g : X --> Y be morphisms in the category of abelian groups. Then f + g is defined to be the morphism (f + g) x = (f x) + (g x). This gives [precategoryWithBinOps] structure on the category. *) Definition abgr_WithBinOpsData : precategoryWithBinOpsData abgr_category. Proof. intros X Y. exact (@abmonoidshombinop (X : abgr) (Y : abgr)). Defined. Definition abgr_WithBinOps : precategoryWithBinOps := make_precategoryWithBinOps abgr_category abgr_WithBinOpsData. (** ** [categoryWithAbgrops] structure on the category of abelian groups *) Definition abgr_WithAbGrops : categoryWithAbgrops. Proof. use make_categoryWithAbgrops. - exact abgr_WithBinOps. - use make_categoryWithAbgropsData. intros X Y. exact (@abgrshomabgr_isabgrop X Y). Defined. (** ** [PreAdditive] structure on the category of abelian groups *) Definition abgr_isPreAdditive : isPreAdditive abgr_WithAbGrops. Proof. use make_isPreAdditive. (* Precomposition with morphism is linear *) - intros X Y Z f. use make_ismonoidfun. + use make_isbinopfun. intros g h. use monoidfun_paths. use funextfun. intros x. use idpath. + use monoidfun_paths. use funextfun. intros x. use idpath. (* Postcomposition with morphism is linear *) - intros X Y Z f. use make_ismonoidfun. + use make_isbinopfun. intros g h. use monoidfun_paths. use funextfun. intros x. use (pathscomp0 ((pr1 (pr2 f)) _ _)). use idpath. + use monoidfun_paths. use funextfun. intros x. exact (monoidfununel f). Qed. Definition abgr_PreAdditive : PreAdditive := make_PreAdditive abgr_WithAbGrops abgr_isPreAdditive. End abgr_preadditive. (** * Additive structure on the category of abelian groups - Direct sums - Additive category structure *) Section abgr_additive. (** ** Direct sums Direct sum of X and Y is given by the direct product abelian group X × Y. The inclusions and projections are given by - In1 : x ↦ (x, 0) - In2 : y ↦ (0, y) - Pr1 : (x, y) ↦ x - Pr2 : (x, y) ↦ y *) Lemma abgr_DirectSumPr1_ismonoidfun (A B : abgr) : ismonoidfun (λ X : abgrdirprod A B, dirprod_pr1 X). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use idpath. - use idpath. Qed. Definition abgr_DirectSumPr1 (A B : abgr) : abgr_category⟦abgrdirprod A B, A⟧ := monoidfunconstr (abgr_DirectSumPr1_ismonoidfun A B). Lemma abgr_DirectSumPr2_ismonoidfun (A B : abgr) : ismonoidfun (λ X : abgrdirprod A B, dirprod_pr2 X). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use idpath. - use idpath. Qed. Definition abgr_DirectSumPr2 (A B : abgr) : abgr_category⟦abgrdirprod A B, B⟧ := monoidfunconstr (abgr_DirectSumPr2_ismonoidfun A B). Lemma abgr_DirectSumIn1_ismonoidfun (A B : abgr) : @ismonoidfun A (abgrdirprod A B) (λ a : A, make_dirprod a (unel B)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use dirprod_paths. + use idpath. + use pathsinv0. use (runax B). - use dirprod_paths. + use idpath. + use idpath. Qed. Definition abgr_DirectSumIn1 (A B : abgr) : abgr_category⟦A, abgrdirprod A B⟧ := monoidfunconstr (abgr_DirectSumIn1_ismonoidfun A B). Lemma abgr_DirectSumIn2_ismonoidfun (A B : abgr) : @ismonoidfun B (abgrdirprod A B) (λ b : B, make_dirprod (unel A) b). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use dirprod_paths. + use pathsinv0. use (runax A). + use idpath. - use dirprod_paths. + use idpath. + use idpath. Qed. Definition abgr_DirectSumIn2 (A B : abgr) : abgr_category⟦B, abgrdirprod A B⟧ := monoidfunconstr (abgr_DirectSumIn2_ismonoidfun A B). Lemma abgr_DirectSumIdIn1 (A B : abgr) : abgr_DirectSumIn1 A B · abgr_DirectSumPr1 A B = (idmonoidiso A : monoidfun A A). Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. Lemma abgr_DirectSumIdIn2 (A B : abgr) : abgr_DirectSumIn2 A B · abgr_DirectSumPr2 A B = (idmonoidiso B : monoidfun B B). Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. Lemma abgr_DirectSumUnel1 (A B : abgr) : abgr_DirectSumIn1 A B · abgr_DirectSumPr2 A B = @to_unel abgr_PreAdditive A B. Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. Lemma abgr_DirectSumUnel2 (A B : abgr) : abgr_DirectSumIn2 A B · abgr_DirectSumPr1 A B = @to_unel abgr_PreAdditive B A. Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. Lemma abgr_DirectSumId (A B : abgr) : @abmonoidshombinop (abgrdirprod A B) (abgrdirprod A B) (abgr_DirectSumPr1 A B · abgr_DirectSumIn1 A B) (abgr_DirectSumPr2 A B · abgr_DirectSumIn2 A B) = ((idmonoidiso (abgrdirprod A B)) : monoidfun (abgrdirprod A B) (abgrdirprod A B)) . Proof. use monoidfun_paths. use funextfun. intros x. use dirprod_paths. - use (runax A). - use (lunax B). Qed. Lemma abgr_isBinDirectSum (X Y : abgr) : @isBinDirectSum abgr_PreAdditive X Y (abgrdirprod X Y) (abgr_DirectSumIn1 X Y) (abgr_DirectSumIn2 X Y) (abgr_DirectSumPr1 X Y) (abgr_DirectSumPr2 X Y). Proof. use make_isBinDirectSum. - exact (abgr_DirectSumIdIn1 X Y). - exact (abgr_DirectSumIdIn2 X Y). - exact (abgr_DirectSumUnel1 X Y). - exact (abgr_DirectSumUnel2 X Y). - exact (abgr_DirectSumId X Y). Defined. Definition abgr_AdditiveStructure : AdditiveStructure abgr_PreAdditive. Proof. use make_AdditiveStructure. - exact abgr_Zero. - use make_BinDirectSums. intros X Y. use make_BinDirectSum. + exact (abgrdirprod X Y). + exact (abgr_DirectSumIn1 X Y). + exact (abgr_DirectSumIn2 X Y). + exact (abgr_DirectSumPr1 X Y). + exact (abgr_DirectSumPr2 X Y). + exact (abgr_isBinDirectSum X Y). Defined. Definition abgr_Additive : CategoryWithAdditiveStructure := make_Additive abgr_PreAdditive abgr_AdditiveStructure. End abgr_additive. (** * Kernels and Cokernels - Kernels in the category of abelian groups - Cokernels in the category of abelian groups *) Section abgr_kernels_and_cokernels. Definition abgr_Kernel_monoidfun {A B : abgr} (f : monoidfun A B) : abgr_category⟦carrierofasubabgr (abgr_Kernel_subabgr f), A⟧ := monoidincltomonoidfun (abgr_Kernel_subabgr f) A (@make_monoidmono (abgr_Kernel_subabgr f) A (make_incl (pr1carrier (abgr_kernel_hsubtype f)) (isinclpr1carrier (abgr_kernel_hsubtype f))) (abgr_Kernel_monoidfun_ismonoidfun f)). (** *** Composition Kernel f --> X --> Y is the zero arrow *) Definition abgr_Kernel_eq {A B : abgr} (f : monoidfun A B) : abgr_Kernel_monoidfun f · f = ZeroArrow abgr_Zero (carrierofasubabgr (abgr_Kernel_subabgr f)) B. Proof. apply monoidfun_paths. apply funextfun; intro x. apply (pr2 x). Qed. (** *** KernelIn morphism *) Lemma abgr_KernelArrowIn_map_property {A B C : abgr_category} (h : C --> A) (f : A --> B) (H : h · f = ZeroArrow abgr_Zero C B) (c : (C : abgr)) : (pr1 f (pr1 h c) = 1%multmonoid). Proof. use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ H) c)). use idpath. Qed. Definition abgr_KernelArrowIn_map {A B C : abgr_category} (h : C --> A) (f : A --> B) (H : h · f = ZeroArrow abgr_Zero C B) (c : (C : abgr)) : abgr_Kernel_subabgr f. Proof. use tpair. - exact (pr1 h c). - exact (abgr_KernelArrowIn_map_property h f H c). Defined. Lemma abgr_KernelArrowIn_ismonoidfun {A B C : abgr_category} (h : C --> A) (f : A --> B) (H : h · f = ZeroArrow abgr_Zero C B) : @ismonoidfun (C : abgr) (@abgr_Kernel_subabgr A B f) (@abgr_KernelArrowIn_map A B C h f H). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use total2_paths_f. + exact (binopfunisbinopfun (h : monoidfun (C : abgr) (A : abgr)) x x'). + use proofirrelevance. use propproperty. - use total2_paths_f. + exact (monoidfununel h). + use proofirrelevance. use propproperty. Qed. Definition abgr_KernelArrowIn {A B C : abgr_category} (h : C --> A) (f : A --> B) (H : h · f = ZeroArrow abgr_Zero C B) : abgr_category⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧. Proof. use monoidfunconstr. - exact (abgr_KernelArrowIn_map h f H). - exact (abgr_KernelArrowIn_ismonoidfun h f H). Defined. (** *** Kernels *) Definition abgr_Kernel_isKernel_KernelArrrow {A B C : abgr} (f : abgr_category ⟦A, B⟧) (h : abgr_category ⟦C, A⟧) (H' : h · f = ZeroArrow abgr_Zero C B) : ∑ ψ : abgr_category ⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧, ψ · abgr_Kernel_monoidfun f = h. Proof. use tpair. - exact (abgr_KernelArrowIn h f H'). - use monoidfun_paths. use funextfun. intros x. use idpath. Defined. Definition abgr_Kernel_isKernel_uniqueness {A B C : abgr} (f : abgr_category ⟦A, B⟧) (h : abgr_category ⟦C, A⟧) (H' : h · f = ZeroArrow abgr_Zero C B) (t : ∑ (t1 : abgr_category ⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧), t1 · abgr_Kernel_monoidfun f = h) : t = abgr_Kernel_isKernel_KernelArrrow f h H'. Proof. use total2_paths_f. - use monoidfun_paths. use funextfun. intros x. use total2_paths_f. + exact (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x). + use proofirrelevance. use propproperty. - use proofirrelevance. use setproperty. Qed. Definition abgr_Kernel_isKernel {A B : abgr} (f : abgr_category⟦A, B⟧) : isKernel abgr_Zero (abgr_Kernel_monoidfun f) f (abgr_Kernel_eq f). Proof. use make_isKernel. - intros w h H'. use make_iscontr. + exact (abgr_Kernel_isKernel_KernelArrrow f h H'). + intros t. exact (abgr_Kernel_isKernel_uniqueness f h H' t). Defined. Definition abgr_Kernel {A B : abgr} (f : monoidfun A B) : Kernel abgr_Zero f := make_Kernel (abgr_Zero) (abgr_Kernel_monoidfun f) f (abgr_Kernel_eq f) (abgr_Kernel_isKernel f). Corollary abgr_Kernels : Kernels abgr_Zero. Proof. intros A B f. exact (abgr_Kernel f). Defined. (** ** Cokernels - Let f : X --> Y be a morphism of abelian groups. A cokernel for f is given by the quotient quotient group Y/(Im f) together with the canonical morphism Y --> Y/(Im f). *) (** *** Subgroup gives an equivalence relation. *) Definition abgr_Cokernel_eqrel_istrans {A B : abgr} (f : monoidfun A B) : istrans (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid). Proof. intros x1 x2 x3 y1 y2. use (hinhuniv _ y1). intros y1'. use (hinhuniv _ y2). intros y2'. use hinhpr. use tpair. - exact (@op A (pr1 y1') (pr1 y2')). - use (pathscomp0 (binopfunisbinopfun f (pr1 y1') (pr1 y2'))). rewrite (pr2 y1'). rewrite (pr2 y2'). rewrite <- assocax. rewrite (assocax _ _ _ x2). rewrite (grlinvax B). rewrite (runax B). use idpath. Qed. Definition abgr_Cokernel_eqrel_isrefl {A B : abgr} (f : monoidfun A B) : isrefl (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid). Proof. intros x1 P X. use X. clear P X. use tpair. - exact (unel A). - cbn. rewrite (grrinvax B). use (monoidfununel f). Qed. Definition abgr_Cokernel_eqrel_issymm {A B : abgr} (f : monoidfun A B) : issymm (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid). Proof. intros x1 x2 x3. use (hinhuniv _ x3). intros x3'. intros P X. use X. clear P X. use tpair. - exact (grinv A (pr1 x3')). - use (pathscomp0 (monoidfuninvtoinv f (pr1 x3'))). rewrite (pr2 x3'). rewrite grinvop. use two_arg_paths. + use grinvinv. + use idpath. Qed. Definition abgr_Cokernel_eqrel {A B : abgr} (f : monoidfun A B) : eqrel B := @eqrelconstr B (λ b1 : B, λ b2 : B, ∃ a : A, (f a) = (op b1 (grinv B b2))) (abgr_Cokernel_eqrel_istrans f) (abgr_Cokernel_eqrel_isrefl f) (abgr_Cokernel_eqrel_issymm f). (** *** Construction of the quotient abelian group Y/(Im f) *) Definition abgr_Cokernel_abgr_isbinoprel {A B : abgr} (f : monoidfun A B) : isbinophrel (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv B b2)%multmonoid). Proof. use isbinophrelif. - exact (commax B). - intros x1 x2 x3 y1. use (hinhuniv _ y1). intros y1'. use hinhpr. use tpair. + exact (pr1 y1'). + use (pathscomp0 (pr2 y1')). rewrite grinvop. rewrite (commax B x3). rewrite (assocax B). rewrite (commax B x3). rewrite (assocax B). rewrite (grlinvax B x3). rewrite (runax B). use idpath. Qed. Definition abgr_Cokernel_abgr {A B : abgr} (f : monoidfun A B) : abgr := @abgrquot B (make_binopeqrel (abgr_Cokernel_eqrel f) (abgr_Cokernel_abgr_isbinoprel f)). (** *** The canonical morphism Y --> Y/(Im f) *) Lemma abgr_CokernelArrow_ismonoidfun {A B : abgr} (f : monoidfun A B) : @ismonoidfun B (@abgr_Cokernel_abgr A B f) (@setquotpr B (@abgr_Cokernel_eqrel A B f)). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use idpath. - use idpath. Qed. Definition abgr_CokernelArrow {A B : abgr} (f : monoidfun A B) : abgr_category⟦B, abgr_Cokernel_abgr f⟧. Proof. use monoidfunconstr. - exact (setquotpr (abgr_Cokernel_eqrel f)). - exact (abgr_CokernelArrow_ismonoidfun f). Defined. (** *** CokernelOut *) Lemma abgr_Cokernel_monoidfun_issurjective {A B : abgr} (f : monoidfun A B) : issurjective (pr1 (abgr_CokernelArrow f)). Proof. use issurjsetquotpr. Qed. Definition abgr_Cokernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) : f · abgr_CokernelArrow f = ZeroArrow abgr_Zero A (abgr_Cokernel_abgr f). Proof. use monoidfun_paths. use funextfun. intros a. use (iscompsetquotpr (abgr_Cokernel_eqrel f)). use hinhpr. use tpair. - exact a. - use (pathscomp0 (pathsinv0 (runax B (pr1 f a)))). use two_arg_paths. + use idpath. + use pathsinv0. use (grinvunel B). Qed. Definition abgr_CokernelArrowOutUniv_iscomprelfun {A B C : abgr_category} (f : A --> B) (h : B --> C) (H : f · h = ZeroArrow abgr_Zero A C) : iscomprelfun (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv (abgrtogr B) b2)%multmonoid) (pr1 h). Proof. intros x x' X. use (squash_to_prop X (setproperty (C : abgr) (pr1 h x) (pr1 h x'))). intros X'. use (grrcan (abgrtogr C) ((pr1 h) (grinv (abgrtogr B) x'))). use (pathscomp0 _ (binopfunisbinopfun (h : monoidfun (B : abgr) (C : abgr)) x' (grinv (B : abgr) x'))). use (pathscomp0 _ (! maponpaths (λ xx : (B : abgr), pr1 h xx) (grrinvax (B : abgr) x'))). use (pathscomp0 _ (! (monoidfununel h))). use (pathscomp0 _ (toforallpaths _ _ _ (base_paths _ _ H) (pr1 X'))). use (pathscomp0 (! (binopfunisbinopfun (h : monoidfun (B : abgr) (C : abgr)) x (grinv (B : abgr) x')))). use maponpaths. use pathsinv0. exact (pr2 X'). Qed. Definition abgr_CokernelOut_map {A B C : abgr_category} (f : A --> B) (h : B --> C) (H : f · h = ZeroArrow abgr_Zero A C) : (abgr_Cokernel_abgr f) -> (pr1 C) := setquotuniv (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv (abgrtogr B) b2)%multmonoid) (pr1 C) (pr1 h) (abgr_CokernelArrowOutUniv_iscomprelfun f h H). Definition abgr_CokernelOut_ismonoidfun {A B C : abgr} (f : abgr_category ⟦A, B⟧) (h : abgr_category ⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) : @ismonoidfun (@abgr_Cokernel_abgr A B f) C (@abgr_CokernelOut_map A B C f h H). Proof. use make_ismonoidfun. - exact (@isbinopfun_twooutof3b (pr1 B) (abgr_Cokernel_abgr f) C (pr1 (abgr_CokernelArrow f)) (abgr_CokernelOut_map f h H) (abgr_Cokernel_monoidfun_issurjective f) (binopfunisbinopfun (h : monoidfun B C)) (binopfunisbinopfun ((abgr_CokernelArrow f) : monoidfun B _))). - exact (monoidfununel (h : monoidfun B C)). Qed. Definition abgr_CokernelOut {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) : monoidfun (abgr_Cokernel_abgr f) C := monoidfunconstr (abgr_CokernelOut_ismonoidfun f h H). Lemma abgr_CokernelOut_Comm {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) : monoidfuncomp (abgr_CokernelArrow f) (abgr_CokernelOut f h H) = h. Proof. use monoidfun_paths. use funextfun. intros x. use idpath. Qed. Definition make_abgr_CokernelOut {A B C : abgr} (f : abgr_category ⟦A, B⟧) (h : abgr_category ⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) : ∑ ψ : abgr_category⟦abgr_Cokernel_abgr f, C⟧, abgr_CokernelArrow f · ψ = h. Proof. use tpair. - exact (abgr_CokernelOut f h H). - exact (abgr_CokernelOut_Comm f h H). Defined. (** *** Cokernels *) Lemma abgr_isCokernel_uniquenss {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) (t : ∑ ψ : abgr_category ⟦abgr_Cokernel_abgr f, C⟧, abgr_CokernelArrow f · ψ = h) : t = make_abgr_CokernelOut f h H. Proof. use total2_paths_f. - use monoidfun_paths. use funextfun. intros x. use (squash_to_prop (abgr_Cokernel_monoidfun_issurjective f x) (setproperty C _ _)). intros hf. rewrite <- (hfiberpr2 _ _ hf). exact (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) (hfiberpr1 _ _ hf)). - use proofirrelevance. use homset_property. Qed. Definition abgr_isCokernel {A B : abgr} (f : abgr_category⟦A, B⟧) : isCokernel abgr_Zero f (abgr_CokernelArrow f) (abgr_Cokernel_eq f). Proof. use make_isCokernel. - intros C h H. use make_iscontr. + exact (make_abgr_CokernelOut f h H). + intros t. exact (abgr_isCokernel_uniquenss f h H t). Defined. Definition abgr_Cokernel {A B : abgr} (f : abgr_category⟦A, B⟧) : Cokernel abgr_Zero f := make_Cokernel abgr_Zero f (abgr_CokernelArrow f) (abgr_Cokernel_eq f) (abgr_isCokernel f). Corollary abgr_Cokernels : Cokernels abgr_Zero. Proof. intros A B f. exact (abgr_Cokernel f). Defined. End abgr_kernels_and_cokernels. (** * Monics are injective and epis are surjective - Epis are surjective - Monics are injective *) Section abgr_monics_and_epis. (** ** Epis *) Definition abgr_epi_hfiber_inhabited {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (b : B) (H : setquotpr (abgr_Cokernel_eqrel f) b = setquotpr (abgr_Cokernel_eqrel f) 1%multmonoid) : ∥ hfiber (pr1 f) b ∥. Proof. set (tmp := weqpathsinsetquot (abgr_Cokernel_eqrel f) b (unel _)). use (hinhuniv _ ((invweq tmp) H)). intros Y. use hinhpr. induction Y as [t p]. rewrite grinvunel in p. rewrite (runax B) in p. exact (make_hfiber (pr1 f) t p). Qed. Definition abgr_epi_issurjective {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) : issurjective (pr1 f). Proof. intros x. use abgr_epi_hfiber_inhabited. - exact isE. - set (tmp := isE (abgr_Cokernel_abgr f) (abgr_CokernelArrow f) (unelabgrfun B (abgr_Cokernel_abgr f))). assert (H : f · abgr_CokernelArrow f = f · unelabgrfun B (abgr_Cokernel_abgr f)). { rewrite abgr_Cokernel_eq. rewrite <- abgr_Zero_arrow_comp. rewrite ZeroArrow_comp_right. use idpath. } exact (toforallpaths _ _ _ (base_paths _ _ (tmp H)) x). Qed. (** ** Monics *) Lemma nat_nat_prod_abgr_monoidfun_paths {A B : abgr} (a1 a2 : A) (f : monoidfun A B) (H : f a1 = f a2) : monoidfuncomp (nat_nat_prod_abmonoid_monoidfun a1) f = monoidfuncomp (nat_nat_prod_abmonoid_monoidfun a2) f. Proof. use monoidfun_paths. use funextfun. intros x. induction x as [x1 x2]. cbn. unfold nataddabmonoid_nataddabmonoid_to_monoid_fun. unfold nat_nat_to_monoid_fun. Opaque nat_to_monoid_fun. cbn. use (pathscomp0 (binopfunisbinopfun f _ _)). use (pathscomp0 _ (! (binopfunisbinopfun f _ _))). cbn. rewrite (monoidfun_nat_to_monoid_fun f a1 x1). rewrite (monoidfun_nat_to_monoid_fun f a2 x1). rewrite (monoidfun_nat_to_monoid_fun f (grinv A a1) x2). rewrite (monoidfun_nat_to_monoid_fun f (grinv A a2) x2). use two_arg_paths. - induction H. use idpath. - assert (e : f (grinv A a1) = f (grinv A a2)). { use (@grlcan B _ _ (pr1 f a1)). use (pathscomp0 (! binopfunisbinopfun f a1 (grinv A a1))). use (pathscomp0 (maponpaths (pr1 f) (grrinvax A a1))). cbn in H. rewrite H. use (pathscomp0 _ (binopfunisbinopfun f a2 (grinv A a2))). use (pathscomp0 _ (! (maponpaths (pr1 f) (grrinvax A a2)))). use idpath. } induction e. use idpath. Qed. Transparent nat_to_monoid_fun. Lemma abgr_monoidfun_precomp {A :abmonoid} {B C : abgr} (f1 f2 : monoidfun B C) (g : monoidfun A B) (H : issurjective (pr1 g)) : monoidfuncomp g f1 = monoidfuncomp g f2 -> f1 = f2. Proof. intros e. use monoidfun_paths. use funextfun. intros x. use (squash_to_prop (H x) (setproperty C _ _)). intros hf. rewrite <- (hfiberpr2 _ _ hf). exact (toforallpaths _ _ _ (base_paths _ _ e) (hfiberpr1 _ _ hf)). Qed. Lemma hz_abgr_fun_monoifun_paths {A B : abgr} (a1 a2 : A) (f : monoidfun A B) (H : f a1 = f a2) : monoidfuncomp (hz_abgr_fun_monoidfun a1) f = monoidfuncomp (hz_abgr_fun_monoidfun a2) f. Proof. use (@abgr_monoidfun_precomp (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) hzaddabgr B (monoidfuncomp (hz_abgr_fun_monoidfun a1) f) (monoidfuncomp (hz_abgr_fun_monoidfun a2) f) hz_abmonoid_monoidfun). - use issurjsetquotpr. - rewrite monoidfunassoc. rewrite monoidfunassoc. rewrite abgr_natnat_hz_X_comm. rewrite abgr_natnat_hz_X_comm. exact (nat_nat_prod_abgr_monoidfun_paths a1 a2 f H). Qed. Definition abgr_monic_isincl {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : isincl (pr1 f). Proof. intros b h1 h2. use make_iscontr. - use total2_paths_f. + set (e := hfiberpr2 _ _ h1 @ (! hfiberpr2 _ _ h2)). set (tmp := isM hzaddabgr (hz_abgr_fun_monoidfun (pr1 h1)) (hz_abgr_fun_monoidfun (pr1 h2)) (hz_abgr_fun_monoifun_paths (pr1 h1) (pr1 h2) f e)). set (e' := toforallpaths _ _ _ (base_paths _ _ tmp) hzone). use (grrcan A (unel A)). use (grrcan A (unel A)). exact e'. + use proofirrelevance. use (setproperty B). - intros t. use proofirrelevance. use isaset_hfiber. + use setproperty. + use setproperty. Qed. Definition abgr_monic_isInjective {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : isInjective (pr1 f). Proof. exact (isweqonpathsincl (pr1 f) (abgr_monic_isincl f isM)). Qed. Lemma abgr_monic_paths {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (a1 a2 : A) : pr1 f a1 = pr1 f a2 -> a1 = a2. Proof. exact (invweq (make_weq _ (abgr_monic_isInjective f isM a1 a2))). Qed. Lemma abgr_monoidfun_postcomp {A B C : abgr} (f1 f2 : monoidfun A B) (g : monoidfun B C) (isM : isMonic (g : abgr_category⟦B, C⟧)) : monoidfuncomp f1 g = monoidfuncomp f2 g -> f1 = f2. Proof. intros e. use monoidfun_paths. use funextfun. intros x. use (invmap (make_weq _ (abgr_monic_isInjective g isM (pr1 f1 x) (pr1 f2 x)))). exact (toforallpaths _ _ _ (base_paths _ _ e) x). Qed. End abgr_monics_and_epis. (** * Monics are kernels of their cokernels and epis are cokernels of their kernels *) Section abgr_monic_kernels_epi_cokernels. (** ** Monics are kernels of their cokernels *) Definition abgr_monic_kernel_in_hfiber_iscontr {A B C : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (h : abgr_category⟦C, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)) (c : C) : iscontr (hfiber (pr1 f) (pr1 h c)). Proof. use (squash_to_prop ((invweq (weqpathsinsetquot (abgr_Cokernel_eqrel f) (pr1 h c) (unel _))) (toforallpaths _ _ _ (base_paths _ _ H) c)) (isapropiscontr _)). intros hf. use make_iscontr. - use make_hfiber. + exact (pr1 hf). + use (pathscomp0 (pr2 hf)). rewrite grinvunel. use (runax B). - intros t. use total2_paths_f. + use (invmap (make_weq _ (abgr_monic_isInjective f isM (pr1 t) (pr1 hf)))). use (pathscomp0 (hfiberpr2 _ _ t)). use (pathscomp0 _ (! (pr2 hf))). rewrite grinvunel. rewrite runax. use idpath. + use proofirrelevance. use (setproperty B). Qed. Lemma abgr_monic_kernel_in_hfiber_mult_eq {A B : abgr} (f : abgr_category⟦A, B⟧) (w : abgr) (x x' : w) (h : abgr_category⟦w, B⟧) (X : hfiber (pr1 f) (pr1 h x)) (X0 : hfiber (pr1 f) (pr1 h x')) : pr1 f (pr1 X * pr1 X0)%multmonoid = pr1 h (x * x')%multmonoid. Proof. rewrite (pr1 (pr2 f)). rewrite (pr2 X). rewrite (pr2 X0). rewrite (pr1 (pr2 h)). use idpath. Qed. Definition abgr_monic_kernel_in_hfiber_mult {A B : abgr} (f : abgr_category⟦A, B⟧) (w : abgr) (x x' : w) (h : abgr_category⟦w, B⟧) : hfiber (pr1 f) (pr1 h x) -> hfiber (pr1 f) (pr1 h x') -> hfiber (pr1 f) (pr1 h (x * x')%multmonoid). Proof. intros X X0. exact (make_hfiber (pr1 f) ((pr1 X) * (pr1 X0))%multmonoid (abgr_monic_kernel_in_hfiber_mult_eq f w x x' h X X0)). Defined. Lemma abgr_monic_kernel_in_hfiber_unel_eq {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦C, B⟧) : pr1 f 1%multmonoid = pr1 h 1%multmonoid. Proof. rewrite (pr2 (pr2 h)). use (pr2 (pr2 f)). Qed. Definition abgr_monic_kernel_in_hfiber_unel {A B : abgr} (f : abgr_category⟦A, B⟧) (w : abgr) (h : abgr_category⟦w, B⟧) : hfiber (pr1 f) (pr1 h 1%multmonoid) := make_hfiber (pr1 f) 1%multmonoid (abgr_monic_kernel_in_hfiber_unel_eq f h). Definition abgr_monic_kernel_in {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (w : abgr) (h: abgr_category⟦w, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) : w -> A. Proof. intros x. exact (hfiberpr1 _ _ (iscontrpr1 (@abgr_monic_kernel_in_hfiber_iscontr A B w f isM h H x))). Defined. Definition abgr_monic_kernel_in_ismonoidfun {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (w : abgr) (h: abgr_category⟦w, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) : ismonoidfun (abgr_monic_kernel_in f isM w h H). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. set (t := abgr_monic_kernel_in_hfiber_iscontr f isM h H x). set (tmp := abgr_monic_kernel_in_hfiber_mult f w x x' h (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x)) (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x'))). use pathscomp0. + exact (hfiberpr1 _ _ tmp). + unfold abgr_monic_kernel_in. use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))). use (pathscomp0 (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H (x * x')%multmonoid)))). use pathsinv0. exact (hfiberpr2 _ _ tmp). + use idpath. - assert (e : iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H 1%multmonoid) = (abgr_monic_kernel_in_hfiber_unel f w h)). { use total2_paths_f. - use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))). use (pathscomp0 (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H 1%multmonoid)))). use pathsinv0. exact (hfiberpr2 _ _ (abgr_monic_kernel_in_hfiber_unel f w h)). - use proofirrelevance. use setproperty. } exact (base_paths _ _ e). Qed. Definition abgr_monic_kernel_in_monoidfun {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (w : abgr) (h: abgr_category⟦w, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) : monoidfun w A := monoidfunconstr (abgr_monic_kernel_in_ismonoidfun f isM w h H). Definition abgr_monic_Kernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : f · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero A (abgr_Cokernel f). Proof. use CokernelCompZero. Qed. Lemma abgr_monic_Kernel_isKernel_comm {A B C : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (h : abgr_category⟦C, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)): monoidfuncomp (abgr_monic_kernel_in_monoidfun f isM C h H) f = h. Proof. use monoidfun_paths. use funextfun. intros x. exact (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x))). Qed. Definition make_abgr_monic_Kernel_isKernel {A B C : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (h : abgr_category⟦C, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)) : ∑ ψ : abgr_category ⟦C, A⟧, ψ · f = h. Proof. use tpair. - exact (abgr_monic_kernel_in_monoidfun f isM C h H). - exact (abgr_monic_Kernel_isKernel_comm f isM h H). Defined. Definition abgr_monic_Kernel_isKernel_uniqueness {A B C : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (h : abgr_category⟦C, B⟧) (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)) (t : ∑ ψ : abgr_category ⟦C, A⟧, ψ · f = h) : t = make_abgr_monic_Kernel_isKernel f isM h H. Proof. use total2_paths_f. - use monoidfun_paths. use funextfun. intros x. use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))). use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x)). use pathsinv0. exact (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x))). - use proofirrelevance. use setproperty. Qed. Definition abgr_monic_Kernel_isKernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : isKernel abgr_Zero f (CokernelArrow (abgr_Cokernel f)) (CokernelCompZero abgr_Zero (abgr_Cokernel f)). Proof. use make_isKernel. - intros w h H. use make_iscontr. + exact (make_abgr_monic_Kernel_isKernel f isM h H). + exact (abgr_monic_Kernel_isKernel_uniqueness f isM h H). Defined. Definition abgr_monic_kernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : Kernel abgr_Zero (CokernelArrow (abgr_Cokernel f)) := make_Kernel abgr_Zero f (CokernelArrow (abgr_Cokernel f)) (abgr_monic_Kernel_eq f isM) (abgr_monic_Kernel_isKernel f isM). Lemma abgr_monic_kernel_comp {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) : KernelArrow (abgr_monic_kernel f isM) = f. Proof. use idpath. Qed. (** ** Epis are cokernels of their kernels *) Definition abgr_epi_cokernel_out_kernel_hsubtype {A B : abgr} (f : abgr_category⟦A, B⟧) (a : A) (H : pr1 f a = 1%multmonoid) : abgr_kernel_hsubtype f. Proof. exact (a,, H). Defined. Lemma abgr_epi_cokernel_out_data_eq {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) : ∏ x : abgr_kernel_hsubtype f, pr1 h (pr1carrier (abgr_kernel_hsubtype f) x) = 1%multmonoid. Proof. exact (toforallpaths _ _ _ (base_paths _ _ H)). Qed. Lemma abgr_epi_cokernel_out_data_hfibers_to_unel {A B : abgr} (f : abgr_category⟦A, B⟧) (b : B) (hfib1 hfib2 : hfiber (pr1 f) b) : (pr1 f) ((pr1 hfib1) * (grinv A (pr1 hfib2)))%multmonoid = unel B. Proof. rewrite (pr1 (pr2 f)). use (grrcan (abgrtogr B) (pr1 f (pr1 hfib2))). rewrite (assocax B). rewrite <- (pr1 (pr2 f)). rewrite (grlinvax A). rewrite (pr2 (pr2 f)). rewrite (runax B). rewrite (lunax B). rewrite (pr2 hfib1). rewrite (pr2 hfib2). use idpath. Qed. Lemma abgr_epi_cokernel_out_data_hfiber_eq {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) (b : B) (X : hfiber (pr1 f) b) : ∏ hfib : hfiber (pr1 f) b, pr1 h (pr1 hfib) = pr1 h (pr1 X). Proof. intros hfib. use (grrcan C (grinv (abgrtogr C) (pr1 h (pr1 X)))). rewrite (grrinvax C). set (e1 := abgr_epi_cokernel_out_data_hfibers_to_unel f b hfib X). set (tmp1 := ! (monoidfuninvtoinv h (hfiberpr1 _ _ X))). cbn in tmp1. use (pathscomp0 (maponpaths (λ k : _, ((pr1 h (pr1 hfib)) * k)%multmonoid) tmp1)). rewrite <- (pr1 (pr2 h)). set (tmp2 := abgr_epi_cokernel_out_data_eq f isE h H). set (tmp3 := abgr_epi_cokernel_out_kernel_hsubtype f (pr1 hfib * grinv A (pr1 X))%multmonoid e1). set (tmp4 := tmp2 tmp3). cbn in tmp4. exact tmp4. Qed. Lemma abgr_epi_CokernelOut_iscontr {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) (b : B) : iscontr (∑ x : C, ∏ (hfib : hfiber (pr1 f) b), pr1 h (pr1 hfib) = x). Proof. use (squash_to_prop (abgr_epi_issurjective f isE b) (isapropiscontr _)). intros X. use make_iscontr. - use tpair. + exact (pr1 h (pr1 X)). + exact (abgr_epi_cokernel_out_data_hfiber_eq f isE h H b X). - intros t. use total2_paths_f. + exact (! ((pr2 t) X)). + use proofirrelevance. use impred. intros t0. use (setproperty C). Defined. Definition abgr_epi_CokernelOut_mult_eq {A B C : abgr} (b1 b2 : B) (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) (X : ∑ x : C, ∏ hfib : hfiber (pr1 f) b1, pr1 h (pr1 hfib) = x) (X0 : ∑ x : C, ∏ hfib : hfiber (pr1 f) b2, pr1 h (pr1 hfib) = x) : ∏ hfib : hfiber (pr1 f) (b1 * b2)%multmonoid, pr1 h (pr1 hfib) = (pr1 X * pr1 X0)%multmonoid. Proof. intros hfib. use (squash_to_prop (abgr_epi_issurjective f isE b1) (setproperty C _ _)). intros X1. use (squash_to_prop (abgr_epi_issurjective f isE b2) (setproperty C _ _)). intros X2. rewrite <- ((pr2 X) X1). rewrite <- ((pr2 X0) X2). rewrite <- (pr1 (pr2 h)). exact (abgr_epi_cokernel_out_data_hfiber_eq f isE h H (b1 * b2)%multmonoid (hfiberbinop (f : monoidfun _ _) b1 b2 X1 X2) hfib). Qed. Definition abgr_epi_cokernel_out_data_mult {A B C : abgr} (b1 b2 : B) (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) : (∑ x : C, ∏ (hfib : hfiber (pr1 f) b1), pr1 h (pr1 hfib) = x) -> (∑ x : C, ∏ (hfib : hfiber (pr1 f) b2), pr1 h (pr1 hfib) = x) -> (∑ x : C, ∏ (hfib : hfiber (pr1 f) (b1 * b2)%multmonoid), pr1 h (pr1 hfib) = x). Proof. intros X X0. exact (tpair _ ((pr1 X) * (pr1 X0))%multmonoid (abgr_epi_CokernelOut_mult_eq b1 b2 f isE h H X X0)). Defined. Definition abgr_epi_cokernel_out_data_unel_eq {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) : ∏ hfib : hfiber (pr1 f) 1%multmonoid, pr1 h (pr1 hfib) = 1%multmonoid. Proof. intros hfib. set (hfib_unel := make_hfiber (pr1 f) 1%multmonoid (pr2 (pr2 f))). rewrite (abgr_epi_cokernel_out_data_hfiber_eq f isE h H 1%multmonoid hfib_unel hfib). exact (monoidfununel h). Qed. Definition abgr_epi_cokernel_out_data_unel {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) : ( ∑ x : C, ∏ (hfib : hfiber (pr1 f) 1%multmonoid), pr1 h (pr1 hfib) = x) := tpair _ 1%multmonoid (abgr_epi_cokernel_out_data_unel_eq f isE h H). Lemma abgr_epi_cokernel_out_ismonoidfun {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) : ismonoidfun (λ b : B, (pr1 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H b)))). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. set (HH0 := abgr_epi_cokernel_out_data_mult x x' f isE h H (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H x)) (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H x'))). assert (HH : iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (x * x')%multmonoid) = HH0). { set (tmp := abgr_epi_CokernelOut_iscontr f isE h H (x * x')%multmonoid). rewrite (pr2 tmp). use pathsinv0. rewrite (pr2 tmp). use idpath. } exact (base_paths _ _ HH). - assert (HH : iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid) = abgr_epi_cokernel_out_data_unel f isE h H). { rewrite (pr2 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid)). use pathsinv0. rewrite (pr2 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid)). use idpath. } exact (base_paths _ _ HH). Qed. Definition abgr_epi_cokernel_out_monoidfun {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) : monoidfun B C := monoidfunconstr (abgr_epi_cokernel_out_ismonoidfun f isE h H). Definition abgr_epi_cokernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) : KernelArrow (abgr_Kernel f) · f = ZeroArrow abgr_Zero _ _. Proof. use KernelCompZero. Qed. Lemma abgr_epi_cokernel_isCokernel_comm {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) : f · abgr_epi_cokernel_out_monoidfun f isE h H = h. Proof. use total2_paths_f. - use funextfun. intros x. use pathsinv0. exact (pr2 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (pr1 f x))) (@make_hfiber _ _ (pr1 f) (pr1 f x) x (idpath _))). - use proofirrelevance. use isapropismonoidfun. Qed. Definition make_abgr_epi_cokernel_isCokernel {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) : ∑ ψ : abgr_category ⟦B, C⟧, f · ψ = h. Proof. use tpair. - exact (abgr_epi_cokernel_out_monoidfun f isE h H). - exact (abgr_epi_cokernel_isCokernel_comm f isE h H). Defined. Lemma abgr_epi_cokernel_isCokernel_uniqueness {A B C : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧) (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) (t : ∑ ψ : abgr_category ⟦B, C⟧, f · ψ = h) : t = make_abgr_epi_cokernel_isCokernel f isE h H. Proof. use total2_paths_f. - use isE. use (pathscomp0 (pr2 t)). use monoidfun_paths. use funextfun. intros x. exact (pr2 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (pr1 f x))) (@make_hfiber _ _ (pr1 f) (pr1 f x) x (idpath _))). - use proofirrelevance. use setproperty. Qed. Definition abgr_epi_cokernel_isCokernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) : isCokernel abgr_Zero (KernelArrow (abgr_Kernel f)) f (abgr_epi_cokernel_eq f isE). Proof. use make_isCokernel. - intros w h H. use make_iscontr. + exact (make_abgr_epi_cokernel_isCokernel f isE h H). + intros t. exact (abgr_epi_cokernel_isCokernel_uniqueness f isE h H t). Defined. Definition abgr_epi_cokernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) : Cokernel abgr_Zero (KernelArrow (abgr_Kernel f)) := make_Cokernel abgr_Zero (KernelArrow (abgr_Kernel f)) f _ (abgr_epi_cokernel_isCokernel f isE). Definition abgr_epi_cokernel_comp {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) : CokernelArrow (abgr_epi_cokernel f isE) = f. Proof. use idpath. Qed. End abgr_monic_kernels_epi_cokernels. (** * Category of abelian groups is an abelian category *) Section abgr_abelian. Definition abgr_Abelian : AbelianPreCat. Proof. set (BinDS := to_BinDirectSums abgr_Additive). use (make_Abelian abgr_category). - use make_Data1. + exact abgr_Zero. + intros X Y. exact (BinDirectSum_BinProduct abgr_Additive (BinDS X Y)). + intros X Y. exact (BinDirectSum_BinCoproduct abgr_Additive (BinDS X Y)). - use make_AbelianData. + use make_Data2. * intros A B f. exact (abgr_Kernel f). * intros A B f. exact (abgr_Cokernel f). + use make_MonicsAreKernels. intros x y M. exact (KernelisKernel abgr_Zero (abgr_monic_kernel M (MonicisMonic abgr_category M))). + use make_EpisAreCokernels. intros x y E. exact (CokernelisCokernel abgr_Zero (abgr_epi_cokernel E (EpiisEpi abgr_category E))). Defined. End abgr_abelian. (** * Corollaries to additive categories In an additive category the homsets are abelian groups and pre- and postcompositions are morphisms of abelian groups. In this section we prove the following lemmas about additive categories using the theory of abelian groups developed above - A morphism φ in an additive category which gives isomorphisms (φ · _) and (_ · φ) is an isomorphism, [abgr_Additive_premor_postmor_is_iso]. - A criteria of being a kernel in the category of abelian groups which uses only elements of abelian groups, [abgr_isKernel_Criteria]. *) Section abgr_corollaries. (** ** Isomorphism criteria *) (** *** (_ · ZeroArrow) = ZeroArrow = (ZeroArrow · _) *) Lemma AdditiveZeroArrow_postmor_Abelian {Add : CategoryWithAdditiveStructure} (x y z : Add) : to_postmor_monoidfun Add x y z (ZeroArrow (Additive.to_Zero Add) y z) = ZeroArrow (to_Zero abgr_Abelian) (@to_abgr Add x y) (@to_abgr Add x z). Proof. rewrite <- PreAdditive_unel_zero. use monoidfun_paths. use funextfun. intros f. exact (to_premor_unel Add z f). Qed. Lemma AdditiveZeroArrow_premor_Abelian {Add : CategoryWithAdditiveStructure} (x y z : Add) : to_premor_monoidfun Add x y z (ZeroArrow (Additive.to_Zero Add) x y) = ZeroArrow (to_Zero abgr_Abelian) (@to_abgr Add y z) (@to_abgr Add x z). Proof. rewrite <- PreAdditive_unel_zero. use monoidfun_paths. use funextfun. intros f. exact (to_postmor_unel Add x f). Qed. (** *** f isomorphism ⇒ (f · _) isomorphism *) Local Lemma abgr_Additive_is_iso_premor_inverses {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : x --> y} (H : is_z_isomorphism f) : is_inverse_in_precat ((to_premor_monoidfun Add x y z f) : abgr_Abelian⟦_, _⟧) (to_premor_monoidfun Add y x z (is_z_isomorphism_mor H)). Proof. use make_is_inverse_in_precat. - use monoidfun_paths. use funextfun. intros x0. cbn. unfold to_premor. rewrite assoc. rewrite (is_inverse_in_precat2 H). use id_left. - use monoidfun_paths. use funextfun. intros x0. cbn. unfold to_premor. rewrite assoc. rewrite (is_inverse_in_precat1 H). use id_left. Qed. Lemma abgr_Additive_is_iso_premor {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : x --> y} (H : is_z_isomorphism f) : @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y z f). Proof. use make_is_z_isomorphism. - exact (to_premor_monoidfun Add _ _ z (is_z_isomorphism_mor H)). - exact (abgr_Additive_is_iso_premor_inverses _ _ z H). Defined. (** *** f isomorphism ⇒ (_ · f) isomorphism *) Local Lemma abgr_Additive_is_iso_postmor_inverses {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : y --> z} (H : is_z_isomorphism f) : is_inverse_in_precat ((to_postmor_monoidfun Add x y z f) : abgr_Abelian⟦_, _⟧) (to_postmor_monoidfun Add x z y (is_z_isomorphism_mor H)). Proof. use make_is_inverse_in_precat. - use monoidfun_paths. use funextfun. intros x0. cbn. unfold to_postmor. rewrite <- assoc. rewrite (is_inverse_in_precat1 H). use id_right. - use monoidfun_paths. use funextfun. intros x0. cbn. unfold to_postmor. rewrite <- assoc. rewrite (is_inverse_in_precat2 H). use id_right. Qed. Lemma abgr_Additive_is_iso_postmor {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : y --> z} (H : is_z_isomorphism f) : @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add x y z f). Proof. use make_is_z_isomorphism. - exact (to_postmor_monoidfun Add x _ _ (is_z_isomorphism_mor H)). - exact (abgr_Additive_is_iso_postmor_inverses x _ _ H). Defined. (** *** Pre- and postcomposition with f is an isomorphism ⇒ f isomorphism *) Local Lemma abgr_Additive_premor_postmor_is_iso_inverses {Add : CategoryWithAdditiveStructure} (x y : Add) {f : x --> y} (H1 : @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y x f)) (H2 : @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add y x y f)) : is_inverse_in_precat f ((is_z_isomorphism_mor H1 : monoidfun (to_abgr x x) (to_abgr y x)) (identity x : to_abgr x x)). Proof. set (mor1 := ((is_z_isomorphism_mor H1) : (monoidfun (to_abgr x x) (to_abgr y x))) ((identity x) : to_abgr x x)). set (mor2 := ((is_z_isomorphism_mor H2) : (monoidfun (to_abgr y y) (to_abgr y x))) ((identity y) : to_abgr y y)). assert (Hx : f · mor1 = identity x). { exact (toforallpaths _ _ _ (base_paths _ _ (is_inverse_in_precat2 H1)) (identity x)). } assert (Hy : mor2 · f = identity y). { exact (toforallpaths _ _ _ (base_paths _ _ (is_inverse_in_precat2 H2)) (identity y)). } assert (H : mor1 = mor2). { rewrite <- (id_right mor2). rewrite <- Hx. rewrite assoc. rewrite Hy. rewrite id_left. use idpath. } use make_is_inverse_in_precat. - exact Hx. - rewrite H. exact Hy. Qed. Lemma abgr_Additive_premor_postmor_is_iso {Add : CategoryWithAdditiveStructure} (x y : Add) {f : x --> y} (H1 : @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y x f)) (H2 : @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add y x y f)) : is_z_isomorphism f. Proof. use make_is_z_isomorphism. - exact (((is_z_isomorphism_mor H1) : (monoidfun (to_abgr x x) (to_abgr y x))) ((identity x) : to_abgr x x)). - exact (abgr_Additive_premor_postmor_is_iso_inverses _ _ H1 H2). Defined. (** ** A criteria for isKernel which uses only the elements in the abelian group. *) Local Opaque ZeroArrow. Definition abgr_isKernel_iscontr {X Y Z W : abgr_Abelian} (f : X --> Y) (g : Y --> Z) (ZA : f · g = @ZeroArrow abgr_Abelian (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥) (isM : @isMonic abgr_Abelian _ _ f) (h : W --> Y) (H' : h · g = @ZeroArrow abgr_Abelian (to_Zero abgr_Abelian) W Z) (w' : pr1 W) : iscontr (∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = pr1 h w'). Proof. cbn in H'. rewrite <- (@PreAdditive_unel_zero (abgr_PreAdditive)) in H'. unfold to_unel in H'. set (e := toforallpaths _ _ _ (base_paths _ _ H') w'). set (H'' := H (tpair _ (pr1 h w') e)). use (squash_to_prop H'' (isapropiscontr _)). intros HH. induction HH as [H1 H2]. cbn in H2. use tpair. - use tpair. + exact H1. + exact H2. - cbn. intros T. induction T as [T1 T2]. use total2_paths_f. + use (abgr_monic_paths f isM T1 H1). cbn in H2. cbn. rewrite H2. rewrite T2. use idpath. + use proofirrelevance. use setproperty. Qed. Lemma abgr_isKernel_Criteria_ismonoidfun {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z) (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D)∥) (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧) (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) : ismonoidfun (λ w' : (W : abgr), pr1 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' w'))). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x y. use (abgr_monic_paths f isM). use (pathscomp0 _ (! binopfunisbinopfun (f : monoidfun _ _) _ _)). use (pathscomp0 (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' ((x * y)%multmonoid))))). use (pathscomp0 (binopfunisbinopfun (h : monoidfun _ _) _ _)). use pathsinv0. use two_arg_paths. + exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))). + exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (y%multmonoid)))). - use (abgr_monic_paths f isM). use (pathscomp0 (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (unel (W : abgr)))))). use (pathscomp0 (monoidfununel h)). exact (! monoidfununel f). Qed. Lemma abgr_isKernel_Criteria_comm {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z) (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥) (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧) (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) : monoidfuncomp (monoidfunconstr (abgr_isKernel_Criteria_ismonoidfun f g ZA H isM h H')) f = h. Proof. use monoidfun_paths. use funextfun. intros x. exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))). Qed. Definition make_abgr_isKernel_Criteria {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z) (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥) (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧) (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) : ∑ ψ : abgr_Abelian ⟦W, X⟧, ψ · f = h. Proof. use tpair. - use monoidfunconstr. + intros w'. exact (pr1 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' w'))). + exact (abgr_isKernel_Criteria_ismonoidfun f g ZA H isM h H'). - exact (abgr_isKernel_Criteria_comm f g ZA H isM h H'). Defined. Lemma abgr_isKernel_Criteria_uniqueness {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z) (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥) (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧) (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) (t : ∑ ψ : abgr_Abelian ⟦W, X⟧, ψ · f = h) : t = make_abgr_isKernel_Criteria f g ZA H isM h H'. Proof. use total2_paths_f. - use monoidfun_paths. use funextfun. intros x. use (abgr_monic_paths f isM). use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x)). use pathsinv0. exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))). - use proofirrelevance. use setproperty. Qed. Definition abgr_isKernel_Criteria {X Y Z : abgr_category} (f : X --> Y) (g : Y --> Z) (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _) (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)), ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥) (isM : @isMonic abgr_category _ _ f) : isKernel (to_Zero abgr_Abelian) f g ZA. Proof. use make_isKernel. - intros w h H'. use make_iscontr. + exact (make_abgr_isKernel_Criteria f g ZA H isM h H'). + intros t. exact (abgr_isKernel_Criteria_uniqueness f g ZA H isM h H' t). Defined. End abgr_corollaries. UniMath-20231010/UniMath/CategoryTheory/categories/abmonoids.v000066400000000000000000000143311451125700300241150ustar00rootroot00000000000000(** * Category of abmonoids *) (** ** Contents - Precategory of abmonoids - Category of abmonoids *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of abmonoids *) Section def_abmonoid_precategory. Definition abmonoid_fun_space (A B : abmonoid) : hSet := make_hSet (monoidfun A B) (isasetmonoidfun A B). Definition abmonoid_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) abmonoid (λ A B : abmonoid, abmonoid_fun_space A B). Definition abmonoid_precategory_data : precategory_data := make_precategory_data abmonoid_precategory_ob_mor (λ (X : abmonoid), ((idmonoidiso X) : monoidfun X X)) (fun (X Y Z : abmonoid) (f : monoidfun X Y) (g : monoidfun Y Z) => monoidfuncomp f g). Local Lemma abmonoid_id_left (X Y : abmonoid) (f : monoidfun X Y) : monoidfuncomp (idmonoidiso X) f = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque abmonoid_id_left. Local Lemma abmonoid_id_right (X Y : abmonoid) (f : monoidfun X Y) : monoidfuncomp f (idmonoidiso Y) = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque abmonoid_id_right. Local Lemma abmonoid_assoc (X Y Z W : abmonoid) (f : monoidfun X Y) (g : monoidfun Y Z) (h : monoidfun Z W) : monoidfuncomp f (monoidfuncomp g h) = monoidfuncomp (monoidfuncomp f g) h. Proof. use monoidfun_paths. use idpath. Defined. Opaque abmonoid_assoc. Lemma is_precategory_abmonoid_precategory_data : is_precategory abmonoid_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use abmonoid_id_left. - intros a b f. use abmonoid_id_right. - intros a b c d f g h. use abmonoid_assoc. Qed. Definition abmonoid_precategory : precategory := make_precategory abmonoid_precategory_data is_precategory_abmonoid_precategory_data. Lemma has_homsets_abmonoid_precategory : has_homsets abmonoid_precategory. Proof. intros X Y. use isasetmonoidfun. Qed. End def_abmonoid_precategory. (** * Category of abmonoids *) Section def_abmonoid_category. Definition abmonoid_category : category := make_category _ has_homsets_abmonoid_precategory. (** ** (monoidsiso X Y) ≃ (iso X Y) *) Lemma abmonoid_iso_is_equiv (A B : ob abmonoid_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1monoidfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropismonoidfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropismonoidfun. Defined. Opaque abmonoid_iso_is_equiv. Lemma abmonoid_iso_equiv (X Y : ob abmonoid_category) : z_iso X Y -> monoidiso (X : abmonoid) (Y : abmonoid). Proof. intro f. use make_monoidiso. - exact (make_weq (pr1 (pr1 f)) (abmonoid_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma abmonoid_equiv_is_z_iso (X Y : ob abmonoid_category) (f : monoidiso (X : abmonoid) (Y : abmonoid)) : @is_z_isomorphism abmonoid_category X Y (monoidfunconstr (pr2 f)). Proof. exists (monoidfunconstr (pr2 (invmonoidiso f))). use make_is_inverse_in_precat. - use monoidfun_paths. use funextfun. intros x. use homotinvweqweq. - use monoidfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque abmonoid_equiv_is_z_iso. Lemma abmonoid_equiv_z_iso (X Y : ob abmonoid_category) : monoidiso (X : abmonoid) (Y : abmonoid) -> z_iso X Y. Proof. intros f. exists (monoidfunconstr (pr2 f)). exact (abmonoid_equiv_is_z_iso X Y f). Defined. Lemma abmonoid_iso_equiv_is_equiv (X Y : ob abmonoid_category) : isweq (abmonoid_iso_equiv X Y). Proof. use isweq_iso. - exact (abmonoid_equiv_z_iso X Y). - intros x. use z_iso_eq. use monoidfun_paths. use idpath. - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Defined. Opaque abmonoid_iso_equiv_is_equiv. Definition abmonoid_iso_equiv_weq (X Y : ob abmonoid_category) : weq (z_iso X Y) (monoidiso (X : abmonoid) (Y : abmonoid)). Proof. use make_weq. - exact (abmonoid_iso_equiv X Y). - exact (abmonoid_iso_equiv_is_equiv X Y). Defined. Lemma abmonoid_equiv_iso_is_equiv (X Y : ob abmonoid_category) : isweq (abmonoid_equiv_z_iso X Y). Proof. use isweq_iso. - exact (abmonoid_iso_equiv X Y). - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. use z_iso_eq. use monoidfun_paths. use idpath. Defined. Opaque abmonoid_equiv_iso_is_equiv. Definition abmonoid_equiv_weq_iso (X Y : ob abmonoid_category) : (monoidiso (X : abmonoid) (Y : abmonoid)) ≃ (z_iso X Y). Proof. use make_weq. - exact (abmonoid_equiv_z_iso X Y). - exact (abmonoid_equiv_iso_is_equiv X Y). Defined. (** ** Category of abmonoids *) Definition abmonoid_category_isweq (X Y : ob abmonoid_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (abmonoid_univalence X Y) (abmonoid_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (abmonoid_univalence X Y) (abmonoid_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque abmonoid_category_isweq. Definition abmonoid_category_is_univalent : is_univalent abmonoid_category. Proof. intros X Y. exact (abmonoid_category_isweq X Y). Defined. Definition abmonoid_univalent_category : univalent_category := make_univalent_category abmonoid_category abmonoid_category_is_univalent. End def_abmonoid_category. UniMath-20231010/UniMath/CategoryTheory/categories/commrigs.v000066400000000000000000000140341451125700300237620ustar00rootroot00000000000000(** * Category of commrigs *) (** ** Contents - Precategory of commrigs - Category of commrigs *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of commrigs *) Section def_commrig_precategory. Definition commrig_fun_space (A B : commrig) : hSet := make_hSet (rigfun A B) (isasetrigfun A B). Definition commrig_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) commrig (λ A B : commrig, commrig_fun_space A B). Definition commrig_precategory_data : precategory_data := make_precategory_data commrig_precategory_ob_mor (λ (X : commrig), (rigisotorigfun (idrigiso X))) (fun (X Y Z : commrig) (f : rigfun X Y) (g : rigfun Y Z) => rigfuncomp f g). Local Lemma commrig_id_left (X Y : commrig) (f : rigfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque commrig_id_left. Local Lemma commrig_id_commright (X Y : commrig) (f : rigfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque commrig_id_commright. Local Lemma commrig_assoc (X Y Z W : commrig) (f : rigfun X Y) (g : rigfun Y Z) (h : rigfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. apply idpath. Defined. Opaque commrig_assoc. Lemma is_precategory_commrig_precategory_data : is_precategory commrig_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use commrig_id_left. - intros a b f. use commrig_id_commright. - intros a b c d f g h. use commrig_assoc. Qed. Definition commrig_precategory : precategory := make_precategory commrig_precategory_data is_precategory_commrig_precategory_data. Lemma has_homsets_commrig_precategory : has_homsets commrig_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_commrig_precategory. (** * Category of commrigs *) Section def_commrig_category. Definition commrig_category : category := make_category _ has_homsets_commrig_precategory. (** ** (rigiso X Y) ≃ (z_iso X Y) *) Lemma commrig_iso_is_equiv (A B : ob commrig_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque commrig_iso_is_equiv. Lemma commrig_iso_equiv (X Y : ob commrig_category) : z_iso X Y -> rigiso (X : commrig) (Y : commrig). Proof. intro f. use make_rigiso. - exact (make_weq (pr1 (pr1 f)) (commrig_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma commrig_equiv_is_z_iso (X Y : ob commrig_category) (f : rigiso (X : commrig) (Y : commrig)) : @is_z_isomorphism commrig_precategory X Y (rigfunconstr (pr2 f)). Proof. exists (rigfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque commrig_equiv_is_z_iso. Lemma commrig_equiv_iso (X Y : ob commrig_category) : rigiso (X : commrig) (Y : commrig) -> z_iso X Y. Proof. intros f. exact (_,,commrig_equiv_is_z_iso X Y f). Defined. Lemma commrig_iso_equiv_is_equiv (X Y : commrig_category) : isweq (commrig_iso_equiv X Y). Proof. use isweq_iso. - exact (commrig_equiv_iso X Y). - intros x. use z_iso_eq. use rigfun_paths. apply idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. Defined. Opaque commrig_iso_equiv_is_equiv. Definition commrig_iso_equiv_weq (X Y : ob commrig_category) : weq (z_iso X Y) (rigiso (X : commrig) (Y : commrig)). Proof. use make_weq. - exact (commrig_iso_equiv X Y). - exact (commrig_iso_equiv_is_equiv X Y). Defined. Lemma commrig_equiv_iso_is_equiv (X Y : ob commrig_category) : isweq (commrig_equiv_iso X Y). Proof. use isweq_iso. - exact (commrig_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. - intros x. use z_iso_eq. use rigfun_paths. apply idpath. Defined. Opaque commrig_equiv_iso_is_equiv. Definition commrig_equiv_weq_iso (X Y : ob commrig_category) : (rigiso (X : commrig) (Y : commrig)) ≃ (z_iso X Y). Proof. use make_weq. - exact (commrig_equiv_iso X Y). - exact (commrig_equiv_iso_is_equiv X Y). Defined. (** ** Category of commrigs *) Definition commrig_category_isweq (X Y : ob commrig_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (commrig_univalence X Y) (commrig_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (commrig_univalence X Y) (commrig_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - apply idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque commrig_category_isweq. Definition commrig_category_is_univalent : is_univalent commrig_category. Proof. intros X Y. exact (commrig_category_isweq X Y). Defined. Definition commrig_univalent_category : univalent_category := make_univalent_category commrig_category commrig_category_is_univalent. End def_commrig_category. UniMath-20231010/UniMath/CategoryTheory/categories/commrings.v000066400000000000000000000141721451125700300241430ustar00rootroot00000000000000(** * Category of commrings *) (** ** Contents - Precategory of commrings - Category of commrings *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Category of commrings *) Section def_commring_precategory. Definition commring_fun_space (A B : commring) : hSet := make_hSet (ringfun A B) (isasetrigfun A B). Definition commring_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) commring (λ A B : commring, commring_fun_space A B). Definition commring_precategory_data : precategory_data := make_precategory_data commring_precategory_ob_mor (λ (X : commring), (rigisotorigfun (idrigiso X))) (fun (X Y Z : commring) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g). Local Lemma commring_id_left (X Y : commring) (f : ringfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. use idpath. Defined. Opaque commring_id_left. Local Lemma commring_id_right (X Y : commring) (f : ringfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. use idpath. Defined. Opaque commring_id_right. Local Lemma commring_assoc (X Y Z W : commring) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. use idpath. Defined. Opaque commring_assoc. Lemma is_precategory_commring_precategory_data : is_precategory commring_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use commring_id_left. - intros a b f. use commring_id_right. - intros a b c d f g h. use commring_assoc. Qed. Definition commring_precategory : precategory := make_precategory commring_precategory_data is_precategory_commring_precategory_data. Lemma has_homsets_commring_precategory : has_homsets commring_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_commring_precategory. (** * Category of commrings *) Section def_commring_category. Definition commring_category : category := make_category _ has_homsets_commring_precategory. (** ** (ringiso X Y) ≃ (z_iso X Y) *) Lemma commring_iso_is_equiv (A B : ob commring_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque commring_iso_is_equiv. Lemma commring_iso_equiv (X Y : ob commring_category) : z_iso X Y -> ringiso (X : commring) (Y : commring). Proof. intro f. use make_ringiso. - exact (make_weq (pr1 (pr1 f)) (commring_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma commring_equiv_is_z_iso (X Y : ob commring_category) (f : ringiso (X : commring) (Y : commring)) : @is_z_isomorphism commring_category X Y (ringfunconstr (pr2 f)). Proof. exists (ringfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque commring_equiv_is_z_iso. Lemma commring_equiv_iso (X Y : ob commring_category) : ringiso (X : commring) (Y : commring) -> z_iso X Y. Proof. intros f. exact (_,,commring_equiv_is_z_iso X Y f). Defined. Lemma commring_iso_equiv_is_equiv (X Y : commring_category) : isweq (commring_iso_equiv X Y). Proof. use isweq_iso. - exact (commring_equiv_iso X Y). - intros x. use z_iso_eq. use rigfun_paths. apply idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. Defined. Opaque commring_iso_equiv_is_equiv. Definition commring_iso_equiv_weq (X Y : ob commring_category) : weq (z_iso X Y) (ringiso (X : commring) (Y : commring)). Proof. use make_weq. - exact (commring_iso_equiv X Y). - exact (commring_iso_equiv_is_equiv X Y). Defined. Lemma commring_equiv_iso_is_equiv (X Y : ob commring_category) : isweq (commring_equiv_iso X Y). Proof. use isweq_iso. - exact (commring_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. - intros x. use z_iso_eq. use rigfun_paths. apply idpath. Defined. Opaque commring_equiv_iso_is_equiv. Definition commring_equiv_weq_iso (X Y : ob commring_category) : (ringiso (X : commring) (Y : commring)) ≃ (z_iso X Y). Proof. use make_weq. - exact (commring_equiv_iso X Y). - exact (commring_equiv_iso_is_equiv X Y). Defined. (** ** Category of commrings *) Definition commring_category_isweq (X Y : ob commring_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (commring_univalence X Y) (commring_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (commring_univalence X Y) (commring_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - apply idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque commring_category_isweq. Definition commring_category_is_univalent : is_univalent commring_category. Proof. intros X Y. exact (commring_category_isweq X Y). Defined. Definition commring_univalent_category : univalent_category := make_univalent_category commring_category commring_category_is_univalent. End def_commring_category. UniMath-20231010/UniMath/CategoryTheory/categories/flds.v000066400000000000000000000133011451125700300230660ustar00rootroot00000000000000(** * Category of flds *) (** ** Contents - Precategory of flds - Category of flds *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of flds *) Section def_fld_precategory. Definition fld_fun_space (A B : fld) : hSet := make_hSet (ringfun A B) (isasetrigfun A B). Definition fld_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) fld (λ A B : fld, fld_fun_space A B). Definition fld_precategory_data : precategory_data := make_precategory_data fld_precategory_ob_mor (λ (X : fld), (rigisotorigfun (idrigiso X))) (fun (X Y Z : fld) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g). Local Lemma fld_id_left (X Y : fld) (f : ringfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque fld_id_left. Local Lemma fld_id_right (X Y : fld) (f : ringfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque fld_id_right. Local Lemma fld_assoc (X Y Z W : fld) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. apply idpath. Defined. Opaque fld_assoc. Lemma is_precategory_fld_precategory_data : is_precategory fld_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use fld_id_left. - intros a b f. use fld_id_right. - intros a b c d f g h. use fld_assoc. Qed. Definition fld_precategory : precategory := make_precategory fld_precategory_data is_precategory_fld_precategory_data. Lemma has_homsets_fld_precategory : has_homsets fld_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_fld_precategory. (** * Category of flds *) Section def_fld_category. Definition fld_category : category := make_category _ has_homsets_fld_precategory. (** ** (rigiso X Y) ≃ (z_iso X Y) *) Lemma fld_iso_is_equiv (A B : ob fld_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque fld_iso_is_equiv. Lemma fld_iso_equiv (X Y : ob fld_category) : z_iso X Y -> ringiso (X : fld) (Y : fld). Proof. intro f. use make_ringiso. - exact (make_weq (pr1 (pr1 f)) (fld_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma fld_equiv_is_z_iso (X Y : ob fld_category) (f : ringiso (X : fld) (Y : fld)) : @is_z_isomorphism fld_category X Y (ringfunconstr (pr2 f)). Proof. exists (ringfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque fld_equiv_is_z_iso. Lemma fld_equiv_iso (X Y : ob fld_category) : ringiso (X : fld) (Y : fld) -> z_iso X Y. Proof. intros f. exact (_,,fld_equiv_is_z_iso X Y f). Defined. Lemma fld_iso_equiv_is_equiv (X Y : fld_category) : isweq (fld_iso_equiv X Y). Proof. use isweq_iso. - exact (fld_equiv_iso X Y). - intros x. use z_iso_eq. use rigfun_paths. apply idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. Defined. Opaque fld_iso_equiv_is_equiv. Definition fld_iso_equiv_weq (X Y : ob fld_category) : weq (z_iso X Y) (ringiso (X : fld) (Y : fld)). Proof. use make_weq. - exact (fld_iso_equiv X Y). - exact (fld_iso_equiv_is_equiv X Y). Defined. Lemma fld_equiv_iso_is_equiv (X Y : ob fld_category) : isweq (fld_equiv_iso X Y). Proof. use isweq_iso. - exact (fld_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. - intros x. use z_iso_eq. use rigfun_paths. apply idpath. Defined. Opaque fld_equiv_iso_is_equiv. Definition fld_equiv_weq_iso (X Y : ob fld_category) : (ringiso (X : fld) (Y : fld)) ≃ (z_iso X Y). Proof. use make_weq. - exact (fld_equiv_iso X Y). - exact (fld_equiv_iso_is_equiv X Y). Defined. (** ** Category of flds *) Definition fld_category_isweq (X Y : ob fld_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (fld_univalence X Y) (fld_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (fld_univalence X Y) (fld_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - apply idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque fld_category_isweq. Definition fld_category_is_univalent : is_univalent fld_category. Proof. intros X Y. exact (fld_category_isweq X Y). Defined. Definition fld_univalent_category : univalent_category := make_univalent_category fld_category fld_category_is_univalent. End def_fld_category. UniMath-20231010/UniMath/CategoryTheory/categories/grs.v000066400000000000000000000132321451125700300227340ustar00rootroot00000000000000(** * Category of grs *) (** ** Contents - Precategory of grs - Category of grs *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.Core.Functors. (** * Precategory of grs *) Section def_gr_precategory. Definition gr_fun_space (A B : gr) : hSet := make_hSet (monoidfun A B) (isasetmonoidfun A B). Definition gr_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) gr (λ A B : gr, gr_fun_space A B). Definition gr_precategory_data : precategory_data := make_precategory_data gr_precategory_ob_mor (λ (X : gr), ((idmonoidiso X) : monoidfun X X)) (fun (X Y Z : gr) (f : monoidfun X Y) (g : monoidfun Y Z) => monoidfuncomp f g). Local Lemma gr_id_left (X Y : gr) (f : monoidfun X Y) : monoidfuncomp (idmonoidiso X) f = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque gr_id_left. Local Lemma gr_id_right (X Y : gr) (f : monoidfun X Y) : monoidfuncomp f (idmonoidiso Y) = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque gr_id_right. Local Lemma gr_assoc (X Y Z W : gr) (f : monoidfun X Y) (g : monoidfun Y Z) (h : monoidfun Z W) : monoidfuncomp f (monoidfuncomp g h) = monoidfuncomp (monoidfuncomp f g) h. Proof. use monoidfun_paths. use idpath. Defined. Opaque gr_assoc. Lemma is_precategory_gr_precategory_data : is_precategory gr_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use gr_id_left. - intros a b f. use gr_id_right. - intros a b c d f g h. use gr_assoc. Qed. Definition gr_precategory : precategory := make_precategory gr_precategory_data is_precategory_gr_precategory_data. Lemma has_homsets_gr_precategory : has_homsets gr_precategory. Proof. intros X Y. use isasetmonoidfun. Qed. End def_gr_precategory. (** * Category of grs *) Section def_gr_category. Definition gr_category : category := make_category _ has_homsets_gr_precategory. (** ** (monoidiso X Y) ≃ (iso X Y) *) Lemma gr_iso_is_equiv (A B : ob gr_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1monoidfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropismonoidfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropismonoidfun. Defined. Opaque gr_iso_is_equiv. Lemma gr_iso_equiv (X Y : ob gr_category) : z_iso X Y -> monoidiso (X : gr) (Y : gr). Proof. intro f. use make_monoidiso. - exact (make_weq (pr1 (pr1 f)) (gr_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma gr_equiv_is_iso (X Y : ob gr_category) (f : monoidiso (X : gr) (Y : gr)) : @is_z_isomorphism gr_precategory X Y (monoidfunconstr (pr2 f)). Proof. exists (monoidfunconstr (pr2 (invmonoidiso f))). use make_is_inverse_in_precat. - use monoidfun_paths. use funextfun. intros x. use homotinvweqweq. - use monoidfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque gr_equiv_is_iso. Lemma gr_equiv_iso (X Y : ob gr_category) : monoidiso (X : gr) (Y : gr) -> z_iso X Y. Proof. intros f. exact (_,,gr_equiv_is_iso X Y f). Defined. Lemma gr_iso_equiv_is_equiv (X Y : gr_category) : isweq (gr_iso_equiv X Y). Proof. use isweq_iso. - exact (gr_equiv_iso X Y). - intros x. use z_iso_eq. use monoidfun_paths. use idpath. - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Defined. Opaque gr_iso_equiv_is_equiv. Definition gr_iso_equiv_weq (X Y : ob gr_category) : weq (z_iso X Y) (monoidiso (X : gr) (Y : gr)). Proof. use make_weq. - exact (gr_iso_equiv X Y). - exact (gr_iso_equiv_is_equiv X Y). Defined. Lemma gr_equiv_iso_is_equiv (X Y : ob gr_category) : isweq (gr_equiv_iso X Y). Proof. use isweq_iso. - exact (gr_iso_equiv X Y). - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. apply z_iso_eq. use monoidfun_paths. use idpath. Defined. Opaque gr_equiv_iso_is_equiv. Definition gr_equiv_weq_iso (X Y : ob gr_category) : (monoidiso (X : gr) (Y : gr)) ≃ (z_iso X Y). Proof. use make_weq. - exact (gr_equiv_iso X Y). - exact (gr_equiv_iso_is_equiv X Y). Defined. (** ** Category of grs *) Definition gr_precategory_isweq (X Y : ob gr_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (gr_univalence X Y) (gr_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (gr_univalence X Y) (gr_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque gr_precategory_isweq. Definition gr_category_is_univalent : is_univalent gr_category. Proof. intros X Y. exact (gr_precategory_isweq X Y). Defined. Definition gr_univalent_category : univalent_category := make_univalent_category gr_category gr_category_is_univalent. End def_gr_category. UniMath-20231010/UniMath/CategoryTheory/categories/intdoms.v000066400000000000000000000137551451125700300236300ustar00rootroot00000000000000(** * Category of intdoms *) (** ** Contents - Precategory of intdoms - Category of intdoms *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of intdoms *) Section def_intdom_precategory. Definition intdom_fun_space (A B : intdom) : hSet := make_hSet (ringfun A B) (isasetrigfun A B). Definition intdom_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) intdom (λ A B : intdom, intdom_fun_space A B). Definition intdom_precategory_data : precategory_data := make_precategory_data intdom_precategory_ob_mor (λ (X : intdom), (rigisotorigfun (idrigiso X))) (fun (X Y Z : intdom) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g). Local Lemma intdom_id_left (X Y : intdom) (f : ringfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque intdom_id_left. Local Lemma intdom_id_right (X Y : intdom) (f : ringfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque intdom_id_right. Local Lemma intdom_assoc (X Y Z W : intdom) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. apply idpath. Defined. Opaque intdom_assoc. Lemma is_precategory_intdom_precategory_data : is_precategory intdom_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use intdom_id_left. - intros a b f. use intdom_id_right. - intros a b c d f g h. use intdom_assoc. Qed. Definition intdom_precategory : precategory := make_precategory intdom_precategory_data is_precategory_intdom_precategory_data. Lemma has_homsets_intdom_precategory : has_homsets intdom_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_intdom_precategory. (** * Category of intdoms *) Section def_intdom_category. Definition intdom_category : category := make_category _ has_homsets_intdom_precategory. (** ** (rigiso X Y) ≃ (iso X Y) *) Lemma intdom_iso_is_equiv (A B : ob intdom_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque intdom_iso_is_equiv. Lemma intdom_iso_equiv (X Y : ob intdom_category) : z_iso X Y -> ringiso (X : intdom) (Y : intdom). Proof. intro f. use make_ringiso. - exact (make_weq (pr1 (pr1 f)) (intdom_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma intdom_equiv_is_z_iso (X Y : ob intdom_category) (f : ringiso (X : intdom) (Y : intdom)) : @is_z_isomorphism intdom_precategory X Y (ringfunconstr (pr2 f)). Proof. exists (ringfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque intdom_equiv_is_z_iso. Lemma intdom_equiv_iso (X Y : ob intdom_category) : ringiso (X : intdom) (Y : intdom) -> z_iso X Y. Proof. intros f. exact (_,,intdom_equiv_is_z_iso X Y f). Defined. Lemma intdom_iso_equiv_is_equiv (X Y : intdom_category) : isweq (intdom_iso_equiv X Y). Proof. use isweq_iso. - exact (intdom_equiv_iso X Y). - intros x. apply z_iso_eq. use rigfun_paths. apply idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. Defined. Opaque intdom_iso_equiv_is_equiv. Definition intdom_iso_equiv_weq (X Y : ob intdom_category) : weq (z_iso X Y) (ringiso (X : intdom) (Y : intdom)). Proof. use make_weq. - exact (intdom_iso_equiv X Y). - exact (intdom_iso_equiv_is_equiv X Y). Defined. Lemma intdom_equiv_iso_is_equiv (X Y : ob intdom_category) : isweq (intdom_equiv_iso X Y). Proof. use isweq_iso. - exact (intdom_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. - intros x. use z_iso_eq. use rigfun_paths. apply idpath. Defined. Opaque intdom_equiv_iso_is_equiv. Definition intdom_equiv_weq_iso (X Y : ob intdom_precategory) : (ringiso (X : intdom) (Y : intdom)) ≃ (z_iso X Y). Proof. use make_weq. - exact (intdom_equiv_iso X Y). - exact (intdom_equiv_iso_is_equiv X Y). Defined. (** ** Category of intdoms *) Definition intdom_category_isweq (X Y : ob intdom_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (intdom_univalence X Y) (intdom_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (intdom_univalence X Y) (intdom_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - apply idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque intdom_category_isweq. Definition intdom_category_is_univalent : is_univalent intdom_category. Proof. intros X Y. exact (intdom_category_isweq X Y). Defined. Definition intdom_univalent_category : univalent_category := make_univalent_category intdom_category intdom_category_is_univalent. End def_intdom_category. UniMath-20231010/UniMath/CategoryTheory/categories/modules.v000066400000000000000000000175151451125700300236210ustar00rootroot00000000000000(** Authors: - Anthony Bordg, March-April 2017 - Langston Barrett (@siddharthist), November-December 2017 *) Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.Algebra.Modules. Require Import UniMath.Algebra.Modules.Examples. Require Import UniMath.CategoryTheory.limits.zero. (** * Contents: - The category of (left) R-modules ([mod_category]) - Mod is a univalent category ([is_univalent_mod]) - Abelian structure - Zero object and zero arrow - Preadditive structure - Additive structure *) Section Mod. Local Open Scope cat. Context {R : ring}. (** * The category of (left) R-modules ([mod_category]) *) Definition mod_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor (module R) (λ M N, modulefun M N). Definition mod_precategory_data : precategory_data := make_precategory_data mod_precategory_ob_mor (λ (M : module R), (idfun M,, id_modulefun M)) (fun M N P => @modulefun_comp R M N P). Lemma is_precategory_mod_precategory_data : is_precategory (mod_precategory_data). Proof. apply is_precategory_one_assoc_to_two. apply make_dirprod. - apply make_dirprod. + intros M N f. use total2_paths_f. * apply funextfun. intro x. apply idpath. * apply isapropismodulefun. + intros M N f. use total2_paths_f. * apply funextfun. intro x. apply idpath. * apply isapropismodulefun. - intros M N P Q f g h. use total2_paths_f. + apply funextfun. intro x. unfold compose. cbn. apply idpath. + apply isapropismodulefun. Defined. Definition mod_precategory : precategory := make_precategory (mod_precategory_data) (is_precategory_mod_precategory_data). Definition has_homsets_mod : has_homsets mod_precategory := isasetmodulefun. Definition mod_category : category := make_category mod_precategory has_homsets_mod. Definition mor_to_modulefun {M N : ob mod_category} : mod_category⟦M, N⟧ -> modulefun M N := idfun _. (** Mod is a univalent category ([Mod_is_univalent]) *) Definition modules_univalence_weq (M N : mod_category) : (M ╝ N) ≃ (moduleiso' M N). Proof. use weqbandf. - apply abgr_univalence. - intro e. use invweq. induction M. induction N. cbn in e. induction e. use weqimplimpl. + intro i. use total2_paths2_f. * use funextfun. intro r. use total2_paths2_f. apply funextfun. intro x. exact (i r x). apply isapropismonoidfun. * apply isapropisrigfun. + intro i. cbn. intros r x. unfold idmonoidiso. cbn in i. induction i. apply idpath. + apply isapropislinear. + apply isasetrigfun. Defined. Definition modules_univalence_map (M N : mod_category) : (M = N) -> (moduleiso M N). Proof. intro p. induction p. exact (idmoduleiso M). Defined. Definition modules_univalence_map_isweq (M N : mod_category) : isweq (modules_univalence_map M N). Proof. use isweqhomot. - exact (weqcomp (weqcomp (total2_paths_equiv _ M N) (modules_univalence_weq M N)) (moduleiso'_to_moduleweq_iso M N)). - intro p. induction p. apply (pathscomp0 weqcomp_to_funcomp_app). apply idpath. - apply weqproperty. Defined. Definition modules_univalence (M N : mod_category) : (M = N) ≃ (moduleiso M N). Proof. use make_weq. - exact (modules_univalence_map M N). - exact (modules_univalence_map_isweq M N). Defined. (** Equivalence between isomorphisms and moduleiso in Mod R *) Lemma moduleisweq_z_iso {M N : ob mod_category} (f : z_iso M N) : isweq (pr1modulefun (morphism_from_z_iso _ _ f)). Proof. use (isweq_iso (pr1modulefun (morphism_from_z_iso _ _ f))). - exact (pr1modulefun (inv_from_z_iso f)). - intro; set (T:= z_iso_inv_after_z_iso f). apply subtypeInjectivity in T. + apply (toforallpaths _ _ _ T). + intro; apply isapropismodulefun. - intro; set (T:= z_iso_after_z_iso_inv f). apply subtypeInjectivity in T. + apply (toforallpaths _ _ _ T). + intro; apply isapropismodulefun. Defined. Lemma z_iso_moduleiso (M N : ob mod_category) : z_iso M N -> moduleiso M N. Proof. intro f. use make_moduleiso. - use make_weq. + exact (pr1modulefun (morphism_from_z_iso _ _ f)). + exact (moduleisweq_z_iso f). - exact (modulefun_ismodulefun (morphism_from_z_iso _ _ f)). Defined. Lemma moduleiso_is_z_iso {M N : ob mod_category} (f : moduleiso M N) : @is_z_isomorphism _ M N (moduleiso_to_modulefun f). Proof. exists (make_modulefun (invmoduleiso f) (pr2 (invmoduleiso f))). split; use total2_paths_f. + apply funextfun. intro. apply homotinvweqweq. + apply isapropismodulefun. + apply funextfun. intro. apply homotweqinvweq. + apply isapropismodulefun. Defined. Lemma moduleiso_z_iso (M N : ob mod_category) : moduleiso M N -> z_iso M N. Proof. intro f. use make_z_iso'. - exact (moduleiso_to_modulefun f). - exact (moduleiso_is_z_iso f). Defined. Lemma moduleiso_isweq_z_iso (M N : ob mod_category) : isweq (@moduleiso_z_iso M N). Proof. apply (isweq_iso _ (z_iso_moduleiso M N)). - intro. apply subtypePath. + intro; apply isapropismodulefun. + unfold moduleiso_z_iso, z_iso_moduleiso. use total2_paths_f. * apply idpath. * apply isapropisweq. - intro; unfold z_iso_moduleiso, moduleiso_z_iso. use total2_paths_f. + apply idpath. + apply isaprop_is_z_isomorphism. Defined. Definition moduleiso_weq_z_iso (M N : mod_category) : (moduleiso M N) ≃ (z_iso M N) := make_weq (moduleiso_z_iso M N) (moduleiso_isweq_z_iso M N). Definition mod_category_idtoisweq_z_iso : ∏ M N : mod_category, isweq (fun p : M = N => idtoiso p). Proof. intros M N. use (isweqhomot (weqcomp (modules_univalence M N) (moduleiso_weq_z_iso M N)) _). - intro p. induction p. use (pathscomp0 weqcomp_to_funcomp_app). cbn. use total2_paths_f. + apply idpath. + apply (isaprop_is_z_isomorphism (identity M)). - apply weqproperty. Defined. Definition is_univalent_mod : is_univalent mod_category. Proof. intros ? ? . apply mod_category_idtoisweq_z_iso. Defined. Definition univalent_category_mod_precategory : univalent_category := make_univalent_category mod_category is_univalent_mod. (** * Abelian structure *) (** ** Zero object and zero arrow - The zero object (0) is the zero abelian group, considered as a module. - The type (hSet) Hom(0, M) is contractible, the center is the zero map. - The type (hSet) Hom(M, 0) is contractible, the center is the zero map. *) (** ** Zero in abelian category *) (** The set of maps 0 -> M is contractible, it only contains the zero morphism. *) Lemma iscontrfromzero_module (M : mod_category) : iscontr (mod_category⟦zero_module R, M⟧). Proof. refine (unelmodulefun _ _,, _). intros f; apply modulefun_paths. apply funextfun; intro x. unfold unelmodulefun; cbn. refine (!maponpaths (fun z => (pr1 f) z) (isProofIrrelevantUnit (@unel (zero_module R)) _ ) @ _). apply (monoidfununel (modulefun_to_monoidfun f)). Defined. (** The set of maps M -> 0 is contractible, it only contains the zero morphism. *) Lemma iscontrtozero_module (M : mod_category) : iscontr (mod_category⟦M, zero_module R⟧). Proof. refine (unelmodulefun _ _,, _). intros f; apply modulefun_paths. apply funextfun. exact (fun x => isProofIrrelevantUnit _ _). Defined. Lemma isZero_zero_module : @isZero mod_category (zero_module R). Proof. exact (@make_isZero mod_category (zero_module _) iscontrfromzero_module iscontrtozero_module). Defined. Definition mod_category_Zero : Zero mod_category := @make_Zero mod_category (zero_module _) isZero_zero_module. (** ** Preadditive structure *) (** ** Additive structure *) End Mod. UniMath-20231010/UniMath/CategoryTheory/categories/monoids.v000066400000000000000000000236401451125700300236150ustar00rootroot00000000000000(** * Category of monoids *) (** ** Contents - Precategory of monoids - Category of monoids - Forgetful functor to [HSET] - Free functor from [HSET] - Free/forgetful adjunction *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Free_Monoids_and_Groups. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.Algebra.IteratedBinaryOperations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** ** Precategory of monoids *) Section def_monoid_precategory. Definition monoid_fun_space (A B : monoid) : hSet := make_hSet (monoidfun A B) (isasetmonoidfun A B). Definition monoid_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) monoid (λ A B : monoid, monoid_fun_space A B). Definition monoid_precategory_data : precategory_data := make_precategory_data monoid_precategory_ob_mor (λ (X : monoid), ((idmonoidiso X) : monoidfun X X)) (fun (X Y Z : monoid) (f : monoidfun X Y) (g : monoidfun Y Z) => monoidfuncomp f g). Local Lemma monoid_id_left {X Y : monoid} (f : monoidfun X Y) : monoidfuncomp (idmonoidiso X) f = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque monoid_id_left. Local Lemma monoid_id_right {X Y : monoid} (f : monoidfun X Y) : monoidfuncomp f (idmonoidiso Y) = f. Proof. use monoidfun_paths. use idpath. Defined. Opaque monoid_id_right. Local Lemma monoid_assoc (X Y Z W : monoid) (f : monoidfun X Y) (g : monoidfun Y Z) (h : monoidfun Z W) : monoidfuncomp f (monoidfuncomp g h) = monoidfuncomp (monoidfuncomp f g) h. Proof. use monoidfun_paths. use idpath. Defined. Opaque monoid_assoc. Lemma is_precategory_monoid_precategory_data : is_precategory monoid_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use monoid_id_left. - intros a b f. use monoid_id_right. - intros a b c d f g h. use monoid_assoc. Qed. Definition monoid_precategory : precategory := make_precategory monoid_precategory_data is_precategory_monoid_precategory_data. Lemma has_homsets_monoid_precategory : has_homsets monoid_precategory. Proof. intros X Y. use isasetmonoidfun. Qed. End def_monoid_precategory. (** ** Category of monoids *) Section def_monoid_category. Definition monoid_category : category := make_category _ has_homsets_monoid_precategory. (** ** (monoidiso X Y) ≃ (z_iso X Y) *) Lemma monoid_z_iso_is_equiv (A B : ob monoid_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1monoidfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropismonoidfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropismonoidfun. Defined. Opaque monoid_z_iso_is_equiv. Lemma monoid_z_iso_equiv (X Y : ob monoid_category) : z_iso X Y -> monoidiso X Y. Proof. intro f. use make_monoidiso. - exact (make_weq (pr1 (pr1 f)) (monoid_z_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma monoid_equiv_is_z_iso (X Y : ob monoid_category) (f : monoidiso X Y) : @is_z_isomorphism monoid_precategory X Y (monoidfunconstr (pr2 f)). Proof. exists (monoidfunconstr (pr2 (invmonoidiso f))). split. - use monoidfun_paths. use funextfun. intros x. use homotinvweqweq. - use monoidfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque monoid_equiv_is_z_iso. Lemma monoid_equiv_z_iso (X Y : ob monoid_category) : monoidiso X Y -> z_iso X Y. Proof. intros f. exact (_,,monoid_equiv_is_z_iso X Y f). Defined. Lemma monoid_z_iso_equiv_is_equiv (X Y : monoid_category) : isweq (monoid_z_iso_equiv X Y). Proof. use isweq_iso. - exact (monoid_equiv_z_iso X Y). - intros x. use z_iso_eq. use monoidfun_paths. use idpath. - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Defined. Opaque monoid_z_iso_equiv_is_equiv. Definition monoid_z_iso_equiv_weq (X Y : ob monoid_category) : (z_iso X Y) ≃ (monoidiso X Y). Proof. use make_weq. - exact (monoid_z_iso_equiv X Y). - exact (monoid_z_iso_equiv_is_equiv X Y). Defined. Lemma monoid_equiv_z_iso_is_equiv (X Y : ob monoid_category) : isweq (monoid_equiv_z_iso X Y). Proof. use isweq_iso. - exact (monoid_z_iso_equiv X Y). - intros y. use monoidiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. use z_iso_eq. use monoidfun_paths. use idpath. Defined. Opaque monoid_equiv_z_iso_is_equiv. Definition monoid_equiv_weq_z_iso (X Y : ob monoid_precategory) : (monoidiso X Y) ≃ (z_iso X Y). Proof. use make_weq. - exact (monoid_equiv_z_iso X Y). - exact (monoid_equiv_z_iso_is_equiv X Y). Defined. (** ** Category of monoids *) Definition monoid_category_isweq (X Y : ob monoid_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (monoid_univalence X Y) (monoid_equiv_weq_z_iso X Y))) _ _ (weqproperty (weqcomp (monoid_univalence X Y) (monoid_equiv_weq_z_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque monoid_category_isweq. Definition monoid_category_is_univalent : is_univalent monoid_category. Proof. intros X Y. exact (monoid_category_isweq X Y). Defined. Definition monoid_univalent_category : univalent_category := make_univalent_category monoid_category monoid_category_is_univalent. End def_monoid_category. (** ** Forgetful functor to [HSET] *) Definition monoid_forgetful_functor : functor monoid_precategory HSET. Proof. use make_functor. - use make_functor_data. + intro; exact (pr1setwithbinop (pr1monoid ltac:(assumption))). + intros ? ? f; exact (pr1monoidfun _ _ f). - split. + (** Identity axiom *) intro; reflexivity. + (** Composition axiom *) intros ? ? ? ? ?; reflexivity. Defined. Lemma monoid_forgetful_functor_is_faithful : faithful monoid_forgetful_functor. Proof. unfold faithful. intros ? ?. apply isinclpr1. apply isapropismonoidfun. Defined. (** ** Free functor from [HSET] *) Definition monoid_free_functor : functor HSET monoid_precategory. Proof. use make_functor. - use make_functor_data. + intros s; exact (free_monoid s). + intros ? ? f; exact (free_monoidfun f). - split. + (** Identity axiom *) intro. abstract (apply monoidfun_paths, funextfun; intro; apply map_idfun). + (** Composition axiom *) intros ? ? ? ? ?. abstract (apply monoidfun_paths, funextfun, (free_monoidfun_comp_homot f g)). Defined. (** ** Free/forgetful adjunction *) Local Definition singleton {A : UU} (x : A) := cons x Lists.nil. (** The unit of this adjunction is the singleton function [x ↦ x::nil] *) Definition monoid_free_forgetful_unit : nat_trans (functor_identity _) (functor_composite monoid_free_functor monoid_forgetful_functor). Proof. use make_nat_trans. - intro; exact singleton. - intros ? ? ?. abstract (apply funextfun; intro; reflexivity). Defined. (** This amounts to naturality of the counit: mapping commutes with folding *) Lemma iterop_list_mon_map {m n : monoid} (f : monoidfun m n) : ∏ l, ((iterop_list_mon ∘ map (pr1monoidfun m n f)) l = (pr1monoidfun _ _ f ∘ iterop_list_mon) l)%functions. Proof. apply list_ind. - apply pathsinv0, monoidfununel. - intros x xs H. simpl in *. refine (maponpaths iterop_list_mon (map_cons _ _ _) @ _). refine (iterop_list_mon_step _ _ @ _). refine (_ @ !maponpaths _ (iterop_list_mon_step _ _)). refine (_ @ !binopfunisbinopfun f _ _). apply maponpaths. assumption. Qed. (** The counit of this adjunction is the "folding" function [[a, b, …, z] ↦ a · b · ⋯ · z] (This is known to Haskell programmers as [mconcat].) *) Definition monoid_free_forgetful_counit : nat_trans (functor_composite monoid_forgetful_functor monoid_free_functor ) (functor_identity _). Proof. use make_nat_trans. - intro. use tpair. + intro; apply iterop_list_mon; assumption. + split. * intros ? ?; apply iterop_list_mon_concatenate. * reflexivity. - intros ? ? f; apply monoidfun_paths. apply funextfun; intro; simpl in *. apply (iterop_list_mon_map f). Defined. Definition monoid_free_forgetful_adjunction_data : adjunction_data HSET monoid_category . Proof. use tpair; [|use tpair]. (* TODO: there should be a constructor for this *) - exact monoid_free_functor. - exact monoid_forgetful_functor. - split. + exact monoid_free_forgetful_unit. + exact monoid_free_forgetful_counit. Defined. Lemma monoid_free_forgetful_adjunction : form_adjunction' monoid_free_forgetful_adjunction_data. Proof. split; intro. - apply monoidfun_paths. apply funextfun. simpl. unfold homot; apply list_ind; [reflexivity|]. intros x xs ?. simpl. rewrite map_cons. (* For some reason, the unifier needs a lot of help here... *) refine (iterop_list_mon_step (_ : pr1hSet (free_monoid _)) _ @ _). apply maponpaths; assumption. - reflexivity. Qed. UniMath-20231010/UniMath/CategoryTheory/categories/preorder_categories.v000066400000000000000000000055601451125700300261750ustar00rootroot00000000000000(** Category generated by a preorder *) Require Import UniMath.Foundations.HLevels. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section po_category_def. Context {X : UU}. (** Precategory over a preorder *) Definition po_precategory_ob_mor (PO : po X) : precategory_ob_mor := make_precategory_ob_mor X (carrierofpo X PO). Definition po_precategory_data (PO : po X) : precategory_data := make_precategory_data (po_precategory_ob_mor PO) (pr2 (pr2 PO)) (pr1 (pr2 PO)). Lemma po_homsets_isaprop (PO : po X) (a b : (po_precategory_data PO)) : isaprop (po_precategory_data PO ⟦a,b⟧). Proof. apply propproperty. Defined. Definition po_precategory_data_is_precategory (PO : po X) : is_precategory (po_precategory_data PO). Proof. use make_is_precategory; intros; apply po_homsets_isaprop. Defined. Definition po_precategory (PO : po X) : precategory. Proof. use make_precategory. - exact (po_precategory_data PO). - exact (po_precategory_data_is_precategory PO). Defined. (** Category over preorder *) Definition po_precategory_has_homsets (PO : po X) : has_homsets (po_precategory_ob_mor PO). Proof. intros ? ?. apply hlevelntosn. apply po_homsets_isaprop. Defined. Definition po_category (PO : po X) : category := make_category (po_precategory PO) (po_precategory_has_homsets PO). (** If the preorder is antisymmetric and X is a set, the category is univalent *) Context (xisaset : isaset X). Lemma antisymm_po_category_isoiseq (PO : po X) {A B : (po_category PO)} (poasymm : isantisymm PO) (isoAB : z_iso A B) : A = B. Proof. apply poasymm. apply (z_iso_mor isoAB). apply (inv_from_z_iso isoAB). Defined. Lemma antisymm_po_category_isweq (PO : po X) {A B : po_category PO} (poasymm : isantisymm PO) : isweq (λ p : A = B, idtoiso p). Proof. use isweq_iso. - apply (antisymm_po_category_isoiseq PO poasymm). - intro eq. apply proofirrelevance. apply xisaset. - intro iso. use z_iso_eq. apply proofirrelevance. apply propproperty. Defined. Theorem po_category_is_univalent_iff_is_antisymm (PO : po X) : is_univalent (po_category PO) <-> isantisymm PO. Proof. split. - intros isuni a b relab relba. apply (isotoid _ isuni). exists relab. exists relba. apply make_is_inverse_in_precat; apply po_homsets_isaprop. - intro poasymm. intros ? ?. apply (antisymm_po_category_isweq PO poasymm). Defined. Definition antisymm_po_univalent_category (PO : po X) (poasymm : isantisymm PO) : univalent_category. use make_univalent_category. - exact (po_category PO). - apply po_category_is_univalent_iff_is_antisymm. exact poasymm. Defined. End po_category_def. UniMath-20231010/UniMath/CategoryTheory/categories/rigs.v000066400000000000000000000133151451125700300231070ustar00rootroot00000000000000(** * Rigs category *) (** ** Contents - Precategory of rigs - Category of rigs *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of rigs *) Section def_rig_precategory. Definition rig_fun_space (A B : rig) : hSet := make_hSet (rigfun A B) (isasetrigfun A B). Definition rig_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) rig (λ A B : rig, rig_fun_space A B). Definition rig_precategory_data : precategory_data := make_precategory_data rig_precategory_ob_mor (λ (X : rig), (rigisotorigfun (idrigiso X))) (fun (X Y Z : rig) (f : rigfun X Y) (g : rigfun Y Z) => rigfuncomp f g). Local Definition rig_id_left (X Y : rig) (f : rigfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. use idpath. Defined. Opaque rig_id_left. Local Definition rig_id_right (X Y : rig) (f : rigfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. use idpath. Defined. Opaque rig_id_right. Local Definition rig_assoc (X Y Z W : rig) (f : rigfun X Y) (g : rigfun Y Z) (h : rigfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. use idpath. Defined. Opaque rig_assoc. Lemma is_precategory_rig_precategory_data : is_precategory rig_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use rig_id_left. - intros a b f. use rig_id_right. - intros a b c d f g h. use rig_assoc. Qed. Definition rig_precategory : precategory := make_precategory rig_precategory_data is_precategory_rig_precategory_data. Lemma has_homsets_rig_precategory : has_homsets rig_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_rig_precategory. (** * Category of rigs *) Section def_rig_category. Definition rig_category : category := make_category _ has_homsets_rig_precategory. (** ** (rigiso X Y) ≃ (iso X Y) *) Lemma rig_iso_is_equiv (A B : ob rig_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque rig_iso_is_equiv. Lemma rig_iso_equiv (X Y : ob rig_category) : z_iso X Y -> rigiso (X : rig) (Y : rig). Proof. intro f. use make_rigiso. - exact (make_weq (pr1 (pr1 f)) (rig_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma rig_equiv_is_z_iso (X Y : ob rig_category) (f : rigiso (X : rig) (Y : rig)) : @is_z_isomorphism rig_precategory X Y (rigfunconstr (pr2 f)). Proof. exists (rigfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque rig_equiv_is_z_iso. Lemma rig_equiv_z_iso (X Y : ob rig_category) : rigiso (X : rig) (Y : rig) -> z_iso X Y. Proof. intros f. exists (rigfunconstr (pr2 f)). exact (rig_equiv_is_z_iso X Y f). Defined. Lemma rig_iso_equiv_is_equiv (X Y : rig_category) : isweq (rig_iso_equiv X Y). Proof. use isweq_iso. - exact (rig_equiv_z_iso X Y). - intros x. use z_iso_eq. use rigfun_paths. use idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Defined. Opaque rig_iso_equiv_is_equiv. Definition rig_iso_equiv_weq (X Y : ob rig_category) : weq (z_iso X Y) (rigiso (X : rig) (Y : rig)). Proof. use make_weq. - exact (rig_iso_equiv X Y). - exact (rig_iso_equiv_is_equiv X Y). Defined. Lemma rig_equiv_iso_is_equiv (X Y : ob rig_category) : isweq (rig_equiv_z_iso X Y). Proof. use isweq_iso. - exact (rig_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. use z_iso_eq. use rigfun_paths. use idpath. Defined. Opaque rig_equiv_iso_is_equiv. Definition rig_equiv_weq_iso (X Y : ob rig_category) : (rigiso (X : rig) (Y : rig)) ≃ (z_iso X Y). Proof. use make_weq. - exact (rig_equiv_z_iso X Y). - exact (rig_equiv_iso_is_equiv X Y). Defined. (** ** Category of rigs *) Definition rig_category_isweq (X Y : ob rig_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (rig_univalence X Y) (rig_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (rig_univalence X Y) (rig_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque rig_category_isweq. Definition rig_category_is_univalent : is_univalent rig_category. Proof. intros X Y. exact (rig_category_isweq X Y). Defined. Definition rig_univalent_category : univalent_category := make_univalent_category rig_category rig_category_is_univalent. End def_rig_category. UniMath-20231010/UniMath/CategoryTheory/categories/rings.v000066400000000000000000000133531451125700300232670ustar00rootroot00000000000000(** * Rings category *) (** ** Contents - Precategory of rings - Category of rings *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of rings *) Section def_ring_precategory. Definition ring_fun_space (A B : ring) : hSet := make_hSet (ringfun A B) (isasetrigfun A B). Definition ring_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) ring (λ A B : ring, ring_fun_space A B). Definition ring_precategory_data : precategory_data := make_precategory_data ring_precategory_ob_mor (λ (X : ring), (rigisotorigfun (idrigiso X))) (fun (X Y Z : ring) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g). Local Lemma ring_id_left (X Y : ring) (f : ringfun X Y) : rigfuncomp (rigisotorigfun (idrigiso X)) f = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque ring_id_left. Local Lemma ring_id_right (X Y : ring) (f : ringfun X Y) : rigfuncomp f (rigisotorigfun (idrigiso Y)) = f. Proof. use rigfun_paths. apply idpath. Defined. Opaque ring_id_right. Local Lemma ring_assoc (X Y Z W : ring) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) : rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h. Proof. use rigfun_paths. apply idpath. Defined. Opaque ring_assoc. Lemma is_precategory_ring_precategory_data : is_precategory ring_precategory_data. Proof. use make_is_precategory_one_assoc. - intros a b f. use ring_id_left. - intros a b f. use ring_id_right. - intros a b c d f g h. use ring_assoc. Qed. Definition ring_precategory : precategory := make_precategory ring_precategory_data is_precategory_ring_precategory_data. Lemma has_homsets_ring_precategory : has_homsets ring_precategory. Proof. intros X Y. use isasetrigfun. Qed. End def_ring_precategory. (** * Category of rings *) Section def_ring_category. Definition ring_category : category := make_category _ has_homsets_ring_precategory. (** ** (ringiso X Y) ≃ (z_iso X Y) *) Lemma ring_iso_is_equiv (A B : ob ring_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1rigfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropisrigfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropisrigfun. Defined. Opaque ring_iso_is_equiv. Lemma ring_iso_equiv (X Y : ob ring_category) : z_iso X Y -> ringiso (X : ring) (Y : ring). Proof. intro f. use make_ringiso. - exact (make_weq (pr1 (pr1 f)) (ring_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma ring_equiv_is_z_iso (X Y : ob ring_category) (f : ringiso (X : ring) (Y : ring)) : @is_z_isomorphism ring_category X Y (ringfunconstr (pr2 f)). Proof. exists (ringfunconstr (pr2 (invrigiso f))). use make_is_inverse_in_precat. - use rigfun_paths. use funextfun. intros x. use homotinvweqweq. - use rigfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque ring_equiv_is_z_iso. Lemma ring_equiv_iso (X Y : ob ring_category) : ringiso (X : ring) (Y : ring) -> z_iso X Y. Proof. intros f. exact (_,,ring_equiv_is_z_iso X Y f). Defined. Lemma ring_iso_equiv_is_equiv (X Y : ring_category) : isweq (ring_iso_equiv X Y). Proof. use isweq_iso. - exact (ring_equiv_iso X Y). - intros x. use z_iso_eq. use rigfun_paths. apply idpath. - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. Defined. Opaque ring_iso_equiv_is_equiv. Definition ring_iso_equiv_weq (X Y : ob ring_category) : weq (z_iso X Y) (ringiso (X : ring) (Y : ring)). Proof. use make_weq. - exact (ring_iso_equiv X Y). - exact (ring_iso_equiv_is_equiv X Y). Defined. Lemma ring_equiv_iso_is_equiv (X Y : ob ring_category) : isweq (ring_equiv_iso X Y). Proof. use isweq_iso. - exact (ring_iso_equiv X Y). - intros y. use rigiso_paths. use subtypePath. + intros x0. use isapropisweq. + apply idpath. - intros x. use z_iso_eq. use rigfun_paths. apply idpath. Defined. Opaque ring_equiv_iso_is_equiv. Definition ring_equiv_weq_iso (X Y : ob ring_category) : (ringiso (X : ring) (Y : ring)) ≃ (z_iso X Y). Proof. use make_weq. - exact (ring_equiv_iso X Y). - exact (ring_equiv_iso_is_equiv X Y). Defined. (** ** Category of rings *) Definition ring_category_isweq (X Y : ob ring_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (ring_univalence X Y) (ring_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (ring_univalence X Y) (ring_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - apply idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque ring_category_isweq. Definition ring_category_is_univalent : is_univalent ring_category. Proof. intros X Y. exact (ring_category_isweq X Y). Defined. Definition ring_univalent_category : univalent_category := make_univalent_category ring_category ring_category_is_univalent. End def_ring_category. UniMath-20231010/UniMath/CategoryTheory/categories/setwith2binops.v000066400000000000000000000152011451125700300251230ustar00rootroot00000000000000(** * Category of setswith2binops *) (** ** Contents - setwith2binops precategory - setwith2binops category *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. (** * Precategory of setwith2binops *) Section def_setwith2binop_precategory. Definition setwith2binop_fun_space (A B : setwith2binop) : hSet := make_hSet (twobinopfun A B) (isasettwobinopfun A B). Definition setwith2binop_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) setwith2binop (λ A B : setwith2binop, setwith2binop_fun_space A B). Definition setwith2binop_precategory_data : precategory_data := make_precategory_data setwith2binop_precategory_ob_mor (λ (X : setwith2binop), ((idtwobinopiso X) : twobinopfun X X)) (fun (X Y Z : setwith2binop) (f : twobinopfun X Y) (g : twobinopfun Y Z) => twobinopfuncomp f g). Local Lemma setwith2binop_id_left (X Y : setwith2binop) (f : twobinopfun X Y) : twobinopfuncomp (idtwobinopiso X) f = f. Proof. use twobinopfun_paths. use idpath. Defined. Opaque setwith2binop_id_left. Local Lemma setwith2binop_id_right (X Y : setwith2binop) (f : twobinopfun X Y) : twobinopfuncomp f (idtwobinopiso Y) = f. Proof. use twobinopfun_paths. use idpath. Defined. Opaque setwith2binop_id_right. Local Lemma setwith2binop_assoc (X Y Z W : setwith2binop) (f : twobinopfun X Y) (g : twobinopfun Y Z) (h : twobinopfun Z W) : twobinopfuncomp f (twobinopfuncomp g h) = twobinopfuncomp (twobinopfuncomp f g) h. Proof. use twobinopfun_paths. use idpath. Defined. Opaque setwith2binop_assoc. Lemma is_precategory_setwith2binop_precategory_data : is_precategory setwith2binop_precategory_data. Proof. use make_is_precategory. - intros a b f. use setwith2binop_id_left. - intros a b f. use setwith2binop_id_right. - intros a b c d f g h. use setwith2binop_assoc. - intros a b c d f g h. apply pathsinv0, setwith2binop_assoc. Defined. Definition setwith2binop_precategory : precategory := make_precategory setwith2binop_precategory_data is_precategory_setwith2binop_precategory_data. Lemma has_homsets_setwith2binop_precategory : has_homsets setwith2binop_precategory. Proof. intros X Y. use isasettwobinopfun. Qed. End def_setwith2binop_precategory. (** * Category of setwith2binops *) Section def_setwith2binop_category. Definition setwith2binop_category : category := make_category _ has_homsets_setwith2binop_precategory. (** ** (twobinopiso X Y) ≃ (iso X Y) *) Lemma setwith2binop_iso_is_equiv (A B : ob setwith2binop_category) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. use isweq_iso. - exact (pr1twobinopfun _ _ (inv_from_z_iso f)). - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x). intros x0. use isapropistwobinopfun. - intros x. use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x). intros x0. use isapropistwobinopfun. Defined. Opaque setwith2binop_iso_is_equiv. Lemma setwith2binop_iso_equiv (X Y : ob setwith2binop_category) : z_iso X Y -> twobinopiso X Y. Proof. intro f. use make_twobinopiso. - exact (make_weq (pr1 (pr1 f)) (setwith2binop_iso_is_equiv X Y f)). - exact (pr2 (pr1 f)). Defined. Lemma setwith2binop_equiv_is_z_iso (X Y : ob setwith2binop_category) (f : twobinopiso X Y) : @is_z_isomorphism setwith2binop_precategory X Y (make_twobinopfun (pr1 (pr1 f)) (pr2 f)). Proof. exists (make_twobinopfun (pr1 (pr1 (invtwobinopiso f))) (pr2 (invtwobinopiso f))). split. - use twobinopfun_paths. use funextfun. intros x. use homotinvweqweq. - use twobinopfun_paths. use funextfun. intros y. use homotweqinvweq. Defined. Opaque setwith2binop_equiv_is_z_iso. Lemma setwith2binop_equiv_iso (X Y : ob setwith2binop_category) : twobinopiso X Y -> z_iso X Y. Proof. intros f. exact (_,,setwith2binop_equiv_is_z_iso X Y f). Defined. Lemma setwith2binop_iso_equiv_is_equiv (X Y : setwith2binop_category) : isweq (setwith2binop_iso_equiv X Y). Proof. use isweq_iso. - exact (setwith2binop_equiv_iso X Y). - intros x. use z_iso_eq. use twobinopfun_paths. use idpath. - intros y. use twobinopiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. Defined. Opaque setwith2binop_iso_equiv_is_equiv. Definition setwith2binop_iso_equiv_weq (X Y : ob setwith2binop_category) : (z_iso X Y) ≃ (twobinopiso X Y). Proof. use make_weq. - exact (setwith2binop_iso_equiv X Y). - exact (setwith2binop_iso_equiv_is_equiv X Y). Defined. Lemma setwith2binop_equiv_iso_is_equiv (X Y : ob setwith2binop_category) : isweq (setwith2binop_equiv_iso X Y). Proof. use isweq_iso. - exact (setwith2binop_iso_equiv X Y). - intros y. use twobinopiso_paths. use subtypePath. + intros x0. use isapropisweq. + use idpath. - intros x. use z_iso_eq. use twobinopfun_paths. use idpath. Defined. Opaque setwith2binop_equiv_iso_is_equiv. Definition setwith2binop_equiv_weq_iso (X Y : ob setwith2binop_category) : (twobinopiso X Y) ≃ (z_iso X Y). Proof. use make_weq. - exact (setwith2binop_equiv_iso X Y). - exact (setwith2binop_equiv_iso_is_equiv X Y). Defined. (** ** Category of setwith2binops *) Definition setwith2binop_category_isweq (X Y : ob setwith2binop_category) : isweq (λ p : X = Y, idtoiso p). Proof. use (@isweqhomot (X = Y) (z_iso X Y) (pr1weq (weqcomp (setwith2binop_univalence X Y) (setwith2binop_equiv_weq_iso X Y))) _ _ (weqproperty (weqcomp (setwith2binop_univalence X Y) (setwith2binop_equiv_weq_iso X Y)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque setwith2binop_category_isweq. Definition setwith2binop_category_is_univalent : is_univalent setwith2binop_category. Proof. intros X Y. exact (setwith2binop_category_isweq X Y). Defined. Definition setwith2binop_univalent_category : univalent_category := make_univalent_category setwith2binop_category setwith2binop_category_is_univalent. End def_setwith2binop_category. UniMath-20231010/UniMath/CategoryTheory/categories/wosets.v000066400000000000000000000162721451125700300234740ustar00rootroot00000000000000(** This file defines two category structures on well-ordered sets: 1. This first where the morphisms are maps that preserve the ordering and initial segments ([wosetfuncat]). 2. The second with arbitrary set theoretic functions as morphisms ([WOSET]). Both of these have initial ([Initial_wosetfuncat], [Initial_WOSET]) and terminal objects ([Terminal_wosetfuncat], [Terminal_WOSET]). The former doesn't seem to have binary products (see discussion below), but using Zermelo's well-ordering theorem (and hence the axiom of choice) I have proved that the latter merely has binary products ([hasBinProducts_WOSET]). I believe that the proofs that WOSET has all limits and colimits carry over exactly like the proof for binary products, but because the category only merely has binary products I ran into all kinds of problems when trying to prove that it merely has exponentials, see discussion at the end of the file. Written by: Anders Mörtberg (Feb 2018) *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.OrderedSets. Require Import UniMath.Combinatorics.WellOrderedSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.exponentials. Local Open Scope cat. Local Open Scope woset. Local Open Scope functions. (** * The category of well-ordered sets with order preserving morphisms *) Section wosetfuncat. Definition wosetfun_precategory : precategory. Proof. use make_precategory. - exists (WellOrderedSet,,wofun). split; simpl. + intros X. apply (_,,iswofun_idfun). + intros X Y Z f g. apply (_,,iswofun_funcomp f g). - abstract (now repeat split; simpl; intros; apply wofun_eq). Defined. Lemma has_homsets_wosetfun_precategory : has_homsets wosetfun_precategory. Proof. intros X Y. apply (isasetsubset (pr1wofun X Y)). - apply isaset_set_fun_space. - apply isinclpr1; intro f. apply isaprop_iswofun. Qed. Definition wosetfuncat : category := (wosetfun_precategory,,has_homsets_wosetfun_precategory). (** TODO: remove this assumption by proving it *) Definition wo_setcategory (isaset_WellOrderedSet : isaset WellOrderedSet) : setcategory. Proof. exists wosetfun_precategory. split. - apply isaset_WellOrderedSet. - apply has_homsets_wosetfun_precategory. Defined. Lemma Initial_wosetfuncat : Initial wosetfuncat. Proof. use make_Initial. - exact empty_woset. - apply make_isInitial; intro a; simpl. use tpair. + exists fromempty. abstract (now split; intros []). + abstract (now intros f; apply wofun_eq, funextfun; intros []). Defined. Lemma Terminal_wosetfuncat : Terminal wosetfuncat. Proof. use make_Terminal. + exact unit_woset. + apply make_isTerminal; intro a. use tpair. - exists (λ _, tt). abstract (split; [intros x y H|intros x [] []]; apply (WO_isrefl unit_woset)). - abstract (now intros f; apply wofun_eq, funextfun; intros x; induction (pr1 f x)). Defined. (** Can we prove any further properties of wosetcat? It doesn't seem like it has binary products, at least the lexicographic ordering does not work. Consider {0,1} × {2,3}, in it we have (0,3) < (1,2) but pr2 doesn't preserve the ordering. (Thanks Dan for pointing this out to me!) *) End wosetfuncat. (** * The category of well-ordered sets with arbitrary functions as morphisms *) Section WOSET. (** TODO: prove the following missing result *) Variable isaset_WellOrderedSet : isaset WellOrderedSet. Definition WOSET_precategory : precategory. Proof. use make_precategory. - use tpair. + exists ((WellOrderedSet,,isaset_WellOrderedSet) : hSet). apply (λ X Y, pr11 X → pr11 Y). + split; simpl. * intros X; apply idfun. * intros X Y Z f g; apply (g ∘ f). - abstract (now intros). Defined. Lemma has_homsets_WOSET : has_homsets WOSET_precategory. Proof. red ; intros ; apply isaset_set_fun_space. Qed. Definition WOSET : category := (WOSET_precategory,,has_homsets_WOSET). Definition WOSET_setcategory : setcategory. Proof. exists WOSET. split. - apply setproperty. - apply has_homsets_WOSET. Defined. Lemma Initial_WOSET : Initial WOSET. Proof. use make_Initial. - exact empty_woset. - apply make_isInitial; intro a. use tpair. + simpl; intro e; induction e. + abstract (intro f; apply funextfun; intro e; induction e). Defined. Lemma Terminal_WOSET : Terminal WOSET. Proof. use make_Terminal. - exact unit_woset. - apply make_isTerminal; intro a. exists (λ _, tt). abstract (simpl; intro f; apply funextfun; intro x; case (f x); apply idpath). Defined. (** Direct proof that woset has binary products using Zermelo's well-ordering theorem. We could prove this using the lexicograpic ordering, but it seems like we need decidable equality for this to work which would not work very well when we construct exponentials. *) Lemma hasBinProducts_WOSET (AC : AxiomOfChoice) : hasBinProducts WOSET. Proof. intros A B. set (AB := BinProductObject _ (BinProductsHSET (pr1 A) (pr1 B)) : hSet). apply (squash_to_hProp (@ZermeloWellOrdering AB AC)); intros R. apply hinhpr. use make_BinProduct. - exists AB. exact R. - apply (BinProductPr1 _ (BinProductsHSET _ _)). - apply (BinProductPr2 _ (BinProductsHSET _ _)). - intros H. apply (isBinProduct_BinProduct _ (BinProductsHSET _ _) (pr1 H)). Defined. (** Using the axiom of choice we can push the quantifiers into the truncation. Hopefully this will help with using this definition below for defining exponentials. However it might run into problems with AC not computing. *) Definition squash_BinProducts_WOSET (AC : AxiomOfChoice) : ∥ BinProducts WOSET ∥. Proof. use AC; intros A; use AC; intros B. apply (hasBinProducts_WOSET AC). Defined. (** Below follows an attempt to prove that this category has exponentials *) (* I first define a weaker formulation of when a category has exponentials. This only requires the binary products to merely exists. We could reformulate this condition in various ways, for instance by defining when the product with an element a : C merely exists or unfolding the definitions to state the property explicitly. I'm not sure which is the best. *) (* Definition hasExponentials (C : precategory) : UU := *) (* ∏ (a : C), ∃ (H : BinProducts C), is_exponentiable H a. *) (* I have run into some serious problems when trying to define the functor X ↦ X^A *) (* Definition exponential_functor_WOSET (AC : AxiomOfChoice) (A : WOSET) : ∥ functor WOSET WOSET ∥. *) (* Proof. *) (* The idea is to well-order the function space using Zermelo's well-ordering theorem, but I can't figure out how to write down the definition. It essentially boils down to some truncation juggling and various issues with AC not computing and hence getting in the way. *) (* Once I have figured out how to write the above definition I should be able to prove *) (* Lemma hasExponentials_WOSET (AC : AxiomOfChoice) : hasExponentials WOSET. *) (* Admitted. *) End WOSET. UniMath-20231010/UniMath/CategoryTheory/category_binops.v000066400000000000000000000161431451125700300232070ustar00rootroot00000000000000(* The category of sets with binary operations. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.Core.Functors. Section BINOPS_precategory. Definition binops_fun_space (A B : setwithbinop) : hSet := make_hSet _ (isasetbinopfun A B). Definition binops_precategory_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) setwithbinop (λ A B : setwithbinop, binops_fun_space A B). Definition idbinopfun (A : setwithbinop) : binopfun A A. Proof. use make_binopfun. intros a. exact a. intros a a'. apply idpath. Defined. Definition idbinopfun_remove_left (A B : setwithbinop) (f : binopfun A B) : binopfuncomp (idbinopfun A) f = f. Proof. unfold binopfuncomp. unfold idbinopfun. use total2_paths_f. cbn. apply idpath. apply proofirrelevance. apply isapropisbinopfun. Defined. Definition idbinopfun_remove_right (A B : setwithbinop) (f : binopfun A B) : binopfuncomp f (idbinopfun B) = f. Proof. unfold binopfuncomp. unfold idbinopfun. use total2_paths_f. cbn. apply idpath. apply proofirrelevance. apply isapropisbinopfun. Defined. Definition binopfuncomp_assoc (A B C D : setwithbinop) (f : binopfun A B) (g : binopfun B C) (h : binopfun C D) : binopfuncomp (binopfuncomp f g) h = binopfuncomp f (binopfuncomp g h). Proof. unfold binopfuncomp. apply maponpaths. apply isapropisbinopfun. Defined. Definition binop_precategory_data : precategory_data := make_precategory_data binops_precategory_ob_mor (λ (A : setwithbinop), idbinopfun A ) (fun (A B C : setwithbinop) (f : binopfun A B) (g : binopfun B C) => binopfuncomp f g). Lemma is_precategory_binop_precategory_data : is_precategory binop_precategory_data. Proof. repeat split; cbn. intros a b f. apply idbinopfun_remove_left. intros a b f. apply idbinopfun_remove_right. intros a b c d f g h. apply pathsinv0. apply (binopfuncomp_assoc a b c d f g h). intros a b c d f g h. apply (binopfuncomp_assoc a b c d f g h). Defined. Definition binop_precategory : precategory := tpair _ _ is_precategory_binop_precategory_data. Lemma has_homsets_BINOP : has_homsets binop_precategory. Proof. intros a b; apply isasetbinopfun. Qed. End BINOPS_precategory. Section BINOP_category. Definition binop_category : category := make_category _ has_homsets_BINOP. Notation BINOP := binop_category. (** ** Equivalence between isomorphisms and binopisos *) Lemma binop_iso_is_equiv (A B : ob BINOP) (f : z_iso A B) : isweq (pr1 (pr1 f)). Proof. apply (isweq_iso _ (pr1binopfun _ _ (inv_from_z_iso f))). - intro x. set (T:=z_iso_inv_after_z_iso f). apply subtypeInjectivity in T. set (T':=toforallpaths _ _ _ T). apply T'. intro x0. apply isapropisbinopfun. - intros y. set (T:=z_iso_after_z_iso_inv f). apply subtypeInjectivity in T. set (T':=toforallpaths _ _ _ T). apply T'. intros x0. apply isapropisbinopfun. Defined. Lemma binop_iso_equiv (A B : ob BINOP) : z_iso A B -> binopiso A B. Proof. intro f. use make_binopiso. set (X := binop_iso_is_equiv A B f). apply (make_weq (pr1 (pr1 f)) X). apply (pr2 (pr1 f)). Defined. Lemma binop_equiv_is_z_iso (A B : setwithbinop) (f : binopiso A B) : @is_z_isomorphism BINOP A B (make_binopfun (pr1 (pr1 f)) (pr2 f)). Proof. exists (make_binopfun (pr1 (pr1 (invbinopiso f))) (pr2 (invbinopiso f))). split; cbn. - unfold compose, identity. cbn. unfold binopfuncomp, idbinopfun. cbn. use total2_paths_f. cbn. apply funextfun. intros x. apply homotinvweqweq. cbn. apply impred_isaprop. intros t. apply impred_isaprop. intros t0. apply (pr2 (pr1 A)). - use total2_paths_f. cbn. apply funextfun. intros x. apply homotweqinvweq. cbn. apply impred_isaprop. intros yt. apply impred_isaprop. intros t0. apply (pr2 (pr1 B)). Defined. Lemma binop_equiv_iso (A B : BINOP) : binopiso A B -> z_iso A B. Proof. intro f. cbn in *. set (T := binop_equiv_is_z_iso A B f). exact (_,,T). Defined. Lemma binop_iso_equiv_is_equiv (A B : BINOP) : isweq (binop_iso_equiv A B). Proof. apply (isweq_iso _ (binop_equiv_iso A B)). - intro; apply z_iso_eq. apply maponpaths. unfold binop_equiv_iso, binop_iso_equiv. cbn. use total2_paths_f. + cbn. unfold make_binopfun. apply subtypePath. * intros y. apply isapropisbinopfun. * apply maponpaths. apply subtypePath. -- unfold isPredicate. intros x0. apply isapropisbinopfun. -- apply idpath. + apply proofirrelevance. apply (isaprop_is_z_isomorphism(C:=BINOP)). - intros y. unfold binop_iso_equiv, binop_equiv_iso. cbn. use total2_paths_f. + cbn. unfold make_binopfun. apply subtypePath. * intros x. apply isapropisweq. * apply idpath. + apply proofirrelevance. apply isapropisbinopfun. Defined. Definition binop_iso_equiv_weq (A B : BINOP) : (z_iso A B) ≃ (binopiso A B). Proof. exists (binop_iso_equiv A B). apply binop_iso_equiv_is_equiv. Defined. Lemma binop_equiv_iso_is_equiv (A B : BINOP) : isweq (binop_equiv_iso A B). Proof. apply (isweq_iso _ (binop_iso_equiv A B)). intros x. apply subtypePath. intros y. apply isapropisbinopfun. unfold binop_equiv_iso, binop_iso_equiv. cbn. use total2_paths_f. cbn. apply idpath. apply isapropisweq. intros y. unfold binop_equiv_iso, binop_iso_equiv. cbn. use total2_paths_f. cbn. unfold make_binopfun. cbn. apply subtypePath. intros x. apply isapropisbinopfun. apply idpath. apply proofirrelevance. apply (isaprop_is_z_isomorphism(C:=BINOP)). Qed. Definition binop_equiv_weq_iso (A B : BINOP) : (binopiso A B) ≃ (z_iso A B). Proof. exists (binop_equiv_iso A B). apply binop_equiv_iso_is_equiv. Defined. Definition binop_precategory_isweq (a b : BINOP) : isweq (λ p : a = b, idtoiso p). Proof. use (@isweqhomot (a = b) (z_iso a b) (pr1weq (weqcomp (setwithbinop_univalence a b) (binop_equiv_weq_iso a b))) _ _ (weqproperty (weqcomp (setwithbinop_univalence a b) (binop_equiv_weq_iso a b)))). intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). use total2_paths_f. - use idpath. - use proofirrelevance. use isaprop_is_z_isomorphism. Defined. Opaque binop_precategory_isweq. Definition binop_precategory_is_univalent : is_univalent binop_category. Proof. intros a b. exact (binop_precategory_isweq a b). Defined. End BINOP_category. UniMath-20231010/UniMath/CategoryTheory/catiso.v000066400000000000000000000423471451125700300213070ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful. (******************************************************************************) (** * Isomorphism of (pre)categories *) (* (as defined in the paper) *) Definition is_catiso {A B : precategory_data} (F : functor A B) := (fully_faithful F) × (isweq (functor_on_objects F)). Definition catiso (A B : precategory_data) := total2 (λ F : functor A B, is_catiso F). Lemma isaprop_is_catiso {A B : precategory_data} {F : functor A B} : isaprop (is_catiso F). Proof. apply isapropdirprod. - apply isaprop_fully_faithful. - apply isapropisweq. Defined. Definition functor_from_catiso (A B : precategory_data) (F : catiso A B) : functor A B := pr1 F. Coercion functor_from_catiso : catiso >-> functor. Definition identity_catiso (A : precategory_data) : catiso A A. Proof. use tpair. - exact (functor_identity A). - use tpair. + apply identity_functor_is_fully_faithful. + apply idisweq. Defined. Definition catiso_ob_weq {A B : precategory_data} (F : catiso A B) : (ob A) ≃ (ob B) := make_weq (functor_on_objects F) (pr2 (pr2 F)). Definition catiso_to_precategory_ob_path {A B : precategory_data} (F : catiso A B) : ob A = ob B := (invmap (univalence _ _) (catiso_ob_weq F)). Definition catiso_fully_faithful_weq {A B : precategory_data} (F : catiso A B) : forall a a' : A, (a --> a') ≃ (F a --> F a') := λ a a', (make_weq (functor_on_morphisms F) (pr1 (pr2 F) a a')). Lemma catiso_fully_faithful_path {A B : precategory_data} (F : catiso A B) : forall a a' : A, (a --> a') = (F a --> F a'). Proof. intros a a'. apply (invmap (univalence _ _)). apply (catiso_fully_faithful_weq F). Defined. (******************************************************************************) (** * Construction of a map (catiso A B) -> (A = B) *) (* The path "p : ob A = ob B" is clear. The next task is to construct a path "A a a' = (transportb p B) a a'" for all a, a' : A. We transport backwards because the fully faithfulness of the functor applies more naturally this way *) (* Let "w (= eqweqmap) : (X = Y) -> (X -> Y)" be the canonical map *) (* The path "A a a' = (transportb p B) a a'" is constructed in three pieces. *) (* a --> a *) (* = F a --> F a' *) (* = w(p) a --> w(p) a' *) (* = (transportb p B) a a' *) Lemma correct_hom {A B : precategory_data} (F : catiso A B) : forall a a' : A, F a --> F a' = (eqweqmap (catiso_to_precategory_ob_path F) a) --> (eqweqmap (catiso_to_precategory_ob_path F) a'). Proof. intros a a'. assert (W := (!(homotweqinvweq (univalence _ _)) (catiso_ob_weq F))). exact (maponpaths (λ T, (pr1weq T) a --> (pr1weq T) a') W ). Defined. (* w(p) a = F a *) Lemma eqweq_ob_path_is_functor_app {A B : precategory_data} (F : catiso A B) : forall a : A, eqweqmap (catiso_to_precategory_ob_path F) a = F a. Proof. intros a. exact (! toforallpaths (λ _ : A, B) F (pr1 (eqweqmap (invmap (univalence A B) (catiso_ob_weq F)))) (maponpaths pr1 (! homotweqinvweq (univalence A B) (catiso_ob_weq F))) a). Defined. Lemma eqweq_ob_path_is_functor_app_compute (A B : precategory) (F : catiso A B) (a a' : A) (f : B ⟦ F a, F a' ⟧): eqweq_ob_path_is_functor_app F a = ! toforallpaths (λ _ : A, B) F (pr1weq (eqweqmap (invmap (univalence A B) (catiso_ob_weq F)))) (maponpaths pr1weq (! homotweqinvweq (univalence A B) (catiso_ob_weq F))) a. Proof. unfold eqweq_ob_path_is_functor_app. Abort. Lemma eqweq_maponpaths_mor {A B : precategory} (F G : A ≃ B) (p : F = G) (a a' : A) (f : F a --> F a') : eqweqmap (maponpaths (λ T : A ≃ B, (pr1 T) a --> (pr1 T) a') p) f = (idtomor _ _ (!toforallpaths _ _ _ (maponpaths pr1 p) a)) · f · (idtomor _ _ (toforallpaths _ _ _ (maponpaths pr1 p) a')). Proof. induction p. rewrite id_left. rewrite id_right. reflexivity. Defined. Lemma eqweq_correct_hom_is_comp {A B : precategory} (F : catiso A B) : forall a a' : A, forall f : F a --> F a', eqweqmap (correct_hom F _ _) f = (idtomor _ _ (eqweq_ob_path_is_functor_app F a)) · f · (idtomor _ _ (!eqweq_ob_path_is_functor_app F a')). Proof. intros a a' f. rewrite (eqweq_maponpaths_mor _ _ (! homotweqinvweq (univalence A B) (catiso_ob_weq F)) a a'). apply maponpaths. apply maponpaths. unfold eqweq_ob_path_is_functor_app. rewrite pathsinv0inv0. reflexivity. Defined. Lemma eqweq_fully_faithful_is_functor_app {A B : precategory_data} (F : catiso A B) : forall a a' : A, eqweqmap (catiso_fully_faithful_path F a a') = catiso_fully_faithful_weq F _ _. Proof. intros a a'. unfold catiso_fully_faithful_path. assert (W := (@homotweqinvweq _ _ (univalence (a --> a') (F a --> F a')))). simpl in W. rewrite W. reflexivity. Defined. Lemma transport_mor {A B : UU} (B1 : B -> B -> UU) (p : A = B) : forall a a' : A, B1 (eqweqmap p a) (eqweqmap p a') = (transportb (λ T, T -> T -> UU) p B1) a a'. Proof. induction p. reflexivity. Defined. Lemma catiso_to_precategory_mor_path {A B : precategory_data} (F : catiso A B) : forall a a', (precategory_morphisms (C:=A)) a a' = transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F) (precategory_morphisms (C:=B)) a a'. Proof. intros a. intros a'. eapply pathscomp0. apply (catiso_fully_faithful_path F). eapply pathscomp0. apply correct_hom. eapply pathscomp0. apply transport_mor. reflexivity. Defined. Lemma catiso_to_precategory_mor_path_funext {A B : precategory_data} (F : catiso A B) : (precategory_morphisms (C:=A)) = transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F) (precategory_morphisms (C:=B)). Proof. apply (pr1 (weqfunextsec _ _ _)). intros a. apply (pr1 (weqfunextsec _ _ _)). intros a'. apply (catiso_to_precategory_mor_path F). Defined. Definition catiso_to_precategory_ob_mor_path {A B : precategory_data} (F : catiso A B) : precategory_ob_mor_from_precategory_data A = precategory_ob_mor_from_precategory_data B := total2_paths_b (catiso_to_precategory_ob_path F) (catiso_to_precategory_mor_path_funext F). (* Remains to show that identity and composition transport correctly. *) Lemma transport_id {A0 B0 : UU} (p0 : A0 = B0) (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb _ p0 B1) (idB : forall b : B0, B1 b b) : forall a : A0, (transportb (X := total2 (λ T, T -> T -> UU)) (λ T, forall a, (pr2 T) a a) (total2_paths2_b p0 p1) idB) a = (eqweqmap ( (transport_mor B1 p0 _ _) @ !weqtoforallpaths _ _ _ (weqtoforallpaths _ _ _ p1 a) a)) (idB (eqweqmap p0 a)). Proof. intro. induction p0. change (transportb _ _ _) with B1 in p1. induction p1. simpl. reflexivity. Defined. Lemma correct_hom_on_id {A B : precategory} (F : catiso A B) : forall a, identity ((eqweqmap (catiso_to_precategory_ob_path F)) a) = (eqweqmap (correct_hom F a a)) (identity (F a)). Proof. intros a. apply pathsinv0. eapply pathscomp0. apply eqweq_correct_hom_is_comp. induction (eqweq_ob_path_is_functor_app F a). simpl. rewrite 2 id_right. reflexivity. Defined. Lemma catiso_to_precategory_id_path {A B : precategory} (F : catiso A B) : forall a : A, (transportb (X := total2 (λ T, T -> T -> UU)) (λ T, forall a, (pr2 T) a a) (total2_paths2_b (catiso_to_precategory_ob_path F) (catiso_to_precategory_mor_path_funext F)) identity) a = identity a. Proof. intros a. eapply pathscomp0. apply transport_id. (* Cancel funext *) unfold catiso_to_precategory_mor_path_funext. unfold catiso_to_precategory_mor_path. unfold weqfunextsec. simpl (pr1 _). rewrite !(homotweqinvweq (weqtoforallpaths _ _ _)). (* Cancel transport_mor with its inverse *) rewrite pathscomp_inv. rewrite pathscomp_inv. rewrite path_assoc. rewrite path_assoc. rewrite pathscomp0rid. rewrite pathsinv0r. simpl. (* Get into a form we can apply correct_hom_on_id *) apply pathsweq1'. rewrite <- pathscomp_inv. rewrite eqweqmap_pathsinv0. rewrite invinv. rewrite <- eqweqmap_pathscomp0. rewrite (eqweq_fully_faithful_is_functor_app F a a). simpl. rewrite functor_id. apply correct_hom_on_id. Defined. (* We want to prove a similar lemma to transport_mor. The following is the type on the RHS of the path. *) Lemma transport_comp_target {A0 B0 : UU} (p0 : A0 = B0) (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb (λ T, T -> T -> UU) p0 B1) : forall a a' a'' : A0, ( B1 (eqweqmap p0 a) (eqweqmap p0 a') -> B1 (eqweqmap p0 a') (eqweqmap p0 a'') -> B1 (eqweqmap p0 a) (eqweqmap p0 a'')) -> ( A1 a a' -> A1 a' a'' -> A1 a a''). Proof. intros a a' a''. intros Bhom. intros f g. set (X := λ a a', (transport_mor B1 p0 a a') @ (! weqtoforallpaths _ _ _ (weqtoforallpaths _ _ _ p1 a) a') ). apply (eqweqmap (X a a'')). apply Bhom. apply (eqweqmap (! X a a')). exact f. apply (eqweqmap (! X a' a'')). exact g. Defined. Lemma transport_comp {A0 B0 : UU} (p0 : A0 = B0) (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb _ p0 B1) (compB : forall b b' b'' : B0, B1 b b' -> B1 b' b'' -> B1 b b'') : forall a a' a'' : A0, (transportb (X := total2 (λ T, T -> T -> UU)) (λ T, forall a b c, (pr2 T) a b -> (pr2 T) b c -> (pr2 T) a c) (total2_paths2_b p0 p1) compB) a a' a'' = transport_comp_target p0 A1 B1 p1 a a' a'' (compB (eqweqmap p0 a) (eqweqmap p0 a') (eqweqmap p0 a'')). Proof. intros. induction p0. change (A1 = B1) in p1. induction p1. reflexivity. Defined. Lemma correct_hom_on_comp {A B : precategory} (F : catiso A B) : forall a a' a'', forall f : F a --> F a', forall g : F a' --> F a'', (eqweqmap (correct_hom F _ _)) f · (eqweqmap (correct_hom F _ _)) g = (eqweqmap (correct_hom F _ _)) (f · g). Proof. intros a a' a'' f g. rewrite !eqweq_correct_hom_is_comp. induction (eqweq_ob_path_is_functor_app F a). induction (eqweq_ob_path_is_functor_app F a'). induction (eqweq_ob_path_is_functor_app F a''). rewrite 3 id_left. simpl. rewrite 3 id_right. reflexivity. Defined. Lemma catiso_to_precategory_comp_path {A B : precategory} (F : catiso A B) : forall a a' a'' : A, (transportb (X := total2 (λ T, T -> T -> UU)) (λ T, forall a b c : (pr1 T), (pr2 T) a b -> (pr2 T) b c -> (pr2 T) a c) (total2_paths2_b (catiso_to_precategory_ob_path F) (catiso_to_precategory_mor_path_funext F)) (@compose B)) a a' a'' = (@compose A a a' a''). Proof. intros a a' a''. eapply pathscomp0. apply transport_comp. apply funextsec. intros f. apply funextsec. intros g. unfold transport_comp_target. (* Cancel funext *) unfold catiso_to_precategory_mor_path_funext. simpl. set (W := homotweqinvweq (weqtoforallpaths (λ _ : A, A -> UU) precategory_morphisms (transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F) precategory_morphisms))). simpl in W. rewrite !W. clear W. set (W := homotweqinvweq (weqtoforallpaths (λ _ : A, UU) (precategory_morphisms a) (transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F) precategory_morphisms a))). simpl in W. rewrite !W. clear W. set (W := homotweqinvweq (weqtoforallpaths (λ _ : A, UU) (precategory_morphisms a') (transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F) precategory_morphisms a'))). simpl in W. rewrite !W. clear W. (* Cancel as much as possible *) unfold catiso_to_precategory_mor_path. rewrite !pathscomp0rid. rewrite !pathscomp_inv. rewrite !pathsinv0inv0. rewrite path_assoc. rewrite path_assoc. rewrite pathsinv0r. simpl. rewrite <- path_assoc. rewrite <- path_assoc. rewrite pathsinv0r. rewrite pathscomp0rid. rewrite <- path_assoc. rewrite <- path_assoc. rewrite pathsinv0r. rewrite pathscomp0rid. rewrite <- pathscomp_inv. (* Rearrange to get into a form to apply correct_hom_on_comp *) apply pathsweq1'. rewrite eqweqmap_pathsinv0. rewrite invinv. rewrite <- !eqweqmap_pathscomp0. rewrite !eqweq_fully_faithful_is_functor_app. simpl. rewrite functor_comp. apply (correct_hom_on_comp F). Defined. Lemma catiso_to_precategory_data_path {A B : precategory} (F : catiso A B) : precategory_data_from_precategory A = precategory_data_from_precategory B. Proof. destruct A as [[[Ao Am] [Ai Ac]] Aax]. destruct B as [[[Bo Bm] [Bi Bc]] Bax]. eapply total2_paths_b. Unshelve. 2: { simpl. exact (catiso_to_precategory_ob_mor_path F). } apply pathsinv0. eapply pathscomp0. apply (transportb_dirprod _ _ _ _ _ (catiso_to_precategory_ob_mor_path F)). apply dirprodeq. - apply funextsec. intros a. apply (catiso_to_precategory_id_path F). - apply funextsec. intro. apply funextsec. intro. apply funextsec. intro. apply (catiso_to_precategory_comp_path F). Defined. (** If either precategory has homsets, then an isomorphism between them becomes a path. This is essentially one half of univalence for categories. *) Lemma catiso_to_precategory_path_f {A B : precategory} (hs : has_homsets A) (F : catiso A B) : A = B. Proof. use total2_paths_b. - exact (catiso_to_precategory_data_path F). - apply proofirrelevance, isaprop_is_precategory. apply hs. Defined. Lemma catiso_to_precategory_path_b {A B : precategory} (hs : has_homsets B) (F : catiso A B) : A = B. Proof. use total2_paths_f. - exact (catiso_to_precategory_data_path F). - apply proofirrelevance, isaprop_is_precategory. apply hs. Defined. (** A special case is that they both have homsets *) Corollary catiso_to_category_path {A B : category} (F : catiso A B) : A = B. Proof. apply category_eq. apply catiso_to_precategory_data_path. assumption. Defined. Definition inv_catiso {C D : category} (F : catiso C D) : D ⟶ C. Proof. use make_functor. - use tpair. + exact (invweq (catiso_ob_weq F)). + intros X Y f ; cbn. refine (invmap (catiso_fully_faithful_weq F (invmap (catiso_ob_weq F) X) (invmap (catiso_ob_weq F) Y)) _). exact ((idtoiso (homotweqinvweq (catiso_ob_weq F) X)) · f · idtoiso (!(homotweqinvweq (catiso_ob_weq F) Y))). - split. + intro X ; cbn. rewrite id_right. etrans. { apply maponpaths. exact (!(maponpaths pr1 (idtoiso_concat D _ _ _ (homotweqinvweq (catiso_ob_weq F) X) (! homotweqinvweq (catiso_ob_weq F) X)))). } rewrite pathsinv0r ; cbn. apply invmap_eq ; cbn. rewrite functor_id. reflexivity. + intros X Y Z f g ; cbn. apply invmap_eq ; cbn. rewrite functor_comp. pose (homotweqinvweq (catiso_fully_faithful_weq F (invmap (catiso_ob_weq F) X) (invmap (catiso_ob_weq F) Y))) as p. cbn in p. rewrite p ; clear p. pose (homotweqinvweq (catiso_fully_faithful_weq F (invmap (catiso_ob_weq F) Y) (invmap (catiso_ob_weq F) Z))) as p. cbn in p. rewrite p ; clear p. rewrite <- !assoc. repeat (apply (maponpaths (λ z, _ · (f · z)))). refine (!(id_left _) @ _). rewrite !assoc. repeat (apply (maponpaths (λ z, z · _))). rewrite idtoiso_inv. cbn. rewrite z_iso_after_z_iso_inv. reflexivity. Defined. (* Any adjoint equivalence between univalent categories is an isomorphism of categories *) Definition adj_equivalence_of_cats_to_cat_iso {C D : category} {F : functor C D} (Fa : adj_equivalence_of_cats F) (Cuniv : is_univalent C) (Duniv : is_univalent D) : catiso C D. Proof. exists F. split. - apply fully_faithful_from_equivalence, Fa. - apply(weq_on_objects_from_adj_equiv_of_cats C D Cuniv Duniv F Fa). Defined. UniMath-20231010/UniMath/CategoryTheory/coslicecat.v000066400000000000000000000103421451125700300221240ustar00rootroot00000000000000(** * Coslice categories Author: Langston Barrett (@siddharthist), March 2018 *) (** ** Contents: - Definition of coslice categories, x/C *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. (* Require Import UniMath.Foundations.Propositions. *) (* Require Import UniMath.Foundations.Sets. *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. (** for second construction: *) Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Local Open Scope cat. (** * Definition of coslice categories *) (** Given a category C and x : obj C. The coslice category x/C is given by: - obj x/C: pairs (a,f) where f : x --> a - morphisms (a,f) --> (b,g): morphism h : a --> b with << x | \ | \ f | \ g v \ a --> b h >> where f · h = g *) Section coslice_cat_def. Context (C : category) (x : C). (** Accessor functions *) Definition coslicecat_ob := ∑ a, C⟦x,a⟧. Definition coslicecat_mor (f g : coslicecat_ob) := ∑ h, pr2 f · h = pr2 g. Definition coslicecat_ob_object (f : coslicecat_ob) : ob C := pr1 f. Definition coslicecat_ob_morphism (f : coslicecat_ob) : C⟦x, coslicecat_ob_object f⟧ := pr2 f. Definition coslicecat_mor_morphism {f g : coslicecat_ob} (h : coslicecat_mor f g) : C⟦coslicecat_ob_object f, coslicecat_ob_object g⟧ := pr1 h. Definition coslicecat_mor_comm {f g : coslicecat_ob} (h : coslicecat_mor f g) : (coslicecat_ob_morphism f) · (coslicecat_mor_morphism h) = (coslicecat_ob_morphism g) := pr2 h. (** Definitions *) Definition coslice_precat_ob_mor : precategory_ob_mor := (coslicecat_ob,,coslicecat_mor). Definition id_coslice_precat (c : coslice_precat_ob_mor) : c --> c := tpair _ _ (id_right (pr2 c)). Definition comp_coslice_precat {a b c : coslice_precat_ob_mor} (f : a --> b) (g : b --> c) : a --> c. Proof. use tpair. - exact (coslicecat_mor_morphism f · coslicecat_mor_morphism g). - abstract (refine (assoc _ _ _ @ _); refine (maponpaths (λ f, f · _) (coslicecat_mor_comm f) @ _); refine (coslicecat_mor_comm g)). Defined. Definition coslice_precat_data : precategory_data := make_precategory_data _ id_coslice_precat (@comp_coslice_precat). Lemma is_precategory_coslice_precat_data : is_precategory coslice_precat_data. Proof. use make_is_precategory; intros; unfold comp_coslice_precat; cbn; apply subtypePairEquality. * intro; apply C. * apply id_left. * intro; apply C. * apply id_right. * intro; apply C. * apply assoc. * intro; apply C. * apply assoc'. Defined. (** that the previous Lemma is defined was done on purpose in 2018 - is it still appropriate? *) Definition coslice_precat : precategory := (_,,is_precategory_coslice_precat_data). Lemma has_homsets_coslice_precat : has_homsets (coslice_precat). Proof. intros a b. induction a as [a f]; induction b as [b g]; simpl. apply (isofhleveltotal2 2); [ apply C | intro h]. apply isasetaprop; apply C. Qed. Definition coslice_cat : category := make_category _ has_homsets_coslice_precat. End coslice_cat_def. Section coslice_cat_displayed. Context (C : category) (x : C). Definition coslice_cat_disp_ob_mor : disp_cat_ob_mor C. Proof. use make_disp_cat_ob_mor. - intro a. exact (x --> a). - intros a b f g h. exact (f · h = g). Defined. Lemma coslice_cat_disp_id_comp : disp_cat_id_comp C coslice_cat_disp_ob_mor. Proof. split. - intros a f. apply id_right. - intros a1 a2 a3 h h' f1 f2 f3 Hyph Hyph'. etrans. { apply assoc. } etrans. { apply cancel_postcomposition, Hyph. } exact Hyph'. Qed. Definition coslice_cat_disp_data : disp_cat_data C := coslice_cat_disp_ob_mor ,, coslice_cat_disp_id_comp. Lemma coslice_cat_disp_locally_prop : locally_propositional coslice_cat_disp_data. Proof. intro; intros; apply C. Qed. Definition coslice_cat_disp : disp_cat C. Proof. use make_disp_cat_locally_prop. - exact coslice_cat_disp_data. - exact coslice_cat_disp_locally_prop. Defined. Definition coslice_cat_total : category := total_category coslice_cat_disp. End coslice_cat_displayed. UniMath-20231010/UniMath/CategoryTheory/covyoneda.v000066400000000000000000000313451451125700300220100ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Anders Mörtberg (adapted from yoneda.v) 2016 ************************************************************) (** ********************************************************** Contents : Definition of the covariant Yoneda functor [covyoneda(C) : [C^op, [C, HSET]]] ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Export UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Export UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Ltac unf := unfold identity, compose, precategory_morphisms; simpl. (** The following lemma is already in precategories.v . It should be transparent? *) (* Lemma iso_comp_left_isweq {C:precategory} {a b:ob C} (h:iso a b) (c:C) : *) (* isweq (λ f : hom _ c a, f · h). *) (* Proof. intros. apply (@iso_comp_right_isweq C^op b a (opp_iso h)). Qed. *) (** * Covariant Yoneda functor *) (** ** On objects *) Definition covyoneda_objects_ob (C : category) (c : C^op) (d : C) := C⟦c,d⟧. (* Definition covyoneda_objects_mor (C : precategory) (c : C^op) *) (* (d d' : C) (f : C⟦d,d'⟧) : *) (* covyoneda_objects_ob C c d -> covyoneda_objects_ob C c d' := *) (* λ g, g · f. *) Definition covyoneda_ob_functor_data (C : category) (c : C^op) : functor_data C HSET. Proof. exists (λ c', make_hSet (covyoneda_objects_ob C c c') (homset_property C c c')) . intros a b f g. unfold covyoneda_objects_ob in *. simpl in *. exact (g · f). Defined. Lemma is_functor_covyoneda_functor_data (C : category) (c : C^op) : is_functor (covyoneda_ob_functor_data C c). Proof. split. - intros c'; apply funextfun; intro x; apply id_right. - intros a b d f g; apply funextfun; intro h; apply assoc. Qed. Definition covyoneda_objects (C : category) (c : C^op) : functor C HSET := tpair _ _ (is_functor_covyoneda_functor_data C c). (** ** On morphisms *) Definition covyoneda_morphisms_data (C : category) (c c' : C^op) (f : C^op⟦c,c'⟧) : ∏ a : C, HSET⟦covyoneda_objects C c a,covyoneda_objects C c' a⟧. Proof. simpl in f; intros a g. apply (f · g). Defined. Lemma is_nat_trans_covyoneda_morphisms_data (C : category) (c c' : C^op) (f : C^op⟦c,c'⟧) : is_nat_trans (covyoneda_objects C c) (covyoneda_objects C c') (covyoneda_morphisms_data C c c' f). Proof. intros d d' g; apply funextsec; intro h; apply assoc. Qed. Definition covyoneda_morphisms (C : category) (c c' : C^op) (f : C^op⟦c,c'⟧) : nat_trans (covyoneda_objects C c) (covyoneda_objects C c') := tpair _ _ (is_nat_trans_covyoneda_morphisms_data C c c' f). Definition covyoneda_functor_data (C : category) : functor_data C^op [C,HSET,has_homsets_HSET] := tpair _ (covyoneda_objects C) (covyoneda_morphisms C). (** ** Functorial properties of the yoneda assignments *) Lemma is_functor_covyoneda (C : category) : is_functor (covyoneda_functor_data C). Proof. split. - intro a. apply (@nat_trans_eq C _ has_homsets_HSET). intro c; apply funextsec; intro f; simpl in *. apply id_left. - intros a b c f g. apply (@nat_trans_eq C _ has_homsets_HSET). simpl; intro d; apply funextsec; intro h; apply pathsinv0, assoc. Qed. Definition covyoneda (C : category) : functor C^op [C, HSET, has_homsets_HSET] := tpair _ _ (is_functor_covyoneda C). (** TODO: adapt the rest? *) (* (* Notation "'ob' F" := (precategory_ob_mor_fun_objects F)(at level 4). *) *) (* (** ** Yoneda lemma: natural transformations from [yoneda C c] to [F] *) (* are isomorphic to [F c] *) *) (* Definition yoneda_map_1 (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) : *) (* hom _ (yoneda C hs c) F -> pr1 (F c) := *) (* λ h, pr1 h c (identity c). *) (* Lemma yoneda_map_2_ax (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) (x : pr1 (F c)) : *) (* is_nat_trans (pr1 (yoneda C hs c)) F *) (* (fun (d : C) (f : hom (C ^op) c d) => #F f x). *) (* Proof. *) (* intros a b f; simpl in *. *) (* apply funextsec. *) (* unfold yoneda_objects_ob; intro g. *) (* set (H:= functor_comp F _ _ b g). *) (* unfold functor_comp in H; *) (* unfold opp_precat_data in H; *) (* simpl in *. *) (* apply (toforallpaths _ _ _ (H f) x). *) (* Qed. *) (* Definition yoneda_map_2 (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) : *) (* pr1 (F c) -> hom _ (yoneda C hs c) F. *) (* Proof. *) (* intro x. *) (* exists (λ d : ob C, λ f, #F f x). *) (* apply yoneda_map_2_ax. *) (* Defined. *) (* Lemma yoneda_map_1_2 (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) *) (* (alpha : hom _ (yoneda C hs c) F) : *) (* yoneda_map_2 _ _ _ _ (yoneda_map_1 _ _ _ _ alpha) = alpha. *) (* Proof. *) (* simpl in *. *) (* set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)). *) (* apply T. *) (* intro a'; simpl. *) (* apply funextsec; intro f. *) (* unfold yoneda_map_1. *) (* pathvia ((alpha c · #F f) (identity c)). *) (* apply idpath. *) (* rewrite <- nat_trans_ax. *) (* unf; apply maponpaths. *) (* apply (id_right C a' c f ). *) (* Qed. *) (* Lemma yoneda_map_2_1 (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) (x : pr1 (F c)) : *) (* yoneda_map_1 _ _ _ _ (yoneda_map_2 _ hs _ _ x) = x. *) (* Proof. *) (* simpl. *) (* rewrite (functor_id F). *) (* apply idpath. *) (* Qed. *) (* Lemma isaset_nat_trans_yoneda (C: precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) : *) (* isaset (nat_trans (yoneda_ob_functor_data C hs c) F). *) (* Proof. *) (* apply isaset_nat_trans. *) (* apply (has_homsets_HSET). *) (* Qed. *) (* Lemma yoneda_iso_sets (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) : *) (* is_iso (C:=HSET) *) (* (a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)) *) (* (b := F c) *) (* (yoneda_map_1 C hs c F). *) (* Proof. *) (* set (T:=yoneda_map_2 C hs c F). simpl in T. *) (* set (T':= T : hom HSET (F c) (make_hSet (hom _ ((yoneda C) hs c) F) *) (* (isaset_nat_trans_yoneda C hs c F))). *) (* apply (is_iso_qinv (C:=HSET) _ T' ). *) (* repeat split; simpl. *) (* - apply funextsec; intro alpha. *) (* unf; simpl. *) (* apply (yoneda_map_1_2 C hs c F). *) (* - apply funextsec; intro x. *) (* unf; rewrite (functor_id F). *) (* apply idpath. *) (* Defined. *) (* Definition yoneda_iso_target (C : precategory) (hs : has_homsets C) *) (* (F : [C^op, HSET, has_homsets_HSET]) *) (* : functor C^op HSET. *) (* Proof. *) (* simple refine (@functor_composite _ [C^op, HSET, has_homsets_HSET]^op _ _ _ ). *) (* - apply functor_opp. *) (* apply yoneda. apply hs. *) (* - apply (yoneda _ (functor_category_has_homsets _ _ _ ) F). *) (* Defined. *) (* Lemma is_natural_yoneda_iso (C : precategory) (hs : has_homsets C) (F : functor C^op HSET): *) (* is_nat_trans (yoneda_iso_target C hs F) F *) (* (λ c, yoneda_map_1 C hs c F). *) (* Proof. *) (* unfold is_nat_trans. *) (* intros c c' f. cbn in *. *) (* apply funextsec. *) (* unfold yoneda_ob_functor_data. cbn. *) (* unfold yoneda_morphisms_data. *) (* unfold yoneda_map_1. *) (* intro X. *) (* assert (XH := nat_trans_ax X). *) (* cbn in XH. unfold yoneda_objects_ob in XH. *) (* assert (XH' := XH c' c' (identity _ )). *) (* assert (XH2 := toforallpaths _ _ _ XH'). *) (* rewrite XH2. *) (* rewrite (functor_id F). *) (* cbn. *) (* clear XH2 XH'. *) (* assert (XH' := XH _ _ f). *) (* assert (XH2 := toforallpaths _ _ _ XH'). *) (* eapply pathscomp0. Focus 2. apply XH2. *) (* rewrite id_right. *) (* apply idpath. *) (* Qed. *) (* Definition natural_trans_yoneda_iso (C : precategory) (hs : has_homsets C) *) (* (F : functor C^op HSET) *) (* : nat_trans (yoneda_iso_target C hs F) F *) (* := tpair _ _ (is_natural_yoneda_iso C hs F). *) (* Lemma is_natural_yoneda_iso_inv (C : precategory) (hs : has_homsets C) (F : functor C^op HSET): *) (* is_nat_trans F (yoneda_iso_target C hs F) *) (* (λ c, yoneda_map_2 C hs c F). *) (* Proof. *) (* unfold is_nat_trans. *) (* intros c c' f. cbn in *. *) (* apply funextsec. *) (* unfold yoneda_ob_functor_data. cbn. *) (* unfold yoneda_map_2. *) (* intro A. *) (* apply nat_trans_eq. { apply (has_homsets_HSET). } *) (* cbn. intro d. *) (* apply funextfun. *) (* unfold yoneda_objects_ob. intro g. *) (* unfold yoneda_morphisms_data. *) (* apply (! toforallpaths _ _ _ (functor_comp F _ _ _ _ _ ) A). *) (* Qed. *) (* Definition natural_trans_yoneda_iso_inv (C : precategory) (hs : has_homsets C) *) (* (F : functor C^op HSET) *) (* : nat_trans (yoneda_iso_target C hs F) F *) (* := tpair _ _ (is_natural_yoneda_iso C hs F). *) (* Lemma isweq_yoneda_map_1 (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) : *) (* isweq *) (* (*a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)*) *) (* (*b := F c*) *) (* (yoneda_map_1 C hs c F). *) (* Proof. *) (* set (T:=yoneda_map_2 C hs c F). simpl in T. *) (* simple refine (isweq_iso _ _ _ _ ). *) (* - apply T. *) (* - apply yoneda_map_1_2. *) (* - apply yoneda_map_2_1. *) (* Defined. *) (* Definition yoneda_weq (C : precategory) (hs: has_homsets C) (c : C) *) (* (F : functor C^op HSET) *) (* : hom [C^op, HSET, has_homsets_HSET] ((yoneda C hs) c) F ≃ pr1hSet (F c) *) (* := make_weq _ (isweq_yoneda_map_1 C hs c F). *) (* (** ** The Yoneda embedding is fully faithful *) *) (* Lemma yoneda_fully_faithful (C : precategory) (hs: has_homsets C) : fully_faithful (yoneda C hs). *) (* Proof. *) (* intros a b; simpl. *) (* apply (isweq_iso _ *) (* (yoneda_map_1 C hs a (pr1 (yoneda C hs) b))). *) (* - intro; simpl in *. *) (* apply id_left. *) (* - intro gamma. *) (* simpl in *. *) (* apply nat_trans_eq. apply (has_homsets_HSET). *) (* intro x. simpl in *. *) (* apply funextsec; intro f. *) (* unfold yoneda_map_1. *) (* unfold yoneda_morphisms_data. *) (* assert (T:= toforallpaths _ _ _ (nat_trans_ax gamma a x f) (identity _ )). *) (* cbn in T. *) (* eapply pathscomp0; [apply (!T) |]. *) (* apply maponpaths. *) (* apply id_right. *) (* Defined. *) (* Section yoneda_functor_precomp. *) (* Variables C D : precategory. *) (* Variables (hsC : has_homsets C) (hsD : has_homsets D). *) (* Variable F : functor C D. *) (* Section fix_object. *) (* Variable c : C. *) (* Definition yoneda_functor_precomp' : nat_trans (yoneda_objects C hsC c) *) (* (functor_composite (functor_opp F) (yoneda_objects D hsD (F c))). *) (* Proof. *) (* simple refine (tpair _ _ _ ). *) (* - intros d f ; simpl. *) (* apply (#F f). *) (* - abstract (intros d d' f ; *) (* apply funextsec; intro t; simpl; *) (* apply functor_comp). *) (* Defined. *) (* Definition yoneda_functor_precomp : _ ⟦ yoneda C hsC c, functor_composite (functor_opp F) (yoneda_objects D hsD (F c))⟧. *) (* Proof. *) (* exact yoneda_functor_precomp'. *) (* Defined. *) (* Variable Fff : fully_faithful F. *) (* Lemma is_iso_yoneda_functor_precomp : is_iso yoneda_functor_precomp. *) (* Proof. *) (* apply functor_iso_if_pointwise_iso. *) (* intro. simpl. *) (* set (T:= make_weq _ (Fff a c)). *) (* set (TA := make_hSet (hom C a c) (hsC _ _ )). *) (* set (TB := make_hSet (hom D (F a) (F c)) (hsD _ _ )). *) (* apply (hset_equiv_is_iso TA TB T). *) (* Defined. *) (* End fix_object. *) (* Let A := functor_composite F (yoneda D hsD). *) (* Let B := pre_composition_functor _ _ HSET (has_homsets_opp hsD) (has_homsets_HSET) (functor_opp F). *) (* Definition yoneda_functor_precomp_nat_trans : *) (* @nat_trans *) (* C *) (* [C^op, HSET, (has_homsets_HSET)] *) (* (yoneda C hsC) *) (* (functor_composite A B). *) (* Proof. *) (* simple refine (tpair _ _ _ ). *) (* - intro c; simpl. *) (* apply yoneda_functor_precomp. *) (* - abstract ( *) (* intros c c' f; *) (* apply nat_trans_eq; try apply (has_homsets_HSET); *) (* intro d; apply funextsec; intro t; *) (* cbn; *) (* apply functor_comp). *) (* Defined. *) (* End yoneda_functor_precomp. *) UniMath-20231010/UniMath/CategoryTheory/dune000066400000000000000000000002431451125700300205010ustar00rootroot00000000000000(rule (target All.v) (deps (source_tree .)) (action (with-stdout-to All.v (run %{project_root}/util/generate-exports UniMath.CategoryTheory "%{deps}")))) UniMath-20231010/UniMath/CategoryTheory/elems_slice_equiv.v000066400000000000000000000407441451125700300235210ustar00rootroot00000000000000(** ********************************************************** Matthew Weaver, 2017 ************************************************************) (** ********************************************************** Contents : Equivalence of the categories PreShv ∫P and PreShv C / P for any P in PreShv C ************************************************************) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Equivalences.Core UniMath.CategoryTheory.categories.HSET.Core UniMath.CategoryTheory.categories.HSET.MonoEpiIso UniMath.CategoryTheory.slicecat UniMath.CategoryTheory.opp_precat UniMath.CategoryTheory.Presheaf UniMath.CategoryTheory.ElementsOp. (** * Proof that PreShv ∫P ≃ PreShv C / P *) Section elems_slice_equiv. Local Open Scope cat. Local Notation "C / X" := (slice_cat C X). Local Definition ap_PreShv {X : category} := fun (P : PreShv X) (x : X) => pr1hSet ((pr1 P) x). Local Notation "##" := ap_PreShv. Variable (C : category) (P : PreShv C). (** ** Construction of the functor from PreShv ∫P to PreShv C / P *) Local Definition make_ob := @make_ob C P. Local Definition make_mor := @make_mor C P. Definition PreShv_to_slice_ob_funct_fun (F : PreShv ∫P) : C^op → HSET := λ X, total2_hSet (fun p : ##P X => (pr1 F) (make_ob X p)). Definition PreShv_to_slice_ob_funct_mor (F : PreShv ∫P) {X Y : C^op} (f : X --> Y) : PreShv_to_slice_ob_funct_fun F X --> PreShv_to_slice_ob_funct_fun F Y := λ p, # (pr1 P) f (pr1 p) ,, # (pr1 F) (mor_to_el_mor (C:=C) f (pr1 p)) (pr2 p). Definition PreShv_to_slice_ob_funct_data (F : PreShv ∫P) : functor_data C^op HSET := PreShv_to_slice_ob_funct_fun F ,, @PreShv_to_slice_ob_funct_mor F. (* Proof from Anders: see [ctx_ext] in https://github.com/mortberg/TypeTheory/blob/cube0/TypeTheory/Cubical/cubical.v *) Definition PreShv_to_slice_ob_is_funct (F : PreShv ∫P) : is_functor (PreShv_to_slice_ob_funct_data F). Proof. split. + intros I; apply funextfun; intros [ρ u]. use total2_paths_f. * exact (eqtohomot (functor_id P I) ρ). * etrans; [use transportf_make_ob|]. etrans; [apply transportf_PreShv|]; cbn. now rewrite (mor_to_el_mor_id ρ), transportfbinv, (functor_id F). + intros I J K f g; apply funextfun; intros [ρ u]. use total2_paths_f. * exact (eqtohomot (functor_comp P f g) ρ). * etrans; [use transportf_make_ob|]. etrans; [apply transportf_PreShv|]. rewrite (mor_to_el_mor_comp _ f g), transportfbinv. generalize u; simpl in *. apply eqtohomot, (functor_comp F (mor_to_el_mor f ρ) (mor_to_el_mor g (# (pr1 P) f ρ))). Qed. (* Version of proof worked out by Vladimir and me *) Definition PreShv_to_slice_ob_is_funct' (F : PreShv ∫P) : is_functor (PreShv_to_slice_ob_funct_data F). Proof. split; [intros X | intros X Y Z f g]; apply funextsec; intros [p q]. + set (T := ∑ p' : ## P X, p' = # (pr1 P) (identity X) p : UU). set (T' := ∑ p' : ## P X, (pr1 F) (X ,, p) --> (pr1 F) (X ,, p') : UU). set (phi := λ (x : T), make_mor (X ,, pr1 x) (X ,, p) (identity X) (pr2 x)). set (G := λ (x : T), pr1 x ,, # (pr1 F) (phi x) : T'). set (e := fun (x : ∫P) => eqtohomot (!((functor_id P) (pr1 x))) (pr2 x)). set (h := λ (x : T'), pr1 x ,, (pr2 x) q : pr1hSet (PreShv_to_slice_ob_funct_fun F X)). use (maponpaths (funcomp G h) (coconustot_isProofIrrelevant ((# (pr1 P) (identity X) p) ,, idpath _) (p ,, e (X ,, p))) @ _). use (@pair_path_in2 _ (λ x, pr1hSet ((pr1 F) (X ,, x))) p). use (eqtohomot _ q @ eqtohomot (functor_id F (X ,, p)) q). use (maponpaths (# (pr1 F))). use total2_paths_f. * reflexivity. * rewrite idpath_transportf; now apply setproperty. + set (T := ∑ p' : ## P Z, p' = # (pr1 P) (g ∘ f) p : UU). set (T' := ∑ p' : ## P Z, (pr1 F) (X ,, p) --> (pr1 F) (Z ,, p') : UU). set (phi := λ (x : T), make_mor (Z ,, pr1 x) (X ,, p) (g ∘ f) (pr2 x)). set (G := λ (x : T), (pr1 x ,, # (pr1 F) (phi x)) : T'). set (e := fun (z y x : ∫P) (f : z --> y) (g : y --> x) => ((pr2 f) @ maponpaths (# (pr1 P) (pr1 f)) (pr2 g) @ (eqtohomot (!(functor_comp P) (pr1 g) (pr1 f)) (pr2 x)))). set (h := λ (x : T'), pr1 x ,, (pr2 x) q : pr1hSet (PreShv_to_slice_ob_funct_fun F Z)). use (maponpaths (funcomp G h) (coconustot_isProofIrrelevant (# (pr1 P) (g ∘ f) p ,, idpath _) (# (pr1 P) g (# (pr1 P) f p) ,, e (make_ob Z (# (pr1 P) g (# (pr1 P) f p))) (make_ob Y (# (pr1 P) f p)) (make_ob X p) (g ,, idpath _) (f ,, idpath _))) @ _). use (@pair_path_in2 _ (λ x, pr1hSet ((pr1 F) (Z ,, x))) (# (pr1 P) g (# (pr1 P) f p))). use (eqtohomot _ q @ eqtohomot (@functor_comp _ _ F (make_ob X p) (make_ob Y (# (pr1 P) f p)) (make_ob Z (# (pr1 P) g (# (pr1 P) f p))) (f ,, idpath _) (g,, idpath _)) q). use (maponpaths (# (pr1 F))). use total2_paths_f. * reflexivity. * rewrite idpath_transportf; now apply setproperty. Qed. Definition PreShv_to_slice_ob_funct (F : PreShv ∫P) : PreShv C := PreShv_to_slice_ob_funct_data F ,, PreShv_to_slice_ob_is_funct F. Definition PreShv_to_slice_ob_nat_fun (F : PreShv ∫P) (x : C) : (∑ (Px :##P x), ##F (x,, Px)) → ##P x := pr1. Definition PreShv_to_slice_ob : PreShv ∫P → PreShv C / P. Proof. intro F. exists (PreShv_to_slice_ob_funct F). now exists (PreShv_to_slice_ob_nat_fun F). Defined. Definition PreShv_to_slice_ob_nat {X Y : PreShv ∫P} (f : X --> Y) (c : C) : (∑ Px : ## P c, ## X (c,, Px)) → (∑ Px : ## P c, ## Y (c,, Px)) := λ p, pr1 p ,, (pr1 f) (c ,, (pr1 p)) (pr2 p). Definition PreShv_to_slice_ob_isnat {X Y : PreShv ∫P} (f : X --> Y) : is_nat_trans (PreShv_to_slice_ob_funct_data X) (PreShv_to_slice_ob_funct_data Y) (PreShv_to_slice_ob_nat f). simpl. intros c c' g. apply funextsec; intro p. apply pair_path_in2. exact (eqtohomot ((pr2 f) (c ,, pr1 p) (c',, # (pr1 P) g (pr1 p)) (g,, idpath (# (pr1 P) g (pr1 p)))) (pr2 p)). Qed. Definition PreShv_to_slice_mor {X Y : PreShv ∫P} (f : X --> Y) : PreShv_to_slice_ob X --> PreShv_to_slice_ob Y. exists (PreShv_to_slice_ob_nat f ,, PreShv_to_slice_ob_isnat f). now apply (nat_trans_eq has_homsets_HSET). Defined. Definition PreShv_to_slice_data : functor_data (PreShv ∫P) (PreShv C / P) := PreShv_to_slice_ob ,, @PreShv_to_slice_mor. Definition PreShv_to_slice_is_funct : is_functor PreShv_to_slice_data. Proof. split; [intros X | intros X Y Z f g]; apply eq_mor_slicecat; apply (nat_trans_eq has_homsets_HSET); unfold PreShv_to_slice_ob_nat , PreShv_to_slice_ob_funct_fun; intro c; apply funextsec; intro p; reflexivity. Defined. Definition PreShv_to_slice : functor (PreShv ∫P) (PreShv C / P) := PreShv_to_slice_data ,, PreShv_to_slice_is_funct. (** ** Construction of the functor from PreShv C / P to PreShv ∫P *) Definition slice_to_PreShv_ob_ob (Q : PreShv C / P) : (∫P)^op → HSET := λ p, hfiber ((pr1 (pr2 Q)) (pr1 p)) (pr2 p) ,, isaset_hfiber ((pr1 (pr2 Q)) (pr1 p)) (pr2 p) (pr2 (((pr1 (pr1 Q)) (pr1 p)))) (pr2 ((pr1 P) (pr1 p))). Definition slice_to_PreShv_ob_mor (Q : PreShv C / P) {F G : (∫P)^op} (f : F --> G) : slice_to_PreShv_ob_ob Q F --> slice_to_PreShv_ob_ob Q G. intros s. destruct Q as [[[Q Qmor] Qisfunct] [Qnat Qisnat]]. destruct F as [x Px]. destruct G as [y Py]. destruct f as [f feq]. apply (hfibersgftog (Qmor _ _ f) (Qnat y)). exists (pr1 s). rewrite feq. use (eqtohomot (Qisnat _ _ f) (pr1 s) @ _). exact (maponpaths (# (pr1 P) f) (pr2 s)). Defined. Definition slice_to_PreShv_ob_funct_data (Q : PreShv C / P) : functor_data ((∫P)^op) HSET := slice_to_PreShv_ob_ob Q ,, @slice_to_PreShv_ob_mor Q. Definition slice_to_PreShv_ob_is_funct (Q : PreShv C / P) : is_functor (slice_to_PreShv_ob_funct_data Q). Proof. split; [intros [x Px] | intros [x Px] [y Py] [z Pz] [f feq] [g geq]]; destruct Q as [[[Q Qmor] Qisfunct] [Qnat Qisnat]]; apply funextsec; intro p; apply (invmaponpathsincl pr1); try (apply isofhlevelfpr1; intro; apply setproperty). + exact (eqtohomot ((pr1 Qisfunct) x) (pr1 p)). + exact (eqtohomot ((pr2 Qisfunct) x y z f g) (pr1 p)). Qed. Definition slice_to_PreShv_ob : PreShv C / P → PreShv ∫P := λ Q, slice_to_PreShv_ob_funct_data Q ,, slice_to_PreShv_ob_is_funct Q. Definition slice_to_PreShv_ob_nat {X Y : PreShv C / P} (F : X --> Y) (e : ∫P^op) : (slice_to_PreShv_ob_ob X) e --> (slice_to_PreShv_ob_ob Y) e. Proof. induction e as [e Pe]. exact (λ p, hfibersgftog ((pr1 (pr1 F)) e) ((pr1 (pr2 Y)) e) Pe (transportf (λ x, hfiber (x e) Pe) (base_paths _ _ (pr2 F)) p)). Defined. Definition slice_to_PreShv_ob_is_nat {X Y : PreShv C / P} (F : X --> Y) : is_nat_trans (slice_to_PreShv_ob X : functor _ _) (slice_to_PreShv_ob Y : functor _ _) (slice_to_PreShv_ob_nat F). Proof. intros [e Pe] [e' Pe'] [f feq]. destruct X as [[[X Xmor] Xisfunct] [Xnat Xisnat]]. destruct Y as [[[Y Ymor] Yisfunct] [Ynat Yisnat]]. destruct F as [[F Fisnat] Feq]. simpl in *. apply funextsec; intros [p peq]. apply (invmaponpathsincl pr1). + apply isofhlevelfpr1. intro. apply setproperty. + simpl. destruct peq. unfold hfiber. repeat rewrite transportf_total2. simpl. repeat rewrite transportf_const. exact (eqtohomot (Fisnat e e' f) p). Qed. Definition slice_to_PreShv_mor {X Y : PreShv C / P} (F : X --> Y) : slice_to_PreShv_ob X --> slice_to_PreShv_ob Y := slice_to_PreShv_ob_nat F ,, slice_to_PreShv_ob_is_nat F. Definition slice_to_PreShv_data : functor_data (PreShv C / P) (PreShv ∫P) := slice_to_PreShv_ob ,, @slice_to_PreShv_mor. Definition slice_to_PreShv_is_funct : is_functor slice_to_PreShv_data. Proof. split; [ intros X | intros X Y Z F G]; apply (nat_trans_eq has_homsets_HSET); intros [c Pc]; apply funextsec; intros [p peq]; apply (invmaponpathsincl pr1); try (apply isofhlevelfpr1; intro; apply setproperty); simpl; unfold hfiber; unfold hfibersgftog; unfold make_hfiber; repeat (rewrite transportf_total2; simpl; unfold hfiber); now repeat rewrite transportf_const. Qed. Definition slice_to_PreShv : functor (PreShv C / P) (PreShv ∫P) := slice_to_PreShv_data ,, slice_to_PreShv_is_funct. (** ** Construction of the natural isomorphism from (slice_to_PreShv ∙ PreShv_to_slice) to the identity functor *) Definition slice_counit_fun (X : PreShv C / P) : (slice_to_PreShv ∙ PreShv_to_slice) X --> (functor_identity _) X. Proof. destruct X as [[[X Xmor] Xisfunct] [Xnat Xisnat]]. simpl in *. repeat (use tpair; simpl). + intros x [p q]. exact (pr1 q). + intros A B f. apply funextsec; intros [p peq]. reflexivity. + apply (nat_trans_eq has_homsets_HSET). intros A. apply funextsec; intros [p [q e]]. exact (!e). Defined. Definition is_nat_trans_slice_counit : is_nat_trans _ _ slice_counit_fun. Proof. intros X Y f. apply eq_mor_slicecat , (nat_trans_eq has_homsets_HSET). intros A. apply funextsec; intros [p [q e]]. simpl. unfold compose. simpl. destruct X as [[[X Xmor] Xisfunct] [Xnat Xisnat]]. destruct Y as [[[Y Ymor] Yisfunct] [Ynat Yisnat]]. destruct f as [[f fisnat] feq]. simpl in *. apply maponpaths. unfold hfiber. rewrite transportf_total2. simpl. rewrite transportf_const. reflexivity. Qed. Definition slice_counit : slice_to_PreShv ∙ PreShv_to_slice ⟹ functor_identity (PreShv C / P) := slice_counit_fun ,, is_nat_trans_slice_counit. Definition slice_all_z_iso : forall F : PreShv C / P, is_z_isomorphism (slice_counit F). Proof. intros [[[F Fmor] Fisfunct] [Fnat Fisnat]]. apply z_iso_to_slice_precat_z_iso. apply nat_trafo_z_iso_if_pointwise_z_iso. intros X; simpl. change (λ X0, pr1 (pr2 X0)) with (fromcoconusf (Fnat X)). exact (hset_equiv_is_z_iso (make_hSet (coconusf (Fnat X)) (isaset_total2_hSet _ (λ y, (hfiber_hSet (Fnat X) y)))) _ (weqfromcoconusf (Fnat X))). Qed. Definition slice_unit : functor_identity (PreShv C / P) ⟹ slice_to_PreShv ∙ PreShv_to_slice := pr1 (nat_trafo_z_iso_if_pointwise_z_iso (has_homsets_slice_precat ((PreShv C)) P) (slice_counit) slice_all_z_iso). (** ** Construction of the natural isomorphism from the identity functor to (PreShv_to_slice ∙ slice_to_PreShv) *) Definition PreShv_unit_fun (F : PreShv ∫P) : (functor_identity _) F --> (PreShv_to_slice ∙ slice_to_PreShv) F. Proof. use tpair. + intros [X p] x. exact ((p ,, x) ,, idpath p). + intros [X p] [X' p'] [f feq]. simpl in *. apply funextsec; intros x. apply (invmaponpathsincl pr1). apply isofhlevelfpr1; intro; apply setproperty. induction (!feq). apply (total2_paths2_f (idpath _)). rewrite idpath_transportf. assert (set_eq : idpath _ = feq). { apply (pr2 (P X')). } now induction set_eq. Defined. Definition is_nat_trans_PreShv_unit : is_nat_trans _ _ PreShv_unit_fun. Proof. intros [[F Fmor] Fisfunct] [[G Gmor] Gisfunct] [f fisnat]. apply (nat_trans_eq has_homsets_HSET). intros [X p]. apply funextsec; intros q. apply (invmaponpathsincl pr1). apply isofhlevelfpr1; intro; apply setproperty. simpl. unfold hfiber. rewrite transportf_total2; simpl. now rewrite transportf_const. Qed. Definition PreShv_unit : functor_identity (PreShv ∫P) ⟹ PreShv_to_slice ∙ slice_to_PreShv := PreShv_unit_fun ,, is_nat_trans_PreShv_unit. Definition PreShv_all_iso : forall F : PreShv ∫P, is_z_isomorphism (PreShv_unit F). Proof. intros [[F Fmor] Fisfunct]. apply nat_trafo_z_iso_if_pointwise_z_iso. intros [X p]; simpl. assert (H : isweq (λ x : pr1hSet (F (X,, p)) , (p,, x) ,, idpath p : pr1hSet (slice_to_PreShv_ob_ob (PreShv_to_slice_ob ((F,, Fmor),, Fisfunct)) (X,, p)))). { unfold isweq. intros [[p' x'] e']. simpl in *. induction e'. use ((x',, idpath _),, _). intros [x'' t]. apply (invmaponpathsincl pr1). apply isofhlevelfpr1; intro; exact (pr2 (@eqset ((slice_to_PreShv_ob_ob (PreShv_to_slice_ob ((F,, Fmor),, Fisfunct)) (X,, p'))) _ _)). assert (eq_id : base_paths (p',, x'') (p',, x') (maponpaths pr1 t) = idpath p'). { set (c := iscontraprop1 (setproperty _ _ _) (idpath p')). exact ((pr2 c) _ @ !((pr2 c) _)). } set (eq := fiber_paths (maponpaths pr1 t)). use (_ @ eq). rewrite (transportf_paths _ eq_id). now rewrite idpath_transportf. } exact (hset_equiv_is_z_iso (F (X ,, p)) _ (_ ,, H)). Qed. Definition PreShv_counit : PreShv_to_slice ∙ slice_to_PreShv ⟹ functor_identity (PreShv ∫P) := pr1 (nat_trafo_z_iso_if_pointwise_z_iso (pr2 (PreShv ∫P)) PreShv_unit PreShv_all_iso). (** ** The equivalence of the categories PreShv ∫P and PreShv C / P *) Definition PreShv_of_elems_slice_of_PreShv_equiv : equivalence_of_cats (PreShv ∫P) (PreShv C / P) := (PreShv_to_slice ,, slice_to_PreShv ,, PreShv_unit ,, slice_counit) ,, (PreShv_all_iso ,, slice_all_z_iso). Definition PreShv_of_elems_slice_of_PreShv_adj_equiv : adj_equivalence_of_cats PreShv_to_slice := @adjointification (PreShv ∫P) (PreShv C / P) PreShv_of_elems_slice_of_PreShv_equiv. End elems_slice_equiv. UniMath-20231010/UniMath/CategoryTheory/exponentials.v000066400000000000000000000522131451125700300225270ustar00rootroot00000000000000 (** ********************************************************** Anders Mörtberg, 2016 ************************************************************) (** ********************************************************** Contents: - Definition of the functors given by binary product with a fixed object - Definition of exponentials Section [ExponentialsCarriedThroughAdjointEquivalence] added by Ralph Matthes in 2023 ************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.binproducts. (* for Section [ExponentialsCarriedThroughAdjointEquivalence] *) Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.catiso. Require Import UniMath.CategoryTheory.CategoryEquality. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Section exponentials. Context {C : category} (PC : BinProducts C). (* The functor "a * _" and "_ * a" *) Definition constprod_functor1 (a : C) : functor C C := BinProduct_of_functors C C PC (constant_functor C C a) (functor_identity C). Definition constprod_functor2 (a : C) : functor C C := BinProduct_of_functors C C PC (functor_identity C) (constant_functor C C a). Definition is_exponentiable (a : C) : UU := is_left_adjoint (constprod_functor1 a). Definition Exponentials : UU := ∏ (a : C), is_exponentiable a. Definition hasExponentials : UU := ∏ (a : C), ∥ is_exponentiable a ∥. Definition nat_trans_constprod_functor1 (a : C) : nat_trans (constprod_functor1 a) (constprod_functor2 a). Proof. use tpair. - intro x; simpl; unfold BinProduct_of_functors_ob; simpl. apply BinProductArrow; [ apply BinProductPr2 | apply BinProductPr1 ]. - abstract (intros x y f; simpl; unfold BinProduct_of_functors_mor; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; apply pathsinv0; eapply pathscomp0; [apply postcompWithBinProductArrow|]; now rewrite (BinProductOfArrowsPr2 C _ (PC a x)), (BinProductOfArrowsPr1 C _ (PC a x))). Defined. Definition nat_trans_constprod_functor2 (a : C) : nat_trans (constprod_functor2 a) (constprod_functor1 a). Proof. use tpair. - intro x; simpl; unfold BinProduct_of_functors_ob; simpl. apply BinProductArrow; [ apply BinProductPr2 | apply BinProductPr1 ]. - abstract (intros x y f; simpl; unfold BinProduct_of_functors_mor; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; apply pathsinv0; eapply pathscomp0; [apply postcompWithBinProductArrow|]; now rewrite (BinProductOfArrowsPr2 C _ (PC x a)), (BinProductOfArrowsPr1 C _ (PC x a))). Defined. Lemma is_z_iso_constprod_functor1 a : @is_z_isomorphism [C,C] _ _ (nat_trans_constprod_functor1 a). Proof. exists (nat_trans_constprod_functor2 a). split. + abstract ( apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left). + abstract ( apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left). Defined. (* This is not used *) Lemma is_z_iso_constprod_functor2 a : @is_z_isomorphism [C,C] _ _ (nat_trans_constprod_functor2 a). Proof. exists (nat_trans_constprod_functor1 a). split. + abstract ( apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left). + abstract ( apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl; eapply pathscomp0; [apply precompWithBinProductArrow|]; now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left). Defined. Definition flip_z_iso a : @z_iso [C,C] (constprod_functor1 a) (constprod_functor2 a) := tpair _ _ (is_z_iso_constprod_functor1 a). Variable (a : C). Variable (HF : is_left_adjoint (constprod_functor1 a)). Local Notation F := (constprod_functor1 a). Local Notation F' := (constprod_functor2 a). Let G := right_adjoint HF. Let H := pr2 HF : are_adjoints F G. Let eta : [C,C]⟦functor_identity C,functor_composite F G⟧ := unit_from_left_adjoint H. Let eps : [C,C]⟦functor_composite G F,functor_identity C⟧ := counit_from_left_adjoint H. Let H1 := triangle_id_left_ad H. Let H2 := triangle_id_right_ad H. Arguments constprod_functor1 : simpl never. Arguments constprod_functor2 : simpl never. Arguments flip_z_iso : simpl never. Local Definition eta' : [C,C]⟦functor_identity C,functor_composite F' G⟧ := let G' := (post_composition_functor C C C G) in eta · (# G' (flip_z_iso a)). Local Definition eps' : [C,C]⟦functor_composite G F',functor_identity C⟧ := let G' := (pre_composition_functor C C C G) in # G' (inv_from_z_iso (flip_z_iso a)) · eps. Local Lemma form_adjunction_eta'_eps' : form_adjunction F' G eta' eps'. Proof. fold eta in H1; fold eps in H1; fold eta in H2; fold eps in H2; fold G in H2. use tpair. + intro x; unfold eta', eps'; cbn. rewrite assoc. eapply pathscomp0. - eapply cancel_postcomposition. exact (nat_trans_ax (inv_from_z_iso (flip_z_iso _)) _ _ _). - rewrite functor_comp, assoc. eapply pathscomp0; [rewrite <- assoc; apply maponpaths, (nat_trans_ax eps)|]. rewrite <- assoc. eapply pathscomp0; [apply maponpaths; rewrite assoc; apply cancel_postcomposition, H1|]. rewrite id_left. apply (nat_trans_eq_pointwise (z_iso_after_z_iso_inv (flip_z_iso a)) x). + intro x; cbn. rewrite <- (H2 x), <- assoc, <- (functor_comp G). apply maponpaths, maponpaths. rewrite assoc. apply remove_id_left; try apply idpath. apply (nat_trans_eq_pointwise (z_iso_inv_after_z_iso (flip_z_iso a))). Qed. Lemma is_left_adjoint_constprod_functor2 : is_left_adjoint F'. Proof. apply (tpair _ G). apply (tpair _ (make_dirprod eta' eps')). apply form_adjunction_eta'_eps'. Defined. End exponentials. Section ExponentialsCarriedThroughAdjointEquivalence. Context {C : category} (PC : BinProducts C) {D : category} (PD : BinProducts D) (ExpC : Exponentials PC) (adjeq : adj_equiv C D). Let F : functor C D := adjeq. Let G : functor D C := adj_equivalence_inv adjeq. Let η_z_iso : ∏ (c : C), z_iso c (G (F c)) := unit_pointwise_z_iso_from_adj_equivalence adjeq. Let ε_z_iso : ∏ (d : D), z_iso (F (G d)) d := counit_pointwise_z_iso_from_adj_equivalence adjeq. Let η_nat_z_iso : nat_z_iso (functor_identity C) (functor_composite F G) := unit_nat_z_iso_from_adj_equivalence_of_cats adjeq. Let ε_nat_z_iso : nat_z_iso (functor_composite G F) (functor_identity D) := counit_nat_z_iso_from_adj_equivalence_of_cats adjeq. Let FC (c : C) : functor C C := constprod_functor1 PC c. Let GC (c : C) : functor C C := right_adjoint (ExpC c). Let ηC (c : C) : functor_identity C ⟹ (FC c) ∙ (GC c) := unit_from_left_adjoint (ExpC c). Let εC (c : C) : functor_composite (GC c) (FC c) ⟹ functor_identity C := counit_from_left_adjoint (ExpC c). Section FixAnObject. Context (d0 : D). Let Fd0 : functor D D := constprod_functor1 PD d0. Let Gd0 : functor D D := functor_composite (functor_composite G (GC (G d0))) F. Local Definition inherited_BP_on_C (d : D) : BinProduct C (G d0) (G d). Proof. use tpair. - exists (G (pr1 (pr1 (PD d0 d)))). exact (# G (pr1 (pr2 (pr1 (PD d0 d)))),,# G (pr2 (pr2 (pr1 (PD d0 d))))). - set (Hpres := right_adjoint_preserves_binproduct adjeq adjeq : preserves_binproduct G). exact (Hpres _ _ _ _ _ (pr2 (PD d0 d))). Defined. Local Definition μ_nat_trans_data : nat_trans_data (G ∙ FC (G d0)) (Fd0 ∙ G). Proof. intro d. exact (BinProductOfArrows _ (inherited_BP_on_C d) (PC (G d0) (G d)) (identity _) (identity _)). Defined. Local Lemma μ_nat_trans_law : is_nat_trans _ _ μ_nat_trans_data. Proof. intros d' d f. apply (BinProductArrowsEq _ _ _ (inherited_BP_on_C d)). - etrans. { rewrite assoc'. apply maponpaths. apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } rewrite id_right. etrans. 2: { cbn. rewrite assoc'. etrans. 2: { apply maponpaths. apply functor_comp. } unfold BinProduct_of_functors_mor. cbn. etrans. 2: { do 2 apply maponpaths. apply pathsinv0, BinProductOfArrowsPr1. } rewrite id_right. unfold BinProductPr1. apply pathsinv0, (BinProductOfArrowsPr1 _ (inherited_BP_on_C d') (PC (G d0) (G d'))). } rewrite id_right. cbn. unfold BinProduct_of_functors_mor, constant_functor, functor_identity. cbn. etrans. { apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (PC (G d0) (G d'))). } apply id_right. - etrans. { rewrite assoc'. apply maponpaths. apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } rewrite id_right. etrans. 2: { cbn. rewrite assoc'. etrans. 2: { apply maponpaths. apply functor_comp. } unfold BinProduct_of_functors_mor. cbn. etrans. 2: { do 2 apply maponpaths. apply pathsinv0, BinProductOfArrowsPr2. } rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. unfold BinProductPr2. apply pathsinv0, (BinProductOfArrowsPr2 _ (inherited_BP_on_C d') (PC (G d0) (G d'))). } rewrite id_right. cbn. unfold BinProduct_of_functors_mor, constant_functor, functor_identity. cbn. etrans. { apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (PC (G d0) (G d'))). } apply idpath. Qed. Local Definition μ_nat_trans : nat_trans (G ∙ FC (G d0)) (Fd0 ∙ G) := _,,μ_nat_trans_law. Local Definition μ_nat_trans_inv_pointwise (d : D) : C ⟦ (Fd0 ∙ G) d, (G ∙ FC (G d0)) d ⟧. Proof. exact (BinProductOfArrows _ (PC (G d0) (G d)) (inherited_BP_on_C d) (identity _) (identity _)). Defined. Local Lemma μ_nat_trans_is_inverse (d : D): is_inverse_in_precat (μ_nat_trans d) (μ_nat_trans_inv_pointwise d). Proof. split; cbn. - apply pathsinv0, BinProduct_endo_is_identity. + rewrite assoc'. etrans. { apply maponpaths. cbn. apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). } rewrite id_right. etrans. { cbn. apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } apply id_right. + rewrite assoc'. etrans. { apply maponpaths. cbn. apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). } rewrite id_right. etrans. { cbn. apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } apply id_right. - unfold BinProduct_of_functors_ob, constant_functor, functor_identity. cbn. apply pathsinv0. apply (BinProduct_endo_is_identity _ _ _ (inherited_BP_on_C d)). + rewrite assoc'. etrans. { apply maponpaths. apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } rewrite id_right. etrans. { apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). } apply id_right. + rewrite assoc'. etrans. { apply maponpaths. apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). } rewrite id_right. etrans. { apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). } apply id_right. Qed. Local Definition μ : nat_z_iso (functor_composite G (FC (G d0))) (functor_composite Fd0 G). Proof. use make_nat_z_iso. - exact μ_nat_trans. - intro d. use tpair. + exact (μ_nat_trans_inv_pointwise d). + exact (μ_nat_trans_is_inverse d). Defined. Local Definition ηDd0 : functor_identity D ⟹ Fd0 ∙ Gd0. Proof. simple refine (nat_trans_comp _ _ _ (nat_z_iso_to_trans_inv ε_nat_z_iso) _). unfold Gd0. change ((functor_composite G (functor_identity C)) ∙ F ⟹ (Fd0 ∙ (G ∙ GC (G d0))) ∙ F). apply post_whisker. refine (nat_trans_comp _ _ _ _ _). - apply (pre_whisker G (ηC (G d0))). - change (functor_composite (functor_composite G (FC (G d0))) (GC (G d0)) ⟹ functor_composite (Fd0 ∙ G) (GC (G d0))). apply post_whisker. apply μ. Defined. Local Definition εDd0 : Gd0 ∙ Fd0 ⟹ functor_identity D. Proof. simple refine (nat_trans_comp _ _ _ _ ε_nat_z_iso). change (functor_composite (functor_composite Gd0 Fd0) (functor_identity D) ⟹ G ∙ F). refine (nat_trans_comp _ _ _ _ _). - apply (pre_whisker _ (nat_z_iso_to_trans_inv ε_nat_z_iso)). - change ((functor_composite (Gd0 ∙ Fd0) G) ∙ F ⟹ G ∙ F). apply post_whisker. unfold Gd0. change (((G ∙ GC (G d0)) ∙ F) ∙ (Fd0 ∙ G) ⟹ G). refine (nat_trans_comp _ _ _ _ _). + apply (pre_whisker _ (nat_z_iso_to_trans_inv μ)). + change ((((G ∙ GC (G d0)) ∙ F) ∙ G) ∙ FC (G d0) ⟹ G). refine (nat_trans_comp _ _ _ _ _). * use (post_whisker _ (FC (G d0))). -- exact (G ∙ GC (G d0)). -- change (functor_composite (G ∙ GC (G d0)) (functor_composite F G) ⟹ functor_composite (G ∙ GC (G d0)) (functor_identity C)). apply (pre_whisker _ (nat_z_iso_to_trans_inv η_nat_z_iso)). * change (functor_composite G (functor_composite (GC (G d0)) (FC (G d0))) ⟹ G). apply (pre_whisker _ (εC (G d0))). Defined. Definition is_expDd0_adjunction_data : adjunction_data D D. Proof. use make_adjunction_data. - exact Fd0. - exact Gd0. - exact ηDd0. - exact εDd0. Defined. Lemma is_expDd0_adjunction_laws : form_adjunction' is_expDd0_adjunction_data. Proof. split. - intro d. change (# Fd0 (ηDd0 d) · εDd0 (Fd0 d) = identity (Fd0 d)). unfold ηDd0. etrans. { apply cancel_postcomposition. etrans. { apply functor_comp. } do 2 apply maponpaths. assert (Hpost := post_whisker_composition _ _ _ F _ _ _ (pre_whisker G (ηC (G d0))) (post_whisker (pr1 μ) (GC (G d0)))). refine (toforallpaths _ _ _ (maponpaths pr1 Hpost) d). } etrans. { apply cancel_postcomposition. apply maponpaths. apply functor_comp. } unfold εDd0. (* so it is in principle possible to work with this definition, but every step takes an effort, requiring a perfect proof on paper before rewrite functor_comp. use BinProductArrowsEq. + rewrite id_left. cbn. unfold BinProduct_of_functors_mor. rewrite id_left. unfold BinProduct_of_functors_ob, constant_functor, functor_identity. cbn. etrans. { apply cancel_postcomposition. apply admit. + cbn. unfold BinProduct_of_functors_mor. rewrite id_left. unfold BinProduct_of_functors_ob, constant_functor, functor_identity. cbn. (* is this supposed to be analogous? *) admit. - intro d. show_id_type. (* F-images in source and target of the morphisms *) cbn. admit. *) Abort. (* Definition is_expDd0_adjunction : adjunction D D := _,,is_expDd0_adjunction_laws. Local Definition is_expDd0 : is_exponentiable PD d0. Proof. exists Gd0. exact is_expDd0_adjunction. Defined. *) (* an experiment towards using univalence for this proof Lemma is_expDd0_adjunction_laws_equal_cats (Heq : C = D) (*(PCeq : transportf _ Heq PC = PD)*) : form_adjunction' is_expDd0_adjunction_data. Proof. induction Heq. *) End FixAnObject. (* Definition exponentials_through_adj_equivalence : Exponentials PD. Proof. intro d0. exact (is_expDd0 d0). Defined. *) End ExponentialsCarriedThroughAdjointEquivalence. Section AlternativeWithUnivalence. Context {C : category} (PC : BinProducts C) {D : category} (PD : BinProducts D) (ExpC : Exponentials PC) (adjeq : adj_equiv C D) (Cuniv : is_univalent C) (Duniv : is_univalent D). Local Lemma CDeq : C = D. Proof. assert (aux : category_to_precategory C = category_to_precategory D). { apply (invmap (catiso_is_path_precat C D D)). apply (adj_equivalence_of_cats_to_cat_iso adjeq); assumption. } apply subtypePath. intro. apply isaprop_has_homsets. exact aux. Qed. Definition exponentials_through_adj_equivalence_univalent_cats : Exponentials PD. Proof. induction CDeq. clear adjeq. assert (aux : PC = PD). 2: { rewrite <- aux. exact ExpC. } apply funextsec. intro c1. apply funextsec. intro c2. apply isaprop_BinProduct; exact Cuniv. Defined. End AlternativeWithUnivalence. (** Accessors for exponentials *) Section AccessorsExponentials. Context {C : category} {prodC : BinProducts C} (expC : Exponentials prodC). Definition exp (x y : C) : C := pr1 (expC x) y. Definition exp_eval (x y : C) : prodC x (exp x y) --> y := counit_from_are_adjoints (pr2 (expC x)) y. Definition exp_eval_alt (x y : C) : prodC (exp x y) x --> y := prod_swap prodC _ _ · exp_eval x y. Definition exp_lam {x y z : C} (f : prodC y x --> z) : x --> exp y z := unit_from_are_adjoints (pr2 (expC y)) x · # (pr1 (expC y)) f. Definition exp_lam_alt {x y z : C} (f : prodC z x --> y) : z --> exp x y := exp_lam (prod_swap prodC _ _ · f). Proposition exp_beta {x y z : C} (f : prodC y x --> z) : BinProductOfArrows _ _ _ (identity _) (exp_lam f) · exp_eval _ _ = f. Proof. unfold exp_lam. rewrite <- BinProductOfArrows_idxcomp. rewrite !assoc'. etrans. { apply maponpaths. exact (nat_trans_ax (counit_from_are_adjoints (pr2 (expC y))) _ _ f). } cbn. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. apply (triangle_id_left_ad (pr2 (expC y))). Qed. Proposition exp_beta_alt {x y z : C} (f : prodC z x --> y) : BinProductOfArrows _ _ _ (exp_lam_alt f) (identity x) · exp_eval_alt x y = f. Proof. unfold exp_eval_alt. rewrite !assoc. rewrite BinProductOfArrows_swap. unfold exp_lam_alt. rewrite !assoc'. rewrite exp_beta. rewrite !assoc. rewrite prod_swap_swap. apply id_left. Qed. Proposition exp_eta {x y z : C} (f : z --> exp x y) : f = exp_lam (BinProductOfArrows C _ _ (identity x) f · exp_eval x y). Proof. unfold exp_lam. rewrite functor_comp. rewrite !assoc. refine (!_). etrans. { apply maponpaths_2. exact (!(nat_trans_ax (unit_from_are_adjoints (pr2 (expC x))) _ _ f)). } refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. exact (triangle_id_right_ad (pr2 (expC x)) _). Qed. Proposition exp_eta_alt {x y z : C} (f : z --> exp x y) : f = exp_lam_alt (BinProductOfArrows C _ _ f (identity x) · exp_eval_alt x y). Proof. refine (exp_eta _ @ _). unfold exp_lam_alt. apply maponpaths. unfold exp_eval_alt. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite BinProductOfArrows_swap. rewrite !assoc. rewrite prod_swap_swap. rewrite id_left. apply idpath. Qed. Proposition exp_funext {x y z : C} {f g : z --> exp x y} (p : ∏ (a : C) (h : a --> x), BinProductOfArrows C _ (prodC a z) h f · exp_eval x y = BinProductOfArrows C _ (prodC a z) h g · exp_eval x y) : f = g. Proof. refine (exp_eta f @ _ @ !(exp_eta g)). apply maponpaths. apply p. Qed. Proposition exp_lam_natural {w x y z : C} (f : prodC y x --> z) (s : w --> x) : s · exp_lam f = exp_lam (BinProductOfArrows _ _ _ (identity _ ) s · f). Proof. use exp_funext. intros a h. etrans. { do 2 apply maponpaths_2. exact (!(id_right _)). } rewrite <- BinProductOfArrows_comp. rewrite !assoc'. rewrite exp_beta. refine (!_). etrans. { do 2 apply maponpaths_2. exact (!(id_right _)). } etrans. { apply maponpaths_2. apply maponpaths. exact (!(id_left _)). } rewrite <- BinProductOfArrows_comp. rewrite !assoc'. rewrite exp_beta. rewrite !assoc. apply maponpaths_2. rewrite BinProductOfArrows_comp. rewrite id_left, id_right. apply idpath. Qed. End AccessorsExponentials. UniMath-20231010/UniMath/CategoryTheory/limits/000077500000000000000000000000001451125700300211255ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/limits/BinDirectSums.v000066400000000000000000001124571451125700300240410ustar00rootroot00000000000000(** * Direct definition of binary direct sum using preadditive categories. *) (** ** Contents - Definition of binary direct sums (also known as biproducts) - Criteria for binary direct sums - Quotient has binary direct sums *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Monoids. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Local Open Scope cat. (** BinDirectSum is at the same time product and coproduct of the underlying objects together with the following equalities i1 · p1 = identity and i2 · p2 = identity i1 · p2 = unit and i2 · p1 = unit p1 · i1 + p2 · i2 = identity *) Lemma rewrite_op {A:PreAdditive} (x y:A) : @to_binop (categoryWithAbgrops_precategoryWithBinOps (PreAdditive_categoryWithAbgrops A)) x y = @op (pr1monoid (grtomonoid (abgrtogr (@to_abgr (PreAdditive_categoryWithAbgrops A) x y)))). Proof. reflexivity. Defined. Section def_bindirectsums. Variable A : PreAdditive. Context (hs := @to_has_homsets A : has_homsets A). Open Scope abgrcat. (** Definition of binary direct sum. *) Definition isBinDirectSum (a b co : A) (i1 : a --> co) (i2 : b --> co) (p1 : co --> a) (p2 : co --> b) : hProp := i1 · p1 = 1 ∧ i2 · p2 = 1 ∧ i1 · p2 = 0 ∧ i2 · p1 = 0 ∧ p1 · i1 + p2 · i2 = 1. Definition to_isBinCoproduct {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} : isBinDirectSum a b co i1 i2 p1 p2 -> isBinCoproduct A a b co i1 i2. Proof. intros [e11 [e22 [e12 [e21 e]]]]. intros T f g. use unique_exists. - exact ((p1 · f) + (p2 · g)). - cbn beta. split. + (* This is clumsy: should rewrite PreAdditive.v ! *) assert (q := to_premor_linear' i1 (p1 · f) (p2 · g)). rewrite 2 rewrite_op in q. rewrite q. clear q. rewrite 2 assoc. rewrite e11. rewrite id_left. rewrite e12. rewrite to_postmor_unel'. rewrite runax. reflexivity. + assert (q := to_premor_linear' i2 (p1 · f) (p2 · g)). rewrite 2 rewrite_op in q. rewrite q. clear q. rewrite 2 assoc. rewrite e22. rewrite id_left. rewrite e21. rewrite to_postmor_unel'. rewrite lunax. reflexivity. - intros h. cbn beta. apply isapropdirprod;apply hs. - intros h. cbn beta. intros [p q]. rewrite <- p, <- q. rewrite 2 assoc. assert (Q := to_postmor_linear' (p1 · i1) (p2 · i2) h). rewrite 2 rewrite_op in Q. rewrite <- Q. rewrite e. rewrite id_left. reflexivity. Defined. Definition to_isBinProduct {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} : isBinDirectSum a b co i1 i2 p1 p2 -> isBinProduct A a b co p1 p2. Proof. intros [e11 [e22 [e12 [e21 e]]]]. intros T f g. use unique_exists. - exact ((f · i1) + (g · i2)). - cbn beta. split. + assert (q := to_postmor_linear' (f · i1) (g · i2) p1). rewrite 2 rewrite_op in q. rewrite q. clear q. rewrite <- 2 assoc. rewrite e11. rewrite id_right. rewrite e21. rewrite to_premor_unel'. rewrite runax. reflexivity. + assert (q := to_postmor_linear' (f · i1) (g · i2) p2). rewrite 2 rewrite_op in q. rewrite q. clear q. rewrite <- 2 assoc. rewrite e22. rewrite id_right. rewrite e12. rewrite to_premor_unel'. rewrite lunax. reflexivity. - intros h. cbn beta. apply isapropdirprod;apply hs. - intros h. cbn beta. intros [p q]. rewrite <- p, <- q. rewrite <- 2 assoc. assert (Q := to_premor_linear' h (p1 · i1) (p2 · i2)). rewrite 2 rewrite_op in Q. rewrite <- Q. rewrite e. rewrite id_right. reflexivity. Defined. Definition to_IdIn1 {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum a b co i1 i2 p1 p2) : i1 · p1 = identity a := pr1 B. Definition to_IdIn2 {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum a b co i1 i2 p1 p2) : i2 · p2 = identity b := pr12 B. Definition to_Unel1 {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum a b co i1 i2 p1 p2) : i1 · p2 = (to_unel a b) := pr122 B. Definition to_Unel2 {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum a b co i1 i2 p1 p2) : i2 · p1 = (to_unel b a) := pr122 (pr2 B). Definition to_BinOpId {a b co : A} {i1 : a --> co} {i2 : b --> co} {p1 : co --> a} {p2 : co --> b} (B : isBinDirectSum a b co i1 i2 p1 p2) : (to_binop co co) (p1 · i1) (p2 · i2) = identity co := pr222 (pr2 B). (** The following definition constructs isBinDirectSum from data. *) Definition make_isBinDirectSum (a b co : A) (i1 : a --> co) (i2 : b --> co) (p1 : co --> a) (p2 : co --> b) (H1 : i1 · p1 = identity a) (H2 : i2 · p2 = identity b) (H3 : i1 · p2 = (to_unel a b)) (H4 : i2 · p1 = (to_unel b a)) (H5 : (to_binop co co) (p1 · i1) (p2 · i2) = identity co) : isBinDirectSum a b co i1 i2 p1 p2 := H1,,H2,,H3,,H4,,H5. (** Definition of BinDirectSums. *) Definition BinDirectSum (a b : A) : UU := ∑ coab : (∑ co : A, a --> co × b --> co × co --> a × co --> b), isBinDirectSum a b (pr1 coab) (pr1 (pr2 coab)) (pr1 (pr2 (pr2 coab))) (pr1 (pr2 (pr2 (pr2 coab)))) (pr2 (pr2 (pr2 (pr2 coab)))). (** Construction of BinDirectSum. *) Definition make_BinDirectSum (a b co : A) (i1 : a --> co) (i2 : b --> co) (p1 : co --> a) (p2 : co --> b) (H : isBinDirectSum a b co i1 i2 p1 p2) : BinDirectSum a b := tpair _ (tpair _ co (i1,,(i2,,(p1,,p2)))) H. (** BinDirectSum in categories. *) Definition BinDirectSums : UU := ∏ (a b : A), BinDirectSum a b. Definition make_BinDirectSums (H : ∏ (a b : A), BinDirectSum a b) : BinDirectSums := H. Definition hasBinDirectSums : hProp. Proof. exists (∏ (a b : A), ∥ BinDirectSum a b ∥). apply impred; intro p. apply impred; intro q. apply isapropishinh. Defined. (** The direct sum object. *) Definition BinDirectSumOb {a b : A} (B : BinDirectSum a b) : A := pr1 (pr1 B). Coercion BinDirectSumOb : BinDirectSum >-> ob. (** Accessor functions *) Definition to_In1 {a b : A} (B : BinDirectSum a b) : A⟦a, B⟧ := dirprod_pr1 (pr2 (pr1 B)). Definition to_In2 {a b : A} (B : BinDirectSum a b) : A⟦b, B⟧ := dirprod_pr1 (dirprod_pr2 (pr2 (pr1 B))). Definition to_Pr1 {a b : A} (B : BinDirectSum a b) : A⟦B, a⟧ := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (pr2 (pr1 B)))). Definition to_Pr2 {a b : A} (B : BinDirectSum a b) : A⟦B, b⟧ := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (pr2 (pr1 B)))). (** Another coercion *) Definition BinDirectSum_isBinDirectSum {a b : A} (B : BinDirectSum a b) : isBinDirectSum a b B (to_In1 B) (to_In2 B) (to_Pr1 B) (to_Pr2 B) := pr2 B. Coercion BinDirectSum_isBinDirectSum : BinDirectSum >-> hProptoType. (** Construction of BinCoproduct and BinProduct from BinDirectSum. *) Definition BinDirectSum_BinCoproduct {a b : A} (B : BinDirectSum a b) : BinCoproduct a b. Proof. use (make_BinCoproduct A a b B (to_In1 B) (to_In2 B)). exact (to_isBinCoproduct B). Defined. Definition BinDirectSum_BinProduct {a b : A} (B : BinDirectSum a b) : BinProduct A a b. Proof. use (make_BinProduct A a b B (to_Pr1 B) (to_Pr2 B)). exact (to_isBinProduct B). Defined. (** An arrow to BinDirectSum and arrow from BinDirectSum. *) Definition ToBinDirectSum {a b : A} (B : BinDirectSum a b) {c : A} (f : c --> a) (g : c --> b) : A⟦c, B⟧ := BinProductArrow A (BinDirectSum_BinProduct B) f g. Definition FromBinDirectSum {a b : A} (B : BinDirectSum a b) {c : A} (f : a --> c) (g : b --> c) : A⟦B, c⟧ := BinCoproductArrow (BinDirectSum_BinCoproduct B) f g. (** Commutativity of BinDirectSum. *) Definition BinDirectSumIn1Commutes {a b : A} (B : BinDirectSum a b) : ∏ (c : A) (f : a --> c) (g : b --> c), (to_In1 B) · (FromBinDirectSum B f g) = f. Proof. intros c f g. apply (BinCoproductIn1Commutes A a b (BinDirectSum_BinCoproduct B) c f g). Qed. Definition BinDirectSumIn2Commutes {a b : A} (B : BinDirectSum a b) : ∏ (c : A) (f : a --> c) (g : b --> c), (to_In2 B) · (FromBinDirectSum B f g) = g. Proof. intros c f g. apply (BinCoproductIn2Commutes A a b (BinDirectSum_BinCoproduct B) c f g). Qed. Definition BinDirectSumPr1Commutes {a b : A} (B : BinDirectSum a b) : ∏ (c : A) (f : c --> a) (g : c --> b), (ToBinDirectSum B f g) · (to_Pr1 B) = f. Proof. intros c f g. apply (BinProductPr1Commutes A a b (BinDirectSum_BinProduct B) c f g). Qed. Definition BinDirectSumPr2Commutes {a b : A} (B : BinDirectSum a b) : ∏ (c : A) (f : c --> a) (g : c --> b), (ToBinDirectSum B f g) · (to_Pr2 B) = g. Proof. intros c f g. apply (BinProductPr2Commutes A a b (BinDirectSum_BinProduct B) c f g). Qed. (** Uniqueness of arrow to and from BinDirectSum using the BinProduct and BinCoproduct structures. *) Definition ToBinDirectSumUnique {a b : A} (B : BinDirectSum a b) {c : A} (f : c --> a) (g : c --> b) (k : c --> B) : k · to_Pr1 B = f -> k · to_Pr2 B = g -> k = ToBinDirectSum B f g := BinProductArrowUnique _ _ _ (BinDirectSum_BinProduct B) c f g k. Definition FromBinDirectSumUnique {a b : A} (B : BinDirectSum a b) {c : A} (f : a --> c) (g : b --> c) (k : B --> c) : to_In1 B · k = f -> to_In2 B · k = g -> k = FromBinDirectSum B f g := BinCoproductArrowUnique _ _ _ (BinDirectSum_BinCoproduct B) c f g k. (** Uniqueness of arrows to and from BinDirectSum *) Lemma ToBinDirectSumsEq {c d : A} (DS : BinDirectSum c d) {x : A} (k1 k2 : x --> DS) : k1 · to_Pr1 DS = k2 · to_Pr1 DS -> k1 · to_Pr2 DS = k2 · to_Pr2 DS -> k1 = k2. Proof. intros H1 H2. rewrite (ToBinDirectSumUnique DS (k1 · to_Pr1 DS) (k1 · to_Pr2 DS) k1). apply pathsinv0. apply ToBinDirectSumUnique. - apply pathsinv0. apply H1. - apply pathsinv0. apply H2. - apply idpath. - apply idpath. Qed. Lemma FromBinDirectSumsEq {c d : A} (DS : BinDirectSum c d) {x : A} (k1 k2 : DS --> x) : to_In1 DS · k1 = to_In1 DS · k2 -> to_In2 DS · k1 = to_In2 DS · k2 -> k1 = k2. Proof. intros H1 H2. rewrite (FromBinDirectSumUnique DS (to_In1 DS · k1) (to_In2 DS · k1) k1). apply pathsinv0. apply FromBinDirectSumUnique. - apply pathsinv0. apply H1. - apply pathsinv0. apply H2. - apply idpath. - apply idpath. Qed. (** The following definitions give a formula for the unique morphisms to and from the BinDirectSum. These formulas are important when one uses bindirectsums. The formulas are to bindirectsum unique arrow = f · in1 + g · in2 from bindirectsum unique arrow = pr1 · f + pr2 · g *) Definition ToBinDirectSumFormula {a b : A} (B : BinDirectSum a b) {c : A} (f : c --> a) (g : c --> b) : A⟦c, B⟧ := (to_binop c B) (f · to_In1 B) (g · to_In2 B). Definition FromBinDirectSumFormula {a b : A} (B : BinDirectSum a b) {c : A} (f : a --> c) (g : b --> c) : A⟦B, c⟧ := (to_binop B c) (to_Pr1 B · f) (to_Pr2 B · g). (** Let us prove that these formulas indeed are the unique morphisms we claimed them to be. *) Lemma ToBinDirectSumFormulaUnique {a b : A} (B : BinDirectSum a b) {c : A} (f : c --> a) (g : c --> b) : ToBinDirectSumFormula B f g = ToBinDirectSum B f g. Proof. apply ToBinDirectSumUnique. - unfold ToBinDirectSumFormula. unfold to_binop. use (pathscomp0 (to_postmor_linear c (to_Pr1 B) (f · to_In1 B) (g · to_In2 B))). unfold to_postmor. repeat rewrite <- assoc. rewrite (to_IdIn1 B). rewrite id_right. rewrite (to_Unel2 B). set (XX := to_premor_unel A a g). unfold to_premor in XX. unfold to_unel. rewrite XX. apply (to_runax c a). - unfold ToBinDirectSumFormula. unfold to_binop. cbn. use (pathscomp0 (to_postmor_linear c (to_Pr2 B) (f · to_In1 B) (g · to_In2 B))). unfold to_postmor. repeat rewrite <- assoc. rewrite (to_IdIn2 B). rewrite (to_Unel1 B). rewrite id_right. set (XX := to_premor_unel A b f). unfold PrecategoriesWithAbgrops.to_premor in XX. unfold PrecategoriesWithAbgrops.to_unel. rewrite XX. clear XX. apply (to_lunax c b). Qed. Lemma FromBinDirectSumFormulaUnique {a b : A} (B : BinDirectSum a b) {c : A} (f : a --> c) (g : b --> c) : FromBinDirectSumFormula B f g = FromBinDirectSum B f g. Proof. unfold FromBinDirectSumFormula. apply FromBinDirectSumUnique. - use (pathscomp0 (to_premor_linear c (to_In1 B) (to_Pr1 B · f) (to_Pr2 B · g))). unfold to_premor. repeat rewrite assoc. rewrite (to_IdIn1 B). rewrite (to_Unel1 B). rewrite id_left. set (XX := to_postmor_unel A a g). unfold to_postmor in XX. unfold to_unel. rewrite XX. apply (to_runax a c). - use (pathscomp0 (to_premor_linear c (to_In2 B) (to_Pr1 B · f) (to_Pr2 B · g))). unfold to_premor. repeat rewrite assoc. rewrite (to_IdIn2 B). rewrite (to_Unel2 B). rewrite id_left. set (XX := to_postmor_unel A b f). unfold to_postmor in XX. unfold to_unel. rewrite XX. apply (to_lunax b c). Qed. (** The following definitions give 2 ways to construct a morphisms a ⊕ c --> b ⊕ d from two morphisms f : a --> b and g : c --> d , by using the binary direct sums as a product and as a coproduct. *) Definition BinDirectSumIndAr {a b c d : A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : A⟦B1, B2⟧ := ToBinDirectSum B2 ((to_Pr1 B1) · f) ((to_Pr2 B1) · g). Definition BinDirectSumIndAr' {a b c d : A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : A⟦B1, B2⟧ := FromBinDirectSum B1 (f · (to_In1 B2)) (g · (to_In2 B2)). (** Both of the above morphisms are given by the following formula. *) Definition BinDirectSumIndArFormula {a b c d: A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : A⟦B1, B2⟧ := (to_binop B1 B2) (to_Pr1 B1 · f · to_In1 B2) (to_Pr2 B1 · g · to_In2 B2). Lemma BinDirectSumIndArEq1 {a b c d : A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : BinDirectSumIndAr f g B1 B2 = BinDirectSumIndArFormula f g B1 B2. Proof. unfold BinDirectSumIndAr. rewrite <- ToBinDirectSumFormulaUnique. unfold ToBinDirectSumFormula. unfold BinDirectSumIndArFormula. apply idpath. Qed. Lemma BinDirectSumIndArEq2 {a b c d : A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : BinDirectSumIndAr' f g B1 B2 = BinDirectSumIndArFormula f g B1 B2. Proof. unfold BinDirectSumIndAr'. rewrite <- FromBinDirectSumFormulaUnique. unfold FromBinDirectSumFormula. unfold BinDirectSumIndArFormula. rewrite assoc. rewrite assoc. apply idpath. Qed. (** Thus we have equality. *) Definition BinDirectSumIndArEq {a b c d : A} (f : a --> b) (g : c --> d) (B1 : BinDirectSum a c) (B2 : BinDirectSum b d) : BinDirectSumIndAr f g B1 B2 = BinDirectSumIndAr' f g B1 B2. Proof. rewrite -> BinDirectSumIndArEq1. rewrite -> BinDirectSumIndArEq2. apply idpath. Qed. (** ** Composition of IndAr *) Lemma BinDirectSumIndArComp {a b c d e f : A} (f1 : a --> b) (f2 : b --> c) (g1 : d --> e) (g2 : e --> f) (B1 : BinDirectSum a d) (B2 : BinDirectSum b e) (B3 : BinDirectSum c f) : BinDirectSumIndAr f1 g1 B1 B2 · BinDirectSumIndAr f2 g2 B2 B3 = BinDirectSumIndAr (f1 · f2) (g1 · g2) B1 B3. Proof. rewrite BinDirectSumIndArEq1. rewrite (BinDirectSumIndArEq1 f2). rewrite (BinDirectSumIndArEq1 (f1 · f2)). unfold BinDirectSumIndArFormula. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 B2)). rewrite <- (assoc _ (to_In1 B2)). rewrite (to_IdIn1 B2). rewrite id_right. rewrite (to_Unel1 B2). rewrite to_premor_unel'. rewrite to_postmor_unel'. rewrite to_postmor_unel'. rewrite to_runax'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In2 B2)). rewrite <- (assoc _ (to_In2 B2)). rewrite (to_IdIn2 B2). rewrite id_right. rewrite (to_Unel2 B2). rewrite to_premor_unel'. rewrite to_postmor_unel'. rewrite to_postmor_unel'. rewrite to_lunax'. apply idpath. Qed. End def_bindirectsums. Arguments BinDirectSumIndAr {_ _ _ _ _}. Arguments BinDirectSumOb {_ _ _}. Arguments BinDirectSum {_}. Arguments to_Pr1 {_ _ _} _. Arguments to_Pr2 {_ _ _} _. Arguments to_In1 {_ _ _} _. Arguments to_In2 {_ _ _} _. Arguments to_BinOpId {_ _ _ _ _ _ _ _}. Arguments to_IdIn1 {_ _ _ _ _ _ _ _}. Arguments to_IdIn2 {_ _ _ _ _ _ _ _}. Arguments to_Unel1 {_ _ _ _ _ _ _ _}. Arguments to_Unel2 {_ _ _ _ _ _ _ _}. Arguments ToBinDirectSum {_ _ _} _ {_}. Arguments isBinDirectSum {_ _ _ _}. (** In1 and In2 are monics, and Pr1 and Pr2 are epis. *) Section bindirectsums_monics_and_epis. Variable A : PreAdditive. Lemma to_In1_isMonic {a b : A} (B : BinDirectSum a b) : isMonic (to_In1 B). Proof. intros z f g H. apply (maponpaths (λ h : _, h · (to_Pr1 B))) in H. repeat rewrite <- assoc in H. set (X:= to_IdIn1 (A:=A) B). assert (X1 : to_In1 B · to_Pr1 B = 1%abgrcat). { apply (to_IdIn1 (A:=A) B). } apply (@pathscomp0 _ _ ( f · (to_In1 B · to_Pr1 B)) _). - apply pathsinv0. etrans. { apply maponpaths. apply X1. } apply id_right. - etrans. { apply H. } etrans. { apply maponpaths. apply X1. } apply id_right. Qed. Lemma to_In2_isMonic {a b : A} (B : BinDirectSum a b) : isMonic (to_In2 B). Proof. intros z f g H. apply (maponpaths (λ h : _, h · (to_Pr2 B))) in H. repeat rewrite <- assoc in H. set (X:= to_IdIn2 (A:=A) B). assert (X1 : to_In2 B · to_Pr2 B = 1%abgrcat). { apply X. } apply (@pathscomp0 _ _ ( f · (to_In2 B · to_Pr2 B)) _). - apply pathsinv0. etrans. { apply maponpaths. apply X1. } apply id_right. - etrans. { apply H. } etrans. { apply maponpaths. apply X1. } apply id_right. Qed. Lemma to_Pr1_isEpi {a b : A} (B : BinDirectSum a b) : isEpi (to_Pr1 B). Proof. intros z f g H. apply (maponpaths (λ h : _, (to_In1 B) · h)) in H. repeat rewrite assoc in H. rewrite (to_IdIn1 B) in H. repeat rewrite id_left in H. apply H. Qed. Lemma to_Pr2_isEpi {a b : A} (B : BinDirectSum a b) : isEpi (to_Pr2 B). Proof. intros z f g H. apply (maponpaths (λ h : _, (to_In2 B) · h)) in H. repeat rewrite assoc in H. rewrite (to_IdIn2 B) in H. repeat rewrite id_left in H. apply H. Qed. End bindirectsums_monics_and_epis. (** If a PreAdditive category has BinProducts, then it has all direct sums. *) Section bindirectsums_criteria. Variable A : PreAdditive. Hypothesis hs : has_homsets A. Variable Z : Zero A. Definition BinDirectSums_from_binproduct_bincoproducts_eq1 {X Y : A} (P : BinProduct A X Y) : BinProductArrow A P (identity X) (ZeroArrow Z X Y) · BinProductPr1 A P = identity _ . Proof. apply BinProductPr1Commutes. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_eq2 {X Y : A} (P : BinProduct A X Y) : BinProductArrow A P (identity X) (ZeroArrow Z X Y) · BinProductPr2 A P = to_unel X Y. Proof. rewrite (PreAdditive_unel_zero A Z). apply BinProductPr2Commutes. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_eq3 {X Y : A} (P : BinProduct A X Y) : BinProductArrow A P (ZeroArrow Z Y X) (identity _ ) · BinProductPr1 A P = to_unel Y X. Proof. rewrite (PreAdditive_unel_zero A Z). apply BinProductPr1Commutes. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_eq4 {X Y : A} (P : BinProduct A X Y) : BinProductArrow A P (ZeroArrow Z Y X) (identity _ ) · BinProductPr2 A P = identity _ . Proof. apply BinProductPr2Commutes. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_eq5 {X Y : A} (P : BinProduct A X Y) : to_binop (BinProductObject A P) (BinProductObject A P) (BinProductPr1 A P · BinProductArrow A P(identity X) (ZeroArrow Z X Y)) (BinProductPr2 A P · BinProductArrow A P (ZeroArrow Z Y X) (identity Y)) = identity _ . Proof. apply BinProductArrowsEq. - rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr1Commutes. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite <- PreAdditive_unel_zero. rewrite id_left. apply to_runax. - rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite BinProductPr2Commutes. rewrite BinProductPr2Commutes. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite <- PreAdditive_unel_zero. rewrite id_left. apply to_lunax. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_isCoproduct {X Y : A} (P : BinProduct A X Y) : isBinCoproduct A X Y (BinProductObject A P) (BinProductArrow A P (identity X) (ZeroArrow Z X Y)) (BinProductArrow A P (ZeroArrow Z Y X) (identity Y)). Proof. use (make_isBinCoproduct _ hs). intros c f g. use unique_exists. - exact (to_binop (BinProductObject A P) c (BinProductPr1 A P · f) (BinProductPr2 A P · g)). - split. + rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. rewrite ZeroArrow_comp_left. rewrite id_left. rewrite <- PreAdditive_unel_zero. apply to_runax. + rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. rewrite ZeroArrow_comp_left. rewrite id_left. rewrite <- PreAdditive_unel_zero. apply to_lunax. - intros y. apply isapropdirprod. apply hs. apply hs. - intros y H. induction H as [t p]. rewrite <- t. rewrite <- p. rewrite assoc. rewrite assoc. rewrite <- to_postmor_linear'. rewrite (BinDirectSums_from_binproduct_bincoproducts_eq5 P). rewrite id_left. apply idpath. Qed. Definition BinDirectSums_from_binproduct_bincoproducts_isProduct {X Y : A} (P : BinProduct A X Y) : isBinProduct A X Y (BinProductObject A P) (BinProductPr1 A P) (BinProductPr2 A P). Proof. use (make_isBinProduct _ ). intros c f g. use unique_exists. - exact (BinProductArrow A P f g). - split. + apply BinProductPr1Commutes. + apply BinProductPr2Commutes. - intros y. apply isapropdirprod. + apply hs. + apply hs. - intros y H. induction H as [t p]. rewrite <- t. rewrite <- p. rewrite <- precompWithBinProductArrow. apply BinProductArrowsEq. + rewrite <- assoc. rewrite BinProductPr1Commutes. apply idpath. + rewrite <- assoc. rewrite BinProductPr2Commutes. apply idpath. Qed. Definition BinDirectSum_from_BinProduct {X Y : A} (P : BinProduct A X Y) : BinDirectSum X Y := make_BinDirectSum A X Y (BinProductObject A P) (BinProductArrow A P (identity X) (ZeroArrow Z X Y)) (BinProductArrow A P (ZeroArrow Z Y X) (identity Y)) (BinProductPr1 A P) (BinProductPr2 A P) (make_isBinDirectSum _ _ _ _ _ _ _ _ (BinDirectSums_from_binproduct_bincoproducts_eq1 P) (BinDirectSums_from_binproduct_bincoproducts_eq4 P) (BinDirectSums_from_binproduct_bincoproducts_eq2 P) (BinDirectSums_from_binproduct_bincoproducts_eq3 P) (BinDirectSums_from_binproduct_bincoproducts_eq5 P)). Definition BinDirectSums_from_BinProducts (BinProds : BinProducts A) : BinDirectSums A. Proof. intros X Y. exact (BinDirectSum_from_BinProduct (BinProds X Y)). Defined. End bindirectsums_criteria. (** * BinDirectSums in quotient of PreAdditive category In this section we show that, if a PreAdditive A has BinDirectSums, then the quotient of the preadditive category has BinDirectSums. This is used to show that quotient of an CategoryWithAdditiveStructure is CategoryWithAdditiveStructure. *) Section bindirectsums_in_quot. Variable A : PreAdditive. Hypothesis Z : Zero A. Hypothesis BD : BinDirectSums A. Hypothesis PAS : PreAdditiveSubabgrs A. Hypothesis PAC : PreAdditiveComps A PAS. Lemma Quotcategory_isBinCoproduct (x y : A) : isBinCoproduct (Quotcategory_PreAdditive A PAS PAC) x y (BD x y) (to_quot_mor A PAS (to_In1 (BD x y))) (to_quot_mor A PAS (to_In2 (BD x y))). Proof. use make_isBinCoproduct. - apply has_homsets_Quotcategory. - intros c f g. set (f'' := @issurjsetquotpr (@to_abgr A x c) (binopeqrel_subgr_eqrel (PAS x c)) f). use (squash_to_prop f''). apply isapropiscontr. intros f'. clear f''. set (g'' := @issurjsetquotpr (@to_abgr A y c) (binopeqrel_subgr_eqrel (PAS y c)) g). use (squash_to_prop g''). apply isapropiscontr. intros g'. clear g''. induction f' as [f1 f2]. induction g' as [g1 g2]. cbn in f1, g1. use unique_exists. + exact (to_quot_mor A PAS (FromBinDirectSum A (BD x y) f1 g1)). + cbn beta. split. * use (pathscomp0 (Quotcategory_comp_linear A PAS PAC _ _)). rewrite BinDirectSumIn1Commutes. exact f2. * use (pathscomp0 (Quotcategory_comp_linear A PAS PAC _ _)). rewrite BinDirectSumIn2Commutes. exact g2. + intros y0. apply isapropdirprod; apply has_homsets_Quotcategory. + intros y0 T. cbn beta in T. induction T as [T1 T2]. * set (y'' := @issurjsetquotpr (@to_abgr A (BD x y) c) (binopeqrel_subgr_eqrel (PAS (BD x y) c)) y0). use (squash_to_prop y''). apply has_homsets_Quotcategory. intros y'. clear y''. induction y' as [y1 y2]. rewrite <- y2. rewrite <- y2 in T1. rewrite <- y2 in T2. cbn in y1. rewrite <- (@id_left (Quotcategory_PreAdditive A PAS PAC) _ _ (setquotpr (binopeqrel_subgr_eqrel (PAS (BD x y) c)) y1)). rewrite <- (@id_left A _ _ (FromBinDirectSum A (BD x y) f1 g1)). rewrite <- (to_BinOpId (BD x y)). rewrite to_postmor_linear'. repeat rewrite <- assoc. rewrite BinDirectSumIn1Commutes. rewrite BinDirectSumIn2Commutes. rewrite <- f2 in T1. rewrite <- g2 in T2. unfold to_quot_mor. set (tmp := @setquotpr_linear A PAS PAC (BD x y) c). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) x c). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite <- T1. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) y c). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite <- T2. unfold to_quot_mor. rewrite comp_eq. rewrite comp_eq. rewrite assoc. rewrite assoc. rewrite <- to_postmor_linear'. repeat rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) x (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) y (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @setquotpr_linear A PAS PAC (BD x y) (BD x y)). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite comp_eq. rewrite (to_BinOpId (BD x y)). rewrite comp_eq. apply cancel_postcomposition. apply idpath. Qed. Lemma Quotcategory_isBinProduct (x y : A) : isBinProduct (Quotcategory_PreAdditive A PAS PAC) x y (BD x y) (to_quot_mor A PAS (to_Pr1 (BD x y))) (to_quot_mor A PAS (to_Pr2 (BD x y))). Proof. use make_isBinProduct. - intros c f g. set (f'' := @issurjsetquotpr (@to_abgr A c x) (binopeqrel_subgr_eqrel (PAS c x)) f). use (squash_to_prop f''). apply isapropiscontr. intros f'. clear f''. set (g'' := @issurjsetquotpr (@to_abgr A c y) (binopeqrel_subgr_eqrel (PAS c y)) g). use (squash_to_prop g''). apply isapropiscontr. intros g'. clear g''. induction f' as [f1 f2]. induction g' as [g1 g2]. cbn in f1, g1. use unique_exists. + exact (to_quot_mor A PAS (ToBinDirectSum (BD x y) f1 g1)). + cbn beta. split. * use (pathscomp0 (Quotcategory_comp_linear A PAS PAC _ _)). rewrite BinDirectSumPr1Commutes. exact f2. * use (pathscomp0 (Quotcategory_comp_linear A PAS PAC _ _)). rewrite BinDirectSumPr2Commutes. exact g2. + intros y0. apply isapropdirprod; apply has_homsets_Quotcategory. + intros y0 T. cbn beta in T. induction T as [T1 T2]. * set (y'' := @issurjsetquotpr (@to_abgr A c (BD x y)) (binopeqrel_subgr_eqrel (PAS c (BD x y))) y0). use (squash_to_prop y''). apply has_homsets_Quotcategory. intros y'. clear y''. induction y' as [y1 y2]. rewrite <- y2. rewrite <- y2 in T1. rewrite <- y2 in T2. cbn in y1. rewrite <- (@id_right (Quotcategory_PreAdditive A PAS PAC) _ _ (setquotpr (binopeqrel_subgr_eqrel (PAS c (BD x y))) y1)). rewrite <- (@id_right A _ _ (ToBinDirectSum (BD x y) f1 g1)). rewrite <- (to_BinOpId (BD x y)). rewrite to_premor_linear'. repeat rewrite assoc. rewrite BinDirectSumPr1Commutes. rewrite BinDirectSumPr2Commutes. rewrite <- f2 in T1. rewrite <- g2 in T2. unfold to_quot_mor. set (tmp := @setquotpr_linear A PAS PAC c (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @Quotcategory_comp_linear A PAS PAC c x (BD x y)). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite <- T1. set (tmp := @Quotcategory_comp_linear A PAS PAC c y (BD x y)). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite <- T2. unfold to_quot_mor. rewrite comp_eq. rewrite comp_eq. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. repeat rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) x (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) y (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @setquotpr_linear A PAS PAC (BD x y) (BD x y)). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite comp_eq. rewrite (to_BinOpId (BD x y)). rewrite comp_eq. apply cancel_precomposition. apply idpath. Qed. Opaque Quotcategory_PreAdditive. (* This speeds up the following proof significantly. *) Lemma Quotcategory_isBinDirectSum (x y : A) : isBinDirectSum (A := Quotcategory_PreAdditive A PAS PAC) (to_quot_mor A PAS (to_In1 (BD x y))) (to_quot_mor A PAS (to_In2 (BD x y))) (to_quot_mor A PAS (to_Pr1 (BD x y))) (to_quot_mor A PAS (to_Pr2 (BD x y))). Proof. use make_isBinDirectSum. - unfold to_quot_mor. rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC x (BD x y) x). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. rewrite (to_IdIn1 (BD x y)). apply idpath. - unfold to_quot_mor. rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC y (BD x y) y). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. rewrite (to_IdIn2 (BD x y)). apply idpath. - unfold to_quot_mor. rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC x (BD x y) y). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. rewrite (to_Unel1 (BD x y)). apply idpath. - unfold to_quot_mor. rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC y (BD x y) x). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. rewrite (to_Unel2 (BD x y)). apply idpath. - unfold to_quot_mor. repeat rewrite <- comp_eq. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) x (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @Quotcategory_comp_linear A PAS PAC (BD x y) y (BD x y)). unfold to_quot_mor in tmp. rewrite tmp. clear tmp. set (tmp := @setquotpr_linear A PAS PAC (BD x y) (BD x y)). unfold to_quot_mor in tmp. rewrite <- tmp. clear tmp. rewrite (to_BinOpId (BD x y)). apply idpath. Qed. Transparent Quotcategory_PreAdditive. (* Transparent again *) Definition Quotcategory_BinDirectSums : BinDirectSums (Quotcategory_PreAdditive A PAS PAC). Proof. intros x y. use make_BinDirectSum. - exact (BD x y). - exact (to_quot_mor A PAS (to_In1 (BD x y))). - exact (to_quot_mor A PAS (to_In2 (BD x y))). - exact (to_quot_mor A PAS (to_Pr1 (BD x y))). - exact (to_quot_mor A PAS (to_Pr2 (BD x y))). - exact (Quotcategory_isBinDirectSum x y). Defined. End bindirectsums_in_quot. Notation "'π₁'" := (to_Pr1 _) : abgrcat. Notation "'π₂'" := (to_Pr2 _) : abgrcat. Notation "'ι₁'" := (to_In1 _) : abgrcat. Notation "'ι₂'" := (to_In2 _) : abgrcat. Local Open Scope abgrcat. Definition reverseBinDirectSum {M:PreAdditive} {A B:M} : BinDirectSum A B -> BinDirectSum B A. Proof. intros AB. refine (make_BinDirectSum M B A (BinDirectSumOb AB) ι₂ ι₁ π₂ π₁ _). unfold isBinDirectSum. exists (to_IdIn2 (pr2 AB)). exists (to_IdIn1 (pr2 AB)). exists (to_Unel2 (pr2 AB)). exists (to_Unel1 (pr2 AB)). cbn. rewrite rewrite_op. (* goal is now π₂ · ι₂ + π₁ · ι₁ = 1 *) exact (commax (to_abgr _ _) _ _ @ to_BinOpId (pr2 AB)). Defined. Definition oppositeBinDirectSum {M:PreAdditive} {x y:M} : BinDirectSum x y -> BinDirectSum (A:=oppositePreAdditive M) x y. Proof. intros Q. use make_BinDirectSum. + exact (BinDirectSumOb Q). + exact (to_Pr1 Q). + exact (to_Pr2 Q). + exact (to_In1 Q). + exact (to_In2 Q). + exact (make_isBinDirectSum (oppositePreAdditive M) _ _ _ _ _ _ _ (to_IdIn1 Q) (to_IdIn2 Q) (to_Unel2 Q) (to_Unel1 Q) (to_BinOpId Q)). Defined. Definition isTrivialDirectSum {M : PreAdditive} (Z:Zero M) (A:M) : @isBinDirectSum M A Z A 1 0 1 0. Proof. repeat split; cbn. - apply id_right. - apply ArrowsToZero. - apply ArrowsToZero. - apply ArrowsFromZero. - rewrite id_right. rewrite to_premor_unel'. rewrite rewrite_op. rewrite runax. reflexivity. Qed. Definition TrivialDirectSum {M : PreAdditive} (Z:Zero M) (A:M) : BinDirectSum A Z. Proof. exact (make_BinDirectSum _ _ _ _ _ _ _ _ (isTrivialDirectSum _ _)). Defined. Definition isTrivialDirectSum' {M : PreAdditive} (Z:Zero M) (A:M) : @isBinDirectSum M Z A A 0 1 0 1. Proof. repeat split; cbn. - apply ArrowsToZero. - apply id_right. - apply ArrowsFromZero. - apply ArrowsToZero. - rewrite id_right. rewrite to_premor_unel'. rewrite rewrite_op. rewrite lunax. reflexivity. Qed. Definition TrivialDirectSum' {M : PreAdditive} (Z:Zero M) (A:M) : BinDirectSum Z A. Proof. exact (make_BinDirectSum _ _ _ _ _ _ _ _ (isTrivialDirectSum' _ _)). Defined. Definition replaceSum {M:PreAdditive} {A B C:M} (S:BinDirectSum A B) : z_iso C S -> BinDirectSum A B (* with C judgmentally equal to the sum object *). Proof. intros r. exists (C,, ι₁ · z_iso_inv r,, ι₂ · z_iso_inv r,, r · π₁,, r · π₂). repeat split; cbn. + rewrite assoc'. rewrite (assoc _ r). rewrite z_iso_after_z_iso_inv, id_left. exact (to_IdIn1 S). + rewrite assoc'. rewrite (assoc _ r). rewrite z_iso_after_z_iso_inv, id_left. exact (to_IdIn2 S). + rewrite assoc'. rewrite (assoc _ r). rewrite z_iso_after_z_iso_inv, id_left. exact (to_Unel1 S). + rewrite assoc'. rewrite (assoc _ r). rewrite z_iso_after_z_iso_inv, id_left. exact (to_Unel2 S). + rewrite rewrite_op. rewrite 2 (assoc' r). rewrite 4 (assoc _ _ (inv_from_z_iso r)). rewrite <- leftDistribute. rewrite <- rightDistribute. rewrite wrap_inverse'. * reflexivity. * exact (to_BinOpId S). Defined. Lemma DirectSumIn1Pr2 {M:PreAdditive} {a b:M} (S:BinDirectSum a b) : to_In1 S · to_Pr2 S = 0. Proof. exact (to_Unel1 S). Defined. Lemma DirectSumIn2Pr1 {M:PreAdditive} {a b:M} (S:BinDirectSum a b) : to_In2 S · to_Pr1 S = 0. Proof. exact (to_Unel2 S). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/Ends.v000066400000000000000000000244431451125700300222140ustar00rootroot00000000000000(************************************************************** Ends Ends are a special kind of limit, namely a limit over a bifunctor that is contravariant in its first argument and covariant in its second argument. In this file, we define the notion of ends, and show that ends can be constructed from products and equalizers. Contents 1. Wedges 2. Ends 3. Accessors for ends 4. Construction of ends from products and equalizers **************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Section Ends. Context {C D : category} (F : category_binproduct (C^opp) C ⟶ D). (** 1. Wedges *) Definition wedge_data : UU := ∑ (w : D), ∏ (x : C), w --> F (x ,, x). Coercion ob_of_wedge (w : wedge_data) : D := pr1 w. Definition mor_of_wedge (w : wedge_data) (x : C) : w --> F (x ,, x) := pr2 w x. Definition make_wedge_data (w : D) (fs : ∏ (x : C), w --> F (x ,, x)) : wedge_data := w ,, fs. Definition is_wedge (w : wedge_data) : UU := ∏ (x y : C) (g : x --> y), mor_of_wedge w x · #F (catbinprodmor (identity _) g) = mor_of_wedge w y · #F (catbinprodmor g (identity _)). Definition wedge : UU := ∑ (w : wedge_data), is_wedge w. Coercion wedge_data_of_wedge (w : wedge) : wedge_data := pr1 w. Proposition eq_of_wedge (w : wedge) {x y : C} (g : x --> y) : mor_of_wedge w x · #F (catbinprodmor (identity _) g) = mor_of_wedge w y · #F (catbinprodmor g (identity _)). Proof. exact (pr2 w x y g). Qed. Definition make_wedge (w : wedge_data) (p : is_wedge w) : wedge := w ,, p. Definition precomp_wedge_data {a : D} (w : wedge) (f : a --> w) : wedge_data. Proof. use make_wedge_data. - exact a. - exact (λ x, f · mor_of_wedge w x). Defined. Proposition precomp_is_wedge {a : D} (w : wedge) (f : a --> w) : is_wedge (precomp_wedge_data w f). Proof. intros x y g ; cbn. rewrite !assoc'. rewrite eq_of_wedge. apply idpath. Qed. Definition precomp_wedge {a : D} (w : wedge) (f : a --> w) : wedge. Proof. use make_wedge. - exact (precomp_wedge_data w f). - exact (precomp_is_wedge w f). Defined. Definition is_wedge_map {w₁ w₂ : wedge} (f : w₁ --> w₂) : UU := ∏ (x : C), f · mor_of_wedge w₂ x = mor_of_wedge w₁ x. Definition wedge_map (w₁ w₂ : wedge) : UU := ∑ (f : w₁ --> w₂), is_wedge_map f. Coercion mor_of_wedge_map {w₁ w₂ : wedge} (f : wedge_map w₁ w₂) : w₁ --> w₂ := pr1 f. Proposition eq_of_wedge_map {w₁ w₂ : wedge} (f : wedge_map w₁ w₂) (x : C) : f · mor_of_wedge w₂ x = mor_of_wedge w₁ x. Proof. exact (pr2 f x). Qed. Definition make_wedge_map {w₁ w₂ : wedge} (f : w₁ --> w₂) (p : is_wedge_map f) : wedge_map w₁ w₂ := f ,, p. Proposition wedge_map_eq {w₁ w₂ : wedge} {f₁ f₂ : wedge_map w₁ w₂} (p : (f₁ : w₁ --> w₂) = f₂) : f₁ = f₂. Proof. use subtypePath. { intro. use impred. intro. apply homset_property. } exact p. Qed. (** 2. Ends *) Definition is_end (w : wedge) : UU := ∏ (w' : wedge), iscontr (wedge_map w' w). Proposition isaprop_is_end (w : wedge) : isaprop (is_end w). Proof. use impred ; intro. apply isapropiscontr. Qed. Definition end_limit : UU := ∑ (w : wedge), is_end w. Coercion end_limit_to_wedge (e : end_limit) : wedge := pr1 e. Definition is_end_end_limit (e : end_limit) : is_end e := pr2 e. (** 3. Accessors for ends *) Section EndAccessors. Context {w : wedge} (Hw : is_end w). Definition mor_to_end (w' : wedge) : w' --> w := pr1 (Hw w'). Definition mor_to_end' (w' : D) (fs : ∏ (x : C), w' --> F (x ,, x)) (H : is_wedge (make_wedge_data w' fs)) : w' --> w := mor_to_end (make_wedge _ H). Proposition mor_to_end_comm (w' : wedge) (x : C) : mor_to_end w' · mor_of_wedge w x = mor_of_wedge w' x. Proof. exact (eq_of_wedge_map (pr1 (Hw w')) x). Qed. Proposition mor_to_end'_comm (w' : D) (fs : ∏ (x : C), w' --> F (x ,, x)) (H : is_wedge (make_wedge_data w' fs)) (x : C) : mor_to_end' w' fs H · mor_of_wedge w x = fs x. Proof. exact (mor_to_end_comm (make_wedge _ H) x). Qed. Section MorToEndEq. Context (a : D) {f g : a --> w} (p : ∏ (x : C), f · mor_of_wedge w x = g · mor_of_wedge w x). Let a_wedge : wedge := precomp_wedge w g. Let f_map : wedge_map a_wedge w := @make_wedge_map a_wedge w f p. Let g_map : wedge_map a_wedge w := @make_wedge_map a_wedge w g (λ _, idpath _). Proposition mor_to_end_eq : f = g. Proof. exact (maponpaths pr1 (proofirrelevance _ (isapropifcontr (Hw a_wedge)) f_map g_map)). Qed. End MorToEndEq. End EndAccessors. (** 4. Construction of ends from products and equalizers *) Section ConstructionOfEnds. Context (EqD : Equalizers D) (PD : Products C D) (PDM : Products (∑ (x : C) (y : C), x --> y) D). Let ProdF : Product C D (λ x : C, F (x,, x)) := PD (λ x, F (x ,, x)). Let ProdM : Product _ D (λ f, F (pr1 f ,, pr12 f)) := PDM (λ f, F (pr1 f ,, pr12 f)). Definition end_left_map : ProdF --> ProdM. Proof. use ProductArrow. intro f ; cbn. refine (ProductPr _ _ _ (pr1 f) · #F (_ ,, _)). - exact (identity _). - exact (pr22 f). Defined. Definition end_right_map : ProdF --> ProdM. Proof. use ProductArrow. intro f ; cbn. refine (ProductPr _ _ _ (pr12 f) · #F (_ ,, _)). - exact (pr22 f). - exact (identity _). Defined. Definition construction_of_ends_ob : Equalizer end_left_map end_right_map := EqD _ _ end_left_map end_right_map. Definition construction_of_ends_pr (x : C) : construction_of_ends_ob --> F (x ,, x) := EqualizerArrow _ · ProductPr _ _ _ x. Definition construction_of_ends_wedge_data : wedge_data. Proof. use make_wedge_data. - exact construction_of_ends_ob. - exact construction_of_ends_pr. Defined. Proposition construction_of_ends_wedge_laws : is_wedge construction_of_ends_wedge_data. Proof. intros x y f. cbn ; unfold construction_of_ends_pr. rewrite !assoc'. pose (maponpaths (λ z, z · ProductPr _ _ _ (x ,, (y ,, f))) (EqualizerEqAr construction_of_ends_ob)) as p. cbn in p. rewrite !assoc' in p. unfold end_left_map, end_right_map in p. refine (_ @ p @ _). - apply maponpaths. refine (!_). exact (ProductPrCommutes _ _ _ ProdM _ _ (x ,, (y ,, f))). - apply maponpaths. exact (ProductPrCommutes _ _ _ ProdM _ _ (x ,, (y ,, f))). Qed. Definition construction_of_ends_wedge : wedge. Proof. use make_wedge. - exact construction_of_ends_wedge_data. - exact construction_of_ends_wedge_laws. Defined. Section EndUMP. Context (w : wedge). Proposition is_end_construction_of_ends_unique_map : isaprop (wedge_map w construction_of_ends_wedge). Proof. use invproofirrelevance. intros φ₁ φ₂. use wedge_map_eq. use EqualizerInsEq. use ProductArrow_eq. intro i. rewrite !assoc'. exact (eq_of_wedge_map φ₁ i @ !(eq_of_wedge_map φ₂ i)). Qed. Definition is_end_construction_of_ends_mor : w --> construction_of_ends_wedge. Proof. use EqualizerIn. - use ProductArrow. exact (λ i, mor_of_wedge w i). - abstract (use ProductArrow_eq ; intro f ; unfold end_left_map, end_right_map ; rewrite !assoc' ; rewrite !(ProductPrCommutes _ _ _ ProdM) ; rewrite !assoc ; rewrite !(ProductPrCommutes _ _ _ ProdF) ; apply eq_of_wedge). Defined. Proposition is_end_construction_of_ends_comm : is_wedge_map is_end_construction_of_ends_mor. Proof. intros x. cbn. unfold is_end_construction_of_ends_mor. unfold construction_of_ends_pr. rewrite !assoc. rewrite EqualizerCommutes. apply (ProductPrCommutes _ _ _ ProdF). Qed. End EndUMP. Definition is_end_construction_of_ends : is_end construction_of_ends_wedge. Proof. intro w. use iscontraprop1. - exact (is_end_construction_of_ends_unique_map w). - use make_wedge_map. + exact (is_end_construction_of_ends_mor w). + exact (is_end_construction_of_ends_comm w). Defined. Definition construction_of_ends : end_limit := construction_of_ends_wedge ,, is_end_construction_of_ends. End ConstructionOfEnds. End Ends. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/000077500000000000000000000000001451125700300227035ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/limits/Examples/AlgebraStructuresColimits.v000066400000000000000000000722541451125700300302510ustar00rootroot00000000000000(***************************************************************** Cocompleteness of the category of algebras In this file, we look at the cocompleteness of the category of algebras for a monad. We proceed in the following steps. We start by looking when the category of algbras has reflexive coequalizers. This is the case if the monad preserves reflexive coequalizers. Note that this holds more generally (although we do not formalize that): if a monad preserves a class of colimits, then the category of algebras also has that class of colimits. The next step is to construct coproducts in the category of algebras, and this is where the main work happens. Here we assume that the category of algebras has reflexive coequalizers. Finally, we conclude cocompleteness, and for that, it suffices to construct coequalizers. Here we use a general statement: if a category has reflexive coequalizers and binary coproducts, then it also has coequalizers. Concluding, if the category of algebras has reflexive coequalizers, then it is cocomplete. Note that reflexive coequalizers are colimits, so these two statements are in fact equivalent. Note that the underlying assumption in this whole story is that the category of algebras has reflexive coequalizers, which is the case if the monad preserves reflexive coequalizers. It is worthwhile to note that every finitary monad preserves reflexive coequalizers. As such, the category of algebras for every finitary algebraic theory is thus cocomplete. Contents 1. Reflexive coequalizers in the Eilenberg-Moore category 2. Binary Coproducts 3. Coequalizers *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.categories.HSET.All. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.AlgebraStructures. Require Import UniMath.CategoryTheory.Monads.Monads. Local Open Scope cat. Section MonadToStruct. Context (M : Monad SET). Definition monad_on_reflexive_coequalizer (HM : preserves_reflexive_coequalizer M) {X Y : hSet} {f g : SET ⟦ X , Y ⟧} {σ : SET ⟦ Y , X ⟧} (pf : ∏ (y : Y), f(σ y) = y) (pg : ∏ (y : Y), g(σ y) = y) : Coequalizer (#M f) (#M g). Proof. pose (C := pr11 (Coequalizers_HSET _ _ f g)). pose (π := CoequalizerArrow (Coequalizers_HSET _ _ f g)). simple refine ((M C ,, #M π) ,, _ ,, _). - abstract (refine (!(functor_comp M _ _) @ _ @ functor_comp M _ _) ; apply maponpaths ; exact (CoequalizerEqAr (Coequalizers_HSET _ _ f g))). - refine (HM X Y C f g σ _ _ π _ _ (pr22 (Coequalizers_HSET _ _ f g))). + abstract (use funextsec ; exact pf). + abstract (use funextsec ; exact pg). Defined. Definition monad_on_reflexive_coequalizer_2 (HM : preserves_reflexive_coequalizer M) {X Y : hSet} {f g : SET ⟦ X , Y ⟧} {σ : SET ⟦ Y , X ⟧} (pf : ∏ (y : Y), f(σ y) = y) (pg : ∏ (y : Y), g(σ y) = y) : Coequalizer (#M(#M f)) (#M(#M g)). Proof. pose (C := pr11 (Coequalizers_HSET _ _ f g)). pose (π := CoequalizerArrow (Coequalizers_HSET _ _ f g)). simple refine ((M(M C) ,, #M(#M π)) ,, _ ,, _). - abstract (refine (!(functor_comp M _ _) @ _ @ functor_comp M _ _) ; apply maponpaths ; refine (!(functor_comp M _ _) @ _ @ functor_comp M _ _) ; apply maponpaths ; exact (CoequalizerEqAr (Coequalizers_HSET _ _ f g))). - simple refine (HM (M X) (M Y) (M C) (#M f) (#M g) (#M σ) _ _ (#M π) _ _ _). + abstract (refine (!(functor_comp M _ _) @ _ @ functor_id M _) ; apply maponpaths ; use funextsec ; exact pf). + abstract (refine (!(functor_comp M _ _) @ _ @ functor_id M _) ; apply maponpaths ; use funextsec ; exact pg). + abstract (refine (!(functor_comp M _ _) @ _ @ functor_comp M _ _) ; apply maponpaths ; exact (CoequalizerEqAr (Coequalizers_HSET _ _ f g))). + refine (HM X Y C f g σ _ _ π _ _ (pr22 (Coequalizers_HSET _ _ f g))). * abstract (use funextsec ; exact pf). * abstract (use funextsec ; exact pg). Defined. (** 1. Reflexive coequalizers in the Eilenberg-Moore category *) Section ReflexiveCoequalizers. Context (HM : preserves_reflexive_coequalizer M). Section ReflexiveCoequalizerConstruction. Context {X Y : hSet} {hX : monad_algebra M X} {hY : monad_algebra M Y} {f g : SET ⟦ X , Y ⟧} (hf : hX · f = # M f · hY) (hg : hX · g = # M g · hY) {σ : SET ⟦ Y , X ⟧} (hσ : hY · σ = #M σ · hX) (pf : ∏ (y : Y), f(σ y) = y) (pg : ∏ (y : Y), g(σ y) = y). Let AX : category_of_monad_algebra M := X ,, hX. Let AY : category_of_monad_algebra M := Y ,, hY. Let Af : AX --> AY := f ,, hf. Let Ag : AX --> AY := g ,, hg. Let Aσ : AY --> AX := σ ,, hσ. Let C : hSet := pr11 (Coequalizers_HSET _ _ f g). Let π : SET ⟦ Y , C ⟧ := CoequalizerArrow (Coequalizers_HSET _ _ f g). Let Cp : f · π = g · π := CoequalizerEqAr (Coequalizers_HSET _ _ f g). Let Coeq : Coequalizer _ _ := Coequalizers_HSET _ _ f g. Definition monad_reflexive_coequalizer_algebra_mor : M C --> C. Proof. use (CoequalizerOut (monad_on_reflexive_coequalizer HM pf pg)). - exact (hY · π). - abstract (rewrite !assoc ; rewrite <- hf, <- hg ; rewrite !assoc' ; rewrite Cp ; apply idpath). Defined. Proposition monad_reflexive_coequalizer_algebra_laws : monad_algebra_laws M monad_reflexive_coequalizer_algebra_mor. Proof. split. - use (CoequalizerOutsEq Coeq). rewrite id_right. unfold monad_reflexive_coequalizer_algebra_mor. rewrite !assoc. etrans. { apply maponpaths_2. exact (nat_trans_ax (η M) _ _ (CoequalizerArrow Coeq)). } rewrite !assoc'. etrans. { apply maponpaths. apply (CoequalizerCommutes (monad_on_reflexive_coequalizer _ _ _)). } rewrite !assoc. rewrite monad_algebra_unit. apply id_left. - use (CoequalizerOutsEq (monad_on_reflexive_coequalizer_2 HM pf pg)). unfold monad_reflexive_coequalizer_algebra_mor. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax (μ M)). } rewrite !assoc'. etrans. { apply maponpaths. apply (CoequalizerCommutes (monad_on_reflexive_coequalizer _ _ _)). } rewrite !assoc. rewrite monad_algebra_mu. refine (!_). etrans. { apply maponpaths_2. refine (!(functor_comp _ _ _) @ _). apply maponpaths. apply (CoequalizerCommutes (monad_on_reflexive_coequalizer _ _ _)). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. apply (CoequalizerCommutes (monad_on_reflexive_coequalizer _ _ _)). Qed. Definition monad_reflexive_coequalizer_algebra : monad_algebra M (coequalizer_hSet f g). Proof. use make_monad_algebra. - exact monad_reflexive_coequalizer_algebra_mor. - exact monad_reflexive_coequalizer_algebra_laws. Defined. Definition monad_reflexive_coequalizer_ob : category_of_monad_algebra M := C ,, monad_reflexive_coequalizer_algebra. Definition monad_reflexive_coequalizer_arrow : AY --> monad_reflexive_coequalizer_ob. Proof. refine (π ,, _). abstract (refine (!_) ; apply (CoequalizerCommutes (monad_on_reflexive_coequalizer _ _ _))). Defined. Proposition monad_reflexive_coequalizer_arrow_eq : Af · monad_reflexive_coequalizer_arrow = Ag · monad_reflexive_coequalizer_arrow. Proof. use subtypePath. { intro ; apply homset_property. } exact Cp. Qed. Section UMP. Context {W : hSet} (hW : monad_algebra M W) {l : Y → W} (hl : hY · l = #M l · hW) (p : f · l = g · l). Let AW : category_of_monad_algebra M := W ,, hW. Proposition monad_reflexive_coequalizer_ump_unique : isaprop (∑ (φ : monad_reflexive_coequalizer_ob --> AW), monad_reflexive_coequalizer_arrow · φ = l ,, hl). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use subtypePath. { intro. apply homset_property. } use (CoequalizerOutsEq Coeq). exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))). Qed. Definition monad_reflexive_coequalizer_ump_mor : monad_reflexive_coequalizer_ob --> AW. Proof. simple refine (_ ,, _). - exact (CoequalizerOut Coeq _ l p). - abstract (use (CoequalizerOutsEq (monad_on_reflexive_coequalizer HM pf pg)) ; refine (assoc _ monad_reflexive_coequalizer_algebra_mor _ @ _) ; unfold monad_reflexive_coequalizer_algebra_mor ; rewrite !assoc ; rewrite (CoequalizerCommutes (monad_on_reflexive_coequalizer HM pf pg)) ; rewrite !assoc' ; rewrite (CoequalizerCommutes Coeq) ; refine (hl @ _) ; rewrite !assoc ; refine (maponpaths (λ z, z · _) (!_)) ; refine (!(functor_comp M _ _) @ _) ; apply maponpaths ; apply (CoequalizerCommutes Coeq)). Defined. Proposition monad_reflexive_coequalizer_ump_commutes : monad_reflexive_coequalizer_arrow · monad_reflexive_coequalizer_ump_mor = l ,, hl. Proof. use subtypePath. { intro ; apply homset_property. } apply idpath. Qed. End UMP. Definition monad_reflexive_coequalizer : Coequalizer Af Ag. Proof. use make_Coequalizer. - exact monad_reflexive_coequalizer_ob. - exact monad_reflexive_coequalizer_arrow. - exact monad_reflexive_coequalizer_arrow_eq. - intros W h p. use iscontraprop1. + exact (monad_reflexive_coequalizer_ump_unique (pr2 W) (pr2 h)). + simple refine (_ ,, _). * apply (monad_reflexive_coequalizer_ump_mor (pr2 W) (pr2 h)). exact (maponpaths pr1 p). * apply monad_reflexive_coequalizer_ump_commutes. Defined. End ReflexiveCoequalizerConstruction. Definition monad_algebra_reflexive_coequalizers : reflexive_coequalizers (category_of_monad_algebra M). Proof. intros hx hy hf hg hh pf pg. use (monad_reflexive_coequalizer (pr2 hf) (pr2 hg) _ _). - exact (pr1 hh). - exact (eqtohomot (maponpaths pr1 pf)). - exact (eqtohomot (maponpaths pr1 pg)). Defined. End ReflexiveCoequalizers. (** 2. Binary Coproducts *) Section BinaryCoproductsEM. Context (RC : reflexive_coequalizers (category_of_monad_algebra M)). Section CoproductAlgebra. Context (alg_X alg_Y : category_of_monad_algebra M). Let F : SET ⟶ category_of_monad_algebra M := monad_free_alg_functor M. Let U : category_of_monad_algebra M ⟶ SET := underlying_of_hset_struct (monad_to_hset_struct M). Let X : hSet := underlying_of_hset_struct _ alg_X. Let Y : hSet := underlying_of_hset_struct _ alg_Y. Let XY : @BinCoproduct HSET X Y := BinCoproductsHSET X Y. Let ι₁ : SET ⟦ X , XY ⟧ := inl. Let ι₂ : SET ⟦ Y , XY ⟧ := inr. Let hX : monad_algebra M X := pr2 alg_X. Let hY : monad_algebra M Y := pr2 alg_Y. Let S₁ : BinCoproduct (F X) (F Y) := free_alg_coproduct M X Y. Let S₂ : BinCoproduct (F(U(F X))) (F(U(F Y))) := free_alg_coproduct M (U(F X)) (U(F Y)). Definition binary_coprod_algebra_left_map : S₂ --> S₁. Proof. use BinCoproductOfArrows. - exact (monad_free_alg_counit M (F X)). - exact (monad_free_alg_counit M (F Y)). Defined. Let l : S₂ --> S₁ := binary_coprod_algebra_left_map. Definition binary_coprod_algebra_right_map : S₂ --> S₁. Proof. use BinCoproductOfArrows. - exact (#F(#U (monad_free_alg_counit M alg_X))). - exact (#F(#U (monad_free_alg_counit M alg_Y))). Defined. Let r : S₂ --> S₁ := binary_coprod_algebra_right_map. Definition binary_coprod_algebra_section : S₁ --> S₂. Proof. use BinCoproductOfArrows. - exact (#F (monad_free_alg_unit M X)). - exact (#F (monad_free_alg_unit M Y)). Defined. Let s : S₁ --> S₂ := binary_coprod_algebra_section. Proposition binary_coprod_algebra_section_left_map : s · l = identity _. Proof. unfold s, l. use BinCoproductArrowsEq. - rewrite id_right. rewrite !assoc. unfold binary_coprod_algebra_section. rewrite BinCoproductOfArrowsIn1. rewrite !assoc'. unfold binary_coprod_algebra_left_map. rewrite BinCoproductOfArrowsIn1. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. exact (triangle_id_left_ad (pr2 (monad_underlying_is_right_adjoint M)) X). - rewrite id_right. rewrite !assoc. unfold binary_coprod_algebra_section. rewrite BinCoproductOfArrowsIn2. rewrite !assoc'. unfold binary_coprod_algebra_left_map. rewrite BinCoproductOfArrowsIn2. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. exact (triangle_id_left_ad (pr2 (monad_underlying_is_right_adjoint M)) Y). Qed. Let sl : s · l = identity _ := binary_coprod_algebra_section_left_map. Proposition binary_coprod_algebra_section_right_map : s · r = identity _. Proof. unfold s, r. use BinCoproductArrowsEq. - rewrite id_right. rewrite !assoc. unfold binary_coprod_algebra_section. rewrite BinCoproductOfArrowsIn1. rewrite !assoc'. unfold binary_coprod_algebra_right_map. rewrite BinCoproductOfArrowsIn1. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite <- (functor_comp F). refine (_ @ functor_id F _). apply maponpaths. exact (triangle_id_right_ad (pr2 (monad_underlying_is_right_adjoint M)) alg_X). - rewrite id_right. rewrite !assoc. unfold binary_coprod_algebra_section. rewrite BinCoproductOfArrowsIn2. rewrite !assoc'. unfold binary_coprod_algebra_right_map. rewrite BinCoproductOfArrowsIn2. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. rewrite <- (functor_comp F). refine (_ @ functor_id F _). apply maponpaths. exact (triangle_id_right_ad (pr2 (monad_underlying_is_right_adjoint M)) alg_Y). Qed. Let sr : s · r = identity _ := binary_coprod_algebra_section_right_map. Definition binary_coprod_algebra_ob : Coequalizer l r := RC _ _ l r s sl sr. Let C : hSet := pr111 binary_coprod_algebra_ob. Let hC : monad_algebra M C := pr211 binary_coprod_algebra_ob. Lemma binary_coprod_algebra_in1_eq : μ M X · #M(ι₁ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob) = #M (hX · η M X) · μ M X · #M(ι₁ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob). Proof. assert (BinCoproductIn1 S₂ · (l · CoequalizerArrow binary_coprod_algebra_ob) = BinCoproductIn1 S₂ · (r · CoequalizerArrow binary_coprod_algebra_ob)) as p. { exact (maponpaths (λ z, BinCoproductIn1 _ · z) (CoequalizerEqAr binary_coprod_algebra_ob)). } unfold l in p. unfold r in p. unfold binary_coprod_algebra_left_map in p. unfold binary_coprod_algebra_right_map in p. rewrite !assoc in p. rewrite !BinCoproductOfArrowsIn1 in p. assert (# M (identity (M X)) · μ M X · (# M (ι₁ · η M XY) · μ M XY) · pr1 (CoequalizerArrow binary_coprod_algebra_ob) = # M (# M (identity _) · hX · η M X) · μ M X · (# M (ι₁ · η M XY) · μ M XY) · pr1 (CoequalizerArrow binary_coprod_algebra_ob)) as q. { exact (maponpaths pr1 p). } rewrite !functor_id in q. rewrite !id_left in q. refine (_ @ q). rewrite !assoc'. apply idpath. Qed. Definition binary_coprod_algebra_in1 : alg_X --> binary_coprod_algebra_ob. Proof. use (CoequalizerOut (algebra_as_coequalizer M hX)). - exact (BinCoproductIn1 _ · CoequalizerArrow binary_coprod_algebra_ob). - abstract (use subtypePath ; [ intro ; apply homset_property | ] ; refine (_ @ binary_coprod_algebra_in1_eq) ; simpl ; rewrite (functor_id M) ; exact (maponpaths (λ z, z · _) (id_left (μ M X)))). Defined. Lemma binary_coprod_algebra_in2_eq : μ M Y · #M(ι₂ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob) = #M (hY · η M Y) · μ M Y · #M(ι₂ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob). Proof. assert (BinCoproductIn2 S₂ · (l · CoequalizerArrow binary_coprod_algebra_ob) = BinCoproductIn2 S₂ · (r · CoequalizerArrow binary_coprod_algebra_ob)) as p. { exact (maponpaths (λ z, BinCoproductIn2 _ · z) (CoequalizerEqAr binary_coprod_algebra_ob)). } unfold l in p. unfold r in p. unfold binary_coprod_algebra_left_map in p. unfold binary_coprod_algebra_right_map in p. rewrite !assoc in p. rewrite !BinCoproductOfArrowsIn2 in p. assert (# M (identity (M Y)) · μ M Y · (# M (ι₂ · η M XY) · μ M XY) · pr1 (CoequalizerArrow binary_coprod_algebra_ob) = # M (# M (identity _) · hY · η M Y) · μ M Y · (# M (ι₂ · η M XY) · μ M XY) · pr1 (CoequalizerArrow binary_coprod_algebra_ob)) as q. { exact (maponpaths pr1 p). } rewrite !functor_id in q. rewrite !id_left in q. refine (_ @ q). rewrite !assoc'. apply idpath. Qed. Definition binary_coprod_algebra_in2 : alg_Y --> binary_coprod_algebra_ob. Proof. use (CoequalizerOut (algebra_as_coequalizer M hY)). - exact (BinCoproductIn2 _ · CoequalizerArrow binary_coprod_algebra_ob). - abstract (use subtypePath ; [ intro ; apply homset_property | ] ; refine (_ @ binary_coprod_algebra_in2_eq) ; simpl ; rewrite (functor_id M) ; exact (maponpaths (λ z, z · _) (id_left (μ M Y)))). Defined. Section UMP. Context {Z : category_of_monad_algebra M} (φ₁ : alg_X --> Z) (φ₂ : alg_Y --> Z). Definition binary_coprod_algebra_arrow_ob : S₁ --> Z. Proof. use BinCoproductArrow. - exact (monad_free_alg_counit M alg_X · φ₁). - exact (monad_free_alg_counit M alg_Y · φ₂). Defined. Definition binary_coprod_algebra_arrow : binary_coprod_algebra_ob --> Z. Proof. use CoequalizerOut. - exact binary_coprod_algebra_arrow_ob. - use BinCoproductArrowsEq. + abstract (rewrite !assoc ; unfold l, binary_coprod_algebra_left_map ; unfold r, binary_coprod_algebra_right_map ; unfold binary_coprod_algebra_arrow_ob ; rewrite !BinCoproductOfArrowsIn1 ; rewrite !assoc' ; rewrite BinCoproductIn1Commutes ; rewrite !assoc ; apply maponpaths_2 ; exact (!(nat_trans_ax (monad_free_alg_counit M) _ _ _))). + abstract (rewrite !assoc ; unfold l, binary_coprod_algebra_left_map ; unfold r, binary_coprod_algebra_right_map ; unfold binary_coprod_algebra_arrow_ob ; rewrite !BinCoproductOfArrowsIn2 ; rewrite !assoc' ; rewrite BinCoproductIn2Commutes ; rewrite !assoc ; apply maponpaths_2 ; exact (!(nat_trans_ax (monad_free_alg_counit M) _ _ _))). Defined. Proposition binary_coprod_algebra_arrow_in1 : binary_coprod_algebra_in1 · binary_coprod_algebra_arrow = φ₁. Proof. use subtypePath. { intro. apply homset_property. } enough (η M X · (# M (ι₁ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob)) · pr1 binary_coprod_algebra_arrow = pr1 φ₁) as p. { exact p. } rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (maponpaths pr1 (CoequalizerCommutes binary_coprod_algebra_ob _ _ _)). } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. exact (@Monad_law2 _ M XY). } apply id_right. } etrans. { apply maponpaths. pose (maponpaths pr1 (BinCoproductIn1Commutes _ _ _ S₁ Z (monad_free_alg_counit M alg_X · φ₁) (monad_free_alg_counit M alg_Y · φ₂))) as p. refine (_ @ p). refine (maponpaths (λ z, z · _) _). refine (!(id_right _) @ _). simpl. rewrite (functor_comp M). refine (_ @ assoc (#M ι₁) _ _). apply maponpaths. refine (!_). apply (Monad_law2(T:=M)). } refine (_ @ id_left _). refine (assoc _ _ _ @ _). apply maponpaths_2. simpl. rewrite (functor_id M). etrans. { apply maponpaths. exact (id_left hX). } apply monad_algebra_unit. Qed. Proposition binary_coprod_algebra_arrow_in2 : binary_coprod_algebra_in2 · binary_coprod_algebra_arrow = φ₂. Proof. use subtypePath. { intro. apply homset_property. } enough (η M Y · (# M (ι₂ · η M XY) · μ M XY · pr1 (CoequalizerArrow binary_coprod_algebra_ob)) · pr1 binary_coprod_algebra_arrow = pr1 φ₂) as p. { exact p. } rewrite !assoc'. etrans. { do 3 apply maponpaths. exact (maponpaths pr1 (CoequalizerCommutes binary_coprod_algebra_ob _ _ _)). } etrans. { apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. exact (@Monad_law2 _ M XY). } apply id_right. } etrans. { apply maponpaths. pose (maponpaths pr1 (BinCoproductIn2Commutes _ _ _ S₁ Z (monad_free_alg_counit M alg_X · φ₁) (monad_free_alg_counit M alg_Y · φ₂))) as p. refine (_ @ p). refine (maponpaths (λ z, z · _) _). refine (!(id_right _) @ _). simpl. rewrite (functor_comp M). refine (_ @ assoc (#M ι₂) _ _). apply maponpaths. refine (!_). apply (Monad_law2(T:=M)). } refine (_ @ id_left _). refine (assoc _ _ _ @ _). apply maponpaths_2. simpl. rewrite (functor_id M). etrans. { apply maponpaths. exact (id_left hY). } apply monad_algebra_unit. Qed. Proposition binary_coprod_algebra_arrow_unique : isaprop (∑ fg, (binary_coprod_algebra_in1 · fg = φ₁) × (binary_coprod_algebra_in2 · fg = φ₂)). Proof. use invproofirrelevance. intros ψ₁ ψ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use CoequalizerOutsEq. use BinCoproductArrowsEq. - use mor_from_free_alg_eq. exact (maponpaths pr1 (pr12 ψ₁ @ !(pr12 ψ₂))). - use mor_from_free_alg_eq. exact (maponpaths pr1 (pr22 ψ₁ @ !(pr22 ψ₂))). Qed. End UMP. Definition binary_coprod_algebra : BinCoproduct alg_X alg_Y. Proof. use make_BinCoproduct. - exact binary_coprod_algebra_ob. - exact binary_coprod_algebra_in1. - exact binary_coprod_algebra_in2. - intros Z φ₁ φ₂. use iscontraprop1. + exact (binary_coprod_algebra_arrow_unique φ₁ φ₂). + simple refine (_ ,, _ ,, _). * exact (binary_coprod_algebra_arrow φ₁ φ₂). * exact (binary_coprod_algebra_arrow_in1 φ₁ φ₂). * exact (binary_coprod_algebra_arrow_in2 φ₁ φ₂). Defined. End CoproductAlgebra. Definition monad_algebra_binary_coproducts : BinCoproducts (category_of_monad_algebra M). Proof. intros hx hy. exact (binary_coprod_algebra hx hy). Defined. End BinaryCoproductsEM. (** 3. Coequalizers *) Definition monad_algebra_coequalizers (RC : reflexive_coequalizers (category_of_monad_algebra M)) : Coequalizers (category_of_monad_algebra M). Proof. use coequalizers_from_reflexive. - exact RC. - exact (monad_algebra_binary_coproducts RC). Defined. End MonadToStruct. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/CategoryOfSetcategoriesLimits.v000066400000000000000000000216761451125700300310540ustar00rootroot00000000000000(****************************************************************************************** Equalizers in the category of strict categories ******************************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Setcategories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. Definition equalizer_of_setcategory_precategory_ob_mor {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : precategory_ob_mor. Proof. use make_precategory_ob_mor. - exact (∑ (x : C₁), F x = G x). - exact (λ x y, ∑ (f : pr1 x --> pr1 y), # F f · idtoiso (pr2 y) = idtoiso (pr2 x) · # G f). Defined. Definition equalizer_of_setcategory_precategory_data {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : precategory_data. Proof. use make_precategory_data. - exact (equalizer_of_setcategory_precategory_ob_mor F G). - cbn ; refine (λ x, identity _ ,, _). abstract (rewrite !functor_id ; rewrite id_left, id_right ; apply idpath). - cbn ; refine (λ x y z f g, pr1 f · pr1 g ,, _). abstract (rewrite !functor_comp ; rewrite !assoc ; rewrite <- (pr2 f) ; rewrite !assoc' ; rewrite <- (pr2 g) ; apply idpath). Defined. Definition equalizer_of_setcategory_is_precategory {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : is_precategory (equalizer_of_setcategory_precategory_data F G). Proof. use make_is_precategory_one_assoc ; intros ; (use subtypePath ; [ intro ; apply homset_property | ]) ; cbn. - apply id_left. - apply id_right. - apply assoc. Qed. Definition equalizer_of_setcategory_precategory {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : precategory. Proof. use make_precategory. - exact (equalizer_of_setcategory_precategory_data F G). - exact (equalizer_of_setcategory_is_precategory F G). Defined. Definition equalizer_of_setcategory_is_setcategory {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : is_setcategory (equalizer_of_setcategory_precategory F G). Proof. split. - use isaset_total2. + apply C₁. + intro. apply isasetaprop. exact (pr12 C₂ (F x) (G x)). - intros x y. use isaset_total2. + apply homset_property. + intro. apply isasetaprop. apply homset_property. Qed. Definition equalizer_of_setcategory {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : setcategory := equalizer_of_setcategory_precategory F G ,, equalizer_of_setcategory_is_setcategory F G. Definition idtoiso_equalizer_of_setcategory {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {x y : equalizer_of_setcategory F G} (p : x = y) : pr11 (idtoiso p) = pr1 (idtoiso (maponpaths pr1 p)). Proof. induction p. apply idpath. Qed. Definition equalizer_of_setcategory_pr1 {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : equalizer_of_setcategory F G ⟶ C₁. Proof. use make_functor. - use make_functor_data. + exact (λ x, pr1 x). + exact (λ x y f, pr1 f). - abstract (split ; intro ; intros ; apply idpath). Defined. Definition equalizer_of_setcategory_eq {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) : equalizer_of_setcategory_pr1 F G ∙ F = equalizer_of_setcategory_pr1 F G ∙ G. Proof. use functor_eq. { apply homset_property. } use functor_data_eq ; cbn. - exact (λ x, pr2 x). - intros x y f. cbn. rewrite double_transport_idtoiso. rewrite !assoc'. rewrite (pr2 f). rewrite !assoc. rewrite z_iso_after_z_iso_inv. apply id_left. Qed. Definition equalizer_of_setcategory_ump_mor_data {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {C₀ : setcategory} (H : C₀ ⟶ C₁) (p : H ∙ F = H ∙ G) : functor_data C₀ (equalizer_of_setcategory F G). Proof. use make_functor_data. - refine (λ x, H x ,, _). exact (maponpaths (λ z, pr11 z x) p). - refine (λ x y f, #H f ,, _). abstract (pose (from_eq_cat_of_setcategory p f) as q ; cbn in q ; etrans ; [ apply maponpaths_2 ; exact q | ] ; cbn ; rewrite !assoc' ; apply maponpaths ; refine (_ @ id_right _) ; apply maponpaths ; refine (!_) ; refine (_ @ pr1_idtoiso_concat (maponpaths (λ z, pr11 z y) (!p)) (maponpaths (λ z, pr11 z y) p)) ; refine (!_) ; apply setcategory_refl_idtoiso). Defined. Definition equalizer_of_setcategory_ump_mor_is_functor {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {C₀ : setcategory} (H : C₀ ⟶ C₁) (p : H ∙ F = H ∙ G) : is_functor (equalizer_of_setcategory_ump_mor_data F G H p). Proof. split. - intro x. use subtypePath. { intro. apply homset_property. } apply functor_id. - intros x y z f g. use subtypePath. { intro. apply homset_property. } apply functor_comp. Qed. Definition equalizer_of_setcategory_ump_mor {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {C₀ : setcategory} (H : C₀ ⟶ C₁) (p : H ∙ F = H ∙ G) : C₀ ⟶ equalizer_of_setcategory F G. Proof. use make_functor. - exact (equalizer_of_setcategory_ump_mor_data F G H p). - exact (equalizer_of_setcategory_ump_mor_is_functor F G H p). Defined. Definition equalizer_of_setcategory_ump_mor_pr1 {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {C₀ : setcategory} (H : C₀ ⟶ C₁) (p : H ∙ F = H ∙ G) : equalizer_of_setcategory_ump_mor F G H p ∙ equalizer_of_setcategory_pr1 F G = H. Proof. use functor_eq. { apply homset_property. } use functor_data_eq. - exact (λ _, idpath _). - exact (λ _ _ _, idpath _). Qed. Definition equalizer_of_setcategory_ump_unique {C₁ C₂ : setcategory} (F G : C₁ ⟶ C₂) {C₀ : setcategory} (H : C₀ ⟶ C₁) (p : H ∙ F = H ∙ G) (K : C₀ ⟶ equalizer_of_setcategory F G) (K_pr1 : K ∙ equalizer_of_setcategory_pr1 F G = H) : K = equalizer_of_setcategory_ump_mor F G H p. Proof. use functor_eq. { apply homset_property. } use functor_data_eq. - abstract (intro x ; use subtypePath ; [ intro z ; exact (pr12 C₂ (F z) (G z)) | ] ; exact (maponpaths (λ z, pr11 z x) K_pr1)). - intros x₁ x₂ f. rewrite double_transport_idtoiso. rewrite !assoc'. use z_iso_inv_on_right. use subtypePath. { intro. apply homset_property. } cbn. pose (from_eq_cat_of_setcategory K_pr1 f) as q. cbn in q. etrans. { apply maponpaths_2. exact q. } rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply maponpaths. exact (idtoiso_equalizer_of_setcategory F G (equalizer_of_setcategory_ump_unique_subproof C₁ C₂ F G C₀ H p K K_pr1 x₂)). } refine (!_). apply (pr1_idtoiso_concat (maponpaths (λ z, (pr11 z) x₂) (! K_pr1))). } etrans. { apply maponpaths. apply setcategory_refl_idtoiso. } apply id_right. } apply maponpaths_2. refine (!_). etrans. { exact (idtoiso_equalizer_of_setcategory F G (equalizer_of_setcategory_ump_unique_subproof C₁ C₂ F G C₀ H p K K_pr1 x₁)). } apply setcategory_eq_idtoiso. Qed. Definition cat_of_setcategory_equalizers : Equalizers cat_of_setcategory. Proof. intros C₁ C₂ F G. use make_Equalizer. - exact (equalizer_of_setcategory F G). - exact (equalizer_of_setcategory_pr1 F G). - exact (equalizer_of_setcategory_eq F G). - use make_isEqualizer. intros C₀ H p. simple refine (_ ,, _). + refine (equalizer_of_setcategory_ump_mor F G H p ,, _). exact (equalizer_of_setcategory_ump_mor_pr1 F G H p). + abstract (simpl ; intro K ; use subtypePath ; [ intro ; apply cat_of_setcategory | ] ; apply equalizer_of_setcategory_ump_unique ; exact (pr2 K)). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/CategoryProductLimits.v000066400000000000000000000471021451125700300273760ustar00rootroot00000000000000(************************************************************************ Limits and colimits in the unit category Contents 1. Terminal objects 2. Products 3. Pullbacks 4. Initial objects 5. Coproducts ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Local Open Scope cat. (** 1. Terminal objects *) Section TerminalProduct. Context {C₁ C₂ : category}. Definition isTerminal_category_binproduct (x : category_binproduct C₁ C₂) (H₁ : isTerminal C₁ (pr1 x)) (H₂ : isTerminal C₂ (pr2 x)) : isTerminal (category_binproduct C₁ C₂) x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use pathsdirprod ; [ exact (TerminalArrowUnique (_ ,, H₁) _ _ @ !(TerminalArrowUnique (_ ,, H₁) _ _)) | exact (TerminalArrowUnique (_ ,, H₂) _ _ @ !(TerminalArrowUnique (_ ,, H₂) _ _)) ]). - exact (TerminalArrow (_ ,, H₁) (pr1 w) ,, TerminalArrow (_ ,, H₂) (pr2 w)). Defined. Definition terminal_category_binproduct (T₁ : Terminal C₁) (T₂ : Terminal C₂) : Terminal (category_binproduct C₁ C₂) := (pr1 T₁ ,, pr1 T₂) ,, isTerminal_category_binproduct (_ ,, _) (pr2 T₁) (pr2 T₂). End TerminalProduct. Definition pr1_preserves_terminal (C₁ C₂ : category) : preserves_terminal (pr1_functor C₁ C₂). Proof. intros x Hx w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (maponpaths pr1 (TerminalArrowUnique (x ,, Hx) (w ,, pr2 x) (φ₁ ,, identity _)) @ !_) ; exact (maponpaths pr1 (TerminalArrowUnique (x ,, Hx) (w ,, pr2 x) (φ₂ ,, identity _)))). - exact (pr1 (TerminalArrow (_ ,, Hx) (w ,, pr2 x))). Defined. Definition pr2_preserves_terminal (C₁ C₂ : category) : preserves_terminal (pr2_functor C₁ C₂). Proof. intros x Hx w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (maponpaths dirprod_pr2 (TerminalArrowUnique (x ,, Hx) (pr1 x ,, w) (identity _ ,, φ₁)) @ !_) ; exact (maponpaths dirprod_pr2 (TerminalArrowUnique (x ,, Hx) (pr1 x ,, w) (identity _ ,, φ₂)))). - exact (pr2 (TerminalArrow (_ ,, Hx) (pr1 x ,, w))). Defined. Definition preserves_terminal_bindelta_pair_functor {C D₁ D₂ : category} {F : C ⟶ D₁} {G : C ⟶ D₂} (HF : preserves_terminal F) (HG : preserves_terminal G) : preserves_terminal (bindelta_pair_functor F G). Proof. intros x Hx. apply isTerminal_category_binproduct. - apply HF. apply Hx. - apply HG. apply Hx. Defined. (** 2. Products *) Section BinProductInProduct. Context {C₁ C₂ : category}. Definition isBinProduct_in_product_category {x y z : category_binproduct C₁ C₂} (p₁ : z --> x) (p₂ : z --> y) (H₁ : isBinProduct _ (pr1 x) (pr1 y) (pr1 z) (pr1 p₁) (pr1 p₂)) (H₂ : isBinProduct _ (pr2 x) (pr2 y) (pr2 z) (pr2 p₁) (pr2 p₂)) : isBinProduct _ x y z p₁ p₂. Proof. pose (P₁ := make_BinProduct _ _ _ _ _ _ H₁). pose (P₂ := make_BinProduct _ _ _ _ _ _ H₂). intros w f g. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; use pathsdirprod ; [ exact (BinProductArrowsEq _ _ _ P₁ _ _ _ (maponpaths pr1 (pr12 φ₁) @ !(maponpaths pr1 (pr12 φ₂))) (maponpaths pr1 (pr22 φ₁) @ !(maponpaths pr1 (pr22 φ₂)))) | exact (BinProductArrowsEq _ _ _ P₂ _ _ _ (maponpaths dirprod_pr2 (pr12 φ₁) @ !(maponpaths dirprod_pr2 (pr12 φ₂))) (maponpaths dirprod_pr2 (pr22 φ₁) @ !(maponpaths dirprod_pr2 (pr22 φ₂)))) ]). - simple refine ((_ ,, _) ,, _ ,, _). + exact (BinProductArrow _ P₁ (pr1 f) (pr1 g)). + exact (BinProductArrow _ P₂ (pr2 f) (pr2 g)). + abstract (use pathsdirprod ; [ apply (BinProductPr1Commutes _ _ _ P₁) | apply (BinProductPr1Commutes _ _ _ P₂)]). + abstract (use pathsdirprod ; [ apply (BinProductPr2Commutes _ _ _ P₁) | apply (BinProductPr2Commutes _ _ _ P₂)]). Defined. Definition binproducts_in_product_category (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : BinProducts (category_binproduct C₁ C₂). Proof. intros x y. use make_BinProduct. - simple refine (_ ,, _). + exact (BinProductObject _ (HC₁ (pr1 x) (pr1 y))). + exact (BinProductObject _ (HC₂ (pr2 x) (pr2 y))). - simple refine (_ ,, _). + exact (BinProductPr1 _ (HC₁ (pr1 x) (pr1 y))). + exact (BinProductPr1 _ (HC₂ (pr2 x) (pr2 y))). - simple refine (_ ,, _). + exact (BinProductPr2 _ (HC₁ (pr1 x) (pr1 y))). + exact (BinProductPr2 _ (HC₂ (pr2 x) (pr2 y))). - use isBinProduct_in_product_category. + apply isBinProduct_BinProduct. + apply isBinProduct_BinProduct. Defined. End BinProductInProduct. Definition pr1_preserves_binproduct {C₁ C₂ : category} (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : preserves_binproduct (pr1_functor C₁ C₂). Proof. use preserves_binproduct_if_preserves_chosen. - apply binproducts_in_product_category. + exact HC₁. + exact HC₂. - intros x y. apply isBinProduct_BinProduct. Defined. Definition pr2_preserves_binproduct {C₁ C₂ : category} (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : preserves_binproduct (pr2_functor C₁ C₂). Proof. use preserves_binproduct_if_preserves_chosen. - apply binproducts_in_product_category. + exact HC₁. + exact HC₂. - intros x y. apply isBinProduct_BinProduct. Defined. Definition preserves_binproduct_bindelta_pair_functor {C D₁ D₂ : category} {F : C ⟶ D₁} {G : C ⟶ D₂} (HF : preserves_binproduct F) (HG : preserves_binproduct G) : preserves_binproduct (bindelta_pair_functor F G). Proof. intros x y z π₁ π₂ H. apply isBinProduct_in_product_category. - apply HF. apply H. - apply HG. apply H. Defined. (** 3. Pullbacks *) Section PullbackInProduct. Context {C₁ C₂ : category}. Section PullbackInProductCategoryUMP. Context {w x y z : category_binproduct C₁ C₂} {f : x --> z} {g : y --> z} (π₁ : w --> x) (π₂ : w --> y) (p : π₁ · f = π₂ · g) (H₁ : isPullback (maponpaths pr1 p)) (H₂ : isPullback (maponpaths dirprod_pr2 p)) {q : category_binproduct C₁ C₂} (h₁ : q --> x) (h₂ : q --> y) (r : h₁ · f = h₂ · g). Let P₁ : Pullback (pr1 f) (pr1 g) := make_Pullback _ H₁. Let P₂ : Pullback (pr2 f) (pr2 g) := make_Pullback _ H₂. Definition isPullback_in_product_category_unique : isaprop (∑ (hk : q --> w), hk · π₁ = h₁ × hk · π₂ = h₂). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use pathsdirprod. - use (MorphismsIntoPullbackEqual (pr22 P₁)). + exact (maponpaths pr1 (pr12 φ₁) @ !(maponpaths pr1 (pr12 φ₂))). + exact (maponpaths pr1 (pr22 φ₁) @ !(maponpaths pr1 (pr22 φ₂))). - use (MorphismsIntoPullbackEqual (pr22 P₂)). + exact (maponpaths dirprod_pr2 (pr12 φ₁) @ !(maponpaths dirprod_pr2 (pr12 φ₂))). + exact (maponpaths dirprod_pr2 (pr22 φ₁) @ !(maponpaths dirprod_pr2 (pr22 φ₂))). Qed. Definition isPullback_in_product_category_mor : q --> w := PullbackArrow P₁ _ (pr1 h₁) (pr1 h₂) (maponpaths pr1 r) ,, PullbackArrow P₂ _ (pr2 h₁) (pr2 h₂) (maponpaths dirprod_pr2 r). Definition isPullback_in_product_category_mor_pr1 : isPullback_in_product_category_mor · π₁ = h₁. Proof. use pathsdirprod ; cbn. - apply (PullbackArrow_PullbackPr1 P₁). - apply (PullbackArrow_PullbackPr1 P₂). Qed. Definition isPullback_in_product_category_mor_pr2 : isPullback_in_product_category_mor · π₂ = h₂. Proof. use pathsdirprod ; cbn. - apply (PullbackArrow_PullbackPr2 P₁). - apply (PullbackArrow_PullbackPr2 P₂). Qed. End PullbackInProductCategoryUMP. Definition isPullback_in_product_category {w x y z : category_binproduct C₁ C₂} {f : x --> z} {g : y --> z} (π₁ : w --> x) (π₂ : w --> y) (p : π₁ · f = π₂ · g) (H₁ : isPullback (maponpaths pr1 p)) (H₂ : isPullback (maponpaths dirprod_pr2 p)) : isPullback p. Proof. intros q h₁ h₂ r. use iscontraprop1. - exact (isPullback_in_product_category_unique π₁ π₂ p H₁ H₂ h₁ h₂). - simple refine (_ ,, _ ,, _). + exact (isPullback_in_product_category_mor π₁ π₂ p H₁ H₂ h₁ h₂ r). + apply isPullback_in_product_category_mor_pr1. + apply isPullback_in_product_category_mor_pr2. Defined. Definition pullbacks_in_product_category (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : Pullbacks (category_binproduct C₁ C₂). Proof. intros z x y f g. simple refine ((_ ,, _ ,, _) ,, (_ ,, _)). - refine (_ ,, _). + exact (PullbackObject (HC₁ _ _ _ (pr1 f) (pr1 g))). + exact (PullbackObject (HC₂ _ _ _ (pr2 f) (pr2 g))). - refine (_ ,, _). + apply PullbackPr1. + apply PullbackPr1. - refine (_ ,, _). + apply PullbackPr2. + apply PullbackPr2. - apply pathsdirprod. + apply PullbackSqrCommutes. + apply PullbackSqrCommutes. - use isPullback_in_product_category. + apply isPullback_Pullback. + apply isPullback_Pullback. Defined. End PullbackInProduct. Definition pr1_preserves_pullback {C₁ C₂ : category} (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : preserves_pullback (pr1_functor C₁ C₂). Proof. use preserves_pullback_if_preserves_chosen. - apply pullbacks_in_product_category. + exact HC₁. + exact HC₂. - intros x y z f g. apply isPullback_Pullback. Defined. Definition pr2_preserves_pullback {C₁ C₂ : category} (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : preserves_pullback (pr2_functor C₁ C₂). Proof. use preserves_pullback_if_preserves_chosen. - apply pullbacks_in_product_category. + exact HC₁. + exact HC₂. - intros x y z f g. apply isPullback_Pullback. Defined. Definition preserves_pullback_bindelta_pair_functor {C D₁ D₂ : category} {F : C ⟶ D₁} {G : C ⟶ D₂} (HF : preserves_pullback F) (HG : preserves_pullback G) : preserves_pullback (bindelta_pair_functor F G). Proof. intros w x y z f g π₁ π₂ p₁ p₂ H. apply isPullback_in_product_category. - exact (HF _ _ _ _ _ _ _ _ _ _ H). - exact (HG _ _ _ _ _ _ _ _ _ _ H). Defined. (** 4. Initial objects *) Section InitialProduct. Context {C₁ C₂ : category}. Definition isInitial_category_binproduct (x : category_binproduct C₁ C₂) (H₁ : isInitial C₁ (pr1 x)) (H₂ : isInitial C₂ (pr2 x)) : isInitial (category_binproduct C₁ C₂) x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use pathsdirprod ; [ exact (InitialArrowUnique (_ ,, H₁) _ _ @ !(InitialArrowUnique (_ ,, H₁) _ _)) | exact (InitialArrowUnique (_ ,, H₂) _ _ @ !(InitialArrowUnique (_ ,, H₂) _ _)) ]). - exact (InitialArrow (_ ,, H₁) (pr1 w) ,, InitialArrow (_ ,, H₂) (pr2 w)). Defined. Definition initial_category_binproduct (I₁ : Initial C₁) (I₂ : Initial C₂) : Initial (category_binproduct C₁ C₂) := (pr1 I₁ ,, pr1 I₂) ,, isInitial_category_binproduct (_ ,, _) (pr2 I₁) (pr2 I₂). End InitialProduct. Definition pr1_preserves_initial (C₁ C₂ : category) : preserves_initial (pr1_functor C₁ C₂). Proof. intros x Hx w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (maponpaths pr1 (InitialArrowUnique (x ,, Hx) (w ,, pr2 x) (φ₁ ,, identity _)) @ !_) ; exact (maponpaths pr1 (InitialArrowUnique (x ,, Hx) (w ,, pr2 x) (φ₂ ,, identity _)))). - exact (pr1 (InitialArrow (_ ,, Hx) (w ,, pr2 x))). Defined. Definition pr2_preserves_initial (C₁ C₂ : category) : preserves_initial (pr2_functor C₁ C₂). Proof. intros x Hx w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (maponpaths dirprod_pr2 (InitialArrowUnique (x ,, Hx) (pr1 x ,, w) (identity _ ,, φ₁)) @ !_) ; exact (maponpaths dirprod_pr2 (InitialArrowUnique (x ,, Hx) (pr1 x ,, w) (identity _ ,, φ₂)))). - exact (pr2 (InitialArrow (_ ,, Hx) (pr1 x ,, w))). Defined. Definition preserves_initial_bindelta_pair_functor {C D₁ D₂ : category} {F : C ⟶ D₁} {G : C ⟶ D₂} (HF : preserves_initial F) (HG : preserves_initial G) : preserves_initial (bindelta_pair_functor F G). Proof. intros x Hx. apply isInitial_category_binproduct. - apply HF. apply Hx. - apply HG. apply Hx. Defined. (** 5. Coproducts *) Section BinCoproductInProduct. Context {C₁ C₂ : category}. Definition isBinCoproduct_in_product_category {x y z : category_binproduct C₁ C₂} (i₁ : x --> z) (i₂ : y --> z) (H₁ : isBinCoproduct _ (pr1 x) (pr1 y) (pr1 z) (pr1 i₁) (pr1 i₂)) (H₂ : isBinCoproduct _ (pr2 x) (pr2 y) (pr2 z) (pr2 i₁) (pr2 i₂)) : isBinCoproduct _ x y z i₁ i₂. Proof. pose (P₁ := make_BinCoproduct _ _ _ _ _ _ H₁). pose (P₂ := make_BinCoproduct _ _ _ _ _ _ H₂). intros w f g. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; use pathsdirprod ; [ exact (BinCoproductArrowsEq _ _ _ P₁ _ _ _ (maponpaths pr1 (pr12 φ₁) @ !(maponpaths pr1 (pr12 φ₂))) (maponpaths pr1 (pr22 φ₁) @ !(maponpaths pr1 (pr22 φ₂)))) | exact (BinCoproductArrowsEq _ _ _ P₂ _ _ _ (maponpaths dirprod_pr2 (pr12 φ₁) @ !(maponpaths dirprod_pr2 (pr12 φ₂))) (maponpaths dirprod_pr2 (pr22 φ₁) @ !(maponpaths dirprod_pr2 (pr22 φ₂)))) ]). - simple refine ((_ ,, _) ,, _ ,, _). + exact (BinCoproductArrow P₁ (pr1 f) (pr1 g)). + exact (BinCoproductArrow P₂ (pr2 f) (pr2 g)). + abstract (use pathsdirprod ; [ apply (BinCoproductIn1Commutes _ _ _ P₁) | apply (BinCoproductIn1Commutes _ _ _ P₂)]). + abstract (use pathsdirprod ; [ apply (BinCoproductIn2Commutes _ _ _ P₁) | apply (BinCoproductIn2Commutes _ _ _ P₂)]). Defined. Definition bincoproducts_in_product_category (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : BinCoproducts (category_binproduct C₁ C₂). Proof. intros x y. use make_BinCoproduct. - simple refine (_ ,, _). + exact (BinCoproductObject (HC₁ (pr1 x) (pr1 y))). + exact (BinCoproductObject (HC₂ (pr2 x) (pr2 y))). - simple refine (_ ,, _). + exact (BinCoproductIn1 (HC₁ (pr1 x) (pr1 y))). + exact (BinCoproductIn1 (HC₂ (pr2 x) (pr2 y))). - simple refine (_ ,, _). + exact (BinCoproductIn2 (HC₁ (pr1 x) (pr1 y))). + exact (BinCoproductIn2 (HC₂ (pr2 x) (pr2 y))). - use isBinCoproduct_in_product_category. + apply isBinCoproduct_BinCoproduct. + apply isBinCoproduct_BinCoproduct. Defined. End BinCoproductInProduct. Definition pr1_preserves_bincoproduct {C₁ C₂ : category} (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : preserves_bincoproduct (pr1_functor C₁ C₂). Proof. use preserves_bincoproduct_if_preserves_chosen. - apply bincoproducts_in_product_category. + exact HC₁. + exact HC₂. - intros x y. apply isBinCoproduct_BinCoproduct. Defined. Definition pr2_preserves_bincoproduct {C₁ C₂ : category} (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : preserves_bincoproduct (pr2_functor C₁ C₂). Proof. use preserves_bincoproduct_if_preserves_chosen. - apply bincoproducts_in_product_category. + exact HC₁. + exact HC₂. - intros x y. apply isBinCoproduct_BinCoproduct. Defined. Definition preserves_bincoproduct_bindelta_pair_functor {C D₁ D₂ : category} {F : C ⟶ D₁} {G : C ⟶ D₂} (HF : preserves_bincoproduct F) (HG : preserves_bincoproduct G) : preserves_bincoproduct (bindelta_pair_functor F G). Proof. intros x y z π₁ π₂ H. apply isBinCoproduct_in_product_category. - apply HF. apply H. - apply HG. apply H. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/EilenbergMooreLimits.v000066400000000000000000001106501451125700300271550ustar00rootroot00000000000000(****************************************************************************** Limits in the Eilenberg-Moore category Contents 1. Terminal objects 2. Binary products 3. Pullbacks 4. Initial objects 5. Binary coproducts ******************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.categories.EilenbergMoore. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Local Open Scope cat. Section EilenbergMooreCategoryLimits. Context {C : category} (m : Monad C). (** 1. Terminal objects *) Definition terminal_obj_eilenberg_moore_cat (T : C) (HT : isTerminal _ T) : eilenberg_moore_cat m. Proof. use make_ob_eilenberg_moore. - exact T. - apply (TerminalArrow (_ ,, HT)). - apply (@TerminalArrowEq _ (_ ,, HT)). - apply (@TerminalArrowEq _ (_ ,, HT)). Defined. Definition is_terminal_obj_eilenberg_moore_cat (T : eilenberg_moore_cat m) (HT : isTerminal _ (pr11 T)) : isTerminal (eilenberg_moore_cat m) T. Proof. intro x. use make_iscontr. - use make_mor_eilenberg_moore. + apply (TerminalArrow (_ ,, HT)). + apply (@TerminalArrowEq _ (_ ,, HT)). - abstract (intro f ; use eq_mor_eilenberg_moore ; apply (@TerminalArrowEq _ (_ ,, HT))). Defined. Section Terminal. Context (T : Terminal C). Definition terminal_eilenberg_moore_cat : Terminal (eilenberg_moore_cat m). Proof. use make_Terminal. - exact (terminal_obj_eilenberg_moore_cat (pr1 T) (pr2 T)). - refine (is_terminal_obj_eilenberg_moore_cat _ _). exact (pr2 T). Defined. Definition eilenberg_moore_pr_preserves_terminal : preserves_terminal (eilenberg_moore_pr m). Proof. use preserves_terminal_if_preserves_chosen. - exact terminal_eilenberg_moore_cat. - unfold preserves_chosen_terminal. apply T. Defined. Definition functor_to_eilenberg_moore_cat_preserves_terminal {C' : category} (F : C' ⟶ C) (HF : preserves_terminal F) (α : F ∙ m ⟹ functor_identity C' ∙ F) (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x))) (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x) : preserves_terminal (functor_to_eilenberg_moore_cat m F α p₁ p₂). Proof. intros x Hx. use is_terminal_obj_eilenberg_moore_cat. apply HF. exact Hx. Defined. End Terminal. (** 2. Binary products *) Section IsBinaryProduct. Context {x y p : eilenberg_moore_cat m} (π₁ : p --> x) (π₂ : p --> y) (H : isBinProduct C _ _ _ (pr11 π₁) (pr11 π₂)). Let P : BinProduct C (pr11 x) (pr11 y) := make_BinProduct _ _ _ _ _ _ H. Definition isBinProduct_eilenberg_moore_cat_unique {w : eilenberg_moore_cat m} (f : w --> x) (g : w --> y) : isaprop (∑ (k : w --> p), k · π₁ = f × k · π₂ = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_mor_eilenberg_moore. use (BinProductArrowsEq _ _ _ P). - exact (maponpaths (λ z, pr11 z) (pr12 φ₁) @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))). - exact (maponpaths (λ z, pr11 z) (pr22 φ₁) @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))). Qed. Definition isBinProduct_eilenberg_moore_cat_mor {w : eilenberg_moore_cat m} (f : w --> x) (g : w --> y) : w --> p. Proof. use make_mor_eilenberg_moore. - exact (BinProductArrow _ P (pr11 f) (pr11 g)). - use (BinProductArrowsEq _ _ _ P). + abstract (rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (BinProductPr1Commutes _ _ _ P) | ] ; refine (eq_of_eilenberg_moore_mor f @ !_) ; etrans ; [ apply maponpaths ; exact (pr21 π₁) | ] ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- functor_comp ; apply maponpaths ; apply (BinProductPr1Commutes _ _ _ P)). + abstract (rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (BinProductPr2Commutes _ _ _ P) | ] ; refine (eq_of_eilenberg_moore_mor g @ !_) ; etrans ; [ apply maponpaths ; exact (pr21 π₂) | ] ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- functor_comp ; apply maponpaths ; apply (BinProductPr2Commutes _ _ _ P)). Defined. Definition isBinProduct_eilenberg_moore_cat_pr1 {w : eilenberg_moore_cat m} (f : w --> x) (g : w --> y) : isBinProduct_eilenberg_moore_cat_mor f g · π₁ = f. Proof. use eq_mor_eilenberg_moore. apply (BinProductPr1Commutes _ _ _ P). Qed. Definition isBinProduct_eilenberg_moore_cat_pr2 {w : eilenberg_moore_cat m} (f : w --> x) (g : w --> y) : isBinProduct_eilenberg_moore_cat_mor f g · π₂ = g. Proof. use eq_mor_eilenberg_moore. apply (BinProductPr2Commutes _ _ _ P). Qed. Definition isBinProduct_eilenberg_moore_cat : isBinProduct _ x y p π₁ π₂. Proof. use make_isBinProduct. intros w f g. use iscontraprop1. - exact (isBinProduct_eilenberg_moore_cat_unique f g). - simple refine (_ ,, _ ,, _). + exact (isBinProduct_eilenberg_moore_cat_mor f g). + exact (isBinProduct_eilenberg_moore_cat_pr1 f g). + exact (isBinProduct_eilenberg_moore_cat_pr2 f g). Defined. End IsBinaryProduct. Section BinaryProducts. Context (P : BinProducts C). Definition BinProduct_obj_eilenberg_moore_cat_ob (x y : eilenberg_moore_cat m) : C := pr11 (P (pr11 x) (pr11 y)). Definition BinProduct_obj_eilenberg_moore_cat_mor (x y : eilenberg_moore_cat m) : m (BinProduct_obj_eilenberg_moore_cat_ob x y) --> BinProduct_obj_eilenberg_moore_cat_ob x y. Proof. use BinProductArrow. - exact (# m (BinProductPr1 _ _) · pr21 x). - exact (# m (BinProductPr2 _ _) · pr21 y). Defined. Definition BinProduct_obj_eilenberg_moore_cat_unit (x y : eilenberg_moore_cat m) : η m (BinProduct_obj_eilenberg_moore_cat_ob x y) · BinProduct_obj_eilenberg_moore_cat_mor x y = identity _. Proof. use BinProductArrowsEq. - rewrite !assoc', id_left. etrans. { apply maponpaths. apply BinProductPr1Commutes. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (η m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr12 x). } apply id_right. - rewrite !assoc', id_left. etrans. { apply maponpaths. apply BinProductPr2Commutes. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (η m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr12 y). } apply id_right. Qed. Definition BinProduct_obj_eilenberg_moore_cat_mult (x y : eilenberg_moore_cat m) : μ m (BinProduct_obj_eilenberg_moore_cat_ob x y) · BinProduct_obj_eilenberg_moore_cat_mor x y = # m (BinProduct_obj_eilenberg_moore_cat_mor x y) · BinProduct_obj_eilenberg_moore_cat_mor x y. Proof. use BinProductArrowsEq. - rewrite !assoc'. etrans. { apply maponpaths. apply BinProductPr1Commutes. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (μ m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply (pr22 x). } refine (!_). etrans. { apply maponpaths. apply BinProductPr1Commutes. } rewrite !assoc. apply maponpaths_2. rewrite <- !functor_comp. apply maponpaths. apply BinProductPr1Commutes. - rewrite !assoc'. etrans. { apply maponpaths. apply BinProductPr2Commutes. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (μ m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply (pr22 y). } refine (!_). etrans. { apply maponpaths. apply BinProductPr2Commutes. } rewrite !assoc. apply maponpaths_2. rewrite <- !functor_comp. apply maponpaths. apply BinProductPr2Commutes. Qed. Definition BinProduct_obj_eilenberg_moore_cat (x y : eilenberg_moore_cat m) : eilenberg_moore_cat m. Proof. use make_ob_eilenberg_moore. - exact (BinProduct_obj_eilenberg_moore_cat_ob x y). - exact (BinProduct_obj_eilenberg_moore_cat_mor x y). - exact (BinProduct_obj_eilenberg_moore_cat_unit x y). - exact (BinProduct_obj_eilenberg_moore_cat_mult x y). Defined. Definition BinProduct_pr1_eilenberg_moore_cat (x y : eilenberg_moore_cat m) : BinProduct_obj_eilenberg_moore_cat x y --> x. Proof. use make_mor_eilenberg_moore. - apply BinProductPr1. - apply BinProductPr1Commutes. Defined. Definition BinProduct_pr2_eilenberg_moore_cat (x y : eilenberg_moore_cat m) : BinProduct_obj_eilenberg_moore_cat x y --> y. Proof. use make_mor_eilenberg_moore. - apply BinProductPr2. - apply BinProductPr2Commutes. Defined. Definition BinProducts_eilenberg_moore_cat : BinProducts (eilenberg_moore_cat m). Proof. intros x y. use make_BinProduct. - exact (BinProduct_obj_eilenberg_moore_cat x y). - exact (BinProduct_pr1_eilenberg_moore_cat x y). - exact (BinProduct_pr2_eilenberg_moore_cat x y). - apply isBinProduct_eilenberg_moore_cat. apply P. Defined. Definition eilenberg_moore_pr_preserves_binproduct : preserves_binproduct (eilenberg_moore_pr m). Proof. use preserves_binproduct_if_preserves_chosen. - exact BinProducts_eilenberg_moore_cat. - intros x y. apply P. Defined. Definition functor_to_eilenberg_moore_cat_preserves_binproduct {C' : category} (F : C' ⟶ C) (HF : preserves_binproduct F) (α : F ∙ m ⟹ functor_identity C' ∙ F) (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x))) (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x) : preserves_binproduct (functor_to_eilenberg_moore_cat m F α p₁ p₂). Proof. intros x y p π₁ π₂ Hx. use isBinProduct_eilenberg_moore_cat. apply HF. exact Hx. Defined. End BinaryProducts. (** 3. Pullbacks *) Section IsPullback. Context {x y z : eilenberg_moore_cat m} {f : x --> z} {g : y --> z} {pb : eilenberg_moore_cat m} {π₁ : pb --> x} {π₂ : pb --> y} (q : π₁ · f = π₂ · g) (q' : pr11 π₁ · pr11 f = pr11 π₂ · pr11 g) (H : @isPullback C (pr11 z) (pr11 x) (pr11 y) (pr11 pb) (pr11 f) (pr11 g) (pr11 π₁) (pr11 π₂) q'). Section UMP. Context {w : eilenberg_moore_cat m} (h : w --> x) (k : w --> y) (r : h · f = k · g). Definition isPullback_eilenberg_moore_unique : isaprop (∑ (hk : w --> pb), hk · π₁ = h × hk · π₂ = k). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_mor_eilenberg_moore. use (MorphismsIntoPullbackEqual H). - exact (maponpaths (λ z, pr11 z) (pr12 φ₁ @ !(pr12 φ₂))). - exact (maponpaths (λ z, pr11 z) (pr22 φ₁ @ !(pr22 φ₂))). Qed. Definition isPullback_eilenberg_moore_mor : w --> pb. Proof. use make_mor_eilenberg_moore. - use (PullbackArrow (make_Pullback _ H)). + exact (mor_of_eilenberg_moore_mor h). + exact (mor_of_eilenberg_moore_mor k). + exact (maponpaths (λ z, pr11 z) r). - use (MorphismsIntoPullbackEqual H). + abstract (rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (PullbackArrow_PullbackPr1 (make_Pullback _ H)) | ] ; refine (!_) ; etrans ; [ apply maponpaths ; exact (pr21 π₁) | ] ; rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply (PullbackArrow_PullbackPr1 (make_Pullback _ H)) | ] ; exact (!(eq_of_eilenberg_moore_mor h))). + abstract (rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (PullbackArrow_PullbackPr2 (make_Pullback _ H)) | ] ; refine (!_) ; etrans ; [ apply maponpaths ; exact (pr21 π₂) | ] ; rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply (PullbackArrow_PullbackPr2 (make_Pullback _ H)) | ] ; exact (!(eq_of_eilenberg_moore_mor k))). Defined. End UMP. Definition isPullback_eilenberg_moore : isPullback q. Proof. intros w h k r. use iscontraprop1. - exact (isPullback_eilenberg_moore_unique h k). - simple refine (_ ,, _ ,, _). + exact (isPullback_eilenberg_moore_mor h k r). + abstract (use eq_mor_eilenberg_moore ; apply (PullbackArrow_PullbackPr1 (make_Pullback _ H))). + abstract (use eq_mor_eilenberg_moore ; apply (PullbackArrow_PullbackPr2 (make_Pullback _ H))). Defined. End IsPullback. Section Pullbacks. Context (PB : Pullbacks C). Section PullbackCone. Context {x y z : eilenberg_moore_cat m} (f : x --> z) (g : y --> z). Definition ob_of_pullbacks_eilenberg_moore_ob : C := PB _ _ _ (pr11 f) (pr11 g). Definition mor_of_pullbacks_eilenberg_moore_ob : m ob_of_pullbacks_eilenberg_moore_ob --> ob_of_pullbacks_eilenberg_moore_ob. Proof. use PullbackArrow. - exact (# m (PullbackPr1 (PB _ _ _ (pr11 f) (pr11 g))) · pr21 x). - exact (# m (PullbackPr2 (PB _ _ _ (pr11 f) (pr11 g))) · pr21 y). - abstract (rewrite !assoc' ; refine (maponpaths (λ z, _ · z) (pr21 f) @ _) ; refine (_ @ !(maponpaths (λ z, _ · z) (pr21 g))) ; rewrite !assoc ; rewrite <- !functor_comp ; apply maponpaths_2 ; apply maponpaths ; apply PullbackSqrCommutes). Defined. Definition pullbacks_eilenberg_moore_ob_unit : η m ob_of_pullbacks_eilenberg_moore_ob · mor_of_pullbacks_eilenberg_moore_ob = identity _. Proof. use (MorphismsIntoPullbackEqual (pr22 (PB _ _ _ (pr11 f) (pr11 g)))) ; unfold mor_of_pullbacks_eilenberg_moore_ob. - rewrite !assoc', id_left. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr1. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (η m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr12 x). } apply id_right. - rewrite !assoc', id_left. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr2. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (η m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr12 y). } apply id_right. Qed. Definition pullbacks_eilenberg_moore_ob_mult : μ m ob_of_pullbacks_eilenberg_moore_ob · mor_of_pullbacks_eilenberg_moore_ob = # m mor_of_pullbacks_eilenberg_moore_ob · mor_of_pullbacks_eilenberg_moore_ob. Proof. use (MorphismsIntoPullbackEqual (pr22 (PB _ _ _ (pr11 f) (pr11 g)))) ; unfold mor_of_pullbacks_eilenberg_moore_ob. - rewrite !assoc'. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr1. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (μ m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr22 x). } rewrite !assoc. rewrite <- functor_comp. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr1. } rewrite !assoc. apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply PullbackArrow_PullbackPr1. - rewrite !assoc'. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr2. } rewrite !assoc. etrans. { apply maponpaths_2. refine (!_). apply (nat_trans_ax (μ m)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr22 y). } rewrite !assoc. rewrite <- functor_comp. refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply PullbackArrow_PullbackPr2. } rewrite !assoc. apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply PullbackArrow_PullbackPr2. Qed. Definition pullbacks_eilenberg_moore_ob : eilenberg_moore_cat m. Proof. use make_ob_eilenberg_moore. - exact ob_of_pullbacks_eilenberg_moore_ob. - exact mor_of_pullbacks_eilenberg_moore_ob. - exact pullbacks_eilenberg_moore_ob_unit. - exact pullbacks_eilenberg_moore_ob_mult. Defined. Definition pullbacks_eilenberg_moore_pr1 : pullbacks_eilenberg_moore_ob --> x. Proof. use make_mor_eilenberg_moore. - apply PullbackPr1. - apply PullbackArrow_PullbackPr1. Defined. Definition pullbacks_eilenberg_moore_pr2 : pullbacks_eilenberg_moore_ob --> y. Proof. use make_mor_eilenberg_moore. - apply PullbackPr2. - apply PullbackArrow_PullbackPr2. Defined. Definition pullbacks_eilenberg_moore_eq : pullbacks_eilenberg_moore_pr1 · f = pullbacks_eilenberg_moore_pr2 · g. Proof. use eq_mor_eilenberg_moore. apply PullbackSqrCommutes. Qed. End PullbackCone. Definition Pullbacks_eilenberg_moore : Pullbacks (eilenberg_moore_cat m). Proof. intros x y z f g. use make_Pullback. - exact (pullbacks_eilenberg_moore_ob f g). - exact (pullbacks_eilenberg_moore_pr1 f g). - exact (pullbacks_eilenberg_moore_pr2 f g). - exact (pullbacks_eilenberg_moore_eq f g). - refine (isPullback_eilenberg_moore _ _ _). exact (pr22 (PB _ _ _ (pr11 f) (pr11 g))). Defined. Definition eilenberg_moore_pr_preserves_pullback : preserves_pullback (eilenberg_moore_pr m). Proof. use preserves_pullback_if_preserves_chosen. - exact Pullbacks_eilenberg_moore. - intro ; intros. apply PB. Defined. Definition functor_to_eilenberg_moore_cat_preserves_pullback {C' : category} (F : C' ⟶ C) (HF : preserves_pullback F) (α : F ∙ m ⟹ functor_identity C' ∙ F) (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x))) (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x) : preserves_pullback (functor_to_eilenberg_moore_cat m F α p₁ p₂). Proof. intros ? ? ? ? ? ? ? ? ? ? Hx. use isPullback_eilenberg_moore. - abstract (cbn ; rewrite <- !functor_comp ; apply maponpaths ; exact q). - use HF. + exact q. + exact Hx. Defined. End Pullbacks. (** 4. Initial objects *) Definition is_initial_eilenberg_moore_cat (I : eilenberg_moore_cat m) (HI : isInitial _ (pr11 I)) (Hm : preserves_initial m) : isInitial (eilenberg_moore_cat m) I. Proof. use make_isInitial. intro x. use make_iscontr. - use make_mor_eilenberg_moore. + apply (InitialArrow (make_Initial _ HI)). + apply (@InitialArrowEq _ (make_Initial _ (Hm _ HI))). - abstract (intro f ; use eq_mor_eilenberg_moore ; apply (@InitialArrowEq _ (make_Initial _ HI))). Defined. Section Initial. Context (I : Initial C) (Hm : preserves_initial m). Definition initial_obj_eilenberg_moore_cat : eilenberg_moore_cat m. Proof. use make_ob_eilenberg_moore. - exact I. - apply (InitialArrow (make_Initial _ (Hm I (pr2 I)))). - apply InitialArrowEq. - apply (@InitialArrowEq _ (make_Initial _ (Hm _ (Hm I (pr2 I))))). Defined. Definition initial_eilenberg_moore_cat : Initial (eilenberg_moore_cat m). Proof. use make_Initial. - exact initial_obj_eilenberg_moore_cat. - apply is_initial_eilenberg_moore_cat. + exact (pr2 I). + exact Hm. Defined. Definition eilenberg_moore_pr_preserves_initial : preserves_initial (eilenberg_moore_pr m). Proof. use preserves_initial_if_preserves_chosen. - exact initial_eilenberg_moore_cat. - apply I. Defined. Definition functor_to_eilenberg_moore_cat_preserves_initial {C' : category} (F : C' ⟶ C) (HF : preserves_initial F) (α : F ∙ m ⟹ functor_identity C' ∙ F) (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x))) (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x) : preserves_initial (functor_to_eilenberg_moore_cat m F α p₁ p₂). Proof. intros x Hx. use is_initial_eilenberg_moore_cat. - apply HF. exact Hx. - exact Hm. Defined. End Initial. (** 5. Binary coproducts *) Section IsBinaryCoproduct. Context (Hm : preserves_bincoproduct m) {x y sum : eilenberg_moore_cat m} (ι₁ : x --> sum) (ι₂ : y --> sum) (H : isBinCoproduct _ _ _ _ (pr11 ι₁) (pr11 ι₂)). Let copr : BinCoproduct (pr11 x) (pr11 y) := make_BinCoproduct _ _ _ _ _ _ H. Section UMP. Context {w : eilenberg_moore_cat m} (f : x --> w) (g : y --> w). Definition isBinCoproduct_eilenberg_moore_unique : isaprop (∑ (fg : sum --> w), ι₁ · fg = f × ι₂ · fg = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_mor_eilenberg_moore. use (BinCoproductArrowsEq _ _ _ copr). - exact (maponpaths (λ z, pr11 z) (pr12 φ₁ @ !(pr12 φ₂))). - exact (maponpaths (λ z, pr11 z) (pr22 φ₁ @ !(pr22 φ₂))). Qed. Definition isBinCoproduct_eilenberg_moore_mor : sum --> w. Proof. use make_mor_eilenberg_moore. - exact (BinCoproductArrow copr (pr11 f) (pr11 g)). - use (BinCoproductArrowsEq _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ H))) ; cbn. + abstract (rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; exact (!(eq_of_eilenberg_moore_mor ι₁)) | ] ; rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (BinCoproductIn1Commutes _ _ _ copr) | ] ; refine (!_) ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply (BinCoproductIn1Commutes _ _ _ copr) | ] ; exact (!(eq_of_eilenberg_moore_mor f))). + abstract (rewrite !assoc ; rewrite <- functor_comp ; etrans ; [ apply maponpaths_2 ; exact (!(eq_of_eilenberg_moore_mor ι₂)) | ] ; rewrite !assoc' ; etrans ; [ apply maponpaths ; apply (BinCoproductIn2Commutes _ _ _ copr) | ] ; refine (!_) ; etrans ; [ apply maponpaths_2 ; apply maponpaths ; apply (BinCoproductIn2Commutes _ _ _ copr) | ] ; exact (!(eq_of_eilenberg_moore_mor g))). Defined. Definition isBinCoproduct_eilenberg_moore_in1 : ι₁ · isBinCoproduct_eilenberg_moore_mor = f. Proof. use eq_mor_eilenberg_moore. apply (BinCoproductIn1Commutes _ _ _ copr). Qed. Definition isBinCoproduct_eilenberg_moore_in2 : ι₂ · isBinCoproduct_eilenberg_moore_mor = g. Proof. use eq_mor_eilenberg_moore. apply (BinCoproductIn2Commutes _ _ _ copr). Qed. End UMP. Definition isBinCoproduct_eilenberg_moore : isBinCoproduct _ _ _ _ ι₁ ι₂. Proof. intros w f g. use iscontraprop1. - exact (isBinCoproduct_eilenberg_moore_unique f g). - simple refine (_ ,, _ ,, _). + exact (isBinCoproduct_eilenberg_moore_mor f g). + exact (isBinCoproduct_eilenberg_moore_in1 f g). + exact (isBinCoproduct_eilenberg_moore_in2 f g). Defined. End IsBinaryCoproduct. Section BinaryCoproducts. Context (P : BinCoproducts C) (Hm : preserves_bincoproduct m). Definition bincoproduct_obj_eilenberg_moore_ob (x y : eilenberg_moore_cat m) : C := pr11 (P (pr11 x) (pr11 y)). Definition bincoproduct_obj_eilenberg_moore_ob_mor (x y : eilenberg_moore_cat m) : m (bincoproduct_obj_eilenberg_moore_ob x y) --> bincoproduct_obj_eilenberg_moore_ob x y. Proof. use (BinCoproductArrow (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). - exact (pr21 x · BinCoproductIn1 _). - exact (pr21 y · BinCoproductIn2 _). Defined. Definition bincoproduct_obj_eilenberg_moore_ob_unit (x y : eilenberg_moore_cat m) : η m (bincoproduct_obj_eilenberg_moore_ob x y) · bincoproduct_obj_eilenberg_moore_ob_mor x y = identity _. Proof. use BinCoproductArrowsEq ; unfold bincoproduct_obj_eilenberg_moore_ob_mor. - rewrite id_right. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax (η m)). } rewrite !assoc'. etrans. { apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite !assoc. etrans. { apply maponpaths_2. exact (pr12 x). } apply id_left. - rewrite id_right. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax (η m)). } rewrite !assoc'. etrans. { apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite !assoc. etrans. { apply maponpaths_2. exact (pr12 y). } apply id_left. Qed. Definition bincoproduct_obj_eilenberg_moore_ob_mult (x y : eilenberg_moore_cat m) : μ m (bincoproduct_obj_eilenberg_moore_ob x y) · bincoproduct_obj_eilenberg_moore_ob_mor x y = # m (bincoproduct_obj_eilenberg_moore_ob_mor x y) · bincoproduct_obj_eilenberg_moore_ob_mor x y. Proof. use (BinCoproductArrowsEq _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))) ; unfold bincoproduct_obj_eilenberg_moore_ob_mor ; cbn. - rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax (μ m)). } rewrite !assoc'. etrans. { apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite !assoc. etrans. { apply maponpaths_2. exact (pr22 x). } refine (!_). etrans. { apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). - rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax (μ m)). } rewrite !assoc'. etrans. { apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite !assoc. etrans. { apply maponpaths_2. exact (pr22 y). } refine (!_). etrans. { apply maponpaths_2. rewrite <- functor_comp. apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). } rewrite functor_comp. rewrite !assoc'. apply maponpaths. apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))). Qed. Definition bincoproduct_obj_eilenberg_moore (x y : eilenberg_moore_cat m) : eilenberg_moore_cat m. Proof. use make_ob_eilenberg_moore. - exact (bincoproduct_obj_eilenberg_moore_ob x y). - exact (bincoproduct_obj_eilenberg_moore_ob_mor x y). - exact (bincoproduct_obj_eilenberg_moore_ob_unit x y). - exact (bincoproduct_obj_eilenberg_moore_ob_mult x y). Defined. Definition bincoproduct_eilenberg_moore_in1 (x y : eilenberg_moore_cat m) : x --> bincoproduct_obj_eilenberg_moore x y. Proof. use make_mor_eilenberg_moore. - apply BinCoproductIn1. - abstract (refine (!_) ; apply (BinCoproductIn1Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))). Defined. Definition bincoproduct_eilenberg_moore_in2 (x y : eilenberg_moore_cat m) : y --> bincoproduct_obj_eilenberg_moore x y. Proof. use make_mor_eilenberg_moore. - apply BinCoproductIn2. - abstract (refine (!_) ; apply (BinCoproductIn2Commutes _ _ _ (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))). Defined. Definition bincoproducts_eilenberg_moore : BinCoproducts (eilenberg_moore_cat m). Proof. intros x y. use make_BinCoproduct. - exact (bincoproduct_obj_eilenberg_moore x y). - exact (bincoproduct_eilenberg_moore_in1 x y). - exact (bincoproduct_eilenberg_moore_in2 x y). - use isBinCoproduct_eilenberg_moore. + exact Hm. + exact (pr2 (P (pr11 x) (pr11 y))). Defined. Definition eilenberg_moore_pr_preserves_bincoproduct : preserves_bincoproduct (eilenberg_moore_pr m). Proof. use preserves_bincoproduct_if_preserves_chosen. - exact bincoproducts_eilenberg_moore. - intros x y. apply P. Defined. Definition functor_to_eilenberg_moore_cat_preserves_bincoproduct {C' : category} (F : C' ⟶ C) (HF : preserves_bincoproduct F) (α : F ∙ m ⟹ functor_identity C' ∙ F) (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x))) (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x) : preserves_bincoproduct (functor_to_eilenberg_moore_cat m F α p₁ p₂). Proof. intros x y p π₁ π₂ Hx. use isBinCoproduct_eilenberg_moore. - exact Hm. - apply HF. exact Hx. Defined. End BinaryCoproducts. End EilenbergMooreCategoryLimits. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/IsoCommaLimits.v000066400000000000000000000723131451125700300257710ustar00rootroot00000000000000(************************************************************************ Limits and colimits in the iso-comma category Contents 1. Terminal objects 2. Products 3. Pullbacks 4. Initial objects 5. Coproducts ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.IsoCommaCategory. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Local Open Scope cat. Section IsoCommaLimits. Context {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₃) (G : C₂ ⟶ C₃). (** 1. Terminal objects *) Section TerminalObject. Context (HF : preserves_terminal F) (HG : preserves_terminal G). Definition isTerminal_iso_comma (x : iso_comma F G) (H₁ : isTerminal C₁ (pr11 x)) (H₂ : isTerminal C₂ (pr21 x)) : isTerminal (iso_comma F G) x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use eq_iso_comma_mor ; [ apply (@TerminalArrowEq _ (make_Terminal _ H₁)) | apply (@TerminalArrowEq _ (make_Terminal _ H₂)) ]). - refine ((TerminalArrow (_ ,, H₁) (pr11 w) ,, TerminalArrow (_ ,, H₂) (pr21 w)) ,, _). apply (@TerminalArrowEq _ (make_Terminal _ (HG _ H₂))). Defined. Definition terminal_category_iso_comma (T₁ : Terminal C₁) (T₂ : Terminal C₂) : Terminal (iso_comma F G). Proof. simple refine (_ ,, _). - refine ((pr1 T₁ ,, pr1 T₂) ,, _) ; cbn. exact (z_iso_Terminals (make_Terminal _ (HF _ (pr2 T₁))) (make_Terminal _ (HG _ (pr2 T₂)))). - apply isTerminal_iso_comma. + exact (pr2 T₁). + exact (pr2 T₂). Defined. Definition iso_comma_pr1_preserves_terminal (T₁ : Terminal C₁) (T₂ : Terminal C₂) : preserves_terminal (iso_comma_pr1 F G). Proof. apply (preserves_terminal_if_preserves_chosen (terminal_category_iso_comma T₁ T₂) (iso_comma_pr1 F G)). exact (pr2 T₁). Defined. Definition iso_comma_pr2_preserves_terminal (T₁ : Terminal C₁) (T₂ : Terminal C₂) : preserves_terminal (iso_comma_pr2 F G). Proof. apply (preserves_terminal_if_preserves_chosen (terminal_category_iso_comma T₁ T₂) (iso_comma_pr2 F G)). exact (pr2 T₂). Defined. Definition iso_comma_ump1_preserves_terminal {C₀ : category} (H₁ : C₀ ⟶ C₁) (HH₁ : preserves_terminal H₁) (H₂ : C₀ ⟶ C₂) (HH₂ : preserves_terminal H₂) (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G)) : preserves_terminal (iso_comma_ump1 F G H₁ H₂ α). Proof. intros x Hx. apply isTerminal_iso_comma. - apply HH₁. exact Hx. - apply HH₂. exact Hx. Defined. End TerminalObject. (** 2. Products *) Section Product. Context (HF : preserves_binproduct F) (HG : preserves_binproduct G). Section IsProductInIsoComma. Context {x y z : iso_comma F G} (p₁ : z --> x) (p₂ : z --> y) (H₁ : isBinProduct _ (pr11 x) (pr11 y) (pr11 z) (pr11 p₁) (pr11 p₂)) (H₂ : isBinProduct _ (pr21 x) (pr21 y) (pr21 z) (pr21 p₁) (pr21 p₂)). Let P₁ : BinProduct C₁ (pr11 x) (pr11 y) := make_BinProduct _ _ _ _ _ _ H₁. Let P₂ : BinProduct C₂ (pr21 x) (pr21 y) := make_BinProduct _ _ _ _ _ _ H₂. Section UMP. Context {w : iso_comma F G} (f : w --> x) (g : w --> y). Definition isBinProduct_in_iso_comma_unique : isaprop (∑ (fg : w --> z), fg · p₁ = f × fg · p₂ = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_iso_comma_mor. - use (BinProductArrowsEq _ _ _ P₁). + exact (maponpaths (λ z, pr11 z) (pr12 φ₁) @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))). + exact (maponpaths (λ z, pr11 z) (pr22 φ₁) @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))). - use (BinProductArrowsEq _ _ _ P₂). + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁) @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))). + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁) @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))). Qed. Definition isBinProduct_in_iso_comma_ump : w --> z. Proof. simple refine ((_ ,, _) ,, _) ; cbn. - exact (BinProductArrow _ P₁ (pr11 f) (pr11 g)). - exact (BinProductArrow _ P₂ (pr21 f) (pr21 g)). - use (BinProductArrowsEq _ _ _ (make_BinProduct _ _ _ _ _ _ (HG _ _ _ _ _ (pr2 P₂)))) ; cbn. + abstract (rewrite !assoc' ; rewrite <- functor_comp ; rewrite (BinProductPr1Commutes _ _ _ P₂) ; refine (_ @ pr2 f) ; refine (!(maponpaths (λ z, _ · z) (pr2 p₁)) @ _) ; rewrite !assoc ; rewrite <- functor_comp ; rewrite (BinProductPr1Commutes _ _ _ P₁) ; apply idpath). + abstract (rewrite !assoc' ; rewrite <- functor_comp ; rewrite (BinProductPr2Commutes _ _ _ P₂) ; refine (_ @ pr2 g) ; refine (!(maponpaths (λ z, _ · z) (pr2 p₂)) @ _) ; rewrite !assoc ; rewrite <- functor_comp ; rewrite (BinProductPr2Commutes _ _ _ P₁) ; apply idpath). Defined. Definition isBinProduct_in_iso_comma_ump_pr1 : isBinProduct_in_iso_comma_ump · p₁ = f. Proof. use eq_iso_comma_mor ; cbn. - apply (BinProductPr1Commutes _ _ _ P₁). - apply (BinProductPr1Commutes _ _ _ P₂). Qed. Definition isBinProduct_in_iso_comma_ump_pr2 : isBinProduct_in_iso_comma_ump · p₂ = g. Proof. use eq_iso_comma_mor ; cbn. - apply (BinProductPr2Commutes _ _ _ P₁). - apply (BinProductPr2Commutes _ _ _ P₂). Qed. End UMP. Definition isBinProduct_in_iso_comma : isBinProduct (iso_comma F G) x y z p₁ p₂. Proof. intros w f g. use iscontraprop1. - exact (isBinProduct_in_iso_comma_unique f g). - simple refine (_ ,, _ ,, _). + exact (isBinProduct_in_iso_comma_ump f g). + exact (isBinProduct_in_iso_comma_ump_pr1 f g). + exact (isBinProduct_in_iso_comma_ump_pr2 f g). Defined. End IsProductInIsoComma. Definition binproducts_in_iso_comma (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : BinProducts (iso_comma F G). Proof. intros x y. pose (FP := make_BinProduct _ _ _ _ _ _ (HF (pr11 x) (pr11 y) _ (BinProductPr1 _ (HC₁ (pr11 x) (pr11 y))) (BinProductPr2 _ (HC₁ (pr11 x) (pr11 y))) (isBinProduct_BinProduct _ (HC₁ (pr11 x) (pr11 y))))). pose (GP := make_BinProduct _ _ _ _ _ _ (HG (pr21 x) (pr21 y) _ (BinProductPr1 _ (HC₂ (pr21 x) (pr21 y))) (BinProductPr2 _ (HC₂ (pr21 x) (pr21 y))) (isBinProduct_BinProduct _ (HC₂ (pr21 x) (pr21 y))))). use make_BinProduct. - simple refine ((_ ,, _) ,, _). + exact (BinProductObject _ (HC₁ (pr11 x) (pr11 y))). + exact (BinProductObject _ (HC₂ (pr21 x) (pr21 y))). + exact (binproduct_of_z_iso FP GP (pr2 x) (pr2 y)). - simple refine ((_ ,, _) ,, _). + exact (BinProductPr1 _ (HC₁ (pr11 x) (pr11 y))). + exact (BinProductPr1 _ (HC₂ (pr21 x) (pr21 y))). + exact (!(BinProductOfArrowsPr1 _ GP FP (pr12 x) (pr12 y))). - simple refine ((_ ,, _) ,, _). + exact (BinProductPr2 _ (HC₁ (pr11 x) (pr11 y))). + exact (BinProductPr2 _ (HC₂ (pr21 x) (pr21 y))). + exact (!(BinProductOfArrowsPr2 _ GP FP (pr12 x) (pr12 y))). - use isBinProduct_in_iso_comma. + apply isBinProduct_BinProduct. + apply isBinProduct_BinProduct. Defined. Definition iso_comma_pr1_preserves_binproduct (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : preserves_binproduct (iso_comma_pr1 F G). Proof. use preserves_binproduct_if_preserves_chosen. - apply binproducts_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y. cbn. apply isBinProduct_BinProduct. Defined. Definition iso_comma_pr2_preserves_binproduct (HC₁ : BinProducts C₁) (HC₂ : BinProducts C₂) : preserves_binproduct (iso_comma_pr2 F G). Proof. use preserves_binproduct_if_preserves_chosen. - apply binproducts_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y. cbn. apply isBinProduct_BinProduct. Defined. Definition iso_comma_ump1_preserves_binproduct {C₀ : category} (H₁ : C₀ ⟶ C₁) (HH₁ : preserves_binproduct H₁) (H₂ : C₀ ⟶ C₂) (HH₂ : preserves_binproduct H₂) (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G)) : preserves_binproduct (iso_comma_ump1 F G H₁ H₂ α). Proof. intros x y z π₁ π₂ Hx. apply isBinProduct_in_iso_comma. - apply HH₁. exact Hx. - apply HH₂. exact Hx. Defined. End Product. (** 3. Pullbacks *) Section Pullbacks. Context (HF : preserves_pullback F) (HG : preserves_pullback G). Section IsPullbackIsoComma. Context {pb x y z : iso_comma F G} (f : x --> z) (g : y --> z) (π₁ : pb --> x) (π₂ : pb --> y) (sqr₁ : pr11 π₁ · pr11 f = pr11 π₂ · pr11 g) (H₁ : isPullback sqr₁) (sqr₂ : pr21 π₁ · pr21 f = pr21 π₂ · pr21 g) (H₂ : isPullback sqr₂) (sqr₃ : π₁ · f = π₂ · g). Let P₁ : Pullback (pr11 f) (pr11 g) := make_Pullback _ H₁. Let P₂ : Pullback (pr21 f) (pr21 g) := make_Pullback _ H₂. Section UMP. Context {w : iso_comma F G} (h₁ : w --> x) (h₂ : w --> y) (p : h₁ · f = h₂ · g). Definition isPullback_iso_comma_unique : isaprop (∑ (hk : w --> pb), hk · π₁ = h₁ × hk · π₂ = h₂). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_iso_comma_mor. - use (MorphismsIntoPullbackEqual H₁). + refine (maponpaths (λ z, pr11 z) (pr12 φ₁) @ _). exact (!(maponpaths (λ z, pr11 z) (pr12 φ₂))). + refine (maponpaths (λ z, pr11 z) (pr22 φ₁) @ _). exact (!(maponpaths (λ z, pr11 z) (pr22 φ₂))). - use (MorphismsIntoPullbackEqual H₂). + refine (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁) @ _). exact (!(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))). + refine (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁) @ _). exact (!(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))). Qed. Definition isPullback_iso_comma_mor : w --> pb. Proof. simple refine ((_ ,, _) ,, _). - refine (PullbackArrow P₁ _ (pr11 h₁) (pr11 h₂) _). abstract (exact (maponpaths (λ z, pr11 z) p)). - refine (PullbackArrow P₂ _ (pr21 h₁) (pr21 h₂) _). abstract (exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) p)). - use (MorphismsIntoPullbackEqual (HG _ _ _ _ _ _ _ _ _ _ (pr22 P₂))). + abstract (rewrite <- !functor_comp ; apply maponpaths ; exact (PullbackSqrCommutes P₂)). + abstract (cbn ; rewrite !assoc' ; rewrite <- !functor_comp ; rewrite (PullbackArrow_PullbackPr1 P₂) ; refine (_ @ pr2 h₁) ; rewrite <- (pr2 π₁) ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- !functor_comp ; apply maponpaths ; apply (PullbackArrow_PullbackPr1 P₁)). + abstract (cbn ; rewrite !assoc' ; rewrite <- !functor_comp ; rewrite (PullbackArrow_PullbackPr2 P₂) ; refine (_ @ pr2 h₂) ; rewrite <- (pr2 π₂) ; rewrite !assoc ; apply maponpaths_2 ; rewrite <- !functor_comp ; apply maponpaths ; apply (PullbackArrow_PullbackPr2 P₁)). Defined. Definition isPullback_iso_comma_mor_pr1 : isPullback_iso_comma_mor · π₁ = h₁. Proof. use eq_iso_comma_mor. - apply (PullbackArrow_PullbackPr1 P₁). - apply (PullbackArrow_PullbackPr1 P₂). Qed. Definition isPullback_iso_comma_mor_pr2 : isPullback_iso_comma_mor · π₂ = h₂. Proof. use eq_iso_comma_mor. - apply (PullbackArrow_PullbackPr2 P₁). - apply (PullbackArrow_PullbackPr2 P₂). Qed. End UMP. Definition isPullback_iso_comma : isPullback sqr₃. Proof. intros w h₁ h₂ p. use iscontraprop1. - apply isPullback_iso_comma_unique. - simple refine (_ ,, _ ,, _). + exact (isPullback_iso_comma_mor h₁ h₂ p). + exact (isPullback_iso_comma_mor_pr1 h₁ h₂ p). + exact (isPullback_iso_comma_mor_pr2 h₁ h₂ p). Defined. End IsPullbackIsoComma. Definition pullbacks_in_iso_comma (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : Pullbacks (iso_comma F G). Proof. intros z x y f g. simple refine ((_ ,, _ ,, _) ,, (_ ,, _)). - simple refine ((_ ,, _) ,, _). + exact (PullbackObject (HC₁ _ _ _ (pr11 f) (pr11 g))). + exact (PullbackObject (HC₂ _ _ _ (pr21 f) (pr21 g))). + use (iso_between_pullbacks _ _ (HF _ _ _ _ _ _ _ _ _ _ (isPullback_Pullback (HC₁ _ _ _ (pr11 f) (pr11 g)))) (HG _ _ _ _ _ _ _ _ _ _ (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))). * abstract (rewrite <- !functor_comp ; apply maponpaths ; apply PullbackSqrCommutes). * abstract (rewrite <- !functor_comp ; apply maponpaths ; apply PullbackSqrCommutes). * exact (pr2 x). * exact (pr2 y). * exact (pr2 z). * exact (!(pr2 f)). * exact (!(pr2 g)). - simple refine ((_ ,, _) ,, _). + apply PullbackPr1. + apply PullbackPr1. + abstract (cbn ; unfold iso_between_pullbacks_map ; refine (!_) ; apply (PullbackArrow_PullbackPr1 (make_Pullback _ (HG _ _ _ _ _ _ _ _ _ _ (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))))). - simple refine ((_ ,, _) ,, _). + apply PullbackPr2. + apply PullbackPr2. + abstract (cbn ; unfold iso_between_pullbacks_map ; refine (!_) ; apply (PullbackArrow_PullbackPr2 (make_Pullback _ (HG _ _ _ _ _ _ _ _ _ _ (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))))). - abstract (use eq_iso_comma_mor ; cbn ; [ apply PullbackSqrCommutes | apply PullbackSqrCommutes ]). - use isPullback_iso_comma. + apply PullbackSqrCommutes. + apply isPullback_Pullback. + apply PullbackSqrCommutes. + apply isPullback_Pullback. Defined. Definition iso_comma_pr1_preserves_pullback (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : preserves_pullback (iso_comma_pr1 F G). Proof. use preserves_pullback_if_preserves_chosen. - apply pullbacks_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y z f g. cbn. apply isPullback_Pullback. Defined. Definition iso_comma_pr2_preserves_pullback (HC₁ : Pullbacks C₁) (HC₂ : Pullbacks C₂) : preserves_pullback (iso_comma_pr2 F G). Proof. use preserves_pullback_if_preserves_chosen. - apply pullbacks_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y z f g. cbn. apply isPullback_Pullback. Defined. Definition iso_comma_ump1_preserves_pullback {C₀ : category} (H₁ : C₀ ⟶ C₁) (HH₁ : preserves_pullback H₁) (H₂ : C₀ ⟶ C₂) (HH₂ : preserves_pullback H₂) (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G)) : preserves_pullback (iso_comma_ump1 F G H₁ H₂ α). Proof. intros w x y z f g π₁ π₂ p₁ p₂ H. use isPullback_iso_comma ; cbn. - abstract (rewrite <- !functor_comp ; apply maponpaths ; exact p₁). - exact (HH₁ _ _ _ _ _ _ _ _ _ _ H). - abstract (rewrite <- !functor_comp ; apply maponpaths ; exact p₁). - exact (HH₂ _ _ _ _ _ _ _ _ _ _ H). Defined. End Pullbacks. (** 4. Initial objects *) Section InitialObject. Context (HF : preserves_initial F) (HG : preserves_initial G). Definition isInitial_iso_comma (x : iso_comma F G) (H₁ : isInitial C₁ (pr11 x)) (H₂ : isInitial C₂ (pr21 x)) : isInitial (iso_comma F G) x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use eq_iso_comma_mor ; [ apply (@InitialArrowEq _ (make_Initial _ H₁)) | apply (@InitialArrowEq _ (make_Initial _ H₂)) ]). - refine ((InitialArrow (_ ,, H₁) (pr11 w) ,, InitialArrow (_ ,, H₂) (pr21 w)) ,, _). apply (@InitialArrowEq _ (make_Initial _ (HF _ H₁))). Defined. Definition initial_category_iso_comma (I₁ : Initial C₁) (I₂ : Initial C₂) : Initial (iso_comma F G). Proof. simple refine (_ ,, _). - refine ((pr1 I₁ ,, pr1 I₂) ,, _) ; cbn. exact (ziso_Initials (make_Initial _ (HF _ (pr2 I₁))) (make_Initial _ (HG _ (pr2 I₂)))). - apply isInitial_iso_comma. + exact (pr2 I₁). + exact (pr2 I₂). Defined. Definition iso_comma_pr1_preserves_initial (I₁ : Initial C₁) (I₂ : Initial C₂) : preserves_initial (iso_comma_pr1 F G). Proof. apply (preserves_initial_if_preserves_chosen (initial_category_iso_comma I₁ I₂) (iso_comma_pr1 F G)). exact (pr2 I₁). Defined. Definition iso_comma_pr2_preserves_initial (I₁ : Initial C₁) (I₂ : Initial C₂) : preserves_initial (iso_comma_pr2 F G). Proof. apply (preserves_initial_if_preserves_chosen (initial_category_iso_comma I₁ I₂) (iso_comma_pr2 F G)). exact (pr2 I₂). Defined. Definition iso_comma_ump1_preserves_initial {C₀ : category} (H₁ : C₀ ⟶ C₁) (HH₁ : preserves_initial H₁) (H₂ : C₀ ⟶ C₂) (HH₂ : preserves_initial H₂) (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G)) : preserves_initial (iso_comma_ump1 F G H₁ H₂ α). Proof. intros x Hx. apply isInitial_iso_comma. - apply HH₁. exact Hx. - apply HH₂. exact Hx. Defined. End InitialObject. (** 5. Coproducts *) Section Coproduct. Context (HF : preserves_bincoproduct F) (HG : preserves_bincoproduct G). Section IsCoproductInIsoComma. Context {x y z : iso_comma F G} (i₁ : x --> z) (i₂ : y --> z) (H₁ : isBinCoproduct _ (pr11 x) (pr11 y) (pr11 z) (pr11 i₁) (pr11 i₂)) (H₂ : isBinCoproduct _ (pr21 x) (pr21 y) (pr21 z) (pr21 i₁) (pr21 i₂)). Let P₁ : BinCoproduct (pr11 x) (pr11 y) := make_BinCoproduct _ _ _ _ _ _ H₁. Let P₂ : BinCoproduct (pr21 x) (pr21 y) := make_BinCoproduct _ _ _ _ _ _ H₂. Section UMP. Context {w : iso_comma F G} (f : x --> w) (g : y --> w). Definition isBinCoproduct_in_iso_comma_unique : isaprop (∑ (fg : z --> w), i₁ · fg = f × i₂ · fg = g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } use eq_iso_comma_mor. - use (BinCoproductArrowsEq _ _ _ P₁). + exact (maponpaths (λ z, pr11 z) (pr12 φ₁) @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))). + exact (maponpaths (λ z, pr11 z) (pr22 φ₁) @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))). - use (BinCoproductArrowsEq _ _ _ P₂). + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁) @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))). + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁) @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))). Qed. Definition isBinCoproduct_in_iso_comma_ump : z --> w. Proof. simple refine ((_ ,, _) ,, _) ; cbn. - exact (BinCoproductArrow P₁ (pr11 f) (pr11 g)). - exact (BinCoproductArrow P₂ (pr21 f) (pr21 g)). - use (BinCoproductArrowsEq _ _ _ (make_BinCoproduct _ _ _ _ _ _ (HF _ _ _ _ _ (pr2 P₁)))) ; cbn. + abstract (rewrite !assoc ; rewrite <- functor_comp ; rewrite (BinCoproductIn1Commutes _ _ _ P₁) ; refine (pr2 f @ _) ; refine (_ @ maponpaths (λ z, z · _) (!(pr2 i₁))) ; rewrite !assoc' ; apply maponpaths ; rewrite <- functor_comp ; apply maponpaths ; refine (!_) ; apply (BinCoproductIn1Commutes _ _ _ P₂)). + abstract (rewrite !assoc ; rewrite <- functor_comp ; rewrite (BinCoproductIn2Commutes _ _ _ P₁) ; refine (pr2 g @ _) ; refine (_ @ maponpaths (λ z, z · _) (!(pr2 i₂))) ; rewrite !assoc' ; apply maponpaths ; rewrite <- functor_comp ; apply maponpaths ; refine (!_) ; apply (BinCoproductIn2Commutes _ _ _ P₂)). Defined. Definition isBinCoproduct_in_iso_comma_ump_in1 : i₁ · isBinCoproduct_in_iso_comma_ump = f. Proof. use eq_iso_comma_mor ; cbn. - apply (BinCoproductIn1Commutes _ _ _ P₁). - apply (BinCoproductIn1Commutes _ _ _ P₂). Qed. Definition isBinCoproduct_in_iso_comma_ump_in2 : i₂ · isBinCoproduct_in_iso_comma_ump = g. Proof. use eq_iso_comma_mor ; cbn. - apply (BinCoproductIn2Commutes _ _ _ P₁). - apply (BinCoproductIn2Commutes _ _ _ P₂). Qed. End UMP. Definition isBinCoproduct_in_iso_comma : isBinCoproduct (iso_comma F G) x y z i₁ i₂. Proof. intros w f g. use iscontraprop1. - exact (isBinCoproduct_in_iso_comma_unique f g). - simple refine (_ ,, _ ,, _). + exact (isBinCoproduct_in_iso_comma_ump f g). + exact (isBinCoproduct_in_iso_comma_ump_in1 f g). + exact (isBinCoproduct_in_iso_comma_ump_in2 f g). Defined. End IsCoproductInIsoComma. Definition bincoproducts_in_iso_comma (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : BinCoproducts (iso_comma F G). Proof. intros x y. pose (FP := make_BinCoproduct _ _ _ _ _ _ (HF (pr11 x) (pr11 y) _ (BinCoproductIn1 (HC₁ (pr11 x) (pr11 y))) (BinCoproductIn2 (HC₁ (pr11 x) (pr11 y))) (isBinCoproduct_BinCoproduct _ (HC₁ (pr11 x) (pr11 y))))). pose (GP := make_BinCoproduct _ _ _ _ _ _ (HG (pr21 x) (pr21 y) _ (BinCoproductIn1 (HC₂ (pr21 x) (pr21 y))) (BinCoproductIn2 (HC₂ (pr21 x) (pr21 y))) (isBinCoproduct_BinCoproduct _ (HC₂ (pr21 x) (pr21 y))))). use make_BinCoproduct. - simple refine ((_ ,, _) ,, _). + exact (BinCoproductObject (HC₁ (pr11 x) (pr11 y))). + exact (BinCoproductObject (HC₂ (pr21 x) (pr21 y))). + exact (bincoproduct_of_z_iso FP GP (pr2 x) (pr2 y)). - simple refine ((_ ,, _) ,, _). + exact (BinCoproductIn1 (HC₁ (pr11 x) (pr11 y))). + exact (BinCoproductIn1 (HC₂ (pr21 x) (pr21 y))). + exact ((BinCoproductOfArrowsIn1 _ FP GP (pr12 x) (pr12 y))). - simple refine ((_ ,, _) ,, _). + exact (BinCoproductIn2 (HC₁ (pr11 x) (pr11 y))). + exact (BinCoproductIn2 (HC₂ (pr21 x) (pr21 y))). + exact ((BinCoproductOfArrowsIn2 _ FP GP (pr12 x) (pr12 y))). - use isBinCoproduct_in_iso_comma. + apply isBinCoproduct_BinCoproduct. + apply isBinCoproduct_BinCoproduct. Defined. Definition iso_comma_pr1_preserves_bincoproduct (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : preserves_bincoproduct (iso_comma_pr1 F G). Proof. use preserves_bincoproduct_if_preserves_chosen. - apply bincoproducts_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y. cbn. apply isBinCoproduct_BinCoproduct. Defined. Definition iso_comma_pr2_preserves_bincoproduct (HC₁ : BinCoproducts C₁) (HC₂ : BinCoproducts C₂) : preserves_bincoproduct (iso_comma_pr2 F G). Proof. use preserves_bincoproduct_if_preserves_chosen. - apply bincoproducts_in_iso_comma. + exact HC₁. + exact HC₂. - intros x y. cbn. apply isBinCoproduct_BinCoproduct. Defined. Definition iso_comma_ump1_preserves_bincoproduct {C₀ : category} (H₁ : C₀ ⟶ C₁) (HH₁ : preserves_bincoproduct H₁) (H₂ : C₀ ⟶ C₂) (HH₂ : preserves_bincoproduct H₂) (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G)) : preserves_bincoproduct (iso_comma_ump1 F G H₁ H₂ α). Proof. intros x y z π₁ π₂ Hx. apply isBinCoproduct_in_iso_comma. - apply HH₁. exact Hx. - apply HH₂. exact Hx. Defined. End Coproduct. End IsoCommaLimits. UniMath-20231010/UniMath/CategoryTheory/limits/Examples/UnitCategoryLimits.v000066400000000000000000000117071451125700300266770ustar00rootroot00000000000000(************************************************************************ Limits and colimits in the unit category Contents 1. Terminal objects 2. Products 3. Pullbacks 4. Initial objects 5. Coproducts ************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.Preservation. Local Open Scope cat. (** 1. Terminal objects *) Definition isTerminal_unit_category (x : unit_category) : isTerminal unit_category x. Proof. use make_isTerminal. intro y. use iscontraprop1 ; [ apply isasetunit | ]. apply isapropunit. Qed. Definition terminal_unit_category : Terminal unit_category. Proof. simple refine (_ ,, _). - exact tt. - exact (isTerminal_unit_category tt). Defined. Definition functor_to_unit_preserves_terminal (C : category) : preserves_terminal (functor_to_unit C). Proof. intros x Hx. apply isTerminal_unit_category. Defined. (** 2. Products *) Definition isBinProduct_unit_category {x y z : unit_category} (f : z --> x) (g : z --> y) : isBinProduct unit_category x y z f g. Proof. intros w h₁ h₂. use iscontraprop1. - apply invproofirrelevance. intros fg₁ fg₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } apply isasetunit. - simple refine (_ ,, _ ,, _). + apply isapropunit. + apply isasetunit. + apply isasetunit. Qed. Definition binproduct_unit_category : BinProducts unit_category. Proof. intros x y. use make_BinProduct. - exact tt. - apply isapropunit. - apply isapropunit. - apply isBinProduct_unit_category. Defined. Definition functor_to_unit_preserves_binproduct (C : category) : preserves_binproduct (functor_to_unit C). Proof. intro ; intros. apply isBinProduct_unit_category. Defined. (** 3. Pullbacks *) Definition isPullback_unit_category {w x y z : unit_category} {f : x --> z} {g : y --> z} {p₁ : w --> x} {p₂ : w --> y} (eq : p₁ · f = p₂ · g) : isPullback eq. Proof. intros r h₁ h₂ q. use iscontraprop1. - apply invproofirrelevance. intros fg₁ fg₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } apply isasetunit. - simple refine (_ ,, _ ,, _). + apply isapropunit. + apply isasetunit. + apply isasetunit. Qed. Definition pullbacks_unit_category : Pullbacks unit_category. Proof. intros x y z f g. use make_Pullback. - exact tt. - apply isapropunit. - apply isapropunit. - apply isasetunit. - apply isPullback_unit_category. Defined. Definition functor_to_unit_preserves_pullback (C : category) : preserves_pullback (functor_to_unit C). Proof. intro ; intros. apply isPullback_unit_category. Defined. (** 4. Initial objects *) Definition isInitial_unit_category (x : unit_category) : isInitial unit_category x. Proof. intro y. use iscontraprop1 ; [ apply isasetunit | ]. apply isapropunit. Qed. Definition initial_unit_category : Initial unit_category. Proof. simple refine (_ ,, _). - exact tt. - exact (isInitial_unit_category tt). Defined. Definition functor_to_unit_preserves_initial (C : category) : preserves_initial (functor_to_unit C). Proof. intros x Hx. apply isInitial_unit_category. Defined. (** 5. Coproducts *) Definition isBinCoproduct_unit_category {x y z : unit_category} (f : x --> z) (g : y --> z) : isBinCoproduct unit_category x y z f g. Proof. intros w h₁ h₂. use iscontraprop1. - apply invproofirrelevance. intros fg₁ fg₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } apply isasetunit. - simple refine (_ ,, _ ,, _). + apply isapropunit. + apply isasetunit. + apply isasetunit. Qed. Definition bincoproduct_unit_category : BinCoproducts unit_category. Proof. intros x y. use make_BinCoproduct. - exact tt. - apply isapropunit. - apply isapropunit. - apply isBinCoproduct_unit_category. Defined. Definition functor_to_unit_preserves_bincoproduct (C : category) : preserves_bincoproduct (functor_to_unit C). Proof. intro ; intros. apply isBinCoproduct_unit_category. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/Filtered.v000066400000000000000000000331511451125700300230550ustar00rootroot00000000000000 (** *********************************************************************** * Filtered Categories * * * * Definition of filtered categories and compact/finitely presentable * * objects. Two definitions of filtered categories are given, * * [is_filtered] * * [is_filtered_alt] * * and a proof that they are equivalent is given in [weq_filtered]. * * * * Contents * * 1) Filtered categories * * 2) Compact objects * * 3) Properties * * 4) Equivalence between [is_filtered] and [is_filtered_alt]. * * * *************************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.covyoneda. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.CategoryTheory.limits.StandardDiagrams. Local Open Scope cat. Local Open Scope stn. Section filtered_categories. (** 1. A category is filtered if it admits cocones for every diagram of finite graphs, or equivalently if it admits cocones for diagrams of the empty graph, the two-point graph and the graph with two parallell edges. *) Definition is_filtered (J : category) : UU := ∏ (g : graph) (d : diagram g J), (is_finite_graph g) -> ∥ ∑ (z : J), cocone d z ∥. Definition is_filtered_alt (J : category) : UU := ∥ J ∥ × (∏ (d : diagram bool_graph J), ∃ z : J, cocone d z) × (∏ (d : diagram pair_graph J), ∃ z : J, cocone d z). Definition preserves_filtered_colimits {C D : category} (F : functor C D) : UU := ∏ (J : category), is_filtered J -> preserves_colimits_of_shape F J. End filtered_categories. Section compact. (** 2. Compact / finitely presentable objects. *) Definition hom {C : category} (x : C) : C ⟶ SET := (covyoneda C x). Definition is_compact {C : category} (x : C) : UU := preserves_filtered_colimits (hom x). End compact. Section properties. (** 3. Properties. *) Lemma isaprop_is_filtered {J : category} : isaprop (is_filtered J). Proof. do 2 (apply impred_isaprop; intro). apply isapropimpl, propproperty. Qed. Lemma isaprop_is_filtered_alt {J : category} : isaprop (is_filtered_alt J). Proof. apply isapropdirprod; [apply propproperty |apply isapropdirprod; repeat (apply impred_isaprop; intro; try apply propproperty)]. Qed. Lemma isaprop_iscompact {C : category} (X : C) : isaprop (is_compact X). Proof. do 6 (apply impred_isaprop ; intro). apply isaprop_isColimCocone. Qed. End properties. Section alternate_formulation. (** 4. The equivalence between [is_filtered] and [is_filtered_alt]. *) Lemma filtered_is_inhabited {J : category} (filtered : is_filtered J) : ∥ J ∥. Proof. exact(hinhfun pr1 (filtered empty_graph make_empty_diagram is_finite_graph_empty)). Qed. Lemma filtered_has_bool_cocones {J : category} (filtered : is_filtered J) (d : diagram bool_graph J) : ∃ z : J, cocone d z. Proof. exact(filtered bool_graph _ is_finite_graph_bool). Qed. Lemma filtered_has_pair_cocones {J : category} (filtered : is_filtered J) (d : diagram pair_graph J) : ∃ z : J, cocone d z. Proof. exact(filtered pair_graph d is_finite_graph_pair). Qed. (* The implication [is_filtered] -> [is_filtered_alt] is the easy one. *) Definition filtered_to_filtered_alt {J : category} (filtered : is_filtered J) : is_filtered_alt J. Proof. repeat split. - exact(filtered_is_inhabited filtered). - exact(filtered_has_bool_cocones filtered). - exact(filtered_has_pair_cocones filtered). Defined. Lemma filtered_alt_has_discrete_cocones_stn {J : category} (filtalt : is_filtered_alt J) (n : nat) (d : diagram (discrete_graph (⟦ n ⟧)) J) : ∃ z : J, cocone d z. Proof. destruct filtalt as [inhab [boolcc paircc]]. induction n as [| n IHn]. - use(hinhfun _ inhab). intro j. exists j. use make_discrete_cocone. exact(λ x : ⟦ 0 ⟧, fromempty (negstn0 x)). - set (d₁ := make_discrete_diagram (λ k : ⟦ n ⟧, dob d (dni lastelement k))). use(IHn d₁); intros [P Pcc]. set (d₂ := make_bool_diagram P (dob d lastelement)). use(boolcc d₂); intros [Q Qcc]; apply hinhpr. exists Q. use make_discrete_cocone. + apply(weqonsecbase (λ (v : ⟦ S n ⟧), J ⟦ dob d v, Q ⟧) (weqdnicoprod n lastelement)). apply coprod_rect. * exact(λ k : ⟦ n ⟧, coconeIn Pcc k · coconeIn Qcc true). * apply unit_rect. exact(coconeIn Qcc false). Qed. Lemma filtered_alt_has_discrete_cocones {J : category} (filtalt : is_filtered_alt J) (X : UU) (d : diagram (discrete_graph X) J) (n : nat) (w : X ≃ ⟦ n ⟧) : ∃ z : J, cocone d z. Proof. use(filtered_alt_has_discrete_cocones_stn filtalt n). - exact(make_discrete_diagram (λ k : ⟦ n ⟧, dob d (invmap w k))). - intros [P Pcc]; apply hinhpr. exists P. use make_discrete_cocone. + intro x. apply(transportf (fun y : X => J⟦ dob d y, P ⟧) (homotinvweqweq w x)). exact(coconeIn Pcc (w x)). Qed. Definition filtered_alt_has_parallell_stn {J : category} (filtalt : is_filtered_alt J) (n : nat) (d : diagram (parallell_graph (⟦ n ⟧)) J) : ∃ z : J, cocone d z. Proof. destruct filtalt as [inhab [bool_cc pair_cc]]. induction n as [|n IHn]. - set (d₁ := make_bool_diagram (dob d parallell_start) (dob d parallell_end)). use(hinhfun _ (bool_cc d₁)); intros [P Pcc]. exists P. use make_parallell_cocone. + exact(coconeIn Pcc true). + exact(coconeIn Pcc false). + exact(λ k : ⟦ 0 ⟧, fromempty (negstn0 k)). - (* dₙ is the restriction of d to ⟦ n ⟧ *) transparent assert(dₙ : (diagram (parallell_graph (⟦ n ⟧)) J)). { use make_parallell_diagram. - exact(dob d parallell_start). - exact(dob d parallell_end). - exact(λ k : ⟦ n ⟧, dmor d (parallell_edge (dni lastelement k))). } use(IHn dₙ); intros [Dₙ Dcc]. (* Dₙ/Dcc is the cocone over the parallell arrows {0, ..., n} *) transparent assert(pairing: (diagram pair_graph J)). { use make_pair_diagram. - exact(dob d parallell_start). - exact Dₙ. - exact(coconeIn Dcc parallell_start). - exact(dmor d (parallell_edge lastelement) · coconeIn Dcc parallell_end). } use(hinhfun _ (pair_cc pairing)); intros [Q Qcc]. exists Q. use make_parallell_cocone. + exact(coconeIn Dcc parallell_start · coconeIn Qcc pair_dst). + exact(coconeIn Dcc parallell_end · coconeIn Qcc pair_dst). + apply(weqonsecbase _ (weqdnicoprod n lastelement)). apply coprod_rect. * intro. etrans;[apply assoc |]. apply cancel_postcomposition. exact(parallell_cocone_commutes Dcc _). * apply unit_rect. etrans;[apply assoc |]. cbn. etrans;[exact(pair_cocone_commutes Qcc pair_right) |]. exact(!pair_cocone_commutes Qcc pair_left). Qed. Lemma filtered_alt_has_parallell_cocones {J : category} (filtalt : is_filtered_alt J) (X : UU) (n : nat) (w : X ≃ ⟦ n ⟧) (d : diagram (parallell_graph X) J) : ∃ z : J, cocone d z. Proof. set (dₙ := make_parallell_diagram (⟦ n ⟧) (dob d parallell_start) (dob d parallell_end) (λ k : ⟦ n ⟧, dmor d (parallell_edge (invmap w k)))). use(hinhfun _ (filtered_alt_has_parallell_stn filtalt n dₙ)). intros [P Pcc]. exists P. use make_parallell_cocone. - exact(coconeIn Pcc parallell_start). - exact(coconeIn Pcc parallell_end). - apply(weqonsecbase _ (invweq w)). exact(λ k : ⟦ n ⟧, parallell_cocone_commutes Pcc k). Qed. Lemma filtered_alt_has_finite_multispan_cocones {J : category} (filtalt : is_filtered_alt J) (X : UU) (n : nat) (w : X ≃ ⟦ n ⟧) (d : diagram (multispan_graph X) J) : ∃ z : J, cocone d z. Proof. set (base := dob d multispan_base). set (point_diagram := make_discrete_diagram' d). assert(r : (X ⨿ unit) ≃ ⟦ (S n) ⟧). { use(weqcomp (weqcoprodf1 w)). exact(weqdnicoprod n lastelement). } use(filtered_alt_has_discrete_cocones filtalt _ point_diagram (S n) r). intros [P Pcc]. transparent assert(edge_diagram : (diagram (parallell_graph (X ⨿ unit)) J)). { use make_parallell_diagram. - exact base. - exact P. - apply sumofmaps. * exact(λ x : X, dmor d (multispan_edge x) · (coconeIn Pcc (multispan_vertex x))). * exact(unit_rect _ (coconeIn Pcc multispan_base)). } use(filtered_alt_has_parallell_cocones filtalt (X ⨿ unit) (S n) r edge_diagram). intros [Q Qcc]; apply hinhpr. exists Q. use make_multispan_cocone. - exact(coconeIn Qcc parallell_start). - exact(λ x : X, coconeIn Pcc (multispan_vertex x) · coconeIn Qcc parallell_end). - intro x. etrans;[apply assoc |]. exact(parallell_cocone_commutes Qcc (inl x)). Qed. Definition filtered_alt_to_filtered {J : category} (filtalt : is_filtered_alt J) : is_filtered J. Proof. intros g d gfinite. use (finite_vertexset gfinite); intros finitevert. set (n := pr1 finitevert). set (w := pr2 finitevert). set (finite_edges := finite_edgeset gfinite). (* Start by creating a point P above d with cocone injections, but no commutativity. *) set (points := make_discrete_diagram (dob d)). use(filtered_alt_has_discrete_cocones filtalt (vertex g) points n (invweq w)). intros [P Pcc]. assert(edgechoice : ∥ ∏ (a b : vertex g), finstruct (edge a b) ∥). { do 2 (use(ischoicebasefiniteset (finite_vertexset gfinite)); intro). apply finite_edges. } use edgechoice; clear edgechoice. intros edgeset. transparent assert(ediagram : (∏ (a b : vertex g), diagram (parallell_graph ((edge a b) ⨿ unit)) J)). { intros a b. use(make_parallell_diagram _ (dob d a) P). apply sumofmaps. - exact(λ e, dmor d e · coconeIn Pcc b). - exact(unit_rect _ (coconeIn Pcc a)). } assert(D : (∏ (a b : vertex g), ∃ (Pab : J), cocone (ediagram a b) Pab)). { intros a b. set (k := pr1 (edgeset a b)). set (i := pr2 (edgeset a b)). use(filtered_alt_has_parallell_cocones filtalt ((edge a b) ⨿ unit) (S k)). refine(weqcomp _ (weqdnicoprod k lastelement)). exact(weqcoprodf1 (invweq i)). } assert(D' : ∥ (∏ (a b : vertex g), ∑ (Pab : J), cocone (ediagram a b) Pab) ∥). { do 2 (use(ischoicebasefiniteset (finite_vertexset gfinite)); intro). apply D. } (* For each pair (u, v) ∈ vertex g × vertex g there is an object D(u,v) in J, and a cocone over the diagram of (edges u v) composed with the injection into P. *) use D'; clear D'; clear D; intros D. transparent assert(spandiagram : (diagram (multispan_graph (vertex g × vertex g)) J)). { use make_multispan_diagram. - exact P. - intros [a b]. exact(pr1 (D a b)). - intros [a b]. exact(coconeIn (pr2 (D a b)) parallell_end). } (* The objects D(u, v) together with their cocone injections from P is a finite multi span. Since J is filtered there is a cocone [Q Qcc] over this span. *) use(filtered_alt_has_finite_multispan_cocones filtalt (vertex g × vertex g) (n * n)). - apply(weqcomp (invweq (weqdirprodf w w))). apply weqfromprodofstn. - exact spandiagram. - intros [Q Qcc]; apply hinhpr. (* Using Q together with the cocones D(u,v) and P to construct a cocone over d with apex Q. *) exists Q. use make_cocone. + exact(λ v : vertex g, coconeIn Pcc v · coconeIn Qcc multispan_base). + intros u v e. etrans. { apply maponpaths; apply maponpaths. exact(!multispan_cocone_commutes Qcc (u ,, v)). } etrans;[apply assoc |]. etrans;[apply assoc |]. set (Duv := pr2 (D u v)). etrans. { apply maponpaths_2. exact(parallell_cocone_commutes Duv (inl e)). } etrans. { apply maponpaths_2. exact(!parallell_cocone_commutes Duv (inr tt)). } etrans;[apply assoc'|]. apply cancel_precomposition. exact(multispan_cocone_commutes Qcc (u ,, v)). Qed. Definition weq_filtered (J : category) : is_filtered J ≃ is_filtered_alt J. Proof. use weqimplimpl. - exact filtered_to_filtered_alt. - exact filtered_alt_to_filtered. - exact isaprop_is_filtered. - exact isaprop_is_filtered_alt. Defined. End alternate_formulation. UniMath-20231010/UniMath/CategoryTheory/limits/FinOrdCoproducts.v000066400000000000000000000105331451125700300245450ustar00rootroot00000000000000(** A direct definition of finite ordered coproducts by using coproducts *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Local Open Scope cat. Local Open Scope stn. (** Definition of finite ordered coproducts. *) Section def_FinOrdCoproducts. Variable C : category. Definition FinOrdCoproducts : UU := ∏ (n : nat) (a : stn n -> C), Coproduct (stn n) C a. Definition hasFinOrdCoproducts : UU := ∏ (n : nat) (a : stn n -> C), ∥ Coproduct (stn n) C a ∥. End def_FinOrdCoproducts. (** Construction of FinOrdCoproducts from Initial and BinCoproducts. *) Section FinOrdCoproduct_criteria. Variable C : category. (** Case n = 0 of the theorem. *) Lemma InitialToCoproduct (I : Initial C): ∏ (a : stn 0 -> C), Coproduct (stn 0) C a. Proof. intros a. use (make_Coproduct _ _ _ I (λ i : stn 0, fromempty (weqstn0toempty i))). intros c g. use unique_exists. - apply (InitialArrow I c). - intros i. apply (fromempty (weqstn0toempty i)). - intro; apply impred_isaprop. intro; apply homset_property. - intros. apply InitialArrowUnique. Defined. (** Case n = 1 of the theorem. *) Lemma ObjectToCoproduct: ∏ (a : stn 1 -> C), Coproduct (stn 1) C a. Proof. intros a. set (stn1ob := invweq(weqstn1tounit) tt). use (make_Coproduct _ _ _ (a stn1ob)). intros i. exact (idtoiso (! (maponpaths a (isconnectedstn1 stn1ob i)))). (* isCoproductcocone *) use (make_isCoproduct _ _ C). intros c g. use (unique_exists (g stn1ob)). (* Commutativity. *) intros i. rewrite <- (isconnectedstn1 stn1ob i). apply id_left. (* Equality of equalities of morphisms. *) intros y. apply impred_isaprop. intros t. apply C. (* Uniqueness. *) intros y X. rewrite <- (X stn1ob). apply pathsinv0. apply id_left. Defined. Local Definition coproducts_stn_unit {n : nat} (Ncoprods : Coproducts (⟦ n ⟧) C) (BinCoprods : BinCoproducts C) : Coproducts (⟦ n ⟧ ⨿ unit) C. Proof. intro t. set (N := Ncoprods (t ∘ inl)%functions). set (E := t (inr tt)). set (B := BinCoprods (CoproductObject _ _ N) E). use make_Coproduct. - exact(BinCoproductObject B). - apply coprod_rect. + exact(λ k : ⟦ n ⟧, CoproductIn _ C N k · BinCoproductIn1 B). + exact(unit_rect _ (BinCoproductIn2 B)). - intros Q q. use unique_exists. + apply BinCoproductArrow. * apply CoproductArrow. exact(q ∘ inl)%functions. * exact(q (inr tt)). + use coprod_rect. * intros k. etrans. { apply assoc'. } etrans. { apply maponpaths. apply BinCoproductIn1Commutes. } use CoproductInCommutes. * apply unit_rect. apply BinCoproductIn2Commutes. + abstract(intros; apply impred_isaprop; intro; apply homset_property). + intros f fcommutes. apply BinCoproductArrowUnique. * apply CoproductArrowUnique; intro k. etrans. { apply assoc. } exact(fcommutes (inl k)). * exact(fcommutes (inr tt)). Defined. Local Definition coproducts_stn_Sn (n : nat) (stncoprods : Coproducts (⟦ n ⟧ ⨿ unit) C) : Coproducts (⟦ S n ⟧) C. Proof. set(w := (weqdnicoprod n lastelement)). set(q := invmap (univalence _ _) w). exact(transportf (fun X : UU => Coproducts X C) q stncoprods). Defined. (** Finite ordered coproducts from initial and binary coproducts. *) Theorem FinOrdCoproducts_from_Initial_and_BinCoproducts : Initial C -> BinCoproducts C -> FinOrdCoproducts C. Proof. intros I BinCoprods n. induction n as [|n IHn]. - exact(InitialToCoproduct I). (* Case n = 0 *) - apply coproducts_stn_Sn. exact(coproducts_stn_unit IHn BinCoprods). Defined. End FinOrdCoproduct_criteria. UniMath-20231010/UniMath/CategoryTheory/limits/FinOrdProducts.v000066400000000000000000000067161451125700300242330ustar00rootroot00000000000000(** A direct definition of finite ordered products by using products *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Local Open Scope stn. (** Definition of finite ordered products. *) Section def_FinOrdProducts. Variable C : category. Definition FinOrdProducts : UU := ∏ (n : nat) (a : stn n -> C), Product (stn n) C a. Definition hasFinOrdProducts : UU := ∏ (n : nat) (a : stn n -> C), ∥ Product (stn n) C a ∥. End def_FinOrdProducts. (** Construction of FinOrdProducts from Terminal and BinProducts. *) Section FinOrdProduct_criteria. Variable C : category. (** Case n = 0 of the theorem. *) Lemma TerminalToProduct (T : Terminal C): ∏ (a : stn 0 -> C), Product (stn 0) C a. Proof. intros a. use make_Product. - exact T. - exact(λ (x : ⟦ 0 ⟧), fromempty (weqstn0toempty x)). - intros c g. use unique_exists. + apply TerminalArrow. + exact(λ (x : ⟦ 0 ⟧), fromempty (weqstn0toempty x)). + intro; apply impred_isaprop. intro; apply homset_property. + intros; apply TerminalArrowEq. Defined. Local Definition products_stn_unit (n : nat) : Products (⟦ n ⟧) C -> BinProducts C -> Products (⟦ n ⟧ ⨿ unit) C. Proof. intros NProds BinProds. intro t. set (N := NProds (t ∘ inl)%functions). set (E := t (inr tt)). set (B := BinProds (ProductObject _ _ N) E). use make_Product. - exact(BinProductObject _ B). - apply coprod_rect. + intro k. exact(BinProductPr1 _ B · (ProductPr _ _ N k)). + apply unit_rect. exact(BinProductPr2 _ B). - intros Q q. use unique_exists. + apply BinProductArrow. * apply ProductArrow. exact(q ∘ inl)%functions. * exact(q (inr tt)). + use coprod_rect. * intros k. etrans. { apply assoc. } etrans. { apply maponpaths_2. apply BinProductPr1Commutes. } use ProductPrCommutes. * apply unit_rect. apply BinProductPr2Commutes. + abstract(intros; apply impred_isaprop; intro; apply homset_property). + intros f fcommutes. apply BinProductArrowUnique. * apply ProductArrowUnique; intro k. etrans. { apply assoc'. } exact(fcommutes (inl k)). * exact(fcommutes (inr tt)). Defined. Local Definition products_stn_Sn (n : nat) (stnprods : Products (⟦ n ⟧ ⨿ unit) C) : Products (⟦ S n ⟧) C. Proof. pose(w := (weqdnicoprod n lastelement)). pose(q := invmap (univalence _ _) w). exact(transportf (fun X : UU => Products X C) q stnprods). Defined. (** Finite ordered products from terminal and binary products *) Theorem FinOrdProducts_from_Terminal_and_BinProducts : Terminal C -> BinProducts C -> FinOrdProducts C. Proof. intros T BinProds n. induction n as [|n IHn]. - (* Case n = 0 *) exact(TerminalToProduct T). - (* Case (S n) assuming n. *) apply products_stn_Sn. now apply products_stn_unit. Defined. End FinOrdProduct_criteria. UniMath-20231010/UniMath/CategoryTheory/limits/Opp.v000066400000000000000000000525531451125700300220640ustar00rootroot00000000000000(** * Duality between C and C^op *) (** ** Contents - From C^op to C - Monics and Epis - Initial, Terminal, and Zero - Equalizers and Coequalizers - Kernels and Cokernels - Pullbacks and Pushouts - BinProducts and BinCoproducts - From C to C^op - Monics and Epis - Initial, Terminal, and Zero - Equalizers and Coequalizers - Kernels and Cokernels - Pullbacks and Pushouts - BinProducts and BinCoproducts *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Local Open Scope cat. Local Notation "C '^op'" := (op_category C) (at level 3, format "C ^op") : cat. (** * Translation of structures from C^op to C *) Section def_opposites. Variable C : category. Let hs : has_homsets C := homset_property C. (** ** Monic and Epi *) Definition opp_isMonic {a b : C} (f : a --> b) (H : @isMonic (op_category C) _ _ f) : @isEpi C _ _ f := H. Opaque opp_isMonic. Definition opp_Monic {a b : C} (f : @Monic (op_category C) a b) : @Epi C b a := @make_Epi C _ _ f (opp_isMonic f (pr2 f)). Definition opp_isEpi {a b : C} (f : a --> b) (H : @isEpi (C^op) _ _ f) : @isMonic C _ _ f := H. Opaque opp_isEpi. Definition opp_Epi {a b : C} (f : @Epi (C^op) a b) : @Monic C b a := @make_Monic C _ _ f (opp_isEpi f (pr2 f)). (** ** Initial, Terminal, and Zero *) Definition opp_isInitial {x : C} (H : @isInitial (C^op) x) : @isTerminal C x := H. Definition opp_Initial (I : @Initial (C^op)) : @Terminal C := @make_Terminal C _ (opp_isInitial (pr2 I)). Definition opp_isTerminal {x : C} (H : @isTerminal (C^op) x) : @isInitial C x := H. Definition opp_Terminal (T : @Terminal (C^op)) : @Initial C := @make_Initial C _ (opp_isTerminal (pr2 T)). Lemma opp_isZero {x : C} (H : @isZero (C^op) x) : @isZero C x. Proof. use make_isZero. - intros a. exact (dirprod_pr2 H a). - intros a. exact (dirprod_pr1 H a). Qed. Definition opp_Zero (Z : @Zero (C^op)) : @Zero C := @make_Zero C _ (opp_isZero (pr2 Z)). (** ** Equality on ZeroArrows *) Lemma opp_ZeroArrowTo {x : C} (Z : @Zero (C^op)) : @ZeroArrowTo (C^op) Z x = @ZeroArrowFrom C (opp_Zero Z) x. Proof. apply ArrowsToZero. Qed. Lemma opp_ZeroArrowFrom {x : C} (Z : @Zero (C^op)) : @ZeroArrowFrom (C^op) Z x = @ZeroArrowTo C (opp_Zero Z) x. Proof. apply ArrowsFromZero. Qed. Lemma opp_ZeroArrow {x y : C} (Z : @Zero (C^op)) : @ZeroArrow (C^op) Z x y = @ZeroArrow C (opp_Zero Z) y x. Proof. unfold ZeroArrow. rewrite opp_ZeroArrowTo. rewrite opp_ZeroArrowFrom. apply idpath. Qed. Local Opaque ZeroArrow. (** ** Equalizers and Coequalizers *) Lemma opp_isEqualizer {x y z : C} (f g : (C^op)⟦y, z⟧) (e : (C^op)⟦x, y⟧) (H : e · f = e · g) (H' : @isEqualizer (op_category C) _ _ _ f g e H) : @isCoequalizer C _ _ _ f g e H. Proof. exact H'. Qed. Lemma opp_isCoequalizer {x y z : C} (f g : (C^op)⟦x, y⟧) (e : (C^op)⟦y, z⟧) (H : f · e = g · e) (H' : @isCoequalizer (C^op) _ _ _ f g e H) : @isEqualizer C _ _ _ f g e H. Proof. exact H'. Qed. Definition opp_Equalizer {y z : C} (f g : (C^op)⟦y, z⟧) (E : @Equalizer (op_category C) y z f g) : @Coequalizer C z y f g := @make_Coequalizer C _ _ _ f g (EqualizerArrow E) (EqualizerEqAr E) (opp_isEqualizer f g (EqualizerArrow E) (EqualizerEqAr E) (isEqualizer_Equalizer E)). Definition opp_Coequalizer {y z : C} (f g : (C^op)⟦y, z⟧) (E : @Coequalizer (C^op) y z f g) : @Equalizer C z y f g := @make_Equalizer C _ _ _ f g (CoequalizerArrow E) (CoequalizerEqAr E) (opp_isCoequalizer f g (CoequalizerArrow E) (CoequalizerEqAr E) (isCoequalizer_Coequalizer E)). Definition opp_Equalizers (E : @Equalizers (op_category C)) : @Coequalizers C. Proof. intros x y f g. use opp_Equalizer. exact (E y x f g). Defined. Definition opp_Coequalizers (E : @Coequalizers (C^op)) : @Equalizers C. Proof. intros x y f g. use opp_Coequalizer. exact (E y x f g). Defined. (** ** Kernels and Cokernels *) Local Lemma opp_isCokernel_eq {x y z : C^op} (f : (C^op)⟦x, y⟧) (g : C^op⟦y, z⟧) (Z : Zero (C^op)) (H : f · g = ZeroArrow Z _ _) (Z' : Zero C) : (g : C⟦z, y⟧) · (f : C⟦y, x⟧) = ZeroArrow Z' _ _. Proof. cbn in *. rewrite H. rewrite opp_ZeroArrow. exact (ZerosArrowEq C (opp_Zero Z) Z' z x). Qed. Lemma opp_isCokernel {x y z : C^op} {f : (C^op)⟦x, y⟧} {g : C^op⟦y, z⟧} {Z : Zero (C^op)} {H : f · g = ZeroArrow Z _ _} (K' : isKernel (C:=op_category C) Z f g H) {Z' : Zero C} : isCokernel Z' (g : C⟦z, y⟧) (f : C⟦y, x⟧) (opp_isCokernel_eq f g Z H Z'). Proof. set (K := make_Kernel _ _ _ _ K'). use make_isCokernel. - intros w h H'. rewrite <- (ZerosArrowEq C (opp_Zero Z) Z' z w) in H'. rewrite <- opp_ZeroArrow in H'. use unique_exists. + exact (KernelIn (C:=op_category _ )Z K w h H'). + use (KernelCommutes (C:=op_category _) Z K). + intros y0. apply hs. + cbn. intros y0 X. use (KernelInsEq (C:=op_category _) Z K). rewrite (KernelCommutes (C:=op_category _) Z K). cbn. rewrite X. apply idpath. Qed. Local Lemma opp_Kernel_eq {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (K : @Kernel (op_category C) Z y z f) : @compose C^op _ _ _ (KernelArrow K) f = ZeroArrow (opp_Zero Z) z K. Proof. cbn. rewrite <- opp_ZeroArrow. apply (KernelCompZero (C:= op_category _) Z K). Qed. Lemma opp_Kernel_isCokernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (K : @Kernel (C^op) Z y z f) : isCokernel (opp_Zero Z) f (KernelArrow K) (opp_Kernel_eq f Z K). Proof. use make_isCokernel. - intros w h H'. rewrite <- opp_ZeroArrow in H'. use unique_exists. + exact (KernelIn Z K w h H'). + use (KernelCommutes Z K). + intros y0. apply hs. + cbn. intros y0 X. use (@KernelInsEq C^op). rewrite (KernelCommutes Z K). cbn. rewrite X. apply idpath. Qed. Definition opp_Kernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (K : @Kernel (C^op) Z y z f) : @Cokernel C (opp_Zero Z) z y f. Proof. use make_Cokernel. - exact K. - exact (KernelArrow K). - exact (opp_Kernel_eq f Z K). - exact (opp_Kernel_isCokernel f Z K). Defined. Lemma opp_isKernel {x y z : op_category C} {f : (C^op)⟦x, y⟧} {g : C^op⟦y, z⟧} {Z : Zero (C^op)} {H : f · g = ZeroArrow Z _ _} (CK' : isCokernel Z f g H) {Z' : Zero C} : isKernel Z' (g : C⟦z, y⟧) (f : C⟦y, x⟧) (opp_isCokernel_eq f g Z H Z'). Proof. set (CK := make_Cokernel _ _ _ _ CK'). use make_isKernel. intros w h H'. rewrite <- (ZerosArrowEq C (opp_Zero Z) Z' w x) in H'. rewrite <- opp_ZeroArrow in H'. use unique_exists. + exact (CokernelOut Z CK w h H'). + use (CokernelCommutes Z CK). + intros y0. apply hs. + cbn. intros y0 X. use (CokernelOutsEq _ CK). rewrite (CokernelCommutes Z CK). cbn. rewrite X. apply idpath. Qed. Local Lemma opp_Cokernel_eq {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (CK : @Cokernel (C^op) Z y z f) : @compose (C^op) _ _ _ f (CokernelArrow CK) = ZeroArrow (opp_Zero Z) CK y. Proof. cbn. rewrite <- opp_ZeroArrow. apply (CokernelCompZero Z CK). Qed. Lemma opp_Cokernel_isKernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (CK : @Cokernel (C^op) Z y z f) : isKernel (opp_Zero Z) (CokernelArrow CK) f (opp_Cokernel_eq f Z CK). Proof. use make_isKernel. intros w h H'. rewrite <- opp_ZeroArrow in H'. use unique_exists. + exact (CokernelOut Z CK w h H'). + use (CokernelCommutes Z CK). + intros y0. apply hs. + cbn. intros y0 X. use (@CokernelOutsEq C^op). rewrite (CokernelCommutes Z CK). cbn. rewrite X. apply idpath. Qed. Definition opp_Cokernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op)) (CK : @Cokernel (C^op) Z y z f) : @Kernel C (opp_Zero Z) z y f. Proof. use make_Kernel. - exact CK. - exact (CokernelArrow CK). - exact (opp_Cokernel_eq f Z CK). - exact (opp_Cokernel_isKernel f Z CK). Defined. Definition opp_Kernels (Z : Zero (C^op)) (K : @Kernels (C^op) Z) : @Cokernels C (opp_Zero Z). Proof. intros x y f. use opp_Kernel. apply (K y x f). Defined. Definition opp_Cokernels (Z : Zero (C^op)) (CK : @Cokernels (C^op) Z) : @Kernels C (opp_Zero Z). Proof. intros x y f. use opp_Cokernel. apply (CK y x f). Defined. (** ** Pushouts and pullbacks *) Lemma opp_isPushout {a b c d : C} (f : (C^op)⟦a, b⟧) (g : (C^op)⟦a, c⟧) (in1 : (C^op)⟦b, d⟧) (in2 : (C^op)⟦c, d⟧) (H : f · in1 = g · in2) (iPo : @isPushout (C^op) a b c d f g in1 in2 H) : @isPullback C a b c d f g in1 in2 H. Proof. exact iPo. Qed. Lemma opp_isPullback {a b c d : C} (f : (C^op)⟦b, a⟧) (g : (C^op)⟦c, a⟧) (p1 : (C^op)⟦d, b⟧) (p2 : (C^op)⟦d, c⟧) (H : p1 · f = p2 · g) (iPb : @isPullback (C^op) a b c d f g p1 p2 H) : @isPushout C a b c d f g p1 p2 H. Proof. exact iPb. Qed. Definition opp_Pushout {a b c : C} (f : (C^op)⟦a, b⟧) (g : (C^op)⟦a, c⟧) (Po : @Pushout (C^op) a b c f g) : @Pullback C a b c f g. Proof. exact Po. Defined. Definition opp_Pullback {a b c : C} (f : (C^op)⟦b, a⟧) (g : (C^op)⟦c, a⟧) (Pb : @Pullback (C^op) a b c f g) : @Pushout C a b c f g. Proof. exact Pb. Defined. Definition opp_Pushouts (Pos : @Pushouts (C^op)) : @Pullbacks C. Proof. exact Pos. Defined. Definition opp_Pullbacks (Pbs : @Pushouts (C^op)) : @Pullbacks C. Proof. exact Pbs. Defined. (** ** BinProducts and BinCoproducts *) Definition opp_isBinProduct (c d p : C) (p1 : (C^op)⟦p, c⟧) (p2 : (C^op)⟦p, d⟧) (iBPC : @isBinProduct (C^op) c d p p1 p2) : @isBinCoproduct C c d p p1 p2 := iBPC. Definition opp_isBinCoproduct (a b co : C) (ia : (C^op)⟦a, co⟧) (ib : (C^op)⟦b, co⟧) (iBCC : @isBinCoproduct (C^op) a b co ia ib) : @isBinProduct C a b co ia ib := iBCC. Definition opp_BinProduct (c d : C) (BPC : @BinProduct (C^op) c d) : @BinCoproduct C c d := BPC. Definition opp_BinCoproduct (c d : C) (BCC : @BinCoproduct (C^op) c d) : @BinProduct C c d := BCC. Definition opp_BinProducts (BP : @BinProducts (C^op)) : @BinCoproducts C := BP. Definition opp_BinCoproducts (BC : @BinCoproducts (C^op)) : @BinProducts C := BC. End def_opposites. (** * Translation of structures from C to C^op *) Section def_opposites'. Variable C : category. Let hs : has_homsets C := homset_property C. (** ** Monic and Epi *) Definition isMonic_opp {a b : C} {f : C⟦a, b⟧} (H : @isMonic C a b f) : @isEpi (C^op) b a f := H. Opaque isMonic_opp. Definition Monic_opp {a b : C} (f : @Monic C a b) : @Epi (C^op) b a := @make_Epi (C^op) b a f (isMonic_opp (pr2 f)). Definition isEpi_opp {a b : C} {f : C⟦a, b⟧} (H : @isEpi C a b f) : @isMonic (C^op) b a f := H. Opaque isEpi_opp. Definition Epi_opp {a b : C} (f : @Epi C a b) : @Monic (C^op) b a := @make_Monic (C^op) b a f (isEpi_opp (pr2 f)). (** ** Initial, Terminal, and Zero *) Definition isInitial_opp {x : C} (H : @isInitial C x) : @isTerminal (C^op) x := H. Definition Initial_opp (I : @Initial C) : @Terminal (C^op) := @make_Terminal (C^op) _ (isInitial_opp (pr2 I)). Definition isTerminal_opp {x : C} (H : @isTerminal C x) : @isInitial (C^op) x := H. Definition Terminal_opp (T : @Terminal C) : @Initial (C^op) := @make_Initial (C^op) _ (isTerminal_opp (pr2 T)). Lemma isZero_opp {x : C} (H : @isZero C x) : @isZero (C^op) x. Proof. use make_isZero. - intros a. apply (pr2 H a). - intros a. apply (pr1 H a). Defined. Definition Zero_opp (T : @Zero C) : @Zero (C^op) := @make_Zero (C^op) _ (isZero_opp (pr2 T)). (** ** Equality on ZeroArrows *) Lemma ZeroArrowTo_opp {x : C} (Z : @Zero C) : @ZeroArrowTo C Z x = @ZeroArrowFrom (C^op) (Zero_opp Z) x. Proof. apply ArrowsToZero. Qed. Lemma ZeroArrowFrom_opp {x : C} (Z : @Zero C) : @ZeroArrowFrom C Z x = @ZeroArrowTo (C^op) (Zero_opp Z) x. Proof. apply ArrowsFromZero. Qed. Lemma ZeroArrow_opp {x y : C} (Z : @Zero C) : @ZeroArrow C Z x y = @ZeroArrow (C^op) (Zero_opp Z) y x. Proof. unfold ZeroArrow. rewrite ZeroArrowTo_opp. rewrite ZeroArrowFrom_opp. apply idpath. Qed. Local Opaque ZeroArrow. (** ** Equalizers and Coequalizers *) Definition isEqualizer_opp {x y z : C} (f g : C⟦y, z⟧) (e : C⟦x, y⟧) (H : e · f = e · g) (isE : @isEqualizer C _ _ _ f g e H) : @isCoequalizer (C^op) _ _ _ f g e H := isE. Definition isCoequalizer_opp {x y z : C} (f g : C⟦x, y⟧) (e : C⟦y, z⟧) (H : f · e = g · e) (isC : @isCoequalizer C _ _ _ f g e H) : @isEqualizer (C^op) _ _ _ f g e H := isC. Definition Equalizer_opp {y z : C} (f g : C⟦y, z⟧) (E : @Equalizer C y z f g) : @Coequalizer (C^op) z y f g := @make_Coequalizer (C^op) _ _ _ f g (EqualizerArrow E) (EqualizerEqAr E) (isEqualizer_opp f g (EqualizerArrow E) (EqualizerEqAr E) (isEqualizer_Equalizer E)). Definition Coequalizer_opp {y z : C} (f g : C⟦y, z⟧) (CE : @Coequalizer C y z f g) : @Equalizer (C^op) z y f g := @make_Equalizer (C^op) _ _ _ f g (CoequalizerArrow CE) (CoequalizerEqAr CE) (isCoequalizer_opp f g (CoequalizerArrow CE) (CoequalizerEqAr CE) (isCoequalizer_Coequalizer CE)). Definition Equalizers_opp (E : @Equalizers C) : @Coequalizers (C^op). Proof. intros x y f g. use Equalizer_opp. exact (E y x f g). Defined. Definition Coequalizers_opp (CE : @Coequalizers C) : @Equalizers (C^op). Proof. intros x y f g. use Coequalizer_opp. exact (CE y x f g). Defined. (** ** Kernels and Cokernels *) Local Lemma isCokernel_opp_eq {x y z : C} (f : C⟦x, y⟧) (g : C⟦y, z⟧) (Z : Zero C) (H : f · g = ZeroArrow Z _ _) (Z' : Zero C^op) : (g : C^op⟦z, y⟧) · (f : C^op⟦y, x⟧) = ZeroArrow Z' _ _. Proof. cbn in *. rewrite H. rewrite ZeroArrow_opp. exact (ZerosArrowEq C^op (Zero_opp Z) Z' z x). Qed. Lemma isCokernel_opp {x y z : C} {f : C⟦x, y⟧} {g : C⟦y, z⟧} {Z : Zero C} {H : f · g = ZeroArrow Z _ _} (K' : isKernel Z f g H) {Z' : Zero C^op} : isCokernel Z' (g : C^op⟦z, y⟧) (f : C^op⟦y, x⟧) (isCokernel_opp_eq f g Z H Z'). Proof. set (K := make_Kernel _ _ _ _ K'). use make_isCokernel. - intros w h H'. cbn in H'. set (XXX := (ZerosArrowEq C^op (Zero_opp Z) Z' z w)). use unique_exists. + use (KernelIn Z K w h _). rewrite ZeroArrow_opp. rewrite XXX. apply H'. + cbn. use (KernelCommutes Z K). + intros y0. apply (has_homsets_opp hs). + cbn. intros y0 X. use (KernelInsEq Z K). rewrite KernelCommutes. exact X. Qed. Local Lemma Kernel_opp_eq {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) : @compose C^op _ _ _ f (KernelArrow K) = ZeroArrow (Zero_opp Z) z K. Proof. cbn. rewrite (KernelCompZero Z K). apply ZeroArrow_opp. Qed. Lemma Kernel_opp_isCokernel {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) : isCokernel (Zero_opp Z) f (KernelArrow K) (Kernel_opp_eq f Z K). Proof. use make_isCokernel. - intros w h H'. cbn in H'. use unique_exists. + rewrite <- ZeroArrow_opp in H'. exact (KernelIn Z K w h H'). + cbn. use KernelCommutes. + intros y0. apply (has_homsets_opp hs). + cbn. intros y0 X. use KernelInsEq. rewrite KernelCommutes. exact X. Qed. Definition Kernel_opp {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) : @Cokernel (C^op) (Zero_opp Z) z y f. Proof. use make_Cokernel. - exact K. - exact (KernelArrow K). - exact (Kernel_opp_eq f Z K). - exact (Kernel_opp_isCokernel f Z K). Defined. Lemma isKernel_opp {x y z : C^op} {f : C⟦x, y⟧} {g : C⟦y, z⟧} {Z : Zero C} {H : f · g = ZeroArrow Z _ _} (CK' : isCokernel Z f g H) {Z' : Zero C^op} : isKernel Z' (g : C^op⟦z, y⟧) (f : C^op⟦y, x⟧) (isCokernel_opp_eq f g Z H Z'). Proof. set (CK := make_Cokernel _ _ _ _ CK'). use make_isKernel. - intros w h H'. rewrite <- (ZerosArrowEq C^op (Zero_opp Z) Z' w x) in H'. rewrite <- ZeroArrow_opp in H'. use unique_exists. + exact (CokernelOut Z CK w h H'). + use (CokernelCommutes Z CK). + intros y0. apply hs. + cbn. intros y0 X. use (CokernelOutsEq _ CK). rewrite (CokernelCommutes Z CK). cbn. rewrite X. apply idpath. Qed. Local Lemma Cokernel_opp_eq {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (CK : @Cokernel C Z y z f) : @compose C^op _ _ _ (CokernelArrow CK) f = ZeroArrow (Zero_opp Z) CK y. Proof. cbn. rewrite (CokernelCompZero Z CK). apply ZeroArrow_opp. Qed. Lemma Cokernel_opp_isKernel {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (CK : @Cokernel C Z y z f) : isKernel (Zero_opp Z) (CokernelArrow CK) f (Cokernel_opp_eq f Z CK). Proof. use make_isKernel. - intros w h H'. cbn in H'. use unique_exists. + rewrite <- ZeroArrow_opp in H'. exact (CokernelOut Z CK w h H'). + cbn. use CokernelCommutes. + intros y0. apply (has_homsets_opp hs). + cbn. intros y0 X. use CokernelOutsEq. rewrite CokernelCommutes. exact X. Qed. Definition Cokernel_opp {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (CK : @Cokernel C Z y z f) : @Kernel (C^op) (Zero_opp Z) z y f. Proof. use make_Kernel. - exact CK. - exact (CokernelArrow CK). - exact (Cokernel_opp_eq f Z CK). - exact (Cokernel_opp_isKernel f Z CK). Defined. Definition Kernels_opp (Z : Zero C) (K : @Kernels C Z) : @Cokernels (C^op) (Zero_opp Z). Proof. intros x y f. use Kernel_opp. apply (K y x f). Defined. Definition Cokernels_opp (Z : Zero C) (CK : @Cokernels C Z) : @Kernels (C^op) (Zero_opp Z). Proof. intros x y f. use Cokernel_opp. apply (CK y x f). Defined. (** ** Pushouts and pullbacks *) Definition isPushout_opp {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (in1 : C⟦b, d⟧) (in2 : C⟦c, d⟧) (H : f · in1 = g · in2) (iPo : @isPushout C a b c d f g in1 in2 H) : @isPullback (C^op) a b c d f g in1 in2 H := iPo. Definition isPullback_opp {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (p1 : C⟦d, b⟧) (p2 : C⟦d, c⟧) (H : p1 · f = p2 · g) (iPb : @isPullback C a b c d f g p1 p2 H) : @isPushout (C^op) a b c d f g p1 p2 H := iPb. Definition Pushout_opp {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (Po : @Pushout C a b c f g) : @Pullback (C^op) a b c f g := Po. Definition Pullback_opp {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (Pb : @Pullback C a b c f g) : @Pushout (C^op) a b c f g := Pb. Definition Pushouts_opp (Pos : @Pushouts C) : @Pullbacks (C^op) := Pos. Definition Pullbacks_opp (Pbs : @Pushouts C) : @Pullbacks (C^op) := Pbs. (** ** BinProducts and BinCoproducts *) Definition isBinProduct_opp (c d p : C) (p1 : C⟦p, c⟧) (p2 : C⟦p, d⟧) (iBPC : @isBinProduct C c d p p1 p2) : @isBinCoproduct (C^op) c d p p1 p2 := iBPC. Definition isBinCoproduct_opp (a b co : C) (ia : C⟦a, co⟧) (ib : C⟦b, co⟧) (iBCC : @isBinCoproduct C a b co ia ib) : @isBinProduct (C^op) a b co ia ib := iBCC. Definition BinProduct_opp (c d : C) (iBPC : @BinProduct C c d) : @BinCoproduct (C^op) c d := iBPC. Definition BinCoproduct_opp (c d : C) (iBCC : @BinCoproduct C c d) : @BinProduct (C^op) c d := iBCC. Definition BinProducts_opp (BP : @BinProducts C) : @BinCoproducts (C^op) := BP. Definition BinCoproducts_opp (BC : @BinCoproducts C) : @BinProducts (C^op) := BC. End def_opposites'. Definition opp_zero_lifts {C:category} {X:Type} (j : X -> ob C) : zero_lifts C j -> zero_lifts C^op j. Proof. apply hinhfun; intros [z iz]. exists z. exact (isZero_opp C iz). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/Preservation.v000066400000000000000000001053721451125700300240050ustar00rootroot00000000000000(********************************************************* Preservation of (co)limits Content 1. Preservation of terminal objects 2. Preservation of binary products 3. Preservation of pullbacks 4. Preservation of initial objects 5. Preservation of binary coproducts 6. Preservation of (reflexive) coequalizers 7. Preservation of coproducts 8. Preservation of pushouts 9. Adjunctions and preservation 9.1 Right adjoints preserve limits 9.2 Left adjoints preserve colimits *********************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** 1. Preservation of terminal objects *) Definition preserves_terminal {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x : C₁), isTerminal C₁ x → isTerminal C₂ (F x). Definition identity_preserves_terminal (C : category) : preserves_terminal (functor_identity C) := λ x Hx, Hx. Definition composition_preserves_terminal {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_terminal F) (HG : preserves_terminal G) : preserves_terminal (F ∙ G) := λ x Hx, HG _ (HF _ Hx). Definition isaprop_preserves_terminal {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_terminal F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_terminal {C₁ C₂ : category} (HC₁ : Terminal C₁) (F : C₁ ⟶ C₂) : UU := isTerminal C₂ (F (TerminalObject HC₁)). Definition preserves_terminal_if_preserves_chosen {C₁ C₂ : category} (HC₁ : Terminal C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_terminal HC₁ F) : preserves_terminal F. Proof. intros x Hx. exact (iso_to_Terminal (make_Terminal _ HF) _ (functor_on_z_iso F (z_iso_Terminals HC₁ (make_Terminal _ Hx)))). Defined. Definition preserves_chosen_terminal_eq {C₁ C₂ : category} (F : C₁ ⟶ C₂) (T₁ : Terminal C₁) (T₂ : Terminal C₂) : UU := ∥ F T₁ = T₂ ∥. Proposition identity_preserves_chosen_terminal_eq {C : category} (T : Terminal C) : preserves_chosen_terminal_eq (functor_identity C) T T. Proof. apply hinhpr. apply idpath. Qed. Proposition composition_preserves_chosen_terminal_eq {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} {T₁ : Terminal C₁} {T₂ : Terminal C₂} {T₃ : Terminal C₃} (HF : preserves_chosen_terminal_eq F T₁ T₂) (HG : preserves_chosen_terminal_eq G T₂ T₃) : preserves_chosen_terminal_eq (F ∙ G) T₁ T₃. Proof. revert HF. use factor_through_squash. { apply propproperty. } intro p. revert HG. use factor_through_squash. { apply propproperty. } intro q. cbn. apply hinhpr. rewrite p, q. apply idpath. Qed. (** 2. Preservation of binary products *) Definition preserves_binproduct {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y prod : C₁) (π₁ : prod --> x) (π₂ : prod --> y), isBinProduct C₁ x y prod π₁ π₂ → isBinProduct C₂ (F x) (F y) (F prod) (#F π₁) (#F π₂). Definition identity_preserves_binproduct (C : category) : preserves_binproduct (functor_identity C) := λ _ _ _ _ _ Hx, Hx. Definition composition_preserves_binproduct {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_binproduct F) (HG : preserves_binproduct G) : preserves_binproduct (F ∙ G). Proof. intros ? ? ? ? ? Hx. apply HG. apply HF. exact Hx. Defined. Definition isaprop_preserves_binproduct {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_binproduct F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_binproduct {C₁ C₂ : category} (HC₁ : BinProducts C₁) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁), isBinProduct C₂ (F x) (F y) (F (BinProductObject C₁ (HC₁ x y))) (#F (BinProductPr1 C₁ (HC₁ x y))) (#F (BinProductPr2 C₁ (HC₁ x y))). Definition preserves_binproduct_if_preserves_chosen {C₁ C₂ : category} (HC₁ : BinProducts C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_binproduct HC₁ F) : preserves_binproduct F. Proof. intros x y z π₁ π₂ Hxy. use (isBinProduct_eq_arrow _ _ (pr2 (iso_to_BinProduct _ (make_BinProduct _ _ _ _ _ _ (HF x y)) (z_iso_to_iso (functor_on_z_iso F (iso_between_BinProduct (make_BinProduct _ _ _ _ _ _ Hxy) (HC₁ x y))))))) ; cbn. - abstract (rewrite <- functor_comp ; rewrite BinProductPr1Commutes ; apply idpath). - abstract (rewrite <- functor_comp ; rewrite BinProductPr2Commutes ; apply idpath). Defined. (** 3. Preservation of pullbacks *) Definition preserves_pullback {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y z pb : C₁) (f : x --> z) (g : y --> z) (π₁ : pb --> x) (π₂ : pb --> y) (q : π₁ · f = π₂ · g) (Fq : # F π₁ · # F f = # F π₂ · # F g), isPullback q → @isPullback C₂ _ _ _ _ (#F f) (#F g) (#F π₁) (#F π₂) Fq. Definition identity_preserves_pullback (C : category) : preserves_pullback (functor_identity C). Proof. intros ? ? ? ? ? ? ? ? ? ? H. exact H. Defined. Definition composition_preserves_pullback {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_pullback F) (HG : preserves_pullback G) : preserves_pullback (F ∙ G). Proof. intros ? ? ? ? ? ? ? ? ? ? H. use HG. - abstract (rewrite <- !functor_comp ; apply maponpaths ; exact q). - use HF. + exact q. + exact H. Defined. Definition isaprop_preserves_pullback {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_pullback F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_pullback {C₁ C₂ : category} (HC₁ : Pullbacks C₁) (F : C₁ ⟶ C₂) : UU. Proof. refine (∏ (x y z : C₁) (f : x --> z) (g : y --> z), @isPullback C₂ (F z) (F x) (F y) (F (PullbackObject (HC₁ _ _ _ f g))) (#F f) (#F g) (#F (PullbackPr1 (HC₁ _ _ _ f g))) (#F (PullbackPr2 (HC₁ _ _ _ f g))) _). abstract (rewrite <- !functor_comp ; apply maponpaths ; apply PullbackSqrCommutes). Defined. Definition preserves_pullback_if_preserves_chosen {C₁ C₂ : category} (HC₁ : Pullbacks C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_pullback HC₁ F) : preserves_pullback F. Proof. intros x y z pb f g π₁ π₂ p Hxy Hpb. apply (isPullback_z_iso _ _ (HF x y z f g) (functor_on_z_iso F (z_iso_from_Pullback_to_Pullback (HC₁ _ _ _ f g) (make_Pullback _ Hpb)))). - abstract (cbn ; rewrite <- !functor_comp ; apply maponpaths ; apply (PullbackArrow_PullbackPr1 (make_Pullback p Hpb))). - abstract (cbn ; rewrite <- !functor_comp ; apply maponpaths ; apply (PullbackArrow_PullbackPr2 (make_Pullback p Hpb))). Defined. (** 4. Preservation of initial objects *) Definition preserves_initial {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x : C₁), isInitial C₁ x → isInitial C₂ (F x). Definition identity_preserves_initial (C : category) : preserves_initial (functor_identity C) := λ x Hx, Hx. Definition composition_preserves_initial {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_initial F) (HG : preserves_initial G) : preserves_initial (F ∙ G) := λ x Hx, HG _ (HF _ Hx). Definition isaprop_preserves_initial {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_initial F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_initial {C₁ C₂ : category} (HC₁ : Initial C₁) (F : C₁ ⟶ C₂) : UU := isInitial C₂ (F (InitialObject HC₁)). Definition preserves_initial_if_preserves_chosen {C₁ C₂ : category} (HC₁ : Initial C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_initial HC₁ F) : preserves_initial F. Proof. intros x Hx. exact (iso_to_Initial (make_Initial _ HF) _ (functor_on_z_iso F (ziso_Initials HC₁ (make_Initial _ Hx)))). Defined. (** 5. Preservation of binary coproducts *) Definition preserves_bincoproduct {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y sum : C₁) (ι₁ : x --> sum) (ι₂ : y --> sum), isBinCoproduct C₁ x y sum ι₁ ι₂ → isBinCoproduct C₂ (F x) (F y) (F sum) (#F ι₁) (#F ι₂). Definition identity_preserves_bincoproduct (C : category) : preserves_bincoproduct (functor_identity C) := λ _ _ _ _ _ Hx, Hx. Definition composition_preserves_bincoproduct {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_bincoproduct F) (HG : preserves_bincoproduct G) : preserves_bincoproduct (F ∙ G). Proof. intros ? ? ? ? ? Hx. apply HG. apply HF. exact Hx. Defined. Definition isaprop_preserves_bincoproduct {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_bincoproduct F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_bincoproduct {C₁ C₂ : category} (HC₁ : BinCoproducts C₁) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁), isBinCoproduct C₂ (F x) (F y) (F (BinCoproductObject (HC₁ x y))) (#F (BinCoproductIn1 (HC₁ x y))) (#F (BinCoproductIn2 (HC₁ x y))). Definition preserves_bincoproduct_if_preserves_chosen {C₁ C₂ : category} (HC₁ : BinCoproducts C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_bincoproduct HC₁ F) : preserves_bincoproduct F. Proof. intros x y z ι₁ ι₂ Hxy. use (isBinCoproduct_eq_arrow _ _ (z_iso_to_isBinCoproduct _ (make_BinCoproduct _ _ _ _ _ _ (HF x y)) (functor_on_z_iso F (z_iso_from_BinCoproduct_to_BinCoproduct _ (make_BinCoproduct _ _ _ _ _ _ Hxy) (HC₁ x y))))) ; cbn. - abstract (rewrite <- functor_comp ; apply maponpaths ; apply BinCoproductIn1Commutes). - abstract (rewrite <- functor_comp ; apply maponpaths ; apply BinCoproductIn2Commutes). Defined. (** 6. Preservation of (reflexive) coequalizers *) Definition preserves_coequalizer {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y c : C₁) (f g : x --> y) (h : y --> c) (p : f · h = g · h) (Fp : #F f · #F h = #F g · #F h), isCoequalizer f g h p → isCoequalizer (#F f) (#F g) (#F h) Fp. Definition identity_preserves_coequalizer (C : category) : preserves_coequalizer (functor_identity C) := λ _ _ _ _ _ _ _ _ Hx, Hx. Definition composition_preserves_coequalizer {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_coequalizer F) (HG : preserves_coequalizer G) : preserves_coequalizer (F ∙ G). Proof. intros ? ? ? ? ? ? ? ? Hx. use HG. - abstract (rewrite <- !functor_comp ; rewrite p ; apply idpath). - use HF. + exact p. + exact Hx. Defined. Definition isaprop_preserves_coequalizer {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_coequalizer F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_coequalizer {C₁ C₂ : category} (HC₁ : Coequalizers C₁) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁) (f g : x --> y) (p : # F f · # F (CoequalizerArrow (HC₁ x y f g)) = # F g · # F (CoequalizerArrow (HC₁ x y f g))), isCoequalizer (#F f) (#F g) (#F (CoequalizerArrow (HC₁ x y f g))) p. Definition preserves_coequalizer_if_preserves_chosen {C₁ C₂ : category} (HC₁ : Coequalizers C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_coequalizer HC₁ F) : preserves_coequalizer F. Proof. intros x y c f g h p Fp Hz. use (Coequalizer_eq_ar _ _ _ (pr22 (z_iso_to_Coequalizer (make_Coequalizer _ _ _ _ (HF x y f g _)) (z_iso_inv (functor_on_z_iso F (z_iso_between_Coequalizer (make_Coequalizer _ _ _ _ Hz) (HC₁ x y f g))))))) ; cbn. - abstract (rewrite <- !functor_comp ; rewrite CoequalizerCommutes ; apply idpath). - abstract (rewrite <- !functor_comp ; rewrite CoequalizerEqAr ; apply idpath). Defined. Definition preserves_reflexive_coequalizer {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y c : C₁) (f g : x --> y) (s : y --> x) (pf : s · f = identity _) (pg : s · g = identity _) (h : y --> c) (p : f · h = g · h) (Fp : #F f · #F h = #F g · #F h), isCoequalizer f g h p → isCoequalizer (#F f) (#F g) (#F h) Fp. Definition identity_preserves_reflexive_coequalizer (C : category) : preserves_coequalizer (functor_identity C) := λ _ _ _ _ _ _ _ _ Hx, Hx. Definition composition_preserves_reflexive_coequalizer {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_reflexive_coequalizer F) (HG : preserves_reflexive_coequalizer G) : preserves_reflexive_coequalizer (F ∙ G). Proof. intros x y c f g s pf pg h p Fp Hx. use (HG (F x) (F y) (F c) (#F f) (#F g) (#F s) _ _ (#F h)). - abstract (rewrite <- functor_comp ; rewrite pf ; apply functor_id). - abstract (rewrite <- functor_comp ; rewrite pg ; apply functor_id). - abstract (rewrite <- !functor_comp ; rewrite p ; apply idpath). - use (HF x y c f g s _ _ h). + exact pf. + exact pg. + exact p. + exact Hx. Defined. Definition isaprop_preserves_reflexive_coequalizer {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_reflexive_coequalizer F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_reflexive_coequalizer {C₁ C₂ : category} (HC₁ : reflexive_coequalizers C₁) (F : C₁ ⟶ C₂) : UU := ∏ (x y : C₁) (f g : x --> y) (s : y --> x) (pf : s · f = identity _) (pg : s · g = identity _) (p : # F f · # F (CoequalizerArrow (HC₁ x y f g s pf pg)) = # F g · # F (CoequalizerArrow (HC₁ x y f g s pf pg))), isCoequalizer (#F f) (#F g) (#F (CoequalizerArrow (HC₁ x y f g s pf pg))) p. Definition preserves_reflexive_coequalizers_if_chosen {C₁ C₂ : category} (HC₁ : reflexive_coequalizers C₁) (F : C₁ ⟶ C₂) (HF : preserves_chosen_reflexive_coequalizer HC₁ F) : preserves_reflexive_coequalizer F. Proof. intros x y c f g s pf pg h p Fp Hz. use (Coequalizer_eq_ar _ _ _ (pr22 (z_iso_to_Coequalizer (make_Coequalizer _ _ _ _ (HF x y f g s pf pg _)) (z_iso_inv (functor_on_z_iso F (z_iso_between_Coequalizer (make_Coequalizer _ _ _ _ Hz) (HC₁ x y f g s pf pg))))))) ; cbn. - abstract (rewrite <- !functor_comp ; rewrite CoequalizerCommutes ; apply idpath). - abstract (rewrite <- !functor_comp ; rewrite CoequalizerEqAr ; apply idpath). Defined. (** 7. Preservation of coproducts *) Definition preserves_coproduct (J : UU) {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (D : J → C₁) (c : C₁) (ι : ∏ (j : J), D j --> c), isCoproduct J C₁ D c ι → isCoproduct J C₂ (λ j, F (D j)) (F c) (λ j, #F (ι j)). Definition identity_preserves_coproduct (C : category) (J : UU) : preserves_coproduct J (functor_identity C) := λ _ _ _ Hx, Hx. Definition composition_preserves_coproduct (J : UU) {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_coproduct J F) (HG : preserves_coproduct J G) : preserves_coproduct J (F ∙ G). Proof. intros ? ? ? Hx. apply HG. apply HF. exact Hx. Defined. Definition isaprop_preserves_coproduct (J : UU) {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_coproduct J F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. Definition preserves_chosen_coproduct (J : UU) {C₁ C₂ : category} (HC₁ : Coproducts J C₁) (F : C₁ ⟶ C₂) : UU := ∏ (D : J → C₁), isCoproduct J C₂ (λ j, F(D j)) (F (HC₁ D)) (λ j, #F (CoproductIn _ _ (HC₁ D) j)). (** 8. Preservation of pushouts *) Definition preserves_pushout {C₁ C₂ : category} (F : C₁ ⟶ C₂) : UU := ∏ (x y z po : C₁) (f : x --> y) (g : x --> z) (i₁ : y --> po) (i₂ : z --> po) (q : f · i₁ = g · i₂) (Fq : # F f · #F i₁ = #F g · #F i₂), isPushout f g i₁ i₂ q → isPushout (#F f) (#F g) (#F i₁) (#F i₂) Fq. Definition identity_preserves_pushout (C : category) : preserves_pushout (functor_identity C). Proof. intros ? ? ? ? ? ? ? ? ? ? H. exact H. Defined. Definition composition_preserves_pushout {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G : C₂ ⟶ C₃} (HF : preserves_pushout F) (HG : preserves_pushout G) : preserves_pushout (F ∙ G). Proof. intros ? ? ? ? ? ? ? ? ? ? H. use HG. - abstract (rewrite <- !functor_comp ; apply maponpaths ; exact q). - use HF. + exact q. + exact H. Defined. Definition isaprop_preserves_pushout {C₁ C₂ : category} (F : C₁ ⟶ C₂) : isaprop (preserves_pushout F). Proof. repeat (use impred ; intro). use isapropiscontr. Qed. (** 9. Adjunctions and preservation *) Section AdjunctionPreservation. Context {C₁ C₂ : category} (L : C₁ ⟶ C₂) (HL : is_left_adjoint L). Let R : C₂ ⟶ C₁ := right_adjoint HL. Let η : functor_identity _ ⟹ L ∙ R := unit_from_left_adjoint HL. Let ε : R ∙ L ⟹ functor_identity _ := counit_from_left_adjoint HL. Local Lemma triangle_1_help (x : C₁) : #L (η x) · ε (L x) = identity (L x). Proof. exact (pr122 HL x). Qed. Local Lemma triangle_2_help (x : C₂) : η (R x) · #R (ε x) = identity (R x). Proof. exact (pr222 HL x). Qed. (** 9.1 Right adjoints preserve limits *) Definition right_adjoint_preserves_terminal : preserves_terminal R. Proof. intros T HT x. use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. refine (!(id_right _) @ _ @ id_right _). rewrite <- !triangle_2_help. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ g₁). } refine (!_). etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ g₂). } rewrite !assoc' ; cbn -[η]. rewrite <- !functor_comp. do 2 apply maponpaths. apply (@TerminalArrowEq _ (T ,, HT)). - exact (η x · #R (TerminalArrow (_ ,, HT) _)). Qed. Definition right_adjoint_preserves_binproduct : preserves_binproduct R. Proof. intros x y p π₁ π₂ Hp c f g. pose (P := make_BinProduct _ _ _ _ _ _ Hp : BinProduct _ _ _). use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } refine (!(id_right _) @ _ @ id_right _). rewrite <- !triangle_2_help. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ (pr1 g₁)). } refine (!_). etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ (pr1 g₂)). } rewrite !assoc' ; cbn -[η]. rewrite <- !functor_comp. do 2 apply maponpaths. use (BinProductArrowsEq _ _ _ P). + cbn. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } refine (!_). etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. exact (pr12 g₁ @ !(pr12 g₂)). + cbn. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } refine (!_). etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. exact (pr22 g₁ @ !(pr22 g₂)). - simple refine (_ ,, _ ,, _). + exact (η c · #R (BinProductArrow _ P (#L f · ε x) (#L g · ε y))). + rewrite !assoc'. etrans. { apply maponpaths. refine (!(functor_comp R _ _) @ _). apply maponpaths. apply BinProductPr1Commutes. } rewrite functor_comp. rewrite !assoc. etrans. { apply maponpaths_2. apply (!(nat_trans_ax η _ _ f)). } rewrite !assoc'. rewrite triangle_2_help. apply id_right. + cbn. rewrite !assoc'. etrans. { apply maponpaths. refine (!(functor_comp R _ _) @ _). apply maponpaths. apply (BinProductPr2Commutes _ _ _ P). } rewrite functor_comp. rewrite !assoc. etrans. { apply maponpaths_2. apply (!(nat_trans_ax η _ _ g)). } rewrite !assoc'. rewrite triangle_2_help. apply id_right. Qed. Definition right_adjoint_preserves_pullback : preserves_pullback R. Proof. intros x y z p f g π₁ π₂ q Fq Hp w h₁ h₂ r. pose (P := make_Pullback _ Hp). use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } refine (!(id_right _) @ _ @ id_right _). rewrite <- !triangle_2_help. rewrite !assoc. etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ (pr1 g₁)). } refine (!_). etrans. { apply maponpaths_2. apply (nat_trans_ax η _ _ (pr1 g₂)). } rewrite !assoc' ; cbn -[η]. rewrite <- !functor_comp. do 2 apply maponpaths. use (MorphismsIntoPullbackEqual Hp). + cbn. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } refine (!_). etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. exact (pr12 g₁ @ !(pr12 g₂)). + cbn. rewrite !assoc'. etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } refine (!_). etrans. { apply maponpaths. refine (!_). apply (nat_trans_ax ε). } rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. exact (pr22 g₁ @ !(pr22 g₂)). - simple refine (_ ,, _ ,, _). + refine (η w · #R (PullbackArrow P _ (#L h₁ · ε x) (#L h₂ · ε y) _)). abstract (rewrite !assoc' ; refine (maponpaths (λ z, _ · z) (!(nat_trans_ax ε _ _ f)) @ _) ; refine (_ @ maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ g)) ; rewrite !assoc ; apply maponpaths_2 ; refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _) ; apply maponpaths ; exact r). + rewrite !assoc'. etrans. { apply maponpaths. refine (!(functor_comp R _ _) @ _). apply maponpaths. apply PullbackArrow_PullbackPr1. } rewrite (functor_comp R). rewrite !assoc. refine (maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ h₁)) @ _). refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. apply triangle_2_help. + cbn -[η]. rewrite !assoc'. etrans. { apply maponpaths. refine (!(functor_comp R _ _) @ _). apply maponpaths. apply (PullbackArrow_PullbackPr2 P). } rewrite (functor_comp R). rewrite !assoc. refine (maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ h₂)) @ _). refine (_ @ id_right _). rewrite !assoc'. apply maponpaths. apply triangle_2_help. Qed. (** 9.2 Left adjoints preserve colimits *) Definition left_adjoint_preserves_initial : preserves_initial L. Proof. intros x Hx y. pose (I := make_Initial x Hx). use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. refine (!(id_left _) @ _ @ id_left _). rewrite <- !triangle_1_help. rewrite !assoc'. etrans. { apply maponpaths. exact (!(nat_trans_ax ε _ _ g₁)). } refine (!_). etrans. { apply maponpaths. exact (!(nat_trans_ax ε _ _ g₂)). } rewrite !assoc. apply maponpaths_2. refine (!(functor_comp _ _ _) @ _ @ functor_comp _ _ _). apply maponpaths. apply (@InitialArrowEq _ I). - exact (#L (InitialArrow I _) · ε y). Qed. Definition left_adjoint_preserves_bincoproduct : preserves_bincoproduct L. Proof. intros x y s ι₁ ι₂ Hs z f g. pose (S := make_BinCoproduct _ _ _ _ _ _ Hs). use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. use subtypePath. { intro ; apply isapropdirprod ; apply homset_property. } refine (!(id_left _) @ _ @ id_left _). rewrite <- !triangle_1_help. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (!(nat_trans_ax ε _ _ (pr1 g₁))) @ _). refine (_ @ maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ (pr1 g₂))). rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. use (BinCoproductArrowsEq _ _ _ S). + rewrite !assoc. refine (maponpaths (λ z, z · _) (nat_trans_ax η _ _ _) @ _). refine (_ @ maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ _))). rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. exact (pr12 g₁ @ !(pr12 g₂)). + rewrite !assoc. refine (maponpaths (λ z, z · _) (nat_trans_ax η _ _ _) @ _). refine (_ @ maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ _))). rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. exact (pr22 g₁ @ !(pr22 g₂)). - simple refine (_ ,, _ ,, _). + exact (#L (BinCoproductArrow S (η x · #R f) (η y · #R g)) · ε z). + rewrite !assoc. rewrite <- (functor_comp L). rewrite (BinCoproductIn1Commutes _ _ _ S). rewrite functor_comp. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ f) @ _). rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. apply triangle_1_help. + cbn. rewrite !assoc. rewrite <- (functor_comp L). rewrite (BinCoproductIn2Commutes _ _ _ S). rewrite functor_comp. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ g) @ _). rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. apply triangle_1_help. Qed. Definition left_adjoint_preserves_coproduct (J : UU) : preserves_coproduct J L. Proof. intros D c ι Hc x f. pose (S := make_Coproduct _ _ _ _ _ Hc). use iscontraprop1. - use invproofirrelevance. intros g₁ g₂. use subtypePath. { intro ; use impred ; intro ; apply homset_property. } refine (!(id_left _) @ _ @ id_left _). rewrite <- !triangle_1_help. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (!(nat_trans_ax ε _ _ (pr1 g₁))) @ _). refine (_ @ maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ (pr1 g₂))). rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. use (CoproductArrow_eq _ _ _ S). intro j. rewrite !assoc. refine (maponpaths (λ z, z · _) (nat_trans_ax η _ _ _) @ _). refine (_ @ maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ _))). rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. exact (pr2 g₁ j @ !(pr2 g₂ j)). - simple refine (_ ,, _). + exact (#L (CoproductArrow _ _ S (λ j, η (D j) · #R (f j))) · ε x). + intro j ; cbn -[η]. rewrite !assoc. rewrite <- (functor_comp L). rewrite (CoproductInCommutes _ _ _ S). rewrite functor_comp. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ (f j)) @ _). rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. apply triangle_1_help. Qed. Definition left_adjoint_preserves_coequalizer : preserves_coequalizer L. Proof. intros x y c f g h p Fp Hc z k q. pose (Coeq := make_Coequalizer _ _ _ _ Hc). use iscontraprop1. - use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro ; apply homset_property. } refine (!(id_left _) @ _ @ id_left _). rewrite <- !triangle_1_help. rewrite !assoc'. refine (maponpaths (λ z, _ · z) (!(nat_trans_ax ε _ _ (pr1 φ₁))) @ _). refine (_ @ maponpaths (λ z, _ · z) (nat_trans_ax ε _ _ (pr1 φ₂))). rewrite !assoc. apply maponpaths_2. refine (!(functor_comp L _ _) @ _ @ functor_comp L _ _). apply maponpaths. use (isCoequalizerOutsEq (pr22 Coeq)). rewrite !assoc. refine (maponpaths (λ z, z · _) (nat_trans_ax η _ _ _) @ _). refine (_ @ maponpaths (λ z, z · _) (!(nat_trans_ax η _ _ _))). rewrite !assoc'. apply maponpaths. refine (!(functor_comp R _ _) @ _ @ functor_comp R _ _). apply maponpaths. exact (pr2 φ₁ @ !(pr2 φ₂)). - simple refine (_ ,, _). + refine (#L _ · ε z). refine (CoequalizerOut Coeq _ (η y · #R k) _). abstract (rewrite !assoc ; etrans ; [ apply maponpaths_2 ; exact (nat_trans_ax η _ _ f) | ] ; refine (!_) ; etrans ; [ apply maponpaths_2 ; exact (nat_trans_ax η _ _ g) | ] ; cbn -[η] ; rewrite !assoc' ; rewrite <- !functor_comp ; rewrite <- q ; apply idpath). + cbn -[η]. rewrite !assoc. rewrite <- functor_comp. rewrite (CoequalizerCommutes Coeq). rewrite functor_comp. rewrite !assoc'. etrans. { apply maponpaths. apply (nat_trans_ax ε _ _ k). } cbn -[η]. rewrite !assoc. refine (_ @ id_left _). apply maponpaths_2. exact (triangle_1_help y). Qed. End AdjunctionPreservation. UniMath-20231010/UniMath/CategoryTheory/limits/README.md000066400000000000000000000046031451125700300224070ustar00rootroot00000000000000limits =============== This directory contains the definition of some limits for the notion of precategory defined in the package *CategoryTheory* which formerly had the name "RezkCompletion". ## Contents * *cones.v* * definition of the precategory of cones over precategory C * proof that that precategory is a category if C is * *initial.v* * direct formalization of initial objects * proof that initial object is a property in a category * link with empty coproduct * initial element in functor precategory * *terminal.v* * direct formalization of terminal objects * proof that terminal object is a property in a category * link with empty product * *pullbacks.v* * direct formalization of pullbacks * proof that pullbacks form a property in a (saturated/univalent) category * symmetry * on sections * pullback chasing * reflection and preservation * pointwise constructions in functor precategory * construction of products from pullbacks * *binproducts.v* * direct formalization of binary product * definition of binary product functor * *bincoproducts.v* * direct formalization of binary coproduct * proof that binary coproduct(cocone) is a property in a category * specialized versions of beta rules for coproducts * definition of binary coproduct functor * *products.v* --- direct generalization to arbitrary products * *coproducts.v* --- direct generalization to arbitrary coproducts * *equalizers.v* * direct formalization of equalizer * equalizer arrows are monic * *coequalizers.v* * direct formalization of coequalizer * coequalizer arrows are epi * *zero.v* --- direct formalization of zero objects * *kernels.v* --- direct formalization of kernels * *cokernels.v* --- direct formalization of cokernels * *FunctorsPointwiseBinProduct.v* --- definition of a binary product structure on a functor category by taking pointwise binary products in the target category * *FunctorsPointwiseBinCoproduct.v* --- definition of a coproduct structure on a functor category by taking pointwise binary coproducts in the target category; option functor as special case * *FunctorsPointwiseProduct.v* --- same with arbitrary products * *FunctorsPointwiseCoproduct.v* --- same with arbitrary coproducts * *graphs* --- development of limits on the basis of descriptions of diagrams by graphs * *cats* --- development of limits on the basis of descriptions of diagrams by functors UniMath-20231010/UniMath/CategoryTheory/limits/StandardDiagrams.v000066400000000000000000000251451451125700300245330ustar00rootroot00000000000000 Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.FiniteSets. Local Open Scope cat. Local Open Scope stn. (** * Standard graphs and diagrams. Contents 1. Graphs 2. Diagram constructors 3. Cocone constructors *) Section graphs. (** 1. Graphs. *) Definition empty_graph : graph := make_graph empty (λ _ _, empty). Definition unit_graph : graph := make_graph unit (λ _ _, empty). (* The graph with two verticies, true and false, no edges. *) Definition bool_graph : graph := make_graph bool (λ _ _, empty). (* The interval graph: true ---tt---> false *) Definition interval_graph : graph. Proof. use make_graph. - exact bool. - intros a b. induction a; induction b. + exact empty. + exact unit. (* true --> false *) + exact empty. + exact empty. Defined. (* (● 1) <------ (● 0) ------> (● 2) *) Definition span_graph : graph. Proof. use make_graph. - exact three. - use three_rec. + apply three_rec. * exact empty. * exact unit. * exact unit. + exact(λ _, empty). + exact(λ _, empty). Defined. (* X as verticies, no edges. *) Definition discrete_graph (X : UU) : graph := make_graph X (λ _ _, empty). (* The graph with two verticies: (● 0) and (● 1), and X as edges from (● 0) to (● 1), no other edges. Input \mdlgblkcircle for ●, or use (stnpr 0) and (stnpr 1) *) Definition parallell_graph (X : UU) : graph. Proof. use make_graph. - exact two. - use two_rec_dep. + exact(two_rec empty X). + exact(λ _, empty). Defined. Definition parallell_start {X : UU} : vertex (parallell_graph X) := (● 0). Definition parallell_end {X : UU} : vertex (parallell_graph X) := (● 1). Definition parallell_edge {X : UU} (e : X) : @edge (parallell_graph X) parallell_start parallell_end := e. (* Two parallell edges, pair_left, pair_right : : pair_src --> pair_end. *) Definition pair_graph : graph := parallell_graph (unit ⨿ unit). Definition pair_src : vertex pair_graph := (● 0). Definition pair_dst : vertex pair_graph := (● 1). Definition pair_left : @edge pair_graph pair_src pair_dst := inl tt. Definition pair_right : @edge pair_graph pair_src pair_dst := inr tt. (* Multi span: One base vertex (inr tt) and X verticies with one unique edge from the base each, no other edges. *) Definition multispan_graph (X : UU) : graph. Proof. use make_graph. - exact(X ⨿ unit). (* inr tt is the base point. *) - use coprod_rect. + exact(λ _ _, empty). (* No edges x --> unit *) + apply unit_rect. apply coprod_rect. * exact(λ _, unit). (* One edge unit --> x *) * exact(λ _, empty). (* No edge unit --> unit *) Defined. Definition multispan_vertex {X : UU} (x : X) : vertex (multispan_graph X) := (inl x). Definition multispan_base {X : UU} : vertex (multispan_graph X) := (inr tt). Definition multispan_edge {X : UU} (x : X) : edge multispan_base (multispan_vertex x) := tt. End graphs. Section diagrams. (** 2. Diagram constructors. *) Definition make_empty_diagram {C : category} : diagram empty_graph C := make_diagram (fromempty : vertex empty_graph -> C) (λ _ _, fromempty). Definition make_unit_diagram {C : category} (point : C) : diagram unit_graph C. Proof. use make_diagram. - exact(unit_rect _ point). - exact(λ _ _, empty_rect _). Defined. Definition make_bool_diagram {C : category} (a b : C) : diagram bool_graph C. Proof. use make_diagram. - exact(bool_rect _ a b). - intros *; exact fromempty. Defined. Definition make_interval_diagram {C : category} (x : C) (y : C) (f : x --> y) : diagram interval_graph C. Proof. use make_diagram. - exact(bool_rect _ x y). - intros a b; destruct a, b; try (exact fromempty). exact(λ _ , f). Defined. Definition make_span_diagram {C : category } (a b c : C) (f : C ⟦a, b⟧) (g : C⟦a, c⟧) : diagram span_graph C. Proof. use make_diagram. - exact(three_rec a b c). - use three_rec_dep; use three_rec_dep; try exact(empty_rect _). + exact(unit_rect _ f). + exact(unit_rect _ g). Defined. Definition make_discrete_diagram {J : category} {X : UU} (objects : X -> J) : diagram (discrete_graph X) J. Proof. use make_diagram. - exact objects. - exact(λ _ _, empty_rect _). Defined. (* Given any diagram we can obtain a new diagram, forgetting the edges in the original graph. *) Definition make_discrete_diagram' {J : category} {g : graph} (d : diagram g J) : diagram (discrete_graph (vertex g)) J. Proof. use make_diagram. - exact(dob d). - exact(λ _ _, empty_rect _). Defined. Definition make_parallell_diagram {C : category} (X : UU) (x y : C) (f : ∏ (t : X), x --> y) : diagram (parallell_graph X) C. Proof. use make_diagram. - exact(two_rec x y). - use two_rec_dep. + use(two_rec_dep _ (empty_rect _) f). + exact(λ _, empty_rect _). Defined. Definition make_pair_diagram {C : category} (a b : C) (f g : a --> b) : diagram pair_graph C. Proof. apply(make_parallell_diagram (unit ⨿ unit) a b). exact(sumofmaps (λ _, f) (λ _, g)). Defined. Definition make_multispan_diagram {J : category} (X : UU) (base : J) (endpoint : ∏ (x : X), J) (morphism : ∏ (x : X), J⟦ base, endpoint x ⟧) : diagram (multispan_graph X) J. Proof. use make_diagram. - exact(sumofmaps endpoint (λ _, base)). - use coprod_rect. + exact(λ _ _, empty_rect _). + apply unit_rect. use coprod_rect. * exact(λ (a : X) (_ : unit), morphism a). * exact(λ _, empty_rect _). Defined. End diagrams. Section cocones. (** 3. Constructors of cocones. *) Definition make_empty_cocone {J : category} (d : diagram empty_graph J) (j : J) : cocone d j. Proof. use make_cocone. - exact(empty_rect _). - exact(λ _ _, empty_rect _). Defined. Definition make_discrete_cocone {J : category} {X : UU} (d : diagram (discrete_graph X) J) (z : J) (f : ∏ (x : X), J⟦dob d x, z⟧) : cocone d z. Proof. use make_cocone. - exact f. - exact(λ _ _, empty_rect _). Defined. Definition make_parallell_cocone {J : category} {X : UU} (d : diagram (parallell_graph X) J) (z : J) (in₀ : dob d (stnpr 0) --> z) (in₁ : dob d (stnpr 1) --> z) (commutes : ∏ (x : X), dmor d (x : @edge (parallell_graph X) (stnpr 0) (stnpr 1)) · in₁ = in₀) : cocone d z. Proof. use make_cocone. - exact(two_rec_dep _ in₀ in₁). - abstract(use(two_rec_dep _ (two_rec_dep _ (empty_rect _) commutes)); exact(λ _, empty_rect _)). Defined. Lemma parallell_cocone_commutes {J : category} {X : UU} {d : diagram (parallell_graph X) J} {j : J} (cc : cocone d j) (x : X) : dmor d (parallell_edge x) · coconeIn cc parallell_end = coconeIn cc parallell_start. Proof. exact(coconeInCommutes cc parallell_start parallell_end (parallell_edge x)). Qed. Definition make_pair_cocone {J : category} {X : UU} (d : diagram pair_graph J) (j : J) (src_in : J⟦dob d pair_src, j⟧) (dst_in : J⟦dob d pair_dst, j⟧) (com_left : dmor d pair_left · dst_in = src_in) (com_right : dmor d pair_right · dst_in = src_in) : cocone d j. Proof. use make_parallell_cocone. - exact src_in. - exact dst_in. - abstract(use coprod_rect; apply unit_rect; assumption). Defined. Lemma pair_cocone_commutes {J : category} {d : diagram pair_graph J} {j : J} (cc : cocone d j) (e : edge pair_src pair_dst) : dmor d e · coconeIn cc pair_dst = coconeIn cc pair_src. Proof. exact(coconeInCommutes cc pair_src pair_dst e). Qed. Definition make_multispan_cocone {J : category} {X : UU} (d : diagram (multispan_graph X) J) (apex : J) (base_inject : J⟦ dob d multispan_base, apex ⟧) (inject : ∏ (x : X), J⟦ dob d (multispan_vertex x), apex ⟧) (commutes : ∏ (x : X), dmor d (multispan_edge x) · inject x = base_inject) : cocone d apex. Proof. use make_cocone. - apply coprod_rect. + exact inject. + apply unit_rect. exact base_inject. - abstract(use coprod_rect; [exact(λ _ _, empty_rect _) | use unit_rect ]; use coprod_rect; cbn; [exact(λ a, unit_rect _ (commutes a)) |exact(λ _, empty_rect _)]). Defined. Lemma multispan_cocone_commutes {J : category} {X : UU} {d : diagram (multispan_graph X) J} {apex : J} (cc : cocone d apex) (z : X) : (dmor d (multispan_edge z)) · coconeIn cc (multispan_vertex z) = coconeIn cc multispan_base. Proof. exact(coconeInCommutes cc multispan_base (multispan_vertex z) tt). Qed. End cocones. Section finite. Definition is_finite_graph (g : graph) : UU := isfinite (vertex g) × ∏ (a b : vertex g), isfinite (edge a b). Definition finite_vertexset {g : graph} (gfinite : is_finite_graph g) : isfinite (vertex g) := pr1 gfinite. Definition finite_edgeset {g : graph} (gfinite : is_finite_graph g) : ∏ (a b : vertex g), isfinite (edge a b) := pr2 gfinite. (* Proofs that some of the above graphs are finite. *) Lemma is_finite_graph_empty : is_finite_graph empty_graph. Proof. split. - exact isfiniteempty. - exact(λ _ _, isfiniteempty). Qed. Lemma is_finite_graph_unit : is_finite_graph unit_graph. Proof. split. - exact isfiniteunit. - exact(λ _ _, isfiniteempty). Qed. Lemma is_finite_graph_bool : is_finite_graph bool_graph. Proof. split. - exact isfinitebool. - exact(λ _ _, isfiniteempty). Qed. Lemma is_finite_graph_pair : is_finite_graph pair_graph. Proof. split. - exact(isfinitestn 2). - use two_rec_dep; use two_rec_dep; try exact isfiniteempty. apply isfinitecoprod; apply isfiniteunit. Qed. Lemma is_finite_graph_interval : is_finite_graph interval_graph. Proof. split. - exact isfinitebool. - use bool_rect; use bool_rect; try exact isfiniteempty. exact isfiniteunit. Qed. End finite. UniMath-20231010/UniMath/CategoryTheory/limits/bincoproducts.v000066400000000000000000001364271451125700300242070ustar00rootroot00000000000000(** ****************************************** Direct implementation of binary coproducts togther with: - Proof that binary coproduct(cocone) is a property in a univalent_category ([isaprop_BinCoproductCocone]) - Specialized versions of beta rules for coproducts - Definition of binary coproduct functor ([bincoproduct_functor]) - Definition of a coproduct structure on a functor category by taking pointwise coproducts in the target category ([BinCoproducts_functor_precat]) - Definition of the option functor ([option_functor]) - Binary coproducts from colimits ([BinCoproducts_from_Colims]) - Equivalent universal property: (A --> C) × (B --> C) ≃ (A + B --> C) - The type of coproducts on a given diagram is a proposition - Associativity - Distribution over a functor Written by Benedikt Ahrens, March 2015 Extended by Anders Mörtberg and Tomi Pannila, 2016 Extended by Langston Barrett (@siddharthist), 2018 Extended by Ralph Matthes, 2023 *********************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.ProductCategory. Local Open Scope cat. Local Open Scope cat. (** * Definition of binary coproduct of objects in a precategory *) Section coproduct_def. Context (C : category). Definition isBinCoproduct (a b co : C) (ia : a --> co) (ib : b --> co) := ∏ (c : C) (f : a --> c) (g : b --> c), ∃! (fg : co --> c), (ia · fg = f) × (ib · fg = g). Lemma isaprop_isBinCoproduct {a b co : C} {ia : a --> co} {ib : b --> co} : isaprop (isBinCoproduct a b co ia ib). Proof. apply impred_isaprop. intros t. apply impred_isaprop. intros t0. apply impred_isaprop. intros g. apply isapropiscontr. Qed. Definition BinCoproduct (a b : C) := ∑ coiaib : (∑ co : C, a --> co × b --> co), isBinCoproduct a b (pr1 coiaib) (pr1 (pr2 coiaib)) (pr2 (pr2 coiaib)). Definition BinCoproducts := ∏ (a b : C), BinCoproduct a b. Definition hasBinCoproducts := ∏ (a b : C), ∥ BinCoproduct a b ∥. Definition BinCoproductObject {a b : C} (CC : BinCoproduct a b) : C := pr1 (pr1 CC). Coercion BinCoproductObject : BinCoproduct >-> ob. Definition BinCoproductIn1 {a b : C} (CC : BinCoproduct a b): a --> BinCoproductObject CC := pr1 (pr2 (pr1 CC)). Definition BinCoproductIn2 {a b : C} (CC : BinCoproduct a b) : b --> BinCoproductObject CC := pr2 (pr2 (pr1 CC)). Definition isBinCoproduct_BinCoproduct {a b : C} (CC : BinCoproduct a b) : isBinCoproduct a b (BinCoproductObject CC) (BinCoproductIn1 CC) (BinCoproductIn2 CC). Proof. exact (pr2 CC). Defined. Definition BinCoproductArrow {a b : C} (CC : BinCoproduct a b) {c : C} (f : a --> c) (g : b --> c) : BinCoproductObject CC --> c. Proof. exact (pr1 (pr1 (isBinCoproduct_BinCoproduct CC _ f g))). Defined. Lemma BinCoproductIn1Commutes (a b : C) (CC : BinCoproduct a b): ∏ (c : C) (f : a --> c) g, BinCoproductIn1 CC · BinCoproductArrow CC f g = f. Proof. intros c f g. exact (pr1 (pr2 (pr1 (isBinCoproduct_BinCoproduct CC _ f g)))). Qed. Lemma BinCoproductIn2Commutes (a b : C) (CC : BinCoproduct a b): ∏ (c : C) (f : a --> c) g, BinCoproductIn2 CC · BinCoproductArrow CC f g = g. Proof. intros c f g. exact (pr2 (pr2 (pr1 (isBinCoproduct_BinCoproduct CC _ f g)))). Qed. Lemma BinCoproductArrowUnique (a b : C) (CC : BinCoproduct a b) (x : C) (f : a --> x) (g : b --> x) (k : BinCoproductObject CC --> x) : BinCoproductIn1 CC · k = f → BinCoproductIn2 CC · k = g → k = BinCoproductArrow CC f g. Proof. intros H1 H2. set (H := tpair (λ h, dirprod _ _ ) k (make_dirprod H1 H2)). set (H' := (pr2 (isBinCoproduct_BinCoproduct CC _ f g)) H). apply (base_paths _ _ H'). Qed. Lemma BinCoproductArrowsEq (c d : C) (CC : BinCoproduct c d) (x : C) (k1 k2 : BinCoproductObject CC --> x) : BinCoproductIn1 CC · k1 = BinCoproductIn1 CC · k2 -> BinCoproductIn2 CC · k1 = BinCoproductIn2 CC · k2 -> k1 = k2. Proof. intros H1 H2. set (p1 := BinCoproductIn1 CC · k1). set (p2 := BinCoproductIn2 CC · k1). rewrite (BinCoproductArrowUnique _ _ CC _ p1 p2 k1). apply pathsinv0. apply BinCoproductArrowUnique. unfold p1. apply pathsinv0. apply H1. unfold p2. apply pathsinv0. apply H2. apply idpath. apply idpath. Qed. Lemma BinCoproductArrowEta (a b : C) (CC : BinCoproduct a b) (x : C) (f : BinCoproductObject CC --> x) : f = BinCoproductArrow CC (BinCoproductIn1 CC · f) (BinCoproductIn2 CC · f). Proof. apply BinCoproductArrowUnique; apply idpath. Qed. Definition BinCoproductOfArrows {a b : C} (CCab : BinCoproduct a b) {c d : C} (CCcd : BinCoproduct c d) (f : a --> c) (g : b --> d) : BinCoproductObject CCab --> BinCoproductObject CCcd := BinCoproductArrow CCab (f · BinCoproductIn1 CCcd) (g · BinCoproductIn2 CCcd). Lemma BinCoproductOfArrowsIn1 {a b : C} (CCab : BinCoproduct a b) {c d : C} (CCcd : BinCoproduct c d) (f : a --> c) (g : b --> d) : BinCoproductIn1 CCab · BinCoproductOfArrows CCab CCcd f g = f · BinCoproductIn1 CCcd. Proof. unfold BinCoproductOfArrows. apply BinCoproductIn1Commutes. Qed. Lemma BinCoproductOfArrowsIn2 {a b : C} (CCab : BinCoproduct a b) {c d : C} (CCcd : BinCoproduct c d) (f : a --> c) (g : b --> d) : BinCoproductIn2 CCab · BinCoproductOfArrows CCab CCcd f g = g · BinCoproductIn2 CCcd. Proof. unfold BinCoproductOfArrows. apply BinCoproductIn2Commutes. Qed. Definition make_BinCoproduct (a b : C) : ∏ (c : C) (f : a --> c) (g : b --> c), isBinCoproduct _ _ _ f g → BinCoproduct a b. Proof. intros. use tpair. - exists c. exists f. exact g. - apply X. Defined. Definition make_isBinCoproduct (hsC : has_homsets C) (a b co : C) (ia : a --> co) (ib : b --> co) : (∏ (c : C) (f : a --> c) (g : b --> c), ∃! k : C ⟦co, c⟧, ia · k = f × ib · k = g) → isBinCoproduct a b co ia ib. Proof. intros H c cc. apply H. Defined. Lemma precompWithBinCoproductArrow {a b : C} (CCab : BinCoproduct a b) {c d : C} (CCcd : BinCoproduct c d) (f : a --> c) (g : b --> d) {x : C} (k : c --> x) (h : d --> x) : BinCoproductOfArrows CCab CCcd f g · BinCoproductArrow CCcd k h = BinCoproductArrow CCab (f · k) (g · h). Proof. apply BinCoproductArrowUnique. - rewrite assoc. rewrite BinCoproductOfArrowsIn1. rewrite <- assoc, BinCoproductIn1Commutes. apply idpath. - rewrite assoc, BinCoproductOfArrowsIn2. rewrite <- assoc, BinCoproductIn2Commutes. apply idpath. Qed. Lemma postcompWithBinCoproductArrow {a b : C} (CCab : BinCoproduct a b) {c : C} (f : a --> c) (g : b --> c) {x : C} (k : c --> x) : BinCoproductArrow CCab f g · k = BinCoproductArrow CCab (f · k) (g · k). Proof. apply BinCoproductArrowUnique. - rewrite assoc, BinCoproductIn1Commutes; apply idpath. - rewrite assoc, BinCoproductIn2Commutes; apply idpath. Qed. Lemma BinCoproduct_endo_is_identity {a b : C} (CC : BinCoproduct a b) (k : BinCoproductObject CC --> BinCoproductObject CC) (H1 : BinCoproductIn1 CC · k = BinCoproductIn1 CC) (H2 : BinCoproductIn2 CC · k = BinCoproductIn2 CC) : identity _ = k. Proof. set (H' := pr2 CC _ (BinCoproductIn1 CC) (BinCoproductIn2 CC) ); simpl in *. set (X := (∑ fg : pr1 (pr1 CC) --> BinCoproductObject CC, pr1 (pr2 (pr1 CC))· fg = BinCoproductIn1 CC × pr2 (pr2 (pr1 CC))· fg = BinCoproductIn2 CC)). set (t1 := tpair _ k (make_dirprod H1 H2) : X). set (t2 := tpair _ (identity _ ) (make_dirprod (id_right _ ) (id_right _ ) ) : X). assert (X' : t1 = t2). { apply proofirrelevancecontr. apply H'. } apply pathsinv0. apply (base_paths _ _ X'). Qed. Definition from_BinCoproduct_to_BinCoproduct {a b : C} (CC CC' : BinCoproduct a b) : BinCoproductObject CC --> BinCoproductObject CC'. Proof. apply (BinCoproductArrow CC (BinCoproductIn1 _ ) (BinCoproductIn2 _ )). Defined. Lemma is_inverse_from_BinCoproduct_to_BinCoproduct {a b : C} (CC CC' : BinCoproduct a b) : is_inverse_in_precat (from_BinCoproduct_to_BinCoproduct CC CC') (from_BinCoproduct_to_BinCoproduct CC' CC). Proof. split; simpl. - apply pathsinv0. apply BinCoproduct_endo_is_identity. + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn1Commutes. rewrite BinCoproductIn1Commutes. apply idpath. + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn2Commutes. rewrite BinCoproductIn2Commutes. apply idpath. - apply pathsinv0. apply BinCoproduct_endo_is_identity. + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct. repeat rewrite BinCoproductIn1Commutes; apply idpath. + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct. repeat rewrite BinCoproductIn2Commutes; apply idpath. Qed. Lemma is_z_iso_from_BinCoproduct_to_BinCoproduct {a b : C} (CC CC' : BinCoproduct a b) : is_z_isomorphism (from_BinCoproduct_to_BinCoproduct CC CC'). Proof. exists (from_BinCoproduct_to_BinCoproduct CC' CC). apply is_inverse_from_BinCoproduct_to_BinCoproduct. Defined. Definition z_iso_from_BinCoproduct_to_BinCoproduct {a b : C} (CC CC' : BinCoproduct a b) : z_iso (BinCoproductObject CC) (BinCoproductObject CC') := _ ,, is_z_iso_from_BinCoproduct_to_BinCoproduct CC CC'. End coproduct_def. Arguments BinCoproduct [_] _ _. Arguments BinCoproductObject [_ _ _] _ . Arguments BinCoproductArrow [_ _ _] _ [_] _ _. Arguments BinCoproductIn1 [_ _ _] _. Arguments BinCoproductIn2 [_ _ _] _. (** * Proof that coproducts are unique when the precategory [C] is a univalent_category *) Section coproduct_unique. Context (C : category) (H : is_univalent C) (a b : C). Lemma isaprop_BinCoproduct : isaprop (BinCoproduct a b). Proof. apply invproofirrelevance. intros CC CC'. apply subtypePath. + intros. intro. do 3 (apply impred; intro); apply isapropiscontr. + apply (total2_paths_f (isotoid _ H (z_iso_from_BinCoproduct_to_BinCoproduct _ CC CC'))). rewrite transportf_dirprod. rewrite transportf_isotoid'. simpl. rewrite transportf_isotoid'. destruct CC as [CC bla]. destruct CC' as [CC' bla']; simpl in *. destruct CC as [CC [CC1 CC2]]. destruct CC' as [CC' [CC1' CC2']]; simpl in *. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn1Commutes. rewrite BinCoproductIn2Commutes. apply idpath. Qed. End coproduct_unique. Section BinCoproducts. Context (C : category) (CC : BinCoproducts C) (a b c d x y : C). Lemma BinCoproductArrow_eq_cor (f f' : BinCoproductObject (CC a b) --> c) : BinCoproductIn1 _· f = BinCoproductIn1 _· f' → BinCoproductIn2 _· f = BinCoproductIn2 _· f' → f = f' . Proof. intros Hyp1 Hyp2. rewrite (BinCoproductArrowEta _ _ _ _ _ f). rewrite (BinCoproductArrowEta _ _ _ _ _ f'). apply maponpaths_12; assumption. Qed. (** specialized versions of beta rules for coproducts *) (* all the following lemmas for manipulation of the hypothesis Lemma BinCoproductIn1Commutes_left (f : a --> c)(g : b --> c)(h : a --> c): BinCoproductIn1 C (CC _ _) · BinCoproductArrow C (CC _ _) f g = h -> f = h. Proof. intro Hyp. rewrite BinCoproductIn1Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn1Commutes_right (f : a --> c)(g : b --> c)(h : a --> c): h = BinCoproductIn1 C (CC _ _) · BinCoproductArrow C (CC _ _) f g -> h = f. Proof. intro Hyp. rewrite BinCoproductIn1Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn2Commutes_left (f : a --> c)(g : b --> c)(h : b --> c): BinCoproductIn2 C (CC _ _) · BinCoproductArrow C (CC _ _) f g = h -> g = h. Proof. intro Hyp. rewrite BinCoproductIn2Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn2Commutes_right (f : a --> c)(g : b --> c)(h : b --> c): h = BinCoproductIn2 C (CC _ _) · BinCoproductArrow C (CC _ _) f g -> h = g. Proof. intro Hyp. rewrite BinCoproductIn2Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn1Commutes_left_in_ctx (f : a --> c)(g : b --> c)(h : c --> d)(h' : a --> d): BinCoproductIn1 C (CC _ _) · (BinCoproductArrow C (CC _ _) f g · h) = h' -> f · h = h'. Proof. intro Hyp. rewrite assoc in Hyp. rewrite BinCoproductIn1Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn1Commutes_right_in_ctx (f : a --> c)(g : b --> c)(h : c --> d)(h' : a --> d): h' = BinCoproductIn1 C (CC _ _) · (BinCoproductArrow C (CC _ _) f g · h) -> h' = f · h. Proof. intro Hyp. apply pathsinv0 in Hyp. apply pathsinv0. exact (BinCoproductIn1Commutes_left_in_ctx _ _ _ _ Hyp). Qed. Lemma BinCoproductIn2Commutes_left_in_ctx (f : a --> c)(g : b --> c)(h : c --> d)(h' : b --> d): BinCoproductIn2 C (CC _ _) · (BinCoproductArrow C (CC _ _) f g · h) = h' -> g · h = h'. Proof. intro Hyp. rewrite assoc in Hyp. rewrite BinCoproductIn2Commutes in Hyp. exact Hyp. Qed. Lemma BinCoproductIn2Commutes_right_in_ctx (f : a --> c)(g : b --> c)(h : c --> d)(h' : b --> d): h' = BinCoproductIn2 C (CC _ _) · (BinCoproductArrow C (CC _ _) f g · h) -> h' = g · h. Proof. intro Hyp. apply pathsinv0 in Hyp. apply pathsinv0. exact (BinCoproductIn2Commutes_left_in_ctx _ _ _ _ Hyp). Qed. Lemma BinCoproductIn2Commutes_right_in_double_ctx (g0 : x --> b)(f : a --> c)(g : b --> c) (h : c --> d)(h' : x --> d): h' = g0 · BinCoproductIn2 C (CC _ _) · (BinCoproductArrow C (CC _ _) f g · h) -> h' = g0 · g · h. Proof. intro Hyp. rewrite Hyp. repeat rewrite <- assoc. apply maponpaths. rewrite assoc. rewrite BinCoproductIn2Commutes. apply idpath. Qed. *) (* optimized versions in direct style *) Lemma BinCoproductIn1Commutes_right_dir (f : a --> c) (g : b --> c) (h : a --> c) : h = f -> h = BinCoproductIn1 (CC _ _) · BinCoproductArrow (CC _ _) f g. Proof. intro Hyp. rewrite Hyp. apply pathsinv0. apply BinCoproductIn1Commutes. Qed. Lemma BinCoproductIn2Commutes_right_dir (f : a --> c) (g : b --> c) (h : b --> c) : h = g -> h = BinCoproductIn2 (CC _ _) · BinCoproductArrow (CC _ _) f g. Proof. intro Hyp. rewrite Hyp. apply pathsinv0. apply BinCoproductIn2Commutes. Qed. Lemma BinCoproductIn1Commutes_right_in_ctx_dir (f : a --> c) (g : b --> c) (h : c --> d) (h' : a --> d) : h' = f · h -> h' = BinCoproductIn1 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h). Proof. intro Hyp. rewrite Hyp. rewrite assoc. rewrite BinCoproductIn1Commutes. apply idpath. Qed. Lemma BinCoproductIn2Commutes_right_in_ctx_dir (f : a --> c) (g : b --> c) (h : c --> d) (h' : b --> d) : h' = g · h -> h' = BinCoproductIn2 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h). Proof. intro Hyp. rewrite Hyp. rewrite assoc. rewrite BinCoproductIn2Commutes. apply idpath. Qed. Lemma BinCoproductIn1Commutes_left_dir (f : a --> c) (g : b --> c) (h : a --> c) : f = h -> BinCoproductIn1 (CC _ _) · BinCoproductArrow (CC _ _) f g = h. Proof. intro Hyp. rewrite Hyp. apply BinCoproductIn1Commutes. Qed. Lemma BinCoproductIn2Commutes_left_dir (f : a --> c) (g : b --> c) (h : b --> c) : g = h -> BinCoproductIn2 (CC _ _) · BinCoproductArrow (CC _ _) f g = h. Proof. intro Hyp. rewrite Hyp. apply BinCoproductIn2Commutes. Qed. Lemma BinCoproductIn1Commutes_left_in_ctx_dir (f : a --> c) (g : b --> c) (h : c --> d) (h' : a --> d) : f · h = h' -> BinCoproductIn1 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h) = h'. Proof. intro Hyp. rewrite <- Hyp. rewrite assoc. rewrite BinCoproductIn1Commutes. apply idpath. Qed. Lemma BinCoproductIn2Commutes_left_in_ctx_dir (f : a --> c) (g : b --> c) (h : c --> d) (h' : b --> d) : g · h = h' -> BinCoproductIn2 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h) = h'. Proof. intro Hyp. rewrite <- Hyp. rewrite assoc. rewrite BinCoproductIn2Commutes. apply idpath. Qed. Lemma BinCoproductIn1Commutes_right_in_double_ctx_dir (g0 : x --> a) (f : a --> c) (g : b --> c) (h : c --> d) (h' : x --> d) : h' = g0 · f · h -> h' = g0 · BinCoproductIn1 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h). Proof. intro Hyp. rewrite Hyp. repeat rewrite <- assoc. apply maponpaths. rewrite assoc. rewrite BinCoproductIn1Commutes. apply idpath. Qed. Lemma BinCoproductIn2Commutes_right_in_double_ctx_dir (g0 : x --> b) (f : a --> c) (g : b --> c) (h : c --> d) (h' : x --> d) : h' = g0 · g · h -> h' = g0 · BinCoproductIn2 (CC _ _) · (BinCoproductArrow (CC _ _) f g · h). Proof. intro Hyp. rewrite Hyp. repeat rewrite <- assoc. apply maponpaths. rewrite assoc. rewrite BinCoproductIn2Commutes. apply idpath. Qed. (** end of specialized versions of the beta laws for coproducts *) (* do we ever want to create a multitude of similar lemmas for other rewrite rules? Lemma id_left_to_the_right (C': precategory)(a b : C')(f h : C' ⟦ a, b ⟧): h = f -> h = identity a· f. Proof. intro Hyp. rewrite Hyp. apply pathsinv0, id_left. Qed. Lemma id_left_to_the_right_in_ctx (C': precategory)(a b c: C')(f : C' ⟦ a, b ⟧)(g : C' ⟦ b, c ⟧) (h : C' ⟦ a, c ⟧): h = f · g -> h = identity a · f · g. Proof. intro Hyp. rewrite Hyp. rewrite id_left. apply idpath. Qed. Lemma assoc_to_the_right (C' : precategory) (a b c d : C') (f : C' ⟦ a, b ⟧) (g : C' ⟦ b, c ⟧) (h : C' ⟦ c, d ⟧)(res: C' ⟦ a, d ⟧) : res = f· g· h -> res = f· (g· h). Proof. intro Hyp. rewrite Hyp. apply pathsinv0, assoc. Qed. Lemma assoc_back_to_the_right (C' : precategory) (a b c d : C') (f : C' ⟦ a, b ⟧) (g : C' ⟦ b, c ⟧) (h : C' ⟦ c, d ⟧)(res: C' ⟦ a, d ⟧) : res = f· (g· h) -> res = f· g· h. Proof. intro Hyp. rewrite Hyp. apply assoc. Qed. *) Definition BinCoproductOfArrows_comp (f : a --> c) (f' : b --> d) (g : c --> x) (g' : d --> y) : BinCoproductOfArrows _ (CC a b) (CC c d) f f' · BinCoproductOfArrows _ (CC _ _) (CC _ _) g g' = BinCoproductOfArrows _ (CC _ _) (CC _ _) (f · g) (f' · g'). Proof. apply BinCoproductArrowUnique. - rewrite assoc. rewrite BinCoproductOfArrowsIn1. rewrite <- assoc. rewrite BinCoproductOfArrowsIn1. apply assoc. - rewrite assoc. rewrite BinCoproductOfArrowsIn2. rewrite <- assoc. rewrite BinCoproductOfArrowsIn2. apply assoc. Qed. Lemma precompWithBinCoproductArrow_eq (CCab : BinCoproduct a b) (CCcd : BinCoproduct c d) (f : a --> c) (g : b --> d) (k : c --> x) (h : d --> x) (fk : a --> x) (gh : b --> x): fk = f · k → gh = g · h → BinCoproductOfArrows _ CCab CCcd f g · BinCoproductArrow CCcd k h = BinCoproductArrow CCab (fk) (gh). Proof. intros H H'. rewrite H. rewrite H'. apply precompWithBinCoproductArrow. Qed. End BinCoproducts. (** * Binary coproducts from colimits *) Section BinCoproducts_from_Colims. Context (C : category). Definition two_graph : graph := (bool,,λ _ _,empty). Definition bincoproduct_diagram (a b : C) : diagram two_graph C. Proof. exists (λ x : bool, if x then a else b). abstract (intros u v F; induction F). Defined. Definition BinCoprod {a b c : C} (ac : a --> c) (bc : b --> c) : cocone (bincoproduct_diagram a b) c. Proof. use make_cocone. + intros x; induction x; assumption. + abstract (intros x y e; destruct e). Defined. Lemma BinCoproducts_from_Colims : Colims_of_shape two_graph C -> BinCoproducts C. Proof. intros H a b. set (CC := H (bincoproduct_diagram a b)). use make_BinCoproduct. + apply (colim CC). + apply (colimIn CC true). + apply (colimIn CC false). + apply (make_isBinCoproduct _ C); intros c f g. use unique_exists. - apply colimArrow, (BinCoprod f g). - abstract (split; [ apply (colimArrowCommutes CC c (BinCoprod f g) true) | apply (colimArrowCommutes CC c (BinCoprod f g) false) ]). - abstract (intros h; apply isapropdirprod; apply C). - abstract (now intros h [H1 H2]; apply colimArrowUnique; intro x; induction x). Defined. End BinCoproducts_from_Colims. (** * Coproducts over bool from binary coproducts *) Section CoproductsBool. Lemma CoproductsBool {C : category} (HC : BinCoproducts C) : Coproducts bool C. Proof. intros H. use make_Coproduct. - apply (HC (H true) (H false)). - induction i; apply (pr1 (HC (H true) (H false))). - use (make_isCoproduct _ _ C); intros c f. set (uniqex := pr2 (HC (H true) (H false)) c (f true) (f false)). (* induction (pr2 (HC (H true) (H false)) c (f true) (f false)) as [[x1 [x2 x3]] x4]. *) use unique_exists. + exact (pr1 (pr1 uniqex)). + abstract (cbn; induction i; [exact (pr1 (pr2 (pr1 uniqex))) | exact (pr2 (pr2 (pr1 uniqex)))]). + abstract (intros x; apply impred; intros; apply C). + abstract (intros h1 h2; apply (maponpaths pr1 (pr2 uniqex (h1,,(h2 true,,h2 false))))). Defined. Definition BinCoproducts_from_Coproducts {C : category} (HC : Coproducts bool C) : BinCoproducts C. Proof. intros x y. use make_BinCoproduct. - exact (HC (λ b, if b then x else y)). - exact (CoproductIn _ _ _ true). - exact (CoproductIn _ _ _ false). - intros w g₁ g₂. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; use CoproductArrow_eq ; intro b ; induction b ; [ exact (pr12 φ₁ @ !(pr12 φ₂)) | ] ; exact (pr22 φ₁ @ !(pr22 φ₂))). + simple refine (_ ,, _ ,, _). * refine (CoproductArrow _ _ _ _). intro b ; induction b. ** exact g₁. ** exact g₂. * abstract (exact (CoproductInCommutes _ _ _ _ _ _ true)). * abstract (exact (CoproductInCommutes _ _ _ _ _ _ false)). Defined. End CoproductsBool. Section functors. Definition bincoproduct_functor_data {C : category} (PC : BinCoproducts C) : functor_data (category_binproduct C C) C. Proof. use tpair. - intros p. apply (BinCoproductObject (PC (pr1 p) (pr2 p))). - intros p q f. apply (BinCoproductOfArrows _ (PC (pr1 p) (pr2 p)) (PC (pr1 q) (pr2 q)) (pr1 f) (pr2 f)). Defined. (* The binary coproduct functor: C * C -> C *) Lemma is_functor_bincoproduct_functor_data {C : category} (PC : BinCoproducts C) : is_functor (bincoproduct_functor_data PC). Proof. split. - intro x; simpl; apply pathsinv0. use BinCoproduct_endo_is_identity. + now rewrite BinCoproductOfArrowsIn1, id_left. + now rewrite BinCoproductOfArrowsIn2, id_left. - now intros x y z f g; simpl; rewrite BinCoproductOfArrows_comp. Qed. Definition bincoproduct_functor {C : category} (PC : BinCoproducts C) : functor (category_binproduct C C) C := make_functor _ (is_functor_bincoproduct_functor_data PC). (* Defines the coproduct of two functors *) Definition BinCoproduct_of_functors_alt {C D : category} (HD : BinCoproducts D) (F G : C ⟶ D) : C ⟶ D := tuple_functor (λ b, bool_rect (λ _, C ⟶ D) F G b) ∙ coproduct_functor bool (CoproductsBool HD). (* Defines the coproduct of two functors by: x -> (x,x) -> (F x,G x) -> F x + G x For a direct and equal definition see FunctorsPointwiseBinCoproduct.v (seems obsolete) Above is a slightly simpler definition *) Definition BinCoproduct_of_functors_alt2 {C D : category} (HD : BinCoproducts D) (F G : functor C D) : functor C D := bindelta_functor C ∙ (pair_functor F G ∙ bincoproduct_functor HD). End functors. (** In the following section we show that if the morphisms to components are zero, then the unique morphism factoring through the bincoproduct is the zero morphism. *) Section BinCoproduct_zeroarrow. Context (C : category) (Z : Zero C). Lemma BinCoproductArrowZero {x y z: C} {BP : BinCoproduct x y} (f : x --> z) (g : y --> z) : f = ZeroArrow Z _ _ -> g = ZeroArrow Z _ _ -> BinCoproductArrow BP f g = ZeroArrow Z _ _ . Proof. intros X X0. apply pathsinv0. use BinCoproductArrowUnique. rewrite X. apply ZeroArrow_comp_right. rewrite X0. apply ZeroArrow_comp_right. Qed. End BinCoproduct_zeroarrow. (** Goal: lift coproducts from the target (pre)category to the functor (pre)category *) Section def_functor_pointwise_coprod. Context (C D : category) (HD : BinCoproducts D). Section BinCoproduct_of_functors. Context (F G : functor C D). Local Notation "c ⊗ d" := (BinCoproductObject (HD c d)). Definition BinCoproduct_of_functors_ob (c : C) : D := F c ⊗ G c. Definition BinCoproduct_of_functors_mor (c c' : C) (f : c --> c') : BinCoproduct_of_functors_ob c --> BinCoproduct_of_functors_ob c' := BinCoproductOfArrows _ _ _ (#F f) (#G f). Definition BinCoproduct_of_functors_data : functor_data C D. Proof. exists BinCoproduct_of_functors_ob. exact BinCoproduct_of_functors_mor. Defined. Lemma is_functor_BinCoproduct_of_functors_data : is_functor BinCoproduct_of_functors_data. Proof. split; simpl; intros. - unfold functor_idax; intros; simpl in *. apply pathsinv0. apply BinCoproduct_endo_is_identity. + unfold BinCoproduct_of_functors_mor. rewrite BinCoproductOfArrowsIn1. rewrite functor_id. apply id_left. + unfold BinCoproduct_of_functors_mor. rewrite BinCoproductOfArrowsIn2. rewrite functor_id. apply id_left. - unfold functor_compax, BinCoproduct_of_functors_mor; intros; simpl in *. unfold BinCoproduct_of_functors_mor. do 2 rewrite functor_comp. rewrite <- BinCoproductOfArrows_comp. apply idpath. (* former proof: unfold BinCoproductOfArrows. apply pathsinv0. apply BinCoproductArrowUnique. + rewrite assoc. simpl in *. set (H:= BinCoproductIn1Commutes ). set (H2 := H D _ _ (HD (F a) (G a))). rewrite H2. rewrite <- assoc. rewrite functor_comp. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn1Commutes. + rewrite assoc. set (H:= BinCoproductIn2Commutes D _ _ (HD (F a) (G a))). rewrite H. rewrite functor_comp. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes. *) Qed. Definition BinCoproduct_of_functors : functor C D := tpair _ _ is_functor_BinCoproduct_of_functors_data. Lemma BinCoproduct_of_functors_alt2_eq_BinCoproduct_of_functors : BinCoproduct_of_functors_alt2 HD F G = BinCoproduct_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Lemma BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors : BinCoproduct_of_functors_alt HD F G = BinCoproduct_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Lemma BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors_alt2 : BinCoproduct_of_functors_alt HD F G = BinCoproduct_of_functors_alt2 HD F G. Proof. now apply (functor_eq _ _ D). Qed. Definition coproduct_nat_trans_in1_data : ∏ c, F c --> BinCoproduct_of_functors c := λ c : C, BinCoproductIn1 (HD (F c) (G c)). Lemma is_nat_trans_coproduct_nat_trans_in1_data : is_nat_trans _ _ coproduct_nat_trans_in1_data. Proof. unfold is_nat_trans. intros c c' f. unfold coproduct_nat_trans_in1_data. unfold BinCoproduct_of_functors. simpl. unfold BinCoproduct_of_functors_mor. assert (XX:= BinCoproductOfArrowsIn1). assert (X1 := XX _ (F c) (G c) (HD (F c) (G c))). assert (X2 := X1 _ _ (HD (F c') (G c'))). rewrite X2. apply idpath. Qed. Definition coproduct_nat_trans_in1 : nat_trans _ _ := tpair _ _ is_nat_trans_coproduct_nat_trans_in1_data. Definition coproduct_nat_trans_in2_data : ∏ c, G c --> BinCoproduct_of_functors c := λ c : C, BinCoproductIn2 (HD (F c) (G c)). Lemma is_nat_trans_coproduct_nat_trans_in2_data : is_nat_trans _ _ coproduct_nat_trans_in2_data. Proof. unfold is_nat_trans. intros c c' f. unfold coproduct_nat_trans_in2_data. unfold BinCoproduct_of_functors. simpl. unfold BinCoproduct_of_functors_mor. assert (XX:= BinCoproductOfArrowsIn2). assert (X1 := XX _ (F c) (G c) (HD (F c) (G c))). assert (X2 := X1 _ _ (HD (F c') (G c'))). rewrite X2. apply idpath. Qed. Definition coproduct_nat_trans_in2 : nat_trans _ _ := tpair _ _ is_nat_trans_coproduct_nat_trans_in2_data. Section vertex. (** The coproduct morphism of a diagram with vertex [A] *) Context (A : functor C D) (f : F ⟹ A) (g : G ⟹ A). Definition coproduct_nat_trans_data : ∏ c, BinCoproduct_of_functors c --> A c. Proof. intro c. apply BinCoproductArrow. - exact (f c). - exact (g c). Defined. Lemma is_nat_trans_coproduct_nat_trans_data : is_nat_trans _ _ coproduct_nat_trans_data. Proof. intros a b k. simpl. unfold BinCoproduct_of_functors_mor. unfold coproduct_nat_trans_data. simpl. set (XX:=precompWithBinCoproductArrow). set (X1 := XX D _ _ (HD (F a) (G a))). set (X2 := X1 _ _ (HD (F b) (G b))). rewrite X2. clear X2 X1 XX. set (XX:=postcompWithBinCoproductArrow). set (X1 := XX D _ _ (HD (F a) (G a))). rewrite X1. rewrite (nat_trans_ax f). rewrite (nat_trans_ax g). apply idpath. Qed. Definition coproduct_nat_trans : nat_trans _ _ := tpair _ _ is_nat_trans_coproduct_nat_trans_data. Lemma coproduct_nat_trans_In1Commutes : nat_trans_comp _ _ _ coproduct_nat_trans_in1 coproduct_nat_trans = f. Proof. apply nat_trans_eq. - apply D. - intro c; simpl. apply BinCoproductIn1Commutes. Qed. Lemma coproduct_nat_trans_In2Commutes : nat_trans_comp _ _ _ coproduct_nat_trans_in2 coproduct_nat_trans = g. Proof. apply nat_trans_eq. - apply D. - intro c; simpl. apply BinCoproductIn2Commutes. Qed. End vertex. Lemma coproduct_nat_trans_univ_prop (A : [C, D]) (f : (F : [C,D]) --> A) (g : (G : [C,D]) --> A) : ∏ t : ∑ fg : (BinCoproduct_of_functors:[C,D]) --> A, (coproduct_nat_trans_in1 : (F:[C,D]) --> BinCoproduct_of_functors)· fg = f × (coproduct_nat_trans_in2: (G : [C,D]) --> BinCoproduct_of_functors)· fg = g, t = tpair (λ fg : (BinCoproduct_of_functors:[C,D]) --> A, (coproduct_nat_trans_in1 : (F:[C,D]) --> BinCoproduct_of_functors)· fg = f × (coproduct_nat_trans_in2 : (G:[C,D]) --> BinCoproduct_of_functors) · fg = g) (coproduct_nat_trans A f g) (make_dirprod (coproduct_nat_trans_In1Commutes A f g) (coproduct_nat_trans_In2Commutes A f g)). Proof. intro t. simpl in *. destruct t as [t1 [ta tb]]. simpl in *. apply subtypePath. - intro. apply isapropdirprod; apply isaset_nat_trans; apply D. - simpl. apply nat_trans_eq. + apply D. + intro c. unfold coproduct_nat_trans. simpl. unfold coproduct_nat_trans_data. simpl. apply BinCoproductArrowUnique. * apply (nat_trans_eq_pointwise ta). * apply (nat_trans_eq_pointwise tb). Qed. Definition functor_precat_coproduct_cocone : @BinCoproduct [C, D] F G. Proof. use make_BinCoproduct. - apply BinCoproduct_of_functors. - apply coproduct_nat_trans_in1. - apply coproduct_nat_trans_in2. - use make_isBinCoproduct. + apply functor_category_has_homsets. + intros A f g. exists (tpair _ (coproduct_nat_trans A f g) (make_dirprod (coproduct_nat_trans_In1Commutes _ _ _ ) (coproduct_nat_trans_In2Commutes _ _ _ ))). apply coproduct_nat_trans_univ_prop. Defined. End BinCoproduct_of_functors. Definition BinCoproducts_functor_precat : BinCoproducts [C, D]. Proof. intros F G. apply functor_precat_coproduct_cocone. Defined. End def_functor_pointwise_coprod. Section generalized_option_functors. Context {C : category} (CC : BinCoproducts C). (* The functors "a + _" and "_ + a" *) Definition constcoprod_functor1 (a : C) : functor C C := BinCoproduct_of_functors C C CC (constant_functor C C a) (functor_identity C). Definition constcoprod_functor2 (a : C) : functor C C := BinCoproduct_of_functors C C CC (functor_identity C) (constant_functor C C a). Section option_functor. Context (TC : Terminal C). Let one : C := TerminalObject TC. Definition option_functor : functor C C := constcoprod_functor1 one. End option_functor. End generalized_option_functors. (** ** Construction of isBinCoproduct from an isomorphism to BinCoproduct. *) Section BinCoproduct_from_z_iso. Context (C : category). Local Lemma z_iso_to_isBinCoproduct_comm {x y z : C} (BP : BinCoproduct x y) (i : z_iso z (BinCoproductObject BP)) (w : C) (f : x --> w) (g : y --> w) : (BinCoproductIn1 BP · inv_from_z_iso i · (i · BinCoproductArrow BP f g) = f) × (BinCoproductIn2 BP · inv_from_z_iso i · (i · BinCoproductArrow BP f g) = g). Proof. split. - rewrite <- assoc. rewrite (assoc _ i). rewrite (z_iso_after_z_iso_inv i). rewrite id_left. apply BinCoproductIn1Commutes. - rewrite <- assoc. rewrite (assoc _ i). rewrite (z_iso_after_z_iso_inv i). rewrite id_left. apply BinCoproductIn2Commutes. Qed. Local Lemma z_iso_to_isBinCoproduct_unique {x y z : C} (BP : BinCoproduct x y) (i : z_iso z (BinCoproductObject BP)) (w : C) (f : x --> w) (g : y --> w) (y0 : C ⟦ z, w ⟧) (T : (BinCoproductIn1 BP · inv_from_z_iso i · y0 = f) × (BinCoproductIn2 BP · inv_from_z_iso i · y0 = g)) : y0 = i · BinCoproductArrow BP f g. Proof. apply (pre_comp_with_z_iso_is_inj (z_iso_inv_from_z_iso i)). rewrite assoc. cbn. rewrite (z_iso_after_z_iso_inv i). rewrite id_left. apply BinCoproductArrowUnique. - rewrite assoc. apply (dirprod_pr1 T). - rewrite assoc. apply (dirprod_pr2 T). Qed. Lemma z_iso_to_isBinCoproduct {x y z : C} (BP : BinCoproduct x y) (i : z_iso z (BinCoproductObject BP)) : isBinCoproduct C _ _ z ((BinCoproductIn1 BP) · (z_iso_inv_from_z_iso i)) ((BinCoproductIn2 BP) · (z_iso_inv_from_z_iso i)). Proof. intros w f g. use unique_exists. (* The arrow *) - exact (i · (BinCoproductArrow BP f g)). (* Commutativity *) - exact (z_iso_to_isBinCoproduct_comm BP i w f g). (* Equality on equalities of morphisms. *) - abstract (intros y0; apply isapropdirprod; apply C). (* Uniqueness *) - abstract (intros y0 T; exact (z_iso_to_isBinCoproduct_unique BP i w f g y0 T)). Qed. Definition z_iso_to_BinCoproduct {x y z : C} (BP : BinCoproduct x y) (i : z_iso z (BinCoproductObject BP)) : BinCoproduct x y := make_BinCoproduct C _ _ z ((BinCoproductIn1 BP) · (z_iso_inv_from_z_iso i)) ((BinCoproductIn2 BP) · (z_iso_inv_from_z_iso i)) (z_iso_to_isBinCoproduct BP i). End BinCoproduct_from_z_iso. (** Equivalent universal property: (A --> C) × (B --> C) ≃ (A + B --> C) Compare to [weqfunfromcoprodtoprod]. *) Section EquivalentDefinition. Context {C : category} {a b co : ob C} (i1 : a --> co) (i2 : b --> co) . Definition precomp_with_injections (c : ob C) (f : co --> c) : (a --> c) × (b --> c) := make_dirprod (i1 · f) (i2 · f). Definition isBinCoproduct' : UU := ∏ c : ob C, isweq (precomp_with_injections c). Definition isBinCoproduct'_weq (is : isBinCoproduct') : ∏ c, (co --> c) ≃ (a --> c) × (b --> c) := λ a, make_weq (precomp_with_injections a) (is a). Lemma isBinCoproduct'_to_isBinCoproduct : isBinCoproduct' -> isBinCoproduct _ _ _ co i1 i2. Proof. intros isBCP' ? f g. apply (@iscontrweqf (hfiber (isBinCoproduct'_weq isBCP' _) (make_dirprod f g))). - use weqfibtototal; intro; cbn. unfold precomp_with_injections. apply pathsdirprodweq. - apply weqproperty. Defined. Lemma isBinCoproduct_to_isBinCoproduct' : isBinCoproduct _ _ _ co i1 i2 -> isBinCoproduct'. Proof. intros isBCP ? fg. unfold hfiber, precomp_with_injections. apply (@iscontrweqf (∑ u : C ⟦ co, c ⟧, i1 · u = pr1 fg × i2 · u = pr2 fg)). - use weqfibtototal; intros to_prod. apply invweq, pathsdirprodweq. - exact (isBCP c (pr1 fg) (pr2 fg)). (* apply universal property *) Defined. (* TODO: prove that [isBinCoproduct'_to_isBinCoproduct] is an equivalence *) End EquivalentDefinition. (** Match non-implicit arguments of [isBinCoproduct] *) Arguments isBinCoproduct' _ _ _ _ _ : clear implicits. (** Coproducts when the inclusions are equal *) Definition isBinCoproduct_eq_arrow {C : category} {x y z : C} {ι₁ ι₁' : x --> z} (p₁ : ι₁ = ι₁') {ι₂ ι₂' : y --> z} (p₂ : ι₂ = ι₂') (H : isBinCoproduct C x y z ι₁ ι₂) : isBinCoproduct C x y z ι₁' ι₂'. Proof. pose (P := make_BinCoproduct _ _ _ _ _ _ H). intros w f g. use iscontraprop1. - abstract (induction p₁, p₂ ; apply isapropifcontr ; apply H). - simple refine (_ ,, _ ,, _). + exact (BinCoproductArrow P f g). + abstract (induction p₁ ; exact (BinCoproductIn1Commutes _ _ _ P _ f g)). + abstract (induction p₂ ; exact (BinCoproductIn2Commutes _ _ _ P _ f g)). Defined. (** Coproduct of isos *) Section BinCoproductOfIsos. Context {C : category} {a b c d : C} (Pab : BinCoproduct a b) (Pcd : BinCoproduct c d) (f : z_iso a c) (g : z_iso b d). Let fg : BinCoproductObject Pab --> BinCoproductObject Pcd := BinCoproductOfArrows _ _ _ f g. Let fg_inv : BinCoproductObject Pcd --> BinCoproductObject Pab := BinCoproductOfArrows _ _ _ (inv_from_z_iso f) (inv_from_z_iso g). Lemma bincoproduct_of_z_iso_inv : is_inverse_in_precat fg fg_inv. Proof. split; use BinCoproductArrowsEq; unfold fg, fg_inv. - rewrite !assoc. rewrite BinCoproductOfArrowsIn1. rewrite !assoc'. rewrite BinCoproductOfArrowsIn1. rewrite !assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. - rewrite !assoc. rewrite BinCoproductOfArrowsIn2. rewrite !assoc'. rewrite BinCoproductOfArrowsIn2. rewrite !assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. - rewrite !assoc. rewrite BinCoproductOfArrowsIn1. rewrite !assoc'. rewrite BinCoproductOfArrowsIn1. rewrite !assoc. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. - rewrite !assoc. rewrite BinCoproductOfArrowsIn2. rewrite !assoc'. rewrite BinCoproductOfArrowsIn2. rewrite !assoc. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. Qed. Definition bincoproduct_of_z_iso : z_iso (BinCoproductObject Pab) (BinCoproductObject Pcd). Proof. use make_z_iso. - exact fg. - exact fg_inv. - exact bincoproduct_of_z_iso_inv. Defined. End BinCoproductOfIsos. Section AssociativityOfBinaryCoproduct. Context {C : category} (BCP : BinCoproducts C). Definition bincoprod_associator_data (c d e : C) : BCP (BCP c d) e --> BCP c (BCP d e). Proof. use BinCoproductArrow. - use BinCoproductOfArrows. + exact (identity c). + apply BinCoproductIn1. - refine (_ · BinCoproductIn2 _). apply BinCoproductIn2. Defined. Definition bincoprod_associatorinv_data (c d e : C) : BCP c (BCP d e) --> BCP (BCP c d) e. Proof. use BinCoproductArrow. - refine (_ · BinCoproductIn1 _). apply BinCoproductIn1. - use BinCoproductOfArrows. + apply BinCoproductIn2. + exact (identity e). Defined. Lemma bincoprod_associator_inverses (c d e : C) : is_inverse_in_precat (bincoprod_associator_data c d e) (bincoprod_associatorinv_data c d e). Proof. split. + apply pathsinv0, BinCoproduct_endo_is_identity. * rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } use BinCoproductArrowsEq. -- repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } rewrite id_left. etrans. { apply BinCoproductIn1Commutes. } apply idpath. -- repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn2Commutes. } apply BinCoproductOfArrowsIn1. * rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn2Commutes. } rewrite BinCoproductOfArrowsIn2. apply id_left. + apply pathsinv0, BinCoproduct_endo_is_identity. * rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn1Commutes. } rewrite BinCoproductOfArrowsIn1. apply id_left. * rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } use BinCoproductArrowsEq. -- repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductOfArrowsIn1. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn1Commutes. } apply BinCoproductOfArrowsIn2. -- repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductOfArrowsIn2. } rewrite id_left. etrans. { apply BinCoproductIn2Commutes. } apply idpath. Qed. Definition bincoprod_associator (c d e : C) : z_iso (BCP (BCP c d) e) (BCP c (BCP d e)) := bincoprod_associator_data c d e,, bincoprod_associatorinv_data c d e,, bincoprod_associator_inverses c d e. End AssociativityOfBinaryCoproduct. Section DistributionThroughFunctor. Context {C D : category} (BCPC : BinCoproducts C) (BCPD : BinCoproducts D) (F : functor C D). Definition bincoprod_antidistributor (c c' : C) : BCPD (F c) (F c') --> F (BCPC c c'). Proof. use BinCoproductArrow; apply #F; [apply BinCoproductIn1 | apply BinCoproductIn2 ]. Defined. Lemma bincoprod_antidistributor_nat (cc'1 cc'2 : category_binproduct C C) (g : category_binproduct C C ⟦ cc'1, cc'2 ⟧) : bincoprod_antidistributor (pr1 cc'1) (pr2 cc'1) · #F (#(bincoproduct_functor BCPC) g) = #(bincoproduct_functor BCPD) (#(pair_functor F F) g) · bincoprod_antidistributor (pr1 cc'2) (pr2 cc'2). Proof. etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } apply maponpaths_12. - etrans. { apply pathsinv0, functor_comp. } etrans. 2: { apply functor_comp. } apply maponpaths. apply BinCoproductIn1Commutes. - etrans. { apply pathsinv0, functor_comp. } etrans. 2: { apply functor_comp. } apply maponpaths. apply BinCoproductIn2Commutes. Qed. Lemma bincoprod_antidistributor_commutes_with_associativity_of_coproduct (c d e : C) : #(bincoproduct_functor BCPD) (catbinprodmor (bincoprod_antidistributor c d) (identity (F e))) · bincoprod_antidistributor (BCPC c d) e · #F (bincoprod_associator_data BCPC c d e) = bincoprod_associator_data BCPD (F c) (F d) (F e) · #(bincoproduct_functor BCPD) (catbinprodmor (identity (F c)) (bincoprod_antidistributor d e)) · bincoprod_antidistributor c (BCPC d e). Proof. etrans. { apply cancel_postcomposition. apply precompWithBinCoproductArrow. } etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, precompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, postcompWithBinCoproductArrow. } apply maponpaths_12. - etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } etrans. { rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. apply BinCoproductIn1Commutes. } etrans. { cbn. apply postcompWithBinCoproductArrow. } apply maponpaths_12. + cbn. do 2 rewrite id_left. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. rewrite BinCoproductOfArrowsIn1. apply id_left. + cbn. etrans. { apply pathsinv0, functor_comp. } etrans. { apply maponpaths. apply BinCoproductOfArrowsIn2. } rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductIn1Commutes. } apply functor_comp. - etrans. { cbn. rewrite id_left. apply pathsinv0, functor_comp. } etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, BinCoproductIn2Commutes. } cbn. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductIn2Commutes. } etrans. { apply maponpaths. apply BinCoproductIn2Commutes. } apply functor_comp. Qed. (** axiomatize extra requirements *) Definition bincoprod_distributor_data : UU := ∏ (c c' : C), F (BCPC c c') --> BCPD (F c) (F c'). Identity Coercion bincoprod_distributor_data_funclass: bincoprod_distributor_data >-> Funclass. Definition bincoprod_distributor_iso_law (δ : bincoprod_distributor_data) : UU := ∏ (c c' : C), is_inverse_in_precat (δ c c') (bincoprod_antidistributor c c'). Definition bincoprod_distributor : UU := ∑ δ : bincoprod_distributor_data, bincoprod_distributor_iso_law δ. Definition bincoprod_distributor_to_data (δ : bincoprod_distributor) : bincoprod_distributor_data := pr1 δ. Coercion bincoprod_distributor_to_data : bincoprod_distributor >-> bincoprod_distributor_data. End DistributionThroughFunctor. Section DistributionForPrecompositionFunctor. Context {A B C : category} (BCPC : BinCoproducts C) (H : functor A B). Let BCPAC : BinCoproducts [A,C] := BinCoproducts_functor_precat A C BCPC. Let BCPBC : BinCoproducts [B,C] := BinCoproducts_functor_precat B C BCPC. Let precomp : functor [B,C] [A,C] := pre_composition_functor A B C H. Definition precomp_bincoprod_distributor_data : bincoprod_distributor_data BCPBC BCPAC precomp. Proof. intros G1 G2. apply nat_trans_id. Defined. Lemma precomp_bincoprod_distributor_law : bincoprod_distributor_iso_law _ _ _ precomp_bincoprod_distributor_data. Proof. intros F G. split. - apply (nat_trans_eq C). intro c. cbn. rewrite id_left. apply pathsinv0, BinCoproduct_endo_is_identity. + apply BinCoproductIn1Commutes. + apply BinCoproductIn2Commutes. - etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, BinCoproductArrowEta. } apply maponpaths_12; (rewrite id_right; apply (nat_trans_eq C); intro c; apply id_right). Qed. Definition precomp_bincoprod_distributor : bincoprod_distributor BCPBC BCPAC precomp := _,,precomp_bincoprod_distributor_law. End DistributionForPrecompositionFunctor. UniMath-20231010/UniMath/CategoryTheory/limits/binproducts.v000066400000000000000000001261261451125700300236600ustar00rootroot00000000000000(** * Direct implementation of binary products Written by: Benedikt Ahrens, Ralph Matthes Extended by: Anders Mörtberg and Tomi Pannila Extended by: Langston Barrett (@siddharthist), 2018 *) (** ** Contents - Definition of binary products - Definition of binary product functor ([binproduct_functor]) - Definition of a binary product structure on a functor category by taking pointwise binary products in the target category ([BinProducts_functor_precat]) - Binary products from limits ([BinProducts_from_Lims]) - Equivalent universal property: [(C --> A) × (C --> B) ≃ (C --> A × B)] - Terminal object as the unit (up to isomorphism) of binary products - Definition of the "associative" z-isomorphism [BinProduct_assoc] - Definition of the diagonal map [diagonalMap] *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. (** ** Definition of binary products *) Section binproduct_def. Context (C : category). Definition isBinProduct (c d p : C) (p1 : p --> c) (p2 : p --> d) : UU := ∏ (a : C) (f : a --> c) (g : a --> d), ∃! fg, (fg · p1 = f) × (fg · p2 = g). Lemma isaprop_isBinProduct (c d p : C) (p1 : p --> c) (p2 : p --> d) : isaprop (isBinProduct c d p p1 p2). Proof. do 3 (apply impred_isaprop; intro). apply isapropiscontr. Qed. Definition BinProduct (c d : C) : UU := ∑ pp1p2 : (∑ p : C, (p --> c) × (p --> d)), isBinProduct c d (pr1 pp1p2) (pr1 (pr2 pp1p2)) (pr2 (pr2 pp1p2)). Definition BinProducts : UU := ∏ (c d : C), BinProduct c d. Definition hasBinProducts : UU := ∏ (c d : C), ∥ BinProduct c d ∥. Definition BinProductObject {c d : C} (P : BinProduct c d) : C := pr1 (pr1 P). Coercion BinProductObject : BinProduct >-> ob. Definition BinProductPr1 {c d : C} (P : BinProduct c d): BinProductObject P --> c := pr1 (pr2 (pr1 P)). Definition BinProductPr2 {c d : C} (P : BinProduct c d) : BinProductObject P --> d := pr2 (pr2 (pr1 P)). Definition isBinProduct_BinProduct {c d : C} (P : BinProduct c d) : isBinProduct c d (BinProductObject P) (BinProductPr1 P) (BinProductPr2 P). Proof. exact (pr2 P). Defined. Definition BinProductArrow {c d : C} (P : BinProduct c d) {a : C} (f : a --> c) (g : a --> d) : a --> BinProductObject P. Proof. exact (pr1 (pr1 (isBinProduct_BinProduct P _ f g))). Defined. Lemma BinProductPr1Commutes (c d : C) (P : BinProduct c d): ∏ (a : C) (f : a --> c) g, BinProductArrow P f g · BinProductPr1 P = f. Proof. intros a f g. exact (pr1 (pr2 (pr1 (isBinProduct_BinProduct P _ f g)))). Qed. Lemma BinProductPr2Commutes (c d : C) (P : BinProduct c d): ∏ (a : C) (f : a --> c) g, BinProductArrow P f g · BinProductPr2 P = g. Proof. intros a f g. exact (pr2 (pr2 (pr1 (isBinProduct_BinProduct P _ f g)))). Qed. Lemma BinProductArrowUnique (c d : C) (P : BinProduct c d) (x : C) (f : x --> c) (g : x --> d) (k : x --> BinProductObject P) : k · BinProductPr1 P = f -> k · BinProductPr2 P = g -> k = BinProductArrow P f g. Proof. intros; apply path_to_ctr; split; assumption. Qed. Lemma BinProductArrowsEq (c d : C) (P : BinProduct c d) (x : C) (k1 k2 : x --> BinProductObject P) : k1 · BinProductPr1 P = k2 · BinProductPr1 P -> k1 · BinProductPr2 P = k2 · BinProductPr2 P -> k1 = k2. Proof. intros H1 H2. set (p1 := k1 · BinProductPr1 P). set (p2 := k1 · BinProductPr2 P). rewrite (BinProductArrowUnique _ _ P _ p1 p2 k1). apply pathsinv0. apply BinProductArrowUnique. unfold p1. apply pathsinv0. apply H1. unfold p2. apply pathsinv0. apply H2. apply idpath. apply idpath. Qed. Definition make_BinProduct (a b : C) : ∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), isBinProduct _ _ _ f g -> BinProduct a b. Proof. intros. use tpair. - exists c. exists f. exact g. - exact X. Defined. Definition make_isBinProduct (a b p : C) (pa : C⟦p,a⟧) (pb : C⟦p,b⟧) : (∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), ∃! k : C⟦c,p⟧, k · pa = f × k · pb = g) -> isBinProduct a b p pa pb. Proof. intros H c cc g. apply H. Defined. Lemma BinProductArrowEta (c d : C) (P : BinProduct c d) (x : C) (f : x --> BinProductObject P) : f = BinProductArrow P (f · BinProductPr1 P) (f · BinProductPr2 P). Proof. apply BinProductArrowUnique; apply idpath. Qed. Definition BinProductOfArrows {c d : C} (Pcd : BinProduct c d) {a b : C} (Pab : BinProduct a b) (f : a --> c) (g : b --> d) : BinProductObject Pab --> BinProductObject Pcd := BinProductArrow Pcd (BinProductPr1 Pab · f) (BinProductPr2 Pab · g). Lemma BinProductOfArrowsPr1 {c d : C} (Pcd : BinProduct c d) {a b : C} (Pab : BinProduct a b) (f : a --> c) (g : b --> d) : BinProductOfArrows Pcd Pab f g · BinProductPr1 Pcd = BinProductPr1 Pab · f. Proof. unfold BinProductOfArrows. rewrite BinProductPr1Commutes. apply idpath. Qed. Lemma BinProductOfArrowsPr2 {c d : C} (Pcd : BinProduct c d) {a b : C} (Pab : BinProduct a b) (f : a --> c) (g : b --> d) : BinProductOfArrows Pcd Pab f g · BinProductPr2 Pcd = BinProductPr2 Pab · g. Proof. unfold BinProductOfArrows. rewrite BinProductPr2Commutes. apply idpath. Qed. Lemma postcompWithBinProductArrow {c d : C} (Pcd : BinProduct c d) {a b : C} (Pab : BinProduct a b) (f : a --> c) (g : b --> d) {x : C} (k : x --> a) (h : x --> b) : BinProductArrow Pab k h · BinProductOfArrows Pcd Pab f g = BinProductArrow Pcd (k · f) (h · g). Proof. apply BinProductArrowUnique. - rewrite <- assoc, BinProductOfArrowsPr1. rewrite assoc, BinProductPr1Commutes. apply idpath. - rewrite <- assoc, BinProductOfArrowsPr2. rewrite assoc, BinProductPr2Commutes. apply idpath. Qed. Lemma precompWithBinProductArrow {c d : C} (Pcd : BinProduct c d) {a : C} (f : a --> c) (g : a --> d) {x : C} (k : x --> a) : k · BinProductArrow Pcd f g = BinProductArrow Pcd (k · f) (k · g). Proof. apply BinProductArrowUnique. - rewrite <- assoc, BinProductPr1Commutes; apply idpath. - rewrite <- assoc, BinProductPr2Commutes; apply idpath. Qed. End binproduct_def. Section BinProducts. Context (C : category) (CC : BinProducts C). Definition BinProductOfArrows_comp (a b c d x y : C) (f : a --> c) (f' : b --> d) (g : c --> x) (g' : d --> y) : BinProductOfArrows _ (CC c d) (CC a b) f f' · BinProductOfArrows _ (CC _ _) (CC _ _) g g' = BinProductOfArrows _ (CC _ _) (CC _ _)(f · g) (f' · g'). Proof. apply BinProductArrowUnique. - rewrite <- assoc. rewrite BinProductOfArrowsPr1. rewrite assoc. rewrite BinProductOfArrowsPr1. apply pathsinv0. apply assoc. - rewrite <- assoc. rewrite BinProductOfArrowsPr2. rewrite assoc. rewrite BinProductOfArrowsPr2. apply pathsinv0. apply assoc. Qed. Lemma BinProductOfArrows_idxcomp {a b c d : C} (f:C⟦ b, c ⟧) (g:C⟦ c, d ⟧) : BinProductOfArrows _ (CC a c) (CC a b) (identity a) f · BinProductOfArrows _ (CC _ _) (CC _ _) (identity a) g = BinProductOfArrows _ (CC _ _) (CC _ _)(identity a) (f·g). Proof. now rewrite BinProductOfArrows_comp, id_right. Qed. Lemma BinProductOfArrows_compxid {a b c d : C} (f:C⟦ b, c ⟧) (g:C⟦ c, d ⟧) : BinProductOfArrows _ (CC c a) (CC b a) f (identity a) · BinProductOfArrows _ (CC _ _) (CC _ _) g (identity a) = BinProductOfArrows _ (CC _ _) (CC _ _) (f·g) (identity a). Proof. now rewrite BinProductOfArrows_comp, id_right. Qed. Lemma BinProductOfArrows_id (a b:C) : BinProductOfArrows _ (CC a b) (CC a b) (identity a) (identity b) = identity _ . Proof. unfold BinProductOfArrows. use pathsinv0. use BinProductArrowUnique. + now rewrite id_left, id_right. + now rewrite id_left, id_right. Qed. End BinProducts. Section BinProduct_unique. Context (C : category) (CC : BinProducts C) (a b : C). Lemma BinProduct_endo_is_identity (P : BinProduct _ a b) (k : BinProductObject _ P --> BinProductObject _ P) (H1 : k · BinProductPr1 _ P = BinProductPr1 _ P) (H2 : k · BinProductPr2 _ P = BinProductPr2 _ P) : identity _ = k. Proof. apply pathsinv0. eapply pathscomp0. apply BinProductArrowEta. apply pathsinv0. apply BinProductArrowUnique; apply pathsinv0. + rewrite id_left. exact H1. + rewrite id_left. exact H2. Qed. End BinProduct_unique. (** ** Binary products from limits ([BinProducts_from_Lims]) *) Section BinProducts_from_Lims. Context (C : category). Definition two_graph : graph := (bool,,λ _ _,empty). Definition binproduct_diagram (a b : C) : diagram two_graph C. Proof. exists (λ x : bool, if x then a else b). abstract (intros u v F; induction F). Defined. Definition Binproduct {a b c : C} (f : c --> a) (g : c --> b) : cone (binproduct_diagram a b) c. Proof. use make_cone. + intros x; induction x; assumption. + abstract (intros x y e; destruct e). Defined. Lemma BinProducts_from_Lims : Lims_of_shape two_graph C -> BinProducts C. Proof. intros H a b. set (LC := H (binproduct_diagram a b)). use make_BinProduct. + apply (lim LC). + apply (limOut LC true). + apply (limOut LC false). + apply (make_isBinProduct C); intros c f g. use unique_exists. - apply limArrow, (Binproduct f g). - abstract (split; [ apply (limArrowCommutes LC c (Binproduct f g) true) | apply (limArrowCommutes LC c (Binproduct f g) false) ]). - abstract (intros h; apply isapropdirprod; apply C). - abstract (now intros h [H1 H2]; apply limArrowUnique; intro x; induction x). Defined. End BinProducts_from_Lims. Section test. Context (C : category) (H : BinProducts C). Arguments BinProductObject [C] c d {_}. Local Notation "c 'x' d" := (BinProductObject c d )(at level 5). (* Check (λ c d : C, c x d). *) End test. (** ** Definition of binary product functor ([binproduct_functor]) *) Section binproduct_functor. Context {C : category} (PC : BinProducts C). Definition binproduct_functor_data : functor_data (category_binproduct C C) C. Proof. use tpair. - intros p. apply (BinProductObject _ (PC (pr1 p) (pr2 p))). - intros p q f. apply (BinProductOfArrows _ (PC (pr1 q) (pr2 q)) (PC (pr1 p) (pr2 p)) (pr1 f) (pr2 f)). Defined. Definition binproduct_functor : functor (category_binproduct C C) C. Proof. apply (tpair _ binproduct_functor_data). abstract (split; [ intro x; simpl; apply pathsinv0, BinProduct_endo_is_identity; [ now rewrite BinProductOfArrowsPr1, id_right | now rewrite BinProductOfArrowsPr2, id_right ] | now intros x y z f g; simpl; rewrite BinProductOfArrows_comp]). Defined. End binproduct_functor. (* Defines the product of two functors by: x -> (x,x) -> (F x,G x) -> F x * G x For a direct definition see FunctorsPointwiseBinProduct.v *) Definition BinProduct_of_functors_alt {C D : category} (HD : BinProducts D) (F G : functor C D) : functor C D := functor_composite (bindelta_functor C) (functor_composite (pair_functor F G) (binproduct_functor HD)). (** In the following section we show that if the morphism to components are zero, then the unique morphism factoring through the binproduct is the zero morphism. *) Section BinProduct_zeroarrow. Context (C : category) (Z : Zero C). Lemma BinProductArrowZero {x y z: C} {BP : BinProduct C x y} (f : z --> x) (g : z --> y) : f = ZeroArrow Z _ _ -> g = ZeroArrow Z _ _ -> BinProductArrow C BP f g = ZeroArrow Z _ _ . Proof. intros X X0. apply pathsinv0. use BinProductArrowUnique. rewrite X. apply ZeroArrow_comp_left. rewrite X0. apply ZeroArrow_comp_left. Qed. End BinProduct_zeroarrow. (** ** Definition of a binary product structure on a functor category *) (** Goal: lift binary products from the target (pre)category to the functor (pre)category *) Section def_functor_pointwise_binprod. Context (C D : category) (HD : BinProducts D). Section BinProduct_of_functors. Context (F G : functor C D). Local Notation "c ⊗ d" := (BinProductObject _ (HD c d)). Definition BinProduct_of_functors_ob (c : C) : D := F c ⊗ G c. Definition BinProduct_of_functors_mor (c c' : C) (f : c --> c') : BinProduct_of_functors_ob c --> BinProduct_of_functors_ob c' := BinProductOfArrows _ _ _ (#F f) (#G f). Definition BinProduct_of_functors_data : functor_data C D. Proof. exists BinProduct_of_functors_ob. exact BinProduct_of_functors_mor. Defined. Lemma is_functor_BinProduct_of_functors_data : is_functor BinProduct_of_functors_data. Proof. split; simpl; intros. - red; intros; simpl in *. apply pathsinv0. unfold BinProduct_of_functors_mor. apply BinProduct_endo_is_identity. + rewrite BinProductOfArrowsPr1. rewrite functor_id. apply id_right. + rewrite BinProductOfArrowsPr2. rewrite functor_id. apply id_right. - red; intros; simpl in *. unfold BinProduct_of_functors_mor. do 2 rewrite functor_comp. apply pathsinv0. apply BinProductOfArrows_comp. Qed. Definition BinProduct_of_functors : functor C D := tpair _ _ is_functor_BinProduct_of_functors_data. Lemma BinProduct_of_functors_alt_eq_BinProduct_of_functors : BinProduct_of_functors_alt HD F G = BinProduct_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Definition binproduct_nat_trans_pr1_data : ∏ c, BinProduct_of_functors c --> F c := λ c : C, BinProductPr1 _ (HD (F c) (G c)). Lemma is_nat_trans_binproduct_nat_trans_pr1_data : is_nat_trans _ _ binproduct_nat_trans_pr1_data. Proof. red. intros c c' f. unfold binproduct_nat_trans_pr1_data. unfold BinProduct_of_functors. simpl. unfold BinProduct_of_functors_mor. apply BinProductOfArrowsPr1. Qed. Definition binproduct_nat_trans_pr1 : nat_trans _ _ := tpair _ _ is_nat_trans_binproduct_nat_trans_pr1_data. Definition binproduct_nat_trans_pr2_data : ∏ c, BinProduct_of_functors c --> G c := λ c : C, BinProductPr2 _ (HD (F c) (G c)). Lemma is_nat_trans_binproduct_nat_trans_pr2_data : is_nat_trans _ _ binproduct_nat_trans_pr2_data. Proof. red. intros c c' f. unfold binproduct_nat_trans_pr2_data. unfold BinProduct_of_functors. simpl. unfold BinProduct_of_functors_mor. apply BinProductOfArrowsPr2. Qed. Definition binproduct_nat_trans_pr2 : nat_trans _ _ := tpair _ _ is_nat_trans_binproduct_nat_trans_pr2_data. Section vertex. (** The product morphism of a diagram with vertex [A] *) Context (A : functor C D) (f : A ⟹ F) (g : A ⟹ G). Definition binproduct_nat_trans_data : ∏ c, A c --> BinProduct_of_functors c. Proof. intro c. apply BinProductArrow. - exact (f c). - exact (g c). Defined. Lemma is_nat_trans_binproduct_nat_trans_data : is_nat_trans _ _ binproduct_nat_trans_data. Proof. intros a b k. simpl. unfold BinProduct_of_functors_mor. unfold binproduct_nat_trans_data. set (XX:=postcompWithBinProductArrow). set (X1 := XX D _ _ (HD (F b) (G b))). set (X2 := X1 _ _ (HD (F a) (G a))). rewrite X2. clear X2 X1 XX. set (XX:=precompWithBinProductArrow). set (X1 := XX D _ _ (HD (F b) (G b))). rewrite X1. rewrite (nat_trans_ax f). rewrite (nat_trans_ax g). apply idpath. Qed. Definition binproduct_nat_trans : nat_trans _ _ := tpair _ _ is_nat_trans_binproduct_nat_trans_data. Lemma binproduct_nat_trans_Pr1Commutes : nat_trans_comp _ _ _ binproduct_nat_trans binproduct_nat_trans_pr1 = f. Proof. apply nat_trans_eq. - apply D. - intro c; simpl. apply BinProductPr1Commutes. Qed. Lemma binproduct_nat_trans_Pr2Commutes : nat_trans_comp _ _ _ binproduct_nat_trans binproduct_nat_trans_pr2 = g. Proof. apply nat_trans_eq. - apply D. - intro c; simpl. apply BinProductPr2Commutes. Qed. End vertex. Lemma binproduct_nat_trans_univ_prop (A : [C, D]) (f : A --> (F:[C,D])) (g : A --> (G:[C,D])) : ∏ t : ∑ fg : A --> (BinProduct_of_functors:[C,D]), fg · (binproduct_nat_trans_pr1 : (BinProduct_of_functors:[C,D]) --> F) = f × fg · (binproduct_nat_trans_pr2 : (BinProduct_of_functors:[C,D]) --> G) = g, t = tpair (λ fg : A --> (BinProduct_of_functors:[C,D]), fg · (binproduct_nat_trans_pr1 : (BinProduct_of_functors:[C,D]) --> F) = f × fg · (binproduct_nat_trans_pr2 : (BinProduct_of_functors:[C,D]) --> G) = g) (binproduct_nat_trans A f g) (make_dirprod (binproduct_nat_trans_Pr1Commutes A f g) (binproduct_nat_trans_Pr2Commutes A f g)). Proof. intro t. simpl in *. destruct t as [t1 [ta tb]]. simpl in *. apply subtypePath. - intro. simpl. apply isapropdirprod; apply isaset_nat_trans; apply D. - simpl. apply nat_trans_eq. + apply D. + intro c. unfold binproduct_nat_trans. simpl. unfold binproduct_nat_trans_data. apply BinProductArrowUnique. * apply (nat_trans_eq_pointwise ta). * apply (nat_trans_eq_pointwise tb). Qed. Definition functor_precat_binproduct_cone : BinProduct [C, D] F G. Proof. use make_BinProduct. - apply BinProduct_of_functors. - apply binproduct_nat_trans_pr1. - apply binproduct_nat_trans_pr2. - use make_isBinProduct. + intros A f g. exists (tpair _ (binproduct_nat_trans A f g) (make_dirprod (binproduct_nat_trans_Pr1Commutes _ _ _ ) (binproduct_nat_trans_Pr2Commutes _ _ _ ))). apply binproduct_nat_trans_univ_prop. Defined. End BinProduct_of_functors. Definition BinProducts_functor_precat : BinProducts [C, D]. Proof. intros F G. apply functor_precat_binproduct_cone. Defined. End def_functor_pointwise_binprod. Section BinProduct_of_functors_commutative. Context (C D : category) (BD : BinProducts D) (F G : functor C D). Definition BinProduct_of_functors_commutes_data : nat_trans_data (BinProduct_of_functors C D BD F G) (BinProduct_of_functors C D BD G F). Proof. intro c. use BinProductArrow. - apply BinProductPr2. - apply BinProductPr1. Defined. Definition BinProduct_of_functors_commutes_invdata : nat_trans_data (BinProduct_of_functors C D BD G F) (BinProduct_of_functors C D BD F G). Proof. intro c. use BinProductArrow. - apply BinProductPr2. - apply BinProductPr1. Defined. Lemma BinProduct_of_functors_commutes_is_inverse (c: C) : is_inverse_in_precat (BinProduct_of_functors_commutes_data c) (BinProduct_of_functors_commutes_invdata c). Proof. split. - apply BinProductArrowsEq. + rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr1Commutes. } etrans. { apply BinProductPr2Commutes. } apply pathsinv0, id_left. + rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr2Commutes. } etrans. { apply BinProductPr1Commutes. } apply pathsinv0, id_left. - apply BinProductArrowsEq. + rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr1Commutes. } etrans. { apply BinProductPr2Commutes. } apply pathsinv0, id_left. + rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr2Commutes. } etrans. { apply BinProductPr1Commutes. } apply pathsinv0, id_left. Qed. Lemma BinProduct_of_functors_commutes_law : is_nat_trans _ _ BinProduct_of_functors_commutes_data. Proof. intros c c' f. cbn. unfold BinProduct_of_functors_mor. etrans. 2: { apply pathsinv0, postcompWithBinProductArrow. } apply BinProductArrowUnique. - rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr1Commutes. } etrans. { apply BinProductOfArrowsPr2. } apply idpath. - rewrite assoc'. etrans. { apply maponpaths. apply BinProductPr2Commutes. } etrans. { apply BinProductOfArrowsPr1. } apply idpath. Qed. Definition BinProduct_of_functors_commutes : nat_z_iso (BinProduct_of_functors C D BD F G) (BinProduct_of_functors C D BD G F). Proof. use make_nat_z_iso. - use make_nat_trans. + exact BinProduct_of_functors_commutes_data. + exact BinProduct_of_functors_commutes_law. - intro c. use make_is_z_isomorphism. { apply BinProduct_of_functors_commutes_invdata. } apply BinProduct_of_functors_commutes_is_inverse. Defined. End BinProduct_of_functors_commutative. Section PairNatTrans. Context {C₁ C₂ C₃ : category} {F : C₁ ⟶ C₂} {G₁ G₂ G₃ : C₂ ⟶ C₃} (H : BinProducts C₃) (η₁ : F ∙ G₁ ⟹ F ∙ G₂) (η₂ : F ∙ G₁ ⟹ F ∙ G₃). Local Definition pair_nat_trans_data : nat_trans_data (F ∙ G₁) (F ∙ BinProduct_of_functors C₂ C₃ H G₂ G₃). Proof. intros x. apply (BinProductArrow). - exact (η₁ x). - exact (η₂ x). Defined. Definition pair_nat_trans_is_nat_trans : is_nat_trans (F ∙ G₁) (F ∙ BinProduct_of_functors C₂ C₃ H G₂ G₃) pair_nat_trans_data. Proof. intros x y f ; cbn. refine (precompWithBinProductArrow _ _ _ _ _ @ _). pose (pr2 η₁ x y f) as p. pose (pr2 η₂ x y f) as q. cbn in p, q. refine (_ @ _). { apply maponpaths. exact q. } refine (_ @ _). { apply maponpaths_2. exact p. } unfold BinProduct_of_functors_mor, BinProductOfArrows, BinProductPr1, BinProductPr2. exact (!(postcompWithBinProductArrow _ _ _ _ _ _ _)). Qed. Definition pair_nat_trans : F ∙ G₁ ⟹ F ∙ (BinProduct_of_functors _ _ H G₂ G₃). Proof. use make_nat_trans. - exact pair_nat_trans_data. - exact pair_nat_trans_is_nat_trans. Defined. End PairNatTrans. (** ** Construction of BinProduct from an isomorphism to BinProduct. *) Section BinProduct_from_iso. Context (C : category). Local Lemma iso_to_isBinProduct_comm {x y z : C} (BP : BinProduct C x y) (i : iso z (BinProductObject C BP)) (w : C) (f : w --> x) (g : w --> y) : (BinProductArrow C BP f g · inv_from_iso i · (i · BinProductPr1 C BP) = f) × (BinProductArrow C BP f g · inv_from_iso i · (i · BinProductPr2 C BP) = g). Proof. split. - rewrite <- assoc. rewrite (assoc _ i). rewrite (iso_after_iso_inv i). rewrite id_left. apply BinProductPr1Commutes. - rewrite <- assoc. rewrite (assoc _ i). rewrite (iso_after_iso_inv i). rewrite id_left. apply BinProductPr2Commutes. Qed. Local Lemma iso_to_isBinProduct_unique {x y z : C} (BP : BinProduct C x y) (i : iso z (BinProductObject C BP)) (w : C) (f : C ⟦w, x⟧) (g : C ⟦w, y⟧) (y0 : C ⟦w, z⟧) (T : y0 · (i · BinProductPr1 C BP) = f × y0 · (i · BinProductPr2 C BP) = g) : y0 = BinProductArrow C BP f g · iso_inv_from_iso i. Proof. apply (post_comp_with_iso_is_inj _ _ i (pr2 i)). rewrite <- assoc. cbn. rewrite (iso_after_iso_inv i). rewrite id_right. apply BinProductArrowUnique. - rewrite <- assoc. apply (dirprod_pr1 T). - rewrite <- assoc. apply (dirprod_pr2 T). Qed. Lemma iso_to_isBinProduct {x y z : C} (BP : BinProduct C x y) (i : iso z (BinProductObject C BP)) : isBinProduct C _ _ z (i · (BinProductPr1 C BP)) (i · (BinProductPr2 C BP)). Proof. intros w f g. use unique_exists. (* Arrow *) - exact ((BinProductArrow C BP f g) · (iso_inv_from_iso i)). (* Commutativity *) - abstract (exact (iso_to_isBinProduct_comm BP i w f g)). (* Equality of equalities of morphisms. *) - abstract (intro; apply isapropdirprod; apply C). (* Uniqueness *) - abstract (intros y0 T; exact (iso_to_isBinProduct_unique BP i w f g y0 T)). Defined. Definition iso_to_BinProduct {x y z : C} (BP : BinProduct C x y) (i : iso z (BinProductObject C BP)) : BinProduct C x y := make_BinProduct C _ _ z (i · (BinProductPr1 C BP)) (i · (BinProductPr2 C BP)) (iso_to_isBinProduct BP i). End BinProduct_from_iso. (** ** Equivalent universal property: [(C --> A) × (C --> B) ≃ (C --> A × B)] Compare to [weqfuntoprodtoprod]. *) Section EquivalentDefinition. Context {C : category} {c d p : ob C} (p1 : p --> c) (p2 : p --> d). Definition postcomp_with_projections (a : ob C) (f : a --> p) : (a --> c) × (a --> d) := make_dirprod (f · p1) (f · p2). Definition isBinProduct' : UU := ∏ a : ob C, isweq (postcomp_with_projections a). Definition isBinProduct'_weq (is : isBinProduct') : ∏ a, (a --> p) ≃ (a --> c) × (a --> d) := λ a, make_weq (postcomp_with_projections a) (is a). Lemma isBinProduct'_to_isBinProduct : isBinProduct' -> isBinProduct _ _ _ p p1 p2. Proof. intros isBP' ? f g. apply (@iscontrweqf (hfiber (isBinProduct'_weq isBP' _) (make_dirprod f g))). - use weqfibtototal; intro; cbn. unfold postcomp_with_projections. apply pathsdirprodweq. - apply weqproperty. Defined. Lemma isBinProduct_to_isBinProduct' : isBinProduct _ _ _ p p1 p2 -> isBinProduct'. Proof. intros isBP ? fg. unfold hfiber, postcomp_with_projections. apply (@iscontrweqf (∑ u : C ⟦ a, p ⟧, u · p1 = pr1 fg × u · p2 = pr2 fg)). - use weqfibtototal; intro; cbn. apply invweq, pathsdirprodweq. - exact (isBP a (pr1 fg) (pr2 fg)). (* apply universal property *) Defined. (* TODO: prove that [isBinProduct'_to_isBinProduct] is an equivalence *) End EquivalentDefinition. (** Match non-implicit arguments of [isBinProduct] *) Arguments isBinProduct' _ _ _ _ _ : clear implicits. (** ** Terminal object as the unit (up to isomorphism) of binary products *) (** [T × x ≅ x]*) Lemma terminal_binprod_unit_l_z_aux {C : category} (T : Terminal C) (BC : BinProducts C) (x : C) : is_inverse_in_precat (BinProductPr2 C (BC T x)) (BinProductArrow C (BC T x) (TerminalArrow T x) (identity x)). Proof. unfold is_inverse_in_precat. split; [|apply BinProductPr2Commutes]. refine (precompWithBinProductArrow _ _ _ _ _ @ _). refine (_ @ !BinProductArrowEta _ _ _ _ _ (identity _)). apply maponpaths_12. - apply TerminalArrowEq. - exact (id_right _ @ !id_left _). Qed. Lemma terminal_binprod_unit_l_z {C : category} (T : Terminal C) (BC : BinProducts C) (x : C) : is_z_isomorphism (BinProductPr2 C (BC T x)). Proof. use make_is_z_isomorphism. - apply BinProductArrow. + (** The unique [x -> T] *) apply TerminalArrow. + apply identity. - apply terminal_binprod_unit_l_z_aux. Defined. (** [x × T ≅ x]*) Lemma terminal_binprod_unit_r_z_aux {C : category} (T : Terminal C) (BC : BinProducts C) (x : C) : is_inverse_in_precat (BinProductPr1 C (BC x T)) (BinProductArrow C (BC x T) (identity x) (TerminalArrow T x)). Proof. unfold is_inverse_in_precat. split; [|apply BinProductPr1Commutes]. refine (precompWithBinProductArrow _ _ _ _ _ @ _). refine (_ @ !BinProductArrowEta _ _ _ _ _ (identity _)). apply maponpaths_12. - exact (id_right _ @ !id_left _). - apply TerminalArrowEq. Qed. Lemma terminal_binprod_unit_r_z {C : category} (T : Terminal C) (BC : BinProducts C) (x : C) : is_z_isomorphism (BinProductPr1 C (BC x T)). Proof. use make_is_z_isomorphism. - apply BinProductArrow. + apply identity. + (** The unique [x -> T] *) apply TerminalArrow. - apply terminal_binprod_unit_r_z_aux. Defined. Section BinProduct_of_functors_with_terminal. Context (C D : category) (HD : BinProducts D) (TD : Terminal D) (F : functor C D). Definition terminal_BinProduct_of_functors_unit_l_data : nat_trans_data (BinProduct_of_functors C D HD (constant_functor C D TD) F) F. Proof. intro c. exact (BinProductPr2 D (HD TD (F c))). Defined. Lemma terminal_BinProduct_of_functors_unit_l_law : is_nat_trans _ _ terminal_BinProduct_of_functors_unit_l_data. Proof. intros c c' f. apply BinProductOfArrowsPr2. Qed. Definition terminal_BinProduct_of_functors_unit_l : nat_z_iso (BinProduct_of_functors _ _ HD (constant_functor _ _ TD) F) F. Proof. use make_nat_z_iso. - use make_nat_trans. + exact terminal_BinProduct_of_functors_unit_l_data. + exact terminal_BinProduct_of_functors_unit_l_law. - intro c. apply terminal_binprod_unit_l_z. Defined. Definition terminal_BinProduct_of_functors_unit_r_data : nat_trans_data (BinProduct_of_functors C D HD F (constant_functor C D TD)) F. Proof. intro c. exact (BinProductPr1 D (HD (F c) TD)). Defined. Lemma terminal_BinProduct_of_functors_unit_r_law : is_nat_trans _ _ terminal_BinProduct_of_functors_unit_r_data. Proof. intros c c' f. apply BinProductOfArrowsPr1. Qed. Definition terminal_BinProduct_of_functors_unit_r : nat_z_iso (BinProduct_of_functors _ _ HD F (constant_functor _ _ TD)) F. Proof. use make_nat_z_iso. - use make_nat_trans. + exact terminal_BinProduct_of_functors_unit_r_data. + exact terminal_BinProduct_of_functors_unit_r_law. - intro c. apply terminal_binprod_unit_r_z. Defined. End BinProduct_of_functors_with_terminal. (** In a univalent category, the type of binary products on a given diagram is a proposition *) Definition eq_BinProduct {C : category} {x y : C} (prod₁ prod₂ : BinProduct C x y) (q : BinProductObject _ prod₁ = BinProductObject _ prod₂) (e₁ : BinProductPr1 _ prod₁ = idtoiso q · BinProductPr1 _ prod₂) (e₂ : BinProductPr2 _ prod₁ = idtoiso q · BinProductPr2 _ prod₂) : prod₁ = prod₂. Proof. use subtypePath. { intro. repeat (use impred ; intro). use isapropiscontr. } use total2_paths_f. - exact q. - rewrite transportf_dirprod. rewrite <- !idtoiso_precompose. rewrite !idtoiso_inv. use pathsdirprod ; cbn ; use z_iso_inv_on_right. + exact e₁. + exact e₂. Qed. Section IsoBinProduct. Context {C : category} {x y : C} (p₁ p₂ : BinProduct C x y). Let f : BinProductObject C p₁ --> BinProductObject C p₂ := BinProductArrow _ _ (BinProductPr1 _ p₁) (BinProductPr2 _ p₁). Let g : BinProductObject C p₂ --> BinProductObject C p₁ := BinProductArrow _ _ (BinProductPr1 _ p₂) (BinProductPr2 _ p₂). Local Lemma iso_between_BinProduct_eq : is_inverse_in_precat f g. Proof. unfold f, g. split. - use BinProductArrowsEq. + rewrite assoc'. rewrite !BinProductPr1Commutes. rewrite id_left. apply idpath. + rewrite assoc'. rewrite !BinProductPr2Commutes. rewrite id_left. apply idpath. - use BinProductArrowsEq. + rewrite assoc'. rewrite !BinProductPr1Commutes. rewrite id_left. apply idpath. + rewrite assoc'. rewrite !BinProductPr2Commutes. rewrite id_left. apply idpath. Qed. Definition iso_between_BinProduct : z_iso (BinProductObject C p₁) (BinProductObject C p₂). Proof. use make_z_iso. - exact f. - exact g. - exact iso_between_BinProduct_eq. Defined. End IsoBinProduct. Definition isaprop_BinProduct {C : category} (HC : is_univalent C) (x y : C) : isaprop (BinProduct C x y). Proof. use invproofirrelevance. intros p₁ p₂. use eq_BinProduct. - refine (isotoid _ HC _). apply iso_between_BinProduct. - rewrite idtoiso_isotoid ; cbn. rewrite BinProductPr1Commutes. apply idpath. - rewrite idtoiso_isotoid ; cbn. rewrite BinProductPr2Commutes. apply idpath. Qed. (** Products when the projections are equal *) Definition isBinProduct_eq_arrow {C : category} {x y z : C} {π₁ π₁' : z --> x} (p₁ : π₁ = π₁') {π₂ π₂' : z --> y} (p₂ : π₂ = π₂') (H : isBinProduct C x y z π₁ π₂) : isBinProduct C x y z π₁' π₂'. Proof. pose (P := make_BinProduct _ _ _ _ _ _ H). use make_isBinProduct. intros w f g. use iscontraprop1. - abstract (induction p₁, p₂ ; apply isapropifcontr ; apply H). - simple refine (_ ,, _ ,, _). + exact (BinProductArrow _ P f g). + abstract (induction p₁ ; exact (BinProductPr1Commutes _ _ _ P _ f g)). + abstract (induction p₂ ; exact (BinProductPr2Commutes _ _ _ P _ f g)). Defined. (** Products of isos *) Section BinProductOfIsos. Context {C : category} {a b c d : C} (Pab : BinProduct C a b) (Pcd : BinProduct C c d) (f : z_iso a c) (g : z_iso b d). Let fg : BinProductObject _ Pab --> BinProductObject _ Pcd := BinProductOfArrows _ _ _ f g. Let fg_inv : BinProductObject _ Pcd --> BinProductObject _ Pab := BinProductOfArrows _ _ _ (inv_from_z_iso f) (inv_from_z_iso g). Definition binproduct_of_z_iso_inv : is_inverse_in_precat fg fg_inv. Proof. split ; use BinProductArrowsEq ; unfold fg, fg_inv. - rewrite !assoc'. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductOfArrowsPr1. rewrite !assoc'. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. - rewrite !assoc'. rewrite BinProductOfArrowsPr2. rewrite !assoc. rewrite BinProductOfArrowsPr2. rewrite !assoc'. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. - rewrite !assoc'. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductOfArrowsPr1. rewrite !assoc'. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. - rewrite !assoc'. rewrite BinProductOfArrowsPr2. rewrite !assoc. rewrite BinProductOfArrowsPr2. rewrite !assoc'. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. Qed. Definition binproduct_of_z_iso : z_iso (BinProductObject _ Pab) (BinProductObject _ Pcd). Proof. use make_z_iso. - exact fg. - exact fg_inv. - exact binproduct_of_z_iso_inv. Defined. End BinProductOfIsos. (* Definition of the "associative" z-isomorphism *) Section BinProduct_assoc_z_iso. Context {C : category} (P : BinProducts C) (a b c : C). Let Pbc := P b c. Let Pa_bc := P a (BinProductObject _ Pbc). Let Pab := P a b. Let Pab_c := P (BinProductObject _ Pab) c. Definition BinProduct_assoc_mor : C ⟦ BinProductObject C Pa_bc , BinProductObject C Pab_c ⟧. Proof. use BinProductArrow. + use BinProductOfArrows. - exact (identity a). - use BinProductPr1. + use (compose (b := BinProductObject C Pbc)). - use BinProductPr2. - use BinProductPr2. Defined. Definition BinProduct_assoc_invmor : C ⟦ BinProductObject C Pab_c , BinProductObject C Pa_bc ⟧. Proof. use BinProductArrow. + use (compose (b := BinProductObject C Pab)). - use BinProductPr1. - use BinProductPr1. + use BinProductOfArrows. - use BinProductPr2. - exact (identity c). Defined. Lemma BinProduct_assoc_is_inverse : is_inverse_in_precat BinProduct_assoc_mor BinProduct_assoc_invmor. Proof. use make_is_inverse_in_precat. - unfold BinProduct_assoc_mor, BinProduct_assoc_invmor. use BinProductArrowsEq. * now rewrite id_left, assoc', BinProductPr1Commutes, assoc, BinProductPr1Commutes, BinProductOfArrowsPr1, id_right. * now rewrite id_left, assoc', BinProductPr2Commutes, postcompWithBinProductArrow, id_right, BinProductOfArrowsPr2, <-precompWithBinProductArrow, <-(id_left (BinProductPr1 C Pbc)), <-(id_left (BinProductPr2 C Pbc)), <-BinProductArrowEta, id_right. - unfold BinProduct_assoc_mor, BinProduct_assoc_invmor. use BinProductArrowsEq. * now rewrite id_left, assoc', BinProductPr1Commutes, postcompWithBinProductArrow, id_right, BinProductOfArrowsPr1, <-precompWithBinProductArrow, <-(id_left (BinProductPr1 C Pab)), <-(id_left (BinProductPr2 C Pab)), <-BinProductArrowEta, id_right. * now rewrite id_left, assoc', BinProductPr2Commutes, assoc, BinProductPr2Commutes, BinProductOfArrowsPr2, id_right. Qed. Definition BinProduct_assoc_is_z_iso : is_z_isomorphism (BinProduct_assoc_mor). Proof. use make_is_z_isomorphism. + exact BinProduct_assoc_invmor. + exact BinProduct_assoc_is_inverse. Defined. Definition BinProduct_assoc : z_iso (BinProductObject C Pa_bc) (BinProductObject C Pab_c). Proof. use make_z_iso'. + exact BinProduct_assoc_mor. + exact BinProduct_assoc_is_z_iso. Defined. End BinProduct_assoc_z_iso. Section BinProduct_OfArrows_assoc. Context {C : category} (P : BinProducts C) {a a' b b' c c' : C} (f : C ⟦ a', a ⟧) (g : C ⟦ b', b ⟧) (h : C ⟦ c', c ⟧). Let Pbc := P b c. Let Pa_bc := P a (BinProductObject _ Pbc). Let Pab := P a b. Let Pab_c := P (BinProductObject _ Pab) c. Let Pbc' := P b' c'. Let Pa_bc' := P a' (BinProductObject _ Pbc'). Let Pab' := P a' b'. Let Pab_c' := P (BinProductObject _ Pab') c'. Lemma BinProduct_OfArrows_assoc : BinProductOfArrows _ Pa_bc Pa_bc' f (BinProductOfArrows _ Pbc Pbc' g h) · (BinProduct_assoc P a b c) = (BinProduct_assoc P a' b' c') · BinProductOfArrows _ Pab_c Pab_c' (BinProductOfArrows _ Pab Pab' f g) h. Proof. unfold BinProduct_assoc, BinProduct_assoc_mor. simpl. use BinProductArrowsEq. + rewrite !assoc', (BinProductPr1Commutes), BinProductOfArrowsPr1, assoc, BinProductPr1Commutes. use BinProductArrowsEq. - now rewrite !assoc', !BinProductOfArrowsPr1, !assoc, !BinProductOfArrowsPr1, id_right, !assoc', id_left. - now rewrite !assoc', !BinProductOfArrowsPr2, !assoc, !BinProductOfArrowsPr2, !assoc', !BinProductOfArrowsPr1. + now rewrite !assoc', !BinProductOfArrowsPr2, !BinProductPr2Commutes, !assoc, !BinProductOfArrowsPr2, !BinProductPr2Commutes, !assoc', !BinProductOfArrowsPr2. Qed. End BinProduct_OfArrows_assoc. Section diagonalMap. Context {C:category} (P : BinProducts C) (B:C). Definition diagonalMap' : C ⟦ B, BinProductObject C (P B B) ⟧. Proof. use BinProductArrow. - exact (identity B). - exact (identity B). Defined. Lemma diagonalMap_isMonic : isMonic (diagonalMap'). Proof. use make_isMonic. intros x g h p. assert (p' := (maponpaths (λ f, compose f (BinProductPr1 C (P B B))) p)). unfold diagonalMap' in p'. rewrite !assoc', BinProductPr1Commutes , !id_right in p'. exact p'. Qed. Definition diagonalMap : Monic _ B (BinProductObject C (P B B)). Proof. use make_Monic. + exact diagonalMap'. + exact diagonalMap_isMonic. Defined. End diagonalMap. Section ProductFunctions. Context {C : category} (prodC : BinProducts C). Definition prod_swap (x y : C) : prodC x y --> prodC y x. Proof. use BinProductArrow. - apply BinProductPr2. - apply BinProductPr1. Defined. Definition prod_lwhisker {x₁ x₂ : C} (f : x₁ --> x₂) (y : C) : prodC x₁ y --> prodC x₂ y. Proof. use BinProductOfArrows. - exact f. - exact (identity _). Defined. Definition prod_rwhisker (x : C) {y₁ y₂ : C} (g : y₁ --> y₂) : prodC x y₁ --> prodC x y₂. Proof. use BinProductOfArrows. - exact (identity _). - exact g. Defined. Proposition prod_lwhisker_rwhisker {x₁ x₂ : C} {y₁ y₂ : C} (f : x₁ --> x₂) (g : y₁ --> y₂) : prod_lwhisker f _ · prod_rwhisker _ g = BinProductOfArrows _ _ _ f g. Proof. unfold prod_lwhisker, prod_rwhisker. rewrite BinProductOfArrows_comp. rewrite id_left, id_right. apply idpath. Qed. Proposition prod_swap_swap (x y : C) : prod_swap x y · prod_swap y x = identity _. Proof. use BinProductArrowsEq. - unfold prod_swap. rewrite !assoc'. rewrite !id_left. rewrite BinProductPr1Commutes. rewrite BinProductPr2Commutes. apply idpath. - unfold prod_swap. rewrite !assoc'. rewrite !id_left. rewrite BinProductPr2Commutes. rewrite BinProductPr1Commutes. apply idpath. Qed. Proposition BinProductOfArrows_swap {x₁ x₂ : C} {y₁ y₂ : C} (f : x₁ --> x₂) (g : y₁ --> y₂) : BinProductOfArrows C (prodC _ _) (prodC _ _) f g · prod_swap x₂ y₂ = prod_swap x₁ y₁ · BinProductOfArrows C _ _ g f. Proof. use BinProductArrowsEq. - unfold prod_swap. rewrite !assoc'. rewrite BinProductPr1Commutes. rewrite BinProductOfArrowsPr2. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductPr1Commutes. apply idpath. - unfold prod_swap. rewrite !assoc'. rewrite BinProductPr2Commutes. rewrite BinProductOfArrowsPr2. rewrite BinProductOfArrowsPr1. rewrite !assoc. rewrite BinProductPr2Commutes. apply idpath. Qed. End ProductFunctions. (** Binary products are closed under iso *) Definition isBinProduct_z_iso {C : category} {x y a₁ a₂ : C} {p₁ : a₁ --> x} {q₁ : a₁ --> y} {p₂ : a₂ --> x} {q₂ : a₂ --> y} (H : isBinProduct C x y a₁ p₁ q₁) (f : z_iso a₂ a₁) (r₁ : p₂ = f · p₁) (r₂ : q₂ = f · q₁) : isBinProduct C x y a₂ p₂ q₂. Proof. intros w h₁ h₂. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ; use (cancel_z_iso _ _ f) ; use (BinProductArrowsEq _ _ _ (make_BinProduct _ _ _ _ _ _ H)) ; [ cbn ; rewrite !assoc' ; rewrite <- !r₁ ; exact (pr12 φ₁ @ !(pr12 φ₂)) | cbn ; rewrite !assoc' ; rewrite <- !r₂ ; exact (pr22 φ₁ @ !(pr22 φ₂)) ]). - simple refine (_ ,, _ ,, _). + exact (BinProductArrow _ (make_BinProduct _ _ _ _ _ _ H) h₁ h₂ · inv_from_z_iso f). + abstract (rewrite r₁ ; rewrite !assoc' ; rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)) ; rewrite z_iso_after_z_iso_inv ; rewrite id_left ; apply BinProductPr1Commutes). + abstract (cbn ; rewrite r₂ ; rewrite !assoc' ; rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)) ; rewrite z_iso_after_z_iso_inv ; rewrite id_left ; apply (BinProductPr2Commutes _ _ _ (make_BinProduct _ _ _ _ _ _ H))). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/cats/000077500000000000000000000000001451125700300220575ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/limits/cats/README.md000066400000000000000000000007471451125700300233460ustar00rootroot00000000000000cats =========== This directory contains a development of limits on the basis of descriptions of diagrams by functors (as in MacLane's CWM). **Warning**: this file is mostly here for historical purposes. For a more developed definition of (co)limits see [limits/graphs](https://github.com/UniMath/UniMath/tree/master/UniMath/CategoryTheory/limits/graphs). ## Contents * *limits.v* * cones given by a functor and a tip * pointwise constructions of limits in functor precategories UniMath-20231010/UniMath/CategoryTheory/limits/cats/limits.v000066400000000000000000000336331451125700300235570ustar00rootroot00000000000000(**************************************************** Benedikt Ahrens and Anders Mörtberg, March 2016 *****************************************************) (** ************************************************* Contents : Definition of limits *****************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Section lim_def. Definition cone {J C : precategory} (F : functor J C) (c : C) : UU := ∑ (f : ∏ (v : J), C⟦c,F v⟧), ∏ (u v : J) (e : J⟦u,v⟧), f u · # F e = f v. Definition make_cone {J C : precategory} {F : functor J C} {c : C} (f : ∏ v, C⟦c, F v⟧) (Hf : ∏ u v (e : J⟦u,v⟧) , f u · # F e = f v) : cone F c := tpair _ f Hf. Definition coneOut {J C : precategory} {F : functor J C} {c : C} (cc : cone F c) : ∏ v, C⟦c, F v⟧ := pr1 cc. Lemma coneOutCommutes {J C : precategory} {F : functor J C} {c : C} (cc : cone F c) : ∏ u v (e : J⟦u,v⟧), coneOut cc u · # F e = coneOut cc v. Proof. apply (pr2 cc). Qed. Definition isLimCone {J C : precategory} (F : functor J C) (l : C) (cc0 : cone F l) : UU := ∏ (c : C) (cc : cone F c), iscontr (∑ x : C⟦c,l⟧, ∏ v, x · coneOut cc0 v = coneOut cc v). Definition LimCone {J C : precategory} (F : functor J C) : UU := ∑ (A : (∑ l, cone F l)), isLimCone F (pr1 A) (pr2 A). Definition make_LimCone {J C : precategory} (F : functor J C) (c : C) (cc : cone F c) (isCC : isLimCone F c cc) : LimCone F := tpair _ (tpair _ c cc) isCC. (* lim is the tip of the lim cone *) Definition lim {J C : precategory} {F : functor J C} (CC : LimCone F) : C := pr1 (pr1 CC). Definition limCone {J C : precategory} {F : functor J C} (CC : LimCone F) : cone F (lim CC) := pr2 (pr1 CC). Definition limOut {J C : precategory} {F : functor J C} (CC : LimCone F) : ∏ v, C⟦lim CC,F v⟧ := coneOut (limCone CC). Lemma limOutCommutes {J C : precategory} {F : functor J C} (CC : LimCone F) : ∏ u v (e : J⟦u,v⟧), limOut CC u · # F e = limOut CC v. Proof. exact (coneOutCommutes (limCone CC)). Qed. Lemma limUnivProp {J C : precategory} {F : functor J C} (CC : LimCone F) : ∏ (c : C) (cc : cone F c), iscontr (∑ x : C⟦c, lim CC⟧, ∏ v, x · limOut CC v = coneOut cc v). Proof. exact (pr2 CC). Qed. Lemma isaprop_isLimCone {J C : precategory} (F : functor J C) (c0 : C) (cc0 : cone F c0) : isaprop (isLimCone F c0 cc0). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Definition isLimCone_LimCone {J C : precategory} {F : functor J C} (CC : LimCone F) : isLimCone F (lim CC) (tpair _ (limOut CC) (limOutCommutes CC)) := pr2 CC. Definition limArrow {J C : precategory} {F : functor J C} (CC : LimCone F) (c : C) (cc : cone F c) : C⟦c, lim CC⟧ := pr1 (pr1 (isLimCone_LimCone CC c cc)). Lemma limArrowCommutes {J C : precategory} {F : functor J C} (CC : LimCone F) (c : C) (cc : cone F c) u : limArrow CC c cc · limOut CC u = coneOut cc u. Proof. exact ((pr2 (pr1 (isLimCone_LimCone CC _ cc))) u). Qed. Lemma limArrowUnique {J C : precategory} {F : functor J C} (CC : LimCone F) (c : C) (cc : cone F c) (k : C⟦c, lim CC⟧) (Hk : ∏ u, k · limOut CC u = coneOut cc u) : k = limArrow CC c cc. Proof. now apply path_to_ctr, Hk. Qed. Lemma Cone_precompose {J C : precategory} {F : functor J C} {c : C} (cc : cone F c) (x : C) (f : C⟦x,c⟧) : ∏ u v (e : J⟦u,v⟧), (f · coneOut cc u) · # F e = f · coneOut cc v. Proof. now intros u v e; rewrite <- assoc, coneOutCommutes. Qed. Lemma limArrowEta {J C : precategory} {F : functor J C} (CC : LimCone F) (c : C) (f : C⟦c, lim CC⟧) : f = limArrow CC c (tpair _ (λ u, f · limOut CC u) (Cone_precompose (limCone CC) c f)). Proof. now apply limArrowUnique. Qed. Definition limOfArrows {J C : precategory} {F1 F2 : functor J C} (CC1 : LimCone F1) (CC2 : LimCone F2) (f : ∏ u, C⟦F1 u,F2 u⟧) (fNat : ∏ u v (e : J⟦u,v⟧), f u · # F2 e = # F1 e · f v) : C⟦lim CC1 , lim CC2⟧. Proof. apply limArrow; use make_cone. - now intro u; apply (limOut CC1 u · f u). - abstract (intros u v e; simpl; now rewrite <- assoc, fNat, assoc, limOutCommutes). Defined. Lemma limOfArrowsOut {J C : precategory} {F1 F2 : functor J C} (CC1 : LimCone F1) (CC2 : LimCone F2) (f : ∏ u, C⟦F1 u,F2 u⟧) (fNat : ∏ u v (e : J⟦u,v⟧), f u · # F2 e = # F1 e · f v) : ∏ u, limOfArrows CC1 CC2 f fNat · limOut CC2 u = limOut CC1 u · f u. Proof. now unfold limOfArrows; intro u; rewrite limArrowCommutes. Qed. Lemma postCompWithLimOfArrows_subproof {J C : precategory} {F1 F2 : functor J C} (CC1 : LimCone F1) (CC2 : LimCone F2) (f : ∏ u, C⟦F1 u,F2 u⟧) (fNat : ∏ u v (e : J⟦u,v⟧), f u · # F2 e = # F1 e · f v) (x : C) (cc : cone F1 x) u v (e : J⟦u,v⟧) : (coneOut cc u · f u) · # F2 e = coneOut cc v · f v. Proof. now rewrite <- (coneOutCommutes cc u v e), <- assoc, fNat, assoc. Defined. Lemma postcompWithLimOfArrows {J C : precategory} {F1 F2 : functor J C} (CC1 : LimCone F1) (CC2 : LimCone F2) (f : ∏ u, C⟦F1 u,F2 u⟧) (fNat : ∏ u v (e : J⟦u,v⟧), f u · # F2 e = # F1 e · f v) (x : C) (cc : cone F1 x) : limArrow CC1 x cc · limOfArrows CC1 CC2 f fNat = limArrow CC2 x (make_cone (λ u, coneOut cc u · f u) (postCompWithLimOfArrows_subproof CC1 CC2 f fNat x cc)). Proof. apply limArrowUnique; intro u. now rewrite <- assoc, limOfArrowsOut, assoc, limArrowCommutes. Qed. Lemma postcompWithLimArrow {J C : precategory} {F : functor J C} (CC : LimCone F) (c : C) (cc : cone F c) (d : C) (k : C⟦d,c⟧) : k · limArrow CC c cc = limArrow CC d (make_cone (λ u, k · coneOut cc u) (Cone_precompose cc d k)). Proof. apply limArrowUnique. now intro u; rewrite <- assoc, limArrowCommutes. Qed. Lemma lim_endo_is_identity {J C : precategory} {F : functor J C} (CC : LimCone F) (k : lim CC --> lim CC) (H : ∏ u, k · limOut CC u = limOut CC u) : identity _ = k. Proof. use (uniqueExists (limUnivProp CC _ _)). - now apply (limCone CC). - now intros v; apply id_left. - simpl; now apply H. Qed. (* Definition Cocone_by_postcompose {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d. Proof. now exists (λ u, coconeIn cc u · k); apply Cocone_postcompose. Defined. Lemma isColim_weq_subproof1 {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : ∏ u, coconeIn cc u · k = pr1 (Cocone_by_postcompose D c cc d k) u. Proof. now intro u. Qed. Lemma isColim_weq_subproof2 (g : graph) (D : diagram g C) (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d)) (d : C) (cd : cocone D d) (u : vertex g) : coconeIn cc u · invmap (make_weq _ (H d)) cd = coconeIn cd u. Proof. rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u). set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p. now rewrite p. Qed. Lemma isColim_weq {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) : isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d). Proof. split. - intros H d. refine (isweq_iso _ _ _ _). + intros k. exact (colimArrow (make_ColimCocone D c cc H) _ k). + abstract (intro k; simpl; now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))). + abstract (simpl; intro k; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | destruct k as [k Hk]; simpl; apply funextsec; intro u; now apply (colimArrowCommutes (make_ColimCocone D c cc H))]). - intros H d cd. refine (tpair _ _ _). + exists (invmap (make_weq _ (H d)) cd). abstract (intro u; now apply isColim_weq_subproof2). + abstract (intro t; apply total2_paths_second_isaprop; [ now apply impred; intro; apply hsC | destruct t as [t Ht]; simpl; apply (invmaponpathsweq (make_weq _ (H d))); simpl; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht; now apply isColim_weq_subproof2]]). Defined. *) Definition z_iso_from_lim_to_lim {J C : precategory} {F : functor J C} (CC CC' : LimCone F) : z_iso (lim CC) (lim CC'). Proof. use make_z_iso. - apply limArrow, limCone. - apply limArrow, limCone. - abstract (now split; apply pathsinv0, lim_endo_is_identity; intro u; rewrite <- assoc, limArrowCommutes; eapply pathscomp0; try apply limArrowCommutes). Defined. End lim_def. Section Lims. Definition Lims (C : precategory) : UU := ∏ (J : precategory) (F : functor J C), LimCone F. Definition hasLims : UU := ∏ (J C : precategory) (F : functor J C), ishinh (LimCone F). Definition Lims_of_shape (J C : precategory) : UU := ∏ (F : functor J C), LimCone F. Section Universal_Unique. Context (C : univalent_category). Let H : is_univalent C := pr2 C. Lemma isaprop_Lims: isaprop (Lims C). Proof. apply impred; intro J; apply impred; intro F. apply invproofirrelevance; intros Hccx Hccy. apply subtypePath. - intro; apply isaprop_isLimCone. - apply (total2_paths_f (isotoid _ H (z_iso_from_lim_to_lim Hccx Hccy))). set (B c := ∏ v, C⟦c,F v⟧). set (C' (c : C) f := ∏ u v (e : J⟦u,v⟧), @compose _ c _ _ (f u) (# F e) = f v). rewrite (@transportf_total2 _ B C'). apply subtypePath. + intro; repeat (apply impred; intro). apply (homset_property C). + abstract (simpl; eapply pathscomp0; [apply transportf_isotoid_dep'|]; apply funextsec; intro v; rewrite inv_isotoid, idtoiso_isotoid; cbn; apply limArrowCommutes). Qed. End Universal_Unique. End Lims. Section LimFunctor. Variable A C : precategory. Variable hsC : has_homsets C. Variable (J : precategory). Variable (D : functor J [A, C, hsC]). Definition functor_pointwise (a : A) : functor J C. Proof. use tpair. - apply (tpair _ (λ v, pr1 (D v) a)). intros u v e; simpl; apply (pr1 (# D e) a). - abstract (use tpair; [ intro x; simpl; apply (toforallpaths _ _ _ (maponpaths pr1 (functor_id D x)) a) | intros x y z f g; simpl; apply (toforallpaths _ _ _ (maponpaths pr1 (functor_comp D f g)) a)]). Defined. Variable (HCg : ∏ (a : A), LimCone (functor_pointwise a)). Definition LimFunctor_ob (a : A) : C := lim (HCg a). Definition LimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) : C⟦LimFunctor_ob a,LimFunctor_ob a'⟧. Proof. use limOfArrows. - now intro u; apply (# (pr1 (D u)) f). - abstract (now intros u v e; simpl; apply (nat_trans_ax (# D e))). Defined. Definition LimFunctor_data : functor_data A C := tpair _ _ LimFunctor_mor. Lemma is_functor_LimFunctor_data : is_functor LimFunctor_data. Proof. split. - intro a; simpl. apply pathsinv0, lim_endo_is_identity; intro u. unfold LimFunctor_mor; rewrite limOfArrowsOut. assert (H : # (pr1 (D u)) (identity a) = identity (pr1 (D u) a)). apply (functor_id (D u) a). now rewrite H, id_right. - intros a b c fab fbc; simpl; unfold LimFunctor_mor. apply pathsinv0. eapply pathscomp0; [now apply postcompWithLimOfArrows|]. apply pathsinv0, limArrowUnique; intro u. rewrite limOfArrowsOut, (functor_comp (D u)); simpl. now rewrite <- assoc. Qed. Definition LimFunctor : functor A C := tpair _ _ is_functor_LimFunctor_data. Definition lim_nat_trans_in_data v : [A, C, hsC] ⟦ LimFunctor, D v ⟧. Proof. use tpair. - intro a; exact (limOut (HCg a) v). - abstract (intros a a' f; apply (limOfArrowsOut (HCg a) (HCg a'))). Defined. Definition cone_pointwise (F : [A,C,hsC]) (cc : cone D F) a : cone (functor_pointwise a) (pr1 F a). Proof. use make_cone. - now intro v; apply (pr1 (coneOut cc v) a). - abstract (intros u v e; now apply (nat_trans_eq_pointwise (coneOutCommutes cc u v e))). Defined. Lemma LimFunctor_unique (F : [A, C, hsC]) (cc : cone D F) : iscontr (∑ x : [A, C, hsC] ⟦ F, LimFunctor ⟧, ∏ v, x · lim_nat_trans_in_data v = coneOut cc v). Proof. use tpair. - use tpair. + apply (tpair _ (λ a, limArrow (HCg a) _ (cone_pointwise F cc a))). abstract (intros a a' f; simpl; apply pathsinv0; eapply pathscomp0; [ apply (postcompWithLimOfArrows (HCg a)) | apply pathsinv0; eapply pathscomp0; [ apply postcompWithLimArrow | apply limArrowUnique; intro u; eapply pathscomp0; [ now apply limArrowCommutes | now use nat_trans_ax]]]). + abstract (intro u; apply (nat_trans_eq hsC); simpl; intro a; now apply (limArrowCommutes (HCg a))). - abstract (intro t; destruct t as [t1 t2]; apply subtypePath; simpl; [ intro; apply impred; intro u; apply functor_category_has_homsets | apply (nat_trans_eq hsC); simpl; intro a; apply limArrowUnique; intro u; now apply (nat_trans_eq_pointwise (t2 u))]). Defined. Lemma LimFunctorCone : LimCone D. Proof. use make_LimCone. - exact LimFunctor. - use make_cone. + now apply lim_nat_trans_in_data. + abstract (now intros u v e; apply (nat_trans_eq hsC); intro a; apply (limOutCommutes (HCg a))). - now intros F cc; simpl; apply (LimFunctor_unique _ cc). Defined. End LimFunctor. Lemma LimsFunctorCategory (A C : precategory) (hsC : has_homsets C) (HC : Lims C) : Lims [A,C,hsC]. Proof. now intros g d; apply LimFunctorCone. Defined. Lemma LimsFunctorCategory_of_shape (J A C : precategory) (hsC : has_homsets C) (HC : Lims_of_shape J C) : Lims_of_shape J [A,C,hsC]. Proof. now intros d; apply LimFunctorCone. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/coequalizers.v000066400000000000000000000373461451125700300240370ustar00rootroot00000000000000(** Direct implementation of coequalizers together with: - Proof that the coequalizer arrow is epi ([CoequalizerArrowisEpi]) Written by Tomi Pannila *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.bincoproducts. Section def_coequalizers. Context {C : precategory}. (** Definition and construction of isCoequalizer. *) Definition isCoequalizer {x y z : C} (f g : x --> y) (e : y --> z) (H : f · e = g · e) : UU := ∏ (w : C) (h : y --> w) (H : f · h = g · h), ∃! φ : z --> w, e · φ = h. Definition make_isCoequalizer {y z w : C} (f g : y --> z) (e : z --> w) (H : f · e = g · e) : (∏ (w0 : C) (h : z --> w0) (H' : f · h = g · h), ∃! ψ : w --> w0, e · ψ = h) -> isCoequalizer f g e H. Proof. intros X. unfold isCoequalizer. exact X. Defined. Lemma isaprop_isCoequalizer {y z w : C} (f g : y --> z) (e : z --> w) (H : f · e = g · e) : isaprop (isCoequalizer f g e H). Proof. repeat (apply impred; intro). apply isapropiscontr. Defined. Lemma isCoequalizer_path {hs : has_homsets C} {x y z : C} {f g : x --> y} {e : y --> z} {H H' : f · e = g · e} (iC : isCoequalizer f g e H) : isCoequalizer f g e H'. Proof. use make_isCoequalizer. intros w0 h H'0. use unique_exists. - exact (pr1 (pr1 (iC w0 h H'0))). - exact (pr2 (pr1 (iC w0 h H'0))). - intros y0. apply hs. - intros y0 X. exact (base_paths _ _ (pr2 (iC w0 h H'0) (tpair _ y0 X))). Defined. (** Proves that the arrow from the coequalizer object with the right commutativity property is unique. *) Lemma isCoequalizerOutUnique {y z w: C} (f g : y --> z) (e : z --> w) (H : f · e = g · e) (E : isCoequalizer f g e H) (w0 : C) (h : z --> w0) (H' : f · h = g · h) (φ : w --> w0) (H'' : e · φ = h) : φ = (pr1 (pr1 (E w0 h H'))). Proof. set (T := tpair (fun ψ : w --> w0 => e · ψ = h) φ H''). set (T' := pr2 (E w0 h H') T). apply (base_paths _ _ T'). Defined. (** Definition and construction of coequalizers. *) Definition Coequalizer {y z : C} (f g : y --> z) : UU := ∑ e : (∑ w : C, z --> w), (∑ H : f · (pr2 e) = g · (pr2 e), isCoequalizer f g (pr2 e) H). Definition make_Coequalizer {y z w : C} (f g : y --> z) (e : z --> w) (H : f · e = g · e) (isE : isCoequalizer f g e H) : Coequalizer f g. Proof. use tpair. - use tpair. + apply w. + apply e. - simpl. exact (tpair _ H isE). Defined. (** Coequalizers in precategories. *) Definition Coequalizers := ∏ (y z : C) (f g : y --> z), Coequalizer f g. Definition hasCoequalizers := ∏ (y z : C) (f g : y --> z), ishinh (Coequalizer f g). (** Returns the coequalizer object. *) Definition CoequalizerObject {y z : C} {f g : y --> z} (E : Coequalizer f g) : C := pr1 (pr1 E). Coercion CoequalizerObject : Coequalizer >-> ob. (** Returns the coequalizer arrow. *) Definition CoequalizerArrow {y z : C} {f g : y --> z} (E : Coequalizer f g) : C⟦z, E⟧ := pr2 (pr1 E). (** The equality on morphisms that coequalizers must satisfy. *) Definition CoequalizerEqAr {y z : C} {f g : y --> z} (E : Coequalizer f g) : f · CoequalizerArrow E = g · CoequalizerArrow E := pr1 (pr2 E). (** Returns the property isCoequalizer from Coequalizer. *) Definition isCoequalizer_Coequalizer {y z : C} {f g : y --> z} (E : Coequalizer f g) : isCoequalizer f g (CoequalizerArrow E) (CoequalizerEqAr E) := pr2 (pr2 E). (** Every morphism which satisfy the coequalizer equality on morphism factors uniquely through the CoequalizerArrow. *) Definition CoequalizerOut {y z : C} {f g : y --> z} (E : Coequalizer f g) (w : C) (h : z --> w) (H : f · h = g · h) : C⟦E, w⟧ := pr1 (pr1 (isCoequalizer_Coequalizer E w h H)). Lemma CoequalizerCommutes {y z : C} {f g : y --> z} (E : Coequalizer f g) (w : C) (h : z --> w) (H : f · h = g · h) : (CoequalizerArrow E) · (CoequalizerOut E w h H) = h. Proof. exact (pr2 (pr1 ((isCoequalizer_Coequalizer E) w h H))). Defined. Lemma isCoequalizerOutsEq {y z w: C} {f g : y --> z} {e : z --> w} {H : f · e = g · e} (E : isCoequalizer f g e H) {w0 : C} (φ1 φ2: w --> w0) (H' : e · φ1 = e · φ2) : φ1 = φ2. Proof. assert (H'1 : f · e · φ1 = g · e · φ1). rewrite H. apply idpath. set (E' := make_Coequalizer _ _ _ _ E). repeat rewrite <- assoc in H'1. set (E'ar := CoequalizerOut E' w0 (e · φ1) H'1). intermediate_path E'ar. apply isCoequalizerOutUnique. apply idpath. apply pathsinv0. apply isCoequalizerOutUnique. apply pathsinv0. apply H'. Defined. Lemma CoequalizerOutsEq {y z: C} {f g : y --> z} (E : Coequalizer f g) {w : C} (φ1 φ2: C⟦E, w⟧) (H' : (CoequalizerArrow E) · φ1 = (CoequalizerArrow E) · φ2) : φ1 = φ2. Proof. apply (isCoequalizerOutsEq (isCoequalizer_Coequalizer E) _ _ H'). Defined. Lemma CoequalizerOutComp {y z : C} {f g : y --> z} (CE : Coequalizer f g) {w w' : C} (h1 : z --> w) (h2 : w --> w') (H1 : f · (h1 · h2) = g · (h1 · h2)) (H2 : f · h1 = g · h1) : CoequalizerOut CE w' (h1 · h2) H1 = CoequalizerOut CE w h1 H2 · h2. Proof. use CoequalizerOutsEq. rewrite CoequalizerCommutes. rewrite assoc. rewrite CoequalizerCommutes. apply idpath. Qed. (** Morphisms between coequalizer objects with the right commutativity equalities. *) Definition identity_is_CoequalizerOut {y z : C} {f g : y --> z} (E : Coequalizer f g) : ∑ φ : C⟦E, E⟧, (CoequalizerArrow E) · φ = (CoequalizerArrow E). Proof. exists (identity E). apply id_right. Defined. Lemma CoequalizerEndo_is_identity {y z : C} {f g : y --> z} {E : Coequalizer f g} (φ : C⟦E, E⟧) (H : (CoequalizerArrow E) · φ = CoequalizerArrow E) : identity E = φ. Proof. set (H1 := tpair ((fun φ' : C⟦E, E⟧ => _ · φ' = _)) φ H). assert (H2 : identity_is_CoequalizerOut E = H1). - apply proofirrelevancecontr. apply (isCoequalizer_Coequalizer E). apply CoequalizerEqAr. - apply (base_paths _ _ H2). Defined. Definition from_Coequalizer_to_Coequalizer {y z : C} {f g : y --> z} (E E': Coequalizer f g) : C⟦E, E'⟧. Proof. apply (CoequalizerOut E E' (CoequalizerArrow E')). apply CoequalizerEqAr. Defined. Lemma are_inverses_from_Coequalizer_to_Coequalizer {y z : C} {f g : y --> z} {E E': Coequalizer f g} : is_inverse_in_precat (from_Coequalizer_to_Coequalizer E E') (from_Coequalizer_to_Coequalizer E' E). Proof. split; apply pathsinv0; use CoequalizerEndo_is_identity; rewrite assoc; unfold from_Coequalizer_to_Coequalizer; repeat rewrite CoequalizerCommutes; apply idpath. Defined. Lemma isiso_from_Coequalizer_to_Coequalizer {y z : C} {f g : y --> z} (E E' : Coequalizer f g) : is_iso (from_Coequalizer_to_Coequalizer E E'). Proof. apply (is_iso_qinv _ (from_Coequalizer_to_Coequalizer E' E)). apply are_inverses_from_Coequalizer_to_Coequalizer. Defined. Definition iso_from_Coequalizer_to_Coequalizer {y z : C} {f g : y --> z} (E E' : Coequalizer f g) : iso E E' := tpair _ _ (isiso_from_Coequalizer_to_Coequalizer E E'). (** We prove that CoequalizerArrow is an epi. *) Lemma CoequalizerArrowisEpi {y z : C} {f g : y --> z} (E : Coequalizer f g ) : isEpi (CoequalizerArrow E). Proof. apply make_isEpi. intros z0 g0 h X. apply (CoequalizerOutsEq E). apply X. Qed. Lemma CoequalizerArrowEpi {y z : C} {f g : y --> z} (E : Coequalizer f g ) : Epi _ z E. Proof. exact (make_Epi C (CoequalizerArrow E) (CoequalizerArrowisEpi E)). Defined. End def_coequalizers. Definition Coequalizer_eq_ar {C : category} {x y c : C} {f g : x --> y} {e₁ e₂ : y --> c} (p : e₁ = e₂) (q₁ : f · e₁ = g · e₁) (q₂ : f · e₂ = g · e₂) (H : isCoequalizer f g e₁ q₁) : isCoequalizer f g e₂ q₂. Proof. induction p. use (isCoequalizer_path H). apply homset_property. Defined. Definition z_iso_to_Coequalizer {C : category} {x y c₂ : C} {f g : x --> y} (c₁ : Coequalizer f g) (h : z_iso c₁ c₂) : Coequalizer f g. Proof. use make_Coequalizer. - exact c₂. - exact (CoequalizerArrow c₁ · h). - abstract (rewrite !assoc ; rewrite CoequalizerEqAr ; apply idpath). - intros w k q. use iscontraprop1. + abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use (cancel_z_iso' h) ; use (isCoequalizerOutsEq (pr22 c₁)) ; rewrite !assoc ; exact (pr2 φ₁ @ !(pr2 φ₂))). + refine (inv_from_z_iso h · CoequalizerOut c₁ w k q ,, _). abstract (rewrite !assoc' ; rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) ; rewrite z_iso_inv_after_z_iso ; rewrite id_left ; rewrite CoequalizerCommutes ; apply idpath). Defined. Definition z_iso_between_Coequalizer {C : category} {x y : C} {f g : x --> y} (c₁ c₂ : Coequalizer f g) : z_iso c₁ c₂. Proof. use make_z_iso. - exact (CoequalizerOut c₁ c₂ (CoequalizerArrow c₂) (CoequalizerEqAr c₂)). - exact (CoequalizerOut c₂ c₁ (CoequalizerArrow c₁) (CoequalizerEqAr c₁)). - split. + abstract (use (isCoequalizerOutsEq (pr22 c₁)) ; rewrite id_right ; rewrite !assoc ; rewrite !CoequalizerCommutes ; apply idpath). + abstract (use (isCoequalizerOutsEq (pr22 c₂)) ; rewrite id_right ; rewrite !assoc ; rewrite !CoequalizerCommutes ; apply idpath). Defined. (** Make the C not implicit for Coequalizers *) Arguments Coequalizers : clear implicits. (** In univalent categories, equalizers are unique up to equality *) Proposition isaprop_Coequalizer {C : category} (HC : is_univalent C) {x y : C} (f g : x --> y) : isaprop (Coequalizer f g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - apply homset_property. - simpl. repeat (use impred ; intro). apply isapropiscontr. } use total2_paths_f. - use (isotoid _ HC). use z_iso_between_Coequalizer. - rewrite transportf_isotoid' ; cbn. apply CoequalizerCommutes. Qed. (** A reflexive coequalizer is a coequalizer of two morphisms that have a common section. Reflexive coequalizers occur in the study of colimits of the Eilenberg-Moore category. More specifically, if a monad `M` preserves a class of colimits, then the Eilenberg-Moore category has such colimits. However, often monads do not preserve all colimits, but only reflexive coequalizers. The nice thing about reflexive coequalizers is that an Eilenberg-Moore category over a cocomplete category is itself cocomplete if and only if it has reflexive coequalizers. As such, it suffices to check whether a monad preserves reflexive coequalizers in order to guarantee the cocompleteness of the Eilenberg-Moore category. *) Definition reflexive_coequalizers (C : category) : UU := ∏ (x y : C) (f g : x --> y) (h : y --> x) (pf : h · f = identity _) (pg : h · g = identity _), Coequalizer f g. (** If a category has both reflexive coequalizers and binary coproducts, then it also has coequalizers. *) Section CoequalizersFromReflexiveCoequalizers. Context {C : category} (RC : reflexive_coequalizers C) (BCC : BinCoproducts C). Section CoequalizersFromReflexive. Context {x y : C} (f g : x --> y). Let xy : BinCoproduct x y := BCC x y. Let ι₁ : x --> xy := BinCoproductIn1 xy. Let ι₂ : y --> xy := BinCoproductIn2 xy. Definition coequalizers_from_reflexive_left_map : xy --> y := BinCoproductArrow xy f (identity _). Definition coequalizers_from_reflexive_right_map : xy --> y := BinCoproductArrow xy g (identity _). Let ℓ : xy --> y := coequalizers_from_reflexive_left_map. Let ρ : xy --> y := coequalizers_from_reflexive_right_map. Lemma coequalizers_from_reflexive_left_map_eq : ι₂ · ℓ = identity y. Proof. apply BinCoproductIn2Commutes. Qed. Lemma coequalizers_from_reflexive_right_map_eq : ι₂ · ρ = identity y. Proof. apply BinCoproductIn2Commutes. Qed. Definition coequalizers_from_reflexive_ob : Coequalizer ℓ ρ := RC _ _ ℓ ρ ι₂ coequalizers_from_reflexive_left_map_eq coequalizers_from_reflexive_right_map_eq. Proposition coequalizers_from_reflexive_eq : f · CoequalizerArrow coequalizers_from_reflexive_ob = g · CoequalizerArrow coequalizers_from_reflexive_ob. Proof. pose (maponpaths (λ z, BinCoproductIn1 _ · z) (CoequalizerEqAr coequalizers_from_reflexive_ob)) as p. unfold ℓ, ρ in p. unfold coequalizers_from_reflexive_left_map in p. unfold coequalizers_from_reflexive_right_map in p. rewrite !assoc in p. rewrite !BinCoproductIn1Commutes in p. exact p. Qed. Section UMP. Context {z : C} (h : y --> z) (p : f · h = g · h). Proposition coequalizer_from_reflexive_unique : isaprop (∑ φ, CoequalizerArrow coequalizers_from_reflexive_ob · φ = h). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use CoequalizerOutsEq. exact (pr2 φ₁ @ !(pr2 φ₂)). Qed. Definition coequalizer_from_reflexive_ump : coequalizers_from_reflexive_ob --> z. Proof. use (CoequalizerOut coequalizers_from_reflexive_ob z h). abstract (use BinCoproductArrowsEq ; unfold ℓ, ρ ; unfold coequalizers_from_reflexive_left_map ; unfold coequalizers_from_reflexive_right_map ; rewrite !assoc ; rewrite ?BinCoproductIn1Commutes ; rewrite ?BinCoproductIn2Commutes ; [ exact p | apply idpath ]). Defined. Proposition coequalizer_from_reflexive_ump_eq : CoequalizerArrow coequalizers_from_reflexive_ob · coequalizer_from_reflexive_ump = h. Proof. apply CoequalizerCommutes. Qed. End UMP. Definition coequalizer_from_reflexive : Coequalizer f g. Proof. use make_Coequalizer. - exact coequalizers_from_reflexive_ob. - exact (CoequalizerArrow coequalizers_from_reflexive_ob). - exact coequalizers_from_reflexive_eq. - intros z h p. use iscontraprop1. + exact (coequalizer_from_reflexive_unique h). + simple refine (_ ,, _). * exact (coequalizer_from_reflexive_ump h p). * exact (coequalizer_from_reflexive_ump_eq h p). Defined. End CoequalizersFromReflexive. Definition coequalizers_from_reflexive : Coequalizers C := λ x y f g, coequalizer_from_reflexive f g. End CoequalizersFromReflexiveCoequalizers. UniMath-20231010/UniMath/CategoryTheory/limits/cokernels.v000066400000000000000000000512701451125700300233060ustar00rootroot00000000000000(** * Direct definition of cokernels *) (** ** Contents - Definition of cokernel - Correspondence of cokernels and coequalizers - Cokernel up to iso - Cokernel of [Epi] · morphism - CokernelOut of equal morphisms *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.zero. Local Open Scope cat. (** * Definition of cokernels *) Section def_cokernels. Context {C : category}. Let hs : has_homsets C := homset_property C. Hypothesis Z : Zero C. (** Definition and construction of Cokernels *) Definition isCokernel {x y z : C} (f : x --> y) (g : y --> z) (H : f · g = (ZeroArrow Z x z)) : UU := ∏ (w : C) (h : y --> w) (H : f · h = ZeroArrow Z x w), ∃! φ : z --> w, g · φ = h. Lemma isCokernel_paths {x y z : C} (f : x --> y) (g : y --> z) (H H' : f · g = (ZeroArrow Z x z)) (isC : isCokernel f g H) : isCokernel f g H'. Proof. assert (e : H = H') by apply hs. induction e. exact isC. Qed. Local Lemma make_isCokernel_uniqueness {x y z : C} (f : x --> y) (g : y --> z) (H1 : f · g = ZeroArrow Z x z) (H2 : ∏ (w : C) (h : C ⟦ y, w ⟧), f · h = ZeroArrow Z x w → ∃! ψ : C ⟦ z, w ⟧, g · ψ = h) (w : C) (h : y --> w) (H' : f · h = ZeroArrow Z x w) : ∏ y0 : C ⟦ z, w ⟧, g · y0 = h → y0 = pr1 (iscontrpr1 (H2 w h H')). Proof. intros y0 H. apply (base_paths _ _ ((pr2 (H2 w h H')) (tpair _ y0 H))). Qed. Definition make_isCokernel {x y z : C} (f : x --> y) (g : y --> z) (H1 : f · g = ZeroArrow Z x z) (H2 : ∏ (w : C) (h : y --> w) (H' : f · h = ZeroArrow Z x w), ∃! ψ : z --> w, g · ψ = h) : isCokernel f g H1. Proof. unfold isCokernel. intros w h H'. use unique_exists. - exact (pr1 (iscontrpr1 (H2 w h H'))). - exact (pr2 (iscontrpr1 (H2 w h H'))). - intros y0. apply hs. - intros y0 X. exact (base_paths _ _ ((pr2 (H2 w h H')) (tpair _ y0 X))). Defined. Definition Cokernel {x y : C} (f : x --> y) : UU := ∑ D : (∑ z : ob C, y --> z), ∑ (e : f · (pr2 D) = ZeroArrow Z x (pr1 D)), isCokernel f (pr2 D) e. Definition make_Cokernel {x y z : C} (f : x --> y) (g : y --> z) (H : f · g = (ZeroArrow Z x z)) (isCK : isCokernel f g H) : Cokernel f := ((z,,g),,(H,,isCK)). Definition Cokernels : UU := ∏ (x y : C) (f : x --> y), Cokernel f. Definition hasCokernels : UU := ∏ (x y : C) (f : x --> y), ishinh (Cokernel f). Definition CokernelOb {x y : C} {f : x --> y} (CK : Cokernel f) : ob C := pr1 (pr1 CK). Coercion CokernelOb : Cokernel >-> ob. Definition CokernelArrow {x y : C} {f : x --> y} (CK : Cokernel f) : C⟦y, CK⟧ := pr2 (pr1 CK). Definition CokernelCompZero {x y : C} {f : x --> y} (CK : Cokernel f) : f · (CokernelArrow CK) = (ZeroArrow Z x CK) := pr1 (pr2 CK). Definition CokernelisCokernel {y z : C} {g : y --> z} (CK : Cokernel g) := pr2 (pr2 CK). Definition CokernelOut {y z : C} {g : y --> z} (CK : Cokernel g) (w : C) (h : z --> w) (H : g · h = ZeroArrow Z y w) : C⟦CK, w⟧ := pr1 (iscontrpr1 (CokernelisCokernel CK w h H)). Definition CokernelCommutes {y z : C} {g : y --> z} (CK : Cokernel g) (w : C) (h : z --> w) (H : g · h = ZeroArrow Z y w) : (CokernelArrow CK) · (CokernelOut CK w h H) = h := pr2 (iscontrpr1 (CokernelisCokernel CK w h H)). Local Lemma CokernelOutUnique {x y z : C} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow Z x z} (isCK : isCokernel f g H) {w : C} {h : y --> w} (H' : f · h = ZeroArrow Z x w) {φ : z --> w} (H'' : g · φ = h) : φ = (pr1 (pr1 (isCK w h H'))). Proof. exact (base_paths _ _ (pr2 (isCK w h H') (tpair _ φ H''))). Qed. Lemma CokernelOutsEq {x y : C} {f : x --> y} (CK : Cokernel f) {w : C} (φ1 φ2 : C⟦CK, w⟧) (H' : (CokernelArrow CK) · φ1 = (CokernelArrow CK) · φ2) : φ1 = φ2. Proof. assert (H1 : f · ((CokernelArrow CK) · φ1) = ZeroArrow Z _ _). { rewrite assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_left. } rewrite (CokernelOutUnique (CokernelisCokernel CK) H1 (idpath _)). apply pathsinv0. set (tmp := pr2 (CokernelisCokernel CK w (CokernelArrow CK · φ1) H1) (tpair _ φ2 (! H'))). exact (base_paths _ _ tmp). Qed. Lemma CokernelOutComp {y z : C} {f : y --> z} (K : Cokernel f) {w w' : C} (h1 : z --> w) (h2 : w --> w') (H1 : f · (h1 · h2) = ZeroArrow Z _ _) (H2 : f · h1 = ZeroArrow Z _ _) : CokernelOut K w' (h1 · h2) H1 = CokernelOut K w h1 H2 · h2. Proof. use CokernelOutsEq. rewrite CokernelCommutes. rewrite assoc. rewrite CokernelCommutes. apply idpath. Qed. (** Results on morphisms between Cokernels. *) Definition identity_is_CokernelOut {x y : C} {f : x --> y} (CK : Cokernel f) : ∑ φ : C⟦CK, CK⟧, (CokernelArrow CK) · φ = (CokernelArrow CK). Proof. exists (identity CK). apply id_right. Defined. Lemma CokernelEndo_is_identity {x y : C} {f : x --> y} {CK : Cokernel f} (φ : C⟦CK, CK⟧) (H : (CokernelArrow CK) · φ = CokernelArrow CK) : identity CK = φ. Proof. set (H1 := tpair ((fun φ' : C⟦CK, CK⟧ => _ · φ' = _)) φ H). assert (H2 : identity_is_CokernelOut CK = H1). - apply proofirrelevancecontr. apply (CokernelisCokernel CK). apply CokernelCompZero. - apply (base_paths _ _ H2). Qed. Definition from_Cokernel_to_Cokernel {x y : C} {f : x --> y} (CK CK': Cokernel f) : C⟦CK, CK'⟧. Proof. use (CokernelOut CK CK' (CokernelArrow CK')). use CokernelCompZero. Defined. Lemma are_inverses_from_Cokernel_to_Cokernel {y z : C} {g : y --> z} (CK CK': Cokernel g) : is_inverse_in_precat (from_Cokernel_to_Cokernel CK CK') (from_Cokernel_to_Cokernel CK' CK). Proof. split. - unfold from_Cokernel_to_Cokernel. apply pathsinv0. use CokernelEndo_is_identity. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply idpath. - unfold from_Cokernel_to_Cokernel. apply pathsinv0. use CokernelEndo_is_identity. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply idpath. Qed. Definition iso_from_Cokernel_to_Cokernel {y z : C} {g : y --> z} (CK CK' : Cokernel g) : z_iso CK CK' := make_z_iso (from_Cokernel_to_Cokernel CK CK') (from_Cokernel_to_Cokernel CK' CK) (are_inverses_from_Cokernel_to_Cokernel CK CK'). (** Cokernel of the ZeroArrow is given by the identity. *) Lemma CokernelOfZeroArrow_isCokernel (x y : C) : isCokernel (ZeroArrow Z x y) (identity y) (id_right (ZeroArrow Z x y)). Proof. use make_isCokernel. intros w h H'. use unique_exists. - exact h. - exact (id_left _). - intros y0. apply hs. - intros y0 t. cbn in t. rewrite id_left in t. exact t. Qed. Definition CokernelofZeroArrow (x y : C) : Cokernel (ZeroArrow Z x y) := make_Cokernel (ZeroArrow Z x y) (identity y) (id_right _) (CokernelOfZeroArrow_isCokernel x y). (** Cokernel of identity is given by arrow to zero *) Local Lemma CokernelOfIdentity_isCokernel (x : C) : isCokernel (identity x) (ZeroArrowTo x) (ArrowsToZero C Z x (identity x · ZeroArrowTo x) (ZeroArrow Z x Z)). Proof. use make_isCokernel. intros w h H'. use unique_exists. - exact (ZeroArrowFrom w). - cbn. rewrite id_left in H'. rewrite H'. apply idpath. - intros y. apply hs. - intros y X. cbn in X. use ArrowsFromZero. Qed. Definition CokernelOfIdentity (x : C) : Cokernel (identity x). Proof. use make_Cokernel. - exact Z. - exact (ZeroArrowTo x). - use ArrowsToZero. - exact (CokernelOfIdentity_isCokernel x). Defined. (** More generally, the CokernelArrow of the cokernel of the ZeroArrow is an isomorphism. *) Lemma CokernelofZeroArrow_is_iso {x y : C} (CK : Cokernel (ZeroArrow Z x y)) : is_inverse_in_precat (CokernelArrow CK) (from_Cokernel_to_Cokernel CK (CokernelofZeroArrow x y)). Proof. use make_is_inverse_in_precat. - unfold from_Cokernel_to_Cokernel. rewrite CokernelCommutes. apply idpath. - unfold from_Cokernel_to_Cokernel. cbn. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite id_left. rewrite id_right. apply idpath. Qed. Definition CokernelofZeroArrow_iso (x y : C) (CK : Cokernel (ZeroArrow Z x y)) : z_iso y CK := make_z_iso (CokernelArrow CK) (from_Cokernel_to_Cokernel CK (CokernelofZeroArrow x y)) (CokernelofZeroArrow_is_iso CK). (** It follows that CokernelArrow is an epi. *) Lemma CokernelArrowisEpi {y z : C} {g : y --> z} (CK : Cokernel g ) : isEpi (CokernelArrow CK). Proof. unfold isEpi. intros z0 g0 h X. use CokernelOutsEq. exact X. Qed. Lemma CokernelsOut_is_iso {x y : C} {f : x --> y} (CK1 CK2 : Cokernel f) : is_iso (CokernelOut CK1 CK2 (CokernelArrow CK2) (CokernelCompZero CK2)). Proof. use is_iso_qinv. - use CokernelOut. + use CokernelArrow. + use CokernelCompZero. - split. + use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. rewrite id_right. apply idpath. + use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. rewrite id_right. apply idpath. Qed. End def_cokernels. Arguments CokernelArrow [C] [Z] [x] [y] [f] _. Arguments Cokernel [_] _ {_ _}. Arguments isCokernel [_] _ {x y z}. Arguments CokernelOut [_] _ {y z g}. Arguments make_Cokernel [_] _ {x y z}. Arguments CokernelCompZero [_] _ {x y f}. (** * Correspondence of cokernels and coequalizers *) Section cokernels_coequalizers. Context (C : category). Let hs : has_homsets C := homset_property C. Hypothesis Z : Zero C. (** ** [Coequalizer] from [Cokernel] *) Lemma CokernelCoequalizer_eq {x y : ob C} {f : x --> y} (CK : Cokernel Z f) : f · CokernelArrow CK = ZeroArrow Z x y · CokernelArrow CK. Proof. rewrite ZeroArrow_comp_left. use CokernelCompZero. Qed. Lemma CokernelCoequalizer_isCokernel {x y : ob C} {f : x --> y} (CK : Cokernel Z f) : isCoequalizer f (ZeroArrow Z x y) (CokernelArrow CK) (CokernelCoequalizer_eq CK). Proof. use make_isCoequalizer. intros w0 h H'. use unique_exists. - use CokernelOut. + exact h. + rewrite H'. apply ZeroArrow_comp_left. - use CokernelCommutes. - intros y0. apply hs. - intros y0 X. use CokernelOutsEq. rewrite CokernelCommutes. exact X. Qed. Definition CokernelCoequalizer {x y : ob C} {f : x --> y} (CK : Cokernel Z f) : Coequalizer f (ZeroArrow Z _ _). Proof. use make_Coequalizer. - exact CK. - exact (CokernelArrow CK). - exact (CokernelCoequalizer_eq CK). - exact (CokernelCoequalizer_isCokernel CK). Defined. (** ** [Cokernel] from [Coequalizer] *) Lemma CoequalizerCokernel_eq {x y : ob C} {f : x --> y} (CE : Coequalizer f (ZeroArrow Z _ _)) : f · CoequalizerArrow CE = ZeroArrow Z x CE. Proof. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ (CoequalizerArrow CE)). exact (CoequalizerEqAr CE). Qed. Lemma CoequalizerCokernel_isCokernel {x y : ob C} {f : x --> y} (CE : Coequalizer f (ZeroArrow Z _ _)) : isCokernel Z f (CoequalizerArrow CE) (CoequalizerCokernel_eq CE). Proof. use (make_isCokernel). intros w h H'. use unique_exists. - use CoequalizerOut. + exact h. + rewrite ZeroArrow_comp_left. exact H'. - use CoequalizerCommutes. - intros y0. apply hs. - intros y0 X. use CoequalizerOutsEq. rewrite CoequalizerCommutes. exact X. Qed. Definition CoequalizerCokernel {x y : ob C} {f : x --> y} (CE : Coequalizer f (ZeroArrow Z _ _)) : Cokernel Z f. Proof. use make_Cokernel. - exact CE. - exact (CoequalizerArrow CE). - exact (CoequalizerCokernel_eq CE). - exact (CoequalizerCokernel_isCokernel CE). Defined. End cokernels_coequalizers. (** * Cokernels up to iso*) Section cokernels_iso. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Lemma Cokernel_up_to_iso_eq {x y z : C} (f : x --> y) (g : y --> z) (CK : Cokernel Z f) (h : z_iso CK z) (H : g = (CokernelArrow CK) · h) : f · g = ZeroArrow Z x z. Proof. induction CK as [t p]. induction t as [t' p']. induction p as [t'' p'']. unfold isCoequalizer in p''. rewrite H. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ h). rewrite assoc. apply cancel_postcomposition. apply CokernelCompZero. Qed. Lemma Cokernel_up_to_iso_isCokernel {x y z : C} (f : x --> y) (g : y --> z) (CK : Cokernel Z f) (h : z_iso CK z) (H : g = (CokernelArrow CK) · h) (H'' : f · g = ZeroArrow Z x z) : isCokernel Z f g H''. Proof. use (make_isCokernel). intros w h0 H'. use unique_exists. - exact ((inv_from_z_iso h) · (CokernelOut Z CK w h0 H')). - cbn. rewrite H. rewrite assoc. rewrite <- (assoc _ h). rewrite (is_inverse_in_precat1 h). rewrite id_right. use CokernelCommutes. - intros y0. apply hs. - intros y0 X. cbn beta in X. use (pre_comp_with_z_iso_is_inj h). rewrite assoc. set (tmp := maponpaths (λ gg : _, gg · CokernelOut Z CK w h0 H') (is_inverse_in_precat1 h)). cbn in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite id_left. use CokernelOutsEq. rewrite CokernelCommutes. rewrite assoc. rewrite <- X. apply cancel_postcomposition. rewrite H. apply cancel_precomposition. apply idpath. Qed. Definition Cokernel_up_to_iso {x y z : C} (f : x --> y) (g : y --> z) (CK : Cokernel Z f) (h : z_iso CK z) (H : g = (CokernelArrow CK) · h) : Cokernel Z f := make_Cokernel Z f g (Cokernel_up_to_iso_eq f g CK h H) (Cokernel_up_to_iso_isCokernel f g CK h H (Cokernel_up_to_iso_eq f g CK h H)). Definition Cokernel_up_to_iso2_eq {x y z : C} (f1 : x --> z) (f2 : y --> z) (h : z_iso y x) (H : h · f1 = f2) (CK : Cokernel Z f1) : f2 · CokernelArrow CK = ZeroArrow Z y CK. Proof. rewrite <- H. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Definition Cokernel_up_to_iso2_isCoequalizer {x y z : C} (f1 : x --> z) (f2 : y --> z) (h : z_iso y x) (H : h · f1 = f2) (CK : Cokernel Z f1) : isCokernel Z f2 (CokernelArrow CK) (Cokernel_up_to_iso2_eq f1 f2 h H CK). Proof. use (make_isCokernel). intros w h0 H'. use unique_exists. - use CokernelOut. + exact h0. + rewrite <- H in H'. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ h) in H'. rewrite <- assoc in H'. apply (pre_comp_with_z_iso_is_inj h) in H'. exact H'. - cbn. use CokernelCommutes. - intros y0. apply hs. - intros y0 X. cbn beta in X. use CokernelOutsEq. rewrite CokernelCommutes. exact X. Qed. Definition Cokernel_up_to_iso2 {x y z : C} (f1 : x --> z) (f2 : y --> z) (h : z_iso y x) (H : h · f1 = f2) (CK : Cokernel Z f1) : Cokernel Z f2 := make_Cokernel Z f2 (CokernelArrow CK) (Cokernel_up_to_iso2_eq f1 f2 h H CK) (Cokernel_up_to_iso2_isCoequalizer f1 f2 h H CK). End cokernels_iso. (** * Cokernel of epi · morphism *) (** ** Introduction Suppose E : x --> y is an [Epi] and f : y --> z is a morphism. Then cokernel of E · f is isomorphic to cokernel of f. *) Section cokernels_epis. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Local Lemma CokernelEpiComp_eq1 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : E · f · CokernelArrow CK2 = ZeroArrow Z x CK2. Proof. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Definition CokernelEpiComp_mor1 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : C⟦CK1, CK2⟧ := CokernelOut Z CK1 _ (CokernelArrow CK2) (CokernelEpiComp_eq1 E f CK1 CK2). Local Lemma CokernelEpiComp_eq2 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : f · CokernelArrow CK1 = ZeroArrow Z y CK1. Proof. use (EpiisEpi C E). rewrite assoc. rewrite ZeroArrow_comp_right. exact (CokernelCompZero Z CK1). Qed. Definition CokernelEpiComp_mor2 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : C⟦CK2, CK1⟧ := CokernelOut Z CK2 _ (CokernelArrow CK1) (CokernelEpiComp_eq2 E f CK1 CK2). Lemma CokernelEpiComp1 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : is_iso (CokernelEpiComp_mor1 E f CK1 CK2). Proof. use is_iso_qinv. - exact (CokernelEpiComp_mor2 E f CK1 CK2). - split. + unfold CokernelEpiComp_mor1. unfold CokernelEpiComp_mor2. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply pathsinv0. apply id_right. + unfold CokernelEpiComp_mor1. unfold CokernelEpiComp_mor2. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply pathsinv0. apply id_right. Qed. Lemma CokernelEpiComp2 {x y z : C} (E : Epi C x y) (f : y --> z) (CK1 : Cokernel Z (E · f)) (CK2 : Cokernel Z f) : is_iso (CokernelEpiComp_mor2 E f CK1 CK2). Proof. use is_iso_qinv. - exact (CokernelEpiComp_mor1 E f CK1 CK2). - split. + unfold CokernelEpiComp_mor1. unfold CokernelEpiComp_mor2. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply pathsinv0. apply id_right. + unfold CokernelEpiComp_mor1. unfold CokernelEpiComp_mor2. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. apply pathsinv0. apply id_right. Qed. Local Lemma CokernelEpiComp_eq {x y z : C} (E : Epi C x y) (f : y --> z) (CK : Cokernel Z (E · f)) : f · CokernelArrow CK = ZeroArrow Z y CK. Proof. use (EpiisEpi C E). rewrite ZeroArrow_comp_right. rewrite assoc. use CokernelCompZero. Qed. Local Lemma CokernelEpiComp_isCoequalizer {x y z : C} (E : Epi C x y) (f : y --> z) (CK : Cokernel Z (E · f)) : isCokernel Z f (CokernelArrow CK) (CokernelEpiComp_eq E f CK). Proof. use make_isCokernel. - intros w h H'. use unique_exists. + use CokernelOut. * exact h. * rewrite <- (ZeroArrow_comp_right _ _ _ _ _ E). rewrite <- assoc. apply cancel_precomposition. exact H'. + cbn. rewrite CokernelCommutes. apply idpath. + intros y0. apply hs. + intros y0 X. apply pathsinv0. cbn in X. use (EpiisEpi C (make_Epi _ _ (CokernelArrowisEpi Z CK))). cbn. rewrite CokernelCommutes. apply pathsinv0. apply X. Qed. Definition CokernelEpiComp {x y z : C} (E : Epi C x y) (f : y --> z) (CK : Cokernel Z (E · f)) : Cokernel Z f. Proof. use make_Cokernel. - exact CK. - use CokernelArrow. - exact (CokernelEpiComp_eq E f CK). - exact (CokernelEpiComp_isCoequalizer E f CK). Defined. End cokernels_epis. (** * CokernelOut of equal, not necessarily definitionally equal, morphisms is iso *) Section cokernel_out_paths. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Definition CokernelOutPaths_is_iso_mor {x y : C} {f f' : x --> y} (e : f = f') (CK1 : Cokernel Z f) (CK2 : Cokernel Z f') : CK1 --> CK2. Proof. induction e. use CokernelOut. - use CokernelArrow. - use CokernelCompZero. Defined. Lemma CokernelOutPaths_is_iso {x y : C} {f f' : x --> y} (e : f = f') (CK1 : Cokernel Z f) (CK2 : Cokernel Z f') : is_iso (CokernelOutPaths_is_iso_mor e CK1 CK2). Proof. induction e. apply CokernelsOut_is_iso. Qed. Local Lemma CokernelPath_eq {x y : C} {f f' : x --> y} (e : f = f') (CK : Cokernel Z f) : f' · CokernelArrow CK = ZeroArrow Z x CK. Proof. induction e. use CokernelCompZero. Qed. Local Lemma CokernelPath_isCokernel {x y : C} {f f' : x --> y} (e : f = f') (CK : Cokernel Z f) : isCokernel Z f' (CokernelArrow CK) (CokernelPath_eq e CK). Proof. induction e. use CokernelisCokernel. Qed. (** Constructs a cokernel of f' from a cokernel of f in a natural way *) Definition CokernelPath {x y : C} {f f' : x --> y} (e : f = f') (CK : Cokernel Z f) : Cokernel Z f'. Proof. use make_Cokernel. - exact CK. - use CokernelArrow. - exact (CokernelPath_eq e CK). - exact (CokernelPath_isCokernel e CK). Defined. End cokernel_out_paths. UniMath-20231010/UniMath/CategoryTheory/limits/cones.v000066400000000000000000000205011451125700300224210ustar00rootroot00000000000000(** Definition of the precategory of cones over a precategory C together with a proof that that precategory is a univalent_category if C is ([is_univalent_CONE]). Written by Benedikt Ahrens, following discussions with J. Gross, D. Grayson and V. Voevodsky *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Section Cone. Variables J : precategory. Variable C : category. Variable F : functor J C. Definition ConeData : UU := ∑ a : C, ∏ j : J, a --> F j. Definition ConeTop (a : ConeData) : C := pr1 a. Definition ConeMor (a : ConeData) (j : J) : ConeTop a --> F j := (pr2 a) j. Lemma eq_ConeData_eq (a b : ConeData) (p q : a = b) : base_paths _ _ p = base_paths _ _ q -> p = q. Proof. intro H. apply (eq_equalities_between_pairs _ _ _ _ _ _ H). apply uip. apply (impred 2); intro j. apply C. Defined. Definition ConeProp (a : ConeData) := ∏ j j' (f : j --> j'), ConeMor a j · #F f = ConeMor a j'. Lemma isaprop_ConeProp (a : ConeData) : isaprop (ConeProp a). Proof. repeat (apply impred; intro). apply C. Qed. Definition Cone := total2 (λ a : ConeData, ConeProp a). Definition ConeData_from_Cone : Cone -> ConeData := λ a, pr1 a. Lemma eq_Cone_eq (a b : Cone) (p q : a = b) : base_paths _ _ (base_paths _ _ p) = base_paths _ _ (base_paths _ _ q) -> p = q. Proof. intro H. assert (H2 : base_paths _ _ p = base_paths _ _ q). apply eq_ConeData_eq. apply H. apply (eq_equalities_between_pairs _ _ _ _ _ _ H2). apply uip. apply isasetaprop. apply isaprop_ConeProp. Defined. Coercion ConeData_from_Cone : Cone >-> ConeData. Definition ConeProp_from_Cone (a : Cone) : ConeProp a := pr2 a. Coercion ConeProp_from_Cone : Cone >-> ConeProp. Lemma cone_prop (a : Cone) : ∏ j j' (f : j --> j'), ConeMor a j · #F f = ConeMor a j'. Proof. exact (pr2 a). Qed. Definition Cone_eq (a b : Cone) : pr1 a = pr1 b -> a = b. Proof. intro H. apply (total2_paths_f H). apply proofirrelevance. apply isaprop_ConeProp. Defined. Definition Cone_Mor (M N : Cone) := total2 (fun f : ConeTop M --> ConeTop N => ∏ j : J, f · ConeMor N j = ConeMor M j). Lemma isaset_Cone_Mor (M N : Cone) : isaset (Cone_Mor M N). Proof. apply (isofhleveltotal2 2). apply C. intros. apply hlevelntosn. apply impred. intros. apply C. Qed. Definition ConeConnect {M N : Cone} (f : Cone_Mor M N) : ConeTop M --> ConeTop N := pr1 f. Lemma Cone_Mor_eq (M N : Cone) (f g : Cone_Mor M N) : ConeConnect f = ConeConnect g -> f = g. Proof. intro H. apply (total2_paths_f H). apply proofirrelevance. apply impred; intro; apply C. Qed. Lemma cone_mor_prop M N (f : Cone_Mor M N) : ∏ j : J, ConeConnect f · ConeMor N j = ConeMor M j. Proof. exact (pr2 f). Qed. Definition Cone_id (A : Cone) : Cone_Mor A A. Proof. exists (identity _). intros; apply id_left. Defined. Definition Cone_comp (A B D : Cone) (f : Cone_Mor A B) (g : Cone_Mor B D) : Cone_Mor A D. Proof. exists (ConeConnect f · ConeConnect g). intro j. (* make this proof opaque *) rewrite <- assoc. rewrite cone_mor_prop. rewrite cone_mor_prop. apply idpath. Defined. Definition Cone_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor Cone (λ a b, Cone_Mor a b). Definition Cone_precategory_data : precategory_data. Proof. exists Cone_precategory_ob_mor. exists Cone_id. exact Cone_comp. Defined. Lemma is_precategory_Cone : is_precategory Cone_precategory_data. Proof. repeat split; simpl. intros; apply Cone_Mor_eq; simpl; apply id_left. intros; apply Cone_Mor_eq; simpl; apply id_right. intros; apply Cone_Mor_eq; simpl; apply assoc. intros; apply Cone_Mor_eq; simpl; apply assoc'. Defined. Definition CONEpre : precategory := tpair _ _ is_precategory_Cone. Lemma has_homsets_CONEpre : has_homsets CONEpre. Proof. intros x y. apply isaset_Cone_Mor. Qed. Definition CONE : category := CONEpre ,, has_homsets_CONEpre. (* this should not need the pr1 before f *) Definition iso_projects_from_CONE (a b : CONE) (f : z_iso a b) : is_z_isomorphism (ConeConnect (pr1 f)). Proof. set (T:=z_iso_inv_after_z_iso f). set (T':=z_iso_after_z_iso_inv f). exists (ConeConnect (inv_from_z_iso f)). split; simpl. - apply (base_paths _ _ T). - apply (base_paths _ _ T'). Defined. Definition ConeConnectIso {a b : CONE} (f : z_iso a b) : z_iso (ConeTop (pr1 a)) (ConeTop (pr1 b)) := tpair _ _ (iso_projects_from_CONE a b f). Lemma ConeConnectIso_identity_iso (a : CONE) : ConeConnectIso (identity_z_iso a) = identity_z_iso _ . Proof. apply z_iso_eq. apply idpath. Qed. Lemma ConeConnectIso_inj (a b : CONE) (f g : z_iso a b) : ConeConnectIso f = ConeConnectIso g -> f = g. Proof. intro H. apply z_iso_eq; simpl in *. apply Cone_Mor_eq. apply (base_paths _ _ H). Qed. Lemma inv_from_iso_ConeConnectIso (a b : CONE) (f : z_iso a b): pr1 (inv_from_z_iso f) = inv_from_z_iso (ConeConnectIso f). Proof. apply idpath. Defined. End Cone. Arguments CONE [J C]. Arguments ConeConnect [J C]. Section CONE_category. Variable J : precategory. Variable C : category. Variable F : functor J C. Hypothesis is_cat_C : is_univalent C. Definition isotoid_CONE_pr1 (a b : CONE F) : z_iso a b -> pr1 a = pr1 b. Proof. intro f. apply (total2_paths_f (isotoid _ is_cat_C (ConeConnectIso _ _ _ f))). intermediate_path ((λ c : J, idtoiso (!isotoid C is_cat_C (ConeConnectIso _ _ _ f))· pr2 (pr1 a) c)). apply transportf_isotoid_dep'. apply funextsec. intro t. intermediate_path (idtoiso (isotoid C is_cat_C (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f)))· pr2 (pr1 a) t). apply cancel_postcomposition. apply maponpaths. apply maponpaths. apply inv_isotoid. intermediate_path (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f)· pr2 (pr1 a) t). apply cancel_postcomposition. set (H := idtoiso_isotoid _ is_cat_C _ _ (z_iso_inv_from_z_iso (ConeConnectIso _ _ _ f))). simpl in *. apply (base_paths _ _ H). simpl. set (T':= inv_from_z_iso f). set (T:=pr2 (inv_from_z_iso f) t). simpl in *. rewrite <- inv_from_iso_ConeConnectIso. apply T. Defined. Definition isotoid_CONE {a b : CONE F} : z_iso a b -> a = b. Proof. intro f. apply Cone_eq. apply (isotoid_CONE_pr1 _ _ f). Defined. Lemma eq_CONE_pr1 (M N : CONE F) (p q : M = N) : base_paths _ _ p = base_paths _ _ q -> p = q. Proof. intro H. simpl in *. apply (eq_equalities_between_pairs _ _ _ _ _ _ H). apply proofirrelevancecontr. apply isaprop_ConeProp. Defined. Lemma base_paths_isotoid_CONE (M : CONE F): base_paths (pr1 M) (pr1 M) (base_paths M M (isotoid_CONE (identity_z_iso M))) = base_paths (pr1 M) (pr1 M) (idpath (pr1 M)). Proof. intermediate_path (base_paths (pr1 M) (pr1 M) (isotoid_CONE_pr1 M M (identity_z_iso M))). unfold Cone_eq. apply maponpaths. apply base_total2_paths. intermediate_path (isotoid C is_cat_C (ConeConnectIso _ _ _ (identity_z_iso M))). unfold isotoid_CONE_pr1. apply base_total2_paths. intermediate_path (isotoid C is_cat_C (identity_z_iso (ConeTop _ _ _ (pr1 M)))). apply maponpaths, ConeConnectIso_identity_iso. apply isotoid_identity_iso. Defined. Lemma isotoid_CONE_idtoiso (M N : CONE F) : ∏ p : M = N, isotoid_CONE (idtoiso p) = p. Proof. intro p. induction p. apply eq_Cone_eq. apply base_paths_isotoid_CONE. Qed. Lemma ConeConnect_idtoiso (M N : CONE F) (p : M = N): ConeConnect _ _ _ (pr1 (idtoiso p)) = idtoiso ((base_paths _ _ (base_paths _ _ p))). Proof. destruct p. apply idpath. Qed. Lemma idtoiso_isotoid_CONE (M N : CONE F) : ∏ f : z_iso M N, idtoiso (isotoid_CONE f) = f. Proof. intro f. apply z_iso_eq. apply Cone_Mor_eq. etrans; [apply ConeConnect_idtoiso |]. unfold isotoid_CONE. unfold Cone_eq. rewrite base_total2_paths. unfold isotoid_CONE_pr1. rewrite base_total2_paths. simpl. rewrite idtoiso_isotoid. apply idpath. Qed. Lemma is_univalent_CONE : is_univalent (CONE F). Proof. intros a b. apply (isweq_iso _ (@isotoid_CONE a b)). apply isotoid_CONE_idtoiso. apply idtoiso_isotoid_CONE. Defined. End CONE_category. UniMath-20231010/UniMath/CategoryTheory/limits/coproducts.v000066400000000000000000000425151451125700300235100ustar00rootroot00000000000000(* Direct implementation of indexed coproducts together with: - The general coproduct functor ([coproduct_functor]) - Definition of a coproduct structure on a functor category by taking pointwise coproducts in the target category (adapted from the binary version) ([]) - Coproducts from colimits ([Coproducts_from_Colims]) Written by: Anders Mörtberg 2016 Extended by Ralph Matthes 2023 for the distributors *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. (** * Definition of indexed coproducts of objects in a precategory *) Section coproduct_def. Context (I : UU) (C : category). Definition isCoproduct (a : I -> C) (co : C) (ia : ∏ i, a i --> co) := ∏ (c : C) (f : ∏ i, a i --> c), ∃! (g : co --> c), ∏ i, ia i · g = f i. Definition Coproduct (a : I -> C) := ∑ coia : (∑ co : C, ∏ i, a i --> co), isCoproduct a (pr1 coia) (pr2 coia). Definition Coproducts := ∏ (a : I -> C), Coproduct a. Definition hasCoproducts := ∏ (a : I -> C), ∥ Coproduct a ∥. Definition CoproductObject {a : I -> C} (CC : Coproduct a) : C := pr1 (pr1 CC). Coercion CoproductObject : Coproduct >-> ob. Definition CoproductIn {a : I -> C} (CC : Coproduct a): ∏ i, a i --> CoproductObject CC := pr2 (pr1 CC). Definition isCoproduct_Coproduct {a : I -> C} (CC : Coproduct a) : isCoproduct a (CoproductObject CC) (CoproductIn CC). Proof. exact (pr2 CC). Defined. Definition CoproductArrow {a : I -> C} (CC : Coproduct a) {c : C} (f : ∏ i, a i --> c) : CoproductObject CC --> c. Proof. exact (pr1 (pr1 (isCoproduct_Coproduct CC _ f))). Defined. Lemma CoproductInCommutes (a : I -> C) (CC : Coproduct a) : ∏ (c : C) (f : ∏ i, a i --> c) i, CoproductIn CC i · CoproductArrow CC f = f i. Proof. intros c f i. exact (pr2 (pr1 (isCoproduct_Coproduct CC _ f)) i). Qed. Lemma CoproductIn_idtoiso {i1 i2 : I} (a : I -> C) (CC : Coproduct a) (e : i1 = i2) : idtoiso (maponpaths a e) · CoproductIn CC i2 = CoproductIn CC i1. Proof. induction e. apply id_left. Qed. Lemma CoproductArrowUnique (a : I -> C) (CC : Coproduct a) (x : C) (f : ∏ i, a i --> x) (k : CoproductObject CC --> x) (Hk : ∏ i, CoproductIn CC i · k = f i) : k = CoproductArrow CC f. Proof. set (H' := pr2 (isCoproduct_Coproduct CC _ f) (k,,Hk)). apply (base_paths _ _ H'). Qed. Lemma CoproductArrowEta (a : I -> C) (CC : Coproduct a) (x : C) (f : CoproductObject CC --> x) : f = CoproductArrow CC (λ i, CoproductIn CC i · f). Proof. now apply CoproductArrowUnique. Qed. Proposition CoproductArrow_eq {d : I → C} (z : C) (x : Coproduct d) (f g : x --> z) (p : ∏ (i : I), CoproductIn x i · f = CoproductIn x i · g) : f = g. Proof. refine (CoproductArrowEta _ _ _ _ @ _ @ !(CoproductArrowEta _ _ _ _)). apply maponpaths. use funextsec. exact p. Qed. Definition CoproductOfArrows {a : I -> C} (CCab : Coproduct a) {c : I -> C} (CCcd : Coproduct c) (f : ∏ i, a i --> c i) : CoproductObject CCab --> CoproductObject CCcd := CoproductArrow CCab (λ i, f i · CoproductIn CCcd i). Lemma CoproductOfArrowsIn {a : I -> C} (CCab : Coproduct a) {c : I -> C} (CCcd : Coproduct c) (f : ∏ i, a i --> c i) : ∏ i, CoproductIn CCab i · CoproductOfArrows CCab CCcd f = f i · CoproductIn CCcd i. Proof. unfold CoproductOfArrows; intro i. apply CoproductInCommutes. Qed. Definition make_Coproduct (a : I -> C) (c : C) (f : ∏ i, a i --> c) : isCoproduct _ _ f → Coproduct a. Proof. intro H. use tpair. - apply (tpair _ c f). - apply H. Defined. Definition make_isCoproduct (hsC : has_homsets C) (a : I -> C) (co : C) (f : ∏ i, a i --> co) : (∏ (c : C) (g : ∏ i, a i --> c), ∃! k : C ⟦co, c⟧, ∏ i, f i · k = g i) → isCoproduct a co f. Proof. intros H c cc. apply H. Defined. Lemma precompWithCoproductArrow {a : I -> C} (CCab : Coproduct a) {c : I -> C} (CCcd : Coproduct c) (f : ∏ i, a i --> c i) {x : C} (k : ∏ i, c i --> x) : CoproductOfArrows CCab CCcd f · CoproductArrow CCcd k = CoproductArrow CCab (λ i, f i · k i). Proof. apply CoproductArrowUnique; intro i. now rewrite assoc, CoproductOfArrowsIn, <- assoc, CoproductInCommutes. Qed. Lemma postcompWithCoproductArrow {a : I -> C} (CCab : Coproduct a) {c : C} (f : ∏ i, a i --> c) {x : C} (k : c --> x) : CoproductArrow CCab f · k = CoproductArrow CCab (λ i, f i · k). Proof. apply CoproductArrowUnique; intro i. now rewrite assoc, CoproductInCommutes. Qed. Lemma Coproduct_endo_is_identity (a : I -> C) (CC : Coproduct a) (k : CoproductObject CC --> CoproductObject CC) (H1 : ∏ i, CoproductIn CC i · k = CoproductIn CC i) : identity _ = k. Proof. apply pathsinv0. eapply pathscomp0; [apply CoproductArrowEta|]. apply pathsinv0, CoproductArrowUnique; intro i; apply pathsinv0. now rewrite id_right, H1. Qed. End coproduct_def. Section Coproducts. Context (I : UU) (C : category) (CC : Coproducts I C). (* Lemma CoproductArrow_eq (f f' : a --> c) (g g' : b --> c) *) (* : f = f' → g = g' → *) (* CoproductArrow _ (CC _ _) f g = CoproductArrow _ _ f' g'. *) (* Proof. *) (* induction 1. *) (* induction 1. *) (* apply idpath. *) (* Qed. *) Definition CoproductOfArrows_comp (a b c : I -> C) (f : ∏ i, a i --> b i) (g : ∏ i, b i --> c i) : CoproductOfArrows _ _ _ _ f · CoproductOfArrows _ _ (CC _) (CC _) g = CoproductOfArrows _ _ (CC _) (CC _)(λ i, f i · g i). Proof. apply CoproductArrowUnique; intro i. rewrite assoc, CoproductOfArrowsIn. now rewrite <- assoc, CoproductOfArrowsIn, assoc. Qed. End Coproducts. Section functors. Definition coproduct_functor_data (I : UU) {C : category} (PC : Coproducts I C) : functor_data (power_category I C) C. Proof. use tpair. - intros p. apply (CoproductObject _ _ (PC p)). - simpl; intros p q f. apply (CoproductOfArrows _ _ _ _ f). Defined. (** * The coproduct functor: C^I -> C *) Definition coproduct_functor (I : UU) {C : category} (PC : Coproducts I C) : functor (power_category I C) C. Proof. apply (tpair _ (coproduct_functor_data _ PC)). abstract (split; [intro x; simpl; apply pathsinv0, Coproduct_endo_is_identity; now intro i; rewrite CoproductOfArrowsIn, id_left | now intros x y z f g; simpl; rewrite CoproductOfArrows_comp]). Defined. End functors. (* The coproduct of a family of functors *) (* This is the old and not so good definition as it is unnecessarily complicated, also the proof that it is omega-cocontinuous requires that C has products *) Definition coproduct_of_functors_alt_old (I : UU) {C D : category} (HD : Coproducts I D) (F : I -> functor C D) : functor C D := functor_composite (delta_functor I C) (functor_composite (family_functor _ F) (coproduct_functor _ HD)). (** The coproduct of a family of functors *) Definition coproduct_of_functors_alt (I : UU) {C D : category} (HD : Coproducts I D) (F : ∏ (i : I), functor C D) := functor_composite (tuple_functor F) (coproduct_functor _ HD). (** * Coproducts lift to functor categories *) Section def_functor_pointwise_coprod. Context (I : UU) (C D : category) (HD : Coproducts I D). Section coproduct_of_functors. Context (F : I -> functor C D). Definition coproduct_of_functors_ob (c : C) : D := CoproductObject _ _ (HD (λ i, F i c)). Definition coproduct_of_functors_mor (c c' : C) (f : c --> c') : coproduct_of_functors_ob c --> coproduct_of_functors_ob c' := CoproductOfArrows _ _ _ _ (λ i, # (F i) f). Definition coproduct_of_functors_data : functor_data C D. Proof. exists coproduct_of_functors_ob. exact coproduct_of_functors_mor. Defined. Lemma is_functor_coproduct_of_functors_data : is_functor coproduct_of_functors_data. Proof. split; simpl; intros. - unfold functor_idax; intros; simpl in *. apply pathsinv0. apply Coproduct_endo_is_identity; intro i. unfold coproduct_of_functors_mor. eapply pathscomp0; [apply (CoproductOfArrowsIn _ _ (HD (λ i, (F i) a)))|]. now simpl; rewrite functor_id, id_left. - unfold functor_compax; simpl; unfold coproduct_of_functors_mor. intros; simpl in *. apply pathsinv0. eapply pathscomp0. apply CoproductOfArrows_comp. apply maponpaths, funextsec; intro i. now rewrite functor_comp. Qed. Definition coproduct_of_functors : functor C D := tpair _ _ is_functor_coproduct_of_functors_data. Lemma coproduct_of_functors_alt_old_eq_coproduct_of_functors : coproduct_of_functors_alt_old _ HD F = coproduct_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Lemma coproduct_of_functors_alt_eq_coproduct_of_functors : coproduct_of_functors_alt _ HD F = coproduct_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Definition coproduct_nat_trans_in_data i (c : C) : D ⟦ (F i) c, coproduct_of_functors c ⟧ := CoproductIn _ _ (HD (λ j, (F j) c)) i. Lemma is_nat_trans_coproduct_nat_trans_in_data i : is_nat_trans _ _ (coproduct_nat_trans_in_data i). Proof. intros c c' f; apply pathsinv0. now eapply pathscomp0;[apply (CoproductOfArrowsIn I _ (HD (λ i, (F i) c)))|]. Qed. Definition coproduct_nat_trans_in i : nat_trans (F i) coproduct_of_functors := tpair _ _ (is_nat_trans_coproduct_nat_trans_in_data i). Section vertex. Context (A : functor C D) (f : ∏ i, nat_trans (F i) A). Definition coproduct_nat_trans_data c : coproduct_of_functors c --> A c := CoproductArrow _ _ _ (λ i, f i c). Lemma is_nat_trans_coproduct_nat_trans_data : is_nat_trans _ _ coproduct_nat_trans_data. Proof. intros a b k; simpl. eapply pathscomp0. apply (precompWithCoproductArrow I D (HD (λ i : I, (F i) a)) (HD (λ i : I, (F i) b))). apply pathsinv0. eapply pathscomp0; [apply postcompWithCoproductArrow|]. apply maponpaths, funextsec; intro i. now rewrite (nat_trans_ax (f i)). Qed. Definition coproduct_nat_trans : nat_trans coproduct_of_functors A := tpair _ _ is_nat_trans_coproduct_nat_trans_data. End vertex. Definition functor_precat_coproduct_cocone : Coproduct I [C, D] F. Proof. use make_Coproduct. - apply coproduct_of_functors. - apply coproduct_nat_trans_in. - use make_isCoproduct. + apply functor_category_has_homsets. + intros A f. use tpair. * apply (tpair _ (coproduct_nat_trans A f)). abstract (intro i; apply (nat_trans_eq D); intro c; apply (CoproductInCommutes I D _ (HD (λ j, (F j) c)))). * abstract ( intro t; apply subtypePath; simpl; [intro; apply impred; intro; apply (isaset_nat_trans D)|]; apply (nat_trans_eq D); intro c; apply CoproductArrowUnique; intro i; apply (nat_trans_eq_pointwise (pr2 t i))). Defined. End coproduct_of_functors. Definition Coproducts_functor_precat : Coproducts I [C, D]. Proof. intros F. apply functor_precat_coproduct_cocone. Defined. End def_functor_pointwise_coprod. (** * Coproducts from colimits *) Section coproducts_from_colimits. Context (I : UU) (C : category). Definition I_graph : graph := (I,,λ _ _,empty). Definition coproducts_diagram (F : I → C) : diagram I_graph C. Proof. exists F. abstract (intros u v e; induction e). Defined. Definition Coproducts_cocone c (F : I → C) (H : ∏ i, F i --> c) : cocone (coproducts_diagram F) c. Proof. use tpair. + intro v; apply H. + abstract (intros u v e; induction e). Defined. Lemma Coproducts_from_Colims : Colims_of_shape I_graph C -> Coproducts I C. Proof. intros H F. set (HF := H (coproducts_diagram F)). use make_Coproduct. + apply (colim HF). + intros i; apply (colimIn HF). + apply (make_isCoproduct _ _ C); intros c Fic. use unique_exists. - now apply colimArrow, Coproducts_cocone. - abstract (simpl; intro i; apply (colimArrowCommutes HF)). - abstract (intros y; apply impred; intro i; apply C). - abstract (intros f Hf; apply colimArrowUnique; simpl in *; intros i; apply Hf). Defined. End coproducts_from_colimits. Section DistributionThroughFunctor. Context {I : UU} {C D : category} (CPC : Coproducts I C) (CPD : Coproducts I D) (F : functor C D). Definition coprod_antidistributor (cs : power_category I C): CPD (fun i => F (cs i)) --> F (CPC cs). Proof. use CoproductArrow; intro i; apply (#F). apply CoproductIn. Defined. Lemma coprod_antidistributor_nat (cs1 cs2 : power_category I C) (g : power_category I C ⟦ cs1, cs2 ⟧) : coprod_antidistributor cs1 · #F (#(coproduct_functor I CPC) g) = #(coproduct_functor I CPD) (#(family_functor I (fun _ => F)) g) · coprod_antidistributor cs2. Proof. etrans. { apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithCoproductArrow. } apply maponpaths. apply funextsec; intro i. etrans. { apply pathsinv0, functor_comp. } etrans. 2: { cbn. apply functor_comp. } apply maponpaths. apply CoproductInCommutes. Qed. (** axiomatize extra requirements *) Definition coprod_distributor_data : UU := ∏ (cs : power_category I C), F (CPC cs) --> CPD (fun i => F (cs i)). Identity Coercion coprod_distributor_data_funclass: coprod_distributor_data >-> Funclass. Definition coprod_distributor_iso_law (δ : coprod_distributor_data) : UU := ∏ (cs : power_category I C), is_inverse_in_precat (δ cs) (coprod_antidistributor cs). Definition coprod_distributor : UU := ∑ δ : coprod_distributor_data, coprod_distributor_iso_law δ. Definition coprod_distributor_to_data (δ : coprod_distributor) : coprod_distributor_data := pr1 δ. Coercion coprod_distributor_to_data : coprod_distributor >-> coprod_distributor_data. End DistributionThroughFunctor. Section DistributionForPrecompositionFunctor. Context {I : UU} {A B C : category} (CPC : Coproducts I C) (H : functor A B). Let CPAC : Coproducts I [A,C] := Coproducts_functor_precat I A C CPC. Let CPBC : Coproducts I [B,C] := Coproducts_functor_precat I B C CPC. Let precomp : functor [B,C] [A,C] := pre_composition_functor A B C H. Definition precomp_coprod_distributor_data : coprod_distributor_data CPBC CPAC precomp. Proof. intro Gs. apply nat_trans_id. Defined. Lemma precomp_coprod_distributor_law : coprod_distributor_iso_law _ _ _ precomp_coprod_distributor_data. Proof. intros Gs. split. - apply (nat_trans_eq C). intro c. cbn. rewrite id_left. apply pathsinv0, Coproduct_endo_is_identity. intro i. unfold coproduct_nat_trans_data. cbn in Gs. apply (CoproductInCommutes I C (λ i0 : I, Gs i0 (H c)) (CPC _) _ (λ i0 : I, coproduct_nat_trans_in_data I B C CPC Gs i0 (H c)) i). - etrans. { apply postcompWithCoproductArrow. } etrans. 2: { apply pathsinv0, CoproductArrowEta. } apply maponpaths; apply funextsec; intro i; (rewrite id_right; apply (nat_trans_eq C); intro c; apply id_right). Qed. Definition precomp_coprod_distributor : coprod_distributor CPBC CPAC precomp := _,,precomp_coprod_distributor_law. End DistributionForPrecompositionFunctor. (** Coproducts are unique *) Definition eq_Coproduct {C : category} {J : UU} {D : J → C} (coprod₁ coprod₂ : Coproduct J C D) (q : CoproductObject _ _ coprod₁ = CoproductObject _ _ coprod₂) (e : ∏ (j : J), CoproductIn _ _ coprod₁ j = CoproductIn _ _ coprod₂ j · idtoiso (!q)) : coprod₁ = coprod₂. Proof. use subtypePath. { intro. repeat (use impred ; intro). use isapropiscontr. } use total2_paths_f. - exact q. - rewrite transportf_sec_constant. use funextsec. intro j. rewrite <- !idtoiso_postcompose. pose (p := e j). rewrite !idtoiso_inv in p. refine (maponpaths (λ z, z · _) p @ _). rewrite !assoc'. refine (_ @ id_right _). apply maponpaths. apply z_iso_after_z_iso_inv. Qed. Definition z_iso_between_Coproduct {C : category} {J : UU} {D : J → C} (coprod₁ coprod₂ : Coproduct J C D) : z_iso coprod₁ coprod₂. Proof. use make_z_iso. - exact (CoproductArrow _ _ coprod₁ (CoproductIn _ _ coprod₂)). - exact (CoproductArrow _ _ coprod₂ (CoproductIn _ _ coprod₁)). - split. + abstract (use CoproductArrow_eq ; intro j ; rewrite !assoc ; rewrite !CoproductInCommutes ; rewrite id_right ; apply idpath). + abstract (use CoproductArrow_eq ; intro j ; rewrite !assoc ; rewrite !CoproductInCommutes ; rewrite id_right ; apply idpath). Defined. Definition isaprop_Coproduct {C : category} (HC : is_univalent C) (J : UU) (D : J → C) : isaprop (Coproduct J C D). Proof. use invproofirrelevance. intros p₁ p₂. use eq_Coproduct. - refine (isotoid _ HC _). apply z_iso_between_Coproduct. - intro j. rewrite idtoiso_inv. rewrite idtoiso_isotoid ; cbn. rewrite CoproductInCommutes. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/limits/equalizers.v000066400000000000000000000351261451125700300235070ustar00rootroot00000000000000(** Direct implementation of equalizers together with: - Definition - Proof that the equalizer arrow is monic ([EqualizerArrowisMonic]) - Proof that the equalizer arrow of equal morphism is an isomorphism ([z_iso_Equalizer_of_same_map]) - Alternative universal property Written by Tomi Pannila Extended by Langston Barrett (Nov 2018) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.Monics. (** ** Definition *) Section def_equalizers. Context {C : category}. (** Definition and construction of isEqualizer. *) Definition isEqualizer {x y z : C} (f g : y --> z) (e : x --> y) (H : e · f = e · g) : UU := ∏ (w : C) (h : w --> y) (H : h · f = h · g), ∃! φ : w --> x, φ · e = h. Definition make_isEqualizer {x y z : C} (f g : y --> z) (e : x --> y) (H : e · f = e · g) : (∏ (w : C) (h : w --> y) (H' : h · f = h · g), ∃! ψ : w --> x, ψ · e = h) -> isEqualizer f g e H. Proof. intros X. unfold isEqualizer. exact X. Defined. Lemma isaprop_isEqualizer {x y z : C} (f g : y --> z) (e : x --> y) (H : e · f = e · g) : isaprop (isEqualizer f g e H). Proof. repeat (apply impred; intro). apply isapropiscontr. Defined. Lemma isEqualizer_path {hs : has_homsets C} {x y z : C} {f g : y --> z} {e : x --> y} {H H' : e · f = e · g} (iC : isEqualizer f g e H) : isEqualizer f g e H'. Proof. use make_isEqualizer. intros w0 h H'0. use unique_exists. - exact (pr1 (pr1 (iC w0 h H'0))). - exact (pr2 (pr1 (iC w0 h H'0))). - intros y0. apply hs. - intros y0 X. exact (base_paths _ _ (pr2 (iC w0 h H'0) (tpair _ y0 X))). Defined. (** Proves that the arrow to the equalizer object with the right commutativity property is unique. *) Lemma isEqualizerInUnique {x y z : C} (f g : y --> z) (e : x --> y) (H : e · f = e · g) (E : isEqualizer f g e H) (w : C) (h : w --> y) (H' : h · f = h · g) (φ : w --> x) (H'' : φ · e = h) : φ = (pr1 (pr1 (E w h H'))). Proof. set (T := tpair (fun ψ : w --> x => ψ · e = h) φ H''). set (T' := pr2 (E w h H') T). apply (base_paths _ _ T'). Defined. (** Definition and construction of equalizers. *) Definition Equalizer {y z : C} (f g : y --> z) : UU := ∑ e : (∑ w : C, w --> y), (∑ H : (pr2 e) · f = (pr2 e) · g, isEqualizer f g (pr2 e) H). Definition make_Equalizer {x y z : C} (f g : y --> z) (e : x --> y) (H : e · f = e · g) (isE : isEqualizer f g e H) : Equalizer f g. Proof. use tpair. - use tpair. + apply x. + apply e. - simpl. exact (tpair _ H isE). Defined. (** Equalizers in precategories. *) Definition Equalizers : UU := ∏ (y z : C) (f g : y --> z), Equalizer f g. Definition hasEqualizers : UU := ∏ (y z : C) (f g : y --> z), ishinh (Equalizer f g). (** Returns the equalizer object. *) Definition EqualizerObject {y z : C} {f g : y --> z} (E : Equalizer f g) : C := pr1 (pr1 E). Coercion EqualizerObject : Equalizer >-> ob. (** Returns the equalizer arrow. *) Definition EqualizerArrow {y z : C} {f g : y --> z} (E : Equalizer f g) : C⟦E, y⟧ := pr2 (pr1 E). (** The equality on morphisms that equalizers must satisfy. *) Definition EqualizerEqAr {y z : C} {f g : y --> z} (E : Equalizer f g) : EqualizerArrow E · f = EqualizerArrow E · g := pr1 (pr2 E). (** Returns the property isEqualizer from Equalizer. *) Definition isEqualizer_Equalizer {y z : C} {f g : y --> z} (E : Equalizer f g) : isEqualizer f g (EqualizerArrow E) (EqualizerEqAr E) := pr2 (pr2 E). (** Every morphism which satisfy the equalizer equality on morphism factors uniquely through the EqualizerArrow. *) Definition EqualizerIn {y z : C} {f g : y --> z} (E : Equalizer f g) (w : C) (h : w --> y) (H : h · f = h · g) : C⟦w, E⟧ := pr1 (pr1 (isEqualizer_Equalizer E w h H)). Lemma EqualizerCommutes {y z : C} {f g : y --> z} (E : Equalizer f g) (w : C) (h : w --> y) (H : h · f = h · g) : (EqualizerIn E w h H) · (EqualizerArrow E) = h. Proof. exact (pr2 (pr1 ((isEqualizer_Equalizer E) w h H))). Defined. Lemma isEqualizerInsEq {x y z: C} {f g : y --> z} {e : x --> y} {H : e · f = e · g} (E : isEqualizer f g e H) {w : C} (φ1 φ2: w --> x) (H' : φ1 · e = φ2 · e) : φ1 = φ2. Proof. assert (H'1 : φ1 · e · f = φ1 · e · g). rewrite <- assoc. rewrite H. rewrite assoc. apply idpath. set (E' := make_Equalizer _ _ _ _ E). set (E'ar := EqualizerIn E' w (φ1 · e) H'1). intermediate_path E'ar. apply isEqualizerInUnique. apply idpath. apply pathsinv0. apply isEqualizerInUnique. apply pathsinv0. apply H'. Defined. Lemma EqualizerInsEq {y z: C} {f g : y --> z} (E : Equalizer f g) {w : C} (φ1 φ2: C⟦w, E⟧) (H' : φ1 · (EqualizerArrow E) = φ2 · (EqualizerArrow E)) : φ1 = φ2. Proof. apply (isEqualizerInsEq (isEqualizer_Equalizer E) _ _ H'). Defined. Lemma EqualizerInComp {y z : C} {f g : y --> z} (E : Equalizer f g) {x x' : C} (h1 : x --> x') (h2 : x' --> y) (H1 : h1 · h2 · f = h1 · h2 · g) (H2 : h2 · f = h2 · g) : EqualizerIn E x (h1 · h2) H1 = h1 · EqualizerIn E x' h2 H2. Proof. use EqualizerInsEq. rewrite EqualizerCommutes. rewrite <- assoc. rewrite EqualizerCommutes. apply idpath. Qed. (** Morphisms between equalizer objects with the right commutativity equalities. *) Definition identity_is_EqualizerIn {y z : C} {f g : y --> z} (E : Equalizer f g) : ∑ φ : C⟦E, E⟧, φ · (EqualizerArrow E) = (EqualizerArrow E). Proof. exists (identity E). apply id_left. Defined. Lemma EqualizerEndo_is_identity {y z : C} {f g : y --> z} {E : Equalizer f g} (φ : C⟦E, E⟧) (H : φ · (EqualizerArrow E) = EqualizerArrow E) : identity E = φ. Proof. set (H1 := tpair ((fun φ' : C⟦E, E⟧ => φ' · _ = _)) φ H). assert (H2 : identity_is_EqualizerIn E = H1). - apply proofirrelevancecontr. apply (isEqualizer_Equalizer E). apply EqualizerEqAr. - apply (base_paths _ _ H2). Defined. Definition from_Equalizer_to_Equalizer {y z : C} {f g : y --> z} (E E': Equalizer f g) : C⟦E, E'⟧. Proof. apply (EqualizerIn E' E (EqualizerArrow E)). apply EqualizerEqAr. Defined. Lemma are_inverses_from_Equalizer_to_Equalizer {y z : C} {f g : y --> z} {E E': Equalizer f g} : is_inverse_in_precat (from_Equalizer_to_Equalizer E E') (from_Equalizer_to_Equalizer E' E). Proof. split; apply pathsinv0; use EqualizerEndo_is_identity; rewrite <- assoc; unfold from_Equalizer_to_Equalizer; repeat rewrite EqualizerCommutes; apply idpath. Defined. Lemma isiso_from_Equalizer_to_Equalizer {y z : C} {f g : y --> z} (E E' : Equalizer f g) : is_iso (from_Equalizer_to_Equalizer E E'). Proof. apply (is_iso_qinv _ (from_Equalizer_to_Equalizer E' E)). apply are_inverses_from_Equalizer_to_Equalizer. Defined. Definition iso_from_Equalizer_to_Equalizer {y z : C} {f g : y --> z} (E E' : Equalizer f g) : iso E E' := tpair _ _ (isiso_from_Equalizer_to_Equalizer E E'). Lemma z_iso_from_Equalizer_to_Equalizer_inverses {y z : C} {f g : y --> z} (E E' : Equalizer f g) : is_inverse_in_precat (from_Equalizer_to_Equalizer E E') (from_Equalizer_to_Equalizer E' E). Proof. use make_is_inverse_in_precat. - apply pathsinv0. use EqualizerEndo_is_identity. rewrite <- assoc. unfold from_Equalizer_to_Equalizer. rewrite EqualizerCommutes. rewrite EqualizerCommutes. apply idpath. - apply pathsinv0. use EqualizerEndo_is_identity. rewrite <- assoc. unfold from_Equalizer_to_Equalizer. rewrite EqualizerCommutes. rewrite EqualizerCommutes. apply idpath. Qed. Definition z_iso_from_Equalizer_to_Equalizer {y z : C} {f g : y --> z} (E E' : Equalizer f g) : z_iso E E'. Proof. use make_z_iso. - exact (from_Equalizer_to_Equalizer E E'). - exact (from_Equalizer_to_Equalizer E' E). - exact (z_iso_from_Equalizer_to_Equalizer_inverses E E'). Defined. (** ** Proof that the equalizer arrow is monic ([EqualizerArrowisMonic]) *) (** We prove that EqualizerArrow is a monic. *) Lemma EqualizerArrowisMonic {y z : C} {f g : y --> z} (E : Equalizer f g ) : isMonic (EqualizerArrow E). Proof. apply make_isMonic. intros z0 g0 h X. apply (EqualizerInsEq E). apply X. Qed. Lemma EqualizerArrowMonic {y z : C} {f g : y --> z} (E : Equalizer f g ) : Monic _ E y. Proof. exact (make_Monic C (EqualizerArrow E) (EqualizerArrowisMonic E)). Defined. (*Definition of the trivial equalizer of f and f*) Definition identity_asEqualizer {y z : C} (f : y --> z) : (Equalizer f f). Proof. use make_Equalizer. + exact y. + exact (identity y). + apply idpath. + use make_isEqualizer. intros x h p. use unique_exists. - exact h. - use id_right. - intro. use homset_property. - intros t t_tri. rewrite <-(id_right t). exact t_tri. Defined. (* The equalizer is a z-isomorphism if f = g *) Lemma z_iso_Equalizer_of_same_map {y z : C} {f g : y --> z} (E : Equalizer f g) (p:f = g) : is_z_isomorphism (EqualizerArrow E). Proof. induction p. use (make_is_z_isomorphism _ (from_Equalizer_to_Equalizer (identity_asEqualizer f) E)). use z_iso_from_Equalizer_to_Equalizer_inverses. Defined. End def_equalizers. (** Make the C not implicit for Equalizers *) Arguments Equalizers : clear implicits. (** ** Alternative universal property *) Section Equalizers'. Context {C : category} {c d : ob C} (f g : C⟦c, d⟧). Context (E : ob C) (h : E --> c) (H : h · f = h · g). (** A map into an equalizer can be turned into a map into [c] such that its composites with [f] and [g] are equal. *) Definition postcomp_with_equalizer_mor (a : ob C) (j : a --> E) : ∑ (k : a --> c), (k · f = k · g). Proof. exists (j · h). refine (!assoc _ _ _ @ _). refine (_ @ assoc _ _ _). apply maponpaths. assumption. Defined. Definition isEqualizer' : UU := ∏ (a : ob C), isweq (postcomp_with_equalizer_mor a). Definition isEqualizer'_weq (is : isEqualizer') : ∏ a, (a --> E) ≃ (∑ k : a --> c, (k · f = k · g)) := λ a, make_weq (postcomp_with_equalizer_mor a) (is a). Lemma isaprop_isEqualizer' : isaprop isEqualizer'. Proof. unfold isEqualizer'. apply impred; intro. apply isapropisweq. Qed. (** Can [isEqualizer'_to_isEqualizer] be generalized to arbitrary precategories? Compare to [isBinProduct'_to_isBinProduct]. *) Lemma isEqualizer'_to_isEqualizer : isEqualizer' -> isEqualizer f g h H. Proof. intros isEq' E' h' H'. apply (@iscontrweqf (hfiber (isEqualizer'_weq isEq' _) (h',, H'))). - cbn; unfold hfiber. use weqfibtototal; intros j; cbn. unfold postcomp_with_equalizer_mor. apply subtypeInjectivity. intro; apply C. - apply weqproperty. Defined. Lemma isEqualizer_to_isEqualizer' : isEqualizer f g h H -> isEqualizer'. Proof. intros isEq E'. unfold postcomp_with_equalizer_mor. unfold isweq, hfiber. intros hH'. apply (@iscontrweqf (∑ u : C ⟦ E', E ⟧, u · h = pr1 hH')). - use weqfibtototal; intro; cbn. apply invweq. use subtypeInjectivity. intro; apply C. - exact (isEq E' (pr1 hH') (pr2 hH')). Defined. Lemma isEqualizer'_weq_isEqualizer : isEqualizer f g h H ≃ isEqualizer'. Proof. apply weqimplimpl. - apply isEqualizer_to_isEqualizer'; assumption. - apply isEqualizer'_to_isEqualizer; assumption. - apply isaprop_isEqualizer. - apply isaprop_isEqualizer'. Qed. End Equalizers'. Definition isEqualizer_eq {C : category} {e x y : C} {f g f' g' : x --> y} {i i' : e --> x} (p : i · f = i · g) (q : i' · f' = i' · g') (s₁ : f = f') (s₂ : g = g') (s₃ : i = i') (He : isEqualizer f g i p) : isEqualizer f' g' i' q. Proof. intros w h r. use iscontraprop1. - abstract (induction s₁, s₂, s₃ ; apply (isapropifcontr (He w h r))). - simple refine (_ ,, _). + refine (EqualizerIn (make_Equalizer _ _ _ _ He) _ h _). abstract (induction s₁, s₂ ; exact r). + abstract (cbn ; induction s₁, s₂, s₃ ; apply (EqualizerCommutes (make_Equalizer _ _ _ _ He))). Defined. (** Equalizers are closed under iso *) Definition isEqualizer_z_iso {C : category} {e₁ e₂ x y : C} {f g : x --> y} {p₁ : e₁ --> x} {q₁ : p₁ · f = p₁ · g} {p₂ : e₂ --> x} {q₂ : p₂ · f = p₂ · g} (H : isEqualizer f g p₁ q₁) (h : z_iso e₂ e₁) (r : p₂ = h · p₁) : isEqualizer f g p₂ q₂. Proof. intros a k s. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; apply homset_property | ] ; use (cancel_z_iso _ _ h) ; use (isEqualizerInsEq H) ; rewrite !assoc' ; rewrite <- !r ; exact (pr2 φ₁ @ !(pr2 φ₂))). - refine (EqualizerIn (make_Equalizer _ _ _ _ H) _ k s · inv_from_z_iso h ,, _). abstract (rewrite r ; rewrite !assoc' ; rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)) ; refine (maponpaths (λ z, _ · (z · _)) (z_iso_after_z_iso_inv h) @ _) ; rewrite id_left ; apply (EqualizerCommutes (make_Equalizer _ _ _ _ H))). Defined. (** In univalent categories, equalizers are unique up to equality *) Proposition isaprop_Equalizer {C : category} (HC : is_univalent C) {x y : C} (f g : x --> y) : isaprop (Equalizer f g). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. use (isaprop_total2 (_ ,, _) (λ _, (_ ,, _))). - apply homset_property. - simpl. repeat (use impred ; intro). apply isapropiscontr. } use total2_paths_f. - use (isotoid _ HC). use z_iso_from_Equalizer_to_Equalizer. - rewrite transportf_isotoid ; cbn. apply EqualizerCommutes. Qed. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/000077500000000000000000000000001451125700300224115ustar00rootroot00000000000000UniMath-20231010/UniMath/CategoryTheory/limits/graphs/README.md000066400000000000000000000030011451125700300236620ustar00rootroot00000000000000graphs ============ This directory contains a development of limits on the basis of descriptions of diagrams by graphs instead of functors. It is often better to use the direct implementation of specific limits in the parent folder for efficiency reasons. For instance we have noticed that changing the proof that binary (co)products lift to functor categories to the general one for limits makes the compilation of SubstitutionSystems very slow. ## Contents * *colimits.v* * definition of graph and diagram * formalization of colimits on this basis * rules for pre- and post-composition * pointwise construction of colimits in functor precategories * *limits.v* * formalization of limits on the basis of graphs * proof that limits form a property in a (saturated/univalent) category * pointwise construction of limits in functor precategories * alternative definition of limits via colimits * *initial.v* --- definition as instance of colimit * *terminal.v* --- definition as instance of limit * *binproducts.v* --- formalization as instance of limit * *bincoproducts.v* --- formalization as instance of colimit * *pullbacks.v* --- formalization as instance of limit * *pushouts.v* --- formalization as instance of colimit * *equalizers.v* --- formalization as instance of limit * *coequalizers.v* --- formalization as instance of colimit * *kernels.v* --- formalization as instance of limit * *cokernels.v* --- formalization as instance of colimit * *zero.v* --- formalization within the approach of this directory UniMath-20231010/UniMath/CategoryTheory/limits/graphs/bincoproducts.v000066400000000000000000000255631451125700300254710ustar00rootroot00000000000000(** ****************************************** Binary coproducts defined as a colimit Written by: Benedikt Ahrens, March 2015 *********************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.eqdiag. Require Import UniMath.CategoryTheory.limits.bincoproducts. Local Open Scope cat. (** * Definition of binary coproduct of objects in a precategory *) Definition two_graph : graph. Proof. exists bool. exact (λ _ _, empty). Defined. Definition bincoproduct_diagram {C : category} (a b : C) : diagram two_graph C. Proof. exists (λ x : bool, if x then a else b). intros u v F. induction F. Defined. Definition CopCocone {C : category} {a b : C} {c : C} (ac : a --> c) (bc : b --> c) : cocone (bincoproduct_diagram a b) c. Proof. use tpair. + intro v. induction v; simpl. - exact ac. - exact bc. + intros u v e; induction e. Defined. Section bincoproduct_def. Variable C : category. Definition isBinCoproductCocone (a b co : C) (ia : a --> co) (ib : b --> co) := isColimCocone (bincoproduct_diagram a b) co (CopCocone ia ib). Definition make_isBinCoproductCocone (hsC : has_homsets C)(a b co : C) (ia : a --> co) (ib : b --> co) : (∏ (c : C) (f : a --> c) (g : b --> c), ∃! k : C ⟦co, c⟧, ia · k = f × ib · k = g) → isBinCoproductCocone a b co ia ib. Proof. intros H c cc. set (H':= H c (coconeIn cc true) (coconeIn cc false)). use tpair. - exists (pr1 (pr1 H')). set (T := pr2 (pr1 H')). simpl in T. abstract (intro u; induction u; [ apply (pr1 T) | apply (pr2 T)]). - simpl. intros. abstract (intros; apply subtypePath; [ intro; apply impred; intro; apply hsC | apply path_to_ctr; split; [ apply (pr2 t true) | apply (pr2 t false)] ]). Defined. Definition BinCoproductCocone (a b : C) := ColimCocone (bincoproduct_diagram a b). Definition make_BinCoproductCocone (a b : C) : ∏ (c : C) (f : a --> c) (g : b --> c), isBinCoproductCocone _ _ _ f g → BinCoproductCocone a b. Proof. intros. use tpair. - exists c. apply (CopCocone f g). - apply X. Defined. Definition BinCoproducts := ∏ (a b : C), BinCoproductCocone a b. Definition hasBinCoproducts := ∏ (a b : C), ∥ BinCoproductCocone a b ∥. Definition BinCoproductObject {a b : C} (CC : BinCoproductCocone a b) : C := colim CC. Definition BinCoproductIn1 {a b : C} (CC : BinCoproductCocone a b): a --> BinCoproductObject CC := colimIn CC true. Definition BinCoproductIn2 {a b : C} (CC : BinCoproductCocone a b) : b --> BinCoproductObject CC := colimIn CC false. Definition BinCoproductArrow {a b : C} (CC : BinCoproductCocone a b) {c : C} (f : a --> c) (g : b --> c) : BinCoproductObject CC --> c. Proof. apply (colimArrow CC). use make_cocone. + intro v. induction v. - apply f. - apply g. + simpl. intros ? ? e; induction e. Defined. Lemma BinCoproductIn1Commutes (a b : C) (CC : BinCoproductCocone a b): ∏ (c : C) (f : a --> c) g, BinCoproductIn1 CC · BinCoproductArrow CC f g = f. Proof. intros c f g. unfold BinCoproductIn1. set (H:=colimArrowCommutes CC _ (CopCocone f g) true). apply H. Qed. Lemma BinCoproductIn2Commutes (a b : C) (CC : BinCoproductCocone a b): ∏ (c : C) (f : a --> c) g, BinCoproductIn2 CC · BinCoproductArrow CC f g = g. Proof. intros c f g. unfold BinCoproductIn1. set (H:=colimArrowCommutes CC _ (CopCocone f g) false). apply H. Qed. Lemma BinCoproductArrowUnique (a b : C) (CC : BinCoproductCocone a b) (x : C) (f : a --> x) (g : b --> x) (k : BinCoproductObject CC --> x) : BinCoproductIn1 CC · k = f → BinCoproductIn2 CC · k = g → k = BinCoproductArrow CC f g. Proof. intros H1 H2. use colimArrowUnique. simpl. intro u; induction u; simpl. - apply H1. - apply H2. Qed. Lemma BinCoproductArrowEta (a b : C) (CC : BinCoproductCocone a b) (x : C) (f : BinCoproductObject CC --> x) : f = BinCoproductArrow CC (BinCoproductIn1 CC · f) (BinCoproductIn2 CC · f). Proof. apply BinCoproductArrowUnique; apply idpath. Qed. Definition BinCoproductOfArrows {a b : C} (CCab : BinCoproductCocone a b) {c d : C} (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) : BinCoproductObject CCab --> BinCoproductObject CCcd := BinCoproductArrow CCab (f · BinCoproductIn1 CCcd) (g · BinCoproductIn2 CCcd). Lemma BinCoproductOfArrowsIn1 {a b : C} (CCab : BinCoproductCocone a b) {c d : C} (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) : BinCoproductIn1 CCab · BinCoproductOfArrows CCab CCcd f g = f · BinCoproductIn1 CCcd. Proof. unfold BinCoproductOfArrows. apply BinCoproductIn1Commutes. Qed. Lemma BinCoproductOfArrowsIn2 {a b : C} (CCab : BinCoproductCocone a b) {c d : C} (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) : BinCoproductIn2 CCab · BinCoproductOfArrows CCab CCcd f g = g · BinCoproductIn2 CCcd. Proof. unfold BinCoproductOfArrows. apply BinCoproductIn2Commutes. Qed. Lemma precompWithBinCoproductArrow {a b : C} (CCab : BinCoproductCocone a b) {c d : C} (CCcd : BinCoproductCocone c d) (f : a --> c) (g : b --> d) {x : C} (k : c --> x) (h : d --> x) : BinCoproductOfArrows CCab CCcd f g · BinCoproductArrow CCcd k h = BinCoproductArrow CCab (f · k) (g · h). Proof. apply BinCoproductArrowUnique. - rewrite assoc. rewrite BinCoproductOfArrowsIn1. rewrite <- assoc, BinCoproductIn1Commutes. apply idpath. - rewrite assoc, BinCoproductOfArrowsIn2. rewrite <- assoc, BinCoproductIn2Commutes. apply idpath. Qed. Lemma postcompWithBinCoproductArrow {a b : C} (CCab : BinCoproductCocone a b) {c : C} (f : a --> c) (g : b --> c) {x : C} (k : c --> x) : BinCoproductArrow CCab f g · k = BinCoproductArrow CCab (f · k) (g · k). Proof. apply BinCoproductArrowUnique. - rewrite assoc, BinCoproductIn1Commutes; apply idpath. - rewrite assoc, BinCoproductIn2Commutes; apply idpath. Qed. End bincoproduct_def. Arguments BinCoproductCocone [_] _ _. Arguments BinCoproductObject [_ _ _] _ . Arguments BinCoproductArrow [_ _ _] _ [_] _ _. Arguments BinCoproductIn1 [_ _ _] _. Arguments BinCoproductIn2 [_ _ _] _. (** * Proof that coproducts are unique when the precategory [C] is a univalent_category *) Section coproduct_unique. Variable C : category. Hypothesis H : is_univalent C. Variables a b : C. Definition from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b) : BinCoproductObject CC --> BinCoproductObject CC'. Proof. apply (BinCoproductArrow CC (BinCoproductIn1 _ ) (BinCoproductIn2 _ )). Defined. Lemma BinCoproduct_endo_is_identity (CC : BinCoproductCocone a b) (k : BinCoproductObject CC --> BinCoproductObject CC) (H1 : BinCoproductIn1 CC · k = BinCoproductIn1 CC) (H2 : BinCoproductIn2 CC · k = BinCoproductIn2 CC) : identity _ = k. Proof. (* apply pathsinv0. *) use colim_endo_is_identity. intro u; induction u; simpl; assumption. Defined. Lemma is_z_iso_from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b) : is_z_isomorphism (from_BinCoproduct_to_BinCoproduct CC CC'). Proof. exists (from_BinCoproduct_to_BinCoproduct CC' CC). split; simpl. - apply pathsinv0. apply BinCoproduct_endo_is_identity. + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn1Commutes. rewrite BinCoproductIn1Commutes. apply idpath. + rewrite assoc. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn2Commutes. rewrite BinCoproductIn2Commutes. apply idpath. - apply pathsinv0. apply BinCoproduct_endo_is_identity. + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct. repeat rewrite BinCoproductIn1Commutes; apply idpath. + rewrite assoc; unfold from_BinCoproduct_to_BinCoproduct. repeat rewrite BinCoproductIn2Commutes; apply idpath. Defined. Definition z_iso_from_BinCoproduct_to_BinCoproduct (CC CC' : BinCoproductCocone a b) : z_iso (BinCoproductObject CC) (BinCoproductObject CC') := make_z_iso' _ (is_z_iso_from_BinCoproduct_to_BinCoproduct CC CC'). (* should be an instance of a lemma about colimits *) (* Lemma isaprop_BinCoproductCocone : isaprop (BinCoproductCocone a b). Proof. apply invproofirrelevance. intros CC CC'. apply subtypePath. + intros. unfold isColimCocone. do 2 (apply impred; intro); apply isapropiscontr. + apply (total2_paths_f (isotoid _ H (iso_from_BinCoproduct_to_BinCoproduct CC CC'))). rewrite transportf_dirprod. rewrite transportf_isotoid'. simpl. rewrite transportf_isotoid'. destruct CC as [CC bla]. destruct CC' as [CC' bla']; simpl in *. destruct CC as [CC [CC1 CC2]]. destruct CC' as [CC' [CC1' CC2']]; simpl in *. unfold from_BinCoproduct_to_BinCoproduct. rewrite BinCoproductIn1Commutes. rewrite BinCoproductIn2Commutes. apply idpath. Qed. *) End coproduct_unique. Definition limits_isBinCoproductCocone_from_isBinCoproduct (C : category) {a b c} (u : C ⟦ a, c⟧)(v : C ⟦ b, c⟧) : limits.bincoproducts.isBinCoproduct C a b c u v -> isBinCoproductCocone _ _ _ _ u v := make_isBinCoproductCocone _ C _ _ _ _ _. Lemma limits_isBinCoproduct_from_isBinCoproductCocone (C : category) {a b c} (u : C ⟦ a, c⟧)(v : C ⟦ b, c⟧) : isBinCoproductCocone _ _ _ _ u v -> limits.bincoproducts.isBinCoproduct C a b c u v. Proof. intro h. set (CC := make_BinCoproductCocone _ _ _ _ _ _ h); simpl. intros x f g. (* set (CCfg := (bincoproducts.BinCoproductArrow C CC f g)). *) use unique_exists; simpl. - apply (bincoproducts.BinCoproductArrow CC f g). - abstract (split; [ apply (bincoproducts.BinCoproductIn1Commutes _ _ _ CC) | apply (bincoproducts.BinCoproductIn2Commutes _ _ _ CC)]). - abstract (intros h'; apply isapropdirprod; apply C). - intros h' [H1 H2]. eapply (bincoproducts.BinCoproductArrowUnique _ _ _ CC). + exact H1. + exact H2. Defined. Lemma BinCoproducts_from_Colims (C : category) : Colims_of_shape two_graph C -> BinCoproducts C. Proof. now intros H a b; apply H. Defined. (** Post-composing a bincoproduct diagram with a functor yields a bincoproduct diagram. *) Lemma mapdiagram_bincoproduct_eq_diag {C : category}{D : category} (F : functor C D)(a b : C) : eq_diag (C := D) (mapdiagram F (bincoproducts.bincoproduct_diagram a b)) (bincoproducts.bincoproduct_diagram (F a) (F b)). Proof. use tpair. - use bool_rect; apply idpath. - intros ??; use empty_rect. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/binproducts.v000066400000000000000000000134311451125700300251360ustar00rootroot00000000000000(** Binary products via limits *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Local Open Scope cat. Section binproduct_def. Variable (C : category). Definition two_graph : graph. Proof. exists bool. exact (λ _ _, empty). Defined. Definition binproduct_diagram (a b : C) : diagram two_graph C. Proof. exists (λ x : bool, if x then a else b). intros u v F. induction F. Defined. Definition ProdCone {a b c : C} (ca : C⟦c,a⟧) (cb : C⟦c,b⟧) : cone (binproduct_diagram a b) c. Proof. use tpair; simpl. - intro v; induction v. + exact ca. + exact cb. - intros u v e; induction e. Defined. Definition isBinProductCone (c d p : C) (p1 : C⟦p,c⟧) (p2 : C⟦p,d⟧) := isLimCone (binproduct_diagram c d) p (ProdCone p1 p2). Definition make_isBinProductCone (hsC : has_homsets C) (a b p : C) (pa : C⟦p,a⟧) (pb : C⟦p,b⟧) : (∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), ∃! k : C⟦c,p⟧, k · pa = f × k · pb = g) -> isBinProductCone a b p pa pb. Proof. intros H c cc. simpl in *. set (H' := H c (coneOut cc true) (coneOut cc false)). use tpair. - exists (pr1 (pr1 H')). set (T := pr2 (pr1 H')); simpl in T. abstract (intro u; induction u; simpl; [exact (pr1 T)|exact (pr2 T)]). - abstract (simpl; intros; apply subtypePath; [intro; apply impred;intro; apply hsC|]; simpl; apply path_to_ctr; split; [ apply (pr2 t true) | apply (pr2 t false) ]). Defined. Definition BinProductCone (a b : C) := LimCone (binproduct_diagram a b). Definition make_BinProductCone (a b : C) : ∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), isBinProductCone _ _ _ f g -> BinProductCone a b. Proof. intros. use tpair. - exists c. apply (ProdCone f g). - apply X. Defined. Definition BinProducts := ∏ (a b : C), BinProductCone a b. Definition hasBinProducts := ∏ (a b : C), ∥ BinProductCone a b ∥. Definition BinProductObject {c d : C} (P : BinProductCone c d) : C := lim P. Definition BinProductPr1 {c d : C} (P : BinProductCone c d): C⟦BinProductObject P,c⟧ := limOut P true. Definition BinProductPr2 {c d : C} (P : BinProductCone c d) : C⟦BinProductObject P,d⟧ := limOut P false. (* Definition isBinProductCone_BinProductCone {c d : C} (P : BinProductCone c d) : *) (* isBinProductCone c d (BinProductObject P) (BinProductPr1 P) (BinProductPr2 P). *) Definition BinProductArrow {a b : C} (P : BinProductCone a b) {c : C} (f : C⟦c,a⟧) (g : C⟦c,b⟧) : C⟦c,BinProductObject P⟧. Proof. apply (limArrow P). use make_cone. - intro v; induction v; [ apply f | apply g ]. - intros ? ? e; induction e. (* <- should not be opaque! otherwise BinProductPr1Commutes doesn't work *) Defined. Lemma BinProductPr1Commutes (a b : C) (P : BinProductCone a b): ∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), BinProductArrow P f g · BinProductPr1 P = f. Proof. intros c f g. apply (limArrowCommutes P c (ProdCone f g) true). Qed. Lemma BinProductPr2Commutes (a b : C) (P : BinProductCone a b): ∏ (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧), BinProductArrow P f g · BinProductPr2 P = g. Proof. intros c f g. apply (limArrowCommutes P c (ProdCone f g) false). Qed. Lemma BinProductArrowUnique (a b : C) (P : BinProductCone a b) (c : C) (f : C⟦c,a⟧) (g : C⟦c,b⟧) (k : C⟦c,BinProductObject P⟧) : k · BinProductPr1 P = f -> k · BinProductPr2 P = g -> k = BinProductArrow P f g. Proof. intros H1 H2. use limArrowUnique; simpl. now intro u; induction u; simpl; [ apply H1 | apply H2 ]. Qed. Lemma BinProductArrowEta (a b : C) (P : BinProductCone a b) (c : C) (f : C⟦c,BinProductObject P⟧) : f = BinProductArrow P (f · BinProductPr1 P) (f · BinProductPr2 P). Proof. now apply BinProductArrowUnique. Qed. Definition BinProductOfArrows {c d : C} (Pcd : BinProductCone c d) {a b : C} (Pab : BinProductCone a b) (f : C⟦a,c⟧) (g : C⟦b,d⟧) : C⟦BinProductObject Pab,BinProductObject Pcd⟧ := BinProductArrow Pcd (BinProductPr1 Pab · f) (BinProductPr2 Pab · g). Lemma BinProductOfArrowsPr1 {c d : C} (Pcd : BinProductCone c d) {a b : C} (Pab : BinProductCone a b) (f : C⟦a,c⟧) (g : C⟦b,d⟧) : BinProductOfArrows Pcd Pab f g · BinProductPr1 Pcd = BinProductPr1 Pab · f. Proof. now apply BinProductPr1Commutes. Qed. Lemma BinProductOfArrowsPr2 {c d : C} (Pcd : BinProductCone c d) {a b : C} (Pab : BinProductCone a b) (f : C⟦a,c⟧) (g : C⟦b,d⟧) : BinProductOfArrows Pcd Pab f g · BinProductPr2 Pcd = BinProductPr2 Pab · g. Proof. now apply BinProductPr2Commutes. Qed. Lemma postcompWithBinProductArrow {c d : C} (Pcd : BinProductCone c d) {a b : C} (Pab : BinProductCone a b) (f : C⟦a,c⟧) (g : C⟦b,d⟧) {x : C} (k : C⟦x,a⟧) (h : C⟦x,b⟧) : BinProductArrow Pab k h · BinProductOfArrows Pcd Pab f g = BinProductArrow Pcd (k · f) (h · g). Proof. apply BinProductArrowUnique. - now rewrite <- assoc, BinProductOfArrowsPr1, assoc, BinProductPr1Commutes. - now rewrite <- assoc, BinProductOfArrowsPr2, assoc, BinProductPr2Commutes. Qed. Lemma precompWithBinProductArrow {c d : C} (Pcd : BinProductCone c d) {a : C} (f : C⟦a,c⟧) (g : C⟦a,d⟧) {x : C} (k : C⟦x,a⟧) : k · BinProductArrow Pcd f g = BinProductArrow Pcd (k · f) (k · g). Proof. apply BinProductArrowUnique. - now rewrite <- assoc, BinProductPr1Commutes. - now rewrite <- assoc, BinProductPr2Commutes. Qed. End binproduct_def. Lemma BinProducts_from_Lims (C : category) : Lims_of_shape two_graph C -> BinProducts C. Proof. now intros H a b; apply H. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/coequalizers.v000066400000000000000000000316211451125700300253110ustar00rootroot00000000000000(** * Coequalizers defined in terms of colimits *) (** ** Contents - Definition of coequalizers - Coincides with the direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.eqdiag. Require Import UniMath.CategoryTheory.limits.coequalizers. Local Open Scope cat. (** * Definition of coequalizers in terms of colimits *) Section def_coequalizers. Variable C : category. Local Open Scope stn. Definition One : two := ● 0. Definition Two : two := ● 1. Definition Coequalizer_graph : graph. Proof. exists two. use (@two_rec (two -> UU)). - apply two_rec. + apply empty. + apply (unit ⨿ unit). - apply (λ _, empty). Defined. Definition Coequalizer_diagram {a b : C} (f g : C⟦a, b⟧) : diagram Coequalizer_graph C. Proof. exists (two_rec a b). use two_rec_dep. - use two_rec_dep; simpl. + apply fromempty. + intro x. induction x. exact f. exact g. - intro. apply fromempty. Defined. Definition Coequalizer_cocone {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧) (H : f · h = g · h) : cocone (Coequalizer_diagram f g) d. Proof. use make_cocone. - use two_rec_dep. + exact (f · h). + exact h. - use two_rec_dep; use two_rec_dep. + exact (empty_rect _). + intro e. induction e. * apply idpath. * apply (! H). + exact (empty_rect _). + exact (empty_rect _). Defined. Definition isCoequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧) (H : f · h = g · h) : UU := isColimCocone (Coequalizer_diagram f g) d (Coequalizer_cocone f g d h H). Definition make_isCoequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧) (H : f · h = g · h) : (∏ e (h' : C⟦b, e⟧) (H' : f · h' = g · h'), iscontr (total2 (fun hk : C⟦d, e⟧ => h · hk = h'))) -> isCoequalizer f g d h H. Proof. intros H' x cx. assert (H1 : f · coconeIn cx Two = g · coconeIn cx Two). { use (pathscomp0 (coconeInCommutes cx One Two (ii1 tt))). use (pathscomp0 _ (!(coconeInCommutes cx One Two (ii2 tt)))). apply idpath. } set (H2 := (H' x (coconeIn cx Two) H1)). use tpair. - use (tpair _ (pr1 (pr1 H2)) _). use two_rec_dep. + use (pathscomp0 _ (coconeInCommutes cx One Two (ii1 tt))). change (coconeIn (Coequalizer_cocone f g d h H) _) with (f · h). change (dmor _ _) with f. rewrite <- assoc. apply cancel_precomposition, (pr2 (pr1 H2)). + apply (pr2 (pr1 H2)). - abstract (intro t; apply subtypePath; [intros y; apply impred; intros t0; apply C |induction t as [t p]; apply path_to_ctr, (p Two)]). Defined. Definition Coequalizer {a b : C} (f g : C⟦a, b⟧) : UU := ColimCocone (Coequalizer_diagram f g). Definition make_Coequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧) (H : f · h = g · h) (isCEq : isCoequalizer f g d h H) : Coequalizer f g. Proof. use tpair. - use tpair. + exact d. + use Coequalizer_cocone. * exact h. * exact H. - exact isCEq. Defined. Definition Coequalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), Coequalizer f g. Definition hasCoequalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), ishinh (Coequalizer f g). Definition CoequalizerObject {a b : C} {f g : C⟦a, b⟧} : Coequalizer f g -> C := λ H, colim H. Definition CoequalizerArrow {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) : C⟦b, colim E⟧ := colimIn E Two. Definition CoequalizerArrowEq {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) : f · CoequalizerArrow E = g · CoequalizerArrow E. Proof. use (pathscomp0 (colimInCommutes E One Two (ii1 tt))). use (pathscomp0 _ (!(colimInCommutes E One Two (ii2 tt)))). apply idpath. Qed. Definition CoequalizerOut {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) e (h : C⟦b, e⟧) (H : f · h = g · h) : C⟦colim E, e⟧. Proof. now use colimArrow; use Coequalizer_cocone. Defined. Lemma CoequalizerArrowComm {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) : CoequalizerArrow E · CoequalizerOut E e h H = h. Proof. exact (colimArrowCommutes E e _ Two). Qed. Lemma CoequalizerOutUnique {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) (w : C⟦colim E, e⟧) (H' : CoequalizerArrow E · w = h) : w = CoequalizerOut E e h H. Proof. apply path_to_ctr. use two_rec_dep. - set (X := colimInCommutes E One Two (ii1 tt)). apply (maponpaths (λ h : _, h · w)) in X. use (pathscomp0 (!X)); rewrite <- assoc. change (dmor _ _) with f. change (coconeIn _ _) with (f · h). apply cancel_precomposition, H'. - apply H'. Qed. Definition isCoequalizer_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) : isCoequalizer f g (CoequalizerObject E) (CoequalizerArrow E) (CoequalizerArrowEq E). Proof. apply make_isCoequalizer. intros e h H. use (unique_exists (CoequalizerOut E e h H)). (* Commutativity *) - exact (CoequalizerArrowComm E e h H). (* Equality on equalities of morphisms *) - intros y. apply C. (* Uniqueness *) - intros y t. cbn in t. use CoequalizerOutUnique. exact t. Qed. Definition CoequalizerOfArrows {a a' b b' : C} {f g : a --> b} {f' g' : a' --> b'} (cfg : Coequalizer f g) (cfg' : Coequalizer f' g') (u : a --> a') (v : b --> b') (eqf : f · v = u · f') (eqg : g · v = u · g') : CoequalizerObject cfg --> CoequalizerObject cfg'. Proof. unshelve eapply CoequalizerOut. - refine (v · _). apply CoequalizerArrow. - abstract (rewrite ! assoc, eqf , eqg, ! assoc' ; apply cancel_precomposition, CoequalizerArrowEq). Defined. Lemma CoequalizerOfArrowsEq {a a' b b' : C} {f g : a --> b} {f' g' : a' --> b'} (cfg : Coequalizer f g) (cfg' : Coequalizer f' g') (u : a --> a') (v : b --> b') (eqf : f · v = u · f') (eqg : g · v = u · g') : CoequalizerArrow cfg · CoequalizerOfArrows cfg cfg' u v eqf eqg = v · CoequalizerArrow cfg'. Proof. apply CoequalizerArrowComm. Qed. (** ** Coequalizers to coequalizers *) Definition identity_is_Coequalizer_input {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) : total2 (fun hk : C⟦colim E, colim E⟧ => CoequalizerArrow E · hk = CoequalizerArrow E). Proof. use tpair. exact (identity _). apply id_right. Defined. Lemma CoequalizerEndo_is_identity {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) (k : C⟦colim E, colim E⟧) (kH :CoequalizerArrow E · k = CoequalizerArrow E) : identity (colim E) = k. Proof. apply colim_endo_is_identity. unfold colimIn. use two_rec_dep; cbn. + set (X := (coconeInCommutes (colimCocone E) One Two (ii1 tt))). use (pathscomp0 (! (maponpaths (λ h' : _, h' · k) X))). use (pathscomp0 _ X). rewrite <- assoc. apply cancel_precomposition. apply kH. + apply kH. Qed. Definition from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) : C⟦colim E1, colim E2⟧. Proof. apply (CoequalizerOut E1 (colim E2) (CoequalizerArrow E2)). exact (CoequalizerArrowEq E2). Defined. Lemma are_inverses_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) : is_inverse_in_precat (from_Coequalizer_to_Coequalizer E2 E1) (from_Coequalizer_to_Coequalizer E1 E2). Proof. split; apply pathsinv0. - apply CoequalizerEndo_is_identity. rewrite assoc. unfold from_Coequalizer_to_Coequalizer. repeat rewrite CoequalizerArrowComm. apply idpath. - apply CoequalizerEndo_is_identity. rewrite assoc. unfold from_Coequalizer_to_Coequalizer. repeat rewrite CoequalizerArrowComm. apply idpath. Qed. Lemma isiso_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) : is_iso (from_Coequalizer_to_Coequalizer E1 E2). Proof. apply (is_iso_qinv _ (from_Coequalizer_to_Coequalizer E2 E1)). apply are_inverses_from_Coequalizer_to_Coequalizer. Qed. Definition iso_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) : iso (colim E1) (colim E2) := tpair _ _ (isiso_from_Coequalizer_to_Coequalizer E1 E2). Lemma inv_from_iso_iso_from_Pullback {a b : C} {f g : C⟦a , b⟧} (E1 E2 : Coequalizer f g): inv_from_iso (iso_from_Coequalizer_to_Coequalizer E1 E2) = from_Coequalizer_to_Coequalizer E2 E1. Proof. apply pathsinv0. apply inv_iso_unique'. apply (pr1 (are_inverses_from_Coequalizer_to_Coequalizer E2 E1)). Qed. (** ** Connections to other colimits *) Lemma Coequalizers_from_Colims : Colims C -> Coequalizers. Proof. intros H a b f g. apply H. Defined. End def_coequalizers. (** * Definitions coincide In this section we show that the definition of coequalizer as a colimit coincides with the direct definition. *) Section coequalizers_coincide. Variable C : category. (** ** isCoequalizers *) Lemma equiv_isCoequalizer1 {a b : C} {f g : C⟦a, b⟧} (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) : limits.coequalizers.isCoequalizer f g h H -> isCoequalizer C f g e h H. Proof. intros X. set (E := limits.coequalizers.make_Coequalizer f g h H X). use (make_isCoequalizer C). intros e' h' H'. use (unique_exists (limits.coequalizers.CoequalizerOut E e' h' H')). (* Commutativity *) - exact (limits.coequalizers.CoequalizerCommutes E e' h' H'). (* Equality on equalities of morphisms *) - intros y. apply C. (* Uniqueness *) - intros y T. cbn in T. use (limits.coequalizers.CoequalizerOutsEq E). use (pathscomp0 T). exact (!(limits.coequalizers.CoequalizerCommutes E e' h' H')). Qed. Lemma equiv_isCoequalizer2 {a b : C} (f g : C⟦a, b⟧) (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) : limits.coequalizers.isCoequalizer f g h H <- isCoequalizer C f g e h H. Proof. intros X. set (E := make_Coequalizer C f g e h H X). intros e' h' H'. use (unique_exists (CoequalizerOut C E e' h' H')). (* Commutativity *) - exact (CoequalizerArrowComm C E e' h' H'). (* Equality on equalities of morphisms *) - intros y. apply C. (* Uniqueness *) - intros y T. cbn in T. use (CoequalizerOutUnique C E). exact T. Qed. (** ** Coequalizers *) Definition equiv_Coequalizer1 {a b : C} (f g : C⟦a, b⟧) : limits.coequalizers.Coequalizer f g -> Coequalizer C f g. Proof. intros E. exact (make_Coequalizer C f g _ _ _ (equiv_isCoequalizer1 (limits.coequalizers.CoequalizerObject E) (limits.coequalizers.CoequalizerArrow E) (limits.coequalizers.CoequalizerEqAr E) (limits.coequalizers.isCoequalizer_Coequalizer E))). Defined. Definition equiv_Coequalizer2 {a b : C} (f g : C⟦a, b⟧) : limits.coequalizers.Coequalizer f g <- Coequalizer C f g. Proof. intros E. exact (@limits.coequalizers.make_Coequalizer C a b (CoequalizerObject C E) f g (CoequalizerArrow C E) (CoequalizerArrowEq C E) (@equiv_isCoequalizer2 a b f g (CoequalizerObject C E) (CoequalizerArrow C E) (CoequalizerArrowEq C E) (isCoequalizer_Coequalizer C E))). Defined. End coequalizers_coincide. (** Post-composing a coequalizer diagram with a functor yields a coequalizer diagram. *) Lemma mapdiagram_coequalizer_eq_diag {C : category}{D : category} (F : functor C D){a b : C}(f g : a --> b) : eq_diag (C := D) (mapdiagram F (Coequalizer_diagram _ f g)) (Coequalizer_diagram _ (# F f) (# F g)). Proof. use tpair. - use StandardFiniteSets.two_rec_dep; cbn; apply idpath. - use StandardFiniteSets.two_rec_dep; use StandardFiniteSets.two_rec_dep; try exact (empty_rect _ ). intro e. induction e; apply idpath. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/cokernels.v000066400000000000000000000072051451125700300245710ustar00rootroot00000000000000(** * Cokernels defined in terms of colimits. *) (** ** Contents - Definition coincides with direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.graphs.zero. Require Import UniMath.CategoryTheory.limits.graphs.coequalizers. Require Import UniMath.CategoryTheory.limits.cokernels. (** * Definition of cokernels in terms of colimits *) Section def_cokernels. Variable C : category. Let hs: has_homsets C := homset_property C. Variable Z : Zero C. Definition Cokernel {a b : C} (f : C⟦a, b⟧) := Coequalizer C f (ZeroArrow Z a b). (** ** Coincides with the direct definiton *) Lemma equiv_Cokernel1_eq {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : f · (CokernelArrow CK) = ZeroArrow Z a b · (CokernelArrow CK). Proof. rewrite CokernelCompZero. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow. Qed. Lemma equiv_Cokernel1_isCoequalizer {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : isCoequalizer C f (ZeroArrow Z a b) CK (CokernelArrow CK) (equiv_Cokernel1_eq f CK). Proof. use (make_isCoequalizer _). intros w h H. use unique_exists. (* Construction of the morphism *) - use CokernelOut. + exact h. + rewrite postcomp_with_ZeroArrow in H. use (pathscomp0 _ (!(equiv_ZeroArrow a w Z))). exact H. (* Commutativity *) - use CokernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. use CokernelOutsEq. unfold CokernelArrow. use (pathscomp0 T). apply pathsinv0. use CokernelCommutes. Qed. Definition equiv_Cokernel1 {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : Cokernel f. Proof. use make_Coequalizer. - exact CK. - exact (CokernelArrow CK). - exact (equiv_Cokernel1_eq f CK). - exact (equiv_Cokernel1_isCoequalizer f CK). Defined. (* Other direction *) Lemma equiv_Cokernel2_eq {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : f · CokernelArrow CK = ZeroArrow Z a b · CokernelArrow CK. Proof. rewrite CokernelCompZero. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow. Qed. Lemma equiv_Cokernel2_isCoequalizer {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : isCoequalizer C f (ZeroArrow Z a b) CK (CokernelArrow CK) (equiv_Cokernel2_eq f CK). Proof. use (make_isCoequalizer _ ). intros w h H. use unique_exists. (* Construction of the morphism *) - use CokernelOut. + exact h. + use (pathscomp0 H). apply pathsinv0. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow. (* Commutativity *) - use CokernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. use CokernelOutsEq. rewrite T. rewrite CokernelCommutes. apply idpath. Qed. Definition equiv_Cokernel2 {a b : C} (f : C⟦a, b⟧) (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : Cokernel f. Proof. use make_Coequalizer. - exact CK. - exact (CokernelArrow CK). - exact (equiv_Cokernel2_eq f CK). - exact (equiv_Cokernel2_isCoequalizer f CK). Defined. End def_cokernels. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/colimits.v000066400000000000000000000627651451125700300244430ustar00rootroot00000000000000 (** ************************************************* Contents: - Definitions of graphs and diagrams - Formalization of colimits on this basis - Rules for pre- and post-composition - Proof that colimits form a property in a (saturated/univalent) category ([isaprop_Colims]) - Pointwise construction of colimits in functor precategories ([ColimsFunctorCategory]) Written by Benedikt Ahrens and Anders Mörtberg, 2015-2016 *****************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Adjunctions.Core. Local Open Scope cat. (** Definition of graphs and diagrams *) Section diagram_def. Definition graph := ∑ (D : UU), D -> D -> UU. Definition vertex : graph -> UU := pr1. Definition edge {g : graph} : vertex g -> vertex g -> UU := pr2 g. Definition make_graph (D : UU) (e : D → D → UU) : graph := tpair _ D e. Definition diagram (g : graph) (C : precategory) : UU := ∑ (f : vertex g -> C), ∏ (a b : vertex g), edge a b -> C⟦f a, f b⟧. Definition make_diagram {g : graph} {C : precategory} (f : vertex g -> C) (P : (∏ (a b : vertex g), edge a b -> C⟦f a, f b⟧)) : diagram g C := (f ,, P). Definition dob {g : graph} {C : precategory} (d : diagram g C) : vertex g -> C := pr1 d. Definition dmor {g : graph} {C : precategory} (d : diagram g C) : ∏ {a b}, edge a b -> C⟦dob d a,dob d b⟧ := pr2 d. Section diagram_from_functor. Variables (J C : precategory). Variable (F : functor J C). Definition graph_from_precategory : graph := (pr1 (pr1 J)). Definition diagram_from_functor : diagram graph_from_precategory C := tpair _ _ (pr2 (pr1 F)). End diagram_from_functor. End diagram_def. Coercion graph_from_precategory : precategory >-> graph. (** * Definition of colimits *) Section colim_def. (** A cocone with tip c over a diagram d *) Definition forms_cocone {C : precategory} {g : graph} (d : diagram g C) {c : C} (f : ∏ (v : vertex g), C⟦dob d v, c⟧) : UU := ∏ (u v : vertex g) (e : edge u v), dmor d e · f v = f u. Definition cocone {C : precategory} {g : graph} (d : diagram g C) (c : C) : UU := ∑ (f : ∏ (v : vertex g), C⟦dob d v,c⟧), forms_cocone d f. Definition make_cocone {C : precategory} {g : graph} {d : diagram g C} {c : C} (f : ∏ v, C⟦dob d v,c⟧) (Hf : forms_cocone d f) : cocone d c := tpair _ f Hf. (** The injections to c in the cocone *) Definition coconeIn {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cocone d c) : ∏ v, C⟦dob d v,c⟧ := pr1 cc. (** not recommended! [Coercion coconeIn : cocone >-> Funclass.] *) Lemma coconeInCommutes {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cocone d c) : forms_cocone d (coconeIn cc). Proof. exact (pr2 cc). Qed. Definition cocone_paths {C : category} {g : graph} {d : diagram g C} {x : C} (cc1 cc2 : cocone d x) (eqin : ∏ g, coconeIn cc1 g = coconeIn cc2 g): cc1 = cc2. Proof. use subtypePath'. - apply funextsec. exact eqin. - repeat (apply impred_isaprop; intro). apply C. Defined. Definition is_cocone_mor {C : precategory} {g : graph} {d : diagram g C} {c1 : C} (cc1 : cocone d c1) {c2 : C} (cc2 : cocone d c2) (x : c1 --> c2) : UU := ∏ (v : vertex g), coconeIn cc1 v · x = coconeIn cc2 v. Lemma isaprop_is_cocone_mor {C : category} {g : graph} {d : diagram g C} {c1 : C} (cc1 : cocone d c1) {c2 : C} (cc2 : cocone d c2) (f : c1 --> c2) : isaprop (is_cocone_mor cc1 cc2 f). Proof. apply impred_isaprop ; intro. apply homset_property. Qed. (** cc0 is a colimit cocone if for any other cocone cc over the same diagram there is a unique morphism from the tip of cc0 to the tip of cc *) Definition isColimCocone {C : precategory} {g : graph} (d : diagram g C) (c0 : C) (cc0 : cocone d c0) : UU := ∏ (c : C) (cc : cocone d c), iscontr (∑ x : C⟦c0,c⟧, is_cocone_mor cc0 cc x). (* Definition isColim {g : graph} (d : diagram g C) (L : C) := *) (* ∑ c : cocone d L, isColimCocone d L c. *) Definition ColimCocone {C : precategory} {g : graph} (d : diagram g C) : UU := ∑ (A : (∑ c0 : C, cocone d c0)), isColimCocone d (pr1 A) (pr2 A). Definition make_ColimCocone {C : precategory} {g : graph} (d : diagram g C) (c : C) (cc : cocone d c) (isCC : isColimCocone d c cc) : ColimCocone d := tpair _ (tpair _ c cc) isCC. (** colim is the tip of the colim cocone *) Definition colim {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : C := pr1 (pr1 CC). Definition colimCocone {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : cocone d (colim CC) := pr2 (pr1 CC). Definition isColimCocone_from_ColimCocone {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : isColimCocone d (colim CC) _ := pr2 CC. Definition colimIn {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : ∏ (v : vertex g), C⟦dob d v,colim CC⟧ := coconeIn (colimCocone CC). Lemma colimInCommutes {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : forms_cocone d (colimIn CC). Proof. exact (coconeInCommutes (colimCocone CC)). Qed. Lemma colimUnivProp {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) : ∏ (c : C) (cc : cocone d c), iscontr (∑ x : C⟦colim CC,c⟧, ∏ (v : vertex g), colimIn CC v · x = coconeIn cc v). Proof. exact (pr2 CC). Qed. Lemma isaprop_isColimCocone {C : precategory} {g : graph} (d : diagram g C) (c0 : C) (cc0 : cocone d c0) : isaprop (isColimCocone d c0 cc0). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Definition colimArrow {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) (c : C) (cc : cocone d c) : C⟦colim CC,c⟧ := pr1 (pr1 (isColimCocone_from_ColimCocone CC c cc)). Lemma colimArrowCommutes {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) (c : C) (cc : cocone d c) (u : vertex g) : colimIn CC u · colimArrow CC c cc = coconeIn cc u. Proof. exact ((pr2 (pr1 (isColimCocone_from_ColimCocone CC _ cc))) u). Qed. Lemma colimArrowUnique {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) (c : C) (cc : cocone d c) (k : C⟦colim CC,c⟧) (Hk : ∏ (u : vertex g), colimIn CC u · k = coconeIn cc u) : k = colimArrow CC c cc. Proof. apply path_to_ctr. red. apply Hk. Qed. Lemma Cocone_postcompose {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cocone d c) (x : C) (f : C⟦c,x⟧) : ∏ u v (e : edge u v), dmor d e · (coconeIn cc v · f) = coconeIn cc u · f. Proof. now intros u v e; rewrite assoc, coconeInCommutes. Qed. Lemma colimArrowEta {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) (c : C) (f : C⟦colim CC,c⟧) : f = colimArrow CC c (tpair _ (λ u, colimIn CC u · f) (Cocone_postcompose (colimCocone CC) c f)). Proof. now apply colimArrowUnique. Qed. Lemma colimArrowUnique' {C : precategory} {g : graph} {d : diagram g C} (CC : ColimCocone d) {c} (k k' : C ⟦ colim CC, c ⟧): (∏ u : vertex g, colimIn CC u · k = colimIn CC u · k') → k = k'. Proof. intro eq. apply pathsinv0. etrans. { apply colimArrowEta. } apply pathsinv0. apply colimArrowUnique. cbn. exact eq. Qed. Definition colimOfArrows {C : precategory} {g : graph} {d1 d2 : diagram g C} (CC1 : ColimCocone d1) (CC2 : ColimCocone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), dmor d1 e · f v = f u · dmor d2 e) : C⟦colim CC1,colim CC2⟧. Proof. apply colimArrow; use make_cocone. - now intro u; apply (f u · colimIn CC2 u). - abstract (intros u v e; simpl; now rewrite assoc, fNat, <- assoc, colimInCommutes). Defined. Lemma colimOfArrowsIn {C : precategory} {g : graph} (d1 d2 : diagram g C) (CC1 : ColimCocone d1) (CC2 : ColimCocone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), dmor d1 e · f v = f u · dmor d2 e) : ∏ u, colimIn CC1 u · colimOfArrows CC1 CC2 f fNat = f u · colimIn CC2 u. Proof. now unfold colimOfArrows; intro u; rewrite colimArrowCommutes. Qed. Lemma preCompWithColimOfArrows_subproof {C : precategory} {g : graph} {d1 d2 : diagram g C} (CC1 : ColimCocone d1) (CC2 : ColimCocone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), dmor d1 e · f v = f u · dmor d2 e) (x : C) (cc : cocone d2 x) u v (e : edge u v) : dmor d1 e · (f v · coconeIn cc v) = f u · coconeIn cc u. Proof. now rewrite <- (coconeInCommutes cc u v e), !assoc, fNat. Qed. Lemma precompWithColimOfArrows {C : precategory} {g : graph} (d1 d2 : diagram g C) (CC1 : ColimCocone d1) (CC2 : ColimCocone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), dmor d1 e · f v = f u · dmor d2 e) (x : C) (cc : cocone d2 x) : colimOfArrows CC1 CC2 f fNat · colimArrow CC2 x cc = colimArrow CC1 x (make_cocone (λ u, f u · coconeIn cc u) (preCompWithColimOfArrows_subproof CC1 CC2 f fNat x cc)). Proof. apply colimArrowUnique. now intro u; rewrite assoc, colimOfArrowsIn, <- assoc, colimArrowCommutes. Qed. Lemma postcompWithColimArrow {C : precategory} {g : graph} (D : diagram g C) (CC : ColimCocone D) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : colimArrow CC c cc · k = colimArrow CC d (make_cocone (λ u, coconeIn cc u · k) (Cocone_postcompose cc d k)). Proof. apply colimArrowUnique. now intro u; rewrite assoc, colimArrowCommutes. Qed. Lemma colim_endo_is_identity {C : precategory} {g : graph} (D : diagram g C) (CC : ColimCocone D) (k : colim CC --> colim CC) (H : ∏ u, colimIn CC u · k = colimIn CC u) : identity _ = k. Proof. use (uniqueExists (colimUnivProp CC _ _)). - now apply (colimCocone CC). - intros v; simpl. now apply id_right. - simpl; now apply H. Qed. Definition Cocone_by_postcompose {C : precategory} {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d. Proof. exists (λ u, coconeIn cc u · k). red; apply Cocone_postcompose. Defined. Lemma isColim_weq_subproof1 {C : precategory} {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : ∏ u, coconeIn cc u · k = coconeIn (Cocone_by_postcompose D c cc d k) u. Proof. now intro u. Qed. Lemma isColim_weq_subproof2 {C : precategory} (g : graph) (D : diagram g C) (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d)) (d : C) (cd : cocone D d) : is_cocone_mor cc cd (invmap (make_weq _ (H d)) cd). Proof. intro u. rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u). set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p. now rewrite p. Qed. Lemma isColim_weq {C : category} {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) : isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d). Proof. split. - intros H d. use isweq_iso. + intros k. exact (colimArrow (make_ColimCocone D c cc H) _ k). + abstract (intro k; simpl; now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))). + abstract (simpl; intro k; apply subtypePath; [ intro; now repeat (apply impred; intro); apply C | destruct k as [k Hk]; simpl; apply funextsec; intro u; now apply (colimArrowCommutes (make_ColimCocone D c cc H))]). - intros H d cd. use tpair. + exists (invmap (make_weq _ (H d)) cd). abstract (intro u; now apply isColim_weq_subproof2). + abstract (intro t; apply subtypePath; [ intro; now apply impred; intro; apply C | destruct t as [t Ht]; simpl; apply (invmaponpathsweq (make_weq _ (H d))); simpl; apply subtypePath; [ intro; now repeat (apply impred; intro); apply C | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht; now apply isColim_weq_subproof2]]). Defined. Lemma isColim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : ColimCocone D) (d : C) (cd : cocone D d) : isColimCocone D d cd -> is_z_isomorphism (colimArrow CC d cd). Proof. intro H. set (CD := make_ColimCocone D d cd H). apply (tpair _ (colimArrow (make_ColimCocone D d cd H) (colim CC) (colimCocone CC))). abstract (split; [ apply pathsinv0, colim_endo_is_identity; simpl; intro u; rewrite assoc; eapply pathscomp0; [eapply cancel_postcomposition; apply colimArrowCommutes|]; apply (colimArrowCommutes CD) | apply pathsinv0, (colim_endo_is_identity _ CD); simpl; intro u; rewrite assoc; eapply pathscomp0; [eapply cancel_postcomposition; apply (colimArrowCommutes CD)|]; apply colimArrowCommutes ]). Defined. Lemma inv_isColim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : ColimCocone D) (d : C) (cd : cocone D d) (H : isColimCocone D d cd) : inv_from_z_iso (_,,isColim_is_z_iso D CC d cd H) = colimArrow (make_ColimCocone D d cd H) _ (colimCocone CC). Proof. apply idpath. Qed. Lemma is_z_iso_isColim {C : category} {g : graph} (D : diagram g C) (CC : ColimCocone D) (d : C) (cd : cocone D d) : is_z_isomorphism (colimArrow CC d cd) -> isColimCocone D d cd. Proof. intro H. set (iinv := z_iso_inv_from_is_z_iso _ H). intros x cx. use tpair. - use tpair. + exact (iinv · colimArrow CC x cx). + simpl; intro u. rewrite <- (colimArrowCommutes CC x cx u), assoc. apply cancel_postcomposition, pathsinv0, z_iso_inv_on_left, pathsinv0, colimArrowCommutes. - intros p; destruct p as [f Hf]. apply subtypePath. + intro a; apply impred; intro u; apply C. + simpl; apply pathsinv0, z_iso_inv_on_right; simpl. apply pathsinv0, colimArrowUnique; intro u. now rewrite <- (Hf u), assoc, colimArrowCommutes. Defined. Definition z_iso_from_colim_to_colim {C : precategory} {g : graph} {d : diagram g C} (CC CC' : ColimCocone d) : z_iso (colim CC) (colim CC'). Proof. use make_z_iso. - apply colimArrow, colimCocone. - apply colimArrow, colimCocone. - abstract (now split; apply pathsinv0, colim_endo_is_identity; intro u; rewrite assoc, colimArrowCommutes; eapply pathscomp0; try apply colimArrowCommutes). Defined. End colim_def. Section Colims. Definition Colims (C : category) : UU := ∏ (g : graph) (d : diagram g C), ColimCocone d. Definition hasColims (C : category) : UU := ∏ (g : graph) (d : diagram g C), ∥ ColimCocone d ∥. (** Colimits of a specific shape *) Definition Colims_of_shape (g : graph) (C : category) : UU := ∏ (d : diagram g C), ColimCocone d. (** If C is a univalent_category then Colims is a prop *) Section Universal_Unique. Variables (C : univalent_category). Let H : is_univalent C := pr2 C. Lemma isaprop_Colims: isaprop (Colims C). Proof. apply impred; intro g; apply impred; intro cc. apply invproofirrelevance; intros Hccx Hccy. apply subtypePath. - intro; apply isaprop_isColimCocone. - apply (total2_paths_f (isotoid _ H (z_iso_from_colim_to_colim Hccx Hccy))). set (B c := ∏ v, C⟦dob cc v,c⟧). set (C' (c : C) f := forms_cocone(c:=c) cc f). rewrite (@transportf_total2 _ B C'). apply subtypePath. + intro; repeat (apply impred; intro); apply univalent_category_has_homsets. + simpl; eapply pathscomp0; [apply transportf_isotoid_dep''|]. apply funextsec; intro v. now rewrite idtoiso_isotoid; apply colimArrowCommutes. Qed. End Universal_Unique. End Colims. (** * Defines colimits in functor categories when the target has colimits *) Section ColimFunctor. Context {A C : category} {g : graph} (D : diagram g [A, C]). (* Variable HC : Colims C. *) (* Too strong! *) Definition diagram_pointwise (a : A) : diagram g C. Proof. exists (λ v, pr1 (dob D v) a); intros u v e. now apply (pr1 (dmor D e) a). Defined. Variable (HCg : ∏ (a : A), ColimCocone (diagram_pointwise a)). Definition ColimFunctor_ob (a : A) : C := colim (HCg a). Definition ColimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) : C⟦ColimFunctor_ob a,ColimFunctor_ob a'⟧. Proof. use colimOfArrows. - now intro u; apply (# (pr1 (dob D u)) f). - abstract (now intros u v e; simpl; apply pathsinv0, (nat_trans_ax (dmor D e))). Defined. Definition ColimFunctor_data : functor_data A C := tpair _ _ ColimFunctor_mor. Lemma is_functor_ColimFunctor_data : is_functor ColimFunctor_data. Proof. split. - intro a; simpl. apply pathsinv0, colim_endo_is_identity; intro u. unfold ColimFunctor_mor. now rewrite colimOfArrowsIn, (functor_id (dob D u)), id_left. - intros a b c fab fbc; simpl; unfold ColimFunctor_mor. apply pathsinv0. eapply pathscomp0; [now apply precompWithColimOfArrows|]. apply pathsinv0, colimArrowUnique; intro u. rewrite colimOfArrowsIn. rewrite (functor_comp (dob D u)). now apply pathsinv0, assoc. Qed. Definition ColimFunctor : functor A C := tpair _ _ is_functor_ColimFunctor_data. Definition colim_nat_trans_in_data v : [A, C] ⟦ dob D v, ColimFunctor ⟧. Proof. use tpair. - intro a; exact (colimIn (HCg a) v). - abstract (intros a a' f; now apply pathsinv0, (colimOfArrowsIn _ _ (HCg a) (HCg a'))). Defined. Definition cocone_pointwise (F : [A,C]) (cc : cocone D F) a : cocone (diagram_pointwise a) (pr1 F a). Proof. use make_cocone. - now intro v; apply (pr1 (coconeIn cc v) a). - abstract (intros u v e; now apply (nat_trans_eq_pointwise (coconeInCommutes cc u v e))). Defined. Lemma ColimFunctor_unique (F : [A, C]) (cc : cocone D F) : iscontr (∑ x : [A, C] ⟦ ColimFunctor, F ⟧, ∏ v : vertex g, colim_nat_trans_in_data v · x = coconeIn cc v). Proof. use tpair. - use tpair. + apply (tpair _ (λ a, colimArrow (HCg a) _ (cocone_pointwise F cc a))). abstract (intros a a' f; simpl; eapply pathscomp0; [ now apply precompWithColimOfArrows | apply pathsinv0; eapply pathscomp0; [ now apply postcompWithColimArrow | apply colimArrowUnique; intro u; eapply pathscomp0; [ now apply colimArrowCommutes | apply pathsinv0; now use nat_trans_ax ]]]). + abstract (intro u; apply (nat_trans_eq C); simpl; intro a; now apply (colimArrowCommutes (HCg a))). - abstract (intro t; destruct t as [t1 t2]; apply subtypePath; simpl; [ intro; apply impred; intro u; apply functor_category_has_homsets | apply (nat_trans_eq C); simpl; intro a; apply colimArrowUnique; intro u; now apply (nat_trans_eq_pointwise (t2 u))]). Defined. Lemma ColimFunctorCocone : ColimCocone D. Proof. use make_ColimCocone. - exact ColimFunctor. - use make_cocone. + now apply colim_nat_trans_in_data. + abstract (now intros u v e; apply (nat_trans_eq C); intro a; apply (colimInCommutes (HCg a))). - now intros F cc; simpl; apply (ColimFunctor_unique _ cc). Defined. Definition isColimFunctor_is_pointwise_Colim (X : [A,C]) (R : cocone D X) (H : isColimCocone D X R) : ∏ a, isColimCocone (diagram_pointwise a) _ (cocone_pointwise X R a). Proof. intro a. apply (is_z_iso_isColim _ (HCg a)). set (XR := isColim_is_z_iso D ColimFunctorCocone X R H). apply (is_functor_z_iso_pointwise_if_z_iso _ _ _ _ _ _ XR). Defined. End ColimFunctor. Lemma ColimsFunctorCategory (A C : category) (HC : Colims C) : Colims [A,C]. Proof. now intros g d; apply ColimFunctorCocone. Defined. Lemma ColimsFunctorCategory_of_shape (g : graph) (A C : category) (HC : Colims_of_shape g C) : Colims_of_shape g [A,C]. Proof. now intros d; apply ColimFunctorCocone. Defined. Lemma pointwise_Colim_is_isColimFunctor {A C : category} {g : graph} (d : diagram g [A,C]) (G : [A,C]) (ccG : cocone d G) (H : ∏ a, isColimCocone _ _ (cocone_pointwise d G ccG a)) : isColimCocone d G ccG. Proof. set (CC a := make_ColimCocone _ _ _ (H a)). set (D' := ColimFunctorCocone _ CC). use is_z_iso_isColim. - apply D'. - use tpair. + use make_nat_trans. * intros a; apply identity. * abstract (intros a b f; rewrite id_left, id_right; simpl; apply (colimArrowUnique (CC a)); intro u; cbn; now rewrite <- (nat_trans_ax (coconeIn ccG u))). + abstract (split; [ apply (nat_trans_eq C); intros x; simpl; rewrite id_right; apply pathsinv0, colimArrowUnique; intros v; now rewrite id_right | apply (nat_trans_eq C); intros x; simpl; rewrite id_left; apply pathsinv0, (colimArrowUnique (CC x)); intro u; now rewrite id_right]). Defined. Section map. Context {C D : precategory} (F : functor C D). Definition mapdiagram {g : graph} (d : diagram g C) : diagram g D. Proof. use tpair. - intros n; apply (F (dob d n)). - simpl; intros m n e. apply (# F (dmor d e)). Defined. Definition mapcocone {g : graph} (d : diagram g C) {x : C} (dx : cocone d x) : cocone (mapdiagram d) (F x). Proof. use make_cocone. - simpl; intro n. exact (#F (coconeIn dx n)). - abstract (intros u v e; simpl; rewrite <- functor_comp; apply maponpaths, (coconeInCommutes dx _ _ e)). Defined. Definition preserves_colimit {g : graph} (d : diagram g C) (L : C) (cc : cocone d L) : UU := isColimCocone d L cc -> isColimCocone (mapdiagram d) (F L) (mapcocone d cc). Definition preserves_colimits_of_shape (g : graph) : UU := ∏ (d : diagram g C) (L : C)(cc : cocone d L), preserves_colimit d L cc. End map. (** ** Left adjoints preserve colimits *) Lemma left_adjoint_preserves_colimit {C D : category} (F : functor C D) (HF : is_left_adjoint F) {g : graph} (d : diagram g C) (L : C) (ccL : cocone d L) : preserves_colimit F d L ccL. Proof. intros HccL M ccM. set (G := right_adjoint HF). set (H := pr2 HF : are_adjoints F G). apply (@iscontrweqb _ (∑ y : C ⟦ L, G M ⟧, ∏ i, coconeIn ccL i · y = φ_adj H (coconeIn ccM i))). - eapply (weqcomp (Y := ∑ y : C ⟦ L, G M ⟧, ∏ i, # F (coconeIn ccL i) · φ_adj_inv H y = coconeIn ccM i)). + apply (weqbandf (adjunction_hom_weq H L M)); simpl; intro f. abstract (apply weqiff; try (apply impred; intro; apply D); now rewrite φ_adj_inv_after_φ_adj). + eapply (weqcomp (Y := ∑ y : C ⟦ L, G M ⟧, ∏ i, φ_adj_inv H (coconeIn ccL i · y) = coconeIn ccM i)). * apply weqfibtototal; simpl; intro f. abstract (apply weqiff; try (apply impred; intro; apply D); split; [ intros HH i; rewrite φ_adj_inv_natural_precomp; apply HH | intros HH i; rewrite <- φ_adj_inv_natural_precomp; apply HH ]). (* apply weqonsecfibers; intro i. *) (* rewrite φ_adj_inv_natural_precomp; apply idweq. *) * apply weqfibtototal; simpl; intro f. abstract (apply weqiff; [ | apply impred; intro; apply D | apply impred; intro; apply C ]; split; intros HH i; [ now rewrite <- (HH i), φ_adj_after_φ_adj_inv | now rewrite (HH i), φ_adj_inv_after_φ_adj ]). (* apply weqonsecfibers; intro i. *) (* apply weqimplimpl; [ | | apply hsD | apply hsC]; intro h. *) (* now rewrite <- h, (φ_adj_after_φ_adj_inv _ _ _ H). *) (* now rewrite h, (φ_adj_inv_after_φ_adj _ _ _ H). *) - transparent assert (X : (cocone d (G M))). { use make_cocone. + intro v; apply (φ_adj H (coconeIn ccM v)). + abstract (intros m n e; simpl; rewrite <- (coconeInCommutes ccM m n e); simpl; now rewrite φ_adj_natural_precomp). } apply (HccL (G M) X). Defined. Section mapcocone_functor_composite. Context {A B C : category} (F : functor A B) (G : functor B C). Lemma mapcocone_functor_composite {g : graph} {D : diagram g A} {a : A} (cc : cocone D a) : mapcocone (functor_composite F G) _ cc = mapcocone G _ (mapcocone F _ cc). Proof. apply subtypePath. - intros x. repeat (apply impred_isaprop; intro). apply C. - reflexivity. Qed. End mapcocone_functor_composite. (** Some functions to construct morphisms using colimits *) Definition colim_mor {C : category} {G : graph} {D : diagram G C} (c : ColimCocone D) (y : C) (g : ∏ (v : vertex G), dob D v --> y) (p : forms_cocone D g) : colim c --> y := pr11 (pr2 c y (make_cocone g p)). Definition colim_mor_commute {C : category} {G : graph} {D : diagram G C} (c : ColimCocone D) (y : C) (g : ∏ (v : vertex G), dob D v --> y) (p : forms_cocone D g) (v : vertex G) : colimIn c v · colim_mor c y g p = g v := pr21 (pr2 c y (make_cocone g p)) v. Definition colim_mor_eq {C : category} {G : graph} {D : diagram G C} (c : ColimCocone D) (y : C) {f₁ f₂ : colim c --> y} (H : ∏ (v : vertex G), colimIn c v · f₁ = colimIn c v · f₂) : f₁ = f₂. Proof. assert (forms_cocone D (λ v : vertex G, colimIn c v · f₂)) as Hf₂. { unfold forms_cocone. cbn. unfold dmor. intros. rewrite !assoc. apply maponpaths_2. apply colimInCommutes. } pose (pr2 (pr2 c y (make_cocone (λ v, colimIn c v · f₂) Hf₂)) (f₁ ,, H)) as p. refine (maponpaths pr1 p @ _). pose (pr2 (pr2 c y (make_cocone (λ v, colimIn c v · f₂) Hf₂)) (f₂ ,, λ _, idpath _)) as q. exact (!(maponpaths pr1 q)). Qed. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/eqdiag.v000066400000000000000000000241131451125700300240330ustar00rootroot00000000000000(** - Custom notion of equality between diagrams (eq_diag) over the same graph - Transports of cones and cocones between equal diagrams. - Limits/Colimits are the same for equal diagrams. This notion of equality is useful to make the link between standard diagrams (pushouts, coequalizers, ...) in a functor category and the induced pointwise diagram given an object of the source category Example of the binary product : Let - C,D be two categories, - A and B two functors from C to D - x an object of C Let J := binproduct_diagram (A x) (B x) Let J' := diagram_pointwise (binproduct_diagram A B) x. J and J' are not definitionnally equal. Let co a cone of J based on c. Using a (not too stupid) proof (e : eq_diag J J'), we can transport the cone co with make_eq_diag_cone to get a cone co' of J' based on c that satisfies the definitional equalities : coneOut co' true ≡ coneOut co true coneOut co' false ≡ coneOut co false (true and false are the two vertices of the binproduct graph). This equality would not be needed if functional extensionality computed. *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Local Open Scope cat. Lemma is_exists_unique {A : UU} {B : A → UU} (H : ∃! a : A, B a) : B ( pr1 (iscontrpr1 H)). Proof. exact(pr2 (pr1 H)). Qed. Lemma transport_swap: ∏ {X Y : UU} (P : X -> Y → UU) {x x':X} {y y' : Y} (e : x = x') (e' : y = y') (p : P x y), transportf (λ a, P _ a) e' (transportf (λ a, P a _) e p) = transportf (λ a, P a _) e (transportf (λ a, P _ a) e' p) . Proof. intros. induction e. induction e'. apply idpath. Qed. Lemma transportf2_comp {X : UU} (P : X -> X → UU) (x x' : X) (ex : x = x') (t:P x x) : transportf (λ y, P y y) ex t = transportf (λ y, P y x') ex (transportf (λ y, P x y) ex t). Proof. now induction ex. Qed. Definition eq_diag {C : category} {g : graph} (d d' : diagram g C) := ∑ (eq_v : ∏ v: vertex g, dob d v = dob d' v), ∏ (v v':vertex g) (f:edge v v'), transportf (λ obj, C⟦obj, dob d v'⟧) (eq_v v) (dmor d f) = transportb (λ obj, C⟦_, obj⟧) (eq_v v') (dmor d' f). Lemma eq_is_eq_diag {C : category} {g : graph} (d d' : diagram g C) : d = d' -> eq_diag d d'. Proof. intro e. induction e. exists (λ x, idpath _). exact (λ x y z, idpath _). Qed. Lemma eq_diag_is_eq {C : category} {g : graph} (d d' : diagram g C) : eq_diag d d' -> d = d'. Proof. intros [eqv autreq]. use total2_paths_f. - apply funextfun. intro v. apply eqv. - rewrite (transportf2_comp (λ x y : vertex g → C, ∏ a b : vertex g, edge a b → C ⟦ y a, x b ⟧)). match goal with |- transportf ?Pf ?x1 (transportf ?Pf2 ?s1 ?s2 ) = _ => set (e := x1); set (P := Pf); set (P2 := Pf2); set (tp2:=transportf P2 s1 s2); set (trp := transportf P x1 tp2) end. change (trp = pr2 d'). unfold trp. apply funextsec. intro v; apply funextsec; intro v'. apply funextsec; intro ed. specialize (autreq v v' ed). rewrite <- (pathsinv0inv0 (eqv v)) in autreq. apply pathsinv0 in autreq. apply transportf_transpose_right in autreq. unfold dmor in autreq. rewrite autreq. rewrite pathsinv0inv0. etrans. eapply pathsinv0. apply ( transport_map (P:=P) (Q:=_) (λ x tp, tp v v' ed)). etrans. apply (transportf_funextfun (λ x, C⟦ pr1 d' v,x⟧)). apply maponpaths. etrans. eapply pathsinv0. apply ( transport_map (P:=P2) (Q:=_) (λ x tp, tp v v' ed)). apply (transportf_funextfun (λ x, C⟦ x,pr1 d v'⟧)). Qed. (* We don't want to use the equivalence with bare identity to show the apply pathsinv0 because we want computation (Defined) *) Lemma sym_eq_diag {C : category} {g : graph} (d d' : diagram g C) : eq_diag d d' -> eq_diag d' d. Proof. intros eq_d. set (eq_d1 := pr1 eq_d). set (eq_d2 := pr2 eq_d). use tpair. - intro v. apply (! (eq_d1 v)). - (* here we use equality *) unfold eq_d1. assert (heqdag:eq_diag d' d). + apply eq_is_eq_diag. apply pathsinv0. apply eq_diag_is_eq. assumption. + (* Proof without using equality *) abstract (cbn; intros v v' f; specialize (eq_d2 v v' f); apply pathsinv0; unfold transportb; rewrite pathsinv0inv0; apply (transportf_transpose_right (P:=(λ obj : C, C ⟦ obj, dob d' v' ⟧))); assert (eq_d2':=transportf_transpose_right (P:=(precategory_morphisms (dob d' v))) (! eq_d2)); rewrite eq_d2'; unfold transportb; rewrite pathsinv0inv0; apply (transport_swap (λ a b, C⟦b,a⟧))). Defined. Lemma make_eq_diag_cocone : ∏ {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (heq_d: eq_diag d d') {c : C} (cc:cocone d c), cocone d' c. Proof. clear. intros. destruct heq_d as [heq heq2]. use make_cocone. intro v. use (transportf (λ obj, C⟦obj,_⟧ ) (heq v)); simpl. apply (coconeIn cc). abstract( intros u v e; simpl; rewrite <- ( coconeInCommutes cc u v e); apply (pathscomp0 (b:=transportb (precategory_morphisms (dob d' u)) (heq v) (dmor d' e) · (coconeIn cc v))); [ unfold transportb; (set (z:= ! heq v)); rewrite <- (pathsinv0inv0 (heq v)); apply pathsinv0; apply transport_compose|]; etrans; [ apply cancel_postcomposition; eapply pathsinv0; apply heq2|]; clear; now destruct (heq u)). Defined. (* The dual proof *) Lemma make_eq_diag_cone : ∏ {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (heq_d: eq_diag d d') {c : C} (cc:cone d c), cone d' c. Proof. clear. intros. set (heq := pr1 heq_d). set (heq2 := pr2 heq_d). use make_cone. intro v. apply (transportf (λ obj, C⟦_,obj⟧ ) (heq v) (coneOut cc v)). abstract( intros u v e; simpl; rewrite <- ( coneOutCommutes cc u v e); etrans;[ apply transport_compose|]; rewrite transport_target_postcompose; apply cancel_precomposition; apply transportf_transpose_right; etrans;[ apply (transport_swap (λ a b, C⟦a,b⟧))|]; etrans;[ apply maponpaths; eapply pathsinv0; apply heq2|]; unfold heq; induction (pr1 heq_d u); apply idpath). Defined. Lemma eq_diag_islimcone: ∏ {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (eq_d : eq_diag d d') {c : C} {cc:cone d c} (islimcone : isLimCone _ _ cc) , isLimCone _ _ (make_eq_diag_cone d' eq_d cc). Proof. intros. set (eq_d1 := pr1 eq_d); set (eq_d2 := pr1 eq_d). set (eq_d' := sym_eq_diag _ _ eq_d). set (eq_d1' := pr1 eq_d'). set (eq_d2' := pr2 eq_d'). red. intros c' cc'. set (cc'2 := make_eq_diag_cone _ eq_d' cc'). specialize (islimcone c' cc'2). apply (unique_exists (pr1 (pr1 islimcone))). - intro v. assert (islim := is_exists_unique islimcone v). cbn in islim. cbn. etrans. eapply pathsinv0. apply transport_target_postcompose. etrans. apply maponpaths. apply islim. apply transportfbinv. - intro y. apply impred_isaprop. intro t. apply homset_property. - intros y hy. apply (path_to_ctr _ _ islimcone). intro v; specialize (hy v). cbn. apply transportf_transpose_right. rewrite <- hy. etrans. unfold transportb. rewrite pathsinv0inv0. apply transport_target_postcompose. apply idpath. Qed. (** The dual proof . This proof could be deduced from the previous if there was a lemma stating that colimits are limits in the dual category. *) Lemma eq_diag_iscolimcocone: ∏ {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (eq_d : eq_diag d d') {c : C} {cc:cocone d c} (islimcone : isColimCocone _ _ cc) , isColimCocone _ _ (make_eq_diag_cocone d' eq_d cc). Proof. intros. destruct eq_d as [eq_d1 eq_d2]. set (eq_d := eq_d1,,eq_d2). set (eq_d'' := sym_eq_diag _ _ eq_d). set (eq_d1' := pr1 eq_d''). set (eq_d2' := pr2 eq_d''). set (eq_d' := (eq_d1',,eq_d2'):eq_diag d' d). red. intros c' cc'. set (cc'2 := make_eq_diag_cocone _ eq_d' cc'). specialize (islimcone c' cc'2). apply (unique_exists (pr1 (pr1 islimcone))). - intro v. assert (islim := is_exists_unique islimcone v). cbn in islim. cbn. etrans. rewrite <- (pathsinv0inv0 (eq_d1 v)). eapply pathsinv0. apply transport_source_precompose. etrans. apply maponpaths. apply islim. cbn. now apply (transportbfinv ( (λ x' : C, C ⟦ x', c' ⟧) )). - intro y. apply impred_isaprop. intro t. apply homset_property. - intros y hy. apply (path_to_ctr _ _ islimcone). intro v; specialize (hy v). revert hy. cbn. intro hy. apply (transportf_transpose_right (P:=(λ obj : C, C ⟦ obj, c' ⟧))). etrans. apply transport_source_precompose. unfold transportb. rewrite pathsinv0inv0. apply hy. Qed. Definition eq_diag_liftcolimcocone {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (eq_d : eq_diag d d') (cc:ColimCocone d ) : ColimCocone d' := make_ColimCocone _ _ _ (eq_diag_iscolimcocone _ eq_d (isColimCocone_from_ColimCocone cc)). Definition eq_diag_liftlimcone {C : category} {g : graph} {d : diagram g C} (d' : diagram g C) (eq_d : eq_diag d d') (cc:LimCone d ) : LimCone d' := make_LimCone _ _ _ (eq_diag_islimcone _ eq_d (isLimCone_LimCone cc)). UniMath-20231010/UniMath/CategoryTheory/limits/graphs/equalizers.v000066400000000000000000000272771451125700300250030ustar00rootroot00000000000000(** * Equalizers defined in terms of limits *) (** ** Contents - Definition of equalizers - Coincides with the direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.equalizers. Local Open Scope cat. (** * Definition of equalizers in terms of limits *) Section def_equalizers. Variable C : category. Let hs: has_homsets C := homset_property C. Open Scope stn. Definition One : two := ● 0. Definition Two : two := ● 1. Close Scope stn. Definition Equalizer_graph : graph. Proof. exists two. use (@two_rec (two -> UU)). - apply two_rec. + apply empty. + apply (unit ⨿ unit). - apply (λ _, empty). Defined. Definition Equalizer_diagram {a b : C} (f g : C⟦a, b⟧) : diagram Equalizer_graph C. Proof. exists (two_rec a b). use two_rec_dep. - use two_rec_dep; simpl. + apply fromempty. + intro x. induction x. exact f. exact g. - intro. apply fromempty. Defined. Definition Equalizer_cone {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) : cone (Equalizer_diagram f g) d. Proof. use make_cone. - use two_rec_dep. + exact h. + exact (h · f). - use two_rec_dep; use two_rec_dep. + exact (empty_rect _). + intro e. induction e. * apply idpath. * apply (! H). + exact (empty_rect _). + exact (empty_rect _). Defined. Definition isEqualizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) : UU := isLimCone (Equalizer_diagram f g) d (Equalizer_cone f g d h H). Definition make_isEqualizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) : (∏ e (h' : C⟦e, a⟧) (H' : h' · f = h' · g), iscontr (total2 (fun hk : C⟦e, d⟧ => hk · h = h'))) -> isEqualizer f g d h H. Proof. intros H' x cx. assert (H1 : coneOut cx One · f = coneOut cx One · g). { use (pathscomp0 (coneOutCommutes cx One Two (ii1 tt))). use (pathscomp0 _ (!(coneOutCommutes cx One Two (ii2 tt)))). apply idpath. } set (H2 := (H' x (coneOut cx One) H1)). use tpair. - use (tpair _ (pr1 (pr1 H2)) _). use two_rec_dep. + apply (pr2 (pr1 H2)). + use (pathscomp0 _ (coneOutCommutes cx One Two (ii1 tt))). change (coneOut (Equalizer_cone f g d h H) (● 1)%stn) with (h · f). rewrite assoc. apply cancel_postcomposition, (pr2 (pr1 H2)). - abstract (intro t; apply subtypePath; [ intros y; apply impred; intros t0; apply hs | induction t as [t p]; apply path_to_ctr, (p One)]). Defined. Definition Equalizer {a b : C} (f g : C⟦a, b⟧) := LimCone (Equalizer_diagram f g). Definition make_Equalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦d, a⟧) (H : h · f = h · g) (isEq : isEqualizer f g d h H) : Equalizer f g. Proof. use tpair. - use tpair. + exact d. + use Equalizer_cone. * exact h. * exact H. - exact isEq. Defined. Definition Equalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), Equalizer f g. Definition hasEqualizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), ishinh (Equalizer f g). Definition EqualizerObject {a b : C} {f g : C⟦a, b⟧} : Equalizer f g -> C := λ H, lim H. Definition EqualizerArrow {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) : C⟦lim E, a⟧ := limOut E One. Definition EqualizerArrowEq {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) : EqualizerArrow E · f = EqualizerArrow E · g. Proof. use (pathscomp0 (limOutCommutes E One Two (ii1 tt))). use (pathscomp0 _ (!(limOutCommutes E One Two (ii2 tt)))). apply idpath. Qed. Definition EqualizerIn {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) : C⟦e, lim E⟧. Proof. now use limArrow; use Equalizer_cone. Defined. Lemma EqualizerArrowComm {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) : EqualizerIn E e h H · EqualizerArrow E = h. Proof. exact (limArrowCommutes E e _ One). Qed. Lemma EqualizerInUnique {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) (w : C⟦e, lim E⟧) (H' : w · EqualizerArrow E = h) : w = EqualizerIn E e h H. Proof. apply path_to_ctr. use two_rec_dep. - apply H'. - set (X := limOutCommutes E One Two (ii1 tt)). apply (maponpaths (λ h : _, w · h)) in X. use (pathscomp0 (!X)); rewrite assoc. change (dmor _ _) with f. change (coneOut _ _) with (h · f). apply cancel_postcomposition, H'. Qed. Definition isEqualizer_Equalizer {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) : isEqualizer f g (EqualizerObject E) (EqualizerArrow E) (EqualizerArrowEq E). Proof. apply make_isEqualizer. intros e h H. use (unique_exists (EqualizerIn E e h H)). (* Commutativity *) - exact (EqualizerArrowComm E e h H). (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y t. cbn in t. use EqualizerInUnique. exact t. Qed. (** ** Equalizers to equalizers *) Definition identity_is_Equalizer_input {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) : total2 (fun hk : C⟦lim E, lim E⟧ => hk · EqualizerArrow E = EqualizerArrow E). Proof. use tpair. exact (identity _). apply id_left. Defined. Lemma EqualizerEndo_is_identity {a b : C} {f g : C⟦a, b⟧} (E : Equalizer f g) (k : C⟦lim E, lim E⟧) (kH : k · EqualizerArrow E = EqualizerArrow E) : identity (lim E) = k. Proof. apply lim_endo_is_identity. unfold limOut. use two_rec_dep; cbn. + apply kH. + set (X := (coneOutCommutes (limCone E) One Two (ii1 tt))). use (pathscomp0 (! (maponpaths (λ h' : _, k · h') X))). use (pathscomp0 _ X). rewrite assoc; change (dmor _ _) with f. apply cancel_postcomposition, kH. Qed. Definition from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) : C⟦lim E1, lim E2⟧. Proof. apply (EqualizerIn E2 (lim E1) (EqualizerArrow E1)). exact (EqualizerArrowEq E1). Defined. Lemma are_inverses_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) : is_inverse_in_precat (from_Equalizer_to_Equalizer E2 E1) (from_Equalizer_to_Equalizer E1 E2). Proof. split; apply pathsinv0. - apply EqualizerEndo_is_identity. rewrite <- assoc. unfold from_Equalizer_to_Equalizer. repeat rewrite EqualizerArrowComm. apply idpath. - apply EqualizerEndo_is_identity. rewrite <- assoc. unfold from_Equalizer_to_Equalizer. repeat rewrite EqualizerArrowComm. apply idpath. Qed. Lemma isiso_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) : is_iso (from_Equalizer_to_Equalizer E1 E2). Proof. apply (is_iso_qinv _ (from_Equalizer_to_Equalizer E2 E1)). apply are_inverses_from_Equalizer_to_Equalizer. Qed. Definition iso_from_Equalizer_to_Equalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Equalizer f g) : iso (lim E1) (lim E2) := tpair _ _ (isiso_from_Equalizer_to_Equalizer E1 E2). Lemma inv_from_iso_iso_from_Pullback {a b : C} {f g : C⟦a , b⟧} (E1 E2 : Equalizer f g): inv_from_iso (iso_from_Equalizer_to_Equalizer E1 E2) = from_Equalizer_to_Equalizer E2 E1. Proof. apply pathsinv0. apply inv_iso_unique'. apply (pr1 (are_inverses_from_Equalizer_to_Equalizer E2 E1)). Qed. (** ** Connections to other limits *) Lemma Equalizers_from_Lims : Lims C -> Equalizers. Proof. intros H a b f g. apply H. Defined. End def_equalizers. (** * Definitions coincide In this section we show that the definition of equalizer as a limit coincides with the direct definition. *) Section equalizers_coincide. Variable C : category. Let hs: has_homsets C := homset_property C. (** ** isEqualizers *) Lemma equiv_isEqualizer1 {a b : C} {f g : C⟦a, b⟧} (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) : limits.equalizers.isEqualizer f g h H -> isEqualizer C f g e h H. Proof. intros X. set (E := limits.equalizers.make_Equalizer f g h H X). use (make_isEqualizer C). intros e' h' H'. use (unique_exists (limits.equalizers.EqualizerIn E e' h' H')). (* Commutativity *) - exact (limits.equalizers.EqualizerCommutes E e' h' H'). (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. use (limits.equalizers.EqualizerInsEq E). use (pathscomp0 T). exact (!(limits.equalizers.EqualizerCommutes E e' h' H')). Qed. Lemma equiv_isEqualizer2 {a b : C} (f g : C⟦a, b⟧) (e : C) (h : C⟦e, a⟧) (H : h · f = h · g) : limits.equalizers.isEqualizer f g h H <- isEqualizer C f g e h H. Proof. intros X. set (E := make_Equalizer C f g e h H X). intros e' h' H'. use (unique_exists (EqualizerIn C E e' h' H')). (* Commutativity *) - exact (EqualizerArrowComm C E e' h' H'). (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. use (EqualizerInUnique C E). exact T. Qed. (** ** Equalizers *) Definition equiv_Equalizer1 {a b : C} (f g : C⟦a, b⟧) : limits.equalizers.Equalizer f g -> Equalizer C f g. Proof. intros E. exact (make_Equalizer C f g _ _ _ (equiv_isEqualizer1 (limits.equalizers.EqualizerObject E) (limits.equalizers.EqualizerArrow E) (limits.equalizers.EqualizerEqAr E) (limits.equalizers.isEqualizer_Equalizer E))). Defined. Definition equiv_Equalizers1 : @limits.equalizers.Equalizers C -> Equalizers C. Proof. intros E' a b f g. set (E := E' a b f g). exact (make_Equalizer C f g _ _ _ (equiv_isEqualizer1 (limits.equalizers.EqualizerObject E) (limits.equalizers.EqualizerArrow E) (limits.equalizers.EqualizerEqAr E) (limits.equalizers.isEqualizer_Equalizer E))). Defined. Definition equiv_Equalizer2 {a b : C} (f g : C⟦a, b⟧) : limits.equalizers.Equalizer f g <- Equalizer C f g. Proof. intros E. exact (@limits.equalizers.make_Equalizer C (EqualizerObject C E) a b f g (EqualizerArrow C E) (EqualizerArrowEq C E) (@equiv_isEqualizer2 a b f g (EqualizerObject C E) (EqualizerArrow C E) (EqualizerArrowEq C E) (isEqualizer_Equalizer C E))). Defined. Definition equiv_Equalizers2 : @limits.equalizers.Equalizers C <- Equalizers C. Proof. intros E' a b f g. set (E := E' a b f g). exact (@limits.equalizers.make_Equalizer C (EqualizerObject C E) a b f g (EqualizerArrow C E) (EqualizerArrowEq C E) (@equiv_isEqualizer2 a b f g (EqualizerObject C E) (EqualizerArrow C E) (EqualizerArrowEq C E) (isEqualizer_Equalizer C E))). Defined. End equalizers_coincide. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/initial.v000066400000000000000000000113111451125700300242260ustar00rootroot00000000000000(** Definition of initial object as a colimit *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.eqdiag. Require Import UniMath.CategoryTheory.limits.initial. Local Open Scope cat. Section def_initial. Context {C : category}. Definition empty_graph : graph. Proof. exists empty. exact (λ _ _, empty). Defined. Definition initDiagram : diagram empty_graph C. Proof. exists fromempty. intros u; induction u. Defined. (** All diagrams over the empty graph are equal *) Lemma empty_graph_eq_diag (d d' : diagram empty_graph C) : eq_diag d d'. Proof. use tpair; use empty_rect. Defined. Definition initCocone (c : C) : cocone initDiagram c. Proof. use make_cocone; intro v; induction v. Defined. Definition isInitial (a : C) := isColimCocone initDiagram a (initCocone a). (* ∏ b : C, iscontr (a --> b). *) Definition make_isInitial (a : C) (H : ∏ (b : C), iscontr (a --> b)) : isInitial a. Proof. intros b cb. use tpair. - exists (pr1 (H b)); intro v; induction v. - intro t. apply subtypePath; simpl; [intro; apply impred; intro v; induction v|]. apply (pr2 (H b)). Defined. Definition Initial : UU := ColimCocone initDiagram. (* total2 (λ a, isInitial a). *) Definition make_Initial (a : C) (H : isInitial a) : Initial. Proof. use (make_ColimCocone _ a (initCocone a)). apply make_isInitial. intro b. set (x := H b (initCocone b)). use tpair. - apply (pr1 x). - simpl; intro f; apply path_to_ctr; intro v; induction v. Defined. Definition InitialObject (O : Initial) : C := colim O. (* Coercion InitialObject : Initial >-> ob. *) Definition InitialArrow (O : Initial) (b : C) : C⟦InitialObject O,b⟧ := colimArrow _ _ (initCocone b). Lemma InitialArrowUnique (I : Initial) (a : C) (f : C⟦InitialObject I,a⟧) : f = InitialArrow I _. Proof. now apply colimArrowUnique; intro v; induction v. Defined. Lemma ArrowsFromInitial (I : Initial) (a : C) (f g : C⟦InitialObject I,a⟧) : f = g. Proof. eapply pathscomp0. apply InitialArrowUnique. now apply pathsinv0, InitialArrowUnique. Qed. Lemma InitialEndo_is_identity (O : Initial) (f : C⟦InitialObject O,InitialObject O⟧) : identity (InitialObject O) = f. Proof. now apply colim_endo_is_identity; intro u; induction u. Qed. Lemma isiso_from_Initial_to_Initial (O O' : Initial) : is_iso (InitialArrow O (InitialObject O')). Proof. apply (is_iso_qinv _ (InitialArrow O' (InitialObject O))). split; apply pathsinv0, InitialEndo_is_identity. Defined. Definition iso_Initials (O O' : Initial) : iso (InitialObject O) (InitialObject O') := tpair _ (InitialArrow O (InitialObject O')) (isiso_from_Initial_to_Initial O O') . Definition hasInitial := ishinh Initial. (* TODO: This should be an instance of a general result for colimits *) (* Section Initial_Unique. *) (* Hypothesis H : is_univalent C. *) (* Lemma isaprop_Initial : isaprop Initial. *) (* Proof. *) (* apply invproofirrelevance. *) (* intros O O'. *) (* apply (total2_paths_f (isotoid _ H (iso_Initials O O')) ). *) (* apply proofirrelevance. *) (* unfold isInitial. *) (* apply impred. *) (* intro t ; apply isapropiscontr. *) (* Qed. *) (* End Initial_Unique. *) Lemma isInitial_Initial (I : Initial) : isInitial (InitialObject I). Proof. use make_isInitial. intros b. use tpair. - exact (InitialArrow I b). - intros t. use (InitialArrowUnique I). Qed. (** ** Maps between initial as special colimit and direct definition *) Lemma equiv_isInitial1 (c : C) : limits.initial.isInitial C c -> isInitial c. Proof. intros X. use make_isInitial. intros b. apply (X b). Qed. Lemma equiv_isInitial2 (c : C) : limits.initial.isInitial C c <- isInitial c. Proof. intros X. set (XI := make_Initial c X). intros b. use tpair. - exact (InitialArrow XI b). - intros t. use (InitialArrowUnique XI b). Qed. Definition equiv_Initial1 (c : C) : limits.initial.Initial C -> Initial. Proof. intros I. use make_Initial. - exact I. - use equiv_isInitial1. exact (pr2 I). Defined. Definition equiv_Initial2 (c : C) : limits.initial.Initial C <- Initial. Proof. intros I. use limits.initial.make_Initial. - exact (InitialObject I). - use equiv_isInitial2. use (isInitial_Initial I). Defined. End def_initial. Arguments Initial : clear implicits. Arguments isInitial : clear implicits. Lemma Initial_from_Colims (C : category) : Colims_of_shape empty_graph C -> Initial C. Proof. now intros H; apply H. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/kernels.v000066400000000000000000000067461451125700300242600ustar00rootroot00000000000000(** * Kernels defined in terms of limits *) (** ** Contents - Definition coincides with the direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.graphs.zero. Require Import UniMath.CategoryTheory.limits.graphs.equalizers. Require Import UniMath.CategoryTheory.limits.kernels. (** * Definition of kernels in terms of limits *) Section def_kernels. Variable C : category. Let hs: has_homsets C := homset_property C. Variable Z : Zero C. Definition Kernel {a b : C} (f : C⟦a, b⟧) := Equalizer C f (ZeroArrow Z a b). (** ** Maps between Kernels as limits and direct definition. *) Lemma equiv_Kernel1_eq {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) : KernelArrow K · f = KernelArrow K · ZeroArrow Z a b. Proof. rewrite precomp_with_ZeroArrow. rewrite <- equiv_ZeroArrow. apply KernelCompZero. Qed. Lemma equiv_Kernel1_isEqualizer {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) : isEqualizer C f (ZeroArrow Z a b) K (KernelArrow K) (equiv_Kernel1_eq f K). Proof. use (make_isEqualizer _ ). intros e h' H'. use unique_exists. (* Construction of the morphism *) - use KernelIn. + exact h'. + rewrite precomp_with_ZeroArrow in H'. use (pathscomp0 _ (!(equiv_ZeroArrow e b Z))). exact H'. (* Commutativity *) - cbn. use KernelCommutes. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y X. cbn in X. use limits.kernels.KernelInsEq. unfold KernelArrow. use (pathscomp0 X). apply pathsinv0. use limits.kernels.KernelCommutes. Qed. Definition equiv_Kernel1 {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) : Kernel f. Proof. use make_Equalizer. - exact K. - exact (KernelArrow K). - exact (equiv_Kernel1_eq f K). - exact (equiv_Kernel1_isEqualizer f K). Defined. (* Other direction *) Lemma equiv_Kernel2_eq {a b : C} (f : C⟦a, b⟧) (K : Kernel f) : EqualizerArrow C K · f = limits.zero.ZeroArrow (equiv_Zero2 Z) (EqualizerObject C K) b. Proof. rewrite (EqualizerArrowEq C K). rewrite equiv_ZeroArrow. rewrite precomp_with_ZeroArrow. apply idpath. Qed. Lemma equiv_Kernel2_isEqualizer {a b : C} (f : C⟦a, b⟧) (K : Kernel f) : isKernel (equiv_Zero2 Z) (EqualizerArrow C K) f (equiv_Kernel2_eq f K). Proof. use (make_isKernel). intros w h H. use unique_exists. (* Construction of the morphism *) - use EqualizerIn. + exact h. + rewrite H. rewrite precomp_with_ZeroArrow. apply equiv_ZeroArrow. (* Commutativity *) - use EqualizerArrowComm. (* Equality on equalities of morphisms *) - intros y. apply hs. (* Uniqueness *) - intros y T. cbn in T. use EqualizerInUnique. exact T. Qed. Definition equiv_Kernel2 {a b : C} (f : C⟦a, b⟧) (K : Kernel f) : limits.kernels.Kernel (equiv_Zero2 Z) f. Proof. use make_Kernel. - exact (EqualizerObject C K). - exact (EqualizerArrow C K). - exact (equiv_Kernel2_eq f K). - exact (equiv_Kernel2_isEqualizer f K). Defined. End def_kernels. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/limits.v000066400000000000000000001164561451125700300241160ustar00rootroot00000000000000(** ************************************************* Contents: - Definition of limits - Proof that limits form a property in a (saturated/univalent) category ([isaprop_Lims]) - Pointwise construction of limits in functor precategories [LimsFunctorCategory] - Alternative definition of limits via colimits Written by: Benedikt Ahrens and Anders Mörtberg, 2015-2016 *****************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Local Open Scope cat. (** * Definition of limits *) Section lim_def. Definition forms_cone {C : precategory} {g : graph} (d : diagram g C) {c : C} (f : ∏ (v : vertex g), C⟦c, dob d v⟧) : UU := ∏ (u v : vertex g) (e : edge u v), f u · dmor d e = f v. (** better not the following: [Coercion coneOut : cone >-> Funclass.] *) Definition cone {C : precategory} {g : graph} (d : diagram g C) (c : C) : UU := ∑ (f : ∏ (v : vertex g), C⟦c,dob d v⟧), forms_cone d f. Definition make_cone {C : precategory} {g : graph} {d : diagram g C} {c : C} (f : ∏ v, C⟦c, dob d v⟧) (Hf : forms_cone d f) : cone d c := tpair _ f Hf. (** The injections to c in the cocone *) Definition coneOut {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) : ∏ v, C⟦c, dob d v⟧ := pr1 cc. Lemma coneOutCommutes {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) : forms_cone d (coneOut cc). Proof. apply (pr2 cc). Qed. Definition is_cone_mor {C : precategory} {g : graph} {d : diagram g C} {c1 : C} (cc1 : cone d c1) {c2 : C} (cc2 : cone d c2) (x : c1 --> c2) : UU := ∏ (v : vertex g), x · coneOut cc2 v = coneOut cc1 v. Definition isLimCone {C : precategory} {g : graph} (d : diagram g C) (c0 : C) (cc0 : cone d c0) : UU := ∏ (c : C) (cc : cone d c), iscontr (∑ x : C⟦c,c0⟧, is_cone_mor cc cc0 x). Definition LimCone {C : precategory} {g : graph} (d : diagram g C) : UU := ∑ (A : (∑ l, cone d l)), isLimCone d (pr1 A) (pr2 A). Definition make_LimCone {C : precategory} {g : graph} (d : diagram g C) (c : C) (cc : cone d c) (isCC : isLimCone d c cc) : LimCone d := tpair _ (tpair _ c cc) isCC. (** [lim] is the tip of the [LimCone] *) Definition lim {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : C := pr1 (pr1 CC). Definition limCone {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : cone d (lim CC) := pr2 (pr1 CC). Definition limOut {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : ∏ (v : vertex g), C⟦lim CC, dob d v⟧ := coneOut (limCone CC). Lemma limOutCommutes {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : forms_cone d (limOut CC). Proof. exact (coneOutCommutes (limCone CC)). Qed. Lemma limUnivProp {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : ∏ (c : C) (cc : cone d c), iscontr (∑ x : C⟦c, lim CC⟧, ∏ (v : vertex g), x · limOut CC v = coneOut cc v). Proof. apply (pr2 CC). Qed. Lemma isaprop_isLimCone {C : precategory} {g : graph} {d : diagram g C} (c0 : C) (cc0 : cone d c0) : isaprop (isLimCone d c0 cc0). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Definition isLimCone_LimCone {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) : isLimCone d (lim CC) (tpair _ (limOut CC) (limOutCommutes CC)) := pr2 CC. Definition limArrow {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) (c : C) (cc : cone d c) : C⟦c, lim CC⟧ := pr1 (pr1 (isLimCone_LimCone CC c cc)). Lemma limArrowCommutes {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) (c : C) (cc : cone d c) (u : vertex g) : limArrow CC c cc · limOut CC u = coneOut cc u. Proof. exact ((pr2 (pr1 (isLimCone_LimCone CC _ cc))) u). Qed. Lemma limArrowUnique {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) (c : C) (cc : cone d c) (k : C⟦c, lim CC⟧) (Hk : ∏ (u : vertex g), k · limOut CC u = coneOut cc u) : k = limArrow CC c cc. Proof. apply path_to_ctr. red. apply Hk. Qed. Lemma Cone_precompose {C : precategory} {g : graph} {d : diagram g C} {c : C} (cc : cone d c) (x : C) (f : C⟦x,c⟧) : ∏ u v (e : edge u v), (f · coneOut cc u) · dmor d e = f · coneOut cc v. Proof. now intros u v e; rewrite <- assoc, coneOutCommutes. Qed. Lemma limArrowEta {C : precategory} {g : graph} {d : diagram g C} (CC : LimCone d) (c : C) (f : C⟦c, lim CC⟧) : f = limArrow CC c (tpair _ (λ u, f · limOut CC u) (Cone_precompose (limCone CC) c f)). Proof. now apply limArrowUnique. Qed. Definition limOfArrows {C : precategory} {g : graph} {d1 d2 : diagram g C} (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) : C⟦lim CC1 , lim CC2⟧. Proof. apply limArrow; use make_cone. - now intro u; apply (limOut CC1 u · f u). - abstract (intros u v e; simpl; now rewrite <- assoc, fNat, assoc, limOutCommutes). Defined. Lemma limOfArrowsOut {C : precategory} {g : graph} (d1 d2 : diagram g C) (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) : ∏ u, limOfArrows CC1 CC2 f fNat · limOut CC2 u = limOut CC1 u · f u. Proof. now unfold limOfArrows; intro u; rewrite limArrowCommutes. Qed. Lemma postCompWithLimOfArrows_subproof {C : precategory} {g : graph} {d1 d2 : diagram g C} (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) (x : C) (cc : cone d1 x) u v (e : edge u v) : (coneOut cc u · f u) · dmor d2 e = coneOut cc v · f v. Proof. now rewrite <- (coneOutCommutes cc u v e), <- assoc, fNat, assoc. Defined. Lemma postCompWithLimOfArrows {C : precategory} {g : graph} (d1 d2 : diagram g C) (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f u · dmor d2 e = dmor d1 e · f v) (x : C) (cc : cone d1 x) : limArrow CC1 x cc · limOfArrows CC1 CC2 f fNat = limArrow CC2 x (make_cone (λ u, coneOut cc u · f u) (postCompWithLimOfArrows_subproof CC1 CC2 f fNat x cc)). Proof. apply limArrowUnique; intro u. now rewrite <- assoc, limOfArrowsOut, assoc, limArrowCommutes. Qed. Lemma postCompWithLimArrow {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (c : C) (cc : cone D c) (d : C) (k : C⟦d,c⟧) : k · limArrow CC c cc = limArrow CC d (make_cone (λ u, k · coneOut cc u) (Cone_precompose cc d k)). Proof. apply limArrowUnique. now intro u; rewrite <- assoc, limArrowCommutes. Qed. Lemma lim_endo_is_identity {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (k : lim CC --> lim CC) (H : ∏ u, k · limOut CC u = limOut CC u) : identity _ = k. Proof. use (uniqueExists (limUnivProp CC _ _)). - now apply (limCone CC). - intros v; simpl. unfold compose. simpl. now apply id_left. - simpl; now apply H. Qed. Lemma isLim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C) (cd : cone D d) : isLimCone D d cd -> is_z_isomorphism (limArrow CC d cd). Proof. intro H. set (CD := make_LimCone D d cd H). apply (tpair _ (limArrow (make_LimCone D d cd H) (lim CC) (limCone CC))). split. apply pathsinv0. change d with (lim CD). apply lim_endo_is_identity. simpl; intro u; rewrite <- assoc. eapply pathscomp0; [eapply maponpaths; apply limArrowCommutes|]. apply (limArrowCommutes CC). apply pathsinv0, (lim_endo_is_identity _ CC); simpl; intro u; rewrite <- assoc. eapply pathscomp0; [eapply maponpaths; apply (limArrowCommutes CC)|]. apply (limArrowCommutes CD). Defined. Lemma inv_isLim_is_z_iso {C : precategory} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C) (cd : cone D d) (H : isLimCone D d cd) : inv_from_z_iso (_,,isLim_is_z_iso D CC d cd H) = limArrow (make_LimCone D d cd H) _ (limCone CC). Proof. apply idpath. Qed. Lemma is_z_iso_isLim {C : category} {g : graph} (D : diagram g C) (CC : LimCone D) (d : C) (cd : cone D d) : is_z_isomorphism (limArrow CC d cd) -> isLimCone D d cd. Proof. intro H. set (iinv := z_iso_inv_from_is_z_iso _ H). intros x cx. use tpair. - use tpair. + exact (limArrow CC x cx·iinv). + simpl; intro u. assert (XR:=limArrowCommutes CC x cx u). eapply pathscomp0; [| apply XR]. eapply pathscomp0; [ apply (!assoc _ _ _ ) |]. apply maponpaths. apply z_iso_inv_on_right. apply pathsinv0, limArrowCommutes. - intros p; destruct p as [f Hf]. apply subtypePath. + intro a; apply impred; intro u; apply C. + simpl; apply z_iso_inv_on_left; simpl. apply pathsinv0, limArrowUnique; intro u. cbn in *. eapply pathscomp0; [| apply Hf]. eapply pathscomp0. apply (!assoc _ _ _ ). apply maponpaths. apply limArrowCommutes. Defined. (* Definition Cocone_by_postcompose {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d. Proof. now exists (λ u, coconeIn cc u · k); apply Cocone_postcompose. Defined. Lemma isColim_weq_subproof1 {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : ∏ u, coconeIn cc u · k = pr1 (Cocone_by_postcompose D c cc d k) u. Proof. now intro u. Qed. Lemma isColim_weq_subproof2 (g : graph) (D : diagram g C) (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d)) (d : C) (cd : cocone D d) (u : vertex g) : coconeIn cc u · invmap (make_weq _ (H d)) cd = coconeIn cd u. Proof. rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u). set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p. now rewrite p. Qed. Lemma isColim_weq {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) : isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d). Proof. split. - intros H d. refine (isweq_iso _ _ _ _). + intros k. exact (colimArrow (make_ColimCocone D c cc H) _ k). + abstract (intro k; simpl; now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))). + abstract (simpl; intro k; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | destruct k as [k Hk]; simpl; apply funextsec; intro u; now apply (colimArrowCommutes (make_ColimCocone D c cc H))]). - intros H d cd. refine (tpair _ _ _). + exists (invmap (make_weq _ (H d)) cd). abstract (intro u; now apply isColim_weq_subproof2). + abstract (intro t; apply total2_paths_second_isaprop; [ now apply impred; intro; apply hsC | destruct t as [t Ht]; simpl; apply (invmaponpathsweq (make_weq _ (H d))); simpl; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht; now apply isColim_weq_subproof2]]). Defined. *) Definition z_iso_from_lim_to_lim {C : precategory} {g : graph} {d : diagram g C} (CC CC' : LimCone d) : z_iso (lim CC) (lim CC'). Proof. use make_z_iso. - apply limArrow, limCone. - apply limArrow, limCone. - abstract (now split; apply pathsinv0, lim_endo_is_identity; intro u; rewrite <- assoc, limArrowCommutes; eapply pathscomp0; try apply limArrowCommutes). Defined. End lim_def. Arguments LimCone [_] {_} _. Section Lims. Definition Lims (C : precategory) : UU := ∏ (g : graph) (d : diagram g C), LimCone d. Definition hasLims (C : precategory) : UU := ∏ (g : graph) (d : diagram g C), ishinh (LimCone d). (** Limits of a specific shape *) Definition Lims_of_shape (g : graph) (C : precategory) : UU := ∏ (d : diagram g C), LimCone d. Section Universal_Unique. Variable (C : univalent_category). Let H : is_univalent C := pr2 C. Lemma isaprop_Lims : isaprop (Lims C). Proof. apply impred; intro g; apply impred; intro cc. apply invproofirrelevance; intros Hccx Hccy. apply subtypePath. - intro; apply isaprop_isLimCone. - apply (total2_paths_f (isotoid _ H (z_iso_from_lim_to_lim Hccx Hccy))). set (B c := ∏ v, C⟦c,dob cc v⟧). set (C' (c : C) f := forms_cone(c:=c) cc f). rewrite (@transportf_total2 _ B C'). apply subtypePath. + intro; repeat (apply impred; intro); apply univalent_category_has_homsets. + abstract (now simpl; eapply pathscomp0; [apply transportf_isotoid_dep'|]; apply funextsec; intro v; rewrite inv_isotoid, idtoiso_isotoid; cbn; apply limArrowCommutes). Qed. End Universal_Unique. End Lims. (** * Limits in functor categories *) Section LimFunctor. Context {A C : category} {g : graph} (D : diagram g [A, C]). Variable (HCg : ∏ (a : A), LimCone (diagram_pointwise D a)). Definition LimFunctor_ob (a : A) : C := lim (HCg a). Definition LimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) : C⟦LimFunctor_ob a,LimFunctor_ob a'⟧. Proof. use limOfArrows. - now intro u; apply (# (pr1 (dob D u)) f). - abstract (now intros u v e; simpl; apply (nat_trans_ax (# D e))). Defined. Definition LimFunctor_data : functor_data A C := tpair _ _ LimFunctor_mor. Lemma is_functor_LimFunctor_data : is_functor LimFunctor_data. Proof. split. - intro a; simpl. apply pathsinv0, lim_endo_is_identity; intro u. unfold LimFunctor_mor; rewrite limOfArrowsOut. assert (H : # (pr1 (dob D u)) (identity a) = identity (pr1 (dob D u) a)). apply (functor_id (dob D u) a). now rewrite H, id_right. - intros a b c fab fbc; simpl; unfold LimFunctor_mor. apply pathsinv0. eapply pathscomp0; [now apply postCompWithLimOfArrows|]. apply pathsinv0, limArrowUnique; intro u. rewrite limOfArrowsOut, (functor_comp (dob D u)); simpl. now rewrite <- assoc. Qed. Definition LimFunctor : functor A C := tpair _ _ is_functor_LimFunctor_data. Definition lim_nat_trans_in_data v : [A, C] ⟦ LimFunctor, dob D v ⟧. Proof. use tpair. - intro a; exact (limOut (HCg a) v). - abstract (intros a a' f; apply (limOfArrowsOut _ _ (HCg a) (HCg a'))). Defined. Definition cone_pointwise (F : [A,C]) (cc : cone D F) a : cone (diagram_pointwise D a) (pr1 F a). Proof. use make_cone. - now intro v; apply (pr1 (coneOut cc v) a). - abstract (intros u v e; now apply (nat_trans_eq_pointwise (coneOutCommutes cc u v e))). Defined. Lemma LimFunctor_unique (F : [A, C]) (cc : cone D F) : iscontr (∑ x : [A, C] ⟦ F, LimFunctor ⟧, ∏ v, x · lim_nat_trans_in_data v = coneOut cc v). Proof. use tpair. - use tpair. + apply (tpair _ (λ a, limArrow (HCg a) _ (cone_pointwise F cc a))). abstract (intros a a' f; simpl; apply pathsinv0; eapply pathscomp0; [ apply (postCompWithLimOfArrows _ _ (HCg a)) | apply pathsinv0; eapply pathscomp0; [ apply postCompWithLimArrow | apply limArrowUnique; intro u; eapply pathscomp0; [ now apply limArrowCommutes | now use nat_trans_ax]]]). + abstract (intro u; apply (nat_trans_eq C); simpl; intro a; now apply (limArrowCommutes (HCg a))). - abstract (intro t; destruct t as [t1 t2]; apply subtypePath; simpl; [ intro; apply impred; intro u; apply functor_category_has_homsets | apply (nat_trans_eq C); simpl; intro a; apply limArrowUnique; intro u; now apply (nat_trans_eq_pointwise (t2 u))]). Defined. Lemma LimFunctorCone : LimCone D. Proof. use make_LimCone. - exact LimFunctor. - use make_cone. + now apply lim_nat_trans_in_data. + abstract (now intros u v e; apply (nat_trans_eq C); intro a; apply (limOutCommutes (HCg a))). - now intros F cc; simpl; apply (LimFunctor_unique _ cc). Defined. Definition isLimFunctor_is_pointwise_Lim (X : [A,C]) (R : cone D X) (H : isLimCone D X R) : ∏ a, isLimCone (diagram_pointwise D a) _ (cone_pointwise X R a). Proof. intro a. apply (is_z_iso_isLim _ (HCg a)). set (XR := isLim_is_z_iso D LimFunctorCone X R H). apply (nat_trafo_pointwise_z_iso_if_z_iso _ _ XR). Defined. End LimFunctor. Lemma LimsFunctorCategory (A C : category) (HC : Lims C) : Lims [A,C]. Proof. now intros g d; apply LimFunctorCone. Defined. Lemma LimsFunctorCategory_of_shape (g : graph) (A C : category) (HC : Lims_of_shape g C) : Lims_of_shape g [A,C]. Proof. now intros d; apply LimFunctorCone. Defined. Lemma pointwise_Lim_is_isLimFunctor {A C : category} {g : graph} (d : diagram g [A,C]) (G : [A,C]) (cG : cone d G) (H : ∏ a, isLimCone _ _ (cone_pointwise d G cG a)) : isLimCone d G cG. Proof. set (CC a := make_LimCone _ _ _ (H a)). set (D' := LimFunctorCone _ CC). use is_z_iso_isLim. - apply D'. - use tpair. + use make_nat_trans. * intros a; apply identity. * abstract ( intros a b f; rewrite id_left, id_right; apply pathsinv0 ; apply (limArrowUnique (CC b) (lim (CC a))) ; intro u ; cbn ; now rewrite <- (nat_trans_ax (coneOut cG u)) ). + abstract (split; [ apply (nat_trans_eq C); intros x; simpl; rewrite id_right; apply pathsinv0, (limArrowUnique (CC x)); intros v; now rewrite id_left | apply (nat_trans_eq C); intros x; simpl; rewrite id_left; apply pathsinv0, (limArrowUnique (CC x)); intro u; now rewrite id_left]). Defined. Section map. Context {C D : category} (F : functor C D). Definition mapcone {g : graph} (d : diagram g C) {x : C} (dx : cone d x) : cone (mapdiagram F d) (F x). Proof. use make_cone. - simpl; intro n. exact (#F (coneOut dx n)). - abstract (intros u v e; simpl; rewrite <- functor_comp; apply maponpaths, (coneOutCommutes dx _ _ e)). Defined. Definition preserves_limit {g : graph} (d : diagram g C) (L : C) (cc : cone d L) : UU := isLimCone d L cc -> isLimCone (mapdiagram F d) (F L) (mapcone d cc). (** ** Right adjoints preserve limits *) Lemma right_adjoint_preserves_limit (HF : is_right_adjoint F) {g : graph} (d : diagram g C) (L : C) (ccL : cone d L) : preserves_limit d L ccL. Proof. intros HccL M ccM. set (G := left_adjoint HF). set (H := pr2 HF : are_adjoints G F). apply (@iscontrweqb _ (∑ y : C ⟦ G M, L ⟧, ∏ i, y · coneOut ccL i = φ_adj_inv H (coneOut ccM i))). - eapply (weqcomp (Y := ∑ y : C ⟦ G M, L ⟧, ∏ i, φ_adj H y · # F (coneOut ccL i) = coneOut ccM i)). + apply invweq, (weqbandf (adjunction_hom_weq H M L)); simpl; intro f. abstract (now apply weqiff; try (apply impred; intro; apply D)). + eapply (weqcomp (Y := ∑ y : C ⟦ G M, L ⟧, ∏ i, φ_adj H (y · coneOut ccL i) = coneOut ccM i)). * apply weqfibtototal; simpl; intro f. abstract (apply weqiff; try (apply impred; intro; apply D); split; intros HH i; [ now rewrite φ_adj_natural_postcomp; apply HH | now rewrite <- φ_adj_natural_postcomp; apply HH ]). * apply weqfibtototal; simpl; intro f. abstract (apply weqiff; [ | apply impred; intro; apply D | apply impred; intro; apply C ]; split; intros HH i; [ now rewrite <- (HH i), φ_adj_inv_after_φ_adj | now rewrite (HH i), φ_adj_after_φ_adj_inv ]). - transparent assert (X : (cone d (G M))). { use make_cone. + intro v; apply (φ_adj_inv H (coneOut ccM v)). + intros m n e; simpl. rewrite <- (coneOutCommutes ccM m n e); simpl. now rewrite φ_adj_inv_natural_postcomp. } apply (HccL (G M) X). Defined. End map. Section Reflects. Context {C D : category} (F : functor C D). Definition reflects_limits_of_shape (g : graph) : UU := ∏ (d : diagram g C) (L : ob C) cc, isLimCone (mapdiagram F d) (F L) (mapcone F d cc) -> isLimCone d L cc. Definition reflects_all_limits : UU := ∏ (g : graph), reflects_limits_of_shape g. (** Fully faithful functors reflect limits of any given shape. *) Lemma fully_faithful_reflects_all_limits (fff : fully_faithful F) : reflects_all_limits. Proof. intros g d L cc isLimConeImL. unfold isLimCone in *. intros L' cc'. unfold fully_faithful in fff. apply (@iscontrweqf (∑ x : D ⟦ F L', F L ⟧, ∏ v : vertex g, x · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)). - apply (@weqcomp _ (∑ x : C ⟦ L', L ⟧, ∏ v : vertex g, # F x · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)). + apply invweq. apply (weqfp (weq_from_fully_faithful fff _ _) (λ f, ∏ v, f · coneOut (mapcone F d cc) v = coneOut (mapcone F d cc') v)). + apply weqfibtototal; intro f. apply weqonsecfibers; intro v. unfold mapcone; cbn. apply invweq. apply fully_faithful_commutative_triangle_weq. assumption. - apply isLimConeImL. Qed. End Reflects. (** * Definition of limits via colimits *) (** Put in a module for namespace reasons *) Require UniMath.CategoryTheory.opp_precat. Module co. Import UniMath.CategoryTheory.opp_precat. Section lim_def. Context (C : category). (* A cone with tip c over a diagram d *) (* Definition cocone {g : graph} (d : diagram g C) (c : C) : UU := ∑ (f : ∏ (v : vertex g), C⟦dob d v,c⟧), ∏ (u v : vertex g) (e : edge u v), dmor d e · f v = f u. *) Definition opp_diagram g C := diagram g C^op. Definition cone {g : graph} (d : diagram g C^op) (c : C) : UU := @cocone C^op g d c. (* Definition make_cocone {g : graph} {d : diagram g C} {c : C} (f : ∏ v, C⟦dob d v,c⟧) (Hf : ∏ u v e, dmor d e · f v = f u) : cocone d c := tpair _ f Hf. *) Definition make_cone {g : graph} {d : diagram g C^op} {c : C} (f : ∏ v, C⟦c, dob d v⟧) (Hf : ∏ u v (e : edge u v) , f v · dmor d e = f u) : cone d c := tpair _ f Hf. (* The injections to c in the cocone *) Definition coneOut {g : graph} {d : diagram g C^op} {c : C} (cc : cone d c) : ∏ v, C⟦c, dob d v⟧ := coconeIn cc. Lemma coneOutCommutes {g : graph} {d : diagram g C^op} {c : C} (cc : cone d c) : ∏ u v (e : edge u v), coneOut cc v · dmor d e = coneOut cc u. Proof. apply (coconeInCommutes cc). Qed. (* cc0 is a colimit cocone if for any other cocone cc over the same diagram there is a unique morphism from the tip of cc0 to the tip of cc *) Definition isLimCone {g : graph} (d : diagram g C^op) (c0 : C) (cc0 : cone d c0) : UU := isColimCocone _ _ cc0. (* ∏ (c : C) (cc : cone d c), isColimCocone iscontr (∑ x : C⟦c0,c⟧, ∏ v, coconeIn cc0 v · x = coconeIn cc v). *) Definition LimCone {g : graph} (d : diagram g C^op) : UU := ColimCocone d. Definition make_LimCone {g : graph} (d : diagram g C^op) (c : C) (cc : cone d c) (isCC : isLimCone d c cc) : LimCone d. Proof. use make_ColimCocone. - apply c. - apply cc. - apply isCC. Defined. Definition Lims : UU := ∏ (g : graph) (d : diagram g C^op), LimCone d. Definition hasLims : UU := ∏ (g : graph) (d : diagram g C^op), ishinh (LimCone d). (* lim is the tip of the lim cone *) Definition lim {g : graph} {d : diagram g C^op} (CC : LimCone d) : C := colim CC. Definition limCone {g : graph} {d : diagram g C^op} (CC : LimCone d) : cone d (lim CC) := colimCocone CC. Definition limOut {g : graph} {d : diagram g C^op} (CC : LimCone d) : ∏ (v : vertex g), C⟦lim CC, dob d v⟧ := coneOut (limCone CC). Lemma limOutCommutes {g : graph} {d : diagram g C^op} (CC : LimCone d) : ∏ (u v : vertex g) (e : edge u v), limOut CC v · dmor d e = limOut CC u. Proof. exact (coneOutCommutes (limCone CC)). Qed. Lemma limUnivProp {g : graph} {d : diagram g C^op} (CC : LimCone d) : ∏ (c : C) (cc : cone d c), iscontr (∑ x : C⟦c, lim CC⟧, ∏ (v : vertex g), x · limOut CC v = coneOut cc v). Proof. apply (colimUnivProp CC). Qed. Definition isLimCone_LimCone {g : graph} {d : diagram g C^op} (CC : LimCone d) : isLimCone d (lim CC) (tpair _ (limOut CC) (limOutCommutes CC)) := isColimCocone_from_ColimCocone CC. Definition limArrow {g : graph} {d : diagram g C^op} (CC : LimCone d) (c : C) (cc : cone d c) : C⟦c, lim CC⟧. Proof. exact (colimArrow CC _ cc). Defined. Lemma limArrowCommutes {g : graph} {d : diagram g C^op} (CC : LimCone d) (c : C) (cc : cone d c) (u : vertex g) : limArrow CC c cc · limOut CC u = coneOut cc u. Proof. exact (colimArrowCommutes CC _ cc _ ). Qed. Lemma limArrowUnique {g : graph} {d : diagram g C^op} (CC : LimCone d) (c : C) (cc : cone d c) (k : C⟦c, lim CC⟧) (Hk : ∏ (u : vertex g), k · limOut CC u = coneOut cc u) : k = limArrow CC c cc. Proof. apply (colimArrowUnique CC c cc k Hk). Qed. Lemma Cone_precompose {g : graph} {d : diagram g C^op} {c : C} (cc : cone d c) (x : C) (f : C⟦x,c⟧) : ∏ u v (e : edge u v), (f · coneOut cc v) · dmor d e = f · coneOut cc u. Proof. apply (Cocone_postcompose cc x f). Qed. Lemma limArrowEta {g : graph} {d : diagram g C^op} (CC : LimCone d) (c : C) (f : C⟦c, lim CC⟧) : f = limArrow CC c (tpair _ (λ u, f · limOut CC u) (Cone_precompose (limCone CC) c f)). Proof. now apply limArrowUnique. Qed. Definition limOfArrows {g : graph} {d1 d2 : diagram g C^op} (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f v · (dmor d2 e : C⟦dob d2 v, dob d2 u⟧) = (dmor d1 e : C⟦dob d1 v, dob d1 u⟧)· f u) : C⟦lim CC1 , lim CC2⟧. Proof. use (colimOfArrows CC2 CC1). - apply f. - apply fNat. Defined. Lemma limOfArrowsOut {g : graph} (d1 d2 : diagram g C^op) (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧) · f u) : ∏ u, limOfArrows CC1 CC2 f fNat · limOut CC2 u = limOut CC1 u · f u. Proof. apply (colimOfArrowsIn _ _ CC2 CC1 f fNat). Qed. Lemma postCompWithLimOfArrows_subproof {g : graph} {d1 d2 : diagram g C^op} (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧) · f u) (x : C) (cc : cone d1 x) u v (e : edge u v) : (coneOut cc v · f v) · dmor d2 e = coneOut cc u · f u. Proof. apply (preCompWithColimOfArrows_subproof CC2 CC1 f fNat x cc _ _ e). Defined. Lemma postcompWithColimOfArrows {g : graph} (d1 d2 : diagram g C^op) (CC1 : LimCone d1) (CC2 : LimCone d2) (f : ∏ (u : vertex g), C⟦dob d1 u,dob d2 u⟧) (fNat : ∏ u v (e : edge u v), f v · dmor d2 e = (dmor d1 e : C ⟦ _ , _ ⟧) · f u) (x : C) (cc : cone d1 x) : limArrow CC1 x cc · limOfArrows CC1 CC2 f fNat = limArrow CC2 x (make_cone (λ u, coneOut cc u · f u) (postCompWithLimOfArrows_subproof CC1 CC2 f fNat x cc)). Proof. apply limArrowUnique. intro. rewrite <- assoc. rewrite limOfArrowsOut. rewrite assoc. rewrite limArrowCommutes. apply idpath. Qed. Lemma precompWithLimArrow {g : graph} (D : diagram g C^op) (CC : LimCone D) (c : C) (cc : cone D c) (d : C) (k : C⟦d,c⟧) : k · limArrow CC c cc = limArrow CC d (make_cone (λ u, k · coneOut cc u) (Cone_precompose cc d k)). Proof. apply limArrowUnique. now intro u; rewrite <- assoc, limArrowCommutes. Qed. Lemma lim_endo_is_identity {g : graph} (D : diagram g C^op) (CC : LimCone D) (k : lim CC --> lim CC) (H : ∏ u, k · limOut CC u = limOut CC u) : identity _ = k. Proof. use (uniqueExists (limUnivProp CC _ _)). - now apply (limCone CC). - intros v; simpl. unfold compose. simpl. now apply id_left. - simpl; now apply H. Qed. (* Definition Cocone_by_postcompose {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : cocone D d. Proof. now exists (λ u, coconeIn cc u · k); apply Cocone_postcompose. Defined. Lemma isColim_weq_subproof1 {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) (d : C) (k : C⟦c,d⟧) : ∏ u, coconeIn cc u · k = pr1 (Cocone_by_postcompose D c cc d k) u. Proof. now intro u. Qed. Lemma isColim_weq_subproof2 (g : graph) (D : diagram g C) (c : C) (cc : cocone D c) (H : ∏ d, isweq (Cocone_by_postcompose D c cc d)) (d : C) (cd : cocone D d) (u : vertex g) : coconeIn cc u · invmap (make_weq _ (H d)) cd = coconeIn cd u. Proof. rewrite (isColim_weq_subproof1 D c cc d (invmap (make_weq _ (H d)) _) u). set (p := homotweqinvweq (make_weq _ (H d)) cd); simpl in p. now rewrite p. Qed. Lemma isColim_weq {g : graph} (D : diagram g C) (c : C) (cc : cocone D c) : isColimCocone D c cc <-> ∏ d, isweq (Cocone_by_postcompose D c cc d). Proof. split. - intros H d. refine (isweq_iso _ _ _ _). + intros k. exact (colimArrow (make_ColimCocone D c cc H) _ k). + abstract (intro k; simpl; now apply pathsinv0, (colimArrowEta (make_ColimCocone D c cc H))). + abstract (simpl; intro k; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | destruct k as [k Hk]; simpl; apply funextsec; intro u; now apply (colimArrowCommutes (make_ColimCocone D c cc H))]). - intros H d cd. refine (tpair _ _ _). + exists (invmap (make_weq _ (H d)) cd). abstract (intro u; now apply isColim_weq_subproof2). + abstract (intro t; apply total2_paths_second_isaprop; [ now apply impred; intro; apply hsC | destruct t as [t Ht]; simpl; apply (invmaponpathsweq (make_weq _ (H d))); simpl; apply total2_paths_second_isaprop; [ now repeat (apply impred; intro); apply hsC | simpl; apply pathsinv0, funextsec; intro u; rewrite Ht; now apply isColim_weq_subproof2]]). Defined. *) Lemma isLim_is_z_iso {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C) (cd : cone D d) : isLimCone D d cd -> is_z_isomorphism (limArrow CC d cd). Proof. intro H. set (CD := make_LimCone D d cd H). apply (tpair _ (limArrow (make_LimCone D d cd H) (lim CC) (limCone CC))). split. apply pathsinv0. change d with (lim CD). apply lim_endo_is_identity. simpl; intro u; rewrite <- assoc. eapply pathscomp0; [eapply maponpaths; apply limArrowCommutes|]. apply (limArrowCommutes CC). apply pathsinv0, (lim_endo_is_identity _ CC); simpl; intro u; rewrite <- assoc. eapply pathscomp0; [eapply maponpaths; apply (limArrowCommutes CC)|]. apply (limArrowCommutes CD). Defined. Lemma inv_isLim_is_iso {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C) (cd : cone D d) (H : isLimCone D d cd) : inv_from_z_iso (_,,isLim_is_z_iso D CC d cd H) = limArrow (make_LimCone D d cd H) _ (limCone CC). Proof. apply idpath. Qed. Lemma is_z_iso_isLim {g : graph} (D : diagram g C^op) (CC : LimCone D) (d : C) (cd : cone D d) : is_z_isomorphism (limArrow CC d cd) -> isLimCone D d cd. Proof. intro H. set (iinv := z_iso_inv_from_is_z_iso _ H). intros x cx. use tpair. - use tpair. + exact (limArrow CC x cx · iinv). + simpl; intro u. assert (XR := limArrowCommutes CC x cx u). eapply pathscomp0; [| apply XR]. etrans. { use assoc. } apply (maponpaths (fun f => compose(C:=C^op) f (limArrow CC x cx))). apply (z_iso_inv_on_right(C:=C)). apply pathsinv0, limArrowCommutes. - intros p; destruct p as [f Hf]. apply subtypePath. + intro a; apply impred; intro u; apply C. + simpl; apply z_iso_inv_on_left; simpl. apply pathsinv0, limArrowUnique; intro u. cbn in *. eapply pathscomp0; [| apply Hf]. eapply pathscomp0. apply (!assoc _ _ _ ). apply (maponpaths (fun f' => compose(C:=C^op) f' f)). apply limArrowCommutes. Defined. End lim_def. Arguments Lims : clear implicits. Section LimFunctor. Definition get_diagram (A C : category) (g : graph) (D : diagram g [A, C]^op) : diagram g [A^op, C^op]. Proof. apply (tpair _ (λ u, from_opp_to_opp_opp _ _ _ (pr1 D u))). intros u v e; simpl. use tpair; simpl. + apply (pr2 D _ _ e). + abstract (intros a b f; apply pathsinv0, (pr2 (pr2 D u v e) b a f)). Defined. Definition get_cocone (A C : category) (g : graph) (D : diagram g [A, C]^op) (F : functor A C) (ccF : cocone D F) : cocone (get_diagram A C g D) (functor_opp F). Proof. destruct ccF as [t p]. (* If I remove this destruct the Qed for LimsFunctorCategory takes twice as long *) use make_cocone. - intro u; apply (tpair _ (pr1 (t u))). abstract (intros a b f; apply pathsinv0, (pr2 (t u) b a f)). - abstract (intros u v e; apply (nat_trans_eq C^op ); now intro a; simpl; rewrite <- (p u v e)). Defined. Lemma LimFunctorCone (A C : category) (g : graph) (D : diagram g [A, C]^op) (HC : ∏ a : A^op, LimCone _ (diagram_pointwise (get_diagram A C g D) a)) : LimCone _ D. Proof. set (HColim := ColimFunctorCocone (get_diagram _ _ _ D) HC). destruct HColim as [pr1x pr2x]. destruct pr1x as [pr1pr1x pr2pr1x]. destruct pr2pr1x as [pr1pr2pr1x pr2pr2pr1x]. simpl in *. use (make_ColimCocone _ (from_op_op_to_op _ _ pr1pr1x)). - use make_cocone. + simpl; intros. use tpair. * intro a; apply (pr1pr2pr1x v a). * abstract (intros a b f; apply pathsinv0, (nat_trans_ax (pr1pr2pr1x v) (*b a f*))). + abstract (intros u v e; apply (nat_trans_eq C); simpl; intro a; now rewrite <- (pr2pr2pr1x u v e)). - intros F ccF. set (H := pr2x (from_opp_to_opp_opp _ _ _ F) (get_cocone _ _ _ _ _ ccF)). destruct H as [H1 H2]. destruct H1 as [α Hα]. simpl in *. use tpair. + use tpair. * exists α. abstract (intros a b f; simpl; now apply pathsinv0, (nat_trans_ax α b a f)). * abstract (intro u; apply (nat_trans_eq C); intro a; destruct ccF as [t p]; apply (toforallpaths _ _ _ (maponpaths pr1 (Hα u)) a)). + intro H; destruct H as [f Hf]; apply subtypePath. * abstract (intro β; repeat (apply impred; intro); now apply (has_homsets_opp (functor_category_has_homsets A C C))). * match goal with |[ H2 : ∏ _ : ?TT , _ = _ ,,_ |- _ ] => transparent assert (T : TT) end. (* refine (let T : ∑ x : nat_trans pr1pr1x (functor_opp F), ∏ v, nat_trans_comp (functor_opp (pr1 D v)) _ _ (pr1pr2pr1x v) x = coconeIn (get_cocone A C hsC g D F ccF) v := _ in _). *) { use (tpair _ (tpair _ (pr1 f) _)); simpl. - abstract (intros x y fxy; apply pathsinv0, (pr2 f y x fxy)). - abstract (intro u; apply (nat_trans_eq (has_homsets_opp C)); intro x; destruct ccF as [t p]; apply (toforallpaths _ _ _ (maponpaths pr1 (Hf u)) x)). } set (T' := maponpaths pr1 (H2 T)); simpl in T'. apply (nat_trans_eq C); intro a; simpl. now rewrite <- T'. Defined. End LimFunctor. (* (* Defines colimits in functor categories when the target has colimits *) Section ColimFunctor. Variable A C : precategory. Variable HC : Colims C. Variable hsC : has_homsets C. Variable g : graph. Variable D : diagram g [A, C, hsC]. Definition diagram_pointwise (a : A) : diagram g C. Proof. exists (λ v, pr1 (dob D v) a); intros u v e. now apply (pr1 (dmor D e) a). Defined. Let HCg a := HC g (diagram_pointwise a). Definition ColimFunctor_ob (a : A) : C := colim (HCg a). Definition ColimFunctor_mor (a a' : A) (f : A⟦a, a'⟧) : C⟦ColimFunctor_ob a,ColimFunctor_ob a'⟧. Proof. refine (colimOfArrows _ _ _ _). - now intro u; apply (# (pr1 (dob D u)) f). - abstract (now intros u v e; simpl; apply pathsinv0, (nat_trans_ax (dmor D e))). Defined. Definition ColimFunctor_data : functor_data A C := tpair _ _ ColimFunctor_mor. Lemma is_functor_ColimFunctor_data : is_functor ColimFunctor_data. Proof. split. - intro a; simpl. apply pathsinv0, colim_endo_is_identity; intro u. unfold ColimFunctor_mor. now rewrite colimOfArrowsIn, (functor_id (dob D u)), id_left. - intros a b c fab fbc; simpl; unfold ColimFunctor_mor. apply pathsinv0. eapply pathscomp0; [now apply precompWithColimOfArrows|]. apply pathsinv0, colimArrowUnique; intro u. rewrite colimOfArrowsIn. rewrite (functor_comp (dob D u)). now apply pathsinv0, assoc. Qed. Definition ColimFunctor : functor A C := tpair _ _ is_functor_ColimFunctor_data. Definition colim_nat_trans_in_data v : [A, C, hsC] ⟦ dob D v, ColimFunctor ⟧. Proof. refine (tpair _ _ _). - intro a; exact (colimIn (HCg a) v). - abstract (intros a a' f; now apply pathsinv0, (colimOfArrowsIn _ _ (HCg a) (HCg a'))). Defined. Definition cocone_pointwise (F : [A,C,hsC]) (cc : cocone D F) a : cocone (diagram_pointwise a) (pr1 F a). Proof. refine (make_cocone _ _). - now intro v; apply (pr1 (coconeIn cc v) a). - abstract (intros u v e; now apply (nat_trans_eq_pointwise (coconeInCommutes cc u v e))). Defined. Lemma ColimFunctor_unique (F : [A, C, hsC]) (cc : cocone D F) : iscontr (∑ x : [A, C, hsC] ⟦ ColimFunctor, F ⟧, ∏ v : vertex g, colim_nat_trans_in_data v · x = coconeIn cc v). Proof. refine (tpair _ _ _). - refine (tpair _ _ _). + apply (tpair _ (λ a, colimArrow (HCg a) _ (cocone_pointwise F cc a))). abstract (intros a a' f; simpl; eapply pathscomp0; [ now apply precompWithColimOfArrows | apply pathsinv0; eapply pathscomp0; [ now apply postcompWithColimArrow | apply colimArrowUnique; intro u; eapply pathscomp0; [ now apply colimArrowCommutes | now apply pathsinv0, nat_trans_ax ]]]). + abstract (intro u; apply (nat_trans_eq hsC); simpl; intro a; now apply (colimArrowCommutes (HCg a))). - abstract (intro t; destruct t as [t1 t2]; apply (total2_paths_second_isaprop); simpl; [ apply impred; intro u; apply functor_category_has_homsets | apply (nat_trans_eq hsC); simpl; intro a; apply colimArrowUnique; intro u; now apply (nat_trans_eq_pointwise (t2 u))]). Defined. Lemma ColimFunctorCocone : ColimCocone D. Proof. refine (make_ColimCocone _ _ _ _). - exact ColimFunctor. - refine (make_cocone _ _). + now apply colim_nat_trans_in_data. + abstract (now intros u v e; apply (nat_trans_eq hsC); intro a; apply (colimInCommutes (HCg a))). - now intros F cc; simpl; apply (ColimFunctor_unique _ cc). Defined. End ColimFunctor. Lemma ColimsFunctorCategory (A C : precategory) (hsC : has_homsets C) (HC : Colims C) : Colims [A,C,hsC]. Proof. now intros g d; apply ColimFunctorCocone. Defined. *) End co. (** Equality of arrows into limits *) Definition arr_to_LimCone_eq {C : category} {g : graph} {D : diagram g C} (l : LimCone D) {x : C} {f₁ f₂ : x --> pr11 l} (p : ∏ (i : vertex g), f₁ · limOut l i = f₂ · limOut l i) : f₁ = f₂. Proof. refine (limArrowEta _ _ _ @ _ @ !(limArrowEta _ _ _)). apply maponpaths. use subtypePath. { intro. repeat (use impred ; intro). apply homset_property. } use funextsec. exact p. Qed. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/pullbacks.v000066400000000000000000000416051451125700300245660ustar00rootroot00000000000000(** Pullbacks defined in terms of limits *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require UniMath.CategoryTheory.limits.pullbacks. Local Open Scope cat. Section def_pb. Variable C : category. Local Open Scope stn. Definition One : three := ● 0. Definition Two : three := ● 1. Definition Three : three := ● 2. Definition pullback_graph : graph. Proof. exists three. use three_rec. - apply three_rec. + apply empty. + apply unit. + apply empty. - apply (λ _, empty). - apply three_rec. + apply empty. + apply unit. + apply empty. Defined. Definition pullback_diagram {a b c : C} (f : C ⟦b,a⟧) (g : C⟦c,a⟧) : diagram pullback_graph C. Proof. exists (three_rec b a c). use three_rec_dep. - use three_rec_dep; simpl. + apply fromempty. + intro x; assumption. + apply fromempty. - intro x; apply fromempty. - use three_rec_dep; simpl. + apply fromempty. + intro x; assumption. + apply fromempty. Defined. Definition PullbCone {a b c : C} (f : C ⟦b,a⟧) (g : C⟦c,a⟧) (d : C) (f' : C ⟦d, b⟧) (g' : C ⟦d,c⟧) (H : f' · f = g'· g) : cone (pullback_diagram f g) d. Proof. use make_cone. - use three_rec_dep; try assumption. apply (f' · f). - use three_rec_dep; use three_rec_dep. + exact (empty_rect _ ). + intro x; apply idpath. + exact (empty_rect _ ). + exact (empty_rect _ ). + exact (empty_rect _ ). + exact (empty_rect _ ). + exact (empty_rect _ ). + intro x; apply (!H). + exact (empty_rect _ ). Defined. Definition isPullback {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) : UU := isLimCone (pullback_diagram f g) d (PullbCone f g d p1 p2 H). (* ∏ e (h : e --> b) (k : e --> c)(H : h · f = k · g ), iscontr (total2 (fun hk : e --> d => dirprod (hk · p1 = h)(hk · p2 = k))). *) Definition make_isPullback {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) : (∏ e (h : C ⟦e, b⟧) (k : C⟦e,c⟧)(Hk : h · f = k · g ), iscontr (total2 (fun hk : C⟦e,d⟧ => dirprod (hk · p1 = h)(hk · p2 = k)))) → isPullback f g p1 p2 H. Proof. intros H' x cx; simpl in *. set (H1 := H' x (coneOut cx One) (coneOut cx Three) ). use (let p : coneOut cx One · f = coneOut cx Three · g := _ in _ ). { eapply pathscomp0; [apply (coneOutCommutes cx One Two tt)|]. apply pathsinv0, (coneOutCommutes cx Three Two tt). } set (H2 := H1 p). use tpair. + exists (pr1 (pr1 H2)). use three_rec_dep. * apply (pr1 (pr2 (pr1 H2))). * simpl. change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f). rewrite assoc. eapply pathscomp0. eapply cancel_postcomposition, (pr2 (pr1 H2)). apply (coneOutCommutes cx One Two tt). * apply (pr2 (pr2 (pr1 H2))). + abstract (intro t; apply subtypePath; [ intro; apply impred; intro; apply C | destruct t as [t p0]; apply path_to_ctr; split; [ apply (p0 One) | apply (p0 Three) ]]). Defined. (* Lemma isaprop_isPullback {a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) : isaprop (isPullback f g p1 p2 H). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. *) Definition Pullback {a b c : C} (f : C⟦b, a⟧)(g : C⟦c, a⟧) := LimCone (pullback_diagram f g). Definition make_Pullback {a b c : C} (f : C⟦b, a⟧)(g : C⟦c, a⟧) (d : C) (p1 : C⟦d,b⟧) (p2 : C ⟦d,c⟧) (H : p1 · f = p2 · g) (ispb : isPullback f g p1 p2 H) : Pullback f g. Proof. use tpair. - use tpair. + apply d. + use PullbCone; assumption. - apply ispb. Defined. (* Definition Pullback {a b c : C} (f : b --> a)(g : c --> a) := total2 (fun pfg : total2 (λ p : C, (p --> b) × (p --> c)) => total2 (fun H : pr1 (pr2 pfg) · f = pr2 (pr2 pfg) · g => isPullback f g (pr1 (pr2 pfg)) (pr2 (pr2 pfg)) H)). *) Definition Pullbacks := ∏ (a b c : C)(f : C⟦b, a⟧)(g : C⟦c, a⟧), Pullback f g. Definition hasPullbacks := ∏ (a b c : C) (f : C⟦b, a⟧) (g : C⟦c, a⟧), ishinh (Pullback f g). Definition PullbackObject {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧}: Pullback f g -> C := λ H, lim H. (* Coercion PullbackObject : Pullback >-> ob. *) Definition PullbackPr1 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) : C⟦lim Pb, b⟧ := limOut Pb One. Definition PullbackPr2 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) : C⟦lim Pb, c⟧ := limOut Pb Three. Definition PullbackSqrCommutes {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) : PullbackPr1 Pb · f = PullbackPr2 Pb · g . Proof. eapply pathscomp0; [apply (limOutCommutes Pb One Two tt) |]. apply (!limOutCommutes Pb Three Two tt) . Qed. Definition PullbackArrow {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g) : C⟦e, lim Pb⟧. Proof. now use limArrow; use PullbCone. Defined. Lemma PullbackArrow_PullbackPr1 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g) : PullbackArrow Pb e h k H · PullbackPr1 Pb = h. Proof. exact (limArrowCommutes Pb e _ One). Qed. Lemma PullbackArrow_PullbackPr2 {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧)(H : h · f = k · g) : PullbackArrow Pb e h k H · PullbackPr2 Pb = k. Proof. exact (limArrowCommutes Pb e _ Three). Qed. Lemma PullbackArrowUnique {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (Pb : Pullback f g) e (h : C⟦e, b⟧) (k : C⟦e, c⟧) (Hcomm : h · f = k · g) (w : C⟦e, PullbackObject Pb⟧) (H1 : w · PullbackPr1 Pb = h) (H2 : w · PullbackPr2 Pb = k) : w = PullbackArrow Pb _ h k Hcomm. Proof. apply path_to_ctr. use three_rec_dep; try assumption. set (X:= limOutCommutes Pb Three Two tt). eapply pathscomp0. eapply maponpaths, pathsinv0, X. simpl. rewrite assoc. eapply pathscomp0. apply cancel_postcomposition, H2. apply (!Hcomm). Qed. Definition isPullback_Pullback {a b c : C} {f : C⟦b, a⟧}{g : C⟦c, a⟧} (P : Pullback f g) : isPullback f g (PullbackPr1 P) (PullbackPr2 P) (PullbackSqrCommutes P). Proof. apply make_isPullback. intros e h k HK. use tpair. - use tpair. + apply (PullbackArrow P _ h k HK). + split. * apply PullbackArrow_PullbackPr1. * apply PullbackArrow_PullbackPr2. - intro t. apply subtypePath. + intro. apply isapropdirprod; apply C. + destruct t as [t p]. simpl. use (PullbackArrowUnique _ _ P). * apply e. * apply (pr1 p). * apply (pr2 p). Qed. (** ** Maps between pullbacks as special limits and direct formulation of pullbacks *) Lemma equiv_isPullback_1 {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) : limits.pullbacks.isPullback (*f g p1 p2*) H -> isPullback f g p1 p2 H. Proof. intro X. intros R cc. set (XR := limits.pullbacks.make_Pullback _ X). use tpair. - use tpair. + use (limits.pullbacks.PullbackArrow XR). * apply (coneOut cc One). * apply (coneOut cc Three). * abstract ( assert (XRT := coneOutCommutes cc Three Two tt); simpl in XRT; eapply pathscomp0; [| apply (!XRT)]; clear XRT; assert (XRT := coneOutCommutes cc One Two tt); simpl in XRT; eapply pathscomp0; [| apply (XRT)]; apply idpath ). + use three_rec_dep. * abstract (apply (limits.pullbacks.PullbackArrow_PullbackPr1 XR)). * abstract (simpl; change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f); rewrite assoc; rewrite (limits.pullbacks.PullbackArrow_PullbackPr1 XR); assert (XRT := coneOutCommutes cc One Two tt); simpl in XRT; eapply pathscomp0; [| apply (XRT)]; apply idpath). * abstract (apply (limits.pullbacks.PullbackArrow_PullbackPr2 XR)). - abstract ( intro t; apply subtypePath; [intro; apply impred; intro; apply C |]; simpl; destruct t as [t HH]; simpl in *; apply limits.pullbacks.PullbackArrowUnique; [ apply (HH One) | apply (HH Three)] ). Qed. Definition equiv_Pullback_1 {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) : limits.pullbacks.Pullback f g -> Pullback f g. Proof. intros X. exact (make_Pullback f g (limits.pullbacks.PullbackObject X) (limits.pullbacks.PullbackPr1 X) (limits.pullbacks.PullbackPr2 X) (limits.pullbacks.PullbackSqrCommutes X) (equiv_isPullback_1 _ _ _ _ _ (limits.pullbacks.isPullback_Pullback X))). Defined. Definition equiv_Pullbacks_1: @limits.pullbacks.Pullbacks C -> Pullbacks. Proof. intros X' a b c f g. set (X := X' a b c f g). exact (make_Pullback f g (limits.pullbacks.PullbackObject X) (limits.pullbacks.PullbackPr1 X) (limits.pullbacks.PullbackPr2 X) (limits.pullbacks.PullbackSqrCommutes X) (equiv_isPullback_1 _ _ _ _ _ (limits.pullbacks.isPullback_Pullback X))). Defined. Lemma equiv_isPullback_2 {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2· g) : limits.pullbacks.isPullback (*f g p1 p2*) H <- isPullback f g p1 p2 H. Proof. intro X. set (XR := make_Pullback _ _ _ _ _ _ X). intros R k h HH. use tpair. - use tpair. use (PullbackArrow XR); try assumption. split. + apply (PullbackArrow_PullbackPr1 XR). + apply (PullbackArrow_PullbackPr2 XR). - abstract ( intro t; apply subtypePath; [ intro; apply isapropdirprod; apply C |] ; induction t as [x Hx]; simpl in * ; use (PullbackArrowUnique _ _ XR); [apply R | apply (pr1 Hx) | apply (pr2 Hx) ] ). Qed. Definition equiv_Pullback_2 {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) : limits.pullbacks.Pullback f g <- Pullback f g. Proof. intros X. exact (limits.pullbacks.make_Pullback (*f g (PullbackObject X) (PullbackPr1 X) (PullbackPr2 X) *) (PullbackSqrCommutes X) (equiv_isPullback_2 _ _ _ _ _ (isPullback_Pullback X))). Defined. Definition equiv_Pullbacks_2 : @limits.pullbacks.Pullbacks C <- Pullbacks. Proof. intros X' a b c f g. set (X := X' a b c f g). exact (limits.pullbacks.make_Pullback (*f g (PullbackObject X) (PullbackPr1 X) (PullbackPr2 X) *) (PullbackSqrCommutes X) (equiv_isPullback_2 _ _ _ _ _ (isPullback_Pullback X))). Defined. Definition identity_is_Pullback_input {a b c : C}{f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) : total2 (fun hk : C⟦lim Pb, lim Pb⟧ => dirprod (hk · PullbackPr1 Pb = PullbackPr1 Pb)(hk · PullbackPr2 Pb = PullbackPr2 Pb)). Proof. exists (identity (lim Pb)). apply make_dirprod; apply id_left. Defined. (* was PullbackArrowUnique *) Lemma PullbackArrowUnique' {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (p1 : C⟦d, b⟧) (p2 : C⟦d, c⟧) (H : p1 · f = p2 · g) (P : isPullback f g p1 p2 H) (e : C) (h : C⟦e, b⟧) (k : C⟦e, c⟧) (Hcomm : h · f = k · g) (w : C⟦e, d⟧) (H1 : w · p1 = h) (H2 : w · p2 = k) : w = (pr1 (pr1 (P e (PullbCone f g _ h k Hcomm)))). Proof. apply path_to_ctr. use three_rec_dep; try assumption; simpl. change (three_rec_dep (λ n, C⟦d,_⟧) _ _ _ _) with (p1 · f). change (three_rec_dep (λ n, C⟦e,_⟧) _ _ _ _) with (h · f). now rewrite <- H1, assoc. Qed. Lemma PullbackEndo_is_identity {a b c : C}{f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb : Pullback f g) (k : C⟦lim Pb, lim Pb⟧) (kH1 : k · PullbackPr1 Pb = PullbackPr1 Pb) (kH2 : k · PullbackPr2 Pb = PullbackPr2 Pb) : identity (lim Pb) = k. Proof. apply lim_endo_is_identity. use three_rec_dep. - apply kH1. - unfold limOut. simpl. assert (T:= coneOutCommutes (limCone Pb) Three Two tt). eapply pathscomp0. apply maponpaths. apply (!T). rewrite assoc. eapply pathscomp0. apply cancel_postcomposition. apply kH2. apply T. - assumption. Qed. Definition from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb Pb': Pullback f g) : C⟦lim Pb, lim Pb'⟧. Proof. apply (PullbackArrow Pb' (lim Pb) (PullbackPr1 _ ) (PullbackPr2 _)). exact (PullbackSqrCommutes _ ). Defined. Lemma are_inverses_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb Pb': Pullback f g) : is_inverse_in_precat (from_Pullback_to_Pullback Pb Pb') (from_Pullback_to_Pullback Pb' Pb). Proof. split; apply pathsinv0; apply PullbackEndo_is_identity; rewrite <- assoc; unfold from_Pullback_to_Pullback; repeat rewrite PullbackArrow_PullbackPr1; repeat rewrite PullbackArrow_PullbackPr2; auto. Qed. Lemma isiso_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb Pb': Pullback f g) : is_iso (from_Pullback_to_Pullback Pb Pb'). Proof. apply (is_iso_qinv _ (from_Pullback_to_Pullback Pb' Pb)). apply are_inverses_from_Pullback_to_Pullback. Defined. Definition iso_from_Pullback_to_Pullback {a b c : C} {f : C⟦b, a⟧} {g : C⟦c, a⟧} (Pb Pb': Pullback f g) : iso (lim Pb) (lim Pb') := tpair _ _ (isiso_from_Pullback_to_Pullback Pb Pb'). (** pullback lemma *) Section pullback_lemma. Variables a b c d e x : C. Variables (f : C⟦b, a⟧) (g : C⟦c, a⟧) (h : C⟦e, b⟧) (k : C⟦e, c⟧) (i : C⟦d, b⟧) (j : C⟦x, e⟧) (m : C⟦x, d⟧). Hypothesis H1 : h · f = k · g. Hypothesis H2 : m · i = j · h. Hypothesis P1 : isPullback _ _ _ _ H1. Hypothesis P2 : isPullback _ _ _ _ H2. Lemma glueSquares : m · (i · f) = (j · k) · g. Proof. rewrite assoc. rewrite H2. repeat rewrite <- assoc. rewrite H1. apply idpath. Qed. (* Lemma isPullbackGluedSquare : isPullback (i · f) g m (j · k) glueSquares. Proof. apply make_isPullback. intros y p q. intro Hrt. assert (ex : (p· i)· f = q· g). { rewrite <- Hrt. rewrite assoc; apply idpath. } set (rt := P1 _ (p · i) q ex). set (Ppiq := pr1 (pr1 (rt))). assert (owiej : p · i = Ppiq · h). { apply pathsinv0. apply (pr1 (pr2 (pr1 rt))). } set (rt' := P2 _ p Ppiq owiej). set (awe := pr1 (pr1 rt')). assert (Hawe1 : awe · m = p). { exact (pr1 (pr2 (pr1 rt'))). } assert (Hawe2 : awe · (j · k) = q). { rewrite assoc. set (X := pr2 (pr2 (pr1 rt'))). simpl in X. unfold awe. rewrite X. exact (pr2 (pr2 (pr1 rt))). } exists (tpair _ awe (make_dirprod Hawe1 Hawe2)). intro t. apply subtypePath. - intro a0. apply isapropdirprod; apply hs. - simpl. destruct t as [t [Ht1 Ht2]]. simpl in *. apply PullbackArrowUnique. + assumption. + apply PullbackArrowUnique. * rewrite <- Ht1. repeat rewrite <- assoc. rewrite H2. apply idpath. * rewrite <- assoc. assumption. Qed. *) End pullback_lemma. Lemma inv_from_iso_iso_from_Pullback (a b c : C) (f : C⟦b, a⟧) (g : C⟦c, a⟧) (Pb : Pullback f g) (Pb' : Pullback f g): inv_from_iso (iso_from_Pullback_to_Pullback Pb Pb') = from_Pullback_to_Pullback Pb' Pb. Proof. apply pathsinv0. apply inv_iso_unique'. set (T:= are_inverses_from_Pullback_to_Pullback Pb Pb'). apply (pr1 T). Qed. (* Lemma isaprop_Pullbacks: isaprop Pullbacks. Proof. apply impred; intro a; apply impred; intro b; apply impred; intro c; apply impred; intro f; apply impred; intro g; apply invproofirrelevance. intros Pb Pb'. apply subtypePath. - intro; apply isofhleveltotal2. + apply hs. + intros; apply isaprop_isPullback. - apply (total2_paths_f (isotoid _ H (iso_from_Pullback_to_Pullback Pb Pb' ))). rewrite transportf_dirprod, transportf_isotoid. rewrite inv_from_iso_iso_from_Pullback. rewrite transportf_isotoid. rewrite inv_from_iso_iso_from_Pullback. destruct Pb as [Cone bla]; destruct Pb' as [Cone' bla']; simpl in *. destruct Cone as [p [h k]]; destruct Cone' as [p' [h' k']]; simpl in *. unfold from_Pullback_to_Pullback; rewrite PullbackArrow_PullbackPr2, PullbackArrow_PullbackPr1. apply idpath. Qed. *) End def_pb. Lemma Pullbacks_from_Lims (C : category) : Lims C -> Pullbacks C. Proof. intros H a b c f g; apply H. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/pushouts.v000066400000000000000000000341011451125700300244710ustar00rootroot00000000000000(** * Pushouts defined in terms of colimits *) (** ** Contents - Definition of pushouts - Coincides with the direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.pushouts. Local Open Scope cat. (** * Definition of pushouts in terms of colimits *) Section def_po. Variable C : category. Local Open Scope stn. Definition One : three := ● 0. Definition Two : three := ● 1. Definition Three : three := ● 2. Definition pushout_graph : graph. Proof. exists three. use three_rec. - apply three_rec. + apply empty. + apply unit. + apply unit. - apply (λ _, empty). - apply three_rec. + apply empty. + apply empty. + apply empty. Defined. Definition pushout_diagram {a b c : C} (f : C ⟦a, b⟧) (g : C⟦a, c⟧) : diagram pushout_graph C. Proof. exists (three_rec a b c). use three_rec_dep; cbn. - use three_rec_dep; cbn. + apply fromempty. + intros _; exact f. + intros _; exact g. - intros x; apply fromempty. - use three_rec_dep; cbn; apply fromempty. Defined. Definition PushoutCocone {a b c : C} (f : C ⟦a, b⟧) (g : C⟦a, c⟧) (d : C) (f' : C ⟦b, d⟧) (g' : C ⟦c, d⟧) (H : f · f' = g · g') : cocone (pushout_diagram f g) d. Proof. use make_cocone. - use three_rec_dep; try assumption. apply (f · f'). - use three_rec_dep; use three_rec_dep. + exact (empty_rect _). + intros x; apply idpath. + intros x; apply (! H). + exact (empty_rect _). + exact (empty_rect _). + exact (empty_rect _). + exact (empty_rect _). + exact (empty_rect _). + exact (empty_rect _). Defined. Definition isPushout {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) : UU := isColimCocone (pushout_diagram f g) d (PushoutCocone f g d i1 i2 H). Definition make_isPushout {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) : (∏ e (h : C ⟦b, e⟧) (k : C⟦c, e⟧)(Hk : f · h = g · k ), iscontr (total2 (fun hk : C⟦d, e⟧ => dirprod (i1 · hk = h)(i2 · hk = k)))) → isPushout f g i1 i2 H. Proof. intros H' x cx. unfold is_cocone_mor; simpl in *. set (H1 := H' x (coconeIn cx Two) (coconeIn cx Three)). use (let p : f · coconeIn cx Two = g · coconeIn cx Three := _ in _ ). { eapply pathscomp0; [apply (coconeInCommutes cx One Two tt)|]. apply pathsinv0, (coconeInCommutes cx One Three tt). } set (H2 := H1 p). use tpair. + exists (pr1 (pr1 H2)). use three_rec_dep. * abstract (use (pathscomp0 _ (coconeInCommutes cx One Two tt)); change (three_rec_dep _ _ _ _ _) with (f · i1); change (dmor _ _) with f; rewrite <- assoc; apply cancel_precomposition, (pr1 (pr2 (pr1 H2)))). * abstract ( apply (pr1 (pr2 (pr1 H2)))). * abstract (now use (pathscomp0 _ (pr2 (pr2 (pr1 H2))))). + abstract (intro t; apply subtypePath; [ intro; apply impred; intro; apply C | destruct t as [t p0]; apply path_to_ctr; split; [ apply (p0 Two) | apply (p0 Three) ]]). Defined. Definition Pushout {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) : UU := ColimCocone (pushout_diagram f g). Definition make_Pushout {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (d : C) (i1 : C⟦b,d⟧) (i2 : C ⟦c,d⟧) (H : f · i1 = g · i2) (ispo : isPushout f g i1 i2 H) : Pushout f g. Proof. use tpair. - exists d. use PushoutCocone; assumption. - apply ispo. Defined. Definition Pushouts : UU := ∏ (a b c : C) (f : C⟦a, b⟧)(g : C⟦a, c⟧), Pushout f g. Definition hasPushouts : UU := ∏ (a b c : C) (f : C⟦a, b⟧) (g : C⟦a, c⟧), ishinh (Pushout f g). Definition PushoutObject {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧}: Pushout f g -> C := λ H, colim H. (* Coercion PushoutObject : Pushout >-> ob. *) Definition PushoutIn1 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) : C⟦b, colim Po⟧ := colimIn Po Two. Definition PushoutIn2 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) : C⟦c, colim Po⟧ := colimIn Po Three. Definition PushoutSqrCommutes {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) : f · PushoutIn1 Po = g · PushoutIn2 Po. Proof. eapply pathscomp0; [apply (colimInCommutes Po One Two tt) |]. apply (!colimInCommutes Po One Three tt). Qed. Definition PushoutArrow {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) (e : C) (h : C⟦b, e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) : C⟦colim Po, e⟧. Proof. now use colimArrow; use PushoutCocone. Defined. Lemma PushoutArrow_PushoutIn1 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) (e : C) (h : C⟦b , e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) : PushoutIn1 Po · PushoutArrow Po e h k H = h. Proof. exact (colimArrowCommutes Po e _ Two). Qed. Lemma PushoutArrow_PushoutIn2 {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) (e : C) (h : C⟦b, e⟧) (k : C⟦c, e⟧) (H : f · h = g · k) : PushoutIn2 Po · PushoutArrow Po e h k H = k. Proof. exact (colimArrowCommutes Po e _ Three). Qed. Lemma PushoutArrowUnique {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (Po : Pushout f g) (e : C) (h : C⟦b, e⟧) (k : C⟦c, e⟧) (Hcomm : f · h = g · k) (w : C⟦PushoutObject Po, e⟧) (H1 : PushoutIn1 Po · w = h) (H2 : PushoutIn2 Po · w = k) : w = PushoutArrow Po _ h k Hcomm. Proof. apply path_to_ctr. use three_rec_dep; try assumption. set (X := colimInCommutes Po One Two tt). use (pathscomp0 (! (maponpaths (λ h' : _, h' · w) X))). now rewrite <- assoc; simpl; rewrite <- H1. Qed. Definition isPushout_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (P : Pushout f g) : isPushout f g (PushoutIn1 P) (PushoutIn2 P) (PushoutSqrCommutes P). Proof. apply make_isPushout. intros e h k HK. use tpair. - use tpair. + apply (PushoutArrow P _ h k HK). + split. * apply PushoutArrow_PushoutIn1. * apply PushoutArrow_PushoutIn2. - intro t. apply subtypePath. + intro. apply isapropdirprod; apply C. + destruct t as [t p]. simpl. use (PushoutArrowUnique _ _ P). * apply e. * apply (pr1 p). * apply (pr2 p). Qed. (** ** Pushouts to Pushouts *) Definition identity_is_Pushout_input {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) : total2 (fun hk : C⟦colim Po, colim Po⟧ => dirprod (PushoutIn1 Po · hk = PushoutIn1 Po) (PushoutIn2 Po · hk = PushoutIn2 Po)). Proof. exists (identity (colim Po)). apply make_dirprod; apply id_right. Defined. (* was PushoutArrowUnique *) Lemma PushoutArrowUnique' {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) (P : isPushout f g i1 i2 H) e (h : C⟦b, e⟧) (k : C⟦c, e⟧) (Hcomm : f · h = g · k) (w : C⟦d, e⟧) (H1 : i1 · w = h) (H2 : i2 · w = k) : w = (pr1 (pr1 (P e (PushoutCocone f g _ h k Hcomm)))). Proof. apply path_to_ctr. use three_rec_dep; try assumption; simpl. change (three_rec_dep (λ n, C⟦three_rec a b c n, d⟧) _ _ _ _) with (f · i1). change (three_rec_dep (λ n, C⟦three_rec a b c n, e⟧) _ _ _ _) with (f · h). now rewrite <- assoc, H1. Qed. Lemma PushoutEndo_is_identity {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po : Pushout f g) (k : C⟦colim Po , colim Po⟧) (kH1 : PushoutIn1 Po · k = PushoutIn1 Po) (kH2 : PushoutIn2 Po · k = PushoutIn2 Po) : identity (colim Po) = k. Proof. apply colim_endo_is_identity. use three_rec_dep; cbn. - unfold colimIn. set (T := (coconeInCommutes (colimCocone Po) One Three tt)). use (pathscomp0 (! (maponpaths (λ h' : _, h' · k) T))). use (pathscomp0 _ (coconeInCommutes (colimCocone Po) One Three tt)). rewrite <- assoc. apply cancel_precomposition. apply kH2. - apply kH1. - apply kH2. Qed. Definition from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po Po': Pushout f g) : C⟦colim Po , colim Po'⟧. Proof. apply (PushoutArrow Po (colim Po') (PushoutIn1 _ ) (PushoutIn2 _)). exact (PushoutSqrCommutes _ ). Defined. Lemma are_inverses_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po Po': Pushout f g) : is_inverse_in_precat (from_Pushout_to_Pushout Po Po') (from_Pushout_to_Pushout Po' Po). Proof. split; apply pathsinv0; apply PushoutEndo_is_identity; rewrite assoc; unfold from_Pushout_to_Pushout; repeat rewrite PushoutArrow_PushoutIn1; repeat rewrite PushoutArrow_PushoutIn2; auto. Qed. Lemma isiso_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po Po': Pushout f g) : is_iso (from_Pushout_to_Pushout Po Po'). Proof. apply (is_iso_qinv _ (from_Pushout_to_Pushout Po' Po)). apply are_inverses_from_Pushout_to_Pushout. Defined. Definition iso_from_Pushout_to_Pushout {a b c : C} {f : C⟦a, b⟧} {g : C⟦a, c⟧} (Po Po': Pushout f g) : iso (colim Po) (colim Po') := tpair _ _ (isiso_from_Pushout_to_Pushout Po Po'). (** pushout lemma *) Section pushout_lemma. Variables a b c d e x : C. Variables (f : C⟦a, b⟧) (g : C⟦a, c⟧) (h : C⟦b, e⟧) (k : C⟦c, e⟧) (i : C⟦b, d⟧) (j : C⟦e, x⟧) (m : C⟦d, x⟧). Hypothesis H1 : f · h = g · k. Hypothesis H2 : i · m = h · j. Hypothesis P1 : isPushout _ _ _ _ H1. Hypothesis P2 : isPushout _ _ _ _ H2. Lemma glueSquares : f · i · m = g · k · j. Proof. rewrite <- assoc. rewrite H2. rewrite <- H1. repeat rewrite <- assoc. apply idpath. Qed. (** TODO: isPushoutGluedSquare : isPushout (f · i) g m (k · j) glueSquares. *) End pushout_lemma. Lemma inv_from_iso_iso_from_Pushout (a b c : C) (f : C⟦a, b⟧) (g : C⟦a, c⟧) (Po : Pushout f g) (Po' : Pushout f g): inv_from_iso (iso_from_Pushout_to_Pushout Po Po') = from_Pushout_to_Pushout Po' Po. Proof. apply pathsinv0. apply inv_iso_unique'. set (T := are_inverses_from_Pushout_to_Pushout Po Po'). apply (pr1 T). Qed. (** ** Connections to other colimits *) Lemma Pushout_from_Colims : Colims C -> Pushouts. Proof. intros H a b c f g; apply H. Defined. End def_po. (** * Definitions coincide In this section we show that pushouts defined as special colimits coincide with the direct definition. *) Section pushout_coincide. Variable C : category. (** ** isPushout *) Lemma equiv_isPushout1 {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) : limits.pushouts.isPushout f g i1 i2 H -> isPushout C f g i1 i2 H. Proof. intros X R cc. set (XR := limits.pushouts.make_Pushout f g d i1 i2 H X). use unique_exists. + use (limits.pushouts.PushoutArrow XR). - exact (coconeIn cc Two). - exact (coconeIn cc Three). - use (pathscomp0 ((coconeInCommutes cc One Two tt))). apply (!(coconeInCommutes cc One Three tt)). + use three_rec_dep; simpl. - change (three_rec_dep (λ n, C⟦three_rec a b c n, d⟧) _ _ _ _) with (f · i1). rewrite <- assoc, (limits.pushouts.PushoutArrow_PushoutIn1 XR). apply (coconeInCommutes cc One Two tt). - apply (limits.pushouts.PushoutArrow_PushoutIn1 XR). - apply (limits.pushouts.PushoutArrow_PushoutIn2 XR). + intros y; apply impred_isaprop; intros t; apply C. + intros y T. use limits.pushouts.PushoutArrowUnique. - apply (T Two). - apply (T Three). Qed. Lemma equiv_isPushout2 {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (i1 : C⟦b, d⟧) (i2 : C⟦c, d⟧) (H : f · i1 = g · i2) : limits.pushouts.isPushout f g i1 i2 H <- isPushout C f g i1 i2 H. Proof. intros X R k h HH. set (XR := make_Pushout C f g d i1 i2 H X). use unique_exists. + use (PushoutArrow C XR). - exact k. - exact h. - exact HH. + split. - exact (PushoutArrow_PushoutIn1 C XR R k h HH). - exact (PushoutArrow_PushoutIn2 C XR R k h HH). + intros y; apply isapropdirprod; apply C. + intros y T. use (PushoutArrowUnique C _ _ XR). - exact R. - exact (pr1 T). - exact (pr2 T). Qed. (** ** Pushout *) Definition equiv_Pushout1 {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) : limits.pushouts.Pushout f g -> Pushout C f g. Proof. intros X. exact (make_Pushout C f g X (limits.pushouts.PushoutIn1 X) (limits.pushouts.PushoutIn2 X) (limits.pushouts.PushoutSqrCommutes X) (equiv_isPushout1 _ _ _ _ _ (limits.pushouts.isPushout_Pushout X))). Defined. Definition equiv_Pushout2 {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) : limits.pushouts.Pushout f g <- Pushout C f g. Proof. intros X. exact (limits.pushouts.make_Pushout f g (PushoutObject C X) (PushoutIn1 C X) (PushoutIn2 C X) (PushoutSqrCommutes C X) (equiv_isPushout2 _ _ _ _ _ (isPushout_Pushout C X))). Defined. End pushout_coincide. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/terminal.v000066400000000000000000000110151451125700300244110ustar00rootroot00000000000000(** Terminal object defined as a limit *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Section def_terminal. Context {C : category}. Definition empty_graph : graph. Proof. exists empty. exact (λ _ _, empty). Defined. Definition termDiagram : diagram empty_graph C. Proof. exists fromempty. intros u; induction u. Defined. Definition termCone (c : C) : cone termDiagram c. Proof. use make_cone; intro v; induction v. Defined. Definition isTerminal (a : C) := isLimCone termDiagram a (termCone a). Definition make_isTerminal (b : C) (H : ∏ (a : C), iscontr (a --> b)) : isTerminal b. Proof. intros a ca. use tpair. - exists (pr1 (H a)); intro v; induction v. - intro t. apply subtypePath; simpl; [ intro f; apply impred; intro v; induction v|]. apply (pr2 (H a)). Defined. Definition Terminal : UU := LimCone termDiagram. (* Definition Terminal := total2 (λ a, isTerminal a). *) Definition make_Terminal (b : C) (H : isTerminal b) : Terminal. Proof. use (make_LimCone _ b (termCone b)). apply make_isTerminal. intro a. set (x := H a (termCone a)). use tpair. - apply (pr1 x). - simpl; intro f; apply path_to_ctr; intro v; induction v. Defined. Definition TerminalObject (T : Terminal) : C := lim T. (* Coercion TerminalObject : Terminal >-> ob. *) Definition TerminalArrow (T : Terminal) (b : C) : C⟦b,TerminalObject T⟧ := limArrow _ _ (termCone b). Lemma TerminalArrowUnique (T : Terminal) (b : C) (f : C⟦b,TerminalObject T⟧) : f = TerminalArrow T _. Proof. now apply limArrowUnique; intro v; induction v. Defined. Lemma ArrowsToTerminal (T : Terminal) (b : C) (f g : C⟦b,TerminalObject T⟧) : f = g. Proof. eapply pathscomp0. apply TerminalArrowUnique. now apply pathsinv0, TerminalArrowUnique. Qed. Lemma TerminalEndo_is_identity (T : Terminal) (f : C⟦TerminalObject T,TerminalObject T⟧) : identity (TerminalObject T) = f. Proof. now apply ArrowsToTerminal. Qed. Lemma isiso_from_Terminal_to_Terminal (T T' : Terminal) : is_iso (TerminalArrow T (TerminalObject T')). Proof. apply (is_iso_qinv _ (TerminalArrow T' (TerminalObject T))). split; apply pathsinv0, TerminalEndo_is_identity. Defined. Definition iso_Terminals (T T' : Terminal) : iso (TerminalObject T) (TerminalObject T') := tpair _ (TerminalArrow T' (TerminalObject T)) (isiso_from_Terminal_to_Terminal T' T) . Definition hasTerminal := ishinh Terminal. (* TODO: This should be an instance of a general result for limits *) (* Section Terminal_Unique. *) (* Hypothesis H : is_univalent C. *) (* Lemma isaprop_Terminal : isaprop Terminal. *) (* Proof. *) (* apply invproofirrelevance. *) (* intros T T'. *) (* apply (total2_paths_f (isotoid _ H (iso_Terminals T T')) ). *) (* apply proofirrelevance. *) (* unfold isTerminal. *) (* apply impred. *) (* intro t ; apply isapropiscontr. *) (* Qed. *) (* End Terminal_Unique. *) Definition isTerminal_Terminal (T : Terminal) : isTerminal (TerminalObject T). Proof. use make_isTerminal. intros a. use tpair. - exact (TerminalArrow T a). - intros t. use (TerminalArrowUnique T a). Qed. (** ** Maps between terminal as a special limit and direct definition *) Lemma equiv_isTerminal1 (c : C) : limits.terminal.isTerminal C c -> isTerminal c. Proof. intros X. use make_isTerminal. intros b. apply (X b). Qed. Lemma equiv_isTerminal2 (c : C) : limits.terminal.isTerminal C c <- isTerminal c. Proof. intros X. set (XT := make_Terminal c X). intros b. use tpair. - exact (TerminalArrow XT b). - intros t. use (TerminalArrowUnique XT b). Qed. Definition equiv_Terminal1 : limits.terminal.Terminal C -> Terminal. Proof. intros T. exact (make_Terminal T (equiv_isTerminal1 _ (pr2 T))). Defined. Definition equiv_Terminal2 : limits.terminal.Terminal C <- Terminal. Proof. intros T. exact (limits.terminal.make_Terminal (TerminalObject T) (equiv_isTerminal2 _ (isTerminal_Terminal T))). Defined. End def_terminal. Arguments Terminal : clear implicits. Arguments isTerminal : clear implicits. Lemma Terminal_from_Lims (C : category) : Lims_of_shape empty_graph C -> Terminal C. Proof. now intros H; apply H. Defined. UniMath-20231010/UniMath/CategoryTheory/limits/graphs/zero.v000066400000000000000000000221231451125700300235570ustar00rootroot00000000000000(** * Zero Objects Zero objects are objects of precategory which are both initial objects and terminal object. *) (** ** Contents - Definition of Zero - Coincides with the direct definition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.initial. Require Import UniMath.CategoryTheory.limits.graphs.terminal. Require Import UniMath.CategoryTheory.limits.zero. Local Open Scope cat. (** * Definition of zero using limits and colimits *) Section def_zero. Context {C : category}. (** An object c is zero if it initial and terminal. *) Definition isZero (c : C) : UU := (isInitial C c) × (isTerminal C c). (** Construction of isZero for an object c from the conditions that the space of all morphisms from c to any object d is contractible and and the space of all morphisms from any object d to c is contractible. *) Definition make_isZero (c : C) (H : (∏ (d : C), iscontr (c --> d)) × (∏ (d : C), iscontr (d --> c))) : isZero c := make_isInitial c (dirprod_pr1 H),,make_isTerminal c (dirprod_pr2 H). (** Definition of Zero. *) Definition Zero : UU := ∑ c : C, isZero c. Definition make_Zero (c : C) (H : isZero c) : Zero := tpair _ c H. Definition ZeroObject (Z : Zero) : C := pr1 Z. (** Construction of Initial and Terminal from Zero. *) Definition Zero_to_Initial (Z : Zero) : Initial C := make_Initial (pr1 Z) (dirprod_pr1 (pr2 Z)). Definition Zero_to_Terminal (Z : Zero) : Terminal C := make_Terminal (pr1 Z) (dirprod_pr2 (pr2 Z)). (** The following lemmas show that the underlying objects of Initial and Terminal, constructed above, are equal to ZeroObject. *) Lemma ZeroObject_equals_InitialObject (Z : Zero) : ZeroObject Z = InitialObject (Zero_to_Initial Z). Proof. apply idpath. Defined. Lemma ZeroObject_equals_TerminalObject (Z : Zero) : ZeroObject Z = TerminalObject (Zero_to_Terminal Z). Proof. apply idpath. Defined. (** We construct morphisms from ZeroObject to any other object c and from any other object c to the ZeroObject. *) Definition ZeroArrowFrom (Z : Zero) (c : C) : C⟦ZeroObject Z, c⟧ := InitialArrow (Zero_to_Initial Z) c. Definition ZeroArrowTo (Z : Zero) (c : C) : C⟦c, ZeroObject Z⟧ := TerminalArrow (Zero_to_Terminal Z) c. (** In particular, we get a zero morphism between any objects. *) Definition ZeroArrow (Z : Zero) (c d : C) : C⟦c, d⟧ := @compose C _ (ZeroObject Z) _ (ZeroArrowTo Z c) (ZeroArrowFrom Z d). (** We show that the above morphisms from ZeroObject and to ZeroObject are unique by using uniqueness of the morphism from InitialObject and uniqueness of the morphism to TerminalObject. *) Lemma ZeroArrowFromUnique (Z : Zero) (c : C) (f : C⟦ZeroObject Z, c⟧) : f = (ZeroArrowFrom Z c). Proof. apply (InitialArrowUnique (Zero_to_Initial Z) c f). Defined. Lemma ZeroArrowToUnique (Z : Zero) (c : C) (f : C⟦c, ZeroObject Z⟧) : f = (ZeroArrowTo Z c). Proof. apply (TerminalArrowUnique (Zero_to_Terminal Z) c f). Defined. (** Therefore, any two morphisms from the ZeroObject to an object c are equal and any two morphisms from an object c to the ZeroObject are equal. *) Corollary ArrowsFromZero (Z : Zero) (c : C) (f g : C⟦ZeroObject Z, c⟧) : f = g. Proof. eapply pathscomp0. apply (ZeroArrowFromUnique Z c f). apply pathsinv0. apply (ZeroArrowFromUnique Z c g). Defined. Corollary ArrowsToZero (Z : Zero) (c : C) (f g : C⟦c, ZeroObject Z⟧) : f = g. Proof. eapply pathscomp0. apply (ZeroArrowToUnique Z c f). apply pathsinv0. apply (ZeroArrowToUnique Z c g). Defined. (** It follows that any morphism which factors through 0 is the ZeroArrow. *) Corollary ZeroArrowUnique (Z : Zero) (c d : C) (f : C⟦c, ZeroObject Z⟧) (g : C⟦ZeroObject Z, d⟧) : f · g = ZeroArrow Z c d. Proof. rewrite (ZeroArrowToUnique Z c f). rewrite (ZeroArrowFromUnique Z d g). apply idpath. Defined. (** Compose any morphism with the ZeroArrow and you get the ZeroArrow. *) Lemma precomp_with_ZeroArrow (Z : Zero) (a b c : C) (f : C⟦a, b⟧) : f · ZeroArrow Z b c = ZeroArrow Z a c. Proof. unfold ZeroArrow at 1. rewrite assoc. apply ZeroArrowUnique. Defined. Lemma postcomp_with_ZeroArrow (Z : Zero) (a b c : C) (f : C⟦b, c⟧) : ZeroArrow Z a b · f = ZeroArrow Z a c. Proof. unfold ZeroArrow at 1. rewrite <- assoc. apply ZeroArrowUnique. Defined. (** An endomorphism of the ZeroObject is the identity morphism. *) Corollary ZeroEndo_is_identity (Z : Zero) (f : C⟦ZeroObject Z, ZeroObject Z⟧) : f = identity (ZeroObject Z). Proof. apply ArrowsFromZero. Defined. (** The morphism from ZeroObject to ZeroObject is an isomorphisms. *) Lemma isiso_from_Zero_to_Zero (Z Z' : Zero) : is_iso (ZeroArrowFrom Z (ZeroObject Z')). Proof. apply (is_iso_qinv _ (ZeroArrowFrom Z' (ZeroObject Z))). split; apply ArrowsFromZero. Defined. (** Using the above lemma we can construct an isomorphisms between any two ZeroObjects. *) Definition iso_Zeros (Z Z' : Zero) : iso (ZeroObject Z) (ZeroObject Z') := tpair _ (ZeroArrowFrom Z (ZeroObject Z')) (isiso_from_Zero_to_Zero Z Z'). Definition hasZero := ishinh Zero. (** Construct Zero from Initial and Terminal for which the underlying objects are isomorphic. *) Definition Initial_and_Terminal_to_Zero (I : Initial C) (T : Terminal C) (e: iso (InitialObject I) (TerminalObject T)) : Zero. Proof. use (make_Zero (InitialObject I)). split. - use (make_isInitial (InitialObject I)); intro b. apply make_iscontr with (x := (InitialArrow I b)), InitialArrowUnique. - use (make_isTerminal (InitialObject I)); intro a. apply (iscontrretract (postcomp_with (inv_from_iso e)) (postcomp_with (morphism_from_iso e))). intros y. unfold postcomp_with. rewrite <- assoc. rewrite (iso_inv_after_iso e). apply (remove_id_right _ _ _ y y _ (idpath _) (idpath _)). apply (make_iscontr (TerminalArrow T a)), TerminalArrowUnique. Defined. (** The following lemma verifies that the ZeroObject of the Zero, constructed from Initial and Terminal with InitialObject isomorphic to TerminalObject, is isomorphic to the InitialObject and isomorphic to the TerminalObject. *) Lemma Initial_and_Terminal_ob_equals_Zero_ob (I : Initial C) (T :Terminal C) (e : iso (InitialObject I) (TerminalObject T)) : (iso (InitialObject I) (ZeroObject (Initial_and_Terminal_to_Zero I T e))) × (iso (TerminalObject T) (ZeroObject (Initial_and_Terminal_to_Zero I T e))). Proof. exact(identity_iso (InitialObject I),,iso_inv_from_iso e). Defined. End def_zero. (** * Zero coincides with the direct definition *) Section zero_coincides. Context {C : category}. (** ** isZero *) Lemma equiv_isZero1 (c : C) : limits.zero.isZero c -> isZero c. Proof. intros X. use make_isZero. split. - intros d. apply ((pr1 X) d). - intros d. apply ((pr2 X) d). Qed. Lemma equiv_isZero2 (c : C) : limits.zero.isZero c <- isZero c. Proof. intros X. set (XZ := make_Zero c X). split. - intros b. use tpair. apply (InitialArrow (Zero_to_Initial XZ) b). intros t. use (InitialArrowUnique (Zero_to_Initial XZ) b). - intros a. use tpair. apply (TerminalArrow (Zero_to_Terminal XZ) a). intros t. use (TerminalArrowUnique (Zero_to_Terminal XZ) a). Qed. (** ** Zero **) Definition equiv_Zero1 : limits.zero.Zero C -> @Zero C. Proof. intros Z. exact (make_Zero Z (equiv_isZero1 _ (pr2 Z))). Defined. Definition equiv_Zero2 : limits.zero.Zero C <- @Zero C. Proof. intros Z. exact (limits.zero.make_Zero (ZeroObject Z) (equiv_isZero2 _ ((isInitial_Initial (Zero_to_Initial Z)) ,,(isTerminal_Terminal (Zero_to_Terminal Z))))). Defined. (** ** Arrows *) Lemma equiv_ZeroArrowTo (x : C) (Z : Zero) : @limits.zero.ZeroArrowTo C (equiv_Zero2 Z) x = ZeroArrowTo Z x. Proof. apply ZeroArrowToUnique. Qed. Lemma equiv_ZeroArrowFrom (x : C) (Z : Zero) : @limits.zero.ZeroArrowFrom C (equiv_Zero2 Z) x = ZeroArrowFrom Z x. Proof. apply ZeroArrowFromUnique. Qed. Lemma equiv_ZeroArrow (x y : C) (Z : Zero) : @limits.zero.ZeroArrow C (equiv_Zero2 Z) x y = ZeroArrow Z x y. Proof. unfold limits.zero.ZeroArrow. unfold ZeroArrow. rewrite equiv_ZeroArrowTo. rewrite equiv_ZeroArrowFrom. apply idpath. Qed. End zero_coincides. (** Following Initial and Terminal, we clear implicit arguments. *) Arguments Zero : clear implicits. Arguments isZero : clear implicits. UniMath-20231010/UniMath/CategoryTheory/limits/initial.v000066400000000000000000000140121451125700300227430ustar00rootroot00000000000000(** Direct definition of initial object together with: - A proof that initial object is a property in a (saturated/univalent) category ([isaprop_Initial]) - Construction of initial from the empty coproduct ([initial_from_empty_coproduct]) - Initial element in a functor precategory ([Initial_functor_precat]) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.limits.coproducts. Local Open Scope cat. Section def_initial. Definition isInitial {C : precategory} (a : C) : UU := ∏ b : C, iscontr (a --> b). Definition Initial (C : precategory) : UU := ∑ a, @isInitial C a. Definition InitialObject {C : precategory} (O : Initial C) : C := pr1 O. Coercion InitialObject : Initial >-> ob. Definition InitialArrow {C : precategory} (O : Initial C) (b : C) : O --> b := pr1 (pr2 O b). Lemma InitialArrowUnique {C : precategory} {I : Initial C} {a : C} (f : C⟦InitialObject I,a⟧) : f = InitialArrow I _. Proof. exact (pr2 (pr2 I _ ) _ ). Qed. Lemma InitialEndo_is_identity {C : precategory} {O : Initial C} (f : O --> O) : f = identity O. Proof. apply proofirrelevancecontr, (pr2 O O). Qed. Lemma InitialArrowEq {C : precategory} {O : Initial C} {a : C} (f g : O --> a) : f = g. Proof. now rewrite (InitialArrowUnique f), (InitialArrowUnique g). Qed. Definition make_Initial {C : precategory} (a : C) (H : isInitial a) : Initial C. Proof. exists a. exact H. Defined. Definition make_isInitial {C : precategory} (a : C) (H : ∏ (b : C), iscontr (a --> b)) : isInitial a. Proof. exact H. Defined. Lemma isziso_from_Initial_to_Initial {C : precategory} (O O' : Initial C) : is_z_isomorphism (InitialArrow O O'). Proof. exists (InitialArrow O' O). split; apply InitialEndo_is_identity. Defined. Definition ziso_Initials {C : precategory} (O O' : Initial C) : z_iso O O' := InitialArrow O O',,isziso_from_Initial_to_Initial O O'. Definition hasInitial {C : precategory} : UU := ishinh (Initial C). End def_initial. Arguments Initial : clear implicits. Arguments isInitial : clear implicits. Arguments InitialObject {_} _. Arguments InitialArrow {_} _ _. Arguments InitialArrowUnique {_} _ _ _. Arguments make_isInitial {_} _ _ _. Arguments make_Initial {_} _ _. (** * Being initial is a property in a (saturated/univalent) category *) Section Initial_Unique. Context (C : category) (H : is_univalent C). Lemma isaprop_Initial : isaprop (Initial C). Proof. apply invproofirrelevance. intros O O'. apply (total2_paths_f (isotoid _ H (ziso_Initials O O')) ). apply proofirrelevance. unfold isInitial. apply impred. intro t ; apply isapropiscontr. Qed. End Initial_Unique. Section Initial_and_EmptyCoprod. (** Construct Initial from empty arbitrary coproduct. *) Definition initial_from_empty_coproduct (C : category): Coproduct empty C fromempty -> Initial C. Proof. intros X. use (make_Initial (CoproductObject _ _ X)). use make_isInitial. intros b. assert (H : ∏ i : empty, C⟦fromempty i, b⟧) by (intros i; apply (fromempty i)). apply (make_iscontr (CoproductArrow _ _ X H)). abstract (intros t; apply CoproductArrowUnique; intros i; apply (fromempty i)). Defined. End Initial_and_EmptyCoprod. (* Section Initial_from_Colims. *) (* Require Import UniMath.CategoryTheory.limits.graphs.colimits. *) (* Variable C : precategory. *) (* Definition empty_graph : graph. *) (* Proof. *) (* exists empty. *) (* exact (λ _ _, empty). *) (* Defined. *) (* Definition initDiagram : diagram empty_graph C. *) (* Proof. *) (* exists fromempty. *) (* intros u; induction u. *) (* Defined. *) (* Definition initCocone (b : C) : cocone initDiagram b. *) (* Proof. *) (* simple refine (make_cocone _ _); intros u; induction u. *) (* Defined. *) (* Lemma Initial_from_Colims : Colims C -> Initial C. *) (* Proof. *) (* intros H. *) (* case (H _ initDiagram); intros cc iscc; destruct cc as [c cc]. *) (* apply (make_Initial c); apply make_isInitial; intros b. *) (* case (iscc _ (initCocone b)); intros f Hf; destruct f as [f fcomm]. *) (* apply (tpair _ f); intro g. *) (* transparent assert (X : (∑ x : c --> b, ∏ v, *) (* coconeIn cc v · x = coconeIn (initCocone b) v)). *) (* { apply (tpair _ g); intro u; induction u. } *) (* apply (maponpaths pr1 (Hf X)). *) (* Defined. *) (* End Initial_from_Colims. *) (** * Construction of initial object in a functor category *) Section InitialFunctorCat. Context (C D : category) (ID : Initial D). Definition Initial_functor_precat : Initial [C, D]. Proof. use make_Initial. - exact (constant_functor _ _ ID). - intros F. use tpair. + use make_nat_trans. * intro a; apply InitialArrow. * abstract (intros a b f; apply InitialArrowEq). + abstract (intros α; apply (nat_trans_eq D); intro a; apply InitialArrowUnique). Defined. End InitialFunctorCat. (** Morphisms to the initial object are epis *) Section epis_initial. Context {C : precategory} (IC : Initial C). Lemma to_initial_isEpi (a : C) (f : a --> IC) : isEpi f. Proof. apply make_isEpi; intros b g h H. now apply InitialArrowEq. Qed. End epis_initial. Definition iso_to_Initial {C : category} (I : Initial C) (x : C) (i : z_iso I x) : isInitial C x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (!(id_left _) @ _ @ id_left _) ; rewrite <- !(z_iso_after_z_iso_inv i) ; rewrite !assoc' ; apply maponpaths ; apply InitialArrowEq). - exact (z_iso_inv i · InitialArrow I w). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/kernels.v000066400000000000000000000504771451125700300227740ustar00rootroot00000000000000(** * Direct implementation of kernels *) (** ** Contents - Definition of [Kernel] - Correspondence of Kernels and Equalizers - Kernel up to isomorphism - Kernel of morphism · [Monic] - KernelIn of equal morphisms - Transport of kernels *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.zero. Local Open Scope cat. (** Definition of kernels *) Section def_kernels. Context {C : category}. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. (** Definition and construction of Kernels *) Definition isKernel {x y z : C} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow Z x z) : UU := ∏ (w : C) (h : w --> y) (H : h · g = ZeroArrow Z w z), ∃! φ : w --> x, φ · f = h. Lemma isKernel_paths {x y z : C} (f : x --> y) (g : y --> z) (H H' : f · g = ZeroArrow Z x z) (isK : isKernel f g H) : isKernel f g H'. Proof. assert (e : H = H') by apply hs. induction e. exact isK. Qed. Definition make_isKernel {x y z : C} (f : x --> y) (g : y --> z) (H1 : f · g = ZeroArrow Z x z) (H2 : ∏ (w : C) (h : w --> y) (H' : h · g = ZeroArrow Z w z), ∃! ψ : w --> x, ψ · f = h) : isKernel f g H1. Proof. unfold isKernel. intros w h H. use unique_exists. - exact (pr1 (iscontrpr1 (H2 w h H))). - exact (pr2 (iscontrpr1 (H2 w h H))). - intros y0. apply hs. - intros y0 X. exact (base_paths _ _ (pr2 (H2 w h H) (tpair _ y0 X))). Defined. Definition Kernel {y z : C} (g : y --> z) : UU := ∑ D : (∑ x : ob C, x --> y), ∑ (e : (pr2 D) · g = ZeroArrow Z (pr1 D) z), isKernel (pr2 D) g e. Definition make_Kernel {x y z : C} (f : x --> y) (g : y --> z) (H : f · g = ZeroArrow Z x z) (isE : isKernel f g H) : Kernel g := ((x,,f),,(H,,isE)). Definition Kernels : UU := ∏ (y z : C) (g : y --> z), Kernel g. Definition hasKernels : UU := ∏ (y z : C) (g : y --> z), ishinh (Kernel g). (** Accessor functions *) Definition KernelOb {y z : C} {g : y --> z} (K : Kernel g) : C := pr1 (pr1 K). Coercion KernelOb : Kernel >-> ob. Definition KernelArrow {y z : C} {g : y --> z} (K : Kernel g) : C⟦K, y⟧ := pr2 (pr1 K). Definition KernelCompZero {y z : C} {g : y --> z} (K : Kernel g) : KernelArrow K · g = ZeroArrow Z K z := pr1 (pr2 K). Definition KernelisKernel {y z : C} {g : y --> z} (K : Kernel g) : isKernel (KernelArrow K) g (KernelCompZero K) := pr2 (pr2 K). Definition KernelIn {y z : C} {g : y --> z} (K : Kernel g) (w : C) (h : w --> y) (H : h · g = ZeroArrow Z w z) : C⟦w, K⟧ := pr1 (iscontrpr1 ((KernelisKernel K) w h H)). Definition KernelCommutes {y z : C} {g : y --> z} (K : Kernel g) (w : C) (h : w --> y) (H : h · g = ZeroArrow Z w z) : (KernelIn K w h H) · (KernelArrow K) = h := pr2 (iscontrpr1 ((KernelisKernel K) w h H)). Local Lemma KernelInUnique {x y z : C} {f : x --> y} {g : y --> z} {H : f · g = ZeroArrow Z x z} (isK : isKernel f g H) {w : C} {h : w --> y} (H' : h · g = ZeroArrow Z w z) {φ : w --> x} (H'' : φ · f = h) : φ = (pr1 (pr1 (isK w h H'))). Proof. exact (base_paths _ _ (pr2 (isK w h H') (tpair _ φ H''))). Qed. Lemma KernelInsEq {y z: C} {g : y --> z} (K : Kernel g) {w : C} (φ1 φ2 : C⟦w, K⟧) (H : φ1 · (KernelArrow K) = φ2 · (KernelArrow K)) : φ1 = φ2. Proof. assert (H1 : φ1 · (KernelArrow K) · g = ZeroArrow Z _ _). { rewrite <- assoc. rewrite KernelCompZero. apply ZeroArrow_comp_right. } rewrite (KernelInUnique (KernelisKernel K) H1 (idpath _)). apply pathsinv0. set (tmp := pr2 (KernelisKernel K w (φ1 · KernelArrow K) H1) (tpair _ φ2 (! H))). exact (base_paths _ _ tmp). Qed. Lemma KernelInComp {y z : C} {f : y --> z} (K : Kernel f) {x x' : C} (h1 : x --> x') (h2 : x' --> y) (H1 : h1 · h2 · f = ZeroArrow Z _ _) (H2 : h2 · f = ZeroArrow Z _ _) : KernelIn K x (h1 · h2) H1 = h1 · KernelIn K x' h2 H2. Proof. use KernelInsEq. rewrite KernelCommutes. rewrite <- assoc. rewrite KernelCommutes. apply idpath. Qed. (** Results on morphisms between Kernels. *) Definition identity_is_KernelIn {y z : C} {g : y --> z} (K : Kernel g) : ∑ φ : C⟦K, K⟧, φ · (KernelArrow K) = (KernelArrow K). Proof. exists (identity K). apply id_left. Defined. Lemma KernelEndo_is_identity {y z : C} {g : y --> z} {K : Kernel g} (φ : C⟦K, K⟧) (H : φ · (KernelArrow K) = KernelArrow K) : identity K = φ. Proof. set (H1 := tpair ((fun φ' : C⟦K, K⟧ => φ' · _ = _)) φ H). assert (H2 : identity_is_KernelIn K = H1). - apply proofirrelevancecontr. apply (KernelisKernel K). apply KernelCompZero. - apply (base_paths _ _ H2). Defined. Definition from_Kernel_to_Kernel {y z : C} {g : y --> z} (K K': Kernel g) : C⟦K, K'⟧. Proof. apply (KernelIn K' K (KernelArrow K)). apply KernelCompZero. Defined. Lemma are_inverses_from_Kernel_to_Kernel {y z : C} {g : y --> z} (K K': Kernel g) : is_inverse_in_precat (from_Kernel_to_Kernel K K') (from_Kernel_to_Kernel K' K). Proof. split. - apply pathsinv0. use KernelEndo_is_identity. rewrite <- assoc. unfold from_Kernel_to_Kernel. rewrite KernelCommutes. rewrite KernelCommutes. apply idpath. - apply pathsinv0. use KernelEndo_is_identity. rewrite <- assoc. unfold from_Kernel_to_Kernel. rewrite KernelCommutes. rewrite KernelCommutes. apply idpath. Qed. Lemma from_Kernel_to_Kernel_is_iso {y z : C} {g : y --> z} (K K' : Kernel g) : is_iso (from_Kernel_to_Kernel K K'). Proof. apply (is_iso_qinv _ (from_Kernel_to_Kernel K' K)). apply are_inverses_from_Kernel_to_Kernel. Qed. Definition iso_from_Kernel_to_Kernel {y z : C} {g : y --> z} (K K' : Kernel g) : z_iso K K' := make_z_iso (from_Kernel_to_Kernel K K') (from_Kernel_to_Kernel K' K) (are_inverses_from_Kernel_to_Kernel K K'). (** Kernel of the ZeroArrow is given by identity *) Local Lemma KernelOfZeroArrow_isKernel (x y : C) : isKernel (identity x) (ZeroArrow Z x y) (id_left (ZeroArrow Z x y)). Proof. use make_isKernel. intros w h H'. use unique_exists. - exact h. - cbn. apply id_right. - intros y0. apply hs. - intros y0 X. cbn in X. rewrite id_right in X. exact X. Qed. Definition KernelofZeroArrow (x y : C) : Kernel (@ZeroArrow C Z x y). Proof. use make_Kernel. - exact x. - exact (identity x). - use id_left. - exact (KernelOfZeroArrow_isKernel x y). Defined. (** Kernel of identity is given by arrow from zero *) Local Lemma KernelOfIdentity_isKernel (x : C) : isKernel (ZeroArrowFrom x) (identity x) (ArrowsFromZero C Z x (ZeroArrowFrom x · identity x) (ZeroArrow Z Z x)). Proof. use make_isKernel. intros w h H'. use unique_exists. - exact (ZeroArrowTo w). - cbn. rewrite id_right in H'. rewrite H'. apply idpath. - intros y. apply hs. - intros y X. cbn in X. use ArrowsToZero. Qed. Definition KernelOfIdentity (x : C) : Kernel (identity x). Proof. use make_Kernel. - exact Z. - exact (ZeroArrowFrom x). - use ArrowsFromZero. - exact (KernelOfIdentity_isKernel x). Defined. (** More generally, the KernelArrow of the kernel of the ZeroArrow is an isomorphism. *) Lemma KernelofZeroArrow_is_iso {x y : C} (K : Kernel (ZeroArrow Z x y)) : is_inverse_in_precat (KernelArrow K) (from_Kernel_to_Kernel (KernelofZeroArrow x y) K). Proof. use make_is_inverse_in_precat. - use KernelInsEq. rewrite <- assoc. unfold from_Kernel_to_Kernel. rewrite KernelCommutes. rewrite id_left. cbn. rewrite id_right. apply idpath. - unfold from_Kernel_to_Kernel. rewrite KernelCommutes. apply idpath. Qed. Definition KernelofZeroArrow_iso (x y : C) (K : Kernel (@ZeroArrow C Z x y)) : z_iso K x := make_z_iso (KernelArrow K) (from_Kernel_to_Kernel (KernelofZeroArrow x y) K) (KernelofZeroArrow_is_iso K). (** It follows that KernelArrow is monic. *) Lemma KernelArrowisMonic {y z : C} {g : y --> z} (K : Kernel g) : isMonic (KernelArrow K). Proof. apply make_isMonic. intros z0 g0 h X. use KernelInsEq. exact X. Defined. Lemma KernelsIn_is_iso {x y : C} {f : x --> y} (K1 K2 : Kernel f) : is_iso (KernelIn K1 K2 (KernelArrow K2) (KernelCompZero K2)). Proof. use is_iso_qinv. - use KernelIn. + use KernelArrow. + use KernelCompZero. - split. + use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. rewrite id_left. apply idpath. + use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. rewrite id_left. apply idpath. Qed. End def_kernels. Arguments KernelArrow [C] [Z] [y] [z] [g] _. (** * Correspondence of kernels and equalizers *) Section kernel_equalizers. Context (C : category). Let hs : has_homsets C := homset_property C. Variable Z : Zero C. (** ** Equalizer from Kernel *) Lemma KernelEqualizer_eq {x y : ob C} {f : x --> y} (K : Kernel Z f) : KernelArrow K · f = KernelArrow K · ZeroArrow Z x y. Proof. rewrite ZeroArrow_comp_right. apply KernelCompZero. Qed. Lemma KernelEqualizer_isEqualizer {x y : ob C} {f : x --> y} (K : Kernel Z f) : isEqualizer f (ZeroArrow Z x y) (KernelArrow K) (KernelEqualizer_eq K). Proof. use make_isEqualizer. intros w h H'. use unique_exists. - use KernelIn. + exact h. + rewrite ZeroArrow_comp_right in H'. exact H'. - cbn. use KernelCommutes. - intros y0. apply hs. - intros y0 X. use KernelInsEq. rewrite KernelCommutes. exact X. Qed. Definition KernelEqualizer {x y : ob C} {f : x --> y} (K : Kernel Z f) : Equalizer f (ZeroArrow Z _ _). Proof. use make_Equalizer. - exact K. - exact (KernelArrow K). - exact (KernelEqualizer_eq K). - exact (KernelEqualizer_isEqualizer K). Defined. (** ** Kernel from Equalizer *) Lemma EqualizerKernel_eq {x y : ob C} {f : x --> y} (E : Equalizer f (ZeroArrow Z _ _)) : EqualizerArrow E · f = ZeroArrow Z E y. Proof. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (EqualizerArrow E)). exact (EqualizerEqAr E). Qed. Lemma EqualizerKernel_isKernel {x y : ob C} {f : x --> y} (E : Equalizer f (ZeroArrow Z _ _)) : isKernel Z (EqualizerArrow E) f (EqualizerKernel_eq E). Proof. use (make_isKernel). intros w h H'. use unique_exists. - use EqualizerIn. + exact h. + rewrite ZeroArrow_comp_right. exact H'. - use EqualizerCommutes. - intros y0. apply hs. - intros y0 X. use EqualizerInsEq. rewrite EqualizerCommutes. exact X. Qed. Definition EqualizerKernel {x y : ob C} {f : x --> y} (E : Equalizer f (ZeroArrow Z _ _)) : Kernel Z f. Proof. use make_Kernel. - exact E. - exact (EqualizerArrow E). - exact (EqualizerKernel_eq E). - exact (EqualizerKernel_isKernel E). Defined. End kernel_equalizers. (** * Kernel up to isomorphism *) Section kernels_iso. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Definition Kernel_up_to_iso_eq {x y z : C} (f : x --> y) (g : y --> z) (K : Kernel Z g) (h : z_iso x K) (H : f = h · (KernelArrow K)) : f · g = ZeroArrow Z x z. Proof. induction K as [t p]. induction t as [t' p']. induction p as [t'' p'']. unfold isEqualizer in p''. rewrite H. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ h). rewrite <- assoc. apply cancel_precomposition. apply KernelCompZero. Qed. Lemma Kernel_up_to_iso_isKernel {x y z : C} (f : x --> y) (g : y --> z) (K : Kernel Z g) (h : z_iso x K) (H : f = h · (KernelArrow K)) (H'' : f · g = ZeroArrow Z x z) : isKernel Z f g H''. Proof. use make_isKernel. intros w h0 H'. use unique_exists. - exact (KernelIn Z K w h0 H' · inv_from_z_iso h). - cbn beta. rewrite H. rewrite assoc. rewrite <- (assoc _ _ h). cbn. rewrite (is_inverse_in_precat2 h). rewrite id_right. apply KernelCommutes. - intros y0. apply hs. - intros y0 X. cbn beta in X. use (post_comp_with_z_iso_is_inj h). rewrite <- assoc. use (pathscomp0 _ (! (maponpaths (λ gg : _, KernelIn Z K w h0 H' · gg) (is_inverse_in_precat2 h)))). rewrite id_right. use KernelInsEq. rewrite KernelCommutes. rewrite <- X. rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. apply H. Qed. Definition Kernel_up_to_iso {x y z : C} (f : x --> y) (g : y --> z) (K : Kernel Z g) (h : z_iso x K) (H : f = h · (KernelArrow K)) : Kernel Z g := make_Kernel Z f _ (Kernel_up_to_iso_eq f g K h H) (Kernel_up_to_iso_isKernel f g K h H (Kernel_up_to_iso_eq f g K h H)). Lemma Kernel_up_to_iso2_eq {x y z : C} {f1 : x --> y} {f2 : x --> z} (h : z_iso y z) (H : f1 · h = f2) (K : Kernel Z f1) : KernelArrow K · f2 = ZeroArrow Z K z. Proof. rewrite <- H. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Definition Kernel_up_to_iso2_isKernel {x y z : C} (f1 : x --> y) (f2 : x --> z) (h : z_iso y z) (H : f1 · h = f2) (K : Kernel Z f1) : isKernel Z (KernelArrow K) f2 (Kernel_up_to_iso2_eq h H K). Proof. use make_isKernel. intros w h0 H'. use unique_exists. - use KernelIn. + exact h0. + rewrite <- H in H'. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ h) in H'. rewrite assoc in H'. apply (post_comp_with_z_iso_is_inj h) in H'. exact H'. - cbn. use KernelCommutes. - intros y0. apply hs. - intros y0 H''. use KernelInsEq. rewrite H''. apply pathsinv0. apply KernelCommutes. Qed. Definition Kernel_up_to_iso2 {x y z : C} {f1 : x --> y} {f2 : x --> z} {h : z_iso y z} (H : f1 · h = f2) (K : Kernel Z f1) : Kernel Z f2 := make_Kernel Z (KernelArrow K) _ (Kernel_up_to_iso2_eq h H K) (Kernel_up_to_iso2_isKernel f1 f2 h H K). End kernels_iso. (** * Kernel of morphism · monic *) (** ** Introduction Suppose f : x --> y is a morphism and M : y --> z is a Monic. Then kernel of f · M is isomorphic to kernel of f. *) Section kernels_monics. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Local Lemma KernelCompMonic_eq1 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : KernelArrow K1 · f = ZeroArrow Z K1 y. Proof. use (MonicisMonic C M). rewrite ZeroArrow_comp_left. rewrite <- assoc. use KernelCompZero. Qed. Definition KernelCompMonic_mor1 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : C⟦K1, K2⟧ := KernelIn Z K2 _ (KernelArrow K1) (KernelCompMonic_eq1 f M K1 K2). Local Lemma KernelCompMonic_eq2 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : KernelArrow K2 · (f · M) = ZeroArrow Z K2 z. Proof. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Definition KernelCompMonic_mor2 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : C⟦K2, K1⟧ := KernelIn Z K1 _ (KernelArrow K2) (KernelCompMonic_eq2 f M K1 K2). Lemma KernelCompMonic1 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : is_iso (KernelCompMonic_mor1 f M K1 K2). Proof. use is_iso_qinv. - exact (KernelCompMonic_mor2 f M K1 K2). - split. + unfold KernelCompMonic_mor1. unfold KernelCompMonic_mor2. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. apply id_left. + unfold KernelCompMonic_mor1. unfold KernelCompMonic_mor2. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. apply id_left. Qed. Lemma KernelCompMonic2 {x y z : C} (f : x --> y) (M : Monic C y z) (K1 : Kernel Z (f · M)) (K2 : Kernel Z f) : is_iso (KernelCompMonic_mor2 f M K1 K2). Proof. use is_iso_qinv. - exact (KernelCompMonic_mor1 f M K1 K2). - split. + unfold KernelCompMonic_mor1. unfold KernelCompMonic_mor2. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. apply id_left. + unfold KernelCompMonic_mor1. unfold KernelCompMonic_mor2. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. apply id_left. Qed. Local Lemma KernelCompMonic_eq {x y z : C} (f : x --> y) (M : Monic C y z) (K : Kernel Z (f · M)) : KernelArrow K · f = ZeroArrow Z K y. Proof. use (MonicisMonic C M). rewrite ZeroArrow_comp_left. rewrite <- assoc. use KernelCompZero. Qed. Lemma KernelCompMonic_isKernel {x y z : C} (f : x --> y) (M : Monic C y z) (K : Kernel Z (f · M)) : isKernel Z (KernelArrow K) f (KernelCompMonic_eq f M K). Proof. use make_isKernel. - intros w h H'. use unique_exists. + use KernelIn. * exact h. * rewrite assoc. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ M). apply cancel_postcomposition. exact H'. + cbn. rewrite KernelCommutes. apply idpath. + intros y0. apply hs. + intros y0 X. apply pathsinv0. cbn in X. use (MonicisMonic C (make_Monic _ _ (KernelArrowisMonic Z K))). cbn. rewrite KernelCommutes. apply pathsinv0. apply X. Qed. Definition KernelCompMonic {x y z : C} (f : x --> y) (M : Monic C y z) (K : Kernel Z (f · M)) : Kernel Z f. Proof. use make_Kernel. - exact K. - use KernelArrow. - exact (KernelCompMonic_eq f M K). - exact (KernelCompMonic_isKernel f M K). Defined. End kernels_monics. (** * KernelIn of equal, not necessarily definitionally equal, morphisms is iso *) Section kernel_in_paths. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Definition KernelInPaths_is_iso_mor {x y : C} {f f' : x --> y} (e : f = f') (K1 : Kernel Z f) (K2 : Kernel Z f') : K1 --> K2. Proof. induction e. use KernelIn. - use KernelArrow. - use KernelCompZero. Defined. Lemma KernelInPaths_is_iso {x y : C} {f f' : x --> y} (e : f = f') (K1 : Kernel Z f) (K2 : Kernel Z f') : is_iso (KernelInPaths_is_iso_mor e K1 K2). Proof. induction e. apply KernelsIn_is_iso. Qed. Local Lemma KernelPath_eq {x y : C} {f f' : x --> y} (e : f = f') (K : Kernel Z f) : KernelArrow K · f' = ZeroArrow Z K y. Proof. induction e. use KernelCompZero. Qed. Local Lemma KernelPath_isKernel {x y : C} {f f' : x --> y} (e : f = f') (K : Kernel Z f) : isKernel Z (KernelArrow K) f' (KernelPath_eq e K). Proof. induction e. use KernelisKernel. Qed. (** Constructs a cokernel of f' from a cokernel of f in a natural way *) Definition KernelPath {x y : C} {f f' : x --> y} (e : f = f') (K : Kernel Z f) : Kernel Z f'. Proof. use make_Kernel. - exact K. - use KernelArrow. - exact (KernelPath_eq e K). - exact (KernelPath_isKernel e K). Defined. End kernel_in_paths. (** * Transports of kernels *) Section transport_kernels. Variable C : category. Let hs : has_homsets C := homset_property C. Variable Z : Zero C. Local Lemma transport_source_KernelIn_eq {x' x y z : C} (f : x --> y) {g : y --> z} (K : Kernel Z g) (e : x = x') (H : f · g = ZeroArrow Z _ _) : (transportf (λ x' : ob C, precategory_morphisms x' y) e f) · g = ZeroArrow Z _ _. Proof. induction e. apply H. Qed. Lemma transport_source_KernelIn {x' x y z : C} (f : x --> y) {g : y --> z} (K : Kernel Z g) (e : x = x') (H : f · g = ZeroArrow Z _ _) : transportf (λ x' : ob C, precategory_morphisms x' K) e (KernelIn Z K _ f H) = KernelIn Z K _ (transportf (λ x' : ob C, precategory_morphisms x' y) e f) (transport_source_KernelIn_eq f K e H). Proof. induction e. use KernelInsEq. cbn. rewrite KernelCommutes. rewrite KernelCommutes. apply idpath. Qed. End transport_kernels. UniMath-20231010/UniMath/CategoryTheory/limits/products.v000066400000000000000000000357451451125700300231750ustar00rootroot00000000000000(** Direct implementation of indexed products together with: - The general product functor ([product_functor]) - Definition of a product structure on a functor category by taking pointwise products in the target category (adapted from the binary version) ([Products_functor_precat]) - Products from limits ([Products_from_Lims]) Written by: Anders Mörtberg 2016 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.Combinatorics.StandardFiniteSets. Local Open Scope cat. (** * Definition of indexed products of objects in a precategory *) Section product_def. Context (I : UU) (C : category). Definition isProduct (c : ∏ (i : I), C) (p : C) (pi : ∏ i, p --> c i) := ∏ (a : C) (f : ∏ i, a --> c i), ∃! (fap : a --> p), ∏ i, fap · pi i = f i. Definition Product (ci : ∏ i, C) := ∑ pp1p2 : (∑ p : C, ∏ i, p --> ci i), isProduct ci (pr1 pp1p2) (pr2 pp1p2). Definition Products := ∏ (ci : ∏ i, C), Product ci. Definition hasProducts := ∏ (ci : ∏ i, C), ∥ Product ci ∥. Definition ProductObject {c : ∏ i, C} (P : Product c) : C := pr1 (pr1 P). Coercion ProductObject : Product >-> ob. Definition ProductPr {c : ∏ i, C} (P : Product c) : ∏ i, P --> c i := pr2 (pr1 P). Definition isProduct_Product {c : ∏ i, C} (P : Product c) : isProduct c P (ProductPr P). Proof. exact (pr2 P). Defined. Definition ProductArrow {c : ∏ i, C} (P : Product c) {a : C} (f : ∏ i, a --> c i) : a --> P. Proof. apply (pr1 (pr1 (isProduct_Product P _ f))). Defined. Lemma ProductPrCommutes (c : ∏ i, C) (P : Product c) : ∏ (a : C) (f : ∏ i, a --> c i) i, ProductArrow P f · ProductPr P i = f i. Proof. intros a f i. apply (pr2 (pr1 (isProduct_Product P _ f)) i). Qed. Lemma ProductPr_idtoiso {i1 i2 : I} (a : I -> C) (P : Product a) (e : i1 = i2) : ProductPr P i1 · idtoiso (maponpaths a e) = ProductPr P i2. Proof. induction e. apply id_right. Qed. Lemma ProductArrowUnique (c : ∏ i, C) (P : Product c) (x : C) (f : ∏ i, x --> c i) (k : x --> P) (Hk : ∏ i, k · ProductPr P i = f i) : k = ProductArrow P f. Proof. set (H' := pr2 (isProduct_Product P _ f) (k,,Hk)). apply (base_paths _ _ H'). Qed. Definition make_Product (a : ∏ i, C) : ∏ (c : C) (f : ∏ i, C⟦c,a i⟧), isProduct _ _ f -> Product a. Proof. intros c f X. exact (tpair _ (c,,f) X). Defined. Definition make_isProduct (hsC : has_homsets C) (a : I -> C) (p : C) (pa : ∏ i, C⟦p,a i⟧) : (∏ (c : C) (f : ∏ i, C⟦c,a i⟧), ∃! k : C⟦c,p⟧, ∏ i, k · pa i = f i) -> isProduct a p pa. Proof. intros H c cc; apply H. Defined. Lemma ProductArrowEta (c : ∏ i, C) (P : Product c) (x : C) (f : x --> P) : f = ProductArrow P (λ i, f · ProductPr P i). Proof. now apply ProductArrowUnique. Qed. Proposition ProductArrow_eq {d : I → C} (w : C) (x : Product d) (f g : w --> x) (p : ∏ (i : I), f · ProductPr x i = g · ProductPr x i) : f = g. Proof. refine (ProductArrowEta _ _ _ _ @ _ @ !(ProductArrowEta _ _ _ _)). apply maponpaths. use funextsec. exact p. Qed. Definition ProductOfArrows {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C} (Pa : Product a) (f : ∏ i, a i --> c i) : Pa --> Pc := ProductArrow Pc (λ i, ProductPr Pa i · f i). Lemma ProductOfArrowsPr {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C} (Pa : Product a) (f : ∏ i, a i --> c i) : ∏ i, ProductOfArrows Pc Pa f · ProductPr Pc i = ProductPr Pa i · f i. Proof. unfold ProductOfArrows; intro i. now rewrite (ProductPrCommutes _ _ _ _ i). Qed. Lemma postcompWithProductArrow {c : ∏ i, C} (Pc : Product c) {a : ∏ i, C} (Pa : Product a) (f : ∏ i, a i --> c i) {x : C} (k : ∏ i, x --> a i) : ProductArrow Pa k · ProductOfArrows Pc Pa f = ProductArrow Pc (λ i, k i · f i). Proof. apply ProductArrowUnique; intro i. now rewrite <- assoc, ProductOfArrowsPr, assoc, ProductPrCommutes. Qed. Lemma precompWithProductArrow {c : ∏ i, C} (Pc : Product c) {a : C} (f : ∏ i, a --> c i) {x : C} (k : x --> a) : k · ProductArrow Pc f = ProductArrow Pc (λ i, k · f i). Proof. apply ProductArrowUnique; intro i. now rewrite <- assoc, ProductPrCommutes. Qed. End product_def. Section Products. Context (I : UU) (C : category) (CC : Products I C). Definition ProductOfArrows_comp (a b c : ∏ (i : I), C) (f : ∏ i, a i --> b i) (g : ∏ i, b i --> c i) : ProductOfArrows _ _ _ _ f · ProductOfArrows _ _ _ (CC _) g = ProductOfArrows _ _ (CC _) (CC _) (λ i, f i · g i). Proof. apply ProductArrowUnique; intro i. rewrite <- assoc, ProductOfArrowsPr. now rewrite assoc, ProductOfArrowsPr, assoc. Qed. End Products. Section finite_products. Definition finite_products (C : category) := ∏ (n : nat), Products (stn n) C. End finite_products. Section Product_unique. Context (I : UU) (C : category) (CC : Products I C) (a : ∏ (i : I), C). Lemma Product_endo_is_identity (P : Product _ _ a) (k : P --> P) (H1 : ∏ i, k · ProductPr _ _ P i = ProductPr _ _ P i) : identity _ = k. Proof. apply pathsinv0. eapply pathscomp0. apply ProductArrowEta. apply pathsinv0. apply ProductArrowUnique; intro i; apply pathsinv0. now rewrite id_left, H1. Qed. End Product_unique. (** * The product functor: C^I -> C *) Section product_functor. Context (I : UU) {C : category} (PC : Products I C). Definition product_functor_data : functor_data (power_category I C) C. Proof. use tpair. - intros p. apply (ProductObject _ _ (PC p)). - intros p q f. exact (ProductOfArrows _ _ _ _ f). Defined. Definition product_functor : functor (power_category I C) C. Proof. apply (tpair _ product_functor_data). abstract (split; [ now intro x; simpl; apply pathsinv0, Product_endo_is_identity; intro i; rewrite ProductOfArrowsPr, id_right | now intros x y z f g; simpl; rewrite ProductOfArrows_comp]). Defined. End product_functor. (* The product of a family of functors *) Definition product_of_functors_alt (I : UU) {C D : category} (HD : Products I D) (F : ∏ (i : I), functor C D) : functor C D := functor_composite (delta_functor I C) (functor_composite (family_functor _ F) (product_functor _ HD)). (** * Products lift to functor categories *) Section def_functor_pointwise_prod. Context(I : UU) (C D : category) (HD : Products I D). Section product_of_functors. Context (F : I -> functor C D). Definition product_of_functors_ob (c : C) : D := HD (λ i, F i c). Definition product_of_functors_mor (c c' : C) (f : c --> c') : product_of_functors_ob c --> product_of_functors_ob c' := ProductOfArrows _ _ _ _ (λ i, # (F i) f). Definition product_of_functors_data : functor_data C D. Proof. exists product_of_functors_ob. exact product_of_functors_mor. Defined. Lemma is_functor_product_of_functors_data : is_functor product_of_functors_data. Proof. split; simpl; intros. - unfold functor_idax; intros; simpl in *. apply pathsinv0. apply Product_endo_is_identity; intro i. unfold product_of_functors_mor. eapply pathscomp0; [apply (ProductOfArrowsPr _ _ (HD (λ i, (F i) a)))|]. now simpl; rewrite functor_id, id_right. - unfold functor_compax; simpl; unfold product_of_functors_mor. intros; simpl in *. apply pathsinv0. eapply pathscomp0. apply ProductOfArrows_comp. apply maponpaths, funextsec; intro i. now rewrite functor_comp. Qed. Definition product_of_functors : functor C D := tpair _ _ is_functor_product_of_functors_data. Lemma product_of_functors_alt_eq_product_of_functors : product_of_functors_alt _ HD F = product_of_functors. Proof. now apply (functor_eq _ _ D). Qed. Definition product_nat_trans_pr_data i (c : C) : D ⟦ product_of_functors c, (F i) c ⟧ := ProductPr _ _ (HD (λ j, (F j) c)) i. Lemma is_nat_trans_product_nat_trans_pr_data i : is_nat_trans _ _ (product_nat_trans_pr_data i). Proof. intros c c' f. apply (ProductOfArrowsPr I _ (HD (λ i, F i c')) (HD (λ i, F i c))). Qed. Definition product_nat_trans_pr i : nat_trans product_of_functors (F i) := tpair _ _ (is_nat_trans_product_nat_trans_pr_data i). Section vertex. (** The product morphism of a diagram with vertex [A] *) Context (A : functor C D) (f : ∏ i, nat_trans A (F i)). Definition product_nat_trans_data c : A c --> product_of_functors c:= ProductArrow _ _ _ (λ i, f i c). Lemma is_nat_trans_product_nat_trans_data : is_nat_trans _ _ product_nat_trans_data. Proof. intros a b k; simpl. eapply pathscomp0; [apply precompWithProductArrow|]. apply pathsinv0. eapply pathscomp0; [apply postcompWithProductArrow|]. apply maponpaths, funextsec; intro i. now rewrite (nat_trans_ax (f i)). Qed. Definition product_nat_trans : nat_trans A product_of_functors := tpair _ _ is_nat_trans_product_nat_trans_data. End vertex. Definition functor_precat_product_cone : Product I [C, D] F. Proof. use make_Product. - apply product_of_functors. - apply product_nat_trans_pr. - use make_isProduct. + apply functor_category_has_homsets. + intros A f. use tpair. * apply (tpair _ (product_nat_trans A f)). abstract (intro i; apply (nat_trans_eq D); intro c; apply (ProductPrCommutes I D _ (HD (λ j, (F j) c)))). * abstract ( intro t; apply subtypePath; simpl; [intro; apply impred; intro; apply (isaset_nat_trans D)|]; apply (nat_trans_eq D); intro c; apply ProductArrowUnique; intro i; apply (nat_trans_eq_pointwise (pr2 t i))). Defined. End product_of_functors. Definition Products_functor_precat : Products I [C, D]. Proof. intros F; apply functor_precat_product_cone. Defined. End def_functor_pointwise_prod. (** * Products from limits *) Section products_from_limits. Context (I : UU) (C : category). Definition I_graph : graph := (I,,λ _ _,empty). Definition products_diagram (F : I → C) : diagram I_graph C. Proof. exists F. abstract (intros u v e; induction e). Defined. Definition productscone c (F : I → C) (H : ∏ i, c --> F i) : cone (products_diagram F) c. Proof. use tpair. + intro v; apply H. + abstract (intros u v e; induction e). Defined. Lemma Products_from_Lims : Lims_of_shape I_graph C -> Products I C. Proof. intros H F. set (HF := H (products_diagram F)). use make_Product. + apply (lim HF). + intros i; apply (limOut HF). + apply (make_isProduct _ _ C); intros c Fic. use unique_exists. - apply limArrow. use make_cone. * simpl; intro i; apply Fic. * abstract (simpl; intros u v e; induction e). - abstract (simpl; intro i; apply (limArrowCommutes HF)). - abstract (intros y; apply impred; intro i; apply C). - abstract (intros f Hf; apply limArrowUnique; simpl in *; intros i; apply Hf). Defined. End products_from_limits. (** Products are closed under iso *) Definition isProduct_z_iso {C : category} {J : UU} (D : J → C) {x y : C} (h : z_iso x y) (px : ∏ (j : J), x --> D j) (py : ∏ (j : J), y --> D j) (Hx : isProduct J _ D x px) (q : ∏ (j : J), py j = inv_from_z_iso h · px j) : isProduct J _ D y py. Proof. use make_isProduct. { apply homset_property. } intros z f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; use (cancel_z_iso _ _ (z_iso_inv h)) ; use (ProductArrow_eq _ _ _ (make_Product _ _ _ _ _ Hx)) ; cbn ; intro j ; rewrite !assoc' ; rewrite <- q ; exact (pr2 φ₁ j @ !(pr2 φ₂ j))). - refine (ProductArrow _ _ (make_Product _ _ _ _ _ Hx) f · h ,, _). abstract (intro j ; rewrite !assoc' ; rewrite q ; rewrite (maponpaths (λ z, _ · z) (assoc _ _ _)) ; rewrite z_iso_inv_after_z_iso ; rewrite id_left ; apply ProductPrCommutes). Defined. (** Products are unique *) Definition eq_Product {C : category} {J : UU} {D : J → C} (prod₁ prod₂ : Product J C D) (q : ProductObject _ _ prod₁ = ProductObject _ _ prod₂) (e : ∏ (j : J), ProductPr _ _ prod₁ j = idtoiso q · ProductPr _ _ prod₂ j) : prod₁ = prod₂. Proof. use subtypePath. { intro. repeat (use impred ; intro). use isapropiscontr. } use total2_paths_f. - exact q. - rewrite transportf_sec_constant. use funextsec. intro j. rewrite <- !idtoiso_precompose. rewrite !idtoiso_inv. use z_iso_inv_on_right. exact (e j). Qed. Definition z_iso_between_Product {C : category} {J : UU} {D : J → C} (prod₁ prod₂ : Product J C D) : z_iso prod₁ prod₂. Proof. use make_z_iso. - exact (ProductArrow _ _ prod₂ (ProductPr _ _ prod₁)). - exact (ProductArrow _ _ prod₁ (ProductPr _ _ prod₂)). - split. + abstract (use ProductArrow_eq ; intro j ; rewrite !assoc' ; rewrite !ProductPrCommutes ; rewrite id_left ; apply idpath). + abstract (use ProductArrow_eq ; intro j ; rewrite !assoc' ; rewrite !ProductPrCommutes ; rewrite id_left ; apply idpath). Defined. Definition isaprop_Product {C : category} (HC : is_univalent C) (J : UU) (D : J → C) : isaprop (Product J C D). Proof. use invproofirrelevance. intros p₁ p₂. use eq_Product. - refine (isotoid _ HC _). apply z_iso_between_Product. - rewrite idtoiso_isotoid ; cbn. intro j. rewrite ProductPrCommutes. apply idpath. Qed. Definition isProduct_eq_arrow {C : category} {J : UU} {D : J → C} {ys : C} {π π' : ∏ (j : J), ys --> D j} (q : ∏ (j : J), π j = π' j) (H : isProduct J C D ys π) : isProduct J C D ys π'. Proof. intros w f. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ; use (ProductArrow_eq _ _ _ (make_Product _ _ _ _ _ H)) ; intro j ; cbn ; rewrite !q ; exact (pr2 φ₁ j @ !(pr2 φ₂ j))). - simple refine (_ ,, _). + exact (ProductArrow _ _ (make_Product _ _ _ _ _ H) f). + abstract (cbn ; intro j ; rewrite <- q ; apply (ProductPrCommutes _ _ _ (make_Product _ _ _ _ _ H))). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/pullbacks.v000066400000000000000000001540101451125700300232750ustar00rootroot00000000000000(** Direct implementation of pullbacks together with: - Proof that pullbacks form a property in a (saturated/univalent) category ([isaprop_Pullbacks]) - The pullback of a monic is monic ([MonicPullbackisMonic]) - A square isomorphic to a pullback is a pullback (case 1) ([isPullback_iso_of_morphisms]) - The pullback of a z_iso is a z_iso ([Pullback_of_z_iso]) - Symmetry ([is_symmetric_isPullback]) - Construction of pullbacks from equalizers and binary products ([Pullbacks_from_Equalizers_BinProducts]) - A fully faithful functor reflects limits ([isPullback_preimage_square]) - A fully faithfull and essentially surjects functor preserves pullbacks ([isPullback_image_square]) - Pullbacks in functor categories ([FunctorcategoryPullbacks]) - Construction of binary products from pullbacks ([BinProductsFromPullbacks]) - The type of pullbacks on a given diagram is a proposition *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Monics. Local Open Scope cat. (** Definition of pullbacks *) Section def_pb. Context (C : category). Definition isPullback {a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) : UU := ∏ e (h : e --> b) (k : e --> c) (H : h · f = k · g ), ∃! hk : e --> d, (hk · p1 = h) × (hk · p2 = k). Lemma isaprop_isPullback {a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) : isaprop (isPullback f g p1 p2 H). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Lemma PullbackArrowUnique {a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) (P : isPullback f g p1 p2 H) e (h : e --> b) (k : e --> c) (Hcomm : h · f = k · g) (w : e --> d) (H1 : w · p1 = h) (H2 : w · p2 = k) : w = (pr1 (pr1 (P e h k Hcomm))). Proof. set (T := tpair (fun hk : e --> d => dirprod (hk · p1 = h)(hk · p2 = k)) w (make_dirprod H1 H2)). set (T' := pr2 (P e h k Hcomm) T). exact (base_paths _ _ T'). Qed. Definition Pullback {a b c : C} (f : b --> a) (g : c --> a) := ∑ pfg : (∑ p : C, (p --> b) × (p --> c)), ∑ (H : pr1 (pr2 pfg) · f = pr2 (pr2 pfg) · g), isPullback f g (pr1 (pr2 pfg)) (pr2 (pr2 pfg)) H. Definition Pullbacks : UU := ∏ (a b c : C) (f : b --> a) (g : c --> a), Pullback f g. Definition hasPullbacks : UU := ∏ (a b c : C) (f : b --> a) (g : c --> a), ishinh (Pullback f g). Definition PullbackObject {a b c : C} {f : b --> a} {g : c --> a}: Pullback f g -> C := λ H, pr1 (pr1 H). Coercion PullbackObject : Pullback >-> ob. Definition PullbackPr1 {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) : Pb --> b := pr1 (pr2 (pr1 Pb)). Definition PullbackPr2 {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) : Pb --> c := pr2 (pr2 (pr1 Pb)). Definition PullbackSqrCommutes {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) : PullbackPr1 Pb · f = PullbackPr2 Pb · g . Proof. exact (pr1 (pr2 Pb)). Qed. Definition isPullback_Pullback {a b c : C} {f : b --> a} {g : c --> a} (P : Pullback f g) : isPullback f g (PullbackPr1 P) (PullbackPr2 P) (PullbackSqrCommutes P). Proof. exact (pr2 (pr2 P)). Defined. Definition PullbackArrow {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) e (h : e --> b) (k : e --> c) (H : h · f = k · g) : e --> Pb := pr1 (pr1 (isPullback_Pullback Pb e h k H)). Lemma PullbackArrowUnique' {a b c : C} (f : C⟦b,a⟧) (g : C⟦c,a⟧) (P : Pullback f g) e (h : C⟦e,b⟧) (k : C⟦e,c⟧) (Hcomm : h · f = k · g) (w : C⟦e,P⟧) (H1 : w · PullbackPr1 P = h) (H2 : w · PullbackPr2 P = k) : w = PullbackArrow P e h k Hcomm. Proof. now apply PullbackArrowUnique. Qed. Lemma PullbackArrow_PullbackPr1 {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) e (h : e --> b) (k : e --> c) (H : h · f = k · g) : PullbackArrow Pb e h k H · PullbackPr1 Pb = h. Proof. exact (pr1 (pr2 (pr1 (isPullback_Pullback Pb e h k H)))). Qed. Lemma PullbackArrow_PullbackPr2 {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) e (h : e --> b) (k : e --> c) (H : h · f = k · g) : PullbackArrow Pb e h k H · PullbackPr2 Pb = k. Proof. exact (pr2 (pr2 (pr1 (isPullback_Pullback Pb e h k H)))). Qed. Definition make_Pullback {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (d : C) (p1 : C⟦d,b⟧) (p2 : C ⟦d,c⟧) (H : p1 · f = p2 · g) (ispb : isPullback f g p1 p2 H) : Pullback f g. Proof. use tpair. - use tpair. + apply d. + exists p1. exact p2. - exists H. apply ispb. Defined. Definition make_isPullback {a b c d : C} (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (p1 : C⟦d,b⟧) (p2 : C⟦d,c⟧) (H : p1 · f = p2 · g) : (∏ e (h : C ⟦e, b⟧) (k : C⟦e,c⟧) (Hk : h · f = k · g ), ∃! hk : C⟦e,d⟧, (hk · p1 = h) × (hk · p2 = k)) → isPullback f g p1 p2 H. Proof. intros H' x cx k sqr. apply H'. assumption. Defined. Local Lemma postCompWithPullbackArrow_subproof {c d a b x : C} (k0 : C⟦c,d⟧) {f : C⟦a,x⟧} {g : C⟦b,x⟧} {h : C ⟦ d, a ⟧} {k : C ⟦ d, b ⟧} (H : h · f = k · g) : k0 · h · f = k0 · k · g. Proof. now rewrite <- assoc, H, assoc. Qed. Lemma postCompWithPullbackArrow (c d : C) (k0 : C⟦c,d⟧) {a b x : C} {f : C⟦a,x⟧} {g : C⟦b,x⟧} (Pb : Pullback f g) (h : C ⟦ d, a ⟧) (k : C ⟦ d, b ⟧) (H : h · f = k · g) : k0 · PullbackArrow Pb d h k H = PullbackArrow Pb _ (k0 · h) (k0 · k) (postCompWithPullbackArrow_subproof k0 H). Proof. apply PullbackArrowUnique. - now rewrite <- assoc, PullbackArrow_PullbackPr1. - now rewrite <- assoc, PullbackArrow_PullbackPr2. Qed. Lemma MorphismsIntoPullbackEqual {a b c d : C} {f : b --> a} {g : c --> a} {p1 : d --> b} {p2 : d --> c} {H : p1 · f = p2 · g} (P : isPullback f g p1 p2 H) {e} (w w': e --> d) (H1 : w · p1 = w' · p1) (H2 : w · p2 = w' · p2) : w = w'. Proof. assert (Hw : w · p1 · f = w · p2 · g). { rewrite <- assoc , H, assoc; apply idpath. } assert (Hw' : w' · p1 · f = w' · p2 · g). { rewrite <- assoc , H, assoc; apply idpath. } set (Pb := make_Pullback _ _ _ _ _ _ P). set (Xw := PullbackArrow Pb e (w·p1) (w·p2) Hw). intermediate_path Xw; [ apply PullbackArrowUnique; apply idpath |]. apply pathsinv0. apply PullbackArrowUnique. apply pathsinv0. apply H1. apply pathsinv0. apply H2. Qed. Definition identity_is_Pullback_input {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) : ∑ hk : Pb --> Pb, (hk · PullbackPr1 Pb = PullbackPr1 Pb) × (hk · PullbackPr2 Pb = PullbackPr2 Pb). Proof. exists (identity Pb). apply make_dirprod; apply id_left. Defined. Lemma PullbackEndo_is_identity {a b c : C} {f : b --> a} {g : c --> a} (Pb : Pullback f g) (k : Pb --> Pb) (kH1 : k · PullbackPr1 Pb = PullbackPr1 Pb) (kH2 : k · PullbackPr2 Pb = PullbackPr2 Pb) : identity Pb = k. Proof. set (H1 := tpair ((fun hk : Pb --> Pb => dirprod (hk · _ = _)(hk · _ = _))) k (make_dirprod kH1 kH2)). assert (H2 : identity_is_Pullback_input Pb = H1). - apply proofirrelevancecontr. apply (isPullback_Pullback Pb). apply PullbackSqrCommutes. - apply (base_paths _ _ H2). Qed. Definition from_Pullback_to_Pullback {a b c : C} {f : b --> a} {g : c --> a} (Pb Pb': Pullback f g) : Pb --> Pb'. Proof. apply (PullbackArrow Pb' Pb (PullbackPr1 _ ) (PullbackPr2 _)). exact (PullbackSqrCommutes _ ). Defined. Lemma are_inverses_from_Pullback_to_Pullback {a b c : C} {f : b --> a} {g : c --> a} (Pb Pb': Pullback f g) : is_inverse_in_precat (from_Pullback_to_Pullback Pb Pb') (from_Pullback_to_Pullback Pb' Pb). Proof. split; apply pathsinv0; apply PullbackEndo_is_identity; rewrite <- assoc; unfold from_Pullback_to_Pullback; repeat rewrite PullbackArrow_PullbackPr1; repeat rewrite PullbackArrow_PullbackPr2; auto. Qed. Lemma isziso_from_Pullback_to_Pullback {a b c : C} {f : b --> a} {g : c --> a} (Pb Pb': Pullback f g) : is_z_isomorphism (from_Pullback_to_Pullback Pb Pb'). Proof. exists (from_Pullback_to_Pullback Pb' Pb). apply are_inverses_from_Pullback_to_Pullback. Defined. Definition z_iso_from_Pullback_to_Pullback {a b c : C}{f : b --> a} {g : c --> a} (Pb Pb': Pullback f g) : z_iso Pb Pb' := _ ,, isziso_from_Pullback_to_Pullback Pb Pb'. Lemma pullbackiso {A B D:C} {f : A --> D} {g : B --> D} (pb : Pullback f g) (pb' : Pullback f g) : ∑ (t : z_iso (PullbackObject pb) (PullbackObject pb')), t · PullbackPr1 pb' = PullbackPr1 pb × t · PullbackPr2 pb' = PullbackPr2 pb. Proof. use tpair. - use z_iso_from_Pullback_to_Pullback. - split. + use PullbackArrow_PullbackPr1. + use PullbackArrow_PullbackPr2. Defined. (** pullback lemma *) Section pullback_lemma. Context (a b c d e x : C) (f : b --> a) (g : c --> a) (h : e --> b) (k : e --> c) (i : d --> b) (j : x --> e) (m : x --> d) (H1 : h · f = k · g) (H2 : m · i = j · h) (P1 : isPullback _ _ _ _ H1) (P2 : isPullback _ _ _ _ H2). Lemma glueSquares : m · (i · f) = (j · k) · g. Proof. rewrite assoc. rewrite H2. repeat rewrite <- assoc. rewrite H1. apply idpath. Qed. Lemma isPullbackGluedSquare : isPullback (i · f) g m (j · k) glueSquares. Proof. unfold isPullback. intros y p q. intro Hrt. assert (ex : (p · i) · f = q · g). { rewrite <- Hrt. rewrite assoc; apply idpath. } set (rt := P1 _ (p · i) q ex). set (Ppiq := pr1 (pr1 (rt))). assert (owiej : p · i = Ppiq · h). { apply pathsinv0. apply (pr1 (pr2 (pr1 rt))). } set (rt' := P2 _ p Ppiq owiej). set (awe := pr1 (pr1 rt')). assert (Hawe1 : awe · m = p). { exact (pr1 (pr2 (pr1 rt'))). } assert (Hawe2 : awe · (j · k) = q). { rewrite assoc. set (X := pr2 (pr2 (pr1 rt'))). simpl in X. unfold awe. rewrite X. exact (pr2 (pr2 (pr1 rt))). } exists (tpair _ awe (make_dirprod Hawe1 Hawe2)). abstract ( intro t; apply subtypePath; [ intro a0; apply isapropdirprod; apply C | destruct t as [t [Ht1 Ht2]]; apply PullbackArrowUnique; [ assumption | apply PullbackArrowUnique; [ rewrite <- Ht1; repeat rewrite <- assoc; rewrite H2; apply idpath | rewrite <- assoc; assumption ] ] ]). Defined. End pullback_lemma. Definition pullback_glue_pullback {a b c e : C} {f : b --> a} {g : c --> a} {h : e --> b} (pbr : Pullback f g) (pbl : Pullback h (PullbackPr1 pbr)) : Pullback (h · f) g. Proof. use make_Pullback. + exact pbl. + exact (PullbackPr1 pbl). + exact ((PullbackPr2 pbl) · (PullbackPr2 pbr)). + abstract (use glueSquares; [ exact (PullbackPr1 pbr) | use (PullbackSqrCommutes pbr) | use PullbackSqrCommutes ]). + use (isPullbackGluedSquare _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (isPullback_Pullback pbr) (isPullback_Pullback pbl)). Defined. End def_pb. Arguments isPullback [_ _ _ _ _ _ _ _ _] _. Arguments Pullback [_ _ _ _] _ _. Arguments PullbackArrow [_ _ _ _ _ _ ] _ _ _ _ _ . Arguments make_Pullback [_ _ _ _ _ _ _ _ _] _ _. Arguments PullbackObject [_ _ _ _ _ _ ] _. Arguments z_iso_from_Pullback_to_Pullback [_ _ _ _ _ _] _ _. Arguments from_Pullback_to_Pullback [_ _ _ _ _ _] _ _. Arguments are_inverses_from_Pullback_to_Pullback [_ _ _ _ _ _] _ _. Arguments PullbackPr1 [_ _ _ _ _ _] _. Arguments PullbackPr2 [_ _ _ _ _ _] _. Arguments isPullback_Pullback [_ _ _ _ _ _] _. Arguments MorphismsIntoPullbackEqual [_ _ _ _ _ _ _ _ _ _] _ _ _ _ . Arguments PullbackSqrCommutes [_ _ _ _ _ _] _. Arguments PullbackArrow_PullbackPr1 [_ _ _ _ _ _] _ _ _ _ _. Arguments PullbackArrow_PullbackPr2 [_ _ _ _ _ _] _ _ _ _ _. Arguments PullbackArrowUnique [_ _ _ _ _ _ _ _ _ ] _ _ _ _ _ _ _ _ _ . Section Universal_Unique. Context (C : category) (H : is_univalent C). Lemma inv_from_z_iso_z_iso_from_Pullback (a b c : C) (f : b --> a) (g : c --> a) (Pb : Pullback f g) (Pb' : Pullback f g): inv_from_z_iso (z_iso_from_Pullback_to_Pullback Pb Pb') = from_Pullback_to_Pullback Pb' Pb. Proof. apply idpath. Qed. Lemma isaprop_Pullbacks: isaprop (Pullbacks C). Proof. apply impred; intro a; apply impred; intro b; apply impred; intro c; apply impred; intro f; apply impred; intro g; apply invproofirrelevance. intros Pb Pb'. apply subtypePath. - intro; apply isofhleveltotal2. + apply C. + intros; apply isaprop_isPullback. - apply (total2_paths_f (isotoid _ H (z_iso_from_Pullback_to_Pullback Pb Pb' ))). rewrite transportf_dirprod, transportf_isotoid. rewrite inv_from_z_iso_z_iso_from_Pullback. rewrite transportf_isotoid. rewrite inv_from_z_iso_z_iso_from_Pullback. destruct Pb as [Cone bla]; destruct Pb' as [Cone' bla']; simpl in *. destruct Cone as [p [h k]]; destruct Cone' as [p' [h' k']]; simpl in *. unfold from_Pullback_to_Pullback; rewrite PullbackArrow_PullbackPr2, PullbackArrow_PullbackPr1. apply idpath. Qed. End Universal_Unique. (** Make the C not implicit for Pullbacks *) Arguments Pullbacks : clear implicits. (** In this section we prove that the pullback of a monomorphism is a monomorphism. *) Section monic_pb. Context (C : category). (** The pullback of a Monic is isMonic. *) Lemma MonicPullbackisMonic {a b c : C} (M : Monic _ b a) (g : c --> a) (PB : Pullback M g) : isMonic (PullbackPr2 PB). Proof. apply make_isMonic. intros x g0 h X. use (MorphismsIntoPullbackEqual (isPullback_Pullback PB) _ _ _ _ X). set (X0 := maponpaths (λ f, f · g) X); simpl in X0. rewrite <- assoc in X0. rewrite <- assoc in X0. rewrite <- (PullbackSqrCommutes PB) in X0. rewrite assoc in X0. rewrite assoc in X0. apply (pr2 M _ _ _) in X0. apply X0. Qed. (** Same result for the other morphism. *) Lemma MonicPullbackisMonic' {a b c : C} (f : b --> a) (M : Monic _ c a) (PB : Pullback f M) : isMonic (PullbackPr1 PB). Proof. apply make_isMonic. intros x g h X. use (MorphismsIntoPullbackEqual (isPullback_Pullback PB) _ _ _ X). set (X0 := maponpaths (λ f', f' · f) X); simpl in X0. rewrite <- assoc in X0. rewrite <- assoc in X0. rewrite (PullbackSqrCommutes PB) in X0. rewrite assoc in X0. rewrite assoc in X0. apply (pr2 M _ _ _) in X0. apply X0. Qed. End monic_pb. Arguments glueSquares {_ _ _ _ _ _ _ _ _ _ _ _ _ _ } _ _ . Arguments isPullbackGluedSquare [_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _] _ _ [_ _ _] _. (** * Criteria for existence of pullbacks. *) Section pb_criteria. Context (C : category). Lemma Pullback_from_Equalizer_BinProduct_eq (X Y Z : C) (f : X --> Z) (g : Y --> Z) (BinProd : BinProduct C X Y) (Eq : Equalizer ((BinProductPr1 C BinProd) · f) ((BinProductPr2 C BinProd) · g)) : EqualizerArrow Eq · (BinProductPr1 C BinProd) · f = EqualizerArrow Eq · (BinProductPr2 C BinProd) · g. Proof. repeat rewrite <- assoc. apply EqualizerEqAr. Qed. Definition Pullback_from_Equalizer_BinProduct_isPullback (X Y Z : C) (f : X --> Z) (g : Y --> Z) (BinProd : BinProduct C X Y) (Eq : Equalizer ((BinProductPr1 C BinProd) · f) ((BinProductPr2 C BinProd) · g)) : isPullback (*f g (EqualizerArrow Eq · BinProductPr1 C BinProd) (EqualizerArrow Eq · BinProductPr2 C BinProd)*) (Pullback_from_Equalizer_BinProduct_eq X Y Z f g BinProd Eq). Proof. use make_isPullback. intros e h k Hk. set (com1 := BinProductPr1Commutes C _ _ BinProd _ h k). set (com2 := BinProductPr2Commutes C _ _ BinProd _ h k). apply (maponpaths (λ l : _, l · f)) in com1. apply (maponpaths (λ l : _, l · g)) in com2. rewrite <- com1 in Hk. rewrite <- com2 in Hk. repeat rewrite <- assoc in Hk. apply (unique_exists (EqualizerIn Eq _ _ Hk)). (* Commutativity *) split. rewrite assoc. rewrite (EqualizerCommutes Eq e _). exact (BinProductPr1Commutes C _ _ BinProd _ h k). rewrite assoc. rewrite (EqualizerCommutes Eq e _). exact (BinProductPr2Commutes C _ _ BinProd _ h k). (* Equality on equalities of morphisms. *) intros y. apply isapropdirprod; apply C. (* Uniqueness *) intros y H. induction H as [t p]. apply EqualizerInsEq. apply BinProductArrowsEq. rewrite assoc in t. rewrite t. rewrite (EqualizerCommutes Eq e _). apply pathsinv0. exact (BinProductPr1Commutes C _ _ BinProd _ h k). rewrite assoc in p. rewrite p. rewrite (EqualizerCommutes Eq e _). apply pathsinv0. exact (BinProductPr2Commutes C _ _ BinProd _ h k). Qed. (* why opaque? *) Definition Pullback_from_Equalizer_BinProduct (X Y Z : C) (f : X --> Z) (g : Y --> Z) (BinProd : BinProduct C X Y) (Eq : Equalizer ((BinProductPr1 C BinProd) · f) ((BinProductPr2 C BinProd) · g)) : Pullback f g. Proof. use (@make_Pullback _ _ _ _ f g Eq (EqualizerArrow Eq · (BinProductPr1 C BinProd)) (EqualizerArrow Eq · (BinProductPr2 C BinProd))). apply Pullback_from_Equalizer_BinProduct_eq. apply Pullback_from_Equalizer_BinProduct_isPullback. Defined. Definition Pullbacks_from_Equalizers_BinProducts (BinProds : BinProducts C) (Eqs : Equalizers C) : Pullbacks C. Proof. intros Z X Y f g. use (Pullback_from_Equalizer_BinProduct X Y Z f g). apply BinProds. apply Eqs. Defined. End pb_criteria. Section lemmas_on_pullbacks. (** setup for this section << k d --------> c | | h | H | g v v b --------> a f >> *) Context {C : category} {a b c d : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} {h : C⟦d, b⟧} {k : C⟦d,c⟧} (H : h · f = k · g). (** Pullback is symmetric, i.e., we can rotate a pb square *) Lemma is_symmetric_isPullback : isPullback H -> isPullback (!H). Proof. intro isPb. use make_isPullback. intros e x y Hxy. set (Pb := make_Pullback _ isPb). use tpair. - use tpair. + use (PullbackArrow Pb). * assumption. * assumption. * abstract (apply (!Hxy)). + abstract (split; [apply (PullbackArrow_PullbackPr2 Pb) | apply (PullbackArrow_PullbackPr1 Pb)]). - abstract (intro t; apply subtypePath; [intro; apply isapropdirprod; apply C | destruct t as [t Ht]; cbn; apply PullbackArrowUnique; [apply (pr2 Ht) | apply (pr1 Ht)]]). Defined. (** Pulling back a section *) Definition pb_of_section (isPb : isPullback H) (s : C⟦a,c⟧) (K : s · g = identity _ ) : ∑ s' : C⟦b, d⟧, s' · h = identity _ . Proof. use tpair. - use (PullbackArrow (make_Pullback _ isPb) b (identity _ ) (f · s)). abstract (rewrite id_left, <- assoc, K, id_right; apply idpath). - abstract (cbn; apply (PullbackArrow_PullbackPr1 (make_Pullback H isPb))). Defined. (** Diagonal morphisms are equivalent to sections *) Definition section_from_diagonal (isPb : isPullback H) : (∑ x : C⟦b, c⟧, x · g = f) -> ∑ s' : C⟦b, d⟧, s' · h = identity _ . Proof. intro X. use tpair. - use (PullbackArrow (make_Pullback _ isPb) _ (identity _ ) (pr1 X)). abstract (rewrite id_left ; apply (! (pr2 X))). - abstract (apply (PullbackArrow_PullbackPr1 (make_Pullback H isPb))). Defined. Definition diagonal_from_section (isPb : isPullback H) : (∑ x : C⟦b, c⟧, x · g = f) <- ∑ s' : C⟦b, d⟧, s' · h = identity _ . Proof. intro X. exists (pr1 X · k). abstract (rewrite <- assoc, <- H, assoc, (pr2 X); apply id_left). Defined. Definition weq_section_from_diagonal (isPb : isPullback H) : (∑ x : C⟦b, c⟧, x · g = f) ≃ ∑ s' : C⟦b, d⟧, s' · h = identity _ . Proof. exists (section_from_diagonal isPb). apply (isweq_iso _ (diagonal_from_section isPb )). - abstract (intro x; apply subtypePath; [intro; apply C |]; apply (PullbackArrow_PullbackPr2 (make_Pullback H isPb) )). - abstract (intro y; apply subtypePath; [intro; apply C |]; destruct y as [y t2]; apply pathsinv0, PullbackArrowUnique; [ apply t2 | apply idpath] ). Defined. (** Diagram for next lemma << i' k d' -------> d --------> c | | | h'| |h | g v v v b'--------> b --------> a i f >> *) Lemma isPullback_two_pullback (b' d' : C) (h' : C⟦d', b'⟧) (i : C⟦b', b⟧) (i' : C⟦d', d⟧) (Hinner : h · f = k · g) (Hinnerpb : isPullback Hinner) (Hleft : h' · i = i' · h) (Houterpb : isPullback (glueSquares Hinner Hleft )) : isPullback Hleft. Proof. apply make_isPullback. intros e x y Hxy. use tpair. - use tpair. use (PullbackArrow (make_Pullback _ Houterpb)). + apply x. + apply (y · k). + abstract (rewrite assoc; rewrite Hxy; repeat rewrite <- assoc; rewrite Hinner; apply idpath). + abstract ( split ; [ apply (PullbackArrow_PullbackPr1 (make_Pullback (*(i · f) g d' h' (i' · k)*) _ Houterpb)) | idtac ]; apply (MorphismsIntoPullbackEqual Hinnerpb); [rewrite <- assoc; match goal with |[ |- ?KK · ( _ · _ ) = _ ] => intermediate_path (KK · (h' · i)) end; [ apply maponpaths; apply (!Hleft) | rewrite assoc; assert (T:= PullbackArrow_PullbackPr1 (make_Pullback (*(i · f) g d' h' (i' · k)*) _ Houterpb)); cbn in T; rewrite T; apply Hxy ] | idtac ] ; assert (T:= PullbackArrow_PullbackPr2 (make_Pullback (*(i · f) g d' h' (i' · k)*) _ Houterpb)); cbn in T; rewrite <- assoc, T; apply idpath ). - abstract ( intro t; apply subtypePath; [ intro; apply isapropdirprod; apply C | simpl; apply PullbackArrowUnique; [ apply (pr1 (pr2 t)) | cbn; rewrite assoc; rewrite (pr2 (pr2 t)); apply idpath ]] ). Defined. (** * A square isomorphic to a pullback is a pullback (case 1) *) Section pullback_iso. (** Diagram for next lemma << i' k d' -------> d --------> c | | | h'| |h | g v v v b'--------> b --------> a i f >> *) Lemma isPullback_z_iso_of_morphisms (b' d' : C) (h' : C⟦d', b'⟧) (i : C⟦b', b⟧) (i' : C⟦d', d⟧) (xi : is_z_isomorphism i) (xi' : is_z_isomorphism i') (Hi : h' · i = i' · h) (H' : h' · (i · f) = (i' · k) · g) (* this one is redundant *) : isPullback H -> isPullback H'. Proof. intro isPb. use make_isPullback. intros e x y Hxy. set (Pb:= make_Pullback _ isPb). use tpair. - use tpair. + use ( PullbackArrow Pb _ _ _ _ · _ ). * apply (x · i). * apply y. * abstract (rewrite <- assoc; apply Hxy). * apply (inv_from_z_iso (make_z_iso' i' xi')). + cbn. split. * assert (X:= PullbackArrow_PullbackPr1 Pb e (x · i) y ). cbn in X. { match goal with |[ |- ?AA · _ · _ = _ ] => intermediate_path (AA · h · inv_from_z_iso (make_z_iso' i xi)) end. - repeat rewrite <- assoc. apply maponpaths. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply pathsinv0, Hi. - rewrite X. apply pathsinv0. apply z_iso_inv_on_left. apply idpath. } * assert (X:= PullbackArrow_PullbackPr2 Pb e (x · i) y ). cbn in X. repeat rewrite assoc. { match goal with |[|- ?AA · _ · _ · ?K = _ ] => intermediate_path (AA · K) end. - apply cancel_postcomposition. repeat rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. - apply X. } - cbn. intro t. apply subtypePath. + intro. apply isapropdirprod; apply C. + cbn. destruct t as [t Ht]; cbn in *. apply z_iso_inv_on_left. apply pathsinv0 , PullbackArrowUnique; cbn in *. * rewrite <- assoc. rewrite <- Hi. rewrite assoc. rewrite (pr1 Ht). apply idpath. * rewrite <- assoc. apply (pr2 Ht). Defined. (* with ample room for opacification *) End pullback_iso. End lemmas_on_pullbacks. Definition switchPullback {C:category} {A B D:C} {f : A --> D} {g : B --> D} (pb : Pullback f g) : Pullback g f. Proof. induction pb as [[P [r s]] [e ip]]; simpl in e. use (make_Pullback (!e) (is_symmetric_isPullback _ ip)). Defined. (** In this section we prove that the pullback of a z_iso is a z_iso. *) Section pb_of_ziso. Lemma Pullback_of_z_iso {C:category} {a b c : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} (gis : is_z_isomorphism g) (pb : Pullback f g) : is_z_isomorphism (PullbackPr1 pb). Proof. use make_is_z_isomorphism. + use PullbackArrow. - exact (identity b). - exact (f · (is_z_isomorphism_mor gis)). - now rewrite assoc', (is_inverse_in_precat2 (is_z_isomorphism_is_inverse_in_precat gis)), id_left, id_right. + use make_is_inverse_in_precat. - use pathsinv0. use PullbackEndo_is_identity. * now rewrite (assoc' (PullbackPr1 pb)), PullbackArrow_PullbackPr1, id_right. * now rewrite (assoc' (PullbackPr1 pb)), PullbackArrow_PullbackPr2, assoc, PullbackSqrCommutes, assoc', (is_inverse_in_precat1 (is_z_isomorphism_is_inverse_in_precat gis)), id_right. - use PullbackArrow_PullbackPr1. Defined. (* with ample room for opacification *) (*same with the other map*) Lemma Pullback_of_z_iso' {C:category} {a b c : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} (fis : is_z_isomorphism f) (pb : Pullback f g) : is_z_isomorphism (PullbackPr2 pb). Proof. use (Pullback_of_z_iso _ (switchPullback pb)). exact fis. Defined. End pb_of_ziso. (* reformulation of [isPullback_z_iso_of_morphisms] with data packaged in Pullback*) Definition Pullback_z_iso_of_morphisms {C:category} {a b c : C} {f : b --> a} {g : c --> a} (pb : Pullback f g) {b' pb' : C} (i : C⟦b', b⟧) (i' : C⟦pb', pb⟧) (h : C⟦pb', b'⟧) (xi : is_z_isomorphism i) (xi' : is_z_isomorphism i') (Hi : h · i = i' · (PullbackPr1 pb)) : Pullback (i · f) g. Proof. assert (H' : h · (i · f) = i' · PullbackPr2 pb · g). { rewrite assoc, Hi, !assoc'. use cancel_precomposition. use PullbackSqrCommutes. } use (make_Pullback (p1:=h) (p2:=(i' · (PullbackPr2 pb))) H'). use (isPullback_z_iso_of_morphisms (PullbackSqrCommutes pb)). - exact xi. - exact xi'. - exact Hi. - use isPullback_Pullback. Defined. (** * A fully faithful functor reflects limits *) Section functor_on_square. Context (C D : category) (F : functor C D). Section isPullback_if_functor_on_square_is. Context (Fff : fully_faithful F) {a b c d : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} {h : C⟦d, b⟧} {k : C⟦d,c⟧} (H : h · f = k · g). Definition functor_on_square : #F h · #F f = #F k · #F g. Proof. eapply pathscomp0; [ | apply functor_comp]. eapply pathscomp0; [ | apply maponpaths ; apply H]. apply (! functor_comp _ _ _ ). Qed. Context (X : isPullback functor_on_square). Lemma isPullback_preimage_square : isPullback H. Proof. use make_isPullback. intros e x y Hxy. set (T := maponpaths (#F) Hxy). set (T' := !functor_comp _ _ _ @ T @ functor_comp _ _ _ ). set (TH := X _ _ _ T'). set (FxFy := pr1 (pr1 TH)). set (HFxFy := pr2 (pr1 TH)). simpl in HFxFy. set (xy := fully_faithful_inv_hom Fff _ _ FxFy). use tpair. - exists xy. set (t := pr1 HFxFy). set (p := pr2 HFxFy). split. + use (invmaponpathsweq (make_weq _ (Fff _ _ ))). simpl. rewrite functor_comp. assert (XX:=homotweqinvweq (make_weq _ (Fff e d ))). simpl in XX. unfold xy. simpl. eapply pathscomp0. eapply cancel_postcomposition. assert (XXX := XX FxFy). apply XX. exact t. + use (invmaponpathsweq (make_weq _ (Fff _ _ ))). simpl. rewrite functor_comp. assert (XX:=homotweqinvweq (make_weq _ (Fff e d ))). simpl in XX. unfold xy. simpl. eapply pathscomp0. eapply cancel_postcomposition. assert (XXX := XX FxFy). apply XX. exact p. - simpl. intro t. apply subtypePath. + intro kkkk. apply isapropdirprod; apply C. + simpl. use (invmaponpathsweq (make_weq _ (Fff _ _ ))). simpl. unfold xy. assert (XX:=homotweqinvweq (make_weq _ (Fff e d ))). simpl in XX. apply pathsinv0. eapply pathscomp0. apply XX. apply pathsinv0. apply path_to_ctr. destruct (pr2 t) as [H1 H2]. split. * assert (X1:= maponpaths (#F) H1). eapply pathscomp0. apply (!functor_comp _ _ _ ). apply X1. * assert (X2:= maponpaths (#F) H2). eapply pathscomp0. apply (!functor_comp _ _ _). apply X2. Defined. (* with ample room for opacification *) End isPullback_if_functor_on_square_is. (** * A fully faithful and essentially surjective functor preserves pullbacks *) Section ff_es_functor_preserves_pb. Context (Fff : fully_faithful F) (Fes : essentially_surjective F). Let FF a b := (weq_from_fully_faithful Fff a b). Context {a b c d : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} {h : C⟦d, b⟧} {k : C⟦d,c⟧} (H : h · f = k · g) (X : isPullback H). Lemma isPullback_image_square : isPullback (functor_on_square H). Proof. intros e x y Hxy. apply (squash_to_prop (Fes e)). apply isapropiscontr. intros [e' i]. set (e'c := invmap (FF _ _ ) (i ·y)). set (e'b := invmap (FF _ _ ) (i ·x)). set (Pb := make_Pullback _ X). assert (XX : e'b · f = e'c · g). { apply (invmaponpathsweq (FF _ _ )). cbn. unfold e'b. unfold e'c. repeat rewrite functor_comp. set (T:=homotweqinvweq (FF e' b)). cbn in T. rewrite T; clear T. set (T:=homotweqinvweq (FF e' c)). cbn in T. rewrite T; clear T. repeat rewrite <- assoc. rewrite Hxy. apply idpath. } set (umor := PullbackArrow Pb _ e'b e'c XX). set (umorPr1 := PullbackArrow_PullbackPr1 Pb _ _ _ XX). set (umorPr2 := PullbackArrow_PullbackPr2 Pb _ _ _ XX). cbn in *. use tpair. - exists (inv_from_z_iso i · #F umor ). split. + rewrite <- assoc. apply z_iso_inv_on_right. rewrite <- functor_comp. apply (invmaponpathsweq (invweq (FF _ _ ))). cbn. set (TX:= homotinvweqweq (FF e' b)). cbn in TX. rewrite TX; clear TX. unfold umor; rewrite umorPr1. apply idpath. + rewrite <- assoc. apply z_iso_inv_on_right. rewrite <- functor_comp. apply (invmaponpathsweq (invweq (FF _ _ ))). cbn. set (TX:= homotinvweqweq (FF e' c)). cbn in TX. rewrite TX; clear TX. unfold umor; rewrite umorPr2. apply idpath. - cbn. intro t. apply subtypePath ; [ intro; apply isapropdirprod; apply D | cbn ]. destruct t as [t [Htx Hty]]; cbn. apply (pre_comp_with_z_iso_is_inj i). rewrite assoc. rewrite z_iso_inv_after_z_iso. rewrite id_left. apply (invmaponpathsweq (invweq (FF _ _ ))). cbn. set (TX:= homotinvweqweq (FF e' d)). cbn in TX. rewrite TX; clear TX. apply PullbackArrowUnique. + apply (invmaponpathsweq (FF _ _ )). set (TX:= homotweqinvweq (FF e' d)). cbn in *. rewrite functor_comp, TX; clear TX. rewrite <- assoc. rewrite Htx. unfold e'b. set (TX:= homotweqinvweq (FF e' b)). cbn in *. rewrite TX. apply idpath. + apply (invmaponpathsweq (FF _ _ )). set (TX:= homotweqinvweq (FF e' d)). cbn in *. rewrite functor_comp, TX; clear TX. rewrite <- assoc. rewrite Hty. unfold e'c. set (TX:= homotweqinvweq (FF e' c)). cbn in *. rewrite TX. apply idpath. Qed. (* why opaque? *) End ff_es_functor_preserves_pb. Definition maps_pb_square_to_pb_square {a b c d : C} {f : C ⟦b, a⟧} {g : C ⟦c, a⟧} {h : C⟦d, b⟧} {k : C⟦d,c⟧} (H : h · f = k · g) : UU := isPullback H -> isPullback (functor_on_square H). Definition maps_pb_squares_to_pb_squares := ∏ (a b c d : C) (f : C ⟦b, a⟧) (g : C ⟦c, a⟧) (h : C⟦d, b⟧) (k : C⟦d,c⟧) (H : h · f = k · g), maps_pb_square_to_pb_square H. End functor_on_square. (** * Pullbacks in functor categories *) Section pullbacks_pointwise. (** Diagram for this section: << d J -------> H | | c | | b v v G -------> F a >> *) Context {C D : category}. Let CD := [C, D]. Context {F G H J : CD} {a : CD ⟦G, F⟧} {b : CD ⟦H, F⟧} {c : CD⟦J,G⟧} {d : CD⟦J, H⟧} (Hcomm : c · a = d · b). Arguments make_Pullback {_ _ _ _ _ _ _ _ _ _ } _ . Let Hcommx x := nat_trans_eq_pointwise Hcomm x. Local Definition g (T : ∏ x, isPullback (Hcommx x)) (E : CD) (h : CD ⟦ E, G ⟧) (k : CD ⟦ E, H ⟧) (Hhk : h · a = k · b) : ∏ x, D ⟦ pr1 E x, pr1 J x ⟧. Proof. intro x; apply (PullbackArrow (make_Pullback (T x)) _ (pr1 h x) (pr1 k x)). abstract (apply (nat_trans_eq_pointwise Hhk)). Defined. Local Lemma is_nat_trans_g (T : ∏ x, isPullback (Hcommx x)) E (h : CD ⟦ E, G ⟧) (k : CD ⟦ E, H ⟧) (Hhk : h · a = k · b) : is_nat_trans _ _ (λ x : C, g T E h k Hhk x). Proof. intros x y f; unfold g. apply (MorphismsIntoPullbackEqual (T y)). + rewrite <- !assoc, (PullbackArrow_PullbackPr1 (make_Pullback (T y))). rewrite (nat_trans_ax c), assoc. now rewrite (PullbackArrow_PullbackPr1 (make_Pullback (T x))), (nat_trans_ax h). + rewrite <- !assoc,(PullbackArrow_PullbackPr2 (make_Pullback (T y))). rewrite (nat_trans_ax d), assoc. now rewrite (PullbackArrow_PullbackPr2 (make_Pullback (T x))), (nat_trans_ax k). Qed. Lemma pb_if_pointwise_pb : (∏ x, isPullback (Hcommx x)) -> isPullback Hcomm. Proof. intro T. use make_isPullback; intros E h k Hhk. use unique_exists. - use tpair. + intro x; apply (g T E h k Hhk). + apply is_nat_trans_g. - abstract (split; apply (nat_trans_eq D); intro x; [ apply (PullbackArrow_PullbackPr1 (make_Pullback (T x))) | apply (PullbackArrow_PullbackPr2 (make_Pullback (T x))) ]). - abstract (intro; apply isapropdirprod; apply functor_category_has_homsets). - abstract (intros t [h1 h2]; destruct h as [h Hh]; apply (nat_trans_eq D); intro x; apply PullbackArrowUnique; [ apply (nat_trans_eq_pointwise h1) | apply (nat_trans_eq_pointwise h2) ]). Defined. End pullbacks_pointwise. (** * Construction of binary products from pullbacks *) Section binproduct_from_pullback. Context {C : category} (Pb : Pullbacks C) (T : Terminal C). Definition UnivProductFromPullback (c d a : C) (f : a --> c) (g : a --> d): ∑ fg : a --> Pb T c d (TerminalArrow T c) (TerminalArrow T d), (fg · PullbackPr1 (Pb T c d (TerminalArrow T c) (TerminalArrow T d)) = f) × (fg · PullbackPr2 (Pb T c d (TerminalArrow T c) (TerminalArrow T d)) = g). Proof. unfold Pullbacks in Pb. exists (PullbackArrow (Pb _ _ _ (TerminalArrow _ c)(TerminalArrow _ d)) _ f g (TerminalArrowEq _ _)). split. apply PullbackArrow_PullbackPr1. apply PullbackArrow_PullbackPr2. Defined. Lemma isBinProduct_Pullback (c d : C): isBinProduct C c d (PullbackObject (Pb _ _ _ (TerminalArrow T c) (TerminalArrow T d))) (PullbackPr1 _ ) (PullbackPr2 _ ). Proof. intros a f g. exists (UnivProductFromPullback c d a f g). intro t. abstract (apply proofirrelevancecontr, isPullback_Pullback, TerminalArrowEq). Defined. Definition BinProduct_Pullback (c d : C) : BinProduct _ c d. Proof. exists (tpair _ (PullbackObject (Pb _ _ _ (TerminalArrow T c) (TerminalArrow T d))) (make_dirprod (PullbackPr1 _) (PullbackPr2 _))). exact (isBinProduct_Pullback c d). Defined. Definition BinProductsFromPullbacks : BinProducts C := BinProduct_Pullback. End binproduct_from_pullback. (** * Pullbacks in functor_precategory We construct pullbacks in the functor category [D, C] from pullbacks of C. *) Section pullbacks_functor_category. Context (D C : category) (hpb : @Pullbacks C). Local Lemma FunctorcategoryPullbacks_eq (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) (a b : D) (f : D ⟦a, b⟧) : PullbackPr1 (hpb _ _ _ (α a) (β a)) · # G f · α b = PullbackPr2 (hpb _ _ _ (α a) (β a)) · # H f · β b. Proof. set (pba := hpb _ _ _ (α a) (β a)). repeat rewrite <- assoc. rewrite (nat_trans_ax α a b f). rewrite (nat_trans_ax β a b f). repeat rewrite assoc. apply cancel_postcomposition. exact (PullbackSqrCommutes pba). Qed. Local Lemma FunctorcategoryPullbacks_isfunctor (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : is_functor (make_functor_data (λ d : D, hpb (F d) (G d) (H d) (α d) (β d)) (λ (a b : D) (f : D ⟦ a, b ⟧), PullbackArrow (hpb (F b) (G b) (H b) (α b) (β b)) (hpb (F a) (G a) (H a) (α a) (β a)) (PullbackPr1 (hpb (F a) (G a) (H a) (α a) (β a)) · # G f) (PullbackPr2 (hpb (F a) (G a) (H a) (α a) (β a)) · # H f) (FunctorcategoryPullbacks_eq F G H α β a b f))). Proof. split. - intros x. apply pathsinv0. cbn. eapply PullbackArrowUnique. + rewrite functor_id. rewrite id_left. rewrite id_right. apply idpath. + rewrite functor_id. rewrite id_left. rewrite id_right. apply idpath. - intros x y z f g. set (px := hpb (F x) (G x) (H x) (α x) (β x)). set (py := hpb (F y) (G y) (H y) (α y) (β y)). set (pz := hpb (F z) (G z) (H z) (α z) (β z)). set (pz1 := PullbackArrow_PullbackPr1 pz py (PullbackPr1 py · # G g) (PullbackPr2 py · # H g) (FunctorcategoryPullbacks_eq F G H α β y z g)). set (pz2 := PullbackArrow_PullbackPr2 pz py (PullbackPr1 py · # G g) (PullbackPr2 py · # H g) (FunctorcategoryPullbacks_eq F G H α β y z g)). set (py1 := PullbackArrow_PullbackPr1 py px (PullbackPr1 px · # G f) (PullbackPr2 px · # H f) (FunctorcategoryPullbacks_eq F G H α β x y f)). set (py2 := PullbackArrow_PullbackPr2 py px (PullbackPr1 px · # G f) (PullbackPr2 px · # H f) (FunctorcategoryPullbacks_eq F G H α β x y f)). apply pathsinv0. cbn. fold px. fold py. fold pz. eapply PullbackArrowUnique. + rewrite functor_comp. rewrite assoc. rewrite <- assoc. rewrite pz1. rewrite assoc. apply cancel_postcomposition. apply py1. + rewrite functor_comp. rewrite assoc. rewrite <- assoc. rewrite pz2. rewrite assoc. apply cancel_postcomposition. apply py2. Qed. Local Definition FunctorcategoryPullbacks_functor (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : functor D C. Proof. use make_functor. - use make_functor_data. + intros d. exact (PullbackObject (hpb _ _ _ (α d) (β d))). + intros a b f. use (PullbackArrow (hpb _ _ _ (α b) (β b)) _ (PullbackPr1 (hpb _ _ _ (α a) (β a)) · (# G f)) (PullbackPr2 (hpb _ _ _ (α a) (β a)) · (# H f)) (FunctorcategoryPullbacks_eq F G H α β a b f)). - exact (FunctorcategoryPullbacks_isfunctor F G H α β). Defined. Local Lemma FunctorcategoryPullbacks_is_nat_trans1 (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : is_nat_trans (FunctorcategoryPullbacks_functor F G H α β) G (λ x : D, PullbackPr1 (hpb (F x) (G x) (H x) (α x) (β x))). Proof. intros x x' f. cbn. set (px := hpb (F x) (G x) (H x) (α x) (β x)). set (px' := hpb (F x') (G x') (H x') (α x') (β x')). apply (PullbackArrow_PullbackPr1 px' px (PullbackPr1 px · # G f) (PullbackPr2 px · # H f) (FunctorcategoryPullbacks_eq F G H α β x x' f)). Qed. Local Definition FunctorcategoryPullbacks_nat_trans1 (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : nat_trans (FunctorcategoryPullbacks_functor F G H α β) G. Proof. use make_nat_trans. - intros x. exact (PullbackPr1 (hpb (F x) (G x) (H x) (α x) (β x))). - exact (FunctorcategoryPullbacks_is_nat_trans1 F G H α β). Defined. Local Lemma FunctorcategoryPullbacks_is_nat_trans2 (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : is_nat_trans (FunctorcategoryPullbacks_functor F G H α β) H (λ x : D, PullbackPr2 (hpb (F x) (G x) (H x) (α x) (β x))). Proof. intros x x' f. cbn. set (px := hpb (F x) (G x) (H x) (α x) (β x)). set (px' := hpb (F x') (G x') (H x') (α x') (β x')). apply (PullbackArrow_PullbackPr2 px' px (PullbackPr1 px · # G f) (PullbackPr2 px · # H f) (FunctorcategoryPullbacks_eq F G H α β x x' f)). Qed. Local Definition FunctorcategoryPullbacks_nat_trans2 (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : nat_trans (FunctorcategoryPullbacks_functor F G H α β) H. Proof. use make_nat_trans. - intros x. exact (PullbackPr2 (hpb (F x) (G x) (H x) (α x) (β x))). - exact (FunctorcategoryPullbacks_is_nat_trans2 F G H α β). Defined. Local Lemma FunctorcategoryPullbacks_comm (F G H : functor D C) (α : nat_trans G F) (β : nat_trans H F) : nat_trans_comp _ _ _ (FunctorcategoryPullbacks_nat_trans1 F G H α β) α = nat_trans_comp _ _ _ (FunctorcategoryPullbacks_nat_trans2 F G H α β) β. Proof. use nat_trans_eq_alt. intros x. apply (PullbackSqrCommutes (hpb (F x) (G x) (H x) (α x) (β x))). Qed. Definition FunctorcategoryPullbacks : @Pullbacks (functor_category D C). Proof. intros F G H α β. use make_Pullback. (* Pullback object *) - exact (FunctorcategoryPullbacks_functor F G H α β). (* Pr1 *) - exact (FunctorcategoryPullbacks_nat_trans1 F G H α β). (* Pr2 *) - exact (FunctorcategoryPullbacks_nat_trans2 F G H α β). (* Commutativity of the square *) - exact (FunctorcategoryPullbacks_comm F G H α β). (* isPullback *) - apply pb_if_pointwise_pb. intros x. apply isPullback_Pullback. Defined. End pullbacks_functor_category. Section pullback_up_to_iso. Context {C : category}. Local Lemma isPullback_up_to_z_iso_eq {a' a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) (i : z_iso a a') : p1 · (f · i) = p2 · (g · i). Proof. rewrite assoc. rewrite assoc. rewrite H. apply idpath. Qed. Lemma isPullback_up_to_z_iso {a' a b c d : C} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) (i : z_iso a a') (iPb : isPullback (*(f · i) (g · i) p1 p2*) (isPullback_up_to_z_iso_eq f g p1 p2 H i)) : isPullback (*f g p1 p2*) H. Proof. set (Pb := make_Pullback _ iPb). use make_isPullback. intros e h k Hk. use unique_exists. - use (PullbackArrow Pb). + exact h. + exact k. + use isPullback_up_to_z_iso_eq. exact Hk. - split. + exact (PullbackArrow_PullbackPr1 Pb e h k (isPullback_up_to_z_iso_eq f g h k Hk i)). + exact (PullbackArrow_PullbackPr2 Pb e h k (isPullback_up_to_z_iso_eq f g h k Hk i)). - intros y. apply isapropdirprod; apply C. - intros y X. cbn in X. eapply PullbackArrowUnique. + exact (dirprod_pr1 X). + exact (dirprod_pr2 X). Qed. (* why opaque? *) End pullback_up_to_iso. Section pullback_paths. Context {C : category}. Lemma isPullback_mor_paths {a b c d : C} {f1 f2 : b --> a} {g1 g2 : c --> a} {p11 p21 : d --> b} {p12 p22 : d --> c} (e1 : f1 = f2) (e2 : g1 = g2) (e3 : p11 = p21) (e4 : p12 = p22) (H1 : p11 · f1 = p12 · g1) (H2 : p21 · f2 = p22 · g2) (iPb : isPullback (*f1 g1 p11 p12*) H1) : isPullback (*f2 g2 p21 p22*) H2. Proof. induction e1, e2, e3, e4. assert (e5 : H1 = H2) by apply C. induction e5. exact iPb. Qed. Lemma isPullback_mor_paths' {a b c d : C} {f1 f2 : b --> a} {g1 g2 : c --> a} {p11 p21 : d --> b} {p12 p22 : d --> c} (e1 : f1 = f2) (e2 : g1 = g2) (e3 : p11 = p21) (e4 : p12 = p22) (H1 : p11 · f1 = p12 · g1) (iPb : isPullback (*f1 g1 p11 p12*) H1) : ∑ (H2 : p21 · f2 = p22 · g2), isPullback H2. Proof. induction e1, e2, e3, e4. use tpair. + exact H1. + exact iPb. Defined. Definition Pullback_mor_paths {a b c : C} {f1 f2 : b --> a} {g1 g2 : c --> a} (e1 : f1 = f2) (e2 : g1 = g2) (pb : Pullback f1 g1) : Pullback f2 g2. Proof. use make_Pullback. + exact pb. + exact (PullbackPr1 pb). + exact (PullbackPr2 pb). + abstract (rewrite <-e1, <-e2; use PullbackSqrCommutes). + use (isPullback_mor_paths e1 e2 (idpath _) (idpath _)). - apply PullbackSqrCommutes. - apply isPullback_Pullback. Defined. End pullback_paths. Lemma induced_precategory_reflects_pullbacks {M : category} {X:Type} (j : X -> ob M) {a b c d : induced_category M j} (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c) (H : p1 · f = p2 · g) : @isPullback _ _ _ _ _ (# (induced_precategory_incl j) f) (# (induced_precategory_incl j) g) (# (induced_precategory_incl j) p1) (# (induced_precategory_incl j) p2) H -> isPullback (*f g p1 p2*) H. Proof. exact (λ pb T, pb (j T)). Qed. (* why opaque? *) (** The type of pullbacks on a given diagram is a proposition *) Definition eq_Pullback {C : category} {x y z : C} {f : x --> z} {g : y --> z} (p₁ p₂ : Pullback f g) (e₁ : PullbackObject p₁ = PullbackObject p₂) (e₂ : idtoiso e₁ · PullbackPr1 p₂ = PullbackPr1 p₁) (e₃ : idtoiso e₁ · PullbackPr2 p₂ = PullbackPr2 p₁) : p₁ = p₂. Proof. use subtypePath. { intro. use isaproptotal2. { intro. apply isaprop_isPullback. } intros. apply homset_property. } induction p₁ as [ [ p₁ [ h₁ k₁ ]] ? ]. induction p₂ as [ [ p₂ [ h₂ k₂ ]] ? ]. cbn in *. induction e₁. cbn in *. rewrite !id_left in *. apply maponpaths. apply pathsdirprod. - exact (!e₂). - exact (!e₃). Qed. Definition isaprop_Pullback {C : category} (HC : is_univalent C) {x y z : C} (f : x --> z) (g : y --> z) : isaprop (Pullback f g). Proof. use invproofirrelevance. intros p₁ p₂. use eq_Pullback. - refine (isotoid _ HC _). apply z_iso_from_Pullback_to_Pullback. - rewrite idtoiso_isotoid ; cbn. apply PullbackArrow_PullbackPr1. - rewrite idtoiso_isotoid ; cbn. apply PullbackArrow_PullbackPr2. Qed. (** Isos between pullbacks *) Section IsoIsPullback. Context {C : category} {x y z : C} {f : x --> z} {g : y --> z} {pb pb' : C} {π₁ : pb --> x} {π₂ : pb --> y} (sqr : π₁ · f = π₂ · g) {π₁' : pb' --> x} {π₂' : pb' --> y} (sqr' : π₁' · f = π₂' · g) (H : isPullback sqr) (i : z_iso pb pb') (iπ₁' : i · π₁' = π₁) (iπ₂' : i · π₂' = π₂). Let P : Pullback f g := make_Pullback _ H. Section UMP. Context {w : C} {h₁ : w --> x} {h₂ : w --> y} (q : h₁ · f = h₂ · g). Definition isPullback_z_iso_unique : isaprop (∑ (hk : w --> pb'), hk · π₁' = h₁ × hk · π₂' = h₂). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply isapropdirprod ; apply homset_property. } refine (!(id_right _) @ _ @ id_right _). rewrite <- (z_iso_after_z_iso_inv i). rewrite !assoc. apply maponpaths_2. use (MorphismsIntoPullbackEqual H). - pose (maponpaths (λ z, inv_from_z_iso i · z) iπ₁') as p. cbn in p. rewrite !assoc in p. rewrite !z_iso_after_z_iso_inv in p. rewrite id_left in p. rewrite !assoc'. rewrite <- p. exact (pr12 φ₁ @ !(pr12 φ₂)). - pose (maponpaths (λ z, inv_from_z_iso i · z) iπ₂') as p. cbn in p. rewrite !assoc in p. rewrite !z_iso_after_z_iso_inv in p. rewrite id_left in p. rewrite !assoc'. rewrite <- p. exact (pr22 φ₁ @ !(pr22 φ₂)). Qed. Definition isPullback_z_iso_mor : w --> pb' := PullbackArrow P _ h₁ h₂ q · i. Definition isPullback_z_iso_pr1 : isPullback_z_iso_mor · π₁' = h₁. Proof. unfold isPullback_z_iso_mor. rewrite !assoc'. etrans. { apply maponpaths. exact iπ₁'. } apply PullbackArrow_PullbackPr1. Qed. Definition isPullback_z_iso_pr2 : isPullback_z_iso_mor · π₂' = h₂. Proof. unfold isPullback_z_iso_mor. rewrite !assoc'. etrans. { apply maponpaths. exact iπ₂'. } apply PullbackArrow_PullbackPr2. Qed. End UMP. Definition isPullback_z_iso : isPullback sqr'. Proof. intros w h₁ h₂ q. use iscontraprop1. - apply isPullback_z_iso_unique. - refine (isPullback_z_iso_mor q ,, _ ,, _). + apply isPullback_z_iso_pr1. + apply isPullback_z_iso_pr2. Defined. End IsoIsPullback. (** A general statement to get isos between pullbacks *) Section IsoOfPullbacks. Context {C : category} {pb pb' x x' y y' z z' : C} {f : x --> z} {f' : x' --> z'} {g : y --> z} {g' : y' --> z'} {π₁ : pb --> x} {π₂ : pb --> y} {π₁' : pb' --> x'} {π₂' : pb' --> y'} (sqr : π₁ · f = π₂ · g) (sqr' : π₁' · f' = π₂' · g') (H : isPullback sqr) (H' : isPullback sqr') (ix : z_iso x x') (iy : z_iso y y') (iz : z_iso z z') (pf : ix · f' = f · iz) (pg : iy · g' = g · iz). Let P : Pullback f g := make_Pullback _ H. Let P' : Pullback f' g' := make_Pullback _ H'. Lemma iso_between_pullbacks_help_path : inv_from_z_iso ix · f = f' · inv_from_z_iso iz. Proof. use z_iso_inv_on_left. rewrite !assoc'. refine (!_). use z_iso_inv_on_right. exact (!pf). Qed. Lemma iso_between_pullbacks_other_help_path : inv_from_z_iso iy · g = g' · inv_from_z_iso iz. Proof. use z_iso_inv_on_left. rewrite !assoc'. refine (!_). use z_iso_inv_on_right. exact (!pg). Qed. Definition iso_between_pullbacks_map : pb --> pb'. Proof. use (PullbackArrow P' _ (π₁ · ix) (π₂ · iy)). abstract (rewrite !assoc' ; rewrite pf, pg ; rewrite !assoc ; apply maponpaths_2 ; exact sqr). Defined. Definition iso_between_pullbacks_inv : pb' --> pb. Proof. use (PullbackArrow P _ (π₁' · inv_from_z_iso ix) (π₂' · inv_from_z_iso iy)). abstract (rewrite !assoc' ; rewrite iso_between_pullbacks_help_path, iso_between_pullbacks_other_help_path ; rewrite !assoc ; apply maponpaths_2 ; exact sqr'). Defined. Lemma iso_between_pullbacks_are_inv : is_inverse_in_precat iso_between_pullbacks_map iso_between_pullbacks_inv. Proof. split ; unfold iso_between_pullbacks_map, iso_between_pullbacks_inv. - use (MorphismsIntoPullbackEqual H). + rewrite !assoc'. rewrite (PullbackArrow_PullbackPr1 P). rewrite !assoc. rewrite (PullbackArrow_PullbackPr1 P'). rewrite !assoc'. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. + rewrite !assoc'. rewrite (PullbackArrow_PullbackPr2 P). rewrite !assoc. rewrite (PullbackArrow_PullbackPr2 P'). rewrite !assoc'. rewrite z_iso_inv_after_z_iso. rewrite id_left, id_right. apply idpath. - use (MorphismsIntoPullbackEqual H'). + rewrite !assoc'. rewrite (PullbackArrow_PullbackPr1 P'). rewrite !assoc. rewrite (PullbackArrow_PullbackPr1 P). rewrite !assoc'. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. + rewrite !assoc'. rewrite (PullbackArrow_PullbackPr2 P'). rewrite !assoc. rewrite (PullbackArrow_PullbackPr2 P). rewrite !assoc'. rewrite z_iso_after_z_iso_inv. rewrite id_left, id_right. apply idpath. Qed. Definition iso_between_pullbacks : z_iso pb pb'. Proof. use make_z_iso. - exact iso_between_pullbacks_map. - exact iso_between_pullbacks_inv. - exact iso_between_pullbacks_are_inv. Defined. End IsoOfPullbacks. UniMath-20231010/UniMath/CategoryTheory/limits/pullbacks_slice_products_equiv.v000066400000000000000000000172611451125700300276160ustar00rootroot00000000000000(** ********************************************************** Matthew Weaver, 2017 ************************************************************) (** ********************************************************** Contents : Equivalence of binary products in C/Z to pullbacks of pairs of arrows to Z in C ************************************************************) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.pullbacks. Local Open Scope cat. (** * Proof that the types of binary products in C/Z and pullbacks of pairs of arrows to Z in C are equivalent *) Section pullbacks_slice_products_equiv. Definition some_pullback (C : category) (Z : C) : UU := ∑ A B (f : A --> Z) (g : B --> Z) , Pullback f g. Definition some_binprod (C : category) : UU := ∑ A B , BinProduct C A B. Context (C : category). Local Notation "C / X" := (slice_cat C X). Lemma isPullback_to_isBinProduct {Z : C} {AZ BZ PZ : C / Z} {l : PZ --> AZ} {r : PZ --> BZ} : @isPullback _ _ _ _ _ (pr2 AZ) (pr2 BZ) (pr1 l) (pr1 r) (! (pr2 l) @ (pr2 r)) → isBinProduct (C / Z) AZ BZ PZ l r. Proof. induction AZ as [A f]. induction BZ as [B g]. induction PZ as [P h]. induction l as [l leq]. induction r as [r req]. intros isPull [Y i] [j jeq] [k keq]; simpl in *. unfold isPullback in isPull. specialize isPull with Y j k. use unique_exists. + use tpair. ++ apply isPull. abstract (simpl; now rewrite <- jeq , keq). ++ abstract (simpl; now rewrite leq, assoc, (pr1 (pr2 (pr1 (isPull _)))), jeq). + abstract (split; apply (eq_mor_slicecat C); simpl; [apply (pr1 (pr2 (pr1 (isPull _)))) | apply (pr2 (pr2 (pr1 (isPull _))))]). + abstract (now intros q; apply isapropdirprod; apply (has_homsets_slice_precat C)). + abstract (intros q [H1 H2]; apply (eq_mor_slicecat C); use (maponpaths pr1 ((pr2 (isPull _)) ((pr1 q) ,, (_ ,, _)))); [apply (maponpaths pr1 H1) | apply (maponpaths pr1 H2)]). Defined. Lemma slice_isBinProduct_to_isPullback {A B Z P : C} {f : A --> Z} {g : B --> Z} {l : P --> A} {r : P --> B} {e : l · f = r · g} : isBinProduct (C / Z) (A ,, f) (B ,, g) (P ,, l · f) (l ,, idpath _) (r ,, e) → isPullback (*f g l r*) e. Proof. intros PisProd Y j k Yeq. use unique_exists. + exact (pr1 (pr1 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))). + abstract (exact (maponpaths pr1 (pr1 (pr2 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))) ,, maponpaths pr1 (pr2 (pr2 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))))). + abstract (intros x; apply isofhleveldirprod; apply C). + intros t teqs. use (maponpaths pr1 (maponpaths pr1 (pr2 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq)) ((t ,, (maponpaths (λ x, x · f) (!(pr1 teqs)) @ !(assoc _ _ _) @ maponpaths (λ x, t · x) (idpath _))) ,, _)))). abstract (split; apply eq_mor_slicecat; [exact (pr1 teqs) | exact (pr2 teqs)]). Defined. (** ** equivalence of function taking proof of isPullback to proof of isBinProduct *) Lemma isweq_isPullback_to_isBinProduct {Z : C} {AZ BZ PZ : C / Z} {l : PZ --> AZ} {r : PZ --> BZ} : isweq (@isPullback_to_isBinProduct Z AZ BZ PZ l r). Proof. apply isweqimplimpl. + induction AZ as [A f]. induction BZ as [B g]. induction PZ as [P h]. induction l as [l leq]. induction r as [r req]. simpl in *. induction (! leq). assert (H : leq = idpath (l · f)) by apply C. intros PisProd. apply slice_isBinProduct_to_isPullback; simpl. rewrite <- H. exact PisProd. + apply isaprop_isPullback. + apply isaprop_isBinProduct. Qed. (** ** equivalence of function taking proof of isBinProduct to proof of isPullback *) Lemma isweq_slice_isBinProduct_to_isPullback {A B Z P : C} {f : A --> Z} {g : B --> Z} {l : P --> A} {r : P --> B} {e : l · f = r · g} : isweq (@slice_isBinProduct_to_isPullback A B Z P f g l r e). Proof. apply isweqimplimpl. + intros isPull. now apply isPullback_to_isBinProduct. + now apply isaprop_isBinProduct. + now apply isaprop_isPullback. Qed. Context (Z : C). (** ** pullback_to_slice_binprod is invertible *) Lemma pullback_to_slice_binprod_inv {A B : C} {f : A --> Z} {g : B --> Z} (P : Pullback f g) : slice_binprod_to_pullback C (pullback_to_slice_binprod C P) = P. Proof. induction P as [[P [l r]] [Peq PisPull]]. apply (invmaponpathsincl pr1). { apply isinclpr1. intro. apply isofhleveltotal2. + apply C. + intro. apply isaprop_isPullback. } reflexivity. Qed. (** ** slice_binprod_to_pullback is invertible *) Lemma slice_binprod_to_pullback_inv {AZ BZ : C / Z} (P : BinProduct (C / Z) AZ BZ) : pullback_to_slice_binprod C (slice_binprod_to_pullback C P) = P. Proof. induction AZ as [A f]. induction BZ as [B g]. induction P as [[[P h] [[l leq] [r req]]] PisProd]. apply (invmaponpathsincl pr1). { apply isinclpr1. intro. apply isaprop_isBinProduct. } simpl in *. use total2_paths2_f. + apply (total2_paths2_f (idpath _)). rewrite idpath_transportf. exact (!leq). + induction (!leq). simpl. rewrite idpath_transportf. use total2_paths2_f. - now apply (eq_mor_slicecat C). - rewrite transportf_const. now apply (eq_mor_slicecat C). Qed. (** ** function taking the type of all binary products in C / Z to the type of all pullbacks of functions to Z in C *) Definition binprod_to_pullback : some_binprod (C / Z) → some_pullback C Z. Proof. intro P. induction P as [AZ BZ]. induction BZ as [BZ P]. exact (pr1 AZ ,, pr1 BZ ,, pr2 AZ ,, pr2 BZ ,, slice_binprod_to_pullback C P). Defined. (** ** function taking the type of all pullbacks of functions to Z in C to the type of all binary products in C / Z *) Definition pullback_to_binprod : some_pullback C Z → some_binprod (C / Z). Proof. intros [A [B [f [g P]]]]. use ((A ,, f) ,, (B ,, g) ,, pullback_to_slice_binprod C P). Defined. (** ** binprod_to_pullback is invertible *) Lemma binprod_to_pullback_inv (P : some_binprod (C / Z)) : pullback_to_binprod (binprod_to_pullback P) = P. Proof. induction P as [[A f] [[B g] P]]. unfold pullback_to_binprod , binprod_to_pullback. simpl. repeat (apply (total2_paths2_f (idpath _)); rewrite idpath_transportf). exact (slice_binprod_to_pullback_inv P). Qed. (** ** pullback_to_binprod is invertible *) Lemma pullback_to_binprod_inv (P : some_pullback C Z) : binprod_to_pullback (pullback_to_binprod P) = P. Proof. induction P as [A [B [f [g P]]]]. unfold binprod_to_pullback , pullback_to_binprod. do 4 (apply (total2_paths2_f (idpath _)); rewrite idpath_transportf). exact (pullback_to_slice_binprod_inv P). Qed. Definition isweq_binprod_to_pullback : isweq binprod_to_pullback := isweq_iso _ _ binprod_to_pullback_inv pullback_to_binprod_inv. (** ** the equivalence of the types of binary products in C/Z and pullbacks of pairs of arrows to Z in C *) Definition weq_binprod_to_pullback : weq (some_binprod (C / Z)) (some_pullback C Z) := binprod_to_pullback ,, isweq_binprod_to_pullback. End pullbacks_slice_products_equiv. UniMath-20231010/UniMath/CategoryTheory/limits/pushouts.v000066400000000000000000000443051451125700300232140ustar00rootroot00000000000000(** Direct implementation of pushouts Definition of Epi in terms of a pushout diagram *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Section def_po. Context {C : category}. Definition isPushout {a b c d : C} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (H : f · in1 = g · in2) : UU := ∏ e (h : b --> e) (k : c --> e) (H : f · h = g · k), ∃! hk : d --> e, (in1 · hk = h) × (in2 · hk = k). Lemma isaprop_isPushout {a b c d : C} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (H : f · in1 = g · in2) : isaprop (isPushout f g in1 in2 H). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Lemma PushoutArrowUnique {a b c d : C} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (H : f · in1 = g · in2) (P : isPushout f g in1 in2 H) e (h : b --> e) (k : c --> e) (Hcomm : f · h = g · k) (w : d --> e) (H1 : in1 · w = h) (H2 : in2 · w = k) : w = (pr1 (pr1 (P e h k Hcomm))). Proof. set (T := tpair (fun hk : d --> e => dirprod (in1 · hk = h)(in2 · hk = k)) w (make_dirprod H1 H2)). set (T' := pr2 (P e h k Hcomm) T). exact (base_paths _ _ T'). Qed. Definition Pushout {a b c : C} (f : a --> b) (g : a --> c) := ∑ pfg : (∑ p : C, (b --> p) × (c --> p)), ∑ H : f · pr1 (pr2 pfg) = g · pr2 (pr2 pfg), isPushout f g (pr1 (pr2 pfg)) (pr2 (pr2 pfg)) H. Definition Pushouts : UU := ∏ (a b c : C) (f : a --> b) (g : a --> c), Pushout f g. Definition hasPushouts : UU := ∏ (a b c : C) (f : a --> b) (g : a --> c), ishinh (Pushout f g). Definition PushoutObject {a b c : C} {f : a --> b} {g : a --> c}: Pushout f g -> C := λ H, pr1 (pr1 H). Coercion PushoutObject : Pushout >-> ob. Definition PushoutIn1 {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) : b --> Pb := pr1 (pr2 (pr1 Pb)). Definition PushoutIn2 {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) : c --> Pb := pr2 (pr2 (pr1 Pb)). Definition PushoutSqrCommutes {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) : f · PushoutIn1 Pb = g · PushoutIn2 Pb. Proof. exact (pr1 (pr2 Pb)). Qed. Definition isPushout_Pushout {a b c : C} {f : a --> b} {g : a --> c} (P : Pushout f g) : isPushout f g (PushoutIn1 P) (PushoutIn2 P) (PushoutSqrCommutes P). Proof. exact (pr2 (pr2 P)). Qed. Definition PushoutArrow {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) e (h : b --> e) (k : c --> e) (H : f · h = g · k) : Pb --> e := pr1 (pr1 (isPushout_Pushout Pb e h k H)). Lemma PushoutArrow_PushoutIn1 {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) e (h : b --> e) (k : c --> e) (H : f · h = g · k) : PushoutIn1 Pb · PushoutArrow Pb e h k H = h. Proof. exact (pr1 (pr2 (pr1 (isPushout_Pushout Pb e h k H)))). Qed. Lemma PushoutArrow_PushoutIn2 {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) e (h : b --> e) (k : c --> e) (H : f · h = g · k) : PushoutIn2 Pb · PushoutArrow Pb e h k H = k. Proof. exact (pr2 (pr2 (pr1 (isPushout_Pushout Pb e h k H)))). Qed. Definition make_Pushout {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (d : C) (in1 : C⟦b,d⟧) (in2 : C ⟦c,d⟧) (H : f · in1 = g · in2) (ispb : isPushout f g in1 in2 H) : Pushout f g. Proof. use tpair. - use tpair. + apply d. + exists in1. exact in2. - exists H. apply ispb. Defined. Definition make_isPushout {a b c d : C} (f : C ⟦a, b⟧) (g : C ⟦a, c⟧) (in1 : C⟦b,d⟧) (in2 : C⟦c,d⟧) (H : f · in1 = g · in2) : (∏ e (h : C ⟦b, e⟧) (k : C⟦c,e⟧)(Hk : f · h = g · k), ∃! hk : C⟦d,e⟧,(in1 · hk = h) × (in2 · hk = k)) → isPushout f g in1 in2 H. Proof. intros H' x cx k sqr. apply H'. assumption. Defined. Lemma MorphismsOutofPushoutEqual {a b c d : C} {f : a --> b} {g : a --> c} {in1 : b --> d} {in2 : c --> d} {H : f · in1 = g · in2} (P : isPushout f g in1 in2 H) {e} (w w': d --> e) (H1 : in1 · w = in1 · w') (H2 : in2 · w = in2 · w') : w = w'. Proof. assert (Hw : f · in1 · w = g · in2 · w). { rewrite H. apply idpath. } assert (Hw' : f · in1 · w' = g · in2 · w'). { rewrite H. apply idpath. } set (Pb := make_Pushout _ _ _ _ _ _ P). rewrite <- assoc in Hw. rewrite <- assoc in Hw. set (Xw := PushoutArrow Pb e (in1 · w) (in2 · w) Hw). intermediate_path Xw; [ apply PushoutArrowUnique; apply idpath |]. apply pathsinv0. apply PushoutArrowUnique. apply pathsinv0. apply H1. apply pathsinv0. apply H2. Qed. Definition identity_is_Pushout_input {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) : ∑ hk : Pb --> Pb, (PushoutIn1 Pb · hk = PushoutIn1 Pb) × (PushoutIn2 Pb · hk = PushoutIn2 Pb). Proof. exists (identity Pb). apply make_dirprod; apply id_right. Defined. Lemma PushoutEndo_is_identity {a b c : C} {f : a --> b} {g : a --> c} (Pb : Pushout f g) (k : Pb --> Pb) (kH1 : PushoutIn1 Pb · k = PushoutIn1 Pb) (kH2 : PushoutIn2 Pb · k = PushoutIn2 Pb) : identity Pb = k. Proof. set (H1 := tpair ((fun hk : Pb --> Pb => dirprod (_ · hk = _)(_ · hk = _))) k (make_dirprod kH1 kH2)). assert (H2 : identity_is_Pushout_input Pb = H1). - apply proofirrelevancecontr. apply (isPushout_Pushout Pb). apply PushoutSqrCommutes. - apply (base_paths _ _ H2). Qed. Definition from_Pushout_to_Pushout {a b c : C} {f : a --> b} {g : a --> c} (Pb Pb': Pushout f g) : Pb --> Pb'. Proof. apply (PushoutArrow Pb Pb' (PushoutIn1 _ ) (PushoutIn2 _)). exact (PushoutSqrCommutes _ ). Defined. Lemma are_inverses_from_Pushout_to_Pushout {a b c : C} {f : a --> b} {g : a --> c} (Pb Pb': Pushout f g) : is_inverse_in_precat (from_Pushout_to_Pushout Pb' Pb) (from_Pushout_to_Pushout Pb Pb'). Proof. split. (** First identity *) apply pathsinv0. apply PushoutEndo_is_identity. unfold from_Pushout_to_Pushout. unfold from_Pushout_to_Pushout. rewrite assoc. rewrite PushoutArrow_PushoutIn1. rewrite PushoutArrow_PushoutIn1. apply idpath. unfold from_Pushout_to_Pushout. unfold from_Pushout_to_Pushout. rewrite assoc. rewrite PushoutArrow_PushoutIn2. rewrite PushoutArrow_PushoutIn2. apply idpath. (** Second identity *) apply pathsinv0. apply PushoutEndo_is_identity. unfold from_Pushout_to_Pushout. unfold from_Pushout_to_Pushout. rewrite assoc. rewrite PushoutArrow_PushoutIn1. rewrite PushoutArrow_PushoutIn1. apply idpath. unfold from_Pushout_to_Pushout. unfold from_Pushout_to_Pushout. rewrite assoc. rewrite PushoutArrow_PushoutIn2. rewrite PushoutArrow_PushoutIn2. apply idpath. Qed. Lemma isziso_from_Pushout_to_Pushout {a b c : C} {f : a --> b} {g : a --> c} (Pb Pb': Pushout f g) : is_z_isomorphism (from_Pushout_to_Pushout Pb Pb'). Proof. exists (from_Pushout_to_Pushout Pb' Pb). apply are_inverses_from_Pushout_to_Pushout. Defined. Definition z_iso_from_Pushout_to_Pushout {a b c : C} {f : a --> b} {g : a --> c} (Pb Pb': Pushout f g) : z_iso Pb Pb' := tpair _ _ (isziso_from_Pushout_to_Pushout Pb Pb'). Lemma inv_from_z_iso_z_iso_from_Pushout (a b c : C) (f : a --> b) (g : a --> c) (Pb : Pushout f g) (Pb' : Pushout f g): inv_from_z_iso (z_iso_from_Pushout_to_Pushout Pb Pb') = from_Pushout_to_Pushout Pb' Pb. Proof. apply pathsinv0. apply inv_z_iso_unique'. set (T:= are_inverses_from_Pushout_to_Pushout Pb' Pb). apply (pr1 T). Qed. End def_po. (** Make the C not implicit for Pushouts *) Arguments Pushouts : clear implicits. Section Universal_Unique. Variable C : category. Hypothesis H : is_univalent C. Lemma isaprop_Pushouts: isaprop (Pushouts C). Proof. apply impred; intro a; apply impred; intro b; apply impred; intro c; apply impred; intro p1; apply impred; intro p2; apply invproofirrelevance. intros Pb Pb'. apply subtypePath. - intro; apply isofhleveltotal2. + apply C. + intros; apply isaprop_isPushout. - apply (total2_paths_f (isotoid _ H (z_iso_from_Pushout_to_Pushout Pb Pb' ))). rewrite transportf_dirprod, transportf_isotoid', transportf_isotoid'. fold (PushoutIn1 Pb). fold (PushoutIn2 Pb). use (dirprodeq); simpl. destruct Pb as [Cone bla]; destruct Pb' as [Cone' bla']; simpl in *. destruct Cone as [p [h k]]; destruct Cone' as [p' [h' k']]; simpl in *. unfold from_Pushout_to_Pushout. rewrite PushoutArrow_PushoutIn1. apply idpath. unfold from_Pushout_to_Pushout. rewrite PushoutArrow_PushoutIn2. apply idpath. Qed. End Universal_Unique. (** In this section we prove that the pushout of an epimorphism is an epimorphism. *) Section epi_po. Variable C : category. (** The pushout of an epimorphism is an epimorphism. *) Lemma EpiPushoutisEpi {a b c : C} (E : Epi _ a b) (g : a --> c) (PB : Pushout E g) : isEpi (PushoutIn2 PB). Proof. apply make_isEpi. intros z g0 h X. use (MorphismsOutofPushoutEqual (isPushout_Pushout PB) _ _ _ X). set (X0 := maponpaths (λ f, g · f) X); simpl in X0. rewrite assoc in X0. rewrite assoc in X0. rewrite <- (PushoutSqrCommutes PB) in X0. rewrite <- assoc in X0. rewrite <- assoc in X0. apply (pr2 E _ _ _) in X0. apply X0. Defined. (** Same result for the other morphism *) Lemma EpiPushoutisEpi' {a b c : C} (f : a --> b) (E : Epi _ a c) (PB : Pushout f E) : isEpi (PushoutIn1 PB). Proof. apply make_isEpi. intros z g0 h X. use (MorphismsOutofPushoutEqual (isPushout_Pushout PB) _ _ X). set (X0 := maponpaths (λ f', f · f') X); simpl in X0. rewrite assoc in X0. rewrite assoc in X0. rewrite (PushoutSqrCommutes PB) in X0. rewrite <- assoc in X0. rewrite <- assoc in X0. apply (pr2 E _ _ _) in X0. apply X0. Defined. End epi_po. (** Criteria for existence of pushouts. *) Section po_criteria. Variable C : category. Definition Pushout_from_Coequalizer_BinCoproduct_eq (X Y Z : C) (f : Z --> X) (g : Z --> Y) (BinCoprod : BinCoproduct X Y) (CEq : Coequalizer (f · (BinCoproductIn1 BinCoprod)) (g · (BinCoproductIn2 BinCoprod))) : f · ((BinCoproductIn1 BinCoprod) · CoequalizerArrow CEq) = g · ((BinCoproductIn2 BinCoprod) · CoequalizerArrow CEq). Proof. repeat rewrite assoc. apply CoequalizerEqAr. Qed. Definition Pushout_from_Coequalizer_BinCoproduct_isPushout (X Y Z : C) (f : Z --> X) (g : Z --> Y) (BinCoprod : BinCoproduct X Y) (CEq : Coequalizer (f · (BinCoproductIn1 BinCoprod)) (g · (BinCoproductIn2 BinCoprod))) : isPushout f g (BinCoproductIn1 BinCoprod · CoequalizerArrow CEq) (BinCoproductIn2 BinCoprod · CoequalizerArrow CEq) (Pushout_from_Coequalizer_BinCoproduct_eq X Y Z f g BinCoprod CEq). Proof. use make_isPushout. intros e h k Hk. set (com1 := BinCoproductIn1Commutes C _ _ BinCoprod _ h k). set (com2 := BinCoproductIn2Commutes C _ _ BinCoprod _ h k). apply (maponpaths (λ l : _, f · l)) in com1. apply (maponpaths (λ l : _, g · l)) in com2. rewrite <- com1 in Hk. rewrite <- com2 in Hk. repeat rewrite assoc in Hk. apply (unique_exists (CoequalizerOut CEq _ _ Hk)). (* Commutativity *) split. rewrite <- assoc. rewrite (CoequalizerCommutes CEq e _). exact (BinCoproductIn1Commutes C _ _ BinCoprod _ h k). rewrite <- assoc. rewrite (CoequalizerCommutes CEq e _). exact (BinCoproductIn2Commutes C _ _ BinCoprod _ h k). (* Equality on equalities of morphisms. *) intros y. apply isapropdirprod. apply C. apply C. (* Uniqueness *) intros y H. induction H as [t p]. apply CoequalizerOutsEq. apply BinCoproductArrowsEq. rewrite <- assoc in t. rewrite t. rewrite (CoequalizerCommutes CEq e _). apply pathsinv0. exact (BinCoproductIn1Commutes C _ _ BinCoprod _ h k). rewrite <- assoc in p. rewrite p. rewrite (CoequalizerCommutes CEq e _). apply pathsinv0. exact (BinCoproductIn2Commutes C _ _ BinCoprod _ h k). Qed. Definition Pushout_from_Coequalizer_BinCoproduct (X Y Z : C) (f : Z --> X) (g : Z --> Y) (BinCoprod : BinCoproduct X Y) (CEq : Coequalizer (f · (BinCoproductIn1 BinCoprod)) (g · (BinCoproductIn2 BinCoprod))) : Pushout f g. Proof. use (make_Pushout f g CEq ((BinCoproductIn1 BinCoprod) · CoequalizerArrow CEq) ((BinCoproductIn2 BinCoprod) · CoequalizerArrow CEq)). - apply Pushout_from_Coequalizer_BinCoproduct_eq. - apply Pushout_from_Coequalizer_BinCoproduct_isPushout. Defined. Definition Pushouts_from_Coequalizers_BinCoproducts (BinCoprods : BinCoproducts C) (CEqs : Coequalizers C) : Pushouts C. Proof. intros Z X Y f g. use (Pushout_from_Coequalizer_BinCoproduct X Y Z f g). apply BinCoprods. apply CEqs. Defined. End po_criteria. Section lemmas_on_pushouts. Context {C : category}. Context {a b c d : C}. Context {f : C ⟦a, b⟧} {g : C ⟦a, c⟧} {h : C⟦b, d⟧} {k : C⟦c, d⟧}. Variable H : f · h = g · k. (** Pushout is symmetric, i.e., we can rotate a po square *) Lemma is_symmetric_isPushout : isPushout _ _ _ _ H -> isPushout _ _ _ _ (!H). Proof. intro isPo. set (Po := make_Pushout _ _ _ _ _ _ isPo). use make_isPushout. intros e x y Hxy. use unique_exists. - use (PushoutArrow Po). + exact y. + exact x. + exact (! Hxy). - cbn. split. + apply (PushoutArrow_PushoutIn2 Po). + apply (PushoutArrow_PushoutIn1 Po). - intros y0. apply isapropdirprod. + apply C. + apply C. - intros y0. intros X. cbn in X. use PushoutArrowUnique. + exact (dirprod_pr2 X). + exact (dirprod_pr1 X). Defined. End lemmas_on_pushouts. Section pushout_up_to_z_iso. Context {C : category}. Local Lemma isPushout_up_to_z_iso_eq {a a' b c d : C} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (H : f · in1 = g · in2) (i : z_iso a' a) : i · f · in1 = i · g · in2. Proof. rewrite <- assoc. rewrite <- assoc. rewrite H. apply idpath. Qed. Lemma isPushout_up_to_z_iso {a a' b c d : C} (f : a --> b) (g : a --> c) (in1 : b --> d) (in2 : c --> d) (H : f · in1 = g · in2) (i : z_iso a' a) (iPo : isPushout (i · f) (i · g) in1 in2 (isPushout_up_to_z_iso_eq f g in1 in2 H i)) : isPushout f g in1 in2 H. Proof. set (Po := make_Pushout _ _ _ _ _ _ iPo). use make_isPushout. intros e h k Hk. use unique_exists. - use (PushoutArrow Po). + exact h. + exact k. + use isPushout_up_to_z_iso_eq. exact Hk. - cbn. split. + exact (PushoutArrow_PushoutIn1 Po e h k (isPushout_up_to_z_iso_eq f g h k Hk i)). + exact (PushoutArrow_PushoutIn2 Po e h k (isPushout_up_to_z_iso_eq f g h k Hk i)). - intros y. apply isapropdirprod. + apply C. + apply C. - intros y X. cbn in X. use PushoutArrowUnique. + exact (dirprod_pr1 X). + exact (dirprod_pr2 X). Qed. End pushout_up_to_z_iso. Section pushout_paths. Context {C : category}. Lemma isPushout_mor_paths {a b c d : C} {f1 f2 : a --> b} {g1 g2 : a --> c} {in11 in21 : b --> d} {in12 in22 : c --> d} (e1 : f1 = f2) (e2 : g1 = g2) (e3 : in11 = in21) (e4 : in12 = in22) (H1 : f1 · in11 = g1 · in12) (H2 : f2 · in21 = g2 · in22) (iPo : isPushout f1 g1 in11 in12 H1) : isPushout f2 g2 in21 in22 H2. Proof. induction e1, e2, e3, e4. assert (e5 : H1 = H2) by apply C. induction e5. exact iPo. Qed. End pushout_paths. (** Proof that f: A -> B is an epi is the same as saying that the diagram << A ---> B | | | | id ‌v ‌‌ v B----> B id >> is a pushout *) Section EpiPushoutId. Context {C : category} {A B : C} (f : C⟦A,B ⟧). Lemma epi_to_pushout : isEpi f -> isPushout f f (identity _) (identity _) (idpath _). Proof. intro h. red. intros x p1 p2 eqx. assert (hp : p1 = p2). { now apply h. } induction hp. apply (unique_exists p1). - split; apply id_left. - intros y. apply isapropdirprod; apply homset_property. - intros y [h1 _]. now rewrite id_left in h1. Qed. Lemma pushout_to_epi : isPushout f f (identity _) (identity _) (idpath _) -> isEpi f. Proof. intros hf. intros D p1 p2 hp. apply hf in hp. destruct hp as [[p [hp1 hp2]] _]. now rewrite <- hp1,hp2. Qed. End EpiPushoutId. Lemma induced_precategory_reflects_pushouts {M : category} {X : Type} (j : X -> ob M) {a b c d : induced_category M j} (f : b <-- a) (g : c <-- a) (p1 : d <-- b) (p2 : d <-- c) (H : p1 ∘ f = p2 ∘ g) : isPushout (# (induced_precategory_incl j) f) (# (induced_precategory_incl j) g) (# (induced_precategory_incl j) p1) (# (induced_precategory_incl j) p2) H -> isPushout f g p1 p2 H. Proof. exact (λ pb T, pb (j T)). Qed. UniMath-20231010/UniMath/CategoryTheory/limits/terminal.v000066400000000000000000000136541451125700300231400ustar00rootroot00000000000000(** Direct definition of terminal object together with: - A proof that the terminal object is a property in a (saturated/univalent) category ([isaprop_Terminal]) - Construction of the terminal object from the empty product ([terminal_from_empty_product]) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.Monics. Local Open Scope cat. Section def_terminal. Context {C : precategory}. Definition isTerminal (b : C) : UU := ∏ a : C, iscontr (a --> b). Lemma isaprop_isTerminal (b : C) : isaprop (isTerminal b). Proof. apply impred_isaprop ; intro ; apply isapropiscontr. Qed. Definition Terminal : UU := ∑ a, isTerminal a. Definition TerminalObject (T : Terminal) : C := pr1 T. Coercion TerminalObject : Terminal >-> ob. Definition TerminalArrow (T : Terminal) (b : C) : b --> T := pr1 (pr2 T b). Lemma TerminalArrowUnique {T : Terminal} {a : C} (f : C⟦a,TerminalObject T⟧) : f = TerminalArrow T _. Proof. exact (pr2 (pr2 T _ ) _ ). Qed. Lemma TerminalEndo_is_identity {T : Terminal} (f : T --> T) : f = identity T. Proof. apply proofirrelevancecontr, (pr2 T T). Qed. Lemma TerminalArrowEq {T : Terminal} {a : C} (f g : a --> T) : f = g. Proof. now rewrite (TerminalArrowUnique f), (TerminalArrowUnique g). Qed. Definition make_Terminal (b : C) (H : isTerminal b) : Terminal. Proof. exists b; exact H. Defined. Definition make_isTerminal (b : C) (H : ∏ (a : C), iscontr (a --> b)) : isTerminal b. Proof. exact H. Defined. Lemma isziso_from_Terminal_to_Terminal (T T' : Terminal) : is_z_isomorphism (TerminalArrow T T'). Proof. exists (TerminalArrow T' T). now split; apply TerminalEndo_is_identity. Defined. Definition z_iso_Terminals (T T' : Terminal) : z_iso T T' := TerminalArrow T' T,,isziso_from_Terminal_to_Terminal T' T. Definition hasTerminal := ishinh Terminal. End def_terminal. Arguments Terminal : clear implicits. Arguments isTerminal : clear implicits. Arguments TerminalObject {_} _. Arguments TerminalArrow {_} _ _. Arguments TerminalArrowUnique {_} _ _ _. Arguments make_isTerminal {_} _ _ _. Arguments make_Terminal {_} _ _. Section Terminal_Unique. Context (C : category) (H : is_univalent C). Lemma isaprop_Terminal : isaprop (Terminal C). Proof. apply invproofirrelevance. intros T T'. apply (total2_paths_f (isotoid _ H (z_iso_Terminals T T')) ). apply isaprop_isTerminal. Qed. End Terminal_Unique. Section Terminal_and_EmptyProd. (** Construct Terminal from empty arbitrary product. *) Definition terminal_from_empty_product (C : category) : Product empty C fromempty -> Terminal C. Proof. intros X. use (make_Terminal (ProductObject _ C X)). use make_isTerminal. intros a. assert (H : ∏ i : empty, C⟦a, fromempty i⟧) by (intros i; apply (fromempty i)). apply (make_iscontr (ProductArrow _ _ X H)). abstract (intros t; apply ProductArrowUnique; intros i; apply (fromempty i)). Defined. End Terminal_and_EmptyProd. (* Section Terminal_from_Lims. *) (* Require Import UniMath.CategoryTheory.limits.graphs.colimits. *) (* Require Import UniMath.CategoryTheory.limits.graphs.limits. *) (* Require Import UniMath.CategoryTheory.opp_precat. *) (* Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). *) (* Context {C : precategory}. *) (* Definition empty_graph : graph. *) (* Proof. *) (* exists empty. *) (* exact (λ _ _, empty). *) (* Defined. *) (* Definition termDiagram : diagram empty_graph C^op. *) (* Proof. *) (* exists fromempty. *) (* intros u; induction u. *) (* Defined. *) (* Definition termCone (c : C) : cone termDiagram c. *) (* Proof. *) (* simple refine (make_cone _ _); intro u; induction u. *) (* Defined. *) (* Lemma Terminal_from_Lims : Lims C -> Terminal C. *) (* Proof. *) (* intros H. *) (* case (H _ termDiagram); intros cc iscc; destruct cc as [c cc]; simpl in *. *) (* apply (make_Terminal c); apply make_isTerminal; intros b. *) (* case (iscc _ (termCone b)); intros f Hf; destruct f as [f fcomm]. *) (* apply (tpair _ f); intro g. *) (* simple refine (let X : ∑ x : b --> c, *) (* ∏ v, coconeIn cc v · x = coconeIn (termCone b) v := _ in _). *) (* { apply (tpair _ g); intro u; induction u. } *) (* apply (maponpaths pr1 (Hf X)). *) (* Defined. *) (* End Terminal_from_Lims. *) (** * Construction of terminal object in a functor category *) Section TerminalFunctorCat. Context (C D : category) (ID : Terminal D). Definition Terminal_functor_precat : Terminal [C,D]. Proof. use make_Terminal. - exact (constant_functor _ _ ID). - intros F. use tpair. + use make_nat_trans. * intro a; apply TerminalArrow. * abstract (intros a b f; apply TerminalArrowEq). + abstract (intros α; apply (nat_trans_eq D); intro a; apply TerminalArrowUnique). Defined. End TerminalFunctorCat. (** Morphisms from the terminal object are monic *) Section monics_terminal. Context {C : category} (TC : Terminal C). Lemma from_terminal_isMonic (a : C) (f : TC --> a) : isMonic f. Proof. apply make_isMonic; intros b g h H. now apply TerminalArrowEq. Qed. End monics_terminal. Definition iso_to_Terminal {C : category} (T : Terminal C) (x : C) (i : z_iso T x) : isTerminal C x. Proof. intros w. use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; refine (!(id_right _) @ _ @ id_right _) ; rewrite <- !(z_iso_after_z_iso_inv i) ; rewrite !assoc ; apply maponpaths_2 ; apply TerminalArrowEq). - exact (TerminalArrow T w · i). Defined. UniMath-20231010/UniMath/CategoryTheory/limits/zero.v000066400000000000000000000132431451125700300222760ustar00rootroot00000000000000(** Direct definition of zero objects *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.opp_precat. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Section def_zero. Variable C : category. Definition isZero (b : C) : UU := (∏ a : C, iscontr (b --> a)) × (∏ a : C, iscontr (a --> b)). Lemma isaprop_isZero (b : C) : isaprop (isZero b). Proof. apply isapropdirprod. - apply impred. intros t. apply isapropiscontr. - apply impred. intros t. apply isapropiscontr. Qed. Definition Zero : UU := total2 (λ a, isZero a). Definition ZeroObject (Z : Zero) : C := pr1 Z. Coercion ZeroObject : Zero >-> ob. Definition make_Zero (b : C) (H : isZero b) : Zero. Proof. exists b; exact H. Defined. Definition make_isZero (b : C) (H : ∏ (a : C), iscontr (b --> a)) (H' : ∏ (a : C), iscontr (a --> b)) : isZero b. Proof. unfold isZero. exact ((H,,H')). Defined. Definition ZeroArrowFrom (Z : Zero) (b : C) : Z --> b := pr1 (pr1 (pr2 Z) b). Definition ZeroArrowTo (Z : Zero) (b : C) : b --> Z := pr1 (pr2 (pr2 Z) b). Lemma ArrowsToZero (Z : Zero) (b : C) (f g : b --> Z) : f = g. Proof. apply proofirrelevancecontr. apply (pr2 (pr2 Z) _). Qed. Lemma ArrowsFromZero (Z : Zero) (b : C) (f g : Z --> b) : f = g. Proof. apply proofirrelevancecontr. apply (pr1 (pr2 Z) _). Qed. (** For any pair of objects, there exists a unique arrow which factors through the zero object *) Definition ZeroArrow (Z : Zero) (a b : C) : C⟦a, b⟧ := (ZeroArrowTo Z a) · (ZeroArrowFrom Z b). Lemma ZeroArrowEq (Z : Zero) (a b : C) (f1 : C⟦a, Z⟧) (g1 : C⟦Z, b⟧) : f1 · g1 = ZeroArrow Z a b. Proof. rewrite (ArrowsToZero Z a f1 (ZeroArrowTo Z a)). rewrite (ArrowsFromZero Z b g1 (ZeroArrowFrom Z b)). apply idpath. Qed. Lemma ZeroArrow_comp_left (Z : Zero) (a b c : C) (f : C⟦b, c⟧) : ZeroArrow Z a b · f = ZeroArrow Z a c. Proof. unfold ZeroArrow at 1. rewrite <- assoc. apply ZeroArrowEq. Qed. Lemma ZeroArrow_comp_right (Z : Zero) (a b c : C) (f : C⟦a, b⟧) : f · ZeroArrow Z b c = ZeroArrow Z a c. Proof. unfold ZeroArrow at 1. rewrite assoc. apply ZeroArrowEq. Qed. Lemma ZeroEndo_is_identity (Z : Zero) (f : Z --> Z) : identity Z = f. Proof. apply ArrowsToZero. Qed. Lemma isziso_from_Zero_to_Zero (Z Z' : Zero) : is_z_isomorphism (ZeroArrowTo Z Z'). Proof. exists (ZeroArrowTo Z' Z). split; apply pathsinv0; apply ZeroEndo_is_identity. Qed. Definition z_iso_Zeros (Z Z' : Zero) : z_iso Z Z' := tpair _ (ZeroArrowTo Z' Z) (isziso_from_Zero_to_Zero Z' Z). Lemma ZerosArrowEq (Z Z' : Zero) (a b : C) : ZeroArrow Z a b = ZeroArrow Z' a b. Proof. set (i := z_iso_Zeros Z Z'). unfold ZeroArrow. assert (e : ZeroArrowTo Z a · identity _ = ZeroArrowTo Z a) by apply id_right. rewrite <- e. clear e. rewrite <- (z_iso_inv_after_z_iso i). rewrite assoc. assert (e1 : ZeroArrowTo Z a · i = ZeroArrowTo Z' a) by apply ArrowsToZero. rewrite e1. clear e1. assert (e2 : inv_from_z_iso i · ZeroArrowFrom Z b = ZeroArrowFrom Z' b) by apply ArrowsFromZero. rewrite <- assoc. rewrite e2. clear e2. apply idpath. Qed. Definition hasZero := ishinh Zero. End def_zero. Arguments isZero {_} _. Arguments ZeroObject [C] _. Arguments ZeroArrowTo [C]{Z} b. Arguments ZeroArrowFrom [C]{Z} b. Arguments ZeroArrow [C] _ _ _. Arguments make_isZero {_} _ _ _ . Arguments make_Zero {_} _ _ . Section Zero_Unique. Variable C : category. Hypothesis H : is_univalent C. Lemma isaprop_Zero : isaprop (Zero C). Proof. apply invproofirrelevance. intros Z Z'. apply (total2_paths_f (isotoid _ H (z_iso_Zeros _ Z Z'))). apply proofirrelevance. unfold isZero. apply isapropdirprod; apply impred; intros t; apply isapropiscontr. Defined. End Zero_Unique. Section facts. Variable C : category. Lemma ZeroIffInitialAndTerminal (b : C) : isZero b <-> (isInitial C b) × (isTerminal C b). Proof. unfold isZero, isInitial, isTerminal. split; intros H; apply H. Qed. Definition ZIsoToisZero {A : C} (Z : Zero C) (i : z_iso A Z) : isZero A. Proof. use make_isZero. - intros a. use tpair. + exact (i · (ZeroArrowFrom a)). + cbn. intros t. apply (pre_comp_with_z_iso_is_inj (pr2 (z_iso_inv_from_z_iso i))). rewrite assoc. cbn. rewrite (z_iso_after_z_iso_inv i). rewrite id_left. apply ArrowsFromZero. - intros a. use tpair. + exact ((ZeroArrowTo a) · (z_iso_inv_from_z_iso i)). + cbn. intros t. apply (post_comp_with_z_iso_is_inj (pr2 i)). rewrite <- assoc. cbn. etrans. 2: { apply maponpaths, pathsinv0, (z_iso_after_z_iso_inv i). } rewrite id_right. apply ArrowsToZero. Qed. (** ** Transport of ZeroArrow *) Lemma transport_target_ZeroArrow {a b c : C} (Z : Zero C) (e : b = c) : transportf _ e (ZeroArrow Z a b) = ZeroArrow Z a c. Proof. induction e. apply idpath. Qed. Lemma transport_source_ZeroArrow {a b c : C} (Z : Zero C) (e : b = a) : transportf (λ (a' : ob C), precategory_morphisms a' c) e (ZeroArrow Z b c) = ZeroArrow Z a c. Proof. induction e. apply idpath. Qed. Definition zero_lifts (M:category) {X:Type} (j : X -> ob M) := ∃ z, isZero (j z). End facts. UniMath-20231010/UniMath/CategoryTheory/opp_precat.v000066400000000000000000000401321451125700300221470ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 ************************************************************) (** ********************************************************** Contents : Definition of opposite category and functor ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. (** * The opposite precategory of a precategory *) Definition opp_precat_ob_mor (C : precategory_ob_mor) : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) C (λ a b : C, C⟦b, a⟧ ). Definition opp_precat_data (C : precategory_data) : precategory_data := tpair _ _ (tpair _ (λ c : opp_precat_ob_mor C, identity c) (λ (a b c : opp_precat_ob_mor C) f g, g · f)). Definition is_precat_opp_precat_data (C : precategory) : is_precategory (opp_precat_data C) := ((λ a b, pr212 C b a),,(λ a b, pr112 C b a)),, ((λ a b c d f g h, pr222 C d c b a h g f),,(λ a b c d f g h, pr122 C d c b a h g f)). Definition opp_precat (C : precategory) : precategory := tpair _ (opp_precat_data C) (is_precat_opp_precat_data C). Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op") : cat. Goal ∏ C:precategory, C^op^op = C. reflexivity. Qed. Definition opp_ob {C : precategory} (c : ob C) : ob C^op := c. Definition rm_opp_ob {C : precategory} (cop : ob C^op) : ob C := cop. Definition opp_mor {C : precategory} {b c : C} (f : C⟦b, c⟧) : C^op⟦c, b⟧ := f. Definition rm_opp_mor {C : precategory} {b c : C} (f : C^op⟦c, b⟧) : C⟦b, c⟧ := f. Definition oppositeCategory : category -> category := λ M, @tpair precategory has_homsets (opp_precat M) (λ A B, homset_property M (rm_opp_ob B) (rm_opp_ob A)). Definition opp_mor_eq {C : precategory} {a b : C} {f g : a --> b} (e : opp_mor f = opp_mor g) : f = g := e. Lemma opp_opp_precat_ob_mor (C : precategory_ob_mor) : C = opp_precat_ob_mor (opp_precat_ob_mor C). Proof. reflexivity. Defined. Lemma opp_opp_precat_ob_mor_compute (C : precategory_ob_mor) : idpath _ = maponpaths precategory_id_comp (opp_opp_precat_ob_mor C). Proof. reflexivity. Defined. Lemma opp_opp_precat_data (C : precategory_data) : C = opp_precat_data (opp_precat_data C). Proof. reflexivity. Defined. Lemma opp_opp_precat (C : precategory) (hs : has_homsets C) : C = C^op^op. Proof. use total2_paths_f. - apply opp_opp_precat_data. - apply (isaprop_is_precategory _ hs). Qed. Definition opp_is_iso {C : precategory} {a b : C} (f : a --> b) : @is_iso C a b f -> @is_iso C^op b a f. Proof. intros H. set (T := is_z_iso_from_is_iso _ H). apply (is_iso_qinv (C:=C^op) _ (pr1 T)). split; [ apply (pr2 (pr2 T)) | apply (pr1 (pr2 T)) ]. Qed. Definition iso_from_opp {C : precategory} {a b : C} (f : a --> b) : @is_iso C^op b a f → @is_iso C a b f. Proof. intros H. set (T := is_z_iso_from_is_iso _ H). apply (is_iso_qinv (C:=C) _ (pr1 T)). split; [ apply (pr2 (pr2 T)) | apply (pr1 (pr2 T)) ]. Qed. Definition opp_iso {C : precategory} {a b : C} : @iso C a b -> @iso C^op b a. intro f. exists (pr1 f). set (T := is_z_iso_from_is_iso _ (pr2 f)). apply (is_iso_qinv (C:=C^op) _ (pr1 T)). split; [ apply (pr2 (pr2 T)) | apply (pr1 (pr2 T)) ]. Defined. Lemma opp_is_inverse_in_precat {C : precategory} {a b : C} {f : a --> b} {g : b --> a} : @is_inverse_in_precat C a b f g -> @is_inverse_in_precat (opp_precat C) a b g f. Proof. intros H. use make_is_inverse_in_precat. - exact (is_inverse_in_precat1 H). - exact (is_inverse_in_precat2 H). Defined. Definition opp_is_z_isomorphism {C : precategory} {a b : C} (f : a --> b) : @is_z_isomorphism C a b f -> @is_z_isomorphism C^op b a f. Proof. intros H. use make_is_z_isomorphism. - exact (is_z_isomorphism_mor H). - exact (opp_is_inverse_in_precat (is_inverse_in_precat_inv H)). Defined. Definition opp_z_iso {C : precategory} {a b : C} : @z_iso C a b -> @z_iso C^op b a. Proof. intros H. use make_z_iso. - exact (z_iso_mor H). - exact (inv_from_z_iso H). - exact (opp_is_inverse_in_precat (is_inverse_in_precat_inv H)). Defined. Definition z_iso_from_opp {C : precategory} {a b : C} (f : a --> b) : @is_z_isomorphism C^op b a f → @is_z_isomorphism C a b f. Proof. intros H. exists (pr1 H). split; [ apply (pr2 (pr2 H)) | apply (pr1 (pr2 H)) ]. Qed. Lemma has_homsets_opp {C : precategory} (hsC : has_homsets C) : has_homsets C^op. Proof. intros a b; apply hsC. Defined. Definition op_cat (c : category) : category := (opp_precat c,, has_homsets_opp (homset_property c) ). (** * The opposite functor *) Definition functor_opp_data {C D : precategory} (F : functor C D) : functor_data C^op D^op := tpair (fun F : C^op -> D^op => ∏ a b, C^op ⟦a, b⟧ -> D^op ⟦F a, F b⟧) F (fun (a b : C) (f : C⟦b, a⟧) => functor_on_morphisms F f). Lemma is_functor_functor_opp {C D : precategory} (F : functor C D) : is_functor (functor_opp_data F). Proof. split; intros. - unfold functor_idax; simpl. apply (functor_id F). - unfold functor_compax; simpl. intros. apply (functor_comp F). Qed. Definition functor_opp {C D : precategory} (F : functor C D) : functor C^op D^op := tpair _ _ (is_functor_functor_opp F). (** Properties of the opp functor *) Section opp_functor_properties. Variables C D : precategory. Variable F : functor C D. Lemma opp_functor_fully_faithful : fully_faithful F -> fully_faithful (functor_opp F). Proof. intros HF a b. apply HF. Defined. Lemma opp_functor_essentially_surjective : essentially_surjective F -> essentially_surjective (functor_opp F). Proof. intros HF d. set (TH := HF d). set (X:=@hinhuniv (∑ a : C, z_iso (F a) d)). use (X _ _ TH). intro H. clear TH. clear X. apply hinhpr. destruct H as [a X]. exists a. simpl in *. apply opp_z_iso. apply (z_iso_inv_from_z_iso X). Qed. End opp_functor_properties. Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op") : cat. Lemma functor_opp_identity {C : precategory} (hsC : has_homsets C) : functor_opp (functor_identity C) = functor_identity C^op. Proof. apply (functor_eq _ _ (has_homsets_opp hsC)); trivial. Qed. Lemma functor_opp_composite {C D E : precategory} (F : functor C D) (G : functor D E) (hsE : has_homsets E) : functor_opp (functor_composite F G) = functor_composite (functor_opp F) (functor_opp G). Proof. apply (functor_eq _ _ (has_homsets_opp hsE)); trivial. Qed. Definition from_opp_to_opp_opp (A C : precategory) (hsC : has_homsets C) : functor_data [A, C, hsC]^op [A^op, C^op, has_homsets_opp hsC]. Proof. apply (tpair _ functor_opp). simpl; intros F G α. use tpair. + simpl; intro a; apply α. + abstract (intros a b f; simpl in *; apply pathsinv0, (nat_trans_ax α)). Defined. Lemma is_functor_from_opp_to_opp_opp (A C : precategory) (hsC : has_homsets C) : is_functor (from_opp_to_opp_opp A C hsC). Proof. split. - now intro F; simpl; apply (nat_trans_eq (has_homsets_opp hsC)); simpl; intro a. - now intros F G H α β; simpl; apply (nat_trans_eq (has_homsets_opp hsC)); simpl; intro a. Qed. Definition functor_from_opp_to_opp_opp (A C : precategory) (hsC : has_homsets C) : functor [A, C, hsC]^op [A^op, C^op, has_homsets_opp hsC] := tpair _ _ (is_functor_from_opp_to_opp_opp A C hsC). Definition from_opp_opp_to_opp (A C : precategory) (hsC : has_homsets C) : functor_data [A^op, C^op, has_homsets_opp hsC] [A, C, hsC]^op. Proof. use tpair; simpl. - intro F. use tpair. + exists F. apply (λ a b f, # F f). + abstract (split; [ intro a; apply (functor_id F) | intros a b c f g; apply (functor_comp F)]). - intros F G α; exists α. abstract (intros a b f; apply pathsinv0, (nat_trans_ax α)). Defined. Lemma is_functor_from_opp_opp_to_opp (A C : precategory) (hsC : has_homsets C) : is_functor (from_opp_opp_to_opp A C hsC). Proof. split. - now intro F; simpl; apply (nat_trans_eq hsC); intro a. - now intros F G H α β; simpl; apply (nat_trans_eq hsC); intro a. Qed. Definition functor_from_opp_opp_to_opp (A C : precategory) (hsC : has_homsets C) : functor [A^op, C^op, has_homsets_opp hsC] [A, C, hsC]^op := tpair _ _ (is_functor_from_opp_opp_to_opp A C hsC). Definition op_nt {c d : category} {f g : functor c d} (a : nat_trans f g) : nat_trans (functor_opp g) (functor_opp f). Proof. use tpair. - exact (λ c, a c). - abstract (intros x y h; apply (! (nat_trans_ax a _ _ _ ))). Defined. Lemma op_nt_is_z_iso {C D : category} {f g : functor C D} (a : nat_trans f g) (is : is_nat_z_iso a) : is_nat_z_iso (op_nt a). Proof. intro c. use opp_is_z_isomorphism. exact (is c). Defined. Lemma op_nt_is_iso {C D : category} {f g : functor C D} (a : nat_trans f g) (is : is_nat_iso a) : is_nat_iso (op_nt a). Proof. intro c. use opp_is_iso. exact (is c). Defined. (** It's univalent *) Definition op_iso_is_cat_iso {C : category} (X Y : C^op) : @iso C Y X ≃ iso X Y. Proof. use weqfibtototal. intro f. use weqimplimpl. - apply opp_is_iso. - apply iso_from_opp. - apply isaprop_is_iso. - apply isaprop_is_iso. Defined. Definition has_homsets_op (C : category) : has_homsets (C^op). Proof. intros a b. apply C. Defined. Definition op_category (C : category) : category := make_category C^op (has_homsets_op C). Definition op_z_iso_is_cat_z_iso {C : category} (X Y : C^op) : @z_iso C Y X ≃ z_iso X Y. Proof. use weqfibtototal. intro f. use weqimplimpl. - apply opp_is_z_isomorphism. - apply z_iso_from_opp. - apply isaprop_is_z_isomorphism. - apply (isaprop_is_z_isomorphism(C:=op_category C)). Defined. Definition from_op_op_to_op (A C : category) : functor [op_category A, op_category C] (op_category [A,C]) := tpair _ _ (is_functor_from_opp_opp_to_opp A C C). Definition op_is_univalent (C : univalent_category) : is_univalent (op_category C). Proof. intros X Y. use weqhomot. + exact ((op_z_iso_is_cat_z_iso X Y) ∘ make_weq (@idtoiso C Y X) (pr2( C) Y X) ∘ weqpathsinv0 _ _)%weq. + intros p. induction p ; cbn. apply subtypePath. * intro ; apply (isaprop_is_z_isomorphism(C:=op_category C)). * apply idpath. Defined. Definition op_unicat (C : univalent_category) : univalent_category := (op_category C ,, op_is_univalent C). Notation "C '^op'" := (op_category C) (at level 3, format "C ^op") : cat. Definition op_ob {C : category} (c : ob C) : ob C^op := c. Definition rm_op_ob {C : category} (cop : ob C^op) : ob C := cop. Definition op_mor {C : category} {b c : C} (f : C⟦b, c⟧) : C^op⟦c, b⟧ := f. Definition rm_op_mor {C : category} {b c : C} (f : C^op⟦c, b⟧) : C⟦b, c⟧ := f. (** Functoriality of taking the opposite *) Definition functor_identity_op (C : category) : functor_identity (C^op) ⟹ functor_opp (functor_identity C). Proof. use make_nat_trans. - exact (λ x, identity x). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition is_nat_z_iso_functor_identity_op (C : category) : is_nat_z_iso (functor_identity_op C). Proof. intros x. apply is_z_isomorphism_identity. Defined. Definition functor_identity_op_nat_z_iso (C : category) : nat_z_iso (functor_identity (C^op)) (functor_opp (functor_identity C)). Proof. use make_nat_z_iso. - exact (functor_identity_op C). - exact (is_nat_z_iso_functor_identity_op C). Defined. Definition functor_comp_op {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₂ ⟶ C₃) : functor_opp F ∙ functor_opp G ⟹ functor_opp (F ∙ G). Proof. use make_nat_trans. - exact (λ x, identity _). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition is_nat_z_iso_functor_comp_op {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₂ ⟶ C₃) : is_nat_z_iso (functor_comp_op F G). Proof. intros x. apply is_z_isomorphism_identity. Defined. Definition functor_comp_op_nat_z_iso {C₁ C₂ C₃ : category} (F : C₁ ⟶ C₂) (G : C₂ ⟶ C₃) : nat_z_iso (functor_opp F ∙ functor_opp G) (functor_opp (F ∙ G)). Proof. use make_nat_z_iso. - exact (functor_comp_op F G). - exact (is_nat_z_iso_functor_comp_op F G). Defined. (** It forms a duality involution *) Definition op_unit_nat_trans {C₁ C₂ : category} (F : C₁ ⟶ C₂) : functor_identity _ ∙ functor_opp (functor_opp F) ⟹ F ∙ functor_identity _. Proof. use make_nat_trans. - exact (λ x, identity (F x)). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition op_unit_nat_z_iso {C₁ C₂ : category} (F : C₁ ⟶ C₂) : nat_z_iso (functor_identity _ ∙ functor_opp (functor_opp F)) (F ∙ functor_identity _). Proof. use make_nat_z_iso. - exact (op_unit_nat_trans F). - intro. apply identity_is_z_iso. Defined. Definition op_unit_inv_nat_trans {C₁ C₂ : category} (F : C₁ ⟶ C₂) : functor_identity _ ∙ F ⟹ functor_opp (functor_opp F) ∙ functor_identity _. Proof. use make_nat_trans. - exact (λ x, identity (F x)). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition op_unit_inv_nat_z_iso {C₁ C₂ : category} (F : C₁ ⟶ C₂) : nat_z_iso (functor_identity _ ∙ F) (functor_opp (functor_opp F) ∙ functor_identity _). Proof. use make_nat_z_iso. - exact (op_unit_inv_nat_trans F). - intro. apply identity_is_z_iso. Defined. Definition op_triangle_nat_trans (C : category) : functor_identity _ ⟹ functor_opp (functor_identity C). Proof. use make_nat_trans. - exact (λ x, identity x). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition op_triangle_nat_z_iso (C : category) : nat_z_iso (functor_identity _) (functor_opp (functor_identity C)). Proof. use make_nat_z_iso. - exact (op_triangle_nat_trans C). - intro. apply identity_is_z_iso. Defined. Definition op_unit_unit_inv_nat_trans (C : category) : nat_trans (functor_identity C) (functor_identity C ∙ functor_identity ((C^op)^op)). Proof. use make_nat_trans. - exact (λ x, identity x). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition op_unit_unit_inv_nat_z_iso (C : category) : nat_z_iso (functor_identity C) (functor_identity C ∙ functor_identity ((C^op)^op)). Proof. use make_nat_z_iso. - exact (op_unit_unit_inv_nat_trans C). - intro. apply identity_is_z_iso. Defined. Definition op_unit_inv_unit_nat_trans (C : category) : nat_trans (functor_identity ((C^op)^op) ∙ functor_identity C) (functor_identity ((C^op)^op)). Proof. use make_nat_trans. - exact (λ x, identity x). - abstract (intros x y f ; cbn ; rewrite id_left, id_right ; apply idpath). Defined. Definition op_unit_inv_unit_nat_z_iso (C : category) : nat_z_iso (functor_identity ((C^op)^op) ∙ functor_identity C) (functor_identity ((C^op)^op)). Proof. use make_nat_z_iso. - exact (op_unit_inv_unit_nat_trans C). - intro. apply identity_is_z_iso. Defined. (** idtoiso in the opposite *) Proposition idtoiso_opp {C : category} {x y : C} (p : x = y) : pr1 (@idtoiso (C^op) _ _ p) = pr1 (@idtoiso C _ _ (!p)). Proof. induction p ; cbn. apply idpath. Qed. UniMath-20231010/UniMath/CategoryTheory/precomp_ess_surj.v000066400000000000000000000704501451125700300234030ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 ************************************************************) (** ********************************************************** Contents : Precomposition with a fully faithful and essentially surjective functor yields an essentially surjective functor ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ). Local Notation "F '^-i'" := (iso_from_fully_faithful_reflection F) (at level 20). Local Notation "G 'O' F" := (functor_compose _ _ _ F G) (at level 25). Ltac inv_functor HF x y := let H:=fresh in set (H:= homotweqinvweq (weq_from_fully_faithful HF x y)); simpl in H; unfold fully_faithful_inv_hom; simpl; rewrite H; clear H. (** * Lengthy preparation for the main result of this file *) Section precomp_w_ess_surj_ff_is_ess_surj. (** ** Section variables *) Context (A B C: category). Hypothesis Ccat : is_univalent C. Variable H : functor A B. Hypothesis p : essentially_surjective H. Hypothesis fH : fully_faithful H. (** We prove that precomposition with a [H] yields an essentially surjective functor *) Section essentially_surjective. (** ** Specification of preimage [G] of a functor [F] *) (** Given a functor [F] from [A] to [C], we construct [G] such that [F = G O H] *) Variable F : functor A C. Section preimage. (** The type [X b] will be contractible, and [G] is defined as the first component of its center. *) Local Definition X (b : B) := total2 ( fun ck : total2 (λ c : C, ∏ a : A, z_iso (H a) b -> z_iso (F a) c) => ∏ t t' : total2 (λ a : A, z_iso (H a) b), ∏ f : pr1 t --> pr1 t', (#H f · pr2 t' = pr2 t -> #F f · pr2 ck (pr1 t') (pr2 t') = pr2 ck (pr1 t) (pr2 t))). Local Definition kX {b : B} (t : X b) := (pr2 (pr1 t)). (** The following is the third component of the center of [X b] *) Lemma X_aux_type_center_of_contr_proof (b : B) (anot : A) (hnot : z_iso (H anot) b) : ∏ (t t' : total2 (λ a : A, z_iso (H a) b)) (f : pr1 t --> pr1 t'), #H f· pr2 t' = pr2 t -> #F f· #F (fH^-1 (pr2 t'· inv_from_z_iso hnot)) = #F (fH^-1 (pr2 t· inv_from_z_iso hnot)). Proof. intros t t' f. destruct t as [a h]. destruct t' as [a' h']. simpl in *. intro star. rewrite <- functor_comp. apply maponpaths. apply (invmaponpathsweq (weq_from_fully_faithful fH a anot)). simpl. rewrite functor_comp. inv_functor fH a' anot. rewrite assoc. inv_functor fH a anot. rewrite <- star. apply idpath. Qed. (** The center of [X b] *) Definition X_aux_type_center_of_contr (b : B) (anot : A)(hnot : z_iso (H anot) b) : X b. Proof. set (cnot := F anot). set (g := fun (a : A)(h : z_iso (H a) b) => (fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot)))). set (knot := fun (a : A)(h : z_iso (H a) b) => functor_on_z_iso F (g a h)). simpl in *. exists (tpair _ (F anot) knot). simpl. apply X_aux_type_center_of_contr_proof. Defined. (** Any inhabitant of [X b] is equal to the center of [X b]. *) Lemma X_aux_type_contr_eq (b : B) (anot : A) (hnot : z_iso (H anot) b) : ∏ t : X b, t = X_aux_type_center_of_contr b anot hnot. Proof. intro t. assert (Hpr1 : pr1 (X_aux_type_center_of_contr b anot hnot) = pr1 t). { set (w := isotoid _ Ccat ((pr2 (pr1 t)) anot hnot) : pr1 (pr1 (X_aux_type_center_of_contr b anot hnot)) = pr1 (pr1 t)). apply (total2_paths_f w). simpl. destruct t as [[c1 k1] q1]. simpl in *. apply funextsec; intro a. apply funextsec; intro h. set (gah := fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot))). set (qhelp := q1 (tpair _ a h)(tpair _ anot hnot) gah). simpl in *. assert (feedtoqhelp : #H (fH^-1 (h· inv_from_z_iso hnot))· hnot = h). { inv_functor fH a anot. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (quack := qhelp feedtoqhelp). simpl in *. intermediate_path (z_iso_comp (functor_on_z_iso F (fH^-i (z_iso_comp h (z_iso_inv_from_z_iso hnot)))) (idtoiso w) ). { generalize w; intro w0. induction w0. simpl. apply z_iso_eq. simpl. simpl. rewrite id_right. apply idpath. } apply z_iso_eq. simpl. unfold w. rewrite idtoiso_isotoid. apply quack. } apply pathsinv0. apply (total2_paths_f Hpr1). apply proofirrelevance. repeat (apply impred; intro). apply C. Qed. (** Putting everything together: [X b] is contractible. *) Definition iscontr_X : ∏ b : B, iscontr (X b). Proof. intro b. assert (HH : isaprop (iscontr (X b))). apply isapropiscontr. apply (p b (tpair (λ x, isaprop x) (iscontr (X b)) HH)). intro t. exists (X_aux_type_center_of_contr b (pr1 t) (pr2 t)). apply (X_aux_type_contr_eq b (pr1 t) (pr2 t)). Defined. (** The object part of [G], [Go b], is defined as the first component of the center of [X b]. *) (** *** [G] on objects *) Definition Go : B -> C := λ b : B, pr1 (pr1 (pr1 (iscontr_X b))). Local Definition k (b : B) : ∏ a : A, z_iso (H a) b -> z_iso (F a) (Go b) := pr2 (pr1 (pr1 (iscontr_X b))). Local Definition q (b : B) := pr2 (pr1 (iscontr_X b)). (** Given any inhabitant of [X b], its first component is equal to [Go b]. *) Definition Xphi (b : B) (t : X b) : pr1 (pr1 t) = Go b. Proof. set (p1 := pr2 (iscontr_X b) t). exact (base_paths _ _ (base_paths _ _ p1)). Defined. (** Given any inhabitant [t : X b], its second component is equal to [k b], modulo transport along [Xphi b t]. *) Definition Xkphi_transp (b : B) (t : X b) : ∏ a : A, ∏ h : z_iso (H a) b, transportf _ (Xphi b t) (kX t) a h = k b a h. Proof. unfold k. rewrite <- (fiber_paths (base_paths _ _ (pr2 (iscontr_X b) t))). intros ? ?. apply maponpaths, idpath. Qed. (** Similarly to the lemma before, the second component of [t] is the same as [k b], modulo postcomposition with an isomorphism. *) Definition Xkphi_idtoiso (b : B) (t : X b) : ∏ a : A, ∏ h : z_iso (H a) b, k b a h · idtoiso (!Xphi b t) = kX t a h. Proof. intros a h. rewrite <- (Xkphi_transp _ t). generalize (Xphi b t). intro i; destruct i. apply id_right. Qed. (* Lemma k_transport (b : ob B) (*t : X b*) (c : ob C) (p : pr1 (pr1 t) = c) (a : ob A) (h : iso (pr1 H a) b): transportf (λ c' : ob C, ∏ a : ob A, iso (pr1 H a) b -> iso ((pr1 F) a) c') p (k) a h = (k b) b a h · idtoiso p . *) (** *** Preparation for [G] on morphisms *) (** [G f] will be defined as the first component of the center of contraction of [Y f]. *) Local Definition Y {b b' : B} (f : b --> b') := total2 (fun g : Go b --> Go b' => ∏ a : A, ∏ h : z_iso (H a) b, ∏ a' : A, ∏ h' : z_iso (H a') b', ∏ l : a --> a', #H l · h' = h · f -> #F l · k b' a' h' = k b a h · g). Lemma Y_inhab_proof (b b' : B) (f : b --> b') (a0 : A) (h0 : z_iso (H a0) b) (a0' : A) (h0' : z_iso (H a0') b') : ∏ (a : A) (h : z_iso (H a) b) (a' : A) (h' : z_iso (H a') b') (l : a --> a'), #H l· h' = h· f -> #F l· k b' a' h' = k b a h· ((inv_from_z_iso (k b a0 h0)· #F (fH^-1 ((h0· f)· inv_from_z_iso h0')))· k b' a0' h0'). Proof. intros a h a' h' l alpha. set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))). set (m' := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))). assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) = k b a0 h0). { apply z_iso_eq. apply (q b (tpair _ a0 h0) (tpair _ a h) m). simpl. inv_functor fH a0 a. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b' a' h') = k b' a0' h0'). { apply z_iso_eq. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m'). simpl; inv_functor fH a0' a'. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } set (hfh := h0 · f · inv_from_z_iso h0'). set (l0 := fH^-1 hfh). set (g0 := inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0'). assert (sssss : #H (l0 · m') = #H (m · l)). { rewrite functor_comp . unfold m'. simpl. inv_functor fH a0' a'. unfold l0. inv_functor fH a0 a0'. unfold hfh. intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · inv_from_z_iso h'). { repeat rewrite assoc; apply idpath. } rewrite z_iso_after_z_iso_inv, id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths, pathsinv0, z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left, pathsinv0, alpha. } assert (star5 : inv_from_z_iso m · l0 = l · inv_from_z_iso m'). { apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left, (invmaponpathsweq (weq_from_fully_faithful fH a0 a' )), pathsinv0, sssss. } clear sssss. unfold g0. assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) = inv_from_z_iso (functor_on_z_iso F m)). { apply pathsinv0, z_iso_inv_on_left, pathsinv0. apply z_iso_inv_on_right. unfold m; simpl. apply pathsinv0, (base_paths _ _ sss). } repeat rewrite assoc. rewrite sss''. clear sss'' sss. rewrite <- functor_on_inv_from_z_iso. rewrite <- functor_comp. rewrite star5; clear star5. rewrite functor_comp, functor_on_inv_from_z_iso. assert (star4 : inv_from_z_iso (functor_on_z_iso F m')· k b' a0' h0' = k b' a' h' ). { apply z_iso_inv_on_right. apply pathsinv0, (base_paths _ _ ssss). } rewrite <- assoc. rewrite star4. apply idpath. Qed. (** The center of [Y b b' f]. *) Definition Y_inhab (b b' : B) (f : b --> b') (a0 : A) (h0 : z_iso (H a0) b) (a0' : A) (h0' : z_iso (H a0') b') : Y f. Proof. set (hfh := h0 · f · inv_from_z_iso h0'). set (l0 := fH^-1 hfh). set (g0 := inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0'). exists g0. apply Y_inhab_proof. Defined. (** Any inhabitant of [Y b b' f] is equal to the center. *) Lemma Y_contr_eq (b b' : B) (f : b --> b') (a0 : A) (h0 : z_iso (H a0) b) (a0' : A) (h0' : z_iso (H a0') b') : ∏ t : Y f, t = Y_inhab b b' f a0 h0 a0' h0'. Proof. intro t. apply pathsinv0. assert (Hpr : pr1 (Y_inhab b b' f a0 h0 a0' h0') = pr1 t). destruct t as [g1 r1]; simpl in *. rewrite <- assoc. apply z_iso_inv_on_right. set (hfh := h0 · f · inv_from_z_iso h0'). set (l0 := fH^-1 hfh). apply (r1 a0 h0 a0' h0' l0). unfold l0. inv_functor fH a0 a0' . unfold hfh. repeat rewrite <- assoc. rewrite z_iso_after_z_iso_inv, id_right. apply idpath. apply (total2_paths_f Hpr). apply proofirrelevance. repeat (apply impred; intro). apply C. Qed. (** The type [Y b b' f] is contractible. *) Definition Y_iscontr (b b' : B) (f : b --> b') : iscontr (Y f). Proof. assert (HH : isaprop (iscontr (Y f))). apply isapropiscontr. apply (p b (tpair (λ x, isaprop x) (iscontr (Y f)) HH)). intros [a0 h0]. apply (p b' (tpair (λ x, isaprop x) (iscontr (Y f)) HH)). intros [a0' h0']. exists (Y_inhab b b' f a0 h0 a0' h0'). apply Y_contr_eq. Defined. (** *** [G] on morphisms *) (** We now have the data necessary to define the functor [G]. *) Definition preimage_functor_data : functor_data B C. Proof. exists Go. intros b b' f. exact (pr1 (pr1 (Y_iscontr b b' f))). Defined. Local Notation "'G' f" := (pr1 (pr1 (Y_iscontr _ _ f))) (at level 3). (** The above data is indeed functorial. *) Lemma is_functor_preimage_functor_data : is_functor preimage_functor_data. Proof. split. - unfold functor_idax. simpl. intro b. assert (PR2 : ∏ (a : A) (h : z_iso (H a) b) (a' : A) (h' : z_iso (H a') b) (l : a --> a'), #H l· h' = h· identity b -> #F l· k b a' h' = k b a h· identity (Go b)). { intros a h a' h' l LL. rewrite id_right. apply (q b (tpair _ a h) (tpair _ a' h') l). rewrite id_right in LL. apply LL. } set (Gbrtilde := tpair _ (identity (Go b)) PR2 : Y (identity b)). set (H' := pr2 (Y_iscontr b b (identity b)) Gbrtilde). set (H'' := base_paths _ _ H'). simpl in H'. rewrite <- H'. apply idpath. - (** composition *) intros b b' b'' f f'. assert (HHHH : isaprop (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f')))). { apply C. } apply (p b (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0 h0]; simpl. apply (p b' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0' h0']; simpl. apply (p b'' (tpair (λ x, isaprop x) (pr1 (pr1 (Y_iscontr b b'' (f· f'))) = pr1 (pr1 (Y_iscontr b b' f))· pr1 (pr1 (Y_iscontr b' b'' f'))) HHHH)). intros [a0'' h0'']. simpl; clear HHHH. set (l0 := fH^-1 (h0 · f · inv_from_z_iso h0')). set (l0' := fH^-1 (h0' · f' · inv_from_z_iso h0'')). set (l0'' := fH^-1 (h0 · (f· f') · inv_from_z_iso h0'')). assert (L : l0 · l0' = l0''). { apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a0'')). simpl; rewrite functor_comp. unfold l0'. inv_functor fH a0' a0''. unfold l0. inv_functor fH a0 a0'. intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · f' · inv_from_z_iso h0''). { repeat rewrite assoc; apply idpath. } rewrite z_iso_after_z_iso_inv, id_right. unfold l0''. inv_functor fH a0 a0''. repeat rewrite assoc; apply idpath. } assert (PR2 : ∏ (a : A) (h : z_iso (H a) b)(a' : A) (h' : z_iso (H a') b') (l : a --> a'), #H l· h' = h· f -> #F l· k b' a' h' = k b a h· ((inv_from_z_iso (k b a0 h0)· #F l0)· k b' a0' h0') ). { intros a h a' h' l. intro alpha. set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))). set (m' := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))). assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) = k b a0 h0). { apply z_iso_eq; simpl. apply (q b (tpair _ a0 h0) (tpair _ a h) m). simpl. inv_functor fH a0 a. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b' a' h') = k b' a0' h0'). { apply z_iso_eq; simpl. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m'); simpl. inv_functor fH a0' a'. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (sssss : #H (l0 · m') = #H (m · l)). { rewrite functor_comp. unfold m'; simpl. inv_functor fH a0' a'. unfold l0. inv_functor fH a0 a0'. intermediate_path (h0 · f · (inv_from_z_iso h0' · h0') · inv_from_z_iso h'). { repeat rewrite assoc; apply idpath. } rewrite z_iso_after_z_iso_inv, id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths. apply pathsinv0. apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply pathsinv0. apply alpha. } assert (star5 : inv_from_z_iso m · l0 = l · inv_from_z_iso m'). { apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a' )). apply pathsinv0. apply sssss. } clear sssss. set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) = inv_from_z_iso (functor_on_z_iso F m)). { apply pathsinv0. apply z_iso_inv_on_left. apply pathsinv0. apply z_iso_inv_on_right. unfold m; simpl. apply pathsinv0. apply sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. rewrite <- functor_on_inv_from_z_iso. rewrite <- functor_comp. rewrite star5, functor_comp, functor_on_inv_from_z_iso. clear star5. assert (star4 : inv_from_z_iso (functor_on_z_iso F m')· k b' a0' h0' = k b' a' h' ). { apply z_iso_inv_on_right. set (ssss' := base_paths _ _ ssss). apply pathsinv0. simpl in ssss'. simpl. apply ssss'; clear ssss'. } rewrite <- assoc. rewrite star4. apply idpath. } assert (HGf : G f = inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0'). { set (Gbrtilde := tpair _ (inv_from_z_iso (k b a0 h0) · #F l0 · k b' a0' h0') PR2 : Y f). set (H' := pr2 (Y_iscontr b b' f) Gbrtilde). set (H'' := base_paths _ _ H'). simpl in H'. rewrite <- H'. apply idpath. } clear PR2. assert (PR2 : ∏ (a : A) (h : z_iso (H a) b') (a' : A) (h' : z_iso (H a') b'') (l : a --> a'), #H l· h' = h· f' -> #F l· k b'' a' h' = k b' a h· ((inv_from_z_iso (k b' a0' h0')· #F l0')· k b'' a0'' h0'')). { intros a' h' a'' h'' l'. intro alpha. set (m := fH^-i (z_iso_comp h0' (z_iso_inv_from_z_iso h'))). set (m' := fH^-i (z_iso_comp h0'' (z_iso_inv_from_z_iso h''))). assert (sss : z_iso_comp (functor_on_z_iso F m) (k b' a' h') = k b' a0' h0'). { apply z_iso_eq; simpl. apply (q b' (tpair _ a0' h0') (tpair _ a' h') m); simpl. inv_functor fH a0' a'. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b'' a'' h'') = k b'' a0'' h0''). { apply z_iso_eq; simpl. apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m'); simpl. inv_functor fH a0'' a''. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (sssss : #H (l0' · m') = #H (m · l')). { rewrite functor_comp. unfold m'. simpl. inv_functor fH a0'' a''. unfold l0'. inv_functor fH a0' a0''. intermediate_path (h0' · f' · (inv_from_z_iso h0'' · h0'') · inv_from_z_iso h''). { repeat rewrite assoc; apply idpath. } rewrite z_iso_after_z_iso_inv, id_right, functor_comp. inv_functor fH a0' a'. repeat rewrite <- assoc. apply maponpaths, pathsinv0, z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left, pathsinv0, alpha. } assert (star5 : inv_from_z_iso m · l0' = l' · inv_from_z_iso m'). { apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left, (invmaponpathsweq (weq_from_fully_faithful fH a0' a'' )), pathsinv0, sssss. } set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b' a' h' · inv_from_z_iso (k b' a0' h0') = inv_from_z_iso (functor_on_z_iso F m)). { apply pathsinv0, z_iso_inv_on_left, pathsinv0, z_iso_inv_on_right. unfold m; simpl; apply pathsinv0, sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. rewrite <- functor_on_inv_from_z_iso. rewrite <- functor_comp. rewrite star5. clear star5 sssss. rewrite functor_comp, functor_on_inv_from_z_iso. assert (star4 : inv_from_z_iso (functor_on_z_iso F m')· k b'' a0'' h0'' = k b'' a'' h'' ). { apply z_iso_inv_on_right. set (ssss' := base_paths _ _ ssss). apply pathsinv0. simpl in *; apply ssss'. } rewrite <- assoc. rewrite star4. apply idpath. } assert (HGf' : G f' = inv_from_z_iso (k b' a0' h0') · #F l0' · k b'' a0'' h0''). { set (Gbrtilde := tpair _ (inv_from_z_iso (k b' a0' h0') · #F l0' · k b'' a0'' h0'') PR2 : Y f'). set (H' := pr2 (Y_iscontr b' b'' f') Gbrtilde). rewrite <- (base_paths _ _ H'). apply idpath. } clear PR2. assert (PR2 : ∏ (a : A) (h : z_iso (H a) b) (a' : A) (h' : z_iso (H a') b'') (l : a --> a'), #H l· h' = h· (f· f') -> #F l· k b'' a' h' = k b a h· ((inv_from_z_iso (k b a0 h0)· #F l0'')· k b'' a0'' h0'')). { intros a h a'' h'' l. intro alpha. set (m := fH^-i (z_iso_comp h0 (z_iso_inv_from_z_iso h))). set (m' := fH^-i (z_iso_comp h0'' (z_iso_inv_from_z_iso h''))). assert (sss : z_iso_comp (functor_on_z_iso F m) (k b a h) = k b a0 h0). { apply z_iso_eq. apply (q b (tpair _ a0 h0) (tpair _ a h) m); simpl. inv_functor fH a0 a. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (ssss : z_iso_comp (functor_on_z_iso F m') (k b'' a'' h'') = k b'' a0'' h0''). { apply z_iso_eq. apply (q b'' (tpair _ a0'' h0'') (tpair _ a'' h'') m'). simpl; inv_functor fH a0'' a''. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply id_right. } assert (sssss : #H (l0'' · m') = #H (m · l)). { rewrite functor_comp. unfold m'. simpl. inv_functor fH a0'' a''. unfold l0''. inv_functor fH a0 a0''. intermediate_path (h0 · (f · f') · (inv_from_z_iso h0'' · h0'') · inv_from_z_iso h''). { repeat rewrite assoc; apply idpath. } rewrite z_iso_after_z_iso_inv, id_right, functor_comp. inv_functor fH a0 a. repeat rewrite <- assoc. apply maponpaths, pathsinv0, z_iso_inv_on_right. repeat rewrite assoc. apply z_iso_inv_on_left, pathsinv0. repeat rewrite <- assoc. apply alpha. } assert (star5 : inv_from_z_iso m · l0'' = l · inv_from_z_iso m'). { apply z_iso_inv_on_right. rewrite assoc. apply z_iso_inv_on_left. apply (invmaponpathsweq (weq_from_fully_faithful fH a0 a'' )). apply pathsinv0, sssss. } set (sss':= base_paths _ _ sss); simpl in sss'. assert (sss'' : k b a h · inv_from_z_iso (k b a0 h0) = inv_from_z_iso (functor_on_z_iso F m)). { apply pathsinv0, z_iso_inv_on_left, pathsinv0, z_iso_inv_on_right. unfold m; simpl. apply pathsinv0, sss'. } repeat rewrite assoc. rewrite sss''. clear sss'' sss' sss. rewrite <- functor_on_inv_from_z_iso. rewrite <- functor_comp. rewrite star5. clear star5 sssss. rewrite functor_comp, functor_on_inv_from_z_iso. assert (star4 : inv_from_z_iso (functor_on_z_iso F m')· k b'' a0'' h0'' = k b'' a'' h'' ). { apply z_iso_inv_on_right, pathsinv0, (base_paths _ _ ssss). } rewrite <- assoc. rewrite star4. apply idpath. } assert (HGff' : G (f · f') = inv_from_z_iso (k b a0 h0) · #F l0'' · k b'' a0'' h0''). { set (Gbrtilde := tpair _ (inv_from_z_iso (k b a0 h0) · #F l0'' · k b'' a0'' h0'') PR2 : Y (f · f')). rewrite <- (pr2 (Y_iscontr b b'' (f · f')) Gbrtilde). apply idpath. } clear PR2. rewrite HGf, HGf'. intermediate_path (inv_from_z_iso (k b a0 h0)· #F l0· (k b' a0' h0'· inv_from_z_iso (k b' a0' h0'))· #F l0'· k b'' a0'' h0''). { rewrite z_iso_inv_after_z_iso, id_right. rewrite HGff'. repeat rewrite <- assoc. apply maponpaths. rewrite <- L. rewrite functor_comp. repeat rewrite <- assoc. apply idpath. } repeat rewrite <- assoc. apply idpath. Qed. (** We call the functor [GG] ... *) Definition GG : [B, C, C] := tpair _ preimage_functor_data is_functor_preimage_functor_data. (** ** [G] is the preimage of [F] under [ _ O H] *) (** Given any [a : A], we produce an element in [X (H a)], whose first component is [F a]. This allows to prove [G (H a) = F a]. *) Lemma qF (a0 : A) : ∏ (t t' : total2 (λ a : A, z_iso (H a) (H a0))) (f : pr1 t --> pr1 t'), #H f· pr2 t' = pr2 t -> #F f· #F (fH^-1 (pr2 t')) = #F (fH^-1 (pr2 t)). Proof. simpl. intros [a h] [a' h'] f L. simpl in L; simpl. rewrite <- functor_comp. apply maponpaths. apply (invmaponpathsweq (weq_from_fully_faithful fH a a0) (f· fH^-1 h') (fH^-1 h) ). inv_functor fH a a0. rewrite functor_comp. inv_functor fH a' a0. apply L. Qed. Definition kFa (a0 : A) : ∏ a : A, z_iso (H a) (H a0) -> z_iso (F a) (F a0) := fun (a : A) (h : z_iso (H a) (H a0)) => functor_on_z_iso F (iso_from_fully_faithful_reflection fH h). Definition XtripleF (a0 : A) : X (H a0) := tpair _ (tpair _ (F a0) (kFa a0)) (qF a0). Lemma phi (a0 : A) : pr1 (pr1 (functor_composite H GG)) a0 = pr1 (pr1 F) a0. Proof. exact (!Xphi _ (XtripleF a0)). Defined. Lemma extphi : pr1 (pr1 (functor_composite H GG)) = pr1 (pr1 F). Proof. apply funextsec. unfold homot. apply phi. Defined. (** Now for the functor as a whole. It remains to prove equality on morphisms, modulo transport. *) Lemma is_preimage_for_pre_composition : functor_composite H GG = F. Proof. apply (functor_eq _ _ C (functor_composite H GG) F). apply (total2_paths_f extphi). apply funextsec; intro a0; apply funextsec; intro a0'; apply funextsec; intro f. rewrite transport_of_functor_map_is_pointwise. unfold extphi. unfold double_transport. rewrite toforallpaths_funextsec. rewrite <- idtoiso_postcompose. rewrite <- idtoiso_precompose. rewrite idtoiso_inv. rewrite <- assoc. assert (PSIf : ∏ (a : A) (h : z_iso (H a) (H a0)) (a' : A) (h' : z_iso (H a') (H a0')) (l : a --> a'), #H l· h' = h· #H f -> #F l· k (H a0') a' h' = k (H a0) a h· ((idtoiso (phi a0)· #F f)· inv_from_z_iso (idtoiso (phi a0')))). { intros a h a' h' l alpha. rewrite assoc. apply z_iso_inv_on_left. unfold phi. repeat rewrite assoc. rewrite (Xkphi_idtoiso (H a0) (XtripleF a0)). repeat rewrite <- assoc. rewrite (Xkphi_idtoiso (H a0') (XtripleF a0')). simpl. assert (HH4 : fH^-1 h · f = l · fH^-1 h'). { apply (invmaponpathsweq (weq_from_fully_faithful fH a a0')). simpl; repeat rewrite functor_comp. inv_functor fH a a0. inv_functor fH a' a0'. apply pathsinv0, alpha. } intermediate_path (#F (fH^-1 h· f)). { rewrite functor_comp. apply idpath. } rewrite HH4. rewrite functor_comp. apply idpath. } set (Ybla := tpair _ (idtoiso (phi a0) · #F f · inv_from_z_iso (idtoiso (phi a0'))) PSIf : Y (#H f)). set (Ycontr := pr2 (Y_iscontr _ _ (#(pr1 H) f)) Ybla). set (Ycontr2 := base_paths _ _ Ycontr); simpl in *. change (G (#H f)) with (G (#(pr1 H) f)). rewrite <- Ycontr2. repeat rewrite assoc. rewrite z_iso_after_z_iso_inv, id_left. repeat rewrite <- assoc. rewrite z_iso_after_z_iso_inv, id_right. apply idpath. Qed. End preimage. End essentially_surjective. (** * Precomposition with an ess. surj. and f. f. functor is ess. surj. *) (** Abstracting from [F] by closing the previous section, we can prove essential surjectivity of [_ O H]. *) Lemma pre_composition_essentially_surjective : essentially_surjective (pre_composition_functor A B C H). Proof. intros F p' f. apply f. exists (GG F). apply idtoiso. apply is_preimage_for_pre_composition. Qed. End precomp_w_ess_surj_ff_is_ess_surj. UniMath-20231010/UniMath/CategoryTheory/precomp_fully_faithful.v000066400000000000000000000151001451125700300245520ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 ************************************************************) (** ********************************************************** Contents : Precomposition with a full and essentially surjective functor yields a full and faithful, i.e. a fully faithful, functor ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Ltac simp_rew lem := let H:=fresh in assert (H:= lem); simpl in *; rewrite H; clear H. Ltac simp_rerew lem := let H:=fresh in assert (H:= lem); simpl in *; rewrite <- H; clear H. Local Notation "G 'O' F" := (functor_compose _ _ _ F G : functor _ _ ) (at level 25). Section pre_composition. (** Section variables *) Variables A B C : category. Variable H : functor A B. (** * Precomposition with an essentially surjective functor is faithful. *) Lemma pre_composition_with_ess_surj_is_faithful (p : essentially_surjective H) : faithful (pre_composition_functor A B C H). Proof. intros F G. apply isinclbetweensets. - apply isaset_nat_trans. apply C. - apply isaset_nat_trans. apply C. - simpl in *. intros gamma delta ex. apply nat_trans_eq. + apply C. + intro b. apply (p b (make_hProp _ (homset_property C _ _ _ _))). intro t; induction t as [a f]; simpl. apply (pre_comp_with_z_iso_is_inj (pr2(pr2(functor_on_z_iso _ f)))). cbn. do 2 rewrite nat_trans_ax. apply cancel_postcomposition. apply (nat_trans_eq_pointwise ex a). Defined. (** * Precomposition with an essentially surjective and full functor is full *) Section precomp_with_ess_surj_full_functor_is_full. Hypothesis p : essentially_surjective H. Hypothesis Hf : full H. (** We prove that [_ O H] yields a full functor. *) Section full. Variables F G : functor B C. (** We have to show that for [F] and [G], the map [(_ O H) (F,G) : (F --> G) -> (F O H --> G O H)] is surjective. *) (** Fixing a [gamma], we produce its preimage. *) Variable gamma : nat_trans (functor_composite H F) (functor_composite H G). Lemma iscontr_aux_space (b : B) : iscontr (total2 (fun g : F b --> G b => ∏ a : A, ∏ f : z_iso (H a) b, g = functor_on_z_iso F (z_iso_inv_from_z_iso f) · gamma a · #G f)). Proof. apply (p b (make_hProp _ (isapropiscontr _))). intro t; induction t as [anot h]; simpl. set (g := functor_on_z_iso F (z_iso_inv_from_z_iso h) · gamma anot · #G h). assert (gp : ∏ (a : A) (f : z_iso (H a) b), g = #F (inv_from_z_iso f) · gamma a · #G f). - intros a f. apply (Hf _ _ (h · inv_from_z_iso f) (make_hProp _ (homset_property C _ _ _ _))). intro sur. simpl. unfold g. rewrite functor_on_z_iso_inv; simpl. rewrite <- assoc. apply z_iso_inv_on_right. rewrite 2 assoc. simpl. rewrite <- functor_comp. rewrite <- (pr2 sur). simp_rew (nat_trans_ax gamma). rewrite (pr2 sur). rewrite <- assoc. apply cancel_precomposition. rewrite <- functor_comp. apply maponpaths. rewrite <- assoc. rewrite z_iso_after_z_iso_inv. apply pathsinv0, id_right. - exists (g,, gp). intro t; induction t as [g' gp']. apply subtypePath. { intro; do 2 (apply impred; intro). apply C. } simpl. rewrite (gp anot h). rewrite (gp' anot h). apply idpath. Defined. Definition pdelta : ∏ b : B, F b --> G b := λ b, pr1 (pr1 (iscontr_aux_space b)). Lemma is_nat_trans_pdelta : is_nat_trans F G pdelta. Proof. intros b b' f. apply (p b (make_hProp _ (homset_property C _ _ _ _) )). intro t; induction t as [a h]; simpl. apply (p b' (make_hProp _ (homset_property C _ _ _ _) )). intro t; induction t as [a' h']; simpl. unfold pdelta. rewrite (pr2 ((pr1 (iscontr_aux_space b))) a h). rewrite (pr2 ((pr1 (iscontr_aux_space b'))) a' h'). rewrite <- 3 assoc. apply pathsinv0. rewrite functor_on_z_iso_inv. apply z_iso_inv_on_right. rewrite 4 assoc. simpl. rewrite <- 2 functor_comp. apply (Hf _ _ (h · f · (inv_from_z_iso h')) (make_hProp _ (homset_property C _ _ _ _))). intro sur. simpl. rewrite <- (pr2 sur). simp_rew (nat_trans_ax gamma). rewrite (pr2 sur). rewrite <- 3 assoc. rewrite <- 2 functor_comp. apply cancel_precomposition, maponpaths. rewrite <- 2 assoc. rewrite z_iso_after_z_iso_inv. rewrite id_right. apply idpath. Defined. Definition delta : nat_trans F G := (pdelta,, is_nat_trans_pdelta). Lemma pdelta_preimage : pre_whisker H delta = gamma. Proof. apply nat_trans_eq. - apply C. - intro a. intermediate_path (pr1 (pr1 (iscontr_aux_space (H a)))). + apply idpath. + rewrite (pr2 (pr1 (iscontr_aux_space (H a))) a (identity_z_iso _)). rewrite z_iso_inv_of_z_iso_id. simpl. rewrite 2 functor_id. rewrite id_right. apply id_left. Defined. End full. (** * Precomposition with an essentially surjective and full functor is fully faithful *) Lemma pre_composition_with_ess_surj_and_full_is_full : full (pre_composition_functor A B C H). Proof. intros F G gamma. apply hinhpr. exists (delta F G gamma). apply pdelta_preimage. Defined. Lemma pre_composition_with_ess_surj_and_full_is_full_and_faithful : full_and_faithful (pre_composition_functor A B C H). Proof. split. apply pre_composition_with_ess_surj_and_full_is_full. apply pre_composition_with_ess_surj_is_faithful. assumption. Defined. Lemma pre_composition_with_ess_surj_and_full_is_fully_faithful : fully_faithful (pre_composition_functor A B C H). Proof. apply full_and_faithful_implies_fully_faithful. apply pre_composition_with_ess_surj_and_full_is_full_and_faithful. Defined. End precomp_with_ess_surj_full_functor_is_full. Lemma pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful (p : essentially_surjective H) (Hff : fully_faithful H): fully_faithful (pre_composition_functor A B C H). Proof. apply pre_composition_with_ess_surj_and_full_is_fully_faithful. - exact p. - apply fully_faithful_implies_full_and_faithful. exact Hff. Defined. End pre_composition. UniMath-20231010/UniMath/CategoryTheory/rezk_completion.v000066400000000000000000000154351451125700300232270ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 ************************************************************) (** ********************************************************** Contents : Rezk completion - Construction of the Rezk completion via Yoneda - Universal property of the Rezk completion ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.Subcategory.Core. Require Import UniMath.CategoryTheory.Subcategory.Full. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.precomp_fully_faithful. Require Import UniMath.CategoryTheory.precomp_ess_surj. (** * Construction of the Rezk completion via Yoneda *) Section rezk. Context (A : category). Definition category_Rezk_completion : category. Proof. exists (full_img_sub_precategory (yoneda A)). exact (has_homsets_full_img_sub_precategory (yoneda A)). Defined. Definition Rezk_completion : univalent_category. Proof. exists category_Rezk_completion. apply is_univalent_full_sub_category. apply (is_univalent_functor_category _ _ is_univalent_HSET). Defined. Definition Rezk_eta : functor A Rezk_completion. Proof. apply (functor_full_img (yoneda A)). Defined. Lemma Rezk_eta_fully_faithful : fully_faithful Rezk_eta. Proof. apply (functor_full_img_fully_faithful_if_fun_is _ _ (yoneda A)). apply yoneda_fully_faithful. Defined. Lemma Rezk_eta_essentially_surjective : essentially_surjective Rezk_eta. Proof. apply (functor_full_img_essentially_surjective _ _ (yoneda A)). Defined. End rezk. (** * Universal property of the Rezk completion *) Definition functor_from (C : precategory) : UU := ∑ D : univalent_category, functor C D. Coercion target_category (C : precategory) (X : functor_from C) : univalent_category := pr1 X. Definition func_functor_from {C : precategory} (X : functor_from C) : functor C X := pr2 X. Definition is_initial_functor_from (C : precategory) (X : functor_from C) : UU := ∏ X' : functor_from C, ∃! H : functor X X', functor_composite (func_functor_from X) H = func_functor_from X'. Section rezk_universal_property. Context (A : category). Section fix_a_category. Context (C : category) (Ccat : is_univalent C). Lemma pre_comp_rezk_eta_is_fully_faithful : fully_faithful (pre_composition_functor _ _ C (Rezk_eta A)). Proof. apply pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful. - apply Rezk_eta_essentially_surjective. - apply Rezk_eta_fully_faithful. Defined. Lemma pre_comp_rezk_eta_is_ess_surj : essentially_surjective (pre_composition_functor _ _ C (Rezk_eta A)). Proof. apply pre_composition_essentially_surjective. - apply Ccat. - apply Rezk_eta_essentially_surjective. - apply Rezk_eta_fully_faithful. Defined. Definition Rezk_adj_equiv : adj_equivalence_of_cats (pre_composition_functor _ _ C (Rezk_eta A)). Proof. apply (@rad_equivalence_of_cats (functor_category (Rezk_completion A) C) (functor_category A C) (is_univalent_functor_category _ _ Ccat ) _ (pre_comp_rezk_eta_is_fully_faithful) (pre_comp_rezk_eta_is_ess_surj)). Defined. Theorem Rezk_eta_Universal_Property : isweq (pre_composition_functor _ _ C (Rezk_eta A)). Proof. apply adj_equiv_of_cats_is_weq_of_objects. - apply is_univalent_functor_category; assumption. - apply is_univalent_functor_category; assumption. - apply Rezk_adj_equiv. Defined. Definition Rezk_weq : [Rezk_completion A, C] ≃ [A, C ] := make_weq _ Rezk_eta_Universal_Property. End fix_a_category. Lemma Rezk_initial_functor_from : is_initial_functor_from A (tpair _ (Rezk_completion A) (Rezk_eta A)). Proof. intro D. destruct D as [D F]. set (T:= Rezk_eta_Universal_Property D (pr2 D)). apply T. Defined. Definition Rezk_completion_endo_is_identity (D : functor_from A) (DH : is_initial_functor_from A D) : ∏ X : functor D D, functor_composite (func_functor_from D) X = func_functor_from D -> X = functor_identity D. Proof. intros X H. set (DH' := DH D). intermediate_path (pr1 (pr1 DH')). - apply path_to_ctr. apply H. - apply pathsinv0. apply path_to_ctr. apply functor_identity_right. Defined. End rezk_universal_property. Section opp_rezk_universal_property. Context (A : category). Section fix_a_category. Context (C : category) (Ccat : is_univalent C). Lemma pre_comp_rezk_eta_opp_is_fully_faithful : fully_faithful (pre_composition_functor A^op (Rezk_completion A)^op C (functor_opp (Rezk_eta A))). Proof. apply pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful. - apply opp_functor_essentially_surjective. apply Rezk_eta_essentially_surjective. - apply opp_functor_fully_faithful. apply Rezk_eta_fully_faithful. Defined. Lemma pre_comp_rezk_eta_opp_is_ess_surj : essentially_surjective (pre_composition_functor A^op (Rezk_completion A)^op C (functor_opp (Rezk_eta A))). Proof. apply pre_composition_essentially_surjective. - apply Ccat. - apply opp_functor_essentially_surjective. apply Rezk_eta_essentially_surjective. - apply opp_functor_fully_faithful. apply Rezk_eta_fully_faithful. Defined. Definition Rezk_op_adj_equiv : adj_equivalence_of_cats (pre_composition_functor A^op (Rezk_completion A)^op C (functor_opp (Rezk_eta A))). Proof. apply (@rad_equivalence_of_cats [(Rezk_completion A)^op, C] [A^op, C] (is_univalent_functor_category _ _ Ccat ) _ (pre_comp_rezk_eta_opp_is_fully_faithful) (pre_comp_rezk_eta_opp_is_ess_surj)). Defined. Theorem Rezk_eta_opp_Universal_Property : isweq (pre_composition_functor A^op (Rezk_completion A)^op C (functor_opp (Rezk_eta A))). Proof. apply adj_equiv_of_cats_is_weq_of_objects. - apply is_univalent_functor_category; assumption. - apply is_univalent_functor_category; assumption. - apply Rezk_op_adj_equiv. Defined. Definition Rezk_opp_weq : [(Rezk_completion A)^op, C] ≃ [A^op, C] := make_weq _ Rezk_eta_opp_Universal_Property. End fix_a_category. End opp_rezk_universal_property. UniMath-20231010/UniMath/CategoryTheory/slicecat.v000066400000000000000000001043221451125700300216040ustar00rootroot00000000000000(** ********************************************************** Anders Mörtberg, Benedikt Ahrens, 2015-2016 *************************************************************) (** ********************************************************** Contents: - Definition of slice precategories, C/x (assumes that C has homsets) - Isos in slice categories - Monics in slice categories - Epis in slice categories - Proof that the forgetful functor [slicecat_to_cat] : C/x → C is a left adjoint if C has binary products ([is_left_adjoint_slicecat_to_cat]) - Proof that C/x is a univalent_category if C is - Proof that any morphism C[x,y] induces a functor from C/x to C/y ([slicecat_functor]) - Colimits in slice categories ([slice_precat_colims]) - Binary products in slice categories of categories with pullbacks ([BinProducts_slice_precat]) - Binary coproducts in slice categories of categories with binary coproducts ([BinCoproducts_slice_precat]) - Coproducts in slice categories of categories with coproducts ([Coproducts_slice_precat]) - Initial object in slice categories with initial object ([Initial_slice_precat]) - Terminal object in slice categories ([Terminal_slice_precat]) - Base change functor ([base_change_functor]) and proof that it is right adjoint to slicecat_functor - Pullbacks ([pullback_to_slice_pullback]) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Local Open Scope cat. (** * Definition of slice categories *) (** Given a category C and x : obj C. The slice category C/x is given by: - obj C/x: pairs (a,f) where f : a -> x - morphism (a,f) -> (b,g): morphism h : a -> b with << h a - - -> b | / | / f | / g | / v x >> where h · g = f *) Section slice_precat_def. Context (C : category) (x : C). (* Accessor functions *) Definition slicecat_ob := ∑ a, C⟦a,x⟧. Definition slicecat_mor (f g : slicecat_ob) := ∑ h, pr2 f = h · pr2 g. Definition slicecat_ob_object (f : slicecat_ob) : ob C := pr1 f. Definition slicecat_ob_morphism (f : slicecat_ob) : C⟦slicecat_ob_object f, x⟧ := pr2 f. (* Accessor functions *) Definition slicecat_mor_morphism {f g : slicecat_ob} (h : slicecat_mor f g) : C⟦slicecat_ob_object f, slicecat_ob_object g⟧ := pr1 h. Definition slicecat_mor_comm {f g : slicecat_ob} (h : slicecat_mor f g) : (slicecat_ob_morphism f) = (slicecat_mor_morphism h) · (slicecat_ob_morphism g) := pr2 h. Definition slice_precat_ob_mor : precategory_ob_mor := (slicecat_ob,,slicecat_mor). Definition id_slice_precat (c : slice_precat_ob_mor) : c --> c := tpair _ _ (!(id_left (pr2 c))). Definition comp_slice_precat_subproof {a b c : slice_precat_ob_mor} (f : a --> b) (g : b --> c) : pr2 a = (pr1 f · pr1 g) · pr2 c. Proof. rewrite <- assoc, (!(pr2 g)). exact (pr2 f). Qed. Definition comp_slice_precat (a b c : slice_precat_ob_mor) (f : a --> b) (g : b --> c) : a --> c := (pr1 f · pr1 g,,comp_slice_precat_subproof _ _). Definition slice_precat_data : precategory_data := make_precategory_data _ id_slice_precat comp_slice_precat. Lemma is_precategory_slice_precat_data : is_precategory slice_precat_data. Proof. repeat split; simpl. * intros a b f. induction f as [h hP]. apply subtypePairEquality; [ intro; apply C | apply id_left ]. * intros a b f. induction f as [h hP]. apply subtypePairEquality; [ intro; apply C | apply id_right ]. * intros a b c d f g h. apply subtypePairEquality; [ intro; apply C | apply assoc ]. * intros a b c d f g h. apply subtypePairEquality; [ intro; apply C | apply assoc' ]. Qed. Definition slice_precat : precategory := (_,,is_precategory_slice_precat_data). Lemma has_homsets_slice_precat : has_homsets (slice_precat). Proof. intros a b. induction a as [a f]; induction b as [b g]; simpl. apply (isofhleveltotal2 2); [ apply C | intro h]. apply isasetaprop; apply C. Qed. Definition slice_cat : category := make_category _ has_homsets_slice_precat. End slice_precat_def. Section slice_precat_theory. Context (C : category) (x : C). Local Notation "C / X" := (slice_cat C X). Lemma eq_mor_slicecat (af bg : C / x) (f g : C/x⟦af,bg⟧) : pr1 f = pr1 g -> f = g. Proof. intro heq; apply (total2_paths_f heq); apply C. Qed. Lemma eq_mor_slicecat_isweq (af bg : C / x) (f g : C/x⟦af,bg⟧) : isweq (eq_mor_slicecat af bg f g). Proof. apply isweqimplimpl. - apply maponpaths. - apply C. - apply has_homsets_slice_precat. Qed. Definition eq_mor_slicecat_weq (af bg : C / x) (f g : C/x⟦af,bg⟧) : (pr1 f = pr1 g ≃ f = g) := make_weq _ (eq_mor_slicecat_isweq af bg f g). (** ** Isos in slice categories *) Lemma eq_z_iso_slicecat (af bg : C / x) (f g : z_iso af bg) : pr1 f = pr1 g -> f = g. Proof. induction f as [f fP]; induction g as [g gP]; intro eq. use (subtypePairEquality _ eq). intro; apply isaprop_is_z_isomorphism. Qed. (** It suffices that the underlying morphism is an iso to get an iso in the slice category *) Lemma z_iso_to_slice_precat_z_iso (af bg : C / x) (h : af --> bg) (isoh : is_z_isomorphism (pr1 h)) : is_z_isomorphism h. Proof. induction isoh as [hinv [h1 h2]]. assert (pinv : hinv · pr2 af = pr2 bg). { rewrite <- id_left, <- h2, <- assoc, (!(pr2 h)); apply idpath. } exists (hinv,,!pinv). split; (apply subtypePairEquality; [ intro; apply C |]); assumption. Defined. (** An iso in the slice category gives an iso in the base category *) Lemma slice_precat_z_iso_to_z_iso (af bg : C / x) (h : af --> bg) (p : is_z_isomorphism h) : is_z_isomorphism (pr1 h). Proof. induction p as [hinv [h1 h2]]. exists (pr1 hinv); split. - apply (maponpaths pr1 h1). - apply (maponpaths pr1 h2). Defined. Lemma weq_z_iso (af bg : C / x) : z_iso af bg ≃ ∑ h : z_iso (pr1 af) (pr1 bg), pr2 af = h · pr2 bg. Proof. apply (weqcomp (weqtotal2asstor _ _)). apply invweq. apply (weqcomp (weqtotal2asstor _ _)). apply weqfibtototal; intro h; simpl. apply (weqcomp (weqdirprodcomm _ _)). apply weqfibtototal; intro p. apply weqimplimpl. - intro hp; apply z_iso_to_slice_precat_z_iso; assumption. - intro hp; apply (slice_precat_z_iso_to_z_iso _ _ _ hp). - apply isaprop_is_z_isomorphism. - apply (isaprop_is_z_isomorphism(C:= C / x)). Defined. (** ** Monics in slice categories *) (** It suffices that the underlying morphism is an monic to get an monic in the slice category *) Lemma monic_to_slice_precat_monic (a b : C / x) (h : a --> b) (monich : isMonic (pr1 h)) : isMonic h. Proof. intros y f g eq. apply eq_mor_slicecat, monich. change (pr1 f · pr1 h) with (pr1 (f · h)); change (pr1 g · pr1 h) with (pr1 (g · h)). apply (maponpaths pr1). assumption. Qed. (** ** Epis in slice categories *) (** It suffices that the underlying morphism is an epic to get an epic in the slice category *) Lemma epic_to_slice_precat_epic (a b : C / x) (h : a --> b) (epich : isEpi (pr1 h)) : isEpi h. Proof. unfold isEpi in *. intros y f g eq. apply eq_mor_slicecat, epich. change (pr1 h · pr1 f) with (pr1 (h · f)); change (pr1 h · pr1 g) with (pr1 (h · g)). apply (maponpaths pr1). assumption. Qed. (** The forgetful functor from C/x to C *) Definition slicecat_to_cat : (C / x) ⟶ C. Proof. use make_functor. + use tpair. - apply pr1. - intros a b; apply pr1. + abstract ( split; [intro; apply idpath | red; intros; apply idpath] ). Defined. (** Right adjoint to slicecat_to_cat *) Definition cat_to_slicecat_data (BPC : BinProducts C) : functor_data C (C / x). Proof. use make_functor_data. * intro y. exists (BinProductObject _ (BPC x y)). apply BinProductPr1. * intros A B f; cbn. use tpair. - apply (BinProductOfArrows _ _ _ (identity x) f). - abstract (cbn; rewrite BinProductOfArrowsPr1, id_right; apply idpath). Defined. Lemma is_functor_cat_to_slicecat_data (BPC : BinProducts C) : is_functor (cat_to_slicecat_data BPC). Proof. split. * intros A; apply eq_mor_slicecat; apply pathsinv0, BinProductArrowUnique; rewrite id_left, id_right; apply idpath. * intros a1 a2 a3 f1 f2; apply eq_mor_slicecat; simpl; rewrite BinProductOfArrows_comp, id_right; apply idpath. Qed. Definition cat_to_slicecat (BPC : BinProducts C) : C ⟶ (C / x). Proof. use make_functor. + exact (cat_to_slicecat_data BPC). + apply is_functor_cat_to_slicecat_data. Defined. Lemma is_left_adjoint_slicecat_to_cat (BPC : BinProducts C) : is_left_adjoint slicecat_to_cat. Proof. exists (cat_to_slicecat BPC). use make_are_adjoints. + use make_nat_trans. * simpl; intros F. exists (BinProductArrow _ _ (pr2 F) (identity _)); simpl. abstract (rewrite BinProductPr1Commutes; apply idpath). * intros Y Z F; apply eq_mor_slicecat; simpl. rewrite postcompWithBinProductArrow. apply BinProductArrowUnique. - rewrite <- assoc, BinProductPr1Commutes, id_right, (pr2 F); apply idpath. - rewrite <- assoc, BinProductPr2Commutes, id_left, id_right; apply idpath. + use make_nat_trans. * intros Y. apply BinProductPr2. * abstract ( intros Y Z f; apply BinProductOfArrowsPr2 ). + split. * intros Y; cbn. rewrite BinProductPr2Commutes; apply idpath. * intros Y; apply eq_mor_slicecat; cbn. rewrite postcompWithBinProductArrow. apply pathsinv0, BinProductArrowUnique; trivial. rewrite id_right, id_left; apply idpath. Defined. (* it would be better if the preceding def. had much larger opaque parts *) End slice_precat_theory. (** * Proof that C/x is a univalent_category if C is. *) (** This is exercise 9.1 in the HoTT book *) Section slicecat_theory. Context {C : category} (is_catC : is_univalent C) (x : C). Local Notation "C / x" := (slice_cat C x). Lemma id_weq_z_iso_slicecat (af bg : C / x) : (af = bg) ≃ (z_iso af bg). Proof. set (a := pr1 af); set (f := pr2 af); set (b := pr1 bg); set (g := pr2 bg). assert (weq1 : weq (af = bg) (total2 (fun (p : a = b) => transportf _ p (pr2 af) = g))). { apply (total2_paths_equiv _ af bg). } assert (weq2 : weq (total2 (fun (p : a = b) => transportf _ p (pr2 af) = g)) (total2 (fun (p : a = b) => idtoiso (! p) · f = g))). { apply weqfibtototal; intro p. rewrite idtoiso_precompose. apply idweq. } assert (weq3 : weq (total2 (fun (p : a = b) => idtoiso (! p) · f = g)) (total2 (λ h : z_iso a b, f = h · g))). { apply (weqbandf (make_weq _ (is_catC a b))); intro p. rewrite idtoiso_inv; simpl. apply weqimplimpl; simpl; try apply (C); intro Hp. rewrite <- Hp, assoc, z_iso_inv_after_z_iso, id_left; apply idpath. rewrite Hp, assoc, z_iso_after_z_iso_inv, id_left; apply idpath. } assert (weq4 : weq (total2 (λ h : z_iso a b, f = h · g)) (z_iso af bg)). { apply invweq; apply weq_z_iso. } apply (weqcomp weq1 (weqcomp weq2 (weqcomp weq3 weq4))). Defined. Lemma is_univalent_slicecat : is_univalent (C / x). Proof. intros a b. set (h := id_weq_z_iso_slicecat a b). apply (isweqhomot h); [intro p|induction h; trivial]. induction p. apply z_iso_eq, eq_mor_slicecat, idpath. Qed. End slicecat_theory. (** * A morphism x --> y in the base category induces a functor between C/x and C/y *) Section slicecat_functor_def. Context {C : category} {x y : C} (f : C⟦x,y⟧). Local Notation "C / X" := (slice_cat C X). Definition slicecat_functor_ob (af : C / x) : C / y := (pr1 af,,pr2 af · f). Lemma slicecat_functor_subproof (af bg : C / x) (h : C/x⟦af,bg⟧) : pr2 af · f = pr1 h · (pr2 bg · f). Proof. rewrite assoc, <- (pr2 h); apply idpath. Qed. Definition slicecat_functor_data : functor_data (C / x) (C / y) := tpair (λ F, ∏ a b, C/x⟦a,b⟧ → C/y⟦F a,F b⟧) slicecat_functor_ob (λ a b h, (pr1 h,,slicecat_functor_subproof _ _ h)). Lemma is_functor_slicecat_functor : is_functor slicecat_functor_data. Proof. split. - intros a; apply eq_mor_slicecat, idpath. - intros a b c g h; apply eq_mor_slicecat, idpath. Qed. Definition slicecat_functor : functor (C / x) (C / y) := (slicecat_functor_data,,is_functor_slicecat_functor). End slicecat_functor_def. Section slicecat_functor_theory. Context (C : category). Local Notation "C / X" := (slice_precat C X). Lemma slicecat_functor_identity_ob (x : C) : slicecat_functor_ob (identity x) = functor_identity (C / x). Proof. apply funextsec; intro af. unfold slicecat_functor_ob. rewrite id_right. apply idpath. Defined. Lemma slicecat_functor_identity (x : C) : slicecat_functor (identity x) = functor_identity (C / x). Proof. apply (functor_eq _ _ (has_homsets_slice_precat _ _)); simpl. apply (two_arg_paths_f (slicecat_functor_identity_ob _)). apply funextsec; intros [a f]. apply funextsec; intros [b g]. apply funextsec; intros [h hh]. rewrite transport_of_functor_map_is_pointwise; simpl in *. unfold double_transport. unfold slicecat_mor, slice_precat_ob_mor, slicecat_mor. simpl. rewrite transportf_total2. apply subtypePairEquality; [intro; apply C | ]. rewrite transportf_total2; simpl. unfold slicecat_functor_identity_ob. rewrite toforallpaths_funextsec; simpl. induction (id_right f). induction (id_right g). apply idpath. Qed. Lemma slicecat_functor_comp_ob {x y z : C} (f : C⟦x,y⟧) (g : C⟦y,z⟧) : slicecat_functor_ob (f · g) = (λ a, slicecat_functor_ob g (slicecat_functor_ob f a)). Proof. apply funextsec; intro af. unfold slicecat_functor_ob; rewrite assoc; apply idpath. Defined. (* This proof is not so nice... *) Lemma slicecat_functor_comp {x y z : C} (f : C⟦x,y⟧) (g : C⟦y,z⟧) : slicecat_functor (f · g) = functor_composite (slicecat_functor f) (slicecat_functor g). Proof. apply (functor_eq _ _ (has_homsets_slice_precat _ _)); simpl. unfold slicecat_functor_data; simpl. unfold functor_composite_data; simpl. apply (two_arg_paths_f (slicecat_functor_comp_ob _ _)). apply funextsec; intros [a fax]. apply funextsec; intros [b fbx]. apply funextsec; intros [h hh]. rewrite transport_of_functor_map_is_pointwise; simpl in *. unfold double_transport. unfold slicecat_mor, slice_precat_ob_mor, slicecat_mor. simpl. rewrite transportf_total2. apply subtypePairEquality; [intro; apply C | ]. rewrite transportf_total2; simpl. unfold slicecat_functor_comp_ob. rewrite toforallpaths_funextsec; simpl. assert (H1 : transportf (fun x : C / z => pr1 x --> b) (Foundations.PartA.internal_paths_rew_r _ _ _ (λ p, tpair _ a p = tpair _ a _) (idpath (tpair _ a _)) (assoc fax f g)) h = h). induction (assoc fax f g); apply idpath. assert (H2 : ∏ h', h' = h -> transportf (fun x : C / z => a --> pr1 x) (Foundations.PartA.internal_paths_rew_r _ _ _ (λ p, tpair _ b p = tpair _ b _) (idpath _) (assoc fbx f g)) h' = h). intros h' eq. induction (assoc fbx f g); rewrite eq; apply idpath. apply H2. exact H1. Qed. End slicecat_functor_theory. (** * Colimits in slice categories *) Section slicecat_colimits. Context (g : graph) (C : category) (x : C). Local Notation "C / X" := (slice_cat C X). Let U : functor (C / x) C := slicecat_to_cat C x. Lemma slice_precat_isColimCocone (d : diagram g (C / x)) (a : C / x) (cc : cocone d a) (H : isColimCocone (mapdiagram U d) (U a) (mapcocone U d cc)) : isColimCocone d a cc. Proof. set (CC := make_ColimCocone _ _ _ H). intros y ccy. use unique_exists. + use tpair; simpl. * apply (colimArrow CC), (mapcocone U _ ccy). * abstract (apply pathsinv0; eapply pathscomp0; [apply (postcompWithColimArrow _ CC (pr1 y) (mapcocone U d ccy))|]; apply pathsinv0, (colimArrowUnique CC); intros u; simpl; eapply pathscomp0; [apply (!(pr2 (coconeIn cc u)))|]; apply (pr2 (coconeIn ccy u))). + abstract (intros u; apply subtypePath; [intros xx; apply C|]; simpl; apply (colimArrowCommutes CC)). + abstract (intros f; simpl; apply impred; intro u; apply has_homsets_slice_precat). + abstract (intros f; simpl; intros Hf; apply eq_mor_slicecat; simpl; apply (colimArrowUnique CC); intro u; cbn; rewrite <- (Hf u); apply idpath). Defined. Lemma slice_precat_ColimCocone (d : diagram g (C / x)) (H : ColimCocone (mapdiagram U d)) : ColimCocone d. Proof. use make_ColimCocone. - use tpair. + apply (colim H). + apply colimArrow. use make_cocone. * intro v; apply (pr2 (dob d v)). * abstract (intros u v e; apply (! pr2 (dmor d e))). - use make_cocone. + intro v; simpl. use tpair; simpl. * apply (colimIn H v). * abstract (apply pathsinv0, (colimArrowCommutes H)). + abstract (intros u v e; apply eq_mor_slicecat, (coconeInCommutes (colimCocone H))). - intros y ccy. use unique_exists. + use tpair; simpl. * apply colimArrow, (mapcocone U _ ccy). * abstract (apply pathsinv0, colimArrowUnique; intros v; simpl; rewrite assoc; eapply pathscomp0; [apply cancel_postcomposition, (colimArrowCommutes H _ (mapcocone U _ ccy) v)|]; induction ccy as [f Hf]; simpl; apply (! pr2 (f v))). + abstract (intro v; apply eq_mor_slicecat; simpl; apply (colimArrowCommutes _ _ (mapcocone U d ccy))). + abstract (simpl; intros f; apply impred; intro v; apply has_homsets_slice_precat). + abstract (intros f Hf; apply eq_mor_slicecat; simpl in *; apply colimArrowUnique; intros v; apply (maponpaths pr1 (Hf v))). Defined. End slicecat_colimits. Lemma slice_precat_colims_of_shape (C : category) {g : graph} (x : C) (CC : Colims_of_shape g C) : Colims_of_shape g (slice_cat C x). Proof. intros y; apply slice_precat_ColimCocone, CC. Defined. Lemma slice_precat_colims (C : category) (x : C) (CC : Colims C) : Colims (slice_cat C x). Proof. intros g d; apply slice_precat_ColimCocone, CC. Defined. (** * Moving between Binary products in slice categories and Pullbacks in base category *) Section slicecat_binproducts. Context (C : category). Local Notation "C / X" := (slice_cat C X). Definition pullback_to_slice_binprod {A B Z : C} {f : A --> Z} {g : B --> Z} : Pullback f g -> BinProduct (C / Z) (A ,, f) (B ,, g). Proof. intros P. use (((PullbackObject P ,, (PullbackPr1 P) · f) ,, (((PullbackPr1 P) ,, idpath _) ,, (((PullbackPr2 P) ,, (PullbackSqrCommutes P))))) ,, _). intros Y [j jeq] [k keq]; simpl in jeq , keq. use unique_exists. + use tpair. - apply (PullbackArrow P _ j k). abstract (rewrite <- jeq , keq; apply idpath). - abstract (cbn; rewrite assoc, PullbackArrow_PullbackPr1, <- jeq; apply idpath). + abstract (split; apply eq_mor_slicecat; simpl; [ apply PullbackArrow_PullbackPr1 | apply PullbackArrow_PullbackPr2 ]). + abstract (intros h; apply isapropdirprod; apply has_homsets_slice_precat). + abstract (intros h [H1 H2]; apply eq_mor_slicecat, PullbackArrowUnique; [ apply (maponpaths pr1 H1) | apply (maponpaths pr1 H2) ]). Defined. Definition BinProducts_slice_precat (PC : Pullbacks C) : ∏ x, BinProducts (C / x) := λ x a b, pullback_to_slice_binprod (PC _ _ _ (pr2 a) (pr2 b)). Definition slice_binprod_to_pullback {Z : C} {AZ BZ : C / Z} : BinProduct (C / Z) AZ BZ → Pullback (pr2 AZ) (pr2 BZ). Proof. induction AZ as [A f]. induction BZ as [B g]. intros [[[P h] [[l leq] [r req]]] PisProd]. use ((P ,, l ,, r) ,, (! leq @ req) ,, _). intros Y j k Yeq. simpl in *. use unique_exists. + exact (pr1 (pr1 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))). + abstract (exact (maponpaths pr1 (pr1 (pr2 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))) ,, maponpaths pr1 (pr2 (pr2 (pr1 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq))))))). + abstract (intros x; apply isofhleveldirprod; apply C). + intros t teqs. use (maponpaths pr1 (maponpaths pr1 (pr2 (PisProd (Y ,, j · f) (j ,, idpath _) (k ,, Yeq)) ((t ,, (maponpaths (λ x, x · f) (!(pr1 teqs)) @ !(assoc _ _ _) @ maponpaths (λ x, t · x) (!leq))) ,, _)))). abstract (split; apply eq_mor_slicecat; [exact (pr1 teqs) | exact (pr2 teqs)]). Defined. Definition Pullbacks_from_slice_BinProducts (BP : ∏ x, BinProducts (C / x)) : Pullbacks C := λ x a b f g, slice_binprod_to_pullback (BP x (a ,, f) (b ,, g)). End slicecat_binproducts. (** * Binary coproducts in slice categories of categories with binary coproducts *) Section slicecat_bincoproducts. Context (C : category) (BC : BinCoproducts C). Local Notation "C / X" := (slice_cat C X). Lemma BinCoproducts_slice_precat (x : C) : BinCoproducts (C / x). Proof. intros a b. use make_BinCoproduct. + exists (BinCoproductObject (BC (pr1 a) (pr1 b))). apply (BinCoproductArrow _ (pr2 a) (pr2 b)). + use tpair. - apply BinCoproductIn1. - abstract (cbn; rewrite BinCoproductIn1Commutes; apply idpath). + use tpair. - apply BinCoproductIn2. - abstract (cbn; rewrite BinCoproductIn2Commutes; apply idpath). + intros c f g. use unique_exists. - exists (BinCoproductArrow _ (pr1 f) (pr1 g)). abstract (apply pathsinv0, BinCoproductArrowUnique; [ rewrite assoc, (BinCoproductIn1Commutes C _ _ (BC (pr1 a) (pr1 b))), (pr2 f); apply idpath | rewrite assoc, (BinCoproductIn2Commutes C _ _ (BC (pr1 a) (pr1 b))), (pr2 g)]; apply idpath). - abstract (split; apply eq_mor_slicecat; simpl; [ apply BinCoproductIn1Commutes | apply BinCoproductIn2Commutes ]). - abstract (intros y; apply isapropdirprod; apply has_homsets_slice_precat). - abstract (intros y [<- <-]; apply eq_mor_slicecat, BinCoproductArrowUnique; apply idpath). Defined. End slicecat_bincoproducts. (** * Coproducts in slice categories of categories with coproducts *) Section slicecat_coproducts. Context (C : category) (I : UU) (BC : Coproducts I C). Local Notation "C / X" := (slice_cat C X). Lemma Coproducts_slice_precat (x : C) : Coproducts I (C / x). Proof. intros a. use make_Coproduct. + exists (CoproductObject _ _ (BC (λ i, pr1 (a i)))). apply CoproductArrow; intro i; apply (pr2 (a i)). + intro i; use tpair; simpl. - apply (CoproductIn I C (BC (λ i, pr1 (a i))) i). - abstract (rewrite (CoproductInCommutes I C _ (BC (λ i, pr1 (a i)))); apply idpath). + intros c f. use unique_exists. - exists (CoproductArrow _ _ _ (λ i, pr1 (f i))). abstract (simpl; apply pathsinv0, CoproductArrowUnique; intro i; rewrite assoc, (CoproductInCommutes _ _ _ (BC (λ i, pr1 (a i)))), (pr2 (f i)); apply idpath). - abstract (intros i; apply eq_mor_slicecat, (CoproductInCommutes _ _ _ (BC (λ i0 : I, pr1 (a i0))))). - abstract (intros y; apply impred; intro i; apply has_homsets_slice_precat). - abstract (simpl; intros y Hy; apply eq_mor_slicecat, CoproductArrowUnique; intros i; apply (maponpaths pr1 (Hy i))). Defined. End slicecat_coproducts. Section slicecat_initial. Context (C : category) (IC : Initial C). Local Notation "C / X" := (slice_cat C X). Lemma Initial_slice_precat (x : C) : Initial (C / x). Proof. use make_Initial. - use tpair. + apply (InitialObject IC). + apply InitialArrow. - intros y. use unique_exists; simpl. * apply InitialArrow. * abstract (apply pathsinv0, InitialArrowUnique). * abstract (intros f; apply C). * abstract (intros f Hf; apply InitialArrowUnique). Defined. End slicecat_initial. Section slicecat_terminal. Context (C : category). Local Notation "C / X" := (slice_cat C X). Lemma Terminal_slice_precat (x : C) : Terminal (C / x). Proof. use make_Terminal. - use tpair. + apply x. + apply (identity x). - intros y. use unique_exists; simpl. * apply (pr2 y). * abstract (rewrite id_right; apply idpath). * abstract (intros f; apply C). * abstract (intros f ->; rewrite id_right; apply idpath). Defined. End slicecat_terminal. (** Base change functor: https://ncatlab.org/nlab/show/base+change *) Section base_change. Context (C : category) (PC : Pullbacks C). Local Notation "C / X" := (slice_cat C X). Definition base_change_functor_data {c c' : C} (g : C⟦c,c'⟧) : functor_data (C / c') (C / c). Proof. use tpair. - intros Af'. exists (PullbackObject (PC _ _ _ g (pr2 Af'))). apply PullbackPr1. - intros a b f. use tpair; simpl. + use PullbackArrow. * apply PullbackPr1. * apply (PullbackPr2 _ · pr1 f). * abstract (rewrite <- assoc, <- (pr2 f), PullbackSqrCommutes; apply idpath). + abstract (rewrite PullbackArrow_PullbackPr1; apply idpath). Defined. Lemma is_functor_base_change_functor {c c' : C} (g : C⟦c,c'⟧) : is_functor (base_change_functor_data g). Proof. split. - intros x; apply (eq_mor_slicecat C); simpl. apply pathsinv0, PullbackArrowUnique; rewrite id_left, ?id_right; apply idpath. - intros x y z f1 f2; apply (eq_mor_slicecat C); simpl. apply pathsinv0, PullbackArrowUnique. + rewrite <- assoc, !PullbackArrow_PullbackPr1; apply idpath. + rewrite <- assoc, PullbackArrow_PullbackPr2, !assoc, PullbackArrow_PullbackPr2; apply idpath. Qed. Definition base_change_functor {c c' : C} (g : C⟦c,c'⟧) : functor (C / c') (C / c) := (base_change_functor_data g,,is_functor_base_change_functor g). Local Definition eta_data {c c' : C} (g : C⟦c,c'⟧) : nat_trans_data (functor_identity (C / c)) (functor_composite (slicecat_functor g) (base_change_functor g)). Proof. intros x. use tpair; simpl. + use (PullbackArrow _ _ (pr2 x) (identity _)). abstract (rewrite id_left; apply idpath). + abstract (rewrite PullbackArrow_PullbackPr1; apply idpath). Defined. Local Lemma is_nat_trans_eta_data {c c' : C} (g : C⟦c,c'⟧) : is_nat_trans _ _ (eta_data g). Proof. intros x y f; apply eq_mor_slicecat; simpl. eapply pathscomp0; [apply postCompWithPullbackArrow|]. apply pathsinv0, PullbackArrowUnique. + rewrite <- assoc, !PullbackArrow_PullbackPr1, <- (pr2 f); apply idpath. + rewrite <- assoc, PullbackArrow_PullbackPr2, assoc, PullbackArrow_PullbackPr2, id_right, id_left; apply idpath. Qed. Local Definition eta {c c' : C} (g : C⟦c,c'⟧) : nat_trans (functor_identity (C / c)) (functor_composite (slicecat_functor g) (base_change_functor g)). Proof. use make_nat_trans. - apply eta_data. - apply is_nat_trans_eta_data. Defined. Local Definition eps {c c' : C} (g : C⟦c,c'⟧) : nat_trans (functor_composite (base_change_functor g) (slicecat_functor g)) (functor_identity (C / c')). Proof. use make_nat_trans. - intros x. exists (PullbackPr2 _). abstract (apply PullbackSqrCommutes). - abstract ( intros x y f; apply eq_mor_slicecat; cbn; rewrite PullbackArrow_PullbackPr2; apply idpath ). Defined. Local Lemma form_adjunction_eta_eps {c c' : C} (g : C⟦c,c'⟧) : form_adjunction (slicecat_functor g) (base_change_functor g) (eta g) (eps g). Proof. use tpair. - intros x; apply eq_mor_slicecat; simpl; rewrite PullbackArrow_PullbackPr2; apply idpath. - intros x; apply (eq_mor_slicecat C); simpl. apply pathsinv0, PullbackEndo_is_identity. + rewrite <- assoc, !PullbackArrow_PullbackPr1; apply idpath. + rewrite <- assoc, PullbackArrow_PullbackPr2, assoc, PullbackArrow_PullbackPr2, id_left; apply idpath. Qed. Lemma are_adjoints_slicecat_functor_base_change {c c' : C} (g : C⟦c,c'⟧) : are_adjoints (slicecat_functor g) (base_change_functor g). Proof. exists (eta g,,eps g). exact (form_adjunction_eta_eps g). Defined. (** If the base change functor has a right adjoint, called dependent product, then C / c has exponentials. The formal proof is inspired by Proposition 2.1 from: https://ncatlab.org/nlab/show/locally+cartesian+closed+category#in_category_theory *) Section dependent_product. Context (H : ∏ (c c' : C) (g : C⟦c,c'⟧), is_left_adjoint (base_change_functor g)). Let dependent_product_functor {c c' : C} (g : C⟦c,c'⟧) : functor (C / c) (C / c') := right_adjoint (H c c' g). Let BPC c : BinProducts (C / c) := @BinProducts_slice_precat C PC c. Lemma const_prod_functor1_slicecat c (Af : C / c) : constprod_functor1 (BPC c) Af = functor_composite (base_change_functor (pr2 Af)) (slicecat_functor (pr2 Af)). Proof. apply functor_eq; [apply has_homsets_slice_precat |]. use functor_data_eq. - intro x; apply idpath. - intros x y f; apply (eq_mor_slicecat C); simpl. apply PullbackArrowUnique. + rewrite PullbackArrow_PullbackPr1, id_right; apply idpath. + rewrite PullbackArrow_PullbackPr2; apply idpath. Qed. Lemma dependent_product_to_exponentials c : Exponentials (BPC c). Proof. intros Af. use tpair. + apply (functor_composite (base_change_functor (pr2 Af)) (dependent_product_functor (pr2 Af))). + rewrite const_prod_functor1_slicecat. apply are_adjoints_functor_composite. - apply (pr2 (H _ _ _)). - apply are_adjoints_slicecat_functor_base_change. Defined. End dependent_product. End base_change. (** ** Pullbacks *) Section Pullbacks. Context {E : category} {I : ob E}. Local Notation "E / X" := (slice_cat E X). Local Notation "% A" := (slicecat_ob_object E I A) (at level 20). Local Notation "$ A" := (slicecat_ob_morphism E I A) (at level 20). Local Notation "$$ f" := (slicecat_mor_morphism E I f) (at level 21). (** A complex lemma statement for a simpler proof later *) Local Lemma iscontr_cond_dirprod_weq {X : UU} {P Q R : X -> UU} (xx : ∃! x : X, P x × Q x) : (∏ x, isaprop (R x)) -> (∏ x, isaprop (P x)) -> (∏ x, isaprop (Q x)) -> (R (pr1 (iscontrpr1 xx))) -> (∃! x : X, P x × Q x × R x). Proof. intros ispropR ispropP ispropQ rxx. use make_iscontr. - exists (pr1 (iscontrpr1 xx)). split; [|split]. + exact (dirprod_pr1 (pr2 (iscontrpr1 xx))). + exact (dirprod_pr2 (pr2 (iscontrpr1 xx))). + assumption. - intros t. use total2_paths_f. + pose (eq := proofirrelevancecontr xx (iscontrpr1 xx) (pr1 t,, make_dirprod (dirprod_pr1 (pr2 t)) (dirprod_pr1 (dirprod_pr2 (pr2 t))))). apply pathsinv0. eapply pathscomp0. apply (maponpaths pr1 eq). reflexivity. + apply proofirrelevance. do 2 (apply isapropdirprod; auto). Qed. (** Pullback diagram: << PB -- PBPr1 -> A | | PBPr2 k V V B ---- l ----> C >> *) Lemma pullback_to_slice_pullback (A B C : ob (E / I)) (k : A --> C) (l : B --> C) (PB : Pullback ($$ k) ($$ l)) : Pullback k l. Proof. assert (eq : PullbackPr1 PB · $ A = PullbackPr2 PB · $ B). { (** Just because [k], [l] are slice category morphisms: *) assert (eq1 : $ A = $$ k · $ C) by (apply slicecat_mor_comm). assert (eq2 : $ B = $$ l · $ C) by (apply slicecat_mor_comm). rewrite eq2, eq1. do 2 rewrite assoc. apply (maponpaths (fun x => x · _)). apply PullbackSqrCommutes. } pose (PBtoI := PullbackPr1 PB · $ A). use make_Pullback. - use tpair. + exact (PullbackObject PB). + exact PBtoI. - (** The arrow [PB --> A] *) use tpair. + (** The arrow from [E] *) exact (PullbackPr1 PB). + (** The triangle commutes by definition *) reflexivity. - (** The arrow [PB --> B] *) use tpair. + exact (PullbackPr2 PB). + exact eq. - (** The square commutes *) apply eq_mor_slicecat, PullbackSqrCommutes. - (** [isPullback] *) intros PB' prA' prB' commSq'. (** In two steps, we reduce the problem of a pullback in [E/I] to that of a pullback in [E] (which we already have). 1. Simplify the equalities involved in the sigma-type. 2. Note that what is required is simply a pullback in [E] with an extra commutation condition. *) use iscontrweqb; [exact (∑ kk : % PB' --> PullbackObject PB, kk · PullbackPr1 PB = ($$ prA') × kk · PullbackPr2 PB = ($$ prB') × slicecat_ob_morphism _ _ PB' = kk · PBtoI)| | ]. use weqcomp. + exact (∑ kk : PB' --> (PullbackObject PB,, PBtoI), ($$ kk) · PullbackPr1 PB = ($$ prA') × ($$ kk) · PullbackPr2 PB = ($$ prB')). + (** Step 1 *) apply weqfibtototal; intro. apply weqdirprodf; (apply weqiff; [|apply has_homsets_slice_precat|apply homset_property]; apply weq_to_iff). * eapply weqcomp; [apply invweq, eq_mor_slicecat_weq|]. apply idweq. * eapply weqcomp; [apply invweq, eq_mor_slicecat_weq|]. apply idweq. + (** Step 2 *) (** This is all just rearranging of direct products *) cbn. eapply weqcomp. * apply (@weqtotal2asstor (E⟦% PB', PB⟧) (fun f => $ PB' = f · PBtoI) _). * apply weqfibtototal; intro; cbn. eapply weqcomp. apply weqdirprodcomm. apply weqdirprodasstor. + apply (iscontr_cond_dirprod_weq (isPullback_Pullback PB _ _ _ (maponpaths pr1 commSq'))). * intro; apply homset_property. * intro; apply homset_property. * intro; apply homset_property. * (** The unique arrow between pullbacks is also an arrow in the slice cat *) unfold PBtoI. change (pr1 (iscontrpr1 (isPullback_Pullback PB (pr1 PB') (pr1 prA') (pr1 prB') (maponpaths pr1 commSq')))) with (PullbackArrow PB _ _ _ (maponpaths pr1 commSq')). cbn. rewrite assoc. rewrite PullbackArrow_PullbackPr1. apply slicecat_mor_comm. Defined. End Pullbacks. UniMath-20231010/UniMath/CategoryTheory/whiskering.v000066400000000000000000000165651451125700300222020ustar00rootroot00000000000000(** * Whiskering Benedikt Ahrens, Chris Kapulkin, Mike Shulman January 2013 *) (** ** Contents : - Precomposition with a functor for - functors and - natural transformations (whiskering) - Functoriality of precomposition / postcomposition *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. (** * Whiskering: Composition of a natural transformation with a functor *) (** Prewhiskering *) Lemma is_nat_trans_pre_whisker (A B C : precategory_data) (F : functor_data A B) (G H : functor_data B C) (gamma : nat_trans G H) : is_nat_trans (functor_composite_data F G) (functor_composite_data F H) (λ a : A, gamma (F a)). Proof. intros a b f; simpl. apply nat_trans_ax. Qed. Definition pre_whisker {A B C : precategory_data} (F : functor_data A B) {G H : functor_data B C} (gamma : nat_trans G H) : nat_trans (functor_composite_data F G) (functor_composite_data F H). Proof. exists (λ a, pr1 gamma (pr1 F a)). apply is_nat_trans_pre_whisker. Defined. Lemma pre_whisker_iso_is_iso {A B C : precategory_data} (F : functor_data A B) {G H : functor_data B C} (gamma : nat_trans G H) (X : is_nat_iso gamma) : is_nat_iso (pre_whisker F gamma). Proof. intros a. apply X. Defined. Lemma pre_whisker_on_nat_z_iso {A B C : precategory_data} (F : functor_data A B) {G H : functor_data B C} (gamma : nat_trans G H) (X : is_nat_z_iso gamma) : is_nat_z_iso (pre_whisker F gamma). Proof. intros a. apply X. Defined. Definition pre_whisker_in_funcat (A B C : category) (F : [A, B]) {G H : [B, C]} (γ : [B, C]⟦G, H⟧) : [A, C]⟦functor_compose F G, functor_compose F H⟧. Proof. exact (pre_whisker (F: A ⟶ B) γ). Defined. (** Postwhiskering *) Lemma is_nat_trans_post_whisker (B C D : precategory_data) (G H : functor_data B C) (gamma : nat_trans G H) (K : functor C D): is_nat_trans (functor_composite_data G K) (functor_composite_data H K) (λ b : B, #K (gamma b)). Proof. unfold is_nat_trans. simpl in *. intros; repeat rewrite <- functor_comp. rewrite (nat_trans_ax gamma). apply idpath. Qed. Definition post_whisker {B C D : precategory_data} {G H : functor_data B C} (gamma : nat_trans G H) (K : functor C D) : nat_trans (functor_composite_data G K) (functor_composite_data H K). Proof. exists (λ a : ob B, #(pr1 K) (pr1 gamma a)). apply is_nat_trans_post_whisker. Defined. Lemma post_whisker_iso_is_iso {B C D : precategory} {G H : functor_data B C} (gamma : nat_trans G H) (K : functor C D) (X : is_nat_iso gamma) : is_nat_iso (post_whisker gamma K). Proof. intros b. unfold post_whisker. simpl. set ( gammab := make_iso (gamma b) (X b) ). apply (functor_on_iso_is_iso C D K _ _ gammab). Defined. Lemma post_whisker_z_iso_is_z_iso {B C D : precategory} {G H : functor_data B C} (gamma : nat_trans G H) (K : functor C D) (X : is_nat_z_iso gamma) : is_nat_z_iso (post_whisker gamma K). Proof. intros b. unfold post_whisker. simpl. apply (functor_on_is_z_isomorphism K (X b)). Defined. Definition post_whisker_in_funcat (B C D : category) {G H : [B, C]} (γ : [B, C]⟦G, H⟧) (K : [C, D]) : [B, D]⟦functor_compose G K, functor_compose H K⟧. Proof. exact (post_whisker γ (K: C ⟶ D)). Defined. (** Precomposition with a functor is functorial *) Definition pre_composition_functor_data (A B C : category) (H : ob [A, B]) : functor_data [B, C] [A, C]. Proof. exists (λ G, functor_compose H G). exact (λ a b gamma, pre_whisker_in_funcat _ _ _ H gamma). Defined. Lemma pre_whisker_identity (A B : precategory_data) (C : category) (H : functor_data A B) (G : functor_data B C) : pre_whisker H (nat_trans_id G) = nat_trans_id (functor_composite_data H G). Proof. apply nat_trans_eq. - apply homset_property. - intro a. apply idpath. Qed. Lemma pre_whisker_composition (A B : precategory_data) (C : category) (H : functor_data A B) (a b c : functor_data B C) (f : nat_trans a b) (g : nat_trans b c) : pre_whisker H (nat_trans_comp _ _ _ f g) = nat_trans_comp _ _ _ (pre_whisker H f) (pre_whisker H g). Proof. apply nat_trans_eq. - apply homset_property. - intro; simpl. apply idpath. Qed. Lemma pre_composition_is_functor (A B C : category) (H : [A, B]) : is_functor (pre_composition_functor_data A B C H). Proof. split; simpl in *. - unfold functor_idax . intros. apply pre_whisker_identity. - unfold functor_compax . intros. apply pre_whisker_composition. Qed. Definition pre_composition_functor (A B C : category) (H : [A , B]) : functor [B, C] [A, C]. Proof. exists (pre_composition_functor_data A B C H). apply pre_composition_is_functor. Defined. (* Variation with more implicit arguments *) Definition pre_comp_functor {A B C: category} : [A, B] → [B, C] ⟶ [A, C] := pre_composition_functor _ _ _. (** Postcomposition with a functor is functorial *) Definition post_composition_functor_data (A B C : category) (H : ob [B, C]) : functor_data [A, B] [A, C]. Proof. exists (λ G, functor_compose G H). exact (λ a b gamma, post_whisker_in_funcat _ _ _ gamma H). Defined. Lemma post_whisker_identity (A B : precategory) (C : category) (H : functor B C) (G : functor_data A B) : post_whisker (nat_trans_id G) H = nat_trans_id (functor_composite_data G H). Proof. apply nat_trans_eq. - apply homset_property. - intro a. unfold post_whisker. simpl. apply functor_id. Qed. Lemma post_whisker_composition (A B : precategory) (C : category) (H : functor B C) (a b c : functor_data A B) (f : nat_trans a b) (g : nat_trans b c) : post_whisker (nat_trans_comp _ _ _ f g) H = nat_trans_comp _ _ _ (post_whisker f H) (post_whisker g H). Proof. apply nat_trans_eq. - apply homset_property. - intro; simpl. apply functor_comp. Qed. Lemma post_composition_is_functor (A B C : category) (H : [B, C]) : is_functor (post_composition_functor_data A B C H). Proof. split; simpl in *. - unfold functor_idax . intros. apply post_whisker_identity. - unfold functor_compax . intros. apply post_whisker_composition. Qed. Definition post_composition_functor (A B C : category) (H : [B , C]) : functor [A, B] [A, C]. Proof. exists (post_composition_functor_data A B C H). apply post_composition_is_functor. Defined. (* Variation with more implicit arguments *) Definition post_comp_functor {A B C : category} : [B, C] → [A, B] ⟶ [A, C] := post_composition_functor _ _ _. Lemma pre_whisker_nat_z_iso {C D E : category} (F : functor C D) {G1 G2 : functor D E} (α : nat_z_iso G1 G2) : nat_z_iso (functor_composite F G1) (functor_composite F G2). Proof. exists (pre_whisker F α). exact (pre_whisker_on_nat_z_iso F α (pr2 α)). Defined. Lemma post_whisker_nat_z_iso {C D E : category} {G1 G2 : functor C D} (α : nat_z_iso G1 G2) (F : functor D E) : nat_z_iso (functor_composite G1 F) (functor_composite G2 F). Proof. exists (post_whisker α F). exact (post_whisker_z_iso_is_z_iso α F (pr2 α)). Defined. UniMath-20231010/UniMath/CategoryTheory/yoneda.v000066400000000000000000000260271451125700300213010ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Chris Kapulkin, Mike Shulman january 2013 ************************************************************) (** ********************************************************** Contents : Definition of the Yoneda functor [yoneda(C) : [C, [C^op, HSET]]] Proof that [yoneda(C)] is fully faithful TODO: this file needs cleanup ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Export UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso. Require Import UniMath.CategoryTheory.whiskering. Local Notation "'hom' C" := (precategory_morphisms (C := C)) (at level 2). Ltac unf := unfold identity, compose, precategory_morphisms; simpl. (** The following lemma is already in precategories.v . It should be transparent? *) Lemma iso_comp_left_isweq {C:category} {a b:ob C} (h:iso a b) (c:C) : isweq (λ f : hom _ c a, f · h). Proof. intros. apply (@iso_comp_right_isweq C^op b a (opp_iso h)). Qed. (** * Yoneda functor *) (** ** On objects *) Definition yoneda_objects_ob (C : category) (c : C) (d : C) := hom C d c. Definition yoneda_objects_mor (C : category) (c : C) (d d' : C) (f : hom C d d') : yoneda_objects_ob C c d' -> yoneda_objects_ob C c d := λ g, f · g. Definition yoneda_ob_functor_data (C : category) (c : C) : functor_data (C^op) HSET. Proof. exists (λ c', make_hSet (yoneda_objects_ob C c c') (homset_property C _ _ ) ). intros a b f g. unfold yoneda_objects_ob in *. simpl in *. exact (f · g). Defined. Lemma is_functor_yoneda_functor_data (C : category) (c : C) : is_functor (yoneda_ob_functor_data C c). Proof. repeat split; unf; simpl. unfold functor_idax . intros. apply funextsec. intro f. unf. apply id_left. intros a b d f g. apply funextsec. intro h. apply (! assoc _ _ _ ). Qed. Definition yoneda_objects (C : category) (c : C) : functor C^op HSET := tpair _ _ (is_functor_yoneda_functor_data C c). (** ** On morphisms *) Definition yoneda_morphisms_data (C : category) (c c' : C) (f : hom C c c') : ∏ a : ob C^op, hom _ (yoneda_objects C c a) ( yoneda_objects C c' a) := λ a g, g · f. Lemma is_nat_trans_yoneda_morphisms_data (C : category) (c c' : ob C) (f : hom C c c') : is_nat_trans (yoneda_objects C c) (yoneda_objects C c') (yoneda_morphisms_data C c c' f). Proof. unfold is_nat_trans; simpl. unfold yoneda_morphisms_data; simpl. intros d d' g. apply funextsec; simpl in *. unfold yoneda_objects_ob; simpl. unf; intro; apply ( ! assoc _ _ _ ). Qed. Definition yoneda_morphisms (C : category) (c c' : C) (f : hom C c c') : nat_trans (yoneda_objects C c) (yoneda_objects C c') := tpair _ _ (is_nat_trans_yoneda_morphisms_data C c c' f). Definition yoneda_functor_data (C : category) : functor_data C [C^op , HSET, (has_homsets_HSET) ] := tpair _ (yoneda_objects C) (yoneda_morphisms C). (** ** Functorial properties of the yoneda assignments *) Lemma is_functor_yoneda (C : category) : is_functor (yoneda_functor_data C). Proof. unfold is_functor. repeat split; simpl. intro a. set (T:= nat_trans_eq (C:=C^op) (has_homsets_HSET)). simpl. apply T. intro c; apply funextsec; intro f. apply id_right. intros a b c f g. set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)). apply T. simpl; intro d; apply funextsec; intro h. apply assoc. Qed. Definition yoneda (C : category) : functor C (functor_category C^op hset_category) := tpair _ _ (is_functor_yoneda C). (* Notation "'ob' F" := (precategory_ob_mor_fun_objects F)(at level 4). *) (** ** Yoneda lemma: natural transformations from [yoneda C c] to [F] are isomorphic to [F c] *) Definition yoneda_map_1 (C : category) (c : C) (F : functor C^op HSET) : hom _ (yoneda C c) F -> pr1 (F c) := λ h, pr1 h c (identity c). Lemma yoneda_map_2_ax (C : category) (c : C) (F : functor C^op HSET) (x : pr1 (F c)) : is_nat_trans (pr1 (yoneda C c)) F (fun (d : C) (f : hom (C ^op) c d) => #F f x). Proof. intros a b f; simpl in *. apply funextsec. unfold yoneda_objects_ob; intro g. set (H:= @functor_comp _ _ F _ _ b g). unfold functor_comp in H; unfold opp_precat_data in H; simpl in *. apply (toforallpaths _ _ _ (H f) x). Qed. Definition yoneda_map_2 (C : category) (c : C) (F : functor C^op HSET) : pr1 (F c) -> hom _ (yoneda C c) F. Proof. intro x. exists (λ d : ob C, λ f, #F f x). apply yoneda_map_2_ax. Defined. Lemma yoneda_map_1_2 (C : category) (c : C) (F : functor C^op HSET) (alpha : hom _ (yoneda C c) F) : yoneda_map_2 _ _ _ (yoneda_map_1 _ _ _ alpha) = alpha. Proof. simpl in *. set (T:=nat_trans_eq (C:=C^op) (has_homsets_HSET)). apply T. intro a'; simpl. apply funextsec; intro f. unfold yoneda_map_1. intermediate_path ((alpha c · #F f) (identity c)). apply idpath. rewrite <- nat_trans_ax. unf; apply maponpaths. apply (id_right f ). Qed. Lemma yoneda_map_2_1 (C : category) (c : C) (F : functor C^op HSET) (x : pr1 (F c)) : yoneda_map_1 _ _ _ (yoneda_map_2 _ _ _ x) = x. Proof. simpl. rewrite (functor_id F). apply idpath. Qed. Lemma isaset_nat_trans_yoneda (C: category) (c : C) (F : functor C^op HSET) : isaset (nat_trans (yoneda_ob_functor_data C c) F). Proof. apply isaset_nat_trans. apply (has_homsets_HSET). Qed. Lemma yoneda_iso_sets (C : category) (c : C) (F : functor C^op HSET) : is_z_isomorphism (C:=HSET) (a := make_hSet (hom _ ((yoneda C) c) F) (isaset_nat_trans_yoneda C c F)) (b := F c) (yoneda_map_1 C c F). Proof. set (T:=yoneda_map_2 C c F). simpl in T. set (T':= T : hom HSET (F c) (make_hSet (hom _ ((yoneda C) c) F) (isaset_nat_trans_yoneda C c F))). exists T'. split; simpl. - apply funextsec; intro alpha. unf; simpl. apply (yoneda_map_1_2 C c F). - apply funextsec; intro x. unf; rewrite (functor_id F). apply idpath. Defined. Definition yoneda_iso_target (C : category) (F : [C^op, HSET]) : functor C^op HSET. Proof. use (@functor_composite _ [C^op, HSET]^op). - apply functor_opp. apply yoneda. - apply (yoneda _ F). Defined. Lemma is_natural_yoneda_iso (C : category) (F : functor C^op HSET): is_nat_trans (yoneda_iso_target C F) F (λ c, yoneda_map_1 C c F). Proof. unfold is_nat_trans. intros c c' f. cbn in *. apply funextsec. unfold yoneda_ob_functor_data. cbn. unfold yoneda_morphisms_data. unfold yoneda_map_1. intro X. assert (XH := nat_trans_ax X). cbn in XH. unfold yoneda_objects_ob in XH. assert (XH' := XH c' c' (identity _ )). assert (XH2 := toforallpaths _ _ _ XH'). rewrite XH2. rewrite (functor_id F). cbn. clear XH2 XH'. assert (XH' := XH _ _ f). assert (XH2 := toforallpaths _ _ _ XH'). eapply pathscomp0. 2: apply XH2. rewrite id_right. apply idpath. Qed. Definition natural_trans_yoneda_iso (C : category) (F : functor C^op HSET) : nat_trans (yoneda_iso_target C F) F := tpair _ _ (is_natural_yoneda_iso C F). Lemma is_natural_yoneda_iso_inv (C : category) (F : functor C^op HSET): is_nat_trans F (yoneda_iso_target C F) (λ c, yoneda_map_2 C c F). Proof. unfold is_nat_trans. intros c c' f. cbn in *. apply funextsec. unfold yoneda_ob_functor_data. cbn. unfold yoneda_map_2. intro A. apply nat_trans_eq. { apply (has_homsets_HSET). } cbn. intro d. apply funextfun. unfold yoneda_objects_ob. intro g. unfold yoneda_morphisms_data. apply (! toforallpaths _ _ _ (functor_comp F _ _ ) A). Qed. Definition natural_trans_yoneda_iso_inv (C : category) (F : functor C^op HSET) : nat_trans (yoneda_iso_target C F) F := tpair _ _ (is_natural_yoneda_iso C F). Lemma isweq_yoneda_map_1 (C : category) (c : C) (F : functor C^op HSET) : isweq (*a := make_hSet (hom _ ((yoneda C) hs c) F) (isaset_nat_trans_yoneda C hs c F)*) (*b := F c*) (yoneda_map_1 C c F). Proof. set (T:=yoneda_map_2 C c F). simpl in T. use isweq_iso. - apply T. - apply yoneda_map_1_2. - apply yoneda_map_2_1. Defined. Definition yoneda_weq (C : category) (c : C) (F : functor C^op HSET) : hom [C^op, HSET, has_homsets_HSET] (yoneda C c) F ≃ pr1hSet (F c) := make_weq _ (isweq_yoneda_map_1 C c F). (** ** The Yoneda embedding is fully faithful *) Lemma yoneda_fully_faithful (C : category) : fully_faithful (yoneda C). Proof. intros a b; simpl. apply (isweq_iso _ (yoneda_map_1 C a (pr1 (yoneda C) b))). - intro; simpl in *. apply id_left. - intro gamma. simpl in *. apply nat_trans_eq. apply (has_homsets_HSET). intro x. simpl in *. apply funextsec; intro f. unfold yoneda_map_1. unfold yoneda_morphisms_data. assert (T:= toforallpaths _ _ _ (nat_trans_ax gamma a x f) (identity _ )). cbn in T. eapply pathscomp0; [apply (!T) |]. apply maponpaths. apply id_right. Defined. Section yoneda_functor_precomp. Variables C D : category. Variable F : functor C D. Section fix_object. Variable c : C. Definition yoneda_functor_precomp' : nat_trans (yoneda_objects C c) (functor_composite (functor_opp F) (yoneda_objects D (F c))). Proof. use tpair. - intros d f ; simpl. apply (#F f). - abstract (intros d d' f ; apply funextsec; intro t; simpl; apply functor_comp). Defined. Definition yoneda_functor_precomp : _ ⟦ yoneda C c, functor_composite (functor_opp F) (yoneda_objects D (F c))⟧. Proof. exact yoneda_functor_precomp'. Defined. Variable Fff : fully_faithful F. Lemma is_z_iso_yoneda_functor_precomp : is_z_isomorphism yoneda_functor_precomp. Proof. apply nat_trafo_z_iso_if_pointwise_z_iso. intro a. simpl. set (T:= make_weq _ (Fff a c)). set (TA := make_hSet (hom C a c) (homset_property C _ _)). set (TB := make_hSet (hom D (F a) (F c)) (homset_property _ _ _ )). apply (hset_equiv_is_z_iso TA TB T). Defined. End fix_object. Let A : C ⟶ [D^op, HSET] := functor_composite F (yoneda D). Let B : [D^op, HSET] ⟶ [C^op, HSET] := pre_composition_functor _ _ HSET (functor_opp F : [C^op, D^op]). Definition yoneda_functor_precomp_nat_trans : @nat_trans C [C^op, HSET, (has_homsets_HSET)] (yoneda C) (functor_composite A B). Proof. use tpair. - intro c; simpl. apply yoneda_functor_precomp. - abstract ( intros c c' f; apply nat_trans_eq; [apply (has_homsets_HSET) |]; intro d; apply funextsec; intro t; cbn; apply functor_comp). Defined. End yoneda_functor_precomp. UniMath-20231010/UniMath/Combinatorics/000077500000000000000000000000001451125700300174505ustar00rootroot00000000000000UniMath-20231010/UniMath/Combinatorics/.package/000077500000000000000000000000001451125700300211215ustar00rootroot00000000000000UniMath-20231010/UniMath/Combinatorics/.package/files000066400000000000000000000004641451125700300221520ustar00rootroot00000000000000StandardFiniteSets.v Vectors.v VectorsTests.v Lists.v FiniteSets.v KFiniteTypes.v KFiniteSubtypes.v Graph.v CGraph.v GraphPaths.v Equivalence_Relations.v OrderedSets.v WellFoundedRelations.v WellOrderedSets.v ZFstructures.v FiniteSequences.v BoundedSearch.v MetricTree.v Tests.v DecSet.v Maybe.v MoreLists.v UniMath-20231010/UniMath/Combinatorics/BoundedSearch.v000066400000000000000000000070431451125700300223510ustar00rootroot00000000000000(** Auke Booij Nov. 2017 If [ P ] is a decidable predicate on the natural numbers, then from the existence of a natural number satisfying [ P ], we can find a natural number satisfying [ P ]. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Propositions. Section constr_indef_descr. Context (P : nat → hProp) (P_dec : ∏ n : nat, P n ⨿ ¬ P n) (P_inhab : ∃ n : nat, P n). Local Definition minimal (n : nat) : UU := ∏ m : nat, P m → (n ≤ m). Local Definition isapropminimal (n : nat) : isaprop (minimal n). Proof. apply impred_isaprop. intros m. apply isapropimpl. apply isasetbool. Defined. Local Definition min_n_UU : UU := ∑ n : nat, P n × minimal n. Local Definition isapropmin_n : isaprop min_n_UU. Proof. apply isaproptotal2. - intros n. apply isapropdirprod. apply (P n). apply isapropminimal. - intros n n' k k'. induction k as [p m], k' as [p' m']. apply isantisymmnatleh. + exact (m n' p'). + exact (m' n p). Defined. Local Definition min_n : hProp := make_hProp min_n_UU isapropmin_n. Local Definition smaller (n : nat) := ∑ l : nat, P l × minimal l × (l ≤ n)%nat. Local Definition smaller_S (n : nat) (k : smaller n) : smaller (S n). Proof. induction k as [l pmz]. induction pmz as [p mz]. induction mz as [m z]. refine (l,,p,,m,,_). refine (istransnatgth _ _ _ _ _). apply natgthsnn. apply z. Defined. Local Definition bounded_search (n : nat) : smaller n ⨿ ∏ l : nat, (l ≤ n)%nat → ¬ P l. Proof. induction n. - assert (P 0 ⨿ ¬ P 0) as X. apply P_dec. induction X as [h|]. + apply ii1. refine (O,,h,,_,,_). * intros ? ?. apply natleh0n. * apply isreflnatleh. + apply ii2. intros l lleq0. assert (H : l = O). { apply natleh0tois0. assumption. } rewrite H. assumption. - induction IHn as [|n0]. + apply ii1. apply smaller_S. assumption. + assert (P (S n) ⨿ ¬ P (S n)) as X. apply P_dec. induction X as [h|]. * refine (ii1 (S n,,h,,_,,_)). -- intros m q. assert (((S n) > m)%nat ⨿ (S n ≤ m)) as X. apply natgthorleh. induction X as [h0|]. ++ apply fromempty. refine (n0 m h0 q). ++ assumption. -- apply isreflnatleh. * apply ii2. intros l q. assert ((l > n)%nat ⨿ (l ≤ n)) as X. apply natgthorleh. induction X as [h|h]. -- assert (H : l = S n). apply isantisymmnatgeh. apply h. apply q. rewrite H. assumption. -- exact (n0 l h). Defined. Local Definition n_to_min_n (n : nat) (p : P n) : min_n. Proof. assert (smaller n ⨿ ∏ l : nat, (l ≤ n)%nat → ¬ P l) as X. apply bounded_search. induction X as [lqmz|none]. - induction lqmz as [l qmz]. induction qmz as [q mz]. induction mz as [m z]. refine (l,,q,,m). - apply fromempty. refine (none n (isreflnatgeh _ ) p). Defined. Local Definition prop_n_to_min_n : min_n. Proof. refine (@hinhuniv (∑ n : nat, P n) _ _ _). - induction 1 as [n p]. exact (n_to_min_n n p). - exact P_inhab. Defined. Definition minimal_n : ∑ n : nat, P n. Proof. induction prop_n_to_min_n as [n pl]. induction pl as [p _]. exact (n,,p). Defined. End constr_indef_descr. UniMath-20231010/UniMath/Combinatorics/CGraph.v000066400000000000000000000171611451125700300210110ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Correspondence graphs Marco Maggesi June 2019 ********************************************************************************* *) (* We refer to graphs formalized in this file as "correspondence graphs" (cgraphs for short). A correspondence is a diagram N <--- A ---> N' In our case A is the type of arcs and N = N' is the type of nodes and the two arrows are interpreted as source and target of an arc. This name is chosen to make a name distinction with the graphs defined in CategoryTheory/Graph.v. Also, to avoid any overlap of the terminology, here we use the words "node" and "arc" instead of "vertex" and "edge". When the type N and A of nodes and arcs are not assumed to be sets, we use the name "correspondence pregraph", abbreviated "precgraph". *) Require Import UniMath.MoreFoundations.Propositions. (** ** Precgraphs. *) Definition precgraph : UU := ∑ (N : UU) (E : UU), (E → N) × (E → N). Definition make_precgraph {N : UU} {E : UU} (s t : E → N) : precgraph := N,, E,, make_dirprod s t. Definition node : precgraph → UU := pr1. Definition arc (G : precgraph) : UU := pr12 G. Definition source {G : precgraph} : arc G → node G := pr122 G. Definition target {G : precgraph} : arc G → node G := pr222 G. Definition has_nodeset (G : precgraph) : UU := isaset (node G). Definition has_arcset (G : precgraph) : UU := isaset (arc G). (** Cgraphs. *) Definition cgraph : UU := ∑ G : precgraph, isaset (node G) × isaset (arc G). Definition make_cgraph (G : precgraph) (h : isaset (node G)) (k : isaset (arc G)) : cgraph := tpair _ G (make_dirprod h k). Definition precgraph_of_cgraph : cgraph → precgraph := pr1. Coercion precgraph_of_cgraph : cgraph >-> precgraph. Definition isaset_node (G : cgraph) : isaset (node G) := pr12 G. Definition node_set (G : cgraph) : hSet := make_hSet (node G) (isaset_node G). Definition isaset_arc (G : cgraph) : isaset (arc G) := pr22 G. Definition arc_set (G : cgraph) : hSet := make_hSet (arc G) (isaset_arc G). (** ** Cgraph morphisms. *) Definition is_cgraph_mor {G H : precgraph} (p₀ : node G → node H) (p₁ : arc G → arc H) : UU := (∏ f : arc G, source (p₁ f) = p₀ (source f)) × (∏ f : arc G, target (p₁ f) = p₀ (target f)). Definition cgraph_mor (G H : precgraph) : UU := ∑ (p₀ : node G → node H) (p₁ : arc G → arc H), is_cgraph_mor p₀ p₁. Definition make_cgraph_mor {G H : precgraph} (p₀ : node G → node H) (p₁ : arc G → arc H) (h : is_cgraph_mor p₀ p₁) : cgraph_mor G H := p₀,, p₁,, h. Definition onnode {G H : precgraph} : cgraph_mor G H → node G → node H := pr1. Definition onarc {G H : precgraph} : cgraph_mor G H → arc G → arc H := λ f, pr12 f. Definition preserves_source {G H : precgraph} (p : cgraph_mor G H) : ∏ x : arc G, source (onarc p x) = onnode p (source x) := pr122 p. Definition preserves_target {G H : precgraph} (p : cgraph_mor G H) : ∏ f : arc G, target (onarc p f) = onnode p (target f) := pr222 p. Lemma is_cgraph_mor_id (G : precgraph) : is_cgraph_mor (idfun (node G)) (idfun (arc G)). Proof. apply make_dirprod; intros; apply idpath. Defined. Definition cgraph_mor_id (G : precgraph) : cgraph_mor G G := make_cgraph_mor (idfun (node G)) (idfun (arc G)) (is_cgraph_mor_id G). Lemma is_cgraph_mor_comp {G H K : precgraph} (p : cgraph_mor G H) (q : cgraph_mor H K) : is_cgraph_mor (onnode q ∘ onnode p) (onarc q ∘ onarc p). Proof. apply make_dirprod. - intros. unfold funcomp. etrans. apply (preserves_source q). apply maponpaths. apply (preserves_source p). - intros. unfold funcomp. etrans. apply (preserves_target q). apply maponpaths. apply (preserves_target p). Defined. Definition cgraph_mor_comp {G H K : precgraph} (p : cgraph_mor G H) (q : cgraph_mor H K) : cgraph_mor G K := make_cgraph_mor (onnode q ∘ onnode p) (onarc q ∘ onarc p) (is_cgraph_mor_comp p q). Lemma cgraph_mor_id_left {G H : precgraph} (p : cgraph_mor G H) : cgraph_mor_comp (cgraph_mor_id G) p = p. Proof. induction p as (p₀,(p₁,h)). apply pair_path_in2. apply pair_path_in2. apply dirprod_paths. - apply funextsec. intro f. cbn. apply pathscomp0rid. - apply funextsec. intro f. cbn. apply pathscomp0rid. Defined. Lemma cgraph_mor_id_right {G H : precgraph} (p : cgraph_mor G H) : cgraph_mor_comp p (cgraph_mor_id H) = p. Proof. induction p as (p₀,(p₁,h)). apply pair_path_in2. apply pair_path_in2. apply dirprod_paths. - apply funextsec. intro f. cbn. apply maponpathsidfun. - apply funextsec. intro f. cbn. apply maponpathsidfun. Defined. Lemma cgraph_mor_comp_assoc {G1 G2 G3 G4 : precgraph} (p : cgraph_mor G1 G2) (q : cgraph_mor G2 G3) (r : cgraph_mor G3 G4) : cgraph_mor_comp p (cgraph_mor_comp q r) = cgraph_mor_comp (cgraph_mor_comp p q) r. Proof. induction p as (p₀,(p₁,h)). induction q as (q₀,(q₁,k)). induction r as (r₀,(r₁,l)). apply pair_path_in2. apply pair_path_in2. apply dirprod_paths; cbn. - apply funextsec. intro f. etrans. { apply pathsinv0, path_assoc. } apply maponpaths. apply pathsinv0. etrans. { apply maponpathscomp0. } apply maponpaths. apply maponpathscomp. - apply funextsec. intro f. etrans. { apply pathsinv0, path_assoc. } apply maponpaths. apply pathsinv0. etrans. { apply maponpathscomp0. } apply maponpaths. apply maponpathscomp. Defined. Lemma isaprop_is_cgraph_mor {G H : precgraph} (p₀ : node G → node H) (p₁ : arc G → arc H) (h : has_nodeset H) : isaprop (is_cgraph_mor p₀ p₁). Proof. apply isapropdirprod; apply impred_isaprop; intro f; apply h. Qed. Lemma isaset_cgraph_mor {G H : precgraph} (h : has_nodeset H) (k : has_arcset H) : isaset (cgraph_mor G H). Proof. apply isaset_total2. - exact (funspace_isaset h). - intro p₀. apply isaset_total2. + exact (funspace_isaset k). + intro p₁. apply isasetaprop. apply isaprop_is_cgraph_mor. exact h. Qed. (** ** Equality of cgraph morphisms *) Lemma cgraph_mor_eq_aux {G H : precgraph} (p q : cgraph_mor G H) (e₀ : onnode p = onnode q) (e₁ : onarc p = onarc q) (h : has_nodeset H) : p = q. Proof. induction p as (p₀,(p₁,(psource,ptarget))). induction q as (q₀,(q₁,(qsource,qtarget))). cbn in *. induction e₀. apply pair_path_in2. induction e₁. apply pair_path_in2. apply pathsdirprod. - apply funextsec. intro f. apply h. - apply funextsec. intro f. apply h. Qed. Lemma cgraph_mor_eq {G H : cgraph} (p q : cgraph_mor G H) (e₀ : ∏ x : node G, onnode p x = onnode q x) (e₁ : ∏ f : arc G, onarc p f = onarc q f) : p = q. Proof. apply cgraph_mor_eq_aux. - apply funextfun. exact e₀. - apply funextfun. exact e₁. - apply isaset_node. Qed. (** ** Weak equivalence between CGraphs and Graphs *) Require Import UniMath.MoreFoundations.PartD. (* display *) Require Import UniMath.Combinatorics.Graph. Lemma precgraph_weq_pregraph : precgraph ≃ pregraph. Proof. unfold pregraph, precgraph. apply weqfibtototal. intro X. apply (weqcomp (Y := ∑ E : UU, E → X × X)). - apply weqfibtototal. intro Y. apply invweq, weqfuntoprodtoprod. - apply (weqcomp (Y := X × X → UU)). + set (A := X × X). apply display_weq. + apply weqfunfromdirprod. Defined. UniMath-20231010/UniMath/Combinatorics/DecSet.v000066400000000000000000000011061451125700300210040ustar00rootroot00000000000000(** * Decidable sets. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) (* In this file we introduce the type [decSet] of h-sets of decidable sets, i.e., types [X] endowed with the property [isdeceq X], just like an [hSet] is a type X endowed with the property [isaset X]. *) Require Import UniMath.Foundations.PartB. Definition decSet: UU := ∑ (X: UU), isdeceq X. Definition make_decSet (X: UU) (i: isdeceq X): decSet := X,, i. Definition pr1decSet: decSet -> UU := pr1. Coercion pr1decSet: decSet >-> UU. Definition decproperty (X: decSet) := pr2 X. UniMath-20231010/UniMath/Combinatorics/Equivalence_Relations.v000066400000000000000000000022151451125700300241200ustar00rootroot00000000000000(** Author: Floris van Doorn, december 2017 *) Require Import UniMath.Combinatorics.GraphPaths. Require Import UniMath.MoreFoundations.Subtypes. (** Equivalence relations. Contents: - construction of the equivalence relation generated by an arbitrary relation, defined as the truncation of paths in a graph *) Definition eqrel_closure_hrel {X : UU} (R : hrel X) : hrel X := λ x y, ∥ gpaths (symmetric_closure R) x y ∥. Lemma iseqrel_closure {X : UU} (R : hrel X) : iseqrel (eqrel_closure_hrel R). Proof. use iseqrelconstr. - intros x y z. apply hinhfun2. apply concat. - intro x. apply hinhpr. apply nil. - intros x y. apply hinhfun. apply reverse_in_closure. Defined. Definition eqrel_closure {X : UU} (R : hrel X) : eqrel X := make_eqrel _ (iseqrel_closure R). Lemma eqrel_closure_minimal {X : UU} {R : hrel X} (S : eqrel X) (H : ∏ x x', R x x' → S x x') {x x' : X} : eqrel_closure R x x' → S x x'. Proof. apply hinhuniv. revert x. apply gpaths_ind. - apply eqrelrefl. - intros x y r p HS. refine (eqreltrans S _ _ _ _ HS). induction r as [r|r]. + apply H. exact r. + apply eqrelsymm. apply H. exact r. Defined. UniMath-20231010/UniMath/Combinatorics/FiniteSequences.v000066400000000000000000000623401451125700300227360ustar00rootroot00000000000000(** * Finite sequences Vectors and matrices defined in March 2018 by Langston Barrett (@siddharthist). *) (** ** Contents - Vectors - Matrices - Sequences - Definitions - Lemmas *) Require Export UniMath.Combinatorics.FiniteSets. Require Export UniMath.Combinatorics.Lists. Require Import UniMath.Combinatorics.Vectors. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Local Open Scope transport. (** ** Vectors *) (** A [Vector] of length n with values in X is an ordered n-tuple of elements of X, encoded here as a function ⟦n⟧ → X. *) Definition Vector (X : UU) (n : nat) : UU := stn n -> X. (** hlevel of vectors *) Lemma vector_hlevel (X : UU) (n : nat) {m : nat} (ism : isofhlevel m X) : isofhlevel m (Vector X n). Proof. apply impred; auto. Defined. (** Constant vector *) Definition const_vec {X : UU} {n : nat} (x : X) : Vector X n := λ _, x. (** The unique empty vector *) Definition iscontr_vector_0 X : iscontr (Vector X 0). Proof. intros. apply (@iscontrweqb _ (empty -> X)). - apply invweq. apply weqbfun. apply weqstn0toempty. - apply iscontrfunfromempty. Defined. Definition empty_vec {X : UU} : Vector X 0 := iscontrpr1 (iscontr_vector_0 X). (** Every type is equivalent to vectors of length 1 on that type. *) Lemma weq_vector_1 {X : UU} : X ≃ Vector X 1. intermediate_weq (unit → X). - apply invweq, weqfunfromunit. - apply weqbfun. exact weqstn1tounit. Defined. Section Append. Context {X : UU} {n : nat} (vec : Vector X n) (x : X). Definition append_vec : Vector X (S n). Proof. intros i. induction (natlehchoice4 (pr1 i) n (pr2 i)) as [c|d]. - exact (vec (pr1 i,,c)). - exact x. Defined. Definition append_vec_compute_1 i : append_vec (dni lastelement i) = vec i. Proof. intros. induction i as [i b]; simpl. rewrite replace_dni_last. unfold append_vec; simpl. induction (natlehchoice4 i n (natlthtolths i n b)) as [p|p]. - simpl. apply maponpaths. apply isinjstntonat; simpl. reflexivity. - simpl. destruct p. induction (isirreflnatlth i b). Defined. Definition append_vec_compute_2 : append_vec lastelement = x. Proof. intros; unfold append_vec; simpl. induction (natlehchoice4 n n (natgthsnn n)) as [a|a]; simpl. - contradicts a (isirreflnatlth n). - reflexivity. Defined. End Append. Lemma drop_and_append_vec {X n} (x : Vector X (S n)) : append_vec (x ∘ dni_lastelement) (x lastelement) = x. Proof. intros. apply funextfun; intros [i b]. simpl. induction (natlehchoice4 i n b) as [p|p]. - simpl. unfold append_vec. simpl. induction (natlehchoice4 i n b) as [q|q]. + simpl. apply maponpaths. apply isinjstntonat; simpl. reflexivity. + induction q. contradicts p (isirreflnatlth i). - induction p. unfold append_vec; simpl. induction (natlehchoice4 i i b) as [r|r]. * simpl. apply maponpaths. apply isinjstntonat; simpl. reflexivity. * simpl. apply maponpaths. apply isinjstntonat; simpl. reflexivity. Defined. (** An induction principle for vectors: If a statement is true for the empty vector, and if it is true for vectors of length n it is also true for those of length S n, then it is true for all vectors. *) Definition Vector_rect {X : UU} {P : ∏ n, Vector X n -> UU} (p0 : P 0 empty_vec) (ind : ∏ (n : nat) (vec : Vector X n) (x : X), P n vec -> P (S n) (append_vec vec x)) {n : nat} (vec : Vector X n) : P n vec. Proof. intros. induction n as [|n IH]. - refine (transportf (P 0) _ p0). apply proofirrelevancecontr, iscontr_vector_0. - exact (transportf (P _) (drop_and_append_vec vec) (ind _ (vec ∘ dni_lastelement) (vec lastelement) (IH (vec ∘ dni_lastelement)))). Defined. Section Lemmas. Context {X : UU} {n : nat}. Definition vectorEquality {m : nat} (f : Vector X n) (g : Vector X m) (p : n = m) : (∏ i, f i = g (transportf stn p i)) -> transportf (Vector X) p f = g. Proof. intro. induction p. apply funextfun. assumption. Defined. Definition tail (vecsn : Vector X (S n)) : Vector X n := vecsn ∘ dni (0,, natgthsn0 n). (** It doesn't matter what the proofs are in the stn inputs. *) Definition vector_stn_proofirrelevance {vec : Vector X n} {i j : stn n} : (stntonat _ i = stntonat _ j) -> vec i = vec j. Proof. intro. apply maponpaths, isinjstntonat; assumption. Defined. End Lemmas. (** ** Matrices *) Local Open Scope stn. (** An m × n matrix is an m-length vector of n-length vectors (rows). << <--- n ---> | [ * * * * ] m [ * * * * ] | [ * * * * ] >> Since [Vector]s are encoded as functions ⟦n⟧ → X, a matrix is a function (of two arguments). Thus, the (i, j)-entry of a matrix Mat is simply Mat i j. *) Definition Matrix (X : UU) (m n : nat) : UU := Vector (Vector X n) m. (** The transpose is obtained by flipping the arguments. *) Definition transpose {X : UU} {n m : nat} (mat : Matrix X m n) : Matrix X n m := flip mat. Definition row {X : UU} {m n : nat} (mat : Matrix X m n) : ⟦ m ⟧ → Vector X n := mat. Definition col {X : UU} {m n : nat} (mat : Matrix X m n) : ⟦ n ⟧ → Vector X m := transpose mat. Definition row_vec {X : UU} {n : nat} (vec : Vector X n) : Matrix X 1 n := λ i j, vec j. Definition col_vec {X : UU} {n : nat} (vec : Vector X n) : Matrix X n 1 := λ i j, vec i. (** hlevel of matrices *) Lemma matrix_hlevel (X : UU) (n m : nat) {o : nat} (ism : isofhlevel o X) : isofhlevel o (Matrix X n m). Proof. do 2 apply vector_hlevel; assumption. Defined. (** Constant matrix *) Definition const_matrix {X : UU} {n m : nat} (x : X) : Matrix X n m := const_vec (const_vec x). (** Every type is equivalent to 1 × 1 matrices on that type. *) Lemma weq_matrix_1_1 {X : UU} : X ≃ Matrix X 1 1. intermediate_weq (Vector X 1); apply weq_vector_1. Defined. (** ** Sequences *) (** *** Definitions *) (** A [Sequence] is a [Vector] of any length. *) Definition Sequence (X : UU) := ∑ n, Vector X n. Definition NonemptySequence (X:UU) := ∑ n, stn (S n) -> X. Definition UnorderedSequence (X:UU) := ∑ I:FiniteSet, I -> X. Definition length {X} : Sequence X -> nat := pr1. Definition sequenceToFunction {X} (x:Sequence X) := pr2 x : stn (length x) -> X. Coercion sequenceToFunction : Sequence >-> Funclass. Definition unorderedSequenceToFunction {X} (x:UnorderedSequence X) := pr2 x : pr1 (pr1 x) -> X. Coercion unorderedSequenceToFunction : UnorderedSequence >-> Funclass. Definition sequenceToUnorderedSequence {X} : Sequence X -> UnorderedSequence X. Proof. intros x. exists (standardFiniteSet (length x)). exact x. Defined. Coercion sequenceToUnorderedSequence : Sequence >-> UnorderedSequence. Definition length'{X} : NonemptySequence X -> nat := λ x, S(pr1 x). Definition functionToSequence {X n} (f:stn n -> X) : Sequence X := (n,,f). Definition functionToUnorderedSequence {X} {I : FiniteSet} (f:I -> X) : UnorderedSequence X := (I,,f). Definition NonemptySequenceToFunction {X} (x:NonemptySequence X) := pr2 x : stn (length' x) -> X. Coercion NonemptySequenceToFunction : NonemptySequence >-> Funclass. Definition NonemptySequenceToSequence {X} (x:NonemptySequence X) := functionToSequence (NonemptySequenceToFunction x) : Sequence X. Coercion NonemptySequenceToSequence : NonemptySequence >-> Sequence. (** *** Lemmas *) Definition composeSequence {X Y} (f:X->Y) : Sequence X -> Sequence Y := λ x, functionToSequence (f ∘ x). Definition composeSequence' {X m n} (f:stn n -> X) (g:stn m -> stn n) : Sequence X := functionToSequence (f ∘ g). Definition composeUnorderedSequence {X Y} (f:X->Y) : UnorderedSequence X -> UnorderedSequence Y := λ x, functionToUnorderedSequence(f ∘ x). Definition weqListSequence {X} : list X ≃ Sequence X. Proof. intros. apply weqfibtototal; intro n. apply weqvecfun. Defined. Definition transport_stn m n i (b:i f = g. Proof. intros e. induction f as [m f]. induction g as [n g]. simpl in p. apply (total2_paths2_f p). now apply vectorEquality. Defined. (** The following two lemmas are the key lemmas that allow to prove (transportational) equality of sequences whose lengths are not definitionally equal. In particular, these lemmas can be used in the proofs of such results as associativity of concatenation of sequences and the right unity axiom for the empty sequence. **) Definition seq_key_eq_lemma {X :UU}( g g' : Sequence X)(e_len : length g = length g') (e_el : forall ( i : nat )(ltg : i < length g )(ltg' : i < length g' ), g (i ,, ltg) = g' (i ,, ltg')) : g=g'. Proof. intros. induction g as [m g]; induction g' as [m' g']. simpl in e_len, e_el. intermediate_path (m' ,, transportf (λ i, stn i -> X) e_len g). - apply transportf_eq. - apply maponpaths. intermediate_path (g ∘ transportb stn e_len). + apply transportf_fun. + apply funextfun. intro x. induction x as [ i b ]. simple refine (_ @ e_el _ _ _). * simpl. apply maponpaths. apply transport_stn. Defined. (** The following lemma requires in the assumption [ e_el ] only one comparison [ i < length g ] and one comparison [ i < length g' ] for each i instead of all such comparisons as in the original version [ seq_key_eq_lemma ] . **) Definition seq_key_eq_lemma' {X :UU} (g g' : Sequence X) : length g = length g' -> (∏ i, ∑ ltg : i < length g, ∑ ltg' : i < length g', g (i ,, ltg) = g' (i ,, ltg')) -> g=g'. Proof. intros k r. apply seq_key_eq_lemma. * assumption. * intros. induction (r i) as [ p [ q e ]]. simple refine (_ @ e @ _). - now apply maponpaths, isinjstntonat. - now apply maponpaths, isinjstntonat. Defined. Notation fromstn0 := empty_vec. Definition nil {X} : Sequence X. Proof. intros. exact (0,, empty_vec). Defined. Definition append {X} : Sequence X -> X -> Sequence X. Proof. intros x y. exact (S (length x),, append_vec (pr2 x) y). Defined. Definition drop_and_append {X n} (x : stn (S n) -> X) : append (n,,x ∘ dni_lastelement) (x lastelement) = (S n,, x). Proof. intros. apply pair_path_in2. apply drop_and_append_vec. Defined. Local Notation "s □ x" := (append s x) (at level 64, left associativity). Definition nil_unique {X} (x : stn 0 -> X) : nil = (0,,x). Proof. intros. unfold nil. apply maponpaths. apply isapropifcontr. apply iscontr_vector_0. Defined. (* induction principle for contractible types, as a warmup *) (* Three ways. Use induction: *) Definition iscontr_rect' X (i : iscontr X) (x0 : X) (P : X ->UU) (p0 : P x0) : ∏ x:X, P x. Proof. intros. induction (pr1 (isapropifcontr i x0 x)). exact p0. Defined. Definition iscontr_rect_compute' X (i : iscontr X) (x : X) (P : X ->UU) (p : P x) : iscontr_rect' X i x P p x = p. Proof. intros. (* this step might be a problem in more complicated situations: *) unfold iscontr_rect'. induction (pr1 (isasetifcontr i x x (idpath _) (pr1 (isapropifcontr i x x)))). reflexivity. Defined. (* ... or use weqsecovercontr, but specializing x to pr1 i: *) Definition iscontr_rect'' X (i : iscontr X) (P : X ->UU) (p0 : P (pr1 i)) : ∏ x:X, P x. Proof. intros. exact (invmap (weqsecovercontr P i) p0 x). Defined. Definition iscontr_rect_compute'' X (i : iscontr X) (P : X ->UU) (p : P(pr1 i)) : iscontr_rect'' X i P p (pr1 i) = p. Proof. try reflexivity. intros. exact (homotweqinvweq (weqsecovercontr P i) p). Defined. (* .... or use transport explicitly: *) Definition iscontr_adjointness X (is:iscontr X) (x:X) : pr1 (isapropifcontr is x x) = idpath x. (* we call this adjointness, because if [unit] had η-reduction, then adjointness of the weq [unit ≃ X] would give it to us, in the case where x is [pr1 is] *) Proof. intros. now apply isasetifcontr. Defined. Definition iscontr_rect X (is : iscontr X) (x0 : X) (P : X ->UU) (p0 : P x0) : ∏ x:X, P x. Proof. intros. exact (transportf P (pr1 (isapropifcontr is x0 x)) p0). Defined. Definition iscontr_rect_compute X (is : iscontr X) (x : X) (P : X ->UU) (p : P x) : iscontr_rect X is x P p x = p. Proof. intros. unfold iscontr_rect. now rewrite iscontr_adjointness. Defined. Corollary weqsecovercontr': (* reprove weqsecovercontr, move upstream *) ∏ (X:UU) (P:X->UU) (is:iscontr X), (∏ x:X, P x) ≃ P (pr1 is). Proof. intros. set (x0 := pr1 is). set (secs := ∏ x : X, P x). set (fib := P x0). set (destr := (λ f, f x0) : secs->fib). set (constr:= iscontr_rect X is x0 P : fib->secs). exists destr. apply (isweq_iso destr constr). - intros f. apply funextsec; intros x. unfold destr, constr. apply transport_section. - apply iscontr_rect_compute. Defined. (* *) Definition nil_length {X} (x : Sequence X) : length x = 0 <-> x = nil. Proof. intros. split. - intro e. induction x as [n x]. simpl in e. induction (!e). apply pathsinv0. apply nil_unique. - intro h. induction (!h). reflexivity. Defined. Definition drop {X} (x:Sequence X) : length x != 0 -> Sequence X. Proof. revert x. intros [n x] h. induction n as [|n]. - simpl in h. contradicts h (idpath 0). - exact (n,,x ∘ dni_lastelement). Defined. Definition drop' {X} (x:Sequence X) : x != nil -> Sequence X. Proof. intros h. exact (drop x (pr2 (logeqnegs (nil_length x)) h)). Defined. Lemma append_and_drop_fun {X n} (x : stn n -> X) y : append_vec x y ∘ dni lastelement = x. Proof. intros. apply funextsec; intros i. simpl. unfold append_vec. induction (natlehchoice4 (pr1 (dni lastelement i)) n (pr2 (dni lastelement i))) as [I|J]. - simpl. apply maponpaths. apply subtypePath_prop. simpl. apply di_eq1. exact (stnlt i). - apply fromempty. simpl in J. assert (P : di n i = i). { apply di_eq1. exact (stnlt i). } induction (!P); clear P. induction i as [i r]. simpl in J. induction J. exact (isirreflnatlth _ r). Defined. Definition drop_and_append' {X n} (x : stn (S n) -> X) : append (drop (S n,,x) (negpathssx0 _)) (x lastelement) = (S n,, x). Proof. intros. simpl. apply pair_path_in2. apply drop_and_append_vec. Defined. Definition disassembleSequence {X} : Sequence X -> coprod unit (X × Sequence X). Proof. intros x. induction x as [n x]. induction n as [|n]. - exact (ii1 tt). - exact (ii2(x lastelement,,(n,,x ∘ dni_lastelement))). Defined. Definition assembleSequence {X} : coprod unit (X × Sequence X) -> Sequence X. Proof. intros co. induction co as [t|p]. - exact nil. - exact (append (pr2 p) (pr1 p)). Defined. Lemma assembleSequence_ii2 {X} (p : X × Sequence X) : assembleSequence (ii2 p) = append (pr2 p) (pr1 p). Proof. reflexivity. Defined. Theorem SequenceAssembly {X} : Sequence X ≃ unit ⨿ (X × Sequence X). Proof. intros. exists disassembleSequence. apply (isweq_iso _ assembleSequence). { intros. induction x as [n x]. induction n as [|n]. { apply nil_unique. } apply drop_and_append'. } intros co. induction co as [t|p]. { unfold disassembleSequence; simpl. apply maponpaths. apply proofirrelevancecontr. apply iscontrunit. } induction p as [x y]. induction y as [n y]. apply (maponpaths (@inr unit (X × Sequence X))). unfold append_vec, lastelement; simpl. unfold append_vec. simpl. induction (natlehchoice4 n n (natgthsnn n)) as [e|e]. { contradicts e (isirreflnatlth n). } simpl. apply maponpaths, maponpaths. apply funextfun; intro i. clear e. induction i as [i b]. unfold dni_lastelement; simpl. induction (natlehchoice4 i n (natlthtolths i n b)) as [d|d]. { simpl. apply maponpaths. now apply isinjstntonat. } simpl. induction d; contradicts b (isirreflnatlth i). Defined. Definition Sequence_rect {X} {P : Sequence X ->UU} (p0 : P nil) (ind : ∏ (x : Sequence X) (y : X), P x -> P (append x y)) (x : Sequence X) : P x. Proof. intros. induction x as [n x]. induction n as [|n IH]. - exact (transportf P (nil_unique x) p0). - exact (transportf P (drop_and_append x) (ind (n,,x ∘ dni_lastelement) (x lastelement) (IH (x ∘ dni_lastelement)))). Defined. Lemma Sequence_rect_compute_nil {X} {P : Sequence X ->UU} (p0 : P nil) (ind : ∏ (s : Sequence X) (x : X), P s -> P (append s x)) : Sequence_rect p0 ind nil = p0. Proof. intros. try reflexivity. unfold Sequence_rect; simpl. change p0 with (transportf P (idpath nil) p0) at 2. apply (maponpaths (λ e, transportf P e p0)). exact (maponpaths (maponpaths functionToSequence) (iscontr_adjointness _ _ _)). Defined. Lemma Sequence_rect_compute_cons {X} {P : Sequence X ->UU} (p0 : P nil) (ind : ∏ (s : Sequence X) (x : X), P s -> P (append s x)) (p := Sequence_rect p0 ind) (x:X) (l:Sequence X) : p (append l x) = ind l x (p l). Proof. intros. cbn. (* proof needed to complete induction for sequences *) Abort. Lemma append_length {X} (x:Sequence X) (y:X) : length (append x y) = S (length x). Proof. intros. reflexivity. Defined. Definition concatenate {X : UU} : binop (Sequence X) := λ x y, functionToSequence (concatenate' x y). Definition concatenate_length {X} (x y:Sequence X) : length (concatenate x y) = length x + length y. Proof. intros. reflexivity. Defined. Definition concatenate_0 {X} (s t:Sequence X) : length t = 0 -> concatenate s t = s. Proof. induction s as [m s]. induction t as [n t]. intro e; simpl in e. induction (!e). simple refine (sequenceEquality2 _ _ _ _). - simpl. apply natplusr0. - intro i; simpl in i. simpl. unfold concatenate'. rewrite weqfromcoprodofstn_invmap_r0. simpl. reflexivity. Defined. Definition concatenateStep {X : UU} (x : Sequence X) {n : nat} (y : stn (S n) -> X) : concatenate x (S n,,y) = append (concatenate x (n,,y ∘ dni lastelement)) (y lastelement). Proof. revert x n y. induction x as [m l]. intros n y. use seq_key_eq_lemma. - cbn. apply natplusnsm. - intros i r s. unfold concatenate, concatenate', weqfromcoprodofstn_invmap; cbn. unfold append_vec, coprod_rect; cbn. induction (natlthorgeh i m) as [H | H]. + induction (natlehchoice4 i (m + n) s) as [H1 | H1]. * reflexivity. * apply fromempty. induction (!H1); clear H1. set (tmp := natlehnplusnm m n). set (tmp2 := natlehlthtrans _ _ _ tmp H). exact (isirreflnatlth _ tmp2). + induction (natlehchoice4 i (m + n) s) as [I|J]. * apply maponpaths, subtypePath_prop. rewrite replace_dni_last. reflexivity. * apply maponpaths, subtypePath_prop. simpl. induction (!J). rewrite natpluscomm. apply plusminusnmm. Qed. Definition flatten {X : UU} : Sequence (Sequence X) -> Sequence X. Proof. intros x. exists (stnsum (length ∘ x)). exact (flatten' (sequenceToFunction ∘ x)). Defined. Definition flattenUnorderedSequence {X : UU} : UnorderedSequence (UnorderedSequence X) -> UnorderedSequence X. Proof. intros x. use tpair. - exact ((∑ i, pr1 (x i))%finset). - intros ij. exact (x (pr1 ij) (pr2 ij)). (* could also have used (uncurry (unorderedSequenceToFunction x)) here *) Defined. Definition flattenStep' {X n} (m : stn (S n) → nat) (x : ∏ i : stn (S n), stn (m i) → X) (m' := m ∘ dni lastelement) (x' := x ∘ dni lastelement) : flatten' x = concatenate' (flatten' x') (x lastelement). Proof. intros. apply funextfun; intro i. unfold flatten'. unfold funcomp. rewrite 2 weqstnsum1_eq'. unfold StandardFiniteSets.weqstnsum_invmap at 1. unfold concatenate'. unfold nat_rect, coprod_rect, funcomp. change (weqfromcoprodofstn_invmap (stnsum (λ r : stn n, m (dni lastelement r)))) with (weqfromcoprodofstn_invmap (stnsum m')) at 1 2. induction (weqfromcoprodofstn_invmap (stnsum m')) as [B|C]. - reflexivity. - now induction C. (* not needed with primitive projections *) Defined. Definition flattenStep {X} (x: NonemptySequence (Sequence X)) : flatten x = concatenate (flatten (composeSequence' x (dni lastelement))) (lastValue x). Proof. intros. apply pair_path_in2. set (xlens := λ i, length(x i)). set (xvals := λ i, λ j:stn (xlens i), x i j). exact (flattenStep' xlens xvals). Defined. (* partitions *) Definition partition' {X n} (f:stn n -> nat) (x:stn (stnsum f) -> X) : stn n -> Sequence X. Proof. intros i. exists (f i). intro j. exact (x(inverse_lexicalEnumeration f (i,,j))). Defined. Definition partition {X n} (f:stn n -> nat) (x:stn (stnsum f) -> X) : Sequence (Sequence X). Proof. intros. exists n. exact (partition' f x). Defined. Definition flatten_partition {X n} (f:stn n -> nat) (x:stn (stnsum f) -> X) : flatten (partition f x) ~ x. Proof. intros. intro i. change (x (weqstnsum1 f (pr1 (invmap (weqstnsum1 f) i),, pr2 (invmap (weqstnsum1 f) i))) = x i). apply maponpaths. apply subtypePath_prop. now rewrite homotweqinvweq. Defined. (* associativity of "concatenate" *) Definition isassoc_concatenate {X : UU} (x y z : Sequence X) : concatenate (concatenate x y) z = concatenate x (concatenate y z). Proof. use seq_key_eq_lemma. - cbn. apply natplusassoc. - intros i ltg ltg'. cbn. unfold concatenate'. unfold weqfromcoprodofstn_invmap. unfold coprod_rect. cbn. induction (natlthorgeh i (length x + length y)) as [H | H]. + induction (natlthorgeh (make_stn (length x + length y) i H) (length x)) as [H1 | H1]. * induction (natlthorgeh i (length x)) as [H2 | H2]. -- apply maponpaths. apply isinjstntonat. apply idpath. -- apply fromempty. exact (natlthtonegnatgeh i (length x) H1 H2). * induction (natchoice0 (length y)) as [H2 | H2]. -- apply fromempty. induction H2. induction (! (natplusr0 (length x))). apply (natlthtonegnatgeh i (length x) H H1). -- induction (natlthorgeh i (length x)) as [H3 | H3]. ++ apply fromempty. apply (natlthtonegnatgeh i (length x) H3 H1). ++ induction (natchoice0 (length y + length z)) as [H4 | H4]. ** apply fromempty. induction (! H4). use (isirrefl_natneq (length y)). use natlthtoneq. use (natlehlthtrans (length y) (length y + length z) (length y) _ H2). apply natlehnplusnm. ** cbn. induction (natlthorgeh (i - length x) (length y)) as [H5 | H5]. --- apply maponpaths. apply isinjstntonat. apply idpath. --- apply fromempty. use (natlthtonegnatgeh (i - (length x)) (length y)). +++ set (tmp := natlthandminusl i (length x + length y) (length x) H (natlthandplusm (length x) _ H2)). rewrite (natpluscomm (length x) (length y)) in tmp. rewrite plusminusnmm in tmp. exact tmp. +++ exact H5. + induction (natchoice0 (length z)) as [H1 | H1]. * apply fromempty. cbn in ltg. induction H1. rewrite natplusr0 in ltg. exact (natlthtonegnatgeh i (length x + length y) ltg H). * induction (natlthorgeh i (length x)) as [H2 | H2]. -- apply fromempty. use (natlthtonegnatgeh i (length x) H2). use (istransnatgeh i (length x + length y) (length x) H). apply natgehplusnmn. -- induction (natchoice0 (length y + length z)) as [H3 | H3]. ++ apply fromempty. cbn in ltg'. induction H3. rewrite natplusr0 in ltg'. exact (natlthtonegnatgeh i (length x) ltg' H2). ++ cbn. induction (natlthorgeh (i - length x) (length y)) as [H4 | H4]. ** apply fromempty. use (natlthtonegnatgeh i (length x + length y) _ H). apply (natlthandplusr _ _ (length x)) in H4. rewrite minusplusnmm in H4. --- rewrite natpluscomm in H4. exact H4. --- exact H2. ** apply maponpaths. apply isinjstntonat. cbn. apply (! (natminusminus _ _ _)). Qed. (** Reverse *) Definition reverse {X : UU} (x : Sequence X) : Sequence X := functionToSequence (fun i : (stn (length x)) => x (dualelement i)). Lemma reversereverse {X : UU} (x : Sequence X) : reverse (reverse x) = x. Proof. induction x as [n x]. apply pair_path_in2. apply funextfun; intro i. unfold reverse, dualelement, coprod_rect. cbn. induction (natchoice0 n) as [H | H]. + apply fromempty. rewrite <- H in i. now apply negstn0. + cbn. apply maponpaths. apply isinjstntonat. apply minusminusmmn. apply natgthtogehm1. apply stnlt. Qed. Lemma reverse_index {X : UU} (x : Sequence X) (i : stn (length x)) : (reverse x) (dualelement i) = x i. Proof. cbn. unfold dualelement, coprod_rect. set (e := natgthtogehm1 (length x) i (stnlt i)). induction (natchoice0 (length x)) as [H' | H']. - apply maponpaths. apply isinjstntonat. cbn. apply (minusminusmmn _ _ e). - apply maponpaths. apply isinjstntonat. cbn. apply (minusminusmmn _ _ e). Qed. Lemma reverse_index' {X : UU} (x : Sequence X) (i : stn (length x)) : (reverse x) i = x (dualelement i). Proof. cbn. unfold dualelement, coprod_rect. induction (natchoice0 (length x)) as [H' | H']. - apply maponpaths. apply isinjstntonat. cbn. apply idpath. - apply maponpaths. apply isinjstntonat. cbn. apply idpath. Qed. UniMath-20231010/UniMath/Combinatorics/FiniteSets.v000066400000000000000000000446051451125700300217250ustar00rootroot00000000000000(** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011. This file contains the definition and main properties of finite sets. In the file [Combinatorics/Tests.v] there are several elementary examples which are used as test cases to check that our constructions do not prevent Coq from normalizing terms of type nat to numerals. *) (** ** Preamble *) (** Imports. *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.DecidablePropositions. Require Import UniMath.MoreFoundations.NegativePropositions. Require Export UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.MoreFoundations.Subtypes. Local Open Scope stn. (** ** Sets with a given number of elements. *) Section nelstructure. (** *** Structure of a set with [n] elements on [X] defined as a term in [⟦ n ⟧ ≃ X]. *) Definition nelstruct (n : nat) (X : UU) : UU := ⟦ n ⟧ ≃ X. Definition nelstructToFunction {n : nat} {X : UU} (S : nelstruct n X) : ⟦ n ⟧ -> X := pr1weq S. Coercion nelstructToFunction : nelstruct >-> Funclass. Definition nelstructonstn (n : nat) : nelstruct n (⟦ n ⟧) := idweq (⟦ n ⟧). Definition nelstructweqf {X Y : UU} {n : nat} (w : X ≃ Y) (sx : nelstruct n X) : nelstruct n Y := weqcomp sx w. Definition nelstructweqb {X Y : UU} {n : nat} (w : X ≃ Y) (sy : nelstruct n Y) : nelstruct n X := weqcomp sy (invweq w). Definition nelstructonempty : nelstruct 0 empty := weqstn0toempty. Definition nelstructonempty2 {X : UU} (nx : neg X) : nelstruct 0 X := weqcomp weqstn0toempty (invweq (weqtoempty nx)). Definition nelstructonunit : nelstruct 1 unit := weqstn1tounit. Definition nelstructoncontr {X : UU} (contrx : iscontr X) : nelstruct 1 X := weqcomp weqstn1tounit (invweq (weqcontrtounit contrx)). Definition nelstructonbool : nelstruct 2 bool := weqstn2tobool. Definition nelstructoncoprodwithunit {X : UU} {n : nat} (sx : nelstruct n X) : nelstruct (S n) (X ⨿ unit) := weqcomp (invweq (weqdnicoprod n lastelement)) (weqcoprodf1 sx). Definition nelstructoncompl {X : UU} {n : nat} (x : X) : nelstruct (S n) X -> nelstruct n (compl X x). Proof. intros sx. refine (invweq (weqoncompl (invweq sx) x) ∘ _ ∘ weqdnicompl (invweq sx x))%weq. apply compl_weq_compl_ne. Defined. Definition nelstructoncoprod {X Y : UU} {n m : nat} (sx : nelstruct n X) (sy : nelstruct m Y) : nelstruct (n + m) (X ⨿ Y) := ((weqcoprodf sx sy) ∘ (invweq (weqfromcoprodofstn n m)))%weq. Definition nelstructontotal2 {X : UU} {n : nat} (P : X -> UU) (f : X -> nat) (sx : nelstruct n X) (fs : ∏ x : X, nelstruct (f x) (P x)) : nelstruct (stnsum (f ∘ sx)) (∑ (y : X), P y) := weqcomp (invweq (weqstnsum (P ∘ sx) (f ∘ sx) (fs ∘ sx))) (weqfp sx P). Definition nelstructondirprod {X Y : UU} {n m : nat} (sx : nelstruct n X) (sy : nelstruct m Y) : nelstruct (n * m) (X × Y) := (weqdirprodf sx sy ∘ invweq (weqfromprodofstn n m))%weq. (** For a generalization of [ weqfromdecsubsetofstn ] see below *) Definition nelstructonfun {X Y : UU} {n m : nat} (sx : nelstruct n X) (sy : nelstruct m Y) : nelstruct (natpower m n) (X -> Y) := (weqbfun Y (invweq sx) ∘ weqffun (⟦ n ⟧) sy ∘ invweq (weqfromfunstntostn n m))%weq. Definition nelstructonforall {X : UU} {n : nat} (P : X -> UU) (f : X -> nat) (sx : nelstruct n X) (fs : ∏ x : X , nelstruct (f x) (P x)) : nelstruct (stnprod (f ∘ sx)) (∏ x : X , P x) := invweq (weqcomp (weqonsecbase P sx) (weqstnprod (P ∘ sx) (f ∘ sx) (λ i : ⟦ n ⟧, fs (sx i)))). Definition nelstructonweq {X : UU} {n : nat} (sx : nelstruct n X) : nelstruct (factorial n) (X ≃ X) := (weqfweq X sx ∘ weqbweq (⟦ n ⟧) (invweq sx) ∘ invweq (weqfromweqstntostn n))%weq. End nelstructure. Section nelproperty. (** *** The property of [ X ] to have [ n ] elements *) Definition isofnel (n : nat) (X : UU) : hProp := ∥ ⟦ n ⟧ ≃ X ∥. Definition isofneluniv {n : nat} {X : UU} (P : hProp) : ((nelstruct n X) -> P) -> (isofnel n X -> P). Proof. intros pnel xofnel. exact(hinhuniv pnel xofnel). Defined. Definition isofnelstn (n : nat) : isofnel n (⟦ n ⟧) := hinhpr (nelstructonstn n). Definition isofnelweqf {X Y : UU} {n : nat} (w : X ≃ Y) (sx : isofnel n X) : isofnel n Y := hinhfun (nelstructweqf w) sx. Definition isofnelweqb {X Y : UU} {n : nat} (w : X ≃ Y) (sy : isofnel n Y) : isofnel n X := hinhfun (nelstructweqb w) sy. Definition isofnelempty : isofnel 0 empty := hinhpr nelstructonempty. Definition isofnelempty2 {X : UU} (nx : neg X) : isofnel 0 X := hinhpr (nelstructonempty2 nx). Definition isofnelunit : isofnel 1 unit := hinhpr nelstructonunit. Definition isofnelcontr {X : UU} (contrx : iscontr X) : isofnel 1 X := hinhpr (nelstructoncontr contrx). Definition isofnelbool : isofnel 2 bool := hinhpr nelstructonbool. Definition isofnelcoprodwithunit {X : UU} {n : nat} (sx : isofnel n X) : isofnel (S n) (X ⨿ unit) := hinhfun nelstructoncoprodwithunit sx. Definition isofnelcompl {X : UU} {n : nat} (x : X) (sx : isofnel (S n) X) : isofnel n (compl X x) := hinhfun (nelstructoncompl x) sx. Definition isofnelcoprod {X Y : UU} {n m : nat} (sx : isofnel n X) (sy : isofnel m Y) : isofnel (n + m) (X ⨿ Y) := hinhfun2 nelstructoncoprod sx sy. (** For a result corresponding to [ nelstructontotal2 ] see below . *) Definition isofnelondirprod {X Y : UU} {n m : nat} (sx : isofnel n X) (sy : isofnel m Y) : isofnel (n * m) (X × Y) := hinhfun2 nelstructondirprod sx sy. Definition isofnelonfun {X Y : UU} {n m : nat} (sx : isofnel n X) (sy : isofnel m Y) : isofnel (natpower m n) (X -> Y) := hinhfun2 nelstructonfun sx sy. (** For a result corresponding to [ nelstructonforall ] see below . *) Definition isofnelonweq {X : UU} {n : nat} (sx : isofnel n X) : isofnel (factorial n) (X ≃ X) := hinhfun nelstructonweq sx. End nelproperty. (** ** General finite sets. *) Section finite_structure. (** *** Finite structure. A finite structure on a type [X] is defined as a pair [( n , w )] where [n : nat] and [w : ⟦ n ⟧ ≃ X]. *) Definition finstruct (X : UU) : UU := ∑ (n : nat), nelstruct n X. Definition finstruct_cardinality {X : UU} (fs : finstruct X) : nat := pr1 fs. Definition finstructToFunction {X : UU} (S : finstruct X) : nelstruct (pr1 S) X := pr2 S. Coercion finstructToFunction : finstruct >-> nelstruct. Definition make_finstruct (X : UU) {n : nat} (w : ⟦ n ⟧ ≃ X) : finstruct X := (n ,, w). Definition finstructonstn (n : nat) : finstruct (⟦ n ⟧) := make_finstruct _ (nelstructonstn n). Definition finstructweqf {X Y : UU} (w : X ≃ Y) (sx : finstruct X) : finstruct Y := make_finstruct Y (nelstructweqf w sx). Definition finstructweqb {X Y : UU} (w : X ≃ Y) (sy : finstruct Y) : finstruct X := make_finstruct X (nelstructweqb w sy). Definition finstructonempty : finstruct empty := make_finstruct empty nelstructonempty. Definition finstructonempty2 {X : UU} (nx : neg X) : finstruct X := make_finstruct X (nelstructonempty2 nx). Definition finstructonunit : finstruct unit := make_finstruct unit nelstructonunit. Definition finstructoncontr {X : UU} (xcontr : iscontr X) : finstruct X := make_finstruct X (nelstructoncontr xcontr). (** It is not difficult to show that a direct summand of a finite set is a finite set. As a corrolary it follows that a proposition (a type of h-level 1) is a finite set if and only if it is decidable . *) Definition finstructonbool : finstruct bool := make_finstruct bool nelstructonbool. Definition finstructoncoprodwithunit {X : UU} (sx : finstruct X) : finstruct (X ⨿ unit) := make_finstruct (X ⨿ unit) (nelstructoncoprodwithunit sx). Definition finstructoncompl {X : UU} (x : X) (sx : finstruct X) : finstruct (compl X x). Proof. destruct sx as [n w]. induction n as [| n ]. - exact(fromempty (negstn0 (invweq w x))). - exact(make_finstruct (compl X x) (nelstructoncompl x w)). Defined. Definition finstructoncoprod {X Y : UU} (sx : finstruct X) (sy : finstruct Y) : finstruct (X ⨿ Y) := make_finstruct (X ⨿ Y) (nelstructoncoprod sx sy). Definition finstructontotal2 {X : UU} (P : X -> UU) (sx : finstruct X) (fs : ∏ x : X, finstruct (P x)) : finstruct (∑ (x : X), P x) := make_finstruct _ (nelstructontotal2 P (λ x : X, finstruct_cardinality (fs x)) sx (λ x : X, fs x)). Definition finstructondirprod {X Y : UU} (sx : finstruct X) (sy : finstruct Y) : finstruct (X × Y) := make_finstruct (X × Y) (nelstructondirprod sx sy). Definition finstructondecsubset {X : UU} (f : X -> bool) (sx : finstruct X) : finstruct (hfiber f true) := make_finstruct _ (weqcomp (invweq (pr2 (weqfromdecsubsetofstn (f ∘ sx)))) (weqhfibersgwtog _ f true)). Definition finstructonfun {X Y : UU} (sx : finstruct X) (sy : finstruct Y) : finstruct (X -> Y) := make_finstruct _ (nelstructonfun sx sy). Definition finstructonforall {X : UU} (P : X -> UU) (sx : finstruct X) (fs : ∏ x : X , finstruct (P x)) : finstruct (∏ x : X , P x) := make_finstruct _ (nelstructonforall P _ sx fs). Definition finstructonweq {X : UU} (sx : finstruct X) : finstruct (X ≃ X) := make_finstruct (X ≃ X) (nelstructonweq sx). End finite_structure. Section finite_property. (** *** Finite types. A type [X] is finite if it is merely equipped with some finite structure. *) Definition isfinite (X : UU) : hProp := ∥ finstruct X ∥. Definition isfinite_isdeceq (X : UU) : isfinite X -> isdeceq X. (* uses funextemptyAxiom *) Proof. intros isfin. use(factor_through_squash (isapropisdeceq X) _ isfin). intro fstruct. use(isdeceqweqf _ (isdeceqstn (finstruct_cardinality fstruct))). apply fstruct. Defined. Definition isfinite_isaset (X : UU) : isfinite X -> isaset X. Proof. intros isfin. use(factor_through_squash (isapropisaset X) _ isfin). intros f. use(isofhlevelweqf 2 _ (isasetstn (finstruct_cardinality f))). apply f. Defined. Definition fincard {X : UU} (xf : isfinite X) : nat. Proof. apply (squash_pairs_to_set (λ n : nat, ⟦ n ⟧ ≃ X) isasetnat). { intros n n' w w'. apply weqtoeqstn. exact (invweq w' ∘ w)%weq. } assumption. Defined. Definition ischoicebasefiniteset {X : UU} (xf : isfinite X) : ischoicebase X. Proof. use(hinhuniv _ xf). intros [n w]. exact(ischoicebaseweqf w (ischoicebasestn n)). Defined. Definition isfinitestn (n : nat) : isfinite (⟦ n ⟧) := hinhpr (finstructonstn n). Definition isfiniteweqf {X Y : UU} (w : X ≃ Y) (sx : isfinite X) : isfinite Y := hinhfun (finstructweqf w) sx. Definition isfiniteweqb {X Y : UU} (w : X ≃ Y) (sy : isfinite Y) : isfinite X := hinhfun (finstructweqb w) sy. Definition isfiniteempty : isfinite empty := hinhpr finstructonempty. Definition isfiniteempty2 {X : UU} (nx : neg X) : isfinite X := hinhpr (finstructonempty2 nx). Definition isfiniteunit : isfinite unit := hinhpr finstructonunit. Definition isfinitecontr {X : UU} (contrx : iscontr X) : isfinite X := hinhpr (finstructoncontr contrx). Definition isfinitebool : isfinite bool := hinhpr finstructonbool. Definition isfinitecoprodwithunit {X : UU} (sx : isfinite X) : isfinite (X ⨿ unit) := hinhfun finstructoncoprodwithunit sx. Definition isfinitecompl {X : UU} (x : X) (sx : isfinite X) : isfinite (compl X x) := hinhfun (finstructoncompl x) sx. Definition isfinitecoprod {X Y : UU} (sx : isfinite X) (sy : isfinite Y) : isfinite (X ⨿ Y) := hinhfun2 finstructoncoprod sx sy. Definition isfinitetotal2 {X : UU} (P : X -> UU) (sx : isfinite X) (fs : ∏ x : X , isfinite (P x)) : isfinite (∑ (x : X), P x). Proof. set (fs' := ischoicebasefiniteset sx _ fs). use(hinhfun2 _ fs' sx). intros. apply finstructontotal2; assumption. Defined. Definition isfinitedirprod {X Y : UU} (sx : isfinite X) (sy : isfinite Y) : isfinite (X × Y) := hinhfun2 finstructondirprod sx sy. Definition isfinitedecsubset {X : UU} (f : X -> bool) (sx : isfinite X) : isfinite (hfiber f true) := hinhfun (finstructondecsubset f) sx. Definition isfinitefun {X Y : UU} (sx : isfinite X) (sy : isfinite Y) : isfinite (X -> Y) := hinhfun2 finstructonfun sx sy. Definition isfiniteforall {X : UU} (P : X -> UU) (sx : isfinite X) (fs : ∏ x : X , isfinite (P x)) : isfinite (∏ (x : X) , P x). Proof. set (fs' := ischoicebasefiniteset sx _ fs). exact(hinhfun2 (fun a b => finstructonforall P b a) fs' sx). Defined. Definition isfiniteweq {X : UU} (sx : isfinite X) : isfinite (X ≃ X) := hinhfun finstructonweq sx. End finite_property. (* (* The cardinality of finite sets using double negation and decidability of equality in nat. *) Definition carddneg (X : UU) (fx: isfinite X) : nat := pr1 (isfiniteimplisfinite0 X fx). Definition preweq ( X : UU ) (is: isfinite X): isofnel (carddneg X is) X. Proof. intros X is X0. set (c:= carddneg X is). set (dnw:= pr2 (isfiniteimplisfinite0 X is)). simpl in dnw. change (pr1 nat (λ n : nat, isofnel0 n X) (isfiniteimplisfinite0 X is)) with c in dnw. assert (f: dirprod (finitestruct X) (dneg (weq (stn c) X)) -> weq (stn c) X). intro H. destruct H as [ t x ]. destruct t as [ t x0 ]. assert (dw: dneg ((stn t) ≃ (stn c))). set (ff:= fun ab:dirprod (weq (stn t) X)(weq (stn c) X) => weqcomp _ _ _ (pr1 ab) (invweq (pr2 ab))). apply (dnegf _ _ ff (inhdnegand _ _ (todneg _ x0) x)). assert (e:t = c). apply (stnsdnegweqtoeq _ _ dw). clear dnw. destruct e. assumption. unfold isofnel. apply (hinhfun _ _ f (hinhand (finitestruct X) _ is (hinhpr dnw))). Defined. *) (* to be completed Theorem carddnegweqf (X Y:UU)(f: X -> Y)(isw:isweq f)(isx: isfinite X): paths (carddneg _ isx) (carddneg _ (isfiniteweqf _ _ _ isw isx)). Proof. intros. *) (* The cardinality of finite sets defined using the "impredicative" ishinh *) Definition isfinite_to_DecidableEquality {X : UU} : isfinite X -> DecidableRelation X. Proof. intros fin x y. exact (@isdecprop_to_DecidableProposition (x=y) (isdecpropif (x=y) (isfinite_isaset X fin x y) (isfinite_isdeceq X fin x y))). Defined. Definition subsetFiniteness {X : UU} (is : isfinite X) (P : DecidableSubtype X) : isfinite (decidableSubtypeCarrier P). Proof. intros. assert (fin : isfinite (decidableSubtypeCarrier' P)). { now apply isfinitedecsubset. } refine (isfiniteweqf _ fin). apply decidableSubtypeCarrier_weq. Defined. Definition fincard_subset {X : UU} (fx : isfinite X) (P : DecidableSubtype X) : nat := fincard (subsetFiniteness fx P). Definition fincard_standardSubset {n : nat} (P : DecidableSubtype (⟦ n ⟧)) : nat := fincard (subsetFiniteness (isfinitestn n) P). Local Definition bound01 (P : DecidableProposition) : ((choice P 1 0) ≤ 1)%nat. Proof. unfold choice. choose P p q; reflexivity. Defined. Definition tallyStandardSubset {n : nat} (P : DecidableSubtype (⟦ n ⟧)) : ⟦ S n ⟧. Proof. exists (stnsum (λ x, choice (P x) 1 0)). apply natlehtolthsn. apply (istransnatleh (m := stnsum(λ _ : stn n, 1))). { apply stnsum_le; intro i. apply bound01. } assert (p : ∏ r s : nat, r = s -> (r ≤ s)%nat). { intros ? ? e. destruct e. apply isreflnatleh. } apply p. exact(stnsum_1 n). Defined. Definition tallyStandardSubsetSegment {n : nat} (P : DecidableSubtype (⟦ n ⟧)) (i : ⟦ n ⟧) : ⟦ n ⟧. Proof. (* count how many elements less than i satisfy P *) assert (k := tallyStandardSubset (λ j : ⟦ i ⟧, P (stnmtostnn i n (natlthtoleh i n (pr2 i)) j))). apply (stnmtostnn (S i) n). { apply natlthtolehsn. exact(pr2 i). } exact k. Defined. Section finite_subsets. Local Open Scope subtype. Definition finite_subset (X : hSet) : UU := ∑ (A : hsubtype X), isfinite (carrier A). Definition make_finite_subset {X : hSet} (A : hsubtype X) (P : isfinite (carrier A)) : finite_subset X := (A ,, P). Definition subtype_from_finite_subset {X : hSet} (A : finite_subset X) : hsubtype X := pr1 A. Coercion subtype_from_finite_subset : finite_subset >-> hsubtype. Lemma isfinite_singleton {X : hSet} {x : X} : isfinite (singleton x). Proof. apply isfinitecontr. apply iscontr_singleton. Qed. Definition finite_singleton {X : hSet} (x : X) : finite_subset X. Proof. use make_finite_subset. - exact(singleton x). - exact isfinite_singleton. Defined. Definition finite_singleton_is_in {X : hSet} (A : hsubtype X) (a : A) : finite_singleton (pr1 a) ⊆ A. Proof. apply singleton_is_in. Defined. End finite_subsets. Section FiniteSets. Definition FiniteSet : UU := ∑ (X : UU), isfinite X. Definition isfinite_to_FiniteSet {X : UU} (f : isfinite X) : FiniteSet := X ,, f. Definition FiniteSet_to_hSet (X : FiniteSet) : hSet := make_hSet (pr1 X) (isfinite_isaset (pr1 X) (pr2 X)). Coercion FiniteSet_to_hSet : FiniteSet >-> hSet. Definition FiniteSetSum {I : FiniteSet} (X : I -> FiniteSet) : FiniteSet. Proof. intros. exists (∑ i, X i). apply isfinitetotal2. - exact (pr2 I). - exact (λ (i : I), pr2 (X i)). Defined. Definition cardinalityFiniteSet (X : FiniteSet) : nat := fincard (pr2 X). Definition standardFiniteSet (n : nat) : FiniteSet := isfinite_to_FiniteSet (isfinitestn n). Definition subsetFiniteSet {X : FiniteSet} (P : DecidableSubtype X) : FiniteSet. Proof. exact(isfinite_to_FiniteSet (subsetFiniteness (pr2 X) P)). Defined. End FiniteSets. Declare Scope finset. Delimit Scope finset with finset. Notation "'∑' x .. y , P" := (FiniteSetSum (λ x,.. (FiniteSetSum (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : finset. (* type this in emacs in agda-input method with \sum *) UniMath-20231010/UniMath/Combinatorics/Graph.v000066400000000000000000000075621451125700300207120ustar00rootroot00000000000000(* ******************************************************************************* *) (** * Bicategory of graphs Benedikt Ahrens, Marco Maggesi May 2018 Revised June 2019 ********************************************************************************* *) Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.Propositions. (** ** Pregraphs. *) Definition pregraph : UU := ∑ N : UU, N → N → UU. Definition make_pregraph : ∏ N : UU, (N → N → UU) → pregraph := tpair _. Definition vertex : pregraph → UU := pr1. Definition edge : ∏ G : pregraph, vertex G → vertex G → UU := pr2. Definition has_vertexset (G : pregraph) : UU := isaset (vertex G). Definition isaprop_has_vertexset (G : pregraph) : isaprop (has_vertexset G) := isapropisaset (vertex G). Definition has_edgesets (G : pregraph) : UU := ∏ x y : vertex G, isaset (edge G x y). (** ** Graphs. *) Definition graph : UU := ∑ G : pregraph, has_vertexset G × has_edgesets G. Definition make_graph (G : pregraph) (h : has_vertexset G) (k : has_edgesets G) : graph := G,, make_dirprod h k. Definition pregraph_of_graph : graph → pregraph := pr1. Coercion pregraph_of_graph : graph >-> pregraph. Definition isaset_vertex (G : graph) : isaset (vertex G) := pr12 G. Definition isaset_edge (G : graph) : ∏ x y : vertex G, isaset (edge G x y) := pr22 G. (** ** Graph morphisms. *) Definition graph_mor (G H : pregraph) : UU := ∑ (f₀ : vertex G → vertex H), (∏ x y : vertex G, edge G x y → edge H (f₀ x) (f₀ y)). Definition make_graph_mor {G H : pregraph} : ∏ (f₀ : vertex G → vertex H) (f₁ : ∏ x y : vertex G, edge G x y → edge H (f₀ x) (f₀ y)), graph_mor G H := tpair _. Definition onvertex {G H : pregraph} : ∏ (p : graph_mor G H), vertex G → vertex H := pr1. Definition onedge {G H : pregraph} (p : graph_mor G H) {x y : vertex G} : edge G x y → edge H (onvertex p x) (onvertex p y) := pr2 p x y. Definition graph_mor_id (G : pregraph) : graph_mor G G := make_graph_mor (idfun (vertex G)) (λ x y : vertex G, idfun (edge G x y)). Definition graph_mor_comp {G H K: pregraph} (p : graph_mor G H) (q : graph_mor H K) : graph_mor G K := make_graph_mor (onvertex q ∘ onvertex p) (λ (x y : vertex G) (f : edge G x y), onedge q (pr2 p x y f)). Lemma make_graph_mor_eq {G H : pregraph} (p₀ : vertex G → vertex H) (p₁ p₁' : ∏ x y : vertex G, edge G x y → edge H (p₀ x) (p₀ y)) (e : ∏ x y (f : edge G x y), p₁ x y f = p₁' x y f) : make_graph_mor p₀ p₁ = make_graph_mor p₀ p₁'. Proof. apply pair_path_in2. apply funextsec. intro x. apply funextsec. intro y. apply funextfun. intro f. apply e. Defined. Lemma graph_mor_id_left {G H : pregraph} (p : graph_mor G H) : graph_mor_comp (graph_mor_id G) p = p. Proof. induction p as (p₀,p₁). apply make_graph_mor_eq. intros. apply idpath. Defined. Lemma graph_mor_id_right {G H : pregraph} (p : graph_mor G H) : graph_mor_comp p (graph_mor_id H) = p. Proof. induction p as (p₀,p₁). apply make_graph_mor_eq. intros. apply idpath. Defined. Lemma graph_mor_comp_assoc {G1 G2 G3 G4 : pregraph} (p : graph_mor G1 G2) (q : graph_mor G2 G3) (r : graph_mor G3 G4) : graph_mor_comp p (graph_mor_comp q r) = graph_mor_comp (graph_mor_comp p q) r. Proof. induction p as (p₀,p₁). induction q as (q₀,q₁). induction r as (r₀,r₁). apply make_graph_mor_eq. intros. apply idpath. Qed. Lemma isaset_graph_mor {G H : pregraph} (h : has_vertexset H) (k : has_edgesets H) : isaset (graph_mor G H). Proof. apply isaset_total2. - exact (funspace_isaset h). - intro p₀. apply impred_isaset. intro x. apply impred_isaset. intro y. apply funspace_isaset. apply k. Qed. UniMath-20231010/UniMath/Combinatorics/GraphPaths.v000066400000000000000000000053711451125700300217060ustar00rootroot00000000000000(** Author: Floris van Doorn, december 2017 *) Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.Subtypes. (** Graphs. Contents: - paths in a graph (called gpaths to disambiguate from the identity type) - operations on paths *) (** In this file we consider graphs with a type of vertices and a type of edges between any pair of vertices. We could restrict to sets, but there is no reason to do that here. *) Definition issymmetric {V : UU} (E : V → V → UU) : UU := ∏u v, E u v ≃ E v u. Definition gpaths_of_length {V : UU} (E : V → V → UU) (v w : V) (n : nat) : UU. Proof. revert v. induction n as [|n IH]. - intro v. exact (v = w). - intro v. exact (∑u, E v u × IH u). Defined. Definition gpaths {V : UU} (E : V → V → UU) (v w : V) : UU := ∑n, gpaths_of_length E v w n. Definition nil {V : UU} {E : V → V → UU} (v : V) : gpaths E v v := (0,, idpath v). Definition cons {V : UU} {E : V → V → UU} {w u v : V} (e : E u v) (p : gpaths E v w) : gpaths E u w := (S (pr1 p),, (v,, (e,, pr2 p))). Local Notation "[]" := (nil _) (at level 0, format "[]"). Local Infix "::" := cons. Lemma gpaths_ind {V : UU} {E : V → V → UU} {w : V} (P : ∏{u}, gpaths E u w → UU) (H1 : P []) (H2 : ∏{u v} (e : E u v) (p : gpaths E v w), P p → P (e :: p)) {u : V} (p : gpaths E u w) : P p. Proof. induction p as [n p]. revert u p. induction n as [|n IH]. - induction p. exact H1. - induction p as [v x]. induction x as [e p]. apply (H2 _ _ _ (n,, p)). apply IH. Defined. Definition foldr {V : UU} {E : V → V → UU} {w : V} {B : V → UU} (f : ∏{u v}, E u v → B v → B u) (b : B w) : ∏{u : V}, gpaths E u w → B u. Proof. apply gpaths_ind. exact b. exact (λ u v e _ b, f u v e b). Defined. Definition concat {V : UU} {E : V → V → UU} {u v w : V} (p : gpaths E u v) (q : gpaths E v w) : gpaths E u w := foldr (λ _ _ , cons) q p. Local Infix "++" := concat. Definition append {V : UU} {E : V → V → UU} {u v w : V} (p : gpaths E u v) (e : E v w) : gpaths E u w := p ++ e::[]. Definition reverse {V : UU} {E : V → V → UU} (H : issymmetric E) {u v : V} (p : gpaths E u v) : gpaths E v u. Proof. revert u p. apply gpaths_ind. - exact []. - intros u u' e p q. exact (append q (invmap (H u' u) e)). Defined. Definition symmetric_closure {V : UU} (E : V → V → UU) (u v : V) : UU := E u v ⨿ E v u. Definition issymmetric_symmetric_closure {V : UU} (E : V → V → UU) : issymmetric (symmetric_closure E) := λ u v, weqcoprodcomm (E u v) (E v u). Definition reverse_in_closure {V : UU} {E : V → V → UU} {u v : V} (p : gpaths (symmetric_closure E) u v) : gpaths (symmetric_closure E) v u := reverse (issymmetric_symmetric_closure E) p. UniMath-20231010/UniMath/Combinatorics/KFiniteSubtypes.v000066400000000000000000000143121451125700300227300ustar00rootroot00000000000000 Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.Combinatorics.KFiniteTypes. (** * Kfinite Subtypes Some results on K-finite subtypes. [iskfinite_singleton] - Singletons are K-finite. [iskfinite_union] - A union of (Bishop-) finitely many K-finite subtypes is K-finite. [kfinite_subtype] - Definition of subtypes that are K-finite. *) Section kfinite_subtypes. Local Open Scope stn. Local Open Scope subtype. (* Singletons are always K-finite. *) Lemma iskfinite_singleton {X : UU} (x : X) : iskfinite (singleton x). Proof. apply kfinstruct_iskfinite. use(make_kfinstruct 1). - exact(λ (_ : ⟦ 1 ⟧), (x ,, hinhpr (idpath x))). - intros [z xz]. use(hinhfun _ xz); intro. use(make_hfiber _ (stnpr 0)). now apply subtypePath_prop. Qed. (* [indexed_carrier_to_carrier_union] and [reindex_carrier_union] need better names, and possibly be moved somewhere else (MoreFoundations/Subtypes.v?), they are currently only used to help prove that K-finite unions are K-finite. *) Definition indexed_carrier_to_carrier_union {X I : UU} (index : I → hsubtype X) : (∑ (i : I), (carrier (index i))) → (carrier (⋃ index)). Proof. intro h. (* This is not very pretty. *) exact(pr12 h ,, hinhpr (pr1 h ,, pr22 h)). Defined. Lemma issurjective_indexed_carrier_to_union {X I : UU} (index : I → hsubtype X) : issurjective (indexed_carrier_to_carrier_union index). Proof. intros [x in_union]. (* x ∈ ⋃ index *) use(hinhfun _ in_union). intros [i in_index]. (* ∑ (i : I), index i x *) use make_hfiber. - exact(i ,, x ,, in_index). (* ∑ (i : I), (carrier (index i)) *) - now apply subtypePath_prop. Qed. Definition reindex_carrier_union {X : UU} {I J : UU} (index : I → hsubtype X) (g : J → I) : (carrier (⋃ (index ∘ g))) → (carrier (⋃ index)). Proof. apply subtype_inc; intro. use hinhfun. use(fpmap g). Defined. Lemma issurjective_reindex_carrier_union {X I J : UU} (index : I → hsubtype X) (g : J → I) (gsurjective : issurjective g) : issurjective (reindex_carrier_union index g). Proof. intros [x in_union]. (* x ∈ (⋃ index) *) use(hinhfun _ in_union). intros [i index_ix]. use make_hfiber. - exists x. use(hinhfun _ (gsurjective i)). intros [j jpath]. exists j. refine(transportb _ (eqtohomot _ x) index_ix). exact(maponpaths index jpath). - now apply subtypePath_prop. Qed. (* The union of K-finitely many K-finite subtypes is K-finite. *) Definition kfinstruct_union {I X : UU} (index : I → hsubtype X) (g : kfinstruct I) (index_finite : ∏ (i : I), kfinstruct (index i)) : kfinstruct (⋃ index). Proof. (* (⋃ idx ∘ g) → ⋃ idx *) apply(kfinstruct_from_surjection (reindex_carrier_union index g)). apply issurjective_reindex_carrier_union. apply issurjective_kfinstruct. (* (∑(k : ⟦ n ⟧), (idx (g k))) → ⋃ (idx ∘ g) *) apply(kfinstruct_from_surjection (indexed_carrier_to_carrier_union (index ∘ g))). apply issurjective_indexed_carrier_to_union. apply kfinstruct_stn_indexed. intro; apply index_finite. Defined. (* The union of (Bishop)-finitely many K-finite subtypes is K-finite. *) Lemma iskfinite_union {I X : UU} (index : I → hsubtype X) (Ifinite : isfinite I) (index_finite : ∏ (i : I), iskfinite (index i)) : iskfinite (⋃ index). Proof. assert(finitechoicebase : ∥ ∏ (i : I), kfinstruct (index i) ∥). { use ischoicebasefiniteset. apply Ifinite. apply index_finite. } use(hinhfun2 _ Ifinite finitechoicebase). intro; apply kfinstruct_union. now apply kfinstruct_finstruct. Qed. (* In particular a binary union of K-finite subtypes is K-finite. *) Lemma iskfinite_binary_union {X : UU} (A B : hsubtype X) (afinite : iskfinite A) (bfinite : iskfinite B) : iskfinite (A ∪ B). Proof. (* We could use iskfinite_union defined above, but we opt to give a direct proof instead by constructing a sequence of surjective maps ⟦ n + m ⟧ -~> ⟦ n ⟧ ⨿ ⟦ m ⟧ --> A ⨿ B --> carrier (A ∪ B). *) use(hinhfun2 _ afinite bfinite). intros afinstruct bfinstruct. use make_kfinstruct. - exact(kfinstruct_cardinality afinstruct + kfinstruct_cardinality bfinstruct). - refine(coprod_carrier_binary_union A B ∘ _). refine(coprodf afinstruct bfinstruct ∘ _). apply weqfromcoprodofstn. - apply issurjcomp. apply issurjcomp. * apply issurjectiveweq, isweqinvmap. * apply issurjective_coprodf; apply issurjective_kfinstruct. * exact(issurjective_coprod_carrier_binary_union A B). Qed. (* Sometimes it's better to bundle it together. *) Definition kfinite_subtype (X : UU) : UU := ∑ (A : hsubtype X), iskfinite (carrier A). Definition subtype_from_kfinite_subtype {X} : kfinite_subtype X -> hsubtype X := pr1. Coercion subtype_from_kfinite_subtype : kfinite_subtype >-> hsubtype. Definition kfinite_subtype_property {X} (A : kfinite_subtype X) : iskfinite (carrier A) := pr2 A. Definition make_kfinite_subtype {X : UU} (A : hsubtype X) (finite_carrier : iskfinite (carrier A)) : kfinite_subtype X := (A ,, finite_carrier). Definition kfinite_subtype_union {X I : UU} (index : I -> kfinite_subtype X) (index_finite : isfinite I) : kfinite_subtype X. Proof. use make_kfinite_subtype. - exact(subtype_union index). - abstract(apply(iskfinite_union index index_finite); intro; apply kfinite_subtype_property). Defined. Definition kfinite_subtype_singleton {X : UU} (x : X) : kfinite_subtype X. Proof. use make_kfinite_subtype. - exact(singleton x). - exact(iskfinite_singleton x). Defined. End kfinite_subtypes. UniMath-20231010/UniMath/Combinatorics/KFiniteTypes.v000066400000000000000000000157511451125700300222260ustar00rootroot00000000000000 (********************************************************************) (* * Kuratowski finite types *) (* *) (* [kfinstruct] -- A Kuratowski structure on a type X consists of a *) (* natural number n : ℕ and a surjective function *) (* f : ⟦ n ⟧ → X. *) (* *) (* [iskfinite] -- A type X is Kuratowski finite (K-finite) if there *) (* merely exists some Kuratowski structure on X: *) (* iskfinite X := ∥ kfinstruct X ∥. *) (* *) (********************************************************************) (* Contents 1. Kuratowski structure. 2. Examples of K-structures. 3. K-finite types. *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.Combinatorics.StandardFiniteSets. Local Open Scope stn. Section kuratowski_structure. (** 1. Kuratowski structure on types. *) Definition kfinstruct (X : UU) : UU := ∑ (n : nat) (f : ⟦ n ⟧ → X), issurjective f. (* Constructor. *) Definition make_kfinstruct {X : UU} (n : nat) (f : ⟦ n ⟧ -> X) (fsurjective : issurjective f) : kfinstruct X := (n ,, f ,, fsurjective). (* Accessors. *) Definition kfinstruct_cardinality {X : UU} (f : kfinstruct X) : nat := pr1 f. Definition kfinstruct_map {X : UU} (f : kfinstruct X) : ⟦ kfinstruct_cardinality f ⟧ -> X := pr12 f. Coercion kfinstruct_map : kfinstruct >-> Funclass. Definition issurjective_kfinstruct {X : UU} (f : kfinstruct X) : issurjective f := pr22 f. (* Some functions useful for constructing kfinstruct from different data. *) Definition kfinstruct_from_surjection {X Y : UU} (g : X → Y) (gsurjective : issurjective g) : kfinstruct X → kfinstruct Y. Proof. intros f. use make_kfinstruct. - exact(kfinstruct_cardinality f). - exact(g ∘ f). - apply issurjcomp. apply issurjective_kfinstruct. exact gsurjective. Defined. Definition kfinstruct_weqf {X Y : UU} (w : X ≃ Y) : kfinstruct X → kfinstruct Y. Proof. apply(kfinstruct_from_surjection w). apply issurjectiveweq. apply weqproperty. Defined. Definition kfinstruct_weqb {X Y : UU} (w : X ≃ Y) : kfinstruct Y → kfinstruct X. Proof. apply(kfinstruct_from_surjection (invmap w)). apply issurjectiveweq. apply isweqinvmap. Defined. Definition kfinstruct_contr {X : UU} (contr : iscontr X) : kfinstruct X. Proof. use(make_kfinstruct 1). - exact(λ _, iscontrpr1 contr). - apply issurjective_to_contr, contr. exact(● 0). Defined. Definition kfinstruct_coprod {X Y : UU} : kfinstruct X → kfinstruct Y → kfinstruct (X ⨿ Y). Proof. intros f g. set (n := kfinstruct_cardinality f). set (m := kfinstruct_cardinality g). use make_kfinstruct. - exact(n + m). - exact((coprodf f g) ∘ invweq (weqfromcoprodofstn n m)). - apply issurjcomp. + apply issurjectiveweq. apply weqproperty. + apply issurjective_coprodf ; apply issurjective_kfinstruct. Defined. Definition kfinstruct_dirprod {X Y : UU} : kfinstruct X -> kfinstruct Y -> kfinstruct (X × Y). Proof. intros f g. set (k := kfinstruct_cardinality f). set (l := kfinstruct_cardinality g). use make_kfinstruct. - exact(k * l). - exact((dirprodf f g) ∘ (invweq (weqfromprodofstn k l))). - apply issurjcomp. + apply issurjectiveweq, weqproperty. + apply issurjective_dirprodf ; apply issurjective_kfinstruct. Defined. (* This relates [kfinstruct] to [finstruct]. *) Definition kfinstruct_finstruct {X : UU} : finstruct X → kfinstruct X. Proof. intros finstr. use make_kfinstruct. - apply finstr. (* n : nat *) - apply finstr. (* ⟦ n ⟧ ≃ X *) - apply issurjectiveweq. apply weqproperty. Defined. End kuratowski_structure. Section kstructure_examples. (** 2. Examples of types with K-structure. *) Definition kfinstruct_unit : kfinstruct unit. Proof. apply kfinstruct_contr. apply iscontrunit. Defined. Definition kfinstruct_bool : kfinstruct bool. Proof. use(make_kfinstruct 2). - exact(two_rec false true). - red; apply bool_rect; apply hinhpr. + exists (● 1); exact(idpath _). + exists (● 0); exact(idpath _). Defined. Definition kfinstruct_stn (n : nat) : kfinstruct (⟦ n ⟧). Proof. use make_kfinstruct. - exact n. - exact(idfun (⟦ n ⟧)). - exact(issurjective_idfun (⟦ n ⟧)). Defined. Definition kfinstruct_stn_indexed {n : nat} (P : ⟦ n ⟧ → UU) (index : ∏ (k : ⟦ n ⟧), kfinstruct (P k)) : kfinstruct (∑ (k : ⟦ n ⟧), P k). Proof. set (J := λ (j : ⟦ n ⟧), kfinstruct_cardinality (index j)). use(kfinstruct_from_surjection (X:=∑ (k : ⟦n⟧), ⟦J k⟧)). - apply totalfun, index. - apply issurjective_totalfun. intro; apply issurjective_kfinstruct. - apply(kfinstruct_weqb (weqstnsum1 J)). apply kfinstruct_stn. Defined. End kstructure_examples. Section kfinite_definition. (** 3. The property of being K-finite. A type is Kuratowski finite if it merely admits a K-structure. *) Definition iskfinite (X : UU) : UU := ∥ kfinstruct X ∥. Definition kfinstruct_iskfinite {X : UU} : kfinstruct X → iskfinite X := hinhpr. Definition iskfinite_weqf {X Y : UU} (w : X ≃ Y) : iskfinite X → iskfinite Y := hinhfun (kfinstruct_weqf w). Definition iskfinite_weqb {X Y : UU} (w : X ≃ Y) : iskfinite Y → iskfinite X := hinhfun (kfinstruct_weqb w). Definition iskfinite_from_surjection {X Y : UU} (f : X → Y) (fsurjective : issurjective f) : iskfinite X → iskfinite Y := hinhfun (kfinstruct_from_surjection f fsurjective). Definition iskfinite_unit : iskfinite unit := hinhpr kfinstruct_unit. Definition iskfinite_bool : iskfinite bool := hinhpr kfinstruct_bool. Definition iskfinite_contr (X : UU) (Xcontr : iscontr X) : iskfinite X := hinhpr (kfinstruct_contr Xcontr). Definition iskfinite_coprod {X Y : UU} : iskfinite X → iskfinite Y → iskfinite (X ⨿ Y) := hinhfun2 kfinstruct_coprod. Definition iskfinite_dirprod {X Y : UU} : iskfinite X → iskfinite Y → iskfinite (X × Y) := hinhfun2 kfinstruct_dirprod. (* Any Bishop-finite type is also K-finite. *) Definition iskfinite_isfinite {X : UU} : isfinite X → iskfinite X := hinhfun kfinstruct_finstruct. End kfinite_definition. UniMath-20231010/UniMath/Combinatorics/Lists.v000066400000000000000000000230311451125700300207340ustar00rootroot00000000000000(** * Lists *) (** This file contains a formalization of lists define as iterated products ([list]). Written by: Anders Mörtberg, 2016 (inspired by a remark of Vladimir Voevodsky), Floris van Doorn, december 2017 *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. (** * Lists over an arbitrary type *) Section lists. Context {A : UU}. (** The type of lists *) Definition list : UU := ∑ n, vec A n. (** The empty list *) Definition nil : list := (0,, vnil). (** List cons *) Definition cons (x : A) (xs : list) : list := (S (pr1 xs),, vcons x (pr2 xs)). Local Notation "[]" := nil (at level 0, format "[]"). Local Infix "::" := cons. Lemma list_ind : ∏ (P : list -> UU), P nil -> (∏ (x : A) (xs : list), P xs -> P (x :: xs)) -> ∏ xs, P xs. Proof. intros P Hnil Hcons xs. induction xs as [n xs]. induction n as [|n IHn]. - induction xs. apply Hnil. - simpl in xs. induction xs as [x xs]. apply (Hcons x (n,,xs) (IHn xs)). Defined. Lemma list_ind_compute_2 (P : list -> UU) (p0 : P nil) (ind : ∏ (x : A) (xs : list), P xs -> P (x :: xs)) (x : A) (xs : list) (f := list_ind P p0 ind) : f (x::xs) = ind x xs (f xs). Proof. apply idpath. Defined. Definition foldr {B : UU} (f : A -> B -> B) (b : B) : list -> B := list_ind (λ _, B) b (λ a _ b', f a b'). Definition length : list -> nat := pr1. (** Variation of foldr that returns a for the empty list and folds the rest with the first element as new default value *) Definition foldr1 (f : A -> A -> A) (a : A) : list → A. Proof. apply list_ind. - exact a. - intros a' l fl. revert l. apply list_ind. + exact a'. + intros _ _ _. exact (f a' fl). Defined. (** Variation of foldr1 with embedded mapping, see below for [foldr1_foldr1_map] *) Definition foldr1_map {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) : list → B. Proof. apply list_ind. - exact b. - intros a' l fl. revert l. apply list_ind. + exact (h a'). + intros _ _ _. exact (f (h a') fl). Defined. (** The n-th element of a list *) Definition nth x : stn(length x) -> A := el (pr2 x). Definition functionToList' n : (stn n -> A) -> vec A n. Proof. intros f. induction n as [|n I]. - exact tt. - exists (f (●0))%stn. exact (I(f ∘ dni (●0)))%stn. Defined. Definition functionToList n : (stn n -> A) -> list. Proof. intros f. exact (n ,, make_vec f). Defined. Section Test. Local Open Scope stn. Context {a b c d:A}. Let x := a::b::c::d::[]. Goal nth x (●0) = a. apply idpath. Qed. Goal nth x (●1) = b. apply idpath. Qed. Goal nth x (●2) = c. apply idpath. Qed. Goal nth x (●3) = d. apply idpath. Qed. Goal functionToList _ (nth x) = x. apply idpath. Qed. End Test. End lists. (** Make the type not implicit for list *) Arguments list : clear implicits. Section more_lists. Definition map {A B : UU} (f : A -> B) : list A -> list B := foldr (λ a l, cons (f a) l) nil. Lemma mapStep {A B : UU} (f : A -> B) (a:A) (x:list A) : map f (cons a x) = cons (f a) (map f x). Proof. apply idpath. Defined. (** Various unfolding lemmas *) Lemma foldr_nil {A B : UU} (f : A -> B -> B) (b : B) : foldr f b nil = b. Proof. apply idpath. Qed. Lemma foldr_cons {A B : UU} (f : A -> B -> B) (b : B) (x : A) (xs : list A) : foldr f b (cons x xs) = f x (foldr f b xs). Proof. apply idpath. Qed. Lemma map_nil {A B : UU} (f : A -> B) : map f nil = nil. Proof. apply idpath. Qed. Lemma map_cons {A B : UU} (f : A -> B) (x : A) (xs : list A) : map f (cons x xs) = cons (f x) (map f xs). Proof. apply idpath. Qed. Lemma map_compose {A B C : UU} (f : A → B) (g : B → C) (xs : list A) : map (g ∘ f) xs = map g (map f xs). Proof. revert xs. apply list_ind. - apply idpath. - intros x xs IH. now rewrite !map_cons, IH. Defined. Lemma map_idfun {A : UU} (xs : list A) : map (idfun A) xs = xs. Proof. revert xs. apply list_ind. - apply idpath. - intros x xs IH. now rewrite !map_cons, IH. Defined. Lemma map_homot {A B : UU} {f g : A → B} (h : f ~ g) (xs : list A) : map f xs = map g xs. Proof. revert xs. apply list_ind. - apply idpath. - intros x xs IH. now rewrite !map_cons, h, IH. Defined. Lemma foldr1_nil {A: UU} (f : A -> A -> A) (a : A) : foldr1 f a nil = a. Proof. apply idpath. Qed. Lemma foldr1_cons_nil {A : UU} (f : A -> A -> A) (a : A) (x : A) : foldr1 f a (cons x nil) = x. Proof. apply idpath. Qed. Lemma foldr1_cons {A : UU} (f : A -> A -> A) (a : A) (x y : A) (xs : list A) : foldr1 f a (cons x (cons y xs)) = f x (foldr1 f a (cons y xs)). Proof. apply idpath. Qed. Lemma foldr1_map_nil {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) : foldr1_map f b h nil = b. Proof. apply idpath. Qed. Lemma foldr1_map_cons_nil {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) (x : A) : foldr1_map f b h (cons x nil) = h x. Proof. apply idpath. Qed. Lemma foldr1_map_cons {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) (x y : A) (xs : list A) : foldr1_map f b h (cons x (cons y xs)) = f (h x) (foldr1_map f b h (cons y xs)). Proof. apply idpath. Qed. Lemma foldr1_foldr1_map {A B : UU} (f : B -> B -> B) (b : B) (h : A -> B) (xs : list A) : foldr1_map f b h xs = foldr1 f b (map h xs). Proof. revert xs. induction xs as [[|n] xs]. - induction xs. apply idpath. - induction n as [|n IH]. + induction xs as [m []]. apply idpath. + induction xs as [m [k xs]]. assert (IHinst := IH (k,,xs)). change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))). do 2 rewrite map_cons. rewrite foldr1_cons. change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst. rewrite map_cons in IHinst. rewrite <- IHinst. apply foldr1_map_cons. (* this steps could be done by cbn and reflexivity *) Qed. End more_lists. Local Notation "[]" := nil (at level 0, format "[]"). Local Infix "::" := cons. (** concatenate two lists *) Definition concatenate {X} : list X -> list X -> list X := λ r s, foldr cons s r. Local Infix "++" := concatenate. Lemma concatenateStep {X} (x:X) (r s:list X) : (x::r) ++ s = x :: (r ++ s). Proof. apply idpath. Defined. Lemma nil_concatenate {X} (r : list X) : nil ++ r = r. Proof. apply idpath. Defined. Lemma concatenate_nil {X} (r : list X) : r ++ nil = r. Proof. revert r. apply list_ind. apply idpath. intros x xs p. exact (maponpaths (cons x) p). Defined. Lemma assoc_concatenate {X} (r s t : list X) : (r ++ s) ++ t = r ++ (s ++ t). Proof. revert r. apply list_ind. - apply idpath. - intros x xs p. now rewrite !concatenateStep, p. Defined. Lemma map_concatenate {X Y} (f : X → Y) (r s : list X) : map f (r ++ s) = map f r ++ map f s. Proof. revert r. apply list_ind. - apply idpath. - intros x xs p. now rewrite mapStep, !concatenateStep, mapStep, p. Defined. Lemma foldr_concatenate {X Y : UU} (f : X → Y) (l : list X) : foldr concatenate [] (map (λ x, f x::[]) l) = map f l. Proof. revert l. apply list_ind. - apply idpath. - intros x l IH. now rewrite !map_cons, foldr_cons, IH. Defined. Lemma foldr1_concatenate {X Y : UU} (f : X → Y) (l : list X) : map f l = foldr1 concatenate [] (map (λ x, f x::[]) l). Proof. revert l. apply list_ind. - apply idpath. - intros x. refine (list_ind _ _ _). + intro. apply idpath. + intros x' l _ IH. exact (maponpaths (cons (f x)) IH). Defined. (** Append a single element to a list *) Definition append {X} (x : X) (l : list X) : list X := l ++ x::[]. Lemma appendStep {X} (x y : X) (l : list X) : append x (y::l) = y::append x l. Proof. apply idpath. Defined. Lemma append_concatenate {X} (x : X) (l s : list X) : append x (l ++ s) = l ++ append x s. Proof. apply assoc_concatenate. Defined. Lemma map_append {X Y} (f : X → Y) (x : X) (r : list X) : map f (append x r) = append (f x) (map f r). Proof. exact (map_concatenate _ _ _). Defined. (** Reverse a list *) Definition reverse {X} : list X → list X := foldr append []. Lemma reverse_nil (X : Type) : reverse (@nil X) = []. Proof. apply idpath. Defined. Lemma reverseStep {X} (x : X) (r : list X) : reverse (x::r) = append x (reverse r). Proof. apply idpath. Defined. Lemma map_reverse {X Y} (f : X → Y) (r : list X) : map f (reverse r) = reverse (map f r). Proof. revert r. apply list_ind. - apply idpath. - intros x xs p. now rewrite mapStep, !reverseStep, map_append, p. Defined. Lemma reverse_concatenate {X} (l s : list X) : reverse (l ++ s) = reverse s ++ reverse l. Proof. revert l. apply list_ind. - symmetry. apply concatenate_nil. - intros x xs p. now rewrite concatenateStep, !reverseStep, p, append_concatenate. Defined. Lemma reverse_append {X} (x : X) (l : list X) : reverse (append x l) = x :: reverse l. Proof. unfold append. now rewrite reverse_concatenate, reverseStep, reverse_nil. Defined. Lemma reverse_reverse {X} (r : list X) : reverse (reverse r) = r. Proof. revert r. apply list_ind. - apply idpath. - intros x xs p. now rewrite !reverseStep, reverse_append, p. Defined. (** flatten lists of lists *) Definition flatten {X} : list (list X) → list X. Proof. apply list_ind. + exact []. + intros s _ f. exact (concatenate s f). Defined. Lemma flattenStep {X} (x:list X) (m : list(list X)) : flatten (x::m) = concatenate x (flatten m). Proof. unfold flatten. rewrite list_ind_compute_2. apply idpath. Defined. Lemma isofhlevellist (n : nat) {X : UU} (is1 : isofhlevel (S (S n)) X) : isofhlevel (S (S n)) (list X). Proof. use isofhleveltotal2. - intros m k. apply isofhlevelsnprop, isasetnat. - intro m. apply isofhlevelvec, is1. Defined. UniMath-20231010/UniMath/Combinatorics/Maybe.v000066400000000000000000000022311451125700300206720ustar00rootroot00000000000000(** * A simple implementation of the maybe/option monad which does not require category theory. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.PartC. Definition maybe (A: UU):= A ⨿ unit. Definition just {A: UU}: A → maybe A := ii1. Definition nothing {A: UU}: maybe A := ii2 tt. Definition just_injectivity {A: UU}: ∏ (x y: A), just x = just y → x = y := ii1_injectivity. Lemma isasetmaybe {A: UU} (H: isaset A): isaset (maybe A). Proof. apply isasetcoprod. - exact H. - exact isasetunit. Defined. Definition flatmap {A B: UU} (f: A → maybe B): maybe A → maybe B := coprod_rect _ f (λ _, nothing). Lemma flatmap_just {A B: UU} (f: A → maybe B) (a: A) : flatmap f (just a) = f a. Proof. apply idpath. Defined. Lemma flatmap_nothing {A B: UU} (f: A → maybe B) : flatmap f nothing = nothing. Proof. apply idpath. Defined. Lemma flatmap_ind {A B: UU} (P: ∏ (x: maybe A), UU): (P nothing) → (∏ a: A, P (just a)) → ∏ x: maybe A, P x. Proof. intros Pnothing Pjust. induction x as [ok | error]. - exact (Pjust ok). - induction error. exact Pnothing. Defined. UniMath-20231010/UniMath/Combinatorics/MetricTree.v000066400000000000000000000075571451125700300217200ustar00rootroot00000000000000(* -*- coding: utf-8 *) (** * Metric trees *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Nat. Import UniMath.MoreFoundations.Nat.Discern. Require Import UniMath.MoreFoundations.Notations. (** ** Definitions *) Definition Tree : Type := ∑ (mt_set: Type) (mt_dist: mt_set -> mt_set -> nat) (mt_refl: ∏ x, mt_dist x x = 0) (mt_anti: ∏ x y, mt_dist x y = 0 -> x = y) (mt_symm: ∏ x y, mt_dist x y = mt_dist y x) (mt_trans: ∏ x y z, mt_dist x z <= mt_dist x y + mt_dist y z), (* mt_step: *) ∏ x z, x != z -> ∑ y, (S (mt_dist x y) = mt_dist x z) × (mt_dist y z = 1). Coercion mt_set (x:Tree) := pr1 x. Definition mt_dist (x:Tree) := pr12 x. Definition mt_refl (x:Tree) := pr122 x. Definition mt_anti (x:Tree) := pr122 (pr2 x). Definition mt_symm (x:Tree) := pr122 (pr22 x). Definition mt_trans (x:Tree) := pr122 (pr222 x). Definition mt_step (x:Tree) := pr222 (pr222 x). Local Definition make mt_set mt_dist mt_refl mt_anti mt_symm mt_trans mt_step : Tree := mt_set,, mt_dist,, mt_refl,, mt_anti,, mt_symm,, mt_trans,, mt_step. Lemma mt_path_refl (T:Tree) (x y:T) : x = y -> mt_dist _ x y = 0. Proof. intros e. destruct e. apply mt_refl. Qed. Lemma tree_deceq (T:Tree) : isdeceq T. Proof. intros. intros t u. induction (isdeceqnat (mt_dist T t u) 0) as [a|b]. { apply inl. apply mt_anti. assumption. } { apply inr. intro e. apply b. destruct e. apply mt_refl. } Qed. Corollary tree_isaset (T:Tree) : isaset T. Proof. intros. apply isasetifdeceq. apply tree_deceq. Qed. Definition step (T:Tree) {x z:T} (ne:x != z) : T := pr1 (mt_step _ x z ne). Definition tree_induction (T:Tree) (x:T) (P:T->Type) (p0 : P x) (pn : ∏ z (ne:x != z), P (step T ne) -> P z) : ∏ z, P z. Proof. assert(d_ind : ∏ n z, mt_dist _ x z = n -> P z). { intro. induction n as [|n IH]. { intros. assert (k:x=z). { apply mt_anti. assumption. } destruct k. assumption. } { intros ? H. assert (ne : x != z). { intros s. exact (negpaths0sx _ (! mt_path_refl _ _ _ s @ H)). } refine (pn z ne _). { apply IH. unfold step; simpl. set (y := mt_step T x z ne). destruct y as [y [i j]]; simpl. apply invmaponpathsS. exact (i@H). } } } intro. apply (d_ind (mt_dist _ x z)). reflexivity. Defined. Definition nat_tree : Tree. Proof. refine (make nat nat_dist _ _ _ _ _). { intro m. induction m as [|m IHm]. { reflexivity. } { rewrite nat_dist_S. assumption. } } { apply nat_dist_anti. } { apply nat_dist_symm. } { apply nat_dist_trans. } { intros m n e. Set Printing All. assert (d := natneqchoice _ _ (nat_nopath_to_neq e)); clear e. destruct d as [h|h]. { exists (S n). { split. { apply nat_dist_gt. exact h. } { destruct (natgthorleh (S n) n) as [_|j]. { clear h. induction n as [|n IHn]. { reflexivity. } { apply IHn. } } { apply fromempty. clear h. contradicts j (negnatSleh n). }}} } { exists (n - 1). { split. { assert (a := natltminus1 m n h). assert (b := natlthtoleh m n h). assert (c := nat_dist_le _ _ a). assert (d := nat_dist_le _ _ b). rewrite c, d; clear c d. rewrite natminusminusassoc. simpl. change (1 + (n - (1+m)) = n - m). rewrite (natpluscomm 1 m). rewrite <- natminusminusassoc. rewrite natpluscomm. apply (minusplusnmm (n-m) 1). apply (natminusplusltcomm m n 1). { assert(e := natleh0n m). assert(f := natlehlthtrans _ _ _ e h). exact (natlthtolehsn _ _ f). } { exact a. } } { assert (a := natleh0n m). assert (b := natlehlthtrans _ _ _ a h). assert (c := natlthtolehsn _ _ b). exact (nat_dist_minus 1 n c). } } } } Defined. (* Local Variables: compile-command: "make -C ../.. TAGS UniMath/Ktheory/MetricTree.vo" End: *) UniMath-20231010/UniMath/Combinatorics/MoreLists.v000066400000000000000000000266251451125700300215730ustar00rootroot00000000000000(** * Additional definitions, lemmas and notations for lists. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Combinatorics.Vectors. Require Export UniMath.Combinatorics.Lists. Require Export UniMath.Combinatorics.DecSet. Require Export UniMath.Combinatorics.Maybe. (** ** Notations for lists. Introduces a new scope, [list_scope], delimited by [list], which adds useful notations for lists. A list of elements [x1], [x2], ..., [xn] may be written a [[x1; x2; ...; xn]]. Moreover [[]] denotes the empty list, [::] is the cons operator and [++] the list concatenation operator. *) Declare Scope list_scope. Delimit Scope list_scope with list. Bind Scope list_scope with list. Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..): list_scope. Notation "[]" := nil (at level 0, format "[]"): list_scope. Infix "::" := cons: list_scope. Infix "++" := concatenate: list_scope. Local Open Scope list_scope. (** ** Proofs that [cons] is injective on both arguments. Introduces the [head] and [tail] operations on lists, using the maybe monad defined in [UniMath.Combinatorics.Maybe] for dealing with invalid function applications. Then, proves that [cons] is injective on both arguments and that there are no paths between [cons] and [nil]. *) Definition head {A: UU}: list A → maybe A. Proof. apply list_ind. - exact nothing. - exact (λ x xs IH, ii1 x). Defined. Definition tail {A: UU}: list A → maybe (list A). Proof. apply list_ind. - exact nothing. - exact (λ x xs IH, ii1 xs). Defined. Lemma list_head_cons {A: UU} (x: A) (xs: list A) : head (x :: xs) = ii1 x. Proof. apply idpath. Defined. Lemma list_tail_cons {A: UU} (x: A) (xs: list A) : tail (x :: xs) = ii1 xs. Proof. apply idpath. Defined. Theorem cons_inj1 {A: UU} (a1 a2: A) (r1 r2: list A) : a1 :: r1 = a2 :: r2 → a1 = a2. Proof. intro H. apply (maponpaths head) in H. change (just a1 = just a2) in H. apply ii1_injectivity in H. assumption. Defined. Theorem cons_inj2 {A: UU} (a1 a2: A) (r1 r2: list A) : a1 :: r1 = a2 :: r2 → r1 = r2. Proof. intro H. apply (maponpaths tail) in H. change (just r1 = just r2) in H. apply ii1_injectivity in H. assumption. Defined. Lemma negpathsconsnil {A: UU} (a: A) (l: list A): a :: l != []. Proof. intro X. apply (maponpaths pr1) in X. cbv in X. apply negpathssx0 in X. assumption. Defined. Lemma negpathsnilcons {A: UU} (a: A) (l: list A): [] != a :: l. Proof. intro X. apply pathsinv0 in X. apply negpathsconsnil in X. assumption. Defined. (** ** Several properties for the length of a list. *) Lemma length_cons {A: UU} (x: A) (xs: list A) : length (x :: xs) = S (length xs). Proof. apply idpath. Defined. Lemma length_zero_back {A: UU} (l: list A): length l = 0 → l = []. Proof. revert l. refine (list_ind _ _ _). - reflexivity. - intros x xs _ HP. apply negpathssx0 in HP. contradiction. Defined. Lemma length_one_back {A: UU} (l: list A) (l1: length l = 1): ∑ x: A, l = [x]. Proof. induction l. cbn in l1. induction (! l1). induction pr2 as [x xs]. exists x. induction xs. apply idpath. Defined. Lemma length_concatenate {A: UU} (l1: list A) (l2: list A) : length (l1 ++ l2) = length l1 + length l2. Proof. revert l1. apply list_ind. - apply idpath. - intros x xs IH. change (S (length (xs ++ l2)) = S (length xs + length l2)). apply maponpaths. apply IH. Defined. Lemma length_sublist1 {A: UU} (l1: list A) (l2: list A) : length l1 ≤ length (l1 ++ l2). Proof. rewrite length_concatenate. apply natlehnplusnm. Defined. Lemma length_sublist2 {A: UU} (l1: list A) (l2: list A) : length l2 ≤ length (l1 ++ l2). Proof. rewrite length_concatenate. rewrite natpluscomm. apply natlehnplusnm. Defined. Lemma length_map {A B: UU} (l: list A) (f: A → B): length (map f l) = length l. Proof. revert l. apply list_ind. - apply idpath. - intros x xs HPind. change (map f (x :: xs)) with (f x :: map f xs). change (S (length (map f xs)) = S(length xs)). apply maponpaths. exact HPind. Defined. (** ** Miscellanea of properties and definitions. *) Definition listset (A: hSet): hSet := make_hSet (list A) (isofhlevellist 0 (setproperty A)). Definition fill {A: UU} (a: A): nat → list A := λ n, n ,, vec_fill a n. Lemma map_const {A B: UU} (b: B) (l: list A): map (λ _, b) l = fill b (length l). Proof. revert l. apply list_ind. - apply idpath. - intros x xs HPind. change (b :: map (λ _: A, b) xs = b :: fill b (length xs)). apply maponpaths. exact HPind. Defined. Lemma length_fill {A: UU} (a: A) (n: nat): length (fill a n) = n. Proof. apply idpath. Defined. (** ** The [drop] operation and related properties. If [l] is a list and [n] a natural number, [drop l n] returns the list obtained from [l] after removing the first [n] elements. If _n > length l_, then [drop l n = []]. *) Definition drop {A: UU} (l: list A) (n: nat): list A. Proof. revert l. induction n. - exact (idfun _). - apply list_ind. + exact []. + intros x xs _. exact (IHn xs). Defined. Lemma drop_nil {A: UU} {n: nat}: @drop A [] n = []. Proof. induction n ; apply idpath. Defined. Lemma drop_zero {A: UU} (l: list A): drop l 0 = l. Proof. revert l. apply list_ind; trivial. Defined. Lemma drop_step {A: UU} (x: A) (xs: list A) (n: nat) : drop (x :: xs) (S n) = drop xs n. Proof. apply idpath. Defined. Lemma drop_full {A: UU} (l: list A): drop l (length l) = []. Proof. revert l; apply list_ind ; trivial. Defined. Lemma drop_concatenate {A: UU} (l1 l2: list A) (n: nat) (nok: n ≤ length l1): drop (l1 ++ l2) n = (drop l1 n) ++ l2. Proof. revert l1 nok. induction n. - reflexivity. - refine (list_ind _ _ _). + intros. contradiction (negnatlehsn0 _ nok). + intros x xs _ sok. rewrite concatenateStep. do 2rewrite drop_step. apply (IHn xs sok). Defined. Lemma length_drop {A: UU} (l: list A) (n: nat): length (drop l n) = length l - n. Proof. revert l n. refine (list_ind _ _ _). - intro n. rewrite drop_nil. induction n. + apply idpath. + change (0 = 0 - (1+ n)). rewrite <- natminusminus. assumption. - intros x xs IH. induction n. + apply idpath. + rewrite drop_step. rewrite length_cons. apply (IH n). Defined. (** ** The [prefix_remove] operation and related properties. If [l2] is a prefix of [l1], then [prefix_remove l1 l2] returns [just l] where [l] is the only list such that [l2 ++ l = l1]. Otherwise [prefix_remove l1 l2] returns [nothing]. It is required for [l1] and [l2] to be of type [list A] with [A: decSet]. *) Definition prefix_remove {A: decSet} (l1 l2: list A): maybe (list A). Proof. revert l1 l2. refine (list_ind _ _ _). - exact (λ l, just l). - intros x xs HP. refine (list_ind _ _ _). + exact nothing. + intros y ys _. induction (decproperty A x y). * exact (HP ys). * exact nothing. Defined. Lemma prefix_remove_stepeq {A: decSet} (x: A) (xs1 xs2: list A) : prefix_remove (x :: xs1) (x :: xs2) = prefix_remove xs1 xs2. Proof. unfold prefix_remove. cbn. induction (decproperty A x x). - cbn. apply idpath. - contradiction (b (idpath x)). Defined. Lemma prefix_remove_stepneq {A: decSet} {x1 x2: A} (p: x1 != x2) (xs1 xs2: list A) : prefix_remove (x1 :: xs1) (x2 :: xs2) = nothing. Proof. unfold prefix_remove. cbn. induction (decproperty A x1 x2). - contradicts a p. - apply idpath. Defined. Lemma prefix_remove_stepback {A: decSet} (x1 x2: A) (xs1 xs2: list A) : prefix_remove (x1 :: xs1) (x2 :: xs2) != nothing → x1 = x2. Proof. induction (decproperty A x1 x2) as [x1eqx2 | x1neqx2] ; intro HP. - assumption. - rewrite (prefix_remove_stepneq x1neqx2) in HP. apply fromempty. apply (HP (idpath _)). Defined. Definition prefix_remove_back {A: decSet} (l1 l2 l3: list A): prefix_remove l1 l2 = just l3 → l2 = l1 ++ l3. Proof. revert l1 l2. refine (list_ind _ _ _). - intros l2 prefixnil. cbn in prefixnil. apply just_injectivity in prefixnil. cbn. assumption. - intros x1 xs1 HPind. refine (list_ind _ _ _). + intro prefixxs. cbn in prefixxs. apply negpathsii2ii1 in prefixxs. contradiction. + intros x2 xs2 HP2ind HP. induction (decproperty A x1 x2) as [x1eqx2 | x1neqx2]. * rewrite x1eqx2 in *. rewrite prefix_remove_stepeq in HP. rewrite concatenateStep. rewrite (HPind xs2 HP). apply idpath. * rewrite (prefix_remove_stepneq x1neqx2) in HP. contradiction (negpathsii2ii1 _ _ HP). Defined. Lemma prefix_remove_self {A: decSet} (l: list A): prefix_remove l l = just []. Proof. revert l. apply list_ind. - apply idpath. - intros x xs IH. rewrite prefix_remove_stepeq. apply IH. Defined. Definition isprefix {A: decSet} (l1 l2: list A): UU := prefix_remove l1 l2 != nothing. Lemma isprefix_self {A: decSet} (l: list A): isprefix l l. Proof. unfold isprefix. rewrite prefix_remove_self. apply negpathsii1ii2. Defined. Lemma prefix_remove_concatenate {A: decSet} (l1 l2 l3: list A) (tl: list A) : prefix_remove l1 l2 = ii1 tl → prefix_remove l1 (l2 ++ l3) = ii1 (tl ++ l3). Proof. revert l1 l2. refine (list_ind _ _ _). - intros l2 prooftl. apply ii1_injectivity in prooftl. rewrite prooftl. apply idpath. - intros x xs HPind. refine (list_ind _ _ _). + intro HP. cbv in HP. apply negpathsii2ii1 in HP. contradiction. + intros x2 x2s HP2. rewrite concatenateStep. induction (decproperty A x x2) as [xeqx2 | xneqx2]. * rewrite xeqx2. do 2 rewrite prefix_remove_stepeq. apply (HPind x2s). * rewrite (prefix_remove_stepneq xneqx2). intro HP. apply negpathsii2ii1 in HP. contradiction. Defined. Lemma prefix_remove_concatenate2 {A: decSet} (l1 l2 l3: list A) : length l1 ≤ length l2 → prefix_remove l1 l2 = nothing → prefix_remove l1 (l2 ++ l3) = nothing. Proof. revert l1 l2. refine (list_ind _ _ _). - intros l2 Hlen Hpref. contradiction (negpathsii1ii2 _ _ Hpref). - intros x1 xs1 IH. refine (list_ind _ _ _). + intros Hlen Hpref. contradiction (negnatlehsn0 _ Hlen). + intros x2 xs2 _ Hlen Hpref. rewrite concatenateStep. induction (decproperty A x1 x2) as [x1eqx2 | x1neqx2]. * induction x1eqx2. rewrite prefix_remove_stepeq. rewrite prefix_remove_stepeq in Hpref. apply (IH xs2 Hlen Hpref). * apply (prefix_remove_stepneq x1neqx2). Defined. Lemma prefix_remove_prefix {A: decSet} (l1 l2: list A): prefix_remove l1 (l1 ++ l2) = just l2. Proof. revert l1. refine (list_ind _ _ _). - reflexivity. - intros x xs IHl1. rewrite concatenateStep. rewrite prefix_remove_stepeq. assumption. Defined. Lemma prefix_remove_drop {A: decSet} (l1 l2: list A) : prefix_remove l1 l2 != nothing → prefix_remove l1 l2 = just (drop l2 (length l1)). Proof. revert l1 l2. refine (list_ind _ _ _). - reflexivity. - intros x1 xs1 IH. refine (list_ind _ _ _). + contradiction. + intros x2 xs2 _ prefixok. induction (decproperty A x1 x2) as [x1eqx2 | x1neqx2]. * induction x1eqx2. rewrite prefix_remove_stepeq. rewrite prefix_remove_stepeq in prefixok. apply (IH xs2 prefixok). * rewrite (prefix_remove_stepneq x1neqx2) in prefixok. contradiction prefixok. apply idpath. Defined. UniMath-20231010/UniMath/Combinatorics/OrderedSets.v000066400000000000000000000605561451125700300220760ustar00rootroot00000000000000(* -*- coding: utf-8 -*- *) Require Import UniMath.Combinatorics.FiniteSets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.DecidablePropositions. Local Open Scope poset. (** partially ordered sets and ordered sets *) Definition isTotalOrder {X : hSet} (R : hrel X) : hProp := make_hProp (isPartialOrder R × istotal R) (isapropdirprod _ _ (isaprop_isPartialOrder R) (isaprop_istotal R)). Local Open Scope logic. Lemma tot_nge_to_le {X:hSet} (R:hrel X) : istotal R -> ∏ x y, ¬ (R x y) -> R y x. Proof. intros tot ? ? nle. now apply (hdisjtoimpl (tot x y)). Defined. Lemma tot_nle_iff_gt {X:hSet} (R:hrel X) : isTotalOrder R -> ∏ x y, ¬ (R x y) <-> R y x ∧ ¬ (y = x). (** if [R x y] is [x ≤ y], then this shows the equivalence of two definitions for [y < x] *) Proof. intros i. assert (tot := pr2 i); simpl in tot. assert (refl := pr2 (pr1 (pr1 i))); simpl in refl. assert (anti := pr2 (pr1 i)); simpl in anti. split. { intros nle. split. - now apply tot_nge_to_le. - intros ne. induction ne. exact (nle (refl y)). } { intros yltx xley. induction yltx as [ylex neq]. exact (neq (anti _ _ ylex xley)). } Defined. Definition isSmallest {X : Poset} (x : X) : UU := ∏ y, x ≤ y. Definition isBiggest {X : Poset} (x : X) : UU := ∏ y, y ≤ x. Definition isMinimal {X : Poset} (x : X) : UU := ∏ y, y ≤ x -> x = y. (* the definition in Sets.v is wrong *) Definition isMaximal {X : Poset} (x : X) : UU := ∏ y, x ≤ y -> x = y. (* the definition in Sets.v is wrong *) Definition consecutive {X : Poset} (x y : X) : UU := x < y × ∏ z, ¬ (x < z × z < y). Lemma isaprop_isSmallest {X : Poset} (x : X) : isaprop (isSmallest x). Proof. intros. unfold isSmallest. apply impred_prop. Defined. Lemma isaprop_isBiggest {X : Poset} (x : X) : isaprop (isBiggest x). Proof. intros. unfold isBiggest. apply impred_prop. Defined. Definition Poset_univalence_map {X Y:Poset} : X=Y -> PosetEquivalence X Y. Proof. intros e. induction e. apply identityPosetEquivalence. Defined. Local Arguments isPosetEquivalence : clear implicits. Local Arguments isaposetmorphism : clear implicits. Lemma posetStructureIdentity {X:hSet} (R S:PartialOrder X) : @isPosetEquivalence (X,,R) (X,,S) (idweq X) <-> (R=S)%type. Proof. intros. split. { intros e. apply subtypePath. { intros T. apply isaprop_isPartialOrder. } induction R as [R r]; induction S as [S s]; simpl. apply funextfun; intro x; apply funextfun; intro y. unfold isPosetEquivalence in e. unfold isaposetmorphism in e; simpl in e. induction e as [e e']. unfold posetRelation in *. unfold invmap in *; simpl in *. apply hPropUnivalence. { apply e. } { apply e'. } } { intros p. induction p. apply isPosetEquivalence_idweq. } Defined. Local Lemma posetTransport_weq (X Y:Poset) : X╝Y ≃ X≅Y. Proof. intros. simple refine (weqbandf _ _ _ _). { apply hSet_univalence. } intros e. apply invweq. induction X as [X R], Y as [Y S]; simpl in e. induction e; simpl. apply weqimplimpl. { exact (pr1 (posetStructureIdentity R S)). } { exact (pr2 (posetStructureIdentity R S)). } { exact (isaprop_isPosetEquivalence _). } { exact (isaset_PartialOrder _ _ _). } Defined. Local Theorem Poset_univalence_0 (X Y:Poset) : X=Y ≃ X≅Y. Proof. intros. intermediate_weq (X╝Y). - apply total2_paths_equiv. - apply posetTransport_weq. Defined. Lemma Poset_univalence_compute {X Y:Poset} (e:X=Y) : Poset_univalence_0 X Y e = Poset_univalence_map e. Proof. try reflexivity. (* fails, so we use "remakeweq" below *) Abort. Theorem Poset_univalence (X Y:Poset) : X=Y ≃ X≅Y. Proof. intros. assert (k : pr1weq (Poset_univalence_0 X Y) ~ @Poset_univalence_map X Y). { intro e. apply isinj_pr1_PosetEquivalence. induction e. reflexivity. } exact (remakeweq k). Defined. Lemma Poset_univalence_compute {X Y:Poset} (e:X=Y) : Poset_univalence X Y e = Poset_univalence_map e. Proof. reflexivity. Defined. (* now we try to mimic this construction: Inductive PosetEquivalence (X Y:Poset) : Type := pathToEq : (X=Y) -> PosetEquivalence X Y. PosetEquivalence_rect : ∏ (X Y : Poset) (P : PosetEquivalence X Y -> Type), (∏ e : X = Y, P (pathToEq X Y e)) -> ∏ p : PosetEquivalence X Y, P p *) Theorem PosetEquivalence_rect (X Y : Poset) (P : X ≅ Y -> UU) : (∏ e : X = Y, P (Poset_univalence_map e)) -> ∏ f, P f. Proof. intros ih ?. set (p := ih (invmap (Poset_univalence _ _) f)). set (h := homotweqinvweq (Poset_univalence _ _) f). exact (transportf P h p). Defined. Ltac poset_induction f e := generalize f; apply PosetEquivalence_rect; intro e; clear f. (* applications of poset equivalence induction: *) Lemma isMinimal_preserved {X Y:Poset} {x:X} (is:isMinimal x) (f:X ≅ Y) : isMinimal (f x). Proof. intros. (* Anders says " induction f. " should look for PosetEquivalence_rect. Why doesn't it? *) poset_induction f e. induction e. simpl. exact is. Defined. Lemma isMaximal_preserved {X Y:Poset} {x:X} (is:isMaximal x) (f:X ≅ Y) : isMaximal (f x). Proof. intros. poset_induction f e. induction e. simpl. exact is. Defined. Lemma consecutive_preserved {X Y:Poset} {x y:X} (is:consecutive x y) (f:X ≅ Y) : consecutive (f x) (f y). Proof. intros. poset_induction f e. induction e. simpl. exact is. Defined. (** * Ordered sets *) (** see Bourbaki, Set Theory, III.1, where they are called totally ordered sets *) Definition OrderedSet := ∑ X:Poset, istotal (posetRelation X). Ltac unwrap_OrderedSet X := induction X as [X total]; induction X as [X _po_]; induction _po_ as [R _i_]; unwrap_isPartialOrder _i_; unfold posetRelation in total; simpl in total. Local Definition underlyingPoset (X:OrderedSet) : Poset := pr1 X. Coercion underlyingPoset : OrderedSet >-> Poset. Declare Scope oset. Delimit Scope oset with oset. Definition Poset_lessthan {X:Poset} (x y:X) := ∥ x ≤ y × x != y ∥. Notation "X ≅ Y" := (PosetEquivalence X Y) (at level 60, no associativity) : oset. Notation "m ≤ n" := (posetRelation _ m n) (no associativity, at level 70) : oset. Notation "m <= n" := (posetRelation _ m n) (no associativity, at level 70) : oset. Notation "m < n" := (Poset_lessthan m n) :oset. Notation "n ≥ m" := (posetRelation _ m n) (no associativity, at level 70) : oset. Notation "n >= m" := (posetRelation _ m n) (no associativity, at level 70) : oset. Notation "n > m" := (Poset_lessthan m n) :oset. Close Scope poset. Local Open Scope oset. Definition OrderedSet_isrefl {X:OrderedSet} (x:X) : x ≤ x. Proof. intros. unwrap_OrderedSet X; simpl in x. apply refl. Defined. Definition OrderedSet_isantisymm {X:OrderedSet} (x y:X) : x ≤ y -> y ≤ x -> x = y. Proof. intros r s. unwrap_OrderedSet X; simpl in x, y. now apply antisymm. Defined. Definition OrderedSet_istotal {X:OrderedSet} (x y:X): x ≤ y ∨ y ≤ x := pr2 X x y. Lemma isdeceq_isdec_ordering (X:OrderedSet) : isdeceq X -> isdec_ordering X. Proof. intros deceq ? ?. assert (tot := OrderedSet_istotal x y). induction (deceq x y) as [j|j]. - apply ii1. induction j. unwrap_OrderedSet X. apply refl. - assert (c : (y ≥ x) ⨿ (x ≥ y)). { assert (d : isaprop ((y ≥ x) ⨿ (x ≥ y))). { apply isapropcoprod. * apply propproperty. * apply propproperty. * intros r s. apply j; clear j. unwrap_OrderedSet X. now apply antisymm. } apply (squash_to_prop tot). + exact d. + intro e. exact e. } induction c as [c|c']. + now apply ii1. + apply ii2. intro le. apply j. now apply OrderedSet_isantisymm. Defined. Corollary isfinite_isdec_ordering (X:OrderedSet) : isfinite X -> isdec_ordering X. Proof. intros i ? ?. apply isdeceq_isdec_ordering. now apply isfinite_isdeceq. Defined. Corollary isdeceq_isdec_lessthan (X:OrderedSet) : isdeceq X -> ∏ (x y:X), decidable (x < y). Proof. intros i ? ?. unfold Poset_lessthan. apply decidable_ishinh. apply decidable_dirprod. - now apply isdeceq_isdec_ordering. - apply neg_isdecprop. apply isdecpropif. * apply setproperty. * apply i. Defined. Corollary isfinite_isdec_lessthan (X:OrderedSet) : isfinite X -> ∏ (x y:X), decidable (x < y). Proof. intros i ? ?. apply isdeceq_isdec_lessthan. now apply isfinite_isdeceq. Defined. Lemma isincl_underlyingPoset : isincl underlyingPoset. Proof. apply isinclpr1. intros X. apply isaprop_istotal. Defined. Definition underlyingPoset_weq (X Y:OrderedSet) : X=Y ≃ (underlyingPoset X)=(underlyingPoset Y). Proof. Set Printing Coercions. intros. simple refine (make_weq _ _). { apply maponpaths. } apply isweqonpathsincl. apply isincl_underlyingPoset. Unset Printing Coercions. Defined. Lemma smallestUniqueness (X:OrderedSet) (x y:X) : isSmallest x -> isSmallest y -> x = y. Proof. intros i j. assert (q := OrderedSet_istotal x y). apply (squash_to_prop q). { apply setproperty. } intro c. induction c as [xley|ylex]. - apply OrderedSet_isantisymm. + assumption. + now apply j. - apply OrderedSet_isantisymm. + now apply i. + assumption. Defined. Lemma biggestUniqueness (X:OrderedSet) (x y:X) : isBiggest x -> isBiggest y -> x = y. Proof. intros i j. assert (q := OrderedSet_istotal x y). apply (squash_to_prop q). { apply setproperty. } intro c. induction c as [xley|ylex]. - apply OrderedSet_isantisymm. + assumption. + now apply i. - apply OrderedSet_isantisymm. + now apply j. + assumption. Defined. Theorem OrderedSet_univalence (X Y:OrderedSet) : X=Y ≃ X≅Y. Proof. intros. exact ((Poset_univalence _ _) ∘ (underlyingPoset_weq _ _))%weq. Defined. Theorem OrderedSetEquivalence_rect (X Y : OrderedSet) (P : X ≅ Y -> UU) : (∏ e : X = Y, P (OrderedSet_univalence _ _ e)) -> ∏ f, P f. Proof. intros ih ?. set (p := ih (invmap (OrderedSet_univalence _ _) f)). set (h := homotweqinvweq (OrderedSet_univalence _ _) f). exact (transportf P h p). Defined. Ltac oset_induction f e := generalize f; apply OrderedSetEquivalence_rect; intro e; clear f. (* standard ordered sets *) Definition FiniteOrderedSet := ∑ X:OrderedSet, isfinite X. Definition underlyingOrderedSet (X:FiniteOrderedSet) : OrderedSet := pr1 X. Coercion underlyingOrderedSet : FiniteOrderedSet >-> OrderedSet. Definition finitenessProperty (X:FiniteOrderedSet) : isfinite X := pr2 X. Definition underlyingFiniteSet : FiniteOrderedSet -> FiniteSet. Proof. intros. exists X. apply finitenessProperty. Defined. Coercion underlyingFiniteSet : FiniteOrderedSet >-> FiniteSet. Lemma istotal_FiniteOrderedSet (X:FiniteOrderedSet) : istotal (posetRelation X). Proof. intros. exact (pr2 (pr1 X)). Defined. Lemma FiniteOrderedSet_isdeceq {X:FiniteOrderedSet} : isdeceq X. Proof. intros. apply isfinite_isdeceq. apply finitenessProperty. Defined. Lemma FiniteOrderedSet_isdec_ordering {X:FiniteOrderedSet} : isdec_ordering X. Proof. intros. apply isfinite_isdec_ordering. apply finitenessProperty. Defined. Definition FiniteOrderedSetDecidableOrdering (X:FiniteOrderedSet) : DecidableRelation X := λ (x y:X), decidable_to_DecidableProposition (FiniteOrderedSet_isdec_ordering x y). Definition FiniteOrderedSetDecidableEquality (X:FiniteOrderedSet) : DecidableRelation X := λ (x y:X), @decidable_to_DecidableProposition (x = y) (FiniteOrderedSet_isdeceq x y). Definition FiniteOrderedSetDecidableInequality (X:FiniteOrderedSet) : DecidableRelation X. intros x y. apply (@decidable_to_DecidableProposition (¬ (x = y)))%logic. unfold decidable; simpl. apply neg_isdecprop. apply decidable_to_isdecprop_2. { apply setproperty. } apply FiniteOrderedSet_isdeceq. Defined. Definition FiniteOrderedSetDecidableLessThan (X:FiniteOrderedSet) : DecidableRelation X. intros x y. simple refine (decidable_to_DecidableProposition _). - exact (x < y). - apply isfinite_isdec_lessthan. apply finitenessProperty. Defined. Declare Scope foset. Notation "x ≐ y" := (FiniteOrderedSetDecidableEquality _ x y) (at level 70, no associativity) : foset. (* in agda mode, \doteq *) Notation "x ≠ y" := (FiniteOrderedSetDecidableInequality _ x y) (at level 70, no associativity) : foset. (* in agda mode, \ne *) Notation " x ≤ y " := ( FiniteOrderedSetDecidableOrdering _ x y ) (at level 70, no associativity) : foset. (* in agda mode, \le *) Notation " x <= y " := ( FiniteOrderedSetDecidableOrdering _ x y ) (at level 70, no associativity) : foset. Notation " x ≥ y " := ( FiniteOrderedSetDecidableOrdering _ y x ) (at level 70, no associativity) : foset. (* in agda mode, \ge *) Notation " x >= y " := ( FiniteOrderedSetDecidableOrdering _ y x ) (at level 70, no associativity) : foset. Notation " x < y " := ( FiniteOrderedSetDecidableLessThan _ x y ) (at level 70, no associativity) : foset. Notation " x > y " := ( FiniteOrderedSetDecidableLessThan _ y x ) (at level 70, no associativity) : foset. Delimit Scope foset with foset. Definition FiniteOrderedSet_segment {X:FiniteOrderedSet} (x:X) : FiniteSet. intros. apply (@subsetFiniteSet X); intro y. exact (y < x)%foset. Defined. Definition height {X:FiniteOrderedSet} : X -> nat. intros x. exact (cardinalityFiniteSet (FiniteOrderedSet_segment x)). Defined. Definition height_stn {X:FiniteOrderedSet} : X -> stn (cardinalityFiniteSet X). Proof. intros x. exists (height x). (* Defined. *) Abort. (** making finite ordered sets in various ways *) Definition standardFiniteOrderedSet (n:nat) : FiniteOrderedSet. Proof. intros. simple refine (_,,_). - exists (stnposet n). intros x y; apply istotalnatleh. - apply isfinitestn. Defined. Notation "⟦ n ⟧" := (standardFiniteOrderedSet n) : foset. (* in agda-mode \[[ n \]] *) Lemma inducedPartialOrder {X Y} (f:X->Y) (incl:isInjective f) (R:hrel Y) (po:isPartialOrder R) : isPartialOrder (λ x x' : X, R (f x) (f x')). Proof. intros. split. - split. * intros x y z a b. exact (pr1 (pr1 po) (f x) (f y) (f z) a b). * intros x. exact (pr2 (pr1 po) (f x)). - intros x y a b. apply incl. exact (pr2 po (f x) (f y) a b). Defined. Corollary inducedPartialOrder_weq {X Y} (f:X≃Y) (R:hrel Y) (po:isPartialOrder R) : isPartialOrder (λ x x' : X, R (f x) (f x')). Proof. intros. exact (inducedPartialOrder f (incl_injectivity f (weqproperty f)) R po). Defined. Local Open Scope foset. Definition transportFiniteOrdering {n} {X:UU} : X ≃ ⟦ n ⟧ -> FiniteOrderedSet. (* The new finite ordered set has X as its underlying set. *) Proof. intros w. simple refine (_,,_). - simple refine (_,,_). * simple refine (_,,_). + exists X. apply (isofhlevelweqb 2 w). apply setproperty. + unfold PartialOrder; simpl. simple refine (_,,_). { intros x y. exact (w x ≤ w y). } apply inducedPartialOrder_weq. exact (pr2 (pr2 (pr1 (pr1 (⟦ n ⟧))))). * intros x y. apply (pr2 (pr1 (⟦ n ⟧))). - simpl. apply (isfiniteweqb w). exact (pr2 (⟦ n ⟧)). Defined. Close Scope foset. (** concatenating finite ordered families of finite ordered sets *) Definition lexicographicOrder (X:hSet) (Y:X->hSet) (R:hrel X) (S : ∏ x, hrel (Y x)) : hrel (∑ x, Y x)%set. intros u u'. set (x := pr1 u). set (y := pr2 u). set (x' := pr1 u'). set (y' := pr2 u'). exact ((x != x' × R x x') ∨ (∑ e : x = x', S x' (transportf Y e y) y')). Defined. Lemma lex_isrefl (X:hSet) (Y:X->hSet) (R:hrel X) (S : ∏ x, hrel (Y x)) : (∏ x, isrefl(S x)) -> isrefl (lexicographicOrder X Y R S). Proof. intros Srefl u. induction u as [x y]. apply hdisj_in2; simpl. exists (idpath x). apply Srefl. Defined. Lemma lex_istrans (X:hSet) (Y:X->hSet) (R:hrel X) (S : ∏ x, hrel (Y x)) : isantisymm R -> istrans R -> (∏ x, istrans(S x)) -> istrans (lexicographicOrder X Y R S). Proof. intros Ranti Rtrans Strans u u' u'' p q. induction u as [x y]. induction u' as [x' y']. induction u'' as [x'' y'']. refine (p _ _); clear p; intro p; simpl in p. induction p as [p|p]. - induction p as [pn pl]. refine (q _ _); clear q; intro q; simpl in q. induction q as [q|q]. + apply hinhpr; simpl. induction q as [qn ql]. apply ii1. split. intro ne. induction ne. assert (k := Ranti x x' pl ql). contradicts pn k. exact (Rtrans x x' x'' pl ql). + induction q as [e l]. apply hinhpr; simpl. apply ii1. induction e. exact (pn,,pl). - induction p as [e s]. induction e; unfold transportf in s; simpl in s. refine (q _ _); clear q; intro q; simpl in q. induction q as [q|q]. + induction q as [n r]. apply hdisj_in1; simpl. exact (n,,r). + induction q as [e' s']. induction e'. unfold transportf in s'; simpl in s'. apply hdisj_in2; simpl. exists (idpath x). exact (Strans x y y' y'' s s'). Defined. Local Ltac unwrap a := apply (squash_to_prop a); [ apply isaset_total2_hSet | simpl; clear a; intro a; simpl in a ]. Lemma lex_isantisymm (X:hSet) (Y:X->hSet) (R:hrel X) (S : ∏ x, hrel (Y x)) : isantisymm R -> (∏ x, isantisymm(S x)) -> isantisymm (lexicographicOrder X Y R S). Proof. intros Ranti Santi u u' a b. induction u as [x y]; induction u' as [x' y']. unwrap a. unwrap b. induction a as [[m r]|a]. - induction b as [[n s]|b]. + assert (eq := Ranti x x' r s). contradicts m eq. + induction b as [eq s]. contradicts (!eq) m. - induction a as [eq s]. induction b as [[n r]|b]. { contradicts n (!eq). } induction b as [eq' s']. assert ( c : eq = !eq' ). { apply setproperty. } induction (!c); clear c. induction eq'. assert ( t : y = y' ). { apply (Santi x' y y' s s'). } induction t. reflexivity. Defined. Lemma lex_istotal (X:hSet) (Y:X->hSet) (R:hrel X) (S : ∏ x, hrel (Y x)) : isdeceq X -> istotal R -> (∏ x, istotal(S x)) -> istotal (lexicographicOrder X Y R S). Proof. intros Xdec Rtot Stot u u'. induction u as [x y]. induction u' as [x' y']. induction (Xdec x x') as [eq|ne]. { refine (Stot x' (transportf Y eq y) y' _ _); intro P. induction P as [P|P]. { apply hdisj_in1. unfold lexicographicOrder; simpl. apply hdisj_in2. exact (eq,,P). } { apply hdisj_in2. unfold lexicographicOrder; simpl. apply hdisj_in2. induction eq. exact (idpath _,,P). }} { refine (Rtot x x' _ _); intro P. induction P as [P|P]. { apply hdisj_in1. apply hdisj_in1. simpl. exact (ne,,P). } { apply hdisj_in2. apply hdisj_in1. simpl. exact (ne ∘ pathsinv0,,P). }} Defined. Definition concatenateFiniteOrderedSets {X:FiniteOrderedSet} (Y:X->FiniteOrderedSet) : FiniteOrderedSet. Proof. (* we use lexicographic order *) intros. simple refine (_,,_). { simple refine (_,,_). { simple refine (_,,_). { exact (∑ x, Y x)%set. } simple refine (_,,_). { apply lexicographicOrder. apply posetRelation. intro. apply posetRelation. } split. { split. { apply lex_istrans. { apply isantisymm_posetRelation. } { apply istrans_posetRelation. } { intro. apply istrans_posetRelation. } } apply lex_isrefl. intro; apply isrefl_posetRelation. } apply lex_isantisymm. { apply isantisymm_posetRelation. } intro. apply isantisymm_posetRelation. } apply lex_istotal. { apply FiniteOrderedSet_isdeceq. } { apply istotal_FiniteOrderedSet. } intro; apply istotal_FiniteOrderedSet. } apply isfinitetotal2. { apply finitenessProperty. } intro; apply finitenessProperty. Defined. Notation "'∑' x .. y , P" := (concatenateFiniteOrderedSets (λ x, .. (concatenateFiniteOrderedSets (λ y, P)) ..)) (at level 200, x binder, y binder, right associativity) : foset. (* type this in emacs in agda-input method with \sum *) (** sorting finite ordered sets *) Definition FiniteStructure (X:OrderedSet) := ∑ n, ⟦ n ⟧ %foset ≅ X. Local Lemma std_auto n : iscontr (⟦ n ⟧ ≅ ⟦ n ⟧) %foset. Proof. intros. exists (identityPosetEquivalence _). intros f. apply subtypePath. { intros g. apply isaprop_isPosetEquivalence. } simpl. apply isinjpr1weq. simpl. apply funextfun. intros i. (* proof in progress... *) Abort. Lemma isapropFiniteStructure X : isaprop (FiniteStructure X). Proof. intros. apply invproofirrelevance; intros r s. destruct r as [m p]. destruct s as [n q]. apply subtypePairEquality. { intros k. apply invproofirrelevance; intros [[r b] i] [[s c] j]; simpl in r,s,i,j. (* proof in progress... *) admit. } { apply weqtoeqstn. exact (weqcomp (pr1 p) (invweq (pr1 q))). } Abort. Theorem enumeration_FiniteOrderedSet (X:FiniteOrderedSet) : iscontr (FiniteStructure X). Proof. intros. simple refine (_,,_). { exists (fincard (finitenessProperty X)). (* proof in progress... *) Abort. Theorem isasetFiniteOrderedSet : isaset FiniteOrderedSet. (* This theorem will be useful for formalizing simplicial objects, which are contravariant functors from the category [Ord] to another category. There are two definitions of [Ord]: in the first, the set of objects in [nat]. In the second, the set of objects is the type of nonempty finite ordered sets. This theorem is part of showing those definitions are equivalent. The second definition is more convenient, for if A and B are objects, so is [coprod A B], where the elements of A come before the elements of B. *) Proof. Abort. (** * computably ordered sets *) (* Here we abstract from Chapter 11 of the HoTT book just the order properties of the real numbers, as constructed there. *) Definition isLattice {X:hSet} (le:hrel X) (min max:binop X) := ∑ po : isPartialOrder le, ∑ lub : ∏ x y z, le x z ∧ le y z <-> le (max x y) z, ∑ glb : ∏ x y t, le t x ∧ le t y <-> le t (min x y), unit. Definition istrans2 {X:hSet} (le lt:hrel X) := ∑ transltle: ∏ x y z, lt x y -> le y z -> lt x z, ∑ translelt: ∏ x y z, le x y -> lt y z -> lt x z, unit. Definition iswklin {X} (lt:hrel X) := ∏ x y z, lt x y -> lt x z ∨ lt z y. Definition isComputablyOrdered {X:hSet} (lt:hrel X) (min max:binop X) := let le x y := ¬ lt y x in ∑ latt: isLattice le min max, ∑ trans2: istrans2 le lt, ∑ translt: istrans lt, ∑ irrefl: isirrefl lt, ∑ cotrans: iscotrans lt, unit. Local Ltac expand ic := induction ic as [[[[transle reflle]antisymmle][lub[glb _]]] [[transltle [translelt _]][translt[irrefl[cotrans _]]]]]. Section OtherProperties. Variable (X:hSet) (lt:hrel X) (min max:binop X) (ic:isComputablyOrdered lt min max). Let le x y := ¬ lt y x. Let apart x y := lt y x ∨ lt x y. Local Lemma apart_isirrefl : isirrefl apart. Proof. expand ic. intros x a. unfold apart in a. apply (a hfalse); clear a; intros b. induction b as [b|b]; exact (irrefl _ b). Defined. Local Lemma lt_implies_le x y : lt x y -> le x y. Proof. intros l. intro m. expand ic. assert (n := translt _ _ _ l m). exact (irrefl _ n). Defined. Local Lemma apart_implies_ne x y : apart x y -> x != y. Proof. expand ic. intros a e. induction e. apply (apart_isirrefl _ a). Defined. Local Lemma tightness x y : ¬ apart x y <-> x = y. Proof. expand ic. split. - intro m. assert (p := fromnegcoprod_prop m); clear m. induction p as [p q]. now apply antisymmle. - intro e. induction e. apply apart_isirrefl. Defined. Local Lemma ne_implies_dnegapart x y : x != y -> ¬¬ apart x y. Proof. intros n m. refine (n _); clear n. now apply tightness. Defined. Section ClassicalProperties. Variable lem:LEM. Local Lemma ne_implies_apart x y : x != y -> apart x y. Proof. intros a. apply (dneg_LEM _ lem). now apply ne_implies_dnegapart. Defined. Local Lemma trichotomy x y : lt x y ∨ x = y ∨ lt y x. Proof. intros. induction (lem (x = y)) as [a|b]. - apply hdisj_in2; apply hdisj_in1; exact a. - assert (l := ne_implies_apart _ _ b); clear b. unfold apart in l. refine (l _ _); intro m; clear l. induction m as [n|o]. * apply hdisj_in2; apply hdisj_in2; exact n. * apply hdisj_in1; exact o. Defined. Local Lemma le_istotal : istotal le. Proof. intros x y. assert (m := trichotomy x y). refine (m _ _); clear m; intro m; induction m as [m|m]. - apply hdisj_in1. apply lt_implies_le. exact m. - refine (m _ _); clear m; intro m; induction m as [m|m]. * apply hdisj_in1. induction m. unfold le. expand ic. apply irrefl. * apply hdisj_in2. apply lt_implies_le. exact m. Defined. End ClassicalProperties. End OtherProperties. UniMath-20231010/UniMath/Combinatorics/README.md000066400000000000000000000007631451125700300207350ustar00rootroot00000000000000Combinatorics ============ This package treats various combinatorial notions not depending on algebra. Overview of contents ==================== ## MetricTree.v Definition of a metric tree as a set with a metric on it and another property. The definition is incomplete, in the sense that if edges are added connecting pairs of points at distance 1, one may not get a tree; example: 4 equally spaced points on a circle. Nevertheless, the definition includes enough to support "tree induction". UniMath-20231010/UniMath/Combinatorics/StandardFiniteSets.v000066400000000000000000002213311451125700300233770ustar00rootroot00000000000000(** * Standard finite sets . Vladimir Voevodsky . Apr. - Sep. 2011 . This file contains main constructions related to the standard finite sets defined as the initial intervals of [ nat ] and their properties . *) (** ** Preamble *) (** Imports. *) Require Export UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.DecidablePropositions. Require Import UniMath.MoreFoundations.NegativePropositions. (** ** Standard finite sets [ stn ]. *) Definition stn ( n : nat ) := ∑ m, m < n. Definition make_stn n m (l:m nat := @pr1 _ _ . Coercion stntonat : stn >-> nat. Lemma stnlt {n : nat} (i:stn n) : i < n. Proof. intros. exact (pr2 i). Defined. (* old way: Notation " 'stnel' ( i , j ) " := ( make_stn _ _ ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ). *) Notation " 'stnpr' j " := (j,,idpath _) ( at level 70 ). Notation " 'stnel' ( i , j ) " := ( (j,,idpath _) : stn i ) ( at level 70 ). Declare Scope stn. Delimit Scope stn with stn. Notation "⟦ n ⟧" := (stn n) : stn. (* in agda-mode \[[ n \]] *) Notation "● i" := (i ,, (idpath _ : natgtb _ _ = _)) (at level 35) : stn. Lemma isinclstntonat ( n : nat ) : isincl ( stntonat n ). Proof. intro. use isinclpr1. intro x. apply ( pr2 ( natlth x n ) ). Defined. Definition stntonat_incl n := make_incl (stntonat n) (isinclstntonat n). Lemma isdecinclstntonat ( n : nat ) : isdecincl ( stntonat n ). Proof. intro. use isdecinclpr1. intro x. apply isdecpropif. use pr2. apply isdecrelnatgth. Defined. Lemma neghfiberstntonat ( n m : nat ) ( is : natgeh m n ) : ¬ ( hfiber ( stntonat n ) m ). Proof. intros. intro h. destruct h as [ j e ]. destruct j as [ j is' ]. simpl in e. rewrite e in is'. apply ( natgehtonegnatlth _ _ is is' ). Defined. Lemma iscontrhfiberstntonat ( n m : nat ) ( is : natlth m n ) : iscontr ( hfiber ( stntonat n ) m ). Proof. intros. apply ( iscontrhfiberofincl ( stntonat n ) ( isinclstntonat n ) ( make_stn n m is ) ). Defined. Local Open Scope stn. Lemma stn_ne_iff_neq {n : nat} (i j: ⟦n⟧ ) : ¬ (i = j) <-> stntonat _ i ≠ stntonat _ j. Proof. intros. split. - intro ne. apply nat_nopath_to_neq. Set Printing Coercions. idtac. intro e; apply ne; clear ne. apply subtypePath_prop. assumption. - simpl. intros neq e. apply (nat_neq_to_nopath neq), maponpaths. assumption. Unset Printing Coercions. Defined. Lemma stnneq {n : nat} : neqReln (⟦n⟧). Proof. (* here we use no axioms *) intros i j. exists (i ≠ j)%nat. split. - apply propproperty. - apply stn_ne_iff_neq. Defined. Notation " x ≠ y " := ( stnneq x y ) (at level 70, no associativity) : stn. Delimit Scope stn with stn. Local Open Scope stn. Lemma isisolatedinstn { n : nat } ( x : ⟦n⟧ ) : isisolated _ x. Proof. intros. apply ( isisolatedinclb ( stntonat n ) ( isinclstntonat n ) x ( isisolatedn x ) ). Defined. Lemma stnneq_iff_nopath {n : nat} (i j: ⟦n⟧ ) : ¬ (i = j) <-> i ≠ j. Proof. intros. apply negProp_to_iff. Defined. Definition stnneq_to_nopath {n : nat} (i j: ⟦n⟧ ) : ¬ (i = j) <- i ≠ j := pr2 (stn_ne_iff_neq i j). Corollary isdeceqstn ( n : nat ) : isdeceq (⟦n⟧). Proof. unfold isdeceq. intros x x'. apply (isisolatedinstn x x' ). Defined. Lemma stn_eq_or_neq {n : nat} (i j: ⟦n⟧ ) : (i=j) ⨿ (i≠j). Proof. intros. induction (nat_eq_or_neq i j) as [eq|ne]. - apply ii1, subtypePath_prop. assumption. - apply ii2. assumption. Defined. Definition weqisolatedstntostn ( n : nat ) : ( isolated (⟦n⟧) ) ≃ ⟦n⟧. Proof. apply weqpr1. intro x. apply iscontraprop1. apply isapropisisolated. set ( int := isdeceqstn n x ). assumption. Defined. Corollary isasetstn ( n : nat ) : isaset (⟦n⟧). Proof. intro. apply ( isasetifdeceq _ ( isdeceqstn n ) ). Defined. Definition stnset n := make_hSet (⟦n⟧) (isasetstn n). Definition stn_to_nat n : stnset n -> natset := pr1. Definition stnposet ( n : nat ) : Poset. Proof. unfold Poset. exists (_,,isasetstn n). unfold PartialOrder. exists (λ i j: ⟦n⟧, i ≤ j)%dnat. unfold isPartialOrder. split. - unfold ispreorder. split. * intros i j k. apply istransnatleh. * intros i. apply isreflnatleh. - intros i j r s. apply (invmaponpathsincl _ ( isinclstntonat _ )). apply isantisymmnatleh; assumption. Defined. Definition lastelement {n : nat} : ⟦S n⟧. Proof. split with n. apply ( natgthsnn n ). Defined. Lemma lastelement_ge {n : nat} : ∏ i : ⟦S n⟧, @lastelement n ≥ i. Proof. intros. apply natlthsntoleh. unfold lastelement. apply stnlt. Defined. Definition firstelement {n : nat} : ⟦S n⟧. Proof. exists 0. apply natgthsn0. Defined. Lemma firstelement_le {n : nat} : ∏ i : ⟦S n⟧, @firstelement n ≤ i. Proof. intros. apply idpath. Defined. Definition firstValue {X:UU} {n:nat} : (⟦S n⟧ -> X) -> X := λ x, x firstelement. Definition lastValue {X:UU} {n:nat} : (⟦S n⟧ -> X) -> X := λ x, x lastelement. (** Dual of i in stn n, is n - 1 - i *) Local Lemma dualelement_0_empty {n : nat} (i : ⟦n⟧ ) (e : 0 = n) : empty. Proof. induction e. apply (negnatlthn0 _ (stnlt i)). Qed. Local Lemma dualelement_lt (i n : nat) (H : n > 0) : n - 1 - i < n. Proof. rewrite natminusminus. apply (natminuslthn _ _ H). apply idpath. Qed. Definition dualelement {n : nat} (i : ⟦n⟧ ) : ⟦n⟧. Proof. induction (natchoice0 n) as [H | H]. - exact (make_stn n (n - 1 - i) (fromempty (dualelement_0_empty i H))). - exact (make_stn n (n - 1 - i) (dualelement_lt i n H)). Defined. Definition stnmtostnn ( m n : nat ) (isnatleh: natleh m n ) : ⟦m⟧ -> ⟦n⟧ := λ x : ⟦m⟧, match x with tpair _ i is => make_stn _ i ( natlthlehtrans i m n is isnatleh ) end. Definition stn_left (m n : nat) : ⟦m⟧ -> ⟦m+n⟧. Proof. intros i. exists (pr1 i). apply (natlthlehtrans (pr1 i) m (m+n) (pr2 i)). apply natlehnplusnm. Defined. Definition stn_right (m n : nat) : ⟦n⟧ -> ⟦m+n⟧. Proof. intros i. exists (m+pr1 i). apply natlthandplusl. exact (pr2 i). Defined. Definition stn_left_compute (m n : nat) (i: ⟦m⟧ ) : pr1 (stn_left m n i) = i. Proof. intros. apply idpath. Defined. Definition stn_right_compute (m n : nat) (i: ⟦n⟧ ) : pr1 (stn_right m n i) = m+i. Proof. intros. apply idpath. Defined. Lemma stn_left_0 {m:nat} {i:⟦m⟧} (e: m=m+0) : stn_left m 0 i = transportf stn e i. Proof. intros. apply subtypePath_prop. induction e. apply idpath. Defined. Definition stn_left' (m n : nat) : m ≤ n -> ⟦m⟧ -> ⟦n⟧. Proof. intros le i. exact (make_stn _ _ (natlthlehtrans _ _ _ (stnlt i) le)). Defined. Definition stn_left'' {m n : nat} : m < n -> ⟦m⟧ -> ⟦n⟧. Proof. intros le i. exact (make_stn _ _ (istransnatlth _ _ _ (stnlt i) le)). Defined. Lemma stn_left_compare (m n : nat) (r : m ≤ m+n) : stn_left' m (m+n) r = stn_left m n. Proof. intros. apply funextfun; intro i. apply subtypePath_prop. apply idpath. Defined. (** ** "Boundary" maps [ dni : stn n -> stn ( S n ) ] and their properties. *) Definition dni {n : nat} ( i : ⟦S n⟧ ) : ⟦n⟧ -> ⟦S n⟧. Proof. intros x. exists (di i x). unfold di. induction (natlthorgeh x i) as [lt|ge]. - apply natgthtogths. exact (pr2 x). - exact (pr2 x). Defined. Definition compute_pr1_dni_last (n : nat) (i: ⟦n⟧ ) : pr1 (dni lastelement i) = pr1 i. Proof. intros. unfold dni,di; simpl. induction (natlthorgeh i n) as [q|q]. - apply idpath. - contradicts (pr2 i) (natlehneggth q). Defined. Definition compute_pr1_dni_first (n : nat) (i: ⟦n⟧ ) : pr1 (dni firstelement i) = S (pr1 i). Proof. intros. apply idpath. Defined. Lemma dni_last {n : nat} (i: ⟦n⟧ ) : pr1 (dni lastelement i) = i. Proof. intros. induction i as [i I]. unfold dni,di. simpl. induction (natlthorgeh i n) as [g|g]. { apply idpath. } simpl. contradicts (natlehtonegnatgth _ _ g) I. Defined. Lemma dni_first {n : nat} (i: ⟦n⟧ ) : pr1 (dni firstelement i) = S i. Proof. intros. apply idpath. Defined. Definition dni_firstelement {n : nat} : ⟦n⟧ -> ⟦S n⟧. (* this definition is simpler than that of [dni n (firstelement n)], since no choice is involved, so it's useful in special situations *) Proof. intros h. exact (S (pr1 h),, pr2 h). Defined. Definition replace_dni_first (n : nat) : dni (@firstelement n) = dni_firstelement. Proof. intros. apply funextfun; intros i. apply subtypePath_prop. exact (compute_pr1_dni_first n i). Defined. Definition dni_lastelement {n : nat} : ⟦n⟧ -> ⟦S n⟧. (* this definition is simpler than that of [dni lastelement], since no choice is involved, so it's useful in special situations *) Proof. intros h. exists (pr1 h). exact (natlthtolths _ _ (pr2 h)). Defined. Definition replace_dni_last (n : nat) : dni (@lastelement n) = dni_lastelement. Proof. intros. apply funextfun; intros i. apply subtypePath_prop. exact (compute_pr1_dni_last n i). Defined. Lemma dni_lastelement_ord {n : nat} : ∏ i j: ⟦n⟧, i≤j -> dni_lastelement i ≤ dni_lastelement j. Proof. intros ? ? e. exact e. Defined. Definition pr1_dni_lastelement {n : nat} {i: ⟦n⟧ } : pr1 (dni_lastelement i) = pr1 i. Proof. intros. apply idpath. Defined. Lemma dni_last_lt {n : nat} (j : ⟦ n ⟧) : dni lastelement j < @lastelement n. Proof. intros. induction j as [j J]. simpl. unfold di. induction (natlthorgeh j n) as [L|M]. - exact J. - apply fromempty. exact (natlthtonegnatgeh _ _ J M). Defined. Lemma dnicommsq ( n : nat ) ( i : ⟦S n⟧ ) : commsqstr( dni i ) ( stntonat ( S n ) ) ( stntonat n ) ( di i ). Proof. intros. intro x. unfold dni. unfold di. destruct ( natlthorgeh x i ). - simpl. apply idpath. - simpl. apply idpath. Defined. Theorem dnihfsq ( n : nat ) ( i : ⟦S n⟧ ) : hfsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni i ). Proof. intros. apply ( ishfsqweqhfibersgtof' ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni i ) ( dnicommsq _ _ ) ). intro x. destruct ( natlthorgeh x n ) as [ g | l ]. - assert ( is1 : iscontr ( hfiber ( stntonat n ) x ) ). { apply iscontrhfiberstntonat. assumption. } assert ( is2 : iscontr ( hfiber ( stntonat ( S n ) ) ( di i x ) ) ). { apply iscontrhfiberstntonat. apply ( natlehlthtrans _ ( S x ) ( S n ) ( natlehdinsn i x ) g ). } apply isweqcontrcontr. + assumption. + assumption. - assert ( is1 : ¬ ( hfiber ( stntonat ( S n ) ) ( di i x ) ) ). { apply neghfiberstntonat. unfold di. destruct ( natlthorgeh x i ) as [ l'' | g' ]. + destruct ( natgehchoice2 _ _ l ) as [ g' | e ]. * apply g'. * rewrite e in l''. assert ( int := natlthtolehsn _ _ l'' ). contradicts (natgthnegleh (pr2 i)) int. + apply l. } apply ( isweqtoempty2 _ is1 ). Defined. Lemma dni_neq_i {n : nat} (i : ⟦S n⟧) (j : ⟦n⟧ ) : i ≠ @dni n i j. Proof. intros. simpl. apply di_neq_i. Defined. Lemma weqhfiberdnihfiberdi ( n : nat ) ( i j : ⟦S n⟧ ) : ( hfiber ( dni i ) j ) ≃ ( hfiber ( di i ) j ). Proof. intros. apply ( weqhfibersg'tof _ _ _ _ ( dnihfsq n i ) j ). Defined. Lemma neghfiberdni ( n : nat ) ( i : ⟦S n⟧ ) : ¬ ( hfiber ( dni i ) i ). Proof. intros. apply ( negf ( weqhfiberdnihfiberdi n i i ) ( neghfiberdi i ) ). Defined. Lemma iscontrhfiberdni ( n : nat ) ( i j : ⟦S n⟧ ) : i ≠ j -> iscontr ( hfiber ( dni i ) j ). Proof. intros ne. exact ( iscontrweqb ( weqhfiberdnihfiberdi n i j ) ( iscontrhfiberdi i j ne ) ). Defined. Lemma isdecincldni ( n : nat ) ( i : ⟦S n⟧ ) : isdecincl ( dni i ). Proof. intros. intro j. induction ( stn_eq_or_neq i j ) as [eq|ne]. - induction eq. apply ( isdecpropfromneg ( neghfiberdni n i ) ). - exact ( isdecpropfromiscontr (iscontrhfiberdni _ _ _ ne) ). Defined. Lemma isincldni ( n : nat ) ( i : ⟦S n⟧ ) : isincl ( dni i ). Proof. intros. exact ( isdecincltoisincl _ ( isdecincldni n i ) ). Defined. (** ** The order-preserving functions [ sni n i : stn (S n) -> stn n ] that take the value [i] twice. *) Definition sni {n : nat} ( i : ⟦n⟧ ) : ⟦n⟧ <- ⟦S n⟧. Proof. intros j. exists (si i j). unfold si. induction (natlthorgeh i j) as [lt|ge]. - induction j as [j J]. induction i as [i I]. simpl. induction j as [|j _]. + contradicts (negnatlthn0 i) lt. + change (S j - 1 < n). change (S j) with (1 + j). rewrite natpluscomm. rewrite plusminusnmm. exact J. - induction i as [i I]. exact (natlehlthtrans _ _ _ ge I). Defined. (** ** Weak equivalences between standard finite sets and constructions on these sets *) (** *** The weak equivalence from [ stn n ] to the complement of a point [ j ] in [ stn ( S n ) ] defined by [ dni j ] *) Definition stn_compl {n : nat} (i: ⟦n⟧ ) := compl_ne _ i (stnneq i). Definition dnitocompl ( n : nat ) ( i : ⟦S n⟧ ) : ⟦n⟧ -> stn_compl i. Proof. intros j. exists ( dni i j ). apply dni_neq_i. Defined. Lemma isweqdnitocompl ( n : nat ) ( i : ⟦S n⟧ ) : isweq ( dnitocompl n i ). Proof. intros jni. assert ( w := samehfibers ( dnitocompl n i ) _ ( isinclpr1compl_ne _ i _ ) jni ) ; simpl in w. apply (iscontrweqb w). apply iscontrhfiberdni. exact (pr2 jni). Defined. Definition weqdnicompl {n : nat} (i: ⟦S n⟧ ): ⟦n⟧ ≃ stn_compl i. Proof. intros. set (w := weqdicompl (stntonat _ i)). assert (eq : ∏ j, j < n <-> pr1 (w j) < S n). { simpl in w. intros j. unfold w. change (pr1 ((weqdicompl i) j)) with (di (stntonat _ i) j). unfold di. induction (natlthorgeh j i) as [lt|ge]. - split. + apply natlthtolths. + intros _. exact (natlehlthtrans (S j) i (S n) lt (pr2 i)). - split; exact (idfun _). } refine (_ ∘ (weq_subtypes w (λ j, j < n) (λ j, pr1 j < S n) eq))%weq. use weqtotal2comm12. Defined. Definition weqdnicompl_compute {n : nat} (j: ⟦S n⟧ ) (i: ⟦n⟧ ) : pr1 (weqdnicompl j i) = dni j i. Proof. intros. apply subtypePath_prop. apply idpath. Defined. (** *** Weak equivalence from [ coprod ( stn n ) unit ] to [ stn ( S n ) ] defined by [ dni i ] *) Definition weqdnicoprod_provisional (n : nat) (j : ⟦S n⟧) : ⟦n⟧ ⨿ unit ≃ ⟦S n⟧. Proof. intros. apply (weqcomp (weqcoprodf (weqdnicompl j) (idweq unit)) (weqrecompl_ne (⟦S n⟧) j (isdeceqstn (S n) j) (stnneq j))). Defined. Opaque weqdnicoprod_provisional. Definition weqdnicoprod_map {n : nat} (j : ⟦S n⟧ ) : ⟦n⟧ ⨿ unit -> ⟦S n⟧. Proof. intros x. induction x as [i|t]. - exact (dni j i). - exact j. Defined. Definition weqdnicoprod_compute {n : nat} (j : ⟦S n⟧ ) : weqdnicoprod_provisional n j ~ weqdnicoprod_map j. Proof. intros. intros i. induction i as [i|i]. - apply subtypePath_prop. induction i as [i I]. apply idpath. - apply idpath. Defined. Definition weqdnicoprod (n : nat) (j : ⟦S n⟧ ) : ⟦n⟧ ⨿ unit ≃ ⟦S n⟧. Proof. intros. apply (make_weq (weqdnicoprod_map j)). apply (isweqhomot _ _ (weqdnicoprod_compute _)). apply weqproperty. Defined. Definition weqoverdnicoprod {n : nat} (P: ⟦S n⟧ → UU) : (∑ i, P i) ≃ (∑ j, P(dni lastelement j)) ⨿ P lastelement. Proof. intros. use (weqcomp (weqtotal2overcoprod' P (weqdnicoprod n lastelement))). apply weqcoprodf. - apply idweq. - apply weqtotal2overunit. Defined. Lemma weqoverdnicoprod_eq1 {n : nat} (P: ⟦S n⟧ → UU) j p : invmap (weqoverdnicoprod P) (ii1 (j,,p)) = ( dni lastelement j ,, p ). Proof. intros. simpl in p. apply idpath. Defined. Lemma weqoverdnicoprod_eq1' {n : nat} (P: ⟦S n⟧ → UU) jp : invmap (weqoverdnicoprod P) (ii1 jp) = (total2_base_map (dni lastelement) jp). Proof. intros. induction jp. apply idpath. Defined. Lemma weqoverdnicoprod_eq2 {n : nat} (P: ⟦S n⟧→UU) p : invmap (weqoverdnicoprod P) (ii2 p) = (lastelement ,, p ). Proof. intros. apply idpath. Defined. Definition weqdnicoprod_invmap {n : nat} (j : ⟦S n⟧ ) : ⟦n⟧ ⨿ unit <- ⟦S n⟧. (* perhaps use this to improve weqdnicoprod *) Proof. intros i. induction (isdeceqstn (S n) i j) as [eq|ne]. - exact (ii2 tt). - apply ii1. induction i as [i I]. induction j as [j J]. choose (i < j)%dnat a a. + exists i. exact (natltltSlt _ _ _ a J). + exists (i - 1). induction (natlehchoice _ _ (negnatgthtoleh a)) as [b|b]. * induction (natlehchoice4 _ _ I) as [c|c]. -- apply (natlehlthtrans (i - 1) i n). ++ apply natminuslehn. ++ exact c. -- induction c. apply natminuslthn. ++ apply (natlehlthtrans _ j _). ** apply natleh0n. ** exact b. ++ apply natlthnsn. * induction b. induction (ne (@subtypePath_prop _ _ (make_stn _ j I) (make_stn _ j J) (idpath j))). Defined. (** *** Weak equivalences from [ stn n ] for [ n = 0 , 1 , 2 ] to [ empty ] , [ unit ] and [ bool ] ( see also the section on [ nelstruct ] in finitesets.v ). *) Definition negstn0 : ¬ (⟦0⟧). Proof. intro x. destruct x as [ a b ]. apply ( negnatlthn0 _ b ). Defined. Definition weqstn0toempty : ⟦0⟧ ≃ empty. Proof. apply weqtoempty. apply negstn0. Defined. Definition weqstn1tounit : ⟦1⟧ ≃ unit. Proof. set ( f := λ x : ⟦1⟧, tt ). apply weqcontrcontr. - split with lastelement. intro t. destruct t as [ t l ]. set ( e := natlth1tois0 _ l ). apply ( invmaponpathsincl _ ( isinclstntonat 1 ) ( make_stn _ t l ) lastelement e ). - apply iscontrunit. Defined. Corollary iscontrstn1 : iscontr (⟦1⟧). Proof. apply iscontrifweqtounit. apply weqstn1tounit. Defined. Corollary isconnectedstn1 : ∏ i1 i2 : ⟦1⟧, i1 = i2. Proof. intros i1 i2. apply (invmaponpathsweq weqstn1tounit). apply isProofIrrelevantUnit. Defined. Lemma isinclfromstn1 { X : UU } ( f : ⟦1⟧ -> X ) ( is : isaset X ) : isincl f. Proof. intros. apply ( isinclbetweensets f ( isasetstn 1 ) is ). intros x x' e. apply ( invmaponpathsweq weqstn1tounit x x' ( idpath tt ) ). Defined. Definition weqstn2tobool : ⟦2⟧ ≃ bool. Proof. set ( f := λ j : ⟦2⟧, match ( isdeceqnat j 0 ) with ii1 _ => false | ii2 _ => true end ). set ( g := λ b : bool, match b with false => make_stn 2 0 ( idpath true ) | true => make_stn 2 1 ( idpath true ) end ). split with f. assert ( egf : ∏ j : _ , paths ( g ( f j ) ) j ). { intro j. unfold f. destruct ( isdeceqnat j 0 ) as [ e | ne ]. - apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ). rewrite e. apply idpath. - apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ). destruct j as [ j l ]. simpl. set ( l' := natlthtolehsn _ _ l ). destruct ( natlehchoice _ _ l' ) as [ l'' | e ]. + simpl in ne. destruct ( ne ( natlth1tois0 _ l'' ) ). + apply ( pathsinv0 ( invmaponpathsS _ _ e ) ). } assert ( efg : ∏ b : _ , paths ( f ( g b ) ) b ). { intro b. unfold g. destruct b. - apply idpath. - apply idpath. } apply ( isweq_iso _ _ egf efg ). Defined. Lemma isinjstntonat (n : nat) : isInjectiveFunction (pr1 : stnset n -> natset). Proof. intros i j. apply subtypePath_prop. Defined. (** *** Weak equivalence between the coproduct of [ stn n ] and [ stn m ] and [ stn ( n + m ) ] *) Definition weqfromcoprodofstn_invmap (n m : nat) : ⟦n + m⟧ -> (⟦n⟧ ⨿ ⟦m⟧). Proof. intros i. induction (natlthorgeh i n) as [i1 | i2]. - exact (ii1 (make_stn n i i1)). - exact (ii2 (make_stn m (i - n) (nat_split (pr2 i) i2))). Defined. Lemma weqfromcoprodofstn_invmap_r0 (n : nat) (i : ⟦n+0⟧ ) : weqfromcoprodofstn_invmap n 0 i = ii1 (transportf stn (natplusr0 n) i). Proof. intros. unfold weqfromcoprodofstn_invmap. simpl. induction (natlthorgeh i n) as [I|J]. - simpl. apply maponpaths. apply subtypePath_prop. simpl. induction (natplusr0 n). apply idpath. - simpl. apply fromempty. induction (! natplusr0 n). exact (natgehtonegnatlth _ _ J (stnlt i)). Defined. Definition weqfromcoprodofstn_map (n m : nat) : (⟦n⟧ ⨿ ⟦m⟧) -> ⟦n+m⟧. Proof. intros i. induction i as [i | i]. - apply stn_left. assumption. - apply stn_right. assumption. Defined. Lemma weqfromcoprodofstn_eq1 (n m : nat) : ∏ x : ⟦n⟧ ⨿ ⟦m⟧, weqfromcoprodofstn_invmap n m (weqfromcoprodofstn_map n m x) = x. Proof. intros x. unfold weqfromcoprodofstn_map, weqfromcoprodofstn_invmap. unfold coprod_rect. induction x as [x | x]. - induction (natlthorgeh (stn_left n m x) n) as [H | H]. + apply maponpaths. apply isinjstntonat. apply idpath. + apply fromempty. apply (natlthtonegnatgeh x n (stnlt x) H). - induction (natlthorgeh (stn_right n m x) n) as [H | H]. + apply fromempty. set (tmp := natlehlthtrans n (n + x) n (natlehnplusnm n x) H). use (isirrefl_natneq n (natlthtoneq _ _ tmp)). + apply maponpaths. apply isinjstntonat. cbn. rewrite natpluscomm. apply plusminusnmm. Qed. Lemma weqfromcoprodofstn_eq2 (n m : nat) : ∏ y : ⟦n+m⟧, weqfromcoprodofstn_map n m (weqfromcoprodofstn_invmap n m y) = y. Proof. intros x. unfold weqfromcoprodofstn_map, weqfromcoprodofstn_invmap. unfold coprod_rect. induction (natlthorgeh x n) as [H | H]. - apply isinjstntonat. apply idpath. - induction (natchoice0 m) as [H1 | H1]. + apply fromempty. induction H1. induction (! (natplusr0 n)). use (natlthtonegnatgeh x n (stnlt x) H). + apply isinjstntonat. cbn. rewrite natpluscomm. apply minusplusnmm. apply H. Qed. (** A proof of weqfromcoprodofstn using isweq_iso *) Theorem weqfromcoprodofstn (n m : nat) : (⟦n⟧ ⨿ ⟦m⟧) ≃ ⟦n+m⟧. Proof. use (tpair _ (weqfromcoprodofstn_map n m)). use (isweq_iso _ (weqfromcoprodofstn_invmap n m)). - exact (weqfromcoprodofstn_eq1 n m). - exact (weqfromcoprodofstn_eq2 n m). Defined. (** Associativity of [weqfromcoprodofstn] *) Definition pr1_eqweqmap_stn (m n : nat) (e: m=n) (i: ⟦m⟧ ) : pr1 (pr1weq (eqweqmap (maponpaths stn e)) i) = pr1 i. Proof. intros. induction e. apply idpath. Defined. Definition coprod_stn_assoc (l m n : nat) : ( eqweqmap (maponpaths stn (natplusassoc l m n)) ∘ weqfromcoprodofstn (l+m) n ∘ weqcoprodf (weqfromcoprodofstn l m) (idweq _) ~ weqfromcoprodofstn l (m+n) ∘ weqcoprodf (idweq _) (weqfromcoprodofstn m n) ∘ weqcoprodasstor _ _ _ ) %weq. Proof. intros. intros abc. simpl. apply (invmaponpathsincl pr1). apply isinclstntonat. rewrite pr1_eqweqmap_stn. induction abc as [[a|b]|c]. - simpl. apply idpath. - simpl. apply idpath. - simpl. apply natplusassoc. Defined. (** *** Weak equivalence from the total space of a family [ stn ( f x ) ] over [ stn n ] to [ stn ( stnsum n f ) ] *) Definition stnsum {n : nat} (f : ⟦n⟧ -> nat) : nat. Proof. revert f. induction n as [ | n IHn]. - intro. exact 0. - intro f. exact (IHn (λ i, f (dni lastelement i)) + f lastelement). Defined. Lemma stnsum_step {n : nat} (f: ⟦S n⟧ -> nat) : stnsum f = stnsum (f ∘ (dni lastelement)) + f lastelement. Proof. intros. apply idpath. Defined. Lemma stnsum_eq {n : nat} (f g: ⟦n⟧ -> nat) : f ~ g -> stnsum f = stnsum g. Proof. intros h. induction n as [|n IH]. - apply idpath. - rewrite 2? stnsum_step. induction (h lastelement). apply (maponpaths (λ i, i + f lastelement)). apply IH. intro x. apply h. Defined. Lemma transport_stnsum {m n : nat} (e: m=n) (g: ⟦n⟧ -> nat) : stnsum g = stnsum (λ i, g(transportf stn e i)). Proof. intros. induction e. apply idpath. Defined. Lemma stnsum_le {n : nat} (f g: ⟦n⟧ -> nat) : (∏ i, f i ≤ g i) -> stnsum f ≤ stnsum g. Proof. intros le. induction n as [|n IH]. - simpl. apply idpath. - apply natlehandplus. + apply IH. intro i. apply le. + apply le. Defined. Lemma transport_stn {m n : nat} (e: m=n) (i: ⟦m⟧ ) : transportf stn e i = make_stn n (pr1 i) (transportf (λ k, pr1 i < k) e (pr2 i)). Proof. intros. induction e. apply subtypePath_prop. apply idpath. Defined. Lemma stnsum_left_right (m n : nat) (f: ⟦m+n⟧ -> nat) : stnsum f = stnsum (f ∘ stn_left m n) + stnsum (f ∘ stn_right m n). Proof. (* why is this proof so obnoxious and fragile? *) intros. induction n as [|n IHn]. { change (stnsum _) with 0 at 3. rewrite natplusr0. assert (e := ! natplusr0 m). rewrite (transport_stnsum e). apply stnsum_eq; intro i. simpl. apply maponpaths. apply pathsinv0. apply stn_left_0. } rewrite stnsum_step. assert (e : S (m+n) = m + S n). { apply pathsinv0. apply natplusnsm. } rewrite (transport_stnsum e). rewrite stnsum_step. rewrite <- natplusassoc. apply map_on_two_paths. { rewrite IHn; clear IHn. apply map_on_two_paths. { apply stnsum_eq; intro i. simpl. apply maponpaths. apply subtypePath_prop. rewrite stn_left_compute. induction e. rewrite idpath_transportf. rewrite dni_last. apply idpath. } { apply stnsum_eq; intro i. simpl. apply maponpaths. apply subtypePath_prop. rewrite stn_right_compute. unfold stntonat. induction e. rewrite idpath_transportf. rewrite 2? dni_last. apply idpath. } } simpl. apply maponpaths. apply subtypePath_prop. induction e. apply idpath. Defined. Corollary stnsum_left_le (m n : nat) (f: ⟦m+n⟧ -> nat) : stnsum (f ∘ stn_left m n) ≤ stnsum f. Proof. intros. rewrite stnsum_left_right. apply natlehnplusnm. Defined. Corollary stnsum_left_le' {m n : nat} (f: ⟦n⟧ -> nat) (r:m≤n) : stnsum (f ∘ stn_left' m n r) ≤ stnsum f. Proof. intros. assert (s := minusplusnmm n m r). rewrite (natpluscomm (n-m) m) in s. generalize r f; clear r f. rewrite <- s; clear s. set (k := n-m). generalize k; clear k; intros k r f. induction (natpluscomm m k). rewrite stn_left_compare. rewrite stnsum_left_right. apply natlehnplusnm. Defined. Lemma stnsum_dni {n : nat} (f: ⟦S n⟧ -> nat) (j: ⟦S n⟧ ) : stnsum f = stnsum (f ∘ dni j) + f j. Proof. intros. induction j as [j J]. assert (e2 : j + (n - j) = n). { rewrite natpluscomm. apply minusplusnmm. apply natlthsntoleh. exact J. } assert (e : (S j) + (n - j) = S n). { change (S j + (n - j)) with (S (j + (n - j))). apply maponpaths. exact e2. } intermediate_path (stnsum (λ i, f (transportf stn e i))). - apply (transport_stnsum e). - rewrite (stnsum_left_right (S j) (n - j)); unfold funcomp. apply pathsinv0. rewrite (transport_stnsum e2). rewrite (stnsum_left_right j (n-j)); unfold funcomp. rewrite (stnsum_step (λ x, f (transportf stn e _))); unfold funcomp. apply pathsinv0. rewrite natplusassoc. rewrite (natpluscomm (f _)). rewrite <- natplusassoc. apply map_on_two_paths. + apply map_on_two_paths. * apply stnsum_eq; intro i. induction i as [i I]. apply maponpaths. apply subtypePath_prop. induction e. rewrite idpath_transportf. rewrite stn_left_compute. unfold dni,di, stntonat; simpl. induction (natlthorgeh i j) as [R|R]. -- unfold stntonat; simpl; rewrite transport_stn; simpl. induction (natlthorgeh i j) as [a|b]. ++ apply idpath. ++ contradicts R (natlehneggth b). -- unfold stntonat; simpl; rewrite transport_stn; simpl. induction (natlthorgeh i j) as [V|V]. ++ contradicts I (natlehneggth R). ++ apply idpath. * apply stnsum_eq; intro i. induction i as [i I]. apply maponpaths. unfold dni,di, stn_right, stntonat; repeat rewrite transport_stn; simpl. induction (natlthorgeh (j+i) j) as [X|X]. -- contradicts (negnatlthplusnmn j i) X. -- apply subtypePath_prop. simpl. apply idpath. + apply maponpaths. rewrite transport_stn; simpl. apply subtypePath_prop. apply idpath. Defined. Lemma stnsum_pos {n : nat} (f: ⟦n⟧ -> nat) (j: ⟦n⟧ ) : f j ≤ stnsum f. Proof. assert (m : 0 < n). { apply (natlehlthtrans _ j). - apply natleh0n. - exact (pr2 j). } assert (l : 1 ≤ n). { apply natlthtolehsn. assumption. } assert (e : n = S (n - 1)). { change (S (n - 1)) with (1 + (n - 1)). rewrite natpluscomm. apply pathsinv0. apply minusplusnmm. assumption. } rewrite (transport_stnsum (!e) f). rewrite (stnsum_dni _ (transportf stn e j)). unfold funcomp. generalize (stnsum (λ x, f (transportf stn (! e) (dni (transportf stn e j) x)))); intro s. induction e. apply natlehmplusnm. Defined. Corollary stnsum_pos_0 {n : nat} (f: ⟦S n⟧ -> nat) : f firstelement ≤ stnsum f. Proof. intros. exact (stnsum_pos f firstelement). Defined. Lemma stnsum_1 (n : nat) : stnsum(λ i: ⟦n⟧, 1) = n. Proof. intros. induction n as [|n IH]. { apply idpath. } simpl. use (natpluscomm _ _ @ _). apply maponpaths. exact IH. Defined. Lemma stnsum_const {m c : nat} : stnsum (λ i: ⟦m⟧, c) = m*c. Proof. intros. induction m as [|m I]. - apply idpath. - exact (maponpaths (λ i, i+c) I). Defined. Lemma stnsum_last_le {n : nat} (f: ⟦S n⟧ -> nat) : f lastelement ≤ stnsum f. Proof. intros. rewrite stnsum_step. apply natlehmplusnm. Defined. Lemma stnsum_first_le {n : nat} (f: ⟦S n⟧ -> nat) : f firstelement ≤ stnsum f. Proof. intros. induction n as [|n IH]. - apply isreflnatleh. - rewrite stnsum_step. assert (W := IH (f ∘ dni lastelement)). change ((f ∘ dni lastelement) firstelement) with (f firstelement) in W. apply (istransnatleh W); clear W. apply natlehnplusnm. Defined. Lemma _c_ {n : nat} {m: ⟦ n ⟧ → nat} (ij : ∑ i : ⟦ n ⟧, ⟦ m i ⟧) : stnsum (m ∘ stn_left'' (stnlt (pr1 ij))) + pr2 ij < stnsum m. Proof. intros. set (m1 := m ∘ stn_left'' (stnlt (pr1 ij))). induction ij as [i j]. induction i as [i I]. induction j as [j J]. simpl in m1. change (stnsum m1 + j < stnsum m). assert (s := stnsum_left_le' m (I : S i ≤ n)). use (natlthlehtrans _ _ _ _ s). clear s. induction n as [|n _]. - induction (negnatlthn0 _ I). - assert (t : stnsum m1 + j < stnsum m1 + m (i,,I)). { apply natlthandplusl. exact J. } apply (natlthlehtrans _ _ _ t). assert (K : ∏ m n, m = n -> m ≤ n). { intros a b e. induction e. apply isreflnatleh. } apply K; clear K. rewrite stnsum_step. clear j J t. unfold m1 ; clear m1. apply two_arg_paths. + apply stnsum_eq. intro l. simpl. apply maponpaths. apply subtypePath_prop; simpl. apply pathsinv0, di_eq1, stnlt. + simpl. apply maponpaths. apply subtypePath_prop. simpl. apply idpath. Defined. Local Definition weqstnsum_map { n : nat } (m : ⟦n⟧ -> nat) : (∑ i, ⟦m i⟧) -> ⟦stnsum m⟧. Proof. intros ij. exact (make_stn _ (stnsum (m ∘ stn_left'' (stnlt (pr1 ij))) + pr2 ij) (_c_ ij)). Defined. Local Definition weqstnsum_invmap {n : nat} (m : ⟦n⟧ -> nat) : ⟦stnsum m⟧ -> (∑ i, ⟦m i⟧). Proof. revert m. induction n as [|n IH]. { intros ? l. apply fromempty, negstn0. assumption. } intros ? l. change (⟦ stnsum (m ∘ dni lastelement) + m lastelement ⟧) in l. (* we are careful to use weqfromcoprodofstn_invmap both here and in concatenate' *) assert (ls := weqfromcoprodofstn_invmap _ _ l). induction ls as [j|k]. - exact (total2_base_map (dni lastelement) (IH _ j)). - exact (lastelement,,k). Defined. Definition weqstnsum_invmap_step1 {n : nat} (f : ⟦S n⟧ -> nat) (j : stn (stnsum (λ x, f (dni lastelement x)))) : weqstnsum_invmap f (weqfromcoprodofstn_map (stnsum (λ x, f (dni lastelement x))) (f lastelement) (ii1 j)) = total2_base_map (dni lastelement) (weqstnsum_invmap (f ∘ dni lastelement) j). Proof. intros. unfold weqstnsum_invmap at 1. unfold nat_rect at 1. rewrite weqfromcoprodofstn_eq1. apply idpath. Defined. Definition weqstnsum_invmap_step2 {n : nat} (f : ⟦S n⟧ -> nat) (k : ⟦f lastelement⟧) : weqstnsum_invmap f (weqfromcoprodofstn_map (stnsum (λ x, f (dni lastelement x))) (f lastelement) (ii2 k)) = (lastelement,,k). Proof. intros. unfold weqstnsum_invmap at 1. unfold nat_rect at 1. rewrite weqfromcoprodofstn_eq1. apply idpath. Defined. Lemma partial_sum_prop_aux {n : nat} {m : ⟦n⟧ → nat} : ∏ (i i' : ⟦ n ⟧) (j : ⟦ m i ⟧) (j' : ⟦ m i' ⟧), i < i' → stnsum (m ∘ stn_left'' (stnlt i)) + j < stnsum (m ∘ stn_left'' (stnlt i')) + j'. Proof. intros ? ? ? ? lt. apply natlthtolehsn in lt. pose (ltS := (natlehlthtrans _ _ _ lt (stnlt i'))). refine (natlthlehtrans _ _ _ _ (natlehnplusnm _ _)). apply natlthlehtrans with (stnsum (m ∘ stn_left'' ltS)). - rewrite stnsum_step. assert (stnsum (m ∘ stn_left'' (stnlt i)) = stnsum (m ∘ stn_left'' ltS ∘ dni lastelement)) as e. { apply stnsum_eq. intros k. simpl. apply maponpaths. apply subtypePath_prop. simpl. apply pathsinv0, di_eq1. apply (stnlt k). } induction e. apply natlthandplusl. assert ((m ∘ stn_left'' ltS) lastelement = m i) as e. { simpl. apply maponpaths. apply subtypePath_prop, idpath. } induction e. apply (stnlt j). - assert (stnsum (m ∘ stn_left'' ltS) = stnsum (m ∘ stn_left'' (stnlt i') ∘ stn_left' _ _ lt)) as e. { apply stnsum_eq. intros k. simpl. apply maponpaths. apply subtypePath_prop, idpath. } rewrite e. apply stnsum_left_le'. Defined. Lemma partial_sum_prop {n : nat} {m : ⟦n⟧ → nat} {l : nat} : isaprop (∑ (i : ⟦n⟧ ) (j : ⟦m i⟧ ), stnsum (m ∘ stn_left'' (stnlt i)) + j = l). Proof. intros. apply invproofirrelevance. intros t t'. induction t as [i je]. induction je as [j e]. induction t' as [i' je']. induction je' as [j' e']. pose (e'' := e @ !e'). assert (i = i') as p. { induction (nat_eq_or_neq i i') as [eq | ne]. + apply subtypePath_prop. assumption. + apply fromempty. generalize e''. apply nat_neq_to_nopath. induction (natneqchoice _ _ ne); [apply natgthtoneq | apply natlthtoneq]; apply partial_sum_prop_aux; assumption. } apply total2_paths_f with p. - use total2_paths_f. + induction p. simpl. apply subtypePath_prop. apply (natpluslcan _ _ _ e''). + apply isasetnat. Defined. Lemma partial_sum_slot {n : nat} {m : ⟦n⟧ → nat} {l : nat} : l < stnsum m -> ∃! (i : ⟦n⟧ ) (j : ⟦m i⟧ ), stnsum (m ∘ stn_left'' (stnlt i)) + j = l. Proof. intros lt. set (len := stnsum m). induction n as [|n IH]. { apply fromempty. change (hProptoType(l < 0)) in lt. exact (negnatlthn0 _ lt). } set (m' := m ∘ dni_lastelement). set (len' := stnsum m'). induction (natlthorgeh l len') as [I|J]. - assert (IH' := IH m' I); clear IH. induction IH' as [ijJ Q]. induction ijJ as [i jJ]. induction jJ as [j J]. use tpair. + exists (dni_lastelement i). exists j. abstract (use (_ @ J); apply (maponpaths (λ x, x+j)); apply stnsum_eq; intro r; unfold m'; simpl; apply maponpaths; apply subtypePath_prop, idpath). + intro t. apply partial_sum_prop. - clear IH. set (j := l - len'). apply iscontraprop1. { apply partial_sum_prop. } assert (K := minusplusnmm _ _ J). change (l-len') with j in K. exists lastelement. use tpair. * exists j. apply (natlthandpluslinv _ _ len'). rewrite natpluscomm. induction (!K); clear K J j. assert(C : len = len' + m lastelement). { use (stnsum_step _ @ _). unfold len', m'; clear m' len'. rewrite replace_dni_last. apply idpath. } induction C. exact lt. * simpl. intermediate_path (stnsum m' + j). -- apply (maponpaths (λ x, x+j)). apply stnsum_eq; intro i. unfold m'. simpl. apply maponpaths. apply subtypePath_prop, idpath. -- rewrite natpluscomm. exact K. Defined. Lemma stn_right_first (n i : nat) : stn_right i (S n) firstelement = make_stn (i + S n) i (natltplusS n i). Proof. intros. apply subtypePath_prop. simpl. apply natplusr0. Defined. Lemma nat_rect_step (P : nat → UU) (p0 : P 0) (IH : ∏ n, P n → P (S n)) n : nat_rect P p0 IH (S n) = IH n (nat_rect P p0 IH n). Proof. intros. apply idpath. Defined. Definition weqstnsum1_prelim {n : nat} (f : ⟦n⟧ -> nat) : (∑ i, ⟦f i⟧) ≃ ⟦stnsum f⟧. Proof. revert f. induction n as [ | n' IHn ]. { intros f. apply weqempty. - exact (negstn0 ∘ pr1). - exact negstn0. } intros f. change (⟦stnsum f⟧) with (⟦stnsum (f ∘ dni lastelement) + f lastelement⟧). use (weqcomp _ (weqfromcoprodofstn _ _)). use (weqcomp (weqoverdnicoprod _) _). apply weqcoprodf1. apply IHn. Defined. Lemma weqstnsum1_step {n : nat} (f : ⟦S n⟧ -> nat) : ( weqstnsum1_prelim f = weqfromcoprodofstn (stnsum (funcomp (dni lastelement) f)) (f lastelement) ∘ (weqcoprodf1 (weqstnsum1_prelim (λ i, f (dni lastelement i))) ∘ weqoverdnicoprod (λ i, ⟦ f i ⟧))) % weq. Proof. intros. apply idpath. Defined. Lemma weqstnsum1_prelim_eq { n : nat } (f : ⟦n⟧ -> nat) : weqstnsum1_prelim f ~ weqstnsum_map f. Proof. revert f. induction n as [|n I]. - intros f ij. apply fromempty, negstn0. exact (pr1 ij). - intros f. rewrite weqstnsum1_step. intros ij. rewrite 2 weqcomp_to_funcomp_app. unfold weqcoprodf1. change (pr1weq (weqcoprodf (weqstnsum1_prelim (λ i, f (dni lastelement i))) (idweq (⟦ f lastelement ⟧)))) with (coprodf (weqstnsum1_prelim (λ i, f (dni lastelement i))) (idfun (⟦ f lastelement ⟧))). intermediate_path ((weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) (coprodf (weqstnsum_map (λ i, f (dni lastelement i))) (idfun (⟦ f lastelement ⟧)) ((weqoverdnicoprod (λ i, ⟦ f i ⟧)) ij))). + apply maponpaths. apply homotcoprodfhomot. * apply I. * intro x. apply idpath. + clear I. apply pathsinv0. generalize ij ; clear ij. apply (homotweqinv' (weqstnsum_map f) (weqoverdnicoprod (λ i : ⟦ S n ⟧, ⟦ f i ⟧)) (λ c, pr1weq (weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) (coprodf (weqstnsum_map (λ i, f (dni lastelement i))) (idfun _) c)) ). intros c. simpl. set (P := λ i, ⟦ f i ⟧). change (pr1weq (weqfromcoprodofstn (stnsum (λ x : ⟦ n ⟧, f (dni lastelement x))) (f lastelement))) with (weqfromcoprodofstn_map (stnsum (λ x : ⟦ n ⟧, f (dni lastelement x))) (f lastelement)). induction c as [jk|k]. * unfold coprodf. induction jk as [j k]. change (invmap (weqoverdnicoprod P) (ii1 (j,,k))) with (tpair P (dni lastelement j) k). unfold weqfromcoprodofstn_map. unfold coprod_rect. unfold weqstnsum_map. apply subtypePath_prop. induction k as [k K]. simpl. apply (maponpaths (λ x, x+k)). unfold funcomp, stntonat, di. clear K k. induction (natlthorgeh _ n) as [G|G']. -- simpl. apply stnsum_eq; intro k. apply maponpaths. apply subtypePath_prop. simpl. apply pathsinv0, di_eq1. exact (istransnatlth _ _ _ (stnlt k) G). -- apply fromempty. exact (natlthtonegnatgeh _ _ (stnlt j) G'). * change (invmap (weqoverdnicoprod P) (ii2 k)) with (tpair P lastelement k). simpl. unfold weqstnsum_map. apply subtypePath_prop. induction k as [k K]. simpl. apply (maponpaths (λ x, x+k)). apply maponpaths. apply funextfun; intro i. induction i as [i I]. simpl. apply maponpaths. apply subtypePath_prop. simpl. apply pathsinv0, di_eq1. assumption. Defined. Lemma weqstnsum1_prelim_eq' { n : nat } (f : ⟦n⟧ -> nat) : invweq (weqstnsum1_prelim f) ~ weqstnsum_invmap f. Proof. revert f. induction n as [|n I]. - intros f k. apply fromempty, negstn0. exact k. - intros f. rewrite weqstnsum1_step. intros k. rewrite 2 invweqcomp. rewrite 2 weqcomp_to_funcomp_app. rewrite 3 pr1_invweq. unfold weqcoprodf1. change (invmap (weqcoprodf (weqstnsum1_prelim (λ i, f (dni lastelement i))) (idweq (⟦ f lastelement ⟧)))) with (coprodf (invweq (weqstnsum1_prelim (λ i, f (dni lastelement i)))) (idweq (⟦ f lastelement ⟧))). intermediate_path (invmap (weqoverdnicoprod (λ i : ⟦ S n ⟧, ⟦ f i ⟧)) (coprodf (weqstnsum_invmap (λ i : ⟦ n ⟧, f (dni lastelement i))) (idweq (⟦ f lastelement ⟧)) (invmap (weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) k))). + apply maponpaths. change (invmap _ k) with (invmap (weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) k). generalize (invmap (weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) k). intro c. apply homotcoprodfhomot. * apply I. * apply homotrefl. + clear I. generalize k; clear k. use (homotweqinv (λ c, invmap (weqoverdnicoprod (λ i, ⟦ f i ⟧)) (coprodf (weqstnsum_invmap (λ i, f (dni lastelement i))) (idweq (⟦ f lastelement ⟧)) c)) (weqfromcoprodofstn (stnsum (f ∘ dni lastelement)) (f lastelement)) ). unfold funcomp. intro c. induction c as [r|s]. * unfold coprodf. change (pr1weq (weqfromcoprodofstn (stnsum (λ x, f (dni lastelement x))) (f lastelement))) with (weqfromcoprodofstn_map (stnsum (λ x, f (dni lastelement x))) (f lastelement)). set (P := (λ i : ⟦ S n ⟧, ⟦ f i ⟧)). rewrite weqstnsum_invmap_step1. change (λ i : ⟦ n ⟧, f (dni lastelement i)) with (f ∘ dni lastelement). generalize (weqstnsum_invmap (f ∘ dni lastelement) r); intro ij. induction ij as [i j]. apply idpath. * unfold coprodf. change (pr1weq (idweq _) s) with s. set (P := (λ i : ⟦ S n ⟧, ⟦ f i ⟧)). change (pr1weq _) with (weqfromcoprodofstn_map (stnsum (λ x : ⟦ n ⟧, f (dni lastelement x))) (f lastelement)). rewrite weqstnsum_invmap_step2. apply idpath. Defined. Definition weqstnsum1 {n : nat} (f : ⟦n⟧ -> nat) : (∑ i, ⟦f i⟧) ≃ ⟦stnsum f⟧. Proof. intros. use (remakeweqboth (weqstnsum1_prelim_eq _) (weqstnsum1_prelim_eq' _)). Defined. Lemma weqstnsum1_eq {n : nat} (f : ⟦n⟧ -> nat) : pr1weq (weqstnsum1 f) = weqstnsum_map f. Proof. intros. apply idpath. Defined. Lemma weqstnsum1_eq' {n : nat} (f : ⟦n⟧ -> nat) : invmap (weqstnsum1 f) = weqstnsum_invmap f. Proof. intros. apply idpath. Defined. Theorem weqstnsum { n : nat } (P : ⟦n⟧ -> UU) (f : ⟦n⟧ -> nat) : (∏ i, ⟦f i⟧ ≃ P i) -> total2 P ≃ ⟦stnsum f⟧. Proof. intros w. intermediate_weq (∑ i, ⟦f i⟧). - apply invweq. apply weqfibtototal. assumption. - apply weqstnsum1. Defined. Corollary weqstnsum2 { X : UU } {n : nat} (f : ⟦n⟧ -> nat) (g : X -> ⟦n⟧ ) : (∏ i, ⟦f i⟧ ≃ hfiber g i) -> X ≃ ⟦stnsum f⟧. Proof. intros w. use (weqcomp _ (weqstnsum _ _ w)). apply weqtococonusf. Defined. (** lexical enumeration of pairs of natural numbers *) Definition lexicalEnumeration {n : nat} (m: ⟦n⟧ -> nat) : ⟦stnsum m⟧ ≃ (∑ i : ⟦n⟧, ⟦m i⟧) := invweq (weqstnsum1 m). Definition inverse_lexicalEnumeration {n : nat} (m: ⟦n⟧ -> nat) : (∑ i : ⟦n⟧, ⟦m i⟧) ≃ ⟦stnsum m⟧ := weqstnsum1 m. (** two generalizations of stnsum, potentially useful *) Definition foldleft {E} (e : E) (m : binop E) {n : nat} (x: ⟦n⟧ -> E) : E. Proof. intros. induction n as [|n foldleft]. + exact e. + exact (m (foldleft (x ∘ (dni lastelement))) (x lastelement)). Defined. Definition foldright {E} (m : binop E) (e : E) {n : nat} (x: ⟦n⟧ -> E) : E. Proof. intros. induction n as [|n foldright]. + exact e. + exact (m (x firstelement) (foldright (x ∘ dni firstelement))). Defined. (** *** Weak equivalence between the direct product of [ stn n ] and [ stn m ] and [ stn n * m ] *) Theorem weqfromprodofstn ( n m : nat ) : ⟦n⟧ × ⟦m⟧ ≃ ⟦n*m⟧. Proof. intros. induction ( natgthorleh m 0 ) as [ is | i ]. - assert ( i1 : ∏ i j : nat, i < n -> j < m -> j + i * m < n * m). + intros i j li lj. apply (natlthlehtrans ( j + i * m ) ( ( S i ) * m ) ( n * m )). * change (S i * m) with (i*m + m). rewrite natpluscomm. exact (natgthandplusl m j ( i * m ) lj ). * exact ( natlehandmultr ( S i ) n m ( natgthtogehsn _ _ li ) ). + set ( f := λ ij : ⟦n⟧ × ⟦m⟧, match ij with tpair _ i j => make_stn ( n * m ) ( j + i * m ) ( i1 i j ( pr2 i ) ( pr2 j ) ) end ). split with f. assert ( isinf : isincl f ). * apply isinclbetweensets. apply ( isofhleveldirprod 2 _ _ ( isasetstn n ) ( isasetstn m ) ). apply ( isasetstn ( n * m ) ). intros ij ij' e. destruct ij as [ i j ]. destruct ij' as [ i' j' ]. destruct i as [ i li ]. destruct i' as [ i' li' ]. destruct j as [ j lj ]. destruct j' as [ j' lj' ]. simpl in e. assert ( e' := maponpaths ( stntonat ( n * m ) ) e ). simpl in e'. assert ( eei : i = i' ). { apply ( pr1 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ). } set ( eeis := invmaponpathsincl _ ( isinclstntonat _ ) ( make_stn _ i li ) ( make_stn _ i' li' ) eei ). assert ( eej : j = j' ). { apply ( pr2 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ). } set ( eejs := invmaponpathsincl _ ( isinclstntonat _ ) ( make_stn _ j lj ) ( make_stn _ j' lj' ) eej ). apply ( pathsdirprod eeis eejs ). * intro xnm. apply iscontraprop1. apply ( isinf xnm ). set ( e := pathsinv0 ( natdivremrule xnm m ( natgthtoneq _ _ is ) ) ). set ( i := natdiv xnm m ). set ( j := natrem xnm m ). destruct xnm as [ xnm lxnm ]. set ( li := natlthandmultrinv _ _ _ ( natlehlthtrans _ _ _ ( natlehmultnatdiv xnm m ( natgthtoneq _ _ is ) ) lxnm ) ). set ( lj := lthnatrem xnm m ( natgthtoneq _ _ is ) ). split with ( make_dirprod ( make_stn n i li ) ( make_stn m j lj ) ). simpl. apply ( invmaponpathsincl _ ( isinclstntonat _ ) _ _ ). simpl. apply e. - set ( e := natleh0tois0 i ). rewrite e. rewrite ( natmultn0 n ). split with ( @pr2 _ _ ). apply ( isweqtoempty2 _ ( weqstn0toempty ) ). Defined. (** *** Weak equivalences between decidable subsets of [ stn n ] and [ stn x ] *) Theorem weqfromdecsubsetofstn { n : nat } ( f : ⟦n⟧ -> bool ) : total2 ( λ x : nat, hfiber f true ≃ (⟦x⟧) ). Proof. revert f. induction n as [ | n IHn ]. - intros. split with 0. assert ( g : hfiber f true -> (⟦0⟧) ). { intro hf. destruct hf as [ i e ]. destruct ( weqstn0toempty i ). } apply ( weqtoempty2 g weqstn0toempty ). - intro. set ( g := weqfromcoprodofstn 1 n ). change ( 1 + n ) with ( S n ) in g. set ( fl := λ i : ⟦1⟧, f ( g ( ii1 i ) ) ). set ( fh := λ i : ⟦n⟧, f ( g ( ii2 i ) ) ). assert ( w : ( hfiber f true ) ≃ ( hfiber ( sumofmaps fl fh ) true ) ). { set ( int := invweq ( weqhfibersgwtog g f true ) ). assert ( h : ∏ x : _ , paths ( f ( g x ) ) ( sumofmaps fl fh x ) ). { intro. destruct x as [ x1 | xn ]. + apply idpath. + apply idpath. } apply ( weqcomp int ( weqhfibershomot _ _ h true ) ). } set ( w' := weqcomp w ( invweq ( weqhfibersofsumofmaps fl fh true ) ) ). set ( x0 := pr1 ( IHn fh ) ). set ( w0 := pr2 ( IHn fh ) ). simpl in w0. destruct ( boolchoice ( fl lastelement ) ) as [ i | ni ]. + split with ( S x0 ). assert ( wi : hfiber fl true ≃ ⟦1⟧ ). { assert ( is : iscontr ( hfiber fl true ) ). { apply iscontraprop1. * apply ( isinclfromstn1 fl isasetbool true ). * apply ( make_hfiber _ lastelement i ). } apply ( weqcontrcontr is iscontrstn1 ). } apply ( weqcomp ( weqcomp w' ( weqcoprodf wi w0 ) ) ( weqfromcoprodofstn 1 _ ) ). + split with x0. assert ( g' : ¬ ( hfiber fl true ) ). { intro hf. destruct hf as [ j e ]. assert ( ee : j = lastelement ). { apply proofirrelevancecontr, iscontrstn1. } destruct ( nopathstruetofalse ( pathscomp0 ( pathscomp0 ( pathsinv0 e ) ( maponpaths fl ee ) ) ni ) ). } apply ( weqcomp w' ( weqcomp ( invweq ( weqii2withneg _ g' ) ) w0 ) ). Defined. (** *** Weak equivalences between hfibers of functions from [ stn n ] over isolated points and [ stn x ] *) Theorem weqfromhfiberfromstn { n : nat } { X : UU } ( x : X ) ( is : isisolated X x ) ( f : ⟦n⟧ -> X ) : total2 ( λ x0 : nat, hfiber f x ≃ (⟦x0⟧) ). Proof. intros. set ( t := weqfromdecsubsetofstn ( λ i : _, eqbx X x is ( f i ) ) ). split with ( pr1 t ). apply ( weqcomp ( weqhfibertobhfiber f x is ) ( pr2 t ) ). Defined. (** *** Weak equivalence between [ stn n -> stn m ] and [ stn ( natpower m n ) ] ( uses functional extensionality ) *) Theorem weqfromfunstntostn ( n m : nat ) : (⟦n⟧ -> ⟦m⟧) ≃ ⟦natpower m n⟧. Proof. revert m. induction n as [ | n IHn ]. - intro m. apply weqcontrcontr. + apply ( iscontrfunfromempty2 _ weqstn0toempty ). + apply iscontrstn1. - intro m. set ( w1 := weqfromcoprodofstn 1 n ). assert ( w2 : ( ⟦S n⟧ -> ⟦m⟧ ) ≃ ( (⟦1⟧ ⨿ ⟦n⟧) -> ⟦m⟧ ) ) by apply ( weqbfun _ w1 ). set ( w3 := weqcomp w2 ( weqfunfromcoprodtoprod (⟦1⟧) (⟦n⟧) (⟦m⟧) ) ). set ( w4 := weqcomp w3 ( weqdirprodf ( weqfunfromcontr (⟦m⟧) iscontrstn1 ) ( IHn m ) ) ). apply ( weqcomp w4 ( weqfromprodofstn m ( natpower m n ) ) ). Defined. (** *** Weak equivalence from the space of functions of a family [ stn ( f x ) ] over [ stn n ] to [ stn ( stnprod n f ) ] ( uses functional extensionality ) *) Definition stnprod { n : nat } ( f : ⟦n⟧ -> nat ) : nat. Proof. revert f. induction n as [ | n IHn ]. - intro. apply 1. - intro f. apply ( ( IHn ( λ i : ⟦n⟧, f ( dni lastelement i ) ) ) * f lastelement ). Defined. Definition stnprod_step { n : nat } ( f : ⟦S n⟧ -> nat ) : stnprod f = stnprod (f ∘ dni lastelement) * f lastelement. Proof. intros. apply idpath. Defined. Lemma stnprod_eq {n : nat} (f g: ⟦n⟧ -> nat) : f ~ g -> stnprod f = stnprod g. Proof. intros h. induction n as [|n IH]. { apply idpath. } rewrite 2? stnprod_step. induction (h lastelement). apply (maponpaths (λ i, i * f lastelement)). apply IH. intro x. apply h. Defined. Theorem weqstnprod { n : nat } ( P : ⟦n⟧ -> UU ) ( f : ⟦n⟧ -> nat ) ( ww : ∏ i : ⟦n⟧ , ( stn ( f i ) ) ≃ ( P i ) ) : ( ∏ x : ⟦n⟧ , P x ) ≃ stn ( stnprod f ). Proof. revert P f ww. induction n as [ | n IHn ]. - intros. simpl. apply ( weqcontrcontr ). + apply ( iscontrsecoverempty2 _ ( negstn0 ) ). + apply iscontrstn1. - intros. set ( w1 := weqdnicoprod n lastelement ). assert ( w2 := weqonsecbase P w1 ). assert ( w3 := weqsecovercoprodtoprod ( λ x : _, P ( w1 x ) ) ). assert ( w4 := weqcomp w2 w3 ) ; clear w2 w3. assert ( w5 := IHn ( λ x : ⟦n⟧, P ( w1 ( ii1 x ) ) ) ( λ x : ⟦n⟧, f ( w1 ( ii1 x ) ) ) ( λ i : ⟦n⟧, ww ( w1 ( ii1 i ) ) ) ). assert ( w6 := weqcomp w4 ( weqdirprodf w5 ( weqsecoverunit _ ) ) ) ; clear w4 w5. simpl in w6. assert ( w7 := weqcomp w6 ( weqdirprodf ( idweq _ ) ( invweq ( ww lastelement ) ) ) ). refine ( _ ∘ w7 )%weq. unfold w1. exact (weqfromprodofstn _ _ ). Defined. (** *** Weak equivalence between [ ( stn n ) ≃ ( stn n ) ] and [ stn ( factorial n ) ] ( uses functional extensionality ) *) Theorem weqweqstnsn ( n : nat ) : (⟦S n⟧ ≃ ⟦S n⟧) ≃ ⟦S n⟧ × ( ⟦n⟧ ≃ ⟦n⟧ ). Proof. assert ( l := @lastelement n ). intermediate_weq ( isolated (⟦S n⟧) × (compl _ l ≃ compl _ l) ). { apply weqcutonweq. intro i. apply isdeceqstn. } apply weqdirprodf. - apply weqisolatedstntostn. - apply weqweq. apply invweq. intermediate_weq (compl_ne (⟦S n⟧) l (stnneq l)). + apply weqdnicompl. + apply compl_weq_compl_ne. Defined. Theorem weqfromweqstntostn ( n : nat ) : ( (⟦n⟧) ≃ (⟦n⟧) ) ≃ ⟦factorial n⟧. Proof. induction n as [ | n IHn ]. - simpl. apply ( weqcontrcontr ). + apply ( iscontraprop1 ). * apply ( isapropweqtoempty2 _ ( negstn0 ) ). * apply idweq. + apply iscontrstn1. - change ( factorial ( S n ) ) with ( ( S n ) * ( factorial n ) ). set ( w1 := weqweqstnsn n ). apply ( weqcomp w1 ( weqcomp ( weqdirprodf ( idweq _ ) IHn ) ( weqfromprodofstn _ _ ) ) ). Defined. (* End of " weak equivalences between standard finite sets and constructions on these sets ". *) (** ** Standard finite sets satisfy weak axiom of choice *) Theorem ischoicebasestn ( n : nat ) : ischoicebase (⟦n⟧). Proof. induction n as [ | n IHn ]. - apply ( ischoicebaseempty2 negstn0 ). - apply ( ischoicebaseweqf ( weqdnicoprod n lastelement ) ( ischoicebasecoprod IHn ischoicebaseunit ) ). Defined. (** ** Weak equivalence class of [ stn n ] determines [ n ]. *) Lemma negweqstnsn0 (n : nat) : ¬ (⟦S n⟧ ≃ stn O). Proof. unfold neg. assert (lp: ⟦S n⟧) by apply lastelement. intro X. apply weqstn0toempty. apply (pr1 X lp). Defined. Lemma negweqstn0sn (n : nat) : ¬ (stn O ≃ ⟦S n⟧). Proof. unfold neg. assert (lp: ⟦S n⟧) by apply lastelement. intro X. apply weqstn0toempty. apply (pr1 ( invweq X ) lp). Defined. Lemma weqcutforstn ( n n' : nat ) : ⟦S n⟧ ≃ ⟦S n'⟧ -> ⟦n⟧ ≃ ⟦n'⟧. Proof. intros w. assert ( k := @lastelement n ). intermediate_weq (stn_compl k). - apply weqdnicompl. - intermediate_weq (stn_compl (w k)). + apply weqoncompl_ne. + apply invweq, weqdnicompl. Defined. Theorem weqtoeqstn { n n' : nat } : ⟦n⟧ ≃ ⟦n'⟧ -> n = n'. Proof. revert n'. induction n as [ | n IHn ]. - intro. destruct n' as [ | n' ]. + intros; apply idpath. + intro X. apply (fromempty (negweqstn0sn _ X)). - intro n'. destruct n' as [ | n' ]. + intro X. apply (fromempty ( negweqstnsn0 n X)). + intro X. apply maponpaths. apply IHn. apply weqcutforstn. assumption. Defined. Corollary stnsdnegweqtoeq ( n n' : nat ) ( dw : dneg (⟦n⟧ ≃ ⟦n'⟧) ) : n = n'. Proof. apply (eqfromdnegeq nat isdeceqnat _ _ (dnegf (@weqtoeqstn n n') dw)). Defined. (** ** Some results on bounded quantification *) Lemma weqforallnatlehn0 ( F : nat -> hProp ) : ( ∏ n : nat , natleh n 0 -> F n ) ≃ ( F 0 ). Proof. intros. assert ( lg : ( ∏ n : nat , natleh n 0 -> F n ) <-> ( F 0 ) ). { split. - intro f. apply ( f 0 ( isreflnatleh 0 ) ). - intros f0 n l. set ( e := natleh0tois0 l ). rewrite e. apply f0. } assert ( is1 : isaprop ( ∏ n : nat , natleh n 0 -> F n ) ). { apply impred. intro n. apply impred. intro l. apply ( pr2 ( F n ) ). } apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 ( pr2 ( F 0 ) ) ). Defined. Lemma weqforallnatlehnsn' ( n' : nat ) ( F : nat -> hProp ) : ( ∏ n : nat , natleh n ( S n' ) -> F n ) ≃ ( ∏ n : nat , natleh n n' -> F n ) × ( F ( S n' ) ). Proof. intros. assert ( lg : ( ∏ n : nat , natleh n ( S n' ) -> F n ) <-> ( ∏ n : nat , natleh n n' -> F n ) × ( F ( S n' ) ) ). { split. - intro f. apply ( make_dirprod ( λ n, λ l, ( f n ( natlehtolehs _ _ l ) ) ) ( f ( S n' ) ( isreflnatleh _ ) ) ). - intro d2. intro n. intro l. destruct ( natlehchoice2 _ _ l ) as [ h | e ]. + simpl in h. apply ( pr1 d2 n h ). + destruct d2 as [ f2 d2 ]. rewrite e. apply d2. } assert ( is1 : isaprop ( ∏ n : nat , natleh n ( S n' ) -> F n ) ). { apply impred. intro n. apply impred. intro l. apply ( pr2 ( F n ) ). } assert ( is2 : isaprop ( ( ∏ n : nat , natleh n n' -> F n ) × ( F ( S n' ) ) ) ). { apply isapropdirprod. - apply impred. intro n. apply impred. intro l. apply ( pr2 ( F n ) ). - apply ( pr2 ( F ( S n' ) ) ). } apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 is2 ). Defined. Lemma weqexistsnatlehn0 ( P : nat -> hProp ) : ( hexists ( λ n : nat, ( natleh n 0 ) × ( P n ) ) ) ≃ P 0. Proof. assert ( lg : hexists ( λ n : nat, ( natleh n 0 ) × ( P n ) ) <-> P 0 ). { split. - simpl. apply ( @hinhuniv _ ( P 0 ) ). intro t2. destruct t2 as [ n d2 ]. destruct d2 as [ l p ]. set ( e := natleh0tois0 l ). clearbody e. destruct e. apply p. - intro p. apply hinhpr. split with 0. split with ( isreflnatleh 0 ). apply p. } apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ). Defined. Lemma weqexistsnatlehnsn' ( n' : nat ) ( P : nat -> hProp ) : ( hexists ( λ n : nat, ( natleh n ( S n' ) ) × ( P n ) ) ) ≃ hdisj ( hexists ( λ n : nat, ( natleh n n' ) × ( P n ) ) ) ( P ( S n' ) ). Proof. intros. assert ( lg : hexists ( λ n : nat, ( natleh n ( S n' ) ) × ( P n ) ) <-> hdisj ( hexists ( λ n : nat, ( natleh n n' ) × ( P n ) ) ) ( P ( S n' ) ) ). { split. - apply hinhfun. intro t2. destruct t2 as [ n d2 ]. destruct d2 as [ l p ]. destruct ( natlehchoice2 _ _ l ) as [ h | nh ]. + simpl in h. apply ii1. apply hinhpr. split with n. apply ( make_dirprod h p ). + destruct nh. apply ( ii2 p ). - simpl. apply ( @hinhuniv _ ( ishinh _ ) ). intro c. destruct c as [ t | p ]. + generalize t. simpl. apply hinhfun. clear t. intro t. destruct t as [ n d2 ]. destruct d2 as [ l p ]. split with n. split with ( natlehtolehs _ _ l ). apply p. + apply hinhpr. split with ( S n' ). split with ( isreflnatleh _ ). apply p. } apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ). Defined. Lemma isdecbexists ( n : nat ) ( P : nat -> UU ) ( is : ∏ n' , isdecprop ( P n' ) ) : isdecprop ( hexists ( λ n', ( natleh n' n ) × ( P n' ) ) ). Proof. intros. set ( P' := λ n' : nat, make_hProp _ ( is n' ) ). induction n as [ | n IHn ]. - apply ( isdecpropweqb ( weqexistsnatlehn0 P' ) ). apply ( is 0 ). - apply ( isdecpropweqb ( weqexistsnatlehnsn' _ P' ) ). apply isdecprophdisj. + apply IHn. + apply ( is ( S n ) ). Defined. Lemma isdecbforall ( n : nat ) ( P : nat -> UU ) ( is : ∏ n' , isdecprop ( P n' ) ) : isdecprop ( ∏ n' , natleh n' n -> P n' ). Proof. intros. set ( P' := λ n' : nat, make_hProp _ ( is n' ) ). induction n as [ | n IHn ]. - apply ( isdecpropweqb ( weqforallnatlehn0 P' ) ). apply ( is 0 ). - apply ( isdecpropweqb ( weqforallnatlehnsn' _ P' ) ). apply isdecpropdirprod. + apply IHn. + apply ( is ( S n ) ). Defined. (** The following lemma finds the largest [ n' ] such that [ neg ( P n' ) ]. It is a stronger form of ( neg ∏ ) -> ( exists neg ) in the case of bounded quantification of decidable propositions. *) Lemma negbforalldectototal2neg ( n : nat ) ( P : nat -> UU ) ( is : ∏ n' : nat , isdecprop ( P n' ) ) : ¬ ( ∏ n' : nat , natleh n' n -> P n' ) -> total2 ( λ n', ( natleh n' n ) × ¬ ( P n' ) ). Proof. set ( P' := λ n' : nat, make_hProp _ ( is n' ) ). induction n as [ | n IHn ]. - intro nf. set ( nf0 := negf ( invweq ( weqforallnatlehn0 P' ) ) nf ). split with 0. apply ( make_dirprod ( isreflnatleh 0 ) nf0 ). - intro nf. set ( nf2 := negf ( invweq ( weqforallnatlehnsn' n P' ) ) nf ). set ( nf3 := fromneganddecy ( is ( S n ) ) nf2 ). destruct nf3 as [ f1 | f2 ]. + set ( int := IHn f1 ). destruct int as [ n' d2 ]. destruct d2 as [ l np ]. split with n'. split with ( natlehtolehs _ _ l ). apply np. + split with ( S n ). split with ( isreflnatleh _ ). apply f2. Defined. (** ** Accessibility - the least element of an inhabited decidable subset of [nat] *) Definition natdecleast ( F : nat -> UU ) ( is : ∏ n , isdecprop ( F n ) ) := total2 ( λ n : nat, ( F n ) × ( ∏ n' : nat , F n' -> natleh n n' ) ). Lemma isapropnatdecleast ( F : nat -> UU ) ( is : ∏ n , isdecprop ( F n ) ) : isaprop ( natdecleast F is ). Proof. intros. set ( P := λ n' : nat, make_hProp _ ( is n' ) ). assert ( int1 : ∏ n : nat, isaprop ( ( F n ) × ( ∏ n' : nat , F n' -> natleh n n' ) ) ). { intro n. apply isapropdirprod. - apply ( pr2 ( P n ) ). - apply impred. intro t. apply impred. intro. apply ( pr2 ( natleh n t ) ). } set ( int2 := ( λ n : nat, make_hProp _ ( int1 n ) ) : nat -> hProp ). change ( isaprop ( total2 int2 ) ). apply isapropsubtype. intros x1 x2. intros c1 c2. simpl in *. destruct c1 as [ e1 c1 ]. destruct c2 as [ e2 c2 ]. set ( l1 := c1 x2 e2 ). set ( l2 := c2 x1 e1 ). apply ( isantisymmnatleh _ _ l1 l2 ). Defined. Theorem accth ( F : nat -> UU ) ( is : ∏ n , isdecprop ( F n ) ) ( is' : hexists F ) : natdecleast F is. Proof. revert is'. simpl. apply (@hinhuniv _ ( make_hProp _ ( isapropnatdecleast F is ) ) ). intro t2. destruct t2 as [ n l ]. simpl. set ( F' := λ n' : nat, hexists ( λ n'', ( natleh n'' n' ) × ( F n'' ) ) ). assert ( X : ∏ n' , F' n' -> natdecleast F is ). { intro n'. induction n' as [ | n' IHn' ]. - apply ( @hinhuniv _ ( make_hProp _ ( isapropnatdecleast F is ) ) ). intro t2. destruct t2 as [ n'' is'' ]. destruct is'' as [ l'' d'' ]. split with 0. split. + set ( e := natleh0tois0 l'' ). clearbody e. destruct e. apply d''. + apply ( λ n', λ f : _, natleh0n n' ). - apply ( @hinhuniv _ ( make_hProp _ ( isapropnatdecleast F is ) ) ). intro t2. destruct t2 as [ n'' is'' ]. set ( j := natlehchoice2 _ _ ( pr1 is'' ) ). destruct j as [ jl | je ]. + simpl. apply ( IHn' ( hinhpr ( tpair _ n'' ( make_dirprod jl ( pr2 is'' ) ) ) ) ). + simpl. rewrite je in is''. destruct is'' as [ nn is'' ]. clear nn. clear je. clear n''. assert ( is' : isdecprop ( F' n' ) ) by apply ( isdecbexists n' F is ). destruct ( pr1 is' ) as [ f | nf ]. * apply ( IHn' f ). * split with ( S n' ). split with is''. intros n0 fn0. destruct ( natlthorgeh n0 ( S n' ) ) as [ l' | g' ]. -- set ( i' := natlthtolehsn _ _ l' ). destruct ( nf ( hinhpr ( tpair _ n0 ( make_dirprod i' fn0 ) ) ) ). -- apply g'. } apply ( X n ( hinhpr ( tpair _ n ( make_dirprod ( isreflnatleh n ) l ) ) ) ). Defined. Corollary dni_lastelement_is_inj {n : nat} {i j : ⟦n⟧ } (e : dni_lastelement i = dni_lastelement j) : i = j. Proof. apply isinjstntonat. unfold dni_lastelement in e. apply (maponpaths pr1) in e. exact e. Defined. Corollary dni_lastelement_eq : ∏ (n : nat) (i : ⟦S n⟧ ) (ie : pr1 i < n), i = dni_lastelement (make_stn n (pr1 i) ie). Proof. intros n i ie. apply isinjstntonat. apply idpath. Defined. Corollary lastelement_eq : ∏ (n : nat) (i : ⟦S n⟧ ) (e : pr1 i = n), i = lastelement. Proof. intros n i e. unfold lastelement. apply isinjstntonat. apply e. Defined. (* a tactic for proving things by induction over a finite number of cases *) Ltac inductive_reflexivity i b := (* Here i is a variable natural number and b is a bound on *) (* i of the form i X) (g : ⟦n⟧ -> X) : ⟦m+n⟧ -> X. Proof. intros i. (* we are careful to use weqfromcoprodofstn_invmap both here and in weqstnsum_invmap *) induction (weqfromcoprodofstn_invmap _ _ i) as [j | k]. + exact (f j). + exact (g k). Defined. Definition concatenate'_r0 {X:UU} {m:nat} (f : ⟦m⟧ -> X) (g : ⟦0⟧ -> X) : concatenate' f g = transportb (λ n, ⟦n⟧ -> X) (natplusr0 m) f. Proof. intros. apply funextfun; intro i. unfold concatenate'. rewrite weqfromcoprodofstn_invmap_r0; simpl. clear g. apply transportb_fun'. Defined. Definition concatenate'_r0' {X:UU} {m:nat} (f : ⟦m⟧ -> X) (g : ⟦0⟧ -> X) (i : ⟦m+0⟧ ) : concatenate' f g i = f (transportf stn (natplusr0 m) i). Proof. intros. unfold concatenate'. rewrite weqfromcoprodofstn_invmap_r0. apply idpath. Defined. Definition flatten' {X:UU} {n:nat} {m: ⟦n⟧ -> nat} : (∏ (i: ⟦n⟧ ), ⟦m i⟧ -> X) -> ( ⟦stnsum m⟧ -> X). Proof. intros g. exact (uncurry g ∘ invmap (weqstnsum1 m)). Defined. Definition stn_predicate {n : nat} (P : ⟦n⟧ -> UU) (k : nat) (h h' : k < n) : P (k,,h) -> P (k,,h'). Proof. intros H. transparent assert (X : (h = h')). - apply propproperty. - exact (transportf (λ x, P (k,,x)) X H). Defined. Definition two := ⟦2⟧. Definition two_rec {A : UU} (a b : A) : ⟦2⟧ -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction (nopathsfalsetotrue p). Defined. Definition two_rec_dep (P : two -> UU): P (● 0) -> P (● 1) -> ∏ n, P n. Proof. intros a b n. induction n as [n p]. induction n as [|n _]. eapply stn_predicate. apply a. induction n as [|n _]. eapply stn_predicate. apply b. induction (nopathsfalsetotrue p). Defined. Definition three := stn 3. Definition three_rec {A : UU} (a b c : A) : stn 3 -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction (nopathsfalsetotrue p). Defined. Definition three_rec_dep (P : three -> UU): P (● 0) -> P (● 1) -> P (● 2) -> ∏ n, P n. Proof. intros a b c n. induction n as [n p]. induction n as [|n _]. eapply stn_predicate. apply a. induction n as [|n _]. eapply stn_predicate. apply b. induction n as [|n _]. eapply stn_predicate. apply c. induction (nopathsfalsetotrue p). Defined. (** ordered bijections are unique *) Definition is_stn_increasing {m : nat} (f : ⟦m⟧ → nat) := ∏ (i j: ⟦m⟧ ), i ≤ j → f i ≤ f j. Definition is_stn_strictly_increasing {m : nat} (f : ⟦m⟧ → nat) := ∏ (i j: ⟦m⟧ ), i < j → f i < f j. Lemma is_strincr_impl_incr {m : nat} (f : ⟦m⟧ → nat) : is_stn_strictly_increasing f -> is_stn_increasing f. Proof. intros inc ? ? e. induction (natlehchoice _ _ e) as [I|J]; clear e. + apply natlthtoleh. apply inc. exact I. + assert (J' : i = j). { apply subtypePath_prop. exact J. } clear J. induction J'. apply isreflnatleh. Defined. Lemma is_incr_impl_strincr {m : nat} (f : ⟦m⟧ → nat) : isincl f -> is_stn_increasing f -> is_stn_strictly_increasing f. Proof. intros incl incr i j e. assert (d : i ≤ j). { apply natlthtoleh. assumption. } assert (c := incr _ _ d); clear d. assert (b : i != j). { intro p. induction p. exact (isirreflnatlth _ e). } induction (natlehchoice _ _ c) as [T|U]. - exact T. - apply fromempty. unfold isincl,isofhlevel,isofhlevelf in incl. assert (V := invmaponpathsincl f incl i j U). induction V. exact (isirreflnatlth _ e). Defined. Lemma stnsum_ge1 {m : nat} (f : ⟦m⟧ → nat) : ( ∏ i, f i ≥ 1 ) → stnsum f ≥ m. Proof. intros G. set (g := λ i:⟦m⟧, 1). assert (E : stnsum g = m). { apply stnsum_1. } assert (F : stnsum g ≤ stnsum f). { apply stnsum_le. exact G. } generalize E F; generalize (stnsum g); clear E F g; intros s e i. induction e. exact i. Defined. Lemma stnsum_add {m : nat} (f g : ⟦m⟧ → nat) : stnsum (λ i, f i + g i) = stnsum f + stnsum g. Proof. intros. induction m as [|m I]. - apply idpath. - rewrite 3 stnsum_step. change ((λ i : ⟦ S m ⟧, f i + g i) ∘ dni lastelement) with (λ y : ⟦ m ⟧, f (dni lastelement y) + g (dni lastelement y)). rewrite I. rewrite natplusassoc. rewrite natplusassoc. simpl. apply maponpaths. rewrite natpluscomm. rewrite natplusassoc. apply maponpaths. rewrite natpluscomm. apply idpath. Defined. Lemma stnsum_lt {m : nat} (f g : ⟦m⟧ → nat) : ( ∏ i, f i < g i ) → stnsum g ≥ stnsum f + m. Proof. intros. set (h := λ i, f i + 1). assert (E : stnsum h = stnsum f + m). { unfold h; clear h. rewrite stnsum_add. rewrite stnsum_1. apply idpath. } rewrite <- E. apply stnsum_le. intros i. unfold h. apply natlthtolehp1. apply X. Defined. Local Arguments dni {_} _ _. Lemma stnsum_diffs {m : nat} (f : ⟦S m⟧ → nat) : is_stn_increasing f -> stnsum (λ i, f (dni_firstelement i) - f (dni_lastelement i)) = f lastelement - f firstelement. Proof. intros e. induction m as [|m I]. - change (0 = f firstelement - f firstelement). apply pathsinv0. apply minuseq0'. - rewrite stnsum_step. change (f (dni_firstelement lastelement)) with (f lastelement). rewrite natpluscomm. use (_ @ ! @natdiffplusdiff (f lastelement) (f (dni_lastelement lastelement)) (f firstelement) _ _). + apply maponpaths. use (_ @ I (f ∘ dni_lastelement) _ @ _). * simpl. apply stnsum_eq; intros i. rewrite replace_dni_last. apply idpath. * intros i j s. unfold funcomp. apply e. apply s. * apply idpath. + apply e. apply lastelement_ge. + apply e. apply firstelement_le. Defined. Lemma stn_ord_incl {m : nat} (f : ⟦S m⟧ → nat) : is_stn_strictly_increasing f → f lastelement ≥ f firstelement + m. Proof. intros strinc. assert (inc := is_strincr_impl_incr _ strinc). set (d := λ i : ⟦ m ⟧, f (dni_firstelement i) - f (dni_lastelement i)). assert (E := stnsum_diffs f inc). change (stnsum d = f lastelement - f firstelement) in E. assert (F : ∏ i, f (dni_firstelement i) > f (dni_lastelement i)). { intros i. apply strinc. change (stntonat _ i < S(stntonat _ i)). apply natlthnsn. } assert (G : ∏ i, d i ≥ 1). { intros i. apply natgthtogehsn. apply minusgth0. apply F. } clear F. assert (H := stnsum_ge1 _ G). clear G. rewrite E in H. clear E d. assert (I : f lastelement ≥ f firstelement). { apply inc. apply idpath. } assert (J := minusplusnmm _ _ I); clear I. rewrite <- J; clear J. rewrite natpluscomm. apply natgehandplusl. exact H. Defined. Lemma stn_ord_inj {n : nat} (f : incl (⟦n⟧) (⟦n⟧)) : (∏ (i j: ⟦n⟧ ), i ≤ j → f i ≤ f j) -> ∏ i, f i = i. Proof. intros inc ?. induction n as [|n I]. - apply fromempty. apply negstn0. assumption. - assert (strincr : is_stn_strictly_increasing (pr1incl _ _ f)). { apply is_incr_impl_strincr. { use (isinclcomp f (stntonat_incl _)). } { exact inc. } } assert (M : stntonat _ (f lastelement) = n). { apply isantisymmnatgeh. * assert (N : f lastelement ≥ f firstelement + n). { exact (stn_ord_incl (pr1incl _ _ f) strincr). } use (istransnatgeh _ _ _ N). apply natgehplusnmm. * exact (stnlt (f lastelement)). } assert (L : ∏ j, f (dni lastelement j) < n). { intros. induction M. apply strincr. apply dni_last_lt. } (* set (f' := λ j : ⟦n⟧, make_stn n (stntonat _ (f (dni_lastelement j))) (L j)). *) pose (f'' := inclcomp (inclcomp (make_incl _ (isincldni n lastelement)) f) (make_incl _ (isinclstntonat _))). pose (f' := λ j : ⟦n⟧, make_stn n (f'' j) (L j)). assert (J : isincl f'). { unfold f'. intros x j j'. apply iscontraprop1. * apply isaset_hfiber; apply isasetstn. * use subtypePath. ** intro. apply isasetstn. ** induction j as [j e]. induction j' as [j' e']. simpl. apply (invmaponpathsincl f'' (pr2 f'')). apply (base_paths _ _ (e @ !e')). } assert (F : ∏ j : ⟦n⟧, f' j = j). { apply (I (make_incl _ J)). intros j j' lt. apply inc. change (pr1 (dni lastelement j) ≤ pr1 (dni lastelement j')). rewrite 2?dni_last. assumption. } apply subtypePath_prop. change (stntonat _ (f i) = i). induction (natgehchoice _ _ (lastelement_ge i)) as [ge | eq]. + pose (p := maponpaths (stntonat _) (F (make_stn n i ge))). simpl in p. induction p. change (stntonat _ (f i) = f (dni lastelement (make_stn n i ge))). apply maponpaths, maponpaths, pathsinv0. apply subtypePath_prop. apply dni_last. + apply subtypePath_prop in eq. rewrite <- eq. apply M. Defined. Lemma stn_ord_bij {n : nat} (f : ⟦ n ⟧ ≃ ⟦ n ⟧) : (∏ (i j: ⟦n⟧ ), i ≤ j → f i ≤ f j) -> ∏ i, f i = i. Proof. apply (stn_ord_inj (weqtoincl f)). Defined. UniMath-20231010/UniMath/Combinatorics/Tests.v000066400000000000000000000454551451125700300207560ustar00rootroot00000000000000Require Import UniMath.Foundations.Preamble. Require UniMath.Combinatorics.Lists. Require UniMath.Combinatorics.StandardFiniteSets. Require UniMath.Combinatorics.FiniteSets. Require UniMath.Combinatorics.FiniteSequences. Require UniMath.Combinatorics.FiniteSets. Require UniMath.Combinatorics.OrderedSets. Require UniMath.Combinatorics.StandardFiniteSets. Require UniMath.Combinatorics.BoundedSearch. Require UniMath.MoreFoundations.DecidablePropositions. Require UniMath.MoreFoundations.NegativePropositions. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.MoreFoundations.NegativePropositions. Require Import UniMath.Combinatorics.Lists. Section Test_list. Local Notation "[]" := nil (at level 0, format "[]"). Local Infix "::" := cons. Local Goal concatenate (1::2::[]) (3::4::5::[]) = (1::2::3::4::5::[]). reflexivity. Defined. Goal flatten ((1::2::[])::(3::4::5::[])::(6::[])::[]) = (1::2::3::4::5::6::[]). reflexivity. Defined. End Test_list. Section Test_stn. Local Open Scope stn. Goal stn 6. exact (stnel(6,3)). Qed. Goal stn 6. exact (stnpr 3). Qed. Goal (stnel(6,3) ≠ stnel(6,4)). exact tt. Defined. Goal ¬(stnel(6,3) ≠ stnel(6,3)). intro n. apply n. Defined. Goal ∏ m n (i:m≤n) (j:stn m), pr1 (stnmtostnn m n i j) = pr1 j. intros. induction j as [j J]. reflexivity. Defined. Goal @sni 6 (●3) (@dni 6 (●3) (●2)) = ●2. reflexivity. Defined. Goal @sni 6 (●3) (@dni 6 (●3) (●3)) = ●3. reflexivity. Defined. Goal @sni 6 (●3) (@dni 6 (●3) (●4)) = ●4. reflexivity. Defined. Goal @sni 6 (●3) (●2) = ●2. reflexivity. Defined. Goal @sni 6 (●3) (●3) = ●3. reflexivity. Defined. Goal @sni 6 (●3) (●4) = ●3. reflexivity. Defined. Goal @sni 6 (●3) (●5) = ●4. reflexivity. Defined. Section Test_weqdnicompl. Let n := 5. Let X := stn n. Let i := ●3 : stn (S n). Let Y := @stn_compl (S n) i. Let v := weqdnicompl i : X ≃ Y. Let j := ●4 : X. Let jni := ●5,,tt : Y. Goal v j = jni. reflexivity. Defined. Goal invmap v jni = j. reflexivity. Defined. Goal homotweqinvweq v jni = idpath _. reflexivity. Defined. Goal homotinvweqweq v j = idpath _. reflexivity. (* fixed; 2 seconds *) Defined. (* fixed, 2 seconds *) Goal homotweqinvweqweq v j = idpath _. (* 2 seconds *) reflexivity. (* 2 seconds *) Defined. (* 3 seconds *) End Test_weqdnicompl. Section Test2. Goal weqdnicoprod 4 firstelement (ii1 (●0)) = ●1. reflexivity. Defined. Goal weqdnicoprod 4 firstelement (ii1 (●3)) = ●4. reflexivity. Defined. Goal invmap (weqdnicoprod 4 firstelement) (●1) = (ii1 (●0)). reflexivity. Defined. Goal invmap (weqdnicoprod 4 firstelement) (●4) = (ii1 (●3)). reflexivity. Defined. Goal weqdnicoprod 4 lastelement (ii1 (●3)) = ●3. reflexivity. Defined. Goal weqdnicoprod 4 lastelement (ii2 tt) = ●4. reflexivity. Defined. Goal invmap (weqdnicoprod 4 lastelement) (●1) = (ii1 (●1)). reflexivity. Defined. Goal invmap (weqdnicoprod 4 lastelement) (●4) = (ii2 tt). reflexivity. Defined. Goal homotweqinvweq (weqdnicoprod 4 lastelement) (● 0) = idpath _. reflexivity. Defined. (* fixed! *) Goal homotinvweqweq (weqdnicoprod 4 (●4)) (ii2 tt) = idpath _. reflexivity. Defined. Goal homotinvweqweq (weqdnicoprod 4 (●4)) (ii1 (●1)) = idpath _. reflexivity. (* fixed; 5 seconds *) Defined. (* 5 seconds *) (* here's an example that shows complications need not impede that sort of computability: *) Local Definition w : unit ≃ stn 1. simple refine (weq_iso _ _ _ _). { intro. exact firstelement. } { intro. exact tt. } { intro u. simpl. induction u. reflexivity. } { intro i. simpl. apply subtypePath_prop. simpl. induction i as [i I]. simpl. apply pathsinv0. apply natlth1tois0. exact I. } Defined. Goal w tt = firstelement. reflexivity. Defined. Goal invmap w firstelement = tt. reflexivity. Defined. Goal homotweqinvweq w firstelement = idpath _. reflexivity. Defined. Goal homotinvweqweq w tt = idpath _. reflexivity. Defined. Local Definition w' := invweq w. Goal w' firstelement = tt. reflexivity. Defined. Goal invmap w' tt= firstelement. reflexivity. Defined. Goal homotweqinvweq w' tt = idpath _. reflexivity. Defined. Goal homotinvweqweq w' firstelement = idpath _. reflexivity. Defined. Local Definition ww' := weqcomp w w'. Goal ww' tt = tt. reflexivity. Defined. Goal invmap ww' tt = tt. reflexivity. Defined. Goal homotweqinvweq ww' tt = idpath _. reflexivity. Defined. Goal homotinvweqweq ww' tt = idpath _. reflexivity. Defined. Local Definition w_w := weqcoprodf w w. Goal w_w (ii1 tt) = ii1 firstelement. reflexivity. Defined. Goal invmap w_w (ii2 firstelement) = ii2 tt. reflexivity. Defined. Goal homotweqinvweq w_w (ii2 firstelement) = idpath _. reflexivity. Defined. Goal homotinvweqweq w_w (ii1 tt) = idpath _. reflexivity. Defined. Local Definition i := ●1 : stn 4. Local Definition j := ●0 : stn 4. Lemma ne : ¬ (i = j). Proof. apply stnneq_to_nopath. exact tt. Defined. Local Definition re := weqrecompl (stn 4) i (isisolatedinstn _). Local Definition re' := weqrecompl_ne (stn 4) i (isisolatedinstn i) (stnneq i). Local Definition c := make_compl (stn 4) i j ne : compl _ i. Local Definition c' := make_compl_ne (stn 4) i (stnneq i) j tt : stn_compl i. Goal re (ii2 tt) = i. reflexivity. Defined. Goal re (ii1 c) = j. reflexivity. Defined. Goal invmap re i = (ii2 tt). reflexivity. Defined. Goal invmap re j = (ii1 c). reflexivity. Defined. Goal homotweqinvweq re i = idpath _. reflexivity. Defined. Goal homotweqinvweq re j = idpath _. reflexivity. Defined. Goal homotinvweqweq re (ii2 tt) = idpath _. reflexivity. Defined. Goal homotinvweqweq re (ii1 c) = idpath _. try reflexivity. (* quickly returns due to the use of funextemptyAxiom in the proof of isweqrecompl. *) Abort. Goal re' (ii2 tt) = i. reflexivity. Defined. Goal re' (ii1 c') = j. reflexivity. Defined. Goal invmap re' i = (ii2 tt). reflexivity. Defined. Goal invmap re' j = (ii1 c'). reflexivity. Defined. Goal homotweqinvweq re' i = idpath _. reflexivity. Defined. Goal homotweqinvweq re' j = idpath _. reflexivity. Defined. Goal homotinvweqweq re' (ii2 tt) = idpath _. reflexivity. Defined. Goal homotinvweqweq re' (ii1 c') = idpath _. reflexivity. Defined. (* fixed! *) Goal @weqdnicoprod_map 4 (●2) (ii2 tt) = (●2). reflexivity. Defined. Goal @weqdnicoprod_map 4 (●2) (ii1 (●2)) = (●3). reflexivity. Defined. Goal @weqdnicoprod_map 4 (●2) (ii1 (●1)) = (●1). reflexivity. Defined. Goal @weqdnicoprod_invmap 4 (●2) (●2) = (ii2 tt). reflexivity. Defined. Goal @weqdnicoprod_invmap 4 (●2) (●3) = (ii1 (●2)). reflexivity. Defined. Goal @weqdnicoprod_invmap 4 (●2) (●1) = (ii1 (●1)). reflexivity. Defined. End Test2. (* confirm that [stnsum] is associative in the same way as the parser, which is left associative *) Goal ∏ (f : stn 3 -> nat), stnsum f = f(●0) + f(●1) + f(●2). reflexivity. Defined. Goal ∏ (f : stn 3 -> nat), stnsum f = (f(●0) + f(●1)) + f(●2). reflexivity. Defined. Section Test_weqstnsum. (* this module exports nothing *) Let X := stnset 7. Let Y (x:X) := stnset (pr1 x). Let W := ∑ x, Y x. Let f : W ≃ stn _ := weqstnsum1 _. Let f' : stn _ ≃ W := invweq f. Goal f(●1,,●0) = ●0. reflexivity. Defined. (* fixed! (formerly, it failed quickly) *) Goal f(●2,,●0) = ●1. reflexivity. Defined. Goal f(●2,,●1) = ●2. reflexivity. Defined. Goal f(●3,,●0) = ●3. reflexivity. Defined. Goal f(●3,,●1) = ●4. reflexivity. Defined. Goal f(●3,,●2) = ●5. reflexivity. Defined. Goal f(●4,,●0) = ●6. reflexivity. Defined. Goal f(●5,,●0) = ●10. reflexivity. Defined. Goal f(●6,,●0) = ●15. reflexivity. Defined. Goal (pr2 (pr2 (f'(●0)))) = idpath true. reflexivity. Defined. (* fixed, Coq bug? *) Goal f'(●0) = (●1,,●0). reflexivity. Defined. (* fixed, Coq bug? *) Goal f'(●0) = (●1,,●0). reflexivity. Defined. Goal f'(●1) = (●2,,●0). reflexivity. Defined. Goal f'(●2) = (●2,,●1). reflexivity. Defined. Goal f'(●3) = (●3,,●0). reflexivity. Defined. Goal f'(●4) = (●3,,●1). reflexivity. Defined. Goal f'(●5) = (●3,,●2). reflexivity. Defined. Goal f'(●6) = (●4,,●0). reflexivity. Defined. Goal f'(●10) = (●5,,●0). reflexivity. Defined. Goal f'(●15) = (●6,,●0). reflexivity. Defined. End Test_weqstnsum. Section Test_weqfromprodofstn. (* verify computability in both directions *) (* this module exports nothing *) Let f : stn 5 × stn 4 ≃ stn 20 := weqfromprodofstn 5 4. Goal f(●0,,●0) = ●0. reflexivity. Defined. Goal f(●0,,●1) = ●1. reflexivity. Defined. Goal f(●2,,●0) = ●8. reflexivity. Defined. Goal f(●4,,●3) = ●19. reflexivity. Defined. Let f' := invweq f. Goal f'(●19) = (●4,,●3). reflexivity. Defined. Goal f'(●18) = (●4,,●2). reflexivity. Defined. Goal f'(●14) = (●3,,●2). reflexivity. Defined. End Test_weqfromprodofstn. (* confirm that [stnprod] is associative in the same way as the parser *) Goal ∏ (f : stn 3 -> nat), stnprod f = f(●0) * f(●1) * f(●2). Proof. reflexivity. Defined. Local Definition testfun : stn 3 -> stn 10. Proof. intros n. induction n as [n b]. induction n as [|n]. - exact (2,,idpath _). - induction n as [|n]. + exact (3,,idpath _). + induction n as [|n]. * exact (4,,idpath _). * contradicts (negnatlthn0 n) b. Defined. Goal ∏ n, testfun n < 5. Proof. intros. induction n as [i c]. inductive_reflexivity i c. Defined. End Test_stn. Section Test_fin. Import UniMath.Combinatorics.FiniteSets. (** ** Test computations. *) Goal fincard (isfiniteempty) = 0. reflexivity. Qed. Goal fincard (isfiniteunit) = 1. reflexivity. Qed. Goal fincard (isfinitebool) = 2. reflexivity. Qed. Goal fincard (isfinitecompl true isfinitebool) = 1. reflexivity. Qed. Goal fincard (isfinitedirprod isfinitebool isfinitebool) = 4. reflexivity. Qed. Goal fincard (isfinitedirprod isfinitebool (isfinitedirprod isfinitebool isfinitebool)) = 8. reflexivity. Qed. Goal cardinalityFiniteSet (isfinite_to_FiniteSet (isfinitedirprod isfinitebool (isfinitedirprod isfinitebool isfinitebool))) = 8. reflexivity. Qed. Goal fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))) = 2. reflexivity. Qed. Goal fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))) = 2. reflexivity. Qed. Goal fincard (isfinitecompl (make_dirprod tt tt) (isfinitedirprod isfiniteunit isfiniteunit)) = 0. reflexivity. Qed. Goal fincard (isfinitecompl (make_dirprod true (make_dirprod true false)) (isfinitedirprod (isfinitebool) (isfinitedirprod (isfinitebool) (isfinitebool)))) = 7. reflexivity. Qed. Goal fincard ( isfiniteweq (isfinitedirprod isfinitebool isfinitebool) ) = 24. reflexivity. Qed. (* stack overflow: Goal fincard (isfiniteweq ( isfinitedirprod ( isfinitedirprod isfinitebool isfinitebool ) isfinitebool )) = 40320. reflexivity. Qed. *) (* Eval compute in (carddneg _ (isfinitedirprod _ _ (isfinitestn (S (S (S (S O))))) (isfinitestn (S (S (S O)))))). *) (* Eval lazy in (pr1 (finitestructcomplement _ (make_dirprod _ _ tt tt) (finitestructdirprod _ _ (finitestructunit) (finitestructunit)))). *) Section Test_isfinite_isdeceq. (* This module exports nothing. *) Import UniMath.MoreFoundations.DecidablePropositions. (* The proofs of isfinite_isdeceq and isfinite_isaset depend on funextfun and funextemptyAxiom, so here we do an experiment to see if that impedes computability of equality using it. *) Local Open Scope stn. Let X := stnset 5. Let finX : isfinite X := isfinitestn _. Let eqX := isfinite_to_DecidableEquality finX. Let x := ●3 : X. Let x' := ●4 : X. Let decide P := choice P true false. Goal decide (eqX x x') = false. reflexivity. Defined. Goal decide (eqX x x) = true. reflexivity. Defined. (* test isfinitebool *) Let eqbool := isfinite_to_DecidableEquality isfinitebool : DecidableRelation bool. Goal decide (eqbool true true) = true. reflexivity. Defined. Goal decide (eqbool false true) = false. reflexivity. Defined. (* test isfinitecoprod *) Let C := X ⨿ X. Let eqQ : DecidableRelation C := isfinite_to_DecidableEquality (isfinitecoprod finX finX). Let c := ii1 x : C. Let c' := ii1 x' : C. Let c'' := ii2 x : C. Goal decide (eqQ c c') = false. reflexivity. Defined. Goal decide (eqQ c c) = true. reflexivity. Defined. Goal decide (eqQ c c'') = false. reflexivity. Defined. (* test isfinitedirprod *) Let Y := stnset 4. Let y := ●1 : Y. Let y' := ●2 : Y. Let finY : isfinite Y := isfinitestn _. Let V := X × Y. Let eqV := isfinite_to_DecidableEquality (isfinitedirprod finX finY). Goal decide (eqV (x,,y) (x',,y')) = false. reflexivity. Defined. (* test isfinitetotal2 *) Let Y' (x:X) : hSet := Y. Let W := ∑ x, Y' x. Let eqW : DecidableRelation W := isfinite_to_DecidableEquality (isfinitetotal2 Y' finX (λ _, finY)). Goal decide (eqW (x,,y) (x',,y')) = false. reflexivity. (* fixed *) Defined. (* test isfiniteforall *) Let T := ∏ x, Y' x. Let eqT : DecidableRelation T := isfinite_to_DecidableEquality (isfiniteforall Y' finX (λ _, finY)). Goal decide (eqT (λ _, y) (λ _, y)) = true. reflexivity. (* fixed *) Defined. End Test_isfinite_isdeceq. End Test_fin. Section Test_seq. Import UniMath.Combinatorics.FiniteSequences. Local Open Scope stn. End Test_seq. Section Test_finite_sets. Import UniMath.Combinatorics.FiniteSets. Import UniMath.MoreFoundations.DecidablePropositions. Local Open Scope stn. Goal 3 = fincard_standardSubset (λ i:stn 10, 2*i < 6)%dnat. Proof. reflexivity. Defined. Goal 6 = tallyStandardSubset (λ i:stn 10, 3 ≤ i ∧ i ≤ 8)%dnat%declog. Proof. reflexivity. Defined. Goal 6 = tallyStandardSubsetSegment (λ i:stn 14, 2*i ≠ 4)%dnat (●7). Proof. reflexivity. Defined. End Test_finite_sets. Section Test_ord. Import UniMath.Combinatorics.OrderedSets. Import UniMath.Combinatorics.StandardFiniteSets. Import UniMath.MoreFoundations.DecidablePropositions. Local Open Scope stn. Goal 3 = height ( ●3 : ⟦ 8 ⟧ %foset ). reflexivity. Defined. Section TestLex. (* we want lex order to be computable if R and S both are *) Let X := stnset 5. Let R := λ (x x':X), (pr1 x ≤ pr1 x')%dnat. Let Y := λ x:X, stnset (pr1 x). Let S := λ (x:X) (y y':Y x), (pr1 y ≤ pr1 y')%dnat. Let Z := ∑ x, Y x. Let T := lexicographicOrder X Y R S. Let x2 := ●2 : X. Let x3 := ●3 : X. Goal (choice (R x2 x3) true false = true). reflexivity. Defined. Goal (choice (R x2 x2) true false = true). reflexivity. Defined. Goal (choice (R x3 x2) true false = false). reflexivity. Defined. Let y1 := ●1 : Y x2. Let y2 := ●2 : Y x3. Let t := (x2,,y1) : Z. Let t' := (x3,,y2) : Z. End TestLex. Section TestLex2. Import UniMath.MoreFoundations.DecidablePropositions. Open Scope foset. Let i := ●2 : ⟦ 4 ⟧. Let j := ●3 : ⟦ 4 ⟧. Goal choice (i < j)%foset true false = true. reflexivity. Defined. Goal choice (i ≤ j)%foset true false = true. reflexivity. Defined. Goal choice (i ≐ j)%foset true false = false. reflexivity. Defined. Let X := (∑ i:⟦ 4 ⟧, ⟦ pr1 i ⟧)%foset. Let x := ( ●2 ,, ●1 ):X. Let y := ( ●3 ,, ●1 ):X. Local Lemma d : isdeceq X. Proof. apply isdeceq_total2. - apply isdeceqstn. - intro k. apply isdeceqstn. Defined. Local Definition which {Y} : Y ⨿ ¬Y -> bool. Proof. intros c. induction c. - exact true. - exact false. Defined. (* we want these to work: *) Goal choice (x < y) true false = true. reflexivity. (* fixed *) Defined. Goal choice (x ≤ y)%foset true false = true. reflexivity. Defined. Goal choice (y < x)%foset true false = false. reflexivity. Defined. Goal choice (y ≤ x)%foset true false = false. reflexivity. Defined. Goal choice (x ≐ y)%foset true false = false. reflexivity. Defined. Goal choice (x ≐ x)%foset true false = true. reflexivity. Defined. Goal which (d x y) = false. reflexivity. Defined. Goal which (d x x) = true. reflexivity. Defined. Goal choice (x ≠ y)%foset true false = true. reflexivity. Defined. Goal which (isdeceqnat 2 (height x)) = true. try reflexivity. (* fix *) Abort. Goal 2 = height x. try reflexivity. (* fix *) Abort. End TestLex2. Goal ∏ X (lt:hrel X), iscotrans lt <-> iswklin lt. Proof. intros. unfold iscotrans, iswklin. split. { intros i x1 x3 x2. apply i. } { intros i x z y. apply i. } Defined. Goal (idweq nat ∘ idweq _ ∘ idweq _)%weq 3 = 3. reflexivity. Defined. Goal (idweq nat ∘ invweq (idweq _) ∘ idweq _)%weq 3 = 3. reflexivity. Defined. Goal invmap (idweq nat ∘ idweq _ ∘ idweq _)%weq 3 = 3. reflexivity. Defined. Goal invmap (idweq nat ∘ invweq (idweq _) ∘ idweq _)%weq 3 = 3. reflexivity. Defined. End Test_ord. Section Test_search. Import UniMath.Combinatorics.BoundedSearch. Import UniMath.Foundations.Propositions. Local Definition someseq (n : nat) : bool. Proof. destruct n. - exact false. - destruct n. + exact true. + destruct n. * exact true. * exact false. Defined. Local Definition P : nat → hProp. Proof. intros n. refine (make_hProp (someseq n = true) _). refine (isasetbool _ _). Defined. Local Definition P_dec (n : nat) : P n ⨿ ¬ P n. Proof. unfold P, someseq. destruct n. - apply ii2. exact nopathsfalsetotrue. - destruct n. + apply ii1. apply idpath. + destruct n. * apply ii1, idpath. * apply ii2. exact nopathsfalsetotrue. Defined. Local Definition P_inhab : ∃ n, P n. Proof. apply hinhpr. refine (2%nat,,_). apply idpath. Defined. Goal 1 = pr1 (minimal_n P P_dec P_inhab). reflexivity. Defined. Variable P_inhab' : ∃ n, P n. Local Definition new_n' : ∑ n : nat, P n := minimal_n P P_dec P_inhab'. End Test_search. UniMath-20231010/UniMath/Combinatorics/Vectors.v000066400000000000000000000200251451125700300212630ustar00rootroot00000000000000(** * Vectors as iterated products. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Foundations.NaturalNumbers. Local Open Scope nat. Local Open Scope stn. (** ** Lemmata about standard finite sets. *) Definition stn_extens {n} (i j : ⟦ n ⟧) (p : stntonat _ i = stntonat _ j) : i = j := subtypePath' p (propproperty (j < n)). Definition fromstn0 (i : ⟦ 0 ⟧) {A : UU} : A := fromempty (negnatlthn0 (pr1 i) (pr2 i)). (** ** Vectors. *) Definition vec (A : UU) (n : nat) : UU. Proof. induction n as [|n IHn]. - apply unit. - apply (A × IHn). Defined. (** *** Constructors. *) Definition vnil {A: UU}: vec A 0 := tt. Definition vcons {A: UU} {n} (x : A) (v : vec A n) : vec A (S n) := x,, v. (** *** Notations. *) Declare Scope vec_scope. Delimit Scope vec_scope with vec. Bind Scope vec_scope with vec. Local Open Scope vec_scope. Notation "[()]" := vnil (at level 0, format "[()]"): vec_scope. Infix ":::" := vcons (at level 60, right associativity) : vec_scope. Notation "[( x ; .. ; y )]" := (vcons x .. (vcons y [()]) ..): vec_scope. Section vecs. Context {A : UU}. Definition drop {n} (f : ⟦ S n ⟧ → A) (i : ⟦ n ⟧) : A := f (dni_firstelement i). Definition make_vec {n} (f : ⟦ n ⟧ → A) : vec A n. Proof. induction n as [|m h]. - exact [()]. - exact ((f firstelement) ::: (h (drop f))). Defined. (** *** Projections. *) Definition hd {n} (v : vec A (S n)) : A := pr1 v. Definition tl {n} (v : vec A (S n)) : vec A n := pr2 v. Definition el {n} (v : vec A n) : ⟦ n ⟧ → A. Proof. induction n as [|m f]. - apply (λ i, fromstn0 i). - intro i. induction i as (j,jlt). induction j as [|k _]. + exact (hd v). + exact (f (tl v) (k,, jlt)). Defined. (** *** Some identities for computing [el]. *) Lemma el_make_vec {n} (f : ⟦ n ⟧ → A) : el (make_vec f) ~ f . Proof. intro i. induction n as [|m meq]. - exact (fromstn0 i). - induction i as (j,jlt). induction j as [|k _]. + cbn. apply maponpaths. apply stn_extens. apply idpath. + etrans. { apply meq. } unfold drop. apply maponpaths. apply idpath. Defined. Lemma el_make_vec_fun {n} (f : ⟦ n ⟧ → A) : el (make_vec f) = f. Proof. apply funextfun. apply el_make_vec. Defined. Lemma el_vcons_tl {n} (v : vec A n) (x : A) (i : ⟦ n ⟧) : el (x ::: v) (dni_firstelement i) = el v i. Proof. induction n as [|m meq]. - apply fromstn0. exact i. - cbn. apply maponpaths. apply proofirrelevance; exact (propproperty (pr1 i < S m)). Defined. Lemma el_vcons_hd {n} (v : vec A n) (x : A) : el (x ::: v) (firstelement) = x. Proof. reflexivity. Defined. Lemma drop_el {n} (v : vec A (S n)) (i: ⟦ n ⟧ ) : drop (el v) i = el (tl v) i. Proof. induction v as (x, u). change (drop (el (x ::: u)) i = el u i). apply el_vcons_tl. Defined. Lemma el_tl {n} (v : vec A (S n)) (i : ⟦ n ⟧) : el (tl v) i = drop (el v) i. Proof. rewrite drop_el. reflexivity. Defined. (** *** Extensionality. *) Definition vec0_eq (u v : vec A 0) : u = v := proofirrelevancecontr iscontrunit u v. Definition vecS_eq {n} {u v : vec A (S n)} (p : hd u = hd v) (q : tl u = tl v) : u = v := dirprod_paths p q. Lemma vec_extens {n} {u v : vec A n} : (∏ i : ⟦ n ⟧, el u i = el v i) → u = v. Proof. intros H. induction n as [|m meq]. - apply vec0_eq. - apply vecS_eq. + exact (H firstelement). + apply meq. intros. do 2 rewrite el_tl. apply H. Defined. Lemma make_vec_el {n} (v : vec A n) : make_vec (el v) = v. Proof. apply vec_extens. intros i. rewrite el_make_vec. reflexivity. Defined. (** *** Weak equivalence with functions. *) Definition isweqvecfun {n} : isweq (el:vec A n → ⟦ n ⟧ → A) := isweq_iso el make_vec make_vec_el el_make_vec_fun. Definition weqvecfun n : vec A n ≃ (⟦ n ⟧ -> A) := make_weq el isweqvecfun. Lemma isofhlevelvec {n} (is1 : isofhlevel n A) k : isofhlevel n (vec A k). Proof. induction k as [|k IH]. - apply isofhlevelcontr, iscontrunit. - apply isofhleveldirprod. + apply is1. + apply IH. Defined. (** *** Induction. *) Lemma vec_ind (P : ∏ n, vec A n → UU) : P 0 [()] → (∏ x n (v : vec A n), P n v → P (S n) (x ::: v)) → (∏ n (v : vec A n), P n v). Proof. intros Hnil Hcons. induction n as [|m H]; intros. - apply (transportb (P 0) (vec0_eq v [()]) Hnil). - apply Hcons, H. Defined. End vecs. (** *** Map, fold and append. *) Definition vec_map {A B : UU} (f : A → B) {n} (v : vec A n) : vec B n. Proof. induction n as [|m h]. - exact vnil. - eapply vcons. + exact (f (hd v)). + exact (h (tl v)). Defined. Lemma hd_vec_map {A B : UU} (f : A → B) {n} (v : vec A (S n)) : hd (vec_map f v) = f (hd v). Proof. reflexivity. Defined. Lemma tl_vec_map {A B : UU} (f : A → B) {n} (v : vec A (S n)) : tl (vec_map f v) = vec_map f (tl v). Proof. reflexivity. Defined. Lemma el_vec_map {A B : UU} (f : A → B) {n} (v : vec A n) (i : ⟦ n ⟧) : el (vec_map f v) i = f (el v i). Proof. induction n as [|m H]. - exact (fromstn0 i). - induction i as (j, jlt). induction j as [|k _]. + apply hd_vec_map. + change (el (tl (vec_map f v)) (make_stn _ k jlt) = f (el (tl v) (make_stn _ k jlt))). etrans. { apply el_tl. } etrans. { apply H. } apply maponpaths. apply maponpaths. reflexivity. Defined. Lemma vec_map_as_make_vec {A B: UU} (f: A → B) {n} (v: vec A n) : vec_map f v = make_vec (λ i, f (el v i)). Proof. apply vec_extens. intro i. rewrite el_vec_map. rewrite el_make_vec. apply idpath. Defined. Definition vec_foldr {A B : UU} (f : A -> B -> B) (b : B) {n} : vec A n -> B := vec_ind (λ (n : nat) (_ : vec A n), B) b (λ (a : A) (m : nat) (_ : vec A m) (acc : B), f a acc) n. Definition vec_foldr1 {A : UU} (f : A -> A -> A) {n} : vec A (S n) → A := nat_rect (λ n : nat, vec A (S n) → A) hd (λ (m : nat) (h : vec A (S m) → A), uncurry (λ (x : A) (u : vec A (S m)), f x (h u))) n. Definition vec_append {A : UU} {m} (u : vec A m) {n} (v : vec A n) : vec A (m + n) := vec_ind (λ (p : nat) (_ : vec A p), vec A (p + n)) v (λ (x : A) (p : nat) (_ : vec A p) (w : vec A (p + n)), x ::: w) m u. (** *** Fusion laws. *) Lemma vec_map_id {A : UU} {n} (v: vec A n) : vec_map (idfun A) v = v. Proof. revert n v. refine (vec_ind _ _ _). - apply idpath. - intros x n xs HPxs. simpl. apply maponpaths. apply HPxs. Defined. Lemma vec_map_comp {A B C: UU} (f: A → B) (g: B → C) {n: nat} (v: vec A n) : vec_map (funcomp f g) v = (funcomp (vec_map f) (vec_map g)) v. Proof. revert n v. refine (vec_ind _ _ _). - apply idpath. - intros x n xs HPxs. apply vecS_eq. + reflexivity. + apply HPxs. Defined. Lemma vec_map_make_vec {A B: UU} {n: nat} (g: ⟦ n ⟧ → A) (f: A → B) : vec_map f (make_vec g) = make_vec (f ∘ g). Proof. apply vec_extens. intro i. rewrite el_vec_map. rewrite el_make_vec. rewrite el_make_vec. apply idpath. Defined. Lemma vec_append_lid {A : UU} (u : vec A 0) {n} : vec_append u = idfun (vec A n). Proof. induction u. reflexivity. Defined. (** *** Other operations on vecs. *) Definition vec_fill {A: UU} (a: A): ∏ n: nat, vec A n := nat_rect (λ n: nat, vec A n) [()] (λ (n: nat) (v: vec A n), a ::: v). Lemma vec_map_const {A: UU} {n: nat} {v: vec A n} {B: UU} (b: B) : vec_map (λ _, b) v = vec_fill b n. Proof. revert n v. apply vec_ind. - apply idpath. - intros x n xs HPind. change (b ::: vec_map (λ _: A, b) xs = b ::: vec_fill b n). apply maponpaths. exact HPind. Defined. Definition vec_zip {A B: UU} {n: nat} (v1: vec A n) (v2: vec B n): vec (A × B) n. Proof. induction n. - exact [()]. - induction v1 as [x1 xs1]. induction v2 as [x2 xs2]. exact ((x1 ,, x2) ::: IHn xs1 xs2). Defined. UniMath-20231010/UniMath/Combinatorics/VectorsTests.v000066400000000000000000000027421451125700300223140ustar00rootroot00000000000000(** * Tests for vectors as iterated products. *) (** Gianluca Amato, Marco Maggesi, Cosimo Perini Brogi 2019-2021 *) Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Vectors. Local Open Scope stn. Section Tests_el. Context {A : UU} {a b c d:A}. Let v := vcons a (vcons b (vcons c (vcons d vnil))). Goal el v (●0) = a. reflexivity. Qed. Goal el v (●1) = b. reflexivity. Qed. Goal el v (●2) = c. reflexivity. Qed. Goal el v (●3) = d. reflexivity. Qed. Goal make_vec (el v) = v. reflexivity. Qed. Let f : ⟦ 4 ⟧ → A := Eval compute in (el v). Goal (el (make_vec f) = f). reflexivity. Qed. End Tests_el. Section Test_vec_foldr. Context {A B : UU} (f : A -> B -> B) (b : B) (p q r : A). Let v := vcons p (vcons q (vcons r vnil)). Eval compute in vec_foldr f b v. Goal vec_foldr f b v = f p (f q (f r b)). reflexivity. Qed. End Test_vec_foldr. Section Test_vec_foldr1. Context {A : UU} (f : A -> A -> A) (p q r t : A). Let v := vcons p (vcons q (vcons r (vcons t vnil))). Eval compute in vec_foldr1 f v. Goal vec_foldr1 f v = f p (f q (f r t)). reflexivity. Qed. End Test_vec_foldr1. Section Test_vec_append. Context {A : UU} {a b c d e : A}. Let u := vcons a (vcons b (vcons c vnil)). Let v := vcons d (vcons e vnil). Let w := vcons a (vcons b (vcons c (vcons d (vcons e vnil)))). Eval compute in vec_append u v. Goal vec_append u v = w. reflexivity. Qed. End Test_vec_append. UniMath-20231010/UniMath/Combinatorics/WellFoundedRelations.v000066400000000000000000000223651451125700300237400ustar00rootroot00000000000000(** From Peter Lumsdaine, Aug 29, 2018: Prompted by a question of Dan Grayson: If you assume a relation is a well-order in the sense of having induction into families of propositions, does it then have induction into arbitrary type families? Answer: yes. See the theorem below. The result is also Proposition 1.4 of this article: Intuitionistic Sets and Ordinals, by Paul Taylor The Journal of Symbolic Logic, Vol. 61, No. 3 (Sep., 1996), pp. 705-744 https://www.jstor.org/stable/pdf/2275781.pdf *) Require Import UniMath.Foundations.All. Require Export UniMath.MoreFoundations.Propositions. Require Import UniMath.MoreFoundations.Univalence. Local Arguments funextsec {_ _ _ _} _. (* A predicate is called hereditary with respect to a relation if whenever it holds everywhere below some element, it holds at that element. Hereditariness is the usual hypothesis required for well-founded induction into a predicate. *) Definition hereditary {X} (lt : X -> X -> Type) (P : X -> Type) : Type := ∏ x, (∏ y, lt y x -> P y) -> P x. Definition strongly_well_founded {X} (lt : X -> X -> Type) := ∏ (P : X -> Type) (H : hereditary lt P), ∑ (f : ∏ x, P x), ∏ x, f x = H x (λ y _, f y). Definition weakly_well_founded {X} (lt : X -> X -> Type) := ∏ P : X -> hProp, hereditary lt P -> ∏ x, P x. Section Attempts. Context {X} (lt : X -> X -> Type). Notation "x < y" := (lt x y). Definition chain (n : nat) : ∏ (x y:X), Type. (* An element of [chain n] will be an ascending sequence [x = s_1 < t_1 = s_2 < t_2 = ... = s_n < t_n = y]. We use this to implement the transitive reflexive closure of [lt]. *) Proof. induction n as [|n H]. - intros x y. exact (x = y). - intros x y. exact (∑ s t, H x s × s Type) (H : hereditary lt P). (* An “attempt” up to x: a partial function into P defined just for all y ≤ x, and guided by the term H witnessing the hereditariness of P. Caveat: we should actually have said not “partial function” but “multivalued partial function”, since (y ≤ x) isn’t necessarily an hprop. *) Definition guided_by x (f : ∏ y, y ≤ x -> P y) H := ∏ y pyx, f y pyx = H y (λ z l, f z (cons (idpath z) l pyx)). Definition attempt x := ∑ f, guided_by x f H. Definition attempt_fun {x} : attempt x -> (∏ y _, P y) := pr1. Coercion attempt_fun : attempt >-> Funclass. Definition attempt_comp {x} : ∏ (f : attempt x), _ := pr2. Definition disassemble_attempt {x} : attempt x -> (∏ y w, y w=x -> attempt y). Proof. intros f y' y l e. exists (λ t p, f t (cons' p l e)). intros z p. use attempt_comp. Defined. Definition assemble_attempt {x} : (∏ y y', y y'=x -> attempt y) -> attempt x. Proof. intros fs. use tpair. - intros y [[|n] c]. + apply H. intros z lzy. exact (fs z y lzy c z nil). + induction c as [s [t [c' [l' e']]]]. exact (fs s t l' e' y (n,,c')). - intros y [[|n] c]. + reflexivity. + use attempt_comp. Defined. Definition attempt_lemma {x} (f g : attempt x) (T : (∏ y (pyx : y ≤ x), f y pyx = g y pyx) -> Type) : (∏ (e : attempt_fun f = attempt_fun g), T (λ y pyx, eqtohomot (eqtohomot e y) pyx)) -> ∏ e, T e. Proof. intros HT e. simple refine (transportf _ _ (HT _)). { apply funextsec; intros y; apply funextsec; intros pyx. eapply pathscomp0. { refine (eqtohomot _ _). apply maponpaths. refine (eqtohomot _ _). apply toforallpaths_funextsec. } refine (eqtohomot _ _). apply toforallpaths_funextsec. } Defined. Definition attempt_paths {x} (f g : attempt x) : ∏ (e_fun : ∏ y pyx, f y pyx = g y pyx), (∏ y pyx, attempt_comp f y pyx @ maponpaths (H y) (funextsec (λ z, funextsec (λ lzy, e_fun z (cons (idpath z) lzy pyx)))) = e_fun y pyx @ attempt_comp g y pyx) -> f = g. Proof. use attempt_lemma. intros e. induction f as [f0 f1], g as [g0 g1]. cbn in e. induction e. cbn. intros e_comp. apply maponpaths. apply funextsec; intros y; apply funextsec; intros pyx. refine (!_ @ e_comp _ _). refine (maponpaths _ _ @ pathscomp0rid _). refine (@maponpaths _ _ _ _ (idpath _) _). refine (maponpaths funextsec _ @ funextsec_toforallpaths _). apply funextsec; intros z. apply (funextsec_toforallpaths (idpath _)). Defined. Definition assemble_disassemble {x} (f : attempt x) : assemble_attempt (disassemble_attempt f) = f. Proof. use attempt_paths. - intros y [[|n] pyx]. + apply pathsinv0. use attempt_comp. + reflexivity. - intros y [[|n] pyx]. + cbn. refine (@maponpaths _ _ _ _ (idpath _) _ @ ! pathsinv0l _). refine (maponpaths _ _ @ funextsec_toforallpaths _). apply funextsec; intros z. apply (funextsec_toforallpaths (idpath _)). + refine (maponpaths _ _ @ pathscomp0rid _). refine (@maponpaths _ _ _ _ (idpath _) _). refine (maponpaths funextsec _ @ funextsec_toforallpaths _). apply funextsec; intros w. apply (funextsec_toforallpaths (idpath _)). Defined. Context (wwf_lt : weakly_well_founded lt). Definition iscontr_attempt : ∏ x, iscontr (attempt x). Proof. apply (wwf_lt (λ x, iscontr_hProp (attempt x))). intros x IH. apply (iscontrretract _ _ assemble_disassemble). apply impred_iscontr; intro z; apply impred_iscontr; intro z'; apply impred_iscontr; intro l; apply impred_iscontr; intro e. induction e. exact (IH z l). Defined. Local Definition the_attempt x : attempt x := iscontrpr1 (iscontr_attempt x). Local Definition the_value x : P x := the_attempt x x nil. Local Definition the_comp x : the_value x = H x (λ y l, the_value y). Proof. assert (e : the_attempt x = assemble_attempt (λ y _ _ _, the_attempt y)). { apply pathsinv0, iscontr_uniqueness. } exact (eqtohomot (eqtohomot (maponpaths attempt_fun e) x) nil). Defined. End Attempts. Arguments le {_ _} _ _. (* The main theorem of this file, due to Peter Lumsdaine. *) Theorem strongly_from_weakly_well_founded {X} {lt : X -> X -> Type} : weakly_well_founded lt -> strongly_well_founded lt. Proof. intros wwf_lt P H_P. exists (the_value lt P H_P wwf_lt). exact (the_comp lt P H_P wwf_lt). Defined. Section OrderedSets. (* These facts might be well known. *) Context {X:UU} (lt : X -> X -> Type). Context (wwf_lt : weakly_well_founded lt). Notation "x < y" := (lt x y). Lemma irrefl z : ¬ (z < z). Proof. (** This proof is provided by Marc Bezem. We use the strong version of well foundedness, so we can avoid needing [funextemptyAxiom] to prove that [¬ (z=t)] is a proposition. *) intro l. simple refine (pr1 (strongly_from_weakly_well_founded wwf_lt (λ t, ¬ (z=t)) _) z (idpath z)). intros x h e. induction e. exact (h z l (idpath z)). Defined. Lemma notboth {r s} : (r ¬ (s nat -> Type) (init : ∏ n, f 0 n) (ind : ∏ m n, f m (S n) -> f (S m) n): ∏ m n, f m n. Proof. intros m. induction m as [|m H]. - exact init. - intros n. apply ind. apply H. Defined. Lemma chaintrans {x y z m n} : chain lt m x y -> chain lt n y z -> chain lt (m+n) x z. Proof. revert m n y. apply (diagRecursion (λ m n, ∏ y, chain lt m x y → chain lt n y z → chain lt (m + n) x z)). - intros k y c. induction c. exact (idfun _). - intros r s p y c d. induction c as [u [t [b [k e]]]]. change ((S r) + s) with (S (r+s)). rewrite plus_n_Sm. apply (p u b); clear p b x r. induction e. exact (cons1 lt z (idpath u) k d). Defined. End OrderedSets. UniMath-20231010/UniMath/Combinatorics/WellOrderedSets.v000066400000000000000000001625761451125700300227270ustar00rootroot00000000000000(* -*- coding: utf-8 -*- *) (** * Well Ordered Sets *) (** In this file our goal is to prove Zorn's Lemma and Zermelo's Well-Ordering Theorem. *) Require Import UniMath.MoreFoundations.DecidablePropositions. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.MoreFoundations.Subtypes. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.AxiomOfChoice. Require Import UniMath.Combinatorics.OrderedSets. Local Open Scope logic. Local Open Scope set. Local Open Scope subtype. Local Open Scope poset. Declare Scope tosubset. Delimit Scope tosubset with tosubset. (* subsets equipped with a well ordering *) Local Open Scope tosubset. Declare Scope wosubset. Delimit Scope wosubset with wosubset. (* subsets equipped with a well ordering *) Local Open Scope wosubset. (** ** Totally ordered subsets of a set *) Definition TotalOrdering (S:hSet) : hSet := ∑ (R : hrel_set S), hProp_to_hSet (isTotalOrder R). Definition TOSubset_set (X:hSet) : hSet := ∑ (S:subtype_set X), TotalOrdering (carrier_subset S). Definition TOSubset (X:hSet) : UU := TOSubset_set X. Definition TOSubset_to_subtype {X:hSet} : TOSubset X -> hsubtype X := pr1. Coercion TOSubset_to_subtype : TOSubset >-> hsubtype. Local Definition TOSrel {X:hSet} (S : TOSubset X) : hrel (carrier_subset S) := pr12 S. Notation "s ≤ s'" := (TOSrel _ s s') : tosubset. Definition TOtotal {X:hSet} (S : TOSubset X) : isTotalOrder (TOSrel S) := pr22 S. Definition TOtot {X:hSet} (S : TOSubset X) : istotal (TOSrel S) := pr222 S. Definition TOanti {X:hSet} (S : TOSubset X) : isantisymm (TOSrel S) := pr2 (pr122 S). Definition TOrefl {X:hSet} (S : TOSubset X) : isrefl (TOSrel S) := pr211 (pr22 S). Definition TOeq_to_refl {X:hSet} (S : TOSubset X) : ∀ s t : carrier_subset S, s = t ⇒ s ≤ t. Proof. intros s t e. induction e. apply TOrefl. Defined. Definition TOeq_to_refl_1 {X:hSet} (S : TOSubset X) : ∀ s t : carrier_subset S, pr1 s = pr1 t ⇒ s ≤ t. Proof. intros s t e. induction (subtypePath_prop e). apply TOrefl. Defined. Definition TOtrans {X:hSet} (S : TOSubset X) : istrans (TOSrel S). Proof. apply (pr2 S). Defined. Local Lemma h1'' {X:hSet} {S:TOSubset X} {r s t u:S} : (r ≤ t -> pr1 r = pr1 s -> pr1 t = pr1 u -> s ≤ u)%tosubset. Proof. intros le p q. induction (subtypePath_prop p). induction (subtypePath_prop q). exact le. Defined. Definition tosub_order_compat {X:hSet} {S T : TOSubset X} (le : S ⊆ T) : hProp := ∀ s s' : S, s ≤ s' ⇒ subtype_inc le s ≤ subtype_inc le s'. Definition tosub_le (X:hSet) (S T : TOSubset X) : hProp := (∑ le : S ⊆ T, tosub_order_compat le)%prop. Notation "S ≼ T" := (tosub_le _ S T) (at level 70) : tosubset. Definition sub_initial {X:hSet} {S : hsubtype X} {T : TOSubset X} (le : S ⊆ T) : hProp := ∀ (s t : X) (Ss : S s) (Tt : T t), TOSrel T (t,,Tt) (s,,le s Ss) ⇒ S t. Definition same_induced_ordering {X:hSet} {S T : TOSubset X} {B : hsubtype X} (BS : B ⊆ S) (BT : B ⊆ T) := ∀ x y : B, subtype_inc BS x ≤ subtype_inc BS y ⇔ subtype_inc BT x ≤ subtype_inc BT y. Definition common_initial {X:hSet} (B : hsubtype X) (S T : TOSubset X) : hProp := (∑ (BS : B ⊆ S) (BT : B ⊆ T), sub_initial BS ∧ sub_initial BT ∧ same_induced_ordering BS BT)%prop. (* the largest initial common ordered subset of S and of T, as the union of all of them *) Definition max_common_initial {X:hSet} (S T : TOSubset X) : hsubtype X := λ x, ∃ (B : hsubtype X), B x ∧ common_initial B S T. Lemma max_common_initial_is_max {X:hSet} (S T : TOSubset X) (A : hsubtype X) : common_initial A S T -> A ⊆ max_common_initial S T. Proof. intros c x Ax. exact (hinhpr (A,,Ax,,c)). Defined. Lemma max_common_initial_is_sub {X:hSet} (S T : TOSubset X) : max_common_initial S T ⊆ S ∧ max_common_initial S T ⊆ T. Proof. split. - intros x m. apply (squash_to_hProp m); intros [B [Bx [BS [_ _]]]]; clear m. exact (BS _ Bx). - intros x m. apply (squash_to_hProp m); intros [B [Bx [_ [BT _]]]]; clear m. exact (BT _ Bx). Defined. Lemma max_common_initial_is_common_initial {X:hSet} (S T : TOSubset X) : common_initial (max_common_initial S T) S T. Proof. exists (pr1 (max_common_initial_is_sub S T)). exists (pr2 (max_common_initial_is_sub S T)). split. { intros x s M Ss le. apply (squash_to_hProp M); intros [B [Bx [BS [BT [BSi [BTi BST]]]]]]. unfold sub_initial in BSi. apply hinhpr. exists B. split. + apply (BSi x s Bx Ss). now apply (h1'' le). + exact (BS,,BT,,BSi,,BTi,,BST). } split. { intros x t M Tt le. apply (squash_to_hProp M); intros [B [Bx [BS [BT [BSi [BTi BST]]]]]]. unfold sub_initial in BSi. apply hinhpr. exists B. split. + apply (BTi x t Bx Tt). now apply (h1'' le). + exact (BS,,BT,,BSi,,BTi,,BST). } intros x y. split. { intros le. induction x as [x xm], y as [y ym]. apply (squash_to_hProp xm); intros [B [Bx [BS [BT [BSi [BTi BST]]]]]]. apply (squash_to_hProp ym); intros [C [Cy [CS [CT [CSi [CTi CST]]]]]]. assert (Cx : C x). { apply (CSi y x Cy (BS x Bx)). now apply (h1'' le). } assert (Q := pr1 (CST (x,,Cx) (y,,Cy))); simpl in Q. assert (E : subtype_inc CS (x,, Cx) ≤ subtype_inc CS (y,, Cy)). { now apply (h1'' le). } clear le. now apply (h1'' (Q E)). } { intros le. induction x as [x xm], y as [y ym]. apply (squash_to_hProp xm); intros [B [Bx [BS [BT [BSi [BTi BST]]]]]]. apply (squash_to_hProp ym); intros [C [Cy [CS [CT [CSi [CTi CST]]]]]]. assert (Cx : C x). { apply (CTi y x Cy (BT x Bx)). now apply (h1'' le). } assert (Q := pr2 (CST (x,,Cx) (y,,Cy))); simpl in Q. assert (E : subtype_inc CT (x,, Cx) ≤ subtype_inc CT (y,, Cy)). { now apply (h1'' le). } clear le. now apply (h1'' (Q E)). } Defined. Lemma tosub_fidelity {X:hSet} {S T:TOSubset X} (le : S ≼ T) (s s' : S) : s ≤ s' ⇔ subtype_inc (pr1 le) s ≤ subtype_inc (pr1 le) s'. Proof. split. { exact (pr2 le s s'). } { intro l. apply (squash_to_hProp (TOtot S s s')). intros [c|c]. - exact c. - apply (TOeq_to_refl S s s'). assert (k := pr2 le _ _ c); clear c. assert (k' := TOanti T _ _ l k); clear k l. apply subtypePath_prop. exact (maponpaths pr1 k'). } Defined. (** *** Adding a point on top of a totally ordered subset *) (** We proceed directly. An indirect way would be to form the corresponding totally ordered set, add a point to it, set up an equivalence between that and the union of our subset and the new point (assuming decidability of equality), and transport the ordering along the equivalence. *) Definition TOSubset_plus_point_rel {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : hrel (carrier_subset (subtype_plus S z)). Proof. intros [s i] [t j]. unfold subtype_plus in i,j. change hPropset. use (squash_to_hSet_2' _ _ i j); clear i j. { intros [Ss|ezs] [St|ezt]. { exact (TOSrel S (s,,Ss) (t,,St)). } { exact htrue. } { exact hfalse. } { exact htrue. } } { split. { intros [Ss|ezs] [Ss'|ezs'] [St|ezt]. repeat split. - now induction_hProp Ss Ss'. - reflexivity. - apply fromempty. induction ezs'. exact (nSz Ss). - reflexivity. - apply fromempty. induction ezs. exact (nSz Ss'). - reflexivity. - reflexivity. - reflexivity. } { intros [Ss|ezs] [St|ezt] [St'|ezt']. repeat split. - now induction_hProp St St'. - apply fromempty. induction ezt'. exact (nSz St). - apply fromempty. induction ezt. exact (nSz St'). - reflexivity. - reflexivity. - apply fromempty. induction ezt'. exact (nSz St). - apply fromempty. induction ezt. exact (nSz St'). - reflexivity. } } Defined. Lemma isTotalOrder_TOSubset_plus_point {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : isTotalOrder (TOSubset_plus_point_rel S z nSz). Proof. split. { split. { split. { (* transitivity *) intros [w Ww] [x Wx] [y Wy] wx xy. apply (squash_to_hProp Wy); intros [Sy|ezy]. - induction (ishinh_irrel (ii1 Sy) Wy). apply (squash_to_hProp Ww); intros [Sw|ezw]. + induction (ishinh_irrel (ii1 Sw) Ww). apply (squash_to_hProp Wx); intros [Sx|ezx]. * induction (ishinh_irrel (ii1 Sx) Wx); change (hProptoType (TOSrel S (w,,Sw) (x,,Sx))) in wx; change (hProptoType (TOSrel S (x,,Sx) (y,,Sy))) in xy; change (hProptoType (TOSrel S (w,,Sw) (y,,Sy))). exact (TOtrans _ _ _ _ wx xy). * induction ezx; induction (ishinh_irrel (ii2 (idpath z)) Wx); change empty in xy. exact (fromempty xy). + induction ezw. induction (ishinh_irrel (ii2 (idpath z)) Ww). change hfalse. apply (squash_to_hProp Wx); intros [Sx|ezx]. * induction (ishinh_irrel (ii1 Sx) Wx); change (hProptoType (TOSrel S (x,,Sx) (y,,Sy))) in xy; change empty in wx. exact wx. * induction ezx; induction (ishinh_irrel (ii2 (idpath z)) Wx); change unit in wx; change empty in xy. exact xy. - induction ezy. apply (squash_to_hProp Ww); intros [Sw|ezw]. + induction (ishinh_irrel (ii1 Sw) Ww), (ishinh_irrel (ii2 (idpath z)) Wy). exact tt. + induction ezw, (ishinh_irrel (ii2 (idpath z)) Wy). induction (ishinh_irrel (ii2 (idpath z)) Ww). exact tt. } { (* reflexivity *) intros [x Wx]. apply (squash_to_hProp Wx); intros [Sx|ezx]. - induction (ishinh_irrel (ii1 Sx) Wx). change (hProptoType (TOSrel S (x,,Sx) (x,,Sx))). apply TOrefl. - induction ezx. induction (ishinh_irrel (ii2 (idpath z)) Wx); change unit. exact tt. } } { (* antisymmetry *) intros [x Wx] [y Wy] xy yx. apply eqset_to_path. apply (squash_to_hProp Wx); intros [Sx|ezx]. - induction (ishinh_irrel (ii1 Sx) Wx). apply (squash_to_hProp Wy); intros [Sy|ezy]. + induction (ishinh_irrel (ii1 Sy) Wy); change (hProptoType (TOSrel S (x,,Sx) (y,,Sy))) in xy; change (hProptoType (TOSrel S (y,,Sy) (x,,Sx))) in yx. apply subtypePath_prop; change (x=y). exact (maponpaths pr1 (TOanti S _ _ xy yx)). + induction ezy. induction (ishinh_irrel (ii2 (idpath z)) Wy); change unit in xy; change empty in yx. apply subtypePath_prop; change (x=z). exact (fromempty yx). - induction ezx. induction (ishinh_irrel (ii2 (idpath z)) Wx). apply (squash_to_hProp Wy); intros [Sy|ezy]. + induction (ishinh_irrel (ii1 Sy) Wy); change unit in yx; change empty in xy. apply subtypePath_prop; change (z=y). exact (fromempty xy). + induction ezy. apply subtypePath_prop; change (z=z). reflexivity. } } { (* totality *) intros [x Wx] [y Wy]. apply (squash_to_hProp Wx); intros [Sx|ezx]. - induction (ishinh_irrel (ii1 Sx) Wx). apply (squash_to_hProp Wy); intros [Sy|ezy]. + induction (ishinh_irrel (ii1 Sy) Wy). generalize (TOtot S (x,,Sx) (y,,Sy)); apply hinhfun; intros [xy|yx]. * apply ii1. exact xy. * apply ii2. exact yx. + induction ezy. induction (ishinh_irrel (ii2 (idpath z)) Wy); change (htrue ∨ hfalse). exact (hinhpr (ii1 tt)). - induction ezx. induction (ishinh_irrel (ii2 (idpath z)) Wx). apply (squash_to_hProp Wy); intros [Sy|ezy]. + induction (ishinh_irrel (ii1 Sy) Wy); change (hfalse ∨ htrue). exact (hinhpr (ii2 tt)). + induction ezy. induction (ishinh_irrel (ii2 (idpath z)) Wy); change (htrue ∨ htrue). exact (hinhpr (ii2 tt)). } Defined. Definition TOSubset_plus_point {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : TOSubset X := subtype_plus S z,, TOSubset_plus_point_rel S z nSz,, isTotalOrder_TOSubset_plus_point S z nSz. Lemma TOSubset_plus_point_incl {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : S ⊆ TOSubset_plus_point S z nSz. Proof. apply subtype_plus_incl. Defined. Lemma TOSubset_plus_point_le {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : S ≼ TOSubset_plus_point S z nSz. Proof. use tpair. - apply TOSubset_plus_point_incl. - intros s t le. exact le. Defined. Lemma TOSubset_plus_point_initial {X:hSet} (S:TOSubset X) (z:X) (nSz : ¬ S z) : sub_initial (TOSubset_plus_point_incl S z nSz). Proof. intros s t Ss Tt le. apply (squash_to_hProp Tt); intros [St|ezt]. - exact St. - induction ezt, (ishinh_irrel (ii2 (idpath z)) Tt); change empty in le. exact (fromempty le). Defined. (** ** Well ordered subsets of a set *) Definition hasSmallest {X : UU} (R : hrel X) : hProp := ∀ S : hsubtype X, (∃ x, S x) ⇒ ∃ x:X, S x ∧ ∀ y:X, S y ⇒ R x y. Definition isWellOrder {X : hSet} (R : hrel X) : hProp := isTotalOrder R ∧ hasSmallest R. Definition WellOrdering (S:hSet) : hSet := ∑ (R : hrel_set S), hProp_to_hSet (isWellOrder R). Definition WOSubset_set (X:hSet) : hSet := ∑ (S:subtype_set X), WellOrdering (carrier_subset S). Definition WOSubset (X:hSet) : UU := WOSubset_set X. Definition WOSubset_to_subtype {X:hSet} : WOSubset X -> hsubtype X := pr1. Definition WOSrel {X:hSet} (S : WOSubset X) : hrel (carrier_subset (WOSubset_to_subtype S)) := pr12 S. Definition WOStotal {X:hSet} (S : WOSubset X) : isTotalOrder (WOSrel S) := pr122 S. Definition WOSubset_to_TOSubset {X:hSet} : WOSubset X -> TOSubset X := λ S, WOSubset_to_subtype S,, WOSrel S,, WOStotal S. Coercion WOSubset_to_TOSubset : WOSubset >-> TOSubset. Definition WOSwo {X:hSet} (S : WOSubset X) : WellOrdering (carrier_subset S) := pr2 S. Notation "s ≤ s'" := (WOSrel _ s s') : wosubset. Local Definition lt {X:hSet} {S : WOSubset X} (s s' : S) := ¬ (s' ≤ s)%wosubset. Notation "s < s'" := (lt s s') : wosubset. Definition WOS_hasSmallest {X:hSet} (S : WOSubset X) : hasSmallest (WOSrel S) := pr222 S. Lemma wo_lt_to_le {X:hSet} {S : WOSubset X} (s s' : S) : s < s' -> s ≤ s'. Proof. unfold lt. intros lt. apply (squash_to_hProp (TOtot S s s')); intros [c|c]. - exact c. - exact (fromempty (lt c)). Defined. Definition wosub_le (X:hSet) : hrel (WOSubset X) := (λ S T : WOSubset X, ∑ (le : S ⊆ T), tosub_order_compat le ∧ sub_initial le)%prop. Notation "S ≼ T" := (wosub_le _ S T) (at level 70) : wosubset. Definition wosub_le_inc {X:hSet} {S T : WOSubset X} : S ≼ T -> S ⊆ T := pr1. Definition wosub_le_comp {X:hSet} {S T : WOSubset X} (le : S ≼ T) : tosub_order_compat (pr1 le) := pr12 le. Definition wosub_le_subi {X:hSet} {S T : WOSubset X} (le : S ≼ T) : sub_initial (pr1 le) := pr22 le. Lemma wosub_le_isrefl {X:hSet} : isrefl (wosub_le X). Proof. intros S. use tpair. + intros x xinS. exact xinS. + split. * intros s s' le. exact le. * intros s s' Ss Ss' le. exact Ss'. Defined. Definition wosub_equal {X:hSet} : hrel (WOSubset X) := λ S T, S ≼ T ∧ T ≼ S. Notation "S ≣ T" := (wosub_equal S T) (at level 70) : wosubset. Definition wosub_comparable {X:hSet} : hrel (WOSubset X) := λ S T, S ≼ T ∨ T ≼ S. Definition hasSmallest_WOSubset_plus_point {X:hSet} (S:WOSubset X) (z:X) (nSz : ¬ S z) : LEM ⇒ hasSmallest (TOSrel (TOSubset_plus_point S z nSz)). Proof. intros lem T ne. (* T is a nonempty set. We need to find the smallest element of it *) set (S' := TOSubset_plus_point S z nSz). assert (S'z := subtype_plus_has_point S z : S' z). set (z' := (z,,S'z) : carrier S'). set (j := TOSubset_plus_point_incl S z nSz). fold S' in j. set (jmap := subtype_inc j). set (SiT := λ s:S, T (subtype_inc j s)). (* Decide whether [S ∩ T] is nonempty: *) induction (lem (∃ s, SiT s)) as [q|q]. - (* ... use the smallest element of SiT *) assert (SiTmin := WOS_hasSmallest _ _ q). apply (squash_to_hProp SiTmin); clear SiTmin; intros [m [SiTm min]]. apply hinhpr. set (m' := jmap m). exists m'. split. + exact SiTm. + intros [t S't] Tt. apply (squash_to_hProp S't); intros [St|etz]. * induction (ishinh_irrel (ii1 St) S't); change (m ≤ (t,,St)). exact (min (t,,St) Tt). * induction etz; induction (ishinh_irrel (ii2 (idpath z)) S't); change unit. exact tt. - (* ... use z *) apply hinhpr. exists z'. split. + (* T doesn't meet S, so it must contain z *) apply (squash_to_hProp ne); clear ne; intros [[t SiTt] Tt]. apply (squash_to_hProp SiTt); intros [St|ezt]. * apply fromempty. (* S also meets T, so get a contradiction *) apply q. apply hinhpr. exists (t,,St). change (T (t,, j t St)). induction (proofirrelevance_hProp _ SiTt (j t St)). exact Tt. * induction ezt. unfold z'. induction (proofirrelevance_hProp _ SiTt S'z). exact Tt. + (* now show z' is the smallest element of T *) intros [t S't] Tt. apply (squash_to_hProp S't); intros [St|ezt]. * apply fromempty. (* t is in S ∩ T, but that's empty *) apply q; clear q. apply hinhpr. exists (t,,St). change (T (t,, j t St)). induction (proofirrelevance_hProp _ S't (j t St)). exact Tt. * induction ezt. (* now show [z ≤ z], by reflexivity *) change (TOSrel S' (z,,S'z) (z,,S't)). induction (proofirrelevance_hProp _ S'z S't). exact (TOrefl S' _). Defined. Definition WOSubset_plus_point {X:hSet} (S:WOSubset X) (z:X) (nSz : ¬ S z) : LEM -> WOSubset X := λ lem, subtype_plus S z,, TOSrel (TOSubset_plus_point S z nSz),, TOtotal (TOSubset_plus_point S z nSz),, hasSmallest_WOSubset_plus_point S z nSz lem. Definition wosub_univalence_map {X:hSet} (S T : WOSubset X) : (S = T) -> (S ≣ T). Proof. intros e. induction e. unfold wosub_equal. simple refine ((λ L, make_dirprod L L) _). use tpair. + intros x s. assumption. + split. * intros s s' le. assumption. * intros s t Ss St le. assumption. Defined. Theorem wosub_univalence {X:hSet} (S T : WOSubset X) : (S = T) ≃ (S ≣ T). Proof. simple refine (remakeweq _). { unfold wosub_equal. intermediate_weq (S ╝ T). - apply total2_paths_equiv. - intermediate_weq (∑ e : S ≡ T, S ≼ T ∧ T ≼ S)%prop. + apply weqbandf. * apply hsubtype_univalence. * intro p. induction S as [S v], T as [T w]. simpl in p. induction p. change (v=w ≃ (S,, v ≼ S,, w ∧ S,, w ≼ S,, v)). induction v as [v i], w as [w j]. intermediate_weq (v=w)%type. { apply subtypeInjectivity. change (isPredicate (λ R : hrel (carrier_subset S), isWellOrder R)). intros R. apply propproperty. } apply weqimplimpl. { intros p. induction p. split. { use tpair. { intros s. change (S s → S s). exact (idfun _). } { split. { intros s s' le. exact le. } { intros s t Ss St le. exact St. } } } { use tpair. { intros s. change (S s → S s). exact (idfun _). } { split. { intros s s' le. exact le. } { intros s t Ss St le. exact St. } } } } { simpl. unfold WOSrel. simpl. intros [[a [b _]] [d [e _]]]. assert (triv : ∏ (f:∏ x : X, S x → S x) (x:carrier_subset S), subtype_inc f x = x). { intros f s. apply subtypePath_prop. reflexivity. } apply funextfun; intros s. apply funextfun; intros t. apply hPropUnivalence. { intros le. assert (q := b s t le). rewrite 2 triv in q. exact q. } { intros le. assert (q := e s t le). rewrite 2 triv in q. exact q. } } { apply setproperty. } { apply propproperty. } + apply weqimplimpl. { intros k. split ; apply k. } { intros c. split. { intros x. exact (wosub_le_inc (pr1 c) x,,wosub_le_inc (pr2 c) x). } { exact c. } } { apply propproperty. } { apply propproperty. } } { apply wosub_univalence_map. } { intros e. induction e. reflexivity. } Defined. Lemma wosub_univalence_compute {X:hSet} (S T : WOSubset X) (e : S = T) : wosub_univalence S T e = wosub_univalence_map S T e. Proof. reflexivity. Defined. Definition wosub_inc {X:hSet} {S T : WOSubset X} : (S ≼ T) -> S -> T. Proof. intros le s. exact (subtype_inc (pr1 le) s). Defined. Lemma wosub_fidelity {X:hSet} {S T:WOSubset X} (le : S ≼ T) (s s' : S) : s ≤ s' ⇔ wosub_inc le s ≤ wosub_inc le s'. (* we want this lemma available after showing the union of a chain is totally ordered but before showing it has the smallest element condition *) Proof. set (Srel := WOSrel S). assert (Stot : istotal Srel). { apply (WOSwo S). } set (Trel := WOSrel T). assert (Tanti : isantisymm Trel). { apply (WOSwo T). } split. { intro l. exact (wosub_le_comp le s s' l). } { intro l. apply (squash_to_hProp (Stot s s')). change ((s ≤ s') ⨿ (s' ≤ s) → s ≤ s'). intro c. induction c as [c|c]. - exact c. - induction le as [le [com ini]]. assert (k := com s' s c). assert (k' := Tanti _ _ l k); clear k. assert (p : s = s'). { apply subtypePath_prop. exact (maponpaths pr1 k'). } induction p. apply (pr2 S). (* refl *) } Defined. Local Lemma h1 {X} {S:WOSubset X} {s t u:S} : s = t -> t ≤ u -> s ≤ u. Proof. intros p le. induction p. exact le. Defined. Lemma wosub_le_isPartialOrder X : isPartialOrder (wosub_le X). Proof. repeat split. - intros S T U i j. exists (pr11 (subtype_containment_isPartialOrder X) S T U (pr1 i) (pr1 j)). split. + intros s s' l. exact (wosub_le_comp j _ _ (wosub_le_comp i _ _ l)). + intros s u Ss Uu l. change (hProptoType ((u,,Uu) ≤ subtype_inc (pr1 j) (subtype_inc (pr1 i) (s,,Ss)))) in l. set (uinT := u ,, wosub_le_subi j s u (pr1 i s Ss) Uu l : T). assert (p : subtype_inc (pr1 j) uinT = u,,Uu). { now apply subtypePath_prop. } assert (q := h1 p l : subtype_inc (pr1 j) uinT ≤ subtype_inc (pr1 j) (subtype_inc (pr1 i) (s,,Ss))). assert (r := pr2 (wosub_fidelity j _ _) q). assert (b := wosub_le_subi i _ _ _ _ r); simpl in b. exact b. - apply wosub_le_isrefl. - intros S T i j. apply (invmap (wosub_univalence _ _)). exact (i,,j). Defined. Definition WosubPoset (X:hSet) : Poset. Proof. exists (WOSubset_set X). exists (λ S T, S ≼ T). exact (wosub_le_isPartialOrder X). Defined. Definition wosub_le_smaller {X:hSet} (S T:WOSubset X) : hProp := (S ≼ T) ∧ (∃ t:T, t ∉ S). Notation "S ≺ T" := (wosub_le_smaller S T) (at level 70) : wosubset. (* [upto s x] means x is in S and, as an element of S, it is strictly less than s *) Definition upto {X:hSet} {S:WOSubset X} (s:S) : hsubtype X := (λ x, ∑ h:S x, (x,,h) < s)%prop. Lemma upto_eqn {X:hSet} {S T:WOSubset X} (x:X) (Sx : S x) (Tx : T x) : S ≼ T -> upto (x,,Sx) = upto (x,,Tx). Proof. intros ST. apply (invmap (hsubtype_univalence _ _)). intros y. split. - intros [Sy lt]. exists (pr1 ST y Sy). generalize lt; clear lt. apply negf. intros le'. apply (pr2 (wosub_fidelity ST (x,, Sx) (y,, Sy))). now apply (h1'' (S := T) le'). - intros [Ty lt]. assert (Q := wosub_le_subi ST x y Sx Ty); simpl in Q. assert (e : pr1 ST x Sx = Tx). { apply propproperty. } induction e. assert (Sy := Q (wo_lt_to_le _ _ lt) : S y); clear Q. exists Sy. generalize lt; clear lt. apply negf. intros le'. now apply (h1'' (wosub_le_comp ST _ _ le')). Defined. Definition isInterval {X:hSet} (S:hsubtype X) (T:WOSubset X) (le : S ⊆ T) : LEM -> sub_initial le -> T ⊈ S -> ∃ t:T, S ≡ upto t. Proof. intros lem ini ne. set (R := WOSrel T). assert (min := WOS_hasSmallest T). set (U := (λ t:T, t ∉ S) : hsubtype (carrier T)). (* complement of S in T *) assert (neU : nonempty (carrier U)). { apply (squash_to_hProp ne); intros [x [Tx nSx]]. apply hinhpr. exact ((x,,Tx),,nSx). } clear ne. assert (minU := min U neU); clear min neU. apply (squash_to_hProp minU); clear minU; intros [u [Uu minu]]. (* minu says that u is the smallest element of T not in S *) apply hinhpr. exists u. intro y. split. - intro Sy. change (∑ Ty : T y, neg (u ≤ y,, Ty)). exists (le y Sy). intro ules. use Uu. exact (ini _ _ _ _ ules). - intro yltu. induction yltu as [yinT yltu]. (* Goal : [S y]. We know y is smaller than the smallest element of T not in S, *) (* so at best, constructively, we know [¬ ¬ (S y)]. So prove it by contradiction. *) apply (proof_by_contradiction lem). intro bc. use yltu. now use minu. Defined. (** ** The union of a chain of totally ordered subsets *) Definition is_wosubset_chain {X : hSet} {I : UU} (S : I → WOSubset X) := ∀ i j : I, wosub_comparable (S i) (S j). Lemma common_index {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) (i : I) (x : carrier_subset (⋃ (λ i, S i))) : ∃ j, S i ≼ S j ∧ S j (pr1 x). Proof. induction x as [x xinU]. apply (squash_to_hProp xinU); intros [k xinSk]. change (∃ j : I, S i ≼ S j ∧ S j x). apply (squash_to_hProp (chain i k)). intros c. apply hinhpr. induction c as [c|c]. - exists k. split. + exact c. + exact xinSk. - exists i. split. + apply wosub_le_isrefl. + exact (pr1 c x xinSk). Defined. Lemma common_index2 {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) (x y : carrier_subset (⋃ (λ i, S i))) : ∃ i, S i (pr1 x) ∧ S i (pr1 y). Proof. induction x as [x j], y as [y k]. change (∃ i, S i x ∧ S i y). apply (squash_to_hProp j). clear j. intros [j s]. apply (squash_to_hProp k). clear k. intros [k t]. apply (squash_to_hProp (chain j k)). clear chain. intros [c|c]. - apply hinhpr. exists k. split. + exact (pr1 c x s). + exact t. - apply hinhpr. exists j. split. + exact s. + exact (pr1 c y t). Defined. Lemma common_index3 {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) (x y z : carrier_subset (⋃ (λ i, S i))) : ∃ i, S i (pr1 x) ∧ S i (pr1 y) ∧ S i (pr1 z). Proof. induction x as [x j], y as [y k], z as [z l]. change (∃ i, S i x ∧ S i y ∧ S i z). apply (squash_to_hProp j). clear j. intros [j s]. apply (squash_to_hProp k). clear k. intros [k t]. apply (squash_to_hProp l). clear l. intros [l u]. apply (squash_to_hProp (chain j k)). intros [c|c]. - apply (squash_to_hProp (chain k l)). clear chain. intros [d|d]. + apply hinhpr. exists l. repeat split. * exact (pr1 d x (pr1 c x s)). * exact (pr1 d y t). * exact u. + apply hinhpr. exists k. repeat split. * exact (pr1 c x s). * exact t. * exact (pr1 d z u). - apply (squash_to_hProp (chain j l)). clear chain. intros [d|d]. + apply hinhpr. exists l. repeat split. * exact (pr1 d x s). * exact (pr1 d y (pr1 c y t)). * exact u. + apply hinhpr. exists j. repeat split. * exact s. * exact (pr1 c y t). * exact (pr1 d z u). Defined. Lemma chain_union_prelim_eq0 {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) (x y : X) (i j: I) (xi : S i x) (xj : S j x) (yi : S i y) (yj : S j y) : WOSrel (S i) (x ,, xi) (y ,, yi) = WOSrel (S j) (x ,, xj) (y ,, yj). Proof. apply weqlogeq. apply (squash_to_hProp (chain i j)). intros [c|c]. - split. + intro l. assert (q := wosub_le_comp c _ _ l); clear l. now apply (h1'' q). + intro l. apply (pr2 ((wosub_fidelity c) (x,,xi) (y,,yi))). now apply (@h1'' X (S j) _ _ _ _ l). - split. + intro l. apply (pr2 ((wosub_fidelity c) (x,,xj) (y,,yj))). now apply (@h1'' X (S i) _ _ _ _ l). + intro l. assert (q := wosub_le_comp c _ _ l); clear l. now apply (h1'' q). Defined. Definition chain_union_rel {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : hrel (carrier_subset (⋃ (λ i, S i))). Proof. intros x y. change (hPropset). simple refine (squash_to_hSet _ _ (common_index2 chain x y)). - intros [i [s t]]. exact (WOSrel (S i) (pr1 x,,s) (pr1 y,,t)). - intros i j. now apply chain_union_prelim_eq0. Defined. Definition chain_union_rel_eqn {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) (x y : carrier_subset (⋃ (λ i, S i))) i (s : S i (pr1 x)) (t : S i (pr1 y)) : chain_union_rel chain x y = WOSrel (S i) (pr1 x,,s) (pr1 y,,t). Proof. unfold chain_union_rel. generalize (common_index2 chain x y); intro h. assert (e : hinhpr (i,,s,,t) = h). { apply propproperty. } now induction e. Defined. Lemma chain_union_rel_istrans {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : istrans (chain_union_rel chain). Proof. intros x y z l m. apply (squash_to_hProp (common_index3 chain x y z)); intros [i [r [s t]]]. assert (p := chain_union_rel_eqn chain x y i r s). assert (q := chain_union_rel_eqn chain y z i s t). assert (e := chain_union_rel_eqn chain x z i r t). rewrite p in l; clear p. rewrite q in m; clear q. rewrite e; clear e. assert (tot : istrans (WOSrel (S i))). { apply (pr2 (S i)). } exact (tot _ _ _ l m). Defined. Lemma chain_union_rel_isrefl {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : isrefl (chain_union_rel chain). Proof. intros x. apply (squash_to_hProp (pr2 x)). intros [i r]. assert (p := chain_union_rel_eqn chain x x i r r). rewrite p; clear p. apply (pr2 (S i)). Defined. Lemma chain_union_rel_isantisymm {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : isantisymm (chain_union_rel chain). Proof. intros x y l m. change (x=y)%logic. apply (squash_to_hProp (common_index2 chain x y)); intros [i [r s]]. apply subtypePath_prop. assert (p := chain_union_rel_eqn chain x y i r s). rewrite p in l; clear p. assert (q := chain_union_rel_eqn chain y x i s r). rewrite q in m; clear q. assert (anti : isantisymm (WOSrel (S i))). { apply (pr2 (S i)). } assert (b := anti _ _ l m); clear anti l m. exact (maponpaths pr1 b). Defined. Lemma chain_union_rel_istotal {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : istotal (chain_union_rel chain). Proof. intros x y. apply (squash_to_hProp (common_index2 chain x y)); intros [i [r s]]. assert (p := chain_union_rel_eqn chain x y i r s). rewrite p; clear p. assert (p := chain_union_rel_eqn chain y x i s r). rewrite p; clear p. apply (pr2 (S i)). Defined. Lemma chain_union_rel_isTotalOrder {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : isTotalOrder (chain_union_rel chain). Proof. repeat split. - apply chain_union_rel_istrans. - apply chain_union_rel_isrefl. - apply chain_union_rel_isantisymm. - apply chain_union_rel_istotal. Defined. Definition chain_union_TOSubset {X : hSet} {I : UU} {S : I → WOSubset X} (Schain : is_wosubset_chain S) : TOSubset X. Proof. exists (⋃ S). exists (chain_union_rel Schain). repeat split. - apply chain_union_rel_istrans. - apply chain_union_rel_isrefl. - apply chain_union_rel_isantisymm. - apply chain_union_rel_istotal. Defined. Notation "⋃ chain" := (chain_union_TOSubset chain) (at level 100, no associativity) : tosubset. (** ** The union of a chain of well ordered subsets *) Lemma chain_union_tosub_le {X : hSet} {I : UU} {S : I → WOSubset X} (Schain : is_wosubset_chain S) (i:I) (inc := subtype_inc (subtype_union_containedIn S i)) : ( S i ≼ ⋃ Schain ) % tosubset. Proof. exists (subtype_union_containedIn S i). intros s s' j. set (u := subtype_inc (λ x J, hinhpr (i,, J)) s : ⋃ Schain). set (u':= subtype_inc (λ x J, hinhpr (i,, J)) s': ⋃ Schain). change (chain_union_rel Schain u u'). assert (q := chain_union_rel_eqn Schain u u' i (pr2 s) (pr2 s')). rewrite q; clear q. exact j. Defined. Lemma chain_union_rel_initial {X : hSet} {I : UU} {S : I → WOSubset X} (Schain : is_wosubset_chain S) (i:I) (inc := subtype_inc (subtype_union_containedIn S i)) : (∀ s:S i, ∀ t:⋃ Schain, t ≤ inc s ⇒ t ∈ S i)%tosubset. Proof. intros s t le. apply (squash_to_hProp (common_index Schain i t)). intros [j [[ij [com ini]] tinSj]]. set (t' := (pr1 t,,tinSj) : S j). unfold sub_initial in ini. assert (K := ini (pr1 s) (pr1 t') (pr2 s) (pr2 t')); simpl in K. change (t' ≤ subtype_inc ij s → t ∈ S i) in K. apply K; clear K. unfold tosub_order_compat in com. apply (pr2 (tosub_fidelity (chain_union_tosub_le Schain j) t' (subtype_inc ij s))). clear com ini. assert (p : t = subtype_inc (pr1 (chain_union_tosub_le _ j)) t'). { now apply subtypePath_prop. } induction p. assert (q : inc s = subtype_inc (pr1 (chain_union_tosub_le Schain j)) (subtype_inc ij s)). { now apply subtypePath_prop. } induction q. exact le. Defined. Lemma chain_union_rel_hasSmallest {X : hSet} {I : UU} {S : I → WOSubset X} (chain : is_wosubset_chain S) : hasSmallest (chain_union_rel chain). Proof. intros T t'. apply (squash_to_hProp t'); clear t'; intros [[x i] xinT]. apply (squash_to_hProp i); intros [j xinSj]. induction (ishinh_irrel ( j ,, xinSj ) i). (* T' is the intersection of T with S j *) set (T' := (λ s, T (subtype_inc (subtype_union_containedIn S j) s))). assert (t' := hinhpr ((x,,xinSj),,xinT) : ∥ carrier T' ∥); clear x xinSj xinT. assert (min := WOS_hasSmallest (S j) T' t'); clear t'. apply (squash_to_hProp min); clear min; intros [t0 [t0inT' t0min]]. (* t0 is the minimal element of T' *) set (t0' := subtype_inc (subtype_union_containedIn S j) t0). apply hinhpr. exists t0'. split. - exact t0inT'. - intros t tinT. (* now show any other element t of T is at least as big as t0' *) (* for that purpose, we may assume t ≤ t0' *) apply (hdisj_impl_2 (chain_union_rel_istotal chain _ _)); intro tle. set (q := chain_union_rel_initial chain j t0 t tle). set (t' := (pr1 t,,q) : S j). assert (E : subtype_inc (subtype_union_containedIn S j) t' = t). { now apply subtypePath_prop. } rewrite <- E. unfold t0'. apply (pr2 (chain_union_tosub_le chain j) t0 t'). apply (t0min t'). unfold T'. rewrite E. exact tinT. Defined. Lemma chain_union_WOSubset {X:hSet} {I:UU} {S : I -> WOSubset X} (Schain : is_wosubset_chain S) : WOSubset X. Proof. exists (⋃ Schain). exists (chain_union_rel Schain). repeat split. - apply chain_union_rel_istrans. - apply chain_union_rel_isrefl. - apply chain_union_rel_isantisymm. - apply chain_union_rel_istotal. - apply chain_union_rel_hasSmallest. Defined. Notation "⋃ chain" := (chain_union_WOSubset chain) (at level 100, no associativity) : wosubset. Lemma chain_union_le {X:hSet} {I:UU} (S : I -> WOSubset X) (Schain : is_wosubset_chain S) : ∀ i, S i ≼ ⋃ Schain. Proof. intros i. exists (subtype_union_containedIn S i). split. * exact (pr2 (chain_union_tosub_le _ i)). * intros s t Ss Tt. exact (chain_union_rel_initial Schain i (s,,Ss) (t,,Tt)). Defined. Definition proper_subtypes_set (X:UU) : hSet := ∑ S : subtype_set X, hProp_to_hSet (∃ x, ¬ (S x)). (* the interval up to c, as a proper subset of X *) Definition upto' {X:hSet} {C:WOSubset X} (c:C) : proper_subtypes_set X. Proof. exists (upto c). apply hinhpr. exists (pr1 c). intro n. simpl in n. induction n as [n o]. apply o; clear o. apply (TOeq_to_refl C _ _). now apply subtypePath_prop. Defined. (** ** Choice functions *) (** A choice function provides an element not in each proper subset. *) Definition choice_fun (X:hSet) : hSet := ∏ S : proper_subtypes_set X, ∑ x : X, hProp_to_hSet (¬ pr1 S x). Lemma AC_to_choice_fun (X:hSet) : AxiomOfChoice ⇒ ∥ choice_fun X ∥. Proof. intros ac. exact (squash_to_hProp (ac (proper_subtypes_set X) (λ S, ∑ x, hProp_to_hSet (¬ (pr1 S x))) pr2) hinhpr). Defined. (** Given a choice function g, we single out well ordered subsets C of X that follow the choice functions advice when constructed by adding one element at a time to the top. We may say that C is "guided" by g. *) Definition is_guided_WOSubset {X:hSet} (g : choice_fun X) (C : WOSubset X) : hProp := ∀ c:C, pr1 c = pr1 (g (upto' c)). Lemma upto'_eqn {X:hSet} (g : choice_fun X) (C D : WOSubset X) (j : C ≼ D) (c : C) (d : D) : pr1 (subtype_inc (pr1 j) c) = pr1 d -> pr1 (g (upto' c)) = pr1 (g (upto' d)). Proof. intros p. assert (e' : upto' c = upto' d). { apply subtypePath_prop. change (upto c = upto d). assert (q : subtype_inc (pr1 j) c = d). { now apply subtypePath_prop. } clear p. induction q. now apply upto_eqn. } now induction e'. Defined. Definition Guided_WOSubset {X:hSet} (g : choice_fun X) := (∑ C, is_guided_WOSubset g C)%type. Definition guidedFamily {X:hSet} (g : choice_fun X) : Guided_WOSubset g -> WOSubset X := pr1. Coercion guidedFamily : Guided_WOSubset >-> WOSubset. (** ** The guided well ordered subsets form a chain *) Lemma guided_WOSubset_total {X:hSet} (g : choice_fun X) : LEM -> is_wosubset_chain (guidedFamily g). Proof. intros lem [C gC] [D gD]. set (W := max_common_initial C D). assert (Q := max_common_initial_is_common_initial C D). induction Q as [WC [WD [WCi [WDi WCD]]]]; fold W in WC, WD, WCi, WDi. assert (E : W ≡ C ∨ W ≡ D). { apply (proof_by_contradiction lem); intro h. assert (k := fromnegcoprod_prop h); clear h; induction k as [nc nd]. assert (nCW : C ⊈ W). { use subtype_notEqual_containedIn. - exact WC. - now apply subtype_notEqual_from_negEqual. } assert (nDW : D ⊈ W). { use subtype_notEqual_containedIn. - exact WD. - now apply subtype_notEqual_from_negEqual. } assert (p : ∃ t : C, W ≡ upto t). { now use isInterval. } assert (q : ∃ t : D, W ≡ upto t). { now use isInterval. } change hfalse. apply (squash_to_hProp p); clear p; intros [c cE]. apply (squash_to_hProp q); clear q; intros [d dE]. assert (ce : W = upto c). { now apply (invmap (hsubtype_univalence _ _)). } assert (de : W = upto d). { now apply (invmap (hsubtype_univalence _ _)). } assert (cd := !ce @ de : upto c = upto d). assert (cd' : upto' c = upto' d). { now apply subtypePath_prop. } assert (p := gC c); simpl in p. assert (q := gD d); simpl in q. unfold choice_fun in g. assert (cd1 : pr1 c = pr1 d). { simple refine (p @ _ @ !q). now induction cd'. } clear cd'. set (W' := subtype_plus W (pr1 c)). assert (j := subtype_plus_incl W (pr1 c) : W ⊆ W'). assert (W'c := subtype_plus_has_point W (pr1 c) : W' (pr1 c)). assert (W'd := transportf W' cd1 W'c : W' (pr1 d)). assert (ci : common_initial W' C D). { assert (W'C := subtype_plus_in WC (pr2 c)); assert (W'D := subtype_plus_in WD (transportb (λ x : X, D x) cd1 (pr2 d))); fold W' in W'C, W'D. exists W'C, W'D. assert (cmax : ∏ (v : carrier W') (W'c : W' (pr1 c)), subtype_inc W'C v ≤ subtype_inc W'C (pr1 c,,W'c)). { intros v W'c'. assert (e : c = subtype_inc W'C (pr1 c,, W'c')). { now apply subtypePath_prop. } induction e. clear W'c'. induction v as [v W'v]. apply (squash_to_hProp W'v); intros [Wv|k]. - assert (L := pr1 (cE v) Wv). unfold upto,lt in L. assert (Q := @tot_nge_to_le (carrier_subset C) (TOSrel C) (TOtot C) _ _ (pr2 L)). now apply(h1'' Q). - use (TOeq_to_refl C). apply subtypePath_prop. simpl. exact (!k). } assert (cmax' : ∏ (w : carrier W) (W'c : W' (pr1 c)), subtype_inc W'C (subtype_inc j w) < subtype_inc W'C (pr1 c,,W'c)). { intros w W'c'. assert (e : c = subtype_inc W'C (pr1 c,, W'c')). { now apply subtypePath_prop. } induction e. clear W'c'. induction w as [v Wv]. assert (L := pr1 (cE v) Wv). unfold upto,lt in L. assert (Q := @tot_nge_to_le (carrier_subset C) (TOSrel C) (TOtot C) _ _ (pr2 L)). apply (@tot_nle_iff_gt (carrier_subset C) (TOSrel C) (pr122 C)). split. - now apply (h1'' Q). - intros e. assert (e' := maponpaths pr1 e); clear e. change (v = pr1 c)%type in e'. assert ( L' := pr2 L ). simpl in L'. apply L'; clear L'. exact (TOeq_to_refl_1 C c (v,, pr1 L) (!e')). } assert (dmax : ∏ (v : carrier W') (W'd : W' (pr1 d)), subtype_inc W'D v ≤ subtype_inc W'D (pr1 d,,W'd)). { intros v W'd'. assert (e : d = subtype_inc W'D (pr1 d,, W'd')). { now apply subtypePath_prop. } induction e. clear W'd'. induction v as [v W'v]. apply (squash_to_hProp W'v); intros [Wv|k]. - assert (L := pr1 (dE v) Wv). unfold upto,lt in L. assert (Q := @tot_nge_to_le (carrier_subset D) (TOSrel D) (TOtot D) _ _ (pr2 L)). now apply(h1'' Q). - use (TOeq_to_refl D). apply subtypePath_prop. simpl. exact (!k @ cd1). } assert (dmax' : ∏ (w : carrier W) (W'd : W' (pr1 d)), subtype_inc W'D (subtype_inc j w) < subtype_inc W'D (pr1 d,,W'd)). { intros w W'd'. assert (e : d = subtype_inc W'D (pr1 d,, W'd')). { now apply subtypePath_prop. } induction e. clear W'd'. induction w as [v Wv]. assert (L := pr1 (dE v) Wv). unfold upto,lt in L. assert (Q := @tot_nge_to_le (carrier_subset D) (TOSrel D) (TOtot D) _ _ (pr2 L)). apply (@tot_nle_iff_gt (carrier_subset D) (TOSrel D) (pr122 D)). split. - now apply (h1'' Q). - intros e. assert (e' := maponpaths pr1 e); clear e. change (v = pr1 d)%type in e'. assert ( L' := pr2 L ). simpl in L'. apply L'; clear L'. exact (TOeq_to_refl_1 D d (v,, pr1 L) (!e')). } split. { intros w' c' W'w' Cc' le. apply (squash_to_hProp W'w'); intros B. induction B as [Ww'|e]. - apply hinhpr, ii1. apply (WCi w' c' Ww' Cc'). now apply (h1'' le). - induction e. induction (lem (pr1 c = c')) as [e|ne]. + induction e. exact W'c. + use j. rewrite ce. exists Cc'. unfold lt. intro le'. apply ne. assert (e : c = (c',,Cc')). { apply (TOanti C). - exact le'. - now apply (h1'' le). } exact (maponpaths pr1 e). } split. { intros w' d' W'w' Dd' le. apply (squash_to_hProp W'w'); intros B. induction B as [Ww'|e]. - apply hinhpr, ii1. apply (WDi w' d' Ww' Dd'). now apply (h1'' le). - induction e. induction (lem (pr1 d = d')) as [e|ne]. + induction e. exact W'd. + use j. rewrite de. exists Dd'. unfold lt. intro le'. apply ne. assert (e : d = (d',,Dd')). { apply (TOanti D). - exact le'. - now apply (h1'' le). } exact (maponpaths pr1 e). } { intros [v W'v] [w W'w]. change (hProptoType (W' v)) in W'v; change (hProptoType (W' w)) in W'w. apply (squash_to_hProp W'v); intros [Wv|Ev]. - apply (squash_to_hProp W'w); intros [Ww|Ew]. + assert (Q := WCD (v,,Wv) (w,,Ww)). change (hProptoType ( (subtype_inc WC (v,, Wv) ≤ subtype_inc WC (w,, Ww)) ⇔ (subtype_inc WD (v,, Wv) ≤ subtype_inc WD (w,, Ww)) )%tosubset) in Q. assert (e : subtype_inc W'C (v,, W'v) = subtype_inc WC (v,, Wv)). { now apply subtypePath_prop. } induction e. assert (e : subtype_inc W'C (w,, W'w) = subtype_inc WC (w,, Ww)). { now apply subtypePath_prop. } induction e. assert (e : subtype_inc W'D (v,, W'v) = subtype_inc WD (v,, Wv)). { now apply subtypePath_prop. } induction e. assert (e : subtype_inc W'D (w,, W'w) = subtype_inc WD (w,, Ww)). { now apply subtypePath_prop. } induction e. exact Q. + induction Ew. apply logeq_if_both_true. * apply cmax. * induction (!cd1). apply dmax. - induction Ev. apply (squash_to_hProp W'w); intros [Ww|Ew]. + apply logeq_if_both_false. * assert (Q := cmax' (w,,Ww) W'v). unfold lt in Q. assert (e : (w,, W'w) = (subtype_inc j (w,, Ww))). { now apply subtypePath_prop. } induction e. exact Q. * assert (Q := dmax' (w,,Ww) W'd). unfold lt in Q. assert (e : (w,, W'w) = (subtype_inc j (w,, Ww))). { now apply subtypePath_prop. } induction e. assert (e : subtype_inc W'D (pr1 c,, W'v) = subtype_inc W'D (pr1 d,, W'd)). { now apply subtypePath_prop. } induction e. exact Q. + induction Ew. apply logeq_if_both_true ; now use TOeq_to_refl_1. } } assert (K := max_common_initial_is_max C D W' ci); fold W in K. assert (Wc : W (pr1 c)). { exact (K (pr1 c) W'c). } assert (L := pr1 (cE (pr1 c)) Wc). induction L as [Cc Q]. change (neg (c ≤ pr1 c,, Cc)) in Q. apply Q; clear Q. simple refine (transportf (λ c', c ≤ c') _ (TOrefl C c)). now apply subtypePath_prop. } change (wosub_comparable C D). unfold wosub_comparable. apply (squash_to_hProp E); clear E; intros E. apply hinhpr. Set Printing Coercions. induction E as [eWC|eWD]. - apply ii1. assert (e : W = C). { now apply hsubtype_univalence. } unfold W in *. clear W. induction (!e); clear e. use tpair. { exact WD. } split. { intros x y le. apply (pr1 (WCD x y)). now apply (h1'' le). } exact WDi. - apply ii2. assert (e : W = D). { now apply hsubtype_univalence. } unfold W in *. clear W. induction (!e); clear e. use tpair. { exact WC. } split. { intros x y le. apply (pr2 (WCD x y)). now apply (h1'' le). } exact WCi. Unset Printing Coercions. Defined. (** ** The proof of the well ordering theorem of Zermelo *) Theorem ZermeloWellOrdering {X:hSet} : AxiomOfChoice ⇒ ∃ R : hrel X, isWellOrder R. (* see http://www.math.illinois.edu/~dan/ShortProofs/WellOrdering.pdf *) Proof. intros ac. assert (lem := AC_to_LEM ac). (* a choice function g allows us to single out the "guided" well ordered subsets of X *) apply (squash_to_hProp (AC_to_choice_fun X ac)); intro g. set (S := guidedFamily g). set (Schain := guided_WOSubset_total g lem). (* we form the union, W, of all the guided (well ordered) subsets of X *) set (W := ⋃ Schain). (* we show W itself is guided, so W is the biggest guided subset of X *) assert (Wguided : is_guided_WOSubset g W). { intros [w Ww]. apply (squash_to_hProp Ww); intros [C Cw]. change (hProptoType (C w)) in Cw. simpl. assert (Q := pr2 C (w,,Cw)); simpl in Q. simple refine (Q @ _); clear Q. assert (CW := chain_union_le S Schain C : C ≼ W). use upto'_eqn. - exact CW. - reflexivity. } (* now we prove W is all of X *) assert (all : ∀ x, W x). { (* ... for if not, we can add a guided element and get a bigger guided subset *) apply (proof_by_contradiction lem); intro n. (* it's not constructive to get an element not in W: *) assert (Q := negforall_to_existsneg _ lem n); clear n. change hfalse. (* zn is the guided element not in W: *) set (znW := g (pr1 W,,Q) : ∑ z : X, ¬ pr1 W z). set (z := pr1 znW). set (nWz := pr2 znW : ¬ pr1 W z). (* make a larger well ordered subset of X by appending z to the top of W *) set (W' := WOSubset_plus_point W z nWz lem). assert (W'z := subtype_plus_has_point W z : W' z). set (j := TOSubset_plus_point_incl W z nWz : W ⊆ W'). set (jmap := subtype_inc j). assert (W'guided : is_guided_WOSubset g W'). { unfold is_guided_WOSubset. intros [x W'x]. change (x = pr1 (g (@upto' X W' (x,, W'x))))%logic. apply (squash_to_hProp W'x); intros [Wx|ezx]. - assert (x_guided := Wguided (x,,Wx)). change (x = pr1 (g (@upto' X W (x,, Wx))))%type in x_guided. simple refine (x_guided @ _); clear x_guided. use upto'_eqn. + (* show W ≼ W'; abstract later *) assert (WW' := TOSubset_plus_point_le W z nWz). induction WW' as [WW' comp]. exists WW'. split. * exact comp. * intros w w' Ww W'w' le. simple refine (TOSubset_plus_point_initial W z nWz w w' Ww W'w' _). now apply (h1'' le). + reflexivity. - induction ezx. change (pr1 (g (pr1 W,, Q)) = pr1 (g (@upto' X W' (z,, W'x)))). assert (e : (pr1 W,, Q) = @upto' X W' (z,, W'x)). { apply subtypePath_prop. apply (invmap (hsubtype_univalence _ _)). intros y. change (W y ⇔ @upto X W' (z,, W'x) y). split. - intros Wy. (* show that the element y in W is less than z *) exists (j y Wy). unfold lt. intros le. induction (ishinh_irrel (ii2 (idpath z)) W'x). change empty in le. exact le. - intros [W'y yz]. (* show that if y in W' is less than z, then it's in W *) apply (squash_to_hProp W'y); intros [Wy|ezy]. + exact Wy. (* it was in W, anyway *) + induction ezy. (* y = x, and we know z hSet := pr1. Coercion WellOrderedSet_to_hSet : WellOrderedSet >-> hSet. Declare Scope woset. Delimit Scope woset with woset. Local Open Scope woset. Definition WOrel (X:WellOrderedSet) : hrel X := pr12 X. Notation "x ≤ y" := (WOrel _ x y) : woset. Definition WOlt {X:WellOrderedSet} (x y : X) := ¬ (y ≤ x). Notation "x < y" := (WOlt x y) : woset. Lemma isaprop_theSmallest {X : hSet} (R : hrel X) (total : isTotalOrder R) (S : hsubtype X) : isaprop (∑ s:X, hProp_to_hSet (S s ∧ ∀ t:X, S t ⇒ R s t)). Proof. induction total as [[po anti] tot]. apply invproofirrelevance; intros s t. apply subtypePath_prop. induction s as [x i], t as [y j], i as [I i], j as [J j]. change (x=y)%logic. apply (squash_to_hProp (tot x y)); intros [c|c]. { apply anti. { exact c. } { exact (j x I). } } { apply anti. { exact (i y J). } { exact c. } } Defined. (** Accessor functions *) Definition WO_isTotalOrder (X : WellOrderedSet) : isTotalOrder (WOrel X) := pr122 X. Definition WO_isrefl (X : WellOrderedSet) : isrefl (WOrel X) := pr211 (WO_isTotalOrder X). Definition WO_istrans (X : WellOrderedSet) : istrans (WOrel X) := pr111 (WO_isTotalOrder X). Definition WO_istotal (X : WellOrderedSet) : istotal (WOrel X) := pr2 (WO_isTotalOrder X). Definition WO_isantisymm (X : WellOrderedSet) : isantisymm (WOrel X) := pr21 (WO_isTotalOrder X). Definition WO_hasSmallest (X : WellOrderedSet) : hasSmallest (WOrel X) := pr222 X. (** Lemmas about WOlt *) Lemma WOlt_istrans (X : WellOrderedSet) : istrans (@WOlt X). Proof. intros x y z H1 H2 H3; simpl in *. apply (@squash_to_hProp _ (_,,isapropempty) (WO_istotal X y z)); intros [H|H]; simpl. - now apply H1, (WO_istrans X y z x H H3). - now apply H2. Qed. Lemma WOlt_isirrefl (X : WellOrderedSet) : isirrefl (@WOlt X). Proof. now intros x; simpl; intros H; apply H, WO_isrefl. Qed. (** Equivalent definition (assuming decidable equality) of the WOlt relation *) Definition WOlt' (X : WellOrderedSet) (x y : X) : hProp. Proof. exists ((x ≤ y) × (x != y))%type. abstract (now apply isapropdirprod; [ apply propproperty | apply isapropneg ]). Defined. Lemma WOlt'_to_WOlt (X : WellOrderedSet) (x y : X) : WOlt' X x y → x < y. Proof. intros [H1 H2] H3. now use H2; apply (WO_isantisymm X x y H1 H3). Qed. (** One direction of the equivalence requires decidable equality *) Lemma WOlt_to_WOlt' (X : WellOrderedSet) (hX : isdeceq X) (x y : X) : x < y → WOlt' X x y. Proof. intros H. apply (squash_to_hProp (WO_istotal X x y)); intros [Hle|Hle]; simpl. - induction (hX x y) as [Heq|Hneq]. + rewrite Heq in H. induction (WOlt_isirrefl _ _ H). + now split. - induction (H Hle). Qed. (** Assuming decidable equality we can prove that < is a trichotomy *) Lemma WOlt_trich (X : WellOrderedSet) (hX : isdeceq X) (x y : X) : y < x ∨ x = y ∨ x < y. Proof. induction (hX x y) as [Heq|Hneq]. - now apply hinhpr, inr, hinhpr, inl. - apply (squash_to_hProp (WO_istotal X x y)); intros [Hle|Hle]. + now apply hinhpr, inr, hinhpr, inr, WOlt'_to_WOlt. + apply hinhpr, inl, WOlt'_to_WOlt; split; trivial. now intros H; apply Hneq. Qed. Definition theSmallest {X : WellOrderedSet} (S : hsubtype X) : hProp := (∃ s, S s) ⇒ make_hProp (∑ s:X, S s ∧ ∀ t:X, S t ⇒ WOrel X s t)%type (isaprop_theSmallest _ (WO_isTotalOrder X) S). (** actually get the smallest element: *) Lemma WO_theSmallest {X : WellOrderedSet} (S : hsubtype X) : theSmallest S. Proof. intros ne. apply (squash_to_hProp (WO_hasSmallest X S ne)). intro c. exact c. Defined. Lemma WO_theUniqueSmallest {X : WellOrderedSet} (S : hsubtype X) : (∃ s, S s) ⇒ ∃! s:X, S s ∧ ∀ t:X, S t ⇒ s ≤ t. Proof. intros ne. apply iscontraprop1. - apply isaprop_theSmallest. apply WO_isTotalOrder. - exact (WO_theSmallest S ne). Defined. (* Close these for now *) Local Close Scope set. Local Close Scope prop. (** Functions of well-ordered sets that preserve the ordering and initial segments *) Definition iswofun {X Y : WellOrderedSet} (f : X → Y) : UU := (iscomprelrelfun (WOrel X) (WOrel Y) f) × (∏ (x : X) (y : Y), y < f x → ∃ (z : X), z < x × f z = y). Lemma isaprop_iswofun {X Y : WellOrderedSet} (f : X → Y) : isaprop (iswofun f). Proof. intros h; apply isapropdirprod; do 3 (apply impred_isaprop; intros). - now apply propproperty. - now apply isapropishinh. Qed. Definition wofun (X Y : WellOrderedSet) : UU := ∑ (f : X -> Y), iswofun f. Definition pr1wofun (X Y : WellOrderedSet) : wofun X Y → (X → Y) := @pr1 _ _. Lemma wofun_eq {X Y : WellOrderedSet} {f g : wofun X Y} : pr1 f = pr1 g → f = g. Proof. intros Heq. apply subtypePath; trivial. now intros h; apply isaprop_iswofun. Qed. Lemma iswofun_idfun {X : WellOrderedSet} : iswofun (idfun X). Proof. split. - now intros x. - intros x y hxy. now apply hinhpr; exists y. Qed. Lemma iswofun_funcomp {X Y Z : WellOrderedSet} (f : wofun X Y) (g : wofun Y Z) : iswofun (pr1 g ∘ pr1 f). Proof. induction f as [f [h1f h2f]]. induction g as [g [h1g h2g]]. split. - intros x y hxy. exact (h1g _ _ (h1f _ _ hxy)). - intros x z hf. apply (squash_to_hProp (h2g (f x) z hf)); intros [y [h1y h2y]]. apply (squash_to_hProp (h2f x y h1y)); intros [x' [h1x' h2x']]. apply hinhpr; exists x'; cbn. now rewrite h2x'. Qed. Local Open Scope set. Local Open Scope prop. (** The empty set is well-ordered *) Definition empty_woset : WellOrderedSet. Proof. exists (_,,isasetempty). use tpair. - intros []. - abstract (repeat split; try (now intros []); now intros T t'; apply (squash_to_hProp t'); intros [[]]). Defined. (** The unit set is well-ordered *) Definition unit_woset : WellOrderedSet. Proof. exists (_,,isasetunit). use tpair. - intros x y. exists (x = y). abstract (apply isapropifcontr, isapropunit). - repeat split. + now intros x y z []. + now intros x. + intros [] [] H H2. now apply H2, inl. + intros T t'; apply (squash_to_hProp t'); clear t'; intros [[] H]. apply hinhpr; exists tt. now split; [|intros []]. Defined. Lemma isaset_WellOrderedSet : isaset WellOrderedSet. Proof. (* First show that an order preserving equivalence f : X ≃ Y of well ordered sets has the property that for any x, f x is least element greater than f y for every y < x. Now given also an order preserving f' : X ≃ Y, take the smallest x where f x ≠ f y. Since they agree on previous values, they agree at x, too, using the previous statement. *) Abort. (* ** Transfinite recursion *) (* We should be able to prove Zorn's lemma from transfinite recursion, or, better yet, make it unneeded. *) Theorem transfiniteRecursion {X:WellOrderedSet} (P : X -> Type) : LEM -> (∏ x:X, (∏ y, y P y) -> P x) -> (∏ x, P x). Proof. intros g. (* Consider subsets C of X that are initial segments for the ordering, each of which is equipped with a section f of P and a proof of ∏ x ∈ C, g x = f x (λ y, g y). One may say that f is guided by g. Then two pairs (C,f), (C',f') agree on their common intersection, which is C or C', and thus the union U of all their graphs is a maximal guided function. If U were a proper subset, then its upper bound could be added to U, contradiction, so U = X. *) Abort. Lemma bigSet (X:Type) : (∑ Y:hSet, ∏ f : Y -> X, ¬ isincl f)%type. Proof. (* This lemma is useful in arguments by contradiction, where one uses transfinite recursion to define an injective function f, after first equipping Y with a well ordering. To prove it, let Y be the set of subsets of π_0 (X). *) Abort. UniMath-20231010/UniMath/Combinatorics/ZFstructures.v000066400000000000000000000715771451125700300223430ustar00rootroot00000000000000(**** ZF Structures Dimitris Tsementzis (@dimtsem), Feb. 2018 Main contents of this file: - A definition of "ZF structures" as well-founded rooted trees with no automorphisms plus some extra properties [ZFS] - A proof that the type [ZFS] of ZF structures is an h-set [isaset_ZFS] - A definition of the elementhood relation for ZF structures [ZFS_elementof] Table of Contents: (1) Auxilliary Lemmas (2) Basic Definitions (3) Definition of ZFS (4) The Elementhood Relation A textbook reference for some of the material in this file can be found in: - Mac Lane and Moerdijk, "Sheaves in Geometry and Logic", VI.10 ****) Require Export UniMath.Foundations.PartB. Require Export UniMath.Foundations.Propositions. Require Export UniMath.Foundations.Sets. Require Export UniMath.Foundations.HLevels. Require Export UniMath.Combinatorics.WellOrderedSets. Require Export UniMath.Combinatorics.OrderedSets. Require Export UniMath.MoreFoundations.DecidablePropositions. Require Export UniMath.MoreFoundations.Propositions. Local Open Scope logic. Local Open Scope type. (*** Auxilliary Lemmas ***) (** Contents **) (** -Some auxilliary lemmas which which are useful stated in this form for this file. **) Lemma contr_to_pr1contr (X : UU) (P : X → hProp) (T : ∑ x, P x) (C : iscontr (T = T)) : iscontr ((pr1 T) = (pr1 T)). Proof. exact (@isofhlevelweqf 0 (T = T) (pr1 T = pr1 T) (@total2_paths_hProp_equiv _ _ T T) C). Qed. Lemma pr1contr_to_contr (X : UU) (P : X → hProp) (T : ∑ x, P x) (C : iscontr (pr1 T = pr1 T)) : iscontr (T = T). Proof. exact (@isofhlevelweqb 0 (T = T) (pr1 T = pr1 T) (@total2_paths_hProp_equiv _ _ T T) C). Qed. Lemma substructure_univalence (S : UU) (iso : S → S → UU) (u : ∏ (X Y : S), (X = Y) ≃ (iso X Y)) (Q : S → hProp) (A B : (∑ (X : S), Q X)) : (A = B) ≃ (iso (pr1 A) (pr1 B)). Proof. intermediate_weq (pr1 A = pr1 B). apply (total2_paths_hProp_equiv Q A B). apply (u (pr1 A) (pr1 B)). Qed. (*** End of Auxilliary Lemmas ***) (*** Basic Definitions ***) (** Contents **) (** -Transitive reflexive rooted graph [TRRGraph] -Tree [Tree] -Up and Down Well-founded tree [Tree_isWellFounded] -Rigid tree (no non-trivial automorphisms) [isrigid] -ZF structures as rigid well-founded trees [ZFStructures] -Proof that ZFStructures is an h-set [isaset_ZFStruc] **) (** The definition of transitive reflexive rooted graphs [TRRGraph] **) Definition PointedGraph := ∑ (V : hSet) (E : hrel V), V. Definition isaroot {V : hSet} (E : hrel V) (r : V) : UU := (∏ w : V, E r w). Lemma isaprop_isaroot {V : hSet} (E : hrel V) (r : V) : isaprop (isaroot E r). Proof. repeat (apply impred ; intros). apply propproperty. Qed. Definition isTRR (V : hSet) (E : hrel V) (r : V) : UU := isrefl E × istrans E × isaroot E r. Lemma isaprop_isTRR (V : hSet) (E : hrel V) (r : V) : isaprop (isTRR V E r). Proof. apply isapropdirprod. - apply (isaprop_isrefl E). - apply isapropdirprod. -- apply (isaprop_istrans E). -- apply (isaprop_isaroot E r). Qed. Definition TRRGraphData (V : hSet) : UU := ∑ (E : hrel V) (r : V), isTRR V E r. Lemma isaset_TRRGraphData (V : hSet) : isaset (TRRGraphData V). Proof. unfold TRRGraphData. apply (isofhleveltotal2 2). - apply isaset_hrel. - intros x. apply (isofhleveltotal2 2). -- apply setproperty. -- intros. apply hlevelntosn. apply isaprop_isTRR. Qed. Definition TRRGraph : UU := ∑ (V : hSet), TRRGraphData V. Definition TRRG_edgerel (G : TRRGraph) : hrel (pr1 G) := pr12 G. Local Notation "x ≤ y" := (TRRG_edgerel _ x y)(at level 70). Definition TRRG_root (G : TRRGraph) : pr1 G := pr122 G. Definition TRRG_transitivity (G : TRRGraph) : istrans (TRRG_edgerel G) := pr12 (pr222 G). Definition selfedge (G : TRRGraph) (x : pr1 G) : pr1 (pr2 G) x x := (pr1 (pr2 (pr2 (pr2 G))) x). (** Definition of [TRRGraph] homomorphisms [isTRRGhomo], isomorphisms [TRRGraphiso], and a proof that isomorphisms are equivalent to identities [TRRGraph_univalence] **) Definition isTRRGhomo {G H : TRRGraph} (f : pr1 G → pr1 H) : UU := (∏ (x y : pr1 G), (x ≤ y) <-> (f x ≤ f y)) × (f (TRRG_root G) = TRRG_root H). Lemma isaprop_isTRRGhomo {G H : TRRGraph} (f : pr1 G → pr1 H) : isaprop (isTRRGhomo f). Proof. apply isapropdirprod. - repeat (apply impred ; intros). apply isapropdirprod. -- repeat (apply impred; intros; apply propproperty). -- repeat (apply impred; intros; apply propproperty). - apply setproperty. Qed. Lemma TRRGhomo_frompath (X Y : hSet) (G : TRRGraphData X) (H : TRRGraphData Y) (p : X = Y) : transportf (λ x : hSet, TRRGraphData x) p G = H → @isTRRGhomo (X ,, G) (Y ,, H) (pr1weq (hSet_univalence _ _ p)). Proof. simpl. induction p. simpl. unfold isTRRGhomo. intros q. split. - intros x y. rewrite -> idpath_transportf in q. split. rewrite -> q. intros P ; apply P. rewrite -> q. intros P ; apply P. - rewrite -> idpath_transportf in q. induction q. reflexivity. Qed. (* The lemma [helper] below is needed because of some buggy Coq behaviour - perhaps it can be eliminated with a different proof *) Local Lemma helper (X : hSet) (E E' : X → X → hProp) (r r' : X) (isE : isTRR X E r) (isE' : isTRR X E' r') (q : E = E') (σ : r = r') : transportf (λ x : X → X → hProp, ∑ r : X, isTRR X x r) q (r ,, isE) = (r' ,, isE'). Proof. induction q. rewrite idpath_transportf. apply total2_paths_equiv. exists σ. simpl. apply (isaprop_isTRR X E r'). Qed. Lemma TRRGhomo_topath (X Y : hSet) (G : TRRGraphData X) (H : TRRGraphData Y) (p : X = Y) : @isTRRGhomo (X ,, G) (Y ,, H) (pr1weq (hSet_univalence _ _ p)) → transportf (λ x : hSet, TRRGraphData x) p G = H. Proof. induction p. rewrite -> idpath_transportf. intros P. unfold isTRRGhomo in P. simpl in P. destruct P as [π σ]. assert (q : pr1 G = pr1 H). { use funextfun. unfold homot. intros x. use funextfun. unfold homot. intros y. apply (hPropUnivalence (pr1 G x y) (pr1 H x y) (pr1 (π x y)) (pr2 (π x y))). } apply total2_paths_equiv. exists q. apply (helper X (pr1 G) (pr1 H) (pr12 G) (pr12 H) _ _ q σ). Qed. Definition TRRGraphiso (G H : TRRGraph) : UU := ∑ (f : pr1 G ≃ pr1 H), isTRRGhomo f. Local Notation "G ≅ H" := (TRRGraphiso G H). Definition id_TRRGraphiso (G : TRRGraph) : TRRGraphiso G G. Proof. exists (idweq (pr1 G)). split. - intros. use isrefl_logeq. - reflexivity. Defined. Definition TRRGraph_univalence_map (G H : TRRGraph) : (G = H) → (G ≅ H). Proof. intro p. induction p. exact (id_TRRGraphiso G). Defined. Definition TRRGraph_univalence_weq1 (G H : TRRGraph) : G = H ≃ G ╝ H := total2_paths_equiv _ G H. Definition TRRGraph_univalence_weq2 (G H : TRRGraph) : G ╝ H ≃ G ≅ H. Proof. use weqbandf. - exact (hSet_univalence (pr1 G) (pr1 H)). - intro p. simpl. use weqimplimpl. * intros q. exact (TRRGhomo_frompath (pr1 G) (pr1 H) (pr2 G) (pr2 H) p q). * intros q. exact (TRRGhomo_topath (pr1 G) (pr1 H) (pr2 G) (pr2 H) p q). * exact (isaset_TRRGraphData (pr1 H) ((p # pr2 G)%transport) (pr2 H)). * exact (isaprop_isTRRGhomo (hSet_univalence_map (pr1 G) (pr1 H) p)). Defined. Lemma TRRGraph_univalence_weq2_idpath (G : TRRGraph) : TRRGraph_univalence_weq2 G G (idpath (pr1 G) ,, idpath (((idpath (pr1 G)) # pr2 G)%transport)) = id_TRRGraphiso G. Proof. apply total2_paths_equiv. exists (idpath (idweq (pr1 G))). apply isaprop_isTRRGhomo. Qed. Lemma TRRGraph_univalence_weq1_idpath (G : TRRGraph) : ((TRRGraph_univalence_weq1 G G) (idpath G)) = (idpath (pr1 G) ,, idpath (((idpath (pr1 G)) # pr2 G)%transport)). Proof. apply total2_paths_equiv. exists (idpath (idpath (pr1 G))). reflexivity. Qed. Theorem isweq_TRRGraph_univalence_map (G H : TRRGraph) : isweq (TRRGraph_univalence_map G H). Proof. use isweqhomot. - exact (weqcomp (TRRGraph_univalence_weq1 G H) (TRRGraph_univalence_weq2 G H)). - intros e. induction e. use (pathscomp0 weqcomp_to_funcomp_app). rewrite TRRGraph_univalence_weq1_idpath. rewrite TRRGraph_univalence_weq2_idpath. reflexivity. - use weqproperty. Qed. Definition TRRGraph_univalence (G H : TRRGraph) : (G = H) ≃ (G ≅ H). Proof. use make_weq. - exact (TRRGraph_univalence_map G H). - exact (isweq_TRRGraph_univalence_map G H). Defined. Lemma TRRGraph_univalence_compute (G H : TRRGraph) : pr1 (TRRGraph_univalence G H) = TRRGraph_univalence_map G H. Proof. reflexivity. Qed. (** Definition of trees as a subtype [Tree] of [TRRGraph] and proof of univalence for trees [Tree_univalence] **) Definition DownwardClosure {G : TRRGraph} (x : pr1 G) : UU := ∑ y : pr1 G, y ≤ x. Definition antisymmetric {G :TRRGraph} (y z : pr1 G) : UU := (y ≤ z) × (z ≤ y) → (z = y). Definition total {G : TRRGraph} (y z : pr1 G) : hProp := (y ≤ z) ∨ (z ≤ y). Definition isatree (G : TRRGraph) : UU := ∏ (x : pr1 G) (y z : DownwardClosure x), antisymmetric (pr1 y) (pr1 z) × total (pr1 y) (pr1 z). Lemma isaprop_isatree (G : TRRGraph) : isaprop (isatree G). Proof. apply impred. intros t ; apply impred. intros x ; apply impred. intros y ; apply isapropdirprod. - apply impred. intros P. apply setproperty. - apply propproperty. Qed. Definition Tree : UU := ∑ G : TRRGraph, isatree G. Definition Tree_iso (T1 T2 : Tree) : UU := pr1 T1 ≅ pr1 T2. Theorem Tree_univalence (T1 T2 : Tree) : (T1 = T2) ≃ (Tree_iso T1 T2). Proof. set (P := λ G, λ H, TRRGraph_univalence G H). set (Q := λ G, (isatree G ,, isaprop_isatree G)). apply (substructure_univalence _ _ P Q T1 T2). Qed. (** Definition of branches ("upward closures") for [Tree]s as a tree [Up x] for a point x of T **) Definition Upw_underlying (T : Tree) (x : pr11 T) := ∑ (y : pr11 T), x ≤ y. Lemma isaset_Upw_underlying (T : Tree) (x : pr11 T) : isaset (Upw_underlying T x). Proof. apply isaset_total2. apply setproperty. intros y. apply hProp_to_hSet. Qed. Definition Upw (T : Tree) (x : pr11 T) : hSet := (∑ (y : pr11 T), pr121 T x y) ,, (isaset_Upw_underlying T x). Definition Upw_E (T : Tree) (x : pr11 T) (y z : Upw T x) : hProp := pr121 T (pr1 y) (pr1 z). Definition Upw_to_PointedGraph (T : Tree) (x : pr11 T) : PointedGraph := Upw T x ,, Upw_E T x ,, (x ,, selfedge (pr1 T) x). Lemma Upw_reflexive (T : Tree) (x : pr11 T) : ∏ (y : pr1 (Upw_to_PointedGraph T x)), pr12 (Upw_to_PointedGraph T x) y y. Proof. intros y. simpl. unfold Upw_E. exact (selfedge (pr1 T) (pr1 y)). Qed. Lemma Upw_transitive (T : Tree) (x : pr11 T) : ∏ y z w, (Upw_E T x) y z → (Upw_E T x) z w → (Upw_E T x) y w. Proof. intros y z w P Q. unfold Upw_E in P. simpl in P. exact (TRRG_transitivity (pr1 T) (pr1 y) (pr1 z) (pr1 w) P Q). Qed. Lemma Upw_rooted (T : Tree) (x : pr11 T) : ∏ y, (Upw_E T x) (x ,, selfedge (pr1 T) x) y. Proof. intros y. exact (pr2 y). Qed. Definition Upw_to_TRRGraph (T : Tree) (x : pr11 T) : TRRGraph := pr1 (Upw_to_PointedGraph T x) ,, pr12 (Upw_to_PointedGraph T x) ,, pr22 (Upw_to_PointedGraph T x) ,, Upw_reflexive T x ,, Upw_transitive T x ,, Upw_rooted T x. Lemma isatree_Upw (T : Tree) (x : pr11 T) : isatree (Upw_to_TRRGraph T x). Proof. unfold isatree. intros a. intros y z. simpl. set (zzz := ((pr1 (pr1 z)))). set (zz := (pr1 z)). set (yyy := ((pr1 (pr1 y)))). set (yy := (pr1 y)). assert (Eya : pr121 T yyy (pr1 a)). { unfold DownwardClosure in y. destruct y as [y σ]. simpl. apply σ. } assert (Eza : pr121 T zzz (pr1 a)). { unfold DownwardClosure in z. destruct z as [z σ]. simpl. apply σ. } split. - simpl. unfold antisymmetric. intros X. destruct X as [yz zy]. assert (L1 : zzz = yyy). { simpl in a. apply (pr1 (pr2 (T) (pr1 a) (yyy ,, Eya) (zzz ,, Eza)) (yz ,, zy)). } assert (p : pr1 zz = pr1 yy). { apply L1. } unfold Upw_to_TRRGraph in zz. unfold Upw_to_TRRGraph in yy. simpl in zz. simpl in yy. assert (q : pr2 zz = transportb (λ w, pr121 T x w) p (pr2 yy)). { apply proofirrelevance. apply (pr2 (pr121 T x (pr1 zz))). } apply (total2_paths_b p q). - assert (L : pr121 T yyy zzz ∨ pr121 T zzz yyy). { apply (pr2 ((pr2 (T)) (pr1 a) (yyy ,, Eya) (zzz ,, Eza))). } apply L. Qed. Definition Up {T : Tree} (x : pr11 T) : Tree := (Upw_to_TRRGraph T x ,, isatree_Upw T x). (** Definition of rigid [isrigid] and superrigid [issuperrigid] trees **) Definition isrigid (T : Tree) : UU := iscontr (T = T). Lemma isaprop_isrigid (T : Tree) : isaprop (isrigid T). Proof. unfold isrigid. apply isapropiscontr. Qed. Definition issuperrigid (T : Tree) : UU := isrigid T × (∏ (x : pr11 T), isrigid (Up x)). Lemma isaprop_issuperrigid (T : Tree) : isaprop (issuperrigid T). Proof. unfold issuperrigid. apply isapropdirprod. apply isaprop_isrigid. apply impred. intros t. apply isaprop_isrigid. Qed. (** Definition of bi-well-founded trees (well-founded both "up" and "down") [Tree_isWellFounded] **) Definition isWellFoundedUp (T : Tree) : hProp := hasSmallest (pr121 T). Definition hasLargest {X : UU} (R : hrel X) : hProp := ∀ S : hsubtype X, (∃ x, S x) ⇒ ∃ x:X, S x ∧ ∀ y:X, S y ⇒ R y x. Definition isWellFoundedDown (T : Tree) := hasLargest (pr121 T). Definition Tree_isWellFounded (T : Tree) := (isWellFoundedUp T) × (isWellFoundedDown T). Lemma isaprop_Tree_isWellFounded (T : Tree) : isaprop (Tree_isWellFounded T). Proof. apply isapropdirprod. apply propproperty. apply propproperty. Qed. (** The definition of pre-ZF structures [preZFS]. **) (** [preZFS] is classically equivalent to the [ZFS] we define below but, as far as we can tell, constructively inequivalent. **) Definition ispreZFS (T : Tree) : UU := (Tree_isWellFounded T) × (issuperrigid T). Lemma isaprop_ispreZFS (T : Tree) : isaprop (ispreZFS T). Proof. apply isapropdirprod. apply (isaprop_Tree_isWellFounded T). apply (isaprop_issuperrigid T). Qed. Definition preZFS : UU := ∑ (T : Tree), ispreZFS T. Definition Ve (X : preZFS) : hSet := pr111 X. Coercion Ve : preZFS >-> hSet. Definition Ed (X : preZFS) : (Ve X) → (Ve X) → hProp := pr1 (pr2 (pr1 (pr1 X))). Definition root (X : preZFS) : Ve X := pr1 (pr2 (pr2 (pr1 (pr1 X)))). Lemma preZFS_isrigid (X : preZFS) : iscontr (X = X). Proof. apply (pr1contr_to_contr _ (λ x, (ispreZFS x ,, isaprop_ispreZFS x)) X). exact (pr122 X). Qed. Theorem isaset_preZFS : isaset preZFS. Proof. simpl. unfold isaset. unfold isaprop. simpl. intros x y p. induction p. intros q. apply (hlevelntosn 0 (x = x) (preZFS_isrigid x) (idpath x) q). Qed. Definition preZFS_iso (X Y : preZFS) : UU := Tree_iso (pr1 X) (pr1 Y). Theorem preZFS_univalence (X Y : preZFS) : (X = Y) ≃ (preZFS_iso X Y). Proof. set (P := λ x, λ y, Tree_univalence x y). set (Q := λ x, (ispreZFS x ,, isaprop_ispreZFS x)). exact (substructure_univalence _ _ P Q X Y). Qed. (*** End of Basic Definitions ***) (*** Definition of ZFS ***) (** Contents **) (** -Upward Closure ("Branch") of a node x in a pre-ZF structure T -Proof that it is a pre-ZF structure [Branch] **) Definition preZFS_Branch (T : preZFS) (x : T) : Tree := Up x. Definition preZFS_Branch_hsubtype_tohsubtype (T : preZFS) (x : T) (S : hsubtype (pr11 (preZFS_Branch T x))) : hsubtype (pr111 T) := λ t, ∃ e, S (t ,, e). (** REMARK : The definition [preZFS_Branch_hsubtype_tohsubtype] probably does not need to be truncated. One can define it without truncation and prove the lemmas that it is a proposition. **) Definition hsubtype_to_preZFS_Branch_hsubtype (T : preZFS) (x : T) (S : hsubtype (pr111 T)) : hsubtype (pr11 (preZFS_Branch T x)) := λ z, S (pr1 z) ∧ Ed T x (pr1 z). Lemma Branch_to_subtype (T : preZFS) (x : T) (S : hsubtype (pr11 (preZFS_Branch T x))) : hsubtype_to_preZFS_Branch_hsubtype T x (preZFS_Branch_hsubtype_tohsubtype T x S) = S. Proof. set (H := (hsubtype_to_preZFS_Branch_hsubtype T x (preZFS_Branch_hsubtype_tohsubtype T x S))). apply (funextfunPreliminaryUAH univalenceAxiom (pr11 (preZFS_Branch T x)) hProp H S). unfold homot. intros y. unfold preZFS_Branch_hsubtype_tohsubtype. unfold hsubtype_to_preZFS_Branch_hsubtype. simpl. assert (ES : ((∃ e : Ed T x (pr1 y), S (pr1 y,, e)) ∧ Ed T x (pr1 y)) -> S y). { intros X. destruct X as [ε e]. apply (ε (S y)). intros X. destruct y. destruct X as [y z]. simpl in z. simpl in y. assert ( p : y = pr2 ). apply propproperty. rewrite <- p. apply z. } assert (SE : ((∃ e : Ed T x (pr1 y), S (pr1 y,, e)) ∧ Ed T x (pr1 y)) <- S y). { intros X. simpl. unfold ishinh_UU. split. - intros P Q. apply Q. exists (pr2 y). apply X. - apply (pr2 y). } apply (hPropUnivalence ((∃ e : Ed T x (pr1 y), S (pr1 y,, e)) ∧ Ed T x (pr1 y)) (S y) ES SE). Qed. Lemma fromBranch_hsubtype {T : preZFS} {x : T} {S : hsubtype (pr11 (preZFS_Branch T x))} {t :pr11 (preZFS_Branch T x)} (s : S t) : preZFS_Branch_hsubtype_tohsubtype T x S (pr1 t). Proof. unfold preZFS_Branch_hsubtype_tohsubtype. simpl. unfold ishinh_UU. intros P X. apply X. exists (pr2 t). apply s. Qed. Lemma toBranch_hsubtype {T : preZFS} {x : T} {S : hsubtype (pr111 T)} {t : pr111 T} (e : Ed T x t) (s : S t) : hsubtype_to_preZFS_Branch_hsubtype T x S (t ,, e). Proof. unfold hsubtype_to_preZFS_Branch_hsubtype. simpl. split. apply s. apply e. Qed. Lemma preZFS_Branch_isWellFounded (T : preZFS) (x : T) : Tree_isWellFounded (preZFS_Branch T x). Proof. unfold Tree_isWellFounded. split. - unfold isWellFoundedUp. intros S. set (SS := preZFS_Branch_hsubtype_tohsubtype T x S). intros X. assert (wfunder : Tree_isWellFounded (pr1 T)). { apply (pr12 T). } unfold Tree_isWellFounded in wfunder. unfold isWellFoundedUp in wfunder. unfold hasSmallest in wfunder. apply pr1 in wfunder. simpl in wfunder. set (L1 := wfunder SS). assert (L2 : (∃ x : pr11 (preZFS_Branch T x), S x) → ishinh_UU (∑ y : pr111 T, SS y)). { intros P. simpl in P. apply (P (ishinh (∑ y : pr111 T, SS y))). intros X1. destruct X1 as [te s]. destruct te as [t e]. simpl. unfold ishinh_UU. intros Q X1. apply X1. exists t. apply (fromBranch_hsubtype s). } apply L2 in X. apply L1 in X. apply (X (∃ x0 : pr11 (preZFS_Branch T x), S x0 ∧ (∀ y : pr11 (preZFS_Branch T x), S y ⇒ pr121 (preZFS_Branch T x) x0 y))). intros Y. destruct Y as [t [s π]]. assert (e : Ed T x t). { unfold SS in s. unfold preZFS_Branch_hsubtype_tohsubtype in s. apply (s (Ed T x t)). intros Y. destruct Y as [τ ξ]. apply τ. } assert (L4 : S (t ,, e)). { rewrite <- (Branch_to_subtype T x S). apply (toBranch_hsubtype e s). } simpl. unfold ishinh_UU. intros P Y. apply Y. exists (t ,, e). split. -- apply L4. -- intros xx Q. unfold Upw_E. simpl. apply π. unfold SS. simpl. unfold ishinh_UU. intros R Z. apply Z. exists (pr2 xx). apply Q. - unfold isWellFoundedDown. intros S. set (SS := preZFS_Branch_hsubtype_tohsubtype T x S). intros X. set (wfunder := pr212 T). unfold isWellFoundedDown in wfunder. unfold hasLargest in wfunder. simpl in wfunder. set (L1 := wfunder SS). assert (L2 : (∃ x : pr11 (preZFS_Branch T x), S x) → ishinh_UU (∑ y : pr111 T, SS y)). { intros Y. simpl in Y. apply (Y (ishinh (∑ y : pr111 T, SS y))). intros Z. destruct Z as [te s]. destruct te as [t e]. simpl. unfold ishinh_UU. intros P W. apply W. exists t. apply (fromBranch_hsubtype s). } apply L2 in X. apply L1 in X. apply (X (∃ xx : pr11 (preZFS_Branch T x), S xx ∧ (∀ y : pr11 (preZFS_Branch T x), S y ⇒ pr121 (preZFS_Branch T x) y xx))). intros Y. destruct Y as [t [s π]]. assert (e : Ed T x t). { unfold SS in s. unfold preZFS_Branch_hsubtype_tohsubtype in s. apply (s (Ed T x t)). intros Y. destruct Y as [τ ξ]. apply τ. } assert (L4 : S (t ,, e)). { rewrite <- (Branch_to_subtype T x S). apply (toBranch_hsubtype e s). } simpl. unfold ishinh_UU. intros P Y. apply Y. exists (t ,, e). split. -- apply L4. -- intros xx Q. unfold Upw_E. simpl. apply π. unfold SS. simpl. unfold ishinh_UU. intros R Z. apply Z. exists (pr2 xx). apply Q. Qed. Lemma iscontrauto_Tree_TRRGraph (T : Tree) : isrigid T → iscontr ((pr1 T) = (pr1 T)). Proof. apply (@contr_to_pr1contr _ (λ x, (isatree x ,, isaprop_isatree x)) T). Qed. Definition Up_to_Up (T : Tree) (x : pr11 T) (y : pr11 (Up x)) : pr1 (Upw_to_TRRGraph T (pr1 y)) → pr1 (Upw_to_TRRGraph (Up x) y). Proof. simpl. intros X. induction X as [t π]. induction y as [y σ]. exact ((t ,, ((pr122 (pr221 T)) x y t σ π)) ,, π). Defined. Definition Up_to_Up_inv (T : Tree) (x : pr11 T) (y : pr11 (Up x)) : pr1 (Upw_to_TRRGraph (Up x) y) → pr1 (Upw_to_TRRGraph T (pr1 y)). Proof. simpl. intros X. induction X as [t π]. induction y as [y σ]. induction t as [tt θ]. simpl. unfold Upw_E in π. simpl in π. exact (tt ,, π). Defined. Lemma isweq_Up_to_Up (T : Tree) (x : pr11 T) (y : pr11 (Up x)): isweq (Up_to_Up T x y). Proof. set (f := Up_to_Up T x y). set (g := Up_to_Up_inv T x y). assert (L : ∏ x, f (g x) = x). { intros z. unfold g ; unfold Up_to_Up_inv. unfold f ; unfold Up_to_Up. destruct z as [z π]. apply total2_paths_equiv. assert (H : (pr1 z,, pr122 (pr221 T) x (pr1 y) (pr1 z) (pr2 y) π) = z). { apply total2_paths_equiv. exists (idpath (pr1 z)). apply propproperty. } exists H. apply propproperty. } assert (LL : ∏ x, g (f x) = x). { intros z. unfold g ; unfold Up_to_Up_inv. unfold f ; unfold Up_to_Up. reflexivity. } apply (@weq_iso _ _ _ _ LL L). Qed. Lemma isTRRGhomo_Up_to_Up (T : Tree) (x : pr11 T) (y : pr11 (Up x)) : isTRRGhomo (Up_to_Up T x y). Proof. split. - intros xx yy. simpl. split. -- intros P ; apply P. -- intros P ; apply P. - simpl. unfold Up_to_Up. unfold selfedge. simpl. apply total2_paths_equiv. destruct y as [y π]. simpl. assert (q : pr122 (pr221 T) x y y π (selfedge (pr1 T) y) = π). { apply propproperty. } rewrite -> q. exists (idpath (y ,, π)). apply propproperty. Qed. Lemma UpUpid (T : Tree) (x : pr11 T) (y : pr11 (Up x)) : pr1 (Up (pr1 y)) = Upw_to_TRRGraph (Up x) y. Proof. apply TRRGraph_univalence. exists (make_weq (Up_to_Up T x y) (isweq_Up_to_Up T x y)). apply (isTRRGhomo_Up_to_Up T x y). Qed. Lemma preZFS_Branch_issuperrigid (T : preZFS) (x : T) : issuperrigid (preZFS_Branch T x). Proof. split. - apply (pr1contr_to_contr _ (λ x, (isatree x ,, isaprop_isatree x)) (preZFS_Branch T x)). apply (iscontrauto_Tree_TRRGraph (Up x) ((pr222 T) x)). - intros y. apply (pr1contr_to_contr _ (λ x, (isatree x ,, isaprop_isatree x)) (Up y)). simpl. unfold preZFS_Branch. unfold preZFS_Branch in y. rewrite <- UpUpid. apply (iscontrauto_Tree_TRRGraph (Up (pr1 y)) ((pr222 T) (pr1 y))). Qed. Definition Branch (T : preZFS) (x : T) : preZFS := preZFS_Branch T x ,, preZFS_Branch_isWellFounded T x ,, preZFS_Branch_issuperrigid T x. (** The definition of [ZFS] as a subtype of [preZFS] consisting of those pre-ZF structures each of whose branches have uniqe representatives [hasuniquerepbranch] **) Definition hasuniquerepbranch (T : preZFS) : UU := ∏ (x y : T), (Branch T x) = (Branch T y) → x = y. Lemma isaprop_hasuniquerepbranch (T : preZFS) : isaprop (hasuniquerepbranch T). Proof. repeat (apply impred ; intros). apply setproperty. Qed. Definition ZFS : UU := ∑ (X : preZFS), hasuniquerepbranch X. Definition pr1ZFS (X : ZFS) : preZFS := pr1 X. Coercion pr1ZFS : ZFS >-> preZFS. Definition ZFS_iso (x y : ZFS) := preZFS_iso x y. Theorem ZFS_univalence (x y : ZFS) : (x = y) ≃ (ZFS_iso x y). Proof. set (P := λ x, λ y, preZFS_univalence x y). set (Q := λ x, (hasuniquerepbranch x ,, isaprop_hasuniquerepbranch x)). apply (substructure_univalence _ _ P Q x y). Qed. Theorem isaset_ZFS : isaset ZFS. Proof. apply (isofhleveltotal2 2). - apply isaset_preZFS. - intros x. apply hlevelntosn. apply isaprop_hasuniquerepbranch. Qed. (*** End of Definition of ZFS ***) (*** The Elementhood Relation ***) (** Contents **) (* - A proof that branches of ZF structures are ZF structures [ZFS_Branch_is_ZFS] - A definition of elementhood [ZFS_elementof] between ZF structures X and Y as the existence of an isomorphism between X and a branch of Y. *) Definition Branch_of_Branch_to_Branch {T : preZFS} (x : T) (y : Branch T x) : pr1 (Upw_to_TRRGraph (preZFS_Branch T x) y) → pr1 (Upw_to_TRRGraph (pr1 T) (pr1 y)). Proof. simpl. intros X. induction X as [[e ε] π]. simpl in e. simpl in π. unfold Upw_E in π. simpl in π. exact (e ,, π). Defined. Definition Branch_of_Branch_to_Branch_inv {T : preZFS} (x : T) (y : Branch T x) : pr1 (Upw_to_TRRGraph (pr1 T) (pr1 y)) → pr1 (Upw_to_TRRGraph (preZFS_Branch T x) y) := λ X, ((pr1 X ,, pr12 (pr222 (pr11 T)) x (pr1 y) (pr1 X) (pr2 y) (pr2 X)) ,, pr2 X). Definition isweq_Branch_of_Branch_to_Branch {T : preZFS} (x : T) (y : Branch T x) : isweq (Branch_of_Branch_to_Branch x y). Proof. set (f := Branch_of_Branch_to_Branch x y). set (g := Branch_of_Branch_to_Branch_inv x y). assert (L : ∏ x, f (g x) = x). { intros z. unfold f ; unfold Branch_of_Branch_to_Branch. unfold g ; unfold Branch_of_Branch_to_Branch_inv. induction z as [z π]. simpl. apply idpath. } assert (LL : ∏ x, g (f x) = x). { intros z. unfold f ; unfold Branch_of_Branch_to_Branch. unfold g ; unfold Branch_of_Branch_to_Branch_inv. simpl. induction z as [z π]. apply total2_paths_equiv. assert (H : (pr1 z,, pr122 (pr221 (pr1 T)) x (pr1 y) (pr1 z) (pr2 y) π) = z). { apply total2_paths_equiv. exists (idpath (pr1 z)). apply propproperty. } exists H. apply propproperty. } apply (@weq_iso _ _ _ _ LL L). Defined. Lemma isTRRGhomo_Branch_of_Branch_to_Branch {T : preZFS} (x : T) (y : Branch T x) : isTRRGhomo (Branch_of_Branch_to_Branch x y). Proof. split. - intros xx yy. simpl. split. -- intros P ; apply P. -- intros P ; apply P. - simpl. unfold Branch_of_Branch_to_Branch. unfold selfedge. simpl. apply total2_paths_equiv. destruct y as [y π]. simpl. exists (idpath y). apply propproperty. Qed. Lemma Branch_of_Branch_eq_Branch {T : preZFS} (x : T) (y : Branch T x) : Branch (Branch T x) y = Branch T (pr1 y). Proof. apply preZFS_univalence. unfold preZFS_iso. unfold Tree_iso. simpl. exact ((Branch_of_Branch_to_Branch x y ,, isweq_Branch_of_Branch_to_Branch x y) ,, isTRRGhomo_Branch_of_Branch_to_Branch x y). Qed. Theorem ZFS_Branch_is_ZFS (X : ZFS) (x : X) : hasuniquerepbranch (Branch X x). Proof. unfold hasuniquerepbranch. intros y z. rewrite -> (Branch_of_Branch_eq_Branch x y). rewrite -> (Branch_of_Branch_eq_Branch x z). intros p. set (π := pr2 X). simpl in π. set (τ := π (pr1 y) (pr1 z) p). apply total2_paths_equiv. exists τ. apply propproperty. Qed. Definition ZFS_Branch (X : ZFS) (x : X) : ZFS := (Branch X x ,, ZFS_Branch_is_ZFS X x). Local Notation "T ↑ x" := (ZFS_Branch T x)(at level 40). Local Notation "x ⊏ y" := ((pr121 (pr111 _)) x y)(at level 50). Definition Root (X : ZFS) := pr122 (pr111 X). Definition isapoint {X : ZFS} (x : X) := ¬ (x = Root X). Lemma isaprop_isapoint {X : ZFS} (x : X) : isaprop (isapoint x). Proof. apply impred. intros. apply isapropempty. Qed. Definition ZFS_elementof (X Y : ZFS) := ∑ (a : Y), (isapoint a) × (X = Y ↑ a). Lemma isaprop_ZFS_elementof (X Y : ZFS) : isaprop (ZFS_elementof X Y). Proof. apply invproofirrelevance. unfold isProofIrrelevant. intros z w. unfold ZFS_elementof in z. unfold ZFS_elementof in w. destruct z as [z [ ispp p]]. destruct w as [w [ ispq q]]. set (r := (! q) @ p). apply total2_paths_equiv in r. destruct r as [r ρ]. set (s := (pr2 Y w z r)). simpl in ρ. set (τ y := @isapropdirprod _ _ (isaprop_isapoint y) (isaset_ZFS X (Y ↑ y))). set (P := λ y : Y, (isapoint y × X = Y ↑ y) ,, τ y). apply (total2_paths_hProp_equiv P (z,, (ispp,, p)) (w,, (ispq,, q))). simpl. apply (! s). Qed. Local Notation "x ∈ y" := (ZFS_elementof x y)(at level 30). (*** End of The Elementhood Relation ***) UniMath-20231010/UniMath/Folds/000077500000000000000000000000001451125700300157235ustar00rootroot00000000000000UniMath-20231010/UniMath/Folds/.package/000077500000000000000000000000001451125700300173745ustar00rootroot00000000000000UniMath-20231010/UniMath/Folds/.package/files000066400000000000000000000001531451125700300204200ustar00rootroot00000000000000UnicodeNotations.v folds_precat.v from_precats_to_folds_and_back.v folds_isomorphism.v folds_pre_2_cat.v UniMath-20231010/UniMath/Folds/README.md000066400000000000000000000002111451125700300171740ustar00rootroot00000000000000FOLDS ===== Categories in FOLDS (First Order Logic with Dependent Sorts) formalized by Benedikt Ahrens following notes by Mike Shulman UniMath-20231010/UniMath/Folds/UnicodeNotations.v000066400000000000000000000014001451125700300213720ustar00rootroot00000000000000Require Export UniMath.Tactics.EnsureStructuredProofs. Require Export UniMath.Foundations.PartD. Require Export UniMath.Foundations.Propositions. (* Notation "'∏' x .. y , P" := (∏ x, .. (∏ y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. Notation "'∑' x .. y , P" := (total2 (λ x, .. (total2 (λ y, P)) ..)) (at level 200, x binder, y binder, right associativity) : type_scope. Notation "A × B" := (A × B) (at level 80, no associativity) : type_scope. Notation "X ≃ Y" := (weq X Y) (at level 80, no associativity) : type_scope. *) (* Notation "'λ' x .. y , t" := (λ x, .. (λ y, t) ..) (at level 200, x binder, y binder, right associativity). Notation "∥ A ∥" := (ishinh A) (at level 200) : type_scope. *) UniMath-20231010/UniMath/Folds/folds_isomorphism.v000066400000000000000000000432621451125700300216610ustar00rootroot00000000000000 (** Univalent FOLDS Benedikt Ahrens, following notes by Michael Shulman Contents of this file: - Definition of type of isomorphism [folds_iso a b] in a FOLDS precategory - consists of two families of isos and an iso, see [folds_iso_data] - [ϕ₁ : ∏ x, x ⇒ a → x ⇒ b] - [ϕ₂ : ∏ z, a ⇒ z → b ⇒ z] - [ϕ∙ : a ⇒ a → b ⇒ b] - and a number of logical equivalences, see [folds_iso_prop] - Some lemmas expressing naturality of maps [ϕX] - Components [ϕ₂] and [ϕ∙] are determined by [ϕ₁] - [ϕ₂_determined] - [ϕo_determined] - Identity isomorphim [id_folds_iso], inverse [inv_folds_iso] and composition - Map [folds_iso_from_iso] associating to any FOLDS precat isomorphism an isomorphism in the corresponding precategory à la RezkCompletion - Map [iso_from_folds_iso] doing the converse, still departing from a FOLDS precategory - Lemma: [folds_iso_from_iso] and [iso_from_folds_iso] are inverse to each other *) Require Import UniMath.Folds.UnicodeNotations. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.Folds.folds_precat. Require Import UniMath.Folds.from_precats_to_folds_and_back. Local Notation "a ⇒ b" := (folds_morphisms a b). (** * Definition of FOLDS precat isomorphisms **) Section folds_iso_def. Variable C : folds_precat. Local Notation C':= (precat_from_folds_precat C). Local Notation "f □ g" := (compose (C:=C') f g) (at level 40, no associativity). Local Notation "'id' a" := (identity (C:=C') a) (at level 30). Definition folds_iso_data (a b : C) : UU := ((∏ (x : C), (x ⇒ a) ≃ (x ⇒ b)) × (∏ (z : C), (a ⇒ z) ≃ (b ⇒ z))) × ((a ⇒ a) ≃ (b ⇒ b)). Definition ϕ₁ {a b : C} (f : folds_iso_data a b) {x : C} : (x ⇒ a) ≃ (x ⇒ b) := pr1 (pr1 f) x. Definition ϕ₂ {a b : C} (f : folds_iso_data a b) {z : C} : (a ⇒ z) ≃ (b ⇒ z) := pr2 (pr1 f) z. Definition ϕo {a b : C} (f : folds_iso_data a b) : (a ⇒ a) ≃ (b ⇒ b) := pr2 f. Notation "ϕ∙" := ϕo. (* works as a notation, but not as an identifier *) Definition folds_iso_prop {a b : C} (i : folds_iso_data a b) : UU := ((((∏ (x y : C) (f : x ⇒ y) (g : y ⇒ a) (h : x ⇒ a), T f g h ≃ T f ((ϕ₁ i) g) ((ϕ₁ i) h)) × (∏ (x z : C) (f : x ⇒ a) (g : a ⇒ z) (h : x ⇒ z), T f g h ≃ T ((ϕ₁ i) f) ((ϕ₂ i) g) h)) × (∏ (z w : C) (f : a ⇒ z) (g : z ⇒ w) (h : a ⇒ w), T f g h ≃ T ((ϕ₂ i) f) g ((ϕ₂ i) h))) × (((∏ (x : C) (f : x ⇒ a) (g : a ⇒ a) (h : x ⇒ a), T f g h ≃ T ((ϕ₁ i) f) ((ϕo i) g) ((ϕ₁ i) h)) × (∏ (x : C) (f : a ⇒ x) (g : x ⇒ a) (h : a ⇒ a), T f g h ≃ T ((ϕ₂ i) f) ((ϕ₁ i) g) ((ϕ∙ i) h))) × ((∏ (x : C) (f : a ⇒ a) (g h : a ⇒ x), T f g h ≃ T ((ϕ∙ i) f) ((ϕ₂ i) g) ((ϕ₂ i) h)) × (∏ f g h : a ⇒ a, T f g h ≃ T ((ϕ∙ i) f) ((ϕ∙ i) g) ((ϕ∙ i) h))))) × (∏ f : a ⇒ a, I f ≃ I ((ϕ∙ i) f)). Definition isaprop_folds_iso_prop (a b : C) (i : folds_iso_data a b) : isaprop (folds_iso_prop i). Proof. repeat (apply isapropdirprod); repeat (apply impred; intro); apply isapropweqtoprop; apply pr2. Qed. Definition folds_iso (a b : C) := ∑ i : folds_iso_data a b, folds_iso_prop i. Definition folds_iso_data_from_folds_iso {a b : C} : folds_iso a b → folds_iso_data a b := λ i, pr1 i. Coercion folds_iso_data_from_folds_iso : folds_iso >-> folds_iso_data. Lemma folds_iso_eq {a b : C} (i i' : folds_iso a b) : folds_iso_data_from_folds_iso i = folds_iso_data_from_folds_iso i' → i = i'. Proof. intro H. apply subtypePath. - intro; apply isaprop_folds_iso_prop. - assumption. Qed. (** * Lemmas about FOLDS isomorphisms *) (** the families of equivalences constituting a FOLDS isomorphism are given by composition **) Section about_folds_isos. Context {a b : C}. Section fix_a_folds_iso. Variable (i : folds_iso a b). Lemma ϕ₁_is_comp (x : C) (f : x ⇒ a) : ϕ₁ i f = f □ (ϕ₁ i (id _ )). Proof. set (q:=pr1 (pr1 (pr1 (pr1 (pr2 i))))). specialize (q _ _ f (id _ ) f). set (q':=pr1 q ); clearbody q'. assert (H: T f (id a) f). { set (H:= pr1 (pr2 (pr1 (pr2 C)))). apply H. apply I_func_I. } set (q'H:= q' H). clearbody q'H; clear H q' q. apply path_to_ctr. assumption. Qed. Lemma ϕ₂_is_comp (z : C) (g : a ⇒ z) : ϕ₂ i g = ϕ₂ i (id _ ) □ g. Proof. set (q:=pr2 (pr1 (pr1 (pr2 i)))). simpl in q. specialize (q _ _ (id _ ) g g). set (q':=pr1 q ); clearbody q'. assert (H: T (id a) g g). { set (H:= pr2 (pr2 (pr1 (pr2 C)))). apply H. apply I_func_I. } set (q'H:= q' H). clearbody q'H; clear H q' q. apply path_to_ctr. assumption. Qed. Lemma ϕ₁_ϕ₂_id : ϕ₁ i (id _ ) □ (ϕ₂ i (id _ )) = id _. Proof. set (q:=pr2 (pr1 (pr1 (pr1 (pr2 i))))). simpl in q. specialize (q _ _ (id _ ) (id _ ) (id _ )). set (q':=pr1 q ); clearbody q'. apply comp_compose2'. apply q'. apply comp_compose2. apply T_I_l. Qed. Lemma ϕo_id : ϕ∙ i (id _ ) = id _ . Proof. apply id_identity2'. apply (pr2 (pr2 i)). apply I_func_I. Qed. Lemma ϕ₂_ϕ₁_id: ϕ₂ i (id a) □ ϕ₁ i (id a) = id b. Proof. set (H':= pr2 (pr1 (pr2 (pr1 (pr2 i))))). simpl in H'. specialize (H' _ (id _ ) (id _ ) (id _ )). simpl in H'. rewrite <- ϕo_id. apply comp_compose2'. apply H'. apply comp_compose2. apply T_I_l. Qed. Lemma ϕ₁_ϕ₂_are_inverse : is_inverse_in_precat (C:= C') (ϕ₁ i (id _ )) (ϕ₂ i (id _ )). Proof. split. - apply ϕ₁_ϕ₂_id. - apply ϕ₂_ϕ₁_id. Qed. Lemma ϕo_ϕ₁_ϕ₂ (f : a ⇒ a) : ϕ∙ i f = (ϕ₂ i (id _ ) □ f) □ ϕ₁ i (id _). Proof. set (q:=pr2 (pr1 (pr2 (pr1 (pr2 i))))); simpl in q; clearbody q. specialize (q _ f (id _ ) f). set (q':=pr1 q). clearbody q'. simpl in q'. clear q. match goal with | [_ : ?a → _ |- _ ] => assert a end. { apply comp_compose2. apply (@id_right C'). } specialize (q' X). clear X. set (q:= comp_compose2' q'). clearbody q; clear q'. simpl in *. change (ϕ∙ i f) with (ϕ∙ (pr1 i) f). rewrite <- q. clear q. rewrite ϕ₂_is_comp. apply idpath. Qed. End fix_a_folds_iso. (** * A FOLDS isomorphism is determined by the first family of isos **) Variables i i' : folds_iso a b. Hypothesis H : ϕ₁ i (id _ ) = ϕ₁ i' (id _ ). Lemma ϕ₂_determined : ∏ x (f : a ⇒ x) , ϕ₂ i f = ϕ₂ i' f. Proof. intros x f. rewrite (ϕ₂_is_comp i). rewrite (ϕ₂_is_comp i'). assert (H': is_inverse_in_precat (C:=C') (ϕ₁ i (id _ )) (ϕ₂ i' (id _ ))). { split. - rewrite H. apply ϕ₁_ϕ₂_id. - rewrite H. apply ϕ₂_ϕ₁_id. } assert (X : ϕ₂ i (id _ ) = ϕ₂ i' (id _ )). { set (H1:= inverse_unique_precat _ _ _ _ _ (ϕ₁_ϕ₂_are_inverse i) H'). assumption. } rewrite X. apply idpath. Qed. Lemma ϕo_determined : ∏ f, ϕ∙ i f = ϕ∙ i' f. Proof. intro f. do 2 rewrite ϕo_ϕ₁_ϕ₂. rewrite ϕ₂_determined. rewrite H. apply idpath. Qed. Lemma folds_iso_equal : i = i'. Proof. apply folds_iso_eq. apply dirprodeq. - apply dirprodeq. + apply funextsec; intro. apply subtypePath. * intro. apply isapropisweq. * apply funextfun; intro f. eapply pathscomp0. { apply ϕ₁_is_comp. } symmetry. eapply pathscomp0. { apply ϕ₁_is_comp. } rewrite H. apply idpath. + apply funextsec; intro. apply subtypePath. * intro; apply isapropisweq. * apply funextfun. unfold homot. apply ϕ₂_determined. - apply subtypePath. { intro. apply isapropisweq. } apply funextfun. intro t. apply ϕo_determined. Qed. End about_folds_isos. (** * Identity FOLDS isomorphism **) Definition id_folds_iso_data (a : C) : folds_iso_data a a. Proof. repeat split. - intro x. apply idweq. - intro z. apply idweq. - apply idweq. Defined. Lemma id_folds_iso_prop (a : C) : folds_iso_prop (id_folds_iso_data a). Proof. repeat split; intros; apply idweq. Qed. Definition id_folds_iso (a : C) : folds_iso a a := tpair _ (id_folds_iso_data a) (id_folds_iso_prop a). (** * Inverse of a FOLDS isomorphism **) Section folds_iso_inverse. Context {a b : C} (i : folds_iso a b). Definition inv_folds_iso_data : folds_iso_data b a. Proof. repeat split. - intro x. exact (invweq (ϕ₁ i)). - intro z. exact (invweq (ϕ₂ i)). - exact (invweq (ϕ∙ i)). Defined. Lemma inv_folds_iso_prop : folds_iso_prop inv_folds_iso_data. Proof. repeat split; intros. - simpl. apply invweq. set (q:=pr1 (pr1 (pr1 (pr1 (pr2 i))))). clearbody q. set (q':= q _ _ f (invmap (ϕ₁ i) g) (invmap (ϕ₁ i) h)). repeat rewrite (homotweqinvweq (ϕ₁ i)) in q'. apply q'. - simpl. apply invweq. set (q:=pr2 (pr1 (pr1 (pr1 (pr2 i))))). simpl in q; clearbody q. set (q':= q _ _ (invmap (ϕ₁ i) f) (invmap (ϕ₂ i) g) h); clearbody q'. repeat rewrite homotweqinvweq in q'. apply q'. - simpl. apply invweq. set (q:= ((pr2 (pr1 (pr1 (pr2 i)))))). clearbody q; simpl in q. set (q':= q _ _ (invmap (ϕ₂ i) f) g (invmap (ϕ₂ i) h) ). repeat rewrite homotweqinvweq in q'. apply q'. - simpl; apply invweq. set (q:= pr1 (pr1 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q. set (q':= q _ (invmap (ϕ₁ i) f) (invmap (ϕ∙ i) g) (invmap (ϕ₁ i) h)). repeat rewrite homotweqinvweq in q'. apply q'. - simpl; apply invweq. set (q:= pr2 (pr1 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q. set (q':= q _ (invmap (ϕ₂ i) f) (invmap (ϕ₁ i) g) (invmap (ϕ∙ i) h)). repeat rewrite homotweqinvweq in q'. apply q'. - simpl. apply invweq. set (q:= pr1 (pr2 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q. specialize (q _ (invmap (ϕ∙ i) f) (invmap (ϕ₂ i) g) (invmap (ϕ₂ i) h)). repeat rewrite homotweqinvweq in q. apply q. - simpl. apply invweq. set (q:= pr2 (pr2 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q. specialize (q (invmap (ϕ∙ i) f) (invmap (ϕ∙ i) g) (invmap (ϕ∙ i) h)). repeat rewrite homotweqinvweq in q. apply q. - simpl. apply invweq. set (q:= pr2 (pr2 i)). simpl in q; clearbody q. specialize (q (invmap (ϕ∙ i) f)). rewrite homotweqinvweq in q. apply q. Qed. Definition inv_folds_iso : folds_iso b a := tpair _ inv_folds_iso_data inv_folds_iso_prop. End folds_iso_inverse. (** * Composition of FOLDS isomorphisms **) Section folds_iso_comp. Context {a b c : C} (i : folds_iso a b) (i' : folds_iso b c). Definition folds_iso_comp_data : folds_iso_data a c. Proof. repeat split. - intro x; apply (weqcomp (ϕ₁ i) (ϕ₁ i')). - intro z; apply (weqcomp (ϕ₂ i) (ϕ₂ i')). - apply (weqcomp (ϕ∙ i) (ϕ∙ i')). Defined. Lemma folds_iso_comp_prop : folds_iso_prop folds_iso_comp_data. Proof. repeat split. - intros. simpl. eapply weqcomp. + apply (pr1 (pr1 (pr1 (pr1 (pr2 i))))). + apply (pr1 (pr1 (pr1 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr2 (pr1 (pr1 (pr1 (pr2 i))))). + apply (pr2 (pr1 (pr1 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr2 (pr1 (pr1 (pr2 i)))). + apply (pr2 (pr1 (pr1 (pr2 i')))). - intros; simpl; eapply weqcomp. + apply (pr1 (pr1 (pr2 (pr1 (pr2 i))))). + apply (pr1 (pr1 (pr2 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr2 (pr1 (pr2 (pr1 (pr2 i))))). + apply (pr2 (pr1 (pr2 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr1 (pr2 (pr2 (pr1 (pr2 i))))). + apply (pr1 (pr2 (pr2 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr2 (pr2 (pr2 (pr1 (pr2 i))))). + apply (pr2 (pr2 (pr2 (pr1 (pr2 i'))))). - intros; simpl; eapply weqcomp. + apply (pr2 (pr2 i)). + apply (pr2 (pr2 i')). Qed. End folds_iso_comp. (** * From isomorphisms to FOLDS isomorphisms **) Section from_iso_to_folds_iso. Variables a b : C. Variable f : z_iso (C:=C') a b. Definition folds_iso_data_from_z_iso : folds_iso_data a b := make_dirprod (make_dirprod (z_iso_comp_left_weq f) (z_iso_comp_right_weq (z_iso_inv_from_z_iso f))) (z_iso_conjug_weq f). Lemma folds_iso_data_prop : folds_iso_prop folds_iso_data_from_z_iso. Proof. repeat split; intros. - simpl. apply logeqweq. + intro H. apply comp_compose2. rewrite assoc. set (H2 := comp_compose2' H). rewrite H2. apply idpath. + intro H. apply comp_compose2. set (H2 := comp_compose2' H). rewrite assoc in H2. eapply post_comp_with_z_iso_is_inj. * apply (z_iso_is_inverse_in_precat f). * apply H2. - simpl. apply logeqweq. + intro H. apply comp_compose2. apply pathsinv0. eapply pathscomp0. * apply (pathsinv0 (comp_compose2' H)). * transitivity ((f0 □ (f □ (inv_from_z_iso f))) □ g). ** rewrite z_iso_inv_after_z_iso. rewrite id_right. apply idpath. ** repeat rewrite assoc; apply idpath. + intro H. apply comp_compose2. set (H2 := comp_compose2' H). apply pathsinv0. eapply pathscomp0. * apply (pathsinv0 H2). * transitivity ((f0 □ (f □ (inv_from_z_iso f))) □ g). ** repeat rewrite assoc; apply idpath. ** rewrite z_iso_inv_after_z_iso. rewrite id_right. apply idpath. - simpl. apply logeqweq. + intro H. apply comp_compose2. rewrite <- assoc. rewrite (comp_compose2' H). apply idpath. + intro H. apply comp_compose2. set (H2:= comp_compose2' H). rewrite <- assoc in H2. use (pre_comp_with_z_iso_inv_is_inj f). exact H2. - simpl; apply logeqweq. + intro H; apply comp_compose2. rewrite <- (comp_compose2' H). transitivity ((f0 □ (f □ (inv_from_z_iso f))) □ (g □ f)). * repeat rewrite assoc; apply idpath. * rewrite z_iso_inv_after_z_iso. rewrite id_right; apply assoc. + intro H; apply comp_compose2. set (H2 := comp_compose2' H). repeat rewrite assoc in H2. use pathscomp0. * exact ((f0 □ (f □ (inv_from_z_iso f))) □ g). * rewrite z_iso_inv_after_z_iso, id_right; apply idpath. * repeat rewrite assoc. use (post_comp_with_z_iso_is_inj f). exact H2. - simpl; apply logeqweq. + intro H. apply comp_compose2. repeat rewrite assoc; rewrite assoc4. rewrite (comp_compose2' H). apply pathsinv0, assoc. + intro H; apply comp_compose2. set (H2 := comp_compose2' H). rewrite <- assoc in H2. use (pre_comp_with_z_iso_inv_is_inj f). use (post_comp_with_z_iso_is_inj f). rewrite assoc. rewrite assoc in H2. rewrite assoc in H2. use (pathscomp0 H2). rewrite <- assoc. apply idpath. - simpl. apply logeqweq. + intro H; apply comp_compose2. rewrite <- (comp_compose2' H); clear H. repeat rewrite <- assoc. apply maponpaths. repeat rewrite assoc. rewrite assoc4, z_iso_inv_after_z_iso, id_right. apply idpath. + intro H; apply comp_compose2. set (H':= comp_compose2' H); generalize H'; clear H' H; intro H. repeat rewrite <- assoc in H. use (pre_comp_with_z_iso_inv_is_inj f). use (pathscomp0 _ H). rewrite (@assoc C' _ _ _ _ f). rewrite z_iso_inv_after_z_iso. rewrite id_left. apply idpath. - simpl; apply logeqweq. + intro H; set (H':=comp_compose2' H); clearbody H'; clear H; rename H' into H; rewrite <- H; clear H. apply comp_compose2. repeat rewrite <- assoc; apply maponpaths; simpl. set (H':=@assoc C' _ _ _ _ f0 g f); clearbody H'; simpl in *. rewrite <- H'; clear H'. apply maponpaths. simpl in *. repeat rewrite (@assoc C'). rewrite z_iso_inv_after_z_iso, id_left; apply idpath. + intro H; set (H':=comp_compose2' H); clearbody H'; clear H; rename H' into H. apply comp_compose2. repeat rewrite <- assoc in H. use (post_comp_with_z_iso_is_inj f). use (pre_comp_with_z_iso_inv_is_inj f). use (pathscomp0 _ H). rewrite (@assoc C' _ _ _ _ f). rewrite z_iso_inv_after_z_iso. rewrite id_left. rewrite <- assoc. apply idpath. - simpl. apply logeqweq. + intro H. apply id_identity2. rewrite (id_identity2' H). rewrite (@id_left C'). apply (z_iso_after_z_iso_inv f). + intro H. apply id_identity2. set (H':=id_identity2' H); clearbody H'; clear H. set (H2:=z_iso_inv_to_left _ _ _ f _ _ H'); clearbody H2. rewrite id_right in H2. transitivity (f □ (inv_from_z_iso f)). * apply (z_iso_inv_on_left (C:=C')), pathsinv0, H2. * apply (z_iso_inv_after_z_iso (C := C')). Qed. Definition folds_iso_from_iso : folds_iso a b := tpair _ _ folds_iso_data_prop. End from_iso_to_folds_iso. (** * from FOLDS isomorphism to isomorphism **) Section from_folds_iso_to_iso. Variables a b : C. Variable i : folds_iso a b. Let i': a ⇒ b := ϕ₁ i (id _ ). Let i'inv : b ⇒ a := ϕ₂ i (id _ ). Definition iso_from_folds_iso : z_iso (C:=C') a b. Proof. exists i'. exists i'inv. apply ϕ₁_ϕ₂_are_inverse. Defined. End from_folds_iso_to_iso. (** * from FOLDS isos to isos and back, and the other way round **) Section iso_from_folds_from_iso. Hypothesis (hs: has_homsets C'). Context {a b : C} (i : z_iso (C:=C') a b). Lemma iso_from_folds_iso_folds_iso_from_iso : iso_from_folds_iso _ _ (folds_iso_from_iso _ _ i) = i. Proof. apply (z_iso_eq(C:=C',,hs)). apply (@id_left C'). Qed. Variable i' : folds_iso a b. Lemma folds_iso_from_iso_iso_from_folds_iso : folds_iso_from_iso _ _ (iso_from_folds_iso _ _ i') = i'. Proof. apply folds_iso_equal. apply (@id_left C'). Qed. End iso_from_folds_from_iso. End folds_iso_def. UniMath-20231010/UniMath/Folds/folds_pre_2_cat.v000066400000000000000000000341761451125700300211520ustar00rootroot00000000000000(** Univalent FOLDS Benedikt Ahrens, following notes by Michael Shulman Contents of this file: - Definition: FOLDS pre-3-category - objects [ob] coerced, morphisms denoted by infix [⇒] - predicates for identity [I], composition [T], equality [E] - [E] is a congruence for [T] and [I], and [E] is an equivalence relation - usual categorical axioms - Definition: FOLDS pre-2-categoy - the fibers of [I], [T] and [E] are hProps - Isomorphism between morphisms in a FOLDS pre-2-category - Definition: given by a family of equivalences - Lemma: Type of isos [folds_2_iso f g] is a proposition (because [I], [T], [E] are) - Definition: Map [idtoiso2] from paths to isos - Lemma: In a FOLDS pre-2-category, [folds_2_iso f g] is equivalent to [E f g] - [E_implies_folds_iso] - [folds_iso_implies_E] - Definition: univalent FOLDS pre-2-category as special FOLDS pre-2-category - [idtoiso2] is an equivalence - [is_univalent_folds_2_precat] is an hProp - Definition: FOLDS precategory as special FOLDS pre-2-category - predicate [is_folds_precategory] defined as - hom-types are sets - axioms of category modul [=] rather than [E] - Lemma: Logical equivalence between being a FOLDS precategory and being univalent - since both are hProps, this entails equivalence between the types of - univalent FOLDS pre-2-cats - FOLDS precats - Implications are called - [is_univalent_implies_is_folds_precat] and - [is_folds_precat_implies_is_univalent] *) Require Import UniMath.Folds.UnicodeNotations. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Local Notation "p ## a" := (transportf _ p a) (at level 3, only parsing). (** * The definition of a FOLDS pre-3-category *) (** ** Objects and a dependent type of morphisms *) Definition folds_3_ob_mor := ∑ a : UU, a → a → UU. Definition make_folds_3_ob_mor (ob : UU)(mor : ob → ob → UU) : folds_3_ob_mor := tpair _ ob mor. Definition ob (C : folds_3_ob_mor) : UU := @pr1 _ _ C. Coercion ob : folds_3_ob_mor >-> UU. Definition folds_3_morphisms {C : folds_3_ob_mor} : C → C → UU := pr2 C. Local Notation "a ⇒ b" := (folds_3_morphisms a b). Definition folds_double_transport {C : folds_3_ob_mor} {a a' b b' : ob C} (p : a = a') (q : b = b') (f : a ⇒ b) : a' ⇒ b' := transportf (λ c, a' ⇒ c) q (transportf (λ c, c ⇒ b) p f). (** ** Identity, composition, and equality, given through predicates *) (** We do not assume those to be propositions. *) Definition folds_3_id_comp_eq := ∑ C : folds_3_ob_mor, ( (∏ a : C, a ⇒ a → UU) × (∏ (a b c : C), (a ⇒ b) → (b ⇒ c) → (a ⇒ c) → UU)) × ∏ a b : C, a ⇒ b → a ⇒ b → UU. Definition folds_ob_mor_from_folds_id_comp (C : folds_3_id_comp_eq) : folds_3_ob_mor := pr1 C. Coercion folds_ob_mor_from_folds_id_comp : folds_3_id_comp_eq >-> folds_3_ob_mor. Definition I {C : folds_3_id_comp_eq} : ∏ {a : C}, a ⇒ a → UU := pr1 (pr1 (pr2 C)). Definition T {C : folds_3_id_comp_eq} : ∏ {a b c : C}, (a ⇒ b) → (b ⇒ c) → (a ⇒ c) → UU := pr2 (pr1 (pr2 C)). Definition E {C : folds_3_id_comp_eq} : ∏ {a b : C}, a ⇒ b → a ⇒ b → UU := pr2 (pr2 C). (** ** E is an "equality", i.e. a congruence and equivalence *) Definition E_is_good_to_I_and_T (C : folds_3_id_comp_eq) : UU := (((∏ (a b : C) (f : a ⇒ b), E f f) (* refl *) × (∏ (a b : C) (f g : a ⇒ b), E f g → E g f)) (* sym *) × (∏ (a b : C) (f g h : a ⇒ b), E f g → E g h → E f h)) × ((∏ (a : C) (f g : a ⇒ a), E f g → I f → I g) × (∏ (a b c : C) (f f' : a ⇒ b) (g g' : b ⇒ c) (h h' : a ⇒ c), E f f' → E g g' → E h h' → T f g h → T f' g' h')). (** ** The axioms for identity *) Definition folds_ax_id (C : folds_3_id_comp_eq) := (∏ a : C, ∥ ∑ f : a ⇒ a, I f ∥ ) (* there is a thing satisfying I *) × ((∏ (a b : C) (f : a ⇒ b)(i : b ⇒ b), I i → T f i f) (* I is post neutral *) × (∏ (a b : C) (f : a ⇒ b)(i : a ⇒ a), I i → T i f f)). (* I is pre neutral *) (** ** The axioms for composition *) Definition folds_ax_comp (C : folds_3_id_comp_eq) := (∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c), ∥ ∑ h : a ⇒ c, T f g h ∥ ) (* there is a composite *) × ( (∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c) (h k : a ⇒ c), T f g h → T f g k → E h k ) (* composite is unique mod E *) × (∏ (a b c d : C) (f : a ⇒ b) (g : b ⇒ c) (h : c ⇒ d) (fg : a ⇒ c) (gh : b ⇒ d) (fg_h : a ⇒ d) (f_gh : a ⇒ d), T f g fg → T g h gh → T fg h fg_h → T f gh f_gh → E f_gh fg_h)). (* composition is assoc mod E *) (** ** A FOLDS pre-3-category is a package of - identity [I] - composition [T] - equality [E] satisfying the categorical axioms modulo [E] and [E] is an "equality" *) Definition folds_pre_3_cat := ∑ C : folds_3_id_comp_eq, (folds_ax_id C × folds_ax_comp C) × E_is_good_to_I_and_T C. Definition folds_id_comp_from_folds_precat (C : folds_pre_3_cat) : folds_3_id_comp_eq := pr1 C. Coercion folds_id_comp_from_folds_precat : folds_pre_3_cat >-> folds_3_id_comp_eq. (** * FOLDS-2-precategories *) (** they are 3-precategories such that T, I and E are hProps *) Definition is_folds_pre_2_cat (C : folds_pre_3_cat) := ( (∏ (a : C) (i : a ⇒ a), isaprop (I i)) × (∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c) (h : a ⇒ c), isaprop (T f g h))) × (∏ (a b : C) (f g : a ⇒ b), isaprop (E f g)). Definition folds_pre_2_cat : UU := ∑ C, is_folds_pre_2_cat C. Ltac folds_pre_2_cat_props C := try apply (pr2 (pr1 (pr2 C))); try apply (pr1 (pr1 (pr2 C))); try apply (pr2 (pr2 C)). Definition folds_3_from_folds_2 (C : folds_pre_2_cat) : folds_pre_3_cat := pr1 C. Coercion folds_3_from_folds_2 : folds_pre_2_cat >-> folds_pre_3_cat. (** * FOLDS-2-isomorphisms *) Definition folds_iso {C: folds_pre_3_cat} {a b : C} (f g : a ⇒ b) : UU := (((∏ (x : C) (u : x ⇒ a) (v : x ⇒ b), T u f v ≃ T u g v) × (∏ (x : C) (u : a ⇒ x) (v : x ⇒ b), T u v f ≃ T u v g)) × (∏ (x : C) (u : b ⇒ x) (v : a ⇒ x), T f u v ≃ T g u v)) × ((((∏ (u : a ⇒ b) (p : b = a), T p ## f f u ≃ T p ## g g u) × (∏ (u : b ⇒ b) (p : a = a), T (transportf (λ a, a ⇒ b) p f) u f ≃ T (transportf (λ a, a ⇒ b) p g) u g)) × ((∏ (u : a ⇒ a) (p : b = b), T u p ## f f ≃ T u p ## g g) × (∏ (p : a = a) (q : b = a) (r : b = b), T (folds_double_transport p q f) r ## f f ≃ T (folds_double_transport p q g) r ## g g))) × (((∏ p : b = a, I p ## f ≃ I p ## g) × (∏ u : a ⇒ b, E f u ≃ E g u)) × ((∏ u : a ⇒ b, E u f ≃ E u g) × (∏ (p : a = a) (q : b = b), E (folds_double_transport p q f) f ≃ E (folds_double_transport p q g) g)))). Lemma isaprop_folds_2_iso (C : folds_pre_2_cat) (a b : C) (f g : a ⇒ b) : isaprop (folds_iso f g). Proof. repeat (apply isofhleveldirprod); repeat (apply impred; intro); apply isofhlevelsnweqtohlevelsn; folds_pre_2_cat_props C. Qed. Definition folds_2_iso_id (C : folds_pre_3_cat) (a b : C) (f : a ⇒ b) : folds_iso f f. Proof. repeat split; intros; apply idweq. Defined. (** * In FOLDS-2-precats, [folds_iso f g <-> E f g] *) Lemma E_transport_source : ∏ (C : folds_pre_2_cat) (a a' b : C) (f g : a ⇒ b) (p : a = a'), E f g → E (transportf (λ c, c ⇒ b) p f) (transportf (λ c, c ⇒ b) p g). Proof. intros. destruct p. assumption. Defined. Lemma E_transport_target : ∏ (C : folds_pre_2_cat) (a b b' : C) (f g : a ⇒ b) (p : b = b'), E f g → E (transportf (λ c, a ⇒ c) p f) (transportf (λ c, a ⇒ c) p g). Proof. intros. destruct p. assumption. Defined. Lemma E_implies_folds_iso (C : folds_pre_2_cat) (a b : C) (f g : a ⇒ b) : E f g → folds_iso f g. Proof. set (H' := pr2 (pr2 (pr1 C))). simpl in H'. destruct H' as [[[Erefl Esym] Etrans] [EI ET]]. intro Efg. repeat split; intros; apply weqimplimpl; intro; folds_pre_2_cat_props C. - apply (ET _ _ _ u u f g v v); auto. - apply (ET _ _ _ u u g f v v) ; auto. - apply (ET _ _ _ u u v v f g); auto. - apply (ET _ _ _ u u v v g f); auto. - apply (ET _ _ _ f g u u v v); auto. - apply (ET _ _ _ g f u u v v); auto. - destruct p; apply (ET _ _ _ f g f g u u); auto. - destruct p; apply (ET _ _ _ g f g f u u); auto. - apply (ET _ _ _ (transportf (λ c, c ⇒ b) p f) (p ## g) u u f g); try apply E_transport_source; auto. - apply (ET _ _ _ (transportf (λ c, c ⇒ b) p g) (p ## f) u u g f); try apply E_transport_source; auto. - apply (ET _ _ _ u u (transportf (λ c, a ⇒ c) p f) (p ## g) f g); try apply E_transport_target; auto. - apply (ET _ _ _ u u (transportf (λ c, a ⇒ c) p g) (p ## f) g f); try apply E_transport_target; auto. - apply (ET _ _ _ (folds_double_transport p q f) (folds_double_transport p q g) (transportf (λ c, a ⇒ c) r f) (r ## g) f g); try apply E_transport_target; try apply E_transport_source; auto. - apply (ET _ _ _ (folds_double_transport p q g) (folds_double_transport p q f) (transportf (λ c, a ⇒ c) r g) (r ## f) g f); try apply E_transport_target; try apply E_transport_source; auto. - destruct p. apply (EI _ f); auto. - destruct p; apply (EI _ g); auto. - apply (Etrans _ _ g f u). + apply Esym; auto. + auto. - apply (Etrans _ _ f g u); auto. - apply (Etrans _ _ u f g); auto. - apply (Etrans _ _ u g f). + auto. + apply Esym; auto. - apply (Etrans _ _ (folds_double_transport p q g) (folds_double_transport p q f) g). + apply E_transport_target. apply E_transport_source. apply Esym; auto. + apply (Etrans _ _ (folds_double_transport p q f) f g); auto. - apply (Etrans _ _ (folds_double_transport p q f) (folds_double_transport p q g) f). + apply E_transport_target. apply E_transport_source. auto. + apply (Etrans _ _ (folds_double_transport p q g) g f); auto. Qed. Lemma folds_iso_implies_E (C : folds_pre_2_cat) (a b : C) (f g : a ⇒ b) : folds_iso f g → E f g. Proof. intro Isofg. set (keytojoy := pr1 (pr2 (pr2 (pr2 Isofg)))). apply (keytojoy f). set (H' := pr2 (pr2 (pr1 C))). simpl in H'. destruct H' as [[[Erefl Esym] Etrans] [EI ET]]. apply Erefl. Qed. (** * Univalent FOLDS-2-precategory *) (** satisfies [isweq (idtoiso2 f g)] for any [f] and [g] *) Definition idtoiso2 {C : folds_pre_2_cat} {a b : C} {f g : a ⇒ b} : f = g → folds_iso f g. Proof. destruct 1. exact (folds_2_iso_id _ _ _ f). Defined. Definition is_univalent_folds_pre_2_cat (C : folds_pre_2_cat) : UU := ∏ (a b : C) (f g : a ⇒ b), isweq (@idtoiso2 _ _ _ f g). Lemma isaprop_is_univalent_folds_2_precat (C : folds_pre_2_cat) : isaprop (is_univalent_folds_pre_2_cat C). Proof. do 4 (apply impred; intro); apply isapropisweq. Qed. Definition isotoid2 (C : folds_pre_2_cat) (H : is_univalent_folds_pre_2_cat C) (a b : C) (f g : a ⇒ b) : folds_iso f g → f = g := invmap (make_weq _ (H a b f g)). (** * FOLDS precategories *) (** We define them as special FOLDS pre-2-categories, namely such that - hom-types are sets - axioms of precategory modulo identity (rather than E) *) Definition is_folds_precategory (C : folds_pre_2_cat) : UU := (∏ a b : C, isaset (a ⇒ b)) × ((∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c) (h k : a ⇒ c), T f g h → T f g k → h = k ) (* T is unique mod identity *) × (∏ (a b c d : C) (f : a ⇒ b) (g : b ⇒ c) (h : c ⇒ d) (fg : a ⇒ c) (gh : b ⇒ d) (fg_h : a ⇒ d) (f_gh : a ⇒ d), T f g fg → T g h gh → T fg h fg_h → T f gh f_gh → f_gh = fg_h)). (* T is assoc mod identity *) Lemma isaprop_is_folds_precategory (C : folds_pre_2_cat) : isaprop (is_folds_precategory C). Proof. apply isofhlevelsn. intro H. repeat (apply isofhleveldirprod). - do 2 (apply impred; intro). apply isapropisaset. - do 9 (apply impred; intro). apply (pr1 H). - do 15 (apply impred; intro). apply H. (* alternatively by hand apply invproofirrelevance. intros [p q] [p' q']. apply pathsdirprod. - apply proofirrelevance. do 2 (apply impred; intro). apply isapropisaset. - destruct q as [q1 q2]. destruct q' as [q'1 q'2]. apply pathsdirprod. + apply proofirrelevance; do 9 (apply impred; intro); apply p. + apply proofirrelevance. do 15 (apply impred; intro); apply p. *) Qed. (** * Univalent FOLDS pre-2-category is a FOLDS precategory *) Section is_univalent_implies_folds_precat. Variable C : folds_pre_2_cat. Hypothesis H : is_univalent_folds_pre_2_cat C. Lemma is_univalent_implies_is_folds_precat : is_folds_precategory C. Proof. apply make_dirprod. - intros a b f g. apply (isofhlevelweqb _ (make_weq _ (H a b f g))). apply isaprop_folds_2_iso. - apply make_dirprod. + intros. apply (isotoid2 _ H). apply E_implies_folds_iso. set (T_unique := pr1 (pr2 (pr2 (pr1 (pr2 (pr1 C)))))). apply (T_unique _ _ _ f g); auto. + intros. apply (isotoid2 _ H). apply E_implies_folds_iso. set (T_assoc := pr2 (pr2 (pr2 (pr1 (pr2 (pr1 C)))))). simpl in T_assoc. apply (T_assoc _ _ _ _ f g h fg gh fg_h f_gh); auto. Qed. End is_univalent_implies_folds_precat. (** * FOLDS precategory implies univalence *) Section folds_precat_implies_univalent. Variable C : folds_pre_2_cat. Hypothesis H : is_folds_precategory C. Hypothesis standardness : ∏ (a b : C) (f g : a ⇒ b), E f g → f = g. Lemma folds_2_iso_implies_identity (a b : C) (f g : a ⇒ b) : folds_iso f g → f = g. Proof. intro Isofg. apply standardness. apply folds_iso_implies_E. apply Isofg. Qed. Lemma is_folds_precat_implies_is_univalent : is_univalent_folds_pre_2_cat C. Proof. intros a b f g. apply isweqimplimpl. - apply folds_2_iso_implies_identity. - apply (pr1 H). - apply isaprop_folds_2_iso. Qed. End folds_precat_implies_univalent. UniMath-20231010/UniMath/Folds/folds_precat.v000066400000000000000000000137451451125700300205710ustar00rootroot00000000000000 (** Univalent FOLDS Benedikt Ahrens, following notes by Michael Shulman Contents of this file: - Definition of the type of FOLDS precategories [folds_precat] - Definition of functions [id_func] and [comp_func] from a FOLDS precategory - Proof of the usual axioms of categories for those functions *) Require Import UniMath.Folds.UnicodeNotations. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. (** * The definition of a FOLDS precategory *) (** ** Objects and a dependent type of morphisms *) Definition folds_ob_mor := ∑ a : UU, a → a → UU. Definition make_folds_ob_mor (ob : UU)(mor : ob → ob → UU) : folds_ob_mor := tpair _ ob mor. Definition ob (C : folds_ob_mor) : UU := @pr1 _ _ C. Coercion ob : folds_ob_mor >-> UU. Definition folds_morphisms {C : folds_ob_mor} : C → C → UU := pr2 C. Local Notation "a ⇒ b" := (folds_morphisms a b). Definition has_folds_homsets (C : folds_ob_mor) : UU := ∏ a b: C, isaset (a ⇒ b). (** ** Identity and composition, given through predicates *) Definition folds_id_T := ∑ C : folds_ob_mor, (∏ a : C, a ⇒ a → hProp) × (∏ (a b c : C), (a ⇒ b) → (b ⇒ c) → (a ⇒ c) → hProp). Definition folds_ob_mor_from_folds_id_comp (C : folds_id_T) : folds_ob_mor := pr1 C. Coercion folds_ob_mor_from_folds_id_comp : folds_id_T >-> folds_ob_mor. Definition I {C : folds_id_T} : ∏ {a : C}, a ⇒ a → hProp := pr1 (pr2 C). Definition T {C : folds_id_T} : ∏ {a b c : C}, (a ⇒ b) → (b ⇒ c) → (a ⇒ c) → hProp := pr2 (pr2 C). (** ** The axioms for identity *) Definition folds_ax_I (C : folds_id_T) := (∏ a : C, ∥ ∑ f : a ⇒ a, I f ∥ ) (* there is an id *) × ((∏ (a b : C) (f : a ⇒ b)(i : b ⇒ b), I i → T f i f) (* id is post neutral *) × (∏ (a b : C) (f : a ⇒ b)(i : a ⇒ a), I i → T i f f)). (* id is pre neutral *) Lemma isaprop_folds_ax_id C : isaprop (folds_ax_I C). Proof. repeat (apply isapropdirprod). - apply impred; intro; apply isapropishinh. - repeat (apply impred; intro). apply pr2. - repeat (apply impred; intro). apply pr2. Qed. Definition folds_ax_T (C : folds_id_T) := (∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c), ∥ ∑ h : a ⇒ c, T f g h ∥ ) (* there is a composite *) × ((∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c) (h k : a ⇒ c), T f g h → T f g k → h = k ) (* composite is unique *) × (∏ (a b c d : C) (f : a ⇒ b) (g : b ⇒ c) (h : c ⇒ d) (fg : a ⇒ c) (gh : b ⇒ d) (fg_h : a ⇒ d) (f_gh : a ⇒ d), T f g fg → T g h gh → T fg h fg_h → T f gh f_gh → f_gh = fg_h)). (* composition is assoc *) Lemma isaprop_folds_ax_T (C:folds_id_T) (hs: has_folds_homsets C): isaprop (folds_ax_T C). Proof. repeat (apply isapropdirprod). - do 5 (apply impred; intro). apply isapropishinh. - repeat (apply impred; intro). apply hs. - repeat (apply impred; intro). apply hs. Qed. Definition folds_precat := ∑ C : folds_id_T, folds_ax_I C × folds_ax_T C. Definition folds_id_comp_from_folds_precat (C : folds_precat) : folds_id_T := pr1 C. Coercion folds_id_comp_from_folds_precat : folds_precat >-> folds_id_T. (** * Some lemmas about FOLDS precategories *) (** used later to go to precategories; we define - identity as a function - composition as a function *) Section some_lemmas_about_folds_precats. Variable C : folds_precat. Lemma I_unique : ∏ (a : C) (i i' : a ⇒ a), I i → I i' → i = i'. Proof. intros a i i' Hi Hi'. destruct C as [CC [Cid Ccomp]]; simpl in *. assert (H1 : T i i' i). { apply (pr1 (pr2 Cid) _ _ _ _ ). assumption. } assert (H2 : T i i' i'). { apply (pr2 (pr2 Cid) _ _ _ _ ) . assumption. } apply (pr1 (pr2 Ccomp) _ _ _ _ _ _ _ H1 H2). Qed. Lemma I_contr : ∏ a : C, iscontr (∑ f : a ⇒ a, I f). Proof. intro a. set (H := pr1 (pr1 (pr2 C)) a). set (H' := make_hProp (iscontr (∑ f : a ⇒ a, I f)) (isapropiscontr _ )). apply (H H'); simpl. intro t; exists t. intro t'. apply subtypePath. - intro b; apply pr2. - destruct t; destruct t'; apply I_unique; assumption. Defined. Definition I_func (a : C) : a ⇒ a := pr1 (pr1 (I_contr a)). Lemma I_func_I (a : C) : I (I_func a). Proof. apply (pr2 (pr1 (I_contr a))). Defined. Lemma T_contr : ∏ (a b c : C) (f : a ⇒ b) (g : b ⇒ c), iscontr (∑ h, T f g h). Proof. intros a b c f g. set (H' := make_hProp (iscontr (∑ h : a ⇒ c, T f g h)) (isapropiscontr _ )). apply (pr1 (pr2 (pr2 C)) a b c f g H'). simpl; intro t; exists t. intro t'. apply subtypePath. - intro; apply pr2. - destruct t as [t tp]; destruct t' as [t' tp']; simpl in *. apply (pr1 (pr2 (pr2 (pr2 C))) _ _ _ f g ); assumption. Defined. Definition T_func {a b c : C} (f : a ⇒ b) (g : b ⇒ c) : a ⇒ c := pr1 (pr1 (T_contr a b c f g)). Local Notation "f ∘ g" := (T_func f g). Lemma T_func_T {a b c : C} (f : a ⇒ b) (g : b ⇒ c) : T f g (f ∘ g). Proof. apply (pr2 (pr1 (T_contr a b c f g))). Defined. Lemma T_I_l (a b : C) (f : a ⇒ b) : f ∘ (I_func b) = f. Proof. assert (H : T f (I_func b) f). { apply (pr1 (pr2 (pr1 (pr2 C)))). apply I_func_I. } assert (H' : T f (I_func b) (T_func f (I_func b))). { apply T_func_T. } set (H2 := pr1 (pr2 (pr2 (pr2 C)))). apply (H2 _ _ _ _ _ _ _ H' H). Defined. Lemma T_I_r (a b : C) (f : a ⇒ b) : (I_func a) ∘ f = f. Proof. assert (H : T (I_func a) f f). { apply (pr2 (pr2 (pr1 (pr2 C)))). apply I_func_I. } assert (H' : T (I_func a) f (T_func (I_func a) f)). { apply T_func_T. } set (H2 := pr1 (pr2 (pr2 (pr2 C)))). apply (H2 _ _ _ _ _ _ _ H' H). Defined. Lemma T_assoc (a b c d : C) (f : a ⇒ b) (g : b ⇒ c) (h : c ⇒ d) : f ∘ (g ∘ h) = (f ∘ g) ∘ h. Proof. apply (pr2 (pr2 (pr2 (pr2 C))) a b c d f g h (f ∘ g) (g ∘ h)). - apply T_func_T. - apply T_func_T. - apply T_func_T. - apply T_func_T. Defined. End some_lemmas_about_folds_precats. UniMath-20231010/UniMath/Folds/from_precats_to_folds_and_back.v000066400000000000000000000170751451125700300243030ustar00rootroot00000000000000 (** Univalent FOLDS Benedikt Ahrens, following notes by Michael Shulman Contents of this file: - Map [folds_precat_from_precat] - Map [precat_from_folds_precat] - Identity [folds_precat_from_precat_precat_from_folds_precat] - Identity [precat_from_folds_precat_folds_precat_from_precat] - Lemmas to pass between the compositions via predicate [comp] and as function [compose] - Lemmas to pass between the identities via predicate [id] and as a function [identity] *) Require Import UniMath.Folds.UnicodeNotations. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.Folds.folds_precat. Local Open Scope cat. Local Notation "a ⇒ b" := (precategory_morphisms a b). (** * From precategories to FOLDS precategories *) Section from_precats_to_folds. Section data. Variable C : precategory_data. Variable hsC : has_homsets C. (** identity as a predicate *) Definition id_pred {a : C} : a ⇒ a → hProp := λ f, make_hProp (f = identity _ ) (hsC a a _ _) . Lemma id_pred_id (a : C) : id_pred (identity a). Proof. apply idpath. Qed. (** composition as a predicate *) Definition comp_pred {a b c : C} : a ⇒ b → b ⇒ c → a ⇒ c → hProp := λ f g fg, make_hProp (compose f g = fg) (hsC _ _ _ _ ). Lemma comp_pred_comp (a b c : C) (f : a ⇒ b) (g : b ⇒ c) : comp_pred f g (compose f g). Proof. apply idpath. Defined. Definition folds_id_comp_from_precat_data : folds_id_T := tpair (λ C : folds_ob_mor, (∏ a : C, a ⇒ a → hProp) × (∏ (a b c : C), (a ⇒ b) → (b ⇒ c) → (a ⇒ c) → hProp)) (pr1 C) (make_dirprod (@id_pred) (@comp_pred)). End data. Variable C : precategory. Hypothesis hs: has_homsets C. (** FOLDS precategory from precategory *) Definition folds_precat_from_precat : folds_precat. Proof. exists (folds_id_comp_from_precat_data C hs). repeat split. - intro a. apply hinhpr. exists (identity a). apply idpath. - intros; unfold T; simpl. intermediate_path (compose f (identity _ )). + apply maponpaths; assumption. + apply id_right. - intros; unfold T; simpl. intermediate_path (compose (identity _ ) f). + rewrite X. apply idpath. + apply id_left. - intros a b c f g. apply hinhpr. exists (compose f g). apply idpath. - simpl. intros a b c f g h k H1 H2. intermediate_path (compose f g). + apply pathsinv0. apply H1. + apply H2. - simpl. intros a b c d f g h fg gh fg_h f_gh H1 H2 H3 H4. rewrite <- H4, <- H3, <- H2, <- H1. apply assoc. Defined. End from_precats_to_folds. (** * From FOLDS precategories to precategories *) Section from_folds_to_precats. Variable C : folds_precat. (** precategory from FOLDS precategory *) Definition precat_from_folds_data : precategory_data := tpair (λ C : precategory_ob_mor, precategory_id_comp C) (pr1 (pr1 C)) (make_dirprod (I_func C)(@T_func C)). Lemma is_precategory_precat_from_folds_data : is_precategory precat_from_folds_data. Proof. apply is_precategory_one_assoc_to_two. repeat split. - apply T_I_r. - apply T_I_l. - apply T_assoc. Qed. Definition precat_from_folds_precat : precategory := tpair _ _ is_precategory_precat_from_folds_data. End from_folds_to_precats. (** * From FOLDS precats to precats to FOLDS precats *) Lemma folds_precat_from_precat_precat_from_folds_precat (C : folds_precat)(hs:has_folds_homsets C): folds_precat_from_precat (precat_from_folds_precat C) hs = C. Proof. apply subtypePath'. 2: { intro a; apply isapropdirprod. + apply isaprop_folds_ax_id. + apply isaprop_folds_ax_T. apply hs. } set (Hid := I_contr C). set (Hcomp := T_contr C). destruct C as [Cd CC]; simpl in *. destruct Cd as [Ca Cb]; simpl in *. unfold folds_id_comp_from_precat_data. apply maponpaths. destruct CC as [C1 C2]. simpl in *. destruct Cb as [Cid Ccomp]. simpl in *. apply pathsdirprod. + apply funextsec. intro a. apply funextsec. intro f. unfold id_pred. simpl. apply subtypePath. { intro. apply isapropisaprop. } simpl. apply weqtopaths. apply weqimplimpl. * intro H. rewrite H. set (Hid' := pr1 (Hid a)). apply (pr2 (Hid')). * intro H. unfold precategory_morphisms in f. set (H2 := pr2 (Hid a)). simpl in H2. apply (path_to_ctr). assumption. * apply hs. (* apply (pr2 (precategory_morphisms _ _ )). *) * apply (pr2 (Cid a f)). + apply funextsec; intro a. apply funextsec; intro b. apply funextsec; intro c. apply funextsec; intro f. apply funextsec; intro g. apply funextsec; intro fg. clear Hid. apply subtypePath. { intro; apply isapropisaprop. } apply weqtopaths. apply weqimplimpl. * intro H. simpl in *. rewrite <- H. apply (pr2 (pr1 (Hcomp a b c f g))). * simpl. intro H. apply pathsinv0. apply path_to_ctr. assumption. * simpl in *. apply hs. (* apply (pr2 (precategory_morphisms _ _ )). *) * apply (pr2 (Ccomp _ _ _ _ _ _ )). Qed. (** * From precats to FOLDS precats to precats *) Lemma precat_from_folds_precat_folds_precat_from_precat (C : precategory)(hs: has_homsets C) : precat_from_folds_precat (folds_precat_from_precat C hs) = C. Proof. apply subtypePath'. 2: { intro; apply isaprop_is_precategory. assumption. } destruct C as [Cdata Cax]; simpl in *. destruct Cdata as [Cobmor Cidcomp]; simpl in *. unfold precat_from_folds_data. simpl. apply maponpaths. destruct Cidcomp as [Cid Ccomp]; simpl in *. apply pathsdirprod. - apply funextsec; intro a. apply pathsinv0. apply path_to_ctr. apply idpath. - apply funextsec; intro a. apply funextsec; intro b. apply funextsec; intro c. apply funextsec; intro f. apply funextsec; intro g. apply pathsinv0. apply path_to_ctr. apply idpath. Qed. (** * Some lemmas to pass from [comp] to [compose] and back **) Local Notation "C ^" := (folds_precat_from_precat C) (at level 3). Local Notation "C ^^" := (precat_from_folds_precat C) (at level 3). Lemma comp_compose {C : precategory} (hs: has_homsets C) {a b c : C} {f : a ⇒ b} {g : b ⇒ c} {h : a ⇒ c} : f · g = h -> T (C:=C^hs) f g h. Proof. apply (λ x, x). Qed. Lemma comp_compose' {C : precategory} (hs: has_homsets C){a b c : C} {f : a ⇒ b} {g : b ⇒ c} {h : a ⇒ c} : T (C:=C^hs) f g h -> f · g = h. Proof. apply (λ x, x). Qed. Lemma comp_compose2 {C : folds_precat} {a b c : C} {f : folds_morphisms a b} {g : folds_morphisms b c} {h : folds_morphisms a c} : compose (C:= C^^) f g = h -> T f g h. Proof. intro H; rewrite <- H. apply T_func_T. Qed. Lemma comp_compose2' {C : folds_precat} {a b c : C} {f : folds_morphisms a b} {g : folds_morphisms b c} {h : folds_morphisms a c} : T f g h -> compose (C:=C^^) f g = h. Proof. intro H. apply pathsinv0. apply path_to_ctr. assumption. Qed. (** * Some lemmas to pass from [id] to [identity] and back **) Lemma id_identity {C : precategory} (hs: has_homsets C){a : C} {f : a ⇒ a} : f = identity _ -> I (C:=C^hs) f. Proof. apply (λ x, x). Qed. Lemma id_identity' {C : precategory} (hs: has_homsets C){a : C} {f : a ⇒ a} : I (C:=C^hs) f -> f = identity _ . Proof. apply (λ x, x). Qed. Lemma id_identity2 {C : folds_precat} {a : C} {f : a ⇒ a} : f = identity (C:=C^^) _ -> I f. Proof. intro H; rewrite H. apply I_func_I. Qed. Lemma id_identity2' {C : folds_precat} {a : C} {f : a ⇒ a} : I f -> f = identity (C:=C^^) _ . Proof. intro H. apply path_to_ctr; assumption. Qed. UniMath-20231010/UniMath/Foundations/000077500000000000000000000000001451125700300171455ustar00rootroot00000000000000UniMath-20231010/UniMath/Foundations/.package/000077500000000000000000000000001451125700300206165ustar00rootroot00000000000000UniMath-20231010/UniMath/Foundations/.package/files000066400000000000000000000002211451125700300216360ustar00rootroot00000000000000Init.v Preamble.v PartA.v PartB.v UnivalenceAxiom.v PartC.v PartD.v UnivalenceAxiom2.v Propositions.v Sets.v NaturalNumbers.v Tests.v HLevels.v UniMath-20231010/UniMath/Foundations/HLevels.v000066400000000000000000000120051451125700300206740ustar00rootroot00000000000000(** * [HLevel(n)] is of hlevel n+1 *) (** Authors: Benedikt Ahrens, Chris Kapulkin Title: HLevel(n) is of hlevel n+1 Date: December 2012 *) (** In this file we prove the main result of this work: the type of types of hlevel n is itself of hlevel n+1. *) Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.UnivalenceAxiom. (** ** Weak equivalence between identity types in [HLevel] and [U] *) (** To show that HLevel(n) is of hlevel n + 1, we need to show that its path spaces are of hlevel n. First, we show that each of its path spaces equivalent to the path space of the underlying types. More generally, we prove this for any predicate [P : UU -> hProp] which we later instantiate with [P := isofhlevel n]. *) (** Overview of the proof: Identity of Sigmas <~> Sigma of Identities <~> Identities in [U] , where the first equivalence is called [weq1] and the second one is called [weq2]. *) Local Lemma weq1 (P : UU -> hProp) (X X' : UU) (p : P X) (p' : P X') : (X,, p) = (X',, p' : ∑ (T : UU), P T ) ≃ (∑ w : X = X', transportf P w p = p'). Proof. apply total2_paths_equiv. Defined. (** This helper lemma is needed to show that our fibration is indeed a predicate, so that we can instantiate the hProposition [P] with this fibration. *) Local Lemma ident_is_prop (P : UU -> hProp) (X X' : UU) (p : P X) (p' : P X') (w : X = X') : isaprop (transportf P w p = p'). Proof. apply isapropifcontr. apply (pr2 (P X')). Defined. (** We construct the equivalence [weq2] as a projection from a total space, which, by the previous lemma, is a weak equivalence. *) Local Lemma weq2 (P : UU -> hProp) (X X' : UU) (p : P X) (p' : P X') : (∑ w : X = X', transportf P w p = p') ≃ (X = X'). Proof. use weqpr1. intro. cbn. apply (pr2 (P X')). Defined. (** Composing [weq1] and [weq2] yields the desired weak equivalence. *) Local Lemma Id_p_weq_Id (P : UU -> hProp) (X X' : UU) (p : P X) (p' : P X') : (X ,, p) = (X',, p' : ∑ T , P T) ≃ X = X'. Proof. set (f := weq1 P X X' p p'). set (g := weq2 P X X' p p'). set (fg := weqcomp f g). exact fg. Defined. (** ** Hlevel of path spaces *) (** We show that if [X] and [X'] are of hlevel [n], then so is their identity type [X = X']. *) (** The proof works differently for [n = 0] and [n = S n'], so we treat these two cases in separate lemmas [isofhlevel0pathspace] and [isofhlevelSnpathspace] and put them together in the lemma [isofhlevelpathspace]. *) (** *** The case [n = 0] *) Lemma iscontr_weq (X Y : UU) : iscontr X → iscontr Y → iscontr (X ≃ Y). Proof. intros cX cY. exists (weqcontrcontr cX cY ). intro f. apply subtypePath. { exact isapropisweq. } apply funextfun. cbn. intro x. apply (pr2 cY). Defined. Lemma isofhlevel0pathspace (X Y : UU) : iscontr X -> iscontr Y -> iscontr (X = Y). Proof. intros pX pY. set (H := isofhlevelweqb 0 (eqweqmap ,, univalenceAxiom X Y)). apply H. clear H. apply iscontr_weq; assumption. Defined. (** *** The case [n = S n'] *) Lemma isofhlevelSnpathspace : ∏ n : nat, ∏ X Y : UU, isofhlevel (S n) Y -> isofhlevel (S n) (X = Y). Proof. intros n X Y pY. set (H:=isofhlevelweqb (S n) (eqweqmap ,, univalenceAxiom X Y)). apply H. apply isofhlevelsnweqtohlevelsn. assumption. Defined. (** ** The lemma itself *) Lemma isofhlevelpathspace : ∏ n : nat, ∏ X Y : UU, isofhlevel n X -> isofhlevel n Y -> isofhlevel n (X = Y). Proof. intros n. induction n as [| n _ ]. - intros X Y pX pY. apply isofhlevel0pathspace; assumption. - intros. apply isofhlevelSnpathspace; assumption. Defined. (** ** HLevel *) (** We define the type [HLevel n] of types of hlevel n. *) Definition HLevel (n : nat) : UU := ∑ X : UU, isofhlevel n X. (** * Main theorem: [HLevel n] is of hlevel [S n] *) Lemma isofhlevel_HLevel (n : nat) : isofhlevel (S n) (HLevel n). Proof. cbn. intros X X'. induction X as [X p]. induction X' as [X' p']. set (H := isofhlevelweqb n (Id_p_weq_Id (λ X, (isofhlevel n X,, isapropisofhlevel _ _)) X X' p p')). cbn in H. apply H. apply isofhlevelpathspace; assumption. Defined. (** ** Aside: Univalence for predicates and hlevels *) (** As a corollary from [Id_p_weq_Id], we obtain a version of the Univalence Axiom for predicates on the universe [U]. In particular, we can instantiate this predicate with [isofhlevel n]. *) Lemma UA_for_Predicates (P : UU -> hProp) (X X' : UU) (pX : P X) (pX' : P X') : (tpair _ X pX) = (tpair P X' pX') ≃ (X ≃ X'). Proof. set (f := Id_p_weq_Id P X X' pX pX'). set (g := tpair _ _ (univalenceAxiom X X')). exact (weqcomp f g). Defined. Corollary UA_for_HLevels : ∏ (n : nat) (X X' : HLevel n), (X = X') ≃ (pr1 X ≃ pr1 X'). Proof. intros n [X pX] [X' pX']. simpl. apply (UA_for_Predicates (λ X, tpair isaprop (isofhlevel n X) (isapropisofhlevel _ _))). Defined. UniMath-20231010/UniMath/Foundations/Init.v000066400000000000000000000162131451125700300202420ustar00rootroot00000000000000(** Initial setup unrelated to Univalent Foundations *) Require Export Coq.Init.Notations. (* get the standard Coq reserved notations *) From Coq Require Export Ltac. (* get the tactics *) (** Notations *) Notation "'∏' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. (* type this in emacs in agda-input method with \prod *) Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) (at level 200, x binder, y binder, right associativity). (* type this in emacs in agda-input method with \lambda *) Notation "A -> B" := (forall (_ : A), B) : type_scope. Notation "X <- Y" := (Y -> X) (at level 90, only parsing, left associativity) : type_scope. Notation "x → y" := (x -> y) (at level 99, y at level 200, right associativity): type_scope. (* written \to or \r- in Agda input method *) (* the level comes from sub/coq/theories/Unicode/Utf8_core.v *) (** Reserved notations *) Reserved Notation "x :: y" (at level 60, right associativity). (* originally in Coq.Init.Datatypes *) Reserved Notation "x ++ y" (at level 60, right associativity). (* originally in Coq.Init.Datatypes *) Reserved Notation "p # x" (right associativity, at level 65). Reserved Notation "a ╝ b" (at level 70, no associativity). (* in agda input mode use \--= and select the 6-th one in the first set, or use \chimney *) Reserved Notation "X ≃ Y" (at level 80, no associativity). (* written \~- or \simeq in Agda input method *) Reserved Notation "p #' x" (right associativity, at level 65). Reserved Notation "f ~ g" (at level 70, no associativity). Reserved Notation "p @ q" (at level 60, right associativity). Reserved Notation "'¬¬' X" (at level 35, right associativity). (* type this in emacs in agda-input method with \neg twice *) Reserved Notation "x != y" (at level 70). Reserved Notation "'¬' X" (at level 35, right associativity). (* type this in emacs in agda-input method with \neg *) Reserved Notation "A × B" (at level 75, right associativity). Reserved Notation "C ⟦ a , b ⟧" (at level 49, right associativity). (* ⟦ to input: type "\[[" or "\(" with Agda input method ⟧ to input: type "\]]" or "\)" with Agda input method *) Reserved Notation "⟦ a ⟧" (at level 48, left associativity). Reserved Notation "f ;; g" (at level 50, left associativity, format "f ;; g"). (* deprecated *) Reserved Notation "g ∘ f" (at level 40, left associativity). (* to input: type "\circ" with Agda input method *) Reserved Notation "f · g" (at level 40, left associativity). (* to input: type "\centerdot" or "\cdot" with Agda input method *) Reserved Notation "a --> b" (at level 55). Reserved Notation "! p " (at level 50, left associativity). (* conflict: Reserved Notation "# F" (at level 3). Reserved Notation "p # x" (right associativity, at level 65, only parsing). *) Reserved Notation "p #' x" (right associativity, at level 65). Reserved Notation "C '^op'" (at level 3, format "C ^op"). Reserved Notation "q '^-1'" (at level 10). Reserved Notation "a <-- b" (at level 55). Reserved Notation "[ C , D ]" . Reserved Notation "C [ a , b ]" (at level 50, left associativity). Reserved Notation "X ⟶ Y" (at level 39). (* to input: type "\-->" with Agda input method *) Reserved Notation "X ⟹ Y" (at level 39). (* same parsing level as ⟶ *) (* to input: type "\==>" with Agda input method *) Reserved Notation "F ∙ G" (at level 35). (* to input: type "\." with Agda input method *) (* the old notation had the arguments in the opposite order *) (* conflict: Reserved Notation "s □ x" (at level 64, left associativity). Reserved Notation "G □ F" (at level 35). (* to input: type "\Box" or "\square" or "\sqw" or "\sq" with Agda input method *) *) Reserved Notation "X ⊗ Y" (at level 40, left associativity). (* to input: type "\ox" or "\otimes" with Agda input method *) Reserved Notation "f '⊗₁' g" (at level 40, left associativity). Reserved Notation "α '⊗₂' β" (at level 40, left associativity). Reserved Notation "F ◾ b" (at level 36, left associativity). (* to input: type "\sqb" or "\sq" with Agda input method *) Reserved Notation "F ▭ f" (at level 36, left associativity). (* to input: type "\rew" or "\re" with Agda input method *) Reserved Notation "A ⇒ B" (at level 95, right associativity). (* to input: type "\Rightarrow" or "\r=" or "\r" or "\Longrightarrow" or "\=>" with Agda input method *) Reserved Notation "X ⇐ c" (at level 94, left associativity). (* to input: type "\Leftarrow" or "\Longleftarrow" or "\l=" or "\l" with Agda input method *) Reserved Notation "x ⟲ f" (at level 50, left associativity). (* to input: type "\l" and select from the menu, row 4, spot 2, with Agda input method *) Reserved Notation "q ⟳ x" (at level 50, left associativity). (* to input: type "\r" and select from the menu, row 4, spot 3, with Agda input method *) Reserved Notation "p ◽ b" (at level 36). (* to input: type "\sqw" or "\sq" with Agda input method *) Reserved Notation "xe ⟲⟲ p" (at level 50, left associativity). (* to input: type "\l" and select from the menu, row 4, spot 2, with Agda input method *) Reserved Notation "r \\ x" (at level 50, left associativity). Reserved Notation "x // r" (at level 50, left associativity). Reserved Notation "X ⨿ Y" (at level 50, left associativity). (* type this in emacs with C-X 8 RET AMALGAMATION OR COPRODUCT *) Reserved Notation "x ,, y" (at level 60, right associativity). Reserved Notation "A ⊕ B" (at level 50, left associativity). (* to input: type "\o+" or "\oplus" with Agda input method *) Reserved Notation "A ↣ B" (at level 50). (* to input: type "\r->" or "\rightarrowtail" or "\r" with Agda input method *) Reserved Notation "B ↠ C" (at level 50). (* to input: type "\rr-" or "\r" or "\twoheadrightarrow" with Agda input method *) (** Tactics *) (* Apply this tactic to a proof of ([X] and [X -> ∅]), in either order: *) Ltac contradicts a b := solve [ induction (a b) | induction (b a) ]. (** A few more tactics, thanks go to Jason Gross *) Ltac simple_rapply p := simple refine p || simple refine (p _) || simple refine (p _ _) || simple refine (p _ _ _) || simple refine (p _ _ _ _) || simple refine (p _ _ _ _ _) || simple refine (p _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || simple refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _). Tactic Notation "use" uconstr(p) := simple_rapply p. Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := simple refine (let name := (_ : type) in _). Ltac exact_op x := (* from Jason Gross: same as "exact", but with unification the opposite way *) let T := type of x in let G := match goal with |- ?G => constr:(G) end in exact (((λ g:G, g) : T -> G) x). Create HintDb rewrite discriminated. #[global] Hint Variables Opaque : rewrite. Create HintDb typeclass_instances discriminated. UniMath-20231010/UniMath/Foundations/NaturalNumbers.v000066400000000000000000001730051451125700300223040ustar00rootroot00000000000000(** * Natural numbers and their properties. Vladimir Voevodsky. Apr. - Sep. 2011 This file contains the formulations and proofs of general properties of natural numbers from the univalent perspecive. *) (** ** Contents - Equality and inequality on [nat] - Basic properties of [paths] on [nat] and the proofs of [isdeceq] and [isaset] for [nat] - [S : nat -> nat] is a decidable inclusion - Inequalities on [nat] - Boolean "less of equal" and "greater or equal" on [nat] - Semi-boolean "greater" on [nat] or [natgth] - Semi-boolean "less" on [nat] or [natlth] - Semi-boolean "less or equal" on [nat] or [natleh] - Semi-boolean "greater or equal" on [nat] or [natgeh] - Simple implications between comparisons - Comparison alternatives - Mixed transitivities - Two comparisons and [S] - Comparison alternatives and [S] - Some properties of [plus] on [nat] - The structure of the additive abelian monoid on [nat] - Addition and comparisons - Comparisons and [n -> n + 1] - Two comparisons and [n -> n + 1] - Comparison alternatives and [n -> n + 1] - Cancellation properties of [plus] on [nat] - Some properties of [minus] on [nat] - Basic algebraic properties of [mul] on [nat] - [nat] as a commutative rig - Cancellation properties of [mul] on [nat] - Multiplication and comparisons - Properties of comparisons in the terminology of algebra1.v - Submonoid of non-zero elements in [nat] - Division with a remainder on [nat] - Exponentiation [natpower n m] ("n to the power of m") on [nat] - Factorial on [nat] - The order-preserving functions [di i : nat -> nat] whose image is the complement of one element [i]. - The order-preserving functions [si i : nat -> nat] that take the value [i] twice. - Inductive types [le] with values in [UU] - A generalization of [le] and its properties - Inductive types [le] with values in [UU] are in [hProp] - Comparison between [le] with values in [UU] and [natleh] *) (** ** Preamble *) (** Imports. *) Require Export UniMath.Foundations.Sets. (** To up-stream files *) (** ** Equality and inequality on [nat] *) (* we will write m ≠ n for algorithmic inequality and ¬(m = n) for negation of equality *) Definition natnegpaths (x y : nat) : hProp := make_hProp (x != y) (isapropneg _). Fixpoint natneq_hProp (n m : nat) : hProp := match n, m with | S n, S m => natneq_hProp n m | O, O => hfalse | _, _ => htrue end. (* Provisional notation, to be replaced below: *) Notation " x ≠ y " := (natneq_hProp x y) (at level 70, no associativity) : nat_scope. Lemma negpaths0sx (x : nat) : ¬ (0 = S x). Proof. set (f := λ n : nat, match n with O => true | S m => false end). apply (negf (@maponpaths _ _ f 0 (S x)) nopathstruetofalse). Defined. Lemma negpathssx0 (x : nat) : ¬ (S x = 0). Proof. intros X. apply (negpaths0sx x (pathsinv0 X)). Defined. Lemma invmaponpathsS (n m : nat) : S n = S m -> n = m. Proof. intros e. set (f := λ n : nat, match n with O => O | S m => m end). apply (@maponpaths _ _ f (S n) (S m) e). Defined. Lemma noeqinjS (x x' : nat) : ¬ (x = x') -> ¬ (S x = S x'). Proof. apply (negf (invmaponpathsS x x')). Defined. Lemma natneq_iff_neq n m : ¬ (n = m) <-> n ≠ m. Proof. revert m. induction n as [|n N]. - intro m. induction m as [|m _]. + apply logeq_both_false. * intro n. exact (n (idpath 0)). * simpl. exact (idfun ∅). + apply logeq_both_true. * apply negpaths0sx. * simpl. exact tt. - intro m. induction m as [|m _]. + apply logeq_both_true. * apply negpathssx0. * simpl. exact tt. + split. * intro ne. apply (pr1 (N m)). intro r. exact (ne (maponpaths S r)). * intro neq. apply noeqinjS. apply (pr2 (N m)). exact neq. Defined. Lemma nat_neq_to_nopath {n m : nat} : ¬ (n = m) <- n ≠ m. Proof. exact (pr2 (natneq_iff_neq n m)). Defined. Lemma nat_nopath_to_neq {n m : nat} : ¬ (n = m) -> n ≠ m. Proof. exact (pr1 (natneq_iff_neq n m)). Defined. Lemma natneq0sx (x : nat) : 0 ≠ S x. Proof. apply nat_nopath_to_neq, negpaths0sx. Defined. Lemma natneqsx0 (x : nat) : S x ≠ 0. Proof. apply nat_nopath_to_neq, negpathssx0. Defined. Lemma natneqinjS (x x' : nat) : x ≠ x' -> S x ≠ S x'. Proof. intros r. apply nat_nopath_to_neq, noeqinjS, nat_neq_to_nopath. assumption. Defined. Lemma isirrefl_natneq i : ¬ (i ≠ i). Proof. intros ne. apply (nat_neq_to_nopath ne). apply idpath. Defined. Lemma issymm_natneq i j : i ≠ j -> j ≠ i. Proof. intros ne. apply nat_nopath_to_neq. intro eq. induction eq. exact (isirrefl_natneq j ne). Defined. (** *** Basic properties of [paths] on [nat] and the proofs of [isdeceq] and [isaset] for [nat]. *) Definition isdeceqnat: isdeceq nat. Proof. unfold isdeceq. intro x. induction x as [ | x IHx ]. - intro x'. induction x'. + apply (ii1 (idpath O)). + apply (ii2 (negpaths0sx x')). - intro x'. induction x'. + apply (ii2 (negpathssx0 x)). + induction (IHx x') as [ p | e ]. * apply (ii1 (maponpaths S p)). * apply (ii2 (noeqinjS _ _ e)). Defined. Definition isisolatedn (n : nat) : isisolated _ n. Proof. unfold isisolated. intro x'. apply isdeceqnat. Defined. Theorem isasetnat: isaset nat. Proof. apply (isasetifdeceq _ isdeceqnat). Defined. Definition natset : hSet := make_hSet _ isasetnat. Lemma nat_eq_or_neq (m n : nat) : (m = n) ⨿ (m ≠ n). Proof. revert m. induction n as [|n N]. - intro m. induction m as [|m _]. + apply ii1. apply idpath. + apply ii2. exact tt. - intro m. induction m as [|m _]. + apply ii2. exact tt. + induction (N m) as [eq|neq]. * apply ii1, maponpaths. assumption. * apply ii2. assumption. Defined. Definition isdecrel_natneq : isdecrel (λ m n, m ≠ n). Proof. intros n. induction n as [|n N]. - intro m. induction m as [|m _]. + simpl. exact (ii2 (idfun ∅)). + simpl. exact (ii1 tt). - intro m. induction m as [|m _]. + simpl. exact (ii1 tt). + exact (N m). Defined. Definition nateq (x y : nat) : hProp := make_hProp (x = y) (isasetnat _ _). Definition isdecrelnateq : isdecrel nateq := λ a b, isdeceqnat a b. Definition natdeceq : decrel nat := make_decrel isdecrelnateq. Definition natdecneq : decrel nat := make_decrel isdecrel_natneq. Definition natboolneq : brel nat := decreltobrel natdecneq. (** *** [ S : nat -> nat ] is a decidable inclusion. *) Theorem isinclS : isincl S. Proof. apply (isinclbetweensets S isasetnat isasetnat invmaponpathsS). Defined. Theorem isdecinclS : isdecincl S. Proof. intro n. apply isdecpropif. - apply (isinclS n). - destruct n as [ | n ]. + assert (nh : ¬ (hfiber S 0)). * intro hf. induction hf as [ m e ]. apply (negpathssx0 _ e). * apply (ii2 nh). + apply (ii1 (make_hfiber _ n (idpath _))). Defined. (** ** Inequalities on [nat]. *) (** *** Boolean "less or equal" and "greater or equal" on [nat]. *) Fixpoint natgtb (n m : nat) : bool := match n, m with | S n, S m => natgtb n m | O, _ => false | _, _ => true end. (** *** Semi-boolean "greater" on [nat] or [natgth] 1. Note that due to its definition [natgth] automatically has the property that [natgth n m <-> natgth (S n) (S m)] and the same applies to all other inequalities defined in this section. 2. We choose "greater" as the root relation from which we define all other relations on [nat] because it is more natural to extend "greater" to integers and then to rationals than it is to extend "less". *) Definition natgth (n m : nat) : hProp := make_hProp (natgtb n m = true) (isasetbool _ _). Notation " x > y " := (natgth x y) : nat_scope. Lemma negnatgth0n (n : nat) : ¬ (0 > n). Proof. simpl. intro np. apply (nopathsfalsetotrue np). Defined. Lemma natgthsnn (n : nat) : S n > n. Proof. induction n as [ | n IHn ]. - apply idpath. - apply IHn. Defined. Lemma natgthsn0 (n : nat) : S n > 0. Proof. simpl. apply idpath. Defined. Lemma negnatgth0tois0 (n : nat) (ng : ¬ (n > 0)) : n = 0. Proof. revert ng. destruct n as [ | n ]. - intro. apply idpath. - intro ng. induction (ng (natgthsn0 _)). Defined. Lemma natneq0togth0 (n : nat) (ne : n ≠ 0) : n > 0. Proof. intros. destruct n as [ | n ]. - induction ne. - apply natgthsn0. Defined. Lemma nat1gthtois0 (n : nat) (g : 1 > n) : n = 0. Proof. revert g. destruct n as [ | n ]. - intro. apply idpath. - intro x. induction (negnatgth0n n x). Defined. Lemma istransnatgth (n m k : nat) : n > m -> m > k -> n > k. Proof. revert m k. induction n as [ | n IHn ]. - intros m k g. induction (negnatgth0n _ g). - intro m. destruct m as [ | m ]. + intros k g g'. induction (negnatgth0n _ g'). + intro k. destruct k as [ | k ]. * intros. apply natgthsn0. * apply (IHn m k). Defined. Lemma isirreflnatgth (n : nat) : ¬ (n > n). Proof. induction n as [ | n IHn ]. - apply (negnatgth0n 0). - apply IHn. Defined. Notation negnatlthnn := isirreflnatgth. Lemma natgthtoneq (n m : nat) (g : n > m) : n ≠ m. Proof. intros. apply nat_nopath_to_neq. intro e. rewrite e in g. apply (isirreflnatgth _ g). Defined. Lemma isasymmnatgth (n m : nat) : n > m -> m > n -> empty. Proof. intros is is'. apply (isirreflnatgth n (istransnatgth _ _ _ is is')). Defined. Lemma isantisymmnegnatgth (n m : nat) : ¬ (n > m) -> ¬ (m > n) -> n = m. Proof. revert m. induction n as [ | n IHn ]. - intros m ng0m ngm0. apply (pathsinv0 (negnatgth0tois0 _ ngm0)). - intro m. destruct m as [ | m ]. + intros ngsn0 ng0sn. induction (ngsn0 (natgthsn0 _)). + intros ng1 ng2. apply (maponpaths S (IHn m ng1 ng2)). Defined. Lemma isdecrelnatgth : isdecrel natgth. Proof. intros n m. apply (isdeceqbool (natgtb n m) true). Defined. Definition natgthdec := make_decrel isdecrelnatgth. Lemma isnegrelnatgth : isnegrel natgth. Proof. apply isdecreltoisnegrel. apply isdecrelnatgth. Defined. Lemma iscoantisymmnatgth (n m : nat) : ¬ (n > m) -> (m > n) ⨿ (n = m). Proof. revert n m. apply isantisymmnegtoiscoantisymm. - apply isdecrelnatgth. - intros n m. apply isantisymmnegnatgth. Defined. Lemma iscotransnatgth (n m k : nat) : n > k -> (n > m) ⨿ (m > k). Proof. intros gnk. induction (isdecrelnatgth n m) as [ p | np ]. - apply ii1. assumption. - apply ii2. induction (isdecrelnatgth m n) as [r|nr]. + apply (istransnatgth _ _ _ r gnk). + assert (e := isantisymmnegnatgth _ _ np nr); clear np nr. induction e. assumption. Defined. (** *** Semi-boolean "less" on [nat] or [natlth] *) Definition natlth (n m : nat) := m > n. Notation " x < y " := (natlth x y) : nat_scope. Definition negnatlthn0 (n : nat) : ¬ (n < 0) := negnatgth0n n. Definition natlthnsn (n : nat) : n < S n := natgthsnn n. Definition negnat0lthtois0 (n : nat) (nl : ¬ (0 < n)) : n = 0 := negnatgth0tois0 n nl. Definition natneq0to0lth (n : nat) : n ≠ 0 -> 0 < n := natneq0togth0 n. Definition natlth1tois0 (n : nat) : n < 1 -> n = 0 := nat1gthtois0 _. Definition istransnatlth (n m k : nat) : n < m -> m < k -> n < k := λ lnm lmk, istransnatgth _ _ _ lmk lnm. Definition isirreflnatlth (n : nat) : ¬ (natlth n n) := isirreflnatgth n. Notation negnatgthnn := isirreflnatlth. Lemma natlthtoneq (n m : nat) (g : natlth n m) : n ≠ m. Proof. intros. apply nat_nopath_to_neq. intro e. rewrite e in g. apply (isirreflnatlth _ g). Defined. Definition isasymmnatlth (n m : nat) : natlth n m -> natlth m n -> empty := λ lnm lmn, isasymmnatgth _ _ lmn lnm. Definition isantisymmnegnattth (n m : nat) : ¬ (natlth n m) -> ¬ (natlth m n) -> n = m := λ nlnm nlmn, isantisymmnegnatgth _ _ nlmn nlnm. Definition isdecrelnatlth : isdecrel natlth := λ n m, isdecrelnatgth m n. Definition natlthdec := make_decrel isdecrelnatlth. Definition isnegrelnatlth : isnegrel natlth := λ n m, isnegrelnatgth m n. Definition iscoantisymmnatlth (n m : nat) : ¬ (natlth n m) -> (natlth m n) ⨿ (n = m). Proof. intros nlnm. induction (iscoantisymmnatgth m n nlnm) as [ l | e ]. - apply (ii1 l). - apply (ii2 (pathsinv0 e)). Defined. Definition iscotransnatlth (n m k : nat) : n < k -> (n < m) ⨿ (m < k). Proof. intros lnk. apply coprodcomm, iscotransnatgth. assumption. Defined. (** *** Semi-boolean "less or equal " on [nat] or [natleh] *) Definition natleh (n m : nat) := S m > n. Notation " x <= y " := (natleh x y) : nat_scope. Notation " x ≤ y " := (natleh x y) (at level 70, no associativity) : nat_scope. Definition isdecrelnatleh : isdecrel natleh := λ m n, isdecrelnatgth _ _. Definition negnatlehsn0 (n : nat) : ¬ (S n ≤ 0) := negnatlthn0 n. (* these two lemmas show agreement with the old definition: *) Lemma natlehneggth {n m : nat} : n ≤ m -> ¬ (n > m). Proof. revert m. induction n as [|n N]. - intros m _. exact (negnatgth0n m). - intros m. induction m as [|m _]. + intros r _. exact (negnatlehsn0 n r). + exact (N m). Defined. Lemma natgthnegleh {n m : nat} : n > m -> ¬ (n ≤ m). Proof. intros r s. exact (natlehneggth s r). Defined. Lemma negnatSleh n : ¬ (S n ≤ n). Proof. intros. unfold natleh. apply isirreflnatgth. Defined. Lemma negnatgthtoleh {n m : nat} : ¬ (n > m) -> n ≤ m. Proof. unfold natleh. revert m. induction n as [|n N]. - intros m r. exact (natgthsn0 m). - intro m. change (S m > S n) with (m > n). induction m as [|m _]. + intro r. contradicts (natgthsn0 n) r. + change (S n > S m) with (n > m). intro r. exact (N m r). Defined. Lemma negnatlehtogth {n m : nat} : n > m <- ¬ (n ≤ m). Proof. intros r. apply (isdecreltoisnegrel isdecrelnatgth). intro s. exact (r (negnatgthtoleh s)). Defined. Definition neggth_logeq_leh (n m : nat) : ¬ (n > m) <-> n ≤ m := (negnatgthtoleh,,natlehneggth). Definition natleh0tois0 {n : nat} (l : n ≤ 0) : n = 0 := natlth1tois0 n l. Definition natleh0n (n : nat) : 0 ≤ n := natgthsn0 _. Definition negnatlehsnn (n : nat) : ¬ (S n ≤ n) := isirreflnatlth _. Definition istransnatleh {n m k : nat} : n ≤ m -> m ≤ k -> n ≤ k. Proof. intros r s. apply negnatgthtoleh. assert (b := natlehneggth r); clear r. assert (c := natlehneggth s); clear s. intro r. induction (iscotransnatgth _ m _ r) as [t|t]. - contradicts b t. - contradicts c t. Defined. Definition isreflnatleh n : n ≤ n. Proof. intros. unfold natleh. apply natgthsnn. Defined. Definition isantisymmnatleh : isantisymm natleh. Proof. intros m. induction m as [|m M]. - intros n _ s. unfold natleh in s. apply pathsinv0. apply nat1gthtois0. exact s. - intros n. induction n as [|n _]. + intros r _. contradicts r (negnatlehsn0 m). + intros r s. change (S m ≤ S n) with (m ≤ n) in r. change (S n ≤ S m) with (n ≤ m) in s. apply (maponpaths S). apply M. * assumption. * assumption. Defined. Definition natlehdec : decrel nat := make_decrel isdecrelnatleh. Definition isnegrelnatleh : isnegrel natleh. Proof. apply isdecreltoisnegrel. apply isdecrelnatleh. Defined. Definition natlthtoleh (m n : nat) : m < n -> m ≤ n. Proof. intros r. unfold natleh. unfold natlth in r. generalize r. clear r. generalize m. clear m. induction n as [|n N]. - intros ? r. contradicts r (negnatgth0n m). - intros ? r. induction m as [|m _]. + apply natgthsn0. + change (S n > S m) with (n > m) in r. change (S (S n) > S m) with (S n > m). apply N. assumption. Defined. Definition iscoasymmnatleh (n m : nat) : ¬ (n ≤ m) -> m ≤ n. Proof. intros r. apply negnatgthtoleh. intros s. unfold natleh in r. apply r. apply natlthtoleh. assumption. Defined. Definition istotalnatleh : istotal natleh. Proof. intros x y. induction (isdecrelnatleh x y) as [ lxy | lyx ]. - apply (hinhpr (ii1 lxy)). - apply hinhpr. apply ii2. apply (iscoasymmnatleh _ _ lyx). Defined. (** *** Semi-boolean "greater or equal" on [nat] or [natgeh]. *) Definition natgeh (n m : nat) : hProp := m ≤ n. Notation " x >= y " := (natgeh x y) : nat_scope. Notation " x ≥ y " := (natgeh x y) (at level 70, no associativity) : nat_scope. Definition nat0gehtois0 (n : nat) (g : 0 ≥ n) : n = 0 := natleh0tois0 g. Definition natgehn0 (n : nat) : n ≥ 0 := natleh0n n. Definition negnatgeh0sn (n : nat) : ¬ (0 ≥ (S n)) := negnatlehsn0 n. Definition negnatgehnsn (n : nat) : ¬ (n ≥ (S n)) := negnatlehsnn n. Definition istransnatgeh (n m k : nat) : n ≥ m -> m ≥ k -> n ≥ k := λ gnm gmk, istransnatleh gmk gnm. Definition isreflnatgeh (n : nat) : n ≥ n := isreflnatleh _. Definition isantisymmnatgeh (n m : nat) : n ≥ m -> m ≥ n -> n = m := λ gnm gmn, isantisymmnatleh _ _ gmn gnm. Definition isdecrelnatgeh : isdecrel natgeh := λ n m, isdecrelnatleh m n. Definition natgehdec : decrel nat := make_decrel isdecrelnatgeh. Definition isnegrelnatgeh : isnegrel natgeh := λ n m, isnegrelnatleh m n. Definition iscoasymmnatgeh (n m : nat) (nl : ¬ (n ≥ m)) : m ≥ n := iscoasymmnatleh _ _ nl. Definition istotalnatgeh : istotal natgeh := λ n m, istotalnatleh m n. (** *** Simple implications between comparisons *) Definition natgthtogeh (n m : nat) : n > m -> n ≥ m. Proof. apply natlthtoleh. Defined. Definition natlehtonegnatgth (n m : nat) : n ≤ m -> ¬ (n > m). Proof. intros r. apply @natlehneggth. assumption. Defined. Definition natgthtonegnatleh (n m : nat) : n > m -> ¬ (n ≤ m) := λ g l, natlehtonegnatgth _ _ l g. Definition natgehtonegnatlth (n m : nat) : n ≥ m -> ¬ (n < m) := λ gnm lnm, natlehtonegnatgth _ _ gnm lnm. Definition natlthtonegnatgeh (n m : nat) : n < m -> ¬ (n ≥ m) := λ gnm lnm, natlehtonegnatgth _ _ lnm gnm. Definition negnatgehtolth (n m : nat) : ¬ (n ≥ m) -> n < m. Proof. intros r. apply negnatlehtogth. assumption. Defined. Definition negnatlthtogeh (n m : nat) : ¬ (n < m) -> n ≥ m := λ nl, negnatgthtoleh nl. (* *** Simple corollaries of implications *** *) Definition natlehnsn (n : nat) : n ≤ S n := natlthtoleh _ _ (natgthsnn n). Definition natgehsnn (n : nat) : (S n) ≥ n := natlehnsn n. (** *** Comparison alternatives *) Definition natgthorleh (n m : nat) : (n > m) ⨿ (n ≤ m). Proof. intros. induction (isdecrelnatgth n m) as [a|a]. - apply ii1. assumption. - apply ii2. apply negnatgthtoleh. assumption. Defined. Definition natlthorgeh (n m : nat) : (n < m) ⨿ (n ≥ m) := natgthorleh _ _. Definition natchoice0 (n : nat) : (0 = n) ⨿ (0 < n). Proof. induction n as [ | n]. - use ii1. apply idpath. - use ii2. apply natgthsn0. Qed. Definition natneqchoice (n m : nat) (ne : n ≠ m) : (n > m) ⨿ (n < m). Proof. intros. induction (natgthorleh n m) as [ l | g ]. - exact (ii1 l). - induction (natlthorgeh n m) as [ l' | g' ]. + apply (ii2 l'). + contradicts (nat_neq_to_nopath ne) (isantisymmnatleh _ _ g g'). Defined. Definition natlehchoice (n m : nat) (l : n ≤ m) : (n < m) ⨿ (n = m). Proof. intros. induction (natlthorgeh n m) as [ l' | g ]. - apply (ii1 l'). - apply (ii2 (isantisymmnatleh _ _ l g)). Defined. Definition natgehchoice (n m : nat) (g : n ≥ m) : (n > m) ⨿ (n = m). Proof. intros. induction (natgthorleh n m) as [ g' | l ]. - apply (ii1 g'). - apply (ii2 (isantisymmnatleh _ _ l g)). Defined. (** *** Mixed transitivities *) Lemma natgthgehtrans (n m k : nat) : n > m -> m ≥ k -> n > k. Proof. intros gnm gmk. induction (natgehchoice m k gmk) as [ g' | e ]. - apply (istransnatgth _ _ _ gnm g'). - rewrite e in gnm. apply gnm. Defined. Lemma natgehgthtrans (n m k : nat) : n ≥ m -> m > k -> n > k. Proof. intros gnm gmk. induction (natgehchoice n m gnm) as [ g' | e ]. - apply (istransnatgth _ _ _ g' gmk). - rewrite e. apply gmk. Defined. Lemma natlthlehtrans (n m k : nat) : n < m -> m ≤ k -> n < k. Proof. intros l1 l2. apply (natgehgthtrans k m n l2 l1). Defined. Lemma natlehlthtrans (n m k : nat) : n ≤ m -> m < k -> n < k. Proof. intros l1 l2. apply (natgthgehtrans k m n l2 l1). Defined. Lemma natltltSlt (i j n : nat) : i < j -> j < S n -> i < n. Proof. intros l. apply natlthlehtrans. assumption. Defined. (** *** Two comparisons and [S] *) Lemma natgthtogehsn (n m : nat) : n > m -> n ≥ (S m). Proof. revert m. induction n as [ | n IHn ]. - intros m X. induction (negnatgth0n _ X). - intros m X. destruct m as [ | m ]. + apply (natgehn0 n). + apply (IHn m X). Defined. Lemma natgthsntogeh (n m : nat) : S n > m -> n ≥ m. Proof. intros a. apply (natgthtogehsn (S n) m a). Defined. (* PeWa *) Lemma natgehtogthsn (n m : nat) : n ≥ m -> S n > m. Proof. intros X. apply (natgthgehtrans _ n _). - apply natgthsnn. - apply X. Defined. (* New *) Lemma natgehsntogth (n m : nat) : n ≥ (S m) -> n > m. Proof. intros X. apply (natgehgthtrans _ (S m) _ X). apply natgthsnn. Defined. (* New *) Lemma natlthtolehsn (n m : nat) : n < m -> S n ≤ m. Proof. intros X. apply (natgthtogehsn m n X). Defined. Lemma natlehsntolth (n m : nat) : S n ≤ m -> n < m. Proof. intros X. apply (natgehsntogth m n X). Defined. Lemma natlehtolthsn (n m : nat) : n ≤ m -> n < S m. Proof. intros X. apply (natgehtogthsn m n X). Defined. Lemma natlthsntoleh (n m : nat) : n < S m -> n ≤ m. Proof. intros a. apply (natlthtolehsn n (S m) a). Defined. (* PeWa *) (** *** Comparision alternatives and [S] *) Lemma natlehchoice2 (n m : nat) : n ≤ m -> (S n ≤ m) ⨿ (n = m). Proof. intros l. induction (natlehchoice n m l) as [ l' | e ]. - apply (ii1 (natlthtolehsn _ _ l')). - apply (ii2 e). Defined. Lemma natgehchoice2 (n m : nat) : n ≥ m -> (n ≥ (S m)) ⨿ (n = m). Proof. intros g. induction (natgehchoice n m g) as [ g' | e ]. - apply (ii1 (natgthtogehsn _ _ g')). - apply (ii2 e). Defined. Lemma natgthchoice2 (n m : nat) : n > m -> (n > S m) ⨿ (n = (S m)). Proof. intros g. induction (natgehchoice _ _ (natgthtogehsn _ _ g)) as [ g' | e ]. - apply (ii1 g'). - apply (ii2 e). Defined. Lemma natlthchoice2 (n m : nat) : n < m -> (S n < m) ⨿ ((S n) = m). Proof. intros l. induction (natlehchoice _ _ (natlthtolehsn _ _ l)) as [ l' | e ]. - apply (ii1 l'). - apply (ii2 e). Defined. (** ** Some properties of [plus] on [nat] *) (* Addition is defined in Init/Peano.v by the following code Fixpoint plus (n m:nat) : nat := match n with | O => m | S p => S (p + m) end where "n + m" := (plus n m) : nat_scope. *) (** *** The structure of the additive abelian monoid on [nat] *) Lemma natplusl0 (n : nat) : (0 + n) = n. Proof. intros. apply idpath. Defined. Lemma natplusr0 (n : nat) : (n + 0) = n. Proof. induction n as [ | n IH]. - apply idpath. - simpl. apply (maponpaths S IH). Defined. #[global] Hint Resolve natplusr0: natarith. Lemma natplusnsm (n m : nat) : n + S m = S n + m. Proof. revert m. simpl. induction n as [ | n IHn ]. - auto with natarith. - simpl. intro. apply (maponpaths S (IHn m)). Defined. #[global] Hint Resolve natplusnsm : natarith. #[global] Hint Resolve pathsinv0 : natarith. Lemma natpluscomm (n m : nat) : n + m = m + n. Proof. revert m. induction n as [ | n IHn ]. - intro. (*apply pathsinv0.*) (*apply natplusr0.*) auto with natarith. - intro. set (int := IHn (S m)). set (int2 := pathsinv0 (natplusnsm n m)). set (int3 := pathsinv0 (natplusnsm m n)). set (int4 := pathscomp0 int2 int). apply (pathscomp0 int4 int3). Defined. #[global] Hint Resolve natpluscomm : natarith. Lemma natplusassoc (n m k : nat) : ((n + m) + k) = (n + (m + k)). Proof. revert m k. induction n as [ | n IHn ]. - auto with natarith. - intros. simpl. apply (maponpaths S (IHn m k)). Defined. #[global] Hint Resolve natplusassoc : natarith. (** *** Addition and comparisons *) (** [natgth] *) Definition natgthtogths (n m : nat) : n > m -> (S n) > m. Proof. intros is. apply (istransnatgth _ _ _ (natgthsnn n) is). Defined. Definition negnatgthmplusnm (n m : nat) : ¬ (m > n + m). Proof. intros. induction n as [ | n IHn ]. - apply isirreflnatgth. - apply natlehtonegnatgth. assert (r := negnatgthtoleh IHn); clear IHn. apply (istransnatleh r (natlthtoleh _ _ (natlthnsn _))). Defined. Definition negnatgthnplusnm (n m : nat) : ¬ (n > (n + m)). Proof. intros. rewrite (natpluscomm n m). apply (negnatgthmplusnm m n). Defined. Definition natgthandplusl (n m k : nat) : n > m -> (k + n) > (k + m). Proof. intros l. induction k as [ | k IHk ]. - assumption. - assumption. Defined. Definition natgthandplusr (n m k : nat) : n > m -> (n + k) > (m + k). Proof. intros. rewrite (natpluscomm n k). rewrite (natpluscomm m k). apply natgthandplusl. assumption. Defined. Definition natgthandpluslinv (n m k : nat) : (k + n) > (k + m) -> n > m. Proof. intros l. induction k as [ | k IHk ]. - assumption. - apply (IHk l). Defined. Definition natgthandplusrinv (n m k : nat) : (n + k) > (m + k) -> n > m. Proof. intros l. rewrite (natpluscomm n k) in l. rewrite (natpluscomm m k) in l. apply (natgthandpluslinv _ _ _ l). Defined. Definition natgthandplusm (n m : nat) (H : m > 0) : n + m > n. Proof. revert m H. induction n as [ | n]. - intros m H. rewrite natplusl0. exact H. - intros m H. rewrite <- natplusnsm. change (S n) with (1 + n). rewrite (natpluscomm 1 n). apply natgthandplusl. apply H. Qed. (** [natlth] *) Definition natlthtolths (n m : nat) : n < m -> n < S m := natgthtogths _ _. Definition negnatlthplusnmm (n m : nat) : ¬ (n + m < m) := negnatgthmplusnm _ _. Definition negnatlthplusnmn (n m : nat) : ¬ (n + m < n) := negnatgthnplusnm _ _. Definition natlthandplusl (n m k : nat) : n < m -> k + n < k + m := natgthandplusl _ _ _. Definition natlthandplusr (n m k : nat) : n < m -> n + k < m + k := natgthandplusr _ _ _. Definition natlthandpluslinv (n m k : nat) : k + n < k + m -> n < m := natgthandpluslinv _ _ _. Definition natlthandplusrinv (n m k : nat) : n + k < m + k -> n < m := natgthandplusrinv _ _ _. Definition natlthandplusm (n m : nat) (H : 0 < m) : n < n + m := natgthandplusm _ _ H. (** [natleh] *) Definition natlehtolehs (n m : nat) : n ≤ m -> n ≤ S m. Proof. intros is. apply (istransnatleh is (natlthtoleh _ _ (natlthnsn _))). Defined. Definition natlehmplusnm (n m : nat) : m ≤ n + m. Proof. intros. induction n as [|n N]. - change (0+m) with m. apply isreflnatleh. - apply natlehtolehs. assumption. Defined. Lemma plus_n_Sm : ∏ n m:nat, S (n + m) = n + S m. Proof. intros n m. induction n as [|n I]. - reflexivity. - simpl. apply (maponpaths S). auto. Qed. Definition natlehnplusnm (n m : nat) : n ≤ n + m. Proof. intros. induction m as [|m M]. - induction (!natplusr0 n). apply isreflnatleh. - induction (plus_n_Sm n m). apply natlehtolehs. assumption. Defined. Definition natlehandplusl (n m k : nat) : n ≤ m -> k + n ≤ k + m. Proof. unfold natleh. intros r. rewrite (plus_n_Sm k m). apply natgthandplusl. assumption. Defined. Definition natlehandplusr (n m k : nat) : n ≤ m -> n + k ≤ m + k. Proof. unfold natleh. intros r. change (S (m + k)) with (S m + k). apply natgthandplusr. assumption. Defined. Definition natlehandplus (i j k l : nat) : i ≤ j -> k ≤ l -> i + k ≤ j + l. Proof. intros r s. use (@istransnatleh _ (j + k) _). - apply natlehandplusr. apply r. - apply natlehandplusl. apply s. Defined. Definition natlehandpluslinv (n m k : nat) : k + n ≤ k + m -> n ≤ m. Proof. unfold natleh. intros r. rewrite (plus_n_Sm k m) in r. apply (natgthandpluslinv _ _ k). assumption. Defined. Definition natlehandplusrinv (n m k : nat) : n + k ≤ m + k -> n ≤ m. Proof. unfold natleh. intros r. change (S (m + k)) with (S m + k) in r. apply (natgthandplusrinv _ _ k). assumption. Defined. (** [natgeh] *) Definition natgehtogehs (n m : nat) : n ≥ m -> S n ≥ m := natlehtolehs _ _. Definition natgehplusnmm (n m : nat) : n + m ≥ m := natlehmplusnm _ _. Definition natgehplusnmn (n m : nat) : n + m ≥ n := natlehnplusnm _ _. Definition natgehandplusl (n m k : nat) : n ≥ m -> k + n ≥ k + m := natlehandplusl _ _ _. Definition natgehandplusr (n m k : nat) : n ≥ m -> n + k ≥ m + k := natlehandplusr _ _ _. Definition natgehandpluslinv (n m k : nat) : k + n ≥ k + m -> n ≥ m := natlehandpluslinv _ _ _. Definition natgehandplusrinv (n m k : nat) : n + k ≥ m + k -> n ≥ m := natlehandplusrinv _ _ _. (* The following are included mainly for direct compatibility with the library hz.v *) (** *** Comparisons and [n -> n + 1] *) Definition natgthtogthp1 (n m : nat) : n > m -> (n + 1) > m. Proof. intros is. induction (natpluscomm 1 n). apply (natgthtogths n m is). Defined. Definition natlthtolthp1 (n m : nat) : n < m -> n < m + 1 := natgthtogthp1 _ _. Definition natlehtolehp1 (n m : nat) : n ≤ m -> n ≤ m + 1. Proof. intros is. induction (natpluscomm 1 m). apply (natlehtolehs n m is). Defined. Definition natgehtogehp1 (n m : nat) : n ≥ m -> (n + 1) ≥ m := natlehtolehp1 _ _. (** *** Two comparisons and [n -> n + 1] *) Lemma natgthtogehp1 (n m : nat) : n > m -> n ≥ (m + 1). Proof. intros is. induction (natpluscomm 1 m). apply (natgthtogehsn n m is). Defined. Lemma natgthp1togeh (n m : nat) : (n + 1) > m -> n ≥ m. Proof. intros is. induction (natpluscomm 1 n). apply (natgthsntogeh n m is). Defined. (* PeWa *) Lemma natlehp1tolth (n m : nat) : n + 1 ≤ m -> n < m. Proof. intros is. induction (natpluscomm 1 n). apply (natlehsntolth n m is). Defined. Lemma natlthtolehp1 (n m : nat) : n < m -> n + 1 ≤ m. Proof. intros is. induction (natpluscomm 1 n). apply (natlthtolehsn n m is). Defined. Lemma natlthp1toleh (n m : nat) : n < m + 1 -> n ≤ m. Proof. intros is. induction (natpluscomm 1 m). apply (natlthsntoleh n m is). Defined. (* PeWa *) Lemma natgehp1togth (n m : nat) : n ≥ (m + 1) -> n > m. Proof. intros is. induction (natpluscomm 1 m). apply (natgehsntogth n m is). Defined. (** *** Comparision alternatives and [n -> n + 1] *) Lemma natlehchoice3 (n m : nat) : n ≤ m -> (n + 1 ≤ m) ⨿ (n = m). Proof. intros l. induction (natlehchoice n m l) as [ l' | e ]. - apply (ii1 (natlthtolehp1 _ _ l')). - apply (ii2 e). Defined. Lemma natgehchoice3 (n m : nat) : n ≥ m -> (n ≥ (m + 1)) ⨿ (n = m). Proof. intros g. induction (natgehchoice n m g) as [ g' | e ]. - apply (ii1 (natgthtogehp1 _ _ g')). - apply (ii2 e). Defined. Lemma natgthchoice3 (n m : nat) : n > m -> (n > (m + 1)) ⨿ (n = (m + 1)). Proof. intros g. induction (natgehchoice _ _ (natgthtogehp1 _ _ g)) as [ g' | e ]. - apply (ii1 g'). - apply (ii2 e). Defined. Lemma natlthchoice3 (n m : nat) : n < m -> (n + 1 < m) ⨿ ((n + 1) = m). Proof. intros l. induction (natlehchoice _ _ (natlthtolehp1 _ _ l)) as [ l' | e ]. - apply (ii1 l'). - apply (ii2 e). Defined. Lemma natlehchoice4 (n m : nat) : n < S m -> (n < m) ⨿ (n = m). Proof. intros b. induction (natlthorgeh n m) as [p|p]. - exact (ii1 p). - exact (ii2 (isantisymmnatleh _ _ (natlthsntoleh _ _ b) p)). Defined. (** *** Cancellation properties of [plus] on [nat] *) Lemma pathsitertoplus (n m : nat) : (iteration S n m) = (n + m). Proof. intros. induction n as [ | n IHn ]. - apply idpath. - simpl. apply (maponpaths S IHn). Defined. Lemma isinclnatplusr (n : nat) : isincl (λ m : nat, m + n). Proof. induction n as [ | n IHn ]. - apply (isofhlevelfhomot 1 _ _ (λ m : nat, pathsinv0 (natplusr0 m))). apply (isofhlevelfweq 1 (idweq nat)). - apply (isofhlevelfhomot 1 _ _ (λ m : nat, pathsinv0 (natplusnsm m n))). simpl. apply (isofhlevelfgf 1 _ _ isinclS IHn). Defined. Lemma isinclnatplusl (n : nat) : isincl (λ m : nat, n + m). Proof. apply (isofhlevelfhomot 1 _ _ (λ m : nat, natpluscomm m n) (isinclnatplusr n)). Defined. Lemma natplusrcan (a b c : nat) (is : a + c = b + c) : a = b. Proof. intros. apply (invmaponpathsincl _ (isinclnatplusr c) a b). apply is. Defined. Lemma natpluslcan (a b c : nat) (is : c + a = c + b) : a = b. Proof. intros. rewrite (natpluscomm _ _) in is. rewrite (natpluscomm c b) in is. apply (natplusrcan a b c is). Defined. Lemma iscontrhfibernatplusr (n m : nat) (is : m ≥ n) : iscontr (hfiber (λ i : nat, i + n) m). Proof. intros. apply iscontraprop1. - apply isinclnatplusr. - induction m as [ | m IHm ]. + set (e := natleh0tois0 is). split with 0. apply e. + induction (natlehchoice2 _ _ is) as [ l | e ]. * set (j := IHm l). induction j as [ j e' ]. split with (S j). simpl. apply (maponpaths S e'). * split with 0. simpl. assumption. Defined. Lemma iscontrhfibernatplusl (n m : nat) (is : m ≥ n) : iscontr (hfiber (λ i : nat, n + i) m). Proof. intros. apply iscontraprop1. - apply isinclnatplusl. - induction m as [ | m IHm ]. + set (e := natleh0tois0 is). split with 0. rewrite natplusr0. apply e. + induction (natlehchoice2 _ _ is) as [ l | e ]. * set (j := IHm l). induction j as [ j e' ]. split with (S j). simpl. rewrite <- plus_n_Sm. apply (maponpaths S e'). * split with 0. simpl. rewrite natplusr0. assumption. Defined. Lemma neghfibernatplusr (n m : nat) (is : m < n) : ¬ (hfiber (λ i : nat, i + n) m). Proof. intros. intro h. induction h as [ i e ]. rewrite (pathsinv0 e) in is. induction (natlehtonegnatgth _ _ (natlehmplusnm i n) is). Defined. Lemma isdecinclnatplusr (n : nat) : isdecincl (λ i : nat, i + n). Proof. intros. intro m. apply isdecpropif. - apply (isinclnatplusr _ m). - induction (natlthorgeh m n) as [ ni | i ]. + apply (ii2 (neghfibernatplusr n m ni)). + apply (ii1 (pr1 (iscontrhfibernatplusr n m i))). Defined. (** *** Some properties of [minus] on [nat] Note : minus is defined in Init/Peano.v by the following code: Fixpoint minus (n m : nat) : nat := match n, m with | O, _ => n | S k, O => n | S k, S l => k - l end where "n - m" := (minus n m) : nat_scope. *) Definition minuseq0 (n m : nat) (is : n <= m) : n - m = 0. Proof. revert is. generalize n. clear n. induction m as [|m IHm]. - intros n is. rewrite (natleh0tois0 is). simpl. apply idpath. - intro n. destruct n. + intro. apply idpath. + apply (IHm n). Defined. Definition minuseq0' (n : nat) : n - n = 0. Proof. induction n as [|n I]. - apply idpath. - simpl. exact I. Defined. Definition minusgth0 (n m : nat) (is : n > m) : n - m > 0. Proof. revert m is. induction n as [ | n IHn ]. - intros. induction (negnatgth0n _ is). - intro m. induction m as [ | m ]. + intro. apply natgthsn0. + intro is. apply (IHn m is). Defined. Definition minusgth0inv (n m : nat) (is : n - m > 0) : n > m. Proof. revert m is. induction n as [ | n IHn ]. - intros. induction (negnatgth0n _ is). - intro. destruct m as [ | m ]. + intros. apply natgthsn0. + intro. apply (IHn m is). Defined. Definition natminuseqn (n : nat) : n - 0 = n. Proof. destruct n. apply idpath. apply idpath. Defined. Definition natminuslehn (n m : nat) : n - m <= n. Proof. revert m. induction n as [ | n IHn ]. - intro. apply isreflnatleh. - intro. destruct m as [ | m ]. + apply isreflnatleh. + simpl. apply (istransnatleh (IHn m) (natlehnsn n)). Defined. Definition natminusgehn (n m : nat) : n ≥ n - m := natminuslehn _ _. Definition natminuslthn (n m : nat) (is : n > 0) (is' : m > 0) : n - m < n. Proof. revert m is is'. induction n as [ | n IHn ]. - intros. induction (negnatgth0n _ is). - intro m. induction m. + intros. induction (negnatgth0n _ is'). + intros. apply (natlehlthtrans _ n _). * apply (natminuslehn n m). * apply natlthnsn. Defined. Definition natminuslthninv (n m : nat) (is : n - m < n) : m > 0. Proof. revert m is. induction n as [ | n IHn ]. - intros. induction (negnatlthn0 _ is). - intro m. destruct m as [ | m ]. + intro. induction (negnatlthnn _ is). + intro. apply (natgthsn0 m). Defined. Definition minusplusnmm (n m : nat) (is : n ≥ m) : (n - m) + m = n. Proof. revert m is. induction n as [ | n IHn]. - intro m. intro is. simpl. apply (natleh0tois0 is). - intro m. destruct m as [ | m ]. + intro. simpl. rewrite (natplusr0 n). apply idpath. + simpl. intro is. rewrite (natplusnsm (n - m) m). apply (maponpaths S (IHn m is)). Defined. Definition minusplusnmmineq (n m : nat) : (n - m) + m ≥ n. Proof. intros. induction (natlthorgeh n m) as [ lt | ge ]. - rewrite (minuseq0 _ _ (natlthtoleh _ _ lt)). apply (natgthtogeh _ _ lt). - rewrite (minusplusnmm _ _ ge). apply isreflnatgeh. Defined. Definition plusminusnmm (n m : nat) : (n + m) - m = n. Proof. intros. set (int1 := natgehplusnmm n m). apply (natplusrcan _ _ m). rewrite (minusplusnmm _ _ int1). apply idpath. Defined. Definition minusminusmmn (n m : nat) (H : m ≥ n) : m - (m - n) = n. Proof. apply (natplusrcan (m - (m - n)) n (m - n)). - rewrite minusplusnmm. + rewrite natpluscomm. rewrite minusplusnmm. * apply idpath. * apply H. + apply natminusgehn. Qed. (** *** Comparisons and [n -> n - 1] *) Definition natgthtogthm1 (n m : nat) : n > m -> n > m - 1. Proof. intros is. induction m as [ | m]. - apply is. - cbn. rewrite natminuseqn. apply (natgehgthtrans n (S m) m). + apply (natgthtogeh _ _ is). + apply natgthsnn. Qed. Definition natlthtolthm1 (n m : nat) : n < m -> n - 1 < m := natgthtogthm1 _ _. Definition natlehtolehm1 (n m : nat) : n ≤ m -> n - 1 ≤ m := (fun X : n ≤ m => natlthtolthm1 n (S m) X). Definition natgehtogehm1 (n m : nat) : n ≥ m -> n ≥ m - 1 := natlehtolehm1 _ _. Definition natgthtogehm1 (n m : nat) : n > m -> n - 1 ≥ m. Proof. revert m. induction n as [ | n]. - intros m X. apply fromempty. apply (negnatgth0n m X). - intros m X. induction m as [ | m]. + apply idpath. + cbn. rewrite natminuseqn. apply X. Qed. (* *** Two-sided minus and comparisons *) Definition natgehandminusr (n m k : nat) (is : n ≥ m) : n - k ≥ m - k. Proof. revert m k is. induction n as [ | n IHn ]. - intros. rewrite (nat0gehtois0 _ is). apply isreflnatleh. - intro m. induction m. + intros. destruct k. * apply natgehn0. * apply natgehn0. + intro k. induction k. * intro is. apply is. * intro is. apply (IHn m k is). Defined. Definition natgehandminusl (n m k : nat) (is : n ≥ m) : n - k ≥ m - k. Proof. revert m k is. induction n as [ | n IHn ]. - intros. rewrite (nat0gehtois0 _ is). apply isreflnatleh. - intro m. induction m. + intros. destruct k. * apply natgehn0. * apply natgehn0. + intro k. induction k. * intro is. apply is. * intro is. apply (IHn m k is). Defined. Definition natgehandminusrinv (n m k : nat) (is' : n ≥ k) (is : n - k ≥ m - k) : n ≥ m. Proof. revert m k is' is. induction n as [ | n IHn ]. - intros. rewrite (nat0gehtois0 _ is') in is. rewrite (natminuseqn m) in is. rewrite (nat0gehtois0 _ is). apply isreflnatleh. - intro m. induction m. + intros. apply natgehn0. + intros. destruct k. * rewrite natminuseqn in is. rewrite natminuseqn in is. apply is. * apply (IHn m k is' is). Defined. Definition natlthandminusl (n m i : nat) (is : n < m) (is' : i < m) : n - i < m - i. Proof. revert is is'. induction i as [ | i]. - intros is is'. rewrite natminuseqn. rewrite natminuseqn. apply is. - intros is is'. induction (natlthorgeh n (S i)) as [H | H]. + assert (e : n - S i = 0). { apply minuseq0. exact (natlthtoleh _ _ H). } rewrite e. apply (natlthandplusrinv _ _ (S i)). rewrite natplusl0. rewrite minusplusnmm. apply is'. apply natlthtoleh. apply is'. + apply (natlthandplusrinv _ _ (S i)). rewrite (minusplusnmm m (S i)). * rewrite (minusplusnmm n (S i)). { apply is. } { apply H. } * apply natlthtoleh. apply is'. Defined. (* Definition natgehandminuslinv (n m k : nat) (is' : natgeh k n) (is : natleh (k - n) (k - m)) : natgeh n m. Proof. intros. set (int := natgehgthtrans _ (k - n) _ is (minusgeh0 _ _ is')). set (int' := minusgeh0inv _ _ int). set (int'' := natlehandplusr _ _ n is). rewrite (minusplusnmm _ _ (natgthtogeh _ _ is')) in int''. set (int''' := natlehandplusr _ _ m int''). rewrite (natplusassoc _ n _) in int'''. rewrite (natpluscomm n m) in int'''. destruct (natplusassoc (k - m) m n) in int'''. rewrite (minusplusnmm _ _ (natgthtogeh _ _ int')) in int'''. apply (natgehandpluslinv _ _ k). apply int'''. Defined. induction n as [ | n IHn ]. intros. rewrite (nat0gehtois0 _ is') in is. rewrite (natminuseqn m) in is. rewrite (nat0gehtois0 _ is). apply isreflnatleh. intro m. induction m. intros. apply natgehn0. intros. destruct k. rewrite natminuseqn in is. rewrite natminuseqn in is. apply is. apply (IHn m k is is'). Defined. (removed to lBsystems) Definition natgthandminusinvr (n m k : nat) (is : natgth n m) (is' : natgth n k) : natgth (n - k) (m - k). Proof. intro n. induction n as [ | n IHn ]. intros. destruct (negnatgth0n _ is). intro m. induction m. intros. destruct k. apply natgthsn0. apply (IHapply natgehn0. intro k. induction k. intro is. apply is. intro is. apply (IHn m k is). Defined. (removed to lBsystems) Definition natlehandminusl (n m k : nat) (is : natgeh n m) : natgeh (k - m) (k - n). Proof. intro n. induction n as [ | n IHn ]. intros. rewrite (nat0gehtois0 _ is). apply isreflnatleh. intro m. induction m. intros. destruct k. apply natminuslehn. apply natminuslehn. intro k. induction k. intro is. apply isreflnatleh. intro is. apply (IHn m k). apply is. Defined. Definition natlehandminusr Definition natlthandminusl (n m k : nat) (is : natgth n m) (is' : natgeh k n) : natlth (k - n) (k - m). Proof. intro n. induction n as [ | n IHn ]. intros. destruct (negnatgth0n _ is). intro m. induction m. intros. destruct k. destruct (negnatgeh0sn _ is'). apply (natlehlthtrans _ k _). apply (natminuslehn k n). apply natlthnsn. intro k. induction k. intros is is'. destruct (negnatgeh0sn _ is'). intros is is'. apply (IHn m k is is'). Defined. Definition natlehandminusl (n m k : nat) (is : natgeh n m) : natleh (k - n) (k - m). Proof. intro n. induction n as [ | n IHn ]. intros. rewrite (nat0gehtois0 _ is). apply isreflnatleh. intro m. induction m. intros. destruct k. apply natminuslehn. apply natminuslehn. intro k. induction k. intro is. apply isreflnatleh. intro is. apply (IHn m k). apply is. Defined. Definition natlehandminusl (n m k : nat) : (n ≤ m) -> natgeh (k - n) (k - m) := natlehandminusl m n k. Definition natlehandminusr (n m k : nat) : (n ≤ m) -> (n - k) ≤ (m - k) := natgehandminusr m n k. (* *** One sided minus and comparisons *) (* *** Greater or equal and minus *) (* See lBsystems.v *) (* **** Less and minus *) Definition natlthrightminus (n m k : nat) (is : natlth (n + m) k) : natlth n (k - m). Definition natlthrightplus (n m k : nat) (is : natlth (n - m) k) : natlth n (k + m). Definition natlthleftminus (n m k : nat) (is : natlth n (m + k)) : natlth (n - k) m. Definition natlthleftplus (n m k : nat) (is : natlth n (m - k)) : natlth (n + k) m. (* **** Less or equal and minus *) Definition natlehrightminus (n m k : nat) (is : (n + m) ≤ k) : n ≤ (k - m). Definition natlehrightplus (n m k : nat) (is : (n - m) ≤ k) : n ≤ (k + m). Definition natlehleftminus (n m k : nat) (is : n ≤ (m + k)) : (n - k) ≤ m. Definition natlehleftplus (n m k : nat) (is : n ≤ (m - k)) : (n + k) ≤ m. (* *** Mixed plus/minus associativities. There are four possible plus/minus associativities which are labelled by pp, pm, mp and mm depending on where in the side with the left parenthesis one has minuses and where one has pluses. Two of those - pp and mm, are unconditional. Two others require a condition to hold as equality and also provide an unconditional inequality. Alltogether we have six statements including a repeat of the usual pp associativity which we give here another name in accrdance with the general naming scheme for these statements. *) Notation natassocppeq := natplusassoc. (* see lBsystems *) Definition natassocpmineq (n m k : nat) : natleh ((n + m) - k) (n + (m - k)). Proof. intros k. destruct (natgthorleh k m) as [g | le]. set (e := minuseq0 m k (natgthtogeh _ _ g)). rewrite e. rewrite (natplusr0 n). destruct (boolchoice (natgtb k (n+m))) as [ g' | le']. set (e' := minuseq0 (n+m) k (natgthtogeh _ _ g')). rewrite e'. apply natleh0n. apply (natlehandplusrinv _ _ k). rewrite (minusplusnmm _ k). apply natlehandplusl. apply (natlthtoleh _ _ g). set (int := falsetonegtrue _ le'). assumption. rewrite (natassocpmeq _ _ _ le). apply isreflnatleh. Defined. (* see lBsystems *) Definition natassocmpineq (n m k : nat) : natgeh ((n - m) + k) (n - (m - k)). Proof. intros k. destruct (natgthorleh k m) as [g | le]. set (e := minuseq0 m k (natgthtogeh _ _ g)). rewrite e. rewrite (natminuseqn n). apply (natgehandplusrinv _ _ m). rewrite (natplusassoc _ _ m). rewrite (natpluscomm _ m). destruct (natplusassoc (n - m) m k). assert (int1 : natgeh (n - m + m + k) (n + k)). apply (natgehandplusr _ _ k). apply minusplusnmmineq. assert (int2 : natgeh (n + k) (n + m)). apply (natgehandplusl _ _ n). apply (natgthtogeh _ _ g). apply (istransnatgeh _ _ _ int1 int2). destruct (natgthorleh m n) as [g' | le']. rewrite (minuseq0 _ _ (natgthtogeh _ _ g')). change (0 + k) with k. apply (natgehandplusrinv _ _ (m - k)). rewrite (natpluscomm k _). rewrite (minusplusnmm _ _ le). destruct (natgthorleh (m - k) n) as [ g'' | le'' ]. rewrite (minuseq0 n (m - k) (natgthtogeh _ _ g'')). apply (natminuslehn m k). rewrite (minusplusnmm _ _ le''). apply (natgthtogeh _ _ g'). rewrite (natassocmpeq _ _ _ le' le). apply isreflnatgeh. Defined. Definition natassocpmineq (n m k : nat) : natleh ((n + m) - k) (n + (m - k)). Proof. intros k. destruct (natgthorleh k m) as [g | le]. set (e := minuseq0 m k (natgthtogeh _ _ g)). rewrite e. rewrite (natplusr0 n). destruct (boolchoice (natgtb k (n+m))) as [ g' | le']. set (e' := minuseq0 (n+m) k (natgthtogeh _ _ g')). rewrite e'. apply natleh0n. apply (natlehandplusrinv _ _ k). rewrite (minusplusnmm _ k). apply natlehandplusl. apply (natlthtoleh _ _ g). set (int := falsetonegtrue _ le'). assumption. rewrite (natassocpmeq _ _ _ le). apply isreflnatleh. Defined. *) (** *** Basic algebraic properties of [mul] on [nat]. We no longer user [mult]. *) Lemma natmult0n (n : nat) : (0 * n) = 0. Proof. apply idpath. Defined. #[global] Hint Resolve natmult0n : natarith. Lemma natmultn0 (n : nat) : n * 0 = 0. Proof. induction n as [ | n IHn ]. - apply idpath. - simpl. exact (natplusr0 _ @ IHn). Defined. #[global] Hint Resolve natmultn0 : natarith. Lemma multsnm (n m : nat) : S n * m = m + n * m. Proof. intros. simpl. apply natpluscomm. Defined. #[global] Hint Resolve multsnm : natarith. Lemma multnsm (n m : nat) : n * S m = n + n * m. Proof. revert m. induction n as [|n IHn]. - intros. apply idpath. - intro m. simpl. rewrite <- natplusassoc. rewrite (natpluscomm _ m). change (S (m + (n + n * m))) with (S m + (n + n * m)). rewrite (natpluscomm (S m) _). apply (maponpaths (λ x, x + S m)). apply IHn. Defined. #[global] Hint Resolve multnsm : natarith. Lemma natmultcomm (n m : nat) : (n * m) = (m * n). Proof. revert m. induction n as [ | n IHn ]. - intro. auto with natarith. - intro m. rewrite (multsnm n m). rewrite (multnsm m n). apply (maponpaths (λ x : _, m + x) (IHn m)). Defined. Lemma natrdistr (n m k : nat) : (n + m) * k = n * k + m * k. Proof. intros. induction n as [ | n IHn ]. - apply idpath. - simpl. rewrite natplusassoc. rewrite (natpluscomm k _). rewrite <- natplusassoc. exact (maponpaths (λ x, x+k) IHn). Defined. Lemma natldistr (m k n : nat) : (n * (m + k)) = (n * m + n * k). Proof. induction m as [ | m IHm ]. - simpl. rewrite (natmultn0 n). auto with natarith. - simpl. rewrite (multnsm n (m + k)). rewrite (multnsm n m). rewrite (natplusassoc _ _ _). apply (maponpaths (λ x : _, n + x) (IHm)). Defined. Lemma natmultassoc (n m k : nat) : ((n * m) * k) = (n * (m * k)). Proof. induction n as [ | n IHn ]. - apply idpath. - simpl. rewrite natrdistr. apply (maponpaths (λ x, x + m * k)). apply IHn. Defined. Lemma natmultl1 (n : nat) : (1 * n) = n. Proof. simpl. auto with natarith. Defined. #[global] Hint Resolve natmultl1 : natarith. Lemma natmultr1 (n : nat) : (n * 1) = n. Proof. rewrite (natmultcomm n 1). auto with natarith. Defined. #[global] Hint Resolve natmultr1 : natarith. (** *** Cancellation properties of [mul] on [nat] *) Definition natplusnonzero (n m : nat) : m ≠ 0 -> n+m ≠ 0. Proof. intros ne. induction n as [|n _]. - assumption. - exact tt. Defined. Definition natneq0andmult (n m : nat) : n ≠ 0 -> m ≠ 0 -> n * m ≠ 0. Proof. intros isn ism. induction n as [|n]. - apply fromempty. apply isn. - clear isn. simpl. apply natplusnonzero. assumption. Defined. Definition natneq0andmultlinv (n m : nat) : n * m ≠ 0 -> n ≠ 0. Proof. revert m. induction n as [|n _]. - intros ? r. apply fromempty, r. - intros _ _. apply natneqsx0. Defined. Definition natneq0andmultrinv (n m : nat) : n * m ≠ 0 -> m ≠ 0. Proof. induction m as [|m _]. - intro r. apply fromempty. apply (nat_neq_to_nopath r), natmultn0. - intros _. apply natneqsx0. Defined. (** *** Multiplication and comparisons *) (** [natgth] *) Definition natgthandmultl (n m k : nat) : k ≠ 0 -> n > m -> (k * n) > (k * m). Proof. revert m k. induction n as [ | n IHn ]. - intros m k g g'. induction (negnatgth0n _ g'). - intro m. destruct m as [ | m ]. + intros k g g'. rewrite (natmultn0 k). rewrite (multnsm k n). apply (natgehgthtrans _ _ _ (natgehplusnmn k (k* n)) (natneq0togth0 _ g)). + intros k g g'. rewrite (multnsm k n). rewrite (multnsm k m). apply (natgthandplusl _ _ _). apply (IHn m k g g'). Defined. Definition natgthandmultr (n m k : nat) : k ≠ 0 -> n > m -> (n * k) > (m * k). Proof. intros l. rewrite (natmultcomm n k). rewrite (natmultcomm m k). apply (natgthandmultl n m k l). Defined. Definition natgthandmultlinv (n m k : nat) : (k * n) > (k * m) -> n > m. Proof. revert m k. induction n as [ | n IHn ]. - intros m k g. rewrite (natmultn0 k) in g. induction (negnatgth0n _ g). - intro m. destruct m as [ | m ]. + intros. apply (natgthsn0 _). + intros k g. rewrite (multnsm k n) in g. rewrite (multnsm k m) in g. apply (IHn m k (natgthandpluslinv _ _ k g)). Defined. Definition natgthandmultrinv (n m k : nat) : (n * k) > (m * k) -> n > m. Proof. intros g. rewrite (natmultcomm n k) in g. rewrite (natmultcomm m k) in g. apply (natgthandmultlinv n m k g). Defined. (** [natlth] *) Definition natlthandmultl (n m k : nat) : k ≠ 0 -> n < m -> k * n < k * m := natgthandmultl _ _ _. Definition natlthandmultr (n m k : nat) : k ≠ 0 -> n < m -> n * k < m * k := natgthandmultr _ _ _. Definition natlthandmultlinv (n m k : nat) : k * n < k * m -> n < m := natgthandmultlinv _ _ _. Definition natlthandmultrinv (n m k : nat) : n * k < m * k -> n < m := natgthandmultrinv _ _ _. (** [natleh] *) Definition natlehandmultl (n m k : nat) : n ≤ m -> k * n ≤ k * m. Proof. intros r. apply negnatgthtoleh; intro t. apply (natlehtonegnatgth _ _ r). apply (natgthandmultlinv _ _ k). assumption. Defined. Definition natlehandmultr (n m k : nat) : n ≤ m -> n * k ≤ m * k. Proof. intros r. apply negnatgthtoleh; intro t. apply (natlehtonegnatgth _ _ r). apply (natgthandmultrinv _ _ k). assumption. Defined. Definition natlehandmultlinv (n m k : nat) : k ≠ 0 -> k * n ≤ k * m -> n ≤ m. Proof. intros r s. apply negnatgthtoleh; intro t. apply (natlehtonegnatgth _ _ s). apply (natgthandmultl _ _ _ r). assumption. Defined. Definition natlehandmultrinv (n m k : nat) : k ≠ 0 -> n * k ≤ m * k -> n ≤ m. Proof. intros r s. apply negnatgthtoleh; intro t. apply (natlehtonegnatgth _ _ s). apply (natgthandmultr _ _ _ r). assumption. Defined. (** [natgeh] *) Definition natgehandmultl (n m k : nat) : n ≥ m -> (k * n) ≥ (k * m) := natlehandmultl _ _ _. Definition natgehandmultr (n m k : nat) : n ≥ m -> (n * k) ≥ (m * k) := natlehandmultr _ _ _. Definition natgehandmultlinv (n m k : nat) : k ≠ 0 -> k * n ≥ k * m -> n ≥ m := natlehandmultlinv _ _ _. Definition natgehandmultrinv (n m k : nat) : k ≠ 0 -> n * k ≥ m * k -> n ≥ m := natlehandmultrinv _ _ _. (** *** Division with a remainder on [nat] For technical reasons it is more convenient to introduce divison with remainder for all pairs (n,m) including pairs of the form (n,0). *) Definition natdivrem (n m : nat) : dirprod nat nat. Proof. intros. induction n as [ | n IHn ]. - intros. apply (make_dirprod 0 0). - induction (natlthorgeh (S (pr2 IHn)) m). + apply (make_dirprod (pr1 IHn) (S (pr2 IHn))). + apply (make_dirprod (S (pr1 IHn)) 0). Defined. Definition natdiv (n m : nat) : nat := pr1 (natdivrem n m). Definition natrem (n m : nat) : nat := pr2 (natdivrem n m). Notation " x /+ y " := (natrem x y) (at level 40, left associativity) : nat_scope. Notation " x / y " := (natdiv x y) (at level 40, left associativity) : nat_scope. Lemma lthnatrem (n m : nat) : m ≠ 0 -> n /+ m < m. Proof. unfold natrem. intros is. destruct n as [ | n ]. - simpl. intros. apply (natneq0togth0 _ is). - simpl. induction (natlthorgeh (S (pr2 (natdivrem n m))) m) as [ nt | t ]. + simpl. apply nt. + simpl. apply (natneq0togth0 _ is). Defined. Theorem natdivremrule (n m : nat) (is : m ≠ 0) : n = ((natrem n m) + (natdiv n m) * m). Proof. revert m is. induction n as [ | n IHn ]. - simpl. intros. apply idpath. - intros m is. unfold natrem. unfold natdiv. simpl. induction (natlthorgeh (S (pr2 (natdivrem n m))) m) as [ nt | t ]. + simpl. apply (maponpaths S (IHn m is)). + simpl. set (is' := lthnatrem n m is). induction (natgthchoice2 _ _ is') as [ h | e ]. induction (natlehtonegnatgth _ _ t h). fold (natdiv n m). set (e'' := maponpaths S (IHn m is)). change (S (natrem n m + natdiv n m * m)) with (S (natrem n m) + natdiv n m * m) in e''. rewrite (pathsinv0 e) in e''. rewrite (natpluscomm _ m). apply e''. Defined. Opaque natdivremrule. Lemma natlehmultnatdiv (n m : nat) (is : m ≠ 0) : natdiv n m * m ≤ n. Proof. intros. set (e := natdivremrule n m is). set (int := (natdiv n m) * m). rewrite e. (* why can't we just say "rewrite e at 2" here? *) apply natlehmplusnm. Defined. Theorem natdivremunique (m i j i' j' : nat) (lj : j < m) (lj' : j' < m) (e : j + i * m = j' + i' * m) : i = i' × j = j'. Proof. revert j i' j' lj lj' e. induction i as [ | i IHi ]. - intros j i' j' lj lj'. simpl. intro e. simpl in e. rewrite natplusr0 in e. rewrite e in lj. induction i'. + simpl in e. rewrite natplusr0 in e. exact (idpath _,,e). + change (S i' * m) with (i' * m + m) in lj. rewrite <- natplusassoc in lj. induction (negnatgthmplusnm _ _ lj). - intros j i' j' lj lj' e. induction i' as [ | i' ]. + simpl in e. rewrite natplusr0 in e. rewrite <- e in lj'. rewrite <- natplusassoc in lj'. induction (negnatgthmplusnm _ _ lj'). + simpl in e. rewrite <- (natplusassoc j) in e. rewrite <- (natplusassoc j') in e. set (e' := invmaponpathsincl _ (isinclnatplusr m) _ _ e). set (ee := IHi j i' j' lj lj' e'). exact (make_dirprod (maponpaths S (pr1 ee)) (pr2 ee)). Defined. Opaque natdivremunique. Lemma natdivremandmultl (n m k : nat) (ism : m ≠ 0) (iskm : (k * m) ≠ 0) : dirprod (paths (natdiv (k * n) (k * m)) (natdiv n m)) (paths (natrem (k * n) (k * m)) (k * (natrem n m))). Proof. intros. set (ak := natdiv (k * n) (k * m)). set (bk := natrem (k * n) (k * m)). set (a := natdiv n m). set (b := natrem n m). assert (e1 : paths (bk + ak * (k * m)) ((b * k) + a * (k * m))). { unfold ak. unfold bk. rewrite (pathsinv0 (natdivremrule (k * n) (k * m) iskm)). rewrite (natmultcomm k m). rewrite (pathsinv0 (natmultassoc _ _ _)). rewrite (pathsinv0 (natrdistr _ _ _)). unfold a. unfold b. rewrite (pathsinv0 (natdivremrule n m ism)). apply (natmultcomm k n). } set (l1 := lthnatrem n m ism). set (l1' := (natlthandmultr _ _ _ (natneq0andmultlinv _ _ iskm) l1)). rewrite (natmultcomm m k) in l1'. set (int := natdivremunique _ _ _ _ _ (lthnatrem (k * n) (k * m) iskm) l1' e1). split with (pr1 int). rewrite (natmultcomm k b). apply (pr2 int). Defined. Opaque natdivremandmultl. Definition natdivandmultl (n m k : nat) (ism : m ≠ 0) (iskm : (k * m) ≠ 0) : paths (natdiv (k * n) (k * m)) (natdiv n m) := pr1 (natdivremandmultl _ _ _ ism iskm). Definition natremandmultl (n m k : nat) (ism : m ≠ 0) (iskm : (k * m) ≠ 0) : paths (natrem (k * n) (k * m)) (k * (natrem n m)) := pr2 (natdivremandmultl _ _ _ ism iskm). Lemma natdivremandmultr (n m k : nat) (ism : m ≠ 0) (ismk : (m * k) ≠ 0) : dirprod (paths (natdiv (n * k) (m * k)) (natdiv n m)) (paths (natrem (n * k) (m * k)) ((natrem n m) * k)). Proof. intros. rewrite (natmultcomm m k). rewrite (natmultcomm m k) in ismk. rewrite (natmultcomm n k). rewrite (natmultcomm (natrem _ _) k). apply (natdivremandmultl _ _ _ ism ismk). Defined. Opaque natdivremandmultr. Definition natdivandmultr (n m k : nat) (ism : m ≠ 0) (ismk : (m * k) ≠ 0) : paths (natdiv (n * k) (m * k)) (natdiv n m) := pr1 (natdivremandmultr _ _ _ ism ismk). Definition natremandmultr (n m k : nat) (ism : m ≠ 0) (ismk : (m * k) ≠ 0) : natrem (n * k) (m * k) = (natrem n m) * k := pr2 (natdivremandmultr _ _ _ ism ismk). (** *** Exponentiation [natpower n m] ("n to the power m") on [nat] *) Fixpoint natpower (n m : nat) : nat := match m with | O => 1 | S m' => n * (natpower n m') end. (** *** Factorial on [nat] *) Fixpoint factorial (n : nat) : nat := match n with | 0 => 1 | S n' => (S n') * (factorial n') end. (** ** The order-preserving functions [di i : nat -> nat] whose image is the complement of one element [i]. *) Definition di (i : nat) (x : nat) : nat := match natlthorgeh x i with | ii1 _ => x | ii2 _ => S x end. Lemma di_eq1 {i x} : x < i → di i x = x. Proof. intros lt. unfold di. induction (natlthorgeh x i) as [_|P]. - apply idpath. - apply fromempty. exact (natgehtonegnatlth _ _ P lt). Defined. Lemma di_eq2 {i x} : x ≥ i → di i x = S x. Proof. intros lt. unfold di. induction (natlthorgeh x i) as [P|_]. - apply fromempty. exact (natlthtonegnatgeh _ _ P lt). - apply idpath. Defined. Lemma di_neq_i (i x : nat) : i ≠ di i x. Proof. intros. apply nat_nopath_to_neq. intro eq. unfold di in eq. induction (natlthorgeh x i) as [lt|ge]. - induction eq. exact (isirreflnatlth i lt). - induction (!eq); clear eq. exact (negnatgehnsn _ ge). Defined. Lemma natlehdinsn (i n : nat) : (di i n) ≤ (S n). Proof. intros. unfold di. induction (natlthorgeh n i). - apply natlthtoleh. apply natlthnsn. - apply isreflnatleh. Defined. Lemma natgehdinn (i n : nat) : (di i n) ≥ n. Proof. intros. unfold di. induction (natlthorgeh n i). - apply isreflnatleh. - apply natlthtoleh. apply natlthnsn. Defined. Lemma isincldi (i : nat) : isincl (di i). Proof. intro. apply (isinclbetweensets (di i) isasetnat isasetnat). intros x x'. unfold di. intro e. induction (natlthorgeh x i) as [ l | nel ]. - induction (natlthorgeh x' i) as [ l' | nel' ]. + apply e. + rewrite e in l. assert (e' := natgthtogths _ _ l). change (S i > S x') with (i > x') in e'. contradicts (natlehtonegnatgth _ _ nel') e'. - induction (natlthorgeh x' i) as [ l' | nel' ]. + induction e. set (e' := natgthtogths _ _ l'). contradicts (natlehtonegnatgth _ _ nel) e'. + apply (invmaponpathsS _ _ e). Defined. Lemma neghfiberdi (i : nat) : ¬ (hfiber (di i) i). Proof. intros hf. unfold di in hf. induction hf as [ j e ]. induction (natlthorgeh j i) as [ l | g ]. induction e. apply (isirreflnatlth _ l). induction e in g. apply (negnatgehnsn _ g). Defined. Lemma iscontrhfiberdi (i j : nat) (ne : i ≠ j) : iscontr (hfiber (di i) j). Proof. intros. apply iscontraprop1. apply (isincldi i j). induction (natlthorgeh j i) as [ l | nel ]. - split with j. unfold di. induction (natlthorgeh j i) as [ l' | nel' ]. + apply idpath. + contradicts (natlehtonegnatgth _ _ nel') l. - induction (natgehchoice2 _ _ nel) as [ g | e ]. destruct j as [ | j ]. + induction (negnatgeh0sn _ g). + split with j. unfold di. induction (natlthorgeh j i) as [ l' | g' ]. * contradicts (natlehtonegnatgth _ _ g) l'. * apply idpath. + induction ((nat_neq_to_nopath ne) (pathsinv0 e)). Defined. Lemma isdecincldi (i : nat) : isdecincl (di i). Proof. intros j. apply isdecpropif. - apply (isincldi i j). - induction (nat_eq_or_neq i j) as [ eq | neq ]. + apply ii2. induction eq. apply (neghfiberdi i). + apply ii1. apply (pr1 (iscontrhfiberdi i j neq)). Defined. (** ** The order-preserving functions [si i : nat -> nat] that take the value [i] twice. *) Definition si (i : nat) (x : nat) : nat := match natlthorgeh i x with | ii1 _ => x - 1 | ii2 _ => x end. Lemma natleh_neq {i j : nat} : i ≤ j -> i ≠ j -> i < j. Proof. intros le ne. induction (natlehchoice _ _ le) as [lt|eq]. - exact lt. - induction eq. apply fromempty. exact (isirrefl_natneq _ ne). Defined. (* more lemmas about natural numbers *) Lemma natminusminus (n i j : nat) : n - i - j = n - (i + j). Proof. revert i j; induction n as [|n N]. - intros. apply idpath. - intros i; induction i as [|i _]. + intros. apply idpath. + apply N. Defined. Lemma natltplusS (n i : nat) : i < i + S n. Proof. intros. rewrite <- (natplusr0 i). rewrite natplusassoc. apply natlthandplusl. apply idpath. Defined. Lemma nat_split {n m i : nat} : (i < n + m) -> (i ≥ n) -> i - n < m. Proof. intros p H. induction (plusminusnmm m n). apply natlthandminusl. - induction (natpluscomm n m). exact p. - induction (natpluscomm n m). apply (natlehlthtrans _ i). * assumption. * assumption. Defined. Lemma natplusminusle {a b c} : b ≥ c -> a+(b-c) = (a+b)-c. Proof. intros e. assert (E := minusplusnmm b c e). rewrite <- E. clear E e. rewrite <- natplusassoc. rewrite plusminusnmm. rewrite plusminusnmm. apply idpath. Defined. Lemma natdiffplusdiff {a b c} : a ≥ b -> b ≥ c -> a-c = (a-b) + (b-c). Proof. intros r s. apply (natplusrcan _ _ c). rewrite natplusassoc. rewrite (minusplusnmm _ _ s). rewrite (minusplusnmm _ _ (istransnatleh s r)). exact (! minusplusnmm _ _ r). Defined. UniMath-20231010/UniMath/Foundations/PartA.v000066400000000000000000003774351451125700300203660ustar00rootroot00000000000000(** * Univalent Foundations, Part A Vladimir Voevodsky. Feb. 2010 - Sep. 2011. This file is based on the first part of the original uu0 file. The uu0 file contained the basic results of the univalent foundations that required the use of only one universe. Eventually the requirement concerning one universe was removed because of the general uncertainty in what does it mean for a construction to require only one universe. For example, [ boolsumfun ], when written in terms of the eliminatior [ bool_rect ] instead of the [ match ], requires application of [ bool_rect ] to an argument that is not a member of the base universe [ UU ]. This would be different if the universe management in Coq was constructed differently. Due to this uncertainty we do not consider any more the single universe requirement as a defining one when selecting results for the inclusion in Foundations. Part A was created as a separate file on Dec. 3, 2014. Together with Part B it contains those results that do not require any axioms. This file was edited and expanded by Benedikt Ahrens 2014-2016, Dan Grayson 2014-2016, Vladimir Voevodsky 2014-2016, Alex Kavvos 2014, Peter LeFanu Lumsdaine 2016 and Tomi Pannila 2016. *) (** ** Contents - Preamble - Settings - Imports - Some standard constructions not using identity types (paths) - Canonical functions from [ empty ] and to [unit ] - Identity functions and function composition, curry and uncurry - Iteration of an endomorphism - Basic constructions related to the adjoint evaluation function [ X -> ((X -> Y) -> Y) ] - Pairwise direct products - Negation and double negation - Logical equivalence - Paths and operations on paths - Associativity of function composition and mutual invertibility of curry/uncurry - Composition of paths and inverse paths - Direct product of paths - The function [ maponpaths ] between paths types defined by a function between ambient types - [ maponpaths ] for the identity functions and compositions of functions - Homotopy between functions - Equality between functions defines a homotopy - [ maponpaths ] for a function homotopic to the identity - [ maponpaths ] in the case of a projection p with a section s - Fibrations and paths - the transport functions - A series of lemmas about paths and [ total2 ] - Lemmas about transport adapted from the HoTT library and the HoTT book - Homotopies between families and the total spaces - First fundamental notions - Contractibility [ iscontr ] - Homotopy fibers [ hfiber ] - The functions between the hfibers of homotopic functions over the same point - Paths in homotopy fibers - Coconuses: spaces of paths that begin (coconusfromt) or end (coconustot) at a given point - The total paths space of a type - two definitions - Coconus of a function: the total space of the family of h-fibers - Weak equivalences - Basics - [ isweq ] and [ weq ] - Weak equivalences and paths spaces (more results in further sections) - Adjointness property of a weak equivalence and its inverse - Transport functions are weak equivalences - Weak equivalences between contractible types (one implication) - Unit and contractibility - Homotopy equivalence is a weak equivalence - Some weak equivalences - 2-out-of-3 property of weak equivalences - Any function between contractible types is a weak equivalence - Composition of weak equivalences - 2-out-of-6 property of weak equivalences - Pairwise direct products of weak equivalences - Weak equivalence of a type and its direct product with the unit - Associativity of total2 as a weak equivalence - Associativity and commutativity of direct products as weak equivalences - Binary coproducts and their basic properties - Distributivity of coproducts and direct products as a weak equivalence - Total space of a family over a coproduct - Pairwise sum of functions, coproduct associativity and commutativity - Coproduct with a "negative" type - Coproduct of two functions - The [ equality_cases ] construction and four applications to [ ii1 ] and [ ii2 ] - Bool as coproduct - Pairwise coproducts as dependent sums of families over [ bool ] - Splitting of [ X ] into a coproduct defined by a function [ X -> Y ⨿ Z ] - Some properties of bool - Fibrations with only one non-empty fiber - Basics about fibration sequences - The structures of a complex and of a fibration sequence on a composable pair of functions - Construction of the derived fibration sequence - Explicit description of the first map in the second derived sequence - Fibration sequences based on [ tpair P z ] and [ pr1 : total2 P -> Z ] ( the "pr1-case" ) - Fibration sequences based on [ hfiberpr1 : hfiber g z -> Y ] and [ g : Y -> Z ] (the "g-case") - Fibration sequence of h-fibers defined by a composable pair of functions (the "hf-case") - Functions between total spaces of families - Function [ totalfun ] between total spaces from a family of functions between the fibers - Function [ fpmap ] between the total spaces from a function between the bases - Homotopy fibers of [ fpmap ] - The [ fpmap ] from a weak equivalence is a weak equivalence - Total spaces of families over a contractible base - Function on the total spaces from functions between the bases and between the fibers - Homotopy fiber squares - Homotopy commutative squares - Short complexes and homotopy commutative squares - Homotopy fiber products - Homotopy fiber products and homotopy fibers - Homotopy fiber squares - Fiber sequences and homotopy fiber squares *) (** ** Preamble *) (** *** Imports *) Require Export UniMath.Foundations.Preamble. (* end of "Preamble" *) (** ** Some standard constructions not using identity types (paths) *) (** *** Canonical functions from [ empty ] and to [ unit ] *) Definition fromempty : ∏ X : UU , empty -> X. (* type this in emacs in agda-input method with \prod *) Proof. intro X. intro H. induction H. Defined. Arguments fromempty { X } _. Definition tounit {X : UU} : X -> unit := λ _, tt. (** *** Functions from [ unit ] corresponding to terms *) Definition termfun {X : UU} (x : X) : unit -> X := λ _, x. (** *** Identity functions and function composition, curry and uncurry *) Definition idfun (T : UU) := λ t:T, t. (** makes [simpl], [cbn], etc. unfold [idfun X x] but not [ idfun X ]: *) Arguments idfun _ _ /. Definition funcomp {X Y : UU} {Z:Y->UU} (f : X -> Y) (g : ∏ y:Y, Z y) := λ x, g (f x). (** make [simpl], [cbn], etc. unfold [ (f ∘ g) x ] but not [ f ∘ g ]: *) Arguments funcomp {_ _ _} _ _ _/. Declare Scope functions. Delimit Scope functions with functions. Open Scope functions. Notation "g ∘ f" := (funcomp f g) : functions. (** back and forth between functions of pairs and functions returning functions *) Definition curry {X : UU} {Y : X -> UU} {Z : (∑ x, Y x) -> UU} (f : ∏ p, Z p) : (∏ x : X, ∏ y : Y x, Z (x,, y)) := λ x y, f (x,, y). Definition uncurry {X : UU} {Y : X -> UU} {Z : (∑ x, Y x) -> UU} (g : ∏ x : X, ∏ y : Y x, Z (x,, y)) : (∏ p, Z p) := λ x, g (pr1 x) (pr2 x). (** *** Definition of binary operation *) Definition binop (X : UU) : UU := X -> X -> X. (** *** Iteration of an endomorphism *) Definition iteration {T : UU} (f : T -> T) (n : nat) : T -> T. Proof. induction n as [ | n IHn ]. + exact (idfun T). + exact (f ∘ IHn). Defined. (** *** Basic constructions related to the adjoint evaluation function [ X -> ((X -> Y) -> Y) ] *) Definition adjev {X Y : UU} (x : X) (f : X -> Y) : Y := f x. Definition adjev2 {X Y : UU} (phi : ((X -> Y) -> Y) -> Y) : X -> Y := λ x, phi (λ f, f x). (** *** Pairwise direct products *) Definition dirprod (X Y : UU) := ∑ x:X, Y. Notation "A × B" := (dirprod A B) : type_scope. Definition dirprod_pr1 {X Y : UU} := pr1 : X × Y -> X. Definition dirprod_pr2 {X Y : UU} := pr2 : X × Y -> Y. Definition make_dirprod {X Y : UU} (x:X) (y:Y) : X × Y := x,,y. Definition dirprodadj {X Y Z : UU} (f : X × Y -> Z) : X -> Y -> Z := λ x y, f (x,,y). Definition dirprodf {X Y X' Y' : UU} (f : X -> Y) (f' : X' -> Y') (xx' : X × X') : Y × Y' := make_dirprod (f (pr1 xx')) (f' (pr2 xx')). Definition ddualand {X Y P : UU} (xp : (X -> P) -> P) (yp : (Y -> P) -> P) : (X × Y -> P) -> P. Proof. intros X0. apply xp. intro x. apply yp. intro y. apply (X0 (make_dirprod x y)). Defined. (** *** Negation and double negation *) Definition neg (X : UU) : UU := X -> empty. Notation "'¬' X" := (neg X). (* type this in emacs in agda-input method with \neg *) Notation "x != y" := (neg (x = y)) : type_scope. Definition negf {X Y : UU} (f : X -> Y) : ¬ Y -> ¬ X := λ phi x, phi (f x). Definition dneg (X : UU) : UU := ¬ ¬ X. Notation "'¬¬' X" := (dneg X). (* type this in emacs in agda-input method with \neg twice *) Definition dnegf {X Y : UU} (f : X -> Y) : dneg X -> dneg Y := negf (negf f). Definition todneg (X : UU) : X -> dneg X := adjev. Definition dnegnegtoneg {X : UU} : ¬¬ ¬ X -> ¬ X := adjev2. Lemma dneganddnegl1 {X Y : UU} (dnx : ¬¬ X) (dny : ¬¬ Y) : ¬ (X -> ¬ Y). Proof. intros. intros X2. apply (dnegf X2). + apply dnx. + apply dny. Defined. Definition dneganddnegimpldneg {X Y : UU} (dnx : ¬¬ X) (dny : ¬¬ Y) : ¬¬ (X × Y) := ddualand dnx dny. (** *** Logical equivalence *) Definition logeq (X Y : UU) := (X -> Y) × (Y -> X). Notation " X <-> Y " := (logeq X Y) : type_scope. Lemma isrefl_logeq (X : UU) : X <-> X. Proof. intros. split; apply idfun. Defined. Lemma issymm_logeq (X Y : UU) : (X <-> Y) -> (Y <-> X). Proof. intros e. exact (pr2 e,,pr1 e). Defined. Definition logeqnegs {X Y : UU} (l : X <-> Y) : (¬ X) <-> (¬ Y) := make_dirprod (negf (pr2 l)) (negf (pr1 l)). Definition logeq_both_true {X Y : UU} : X -> Y -> (X <-> Y). Proof. intros x y. split. - intros x'. exact y. - intros y'. exact x. Defined. Definition logeq_both_false {X Y : UU} : ¬X -> ¬Y -> (X <-> Y). Proof. intros nx ny. split. - intros x. induction (nx x). - intros y. induction (ny y). Defined. Definition logeq_trans {X Y Z : UU} : (X <-> Y) -> (Y <-> Z) -> (X <-> Z). Proof. intros i j. exact (pr1 j ∘ pr1 i,, pr2 i ∘ pr2 j). Defined. (* end of "Some standard constructions not using identity types (paths)". *) (** ** Paths and operations on [ paths ] *) (** *** Associativity of function composition and mutual invertibility of curry/uncurry *) (** While the paths in two of the three following lemmas are trivial, having them as lemmas turns out to be convenient in some future proofs. They are used to apply a particular definitional equality to modify the syntactic form of the goal in order to make the next tactic, which uses the syntactic form of the goal to guess how to proceed, to work. The same applies to other lemmas below whose proof is by immediate "reflexivity" or "idpath". *) Lemma funcomp_assoc {X Y Z W : UU} (f : X -> Y) (g : Y -> Z) (h : Z -> W) : h ∘ (g ∘ f) = (h ∘ g) ∘ f. Proof. intros . apply idpath. Defined. Lemma uncurry_curry {X Z : UU} {Y : X -> UU} (f : (∑ x : X, Y x) -> Z) : ∏ p, uncurry (curry f) p = f p. Proof. intros. induction p as [x y]. apply idpath. Defined. Lemma curry_uncurry {X Z : UU} {Y : X -> UU} (g : ∏ x : X, Y x -> Z) : ∏ x y, curry (uncurry g) x y = g x y. Proof. intros. apply idpath. Defined. (** *** Composition of paths and inverse paths *) Definition pathscomp0 {X : UU} {a b c : X} (e1 : a = b) (e2 : b = c) : a = c. Proof. intros. induction e1. apply e2. Defined. #[global] Hint Resolve @pathscomp0 : pathshints. Ltac intermediate_path x := apply (pathscomp0 (b := x)). Ltac etrans := eapply pathscomp0. Notation "p @ q" := (pathscomp0 p q). Definition pathscomp0rid {X : UU} {a b : X} (e1 : a = b) : e1 @ idpath b = e1. Proof. intros. induction e1. simpl. apply idpath. Defined. (** Note that we do not introduce [ pathscomp0lid ] since the corresponding two terms are convertible to each other due to our definition of [ pathscomp0 ]. If we defined it by inductioning [ e2 ] and applying [ e1 ] then [ pathscomp0rid ] would be trivial but [ pathscomp0lid ] would require a proof. Similarly we do not introduce a lemma to connect [ pathsinv0 (idpath _) ] to [ idpath ]. *) Definition pathsinv0 {X : UU} {a b : X} (e : a = b) : b = a. Proof. intros. induction e. apply idpath. Defined. #[global] Hint Resolve @pathsinv0 : pathshints. Definition path_assoc {X} {a b c d:X} (f : a = b) (g : b = c) (h : c = d) : f @ (g @ h) = (f @ g) @ h. Proof. intros. induction f. apply idpath. Defined. Notation "! p " := (pathsinv0 p). Definition pathsinv0l {X : UU} {a b : X} (e : a = b) : !e @ e = idpath _. Proof. intros. induction e. apply idpath. Defined. Definition pathsinv0r {X : UU} {a b : X} (e : a = b) : e @ !e = idpath _. Proof. intros. induction e. apply idpath. Defined. Definition pathsinv0inv0 {X : UU} {x x' : X} (e : x = x') : !(!e) = e. Proof. intros. induction e. apply idpath. Defined. Lemma pathscomp_cancel_left {X : UU} {x y z : X} (p : x = y) (r s : y = z) : p @ r= p @ s -> r = s. Proof. intros e. induction p. exact e. Defined. Lemma pathscomp_cancel_right {X : UU} {x y z : X} (p q : x = y) (s : y = z) : p @ s = q @ s -> p = q. Proof. intros e. induction s. refine (_ @ e @ _). - apply pathsinv0, pathscomp0rid. - apply pathscomp0rid. Defined. Lemma pathscomp_inv {X : UU} {x y z : X} (p : x = y) (q : y = z) : !(p @ q) = !q @ !p. Proof. induction p. induction q. apply idpath. Defined. (** *** Direct product of paths *) Definition pathsdirprod {X Y : UU} {x1 x2 : X} {y1 y2 : Y} (ex : x1 = x2) (ey : y1 = y2) : make_dirprod x1 y1 = make_dirprod x2 y2. Proof. intros. induction ex. induction ey. apply idpath. Defined. Lemma dirprodeq (A B : UU) (ab ab' : A × B) : pr1 ab = pr1 ab' -> pr2 ab = pr2 ab' -> ab = ab'. Proof. intros H H'. induction ab as [a b]. induction ab' as [a' b']; simpl in *. induction H. induction H'. apply idpath. Defined. (** *** The function [ maponpaths ] between paths types defined by a function between ambient types and its behavior relative to [ @ ] and [ ! ] *) Definition maponpaths {T1 T2 : UU} (f : T1 -> T2) {t1 t2 : T1} (e: t1 = t2) : f t1 = f t2. Proof. intros. induction e. apply idpath. Defined. (* useful with apply, to save typing *) Definition map_on_two_paths {X Y Z : UU} (f : X -> Y -> Z) {x x' y y'} (ex : x = x') (ey: y = y') : f x y = f x' y'. Proof. intros. induction ex. induction ey. apply idpath. Defined. Definition maponpathscomp0 {X Y : UU} {x1 x2 x3 : X} (f : X -> Y) (e1 : x1 = x2) (e2 : x2 = x3) : maponpaths f (e1 @ e2) = maponpaths f e1 @ maponpaths f e2. Proof. intros. induction e1. induction e2. apply idpath. Defined. Definition maponpathsinv0 {X Y : UU} (f : X -> Y) {x1 x2 : X} (e : x1 = x2) : maponpaths f (! e) = ! (maponpaths f e). Proof. intros. induction e. apply idpath. Defined. (** *** [ maponpaths ] for the identity functions and compositions of functions *) Lemma maponpathsidfun {X : UU} {x x' : X} (e : x = x') : maponpaths (idfun _) e = e. Proof. intros. induction e. apply idpath. Defined. Lemma maponpathscomp {X Y Z : UU} {x x' : X} (f : X -> Y) (g : Y -> Z) (e : x = x') : maponpaths g (maponpaths f e) = maponpaths (g ∘ f) e. Proof. intros. induction e. apply idpath. Defined. (** *** Homotopy between sections *) Definition homot {X : UU} {P : X -> UU} (f g : ∏ x : X, P x) := ∏ x : X , f x = g x. Notation "f ~ g" := (homot f g). Definition homotrefl {X : UU} {P : X -> UU} (f: ∏ x : X, P x) : f ~ f. Proof. intros x. apply idpath. Defined. Definition homotcomp {X:UU} {Y:X->UU} {f f' f'' : ∏ x : X, Y x} (h : f ~ f') (h' : f' ~ f'') : f ~ f'' := λ x, h x @ h' x. Definition invhomot {X:UU} {Y:X->UU} {f f' : ∏ x : X, Y x} (h : f ~ f') : f' ~ f := λ x, !(h x). Definition funhomot {X Y Z:UU} (f : X -> Y) {g g' : Y -> Z} (h : g ~ g') : g ∘ f ~ g' ∘ f := λ x, h (f x). Definition funhomotsec {X Y:UU} {Z:Y->UU} (f : X -> Y) {g g' : ∏ y:Y, Z y} (h : g ~ g') : g ∘ f ~ g' ∘ f := λ x, h (f x). Definition homotfun {X Y Z : UU} {f f' : X -> Y} (h : f ~ f') (g : Y -> Z) : g ∘ f ~ g ∘ f' := λ x, maponpaths g (h x). (** *** Equality between functions defines a homotopy *) Definition toforallpaths {T:UU} (P:T->UU) (f g:∏ t:T, P t) : f = g -> f ~ g. Proof. intros h t. induction h. apply (idpath _). Defined. Definition eqtohomot {T:UU} {P:T->UU} {f g:∏ t:T, P t} : f = g -> f ~ g. (* the same as toforallpaths, but with different implicit arguments *) Proof. intros e t. induction e. apply idpath. Defined. (** *** [ maponpaths ] for a function homotopic to the identity The following three statements show that [ maponpaths ] defined by a function f which is homotopic to the identity is "surjective". It is later used to show that the maponpaths defined by a function which is a weak equivalence is itself a weak equivalence. *) (** Note that the type of the assumption h below can equivalently be written as [ homot f ( idfun X ) ] *) Definition maponpathshomidinv {X : UU} (f : X -> X) (h : ∏ x : X, f x = x) (x x' : X) (e : f x = f x') : x = x' := ! (h x) @ e @ (h x'). Lemma maponpathshomid1 {X : UU} (f : X -> X) (h: ∏ x : X, f x = x) {x x' : X} (e : x = x') : maponpaths f e = (h x) @ e @ (! h x'). Proof. intros. induction e. simpl. apply pathsinv0. apply pathsinv0r. Defined. Lemma maponpathshomid2 {X : UU} (f : X -> X) (h : ∏ x : X, f x = x) (x x' : X) (e: f x = f x') : maponpaths f (maponpathshomidinv f h _ _ e) = e. Proof. intros. unfold maponpathshomidinv. apply (pathscomp0 (maponpathshomid1 f h (! h x @ e @ h x'))). assert (l : ∏ (X : UU) (a b c d : X) (p : a = b) (q : a = c) (r : c = d), p @ (!p @ q @ r) @ !r = q). { intros. induction p. induction q. induction r. apply idpath. } apply (l _ _ _ _ _ (h x) e (h x')). Defined. (** *** [ maponpaths ] in the case of a projection p with a section s *) (** Note that the type of the assumption eps below can equivalently be written as [ homot ( funcomp s p ) ( idfun X ) ] *) Definition pathssec1 {X Y : UU} (s : X -> Y) (p : Y -> X) (eps : ∏ (x : X) , p (s x) = x) (x : X) (y : Y) (e : s x = y) : x = p y. Proof. intros. apply (pathscomp0 (! eps x)). apply (maponpaths p e). Defined. Definition pathssec2 {X Y : UU} (s : X -> Y) (p : Y -> X) (eps : ∏ (x : X), p (s x) = x) (x x' : X) (e : s x = s x') : x = x'. Proof. intros. set (e' := pathssec1 s p eps _ _ e). apply (e' @ (eps x')). Defined. Definition pathssec2id {X Y : UU} (s : X -> Y) (p : Y -> X) (eps : ∏ x : X, p (s x) = x) (x : X) : pathssec2 s p eps _ _ (idpath (s x)) = idpath x. Proof. intros. unfold pathssec2. unfold pathssec1. simpl. assert (e : ∏ X : UU, ∏ a b : X, ∏ p : a = b, (! p @ idpath _) @ p = idpath _). { intros. induction p0. simpl. apply idpath. } apply e. Defined. Definition pathssec3 {X Y : UU} (s : X -> Y) (p : Y -> X) (eps : ∏ x : X, p (s x) = x) {x x' : X} (e : x = x') : pathssec2 s p eps _ _ (maponpaths s e) = e. Proof. intros. induction e. simpl. apply pathssec2id. Defined. (** *** Fibrations and paths - the transport functions *) Definition constr1 {X : UU} (P : X -> UU) {x x' : X} (e : x = x') : ∑ (f : P x -> P x'), ∑ (ee : ∏ p : P x, tpair _ x p = tpair _ x' (f p)), ∏ (pp : P x), maponpaths pr1 (ee pp) = e. Proof. intros. induction e. split with (idfun (P x)). split with (λ p, idpath _). unfold maponpaths. simpl. intro. apply idpath. Defined. Definition transportf {X : UU} (P : X -> UU) {x x' : X} (e : x = x') : P x -> P x' := pr1 (constr1 P e). Definition transportf_eq {X : UU} (P : X -> UU) {x x' : X} (e : x = x') ( p : P x ) : tpair _ x p = tpair _ x' ( transportf P e p ) := ( pr1 ( pr2 ( constr1 P e ))) p . Definition transportb {X : UU} (P : X -> UU) {x x' : X} (e : x = x') : P x' -> P x := transportf P (!e). Declare Scope transport. Notation "p # x" := (transportf _ p x) (only parsing) : transport. Notation "p #' x" := (transportb _ p x) (only parsing) : transport. Delimit Scope transport with transport. Definition idpath_transportf {X : UU} (P : X -> UU) {x : X} (p : P x) : transportf P (idpath x) p = p. Proof. intros. apply idpath. Defined. Lemma functtransportf {X Y : UU} (f : X -> Y) (P : Y -> UU) {x x' : X} (e : x = x') (p : P (f x)) : transportf (λ x, P (f x)) e p = transportf P (maponpaths f e) p. Proof. intros. induction e. apply idpath. Defined. Lemma functtransportb {X Y : UU} (f : X -> Y) (P : Y -> UU) {x x' : X} (e : x' = x) (p : P (f x)) : transportb (λ x, P (f x)) e p = transportb P (maponpaths f e) p. Proof. intros. induction e. apply idpath. Defined. Definition transport_f_b {X : UU} (P : X ->UU) {x y z : X} (e : y = x) (e' : y = z) (p : P x) : transportf P e' (transportb P e p) = transportf P (!e @ e') p. Proof. intros. induction e'. induction e. apply idpath. Defined. Definition transport_b_f {X : UU} (P : X ->UU) {x y z : X} (e : x = y) (e' : z = y) (p : P x) : transportb P e' (transportf P e p) = transportf P (e @ !e') p. Proof. intros. induction e'. induction e. apply idpath. Defined. Definition transport_f_f {X : UU} (P : X ->UU) {x y z : X} (e : x = y) (e' : y = z) (p : P x) : transportf P e' (transportf P e p) = transportf P (e @ e') p. Proof. intros. induction e'. induction e. apply idpath. Defined. Definition transport_b_b {X : UU} (P : X ->UU) {x y z : X} (e : x = y) (e' : y = z) (p : P z) : transportb P e (transportb P e' p) = transportb P (e @ e') p. Proof. intros. induction e'. induction e. apply idpath. Defined. Definition transport_map {X : UU} {P Q : X -> UU} (f : ∏ x, P x -> Q x) {x : X} {y : X} (e : x = y) (p : P x) : transportf Q e (f x p) = f y (transportf P e p). Proof. intros. induction e. apply idpath. Defined. Definition transport_section {X : UU} {P:X -> UU} (f : ∏ x, P x) {x : X} {y : X} (e : x = y) : transportf P e (f x) = f y. Proof. intros. exact (transport_map (P:= λ _,unit) (λ x _,f x) e tt). Defined. Definition transportf_fun {X Y : UU}(P : X -> UU) {x1 x2 : X}(e : x1 = x2)(f : P x1 -> Y) : transportf (λ x, (P x -> Y)) e f = f ∘ transportb P e . Proof. intros. induction e. apply idpath . Defined. Lemma transportb_fun' {X:UU} {P:X->UU} {Z:UU} {x x':X} (f:P x'->Z) (p:x=x') (y:P x) : f (transportf P p y) = transportb (λ x, P x->Z) p f y. Proof. intros. induction p. apply idpath. Defined. Definition transportf_const {X : UU}{x1 x2 : X}(e : x1 = x2)(Y : UU) : transportf (λ x, Y) e = idfun Y. Proof. intros. induction e. apply idpath. Defined. Definition transportb_const {X : UU}{x1 x2 : X}(e : x1 = x2)(Y : UU) : transportb (λ x, Y) e = idfun Y. Proof. intros. induction e. apply idpath. Defined. Lemma transportf_paths {X : UU} (P : X -> UU) {x1 x2 : X} {e1 e2 : x1 = x2} (e : e1 = e2) (p : P x1) : transportf P e1 p = transportf P e2 p. Proof. induction e. apply idpath. Defined. Opaque transportf_paths. Local Open Scope transport. Definition transportbfinv {T} (P:T->Type) {t u:T} (e:t = u) (p:P t) : e#'e#p = p. Proof. intros. induction e. apply idpath. Defined. Definition transportfbinv {T} (P:T->Type) {t u:T} (e:t = u) (p:P u) : e#e#'p = p. Proof. intros. induction e. apply idpath. Defined. Close Scope transport. (** *** A series of lemmas about paths and [ total2 ] Some lemmas are adapted from the HoTT library http://github.com/HoTT/HoTT *) Lemma base_paths {A : UU} {B : A -> UU} (a b : total2 B) : a = b -> pr1 a = pr1 b. Proof. intros. apply maponpaths; assumption. Defined. Lemma two_arg_paths {A B C:UU} {f : A -> B -> C} {a1 b1 a2 b2} (p : a1 = a2) (q : b1 = b2) : f a1 b1 = f a2 b2. (* This lemma is an analogue of [maponpaths] for functions of two arguments. *) Proof. intros. induction p. induction q. apply idpath. Defined. Lemma two_arg_paths_f {A : UU} {B : A -> UU} {C:UU} {f : ∏ a, B a -> C} {a1 b1 a2 b2} (p : a1 = a2) (q : transportf B p b1 = b2) : f a1 b1 = f a2 b2. (* This lemma is a replacement for and a generalization of [total2_paths2_f], formerly called [total2_paths2], which does not refer to [total2]. The lemma [total2_paths2_f] can be obtained as the special case [f := tpair _], and Coq can often infer the value for [f], which is declared as an implicit argument. *) Proof. intros. induction p. induction q. apply idpath. Defined. Lemma two_arg_paths_b {A : UU} {B : A -> UU} {C:UU} {f : ∏ a, B a -> C} {a1 b1 a2 b2} (p : a1 = a2) (q : b1 = transportb B p b2) : f a1 b1 = f a2 b2. (* This lemma is a replacement for and a generalization of [total2_paths2_b], which does not refer to [total2]. The lemma [total2_paths2_b] can be obtained as the special case [f := tpair _], and Coq can often infer the value for [f], which is declared as an implicit argument. *) Proof. intros. induction p. change _ with (b1 = b2) in q. induction q. apply idpath. Defined. Lemma dirprod_paths {A : UU} {B : UU} {s s' : A × B} (p : pr1 s = pr1 s') (q : pr2 s = pr2 s') : s = s'. Proof. intros. induction s as [a b]; induction s' as [a' b']; simpl in *. exact (two_arg_paths p q). Defined. Lemma total2_paths_f {A : UU} {B : A -> UU} {s s' : ∑ x, B x} (p : pr1 s = pr1 s') (q : transportf B p (pr2 s) = pr2 s') : s = s'. Proof. intros. induction s as [a b]; induction s' as [a' b']; simpl in *. exact (two_arg_paths_f p q). Defined. Lemma total2_paths_b {A : UU} {B : A -> UU} {s s' : ∑ x, B x} (p : pr1 s = pr1 s') (q : pr2 s = transportb B p (pr2 s')) : s = s'. Proof. intros. induction s as [a b]; induction s' as [a' b']; simpl in *. exact (two_arg_paths_b p q). Defined. Lemma total2_paths2 {A : UU} {B : UU} {a1 a2:A} {b1 b2:B} (p : a1 = a2) (q : b1 = b2) : a1,,b1 = a2,,b2. Proof. intros. exact (two_arg_paths p q). Defined. Lemma total2_paths2_f {A : UU} {B : A -> UU} {a1 : A} {b1 : B a1} {a2 : A} {b2 : B a2} (p : a1 = a2) (q : transportf B p b1 = b2) : a1,,b1 = a2,,b2. Proof. intros. exact (two_arg_paths_f p q). Defined. Lemma total2_paths2_b {A : UU} {B : A -> UU} {a1 : A} {b1 : B a1} {a2 : A} {b2 : B a2} (p : a1 = a2) (q : b1 = transportb B p b2) : a1,,b1 = a2,,b2. Proof. intros. exact (two_arg_paths_b p q). Defined. Definition pair_path_in2 {X : UU} (P : X -> UU) {x : X} {p q : P x} (e : p = q) : x,,p = x,,q. (* this function can often replaced by [maponpaths _] or by [maponpaths (tpair _ _)], except when the pairs in the goal have not been simplified enough to make the equality of their first parts evident, in which case this can be useful *) Proof. intros. apply maponpaths. exact e. Defined. Definition fiber_paths {A : UU} {B : A -> UU} {u v : ∑ x, B x} (p : u = v) : transportf (λ x, B x) (base_paths _ _ p) (pr2 u) = pr2 v. Proof. induction p. apply idpath. Defined. Lemma total2_fiber_paths {A : UU} {B : A -> UU} {x y : ∑ x, B x} (p : x = y) : total2_paths_f _ (fiber_paths p) = p. Proof. induction p. induction x. apply idpath. Defined. Lemma base_total2_paths {A : UU} {B : A -> UU} {x y : ∑ x, B x} {p : pr1 x = pr1 y} (q : transportf _ p (pr2 x) = pr2 y) : (base_paths _ _ (total2_paths_f _ q)) = p. Proof. induction x as [x H]. induction y as [y K]. simpl in *. induction p. induction q. apply idpath. Defined. Lemma transportf_fiber_total2_paths {A : UU} (B : A -> UU) (x y : ∑ x, B x) (p : pr1 x = pr1 y) (q : transportf _ p (pr2 x) = pr2 y) : transportf (λ p' : pr1 x = pr1 y, transportf _ p' (pr2 x) = pr2 y) (base_total2_paths q) (fiber_paths (total2_paths_f _ q)) = q. Proof. induction x as [x H]. induction y as [y K]. simpl in *. induction p. induction q. apply idpath. Defined. Definition total2_base_map {S T:UU} {P: T -> UU} (f : S->T) : (∑ i, P(f i)) -> (∑ j, P j). Proof. intros x. exact (f(pr1 x),,pr2 x). Defined. Lemma total2_section_path {X:UU} {Y:X->UU} (a:X) (b:Y a) (e:∏ x, Y x) : (a,,e a) = (a,,b) -> e a = b. (* this is called "Voldemort's theorem" by David McAllester, https://arxiv.org/pdf/1407.7274.pdf *) Proof. intros p. simple refine (_ @ fiber_paths p). unfold base_paths. simpl. apply pathsinv0, transport_section. Defined. (** *** Lemmas about transport adapted from the HoTT library and the HoTT book *) Definition transportD {A : UU} (B : A -> UU) (C : ∏ a : A, B a -> UU) {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1 y) : C x2 (transportf _ p y). Proof. intros. induction p. exact z. Defined. Definition transportf_total2 {A : UU} {B : A -> UU} {C : ∏ a:A, B a -> UU} {x1 x2 : A} (p : x1 = x2) (yz : ∑ y : B x1, C x1 y) : transportf (λ x, ∑ y : B x, C x y) p yz = tpair (λ y, C x2 y) (transportf _ p (pr1 yz)) (transportD _ _ p (pr1 yz) (pr2 yz)). Proof. intros. induction p. induction yz. apply idpath. Defined. Definition transportf_dirprod (A : UU) (B B' : A -> UU) (x x' : ∑ a, B a × B' a) (p : pr1 x = pr1 x') : transportf (λ a, B a × B' a) p (pr2 x) = make_dirprod (transportf (λ a, B a) p (pr1 (pr2 x))) (transportf (λ a, B' a) p (pr2 (pr2 x))). Proof. induction p. apply idpath. Defined. Definition transportb_dirprod (A : UU) (B B' : A -> UU) (x x' : ∑ a, B a × B' a) (p : pr1 x = pr1 x') : transportb (λ a, B a × B' a) p (pr2 x') = make_dirprod (transportb (λ a, B a) p (pr1 (pr2 x'))) (transportb (λ a, B' a) p (pr2 (pr2 x'))). Proof. intros. apply transportf_dirprod. Defined. Definition transportf_id1 {A : UU} {a x1 x2 : A} (p : x1 = x2) (q : a = x1) : transportf (λ (x : A), a = x) p q = q @ p. Proof. intros. induction p. induction q. apply idpath. Defined. Definition transportf_id2 {A : UU} {a x1 x2 : A} (p : x1 = x2) (q : x1 = a) : transportf (λ (x : A), x = a) p q = !p @ q. Proof. intros. induction p. induction q. apply idpath. Defined. Definition transportf_id3 {A : UU} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) : transportf (λ (x : A), x = x) p q = !p @ q @ p. Proof. intros. induction p. simpl. apply pathsinv0. apply pathscomp0rid. Defined. (** *** Homotopies between families and the total spaces *) Definition famhomotfun {X : UU} {P Q : X -> UU} (h : P ~ Q) (xp : total2 P) : total2 Q. Proof. intros. exists (pr1 xp). induction (h (pr1 xp)). apply (pr2 xp). Defined. Definition famhomothomothomot {X : UU} {P Q : X -> UU} (h1 h2 : P ~ Q) (H : h1 ~ h2) : famhomotfun h1 ~ famhomotfun h2. Proof. intros. intro xp. apply (maponpaths (λ q, tpair Q (pr1 xp) q)). induction (H (pr1 xp)). apply idpath. Defined. (** ** First fundamental notions *) (** *** Contractibility [ iscontr ] *) Definition iscontr (T:UU) : UU := ∑ cntr:T, ∏ t:T, t=cntr. Notation "'∃!' x .. y , P" := (iscontr (∑ x, .. (∑ y, P) ..)) (at level 200, x binder, y binder, right associativity) : type_scope. (* type this in emacs in agda-input method with \ex ! *) Definition make_iscontr {T : UU} : ∏ x : T, (∏ t : T, t = x) -> iscontr T := tpair _. Definition iscontrpr1 {T : UU} : iscontr T -> T := pr1. Definition iscontr_uniqueness {T} (i:iscontr T) (t:T) : t = iscontrpr1 i := pr2 i t. Lemma iscontrretract {X Y : UU} (p : X -> Y) (s : Y -> X) (eps : ∏ y : Y, p (s y) = y) (is : iscontr X) : iscontr Y. Proof. intros. set (x := iscontrpr1 is). set (fe := pr2 is). split with (p x). intro t. apply (! (eps t) @ maponpaths p (fe (s t))). Defined. Lemma proofirrelevancecontr {X : UU} (is : iscontr X) (x x' : X) : x = x'. Proof. intros. apply ((pr2 is) x @ !(pr2 is x')). Defined. Lemma path_to_ctr (A : UU) (B : A -> UU) (isc : ∃! a, B a) (a : A) (p : B a) : a = pr1 (pr1 isc). Proof. set (Hi := tpair _ a p). apply (maponpaths pr1 (pr2 isc Hi)). Defined. (** *** Homotopy fibers [ hfiber ] *) Definition hfiber {X Y : UU} (f : X -> Y) (y : Y) : UU := ∑ x : X, f x = y. Definition make_hfiber {X Y : UU} (f : X -> Y) {y : Y} (x : X) (e : f x = y) : hfiber f y := tpair _ x e. Definition hfiberpr1 {X Y : UU} (f : X -> Y) (y : Y) : hfiber f y -> X := pr1. Definition hfiberpr2 {X Y : UU} (f : X -> Y) (y : Y) (y' : hfiber f y) : f (hfiberpr1 f y y') = y := pr2 y'. (** *** The functions between the hfibers of homotopic functions over the same point *) Lemma hfibershomotftog {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) : hfiber f y -> hfiber g y. Proof. intros xe. induction xe as [x e]. split with x. apply (!(h x) @ e). Defined. Lemma hfibershomotgtof {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) : hfiber g y -> hfiber f y. Proof. intros xe. induction xe as [x e]. split with x. apply (h x @ e). Defined. (** *** Paths in homotopy fibers *) Lemma hfibertriangle1 {X Y : UU} (f : X -> Y) {y : Y} {xe1 xe2 : hfiber f y} (e : xe1 = xe2) : pr2 xe1 = maponpaths f (maponpaths pr1 e) @ pr2 xe2. Proof. intros. induction e. simpl. apply idpath. Defined. Corollary hfibertriangle1' {X Y : UU} (f : X -> Y) {x : X} {xe1: hfiber f (f x)} (e : xe1 = (x,,idpath (f x))) : pr2 xe1 = maponpaths f (maponpaths pr1 e). Proof. intros. intermediate_path (maponpaths f (maponpaths pr1 e) @ idpath (f x)). - apply hfibertriangle1. - apply pathscomp0rid. Defined. Lemma hfibertriangle1inv0 {X Y : UU} (f : X -> Y) {y : Y} {xe1 xe2: hfiber f y} (e : xe1 = xe2) : maponpaths f (! (maponpaths pr1 e)) @ (pr2 xe1) = pr2 xe2. Proof. intros. induction e. apply idpath. Defined. Corollary hfibertriangle1inv0' {X Y : UU} (f : X -> Y) {x : X} {xe2: hfiber f (f x)} (e : (x,,idpath (f x)) = xe2) : maponpaths f (! (maponpaths pr1 e)) = pr2 xe2. Proof. intros. intermediate_path (maponpaths f (! (maponpaths pr1 e)) @ idpath (f x)). - apply pathsinv0, pathscomp0rid. - apply hfibertriangle1inv0. Defined. Lemma hfibertriangle2 {X Y : UU} (f : X -> Y) {y : Y} (xe1 xe2: hfiber f y) (ee: pr1 xe1 = pr1 xe2) (eee: pr2 xe1 = maponpaths f ee @ (pr2 xe2)) : xe1 = xe2. Proof. intros. induction xe1 as [t e1]. induction xe2 as [t' e2]. simpl in *. fold (make_hfiber f t e1). fold (make_hfiber f t' e2). induction ee. simpl in eee. apply (maponpaths (λ e, make_hfiber f t e) eee). Defined. (** *** Coconuses: spaces of paths that begin [ coconusfromt ] or end [ coconustot ] at a given point *) Definition coconusfromt (T : UU) (t : T) := ∑ t' : T, t = t'. Definition coconusfromtpair (T : UU) {t t' : T} (e: t = t') : coconusfromt T t := tpair _ t' e. Definition coconusfromtpr1 (T : UU) (t : T) : coconusfromt T t -> T := pr1. Definition coconustot (T : UU) (t : T) := ∑ t' : T, t' = t. Definition coconustotpair (T : UU) {t t' : T} (e: t' = t) : coconustot T t := tpair _ t' e. Definition coconustotpr1 (T : UU) (t : T) : coconustot T t -> T := pr1. (* There is a path between any two points in a coconus. As we always have a point in a coconus, namely the one that is given by the pair of t and the path that starts at t and ends at t, the coconuses are contractible. *) Lemma coconustot_isProofIrrelevant {T : UU} {t : T} (c1 c2 : coconustot T t) : c1 = c2. Proof. intros. induction c1 as [x0 x]. induction x. induction c2 as [x1 y]. induction y. apply idpath. Defined. Lemma iscontrcoconustot (T : UU) (t : T) : iscontr (coconustot T t). Proof. use (tpair _ (t,, idpath t)). intros [u []]. reflexivity. Defined. Lemma coconusfromt_isProofIrrelevant {T : UU} {t : T} (c1 c2 : coconusfromt T t) : c1 = c2. Proof. intros. induction c1 as [x0 x]. induction x. induction c2 as [x1 y]. induction y. apply idpath. Defined. Lemma iscontrcoconusfromt (T : UU) (t : T) : iscontr (coconusfromt T t). Proof. use (tpair _ (t,, idpath t)). intros [u []]. reflexivity. Defined. (** *** The total paths space of a type - two definitions The definitions differ by the (non) associativity of the [ total2 ]. *) Definition pathsspace (T : UU) := ∑ t:T, coconusfromt T t. Definition pathsspacetriple (T : UU) {t1 t2 : T} (e : t1 = t2) : pathsspace T := tpair _ t1 (coconusfromtpair T e). Definition deltap (T : UU) : T -> pathsspace T := λ (t : T), pathsspacetriple T (idpath t). Definition pathsspace' (T : UU) := ∑ xy : T × T, pr1 xy = pr2 xy. (** *** Coconus of a function: the total space of the family of h-fibers *) Definition coconusf {X Y : UU} (f : X -> Y) := ∑ y:Y, hfiber f y. Definition fromcoconusf {X Y : UU} (f : X -> Y) : coconusf f -> X := λ yxe, pr1 (pr2 yxe). Definition tococonusf {X Y : UU} (f : X -> Y) : X -> coconusf f := λ x, tpair _ (f x) (make_hfiber f x (idpath _)). Lemma homottofromcoconusf {X Y : UU} (f : X -> Y) : ∏ yxe : coconusf f, tococonusf f (fromcoconusf f yxe) = yxe. Proof. intros. induction yxe as [y xe]. induction xe as [x e]. unfold fromcoconusf. unfold tococonusf. simpl. induction e. apply idpath. Defined. Lemma homotfromtococonusf {X Y : UU} (f : X -> Y) : ∏ x : X, fromcoconusf f (tococonusf f x) = x. Proof. intros. unfold fromcoconusf. unfold tococonusf. simpl. apply idpath. Defined. (** ** Weak equivalences *) (** *** Basics - [ isweq ] and [ weq ] *) Definition isweq {X Y : UU} (f : X -> Y) : UU := ∏ y : Y, iscontr (hfiber f y). Lemma idisweq (T : UU) : isweq (idfun T). Proof. intros. unfold isweq. intro y. unfold iscontr. split with (make_hfiber (idfun T) y (idpath y)). intro t. induction t as [x e]. induction e. apply idpath. Defined. Definition weq (X Y : UU) : UU := ∑ f:X->Y, isweq f. Notation "X ≃ Y" := (weq X%type Y%type) : type_scope. (* written \~- or \simeq in Agda input method *) Definition pr1weq {X Y : UU} := pr1 : X ≃ Y -> (X -> Y). Coercion pr1weq : weq >-> Funclass. Definition weqproperty {X Y} (f:X≃Y) : isweq f := pr2 f. Definition weqccontrhfiber {X Y : UU} (w : X ≃ Y) (y : Y) : hfiber w y. Proof. intros. apply (iscontrpr1 (weqproperty w y)). Defined. Definition weqccontrhfiber2 {X Y : UU} (w : X ≃ Y) (y : Y) : ∏ x : hfiber w y, x = weqccontrhfiber w y. Proof. intros. unfold weqccontrhfiber. apply (pr2 (pr2 w y)). Defined. Definition make_weq {X Y : UU} (f : X -> Y) (is: isweq f) : X ≃ Y := tpair (λ f : X -> Y, isweq f) f is. Definition idweq (X : UU) : X ≃ X := tpair (λ f : X -> X, isweq f) (λ (x : X), x) (idisweq X). Definition isweqtoempty {X : UU} (f : X -> ∅) : isweq f. Proof. intros. intro y. apply (fromempty y). Defined. Definition weqtoempty {X : UU} (f : X -> ∅) : X ≃ ∅ := make_weq _ (isweqtoempty f). Lemma isweqtoempty2 {X Y : UU} (f : X -> Y) (is : ¬ Y) : isweq f. Proof. intros. intro y. induction (is y). Defined. Definition weqtoempty2 {X Y : UU} (f : X -> Y) (is : ¬ Y) : X ≃ Y := make_weq _ (isweqtoempty2 f is). Definition weqempty {X Y : UU} : ¬X → ¬Y → X≃Y. Proof. intros nx ny. use make_weq. - intro x. apply fromempty, nx. exact x. - intro y. apply fromempty, ny. exact y. Defined. Definition invmap {X Y : UU} (w : X ≃ Y) : Y -> X := λ (y : Y), hfiberpr1 _ _ (weqccontrhfiber w y). (** *** Weak equivalences and paths spaces (more results in further sections) *) (** We now define different homotopies and maps between the paths spaces corresponding to a weak equivalence. What may look like unnecessary complexity in the definition of [ homotinvweqweq ] is due to the fact that the "naive" definition needs to be corrected in order for lemma [ homotweqinvweqweq ] to hold. *) Definition homotweqinvweq {X Y : UU} (w : X ≃ Y) : ∏ y : Y, w (invmap w y) = y. Proof. intros. unfold invmap. apply (pr2 (weqccontrhfiber w y)). Defined. Definition homotinvweqweq0 {X Y : UU} (w : X ≃ Y) : ∏ x : X, x = invmap w (w x). Proof. intros. unfold invmap. set (xe1 := weqccontrhfiber w (w x)). set (xe2 := make_hfiber w x (idpath (w x))). set (p := weqccontrhfiber2 w (w x) xe2). apply (maponpaths pr1 p). Defined. Definition homotinvweqweq {X Y : UU} (w : X ≃ Y) : ∏ x : X, invmap w (w x) = x := λ (x : X), ! (homotinvweqweq0 w x). Definition invmaponpathsweq {X Y : UU} (w : X ≃ Y) (x x' : X) : w x = w x' -> x = x' := pathssec2 w (invmap w) (homotinvweqweq w) x x'. Definition invmaponpathsweqid {X Y : UU} (w : X ≃ Y) (x : X) : invmaponpathsweq w _ _ (idpath (w x)) = idpath x := pathssec2id w (invmap w) (homotinvweqweq w) x. Definition pathsweq1 {X Y : UU} (w : X ≃ Y) (x : X) (y : Y) : w x = y -> x = invmap w y := λ e, maponpaths pr1 (pr2 (weqproperty w y) (x,,e)). Definition pathsweq1' {X Y : UU} (w : X ≃ Y) (x : X) (y : Y) : x = invmap w y -> w x = y := λ e, maponpaths w e @ homotweqinvweq w y. Definition pathsweq3 {X Y : UU} (w : X ≃ Y) {x x' : X} (e : x = x') : invmaponpathsweq w x x' (maponpaths w e) = e := pathssec3 w (invmap w) (homotinvweqweq w) _. Definition pathsweq4 {X Y : UU} (w : X ≃ Y) (x x' : X) (e : w x = w x') : maponpaths w (invmaponpathsweq w x x' e) = e. Proof. intros. induction w as [f is1]. set (w := make_weq f is1). set (g := invmap w). set (ee := maponpaths g e). simpl in *. set (eee := maponpathshomidinv (g ∘ f) (homotinvweqweq w) x x' ee). assert (e1 : maponpaths f eee = e). { assert (e2 : maponpaths (g ∘ f) eee = ee). { apply maponpathshomid2. } assert (e3 : maponpaths g (maponpaths f eee) = maponpaths g e). { apply (maponpathscomp f g eee @ e2). } set (s := @maponpaths _ _ g (f x) (f x')). set (p := @pathssec2 _ _ g f (homotweqinvweq w) (f x) (f x')). set (eps := @pathssec3 _ _ g f (homotweqinvweq w) (f x) (f x')). apply (pathssec2 s p eps _ _ e3). } assert (e4: maponpaths f (invmaponpathsweq w x x' (maponpaths f eee)) = maponpaths f (invmaponpathsweq w x x' e)). { apply (maponpaths (λ e0: f x = f x', maponpaths f (invmaponpathsweq w x x' e0)) e1). } assert (X0 : invmaponpathsweq w x x' (maponpaths f eee) = eee). { apply (pathsweq3 w). } assert (e5: maponpaths f (invmaponpathsweq w x x' (maponpaths f eee)) = maponpaths f eee). { apply (maponpaths (λ eee0: x = x', maponpaths f eee0) X0). } apply (! e4 @ e5 @ e1). Defined. Lemma homotweqinv {X Y Z} (f:X->Z) (w:X≃Y) (g:Y->Z) : f ~ g ∘ w -> f ∘ invmap w ~ g. Proof. intros p y. simple refine (p (invmap w y) @ _); clear p. simpl. apply maponpaths. apply homotweqinvweq. Defined. Lemma homotweqinv' {X Y Z} (f:X->Z) (w:X≃Y) (g:Y->Z) : f ~ g ∘ w <- f ∘ invmap w ~ g. Proof. intros q x. simple refine (_ @ q (w x)). simpl. apply maponpaths, pathsinv0. apply homotinvweqweq. Defined. Definition isinjinvmap {X Y} (v w:X≃Y) : invmap v ~ invmap w -> v ~ w. Proof. intros h x. intermediate_path (w ((invmap w) (v x))). { apply pathsinv0. apply homotweqinvweq. } rewrite <- h. rewrite homotinvweqweq. apply idpath. Defined. Definition isinjinvmap' {X Y} (v w:X->Y) (v' w':Y->X) : w ∘ w' ~ idfun Y -> v' ∘ v ~ idfun X -> v' ~ w' -> v ~ w. Proof. intros p q h x . intermediate_path (w (w' (v x))). { apply pathsinv0. apply p. } apply maponpaths. rewrite <- h. apply q. Defined. (** *** Adjointness property of a weak equivalence and its inverse *) Lemma diaglemma2 {X Y : UU} (f : X -> Y) {x x' : X} (e1 : x = x') (e2 : f x' = f x) (ee : idpath (f x) = maponpaths f e1 @ e2) : maponpaths f (! e1) = e2. Proof. intros. induction e1. simpl in *. exact ee. Defined. (* this is the adjointness relation for w and its homotopy inverse: *) Definition homotweqinvweqweq {X Y : UU} (w : X ≃ Y) (x : X) : maponpaths w (homotinvweqweq w x) = homotweqinvweq w (w x). Proof. intros. unfold homotinvweqweq. unfold homotinvweqweq0. set (hfid := make_hfiber w x (idpath (w x))). set (hfcc := weqccontrhfiber w (w x)). unfold homotweqinvweq. apply diaglemma2. apply (@hfibertriangle1 _ _ w _ hfid hfcc (weqccontrhfiber2 w (w x) hfid)). Defined. (* another way the adjointness relation may occur (added by D. Grayson, Oct. 2015): *) Definition weq_transportf_adjointness {X Y : UU} (w : X ≃ Y) (P : Y -> UU) (x : X) (p : P (w x)) : transportf (P ∘ w) (! homotinvweqweq w x) p = transportf P (! homotweqinvweq w (w x)) p. Proof. intros. refine (functtransportf w P (!homotinvweqweq w x) p @ _). apply (maponpaths (λ e, transportf P e p)). rewrite maponpathsinv0. apply maponpaths. apply homotweqinvweqweq. Defined. Definition weq_transportb_adjointness {X Y : UU} (w : X ≃ Y) (P : Y -> UU) (x : X) (p : P (w x)) : transportb (P ∘ w) (homotinvweqweq w x) p = transportb P (homotweqinvweq w (w x)) p. Proof. intros. refine (functtransportb w P (homotinvweqweq w x) p @ _). apply (maponpaths (λ e, transportb P e p)). apply homotweqinvweqweq. Defined. (** *** Transport functions are weak equivalences *) Lemma isweqtransportf {X : UU} (P : X -> UU) {x x' : X} (e : x = x') : isweq (transportf P e). Proof. intros. induction e. unfold transportf. simpl. apply idisweq. Defined. Lemma isweqtransportb {X : UU} (P : X -> UU) {x x' : X} (e : x = x') : isweq (transportb P e). Proof. intros. apply (isweqtransportf _ (pathsinv0 e)). Defined. (** *** Weak equivalences between contractible types (one implication) *) Lemma iscontrweqb {X Y : UU} (w : X ≃ Y) (is : iscontr Y) : iscontr X. Proof. intros. apply (iscontrretract (invmap w) w (homotinvweqweq w) is). Defined. (** *** [ unit ] and contractibility *) (** [ unit ] is contractible (recall that [ tt ] is the name of the canonical term of the type [ unit ]). *) Lemma isProofIrrelevantUnit : ∏ x x' : unit, x = x'. Proof. intros. induction x. induction x'. apply idpath. Defined. Lemma unitl0 : tt = tt -> coconustot _ tt. Proof. intros e. apply (coconustotpair unit e). Defined. Lemma unitl1: coconustot _ tt -> tt = tt. Proof. intro cp. induction cp as [x t]. induction x. exact t. Defined. Lemma unitl2: ∏ e : tt = tt, unitl1 (unitl0 e) = e. Proof. intros. unfold unitl0. simpl. apply idpath. Defined. Lemma unitl3: ∏ e : tt = tt, e = idpath tt. Proof. intros. assert (e0 : unitl0 (idpath tt) = unitl0 e). { apply coconustot_isProofIrrelevant. } set (e1 := maponpaths unitl1 e0). apply (! (unitl2 e) @ (! e1) @ (unitl2 (idpath _))). Defined. Theorem iscontrunit: iscontr (unit). Proof. split with tt. intros t. apply (isProofIrrelevantUnit t tt). Defined. (** [ paths ] in [ unit ] are contractible. *) Theorem iscontrpathsinunit (x x' : unit) : iscontr (x = x'). Proof. intros. split with (isProofIrrelevantUnit x x'). intros e'. induction x. induction x'. simpl. apply unitl3. Defined. (** A type [ T : UU ] is contractible if and only if [ T -> unit ] is a weak equivalence. *) Lemma ifcontrthenunitl0 (e1 e2 : tt = tt) : e1 = e2. Proof. intros. apply proofirrelevancecontr. apply (iscontrpathsinunit tt tt). Defined. Lemma isweqcontrtounit {T : UU} (is : iscontr T) : isweq (λ (_ : T), tt). Proof. intros. unfold isweq. intro y. induction y. induction is as [c h]. set (hc := make_hfiber _ c (idpath tt)). split with hc. intros ha. induction ha as [x e]. unfold hc. unfold make_hfiber. unfold isProofIrrelevantUnit. simpl. apply (λ q, two_arg_paths_f (h x) q). apply ifcontrthenunitl0. Defined. Definition weqcontrtounit {T : UU} (is : iscontr T) : T ≃ unit := make_weq _ (isweqcontrtounit is). Theorem iscontrifweqtounit {X : UU} (w : X ≃ unit) : iscontr X. Proof. intros. apply (iscontrweqb w). apply iscontrunit. Defined. (** *** Homotopy equivalence is a weak equivalence *) Definition hfibersgftog {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (xe : hfiber (g ∘ f) z) : hfiber g z := make_hfiber g (f (pr1 xe)) (pr2 xe). Lemma constr2 {X Y : UU} (f : X -> Y) (g : Y -> X) (efg: ∏ y : Y, f (g y) = y) (x0 : X) (xe : hfiber g x0) : ∑ xe' : hfiber (g ∘ f) x0, xe = hfibersgftog f g x0 xe'. Proof. intros. induction xe as [y0 e]. set (eint := pathssec1 _ _ efg _ _ e). set (ee := ! (maponpaths g eint) @ e). split with (make_hfiber (g ∘ f) x0 ee). unfold hfibersgftog. unfold make_hfiber. simpl. apply (two_arg_paths_f eint). induction eint. apply idpath. Defined. Lemma iscontrhfiberl1 {X Y : UU} (f : X -> Y) (g : Y -> X) (efg: ∏ y : Y, f (g y) = y) (x0 : X) (is : iscontr (hfiber (g ∘ f) x0)) : iscontr (hfiber g x0). Proof. intros. set (f1 := hfibersgftog f g x0). set (g1 := λ (xe : hfiber g x0), pr1 (constr2 f g efg x0 xe)). set (efg1 := λ (xe : hfiber g x0), ! (pr2 (constr2 f g efg x0 xe))). apply (iscontrretract f1 g1 efg1). apply is. Defined. Definition homothfiber1 {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) (xe : hfiber f y) : hfiber g y. Proof. intros. set (x := pr1 xe). set (e := pr2 xe). apply (make_hfiber g x (!(h x) @ e)). Defined. Definition homothfiber2 {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) (xe : hfiber g y) : hfiber f y. Proof. intros. set (x := pr1 xe). set (e := pr2 xe). apply (make_hfiber f x (h x @ e)). Defined. Definition homothfiberretr {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) (xe : hfiber g y) : homothfiber1 f g h y (homothfiber2 f g h y xe) = xe. Proof. intros. induction xe as [x e]. simpl. fold (make_hfiber g x e). set (xe1 := make_hfiber g x (! h x @ h x @ e)). set (xe2 := make_hfiber g x e). apply (hfibertriangle2 g xe1 xe2 (idpath _)). simpl. (* A little lemma: *) assert (ee : ∏ a b c : Y, ∏ p : a = b, ∏ q : b = c, !p @ (p @ q) = q). { intros. induction p. induction q. apply idpath. } apply ee. Defined. Lemma iscontrhfiberl2 {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) (is : iscontr (hfiber f y)) : iscontr (hfiber g y). Proof. intros. set (a := homothfiber1 f g h y). set (b := homothfiber2 f g h y). set (eab := homothfiberretr f g h y). apply (iscontrretract a b eab is). Defined. Corollary isweqhomot {X Y : UU} (f1 f2 : X -> Y) (h : f1 ~ f2) : isweq f1 -> isweq f2. Proof. intros x0. unfold isweq. intro y. apply (iscontrhfiberl2 f1 f2 h). apply x0. Defined. Corollary remakeweq {X Y : UU} {f:X≃Y} {g:X->Y} : f ~ g -> X≃Y. (* this lemma may be used to replace an equivalence by one whose forward map has a simpler definition, keeping the same inverse map, judgmentally *) Proof. intros e. exact (g ,, isweqhomot f g e (weqproperty f)). Defined. Lemma remakeweq_eq {X Y : UU} (f1:X≃Y) (f2:X->Y) (e:f1~f2) : pr1weq (remakeweq e) = f2. (* check the claim in the comment above *) Proof. intros. apply idpath. Defined. Lemma remakeweq_eq' {X Y : UU} (f1:X≃Y) (f2:X->Y) (e:f1~f2) : invmap (remakeweq e) = invmap f1. (* check the claim in the comment above *) Proof. intros. apply idpath. Defined. Lemma iscontr_move_point {X} : X -> iscontr X -> iscontr X. Proof. intros x i. exists x. intro y. apply proofirrelevancecontr. exact i. Defined. Lemma iscontr_move_point_eq {X} (x:X) (i:iscontr X) : iscontrpr1 (iscontr_move_point x i) = x. Proof. intros. apply idpath. Defined. Corollary remakeweqinv {X Y : UU} {f:X≃Y} {h:Y->X} : invmap f ~ h -> X≃Y. (* this lemma may be used to replace an equivalence by one whose inverse map is simpler, leaving the forward map the same, judgmentally *) Proof. intros e. exists f. intro y. assert (p : hfiber f y). { exists (h y). apply pathsweq1', pathsinv0. apply e. } exact (iscontr_move_point p (weqproperty f y)). Defined. Lemma remakeweqinv_eq {X Y : UU} (f:X≃Y) (h:Y->X) (e:invmap f ~ h) : pr1weq (remakeweqinv e) = pr1weq f. (* check the claim in the comment above *) Proof. intros. apply idpath. Defined. Lemma remakeweqinv_eq' {X Y : UU} (f:X≃Y) (h:Y->X) (e:invmap f ~ h) : invmap (remakeweqinv e) = h. (* check the claim in the comment above *) Proof. intros. apply idpath. Defined. Corollary remakeweqboth {X Y : UU} {f:X≃Y} {g:X->Y} {h:Y->X} : f ~ g -> invmap f ~ h -> X≃Y. (* this lemma may be used to replace an equivalence by one whose two maps are simpler *) Proof. intros r s. use (remakeweqinv (f := remakeweq r) s). Defined. Lemma remakeweqboth_eq {X Y : UU} (f:X≃Y) (g:X->Y) (h:Y->X) (r:f~g) (s:invmap f ~ h) : pr1weq (remakeweqboth r s) = g. Proof. intros. apply idpath. Defined. Lemma remakeweqboth_eq' {X Y : UU} (f:X≃Y) (g:X->Y) (h:Y->X) (r:f~g) (s:invmap f ~ h) : invmap (remakeweqboth r s) = h. Proof. intros. apply idpath. Defined. Corollary isweqhomot_iff {X Y : UU} (f1 f2 : X -> Y) (h : f1 ~ f2) : isweq f1 <-> isweq f2. Proof. intros. split. - apply isweqhomot; assumption. - apply isweqhomot, invhomot; assumption. Defined. Lemma isweq_to_isweq_unit {X:UU} (f g:X->unit) : isweq f -> isweq g. Proof. intros i. assert (h : f ~ g). { intros t. apply isProofIrrelevantUnit. } exact (isweqhomot f g h i). Defined. Theorem isweq_iso {X Y : UU} (f : X -> Y) (g : Y -> X) (egf: ∏ x : X, g (f x) = x) (efg: ∏ y : Y, f (g y) = y) : isweq f. Proof. intros. unfold isweq. intro y. assert (X0 : iscontr (hfiber (f ∘ g) y)). assert (efg' : ∏ y : Y, y = f (g y)). { intro y0. apply pathsinv0. apply (efg y0). } apply (iscontrhfiberl2 (idfun _) (f ∘ g) efg' y (idisweq Y y)). apply (iscontrhfiberl1 g f egf y). apply X0. Defined. (** This is kept to preserve compatibility with publications that use the name "gradth" for the "grad theorem". *) #[deprecated(note="Use isweq_iso instead.")] Notation gradth := isweq_iso (only parsing). Definition weq_iso {X Y : UU} (f : X -> Y) (g : Y -> X) (egf: ∏ x : X, g (f x) = x) (efg: ∏ y : Y, f (g y) = y) : X ≃ Y := make_weq _ (isweq_iso _ _ egf efg). Definition UniqueConstruction {X Y:UU} (f:X->Y) := (∏ y, ∑ x, f x = y) × (∏ x x', f x = f x' -> x = x'). Corollary UniqueConstruction_to_weq {X Y:UU} (f:X->Y) : UniqueConstruction f -> isweq f. Proof. intros bij. assert (sur := pr1 bij). assert (inj := pr2 bij). use (isweq_iso f). - intros y. exact (pr1 (sur y)). - intros. simpl. simpl in inj. apply inj. exact (pr2 (sur (f x))). - intros. simpl. exact (pr2 (sur y)). Defined. (** *** Some weak equivalences *) (* ### *) Corollary isweqinvmap {X Y : UU} (w : X ≃ Y) : isweq (invmap w). Proof. intros. assert (efg : ∏ (y : Y), w (invmap w y) = y). apply homotweqinvweq. assert (egf : ∏ (x : X), invmap w (w x) = x). apply homotinvweqweq. apply (isweq_iso _ _ efg egf). Defined. Definition invweq {X Y : UU} (w : X ≃ Y) : Y ≃ X := make_weq (invmap w) (isweqinvmap w). Lemma invinv {X Y : UU} (w : X ≃ Y) (x : X) : invmap (invweq w) x = w x. Proof. intros. apply idpath. Defined. Lemma pr1_invweq {X Y : UU} (w : X ≃ Y) : pr1weq (invweq w) = invmap w. (* useful for rewriting *) Proof. intros. apply idpath. Defined. Corollary iscontrweqf {X Y : UU} (w : X ≃ Y) (is : iscontr X) : iscontr Y. Proof. intros. apply (iscontrweqb (invweq w) is). Defined. (** Equality between pairs is equivalent to pairs of equalities between components. Theorem adapted from HoTT library http://github.com/HoTT/HoTT. *) Definition PathPair {A : UU} {B : A -> UU} (x y : ∑ x, B x) := ∑ p : pr1 x = pr1 y, transportf _ p (pr2 x) = pr2 y. Notation "a ╝ b" := (PathPair a b) : type_scope. (* the two horizontal lines represent an equality in the base and the two vertical lines represent an equality in the fiber *) (* in agda input mode use \--= and select the 6-th one in the first set, or use \chimney *) Theorem total2_paths_equiv {A : UU} (B : A -> UU) (x y : ∑ x, B x) : x = y ≃ x ╝ y. Proof. intros. exists (λ r : x = y, tpair (λ p : pr1 x = pr1 y, transportf _ p (pr2 x) = pr2 y) (base_paths _ _ r) (fiber_paths r)). apply (isweq_iso _ (λ pq, total2_paths_f (pr1 pq) (pr2 pq))). - intro p. apply total2_fiber_paths. - intros [p q]. simpl. apply (two_arg_paths_f (base_total2_paths q)). apply transportf_fiber_total2_paths. Defined. (** The standard weak equivalence from [ unit ] to a contractible type *) Definition wequnittocontr {X : UU} (is : iscontr X) : unit ≃ X. Proof. intros. set (f := λ (_ : unit), pr1 is). set (g := λ (_ : X), tt). split with f. assert (egf : ∏ t : unit, g (f t) = t). { intro. induction t. apply idpath. } assert (efg : ∏ x : X, f (g x) = x). { intro. apply (! (pr2 is x)). } apply (isweq_iso _ _ egf efg). Defined. (** A weak equivalence between types defines weak equivalences on the corresponding [ paths ] types. *) Corollary isweqmaponpaths {X Y : UU} (w : X ≃ Y) (x x' : X) : isweq (@maponpaths _ _ w x x'). Proof. intros. apply (isweq_iso (@maponpaths _ _ w x x') (@invmaponpathsweq _ _ w x x') (@pathsweq3 _ _ w x x') (@pathsweq4 _ _ w x x')). Defined. Definition weqonpaths {X Y : UU} (w : X ≃ Y) (x x' : X) : x = x' ≃ w x = w x' := make_weq _ (isweqmaponpaths w x x'). (** The inverse path and the composition with a path functions are weak equivalences *) Lemma isweqpathsinv0 {X : Type} (x y : X) : isweq (@pathsinv0 X x y). Proof. intros. intros p. use tpair. - exists (!p). apply pathsinv0inv0. - cbn. intros [q k]. induction q,k. reflexivity. Defined. Definition weqpathsinv0 {X : UU} (x x' : X) : x = x' ≃ x' = x := make_weq _ (isweqpathsinv0 x x'). Corollary isweqpathscomp0r {X : UU} (x : X) {x' x'' : X} (e' : x' = x'') : isweq (λ e : x = x', e @ e'). Proof. intros. set (f := λ e : x = x', e @ e'). set (g := λ e'' : x = x'', e'' @ (! e')). assert (egf : ∏ e : _, g (f e) = e). { intro e. induction e. induction e'. apply idpath. } assert (efg : ∏ e : _, f (g e) = e). { intro e. induction e. induction e'. apply idpath. } apply (isweq_iso f g egf efg). Defined. (** Weak equivalences to and from coconuses and total path spaces *) Corollary isweqtococonusf {X Y : UU} (f : X -> Y) : isweq (tococonusf f). Proof. intros. apply (isweq_iso _ _ (homotfromtococonusf f) (homottofromcoconusf f)). Defined. Definition weqtococonusf {X Y : UU} (f : X -> Y) : X ≃ coconusf f := make_weq _ (isweqtococonusf f). Corollary isweqfromcoconusf {X Y : UU} (f : X -> Y) : isweq (fromcoconusf f). Proof. intros. apply (isweq_iso _ _ (homottofromcoconusf f) (homotfromtococonusf f)). Defined. Definition weqfromcoconusf {X Y : UU} (f : X -> Y) : coconusf f ≃ X := make_weq _ (isweqfromcoconusf f). Corollary isweqdeltap (T : UU) : isweq (deltap T). Proof. intros. set (ff := deltap T). set (gg := λ (z : pathsspace T), pr1 z). assert (egf : ∏ t : T, gg (ff t) = t). { intro. apply idpath. } assert (efg : ∏ (tte : _), ff (gg tte) = tte). { intro tte. induction tte as [t c]. induction c as [x e]. induction e. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. Corollary isweqpr1pr1 (T : UU) : isweq (λ (a : pathsspace' T), pr1 (pr1 a)). Proof. intros. set (f := λ (a : pathsspace' T), pr1 (pr1 a)). set (g := λ (t : T), tpair _ (make_dirprod t t) (idpath t) : pathsspace' T). assert (efg : ∏ t : T, f (g t) = t). { intros t. unfold f. unfold g. simpl. apply idpath. } assert (egf : ∏ a : _, g (f a) = a). { intros a. induction a as [xy e]. induction xy as [x y]. simpl in e. induction e. unfold f. unfold g. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. (** The weak equivalence between hfibers of homotopic functions *) Theorem weqhfibershomot {X Y : UU} (f g : X -> Y) (h : f ~ g) (y : Y) : hfiber f y ≃ hfiber g y. Proof. intros. set (ff := hfibershomotftog f g h y). set (gg := hfibershomotgtof f g h y). split with ff. assert (effgg : ∏ xe : _, ff (gg xe) = xe). { intro xe. induction xe as [x e]. simpl. assert (eee : ! h x @ h x @ e = maponpaths g (idpath x) @ e). { simpl. induction e. induction (h x). apply idpath. } set (xe1 := make_hfiber g x (! h x @ h x @ e)). set (xe2 := make_hfiber g x e). apply (hfibertriangle2 g xe1 xe2 (idpath x) eee). } assert (eggff : ∏ xe : _, gg (ff xe) = xe). { intro xe. induction xe as [x e]. simpl. assert (eee : h x @ !h x @ e = maponpaths f (idpath x) @ e). { simpl. induction e. induction (h x). apply idpath. } set (xe1 := make_hfiber f x (h x @ ! h x @ e)). set (xe2 := make_hfiber f x e). apply (hfibertriangle2 f xe1 xe2 (idpath x) eee). } apply (isweq_iso _ _ eggff effgg). Defined. (** *** The 2-out-of-3 property of weak equivalences Theorems showing that if any two of three functions f, g, gf are weak equivalences then so is the third - the 2-out-of-3 property. *) Theorem twooutof3a {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isgf: isweq (g ∘ f)) (isg: isweq g) : isweq f. Proof. intros. set (gw := make_weq g isg). set (gfw := make_weq (g ∘ f) isgf). set (invg := invmap gw). set (invgf := invmap gfw). set (invf := invgf ∘ g). assert (efinvf : ∏ y : Y, f (invf y) = y). { intro y. assert (int1 : g (f (invf y)) = g y). { unfold invf. apply (homotweqinvweq gfw (g y)). } apply (invmaponpathsweq gw _ _ int1). } assert (einvff: ∏ x : X, invf (f x) = x). { intro. unfold invf. apply (homotinvweqweq gfw x). } apply (isweq_iso f invf einvff efinvf). Defined. Theorem twooutof3b {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isf : isweq f) (isgf : isweq (g ∘ f)) : isweq g. Proof. intros. set (wf := make_weq f isf). set (wgf := make_weq (g ∘ f) isgf). set (invf := invmap wf). set (invgf := invmap wgf). set (invg := f ∘ invgf). assert (eginvg : ∏ z : Z, g (invg z) = z). { intro. unfold invg. apply (homotweqinvweq wgf z). } assert (einvgg : ∏ y : Y, invg (g y) = y). { intro. unfold invg. assert (isinvf: isweq invf). { apply isweqinvmap. } assert (isinvgf: isweq invgf). { apply isweqinvmap. } assert (int1 : g y = (g ∘ f) (invf y)). apply (maponpaths g (! homotweqinvweq wf y)). assert (int2 : (g ∘ f) (invgf (g y)) = (g ∘ f) (invf y)). { assert (int3: (g ∘ f) (invgf (g y)) = g y). { apply (homotweqinvweq wgf). } induction int1. apply int3. } assert (int4: (invgf (g y)) = (invf y)). { apply (invmaponpathsweq wgf). apply int2. } assert (int5: (invf (f (invgf (g y)))) = (invgf (g y))). { apply (homotinvweqweq wf). } assert (int6: (invf (f (invgf (g (y))))) = (invf y)). { induction int4. apply int5. } apply (invmaponpathsweq (make_weq invf isinvf)). simpl. apply int6. } apply (isweq_iso g invg einvgg eginvg). Defined. Lemma isweql3 {X Y : UU} (f : X -> Y) (g : Y -> X) (egf : ∏ x : X, g (f x) = x) : isweq f -> isweq g. Proof. intros w. assert (int1 : isweq (g ∘ f)). { apply (isweqhomot (idfun X) (g ∘ f) (λ (x : X), ! (egf x))). apply idisweq. } apply (twooutof3b f g w int1). Defined. Theorem twooutof3c {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isf : isweq f) (isg : isweq g) : isweq (g ∘ f). Proof. intros. set (wf := make_weq f isf). set (wg := make_weq g isg). set (invf := invmap wf). set (invg := invmap wg). set (gf := g ∘ f). set (invgf := invf ∘ invg). assert (egfinvgf : ∏ x : X, invgf (gf x) = x). { intros x. assert (int1 : invf (invg (g (f x))) = invf (f x)). { apply (maponpaths invf (homotinvweqweq wg (f x))). } assert (int2 : invf (f x) = x). { apply (homotinvweqweq wf x). } induction int1. apply int2. } assert (einvgfgf : ∏ z : Z, gf (invgf z) = z). { intros z. assert (int1 : g (f (invgf z)) = g (invg z)). { unfold invgf. apply (maponpaths g (homotweqinvweq wf (invg z))). } assert (int2 : g (invg z) = z). { apply (homotweqinvweq wg z). } induction int1. apply int2. } apply (isweq_iso gf invgf egfinvgf einvgfgf). Defined. Corollary twooutof3c_iff_2 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) : isweq f -> (isweq g <-> isweq (g ∘ f)). Proof. intros i. split. - intro j. exact (twooutof3c f g i j). - intro j. exact (twooutof3b f g i j). Defined. Corollary twooutof3c_iff_1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) : isweq g -> (isweq f <-> isweq (g ∘ f)). Proof. intros i. split. - intro j. exact (twooutof3c f g j i). - intro j. exact (twooutof3a f g j i). Defined. Corollary twooutof3c_iff_1_homot {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (h : X -> Z) : g ∘ f ~ h -> isweq g -> (isweq f <-> isweq h). Proof. intros r i. apply (logeq_trans (Y := isweq (g ∘ f))). - apply twooutof3c_iff_1; assumption. - apply isweqhomot_iff; assumption. Defined. Corollary twooutof3c_iff_2_homot {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (h : X -> Z) : g ∘ f ~ h -> isweq f -> (isweq g <-> isweq h). Proof. intros r i. apply (logeq_trans (Y := isweq (g ∘ f))). - apply twooutof3c_iff_2; assumption. - apply isweqhomot_iff; assumption. Defined. (** *** Any function between contractible types is a weak equivalence *) Corollary isweqcontrcontr {X Y : UU} (f : X -> Y) (isx : iscontr X) (isy: iscontr Y): isweq f. Proof. intros. set (py := λ (y : Y), tt). apply (twooutof3a f py (isweqcontrtounit isx) (isweqcontrtounit isy)). Defined. Definition weqcontrcontr {X Y : UU} (isx : iscontr X) (isy : iscontr Y) : X ≃ Y := make_weq (λ _, pr1 isy) (isweqcontrcontr _ isx isy). (** *** Composition of weak equivalences *) Definition weqcomp {X Y Z : UU} (w1 : X ≃ Y) (w2 : Y ≃ Z) : X ≃ Z := make_weq (λ (x : X), w2 (w1 x)) (twooutof3c w1 w2 (pr2 w1) (pr2 w2)). Declare Scope weq_scope. Notation "g ∘ f" := (weqcomp f g) : weq_scope. Delimit Scope weq_scope with weq. Ltac intermediate_weq Y' := apply (weqcomp (Y := Y')). Definition weqcomp_to_funcomp_app {X Y Z : UU} {x : X} {f : X ≃ Y} {g : Y ≃ Z} : (weqcomp f g) x = pr1weq g (pr1weq f x). Proof. intros. apply idpath. Defined. Definition weqcomp_to_funcomp {X Y Z : UU} {f : X ≃ Y} {g : Y ≃ Z} : pr1weq (weqcomp f g) = pr1weq g ∘ pr1weq f. Proof. intros. apply idpath. Defined. Definition invmap_weqcomp_expand {X Y Z : UU} {f : X ≃ Y} {g : Y ≃ Z} : invmap (weqcomp f g) = invmap f ∘ invmap g. Proof. intros. apply idpath. Defined. (** *** The 2-out-of-6 (two-out-of-six) property of weak equivalences *) Theorem twooutofsixu {X Y Z K : UU} {u : X -> Y} {v : Y -> Z} {w : Z -> K} (isuv : isweq (funcomp u v)) (isvw : isweq (funcomp v w)) : isweq u. Proof. intros. set (invuv := invmap (make_weq _ isuv)). set (pu := funcomp v invuv). set (hupu := homotinvweqweq (make_weq _ isuv) : homot (funcomp u pu) (idfun X)). set (invvw := invmap (make_weq _ isvw)). set (pv := funcomp w invvw). set (hvpv := homotinvweqweq (make_weq _ isvw) : homot (funcomp v pv) (idfun Y)). set (h0 := funhomot v (homotweqinvweq (make_weq _ isuv))). set (h1 := funhomot (funcomp pu u) (invhomot hvpv)). set (h2 := homotfun h0 pv). set (hpuu := homotcomp (homotcomp h1 h2) hvpv). exact (isweq_iso u pu hupu hpuu). Defined. Theorem twooutofsixv {X Y Z K : UU} {u : X -> Y} {v : Y -> Z} {w : Z -> K} (isuv : isweq (funcomp u v))(isvw : isweq (funcomp v w)) : isweq v. Proof. intros. exact (twooutof3b _ _ (twooutofsixu isuv isvw) isuv). Defined. Theorem twooutofsixw {X Y Z K : UU} {u : X -> Y} {v : Y -> Z} {w : Z -> K} (isuv : isweq (funcomp u v))(isvw : isweq (funcomp v w)) : isweq w. Proof. intros. exact (twooutof3b _ _ (twooutofsixv isuv isvw) isvw). Defined. (** *** Pairwise direct products of weak equivalences *) Theorem isweqdirprodf {X Y X' Y' : UU} (w : X ≃ Y) (w' : X' ≃ Y') : isweq (dirprodf w w'). Proof. intros. set (f := dirprodf w w'). set (g := dirprodf (invweq w) (invweq w')). assert (egf : ∏ a : _, (g (f a)) = a). intro a. induction a as [ x x' ]. simpl. apply pathsdirprod. apply (homotinvweqweq w x). apply (homotinvweqweq w' x'). assert (efg : ∏ a : _, (f (g a)) = a). intro a. induction a as [ x x' ]. simpl. apply pathsdirprod. apply (homotweqinvweq w x). apply (homotweqinvweq w' x'). apply (isweq_iso _ _ egf efg). Defined. Definition weqdirprodf {X Y X' Y' : UU} (w : X ≃ Y) (w' : X' ≃ Y') : X × X' ≃ Y × Y' := make_weq _ (isweqdirprodf w w'). (** *** Weak equivalence of a type and its direct product with the unit *) Definition weqtodirprodwithunit (X : UU): X ≃ X × unit. Proof. intros. set (f := λ x : X, make_dirprod x tt). split with f. set (g := λ xu : X × unit, pr1 xu). assert (egf : ∏ x : X, (g (f x)) = x). intro. apply idpath. assert (efg : ∏ xu : _, (f (g xu)) = xu). intro. induction xu as [ t x ]. induction x. apply idpath. apply (isweq_iso f g egf efg). Defined. (** *** Associativity of [ total2 ] as a weak equivalence *) Lemma total2asstor {X : UU} (P : X -> UU) (Q : total2 P -> UU) : total2 Q -> ∑ x:X, ∑ p : P x, Q (tpair P x p). Proof. intros xpq. exists (pr1 (pr1 xpq)). exists (pr2 (pr1 xpq)). exact (pr2 xpq). Defined. Lemma total2asstol {X : UU} (P : X -> UU) (Q : total2 P -> UU) : (∑ x : X, ∑ p : P x, Q (tpair P x p)) -> total2 Q. Proof. intros xpq. use tpair. - use tpair. + apply (pr1 xpq). + apply (pr1 (pr2 xpq)). - exact (pr2 (pr2 xpq)). Defined. Theorem weqtotal2asstor {X : UU} (P : X -> UU) (Q : total2 P -> UU) : total2 Q ≃ ∑ x : X, ∑ p : P x, Q (tpair P x p). Proof. intros. set (f := total2asstor P Q). set (g:= total2asstol P Q). split with f. assert (egf : ∏ xpq : _ , (g (f xpq)) = xpq). intro. apply idpath. assert (efg : ∏ xpq : _ , (f (g xpq)) = xpq). intro. apply idpath. apply (isweq_iso _ _ egf efg). Defined. Definition weqtotal2asstol {X : UU} (P : X -> UU) (Q : total2 P -> UU) : (∑ x : X, ∑ p : P x, Q (tpair P x p)) ≃ total2 Q := invweq (weqtotal2asstor P Q). (** *** Associativity and commutativity of direct products as weak equivalences *) Definition weqdirprodasstor (X Y Z : UU) : (X × Y) × Z ≃ X × (Y × Z). Proof. intros. apply weqtotal2asstor. Defined. Definition weqdirprodasstol (X Y Z : UU) : X × (Y × Z) ≃ (X × Y) × Z := invweq (weqdirprodasstor X Y Z). Definition weqdirprodcomm (X Y : UU) : X × Y ≃ Y × X. Proof. intros. set (f := λ xy : X × Y, make_dirprod (pr2 xy) (pr1 xy)). set (g := λ yx : Y × X, make_dirprod (pr2 yx) (pr1 yx)). assert (egf : ∏ xy : _, (g (f xy)) = xy). intro. induction xy. apply idpath. assert (efg : ∏ yx : _, (f (g yx)) = yx). intro. induction yx. apply idpath. split with f. apply (isweq_iso _ _ egf efg). Defined. Definition weqtotal2dirprodcomm {X Y : UU} (P : X × Y -> UU) : (∑ xy : X × Y, P xy) ≃ (∑ xy : Y × X, P (weqdirprodcomm _ _ xy)). Proof. intros. use weq_iso. - intros xyp. exact ((pr2 (pr1 xyp),, pr1 (pr1 xyp)),,pr2 xyp). - intros yxp. exact (((pr2 (pr1 yxp)),, (pr1 (pr1 yxp))),, pr2 yxp). - intros xyp. apply idpath. - intros yxp. apply idpath. Defined. Definition weqtotal2dirprodassoc {X Y : UU} (P : X × Y -> UU) : (∑ xy : X × Y, P xy) ≃ (∑ (x : X) (y : Y), P (x,,y)). intros. use weq_iso. - intros xyp. exact (pr1 (pr1 xyp),,pr2 (pr1 xyp),, pr2 xyp). - intros xyp. exact (((pr1 xyp),, pr1 (pr2 xyp)),, pr2 (pr2 xyp)). - intros xyp. apply idpath. - intros xyp. apply idpath. Defined. Definition weqtotal2dirprodassoc' {X Y : UU} (P : X × Y -> UU) : (∑ xy : X × Y, P xy) ≃ (∑ (y : Y) (x : X), P (x,,y)). Proof. intros. use weq_iso. - intros xyp. exact (pr2 (pr1 xyp),,pr1 (pr1 xyp),,pr2 xyp). - intros yxp. exact ((pr1 (pr2 yxp),,pr1 yxp),,pr2 (pr2 yxp)). - intros xyp. apply idpath. - intros yxp. apply idpath. Defined. Definition weqtotal2comm12 {X} (P Q : X -> UU) : (∑ (w : ∑ x, P x), Q (pr1 w)) ≃ (∑ (w : ∑ x, Q x), P (pr1 w)). Proof. intros. use weq_iso. - intro xpq. exact ((pr1 (pr1 xpq),,pr2 xpq),, pr2 (pr1 xpq)). - intro xqp. exact ((pr1 (pr1 xqp),, pr2 xqp),, pr2 (pr1 xqp)). - intro. apply idpath. - intro. apply idpath. Defined. (** ** Binary coproducts and their basic properties *) (** Binary coproducts have not been introduced or used earlier except for the lines in the Preamble.v that define [ coprod ] and [ ⨿ ] as a notation for the inductive type family [ sum ] that is defined in Coq.Init. *) (** *** Distributivity of coproducts and direct products as a weak equivalence *) Definition rdistrtocoprod (X Y Z : UU) : X × (Y ⨿ Z) -> (X × Y) ⨿ (X × Z). Proof. intros X0. induction X0 as [ t x ]. induction x as [ y | z ]. apply (ii1 (make_dirprod t y)). apply (ii2 (make_dirprod t z)). Defined. Definition rdistrtoprod (X Y Z : UU) : (X × Y) ⨿ (X × Z) -> X × (Y ⨿ Z). Proof. intros X0. induction X0 as [ d | d ]. induction d as [ t x ]. apply (make_dirprod t (ii1 x)). induction d as [ t x ]. apply (make_dirprod t (ii2 x)). Defined. Theorem isweqrdistrtoprod (X Y Z : UU) : isweq (rdistrtoprod X Y Z). Proof. intros. set (f := rdistrtoprod X Y Z). set (g := rdistrtocoprod X Y Z). assert (egf: ∏ a, (g (f a)) = a). intro. induction a as [ d | d ]. induction d. apply idpath. induction d. apply idpath. assert (efg: ∏ a, (f (g a)) = a). intro. induction a as [ t x ]. induction x. apply idpath. apply idpath. apply (isweq_iso f g egf efg). Defined. Definition weqrdistrtoprod (X Y Z : UU) := make_weq _ (isweqrdistrtoprod X Y Z). Corollary isweqrdistrtocoprod (X Y Z : UU) : isweq (rdistrtocoprod X Y Z). Proof. intros. apply (isweqinvmap (weqrdistrtoprod X Y Z)). Defined. Definition weqrdistrtocoprod (X Y Z : UU) := make_weq _ (isweqrdistrtocoprod X Y Z). (** *** Total space of a family over a coproduct *) Definition fromtotal2overcoprod {X Y : UU} (P : X ⨿ Y -> UU) (xyp : total2 P) : coprod (∑ x : X, P (ii1 x)) (∑ y : Y, P (ii2 y)). Proof. intros. set (PX := λ x : X, P (ii1 x)). set (PY := λ y : Y, P (ii2 y)). induction xyp as [ xy p ]. induction xy as [ x | y ]. apply (ii1 (tpair PX x p)). apply (ii2 (tpair PY y p)). Defined. Definition tototal2overcoprod {X Y : UU} (P : X ⨿ Y -> UU) (xpyp : coprod (∑ x : X, P (ii1 x)) (∑ y : Y, P (ii2 y))) : total2 P. Proof. intros. induction xpyp as [ xp | yp ]. induction xp as [ x p ]. apply (tpair P (ii1 x) p). induction yp as [ y p ]. apply (tpair P (ii2 y) p). Defined. Theorem weqtotal2overcoprod {X Y : UU} (P : X ⨿ Y -> UU) : (∑ xy, P xy) ≃ (∑ x : X, P (ii1 x)) ⨿ (∑ y : Y, P (ii2 y)). Proof. intros. set (f := fromtotal2overcoprod P). set (g := tototal2overcoprod P). split with f. assert (egf : ∏ a : _ , (g (f a)) = a). { intro a. induction a as [ xy p ]. induction xy as [ x | y ]. simpl. apply idpath. simpl. apply idpath. } assert (efg : ∏ a : _ , (f (g a)) = a). { intro a. induction a as [ xp | yp ]. induction xp as [ x p ]. simpl. apply idpath. induction yp as [ y p ]. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. (** *** Pairwise sum of functions, coproduct associativity and commutativity *) Definition sumofmaps {X Y Z : UU} (fx : X -> Z)(fy : Y -> Z) : (X ⨿ Y) -> Z := λ xy : _, match xy with ii1 x => fx x | ii2 y => fy y end. Definition coprodasstor (X Y Z : UU) : (X ⨿ Y) ⨿ Z -> X ⨿ (Y ⨿ Z). Proof. intros X0. induction X0 as [ c | z ]. induction c as [ x | y ]. apply (ii1 x). apply (ii2 (ii1 y)). apply (ii2 (ii2 z)). Defined. Definition coprodasstol (X Y Z : UU): X ⨿ (Y ⨿ Z) -> (X ⨿ Y) ⨿ Z. Proof. intros X0. induction X0 as [ x | c ]. apply (ii1 (ii1 x)). induction c as [ y | z ]. apply (ii1 (ii2 y)). apply (ii2 z). Defined. Definition sumofmaps_assoc_left {X Y Z T : UU} (f : X -> T) (g : Y -> T) (h : Z -> T) : sumofmaps (sumofmaps f g) h ∘ coprodasstol _ _ _ ~ sumofmaps f (sumofmaps g h). Proof. intros. intros [x|[y|z]]; apply idpath. Defined. Definition sumofmaps_assoc_right {X Y Z T : UU} (f : X -> T) (g : Y -> T) (h : Z -> T) : sumofmaps f (sumofmaps g h) ∘ coprodasstor _ _ _ ~ sumofmaps (sumofmaps f g) h. Proof. intros. intros [[x|y]|z]; apply idpath. Defined. Theorem isweqcoprodasstor (X Y Z : UU): isweq (coprodasstor X Y Z). Proof. intros. set (f := coprodasstor X Y Z). set (g := coprodasstol X Y Z). assert (egf : ∏ xyz, (g (f xyz)) = xyz). intro xyz. induction xyz as [ c | z ]. induction c. apply idpath. apply idpath. apply idpath. assert (efg : ∏ xyz, (f (g xyz)) = xyz). intro xyz. induction xyz as [ x | c ]. apply idpath. induction c. apply idpath. apply idpath. apply (isweq_iso f g egf efg). Defined. Definition weqcoprodasstor (X Y Z : UU) := make_weq _ (isweqcoprodasstor X Y Z). Corollary isweqcoprodasstol (X Y Z : UU) : isweq (coprodasstol X Y Z). Proof. intros. apply (isweqinvmap (weqcoprodasstor X Y Z)). Defined. Definition weqcoprodasstol (X Y Z : UU) := make_weq _ (isweqcoprodasstol X Y Z). Definition coprodcomm (X Y : UU) : X ⨿ Y -> Y ⨿ X := λ xy : _, match xy with ii1 x => ii2 x | ii2 y => ii1 y end. Theorem isweqcoprodcomm (X Y : UU) : isweq (coprodcomm X Y). Proof. intros. set (f := coprodcomm X Y). set (g := coprodcomm Y X). assert (egf : ∏ xy : _, (g (f xy)) = xy). intro. induction xy. apply idpath. apply idpath. assert (efg : ∏ yx : _, (f (g yx)) = yx). intro. induction yx. apply idpath. apply idpath. apply (isweq_iso f g egf efg). Defined. Definition weqcoprodcomm (X Y : UU) := make_weq _ (isweqcoprodcomm X Y). (** *** Coproduct with a "negative" type *) Theorem isweqii1withneg (X : UU) {Y : UU} (nf : Y -> empty) : isweq (@ii1 X Y). Proof. intros. set (f := @ii1 X Y). set (g := λ xy : X ⨿ Y, match xy with | ii1 x => x | ii2 y => fromempty (nf y) end). assert (egf : ∏ x : X, (g (f x)) = x). intro. apply idpath. assert (efg : ∏ xy : X ⨿ Y, (f (g xy)) = xy). intro. induction xy as [ x | y ]. apply idpath. apply (fromempty (nf y)). apply (isweq_iso f g egf efg). Defined. Definition weqii1withneg (X : UU) {Y : UU} (nf : ¬ Y) := make_weq _ (isweqii1withneg X nf). Theorem isweqii2withneg {X : UU} (Y : UU) (nf : X -> empty) : isweq (@ii2 X Y). Proof. intros. set (f:= @ii2 X Y). set (g:= λ xy : X ⨿ Y, match xy with | ii1 x => fromempty (nf x) | ii2 y => y end). assert (egf : ∏ y : Y, (g (f y)) = y). intro. apply idpath. assert (efg : ∏ xy : X ⨿ Y, (f (g xy)) = xy). intro. induction xy as [ x | y ]. apply (fromempty (nf x)). apply idpath. apply (isweq_iso f g egf efg). Defined. Definition weqii2withneg {X : UU} (Y : UU) (nf : ¬ X) := make_weq _ (isweqii2withneg Y nf). (** *** Coproduct of two functions *) Definition coprodf {X Y X' Y' : UU} (f : X -> X') (g : Y-> Y') : X ⨿ Y -> X' ⨿ Y' := λ xy: X ⨿ Y, match xy with | ii1 x => ii1 (f x) | ii2 y => ii2 (g y) end. Definition coprodf1 {X Y X' : UU} : (X -> X') -> X ⨿ Y -> X' ⨿ Y. Proof. intros f. exact (coprodf f (idfun Y)). Defined. Definition coprodf2 {X Y Y' : UU} : (Y -> Y') -> X ⨿ Y -> X ⨿ Y'. Proof. intros g. exact (coprodf (idfun X) g). Defined. Definition homotcoprodfcomp {X X' Y Y' Z Z' : UU} (f : X -> Y) (f' : X' -> Y') (g : Y -> Z) (g' : Y' -> Z') : homot (funcomp (coprodf f f') (coprodf g g')) (coprodf (funcomp f g) (funcomp f' g')). Proof. intros. intro xx'. induction xx' as [ x | x' ]. apply idpath. apply idpath. Defined. Definition homotcoprodfhomot {X X' Y Y' : UU} (f g : X -> Y) (f' g' : X' -> Y') (h : homot f g) (h' : homot f' g') : homot (coprodf f f') (coprodf g g') := λ xx' : _, match xx' with | ii1 x => maponpaths (@ii1 _ _) (h x) | ii2 x' => maponpaths (@ii2 _ _) (h' x') end. Theorem isweqcoprodf {X Y X' Y' : UU} (w : X ≃ X') (w' : Y ≃ Y') : isweq (coprodf w w'). Proof. intros. set (finv := invmap w). set (ginv := invmap w'). set (ff := coprodf w w'). set (gg := coprodf finv ginv). assert (egf : ∏ xy : X ⨿ Y, (gg (ff xy)) = xy). intro. induction xy as [ x | y ]. simpl. apply (maponpaths (@ii1 X Y) (homotinvweqweq w x)). apply (maponpaths (@ii2 X Y) (homotinvweqweq w' y)). assert (efg : ∏ xy' : coprod X' Y', (ff (gg xy')) = xy'). intro. induction xy' as [ x | y ]. simpl. apply (maponpaths (@ii1 X' Y') (homotweqinvweq w x)). apply (maponpaths (@ii2 X' Y') (homotweqinvweq w' y)). apply (isweq_iso ff gg egf efg). Defined. Definition weqcoprodf {X Y X' Y' : UU} : X ≃ X' -> Y ≃ Y' -> X ⨿ Y ≃ X' ⨿ Y'. Proof. intros w1 w2. exact (make_weq _ (isweqcoprodf w1 w2)). Defined. Definition weqcoprodf1 {X Y X' : UU} : X ≃ X' -> X ⨿ Y ≃ X' ⨿ Y. Proof. intros w. exact (weqcoprodf w (idweq Y)). Defined. Definition weqcoprodf2 {X Y Y' : UU} : Y ≃ Y' -> X ⨿ Y ≃ X ⨿ Y'. Proof. intros w. exact (weqcoprodf (idweq X) w). Defined. (** *** The [ equality_cases ] construction and four applications to [ ii1 ] and [ ii2 ] *) (* Added by D. Grayson, Nov. 2015 *) Definition equality_cases {P Q : UU} (x x' : P ⨿ Q) : UU. Proof. (* "codes" *) intros. induction x as [p|q]. - induction x' as [p'|q']. + exact (p = p'). + exact empty. - induction x' as [p'|q']. + exact empty. + exact (q = q'). Defined. Definition equality_by_case {P Q : UU} {x x' : P ⨿ Q} : x = x'-> equality_cases x x'. Proof. intros e. induction x as [p|q]. - induction x' as [p'|q']. + simpl. exact (maponpaths (@coprod_rect P Q (λ _, P) (λ p, p) (λ _, p)) e). + simpl. exact (transportf (@coprod_rect P Q (λ _, UU) (λ _, unit) (λ _, empty)) e tt). - induction x' as [p'|q']. + simpl. exact (transportb (@coprod_rect P Q (λ _, UU) (λ _, unit) (λ _, empty)) e tt). + simpl. exact (maponpaths (@coprod_rect P Q (λ _,Q) (λ _, q) (λ q, q)) e). Defined. Definition inv_equality_by_case {P Q : UU} {x x' : P ⨿ Q} : equality_cases x x' -> x = x'. Proof. intros e. induction x as [p|q]. - induction x' as [p'|q']. + exact (maponpaths (@ii1 P Q) e). + induction e. - induction x' as [p'|q']. + induction e. + exact (maponpaths (@ii2 P Q) e). Defined. (* the same proof proves 4 lemmas: *) Lemma ii1_injectivity {P Q : UU} (p p' : P) : ii1 (B := Q) p = ii1 (B := Q) p' -> p = p'. Proof. exact equality_by_case. Defined. Lemma ii2_injectivity {P Q : UU} (q q' : Q) : ii2 (A := P) q = ii2 (A := P) q' -> q = q'. Proof. exact equality_by_case. Defined. Lemma negpathsii1ii2 {X Y : UU} (x : X) (y : Y) : ii1 x != ii2 y. Proof. exact equality_by_case. Defined. Lemma negpathsii2ii1 {X Y : UU} (x : X) (y : Y) : ii2 y != ii1 x. Proof. exact equality_by_case. Defined. (** *** Bool as coproduct *) Definition boolascoprod: unit ⨿ unit ≃ bool. Proof. set (f := λ xx : coprod unit unit, match xx with ii1 t => true | ii2 t => false end). split with f. set (g := λ t:bool, match t with true => ii1 tt | false => ii2 tt end). assert (egf : ∏ xx : _, g (f xx) = xx). intro xx. induction xx as [ u | u ]. induction u. apply idpath. induction u. apply idpath. assert (efg : ∏ t : _, f (g t) = t). induction t. apply idpath. apply idpath. apply (isweq_iso f g egf efg). Defined. (** *** Pairwise coproducts as dependent sums of families over [ bool ] *) Definition coprodtobool {X Y : UU} (xy : X ⨿ Y) : bool := match xy with | ii1 x => true | ii2 y => false end. Definition boolsumfun (X Y : UU) : bool -> UU := λ t : _, match t with | true => X | false => Y end. Definition coprodtoboolsum (X Y : UU) : X ⨿ Y -> total2 (boolsumfun X Y) := λ xy : _, match xy with | ii1 x => tpair (boolsumfun X Y) true x | ii2 y => tpair (boolsumfun X Y) false y end. Definition boolsumtocoprod (X Y : UU): (total2 (boolsumfun X Y)) -> X ⨿ Y := λ xy, match xy with | tpair _ true x => ii1 x | tpair _ false y => ii2 y end. Theorem isweqcoprodtoboolsum (X Y : UU) : isweq (coprodtoboolsum X Y). Proof. intros. set (f := coprodtoboolsum X Y). set (g := boolsumtocoprod X Y). assert (egf : ∏ xy : X ⨿ Y , (g (f xy)) = xy). induction xy. apply idpath. apply idpath. assert (efg : ∏ xy : total2 (boolsumfun X Y), (f (g xy)) = xy). intro. induction xy as [ t x ]. induction t. apply idpath. apply idpath. apply (isweq_iso f g egf efg). Defined. Definition weqcoprodtoboolsum (X Y : UU) := make_weq _ (isweqcoprodtoboolsum X Y). Corollary isweqboolsumtocoprod (X Y : UU): isweq (boolsumtocoprod X Y). Proof. intros. apply (isweqinvmap (weqcoprodtoboolsum X Y)). Defined. Definition weqboolsumtocoprod (X Y : UU) := make_weq _ (isweqboolsumtocoprod X Y). (** *** Splitting of [ X ] into a coproduct defined by a function [ X -> Y ⨿ Z ] *) Definition weqcoprodsplit {X Y Z : UU} (f : X -> coprod Y Z) : X ≃ (∑ y : Y, hfiber f (ii1 y)) ⨿ (∑ z : Z, hfiber f (ii2 z)). Proof. intros. set (w1 := weqtococonusf f). set (w2 := weqtotal2overcoprod (λ yz : coprod Y Z, hfiber f yz)). apply (weqcomp w1 w2). Defined. (** *** Some properties of [ bool ] *) Definition boolchoice (x : bool) : (x = true) ⨿ (x = false). Proof. induction x. apply (ii1 (idpath _)). apply (ii2 (idpath _)). Defined. Definition bool_to_type : bool -> UU. Proof. intros b. induction b as [|]. { exact unit. } { exact empty. } Defined. Theorem nopathstruetofalse : true = false -> empty. Proof. intro X. apply (transportf bool_to_type X tt). Defined. Corollary nopathsfalsetotrue : false = true -> empty. Proof. intro X. apply (transportb bool_to_type X tt). Defined. Definition truetonegfalse (x : bool) : x = true -> x != false. Proof. intros e. rewrite e. unfold neg. apply nopathstruetofalse. Defined. Definition falsetonegtrue (x : bool) : x = false -> x != true. Proof. intros e. rewrite e. unfold neg. apply nopathsfalsetotrue. Defined. Definition negtruetofalse (x : bool) : x != true -> x = false. Proof. intros ne. induction (boolchoice x) as [t | f]. induction (ne t). apply f. Defined. Definition negfalsetotrue (x : bool) : x != false -> x = true. Proof. intros ne. induction (boolchoice x) as [t | f]. apply t. induction (ne f). Defined. (** *** Fibrations with only one non-empty fiber Theorem saying that if a fibration has only one non-empty fiber then the total space is weakly equivalent to this fiber. *) (* The current proof added by P. L. Lumsdaine, 2016 *) Theorem onefiber {X : UU} (P : X -> UU) (x : X) (c : ∏ x' : X, (x = x') ⨿ ¬ P x') : isweq (λ p, tpair P x p). Proof. intros. set (f := λ p : P x, tpair _ x p). set (cx := c x). transparent assert (cnew : (∏ x' : X, (x = x') ⨿ ¬ P x')). { intro x'. refine (coprod_rect (λ _, _) _ _ (cx)). - intro x0. refine (coprod_rect (λ _, _) _ _ (c x')). + intro ee. apply ii1; exact (pathscomp0 (pathsinv0 x0) ee). + intro phi. apply ii2, phi. - intro phi. exact (c x'). } set (g := λ pp : total2 P, match (cnew (pr1 pp)) with | ii1 e => transportb P e (pr2 pp) | ii2 phi => fromempty (phi (pr2 pp)) end). assert (efg : ∏ pp : total2 P, (f (g pp)) = pp). intro. induction pp as [ t x0 ]. set (cnewt := cnew t). unfold g. unfold f. simpl. change (cnew t) with cnewt. induction cnewt as [ x1 | y ]. apply (pathsinv0 (pr1 (pr2 (constr1 P (pathsinv0 x1))) x0)). induction (y x0). set (cnewx := cnew x). assert (e1 : (cnew x) = cnewx). apply idpath. unfold cnew in cnewx. change (c x) with cx in cnewx. induction cx as [ x0 | e0 ]. assert (e : (cnewx) = (ii1 (idpath x))). apply (maponpaths (@ii1 (x = x) (P x -> empty)) (pathsinv0l x0)). assert (egf : ∏ p: P x, (g (f p)) = p). intro. simpl in g. unfold g. unfold f. simpl. set (ff := λ cc:(x = x) ⨿ (P x -> empty), match cc with | ii1 e0 => transportb P e0 p | ii2 phi => fromempty (phi p) end). assert (ee : (ff (cnewx)) = (ff (@ii1 (x = x) (P x -> empty) (idpath x)))). apply (maponpaths ff e). assert (eee : (ff (@ii1 (x = x) (P x -> empty) (idpath x))) = p). apply idpath. fold (ff (cnew x)). assert (e2 : (ff (cnew x)) = (ff cnewx)). apply (maponpaths ff e1). apply (pathscomp0 (pathscomp0 e2 ee) eee). apply (isweq_iso f g egf efg). unfold isweq. intro y0. induction (e0 (g y0)). Defined. (** ** Basics about fibration sequences. *) (** *** Fibrations sequences and their first "left shifts" The group of constructions related to fibration sequences forms one of the most important computational toolboxes of homotopy theory. Given a pair of functions [ (f : X -> Y) (g : Y -> Z) ] and a point [ z : Z ] , a structure of the complex on such a triple is a homotopy from the composition [ funcomp f g ] to the constant function [ X -> Z ] corresponding to [ z ] i.e. a term [ ez : ∏ x : X, (g (f x)) = z ]. Specifing such a structure is essentially equivalent to specifing a structure of the form [ ezmap : X -> hfiber g z ]. The mapping in one direction is given in the definition of [ ezmap ] below. The mapping in another is given by [ f := λ x : X, pr1 (ezmap x) ] and [ ez := λ x : X, pr2 (ezmap x) ]. A complex is called a fibration sequence if [ ezmap ] is a weak equivalence. Correspondingly, the structure of a fibration sequence on [ f g z ] is a pair [ (ez , is) ] where [ is : isweq (ezmap f g z ez) ]. For a fibration sequence [ f g z fs ] where [ fs : fibseqstr f g z ] and any [ y : Y ] there is defined a function [ diff1 : (g y) = z -> X ] and a structure of the fibration sequence [ fibseqdiff1 ] on the triple [ diff1 g y ]. This new fibration sequence is called the derived fibration sequence of the original one. The first function of the second derived of [ f g z fs ] corresponding to [ (y : Y) (x : X) ] is of the form [ (f x) = y -> (g y) = z ] and it is homotopic to the function defined by [ e => pathscomp0 (maponpaths g (pathsinv0 e)) (ez x) ]. The first function of the third derived of [ f g z fs ] corresponding to [ (y : Y) (x : X) (e : (g y) = z) ] is of the form [ (diff1 e) = x -> (f x) = y ]. Therefore, the third derived of a sequence based on [ X Y Z ] is based entirely on types = of [ X ], [ Y ] and [ Z ]. When this construction is applied to types of finite h-level (see below) and combined with the fact that the h-level of a path type is strictly lower than the h-level of the ambient type it leads to the possibility of building proofs about types by induction on h-level. There are three important special cases in which fibration sequences arise: ( pr1 - case ) The fibration sequence [ fibseqpr1 P z ] defined by family [ P : Z -> UU ] and a term [ z : Z ]. It is based on the sequence of functions [ (tpair P z : P z -> total2 P) (pr1 : total2 P -> Z) ]. The corresponding [ ezmap ] is defined by an obvious rule and the fact that it is a weak equivalence is proved in [ isweqfibertohfiber ]. ( g - case ) The fibration sequence [ fibseqg g z ] defined by a function [ g : Y -> Z ] and a term [ z : Z ]. It is based on the sequence of functions [ (hfiberpr1 : hfiber g z -> Y) (g : Y -> Z) ] and the corresponding [ ezmap ] is the function which takes a term [ ye : hfiber ] to [ make_hfiber g (pr1 ye) (pr2 ye) ]. We now have eta-coercion for dependent sums, so it is the identity function, which is sufficient to ensure that it is a weak equivalence. The first derived of [ fibseqg g z ] corresponding to [ y : Y ] coincides with [ fibseqpr1 (λ y' : Y , (g y') = z) y ]. ( hf -case ) The fibration sequence of homotopy fibers defined for any pair of functions [ (f : X -> Y) (g : Y -> Z) ] and any terms [ (z : Z) (ye : hfiber g z) ]. It is based on functions [ hfiberftogf : hfiber f (pr1 ye) -> hfiber (funcomp f g) z ] and [ hfibergftog : hfiber (funcomp f g) z -> hfiber g z ] which are defined below. *) (** *** The structures of a complex and of a fibration sequence on a composable pair of functions *) (** The structure of a complex on a composable pair of functions [ (f : X -> Y) (g : Y -> Z) ] relative to a term [ z : Z ]. *) Definition complxstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) := ∏ x : X, (g (f x)) = z. (** The structure of a fibration sequence on a complex. *) Definition ezmap {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ez : complxstr f g z) : X -> hfiber g z := λ x : X, make_hfiber g (f x) (ez x). Definition isfibseq {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ez : complxstr f g z) := isweq (ezmap f g z ez). Definition fibseqstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) := ∑ ez : complxstr f g z, isfibseq f g z ez. Definition make_fibseqstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) := tpair (λ ez : complxstr f g z, isfibseq f g z ez). Definition fibseqstrtocomplxstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) : fibseqstr f g z -> complxstr f g z := @pr1 _ (λ ez : complxstr f g z, isfibseq f g z ez). Coercion fibseqstrtocomplxstr : fibseqstr >-> complxstr. Definition ezweq {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) : X ≃ hfiber g z := make_weq _ (pr2 fs). (** *** Construction of the derived fibration sequence *) Definition d1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) : (g y) = z -> X := λ e : _, invmap (ezweq f g z fs) (make_hfiber g y e). Definition ezmap1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) (e : (g y) = z) : hfiber f y. Proof. intros. split with (d1 f g z fs y e). unfold d1. change (f (invmap (ezweq f g z fs) (make_hfiber g y e))) with (hfiberpr1 _ _ (ezweq f g z fs (invmap (ezweq f g z fs) (make_hfiber g y e)))). apply (maponpaths (hfiberpr1 g z) (homotweqinvweq (ezweq f g z fs) (make_hfiber g y e))). Defined. Definition invezmap1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ez : complxstr f g z) (y : Y) : hfiber f y -> (g y) = z := λ xe: hfiber f y, match xe with tpair _ x e => pathscomp0 (maponpaths g (pathsinv0 e)) (ez x) end. Theorem isweqezmap1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) : isweq (ezmap1 f g z fs y). Proof. intros. set (ff := ezmap1 f g z fs y). set (gg := invezmap1 f g z (pr1 fs) y). assert (egf : ∏ e : _, (gg (ff e)) = e). intro. simpl. apply (hfibertriangle1inv0 g (homotweqinvweq (ezweq f g z fs) (make_hfiber g y e))). assert (efg : ∏ xe : _, (ff (gg xe)) = xe). intro. induction xe as [ x e ]. induction e. simpl. unfold ff. unfold ezmap1. unfold d1. change (make_hfiber g (f x) (pr1 fs x)) with (ezmap f g z fs x). apply (hfibertriangle2 f (make_hfiber f (invmap (ezweq f g z fs) (ezmap f g z fs x)) _) (make_hfiber f x (idpath _)) (homotinvweqweq (ezweq f g z fs) x)). simpl. set (e1 := pathsinv0 (pathscomp0rid (maponpaths f (homotinvweqweq (ezweq f g z fs) x)))). assert (e2 : (maponpaths (hfiberpr1 g z) (homotweqinvweq (ezweq f g z fs) ((ezmap f g z fs) x))) = (maponpaths f (homotinvweqweq (ezweq f g z fs) x))). set (e3 := maponpaths (λ e : _, maponpaths (hfiberpr1 g z) e) (pathsinv0 (homotweqinvweqweq (ezweq f g z fs) x))). simpl in e3. set (e4 := maponpathscomp (ezmap f g z (pr1 fs)) (hfiberpr1 g z) (homotinvweqweq (ezweq f g z fs) x)). simpl in e4. apply (pathscomp0 e3 e4). apply (pathscomp0 e2 e1). apply (isweq_iso _ _ egf efg). Defined. Definition ezweq1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) := make_weq _ (isweqezmap1 f g z fs y). Definition fibseq1 {X Y Z : UU} (f :X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) : fibseqstr (d1 f g z fs y) f y := make_fibseqstr _ _ _ _ (isweqezmap1 f g z fs y). (** *** Explicit description of the first map in the second derived sequence *) Definition d2 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) (x : X) (e : (f x) = y) : (g y) = z := pathscomp0 (maponpaths g (pathsinv0 e)) ((pr1 fs) x). Definition ezweq2 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (y : Y) (x : X) : f x = y ≃ hfiber (d1 f g z fs y) x := ezweq1 (d1 f g z fs y) f y (fibseq1 f g z fs y) x. Definition fibseq2 {X Y Z : UU} (f : X -> Y) (g : Y->Z) (z : Z) (fs : fibseqstr f g z) (y : Y) (x : X) : fibseqstr (d2 f g z fs y x) (d1 f g z fs y) x := make_fibseqstr _ _ _ _ (isweqezmap1 (d1 f g z fs y) f y (fibseq1 f g z fs y) x). (** *** Fibration sequences based on [ tpair P z ] and [ pr1 : total2 P -> Z ] ( the "pr1-case" ) *) (** Construction of the fibration sequence. *) Definition ezmappr1 {Z : UU} (P : Z -> UU) (z : Z) : P z -> hfiber (@pr1 Z P) z := λ p : P z, tpair _ (tpair _ z p) (idpath z). Definition invezmappr1 {Z : UU} (P : Z -> UU) (z : Z) : hfiber (@pr1 Z P) z -> P z := λ te, transportf P (pr2 te) (pr2 (pr1 te)). Definition isweqezmappr1 {Z : UU} (P : Z -> UU) (z : Z) : isweq (ezmappr1 P z). Proof. intros. assert (egf : ∏ x: P z , (invezmappr1 _ z ((ezmappr1 P z) x)) = x). intro. unfold ezmappr1. unfold invezmappr1. simpl. apply idpath. assert (efg : ∏ x: hfiber (@pr1 Z P) z , (ezmappr1 _ z (invezmappr1 P z x)) = x). intros. induction x as [ x t0 ]. induction t0. simpl in x. simpl. induction x. simpl. unfold transportf. unfold ezmappr1. apply idpath. apply (isweq_iso _ _ egf efg). Defined. Definition ezweqpr1 {Z : UU} (P : Z -> UU) (z : Z) := make_weq _ (isweqezmappr1 P z). Lemma isfibseqpr1 {Z : UU} (P : Z -> UU) (z : Z) : isfibseq (λ p : P z, tpair _ z p) (@pr1 Z P) z (λ p : P z, idpath z). Proof. intros. unfold isfibseq. unfold ezmap. apply isweqezmappr1. Defined. Definition fibseqpr1 {Z : UU} (P : Z -> UU) (z : Z) : fibseqstr (λ p : P z, tpair _ z p) (@pr1 Z P) z := make_fibseqstr _ _ _ _ (isfibseqpr1 P z). (** The main weak equivalence defined by the first derived of [ fibseqpr1 ]. *) Definition ezweq1pr1 {Z : UU} (P : Z -> UU) (z : Z) (zp : total2 P) : pr1 zp = z ≃ hfiber (tpair P z) zp := ezweq1 _ _ z (fibseqpr1 P z) zp. (** *** Fibration sequences based on [ hfiberpr1 : hfiber g z -> Y ] and [ g : Y -> Z ] (the "g-case") *) Theorem isfibseqg {Y Z : UU} (g : Y -> Z) (z : Z) : isfibseq (hfiberpr1 g z) g z (λ ye: _, pr2 ye). Proof. intros. simple refine (isweqhomot _ _ _ (idisweq _)). - intro. apply idpath. Defined. Definition ezweqg {Y Z : UU} (g : Y -> Z) (z : Z) := make_weq _ (isfibseqg g z). Definition fibseqg {Y Z : UU} (g : Y -> Z) (z : Z) : fibseqstr (hfiberpr1 g z) g z := make_fibseqstr _ _ _ _ (isfibseqg g z). (** The first derived of [ fibseqg ]. *) Definition d1g {Y Z : UU} (g : Y -> Z) (z : Z) (y : Y) : (g y) = z -> hfiber g z := make_hfiber g y. (** note that [ d1g ] coincides with [ d1 _ _ _ (fibseqg g z) ] which makes the following two definitions possible. *) Definition ezweq1g {Y Z : UU} (g : Y -> Z) (z : Z) (y : Y) : g y = z ≃ hfiber (hfiberpr1 g z) y := make_weq _ (isweqezmap1 (hfiberpr1 g z) g z (fibseqg g z) y). Definition fibseq1g {Y Z : UU} (g : Y -> Z) (z : Z) (y : Y) : fibseqstr (d1g g z y) (hfiberpr1 g z) y := make_fibseqstr _ _ _ _ (isweqezmap1 (hfiberpr1 g z) g z (fibseqg g z) y). (** The second derived of [ fibseqg ]. *) Definition d2g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) (e: (pr1 ye') = y) : (g y) = z := pathscomp0 (maponpaths g (pathsinv0 e)) (pr2 ye'). (** note that [ d2g ] coincides with [ d2 _ _ _ (fibseqg g z) ] which makes the following two definitions possible. *) Definition ezweq2g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) : (pr1 ye') = y ≃ hfiber (make_hfiber g y) ye' := ezweq2 _ _ _ (fibseqg g z) _ _. Definition fibseq2g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) : fibseqstr (d2g g y ye') (make_hfiber g y) ye' := fibseq2 _ _ _ (fibseqg g z) _ _. (** The third derived of [ fibseqg ] and an explicit description of the corresponding first map. *) Definition d3g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) (e : (g y) = z) : (make_hfiber g y e) = ye' -> (pr1 ye') = y := d2 (d1g g z y) (hfiberpr1 g z) y (fibseq1g g z y) ye' e. Lemma homotd3g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) (e : (g y) = z) (ee : (make_hfiber g y e) = ye') : (d3g g y ye' e ee) = (maponpaths (@pr1 _ _) (pathsinv0 ee)). Proof. intros. unfold d3g. unfold d2. simpl. apply pathscomp0rid. Defined. Definition ezweq3g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) (e : (g y) = z) := ezweq2 (d1g g z y) (hfiberpr1 g z) y (fibseq1g g z y) ye' e. Definition fibseq3g {Y Z : UU} (g : Y -> Z) {z : Z} (y : Y) (ye' : hfiber g z) (e : (g y) = z) := fibseq2 (d1g g z y) (hfiberpr1 g z) y (fibseq1g g z y) ye' e. (** *** Fibration sequence of h-fibers defined by a composable pair of functions (the "hf-case") We construct a fibration sequence based on [ hfibersftogf f g z ye : hfiber f (pr1 ye) -> hfiber gf z) ] and [ hfibersgftog f g z : hfiber gf z -> hfiber g z) ]. *) Definition hfibersftogf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) (xe : hfiber f (pr1 ye)) : hfiber (funcomp f g) z. Proof. intros. split with (pr1 xe). apply (pathscomp0 (maponpaths g (pr2 xe)) (pr2 ye)). Defined. Definition ezmaphf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) (xe : hfiber f (pr1 ye)) : hfiber (hfibersgftog f g z) ye. Proof. intros. split with (hfibersftogf f g z ye xe). simpl. apply (hfibertriangle2 g (make_hfiber g (f (pr1 xe)) (pathscomp0 (maponpaths g (pr2 xe)) (pr2 ye))) ye (pr2 xe)). simpl. apply idpath. Defined. Definition invezmaphf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) (xee' : hfiber (hfibersgftog f g z) ye) : hfiber f (pr1 ye). Proof. intros. split with (pr1 (pr1 xee')). apply (maponpaths (hfiberpr1 _ _) (pr2 xee')). Defined. Definition ffgg {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) (xee' : hfiber (hfibersgftog f g z) ye) : hfiber (hfibersgftog f g z) ye. Proof. intros. induction ye as [ y e ]. induction e. unfold hfibersgftog. unfold hfibersgftog in xee'. induction xee' as [ xe e' ]. induction xe as [ x e ]. set (e'' := (maponpaths g (maponpaths (hfiberpr1 g (g y)) e'))). simpl in e'. split with (make_hfiber (funcomp f g) x (pathscomp0 e'' (idpath (g y)))). simpl. apply (hfibertriangle2 _ (make_hfiber g (f x) (pathscomp0 e'' (idpath (g y)))) (make_hfiber g y (idpath _)) (maponpaths (hfiberpr1 _ _) e') (idpath _)). Defined. Definition homotffggid {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) (xee' : hfiber (hfibersgftog f g z) ye) : (ffgg f g z ye xee') = xee'. Proof. intros. induction ye as [ y e ]. induction e. induction xee' as [ xe e' ]. induction e'. induction xe as [ x e ]. induction e. simpl. apply idpath. Defined. Theorem isweqezmaphf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) : isweq (ezmaphf f g z ye). Proof. intros. set (ff := ezmaphf f g z ye). set (gg := invezmaphf f g z ye). assert (egf : ∏ xe : _ , (gg (ff xe)) = xe). induction ye as [ y e ]. induction e. intro xe. apply (hfibertriangle2 f (gg (ff xe)) xe (idpath (pr1 xe))). induction xe as [ x ex ]. simpl in ex. induction ex. simpl. apply idpath. assert (efg : ∏ xee' : _ , (ff (gg xee')) = xee'). induction ye as [ y e ]. induction e. intro xee'. assert (hint : (ff (gg xee')) = (ffgg f g (g y) (make_hfiber g y (idpath _)) xee')). induction xee' as [ xe e' ]. induction xe as [ x e ]. apply idpath. apply (pathscomp0 hint (homotffggid _ _ _ _ xee')). apply (isweq_iso _ _ egf efg). Defined. Definition ezweqhf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) : hfiber f (pr1 ye) ≃ hfiber (hfibersgftog f g z) ye := make_weq _ (isweqezmaphf f g z ye). Definition fibseqhf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) : fibseqstr (hfibersftogf f g z ye) (hfibersgftog f g z) ye := make_fibseqstr _ _ _ _ (isweqezmaphf f g z ye). Definition isweqinvezmaphf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (ye : hfiber g z) : isweq (invezmaphf f g z ye) := pr2 (invweq (ezweqhf f g z ye)). Corollary weqhfibersgwtog {X Y Z : UU} (w : X ≃ Y) (g : Y -> Z) (z : Z) : hfiber (funcomp w g) z ≃ hfiber g z. Proof. intros. split with (hfibersgftog w g z). intro ye. apply (iscontrweqf (ezweqhf w g z ye) ((pr2 w) (pr1 ye))). Defined. (** ** Functions between total spaces of families (** *** Function [ totalfun ] between total spaces from a family of functions between the fibers Including theorems saying that a fiber-wise morphism between total spaces is a weak equivalence if and only if all the morphisms between the fibers are weak equivalences. *) *) Definition totalfun {X : UU} (P Q : X -> UU) (f : ∏ x : X, P x -> Q x) : (∑ y, P y) → (∑ y, Q y) := (λ z: total2 P, tpair Q (pr1 z) (f (pr1 z) (pr2 z))). Theorem isweqtotaltofib {X : UU} (P Q : X -> UU) (f : ∏ x : X, P x -> Q x): isweq (totalfun _ _ f) -> ∏ x : X, isweq (f x). Proof. intros X0 x. set (totp := total2 P). set (totq := total2 Q). set (totf := (totalfun _ _ f)). set (pip := λ z: totp, pr1 z). set (piq:= λ z: totq, pr1 z). set (hfx := hfibersgftog totf piq x). simpl in hfx. assert (H : isweq hfx). unfold isweq. intro y. set (int := invezmaphf totf piq x y). assert (X1 : isweq int). apply (isweqinvezmaphf totf piq x y). induction y as [ t e ]. assert (is1 : iscontr (hfiber totf t)). apply (X0 t). apply (iscontrweqb (make_weq int X1) is1). set (ip := ezmappr1 P x). set (iq := ezmappr1 Q x). set (h := λ p: P x, hfx (ip p)). assert (is2 : isweq h). apply (twooutof3c ip hfx (isweqezmappr1 P x) H). set (h':= λ p: P x, iq ((f x) p)). assert (ee : ∏ p:P x, (h p) = (h' p)). intro. apply idpath. assert (X2 : isweq h'). apply (isweqhomot h h' ee is2). apply (twooutof3a (f x) iq X2). apply (isweqezmappr1 Q x). Defined. Definition weqtotaltofib {X : UU} (P Q : X -> UU) (f : ∏ x : X , P x -> Q x) (is : isweq (totalfun _ _ f)) (x : X) : P x ≃ Q x := make_weq _ (isweqtotaltofib P Q f is x). Theorem isweqfibtototal {X : UU} (P Q : X -> UU) (f : ∏ x : X, P x ≃ Q x) : isweq (totalfun _ _ f). Proof. set (fpq := totalfun P Q f). set (pr1p := λ z : total2 P, pr1 z). set (pr1q := λ z : total2 Q, pr1 z). unfold isweq. intro xq. set (x:= pr1q xq). set (xqe:= make_hfiber pr1q xq (idpath _)). set (hfpqx:= hfibersgftog fpq pr1q x). assert (isint : iscontr (hfiber hfpqx xqe)). assert (isint1 : isweq hfpqx). set (ipx := ezmappr1 P x). set (iqx := ezmappr1 Q x). set (diag := λ p : P x, (iqx ((f x) p))). assert (is2: isweq diag). apply (twooutof3c (f x) iqx (pr2 (f x)) (isweqezmappr1 Q x)). apply (twooutof3b ipx hfpqx (isweqezmappr1 P x) is2). unfold isweq in isint1. apply (isint1 xqe). set (intmap := invezmaphf fpq pr1q x xqe). apply (iscontrweqf (make_weq intmap (isweqinvezmaphf fpq pr1q x xqe)) isint). Defined. Theorem isweqfibtototal' {X : UU} (P Q : X -> UU) (f : ∏ x : X, P x ≃ Q x) : isweq (totalfun _ _ f). Proof. use isweq_iso. - use totalfun. intro x. apply (invmap (f x)). - intro xp. use total2_paths_f. + apply idpath. + apply homotinvweqweq. - intro xp. use total2_paths_f. + apply idpath. + apply homotweqinvweq. Defined. Definition weqfibtototal {X : UU} (P Q : X -> UU) (f : ∏ x, P x ≃ Q x) : (∑ x, P x) ≃ (∑ x, Q x) := make_weq _ (isweqfibtototal' P Q f). (** *** Function [ fpmap ] between the total spaces from a function between the bases Given [ X Y ] in [ UU ], [ P:Y -> UU ] and [ f: X -> Y ] we get a function [ fpmap: total2 X (P f) -> total2 Y P ]. The main theorem of this section asserts that the homotopy fiber of fpmap over [ yp:total Y P ] is naturally weakly equivalent to the homotopy fiber of [ f ] over [ pr1 yp ]. In particular, if [ f ] is a weak equivalence then so is [ fpmap ]. *) Definition fpmap {X Y : UU} (f : X -> Y) (P : Y -> UU) : (∑ x, P (f x)) -> (∑ y, P y) := λ z, tpair P (f (pr1 z)) (pr2 z). Definition hffpmap2 {X Y : UU} (f : X -> Y) (P : Y -> UU) : (∑ x, P (f x)) -> ∑ u : total2 P, hfiber f (pr1 u). Proof. intros X0. set (u:= fpmap f P X0). split with u. set (x:= pr1 X0). split with x. simpl. apply idpath. Defined. Lemma centralfiber {X : UU} (P : X -> UU) (x : X) : isweq (λ p : P x, tpair (λ u : coconusfromt X x, P (pr1 u)) (coconusfromtpair X (idpath x)) p). Proof. intros. set (f := λ p: P x, tpair (λ u: coconusfromt X x, P(pr1 u)) (coconusfromtpair X (idpath x)) p). set (g := λ z: total2 (λ u: coconusfromt X x, P (pr1 u)), transportf P (pathsinv0 (pr2 (pr1 z))) (pr2 z)). assert (efg : ∏ z : total2 (λ u : coconusfromt X x, P (pr1 u)), (f (g z)) = z). intro. induction z as [ t x0 ]. induction t as [ t x1 ]. simpl. induction x1. simpl. apply idpath. assert (egf : ∏ p : P x , (g (f p)) = p). intro. apply idpath. apply (isweq_iso f g egf efg). Defined. Lemma isweqhff {X Y : UU} (f : X -> Y) (P : Y -> UU) : isweq (hffpmap2 f P). Proof. intros. set (int := total2 (λ x : X, total2 (λ u : coconusfromt Y (f x), P (pr1 u)))). set (intpair := tpair (λ x:X, total2 (λ u : coconusfromt Y (f x), P (pr1 u)))). set (toint := λ z : (total2 (λ u : total2 P, hfiber f (pr1 u))), intpair (pr1 (pr2 z)) (tpair (fun u: coconusfromt Y (f (pr1 (pr2 z))) => P (pr1 u)) (coconusfromtpair _ (pr2 (pr2 z))) (pr2 (pr1 z)))). set (fromint := λ z : int, tpair (λ u : total2 P, hfiber f (pr1 u)) (tpair P (pr1 (pr1 (pr2 z))) (pr2 (pr2 z))) (make_hfiber f (pr1 z) (pr2 (pr1 (pr2 z))))). assert (fromto : ∏ u : (total2 (λ u : total2 P, hfiber f (pr1 u))), (fromint (toint u)) = u). simpl in toint. simpl in fromint. simpl. intro u. induction u as [ t x ]. induction x. induction t as [ p0 p1 ]. simpl. unfold toint. unfold fromint. simpl. apply idpath. assert (tofrom : ∏ u : int, (toint (fromint u)) = u). intro. induction u as [ t x ]. induction x as [ t0 x ]. induction t0. simpl in x. simpl. unfold fromint. unfold toint. simpl. apply idpath. assert (is : isweq toint). apply (isweq_iso toint fromint fromto tofrom). clear tofrom. clear fromto. clear fromint. set (h := λ u : total2 (λ x : X, P (f x)), toint ((hffpmap2 f P) u)). simpl in h. assert (l1 : ∏ x : X, isweq (λ p: P (f x), tpair (λ u : coconusfromt _ (f x), P (pr1 u)) (coconusfromtpair _ (idpath (f x))) p)). intro. apply (centralfiber P (f x)). assert (X0 : isweq h). apply (isweqfibtototal (λ x : X, P (f x)) (λ x : X, total2 (λ u : coconusfromt _ (f x), P (pr1 u))) (λ x : X, make_weq _ (l1 x))). apply (twooutof3a (hffpmap2 f P) toint X0 is). Defined. (** *** Homotopy fibers of [ fpmap ] *) Definition hfiberfpmap {X Y : UU} (f : X -> Y) (P : Y -> UU) (yp : total2 P) : hfiber (fpmap f P) yp -> hfiber f (pr1 yp). Proof. intros X0. set (int1:= hfibersgftog (hffpmap2 f P) (λ u : (∑ u : total2 P, hfiber f (pr1 u)), (pr1 u)) yp). set (phi := invezmappr1 (λ u:total2 P, hfiber f (pr1 u)) yp). apply (phi (int1 X0)). Defined. Theorem isweqhfiberfp {X Y : UU} (f : X -> Y) (P : Y -> UU) (yp : total2 P) : isweq (hfiberfpmap f P yp). Proof. intros. set (int1 := hfibersgftog (hffpmap2 f P) (λ u : (total2 (λ u : total2 P, hfiber f (pr1 u))), (pr1 u)) yp). assert (is1 : isweq int1). simpl in int1. apply (pr2 (weqhfibersgwtog (make_weq _ (isweqhff f P)) (λ u : total2 (λ u : total2 P, hfiber f (pr1 u)), pr1 u) yp)). set (phi := invezmappr1 (λ u : total2 P, hfiber f (pr1 u)) yp). assert (is2 : isweq phi). apply (pr2 (invweq (ezweqpr1 (λ u : total2 P, hfiber f (pr1 u)) yp))). apply (twooutof3c int1 phi is1 is2). Defined. (** *** The [ fpmap ] from a weak equivalence is a weak equivalence *) Corollary isweqfpmap {X Y : UU} (w : X ≃ Y)(P : Y -> UU) : isweq (fpmap w P). Proof. intros. unfold isweq. intro y. set (h := hfiberfpmap w P y). assert (X1 : isweq h). apply isweqhfiberfp. assert (is : iscontr (hfiber w (pr1 y))). apply (pr2 w). apply (iscontrweqb (make_weq h X1) is). Defined. Definition weqfp_map {X Y : UU} (w : X ≃ Y) (P : Y -> UU) : (∑ x, P(w x)) -> (∑ y, P y). Proof. intros xp. exact (w (pr1 xp),,pr2 xp). Defined. Definition weqfp_invmap {X Y : UU} (w : X ≃ Y) (P : Y -> UU) : (∑ y, P y) -> (∑ x, P(w x)). Proof. intros yp. exact (invmap w (pr1 yp),, transportf P (! homotweqinvweq w (pr1 yp)) (pr2 yp)). Defined. Definition weqfp {X Y : UU} (w : X ≃ Y) (P : Y -> UU) : (∑ x : X, P (w x)) ≃ (∑ y, P y). Proof. intros. exists (weqfp_map w P). refine (isweq_iso _ (weqfp_invmap w P) _ _). { intros xp. use total2_paths_f. { simpl. apply homotinvweqweq. } simpl. rewrite <- weq_transportf_adjointness. rewrite transport_f_f. rewrite pathsinv0l. apply idpath. } { intros yp. simple refine (total2_paths_f _ _). { simpl. apply homotweqinvweq. } simpl. rewrite transport_f_f. rewrite pathsinv0l. apply idpath. } Defined. Definition weqfp_compute_1 {X Y : UU} (w : X ≃ Y) (P : Y -> UU) : weqfp w P ~ weqfp_map w P. Proof. intros. intros xp. apply idpath. Defined. Definition weqfp_compute_2 {X Y : UU} (w : X ≃ Y) (P : Y -> UU) : invmap (weqfp w P) ~ weqfp_invmap w P. Proof. intros. intros yp. apply idpath. Defined. Definition weqtotal2overcoprod' {W X Y : UU} (P : W -> UU) (f : X ⨿ Y ≃ W) : (∑ w, P w) ≃ (∑ x : X, P (f (ii1 x))) ⨿ (∑ y : Y, P (f (ii2 y))). Proof. intros. exact (weqcomp (invweq (weqfp f _)) (weqtotal2overcoprod (P ∘ f))). Defined. (** *** Total spaces of families over a contractible base *) Definition fromtotal2overunit (P : unit -> UU) (tp : total2 P) : P tt. Proof. intros. induction tp as [ t p ]. induction t. apply p. Defined. Definition tototal2overunit (P : unit -> UU) (p : P tt) : total2 P := tpair P tt p. Theorem weqtotal2overunit (P : unit -> UU) : (∑ u, P u) ≃ P tt. Proof. set (f := fromtotal2overunit P). set (g := tototal2overunit P). split with f. assert (egf : ∏ a : _ , (g (f a)) = a). intro a. induction a as [ t p ]. induction t. apply idpath. assert (efg : ∏ a : _ , (f (g a)) = a). intro a. apply idpath. apply (isweq_iso _ _ egf efg). Defined. (** *** The function on the total spaces from functions on the bases and on the fibers *) Definition bandfmap {X Y : UU} (f : X -> Y) (P : X -> UU) (Q : Y -> UU) (fm : ∏ x : X, P x -> (Q (f x))) : (∑ x, P x) -> (∑ x, Q x) := λ xp, f (pr1 xp) ,, fm (pr1 xp) (pr2 xp). Theorem isweqbandfmap {X Y : UU} (w : X ≃ Y) (P : X -> UU) (Q : Y -> UU) (fw : ∏ x : X, P x ≃ Q (w x)) : isweq (bandfmap _ P Q fw). Proof. intros. set (f1 := totalfun P _ fw). set (is1 := isweqfibtototal P (λ x:X, Q (w x)) fw). set (f2:= fpmap w Q). set (is2:= isweqfpmap w Q). assert (h: ∏ xp: total2 P, (f2 (f1 xp)) = (bandfmap w P Q fw xp)). { intro. apply idpath. } apply (isweqhomot _ _ h (twooutof3c f1 f2 is1 is2)). Defined. Definition weqbandf {X Y : UU} (w : X ≃ Y) (P : X -> UU) (Q : Y -> UU) (fw : ∏ x : X, P x ≃ Q (w x)) := make_weq _ (isweqbandfmap w P Q fw). (** ** Homotopy fiber squares *) (** *** Homotopy commutative squares *) Definition commsqstr {X X' Y Z : UU} (g' : Z -> X') (f' : X' -> Y) (g : Z -> X) (f : X -> Y) := ∏ (z : Z), (f' (g' z)) = (f (g z)). Definition hfibersgtof' {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) (x : X) (ze : hfiber g x) : hfiber f' (f x). Proof. intros. induction ze as [ z e ]. split with (g' z). apply (pathscomp0 (h z) (maponpaths f e)). Defined. Definition hfibersg'tof {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) (x' : X') (ze : hfiber g' x') : hfiber f (f' x'). Proof. intros. induction ze as [ z e ]. split with (g z). apply (pathscomp0 (pathsinv0 (h z)) (maponpaths f' e)). Defined. Definition transposcommsqstr {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') : commsqstr g' f' g f -> commsqstr g f g' f' := λ h : _, λ z : Z, (pathsinv0 (h z)). (** *** Short complexes and homotopy commutative squares *) Lemma complxstrtocommsqstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (h : complxstr f g z) : commsqstr f g (λ x : X, tt) (λ t : unit, z). Proof. intros. assumption. Defined. Lemma commsqstrtocomplxstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (h : commsqstr f g (λ x : X, tt) (λ t : unit, z)) : complxstr f g z. Proof. intros. assumption. Defined. (** *** Homotopy fiber products *) Definition hfp {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) := total2 (λ xx' : X × X', (f' (pr2 xx')) = (f (pr1 xx'))). Definition hfpg {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) : hfp f f' -> X := λ xx'e, (pr1 (pr1 xx'e)). Definition hfpg' {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) : hfp f f' -> X' := λ xx'e, (pr2 (pr1 xx'e)). Definition commsqZtohfp {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) : Z -> hfp f f' := λ z : _, tpair _ (make_dirprod (g z) (g' z)) (h z). Definition commsqZtohfphomot {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) : ∏ z : Z, (hfpg _ _ (commsqZtohfp _ _ _ _ h z)) = (g z) := λ z : _, idpath _. Definition commsqZtohfphomot' {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) : ∏ z : Z, (hfpg' _ _ (commsqZtohfp _ _ _ _ h z)) = (g' z) := λ z : _, idpath _. Definition hfpoverX {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) := total2 (λ x : X, hfiber f' (f x)). Definition hfpoverX' {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) := total2 (λ x' : X', hfiber f (f' x')). Definition weqhfptohfpoverX {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) : hfp f f' ≃ hfpoverX f f'. Proof. intros. exact (weqtotal2asstor _ (λ xx', f' (pr2 xx') = f (pr1 xx'))). Defined. Definition weqhfptohfpoverX' {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) : hfp f f' ≃ hfpoverX' f f'. Proof. intros. set (w1 := weqfp (weqdirprodcomm X X') (λ xx' : X' × X , (f' (pr1 xx')) = (f (pr2 xx')))). simpl in w1. set (w2 := weqfibtototal (λ x'x : X' × X, (f' (pr1 x'x)) = (f (pr2 x'x))) (λ x'x : X' × X, (f (pr2 x'x)) = (f' (pr1 x'x))) (λ x'x : _, weqpathsinv0 (f' (pr1 x'x)) (f (pr2 x'x)))). set (w3 := weqtotal2asstor (λ x' : X', X) (λ x'x : X' × X, (f (pr2 x'x)) = (f' (pr1 x'x)))). simpl in w3. apply (weqcomp (weqcomp w1 w2) w3). Defined. Lemma weqhfpcomm {X X' Y : UU} (f : X -> Y) (f' : X' -> Y): hfp f f' ≃ hfp f' f. Proof. intros. set (w1 := weqfp (weqdirprodcomm X X') (λ xx' : X' × X, (f' (pr1 xx')) = (f (pr2 xx')))). simpl in w1. set (w2 := weqfibtototal (λ x'x : X' × X, (f' (pr1 x'x)) = (f (pr2 x'x))) (λ x'x : X' × X, (f (pr2 x'x)) = (f' (pr1 x'x))) (λ x'x : _, weqpathsinv0 (f' (pr1 x'x)) (f (pr2 x'x)))). apply (weqcomp w1 w2). Defined. Definition commhfp {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) : commsqstr (hfpg' f f') f' (hfpg f f') f := λ xx'e : hfp f f', pr2 xx'e. (** *** Homotopy fiber products and homotopy fibers *) Definition hfibertohfp {X Y : UU} (f : X -> Y) (y : Y) (xe : hfiber f y) : hfp (λ t : unit, y) f := tpair (λ tx : unit × X, (f (pr2 tx)) = y) (make_dirprod tt (pr1 xe)) (pr2 xe). Definition hfptohfiber {X Y : UU} (f : X -> Y) (y : Y) (hf : hfp (λ t : unit, y) f) : hfiber f y := make_hfiber f (pr2 (pr1 hf)) (pr2 hf). Lemma weqhfibertohfp {X Y : UU} (f : X -> Y) (y : Y) : hfiber f y ≃ hfp (λ _:unit, y) f. Proof. intros. set (ff := hfibertohfp f y). set (gg := hfptohfiber f y). split with ff. assert (egf : ∏ xe : _, (gg (ff xe)) = xe). intro. induction xe. apply idpath. assert (efg : ∏ hf : _, (ff (gg hf)) = hf). intro. induction hf as [ tx e ]. induction tx as [ t x ]. induction t. apply idpath. apply (isweq_iso _ _ egf efg). Defined. Lemma hfp_left {X Y Z : UU} (f : X -> Z) (g : Y -> Z) : hfp f g ≃ ∑ x, hfiber g (f x). Proof. intros. apply weqtotal2dirprodassoc. Defined. Definition hfp_right {X Y Z : UU} (f : X -> Z) (g : Y -> Z) : hfp f g ≃ ∑ y, hfiber f (g y). Proof. intros. use weq_iso. - intros [[x y] e]. exact (y,,x,,!e). - intros [x [y e]]. exact ((y,,x),,!e). - intros [[x y] e]. apply maponpaths, pathsinv0inv0. - intros [x [y e]]. apply maponpaths, maponpaths, pathsinv0inv0. Defined. Definition hfiber_comm {X Y Z : UU} (f : X -> Z) (g : Y -> Z) : (∑ x, hfiber g (f x)) ≃ (∑ y, hfiber f (g y)). Proof. intros. use weq_iso. - intros [x [y e]]. exact (y,,x,,!e). - intros [y [x e]]. exact (x,,y,,!e). - intros [x [y e]]. apply maponpaths, maponpaths, pathsinv0inv0. - intros [y [x e]]. apply maponpaths, maponpaths, pathsinv0inv0. Defined. (** *** Homotopy fiber squares *) Definition ishfsq {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) := isweq (commsqZtohfp f f' g g' h). Definition hfsqstr {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') := total2 (λ h : commsqstr g' f' g f, isweq (commsqZtohfp f f' g g' h)). Definition make_hfsqstr {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') := tpair (λ h : commsqstr g' f' g f, isweq (commsqZtohfp f f' g g' h)). Definition hfsqstrtocommsqstr {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') : hfsqstr f f' g g' -> commsqstr g' f' g f := @pr1 _ (λ h : commsqstr g' f' g f, isweq (commsqZtohfp f f' g g' h)). Coercion hfsqstrtocommsqstr : hfsqstr >-> commsqstr. Definition weqZtohfp {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') : Z ≃ hfp f f' := make_weq _ (pr2 hf). Lemma isweqhfibersgtof' {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') (x : X) : isweq (hfibersgtof' f f' g g' hf x). Proof. intros. set (is := pr2 hf). set (h := pr1 hf). set (a := weqtococonusf g). set (c := make_weq _ is). set (d := weqhfptohfpoverX f f'). set (b0 := totalfun _ _ (hfibersgtof' f f' g g' h)). assert (h1 : ∏ z : Z, (d (c z)) = (b0 (a z))). intro. simpl. unfold b0. unfold a. unfold weqtococonusf. unfold tococonusf. simpl. unfold totalfun, total2asstor, hfibersgtof'; simpl. assert (e : (h z) = (pathscomp0 (h z) (idpath (f (g z))))). apply (pathsinv0 (pathscomp0rid _)). induction e. apply idpath. assert (is1 : isweq (λ z : _, b0 (a z))). apply (isweqhomot _ _ h1). apply (twooutof3c _ _ (pr2 c) (pr2 d)). assert (is2 : isweq b0). apply (twooutof3b _ _ (pr2 a) is1). apply (isweqtotaltofib _ _ _ is2 x). Defined. Definition weqhfibersgtof' {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') (x : X) := make_weq _ (isweqhfibersgtof' _ _ _ _ hf x). Lemma ishfsqweqhfibersgtof' {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) (is : ∏ x : X, isweq (hfibersgtof' f f' g g' h x)) : hfsqstr f f' g g'. Proof. intros. split with h. set (a := weqtococonusf g). set (c0 := commsqZtohfp f f' g g' h). set (d := weqhfptohfpoverX f f'). set (b := weqfibtototal _ _ (λ x : X, make_weq _ (is x))). assert (h1 : ∏ z : Z, (d (c0 z)) = (b (a z))). intro. simpl. unfold b. unfold a. unfold weqtococonusf. unfold tococonusf. simpl. unfold totalfun, total2asstor, hfibersgtof'; simpl. assert (e : (h z) = (pathscomp0 (h z) (idpath (f (g z))))). apply (pathsinv0 (pathscomp0rid _)). induction e. apply idpath. assert (is1 : isweq (λ z : _, d (c0 z))). apply (isweqhomot _ _ (λ z : Z, (pathsinv0 (h1 z)))). apply (twooutof3c _ _ (pr2 a) (pr2 b)). apply (twooutof3a _ _ is1 (pr2 d)). Defined. Lemma isweqhfibersg'tof {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') (x' : X') : isweq (hfibersg'tof f f' g g' hf x'). Proof. intros. set (is := pr2 hf). set (h := pr1 hf). set (a' := weqtococonusf g'). set (c' := make_weq _ is). set (d' := weqhfptohfpoverX' f f'). set (b0' := totalfun _ _ (hfibersg'tof f f' g g' h)). assert (h1 : ∏ z : Z, (d' (c' z)) = (b0' (a' z))). intro. unfold b0'. unfold a'. unfold weqtococonusf. unfold tococonusf. unfold totalfun, hfibersg'tof; simpl. assert (e : (pathsinv0 (h z)) = (pathscomp0 (pathsinv0 (h z)) (idpath (f' (g' z))))). apply (pathsinv0 (pathscomp0rid _)). induction e. apply idpath. assert (is1 : isweq (λ z : _, b0'(a' z))). apply (isweqhomot _ _ h1). apply (twooutof3c _ _ (pr2 c') (pr2 d')). assert (is2 : isweq b0'). apply (twooutof3b _ _ (pr2 a') is1). apply (isweqtotaltofib _ _ _ is2 x'). Defined. Definition weqhfibersg'tof {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') (x' : X') := make_weq _ (isweqhfibersg'tof _ _ _ _ hf x'). Lemma ishfsqweqhfibersg'tof {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (h : commsqstr g' f' g f) (is : ∏ x' : X', isweq (hfibersg'tof f f' g g' h x')) : hfsqstr f f' g g'. Proof. intros. split with h. set (a' := weqtococonusf g'). set (c0' := commsqZtohfp f f' g g' h). set (d' := weqhfptohfpoverX' f f'). set (b' := weqfibtototal _ _ (λ x' : X', make_weq _ (is x'))). assert (h1 : ∏ z : Z, (d' (c0' z)) = (b' (a' z))). intro. simpl. unfold b'. unfold a'. unfold weqtococonusf. unfold tococonusf. unfold totalfun, total2asstor, hfibersg'tof; simpl. assert (e : (pathsinv0 (h z)) = (pathscomp0 (pathsinv0 (h z)) (idpath (f' (g' z))))). apply (pathsinv0 (pathscomp0rid _)). induction e. apply idpath. assert (is1 : isweq (λ z : _, d' (c0' z))). apply (isweqhomot _ _ (λ z : Z, (pathsinv0 (h1 z)))). apply (twooutof3c _ _ (pr2 a') (pr2 b')). apply (twooutof3a _ _ is1 (pr2 d')). Defined. Theorem transposhfpsqstr {X X' Y Z : UU} (f : X -> Y) (f' : X' -> Y) (g : Z -> X) (g' : Z -> X') (hf : hfsqstr f f' g g') : hfsqstr f' f g' g. Proof. intros. set (is := pr2 hf). set (h := pr1 hf). set (th := transposcommsqstr f f' g g' h). split with th. set (w1 := weqhfpcomm f f'). assert (h1 : ∏ z : Z, (w1 (commsqZtohfp f f' g g' h z)) = (commsqZtohfp f' f g' g th z)). intro. unfold commsqZtohfp. simpl. unfold fpmap. unfold totalfun. simpl. apply idpath. apply (isweqhomot _ _ h1). apply (twooutof3c _ _ is (pr2 w1)). Defined. (** *** Fiber sequences and homotopy fiber squares *) Theorem fibseqstrtohfsqstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (hf : fibseqstr f g z) : hfsqstr (λ t : unit, z) g (λ x : X, tt) f. Proof. intros. split with (pr1 hf). set (ff := ezweq f g z hf). set (ggff := commsqZtohfp (λ t : unit, z) g (λ x : X, tt) f (pr1 hf)). set (gg := weqhfibertohfp g z). apply (pr2 (weqcomp ff gg)). Defined. Theorem hfsqstrtofibseqstr {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (hf : hfsqstr (λ t : unit, z) g (λ x : X, tt) f) : fibseqstr f g z. Proof. intros. split with (pr1 hf). set (ff := ezmap f g z (pr1 hf)). set (ggff := weqZtohfp (λ t : unit, z) g (λ x : X, tt) f hf). set (gg := weqhfibertohfp g z). apply (twooutof3a ff gg (pr2 ggff) (pr2 gg)). Defined. (* End of the file PartA.v *) UniMath-20231010/UniMath/Foundations/PartB.v000066400000000000000000001176131451125700300203550ustar00rootroot00000000000000(** * Univalent Foundations. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014. The second part of the original uu0 file, created on Dec. 3, 2014. This file starts with the definition of h-levels. No axioms are used. Only one universe [ UU ] is used, except in one case. In the current approach to dependent eliminators for inductive types, in this case for [ nat ], the type family appears as an argument of the eliminator in the form of a function. Therefore, if one wants to use the eliminator [ nat_rect ] to define a function [ nat -> UU ] one must use, as an argument, the function [ n : nat => UU ] whose type is [ forall n : nat, UU' ] where [ UU' ] is the type of [ UU ]. Therefore, the eliminator must be defined on arguments whose type contains [ UU' ] and we should acknowledge it as an instance of using a second universe. *) (** ** Contents - Basics about h-levels - h-levels of types - h-levels of functions - h-levelf of pr1 - h-level of the total space of total2 - Basics on propositions, inclusions and sets - Propositions, types of h-level 1 - Inclusions, functions of h-level 1 - Sets, types of h-level 2 *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.PartA. (** ** Basics about h-levels *) (** *** h-levels of types *) Fixpoint isofhlevel (n : nat) (X : UU) : UU := match n with | O => iscontr X | S m => ∏ x : X, ∏ x' : X, (isofhlevel m (x = x')) end. (* induction induction *) Theorem hlevelretract (n : nat) {X Y : UU} (p : X -> Y) (s : Y -> X) (eps : ∏ y : Y , paths (p (s y)) y) : isofhlevel n X -> isofhlevel n Y. Proof. revert X Y p s eps. induction n as [ | n IHn ]. - intros X Y p s eps X0. unfold isofhlevel. apply (iscontrretract p s eps X0). - unfold isofhlevel. intros X Y p s eps X0 x x'. unfold isofhlevel in X0. assert (is: isofhlevel n (paths (s x) (s x'))) by apply X0. set (s':= @maponpaths _ _ s x x'). set (p':= pathssec2 s p eps x x'). set (eps':= @pathssec3 _ _ s p eps x x'). simpl. apply (IHn _ _ p' s' eps' is). Defined. Corollary isofhlevelweqf (n : nat) {X Y : UU} (f : X ≃ Y) : isofhlevel n X -> isofhlevel n Y. Proof. intros X0. apply (hlevelretract n f (invmap f) (homotweqinvweq f)). assumption. Defined. Corollary isofhlevelweqb (n : nat) {X Y : UU} (f : X ≃ Y) : isofhlevel n Y -> isofhlevel n X. Proof. intros X0. apply (hlevelretract n (invmap f) f (homotinvweqweq f)). assumption. Defined. Lemma isofhlevelsn (n : nat) {X : UU} (f : X -> isofhlevel (S n) X) : isofhlevel (S n) X. Proof. intros. simpl. intros x x'. apply (f x x x'). Defined. Lemma isofhlevelssn (n : nat) {X : UU} (is : ∏ x : X, isofhlevel (S n) (x = x)) : isofhlevel (S (S n)) X. Proof. intros. simpl. intros x x'. change (∏ (x0 x'0 : x = x'), isofhlevel n (x0 = x'0)) with (isofhlevel (S n) (x = x')). assert (X1 : x = x' -> isofhlevel (S n) (x = x')) by (intro X2; induction X2; apply (is x)). apply (isofhlevelsn n X1). Defined. (** *** h-levels of functions *) Definition isofhlevelf (n : nat) {X Y : UU} (f : X -> Y) : UU := ∏ y : Y, isofhlevel n (hfiber f y). Theorem isofhlevelfhomot (n : nat) {X Y : UU} (f f' : X -> Y) (h : ∏ x : X, paths (f x) (f' x)) : isofhlevelf n f -> isofhlevelf n f'. Proof. intros X0. unfold isofhlevelf. intro y. apply (isofhlevelweqf n (weqhfibershomot f f' h y) (X0 y)). Defined. Theorem isofhlevelfpmap (n : nat) {X Y : UU} (f : X -> Y) (Q : Y -> UU) : isofhlevelf n f -> isofhlevelf n (fpmap f Q). Proof. intros X0. unfold isofhlevelf. unfold isofhlevelf in X0. intro y. set (yy := pr1 y). set (g := hfiberfpmap f Q y). set (is := isweqhfiberfp f Q y). set (isy := X0 yy). apply (isofhlevelweqb n (make_weq g is) isy). Defined. Theorem isofhlevelfffromZ (n : nat) {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (isz : isofhlevel (S n) Z) : isofhlevelf n f. Proof. intros. intro y. assert (w : (hfiber f y) ≃ ((g y) = z)). apply (invweq (ezweq1 f g z fs y)). apply (isofhlevelweqb n w (isz (g y) z)). Defined. Theorem isofhlevelXfromg (n : nat) {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) : isofhlevelf n g -> isofhlevel n X. Proof. intros isf. assert (w : X ≃ (hfiber g z)). apply (make_weq _ (pr2 fs)). apply (isofhlevelweqb n w (isf z)). Defined. Theorem isofhlevelffromXY (n : nat) {X Y : UU} (f : X -> Y) : isofhlevel n X -> isofhlevel (S n) Y -> isofhlevelf n f. Proof. revert X Y f. induction n as [ | n IHn ]. - intros X Y f X0 X1. assert (is1 : isofhlevel O Y). { split with (f (pr1 X0)). intro t. unfold isofhlevel in X1. set (is := X1 t (f (pr1 X0))). apply (pr1 is). } apply (isweqcontrcontr f X0 is1). - intros X Y f X0 X1. unfold isofhlevelf. simpl. assert (is1 : ∏ x' x : X, isofhlevel n (x' = x)) by (simpl in X0; assumption). assert (is2 : ∏ y' y : Y, isofhlevel (S n) (y' = y)) by (simpl in X1; simpl; assumption). assert (is3 : ∏ (y : Y) (x : X) (xe' : hfiber f y), isofhlevelf n (d2g f x xe')) by (intros; apply (IHn _ _ (d2g f x xe') (is1 (pr1 xe') x) (is2 (f x) y))). assert (is4 : ∏ (y : Y) (x : X) (xe' : hfiber f y) (e : (f x) = y), isofhlevel n ((make_hfiber f x e) = xe')) by (intros; apply (isofhlevelweqb n (ezweq3g f x xe' e) (is3 y x xe' e))). intros y xe xe'. induction xe as [ t x ]. apply (is4 y t xe' x). Defined. Theorem isofhlevelXfromfY (n : nat) {X Y : UU} (f : X -> Y) : isofhlevelf n f -> isofhlevel n Y -> isofhlevel n X. Proof. revert X Y f. induction n as [ | n IHn ]. - intros X Y f X0 X1. apply (iscontrweqb (make_weq f X0) X1). - intros X Y f X0 X1. simpl. assert (is1 : ∏ (y : Y) (xe xe': hfiber f y), isofhlevel n (xe = xe')) by (intros; apply (X0 y)). assert (is2 : ∏ (y : Y) (x : X) (xe' : hfiber f y), isofhlevelf n (d2g f x xe')). { intros. unfold isofhlevel. intro y0. apply (isofhlevelweqf n (ezweq3g f x xe' y0) (is1 y (make_hfiber f x y0) xe')). } assert (is3 : ∏ (y' y : Y), isofhlevel n (y' = y)) by (simpl in X1; assumption). intros x' x. set (y := f x'). set (e' := idpath y). set (xe' := make_hfiber f x' e'). apply (IHn _ _ (d2g f x xe') (is2 y x xe') (is3 (f x) y)). Defined. Theorem isofhlevelffib (n : nat) {X : UU} (P : X -> UU) (x : X) (is : ∏ x' : X, isofhlevel n (x' = x)) : isofhlevelf n (tpair P x). Proof. intros. unfold isofhlevelf. intro xp. apply (isofhlevelweqf n (ezweq1pr1 P x xp) (is (pr1 xp))). Defined. Theorem isofhlevelfhfiberpr1y (n : nat) {X Y : UU} (f : X -> Y) (y : Y) (is : ∏ y' : Y, isofhlevel n (y' = y)) : isofhlevelf n (hfiberpr1 f y). Proof. intros. unfold isofhlevelf. intro x. apply (isofhlevelweqf n (ezweq1g f y x) (is (f x))). Defined. Theorem isofhlevelfsnfib (n : nat) {X : UU} (P : X -> UU) (x : X) (is : isofhlevel (S n) (x = x)) : isofhlevelf (S n) (tpair P x). Proof. intros. unfold isofhlevelf. intro xp. apply (isofhlevelweqf (S n) (ezweq1pr1 P x xp)). apply isofhlevelsn. intro X1. induction X1. assumption. Defined. Theorem isofhlevelfsnhfiberpr1 (n : nat) {X Y : UU} (f : X -> Y) (y : Y) (is : isofhlevel (S n) (y = y)) : isofhlevelf (S n) (hfiberpr1 f y). Proof. intros. unfold isofhlevelf. intro x. apply (isofhlevelweqf (S n) ( ezweq1g f y x)). apply isofhlevelsn. intro X1. induction X1. assumption. Defined. Corollary isofhlevelfhfiberpr1 (n : nat) {X Y : UU} (f : X -> Y) (y : Y) (is : isofhlevel (S n) Y) : isofhlevelf n (hfiberpr1 f y). Proof. intros. apply isofhlevelfhfiberpr1y. intro y'. apply (is y' y). Defined. Theorem isofhlevelff (n : nat) {X Y Z : UU} (f : X -> Y) (g : Y -> Z) : isofhlevelf n (λ x : X, g (f x)) -> isofhlevelf (S n) g -> isofhlevelf n f. Proof. intros X0 X1. unfold isofhlevelf. intro y. set (ye := make_hfiber g y (idpath (g y))). apply (isofhlevelweqb n ( ezweqhf f g (g y) ye) (isofhlevelffromXY n _ (X0 (g y)) (X1 (g y)) ye)). Defined. Theorem isofhlevelfgf (n : nat) {X Y Z : UU} (f : X -> Y) (g : Y -> Z) : isofhlevelf n f -> isofhlevelf n g -> isofhlevelf n (λ x : X, g (f x)). Proof. intros X0 X1. unfold isofhlevelf. intro z. assert (is1 : isofhlevelf n (hfibersgftog f g z)). { unfold isofhlevelf. intro ye. apply (isofhlevelweqf n (ezweqhf f g z ye) (X0 (pr1 ye))). } assert (is2 : isofhlevel n (hfiber g z)) by apply (X1 z). apply (isofhlevelXfromfY n _ is1 is2). Defined. Theorem isofhlevelfgwtog (n : nat) {X Y Z : UU} (w : X ≃ Y) (g : Y -> Z) (is : isofhlevelf n (λ x : X, g (w x))) : isofhlevelf n g. Proof. intros. intro z. assert (is' : isweq (hfibersgftog w g z)). { intro ye. apply (iscontrweqf (ezweqhf w g z ye) (pr2 w (pr1 ye))). } apply (isofhlevelweqf _ (make_weq _ is') (is _)). Defined. Theorem isofhlevelfgtogw (n : nat) {X Y Z : UU} (w : X ≃ Y) (g : Y -> Z) (is : isofhlevelf n g) : isofhlevelf n (λ x : X, g (w x)). Proof. intros. intro z. assert (is' : isweq (hfibersgftog w g z)). { intro ye. apply (iscontrweqf (ezweqhf w g z ye) (pr2 w (pr1 ye))). } apply (isofhlevelweqb _ (make_weq _ is') (is _)). Defined. Corollary isofhlevelfhomot2 (n : nat) {X X' Y : UU} (f : X -> Y) (f' : X' -> Y) (w : X ≃ X') (h : ∏ x : X, paths (f x) (f' (w x))) : isofhlevelf n f -> isofhlevelf n f'. Proof. intros X0. assert (X1 : isofhlevelf n (λ x : X, f' (w x))) by apply (isofhlevelfhomot n _ _ h X0). apply (isofhlevelfgwtog n w f' X1). Defined. Theorem isofhlevelfonpaths (n : nat) {X Y : UU} (f : X -> Y) (x x' : X) : isofhlevelf (S n) f -> isofhlevelf n (@maponpaths _ _ f x x'). Proof. intros X0. set (y := f x'). set (xe' := make_hfiber f x' (idpath _)). assert (is1 : isofhlevelf n (d2g f x xe')). { unfold isofhlevelf. intro y0. apply (isofhlevelweqf n (ezweq3g f x xe' y0) (X0 y (make_hfiber f x y0) xe')). } assert (h : ∏ ee : x' = x, paths (d2g f x xe' ee) (maponpaths f (pathsinv0 ee))). { intro. assert (e0: paths (pathscomp0 (maponpaths f (pathsinv0 ee)) (idpath _)) (maponpaths f (pathsinv0 ee))) by (induction ee; simpl; apply idpath). apply (e0). } apply (isofhlevelfhomot2 n _ _ (make_weq (@pathsinv0 _ x' x) (isweqpathsinv0 _ _)) h is1). Defined. Theorem isofhlevelfsn (n : nat) {X Y : UU} (f : X -> Y) : (∏ x x' : X, isofhlevelf n (@maponpaths _ _ f x x')) -> isofhlevelf (S n) f. Proof. intros X0. unfold isofhlevelf. intro y. simpl. intros x x'. induction x as [ x e ]. induction x' as [ x' e' ]. induction e'. set (xe' := make_hfiber f x' (idpath _)). set (xe := make_hfiber f x e). set (d3 := d2g f x xe'). simpl in d3. assert (is1 : isofhlevelf n (d2g f x xe')). assert (h : ∏ ee : x' = x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). { intro. unfold d2g. simpl. apply (pathsinv0 (pathscomp0rid _)). } assert (is2 : isofhlevelf n (λ ee: x' = x, maponpaths f (pathsinv0 ee))) by apply (isofhlevelfgtogw n ( make_weq _ (isweqpathsinv0 _ _)) (@maponpaths _ _ f x x') (X0 x x')). apply (isofhlevelfhomot n _ _ h is2). apply (isofhlevelweqb n (ezweq3g f x xe' e) (is1 e)). Defined. Theorem isofhlevelfssn (n : nat) {X Y : UU} (f : X -> Y) : (∏ x : X, isofhlevelf (S n) (@maponpaths _ _ f x x)) -> isofhlevelf (S (S n)) f. Proof. intros X0. unfold isofhlevelf. intro y. assert (∏ xe0 : hfiber f y, isofhlevel (S n) (xe0 = xe0)). { intro. induction xe0 as [ x e ]. induction e. set (e':= idpath (f x)). set (xe':= make_hfiber f x e'). set (xe:= make_hfiber f x e'). set (d3:= d2g f x xe'). simpl in d3. assert (is1: isofhlevelf (S n) (d2g f x xe')). { assert (h : ∏ ee: x = x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). { intro. unfold d2g. simpl. apply (pathsinv0 (pathscomp0rid _)). } assert (is2 : isofhlevelf (S n) (fun ee : x = x => maponpaths f (pathsinv0 ee))) by apply (isofhlevelfgtogw (S n) (make_weq _ (isweqpathsinv0 _ _)) (@maponpaths _ _ f x x) (X0 x)). apply (isofhlevelfhomot (S n) _ _ h is2). } apply (isofhlevelweqb (S n) (ezweq3g f x xe' e') (is1 e')). } apply (isofhlevelssn). assumption. Defined. (** ** h -levels of [ pr1 ], fiber inclusions, fibers, total spaces and bases of fibrations *) (** *** h-levelf of [ pr1 ] *) Theorem isofhlevelfpr1 (n : nat) {X : UU} (P : X -> UU) (is : ∏ x : X, isofhlevel n (P x)) : isofhlevelf n (@pr1 X P). Proof. intros. unfold isofhlevelf. intro x. apply (isofhlevelweqf n (ezweqpr1 _ x) (is x)). Defined. Lemma isweqpr1 {Z : UU} (P : Z -> UU) (is1 : ∏ z : Z, iscontr (P z)) : isweq (@pr1 Z P). Proof. intros. unfold isweq. intro y. set (isy := is1 y). apply (iscontrweqf (ezweqpr1 P y)). assumption. Defined. Definition weqpr1 {Z : UU} (P : Z -> UU) (is : ∏ z : Z , iscontr (P z)) : weq (total2 P) Z := make_weq _ (isweqpr1 P is). (** *** h-level of the total space [ total2 ] *) Theorem isofhleveltotal2 (n : nat) {X : UU} (P : X -> UU) (is1 : isofhlevel n X) (is2 : ∏ x : X, isofhlevel n (P x)) : isofhlevel n (total2 P). Proof. intros. apply (isofhlevelXfromfY n (@pr1 _ _)). apply isofhlevelfpr1. assumption. assumption. Defined. Corollary isofhleveldirprod (n : nat) (X Y : UU) (is1 : isofhlevel n X) (is2 : isofhlevel n Y) : isofhlevel n (X × Y). Proof. intros. apply isofhleveltotal2. assumption. intro. assumption. Defined. (** ** Propositions, inclusions and sets *) (** *** Basics about types of h-level 1 - "propositions" *) Definition isaprop := isofhlevel 1. Definition isPredicate {X : UU} (Y : X -> UU) := ∏ x : X, isaprop (Y x). Definition isapropunit : isaprop unit := iscontrpathsinunit. Definition isapropdirprod (X Y : UU) : isaprop X -> isaprop Y -> isaprop (X × Y) := isofhleveldirprod 1 X Y. Lemma isapropifcontr {X : UU} (is : iscontr X) : isaprop X. Proof. intros. set (f := λ x : X, tt). assert (isw : isweq f) by (apply isweqcontrtounit; assumption). apply (isofhlevelweqb (S O) (make_weq f isw)). intros x x'. apply iscontrpathsinunit. Defined. Theorem hlevelntosn (n : nat) (T : UU) (is : isofhlevel n T) : isofhlevel (S n) T. Proof. revert T is. induction n as [ | n IHn ]. - intro. apply isapropifcontr. - intro. intro X. change (∏ t1 t2 : T, isofhlevel (S n) (t1 = t2)). intros t1 t2. change (∏ t1 t2 : T, isofhlevel n (t1 = t2)) in X. set (XX := X t1 t2). apply (IHn _ XX). Defined. Corollary isofhlevelcontr (n : nat) {X : UU} (is : iscontr X) : isofhlevel n X. Proof. revert X is. induction n as [ | n IHn ]. - intros X X0. assumption. - intros X X0. simpl. intros x x'. assert (is : iscontr (x = x')). apply (isapropifcontr X0 x x'). apply (IHn _ is). Defined. Lemma isofhlevelfweq (n : nat) {X Y : UU} (f : X ≃ Y) : isofhlevelf n f. Proof. unfold isofhlevelf. intro y. apply (isofhlevelcontr n). apply (pr2 f). Defined. Corollary isweqfinfibseq {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) (isz : iscontr Z) : isweq f. Proof. intros. apply (isofhlevelfffromZ 0 f g z fs (isapropifcontr isz)). Defined. Corollary weqhfibertocontr {X Y : UU} (f : X -> Y) (y : Y) (is : iscontr Y) : weq (hfiber f y) X. Proof. intros. split with (hfiberpr1 f y). apply (isofhlevelfhfiberpr1 0 f y (hlevelntosn 0 _ is)). Defined. Corollary weqhfibertounit (X : UU) : (hfiber (λ x : X, tt) tt) ≃ X. Proof. apply (weqhfibertocontr _ tt iscontrunit). Defined. Corollary isofhleveltofun (n : nat) (X : UU) : isofhlevel n X -> isofhlevelf n (λ x : X, tt). Proof. intros is. intro t. induction t. apply (isofhlevelweqb n (weqhfibertounit X) is). Defined. Corollary isofhlevelfromfun (n : nat) (X : UU) : isofhlevelf n (λ x : X, tt) -> isofhlevel n X. Proof. intros is. apply (isofhlevelweqf n (weqhfibertounit X) (is tt)). Defined. Definition weqhfiberunit {X Z : UU} (i : X -> Z) (z : Z) : (∑ x, hfiber (λ _ : unit, z) (i x)) ≃ hfiber i z. Proof. intros. use weq_iso. + intros [x [t e]]. exact (x,,!e). + intros [x e]. exact (x,,tt,,!e). + intros [x [t e]]. apply maponpaths. simple refine (two_arg_paths_f _ _). * apply isapropunit. * simpl. induction e. rewrite pathsinv0inv0. induction t. apply idpath. + intros [x e]. apply maponpaths. apply pathsinv0inv0. Defined. Lemma isofhlevelsnprop (n : nat) {X : UU} (is : isaprop X) : isofhlevel (S n) X. Proof. simpl. unfold isaprop in is. simpl in is. intros x x'. apply isofhlevelcontr. apply (is x x'). Defined. (** A proposition that is inhabited is contractible. *) Lemma iscontraprop1 {X : UU} (is : isaprop X) (x : X) : iscontr X. Proof. intros. unfold iscontr. split with x. intro t. unfold isofhlevel in is. set (is' := is t x). apply (pr1 is'). Defined. Lemma iscontraprop1inv {X : UU} (f : X -> iscontr X) : isaprop X. Proof. apply (isofhlevelsn O). intro x. exact (hlevelntosn O X (f x)). Defined. Definition isProofIrrelevant (X:UU) := ∏ x y:X, x = y. Lemma proofirrelevance (X : UU) : isaprop X -> isProofIrrelevant X. Proof. intros is x x'. unfold isaprop in is. unfold isofhlevel in is. exact (iscontrpr1 (is x x')). Defined. Lemma invproofirrelevance (X : UU) : isProofIrrelevant X -> isaprop X. Proof. intros ee x x'. apply isapropifcontr. exists x. intros t. exact (ee t x). Defined. Lemma isProofIrrelevant_paths {X} (irr:isProofIrrelevant X) {x y:X} : isProofIrrelevant (x=y). Proof. intros p q. assert (r := invproofirrelevance X irr x y). exact (pr2 r p @ ! pr2 r q). Defined. Lemma isapropcoprod (P Q : UU) : isaprop P -> isaprop Q -> (P -> Q -> ∅) -> isaprop (P ⨿ Q). Proof. intros i j n. apply invproofirrelevance. intros a b. apply inv_equality_by_case. induction a as [a|a]. - induction b as [b|b]. + apply i. + contradicts (n a) b. - induction b as [b|b]. + contradicts (n b) a. + apply j. Defined. Lemma isweqimplimpl {X Y : UU} (f : X -> Y) (g : Y -> X) (isx : isaprop X) (isy : isaprop Y) : isweq f. Proof. intros. assert (isx0: ∏ x : X, paths (g (f x)) x) by (intro; apply proofirrelevance; apply isx). assert (isy0 : ∏ y : Y, paths (f (g y)) y) by (intro; apply proofirrelevance; apply isy). apply (isweq_iso f g isx0 isy0). Defined. Definition weqimplimpl {X Y : UU} (f : X -> Y) (g : Y -> X) (isx : isaprop X) (isy : isaprop Y) := make_weq _ (isweqimplimpl f g isx isy). Definition weqiff {X Y : UU} : (X <-> Y) -> isaprop X -> isaprop Y -> X ≃ Y := λ f i j, make_weq _ (isweqimplimpl (pr1 f) (pr2 f) i j). Definition weq_to_iff {X Y : UU} : X ≃ Y -> (X <-> Y) := λ f, (pr1weq f ,, invmap f). Theorem isapropempty: isaprop empty. Proof. unfold isaprop. unfold isofhlevel. intros x x'. induction x. Defined. Theorem isapropifnegtrue {X : UU} (a : X -> empty) : isaprop X. Proof. intros. set (w := make_weq _ (isweqtoempty a)). apply (isofhlevelweqb 1 w isapropempty). Defined. Lemma isapropretract {P Q : UU} (i : isaprop Q) (f : P -> Q) (g : Q -> P) (h : g ∘ f ~ idfun _) : isaprop P. Proof. intros. apply invproofirrelevance; intros p p'. refine (_ @ (_ : g (f p) = g (f p')) @ _). - apply pathsinv0. apply h. - apply maponpaths. apply proofirrelevance. exact i. - apply h. Defined. Lemma isapropcomponent1 (P Q : UU) : isaprop (P ⨿ Q) -> isaprop P. Proof. (* see also [isofhlevelsnsummand1] *) intros i. apply invproofirrelevance; intros p p'. exact (equality_by_case (proofirrelevance _ i (ii1 p) (ii1 p'))). Defined. Lemma isapropcomponent2 (P Q : UU) : isaprop (P ⨿ Q) -> isaprop Q. Proof. (* see also [isofhlevelsnsummand2] *) intros i. apply invproofirrelevance; intros q q'. exact (equality_by_case (proofirrelevance _ i (ii2 q) (ii2 q'))). Defined. (** *** Inclusions - functions of h-level 1 *) Definition isincl {X Y : UU} (f : X -> Y) := isofhlevelf 1 f. Definition incl (X Y : UU) := total2 (fun f : X -> Y => isincl f). Definition make_incl {X Y : UU} (f : X -> Y) (is : isincl f) : incl X Y := tpair _ f is. Definition pr1incl (X Y : UU) : incl X Y -> (X -> Y) := @pr1 _ _. Coercion pr1incl : incl >-> Funclass. Lemma isinclweq (X Y : UU) (f : X -> Y) : isweq f -> isincl f. Proof. intros is. apply (isofhlevelfweq 1 (make_weq _ is)). Defined. Coercion isinclweq : isweq >-> isincl. Lemma isofhlevelfsnincl (n : nat) {X Y : UU} (f : X -> Y) (is : isincl f) : isofhlevelf (S n) f. Proof. intros. unfold isofhlevelf. intro y. apply isofhlevelsnprop. apply (is y). Defined. Definition weqtoincl {X Y : UU} : X ≃ Y -> incl X Y := λ w, make_incl (pr1weq w) (pr2 w). Lemma isinclcomp {X Y Z : UU} (f : incl X Y) (g : incl Y Z) : isincl (funcomp (pr1 f) (pr1 g)). Proof. intros. apply (isofhlevelfgf 1 f g (pr2 f) (pr2 g)). Defined. Definition inclcomp {X Y Z : UU} (f : incl X Y) (g : incl Y Z) : incl X Z := make_incl (funcomp (pr1 f) (pr1 g)) (isinclcomp f g). Lemma isincltwooutof3a {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isg : isincl g) (isgf : isincl (funcomp f g)) : isincl f. Proof. intros. apply (isofhlevelff 1 f g isgf). apply (isofhlevelfsnincl 1 g isg). Defined. Lemma isinclgwtog {X Y Z : UU} (w : X ≃ Y) (g : Y -> Z) (is : isincl (funcomp w g)) : isincl g. Proof. intros. apply (isofhlevelfgwtog 1 w g is). Defined. Lemma isinclgtogw {X Y Z : UU} (w : X ≃ Y) (g : Y -> Z) (is : isincl g) : isincl (funcomp w g). Proof. intros. apply (isofhlevelfgtogw 1 w g is). Defined. Lemma isinclhomot {X Y : UU} (f g : X -> Y) (h : homot f g) (isf : isincl f) : isincl g. Proof. intros. apply (isofhlevelfhomot (S O) f g h isf). Defined. Definition isofhlevelsninclb (n : nat) {X Y : UU} (f : X -> Y) (is : isincl f) : isofhlevel (S n) Y -> isofhlevel (S n) X := isofhlevelXfromfY (S n) f (isofhlevelfsnincl n f is). Definition isapropinclb {X Y : UU} (f : X -> Y) (isf : isincl f) : isaprop Y -> isaprop X := isofhlevelXfromfY 1 _ isf. Lemma iscontrhfiberofincl {X Y : UU} (f : X -> Y) : isincl f -> (∏ x : X, iscontr (hfiber f (f x))). Proof. intros X0 x. unfold isofhlevelf in X0. set (isy := X0 (f x)). apply (iscontraprop1 isy (make_hfiber f _ (idpath (f x)))). Defined. (* see incl_injectivity for the equivalence between isincl and isInjective *) Definition isInjective {X Y : UU} (f : X -> Y) := ∏ (x x' : X), isweq (maponpaths f : x = x' -> f x = f x'). Definition Injectivity {X Y : UU} (f : X -> Y) : isInjective f -> ∏ (x x' : X), x = x' ≃ f x = f x'. Proof. intros i ? ?. exact (make_weq _ (i x x')). Defined. Lemma isweqonpathsincl {X Y : UU} (f : X -> Y) : isincl f -> isInjective f. Proof. intros is x x'. apply (isofhlevelfonpaths O f x x' is). Defined. Definition weqonpathsincl {X Y : UU} (f : X -> Y) (is : isincl f) (x x' : X) := make_weq _ (isweqonpathsincl f is x x'). Definition invmaponpathsincl {X Y : UU} (f : X -> Y) : isincl f -> ∏ x x', f x = f x' -> x = x'. Proof. intros is x x'. exact (invmap (weqonpathsincl f is x x')). Defined. Lemma isinclweqonpaths {X Y : UU} (f : X -> Y) : isInjective f -> isincl f. Proof. intros X0. apply (isofhlevelfsn O f X0). Defined. Definition isinclpr1 {X : UU} (P : X -> UU) (is : ∏ x : X, isaprop (P x)) : isincl (@pr1 X P):= isofhlevelfpr1 (S O) P is. Theorem subtypeInjectivity {A : UU} (B : A -> UU) : isPredicate B -> ∏ (x y : total2 B), (x = y) ≃ (pr1 x = pr1 y). Proof. intros. apply Injectivity. apply isweqonpathsincl. apply isinclpr1. exact X. Defined. Corollary subtypePath {A : UU} {B : A -> UU} (is : isPredicate B) {s s' : total2 (λ x, B x)} : pr1 s = pr1 s' -> s = s'. Proof. intros e. apply (total2_paths_f e). apply is. Defined. Corollary subtypePath' {A : UU} {B : A -> UU} {s s' : total2 (λ x, B x)} : pr1 s = pr1 s' -> isaprop (B (pr1 s')) -> s = s'. Proof. intros e is. apply (total2_paths_f e). apply is. Defined. (* This corollary of subtypePath is used for categories. *) Corollary unique_exists {A : UU} {B : A -> UU} (x : A) (b : B x) (h : ∏ y, isaprop (B y)) (H : ∏ y, B y -> y = x) : iscontr (total2 (λ t : A, B t)). Proof. use make_iscontr. - exact (x,,b). - intros t. apply subtypePath. + exact h. + apply (H (pr1 t)). exact (pr2 t). Defined. Definition subtypePairEquality {X : UU} {P : X -> UU} (is : isPredicate P) {x y : X} {p : P x} {q : P y} : x = y -> (x,,p) = (y,,q). Proof. intros e. apply (two_arg_paths_f e). apply is. Defined. Definition subtypePairEquality' {X : UU} {P : X -> UU} {x y : X} {p : P x} {q : P y} : x = y -> isaprop(P y) -> (x,,p) = (y,,q). (* This variant of subtypePairEquality is never needed. *) Proof. intros e is. apply (two_arg_paths_f e). apply is. Defined. Theorem samehfibers {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (is1 : isincl g) (y : Y) : hfiber f y ≃ hfiber (g ∘ f) (g y). Proof. intros. exists (hfibersftogf f g (g y) (make_hfiber g y (idpath _))). set (z := g y). set (ye := make_hfiber g y (idpath _)). intro xe. apply (iscontrweqf (X := hfibersgftog f g z xe = ye)). { exists (ezmap _ _ _ (fibseq1 _ _ _ (fibseqhf f g z ye) _)). exact (isweqezmap1 _ _ _ _ _). } apply isapropifcontr. apply iscontrhfiberofincl. exact is1. Defined. (** *** Basics about types of h-level 2 - "sets" *) Definition isaset (X : UU) : UU := ∏ x x' : X, isaprop (x = x'). (* Definition isaset := isofhlevel 2. *) Notation isasetdirprod := (isofhleveldirprod 2). Lemma isasetunit : isaset unit. Proof. apply (isofhlevelcontr 2 iscontrunit). Defined. Lemma isasetempty : isaset empty. Proof. apply (isofhlevelsnprop 1 isapropempty). Defined. Lemma isasetifcontr {X : UU} (is : iscontr X) : isaset X. Proof. intros. apply (isofhlevelcontr 2 is). Defined. Lemma isasetaprop {X : UU} (is : isaprop X) : isaset X. Proof. intros. apply (isofhlevelsnprop 1 is). Defined. Corollary isaset_total2 {X : UU} (P : X->UU) : isaset X -> (∏ x, isaset (P x)) -> isaset (∑ x, P x). Proof. intros. apply (isofhleveltotal2 2); assumption. Defined. Corollary isaset_dirprod {X Y : UU} : isaset X -> isaset Y -> isaset (X × Y). Proof. intros. apply isaset_total2. assumption. intro. assumption. Defined. Corollary isaset_hfiber {X Y : UU} (f : X -> Y) (y : Y) : isaset X -> isaset Y -> isaset (hfiber f y). Proof. intros isX isY. apply isaset_total2. assumption. intro. apply isasetaprop. apply isY. Defined. (** The following lemma asserts "uniqueness of identity proofs" (uip) for sets. *) Lemma uip {X : UU} (is : isaset X) {x x' : X} (e e' : x = x') : e = e'. Proof. intros. apply (proofirrelevance _ (is x x') e e'). Defined. (** For the theorem about the coproduct of two sets see [ isasetcoprod ] below. *) Lemma isofhlevelssnset (n : nat) (X : UU) (is : isaset X) : isofhlevel (S (S n)) X. Proof. simpl. unfold isaset in is. intros x x'. apply isofhlevelsnprop. exact (is x x'). Defined. Lemma isasetifiscontrloops (X : UU) : (∏ x : X, iscontr (x = x)) -> isaset X. Proof. intros X0. unfold isaset. unfold isofhlevel. intros x x' x0 x0'. induction x0. apply isapropifcontr. exact (X0 x). Defined. Lemma iscontrloopsifisaset (X : UU) : (isaset X) -> (∏ x : X, iscontr (x = x)). Proof. intros X0 x. unfold isaset in X0. unfold isofhlevel in X0. change (∏ (x x' : X) (x0 x'0 : x = x'), iscontr (x0 = x'0)) with (∏ (x x' : X), isaprop (x = x')) in X0. apply (iscontraprop1 (X0 x x) (idpath x)). Defined. (** A monic subtype of a set is a set. *) Theorem isasetsubset {X Y : UU} (f : X -> Y) (is1 : isaset Y) (is2 : isincl f) : isaset X. Proof. intros. apply (isofhlevelsninclb (S O) f is2). apply is1. Defined. (** The morphism from hfiber of a map to a set is an inclusion. *) Theorem isinclfromhfiber {X Y : UU} (f: X -> Y) (is : isaset Y) (y : Y) : @isincl (hfiber f y) X (@pr1 _ _). Proof. intros. refine (isofhlevelfhfiberpr1 _ _ _ _). assumption. Defined. (** Criterion for a function between sets being an inclusion. *) Theorem isinclbetweensets {X Y : UU} (f : X -> Y) (isx : isaset X) (isy : isaset Y) (inj : ∏ x x' : X , (paths (f x) (f x') -> x = x')) : isincl f. Proof. intros. apply isinclweqonpaths. intros x x'. apply (isweqimplimpl (@maponpaths _ _ f x x') (inj x x') (isx x x') (isy (f x) (f x'))). Defined. (** A map from [ unit ] to a set is an inclusion. *) Theorem isinclfromunit {X : UU} (f : unit -> X) (is : isaset X) : isincl f. Proof. intros. apply (isinclbetweensets f (isofhlevelcontr 2 (iscontrunit)) is). intros. induction x. induction x'. apply idpath. Defined. Corollary set_bijection_to_weq {X Y : UU} (f : X -> Y) : UniqueConstruction f -> isaset Y -> isweq f. Proof. (* compare with bijection_to_weq: this one doesn't use isweq_iso *) intros bij i y. set (sur := pr1 bij); set (inj := pr2 bij). use tpair. - exists (pr1 (sur y)). exact (pr2 (sur y)). - intro w. use total2_paths_f. + simpl. apply inj. intermediate_path y. * exact (pr2 w). * exact (! pr2 (sur y)). + induction w as [x e]; simpl. induction e. apply i. Defined. (** Complementary types *) Definition complementary P Q := (P -> Q -> ∅) × (P ⨿ Q). Definition complementary_to_neg_iff {P Q} : complementary P Q -> ¬P <-> Q. Proof. intros c. induction c as [n c]. split. - intro np. induction c as [p|q]. * contradicts p np. * exact q. - intro q. induction c as [p|_]. * intros _. exact (n p q). * intros p. exact (n p q). Defined. Definition decidable (X:UU) := X ⨿ ¬X. Definition decidable_to_complementary {X} : decidable X -> complementary X (¬X). Proof. intros d. split. - intros x n. exact (n x). - exact d. Defined. Definition decidable_dirprod (X Y : UU) : decidable X -> decidable Y -> decidable (X × Y). Proof. intros b c. induction b as [b|b']. - induction c as [c|c']. + apply ii1. exact (b,,c). + apply ii2. clear b. intro k. apply c'. exact (pr2 k). - clear c. apply ii2. intro k. apply b'. exact (pr1 k). Defined. (** *** Decidable propositions [ isdecprop ] *) Definition isdecprop (P:UU) := (P ⨿ ¬P) × isaprop P. Definition isdecproptoisaprop ( X : UU ) ( is : isdecprop X ) : isaprop X := pr2 is. Coercion isdecproptoisaprop : isdecprop >-> isaprop . Lemma isdecpropif ( X : UU ) : isaprop X -> X ⨿ ¬ X -> isdecprop X. Proof. intros i c. exact (c,,i). Defined. Lemma isdecpropfromiscontr {P} : iscontr P -> isdecprop P. Proof. intros i. split. - exact (ii1 (iscontrpr1 i)). - apply isapropifcontr. assumption. Defined. Lemma isdecpropempty : isdecprop ∅. Proof. unfold isdecprop. split. - exact (ii2 (idfun ∅)). - exact isapropempty. Defined. Lemma isdecpropweqf {X Y} : X≃Y -> isdecprop X -> isdecprop Y. Proof. intros w i. unfold isdecprop in *. induction i as [xnx i]. split. - clear i. induction xnx as [x|nx]. * apply ii1. apply w. assumption. * apply ii2. intro x'. apply nx. apply (invmap w). assumption. - apply (isofhlevelweqf 1 (X:=X)). { exact w. } { exact i. } Defined. Lemma isdecpropweqb {X Y} : X≃Y -> isdecprop Y -> isdecprop X. Proof. intros w i. unfold isdecprop in *. induction i as [yny i]. split. - clear i. induction yny as [y|ny]. * apply ii1. apply (invmap w). assumption. * apply ii2. intro x. apply ny. apply w. assumption. - apply (isofhlevelweqb 1 (Y:=Y)). { exact w. } { exact i. } Defined. Lemma isdecproplogeqf {X Y : UU} (isx : isdecprop X) (isy : isaprop Y) (lg : X <-> Y) : isdecprop Y. Proof. intros. set (w := weqimplimpl (pr1 lg) (pr2 lg) isx isy). apply (isdecpropweqf w isx). Defined. Lemma isdecproplogeqb {X Y : UU} (isx : isaprop X) (isy : isdecprop Y) (lg : X <-> Y) : isdecprop X. Proof. intros. set (w := weqimplimpl (pr1 lg) (pr2 lg) isx isy). apply (isdecpropweqb w isy). Defined. Lemma isdecpropfromneg {P : UU} : ¬P -> isdecprop P. Proof. intros n. split. - exact (ii2 n). - apply isapropifnegtrue. assumption. Defined. (** *** Types with decidable equality *) Definition isdeceq (X:UU) : UU := ∏ (x x':X), decidable (x=x'). Lemma isdeceqweqf {X Y : UU} (w : X ≃ Y) (is : isdeceq X) : isdeceq Y. Proof. intros. intros y y'. set (w' := weqonpaths (invweq w) y y'). set (int := is ((invweq w) y) ((invweq w) y')). induction int as [ i | ni ]. - apply (ii1 ((invweq w') i)). - apply (ii2 ((negf w') ni)). Defined. Lemma isdeceqweqb {X Y : UU} (w : X ≃ Y) (is : isdeceq Y) : isdeceq X. Proof. intros. apply (isdeceqweqf (invweq w) is). Defined. Theorem isdeceqinclb {X Y : UU} (f : X -> Y) (is : isdeceq Y) (is' : isincl f) : isdeceq X. Proof. intros. intros x x'. set (w := weqonpathsincl f is' x x'). set (int := is (f x) (f x')). induction int as [ i | ni ]. - apply (ii1 ((invweq w) i)). - apply (ii2 ((negf w) ni)). Defined. Lemma isdeceqifisaprop (X : UU) : isaprop X -> isdeceq X. Proof. intros is x x'. apply (ii1 (proofirrelevance _ is x x')). Defined. Definition booleq {X : UU} (is : isdeceq X) (x x' : X) : bool. Proof. intros. induction (is x x'). apply true. apply false. Defined. Lemma eqfromdnegeq (X : UU) (is : isdeceq X) (x x' : X) : dneg (x = x') -> x = x'. Proof. intros X0. induction (is x x') as [ y | n ]. - assumption. - induction (X0 n). Defined. Lemma isdecequnit : isdeceq unit. Proof. apply (isdeceqifisaprop _ isapropunit). Defined. Theorem isdeceqbool: isdeceq bool. Proof. unfold isdeceq. intros x' x. induction x. - induction x'. + apply (ii1 (idpath true)). + apply (ii2 nopathsfalsetotrue). - induction x'. + apply (ii2 nopathstruetofalse). + apply (ii1 (idpath false)). Defined. Lemma isdeceqcoprod {A B : UU} (h1 : isdeceq A) (h2 : isdeceq B) : isdeceq (A ⨿ B). Proof. intros ab ab'. induction ab as [a|b]; induction ab' as [a'|b']. - induction (h1 a a') as [p|p]. + apply inl, (maponpaths (@ii1 A B) p). + apply inr; intro H; apply (p (ii1_injectivity _ _ H)). - apply inr, negpathsii1ii2. - apply inr, negpathsii2ii1. - induction (h2 b b') as [p|p]. + apply inl, (maponpaths (@ii2 A B) p). + apply inr; intro H; apply (p (ii2_injectivity _ _ H)). Defined. (** *** Isolated points *) Definition isisolated (X:UU) (x:X) := ∏ x':X, (x = x') ⨿ (x != x'). Definition isolated ( T : UU ) := ∑ t:T, isisolated _ t. Definition make_isolated ( T : UU ) (t:T) (i:isisolated _ t) : isolated T := (t,,i). Definition pr1isolated ( T : UU ) (x:isolated T) : T := pr1 x. Theorem isaproppathsfromisolated (X : UU) (x : X) (is : isisolated X x) : ∏ x', isaprop(x = x'). Proof. intros. apply iscontraprop1inv. intro e. induction e. set (f := λ e : x = x, coconusfromtpair _ e). assert (is' : isweq f) by apply (onefiber (λ x' : X, x = x') (x : X) (λ x' : X, is x')). assert (is2 : iscontr (coconusfromt _ x)) by apply iscontrcoconusfromt. apply (iscontrweqb (make_weq f is')). assumption. Defined. Local Open Scope transport. Theorem isaproppathstoisolated (X : UU) (x : X) (is : isisolated X x) : ∏ x' : X, isaprop (x' = x). Proof. intros. apply (isofhlevelweqf 1 (weqpathsinv0 x x') (isaproppathsfromisolated X x is x')). Defined. Lemma isisolatedweqf { X Y : UU } (f : X ≃ Y) (x:X) : isisolated X x -> isisolated Y (f x). Proof. intros is. unfold isisolated. intro y. induction (is (invmap f y)) as [ eq | ne ]. { apply ii1. apply pathsweq1'. assumption. } { apply ii2. intro eq. apply ne; clear ne. apply pathsweq1. assumption. } Defined. Theorem isisolatedinclb {X Y : UU} (f : X -> Y) (is : isincl f) (x : X) (is0 : isisolated _ (f x)) : isisolated _ x. Proof. intros. unfold isisolated. intro x'. set (a := is0 (f x')). induction a as [ a1 | a2 ]. apply (ii1 (invmaponpathsincl f is _ _ a1)). apply (ii2 ((negf (@maponpaths _ _ f _ _)) a2)). Defined. Lemma disjointl1 (X : UU) : isisolated (coprod X unit) (ii2 tt). Proof. intros. unfold isisolated. intros x'. induction x' as [ x | u ]. apply (ii2 (negpathsii2ii1 x tt)). induction u. apply (ii1 (idpath _)). Defined. (** *** Decidable types are sets *) Theorem isasetifdeceq (X : UU) : isdeceq X -> isaset X. Proof. intros is x x'. apply (isaproppathsfromisolated X x (is x)). Defined. (** *** Decidable equality on a sigma type *) Lemma isdeceq_total2 {X : UU} {P : X -> UU} : isdeceq X -> (∏ x : X, isdeceq (P x)) → isdeceq (∑ x : X, P x). Proof. intros HX HP. intros xp yq. induction (HX (pr1 xp) (pr1 yq)) as [e_xy | ne_xy]. - induction ((HP _) (transportf _ e_xy (pr2 xp)) (pr2 yq)) as [e_pq | ne_pq]. + apply inl. exact (total2_paths_f e_xy e_pq). + apply inr. intro e_xpyq. apply ne_pq. set (e_pq := fiber_paths e_xpyq). refine (_ @ e_pq). refine (maponpaths (λ e, transportf _ e _) _). (* NOTE: want [maponpaths_2] from the [TypeTheory] library here. Upstream it to [Foundations], perhaps? *) apply isasetifdeceq, HX. - apply inr. intros e_xypq. apply ne_xy, base_paths, e_xypq. Defined. (** *** Construction of functions with specified values at a few isolated points *) Definition isolfun1 {X Y:UU} (x1:X) (i1 : isisolated _ x1) (y1 y':Y) : X → Y. Proof. intros x. induction (i1 x). - exact y1. - exact y'. Defined. Definition decfun1 {X Y:UU} (i : isdeceq X) (x1:X) : ∏ (y1 y':Y), X → Y. Proof. exact (isolfun1 x1 (i x1)). Defined. Definition isolfun2 {X Y:UU} (x1 x2:X) (i1 : isisolated _ x1) (i2 : isisolated _ x2) (y1 y2 y':Y) : X → Y. Proof. intros x. induction (i1 x). - exact y1. - induction (i2 x). + exact y2. + exact y'. Defined. Definition decfun2 {X Y:UU} (i : isdeceq X) (x1 x2:X) (y1 y2 y':Y) : X → Y. Proof. revert y1 y2 y'. exact (isolfun2 x1 x2 (i x1) (i x2)). Defined. Definition isolfun3 {X Y:UU} (x1 x2 x3:X) (i1 : isisolated _ x1) (i2 : isisolated _ x2) (i3 : isisolated _ x3) (y1 y2 y3 y':Y) : X → Y. Proof. intros x. induction (i1 x). - exact y1. - induction (i2 x). + exact y2. + induction (i3 x). * exact y3. * exact y'. Defined. Definition decfun3 {X Y:UU} (i : isdeceq X) (x1 x2 x3:X) (y1 y2 y3 y':Y) : X → Y. revert y1 y2 y3 y'. exact (isolfun3 x1 x2 x3 (i x1) (i x2) (i x3)). Defined. (** **** [ bool ] is a set *) Theorem isasetbool: isaset bool. Proof. apply (isasetifdeceq _ isdeceqbool). Defined. (** ** Splitting of [ X ] into a coproduct defined by a function [ X -> bool ] *) Definition subsetsplit {X : UU} (f : X -> bool) (x : X) : (hfiber f true) ⨿ (hfiber f false). Proof. intros. induction (boolchoice (f x)) as [ a | b ]. - apply (ii1 (make_hfiber f x a)). - apply (ii2 (make_hfiber f x b)). Defined. Definition subsetsplitinv {X : UU} (f : X -> bool) (ab : (hfiber f true) ⨿ (hfiber f false)) : X := match ab with ii1 xt => pr1 xt | ii2 xf => pr1 xf end. Theorem weqsubsetsplit {X : UU} (f : X -> bool) : weq X ((hfiber f true) ⨿ (hfiber f false)). Proof. intros. set (ff := subsetsplit f). set (gg := subsetsplitinv f). split with ff. assert (egf : ∏ a : _, paths (gg (ff a)) a). { intros. unfold ff. unfold subsetsplit. induction (boolchoice (f a)) as [ et | ef ]. simpl. apply idpath. simpl. apply idpath. } assert (efg : ∏ a : _, paths (ff (gg a)) a). { intros. induction a as [ et | ef ]. - induction et as [ x et' ]. simpl. unfold ff. unfold subsetsplit. induction (boolchoice (f x)) as [ e1 | e2 ]. + apply (maponpaths (@ii1 _ _ )). apply (maponpaths (make_hfiber f x)). apply uip. apply isasetbool. + induction (nopathstruetofalse (pathscomp0 (pathsinv0 et') e2)). - induction ef as [ x et' ]. simpl. unfold ff. unfold subsetsplit. induction (boolchoice (f x)) as [ e1 | e2 ]. + induction (nopathsfalsetotrue (pathscomp0 (pathsinv0 et') e1)). + apply (maponpaths (@ii2 _ _ )). apply (maponpaths (make_hfiber f x)). apply uip. apply isasetbool. } apply (isweq_iso _ _ egf efg). Defined. (* End of file *) UniMath-20231010/UniMath/Foundations/PartC.v000066400000000000000000001263661451125700300203630ustar00rootroot00000000000000(** * Univalent Foundations. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014. The third part of the original uu0 file, created on Dec. 3, 2014. Only one universe is used, and it is never used as a type. The only axiom we use is [ funextemptyAxiom ], which is the functional extensionality axiom for functions with values in the empty type. Any results that don't depend on axioms should be in an earlier file. *) (** ** Contents - More results on propositions - Isolated points and types with decidable equality - Basic results on complements to a point - Basic results on types with an isolated point - Weak equivalences and isolated points - Recomplement on functions - Standard weak equivalences between [compl T t1] and [compl T t2] for isolated t1 and t2 - Transposition of two isolated points - Types with decidable equality - unit - bool - coprod - Splitting of X into a coproduct by X -> bool - Semi-boolean hfiber of functions over isolated points - hfibers of ii1 and ii2 - ii1 and ii2 map isolated points to isolated points - hfibers of coprodf of two functions - Coproduct of two functions of h-level n is of h-level n - h-levels of coproducts and their component types - h-fibers of the sum of two functions sumofmaps f g - The sum of two functions of h-level (S (S n)) is of h-level (S (S n)) - The sum of two functions of h-level n with non-intersecting images is of h-level n - Coproducts and complements - Decidable propositions and decidable inclusions - Decidable propositions - Paths to and from an isolated point form a decidable proposition - Decidable inclusions - Decidable inclusions and isolated points - Decidable inclusions and coprojections *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.PartB. Require Export UniMath.Foundations.UnivalenceAxiom. (** *** More results on propositions *) Theorem isapropneg (X : UU) : isaprop (neg X). Proof. apply invproofirrelevance. intros x x'. apply (funextempty X x x'). Defined. Lemma isaprop_isProofIrrelevant X : isaprop (isProofIrrelevant X). Proof. intros. apply invproofirrelevance. intros i j. apply funextsec; intro x; apply funextsec; intro y. generalize (i x y) as p; generalize (j x y) as q; intros. apply isProofIrrelevant_paths. assumption. Defined. (** See also [ isapropneg2 ] *) Corollary isapropdneg (X : UU) : isaprop (dneg X). Proof. intro. apply (isapropneg (neg X)). Defined. Definition isaninvprop (X : UU) := isweq (todneg X). Definition invimpl (X : UU) (is : isaninvprop X) : (dneg X) -> X := invmap (make_weq (todneg X) is). Lemma isapropaninvprop (X : UU) : isaninvprop X -> isaprop X. Proof. intros X0. apply (isofhlevelweqb (S O) (make_weq (todneg X) X0) (isapropdneg X)). Defined. Theorem isaninvpropneg (X : UU) : isaninvprop (neg X). Proof. intros. set (f := todneg (neg X)). set (g := negf (todneg X)). set (is1 := isapropneg X). set (is2 := isapropneg (dneg X)). apply (isweqimplimpl f g is1 is2). Defined. Theorem isapropdec (X : UU) : isaprop X -> isaprop (decidable X). (* uses [funextemptyAxiom] *) Proof. intros i. apply isapropcoprod. - exact i. - apply isapropneg. - exact (λ x n, n x). Defined. (** ** Isolated points and types with decidable equality. *) (** *** Basic results on complements to a point *) Definition compl (X : UU) (x : X) := ∑ x', x != x'. Definition make_compl (X : UU) (x : X) := tpair (λ x' : X, x != x'). Definition pr1compl (X : UU) (x : X) := @pr1 _ (λ x' : X, x != x'). Lemma isinclpr1compl (X : UU) (x : X) : isincl (pr1compl X x). Proof. intros. apply (isinclpr1 _ (λ x' : X, isapropneg _)). Defined. Definition recompl (X : UU) (x : X) : compl X x ⨿ unit -> X := λ u : _, match u with | ii1 x0 => pr1compl _ _ x0 | ii2 t => x end. Definition maponcomplincl {X Y : UU} (f : X -> Y) (is : isincl f) (x : X) : compl X x -> compl Y (f x) := λ x0' : _, match x0' with tpair _ x' neqx => tpair _ (f x') (negf (invmaponpathsincl _ is x x') neqx) end. Definition weqoncompl {X Y : UU} (w : X ≃ Y) x : compl X x ≃ compl Y (w x). Proof. (* uses [funextemptyAxiom] *) intros. intermediate_weq (∑ x', w x != w x'). - apply weqfibtototal; intro x'. apply weqiff. {apply logeqnegs. apply weq_to_iff. apply weqonpaths. } {apply isapropneg. } {apply isapropneg. } - refine (weqfp _ _). Defined. Definition weqoncompl_compute {X Y : UU} (w : X ≃ Y) (x : X) : ∏ x', pr1 (weqoncompl w x x') = w (pr1 x'). Proof. intros. induction x' as [x' b]. apply idpath. Defined. Definition homotweqoncomplcomp {X Y Z : UU} (f : X ≃ Y) (g : Y ≃ Z) (x : X) : homot (weqcomp (weqoncompl f x) (weqoncompl g (f x))) (weqoncompl (weqcomp f g) x). Proof. intros. intro x'. induction x' as [ x' nexx' ]. apply (invmaponpathsincl _ (isinclpr1compl Z _) _ _). simpl. apply idpath. Defined. (** *** Decomposition of a type with an isolated point into two parts [ weqrecompl ] *) Definition invrecompl (X : UU) (x : X) (is : isisolated X x) : X -> coprod (compl X x) unit := λ x' : X, match (is x') with | ii1 e => ii2 tt | ii2 phi => ii1 (make_compl _ _ x' phi) end. Theorem isweqrecompl (X : UU) (x : X) (is : isisolated X x) : isweq (recompl _ x). Proof. set (f := recompl _ x). set (g := invrecompl X x is). unfold invrecompl in g. simpl in g. assert (efg: ∏ x' : X, paths (f (g x')) x'). { intro. induction (is x') as [ x0 | e ]. - induction x0. unfold f. unfold g. simpl. unfold recompl. simpl. induction (is x) as [ x0 | e ]. + simpl. apply idpath. + induction (e (idpath x)). - unfold f. unfold g. simpl. unfold recompl. simpl. induction (is x') as [ x0 | e0 ]. + induction (e x0). + simpl. apply idpath. } assert (egf : ∏ u : coprod (compl X x) unit, paths (g (f u)) u). { unfold isisolated in is. intro. induction (is (f u)) as [ p | e ]. - induction u as [ c | u]. + simpl. induction c as [ t x0 ]. simpl in p. induction (x0 p). + induction u. assert (e1 : paths (g (f (ii2 tt))) (g x)). apply (maponpaths g p). assert (e2 : paths (g x) (ii2 tt)). { unfold g. induction (is x) as [ i | e ]. apply idpath. induction (e (idpath x)). } apply (pathscomp0 e1 e2). - induction u as [ c | u ]. simpl. induction c as [ t x0 ]. simpl. unfold isisolated in is. unfold g. induction (is t) as [ p | e0 ]. induction (x0 p). simpl in g. unfold f. unfold recompl. simpl in e. assert (ee : e0 = x0) by apply (proofirrelevance _ (isapropneg (x = t))). induction ee. apply idpath. unfold f. unfold g. simpl. induction u. induction (is x). + apply idpath. + induction (e (idpath x)). } apply (isweq_iso f g egf efg). Defined. Definition weqrecompl (X : UU) (x : X) (is : isisolated _ x) : compl X x ⨿ unit ≃ X := make_weq _ (isweqrecompl X x is). (** *** Theorem saying that [ recompl ] commutes up to homotopy with [ maponcomplweq ] *) Theorem homotrecomplnat {X Y : UU} (w : X ≃ Y) (x : X) (a : compl X x ⨿ unit) : recompl Y (w x) (coprodf (weqoncompl w x) (idfun unit) a) = w (recompl X x a). Proof. intros. induction a as [ ane | t ]. induction ane as [ a ne ]. simpl. apply idpath. induction t. simpl. apply idpath. Defined. (** *** Recomplement on functions *) Definition recomplf {X Y : UU} (x : X) (y : Y) (isx : isisolated X x) (f : compl X x -> compl Y y) : X -> Y := funcomp (funcomp (invmap (weqrecompl X x isx)) (coprodf f (idfun unit))) (recompl Y y). Definition weqrecomplf {X Y : UU} (x : X) (y : Y) (isx : isisolated X x) (isy : isisolated Y y) (w : (compl X x) ≃ (compl Y y)) : X ≃ Y := weqcomp (weqcomp (invweq (weqrecompl X x isx)) (weqcoprodf w (idweq unit))) (weqrecompl Y y isy). Definition homotrecomplfhomot {X Y : UU} (x : X) (y : Y) (isx : isisolated X x) (f f' : compl X x -> compl Y y) (h : homot f f') : homot (recomplf x y isx f) (recomplf x y isx f'). Proof. intros. intro a. unfold recomplf. apply (maponpaths (recompl Y y) (homotcoprodfhomot _ _ _ _ h (λ t : unit, idpath t) (invmap (weqrecompl X x isx) a))). Defined. Lemma pathsrecomplfxtoy {X Y : UU} (x : X) (y : Y) (isx : isisolated X x) (f : compl X x -> compl Y y) : (recomplf x y isx f x) = y. Proof. intros. unfold recomplf. unfold weqrecompl. unfold invmap. simpl. unfold invrecompl. induction (isx x) as [ i1 | i2 ]. - simpl. apply idpath. - induction (i2 (idpath _)). Defined. Definition homotrecomplfcomp {X Y Z : UU} (x : X) (y : Y) (z : Z) (isx : isisolated X x) (isy : isisolated Y y) (f : compl X x -> compl Y y) (g : compl Y y -> compl Z z) : homot (funcomp (recomplf x y isx f) (recomplf y z isy g)) (recomplf x z isx (funcomp f g)). Proof. intros. intro x'. unfold recomplf. set (e := homotinvweqweq (weqrecompl Y y isy) (coprodf f (idfun unit) (invmap (weqrecompl X x isx) x'))). simpl in e. simpl. rewrite e. set (e' := homotcoprodfcomp f (idfun unit) g (idfun unit) (invmap (weqrecompl X x isx) x')). simpl in e'. rewrite e'. apply idpath. Defined. Definition homotrecomplfidfun {X : UU} (x : X) (isx : isisolated X x) : homot (recomplf x x isx (idfun (compl X x))) (idfun _). Proof. intros. intro x'. unfold recomplf. unfold weqrecompl. unfold invmap. simpl. unfold invrecompl. induction (isx x') as [ e | ne ]. - simpl. apply e. - simpl. apply idpath. Defined. Lemma ishomotinclrecomplf {X Y : UU} (x : X) (y : Y) (isx : isisolated X x) (f : compl X x -> compl Y y) (x'n : compl X x) (y'n : compl Y y) (e : paths (recomplf x y isx f (pr1 x'n)) (pr1 y'n)) : (f x'n) = y'n. Proof. intros. induction x'n as [ x' nexx' ]. induction y'n as [ y' neyy' ]. simpl in e . apply (invmaponpathsincl _ (isinclpr1compl _ _)). simpl. rewrite (pathsinv0 e). unfold recomplf. unfold invmap. unfold coprodf. simpl. unfold invrecompl. induction (isx x') as [ exx' | nexx'' ]. - induction (nexx' exx'). - simpl. assert (ee : nexx' = nexx''). apply (proofirrelevance _ (isapropneg _)). rewrite ee. apply idpath. Defined. (** *** Equivalence between [ compl T t1 ] and [ compl T t2 ] for isolated [ t1 t2 ] *) Definition funtranspos0 {T: UU} (t1 t2 : T) (is2 : isisolated T t2) (x : compl T t1) : compl T t2 := match (is2 (pr1 x)) with | ii1 e => match (is2 t1) with | ii1 e' => fromempty (pr2 x (pathscomp0 (pathsinv0 e') e)) | ii2 ne' => make_compl T t2 t1 ne' end | ii2 ne => make_compl T t2 (pr1 x) ne end. Definition homottranspos0t2t1t1t2 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : funtranspos0 t2 t1 is1 ∘ funtranspos0 t1 t2 is2 ~ idfun _. Proof. intros. intro x. unfold funtranspos0. simpl. induction x as [ t net1 ]; simpl. induction (is2 t) as [ et2 | net2 ]. - induction (is2 t1) as [ et2t1 | net2t1 ]. + induction (net1 (pathscomp0 (pathsinv0 et2t1) et2)). + simpl. induction (is1 t1) as [ e | ne ]. * induction (is1 t2) as [ et1t2 | net1t2 ]. {induction (net2t1 (pathscomp0 (pathsinv0 et1t2) e)). } {apply (invmaponpathsincl _ (isinclpr1compl _ _)). simpl. exact et2. } * induction (ne (idpath _)). - simpl. induction (is1 t) as [ et1t | net1t ]. + induction (net1 et1t). + apply (invmaponpathsincl _ (isinclpr1compl _ _)). simpl. apply idpath. Defined. Definition weqtranspos0 {T : UU} (t1 t2 : T) : isisolated T t1 -> isisolated T t2 -> compl T t1 ≃ compl T t2. Proof. intros is1 is2. simple refine (weq_iso (funtranspos0 t1 t2 is2) (funtranspos0 t2 t1 is1) _ _). - intro x. apply (homottranspos0t2t1t1t2 t1 t2 is1 is2). - intro x. apply (homottranspos0t2t1t1t2 t2 t1 is2 is1). Defined. (** *** Transposition of two isolated points *) Definition funtranspos {T : UU} (t1 t2 : isolated T) : T -> T := recomplf (pr1 t1) (pr1 t2) (pr2 t1) (funtranspos0 (pr1 t1) (pr1 t2) (pr2 t2)). Definition homottranspost2t1t1t2 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : homot (funcomp (funtranspos (tpair _ t1 is1) (tpair _ t2 is2)) (funtranspos (tpair _ t2 is2) (tpair _ t1 is1))) (idfun _). Proof. intros. intro t. unfold funtranspos. rewrite (homotrecomplfcomp t1 t2 t1 is1 is2 _ _ t). set (e := homotrecomplfhomot t1 t1 is1 _ (idfun _) (homottranspos0t2t1t1t2 t1 t2 is1 is2) t). set (e' := homotrecomplfidfun t1 is1 t). apply (pathscomp0 e e'). Defined. Theorem weqtranspos {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : T ≃ T. Proof. intros. set (f := funtranspos (tpair _ t1 is1) (tpair _ t2 is2)). set (g := funtranspos (tpair _ t2 is2) (tpair _ t1 is1)). split with f. assert (egf : ∏ t : T, paths (g (f t)) t) by (intro; refine (homottranspost2t1t1t2 _ _ _ _ _)). assert (efg : ∏ t : T, paths (f (g t)) t) by (intro; refine (homottranspost2t1t1t2 _ _ _ _ _)). apply (isweq_iso _ _ egf efg). Defined. Lemma pathsfuntransposoft1 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : paths (funtranspos (tpair _ t1 is1) (tpair _ t2 is2) t1) t2. Proof. intros. unfold funtranspos. rewrite (pathsrecomplfxtoy t1 t2 is1 _). apply idpath. Defined. Lemma pathsfuntransposoft2 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : paths (funtranspos (tpair _ t1 is1) (tpair _ t2 is2) t2) t1. Proof. intros. unfold funtranspos. simpl. unfold funtranspos0. unfold recomplf. unfold coprodf. unfold invmap. unfold weqrecompl. unfold recompl. simpl. unfold invrecompl. induction (is1 t2) as [ et1t2 | net1t2 ]. - apply (pathsinv0 et1t2). - simpl. induction (is2 t2) as [ et2t2 | net2t2 ]. + induction (is2 t1) as [ et2t1 | net2t1 ]. * induction (net1t2 (pathscomp0 (pathsinv0 et2t1) et2t2)). * simpl. apply idpath. + induction (net2t2 (idpath _)). Defined. Lemma pathsfuntransposofnet1t2 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) (t : T) (net1t : t1 != t) (net2t : t2 != t) : paths (funtranspos (tpair _ t1 is1) (tpair _ t2 is2) t) t. Proof. intros. unfold funtranspos. simpl. unfold funtranspos0. unfold recomplf. unfold coprodf. unfold invmap. unfold weqrecompl. unfold recompl. simpl. unfold invrecompl. induction (is1 t) as [ et1t | net1t' ]. - induction (net1t et1t). - simpl. induction (is2 t) as [ et2t | net2t' ]. induction (net2t et2t). simpl. apply idpath. Defined. Lemma homotfuntranspos2 {T : UU} (t1 t2 : T) (is1 : isisolated T t1) (is2 : isisolated T t2) : homot (funcomp (funtranspos (tpair _ t1 is1) (tpair _ t2 is2)) (funtranspos (tpair _ t1 is1) (tpair _ t2 is2))) (idfun _). Proof. intros. intro t. simpl. induction (is1 t) as [ et1t | net1t ]. - rewrite (pathsinv0 et1t). rewrite (pathsfuntransposoft1 _ _). rewrite (pathsfuntransposoft2 _ _). apply idpath. - induction (is2 t) as [ et2t | net2t ]. + rewrite (pathsinv0 et2t). rewrite (pathsfuntransposoft2 _ _). rewrite (pathsfuntransposoft1 _ _). apply idpath. + rewrite (pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t). rewrite (pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t). apply idpath. Defined. (** ** Semi-boolean hfiber of functions over isolated points *) Definition eqbx (X : UU) (x : X) (is : isisolated X x) : X -> bool. Proof. intros x'. induction (is x'). apply true. apply false. Defined. Lemma iscontrhfibereqbx (X : UU) (x : X) (is : isisolated X x) : iscontr (hfiber (eqbx X x is) true). Proof. intros. assert (b : (eqbx X x is x) = true). { unfold eqbx. induction (is x) as [ e | ne ]. - apply idpath. - induction (ne (idpath _)). } set (i := make_hfiber (eqbx X x is) x b). split with i. unfold eqbx. induction (boolchoice (eqbx X x is x)) as [ b' | nb' ]. - intro t. induction t as [ x' e ]. assert (e' : x' = x). { induction (is x') as [ ee | nee ]. apply (pathsinv0 ee). induction (nopathsfalsetotrue e) . } apply (invmaponpathsincl _ (isinclfromhfiber (eqbx X x is) isasetbool true) (make_hfiber _ x' e) i e'). - induction (nopathstruetofalse (pathscomp0 (pathsinv0 b) nb')). Defined. Definition bhfiber {X Y : UU} (f : X -> Y) (y : Y) (is : isisolated Y y) := hfiber (λ x : X, eqbx Y y is (f x)) true. Lemma weqhfibertobhfiber {X Y : UU} (f : X -> Y) (y : Y) (is : isisolated Y y) : (hfiber f y) ≃ (bhfiber f y is). Proof. intros. set (g := eqbx Y y is). set (ye := pr1 (iscontrhfibereqbx Y y is)). split with (hfibersftogf f g true ye). apply (isofhlevelfffromZ 0 _ _ ye (fibseqhf f g true ye)). apply (isapropifcontr). apply (iscontrhfibereqbx _ y is). Defined. (** *** h-fibers of [ ii1 ] and [ ii2 ] *) Theorem isinclii1 (X Y : UU) : isincl (@ii1 X Y). Proof. intros. set (f := @ii1 X Y). set (g := coprodtoboolsum X Y). set (gf := λ x : X, (g (f x))). set (gf' := λ x : X, tpair (boolsumfun X Y) true x). assert (h : ∏ x : X, paths (gf' x) (gf x)) by (intro; apply idpath). assert (is1 : isofhlevelf (S O) gf') by apply (isofhlevelfsnfib O (boolsumfun X Y) true (isasetbool true true)). assert (is2 : isofhlevelf (S O) gf) by apply (isofhlevelfhomot (S O) gf' gf h is1). apply (isofhlevelff (S O) _ _ is2 (isofhlevelfweq (S (S O)) (weqcoprodtoboolsum X Y))). Defined. Corollary iscontrhfiberii1x (X Y : UU) (x : X) : iscontr (hfiber (@ii1 X Y) (ii1 x)). Proof. intros. set (xe1 := make_hfiber (@ii1 _ _) x (idpath (@ii1 X Y x))). apply (iscontraprop1 (isinclii1 X Y (ii1 x)) xe1). Defined. Corollary neghfiberii1y (X Y : UU) (y : Y) : neg (hfiber (@ii1 X Y) (ii2 y)). Proof. intros. intro xe. induction xe as [ x e ]. apply (negpathsii1ii2 _ _ e). Defined. Theorem isinclii2 (X Y : UU) : isincl (@ii2 X Y). Proof. intros. set (f := @ii2 X Y). set (g := coprodtoboolsum X Y). set (gf := λ y : Y, (g (f y))). set (gf' := λ y : Y, tpair (boolsumfun X Y) false y). assert (h : ∏ y : Y, paths (gf' y) (gf y)) by (intro; apply idpath). assert (is1 : isofhlevelf (S O) gf') by apply (isofhlevelfsnfib O (boolsumfun X Y) false (isasetbool false false)). assert (is2 : isofhlevelf (S O) gf) by apply (isofhlevelfhomot (S O) gf' gf h is1). apply (isofhlevelff (S O) _ _ is2 (isofhlevelfweq (S (S O)) (weqcoprodtoboolsum X Y))). Defined. Corollary iscontrhfiberii2y (X Y : UU) (y : Y) : iscontr (hfiber (@ii2 X Y) (ii2 y)). Proof. intros. set (xe1 := make_hfiber (@ii2 _ _) y (idpath (@ii2 X Y y))). apply (iscontraprop1 (isinclii2 X Y (ii2 y)) xe1). Defined. Corollary neghfiberii2x (X Y : UU) (x : X) : neg (hfiber (@ii2 X Y) (ii1 x)). Proof. intros. intro ye. induction ye as [ y e ]. apply (negpathsii2ii1 _ _ e). Defined. Lemma negintersectii1ii2 {X Y : UU} (z : coprod X Y) : hfiber (@ii1 X Y) z -> hfiber (@ii2 _ _) z -> empty. Proof. intros X0 X1. induction X0 as [ t x ]. induction X1 as [ t0 x0 ]. set (e := pathscomp0 x (pathsinv0 x0)). apply (negpathsii1ii2 _ _ e). Defined. (** *** [ ii1 ] and [ ii2 ] map isolated points to isolated points *) Lemma isolatedtoisolatedii1 (X Y : UU) (x : X) (is : isisolated _ x) : isisolated (coprod X Y) (ii1 x). Proof. intros. unfold isisolated. intro x'. induction x' as [ x0 | y ]. - induction (is x0) as [ p | e ]. + apply (ii1 (maponpaths (@ii1 X Y) p)). + apply (ii2 (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) _ _) e)). - apply (ii2 (negpathsii1ii2 x y)). Defined. Lemma isolatedtoisolatedii2 (X Y : UU) (y : Y) (is : isisolated _ y) : isisolated (coprod X Y) (ii2 y). Proof. intros. intro x'. induction x' as [ x | y0 ]. - apply (ii2 (negpathsii2ii1 x y)). - induction (is y0) as [ p | e ]. + apply (ii1 (maponpaths (@ii2 X Y) p)). + apply (ii2 (negf (invmaponpathsincl (@ii2 X Y) (isinclii2 X Y) _ _) e)). Defined. (** *** h-fibers of [ coprodf ] of two functions *) Theorem weqhfibercoprodf1 {X Y X' Y' : UU} (f : X -> X') (g : Y -> Y') (x' : X') : weq (hfiber f x') (hfiber (coprodf f g) (ii1 x')). Proof. intros. set (ix := @ii1 X Y). set (ix' := @ii1 X' Y'). set (fpg := coprodf f g). set (fpgix := λ x : X, (fpg (ix x))). assert (w1 : weq (hfiber f x') (hfiber fpgix (ix' x'))) by apply (samehfibers f ix' (isinclii1 _ _) x'). assert (w2 : weq (hfiber fpgix (ix' x')) (hfiber fpg (ix' x'))). { split with (hfibersgftog ix fpg (ix' x')). unfold isweq. intro y. set (u := invezmaphf ix fpg (ix' x') y). assert (is : isweq u) by apply isweqinvezmaphf. apply (iscontrweqb (make_weq u is)). induction y as [ xy e ]. induction xy as [ x0 | y0 ]. - simpl. apply iscontrhfiberofincl. apply (isinclii1 X Y). - apply (fromempty ((negpathsii2ii1 x' (g y0)) e)). } apply (weqcomp w1 w2). Defined. Theorem weqhfibercoprodf2 {X Y X' Y' : UU} (f : X -> X') (g : Y -> Y') (y' : Y') : weq (hfiber g y') (hfiber (coprodf f g) (ii2 y')). Proof. intros. set (iy := @ii2 X Y). set (iy' := @ii2 X' Y'). set (fpg := coprodf f g). set (fpgiy := λ y : Y, (fpg (iy y))). assert (w1 : weq (hfiber g y') (hfiber fpgiy (iy' y'))) by apply (samehfibers g iy' (isinclii2 _ _) y'). assert (w2 : weq (hfiber fpgiy (iy' y')) (hfiber fpg (iy' y'))). { split with (hfibersgftog iy fpg (iy' y')). unfold isweq. intro y. set (u:= invezmaphf iy fpg (iy' y') y). assert (is : isweq u) by apply isweqinvezmaphf. apply (iscontrweqb (make_weq u is)). induction y as [ xy e ]. induction xy as [ x0 | y0 ]. simpl. apply (fromempty ((negpathsii1ii2 (f x0) y') e)). simpl. apply iscontrhfiberofincl. apply (isinclii2 X Y). } apply (weqcomp w1 w2). Defined. (** *** Theorem saying that coproduct of two functions of h-level n is of h-level n *) Theorem isofhlevelfcoprodf (n : nat) {X Y Z T : UU} (f : X -> Z) (g : Y -> T) (is1 : isofhlevelf n f) (is2 : isofhlevelf n g) : isofhlevelf n (coprodf f g). Proof. intros. unfold isofhlevelf. intro y. induction y as [ z | t ]. apply (isofhlevelweqf n (weqhfibercoprodf1 f g z)). apply (is1 z). apply (isofhlevelweqf n (weqhfibercoprodf2 f g t)). apply (is2 t). Defined. (** *** Theorems about h-levels of coproducts and their component types *) Theorem isofhlevelsnsummand1 (n : nat) (X Y : UU) : isofhlevel (S n) (coprod X Y) -> isofhlevel (S n) X. Proof. intros is. apply (isofhlevelXfromfY (S n) (@ii1 X Y) (isofhlevelfsnincl n _ (isinclii1 _ _)) is). Defined. Theorem isofhlevelsnsummand2 (n : nat) (X Y : UU) : isofhlevel (S n) (coprod X Y) -> isofhlevel (S n) Y. Proof. intros is. apply (isofhlevelXfromfY (S n) (@ii2 X Y) (isofhlevelfsnincl n _ (isinclii2 _ _)) is). Defined. Theorem isofhlevelssncoprod (n : nat) (X Y : UU) (isx : isofhlevel (S (S n)) X) (isy : isofhlevel (S (S n)) Y) : isofhlevel (S (S n)) (coprod X Y). Proof. intros. apply isofhlevelfromfun. set (f := coprodf (λ x : X, tt) (λ y : Y, tt)). assert (is1 : isofhlevelf (S (S n)) f) by apply (isofhlevelfcoprodf (S (S n)) _ _ (isofhleveltofun _ X isx) (isofhleveltofun _ Y isy)). assert (is2 : isofhlevel (S (S n)) (coprod unit unit)) by apply (isofhlevelweqb (S (S n)) boolascoprod (isofhlevelssnset n _ (isasetbool))). apply (isofhlevelfgf (S (S n)) _ _ is1 (isofhleveltofun _ _ is2)). Defined. Lemma isasetcoprod (X Y : UU) (isx : isaset X) (isy : isaset Y) : isaset (coprod X Y). Proof. intros. apply (isofhlevelssncoprod 0 _ _ isx isy). Defined. (** *** h-fibers of the sum of two functions [ sumofmaps f g ] *) Lemma coprodofhfiberstohfiber {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (z : Z) : (hfiber f z) ⨿ (hfiber g z) -> hfiber (sumofmaps f g) z. Proof. intros hfg. induction hfg as [ hf | hg ]. - induction hf as [ x fe ]. split with (ii1 x). simpl. assumption. - induction hg as [ y ge ]. split with (ii2 y). simpl. assumption. Defined. Lemma hfibertocoprodofhfibers {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (z : Z) : hfiber (sumofmaps f g) z -> (hfiber f z) ⨿ (hfiber g z). Proof. intros hsfg. induction hsfg as [ xy e ]. induction xy as [ x | y ]. - simpl in e. apply (ii1 (make_hfiber _ x e)). - simpl in e. apply (ii2 (make_hfiber _ y e)). Defined. Theorem weqhfibersofsumofmaps {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (z : Z) : weq ((hfiber f z) ⨿ (hfiber g z)) (hfiber (sumofmaps f g) z). Proof. intros. set (ff := coprodofhfiberstohfiber f g z). set (gg := hfibertocoprodofhfibers f g z). split with ff. assert (effgg : ∏ hsfg : _, paths (ff (gg hsfg)) hsfg). { intro. induction hsfg as [ xy e ]. induction xy as [ x | y ]. - simpl. apply idpath. - simpl. apply idpath. } assert (eggff : ∏ hfg : _, paths (gg (ff hfg)) hfg). { intro. induction hfg as [ hf | hg ]. induction hf as [ x fe ]. - simpl. apply idpath. - induction hg as [ y ge ]. simpl. apply idpath. } apply (isweq_iso _ _ eggff effgg). Defined. (** *** Theorem saying that the sum of two functions of h-level (S (S n)) is of hlevel (S (S n)) *) Theorem isofhlevelfssnsumofmaps (n : nat) {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (isf : isofhlevelf (S (S n)) f) (isg : isofhlevelf (S (S n)) g) : isofhlevelf (S (S n)) (sumofmaps f g). Proof. intros. intro z. set (w := weqhfibersofsumofmaps f g z). set (is := isofhlevelssncoprod n _ _ (isf z) (isg z)). apply (isofhlevelweqf _ w is). Defined. (** *** The sum of two functions of h-level n with non-intersecting images is of h-level n *) Lemma noil1 {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (noi : ∏ (x : X) (y : Y), neg (paths (f x) (g y))) (z : Z) : hfiber f z -> hfiber g z -> empty. Proof. intros hfz hgz. induction hfz as [ x fe ]. induction hgz as [ y ge ]. apply (noi x y (pathscomp0 fe (pathsinv0 ge))). Defined. Lemma weqhfibernoi1 {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (noi : ∏ (x : X) (y : Y), neg (paths (f x) (g y))) (z : Z) (xe : hfiber f z) : (hfiber (sumofmaps f g) z) ≃ (hfiber f z). Proof. intros. set (w1 := invweq (weqhfibersofsumofmaps f g z)). assert (a : neg (hfiber g z)) by (intro ye; apply (noil1 f g noi z xe ye)). set (w2 := invweq (weqii1withneg (hfiber f z) a)). apply (weqcomp w1 w2). Defined. Lemma weqhfibernoi2 {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (noi : ∏ (x : X) (y : Y), neg (paths (f x) (g y))) (z : Z) (ye : hfiber g z) : (hfiber (sumofmaps f g) z) ≃ (hfiber g z). Proof. intros. set (w1 := invweq (weqhfibersofsumofmaps f g z)). assert (a : neg (hfiber f z)). intro xe. apply (noil1 f g noi z xe ye). set (w2 := invweq (weqii2withneg (hfiber g z) a)). apply (weqcomp w1 w2). Defined. Theorem isofhlevelfsumofmapsnoi (n : nat) {X Y Z : UU} (f : X -> Z) (g : Y -> Z) (isf : isofhlevelf n f) (isg : isofhlevelf n g) (noi : ∏ (x : X) (y : Y), neg (paths (f x) (g y))) : isofhlevelf n (sumofmaps f g). Proof. intros. intro z. induction n as [ | n ]. - set (zinx := invweq (make_weq _ isf) z). set (ziny := invweq (make_weq _ isg) z). assert (ex : (f zinx) = z) by apply (homotweqinvweq (make_weq _ isf) z). assert (ey : (g ziny) = z) by apply (homotweqinvweq (make_weq _ isg) z). induction ((noi zinx ziny) (pathscomp0 ex (pathsinv0 ey))). - apply isofhlevelsn. intro hfgz. induction ((invweq (weqhfibersofsumofmaps f g z) hfgz)) as [ xe | ye ]. + apply (isofhlevelweqb _ (weqhfibernoi1 f g noi z xe) (isf z)). + apply (isofhlevelweqb _ (weqhfibernoi2 f g noi z ye) (isg z)). Defined. (** *** Coproducts and complements *) Definition tocompltoii1x (X Y : UU) (x : X) : coprod (compl X x) Y -> compl (coprod X Y) (ii1 x). Proof. intros X0. induction X0 as [ c | y ]. - split with (ii1 (pr1 c)). assert (e : neg (x = (pr1 c))) by apply (pr2 c). apply (negf (invmaponpathsincl (@ii1 _ _) (isinclii1 X Y) _ _) e). - split with (ii2 y). apply (negf (pathsinv0) (negpathsii2ii1 x y)). Defined. Definition fromcompltoii1x (X Y : UU) (x : X) : compl (coprod X Y) (ii1 x) -> coprod (compl X x) Y. Proof. intros X0. induction X0 as [ t x0 ]. induction t as [ x1 | y ]. - assert (ne : x != x1) by apply (negf (maponpaths (@ii1 _ _)) x0). apply (ii1 (make_compl _ _ x1 ne)). - apply (ii2 y). Defined. Theorem isweqtocompltoii1x (X Y : UU) (x : X) : isweq (tocompltoii1x X Y x). Proof. intros. set (f := tocompltoii1x X Y x). set (g := fromcompltoii1x X Y x). assert (egf : ∏ nexy : _, paths (g (f nexy)) nexy). { intro. induction nexy as [ c | y ]. - induction c as [ t x0 ]. simpl. assert (e : paths (negf (maponpaths (@ii1 X Y)) (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) x t) x0)) x0) by apply (isapropneg (x = t)). apply (maponpaths (fun ee : x != t => ii1 (make_compl X x t ee)) e). - apply idpath. } assert (efg: ∏ neii1x : _, paths (f (g neii1x)) neii1x). { intro. induction neii1x as [ t x0 ]. induction t as [ x1 | y ]. - simpl. assert (e : paths (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) x x1) (negf (maponpaths (@ii1 X Y)) x0)) x0) by apply (isapropneg (paths _ _)). apply (maponpaths (fun ee : (neg (paths (ii1 x) (ii1 x1))) => (make_compl _ _ (ii1 x1) ee)) e). - simpl. assert (e : paths (negf pathsinv0 (negpathsii2ii1 x y)) x0) by apply (isapropneg (paths _ _)). apply (maponpaths (fun ee : (neg (paths (ii1 x) (ii2 y))) => (make_compl _ _ (ii2 y) ee)) e). } apply (isweq_iso f g egf efg). Defined. Definition tocompltoii2y (X Y : UU) (y : Y) : coprod X (compl Y y) -> compl (coprod X Y) (ii2 y). Proof. intros X0. induction X0 as [ x | c ]. - split with (ii1 x). apply (negpathsii2ii1 x y). - split with (ii2 (pr1 c)). assert (e : neg(y = (pr1 c))) by apply (pr2 c). apply (negf (invmaponpathsincl (@ii2 _ _) (isinclii2 X Y) _ _) e). Defined. Definition fromcompltoii2y (X Y : UU) (y : Y) : compl (coprod X Y) (ii2 y) -> coprod X (compl Y y). Proof. intros X0. induction X0 as [ t x ]. induction t as [ x0 | y0 ]. - apply (ii1 x0). - assert (ne : y != y0) by apply (negf (maponpaths (@ii2 _ _)) x). apply (ii2 (make_compl _ _ y0 ne)). Defined. Theorem isweqtocompltoii2y (X Y : UU) (y : Y) : isweq (tocompltoii2y X Y y). Proof. intros. set (f := tocompltoii2y X Y y). set (g := fromcompltoii2y X Y y). assert (egf : ∏ nexy : _, paths (g (f nexy)) nexy). { intro. induction nexy as [ x | c ]. - apply idpath. - induction c as [ t x ]. simpl. assert (e : paths (negf (maponpaths (@ii2 X Y)) (negf (invmaponpathsincl (@ii2 X Y) (isinclii2 X Y) y t) x)) x) by apply (isapropneg (y = t)). apply (maponpaths (fun ee : y != t => ii2 (make_compl _ y t ee)) e). } assert (efg : ∏ neii2x : _, paths (f (g neii2x)) neii2x). { intro. induction neii2x as [ t x ]. induction t as [ x0 | y0 ]. - simpl. assert (e : (negpathsii2ii1 x0 y) = x) by apply (isapropneg (paths _ _)). apply (maponpaths (fun ee : (neg (paths (ii2 y) (ii1 x0))) => (make_compl _ _ (ii1 x0) ee)) e). - simpl. assert (e : paths (negf (invmaponpathsincl _ (isinclii2 X Y) y y0) (negf (maponpaths (@ii2 X Y)) x)) x) by apply (isapropneg (paths _ _)). apply (maponpaths (fun ee : (neg (paths (ii2 y) (ii2 y0))) => (make_compl _ _ (ii2 y0) ee)) e). } apply (isweq_iso f g egf efg). Defined. Definition tocompltodisjoint (X : UU) : X -> compl (coprod X unit) (ii2 tt) := λ x : _, make_compl _ _ (ii1 x) (negpathsii2ii1 x tt). Definition fromcompltodisjoint (X : UU) : compl (coprod X unit) (ii2 tt) -> X. Proof. intros X0. induction X0 as [ t x ]. induction t as [ x0 | u ]. - assumption. - induction u. apply (fromempty (x (idpath (ii2 tt)))). Defined. Lemma isweqtocompltodisjoint (X : UU) : isweq (tocompltodisjoint X). Proof. intros. set (ff := tocompltodisjoint X). set (gg := fromcompltodisjoint X). assert (egf : ∏ x : X, paths (gg (ff x)) x) by (intro; apply idpath). assert (efg : ∏ xx : _, paths (ff (gg xx)) xx). { intro. induction xx as [ t x ]. induction t as [ x0 | u ]. - simpl. unfold ff. unfold tocompltodisjoint. simpl. assert (ee : (negpathsii2ii1 x0 tt) = x) by apply (proofirrelevance _ (isapropneg _)). induction ee. apply idpath. - induction u. simpl. apply (fromempty (x (idpath _))). } apply (isweq_iso ff gg egf efg). Defined. Definition weqtocompltodisjoint (X : UU) : X ≃ compl (X ⨿ unit) (ii2 tt) := make_weq _ (isweqtocompltodisjoint X). Corollary isweqfromcompltodisjoint (X : UU) : isweq (fromcompltodisjoint X). Proof. intros. apply (isweqinvmap (weqtocompltodisjoint X)). Defined. (** ** Decidable propositions and decidable inclusions *) (** *** Decidable propositions [ isdecprop ] *) Lemma isdecpropif' (X : UU) : isaprop X -> X ⨿ ¬ X -> iscontr (X ⨿ ¬ X). (* This contractibility was the old definition of isdecpropif. We can probably do without it. *) Proof. intros is a. assert (is1 : isaprop (coprod X (neg X))) by (apply isapropdec; assumption). apply (iscontraprop1 is1 a). Defined. Lemma isdecproppaths {X : UU} (is : isdeceq X) (x x' : X) : isdecprop (x = x'). Proof. intros. apply (isdecpropif _ (isasetifdeceq _ is x x') (is x x')). Defined. Lemma isdeceqif {X : UU} (is : ∏ x x' : X, isdecprop (x = x')) : isdeceq X. Proof. intros. intros x x'. apply (pr1 (is x x')). Defined. Lemma isaninv1 (X : UU) : isdecprop X -> isaninvprop X. Proof. intros is1. unfold isaninvprop. assert (is2 := pr1 is1); simpl in is2. assert (adjevinv: dneg X -> X). {intro X0. induction is2 as [ a | b ]. - assumption. - contradicts X0 b. } assert (is3: isaprop (dneg X)). {apply (isapropneg (X -> empty)). } apply (isweqimplimpl (todneg X) adjevinv is1 is3). Defined. Theorem isdecpropfibseq1 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) : isdecprop X -> isaprop Z -> isdecprop Y. Proof. intros isx isz. assert (isc : iscontr Z) by apply (iscontraprop1 isz z). assert (X0 : isweq f) by apply (isweqfinfibseq f g z fs isc). apply (isdecpropweqf (make_weq _ X0) isx). Defined. Theorem isdecpropfibseq0 {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (z : Z) (fs : fibseqstr f g z) : isdecprop Y -> isdeceq Z -> isdecprop X. Proof. intros isy isz. assert (isg : isofhlevelf 1 g) by apply (isofhlevelffromXY 1 g (isdecproptoisaprop _ isy) (isasetifdeceq _ isz)). assert (isp : isaprop X) by apply (isofhlevelXfromg 1 f g z fs isg). induction (pr1 isy) as [ y | ny ]. - apply (isdecpropfibseq1 _ _ y (fibseq1 f g z fs y) (isdecproppaths isz (g y) z) (isdecproptoisaprop _ isy)). - apply (isdecpropif _ isp (ii2 (negf f ny))). Defined. Theorem isdecpropdirprod {X Y : UU} (isx : isdecprop X) (isy : isdecprop Y) : isdecprop (X × Y). Proof. intros. assert (isp : isaprop (X × Y)) by apply (isofhleveldirprod 1 _ _ (isdecproptoisaprop _ isx) (isdecproptoisaprop _ isy)). induction (pr1 isx) as [ x | nx ]. - induction (pr1 isy) as [ y | ny ]. + apply (isdecpropif _ isp (ii1 (make_dirprod x y))). + assert (nxy : neg (X × Y)). { intro xy. induction xy as [ x0 y0 ]. apply (ny y0). } apply (isdecpropif _ isp (ii2 nxy)). - assert (nxy : neg (X × Y)). { intro xy. induction xy as [ x0 y0 ]. apply (nx x0). } apply (isdecpropif _ isp (ii2 nxy)). Defined. Lemma fromneganddecx {X Y : UU} : isdecprop X -> ¬ (X × Y) -> ¬X ⨿ ¬Y. Proof. intros isx nf. induction (pr1 isx) as [ x | nx ]. - assert (ny := negf (λ y : Y, make_dirprod x y) nf). exact (ii2 ny). - exact (ii1 nx). Defined. Lemma fromneganddecy {X Y : UU} : isdecprop Y -> ¬ (X × Y) -> ¬X ⨿ ¬Y. Proof. intros isy nf. induction (pr1 isy) as [ y | ny ]. - assert (nx := negf (λ x : X, make_dirprod x y) nf). exact (ii1 nx). - exact (ii2 ny). Defined. (** *** Paths to and from an isolated point form a decidable proposition *) Lemma isdecproppathsfromisolated (X : UU) (x : X) (is : isisolated X x) (x' : X) : isdecprop (x = x'). Proof. intros. apply isdecpropif. - apply isaproppathsfromisolated. assumption. - apply (is x'). Defined. Lemma isdecproppathstoisolated (X : UU) (x : X) (is : isisolated X x) (x' : X) : isdecprop (x' = x). Proof. intros. apply (isdecpropweqf (weqpathsinv0 x x') (isdecproppathsfromisolated X x is x')). Defined. (** *** Decidable inclusions *) Definition isdecincl {X Y : UU} (f : X -> Y) := ∏ y : Y, isdecprop (hfiber f y). Lemma isdecincltoisincl {X Y : UU} (f : X -> Y) : isdecincl f -> isincl f. Proof. intros is y. apply (isdecproptoisaprop _ (is y)). Defined. Coercion isdecincltoisincl : isdecincl >-> isincl. Lemma isdecinclfromisweq {X Y : UU} (f : X -> Y) : isweq f -> isdecincl f. Proof. intros iswf. intro y. apply (isdecpropfromiscontr (iswf y)). Defined. Lemma isdecpropfromdecincl {X Y : UU} (f : X -> Y) : isdecincl f -> isdecprop Y -> isdecprop X. Proof. intros isf isy. induction (pr1 isy) as [ y | n ]. - assert (w : weq (hfiber f y) X) by apply (weqhfibertocontr f y (iscontraprop1 (isdecproptoisaprop _ isy) y)). apply (isdecpropweqf w (isf y)). - apply isdecpropif. apply (isapropinclb _ isf isy). apply (ii2 (negf f n)). Defined. Lemma isdecinclii1 (X Y : UU) : isdecincl (@ii1 X Y). Proof. intros. intro y. induction y as [ x | y ]. - apply (isdecpropif _ (isinclii1 X Y (ii1 x)) (ii1 (make_hfiber (@ii1 _ _) x (idpath _)))). - apply (isdecpropif _ (isinclii1 X Y (ii2 y)) (ii2 (neghfiberii1y X Y y))). Defined. Lemma isdecinclii2 (X Y : UU) : isdecincl (@ii2 X Y). Proof. intros. intro y. induction y as [ x | y ]. - apply (isdecpropif _ (isinclii2 X Y (ii1 x)) (ii2 (neghfiberii2x X Y x))). - apply (isdecpropif _ (isinclii2 X Y (ii2 y)) (ii1 (make_hfiber (@ii2 _ _) y (idpath _)))). Defined. Lemma isdecinclpr1 {X : UU} (P : X -> UU) (is : ∏ x : X, isdecprop (P x)) : isdecincl (@pr1 _ P). Proof. intros. intro x. assert (w : weq (P x) (hfiber (@pr1 _ P) x)) by apply ezweqpr1. apply (isdecpropweqf w (is x)). Defined. Theorem isdecinclhomot {X Y : UU} (f g : X -> Y) (h : ∏ x : X, paths (f x) (g x)) (is : isdecincl f) : isdecincl g. Proof. intros. intro y. apply (isdecpropweqf (weqhfibershomot f g h y) (is y)). Defined. Theorem isdecinclcomp {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isf : isdecincl f) (isg : isdecincl g) : isdecincl (λ x : X, g (f x)). Proof. intros. intro z. set (gf := λ x : X, g (f x)). assert (wy : ∏ ye : hfiber g z, weq (hfiber f (pr1 ye)) (hfiber (hfibersgftog f g z) ye)) by apply ezweqhf. assert (ww : ∏ y : Y, weq (hfiber f y) (hfiber gf (g y))). { intro. apply (samehfibers f g). apply (isdecincltoisincl _ isg). } induction (pr1 (isg z)) as [ ye | nye ]. - induction ye as [ y e ]. induction e. apply (isdecpropweqf (ww y) (isf y)). - assert (wz : (hfiber gf z) ≃ (hfiber g z)). { split with (hfibersgftog f g z). intro ye. induction (nye ye). } apply (isdecpropweqb wz (isg z)). Defined. (** The conditions of the following theorem can be weakened by assuming only that the h-fibers of g satisfy [ isdeceq ] i.e. are "sets with decidable equality". *) Theorem isdecinclf {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isg : isincl g) (isgf : isdecincl (λ x : X, g (f x))) : isdecincl f. Proof. intros. intro y. set (gf := λ x : _, g (f x)). assert (ww : weq (hfiber f y) (hfiber gf (g y))) by (apply (samehfibers f g); assumption). apply (isdecpropweqb ww (isgf (g y))). Defined. (** *) Theorem isdecinclg {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isf : isweq f) (isgf : isdecincl (λ x : X, g (f x))) : isdecincl g. Proof. intros. intro z. set (gf := λ x : X, g (f x)). assert (w : (hfiber gf z) ≃ (hfiber g z)). { split with (hfibersgftog f g z). intro ye. assert (ww : weq (hfiber f (pr1 ye)) (hfiber (hfibersgftog f g z) ye)) by apply ezweqhf. apply (iscontrweqf ww (isf (pr1 ye))). } apply (isdecpropweqf w (isgf z)). Defined. (** *** Decidable inclusions and isolated points *) Theorem isisolateddecinclf {X Y : UU} (f : X -> Y) (x : X) : isdecincl f -> isisolated X x -> isisolated Y (f x). Proof. intros isf isx. assert (is' : ∏ y : Y, isdecincl (d1g f y x)). { intro y. intro xe. set (w := ezweq2g f x xe). apply (isdecpropweqf w (isdecproppathstoisolated X x isx _)). } assert (is'' : ∏ y : Y, isdecprop ((f x) = y)) by (intro; apply (isdecpropfromdecincl _ (is' y) (isf y))). intro y'. apply (pr1 (is'' y')). Defined. (** *** Decidable inclusions and coprojections *) Definition negimage {X Y : UU} (f : X -> Y) : UU := total2 (λ y : Y, neg (hfiber f y)). Definition make_negimage {X Y : UU} (f : X -> Y) : ∏ t : Y, ¬ hfiber f t → ∑ y : Y, ¬ hfiber f y := tpair (λ y : Y, neg (hfiber f y)). Lemma isinclfromcoprodwithnegimage {X Y : UU} (f : X -> Y) (is : isincl f) : isincl (sumofmaps f (@pr1 _ (λ y : Y, neg (hfiber f y)))). Proof. intros. assert (noi : ∏ (x : X) (nx : negimage f), neg (paths (f x) (pr1 nx))). { intros x nx e. induction nx as [ y nhf ]. simpl in e. apply (nhf (make_hfiber _ x e)). } assert (is' : isincl (@pr1 _ (λ y : Y, neg (hfiber f y)))). { apply isinclpr1. intro y. apply isapropneg. } apply (isofhlevelfsumofmapsnoi 1 f _ is is' noi). Defined. Definition iscoproj {X Y : UU} (f : X -> Y) : UU := isweq (sumofmaps f (@pr1 _ (λ y : Y, neg (hfiber f y)))). Definition weqcoproj {X Y : UU} (f : X -> Y) (is : iscoproj f) : weq (coprod X (negimage f)) Y := make_weq _ is. Theorem iscoprojfromisdecincl {X Y : UU} (f : X -> Y) (is : isdecincl f) : iscoproj f. Proof. intros. set (p := sumofmaps f (@pr1 _ (λ y : Y, neg (hfiber f y)))). assert (is' : isincl p). { apply isinclfromcoprodwithnegimage. apply (isdecincltoisincl _ is). } unfold iscoproj. intro y. induction (pr1 (is y)) as [ h | nh ]. - induction h as [ x e ]. induction e. change (f x) with (p (ii1 x)). apply iscontrhfiberofincl. assumption. - change y with (p (ii2 (make_negimage _ y nh))). apply iscontrhfiberofincl. assumption. Defined. Theorem isdecinclfromiscoproj {X Y : UU} (f : X -> Y) (is : iscoproj f) : isdecincl f. Proof. intros. set (g := (sumofmaps f (@pr1 _ (λ y : Y, neg (hfiber f y))))). set (f' := λ x : X, g (ii1 x)). assert (is' : isdecincl f') by apply (isdecinclcomp _ _ (isdecinclii1 _ _) (isdecinclfromisweq _ is)). assumption. Defined. (* End of the file uu0c.v *) UniMath-20231010/UniMath/Foundations/PartD.v000066400000000000000000001125321451125700300203520ustar00rootroot00000000000000(** * Univalent Foundations. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014. The third part of the original uu0 file, created on Dec. 3, 2014. Only one universe is used and never as a type. *) (** ** Contents - Sections of "double fibration" [(P : T -> UU) (PP : ∏ t : T, P t -> UU)] and pairs of sections - General case - Functions on dependent sum (to a [total2]) - Functions to direct product - Homotopy fibers of the map [∏ x : X, P x -> ∏ x : X, Q x] - General case - The weak equivalence between sections spaces (dependent products) defined by a family of weak equivalences [(P x) ≃ (Q x)] - Composition of functions with a weak equaivalence on the right - The map between section spaces (dependent products) defined by the map between the bases [ f : Y -> X ] - General case - Composition of functions with a weak equivalence on the left - Sections of families over an empty type and over coproducts - General case - Functions from the empty type - Functions from a coproduct - Sections of families over contractible types and over [ total2 ] (over dependent sums) - General case - Functions from [unit] and from contractible types - Functions from [total2] - Functiosn from direct product - Theorem saying that if each member of a family is of h-level n then the space of sections of the family is of h-level n. - General case - Functions to a contractible type - Functions to a proposition - Functions to an empty type (generalization of [isapropneg]) - Theorems saying that [ iscontr T ], [ isweq f ] etc. are of h-level 1 - Theorems saying that various [ pr1 ] maps are inclusions - Various weak equivalences between spaces of weak equivalences - Composition with a weak equivalence is a weak equivalence on weak equivalences - Invertion on weak equivalences as a weak equivalence - h-levels of spaces of weak equivalences - Weak equivalences to and from types of h-level (S n) - Weak equivalences to and from contractible types - Weak equivalences to and from propositions - Weak equivalences to and from sets - Weak equivalences to an empty type - Weak equivalences from an empty type - Weak equivalences to and from [unit] - Weak auto-equivalences of a type with an isolated point *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.PartC. (** ** Sections of "double fibration" [(P : T -> UU) (PP : ∏ t : T, P t -> UU)] and pairs of sections *) (** *** General case *) Definition totaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : (∑ (s0 : ∏ x, P x), ∏ x, PP x (s0 x)) -> ∏ x, ∑ p, PP x p. Proof. intros X0 x. exists (pr1 X0 x). apply (pr2 X0 x). Defined. Definition foralltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : (∏ x, ∑ p, PP x p) -> (∑ (s0 : ∏ x, P x), ∏ x, PP x (s0 x)). Proof. intros X0. exists (λ x, pr1 (X0 x)). apply (λ x, pr2 (X0 x)). Defined. Theorem isweqforalltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : isweq (foralltototal P PP). Proof. intros. simple refine (isweq_iso (foralltototal P PP) (totaltoforall P PP) _ _). - apply idpath. - apply idpath. Defined. Theorem isweqtotaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : isweq (totaltoforall P PP). Proof. intros. simple refine (isweq_iso (totaltoforall P PP) (foralltototal P PP) _ _). - apply idpath. - apply idpath. Defined. Definition weqforalltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : (∏ x, ∑ y, PP x y) ≃ (∑ s : (∏ x, P x), (∏ x, PP x (s x))) := make_weq _ (isweqforalltototal P PP). Definition weqtotaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) : (∑ s : (∏ x, P x), (∏ x, PP x (s x))) ≃ (∏ x, ∑ y, PP x y) := invweq (weqforalltototal P PP). (** *** Functions to a dependent sum (to a [ total2 ]) *) Definition weqfuntototaltototal (X : UU) {Y : UU} (Q : Y -> UU) : (X → ∑ y, Q y) ≃ (∑ f : X → Y, ∏ x, Q (f x)) := weqforalltototal (λ x, Y) (λ x, Q). (** *** Functions to direct product *) (** Note: we give direct proofs for this special case. *) Definition funtoprodtoprod {X Y Z : UU} (f : X -> Y × Z) : (X -> Y) × (X -> Z) := make_dirprod (λ x, pr1 (f x)) (λ x, (pr2 (f x))). Definition prodtofuntoprod {X Y Z : UU} (fg : (X -> Y) × (X -> Z)) : X -> Y × Z := λ x, (pr1 fg x ,, pr2 fg x). Theorem weqfuntoprodtoprod (X Y Z : UU) : (X -> Y × Z) ≃ (X -> Y) × (X -> Z). Proof. intros. simple refine (make_weq _ (isweq_iso (@funtoprodtoprod X Y Z) (@prodtofuntoprod X Y Z) _ _)). - intro a. apply funextfun. intro x. apply idpath. - intro a. induction a as [ fy fz ]. apply idpath. Defined. (** ** Homotopy fibers of the map [∏ x, P x -> ∏ x, Q x] *) (** *** General case *) Definition maponsec {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) : (∏ x, P x) -> (∏ x, Q x) := λ (s : ∏ x, P x) (x : X), (f x) (s x). Definition maponsec1 {X Y : UU} (P : Y -> UU) (f : X -> Y) : (∏ y : Y, P y) -> (∏ x, P (f x)) := λ (sy : ∏ y : Y, P y) (x : X), sy (f x). Definition hfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : hfiber (maponsec _ _ f) s -> ∏ x, hfiber (f x) (s x). Proof. unfold hfiber. set (map1 := totalfun (λ (pointover : ∏ x, P x), (λ x, f x (pointover x)) = s) (λ (pointover : ∏ x, P x), ∏ x, (f x) (pointover x) = s x) (λ (pointover : ∏ x, P x), toforallpaths _ (λ x, f x (pointover x)) s)). set (map2 := totaltoforall P (λ x pointover, f x pointover = s x)). exact (map2 ∘ map1). Defined. Definition foralltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : (∏ x, hfiber (f x) (s x)) -> hfiber (maponsec _ _ f) s. Proof. unfold hfiber. set (map2inv := foralltototal P (λ x pointover, f x pointover = s x)). set (map1inv := totalfun (λ pointover, ∏ x, f x (pointover x) = s x) (λ pointover, (λ x, f x (pointover x)) = s) (λ pointover, funextsec _ (λ x, f x (pointover x)) s)). exact (λ a, map1inv (map2inv a)). Defined. Theorem isweqhfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : isweq (hfibertoforall P Q f s). Proof. use twooutof3c. - exact (isweqfibtototal _ _ (λ pointover, weqtoforallpaths _ _ _)). - apply isweqtotaltoforall. Defined. Definition weqhfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : hfiber (maponsec P Q f) s ≃ ∏ x, hfiber (f x) (s x) := make_weq _ (isweqhfibertoforall P Q f s). Theorem isweqforalltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : isweq (foralltohfiber _ _ f s). Proof. use (twooutof3c (Y := @total2 (forall x, P x) (λ (s0 : forall x, P x), forall x, (λ x0 (pointover : P x0), f x0 pointover = s x0) x (s0 x)))). - exact (isweqforalltototal P (λ x, (λ pointover, f x pointover = s x))). - exact (isweqfibtototal _ _ (λ pointover, weqfunextsec _ _ _)). Defined. Definition weqforalltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x) (s : ∏ x, Q x) : (∏ x, hfiber (f x) (s x)) ≃ hfiber (maponsec P Q f) s := make_weq _ (isweqforalltohfiber P Q f s). (** *** The weak equivalence between section spaces (dependent products) defined by a family of weak equivalences [ (P x) ≃ (Q x) ] *) Corollary isweqmaponsec {X : UU} (P Q : X -> UU) (f : ∏ x, (P x) ≃ (Q x)) : isweq (maponsec _ _ f). Proof. intros. unfold isweq. intro y. assert (is1 : iscontr (∏ x, hfiber (f x) (y x))). { assert (is2 : ∏ x, iscontr (hfiber (f x) (y x))) by (intro x; apply ((pr2 (f x)) (y x))). apply funcontr. assumption. } apply (iscontrweqb (weqhfibertoforall P Q f y) is1). Defined. Definition weqonsecfibers {X : UU} (P Q : X -> UU) (f : ∏ x, (P x) ≃ (Q x)) : (∏ x, P x) ≃ (∏ x, Q x) := make_weq _ (isweqmaponsec P Q f). (** *** Composition of functions with a weak equivalence on the right *) Definition weqffun (X : UU) {Y Z : UU} (w : Y ≃ Z) : (X -> Y) ≃ (X -> Z) := weqonsecfibers _ _ (λ x, w). (** ** The map between section spaces (dependent products) defined by the map between the bases [ f : Y -> X ] *) (** *** General case *) Definition maponsec1l0 {X : UU} (P : X -> UU) (f : X -> X) (h : ∏ x, f x = x) : (∏ x, P x) -> (∏ x, P x) := λ s x, transportf P (h x) (s (f x)). Lemma maponsec1l1 {X : UU} (P : X -> UU) (x : X) (s : ∏ x, P x) : maponsec1l0 P (λ x, x) idpath s x = s x. Proof. intros. unfold maponsec1l0. apply idpath. Defined. Lemma maponsec1l2 {X : UU} (P : X -> UU) (f : X -> X) (h : ∏ x, f x = x) (s : ∏ x, P x) x : maponsec1l0 P f h s x = s x. Proof. intros. set (map := λ (ff : (∑ (f0 : X -> X), ∏ x, (f0 x) = x)), maponsec1l0 P (pr1 ff) (pr2 ff) s x). assert (is1 : iscontr (∑ (f0 : X -> X), ∏ x, (f0 x) = x)) by apply funextcontr. assert (e: (f,,h) = tpair (λ g, ∏ x, g x = x) (λ x, x) idpath) by (apply proofirrelevancecontr; assumption). apply (maponpaths map e). Defined. Theorem isweqmaponsec1 {X Y : UU} (P : Y -> UU) (f : X ≃ Y) : isweq (maponsec1 P f). Proof. intros. set (map := maponsec1 P f). set (invf := invmap f). set (e1 := homotweqinvweq f). set (e2 := homotinvweqweq f). set (im1 := λ (sx : ∏ x, P (f x)) y, sx (invf y)). set (im2 := λ (sy': ∏ y : Y, P (f (invf y))) y, transportf _ (homotweqinvweq f y) (sy' y)). set (invmapp := λ (sx : ∏ x, P (f x)), im2 (im1 sx)). assert (efg0 : ∏ (sx : (∏ x, P (f x))) x, (map (invmapp sx)) x = sx x). { intro. intro. unfold map. unfold invmapp. unfold im1. unfold im2. unfold maponsec1. simpl. fold invf. set (ee := e2 x). fold invf in ee. set (e3x := λ x0 : X, invmaponpathsweq f (invf (f x0)) x0 (homotweqinvweq f (f x0))). set (e3 := e3x x). assert (e4 : homotweqinvweq f (f x) = maponpaths f e3) by apply (pathsinv0 (pathsweq4 f (invf (f x)) x _)). assert (e5 : transportf P (homotweqinvweq f (f x)) (sx (invf (f x))) = transportf P (maponpaths f e3) (sx (invf (f x)))) by apply (maponpaths (λ e40, (transportf P e40 (sx (invf (f x))))) e4). assert (e6 : transportf P (maponpaths f e3) (sx (invf (f x))) = transportf (λ x, P (f x)) e3 (sx (invf (f x)))) by apply (pathsinv0 (functtransportf f P e3 (sx (invf (f x))))). set (ff := λ x, invf (f x)). assert (e7 : transportf (λ x, P (f x)) e3 (sx (invf (f x))) = sx x) by apply (maponsec1l2 (λ x, P (f x)) ff e3x sx x). apply (pathscomp0 (pathscomp0 e5 e6) e7). } assert (efg : ∏ sx : (∏ x, P (f x)), map (invmapp sx) = sx) by (intro; apply (funextsec _ _ _ (efg0 sx))). assert (egf0 : ∏ sy : (∏ y : Y, P y), ∏ y : Y, (invmapp (map sy)) y = sy y). { intros. unfold invmapp. unfold map. unfold im1. unfold im2. unfold maponsec1. set (ff := λ y : Y, f (invf y)). fold invf. apply (maponsec1l2 P ff (homotweqinvweq f) sy y). } assert (egf : ∏ sy : (∏ y : Y, P y), invmapp (map sy) = sy) by (intro; apply (funextsec _ _ _ (egf0 sy))). apply (isweq_iso map invmapp egf efg). Defined. Definition weqonsecbase {X Y : UU} (P : Y -> UU) (f : X ≃ Y) : (∏ y : Y, P y) ≃ (∏ x, P (f x)) := make_weq _ (isweqmaponsec1 P f). (** *** Composition of functions with a weak equivalence on the left *) Definition weqbfun {X Y : UU} (Z : UU) (w : X ≃ Y) : (Y -> Z) ≃ (X -> Z) := weqonsecbase _ w. (** ** Sections of families over an empty type and over coproducts *) (** *** General case *) Definition iscontrsecoverempty (P : empty -> UU) : iscontr (∏ x : empty, P x). Proof. split with (λ x : empty, fromempty x). intro t. apply funextsec. intro t0. induction t0. Defined. Definition iscontrsecoverempty2 {X : UU} (P : X -> UU) (is : neg X) : iscontr (∏ x, P x). Proof. intros. set (w := weqtoempty is). set (w' := weqonsecbase P (invweq w)). apply (iscontrweqb w' (iscontrsecoverempty _)). Defined. Definition secovercoprodtoprod {X Y : UU} (P : X ⨿ Y -> UU) (a : ∏ xy : X ⨿ Y, P xy) : (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y)) := make_dirprod (λ x, a (ii1 x)) (λ y : Y, a (ii2 y)). Definition prodtosecovercoprod {X Y : UU} (P : X ⨿ Y -> UU) (a : (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y))) : ∏ xy : X ⨿ Y, P xy. Proof. intros. induction xy as [ x | y ]. - exact (pr1 a x). - exact (pr2 a y). Defined. Definition weqsecovercoprodtoprod {X Y : UU} (P : X ⨿ Y -> UU) : (∏ xy : X ⨿ Y, P xy) ≃ (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y)). Proof. intros. use (weq_iso (secovercoprodtoprod P) (prodtosecovercoprod P)). - intro. apply funextsec. intro t. induction t; reflexivity. - intro a. apply pathsdirprod. + apply funextsec. apply homotrefl. + apply funextsec. apply homotrefl. Defined. (** *** Functions from the empty type *) Theorem iscontrfunfromempty (X : UU) : iscontr (empty -> X). Proof. split with fromempty. intro t. apply funextfun. intro x. induction x. Defined. Theorem iscontrfunfromempty2 (X : UU) {Y : UU} (is : neg Y) : iscontr (Y -> X). Proof. intros. set (w := weqtoempty is). set (w' := weqbfun X (invweq w)). apply (iscontrweqb w' (iscontrfunfromempty X)). Defined. (** *** Functions from a coproduct *) Definition funfromcoprodtoprod {X Y Z : UU} (f : X ⨿ Y -> Z) : (X -> Z) × (Y -> Z) := make_dirprod (λ x, f (ii1 x)) (λ y : Y, f (ii2 y)). Definition prodtofunfromcoprod {X Y Z : UU} (fg : (X -> Z) × (Y -> Z)) : X ⨿ Y -> Z := sumofmaps (pr1 fg) (pr2 fg). Theorem weqfunfromcoprodtoprod (X Y Z : UU) : (X ⨿ Y -> Z) ≃ ((X -> Z) × (Y -> Z)). Proof. intros. simple refine ( make_weq _ (isweq_iso (@funfromcoprodtoprod X Y Z) (@prodtofunfromcoprod X Y Z) _ _)). - intro a. apply funextfun; intro xy. induction xy as [ x | y ]; apply idpath. - intro a. induction a as [fx fy]. apply idpath. Defined. (** ** Sections of families over contractible types and over [ total2 ] (over dependent sums) *) (** *** General case *) Definition tosecoverunit (P : unit -> UU) (p : P tt) : ∏ t : unit, P t. Proof. intros. induction t. apply p. Defined. Definition weqsecoverunit (P : unit -> UU) : (∏ t : unit, P t) ≃ (P tt). Proof. set (f := λ a : ∏ t : unit, P t, a tt). set (g := tosecoverunit P). split with f. assert (egf : ∏ a, g (f a) = a). { intro. apply funextsec. intro t. induction t. apply idpath. } assert (efg : ∏ a, f (g a) = a) by (intros; apply idpath). apply (isweq_iso _ _ egf efg). Defined. Definition weqsecovercontr {X : UU} (P : X -> UU) (is : iscontr X) : (∏ x, P x) ≃ (P (pr1 is)). Proof. intros. set (w1 := weqonsecbase P (wequnittocontr is)). apply (weqcomp w1 (weqsecoverunit _)). Defined. Definition tosecovertotal2 {X : UU} (P : X -> UU) (Q : (∑ x, P x) -> UU) (a : ∏ x, ∏ p : P x, Q (x ,, p)) : ∏ xp : (∑ x, P x), Q xp. Proof. intros. induction xp as [ x p ]. apply (a x p). Defined. (** General equivalence between curried and uncurried function types *) Definition weqsecovertotal2 {X : UU} (P : X -> UU) (Q : (∑ x, P x) -> UU) : (∏ xp : (∑ x, P x), Q xp) ≃ (∏ x, ∏ p : P x, Q (x,, p)). Proof. intros. set (f := λ a : ∏ xp : (∑ x, P x), Q xp, λ x, λ p : P x, a (x,, p)). set (g := tosecovertotal2 P Q). split with f. assert (egf : ∏ a, g (f a) = a). { intro. apply funextsec. intro xp. induction xp as [ x p ]. apply idpath. } assert (efg : ∏ a, f (g a) = a). { intro. apply funextsec. intro x. apply funextsec. intro p. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. (** *** Functions from [ unit ] and from contractible types *) Definition weqfunfromunit (X : UU) : (unit -> X) ≃ X := weqsecoverunit _. Definition weqfunfromcontr {X : UU} (Y : UU) (is : iscontr X) : (X -> Y) ≃ Y := weqsecovercontr _ is. (** *** Functions from [ total2 ] *) Definition weqfunfromtotal2 {X : UU} (P : X -> UU) (Y : UU) : ((∑ x, P x) -> Y) ≃ (∏ x, P x -> Y) := weqsecovertotal2 P _. (** *** Functions from direct product *) Definition weqfunfromdirprod (X X' Y : UU) : (X × X' -> Y) ≃ (∏ x, X' -> Y) := weqsecovertotal2 _ _. (** ** Theorem saying that if each member of a family is of h-level n then the space of sections of the family is of h-level n. *) (** *** General case *) Theorem impred (n : nat) {T : UU} (P : T -> UU) : (∏ t : T, isofhlevel n (P t)) -> (isofhlevel n (∏ t : T, P t)). Proof. revert T P. induction n as [ | n IHn ]. - intros T P X. apply (funcontr P X). - intros T P X. unfold isofhlevel in X. unfold isofhlevel. intros x x'. assert (is : ∏ t : T, isofhlevel n (x t = x' t)) by (intro; apply (X t (x t) (x' t))). assert (is2 : isofhlevel n (∏ t : T, x t = x' t)) by apply (IHn _ (λ t0 : T, x t0 = x' t0) is). set (u := toforallpaths P x x'). assert (is3: isweq u) by apply isweqtoforallpaths. set (v:= invmap (make_weq u is3)). assert (is4: isweq v) by apply isweqinvmap. apply (isofhlevelweqf n (make_weq v is4)). assumption. Defined. Corollary impred_iscontr {T : UU} (P : T -> UU) : (∏ t : T, iscontr (P t)) -> (iscontr (∏ t : T, P t)). Proof. intros. apply (impred 0). assumption. Defined. Corollary impred_isaprop {T : UU} (P : T -> UU) : (∏ t : T, isaprop (P t)) -> (isaprop (∏ t : T, P t)). Proof. apply impred. Defined. Corollary impred_isaset {T : UU} (P : T -> UU) : (∏ t : T, isaset (P t)) -> (isaset (∏ t : T, P t)). Proof. intros. apply (impred 2). assumption. Defined. Corollary impredtwice (n : nat) {T T' : UU} (P : T -> T' -> UU) : (∏ (t : T) (t': T'), isofhlevel n (P t t')) -> (isofhlevel n (∏ (t : T) (t': T'), P t t')). Proof. intros X. assert (is1 : ∏ t : T, isofhlevel n (∏ t': T', P t t')) by (intro; apply (impred n _ (X t))). apply (impred n _ is1). Defined. Corollary impredfun (n : nat) (X Y : UU) (is : isofhlevel n Y) : isofhlevel n (X -> Y). Proof. intros. apply (impred n (λ x , Y) (λ x, is)). Defined. Theorem impredtech1 (n : nat) (X Y : UU) : (X -> isofhlevel n Y) -> isofhlevel n (X -> Y). Proof. revert X Y. induction n as [ | n IHn ]. intros X Y X0. simpl. split with (λ x, pr1 (X0 x)). - intro t. assert (s1 : ∏ x, t x = pr1 (X0 x)) by (intro; apply proofirrelevancecontr; apply (X0 x)). apply funextsec. assumption. - intros X Y X0. simpl. assert (X1 : X -> isofhlevel (S n) (X -> Y)) by (intro X1; apply impred; assumption). intros x x'. assert (s1 : isofhlevel n (∏ xx, x xx = x' xx)) by (apply impred; intro t; apply (X0 t)). assert (w : (∏ xx, x xx = x' xx) ≃ (x = x')) by apply (weqfunextsec _ x x'). apply (isofhlevelweqf n w s1). Defined. (** *** Functions to a contractible type *) Theorem iscontrfuntounit (X : UU) : iscontr (X -> unit). Proof. split with (λ x, tt). intro f. apply funextfun. intro x. induction (f x). apply idpath. Defined. Theorem iscontrfuntocontr (X : UU) {Y : UU} (is : iscontr Y) : iscontr (X -> Y). Proof. set (w := weqcontrtounit is). set (w' := weqffun X w). apply (iscontrweqb w' (iscontrfuntounit X)). Defined. (** *** Functions to a proposition *) Lemma isapropimpl (X Y : UU) (isy : isaprop Y) : isaprop (X -> Y). Proof. apply impred. intro. assumption. Defined. (** *** Functions to an empty type (generalization of [ isapropneg ]) *) Theorem isapropneg2 (X : UU) {Y : UU} (is : neg Y) : isaprop (X -> Y). Proof. intros. apply impred. intro. apply (isapropifnegtrue is). Defined. (** ** Theorems saying that [ iscontr T ], [ isweq f ] etc. are of h-level 1 *) Theorem iscontriscontr {X : UU} (is : iscontr X) : iscontr (iscontr X). Proof. assert (is0 : ∏ (x x' : X), x = x') by (apply proofirrelevancecontr; assumption). assert (is1 : ∏ cntr : X, iscontr (∏ x, x = cntr)). { intro. assert (is2 : ∏ x, iscontr (x = cntr)). { assert (is2 : isaprop X) by (apply isapropifcontr; assumption). unfold isaprop in is2. unfold isofhlevel in is2. intro x. apply (is2 x cntr). } apply funcontr. assumption. } set (f := @pr1 X (λ cntr : X, ∏ x, x = cntr)). assert (X1 : isweq f) by (apply isweqpr1; assumption). change (∑ (cntr : X), ∏ x, x = cntr) with (iscontr X) in X1. apply (iscontrweqb (make_weq f X1)). assumption. Defined. Theorem isapropiscontr (T : UU) : isaprop (iscontr T). Proof. intros. unfold isaprop. unfold isofhlevel. intros x x'. assert (is : iscontr(iscontr T)). apply iscontriscontr. apply x. assert (is2 : isaprop (iscontr T)) by apply (isapropifcontr is). apply (is2 x x'). Defined. Theorem isapropisweq {X Y : UU} (f : X -> Y) : isaprop (isweq f). Proof. intros. unfold isweq. apply (impred (S O) (λ y : Y, iscontr (hfiber f y)) (λ y : Y, isapropiscontr (hfiber f y))). Defined. Theorem isapropisisolated (X : UU) (x : X) : isaprop (isisolated X x). (* uses funextemptyAxiom *) Proof. intros. apply isofhlevelsn. intro is. apply impred. intro x'. apply (isapropdec _ (isaproppathsfromisolated X x is x')). Defined. Theorem isapropisdeceq (X : UU) : isaprop (isdeceq X). (* uses funextemptyAxiom *) Proof. apply (isofhlevelsn 0). intro is. unfold isdeceq. apply impred. intro x. apply (isapropisisolated X x). Defined. Theorem isapropisofhlevel (n : nat) (X : UU) : isaprop (isofhlevel n X). Proof. revert X. induction n as [ | n IHn ]. - apply isapropiscontr. - intro X. apply impred. intros t. apply impred. intros t0. apply IHn. Defined. Corollary isapropisaprop (X : UU) : isaprop (isaprop X). Proof. intro. apply (isapropisofhlevel (S O)). Defined. Definition isapropisdecprop (X : UU) : isaprop (isdecprop X). Proof. intros. unfold isdecprop. apply (isofhlevelweqf 1 (weqdirprodcomm _ _)). apply isofhleveltotal2. - apply isapropisaprop. - intro i. apply isapropdec. assumption. Defined. Corollary isapropisaset (X : UU) : isaprop (isaset X). Proof. intro. apply (isapropisofhlevel (S (S O))). Defined. Theorem isapropisofhlevelf (n : nat) {X Y : UU} (f : X -> Y) : isaprop (isofhlevelf n f). Proof. intros. unfold isofhlevelf. apply impred. intro y. apply isapropisofhlevel. Defined. Definition isapropisincl {X Y : UU} (f : X -> Y) : isaprop (isofhlevelf 1 f) := isapropisofhlevelf 1 f. Lemma isaprop_isInjective {X Y : UU} (f : X -> Y) : isaprop (isInjective f). Proof. intros. unfold isInjective. apply impred; intro. apply impred; intro. apply isapropisweq. Defined. Lemma incl_injectivity {X Y : UU} (f : X -> Y) : isincl f ≃ isInjective f. Proof. intros. apply weqimplimpl. - apply isweqonpathsincl. - apply isinclweqonpaths. - apply isapropisincl. - apply isaprop_isInjective. Defined. (** ** Theorems saying that various [ pr1 ] maps are inclusions *) Theorem isinclpr1weq (X Y : UU) : isincl (pr1weq : X ≃ Y -> X -> Y). Proof. intros. refine (isinclpr1 _ _). intro f. apply isapropisweq. Defined. Corollary isinjpr1weq (X Y : UU) : isInjective (pr1weq : X ≃ Y -> X -> Y). Proof. intros. apply isweqonpathsincl. apply isinclpr1weq. Defined. Theorem isinclpr1isolated (T : UU) : isincl (pr1isolated T). Proof. intro. apply (isinclpr1 _ (λ t : T, isapropisisolated T t)). Defined. (** associativity of weqcomp **) Definition weqcomp_assoc {W X Y Z : UU} (f : W ≃ X) (g: X ≃ Y) (h : Y ≃ Z) : (h ∘ (g ∘ f) = (h ∘ g) ∘ f)%weq. Proof. intros. apply subtypePath. - intros p. apply isapropisweq. - simpl. apply idpath. Defined. Lemma eqweqmap_pathscomp0 {A B C : UU} (p : A = B) (q : B = C) : weqcomp (eqweqmap p) (eqweqmap q) = eqweqmap (pathscomp0 p q). Proof. induction p. induction q. apply pair_path_in2. apply isapropisweq. Defined. Lemma inv_idweq_is_idweq {A : UU} : idweq A = invweq (idweq A). Proof. apply pair_path_in2. apply isapropisweq. Defined. Lemma eqweqmap_pathsinv0 {A B : UU} (p : A = B) : eqweqmap (!p) = invweq (eqweqmap p). Proof. induction p. exact inv_idweq_is_idweq. Defined. (** ** Various weak equivalences between spaces of weak equivalences *) (** *** Composition with a weak quivalence is a weak equivalence on weak equivalences *) Theorem weqfweq (X : UU) {Y Z : UU} (w : Y ≃ Z) : (X ≃ Y) ≃ (X ≃ Z). Proof. intros. set (f := λ a : X ≃ Y, weqcomp a w). set (g := λ b : X ≃ Z, weqcomp b (invweq w)). split with f. assert (egf : ∏ a, g (f a) = a). { intro a. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. intro x. apply (homotinvweqweq w (a x)). } assert (efg : ∏ b, f (g b) = b). { intro b. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. intro x. apply (homotweqinvweq w (b x)). } apply (isweq_iso _ _ egf efg). Defined. Theorem weqbweq {X Y : UU} (Z : UU) (w : X ≃ Y) : (Y ≃ Z) ≃ (X ≃ Z). Proof. intros. set (f := λ a : Y ≃ Z, weqcomp w a). set (g := λ b : X ≃ Z, weqcomp (invweq w) b). split with f. assert (egf : ∏ a, g (f a) = a). { intro a. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. intro y. apply (maponpaths a (homotweqinvweq w y)). } assert (efg : ∏ b, f (g b) = b). { intro b. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. intro x. apply (maponpaths b (homotinvweqweq w x)). } apply (isweq_iso _ _ egf efg). Defined. Theorem weqweq {X Y : UU} (w: X ≃ Y) : (X ≃ X) ≃ (Y ≃ Y). Proof. intros. intermediate_weq (X ≃ Y). - apply weqfweq. assumption. - apply invweq. apply weqbweq. assumption. Defined. (** *** Invertion on weak equivalences as a weak equivalence *) (** Comment : note that full form of [ funextfun ] is only used in the proof of this theorem in the form of [ isapropisweq ]. The rest of the proof can be completed using eta-conversion. *) Theorem weqinvweq (X Y : UU) : (X ≃ Y) ≃ (Y ≃ X). Proof. intros. apply (weq_iso invweq invweq). - intro. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. apply homotrefl. - intro. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. apply homotrefl. Defined. (** ** h-levels of spaces of weak equivalences *) (** *** Weak equivalences to and from types of h-level (S n) *) Theorem isofhlevelsnweqtohlevelsn (n : nat) (X Y : UU) (is : isofhlevel (S n) Y) : isofhlevel (S n) (X ≃ Y). Proof. intros. apply (isofhlevelsninclb n _ (isinclpr1weq _ _)). apply impred. intro. exact is. Defined. Theorem isofhlevelsnweqfromhlevelsn (n : nat) (X Y : UU) (is : isofhlevel (S n) Y) : isofhlevel (S n) (Y ≃ X). Proof. intros. apply (isofhlevelweqf (S n) (weqinvweq X Y)). apply isofhlevelsnweqtohlevelsn. exact is. Defined. (** *** Weak equivalences to and from contractible types *) Theorem isapropweqtocontr (X : UU) {Y : UU} (is : iscontr Y) : isaprop (X ≃ Y). Proof. intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropifcontr is)). Defined. Theorem isapropweqfromcontr (X : UU) {Y : UU} (is : iscontr Y) : isaprop (Y ≃ X). Proof. intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropifcontr is)). Defined. (** *** Weak equivalences to and from propositions *) Theorem isapropweqtoprop (X Y : UU) (is : isaprop Y) : isaprop (X ≃ Y). Proof. intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ is). Defined. Theorem isapropweqfromprop (X Y : UU) (is : isaprop Y) : isaprop (Y ≃ X). Proof. intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ is). Defined. (** *** Weak equivalences to and from sets *) Theorem isasetweqtoset (X Y : UU) (is : isaset Y) : isaset (X ≃ Y). Proof. intros. apply (isofhlevelsnweqtohlevelsn 1 _ _ is). Defined. Theorem isasetweqfromset (X Y : UU) (is : isaset Y) : isaset (Y ≃ X). Proof. intros. apply (isofhlevelsnweqfromhlevelsn 1 X _ is). Defined. (** *** Weak equivalences to an empty type *) Theorem isapropweqtoempty (X : UU) : isaprop (X ≃ empty). Proof. intro. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropempty)). Defined. Theorem isapropweqtoempty2 (X : UU) {Y : UU} (is : neg Y) : isaprop (X ≃ Y). Proof. intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropifnegtrue is)). Defined. (** *** Weak equivalences from an empty type *) Theorem isapropweqfromempty (X : UU) : isaprop (empty ≃ X). Proof. intro. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropempty)). Defined. Theorem isapropweqfromempty2 (X : UU) {Y : UU} (is : neg Y) : isaprop (Y ≃ X). Proof. intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropifnegtrue is)). Defined. (** *** Weak equivalences to and from [ unit ] *) Theorem isapropweqtounit (X : UU) : isaprop (X ≃ unit). Proof. intro. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropunit)). Defined. Theorem isapropweqfromunit (X : UU) : isaprop (unit ≃ X). Proof. intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropunit)). Defined. (** ** Weak auto-equivalences of a type with an isolated point *) Definition cutonweq {T : UU} t (is : isisolated T t) (w : T ≃ T) : isolated T × (compl T t ≃ compl T t). Proof. intros. split. - exists (w t). apply isisolatedweqf. assumption. - intermediate_weq (compl T (w t)). + apply weqoncompl. + apply weqtranspos0. * apply isisolatedweqf. assumption. * assumption. Defined. Definition invcutonweq {T : UU} (t : T) (is : isisolated T t) (t'w : isolated T × (compl T t ≃ compl T t)) : T ≃ T := weqcomp (weqrecomplf t t is is (pr2 t'w)) (weqtranspos t (pr1 (pr1 t'w)) is (pr2 (pr1 t'w))). Lemma pathsinvcuntonweqoft {T : UU} (t : T) (is : isisolated T t) (t'w : isolated T × (compl T t ≃ compl T t)) : invcutonweq t is t'w t = pr1 (pr1 t'w). Proof. intros. unfold invcutonweq. simpl. unfold recompl. unfold coprodf. unfold invmap. simpl. unfold invrecompl. induction (is t) as [ ett | nett ]. - apply pathsfuntransposoft1. - induction (nett (idpath _)). Defined. Definition weqcutonweq (T : UU) (t : T) (is : isisolated T t) : (T ≃ T) ≃ isolated T × (compl T t ≃ compl T t). Proof. intros. set (f := cutonweq t is). set (g := invcutonweq t is). apply (weq_iso f g). - intro w. Set Printing Coercions. idtac. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun; intro t'. simpl. unfold invmap; simpl. unfold coprodf, invrecompl. induction (is t') as [ ett' | nett' ]. + simpl. rewrite (pathsinv0 ett'). apply pathsfuntransposoft1. + unfold funtranspos0; simpl. induction (is (w t)) as [ etwt | netwt ]. * induction (is (w t')) as [ etwt' | netwt' ]. -- induction (negf (invmaponpathsincl w (isofhlevelfweq 1 w) t t') nett' (pathscomp0 (pathsinv0 etwt) etwt')). -- simpl. assert (newtt'' := netwt'). rewrite etwt in netwt'. apply (pathsfuntransposofnet1t2 t (w t) is _ (w t') newtt'' netwt'). * simpl. induction (is (w t')) as [ etwt' | netwt' ]. -- simpl. rewrite (pathsinv0 etwt'). apply (pathsfuntransposoft2 t (w t) is _). -- simpl. assert (ne : neg (w t = w t')) by apply (negf (invmaponpathsweq w _ _) nett'). apply (pathsfuntransposofnet1t2 t (w t) is _ (w t') netwt' ne). - intro xw. induction xw as [ x w ]. induction x as [ t' is' ]. simpl in w. apply pathsdirprod. + apply (invmaponpathsincl _ (isinclpr1isolated _)). simpl. unfold recompl, coprodf, invmap; simpl. unfold invrecompl. induction (is t) as [ ett | nett ]. * apply pathsfuntransposoft1. * induction (nett (idpath _)). + simpl. apply (invmaponpathsincl _ (isinclpr1weq _ _) _ _). apply funextfun. intro x. induction x as [ x netx ]. unfold g, invcutonweq; simpl. set (int := funtranspos (t,, is) (t',, is') (recompl T t (coprodf w (λ x0 :unit, x0) (invmap (weqrecompl T t is) t)))). assert (eee : int = t'). { unfold int. unfold recompl, coprodf, invmap; simpl. unfold invrecompl. induction (is t) as [ ett | nett ]. - apply pathsfuntransposoft1. - induction (nett (idpath _)). } assert (isint : isisolated _ int). { rewrite eee. apply is'. } apply (ishomotinclrecomplf _ _ isint (funtranspos0 _ _ _) _ _). simpl. change (recomplf int t isint (funtranspos0 int t is)) with (funtranspos (int,, isint) (t,, is)). assert (ee : (int,, isint) = (t',, is')). { apply (invmaponpathsincl _ (isinclpr1isolated _) _ _). simpl. apply eee. } rewrite ee. set (e := homottranspost2t1t1t2 t t' is is' (recompl T t (coprodf w (λ x0 : unit, x0) (invmap (weqrecompl T t is) x)))). simpl in e. rewrite e. unfold recompl, coprodf, invmap; simpl. unfold invrecompl. induction (is x) as [ etx | netx' ]. * induction (netx etx). * apply (maponpaths (@pr1 _ _)). apply (maponpaths w). apply (invmaponpathsincl _ (isinclpr1compl _ _) _ _). simpl. apply idpath. Unset Printing Coercions. Defined. (* Coprojections i.e. functions which are weakly equivalent to functions of the form ii1 : X -> X ⨿ Y Definition locsplit (X : UU) (Y : UU) (f : X -> Y) := ∏ y : Y, (hfiber f y) ⨿ (hfiber f y -> empty). Definition dnegimage (X : UU) (Y : UU) (f : X -> Y) := total2 Y (λ y : Y, dneg(hfiber f y)). Definition dnegimageincl (X Y : UU) (f : X -> Y) := pr1 Y (λ y : Y, dneg(hfiber f y)). Definition xtodnegimage (X : UU) (Y : UU) (f : X -> Y) : X -> dnegimage f := λ x, tpair (f x) ((todneg _) (make_hfiber f (f x) x (idpath (f x)))). Definition locsplitsec (X : UU) (Y : UU) (f : X -> Y) (ls : locsplit f) : dnegimage f -> X := λ u, match u with tpair y psi => match (ls y) with ii1 z => pr1 z| ii2 phi => fromempty (psi phi) end end. Definition locsplitsecissec (X Y : UU) (f : X -> Y) (ls : locsplit f) (u:dnegimage f) : paths (xtodnegimage f (locsplitsec f ls u)) u. Proof. intros. set (p := xtodnegimage f). set (s := locsplitsec f ls). assert (paths (pr1 (p (s u))) (pr1 u)). unfold p. unfold xtodnegimage. unfold s. unfold locsplitsec. simpl. induction u. set (lst := ls t). induction lst. simpl. apply (pr2 x0). induction (x y). assert (is : isofhlevelf (S O) (dnegimageincl f)). apply (isofhlevelfpr1 (S O) (λ y : Y, isapropdneg (hfiber f y))). assert (isw: isweq (maponpaths (dnegimageincl f) (p (s u)) u)). apply (isofhlevelfonpaths O _ is). apply (invmap _ isw X0). Defined. Definition negimage (X : UU) (Y : UU) (f : X -> Y) := total2 Y (λ y : Y, neg(hfiber f y)). Definition negimageincl (X Y : UU) (f : X -> Y) := pr1 Y (λ y : Y, neg(hfiber f y)). Definition imsum (X : UU) (Y : UU) (f : X -> Y) : (dnegimage f) ⨿ (negimage f) -> Y := λ u, match u with ii1 z => pr1 z| ii2 z => pr1 z end. *) (** some lemmas about weak equivalences *) Definition weqcompidl {X Y} (f:X ≃ Y) : weqcomp (idweq X) f = f. Proof. intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextsec; intro x; simpl. apply idpath. Defined. Definition weqcompidr {X Y} (f:X ≃ Y) : weqcomp f (idweq Y) = f. Proof. intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextsec; intro x; simpl. apply idpath. Defined. Definition weqcompinvl {X Y} (f:X ≃ Y) : weqcomp (invweq f) f = idweq Y. Proof. intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextsec; intro y; simpl. apply homotweqinvweq. Defined. Definition weqcompinvr {X Y} (f:X ≃ Y) : weqcomp f (invweq f) = idweq X. Proof. intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextsec; intro x; simpl. apply homotinvweqweq. Defined. Definition weqcompassoc {X Y Z W} (f:X ≃ Y) (g:Y ≃ Z) (h:Z ≃ W) : weqcomp (weqcomp f g) h = weqcomp f (weqcomp g h). Proof. intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextsec; intro x; simpl. apply idpath. Defined. Definition weqcompweql {X Y Z} (f:X ≃ Y) : isweq (λ g:Y ≃ Z, weqcomp f g). Proof. intros. simple refine (isweq_iso _ _ _ _). { intro h. exact (weqcomp (invweq f) h). } { intro g. simpl. rewrite <- weqcompassoc. rewrite weqcompinvl. apply weqcompidl. } { intro h. simpl. rewrite <- weqcompassoc. rewrite weqcompinvr. apply weqcompidl. } Defined. Definition weqcompweqr {X Y Z} (g:Y ≃ Z) : isweq (λ f:X ≃ Y, weqcomp f g). Proof. intros. simple refine (isweq_iso _ _ _ _). { intro h. exact (weqcomp h (invweq g)). } { intro f. simpl. rewrite weqcompassoc. rewrite weqcompinvr. apply weqcompidr. } { intro h. simpl. rewrite weqcompassoc. rewrite weqcompinvl. apply weqcompidr. } Defined. Definition weqcompinjr {X Y Z} {f f':X ≃ Y} (g:Y ≃ Z) : weqcomp f g = weqcomp f' g -> f = f'. Proof. apply (invmaponpathsincl _ (isinclweq _ _ _ (weqcompweqr g))). Defined. Definition weqcompinjl {X Y Z} (f:X ≃ Y) {g g':Y ≃ Z} : weqcomp f g = weqcomp f g' -> g = g'. Proof. apply (invmaponpathsincl _ (isinclweq _ _ _ (weqcompweql f))). Defined. Definition invweqcomp {X Y Z} (f:X ≃ Y) (g:Y ≃ Z) : invweq (weqcomp f g) = weqcomp (invweq g) (invweq f). Proof. intros. apply (weqcompinjr (weqcomp f g)). rewrite weqcompinvl. rewrite weqcompassoc. rewrite <- (weqcompassoc (invweq f)). rewrite weqcompinvl. rewrite weqcompidl. rewrite weqcompinvl. apply idpath. Defined. Definition invmapweqcomp {X Y Z} (f:X ≃ Y) (g:Y ≃ Z) : invmap (weqcomp f g) = weqcomp (invweq g) (invweq f). Proof. reflexivity. Defined. (* End of the file uu0d.v *) UniMath-20231010/UniMath/Foundations/Preamble.v000066400000000000000000000126501451125700300210670ustar00rootroot00000000000000(** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011 This is the first in the group of files which contain the (current state of) the mathematical library for the proof assistant Coq based on the Univalent Foundations. It contains some new notations for constructions defined in Coq.Init library as well as the definition of dependent sum. *) (** Initial setup unrelated to Univalent Foundations *) Require Export UniMath.Foundations.Init. (** Universe structure *) Definition UU := Type. Identity Coercion fromUUtoType : UU >-> Sortclass. (** The empty type *) Inductive empty : UU := . Notation "∅" := empty. (** The one-element type *) Inductive unit : UU := tt : unit. (** The two-element type *) Inductive bool : UU := | true : bool | false : bool. Definition negb (b:bool) := if b then false else true. (** The coproduct of two types *) Inductive coprod (A B:UU) : UU := | ii1 : A -> coprod A B | ii2 : B -> coprod A B. Arguments coprod_rect {_ _} _ _ _ _. Arguments ii1 {_ _} _. Arguments ii2 {_ _} _. Notation inl := ii1. (* deprecated; will be removed eventually *) Notation inr := ii2. (* deprecated; will be removed eventually *) Notation "X ⨿ Y" := (coprod X Y). (* type this in emacs with C-X 8 RET AMALGAMATION OR COPRODUCT *) (** The natural numbers *) (* Declare ML Module "nat_syntax_plugin". *) Inductive nat : UU := | O : nat | S : nat -> nat. Definition succ := S. Declare Scope nat_scope. Delimit Scope nat_scope with nat. Bind Scope nat_scope with nat. Arguments S _%nat. Open Scope nat_scope. Fixpoint add n m := match n with | O => m | S p => S (p + m) end where "n + m" := (add n m) : nat_scope. Fixpoint sub n m := match n, m with | S k, S l => k - l | _, _ => n end where "n - m" := (sub n m) : nat_scope. (* note: our mul differs from that in Coq.Init.Nat *) Definition mul : nat -> nat -> nat. Proof. intros n m. induction n as [|p pm]. - exact O. - exact (pm + m). Defined. Notation "n * m" := (mul n m) : nat_scope. Fixpoint max n m := match n, m with | O, _ => m | S n', O => n | S n', S m' => S (max n' m') end. Fixpoint min n m := match n, m with | O, _ => O | S n', O => O | S n', S m' => S (min n' m') end. Notation "0" := (O) : nat_scope. Notation "1" := (S 0) : nat_scope. Notation "2" := (S 1) : nat_scope. Notation "3" := (S 2) : nat_scope. Notation "4" := (S 3) : nat_scope. Notation "5" := (S 4) : nat_scope. Notation "6" := (S 5) : nat_scope. Notation "7" := (S 6) : nat_scope. Notation "8" := (S 7) : nat_scope. Notation "9" := (S 8) : nat_scope. Notation "10" := (S 9) : nat_scope. Notation "11" := (S 10) : nat_scope. Notation "12" := (S 11) : nat_scope. Notation "13" := (S 12) : nat_scope. Notation "14" := (S 13) : nat_scope. Notation "15" := (S 14) : nat_scope. Notation "16" := (S 15) : nat_scope. Notation "17" := (S 16) : nat_scope. Notation "18" := (S 17) : nat_scope. Notation "19" := (S 18) : nat_scope. Notation "20" := (S 19) : nat_scope. Notation "21" := (S 20) : nat_scope. Notation "22" := (S 21) : nat_scope. Notation "23" := (S 22) : nat_scope. Notation "24" := (S 23) : nat_scope. Notation "100" := (10 * 10) : nat_scope. Notation "1000" := (10 * 100) : nat_scope. (** Identity Types *) Inductive paths {A:UU} (a:A) : A -> UU := paths_refl : paths a a. #[global] Hint Resolve paths_refl : core . Notation "a = b" := (paths a b) : type_scope. Notation idpath := paths_refl . (* Remark: all of the uu0.v now uses only paths_rect and not the direct "match" construction on paths. By adding a constantin paths for the computation rule for paths_rect and then making both this constant and paths_rect itself opaque it is possible to check which of the constructions of the uu0 can be done with the weakened version of the Martin-Lof Type Theory that is interpreted by the Bezem-Coquand-Huber cubical set model of 2014. *) (** Dependent sums. One can not use a new record each time one needs it because the general theorems about this construction would not apply to new instances of "Record" due to the "generativity" of inductive definitions in Coq. We use "Record", which is equivalent to "Structure", instead of "Inductive" here, so we can take advantage of the "primitive projections" feature of Coq, which introduces η-reduction for pairs, by adding the option "Set Primitive Projections". It also speeds up compilation by 56 percent. The terms produced by the "induction" tactic, when we define "total2" as a record, contain the "match" construction instead appealing to the eliminator. However, assuming the eliminator will be justified mathematically, the way to justify the the "match" construction is to point out that it can be regarded as an abbreviation for the eliminator that omits explicit mention of the first two parameters (X:Type) and (Y:X->Type). I.e., whenever you see [match w as t0 return TYPE with | tpair _ _ x y => BODY end] in a proof term, just mentally replace it by [@total2_rect _ _ (λ t0, TYPE) (λ x y, BODY) w] *) Set Primitive Projections. Set Nonrecursive Elimination Schemes. Record total2 { T: UU } ( P: T -> UU ) := tpair { pr1 : T; pr2 : P pr1 }. Arguments tpair {_} _ _ _. Arguments pr1 {_ _} _. Arguments pr2 {_ _} _. Notation "'∑' x .. y , P" := (total2 (λ x, .. (total2 (λ y, P)) ..)) (at level 200, x binder, y binder, right associativity) : type_scope. (* type this in emacs in agda-input method with \sum *) Notation "x ,, y" := (tpair _ x y). UniMath-20231010/UniMath/Foundations/Propositions.v000066400000000000000000000571201451125700300220510ustar00rootroot00000000000000(** * Generalities on hProp. Vladimir Voevodsky . May - Sep. 2011 . In this file we introduce the hProp - an analog of Prop defined based on the univalent semantics. We further introduce the hProp version of the "inhabited" construction - i.e. for any [T] in [UU0] we construct an object [ishinh T] and a function [hinhpr : T -> ishinh T] which plays the role of [inhabits] from the Coq standard library. The semantic meaning of [hinhpr] is that it is universal among functions from [T] to objects of hProp. Proving that [ishinh T] is in [hProp] requires a resizing rule which can be written in the putative notation for such rules as follows : Resizing Rule RR1 (U1 U2 : Univ) (X : U1) (is : isaprop X) |- X : U2. Further in the file we introduce the univalence axiom [hPropUnivalence] for hProp and a proof of the fact that it is equivalent to a simplier and better known axiom [propositionalUnivalenceAxiom]. We prove that this axiom implies that [hProp] satisfies [isaset] i.e. it is a type of h-level 2. This requires another resizing rule : Resizing Rule RR2 (U1 U2 : Univ) |- @hProp U1 : U2. Since resizing rules are not currently implemented in Coq the file does not compile without a patch provided by Hugo Herbelin which turns off the universe consistency verification. We do however keep track of universes in our development "by hand" to ensure that when the resizing rules will become available the current proofs will verify correctly. To point out which results require resizing rules in a substantial way we mark the first few of such reults by (** RR1 *) or (** RR2 *) comment. One can achieve similar results with a combination of usual axioms which imitate the resizing rules. However unlike the usual axioms the resizing rules do not affect the computation/normalization abilities of Coq which makes them the preferred choice in this situation. *) (** ** Contents - The type [hProp] of types of h-level 1 - The type [tildehProp] of pairs (P, p : P) where [P : hProp] - Intuitionistic logic on [hProp] - The [hProp] version of the "inhabited" construction. - [ishinh] and negation [neg] - [ishinh] and [coprod] - Images and surjectivity for functions between types - The two-out-of-three properties of surjections - A function between types which is an inclusion and a surjection is a weak equivalence - Intuitionistic logic on [hProp] - Associativity and commutativity of [hdisj] and [hconj] up to logical equivalence - Proof of the only non-trivial axiom of intuitionistic logic for our constructions - Negation and quantification - Negation and conjunction ("and") and disjunction ("or") - Property of being decidable and [hdisj] ("or") - The double negation version of [hinhabited] (does not require RR1) - Univalence for hProp *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.PartD. (** Universe structure *) (* Definition UU0 := UU. *) (* end of " Preamble ". *) (** ** To upstream files *) (** ** The type [hProp] of types of h-level 1 *) Definition hProp := total2 (λ X : UU, isaprop X). Definition make_hProp (X : UU) (is : isaprop X) : hProp := tpair (λ X : UU, isaprop X) X is. Definition hProptoType := @pr1 _ _ : hProp -> UU. Coercion hProptoType : hProp >-> UU. Definition propproperty (P : hProp) := pr2 P : isaprop (pr1 P). (** ** The type [tildehProp] of pairs (P, p : P) where [P : hProp] *) Definition tildehProp := total2 (λ P : hProp, P). Definition make_tildehProp {P : hProp} (p : P) : tildehProp := tpair _ P p. (* convenient corollaries of some theorems that take separate isaprop arguments: *) Corollary subtypeInjectivity_prop {A : UU} (B : A -> hProp) : ∏ (x y : total2 B), (x = y) ≃ (pr1 x = pr1 y). Proof. intros. apply subtypeInjectivity. intro. apply propproperty. Defined. Corollary subtypePath_prop {A : UU} {B : A -> hProp} {s s' : total2 (λ x, B x)} : pr1 s = pr1 s' -> s = s'. Proof. apply invmap. apply subtypeInjectivity_prop. Defined. Corollary impred_prop {T : UU} (P : T -> hProp) : isaprop (∏ t : T, P t). Proof. intros. apply impred; intro. apply propproperty. Defined. Corollary isaprop_total2 (X : hProp) (Y : X -> hProp) : isaprop (∑ x, Y x). Proof. intros. apply (isofhleveltotal2 1). - apply propproperty. - intro x. apply propproperty. Defined. Lemma isaprop_forall_hProp (X : UU) (Y : X -> hProp) : isaprop (∏ x, Y x). Proof. intros. apply impred_isaprop. intro x. apply propproperty. Defined. Definition forall_hProp {X : UU} (Y : X -> hProp) : hProp := make_hProp (∏ x, Y x) (isaprop_forall_hProp X Y). Notation "∀ x .. y , P" := (forall_hProp (λ x, .. (forall_hProp (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : type_scope. (* type this in emacs in agda-input method with \prod *) (** The following re-definitions should make proofs easier in the future when the unification algorithms in Coq are improved. At the moment they create more complications than they eliminate (e.g. try to prove [isapropishinh] with [isaprop] in [hProp]) so for the time being they are commented out. (** *** Re-definitions of some of the standard constructions of uu0.v which lift these contructions from UU to hProp. *) Definition iscontr (X : UU) : hProp := make_hProp _ (isapropiscontr X). Definition isweq {X Y : UU} (f : X -> Y) : hProp := make_hProp _ (isapropisweq f). Definition isofhlevel (n : nat) (X : UU) : hProp := make_hProp _ (isapropisofhlevel n X). Definition isaprop (X : UU) : hProp := make_hProp (isaprop X) (isapropisaprop X). Definition isaset (X : UU) : hProp := make_hProp _ (isapropisaset X). Definition isisolated (X : UU) (x : X) : hProp := make_hProp _ (isapropisisolated X x). Definition isdecEq (X : UU) : hProp := make_hProp _ (isapropisdeceq X). *) (** ** Intuitionistic logic on [hProp] *) (** *** The [hProp] version of the "inhabited" construction. *) Definition ishinh_UU (X : UU) : UU := ∏ P : hProp, ((X -> P) -> P). Lemma isapropishinh (X : UU) : isaprop (ishinh_UU X). Proof. apply impred. intro P. apply impred. intro. apply (pr2 P). Qed. Definition ishinh (X : UU) : hProp := make_hProp (ishinh_UU X) (isapropishinh X). Notation nonempty := ishinh (only parsing). Notation "∥ A ∥" := (ishinh A) (at level 20) : type_scope. (* written \|| in agda-input method *) Definition hinhpr {X : UU} : X -> ∥ X ∥ := λ x : X, λ P : hProp, fun f : X -> P => f x. Definition hinhfun {X Y : UU} (f : X -> Y) : ∥ X ∥ -> ∥ Y ∥ := fun isx : ∥ X ∥ => λ P : _, fun yp : Y -> P => isx P (λ x : X, yp (f x)). (** Note that the previous definitions do not require RR1 in an essential way (except for the placing of [ishinh] in [hProp UU] - without RR1 it would be placed in [hProp UU1]). The first place where RR1 is essentially required is in application of [hinhuniv] to a function [X -> ishinh Y] *) Definition hinhuniv {X : UU} {P : hProp} (f : X -> P) (wit : ∥ X ∥) : P := wit P f. Corollary factor_through_squash {X Q : UU} : isaprop Q -> (X -> Q) -> ∥ X ∥ -> Q. Proof. intros i f h. exact (@hinhuniv X (Q,,i) f h). Defined. Corollary squash_to_prop {X Q : UU} : ∥ X ∥ -> isaprop Q -> (X -> Q) -> Q. Proof. intros h i f. exact (@hinhuniv X (Q,,i) f h). Defined. Definition hinhand {X Y : UU} (inx1 : ∥ X ∥) (iny1 : ∥ Y ∥) : ∥ X × Y ∥ := λ P : _, ddualand (inx1 P) (iny1 P). Definition hinhuniv2 {X Y : UU} {P : hProp} (f : X -> Y -> P) (isx : ∥ X ∥) (isy : ∥ Y ∥) : P := hinhuniv (λ xy : X × Y, f (pr1 xy) (pr2 xy)) (hinhand isx isy). Definition hinhfun2 {X Y Z : UU} (f : X -> Y -> Z) (isx : ∥ X ∥) (isy : ∥ Y ∥) : ∥ Z ∥ := hinhfun (λ xy: X × Y, f (pr1 xy) (pr2 xy)) (hinhand isx isy). Definition hinhunivcor1 (P : hProp) : ∥ P ∥ -> P := hinhuniv (idfun P). Notation hinhprinv := hinhunivcor1. (** *** [ishinh] and negation [neg] *) Lemma weqishinhnegtoneg (X : UU) : ∥ ¬ X ∥ ≃ ¬ X. Proof. assert (lg : logeq (ishinh (neg X)) (neg X)). { split. - simpl. apply (@hinhuniv _ (make_hProp _ (isapropneg X))). simpl. intro nx. apply nx. - apply hinhpr. } apply (weqimplimpl (pr1 lg) (pr2 lg) (pr2 (ishinh _)) (isapropneg X)). Defined. Lemma weqnegtonegishinh (X : UU) : ¬ X ≃ ¬ ∥ X ∥. Proof. assert (lg : logeq (neg (ishinh X)) (neg X)). { split. - apply (negf (@hinhpr X)). - intro nx. unfold neg. simpl. apply (@hinhuniv _ (make_hProp _ isapropempty)). apply nx. } apply (weqimplimpl (pr2 lg) (pr1 lg) (isapropneg _) (isapropneg _)). Defined. (** *** [ishinh] and [coprod] *) Lemma hinhcoprod (X Y : UU) : ∥ (∥ X ∥ ⨿ ∥ Y ∥) ∥ -> ∥ X ⨿ Y ∥. Proof. intros is. unfold ishinh. intro P. intro CP. set (CPX := λ x : X, CP (ii1 x)). set (CPY := λ y : Y, CP (ii2 y)). set (is1P := is P). assert (f : (ishinh X) ⨿ (ishinh Y) -> P). apply (sumofmaps (hinhuniv CPX) (hinhuniv CPY)). apply (is1P f). Defined. (** [ishinh] and decidability *) Lemma decidable_ishinh {X} : decidable X → decidable(∥X∥). Proof. intros d. unfold decidable in *. induction d as [x|x']. - apply ii1. apply hinhpr. assumption. - apply ii2. intros p. apply (squash_to_prop p). + exact isapropempty. + exact x'. Defined. (** ** Images and surjectivity for functions between types (both depend only on the behavior of the corresponding function between the sets of connected components) **) Definition image {X Y : UU} (f : X -> Y) : UU := total2 (λ y : Y, ishinh (hfiber f y)). Definition make_image {X Y : UU} (f : X -> Y) : ∏ (t : Y), (λ y : Y, ∥ hfiber f y ∥) t → ∑ y : Y, ∥ hfiber f y ∥ := tpair (λ y : Y, ishinh (hfiber f y)). Definition pr1image {X Y : UU} (f : X -> Y) : (∑ y : Y, ∥ hfiber f y ∥) → Y := @pr1 _ (λ y : Y, ishinh (hfiber f y)). Definition prtoimage {X Y : UU} (f : X -> Y) : X -> image f. Proof. intros X0. apply (make_image _ (f X0) (hinhpr (make_hfiber f X0 (idpath _)))). Defined. Definition issurjective {X Y : UU} (f : X -> Y) := ∏ y : Y, ishinh (hfiber f y). Lemma isapropissurjective {X Y : UU} (f : X -> Y) : isaprop (issurjective f). Proof. intros. apply impred. intro t. apply (pr2 (ishinh (hfiber f t))). Defined. Lemma isinclpr1image {X Y : UU} (f : X -> Y): isincl (pr1image f). Proof. intros. refine (isofhlevelfpr1 _ _ _). intro. apply (pr2 (ishinh (hfiber f x))). Defined. Lemma issurjprtoimage {X Y : UU} (f : X -> Y) : issurjective (prtoimage f). Proof. intros. intro z. set (f' := prtoimage f). assert (ff: hfiber (funcomp f' (pr1image f)) (pr1 z) -> hfiber f' z) by refine (invweq (samehfibers _ _ (isinclpr1image f) z)). apply (hinhfun ff). exact (pr2 z). Defined. (** *** The two-out-of-three properties of surjections *) Lemma issurjcomp {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isf : issurjective f) (isg : issurjective g) : issurjective (funcomp f g). Proof. intros. unfold issurjective. intro z. apply (λ ff, hinhuniv ff (isg z)). intro ye. apply (hinhfun (hfibersftogf f g z ye)). apply (isf). Defined. Notation issurjtwooutof3c := issurjcomp. Lemma issurjtwooutof3b {X Y Z : UU} (f : X -> Y) (g : Y -> Z) (isgf : issurjective (funcomp f g)) : issurjective g. Proof. intros. unfold issurjective. intro z. apply (hinhfun (hfibersgftog f g z) (isgf z)). Defined. (** *** A function between types which is an inclusion and a surjection is a weak equivalence *) Lemma isweqinclandsurj {X Y : UU} (f : X -> Y) : isincl f -> issurjective f -> isweq f. Proof. intros Hincl Hsurj. intro y. set (H := make_hProp (iscontr (hfiber f y)) (isapropiscontr _)). apply (Hsurj y H). intro x. simpl. apply iscontraprop1. - apply Hincl. - apply x. Defined. (** On the other hand, a weak equivalence is surjective *) Lemma issurjectiveweq (X Y : UU) (f : X -> Y) : isweq f -> issurjective f. Proof. intros H y. apply hinhpr. apply (pr1 (H y)). Defined. (** *** Intuitionistic logic on [hProp]. *) Definition htrue : hProp := make_hProp unit isapropunit. Definition hfalse : hProp := make_hProp empty isapropempty. Definition hconj (P Q : hProp) : hProp := make_hProp (P × Q) (isapropdirprod _ _ (pr2 P) (pr2 Q)). Notation "A ∧ B" := (hconj A B) (at level 80, right associativity) : type_scope. (* precedence same as /\ *) (* in agda-input method, type \and or \wedge *) Definition hdisj (P Q : UU) : hProp := ishinh (coprod P Q). Notation "X ∨ Y" := (hdisj X Y) (at level 85, right associativity) : type_scope. (* in agda-input method, type \or *) (* precedence same as ‌\/, whereas ⨿ has the opposite associativity *) Definition hdisj_in1 {P Q : UU} : P -> P ∨ Q. Proof. intros. apply hinhpr. apply ii1. assumption. Defined. Definition hdisj_in2 {P Q : UU} : Q -> P ∨ Q. Proof. intros. apply hinhpr. apply ii2. assumption. Defined. Lemma disjoint_disjunction (P Q : hProp) : (P -> Q -> ∅) -> hProp. Proof. intros n. exact (P ⨿ Q,, isapropcoprod P Q (propproperty P) (propproperty Q) n). Defined. Definition hneg (P : UU) : hProp := make_hProp (¬ P) (isapropneg P). (* uses funextemptyAxiom *) (* use scope "logic" for notations that might conflict with others *) Declare Scope logic. Notation "'¬' X" := (hneg X) (at level 35, right associativity) : logic. (* type this in emacs in agda-input method with \neg *) Delimit Scope logic with logic. Definition himpl (P : UU) (Q : hProp) : hProp. Proof. intros. split with (P -> Q). apply impred. intro. apply (pr2 Q). Defined. Local Notation "A ⇒ B" := (himpl A B) : logic. (* precedence same as <-> *) (* in agda-input method, type \r= or \Rightarrow or \=> *) (* can't make it global, because it's defined differently in CategoryTheory/UnicodeNotations.v *) Local Open Scope logic. Definition hexists {X : UU} (P : X -> UU) := ∥ total2 P ∥. Notation "'∃' x .. y , P" := (ishinh (∑ x ,.. (∑ y , P)..)) (at level 200, x binder, y binder, right associativity) : type_scope. (* in agda-input method, type \ex *) Definition wittohexists {X : UU} (P : X -> UU) (x : X) (is : P x) : hexists P := @hinhpr (total2 P) (tpair _ x is). Definition total2tohexists {X : UU} (P : X -> UU) : total2 P -> hexists P := hinhpr. Definition weqneghexistsnegtotal2 {X : UU} (P : X -> UU) : weq (neg (hexists P)) (neg (total2 P)). Proof. intros. assert (lg : (neg (hexists P)) <-> (neg (total2 P))). { split. - apply (negf (total2tohexists P)). - intro nt2. unfold neg. change (ishinh_UU (total2 P) -> hfalse). apply (hinhuniv). apply nt2. } apply (weqimplimpl (pr1 lg) (pr2 lg) (isapropneg _) (isapropneg _)). Defined. (** *** Associativity and commutativity of [hdisj] and [hconj] up to logical equivalence *) Lemma islogeqcommhdisj {P Q : hProp} : hdisj P Q <-> hdisj Q P. Proof. intros. split. - simpl. apply hinhfun. apply coprodcomm. - simpl. apply hinhfun. apply coprodcomm. Defined. (** *** Proof of the only non-trivial axiom of intuitionistic logic for our constructions. For the full list of axioms see e.g. http://plato.stanford.edu/entries/logic-intuitionistic/ *) Lemma hconjtohdisj (P Q : UU) (R : hProp) : (P ⇒ R) ∧ (Q ⇒ R) -> (P ∨ Q) ⇒ R. Proof. intros X0. assert (s1: hdisj P Q -> R). { intro X1. assert (s2: coprod P Q -> R). { intro X2. induction X2 as [ XP | XQ ]. - apply X0. apply XP. - apply (pr2 X0). apply XQ. } apply (hinhuniv s2). apply X1. } unfold himpl. simpl. apply s1. Defined. (** *** Negation and quantification. There are four standard implications in classical logic which can be summarized as (neg (∏ P)) <-> (exists (neg P)) and (neg (exists P)) <-> (∏ (neg P)). Of these four implications three are provable in the intuitionistic logic. The remaining implication (neg (∏ P)) -> (exists (neg P)) is not provable in general. For a proof in the case of bounded quantification of decidable predicates on natural numbers see hnat.v. For some other cases when these implications hold see ???. *) Lemma hexistsnegtonegforall {X : UU} (F : X -> UU) : (∃ x : X, neg (F x)) -> neg (∏ x : X, F x). Proof. simpl. apply (@hinhuniv _ (make_hProp _ (isapropneg (∏ x : X, F x)))). simpl. intros t2 f2. induction t2 as [ x d2 ]. apply (d2 (f2 x)). Defined. Lemma forallnegtoneghexists {X : UU} (F : X -> UU) : (∏ x : X, neg (F x)) -> neg (∃ x, F x). Proof. intros nf. change ((ishinh_UU (total2 F)) -> hfalse). apply hinhuniv. intro t2. induction t2 as [ x f ]. apply (nf x f). Defined. Lemma neghexisttoforallneg {X : UU} (F : X -> UU) : ¬ (∃ x, F x) -> ∏ x : X, ¬ (F x). Proof. intros nhe x. intro fx. apply (nhe (hinhpr (tpair F x fx))). Defined. Definition weqforallnegtonegexists {X : UU} (F : X -> UU) : (∏ x : X, ¬ F x) ≃ (¬ ∃ x, F x). Proof. intros. apply (weqimplimpl (forallnegtoneghexists F) (neghexisttoforallneg F)). apply impred. intro x. apply isapropneg. apply isapropneg. Defined. (** *** Negation and conjunction ("and") and disjunction ("or"). There are four implications in classical logic ((¬ X) and (¬ Y)) <-> (¬ (X or Y)) and ((¬ X) or (¬ Y)) <-> (¬ (X and Y)). Of these four, three are provable unconditionally in the intuitionistic logic and the remaining one (¬ (X and Y)) -> ((¬ X) or (¬ Y)) is provable only if one of the propositions is decidable. These two cases are proved in PartC.v under the names [fromneganddecx] and [fromneganddecy]. *) Lemma tonegdirprod {X Y : UU} : ¬ X ∨ ¬ Y -> ¬ (X × Y). Proof. simpl. apply (@hinhuniv _ (make_hProp _ (isapropneg (X × Y)))). intro c. induction c as [ nx | ny ]. - simpl. intro xy. apply (nx (pr1 xy)). - simpl. intro xy. apply (ny (pr2 xy)). Defined. Lemma weak_fromnegdirprod (P Q: hProp) : ¬ (P ∧ Q) -> ¬¬(¬ P ∨ ¬ Q). (* this is also called a weak deMorgan law *) Proof. intros npq k. assert (e : ¬¬ Q). { intro n. apply k. apply hdisj_in2. assumption. } assert (d : ¬¬ P). { intro n. apply k. apply hdisj_in1. assumption. } clear k. apply d; clear d. intro p. apply e; clear e. intro q. refine (npq _). exact (p,,q). Defined. Lemma tonegcoprod {X Y : UU} : ¬ X × ¬ Y -> ¬ (X ⨿ Y). Proof. intros is. intro c. induction c as [ x | y ]. - apply (pr1 is x). - apply (pr2 is y). Defined. Lemma toneghdisj {X Y : UU} : ¬ X × ¬ Y -> ¬ (X ∨ Y). Proof. intros is. unfold hdisj. apply weqnegtonegishinh. apply tonegcoprod. apply is. Defined. Lemma fromnegcoprod {X Y : UU} : ¬ (X ⨿ Y) -> ¬X × ¬Y. Proof. intros is. split. - exact (λ x, is (ii1 x)). - exact (λ y, is (ii2 y)). Defined. Corollary fromnegcoprod_prop {X Y : hProp} : ¬ (X ∨ Y) -> ¬ X ∧ ¬ Y. Proof. intros n. simpl in *. assert (n' := negf hinhpr n); simpl in n'; clear n. apply fromnegcoprod. assumption. Defined. Lemma hdisjtoimpl {P : UU} {Q : hProp} : P ∨ Q -> ¬ P -> Q. Proof. assert (int : isaprop (¬ P -> Q)). { apply impred. intro. apply (pr2 Q). } simpl. apply (@hinhuniv _ (make_hProp _ int)). simpl. intro pq. induction pq as [ p | q ]. - intro np. induction (np p). - intro np. apply q. Defined. (** *** Property of being decidable and [hdisj] ("or"). For being decidable [hconj] see [isdecpropdirprod] in uu0.v *) Lemma isdecprophdisj {X Y : UU} (isx : isdecprop X) (isy : isdecprop Y) : isdecprop (hdisj X Y). Proof. intros. apply isdecpropif. apply (pr2 (hdisj X Y)). induction (pr1 isx) as [ x | nx ]. - apply (ii1 (hinhpr (ii1 x))). - induction (pr1 isy) as [ y | ny ]. + apply (ii1 (hinhpr (ii2 y))). + apply (ii2 (toneghdisj (make_dirprod nx ny))). Defined. (** *** The double negation version of [hinhabited] (does not require RR1). *) Definition isinhdneg (X : UU) : hProp := make_hProp (dneg X) (isapropdneg X). Definition inhdnegpr (X : UU) : X -> isinhdneg X := todneg X. Definition inhdnegfun {X Y : UU} (f : X -> Y) : isinhdneg X -> isinhdneg Y := dnegf f. Definition inhdneguniv (X : UU) (P : UU) (is : isweq (todneg P)) : (X -> P) -> ((isinhdneg X) -> P) := λ xp : _, λ inx0 : _, (invmap (make_weq _ is) (dnegf xp inx0)). Definition inhdnegand (X Y : UU) (inx0 : isinhdneg X) (iny0 : isinhdneg Y) : isinhdneg (X × Y) := dneganddnegimpldneg inx0 iny0. Definition hinhimplinhdneg (X : UU) (inx1 : ishinh X) : isinhdneg X := inx1 hfalse. (** ** Univalence for hProp *) Theorem hPropUnivalence : ∏ (P Q : hProp), (P -> Q) -> (Q -> P) -> P = Q. (* this theorem replaced a former axiom, with the same statement, called "uahp" *) Proof. intros ? ? f g. apply subtypePath. - intro X. apply isapropisaprop. - apply propositionalUnivalenceAxiom. + apply propproperty. + apply propproperty. + assumption. + assumption. Defined. Definition eqweqmaphProp {P P' : hProp} (e : @paths hProp P P') : P ≃ P'. Proof. intros. induction e. apply idweq. Defined. Definition weqtopathshProp {P P' : hProp} (w : P ≃ P') : P = P' := hPropUnivalence P P' w (invweq w). Definition weqpathsweqhProp {P P' : hProp} (w : P ≃ P') : eqweqmaphProp (weqtopathshProp w) = w. Proof. intros. apply proofirrelevance. apply (isapropweqtoprop P P' (pr2 P')). Defined. Theorem univfromtwoaxiomshProp (P P' : hProp) : isweq (@eqweqmaphProp P P'). Proof. intros. set (P1 := λ XY : hProp × hProp, paths (pr1 XY) (pr2 XY)). set (P2 := λ XY : hProp × hProp, (pr1 XY) ≃ (pr2 XY)). set (Z1 := total2 P1). set (Z2 := total2 P2). set (f := (totalfun _ _ (λ XY : hProp × hProp, @eqweqmaphProp (pr1 XY) (pr2 XY)): Z1 -> Z2)). set (g := (totalfun _ _ (λ XY : hProp × hProp, @weqtopathshProp (pr1 XY) (pr2 XY)): Z2 -> Z1)). assert (efg : ∏ z2 : Z2 , paths (f (g z2)) z2). { intros. induction z2 as [ XY w]. exact (maponpaths (fun w : (pr1 XY) ≃ (pr2 XY) => tpair P2 XY w) (@weqpathsweqhProp (pr1 XY) (pr2 XY) w)). } set (h := λ a1 : Z1, (pr1 (pr1 a1))). assert (egf0 : ∏ a1 : Z1, paths (pr1 (g (f a1))) (pr1 a1)) by (intro; apply idpath). assert (egf1 : ∏ a1 a1' : Z1, paths (pr1 a1') (pr1 a1) -> a1' = a1). { intros ? ? X. set (X' := maponpaths (@pr1 _ _) X). assert (is : isweq h) by apply (isweqpr1pr1 hProp). apply (invmaponpathsweq (make_weq h is) _ _ X'). } set (egf := λ a1, (egf1 _ _ (egf0 a1))). set (is2 := isweq_iso _ _ egf efg). apply (isweqtotaltofib P1 P2 (λ XY : hProp × hProp, @eqweqmaphProp (pr1 XY) (pr2 XY)) is2 (make_dirprod P P')). Defined. Definition weqeqweqhProp (P P' : hProp) : P = P' ≃ (P ≃ P') := make_weq _ (univfromtwoaxiomshProp P P'). Corollary isasethProp : isaset hProp. Proof. unfold isaset. simpl. intros x x'. apply (isofhlevelweqb (S O) (weqeqweqhProp x x') (isapropweqtoprop x x' (pr2 x'))). Defined. Definition weqpathsweqhProp' {P P' : hProp} (e : P = P') : weqtopathshProp (eqweqmaphProp e) = e. Proof. intros. apply isasethProp. Defined. Lemma iscontrtildehProp : iscontr tildehProp. Proof. split with (tpair _ htrue tt). intro tP. induction tP as [ P p ]. apply (invmaponpathsincl _ (isinclpr1 (λ P : hProp, P) (λ P, pr2 P))). simpl. apply hPropUnivalence. apply (λ x, tt). intro t. apply p. Defined. Lemma isaproptildehProp : isaprop tildehProp. Proof. apply (isapropifcontr iscontrtildehProp). Defined. Lemma isasettildehProp : isaset tildehProp. Proof. apply (isasetifcontr iscontrtildehProp). Defined. (* ** Logical equivalence yields weak equivalence *) Definition logeqweq (P Q : hProp) : (P -> Q) -> (Q -> P) -> P ≃ Q := λ f g, weqimplimpl f g (pr2 P) (pr2 Q). (* ** A variant of a lemma proved in uu0b.v *) Theorem total2_paths_hProp_equiv {A : UU} (B : A -> hProp) (x y : total2 (λ x, B x)) : (x = y) ≃ (pr1 x = pr1 y). Proof. intros. apply subtypeInjectivity. intro a. apply (pr2 (B a)). Defined. UniMath-20231010/UniMath/Foundations/README000066400000000000000000000112371451125700300200310ustar00rootroot00000000000000By Vladimir Voevodsky Feb. 2010 - Dec. 2013 . This is the current version of the mathematical library for the proof assistant Coq based on the univalent semantics for the calculus of inductive constructions. The best way to see in detail what the files in these subdirectories are about is to generate the corresponding tables of content with coqdoc . Here we give a brief outline of the library structure . Important : files in the library starting with hProp.v will not compile without a type_in_type patch which turns off the universe consistency checking . This is a temporary situation which will be corrected when better universe management is implememnted in Coq . We also use a patch which modifies the rule by which the universe level of inductive definitions is computed . If the later patch is applied correctly then the compilation of the first file uuu.v should produce a message of the form [ paths 0 0 : UUU ] . Without a patch the message will be [ paths 0 0 : Prop ] . The library contains subdirectories Generalities/ hlevel1/ hlevel2/ and /Proof_of_Extensionality . Directory Generalities/ contains files uuu.v and uu0.v . The file uuu.v contains some new notations for the constructions defined in Coq.Init library as well as the definition of "dependent sum" [ total2 ] . The file uu0.v contains the bulk of general results and definitions about types which are pertinent to the univalent approach . In this file we prove main results which apply to all types and which require only one universe level to be proved. Some of the results in uu0 use the extensionality axiom for functions (introduced in the same file). No other axioms or resizings rules (see below) are used and these files should compile with the standard version of Coq. Directory hlevel1/ contains one file hProp.v with results and constructions related to types of h-level 1 i.e. to types which correspond to "propositions" in our formalization. Some of the results here use " resizing rules " and therefore it will currently not compile without a type_in_type patch . Note that we continue to keep track of universe levels in these files "by hand" and use only those "universe re-assigment" or "resizing" rules which are semantically justified. Some of the results in this file also use the univalence axiom for hProp called [ uahp ] which is equivalent to the axiom asserting that if two propositions are logically equivalent then they are equal . Directory hlevel2/ contains files with constructions and results related to types of hlevel 2 i.e. to types corresponding to sets in our formalization . The first file is hSet.v . It contains most general definitions related to sets including the constructions related to set-quotients of types . The next group of files in the hierarchy are algebra1(a b c d).v which contains many definitions and constructions of general abstract algebra culminating at the moment in the construction of the field of fractions of an integral domain. The files also contain definitions and results about the relations on algebraic structures . The next file is hnat.v which contains many simple lemmas about arithmetic and comparisons on natural numbers . Then the hierarchy branches. On one branch there are files stnfsets.v and finitesets.v which introduce constructions related to standard and general finite sets respectively. On another branch there are files hz.v and hq.v which introduce the basic cosntructions related to the integer and rational arithmetic as particular cases of the general theorems of the algebra1 group of files. At the end of files finitesets.v, hz.v and hq.v there are sample computations which show that despite our use of stnadard extensionality axioms the relevant terms of types [ bool ] and [ nat ] fully normalize. The last computation example in hq.v which evaluates the integral part of 10/-3 takes relatively long time ( about 30 sec. on my computer, it should work much faster with the stnadard optimized version of the "call by need" normalization algorithm which is switched off by one of the patches which I use, see the explanation in the README file of the patches directory) and it might make sense to comment it out. Directory Proof_of_Extensionality/ contains the formulation of general Univalence Axiom and a proof that it implies functional extensionality . The easiest way to compile the library is by typing "make" in this directory. For this to work one should have GNU Make installed which is easly to find on the web. Once the library is compiled the individual files of the library can be followed line-by-line in CoqIDE or Proof General. By running "make install" one can install the compiled library to the /user-contrib/ directory of Coq. UniMath-20231010/UniMath/Foundations/Sets.v000066400000000000000000003113241451125700300202560ustar00rootroot00000000000000(** * Generalities on [hSet]. Vladimir Voevodsky. Feb. - Sep. 2011 In this file we introduce the type [hSet] of h-sets, i.e., of types of h-level 2 as well as a number of constructions such as type of (monic) subtypes, images, surjectivity etc. which, while they formally apply to functions between arbitrary types actually only depend on the behavior of the function on the sets of connected components of these types. While it is possible to write a part of this file in a form which does not require RR1 it seems like a waste of effort since it would require to repeat a lot of things twice. Accordingly we assume RR1 from the start in dealing with sets. The drawback is that all the subsequent files will not compile at the moment without the Type in Type patch. *) (** ** Contents - The type of sets i.e. of types of h-level 2 in [UU] - [hProp] as a set - Booleans as a set - Types [X] which satisfy "weak" axiom of choice for all families [P : X -> UU] - The type of monic subtypes of a type (subsets of the set of connected components) - General definitions - Direct product of two subtypes - A subtype with paths between any two elements is an [hProp] - Relations on types (or equivalently relations on the sets of connected components) - Relations and boolean relations - Standard properties of relations - Elementary implications between properties of relations - Standard properties of relations and logical equivalences - Preorderings, partial orderings, and associated types - Equivalence relations and associated types - Direct product of two relations - Negation of a relation and its properties - Boolean representation of decidable equality - Boolean representation of decidable relations - Restriction of a relation to a subtype - Equivalence classes with respect to a given relation - Direct product of equivalence classes - Surjections to sets are epimorphisms - Epimorphisms are surjections - Universal property enjoyed by surjections - Set quotients of types - Set quotients defined in terms of equivalence classes - Universal property of [setquot R] for functions to sets satisfying compatibility condition [iscomprelfun] - Functoriality of [setquot] for functions mapping one relation to another - Universal property of [setquot] for predicates of one and several variables - The case when the function between quotients defined by [setquotfun] is a surjection, inclusion or a weak equivalence - [setquot] with respect to the product of two relations - Universal property of [setquot] for functions of two variables - Functoriality of [setquot] for functions of two variables mapping one relation to another - Set quotients with respect to decidable equivalence relations have decidable equality - Relations on quotient sets - Subtypes of quotients and quotients of subtypes - The set of connected components of a type - Set quotients. Construction 2 (Unfinished) - Functions compatible with a relation - The quotient set of a type by a relation - Universal property of [setquot2 R] for functions to sets satisfying compatibility condition [iscomplrelfun] - Weak equivalence from [R x x'] to [paths (setquot2pr R x) (setquot2pr R x')] - Consequences of univalence *) (** ** Preamble *) (** Imports *) Require Export UniMath.Foundations.Propositions. (** ** The type of sets i.e. of types of h-level 2 in [UU] *) Definition hSet : UU := total2 (λ X : UU, isaset X). Definition make_hSet (X : UU) (i : isaset X) := tpair isaset X i : hSet. Definition pr1hSet : hSet -> UU := @pr1 UU (λ X : UU, isaset X). Coercion pr1hSet: hSet >-> UU. Definition eqset {X : hSet} (x x' : X) : hProp := make_hProp (x = x') (pr2 X x x'). Notation "a = b" := (eqset a b) (at level 70, no associativity) : logic. Definition neqset {X : hSet} (x x' : X) : hProp := make_hProp (x != x') (isapropneg _). (* uses funextemptyAxiom *) Notation "a != b" := (neqset a b) (at level 70, no associativity) : logic. Definition setproperty (X : hSet) := pr2 X. Definition setdirprod (X Y : hSet) : hSet. Proof. intros. exists (X × Y). apply (isofhleveldirprod 2); apply setproperty. Defined. Definition setcoprod (X Y : hSet) : hSet. Proof. intros. exists (X ⨿ Y). apply isasetcoprod; apply setproperty. Defined. Lemma isaset_total2_hSet (X : hSet) (Y : X -> hSet) : isaset (∑ x, Y x). Proof. intros. apply isaset_total2. - apply setproperty. - intro x. apply setproperty. Defined. Definition total2_hSet {X : hSet} (Y : X -> hSet) : hSet := make_hSet (∑ x, Y x) (isaset_total2_hSet X Y). Definition hfiber_hSet {X Y : hSet} (f : X → Y) (y : Y) : hSet := make_hSet (hfiber f y) (isaset_hfiber f y (pr2 X) (pr2 Y)). Declare Scope set. Delimit Scope set with set. Notation "'∑' x .. y , P" := (total2_hSet (λ x,.. (total2_hSet (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : set. (* type this in emacs in agda-input method with \sum *) Lemma isaset_forall_hSet (X : UU) (Y : X -> hSet) : isaset (∏ x, Y x). Proof. intros. apply impred_isaset. intro x. apply setproperty. Defined. Definition forall_hSet {X : UU} (Y : X -> hSet) : hSet := make_hSet (∏ x, Y x) (isaset_forall_hSet X Y). Notation "'∏' x .. y , P" := (forall_hSet (λ x,.. (forall_hSet (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : set. (* type this in emacs in agda-input method with \sum *) Definition unitset : hSet := make_hSet unit isasetunit. Definition dirprod_hSet (X Y : hSet) : hSet. Proof. exists (X × Y). abstract (exact (isasetdirprod _ _ (setproperty X) (setproperty Y))). Defined. Notation "A × B" := (dirprod_hSet A B) (at level 75, right associativity) : set. (** *** [hProp] as a set *) Definition hPropset : hSet := tpair _ hProp isasethProp. (* Canonical Structure hPropset. *) Definition hProp_to_hSet (P : hProp) : hSet := make_hSet P (isasetaprop (propproperty P)). (** *** Booleans as a set *) Definition boolset : hSet := make_hSet bool isasetbool. (* Canonical Structure boolset. *) (* properties of functions between sets *) Definition isInjectiveFunction {X Y : hSet} (f : X -> Y) : hProp. Proof. intros. exists (∏ (x x': X), f x = f x' -> x = x'). abstract ( intros; apply impred; intro x; apply impred; intro y; apply impred; intro e; apply setproperty) using isaprop_isInjectiveFunction. Defined. (** ** Types [X] which satisfy "weak" axiom of choice for all families [P : X -> UU] Weak axiom of choice for [X] is the condition that for any family [P : X -> UU] over [X] such that all members of the family are inhabited the space of sections of the family is inhabited. Equivalently one can formulate it as an assertion that for any surjection (see below) [p : Y -> X] the space of sections of this surjection i.e. functions [s : X -> Y] together with a homotopy from [funcomp s p] to [idfun X] is inhabited. It does not provide a choice of a section for such a family or a surjection. In topos-theoretic semantics this condition corresponds to "local projectivity" of [X]. It automatically holds for the point [unit] but need not hold for sub-objects of [unit] i.e. for types of h-level 1 (propositions). In particular it does not have to hold for general types with decidable equality. Intuition based on standard univalent models suggests that any type satisfying weak axiom of choice is a set. Indeed it seems to be possible to show that if both a type and the set of connected components of this type (see below) satisfy weak axiom of choice then the type is a set. In particular, if one imposes weak axiom of choice for sets as an axiom then it would follow that every type satisfying weak axiom of choice is a set. I do not know however if there are models which would validate a possibility of types other than sets to satisfy weak axiom of choice. *) Definition ischoicebase_uu1 (X : UU) := ∏ P : X -> UU, (∏ x : X, ishinh (P x)) -> ishinh (∏ x : X, P x). (** Uses RR1 *) Lemma isapropischoicebase (X : UU) : isaprop (ischoicebase_uu1 X). Proof. apply impred. intro P. apply impred. intro fs. apply (pr2 (ishinh _)). Defined. Definition ischoicebase (X : UU) : hProp := make_hProp _ (isapropischoicebase X). Lemma ischoicebaseweqf {X Y : UU} (w : X ≃ Y) (is : ischoicebase X) : ischoicebase Y. Proof. intros. unfold ischoicebase. intros Q fs. apply (hinhfun (invweq (weqonsecbase Q w))). apply (is (funcomp w Q) (λ x : X, fs (w x))). Defined. Lemma ischoicebaseweqb {X Y : UU} (w : X ≃ Y) (is : ischoicebase Y) : ischoicebase X. Proof. intros. apply (ischoicebaseweqf (invweq w) is). Defined. Lemma ischoicebaseunit : ischoicebase unit. Proof. unfold ischoicebase. intros P fs. apply (hinhfun (tosecoverunit P)). apply (fs tt). Defined. Lemma ischoicebasecontr {X : UU} (is : iscontr X) : ischoicebase X. Proof. intros. apply (ischoicebaseweqb (weqcontrtounit is) ischoicebaseunit). Defined. Lemma ischoicebaseempty : ischoicebase empty. Proof. unfold ischoicebase. intros P fs. apply (hinhpr (λ x : empty, fromempty x)). Defined. Lemma ischoicebaseempty2 {X : UU} (is : ¬ X) : ischoicebase X. Proof. intros. apply (ischoicebaseweqb (weqtoempty is) ischoicebaseempty). Defined. Lemma ischoicebasecoprod {X Y : UU} (isx : ischoicebase X) (isy : ischoicebase Y) : ischoicebase (coprod X Y). Proof. intros. unfold ischoicebase. intros P fs. apply (hinhfun (invweq (weqsecovercoprodtoprod P))). apply hinhand. apply (isx _ (λ x : X, fs (ii1 x))). apply (isy _ (λ y : Y, fs (ii2 y))). Defined. (** ** The type of monic subtypes of a type (subsets of the set of connected components) *) (** *** General definitions *) Definition hsubtype (X : UU) : UU := X -> hProp. Identity Coercion id_hsubtype : hsubtype >-> Funclass. Definition carrier {X : UU} (A : hsubtype X) := total2 A. Coercion carrier : hsubtype >-> Sortclass. Definition make_carrier {X : UU} (A : hsubtype X) : ∏ t : X, A t → ∑ x : X, A x := tpair A. Definition pr1carrier {X : UU} (A : hsubtype X) := @pr1 _ _ : carrier A -> X. Lemma isaset_carrier_subset (X : hSet) (Y : hsubtype X) : isaset (∑ x, Y x). Proof. intros. apply isaset_total2. - apply setproperty. - intro x. apply isasetaprop, propproperty. Defined. Definition carrier_subset {X : hSet} (Y : hsubtype X) : hSet := make_hSet (∑ x, Y x) (isaset_carrier_subset X Y). Declare Scope subset. Notation "'∑' x .. y , P" := (carrier_subset (λ x,.. (carrier_subset (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : subset. (* type this in emacs in agda-input method with \sum *) Delimit Scope subset with subset. Lemma isinclpr1carrier {X : UU} (A : hsubtype X) : isincl (@pr1carrier X A). Proof. intros. apply (isinclpr1 A (λ x : _, pr2 (A x))). Defined. Lemma isasethsubtype (X : UU) : isaset (hsubtype X). Proof. change (isofhlevel 2 (hsubtype X)). apply impred; intro x. exact isasethProp. Defined. Definition totalsubtype (X : UU) : hsubtype X := λ x, htrue. Definition weqtotalsubtype (X : UU) : totalsubtype X ≃ X. Proof. apply weqpr1. intro. apply iscontrunit. Defined. Definition weq_subtypes {X Y : UU} (w : X ≃ Y) (S : hsubtype X) (T : hsubtype Y) : (∏ x, S x <-> T (w x)) -> carrier S ≃ carrier T. Proof. intros eq. apply (weqbandf w). intro x. apply weqiff. - apply eq. - apply propproperty. - apply propproperty. Defined. (** *** Direct product of two subtypes *) Definition subtypesdirprod {X Y : UU} (A : hsubtype X) (B : hsubtype Y) : hsubtype (X × Y) := λ xy : _, hconj (A (pr1 xy)) (B (pr2 xy)). Definition fromdsubtypesdirprodcarrier {X Y : UU} (A : hsubtype X) (B : hsubtype Y) (xyis : subtypesdirprod A B) : dirprod A B. Proof. intros. set (xy := pr1 xyis). set (is := pr2 xyis). set (x := pr1 xy). set (y := pr2 xy). simpl in is. simpl in y. apply (make_dirprod (tpair A x (pr1 is)) (tpair B y (pr2 is))). Defined. Definition tosubtypesdirprodcarrier {X Y : UU} (A : hsubtype X) (B : hsubtype Y) (xisyis : dirprod A B) : subtypesdirprod A B. Proof. intros. set (xis := pr1 xisyis). set (yis := pr2 xisyis). set (x := pr1 xis). set (isx := pr2 xis). set (y := pr1 yis). set (isy := pr2 yis). simpl in isx. simpl in isy. apply (tpair (subtypesdirprod A B) (make_dirprod x y) (make_dirprod isx isy)). Defined. Lemma weqsubtypesdirprod {X Y : UU} (A : hsubtype X) (B : hsubtype Y) : subtypesdirprod A B ≃ A × B. Proof. intros. set (f := fromdsubtypesdirprodcarrier A B). set (g := tosubtypesdirprodcarrier A B). split with f. assert (egf : ∏ a : _, paths (g (f a)) a). { intro a. induction a as [ xy is ]. induction xy as [ x y ]. induction is as [ isx isy ]. apply idpath. } assert (efg : ∏ a : _, paths (f (g a)) a). { intro a. induction a as [ xis yis ]. induction xis as [ x isx ]. induction yis as [ y isy ]. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. Lemma ishinhsubtypedirprod {X Y : UU} (A : hsubtype X) (B : hsubtype Y) (isa : ishinh A) (isb : ishinh B) : ishinh (subtypesdirprod A B). Proof. intros. apply (hinhfun (invweq (weqsubtypesdirprod A B))). apply hinhand. apply isa. apply isb. Defined. (** *** A subtype with paths between any two elements is an [hProp]. *) Lemma isapropsubtype {X : UU} (A : hsubtype X) (is : ∏ (x1 x2 : X), A x1 -> A x2 -> x1 = x2) : isaprop (carrier A). Proof. intros. apply invproofirrelevance. intros x x'. assert (X0 : isincl (@pr1 _ A)). { apply isinclpr1. intro x0. apply (pr2 (A x0)). } apply (invmaponpathsincl (@pr1 _ A) X0). induction x as [ x0 is0 ]. induction x' as [ x0' is0' ]. simpl. apply (is x0 x0' is0 is0'). Defined. Definition squash_pairs_to_set {Y : UU} (F : Y -> UU) : (isaset Y) -> (∏ y y', F y -> F y' -> y = y') -> (∃ y, F y) -> Y. Proof. intros is e. set (P := ∑ y, ∥ F y ∥). assert (iP : isaprop P). { apply isapropsubtype. intros y y' f f'. apply (squash_to_prop f). apply is. clear f; intro f. apply (squash_to_prop f'). apply is. clear f'; intro f'. apply e. - assumption. - assumption. } intros w. assert (p : P). { apply (squash_to_prop w). exact iP. clear w; intro w. exact (pr1 w,,hinhpr (pr2 w)). } clear w. exact (pr1 p). Defined. Definition squash_to_set {X Y : UU} (is : isaset Y) (f : X -> Y) : (∏ x x', f x = f x') -> ∥ X ∥ -> Y. Proof. intros e w. set (P := ∑ y, ∃ x, f x = y). assert (j : isaprop P). { apply isapropsubtype; intros y y' j j'. apply (squash_to_prop j). apply is. clear j; intros [j k]. apply (squash_to_prop j'). apply is. clear j'; intros [j' k']. intermediate_path (f j). exact (!k). intermediate_path (f j'). apply e. exact k'. } assert (p : P). { apply (squash_to_prop w). exact j. intro x0. exists (f x0). apply hinhpr. exists x0. apply idpath. } exact (pr1 p). Defined. (* End of "the type of monic subtypes of a type". *) (** ** Relations on types (or equivalently relations on the sets of connected components) *) (** *** Relations and boolean relations *) Definition hrel (X : UU) : UU := X -> X -> hProp. Identity Coercion idhrel : hrel >-> Funclass. Definition brel (X : UU) : UU := X -> X -> bool. Identity Coercion idbrel : brel >-> Funclass. (** *** Standard properties of relations *) Definition istrans {X : UU} (R : hrel X) : UU := ∏ (x1 x2 x3 : X), R x1 x2 -> R x2 x3 -> R x1 x3. Definition isrefl {X : UU} (R : hrel X) : UU := ∏ x : X, R x x. Definition issymm {X : UU} (R : hrel X) : UU := ∏ (x1 x2 : X), R x1 x2 -> R x2 x1. Definition ispreorder {X : UU} (R : hrel X) : UU := istrans R × isrefl R. Definition iseqrel {X : UU} (R : hrel X) := ispreorder R × issymm R. Definition iseqrelconstr {X : UU} {R : hrel X} (trans0 : istrans R) (refl0 : isrefl R) (symm0 : issymm R) : iseqrel R := make_dirprod (make_dirprod trans0 refl0) symm0. Definition isirrefl {X : UU} (R : hrel X) : UU := ∏ x : X, ¬ R x x. Definition isasymm {X : UU} (R : hrel X) : UU := ∏ (x1 x2 : X), R x1 x2 -> R x2 x1 -> empty. Definition iscoasymm {X : UU} (R : hrel X) : UU := ∏ x1 x2, ¬ R x1 x2 -> R x2 x1. Definition istotal {X : UU} (R : hrel X) : UU := ∏ x1 x2, R x1 x2 ∨ R x2 x1. Definition isdectotal {X : UU} (R : hrel X) : UU := ∏ x1 x2, R x1 x2 ⨿ R x2 x1. Definition iscotrans {X : UU} (R : hrel X) : UU := ∏ x1 x2 x3, R x1 x3 -> R x1 x2 ∨ R x2 x3. Definition isdeccotrans {X : UU} (R : hrel X) : UU := ∏ x1 x2 x3, R x1 x3 -> R x1 x2 ⨿ R x2 x3. Definition isdecrel {X : UU} (R : hrel X) : UU := ∏ x1 x2, R x1 x2 ⨿ ¬ R x1 x2. Definition isnegrel {X : UU} (R : hrel X) : UU := ∏ x1 x2, ¬ ¬ R x1 x2 -> R x1 x2. (** Note that the property of being (co-)antisymmetric is different from other properties of relations which we consider due to the presence of [paths] in its formulation. As a consequence it behaves differently relative to the quotients of types - the quotient relation can be (co-)antisymmetric while the original relation was not. *) Definition isantisymm {X : UU} (R : hrel X) : UU := ∏ (x1 x2 : X), R x1 x2 -> R x2 x1 -> x1 = x2. Definition isPartialOrder {X : UU} (R : hrel X) : UU := ispreorder R × isantisymm R. Ltac unwrap_isPartialOrder i := induction i as [transrefl antisymm]; induction transrefl as [trans refl]. Definition isantisymmneg {X : UU} (R : hrel X) : UU := ∏ (x1 x2 : X), ¬ R x1 x2 -> ¬ R x2 x1 -> x1 = x2. Definition iscoantisymm {X : UU} (R : hrel X) : UU := ∏ x1 x2, ¬ R x1 x2 -> R x2 x1 ⨿ (x1 = x2). (** Note that the following condition on a relation is different from all the other which we have considered since it is not a property but a structure, i.e. it is in general unclear whether [isaprop (neqchoice R)] is provable. *) Definition neqchoice {X : UU} (R : hrel X) : UU := ∏ x1 x2, x1 != x2 -> R x1 x2 ⨿ R x2 x1. (** proofs that the properties are propositions *) Lemma isaprop_istrans {X : hSet} (R : hrel X) : isaprop (istrans R). Proof. intros. repeat (apply impred;intro). apply propproperty. Defined. Lemma isaprop_isrefl {X : hSet} (R : hrel X) : isaprop (isrefl R). Proof. intros. apply impred; intro. apply propproperty. Defined. Lemma isaprop_istotal {X : hSet} (R : hrel X) : isaprop (istotal R). Proof. intros. unfold istotal. apply impred; intro x. apply impred; intro y. apply propproperty. Defined. Lemma isaprop_isantisymm {X : hSet} (R : hrel X) : isaprop (isantisymm R). Proof. intros. unfold isantisymm. apply impred; intro x. apply impred; intro y. apply impred; intro r. apply impred; intro s. apply setproperty. Defined. Lemma isaprop_ispreorder {X : hSet} (R : hrel X) : isaprop (ispreorder R). Proof. intros. unfold ispreorder. apply isapropdirprod. { apply isaprop_istrans. } { apply isaprop_isrefl. } Defined. Lemma isaprop_isPartialOrder {X : hSet} (R : hrel X) : isaprop (isPartialOrder R). Proof. intros. unfold isPartialOrder. apply isapropdirprod. { apply isaprop_ispreorder. } { apply isaprop_isantisymm. } Defined. (** the relations on a set form a set *) Definition isaset_hrel (X : hSet) : isaset (hrel X). intros. unfold hrel. apply impred_isaset; intro x. apply impred_isaset; intro y. exact isasethProp. Defined. (** *** Elementary implications between properties of relations *) Lemma istransandirrefltoasymm {X : UU} {R : hrel X} (is1 : istrans R) (is2 : isirrefl R) : isasymm R. Proof. intros. intros a b rab rba. apply (is2 _ (is1 _ _ _ rab rba)). Defined. Lemma istotaltoiscoasymm {X : UU} {R : hrel X} (is : istotal R) : iscoasymm R. Proof. intros. intros x1 x2. apply (hdisjtoimpl (is _ _)). Defined. Lemma isdecreltoisnegrel {X : UU} {R : hrel X} (is : isdecrel R) : isnegrel R. Proof. intros. intros x1 x2. induction (is x1 x2) as [ r | nr ]. - intro. apply r. - intro nnr. induction (nnr nr). Defined. Lemma isantisymmnegtoiscoantisymm {X : UU} {R : hrel X} (isdr : isdecrel R) (isr : isantisymmneg R) : iscoantisymm R. Proof. intros. intros x1 x2 nrx12. induction (isdr x2 x1) as [ r | nr ]. apply (ii1 r). apply ii2. apply (isr _ _ nrx12 nr). Defined. Lemma rtoneq {X : UU} {R : hrel X} (is : isirrefl R) {a b : X} (r : R a b) : a != b. Proof. intros. intro e. rewrite e in r. apply (is b r). Defined. (** *** Standard properties of relations and logical equivalences *) Definition hrellogeq {X : UU} (L R : hrel X) : UU := ∏ x1 x2, (L x1 x2 <-> R x1 x2). Definition istranslogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : istrans L) : istrans R. Proof. intros. intros x1 x2 x3 r12 r23. apply ((pr1 (lg _ _)) (isl _ _ _ ((pr2 (lg _ _)) r12) ((pr2 (lg _ _)) r23))). Defined. Definition isrefllogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isrefl L) : isrefl R. Proof. intros. intro x. apply (pr1 (lg _ _) (isl x)). Defined. Definition issymmlogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : issymm L) : issymm R. Proof. intros. intros x1 x2 r12. apply (pr1 (lg _ _) (isl _ _ (pr2 (lg _ _) r12))). Defined. Definition ispologeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : ispreorder L) : ispreorder R. Proof. intros. apply (make_dirprod (istranslogeqf lg (pr1 isl)) (isrefllogeqf lg (pr2 isl))). Defined. Definition iseqrellogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : iseqrel L) : iseqrel R. Proof. intros. apply (make_dirprod (ispologeqf lg (pr1 isl)) (issymmlogeqf lg (pr2 isl))). Defined. Definition isirrefllogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isirrefl L) : isirrefl R. Proof. intros. intros x r. apply (isl _ (pr2 (lg x x) r)). Defined. Definition isasymmlogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isasymm L) : isasymm R. Proof. intros. intros x1 x2 r12 r21. apply (isl _ _ (pr2 (lg _ _) r12) (pr2 (lg _ _) r21)). Defined. Definition iscoasymmlogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : iscoasymm L) : iscoasymm R. Proof. intros. intros x1 x2 r12. apply ((pr1 (lg _ _)) (isl _ _ (negf (pr1 (lg _ _)) r12))). Defined. Definition istotallogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : istotal L) : istotal R. Proof. intros. intros x1 x2. set (int := isl x1 x2). generalize int. clear int. simpl. apply hinhfun. apply (coprodf (pr1 (lg x1 x2)) (pr1 (lg x2 x1))). Defined. Definition iscotranslogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : iscotrans L) : iscotrans R. Proof. intros. intros x1 x2 x3 r13. set (int := isl x1 x2 x3 (pr2 (lg _ _) r13)). generalize int. clear int. simpl. apply hinhfun. apply (coprodf (pr1 (lg x1 x2)) (pr1 (lg x2 x3))). Defined. Definition isdecrellogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isdecrel L) : isdecrel R. Proof. intros. intros x1 x2. induction (isl x1 x2) as [ l | nl ]. - apply (ii1 (pr1 (lg _ _) l)). - apply (ii2 (negf (pr2 (lg _ _)) nl)). Defined. Definition isnegrellogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isnegrel L) : isnegrel R. Proof. intros. intros x1 x2 nnr. apply ((pr1 (lg _ _)) (isl _ _ (negf (negf (pr2 (lg _ _))) nnr))). Defined. Definition isantisymmlogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isantisymm L) : isantisymm R. Proof. intros. intros x1 x2 r12 r21. apply (isl _ _ (pr2 (lg _ _) r12) (pr2 (lg _ _) r21)). Defined. Definition isantisymmneglogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : isantisymmneg L) : isantisymmneg R. Proof. intros. intros x1 x2 nr12 nr21. apply (isl _ _ (negf (pr1 (lg _ _)) nr12) (negf (pr1 (lg _ _)) nr21)). Defined. Definition iscoantisymmlogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : iscoantisymm L) : iscoantisymm R. Proof. intros. intros x1 x2 r12. set (int := isl _ _ (negf (pr1 (lg _ _)) r12)). generalize int. clear int. simpl. apply (coprodf (pr1 (lg _ _)) (idfun _)). Defined. Definition neqchoicelogeqf {X : UU} {L R : hrel X} (lg : ∏ x1 x2, L x1 x2 <-> R x1 x2) (isl : neqchoice L) : neqchoice R. Proof. intros. intros x1 x2 ne. apply (coprodf (pr1 (lg x1 x2)) (pr1 (lg x2 x1)) (isl _ _ ne)). Defined. (** *** Preorderings, partial orderings, and associated types. *) (* preoderings *) Definition po (X : UU) : UU := ∑ R : hrel X, ispreorder R. Definition make_po {X : UU} (R : hrel X) (is : ispreorder R) : po X := tpair ispreorder R is. Definition carrierofpo (X : UU) : po X -> (X -> X -> hProp) := @pr1 _ ispreorder. Coercion carrierofpo : po >-> Funclass. Definition PreorderedSet : UU := ∑ X : hSet, po X. Definition PreorderedSetPair (X : hSet) (R :po X) : PreorderedSet := tpair _ X R. Definition carrierofPreorderedSet : PreorderedSet -> hSet := pr1. Coercion carrierofPreorderedSet : PreorderedSet >-> hSet. Definition PreorderedSetRelation (X : PreorderedSet) : hrel X := pr1 (pr2 X). (* partial orderings *) Definition PartialOrder (X : hSet) : UU := ∑ R : hrel X, isPartialOrder R. Definition make_PartialOrder {X : hSet} (R : hrel X) (is : isPartialOrder R) : PartialOrder X := tpair isPartialOrder R is. Definition carrierofPartialOrder {X : hSet} : PartialOrder X -> hrel X := pr1. Coercion carrierofPartialOrder : PartialOrder >-> hrel. Definition Poset : UU := ∑ X, PartialOrder X. Definition make_Poset (X : hSet) (R : PartialOrder X) : Poset := tpair PartialOrder X R. Definition carrierofposet : Poset -> hSet := pr1. Coercion carrierofposet : Poset >-> hSet. Definition posetRelation (X : Poset) : hrel X := pr1 (pr2 X). Lemma isrefl_posetRelation (X : Poset) : isrefl (posetRelation X). Proof. intros x. exact (pr2 (pr1 (pr2 (pr2 X))) x). Defined. Lemma istrans_posetRelation (X : Poset) : istrans (posetRelation X). Proof. intros x y z l m. exact (pr1 (pr1 (pr2 (pr2 X))) x y z l m). Defined. Lemma isantisymm_posetRelation (X : Poset) : isantisymm (posetRelation X). Proof. intros x y l m. exact (pr2 (pr2 (pr2 X)) x y l m). Defined. Declare Scope poset. Delimit Scope poset with poset. Notation "m ≤ n" := (posetRelation _ m n) (no associativity, at level 70) : poset. Definition isaposetmorphism {X Y : Poset} (f : X -> Y) := (∏ x x' : X, x ≤ x' -> f x ≤ f x')%poset. Definition posetmorphism (X Y : Poset) : UU := total2 (fun f : X -> Y => isaposetmorphism f). Definition make_posetmorphism (X Y : Poset) : ∏ t : X → Y, isaposetmorphism t → ∑ f : X → Y, isaposetmorphism f := tpair (fun f : X -> Y => isaposetmorphism f). Definition carrierofposetmorphism (X Y : Poset) : posetmorphism X Y -> (X -> Y) := @pr1 _ _. Coercion carrierofposetmorphism : posetmorphism >-> Funclass. Definition isdec_ordering (X : Poset) : UU := ∏ (x y : X), decidable (x ≤ y)%poset. Lemma isaprop_isaposetmorphism {X Y : Poset} (f : X -> Y) : isaprop (isaposetmorphism f). Proof. intros. apply impredtwice; intros. apply impred_prop. Defined. (** the preorders on a set form a set *) Definition isaset_po (X : hSet) : isaset (po X). intros. unfold po. apply (isofhleveltotal2 2). { apply isaset_hrel. } intros x. apply hlevelntosn. apply isaprop_ispreorder. Defined. (** the partial orders on a set form a set *) Definition isaset_PartialOrder X : isaset (PartialOrder X). intros. unfold PartialOrder. apply (isofhleveltotal2 2). { apply isaset_hrel. } intros x. apply hlevelntosn. apply isaprop_isPartialOrder. Defined. (** poset equivalences *) Definition isPosetEquivalence {X Y : Poset} (f : X ≃ Y) := isaposetmorphism f × isaposetmorphism (invmap f). Lemma isaprop_isPosetEquivalence {X Y : Poset} (f : X ≃ Y) : isaprop (isPosetEquivalence f). Proof. intros. unfold isPosetEquivalence. apply isapropdirprod; apply isaprop_isaposetmorphism. Defined. Definition isPosetEquivalence_idweq (X : Poset) : isPosetEquivalence (idweq X). Proof. intros. split. - intros x y le. exact le. - intros x y le. exact le. Defined. Definition PosetEquivalence (X Y : Poset) : UU := ∑ f : X ≃ Y, isPosetEquivalence f. Local Open Scope poset. Notation "X ≅ Y" := (PosetEquivalence X Y) (at level 60, no associativity) : poset. (* written \cong in Agda input method *) Definition posetUnderlyingEquivalence {X Y : Poset} : X ≅ Y -> X ≃ Y := pr1. Coercion posetUnderlyingEquivalence : PosetEquivalence >-> weq. Definition identityPosetEquivalence (X : Poset) : PosetEquivalence X X. Proof. intros. exists (idweq X). apply isPosetEquivalence_idweq. Defined. Lemma isincl_pr1_PosetEquivalence (X Y : Poset) : isincl (pr1 : X ≅ Y -> X ≃ Y). Proof. intros. apply isinclpr1. apply isaprop_isPosetEquivalence. Defined. Lemma isinj_pr1_PosetEquivalence (X Y : Poset) : isInjective (pr1 : X ≅ Y -> X ≃ Y). Proof. intros f g. apply isweqonpathsincl. apply isincl_pr1_PosetEquivalence. Defined. (** poset concepts *) Notation "m < n" := (m ≤ n × m != n)%poset (only parsing) : poset. Definition isMinimal {X : Poset} (x : X) : UU := ∏ y, x ≤ y. Definition isMaximal {X : Poset} (x : X) : UU := ∏ y, y ≤ x. Definition consecutive {X : Poset} (x y : X) : UU := x < y × ∏ z, ¬ (x < z × z < y). Lemma isaprop_isMinimal {X : Poset} (x : X) : isaprop (isMaximal x). Proof. intros. unfold isMaximal. apply impred_prop. Defined. Lemma isaprop_isMaximal {X : Poset} (x : X) : isaprop (isMaximal x). Proof. intros. unfold isMaximal. apply impred_prop. Defined. Lemma isaprop_consecutive {X : Poset} (x y : X) : isaprop (consecutive x y). Proof. intros. unfold consecutive. apply isapropdirprod. - apply isapropdirprod. { apply pr2. } simpl. apply isapropneg. - apply impred; intro z. apply isapropneg. Defined. (** *** Eqivalence relations and associated types. *) Definition eqrel (X : UU) : UU := total2 (λ R : hrel X, iseqrel R). Definition make_eqrel {X : UU} (R : hrel X) (is : iseqrel R) : eqrel X := tpair (λ R : hrel X, iseqrel R) R is. Definition eqrelconstr {X : UU} (R : hrel X) (is1 : istrans R) (is2 : isrefl R) (is3 : issymm R) : eqrel X := make_eqrel R (make_dirprod (make_dirprod is1 is2) is3). Definition pr1eqrel (X : UU) : eqrel X -> (X -> (X -> hProp)) := @pr1 _ _. Coercion pr1eqrel : eqrel >-> Funclass. Definition eqreltrans {X : UU} (R : eqrel X) : istrans R := pr1 (pr1 (pr2 R)). Definition eqrelrefl {X : UU} (R : eqrel X) : isrefl R := pr2 (pr1 (pr2 R)). Definition eqrelsymm {X : UU} (R : eqrel X) : issymm R := pr2 (pr2 R). (** *** Direct product of two relations *) Definition hreldirprod {X Y : UU} (RX : hrel X) (RY : hrel Y) : hrel (X × Y) := λ xy xy' : dirprod X Y, hconj (RX (pr1 xy) (pr1 xy')) (RY (pr2 xy) (pr2 xy')). Definition istransdirprod {X Y : UU} (RX : hrel X) (RY : hrel Y) (isx : istrans RX) (isy : istrans RY) : istrans (hreldirprod RX RY) := λ xy1 xy2 xy3 : _, λ is12 : _ , λ is23 : _, make_dirprod (isx _ _ _ (pr1 is12) (pr1 is23)) (isy _ _ _ (pr2 is12) (pr2 is23)). Definition isrefldirprod {X Y : UU} (RX : hrel X) (RY : hrel Y) (isx : isrefl RX) (isy : isrefl RY) : isrefl (hreldirprod RX RY) := λ xy : _, make_dirprod (isx _) (isy _). Definition issymmdirprod {X Y : UU} (RX : hrel X) (RY : hrel Y) (isx : issymm RX) (isy : issymm RY) : issymm (hreldirprod RX RY) := λ xy1 xy2 : _, λ is12 : _, make_dirprod (isx _ _ (pr1 is12)) (isy _ _ (pr2 is12)). Definition eqreldirprod {X Y : UU} (RX : eqrel X) (RY : eqrel Y) : eqrel (X × Y) := eqrelconstr (hreldirprod RX RY) (istransdirprod _ _ (eqreltrans RX) (eqreltrans RY)) (isrefldirprod _ _ (eqrelrefl RX) (eqrelrefl RY)) (issymmdirprod _ _ (eqrelsymm RX) (eqrelsymm RY)). (** *** Negation of a relation and its properties *) Definition negrel {X : UU} (R : hrel X) : hrel X := λ x x', make_hProp (¬ R x x') (isapropneg _). (* uses [funextemptyAxiom] *) Lemma istransnegrel {X : UU} (R : hrel X) (isr : iscotrans R) : istrans (negrel R). (* uses [funextfun] and [funextemptyAxiom] *) Proof. intros. intros x1 x2 x3 r12 r23. apply (negf (isr x1 x2 x3)). apply (toneghdisj (make_dirprod r12 r23)). Defined. Lemma isasymmnegrel {X : UU} (R : hrel X) (isr : iscoasymm R) : isasymm (negrel R). Proof. intros. intros x1 x2 r12 r21. apply (r21 (isr _ _ r12)). Defined. Lemma iscoasymmgenrel {X : UU} (R : hrel X) (isr : isasymm R) : iscoasymm (negrel R). Proof. intros. intros x1 x2 nr12. apply (negf (isr _ _) nr12). Defined. Lemma isdecnegrel {X : UU} (R : hrel X) (isr : isdecrel R) : isdecrel (negrel R). (* uses [funextemptyAxiom] *) Proof. intros. intros x1 x2. induction (isr x1 x2) as [ r | nr ]. - apply ii2. apply (todneg _ r). - apply (ii1 nr). Defined. Lemma isnegnegrel {X : UU} (R : hrel X) : isnegrel (negrel R). Proof. intros. intros x1 x2. apply (negf (todneg (R x1 x2))). Defined. Lemma isantisymmnegrel {X : UU} (R : hrel X) (isr : isantisymmneg R) : isantisymm (negrel R). Proof. intros. apply isr. Defined. (** *** Boolean representation of decidable equality *) Definition eqh {X : UU} (is : isdeceq X) : hrel X := λ x x', make_hProp (booleq is x x' = true) (isasetbool (booleq is x x') true). Definition neqh {X : UU} (is : isdeceq X) : hrel X := λ x x', make_hProp (booleq is x x' = false) (isasetbool (booleq is x x') false). Lemma isrefleqh {X : UU} (is : isdeceq X) : isrefl (eqh is). Proof. intros. unfold eqh. unfold booleq. intro x. induction (is x x) as [ e | ne ]. - simpl. apply idpath. - induction (ne (idpath x)). Defined. Definition weqeqh {X : UU} (is : isdeceq X) (x x' : X) : (x = x') ≃ (eqh is x x'). Proof. intros. apply weqimplimpl. - intro e. induction e. apply isrefleqh. - intro e. unfold eqh in e. unfold booleq in e. induction (is x x') as [ e' | ne' ]. + apply e'. + induction (nopathsfalsetotrue e). - unfold isaprop. unfold isofhlevel. apply (isasetifdeceq X is x x'). - unfold eqh. simpl. unfold isaprop. unfold isofhlevel. apply (isasetbool _ true). Defined. Definition weqneqh {X : UU} (is : isdeceq X) (x x' : X) : (x != x') ≃ (neqh is x x'). Proof. intros. unfold neqh. unfold booleq. apply weqimplimpl. - induction (is x x') as [ e | ne ]. + intro ne. induction (ne e). + intro ne'. simpl. apply idpath. - induction (is x x') as [ e | ne ]. + intro tf. induction (nopathstruetofalse tf). + intro. exact ne. - apply (isapropneg). - simpl. unfold isaprop. unfold isofhlevel. apply (isasetbool _ false). Defined. (** *** Boolean representation of decidable relations *) Definition decrel (X : UU) : UU := total2 (λ R : hrel X, isdecrel R). Definition pr1decrel (X : UU) : decrel X -> hrel X := @pr1 _ _. Definition make_decrel {X : UU} {R : hrel X} (is : isdecrel R) : decrel X := tpair _ R is. Coercion pr1decrel : decrel >-> hrel. Definition decreltobrel {X : UU} (R : decrel X) : brel X. Proof. intros. intros x x'. induction ((pr2 R) x x'). - apply true. - apply false. Defined. Definition breltodecrel {X : UU} (B : brel X) : decrel X := @make_decrel _ (λ x x', make_hProp ((B x x') = true) (isasetbool _ _)) (λ x x', (isdeceqbool _ _)). Definition pathstor {X : UU} (R : decrel X) (x x' : X) (e : decreltobrel R x x' = true) : R x x'. Proof. unfold decreltobrel in e. induction (pr2 R x x') as [ e' | ne ]. - apply e'. - induction (nopathsfalsetotrue e). Defined. Definition rtopaths {X : UU} (R : decrel X) (x x' : X) (r : R x x') : decreltobrel R x x' = true. Proof. unfold decreltobrel. intros. induction ((pr2 R) x x') as [ r' | nr ]. - apply idpath. - induction (nr r). Defined. Definition pathstonegr {X : UU} (R : decrel X) (x x' : X) (e : decreltobrel R x x' = false) : neg (R x x'). Proof. unfold decreltobrel in e. induction (pr2 R x x') as [ e' | ne ]. - induction (nopathstruetofalse e). - apply ne. Defined. Definition negrtopaths {X : UU} (R : decrel X) (x x' : X) (nr : neg (R x x')) : decreltobrel R x x' = false. Proof. unfold decreltobrel. intros. induction (pr2 R x x') as [ r | nr' ]. - induction (nr r). - apply idpath. Defined. (** The following construction of "ct" ("canonical term") is inspired by the ideas of George Gonthier. The expression [ct (R, x, y)] where [R] is in [hrel X] for some [X] and has a canonical structure of a decidable relation and [x, y] are closed terms of type [X] such that [R x y] is inhabited is the term of type [R x y] which relizes the canonical term in [isdecrel R x y]. Definition pathstor_comp {X : UU} (R : decrel X) (x x' : X) (e : (decreltobrel R x x') = true) : R x x'. Proof. unfold decreltobrel. intros. induction (pr2 R x x') as [ e' | ne ]. apply e'. induction (nopathsfalsetotrue e). Defined. Notation " 'ct' (R, x, y) " := ((pathstor_comp _ x y (idpath true)) : R x y) (at level 70). *) Definition ctlong {X : UU} (R : hrel X) (is : isdecrel R) (x x' : X) (e : decreltobrel (make_decrel is) x x' = true) : R x x'. Proof. unfold decreltobrel in e. simpl in e. induction (is x x') as [ e' | ne ]. - apply e'. - induction (nopathsfalsetotrue e). Defined. Notation " 'ct' ( R , is , x , y ) " := (ctlong R is x y (idpath true)) (at level 70). (* Tactics for computing with decidable relations A tactic alternative to [ct], with negation If [R x y] is a decidable relation on a type [X], then, by definition, we have a proof [d] of [R x y ⨿ ¬ R x y]. If [x] and [y] are constants (definable in an empty context), then simplification of [d] will yield either a term of the form [inl p] or [inr q], depending on whether [R x y] is true or false. Let us suppose the answer turns out to be true. Then if our current proof goal is [R x y], then we can automate the proof by first converting [R] to a binary relation [S], so that [S x y] simplifies to [true]. Then we know that a proof of [S x y = true] is [idpath true], and we can convert that into a proof of [R x y] using a proof of the implication [S x y = true → R x y]. Similarly, if the answer turns out to be false, then we know that a proof of [S x y = false] is [idpath false], and we can convert that into a proof of [¬ R x y]. The tactics [confirm_equal] and [confirm_not_equal] make this strategy concise when the goal is of the form [x = y] or [x != y] and we have a proof [i] that equality is decidable. (It would be redundant to also have a proof that inequality is decidable.) To evaluate whether having a tactic simplifies things, compare the proofs of [hzbooleqisi] and [hzbooleqisi'] in Integers.v. *) Definition deceq_to_decrel {X:UU} : isdeceq X -> decrel X. Proof. intros i. use make_decrel. - intros x y. exists (x=y). apply isasetifdeceq. assumption. - exact i. Defined. Definition confirm_equal {X : UU} (i : isdeceq X) (x x' : X) (e : decreltobrel (deceq_to_decrel i) x x' = true) : x = x'. Proof. intros. exact (pathstor (deceq_to_decrel i) _ _ e). Defined. Definition confirm_not_equal {X : UU} (i : isdeceq X) (x x' : X) (e : decreltobrel (deceq_to_decrel i) x x' = false) : x != x'. Proof. intros. exact (pathstonegr (deceq_to_decrel i) _ _ e). Defined. (* I don't know why exact_op works better here, but with "exact", the code in RealNumbers/Prelim.v breaks *) Ltac confirm_yes d x y := exact_op (pathstor d x y (idpath true)). Ltac confirm_no d x y := exact_op (pathstonegr d x y (idpath false)). Ltac confirm_equal i := match goal with |- ?x = ?y => confirm_yes (deceq_to_decrel i) x y end. Ltac confirm_not_equal i := match goal with |- ?x != ?y => confirm_no (deceq_to_decrel i) x y end. Ltac confirm_equal_absurd i := match goal with |- ?x = ?y → ∅ => confirm_no (deceq_to_decrel i) x y end. (** *** Restriction of a relation to a subtype *) Definition resrel {X : UU} (L : hrel X) (P : hsubtype X) : hrel P := λ p1 p2, L (pr1 p1) (pr1 p2). Definition istransresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : istrans L) : istrans (resrel L P). Proof. intros. intros x1 x2 x3 r12 r23. apply (isl _ (pr1 x2) _ r12 r23). Defined. Definition isreflresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isrefl L) : isrefl (resrel L P). Proof. intros. intro x. apply isl. Defined. Definition issymmresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : issymm L) : issymm (resrel L P). Proof. intros. intros x1 x2 r12. apply isl. apply r12. Defined. Definition isporesrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : ispreorder L) : ispreorder (resrel L P). Proof. intros. apply (make_dirprod (istransresrel L P (pr1 isl)) (isreflresrel L P (pr2 isl))). Defined. Definition iseqrelresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : iseqrel L) : iseqrel (resrel L P). Proof. intros. apply (make_dirprod (isporesrel L P (pr1 isl)) (issymmresrel L P (pr2 isl))). Defined. Definition isirreflresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isirrefl L) : isirrefl (resrel L P). Proof. intros. intros x r. apply (isl _ r). Defined. Definition isasymmresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isasymm L) : isasymm (resrel L P). Proof. intros. intros x1 x2 r12 r21. apply (isl _ _ r12 r21). Defined. Definition iscoasymmresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : iscoasymm L) : iscoasymm (resrel L P). Proof. intros. intros x1 x2 r12. apply (isl _ _ r12). Defined. Definition istotalresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : istotal L) : istotal (resrel L P). Proof. intros. intros x1 x2. apply isl. Defined. Definition iscotransresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : iscotrans L) : iscotrans (resrel L P). Proof. intros. intros x1 x2 x3 r13. apply (isl _ _ _ r13). Defined. Definition isdecrelresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isdecrel L) : isdecrel (resrel L P). Proof. intros. intros x1 x2. apply isl. Defined. Definition isnegrelresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isnegrel L) : isnegrel (resrel L P). Proof. intros. intros x1 x2 nnr. apply (isl _ _ nnr). Defined. Definition isantisymmresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isantisymm L) : isantisymm (resrel L P). Proof. intros. intros x1 x2 r12 r21. apply (invmaponpathsincl _ (isinclpr1carrier _) _ _ (isl _ _ r12 r21)). Defined. Definition isantisymmnegresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : isantisymmneg L) : isantisymmneg (resrel L P). Proof. intros. intros x1 x2 nr12 nr21. apply (invmaponpathsincl _ (isinclpr1carrier _) _ _ (isl _ _ nr12 nr21)). Defined. Definition iscoantisymmresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : iscoantisymm L) : iscoantisymm (resrel L P). Proof. intros. intros x1 x2 r12. induction (isl _ _ r12) as [ l | e ]. - apply (ii1 l). - apply ii2. apply (invmaponpathsincl _ (isinclpr1carrier _) _ _ e). Defined. Definition neqchoiceresrel {X : UU} (L : hrel X) (P : hsubtype X) (isl : neqchoice L) : neqchoice (resrel L P). Proof. intros. intros x1 x2 ne. set (int := negf (invmaponpathsincl _ (isinclpr1carrier P) _ _) ne). apply (isl _ _ int). Defined. (** *** Equivalence classes with respect to a given relation *) Definition iseqclass {X : UU} (R : hrel X) (A : hsubtype X) : UU := dirprod (ishinh (carrier A)) (dirprod (∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2) (∏ x1 x2 : X, A x1 -> A x2 -> R x1 x2)). Definition iseqclassconstr {X : UU} (R : hrel X) {A : hsubtype X} (ax0 : ishinh (carrier A)) (ax1 : ∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2) (ax2 : ∏ x1 x2 : X, A x1 -> A x2 -> R x1 x2) : iseqclass R A := make_dirprod ax0 (make_dirprod ax1 ax2). Definition eqax0 {X : UU} {R : hrel X} {A : hsubtype X} : iseqclass R A -> ishinh (carrier A) := λ is : iseqclass R A, pr1 is. Definition eqax1 {X : UU} {R : hrel X} {A : hsubtype X} : iseqclass R A -> ∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2 := λ is : iseqclass R A, pr1 (pr2 is). Definition eqax2 {X : UU} {R : hrel X} {A : hsubtype X} : iseqclass R A -> ∏ x1 x2 : X, A x1 -> A x2 -> R x1 x2 := λ is : iseqclass R A, pr2 (pr2 is). Lemma isapropiseqclass {X : UU} (R : hrel X) (A : hsubtype X) : isaprop (iseqclass R A). Proof. apply isofhleveldirprod. - exact (isapropishinh (carrier A)). - apply isofhleveldirprod. + repeat (apply impred; intro). exact (pr2 (A t0)). + repeat (apply impred; intro). exact (pr2 (R t t0)). Defined. (** *** Direct product of equivalence classes *) Lemma iseqclassdirprod {X Y : UU} {R : hrel X} {Q : hrel Y} {A : hsubtype X} {B : hsubtype Y} (isa : iseqclass R A) (isb : iseqclass Q B) : iseqclass (hreldirprod R Q) (subtypesdirprod A B). Proof. intros. set (XY := dirprod X Y). set (AB := subtypesdirprod A B). set (RQ := hreldirprod R Q). set (ax0 := ishinhsubtypedirprod A B (eqax0 isa) (eqax0 isb)). assert (ax1 : ∏ xy1 xy2 : XY, RQ xy1 xy2 -> AB xy1 -> AB xy2). { intros xy1 xy2 rq ab1. apply (make_dirprod (eqax1 isa _ _ (pr1 rq) (pr1 ab1)) (eqax1 isb _ _ (pr2 rq) (pr2 ab1))). } assert (ax2 : ∏ xy1 xy2 : XY, AB xy1 -> AB xy2 -> RQ xy1 xy2). { intros xy1 xy2 ab1 ab2. apply (make_dirprod (eqax2 isa _ _ (pr1 ab1) (pr1 ab2)) (eqax2 isb _ _ (pr2 ab1) (pr2 ab2))). } apply (iseqclassconstr _ ax0 ax1 ax2). Defined. (** ** Surjections to sets are epimorphisms *) Theorem surjectionisepitosets {X Y Z : UU} (f : X -> Y) (g1 g2 : Y -> Z) (is1 : issurjective f) (is2 : isaset Z) (isf : ∏ x : X, g1 (f x) = g2 (f x)) : ∏ y : Y, g1 y = g2 y. Proof. intros. set (P1:= make_hProp (paths (g1 y) (g2 y)) (is2 (g1 y) (g2 y))). unfold issurjective in is1. assert (s1: (hfiber f y)-> paths (g1 y) (g2 y)). { intro X1. induction X1 as [t x ]. induction x. apply (isf t). } assert (s2: ishinh (paths (g1 y) (g2 y))) by apply (hinhfun s1 (is1 y)). set (is3 := is2 (g1 y) (g2 y)). simpl in is3. apply (@hinhuniv (paths (g1 y) (g2 y)) (make_hProp _ is3)). - intro X1. assumption. - assumption. Defined. (** ** Epimorphisms are surjections to sets The proof goes as follows : Let p : A -> B be an epi. Let f,g : B -> P(B) defined by f(x) = {x} g(x) = p(p^-1({x})) (either {x} or the empty set if x is not in the image) Then f o p = g o p, so f = g, so p is surjective *) Lemma isaset_set_fun_space A (B : hSet) : isaset (A -> B). Proof. intros. change isaset with (isofhlevel 2). apply impred. apply (λ _, (pr2 B)). Qed. (** TODO find a proof without univalence for propositions (if possible) *) Lemma epiissurjectiontosets {A B : UU} (p : A -> B) (isB:isaset B) (epip : ∏ (C:hSet) (g1 g2:B->C), (∏ x : A, g1 (p x) = g2 (p x)) -> (∏ y : B, g1 y = g2 y)) : issurjective p. Proof. intros. assert(pred_set : isaset (B -> hProp)). { apply (isaset_set_fun_space _ (make_hSet _ isasethProp)). } specialize (epip (make_hSet _ pred_set) (λ b x, ∥ ∑ y : hfiber p b, x = p (pr1 y) ∥ ) (λ b x, make_hProp (x = b) (isB x b)) ). lapply epip. - intro h. intro y. specialize (h y). apply toforallpaths in h. specialize (h y). cbn in h. match type of h with _ = ?type_witn => set (typ:= type_witn) in h end. assert (witness:typ ). { apply idpath. } revert witness. rewrite <- h. apply hinhfun. intro h'. exact (pr1 h'). - intro b. apply funextfun. intro x; cbn. apply weqtopathshProp. apply logeqweq. + apply hinhuniv. intros [y eqx]. rewrite eqx. apply (hfiberpr2 _ _ y). + intro eqx. apply hinhpr. use tpair. * exists b. apply idpath. * exact eqx. Qed. (** ** Universal property enjoyed by surjections << f A ---> C | | p | v B >> If p is surjective and forall x, y dans A, p(x)=p(y) => f(x)=f(y) then there exists a unique function from B to C that makes the diagram commute *) Section LiftSurjection. Context {A B C :UU}. Hypothesis hsc:isaset C. Variables (p : A -> B ) (f: A -> C ). Hypothesis comp_f_epi: ∏ x y, p x = p y -> f x = f y. Hypothesis surjectivep : issurjective p. (* Reformulation of the previous hypothesis *) Lemma surjective_iscontr_im : ∏ b : B, iscontr (image (λ (x:hfiber p b), f (pr1 x))). Proof. intro b. apply (squash_to_prop (surjectivep b)). { apply isapropiscontr. } intro H. apply iscontraprop1. (* inspired by isapropimeqclass *) - apply isapropsubtype. intros x1 x2. apply (@hinhuniv2 _ _ (make_hProp _ (hsc _ _))). simpl; intros y1 y2; simpl. induction y1 as [ [z1 h1] h1' ]. induction y2 as [ [z2 h2] h2' ]. rewrite <- h1' ,<-h2'. apply comp_f_epi;simpl. rewrite h1,h2. apply idpath. - apply prtoimage. apply H. Defined. Definition univ_surj : B -> C := λ b, (pr1 (pr1 (surjective_iscontr_im b))). Lemma univ_surj_ax : ∏ x, univ_surj (p x) = f x. Proof. intro x. apply pathsinv0. apply path_to_ctr. apply (squash_to_prop (surjectivep (p x))). { apply isapropishinh. } intro r. apply hinhpr. exists r. apply comp_f_epi. apply (pr2 r). Qed. Lemma univ_surj_unique : ∏ (g : B -> C) (H : ∏ a : A, g (p a) = f a) (b : B), g b = univ_surj b. Proof. intros g H b. apply (surjectionisepitosets p); [assumption|assumption|]. intro x. rewrite H,univ_surj_ax. apply idpath. Qed. End LiftSurjection. (** ** Set quotients of types. In this file we study the set quotients of types by equivalence relations. While the general notion of a quotient of a type by a relation is complicated due to the existence of different kinds of quotients (e.g. homotopy quotients or categorical quotients in the homotopy category which are usually different from each other) there is one particular class of quotients which is both very important for applications and semantically straightforward. These quotients are the universal functions from a type to an hset which respect a given relation. Some of the proofs in this section depend on the proerties of the hinhabited construction and some also depend on the univalence axiom for [hProp] which allows us to prove that the type of monic subtypes of a type is a set. Our main construction is analogous to the usual construction of quotient as a set of equivalence classes. Wev also consider another construction of [setquot] which is analogous (on the next h-level) to our construction of [ishinh]. Both have generalizations to the "higher" quotients (i.e. groupoid quotients etc.) which will be considered separately. In particular, the quotients the next h-level appear to be closely related to the localizations of categories and will be considered in the section about types of h-level 3. *) (** *** Setquotient defined in terms of equivalence classes *) Definition setquot {X : UU} (R : hrel X) : UU := total2 (λ A : _, iseqclass R A). Definition make_setquot {X : UU} (R : hrel X) (A : hsubtype X) (is : iseqclass R A) : setquot R := tpair _ A is. Definition pr1setquot {X : UU} (R : hrel X) : setquot R -> (hsubtype X) := @pr1 _ (λ A : _, iseqclass R A). Coercion pr1setquot : setquot >-> hsubtype. Lemma isinclpr1setquot {X : UU} (R : hrel X) : isincl (pr1setquot R). Proof. apply isinclpr1. intro x0. apply isapropiseqclass. Defined. Theorem isasetsetquot {X : UU} (R : hrel X) : isaset (setquot R). Proof. apply (isasetsubset (@pr1 _ _) (isasethsubtype X)). apply isinclpr1; intro x. apply isapropiseqclass. Defined. Definition setquotinset {X : UU} (R : hrel X) : hSet := make_hSet _ (isasetsetquot R). Theorem setquotpr {X : UU} (R : eqrel X) : X -> setquot R. Proof. intros X0. set (rax := eqrelrefl R). set (sax := eqrelsymm R). set (tax := eqreltrans R). apply (tpair _ (λ x : X, R X0 x)). split. - exact (hinhpr (tpair _ X0 (rax X0))). - split; intros x1 x2 X1 X2. + exact (tax X0 x1 x2 X2 X1). + exact (tax x1 X0 x2 (sax X0 x1 X1) X2). Defined. Lemma setquotl0 {X : UU} (R : eqrel X) (c : setquot R) (x : c) : setquotpr R (pr1 x) = c. Proof. apply (invmaponpathsincl _ (isinclpr1setquot R)). apply funextsec; intro x0. apply hPropUnivalence; intro r. - exact (eqax1 (pr2 c) (pr1 x) x0 r (pr2 x)). - exact (eqax2 (pr2 c) (pr1 x) x0 (pr2 x) r). Defined. Theorem issurjsetquotpr {X : UU} (R : eqrel X) : issurjective (setquotpr R). Proof. intros. unfold issurjective. intro c. apply (@hinhuniv (carrier (pr1 c))). intro x. apply hinhpr. split with (pr1 x). - apply setquotl0. - apply (eqax0 (pr2 c)). Defined. Lemma iscompsetquotpr {X : UU} (R : eqrel X) (x x' : X) (a : R x x') : setquotpr R x = setquotpr R x'. Proof. intros. apply (invmaponpathsincl _ (isinclpr1setquot R)). simpl. apply funextsec. intro x0. apply hPropUnivalence. intro r0. apply (eqreltrans R _ _ _ (eqrelsymm R _ _ a) r0). intro x0'. apply (eqreltrans R _ _ _ a x0'). Defined. (** *** Universal property of [seqtquot R] for functions to sets satisfying compatibility condition [iscomprelfun] *) Definition iscomprelfun {X Y : UU} (R : hrel X) (f : X -> Y) : UU := ∏ x x' : X, R x x' -> f x = f x'. Lemma iscomprelfunlogeqf {X Y : UU} {R L : hrel X} (lg : hrellogeq L R) (f : X -> Y) (is : iscomprelfun L f) : iscomprelfun R f. Proof. intros. intros x x' r. apply (is _ _ (pr2 (lg _ _) r)). Defined. Lemma isapropimeqclass {X : UU} (R : hrel X) (Y : hSet) (f : X -> Y) (is : iscomprelfun R f) (c : setquot R) : isaprop (image (λ x : c, f (pr1 x))). Proof. intros. apply isapropsubtype. intros y1 y2. simpl. apply (@hinhuniv2 _ _ (make_hProp (y1 = y2) (pr2 Y y1 y2))). intros x1 x2. simpl. induction c as [ A iseq ]. induction x1 as [ x1 is1 ]. induction x2 as [ x2 is2 ]. induction x1 as [ x1 is1' ]. induction x2 as [ x2 is2' ]. simpl in is1. simpl in is2. simpl in is1'. simpl in is2'. assert (r : R x1 x2) by apply (eqax2 iseq _ _ is1' is2'). apply (pathscomp0 (pathsinv0 is1) (pathscomp0 (is _ _ r) is2)). Defined. Global Opaque isapropimeqclass. Theorem setquotuniv {X : UU} (R : hrel X) (Y : hSet) (f : X -> Y) (is : iscomprelfun R f) (c : setquot R) : Y. Proof. intros. apply (pr1image (λ x : c, f (pr1 x))). apply (@hinhuniv (pr1 c) (make_hProp _ (isapropimeqclass R Y f is c)) (prtoimage (λ x : c, f (pr1 x)))). apply (eqax0 (pr2 c)). Defined. (** Note : the axioms rax, sax and trans are not used in the proof of setquotuniv. If we consider a relation which is not an equivalence relation then setquot will still be the set of subsets which are equivalence classes. Now however such subsets need not to cover all of the type. In fact their set can be empty. Nevertheless setquotuniv will apply. *) Theorem setquotunivcomm {X : UU} (R : eqrel X) (Y : hSet) (f : X -> Y) (is : iscomprelfun R f) : ∏ x : X, setquotuniv R Y f is (setquotpr R x) = f x. Proof. intros. unfold setquotuniv. unfold setquotpr. simpl. apply idpath. Defined. Theorem weqpathsinsetquot {X : UU} (R : eqrel X) (x x' : X) : R x x' ≃ setquotpr R x = setquotpr R x'. Proof. intros. split with (iscompsetquotpr R x x'). apply isweqimplimpl. - intro e. set (e' := maponpaths (pr1setquot R) e). unfold pr1setquot in e'. unfold setquotpr in e'. simpl in e'. set (e'' := maponpaths (λ f : _, f x') e'). simpl in e''. apply (eqweqmaphProp (pathsinv0 e'') (eqrelrefl R x')). - apply (pr2 (R x x')). - set (int := isasetsetquot R (setquotpr R x) (setquotpr R x')). assumption. Defined. (** *** Functoriality of [setquot] for functions mapping one relation to another *) Definition iscomprelrelfun {X Y : UU} (RX : hrel X) (RY : hrel Y) (f : X -> Y) : UU := ∏ x x' : X, RX x x' -> RY (f x) (f x'). Lemma iscomprelfunlogeqf1 {X Y : UU} {LX RX : hrel X} (RY : hrel Y) (lg : hrellogeq LX RX) (f : X -> Y) (is : iscomprelrelfun LX RY f) : iscomprelrelfun RX RY f. Proof. intros. intros x x' r. apply (is _ _ (pr2 (lg _ _) r)). Defined. Lemma iscomprelfunlogeqf2 {X Y : UU} (RX : hrel X) {LY RY : hrel Y} (lg : hrellogeq LY RY) (f : X -> Y) (is : iscomprelrelfun RX LY f) : iscomprelrelfun RX RY f. Proof. intros. intros x x' r. apply ((pr1 (lg _ _)) (is _ _ r)). Defined. Definition setquotfun {X Y : UU} (RX : hrel X) (RY : eqrel Y) (f : X -> Y) (is : iscomprelrelfun RX RY f) (cx : setquot RX) : setquot RY. Proof. intros. set (ff := funcomp f (setquotpr RY)). assert (isff : iscomprelfun RX ff). { intros x x'. intro r. apply (weqpathsinsetquot RY (f x) (f x')). apply is. apply r. } apply (setquotuniv RX (setquotinset RY) ff isff cx). Defined. Definition setquotfuncomm {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> Y) (is : iscomprelrelfun RX RY f) : ∏ x : X, setquotfun RX RY f is (setquotpr RX x) = setquotpr RY (f x). Proof. intros. simpl. apply idpath. Defined. (** *** Universal property of [setquot] for predicates of one and several variables *) Theorem setquotunivprop {X : UU} (R : eqrel X) (P : setquot (pr1 R) -> hProp) (ps : ∏ x : X, pr1 (P (setquotpr R x))) : ∏ c : setquot (pr1 R), pr1 (P c). Proof. intros c. apply (@hinhuniv (carrier (pr1 c)) (P c)). - intro x. set (e := setquotl0 R c x). apply (eqweqmaphProp (maponpaths P e)). exact (ps (pr1 x)). - exact (eqax0 (pr2 c)). Defined. Theorem setquotuniv2prop {X : UU} (R : eqrel X) (P : setquot R -> setquot R -> hProp) (is : ∏ x x' : X, P (setquotpr R x) (setquotpr R x')) : ∏ c c' : setquot R, P c c'. Proof. intros. assert (int1 : ∏ c0' : _, P c c0'). { apply (setquotunivprop R (λ c0', P c c0')). intro x. apply (setquotunivprop R (λ c0 : _, P c0 (setquotpr R x))). intro x0. apply (is x0 x). } apply (int1 c'). Defined. Theorem setquotuniv3prop {X : UU} (R : eqrel X) (P : setquot R -> setquot R -> setquot R -> hProp) (is : ∏ x x' x'' : X, P (setquotpr R x) (setquotpr R x') (setquotpr R x'')) : ∏ c c' c'' : setquot R, P c c' c''. Proof. intros. assert (int1 : ∏ c0' c0'' : _, P c c0' c0''). { apply (setquotuniv2prop R (λ c0' c0'', P c c0' c0'')). intros x x'. apply (setquotunivprop R (λ c0 : _, P c0 (setquotpr R x) (setquotpr R x'))). intro x0. apply (is x0 x x'). } apply (int1 c' c''). Defined. Theorem setquotuniv4prop {X : UU} (R : eqrel X) (P : setquot R -> setquot R -> setquot R -> setquot R -> hProp) (is : ∏ x x' x'' x''' : X, P (setquotpr R x) (setquotpr R x') (setquotpr R x'') (setquotpr R x''')) : ∏ c c' c'' c''' : setquot R, P c c' c'' c'''. Proof. intros. assert (int1 : ∏ c0 c0' c0'' : _, P c c0 c0' c0''). { apply (setquotuniv3prop R (λ c0 c0' c0'', P c c0 c0' c0'')). intros x x' x''. apply (setquotunivprop R (λ c0 : _, P c0 (setquotpr R x) (setquotpr R x') (setquotpr R x''))). intro x0. apply (is x0 x x' x''). } apply (int1 c' c'' c'''). Defined. (** Important note : theorems proved above can not be used (al least at the moment) to construct terms whose complete normalization (evaluation) is important. For example they should not be used * directly * to construct [isdeceq] property of [setquot] since [isdeceq] is in turn used to construct boolean equality [booleq] and evaluation of [booleq x y] is important for computational purposes. Terms produced using these universality theorems will not fully normalize even in simple cases due to the following steps in the proof of [setquotunivprop]. As a part of the proof term of this theorem there appears the composition of an application of [hPropUnivalence], transfer of the resulting term of the identity type by [maponpaths] along [P] followed by the reconstruction of a equivalence (two directional implication) between the corresponding propositions through [eqweqmaphProp]. The resulting implications are "opaque" and the proofs of disjunctions [P \/ Q] produced with the use of such implications can not be evaluated to one of the summands of the disjunction. An example is given by the following theorem [isdeceqsetquot_non_constr] which, as simple experiments show, can not be used to compute the value of [isdeceqsetquot]. Below we give another proof of [isdeceq (setquot R)] using the same assumptions which is "constructive" i.e. usable for the evaluation purposes. *) (** *** The case when [setquotfun] is a surjection, inclusion or a weak equivalence *) Lemma issurjsetquotfun {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> Y) (is : issurjective f) (is1 : iscomprelrelfun RX RY f) : issurjective (setquotfun RX RY f is1). Proof. intros. apply (issurjtwooutof3b (setquotpr RX)). apply (issurjcomp f (setquotpr RY) is (issurjsetquotpr RY)). Defined. Lemma isinclsetquotfun {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> Y) (is1 : iscomprelrelfun RX RY f) (is2 : ∏ x x' : X, RY (f x) (f x') -> RX x x') : isincl (setquotfun RX RY f is1). Proof. intros. apply isinclbetweensets. - apply isasetsetquot. - apply isasetsetquot. - assert (is : ∏ (x x' : setquot RX), isaprop (paths (setquotfun RX RY f is1 x) (setquotfun RX RY f is1 x') -> x = x')). { intros. apply impred. intro. apply isasetsetquot. } apply (setquotuniv2prop RX (λ x x', make_hProp _ (is x x'))). simpl. intros x x'. intro e. set (e' := invweq (weqpathsinsetquot RY (f x) (f x')) e). apply (weqpathsinsetquot RX _ _ (is2 x x' e')). Defined. Definition setquotincl {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> Y) (is1 : iscomprelrelfun RX RY f) (is2 : ∏ x x' : X, RY (f x) (f x') -> RX x x') : incl (setquot RX) (setquot RY) := make_incl (setquotfun RX RY f is1) (isinclsetquotfun RX RY f is1 is2). Definition weqsetquotweq {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X ≃ Y) (is1 : iscomprelrelfun RX RY f) (is2 : ∏ x x' : X, RY (f x) (f x') -> RX x x') : (setquot RX) ≃ (setquot RY). Proof. intros. set (ff := setquotfun RX RY f is1). split with ff. assert (is2' : ∏ y y' : Y, RY y y' -> RX (invmap f y) (invmap f y')). intros y y'. rewrite (pathsinv0 (homotweqinvweq f y)). rewrite (pathsinv0 (homotweqinvweq f y')). rewrite (homotinvweqweq f (invmap f y)). rewrite (homotinvweqweq f (invmap f y')). apply (is2 _ _). set (gg := setquotfun RY RX (invmap f) is2'). assert (egf : ∏ a, paths (gg (ff a)) a). { apply (setquotunivprop RX (λ a0, make_hProp _ (isasetsetquot RX (gg (ff a0)) a0))). simpl. intro x. unfold ff. unfold gg. apply (maponpaths (setquotpr RX) (homotinvweqweq f x)). } assert (efg : ∏ a, paths (ff (gg a)) a). { apply (setquotunivprop RY (λ a0, make_hProp _ (isasetsetquot RY (ff (gg a0)) a0))). simpl. intro x. unfold ff. unfold gg. apply (maponpaths (setquotpr RY) (homotweqinvweq f x)). } apply (isweq_iso _ _ egf efg). Defined. Definition weqsetquotsurj {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> Y) (is : issurjective f) (is1 : iscomprelrelfun RX RY f) (is2 : ∏ x x' : X, RY (f x) (f x') -> RX x x') : (setquot RX) ≃ (setquot RY). Proof. intros. set (ff := setquotfun RX RY f is1). split with ff. apply (@isweqinclandsurj (setquotinset RX) (setquotinset RY) ff). apply (isinclsetquotfun RX RY f is1 is2). apply (issurjsetquotfun RX RY f is is1). Defined. (** *** [setquot] with respect to the product of two relations *) Definition setquottodirprod {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (cc : setquot (eqreldirprod RX RY)) : (setquot RX) × (setquot RY). Proof. intros. set (RXY := eqreldirprod RX RY). apply (make_dirprod (setquotuniv RXY (setquotinset RX) (funcomp (@pr1 _ (λ x : _, Y)) (setquotpr RX)) (λ xy xy' : dirprod X Y, λ rr : RXY xy xy', iscompsetquotpr RX _ _ (pr1 rr)) cc) (setquotuniv RXY (setquotinset RY) (funcomp (@pr2 _ (λ x : _, Y)) (setquotpr RY)) (λ xy xy' : dirprod X Y, λ rr : RXY xy xy', iscompsetquotpr RY _ _ (pr2 rr)) cc)). Defined. Definition dirprodtosetquot {X Y : UU} (RX : hrel X) (RY : hrel Y) (cd : (setquot RX) × (setquot RY)) : setquot (hreldirprod RX RY) := make_setquot _ _ (iseqclassdirprod (pr2 (pr1 cd)) (pr2 (pr2 cd))). Theorem weqsetquottodirprod {X Y : UU} (RX : eqrel X) (RY : eqrel Y) : weq (setquot (eqreldirprod RX RY)) ((setquot RX) × (setquot RY)). Proof. intros. set (f := setquottodirprod RX RY). set (g := dirprodtosetquot RX RY). split with f. assert (egf : ∏ a : _, paths (g (f a)) a). { apply (setquotunivprop _ (λ a : _, (make_hProp _ (isasetsetquot _ (g (f a)) a)))). intro xy. induction xy as [ x y ]. simpl. apply (invmaponpathsincl _ (isinclpr1setquot _)). simpl. apply funextsec. intro xy'. induction xy' as [ x' y' ]. apply idpath. } assert (efg : ∏ a : _, paths (f (g a)) a). { intro a. induction a as [ ax ay ]. apply pathsdirprod. generalize ax. clear ax. apply (setquotunivprop RX (λ ax : _, (make_hProp _ (isasetsetquot _ _ _)))). intro x. simpl. generalize ay. clear ay. apply (setquotunivprop RY (λ ay : _, (make_hProp _ (isasetsetquot _ _ _)))). intro y. simpl. apply (invmaponpathsincl _ (isinclpr1setquot _)). apply funextsec. intro x0. simpl. apply idpath. generalize ax. clear ax. apply (setquotunivprop RX (λ ax : _, (make_hProp _ (isasetsetquot _ _ _)))). intro x. simpl. generalize ay. clear ay. apply (setquotunivprop RY (λ ay : _, (make_hProp _ (isasetsetquot _ _ _)))). intro y. simpl. apply (invmaponpathsincl _ (isinclpr1setquot _)). apply funextsec. intro x0. simpl. apply idpath. } apply (isweq_iso _ _ egf efg). Defined. (** *** Universal property of [setquot] for functions of two variables *) Definition iscomprelfun2 {X Y : UU} (R : hrel X) (f : X -> X -> Y) : UU := ∏ x x' x0 x0' : X, R x x' -> R x0 x0' -> f x x0 = f x' x0'. Lemma iscomprelfun2if {X Y : UU} (R : hrel X) (f : X -> X -> Y) (is1 : ∏ x x' x0 : X, R x x' -> f x x0 = f x' x0) (is2 : ∏ x x0 x0' : X, R x0 x0' -> f x x0 = f x x0') : iscomprelfun2 R f. Proof. intros. intros x x' x0 x0'. intros r r'. set (e := is1 x x' x0 r). set (e' := is2 x' x0 x0' r'). apply (pathscomp0 e e'). Defined. Lemma iscomprelfun2logeqf {X Y : UU} {L R : hrel X} (lg : hrellogeq L R) (f : X -> X -> Y) (is : iscomprelfun2 L f) : iscomprelfun2 R f. Proof. intros. intros x x' x0 x0' r r0. apply (is _ _ _ _ ((pr2 (lg _ _)) r) ((pr2 (lg _ _)) r0)). Defined. Local Lemma setquotuniv2_iscomprelfun {X : UU} (R : hrel X) (Y : hSet) (f : X -> X -> Y) (is : iscomprelfun2 R f) (c c0 : setquot R) : iscomprelfun (hreldirprod R R) (λ xy : dirprod X X, f (pr1 xy) (pr2 xy)). Proof. intros xy x'y'. simpl. intro dp. induction dp as [ r r']. apply (is _ _ _ _ r r'). Defined. Global Opaque setquotuniv2_iscomprelfun. Definition setquotuniv2 {X : UU} (R : hrel X) (Y : hSet) (f : X -> X -> Y) (is : iscomprelfun2 R f) (c c0 : setquot R) : Y. Proof. intros. set (ff := λ xy : dirprod X X, f (pr1 xy) (pr2 xy)). set (RR := hreldirprod R R). apply (setquotuniv RR Y ff (setquotuniv2_iscomprelfun R Y f is c c0) (dirprodtosetquot R R (make_dirprod c c0))). Defined. Theorem setquotuniv2comm {X : UU} (R : eqrel X) (Y : hSet) (f : X -> X -> Y) (is : iscomprelfun2 R f) : ∏ x x' : X, setquotuniv2 R Y f is (setquotpr R x) (setquotpr R x') = f x x'. Proof. intros. apply idpath. Defined. (** *** Functoriality of [setquot] for functions of two variables mapping one relation to another *) Definition iscomprelrelfun2 {X Y : UU} (RX : hrel X) (RY : hrel Y) (f : X -> X -> Y) : UU := ∏ x x' x0 x0' : X, RX x x' -> RX x0 x0' -> RY (f x x0) (f x' x0'). Lemma iscomprelrelfun2if {X Y : UU} (RX : hrel X) (RY : eqrel Y) (f : X -> X -> Y) (is1 : ∏ x x' x0 : X, RX x x' -> RY (f x x0) (f x' x0)) (is2 : ∏ x x0 x0' : X, RX x0 x0' -> RY (f x x0) (f x x0')) : iscomprelrelfun2 RX RY f. Proof. intros. intros x x' x0 x0'. intros r r'. set (e := is1 x x' x0 r). set (e' := is2 x' x0 x0' r'). apply (eqreltrans RY _ _ _ e e'). Defined. Lemma iscomprelrelfun2logeqf1 {X Y : UU} {LX RX : hrel X} (RY : hrel Y) (lg : hrellogeq LX RX) (f : X -> X -> Y) (is : iscomprelrelfun2 LX RY f) : iscomprelrelfun2 RX RY f. Proof. intros. intros x x' x0 x0' r r0. apply (is _ _ _ _ ((pr2 (lg _ _)) r) ((pr2 (lg _ _)) r0)). Defined. Lemma iscomprelrelfun2logeqf2 {X Y : UU} (RX : hrel X) {LY RY : hrel Y} (lg : hrellogeq LY RY) (f : X -> X -> Y) (is : iscomprelrelfun2 RX LY f) : iscomprelrelfun2 RX RY f. Proof. intros. intros x x' x0 x0' r r0. apply ((pr1 (lg _ _)) (is _ _ _ _ r r0)). Defined. Local Lemma setquotfun2_iscomprelfun2 {X Y : UU} (RX : hrel X) (RY : eqrel Y) (f : X -> X -> Y) (is : iscomprelrelfun2 RX RY f) (cx cx0 : setquot RX) : iscomprelfun2 RX (λ x x0 : X, setquotpr RY (f x x0)). Proof. intros x x' x0 x0'. intros r r0. apply (weqpathsinsetquot RY (f x x0) (f x' x0')). apply is. apply r. apply r0. Defined. Global Opaque setquotfun2_iscomprelfun2. Definition setquotfun2 {X Y : UU} (RX : hrel X) (RY : eqrel Y) (f : X -> X -> Y) (is : iscomprelrelfun2 RX RY f) (cx cx0 : setquot RX) : setquot RY. Proof. intros. set (ff := λ x x0 : X, setquotpr RY (f x x0)). exact (setquotuniv2 RX (setquotinset RY) ff (setquotfun2_iscomprelfun2 RX RY f is cx cx0) cx cx0). Defined. Theorem setquotfun2comm {X Y : UU} (RX : eqrel X) (RY : eqrel Y) (f : X -> X -> Y) (is : iscomprelrelfun2 RX RY f) : ∏ (x x' : X), setquotfun2 RX RY f is (setquotpr RX x) (setquotpr RX x') = setquotpr RY (f x x'). Proof. intros. apply idpath. Defined. (** *** Set quotients with respect to decidable equivalence relations have decidable equality *) Theorem isdeceqsetquot_non_constr {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) : isdeceq (setquot R). Proof. intros. apply isdeceqif. intros x x'. apply (setquotuniv2prop R (λ x0 x0', make_hProp _ (isapropisdecprop (x0 = x0')))). intros x0 x0'. simpl. apply (isdecpropweqf (weqpathsinsetquot R x0 x0') (is x0 x0')). Defined. Definition setquotbooleqint {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) (x x' : X) : bool. Proof. intros. induction (pr1 (is x x')). apply true. apply false. Defined. Lemma setquotbooleqintcomp {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) : iscomprelfun2 R (setquotbooleqint R is). Proof. intros. unfold iscomprelfun2. intros x x' x0 x0' r r0. unfold setquotbooleqint. induction (pr1 (is x x0)) as [ r1 | nr1 ]. - induction (pr1 (is x' x0')) as [ r1' | nr1' ]. + apply idpath. + induction (nr1' (eqreltrans R _ _ _ (eqreltrans R _ _ _ (eqrelsymm R _ _ r) r1) r0)). - induction (pr1 (is x' x0')) as [ r1' | nr1' ]. + induction (nr1 (eqreltrans R _ _ _ r (eqreltrans R _ _ _ r1' (eqrelsymm R _ _ r0)))). + apply idpath. Defined. Definition setquotbooleq {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) : setquot R -> setquot R -> bool := setquotuniv2 R (make_hSet _ (isasetbool)) (setquotbooleqint R is) (setquotbooleqintcomp R is). Lemma setquotbooleqtopaths {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) (x x' : setquot R) : setquotbooleq R is x x' = true -> x = x'. Proof. revert x x'. assert (isp : ∏ (x x' : setquot R), isaprop ((setquotbooleq R is x x') = true -> x = x')). { intros x x'. apply impred. intro. apply (isasetsetquot R x x'). } apply (setquotuniv2prop R (λ x x', make_hProp _ (isp x x'))). simpl. intros x x'. change ((setquotbooleqint R is x x') = true -> paths (setquotpr R x) (setquotpr R x')). unfold setquotbooleqint. induction (pr1 (is x x')) as [ i1 | i2 ]. - intro. apply (weqpathsinsetquot R _ _ i1). - intro H. induction (nopathsfalsetotrue H). Defined. Lemma setquotpathstobooleq {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) (x x' : setquot R) : x = x' -> setquotbooleq R is x x' = true. Proof. intros e. induction e. generalize x. apply (setquotunivprop R (λ x, make_hProp _ (isasetbool (setquotbooleq R is x x) true))). simpl. intro x0. change ((setquotbooleqint R is x0 x0) = true). unfold setquotbooleqint. induction (pr1 (is x0 x0)) as [ i1 | i2 ]. - apply idpath. - induction (i2 (eqrelrefl R x0)). Defined. Definition isdeceqsetquot {X : UU} (R : eqrel X) (is : ∏ x x' : X, isdecprop (R x x')) : isdeceq (setquot R). Proof. intros. intros x x'. induction (boolchoice (setquotbooleq R is x x')) as [ i | ni ]. - apply (ii1 (setquotbooleqtopaths R is x x' i)). - apply ii2. intro e. induction (falsetonegtrue _ ni (setquotpathstobooleq R is x x' e)). Defined. (** *** Relations on quotient sets Note that all the properties of the quotient relations which we consider other than [isantisymm] are also inherited in the opposite direction - if the quotent relation satisfies the property then the original relation does. *) Definition iscomprelrel {X : UU} (R : hrel X) (L : hrel X) : UU := iscomprelfun2 R L. Lemma iscomprelrelif {X : UU} {R : hrel X} (L : hrel X) (isr : issymm R) (i1 : ∏ x x' y, R x x' -> L x y -> L x' y) (i2 : ∏ x y y', R y y' -> L x y -> L x y') : iscomprelrel R L. Proof. intros. intros x x' y y' rx ry. set (rx' := isr _ _ rx). set (ry' := isr _ _ ry). apply hPropUnivalence. - intro lxy. set (int1 := i1 _ _ _ rx lxy). apply (i2 _ _ _ ry int1). - intro lxy'. set (int1 := i1 _ _ _ rx' lxy'). apply (i2 _ _ _ ry' int1). Defined. Lemma iscomprelrellogeqf1 {X : UU} {R R' : hrel X} (L : hrel X) (lg : hrellogeq R R') (is : iscomprelrel R L) : iscomprelrel R' L. Proof. intros. apply (iscomprelfun2logeqf lg L is). Defined. Lemma iscomprelrellogeqf2 {X : UU} (R : hrel X) {L L' : hrel X} (lg : hrellogeq L L') (is : iscomprelrel R L) : iscomprelrel R L'. Proof. intros. intros x x' x0 x0' r r0. assert (e : paths (L x x0) (L' x x0)). { apply hPropUnivalence. - apply (pr1 (lg _ _)). - apply (pr2 (lg _ _)). } assert (e' : paths (L x' x0') (L' x' x0')). { apply hPropUnivalence. - apply (pr1 (lg _ _)). - apply (pr2 (lg _ _)). } induction e. induction e'. apply (is _ _ _ _ r r0). Defined. Definition quotrel {X : UU} {R L : hrel X} (is : iscomprelrel R L) : hrel (setquot R) := setquotuniv2 R hPropset L is. Lemma istransquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : istrans L) : istrans (quotrel is). Proof. intros. unfold istrans. assert (int : ∏ (x1 x2 x3 : setquot R), isaprop (quotrel is x1 x2 -> quotrel is x2 x3 -> quotrel is x1 x3)). { intros x1 x2 x3. apply impred. intro. apply impred. intro. apply (pr2 (quotrel is x1 x3)). } apply (setquotuniv3prop R (λ x1 x2 x3, make_hProp _ (int x1 x2 x3))). intros x x' x''. intros r r'. apply (isl x x' x'' r r'). Defined. Lemma issymmquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : issymm L) : issymm (quotrel is). Proof. intros. unfold issymm. assert (int : ∏ (x1 x2 : setquot R), isaprop (quotrel is x1 x2 -> quotrel is x2 x1)). { intros x1 x2. apply impred. intro. apply (pr2 (quotrel is x2 x1)). } apply (setquotuniv2prop R (λ x1 x2, make_hProp _ (int x1 x2))). intros x x'. intros r. apply (isl x x' r). Defined. Lemma isreflquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isrefl L) : isrefl (quotrel is). Proof. intros. unfold isrefl. apply (setquotunivprop R). intro x. apply (isl x). Defined. Lemma ispoquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : ispreorder L) : ispreorder (quotrel is). Proof. intros. split with (istransquotrel is (pr1 isl)). apply (isreflquotrel is (pr2 isl)). Defined. Lemma iseqrelquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : iseqrel L) : iseqrel (quotrel is). Proof. intros. split with (ispoquotrel is (pr1 isl)). apply (issymmquotrel is (pr2 isl)). Defined. Lemma isirreflquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isirrefl L) : isirrefl (quotrel is). Proof. intros. unfold isirrefl. apply (setquotunivprop R (λ x, make_hProp _ (isapropneg (quotrel is x x)))). intro x. apply (isl x). Defined. Lemma isasymmquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isasymm L) : isasymm (quotrel is). Proof. intros. unfold isasymm. assert (int : ∏ (x1 x2 : setquot R), isaprop (quotrel is x1 x2 -> quotrel is x2 x1 -> empty)). { intros x1 x2. apply impred. intro. apply impred. intro. apply isapropempty. } apply (setquotuniv2prop R (λ x1 x2, make_hProp _ (int x1 x2))). intros x x'. intros r r'. apply (isl x x' r r'). Defined. Lemma iscoasymmquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : iscoasymm L) : iscoasymm (quotrel is). Proof. intros. unfold iscoasymm. assert (int : ∏ (x1 x2 : setquot R), isaprop (neg (quotrel is x1 x2) -> quotrel is x2 x1)). { intros x1 x2. apply impred. intro. apply (pr2 _). } apply (setquotuniv2prop R (λ x1 x2, make_hProp _ (int x1 x2))). intros x x'. intros r. apply (isl x x' r). Defined. Lemma istotalquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : istotal L) : istotal (quotrel is). Proof. intros. unfold istotal. apply (setquotuniv2prop R (λ x1 x2, hdisj _ _)). intros x x'. intros r r'. apply (isl x x' r r'). Defined. Lemma iscotransquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : iscotrans L) : iscotrans (quotrel is). Proof. intros. unfold iscotrans. assert (int : ∏ (x1 x2 x3 : setquot R), isaprop (quotrel is x1 x3 -> hdisj (quotrel is x1 x2) (quotrel is x2 x3))). { intros. apply impred. intro. apply (pr2 _). } apply (setquotuniv3prop R (λ x1 x2 x3, make_hProp _ (int x1 x2 x3))). intros x x' x''. intros r. apply (isl x x' x'' r). Defined. Lemma isantisymmquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isantisymm L) : isantisymm (quotrel is). Proof. intros. unfold isantisymm. assert (int : ∏ (x1 x2 : setquot R), isaprop (quotrel is x1 x2 -> quotrel is x2 x1 -> x1 = x2)). { intros x1 x2. apply impred. intro. apply impred. intro. apply (isasetsetquot R x1 x2). } apply (setquotuniv2prop R (λ x1 x2, make_hProp _ (int x1 x2))). intros x x'. intros r r'. apply (maponpaths (setquotpr R) (isl x x' r r')). Defined. Lemma isantisymmnegquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isantisymmneg L) : isantisymmneg (quotrel is). Proof. intros. unfold isantisymmneg. assert (int : ∏ (x1 x2 : setquot R), isaprop (neg (quotrel is x1 x2) -> neg (quotrel is x2 x1) -> x1 = x2)). { intros x1 x2. apply impred. intro. apply impred. intro. apply (isasetsetquot R x1 x2). } apply (setquotuniv2prop R (λ x1 x2, make_hProp _ (int x1 x2))). intros x x'. intros r r'. apply (maponpaths (setquotpr R) (isl x x' r r')). Defined. (** We do not have a lemma for [neqchoicequotrel] since [neqchoice] is not a property and since even when it is a property such as under the additional condition [isasymm] on the relation it still carrier computational content (similarly to [isdec]) which would be lost under our current approach of taking quotients. How to best define [neqchoicequotrel] remains at the moment an open question.*) Lemma quotrelimpl {X : UU} {R : eqrel X} {L L' : hrel X} (is : iscomprelrel R L) (is' : iscomprelrel R L') (impl : ∏ x x', L x x' -> L' x x') (x x' : setquot R) (ql : quotrel is x x') : quotrel is' x x'. Proof. intros. generalize x x' ql. assert (int : ∏ (x0 x0' : setquot R), isaprop (quotrel is x0 x0' -> quotrel is' x0 x0')). { intros x0 x0'. apply impred. intro. apply (pr2 _). } apply (setquotuniv2prop _ (λ x0 x0', make_hProp _ (int x0 x0'))). intros x0 x0'. change (L x0 x0' -> L' x0 x0'). apply (impl x0 x0'). Defined. Lemma quotrellogeq {X : UU} {R : eqrel X} {L L' : hrel X} (is : iscomprelrel R L) (is' : iscomprelrel R L') (lg : ∏ x x', L x x' <-> L' x x') (x x' : setquot R) : (quotrel is x x') <-> (quotrel is' x x'). Proof. intros. split. - apply (quotrelimpl is is' (λ x0 x0', pr1 (lg x0 x0')) x x'). - apply (quotrelimpl is' is (λ x0 x0', pr2 (lg x0 x0')) x x'). Defined. (** Constructive proof of decidability of the quotient relation *) Definition quotdecrelint {X : UU} {R : hrel X} (L : decrel X) (is : iscomprelrel R (pr1 L)) : brel (setquot R). Proof. intros. set (f := decreltobrel L). unfold brel. apply (setquotuniv2 R boolset f). intros x x' x0 x0' r r0. unfold f. unfold decreltobrel in *. induction (pr2 L x x0') as [ l | nl ]. - induction (pr2 L x' x0') as [ l' | nl' ]. + induction (pr2 L x x0) as [ l'' | nl'' ]. * apply idpath. * set (e := is x x' x0 x0' r r0). induction e. induction (nl'' l'). + induction (pr2 L x x0) as [ l'' | nl'' ]. * set (e := is x x' x0 x0' r r0). induction e. induction (nl' l''). * apply idpath. - induction (pr2 L x x0) as [ l' | nl' ]. + induction (pr2 L x' x0') as [ l'' | nl'' ]. * apply idpath. * set (e := is x x' x0 x0' r r0). induction e. induction (nl'' l'). + induction (pr2 L x' x0') as [ l'' | nl'' ]. * set (e := is x x' x0 x0' r r0). induction e. induction (nl' l''). * apply idpath. Defined. Definition quotdecrelintlogeq {X : UU} {R : eqrel X} (L : decrel X) (is : iscomprelrel R (pr1 L)) (x x' : setquot R) : breltodecrel (quotdecrelint L is) x x' <-> quotrel is x x'. Proof. revert x x'. assert (int : ∏ (x x' : setquot R), isaprop ((quotdecrelint L is x x') = true <-> (quotrel is x x'))). { intros x x'. apply isapropdirprod. - apply impred. intro. apply (pr2 (quotrel _ _ _)). - apply impred. intro. apply isasetbool. } apply (setquotuniv2prop R (λ x x', make_hProp _ (int x x'))). intros x x'. simpl. split. - apply (pathstor L x x'). - apply (rtopaths L x x'). Defined. Lemma isdecquotrel {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) (isl : isdecrel L) : isdecrel (quotrel is). Proof. intros. apply (isdecrellogeqf (quotdecrelintlogeq (make_decrel isl) is) (pr2 (breltodecrel (quotdecrelint (make_decrel isl) is)))). Defined. Definition decquotrel {X : UU} {R : eqrel X} (L : decrel X) (is : iscomprelrel R L) : decrel (setquot R) := make_decrel (isdecquotrel is (pr2 L)). (** *** Subtypes of quotients and quotients of subtypes *) Definition reseqrel {X : UU} (R : eqrel X) (P : hsubtype X) : eqrel P := make_eqrel _ (iseqrelresrel R P (pr2 R)). Lemma iseqclassresrel {X : UU} (R : hrel X) (P Q : hsubtype X) (is : iseqclass R Q) (is' : ∏ x, Q x -> P x) : iseqclass (resrel R P) (λ x : P, Q (pr1 x)). Proof. intros. split. - set (l1 := pr1 is). generalize l1. clear l1. simpl. apply hinhfun. intro q. split with (make_carrier P (pr1 q) (is' (pr1 q) (pr2 q))). apply (pr2 q). - split. + intros p1 p2 r12 q1. apply ((pr1 (pr2 is)) _ _ r12 q1). + intros p1 p2 q1 q2. apply ((pr2 (pr2 is)) _ _ q1 q2). Defined. Definition fromsubquot {X : UU} (R : eqrel X) (P : hsubtype (setquot R)) (p : P) : setquot (resrel R (funcomp (setquotpr R) P)). Proof. intros. split with (fun rp : carrier (funcomp (setquotpr R) P) => (pr1 p) (pr1 rp)). apply (iseqclassresrel R (funcomp (setquotpr R) P) _ (pr2 (pr1 p))). intros x px. set (e := setquotl0 R _ (make_carrier _ x px)). simpl in e. unfold funcomp. rewrite e. apply (pr2 p). Defined. Definition tosubquot {X : UU} (R : eqrel X) (P : hsubtype (setquot R)) : setquot (resrel R (funcomp (setquotpr R) P)) -> P. Proof. assert (int : isaset P). { apply (isasetsubset (@pr1 _ P)). - apply (setproperty (setquotinset R)). - refine (isinclpr1carrier _). } apply (setquotuniv _ (make_hSet _ int) (λ xp, make_carrier P (setquotpr R (pr1 xp)) (pr2 xp))). intros xp1 xp2 rp12. apply (invmaponpathsincl _ (isinclpr1carrier P) _ _). simpl. apply (iscompsetquotpr). apply rp12. Defined. Definition weqsubquot {X : UU} (R : eqrel X) (P : hsubtype (setquot R)) : weq P (setquot (resrel R (funcomp (setquotpr R) P))). Proof. intros. set (f := fromsubquot R P). set (g := tosubquot R P). split with f. assert (int0 : isaset P). { apply (isasetsubset (@pr1 _ P)). - apply (setproperty (setquotinset R)). - refine (isinclpr1carrier _). } assert (egf : ∏ (a : P), paths (g (f a)) a). { intros a. induction a as [ p isp ]. generalize isp. generalize p. clear isp. clear p. assert (int : ∏ (p : setquot R), isaprop (∏ isp : P p, paths (g (f (tpair _ p isp))) (tpair _ p isp))). { intro p. apply impred. intro. apply (int0 _ _). } apply (setquotunivprop _ (λ a, make_hProp _ (int a))). simpl. intros x isp. apply (invmaponpathsincl _ (isinclpr1carrier P) _ _). apply idpath. } assert (efg : ∏ (a : setquot (resrel R (P ∘ setquotpr R))), paths (f (g a)) a). { assert (int : ∏ a, isaprop (paths (f (g a)) a)). { intro a. apply (setproperty (setquotinset (resrel R (funcomp (setquotpr R) P)))). } set (Q := reseqrel R (funcomp (setquotpr R) P)). apply (setquotunivprop Q (fun a : setquot (resrel R (funcomp (setquotpr R) P)) => make_hProp _ (int a))). intro a. simpl. unfold f. unfold g. unfold fromsubquot. unfold tosubquot. (* Compilations hangs here if the next command is "simpl." in 8.4-8.5-trunk *) apply (invmaponpathsincl _ (isinclpr1 _ (λ a, isapropiseqclass _ a))). apply idpath. } apply (isweq_iso _ _ egf efg). Defined. (** Comment: unfortunetely [weqsubquot] is not as useful as it should be at moment due to the failure of the following code to work: [Lemma test (X : UU) (R : eqrel X) (P : hsubtype (setquot R)) (x : X) (is : P (setquotpr R x)) : paths (setquotpr (reseqrel R (funcomp (setquotpr R) P)) (tpair _ x is)) (fromsubquot R P (tpair _ (setquotpr R x) is)). Proof. intros. apply idpath. Defined.] As one of the consequences we are forced to use a "hack" in the definition of multiplicative inverses for rationals in [hqmultinv]. The issue which arises here is the same one which arises in several other places in the work with quotients. It can be traced back first to the failure of [invmaponpathsincl] to map [idpath] to [idpath] and then to the fact that for [(X : UU) (is : isaprop X)] the term [t := proofirrelevance is : ∏ x1 x2 : X, x1 = x2] does not satisfy (definitionally) the condition [t x x == idpath x]. It can and probably should be fixed by the addition of a new componenet to CIC in the form of a term constructor: tfc (X : UU) (E : X -> UU) (is : ∏ x, iscontr (E x)) (x0 : X) (e0 : E x0) : ∏ x : X, E x. and a computation rule tfc_comp (tfc X E is x0 e0 x0) == e0 (with both tfc and tfc_comp definable in an arbitrary context) Such an extension will be compatible with the univalent models and should not, as far as I can see, provide any problems for normalization or for the decidability of typing. Using tfc one can give a construction of [proofirrelevance] as follows (recall that [isaprop := ∏ x1 x2, iscontr (x1 = x2)]) : Lemma proofirrelevance {X : UU} (is : isaprop X) : ∏ x1 x2, x1 = x2. Proof. intros X is x1. apply (tfc X (λ x2, x1 = x2) is x1 (idpath x1)). Defined. Defined in this way [proofirrelevance] will have the required property and will enable to define [invmaponpathsincl] in such a way that the existing proofs of [setquotl0] and [fromsubquot] and [weqsubquot] will provide the desired behavior of [fromsubquot] on terms of the form [(tpair _ (setquotpr R x) is)]. *) (** *** The set of connected components of type. *) Definition pathshrel (X : UU) : X → X → hProp := λ x x' : X, ishinh (x = x'). Definition istranspathshrel (X : UU) : istrans (pathshrel X) := λ x x' x'' : _, λ a : _, λ b : _, hinhfun2 (fun e1 : x = x' => fun e2 : x' = x'' => e1 @ e2) a b. Definition isreflpathshrel (X : UU) : isrefl (pathshrel X) := λ x : _, hinhpr (idpath x). Definition issymmpathshrel (X : UU) : issymm (pathshrel X) := λ x x': _, λ a : _, hinhfun (fun e : x = x' => ! e) a. Definition pathseqrel (X : UU) : eqrel X := eqrelconstr (pathshrel X) (istranspathshrel X) (isreflpathshrel X) (issymmpathshrel X). Definition pi0 (X : UU) : UU := setquot (pathshrel X). Definition pi0pr (X : UU) : X -> setquot (pathseqrel X) := setquotpr (pathseqrel X). (** ** Set quotients. Construction 2. ****************** THIS SECTION IS UNFINISHED ****************** Another construction of the set quotient is based on the following idea. Let X be a set. Then we have the obvious "double evaluation map" from X to the product over all sets Y of the sets ((X -> Y) -> Y). This is always an inclusion and in particular X is isomorphic to the image of this map. Suppore now we have a relation (which need not be an equivalence relation) R on X. Then we know that (X/R -> Y) is a subset of (X -> Y) which consists of functions compatible with the relation even if we do not know what X/R is. Thus we may consider the image of X in the product over all Y of ((X/R -> Y) ->Y) and it must be isomorphic to X/R. This ideas are realized in the definitions given below. There are two advantages to this approach. One is that the relation need not be an equivalence relation. Another one is that it can be more easily generalized to the higher quotients of type. We also show that two constructions of set-quotients of types - the one given in set_quotients and the one given here agree up to an isomorphism (weak equivalence). *) (** *** Functions compatible with a relation *) Definition compfun {X : UU} (R : hrel X) (S : UU) : UU := total2 (fun F : X -> S => iscomprelfun R F). Definition make_compfun {X : UU} (R : hrel X) {S : UU} (f : X -> S) (is : iscomprelfun R f) : compfun R S := tpair _ f is. Definition pr1compfun (X : UU) (R : hrel X) (S : UU) : @compfun X R S -> (X -> S) := @pr1 _ _. Coercion pr1compfun : compfun >-> Funclass. Definition compevmapset {X : UU} (R : hrel X) : X -> ∏ S : hSet, (compfun R S) -> S := λ x : X, λ S : _, λ f : compfun R S, pr1 f x. Definition compfuncomp {X : UU} (R : hrel X) {S S' : UU} (f : compfun R S) (g : S -> S') : compfun R S'. Proof. intros. split with (funcomp f g). intros x x' r. apply (maponpaths g (pr2 f x x' r)). Defined. (** Tests Definition F (X Y : UU) (R : hrel X) := (compfun R Y) -> Y. Definition Fi (X Y : UU) (R : hrel X) : X -> F X Y R := λ x, λ f, f x. Lemma iscompFi {X Y : UU} (R : hrel X) : iscomprelfun R (Fi X Y R). Proof. intros. intros x x' r. unfold Fi. apply funextfun. intro f. apply (pr2 f x x' r). Defined. Definition Fv {X Y : UU} (R : hrel X) (f : compfun R Y) (phi : F X Y R) : Y := phi f. Definition qeq {X Y : UU} (R : hrel X) := total2 (λ phi : F X Y R, ∏ psi : F X Y R -> Y, paths (psi phi) (Fv R (compfuncomp R (make_compfun R _ (iscompFi R)) psi) phi)). Lemma isinclpr1qeq {X : UU} (R : hrel X) (Y : hSet) : isincl (@pr1 _ (λ phi : F X Y R, ∏ psi : F X Y R -> Y, paths (psi phi) (Fv R (compfuncomp R (make_compfun R _ (iscompFi R)) psi) phi))). Proof. intros. apply isinclpr1. intro phi. apply impred. intro psi. apply (pr2 Y). Defined. Definition toqeq {X Y : UU} (R : hrel X) (x : X) : @qeq X Y R. Proof. intros. split with (Fi X Y R x). intro psi. apply idpath. Defined. Lemma iscomptoqeq {X : UU} (Y : hSet) (R : hrel X) : iscomprelfun R (@toqeq X Y R). Proof. intros. intros x x' r. unfold toqeq. apply (invmaponpathsincl _ (isinclpr1qeq R Y)). apply (@iscompFi X Y R x x' r). Defined. Definition qequniv {X : UU} (Y : hSet) (R : hrel X) (f : compfun R Y) (phi : @qeq X Y R) : Y. Proof. intros. apply (Fv R f (pr1 phi)). Defined. Lemma qequnivandpr {X : UU} (Y : hSet) (R : hrel X) (f : compfun R Y) (x : X) : paths (qequniv Y R f (toqeq R x)) (f x). Proof. intros. apply idpath. Defined. Lemma etaqeq {X : UU} (Y : hSet) (R : hrel X) (psi : qeq R -> Y) (phi : qeq R) : paths (psi phi) (qequniv Y R (compfuncomp R (make_compfun R _ (iscomptoqeq Y R)) psi) phi). Proof. intros. apply (pr2 phi psi). Definition Fd1 {X Y : UU} : F X Y R -> (F (F X Y) Y) := Fi (F X Y) Y. Definition Fd2 {X Y : UU} (R : hrel X) (phi : F X Y R) (psi : F X Y R -> Y) : Y := (Fv R (funcomp (Fi X Y R) psi) phi). Definition Ffunct {X1 X2 : UU} (f : X1 -> X2) (Y : UU) : F X1 Y -> F X2 Y := λ phi, λ g, phi (funcomp f g). Lemma testd1 {X Y : UU} (psi : F X Y -> Y) (phi : F X Y) : paths (psi phi) (Fd1 phi psi). Proof. intros. apply idpath. Defined. Lemma testd2 {X Y : UU} (psi : F X Y -> Y) (phi : F X Y) : paths (Fv (funcomp (Fi X Y) psi) phi) (Fd2 phi psi). Proof. intros. apply idpath. Defined. Definition F (X Y : UU) := (X -> Y) -> Y. Definition Ffunct {X1 X2 : UU} (f : X1 -> X2) (Y : UU) : F X1 Y -> F X2 Y := λ phi, λ g, phi (funcomp f g). Definition Fi (X Y : UU) : X -> F X Y := λ x, λ f, f x. Definition Fd1 {X Y : UU} : F X Y -> (F (F X Y) Y) := Fi (F X Y) Y. Definition Fd2 {X Y : UU} : F X Y -> (F (F X Y) Y) := Ffunct (Fi X Y) Y. Definition Fv {X Y : UU} (f : X -> Y) (phi : F X Y) : Y := phi f. Lemma testd1 {X Y : UU} (psi : F X Y -> Y) (phi : F X Y) : paths (psi phi) (Fd1 phi psi). Proof. intros. apply idpath. Defined. Lemma testd2 {X Y : UU} (psi : F X Y -> Y) (phi : F X Y) : paths (Fv (funcomp (Fi X Y) psi) phi) (Fd2 phi psi). Proof. intros. apply idpath. Defined. Lemma Xineq (X Y : UU) (x : X) : paths (Fd1 (Fi X Y x)) (Fd2 (Fi X Y x)). Proof. intros. apply idpath. Defined. Lemma test (X Y : UU) (phi : F X Y) (f : X -> Y) : paths (Fd1 phi (Fi (X -> Y) Y f)) (Fd2 phi (Fi (X -> Y) Y f)). Proof. intros. unfold Fd1. unfold Fd2. unfold Fi. unfold Ffunct. unfold funcomp. simpl. apply (maponpaths phi). apply etacorrection. Defined. Inductive try0 (T : UU) (t : T) : ∏ (t1 t2 : T) (e1 : t = t1) (e2 : t = t2), UU := idconstr : ∏ (t' : T) (e' : t = t'), try0 T t t' t' e' e'. Definition try0map1 (T : UU) (t : T) (t1 t2 : T) (e1 : t = t1) (e2 : t = t2) (X : try0 T t t1 t2 e1 e2) : t1 = t2. Proof. intros. induction X. apply idpath. Defined. Definition try0map2 (T : UU) (t : T) (t1 t2 : T) (e1 : t = t1) (e2 : t = t2) : try0 T t t1 t2 e1 e2. Proof. Lemma test (X : UU) (t : X) : paths (pr2 (iscontrcoconustot X t) (pr1 (iscontrcoconustot X t))) (idpath _). Proof. intros. apply idpath. Lemma test {X : UU} (is : iscontr X) : paths (pr2 (iscontrcor is) (pr1 (iscontrcor is))) (idpath _). Proof. intros. apply idpath. Lemma test {X : UU} (R : eqrel X) (Y : hSet) (f : setquot R -> Y) : paths f (setquotuniv R Y (funcomp (setquotpr R) f) (λ x x' : X, λ r : R x x', maponpaths f (iscompsetquotpr R x x' r))). Proof. intros. apply funextfun. intro c. simpl. induction c as [ A iseq ]. simpl. *) (** *** The quotient set of a type by a relation. *) Definition setquot2 {X : UU} (R : hrel X) : UU := image (compevmapset R). Theorem isasetsetquot2 {X : UU} (R : hrel X) : isaset (setquot2 R). Proof. intros. assert (is1: isofhlevel 2 (∏ S : hSet, (compfun R S) -> S)). { apply impred. intro. apply impred. intro X0. apply (pr2 t). } apply (isasetsubset _ is1 (isinclpr1image _)). Defined. Definition setquot2inset {X : UU} (R : hrel X) : hSet := make_hSet _ (isasetsetquot2 R). (** We will be asuming below that setquot2 is in UU. In the future it should be proved using [issurjsetquot2pr] below and a resizing axiom. The appropriate resizing axiom for this should say that if X -> Y is a surjection, Y is an hset and X : UU then Y : UU. *) Definition setquot2pr {X : UU} (R : hrel X) : X -> setquot2 R := λ x : X, make_image (compevmapset R) _ (hinhpr (make_hfiber (compevmapset R) x (idpath _))). Lemma issurjsetquot2pr {X : UU} (R : hrel X) : issurjective (setquot2pr R). Proof. intros. apply issurjprtoimage. Defined. Lemma iscompsetquot2pr {X : UU} (R : hrel X) : iscomprelfun R (setquot2pr R). Proof. intros. intros x x' r. assert (e1: paths (compevmapset R x) (compevmapset R x')). { apply funextsec. intro S. apply funextsec. intro f. unfold compfun in f. apply (pr2 f x x' r). } apply (invmaponpathsincl _ (isinclpr1image (compevmapset R)) (setquot2pr R x) (setquot2pr R x') e1). Defined. (** *** Universal property of [seqtquot2 R] for functions to sets satisfying compatibility condition [iscomprelfun] *) Definition setquot2univ {X : UU} (R : hrel X) (Y : hSet) (F : X -> Y) (is : iscomprelfun R F) (c : setquot2 R) : Y := pr1 c Y (make_compfun _ F is). Theorem setquot2univcomm {X : UU} (R : hrel X) (Y : hSet) (F : X -> Y) (iscomp : iscomprelfun R F) (x : X) : setquot2univ _ _ F iscomp (setquot2pr R x) = F x. Proof. intros. apply idpath. Defined. (** *** Weak equivalence from [R x x'] to [paths (setquot2pr R x) (setquot2pr R x')] *) Lemma weqpathssetquot2l1 {X : UU} (R : eqrel X) (x : X) : iscomprelfun R (λ x', R x x'). Proof. intros. intros x' x''. intro r. apply hPropUnivalence. intro r'. apply (eqreltrans R _ _ _ r' r). intro r''. apply (eqreltrans R _ _ _ r'' (eqrelsymm R _ _ r)). Defined. Theorem weqpathsinsetquot2 {X : UU} (R : eqrel X) (x x' : X) : (R x x') ≃ (setquot2pr R x = setquot2pr R x'). Proof. intros. apply weqimplimpl. apply iscompsetquot2pr. set (int := setquot2univ R hPropset (λ x'', R x x'') (weqpathssetquot2l1 R x)). intro e. change (pr1 (int (setquot2pr R x'))). induction e. change (R x x). apply (eqrelrefl R). apply (pr2 (R x x')). apply (isasetsetquot2). Defined. (* *** Comparison of setquot2 and setquot. *) Definition setquottosetquot2 (X : UU) (R : hrel X) (is : iseqrel R) : setquot R -> setquot2 R. Proof. intros X0. apply (setquotuniv R (make_hSet _ (isasetsetquot2 R)) (setquot2pr R) (iscompsetquot2pr R) X0). Defined. (** ** Consequences of univalence *) Require Import UniMath.Foundations.UnivalenceAxiom. Definition hSet_univalence_map (X Y : hSet) : (X = Y) -> (pr1 X ≃ pr1 Y). Proof. intros e. exact (eqweqmap (maponpaths pr1hSet e)). Defined. Theorem hSet_univalence (X Y : hSet) : (X = Y) ≃ (X ≃ Y). Proof. Set Printing Coercions. intros. set (f := hSet_univalence_map X Y). exists f. set (g := @eqweqmap (pr1 X) (pr1 Y)). set (h := λ e : X = Y, maponpaths pr1hSet e). assert (comp : f = g ∘ h). { apply funextfun; intro e. induction e. apply idpath. } induction (!comp). apply twooutof3c. - apply isweqonpathsincl. apply isinclpr1. exact isapropisaset. - apply univalenceAxiom. Unset Printing Coercions. Defined. Theorem hSet_rect (X Y : hSet) (P : X ≃ Y -> UU) : (∏ e : X=Y, P (hSet_univalence _ _ e)) -> ∏ f, P f. Proof. intros ih ?. Set Printing Coercions. set (p := ih (invmap (hSet_univalence _ _) f)). set (h := homotweqinvweq (hSet_univalence _ _) f). exact (transportf P h p). Unset Printing Coercions. Defined. Ltac hSet_induction f e := generalize f; apply UU_rect; intro e; clear f. (* End of the file hSet.v *) UniMath-20231010/UniMath/Foundations/Tests.v000066400000000000000000000072451451125700300204460ustar00rootroot00000000000000Require Export UniMath.Foundations.PartD. Goal ∑ (_:nat) (_:nat) (_:nat) (_:nat), nat. exact (2,,3,,4,,5,,6). Defined. Goal ∏ i j k, i+j+k = (i+j)+k. intros. apply idpath. Defined. Goal ∏ n, 1+n = S n. intros. apply idpath. Defined. Goal ∏ i j k, i*j*k = (i*j)*k. intros. apply idpath. Defined. Goal ∏ n, 0*n = 0. intros. apply idpath. Defined. Goal ∏ n, 0+n = n. intros. apply idpath. Defined. Goal ∏ n, 0*n = 0. intros. apply idpath. Defined. Goal ∏ n m, S n * m = n*m + m. intros. apply idpath. Defined. Goal ∏ n, 1*n = n. intros. apply idpath. Defined. Goal ∏ n, 4*n = n+n+n+n. intros. apply idpath. Defined. Goal ∏ X x, idweq X x = x. intros. apply idpath. Defined. Section Test_isweq_iso. Let f := idfun nat. Let w : nat ≃ nat := weq_iso f f (λ _, idpath _) (λ _, idpath _). Goal homotinvweqweq w 3 = idpath _. apply idpath. Defined. Goal homotweqinvweq w 3 = idpath _. apply idpath. Defined. Goal homotweqinvweqweq w 3 = idpath _. apply idpath. Defined. Definition v : bool ≃ bool. simple refine (weq_iso negb negb _ _); intro x; induction x; apply idpath. Defined. Goal homotinvweqweq v true = idpath _. apply idpath. Defined. Goal homotweqinvweq v true = idpath _. apply idpath. Defined. Goal homotweqinvweqweq v true = idpath _. apply idpath. Defined. End Test_isweq_iso. Goal ∏ X x, invweq (idweq X) x = x. intros. apply idpath. Defined. Section Test_weqtotal2overcoprod. Let P (t : bool ⨿ bool) := nat. Goal weqtotal2overcoprod P (ii1 true,,3) = ii1 (true,,3). apply idpath. Defined. Goal weqtotal2overcoprod P (ii2 false,,3) = ii2 (false,,3). apply idpath. Defined. Goal invmap (weqtotal2overcoprod P) (ii1 (true,,3)) = ii1 true,,3. apply idpath. Defined. Goal invmap (weqtotal2overcoprod P) (ii2 (false,,3)) = ii2 false,,3. apply idpath. Defined. End Test_weqtotal2overcoprod. Goal weqcoprodf (idweq nat) (idweq nat) (ii1 3) = ii1 3. apply idpath. Defined. Goal weqcoprodf (idweq nat) (idweq nat) (ii2 3) = ii2 3. apply idpath. Defined. Goal invmap (weqcoprodf (idweq nat) (idweq nat)) (ii1 3) = ii1 3. apply idpath. Defined. Goal invmap (weqcoprodf (idweq nat) (idweq nat)) (ii2 3) = ii2 3. apply idpath. Defined. Goal bool_to_type true = unit . apply idpath. Defined. Goal bool_to_type false = empty. apply idpath. Defined. Goal @weqfibtototal bool _ _ (λ _, idweq bool) (true,,true) = (true,,true). apply idpath. Defined. Goal invmap (@weqfibtototal bool _ _ (λ _, idweq bool)) (true,,true) = (true,,true). apply idpath. Defined. Goal @weqfp_map nat nat (idweq _) (λ _,nat) (3,,4) = (3,,4). apply idpath. Defined. Goal @weqfp_map _ _ boolascoprod (λ _,nat) (ii1 tt,,4) = (true,,4). apply idpath. Defined. Goal @weqfp_invmap nat nat (idweq _) (λ _,nat) (3,,4) = (3,,4). apply idpath. Defined. Goal @weqfp_invmap _ _ boolascoprod (λ _,nat) (true,,4) = (ii1 tt,,4). apply idpath. Defined. Goal weqfp (idweq nat) (λ _,nat) (3,,4) = (3,,4). apply idpath. Defined. Goal invmap (weqfp (idweq nat) (λ _,nat)) (3,,4) = (3,,4). apply idpath. Defined. Goal weqtotal2overunit (λ _,nat) (tt,,3) = 3. apply idpath. Defined. Goal invmap (weqtotal2overunit (λ _,nat)) 3 = (tt,,3). apply idpath. Defined. Goal iscontr = isofhlevel 0. apply idpath. Defined. Goal isaset = isofhlevel 2. apply idpath. Defined. Require UniMath.Foundations.Sets. Module Test_sets. Import UniMath.Foundations.Sets. Goal ∏ Y (is:isaset Y) (F:Y->UU) (e :∏ y y', F y -> F y' -> y=y') y (f:F y), squash_pairs_to_set F is e (hinhpr (y,,f)) = y. Proof. intros. apply idpath. Qed. Goal ∏ X Y (is:isaset Y) (f:X->Y) (e:∏ x x', f x = f x'), f = funcomp hinhpr (squash_to_set is f e). Proof. intros. apply idpath. Qed. End Test_sets. UniMath-20231010/UniMath/Foundations/UnivalenceAxiom.v000066400000000000000000000432241451125700300224300ustar00rootroot00000000000000(** The univalence axiom and its consequences *) (** In this file, we formulate univalence and its consequences, including functional extensionality (the statement that functions with equal values are equal). One approach would be to take univalence as the only axiom and to formulate theorems proving the consequences, whose proofs would appeal to the univalence axiom. We adopt a different approach here, preferring also to introduce axioms for various consequences of univalence. This allows us to measure how subsequent theorems depend on the axioms using the "Print Assumptions" command of Coq. An important point is that the types of all our axioms are propositions, that is types of h-level 1 and once an element of such a type is declared or contructed it becomes a contractible type. In particular, the declared element corresponding to the axiom and the element that can be contructed using another, stronger, axiom are connected by a path. Proofs that the types of our axioms are propositions will be provided in the file UnivalenceAxiom2. We postpone stating the axioms themselves until after all the implications are established; this helps us encourage the use of the axioms for the consequences of univalence, rather than the theorems giving the implications. *) (** Preliminaries *) Require Export UniMath.Foundations.PartB. (* everything related to eta correction is obsolete *) Definition eqweqmap { T1 T2 : UU } : T1 = T2 -> T1 ≃ T2. Proof. intro e. induction e. apply idweq. Defined. Definition sectohfiber { X : UU } (P:X -> UU): (∏ x:X, P x) -> (hfiber (λ f, λ x, pr1 (f x)) (λ x:X, x)) := (fun a : ∏ x:X, P x => tpair _ (λ x, tpair _ x (a x)) (idpath (λ x:X, x))). Definition hfibertosec { X : UU } (P:X -> UU): (hfiber (λ f x, pr1 (f x)) (λ x:X, x)) -> (∏ x:X, P x) := λ se , λ x:X, match se as se' return P x with tpair _ s e => (transportf P (toforallpaths _ (λ x:X, pr1 (s x)) (λ x:X, x) e x) (pr2 (s x))) end. Definition sectohfibertosec { X : UU } (P:X -> UU): ∏ a : (∏ x:X, P x), hfibertosec _ (sectohfiber _ a) = a. Proof. apply idpath. Defined. Lemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : x = x' ) : isweq ( transportf P e ). Proof. intros. induction e. apply idisweq. Defined. Lemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : x = x' ) : isweq ( transportb P e ). Proof. intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ). Defined. Lemma l1 { X0 X0' : UU } ( ee : X0 = X0' ) ( P : UU -> UU ) ( pp' : P X0' ) ( R : ∏ X X' : UU , ∏ w : X ≃ X' , P X' -> P X ) ( r : ∏ X : UU , ∏ p : P X , paths ( R X X ( idweq X ) p ) p ) : paths ( R X0 X0' ( eqweqmap ee ) pp' ) ( transportb P ee pp' ). Proof. induction ee. simpl. apply r. Defined. (** Axiom statements (propositions) *) Definition univalenceStatement := ∏ X Y:UU, isweq (@eqweqmap X Y). Definition funextemptyStatement := ∏ (X:UU) (f g : X->empty), f = g. Definition propositionalUnivalenceStatement := ∏ (P Q:UU), isaprop P -> isaprop Q -> (P -> Q) -> (Q -> P) -> P=Q. Definition funcontrStatement := ∏ (X : UU) (P:X -> UU), (∏ x:X, iscontr (P x)) -> iscontr (∏ x:X, P x). Definition funextcontrStatement := ∏ (T:UU) (P:T -> UU) (g: ∏ t, P t), ∃! (f:∏ t, P t), ∏ t:T, f t = g t. Definition isweqtoforallpathsStatement := ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), isweq (toforallpaths _ f g). (** Axiom consequence statements (not propositions) *) Definition funextsecStatement := ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), f ~ g -> f = g. Definition funextfunStatement := ∏ (X Y:UU) (f g : X -> Y), f ~ g -> f = g. Definition weqtopathsStatement := ∏ ( T1 T2 : UU ), T1 ≃ T2 -> T1 = T2. Definition weqpathsweqStatement (weqtopaths:weqtopathsStatement) := ∏ ( T1 T2 : UU ) ( w : T1 ≃ T2 ), eqweqmap (weqtopaths _ _ w) = w. Definition weqtoforallpathsStatement := ∏ (T:UU) (P:T -> UU) (f g :∏ t:T, P t), (f = g) ≃ (f ~ g). (** Implications between statements and consequences of them *) Theorem funextsecImplication : isweqtoforallpathsStatement -> funextsecStatement. Proof. intros fe ? ? ? ?. exact (invmap (make_weq _ (fe _ _ f g))). Defined. Theorem funextfunImplication : funextsecStatement -> funextfunStatement. Proof. intros fe ? ?. apply fe. Defined. (** We show that [ univalenceAxiom ] is equivalent to the axioms [ weqtopathsStatement ] and [ weqpathsweqStatement ] stated below . *) Theorem univfromtwoaxioms : (∑ weqtopaths: weqtopathsStatement, weqpathsweqStatement weqtopaths) <-> univalenceStatement. Proof. split. { intros [weqtopaths weqpathsweq] T1 T2. set ( P1 := λ XY : UU × UU, pr1 XY = pr2 XY ) . set ( P2 := λ XY : UU × UU, (pr1 XY) ≃ (pr2 XY) ) . set ( Z1 := total2 P1 ). set ( Z2 := total2 P2 ). set ( f := totalfun _ _ ( λ XY : UU × UU, @eqweqmap (pr1 XY) (pr2 XY)) : Z1 -> Z2 ) . set ( g := totalfun _ _ ( λ XY : UU × UU, weqtopaths (pr1 XY) (pr2 XY) ) : Z2 -> Z1 ) . assert (efg : funcomp g f ~ idfun _) . - intro z2 . induction z2 as [ XY e ] . unfold g . unfold f . unfold totalfun . simpl . apply ( maponpaths ( fun w : ( pr1 XY) ≃ (pr2 XY) => tpair P2 XY w ) ( weqpathsweq ( pr1 XY ) ( pr2 XY ) e )) . - set ( h := λ a1 : Z1, pr1 ( pr1 a1 ) ) . assert ( egf0 : ∏ a1 : Z1 , pr1 ( g ( f a1 ) ) = pr1 a1 ). + intro. apply idpath. + assert ( egf1 : ∏ a1 a1' : Z1 , paths ( pr1 a1' ) ( pr1 a1 ) -> a1' = a1 ). * intros. set ( X' := maponpaths pr1 X ). assert ( is : isweq h ). { simpl in h . apply isweqpr1pr1 . } apply ( invmaponpathsweq ( make_weq h is ) _ _ X' ). * set ( egf := λ a1 , egf1 _ _ ( egf0 a1 ) ). set ( is2 := isweq_iso _ _ egf efg ). apply ( isweqtotaltofib _ _ ( λ _, eqweqmap) is2 ( make_dirprod T1 T2 ) ). } { intros ua. simple refine (_,,_). - intros ? ?. exact (invmap (make_weq _ (ua _ _))). - intros ? ?. exact (homotweqinvweq (make_weq _ (ua _ _))). } Defined. (** Conjecture : the pair [weqtopaths] and [weqtopathsweq] in the proof above is well defined up to a canonical equality. **) Section UnivalenceImplications. (** In this section we take univalence as a hypothesis, not as an axiom, so we can limit the number of theorems that take univalence an axiom. The suffix UAH on the name of a theorem indicates a theorem that will be stated later unconditionally, with a proof that appeals to the future univalence axiom. *) Hypothesis univalenceAxiom : univalenceStatement. Theorem univalenceUAH (X Y:UU) : (X=Y) ≃ (X≃Y). Proof. exact (make_weq _ (univalenceAxiom X Y)). Defined. Definition weqtopathsUAH : weqtopathsStatement. Proof. intros ? ?. exact (invmap (univalenceUAH _ _)). Defined. Arguments weqtopathsUAH {_ _} _. Definition weqpathsweqUAH : weqpathsweqStatement (@weqtopathsUAH). Proof. intros ? ? w. exact (homotweqinvweq (univalenceUAH T1 T2) w). Defined. Arguments weqpathsweqUAH {_ _} _. Lemma propositionalUnivalenceUAH: propositionalUnivalenceStatement. Proof. unfold propositionalUnivalenceStatement; intros ? ? i j f g. apply weqtopathsUAH. simple refine (make_weq f (isweq_iso f g _ _)). - intro p. apply proofirrelevance, i. - intro q. apply proofirrelevance, j. Defined. (** ** Proof of the functional extensionality for functions from univalence *) (** ** Transport theorem. Theorem saying that any general scheme to "transport" a structure along a weak equivalence which does not change the structure in the case of the identity equivalence is equivalent to the transport along the path which corresponds to a weak equivalence by the univalenceAxiom. As a corollary we conclude that for any such transport scheme the corresponding maps on spaces of structures are weak equivalences. *) Theorem weqtransportbUAH ( P : UU -> UU ) ( R : ∏ ( X X' : UU ) ( w : X ≃ X' ) , P X' -> P X ) ( r : ∏ X : UU , ∏ p : P X , R X X ( idweq X ) p = p ) : ∏ ( X X' : UU ) ( w : X ≃ X' ) ( p' : P X' ), R X X' w p' = transportb P ( weqtopathsUAH w ) p'. Proof. intros. set ( uv := weqtopathsUAH w ). set ( v := eqweqmap uv ). assert ( e : v = w ) . - unfold weqtopathsUAH in uv. apply ( homotweqinvweq ( univalenceUAH X X' ) w ). - assert ( ee : R X X' v p' = R X X' w p' ). + set ( R' := fun vis : X ≃ X' => R X X' vis p' ). assert ( ee' : R' v = R' w ). * apply ( maponpaths R' e ). * assumption. + induction ee. apply l1. assumption. Defined. Corollary isweqweqtransportbUAH ( P : UU -> UU ) ( R : ∏ ( X X' : UU ) ( w : X ≃ X' ) , P X' -> P X ) ( r : ∏ X : UU , ∏ p : P X , R X X ( idweq X ) p = p ) : ∏ ( X X' : UU ) ( w : X ≃ X' ), isweq ( λ p' : P X', R X X' w p' ). Proof. intros. assert ( e : R X X' w ~ transportb P ( weqtopathsUAH w )). - unfold homot. apply weqtransportbUAH. assumption. - assert ( ee : transportb P ( weqtopathsUAH w ) ~ R X X' w). + intro p'. apply ( pathsinv0 ( e p' ) ). + clear e. assert ( is1 : isweq ( transportb P ( weqtopathsUAH w ) ) ). apply isweqtransportb10. apply ( isweqhomot ( transportb P ( weqtopathsUAH w ) ) (R X X' w) ee is1 ). Defined. (** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *) Theorem isweqcompwithweqUAH { X X' : UU } ( w : X ≃ X' ) ( Y : UU ) : isweq ( fun f : X' -> Y => ( λ x : X, f ( w x ) ) ). Proof. set ( P := λ X0 : UU, ( X0 -> Y ) ). set ( R := λ X0 : UU, ( λ X0' : UU, ( fun w1 : X0 -> X0' => ( λ f : P X0' , ( λ x : X0, f ( w1 x ) ) ) ) ) ). apply ( isweqweqtransportbUAH P R (λ X0 f, idpath _) X X' w ). Defined. Lemma eqcor0UAH { X X' : UU } ( w : X ≃ X' ) ( Y : UU ) ( f1 f2 : X' -> Y ) : (λ x : X, f1 ( w x )) = (λ x : X, f2 ( w x ) ) -> f1 = f2. Proof. apply ( invmaponpathsweq ( make_weq _ ( isweqcompwithweqUAH w Y ) ) f1 f2 ). Defined. Lemma apathpr1toprUAH ( T : UU ) : paths ( λ z : pathsspace T, pr1 z ) ( λ z : pathsspace T, pr1 ( pr2 z ) ). Proof. apply ( eqcor0UAH ( make_weq _ ( isweqdeltap T ) ) _ ( λ z : pathsspace T, pr1 z ) ( λ z : pathsspace T, pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) . Defined. Theorem funextfunPreliminaryUAH : funextfunStatement. Proof. intros ? ? f1 f2 e. set ( f := λ x : X, pathsspacetriple Y ( e x ) ). set ( g1 := λ z : pathsspace Y, pr1 z ). set ( g2 := λ z : pathsspace Y, pr1 ( pr2 z ) ). change ( (funcomp f g1) = (funcomp f g2) ). apply maponpaths. apply apathpr1toprUAH. Defined. Arguments funextfunPreliminaryUAH {_ _} _ _ _. Lemma funextemptyUAH : funextemptyStatement. Proof. unfold funextemptyStatement; intros. apply funextfunPreliminaryUAH. intro x. induction (f x). Defined. (** *** Deduction of functional extensionality for dependent functions (sections) from functional extensionality of usual functions *) Lemma isweqlcompwithweqUAH {X X' : UU} (w: X ≃ X') (Y:UU) : isweq (fun (a:X'->Y) x => a (w x)). (* this lemma is currently unused *) Proof. simple refine (isweq_iso _ _ _ _). exact (λ b x', b (invweq w x')). exact (λ a, funextfunPreliminaryUAH _ a (λ x', maponpaths a (homotweqinvweq w x'))). exact (λ a, funextfunPreliminaryUAH _ a (λ x , maponpaths a (homotinvweqweq w x ))). Defined. Lemma isweqrcompwithweqUAH { Y Y':UU } (w: Y ≃ Y')(X:UU) : isweq (fun a:X->Y => (λ x, w (a x))). Proof. simple refine (isweq_iso _ _ _ _). exact (fun a':X->Y' => λ x, (invweq w (a' x))). exact (fun a :X->Y => funextfunPreliminaryUAH _ a (λ x, homotinvweqweq w (a x))). exact (fun a':X->Y' => funextfunPreliminaryUAH _ a' (λ x, homotweqinvweq w (a' x))). Defined. Theorem funcontrUAH : funcontrStatement. Proof. unfold funcontrStatement. intros ? ? X0. set (T1 := ∏ x:X, P x). set (T2 := (hfiber (fun f: (X -> total2 P) => λ x: X, pr1 (f x)) (λ x:X, x))). assert (is1:isweq (@pr1 X P)). - apply isweqpr1. assumption. - set (w1:= make_weq (@pr1 X P) is1). assert (X1:iscontr T2). + apply (isweqrcompwithweqUAH w1 X (λ x:X, x)). + apply (iscontrretract _ _ (sectohfibertosec P) X1). Defined. (** Proof of the fact that the [ toforallpaths ] from [s1 = s2] to [∏ t:T, paths (s1 t) (s2 t)] is a weak equivalence - a strong form of functional extensionality for sections of general families. The proof uses only [funcontrUAH] which is an element of a proposition. *) Lemma funextcontrUAH : funextcontrStatement. Proof. unfold funextcontrStatement. intros. use (iscontrretract (X := ∏ t, ∑ p, p = g t)). - intros x. use tpair. + intro t. exact (pr1 (x t)). + intro t; simpl. exact (pr2 (x t)). - intros y t. exists (pr1 y t). exact (pr2 y t). - intros u. induction u as [t x]. apply idpath. - apply funcontrUAH. intro t. apply iscontrcoconustot. Defined. Arguments funextcontrUAH {_} _ _. Theorem isweqtoforallpathsUAH : isweqtoforallpathsStatement. Proof. unfold isweqtoforallpathsStatement. intros. refine (isweqtotaltofib _ _ (λ (h:∏ t, P t), toforallpaths _ h g) _ f). refine (isweqcontrcontr (X := ∑ (h: ∏ t, P t), h = g) (λ ff, tpair _ (pr1 ff) (toforallpaths P (pr1 ff) g (pr2 ff))) _ _). { exact (iscontrcoconustot _ g). } { apply funextcontrUAH. } Qed. End UnivalenceImplications. (** Univalence implies each of the other axioms *) Definition funcontrFromUnivalence: univalenceStatement -> funcontrStatement := funcontrUAH. Definition funextsecweqFromUnivalence: univalenceStatement -> isweqtoforallpathsStatement := isweqtoforallpathsUAH. Definition funextemptyFromUnivalence: univalenceStatement -> funextemptyStatement := funextemptyUAH. Definition propositionalUnivalenceFromUnivalence: univalenceStatement -> propositionalUnivalenceStatement := propositionalUnivalenceUAH. Definition funextcontrStatementFromUnivalence: univalenceStatement -> funextcontrStatement := funextcontrUAH. (** the axioms themselves *) Axiom univalenceAxiom : univalenceStatement. Axiom funextemptyAxiom : funextemptyStatement. Axiom isweqtoforallpathsAxiom : isweqtoforallpathsStatement. Axiom funcontrAxiom : funcontrStatement. Axiom propositionalUnivalenceAxiom : propositionalUnivalenceStatement. Axiom funextcontrAxiom : funextcontrStatement. (** provide some theorems based on the axioms *) Definition funextempty := funextemptyAxiom. Definition univalence := univalenceUAH univalenceAxiom. Definition weqtopaths : weqtopathsStatement. Proof. unfold weqtopathsStatement. intros ? ?. exact (invmap (univalence _ _)). Defined. Arguments weqtopaths {_ _} _. Definition weqpathsweq := weqpathsweqUAH univalenceAxiom. Arguments weqpathsweq {_ _} _. Definition funcontr : funcontrStatement := funcontrAxiom. Arguments funcontr {_} _ _. Definition funextcontr : funextcontrStatement := @funextcontrAxiom. Arguments funextcontr {_} _ _. Definition isweqtoforallpaths : isweqtoforallpathsStatement := isweqtoforallpathsAxiom. Arguments isweqtoforallpaths {_} _ _ _ _. Definition weqtoforallpaths : weqtoforallpathsStatement := λ X P f g, make_weq _ (@isweqtoforallpaths X P f g). Arguments weqtoforallpaths {_} _ _ _. (* Print Assumptions weqtoforallpaths. (* isweqtoforallpathsAxiom *) *) Definition funextsec : funextsecStatement := funextsecImplication isweqtoforallpathsAxiom. Arguments funextsec {_} _ _ _ _. (* Print Assumptions funextsec. (* isweqtoforallpathsAxiom *) *) Definition funextfun := funextfunImplication (@funextsec). Arguments funextfun {_ _} _ _ _. (* Print Assumptions funextfun. (* isweqtoforallpathsAxiom *) *) Definition weqfunextsec { T : UU } (P:T -> UU) (f g : ∏ t:T, P t) : (f ~ g) ≃ (f = g) := invweq (weqtoforallpaths P f g). (* Print Assumptions weqfunextsec. (* isweqtoforallpathsAxiom *) *) Corollary funcontrtwice { X : UU } (P: X-> X -> UU) (is: ∏ (x x':X), iscontr (P x x')) : iscontr (∏ (x x':X), P x x'). Proof. intros. assert (is1: ∏ x:X, iscontr (∏ x':X, P x x')). - intro. apply (funcontr _ (is x)). - apply (funcontr _ is1). Defined. (** Check assumptions *) Lemma toforallpaths_induction (X Y : UU) (f g : X -> Y) (P : (∏ x, f x = g x) -> UU) (H : ∏ e : f = g, P (toforallpaths _ _ _ e)) : ∏ i : (∏ x, f x = g x), P i. Proof. intros i. rewrite <- (homotweqinvweq (weqtoforallpaths _ f g)). apply H. Defined. Definition transportf_funextfun {X Y : UU} (P : Y -> UU) (F F' : X -> Y) (H : ∏ (x : X), F x = F' x) (x : X) (f : P (F x)) : transportf (λ x0 : X → Y, P (x0 x)) (funextsec _ F F' H) f = transportf (λ x0 : Y, P x0) (H x) f. Proof. apply (toforallpaths_induction _ _ F F' (λ H', transportf (λ x0 : X → Y, P (x0 x)) (funextsec (λ _ : X, Y) F F' (λ x0 : X, H' x0)) f = transportf (λ x0 : Y, P x0) (H' x) f)). intro e. clear H. set (XR := homotinvweqweq (weqtoforallpaths _ F F') e). set (H := funextsec (λ _ : X, Y) F F' (λ x0 : X, toforallpaths (λ _ : X, Y) F F' e x0)). set (P' := λ x0 : X → Y, P (x0 x)). use pathscomp0. - exact (transportf P' e f). - use transportf_paths. exact XR. - induction e. apply idpath. Defined. (** induction tactic for the universe *) Theorem UU_rect (X Y : UU) (P : X ≃ Y -> UU) : (∏ e : X=Y, P (univalence _ _ e)) -> ∏ f, P f. Proof. intros ih ?. set (p := ih (invmap (univalence _ _) f)). set (h := homotweqinvweq (univalence _ _) f). exact (transportf P h p). Defined. Ltac type_induction f e := generalize f; apply UU_rect; intro e; clear f. UniMath-20231010/UniMath/Foundations/UnivalenceAxiom2.v000066400000000000000000000035221451125700300225070ustar00rootroot00000000000000(** proofs that the statements of the axioms are propositions *) Require Import UniMath.Foundations.PartD. Lemma isaprop_univalenceStatement : isaprop univalenceStatement. Proof. unfold univalenceStatement. apply impred_isaprop; intro X; apply impred_isaprop; intro Y. apply isapropisweq. Defined. Lemma isaprop_funextemptyStatement : isaprop funextemptyStatement. Proof. unfold funextemptyStatement. apply impred_isaprop; intro X; apply impred_isaprop; intro f; apply impred_isaprop; intro g. generalize g; clear g. generalize f; clear f. change (isaset (X → ∅)). apply impred_isaset; intro x. apply isasetempty. Defined. Lemma isaprop_isweqtoforallpathsStatement : isaprop isweqtoforallpathsStatement. Proof. unfold isweqtoforallpathsStatement. apply impred_isaprop; intro T; apply impred_isaprop; intro P; apply impred_isaprop; intro f; apply impred_isaprop; intro g. apply isapropisweq. Defined. Lemma isaprop_propositionalUnivalenceStatement : isaprop propositionalUnivalenceStatement. Proof. unfold propositionalUnivalenceStatement. apply impred_isaprop; intro P; apply impred_isaprop; intro Q; apply impred_isaprop; intro i; apply impred_isaprop; intro j; apply impred_isaprop; intros _; apply impred_isaprop; intros _. apply (isofhlevelweqb 1 (univalence P Q)). fold isaprop. apply isapropweqtoprop. exact j. Defined. Lemma isaprop_funcontrStatement : isaprop funcontrStatement. Proof. unfold funcontrStatement. apply impred_isaprop; intro X; apply impred_isaprop; intro P; apply impred_isaprop; intros _. apply isapropiscontr. Defined. Lemma isaprop_funextcontrStatement : isaprop funextcontrStatement. Proof. unfold funextcontrStatement. apply impred_isaprop; intro T; apply impred_isaprop; intro P; apply impred_isaprop; intro g. apply isapropiscontr. Defined. (* end *) UniMath-20231010/UniMath/Foundations/dune000066400000000000000000000002201451125700300200150ustar00rootroot00000000000000(rule (deps (source_tree .)) (action (with-stdout-to All.v (run %{project_root}/util/generate-exports UniMath.Foundations "%{deps}")))) UniMath-20231010/UniMath/HomologicalAlgebra/000077500000000000000000000000001451125700300203675ustar00rootroot00000000000000UniMath-20231010/UniMath/HomologicalAlgebra/.package/000077500000000000000000000000001451125700300220405ustar00rootroot00000000000000UniMath-20231010/UniMath/HomologicalAlgebra/.package/files000066400000000000000000000002171451125700300230650ustar00rootroot00000000000000Triangulated.v Complexes.v KA.v TranslationFunctors.v MappingCone.v MappingCylinder.v KAPreTriangulated.v KATriangulated.v CohomologyComplex.v UniMath-20231010/UniMath/HomologicalAlgebra/CohomologyComplex.v000066400000000000000000003231071451125700300242330ustar00rootroot00000000000000(** * Cohomology of complexes *) (** ** Contents - Cohomology functor C(A) -> C(A) - Alternative definition of cohomology complex - Quasi-isomorphism in C(A) - Cohomology functor K(A) -> C(A) - Construction of K(A) -> C(A) - K(A) -> C(A) is additive - Quasi-isomorphisms in K(A) - Complex of kernels and complex of cokernels - Construction of the complexes - Cohomology and morphisms from cokernels to kernels *) Unset Kernel Term Sharing. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.KA. Local Open Scope hz_scope. Local Opaque hz isdecrelhzeq hzplus iscommringops ishinh. (** * Cohomology functor *) (** ** Introduction In this section we define the cohomology functor H : C(A) -> C(A). Suppose A is the category of abelian groups. Then H sends a complex ... -> X^{i-1} -> X^i -> X^{i+1} -> ... to the complex ... -> Ker d^{i-1} / Im d^{i-2} -> Ker d^i / Im d^{i-1} -> Ker d^{i+1} / Im d^i -> ... where the differentials are given by zero morphisms. A morphism f : X -> Y is sent to the induced morphism. That is, f^i : X^i -> Y^i induces a morphism #(H f)^i : ker d^i_X / Im d^{i-1}_X -> ker d^i_Y / Im d^{i-1}_Y# $(H f)^i : ker d^i_X / Im d^{i-1}_X -> ker d^i_Y / Im d^{i-1}_Y$ as one can check. In category theory, there are two isomorphic ways to define the cohomology complex. We use the following definition. The ith cohomology is defined to be the cokernel of the morphism X^{i-1} -> Ker d^i, the KernelIn map of Ker d^i obtained by using the fact that d^{i-1} · d^i = 0. If f is a morphism of complexes, then by using properties of kernelin and cokernelout we construct the induced morphism. The map on complexes is constructed in [CohomologyComplex]. The map on morphisms is constructed in [CohomologyMorphism]. The functor_data is contructed from these in [CohomologyFunctor_data], and finally in [CohomologyFunctor] we prove that this data defines a functor. *) Section def_cohomology_complex. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** Cohomology complex *) Local Lemma CohomologyComplex_KernelIn_eq' (C : Complex (AbelianToAdditive A)) (i : hz) : (transportf (λ x : pr1 hz, A ⟦ C (i - 1), C x ⟧) (hzrminusplus i 1) (Diff C (i - 1))) · (Diff C i) = ZeroArrow (to_Zero A) _ _. Proof. induction (hzrminusplus i 1). cbn. apply (DSq (AbelianToAdditive A) C (i - 1)). Qed. Local Lemma CohomologyComplex_KernelIn_eq (C : Complex (AbelianToAdditive A)) (i : hz) : (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · (Diff C i) = ZeroArrow (to_Zero A) _ _. Proof. rewrite <- functtransportf. cbn. induction (hzrminusplus i 1). cbn. apply (DSq (AbelianToAdditive A) C (i - 1)). Qed. Definition CohomologyComplex (C : (ComplexPreCat_AbelianPreCat A)) : ComplexPreCat_AbelianPreCat A. Proof. cbn in *. use make_Complex. - intros i. exact (Abelian.Cokernel (KernelIn (to_Zero A) (Abelian.Kernel (Diff C i)) _ _ (CohomologyComplex_KernelIn_eq C i))). - intros i. exact (ZeroArrow ((to_Zero A)) _ _). - intros i. cbn. apply ZeroArrow_comp_left. Defined. (** ** Cohomology morphism *) Local Lemma CohomologyMorphism_KernelIn_comm {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) (i : hz) : KernelArrow (Kernel (Diff C1 i)) · MMor f i · Diff C2 i = ZeroArrow (to_Zero A) (Kernel (Diff C1 i)) (C2 (i + 1)). Proof. rewrite <- assoc. set (tmp := MComm f i). cbn in tmp. rewrite tmp. clear tmp. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Local Lemma CohomolohyMorphism_Ker_comm {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) (i : hz) : (KernelIn (to_Zero A) (Kernel (Diff C1 i)) (C1 (i - 1)) (transportf (precategory_morphisms (C1 (i - 1))) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1))) (CohomologyComplex_KernelIn_eq C1 i)) · (KernelIn (to_Zero A) (Kernel (Diff C2 i)) (Kernel (Diff C1 i)) (KernelArrow (Kernel (Diff C1 i)) · MMor f i) (CohomologyMorphism_KernelIn_comm f i)) = (MMor f (i - 1)) · (KernelIn (to_Zero A) (Kernel (Diff C2 i)) (C2 (i - 1)) (transportf (precategory_morphisms (C2 (i - 1))) (maponpaths C2 (hzrminusplus i 1)) (Diff C2 (i - 1))) (CohomologyComplex_KernelIn_eq C2 i)). Proof. apply (KernelArrowisMonic (to_Zero A) (Kernel (Diff C2 i))). rewrite <- assoc. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. cbn. rewrite <- transport_target_postcompose. cbn. set (tmp := MComm f (i - 1)). cbn in tmp. rewrite tmp. clear tmp. rewrite assoc. rewrite KernelCommutes. induction (hzrminusplus i 1). cbn. apply idpath. Qed. Local Lemma CohomologyMorphism_Ker_Coker_Zero {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) (i : hz) : (KernelIn (to_Zero A) (Kernel (Diff C1 i)) (C1 (i - 1)) (transportf (precategory_morphisms (C1 (i - 1))) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1))) (CohomologyComplex_KernelIn_eq C1 i)) · ((KernelIn (to_Zero A) (Kernel (Diff C2 i)) (Kernel (Diff C1 i)) (KernelArrow (Kernel (Diff C1 i)) · MMor f i) (CohomologyMorphism_KernelIn_comm f i)) · (CokernelArrow (Cokernel (KernelIn (to_Zero A) (Kernel (Diff C2 i)) (C2 (i - 1)) (transportf (precategory_morphisms (C2 (i - 1))) (maponpaths C2 (hzrminusplus i 1)) (Diff C2 (i - 1))) (CohomologyComplex_KernelIn_eq C2 i))))) = ZeroArrow (to_Zero A) _ _. Proof. rewrite assoc. rewrite CohomolohyMorphism_Ker_comm. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Definition CohomologyMorphism_Mor {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) (i : hz) : AbelianToAdditive A ⟦((CohomologyComplex C1) : Complex (AbelianToAdditive A)) i, ((CohomologyComplex C2) : Complex (AbelianToAdditive A)) i⟧. Proof. cbn. use CokernelOut. - use compose. + exact (Kernel (Diff C2 i)). + use KernelIn. * use compose. -- exact (C1 i). -- use KernelArrow. -- exact (MMor f i). * exact (CohomologyMorphism_KernelIn_comm f i). + use CokernelArrow. - apply CohomologyMorphism_Ker_Coker_Zero. Defined. Local Lemma CohomologyMorphism_Mor_comm {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) (i : hz) : (CohomologyMorphism_Mor f i) · (Diff ((CohomologyComplex C2) : Complex (AbelianToAdditive A)) i) = (Diff ((CohomologyComplex C1) : Complex (AbelianToAdditive A)) i) · (CohomologyMorphism_Mor f (i + 1)). Proof. cbn. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition CohomologyMorphism {C1 C2 : Complex (AbelianToAdditive A)} (f : Morphism C1 C2) : Morphism (CohomologyComplex C1) (CohomologyComplex C2). Proof. use make_Morphism. - intros i. exact (CohomologyMorphism_Mor f i). - intros i. exact (CohomologyMorphism_Mor_comm f i). Defined. (** ** Cohomology functor *) Definition CohomologyFunctor_data : functor_data (ComplexPreCat_AbelianPreCat A) (ComplexPreCat_AbelianPreCat A). Proof. use tpair. - cbn. intros C. exact (CohomologyComplex C). - cbn. intros C1 C2 f. exact (CohomologyMorphism f). Defined. Local Lemma CohomologyFunctor_id (C : (ComplexPreCat_AbelianPreCat A)) : CohomologyMorphism (IdMor C) = IdMor (CohomologyComplex C). Proof. cbn in *. use MorphismEq. intros i. cbn. apply pathsinv0. apply CokernelEndo_is_identity. unfold CohomologyMorphism_Mor. rewrite CokernelCommutes. rewrite <- id_left. apply cancel_postcomposition. use KernelInsEq. rewrite KernelCommutes. rewrite id_left. rewrite id_right. apply idpath. Qed. Local Lemma CohomologyFunctor_assoc {C1 C2 C3 : (ComplexPreCat_AbelianPreCat A)} (f : (ComplexPreCat_AbelianPreCat A)⟦C1, C2⟧) (g : (ComplexPreCat_AbelianPreCat A)⟦C2, C3⟧) : # CohomologyFunctor_data (f · g) = # CohomologyFunctor_data f · # CohomologyFunctor_data g. Proof. cbn in *. use MorphismEq. intros i. cbn. unfold CohomologyMorphism_Mor. use CokernelOutsEq. rewrite CokernelCommutes. rewrite assoc. rewrite CokernelCommutes. rewrite <- assoc. rewrite CokernelCommutes. rewrite assoc. apply cancel_postcomposition. use KernelInsEq. rewrite KernelCommutes. rewrite <- assoc. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. cbn. rewrite assoc. apply idpath. Qed. Definition CohomologyFunctor : functor (ComplexPreCat_AbelianPreCat A) (ComplexPreCat_AbelianPreCat A). Proof. use tpair. - exact CohomologyFunctor_data. - cbn. split. + intros C. cbn. exact (CohomologyFunctor_id C). + intros C1 C2 C3 f g. exact (CohomologyFunctor_assoc f g). Defined. End def_cohomology_complex. (** * Alternative definition of Cohomology complex *) (** ** Introduction We construct an isomorphic alternative of [CohomologyComplex]. *) Section def_cohomology'_complex. Variable A : AbelianPreCat. Definition CohomologyComplex' (C : (ComplexPreCat_AbelianPreCat A)) : (ComplexPreCat_AbelianPreCat A). Proof. cbn in *. use make_Complex. - intros i. exact (Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ (Diff C i) (CohomologyComplex_KernelIn_eq A C i))). - intros i. exact (ZeroArrow (to_Zero A) _ _). - intros i. apply ZeroArrow_comp_left. Defined. Local Lemma CohomologyComplexIso_eq1 (C : Complex (AbelianToAdditive A)) (i : hz) : (factorization1_monic A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) · (Diff C i) = ZeroArrow (to_Zero A) _ _. Proof. use (EpiisEpi A (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). rewrite assoc. rewrite <- factorization1. rewrite ZeroArrow_comp_right. exact (CohomologyComplex_KernelIn_eq A C i). Qed. Local Lemma CohomologyComplexIso_eq1' (C : Complex (AbelianToAdditive A)) (i : hz) : (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) · (factorization1_monic A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) · (Diff C i) = ZeroArrow (to_Zero A) _ _. Proof. rewrite <- factorization1. exact (CohomologyComplex_KernelIn_eq A C i). Qed. Local Lemma CohomologyComplexIso_eq2 (C : Complex (AbelianToAdditive A)) (i : hz) : (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · (factorization2_epi A (Diff C i)) = ZeroArrow (to_Zero A) _ _. Proof. use (MonicisMonic A (factorization2_monic A (Diff C i))). rewrite <- assoc. set (tmp := factorization1 (Diff C i)). cbn in tmp. cbn. rewrite <- assoc in tmp. rewrite <- tmp. clear tmp. rewrite ZeroArrow_comp_left. exact (CohomologyComplex_KernelIn_eq A C i). Qed. Local Lemma CohomologyComplexIso_eq2' (C : Complex (AbelianToAdditive A)) (i : hz) : (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · ((factorization2_epi A (Diff C i)) · (factorization2_monic A (Diff C i))) = ZeroArrow (to_Zero A) _ _. Proof. rewrite <- factorization2. exact (CohomologyComplex_KernelIn_eq A C i). Qed. Local Lemma CohomologyComplexIso_KerCokerIso_eq1 {x y : A} {f : A⟦x, y⟧} (CK1 CK2 : cokernels.Cokernel (to_Zero A) f) (K1 : kernels.Kernel (to_Zero A) (CokernelArrow CK1)) (K2 : kernels.Kernel (to_Zero A) (CokernelArrow CK2)) : KernelArrow K1 · CokernelArrow CK2 = ZeroArrow (to_Zero A) K1 CK2. Proof. assert (e1 : CokernelArrow CK2 = (CokernelArrow CK1) · (CokernelOut (to_Zero A) CK1 CK2 (CokernelArrow CK2) (CokernelCompZero (to_Zero A) CK2))). { rewrite CokernelCommutes. apply idpath. } rewrite e1. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Local Lemma CohomologyComplexIso_KerCokerIso_eq2 {x y : A} {f : A⟦x, y⟧} (CK1 CK2 : cokernels.Cokernel (to_Zero A) f) (K1 : kernels.Kernel (to_Zero A) (CokernelArrow CK1)) (K2 : kernels.Kernel (to_Zero A) (CokernelArrow CK2)) : KernelArrow K2 · CokernelArrow CK1 = ZeroArrow (to_Zero A) K2 CK1. Proof. assert (e1 : CokernelArrow CK1 = (CokernelArrow CK2) · (CokernelOut (to_Zero A) CK2 CK1 (CokernelArrow CK1) (CokernelCompZero (to_Zero A) CK1))). { rewrite CokernelCommutes. apply idpath. } rewrite e1. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Definition CohomologyComplexIso_KerCokerIso {x y : A} {f : A⟦x, y⟧} (CK1 CK2 : cokernels.Cokernel (to_Zero A) f) (K1 : kernels.Kernel (to_Zero A) (CokernelArrow CK1)) (K2 : kernels.Kernel (to_Zero A) (CokernelArrow CK2)) : iso K1 K2. Proof. use make_iso. - use KernelIn. + use KernelArrow. + exact (CohomologyComplexIso_KerCokerIso_eq1 CK1 CK2 K1 K2). - use is_iso_qinv. + use KernelIn. * use KernelArrow. * exact (CohomologyComplexIso_KerCokerIso_eq2 CK1 CK2 K1 K2). + split. * use (KernelArrowisMonic (to_Zero A) K1). rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. rewrite id_left. apply idpath. * use (KernelArrowisMonic (to_Zero A) K2). rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. rewrite id_left. apply idpath. Qed. Local Lemma CohomologyComplexIso_CokerKerIso_eq1 {x y : A} {f : A⟦x, y⟧} (K1 K2 : kernels.Kernel (to_Zero A) f) (CK1 : cokernels.Cokernel (to_Zero A) (KernelArrow K1)) (CK2 : cokernels.Cokernel (to_Zero A) (KernelArrow K2)) : KernelArrow K1 · CokernelArrow CK2 = ZeroArrow (to_Zero A) K1 CK2. Proof. assert (e1 : KernelArrow K1 = (KernelIn (to_Zero A) K2 K1 (KernelArrow K1) (KernelCompZero (to_Zero A) K1)) · (KernelArrow K2)). { rewrite KernelCommutes. apply idpath. } rewrite e1. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Local Lemma CohomologyComplexIso_CokerKerIso_eq2 {x y : A} {f : A⟦x, y⟧} (K1 K2 : kernels.Kernel (to_Zero A) f) (CK1 : cokernels.Cokernel (to_Zero A) (KernelArrow K1)) (CK2 : cokernels.Cokernel (to_Zero A) (KernelArrow K2)) : KernelArrow K2 · CokernelArrow CK1 = ZeroArrow (to_Zero A) K2 CK1. Proof. assert (e2 : KernelArrow K2 = (KernelIn (to_Zero A) K1 K2 (KernelArrow K2) (KernelCompZero (to_Zero A) K2)) · (KernelArrow K1)). { rewrite KernelCommutes. apply idpath. } rewrite e2. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Definition CohomologyComplexIso_CokerKerIso {x y : A} {f : A⟦x, y⟧} (K1 K2 : kernels.Kernel (to_Zero A) f) (CK1 : cokernels.Cokernel (to_Zero A) (KernelArrow K1)) (CK2 : cokernels.Cokernel (to_Zero A) (KernelArrow K2)) : iso CK1 CK2. Proof. use make_iso. - use CokernelOut. + use CokernelArrow. + exact (CohomologyComplexIso_CokerKerIso_eq1 K1 K2 CK1 CK2). - use is_iso_qinv. + use CokernelOut. * use CokernelArrow. * exact (CohomologyComplexIso_CokerKerIso_eq2 K1 K2 CK1 CK2). + split. * use (CokernelArrowisEpi (to_Zero A) CK1). rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. rewrite id_right. apply idpath. * use (CokernelArrowisEpi (to_Zero A) CK2). rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. rewrite id_right. apply idpath. Qed. Local Lemma CohomologyComplexIso_isMonic (C : Complex (AbelianToAdditive A)) (i : hz) : let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in isMonic K1. Proof. intros K1. use isMonic_postcomp. - exact (C i). - use KernelArrow. - unfold K1. rewrite KernelCommutes. apply MonicisMonic. Qed. Local Lemma CohomologyComplexIso_isEpi (C : Complex (AbelianToAdditive A)) (i : hz) : let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in isEpi CK1. Proof. intros CK1. use isEpi_precomp. - exact (C i). - use CokernelArrow. - unfold CK1. rewrite CokernelCommutes. apply EpiisEpi. Qed. Local Lemma CohomologyComplexIso_mor_eq1 (C : Complex (AbelianToAdditive A)) (i : hz) : let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) · K1 = KernelIn (to_Zero A) (Abelian.Kernel (Diff C i)) _ _ (CohomologyComplex_KernelIn_eq A C i). Proof. intros K1. unfold K1. rewrite <- (@KernelInComp A (to_Zero A) _ _ _ _ _ _ _ _ (CohomologyComplexIso_eq1' C i)). use KernelInsEq. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. apply factorization1. Qed. Local Lemma CohomologyComplexIso_mor_eq2 (C : Complex (AbelianToAdditive A)) (i : hz) : let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i)) = CK1 · (factorization2_monic A (Diff C i)). Proof. intros CK1. unfold CK1. rewrite <- (@CokernelOutComp A (to_Zero A) _ _ _ _ _ _ _ _ (CohomologyComplexIso_eq2' C i)). use CokernelOutsEq. rewrite CokernelCommutes. rewrite CokernelCommutes. apply factorization2. Qed. Local Lemma CohomologyComplexIso_isKernel_Eq (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in K1 · (φ1 · φ2) = ZeroArrow (to_Zero A) _ _. Proof. intros φ1 φ2 K1. rewrite assoc. unfold K1. unfold φ1. rewrite KernelCommutes. set (f1 := factorization1 (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). set (CK2 := CokernelPath A (to_Zero A) f1 (Cokernel _)). set (CK2' := CokernelEpiComp A (to_Zero A) _ _ CK2). set (K3 := MonicToKernel' A _ CK2'). apply (KernelCompZero (to_Zero A) K3). Qed. Local Lemma CohomologyComplexIso_isKernel (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in isKernel (to_Zero A) K1 (φ1 · φ2) (CohomologyComplexIso_isKernel_Eq C i). Proof. intros φ1 φ2 K1. set (f1 := factorization1 (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). set (CK2 := CokernelPath A (to_Zero A) f1 (Cokernel _)). set (CK2' := CokernelEpiComp A (to_Zero A) _ _ CK2). set (K3 := MonicToKernel' A _ CK2'). use make_isKernel. - intros w h H'. rewrite assoc in H'. use unique_exists. + exact (KernelIn (to_Zero A) K3 _ (h · φ1) H'). + cbn beta. use (KernelArrowisMonic (to_Zero A) (Kernel (Diff C i))). unfold K1. rewrite <- assoc. rewrite KernelCommutes. fold φ1. rewrite <- (KernelCommutes (to_Zero A) K3 _ _ H'). apply cancel_precomposition. apply idpath. + intros y. apply homset_property. + intros y X. cbn beta in X. apply (CohomologyComplexIso_isMonic C i). fold K1. rewrite X. use (KernelArrowisMonic (to_Zero A) (Kernel (Diff C i))). unfold K1. rewrite <- assoc. rewrite KernelCommutes. rewrite (KernelCommutes (to_Zero A) K3). apply idpath. Qed. Local Lemma CohomologyComplexIso_KernelArrow (C : Complex (AbelianToAdditive A)) (i : hz) : let K4 := make_Kernel _ _ _ (CohomologyComplexIso_isKernel_Eq C i) (CohomologyComplexIso_isKernel C i) in KernelArrow K4 = KernelIn (to_Zero A) (Kernel (Diff C i)) (Image (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (factorization1_monic A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (CohomologyComplexIso_eq1 C i). Proof. apply idpath. Qed. Local Lemma CohomologyComplexIso_isCokernel_Eq (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in φ1 · φ2 · CK1 = ZeroArrow (to_Zero A) _ _. Proof. intros φ1 φ2 CK1. unfold CK1. unfold φ2. rewrite <- assoc. rewrite CokernelCommutes. set (f2 := factorization2 (Diff C i)). set (K2 := KernelPath A (to_Zero A) f2 (Kernel _)). set (K2' := KernelCompMonic A (to_Zero A) _ _ K2). set (CK3 := EpiToCokernel' A _ K2'). apply (CokernelCompZero (to_Zero A) CK3). Qed. Local Lemma CohomologyComplexIso_isCokernel (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in isCokernel (to_Zero A) (φ1 · φ2) CK1 (CohomologyComplexIso_isCokernel_Eq C i). Proof. intros φ1 φ2 CK1. set (f2 := factorization2 (Diff C i)). set (K2 := KernelPath A (to_Zero A) f2 (Kernel _)). set (K2' := KernelCompMonic A (to_Zero A) _ _ K2). set (CK3 := EpiToCokernel' A _ K2'). use make_isCokernel. - intros w h H'. rewrite <- assoc in H'. use unique_exists. + exact (CokernelOut (to_Zero A) CK3 _ (φ2 · h) H'). + cbn beta. use (CokernelArrowisEpi (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). unfold CK1. rewrite assoc. rewrite CokernelCommutes. fold φ2. rewrite <- (CokernelCommutes (to_Zero A) CK3 _ _ H'). apply cancel_postcomposition. apply idpath. + intros y. apply homset_property. + intros y X. cbn beta in X. apply (CohomologyComplexIso_isEpi C i). fold CK1. rewrite X. use (CokernelArrowisEpi (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). unfold CK1. rewrite assoc. rewrite CokernelCommutes. rewrite (CokernelCommutes (to_Zero A) CK3). apply idpath. Qed. Local Lemma CohomologyComplexIso_CokernelArrow (C : Complex (AbelianToAdditive A)) (i : hz) : let CK4 := make_Cokernel _ _ _ (CohomologyComplexIso_isCokernel_Eq C i) (CohomologyComplexIso_isCokernel C i) in CokernelArrow CK4 = (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (CoImage (Diff C i)) (factorization2_epi A (Diff C i)) (CohomologyComplexIso_eq2 C i)). Proof. apply idpath. Qed. Definition CohomologyComplexIso_Mor1 (C : Complex (AbelianToAdditive A)) (i : hz) : let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in A⟦Cokernel (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · K1), Cokernel (KernelIn (to_Zero A) (Kernel (Diff C i)) (C (i - 1)) (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) (CohomologyComplex_KernelIn_eq A C i))⟧ := @CokernelOutPaths_is_iso_mor A (to_Zero A) _ _ _ _ (CohomologyComplexIso_mor_eq1 C i) (Cokernel _) (Cokernel _). Definition CohomologyComplexIso_Mor2 (C : Complex (AbelianToAdditive A)) (i : hz) : let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in A ⟦Cokernel K1, Cokernel (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · K1)⟧ := let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in CokernelEpiComp_mor2 A (to_Zero A) (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) K1 (Cokernel _) (Cokernel _). Definition CohomologyComplexIso_Mor3 (C : Complex (AbelianToAdditive A)) (i : hz) : let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in A⟦Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i)), Kernel (CK1 · factorization2_monic A (Diff C i))⟧ := @KernelInPaths_is_iso_mor A (to_Zero A) _ _ _ _ (CohomologyComplexIso_mor_eq2 C i) (Kernel _) (Kernel _). Definition CohomologyComplexIso_Mor4 (C : Complex (AbelianToAdditive A)) (i : hz) : let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in A ⟦Kernel (CK1 · factorization2_monic A (Diff C i)), Kernel CK1⟧ := (KernelCompMonic_mor1 A (to_Zero A) _ _ (Kernel _) (Kernel _)). Definition CohomologyComplexIso_Mor5 (C : Complex (AbelianToAdditive A)) (i : hz) : let K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i) in let K4 := make_Kernel _ _ _ (CohomologyComplexIso_isKernel_Eq C i) (CohomologyComplexIso_isKernel C i) in A⟦Cokernel (KernelArrow K4), Cokernel K1⟧ := @CokernelOutPaths_is_iso_mor A (to_Zero A) _ _ _ _ (CohomologyComplexIso_KernelArrow C i) (Cokernel _) (Cokernel _). Definition CohomologyComplexIso_Mor6 (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let K4 := make_Kernel _ _ _ (CohomologyComplexIso_isKernel_Eq C i) (CohomologyComplexIso_isKernel C i) in iso (CoImage (φ1 · φ2)) (Cokernel (KernelArrow K4)) := let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let K4 := make_Kernel _ _ _ (CohomologyComplexIso_isKernel_Eq C i) (CohomologyComplexIso_isKernel C i) in CohomologyComplexIso_CokerKerIso _ K4 (CoImage (φ1 · φ2)) (Cokernel (KernelArrow K4)). Definition CohomologyComplexIso_Mor7 (C : Complex (AbelianToAdditive A)) (i : hz) : let CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i) in A⟦Kernel CK1, Kernel (CokernelArrow (make_Cokernel (to_Zero A) (KernelArrow (Kernel (Diff C i)) · CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))) CK1 (CohomologyComplexIso_isCokernel_Eq C i) (CohomologyComplexIso_isCokernel C i)))⟧ := @KernelInPaths_is_iso_mor A (to_Zero A) _ _ _ _ (! (CohomologyComplexIso_CokernelArrow C i)) (Kernel _) (Kernel _). Definition CohomologyComplexIso_Mor8 (C : Complex (AbelianToAdditive A)) (i : hz) : let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let CK4 := make_Cokernel _ _ _ (CohomologyComplexIso_isCokernel_Eq C i) (CohomologyComplexIso_isCokernel C i) in iso (Kernel (CokernelArrow CK4)) (Image (φ1 · φ2)) := let φ1 := KernelArrow (Kernel (Diff C i)) in let φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) in let CK4 := make_Cokernel _ _ _ (CohomologyComplexIso_isCokernel_Eq C i) (CohomologyComplexIso_isCokernel C i) in CohomologyComplexIso_KerCokerIso CK4 _ (Kernel (CokernelArrow CK4)) (Image (φ1 · φ2)). Definition CohomologyComplexIso_Mor_i (C : Complex (AbelianToAdditive A)) (i : hz) : AbelianToAdditive A ⟦((CohomologyComplex' C) : Complex (AbelianToAdditive A)) i, ((CohomologyComplex A C) : Complex (AbelianToAdditive A)) i⟧. Proof. cbn. set (φ1 := KernelArrow (Kernel (Diff C i))). set (φ2 := CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). (* The idea is to pre- and postcompose with morphisms to reach inverse of [CoIm_to_Im_is_iso]. *) (* Change source and target by compose and postcompose with isomorphisms *) set (f1 := factorization1 (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). set (f2 := factorization2 (Diff C i)). set (K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i)). set (CK1 := CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) _ _ (CohomologyComplexIso_eq2 C i)). use (postcompose (CohomologyComplexIso_Mor1 C i)). use (postcompose (CohomologyComplexIso_Mor2 C i)). use (compose (CohomologyComplexIso_Mor3 C i)). use (compose (CohomologyComplexIso_Mor4 C i)). (* Postcompose *) set (CK2 := CokernelPath A (to_Zero A) f1 (Cokernel _)). set (CK2' := CokernelEpiComp A (to_Zero A) _ _ CK2). set (K3 := MonicToKernel' A _ CK2'). set (K4 := make_Kernel _ _ _ (CohomologyComplexIso_isKernel_Eq C i) (CohomologyComplexIso_isKernel C i)). use (postcompose (CohomologyComplexIso_Mor5 C i)). use (postcompose (CohomologyComplexIso_Mor6 C i)). (* compose *) set (K2 := KernelPath A (to_Zero A) f2 (Kernel _)). set (K2' := KernelCompMonic A (to_Zero A) _ _ K2). set (CK3 := EpiToCokernel' A _ K2'). set (CK4 := make_Cokernel _ _ _ (CohomologyComplexIso_isCokernel_Eq C i) (CohomologyComplexIso_isCokernel C i)). use (compose (CohomologyComplexIso_Mor7 C i)). use (compose (CohomologyComplexIso_Mor8 C i)). exact (iso_inv_from_is_iso _ (is_iso_qinv _ _ (CoIm_to_Im_is_iso A (φ1 · φ2)))). Defined. Local Lemma CohomologyComplexIso_Mor_comm (C : Complex (AbelianToAdditive A)) (i : hz) : (CohomologyComplexIso_Mor_i C i) · ZeroArrow (to_Zero A) _ _ = ZeroArrow (to_Zero A) _ _ · (CohomologyComplexIso_Mor_i C (i + 1)). Proof. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition CohomologyComplexIso_Mor (C : Complex (AbelianToAdditive A)) : ComplexPreCat_AbelianPreCat A ⟦CohomologyComplex' C, CohomologyComplex A C⟧. Proof. use make_Morphism. - intros i. exact (CohomologyComplexIso_Mor_i C i). - intros i. exact (CohomologyComplexIso_Mor_comm C i). Defined. Local Opaque is_iso_qinv. Lemma CohomologyComplexIso_is_iso_i (C : Complex (AbelianToAdditive A)) (i : hz) : is_iso (CohomologyComplexIso_Mor_i C i). Proof. unfold CohomologyComplexIso_Mor. cbn. unfold CohomologyComplexIso_Mor_i. cbn. unfold postcompose. use is_iso_comp_of_is_isos. - use is_iso_comp_of_is_isos. + use is_iso_comp_of_is_isos. * unfold CohomologyComplexIso_Mor3. apply KernelInPaths_is_iso. * use is_iso_comp_of_is_isos. -- unfold CohomologyComplexIso_Mor4. set (CK1 := Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). set (K1 := Kernel (CokernelOut (to_Zero A) CK1 (CoImage (Diff C i)) (factorization2_epi A (Diff C i)) (CohomologyComplexIso_eq2 C i))). apply (KernelCompMonic1 A (to_Zero A) (CokernelOut (to_Zero A) CK1 (CoImage (Diff C i)) (factorization2_epi A (Diff C i)) (CohomologyComplexIso_eq2 C i)) (factorization2_monic A (Diff C i)) (Kernel _) K1). -- use is_iso_comp_of_is_isos. ++ use is_iso_comp_of_is_isos. ** use is_iso_comp_of_is_isos. --- unfold CohomologyComplexIso_Mor7. apply KernelInPaths_is_iso. --- use is_iso_comp_of_is_isos. +++ unfold CohomologyComplexIso_Mor8. apply pr2. +++ apply is_iso_inv_from_iso. ** unfold CohomologyComplexIso_Mor6. apply pr2. ++ unfold CohomologyComplexIso_Mor5. apply CokernelOutPaths_is_iso. + unfold CohomologyComplexIso_Mor2. set (K1 := KernelIn (to_Zero A) (Kernel (Diff C i)) _ _ (CohomologyComplexIso_eq1 C i)). apply (CokernelEpiComp2 A (to_Zero A) (factorization1_epi A (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) K1 (Cokernel _) (Cokernel _)). - unfold CohomologyComplexIso_Mor1. apply CokernelOutPaths_is_iso. Qed. Local Transparent is_iso_qinv. Local Lemma CohomologyComplexIso_is_iso (C : Complex (AbelianToAdditive A)) : is_iso (CohomologyComplexIso_Mor C). Proof. use ComplexIsoIndexIso. intros i. exact (CohomologyComplexIso_is_iso_i C i). Qed. Definition CohomologyComplexIso (C : Complex (AbelianToAdditive A)) : iso (CohomologyComplex' C) (CohomologyComplex A C). Proof. use make_iso. - exact (CohomologyComplexIso_Mor C). - exact (CohomologyComplexIso_is_iso C). Defined. End def_cohomology'_complex. (** * Definition of quasi-isomorphisms *) (** ** Introduction A quasi-isomorphism is a morphism of complexes which maps to an isomorphisms by the cohomology functor H : C(A) -> C(A). See section [def_cohomology_complex] for definition of this functor. Quasi-isomorphisms are defined in [isQIS]. In [IdentityIsQIS] we show that identity morphism is a quasi-isomorphism, and in [CompIsQIS] we show that composition of quasi-isomorphisms is a quasi-isomorphism. *) Section def_quasi_isomorphisms. Variable A : AbelianPreCat. Definition isQIS {C1 C2 : (ComplexPreCat_AbelianPreCat A)} (f : (ComplexPreCat_AbelianPreCat A)⟦C1, C2⟧) : UU := is_iso (#(CohomologyFunctor A) f). Lemma isaprop_isQIS {C1 C2 : (ComplexPreCat_AbelianPreCat A)} (f : (ComplexPreCat_AbelianPreCat A)⟦C1, C2⟧) : isaprop (isQIS f). Proof. apply isaprop_is_iso. Qed. Lemma IdentityIsQIS (C : (ComplexPreCat_AbelianPreCat A)) : isQIS (identity C). Proof. exact (pr2 (functor_on_iso (CohomologyFunctor A) (identity_iso C))). Qed. Lemma CompIsQIS {C1 C2 C3 : (ComplexPreCat_AbelianPreCat A)} (f1 : (ComplexPreCat_AbelianPreCat A)⟦C1, C2⟧) (H1 : isQIS f1) (f2 : (ComplexPreCat_AbelianPreCat A)⟦C2, C3⟧) (H2 : isQIS f2) : isQIS (f1 · f2). Proof. unfold isQIS. rewrite functor_comp. apply (@is_iso_comp_of_isos (ComplexPreCat_AbelianPreCat A) _ _ _ (make_iso _ H1) (make_iso _ H2)). Qed. End def_quasi_isomorphisms. (** * Cohomology functor is an additive functor *) (** ** Introduction In this section we show that the cohomology functor, [CohomologyFunctor], is an additive functor. This is shown in [CohomologyFunctor_Additive]. *) Section def_cohomology_functor_additive. Variable A : AbelianPreCat. Local Lemma CohomologyFunctor_isAdditive : @isAdditiveFunctor (ComplexPreCat_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)) (CohomologyFunctor A). (* note: with primitive projections off, the goal can be written more simply as isAdditiveFunctor (CohomologyFunctor A) *) Proof. use make_isAdditiveFunctor. intros C1 C2. use tpair. - intros f1 f2. use MorphismEq. intros i. cbn in *. unfold CohomologyMorphism_Mor. set (CK1 := Cokernel (KernelIn (to_Zero A) (Kernel (Diff C1 i)) (C1 (i - 1)) (transportf (precategory_morphisms (C1 (i - 1))) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1))) (CohomologyComplex_KernelIn_eq A C1 i))). cbn in CK1. fold CK1. set (CK2 := Cokernel (KernelIn (to_Zero A) (Kernel (Diff C2 i)) (C2 (i - 1)) (transportf (precategory_morphisms (C2 (i - 1))) (maponpaths C2 (hzrminusplus i 1)) (Diff C2 (i - 1))) (CohomologyComplex_KernelIn_eq A C2 i))). cbn in CK2. fold CK2. set (tmp := CokernelOutOp (AbelianToAdditive A)). cbn in tmp. rewrite <- tmp. clear tmp. use CokernelOutsEq. rewrite CokernelCommutes. rewrite CokernelCommutes. set (tmp := @to_postmor_linear' (AbelianToAdditive A)). cbn in tmp. rewrite <- tmp. clear tmp. apply cancel_postcomposition. set (tmp := KernelInOp (AbelianToAdditive A)). cbn in tmp. rewrite <- tmp. clear tmp. use KernelInsEq. rewrite KernelCommutes. rewrite KernelCommutes. set (tmp := @to_premor_linear' (AbelianToAdditive A)). cbn in tmp. rewrite <- tmp. clear tmp. apply idpath. - cbn. use MorphismEq. intros i. cbn in *. unfold CohomologyMorphism_Mor. set (CK1 := Cokernel (KernelIn (to_Zero A) (Kernel (Diff C1 i)) (C1 (i - 1)) (transportf (precategory_morphisms (C1 (i - 1))) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1))) (CohomologyComplex_KernelIn_eq A C1 i))). cbn in CK1. fold CK1. set (CK2 := Cokernel (KernelIn (to_Zero A) (Kernel (Diff C2 i)) (C2 (i - 1)) (transportf (precategory_morphisms (C2 (i - 1))) (maponpaths C2 (hzrminusplus i 1)) (Diff C2 (i - 1))) (CohomologyComplex_KernelIn_eq A C2 i))). cbn in CK2. fold CK2. use CokernelOutsEq. rewrite CokernelCommutes. rewrite ZeroArrow_comp_right. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ (CokernelArrow CK2)). apply cancel_postcomposition. use KernelInsEq. rewrite KernelCommutes. rewrite ZeroArrow_comp_left. cbn. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition CohomologyFunctor_Additive : AdditiveFunctor (ComplexPreCat_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)). Proof. use make_AdditiveFunctor. - exact (CohomologyFunctor A). - exact CohomologyFunctor_isAdditive. Defined. End def_cohomology_functor_additive. (** * CohomologyFunctor factors through naive homotopy category *) (** ** Introduction We show that there exists a functor K(A) -> K(A) such that the following diagram is commutative C(A) -> C(A) | || (Think this as a triangle) K(A) -> C(A) Here C(A) -> C(A) is the cohomology functor H : C(A) -> C(A), [CohomologyFunctor], see section [def_cohomology_complex]. The vertical functor C(A) -> K(A) is the canonical functor [ComplexHomotFunctor]. The constructed functor K(A) -> K(A) is also additive. Using this functor we define quasi-isomorphisms for K(A). On objects this functor sends a complex X to its cohomology complex. This is easily verified to commute because the vertical functors are identity on objects. To construct the map on morphisms we first show that two homotopic, [ComplexHomotSubset], morphisms in C(A) are mapped to the same morphism by the cohomology functor for C(A). Thus, given a morphism f in K(A), for every morphism f' which maps to f by C(A) -> K(A) the image under C(A) -> C(A) is the same, that is, is contractible. This is the observation we use to define the map on morphisms. After this observation it is easy to see that the diagram is commutative. In [CohomologyFunctorHomotopy] it is shown that a morphism induced by homotopy is sent to the zero morphism in C(A). In [CohomologyFunctorHomotopies] we use this observation to prove that two homotopic morphisms are sent to the same morphisms by the cohomology functor. In [CohomologyFunctorH_Mor] we show that the image on morphisms is contractible, in [CohomologyFunctorH_functor_data] we construct the functor data for K(A) -> C(A), and finally in [CohomologyFunctorH] we construct the functor. Commutativity of the diagram is proved in [CohomologyFunctorHCommutes]. The fact that K(A) -> C(A) is additive is proved in [CohomologyFunctorH_Additive]. *) Section def_cohomology_homotopy. Variable A : AbelianPreCat. (** ** Homotopic maps are mapped to equal morphisms by the cohomology functor C(A) -> C(A) *) Lemma CohomologyFunctorHomotopy_eq1 {C1 C2 : Complex (AbelianToAdditive A)} (H : ComplexHomot _ C1 C2) (i : hz) : KernelArrow (Kernel (Diff C1 i)) · transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1)) · Diff C2 i = ZeroArrow (to_Zero A) (Kernel (Diff C1 i)) (C2 (i + 1)). Proof. induction (hzrminusplus i 1). cbn. rewrite <- assoc. rewrite <- assoc. set (tmp := DSq _ C2 (i - 1)). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Qed. (** Homotopy is mapped to ZeroArrow *) Lemma CohomologyFunctorHomotopy {C1 C2 : Complex (AbelianToAdditive A)} (H : ComplexHomot _ C1 C2) : CohomologyMorphism A (ComplexHomotMorphism (AbelianToAdditive A) H) = ZeroMorphism (AbelianToAdditive A) (CohomologyComplex A C1) (CohomologyComplex A C2). Proof. use MorphismEq. intros i. cbn. unfold CohomologyMorphism_Mor. use CokernelOutsEq. rewrite CokernelCommutes. rewrite ZeroArrow_comp_right. set (tmp := @KernelIn _ (to_Zero A) _ _ _ (Kernel (Diff C2 i)) (Kernel (Diff C1 i)) (KernelArrow (Kernel (Diff C1 i)) · (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1)))) (CohomologyFunctorHomotopy_eq1 H i)). assert (e0 : KernelIn (to_Zero A) (Kernel (Diff C2 i)) (Kernel (Diff C1 i)) (KernelArrow (Kernel (Diff C1 i)) · Abelian_op A (C1 i) (C2 i) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1))) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · H (i + 1)))) (CohomologyMorphism_KernelIn_comm A (ComplexHomotMorphism (AbelianToAdditive A) H) i) = tmp). { unfold tmp. clear tmp. use KernelInsEq. rewrite KernelCommutes. rewrite KernelCommutes. set (tmp := @to_premor_linear' (AbelianToAdditive A)). cbn in tmp. rewrite tmp. clear tmp. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite assoc. rewrite assoc. rewrite KernelCompZero. rewrite ZeroArrow_comp_left. rewrite <- PreAdditive_unel_zero. set (tmp := @to_runax' (AbelianToAdditive A)). cbn in tmp. rewrite tmp. clear tmp. apply idpath. } cbn. cbn in e0. rewrite e0. clear e0. unfold tmp. clear tmp. assert (e1 : KernelIn (to_Zero A) (Kernel (Diff C2 i)) (Kernel (Diff C1 i)) ((KernelArrow (Kernel (Diff C1 i))) · (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1)))) (CohomologyFunctorHomotopy_eq1 H i) = (KernelArrow (Kernel (Diff C1 i))) · (H i) · (KernelIn ((to_Zero A)) (Abelian.Kernel (Diff C2 i)) _ _ (CohomologyComplex_KernelIn_eq A C2 i))). { use KernelInsEq. rewrite KernelCommutes. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite KernelCommutes. rewrite transport_target_postcompose. apply idpath. } cbn. cbn in e1. rewrite e1. clear e1. rewrite <- assoc. rewrite CokernelCompZero. rewrite ZeroArrow_comp_right. apply idpath. Qed. Lemma CohomologyFunctorHomotopies {C1 C2 : Complex (AbelianToAdditive A)} (f g : (ComplexPreCat_Additive (AbelianToAdditive A))⟦C1, C2⟧) (H : subgrhrel (ComplexHomotSubgrp (AbelianToAdditive A) C1 C2) f g) : # (CohomologyFunctor_Additive A) f = # (CohomologyFunctor_Additive A) g. Proof. set (inv := @to_inv (ComplexPreCat_Additive (AbelianToAdditive A)) _ _ (# (CohomologyFunctor_Additive A) g)). set (tmp := @grrcan (@to_abgr (ComplexPreCat_Additive (AbelianToAdditive A)) _ _) (# (CohomologyFunctor_Additive A) f) (# (CohomologyFunctor_Additive A) g) inv). apply tmp. clear tmp. unfold inv. clear inv. set (tmp := @rinvax (ComplexPreCat_Additive (AbelianToAdditive A)) _ _ (# (CohomologyFunctor_Additive A) g)). use (pathscomp0 _ (! tmp)). clear tmp. rewrite <- AdditiveFunctorInv. set (tmp := AdditiveFunctorLinear (CohomologyFunctor_Additive A) f (to_inv g)). apply pathsinv0 in tmp. use (pathscomp0 tmp). clear tmp. use (squash_to_prop H). { apply has_homsets_ComplexPreCat_AbelianPreCat. } intros H'. induction H' as [H1 H2]. induction H1 as [H11 H12]. cbn in H11. cbn in H2. cbn. rewrite <- H2. clear H. use (squash_to_prop H12). { apply has_homsets_ComplexPreCat_AbelianPreCat. } intros G. induction G as [G1 G2]. rewrite <- G2. clear H11 H12 H2 G2. apply CohomologyFunctorHomotopy. Qed. (** ** Structure for the image of a morphism to make type cheking faster *) Definition CohomologyFunctorHIm {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} (f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧) : UU := ∑ (h : (ComplexPreCat_Additive (AbelianToAdditive A))⟦CohomologyComplex A C1, CohomologyComplex A C2⟧), ∏ (f' : ComplexPreCat_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (H : # (ComplexHomotFunctor (AbelianToAdditive A)) f' = f), h = # (CohomologyFunctor A) f'. Definition CohomologyFunctorHImMor {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} {f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧} (h : CohomologyFunctorHIm f) : (ComplexPreCat_Additive (AbelianToAdditive A))⟦CohomologyComplex A C1, CohomologyComplex A C2⟧ := pr1 h. Definition CohomologyFunctorHImEq {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} {f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧} (h : CohomologyFunctorHIm f) (f' : ComplexPreCat_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (H : # (ComplexHomotFunctor (AbelianToAdditive A)) f' = f) : CohomologyFunctorHImMor h = # (CohomologyFunctor A) f' := pr2 h f' H. Definition make_CohomologyFunctorHIm {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} (f : (ComplexHomot_Additive (AbelianToAdditive A))⟦C1, C2⟧) (h : (ComplexPreCat_Additive (AbelianToAdditive A))⟦CohomologyComplex A C1, CohomologyComplex A C2⟧) (HH : ∏ (f' : ComplexPreCat_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (H : # (ComplexHomotFunctor (AbelianToAdditive A)) f' = f), h = # (CohomologyFunctor A) f') : CohomologyFunctorHIm f := tpair _ h HH. Lemma CohomologyFunctorHImEquality {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} {f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧} (h : CohomologyFunctorHIm f) (h' : CohomologyFunctorHIm f) (e : CohomologyFunctorHImMor h = CohomologyFunctorHImMor h') : h = h'. Proof. use total2_paths_f. - exact e. - apply proofirrelevance. apply impred_isaprop. intros t0. apply impred_isaprop. intros H0. apply has_homsets_ComplexPreCat. Qed. (** ** Construction of the functor and commutativity *) Lemma CohomologyFunctorH_Mor_eq {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} (f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor (AbelianToAdditive A)) f) (f' : ComplexPreCat_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (H' : # (ComplexHomotFunctor (AbelianToAdditive A)) f' = f) : # (CohomologyFunctor A) (pr1 H) = # (CohomologyFunctor A) f'. Proof. use CohomologyFunctorHomotopies. use (@abgrquotpr_rel_paths _ (binopeqrel_subgr_eqrel (ComplexHomotSubgrp (AbelianToAdditive A) C1 C2))). use (pathscomp0 (hfiberpr2 _ _ H)). apply pathsinv0. exact H'. Qed. Definition CohomologyFunctorH_Mor {C1 C2 : ComplexHomot_Additive (AbelianToAdditive A)} (f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧) : iscontr (CohomologyFunctorHIm f). Proof. use (squash_to_prop (ComplexHomotFunctor_issurj (AbelianToAdditive A) f)). { apply isapropiscontr. } intros H. use make_iscontr. - use make_CohomologyFunctorHIm. + exact ((# (CohomologyFunctor A) (hfiberpr1 _ _ H))). + intros f' H'. exact (CohomologyFunctorH_Mor_eq f H f' H'). - intros t. use CohomologyFunctorHImEquality. use CohomologyFunctorHImEq. exact (hfiberpr2 _ _ H). Qed. Lemma CohomologyFunctorH_Mor_Id (C : ComplexHomot_Additive (AbelianToAdditive A)) : CohomologyFunctorHImMor (iscontrpr1 (CohomologyFunctorH_Mor (identity C))) = identity _. Proof. use (pathscomp0 (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor (identity C))) (identity _) (functor_id (ComplexHomotFunctor (AbelianToAdditive A)) _))). rewrite functor_id. apply idpath. Qed. Lemma CohomologyFunctorH_Mor_Comp {C1 C2 C3 : ComplexHomot_Additive (AbelianToAdditive A)} (f : ComplexHomot_Additive (AbelianToAdditive A) ⟦C1, C2⟧) (g : ComplexHomot_Additive (AbelianToAdditive A) ⟦C2, C3⟧) : (CohomologyFunctorHImMor (iscontrpr1 (CohomologyFunctorH_Mor (f · g)))) = (CohomologyFunctorHImMor (iscontrpr1 (CohomologyFunctorH_Mor f))) · (CohomologyFunctorHImMor (iscontrpr1 (CohomologyFunctorH_Mor g))) . Proof. use (squash_to_prop (ComplexHomotFunctor_issurj (AbelianToAdditive A) f)). { apply has_homsets_ComplexPreCat. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj (AbelianToAdditive A) g)). { apply has_homsets_ComplexPreCat. } intros g'. rewrite (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor f)) _ (hfiberpr2 _ _ f')). rewrite (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor g)) _ (hfiberpr2 _ _ g')). set (tmp := functor_comp (CohomologyFunctor A) (hfiberpr1 _ _ f') (hfiberpr1 _ _ g')). use (pathscomp0 _ tmp). clear tmp. use (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor (f · g)))). rewrite functor_comp. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Definition CohomologyFunctorH_functor_data : functor_data (ComplexHomot_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)). Proof. use tpair. - intros C. exact (CohomologyComplex A C). - intros C1 C2 f. exact (CohomologyFunctorHImMor (iscontrpr1 (CohomologyFunctorH_Mor f))). Defined. Local Lemma CohomologyFunctorH_isfunctor : is_functor CohomologyFunctorH_functor_data. Proof. split. - intros C. use CohomologyFunctorH_Mor_Id. - intros C1 C2 C3 f1 f2. use (CohomologyFunctorH_Mor_Comp f1 f2). Qed. Definition CohomologyFunctorH : functor (ComplexHomot_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)). Proof. use tpair. - exact CohomologyFunctorH_functor_data. - exact CohomologyFunctorH_isfunctor. Defined. Lemma CohomologyFunctorHCommutes : functor_composite (ComplexHomotFunctor (AbelianToAdditive A)) CohomologyFunctorH = (CohomologyFunctor A). Proof. use total2_paths_f. - use total2_paths_f. + apply idpath. + rewrite idpath_transportf. use funextsec. intros C1. use funextsec. intros C2. use funextsec. intros f. use (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor (# (ComplexHomotFunctor (AbelianToAdditive A)) f))) f (idpath _)). - apply proofirrelevance. apply isaprop_is_functor. use has_homsets_ComplexPreCat. Qed. (** ** Additivity of CohomologyFunctorH *) Local Opaque to_binop. Local Lemma CohomologyFunctorH_Additive_zero (C1 C2 : (ComplexHomot_Additive (AbelianToAdditive A))) : # CohomologyFunctorH (ZeroArrow (Additive.to_Zero (ComplexHomot_Additive (AbelianToAdditive A))) C1 C2) = ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (CohomologyFunctorH C1) (CohomologyFunctorH C2). Proof. use (pathscomp0 _ (@AdditiveFunctorZeroArrow (ComplexPreCat_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)) (CohomologyFunctor_Additive A) C1 C2)). assert (e0 : # (ComplexHomotFunctor (AbelianToAdditive A)) (ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) _ _) = ZeroArrow (Additive.to_Zero (ComplexHomot_Additive (AbelianToAdditive A))) C1 C2). { apply AdditiveFunctorZeroArrow. } rewrite <- e0. clear e0. use CohomologyFunctorHImEq. apply idpath. Qed. Local Lemma CohomologyFunctorH_Additive_linear {C1 C2 : (ComplexHomot_Additive (AbelianToAdditive A))} (f g : (ComplexHomot_Additive (AbelianToAdditive A))⟦C1, C2⟧) : # CohomologyFunctorH (to_binop C1 C2 f g) = to_binop (CohomologyFunctorH C1) (CohomologyFunctorH C2) (# CohomologyFunctorH f) (# CohomologyFunctorH g). Proof. use (squash_to_prop (ComplexHomotFunctor_issurj (AbelianToAdditive A) f)). { apply has_homsets_ComplexPreCat. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj (AbelianToAdditive A) g)). { apply has_homsets_ComplexPreCat. } intros g'. cbn. rewrite (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor f)) (hfiberpr1 _ _ f') (hfiberpr2 _ _ f')). rewrite (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor g)) (hfiberpr1 _ _ g') (hfiberpr2 _ _ g')). set (tmp := @AdditiveFunctorLinear (ComplexPreCat_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)) (CohomologyFunctor_Additive A) C1 C2 (hfiberpr1 # (ComplexHomotFunctor (AbelianToAdditive A)) f f') (hfiberpr1 # (ComplexHomotFunctor (AbelianToAdditive A)) g g')). use (pathscomp0 _ tmp). clear tmp. use (CohomologyFunctorHImEq (iscontrpr1 (CohomologyFunctorH_Mor (to_binop C1 C2 f g)))). rewrite AdditiveFunctorLinear. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Local Lemma CohomologyFunctorH_isAdditive : isAdditiveFunctor CohomologyFunctorH. Proof. refine (@make_isAdditiveFunctor' (ComplexHomot_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)) CohomologyFunctorH _ _). - intros C1 C2. exact (CohomologyFunctorH_Additive_zero C1 C2). - intros C1 C2 f g. exact (CohomologyFunctorH_Additive_linear f g). Qed. Definition CohomologyFunctorH_Additive : AdditiveFunctor (ComplexHomot_Additive (AbelianToAdditive A)) (ComplexPreCat_Additive (AbelianToAdditive A)). Proof. use make_AdditiveFunctor. - exact CohomologyFunctorH. - exact CohomologyFunctorH_isAdditive. Defined. Local Transparent to_binop. (** ** Quasi-isomorphisms in K(A) *) Definition isHQIS {C1 C2 : (ComplexHomot_Additive (AbelianToAdditive A))} (f : (ComplexHomot_Additive (AbelianToAdditive A))⟦C1, C2⟧) : UU := is_iso (# CohomologyFunctorH_Additive f). Lemma isaprop_isHQIS {C1 C2 : (ComplexHomot_Additive (AbelianToAdditive A))} (f : (ComplexHomot_Additive (AbelianToAdditive A))⟦C1, C2⟧) : isaprop (isHQIS f). Proof. apply isaprop_is_iso. Qed. Lemma IdentityIsHQIS (C : (ComplexHomot_Additive (AbelianToAdditive A))) : isHQIS (identity C). Proof. exact (pr2 (functor_on_iso CohomologyFunctorH (identity_iso C))). Qed. Lemma CompIsHQIS {C1 C2 C3 : (ComplexHomot_Additive (AbelianToAdditive A))} (f1 : (ComplexHomot_Additive (AbelianToAdditive A))⟦C1, C2⟧) (H1 : isHQIS f1) (f2 : (ComplexHomot_Additive (AbelianToAdditive A))⟦C2, C3⟧) (H2 : isHQIS f2) : isHQIS (f1 · f2). Proof. unfold isHQIS. rewrite functor_comp. apply (@is_iso_comp_of_isos (ComplexPreCat_Additive (AbelianToAdditive A)) _ _ _ (make_iso _ H1) (make_iso _ H2)). Qed. End def_cohomology_homotopy. (** * Complex of kernels and complex of cokernels Let X be a complex. We construct a complex of kernels, which has objects ker d^{i+1}, and a complex of cokernels, which has objects coker d^{i-1}. The differentials of these complexes are the induced morphisms obtained by KernelIn and CokernelOut. For all integers i, we construct a morphisms h^i : coker d^{i-1} -> ker d^{i+1}, which is unique up to 2 commutative triangles. We show that the ith cohomology of X is isomorphic to the kernel of h^i and that the (i+1)th cohomology of X is isomorphic to cokernel of h^i. These results will be used, together with the snake lemma, to construct the long exact sequence associated to a short exact sequence of complexes. The complex of kernels is constructed in [KernelComplex]. The complex of cokernels is constructed in [CokernelComplex]. The morphism h^i is constructed in [CokernelKernelMorphism], where it is also shown to be unique with respect to the 2 commutative triangles. An isomorphism of ith cohomology of X with the kernel of h^i is constructed in [CokernelKernelCohomology1]. An isomorphism of the (i+1)th cohomology of X with cokernel of h^i is constructed in [CokernelKernelCohomology2]. *) Section def_kernel_cokernel_complex. Variable A : AbelianPreCat. (** ** Construction of kernel and cokernel complexes *) (** *** Complex of kernels *) Local Lemma KernelComplex_Kernel_comm (C : Complex (AbelianToAdditive A)) (i : hz) : KernelArrow (Kernel (Diff C i)) · Diff C i · Diff C (i + 1) = ZeroArrow (to_Zero A) (Kernel (Diff C i)) (C (i + 1 + 1)). Proof. rewrite <- assoc. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (KernelArrow (Kernel (Diff C i)))). apply cancel_precomposition. exact (DSq (AbelianToAdditive A) C i). Qed. Local Lemma KernelComplex_comm (C : Complex (AbelianToAdditive A)) (i : hz) : (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Kernel (Diff C i)) (KernelArrow (Kernel (Diff C i)) · Diff C i) (KernelComplex_Kernel_comm C i)) · (KernelIn (to_Zero A) (Kernel (Diff C (i + 1 + 1))) (Kernel (Diff C (i + 1))) (KernelArrow (Kernel (Diff C (i + 1))) · Diff C (i + 1)) (KernelComplex_Kernel_comm C (i + 1))) = ZeroArrow (to_Zero A) (Kernel (Diff C i)) (Kernel (Diff C (i + 1 + 1))). Proof. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. rewrite ZeroArrow_comp_left. exact (KernelComplex_Kernel_comm C i). Qed. Definition KernelComplex (C : Complex (AbelianToAdditive A)) : Complex (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Kernel (Diff C (i + 1))). - intros i. cbn. use KernelIn. + use compose. * exact (C (i + 1)). * use KernelArrow. * exact (Diff C (i + 1)). + exact (KernelComplex_Kernel_comm C (i + 1)). - intros i. cbn. exact (KernelComplex_comm C (i + 1)). Defined. (** *** Complex of cokernels *) Local Lemma CokernelComplex_Cokernel_comm (C : Complex (AbelianToAdditive A)) (i : hz) : (Diff C (i - 1)) · (transportf (λ x' : A, A ⟦ x', C (i + 1 - 1 + 1) ⟧) (! maponpaths C (hzrminusplus i 1 @ hzrplusminus' i 1)) (Diff C (i + 1 - 1)) · CokernelArrow (Cokernel (Diff C (i + 1 - 1)))) = ZeroArrow (to_Zero A) (C (i - 1)) (Cokernel (Diff C (i + 1 - 1))). Proof. induction (hzrminusplus i 1 @ hzrplusminus' i 1). cbn. rewrite assoc. set (tmp := DSq (AbelianToAdditive A) C (i - 1)). cbn in tmp. rewrite tmp. clear tmp. apply ZeroArrow_comp_left. Qed. Local Lemma CokernelComplex_comm (C : Complex (AbelianToAdditive A)) (i : hz) : CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (Cokernel (Diff C (i + 1 - 1))) (transportf (λ x' : A, A ⟦ x', C (i + 1 - 1 + 1) ⟧) (! maponpaths C (hzrminusplus i 1 @ hzrplusminus' i 1)) (Diff C (i + 1 - 1)) · CokernelArrow (Cokernel (Diff C (i + 1 - 1)))) (CokernelComplex_Cokernel_comm C i) · CokernelOut (to_Zero A) (Cokernel (Diff C (i + 1 - 1))) (Cokernel (Diff C (i + 1 + 1 - 1))) (transportf (λ x' : A, A ⟦ x', C (i + 1 + 1 - 1 + 1) ⟧) (! maponpaths C (hzrminusplus (i + 1) 1 @ hzrplusminus' (i + 1) 1)) (Diff C (i + 1 + 1 - 1)) · CokernelArrow (Cokernel (Diff C (i + 1 + 1 - 1)))) (CokernelComplex_Cokernel_comm C (i + 1)) = ZeroArrow (to_Zero A) (Cokernel (Diff C (i - 1))) (Cokernel (Diff C (i + 1 + 1 - 1))). Proof. use (CokernelArrowisEpi (to_Zero A) (Cokernel (Diff C (i - 1)))). rewrite ZeroArrow_comp_right. rewrite assoc. rewrite CokernelCommutes. rewrite <- assoc. rewrite CokernelCommutes. rewrite assoc. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ (CokernelArrow (Cokernel (Diff C (i + 1 + 1 - 1))))). apply cancel_postcomposition. use (transport_source_path _ _ (! maponpaths C (hzrplusminus i 1 @ hzrminusplus' i 1))). rewrite <- transport_source_precompose. rewrite <- maponpathsinv0. rewrite <- functtransportf. rewrite <- maponpathsinv0. rewrite <- functtransportf. rewrite transport_f_f. assert (e0 : (! (hzrminusplus i 1 @ hzrplusminus' i 1) @ ! (hzrplusminus i 1 @ hzrminusplus' i 1)) = idpath _) by apply isasethz. cbn in e0. cbn. rewrite e0. clear e0. cbn. rewrite transport_source_ZeroArrow. induction (hzrminusplus (i + 1) 1). cbn. induction (hzrplusminus' (i + 1 - 1 + 1) 1). cbn. exact (DSq _ C (i + 1 - 1)). Qed. Definition CokernelComplex (C : Complex (AbelianToAdditive A)) : Complex (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Cokernel (Diff C (i - 1))). - intros i. cbn. use CokernelOut. + use compose. * exact (C (i + 1 - 1 + 1)). * use (transportf (λ x' : A, precategory_morphisms x' (C (i + 1 - 1 + 1))) (! maponpaths C (hzrminusplus i 1 @ hzrplusminus' i 1))). cbn. exact (Diff C (i + 1 - 1)). * use CokernelArrow. + exact (CokernelComplex_Cokernel_comm C i). - intros i. cbn. exact (CokernelComplex_comm C i). Defined. (** ** Construction of h^i and isomorphisms with cohomology *) (** *** Uniqueness and existence of h^i *) Local Lemma CokernelKernelMorphism_comm1 (C : Complex (AbelianToAdditive A)) (i : hz) : Diff C (i - 1) · transportf (λ x : A, A ⟦x, C (i + 1)⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i) = ZeroArrow (to_Zero A) (C (i - 1)) (C (i + 1)). Proof. induction (hzrminusplus i 1). cbn. exact (DSq _ C (i - 1)). Qed. Local Lemma CokernelKernelMorphism_comm2 (C : Complex (AbelianToAdditive A)) (i : hz) : CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i) · Diff C (i + 1) = ZeroArrow (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1 + 1)). Proof. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite ZeroArrow_comp_right. induction (hzrminusplus i 1). cbn. exact (DSq _ C (i - 1 + 1)). Qed. Local Lemma CokernelKernelMorphism_comm3 (C : Complex (AbelianToAdditive A)) (i : hz) : KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C i) (Diff C i) (DSq (AbelianToAdditive A) C i) = transportf (λ i0 : pr1 hz, A ⟦ C i0, Cokernel (Diff C (i - 1)) ⟧) (hzrminusplus i 1) (CokernelArrow (Cokernel (Diff C (i - 1)))) · KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i). Proof. use KernelInsEq. rewrite KernelCommutes. rewrite <- assoc. rewrite KernelCommutes. assert (e1 : transportf (λ i0 : pr1 hz, A ⟦ C i0, Cokernel (Diff C (i - 1)) ⟧) (hzrminusplus i 1) (CokernelArrow (Cokernel (Diff C (i - 1)))) = transportf (λ x : A, A⟦x, Cokernel (Diff C (i - 1))⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (Diff C (i - 1))))). { rewrite <- functtransportf. apply idpath. } rewrite e1. clear e1. rewrite <- transport_source_precompose. rewrite CokernelCommutes. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite <- functtransportf. assert (e2 : ! hzrminusplus i 1 @ hzrminusplus i 1 = idpath _) by apply isasethz. rewrite e2. apply idpath. Qed. Local Lemma CokernelKernelMorphism_comm1' (C : Complex (AbelianToAdditive A)) (i : hz) : Diff C (i - 1) · transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i) = ZeroArrow (to_Zero A) (C (i - 1)) (C (i + 1)). Proof. induction (hzrminusplus i 1). cbn. exact (DSq _ C (i - 1)). Qed. Local Lemma CokernelKernelMorphism_comm2' (C : Complex (AbelianToAdditive A)) (i : hz) : CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1' C i) = (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i)) · (KernelArrow (Kernel (Diff C (i + 1)))). Proof. rewrite KernelCommutes. use CokernelOutsEq. rewrite CokernelCommutes. rewrite CokernelCommutes. apply idpath. Qed. Local Lemma CokernelKernelMorphism_uni (C : Complex (AbelianToAdditive A)) (i : hz) : ∏ t : ∑ f : A ⟦Cokernel (Diff C (i - 1)), Kernel (Diff C (i + 1))⟧, (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C i) (Diff C i) (DSq (AbelianToAdditive A) C i) = transportf (λ i0 : pr1 hz, A ⟦ C i0, Cokernel (Diff C (i - 1)) ⟧) (hzrminusplus i 1) (CokernelArrow (Cokernel (Diff C (i - 1)))) · f) × (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1' C i) = f · KernelArrow (Kernel (Diff C (i + 1)))), t = KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i),, CokernelKernelMorphism_comm3 C i,, CokernelKernelMorphism_comm2' C i. Proof. intros t. induction t as [t1 t2]. induction t2 as [t21 t22]. use total2_paths_f. - cbn. use KernelInsEq. rewrite KernelCommutes. use CokernelOutsEq. rewrite CokernelCommutes. rewrite assoc. use transport_source_path. + exact (C i). + exact (! maponpaths C (hzrminusplus' i 1)). + rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. assert (e0 : (! hzrminusplus i 1 @ ! hzrminusplus' i 1) = idpath _) by apply isasethz. cbn in e0. cbn. rewrite e0. clear e0. cbn. rewrite transport_source_precompose. rewrite transport_source_precompose. rewrite <- functtransportf. assert (e1 : ! hzrminusplus' i 1 = hzrminusplus i 1) by apply isasethz. cbn in e1. rewrite e1. clear e1. rewrite <- t21. rewrite KernelCommutes. apply idpath. - apply proofirrelevance. apply isapropdirprod. + apply homset_property. + apply homset_property. Qed. Definition CokernelKernelMorphism (C : Complex (AbelianToAdditive A)) (i : hz) : iscontr (∑ f : A⟦(CokernelComplex C) i, (KernelComplex C) i⟧, ((KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C i) (Diff C i) (DSq _ C i)) = (transportf (λ (i0 : hz), A⟦C i0, (Cokernel (Diff C (i - 1)))⟧) (hzrminusplus i 1) (CokernelArrow (Cokernel (Diff C (i - 1))))) · f) × ((CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1' C i)) = f · (KernelArrow (Kernel (Diff C (i + 1)))))). Proof. use tpair. - use tpair. + cbn. use KernelIn. * use CokernelOut. -- exact (transportf (λ (x : A), A⟦x, C(i + 1)⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)). -- exact (CokernelKernelMorphism_comm1 C i). * exact (CokernelKernelMorphism_comm2 C i). + cbn. split. * exact (CokernelKernelMorphism_comm3 C i). * exact (CokernelKernelMorphism_comm2' C i). - cbn. exact (CokernelKernelMorphism_uni C i). Defined. (** *** Kernel and cohomology *) Local Lemma CokernelKernelCohomology1_eq (C : Complex (AbelianToAdditive A)) (i : hz) : let CK := Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) in (Diff C (i - 1)) · (transportf (λ x' : A, A ⟦ x', CK⟧) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow CK)) = ZeroArrow (to_Zero A) _ _. Proof. induction (hzrminusplus i 1). cbn. apply CokernelCompZero. Qed. Local Lemma CokernelKernelCohomology1_Mor1_eq1 (C : Complex (AbelianToAdditive A)) (i : hz) : (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · (transportf (λ x' : A, A ⟦ x', Cokernel (Diff C (i - 1)) ⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (Diff C (i - 1))))) = ZeroArrow (to_Zero A) _ _. Proof. rewrite transport_compose'. use CokernelCompZero. Qed. Local Lemma CokernelKernelCohomology1_Mor1_comm1 (C : Complex (AbelianToAdditive A)) (i : hz) : KernelArrow (Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i))) · CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (Cokernel (Diff C (i - 1))) (transportf (λ x' : A, A ⟦ x', Cokernel (Diff C (i - 1)) ⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (Diff C (i - 1))))) (CokernelKernelCohomology1_Mor1_eq1 C i) · KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i) = ZeroArrow (to_Zero A) _ _. Proof. set (K := Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i))). cbn. use (KernelArrowisMonic (to_Zero A) (Kernel (Diff C (i + 1)))). rewrite <- assoc. rewrite <- assoc. rewrite KernelCommutes. rewrite ZeroArrow_comp_left. cbn. cbn in K. fold K. rewrite <- (KernelCompZero (to_Zero A) K). apply cancel_precomposition. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. use transport_source_path. - exact (C (i - 1 + 1)). - exact (! maponpaths C (hzrminusplus i 1)). - rewrite <- transport_source_precompose. set (tmp := CokernelCommutes (to_Zero A) (Cokernel (Diff C (i - 1))) _ _ (CokernelKernelMorphism_comm1 C i)). cbn in tmp. cbn. rewrite tmp. clear tmp. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. assert (e0 : (hzrminusplus i 1 @ ! hzrminusplus i 1) = idpath _) by apply isasethz. cbn. cbn in e0. rewrite e0. clear e0. cbn. apply idpath. Qed. Definition CokernelKernelCohomology1_Mor1 (C : Complex (AbelianToAdditive A)) (i : hz) : A⟦(((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) i), (Kernel (pr1 (pr1 (CokernelKernelMorphism C i))))⟧. Proof. set (K := Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i))). use (compose (iso_inv_from_is_iso _ (CohomologyComplexIso_is_iso_i A C i))). use KernelIn. - cbn. use (compose (KernelArrow K)). use CokernelOut. + exact (transportf (λ x' : A, A ⟦x', Cokernel (Diff C (i - 1))⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (Diff C (i - 1))))). + exact (CokernelKernelCohomology1_Mor1_eq1 C i). - exact (CokernelKernelCohomology1_Mor1_comm1 C i). Defined. Local Lemma CokernelKernelCohomology1_Mor2_comm1 (C : Complex (AbelianToAdditive A)) (i : hz) : KernelArrow (Kernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦x, C (i + 1)⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i))) · CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (transportf (λ x' : A, A ⟦x', Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))⟧) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))))) (CokernelKernelCohomology1_eq C i) · (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i)) = ZeroArrow (to_Zero A) _ _. Proof. set (CK := Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). cbn. cbn in CK. fold CK. set (K := (Kernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i)))). cbn. cbn in K. fold K. set (tmp := dirprod_pr2 (pr2 (pr1 (CokernelKernelMorphism C i)))). assert (e0 : CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) CK (transportf (λ x' : A, A ⟦ x', CK ⟧) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow CK)) (CokernelKernelCohomology1_eq C i) · CokernelOut (to_Zero A) CK (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i) = (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i)) · KernelArrow (Kernel _)). { use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. use transport_source_path. + exact (C i). + exact (! maponpaths C (! hzrminusplus i 1)). + rewrite transport_source_precompose. rewrite transport_f_f. rewrite maponpathsinv0. rewrite pathsinv0inv0. assert (e0 : (! maponpaths C (hzrminusplus i 1) @ maponpaths C (hzrminusplus i 1)) = maponpaths C (idpath _)). { rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. apply maponpaths. apply isasethz. } cbn. cbn in e0. rewrite e0. clear e0. cbn. rewrite CokernelCommutes. cbn in tmp. rewrite <- tmp. clear tmp. use transport_source_path. * exact (C (i - 1 + 1)). * exact (! maponpaths C (hzrminusplus i 1)). * rewrite transport_source_precompose. rewrite transport_source_precompose. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite pathsinv0r. cbn. rewrite CokernelCommutes. rewrite maponpathsinv0. apply idpath. } rewrite <- assoc. cbn in e0. rewrite e0. clear e0. rewrite KernelCommutes. unfold K. set (CKO := CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)). cbn. cbn in CKO. fold CKO. set (K2 := Kernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) CKO (CokernelKernelMorphism_comm2 C i))). rewrite <- (ZeroArrow_comp_left _ _ _ _ _ (KernelArrow (Kernel (Diff C (i + 1))))). rewrite <- (KernelCompZero (to_Zero A) K2). unfold CKO. unfold K2. clear K2. unfold CKO. clear CKO. cbn. rewrite <- assoc. apply cancel_precomposition. apply pathsinv0. use KernelCommutes. Qed. Definition CokernelKernelCohomology1_Mor2 (C : Complex (AbelianToAdditive A)) (i : hz) : A⟦(Kernel (pr1 (pr1 (CokernelKernelMorphism C i)))), (((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) i)⟧. Proof. use (postcompose (CohomologyComplexIso_Mor_i A C i)). cbn. use KernelIn. - use (compose (KernelArrow _)). use CokernelOut. + exact (transportf (λ x' : A, precategory_morphisms x' _) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))))). + exact (CokernelKernelCohomology1_eq C i). - exact (CokernelKernelCohomology1_Mor2_comm1 C i). Defined. Local Lemma CokernelKernelCohomology1_id1 (C : Complex (AbelianToAdditive A)) (i : hz) : CokernelKernelCohomology1_Mor2 C i · CokernelKernelCohomology1_Mor1 C i = identity (Kernel (pr1 (pr1 (CokernelKernelMorphism C i)))). Proof. unfold CokernelKernelCohomology1_Mor2. unfold postcompose. unfold CokernelKernelCohomology1_Mor1. cbn. (* Make the goal more readable *) set (K1 := Kernel (CokernelOut (to_Zero A) (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i))). cbn in K1. fold K1. set (K2 := (Kernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (Cokernel (Diff C (i - 1))) (CokernelOut (to_Zero A) (Cokernel (Diff C (i - 1))) (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i)))). cbn in K2. fold K2. set (CK1 := (Cokernel (Diff C (i - 1)))). set (CK2 := (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). cbn in CK2. fold CK2. use KernelInsEq. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite KernelCommutes. rewrite id_left. (* Get rid of the inv_from_iso stuff *) assert (ee : ((CohomologyComplexIso_Mor_i A C i) · (inv_from_iso (CohomologyComplexIso_Mor_i A C i,, CohomologyComplexIso_is_iso_i A C i) · (KernelArrow K1 · CokernelOut (to_Zero A) CK2 CK1 (transportf (λ x' : A, A ⟦ x', CK1 ⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow CK1)) (CokernelKernelCohomology1_Mor1_eq1 C i)))) = (KernelArrow K1 · CokernelOut (to_Zero A) CK2 CK1 (transportf (λ x' : A, A ⟦ x', CK1 ⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow CK1)) (CokernelKernelCohomology1_Mor1_eq1 C i))). { rewrite assoc. rewrite assoc. apply cancel_postcomposition. assert (ee' : (CohomologyComplexIso_Mor_i A C i) · (inv_from_iso ((CohomologyComplexIso_Mor_i A C i) ,, (CohomologyComplexIso_is_iso_i A C i))) = identity _). { apply (iso_inv_after_iso (make_iso _ (CohomologyComplexIso_is_iso_i A C i))). } cbn beta in ee'. rewrite ee'. clear ee'. apply id_left. } cbn in ee. cbn. apply (maponpaths (λ gg : _, KernelIn (to_Zero A) K1 K2 (KernelArrow K2 · CokernelOut (to_Zero A) CK1 CK2 (transportf (λ x' : A, A ⟦ x', CK2 ⟧) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow CK2)) (CokernelKernelCohomology1_eq C i)) (CokernelKernelCohomology1_Mor2_comm1 C i) · gg)) in ee. use (pathscomp0 ee). clear ee. (* Use KernelCommutes and CokernelCommutes to solve the goal *) rewrite assoc. rewrite KernelCommutes. rewrite <- id_right. rewrite <- assoc. apply cancel_precomposition. use CokernelOutsEq. rewrite id_right. rewrite assoc. rewrite CokernelCommutes. use transport_source_path. -- exact (C i). -- exact (! maponpaths C (! hzrminusplus i 1)). -- rewrite transport_source_precompose. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite pathsinv0inv0. rewrite pathsinv0l. cbn. apply CokernelCommutes. Qed. Local Lemma CokernelKernelCohomology1_id2 (C : Complex (AbelianToAdditive A)) (i : hz) : CokernelKernelCohomology1_Mor1 C i · CokernelKernelCohomology1_Mor2 C i = identity _. Proof. unfold CokernelKernelCohomology1_Mor2. unfold postcompose. unfold CokernelKernelCohomology1_Mor1. cbn. (* Make the goal more readable *) set (CK1 := (Cokernel (Diff C (i - 1)))). set (CK2 := (Cokernel (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))))). cbn in CK2. fold CK2. set (K1 := Kernel (CokernelOut (to_Zero A) CK2 (C (i + 1)) (Diff C i) (CohomologyComplex_KernelIn_eq A C i))). set (K2 := Kernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) CK1 (CokernelOut (to_Zero A) CK1 (C (i + 1)) (transportf (λ x : A, A ⟦ x, C (i + 1) ⟧) (! maponpaths C (hzrminusplus i 1)) (Diff C i)) (CokernelKernelMorphism_comm1 C i)) (CokernelKernelMorphism_comm2 C i))). cbn in K2. fold K2. set (KI21 := KernelIn (to_Zero A) K2 K1 ((KernelArrow K1) · (CokernelOut (to_Zero A) CK2 CK1 (transportf (λ x' : A, A ⟦ x', CK1 ⟧) (maponpaths C (hzrminusplus i 1)) (CokernelArrow CK1)) (CokernelKernelCohomology1_Mor1_eq1 C i))) (CokernelKernelCohomology1_Mor1_comm1 C i)). cbn in KI21. fold KI21. set (KI12 := KernelIn (to_Zero A) K1 K2 (KernelArrow K2 · CokernelOut (to_Zero A) CK1 CK2 (transportf (λ x' : A, A ⟦ x', CK2 ⟧) (! maponpaths C (hzrminusplus i 1)) (CokernelArrow CK2)) (CokernelKernelCohomology1_eq C i)) (CokernelKernelCohomology1_Mor2_comm1 C i)). cbn in KI12. fold KI12. (* Begin to prove the equality *) (* Cancel the inv_from_iso *) use (pre_comp_with_iso_is_inj _ _ _ _ (CohomologyComplexIso_is_iso_i A C i)). rewrite assoc. rewrite assoc. rewrite assoc. assert (e : (CohomologyComplexIso_Mor_i A C i) · (inv_from_iso ((CohomologyComplexIso_Mor_i A C i) ,, (CohomologyComplexIso_is_iso_i A C i))) = identity _). { apply (iso_inv_after_iso (make_iso _ (CohomologyComplexIso_is_iso_i A C i))). } cbn beta in e. rewrite id_right. apply (maponpaths (λ gg : _, gg · KI21 · KI12 · CohomologyComplexIso_Mor_i A C i)) in e. use (pathscomp0 e). clear e. rewrite id_left. (* Cancel the last morphism *) use (post_comp_with_iso_is_inj _ _ _ (is_iso_inv_from_iso (make_iso _ (CohomologyComplexIso_is_iso_i A C i)))). rewrite <- assoc. rewrite <- assoc. assert (ee : (CohomologyComplexIso_Mor_i A C i) · (inv_from_iso (make_iso _ (CohomologyComplexIso_is_iso_i A C i))) = identity _). { apply (iso_inv_after_iso (make_iso _ (CohomologyComplexIso_is_iso_i A C i))). } cbn beta in ee. rewrite ee. apply (maponpaths (λ gg : _, KI21 · (KI12 · gg))) in ee. use (pathscomp0 ee). clear ee. rewrite id_right. (* Solve by using KernelInsEq *) unfold KI12, KI21. clear KI12 KI21. unfold K1, K2. clear K1 K2. unfold CK1, CK2. clear CK1 CK2. cbn. use KernelInsEq. rewrite <- assoc. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. rewrite id_left. rewrite <- id_right. rewrite <- assoc. apply cancel_precomposition. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. rewrite id_right. use transport_source_path. - exact (C (i - 1 + 1)). - exact (! maponpaths C (hzrminusplus i 1)). - rewrite transport_source_precompose. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite pathsinv0r. cbn. rewrite maponpathsinv0. apply CokernelCommutes. Qed. Definition CokernelKernelCohomology1 (C : Complex (AbelianToAdditive A)) (i : hz) : iso (Kernel (pr1 (pr1 (CokernelKernelMorphism C i)))) ((((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) i)). Proof. use make_iso. - exact (CokernelKernelCohomology1_Mor2 C i). - use is_iso_qinv. + exact (CokernelKernelCohomology1_Mor1 C i). + split. * exact (CokernelKernelCohomology1_id1 C i). * exact (CokernelKernelCohomology1_id2 C i). Defined. (** *** Cokernel and cohomology *) Local Lemma CokernelKernelCohomology2_comm1 (C : Complex (AbelianToAdditive A)) (i : hz) : let CK := Cokernel (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C (i + 1 - 1)) (transportf (precategory_morphisms (C (i + 1 - 1))) (maponpaths C (hzrminusplus (i + 1) 1)) (Diff C (i + 1 - 1))) (CohomologyComplex_KernelIn_eq A C (i + 1))) in pr1 (pr1 (CokernelKernelMorphism C i)) · CokernelArrow CK = ZeroArrow (to_Zero A) _ _. Proof. intros CK. cbn. assert (e0 : isEpi (transportf (λ i0 : pr1 hz, A ⟦C i0, Cokernel (Diff C (i - 1))⟧) (hzrminusplus i 1) (CokernelArrow (Cokernel (Diff C (i - 1)))))). { set (tmp' := transport_source_isEpi A (CokernelArrow (Cokernel (Diff C (i - 1)))) (CokernelArrowisEpi _ _) (maponpaths C (hzrminusplus i 1))). rewrite <- functtransportf in tmp'. apply tmp'. } use e0. rewrite assoc. clear e0. rewrite ZeroArrow_comp_right. set (tmp := dirprod_pr1 (pr2 (pr1 (CokernelKernelMorphism C i)))). cbn in tmp. rewrite <- tmp. clear tmp. set (tmp := CokernelCompZero _ CK). use transport_source_path. - exact (C (i + 1 - 1)). - exact (! maponpaths C (hzrplusminus i 1)). - rewrite transport_source_ZeroArrow. cbn in tmp. rewrite <- tmp. clear tmp. rewrite transport_source_precompose. apply cancel_postcomposition. clear CK. rewrite transport_source_KernelIn. use KernelInsEq. rewrite KernelCommutes. rewrite KernelCommutes. apply pathsinv0. rewrite <- maponpathsinv0. use (pathscomp0 _ (transport_hz_section A C 1 (Diff C) _ _ (hzrplusminus i 1))). use transportf_paths. apply maponpaths. apply isasethz. Qed. Definition CokernelKernelCohomology2_Mor1 (C : Complex (AbelianToAdditive A)) (i : hz) : A⟦(Cokernel (pr1 (pr1 (CokernelKernelMorphism C i)))), ((((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) (i + 1)))⟧. Proof. use CokernelOut. - use CokernelArrow. - exact (CokernelKernelCohomology2_comm1 C i). Defined. Local Lemma CokernelKernelCohomology2_comm2 (C : Complex (AbelianToAdditive A)) (i : hz) : (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C (i + 1 - 1)) (transportf (precategory_morphisms (C (i + 1 - 1))) (maponpaths C (hzrminusplus (i + 1) 1)) (Diff C (i + 1 - 1))) (CohomologyComplex_KernelIn_eq A C (i + 1))) · (CokernelArrow (Cokernel (pr1 (pr1 (CokernelKernelMorphism C i))))) = ZeroArrow (to_Zero A) _ _. Proof. set (tmp := dirprod_pr1 (pr2 (pr1 (CokernelKernelMorphism C i)))). assert (e0 : KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C (i + 1 - 1)) (transportf (precategory_morphisms (C (i + 1 - 1))) (maponpaths C (hzrminusplus (i + 1) 1)) (Diff C (i + 1 - 1))) (CohomologyComplex_KernelIn_eq A C (i + 1)) = transportf (λ x' : ob A, precategory_morphisms x' _) (! maponpaths C (hzrplusminus i 1)) (KernelIn (to_Zero A) (Kernel (Diff C (i + 1))) (C i) (Diff C i) (DSq (AbelianToAdditive A) C i))). { rewrite transport_source_KernelIn. use KernelInsEq. rewrite KernelCommutes. rewrite KernelCommutes. clear tmp. rewrite <- maponpathsinv0. use (pathscomp0 _ (transport_hz_section A C 1 (Diff C) _ _ (hzrplusminus i 1))). use transportf_paths. apply maponpaths. apply isasethz. } cbn in e0. cbn. rewrite e0. clear e0. rewrite tmp. clear tmp. cbn. rewrite transport_source_precompose. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Definition CokernelKernelCohomology2_Mor2 (C : Complex (AbelianToAdditive A)) (i : hz) : A⟦((((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) (i + 1))), (Cokernel (pr1 (pr1 (CokernelKernelMorphism C i))))⟧. Proof. use CokernelOut. - use CokernelArrow. - exact (CokernelKernelCohomology2_comm2 C i). Defined. Local Lemma CokernelKernelCohomology2_inverses (C : Complex (AbelianToAdditive A)) (i : hz) : is_inverse_in_precat (CokernelKernelCohomology2_Mor1 C i) (CokernelKernelCohomology2_Mor2 C i). Proof. split. - unfold CokernelKernelCohomology2_Mor1. use CokernelOutsEq. rewrite assoc. rewrite CokernelCommutes. unfold CokernelKernelCohomology2_Mor2. cbn. rewrite CokernelCommutes. rewrite id_right. apply idpath. - unfold CokernelKernelCohomology2_Mor2. use CokernelOutsEq. rewrite assoc. cbn. rewrite CokernelCommutes. unfold CokernelKernelCohomology2_Mor1. cbn. rewrite CokernelCommutes. rewrite id_right. apply idpath. Qed. Definition CokernelKernelCohomology2 (C : Complex (AbelianToAdditive A)) (i : hz) : iso (Cokernel (pr1 (pr1 (CokernelKernelMorphism C i)))) ((((CohomologyFunctor A C) : Complex (AbelianToAdditive A)) (i + 1))). Proof. use make_iso. - exact (CokernelKernelCohomology2_Mor1 C i). - use is_iso_qinv. + exact (CokernelKernelCohomology2_Mor2 C i). + exact (CokernelKernelCohomology2_inverses C i). Defined. End def_kernel_cokernel_complex. Local Transparent hz isdecrelhzeq hzplus iscommringops. Close Scope hz_scope. UniMath-20231010/UniMath/HomologicalAlgebra/Complexes.v000066400000000000000000002514101451125700300225200ustar00rootroot00000000000000(** * The category of complexes over an additive category *) (** ** Contents - Definition of complexes [def_complexes] - Complexes and morphisms between complexes - Direct sum of complexes - Construction of some complexes from objects - The precategory of complexes over an additive precategory [complexes_precategory] - The precategory of complexes over an additive precategory is an additive category, [complexes_additive] - Precategory of complexes over an abelian category is abelian [complexes_abelian] - Useful transports for complexes *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Unset Kernel Term Sharing. Local Open Scope hz_scope. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow. (** * Definition of complexes *) (** ** Introduction A complex consists of an objects C_i, for every integer i, and a morphism C_i --> C_{i+1} for every i, such that composition of two such morphisms is the zero morphism. One visualizes complexes as ... --> C_{i-1} --> C_i --> C_{i+1} --> ... A morphism of complexes from a complex C to a complex D is a collection of morphisms C_i --> D_i for every integer i, such that for every i the following diagram is commutative C_i --> C_{i+1} | | D_i --> D_{i+1} Composition of morphisms is defined as pointwise composition. It is easy to check that this forms a morphisms of complexes. Identity morphism is indexwise identity. A direct sum of complexes is given by taking pointwise direct sum of the underlying objects. The morphisms between the objects in direct sum complex is given by the following formula Pr1 · (C_i --> C_{i+1]) · In1 + Pr2 · (D_i --> D_{i+1}) · In2 To show that this defines a direct sum in the category of complexes is straightforward. The zero complex is given by zero objects and zero morphisms. *) Section def_complexes. (** ** Basics of complexes *) Variable A : CategoryWithAdditiveStructure. (** Complex *) Definition Complex : UU := ∑ D' : (∑ D : (∏ i : hz, ob A), (∏ i : hz, A⟦D i, D (i + 1)⟧)), ∏ i : hz, (pr2 D' i) · (pr2 D' (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Definition make_Complex (D : ∏ i : hz, ob A) (D' : ∏ i : hz, A⟦D i, D (i + 1)⟧) (D'' : ∏ i : hz, (D' i) · (D' (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _) : Complex := ((D,,D'),,D''). (** Accessor functions *) Definition Complex_Funclass (C : Complex) : hz -> ob A := pr1 (pr1 C). Coercion Complex_Funclass : Complex >-> Funclass. Definition Diff (C : Complex) (i : hz) : A⟦C i, C (i + 1)⟧ := pr2 (pr1 C) i. Definition DSq (C : Complex) (i : hz) : (Diff C i) · (Diff C (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _ := pr2 C i. Lemma ComplexEq' (C1 C2 : Complex) (H : ∏ (i : hz), C1 i = C2 i) (H1 : ∏ (i : hz), transportf (λ x : A, C2 i --> x) (H (i + 1)) (transportf (λ x : A, x --> C1 (i + 1)) (H i) (Diff C1 i)) = Diff C2 i) : transportf (λ x : hz → A, ∏ i : hz, A ⟦ x i, x (i + 1) ⟧) (funextfun C1 C2 (λ i : hz, H i)) (Diff C1) = Diff C2. Proof. use funextsec. intros i. assert (e : transportf (λ x : hz → A, ∏ i0 : hz, A ⟦ x i0, x (i0 + 1) ⟧) (funextfun C1 C2 (λ i0 : hz, H i0)) (Diff C1) i = transportf (λ x : hz → A, A ⟦ x i, x (i + 1) ⟧) (funextfun C1 C2 (λ i0 : hz, H i0)) (Diff C1 i)). { induction (funextfun C1 C2 (λ i0 : hz, H i0)). apply idpath. } rewrite e. clear e. rewrite transport_mor_funextfun. rewrite transport_source_funextfun. rewrite transport_target_funextfun. exact (H1 i). Qed. Lemma ComplexEq'' (C1 C2 : Complex) (H : ∏ (i : hz), C1 i = C2 i) (H1 : ∏ (i : hz), transportf (λ x : A, C2 i --> x) (H (i + 1)) (transportf (λ x : A, x --> C1 (i + 1)) (H i) (Diff C1 i)) = Diff C2 i) : transportf (λ x : ∑ D : hz → A, ∏ i : hz, A ⟦ D i, D (i + 1) ⟧, ∏ i : hz, pr2 x i · pr2 x (i + 1) = ZeroArrow (Additive.to_Zero A) _ _) (total2_paths_f (funextfun C1 C2 (λ i : hz, H i)) (ComplexEq' C1 C2 H H1)) (DSq C1) = DSq C2. Proof. apply proofirrelevance. apply impred_isaprop. intros t. apply to_has_homsets. Qed. Lemma ComplexEq (C1 C2 : Complex) (H : ∏ (i : hz), C1 i = C2 i) (H1 : ∏ (i : hz), transportf (λ x : A, C2 i --> x) (H (i + 1)) (transportf (λ x : A, x --> C1 (i + 1)) (H i) (Diff C1 i)) = Diff C2 i) : C1 = C2. Proof. use total2_paths_f. - use total2_paths_f. + use funextfun. intros i. exact (H i). + exact (ComplexEq' C1 C2 H H1). - exact (ComplexEq'' C1 C2 H H1). Defined. (** Zero Complex *) Definition ZeroComplex : Complex. Proof. use make_Complex. - intros i. exact (Additive.to_Zero A). - intros i. exact (ZeroArrow (Additive.to_Zero A) _ _). - intros i. apply ZeroArrowEq. Defined. (** Direct sum of two complexes *) Local Lemma DirectSumComplex_comm {C1 C2 : Complex} (i : hz) : let B1 := to_BinDirectSums A (C1 i) (C2 i) in let B2 := to_BinDirectSums A (C1 (i + 1)) (C2 (i + 1)) in let B3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1 + 1)) in (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) B1 B2) · (BinDirectSumIndAr (Diff C1 (i + 1)) (Diff C2 (i + 1)) B2 B3) = ZeroArrow (Additive.to_Zero A) B1 B3. Proof. intros. rewrite BinDirectSumIndArComp. unfold BinDirectSumIndAr. rewrite (DSq C1 i). rewrite ZeroArrow_comp_right. rewrite (DSq C2 i). rewrite ZeroArrow_comp_right. apply pathsinv0. use ToBinDirectSumUnique. - apply ZeroArrow_comp_left. - apply ZeroArrow_comp_left. Qed. Definition DirectSumComplex (C1 C2 : Complex) : Complex. Proof. use make_Complex. - intros i. exact (to_BinDirectSums A (C1 i) (C2 i)). - intros i. exact (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) _ _). - intros i. exact (DirectSumComplex_comm i). Defined. (** Morphism of complexes *) Definition Morphism (C1 C2 : Complex) : UU := ∑ D : (∏ i : hz, A⟦C1 i, C2 i⟧), ∏ i : hz, (D i) · (Diff C2 i) = (Diff C1 i) · (D (i + 1)). Definition make_Morphism (C1 C2 : Complex) (Mors : ∏ i : hz, A⟦C1 i, C2 i⟧) (Comm : ∏ i : hz, (Mors i) · (Diff C2 i) = (Diff C1 i) · (Mors (i + 1))) : Morphism C1 C2 := tpair _ Mors Comm. (** Accessor functions *) Definition MMor {C1 C2 : Complex} (M : Morphism C1 C2) (i : hz) : A⟦C1 i, C2 i⟧ := pr1 M i. Coercion MMor : Morphism >-> Funclass. Definition MComm {C1 C2 : Complex} (M : Morphism C1 C2) (i : hz) : (M i) · (Diff C2 i) = (Diff C1 i) · (M (i + 1)) := pr2 M i. (** A lemma to show that two morphisms are the same *) Lemma MorphismEq {C1 C2 : Complex} (M1 M2 : Morphism C1 C2) (H : ∏ i : hz, M1 i = M2 i) : M1 = M2. Proof. use total2_paths_f. - use funextsec. intros i. exact (H i). - use proofirrelevance. apply impred_isaprop. intros t. apply to_has_homsets. Qed. (** Inverse to [MorphismEq] *) Lemma MorphismEq' {C1 C2 : Complex} (M1 M2 : Morphism C1 C2) (H : M1 = M2) : ∏ i : hz, M1 i = M2 i. Proof. induction H. intros i. apply idpath. Qed. (** The collection of morphism between two complexes is a set *) Lemma Morphisms_isaset (C1 C2 : Complex) : isaset (Morphism C1 C2). Proof. apply isaset_total2. - apply impred_isaset. intros t. apply to_has_homsets. - intros x. apply impred_isaset. intros t. apply isasetaprop. apply to_has_homsets. Qed. Definition Morphisms_hSet (C1 C2 : Complex) : hSet := make_hSet _ (Morphisms_isaset C1 C2). (** Identity Morphism *) Local Lemma IdMorComm (C1 : Complex) (i : hz) : (identity (C1 i)) · (Diff C1 i) = (Diff C1 i) · (identity (C1 (i + 1))). Proof. rewrite id_left. rewrite id_right. apply idpath. Qed. Definition IdMor (C1 : Complex) : Morphism C1 C1. Proof. use make_Morphism. - intros i. exact (identity _). - intros i. exact (IdMorComm C1 i). Defined. (** Morphisms from and to Zero complex *) Local Lemma MorphismFromZero_comm (C : Complex) (i : hz) : (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (C i)) · (Diff C i) = (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (Additive.to_Zero A)) · (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (C (i + 1))). Proof. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. Qed. Definition MorphismFromZero (C : Complex) : Morphism ZeroComplex C. Proof. use make_Morphism. - intros i. exact (ZeroArrow (Additive.to_Zero A) _ _). - intros i. exact (MorphismFromZero_comm C i). Defined. Local Lemma MorphismToZero_comm (C : Complex) (i : hz) : (ZeroArrow (Additive.to_Zero A) (C i) (Additive.to_Zero A)) · (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (Additive.to_Zero A)) = (Diff C i) · ZeroArrow (Additive.to_Zero A) (C (i + 1)) (Additive.to_Zero A). Proof. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition MorphismToZero (C : Complex) : Morphism C ZeroComplex. Proof. use make_Morphism. - intros i. exact (ZeroArrow (Additive.to_Zero A) _ _). - intros i. exact (MorphismToZero_comm C i). Defined. (** Composition of morphisms *) Local Lemma MorphismCompComm {C1 C2 C3 : Complex} (M1 : Morphism C1 C2) (M2 : Morphism C2 C3) (i : hz) : (M1 i) · (M2 i) · (Diff C3 i) = (Diff C1 i) · (M1 (i + 1) · M2 (i + 1)). Proof. rewrite assoc. rewrite <- (MComm M1). rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (MComm M2 i). Qed. Definition MorphismComp {C1 C2 C3 : Complex} (M1 : Morphism C1 C2) (M2 : Morphism C2 C3) : Morphism C1 C3. Proof. use make_Morphism. - intros i. exact ((M1 i) · (M2 i)). - intros i. exact (MorphismCompComm M1 M2 i). Defined. (** ZeroMorphism as the composite of to zero and from zero *) Local Lemma ZeroMorphism_comm (C1 C2 : Complex) (i : hz) : ZeroArrow (Additive.to_Zero A) (C1 i) (C2 i) · Diff C2 i = Diff C1 i · ZeroArrow (Additive.to_Zero A) (C1 (i + 1)) (C2 (i + 1)). Proof. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition ZeroMorphism (C1 C2 : Complex) : Morphism C1 C2. Proof. use make_Morphism. - intros i. exact (ZeroArrow (Additive.to_Zero A) _ _). - intros i. exact (ZeroMorphism_comm C1 C2 i). Defined. Lemma ZeroMorphism_eq (C1 C2 : Complex) : ZeroMorphism C1 C2 = MorphismComp (MorphismToZero C1) (MorphismFromZero C2). Proof. use MorphismEq. intros i. apply pathsinv0. apply ZeroArrowEq. Qed. (** ** Direct sums *) (** Inclusions and projections from the DirectSumComplex *) Local Lemma DirectSumComplexIn1_comm (C1 C2 : Complex) (i : hz) : let B1 := to_BinDirectSums A (C1 i) (C2 i) in let B2 := to_BinDirectSums A (C1 (i + 1)) (C2 (i + 1)) in (to_In1 B1) · (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) B1 B2) = (Diff C1 i) · (to_In1 B2). Proof. intros. rewrite BinDirectSumIndArEq1. unfold BinDirectSumIndArFormula. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 B1). rewrite (to_Unel1 B1). rewrite id_left. rewrite to_postmor_unel'. rewrite to_postmor_unel'. rewrite to_runax'. apply idpath. Qed. Definition DirectSumComplexIn1 (C1 C2 : Complex) : Morphism C1 (DirectSumComplex C1 C2). Proof. use make_Morphism. - intros i. exact (to_In1 (to_BinDirectSums A (C1 i) (C2 i))). - intros i. exact (DirectSumComplexIn1_comm C1 C2 i). Defined. Local Lemma DirectSumComplexIn2_comm (C1 C2 : Complex) (i : hz) : let B1 := to_BinDirectSums A (C1 i) (C2 i) in let B2 := to_BinDirectSums A (C1 (i + 1)) (C2 (i + 1)) in (to_In2 B1) · (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) B1 B2) = (Diff C2 i) · (to_In2 B2). Proof. intros. rewrite BinDirectSumIndArEq1. unfold BinDirectSumIndArFormula. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 B1). rewrite (to_Unel2 B1). rewrite id_left. rewrite to_postmor_unel'. rewrite to_postmor_unel'. rewrite to_lunax'. apply idpath. Qed. Definition DirectSumComplexIn2 (C1 C2 : Complex) : Morphism C2 (DirectSumComplex C1 C2). Proof. use make_Morphism. - intros i. exact (to_In2 (to_BinDirectSums A (C1 i) (C2 i))). - intros i. exact (DirectSumComplexIn2_comm C1 C2 i). Defined. Local Lemma DirectSumComplexPr1_comm (C1 C2 : Complex) (i : hz) : let B1 := to_BinDirectSums A (C1 i) (C2 i) in let B2 := to_BinDirectSums A (C1 (i + 1)) (C2 (i + 1)) in (to_Pr1 B1) · (Diff C1 i) = (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) B1 B2) · (to_Pr1 B2). Proof. intros. rewrite BinDirectSumIndArEq1. unfold BinDirectSumIndArFormula. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 B2). rewrite (to_Unel2 B2). rewrite id_right. rewrite to_premor_unel'. rewrite to_premor_unel'. rewrite to_runax'. apply idpath. Qed. Definition DirectSumComplexPr1 (C1 C2 : Complex) : Morphism (DirectSumComplex C1 C2) C1. Proof. use make_Morphism. - intros i. exact (to_Pr1 (to_BinDirectSums A (C1 i) (C2 i))). - intros i. exact (DirectSumComplexPr1_comm C1 C2 i). Defined. Local Lemma DirectSumComplexPr2_comm (C1 C2 : Complex) (i : hz) : let B1 := to_BinDirectSums A (C1 i) (C2 i) in let B2 := to_BinDirectSums A (C1 (i + 1)) (C2 (i + 1)) in (to_Pr2 B1) · (Diff C2 i) = (BinDirectSumIndAr (Diff C1 i) (Diff C2 i) B1 B2) · (to_Pr2 B2). Proof. intros. rewrite BinDirectSumIndArEq1. unfold BinDirectSumIndArFormula. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn2 B2). rewrite (to_Unel1 B2). rewrite id_right. rewrite to_premor_unel'. rewrite to_premor_unel'. rewrite to_lunax'. apply idpath. Qed. Definition DirectSumComplexPr2 (C1 C2 : Complex) : Morphism (DirectSumComplex C1 C2) C2. Proof. use make_Morphism. - intros i. exact (to_Pr2 (to_BinDirectSums A (C1 i) (C2 i))). - intros i. exact (DirectSumComplexPr2_comm C1 C2 i). Defined. (** The equations for composing in1, in2, pr1, and pr2. *) Lemma DirectSumIdIn1 (C1 C2 : Complex) : IdMor C1 = MorphismComp (DirectSumComplexIn1 C1 C2) (DirectSumComplexPr1 C1 C2). Proof. use MorphismEq. intros i. cbn. set (B := to_BinDirectSums A (C1 i) (C2 i)). rewrite (to_IdIn1 B). apply idpath. Qed. Lemma DirectSumIdIn2 (C1 C2 : Complex) : IdMor C2 = MorphismComp (DirectSumComplexIn2 C1 C2) (DirectSumComplexPr2 C1 C2). Proof. use MorphismEq. intros i. cbn. set (B := to_BinDirectSums A (C1 i) (C2 i)). rewrite (to_IdIn2 B). apply idpath. Qed. Lemma DirectSumUnit1 (C1 C2 : Complex) : MorphismComp (DirectSumComplexIn1 C1 C2) (DirectSumComplexPr2 C1 C2) = ZeroMorphism C1 C2. Proof. use MorphismEq. intros i. cbn. set (B := to_BinDirectSums A (C1 i) (C2 i)). rewrite (to_Unel1 B). apply PreAdditive_unel_zero. Qed. Lemma DirectSumUnit2 (C1 C2 : Complex) : MorphismComp (DirectSumComplexIn2 C1 C2) (DirectSumComplexPr1 C1 C2) = ZeroMorphism C2 C1. Proof. use MorphismEq. intros i. cbn. set (B := to_BinDirectSums A (C1 i) (C2 i)). rewrite (to_Unel2 B). apply PreAdditive_unel_zero. Qed. (** Additition of morphisms is pointwise addition *) Local Lemma MorphismOpComm {C1 C2 : Complex} (M1 M2 : Morphism C1 C2) (i : hz) : (to_binop (C1 i) (C2 i) (M1 i) (M2 i)) · (Diff C2 i) = (Diff C1 i) · (to_binop (C1 (i + 1)) (C2 (i + 1)) (M1 (i + 1)) (M2 (i + 1))). Proof. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite (MComm M1 i). rewrite (MComm M2 i). apply idpath. Qed. Definition MorphismOp {C1 C2 : Complex} (M1 M2 : Morphism C1 C2) : Morphism C1 C2. Proof. use make_Morphism. - intros i. exact (to_binop _ _ (M1 i) (M2 i)). - intros i. exact (MorphismOpComm M1 M2 i). Defined. Lemma MorphismOp_isassoc (C1 C2 : Complex) : @isassoc (Morphisms_hSet C1 C2) MorphismOp. Proof. intros M1 M2 M3. use MorphismEq. intros i. cbn. apply (assocax (to_abgr (C1 i) (C2 i))). Qed. Lemma MorphismOp_isunit (C1 C2 : Complex) : @isunit (Morphisms_hSet C1 C2) MorphismOp (ZeroMorphism C1 C2). Proof. split. - intros M. use MorphismEq. intros i. cbn. rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. apply idpath. - intros M. use MorphismEq. intros i. cbn. rewrite <- PreAdditive_unel_zero. rewrite to_runax'. apply idpath. Qed. Local Lemma MorphismOp_inv_comm {C1 C2 : Complex} (M : Morphism C1 C2) (i : hz) : (to_inv (M i)) · (Diff C2 i) = (Diff C1 i) · (to_inv (M (i + 1))). Proof. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply PreAdditive_cancel_inv. rewrite inv_inv_eq. rewrite inv_inv_eq. exact (MComm M i). Qed. Definition MorphismOp_inv {C1 C2 : Complex} (M : Morphism C1 C2) : Morphism C1 C2. Proof. use make_Morphism. - intros i. exact (to_inv (M i)). - intros i. exact (MorphismOp_inv_comm M i). Defined. Lemma MorphismOp_isinv (C1 C2 : Complex) : @isinv (Morphisms_hSet C1 C2) MorphismOp (ZeroMorphism C1 C2) MorphismOp_inv. Proof. split. - intros H. use MorphismEq. intros i. cbn. rewrite (linvax A (MMor H i)). apply PreAdditive_unel_zero. - intros H. use MorphismEq. intros i. cbn. rewrite (rinvax A (MMor H i)). apply PreAdditive_unel_zero. Qed. Definition MorphismOp_iscomm (C1 C2 : Complex) : @iscomm (Morphisms_hSet C1 C2) MorphismOp. Proof. intros M1 M2. use MorphismEq. intros i. cbn. apply (commax (to_abgr (C1 i) (C2 i)) (MMor M1 i) (MMor M2 i)). Qed. Definition MorphismOp_isabgrop (C1 C2 : Complex) : @isabgrop (Morphisms_hSet C1 C2) MorphismOp. Proof. split. - use make_isgrop. + split. * exact (MorphismOp_isassoc C1 C2). * use make_isunital. -- exact (ZeroMorphism C1 C2). -- exact (MorphismOp_isunit C1 C2). + use tpair. * exact MorphismOp_inv. * exact (MorphismOp_isinv C1 C2). - exact (MorphismOp_iscomm C1 C2). Defined. (** pr1 · in1 + pr2 · in2 = id *) Lemma DirectSumId (C1 C2 : Complex) : MorphismOp (MorphismComp (DirectSumComplexPr1 C1 C2) (DirectSumComplexIn1 C1 C2)) (MorphismComp (DirectSumComplexPr2 C1 C2) (DirectSumComplexIn2 C1 C2)) = IdMor (DirectSumComplex C1 C2). Proof. use MorphismEq. intros i. cbn. set (B := to_BinDirectSums A (C1 i) (C2 i)). apply (to_BinOpId B). Qed. End def_complexes. Arguments Diff [A] _ _. Arguments ZeroComplex {A}. Arguments Morphism [A] _ _. Arguments MorphismEq [A] [C1] [C2] _ _ _. Arguments MorphismFromZero [A] _. Arguments MorphismToZero [A] _. Arguments MMor [A] [C1] [C2] _ _. Arguments MComm [A] [C1] [C2] _ _. Arguments IdMor [A] _. Arguments MorphismComp [A] [C1] [C2] [C3] _ _. (** * Transport of morphisms indexed by integers *) Section transport_section'. Variable C : precategory. Lemma transport_hz_source_target (f : hz -> ob C) (n : hz) (H : ∏ (i : hz), C⟦f i, f (i + n)⟧) (i i' : hz) (e1 : i = i') : H i' = transportf (λ (x : ob C), C⟦x, f (i' + n)⟧) (maponpaths f e1) (transportf (precategory_morphisms (f i)) (maponpaths f (maponpaths_2 _ e1 _)) (H i)). Proof. induction e1. apply idpath. Qed. Lemma transport_hz_target_source (f : hz -> ob C) (n : hz) (H : ∏ (i : hz), C⟦f i, f (i + n)⟧) (i i' : hz) (e1 : i = i') : H i' = transportf (precategory_morphisms (f i')) (maponpaths f (maponpaths_2 _ e1 _)) (transportf (λ (x : ob C), C⟦x, f (i + n)⟧) (maponpaths f e1) (H i)). Proof. induction e1. apply idpath. Qed. Lemma transport_hz_section (f : hz -> ob C) (n : hz) (H : ∏ (i : hz), C⟦f i, f (i + n)⟧) (i i' : hz) (e1 : i = i') : transportf (precategory_morphisms (f i)) (maponpaths f (maponpaths_2 _ e1 _)) (H i) = transportf (λ (x : ob C), C⟦x, f (i' + n)⟧) (maponpaths f (! e1)) (H i'). Proof. induction e1. apply idpath. Qed. Lemma transport_hz_section' (f : hz -> ob C) (n : hz) (H : ∏ (i : hz), C⟦f (i + n), f i⟧) (i i' : hz) (e1 : i + n = i' + n) (e2 : i = i') : transportf (precategory_morphisms (f (i + n))) (maponpaths f e2) (H i) = transportf (λ (x : ob C), C⟦x, f i'⟧) (maponpaths f (! e1)) (H i'). Proof. induction e2. assert (e : e1 = idpath _) by apply isasethz. rewrite e. clear e. apply idpath. Qed. Lemma transport_hz_double_section (f f' : hz -> ob C) (H : ∏ (i : hz), C⟦f i, f' i⟧) (i i' : hz) (e : i = i') : transportf (precategory_morphisms (f i)) (maponpaths f' e) (H i) = transportf (λ (x : ob C), C⟦x, f' i'⟧) (maponpaths f (! e)) (H i'). Proof. induction e. apply idpath. Qed. Lemma transport_hz_double_section_source_target (f f' : hz -> ob C) (H : ∏ (i : hz), C⟦f i, f' i⟧) (i i' : hz) (e : i = i') : H i' = transportf (precategory_morphisms (f i')) (maponpaths f' e) (transportf (λ (x : ob C), C⟦x, f' i⟧) (maponpaths f e) (H i)). Proof. induction e. apply idpath. Qed. End transport_section'. Section acyclic_complexes. Variable A : CategoryWithAdditiveStructure. (** ** Construction of a complexes with one object *) (** ... -> 0 -> X -> 0 -> ... *) Definition ComplexFromObject_obs (X : ob A) (i : hz) : hz -> A. Proof. intros i0. induction (isdecrelhzeq i i0) as [e | n]. - exact X. - exact (Additive.to_Zero A). Defined. Definition ComplexFromObject_mors (X : ob A) (i : hz) : ∏ i0 : hz, A ⟦ComplexFromObject_obs X i i0, ComplexFromObject_obs X i (i0 + 1)⟧. Proof. intros i0. exact (ZeroArrow (Additive.to_Zero A) (ComplexFromObject_obs X i i0) (ComplexFromObject_obs X i (i0 + 1))). Defined. Local Lemma ComplexFromObject_comm (X : ob A) (i : hz) : ∏ i0 : hz, (ComplexFromObject_mors X i i0) · (ComplexFromObject_mors X i (i0 + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros i0. apply ZeroArrow_comp_left. Qed. Definition ComplexFromObject (X : ob A) (i : hz) : Complex A. Proof. use make_Complex. - exact (ComplexFromObject_obs X i). - exact (ComplexFromObject_mors X i). - exact (ComplexFromObject_comm X i). Defined. (** A morphism in A induces a morphisms of ComplexFromObjects *) Definition ObjectMorToComplexMor_mors {a b : ob A} (f : a --> b) (i : hz) : ∏ i0 : hz, A ⟦(ComplexFromObject a i) i0, (ComplexFromObject b i) i0⟧. Proof. intros i0. unfold ComplexFromObject. cbn. unfold ComplexFromObject_obs. cbn. unfold coprod_rect. induction (isdecrelhzeq i i0) as [e | n]. - exact f. - apply (ZeroArrow (Additive.to_Zero A)). Defined. Local Lemma ObjectMorToComplexMor_comm {a b : ob A} (f : a --> b) (i : hz) : ∏ i0 : hz, (ObjectMorToComplexMor_mors f i i0) · (Diff (ComplexFromObject b i) i0) = (Diff (ComplexFromObject a i) i0) · (ObjectMorToComplexMor_mors f i (i0 + 1)). Proof. intros i0. unfold ComplexFromObject. unfold ComplexFromObject_mors. unfold ComplexFromObject_obs. cbn. unfold ObjectMorToComplexMor_mors. cbn. unfold coprod_rect. induction (isdecrelhzeq i i0) as [e | n]. - induction (isdecrelhzeq i (i0 + 1)) as [e' | n']. + apply (fromempty (hzeqeisi e e')). + rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_right. - induction (isdecrelhzeq i (i0 + 1)) as [e' | n']. + rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. + rewrite ZeroArrow_comp_left. apply idpath. Qed. Definition ObjectMorToComplexMor {a b : ob A} (f : a --> b) (i : hz) : Morphism (ComplexFromObject a i) (ComplexFromObject b i). Proof. use make_Morphism. - exact (ObjectMorToComplexMor_mors f i). - exact (ObjectMorToComplexMor_comm f i). Defined. (** ** Construction of a complex with a given object in two adjacent positions *) (** *** Construction of the complex ... --> 0 --> X -Id-> X --> 0 --> ... *) Definition AcyclicComplexFromObject_obs (a : ob A) (i : hz) : hz -> ob A. Proof. intros i0. induction (isdecrelhzeq i i0) as [e | n]. - exact a. - induction (isdecrelhzeq (i + 1) i0) as [e' | n']. + exact a. + exact (Additive.to_Zero A). Defined. Definition AcyclicComplexFromObject_mors (a : ob A) (i : hz) : ∏ i0 : hz, A ⟦AcyclicComplexFromObject_obs a i i0, AcyclicComplexFromObject_obs a i (i0 + 1)⟧. Proof. intros i0. unfold AcyclicComplexFromObject_obs. cbn. unfold coprod_rect. induction (isdecrelhzeq i i0) as [e | n]. + induction (isdecrelhzeq i (i0 + 1)) as [e' | n']. * exact (fromempty (hzeqeisi e e')). * induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e'' | n'']. -- exact (identity a). -- exact (fromempty (hzeqnmplusr e n'')). + induction (isdecrelhzeq (i + 1) i0) as [e' | n']. * induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. -- exact (fromempty (hzeqsnmnsm e' e'')). -- induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e''' | n''']. ++ exact (fromempty (hzeqeisi e' e''')). ++ exact (ZeroArrow (Additive.to_Zero A) a (Additive.to_Zero A)). * induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. -- exact (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) a). -- induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e''' | n''']. ++ exact (fromempty (hzeqnmplusr' n e''')). ++ exact (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (Additive.to_Zero A)). Defined. Local Lemma AcyclicComplexFromObject_diff (a : ob A) (i : hz) : ∏ i0 : hz, (AcyclicComplexFromObject_mors a i i0) · (AcyclicComplexFromObject_mors a i (i0 + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros i0. unfold AcyclicComplexFromObject_obs. unfold AcyclicComplexFromObject_mors. unfold coprod_rect. induction (isdecrelhzeq i i0) as [e | n]. - induction (isdecrelhzeq i (i0 + 1)) as [e' | n']. + exact (fromempty (hzeqeisi e e')). + induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e'' | n'']. * induction (isdecrelhzeq i (i0 + 1 + 1)) as [e''' | n''']. -- exact (fromempty (hzeqsnmnsm e'' e''')). -- induction (isdecrelhzeq (i + 1) (i0 + 1 + 1)) as [e'''' | n'''']. ++ exact (fromempty (hzeqeisi e'' e'''')). ++ exact (ZeroArrow_comp_right _ _ _ _ _ _). * exact (fromempty (hzeqnmplusr e n'')). - induction (isdecrelhzeq (i + 1) i0) as [e' | n']. + induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. * exact (fromempty (hzeqsnmnsm e' e'')). * induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e''' | n''']. -- exact (fromempty (hzeqeisi e' e''')). -- induction (isdecrelhzeq i (i0 + 1 + 1)) as [e'''' | n'''']. ++ exact (ZeroArrow_comp_left _ _ _ _ _ _). ++ induction (isdecrelhzeq (i + 1) (i0 + 1 + 1)) as [e5 | n5]. ** exact (fromempty (hzeqnmplusr' n'' e5)). ** exact (ZeroArrow_comp_left _ _ _ _ _ _). + induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. * induction (isdecrelhzeq i (i0 + 1 + 1)) as [e3 | n3]. -- exact (fromempty (hzeqeisi e'' e3)). -- induction (isdecrelhzeq (i + 1) (i0 + 1 + 1)) as [e4 | n4]. ++ exact (ZeroArrow_comp_left _ _ _ _ _ _). ++ exact (fromempty (hzeqnmplusr e'' n4)). * induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e3 | n3]. -- exact (fromempty (hzeqnmplusr' n e3)). -- induction (isdecrelhzeq i (i0 + 1 + 1)) as [e4 | n4]. ++ exact (ZeroArrow_comp_left _ _ _ _ _ _). ++ induction (isdecrelhzeq (i + 1) (i0 + 1 + 1)) as [e5 | n5]. ** exact (fromempty (hzeqnmplusr' n'' e5)). ** exact (ZeroArrow_comp_left _ _ _ _ _ _). Qed. Definition AcyclicComplexFromObject (a : ob A) (i : hz) : Complex A. Proof. use make_Complex. - exact (AcyclicComplexFromObject_obs a i). - exact (AcyclicComplexFromObject_mors a i). - exact (AcyclicComplexFromObject_diff a i). Defined. (** *** Morphism from [AcyclicComplexFromObject] to a complex ... --> 0 --> X^i --> X^i --> 0 --> ... | | | | .. --> X^{i-1} --> X^i --> X^{i+1} --> X^{i+2} --> ... *) Definition FromAcyclicComplexFromObject_mors {a : ob A} {C : Complex A} {i : hz} (f : a --> (C i)) : ∏ i0 : hz, A ⟦(AcyclicComplexFromObject a i) i0, C i0⟧. Proof. intros i0. unfold AcyclicComplexFromObject. unfold AcyclicComplexFromObject_obs. unfold AcyclicComplexFromObject_mors. cbn. unfold coprod_rect. induction (isdecrelhzeq i i0) as [e | n]. + exact (transportf (precategory_morphisms a) (maponpaths C e) f). + induction (isdecrelhzeq (i + 1) i0) as [e' | n']. * exact (transportf (precategory_morphisms a) (maponpaths C e') (f · Diff C i)). * exact (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (C i0)). Defined. Local Lemma FromAcyclicComplexFromObject_comm_eq1 {a : ob A} {C : Complex A} {i : hz} (f : a --> (C i)) (i0 : hz) (e : i = i0) (e'' : (i + 1) = (i0 + 1)) : transportf (precategory_morphisms a) (maponpaths C e) f · Diff C i0 = identity a · transportf (precategory_morphisms a) (maponpaths C e'') (f · Diff C i). Proof. rewrite id_left. rewrite transport_target_postcompose. rewrite transport_compose. apply cancel_precomposition. rewrite <- maponpathsinv0. use (pathscomp0 (! (transport_hz_section A C 1 (Diff C) _ _ e))). use transportf_paths. apply maponpaths. apply isasethz. Qed. Local Lemma FromAcyclicComplexFromObject_comm_eq2 {a : ob A} {C : Complex A} {i : hz} (f : a --> (C i)) (i0 : hz) (e' : i + 1 = i0) : transportf (precategory_morphisms a) (maponpaths C e') (f · Diff C i) · Diff C i0 = (ZeroArrow (Additive.to_Zero A) a (Additive.to_Zero A)) · (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) (C (i0 + 1))). Proof. rewrite ZeroArrow_comp_left. rewrite (transport_hz_source_target A C 1 (Diff C) _ _ (e')). rewrite transport_compose'. rewrite <- transport_target_postcompose. rewrite <- assoc. rewrite DSq. rewrite ZeroArrow_comp_right. rewrite transport_target_ZeroArrow. apply idpath. Qed. Local Lemma FromAcyclicComplexFromObject_comm {a : ob A} {C : Complex A} {i : hz} (f : a --> (C i)) : ∏ i0 : hz, (FromAcyclicComplexFromObject_mors f i0) · (Diff C i0) = (Diff (AcyclicComplexFromObject a i) i0) · (FromAcyclicComplexFromObject_mors f (i0 + 1)). Proof. intros i0. unfold AcyclicComplexFromObject. unfold AcyclicComplexFromObject_obs. unfold AcyclicComplexFromObject_mors. unfold FromAcyclicComplexFromObject_mors. unfold coprod_rect. cbn. induction (isdecrelhzeq i i0) as [e | n]. + induction (isdecrelhzeq i (i0 + 1)) as [e' | n']. * exact (fromempty (hzeqeisi e e')). * induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e'' | n'']. -- exact (FromAcyclicComplexFromObject_comm_eq1 f i0 e e''). -- exact (fromempty (n'' (maponpaths (λ i' : hz, i' + 1) e))). + induction (isdecrelhzeq (i + 1) i0) as [e' | n']. * induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. -- exact (fromempty (hzeqsnmnsm e' e'')). -- induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e''' | n''']. ++ exact (fromempty (hzeqeisi e' e''')). ++ exact (FromAcyclicComplexFromObject_comm_eq2 f i0 e'). * induction (isdecrelhzeq i (i0 + 1)) as [e'' | n'']. -- rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. -- induction (isdecrelhzeq (i + 1) (i0 + 1)) as [e''' | n''']. ++ exact (fromempty (n (hzplusrcan i i0 1 e'''))). ++ rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath. Qed. Definition FromAcyclicComplexFromObject {a : ob A} {C : Complex A} {i : hz} (f : a --> (C i)) : Morphism (AcyclicComplexFromObject a i) C. Proof. use make_Morphism. - exact (FromAcyclicComplexFromObject_mors f). - exact (FromAcyclicComplexFromObject_comm f). Defined. (** *** Morphism from [AcyclicComplexFromObject] to a complex .. --> X^{i-1} --> X^i --> X^{i+1} --> X^{i+2} --> ... | | | | ... --> 0 --> X^i --> X^i --> 0 --> ... *) Definition ToAcyclicComplexFromObject_mors {a : ob A} {C : Complex A} {i : hz} (f : (C i) --> a) : ∏ i0 : hz, A ⟦C i0, (AcyclicComplexFromObject a (i - 1)) i0⟧. Proof. intros i0. unfold AcyclicComplexFromObject. unfold AcyclicComplexFromObject_obs. unfold AcyclicComplexFromObject_mors. cbn. unfold coprod_rect. induction (isdecrelhzeq (i - 1) i0) as [e | n]. - use compose. + exact (C i). + exact (transportf (λ x' : ob A, A⟦x', C i⟧) (maponpaths C e) (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))). + exact f. - induction (isdecrelhzeq (i - 1 + 1) i0) as [e' | n']. + exact (transportf (λ x' : ob A, A⟦x', a⟧) (maponpaths C (! (hzrminusplus i 1) @ e')) f). + exact (ZeroArrow (Additive.to_Zero A) (C i0) (Additive.to_Zero A)). Defined. Local Lemma ToAcyclicComplexFromObject_mors_comm_eq1 {a : ob A} {C : Complex A} {i : hz} (f : C i --> a) (i0 : hz) (e : i - 1 = i0) (e'' : i - 1 + 1 = i0 + 1) : (transportf (λ x' : A, A ⟦ x', C i ⟧) (maponpaths C e) (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1)))) · f · identity a = Diff C i0 · transportf (λ x' : A, A ⟦ x', a ⟧) (maponpaths C (! hzrminusplus i 1 @ e'')) f. Proof. rewrite id_right. rewrite <- (pathsinv0inv0 (! hzrminusplus i 1 @ e'')). rewrite maponpathsinv0. rewrite <- transport_compose. apply cancel_postcomposition. rewrite transport_source_target_comm. induction e. use transportf_paths. apply maponpaths. apply isasethz. Qed. Local Lemma ToAcyclicComplexFromObject_mors_comm_eq2 {a : ob A} {C : Complex A} {i : hz} (f : (C i) --> a) (i0 : hz) (e' : i - 1 = i0 + 1) : (ZeroArrow (Additive.to_Zero A) (C i0) (Additive.to_Zero A)) · (ZeroArrow (Additive.to_Zero A) (Additive.to_Zero A) a) = Diff C i0 · (transportf (λ x' : A, A ⟦ x', C i ⟧) (maponpaths C e') (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1)) (Diff C (i - 1))) · f). Proof. rewrite ZeroArrow_comp_left. rewrite assoc. rewrite <- (pathsinv0inv0 e'). rewrite maponpathsinv0. rewrite <- transport_compose. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ f). apply cancel_postcomposition. use (transport_target_path _ _ (! maponpaths C (hzrminusplus i 1))). rewrite <- transport_target_postcompose. rewrite transport_f_f. rewrite pathsinv0r. rewrite transport_target_ZeroArrow. use (transport_target_path _ _ (maponpaths C (maponpaths_2 _ e' _))). rewrite transport_target_ZeroArrow. rewrite transport_f_f. cbn. rewrite <- (DSq A C i0). rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. use (pathscomp0 (transport_hz_source_target A _ 1 (Diff C) _ _ e')). rewrite transport_source_target_comm. rewrite maponpathsinv0. rewrite pathsinv0inv0. apply idpath. Qed. Local Lemma ToAcyclicComplexFromObject_mors_comm {a : ob A} {C : Complex A} {i : hz} (f : (C i) --> a) : ∏ i0 : hz, (ToAcyclicComplexFromObject_mors f i0) · (Diff (AcyclicComplexFromObject a (i - 1)) i0) = (Diff C i0) · (ToAcyclicComplexFromObject_mors f (i0 + 1)). Proof. intros i0. unfold AcyclicComplexFromObject. unfold AcyclicComplexFromObject_obs. unfold AcyclicComplexFromObject_mors. cbn. unfold ToAcyclicComplexFromObject_mors. unfold coprod_rect. cbn. induction (isdecrelhzeq (i - 1) i0) as [e | n]. - induction (isdecrelhzeq (i - 1) (i0 + 1)) as [e' | n']. + exact (fromempty (hzeqeisi e e')). + induction (isdecrelhzeq (i - 1 + 1) (i0 + 1)) as [e'' | n'']. * exact (ToAcyclicComplexFromObject_mors_comm_eq1 f i0 e e''). * exact (fromempty (hzeqnmplusr e n'')). - induction (isdecrelhzeq (i - 1) (i0 + 1)) as [e' | n']. + induction (isdecrelhzeq (i - 1 + 1) (i0 + 1)) as [e'' | n'']. * induction (isdecrelhzeq (i - 1 + 1) i0) as [e''' | n''']. -- exact (fromempty (hzeqsnmnsm e''' e')). -- exact (ToAcyclicComplexFromObject_mors_comm_eq2 f i0 e'). * induction (isdecrelhzeq (i - 1 + 1) i0) as [e''' | n''']. -- exact (fromempty (hzeqsnmnsm e''' e')). -- exact (ToAcyclicComplexFromObject_mors_comm_eq2 f i0 e'). + induction (isdecrelhzeq (i - 1 + 1) i0) as [e''' | n''']. * induction (isdecrelhzeq (i - 1 + 1) (i0 + 1)) as [e'''' | n'''']. -- exact (fromempty (hzeqeisi e''' e'''')). -- rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. * induction (isdecrelhzeq (i - 1 + 1) (i0 + 1)) as [e'''' | n'''']. -- exact (fromempty (hzeqnmplusr' n e'''')). -- rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition ToAcyclicComplexFromObject {a : ob A} {C : Complex A} {i : hz} (f : (C i) --> a) : Morphism C (AcyclicComplexFromObject a (i - 1)). Proof. use make_Morphism. - exact (ToAcyclicComplexFromObject_mors f). - exact (ToAcyclicComplexFromObject_mors_comm f). Defined. (** Some equalities *) Lemma FromAcyclicComplexFromObject_Eq {a : ob A} {C : Complex A} (i0 : hz) {i : hz} (f : a --> (C i)) : FromAcyclicComplexFromObject f i0 = FromAcyclicComplexFromObject_mors f i0. Proof. apply idpath. Qed. Lemma ToAcyclicComplexFromObject_Eq {a : ob A} {C : Complex A} (i0 : hz) {i : hz} (f : (C i) --> a) : ToAcyclicComplexFromObject f i0 = ToAcyclicComplexFromObject_mors f i0. Proof. apply idpath. Qed. End acyclic_complexes. (** * The category of complexes *) (** ** Introduction We construct the category of complexes where the objects are complexes, [Complex], and morphisms are morphisms between complexes, [Morphism]. Also, we show that a monic (resp. epi) in this category is indexwise monic (resp. epi), [ComplexMonicIndexMonic] (resp. [ComplexEpiIndexEpi]). To show that a morphism of complexes is an isomorphism, it is enough to show that the morphism is indexwise isomorphism, [ComplexIsoIndexIso]. *) Section complexes_precat. Variable A : CategoryWithAdditiveStructure. (** ** Construction of the category of complexes *) Definition ComplexPreCat_ob_mor : precategory_ob_mor := tpair (λ ob : UU, ob -> ob -> UU) (Complex A) (λ C1 C2 : Complex A, Morphism C1 C2). Definition ComplexPreCat_data : precategory_data := make_precategory_data ComplexPreCat_ob_mor (λ (C : Complex A), IdMor C) (fun (C1 C2 C3 : Complex A) (M1 : Morphism C1 C2) (M2 : Morphism C2 C3) => MorphismComp M1 M2). Lemma is_precategory_ComplexPreCat_data : is_precategory ComplexPreCat_data. Proof. split. - split. + intros a b f. use MorphismEq. intros i. cbn. apply id_left. + intros a b f. use MorphismEq. intros i. cbn. apply id_right. - split. + intros a b c d f g h. use MorphismEq. intros i. cbn. apply assoc. + intros a b c d f g h. use MorphismEq. intros i. cbn. apply assoc'. Qed. (* With Defined instead of Qed just above, we get a substantial increase in compile time: HomologicalAlgebra/KA (real: 334.56) >> (real: 57.64) HomologicalAlgebra/TranslationFunctors (real: 587.48) >> (real: 106.44) HomologicalAlgebra/MappingCylinder (real: 31.59) >> (real: 13.79) HomologicalAlgebra/KAPreTriangulated (real: 295.70) >> (real: 63.97) HomologicalAlgebra/KATriangulated (real: 281.79) >> (real: 51.55) HomologicalAlgebra/CohomologyComplex (real: 138.27) >> (real: 51.45) *) Definition ComplexPreCat : precategory := tpair _ _ is_precategory_ComplexPreCat_data. Lemma has_homsets_ComplexPreCat : has_homsets ComplexPreCat. Proof. intros C1 C2. cbn. apply isaset_total2. - apply impred_isaset. intros t. apply to_has_homsets. - intros x. apply impred_isaset. intros t. apply isasetaprop. apply to_has_homsets. Qed. Definition ComplexCat : category := make_category _ has_homsets_ComplexPreCat. (** ** Monic of complexes is indexwise monic *) Local Lemma ComplexMonicIndexMonic_eq {C1 C2 : Complex A} (M : Monic ComplexCat C1 C2) (i : hz) {a : A} (g h : A ⟦a, C1 i⟧) (H : g · (MMor (MonicArrow _ M) i) = h · (MMor (MonicArrow _ M) i)) : FromAcyclicComplexFromObject_mors A g i = FromAcyclicComplexFromObject_mors A h i. Proof. use (pathscomp0 (! (FromAcyclicComplexFromObject_Eq A i g))). use (pathscomp0 _ (FromAcyclicComplexFromObject_Eq A i h)). use MorphismEq'. use (MonicisMonic ComplexCat M). cbn. use MorphismEq. intros i0. cbn. unfold FromAcyclicComplexFromObject_mors. unfold coprod_rect. unfold AcyclicComplexFromObject_obs. cbn. induction (isdecrelhzeq i i0) as [T | F]. - induction T. exact H. - induction (isdecrelhzeq (i + 1) i0) as [T' | F']. + induction T'. cbn. rewrite <- assoc. rewrite <- assoc. rewrite <- MComm. rewrite assoc. rewrite assoc. apply cancel_postcomposition. exact H. + apply idpath. Qed. Lemma ComplexMonicIndexMonic {C1 C2 : Complex A} (M : Monic ComplexCat C1 C2) : ∏ i : hz, isMonic (@MMor A C1 C2 (MonicArrow _ M) i). Proof. intros i a g h H. set (tmp := ComplexMonicIndexMonic_eq M i g h H). unfold FromAcyclicComplexFromObject_mors in tmp. cbn in tmp. unfold coprod_rect in tmp. unfold AcyclicComplexFromObject_obs in tmp. unfold paths_rect in tmp. cbn in tmp. rewrite (isdecrelhzeqi i) in tmp. exact tmp. Qed. Lemma ComplexMonicIndexMonic' {C1 C2 : Complex A} (f : Morphism C1 C2) (H : ∏ i : hz, isMonic (f i)) : isMonic (f : ComplexCat⟦_, _⟧). Proof. use make_isMonic. intros x g h X. use MorphismEq. intros i. set (tmp := MorphismEq' A _ _ X i). cbn in tmp. apply (H i) in tmp. exact tmp. Qed. (** ** Epi of complexes is indexwise epi *) Local Lemma ComplexEpiIndexEpi_eq {C1 C2 : Complex A} (E : Epi ComplexCat C1 C2) (i : hz) {a : A} (g h : A ⟦C2 i, a⟧) (H : (MMor (EpiArrow _ E) i) · g = (MMor (EpiArrow _ E) i) · h) : ToAcyclicComplexFromObject_mors A g i = ToAcyclicComplexFromObject_mors A h i. Proof. use (pathscomp0 (! (ToAcyclicComplexFromObject_Eq A i g))). use (pathscomp0 _ (ToAcyclicComplexFromObject_Eq A i h)). use MorphismEq'. use (EpiisEpi ComplexCat E). cbn. use MorphismEq. intros i0. cbn. unfold ToAcyclicComplexFromObject_mors. unfold coprod_rect. unfold AcyclicComplexFromObject_obs. cbn. induction (isdecrelhzeq (i - 1) i0) as [T | F]. - rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- (pathsinv0inv0 T). rewrite maponpathsinv0. rewrite <- transport_compose. rewrite <- transport_compose. rewrite assoc. rewrite assoc. rewrite <- transport_target_postcompose. assert (e : (transportf (precategory_morphisms (C1 i0)) (maponpaths C2 (! T)) (MMor (EpiArrow _ E) i0)) · Diff C2 (i - 1) = (Diff C1 i0) · (transportf (precategory_morphisms (C1 (i0 + 1))) (maponpaths C2 (maponpaths_2 _ (!T) _)) (MMor (EpiArrow _ E) (i0 + 1)))). { rewrite <- transport_target_postcompose. rewrite <- MComm. rewrite transport_target_postcompose. induction T. apply idpath. } cbn in e. cbn. rewrite e. clear e. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite transport_f_f. rewrite <- maponpathscomp0. use (@transport_source_path A (C1 i) (C1 (i0 + 1)) a _ _ (maponpaths C1 (maponpaths_2 _ (!T) _ @ hzrminusplus i 1))). rewrite transport_source_precompose. rewrite transport_source_precompose. rewrite transport_source_target_comm. set (tmp''' := transport_hz_double_section_source_target A _ _ (MMor (EpiArrow _ E)) _ _ (maponpaths_2 _ (! T) _ @ hzrminusplus i 1)). cbn in tmp'''. cbn. rewrite <- tmp'''. clear tmp'''. exact H. - induction (isdecrelhzeq (i - 1 + 1) i0) as [e' | n']. + rewrite <- (pathsinv0inv0 e'). rewrite <- pathscomp_inv. rewrite maponpathsinv0. rewrite <- transport_compose. rewrite <- transport_compose. use (@transport_source_path A (C1 i) (C1 i0) a _ _ (maponpaths C1 (! e' @ hzrminusplus i 1))). rewrite transport_source_precompose. rewrite transport_source_precompose. rewrite transport_source_target_comm. set (tmp''' := transport_hz_double_section_source_target A _ _ (MMor (EpiArrow _ E)) _ _ (! e' @ hzrminusplus i 1)). cbn in tmp'''. cbn. rewrite <- tmp'''. clear tmp'''. exact H. + apply idpath. Qed. Lemma ComplexEpiIndexEpi {C1 C2 : Complex A} (E : Epi ComplexCat C1 C2) : ∏ i : hz, isEpi (@MMor A C1 C2 (EpiArrow _ E) i). Proof. intros i a g h H. set (tmp := ComplexEpiIndexEpi_eq E i g h H). unfold ToAcyclicComplexFromObject_mors in tmp. cbn in tmp. unfold coprod_rect in tmp. unfold AcyclicComplexFromObject_obs in tmp. cbn in tmp. rewrite (isdecrelhzeqpii i) in tmp. rewrite (isdecrelhzeqminusplus' i) in tmp. rewrite pathsinv0l in tmp. exact tmp. Qed. Lemma ComplexEpiIndexEpi' {C1 C2 : Complex A} (f : Morphism C1 C2) (H : ∏ i : hz, isEpi (f i)) : isEpi (f : ComplexPreCat⟦_, _⟧). Proof. use make_isEpi. intros z g h X. use MorphismEq. intros i. set (tmp := MorphismEq' A _ _ X i). cbn in tmp. apply (H i) in tmp. exact tmp. Qed. (** ** An morphism in complexes is an isomorphism if it is so indexwise *) Lemma ComplexIsoIndexIso {C1 C2 : Complex A} (f : ComplexPreCat⟦C1, C2⟧) (H : ∏ (i : hz), is_iso (MMor f i)) : is_iso f. Proof. use is_iso_qinv. - use make_Morphism. + intros i. exact (iso_inv_from_is_iso _ (H i)). + intros i. cbn. use (post_comp_with_iso_is_inj _ _ _ (H (i + 1))). use (pre_comp_with_iso_is_inj _ _ _ _ (H i)). assert (e0 : MMor f i · inv_from_iso (MMor f i,, H i) = identity _). { apply (iso_inv_after_iso (make_iso _ (H i))). } rewrite assoc. rewrite assoc. rewrite e0. rewrite id_left. rewrite <- (MComm f i). apply cancel_precomposition. assert (e1 : inv_from_iso (MMor f (i + 1),, H (i + 1)) · MMor f (i + 1) = identity _). { apply (iso_after_iso_inv (make_iso _ (H (i + 1)))). } rewrite <- assoc. rewrite e1. rewrite id_right. apply idpath. - split. + use MorphismEq. intros i. cbn. apply (iso_inv_after_iso (make_iso _ (H i))). + use MorphismEq. intros i. cbn. apply (iso_after_iso_inv (make_iso _ (H i))). Qed. End complexes_precat. (** * The category of complexes over CategoryWithAdditiveStructure is CategoryWithAdditiveStructure *) (** ** Introduction We give the category of complexes over an additive category a natural structure as an additive category. Addition of morphisms is given by indexwise addition, [MorphismOp], [ZeroComplex] is a zero object, which is shown to be zero in [ComplexPreCat_isZero], and binary direct sums are given by [DirectSumComplex]. [ComplexPreCat_Additive] is the main result. *) Section complexes_additive. Variable A : CategoryWithAdditiveStructure. Definition ComplexPreCat_precategoryWithBinOps : precategoryWithBinOps. Proof. use make_precategoryWithBinOps. - exact (ComplexCat A). - intros x y. exact (MorphismOp A). Defined. Definition ComplexPreCat_categoryWithAbgrops : categoryWithAbgrops. Proof. use make_categoryWithAbgrops. - exact ComplexPreCat_precategoryWithBinOps. - intros x y. exact (MorphismOp_isabgrop A x y). Defined. Lemma ComplexPreCat_isPreAdditive : isPreAdditive ComplexPreCat_categoryWithAbgrops. Proof. split. - intros x y z f. split. + intros g h. use MorphismEq. intros i. apply to_premor_linear'. + use MorphismEq. intros i. cbn. apply ZeroArrow_comp_right. - intros x y z f. split. + intros g h. use MorphismEq. intros i. apply to_postmor_linear'. + use MorphismEq. intros i. cbn. apply ZeroArrow_comp_left. Qed. Lemma ComplexPreCat_PreAdditive : PreAdditive. Proof. use make_PreAdditive. - exact ComplexPreCat_categoryWithAbgrops. - exact ComplexPreCat_isPreAdditive. Defined. Lemma ComplexPreCat_isZero : @isZero ComplexPreCat_PreAdditive ZeroComplex. Proof. split. - intros C. use tpair. + exact (MorphismFromZero C). + cbn. intros t. use MorphismEq. intros i. cbn. apply ArrowsFromZero. - intros C. use tpair. + exact (MorphismToZero C). + cbn. intros t. use MorphismEq. intros i. cbn. apply ArrowsToZero. Defined. Opaque ComplexPreCat_isZero. Lemma ComplexPreCat_isBinDirectSum (C1 C2 : Complex A) : @isBinDirectSum ComplexPreCat_PreAdditive C1 C2 (DirectSumComplex A C1 C2) (DirectSumComplexIn1 A C1 C2) (DirectSumComplexIn2 A C1 C2) (DirectSumComplexPr1 A C1 C2) (DirectSumComplexPr2 A C1 C2). Proof. use make_isBinDirectSum. - apply (! (DirectSumIdIn1 A C1 C2)). - apply (! (DirectSumIdIn2 A C1 C2)). - cbn. rewrite (DirectSumUnit1 A C1 C2). apply idpath. - cbn. rewrite (DirectSumUnit2 A C1 C2). apply idpath. - apply (DirectSumId A C1 C2). Qed. (** The category of complexes over an additive category is additive *) Definition ComplexPreCat_Additive : CategoryWithAdditiveStructure. Proof. use make_Additive. - exact ComplexPreCat_PreAdditive. - use make_AdditiveStructure. + use make_Zero. * exact ZeroComplex. * exact ComplexPreCat_isZero. + intros C1 C2. use (make_BinDirectSum ComplexPreCat_PreAdditive). * exact (DirectSumComplex A C1 C2). * exact (DirectSumComplexIn1 A C1 C2). * exact (DirectSumComplexIn2 A C1 C2). * exact (DirectSumComplexPr1 A C1 C2). * exact (DirectSumComplexPr2 A C1 C2). * exact (ComplexPreCat_isBinDirectSum C1 C2). Defined. Local Transparent ZeroArrow. Lemma ComplexPreCat_ZeroArrow_ZeroMorphism (C1 C2 : ob ComplexPreCat_Additive) : ZeroMorphism A C1 C2 = ZeroArrow (Additive.to_Zero ComplexPreCat_Additive) _ _. Proof. use MorphismEq. - intros i. cbn. apply pathsinv0. apply ZeroArrowEq. Qed. Local Opaque ZeroArrow. End complexes_additive. (** * Complexes over Abelian is Abelian *) (** ** Introduction We show that the category of complexes, [ComplexPreCat_Additive], over an abelian category A, more precisely [AbelianToAdditive A hs], is an abelian category, [ComplexPreCat_AbelianPreCat]. Kernels and cokernels are given by taking kernels and cokernels indexwise. Since monics and epis in [ComplexPreCat_Additive] are indexwise monics and epis, by [ComplexMonicIndexMonic] and [ComplexEpiIndexEpi], we can use the fact that A is abelian to show that every monic is a kernel of some morphism in [ComplexPreCat_Additive] and every epi is a cokernel of some morphism in [ComplexPreCat_Additive]. *) Section complexes_abelian. Variable A : AbelianPreCat. Let hs : has_homsets A := homset_property A. (** ** Kernels in Complexes over Abelian *) (** *** Construction of the kernel object *) Local Lemma ComplexPreCat_Kernel_moreq {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) (i : hz) : (KernelArrow (Kernel (g i))) · (Diff Y i) · (g (i + 1)) = ZeroArrow (to_Zero A) (Kernel (g i)) (Z (i + 1)). Proof. rewrite <- assoc. cbn. set (tmp := MComm g i). cbn in tmp. rewrite <- tmp. clear tmp. rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Local Lemma ComplexPreCat_Kernel_comp {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) (i : hz) : (KernelIn (to_Zero A) (Kernel (g (i + 1))) (Kernel (g i)) ((KernelArrow (Kernel (g i))) · (Diff Y i)) (ComplexPreCat_Kernel_moreq g i)) · (KernelIn (to_Zero A) (Kernel (g (i + 1 + 1))) (Kernel (g (i + 1))) ((KernelArrow (Kernel (g (i + 1)))) · (Diff Y (i + 1))) (ComplexPreCat_Kernel_moreq g (i + 1))) = ZeroArrow (to_Zero A) (Kernel (g i)) (Kernel (g (i + 1 + 1))). Proof. apply KernelArrowisMonic. rewrite ZeroArrow_comp_left. rewrite <- assoc. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. rewrite <- assoc. set (tmp := DSq _ Y i). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition ComplexPreCat_Kernel {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) : ComplexCat (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Kernel (g i)). - intros i. cbn. use KernelIn. + exact (KernelArrow (Kernel (g i)) · Diff Y i). + exact (ComplexPreCat_Kernel_moreq g i). - intros i. exact (ComplexPreCat_Kernel_comp g i). Defined. (** *** Construction of the KernelArrow *) Definition ComplexPreCat_KernelArrow {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) : Morphism (ComplexPreCat_Kernel g) Y. Proof. use make_Morphism. - intros i. use KernelArrow. - intros i. exact (! (KernelCommutes _ _ _ _ _)). Defined. (** *** isEqualizer *) Local Lemma ComplexPreCat_Kernels_comp {X Y : Complex (AbelianToAdditive A)} (g : Morphism X Y) : let Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in MorphismComp (ComplexPreCat_KernelArrow g) g = MorphismComp (ZeroArrowTo (ComplexPreCat_Kernel g)) (@ZeroArrowFrom _ Z Y). Proof. use MorphismEq. intros i. cbn. rewrite KernelCompZero. apply pathsinv0. apply ZeroArrowEq. Qed. Local Lemma ComplexPreCat_KernelIn_comp {X Y w : Complex (AbelianToAdditive A)} (g : Morphism X Y) (h : Morphism w X) (i : hz) : let Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in MorphismComp h g = ZeroArrow Z w Y -> (h i) · (g i) = ZeroArrow (to_Zero A) (w i) (Y i). Proof. intros Z H. set (tmp := MorphismEq' _ (MorphismComp h g) (ZeroArrow Z _ _) H i). cbn in tmp. cbn. rewrite tmp. clear tmp. apply ZeroArrowEq. Qed. Definition ComplexPreCat_KernelIn {X Y w : Complex (AbelianToAdditive A)} (g : Morphism X Y) (h : Morphism w X) : let Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in MorphismComp h g = ZeroArrow Z w Y -> (ComplexCat (AbelianToAdditive A)) ⟦w, ComplexPreCat_Kernel g⟧. Proof. cbn. set (Z := @make_Zero (ComplexCat (AbelianToAdditive A)) ZeroComplex (ComplexPreCat_isZero (AbelianToAdditive A))). intros H. use make_Morphism. - intros i. cbn. use KernelIn. + exact (h i). + apply (ComplexPreCat_KernelIn_comp g h i H). - intros i. cbn. apply KernelArrowisMonic. rewrite <- assoc. rewrite <- assoc. rewrite KernelCommutes. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. apply (MComm h i). Defined. Local Lemma ComplexPreCat_Kernels_isKernel {X Y : Complex (AbelianToAdditive A)} (g : Morphism X Y) : let Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in @isKernel (ComplexCat (AbelianToAdditive A)) _ _ _ _ (ComplexPreCat_KernelArrow g) g (ComplexPreCat_Kernels_comp g). Proof. intros Z. use (make_isKernel (*(has_homsets_ComplexPreCat (AbelianToAdditive A))*)). intros w h H'. use unique_exists. - exact (ComplexPreCat_KernelIn g h H'). - cbn. use MorphismEq. intros i. use KernelCommutes. - intros y. apply has_homsets_ComplexPreCat. - intros y T. cbn beta in T. use MorphismEq. intros i. cbn. apply KernelArrowisMonic. rewrite KernelCommutes. apply (MorphismEq' _ _ _ T i). Qed. (** *** Kernels *) Definition ComplexPreCat_Kernels : Kernels (@make_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) ZeroComplex (ComplexPreCat_isZero (AbelianToAdditive A))). Proof. intros X Y f. cbn in *. use make_Kernel. (* Kernel complex *) - exact (ComplexPreCat_Kernel f). (* Kernel arrow *) - exact (ComplexPreCat_KernelArrow f). (* Composition KernelArrow · g = ZeroArrow *) - exact (ComplexPreCat_Kernels_comp f). (* isEqualizer property *) - exact (ComplexPreCat_Kernels_isKernel f). Defined. (** ** Cokernels in Complexes over Abelian *) (** *** Cokernel complex *) Local Lemma ComplexPreCat_Cokernel_comm {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) (i : hz) : (g i) · ((Diff Z i) · (CokernelArrow (Cokernel (g (i + 1))))) = ZeroArrow (to_Zero A) (Y i) (Cokernel (g (i + 1))). Proof. rewrite assoc. cbn. set (tmp := MComm g i). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Local Lemma ComplexPreCat_Cokernel_comp {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) (i : hz) : (CokernelOut (to_Zero A) (Cokernel (g i)) (Cokernel (g (i + 1))) ((Diff Z i) · (CokernelArrow (Cokernel (g (i + 1))))) (ComplexPreCat_Cokernel_comm g i)) · (CokernelOut (to_Zero A) (Cokernel (g (i + 1))) (Cokernel (g (i + 1 + 1))) ((Diff Z (i + 1)) · (CokernelArrow (Cokernel (g (i + 1 + 1))))) (ComplexPreCat_Cokernel_comm g (i + 1))) = ZeroArrow (to_Zero A) (Cokernel (g i)) (Cokernel (g (i + 1 + 1))). Proof. apply CokernelArrowisEpi. rewrite ZeroArrow_comp_right. rewrite assoc. rewrite CokernelCommutes. rewrite <- assoc. rewrite CokernelCommutes. rewrite assoc. set (tmp := DSq _ Z i). cbn in tmp. cbn. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_left. apply idpath. Qed. Definition ComplexPreCat_Cokernel {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) : ComplexCat (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Cokernel (g i)). - intros i. cbn. use CokernelOut. + exact ((Diff Z i) · (CokernelArrow (Cokernel (g (i + 1))))). + exact (ComplexPreCat_Cokernel_comm g i). - intros i. exact (ComplexPreCat_Cokernel_comp g i). Defined. (** *** CokernelArrow *) Definition ComplexPreCat_CokernelArrow {Y Z : Complex (AbelianToAdditive A)} (g : Morphism Y Z) : Morphism Z (ComplexPreCat_Cokernel g). Proof. use make_Morphism. - intros i. use CokernelArrow. - intros i. use CokernelCommutes. Defined. (** *** Cokernel *) Local Lemma ComplexPreCat_CokernelCompZero {Y Z w : Complex (AbelianToAdditive A)} (g : (ComplexCat (AbelianToAdditive A))⟦Y, Z⟧) (h : (ComplexCat (AbelianToAdditive A))⟦Z, w⟧) (i : hz) : let Z0 := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in g · h = ZeroArrow Z0 Y w -> (MMor g i) · (MMor h i) = ZeroArrow (to_Zero A) (Y i) (w i). Proof. intros Z0. cbn. intros H. set (tmp := MorphismEq' _ (g · h) _ H i). cbn in tmp. rewrite tmp. apply ZeroArrowEq. Qed. Local Lemma ComplexPreCat_Cokernels_Eq {Y Z w : Complex (AbelianToAdditive A)} (g : (ComplexCat (AbelianToAdditive A))⟦Y, Z⟧) (h : (ComplexCat (AbelianToAdditive A))⟦Z, w⟧) (H : g · h = ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) Y w) (i : hz) : (CokernelOut (to_Zero A) (Cokernel (MMor g i)) (w i) (MMor h i) (ComplexPreCat_CokernelCompZero g h i H)) · (Diff w i) = (CokernelOut (to_Zero A) (Cokernel (MMor g i)) (Cokernel (MMor g (i + 1))) ((Diff Z i) · (CokernelArrow (Cokernel (MMor g (i + 1))))) (ComplexPreCat_Cokernel_comm g i)) · (CokernelOut (to_Zero A) (Cokernel (MMor g (i + 1))) (w (i + 1)) (MMor h (i + 1)) (ComplexPreCat_CokernelCompZero g h (i + 1) H)). Proof. apply CokernelArrowisEpi. rewrite assoc. rewrite assoc. rewrite CokernelCommutes. rewrite CokernelCommutes. rewrite <- assoc. rewrite CokernelCommutes. apply (MComm h i). Qed. Local Lemma ComplexPreCat_Cokernels_Comp {Y Z : Complex (AbelianToAdditive A)} (g : (ComplexCat (AbelianToAdditive A))⟦Y, Z⟧) : let Z0 := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in MorphismComp g (ComplexPreCat_CokernelArrow g) = MorphismComp (@ZeroArrowTo _ Z0 Y) (@ZeroArrowFrom _ Z0 (ComplexPreCat_Cokernel g)). Proof. use MorphismEq. intros i. cbn. rewrite CokernelCompZero. apply pathsinv0. apply ZeroArrowEq. Qed. Local Lemma ComplexPreCat_Cokernels_isCokernel {Y Z : Complex (AbelianToAdditive A)} (g : (ComplexCat (AbelianToAdditive A))⟦Y, Z⟧) : let Z0 := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A)) in isCokernel _ g (ComplexPreCat_CokernelArrow g) (ComplexPreCat_Cokernels_Comp g). Proof. intros Z0. use make_isCokernel. intros w h H'. use unique_exists. - use make_Morphism. + intros i. cbn. use CokernelOut. * exact (MMor h i). * exact (ComplexPreCat_CokernelCompZero g h i H'). + intros i. cbn. use ComplexPreCat_Cokernels_Eq. - cbn. use MorphismEq. intros i. use CokernelCommutes. - intros y. apply has_homsets_ComplexPreCat. - intros y T. cbn beta in T. use MorphismEq. intros i. cbn. apply CokernelArrowisEpi. rewrite CokernelCommutes. set (tmp := MorphismEq' _ _ _ T i). cbn in tmp. exact tmp. Qed. Definition ComplexPreCat_Cokernels : Cokernels (Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))). Proof. intros Y Z g. cbn in *. use make_Cokernel. (* Cokernel *) - exact (ComplexPreCat_Cokernel g). (* CokernelArrow *) - exact (ComplexPreCat_CokernelArrow g). (* Composition is zero *) - exact (ComplexPreCat_Cokernels_Comp g). (* isCoequalizer *) - exact (ComplexPreCat_Cokernels_isCokernel g). Defined. (** ** Monics are kernels *) (** *** Kernel complex from Monic *) Local Lemma ComplexPreCat_Monic_Kernel_Complex_comm {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (M : Monic (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (i : hz) : (MMor (MonicArrow _ M) i) · ((Diff y i) · (CokernelArrow (Cokernel (MMor (MonicArrow _ M) (i + 1))))) = ZeroArrow (to_Zero A) _ (Cokernel (MMor (MonicArrow _ M) (i + 1))). Proof. rewrite assoc. rewrite (MComm (MonicArrow _ M)). rewrite <- assoc. rewrite CokernelCompZero. apply ZeroArrow_comp_right. Qed. Local Lemma ComplexPreCat_Monic_Kernel_Complex_comp {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (M : Monic (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (i : hz) : (CokernelOut (to_Zero A) (Cokernel (MMor (MonicArrow _ M) i)) (Cokernel (MMor (MonicArrow _ M) (i + 1))) ((Diff y i) · (CokernelArrow (Cokernel (MMor (MonicArrow _ M) (i + 1))))) (ComplexPreCat_Monic_Kernel_Complex_comm M i)) · (CokernelOut (to_Zero A) (Cokernel (MMor (MonicArrow _ M) (i + 1))) (Cokernel (MMor (MonicArrow _ M) (i + 1 + 1))) ((Diff y (i + 1)) · (CokernelArrow (Cokernel (MMor (MonicArrow _ M) (i + 1 + 1))))) (ComplexPreCat_Monic_Kernel_Complex_comm M (i + 1))) = ZeroArrow (to_Zero A) (Cokernel (MMor (MonicArrow _ M) i)) (Cokernel (MMor (MonicArrow _ M) (i + 1 + 1))). Proof. apply CokernelArrowisEpi. rewrite assoc. rewrite CokernelCommutes. rewrite <- assoc. rewrite CokernelCommutes. rewrite assoc. cbn. set (tmp := DSq _ y i). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. apply idpath. Qed. Definition ComplexPreCat_Monic_Kernel_Complex {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (M : Monic (ComplexPreCat_Additive (AbelianToAdditive A)) x y) : ComplexPreCat_Additive (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Cokernel (@MMor _ x y (MonicArrow _ M) i)). - intros i. cbn. use CokernelOut. + exact ((Diff y i) · (CokernelArrow (Cokernel (@MMor _ x y (MonicArrow _ M) (i + 1))))). + use ComplexPreCat_Monic_Kernel_Complex_comm. - intros i. cbn. exact (ComplexPreCat_Monic_Kernel_Complex_comp M i). Defined. Local Lemma KernelMorphism_eq {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (M : Monic (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) : MorphismComp (MonicArrow _ M) (ComplexPreCat_CokernelArrow ((MonicArrow _ M) : Morphism _ _)) = ZeroMorphism _ _ _. Proof. use MorphismEq. intros i. use CokernelCompZero. Qed. Local Lemma ComplexMonicKernelInComm {x y : Complex (AbelianToAdditive A)} (M : Monic (ComplexCat (AbelianToAdditive A)) x y) {w : ComplexCat (AbelianToAdditive A)} (h : (ComplexCat (AbelianToAdditive A))⟦w, y⟧) (i : hz) (Z := @Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (H : h · (ComplexPreCat_CokernelArrow (MonicArrow _ M)) = ZeroArrow Z _ _) : (MMor h i) · (CokernelArrow (Cokernel (MMor (MonicArrow _ M) i))) = ZeroArrow (to_Zero A) _ (Cokernel (MMor (MonicArrow _ M) i)). Proof. set (H' := MorphismEq' _ _ _ H i). cbn in H'. cbn. rewrite H'. apply ZeroArrowEq. Qed. Local Lemma ComplexMonicKernelIn_Complex_Comm {x y w : Complex (AbelianToAdditive A)} (M : Monic (ComplexCat (AbelianToAdditive A)) x y) (h : (ComplexCat (AbelianToAdditive A))⟦w, y⟧) (i : hz) (Z := @Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (H : h · (ComplexPreCat_CokernelArrow (MonicArrow _ M)) = ZeroArrow Z _ _) : (KernelIn (to_Zero A) (MonicToKernel (make_Monic A (MMor (MonicArrow _ M) i) ((ComplexMonicIndexMonic _ M) i))) (w i) (MMor h i) (ComplexMonicKernelInComm M h i H)) · (Diff x i) = (Diff w i) · (KernelIn (to_Zero A) (MonicToKernel (make_Monic A (MMor (MonicArrow _ M) (i + 1)) ((ComplexMonicIndexMonic _ M) (i + 1)))) (w (i + 1)) (MMor h (i + 1)) (ComplexMonicKernelInComm M h (i + 1) H)). Proof. set (isM := ComplexMonicIndexMonic _ M). set (ker := MonicToKernel (make_Monic _ _ (isM (i + 1)))). cbn in *. apply (KernelArrowisMonic _ ker). rewrite <- assoc. rewrite <- assoc. fold ker. rewrite (KernelCommutes _ ker). cbn. use (pathscomp0 _ (MComm h i)). set (tmp := MComm (MonicArrow _ M) i). cbn in tmp. rewrite <- tmp. clear tmp. rewrite assoc. apply cancel_postcomposition. apply (KernelCommutes _ (MonicToKernel (make_Monic A _ (isM i))) (w i) (MMor h i)). Qed. Definition ComplexMonicKernelIn {x y : Complex (AbelianToAdditive A)} (M : Monic (ComplexCat (AbelianToAdditive A)) x y) {w : ComplexCat (AbelianToAdditive A)} (h : (ComplexCat (AbelianToAdditive A))⟦w, y⟧) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) : h · (ComplexPreCat_CokernelArrow (MonicArrow _ M)) = ZeroArrow Z _ _ -> (ComplexCat (AbelianToAdditive A))⟦w, x⟧. Proof. intros H'. set (isM := ComplexMonicIndexMonic _ M). use make_Morphism. - intros i. exact (KernelIn (to_Zero A) (MonicToKernel (make_Monic _ _ (isM i))) _ (MMor h i) (ComplexMonicKernelInComm M h i H')). - intros i. exact (ComplexMonicKernelIn_Complex_Comm M h i H'). Defined. Local Lemma KernelMorphism_eq' {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (M : Monic (ComplexCat (AbelianToAdditive A)) x y) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))): M · (CokernelArrow (ComplexPreCat_Cokernels x y M)) = ZeroArrow Z x (ComplexPreCat_Cokernels x y M). Proof. cbn. rewrite KernelMorphism_eq. apply ComplexPreCat_ZeroArrow_ZeroMorphism. Qed. Definition ComplexPreCatAbelianMonicKernelsData_isKernel {x y : Complex (AbelianToAdditive A)} (M : Monic (ComplexCat (AbelianToAdditive A)) x y) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) : @isKernel (ComplexCat (AbelianToAdditive A)) _ _ _ _ M (ComplexPreCat_CokernelArrow (MonicArrow _ M)) (CokernelCompZero Z (ComplexPreCat_Cokernels _ _ (MonicArrow _ M))). Proof. set (isM := ComplexMonicIndexMonic _ M). use (make_isKernel). intros w h H'. use unique_exists. - apply (ComplexMonicKernelIn M h H'). - cbn. use MorphismEq. intros i. cbn. apply (KernelCommutes _ (MonicToKernel (make_Monic A _ (isM i))) _ (MMor h i)). - intros y0. apply has_homsets_ComplexPreCat. - intros y0 T. cbn in T. use MorphismEq. intros i. apply (isM i). set (tmp := MorphismEq' _ _ _ T i). cbn in tmp. cbn. rewrite tmp. apply pathsinv0. clear tmp. apply (KernelCommutes _ (MonicToKernel (make_Monic A _ (isM i))) _ (MMor h i)). Qed. (** ** Epis are Cokernels of kernels *) Local Lemma ComplexPreCat_Epi_Cokernel_Complex_comm {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (i : hz) : (KernelArrow (Kernel (MMor (EpiArrow _ E) i))) · (Diff x i) · (MMor (EpiArrow _ E) (i + 1)) = ZeroArrow (to_Zero A) (Kernel (MMor (EpiArrow _ E) i)) _. Proof. rewrite <- assoc. rewrite <- (MComm (EpiArrow _ E)). rewrite assoc. rewrite KernelCompZero. apply ZeroArrow_comp_left. Qed. Local Lemma ComplexPreCat_Epi_Cokernel_Complex_comp {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (i : hz) : (KernelIn (to_Zero A) (Kernel (MMor (EpiArrow _ E) (i + 1))) (Kernel (MMor (EpiArrow _ E) i)) ((KernelArrow (Kernel (MMor (EpiArrow _ E) i))) · (Diff x i)) (ComplexPreCat_Epi_Cokernel_Complex_comm E i)) · (KernelIn (to_Zero A) (Kernel (MMor (EpiArrow _ E) (i + 1 + 1))) (Kernel (MMor (EpiArrow _ E) (i + 1))) ((KernelArrow (Kernel (MMor (EpiArrow _ E) (i + 1)))) · (Diff x (i + 1))) (ComplexPreCat_Epi_Cokernel_Complex_comm E (i + 1))) = ZeroArrow (to_Zero A) (Kernel (MMor (EpiArrow _ E) i)) (Kernel (MMor (EpiArrow _ E) (i + 1 + 1))). Proof. apply KernelArrowisMonic. rewrite <- assoc. rewrite KernelCommutes. rewrite assoc. rewrite KernelCommutes. rewrite <- assoc. cbn. set (tmp := DSq _ x i). cbn in tmp. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply idpath. Qed. Definition ComplexPreCat_Epi_Cokernel_Complex {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexPreCat_Additive (AbelianToAdditive A)) x y) : ComplexPreCat_Additive (AbelianToAdditive A). Proof. use make_Complex. - intros i. exact (Kernel (@MMor _ x y (EpiArrow _ E) i)). - intros i. cbn. use KernelIn. + exact ((KernelArrow (Kernel (@MMor _ x y (EpiArrow _ E) i))) · (Diff x i)). + apply ComplexPreCat_Epi_Cokernel_Complex_comm. - intros i. exact (ComplexPreCat_Epi_Cokernel_Complex_comp E i). Defined. Definition CokernelMorphism_eq {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) : MorphismComp (ComplexPreCat_KernelArrow ((EpiArrow _ E) : Morphism _ _)) (EpiArrow _ E) = ZeroMorphism _ _ _. Proof. use MorphismEq. intros i. use KernelCompZero. Qed. Local Lemma ComplexPreCatCokernelOut_comp {x y w0 : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexCat (AbelianToAdditive A)) x y) (h : (ComplexCat (AbelianToAdditive A))⟦x, w0⟧) (i : hz) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (H : MorphismComp (ComplexPreCat_KernelArrow ((EpiArrow _ E) : Morphism _ _)) h = ZeroArrow Z _ _) : KernelArrow (Kernel (MMor (EpiArrow _ E) i)) · MMor h i = ZeroArrow (to_Zero A) (Kernel (MMor (EpiArrow _ E) i)) _. Proof. set (H' := MorphismEq' _ _ _ H i). cbn in H'. cbn. rewrite H'. apply ZeroArrowEq. Qed. Local Lemma ComplexPreCatCokernelOut_comm {x y w0 : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexCat (AbelianToAdditive A)) x y) (i : hz) (h : (ComplexCat (AbelianToAdditive A))⟦x, w0⟧) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (H : MorphismComp (ComplexPreCat_KernelArrow ((EpiArrow _ E) : Morphism _ _)) h = ZeroArrow Z _ _) (isE := ComplexEpiIndexEpi _ E) : (CokernelOut (to_Zero A) (EpiToCokernel (make_Epi A (MMor (EpiArrow _ E) i) (isE i))) _ (MMor h i) (ComplexPreCatCokernelOut_comp E h i H)) · (Diff w0 i) = (Diff y i) · (CokernelOut (to_Zero A) (EpiToCokernel (make_Epi A (MMor (EpiArrow _ E) (i + 1)) (isE (i + 1)))) _ (MMor h (i + 1)) (ComplexPreCatCokernelOut_comp E h (i + 1) H)). Proof. apply pathsinv0. set (coker := EpiToCokernel (make_Epi _ _ (isE i))). apply (CokernelArrowisEpi _ coker). rewrite assoc. rewrite assoc. rewrite CokernelCommutes. use (pathscomp0 _ (! (MComm h i))). cbn. set (tmp := MComm (EpiArrow _ E) i). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. apply cancel_precomposition. apply (CokernelCommutes _ (EpiToCokernel (make_Epi A _ (isE (i + 1))))). Qed. Definition ComplexPreCatCokernelOut {x y z : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexCat (AbelianToAdditive A)) x y) (h : (ComplexCat (AbelianToAdditive A))⟦x, z⟧) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) (H : MorphismComp (ComplexPreCat_KernelArrow ((EpiArrow _ E) : Morphism _ _)) h = ZeroArrow Z _ _) : (ComplexCat (AbelianToAdditive A))⟦y, z⟧. Proof. set (isE := ComplexEpiIndexEpi _ E). use make_Morphism. - intros i. exact (CokernelOut (to_Zero A) (EpiToCokernel (make_Epi _ _ (isE i))) _ (MMor h i) (ComplexPreCatCokernelOut_comp E h i H)). - intros i. exact (ComplexPreCatCokernelOut_comm E i h H). Defined. (** *** EpisCokernelsData *) Local Lemma CokernelMorphism_eq' {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexCat (AbelianToAdditive A)) x y) (Z := Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))) : KernelArrow (ComplexPreCat_Kernels x y E) · E = ZeroArrow Z (ComplexPreCat_Kernels x y E) y. Proof. cbn. rewrite CokernelMorphism_eq. apply ComplexPreCat_ZeroArrow_ZeroMorphism. Qed. Local Lemma ComplexPreCatAbelianEpiCokernelsData_isCokernel {x y : ComplexPreCat_Additive (AbelianToAdditive A)} (E : Epi (ComplexPreCat_Additive (AbelianToAdditive A)) x y) (Add := ComplexPreCat_Additive (AbelianToAdditive A)) : @isCokernel Add _ _ _ _ (KernelArrow (ComplexPreCat_Kernels _ _ E)) E (CokernelMorphism_eq' E). Proof. set (isE := ComplexEpiIndexEpi (AbelianToAdditive A) E). use make_isCokernel. intros w0 h H'. use unique_exists. - apply (ComplexPreCatCokernelOut E h H'). - cbn. use MorphismEq. intros i. cbn. apply (CokernelCommutes _ (EpiToCokernel (make_Epi A _ (isE i))) _ (MMor h i)). - intros y0. apply has_homsets_ComplexPreCat. - intros y0 T. cbn in T. use MorphismEq. intros i. apply (isE i). set (tmp := MorphismEq' _ _ _ T i). cbn in tmp. cbn. rewrite tmp. apply pathsinv0. clear tmp. apply (CokernelCommutes _ (EpiToCokernel (make_Epi A _ (isE i))) _ (MMor h i)). Qed. (** ** Complexes over Abelian is Abelian *) Definition ComplexPreCat_AbelianPreCat : AbelianPreCat. Proof. use make_Abelian. - exact (ComplexPreCat_Additive (AbelianToAdditive A)). - use make_Data1. + exact (Additive.to_Zero (ComplexPreCat_Additive (AbelianToAdditive A))). + exact (Additive.to_BinProducts (ComplexPreCat_Additive (AbelianToAdditive A ))). + exact (Additive.to_BinCoproducts (ComplexPreCat_Additive (AbelianToAdditive A))). - use make_AbelianData. + use make_Data2. * exact ComplexPreCat_Kernels. * exact ComplexPreCat_Cokernels. + use make_MonicsAreKernels. intros x y M. cbn. exact (ComplexPreCatAbelianMonicKernelsData_isKernel M). + use make_EpisAreCokernels. intros x y E. cbn. exact (ComplexPreCatAbelianEpiCokernelsData_isCokernel E). Defined. Lemma has_homsets_ComplexPreCat_AbelianPreCat : has_homsets ComplexPreCat_AbelianPreCat. Proof. apply has_homsets_ComplexPreCat. Qed. End complexes_abelian. (** * Transport binary direct sums *) Section transport_hz_toBinDirectSums. Context {A : CategoryWithAdditiveStructure}. Lemma transport_to_BinDirectSums (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : @maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e = (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i')) _ _ e) @ (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i) (f' i0)) _ _ e). Proof. induction e. apply idpath. Qed. Lemma transport_to_BinDirectSums_comm (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i')) _ _ e) @ (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i) (f' i0)) _ _ e) = (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i') (f' i0)) _ _ e) @ (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i)) _ _ e). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_In1 (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : to_In1 (to_BinDirectSums A (f i) (f' i)) = transportf (precategory_morphisms (f i)) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (transportf (λ (x : ob A), A⟦x, to_BinDirectSums A (f i') (f' i')⟧) (maponpaths f e) (to_In1 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_In1' (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : transportf (precategory_morphisms (f i)) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ (! e)) (to_In1 (to_BinDirectSums A (f i) (f' i))) = transportf (λ (x : ob A), A⟦x, to_BinDirectSums A (f i') (f' i')⟧) (maponpaths f e) (to_In1 (to_BinDirectSums A (f i') (f' i'))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_In2 (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : to_In2 (to_BinDirectSums A (f i) (f' i)) = transportf (precategory_morphisms (f' i)) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (transportf (λ (x : ob A), A⟦x, to_BinDirectSums A (f i') (f' i')⟧) (maponpaths f' e) (to_In2 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_In2' (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : transportf (precategory_morphisms (f' i)) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ (! e)) (to_In2 (to_BinDirectSums A (f i) (f' i))) = transportf (λ (x : ob A), A⟦x, to_BinDirectSums A (f i') (f' i')⟧) (maponpaths f' e) (to_In2 (to_BinDirectSums A (f i') (f' i'))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_Pr1 (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : to_Pr1 (to_BinDirectSums A (f i) (f' i)) = transportf (precategory_morphisms (to_BinDirectSums A (f i) (f' i))) (maponpaths f e) (transportf (λ (x : ob A), A⟦x, (f i')⟧) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (to_Pr1 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_Pr1' (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : transportf (precategory_morphisms (to_BinDirectSums A (f i) (f' i))) (maponpaths f (! e)) (to_Pr1 (to_BinDirectSums A (f i) (f' i))) = (transportf (λ (x : ob A), A⟦x, (f i')⟧) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (to_Pr1 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_Pr2 (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : to_Pr2 (to_BinDirectSums A (f i) (f' i)) = transportf (precategory_morphisms (to_BinDirectSums A (f i) (f' i))) (maponpaths f' e) (transportf (λ (x : ob A), A⟦x, (f' i')⟧) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (to_Pr2 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. Lemma transport_hz_to_Pr2' (f f' : hz -> ob A) {i i' : hz} (e : i' = i) : transportf (precategory_morphisms (to_BinDirectSums A (f i) (f' i))) (maponpaths f' (! e)) (to_Pr2 (to_BinDirectSums A (f i) (f' i))) = (transportf (λ (x : ob A), A⟦x, (f' i')⟧) (@maponpaths hz A (λ i0 : hz, to_BinDirectSums A (f i0) (f' i0)) _ _ e) (to_Pr2 (to_BinDirectSums A (f i') (f' i')))). Proof. induction e. apply idpath. Qed. End transport_hz_toBinDirectSums. UniMath-20231010/UniMath/HomologicalAlgebra/KA.v000066400000000000000000000570621451125700300210630ustar00rootroot00000000000000(** * K(A), the naive homotopy category of C(A) *) (** ** Contents - Definition of K(A) *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Local Open Scope cat. Unset Kernel Term Sharing. Global Opaque hz. Local Open Scope hz_scope. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow ishinh. (** * Homotopies of complexes and K(A), the naive homotopy category of A. *) (** ** Introduction We define homotopy of complexes and the naive homotopy category K(A). A homotopy χ from complex X to a complex Y is a family of morphisms χ^i : X^i --> Y^{i-1}. Note that a homotopy χ induces a morphism of complexes h : X --> Y by setting # h^i = χ^i · d^{i-1}_Y + d^i_X · χ^{i+1}. # $ h^i = χ^i · d^{i-1}_Y + d^i_X · χ^{i+1}. $ The subset of morphisms in Mor(X, Y) which are of the form h form an abelian subgroup of Mor(X, Y). Also, if f : Z_1 --> X and g : Y --> Z_2 are morphisms of complexes, then f · h and h · g have paths to morphisms induced by homotopies. These are given (f^i · χ^i) and (χ^i · g^{i-1}), respectively. These are the properties that are enough to form the quotient category of C(A) using [Quotcategory_Additive]. We call the resulting category the naive homotopy category of A, and denote it by K(A). The objects of K(A) are objects of C(A) and Mor_{K(A)}(X, Y) = Mor_{C(A)}(X, Y) / (the subgroup of null-homotopic morphisms, [ComplexHomotSubgrp]). Homotopies are defined in [ComplexHomot]. The induced morphisms of a homotopy is constructed in [ComplexHomotMorphism]. The subgroup of morphisms coming from homotopies is defined in [ComplexHomotSubgrp]. Pre- and postcomposition of morphisms coming from homotopies are morphisms coming from homotopies are proven in [ComplexHomotSubgrop_comp_right] and [ComplexHomotSubgrop_comp_left]. The naive homotopy category K(A) is constructed in [ComplexHomot_Additive]. *) Section complexes_homotopies. Variable A : CategoryWithAdditiveStructure. Definition ComplexHomot (C1 C2 : Complex A) : UU := ∏ (i : hz), A⟦C1 i, C2 (i - 1)⟧. (** This lemma shows that the squares of the morphism map, defined by the homotopy H, commute. *) Local Lemma ComplexHomotMorphism_comm {C1 C2 : Complex A} (H : ComplexHomot C1 C2) (i : hz) : to_binop (C1 i) (C2 i) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1))) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · H (i + 1))) · Diff C2 i = Diff C1 i · to_binop (C1 (i + 1)) (C2 (i + 1)) (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrminusplus (i + 1) 1)) (H (i + 1) · Diff C2 (i + 1 - 1))) (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrplusminus (i + 1) 1)) (Diff C1 (i + 1) · H (i + 1 + 1))). Proof. (* First we get rid of the ZeroArrows *) rewrite to_postmor_linear'. rewrite to_premor_linear'. assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (H i · Diff C2 (i - 1)) · Diff C2 i) = ZeroArrow (Additive.to_Zero A) _ _). { induction (hzrminusplus i 1). cbn. rewrite <- assoc. rewrite (@DSq A C2 (i - 1)). apply ZeroArrow_comp_right. } rewrite e0. clear e0. assert (e1 : (Diff C1 i · transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrplusminus (i + 1) 1)) (Diff C1 (i + 1) · H (i + 1 + 1))) = ZeroArrow (Additive.to_Zero A) _ _). { rewrite <- transport_target_postcompose. rewrite assoc. rewrite (@DSq A C1 i). rewrite ZeroArrow_comp_left. apply transport_target_ZeroArrow. } rewrite e1. clear e1. rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. rewrite to_runax'. (* Here the idea is to apply cancel_precomposition *) rewrite transport_target_postcompose. rewrite <- assoc. apply cancel_precomposition. (* Other application of cancel_precomposition *) rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. (* Follows frm transport of differentials *) apply pathsinv0. rewrite <- maponpathsinv0. use (pathscomp0 _ (transport_hz_section A C2 1 (Diff C2) _ _ (hzrplusminus i 1))). use transportf_paths. apply maponpaths. apply isasethz. Qed. (** Every homotopy H of complexes induces a morphism of complexes. The morphism is defined by taking the map C1 i --> C2 i to be the sum (H i) · (Diff C2 (i - 1)) + (Diff C1 i) · (H (i + 1)). Note that we need to use transportf because the targets are not definitionally equal. The target of the first is C2 (i - 1 + 1) and the second target is C2 (i + 1 - 1). We transport these to C2 i. *) Definition ComplexHomotMorphism {C1 C2 : Complex A} (H : ComplexHomot C1 C2) : Morphism C1 C2. Proof. use make_Morphism. - intros i. use (@to_binop A (C1 i) (C2 i)). + exact (transportf _ (maponpaths C2 (hzrminusplus i 1)) ((H i) · (Diff C2 (i - 1)))). + exact (transportf _ (maponpaths C2 (hzrplusminus i 1)) ((Diff C1 i) · (H (i + 1)))). - intros i. exact (ComplexHomotMorphism_comm H i). Defined. (** For all complexes C1 and C2, we define a subset of C1 --> C2 to consist of all the morphisms which have a path to a morphism induced by a homotopy H by [ComplexHomotMorphism]. Our goal is to show that this subset is an abelian subgroup, and thus we can form the quotient group. *) Definition ComplexHomotSubset (C1 C2 : Complex A) : @hsubtype ((ComplexPreCat_Additive A)⟦C1, C2⟧) := (fun (f : ((ComplexPreCat_Additive A)⟦C1, C2⟧)) => ∃ (H : ComplexHomot C1 C2), ComplexHomotMorphism H = f). (** This lemma shows that the subset [ComplexHomotSubset] satisfies the axioms of a subgroup. *) Lemma ComplexHomotisSubgrop (C1 C2 : Complex A) : @issubgr (@to_abgr (ComplexPreCat_Additive A) C1 C2) (ComplexHomotSubset C1 C2). Proof. use tpair. - use tpair. + intros f g. induction f as [f1 f2]. induction g as [g1 g2]. use (squash_to_prop f2). { apply propproperty. } intros f3. use (squash_to_prop g2). { apply propproperty. } intros g3. induction f3 as [f3 f4]. induction g3 as [g3 g4]. use hinhpr. cbn. use tpair. * intros i. use to_binop. -- exact (f3 i). -- exact (g3 i). * cbn. rewrite <- f4. rewrite <- g4. use MorphismEq. intros i. cbn. rewrite to_postmor_linear'. rewrite to_premor_linear'. assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (to_binop (C1 i) (C2 (i + 1 - 1)) (Diff C1 i · f3 (i + 1)) (Diff C1 i · g3 (i + 1)))) = to_binop (C1 i) (C2 i) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · f3 (i + 1))) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · g3 (i + 1)))). { induction (hzrplusminus i 1). apply idpath. } cbn in e0. rewrite e0. clear e0. assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (to_binop (C1 i) (C2 (i - 1 + 1)) (f3 i · Diff C2 (i - 1)) (g3 i · Diff C2 (i - 1)))) = to_binop (C1 i) (C2 i) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (f3 i · Diff C2 (i - 1))) (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (g3 i · Diff C2 (i - 1)))). { induction (hzrminusplus i 1). apply idpath. } cbn in e1. rewrite e1. clear e1. set (tmp := @assocax (@to_abgr A (C1 i) (C2 i))). cbn in tmp. rewrite tmp. rewrite tmp. apply maponpaths. rewrite <- tmp. rewrite <- tmp. set (tmp' := @commax (@to_abgr A (C1 i) (C2 i))). cbn in tmp'. rewrite tmp'. rewrite (tmp' _ (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · g3 (i + 1)))). apply maponpaths. apply tmp'. (* ZeroMorphisms *) + use hinhpr. use tpair. * intros i. exact (ZeroArrow (Additive.to_Zero A) _ _). * cbn. use MorphismEq. intros i. cbn. rewrite ZeroArrow_comp_left. rewrite transport_target_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite transport_target_ZeroArrow. rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. apply idpath. - intros f H. use (squash_to_prop H). { apply propproperty. } intros H'. clear H. induction H' as [homot eq]. use hinhpr. use tpair. + intros i. exact (grinv (to_abgr (C1 i) (C2 (i - 1))) (homot i)). + cbn. rewrite <- eq. use MorphismEq. intros i. cbn. set (tmp := @PreAdditive_invrcomp A _ _ _ (Diff C1 i) (homot (i + 1))). unfold to_inv in tmp. cbn in tmp. cbn. rewrite <- tmp. clear tmp. assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (grinv (to_abgr (C1 i) (C2 (i + 1 - 1))) (Diff C1 i · homot (i + 1)))) = to_inv (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · homot (i + 1)))). { unfold to_inv. cbn. induction (hzrplusminus i 1). apply idpath. } cbn in e0. rewrite e0. clear e0. assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (grinv (to_abgr (C1 i) (C2 (i - 1))) (homot i) · Diff C2 (i - 1))) = to_inv (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (homot i · Diff C2 (i - 1)))). { unfold to_inv. cbn. induction (hzrminusplus i 1). cbn. set (tmp := @PreAdditive_invlcomp A (C1 i) (C2 (i - 1)) (C2 (i - 1 + 1)) (homot i) (Diff C2 (i - 1))). apply pathsinv0. unfold to_inv in tmp. apply tmp. } cbn in e1. rewrite e1. clear e1. set (tmp' := @commax (@to_abgr A (C1 i) (C2 i))). cbn in tmp'. rewrite tmp'. clear tmp'. set (tmp := @grinvop (@to_abgr A (C1 i) (C2 i))). cbn in tmp. unfold to_inv. apply pathsinv0. apply tmp. Qed. Definition ComplexHomotSubgrp (C1 C2 : Complex A) : @subabgr (@to_abgr (ComplexPreCat_Additive A) C1 C2). Proof. use subgrconstr. - exact (ComplexHomotSubset C1 C2). - exact (ComplexHomotisSubgrop C1 C2). Defined. (** Pre- and postcomposition with morphisms in ComplexHomotSubset is in ComplexHomotSubset. *) Lemma ComplexHomotSubgrop_comp_left (C1 : Complex A) {C2 C3 : Complex A} (f : ((ComplexPreCat_Additive A)⟦C2, C3⟧)) (H : ComplexHomotSubset C2 C3 f) : ∏ (g : ((ComplexPreCat_Additive A)⟦C1, C2⟧)), ComplexHomotSubset C1 C3 (g · f). Proof. intros g. use (squash_to_prop H). { apply propproperty. } intros HH. use hinhpr. induction HH as [homot eq]. use tpair. - intros i. exact ((MMor g i) · (homot i)). - cbn. rewrite <- eq. use MorphismEq. intros i. cbn. rewrite assoc. rewrite <- (MComm g i). rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. apply idpath. Qed. Lemma ComplexHomotSubgrop_comp_right {C1 C2 : Complex A} (C3 : Complex A) (f : ((ComplexPreCat_Additive A)⟦C1, C2⟧)) (H : ComplexHomotSubset C1 C2 f) : ∏ (g : ((ComplexPreCat_Additive A)⟦C2, C3⟧)), ComplexHomotSubset C1 C3 (f · g). Proof. intros g. use (squash_to_prop H). { apply propproperty. } intros HH. use hinhpr. induction HH as [homot eq]. use tpair. - intros i. exact ((homot i) · (MMor g (i - 1))). - cbn. rewrite <- eq. use MorphismEq. intros i. cbn. rewrite <- assoc. rewrite (MComm g (i - 1)). rewrite assoc. rewrite assoc. assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C3 (hzrminusplus i 1)) (homot i · Diff C2 (i - 1) · MMor g (i - 1 + 1))) = (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1)) (homot i · Diff C2 (i - 1))) · (MMor g i)). { induction (hzrminusplus i 1). apply idpath. } cbn in e0. rewrite e0. clear e0. assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C3 (hzrplusminus i 1)) (Diff C1 i · homot (i + 1) · MMor g (i + 1 - 1))) = (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1)) (Diff C1 i · homot (i + 1))) · (MMor g i)). { induction (hzrplusminus i 1). apply idpath. } cbn in e1. rewrite e1. clear e1. rewrite <- to_postmor_linear'. apply idpath. Qed. (** ** Naive homotopy category We know that the homotopies from C1 to C2 form an abelian subgroup of the abelian group of all morphisms from C1 to C2, by [ComplexHomotSubgrp]. We also know that composition of a morphism with a morphism coming from a homotopy, is a morphism which comes from a homotopy, by [ComplexHomotSubgrop_comp_left] and [ComplexHomotSubgrop_comp_right]. This is enough to invoke our abstract construction Quotcategory_Additive, to construct the naive homotopy category. *) Local Lemma ComplexHomot_Additive_Comp : PreAdditiveComps (ComplexPreCat_Additive A) (λ C1 C2 : ComplexPreCat_Additive A, ComplexHomotSubgrp C1 C2). Proof. intros C1 C2. split. - intros C3 f H g. apply ComplexHomotSubgrop_comp_right. apply H. - intros C3 f g H. apply ComplexHomotSubgrop_comp_left. apply H. Qed. (** Here we construct K(A). *) Definition ComplexHomot_Additive : CategoryWithAdditiveStructure := Quotcategory_Additive (ComplexPreCat_Additive A) ComplexHomotSubgrp ComplexHomot_Additive_Comp. Definition ComplexHomotFunctor : AdditiveFunctor (ComplexPreCat_Additive A) ComplexHomot_Additive := QuotcategoryAdditiveFunctor (ComplexPreCat_Additive A) ComplexHomotSubgrp ComplexHomot_Additive_Comp. Arguments ComplexHomotFunctor : simpl never. Lemma ComplexHomotFunctor_issurj {C1 C2 : ComplexPreCat_Additive A} (f : ComplexHomot_Additive⟦C1, C2⟧) : ∥ hfiber (# ComplexHomotFunctor) f ∥. Proof. apply issurjsetquotpr. Qed. Lemma ComplexHomotFunctor_rel_mor {C1 C2 : ComplexPreCat_Additive A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : subgrhrel (ComplexHomotSubgrp C1 C2) f g) : # ComplexHomotFunctor f = # ComplexHomotFunctor g. Proof. apply abgrquotpr_rel_image. apply H. Qed. Lemma ComplexHomotFunctor_rel_mor' {C1 C2 : ComplexPreCat_Additive A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : ComplexHomot C1 C2) (H' : to_binop _ _ f (to_inv g) = ComplexHomotMorphism H) : # ComplexHomotFunctor f = # ComplexHomotFunctor g. Proof. apply ComplexHomotFunctor_rel_mor. use hinhpr. use tpair. - cbn. use tpair. + exact (ComplexHomotMorphism H). + use hinhpr. use tpair. * exact H. * apply idpath. - exact (! H'). Qed. Lemma ComplexHomotFunctor_mor_rel {C1 C2 : ComplexPreCat_Additive A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # ComplexHomotFunctor f = # ComplexHomotFunctor g) : subgrhrel (ComplexHomotSubgrp C1 C2) f g. Proof. use (@abgrquotpr_rel_paths _ (binopeqrel_subgr_eqrel (ComplexHomotSubgrp C1 C2))). apply H. Qed. Lemma ComplexHomotFunctor_im_to_homot {C1 C2 : ComplexPreCat_Additive A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # ComplexHomotFunctor f = # ComplexHomotFunctor g) : ∥ ∑ h : ComplexHomot C1 C2, ComplexHomotMorphism h = to_binop _ _ f (to_inv g) ∥. Proof. use (squash_to_prop (ComplexHomotFunctor_mor_rel f g H) (propproperty _)). intros h. induction h as [b hh]. cbn in b. unfold ComplexHomotSubset in b. use (squash_to_prop (pr2 b) (propproperty _)). intros hhh. induction hhh as [H1 H2]. cbn in hh. cbn in H2. use hinhpr. use tpair. - exact H1. - exact (H2 @ hh). Qed. Lemma ComplexHomotPreCompHomot {C1 C2 C3 : ComplexPreCat_Additive A} (f1 : (ComplexPreCat_Additive A)⟦C1, C2⟧) (f2 f3 : (ComplexPreCat_Additive A)⟦C2, C3⟧) (H : # ComplexHomotFunctor f2 = # ComplexHomotFunctor f3) : ∥ ∑ (h : ComplexHomot C1 C3), ComplexHomotMorphism h = to_binop _ _ (f1 · f2) (to_inv (f1 · f3)) ∥. Proof. assert (e : # ComplexHomotFunctor (f1 · f2) = # ComplexHomotFunctor (f1 · f3)). { rewrite functor_comp. rewrite H. rewrite functor_comp. apply idpath. } exact (ComplexHomotFunctor_im_to_homot (f1 · f2) (f1 · f3) e). Qed. Lemma ComplexHomotPostCompHomot {C1 C2 C3 : ComplexPreCat_Additive A} (f1 f2 : (ComplexPreCat_Additive A)⟦C1, C2⟧) (f3 : (ComplexPreCat_Additive A)⟦C2, C3⟧) (H : # ComplexHomotFunctor f1 = # ComplexHomotFunctor f2) : ∥ ∑ (h : ComplexHomot C1 C3), ComplexHomotMorphism h = to_binop _ _ (f1 · f3) (to_inv (f2 · f3)) ∥. Proof. assert (e : # ComplexHomotFunctor (f1 · f3) = # ComplexHomotFunctor (f2 · f3)). { rewrite functor_comp. rewrite H. rewrite functor_comp. apply idpath. } exact (ComplexHomotFunctor_im_to_homot (f1 · f3) (f2 · f3) e). Qed. (** Commutativity of squares *) Lemma ComplexHomotComm2 {C1 C2 C3 C4 : ob ComplexHomot_Additive} {f1 : C1 --> C2} {f2 : C2 --> C4} {g1 : C1 --> C3} {g2 : C3 --> C4} (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2) (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2) (H : f1 · f2 = g1 · g2) : # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2')) = # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2')). Proof. rewrite functor_comp. rewrite functor_comp. rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2'). rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2'). exact H. Qed. Lemma ComplexHomotComm3 {C1 C2 C3 C4 C5 C6 : ob ComplexHomot_Additive} {f1 : C1 --> C2} {f2 : C2 --> C3} {f3 : C3 --> C6} {g1 : C1 --> C4} {g2 : C4 --> C5} {g3 : C5 --> C6} (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2) (f3' : hfiber (# ComplexHomotFunctor) f3) (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2) (g3' : hfiber (# ComplexHomotFunctor) g3) (H : f1 · f2 · f3 = g1 · g2 · g3 ) : # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2') · (hfiberpr1 _ _ f3')) = # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2') · (hfiberpr1 _ _ g3')). Proof. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2'). rewrite (hfiberpr2 _ _ f3'). rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2'). rewrite (hfiberpr2 _ _ g3'). exact H. Qed. Lemma ComplexHomotComm4 {C1 C2 C3 C4 C5 C6 C7 C8 : ob ComplexHomot_Additive} {f1 : C1 --> C2} {f2 : C2 --> C3} {f3 : C3 --> C4} {f4 : C4 --> C8} {g1 : C1 --> C5} {g2 : C5 --> C6} {g3 : C6 --> C7} {g4 : C7 --> C8} (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2) (f3' : hfiber (# ComplexHomotFunctor) f3) (f4' : hfiber (# ComplexHomotFunctor) f4) (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2) (g3' : hfiber (# ComplexHomotFunctor) g3) (g4' : hfiber (# ComplexHomotFunctor) g4) (H : f1 · f2 · f3 · f4 = g1 · g2 · g3 · g4) : # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2') · (hfiberpr1 _ _ f3') · (hfiberpr1 _ _ f4')) = # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2') · (hfiberpr1 _ _ g3') · (hfiberpr1 _ _ g4')). Proof. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2'). rewrite (hfiberpr2 _ _ f3'). rewrite (hfiberpr2 _ _ f4'). rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2'). rewrite (hfiberpr2 _ _ g3'). rewrite (hfiberpr2 _ _ g4'). exact H. Qed. End complexes_homotopies. UniMath-20231010/UniMath/HomologicalAlgebra/KAPreTriangulated.v000066400000000000000000001003701451125700300240650ustar00rootroot00000000000000(** * K(A) is a pretriangulated category *) (** Contents - K(A) pretriangulated - Pretriangulated data - Trivial triangle is distinguished - Rotations of triangles - Every morphism can be completed to a distinguished triangle - Extension of triangles - Distinguished triangles are closed under isomorphism - K(A) pretriangulated *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.ShortExactSequences. Require Import UniMath.CategoryTheory.categories.abgrs. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.Triangulated. Require Import UniMath.HomologicalAlgebra.KA. Require Import UniMath.HomologicalAlgebra.TranslationFunctors. Require Import UniMath.HomologicalAlgebra.MappingCone. Unset Kernel Term Sharing. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow. (** * K(A) with a structure of a pretriangulated category *) (** ** Introduction Let f : X --> Y be a morphism in K(A). We use [squash_to_prop] to obtain a morphism f' : X --> Y which maps to f by the natural functor C(A) -> K(A). To f' we associate a cone given by C(f'), the mapping cone of f' in C(A). The translation functors give the natural equivalence T : K(A) -> K(A). A distinguished triangle in K(A) is a triangle (X,Y,Z,u,v,w) such that there exists a morphism M of K(A), and a fiber M' of M, such that we have the following isomorphism of triangles X --u--> Y --v--> Z --w--> X[1] | | | | X' -M'-> Y -in2-> C(M') -pr1-> X[1] To show that K(A) is pretriangulated, it suffices to show that - Trivial triangle is distinguished - Distinguished triangles are closed under isomorphism - Rotation of a distinguished triangle is distinguished - Inverse rotation of a distinguished triangle is distinguished - Any morphism can be completed to a distinguished triangle - Any commutative square coming from distinguished triangles can be completed to a morphism of distinguished triangles. To show that trivial triangle is distinguished, we construct the following isomorphism of triangles X --> X --> 0 --> Y[1] | | | | X --> X --> C(Id_X) --> Y[1] To prove rotation of distinguished triangles, we construct the following isomorphism of triangles Y --> C(f') --> C(i2)--> Y[1] | | | | Y --> C(f') --> X[1] --> Y[1] To prove inverse rotation of distinguished triangles, we construct the following isomorphism of triangles C(f)[-1] --> X --> Y --> C(f) | | | | C(f)[-1] --> X -->C(-p1[-1])--> C(f) Extension of triangles is given by the following morphism of triangles X -g-> Y --> C(g) --> Y[1] | | | | X' -g'-> Y' --> C(g') --> Y[1] *) Section KAPreTriangulated. Context {A : CategoryWithAdditiveStructure}. Local Opaque ComplexHomotFunctor ComplexHomotSubset Quotcategory identity MappingConePr1 MappingConeIn2 RotMorphism RotMorphismInv InvRotMorphism InvRotMorphismInv to_inv compose pathsinv0 pathscomp0 ishinh to_abgr. Definition MappingConeTri {x y : ob (ComplexHomot_Additive A)} (f : x --> y) (f' : hfiber (# (ComplexHomotFunctor A)) f) : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A). Proof. use make_Tri. - exact x. - exact y. - exact (MappingCone A (hfiberpr1 _ _ f')). - exact f. - exact (# (ComplexHomotFunctor A) (MappingConeIn2 A (hfiberpr1 _ _ f'))). - exact (# (ComplexHomotFunctor A) (MappingConePr1 A (hfiberpr1 _ _ f'))). Defined. Definition KADTriData (T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)) : UU := ∑ D : (∑ M : @Morphisms.Morphism (ComplexHomot_Additive A), hfiber (# (ComplexHomotFunctor A)) M), TriIso T (MappingConeTri (pr1 D) (pr2 D)). Definition make_KADTriData {T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)} (M : @Morphisms.Morphism (ComplexHomot_Additive A)) (M' : hfiber (# (ComplexHomotFunctor A)) M) (I : TriIso T (MappingConeTri M M')) : KADTriData T := ((M,,M'),,I). Definition KADTriDataMor {T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)} (D : KADTriData T) : @Morphisms.Morphism (ComplexHomot_Additive A) := pr1 (pr1 D). Definition KADTriDataFiber {T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)} (D : KADTriData T) : hfiber (# (ComplexHomotFunctor A)) (KADTriDataMor D) := pr2 (pr1 D). Definition KADTriDataIso {T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)} (D : KADTriData T) : TriIso T (MappingConeTri (KADTriDataMor D) (KADTriDataFiber D)) := pr2 D. Definition KAisDTri (T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)) : hProp := ∥ KADTriData T ∥. Definition KAPreTriangData : PreTriangData. Proof. use make_PreTriangData. - exact (ComplexHomot_Additive A). - exact (TranslationHEquiv A). - intros T. exact (KAisDTri T). Defined. Lemma KAFiberisDTri (M : @Morphisms.Morphism (ComplexHomot_Additive A)) (M' : hfiber (# (ComplexHomotFunctor A)) M) : @isDTri KAPreTriangData (MappingConeTri M M'). Proof. use hinhpr. use make_KADTriData. - exact M. - exact M'. - exact (TriIsoId _). Qed. Definition KADTriDataDTri {T : @Tri (ComplexHomot_Additive A) (TranslationHEquiv A)} (D : KADTriData T) : @DTri KAPreTriangData. Proof. use make_DTri'. - exact (MappingConeTri (KADTriDataMor D) (KADTriDataFiber D)). - exact (KAFiberisDTri (KADTriDataMor D) (KADTriDataFiber D)). Defined. (** Different fibers of a same morphism induce an isomorphism *) Lemma KAIdComml {x y : ob KAPreTriangData} (f g : x --> y) (e : f = g) : identity _ · f = g. Proof. rewrite id_left. exact e. Qed. Lemma KAIdCommr {x y : ob KAPreTriangData} (f g : x --> y) (e : f = g) : f · identity _ = g. Proof. rewrite id_right. exact e. Qed. Lemma KAIdComm {x y : ob KAPreTriangData} (f g : x --> y) (e : f = g) : f · identity _ = identity _ · g. Proof. rewrite id_left. rewrite id_right. exact e. Qed. Definition KAFiber {x y : ob (ComplexPreCat_Additive A)} (f : x --> y) : hfiber (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) f) := make_hfiber (# (ComplexHomotFunctor A)) f (idpath _). Definition KAFiberIsoMor {x y : KAPreTriangData} {f : x --> y} (f' f'' : hfiber (# (ComplexHomotFunctor A)) f) (f1 := hfiberpr1 _ _ f') (f2 := hfiberpr1 _ _ f'') (Ho : ComplexHomot A x y) (e : to_binop _ _ f1 (to_inv f2) = ComplexHomotMorphism A Ho) : MPMorMors (MappingConeTri f f') (MappingConeTri f f''). Proof. use make_MPMorMors. - exact (identity _). - exact (identity _). - exact (# (ComplexHomotFunctor A) (FiberExt A f1 f2 Ho e)). Defined. Lemma KAFiberIsoMorComms {x y : KAPreTriangData} {f : x --> y} (f' f'' : hfiber (# (ComplexHomotFunctor A)) f) (f1 := hfiberpr1 _ _ f') (f2 := hfiberpr1 _ _ f'') (Ho : ComplexHomot A x y) (e : to_binop _ _ f1 (to_inv f2) = ComplexHomotMorphism A Ho) : MPMorComms (KAFiberIsoMor f' f'' Ho e). Proof. use make_MPMorComms. - exact (! (KAIdComm _ _ (idpath _))). - use KAIdComml. exact (! (FiberExt_Comm2H A f1 f2 Ho e)). Qed. Lemma KAFiberIsoMorComm3 {x y : KAPreTriangData} {f : x --> y} (f' f'' : hfiber (# (ComplexHomotFunctor A)) f) (f1 := hfiberpr1 _ _ f') (f2 := hfiberpr1 _ _ f'') (Ho : ComplexHomot A x y) (e : to_binop _ _ f1 (to_inv f2) = ComplexHomotMorphism A Ho) : (MPMor3 (make_MPMor (KAFiberIsoMor f' f'' Ho e) (KAFiberIsoMorComms f' f'' Ho e))) · Mor3 (MappingConeTri f f'') = (Mor3 (MappingConeTri f f')) · (# (AddEquiv1 (@Trans KAPreTriangData)) (MPMor1 (make_MPMor (KAFiberIsoMor f' f'' Ho e) (KAFiberIsoMorComms f' f'' Ho e)))). Proof. cbn. rewrite functor_id. use (! (KAIdCommr _ _ _)). exact (FiberExt_Comm3H A f1 f2 Ho e). Qed. Definition KAFiberIso {x y : KAPreTriangData} {f : x --> y} (f' f'' : hfiber (# (ComplexHomotFunctor A)) f) (f1 := hfiberpr1 _ _ f') (f2 := hfiberpr1 _ _ f'') (Ho : ComplexHomot A x y) (e : to_binop _ _ f1 (to_inv f2) = ComplexHomotMorphism A Ho) : TriIso (MappingConeTri f f') (MappingConeTri f f''). Proof. use make_TriIso. - use make_TriMor. + use make_MPMor. * exact (KAFiberIsoMor f' f'' Ho e). * exact (KAFiberIsoMorComms f' f'' Ho e). + exact (KAFiberIsoMorComm3 f' f'' Ho e). - use make_TriMor_is_iso. + exact (is_z_isomorphism_identity _). + exact (is_z_isomorphism_identity _). + exact (FiberExt_is_z_isomorphism A f1 f2 Ho e). Defined. (** ** Trivial triangle is distinguished *) Definition KATrivialDistinguished_MPMorMors (x : ob KAPreTriangData) (i' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) _ _ (functor_id (ComplexHomotFunctor A) x)) : @MPMorMors KAPreTriangData (@TrivialTri _ (@Trans KAPreTriangData) x) (MappingConeTri (identity x) i'). Proof. use make_MPMorMors. - exact (# (ComplexHomotFunctor A) (identity _)). - exact (# (ComplexHomotFunctor A) (identity _)). - exact (ZeroArrow (to_Zero _) _ _). Defined. Local Lemma KATrivialDistinguished_MPMorsComm (x : ob (ComplexPreCat_Additive A)) : MPMorComms (KATrivialDistinguished_MPMorMors x). Proof. use make_MPMorComms. - apply idpath. - cbn. rewrite (functor_id (ComplexHomotFunctor A)). rewrite (@id_left (ComplexHomot_Additive A)). rewrite (@ZeroArrow_comp_right (ComplexHomot_Additive A)). use (pathscomp0 _ (AdditiveFunctorZeroArrow (ComplexHomotFunctor A) _ _)). exact (MappingConeIn2Eq A x). Qed. Definition KATrivialDistinguished_TriMor (x : ob KAPreTriangData) (i' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) _ _ (functor_id (ComplexHomotFunctor A) x)) : TriMor (TrivialTri x) (MappingConeTri (identity x) i'). Proof. use make_TriMor. - exact (make_MPMor (KATrivialDistinguished_MPMorMors x) (KATrivialDistinguished_MPMorsComm x)). - cbn. rewrite (@ZeroArrow_comp_left (ComplexHomot_Additive A)). rewrite (@ZeroArrow_comp_left (ComplexHomot_Additive A)). apply idpath. Defined. Lemma KATrivialDistinguished : ∏ x : KAPreTriangData, isDTri (TrivialTri x). Proof. intros x. set (i' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) _ _ (functor_id (ComplexHomotFunctor A) x)). use hinhpr. use make_KADTriData. - exact (Morphisms.make_Morphism (identity x)). - exact i'. - use make_TriIso. + exact (KATrivialDistinguished_TriMor x). + use make_TriMor_is_iso. * exact (functor_on_is_z_isomorphism (ComplexHomotFunctor A) (@is_z_isomorphism_identity (ComplexPreCat_Additive A) (x : Complex A))). * exact (functor_on_is_z_isomorphism (ComplexHomotFunctor A) (@is_z_isomorphism_identity (ComplexPreCat_Additive A) (x : Complex A))). * exact (IDMappingCone_is_z_isomorphism A x). Qed. (** ** Rotation of distinguished triangles *) Local Lemma KARotDTris_Comm2 (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : identity _ · # (ComplexHomotFunctor A) (MappingConeIn2 A (MappingConeIn2 A I')) = # (ComplexHomotFunctor A) (MappingConePr1 A I') · # (ComplexHomotFunctor A) (RotMorphism A I'). Proof. use (pathscomp0 (id_left _)). use (pathscomp0 _ ((functor_comp (ComplexHomotFunctor A) (MappingConePr1 A I') (RotMorphism A I')))). exact (! (RotMorphism_comm A I')). Qed. Local Lemma KARotDTris_Comm3 (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : # (ComplexHomotFunctor A) (RotMorphism A I') · # (ComplexHomotFunctor A) (MappingConePr1 A (MappingConeIn2 A I')) = to_inv (# (AddEquiv1 (TranslationHEquiv A)) (KADTriDataMor I)) · # (AddEquiv1 (TranslationHEquiv A)) (identity (Target (KADTriDataMor I))). Proof. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) (RotMorphism A I') (MappingConePr1 A (MappingConeIn2 A I'))))). use (pathscomp0 (! (maponpaths (# (ComplexHomotFunctor A)) (RotMorphism_comm2 A I')))). rewrite functor_id. rewrite id_right. rewrite (AdditiveFunctorInv (ComplexHomotFunctor A)). apply maponpaths. apply pathsinv0. apply TranslationFunctorHImEq. exact (hfiberpr2 _ _ (KADTriDataFiber I)). Qed. Definition KARotDTris_Iso (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : TriIso (RotTri D) (MappingConeTri (Morphisms.make_Morphism (Mor2 (MappingConeTri (KADTriDataMor I) (KADTriDataFiber I)))) (KAFiber (MappingConeIn2 A I'))). Proof. use (TriIso_comp (RotTriIso (KADTriDataIso I))). use make_TriIso. - use make_TriMor. + use make_MPMor. * use make_MPMorMors. -- exact (identity _). -- exact (identity _). -- exact (# (ComplexHomotFunctor A) (RotMorphism A I')). * use make_MPMorComms. -- exact (! (KAIdComm _ _ (idpath _))). -- exact (KARotDTris_Comm2 D I). + exact (KARotDTris_Comm3 D I). - use make_TriMor_is_iso. + exact (is_z_isomorphism_identity _). + exact (is_z_isomorphism_identity _). + exact (RotMorphism_is_z_isomorphism A _). Defined. Lemma KARotDTris : ∏ D : DTri, @isDTri KAPreTriangData (RotTri D). Proof. intros D. use (squash_to_prop (DTriisDTri D) (propproperty _)). intros I. use hinhpr. use make_KADTriData. - exact (Morphisms.make_Morphism (Mor2 (MappingConeTri (KADTriDataMor I) (KADTriDataFiber I)))). - exact (KAFiber (MappingConeIn2 A (hfiberpr1 _ _ (KADTriDataFiber I)))). - exact (KARotDTris_Iso D I). Qed. (** ** Inverse rotation of distinguished triangles *) Lemma KAInvRotDTris_Comm1 (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : (identity _) · (# (ComplexHomotFunctor A) ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) · TranslationEquivUnitInv A (Source (KADTriDataMor I)))) = (to_inv (# (AddEquiv2 (TranslationHEquiv A)) (# (ComplexHomotFunctor A) (MappingConePr1 A I')))) · # (ComplexHomotFunctor A) (TranslationEquivUnitInv A (Source (KADTriDataMor I))) · identity (Source (KADTriDataMor I)). Proof. use (! (KAIdComm _ _ _)). use (pathscomp0 _ (! (functor_comp (ComplexHomotFunctor A) (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) (inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I))))))). set (tmp''' := @AdditiveFunctorInv _ _ (ComplexHomotFunctor A) _ _ (# (InvTranslationFunctor A) (MappingConePr1 A I'))). apply (maponpaths (postcompose (# (ComplexHomotFunctor A) (inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I))))))) in tmp'''. use (pathscomp0 _ (! tmp''')). clear tmp'''. unfold postcompose. apply cancel_postcomposition. apply maponpaths. use InvTranslationFunctorHImEq. apply idpath. Qed. Lemma KAInvRotDTris_Comm2 (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : (identity (Source (KADTriDataMor I))) · (# (ComplexHomotFunctor A) (MappingConeIn2 A ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) · TranslationEquivUnitInv A (Source (KADTriDataMor I))))) = KADTriDataMor I · # (ComplexHomotFunctor A) (InvRotMorphismInv A I'). Proof. rewrite id_left. use (pathscomp0 (! (InvRotMorphismInvComm1 A I'))). use (pathscomp0 (functor_comp (ComplexHomotFunctor A) _ _)). use cancel_postcomposition. exact (hfiberpr2 _ _ (KADTriDataFiber I)). Qed. Lemma KAInvRotDTris_Comm3 (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : (# (ComplexHomotFunctor A) (InvRotMorphismInv A I')) · (# (ComplexHomotFunctor A) (MappingConePr1 A ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) · TranslationEquivUnitInv A (Source (KADTriDataMor I))))) = (# (ComplexHomotFunctor A) (MappingConeIn2 A I')) · # (ComplexHomotFunctor A) (TranslationEquivCounitInv A (MappingCone A I')) · (# (AddEquiv1 (TranslationHEquiv A)) (identity ((AddEquiv2 (TranslationHEquiv A)) (MappingCone A I')))). Proof. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). use (pathscomp0 (maponpaths # (ComplexHomotFunctor A) (! (InvRotMorphismInvComm2 A I')))). rewrite functor_id. use (pathscomp0 _ (! (id_right _))). exact (functor_comp (ComplexHomotFunctor A) _ _). Qed. Local Opaque AddEquiv1 AddEquiv2. Definition KAInvRotDTris_Iso (D : @DTri KAPreTriangData) (I : KADTriData D) (I' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I) (KADTriDataFiber I)) : TriIso (InvRotTri D) (MappingConeTri (# (ComplexHomotFunctor A) ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I))))) (KAFiber ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A I'))) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I)))))). Proof. use (TriIso_comp (InvRotTriIso (KADTriDataIso I))). use make_TriIso. - use make_TriMor. + use make_MPMor. * use make_MPMorMors. -- exact (identity _). -- exact (identity _). -- exact (# (ComplexHomotFunctor A) (InvRotMorphismInv A I')). * use make_MPMorComms. -- exact (KAInvRotDTris_Comm1 D I). -- exact (KAInvRotDTris_Comm2 D I). + exact (KAInvRotDTris_Comm3 D I). - use make_TriMor_is_iso. + exact (is_z_isomorphism_identity _). + exact (is_z_isomorphism_identity _). + exact (InvRotMorphism_is_z_isomorphism A _). Defined. Lemma KAInvRotDTris : ∏ D : DTri, @isDTri KAPreTriangData (InvRotTri D). Proof. intros D. use (squash_to_prop (DTriisDTri D) (propproperty _)). intros I. set (i' := hfiberpr1 _ _ (KADTriDataFiber I)). use hinhpr. use make_KADTriData. - exact (Morphisms.make_Morphism (# (ComplexHomotFunctor A) (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A i')) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I)))))). - exact (KAFiber (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A i')) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) (Source (KADTriDataMor I))))). - exact (KAInvRotDTris_Iso D I). Qed. (** ** Completion to distinguished triangle *) Local Opaque TranslationFunctor TranslationFunctorH. Lemma KAConeDTri : ∏ (x y : KAPreTriangData) (f : KAPreTriangData ⟦ x, y ⟧), ∃ D : ConeData Trans x y, isDTri (ConeTri f D). Proof. intros x y f. use (squash_to_prop (ComplexHomotFunctor_issurj A f) (propproperty _)). intros f'. set (f'' := hfiberpr1 _ _ f'). use hinhpr. use tpair. - use make_ConeData. + exact ((ComplexHomotFunctor A) (MappingCone A f'')). + exact (# (ComplexHomotFunctor A) (MappingConeIn2 A f'')). + exact (# (ComplexHomotFunctor A) (MappingConePr1 A f'')). - use hinhpr. use make_KADTriData. + exact (Morphisms.make_Morphism f). + exact f'. + use make_TriIso. * use make_TriMor. -- use make_MPMor. ++ use make_MPMorMors. ** exact (identity _). ** exact (identity _). ** exact (identity _). ++ use make_MPMorComms. ** exact (! (KAIdComm _ _ (idpath _))). ** exact (! (KAIdComm _ _ (idpath _))). -- cbn. rewrite id_left. use (pathscomp0 (! (id_right _))). apply cancel_precomposition. apply (! (functor_id _ _)). * use make_TriMor_is_iso. -- exact (is_z_isomorphism_identity _). -- exact (is_z_isomorphism_identity _). -- exact (is_z_isomorphism_identity _). Qed. (** ** Extension of squares *) Lemma KAExt_Comm1 (D1 D2 : DTri) (g1 : KAPreTriangData ⟦ Ob1 D1, Ob1 D2 ⟧) (g2 : KAPreTriangData ⟦ Ob2 D1, Ob2 D2 ⟧) (H : g1 · Mor1 D2 = Mor1 D1 · g2) (I1 : KADTriData D1) (I2 : KADTriData D2) : (MPMor1 (TriIsoInv (KADTriDataIso I1))) · g1 · (MPMor1 (KADTriDataIso I2)) · (KADTriDataMor I2) = (KADTriDataMor I1) · (MPMor2 (TriIsoInv (KADTriDataIso I1))) · g2 · (MPMor2 (KADTriDataIso I2)). Proof. set (tmp := MPComm1 (TriIsoInv (KADTriDataIso I1))). apply (maponpaths (postcompose (g2 · MPMor2 (KADTriDataIso I2)))) in tmp. unfold postcompose in tmp. rewrite assoc in tmp. rewrite assoc in tmp. use (pathscomp0 _ tmp). clear tmp. rewrite <- (assoc (MPMor1 (TriIsoInv (KADTriDataIso I1)))). rewrite <- (assoc (MPMor1 (TriIsoInv (KADTriDataIso I1)))). rewrite <- (assoc (MPMor1 (TriIsoInv (KADTriDataIso I1)))). rewrite <- (assoc (MPMor1 (TriIsoInv (KADTriDataIso I1)))). apply cancel_precomposition. apply (maponpaths (postcompose (MPMor2 (KADTriDataIso I2)))) in H. unfold postcompose in H. use (pathscomp0 _ H). clear H. rewrite <- (assoc g1). rewrite <- (assoc g1). apply cancel_precomposition. exact (MPComm1 (KADTriDataIso I2)). Qed. Lemma KAExt_MorEq (D1 D2 : DTri) (g1 : KAPreTriangData ⟦ Ob1 D1, Ob1 D2 ⟧) (g2 : KAPreTriangData ⟦ Ob2 D1, Ob2 D2 ⟧) (H : g1 · Mor1 D2 = Mor1 D1 · g2) (I1 : KADTriData D1) (I2 : KADTriData D2) (h1 : hfiber # (ComplexHomotFunctor A) (MPMor1 (TriIsoInv (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2))) (h2 : hfiber # (ComplexHomotFunctor A) (MPMor2 (TriIsoInv (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2))) (I1' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I1) (KADTriDataFiber I1)) (I2' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I2) (KADTriDataFiber I2)) (h1' := hfiberpr1 _ _ h1) (h2' := hfiberpr1 _ _ h2) : # (ComplexHomotFunctor A) (I1' · h2') = # (ComplexHomotFunctor A) (h1' · I2'). Proof. use ComplexHomotComm2. rewrite assoc. rewrite assoc. exact (! (KAExt_Comm1 D1 D2 g1 g2 H I1 I2)). Qed. Lemma KAExt_Comm2 (D1 D2 : DTri) (g1 : KAPreTriangData ⟦ Ob1 D1, Ob1 D2 ⟧) (g2 : KAPreTriangData ⟦ Ob2 D1, Ob2 D2 ⟧) (H : g1 · Mor1 D2 = Mor1 D1 · g2) (I1 : KADTriData D1) (I2 : KADTriData D2) (h1 : hfiber # (ComplexHomotFunctor A) (MPMor1 (TriIsoInv (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2))) (h2 : hfiber # (ComplexHomotFunctor A) (MPMor2 (TriIsoInv (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2))) (I1' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I1) (KADTriDataFiber I1)) (I2' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I2) (KADTriDataFiber I2)) (h1' := hfiberpr1 # (ComplexHomotFunctor A) (is_z_isomorphism_mor (TriMor_is_iso1 (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2)) h1) (h2' := hfiberpr1 # (ComplexHomotFunctor A) (is_z_isomorphism_mor (TriMor_is_iso2 (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2)) h2) (HH1 : ComplexHomot A (Source (KADTriDataMor I1)) (Ob2 (MappingConeTri (KADTriDataMor I2) (KADTriDataFiber I2)))) (HH2 : ComplexHomotMorphism A HH1 = @to_binop (ComplexPreCat_Additive A) (Source (KADTriDataMor I1)) (Ob2 (MappingConeTri (KADTriDataMor I2) (KADTriDataFiber I2))) (I1' · h2') (to_inv (h1' · I2'))) : # (ComplexHomotFunctor A) (MappingConeIn2 A I1') · # (ComplexHomotFunctor A) (MappingConeMorExt A I1' I2' h1' h2' HH1 (! HH2)) = (is_z_isomorphism_mor (TriMor_is_iso2 (KADTriDataIso I1))) · g2 · MPMor2 (KADTriDataIso I2) · # (ComplexHomotFunctor A) (MappingConeIn2 A I2'). Proof. set (tmp := hfiberpr2 _ _ h2). apply (maponpaths (postcompose (Mor2 (MappingConeTri (KADTriDataMor I2) (KADTriDataFiber I2))))) in tmp. use (pathscomp0 _ tmp). clear tmp. cbn. unfold postcompose. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). use (pathscomp0 _ (functor_comp (ComplexHomotFunctor A) _ _)). apply maponpaths. exact (MappingConeMorExtComm1 A I1' I2' h1' h2' HH1 (! HH2)). Qed. Lemma KAExt_Comm3 (D1 D2 : DTri) (g1 : KAPreTriangData ⟦ Ob1 D1, Ob1 D2 ⟧) (g2 : KAPreTriangData ⟦ Ob2 D1, Ob2 D2 ⟧) (H : g1 · Mor1 D2 = Mor1 D1 · g2) (I1 : KADTriData D1) (I2 : KADTriData D2) (h1 : hfiber # (ComplexHomotFunctor A) (MPMor1 (TriIsoInv (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2))) (h2 : hfiber # (ComplexHomotFunctor A) (MPMor2 (TriIsoInv (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2))) (I1' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I1) (KADTriDataFiber I1)) (I2' := hfiberpr1 # (ComplexHomotFunctor A) (KADTriDataMor I2) (KADTriDataFiber I2)) (h1' := hfiberpr1 # (ComplexHomotFunctor A) (is_z_isomorphism_mor (TriMor_is_iso1 (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2)) h1) (h2' := hfiberpr1 # (ComplexHomotFunctor A) (is_z_isomorphism_mor (TriMor_is_iso2 (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2)) h2) (HH1 : ComplexHomot A (Source (KADTriDataMor I1)) (Ob2 (MappingConeTri (KADTriDataMor I2) (KADTriDataFiber I2)))) (HH2 : ComplexHomotMorphism A HH1 = @to_binop (ComplexPreCat_Additive A) (Source (KADTriDataMor I1)) (Ob2 (MappingConeTri (KADTriDataMor I2) (KADTriDataFiber I2))) (I1' · h2') (to_inv (h1' · I2'))) : # (ComplexHomotFunctor A) (MappingConePr1 A I1') · (# (AddEquiv1 (@Trans KAPreTriangData)) (is_z_isomorphism_mor (TriMor_is_iso1 (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2))) = # (ComplexHomotFunctor A) (MappingConeMorExt A I1' I2' h1' h2' HH1 (! HH2)) · # (ComplexHomotFunctor A) (MappingConePr1 A I2'). Proof. use (pathscomp0 _ (functor_comp (ComplexHomotFunctor A) _ _)). use (pathscomp0 _ (maponpaths # (ComplexHomotFunctor A) (MappingConeMorExtComm2 A I1' I2' h1' h2' HH1 (! HH2)))). use (pathscomp0 _ (! (functor_comp (ComplexHomotFunctor A) _ _))). apply cancel_precomposition. use TranslationFunctorHImEq. exact (hfiberpr2 _ _ h1). Qed. Lemma KAExt : ∏ (D1 D2 : DTri) (g1 : KAPreTriangData ⟦ Ob1 D1, Ob1 D2 ⟧) (g2 : KAPreTriangData ⟦ Ob2 D1, Ob2 D2 ⟧) (H : g1 · Mor1 D2 = Mor1 D1 · g2), ∥ TExt H ∥. Proof. intros D1 D2 g1 g2 H. use (squash_to_prop (DTriisDTri D1) (propproperty _)). intros I1. set (I1' := hfiberpr1 _ _ (KADTriDataFiber I1)). use (squash_to_prop (DTriisDTri D2) (propproperty _)). intros I2. set (I2' := hfiberpr1 _ _ (KADTriDataFiber I2)). set (φ1 := (MPMor1 (TriIsoInv (KADTriDataIso I1)) · g1 · MPMor1 (KADTriDataIso I2))). set (φ2 := (MPMor2 (TriIsoInv (KADTriDataIso I1)) · g2 · MPMor2 (KADTriDataIso I2))). use (squash_to_prop (ComplexHomotFunctor_issurj A φ1) (propproperty _)). intros φ1'. use (squash_to_prop (ComplexHomotFunctor_issurj A φ2) (propproperty _)). intros φ2'. use (squash_to_prop (ComplexHomotFunctor_im_to_homot A _ _ (KAExt_MorEq D1 D2 g1 g2 H I1 I2 φ1' φ2')) (propproperty _ )). intros HH. use hinhpr. use (@DExtIso KAPreTriangData _ _ _ _ (KADTriDataIso I1) (KADTriDataIso I2)). - exact (# (ComplexHomotFunctor A) (MappingConeMorExt A I1' I2' (hfiberpr1 _ _ φ1') (hfiberpr1 _ _ φ2') (pr1 HH) (! (pr2 HH)))). - exact (KAExt_Comm2 D1 D2 g1 g2 H I1 I2 φ1' φ2' (pr1 HH) (pr2 HH)). - exact (KAExt_Comm3 D1 D2 g1 g2 H I1 I2 φ1' φ2' (pr1 HH) (pr2 HH)). Defined. (** ** Closed under isomorphisms *) Definition KADTrisIsos : ∏ T1 T2 : Tri, ∥ TriIso T1 T2 ∥ → @isDTri KAPreTriangData T1 → @isDTri KAPreTriangData T2. Proof. intros T1 T2 I X0. use (squash_to_prop I (propproperty _)). intros I'. use (squash_to_prop X0 (propproperty _)). intros I1. clear X0. use hinhpr. use make_KADTriData. - exact (KADTriDataMor I1). - exact (KADTriDataFiber I1). - exact (TriIso_comp (TriIsoInv I') (KADTriDataIso I1)). Qed. Definition KAPreTriang : PreTriang. Proof. use make_PreTriang. - exact KAPreTriangData. - use make_isPreTriang. + exact KATrivialDistinguished. + exact KADTrisIsos. + exact KARotDTris. + exact KAInvRotDTris. + exact KAConeDTri. + exact KAExt. Defined. End KAPreTriangulated. UniMath-20231010/UniMath/HomologicalAlgebra/KATriangulated.v000066400000000000000000000232161451125700300234210ustar00rootroot00000000000000(** * K(A) is a triangulated category *) (** Contents - K(A) triangulated - Octahedral axiom - K(A) triangulated *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.ShortExactSequences. Require Import UniMath.CategoryTheory.categories.abgrs. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.Triangulated. Require Import UniMath.HomologicalAlgebra.KA. Require Import UniMath.HomologicalAlgebra.TranslationFunctors. Require Import UniMath.HomologicalAlgebra.MappingCone. Require Import UniMath.HomologicalAlgebra.KAPreTriangulated. Unset Kernel Term Sharing. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow. (** * K(A) as a triangulated category *) Section KATriangulated. Context {A : CategoryWithAdditiveStructure}. Local Opaque ComplexHomotFunctor ComplexHomotSubset Quotcategory identity MappingConePr1 MappingConeIn2 RotMorphism RotMorphismInv InvRotMorphism InvRotMorphismInv to_inv compose to_abgr pathsinv0 pathscomp0 ishinh. Definition KATriangOcta_TriIso {x y z : ob (@KAPreTriang A)} {f1 : x --> y} {g1 : y --> z} (f1' : hfiber # (ComplexHomotFunctor A) f1) (g1' : hfiber # (ComplexHomotFunctor A) g1) (f1'' := hfiberpr1 _ _ f1') (g1'' := hfiberpr1 _ _ g1') (i' := make_hfiber # (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'') (idpath (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'')))) : TriIso (@make_Tri KAPreTriang Trans _ _ _ (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'')) (# (ComplexHomotFunctor A) (KAOctaMor2 f1'' g1'')) (# (ComplexHomotFunctor A) (MappingConePr1 A g1'') · # (AddEquiv1 (@Trans KAPreTriang)) (# (ComplexHomotFunctor A) (MappingConeIn2 A f1'')))) (MappingConeTri (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'')) i'). Proof. use make_TriIso. * use make_TriMor. -- use make_MPMor. ++ use make_MPMorMors. ** exact (identity _). ** exact (identity _). ** exact (# (ComplexHomotFunctor A) (KAOctaMor3 f1'' g1'')). ++ use make_MPMorComms. ** exact (! (KAIdComm _ _ (idpath _))). ** exact (KAOctaComm2' f1'' g1''). -- exact (KAOctaComm3' f1'' g1''). * use make_TriMor_is_iso. ++ exact (is_z_isomorphism_identity _). ++ exact (is_z_isomorphism_identity _). ++ exact (KAOctaMor3Iso f1'' g1''). Defined. Definition KATriangOcta_KADTriData {x y z : ob (@KAPreTriang A)} {f1 : x --> y} {g1 : y --> z} (f1' : hfiber # (ComplexHomotFunctor A) f1) (g1' : hfiber # (ComplexHomotFunctor A) g1) (f1'' := hfiberpr1 _ _ f1') (g1'' := hfiberpr1 _ _ g1') : KADTriData (@make_Tri KAPreTriang Trans _ _ _ (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'')) (# (ComplexHomotFunctor A) (KAOctaMor2 f1'' g1'')) (# (ComplexHomotFunctor A) (MappingConePr1 A g1'') · # (AddEquiv1 (@Trans KAPreTriang)) (# (ComplexHomotFunctor A) (MappingConeIn2 A f1'')))). Proof. use make_KADTriData. + exact (Morphisms.make_Morphism (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1''))). + exact (make_hfiber (# (ComplexHomotFunctor A)) (KAOctaMor1 f1'' g1'') (idpath _)). + exact (KATriangOcta_TriIso f1' g1'). Defined. Lemma KATriangOcta_hfiber_comp_eq {x y z : ob (@KAPreTriang A)} (f : x --> y) (g : y --> z) (f' : hfiber (# (ComplexHomotFunctor A)) f) (g' : hfiber (# (ComplexHomotFunctor A)) g) (f'' := hfiberpr1 # (ComplexHomotFunctor A) f f') (g'' := hfiberpr1 # (ComplexHomotFunctor A) g g'): # (ComplexHomotFunctor A) (f'' · g'') = f · g. Proof. unfold f'', g''. rewrite functor_comp. rewrite hfiberpr2. rewrite hfiberpr2. apply idpath. Qed. Lemma KATriangOcta {x1 x2 y1 y2 z1 z2 : ob (@KAPreTriang A)} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) : ∥ Octa H1 H2 H3 ∥. Proof. use (squash_to_prop (ComplexHomotFunctor_issurj A f1) (propproperty _)). intros f1'. use (squash_to_prop (ComplexHomotFunctor_issurj A g1) (propproperty _)). intros g1'. set (f1'' := hfiberpr1 _ _ f1'). set (g1'' := hfiberpr1 _ _ g1'). set (fg1' := make_hfiber (# (ComplexHomotFunctor A)) (f1'' · g1'') (KATriangOcta_hfiber_comp_eq f1 g1 f1' g1')). set (H1' := KAFiberisDTri (Morphisms.make_Morphism f1) f1'). set (H2' := KAFiberisDTri (Morphisms.make_Morphism g1) g1'). set (H3' := KAFiberisDTri (Morphisms.make_Morphism (f1 · g1)) fg1'). use (squash_to_prop (DExt KAPreTriang (make_DTri' _ H1) (make_DTri' _ (KAFiberisDTri (Morphisms.make_Morphism f1) f1')) (identity _) (identity _) (! (KAIdComm _ _ (idpath _)))) (propproperty _)). intros Ext1. set (I1' := make_TriIso (TExtMor Ext1) (@make_TriMor_is_iso KAPreTriang Trans _ _ (TExtMor Ext1) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _) (TriangulatedFiveLemma (TExtMor Ext1) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _)))). use (squash_to_prop (DExt KAPreTriang (make_DTri' _ H2) (make_DTri' _ (KAFiberisDTri (Morphisms.make_Morphism g1) g1')) (identity _) (identity _) (! (KAIdComm _ _ (idpath _)))) (propproperty _)). intros Ext2. set (I2' := make_TriIso (TExtMor Ext2) (@make_TriMor_is_iso KAPreTriang Trans _ _ (TExtMor Ext2) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _) (TriangulatedFiveLemma (TExtMor Ext2) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _)))). use (squash_to_prop (DExt KAPreTriang (make_DTri' _ H3) (make_DTri' _ (KAFiberisDTri (Morphisms.make_Morphism (f1 · g1)) fg1')) (identity _) (identity _) (! (KAIdComm _ _ (idpath _)))) (propproperty _)). intros Ext3. set (I3' := make_TriIso (TExtMor Ext3) (@make_TriMor_is_iso KAPreTriang Trans _ _ (TExtMor Ext3) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _) (TriangulatedFiveLemma (TExtMor Ext3) (is_z_isomorphism_identity _) (is_z_isomorphism_identity _)))). use hinhpr. use (OctaIso H1 H2 H3 H1' H2' H3' I1' I2' I3' (idpath _) (idpath _) (idpath _)). clear I3' Ext3 I2' Ext2 I1' Ext1. use make_Octa. - exact (# (ComplexHomotFunctor A) (KAOctaMor1 f1'' g1'')). - exact (# (ComplexHomotFunctor A) (KAOctaMor2 f1'' g1'')). - exact (hinhpr (KATriangOcta_KADTriData f1' g1')). - use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). apply maponpaths. exact (KAOctaMor1Comm f1'' g1''). - use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). apply maponpaths. exact (KAOctaMor2Comm f1'' g1''). - use (pathscomp0 (KAOctaComm5' f1'' g1'')). apply cancel_postcomposition. exact (hfiberpr2 _ _ g1'). - use (pathscomp0 (KAOctaComm4' f1'' g1'')). apply cancel_precomposition. apply maponpaths. exact (hfiberpr2 _ _ f1'). Qed. Definition KATriang : Triang. Proof. use make_Triang. - exact (@KAPreTriang A). - intros x1 x2 y1 y2 z1 z2 f1 f2 f3 g1 g2 g3 h2 h3 H1 H2 H3. exact(KATriangOcta H1 H2 H3). Defined. End KATriangulated.UniMath-20231010/UniMath/HomologicalAlgebra/MappingCone.v000066400000000000000000010154341451125700300227660ustar00rootroot00000000000000(** * Mapping cones in C(A) *) (** ** Contents - Definition of a mapping cone C(f) - C(id) - Rotation of triangles - Inverse rotation of triangles - Extension of triangles - Octahedral axiom in K(A) *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.KA. Require Import UniMath.HomologicalAlgebra.TranslationFunctors. Unset Kernel Term Sharing. Local Open Scope hz_scope. Local Open Scope cat. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow. (** * Mapping cone *) (** ** Introduction In this section we construct the mapping cone, which is a complex, of a morphism f : C_1 -> C_2 of complexes. We denote mapping cone of f by Cone(f). The objects of mapping cone are given by T C_1^i ⊕ C_2^i. The ith differential of Cone(f) is given by # - p_1 · d^{i+1}_X · i_1 - i_2 · f^{i+1} · p_1 + p_2 · d^i_Y · i_2 # $ - p_1 · d^{i+1}_X · i_1 - i_2 · f^{i+1} · p_1 + p_2 · d^i_Y · i_2 $ We split the definition of the ith differential into a sum of 3 morphisms. These are constructed in [MappingConeDiff1], [MappingConeDiff3], and [MappingConeDiff3], and correspond the morphisms of the above formula, respectively. In [MappingConeDiff] we construct the differential. In [MappingCone_comp] we show that composition of two consecutive differentials is 0. The complex Cone(f) is constructed in [MappingCone]. *) Section mapping_cone. Variable A : CategoryWithAdditiveStructure. (** # - (p_1 · d^{i+1}_{C_1} · i_1) # *) Definition MappingConeDiff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in A ⟦ to_BinDirectSums A (C1 (i + 1)) (C2 i), to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) ⟧. Proof. intros DS1 DS2. use compose. - exact (TranslationComplex A C1 i). - exact (to_Pr1 DS1). - use compose. + exact (TranslationComplex A C1 (i + 1)). + exact (DiffTranslationComplex A C1 i). + exact (to_In1 DS2). Defined. (** # (p_1 · f (i + 1) · i_2) # *) Definition MappingConeDiff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in A ⟦ to_BinDirectSums A (C1 (i + 1)) (C2 i), to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) ⟧. Proof. intros DS1 DS2. use compose. - exact (TranslationComplex A C1 i). - exact (to_Pr1 DS1). - use compose. + exact (C2 (i + 1)). + exact (f (i + 1)). + exact (to_In2 DS2). Defined. (** # p2 · d^i_{C_2} · i2 # *) Definition MappingConeDiff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in A ⟦ to_BinDirectSums A (C1 (i + 1)) (C2 i), to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) ⟧. Proof. intros DS1 DS2. use compose. - exact (C2 i). - exact (to_Pr2 DS1). - use compose. + exact (C2 (i + 1)). + exact (Diff C2 i). + exact (to_In2 DS2). Defined. Definition MappingConeDiff {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in A ⟦ to_BinDirectSums A (C1 (i + 1)) (C2 i), to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) ⟧. Proof. intros DS1 DS2. use to_binop. - exact (MappingConeDiff1 f i). - use to_binop. + exact (MappingConeDiff2 f i). + exact (MappingConeDiff3 f i). Defined. Lemma MappingCone_Diff1_Diff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in (MappingConeDiff1 f i) · (MappingConeDiff1 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingConeDiff1. fold DS1. fold DS2. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_IdIn1 DS2). rewrite id_right. cbn. rewrite <- (assoc _ _ (DiffTranslationComplex A C1 (i + 1))). cbn. set (tmp := DiffTranslationComplex_comp A C1 i). cbn in tmp. cbn. rewrite tmp. rewrite ZeroArrow_comp_right. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff1_Diff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in (MappingConeDiff1 f i) · (MappingConeDiff3 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingConeDiff1. unfold MappingConeDiff3. fold DS1. fold DS2. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS2)). rewrite (to_Unel1 DS2). rewrite (PreAdditive_unel_zero _ (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff2_Diff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in let DS3 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1 + 1)) (C2 (i + 1 + 1)) in (MappingConeDiff2 f i) · (MappingConeDiff1 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2 DS3. unfold MappingConeDiff2. unfold MappingConeDiff1. fold DS1. fold DS2. fold DS3. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2 DS2). rewrite (PreAdditive_unel_zero _ (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff2_Diff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in (MappingConeDiff2 f i) · (MappingConeDiff2 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingConeDiff2. fold DS1. fold DS2. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2 DS2). rewrite (PreAdditive_unel_zero _ (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff3_Diff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in (MappingConeDiff3 f i) · (MappingConeDiff1 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingConeDiff3. unfold MappingConeDiff1. fold DS1. fold DS2. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2 DS2). rewrite (PreAdditive_unel_zero _ (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff3_Diff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in (MappingConeDiff3 f i) · (MappingConeDiff2 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingConeDiff3. unfold MappingConeDiff2. fold DS1. fold DS2. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2 DS2). rewrite (PreAdditive_unel_zero _ (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_Diff3_Diff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A ((TranslationComplex A C1) i) (C2 i) in let DS2 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1)) (C2 (i + 1)) in let DS3 := to_BinDirectSums A ((TranslationComplex A C1) (i + 1 + 1)) (C2 (i + 1 + 1)) in (MappingConeDiff3 f i) · (MappingConeDiff3 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2 DS3. unfold MappingConeDiff3. fold DS1. fold DS2. fold DS3. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite <- (assoc _ _ (Diff C2 (i + 1))). rewrite (DSq A C2 i). rewrite ZeroArrow_comp_right. apply ZeroArrow_comp_left. Qed. Lemma MappingCone_comp {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (to_binop _ _ (MappingConeDiff1 f i) (to_binop _ _ (MappingConeDiff2 f i) (MappingConeDiff3 f i))) · (to_binop _ _ (MappingConeDiff1 f (i + 1)) (to_binop _ _ (MappingConeDiff2 f (i + 1)) (MappingConeDiff3 f (i + 1)))) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1 + 1)) (C2 (i + 1 + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite (to_Unel2' DS2). rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_runax''. unfold DiffTranslationComplex. rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_IdIn1 DS2). rewrite (to_Unel1' DS2). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_lunax''. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc _ (Diff C1 (i + 1))). rewrite DSq. rewrite <- (assoc _ (Diff C2 i)). rewrite DSq. rewrite inv_inv_eq. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_runax''. rewrite <- (assoc _ (f (i + 1))). rewrite (MComm f (i + 1)). rewrite assoc. rewrite (@to_linvax' A (Additive.to_Zero A)). apply idpath. Qed. Definition MappingCone {C1 C2 : Complex A} (f : Morphism C1 C2) : Complex A. Proof. use make_Complex. - intros i. exact (to_BinDirectSums A (C1 (i + 1)) (C2 i)). - intros i. exact (MappingConeDiff f i). - intros i. exact (MappingCone_comp f i). Defined. (** In2 to MappingCone *) Local Lemma MappingConeIn2_comm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : to_In2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · MappingConeDiff f i = Diff C2 i · to_In2 (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_premor_linear'. rewrite assoc. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_premor_linear'. rewrite assoc. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite assoc. rewrite (to_IdIn2 DS1). apply id_left. Qed. Definition MappingConeIn2 {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism C2 (MappingCone f). Proof. use make_Morphism. - intros i. exact (to_In2 (to_BinDirectSums A (TranslationComplex A C1 i) (C2 i))). - intros i. exact (MappingConeIn2_comm f i). Defined. (** Pr1 from MappingCone *) Local Lemma MappingConePr1_comm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · to_inv (Diff C1 (i + 1)) = MappingConeDiff f i · to_Pr1 (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 DS2). rewrite id_right. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite to_runax''. rewrite to_runax''. unfold DiffTranslationComplex. apply idpath. Qed. Definition MappingConePr1 {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism (MappingCone f) (TranslationComplex A C1). Proof. use make_Morphism. - intros i. exact (to_Pr1 (to_BinDirectSums A (TranslationComplex A C1 i) (C2 i))). - intros i. exact (MappingConePr1_comm f i). Defined. End mapping_cone. (** * Results on C(id) *) (** ** Introduction We show that for all objects X in K(A) we have the following isomorphism of triangles X --> X --> 0 --> X[1] | | | | X --> X --> C(id) --> X[1] *) Section mapping_cone_of_id. Variable A : CategoryWithAdditiveStructure. Local Opaque precategory_morphisms InvTranslationFunctorHIm TranslationFunctorHIm ComplexHomotFunctor compose InvTranslationFunctorH TranslationFunctorH TranslationFunctor InvTranslationFunctor identity. Definition MappingConeIn2Homot (C : Complex A) : ComplexHomot A C (MappingCone A (@identity (ComplexPreCat_Additive A) C)). Proof. intros i. exact (transportf (λ x' : ob A, precategory_morphisms x' ((MappingCone A (@identity (ComplexPreCat_Additive A) C)) (i - 1))) (maponpaths C (hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C (i - 1 + 1)) (C (i - 1))))). Defined. Lemma MappingConeIn2Eq (C : Complex A) : # (ComplexHomotFunctor A) (MappingConeIn2 A (@identity (ComplexPreCat_Additive A) C)) = # (ComplexHomotFunctor A) (ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive A)) _ _). Proof. use ComplexHomotFunctor_rel_mor'. - exact (MappingConeIn2Homot C). - rewrite to_inv_zero. rewrite to_runax''. use MorphismEq. intros i. cbn. unfold MappingConeIn2Homot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C (i + 1)) (C i)). set (DS2 := to_BinDirectSums A (C (i - 1 + 1)) (C (i - 1))). set (DS3 := to_BinDirectSums A (C (i - 1 + 1 + 1)) (C (i - 1 + 1))). set (DS4 := to_BinDirectSums A (C (i + 1 - 1 + 1)) (C (i + 1 - 1))). rewrite id_left. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- transport_source_precompose. rewrite (to_IdIn1 DS2). rewrite <- transport_source_precompose. rewrite id_left. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite id_left. rewrite <- transport_source_precompose. rewrite (to_Unel1' DS2). rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite transport_source_to_binop. unfold DiffTranslationComplex. assert (e1 : (transportf (precategory_morphisms (C i)) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS3 ⟧) (maponpaths C (hzrminusplus i 1)) (to_binop (C (i - 1 + 1)) DS3 (to_inv (Diff C (i - 1 + 1)) · to_In1 DS3) (to_In2 DS3)))) = to_binop (C i) DS1 (to_inv (Diff C i) · to_In1 DS1) (to_In2 DS1)). { unfold DS1, DS2, DS3, DS4. set (tmp := transport_hz_double_section_source_target A C (λ (i0 : hz), to_BinDirectSums A (C (i0 + 1)) (C i0)) (λ (i0 : hz), to_binop (C i0) (to_BinDirectSums A (C (i0 + 1)) (C i0)) (to_inv (Diff C i0) · to_In1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) (to_In2 (to_BinDirectSums A (C (i0 + 1)) (C i0)))) _ _ (hzrminusplus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply idpath. } apply (maponpaths (λ gg : _, to_binop _ _ gg ((transportf (precategory_morphisms (C i)) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrplusminus i 1)) (Diff C i · transportf (λ x' : A, A ⟦ x', DS4 ⟧) (maponpaths C (hzrminusplus (i + 1) 1)) (to_In1 DS4)))))) in e1. use (pathscomp0 _ (! e1)). clear e1. rewrite transport_target_postcompose. assert (e2 : transportf (precategory_morphisms (C (i + 1))) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS4 ⟧) (maponpaths C (hzrminusplus (i + 1) 1)) (to_In1 DS4)) = to_In1 DS1). { unfold DS1, DS2, DS3, DS4. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, C (i0 + 1)) (λ (i0 : hz), to_BinDirectSums A (C (i0 + 1)) (C i0)) (λ (i0 : hz), to_In1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) _ _ (hzrplusminus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. assert (e3 : (maponpaths C (hzrminusplus (i + 1) 1)) = (maponpaths (λ i0 : hz, C (i0 + 1)) (hzrplusminus i 1))). { assert (e4 : maponpaths (λ i0 : hz, C (i0 + 1)) (hzrplusminus i 1) = maponpaths C (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e4. clear e4. apply maponpaths. apply isasethz. } rewrite e3. apply idpath. } rewrite e2. clear e2. rewrite to_commax'. rewrite <- to_assoc. rewrite <- to_postmor_linear'. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite ZeroArrow_comp_left. rewrite to_lunax''. apply idpath. Qed. Definition MappingConePr1Homot (C : Complex A) : ComplexHomot A (MappingCone A (@identity (ComplexPreCat_Additive A) C)) (TranslationComplex A C). Proof. intros i. cbn. exact (transportf (precategory_morphisms (to_BinDirectSums A (C (i + 1)) (C i))) (maponpaths C (! hzrminusplus i 1)) (to_Pr2 (to_BinDirectSums A (C (i + 1)) (C i)))). Defined. Lemma MappingConePr1Eq (C : Complex A) : # (ComplexHomotFunctor A) (MappingConePr1 A (@identity (ComplexPreCat_Additive A) C)) = # (ComplexHomotFunctor A) (ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive A)) _ _). Proof. use ComplexHomotFunctor_rel_mor'. - exact (MappingConePr1Homot C). - rewrite to_inv_zero. rewrite to_runax''. use MorphismEq. intros i. cbn. unfold MappingConePr1Homot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C (i + 1)) (C i)). set (DS2 := to_BinDirectSums A (C (i + 1 + 1)) (C (i + 1))). rewrite id_left. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite assoc. rewrite assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn2 DS2). rewrite id_right. rewrite id_right. rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite transport_target_ZeroArrow. rewrite (to_lunax''). assert (e1 : (transportf (precategory_morphisms DS1) (maponpaths (λ i0 : pr1 hz, C (i0 + 1)) (hzrplusminus i 1)) (to_binop DS1 (C (i + 1 - 1 + 1)) (transportf (precategory_morphisms DS1) (maponpaths C (! hzrminusplus (i + 1) 1)) (to_Pr1 DS1)) (transportf (precategory_morphisms DS1) (maponpaths C (! hzrminusplus (i + 1) 1)) (to_Pr2 DS1 · Diff C i)))) = to_binop DS1 (C (i + 1)) (to_Pr1 DS1) (to_Pr2 DS1 · Diff C i)). { unfold DS1, DS2. set (tmp := transport_hz_double_section_source_target A (λ (i0 : hz), to_BinDirectSums A (C (i0 + 1)) (C i0)) (λ i0 : hz, C (i0 + 1)) (λ (i0 : hz), to_binop (to_BinDirectSums A (C (i0 + 1)) (C i0)) (C (i0 + 1)) (to_Pr1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) (to_Pr2 (to_BinDirectSums A (C (i0 + 1)) (C i0)) · Diff C i0)) _ _ (hzrplusminus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. rewrite transport_target_to_binop. set (tmp := transport_hz_double_section A (λ i0 : hz, to_BinDirectSums A (C (i0 + 1)) (C i0)) (λ (i0 : hz), C (i0 + 1)) (λ i0 : hz, (to_binop (to_BinDirectSums A (C (i0 + 1)) (C i0)) (C (i0 + 1)) (to_Pr1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) (to_Pr2 (to_BinDirectSums A (C (i0 + 1)) (C i0)) · Diff C i0))) _ _ (! hzrplusminus i 1)). cbn beta in tmp. assert (e2 : (maponpaths (λ i0 : hz, C (i0 + 1)) (! hzrplusminus i 1)) = (maponpaths C (! hzrminusplus (i + 1) 1))). { assert (e3 : maponpaths (λ i0 : hz, C (i0 + 1)) (! hzrplusminus i 1) = maponpaths C (maponpaths (λ (i0 : hz), i0 + 1) (! hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e3. clear e3. apply maponpaths. apply isasethz. } rewrite e2 in tmp. clear e2. use (pathscomp0 tmp). clear tmp. assert (e4 : (maponpaths (λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (! (! hzrplusminus i 1))) = (maponpaths (λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrplusminus i 1))). { apply maponpaths. apply isasethz. } rewrite e4. apply idpath. } apply (maponpaths (λ gg : _, to_binop _ _ (transportf (precategory_morphisms DS1) (maponpaths (λ i0 : pr1 hz, C (i0 + 1)) (hzrminusplus i 1)) (transportf (precategory_morphisms DS1) (maponpaths C (! hzrminusplus i 1)) (to_Pr2 DS1) · to_inv (Diff C (i - 1 + 1)))) gg)) in e1. use (pathscomp0 _ (! e1)). clear e1. assert (e2 : (transportf (precategory_morphisms DS1) (maponpaths (λ i0 : pr1 hz, C (i0 + 1)) (hzrminusplus i 1)) (transportf (precategory_morphisms DS1) (maponpaths C (! hzrminusplus i 1)) (to_Pr2 DS1) · to_inv (Diff C (i - 1 + 1)))) = to_Pr2 DS1 · to_inv (Diff C i)). { rewrite transport_target_postcompose. rewrite transport_compose. apply cancel_precomposition. rewrite <- transport_target_to_inv. rewrite <- transport_source_to_inv. apply maponpaths. rewrite <- maponpathsinv0. rewrite pathsinv0inv0. induction (hzrminusplus i 1). apply idpath. } apply (maponpaths (λ gg : _, to_binop _ _ gg (to_binop DS1 (C (i + 1)) (to_Pr1 DS1) (to_Pr2 DS1 · Diff C i)))) in e2. use (pathscomp0 _ (! e2)). clear e2. rewrite to_commax'. rewrite to_assoc. rewrite <- to_premor_linear'. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply idpath. Qed. Local Transparent precategory_morphisms identity ZeroArrow compose. Definition MappingConeIdHomot (C : Complex A) : ComplexHomot A (MappingCone A (@identity (ComplexPreCat_Additive A) C)) (MappingCone A (@identity (ComplexPreCat_Additive A) C)). Proof. intros i. cbn. exact ((to_Pr2 (to_BinDirectSums A (C (i + 1)) (C i))) · (transportf (λ x' : ob A, precategory_morphisms x' ((MappingCone A (@identity (ComplexPreCat_Additive A) C)) (i - 1))) (maponpaths C (hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C (i - 1 + 1)) (C (i - 1)))))). Defined. Lemma IDMappingConeEq (C : Complex A) : # (ComplexHomotFunctor A) (@identity (ComplexPreCat_Additive A) (MappingCone A (@identity (ComplexPreCat_Additive A) C))) = # (ComplexHomotFunctor A) (ZeroArrow (Additive.to_Zero (ComplexPreCat_Additive A)) _ _). Proof. use ComplexHomotFunctor_rel_mor'. - exact (MappingConeIdHomot C). - rewrite to_inv_zero. rewrite to_runax''. use MorphismEq. intros i. cbn. use (pathscomp0 (! (to_BinOpId (to_BinDirectSums A (C (i + 1)) (C i))))). unfold MappingConeIdHomot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. rewrite id_left. rewrite id_left. cbn. set (DS1 := to_BinDirectSums A (C (i + 1)) (C i)). set (DS2 := to_BinDirectSums A (C (i - 1 + 1)) (C (i - 1))). set (DS3 := to_BinDirectSums A (C (i - 1 + 1 + 1)) (C (i - 1 + 1))). set (DS4 := to_BinDirectSums A (C (i + 1 + 1)) (C (i + 1))). set (DS5 := to_BinDirectSums A (C (i + 1 - 1 + 1)) (C (i + 1 - 1))). unfold DiffTranslationComplex. rewrite to_commax'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 DS2). rewrite id_left. rewrite id_left. rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite to_runax''. rewrite <- to_premor_linear'. rewrite transport_target_postcompose. rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_Unel1' DS4). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- to_postmor_linear'. rewrite transport_target_postcompose. rewrite <- transport_target_to_binop. assert (e1 : transportf (precategory_morphisms (C i)) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS3 ⟧) (maponpaths C (hzrminusplus i 1)) (to_inv (Diff C (i - 1 + 1)) · to_In1 DS3)) = to_inv (Diff C i) · to_In1 DS1). { unfold DS1. set (tmp := transport_hz_double_section_source_target A C (λ i0 : hz, (to_BinDirectSums A (C (i0 + 1)) (C i0))) (λ i0 : hz, to_inv (Diff C i0) · to_In1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) _ _ (hzrminusplus i 1)). cbn beta in tmp. unfold DS3. exact (! tmp). } assert (e2 : transportf (precategory_morphisms (C i)) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS3 ⟧) (maponpaths C (hzrminusplus i 1)) (to_In2 DS3)) = to_In2 DS1). { unfold DS1, DS3. set (tmp := transport_hz_double_section_source_target A C (λ i0 : hz, (to_BinDirectSums A (C (i0 + 1)) (C i0))) (λ i0 : hz, to_In2 (to_BinDirectSums A (C (i0 + 1)) (C i0))) _ _ (hzrminusplus i 1)). cbn beta in tmp. exact (! tmp). } set (e3 := maponpaths_12 (to_binop _ _) e1 e2). apply (maponpaths (λ gg : _, to_Pr2 DS1 · gg)) in e3. apply (maponpaths (λ gg : _, to_binop _ _ gg (to_binop DS1 (C (i + 1)) (to_Pr1 DS1) (to_Pr2 DS1 · Diff C i) · transportf (precategory_morphisms (C (i + 1))) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS5 ⟧) (maponpaths C (hzrminusplus (i + 1) 1)) (to_In1 DS5))))) in e3. use (pathscomp0 _ (! e3)). clear e3. clear e1 e2. assert (e4 : transportf (precategory_morphisms (C (i + 1))) (maponpaths (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C (i0 + 1)) (C i0))) (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS5 ⟧) (maponpaths C (hzrminusplus (i + 1) 1)) (to_In1 DS5)) = to_In1 DS1). { unfold DS1, DS5. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, C (i0 + 1)) (λ i0 : hz, (to_BinDirectSums A (C (i0 + 1)) (C i0))) (λ i0 : hz, to_In1 (to_BinDirectSums A (C (i0 + 1)) (C i0))) _ _ (hzrplusminus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. assert (e5 : (maponpaths C (hzrminusplus (i + 1) 1)) = (maponpaths (λ i0 : hz, C (i0 + 1)) (hzrplusminus i 1))). { assert (e6 : maponpaths (λ i0 : hz, C (i0 + 1)) (hzrplusminus i 1) = maponpaths C (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e6. apply maponpaths. apply isasethz. } rewrite e5. apply idpath. } apply (maponpaths (λ gg : _, to_binop DS1 (to_BinDirectSums A (C (i + 1)) (C i)) (to_Pr2 DS1 · to_binop (C i) (to_BinDirectSums A (C (i + 1)) (C i)) (to_inv (Diff C i) · to_In1 DS1) (to_In2 DS1)) (to_binop DS1 (C (i + 1)) (to_Pr1 DS1) (to_Pr2 DS1 · Diff C i) · gg))) in e4. use (pathscomp0 _ (! e4)). clear e4. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite assoc. rewrite (to_commax' A (to_inv (to_Pr2 DS1 · Diff C i · to_In1 DS1))). rewrite (to_commax' A _ (to_Pr2 DS1 · Diff C i · to_In1 DS1)). rewrite <- to_assoc. rewrite (to_assoc _ _ _ (to_Pr2 DS1 · Diff C i · to_In1 DS1)). rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_runax''. apply idpath. Qed. Lemma IDMappingCone_is_z_isomorphism_inverses (C : Complex A) : is_inverse_in_precat (ZeroArrow (Additive.to_Zero (ComplexHomot_Additive A)) ((ComplexHomotFunctor A) (Additive.to_Zero (ComplexPreCat_Additive A))) ((ComplexHomotFunctor A) (MappingCone A (@identity (ComplexPreCat_Additive A) C)))) (ZeroArrow (Additive.to_Zero (ComplexHomot_Additive A)) ((ComplexHomotFunctor A) (MappingCone A (@identity (ComplexPreCat_Additive A) C))) ((ComplexHomotFunctor A) (Additive.to_Zero (ComplexPreCat_Additive A)))). Proof. use make_is_inverse_in_precat. - rewrite ZeroArrow_comp_left. use (@ArrowsToZero (ComplexHomot_Additive A) (Additive.to_Zero (ComplexHomot_Additive A))). - rewrite ZeroArrow_comp_left. use (pathscomp0 _ (functor_id (ComplexHomotFunctor A) (MappingCone A (@identity (ComplexPreCat_Additive A) C)))). use (pathscomp0 (! (AdditiveFunctorZeroArrow (ComplexHomotFunctor A) _ _))). exact (! (IDMappingConeEq C)). Qed. Lemma IDMappingCone_is_z_isomorphism (C : Complex A) : is_z_isomorphism (ZeroArrow (Additive.to_Zero (ComplexHomot_Additive A)) ((ComplexHomotFunctor A) (Additive.to_Zero (ComplexPreCat_Additive A))) ((ComplexHomotFunctor A) (MappingCone A (@identity (ComplexPreCat_Additive A) C)))). Proof. use make_is_z_isomorphism. - exact (ZeroArrow (Additive.to_Zero (ComplexHomot_Additive A)) _ _). - exact (IDMappingCone_is_z_isomorphism_inverses C). Defined. End mapping_cone_of_id. (** * Rotation *) (** ** Introduction We prove results that are needed to prove that rotation of a distinguished triangle in K(A) is a distinguished triangle. More precisely, we construct h in the following diagram Y --> C(f) --> X[1] --> Y[1] | | h | | Y --> C(f) --> C(i2) --> Y[1] here i2 : Y --> C(f) is the second inclusion. Also, we show that h is an isomorphism in K(A) and that the above diagram is commutative in K(A). *) Section rotation_mapping_cone. Variable A : CategoryWithAdditiveStructure. Local Lemma RotMorphismComm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : to_binop (C1 (i + 1)) (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) ((to_inv (f (i + 1))) · to_In1 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))) ((to_In1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))) · (to_In2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))))) · MappingConeDiff A (MappingConeIn2 A f) i = to_inv (Diff C1 (i + 1)) · to_binop (C1 (i + 1 + 1)) (to_BinDirectSums A (C2 (i + 1 + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))) ((to_inv (f (i + 1 + 1))) · (to_In1 (to_BinDirectSums A (C2 (i + 1 + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))))) (to_In1 (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))) · to_In2 (to_BinDirectSums A (C2 (i + 1 + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_Unel2' DS2). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_runax''. unfold DiffTranslationComplex. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4. unfold DiffTranslationComplex. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_Unel1' DS1). rewrite (to_IdIn1 DS1). rewrite id_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_left. rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_Unel1' DS2). rewrite (to_IdIn1 DS2). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite to_binop_inv_inv. rewrite <- to_assoc. rewrite <- to_assoc. rewrite (to_commax' _ _ (to_inv (Diff C1 (i + 1) · to_In1 DS3 · to_In2 DS4))). rewrite to_assoc. rewrite to_assoc. rewrite (@to_linvax' A (Additive.to_Zero _)). rewrite to_runax''. rewrite to_binop_inv_inv. apply maponpaths. rewrite to_commax'. use maponpaths_12. - apply cancel_postcomposition. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. exact (MComm f (i + 1)). - apply idpath. Qed. Definition RotMorphism {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism (TranslationComplex A C1) (MappingCone A (MappingConeIn2 A f)). Proof. use make_Morphism. - intros i. cbn. use to_binop. + use compose. * exact (C2 (i + 1)). * exact (to_inv (f (i + 1))). * exact (to_In1 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))). + use compose. * exact (to_BinDirectSums A (C1 (i + 1)) (C2 i)). * exact (to_In1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). * exact (to_In2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))). - intros i. exact (RotMorphismComm f i). Defined. Lemma RotMorphismInvComm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : to_Pr2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) · to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · to_inv (Diff C1 (i + 1)) = MappingConeDiff A (MappingConeIn2 A f) i · (to_Pr2 (to_BinDirectSums A (C2 (i + 1 + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))) · to_Pr1 (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3). unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4. unfold DiffTranslationComplex. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite id_right. rewrite id_right. rewrite id_right. rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ (to_In2 DS3)). rewrite <- (assoc _ (to_In2 DS3)). rewrite <- (assoc _ (to_In2 DS3)). rewrite <- (assoc _ (to_In1 DS3)). rewrite (to_Unel2' DS3). rewrite (to_IdIn1 DS3). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite to_lunax''. rewrite to_lunax''. rewrite to_runax''. apply idpath. Qed. Definition RotMorphismInv {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism (MappingCone A (MappingConeIn2 A f)) (TranslationComplex A C1). Proof. use make_Morphism. - intros i. cbn. use compose. + exact (to_BinDirectSums A (C1 (i + 1)) (C2 i)). + exact (to_Pr2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))). + exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). - intros i. exact (RotMorphismInvComm f i). Defined. Definition RotMorphismIsoHomot {C1 C2 : Complex A} (f : Morphism C1 C2) : ComplexHomot A (MappingCone A (MappingConeIn2 A f)) (MappingCone A (MappingConeIn2 A f)). Proof. intros i. cbn. use compose. - exact (to_BinDirectSums A (C1 (i + 1)) (C2 i)). - exact (to_Pr2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))). - use compose. + exact (C2 i). + exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C2 (i - 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))))) (maponpaths C2 (hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C2 (i - 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1)))))). Defined. Lemma RotMorphismIsoEq1 {C1 C2 : Complex A} (f : Morphism C1 C2) : (((RotMorphism f) : (ComplexPreCat_Additive A)⟦_, _⟧) · RotMorphismInv f) = (@identity (ComplexPreCat_Additive A) (TranslationComplex A C1)). Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. exact (to_IdIn1 DS1). Qed. Local Lemma RotMorphismEq2' {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i) in let DS2 := to_BinDirectSums A (C2 (i + 1)) DS1 in to_binop DS2 DS2 (to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr2 DS1 · to_inv (Diff C2 i · to_In1 DS2)) (to_Pr2 DS2 · to_Pr2 DS1 · (to_In2 DS1 · to_In2 DS2))) (to_binop DS2 DS2 (to_Pr1 DS2 · to_In1 DS2) (to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2) (to_Pr2 DS2 · to_Pr2 DS1 · Diff C2 i · to_In1 DS2))) = to_binop DS2 DS2 (to_binop DS2 DS2 (to_Pr1 DS2 · to_In1 DS2) (to_Pr2 DS2 · to_In2 DS2)) (to_inv (to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr1 DS1 · to_inv (f (i + 1)) · to_In1 DS2) (to_Pr2 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2))). Proof. intros DS1 DS2. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite to_assoc. rewrite to_assoc. rewrite <- (to_assoc A _ (to_Pr1 DS2 · to_In1 DS2)). rewrite (to_commax' A _ (to_Pr1 DS2 · to_In1 DS2)). rewrite to_assoc. rewrite <- (to_assoc A _ (to_Pr1 DS2 · to_In1 DS2)). rewrite (to_commax' A _ (to_Pr1 DS2 · to_In1 DS2)). rewrite to_assoc. apply maponpaths. rewrite <- to_binop_inv_comm_2. rewrite <- (to_assoc A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite (to_commax' A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite to_assoc. rewrite <- (to_assoc A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite (to_commax' A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite to_assoc. rewrite <- (to_assoc A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite (to_commax' A _ (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2)). rewrite to_assoc. apply maponpaths. rewrite assoc. rewrite assoc. rewrite (to_commax' A (to_Pr2 DS2 · to_Pr2 DS1 · to_In2 DS1 · to_In2 DS2)). rewrite <- to_assoc. rewrite (@to_linvax' A (Additive.to_Zero _)). rewrite to_lunax''. apply (to_rcan A (to_Pr2 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2)). rewrite <- to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite to_commax'. rewrite (to_BinOpId DS1). rewrite id_right. rewrite <- (@to_runax'' A (Additive.to_Zero A) _ _ (to_Pr2 DS2 · to_In2 DS2)). rewrite to_assoc. rewrite to_assoc. apply maponpaths. rewrite to_lunax''. rewrite assoc. rewrite (@to_linvax' A (Additive.to_Zero _)). apply idpath. Qed. Lemma RotMorphismIsoEq2'_eq {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i) in let DS2 := to_BinDirectSums A (C2 (i + 1)) DS1 in to_binop DS2 DS2 (to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr2 DS1 · to_inv (Diff C2 i · to_In1 DS2)) (to_Pr2 DS2 · to_Pr2 DS1 · (to_In2 DS1 · to_In2 DS2))) (to_binop DS2 DS2 (to_Pr1 DS2 · to_In1 DS2) (to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2) (to_Pr2 DS2 · to_Pr2 DS1 · Diff C2 i · to_In1 DS2))) = to_binop DS2 DS2 (identity DS2) (to_inv (to_Pr2 DS2 · to_Pr1 DS1 · to_binop (C1 (i + 1)) DS2 (to_inv (f (i + 1)) · to_In1 DS2) (to_In1 DS1 · to_In2 DS2))). Proof. intros DS1 DS2. use (pathscomp0 (RotMorphismEq2' f i)). fold DS1 DS2. rewrite (to_BinOpId DS2). apply maponpaths. apply maponpaths. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. apply idpath. Qed. Lemma RotMorphismIsoEq2''_1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : transportf (precategory_morphisms (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus i 1)) (RotMorphismIsoHomot f i · MappingConeDiff A (MappingConeIn2 A f) (i - 1)) = to_binop (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (to_Pr2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) · to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · to_inv (Diff C2 i · to_In1 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))))) (to_Pr2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) · to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · (to_In2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) · to_In2 (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))))). Proof. unfold RotMorphismIsoHomot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS6 := to_BinDirectSums A (C2 (i - 1 + 1 + 1)) DS5). set (DS7 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS8 := to_BinDirectSums A (C2 (i - 1 + 1)) DS7). set (DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS10 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS9). unfold DiffTranslationComplex. rewrite <- to_premor_linear'. rewrite assoc. rewrite transport_target_postcompose. rewrite <- assoc. apply cancel_precomposition. rewrite <- transport_source_precompose. rewrite <- transport_target_postcompose. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite (assoc (to_In1 DS8)). rewrite (assoc (to_In1 DS8)). rewrite (to_IdIn1 DS8). rewrite (to_Unel1' DS8). rewrite id_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_left. rewrite <- transport_target_to_binop. rewrite <- transport_source_to_binop. use maponpaths_12. + rewrite PreAdditive_invlcomp. unfold DS2, DS1, DS6, DS5. set (tmp := transport_hz_double_section_source_target A C2 (λ i0 : hz, (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (λ i0 : hz, to_inv (Diff C2 i0) · (to_In1 (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))))) _ _ (hzrminusplus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite transport_source_target_comm. apply idpath. + unfold DS2, DS1, DS6, DS5. set (tmp := transport_hz_double_section_source_target A C2 (λ i0 : hz, (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (λ i0 : hz, to_In2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) · to_In2 (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) _ _ (hzrminusplus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite transport_source_target_comm. apply idpath. Qed. Lemma RotMorphismIsoEq2''_2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i) in let DS2 := to_BinDirectSums A (C2 (i + 1)) DS1 in let DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) in let DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3 in let DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)) in let DS10 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS9 in transportf (precategory_morphisms DS2) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)) (to_Pr1 DS2 · to_In2 DS3 · (to_Pr2 DS3 · transportf (λ x' : A, A ⟦ x', DS10 ⟧) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 DS10))) = to_Pr1 DS2 · to_In1 DS2. Proof. intros DS1 DS2 DS3 DS4 DS9 DS10. rewrite assoc. rewrite <- (assoc _ (to_In2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite transport_target_postcompose. apply cancel_precomposition. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, C2 (i0 + 1)) (λ i0 : hz, (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (λ i0 : hz, to_In1 (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) _ _ (hzrplusminus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. assert (e2 : maponpaths (λ i0 : hz, C2 (i0 + 1)) (hzrplusminus i 1) = maponpaths C2 (hzrminusplus (i + 1) 1)). { assert (e3 : maponpaths (λ i0 : hz, C2 (i0 + 1)) (hzrplusminus i 1) = maponpaths C2 (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e3. apply maponpaths. apply isasethz. } rewrite e2. apply idpath. Qed. Lemma RotMorphismIsoEq2''_3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i) in let DS2 := to_BinDirectSums A (C2 (i + 1)) DS1 in let DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)) in let DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3 in let DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)) in let DS10 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS9 in transportf (precategory_morphisms DS2) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)) (to_Pr2 DS2 · MappingConeDiff A f i · (to_Pr2 DS3 · transportf (λ x' : A, A ⟦ x', DS10 ⟧) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 DS10))) = to_binop DS2 DS2 (to_Pr2 DS2 · to_Pr1 DS1 · f (i + 1) · to_In1 DS2) (to_Pr2 DS2 · to_Pr2 DS1 · Diff C2 i · to_In1 DS2). Proof. intros DS1 DS2 DS3 DS4 DS9 DS10. rewrite transport_target_postcompose. rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite assoc. rewrite <- to_postmor_linear'. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4 DS9 DS10. rewrite assoc. unfold DiffTranslationComplex. rewrite transport_target_postcompose. rewrite assoc. rewrite to_postmor_linear'. rewrite (to_postmor_linear' _ _ (to_Pr2 DS3)). rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_Unel1' DS3). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite to_lunax''. apply cancel_precomposition. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, C2 (i0 + 1)) (λ i0 : hz, (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (λ i0 : hz, to_In1 (to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) _ _ (hzrplusminus i 1)). cbn beta in tmp. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. assert (e2 : maponpaths (λ i0 : hz, C2 (i0 + 1)) (hzrplusminus i 1) = maponpaths C2 (hzrminusplus (i + 1) 1)). { assert (e3 : maponpaths (λ i0 : hz, C2 (i0 + 1)) (hzrplusminus i 1) = maponpaths C2 (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e3. apply maponpaths. apply isasethz. } rewrite e2. apply idpath. Qed. Lemma RotMorphismIsoEq2'' {C1 C2 : Complex A} (f : Morphism C1 C2) : to_binop ((MappingCone A (MappingConeIn2 A f)) : (ComplexPreCat_Additive A)) ((MappingCone A (MappingConeIn2 A f)) : (ComplexPreCat_Additive A)) (@identity (ComplexPreCat_Additive A) (MappingCone A (MappingConeIn2 A f))) (to_inv ((RotMorphismInv f : (ComplexPreCat_Additive A)⟦_, _⟧) · RotMorphism f)) = ComplexHomotMorphism A (RotMorphismIsoHomot f). Proof. use MorphismEq. intros i. cbn. apply pathsinv0. use (pathscomp0 _ (RotMorphismIsoEq2'_eq f i)). use maponpaths_12. - exact (RotMorphismIsoEq2''_1 f i). - unfold RotMorphismIsoHomot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold DiffTranslationComplex. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C2 (i + 1 + 1)) DS3). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS6 := to_BinDirectSums A (C2 (i - 1 + 1 + 1)) DS5). set (DS7 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS8 := to_BinDirectSums A (C2 (i - 1 + 1)) DS7). set (DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS10 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS9). rewrite to_postmor_linear'. rewrite assoc. rewrite (assoc _ _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite assoc. rewrite (assoc _ _ (to_In2 DS4)). rewrite (assoc _ _ (to_In2 DS4)). rewrite to_postmor_linear'. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite id_right. rewrite to_postmor_linear'. rewrite <- transport_target_to_binop. use maponpaths_12. + exact (RotMorphismIsoEq2''_2 f i). + exact (RotMorphismIsoEq2''_3 f i). Qed. Lemma RotMorphism_is_z_isomorphism_inverses {C1 C2 : Complex A} (f : Morphism C1 C2) : is_inverse_in_precat (# (ComplexHomotFunctor A) (RotMorphism f)) (# (ComplexHomotFunctor A) (RotMorphismInv f)). Proof. use make_is_inverse_in_precat. - rewrite <- functor_comp. rewrite <- (@functor_id _ _ (ComplexHomotFunctor A)). apply maponpaths. exact (RotMorphismIsoEq1 f). - rewrite <- functor_comp. rewrite <- (@functor_id _ _ (ComplexHomotFunctor A)). apply pathsinv0. use ComplexHomotFunctor_rel_mor'. + exact (RotMorphismIsoHomot f). + exact (RotMorphismIsoEq2'' f). Qed. Lemma RotMorphism_is_z_isomorphism {C1 C2 : Complex A} (f : Morphism C1 C2) : is_z_isomorphism (# (ComplexHomotFunctor A) (RotMorphism f)). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) (RotMorphismInv f)). - exact (RotMorphism_is_z_isomorphism_inverses f). Defined. (** Commutativity of the middle square *) Definition RotMorphismCommHomot {C1 C2 : Complex A} (f : Morphism C1 C2) : ComplexHomot A (MappingCone A f) (MappingCone A (MappingConeIn2 A f)). Proof. intros i. cbn. use compose. - exact (C2 i). - exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). - exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C2 (i - 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))))) (maponpaths C2 (hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C2 (i - 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1)))))). Defined. Definition RotMorphismCommMor1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A⟦ (MappingCone A f) i, to_BinDirectSums A (TranslationComplex A C2 (i - 1 + 1)) ((MappingCone A f) (i - 1 + 1)) ⟧. Proof. cbn. use to_binop. - use compose. + exact (C2 i). + exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (C2 (i + 1)). * exact (to_inv (Diff C2 i)). * exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C2 (i - 1 + 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))))) (maponpaths C2 (maponpaths (λ i0 : hz, (i0 + 1)) (hzrminusplus i 1))) (to_In1 (to_BinDirectSums A (C2 (i - 1 + 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1)))))). - use compose. + exact (C2 i). + exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). * exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1)))) (maponpaths C2 (hzrminusplus i 1)) (to_In2 (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))))). * exact (to_In2 (to_BinDirectSums A (C2 (i - 1 + 1 + 1)) (to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))))). Defined. Lemma RotMorphismCommHomot1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : RotMorphismCommHomot f i · MappingConeDiff A (MappingConeIn2 A f) (i - 1) = RotMorphismCommMor1 f i. Proof. unfold RotMorphismCommHomot. unfold MappingConeDiff. cbn. unfold RotMorphismCommMor1. cbn. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS6 := to_BinDirectSums A (C2 (i - 1 + 1 + 1)) DS5). set (DS7 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS8 := to_BinDirectSums A (C2 (i - 1 + 1)) DS7). unfold DiffTranslationComplex. rewrite to_premor_linear'. rewrite to_premor_linear'. use maponpaths_12. - rewrite <- assoc. apply cancel_precomposition. rewrite <- transport_source_precompose. rewrite assoc. rewrite (to_IdIn1 DS8). rewrite id_left. induction (hzrminusplus i 1). apply idpath. - rewrite <- assoc. rewrite <- transport_source_precompose. rewrite assoc. rewrite (to_IdIn1 DS8). rewrite id_left. rewrite <- assoc. rewrite <- transport_source_precompose. rewrite assoc. rewrite (to_Unel1' DS8). rewrite ZeroArrow_comp_left. rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite to_runax''. rewrite <- transport_source_precompose. apply idpath. Qed. Definition RotMorphismCommMor2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A ⟦ to_BinDirectSums A (C1 (i + 1)) (C2 i), to_BinDirectSums A (C2 (i + 1 - 1 + 1)) (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) ⟧. Proof. cbn. use to_binop. - use compose. + exact (C1 (i + 1)). + exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (C2 (i + 1)). * exact (f (i + 1)). * exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C2 (i + 1 - 1 + 1)) (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))))) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 (to_BinDirectSums A (C2 (i + 1 - 1 + 1)) (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)))))). - use compose. + exact (C2 i). + exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (C2 (i + 1)). * exact (Diff C2 i). * exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C2 (i + 1 - 1 + 1)) (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))))) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 (to_BinDirectSums A (C2 (i + 1 - 1 + 1)) (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)))))). Defined. Lemma RotMorphismCommHomot2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : MappingConeDiff A f i · RotMorphismCommHomot f (i + 1) = RotMorphismCommMor2 f i. Proof. unfold RotMorphismCommHomot. unfold MappingConeDiff. cbn. unfold RotMorphismCommMor2. cbn. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS10 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS9). unfold DiffTranslationComplex. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_Unel1' DS3). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. use maponpaths_12. - rewrite assoc. apply idpath. - rewrite assoc. apply idpath. Qed. Lemma RotMorphism_comm' {C1 C2 : Complex A} (f : Morphism C1 C2) : @to_binop (ComplexPreCat_Additive A) (MappingCone A f) (MappingCone A (MappingConeIn2 A f)) (MappingConeIn2 A (MappingConeIn2 A f)) (to_inv (((MappingConePr1 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) · RotMorphism f)) = ComplexHomotMorphism A (RotMorphismCommHomot f). Proof. use MorphismEq. intros i. cbn. apply pathsinv0. use pathscomp0. - exact (to_binop (to_BinDirectSums A (C1 (i + 1)) (C2 i)) (to_BinDirectSums A (C2 (i + 1)) (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (transportf (precategory_morphisms (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus i 1)) (RotMorphismCommMor1 f i)) (transportf (precategory_morphisms (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)) (RotMorphismCommMor2 f i))). - use maponpaths_12. + apply maponpaths. exact (RotMorphismCommHomot1 f i). + apply maponpaths. exact (RotMorphismCommHomot2 f i). - unfold RotMorphismCommMor1, RotMorphismCommMor2. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). set (DS3 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS4 := to_BinDirectSums A (C2 (i - 1 + 1 + 1)) DS3). set (DS5 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS6 := to_BinDirectSums A (C2 (i + 1 - 1 + 1)) DS5). rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- transport_target_to_binop. rewrite <- transport_target_to_binop. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite (to_commax' A _ (to_Pr2 DS1 · Diff C2 i · transportf (precategory_morphisms (C2 (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 DS6)))). rewrite to_assoc. rewrite (to_commax' A (to_Pr2 DS1 · transportf (λ x' : A, A ⟦ x', DS3 ⟧) (maponpaths C2 (hzrminusplus i 1)) (to_In2 DS3) · transportf (precategory_morphisms DS3) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus i 1)) (to_In2 DS4))). rewrite <- to_assoc. rewrite <- to_assoc. rewrite to_assoc. rewrite <- (@to_lunax'' A (Additive.to_Zero A) _ _ (to_binop DS1 DS2 (to_In2 DS2) (to_inv (to_binop DS1 DS2 (to_Pr1 DS1 · to_inv (f (i + 1)) · to_In1 DS2) (to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2))))). use maponpaths_12. + rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite PreAdditive_invrcomp. rewrite <- to_premor_linear'. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (to_Pr2 DS1 · Diff C2 i)). apply cancel_precomposition. unfold DS2. unfold DS1. rewrite <- (@to_linvax' A (Additive.to_Zero A) _ _ ((transportf (precategory_morphisms (C2 (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C2 (i0 + 1)) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C2 (hzrminusplus (i + 1) 1)) (to_In1 DS6))))). apply maponpaths_2, maponpaths. unfold DS4, DS3, DS6, DS5. set (tmp := @transport_hz_to_In1 A (λ i0 : hz, C2 (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus i 1)). cbn in tmp. assert (e : (maponpaths C2 (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1))) = (maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrminusplus i 1))). { induction (hzrminusplus i 1). apply idpath. } cbn in e. rewrite e. clear e. use (pathscomp0 (! tmp)). clear tmp. set (tmp := @transport_hz_to_In1 A (λ i0 : hz, C2 (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)). cbn in tmp. use (pathscomp0 tmp). clear tmp. apply maponpaths. assert (e : (maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrplusminus i 1)) = (maponpaths C2 (hzrminusplus (i + 1) 1))). { assert (e' : maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrplusminus i 1) = maponpaths C2 (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e'. apply maponpaths. apply isasethz. } rewrite e. apply idpath. + rewrite <- to_binop_inv_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite inv_inv_eq. rewrite <- to_assoc. rewrite (to_commax' A (to_In2 DS2)). rewrite to_assoc. use maponpaths_12. * apply cancel_precomposition. set (tmp := @transport_hz_to_In1 A (λ i0 : hz, C2 (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)). cbn in tmp. unfold DS2, DS1. use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. unfold DS6, DS5. assert (e : (maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrplusminus i 1)) = (maponpaths C2 (hzrminusplus (i + 1) 1))). { assert (e' : (maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrplusminus i 1)) = (maponpaths C2 (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrplusminus i 1)))). { induction (hzrplusminus i 1). apply idpath. } rewrite e'. apply maponpaths. apply isasethz. } rewrite e. apply idpath. * assert (e : to_binop DS1 DS2 (to_In2 DS2) (to_inv (to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2)) = to_binop DS1 DS2 (identity _ · to_In2 DS2) (to_inv (to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2))). { rewrite id_left. apply idpath. } rewrite e. clear e. rewrite <- (to_BinOpId DS1). rewrite to_postmor_linear'. rewrite to_commax'. rewrite <- to_assoc. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. unfold DS4, DS3, DS2, DS1. induction (hzrminusplus i 1). apply idpath. Qed. Lemma RotMorphism_comm {C1 C2 : Complex A} (f : Morphism C1 C2) : # (ComplexHomotFunctor A) (((MappingConePr1 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) · RotMorphism f) = # (ComplexHomotFunctor A) (MappingConeIn2 A (MappingConeIn2 A f)). Proof. apply pathsinv0. use ComplexHomotFunctor_rel_mor'. - exact (RotMorphismCommHomot f). - exact (RotMorphism_comm' f). Qed. Lemma RotMorphism_comm2 {C1 C2 : Complex A} (f : Morphism C1 C2) : to_inv (# (TranslationFunctor A) f) = (RotMorphism f : (ComplexPreCat_Additive A)⟦_, _⟧) · MappingConePr1 A (MappingConeIn2 A f). Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C2 (i + 1)) DS1). rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 DS2). rewrite id_right. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply idpath. Qed. End rotation_mapping_cone. (** * Inverse rotation *) (** ** Introduction We prove results that are needed to prove that inverse rotation of a distinguished triangle in K(A) is a distinguished triangle. More precisely, we construct h in the following diagram C(f)[-1] --> X -->C(-p1[-1])--> C(f) | | h | | C(f)[-1] --> X --> Y --> C(f) here p1[-1] : C(f)[-1] --> X is the first projection. Also, we show that h is an isomorphism in K(A) and that the above diagram is commutative in K(A). *) Section inv_rotation_mapping_cone. Variable A : CategoryWithAdditiveStructure. Definition InvRotMorphismMor {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A ⟦ (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))) i, C2 i ⟧. Proof. cbn. use to_binop. + use compose. * exact (C1 i). * exact (to_Pr2 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). * exact (f i). + use compose. * exact (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). * exact (to_Pr1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). * exact (transportf (precategory_morphisms _) (maponpaths C2 (hzrplusminus i 1)) (to_Pr2 (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))))). Defined. Lemma InvRotMorphismComm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : InvRotMorphismMor f i · Diff C2 i = MappingConeDiff A (MorphismComp (MorphismOp_inv A (InvTranslationMorphism A (MappingCone A f) (TranslationComplex A C1) (MappingConePr1 A f))) (TranslationEquivUnitInv A C1)) i · InvRotMorphismMor f (i + 1). Proof. unfold InvRotMorphismMor. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold DiffTranslationComplex. unfold InvTranslationComplex. cbn. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold DiffTranslationComplex. unfold InvTranslationComplex. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1))). set (DS4 := to_BinDirectSums A DS3 (C1 (i + 1))). set (DS5 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1 - 1 + 1))). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_Unel2' DS4). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_runax''. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_target_to_inv. rewrite inv_inv_eq. rewrite <- transport_target_postcompose. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_target_to_inv. rewrite <- to_assoc. rewrite to_commax'. rewrite <- (assoc _ (Diff C1 i)). rewrite <- (MComm f i). rewrite assoc. use maponpaths_12. - rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- transport_target_to_binop. rewrite PreAdditive_invrcomp. rewrite PreAdditive_invrcomp. rewrite transport_target_postcompose. rewrite <- transport_target_to_binop. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- (assoc (to_Pr1 DS2)). rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. rewrite <- (assoc (to_Pr1 DS2)). rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite <- to_assoc. rewrite (to_commax' A _ (((to_Pr2 DS1) · (Diff C2 (i + 1 - 1)) · (transportf (precategory_morphisms (C2 (i + 1 - 1 + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) (to_In2 DS5))))). rewrite to_postmor_linear'. rewrite to_assoc. set (tmp := @to_runax'' A (Additive.to_Zero A) _ _ (transportf (precategory_morphisms DS1) (maponpaths C2 (hzrplusminus i 1)) (to_Pr2 DS1) · Diff C2 i)). use (pathscomp0 (! tmp)). clear tmp. use maponpaths_12. + rewrite transport_compose. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite assoc. rewrite <- transport_target_postcompose. rewrite <- maponpathsinv0. set (tmp := transport_hz_section A C2 1 (Diff C2) _ _ (hzrplusminus i 1)). use (pathscomp0 (! tmp)). clear tmp. apply pathsinv0. rewrite transport_target_postcompose. rewrite transport_compose. rewrite <- (id_right (Diff C2 (i + 1 - 1))). rewrite transport_target_postcompose. rewrite id_right. rewrite <- assoc. apply cancel_precomposition. rewrite <- (to_IdIn2 DS5). rewrite transport_target_postcompose. apply cancel_precomposition. assert (e : ! (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))). { rewrite maponpathsinv0. apply idpath. } rewrite e. clear e. unfold DS5. set (tmp := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1 - 1 + 1 + 1)) (C2 (i0 + 1 - 1 + 1))) (λ (i0 : hz), C2 (i0 + 1 - 1 + 1)) (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1 + 1)) (C2 (i0 + 1 - 1 + 1)))) _ _ (! (hzrplusminus i 1))). cbn in tmp. set (e1 := maponpaths C2 (maponpaths_2 _ (hzrplusminus i 1) _)). set (e2 := maponpaths (λ i0 : pr1 hz, C2 (i0 + 1 - 1 + 1)) (! hzrplusminus i 1)). cbn in e1, e2. set (tmp' := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) C2 (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (maponpaths_2 hzplus (hzrplusminus i 1) 1)). cbn in tmp'. unfold e1. use (pathscomp0 _ (! tmp')). clear tmp'. unfold DS3. set (tmp' := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) C2 (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus (i + 1) 1)). cbn in tmp'. rewrite tmp'. clear tmp'. rewrite transport_f_f. assert (e : (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrplusminus (i + 1) 1) @ @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! maponpaths_2 _ (hzrplusminus i 1) _)). { set (tmp' := @maponpathscomp0 _ _ _ _ _ (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) (! hzrplusminus (i + 1) 1) (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))). use (pathscomp0 (! tmp')). clear tmp'. apply maponpaths. apply isasethz. } cbn in e. cbn. rewrite e. clear e. apply idpath. + rewrite to_postmor_linear'. rewrite to_assoc. rewrite to_commax'. rewrite <- (@to_runax'' A (Additive.to_Zero A) _ _ (ZeroArrow (Additive.to_Zero A) DS1 (C2 (i + 1)))). use maponpaths_12. * rewrite <- PreAdditive_invlcomp. assert (e : (to_Pr1 DS1 · f (i + 1 - 1 + 1) · transportf (precategory_morphisms (C2 (i + 1 - 1 + 1))) (@maponpaths hz A(λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) (to_In2 DS5) · transportf (precategory_morphisms DS3) (maponpaths C2 (hzrplusminus (i + 1) 1)) (to_Pr2 DS3)) = (transportf (precategory_morphisms DS1) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_Pr1 DS1) · f (i + 1))). { rewrite transport_compose. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := transport_hz_double_section A C1 C2 f _ _ (hzrminusplus (i + 1) 1)). rewrite <- maponpathsinv0. use (pathscomp0 _ tmp). clear tmp. rewrite <- (id_right (f (i + 1 - 1 + 1))). rewrite transport_target_postcompose. rewrite id_right. apply cancel_precomposition. rewrite <- (to_IdIn2 DS5). rewrite transport_target_postcompose. rewrite transport_compose. apply cancel_precomposition. assert (e : ! (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))). { rewrite maponpathsinv0. apply idpath. } rewrite e. clear e. unfold DS5. set (tmp' := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) C2 (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus (i + 1) 1)). cbn in tmp'. use (pathscomp0 _ (! tmp')). clear tmp'. unfold DS3. set (tmp' := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) C2 (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus (i + 1) 1)). cbn in tmp'. cbn. cbn in tmp'. rewrite tmp'. clear tmp'. rewrite transport_f_f. assert (e : (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrplusminus (i + 1) 1) @ @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrminusplus (i + 1) 1)). { set (tmp' := @maponpathscomp0 _ _ _ _ _ (λ i0 : pr1 hz, BinDirectSumOb (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) (! hzrplusminus (i + 1) 1) (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))). use (pathscomp0 (! tmp')). clear tmp'. apply maponpaths. apply isasethz. } cbn in e. cbn. rewrite e. clear e. apply idpath. } apply (maponpaths (λ g : _, to_binop _ _ g (to_inv (transportf (precategory_morphisms DS1) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_Pr1 DS1) · f (i + 1))))) in e. use (pathscomp0 _ (! e)). clear e. rewrite (@to_rinvax' A (Additive.to_Zero A)). apply idpath. * rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (to_Pr1 DS1 · Diff C1 (i + 1 - 1 + 1))). rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. rewrite transport_compose. rewrite <- PreAdditive_invlcomp. rewrite <- to_inv_zero. apply maponpaths. set (DS6 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1))). rewrite <- (to_Unel1' DS6). rewrite <- transport_compose. unfold DS3. set (tmp' := transport_hz_double_section A (λ (i0 : hz), to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) C2 (λ (i0 : hz), to_Pr2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus (i + 1) 1)). cbn in tmp'. rewrite tmp'. clear tmp'. rewrite transport_compose. rewrite transport_f_f. set (e := @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus (i + 1) 1)). cbn in e. unfold DS6. unfold DS5. set (e' := @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1)). cbn in e'. set (tmp := @transport_compose' A _ _ _ _ (to_In1 (to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1)))) (to_Pr2 (to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1)))) (! e')). use (pathscomp0 (! tmp)). clear tmp. fold DS5 DS6. clear e. assert (e : transportf (precategory_morphisms (C1 (i + 1 - 1 + 1 + 1))) (! e') (to_In1 DS6) = to_In1 DS5). { unfold e'. unfold DS6, DS5. induction (hzrminusplus (i + 1) 1). apply idpath. } apply (maponpaths (postcompose (transportf (λ x' : A, A ⟦ x', C2 (i + 1) ⟧) (! e') (to_Pr2 DS6)))) in e. use (pathscomp0 e). clear e. unfold postcompose. apply cancel_precomposition. unfold e'. clear e'. unfold DS6. set (e1 := (! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1))). set (e2 := (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrplusminus (i + 1) 1) @ ! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))). cbn in e1, e2. induction (hzrminusplus (i + 1) 1). cbn. fold DS5. clear e1 e2. assert (e : (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrplusminus (i + 1 - 1 + 1) 1) @ ! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (! hzrplusminus (i + 1 - 1 + 1) 1)) = idpath _). { rewrite maponpathsinv0. rewrite <- pathscomp_inv. rewrite pathsinv0l. apply idpath. } apply (maponpaths (λ g : _, transportf (λ x : A, A ⟦ x, C2 (i + 1 - 1 + 1) ⟧) g (to_Pr2 DS5))) in e. use (pathscomp0 _ (! e)). apply idpath. - apply idpath. Qed. Definition InvRotMorphism {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))) C2. Proof. use make_Morphism. - intros i. exact (InvRotMorphismMor f i). - intros i. exact (InvRotMorphismComm f i). Defined. (** Commutativity of the middle square *) Lemma InvRotMorphismComm2 {C1 C2 : Complex A} (f : Morphism C1 C2 ) : ((MappingConeIn2 A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1)) : (ComplexPreCat_Additive A)⟦_, _⟧)) · InvRotMorphism f = f. Proof. use MorphismEq. intros i. cbn. unfold InvRotMorphismMor. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS2). rewrite id_left. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_left. rewrite to_runax''. apply idpath. Qed. (** Commutativity of the right square *) Definition InvRotMorphismComm3Homot {C1 C2 : Complex A} (f : Morphism C1 C2 ) : ComplexHomot A (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))) (MappingCone A f). Proof. intros i. cbn. use compose. - exact (C1 i). - exact (to_Pr2 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). - exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1)))) (maponpaths C1 (hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))))). Defined. Lemma InvRotMorphismComm3' {C1 C2 : Complex A} (f : Morphism C1 C2) : MorphismOp A (MorphismComp (InvRotMorphism f) (MappingConeIn2 A f)) (MorphismOp_inv A (MorphismComp (MappingConePr1 A (MorphismComp (MorphismOp_inv A (InvTranslationMorphism A (MappingCone A f) (TranslationComplex A C1) (MappingConePr1 A f))) (TranslationEquivUnitInv A C1))) (InvTranslationTranslationNatTrans_Mor A (MappingCone A f)))) = ComplexHomotMorphism A (InvRotMorphismComm3Homot f). Proof. use MorphismEq. intros i. cbn. unfold InvRotMorphismMor. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold InvRotMorphismComm3Homot. unfold DiffTranslationComplex. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). set (DS3 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS4 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS6 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1))). set (DS7 := to_BinDirectSums A DS6 (C1 (i + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite id_right. rewrite id_right. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite (to_Unel1' DS4). rewrite (to_IdIn1 DS4). rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ _ (to_Pr2 DS7)). rewrite <- (assoc _ _ (to_Pr2 DS7)). rewrite (to_Unel1' DS7). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite (to_IdIn2 DS7). rewrite id_right. rewrite <- (assoc _ _ (to_Pr2 DS7)). rewrite (to_IdIn2 DS7). rewrite id_right. rewrite <- (assoc _ _ (to_inv (Diff C1 (i - 1 + 1)))). rewrite <- transport_source_precompose. rewrite id_left. rewrite <- (assoc _ _ (f (i - 1 + 1))). rewrite <- transport_source_precompose. rewrite id_left. rewrite <- transport_target_to_binop. rewrite <- transport_target_to_binop. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. cbn. rewrite (to_commax' A _ ((to_Pr2 DS2 · transportf (λ x' : A, A ⟦ x', C2 (i - 1 + 1) ⟧) (maponpaths C1 (hzrminusplus i 1)) (f (i - 1 + 1)) · transportf (precategory_morphisms (C2 (i - 1 + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus i 1)) (to_In2 DS5)))). rewrite to_assoc. rewrite to_assoc. use maponpaths_12. - rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := @transport_hz_double_section A C1 C2 f _ _ (! hzrminusplus i 1)). rewrite pathsinv0inv0 in tmp. rewrite <- tmp. clear tmp. rewrite transport_compose. apply cancel_precomposition. rewrite maponpathsinv0. rewrite pathsinv0inv0. unfold DS3, DS5. induction (hzrminusplus i 1). apply idpath. - rewrite <- transport_target_to_inv. rewrite <- transport_source_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite (to_commax' A _ (to_Pr2 DS2 · Diff C1 i · transportf (precategory_morphisms (C1 (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_In1 DS1)))). rewrite <- to_assoc. assert (e : (to_Pr2 DS2 · transportf (λ x' : A, A ⟦ x', C1 (i - 1 + 1 + 1) ⟧) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1 + 1)) · transportf (precategory_morphisms (C1 (i - 1 + 1 + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus i 1)) (to_In1 DS5)) = (to_Pr2 DS2 · Diff C1 i · transportf (precategory_morphisms (C1 (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_In1 DS1)))). { rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := @transport_hz_section A C1 1 (Diff C1) _ _ (! hzrminusplus i 1)). rewrite pathsinv0inv0 in tmp. rewrite <- tmp. clear tmp. rewrite transport_compose. apply cancel_precomposition. rewrite transport_source_target_comm. unfold DS5. unfold DS1. rewrite <- maponpathsinv0. assert (e : maponpaths C1 (! maponpaths_2 hzplus (! hzrminusplus i 1) 1) = maponpaths C1 (maponpaths_2 hzplus (hzrminusplus i 1) 1)). { apply maponpaths. apply isasethz. } rewrite e. clear e. set (tmp := @transport_hz_double_section_source_target A (λ i0 : hz, C1 (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus i 1)). cbn in tmp. assert (e : maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrminusplus i 1) = maponpaths C1 (maponpaths_2 _ (hzrminusplus i 1) _)). { induction (hzrminusplus i 1). apply idpath. } rewrite e in tmp. clear e. use (pathscomp0 (! tmp)). clear tmp. set (tmp := @transport_hz_double_section_source_target A (λ i0 : hz, C1 (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrplusminus i 1)). cbn in tmp. use (pathscomp0 tmp). clear tmp. apply maponpaths. assert (e : maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrplusminus i 1) = maponpaths C1 (hzrminusplus (i + 1) 1)). { assert (e' : maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrplusminus i 1) = maponpaths C1 (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e'. apply maponpaths. apply isasethz. } rewrite e. apply idpath. } apply (maponpaths (λ g : _, to_binop DS2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) (to_inv (to_Pr2 DS2 · transportf (λ x' : A, A ⟦ x', C1 (i - 1 + 1 + 1) ⟧) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1 + 1)) · transportf (precategory_morphisms (C1 (i - 1 + 1 + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus i 1)) (to_In1 DS5))) g)) in e. apply (maponpaths (λ g : _, to_binop DS2 (to_BinDirectSums A (C1 (i + 1)) (C2 i)) g ((to_inv ((to_Pr1 DS2) · (transportf (precategory_morphisms DS1) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_Pr1 DS1)) · transportf (precategory_morphisms (C1 (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)) (transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_In1 DS1))))))) in e. use (pathscomp0 _ e). clear e. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite <- (id_right (to_Pr1 DS2)). rewrite transport_target_postcompose. rewrite PreAdditive_invrcomp. rewrite id_right. rewrite <- assoc. rewrite <- assoc. rewrite PreAdditive_invrcomp. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite to_binop_inv_comm_2. apply maponpaths. rewrite <- (to_BinOpId DS1). rewrite (to_commax' A (to_Pr1 DS1 · to_In1 DS1) _). rewrite <- transport_target_to_binop. rewrite <- to_assoc. assert (e : transportf (precategory_morphisms DS1) (maponpaths C2 (hzrplusminus i 1)) (to_Pr2 DS1) · to_In2 DS3 = (transportf (precategory_morphisms DS1) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)) (to_Pr2 DS1 · to_In2 DS1))). { rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. unfold DS1, DS3. induction (hzrplusminus i 1). apply idpath. } cbn in e. rewrite e. clear e. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. rewrite transport_source_target_comm. apply maponpaths. rewrite <- maponpathsinv0. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite pathsinv0r. apply idpath. Qed. Lemma InvRotMorphismComm3 {C1 C2 : Complex A} (f : Morphism C1 C2) : # (ComplexHomotFunctor A) (((InvRotMorphism f) : (ComplexPreCat_Additive A)⟦_, _⟧) · (MappingConeIn2 A f)) = # (ComplexHomotFunctor A) (((MappingConePr1 A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))) : (ComplexPreCat_Additive A)⟦_, _⟧) · (AddEquivCounitIso (TranslationEquiv A) (MappingCone A f))). Proof. use ComplexHomotFunctor_rel_mor'. - exact (InvRotMorphismComm3Homot f). - exact (InvRotMorphismComm3' f). Qed. Definition InvRotMorphismMorInv {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A ⟦ C2 i, to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i) ⟧. Proof. use compose. - exact (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). - exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)))) (maponpaths C2 (hzrplusminus i 1)) (to_In2 (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))))). - exact (to_In1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). Defined. Lemma InvRotMorphismMorInvComm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (InvRotMorphismMorInv f i) · (MappingConeDiff A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1)) i) = Diff C2 i · InvRotMorphismMorInv f (i + 1). Proof. unfold InvRotMorphismMorInv. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold DiffTranslationComplex. unfold InvTranslationComplex. cbn. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold DiffTranslationComplex. unfold InvTranslationComplex. cbn. unfold InvRotMorphismMorInv. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1))). set (DS4 := to_BinDirectSums A DS3 (C1 (i + 1))). set (DS5 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1 - 1 + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_Unel1' DS2). rewrite (to_IdIn1 DS2). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite (to_Unel2' DS1). rewrite to_inv_zero. rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_to_inv. rewrite <- transport_source_to_inv. rewrite inv_inv_eq. rewrite transport_source_precompose. apply cancel_postcomposition. rewrite <- transport_target_postcompose. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invrcomp. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS1). rewrite id_left. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_inv_zero. rewrite to_lunax''. rewrite to_lunax''. rewrite transport_target_postcompose. rewrite transport_source_precompose. set (tmp := @transport_compose' A _ _ _ _ (Diff C2 i) (transportf (λ x' : A, A ⟦ x', DS3 ⟧) (maponpaths C2 (hzrplusminus (i + 1) 1)) (to_In2 DS3)) (maponpaths C2 (! hzrminusplus (i + 1) 1))). use (pathscomp0 _ tmp). clear tmp. set (tmp := transport_hz_section A C2 1 (Diff C2) _ _ (! hzrplusminus i 1)). assert (e : maponpaths C2 (maponpaths_2 _ (! hzrplusminus i 1) _) = maponpaths C2 (! hzrminusplus (i + 1) 1)). { apply maponpaths. apply isasethz. } rewrite <- e. clear e. rewrite tmp. clear tmp. rewrite pathsinv0inv0. apply cancel_precomposition. rewrite transport_f_f. unfold DS5, DS3. rewrite <- maponpathscomp0. set (tmp := @transport_hz_double_section A C2 (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, to_In2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)). cbn in tmp. use (pathscomp0 tmp). assert (e : (maponpaths C2 (! (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1))) = (maponpaths C2 (hzrplusminus (i + 1) 1 @ maponpaths_2 _ (! hzrplusminus i 1) _))). { apply maponpaths. apply isasethz. } cbn in e. rewrite e. clear e. apply idpath. Qed. Definition InvRotMorphismInv {C1 C2 : Complex A} (f : Morphism C1 C2) : Morphism C2 (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))). Proof. use make_Morphism. - intros i. exact (InvRotMorphismMorInv f i). - intros i. exact (InvRotMorphismMorInvComm f i). Defined. Lemma InvRotMorphism_is_iso_with_inv_eq1 {C1 C2 : Complex A} (f : Morphism C1 C2) : # (ComplexHomotFunctor A) (((InvRotMorphismInv f) : (ComplexPreCat_Additive A)⟦_, _⟧) · InvRotMorphism f) = # (ComplexHomotFunctor A) (identity (C2 : (ComplexPreCat_Additive A))). Proof. apply maponpaths. unfold InvRotMorphismInv. unfold InvRotMorphism. use MorphismEq. intros i. cbn. unfold InvRotMorphismMorInv. unfold InvRotMorphismMor. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). rewrite to_premor_linear'. rewrite assoc. rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite assoc. rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_IdIn1 DS2). rewrite id_right. induction (hzrplusminus i 1). cbn. exact (to_IdIn2 DS1). Qed. Definition InvRotMorphismIsoHomot {C1 C2 : Complex A} (f : Morphism C1 C2) : ComplexHomot A (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))) (MappingCone A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1))). Proof. intros i. cbn. use compose. - exact (C1 i). - exact (to_Pr2 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). - use compose. + exact (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))). + exact (transportf (λ x' : ob A, precategory_morphisms x' (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1)))) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))))). + exact (to_In1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))) (C1 (i - 1)))). Defined. Local Lemma InvRotMorphismIso'_eq2_1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)) in let DS2 := to_BinDirectSums A DS1 (C1 i) in let DS3 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1)) in let DS4 := to_BinDirectSums A DS3 (C1 (i - 1)) in let DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 + 1 - 1)) in let DS6 := to_BinDirectSums A DS5 (C1 (i - 1 + 1)) in let DS7 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1)) in let DS8 := to_BinDirectSums A DS7 (C1 (i + 1)) in let DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 - 1 + 1)) (C2 (i + 1 - 1 + 1 - 1)) in let DS10 := to_BinDirectSums A DS9 (C1 (i + 1 - 1)) in let DS11 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1 + 1)) (C2 (i - 1 + 1 - 1 + 1)) in to_inv (transportf (precategory_morphisms (C1 i)) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1)) (Diff C1 i · (transportf (λ x' : A, A ⟦ x', DS9 ⟧) (maponpaths C1 (hzrminusplus (i + 1 - 1 + 1) 1 @ hzrminusplus (i + 1) 1)) (to_In1 DS9) · to_In1 DS10))) = to_inv (transportf (precategory_morphisms (C1 i)) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) (Diff C1 (i - 1 + 1 - 1 + 1) · to_In1 DS11 · transportf (λ x' : A, A ⟦ x', DS6 ⟧) (! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i - 1 + 1) 1 @ ! hzrplusminus (i - 1 + 1) 1)) (to_In1 DS6)))). Proof. intros DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8 DS9 DS10 DS11. cbn. apply maponpaths. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_source_precompose. rewrite transport_source_precompose. rewrite transport_target_postcompose. set (tmp := @transport_hz_section A C1 1 (Diff C1) _ _ (! (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1))). rewrite pathsinv0inv0 in tmp. cbn in tmp. rewrite <- tmp. clear tmp. rewrite transport_compose. rewrite <- assoc. apply cancel_precomposition. assert (e : (! maponpaths C1 (maponpaths_2 hzplus (! (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) 1)) = maponpaths C1 (maponpaths_2 _ (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1) _)). { rewrite <- maponpathsinv0. apply maponpaths. apply isasethz. } cbn in e. rewrite e. clear e. set (tmp := @transport_hz_double_section A (λ i0 : pr1 hz, C1 (i0 + 1)) (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : pr1 hz, to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (! (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1))). cbn in tmp. unfold DS11. cbn. rewrite pathsinv0inv0 in tmp. assert (e : (maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) = maponpaths C1 (maponpaths_2 _ (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1) _)). { induction (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1). apply idpath. } cbn in e. rewrite e in tmp. clear e. rewrite <- tmp. clear tmp. rewrite transport_compose. rewrite transport_source_target_comm. rewrite transport_f_f. set (tmp := @transport_hz_double_section A (λ i0 : pr1 hz, C1 (i0 + 1)) (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : pr1 hz, to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (! (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1))). rewrite pathsinv0inv0 in tmp. unfold DS9. assert (e : (maponpaths C1 (hzrminusplus (i + 1 - 1 + 1) 1 @ hzrminusplus (i + 1) 1)) = (maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1))). { assert (e' : maponpaths (λ i0 : pr1 hz, C1 (i0 + 1)) (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1) = maponpaths C1 (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1))). { induction (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1). apply idpath. } rewrite e'. apply maponpaths. apply isasethz. } cbn in e. rewrite e. clear e. cbn. cbn in tmp. rewrite <- tmp. clear tmp. rewrite transport_compose. apply cancel_precomposition. rewrite transport_source_target_comm. rewrite maponpathsinv0. rewrite pathsinv0inv0. rewrite maponpathsinv0. rewrite pathsinv0inv0. assert (e : (! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i - 1 + 1) 1 @ ! hzrplusminus (i - 1 + 1) 1) @ @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) = (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus (i - 1 + 1) 1 @ hzrminusplus i 1))). { rewrite maponpathscomp0. rewrite pathscomp_inv. rewrite maponpathsinv0. rewrite pathsinv0inv0. rewrite maponpathscomp0. rewrite maponpathscomp0. rewrite path_assoc. rewrite <- (path_assoc _ _ (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i - 1 + 1) 1))). rewrite pathsinv0l. rewrite pathscomp0rid. apply idpath. } apply (maponpaths (λ ee : _, transportf (precategory_morphisms (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) ee (to_In1 DS6)))) in e. use (pathscomp0 _ (! e)). clear e. assert (e : (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus (i - 1 + 1) 1 @ hzrminusplus i 1)) (to_In1 DS6)) = (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus (i - 1 + 1) 1)) (to_In1 DS6)))). { rewrite transport_f_f. rewrite maponpathscomp0. apply idpath. } apply (maponpaths (λ ee : _, transportf (precategory_morphisms (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)) ee)) in e. use (pathscomp0 _ (! e)). clear e. set (m1 := to_In1 DS2). unfold DS2, DS1 in m1. set (e := @maponpaths hz A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrplusminus i 1)). cbn in e. apply pathsinv0. use pathscomp0. - exact (transportf (λ x' : ob A, precategory_morphisms x' _) e (to_In1 DS2)). - unfold DS10, DS9, DS6, DS5, DS2, DS1. unfold e. induction (hzrminusplus i 1). cbn. apply idpath. - unfold DS10, DS9, DS6, DS5, DS2, DS1. unfold e. clear e. set (tmp := @transport_hz_to_In1' A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, C1 i) _ _ (hzrplusminus i 1)). cbn in tmp. use (pathscomp0 (! tmp)). clear tmp. set (e := (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1))). cbn in e. use transport_target_path. + exact (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1 - 1 + 1)) (C2 (i + 1 - 1 + 1 - 1))) (C1 (i + 1 - 1))). + exact (! e). + unfold e. rewrite transport_f_f. rewrite transport_f_f. rewrite pathsinv0r. cbn. set (tmp := @transport_hz_to_In1' A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, C1 (i + 1 - 1)) _ _ (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1)). cbn in tmp. use (pathscomp0 _ tmp). clear tmp. clear e. clear m1. assert (e : @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 i)) _ _ (! hzrplusminus i 1) @ ! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1) = ! (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1) @ @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 i0)) _ _ (hzrplusminus i 1))). { rewrite maponpathsinv0. rewrite <- pathscomp_inv. apply maponpaths. set (tmp := @transport_to_BinDirectSums A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (λ i0 : hz, C1 i0) _ _ (hzrplusminus i 1)). cbn in tmp. apply (maponpaths (λ g : _, g @ @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 i)) _ _ (hzrplusminus i 1))) in tmp. cbn in tmp. use (pathscomp0 tmp). clear tmp. rewrite <- path_assoc. set (tmp := @transport_to_BinDirectSums_comm A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, C1 i0) _ _ (hzrplusminus i 1)). cbn in tmp. apply (maponpaths (λ g : _, @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1)@ g)) in tmp. use (pathscomp0 (! tmp)). clear tmp. apply maponpaths. set (tmp := @transport_to_BinDirectSums A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, C1 i0) _ _ (hzrplusminus i 1)). cbn in tmp. exact (! tmp). } cbn in e. rewrite e. clear e. rewrite pathscomp_inv. rewrite <- transport_f_f. set (tmp := @transport_to_BinDirectSums A (λ i0 : hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : hz, C1 i0) _ _ (hzrplusminus i 1)). cbn in tmp. rewrite tmp. clear tmp. rewrite pathscomp_inv. rewrite <- transport_f_f. assert (e : transportf (precategory_morphisms (to_BinDirectSums A (C1 (i + 1)) (C2 i))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1)) (C2 i)) (C1 i0)) _ _ (! hzrplusminus i 1)) (to_In1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1)) (C2 i)) (C1 i))) = (to_In1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1)) (C2 i)) (C1 (i + 1 - 1))))). { induction (hzrplusminus i 1). apply idpath. } rewrite maponpathsinv0 in e. cbn in e. rewrite e. clear e. rewrite transport_f_f. assert (e : (! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1) @ ! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1)) = (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (! (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1)))). { rewrite <- pathscomp_inv. assert (e' : @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (! (hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1)) = ! @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ ((hzrplusminus (i + 1 - 1) 1 @ hzrplusminus i 1))). { rewrite maponpathsinv0. apply idpath. } use (pathscomp0 _ (! e')). clear e'. apply maponpaths. rewrite maponpathscomp0. assert (e' : @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (hzrplusminus (i + 1 - 1) 1)). { assert (e'' : @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1) = @maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (maponpaths (λ i1 : hz, i1 + 1 - 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e''. clear e''. apply maponpaths. apply isasethz. } apply (maponpaths (λ g : _, g @ (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (C1 (i + 1 - 1))) _ _ (hzrplusminus i 1)))) in e'. exact e'. } cbn in e. rewrite e. apply idpath. Qed. Lemma InvRotMorphismIso'_eq2_2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1)) in let DS2 := to_BinDirectSums A DS1 (C1 i) in let DS3 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1)) in let DS4 := to_BinDirectSums A DS3 (C1 (i - 1)) in let DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 + 1 - 1)) in let DS6 := to_BinDirectSums A DS5 (C1 (i - 1 + 1)) in let DS7 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1)) in let DS8 := to_BinDirectSums A DS7 (C1 (i + 1)) in let DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 - 1 + 1)) (C2 (i + 1 - 1 + 1 - 1)) in let DS10 := to_BinDirectSums A DS9 (C1 (i + 1 - 1)) in let DS11 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1 + 1)) (C2 (i - 1 + 1 - 1 + 1)) in to_inv (to_Pr2 DS2 · (f i · transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C2 (hzrplusminus i 1)) (to_In2 DS1) · to_In1 DS2)) = to_binop DS2 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i)) (to_inv (to_Pr2 DS2 · transportf (precategory_morphisms (C1 i)) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) (transportf (precategory_morphisms (C1 (i - 1 + 1 - 1 + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) _ _ (hzrminusplus (i - 1 + 1) 1 @ ! hzrplusminus (i - 1 + 1) 1)) (to_binop (C1 (i - 1 + 1 - 1 + 1)) DS11 (to_inv (Diff C1 (i - 1 + 1 - 1 + 1)) · to_In1 DS11) (f (i - 1 + 1 - 1 + 1) · to_In2 DS11)) · to_In1 DS6)))) (to_inv (to_Pr2 DS2 · Diff C1 i · transportf (λ x' : A, A ⟦ x', DS9 ⟧) (maponpaths C1 (hzrminusplus (i + 1 - 1 + 1) 1 @ hzrminusplus (i + 1) 1)) (to_In1 DS9) · transportf (precategory_morphisms DS9) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1)) (to_In1 DS10))). Proof. intros DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8 DS9 DS10 DS11. cbn. rewrite to_binop_inv_inv. apply maponpaths. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite transport_compose. rewrite to_postmor_linear'. rewrite <- transport_source_to_binop. rewrite <- transport_target_to_binop. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite to_assoc. rewrite to_commax'. rewrite to_assoc. use (pathscomp0 (! (@to_runax'' A (Additive.to_Zero A) _ _ (f i · (transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C2 (hzrplusminus i 1)) (to_In2 DS1) · to_In1 DS2))))). use maponpaths_12. - rewrite <- transport_compose. rewrite transport_source_precompose. use (transport_target_path _ _ (! (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)))). rewrite transport_f_f. rewrite pathsinv0r. cbn. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_source_precompose. set (tmp := @transport_hz_double_section A C1 C2 f _ _ (! (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1))). rewrite pathsinv0inv0 in tmp. cbn. cbn in tmp. rewrite <- tmp. clear tmp. rewrite transport_compose. rewrite <- assoc. apply cancel_precomposition. rewrite <- transport_source_precompose. rewrite <- transport_target_postcompose. rewrite transport_source_target_comm. rewrite <- maponpathsinv0. rewrite pathsinv0inv0. unfold DS11. unfold DS6, DS5, DS2, DS1. induction (hzrminusplus i 1). cbn. fold DS11 DS6 DS5 DS2 DS1. rewrite transport_source_precompose. apply cancel_postcomposition. rewrite pathscomp0rid. unfold DS11, DS5. induction (hzrplusminus (i - 1 + 1) 1). cbn. fold DS5. rewrite pathscomp0rid. set (tmp := @transport_hz_double_section_source_target A (λ i0 : pr1 hz, C2 i0) (λ i0 : pr1 hz, to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)) (λ i0 : pr1 hz, to_In2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) _ _ (hzrminusplus (i - 1 + 1 + 1 - 1) 1)). cbn in tmp. unfold DS5. use (pathscomp0 tmp). clear tmp. rewrite transport_source_target_comm. apply idpath. - rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_to_inv. rewrite <- transport_target_to_inv. use (pathscomp0 (! (@to_rinvax' A (Additive.to_Zero A) _ _ (transportf (precategory_morphisms (C1 i)) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1)) (Diff C1 i · (transportf (λ x' : A, A ⟦ x', DS9 ⟧) (maponpaths C1 ((hzrminusplus (i + 1 - 1 + 1) 1) @ hzrminusplus (i + 1) 1)) (to_In1 DS9) · to_In1 DS10)))))). use maponpaths_12. + apply idpath. + exact (InvRotMorphismIso'_eq2_1 f i). Qed. Lemma InvRotMorphismIso'_eq2' {C1 C2 : Complex A} (f : Morphism C1 C2) : MorphismOp A (MorphismComp (InvRotMorphism f) (InvRotMorphismInv f)) (MorphismOp_inv A (IdMor (MappingCone A (MorphismComp (MorphismOp_inv A (InvTranslationMorphism A (MappingCone A f) (TranslationComplex A C1) (MappingConePr1 A f))) (TranslationEquivUnitInv A C1))))) = ComplexHomotMorphism A (InvRotMorphismIsoHomot f). Proof. use MorphismEq. intros i. cbn. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex, InvTranslationComplex. unfold InvRotMorphismIsoHomot. unfold DiffTranslationComplex. unfold InvRotMorphismMor, InvRotMorphismMorInv. cbn. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS2 := to_BinDirectSums A DS1 (C1 i)). set (DS3 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))). set (DS4 := to_BinDirectSums A DS3 (C1 (i - 1))). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 + 1 - 1))). set (DS6 := to_BinDirectSums A DS5 (C1 (i - 1 + 1))). set (DS7 := to_BinDirectSums A (C1 (i + 1 + 1 - 1 + 1)) (C2 (i + 1 + 1 - 1))). set (DS8 := to_BinDirectSums A DS7 (C1 (i + 1))). set (DS9 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 - 1 + 1)) (C2 (i + 1 - 1 + 1 - 1))). set (DS10 := to_BinDirectSums A DS9 (C1 (i + 1 - 1))). set (DS11 := to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1 + 1)) (C2 (i - 1 + 1 - 1 + 1))). set (DS12 := to_BinDirectSums A (C1 (i + 1 - 1 + 1 + 1)) (C2 (i + 1 - 1 + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ _ (to_inv (to_Pr1 DS3))). rewrite <- transport_source_precompose. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_to_inv. rewrite (to_IdIn1 DS3). rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- (assoc (to_Pr2 DS2)). rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite id_left. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc (to_Pr2 DS2)). rewrite <- transport_source_precompose. rewrite <- (assoc _ (to_In1 DS8)). rewrite (to_Unel1' DS8). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite id_right. rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite (to_IdIn2 DS8). rewrite id_right. rewrite id_right. rewrite <- transport_target_to_binop. rewrite <- transport_target_to_binop. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- transport_target_to_inv. rewrite <- transport_target_to_inv. rewrite <- transport_target_to_inv. rewrite <- transport_target_to_inv. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_to_inv. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. rewrite <- (transport_target_postcompose (to_In1 DS3)). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite (assoc (to_In1 DS3)). rewrite (assoc (to_In1 DS3)). rewrite (assoc (to_In1 DS3)). rewrite (assoc (to_In1 DS3)). rewrite (assoc (to_In1 DS3)). rewrite (assoc (to_In1 DS3)). rewrite (to_Unel1' DS3). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite (to_IdIn1 DS3). rewrite id_left. rewrite id_left. unfold DiffTranslationComplex. rewrite <- (to_BinOpId DS2). rewrite to_binop_inv_comm_2. rewrite to_binop_inv_comm_2. rewrite to_binop_inv_comm_1. rewrite to_binop_inv_comm_1. rewrite inv_inv_eq. rewrite to_binop_inv_comm_2. apply maponpaths. rewrite <- to_binop_inv_inv. rewrite to_assoc. assert (e : (to_binop DS2 DS2 (to_inv (to_Pr1 DS2 · transportf (precategory_morphisms DS1) (maponpaths C2 (hzrplusminus i 1)) (to_Pr2 DS1) · transportf (λ x' : A, A ⟦ x', DS1 ⟧) (maponpaths C2 (hzrplusminus i 1)) (to_In2 DS1) · to_In1 DS2)) (to_binop DS2 DS2 (to_Pr1 DS2 · to_In1 DS2) (to_Pr2 DS2 · to_In2 DS2))) = to_binop DS2 DS2 (to_Pr1 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In1 DS2) (to_Pr2 DS2 · to_In2 DS2)). { rewrite <- to_assoc. use maponpaths_12. - assert (e1 : to_Pr1 DS2 · to_In1 DS2 = to_binop DS2 DS2 (to_Pr1 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In1 DS2) (to_Pr1 DS2 · to_Pr2 DS1 · to_In2 DS1 · to_In1 DS2)). { rewrite <- to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. apply cancel_postcomposition. rewrite (to_BinOpId DS1). rewrite id_right. apply idpath. } rewrite e1. clear e1. set (tmp := @to_lunax'' A (Additive.to_Zero A) _ _ (to_Pr1 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In1 DS2)). use (pathscomp0 _ tmp). clear tmp. rewrite (to_commax' A (to_Pr1 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In1 DS2)). rewrite <- to_assoc. use maponpaths_12. + set (tmp := @to_linvax' A (Additive.to_Zero A) _ _ (to_Pr1 DS2 · to_Pr2 DS1 · to_In2 DS1 · to_In1 DS2)). use (pathscomp0 _ tmp). clear tmp. use maponpaths_12. * apply maponpaths. apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite transport_compose'. apply idpath. * apply idpath. + apply idpath. - apply idpath. } cbn in e. rewrite e. clear e. rewrite (to_commax' A _ (to_Pr2 DS2 · transportf (precategory_morphisms (C1 i)) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) (transportf (precategory_morphisms (C1 (i - 1 + 1 - 1 + 1))) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1)) (identity (C1 (i - 1 + 1 - 1 + 1))) · to_In2 DS6)))). rewrite (to_commax' A _ (to_Pr2 DS2 · to_In2 DS2)). rewrite <- to_assoc. rewrite (to_commax' A _ (to_Pr2 DS2 · to_In2 DS2)). rewrite to_assoc. rewrite to_assoc. use maponpaths_12. - apply cancel_precomposition. rewrite transport_source_precompose. unfold DS2, DS6. rewrite transport_source_target_comm. unfold DS1, DS5. induction (hzrminusplus i 1). cbn. rewrite pathscomp0rid. induction (hzrminusplus (i - 1 + 1) 1). cbn. rewrite id_left. apply idpath. - fold DS1 DS2. fold DS5 DS6. rewrite <- to_binop_inv_comm_2. rewrite to_commax'. rewrite <- to_assoc. rewrite (to_commax' A _ (to_Pr1 DS2 · transportf (precategory_morphisms DS1) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_Pr1 DS1) · transportf (λ x' : A, A ⟦ x', DS9 ⟧) (maponpaths C1 (hzrminusplus (i + 1 - 1 + 1) 1 @ hzrminusplus (i + 1) 1)) (to_In1 DS9) · transportf (precategory_morphisms DS9) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) _ _ (hzrplusminus i 1)) (to_In1 DS10))). rewrite to_assoc. use maponpaths_12. + rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite transport_compose. apply cancel_precomposition. rewrite transport_source_precompose. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite <- path_assoc. rewrite pathsinv0r. rewrite pathscomp0rid. rewrite <- transport_source_precompose. rewrite <- transport_target_postcompose. rewrite transport_source_target_comm. set (e := hzrplusminus (i + 1 - 1) 1). set (tmp := @transport_hz_double_section_source_target A (λ i0 : hz, C1 (i0 + 1 - 1 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)) (λ i0 : hz, (to_In1 (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1)))) · (to_In1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i0 + 1 - 1 + 1)) (C2 (i0 + 1 - 1))) (C1 i0)))) _ _ (hzrplusminus i 1)). cbn in tmp. unfold DS2, DS1. use (pathscomp0 tmp). clear tmp. unfold DS10, DS9. apply maponpaths. assert (e' : (maponpaths (λ i0 : pr1 hz, C1 (i0 + 1 - 1 + 1)) (hzrplusminus i 1)) = (maponpaths C1 (hzrminusplus (i + 1 - 1 + 1) 1))). { cbn. assert (e'' : maponpaths (λ i0 : pr1 hz, C1 (i0 + 1 - 1 + 1)) (hzrplusminus i 1) = maponpaths C1 (maponpaths (λ i0 : pr1 hz, i0 + 1 - 1 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e''. apply maponpaths. apply isasethz. } rewrite e'. apply idpath. + exact (InvRotMorphismIso'_eq2_2 f i). Qed. Lemma InvRotMorphism_is_iso_with_inv_eq2 {C1 C2 : Complex A} (f : Morphism C1 C2) : # (ComplexHomotFunctor A) (((InvRotMorphism f) : (ComplexPreCat_Additive A)⟦_, _⟧) · InvRotMorphismInv f) = # (ComplexHomotFunctor A) (identity _). Proof. use ComplexHomotFunctor_rel_mor'. - exact (InvRotMorphismIsoHomot f). - exact (InvRotMorphismIso'_eq2' f). Qed. Lemma InvRotMorphism_is_z_isomorphism_inverses {C1 C2 : Complex A} (f : Morphism C1 C2) : is_inverse_in_precat (# (ComplexHomotFunctor A) (InvRotMorphismInv f)) (# (ComplexHomotFunctor A) (InvRotMorphism f)). Proof. use make_is_inverse_in_precat. - cbn beta. rewrite <- functor_comp. rewrite <- functor_id. exact (InvRotMorphism_is_iso_with_inv_eq1 f). - cbn beta. rewrite <- functor_comp. rewrite <- functor_id. exact (InvRotMorphism_is_iso_with_inv_eq2 f). Qed. Definition InvRotMorphism_is_z_isomorphism {C1 C2 : Complex A} (f : Morphism C1 C2) : @is_z_isomorphism (ComplexHomot_Additive A) _ _ (# (ComplexHomotFunctor A) (((InvRotMorphismInv f) : (ComplexPreCat_Additive A)⟦_, _⟧))). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) (InvRotMorphism f)). - exact (InvRotMorphism_is_z_isomorphism_inverses f). Defined. Definition InvRotMorphismInvComm1Homot {C1 C2 : Complex A} (f : Morphism C1 C2) : ComplexHomot A C1 (MappingCone A ((to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f))) · (inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1)))). Proof. intros i. cbn. use compose. - exact (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))). - exact (transportf (λ x' : ob A, precategory_morphisms x' _) (maponpaths C1 (hzrminusplus (i - 1 + 1) 1 @ hzrminusplus i 1)) (to_In1 (to_BinDirectSums A (C1 (i - 1 + 1 - 1 + 1)) (C2 (i - 1 + 1 - 1))))). - exact (to_In1 _). Defined. Definition InvRotMorphismInvComm1 {C1 C2 : Complex A} (f : Morphism C1 C2) : # (ComplexHomotFunctor A) ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · InvRotMorphismInv f) = # (ComplexHomotFunctor A) (MappingConeIn2 A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · (inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1)))). Proof. use (post_comp_with_z_iso_inv_is_inj (InvRotMorphism_is_z_isomorphism f)). unfold is_z_isomorphism_mor. unfold InvRotMorphism_is_z_isomorphism. set (tmp := functor_comp (ComplexHomotFunctor A) ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · InvRotMorphismInv f) (InvRotMorphism f)). use (pathscomp0 (! tmp)). clear tmp. rewrite <- assoc. set (tmp := functor_comp (ComplexHomotFunctor A) ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (((InvRotMorphismInv f) : (ComplexPreCat_Additive A)⟦_, _⟧) · (InvRotMorphism f))). use (pathscomp0 tmp). clear tmp. set (tmp := is_inverse_in_precat1 (InvRotMorphism_is_z_isomorphism f)). cbn beta in tmp. cbn beta. set (tmp' := functor_comp (ComplexHomotFunctor A) (((InvRotMorphismInv f) : (ComplexPreCat_Additive A)⟦_, _⟧)) (((InvRotMorphism f) : (ComplexPreCat_Additive A)⟦_, _⟧))). cbn beta in tmp'. rewrite tmp'. clear tmp'. apply (maponpaths (λ g : _, # (ComplexHomotFunctor A) f · g)) in tmp. use (pathscomp0 tmp). clear tmp. rewrite id_right. set (tmp := InvRotMorphismComm2 f). cbn beta in tmp. apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 (! tmp)). clear tmp. rewrite functor_comp. apply idpath. Qed. Local Opaque precategory_morphisms compose identity. Definition InvRotMorphismInvComm2 {C1 C2 : Complex A} (f : Morphism C1 C2) : ((MappingConeIn2 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) · (TranslationEquivCounitInv A (MappingCone A f)) = ((InvRotMorphismInv f) : (ComplexPreCat_Additive A)⟦_, _⟧) · MappingConePr1 A (to_inv (# (InvTranslationFunctor A) (MappingConePr1 A f)) · inv_from_z_iso (AddEquivUnitIso (TranslationEquiv A) C1)). Proof. use (post_comp_with_z_iso_is_inj (AddEquivCounitIso (TranslationEquiv A) (MappingCone A f))). rewrite <- assoc. set (tmp := is_inverse_in_precat2 (AddEquivCounitIso (TranslationEquiv A) (MappingCone A f))). cbn in tmp. cbn. rewrite tmp. clear tmp. use (pathscomp0 (@id_right (ComplexPreCat_Additive A) _ _ ((MappingConeIn2 A f) : (ComplexPreCat_Additive A)⟦_, _⟧))). use MorphismEq. Local Transparent compose. intros i. cbn. unfold InvRotMorphismMorInv. cbn. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite <- assoc. rewrite (to_IdIn1 (to_BinDirectSums A (to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))) (C1 i))). rewrite id_right. induction (hzrplusminus i 1). cbn. rewrite id_right. apply idpath. Qed. End inv_rotation_mapping_cone. (** Different fibers of the same morphism give isomorphic mapping cones *) Section fiber_ext. Variable A : CategoryWithAdditiveStructure. Definition FiberExtMor {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (i : hz) : A ⟦ (MappingCone A f) i, (MappingCone A g) i ⟧. Proof. cbn. use to_binop. - use compose. + exact (C1 (i + 1)). + exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + exact (to_In1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). - use to_binop. + use compose. * exact (C1 (i + 1)). * exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). * use compose. -- exact (C2 i). -- exact (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrplusminus i 1)) (H (i + 1))). -- exact (to_In2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (C2 i). * exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). * exact (to_In2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). Defined. Lemma FiberExtComm {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) (i : hz) : FiberExtMor f g H i · Diff (MappingCone A g) i = Diff (MappingCone A f) i · FiberExtMor f g H (i + 1). Proof. set (Comm' := MorphismEq' A _ _ Comm). cbn in Comm'. cbn. unfold FiberExtMor. unfold MappingConeDiff. cbn. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold FiberExtMor. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS4 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite (to_IdIn2 DS4). rewrite (to_Unel1' DS4). rewrite (to_Unel2' DS4). unfold DiffTranslationComplex. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_lunax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite (to_IdIn1 DS1). rewrite (to_IdIn2 DS1). rewrite (to_Unel1' DS1). rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_runax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. apply maponpaths. rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. apply cancel_postcomposition. rewrite <- to_assoc. rewrite to_postmor_linear'. rewrite to_commax'. rewrite (to_commax' _ _ (to_Pr2 DS1 · Diff C2 i)). rewrite (to_commax' _ _ (to_Pr2 DS1 · Diff C2 i)). rewrite to_assoc. apply maponpaths. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. apply cancel_precomposition. apply (to_rcan A (to_inv (g (i + 1)))). rewrite to_assoc. rewrite to_assoc. rewrite (Comm' (i + 1)). rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_runax''. rewrite <- transport_target_postcompose. rewrite <- PreAdditive_invlcomp. rewrite <- transport_target_to_inv. rewrite to_commax'. rewrite to_assoc. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_runax''. rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. set (tmp := transport_hz_section A C2 1 (Diff C2) _ _ (hzrplusminus i 1)). rewrite <- maponpathsinv0. use (pathscomp0 (! tmp)). clear tmp. use transportf_paths. apply maponpaths. apply isasethz. Qed. Definition FiberExt {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : Morphism (MappingCone A f) (MappingCone A g). Proof. use make_Morphism. - intros i. exact (FiberExtMor f g H i). - intros i. exact (FiberExtComm f g H Comm i). Defined. Definition InvHomot {C1 C2 : Complex A} (H : ComplexHomot A C1 C2) : ComplexHomot A C1 C2. Proof. intros i. exact (to_inv (H i)). Defined. Lemma InvHomotEq {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : to_binop _ _ ((g : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((f : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A (InvHomot H). Proof. set (Comm' := MorphismEq' A _ _ Comm). cbn in Comm'. use MorphismEq. intros i. cbn. unfold InvHomot. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite <- transport_target_to_inv. rewrite <- transport_target_to_inv. rewrite to_binop_inv_inv. rewrite <- (Comm' i). rewrite <- to_binop_inv_comm_1. rewrite to_commax'. apply idpath. Qed. Lemma FiberExt_eq1 {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : (((FiberExt f g H Comm) : (ComplexPreCat_Additive A)⟦_, _⟧) · ((FiberExt g f (InvHomot H) (InvHomotEq f g H Comm)) : (ComplexPreCat_Additive A)⟦_, _⟧)) = (identity _). Proof. use MorphismEq. intros i. cbn. unfold FiberExtMor. unfold InvHomot. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS4 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite <- (to_BinOpId DS1). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite (to_IdIn1 DS1). rewrite (to_IdIn2 DS1). rewrite (to_Unel1' DS1). rewrite (to_Unel2' DS1). unfold DiffTranslationComplex. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_runax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. apply maponpaths. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- to_assoc. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. apply idpath. Qed. Lemma FiberExt_eq2 {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : (((FiberExt g f (InvHomot H) (InvHomotEq f g H Comm)) : (ComplexPreCat_Additive A)⟦_, _⟧) · ((FiberExt f g H Comm) : (ComplexPreCat_Additive A)⟦_, _⟧)) = (identity _). Proof. use MorphismEq. intros i. cbn. unfold FiberExtMor. unfold InvHomot. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS4 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite <- (to_BinOpId DS1). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite (to_IdIn1 DS1). rewrite (to_IdIn2 DS1). rewrite (to_Unel1' DS1). rewrite (to_Unel2' DS1). unfold DiffTranslationComplex. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_runax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. apply maponpaths. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- to_assoc. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. apply idpath. Qed. Lemma FiberExt_inverses' {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : @is_inverse_in_precat (ComplexPreCat_Additive A) _ _ ((FiberExt f g H Comm)) ((FiberExt g f (InvHomot H) (InvHomotEq f g H Comm))). Proof. use make_is_inverse_in_precat. - exact (FiberExt_eq1 f g H Comm). - exact (FiberExt_eq2 f g H Comm). Qed. Lemma FiberExt_inverses {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : is_inverse_in_precat (# (ComplexHomotFunctor A) (FiberExt f g H Comm)) (# (ComplexHomotFunctor A) (FiberExt g f (InvHomot H) (InvHomotEq f g H Comm))). Proof. use make_is_inverse_in_precat. - rewrite <- functor_id. rewrite <- functor_comp. apply maponpaths. exact (FiberExt_eq1 f g H Comm). - rewrite <- functor_id. rewrite <- functor_comp. apply maponpaths. exact (FiberExt_eq2 f g H Comm). Qed. Definition FiberExt_is_z_isomorphism {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : @is_z_isomorphism (ComplexHomot_Additive A) _ _ (# (ComplexHomotFunctor A) (((FiberExt f g H Comm) : (ComplexPreCat_Additive A)⟦_, _⟧))). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) ((FiberExt g f (InvHomot H) (InvHomotEq f g H Comm)) : (ComplexPreCat_Additive A)⟦_, _⟧)). - exact (FiberExt_inverses f g H Comm). Defined. Lemma FiberExt_Comm2 {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : ((MappingConeIn2 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) · (FiberExt f g H Comm) = (MappingConeIn2 A g). Proof. use MorphismEq. intros i. cbn. unfold FiberExtMor. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS1). rewrite (to_Unel2' DS1). rewrite id_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. apply idpath. Qed. Lemma FiberExt_Comm2H {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : (# (ComplexHomotFunctor A) (MappingConeIn2 A f)) · (# (ComplexHomotFunctor A) (FiberExt f g H Comm)) = # (ComplexHomotFunctor A) (MappingConeIn2 A g). Proof. rewrite <- functor_comp. apply maponpaths. exact (FiberExt_Comm2 f g H Comm). Qed. Lemma FiberExt_Comm3 {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : ((MappingConePr1 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) = ((FiberExt f g H Comm) : (ComplexPreCat_Additive A)⟦_, _⟧) · (MappingConePr1 A g). Proof. use MorphismEq. intros i. cbn. unfold FiberExtMor. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 DS1). rewrite (to_Unel2' DS1). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite to_lunax''. rewrite to_runax''. apply idpath. Qed. Lemma FiberExt_Comm3H {C1 C2 : Complex A} (f g : Morphism C1 C2) (H : ComplexHomot A C1 C2) (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧)) (to_inv ((g : (ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A H) : # (ComplexHomotFunctor A) (MappingConePr1 A f) = # (ComplexHomotFunctor A) (FiberExt f g H Comm) · # (ComplexHomotFunctor A) (MappingConePr1 A g). Proof. rewrite <- functor_comp. apply maponpaths. exact (FiberExt_Comm3 f g H Comm). Qed. End fiber_ext. (** * Extension of morphisms *) (** ** Introduction Suppose you have morphisms f1 : X1 --> Y1, f2 : X2 --> Y2, g1 : X1 --> X2, and g2 : Y1 --> Y2, such that f1 · g2 = f2 · g1 in K(A). We construct a morphism h : C(f1) --> C(f2) such that the following squares are commutative in K(A) Y1 --> C(f1) C(f1) --> X1[1] | | | | Y2 --> C(f2) C(f2) --> X2[1] *) Section mapping_cone_ext. Variable A : CategoryWithAdditiveStructure. Definition MappingConeMorExtMor {C1 C1' C2 C2' : Complex A} (f : Morphism C1 C2) (f' : Morphism C1' C2') (g1 : Morphism C1 C1') (g2 : Morphism C2 C2') (H : ComplexHomot A C1 C2') (i : hz) : A ⟦ (MappingCone A f) i, (MappingCone A f') i ⟧. Proof. cbn. use to_binop. - use compose. + exact (C1 (i + 1)). + exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). + use compose. * exact (C1' (i + 1)). * exact (g1 (i + 1)). * exact (to_In1 (to_BinDirectSums A (C1' (i + 1)) (C2' i))). - use to_binop. + use compose. * exact (C1 (i + 1)). * exact (to_Pr1 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). * use compose. -- exact (C2' i). -- exact (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2' (hzrplusminus i 1)) (H (i + 1))). -- exact (to_In2 (to_BinDirectSums A (C1' (i + 1)) (C2' i))). + use compose. * exact (C2 i). * exact (to_Pr2 (to_BinDirectSums A (C1 (i + 1)) (C2 i))). * use compose. -- exact (C2' i). -- exact (g2 i). -- exact (to_In2 (to_BinDirectSums A (C1' (i + 1)) (C2' i))). Defined. Lemma MappingConeMorExtComm {C1 C1' C2 C2' : Complex A} (f : Morphism C1 C2) (f' : Morphism C1' C2') (g1 : Morphism C1 C1') (g2 : Morphism C2 C2') (H : ComplexHomot A C1 C2') (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · g2) (to_inv ((g1 : (ComplexPreCat_Additive A)⟦_, _⟧) · f')) = ComplexHomotMorphism A H) (i : hz) : MappingConeMorExtMor f f' g1 g2 H i · MappingConeDiff A f' i = MappingConeDiff A f i · MappingConeMorExtMor f f' g1 g2 H (i + 1). Proof. set (Comm' := MorphismEq' A _ _ Comm). cbn in Comm'. unfold MappingConeMorExtMor. unfold MappingConeDiff. cbn. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. cbn. unfold MappingConeMorExtMor. cbn. set (DS1 := to_BinDirectSums A (C1' (i + 1)) (C2' i)). set (DS2 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS3 := to_BinDirectSums A (C1' (i + 1 + 1)) (C2' (i + 1))). set (DS4 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite (to_IdIn2 DS4). rewrite (to_Unel1' DS4). rewrite (to_Unel2' DS4). unfold DiffTranslationComplex. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_lunax''. rewrite to_runax''. rewrite to_runax''. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr2 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite (to_IdIn1 DS1). rewrite (to_IdIn2 DS1). rewrite (to_Unel1' DS1). rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_right. rewrite id_right. rewrite id_right. rewrite to_runax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. use maponpaths_12. - apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. exact (MComm g1 (i + 1)). - rewrite <- to_assoc. rewrite <- to_assoc. use maponpaths_12. + rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'. apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite <- transport_target_postcompose. assert (e : (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2' (hzrplusminus i 1)) (H (i + 1)) · Diff C2' i) = (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2' (hzrminusplus (i + 1) 1)) (H (i + 1) · Diff C2' (i + 1 - 1)))). { rewrite transport_target_postcompose. rewrite transport_compose. apply cancel_precomposition. apply pathsinv0. rewrite <- maponpathsinv0. use (pathscomp0 _ (transport_hz_section A C2' 1 (Diff C2') _ _ (hzrplusminus i 1))). use transportf_paths. apply maponpaths. apply isasethz. } cbn in e. rewrite e. clear e. use (to_lcan A (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2' (hzrplusminus (i + 1) 1)) (Diff C1 (i + 1) · H (i + 1 + 1)))). rewrite <- to_assoc. rewrite <- to_assoc. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite to_commax'. rewrite <- to_assoc. use (to_rcan A (to_inv (g1 (i + 1) · f' (i + 1)))). rewrite to_assoc. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_runax''. apply pathsinv0. exact (Comm' (i + 1)). + apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (MComm g2 i). Qed. Definition MappingConeMorExt {C1 C1' C2 C2' : Complex A} (f : Morphism C1 C2) (f' : Morphism C1' C2') (g1 : Morphism C1 C1') (g2 : Morphism C2 C2') (H : ComplexHomot A C1 C2') (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · g2) (to_inv ((g1 : (ComplexPreCat_Additive A)⟦_, _⟧) · f')) = ComplexHomotMorphism A H) : Morphism (MappingCone A f) (MappingCone A f'). Proof. use make_Morphism. - intros i. exact (MappingConeMorExtMor f f' g1 g2 H i). - intros i. exact (MappingConeMorExtComm f f' g1 g2 H Comm i). Defined. Lemma MappingConeMorExtComm1 {C1 C1' C2 C2' : Complex A} (f : Morphism C1 C2) (f' : Morphism C1' C2') (g1 : Morphism C1 C1') (g2 : Morphism C2 C2') (H : ComplexHomot A C1 C2') (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · g2) (to_inv ((g1 : (ComplexPreCat_Additive A)⟦_, _⟧) · f')) = ComplexHomotMorphism A H) : (MappingConeIn2 A f : (ComplexPreCat_Additive A)⟦_, _⟧) · (MappingConeMorExt f f' g1 g2 H Comm) = (g2 : (ComplexPreCat_Additive A)⟦_, _⟧) · (MappingConeIn2 A f' : (ComplexPreCat_Additive A)⟦_, _⟧). Proof. use MorphismEq. intros i. cbn. unfold MappingConeMorExtMor. cbn. set (DS1 := to_BinDirectSums A (C1' (i + 1)) (C2' i)). set (DS2 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS2). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite id_left. rewrite to_lunax''. rewrite to_lunax''. apply idpath. Qed. Lemma MappingConeMorExtComm2 {C1 C1' C2 C2' : Complex A} (f : Morphism C1 C2) (f' : Morphism C1' C2') (g1 : Morphism C1 C1') (g2 : Morphism C2 C2') (H : ComplexHomot A C1 C2') (Comm : to_binop _ _ ((f : (ComplexPreCat_Additive A)⟦_, _⟧) · g2) (to_inv ((g1 : (ComplexPreCat_Additive A)⟦_, _⟧) · f')) = ComplexHomotMorphism A H) : ((MappingConePr1 A f) : (ComplexPreCat_Additive A)⟦_, _⟧) · (# (TranslationFunctor A) g1) = ((MappingConeMorExt f f' g1 g2 H Comm) : (ComplexPreCat_Additive A)⟦_, _⟧) · (MappingConePr1 A f'). Proof. use MorphismEq. intros i. cbn. unfold MappingConeMorExtMor. cbn. set (DS1 := to_BinDirectSums A (C1' (i + 1)) (C2' i)). set (DS2 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite <- (assoc _ _ (to_Pr1 DS1)). rewrite (to_IdIn1 DS1). rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite id_right. rewrite to_lunax''. rewrite to_runax''. apply idpath. Qed. End mapping_cone_ext. (** * Octahedral axiom for K(A) *) Section mapping_cone_octa. Context {A : CategoryWithAdditiveStructure}. Local Lemma KAOctaMor1_comm {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) (i : hz) : to_binop (to_BinDirectSums A (x (i + 1)) (y i)) (to_BinDirectSums A (x (i + 1)) (z i)) (to_Pr1 (to_BinDirectSums A (x (i + 1)) (y i)) · to_In1 (to_BinDirectSums A (x (i + 1)) (z i))) (to_Pr2 (to_BinDirectSums A (x (i + 1)) (y i)) · f2 i · to_In2 (to_BinDirectSums A (x (i + 1)) (z i))) · MappingConeDiff A (MorphismComp f1 f2) i = (MappingConeDiff A f1 i) · to_binop (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))) (to_Pr1 (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) · to_In1 (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1)))) (to_Pr2 (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) · f2 (i + 1) · to_In2 (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1)))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. cbn in x, y, z. set (DS1 := to_BinDirectSums A (x (i + 1)) (y i)). set (DS2 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS3 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). set (DS4 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS2 *) rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_IdIn1 DS2). rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS4 *) rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. (* binop_eq *) rewrite to_assoc. use maponpaths_12. + apply idpath. + use maponpaths_12. * apply idpath. * apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (MComm f2 i). Qed. (** The following morphism is used in the octahedral axiom for K(A) *) Definition KAOctaMor1 {x y z : ob (ComplexPreCat_Additive A)} (f1 : x --> y) (f2 : y --> z) : Morphism (MappingCone A f1) (MappingCone A (f1 · f2)). Proof. use make_Morphism. - intros i. cbn. use to_binop. + exact (to_Pr1 _ · to_In1 _). + exact (to_Pr2 _ · ((f2 : Morphism _ _) i) · to_In2 _). - intros i. exact (KAOctaMor1_comm f1 f2 i). Defined. Local Lemma KAOctaMor2_comm {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) (i : hz) : to_binop (to_BinDirectSums A (x (i + 1)) (z i)) (to_BinDirectSums A (y (i + 1)) (z i)) (to_Pr1 (to_BinDirectSums A (x (i + 1)) (z i)) · f1 (i + 1) · to_In1 (to_BinDirectSums A (y (i + 1)) (z i))) (to_Pr2 (to_BinDirectSums A (x (i + 1)) (z i)) · to_In2 (to_BinDirectSums A (y (i + 1)) (z i))) · MappingConeDiff A f2 i = (MappingConeDiff A (MorphismComp f1 f2) i) · (to_binop (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))) (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))) (to_Pr1 (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))) · f1 (i + 1 + 1) · to_In1 (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1)))) (to_Pr2 (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))) · to_In2 (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. cbn in x, y, z. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS3 := to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))). set (DS4 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS2 *) rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite (to_IdIn1 DS2). rewrite (to_Unel1' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS4 *) rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. (* maponpaths_12 *) rewrite to_assoc. use maponpaths_12. - apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. exact (MComm f1 (i + 1)). - apply idpath. Qed. Definition KAOctaMor2 {x y z : ob (ComplexPreCat_Additive A)} (f1 : x --> y) (f2 : y --> z) : Morphism (MappingCone A (f1 · f2)) (MappingCone A f2). Proof. use make_Morphism. - intros i. cbn. use to_binop. + exact (to_Pr1 _ · ((f1 : Morphism _ _) (i + 1)) · to_In1 _). + exact (to_Pr2 _ · to_In2 _). - intros i. exact (KAOctaMor2_comm f1 f2 i). Defined. Local Lemma KAOctaMor3_comm {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) (i : hz) : to_binop (to_BinDirectSums A (y (i + 1)) (z i)) (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1)) (z i))) (to_Pr1 (to_BinDirectSums A (y (i + 1)) (z i)) · to_In2 (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1)) (z i)))) (to_Pr2 (to_BinDirectSums A (y (i + 1)) (z i)) · to_In2 (to_BinDirectSums A (x (i + 1)) (z i)) · to_In2 (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1)) (z i)))) · MappingConeDiff A (KAOctaMor1 f1 f2) i = (MappingConeDiff A f2 i) · to_binop (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))) (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))) (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1)))) (to_Pr1 (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))) · to_In2 (to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))) (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))))) (to_Pr2 (to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))) · to_In2 (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))) · to_In2 (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))) (to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))))). Proof. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. cbn in x, y, z. set (DS1 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS3 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS4 := to_BinDirectSums A DS2 DS3). set (DS5 := to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))). set (DS6 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). set (DS7 := to_BinDirectSums A DS5 DS6). set (DS8 := to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS4 *) rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* DS2 *) rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS4 *) rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. (* DS8 *) rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite (to_IdIn2 DS8). rewrite id_right. rewrite id_right. rewrite (to_Unel2' DS8). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ (to_In1 DS8)). rewrite <- (assoc _ (to_In1 DS8)). rewrite (to_IdIn1 DS8). rewrite id_right. rewrite (to_Unel1' DS8). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* remove one sum *) rewrite (to_commax' _ _ (to_Pr1 DS1 · f2 (i + 1) · to_In2 DS6 · to_In2 DS7)). rewrite to_assoc. rewrite <- (to_assoc _ _ (to_Pr1 DS1 · f2 (i + 1) · to_In2 DS6 · to_In2 DS7)). rewrite (to_commax' _ _ (to_Pr1 DS1 · f2 (i + 1) · to_In2 DS6 · to_In2 DS7)). rewrite to_assoc. use maponpaths_12. - apply idpath. - unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS3 *) rewrite <- (assoc _ (to_In2 DS3)). rewrite <- (assoc _ (to_In2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite (to_Unel2' DS3). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. use maponpaths_12. + apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite to_binop_inv_comm_1. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. rewrite <- to_binop_inv_inv. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS2). rewrite id_left. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_binop_inv_inv. rewrite to_lunax''. apply idpath. + apply idpath. Qed. Definition KAOctaMor3 {x y z : ob (ComplexPreCat_Additive A)} (f1 : x --> y) (f2 : y --> z) : Morphism (MappingCone A f2) (MappingCone A (KAOctaMor1 f1 f2)). Proof. use make_Morphism. - intros i. cbn. use to_binop. + exact (to_Pr1 _ · to_In2 _ · to_In1 _). + exact (to_Pr2 _ · to_In2 _ · to_In2 _). - intros i. exact (KAOctaMor3_comm f1 f2 i). Defined. Definition KAOctaMor3InvMor {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : ∏ i : hz, A ⟦ (MappingCone A (KAOctaMor1 f1 f2)) i, (MappingCone A f2) i ⟧. Proof. intros i. cbn. use to_binop. - exact (to_Pr1 _ · to_Pr2 _ · to_In1 _). - use to_binop. + exact (to_Pr2 _ · to_Pr1 _ · f1 (i + 1) · to_In1 _). + exact (to_Pr2 _ · to_Pr2 _ · to_In2 _). Defined. Local Lemma KAOctaMor3InvComm {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) (i : hz) : KAOctaMor3InvMor f1 f2 i · Diff (MappingCone A f2) i = Diff (MappingCone A (KAOctaMor1 f1 f2)) i · KAOctaMor3InvMor f1 f2 (i + 1). Proof. cbn. unfold KAOctaMor3InvMor, MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. set (DS1 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS2 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS3 := to_BinDirectSums A DS1 DS2). set (DS4 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS5 := to_BinDirectSums A (y (i + 1 + 1)) (z (i + 1))). set (DS6 := to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))). set (DS7 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). set (DS8 := to_BinDirectSums A DS6 DS7). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS4 *) rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* DS8 *) rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In1 DS8)). rewrite <- (assoc _ (to_In1 DS8)). rewrite (to_IdIn1 DS8). rewrite (to_IdIn2 DS8). rewrite id_right. rewrite id_right. rewrite (to_Unel2' DS8). rewrite (to_Unel1' DS8). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. rewrite to_runax''. (* DS7 *) rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS7)). rewrite <- (assoc _ (to_In2 DS7)). rewrite <- (assoc _ (to_In1 DS7)). rewrite <- (assoc _ (to_In2 DS7)). rewrite (to_IdIn1 DS7). rewrite (to_IdIn2 DS7). rewrite id_right. rewrite id_right. rewrite (to_Unel1' DS7). rewrite (to_Unel2' DS7). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS8 *) rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite (to_IdIn2 DS8). rewrite id_right. (* MappingConeDiff *) unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. cbn. (* DS8 *) rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite <- (assoc _ (to_In2 DS8)). rewrite (to_Unel2' DS8). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. rewrite to_lunax''. (* DS7 *) rewrite <- (assoc _ (to_In2 DS7)). rewrite <- (assoc _ (to_In2 DS7)). rewrite <- (assoc _ (to_In2 DS7)). rewrite (to_IdIn2 DS7). rewrite (to_Unel2' DS7). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_runax''. rewrite id_right. rewrite <- (assoc _ (to_In1 DS7)). rewrite <- (assoc _ (to_In1 DS7)). rewrite (to_IdIn1 DS7). rewrite (to_Unel1' DS7). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite id_right. rewrite <- (assoc _ (to_In2 DS7)). rewrite (to_IdIn2 DS7). rewrite id_right. (* DS6 *) rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS6)). rewrite <- (assoc _ (to_In2 DS6)). rewrite <- (assoc _ (to_In2 DS6)). rewrite (to_IdIn2 DS6). rewrite id_right. rewrite id_right. rewrite (to_Unel1' DS6). rewrite ZeroArrow_comp_right. rewrite to_lunax''. rewrite <- PreAdditive_invlcomp. rewrite to_postmor_linear'. rewrite <- to_binop_inv_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. (* binop_eq *) rewrite (to_commax' _ _ (to_inv (to_Pr1 DS3 · to_Pr2 DS1 · Diff y (i + 1) · to_In1 DS5))). rewrite to_assoc. rewrite to_assoc. rewrite to_assoc. apply maponpaths. rewrite to_assoc. rewrite <- (to_assoc _ (to_inv (to_Pr1 DS3 · to_Pr1 DS1 · f1 (i + 1 + 1) · to_In1 DS5))). rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. apply maponpaths. rewrite <- (assoc _ (f1 (i + 1))). rewrite (MComm f1 (i + 1)). rewrite assoc. apply idpath. Qed. Definition KAOctaMor3Inv {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : Morphism (MappingCone A (KAOctaMor1 f1 f2)) (MappingCone A f2). Proof. use make_Morphism. - exact (KAOctaMor3InvMor f1 f2). - exact (KAOctaMor3InvComm f1 f2). Defined. Lemma KAOctaMor3Iso1 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) (i : hz) : (MorphismComp (KAOctaMor3 f1 f2) (KAOctaMor3Inv f1 f2)) i = (IdMor (MappingCone A f2)) i. Proof. unfold KAOctaMor3, KAOctaMor3Inv, KAOctaMor3InvMor. cbn. set (DS1 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS2 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS3 := to_BinDirectSums A DS1 DS2). set (DS4 := to_BinDirectSums A (y (i + 1)) (z i)). rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS3 *) rewrite <- (assoc _ (to_In1 DS3)). rewrite <- (assoc _ (to_In1 DS3)). rewrite <- (assoc _ (to_In2 DS3)). rewrite <- (assoc _ (to_In2 DS3)). rewrite (to_IdIn1 DS3). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite id_right. rewrite (to_Unel1' DS3). rewrite (to_Unel2' DS3). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_lunax''. rewrite to_runax''. (* DS2 *) rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS1 *) rewrite <- (assoc _ (to_In2 DS1)). rewrite (to_IdIn2 DS1). rewrite id_right. exact (to_BinOpId DS4). Qed. Definition KAOctaMor3InvHomot {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : ComplexHomot A (MappingCone A (KAOctaMor1 f1 f2)) (MappingCone A (KAOctaMor1 f1 f2)). Proof. intros i. cbn. use compose. - exact (x (i + 1)). - exact (to_Pr2 _ · to_Pr1 _). - use compose. + exact (to_BinDirectSums A (x (i - 1 + 1 + 1)) (y (i - 1 + 1))). + exact (to_inv (transportf (λ x' : ob A, precategory_morphisms x' _) (maponpaths x (maponpaths (λ i0 : hz, (i0 + 1)) (hzrminusplus i 1))) (to_In1 (to_BinDirectSums A (x (i - 1 + 1 + 1)) (y (i - 1 + 1)))))). + exact (to_In1 _). Defined. Lemma KAOctaMor3Iso2 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : (@to_binop (ComplexPreCat_Additive A) (MappingCone A (KAOctaMor1 f1 f2)) (MappingCone A (KAOctaMor1 f1 f2)) (MorphismComp (KAOctaMor3Inv f1 f2) (KAOctaMor3 f1 f2)) (to_inv ((IdMor (MappingCone A (KAOctaMor1 f1 f2))) : (ComplexPreCat_Additive A)⟦_, _⟧))) = (ComplexHomotMorphism A (KAOctaMor3InvHomot f1 f2)). Proof. use MorphismEq. intros i. unfold KAOctaMor3, KAOctaMor3Inv, KAOctaMor3InvMor. unfold KAOctaMor3InvHomot, MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. set (DS1 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS2 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS3 := to_BinDirectSums A DS1 DS2). set (DS4 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS5 := to_BinDirectSums A (x (i - 1 + 1 + 1)) (y (i - 1 + 1))). set (DS6 := to_BinDirectSums A (x (i - 1 + 1)) (z (i - 1))). set (DS7 := to_BinDirectSums A DS5 DS6). set (DS8 := to_BinDirectSums A (x (i + 1 + 1 + 1)) (y (i + 1 + 1))). set (DS9 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). set (DS10 := to_BinDirectSums A DS8 DS9). set (DS11 := to_BinDirectSums A (x (i + 1 - 1 + 1 + 1)) (y (i + 1 - 1 + 1))). set (DS12 := to_BinDirectSums A (x (i + 1 - 1 + 1)) (z (i + 1 - 1))). set (DS13 := to_BinDirectSums A DS11 DS12). set (DS14 := to_BinDirectSums A (x (i - 1 + 1 + 1 + 1)) (y (i - 1 + 1 + 1))). set (DS15 := to_BinDirectSums A (x (i - 1 + 1 + 1)) (z (i - 1 + 1))). set (DS16 := to_BinDirectSums A DS14 DS15). rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS4 *) rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In2 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite <- (assoc _ (to_In1 DS4)). rewrite (to_Unel1' DS4). rewrite (to_Unel2' DS4). rewrite (to_IdIn1 DS4). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_runax''. rewrite to_runax''. (* DS7 *) rewrite <- (assoc _ (to_In1 DS7)). rewrite <- (assoc _ (to_In1 DS7)). rewrite (to_IdIn1 DS7). rewrite (to_Unel1' DS7). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* DS5 *) rewrite <- (assoc _ _ (to_Pr1 DS5)). rewrite <- (assoc _ _ (to_Pr2 DS5)). rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite (to_IdIn1 DS5). rewrite (to_Unel1' DS5). rewrite transport_source_ZeroArrow. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_binop_inv_inv. rewrite to_runax''. (* DS10 *) rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite <- (assoc _ (to_In1 DS10)). rewrite <- (assoc _ (to_In2 DS10)). rewrite <- (assoc _ (to_In2 DS10)). rewrite <- (assoc _ (to_In2 DS10)). rewrite (to_Unel1' DS10). rewrite (to_IdIn2 DS10). rewrite id_right. rewrite id_right. rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. (* DS9 *) rewrite <- (assoc _ (to_In1 DS9)). rewrite <- (assoc _ (to_In2 DS9)). rewrite (to_Unel2' DS9). rewrite (to_IdIn1 DS9). rewrite id_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* MappingConeDiff *) unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8 DS9 DS10 DS11 DS12 DS13 DS14 DS15 DS16. rewrite inv_inv_eq. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite to_binop_inv_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS9 *) rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc _ (to_In2 DS9)). rewrite <- (assoc _ (to_In2 DS9)). rewrite (to_Unel2' DS9). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ (to_In1 DS9)). rewrite (to_IdIn1 DS9). rewrite id_right. (* DS5 *) rewrite <- (assoc _ _ (to_Pr1 DS5)). rewrite <- (assoc _ _ (to_Pr2 DS5)). rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite (to_IdIn1 DS5). rewrite (to_Unel1' DS5). rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* manipulate to_binops *) rewrite <- transport_target_to_binop. rewrite <- transport_target_to_binop. rewrite <- to_assoc. rewrite (to_commax' _ _ (to_Pr2 DS3 · to_Pr1 DS2 · f1 (i + 1) · to_In2 DS1 · to_In1 DS3)). rewrite to_assoc. rewrite to_assoc. rewrite <- transport_target_to_inv. rewrite <- transport_target_to_inv. rewrite <- to_binop_inv_comm_1. rewrite (to_commax' _ (to_inv (transportf (precategory_morphisms DS3) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) _ _ (hzrminusplus i 1)) (to_Pr2 DS3 · to_Pr1 DS2 · transportf (λ x' : A, A ⟦ x', x (i - 1 + 1 + 1) ⟧) (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1))) (identity (x (i - 1 + 1 + 1))) · Diff x (i - 1 + 1 + 1) · to_In1 DS14 · to_In1 DS16)))). rewrite to_assoc. rewrite to_assoc. (* binop_eq *) use maponpaths_12. - rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. rewrite <- transport_source_precompose. rewrite id_left. unfold DS3, DS2, DS1. unfold DS16, DS15, DS14. induction (hzrminusplus i 1). apply idpath. - rewrite <- (to_BinOpId DS3). rewrite <- to_binop_inv_inv. assert (e1 : (to_Pr1 DS3 · to_In1 DS3) = (to_Pr1 DS3 · identity _ · to_In1 DS3)). { rewrite id_right. apply idpath. } rewrite e1. clear e1. assert (e2 : (to_Pr2 DS3 · to_In2 DS3) = (to_Pr2 DS3 · identity _ · to_In2 DS3)). { rewrite id_right. apply idpath. } rewrite e2. clear e2. rewrite <- (to_BinOpId DS1). rewrite <- (to_BinOpId DS2). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- to_binop_inv_inv. rewrite <- to_binop_inv_inv. rewrite (to_commax' _ (to_Pr2 DS3 · to_Pr2 DS2 · to_In2 DS2 · to_In2 DS3)). rewrite <- to_assoc. rewrite <- to_assoc. rewrite <- to_assoc. rewrite to_assoc. rewrite to_assoc. rewrite to_assoc. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_runax''. rewrite (to_commax' _ _ (to_inv (to_Pr1 DS3 · to_Pr2 DS1 · to_In2 DS1 · to_In1 DS3))). rewrite <- to_assoc. rewrite <- to_assoc. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite <- to_assoc. rewrite (to_commax' _ _ (transportf (precategory_morphisms DS3) _ _)). rewrite <- transport_target_to_binop. rewrite to_assoc. use maponpaths_12. + rewrite <- transport_target_to_inv. apply maponpaths. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- (assoc _ (transportf (λ x' : A, A ⟦ x', DS11 ⟧) (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus (i + 1) 1))) (to_In1 DS11))). apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, x (i0 + 1 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) (λ i0 : hz, ((to_In1 (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1)))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))))) _ _ (hzrplusminus i 1)). cbn in tmp. unfold DS3, DS2, DS1. use (pathscomp0 tmp). clear tmp. apply maponpaths. assert (e : (maponpaths (λ i0 : pr1 hz, x (i0 + 1 + 1)) (hzrplusminus i 1)) = (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus (i + 1) 1)))). { assert (e1 : (maponpaths (λ i0 : pr1 hz, x (i0 + 1 + 1)) (hzrplusminus i 1)) = (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1 + 1) (hzrplusminus i 1)))). { induction (hzrplusminus i 1). apply idpath. } rewrite e1. apply maponpaths. apply isasethz. } rewrite e. apply idpath. + rewrite <- to_assoc. rewrite to_commax'. rewrite <- (@to_runax'' A (Additive.to_Zero A) _ _ (to_inv (to_Pr2 DS3 · to_Pr1 DS2 · to_In1 DS2 · to_In2 DS3))). use maponpaths_12. * apply maponpaths. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- (assoc _ (transportf (λ x' : A, A ⟦ x', x (i - 1 + 1 + 1) ⟧) (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1))) (identity (x (i - 1 + 1 + 1))))). rewrite <- transport_source_precompose. rewrite id_left. rewrite <- (assoc _ (transportf (λ x' : A, A ⟦ x', DS15 ⟧) (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1))) (to_In1 DS15))). apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. unfold DS3, DS2, DS1, DS16, DS15, DS14. induction (hzrminusplus i 1). apply idpath. * rewrite <- (assoc _ _ (Diff x (i - 1 + 1 + 1))). rewrite <- transport_source_precompose. rewrite id_left. unfold DS3, DS2, DS1. rewrite <- (@to_rinvax' A (Additive.to_Zero A) _ _ ((transportf (precategory_morphisms (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1)) (z i)))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) _ _ (hzrplusminus i 1)) (to_Pr2 (to_BinDirectSums A (to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))) (to_BinDirectSums A (x (i + 1)) (z i))) · to_Pr1 (to_BinDirectSums A (x (i + 1)) (z i)) · Diff x (i + 1) · transportf (λ x' : A, A ⟦ x', DS11 ⟧) (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus (i + 1) 1))) (to_In1 DS11) · to_In1 DS13)))). apply maponpaths. apply maponpaths. fold DS1 DS2 DS3. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. set (tmp := transport_hz_section A (λ i0 : hz, x (i0 + 1)) 1 (λ i0 : hz, Diff x (i0 + 1)) _ _ (! hzrminusplus i 1)). cbn in tmp. rewrite pathsinv0inv0 in tmp. assert (e : (maponpaths (λ i0 : pr1 hz, x (i0 + 1)) (hzrminusplus i 1)) = (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1)))). { induction (hzrminusplus i 1). apply idpath. } rewrite e in tmp. clear e. rewrite <- tmp. clear tmp. rewrite transport_compose. apply cancel_precomposition. assert (e : (! maponpaths (λ i0 : pr1 hz, x (i0 + 1)) (maponpaths_2 hzplus (! hzrminusplus i 1) 1)) = maponpaths (λ i0 : pr1 hz, x (i0 + 1)) (maponpaths_2 _ (hzrminusplus i 1) _)). { induction (hzrminusplus i 1). apply idpath. } cbn in e. rewrite e. clear e. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. rewrite transport_source_target_comm. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, x (i0 + 1 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) (λ i0 : hz, ((to_In1 (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1)))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))))) _ _ (hzrminusplus i 1)). cbn in tmp. unfold DS16, DS15, DS14. assert (e : maponpaths (λ i0 : pr1 hz, x (i0 + 1 + 1)) (hzrminusplus i 1) = maponpaths (λ i0 : pr1 hz, x (i0 + 1)) (maponpaths_2 _ (hzrminusplus i 1) _)). { induction (hzrminusplus i 1). apply idpath. } rewrite e in tmp. clear e. use (pathscomp0 _ tmp). clear tmp. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, x (i0 + 1 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) (λ i0 : hz, ((to_In1 (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1)))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))))) _ _ (hzrplusminus i 1)). use (pathscomp0 _ (! tmp)). clear tmp. apply maponpaths. assert (e : (maponpaths x (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus (i + 1) 1))) = (maponpaths (λ i0 : hz, x (i0 + 1 + 1)) (hzrplusminus i 1))). { use pathscomp0. - exact (maponpaths x (maponpaths (λ i0 : hz, i0 + 1 + 1) (hzrplusminus i 1))). - apply maponpaths. apply isasethz. - induction (hzrplusminus i 1). apply idpath. } rewrite e. clear e. apply idpath. Qed. Definition KAOctaMor3IsoInverses {x y z : ob (ComplexPreCat_Additive A)} (f1 : x --> y) (f2 : y --> z) : is_inverse_in_precat (# (ComplexHomotFunctor A) (KAOctaMor3 f1 f2)) (# (ComplexHomotFunctor A) (KAOctaMor3Inv f1 f2)). Proof. use make_is_inverse_in_precat. - rewrite <- functor_comp. rewrite <- functor_id. apply maponpaths. use MorphismEq. exact (KAOctaMor3Iso1 f1 f2). - rewrite <- functor_comp. rewrite <- functor_id. use ComplexHomotFunctor_rel_mor'. + exact (KAOctaMor3InvHomot f1 f2). + exact (KAOctaMor3Iso2 f1 f2). Defined. Definition KAOctaMor3Iso {x y z : ob (ComplexPreCat_Additive A)} (f1 : x --> y) (f2 : y --> z) : is_z_isomorphism (# (ComplexHomotFunctor A) ((KAOctaMor3 f1 f2) : (ComplexPreCat_Additive A)⟦_, _⟧)). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) (KAOctaMor3Inv f1 f2)). - exact (KAOctaMor3IsoInverses f1 f2). Defined. Definition KAOctaComm2Homot {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : ComplexHomot A (MappingCone A (MorphismComp f1 f2)) (MappingCone A (KAOctaMor1 f1 f2)). Proof. intros i. cbn. use compose. - exact (x (i + 1)). - exact (to_Pr1 _). - use compose. + exact (to_BinDirectSums A (x (i - 1 + 1 + 1)) (y (i - 1 + 1))). + exact (to_inv (transportf (λ x' : ob A, A⟦x', _⟧) (maponpaths x (maponpaths_2 _ (hzrminusplus i 1) _)) (to_In1 _))). + exact (to_In1 _). Defined. Local Lemma KAOctaComm2Eq {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : @to_binop (ComplexPreCat_Additive A) (MappingCone A (MorphismComp f1 f2)) (MappingCone A (KAOctaMor1 f1 f2)) (MorphismComp (KAOctaMor2 f1 f2) (KAOctaMor3 f1 f2)) (to_inv ((MappingConeIn2 A (KAOctaMor1 f1 f2)) : ((ComplexPreCat_Additive A)⟦_, _⟧))) = ComplexHomotMorphism A (KAOctaComm2Homot f1 f2). Proof. use MorphismEq. intros i. cbn. unfold KAOctaComm2Homot. unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS3 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS4 := to_BinDirectSums A DS3 DS1). set (DS5 := to_BinDirectSums A ((MappingCone A f1) (i - 1 + 1)) ((MappingCone A (MorphismComp f1 f2)) (i - 1))). set (DS6 := to_BinDirectSums A (x (i - 1 + 1 + 1)) (y (i - 1 + 1))). set (DS7 := to_BinDirectSums A ((MappingCone A f1) (i - 1 + 1 + 1)) ((MappingCone A (MorphismComp f1 f2)) (i - 1 + 1))). set (DS8 := to_BinDirectSums A (x (i - 1 + 1)) (z (i - 1))). set (DS9 := to_BinDirectSums A DS6 DS8). set (DS10 := to_BinDirectSums A (x (i + 1 + 1)) (z (i + 1))). set (DS11 := to_BinDirectSums A (x (i - 1 + 1 + 1)) (z (i - 1 + 1))). set (DS12 := to_BinDirectSums A (x (i - 1 + 1 + 1 + 1)) (y (i - 1 + 1 + 1))). set (DS13 := to_BinDirectSums A DS12 DS11). set (DS14 := to_BinDirectSums A (x (i + 1 - 1 + 1 + 1)) (y (i + 1 - 1 + 1))). set (DS15 := to_BinDirectSums A (x (i + 1 - 1 + 1)) (z (i + 1 - 1))). set (DS16 := to_BinDirectSums A DS14 DS15). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* DS2 *) rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In1 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite <- (assoc _ (to_In2 DS2)). rewrite (to_IdIn1 DS2). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite id_right. rewrite (to_Unel1' DS2). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_lunax''. (* DS9 *) rewrite <- (assoc _ (to_In1 DS9)). rewrite <- (assoc _ (to_In1 DS9)). rewrite (to_IdIn1 DS9). rewrite id_right. rewrite (to_Unel1' DS9). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* DS10 *) rewrite <- (assoc _ (to_In1 DS10)). rewrite <- (assoc _ (to_In2 DS10)). rewrite <- (assoc _ (to_In2 DS10)). rewrite (to_IdIn1 DS10). rewrite id_right. rewrite (to_Unel2' DS10). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite to_runax''. (* DS6 *) rewrite <- (assoc (to_Pr1 DS1)). rewrite <- (assoc (to_Pr1 DS1)). rewrite <- (assoc (to_Pr1 DS1)). rewrite <- (assoc (to_Pr1 DS1)). rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite to_premor_linear'. rewrite <- (assoc (to_Pr1 DS1)). rewrite <- (assoc (to_Pr1 DS1)). rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 DS6). rewrite id_left. rewrite (to_Unel1' DS6). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite transport_source_ZeroArrow. rewrite ZeroArrow_comp_right. rewrite to_runax''. (* unfold MappingConeDiff *) unfold MappingConeDiff. unfold MappingConeDiff1, MappingConeDiff2, MappingConeDiff3. unfold TranslationComplex. unfold DiffTranslationComplex. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6 DS7 DS8 DS9 DS10 DS11 DS12 DS13 DS14 DS15 DS16. rewrite <- PreAdditive_invrcomp. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 DS6). rewrite id_left. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 DS6). rewrite id_left. rewrite (to_Unel1' DS6). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* DS4 *) rewrite <- (id_left (to_inv (to_In2 DS4))). rewrite <- (to_BinOpId DS1). rewrite to_postmor_linear'. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite (to_commax' _ _ (to_inv (to_Pr2 DS1 · to_In2 DS1 · to_In2 DS4))). rewrite to_assoc. rewrite <- (to_assoc _ _ (to_inv (to_Pr2 DS1 · to_In2 DS1 · to_In2 DS4))). rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. (* Cancel to_Pr1 DS1 *) rewrite PreAdditive_invrcomp. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite inv_inv_eq. rewrite PreAdditive_invrcomp. rewrite <- to_premor_linear'. rewrite transport_target_postcompose. rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. rewrite to_commax'. rewrite (to_commax' _ _ (to_inv (transportf (λ x' : A, A ⟦ x', DS13 ⟧) (maponpaths x (maponpaths_2 _ (hzrminusplus i 1) _)) (to_In1 DS11 · to_In2 DS13)))). rewrite <- transport_target_to_binop. rewrite to_assoc. (* binop_eq *) use maponpaths_12. - rewrite <- transport_target_to_inv. apply maponpaths. unfold DS4, DS3, DS1. unfold DS13, DS12, DS11. induction (hzrminusplus i 1). cbn. apply idpath. - rewrite to_postmor_linear'. rewrite (to_commax' _ _ (f1 (i - 1 + 1 + 1) · to_In2 DS12 · to_In1 DS13)). rewrite <- transport_source_to_binop. rewrite <- transport_target_to_binop. rewrite to_assoc. rewrite <- (@to_runax'' A (Additive.to_Zero A) _ _ (f1 (i + 1) · (to_In2 DS3 · to_In1 DS4))). use maponpaths_12. + unfold DS4, DS3, DS1. unfold DS13, DS12, DS11. induction (hzrminusplus i 1). cbn. rewrite assoc. apply idpath. + rewrite <- PreAdditive_invlcomp. rewrite <- transport_source_to_inv. rewrite <- transport_target_to_inv. rewrite transport_source_precompose. rewrite transport_source_precompose. unfold DS4, DS3, DS1. rewrite <- (@to_linvax' A (Additive.to_Zero A) _ _ ((transportf (precategory_morphisms (x (i + 1))) (@maponpaths hz A (λ i0 : pr1 hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) _ _ (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', x (i - 1 + 1 + 1 + 1) ⟧) (maponpaths x (maponpaths_2 _ (hzrminusplus i 1) _)) (Diff x (i - 1 + 1 + 1)) · to_In1 DS12 · to_In1 DS13)))). use maponpaths_12. * apply idpath. * rewrite <- transport_source_precompose. rewrite <- transport_source_precompose. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, x (i0 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) (λ i0 : hz, ((Diff x (i0 + 1)) · to_In1 (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))))) _ _ (hzrminusplus i 1)). cbn in tmp. assert (e : (maponpaths (λ i0 : pr1 hz, x (i0 + 1)) (hzrminusplus i 1)) = (maponpaths x (maponpaths_2 _ (hzrminusplus i 1) _))). { induction (hzrminusplus i 1). apply idpath. } rewrite e in tmp. clear e. use (pathscomp0 (! tmp)). clear tmp. rewrite <- assoc. apply cancel_precomposition. rewrite <- transport_source_precompose. unfold DS16, DS15, DS14. set (tmp := transport_hz_double_section_source_target A (λ i0 : hz, x (i0 + 1 + 1)) (λ i0 : hz, to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))) (λ i0 : hz, (to_In1 (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) · to_In1 (to_BinDirectSums A (to_BinDirectSums A (x (i0 + 1 + 1)) (y (i0 + 1))) (to_BinDirectSums A (x (i0 + 1)) (z i0))))) _ _ (hzrplusminus i 1)). cbn in tmp. use (pathscomp0 tmp). clear tmp. apply maponpaths. assert (e : (maponpaths (λ i0 : pr1 hz, x (i0 + 1 + 1)) (hzrplusminus i 1)) = (maponpaths x (maponpaths_2 _ (hzrminusplus (i + 1) 1) _))). { assert (e' : maponpaths (λ i0 : pr1 hz, x (i0 + 1 + 1)) (hzrplusminus i 1) = maponpaths x (maponpaths (λ i0 : pr1 hz, (i0 + 1 + 1)) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } use (pathscomp0 e'). apply maponpaths. apply isasethz. } rewrite e. apply idpath. Qed. Lemma KAOctaComm2 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : # (ComplexHomotFunctor A) (MorphismComp (KAOctaMor2 f1 f2) (KAOctaMor3 f1 f2)) = # (ComplexHomotFunctor A) (MappingConeIn2 A (KAOctaMor1 f1 f2)). Proof. use ComplexHomotFunctor_rel_mor'. - exact (KAOctaComm2Homot f1 f2). - exact (KAOctaComm2Eq f1 f2). Qed. Lemma KAOctaComm3 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : MorphismComp (KAOctaMor3 f1 f2) (MappingConePr1 A (KAOctaMor1 f1 f2)) = MorphismComp (MappingConePr1 A f2) (# (TranslationFunctor A) (MappingConeIn2 A f1)). Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (y (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (x (i + 1 + 1)) (y (i + 1))). set (DS3 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS4 := to_BinDirectSums A DS2 DS3). rewrite to_postmor_linear'. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply idpath. Qed. Lemma KAOctaComm4 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : MorphismComp (KAOctaMor2 f1 f2) (MappingConePr1 A f2) = MorphismComp (MappingConePr1 A (MorphismComp f1 f2)) (# (TranslationFunctor A) f1). Proof. use MorphismEq. intros i. cbn. unfold TranslationMorphism_mor. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (y (i + 1)) (z i)). rewrite to_postmor_linear'. rewrite <- assoc. rewrite <- assoc. rewrite (to_IdIn1 DS2). rewrite id_right. rewrite <- assoc. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply idpath. Qed. Lemma KAOctaComm5 {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : MorphismComp f2 (MappingConeIn2 A (MorphismComp f1 f2)) = MorphismComp (MappingConeIn2 A f1) (KAOctaMor1 f1 f2). Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (x (i + 1)) (y i)). rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS2). rewrite id_left. rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_left. rewrite to_lunax''. apply idpath. Qed. Lemma KAOctaComm2' {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : (identity ((ComplexHomotFunctor A) (MappingCone A (MorphismComp f1 f2)))) · # (ComplexHomotFunctor A) (MappingConeIn2 A (KAOctaMor1 f1 f2)) = # (ComplexHomotFunctor A) (KAOctaMor2 f1 f2) · # (ComplexHomotFunctor A) (KAOctaMor3 f1 f2). Proof. rewrite id_left. use (pathscomp0 _ ((functor_comp (ComplexHomotFunctor A) _ _))). exact (! (KAOctaComm2 f1 f2)). Qed. Lemma KAOctaComm3' {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : # (ComplexHomotFunctor A) (KAOctaMor3 f1 f2) · # (ComplexHomotFunctor A) (MappingConePr1 A (KAOctaMor1 f1 f2)) = # (ComplexHomotFunctor A) (MappingConePr1 A f2) · # (AddEquiv1 (TranslationHEquiv A)) (# (ComplexHomotFunctor A) (MappingConeIn2 A f1)) · # (AddEquiv1 (TranslationHEquiv A)) (identity ((ComplexHomotFunctor A) (MappingCone A f1))). Proof. rewrite functor_id. rewrite id_right. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). set (tmp := KAOctaComm3 f1 f2). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 tmp). clear tmp. use (pathscomp0 ((functor_comp (ComplexHomotFunctor A) _ _))). apply cancel_precomposition. unfold AddEquiv1, TranslationHEquiv. cbn. apply pathsinv0. use TranslationFunctorHImEq. apply idpath. Qed. Lemma KAOctaComm4' {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : # (ComplexHomotFunctor A) (KAOctaMor2 f1 f2) · # (ComplexHomotFunctor A) (MappingConePr1 A f2) = # (ComplexHomotFunctor A) (MappingConePr1 A (MorphismComp f1 f2)) · # (AddEquiv1 (TranslationHEquiv A)) (# (ComplexHomotFunctor A) f1). Proof. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). set (tmp := (KAOctaComm4 f1 f2)). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 tmp). clear tmp. use (pathscomp0 ((functor_comp (ComplexHomotFunctor A) _ _))). apply cancel_precomposition. unfold AddEquiv1, TranslationHEquiv. cbn. apply pathsinv0. use TranslationFunctorHImEq. apply idpath. Qed. Lemma KAOctaComm5' {x y z : Complex A} (f1 : Morphism x y) (f2 : Morphism y z) : # (ComplexHomotFunctor A) (MappingConeIn2 A f1) · # (ComplexHomotFunctor A) (KAOctaMor1 f1 f2) = # (ComplexHomotFunctor A) f2 · # (ComplexHomotFunctor A) (MappingConeIn2 A (MorphismComp f1 f2)). Proof. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) _ _))). use (pathscomp0 _ ((functor_comp (ComplexHomotFunctor A) _ _))). apply maponpaths. exact (! (KAOctaComm5 f1 f2)). Qed. Lemma KAOctaMor1Comm {x y z : Complex A} (f1 : Morphism x y) (g1 : Morphism y z) : ((KAOctaMor1 f1 g1) : ((ComplexPreCat_Additive A)⟦_, _⟧)) · MappingConePr1 A ((f1 : ((ComplexPreCat_Additive A)⟦_, _⟧)) · g1) = MappingConePr1 A f1. Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (x (i + 1)) (y i)). rewrite to_postmor_linear'. rewrite <- assoc. rewrite (to_IdIn1 DS1). rewrite id_right. rewrite <- assoc. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_right. rewrite to_runax''. apply idpath. Qed. Lemma KAOctaMor2Comm {x y z : Complex A} (f1 : Morphism x y) (g1 : Morphism y z) : ((MappingConeIn2 A ((f1 : ((ComplexPreCat_Additive A)⟦_, _⟧)) · g1)) : ((ComplexPreCat_Additive A)⟦_, _⟧)) · ((KAOctaMor2 f1 g1) : ((ComplexPreCat_Additive A)⟦_, _⟧)) = MappingConeIn2 A g1. Proof. use MorphismEq. intros i. cbn. set (DS1 := to_BinDirectSums A (x (i + 1)) (z i)). set (DS2 := to_BinDirectSums A (y (i + 1)) (y i)). rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn2 DS1). rewrite id_left. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. apply idpath. Qed. End mapping_cone_octa. UniMath-20231010/UniMath/HomologicalAlgebra/MappingCylinder.v000066400000000000000000001226301451125700300236470ustar00rootroot00000000000000(** * Mapping cylinder in C(A) *) (** ** Introduction - Mapping cylinder - Let f : X -> Y be a morphism of complexes, then Y is isomorphic to Cyl(f) in K(A) *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.KA. Require Import UniMath.HomologicalAlgebra.TranslationFunctors. Require Import UniMath.HomologicalAlgebra.MappingCone. Unset Kernel Term Sharing. Local Open Scope hz_scope. Local Open Scope cat. Local Opaque hz isdecrelhzeq hzplus iscommringops ZeroArrow. (** * Mapping cylinder *) (** ** Introduction In this section we construct the mapping cylinder, which is a complex, of a morphism f : C_1 -> C_2 of complexes. We denote mapping cylinder of f by Cyl(f). The objects of mapping cylinder are given by C_1^i ⊕ Cone(f)^i. The ith differential of Cyl(f) is given by # p_1 · d^i_X · i_1 - p_2 · p1 · i_1 + p_2 · d^i_C(f) · i_2 # Here d^i_C(F) is the ith differential of the mapping cone of f, see section [mapping_cone]. We split the definition of the ith differential into a sum of 3 morphisms. These are constructed in [MappingCylinderDiff1], [MappingCylinderDiff3], and [MappingCylinderDiff3], and correspond the morphisms of the above formula, respectively. In [MappingCylinderDiff] we construct the differential. In [MappingCylinder_comp] we show that composition of two consecutive differentials is 0. The complex Cyl(f) is constructed in [MappingCylinder]. *) Section mapping_cylinder. Variable A : CategoryWithAdditiveStructure. (** # p_1 · d^i_X · i_1 # *) Definition MappingCylinderDiff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1' := to_BinDirectSums A (TranslationComplex A C1 i) (C2 i) in let DS1 := to_BinDirectSums A (C1 i) DS1' in let DS2' := to_BinDirectSums A (TranslationComplex A C1 (i + 1)) (C2 (i + 1)) in let DS2 := to_BinDirectSums A (C1 (i + 1)) DS2' in A ⟦ DS1, DS2 ⟧. Proof. intros DS1' DS1 DS2' DS2. use compose. - exact (C1 i). - exact (to_Pr1 DS1). - use compose. + exact (C1 (i + 1)). + exact (Diff C1 i). + exact (to_In1 DS2). Defined. (** # p_2 · (- p1) · i_1 # *) Definition MappingCylinderDiff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1' := to_BinDirectSums A (TranslationComplex A C1 i) (C2 i) in let DS1 := to_BinDirectSums A (C1 i) DS1' in let DS2' := to_BinDirectSums A (TranslationComplex A C1 (i + 1)) (C2 (i + 1)) in let DS2 := to_BinDirectSums A (C1 (i + 1)) DS2' in A ⟦ DS1, DS2 ⟧. Proof. intros DS1' DS1 DS2' DS2. use compose. - exact (DS1'). - exact (to_Pr2 DS1). - use compose. + exact ((TranslationComplex A C1) i). + exact (to_inv (to_Pr1 DS1')). + exact (to_In1 DS2). Defined. (** p_2 · d^i_C(f) · i_2 *) Definition MappingCylinderDiff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1' := to_BinDirectSums A (TranslationComplex A C1 i) (C2 i) in let DS1 := to_BinDirectSums A (C1 i) DS1' in let DS2' := to_BinDirectSums A (TranslationComplex A C1 (i + 1)) (C2 (i + 1)) in let DS2 := to_BinDirectSums A (C1 (i + 1)) DS2' in A ⟦ DS1, DS2 ⟧. Proof. intros DS1' DS1 DS2' DS2. use compose. - exact DS1'. - exact (to_Pr2 DS1). - use compose. + exact DS2'. + exact (MappingConeDiff A f i). + exact (to_In2 DS2). Defined. Definition MappingCylinderDiff {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1' := to_BinDirectSums A (TranslationComplex A C1 i) (C2 i) in let DS1 := to_BinDirectSums A (C1 i) DS1' in let DS2' := to_BinDirectSums A (TranslationComplex A C1 (i + 1)) (C2 (i + 1)) in let DS2 := to_BinDirectSums A (C1 (i + 1)) DS2' in A ⟦ DS1, DS2 ⟧. Proof. intros DS1 DS2. use to_binop. - exact (MappingCylinderDiff1 f i). - use to_binop. + exact (MappingCylinderDiff2 f i). + exact (MappingCylinderDiff3 f i). Defined. Lemma MappingCylinder_Diff1_Diff1 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : let DS1 := to_BinDirectSums A (C1 i) (MappingCone A f i) in let DS2 := to_BinDirectSums A (C1 (i + 1)) (MappingCone A f i) in (MappingCylinderDiff1 f i) · (MappingCylinderDiff1 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. intros DS1 DS2. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 _)). set (DS3 := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_IdIn1 DS3). rewrite id_right. rewrite <- (assoc _ _ (Diff C1 (i + 1))). rewrite (DSq A C1 i). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply idpath. Qed. Lemma MappingCylinder_Diff1_Diff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (MappingCylinderDiff1 f i) · (MappingCylinderDiff2 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 _)). set (DS := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_Unel1' DS). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCylinder_Diff1_Diff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (MappingCylinderDiff1 f i) · (MappingCylinderDiff3 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff1. unfold MappingCylinderDiff3. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 _)). set (DS := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_Unel1' DS). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCylinder_Diff2_Diff2 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (MappingCylinderDiff2 f i) · (MappingCylinderDiff2 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff2. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 _)). set (DS := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_Unel1' DS). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MappingCylinder_Diff2_Diff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (MappingCylinderDiff2 f i) · (MappingCylinderDiff3 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 _)). set (DS := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_Unel1' DS). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply ZeroArrow_comp_left. Qed. Lemma MapingCylinder_Diff3_Diff3 {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (MappingCylinderDiff3 f i) · (MappingCylinderDiff3 f (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff3. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 _)). set (DS := to_BinDirectSums A (C1 (i + 1)) (to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1)))). rewrite (to_IdIn2 DS). rewrite id_right. rewrite <- (assoc _ (MappingConeDiff A f i)). set (tmp := DSq A (MappingCone A f) i). cbn in tmp. cbn. rewrite tmp. clear tmp. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. apply idpath. Qed. Lemma MappingCylinder_comp {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : MappingCylinderDiff f i · MappingCylinderDiff f (i + 1) = ZeroArrow (Additive.to_Zero A) _ _. Proof. unfold MappingCylinderDiff. cbn. set (D11 := MappingCylinder_Diff1_Diff1 f i). set (D12 := MappingCylinder_Diff1_Diff2 f i). set (D13 := MappingCylinder_Diff1_Diff3 f i). set (D22 := MappingCylinder_Diff2_Diff2 f i). set (D23 := MappingCylinder_Diff2_Diff3 f i). set (D33 := MapingCylinder_Diff3_Diff3 f i). rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. cbn. cbn in D11. rewrite D11. cbn in D12. rewrite D12. cbn in D13. rewrite D13. cbn in D22. rewrite D22. cbn in D23. rewrite D23. cbn in D33. rewrite D33. rewrite to_lunax''. rewrite to_lunax''. rewrite to_runax''. rewrite to_runax''. rewrite to_lunax''. rewrite to_runax''. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. clear D11 D12 D13 D22 D23 D33. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS1' := to_BinDirectSums A (C1 i) DS1). set (DS2 := to_BinDirectSums A (C1 (i + 1 + 1 + 1)) (C2 (i + 1 + 1))). set (DS2' := to_BinDirectSums A (C1 (i + 1 + 1)) DS2). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS3' := to_BinDirectSums A (C1 (i + 1)) DS3). cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc _ _ (to_Pr1 DS3')). rewrite (to_IdIn1 DS3'). rewrite id_right. rewrite <- (assoc _ _ (to_Pr1 DS3')). rewrite (to_Unel2' DS3'). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ _ (to_Pr2 DS3')). rewrite (to_IdIn2 DS3'). rewrite id_right. rewrite to_binop_inv_inv. apply cancel_inv. rewrite inv_inv_eq. rewrite to_inv_zero. rewrite <- to_postmor_linear'. rewrite <- (ZeroArrow_comp_left _ _ _ _ _ (to_In1 DS2')). apply cancel_postcomposition. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite <- (ZeroArrow_comp_right _ _ _ _ _ (to_Pr2 DS1')). apply cancel_precomposition. unfold MappingConeDiff. unfold MappingConeDiff1. unfold MappingConeDiff2. unfold MappingConeDiff3. cbn in *. fold DS1 DS1' DS2 DS2' DS3 DS3'. unfold DiffTranslationComplex. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invrcomp. rewrite to_postmor_linear'. rewrite <- (assoc _ _ (to_Pr1 DS3)). rewrite (to_IdIn1 DS3). rewrite id_right. cbn. rewrite to_postmor_linear'. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS3)). rewrite <- (assoc _ _ (to_Pr1 DS3)). rewrite (to_Unel2' DS3). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. rewrite to_runax''. rewrite to_runax''. rewrite (@to_rinvax' A (Additive.to_Zero A)). apply idpath. Qed. Definition MappingCylinder {C1 C2 : Complex A} (f : Morphism C1 C2) : Complex A. Proof. use make_Complex. - intros i. exact (to_BinDirectSums A (C1 i) (to_BinDirectSums A (TranslationComplex A C1 i) (C2 i))). - intros i. exact (MappingCylinderDiff f i). - intros i. cbn beta. exact (MappingCylinder_comp f i). Defined. End mapping_cylinder. (** * Let f : X -> Y, then Y is isomorphic to Cyl(f) in K(A) *) (** ** Introduction We show that in K(A) Y and Cyl(f) are isomorphic. The isomorphism is given by the morphisms α := i_2 · i_2 and β := p_1 · f + p_2 · p_2. We have α · β = id in C(A), but β · α ≠ id_{Cyl(f)} in C(A). We define a homotopy by χ^i := p_1 · i_1 · i_2 : Cyl(f)^i --> Cyl(f)^{i-1}. We show that # id_{Cyl(f)} - β · α = χ^i · d^{i-1}_{Cyl(f)} + d^i_{Cyl(f)} · χ^{i-1} # $ id_{Cyl(f)} - β · α = χ^i · d^{i-1}_{Cyl(f)} + d^i_{Cyl(f)} · χ^{i-1} $ ( * ) This means that β · α = id_{Cyl(f)} in K(A) by the definition of homotopy of morphisms. Hence Y and C(f) are isomorphic. The morphisms α and β are defined in [MappingCylinderMor1_mor] and [MappingCylinderMor2_mor]. The equality α · β = id is proven in [MappingCylinderIso_eq1]. The homotopy χ is constructed in [MappingCylinderIsoHomot]. The equality ( * ) is proven in 4 steps. These steps are [MappingCylinderIsoHomot_eq1], [MappingCylinderIsoHomot_eq2], [MappingCylinderIsoHomot_eq3], and [MappingCylinderIsoHomot_eq4]. The equality β · α = id is proved in [MappingCylinderIso_eq2]. The fact that Y and Cyl(f) are isomorphic in K(A) is proved in [MappingCylinderIso]. *) Section mapping_cylinder_KA_iso. Variable A : CategoryWithAdditiveStructure. Definition MappingCylinderMor1_mor {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : A ⟦ C2 i, (MappingCylinder A f) i ⟧. Proof. unfold MappingCylinder. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). use compose. - exact DS1. - use (to_In2 DS1). - use (to_In2 DS2). Defined. Lemma MappingCylinderMor1_comm {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : MappingCylinderMor1_mor f i · Diff (MappingCylinder A f) i = Diff C2 i · MappingCylinderMor1_mor f (i + 1). Proof. unfold MappingCylinderMor1_mor. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C1 (i + 1)) DS3). rewrite assoc. unfold MappingCylinderDiff. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. fold DS1 DS2 DS3 DS4. rewrite to_premor_linear'. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite <- PreAdditive_invrcomp. rewrite (to_Unel2' DS1). rewrite to_inv_zero. rewrite ZeroArrow_comp_left. rewrite to_lunax''. apply cancel_postcomposition. unfold MappingConeDiff. unfold MappingConeDiff1. unfold MappingConeDiff2. unfold MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4. rewrite to_premor_linear'. rewrite assoc. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_premor_linear'. rewrite assoc. rewrite (to_Unel2' DS1). rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite assoc. rewrite (to_IdIn2 DS1). rewrite id_left. apply idpath. Qed. Definition MappingCylinderMor1 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : (ComplexPreCat_Additive A)⟦(ComplexHomotFunctor A C2), (ComplexHomotFunctor A (MappingCylinder A f))⟧. Proof. cbn. use make_Morphism. - intros i. exact (MappingCylinderMor1_mor f i). - intros i. exact (MappingCylinderMor1_comm f i). Defined. Definition MappingCylinderMor2_mor {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : A ⟦ (MappingCylinder A f) i, C2 i ⟧. Proof. unfold MappingCylinder. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). use to_binop. - use compose. + exact (C1 i). + use (to_Pr1 DS2). + exact (MMor f i). - use compose. + exact DS1. + use (to_Pr2 DS2). + use (to_Pr2 DS1). Defined. Lemma MappingCylinderMor2_comm {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : MappingCylinderMor2_mor f i · Diff C2 i = Diff (MappingCylinder A f) i · MappingCylinderMor2_mor f (i + 1). Proof. unfold MappingCylinderMor2_mor. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C1 (i + 1)) DS3). unfold MappingCylinderDiff. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. fold DS1 DS2 DS3 DS4. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite (to_Unel1' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_runax''. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite <- assoc. rewrite (MComm f i). rewrite assoc. apply maponpaths. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. apply cancel_precomposition. unfold MappingConeDiff. unfold MappingConeDiff1. unfold MappingConeDiff2. unfold MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_Unel1' DS3). rewrite ZeroArrow_comp_right. rewrite to_lunax''. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite <- (assoc _ _ (to_Pr2 DS3)). rewrite (to_IdIn2 DS3). rewrite id_right. rewrite <- PreAdditive_invlcomp. rewrite <- to_assoc. rewrite (@to_linvax' A (Additive.to_Zero A)). rewrite to_lunax''. apply idpath. Qed. Definition MappingCylinderMor2 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : (ComplexPreCat_Additive A)⟦(ComplexHomotFunctor A (MappingCylinder A f)), (ComplexHomotFunctor A C2)⟧. Proof. cbn. use make_Morphism. - intros i. exact (MappingCylinderMor2_mor f i). - intros i. exact (MappingCylinderMor2_comm f i). Defined. Lemma MappingCylinderIso_eq1' {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : (MappingCylinderMor1 f) · (MappingCylinderMor2 f) = identity _. Proof. use MorphismEq. intros i. cbn. unfold MappingCylinderMor1_mor. unfold MappingCylinderMor2_mor. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). rewrite to_premor_linear'. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS2)). rewrite (to_Unel2' DS2). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite assoc. rewrite <- (assoc _ _ (to_Pr2 DS2)). rewrite (to_IdIn2 DS2). rewrite id_right. rewrite (to_IdIn2 DS1). apply idpath. Qed. Lemma MappingCylinderIso_eq1 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : (# (ComplexHomotFunctor A) (MappingCylinderMor1 f)) · (# (ComplexHomotFunctor A) (MappingCylinderMor2 f)) = identity _. Proof. rewrite <- functor_comp. rewrite MappingCylinderIso_eq1'. rewrite functor_id. apply idpath. Qed. Lemma MappingCylinderIsoHomot {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : ComplexHomot A (MappingCylinder A f) (MappingCylinder A f). Proof. intros i. unfold MappingCylinder. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). set (DS3 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS4 := to_BinDirectSums A (C1 (i - 1)) DS3). use compose. - exact (C1 i). - exact (to_Pr1 DS2). - use compose. + exact DS3. + exact (transportf (λ x' : ob A, precategory_morphisms x' DS3) (maponpaths C1 (hzrminusplus i 1)) (to_In1 DS3)). + exact (to_inv (to_In2 DS4)). Defined. Definition MappingCylinderIsoHomot_mor1 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : A⟦(MappingCylinder A f) i, (MappingCylinder A f) i⟧. Proof. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). use to_binop. - use compose. + exact (C1 i). + exact (to_Pr1 DS2). + exact (to_In1 DS2). - use to_binop. + use compose. * exact (C1 i). * exact (to_Pr1 DS2). * use compose. -- exact (C1 (i + 1)). -- exact (Diff C1 i). -- use compose. ++ exact DS1. ++ exact (to_In1 DS1). ++ exact (to_In2 DS2). + use compose. * exact (C1 i). * exact (to_Pr1 DS2). * use compose. -- exact (C2 i). -- exact (to_inv (MMor f i)). -- use compose. ++ exact DS1. ++ exact (to_In2 DS1). ++ exact (to_In2 DS2). Defined. Lemma MappingCylinderIsoHomot_eq1 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : (transportf (precategory_morphisms (to_BinDirectSums A (C1 i) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))) (maponpaths (λ (i0 : hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (hzrminusplus i 1)) (MappingCylinderIsoHomot f i · MappingCylinderDiff A f (i - 1))) = MappingCylinderIsoHomot_mor1 f i. Proof. cbn. rewrite transport_target_postcompose. unfold MappingCylinderIsoHomot. unfold MappingCylinderIsoHomot_mor1. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). set (DS3 := to_BinDirectSums A (C1 (i - 1 + 1)) (C2 (i - 1))). set (DS4 := to_BinDirectSums A (C1 (i - 1)) DS3). set (DS5 := to_BinDirectSums A (C1 (i - 1 + 1 + 1)) (C2 (i - 1 + 1))). set (DS6 := to_BinDirectSums A (C1 (i - 1 + 1)) DS5). cbn. rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'. rewrite <- to_premor_linear'. apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite assoc. rewrite assoc. rewrite <- to_postmor_linear'. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. (* Unfold MappingCylinderDiff *) unfold MappingCylinderDiff. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. (* simplify *) rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invrcomp. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite to_inv_zero. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_lunax''. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite assoc. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- (assoc _ _ (to_Pr2 DS4)). rewrite (to_IdIn2 DS4). rewrite id_right. rewrite inv_inv_eq. (* Unfold MappingConeDiff *) unfold MappingConeDiff. unfold MappingConeDiff1. unfold MappingConeDiff2. unfold MappingConeDiff3. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6. cbn. rewrite to_premor_linear'. rewrite assoc. rewrite to_premor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (to_IdIn1 DS3). rewrite id_left. rewrite id_left. rewrite (to_Unel1' DS3). rewrite id_left. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. unfold DiffTranslationComplex. cbn. (* rewrite transports *) rewrite <- transport_source_to_binop. rewrite <- transport_target_to_binop. rewrite <- transport_source_to_inv. rewrite <- transport_target_to_inv. cbn. rewrite to_postmor_linear'. rewrite <- transport_source_to_binop. rewrite <- transport_target_to_binop. (* The first terms of to_binop are equal, cancel them *) assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths (λ (i0 : pr1 hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C1 (hzrminusplus i 1)) (to_In1 DS6))) = (to_In1 DS2)). { cbn. unfold DS2, DS1, DS6, DS5. set (tmp := λ (i0 : hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))). set (tmp'' := (λ (i0 : hz), to_In1 (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))))). set (tmp' := @transport_hz_double_section_source_target A C1 tmp tmp'' _ _ (hzrminusplus i 1)). unfold tmp'' in tmp'. rewrite tmp'. unfold tmp. apply idpath. } cbn in e1. cbn. rewrite <- e1. clear e1. apply maponpaths. (* The first term of to_binop are equal, cancel them *) rewrite <- to_binop_inv_inv. rewrite transport_target_to_inv. rewrite transport_source_to_inv. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite inv_inv_eq. rewrite transport_target_to_inv. rewrite transport_source_to_inv. rewrite PreAdditive_invlcomp. rewrite PreAdditive_invlcomp. rewrite to_postmor_linear'. assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths (λ (i0 : pr1 hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (hzrminusplus i 1)) (transportf (λ x' : A, A ⟦ x', DS6 ⟧) (maponpaths C1 (hzrminusplus i 1)) (Diff C1 (i - 1 + 1) · to_In1 DS5 · to_In2 DS6))) = (Diff C1 i · to_In1 DS1 · to_In2 DS2)). { cbn. unfold DS2, DS1, DS6, DS5. set (tmp := λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))). set (tmp'' := (λ (i0 : hz), (Diff C1 i0) · (to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) · (to_In2 (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))))). set (tmp' := @transport_hz_double_section_source_target A C1 tmp tmp'' _ _ (hzrminusplus i 1)). unfold tmp'' in tmp'. rewrite tmp'. unfold tmp. apply idpath. } rewrite <- e1. clear e1. apply maponpaths. (* Solve the rest *) cbn. unfold DS2, DS1, DS6, DS5. set (tmp := λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))). set (tmp'' := (λ (i0 : hz), (to_inv (MMor f i0)) · (to_In2 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) · (to_In2 (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))))). set (tmp' := @transport_hz_double_section_source_target A C1 tmp tmp'' _ _ (hzrminusplus i 1)). unfold tmp'' in tmp'. rewrite tmp'. unfold tmp. apply idpath. Qed. Definition MappingCylinderIsoHomot_mor2 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : A⟦(MappingCylinder A f) i, (MappingCylinder A f) i⟧. Proof. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). use to_binop. - use compose. + exact (C1 i). + exact (to_Pr1 DS2). + use compose. * exact (C1 (i + 1)). * exact (to_inv (Diff C1 i)). * use compose. -- exact DS1. -- exact (to_In1 DS1). -- exact (to_In2 DS2). - use compose. + exact DS1. + exact (to_Pr2 DS2). + use compose. * exact (C1 (i + 1)). * exact (to_Pr1 DS1). * use compose. -- exact DS1. -- exact (to_In1 DS1). -- exact (to_In2 DS2). Defined. Lemma MappyngCylinderIsoHomot_eq2 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : (transportf (precategory_morphisms (to_BinDirectSums A (C1 i) (to_BinDirectSums A (C1 (i + 1)) (C2 i)))) (maponpaths (λ (i0 : pr1 hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (hzrplusminus i 1)) (MappingCylinderDiff A f i · MappingCylinderIsoHomot f (i + 1))) = MappingCylinderIsoHomot_mor2 f i. Proof. cbn. unfold MappingCylinderIsoHomot. unfold MappingCylinderIsoHomot_mor2. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). set (DS3 := to_BinDirectSums A (C1 (i + 1 + 1)) (C2 (i + 1))). set (DS4 := to_BinDirectSums A (C1 (i + 1)) DS3). set (DS5 := to_BinDirectSums A (C1 (i + 1 - 1 + 1)) (C2 (i + 1 - 1))). set (DS6 := to_BinDirectSums A (C1 (i + 1 - 1)) DS5). cbn. unfold MappingCylinderDiff. unfold MappingCylinderDiff1. unfold MappingCylinderDiff2. unfold MappingCylinderDiff3. cbn. fold DS1 DS2 DS3 DS4 DS5 DS6. cbn. rewrite to_postmor_linear'. rewrite to_postmor_linear'. rewrite <- transport_target_to_binop. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_IdIn1 DS4). rewrite id_right. rewrite <- (assoc _ _ (to_Pr1 DS4)). rewrite (to_Unel2' DS4). rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. rewrite to_runax''. (* The first terms of to_binop are equal, cancel them *) assert (e1 : (transportf (precategory_morphisms DS2) (maponpaths (λ (i0 : pr1 hz), BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))) (hzrplusminus i 1)) (to_Pr1 DS2 · Diff C1 i · transportf (λ x' : A, A ⟦ x', DS5 ⟧) (maponpaths C1 (hzrminusplus (i + 1) 1)) (to_In1 DS5) · to_inv (to_In2 DS6))) = ((to_Pr1 DS2) · (to_inv (Diff C1 i)) · (to_In1 DS1) · (to_In2 DS2))). { rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite PreAdditive_invrcomp. apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. rewrite <- PreAdditive_invrcomp. unfold DS2, DS1, DS6, DS5. set (tmp := λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))). set (tmp'' := (λ i0 : hz, (to_inv ((to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) · (to_In2 (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))))))). set (tmp' := @transport_hz_double_section_source_target A (λ i0 : hz, C1 (i0 + 1)) tmp tmp'' _ _ (hzrplusminus i 1)). unfold tmp'' in tmp'. rewrite tmp'. clear tmp'. unfold tmp. clear tmp. clear tmp''. apply maponpaths. rewrite <- transport_source_to_inv. rewrite <- transport_source_to_inv. apply maponpaths. rewrite transport_source_precompose. rewrite transport_source_precompose. apply cancel_postcomposition. assert (e2 : maponpaths C1 (hzrminusplus (i + 1) 1) = maponpaths (λ i0 : hz, C1 (i0 + 1)) (hzrplusminus i 1)). { assert (e3 : maponpaths (λ i0 : hz, C1 (i0 + 1)) (hzrplusminus i 1) = maponpaths C1 (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e3. clear e3. apply maponpaths. apply isasethz. } rewrite <- e2. apply idpath. } cbn in e1. cbn. rewrite <- e1. clear e1. apply maponpaths. (* Use similar technique as above *) rewrite transport_target_postcompose. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite PreAdditive_invrcomp. apply cancel_precomposition. rewrite <- transport_target_postcompose. rewrite <- transport_source_precompose. rewrite <- PreAdditive_invrcomp. unfold DS2, DS1, DS6, DS5. rewrite transport_target_to_inv. rewrite transport_source_to_inv. rewrite inv_inv_eq. set (tmp := λ i0 : hz, BinDirectSumOb (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))). set (tmp'' := (λ i0 : hz, (to_In1 (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0))) · (to_In2 (to_BinDirectSums A (C1 i0) (to_BinDirectSums A (C1 (i0 + 1)) (C2 i0)))))). set (tmp' := @transport_hz_double_section_source_target A (λ i0 : hz, C1 (i0 + 1)) tmp tmp'' _ _ (hzrplusminus i 1)). unfold tmp'' in tmp'. rewrite tmp'. clear tmp'. unfold tmp. clear tmp. clear tmp''. apply maponpaths. rewrite transport_source_precompose. rewrite transport_source_precompose. apply cancel_postcomposition. assert (e2 : maponpaths C1 (hzrminusplus (i + 1) 1) = maponpaths (λ i0 : hz, C1 (i0 + 1)) (hzrplusminus i 1)). { assert (e3 : maponpaths (λ i0 : hz, C1 (i0 + 1)) (hzrplusminus i 1) = maponpaths C1 (maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e3. clear e3. apply maponpaths. apply isasethz. } rewrite <- e2. apply idpath. Qed. Lemma MappingCylinderisoHomot_eq3 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) (i : hz) : let DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i) in let DS2 := to_BinDirectSums A (C1 i) DS1 in to_binop DS2 DS2 (to_binop DS2 DS2 (to_Pr1 DS2 · to_In1 DS2) (to_Pr2 DS2 · to_Pr1 DS1 · to_In1 DS1 · to_In2 DS2)) (to_inv (to_Pr1 DS2 · MMor f i · to_In2 DS1 · to_In2 DS2)) = to_binop DS2 DS2 (MappingCylinderIsoHomot_mor1 f i) (MappingCylinderIsoHomot_mor2 f i). Proof. intros DS1 DS2. unfold MappingCylinderIsoHomot_mor1. unfold MappingCylinderIsoHomot_mor2. cbn. fold DS1 DS2. cbn. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite to_assoc. rewrite to_assoc. apply maponpaths. rewrite to_commax'. rewrite (to_commax' _ _ ((to_Pr1 DS2) · (to_inv (MMor f i)) · (to_In2 DS1) · (to_In2 DS2))). rewrite to_assoc. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. apply maponpaths. rewrite <- to_assoc. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. apply idpath. Qed. Lemma MappingCylinderIsoHomot_eq {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : to_binop _ _ (identity _) (to_inv (MappingCylinderMor2 f · MappingCylinderMor1 f)) = ComplexHomotMorphism A (MappingCylinderIsoHomot f). Proof. use MorphismEq. intros i. cbn. unfold MappingCylinderMor1_mor. unfold MappingCylinderMor2_mor. cbn. set (DS1 := to_BinDirectSums A (C1 (i + 1)) (C2 i)). set (DS2 := to_BinDirectSums A (C1 i) DS1). rewrite to_postmor_linear'. rewrite <- to_binop_inv_inv. rewrite <- (to_BinOpId DS2). assert (e : to_Pr2 DS2 · to_In2 DS2 = to_Pr2 DS2 · identity _ · to_In2 DS2). { rewrite id_right. apply idpath. } rewrite e. clear e. rewrite <- (to_BinOpId DS1). rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite assoc. rewrite to_assoc. rewrite to_assoc. rewrite (to_commax' _ (to_inv (to_Pr1 DS2 · MMor f i · to_In2 DS1 · to_In2 DS2))). rewrite <- (to_assoc _ _ _ (to_inv (to_Pr1 DS2 · MMor f i · to_In2 DS1 · to_In2 DS2))). rewrite (@to_rinvax' A (Additive.to_Zero A)). rewrite to_lunax''. rewrite <- to_assoc. use (pathscomp0 (MappingCylinderisoHomot_eq3 f i)). rewrite <- (MappingCylinderIsoHomot_eq1 f i). rewrite <- (MappyngCylinderIsoHomot_eq2 f i). unfold DS2. unfold DS1. apply idpath. Qed. Lemma MappingCylinderIso_eq2 {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : (# (ComplexHomotFunctor A) (MappingCylinderMor2 f)) · (# (ComplexHomotFunctor A) (MappingCylinderMor1 f)) = identity _. Proof. rewrite <- functor_comp. rewrite <- functor_id. apply pathsinv0. use ComplexHomotFunctor_rel_mor'. - exact (MappingCylinderIsoHomot f). - exact (MappingCylinderIsoHomot_eq f). Qed. Definition MappingCylinderIso {C1 C2 : Complex A} (f : (ComplexPreCat_Additive A)⟦C1, C2⟧) : iso (ComplexHomotFunctor A C2) (ComplexHomotFunctor A (MappingCylinder A f)). Proof. use tpair. - exact (# (ComplexHomotFunctor A) (MappingCylinderMor1 f)). - use is_iso_qinv. + exact (# (ComplexHomotFunctor A) (MappingCylinderMor2 f)). + split. * exact (MappingCylinderIso_eq1 f). * exact (MappingCylinderIso_eq2 f). Qed. End mapping_cylinder_KA_iso. Local Transparent hz isdecrelhzeq hzplus iscommringops ZeroArrow. UniMath-20231010/UniMath/HomologicalAlgebra/README.md000066400000000000000000000000771451125700300216520ustar00rootroot00000000000000Homological algebra Depends on Foundations and CategoryTheory UniMath-20231010/UniMath/HomologicalAlgebra/TranslationFunctors.v000066400000000000000000002442531451125700300246120ustar00rootroot00000000000000(** * Translation functors *) (** - Translation functors for C(A) - T ∘ T^{-1} = Id - Translation functors form equivalence - Translation functors for K(A) - T ∘ T^{-1} = Id - Translation functors form equivalence *) Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.TransportMorphisms. Require Import UniMath.CategoryTheory.Core.Univalence. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.AbelianToAdditive. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.HomologicalAlgebra.Complexes. Require Import UniMath.HomologicalAlgebra.KA. Unset Kernel Term Sharing. Local Open Scope hz_scope. Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow. (** * Translation funtor for C(A) and for K(A) *) (** ** Introduction We define the translation functor T : C(A) -> C(A) for complexes, and a translation functor T' : K(A) -> K(A). The functor T' is constructed so that we have the following commutative diagram C(A) ---T---> C(A) | | K(A) ---T'--> K(A) Here the vertical functors are given by [ComplexHomotFunctor]. The functor T sends a complex # ... -> X^{i-1} --(d^{i-1})--> X^i --(d^i)--> X^{i+1} -> ... # $ ... -> X^{i-1} --(d^{i-1})--> X^i --(d^i)--> X^{i+1} -> ... $ to the complex # ... -> X^i --(-d^i)--> X^{i+1} --(-d^{i+1})--> X^{i+2} -> ... # $ ... -> X^i --(-d^i)--> X^{i+1} --(-d^{i+1})--> X^{i+2} -> ... $ More precicely, on objects # X^i ↦ X^{i+1} # $ X^i ↦ X^{i+1} $ and differentials # d^i_X ↦ -d^{i+1}_X # $ d^i_X ↦ -d^{i+1}_X $. A morphism f : X -> Y is mapped by # f^i ↦ f^{i+1} # $ f^i ↦ f^{i+1} $. We also construct the inverse translation T^{-1} which is the unique functor such that T ∘ T^{-1} = id and T^{-1} ∘ T = id. All the functors T, T^{-1}, and T' are additive. The functor T : C(A) -> C(A) is constructed in [TranslationFunctor]. It is shown to be additive in [TranslationFunctor_Additive]. In [TranslationFunctorPreservesHomotopies] we show that T preserves homotopies, that is if f is homotopic to g, then T(f) is homotopic to T(g). In [InvTranslationFunctor] we construct T^{-1}. *) Section translation_functor. Variable A : CategoryWithAdditiveStructure. (** ** Translation functor for C(A) *) Local Lemma TranslationFunctor_comp (C : Complex A) (i : hz) : (to_inv (Diff C (i + 1))) · (to_inv (Diff C (i + 1 + 1))) = ZeroArrow (Additive.to_Zero A) (C (i + 1)) (C (i + 1 + 1 + 1)). Proof. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. apply (DSq A C (i + 1)). Qed. Definition TranslationComplex (C : Complex A) : Complex A. Proof. use make_Complex. - intros i. exact (C (i + 1)). - intros i. exact (to_inv (Diff C (i + 1))). - intros i. exact (TranslationFunctor_comp C i). Defined. Global Transparent TranslationComplex. Definition DiffTranslationComplex (C : Complex A) (i : hz) : A⟦ TranslationComplex C i, TranslationComplex C (i + 1) ⟧ := to_inv (Diff C (i + 1)). Global Transparent DiffTranslationComplex. Lemma DiffTranslationComplex_comp (C : Complex A) (i : hz) : (DiffTranslationComplex C i) · (DiffTranslationComplex C (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. exact (TranslationFunctor_comp C i). Qed. Definition TranslationMorphism_mor {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A⟦TranslationComplex C1 i, TranslationComplex C2 i⟧ := f (i + 1). Local Lemma TranslationFunctor_comm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (TranslationMorphism_mor f i) · (DiffTranslationComplex C2 i) = (DiffTranslationComplex C1 i) · (TranslationMorphism_mor f (i + 1)). Proof. unfold DiffTranslationComplex. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. apply (MComm f (i + 1)). Qed. Definition TranslationMorphism (C1 C2 : Complex A) (f : Morphism C1 C2) : Morphism (TranslationComplex C1) (TranslationComplex C2) := make_Morphism A (TranslationComplex C1) (TranslationComplex C2) (λ i : hz, TranslationMorphism_mor f i) (λ i : hz, TranslationFunctor_comm f i). Definition TranslationFunctor_data : functor_data (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_functor_data. - intros C. exact (TranslationComplex C). - intros C1 C2 f. exact (TranslationMorphism C1 C2 f). Defined. Lemma TranslationFunctor_isfunctor : is_functor TranslationFunctor_data. Proof. split. - intros C. cbn. use MorphismEq. intros i. cbn. apply idpath. - intros C1 C2 C3 f g. cbn. use MorphismEq. intros i. cbn. apply idpath. Qed. Definition TranslationFunctor : functor (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_functor. - exact TranslationFunctor_data. - exact TranslationFunctor_isfunctor. Defined. Definition TranslationFunctor_isAdditive : isAdditiveFunctor TranslationFunctor. Proof. use make_isAdditiveFunctor. intros C1 C2. split. - intros f g. cbn. use MorphismEq. intros i. cbn. apply idpath. - cbn. use MorphismEq. intros i. apply idpath. Qed. Definition TranslationFunctor_Additive : AdditiveFunctor (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_AdditiveFunctor. - exact TranslationFunctor. - exact TranslationFunctor_isAdditive. Defined. (** *** Translation functor preserves homotopies *) Definition TranslationHomot {C1 C2 : Complex A} (H : ComplexHomot A C1 C2) : ComplexHomot A (TranslationComplex C1) (TranslationComplex C2). Proof. intros i. exact (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrplusminus i 1 @ ! hzrminusplus i 1)) (to_inv (H (i + 1)))). Defined. Lemma TranslationFunctorHomotopies {C1 C2 : Complex A} (H : ComplexHomot A C1 C2) : ComplexHomotMorphism A (TranslationHomot H) = TranslationMorphism C1 C2 (ComplexHomotMorphism A H). Proof. unfold TranslationHomot. cbn. use MorphismEq. intros i. cbn. induction (hzrminusplus i 1). cbn. rewrite pathscomp0rid. cbn. rewrite <- PreAdditive_invrcomp. rewrite <- transport_target_to_inv. rewrite PreAdditive_invlcomp. rewrite inv_inv_eq. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. assert (e : (maponpaths (λ i0 : pr1 hz, C2 (i0 + 1)) (hzrplusminus (i - 1 + 1) 1)) = (maponpaths C2 (maponpaths (λ (i0 : hz), i0 + 1) (hzrplusminus (i - 1 + 1) 1)))). { induction (hzrplusminus (i - 1 + 1) 1). apply idpath. } cbn in e. rewrite e. clear e. (* The first elements of to_binop are the same *) assert (e1 : (transportf (precategory_morphisms (C1 (i - 1 + 1 + 1))) (maponpaths C2 (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrplusminus (i - 1 + 1) 1))) ((Diff C1 (i - 1 + 1 + 1)) · (transportf (precategory_morphisms (C1 (i - 1 + 1 + 1 + 1))) (maponpaths C2 (hzrplusminus (i - 1 + 1 + 1) 1 @ ! hzrminusplus (i - 1 + 1 + 1) 1)) (H (i - 1 + 1 + 1 + 1)))) = (transportf (precategory_morphisms (C1 (i - 1 + 1 + 1))) (maponpaths C2 (hzrplusminus (i - 1 + 1 + 1) 1)) (Diff C1 (i - 1 + 1 + 1) · H (i - 1 + 1 + 1 + 1))))). { rewrite transport_target_postcompose. rewrite transport_f_f. rewrite <- maponpathscomp0. set (tmp := ((hzrplusminus (i - 1 + 1 + 1) 1 @ ! hzrminusplus (i - 1 + 1 + 1) 1) @ maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrplusminus (i - 1 + 1) 1))). assert (ee : tmp = (hzrplusminus (i - 1 + 1 + 1) 1)) by apply isasethz. unfold tmp in ee. cbn in ee. unfold tmp. cbn. rewrite ee. clear ee. clear tmp. induction (hzrplusminus (i - 1 + 1 + 1) 1). cbn. apply idpath. } cbn in e1. rewrite e1. clear e1. use maponpaths_2. (* Show that the first elements of to_binop are the same *) set (tmp := @transport_hz_source_target A C2 1 (Diff C2) _ _ (hzrplusminus (i - 1 + 1) 1)). rewrite tmp. clear tmp. rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition. rewrite transport_f_f. rewrite <- maponpathsinv0. rewrite <- maponpathscomp0. rewrite pathsinv0r. rewrite <- functtransportf. rewrite idpath_transportf. apply transportf_paths. apply maponpaths. apply isasethz. Qed. Lemma TranslationFunctorPreservesHomotopies {C1 C2 : Complex A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : subgrhrel (ComplexHomotSubgrp A C1 C2) f g) : subgrhrel (ComplexHomotSubgrp A _ _) (TranslationMorphism C1 C2 f) (TranslationMorphism C1 C2 g). Proof. use (squash_to_prop H). { apply propproperty. } intros H'. clear H. induction H' as [H1 H2]. induction H1 as [H11 H12]. cbn in H11. use (squash_to_prop H12). { apply propproperty. } intros H. cbn in H2. induction H as [HH1 HH2]. intros P X. apply X. clear X P. use tpair. - use tpair. + cbn. exact (TranslationMorphism _ _ H11). + intros P X. apply X. clear X P. use tpair. * exact (TranslationHomot HH1). * cbn. rewrite TranslationFunctorHomotopies. rewrite HH2. apply idpath. - cbn. rewrite H2. set (tmp := @AdditiveFunctorLinear (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) TranslationFunctor_Additive C1 C2 f (to_inv g)). cbn in tmp. rewrite tmp. clear tmp. apply maponpaths. set (tmp := @AdditiveFunctorInv (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) TranslationFunctor_Additive C1 C2 g). cbn in tmp. exact tmp. Qed. (** *** Inverse of the translation functor functor *) Local Lemma InvTranslationFunctor_comp (C : Complex A) (i : hz) : (transportf (precategory_morphisms (C (i - 1))) (maponpaths C (hzrminusplus i 1 @ ! hzrplusminus i 1)) (to_inv (Diff C (i - 1)))) · (transportf (precategory_morphisms (C (i + 1 - 1))) (maponpaths C (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) (to_inv (Diff C (i + 1 - 1)))) = ZeroArrow (Additive.to_Zero A) _ _. Proof. induction (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1). induction (hzrminusplus i 1 @ ! hzrplusminus i 1). cbn. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. apply DSq. Qed. Definition InvTranslationComplex (C : Complex A) : Complex A. Proof. use make_Complex. - intros i. exact (C (i - 1)). - intros i. exact (transportf (precategory_morphisms (C (i - 1))) (maponpaths C ((hzrminusplus i 1) @ (! hzrplusminus i 1))) (to_inv (Diff C (i - 1)))). - intros i. exact (InvTranslationFunctor_comp C i). Defined. Global Transparent InvTranslationComplex. Definition DiffInvTranslationComplex (C : Complex A) (i : hz) : A⟦ InvTranslationComplex C i, InvTranslationComplex C (i + 1) ⟧ := transportf (precategory_morphisms (C (i - 1))) (maponpaths C ((hzrminusplus i 1) @ (! hzrplusminus i 1))) (to_inv (Diff C (i - 1))). Lemma DiffInvTranslationComplex_comp (C : Complex A) (i : hz) : (DiffInvTranslationComplex C i) · (DiffInvTranslationComplex C (i + 1)) = ZeroArrow (Additive.to_Zero A) _ _. Proof. exact (InvTranslationFunctor_comp C i). Qed. Definition InvTranslationMorphism_mor {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : A⟦InvTranslationComplex C1 i, InvTranslationComplex C2 i⟧ := f (i - 1). Local Lemma InvTranslationFunctor_comm {C1 C2 : Complex A} (f : Morphism C1 C2) (i : hz) : (InvTranslationMorphism_mor f i) · (DiffInvTranslationComplex C2 i) = (DiffInvTranslationComplex C1 i) · (InvTranslationMorphism_mor f (i + 1)). Proof. unfold DiffInvTranslationComplex. rewrite <- transport_target_postcompose. unfold InvTranslationMorphism_mor. cbn. rewrite <- PreAdditive_invrcomp. rewrite (MComm f (i - 1)). rewrite PreAdditive_invlcomp. rewrite transport_target_postcompose. use transport_target_path. - exact (C2 i). - exact (maponpaths C2 (hzrplusminus i 1)). - rewrite transport_target_postcompose. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite <- path_assoc. rewrite pathsinv0l. rewrite pathscomp0rid. induction (hzrminusplus i 1). cbn. rewrite transport_target_postcompose. set (tmp := transport_hz_double_section A C1 C2 (MMor f) _ _ (hzrplusminus (i - 1 + 1) 1)). cbn. cbn in tmp. rewrite tmp. clear tmp. rewrite <- (transport_compose' _ _ (maponpaths C1 (! hzrplusminus (i - 1 + 1) 1))). apply cancel_precomposition. apply idpath. Qed. Definition InvTranslationMorphism (C1 C2 : Complex A) (f : Morphism C1 C2) : Morphism (InvTranslationComplex C1) (InvTranslationComplex C2) := make_Morphism A (InvTranslationComplex C1) (InvTranslationComplex C2) (λ i : hz, InvTranslationMorphism_mor f i) (λ i : hz, InvTranslationFunctor_comm f i). Definition InvTranslationFunctor_data : functor_data (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_functor_data. - intros C. exact (InvTranslationComplex C). - intros C1 C2 f. exact (InvTranslationMorphism C1 C2 f). Defined. Lemma InvTranslationFunctor_isfunctor : is_functor InvTranslationFunctor_data. Proof. split. - intros C. cbn. use MorphismEq. intros i. cbn. apply idpath. - intros C1 C2 C3 f g. cbn. use MorphismEq. intros i. cbn. apply idpath. Qed. Definition InvTranslationFunctor : functor (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_functor. - exact InvTranslationFunctor_data. - exact InvTranslationFunctor_isfunctor. Defined. Definition InvTranslationFunctor_isAdditive : isAdditiveFunctor InvTranslationFunctor. Proof. use make_isAdditiveFunctor. intros C1 C2. split. - intros f g. cbn. use MorphismEq. intros i. cbn. apply idpath. - cbn. use MorphismEq. intros i. apply idpath. Qed. Definition InvTranslationFunctor_Additive : AdditiveFunctor (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_AdditiveFunctor. - exact InvTranslationFunctor. - exact InvTranslationFunctor_isAdditive. Defined. (** *** InvTranslation functor preserves homotopies *) Definition InvTranslationHomot {C1 C2 : Complex A} (H : ComplexHomot A C1 C2) : ComplexHomot A (InvTranslationComplex C1) (InvTranslationComplex C2). Proof. intros i. exact (to_inv (H (i - 1))). Defined. Lemma InvTranslationFunctorHomotopies {C1 C2 : Complex A} (H : ComplexHomot A C1 C2) : ComplexHomotMorphism A (InvTranslationHomot H) = InvTranslationMorphism C1 C2 (ComplexHomotMorphism A H). Proof. unfold InvTranslationHomot. cbn. use MorphismEq. intros i. cbn. induction (hzrplusminus i 1). cbn. rewrite pathscomp0rid. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite inv_inv_eq. rewrite <- transport_target_to_inv. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite inv_inv_eq. assert (e1 : transportf (precategory_morphisms (C1 (i + 1 - 1 - 1))) (maponpaths C1 (hzrminusplus (i + 1 - 1) 1)) (Diff C1 (i + 1 - 1 - 1)) · H (i + 1 - 1) = transportf (precategory_morphisms (C1 (i + 1 - 1 - 1))) (maponpaths C2 (hzrplusminus (i + 1 - 1 - 1) 1)) (Diff C1 (i + 1 - 1 - 1) · H (i + 1 - 1 - 1 + 1))). { rewrite transport_target_postcompose. rewrite transport_compose. apply cancel_precomposition. rewrite <- maponpathsinv0. rewrite <- (transport_hz_double_section A _ _ H _ _ (hzrminusplus (i + 1 - 1) 1)). use transportf_paths. assert (e2 : maponpaths (λ i0 : hz, C2 (i0 - 1)) (hzrminusplus (i + 1 - 1) 1) = maponpaths C2 (maponpaths (λ i0 : hz, i0 - 1) (hzrminusplus (i + 1 - 1) 1))). { induction (hzrminusplus (i + 1 - 1) 1). apply idpath. } rewrite e2. clear e2. apply maponpaths. apply isasethz. } cbn in e1. rewrite e1. clear e1. use maponpaths_2. rewrite <- transport_target_postcompose. rewrite transport_f_f. assert (e2 : maponpaths (λ i0 : pr1 hz, C2 (i0 - 1)) (hzrminusplus (i + 1 - 1) 1) = maponpaths C2 (maponpaths (λ i0 : hz, i0 - 1) (hzrminusplus (i + 1 - 1) 1))). { induction (hzrminusplus (i + 1 - 1) 1). apply idpath. } rewrite e2. clear e2. rewrite <- maponpathscomp0. use transportf_paths. apply maponpaths. apply isasethz. Qed. Lemma InvTranslationFunctorPreservesHomotopies {C1 C2 : Complex A} (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : subgrhrel (ComplexHomotSubgrp A C1 C2) f g) : subgrhrel (ComplexHomotSubgrp A _ _) (InvTranslationMorphism C1 C2 f) (InvTranslationMorphism C1 C2 g). Proof. use (squash_to_prop H). { apply propproperty. } intros H'. clear H. induction H' as [H1 H2]. induction H1 as [H11 H12]. cbn in H11. use (squash_to_prop H12). { apply propproperty. } intros H. cbn in H2. induction H as [HH1 HH2]. intros P X. apply X. clear X P. use tpair. - use tpair. + cbn. exact (InvTranslationMorphism _ _ H11). + intros P X. apply X. clear X P. use tpair. * exact (InvTranslationHomot HH1). * cbn. rewrite InvTranslationFunctorHomotopies. rewrite HH2. apply idpath. - cbn. rewrite H2. set (tmp := @AdditiveFunctorLinear (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) InvTranslationFunctor_Additive C1 C2 f (to_inv g)). cbn in tmp. rewrite tmp. clear tmp. apply maponpaths. set (tmp := @AdditiveFunctorInv (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) InvTranslationFunctor_Additive C1 C2 g). cbn in tmp. exact tmp. Qed. (** ** Translation functor is an isomorphism, with inverse the inverse translation. *) Lemma transportf_total2_base {AA : UU} {B : AA -> UU} {BB : AA -> UU} (s s' : ∑ x : AA, B x) (p : pr1 s = pr1 s') (q : transportf B p (pr2 s) = pr2 s') (x : BB (pr1 s)) : transportf (λ x' : ∑ x : AA, B x, BB (pr1 x')) (total2_paths_f p q) x = transportf (λ x : AA, BB x) p x. Proof. induction s as [s1 s2]. induction s' as [s1' s2']. cbn in *. induction p. induction q. apply idpath. Qed. Lemma ComplexEq_transport_target {C1 C2 C2' : Complex A} (H : ∏ (i : hz), C2 i = C2' i) (H1 : ∏ (i : hz), transportf (λ x : A, C2' i --> x) (H (i + 1)) (transportf (λ x : A, x --> C2 (i + 1)) (H i) (Diff C2 i)) = Diff C2' i) (f : Morphism C1 C2) (i : hz) : (transportf (λ x : Complex A, Morphism C1 x) (ComplexEq A C2 C2' H H1) f) i = transportf (λ x : A, C1 i --> x) (H i) (f i). Proof. assert (e : (transportf (λ x : Complex A, Morphism C1 x) (ComplexEq A C2 C2' H H1) f) i = (transportf (λ x : Complex A, C1 i --> x i) (ComplexEq A C2 C2' H H1) (f i))). { induction (ComplexEq A C2 C2' H H1). apply idpath. } use (pathscomp0 e). clear e. rewrite <- (@transport_target_funextfun hz _ C2 C2' H i (C1 i) (f i)). unfold ComplexEq. unfold Complex_Funclass. set (e := (funextfun (pr1 (pr1 C2)) (pr1 (pr1 C2')) (λ x0 : pr1 hz, H x0))). cbn. cbn in e. fold e. set (tmp := @transportf_total2_base _ _ (λ x0 : _ , A ⟦ pr1 (pr1 C1) i, (pr1 x0) i ⟧) C2 C2' (total2_paths_f e (ComplexEq' A C2 C2' H H1)) (ComplexEq'' A C2 C2' H H1) (f i)). cbn beta in tmp. use (pathscomp0 tmp). clear tmp. use transportf_total2_base. Qed. Lemma ComplexEq_transport_source {C1 C1' C2 : Complex A} (H : ∏ (i : hz), C1' i = C1 i) (H1 : ∏ (i : hz), transportf (λ x : A, C1 i --> x) (H (i + 1)) (transportf (λ x : A, x --> C1' (i + 1)) (H i) (Diff C1' i)) = Diff C1 i) (f : Morphism C1' C2) (i : hz) : (transportf (λ x : Complex A, Morphism x C2) (ComplexEq A C1' C1 H H1) f) i = transportf (λ x : A, x --> C2 i) (H i) (f i). Proof. assert (e : (transportf (λ x : Complex A, Morphism x C2) (ComplexEq A C1' C1 H H1) f) i = (transportf (λ x : Complex A, x i --> C2 i) (ComplexEq A C1' C1 H H1) (f i))). { induction (ComplexEq A C1' C1 H H1). apply idpath. } use (pathscomp0 e). clear e. rewrite <- (@transport_source_funextfun hz _ C1' C1 H i (C2 i) (f i)). unfold ComplexEq. unfold Complex_Funclass. set (e := (funextfun (pr1 (pr1 C1')) (pr1 (pr1 C1)) (λ i0 : hz, H i0))). cbn. cbn in e. fold e. set (tmp := @transportf_total2_base (hz -> ob A) _ (λ x0 : pr1 hz → A, A ⟦ x0 i, pr1 (pr1 C2) i ⟧) (pr1 C1') (pr1 C1) e (ComplexEq' A C1' C1 H H1) (f i)). use (pathscomp0 _ tmp). clear tmp. cbn beta. use transportf_total2_base. Qed. Local Lemma TranslationInvTranslation_eq1 (C : Complex A) (i : hz) : transportf (λ x : A, A ⟦ C i, x ⟧) (maponpaths C (hzrminusplus (i + 1) 1)) (transportf (λ x : A, A ⟦ x, C (i + 1 - 1 + 1) ⟧) (maponpaths C (hzrminusplus i 1)) (transportf (precategory_morphisms (C (i - 1 + 1))) (maponpaths (λ i0 : pr1 hz, C (i0 + 1)) (hzrminusplus i 1 @ ! hzrplusminus i 1)) (to_inv (to_inv (Diff C (i - 1 + 1)))))) = Diff C i. Proof. rewrite inv_inv_eq. induction (hzrminusplus i 1). cbn. rewrite transport_f_f. assert (e : maponpaths (λ i0 : pr1 hz, (C : Complex _) (i0 + 1)) (! hzrplusminus (i - 1 + 1) 1) = maponpaths (C : Complex _) (maponpaths (λ i0 : hz, i0 + 1) (! hzrplusminus (i - 1 + 1) 1))). { induction (hzrplusminus (i - 1 + 1) 1). apply idpath. } cbn in e. rewrite e. clear e. rewrite <- maponpathscomp0. assert (e : (maponpaths (λ i0 : pr1 hz, i0 + 1) (! hzrplusminus (i - 1 + 1) 1) @ hzrminusplus (i - 1 + 1 + 1) 1) = idpath _). { apply isasethz. } cbn in e. cbn. rewrite e. clear e. apply idpath. Qed. Local Lemma TranslationInvTranslation_eq2 {C1 C2 : Complex A} (f : Morphism C1 C2) : transportf (λ x : Complex A, Morphism C1 x) (ComplexEq A (InvTranslationComplex (TranslationComplex C2)) C2 (λ i : pr1 hz, maponpaths C2 (hzrminusplus i 1)) (λ i : pr1 hz, TranslationInvTranslation_eq1 C2 i)) (transportf (λ x : Complex A, Morphism x (InvTranslationComplex (TranslationComplex C2))) (ComplexEq A (InvTranslationComplex (TranslationComplex C1)) C1 (λ i : pr1 hz, maponpaths C1 (hzrminusplus i 1)) (λ i : pr1 hz, TranslationInvTranslation_eq1 C1 i)) (InvTranslationMorphism (TranslationComplex C1) (TranslationComplex C2) (TranslationMorphism C1 C2 f))) = f. Proof. use MorphismEq. intros i. Local Opaque ComplexEq. cbn. rewrite ComplexEq_transport_target. rewrite ComplexEq_transport_source. cbn. induction (hzrminusplus i 1). cbn. apply idpath. Qed. Lemma TranslationInvTranslation : functor_composite TranslationFunctor InvTranslationFunctor = functor_identity _. Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. use ComplexEq. * intros i. cbn. apply maponpaths. apply (hzrminusplus i 1). * intros i. cbn. exact (TranslationInvTranslation_eq1 C i). + intros C1 C2 f. Local Opaque ComplexEq. cbn. exact (TranslationInvTranslation_eq2 f). Qed. Local Lemma InvTranslationTranslation_eq1 (C : Complex A) (i : hz) : transportf (λ x : A, A ⟦ C i, x ⟧) (maponpaths C (hzrplusminus (i + 1) 1)) (transportf (λ x : A, A ⟦ x, C (i + 1 + 1 - 1) ⟧) (maponpaths C (hzrplusminus i 1)) (to_inv (transportf (precategory_morphisms (C (i + 1 - 1))) (maponpaths C (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) (to_inv (Diff C (i + 1 - 1)))))) = Diff C i. Proof. rewrite transport_target_to_inv. rewrite inv_inv_eq. rewrite <- transport_source_target_comm. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite <- path_assoc. rewrite pathsinv0l. rewrite pathscomp0rid. rewrite (transport_hz_source_target A C 1 (Diff C) _ _ (hzrplusminus i 1)). apply maponpaths. use transportf_paths. apply maponpaths. apply isasethz. Qed. Local Lemma InvTranslationTranslation_eq2 {C1 C2 : Complex A} (f : Morphism C1 C2) : transportf (λ x : Complex A, Morphism C1 x) (ComplexEq A (TranslationComplex (InvTranslationComplex C2)) C2 (λ i : pr1 hz, maponpaths C2 (hzrplusminus i 1)) (λ i : pr1 hz, InvTranslationTranslation_eq1 C2 i)) (transportf (λ x : Complex A, Morphism x (TranslationComplex (InvTranslationComplex C2))) (ComplexEq A (TranslationComplex (InvTranslationComplex C1)) C1 (λ i : pr1 hz, maponpaths C1 (hzrplusminus i 1)) (λ i : pr1 hz, InvTranslationTranslation_eq1 C1 i)) (TranslationMorphism (InvTranslationComplex C1) (InvTranslationComplex C2) (InvTranslationMorphism C1 C2 f))) = f. Proof. Local Opaque ComplexEq. use MorphismEq. intros i. cbn. rewrite ComplexEq_transport_target. rewrite ComplexEq_transport_source. cbn. induction (hzrplusminus i 1). cbn. apply idpath. Qed. Lemma InvTranslationTranslation : functor_composite InvTranslationFunctor TranslationFunctor = functor_identity _. Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. use ComplexEq. * intros i. cbn. apply maponpaths. apply (hzrplusminus i 1). * intros i. cbn. apply (InvTranslationTranslation_eq1 C i). + intros C1 C2 f. Local Opaque ComplexEq. cbn. exact (InvTranslationTranslation_eq2 f). Qed. (** *** Natural transformation for equivalence consisting of the translations *) Local Lemma TranslationTranslationInvNatTrans_Eq1 (x : Complex A): ∏ i : hz, transportf (precategory_morphisms (x i)) (maponpaths x (! hzrminusplus i 1)) (identity (x i)) · Diff (InvTranslationComplex (TranslationComplex x)) i = (Diff x i) · (transportf (precategory_morphisms (x (i + 1))) (maponpaths x (! hzrminusplus (i + 1) 1)) (identity (x (i + 1)))). Proof. intros i. cbn. rewrite inv_inv_eq. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_target_postcompose. induction (hzrminusplus i 1). cbn. rewrite id_left. use transportf_paths. assert (e : maponpaths (λ i0 : pr1 hz, (x : Complex A) (i0 + 1)) (! hzrplusminus (i - 1 + 1) 1) = maponpaths (x : Complex A) (maponpaths (λ i0 : hz, i0 + 1) (! hzrplusminus (i - 1 + 1) 1))). { induction (hzrplusminus (i - 1 + 1) 1). apply idpath. } use (pathscomp0 e). apply maponpaths. apply isasethz. Qed. Definition TranslationTranslationInvNatTrans_Mor (x : Complex A) : Morphism x (InvTranslationComplex (TranslationComplex x)). Proof. use make_Morphism. - intros i. cbn. exact (transportf (precategory_morphisms ((x : Complex A) i)) (maponpaths (x : Complex A) (! hzrminusplus i 1)) (identity ((x : Complex A) i))). - exact (TranslationTranslationInvNatTrans_Eq1 x). Defined. Local Lemma TranslationTranslationInvNatTrans_isnattrans : is_nat_trans (functor_identity (ComplexPreCat_Additive A)) (functor_composite TranslationFunctor_Additive InvTranslationFunctor_Additive) (λ x : ComplexPreCat_Additive A, TranslationTranslationInvNatTrans_Mor x). Proof. intros x y f. cbn. use MorphismEq. intros i. cbn. induction (hzrminusplus i 1). cbn. rewrite id_right. rewrite id_left. apply idpath. Qed. Definition TranslationTranslationInvNatTrans : nat_trans (functor_identity (ComplexPreCat_Additive A)) (functor_composite TranslationFunctor_Additive InvTranslationFunctor_Additive). Proof. use make_nat_trans. - intros x. exact (TranslationTranslationInvNatTrans_Mor x). - exact (TranslationTranslationInvNatTrans_isnattrans). Defined. Local Lemma InvTranslationTranslationNatTrans_Eq1 (x : Complex A) : ∏ i : hz, (transportf (precategory_morphisms (x (i + 1 - 1))) (maponpaths x (hzrplusminus i 1)) (identity (x (i + 1 - 1)))) · Diff x i = (Diff (TranslationComplex (InvTranslationComplex x)) i) · (transportf (precategory_morphisms (x (i + 1 + 1 - 1))) (maponpaths x (hzrplusminus (i + 1) 1)) (identity (x (i + 1 + 1 - 1)))). Proof. intros i. cbn. rewrite transport_target_to_inv. rewrite inv_inv_eq. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite <- path_assoc. rewrite pathsinv0l. rewrite pathscomp0rid. rewrite transport_compose. rewrite id_left. apply pathsinv0. rewrite <- maponpathsinv0. use (pathscomp0 _ (transport_hz_section A x 1 (Diff x) _ _ (hzrplusminus i 1))). use transportf_paths. apply maponpaths. apply isasethz. Qed. Definition InvTranslationTranslationNatTrans_Mor (x : Complex A) : Morphism (TranslationComplex (InvTranslationComplex x)) x. Proof. use make_Morphism. - intros i. cbn. exact (transportf (precategory_morphisms ((x : Complex A) (i + 1 - 1))) (maponpaths (x : Complex A) (hzrplusminus i 1)) (identity ((x : Complex A) (i + 1 - 1)))). - exact (InvTranslationTranslationNatTrans_Eq1 x). Defined. Local Lemma InvTranslationTranslationNatTrans_isnattrans : is_nat_trans (functor_composite InvTranslationFunctor_Additive TranslationFunctor_Additive) (functor_identity (ComplexPreCat_Additive A)) (λ x : ComplexPreCat_Additive A, InvTranslationTranslationNatTrans_Mor x). Proof. intros x y f. use MorphismEq. intros i. cbn. induction (hzrplusminus i 1). cbn. rewrite id_right. rewrite id_left. apply idpath. Qed. Definition InvTranslationTranslationNatTrans : nat_trans (functor_composite InvTranslationFunctor_Additive TranslationFunctor_Additive) (functor_identity (ComplexPreCat_Additive A)). Proof. use make_nat_trans. - intros x. exact (InvTranslationTranslationNatTrans_Mor x). - exact InvTranslationTranslationNatTrans_isnattrans. Defined. Lemma TranslationInvTranslation_adjunction_eq1 (x : ob (ComplexPreCat_Additive A)) : (# TranslationFunctor_Additive (TranslationTranslationInvNatTrans x)) · (InvTranslationTranslationNatTrans (TranslationFunctor_Additive x)) = identity (TranslationFunctor_Additive x). Proof. use MorphismEq. intros i. cbn. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. assert (e : maponpaths (λ i0 : pr1 hz, (x : Complex A) (i0 + 1)) (hzrplusminus i 1) = maponpaths (x : Complex A) (maponpaths (λ i0 : hz, (i0 + 1)) (hzrplusminus i 1))). { induction (hzrplusminus i 1). apply idpath. } rewrite e. clear e. rewrite <- maponpathscomp0. assert (e : ! hzrminusplus (i + 1) 1 @ maponpaths (λ i0 : hz, i0 + 1) (hzrplusminus i 1) = idpath _) by apply isasethz. cbn in e. cbn. rewrite e. clear e. apply idpath. Qed. Lemma TranslationInvTranslation_adjunction_eq2 (x : ob (ComplexPreCat_Additive A)) : (TranslationTranslationInvNatTrans (InvTranslationFunctor_Additive x)) · (# InvTranslationFunctor_Additive (InvTranslationTranslationNatTrans x)) = identity (InvTranslationFunctor_Additive x). Proof. use MorphismEq. intros i. cbn. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. assert (e : maponpaths (λ i0 : pr1 hz, (x : Complex A) (i0 - 1)) (! hzrminusplus i 1) @ maponpaths (x : Complex A) (hzrplusminus (i - 1) 1) = idpath _). { assert (e1 : maponpaths (λ i0 : pr1 hz, (x : Complex A) (i0 - 1)) (! hzrminusplus i 1) = maponpaths (x : Complex A) (maponpaths (λ i0 : hz, (i0 - 1)) (! hzrminusplus i 1))). { induction (hzrminusplus i 1). apply idpath. } rewrite e1. rewrite <- maponpathscomp0. clear e1. assert (e2 : maponpaths (λ i0 : hz, i0 - 1) (! hzrminusplus i 1) @ hzrplusminus (i - 1) 1 = idpath _) by apply isasethz. rewrite e2. apply idpath. } cbn. cbn in e. rewrite e. clear e. apply idpath. Qed. Definition TranslationInvTranslation_adjunction : form_adjunction TranslationFunctor_Additive InvTranslationFunctor_Additive TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans. Proof. use make_form_adjunction. - intros x. exact (TranslationInvTranslation_adjunction_eq1 x). - intros x. exact (TranslationInvTranslation_adjunction_eq2 x). Qed. Local Lemma TranslationEquivUnitInvComm (a : Complex A) (i : hz) : transportf (precategory_morphisms (a (i - 1 + 1))) (maponpaths a (hzrminusplus i 1)) (identity (a (i - 1 + 1))) · Diff a i = transportf (precategory_morphisms (a (i - 1 + 1))) (maponpaths (λ i0 : pr1 hz, a (i0 + 1)) (hzrminusplus i 1 @ ! hzrplusminus i 1)) (to_inv (to_inv (Diff a (i - 1 + 1)))) · transportf (precategory_morphisms (a (i + 1 - 1 + 1))) (maponpaths a (hzrminusplus (i + 1) 1)) (identity (a (i + 1 - 1 + 1))). Proof. rewrite <- transport_target_postcompose. rewrite id_right. rewrite inv_inv_eq. assert (e : maponpaths (λ i0 : pr1 hz, a (i0 + 1)) (hzrminusplus i 1 @ ! hzrplusminus i 1) = maponpaths a (maponpaths (λ i0 : pr1 hz, i0 + 1) (hzrminusplus i 1 @ ! hzrplusminus i 1))). { induction (hzrminusplus i 1 @ ! hzrplusminus i 1). apply idpath. } rewrite e. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite transport_compose. rewrite id_left. apply pathsinv0. rewrite <- maponpathsinv0. set (tmp := transport_hz_section A (a : Complex A) 1 (Diff a) _ _ (hzrminusplus i 1)). cbn in tmp. use (pathscomp0 _ tmp). clear tmp. use transportf_paths. apply maponpaths. apply isasethz. Qed. Definition TranslationEquivUnitInv (a : ComplexPreCat_Additive A) : Morphism (InvTranslationFunctor (TranslationFunctor a)) a. Proof. use make_Morphism. - intros i. cbn. exact (transportf (precategory_morphisms ((a : Complex A) (i - 1 + 1))) (maponpaths (a : Complex A) (hzrminusplus i 1)) (identity _)). - intros i. cbn. exact (TranslationEquivUnitInvComm a i). Defined. Lemma TranslationEquiv_is_iso1_eq1 (a : ComplexPreCat_Additive A) : ((unit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) a) · (TranslationEquivUnitInv a) = identity _. Proof. use MorphismEq. intros i. cbn. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite pathsinv0l. apply idpath. Qed. Lemma TranslationEquiv_is_iso1_eq2 (a : ComplexPreCat_Additive A) : ((TranslationEquivUnitInv a) : (ComplexPreCat_Additive A)⟦_, _⟧) · ((unit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) a) = identity _. Proof. use MorphismEq. intros i. cbn. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. rewrite <- maponpathscomp0. rewrite pathsinv0r. apply idpath. Qed. Definition TranslationEquiv_is_iso1 (a : ComplexPreCat_Additive A) : is_z_isomorphism ((unit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) a). Proof. use make_is_z_isomorphism. - exact (TranslationEquivUnitInv a). - use make_is_inverse_in_precat. + exact (TranslationEquiv_is_iso1_eq1 a). + exact (TranslationEquiv_is_iso1_eq2 a). Defined. Local Lemma TranslationEquivCounitInvComm (a : ComplexPreCat_Additive A) (i : hz) : transportf (precategory_morphisms ((a : Complex A) i)) (maponpaths (a : Complex A) (! hzrplusminus i 1)) (identity ((a : Complex A) i)) · to_inv (transportf (precategory_morphisms ((a : Complex A) (i + 1 - 1))) (maponpaths (a : Complex A) (hzrminusplus (i + 1) 1 @ ! hzrplusminus (i + 1) 1)) (to_inv (Diff (a : Complex A) (i + 1 - 1)))) = Diff a i · transportf (precategory_morphisms ((a : Complex A) (i + 1))) (maponpaths (a : Complex A) (! hzrplusminus (i + 1) 1)) (identity ((a : Complex A) (i + 1))). Proof. rewrite <- transport_target_to_inv. rewrite inv_inv_eq. set (tmp' := transport_hz_source_target A (a : Complex A) 1 (Diff a) _ _ (hzrplusminus i 1)). cbn in tmp'. rewrite tmp'. clear tmp'. rewrite transport_source_target_comm. rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose. rewrite id_right. rewrite transport_f_f. rewrite transport_compose. rewrite id_left. rewrite <- maponpathsinv0. rewrite pathsinv0inv0. use transportf_paths. rewrite <- maponpathscomp0. apply maponpaths. apply isasethz. Qed. Definition TranslationEquivCounitInv (a : ComplexPreCat_Additive A) : Morphism a (TranslationFunctor (InvTranslationFunctor a)). Proof. use make_Morphism. - intros i. cbn. exact (transportf (precategory_morphisms ((a : Complex A) i)) (maponpaths (a : Complex A) (! hzrplusminus i 1)) (identity _)). - intros i. cbn. exact (TranslationEquivCounitInvComm a i). Defined. Lemma TranslationEquiv_is_iso2_eq1 (a : ComplexPreCat_Additive A) : ((counit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) a) · TranslationEquivCounitInv a = identity _. Proof. use MorphismEq. intros i. cbn. induction (hzrplusminus i 1). apply id_left. Qed. Lemma TranslationEquiv_is_iso2_eq2 (a : ComplexPreCat_Additive A) : ((TranslationEquivCounitInv a) : (ComplexPreCat_Additive A)⟦_, _⟧) · ((counit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) a) = identity _. Proof. use MorphismEq. intros i. cbn. induction (hzrplusminus i 1). apply id_left. Qed. Lemma TranslationEquiv_is_iso2 (b : ComplexPreCat_Additive A) : is_z_isomorphism ((counit_from_left_adjoint (make_are_adjoints _ _ TranslationTranslationInvNatTrans InvTranslationTranslationNatTrans TranslationInvTranslation_adjunction)) b). Proof. use make_is_z_isomorphism. - exact (TranslationEquivCounitInv b). - use make_is_inverse_in_precat. + exact (TranslationEquiv_is_iso2_eq1 b). + exact (TranslationEquiv_is_iso2_eq2 b). Defined. Definition TranslationEquiv : AddEquiv (ComplexPreCat_Additive A) (ComplexPreCat_Additive A). Proof. use make_AddEquiv. - exact TranslationFunctor_Additive. - exact InvTranslationFunctor_Additive. - use make_are_adjoints. + exact TranslationTranslationInvNatTrans. + exact InvTranslationTranslationNatTrans. + exact TranslationInvTranslation_adjunction. - exact TranslationEquiv_is_iso1. - exact TranslationEquiv_is_iso2. Defined. (** ** Translation functor for K(A) *) (** *** Image for the translation functor *) Definition TranslationFunctorHIm {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) : UU := ∑ (h : (ComplexHomot_Additive A)⟦TranslationComplex C1, TranslationComplex C2⟧), ∏ (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f), h = # (ComplexHomotFunctor A) (# TranslationFunctor f'). Definition TranslationFunctorHImMor {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : TranslationFunctorHIm f) : (ComplexHomot_Additive A)⟦TranslationComplex C1, TranslationComplex C2⟧ := pr1 h. Definition TranslationFunctorHImEq {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : TranslationFunctorHIm f) (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f) : TranslationFunctorHImMor h = # (ComplexHomotFunctor A) (# TranslationFunctor f') := pr2 h f' H. Definition make_TranslationFunctorHIm {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : (ComplexHomot_Additive A)⟦TranslationComplex C1, TranslationComplex C2⟧) (HH : ∏ (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f), h = # (ComplexHomotFunctor A) (# TranslationFunctor f')) : TranslationFunctorHIm f := tpair _ h HH. Lemma TranslationFunctorHImEquality {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h h' : TranslationFunctorHIm f) (e : TranslationFunctorHImMor h = TranslationFunctorHImMor h') : h = h'. Proof. use total2_paths_f. - exact e. - apply proofirrelevance. apply impred_isaprop. intros t0. apply impred_isaprop. intros H0. use to_has_homsets. Qed. (** *** Construction of the functor *) Lemma TranslationFunctor_eq {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H' : # (ComplexHomotFunctor A) f' = f) : # (ComplexHomotFunctor A) (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f H)) = # (ComplexHomotFunctor A) (# TranslationFunctor f'). Proof. use ComplexHomotFunctor_rel_mor. use TranslationFunctorPreservesHomotopies. use ComplexHomotFunctor_mor_rel. rewrite H'. apply hfiberpr2. Qed. Definition TranslationFunctorH_Mor_data {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) : TranslationFunctorHIm f. Proof. use make_TranslationFunctorHIm. - exact (# (ComplexHomotFunctor A) (# (TranslationFunctor) (hfiberpr1 _ _ H))). - intros f' H'. exact (TranslationFunctor_eq f H f' H'). Defined. Definition TranslationFunctorH_Mor {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) : iscontr (TranslationFunctorHIm f). Proof. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { apply isapropiscontr. } intros H. use make_iscontr. - exact (TranslationFunctorH_Mor_data f H). - intros t. use TranslationFunctorHImEquality. use TranslationFunctorHImEq. exact (hfiberpr2 _ _ H). Qed. Lemma TranslationFunctorH_Mor_unique {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) : iscontrpr1 (TranslationFunctorH_Mor f) = (TranslationFunctorH_Mor_data f H). Proof. use TranslationFunctorHImEquality. use TranslationFunctorHImEq. exact (hfiberpr2 _ _ H). Qed. Definition TranslationFunctorH_data : functor_data (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_functor_data. - intros C. exact (TranslationComplex C). - intros C1 C2 f. exact (TranslationFunctorHImMor (iscontrpr1 (TranslationFunctorH_Mor f))). Defined. Lemma TranslationFunctorH_Mor_Id : functor_idax TranslationFunctorH_data. Proof. intros C. use (pathscomp0 (TranslationFunctorHImEq (iscontrpr1 (TranslationFunctorH_Mor (identity C))) (identity _) (functor_id (ComplexHomotFunctor A) _))). rewrite functor_id. rewrite functor_id. apply idpath. Qed. Lemma TranslationFunctorH_Mor_Comp {C1 C2 C3 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) (g : (ComplexHomot_Additive A)⟦C2, C3⟧) : (TranslationFunctorHImMor (iscontrpr1 (TranslationFunctorH_Mor (f · g)))) = (TranslationFunctorHImMor (iscontrpr1 (TranslationFunctorH_Mor f))) · (TranslationFunctorHImMor (iscontrpr1 (TranslationFunctorH_Mor g))) . Proof. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj A g)). { use to_has_homsets. } intros g'. rewrite (TranslationFunctorHImEq (iscontrpr1 (TranslationFunctorH_Mor f)) _ (hfiberpr2 _ _ f')). rewrite (TranslationFunctorHImEq (iscontrpr1 (TranslationFunctorH_Mor g)) _ (hfiberpr2 _ _ g')). set (tmp := functor_comp (ComplexHomotFunctor A) (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f')) (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) g g'))). use (pathscomp0 _ tmp). clear tmp. set (tmp := functor_comp TranslationFunctor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g')). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use (TranslationFunctorHImEq (iscontrpr1 (TranslationFunctorH_Mor (f · g)))). rewrite functor_comp. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Definition TranslationFunctorH_is_functor : is_functor TranslationFunctorH_data. Proof. split. - exact TranslationFunctorH_Mor_Id. - intros C1 C2 C3 f g. exact (TranslationFunctorH_Mor_Comp f g). Qed. Definition TranslationFunctorH : functor (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_functor. - exact TranslationFunctorH_data. - exact TranslationFunctorH_is_functor. Defined. Lemma TranslationFunctorH_comm : functor_composite (ComplexHomotFunctor A) TranslationFunctorH = functor_composite TranslationFunctor (ComplexHomotFunctor A). Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. cbn. apply idpath. + intros C1 C2 f. unfold double_transport. rewrite idpath_transportf. rewrite idpath_transportf. assert (e1 : pr2 (pr1 (functor_composite (ComplexHomotFunctor A) TranslationFunctorH)) C1 C2 f = # TranslationFunctorH (# (ComplexHomotFunctor A) f)) by apply idpath. rewrite e1. clear e1. assert (e2 : pr2 (pr1 (functor_composite TranslationFunctor (ComplexHomotFunctor A))) C1 C2 f = # (ComplexHomotFunctor A) (# TranslationFunctor f)) by apply idpath. rewrite e2. clear e2. use (squash_to_prop (ComplexHomotFunctor_issurj A (# (ComplexHomotFunctor A) f))). { apply to_has_homsets. } intros f'. set (im := TranslationFunctorH_Mor_data (# (ComplexHomotFunctor A) f) f'). rewrite <- (@TranslationFunctorHImEq C1 C2 _ im f (idpath _)). use TranslationFunctorHImEq. exact (hfiberpr2 _ _ f'). Qed. Lemma TranslationFunctorH_Mor_Im {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (f' : hfiber # (ComplexHomotFunctor A) f) : # TranslationFunctorH f = # (ComplexHomotFunctor A) (# TranslationFunctor (hfiberpr1 _ _ f')). Proof. use TranslationFunctorHImEq. exact (hfiberpr2 _ _ f'). Qed. Lemma TranslationFunctorH_isAdditiveFunctor : isAdditiveFunctor TranslationFunctorH. Proof. use make_isAdditiveFunctor'. - intros C1 C2. use (pathscomp0 _ (@AdditiveFunctorZeroArrow (ComplexPreCat_Additive A) (ComplexHomot_Additive A) (ComplexHomotFunctor A) (TranslationFunctorH C1) (TranslationFunctorH C2))). set (tmp := (@AdditiveFunctorZeroArrow (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) TranslationFunctor_Additive C1 C2)). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use TranslationFunctorHImEq. use AdditiveFunctorZeroArrow. - intros C1 C2 f g. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { apply to_has_homsets. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj A g)). { apply to_has_homsets. } intros g'. rewrite (TranslationFunctorH_Mor_Im f f'). rewrite (TranslationFunctorH_Mor_Im g g'). use (pathscomp0 _ (AdditiveFunctorLinear (ComplexHomotFunctor A) (# TranslationFunctor (hfiberpr1 _ _ f')) (# TranslationFunctor (hfiberpr1 _ _ g')))). set (tmp := AdditiveFunctorLinear TranslationFunctor_Additive (hfiberpr1 _ _ f') (hfiberpr1 _ _ g')). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use TranslationFunctorHImEq. rewrite AdditiveFunctorLinear. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Definition TranslationFunctorH_AdditiveFunctor : AdditiveFunctor (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_AdditiveFunctor. - exact TranslationFunctorH. - exact TranslationFunctorH_isAdditiveFunctor. Defined. (** ** Inverse translation in K(A) *) Definition InvTranslationFunctorHIm {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) : UU := ∑ (h : (ComplexHomot_Additive A)⟦InvTranslationComplex C1, InvTranslationComplex C2⟧), ∏ (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f), h = # (ComplexHomotFunctor A) (# InvTranslationFunctor f'). Definition InvTranslationFunctorHImMor {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : InvTranslationFunctorHIm f) : (ComplexHomot_Additive A)⟦InvTranslationComplex C1, InvTranslationComplex C2⟧ := pr1 h. Definition InvTranslationFunctorHImEq {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : InvTranslationFunctorHIm f) (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f) : InvTranslationFunctorHImMor h = # (ComplexHomotFunctor A) (# InvTranslationFunctor f') := pr2 h f' H. Definition make_InvTranslationFunctorHIm {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h : (ComplexHomot_Additive A)⟦InvTranslationComplex C1, InvTranslationComplex C2⟧) (HH : ∏ (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : # (ComplexHomotFunctor A) f' = f), h = # (ComplexHomotFunctor A) (# InvTranslationFunctor f')) : InvTranslationFunctorHIm f := tpair _ h HH. Lemma InvTranslationFunctorHImEquality {C1 C2 : ComplexHomot_Additive A} {f : (ComplexHomot_Additive A)⟦C1, C2⟧} (h h' : InvTranslationFunctorHIm f) (e : InvTranslationFunctorHImMor h = InvTranslationFunctorHImMor h') : h = h'. Proof. use total2_paths_f. - exact e. - apply proofirrelevance. apply impred_isaprop. intros t0. apply impred_isaprop. intros H0. use to_has_homsets. Qed. (** *** Construction of the functor *) Lemma InvTranslationFunctor_eq {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) (f' : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H' : # (ComplexHomotFunctor A) f' = f) : # (ComplexHomotFunctor A) (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f H)) = # (ComplexHomotFunctor A) (# InvTranslationFunctor f'). Proof. use ComplexHomotFunctor_rel_mor. use InvTranslationFunctorPreservesHomotopies. use ComplexHomotFunctor_mor_rel. rewrite H'. apply hfiberpr2. Qed. Definition InvTranslationFunctorH_Mor_data {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) : InvTranslationFunctorHIm f. Proof. use make_InvTranslationFunctorHIm. - exact (# (ComplexHomotFunctor A) (# (InvTranslationFunctor) (hfiberpr1 _ _ H))). - intros f' H'. exact (InvTranslationFunctor_eq f H f' H'). Defined. Definition InvTranslationFunctorH_Mor {C1 C2 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) : iscontr (InvTranslationFunctorHIm f). Proof. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { apply isapropiscontr. } intros H. use make_iscontr. - exact (InvTranslationFunctorH_Mor_data f H). - intros t. use InvTranslationFunctorHImEquality. use InvTranslationFunctorHImEq. exact (hfiberpr2 _ _ H). Qed. Lemma InvTranslationFunctorH_Mor_unique {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (H : hfiber # (ComplexHomotFunctor A) f) : iscontrpr1 (InvTranslationFunctorH_Mor f) = (InvTranslationFunctorH_Mor_data f H). Proof. use InvTranslationFunctorHImEquality. use InvTranslationFunctorHImEq. exact (hfiberpr2 _ _ H). Qed. Definition InvTranslationFunctorH_data : functor_data (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_functor_data. - intros C. exact (InvTranslationComplex C). - intros C1 C2 f. exact (InvTranslationFunctorHImMor (iscontrpr1 (InvTranslationFunctorH_Mor f))). Defined. Lemma InvTranslationFunctorH_Mor_Id : functor_idax InvTranslationFunctorH_data. Proof. intros C. use (pathscomp0 (InvTranslationFunctorHImEq (iscontrpr1 (InvTranslationFunctorH_Mor (identity C))) (identity _) (functor_id (ComplexHomotFunctor A) _))). rewrite functor_id. rewrite functor_id. apply idpath. Qed. Lemma InvTranslationFunctorH_Mor_Comp {C1 C2 C3 : ComplexHomot_Additive A} (f : (ComplexHomot_Additive A)⟦C1, C2⟧) (g : (ComplexHomot_Additive A)⟦C2, C3⟧) : (InvTranslationFunctorHImMor (iscontrpr1 (InvTranslationFunctorH_Mor (f · g)))) = (InvTranslationFunctorHImMor (iscontrpr1 (InvTranslationFunctorH_Mor f))) · (InvTranslationFunctorHImMor (iscontrpr1 (InvTranslationFunctorH_Mor g))) . Proof. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj A g)). { use to_has_homsets. } intros g'. rewrite (InvTranslationFunctorHImEq (iscontrpr1 (InvTranslationFunctorH_Mor f)) _ (hfiberpr2 _ _ f')). rewrite (InvTranslationFunctorHImEq (iscontrpr1 (InvTranslationFunctorH_Mor g)) _ (hfiberpr2 _ _ g')). set (tmp := functor_comp (ComplexHomotFunctor A) (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f')) (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) g g'))). use (pathscomp0 _ tmp). clear tmp. set (tmp := functor_comp InvTranslationFunctor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g')). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use (InvTranslationFunctorHImEq (iscontrpr1 (InvTranslationFunctorH_Mor (f · g)))). rewrite functor_comp. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Definition InvTranslationFunctorH_is_functor : is_functor InvTranslationFunctorH_data. Proof. split. - exact InvTranslationFunctorH_Mor_Id. - intros C1 C2 C3 f g. exact (InvTranslationFunctorH_Mor_Comp f g). Qed. Definition InvTranslationFunctorH : functor (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_functor. - exact InvTranslationFunctorH_data. - exact InvTranslationFunctorH_is_functor. Defined. Lemma InvTranslationFunctorH_comm : functor_composite (ComplexHomotFunctor A) InvTranslationFunctorH = functor_composite InvTranslationFunctor (ComplexHomotFunctor A). Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. cbn. apply idpath. + intros C1 C2 f. unfold double_transport. rewrite idpath_transportf. rewrite idpath_transportf. assert (e1 : pr2 (pr1 (functor_composite (ComplexHomotFunctor A) InvTranslationFunctorH)) C1 C2 f = # InvTranslationFunctorH (# (ComplexHomotFunctor A) f)) by apply idpath. rewrite e1. clear e1. assert (e2 : pr2 (pr1 (functor_composite InvTranslationFunctor (ComplexHomotFunctor A))) C1 C2 f = # (ComplexHomotFunctor A) (# InvTranslationFunctor f)) by apply idpath. rewrite e2. clear e2. use (squash_to_prop (ComplexHomotFunctor_issurj A (# (ComplexHomotFunctor A) f))). { apply to_has_homsets. } intros f'. set (im := InvTranslationFunctorH_Mor_data (# (ComplexHomotFunctor A) f) f'). rewrite <- (@InvTranslationFunctorHImEq C1 C2 _ im f (idpath _)). use InvTranslationFunctorHImEq. exact (hfiberpr2 _ _ f'). Qed. Lemma InvTranslationFunctorH_Mor_Im {C1 C2 : ob (ComplexHomot_Additive A)} (f : ComplexHomot_Additive A ⟦C1, C2⟧) (f' : hfiber # (ComplexHomotFunctor A) f) : # InvTranslationFunctorH f = # (ComplexHomotFunctor A) (# InvTranslationFunctor (hfiberpr1 _ _ f')). Proof. use InvTranslationFunctorHImEq. exact (hfiberpr2 _ _ f'). Qed. Lemma InvTranslationFunctorH_isAdditiveFunctor : isAdditiveFunctor InvTranslationFunctorH. Proof. use make_isAdditiveFunctor'. - intros C1 C2. use (pathscomp0 _ (@AdditiveFunctorZeroArrow (ComplexPreCat_Additive A) (ComplexHomot_Additive A) (ComplexHomotFunctor A) (InvTranslationFunctorH C1) (InvTranslationFunctorH C2))). set (tmp := (@AdditiveFunctorZeroArrow (ComplexPreCat_Additive A) (ComplexPreCat_Additive A) InvTranslationFunctor_Additive C1 C2)). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use InvTranslationFunctorHImEq. use AdditiveFunctorZeroArrow. - intros C1 C2 f g. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { apply to_has_homsets. } intros f'. use (squash_to_prop (ComplexHomotFunctor_issurj A g)). { apply to_has_homsets. } intros g'. rewrite (InvTranslationFunctorH_Mor_Im f f'). rewrite (InvTranslationFunctorH_Mor_Im g g'). use (pathscomp0 _ (AdditiveFunctorLinear (ComplexHomotFunctor A) (# InvTranslationFunctor (hfiberpr1 _ _ f')) (# InvTranslationFunctor (hfiberpr1 _ _ g')))). set (tmp := AdditiveFunctorLinear InvTranslationFunctor_Additive (hfiberpr1 _ _ f') (hfiberpr1 _ _ g')). apply (maponpaths (# (ComplexHomotFunctor A))) in tmp. use (pathscomp0 _ tmp). clear tmp. use InvTranslationFunctorHImEq. rewrite AdditiveFunctorLinear. rewrite (hfiberpr2 _ _ f'). rewrite (hfiberpr2 _ _ g'). apply idpath. Qed. Definition InvTranslationFunctorH_AdditiveFunctor : AdditiveFunctor (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_AdditiveFunctor. - exact InvTranslationFunctorH. - exact InvTranslationFunctorH_isAdditiveFunctor. Defined. (** Translation functors in K(A) are isomorphisms and inverse to each other. *) Lemma transport_target_ComplexHomotFunctor {C1 C2 C2' : Complex A} (e : C2 = C2') (f : Morphism C1 C2) : # (ComplexHomotFunctor A) (transportf (λ x : Complex A, Morphism C1 x) e f) = transportf (λ x : Complex A, (ComplexHomot_Additive A)⟦C1, x⟧) e (# (ComplexHomotFunctor A) f). Proof. induction e. apply idpath. Qed. Lemma transport_source_ComplexHomotFunctor {C1' C1 C2 : Complex A} (e : C1' = C1) (f : Morphism C1' C2) : # (ComplexHomotFunctor A) (transportf (λ x : Complex A, Morphism x C2) e f) = transportf (λ x : Complex A, (ComplexHomot_Additive A)⟦x, C2⟧) e (# (ComplexHomotFunctor A) f). Proof. induction e. apply idpath. Qed. Lemma TranslationHInvTranslationH : functor_composite TranslationFunctorH InvTranslationFunctorH = functor_identity _. Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. cbn. use ComplexEq. * intros i. cbn. apply maponpaths. apply (hzrminusplus i 1). * intros i. cbn. exact (TranslationInvTranslation_eq1 C i). + intros C1 C2 f. unfold double_transport. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. cbn. rewrite (TranslationFunctorH_Mor_unique _ f'). use (squash_to_prop (ComplexHomotFunctor_issurj A (TranslationFunctorHImMor (TranslationFunctorH_Mor_data f f')))). { use (@to_has_homsets (ComplexHomot_Additive A)). } intros f''. rewrite (InvTranslationFunctorH_Mor_unique _ f''). rewrite <- (hfiberpr2 _ _ f'). rewrite <- (TranslationInvTranslation_eq2 (hfiberpr1 # (ComplexHomotFunctor A) f f')). rewrite transport_target_ComplexHomotFunctor. rewrite transport_source_ComplexHomotFunctor. apply maponpaths. apply maponpaths. assert (e1 : # (ComplexHomotFunctor A) (InvTranslationMorphism (TranslationComplex C1) (TranslationComplex C2) (TranslationMorphism C1 C2 (hfiberpr1 # (ComplexHomotFunctor A) f f'))) = # InvTranslationFunctorH (# (ComplexHomotFunctor A) (TranslationMorphism C1 C2 (hfiberpr1 # (ComplexHomotFunctor A) f f')))). { apply pathsinv0. use InvTranslationFunctorHImEq. apply idpath. } use (pathscomp0 _ (! e1)). clear e1. apply pathsinv0. use InvTranslationFunctorHImEq. set (tmp := hfiberpr2 _ _ f''). rewrite tmp. clear tmp. use TranslationFunctorHImEq. apply (hfiberpr2 _ _ f'). Qed. Lemma InvTranslationHTranslationH : functor_composite InvTranslationFunctorH TranslationFunctorH = functor_identity _. Proof. use functor_eq. - apply to_has_homsets. - use functor_data_eq. + intros C. cbn. use ComplexEq. * intros i. cbn. apply maponpaths. apply (hzrplusminus i 1). * intros i. cbn. exact (InvTranslationTranslation_eq1 C i). + intros C1 C2 f. unfold double_transport. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. cbn. rewrite (InvTranslationFunctorH_Mor_unique _ f'). use (squash_to_prop (ComplexHomotFunctor_issurj A (InvTranslationFunctorHImMor (InvTranslationFunctorH_Mor_data f f')))). { use (@to_has_homsets (ComplexHomot_Additive A)). } intros f''. rewrite (TranslationFunctorH_Mor_unique _ f''). rewrite <- (hfiberpr2 _ _ f'). rewrite <- (InvTranslationTranslation_eq2 (hfiberpr1 # (ComplexHomotFunctor A) f f')). rewrite transport_target_ComplexHomotFunctor. rewrite transport_source_ComplexHomotFunctor. apply maponpaths. apply maponpaths. assert (e1 : # (ComplexHomotFunctor A) (TranslationMorphism (InvTranslationComplex C1) (InvTranslationComplex C2) (InvTranslationMorphism C1 C2 (hfiberpr1 # (ComplexHomotFunctor A) f f'))) = # TranslationFunctorH (# (ComplexHomotFunctor A) (InvTranslationMorphism C1 C2 (hfiberpr1 # (ComplexHomotFunctor A) f f')))). { apply pathsinv0. use TranslationFunctorHImEq. apply idpath. } use (pathscomp0 _ (! e1)). clear e1. apply pathsinv0. use TranslationFunctorHImEq. set (tmp := hfiberpr2 _ _ f''). rewrite tmp. clear tmp. use InvTranslationFunctorHImEq. apply (hfiberpr2 _ _ f'). Qed. (** ** Translation equivalence for K(A) *) Local Lemma TranslationHInvTranslationHNatTrans_isnattrans : is_nat_trans (functor_identity (ComplexHomot_Additive A)) (functor_composite TranslationFunctorH_AdditiveFunctor InvTranslationFunctorH_AdditiveFunctor) (λ x : ComplexHomot_Additive A, # (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x)). Proof. intros x y f. Local Opaque precategory_morphisms InvTranslationFunctorHIm TranslationFunctorHIm ComplexHomotFunctor compose InvTranslationFunctorH TranslationFunctorH TranslationFunctor InvTranslationFunctor. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. cbn. set (tmp := TranslationFunctorH_Mor_Im f f'). cbn in tmp. rewrite tmp. clear tmp. set (f'' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f'))) (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f')) (idpath _)). set (tmp := InvTranslationFunctorH_Mor_Im _ f''). apply (maponpaths (compose (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x)))) in tmp. use (pathscomp0 _ (! tmp)). clear tmp. cbn. set (tmp := functor_comp (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x) (# InvTranslationFunctor (# TranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f')))). use (pathscomp0 _ tmp). clear tmp. set (tmp := hfiberpr2 _ _ f'). clear f''. apply (maponpaths (postcompose (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor y)))) in tmp. use (pathscomp0 (! tmp)). clear tmp. unfold postcompose. rewrite <- functor_comp. apply maponpaths. set (tmp := TranslationTranslationInvNatTrans_isnattrans x y (hfiberpr1 _ _ f')). cbn in tmp. exact tmp. Qed. Definition TranslationHTranslationInvHNatTrans : nat_trans (functor_identity (ComplexHomot_Additive A)) (functor_composite TranslationFunctorH_AdditiveFunctor InvTranslationFunctorH_AdditiveFunctor). Proof. use make_nat_trans. - intros x. exact (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x)). - exact TranslationHInvTranslationHNatTrans_isnattrans. Defined. Local Lemma InvTranslationHTranslationHNatTrans_isnattrans : is_nat_trans (functor_composite InvTranslationFunctorH_AdditiveFunctor TranslationFunctorH_AdditiveFunctor) (functor_identity (ComplexHomot_Additive A)) (λ x : ComplexHomot_Additive A, # (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x)). Proof. intros x y f. Local Opaque precategory_morphisms InvTranslationFunctorHIm TranslationFunctorHIm ComplexHomotFunctor compose InvTranslationFunctorH TranslationFunctorH TranslationFunctor InvTranslationFunctor. use (squash_to_prop (ComplexHomotFunctor_issurj A f)). { use to_has_homsets. } intros f'. cbn. set (tmp := InvTranslationFunctorH_Mor_Im f f'). cbn in tmp. rewrite tmp. clear tmp. set (f'' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f'))) (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f')) (idpath _)). set (tmp := TranslationFunctorH_Mor_Im _ f''). apply (maponpaths (postcompose (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor y)))) in tmp. use (pathscomp0 tmp). clear tmp. cbn. unfold postcompose. set (tmp := functor_comp (ComplexHomotFunctor A) (# TranslationFunctor (# InvTranslationFunctor (hfiberpr1 # (ComplexHomotFunctor A) f f'))) (InvTranslationTranslationNatTrans_Mor y)). use (pathscomp0 (! tmp)). clear tmp. set (tmp := hfiberpr2 _ _ f'). clear f''. apply (maponpaths (compose (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x)))) in tmp. use (pathscomp0 _ tmp). clear tmp. rewrite <- functor_comp. apply maponpaths. set (tmp := InvTranslationTranslationNatTrans_isnattrans x y (hfiberpr1 _ _ f')). cbn in tmp. exact tmp. Qed. Definition InvTranslationHTranslationHNatTrans : nat_trans (functor_composite InvTranslationFunctorH_AdditiveFunctor TranslationFunctorH_AdditiveFunctor) (functor_identity (ComplexHomot_Additive A)). Proof. use make_nat_trans. - intros x. exact (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x)). - exact InvTranslationHTranslationHNatTrans_isnattrans. Defined. Local Opaque precategory_morphisms InvTranslationFunctorHIm TranslationFunctorHIm ComplexHomotFunctor compose InvTranslationFunctorH TranslationFunctorH TranslationFunctor InvTranslationFunctor identity. Lemma TranslationHInvTranslationH_adjunction_eq1 (x : ComplexHomot_Additive A) : # TranslationFunctorH (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x)) · # (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor (TranslationFunctorH x)) = identity (TranslationFunctorH x). Proof. use (pathscomp0 _ (functor_id TranslationFunctorH_AdditiveFunctor x)). set (tmp := functor_id (ComplexHomotFunctor A) x). apply (maponpaths (# TranslationFunctorH_AdditiveFunctor)) in tmp. use (pathscomp0 _ tmp). clear tmp. cbn. set (f' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x)) (TranslationTranslationInvNatTrans_Mor x) (idpath _)). set (tmp := TranslationFunctorH_Mor_Im _ f'). apply (maponpaths (postcompose (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor (TranslationFunctorH x))))) in tmp. use (pathscomp0 tmp). clear tmp. unfold postcompose. set (id' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (identity _)) (identity (x : ob (ComplexPreCat_Additive A))) (idpath _)). set (tmp := TranslationFunctorH_Mor_Im _ id'). use (pathscomp0 _ (! tmp)). clear tmp. cbn. clear id'. set (tmp := functor_comp (ComplexHomotFunctor A) (# TranslationFunctor (TranslationTranslationInvNatTrans_Mor x)) (InvTranslationTranslationNatTrans_Mor (TranslationFunctorH x))). use (pathscomp0 (! tmp)). clear tmp. apply maponpaths. Local Transparent TranslationFunctorH. cbn. set (tmp := TranslationInvTranslation_adjunction_eq1 x). cbn in tmp. use (pathscomp0 tmp). clear tmp. apply pathsinv0. use (functor_id TranslationFunctor). Qed. Lemma TranslationHInvTranslationH_adjunction_eq2 (x : ComplexHomot_Additive A) : # (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor (InvTranslationFunctorH x)) · # InvTranslationFunctorH (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x)) = identity (InvTranslationFunctorH x). Proof. use (pathscomp0 _ (functor_id InvTranslationFunctorH_AdditiveFunctor x)). set (tmp := functor_id (ComplexHomotFunctor A) x). apply (maponpaths (# InvTranslationFunctorH_AdditiveFunctor)) in tmp. use (pathscomp0 _ tmp). clear tmp. set (f' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x)) (InvTranslationTranslationNatTrans_Mor x) (idpath _)). set (tmp := InvTranslationFunctorH_Mor_Im _ f'). apply (maponpaths (compose (# (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor (InvTranslationFunctorH x))))) in tmp. use (pathscomp0 tmp). clear tmp. set (id' := @make_hfiber _ _ (# (ComplexHomotFunctor A)) (# (ComplexHomotFunctor A) (identity _)) (identity (x : ob (ComplexPreCat_Additive A))) (idpath _)). set (tmp := InvTranslationFunctorH_Mor_Im _ id'). use (pathscomp0 _ (! tmp)). clear tmp. cbn. clear id'. set (tmp := functor_comp (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor (InvTranslationFunctorH x)) (# InvTranslationFunctor (InvTranslationTranslationNatTrans_Mor x))). use (pathscomp0 (! tmp)). clear tmp. apply maponpaths. Local Transparent InvTranslationFunctorH. cbn. set (tmp := TranslationInvTranslation_adjunction_eq2 x). cbn in tmp. use (pathscomp0 tmp). clear tmp. apply pathsinv0. use (functor_id InvTranslationFunctor). Qed. Definition TranslationHInvTranslationH_adjunction : form_adjunction TranslationFunctorH_AdditiveFunctor InvTranslationFunctorH_AdditiveFunctor TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans. Proof. use make_form_adjunction. - intros x. exact (TranslationHInvTranslationH_adjunction_eq1 x). - intros x. exact (TranslationHInvTranslationH_adjunction_eq2 x). Qed. Local Lemma TranslationHEquiv_is_iso1_eq1' (x : ComplexHomot_Additive A) : (unit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x · # (ComplexHomotFunctor A) (TranslationEquivUnitInv x) = identity ((functor_identity (ComplexHomot_Additive A)) x). Proof. cbn. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) (TranslationTranslationInvNatTrans_Mor x) (TranslationEquivUnitInv x)))). use (pathscomp0 _ (functor_id (ComplexHomotFunctor A) x)). apply maponpaths. exact (TranslationEquiv_is_iso1_eq1 x). Qed. Local Lemma TranslationHEquiv_is_iso1_eq2' (x : ComplexHomot_Additive A) : (# (ComplexHomotFunctor A) (TranslationEquivUnitInv x)) · (unit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x = identity _. Proof. cbn. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) (TranslationEquivUnitInv x) (TranslationTranslationInvNatTrans_Mor x)))). use (pathscomp0 _ (functor_id (ComplexHomotFunctor A) _)). apply maponpaths. exact (TranslationEquiv_is_iso1_eq2 x). Qed. Definition TranslationHEquiv_is_iso1 (x : ComplexHomot_Additive A) : is_z_isomorphism ((unit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) (TranslationEquivUnitInv x)). - use make_is_inverse_in_precat. + exact (TranslationHEquiv_is_iso1_eq1' x). + exact (TranslationHEquiv_is_iso1_eq2' x). Defined. Local Lemma TranslationHEquiv_is_iso2_eq1' (x : ComplexHomot_Additive A) : (counit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x · # (ComplexHomotFunctor A) (TranslationEquivCounitInv x) = identity _. Proof. cbn. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) (InvTranslationTranslationNatTrans_Mor x) (TranslationEquivCounitInv x)))). use (pathscomp0 _ (functor_id (ComplexHomotFunctor A) _)). apply maponpaths. exact (TranslationEquiv_is_iso2_eq1 x). Qed. Local Lemma TranslationHEquiv_is_iso2_eq2' (x : ComplexHomot_Additive A) : (# (ComplexHomotFunctor A) (TranslationEquivCounitInv x)) · (counit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x = identity _. Proof. cbn. use (pathscomp0 (! (functor_comp (ComplexHomotFunctor A) (TranslationEquivCounitInv x) (InvTranslationTranslationNatTrans_Mor x)))). use (pathscomp0 _ (functor_id (ComplexHomotFunctor A) _)). apply maponpaths. exact (TranslationEquiv_is_iso2_eq2 x). Qed. Definition TranslationHEquiv_is_iso2 (x : ComplexHomot_Additive A) : is_z_isomorphism ((counit_from_left_adjoint (make_are_adjoints _ _ TranslationHTranslationInvHNatTrans InvTranslationHTranslationHNatTrans TranslationHInvTranslationH_adjunction)) x). Proof. use make_is_z_isomorphism. - exact (# (ComplexHomotFunctor A) (TranslationEquivCounitInv x)). - use make_is_inverse_in_precat. + exact (TranslationHEquiv_is_iso2_eq1' x). + exact (TranslationHEquiv_is_iso2_eq2' x). Defined. Definition TranslationHEquiv : AddEquiv (ComplexHomot_Additive A) (ComplexHomot_Additive A). Proof. use make_AddEquiv. - exact TranslationFunctorH_AdditiveFunctor. - exact InvTranslationFunctorH_AdditiveFunctor. - use make_are_adjoints. + exact TranslationHTranslationInvHNatTrans. + exact InvTranslationHTranslationHNatTrans. + exact TranslationHInvTranslationH_adjunction. - intros x. exact (TranslationHEquiv_is_iso1 x). - intros x. exact (TranslationHEquiv_is_iso2 x). Defined. End translation_functor. UniMath-20231010/UniMath/HomologicalAlgebra/Triangulated.v000066400000000000000000002625731451125700300232200ustar00rootroot00000000000000(** * Triangulated categories *) (** ** Contents - Triangles, rotations of triangles, and cones - Pretriangulated data - Distinguished triangles (DTri) and extensions - Pretriangulated categories - Triangulated categories - Rotations of morphisms and extensions - Composition of consecutive morphisms in DTri is 0 - Exact sequences associated to a distinguished triangle - Five lemma for distinguished triangles - Change of triangles in octahedral axiom *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Monoids. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.zero. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.equalizers. Require Import UniMath.CategoryTheory.limits.coequalizers. Require Import UniMath.CategoryTheory.limits.kernels. Require Import UniMath.CategoryTheory.limits.cokernels. Require Import UniMath.CategoryTheory.limits.pushouts. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.limits.BinDirectSums. Require Import UniMath.CategoryTheory.Monics. Require Import UniMath.CategoryTheory.Epis. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Abelian. Require Import UniMath.CategoryTheory.ShortExactSequences. Require Import UniMath.CategoryTheory.categories.abgrs. Require Import UniMath.CategoryTheory.CategoriesWithBinOps. Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops. Require Import UniMath.CategoryTheory.PreAdditive. Require Import UniMath.CategoryTheory.Additive. Require Import UniMath.CategoryTheory.Morphisms. Require Import UniMath.CategoryTheory.AdditiveFunctors. Require Import UniMath.CategoryTheory.FiveLemma. Unset Kernel Term Sharing. (** * Triangulated categories *) (** ** Introduction A triangulated category Tr consists of an additive category A together with the following data - An additive equivalence T : A -> A, called a translation functor. - A collection of triangles in A, that is, a collection of diagrams of the form X -f-> Y -g-> Z -h-> X[1] which are called distinguished triangles. Such a diagram is denoted by (X, Y, Z, f, g, h). and these data must satisfy the following conditions (TR1) For all objects X of A the triangle (X, X, 0, Id_X, 0, 0) is distinguished. (TR2) Any triangle isomorphic to a distinguished triangle is a distinguished triangle. (TR3) A triangle (X, Y, Z, f, g, h) is distinguished if and only if the rotated triangle (Y, Z, T X, g, h, - T f) is distinguished. (TR4) For any morphism f : X --> Y one has a triangle (X, Y, Z, f, g, h) for some object Z and morphisms g and h. The object Z is called the cone of f. (TR5) Suppose you have two distinguished triangle (X, Y, Z, f, g, h) and (X', Y', Z', f', g', h') and morphisms φ1 : X --> X' and φ2 : Y --> Y' such that the following diagram is commutative X -f-> Y -g-> Z -h-> X[1] φ1 | φ2 | X' -f-> Y' -g-> Z' -h-> X'[1] Then there exists a morphism φ3 : Z --> Z' such that the following diagram is commutative X -f-> Y -g-> Z -h-> X[1] φ1 | φ2 | φ3 | φ1[1] | X' -f-> Y' -g-> Z' -h'-> X'[1]. Such a commutative diagram is called a morphism of triangles. (TR6) (Octahedral axiom). Suppose you have 3 distinguished triangles (X1, Y1, Z2, f, g, h), (Y1, Z1, X2, f', g', h'), and (X1, Z1, Y2, f · f', g'', h''). Then there exists a distinguished triangle (Z2, Y2, X2, f''', g''', h'' · g[1]) such that the following diagram is commutative X1 ----f----> Y1 ----g----> Z2 ----h----> X1[1] || | | || || f' | f''' | || || | | || X1 -f·f'-> Z1 --g''--> Y2 ----h''---> X1[1] | | | g' | g''' | f[1] | | | | X2 ======== X2 ----h'----> Y1[1] | | h' | h'·g[1] | | | Y1[1] --g[1]-> Z2[1] This version of octahedral axiom corresponds to Axiom D of http://math-www.uni-paderborn.de/user/hubery/static/Octahedral.pdf We call the data for triangulated category which satisfies (TR1)-(TR5) a pretriangulated category. *) Local Opaque ishinh. (** * Basic notions *) (** ** Introduction In this section we define - Triangles. Diagrams of the form X -f-> Y -g-> Z -h-> X[1] - Morphisms of triangles. Commutative diagrams of the form X -f-> Y -g-> Z -h-> X[1] φ1 | φ2 | φ3 | φ1[1] | X' -f-> Y' -g-> Z' -h-> X'[1]. - Rotations of triangles. Rotation of X -f-> Y -g-> Z -h-> X[1] is the triangle Y -g-> Z -h-> X[1] -(-f[1])-> Y[1] - Inverse rotation of triangle. Inverse rotation of X -f-> Y -g-> Z -h-> X[1] is the triangle Z[-1] -(-h[-1])-> X -f-> Y -g-> Z - Rotations of morphisms. Let X -f-> Y -g-> Z -h-> X[1] φ1 | φ2 | φ3 | φ1[1] | X' -f-> Y' -g-> Z' -h'-> X'[1]. be a morphism of triangles. Then Y -g-> Z -h-> X[1] -f[1]-> Y[1] φ2 | φ3 | φ1[1] | φ2[1] | Y' -g-> Z' -h-> X'[1] -f[1]-> Y'[1]. is the rotation of the morphism. Similarly for inverse rotations of morphisms. - ConeData to triangles. A ConeData for a morphism f : x --> y consists of - An object z - A morphism y --> z - A morphism z --> x[1] *) Section def_triangles. Context {A : CategoryWithAdditiveStructure}. Context {T : AddEquiv A A}. (** ** Triangles *) Definition Tri : UU := ∑ MP : MorphismPair A, A⟦Ob3 MP, (AddEquiv1 T) (Ob1 MP)⟧. Definition make_Tri {x y z : ob A} (f : x --> y) (g : y --> z) (h : A⟦z, (AddEquiv1 T x)⟧) : Tri := (make_MorphismPair f g),,h. Definition TriMP (D : Tri) : MorphismPair A := pr1 D. Coercion TriMP : Tri >-> MorphismPair. (** Follows the naming convention Mor1, Mor2, for MorphismPair *) Definition Mor3 (D : Tri) : A⟦Ob3 D, (AddEquiv1 T) (Ob1 D)⟧ := pr2 D. (** ** Morphisms of triangles *) Definition TriMor (D1 D2 : Tri) : UU := ∑ (M : MPMor D1 D2), (MPMor3 M) · (Mor3 D2) = (Mor3 D1) · (# (AddEquiv1 T) (MPMor1 M)). Definition make_TriMor {D1 D2 : Tri} (M : MPMor D1 D2) (H : (MPMor3 M) · (Mor3 D2) = (Mor3 D1) · (# (AddEquiv1 T) (MPMor1 M))) : TriMor D1 D2 := (M,,H). Definition TriMor_Mors {D1 D2 : Tri} (DTM : TriMor D1 D2) : MPMor D1 D2 := pr1 DTM. Coercion TriMor_Mors : TriMor >-> MPMor. Local Lemma TriMorId_comms {x y : ob A} (f : x --> y) : identity x · f = f · identity y. Proof. rewrite id_left. rewrite id_right. apply idpath. Qed. Local Lemma TriMorId_comm3 (D : Tri) : identity (Ob3 D) · Mor3 D = Mor3 D · # (AddEquiv1 T) (identity (Ob1 D)). Proof. rewrite functor_id. rewrite id_left. rewrite id_right. apply idpath. Qed. Definition TriMorId (D : Tri) : TriMor D D. Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (identity _). * exact (identity _). * exact (identity _). + use make_MPMorComms. * exact (TriMorId_comms _). * exact (TriMorId_comms _). - exact (TriMorId_comm3 D). Defined. Definition DComm3 {D1 D2 : Tri} (TM : TriMor D1 D2) : (MPMor3 TM) · (Mor3 D2) = (Mor3 D1) · (# (AddEquiv1 T) (MPMor1 TM)) := pr2 TM. (** *** Composition of morphisms is a morphism *) Local Lemma TriMor_comp_comms {D1 D2 D3 : Tri} (TM1 : TriMor D1 D2) (TM2 : TriMor D2 D3) : MPMorComms (make_MPMorMors (MPMor1 TM1 · MPMor1 TM2) (MPMor2 TM1 · MPMor2 TM2) (MPMor3 TM1 · MPMor3 TM2)). Proof. use make_MPMorComms. - cbn. rewrite <- assoc. rewrite (MPComm1 TM2). rewrite assoc. rewrite (MPComm1 TM1). rewrite assoc. apply idpath. - cbn. rewrite <- assoc. rewrite (MPComm2 TM2). rewrite assoc. rewrite (MPComm2 TM1). rewrite assoc. apply idpath. Qed. Local Lemma TriMor_comp_comm3 {D1 D2 D3 : Tri} (TM1 : TriMor D1 D2) (TM2 : TriMor D2 D3) : MPMor3 TM1 · MPMor3 TM2 · Mor3 D3 = Mor3 D1 · # (AddEquiv1 T) (MPMor1 TM1 · MPMor1 TM2). Proof. rewrite <- assoc. rewrite (DComm3 TM2). rewrite assoc. rewrite (DComm3 TM1). rewrite <- assoc. rewrite <- functor_comp. apply idpath. Qed. Definition TriMor_comp {D1 D2 D3 : Tri} (TM1 : TriMor D1 D2) (TM2 : TriMor D2 D3) : TriMor D1 D3. Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (MPMor1 TM1 · MPMor1 TM2). * exact (MPMor2 TM1 · MPMor2 TM2). * exact (MPMor3 TM1 · MPMor3 TM2). + exact (TriMor_comp_comms TM1 TM2). - exact (TriMor_comp_comm3 TM1 TM2). Defined. (** ** is isomorphism *) Definition TriMor_is_iso {D1 D2 : Tri} (M : TriMor D1 D2) : UU := (is_z_isomorphism (MPMor1 M)) × (is_z_isomorphism (MPMor2 M)) × (is_z_isomorphism (MPMor3 M)). Definition TriMor_is_iso1 {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : is_z_isomorphism (MPMor1 M) := dirprod_pr1 Ti. Definition TriMor_is_iso2 {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : is_z_isomorphism (MPMor2 M) := dirprod_pr1 (dirprod_pr2 Ti). Definition TriMor_is_iso3 {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : is_z_isomorphism (MPMor3 M) := dirprod_pr2 (dirprod_pr2 Ti). Definition make_TriMor_is_iso {D1 D2 : Tri} {M : TriMor D1 D2} (H1 : is_z_isomorphism (MPMor1 M)) (H2 : is_z_isomorphism (MPMor2 M)) (H3 : is_z_isomorphism (MPMor3 M)) : TriMor_is_iso M := (H1,,(H2,,H3)). (** *** Composition of is isomorphism is isomorphism *) Definition TriMor_is_iso_comp {D1 D2 D3 : Tri} {M1 : TriMor D1 D2} {M2 : TriMor D2 D3} (i1 : TriMor_is_iso M1) (i2 : TriMor_is_iso M2) : TriMor_is_iso (TriMor_comp M1 M2). Proof. use make_TriMor_is_iso. - use is_z_isomorphism_comp. + exact (TriMor_is_iso1 i1). + exact (TriMor_is_iso1 i2). - use is_z_isomorphism_comp. + exact (TriMor_is_iso2 i1). + exact (TriMor_is_iso2 i2). - use is_z_isomorphism_comp. + exact (TriMor_is_iso3 i1). + exact (TriMor_is_iso3 i2). Defined. (** *** Construction of an inverse and the fact that it is isomorphism *) Local Lemma TriMor_is_iso_to_inv_Comm {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : MPMorComms (make_MPMorMors (is_z_isomorphism_mor (TriMor_is_iso1 Ti)) (is_z_isomorphism_mor (TriMor_is_iso2 Ti)) (is_z_isomorphism_mor (TriMor_is_iso3 Ti))). Proof. use make_MPMorComms. - cbn. use (pre_comp_with_z_iso_is_inj (TriMor_is_iso1 Ti)). use (post_comp_with_z_iso_is_inj (TriMor_is_iso2 Ti)). rewrite assoc. rewrite (is_inverse_in_precat1 (TriMor_is_iso1 Ti)). rewrite id_left. rewrite <- assoc. rewrite <- assoc. rewrite (is_inverse_in_precat2 (TriMor_is_iso2 Ti)). rewrite id_right. exact (! MPComm1 M). - cbn. use (pre_comp_with_z_iso_is_inj (TriMor_is_iso2 Ti)). use (post_comp_with_z_iso_is_inj (TriMor_is_iso3 Ti)). rewrite assoc. rewrite (is_inverse_in_precat1 (TriMor_is_iso2 Ti)). rewrite id_left. rewrite <- assoc. rewrite <- assoc. rewrite (is_inverse_in_precat2 (TriMor_is_iso3 Ti)). rewrite id_right. exact (! MPComm2 M). Qed. Lemma TriMor_is_iso_to_inv_Comm3 {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : MPMor3 (make_MPMor (make_MPMorMors (is_z_isomorphism_mor (TriMor_is_iso1 Ti)) (is_z_isomorphism_mor (TriMor_is_iso2 Ti)) (is_z_isomorphism_mor (TriMor_is_iso3 Ti))) (TriMor_is_iso_to_inv_Comm Ti)) · Mor3 D1 = (Mor3 D2) · (# (AddEquiv1 T) (MPMor1 (make_MPMor (make_MPMorMors (is_z_isomorphism_mor (TriMor_is_iso1 Ti)) (is_z_isomorphism_mor (TriMor_is_iso2 Ti)) (is_z_isomorphism_mor (TriMor_is_iso3 Ti))) (TriMor_is_iso_to_inv_Comm Ti)))). Proof. cbn. use (pre_comp_with_z_iso_is_inj (TriMor_is_iso3 Ti)). rewrite assoc. rewrite (is_inverse_in_precat1 (TriMor_is_iso3 Ti)). rewrite id_left. use (post_comp_with_z_iso_is_inj (functor_on_is_z_isomorphism _ (TriMor_is_iso1 Ti))). rewrite <- assoc. rewrite <- assoc. rewrite <- functor_comp. rewrite (is_inverse_in_precat2 (TriMor_is_iso1 Ti)). rewrite functor_id. rewrite id_right. rewrite <- (DComm3 M). apply idpath. Qed. Definition TriMor_is_iso_inv {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : TriMor D2 D1. Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (is_z_isomorphism_mor (TriMor_is_iso1 Ti)). * exact (is_z_isomorphism_mor (TriMor_is_iso2 Ti)). * exact (is_z_isomorphism_mor (TriMor_is_iso3 Ti)). + exact (TriMor_is_iso_to_inv_Comm Ti). - exact (TriMor_is_iso_to_inv_Comm3 Ti). Defined. Lemma TriMor_is_iso_inv_is_iso {D1 D2 : Tri} {M : TriMor D1 D2} (Ti : TriMor_is_iso M) : TriMor_is_iso (TriMor_is_iso_inv Ti). Proof. use make_TriMor_is_iso. - cbn. exact (is_z_isomorphism_inv (TriMor_is_iso1 Ti)). - cbn. exact (is_z_isomorphism_inv (TriMor_is_iso2 Ti)). - cbn. exact (is_z_isomorphism_inv (TriMor_is_iso3 Ti)). Defined. (** ** Isomorphisms of triangles *) Definition TriIso (D1 D2 : Tri) : UU := ∑ M : TriMor D1 D2, TriMor_is_iso M. Definition make_TriIso {D1 D2 : Tri} (M : TriMor D1 D2) (H : TriMor_is_iso M) : TriIso D1 D2 := (M,,H). Definition TriIsoMor {D1 D2 : Tri} (I : TriIso D1 D2) : TriMor D1 D2 := pr1 I. Coercion TriIsoMor : TriIso >-> TriMor. Definition TriIso_is_iso {D1 D2 : Tri} (I : TriIso D1 D2) : TriMor_is_iso I := pr2 I. Coercion TriIso_is_iso : TriIso >-> TriMor_is_iso. (** *** Composition of isomorphisms *) Definition TriIso_comp {D1 D2 D3 : Tri} (M1 : TriIso D1 D2) (M2 : TriIso D2 D3) : TriIso D1 D3. Proof. use make_TriIso. - exact (TriMor_comp M1 M2). - exact (TriMor_is_iso_comp (TriIso_is_iso M1) (TriIso_is_iso M2)). Defined. (** *** Inverse of an isomorphism *) Definition TriIsoInv {D1 D2 : Tri} (I : TriIso D1 D2) : TriIso D2 D1. Proof. use make_TriIso. - exact (TriMor_is_iso_inv (TriIso_is_iso I)). - exact (TriMor_is_iso_inv_is_iso (TriIso_is_iso I)). Defined. (** *** Identity isomorphism *) Definition TriIsoId (D : Tri) : TriIso D D. Proof. use make_TriIso. - exact (TriMorId D). - use make_TriMor_is_iso. + exact (is_z_isomorphism_identity _). + exact (is_z_isomorphism_identity _). + exact (is_z_isomorphism_identity _). Defined. (** ** Trivial triangle, rotated triangle, and inv rotated triangle *) (** *** X -Id-> X -> 0 -> X[1] *) Definition TrivialTri (x : ob A) : Tri. Proof. use make_Tri. - exact x. - exact x. - exact (to_Zero A). - exact (identity _). - exact (ZeroArrow (to_Zero A) _ _). - exact (ZeroArrow (to_Zero A) _ _). Defined. (** *** See introduction to this section for the diagram *) Definition RotTri (D : Tri) : Tri. Proof. use make_Tri. - exact (Ob2 D). - exact (Ob3 D). - exact (AddEquiv1 T (Ob1 D)). - exact (Mor2 D). - exact (Mor3 D). - exact (to_inv (# (AddEquiv1 T) (Mor1 D))). Defined. Definition InvRotTri (D : Tri) : Tri. Proof. use make_Tri. - exact (AddEquiv2 T (Ob3 D)). - exact (Ob1 D). - exact (Ob2 D). - exact (to_inv (# (AddEquiv2 T) (Mor3 D)) · (inv_from_z_iso (AddEquivUnitIso T (Ob1 D)))). - exact (Mor1 D). - exact (Mor2 D · (inv_from_z_iso (AddEquivCounitIso T (Ob3 D)))). Defined. (** ** Rotation and inverse rotation of a morphism *) (** *** See the diagram in the introduction *) Local Lemma RotTriMor_Comm3 {D1 D2 : Tri} (M : TriMor D1 D2) : # (AddEquiv1 T) (MPMor1 M) · to_inv (# (AddEquiv1 T) (Mor1 D2)) = to_inv (# (AddEquiv1 T) (Mor1 D1)) · # (AddEquiv1 T) (MPMor2 M). Proof. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. exact (MPComm1 M). Qed. Definition RotTriMor {D1 D2 : Tri} (M : TriMor D1 D2) : TriMor (RotTri D1) (RotTri D2). Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (MPMor2 M). * exact (MPMor3 M). * exact (# (AddEquiv1 T) (MPMor1 M)). + use make_MPMorComms. * exact (MPComm2 M). * exact (DComm3 M). - exact (RotTriMor_Comm3 M). Defined. Local Lemma InvRotTriMor_Comm1 {D1 D2 : Tri} (M : TriMor D1 D2) : (# (AddEquiv2 T) (MPMor3 M)) · ((to_inv (# (AddEquiv2 T) (Mor3 D2))) · inv_from_z_iso (AddEquivUnitIso T (Ob1 D2))) = (to_inv (# (AddEquiv2 T) (Mor3 D1))) · inv_from_z_iso (AddEquivUnitIso T (Ob1 D1)) · MPMor1 M. Proof. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. apply maponpaths. rewrite assoc. rewrite <- functor_comp. set (tmp := maponpaths (# (AddEquiv2 T)) (DComm3 M)). rewrite tmp. clear tmp. rewrite functor_comp. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := AddEquivUnitComm T _ _ (MPMor1 M)). cbn in tmp. use (! AddEquivUnitInv T (MPMor1 M)). Qed. Local Lemma InvRotTriMor_Comm3 {D1 D2 : Tri} (M : TriMor D1 D2) : MPMor2 M · (Mor2 D2 · inv_from_z_iso (AddEquivCounitIso T (Ob3 D2))) = Mor2 D1 · inv_from_z_iso (AddEquivCounitIso T (Ob3 D1)) · # (AddEquiv1 T) (# (AddEquiv2 T) (MPMor3 M)). Proof. set (tmp := MPComm2 M). rewrite assoc. rewrite tmp. clear tmp. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. use (! AddEquivCounitInv T (MPMor3 M)). Qed. Definition InvRotTriMor {D1 D2 : Tri} (M : TriMor D1 D2) : TriMor (InvRotTri D1) (InvRotTri D2). Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (# (AddEquiv2 T) (MPMor3 M)). * exact (MPMor1 M). * exact (MPMor2 M). + use make_MPMorComms. * exact (InvRotTriMor_Comm1 M). * exact (MPComm1 M). - exact (InvRotTriMor_Comm3 M). Defined. Definition RotTriMor_is_iso {D1 D2 : Tri} {M : TriMor D1 D2} (H : TriMor_is_iso M) : TriMor_is_iso (RotTriMor M). Proof. use make_TriMor_is_iso. - exact (TriMor_is_iso2 H). - exact (TriMor_is_iso3 H). - exact (functor_on_is_z_isomorphism (AddEquiv1 T) (TriMor_is_iso1 H)). Defined. Definition RotTriIso {D1 D2 : Tri} (M : TriIso D1 D2) : TriIso (RotTri D1) (RotTri D2). Proof. use make_TriIso. - exact (RotTriMor M). - exact (RotTriMor_is_iso (TriIso_is_iso M)). Defined. Definition InvRotTriMor_is_iso {D1 D2 : Tri} {M : TriMor D1 D2} (H : TriMor_is_iso M) : TriMor_is_iso (InvRotTriMor M). Proof. use make_TriMor_is_iso. - exact (functor_on_is_z_isomorphism (AddEquiv2 T) (TriMor_is_iso3 H)). - exact (TriMor_is_iso1 H). - exact (TriMor_is_iso2 H). Defined. Definition InvRotTriIso {D1 D2 : Tri} (M : TriIso D1 D2) : TriIso (InvRotTri D1) (InvRotTri D2). Proof. use make_TriIso. - exact (InvRotTriMor M). - exact (InvRotTriMor_is_iso (TriIso_is_iso M)). Defined. (** ** Cone data *) Definition ConeData {A : CategoryWithAdditiveStructure} (T : AddEquiv A A) (x y : ob A) : UU := ∑ (z : ob A), A⟦y, z⟧ × A⟦z, (AddEquiv1 T x)⟧. Definition make_ConeData {A : CategoryWithAdditiveStructure} (T : AddEquiv A A) {x y z : ob A} (g : y --> z) (h : z --> (AddEquiv1 T x)) : ConeData T x y := (z,,(g,,h)). Definition ConeDataOb {A : CategoryWithAdditiveStructure} {T : AddEquiv A A} {x y : ob A} (C : ConeData T x y) : ob A := pr1 C. Coercion ConeDataOb : ConeData >-> ob. Definition ConeData1 {A : CategoryWithAdditiveStructure} {T : AddEquiv A A} {x y : ob A} (C : ConeData T x y) : A⟦y, C⟧ := dirprod_pr1 (pr2 C). Definition ConeData2 {A : CategoryWithAdditiveStructure} {T : AddEquiv A A} {x y : ob A} (C : ConeData T x y) : A⟦C, (AddEquiv1 T x)⟧ := dirprod_pr2 (pr2 C). End def_triangles. (** * Data for pretriangulated categories *) Section def_pretriang_data. (** ** PreTriangData *) (** Data for pretriangulated category consists of - An additive category A - An additive equivalence T : A -> A - A subtype for triangles in (A, T), called the distinguished triangles. *) Definition PreTriangData : UU := ∑ D : (∑ A : (CategoryWithAdditiveStructure), (AddEquiv A A)), hsubtype (@Tri (pr1 D) (pr2 D)). Definition make_PreTriangData (A : CategoryWithAdditiveStructure) (T : AddEquiv A A) (H : hsubtype (@Tri A T)) : PreTriangData. Proof. use tpair. - use tpair. + exact A. + exact T. - exact H. Defined. Definition PreTriangData_Additive (PTD : PreTriangData) : CategoryWithAdditiveStructure := pr1 (pr1 PTD). Coercion PreTriangData_Additive : PreTriangData >-> CategoryWithAdditiveStructure. Definition Trans {PTD : PreTriangData} : AddEquiv PTD PTD := pr2 (pr1 PTD). Definition isDTri {PTD : PreTriangData} (T : @Tri PTD Trans) : hProp := (pr2 PTD) T. (** Construction of a triangle in PTD from ConeData *) Definition ConeTri {PTD : PreTriangData} {x y : ob PTD} (f : x --> y) (D : ConeData Trans x y) : @Tri _ (@Trans PTD). Proof. use make_Tri. - exact x. - exact y. - exact D. - exact f. - exact (ConeData1 D). - exact (ConeData2 D). Defined. End def_pretriang_data. (** * Distinguished triangles and extentions *) (** ** Inroduction In this section we define data for - Distinguished triangles - Extentions of morphisms *) Section def_pretriangulated_data. Context {PTD : PreTriangData}. (** ** Distinguished triangles *) Definition DTri : UU := ∑ (T : @Tri _ (@Trans PTD)), isDTri T. Definition make_DTri {x y z : ob PTD} (f : x --> y) (g : y --> z) (h : z --> (AddEquiv1 Trans x)) (H : isDTri (make_Tri f g h)) : DTri := ((make_Tri f g h),,H). Definition make_DTri' (T : @Tri _ (@Trans PTD)) (H : isDTri T) : DTri := (T,,H). Definition DTriTri (D : DTri) : Tri := pr1 D. Coercion DTriTri : DTri >-> Tri. Definition DTriisDTri (D : DTri) : isDTri D := pr2 D. (** ** Extensions *) Definition TExt {D1 D2 : DTri} {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} (H : f1 · Mor1 D2 = Mor1 D1 · f2) : UU := ∑ f3 : Ob3 D1 --> Ob3 D2, (Mor2 D1 · f3 = f2 · Mor2 D2) × (Mor3 D1 · (# (AddEquiv1 (@Trans PTD)) f1) = f3 · Mor3 D2). Definition make_TExt {D1 D2 : DTri} {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} {H : f1 · Mor1 D2 = Mor1 D1 · f2} (f3 : Ob3 D1 --> Ob3 D2) (H2 : Mor2 D1 · f3 = f2 · Mor2 D2) (H3 : Mor3 D1 · (# (AddEquiv1 (@Trans PTD)) f1) = f3 · Mor3 D2) : TExt H := (f3,,(H2,,H3)). Definition TExt_Mor {D1 D2 : DTri} {f1 : Ob1 (DTriTri D1) --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} {H : f1 · Mor1 D2 = Mor1 D1 · f2} (TE : TExt H) : PTD⟦Ob3 D1, Ob3 D2⟧ := pr1 TE. Coercion TExt_Mor : TExt >-> precategory_morphisms. Definition TExtComm1 {D1 D2 : DTri} {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} {H : f1 · Mor1 D2 = Mor1 D1 · f2} (TE : TExt H) : Mor2 D1 · TE = f2 · Mor2 D2 := dirprod_pr1 (pr2 TE). Definition TExtComm2 {D1 D2 : DTri} {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} {H : f1 · Mor1 D2 = Mor1 D1 · f2} (TE : TExt H) : (Mor3 D1 · (# (AddEquiv1 Trans) f1) = TE · Mor3 D2) := dirprod_pr2 (pr2 TE). Definition TExtMor {D1 D2 : DTri} {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} {H : f1 · Mor1 D2 = Mor1 D1 · f2} (TE : TExt H) : TriMor D1 D2. Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact f1. * exact f2. * exact TE. + use make_MPMorComms. * exact H. * exact (! TExtComm1 TE). - exact (! TExtComm2 TE). Defined. End def_pretriangulated_data. (** * PreTriangulated categories *) Section def_pretrangulated. (** *** isPreTriang - Trivial triangles are distinguished - Distinguished triangles are closed under isomorphism - Rotation of a distinguished triangle is distinguished - Inverse rotation of a distinguished triangle is distinguished - For every morphism f, there exists a completion to distinguished triangle - Commutative squares to morphisms of distinguished triangles *) Definition isPreTriang (PTD : PreTriangData) : UU := (∏ (x : ob PTD), isDTri (TrivialTri x)) × (∏ (T1 T2 : @Tri PTD Trans) (I : ∥ TriIso T1 T2 ∥), isDTri T1 -> isDTri T2) × (∏ (D : DTri), @isDTri PTD (RotTri D)) × (∏ (D : DTri), @isDTri PTD (InvRotTri D)) × (∏ (x y : ob PTD) (f : x --> y), ∥ ∑ D : ConeData Trans x y, isDTri (ConeTri f D) ∥) × (∏ (D1 D2 : DTri) (f1 : Ob1 D1 --> Ob1 D2) (f2 : Ob2 D1 --> Ob2 D2) (H : f1 · Mor1 D2 = Mor1 D1 · f2), ∥ @TExt PTD _ _ _ _ H ∥). Definition make_isPreTriang {PTD : PreTriangData} (H1 : (∏ (x : ob PTD), isDTri (TrivialTri x))) (H2 : ∏ (T1 T2 : @Tri PTD Trans) (I : ∥ TriIso T1 T2 ∥), isDTri T1 -> isDTri T2) (H3 : ∏ (D : DTri), isDTri (RotTri D)) (H4 : ∏ (D : DTri), isDTri (InvRotTri D)) (H5 : ∏ (x y : ob PTD) (f : x --> y), ∥ ∑ D : ConeData Trans x y, isDTri (ConeTri f D) ∥) (H6 : ∏ (D1 D2 : DTri) (f1 : Ob1 D1 --> Ob1 D2) (f2 : Ob2 D1 --> Ob2 D2) (H : f1 · Mor1 D2 = Mor1 D1 · f2), ∥ (@TExt PTD _ _ _ _ H) ∥) : isPreTriang PTD := (H1,,(H2,,(H3,,(H4,,(H5,,H6))))). (** *** Accessor functions *) Definition TrivialDTrisData {PTD : PreTriangData} (iPT : isPreTriang PTD) : ∏ (x : ob PTD), isDTri (TrivialTri x) := dirprod_pr1 iPT. Definition TrivialDTri {PTD : PreTriangData} (iPT : isPreTriang PTD) (x : ob PTD) : @DTri PTD. Proof. set (TDT := TrivialDTrisData iPT x). exact (make_DTri (identity x) (ZeroArrow (to_Zero PTD) _ (to_Zero PTD)) (ZeroArrow (to_Zero PTD) _ (AddEquiv1 Trans x)) TDT). Defined. Definition DTrisUnderIso {PTD : PreTriangData} (iPT : isPreTriang PTD) : ∏ (T1 T2 : @Tri PTD Trans) (I : ∥ TriIso T1 T2 ∥), isDTri T1 -> isDTri T2 := dirprod_pr1 (dirprod_pr2 iPT). Definition RotDTris {PTD : PreTriangData} (iPT : isPreTriang PTD) (D : @DTri PTD) : isDTri (RotTri D) := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 iPT)) D. Definition RotDTri {PTD : PreTriangData} (iPT : isPreTriang PTD) (D : @DTri PTD) : @DTri PTD. Proof. set (D' := RotDTris iPT D). exact (make_DTri' (RotTri D) D'). Defined. Definition InvRotDTris {PTD : PreTriangData} (iPT : isPreTriang PTD) (D : @DTri PTD) : isDTri (InvRotTri D) := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 iPT))) D. Definition InvRotDTri {PTD : PreTriangData} (iPT : isPreTriang PTD) (D : @DTri PTD) : @DTri PTD. Proof. set (D' := InvRotDTris iPT D). exact (make_DTri' (InvRotTri D) D'). Defined. Definition DCompletion {PTD : PreTriangData} (iPT : isPreTriang PTD) : ∏ (x y : ob PTD) (f : x --> y), ∥ ∑ D : ConeData Trans x y, isDTri (ConeTri f D) ∥ := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 iPT)))). Definition DExts {PTD : PreTriangData} (iPT : isPreTriang PTD) : ∏ (D1 D2 : DTri) (f1 : Ob1 D1 --> Ob1 D2) (f2 : Ob2 D1 --> Ob2 D2) (H : f1 · Mor1 D2 = Mor1 D1 · f2), ∥ @TExt PTD _ _ _ _ H ∥ := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 iPT)))). Definition DExt {PTD : PreTriangData} (iPT : isPreTriang PTD) (D1 D2 : DTri) (f1 : Ob1 D1 --> Ob1 D2) (f2 : Ob2 D1 --> Ob2 D2) (H : f1 · Mor1 D2 = Mor1 D1 · f2) : ∥ TExt H ∥ := DExts iPT D1 D2 f1 f2 H. (** ** Pretriangulated category *) Definition PreTriang : UU := ∑ PTD : PreTriangData, isPreTriang PTD. Definition make_PreTriang (PTD : PreTriangData) (H : isPreTriang PTD) := (PTD,,H). (** Accessor functions for pretriangulated categories *) Definition PreTriang_PreTriangData (PT : PreTriang) : PreTriangData := pr1 PT. Coercion PreTriang_PreTriangData : PreTriang >-> PreTriangData. Definition PreTriang_isPreTriang (PT : PreTriang) : isPreTriang PT := pr2 PT. Coercion PreTriang_isPreTriang : PreTriang >-> isPreTriang. End def_pretrangulated. Arguments Trans {PTD} : simpl never. (** * Triangulated categories **) Section def_triangulated. (** ** Octahedral data *) (** (Octahedral axiom). Suppose you have 3 distinguished triangles (X1, Y1, Z2, f1, f2, f3), (Y1, Z1, X2, g1, g2, g3), and (X1, Z1, Y2, f1 · g1, h2, h3). Then there exists a distinguished triangle (Z2, Y2, X2, φ1, φ2, g3 · f2[1]) such that the following diagram is commutative X1 ----f1----> Y1 ----f2----> Z2 ----f3----> X1[1] || | | || || g1 | φ1 | || || | | || X1 -f1·g1-> Z1 ---h2--> Y2 ----h3---> X1[1] | | | g2 | φ2 | f[1] | | | | X2 ======== X2 ----h''---> Y1[1] | | g3 | g3·f2[1] | | | Y1[1] --f2[1]-> Z2[1] *) Definition Octa {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) : UU := ∑ D : ((z2 --> y2) × (y2 --> x2)), (isDTri (make_Tri (dirprod_pr1 D) (dirprod_pr2 D) (g3 · (# (AddEquiv1 Trans) f2)))) × (dirprod_pr1 D · h3 = f3) × (h2 · dirprod_pr2 D = g2) × (f2 · dirprod_pr1 D = g1 · h2) × (dirprod_pr2 D · g3 = h3 · (# (AddEquiv1 Trans) f1)). Definition make_Octa {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) (φ1 : z2 --> y2) (φ2 : y2 --> x2) (H4 : isDTri (make_Tri φ1 φ2 (g3 · (# (AddEquiv1 Trans) f2)))) (Comm1 : φ1 · h3 = f3) (Comm2 : h2 · φ2 = g2) (Comm3 : f2 · φ1 = g1 · h2) (Comm4 : φ2 · g3 = h3 · (# (AddEquiv1 Trans) f1)) : Octa H1 H2 H3 := ((φ1,,φ2),,(H4,,(Comm1,,(Comm2,,(Comm3,,Comm4))))). (** Accessor functions *) Definition OctaMor1 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : PT⟦z2, y2⟧ := dirprod_pr1 (pr1 O). Definition OctaMor2 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : PT⟦y2, x2⟧ := dirprod_pr2 (pr1 O). Definition OctaDTri {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : @DTri PT := make_DTri' _ (dirprod_pr1 (pr2 O)). Definition OctaComm1 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : (OctaMor1 O) · h3 = f3 := dirprod_pr1 (dirprod_pr2 (pr2 O)). Definition OctaComm2 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : h2 · (OctaMor2 O) = g2 := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (pr2 O))). Definition OctaComm3 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : f2 · (OctaMor1 O) = g1 · h2 := dirprod_pr1 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (pr2 O)))). Definition OctaComm4 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} (O : Octa H1 H2 H3) : (OctaMor2 O) · g3 = h3 · (# (AddEquiv1 Trans) f1) := dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (dirprod_pr2 (pr2 O)))). (** ** Triangulated category *) Definition Triang : UU := ∑ PT : PreTriang, (∏ (x1 x2 y1 y2 z1 z2 : ob PT) (f1 : x1 --> y1) (f2 : y1 --> z2) (f3 : z2 --> (AddEquiv1 Trans x1)) (g1 : y1 --> z1) (g2 : z1 --> x2) (g3 : x2 --> (AddEquiv1 Trans y1)) (h2 : z1 --> y2) (h3 : y2 --> (AddEquiv1 Trans x1)) (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)), ∥ Octa H1 H2 H3 ∥). Definition make_Triang {PT : PreTriang} (H : ∏ (x1 x2 y1 y2 z1 z2 : ob PT) (f1 : x1 --> y1) (f2 : y1 --> z2) (f3 : z2 --> (AddEquiv1 Trans x1)) (g1 : y1 --> z1) (g2 : z1 --> x2) (g3 : x2 --> (AddEquiv1 Trans y1)) (h2 : z1 --> y2) (h3 : y2 --> (AddEquiv1 Trans x1)) (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)), ∥ Octa H1 H2 H3 ∥) : Triang := (PT,,H). Definition Triang_PreTriang (TR : Triang) : PreTriang := pr1 TR. Coercion Triang_PreTriang : Triang >-> PreTriang. Definition Octahedral {TR : Triang} {x1 x2 y1 y2 z1 z2 : ob TR} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} {H1 : isDTri (make_Tri f1 f2 f3)} {H2 : isDTri (make_Tri g1 g2 g3)} {H3 : isDTri (make_Tri (f1 · g1) h2 h3)} : ∥ Octa H1 H2 H3 ∥ := (pr2 TR) x1 x2 y1 y2 z1 z2 f1 f2 f3 g1 g2 g3 h2 h3 H1 H2 H3. End def_triangulated. (** * Rotations and inverse rotations of morphisms, Extensions, and DTris *) Section rotation_isos. Context {PT : PreTriang}. (** ** iso D InvRot (Rot D) and iso D Rot (InvRot D) *) Local Lemma RotInvIso_Mor_Comm1 (D : DTri) : ((AddEquivUnitIso Trans (Ob1 D)) : PT⟦_, _⟧) · ((to_inv (# (AddEquiv2 Trans) (to_inv (# (AddEquiv1 Trans) (Mor1 D))))) · (inv_from_z_iso (AddEquivUnitIso (@Trans PT) (Ob2 D)))) = Mor1 D · identity (Ob2 D). Proof. rewrite AdditiveFunctorInv. rewrite inv_inv_eq. rewrite id_right. use (post_comp_with_z_iso_is_inj (AddEquivUnitIso Trans (Ob2 D))). rewrite <- assoc. rewrite <- assoc. rewrite (is_inverse_in_precat2 (AddEquivUnitIso Trans (Ob2 D))). rewrite id_right. use (! (AddEquivUnitComm (@Trans PT) _ _ (Mor1 D))). Qed. Local Lemma RotInvIso_Mor_Comm2 (D : @DTri PT) : identity (Ob2 D) · Mor2 D = Mor2 D · identity (Ob3 D). Proof. rewrite id_right. apply id_left. Qed. Local Lemma RotInvIso_Mor_Comm3 (D : DTri) : (identity (Ob3 D)) · ((Mor3 D) · (inv_from_z_iso (AddEquivCounitIso Trans ((AddEquiv1 Trans) (Ob1 D))))) = Mor3 D · # (AddEquiv1 (@Trans PT)) (AddEquivUnitIso Trans (Ob1 D)). Proof. rewrite id_left. apply cancel_precomposition. use AddEquivCounitUnit. Qed. Definition RotInvIso_Mor (D : DTri) : TriMor D (InvRotDTri PT (RotDTri PT D)). Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (AddEquivUnitIso Trans (Ob1 D)). * exact (identity _). * exact (identity _). + use make_MPMorComms. * exact (RotInvIso_Mor_Comm1 D). * exact (RotInvIso_Mor_Comm2 D). - exact (RotInvIso_Mor_Comm3 D). Defined. Definition RotInvIso_is_iso (D : DTri) : TriMor_is_iso (RotInvIso_Mor D). Proof. use make_TriMor_is_iso. - exact (AddEquivUnitInvMor_is_iso_with_inv_data Trans (Ob1 D)). - exact (is_z_isomorphism_identity (Ob2 D)). - exact (is_z_isomorphism_identity (Ob3 D)). Qed. Local Lemma InvRotIso_Mor_Comm1 (D : @DTri PT) : identity (Ob1 D) · Mor1 D = Mor1 D · identity (Ob2 D). Proof. rewrite id_right. apply id_left. Qed. Local Lemma InvRotIso_Mor_Comm2 (D : @DTri PT) : (identity (Ob2 D)) · (Mor2 D · inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D))) = Mor2 D · inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D)). Proof. rewrite id_left. apply idpath. Qed. Local Lemma InvRotIso_Mor_Comm3 (D : @DTri PT) : (inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D))) · (to_inv (# (AddEquiv1 Trans) ((to_inv (# (AddEquiv2 Trans) (Mor3 D))) · inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D))))) = Mor3 D · # (AddEquiv1 Trans) (identity (Ob1 D)). Proof. rewrite functor_id. rewrite id_right. rewrite <- PreAdditive_invlcomp. rewrite AdditiveFunctorInv. rewrite inv_inv_eq. rewrite functor_comp. set (tmp := AddEquivCounitUnit' Trans (Ob1 D)). cbn in tmp. rewrite assoc. cbn. apply (maponpaths (λ g : _, (inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D))) · (# (AddEquiv1 Trans) (# (AddEquiv2 Trans) (Mor3 D))) · g)) in tmp. use (pathscomp0 (! tmp)). clear tmp. use (pre_comp_with_z_iso_is_inj (AddEquivCounitIso Trans (Ob3 D))). rewrite assoc. rewrite assoc. cbn. set (tmp := is_inverse_in_precat1 (AddEquivCounitIso Trans (Ob3 D))). cbn in tmp. rewrite tmp. clear tmp. rewrite id_left. exact (AddEquivCounitComm Trans _ _ (Mor3 D)). Qed. Definition InvRotIso_Mor (D : @DTri PT) : TriMor D (RotDTri PT (InvRotDTri PT D)). Proof. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (identity _). * exact (identity _). * exact (inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D))). + use make_MPMorComms. * exact (InvRotIso_Mor_Comm1 D). * exact (InvRotIso_Mor_Comm2 D). - exact (InvRotIso_Mor_Comm3 D). Defined. Definition InvRotIso_is_iso (D : @DTri PT) : TriMor_is_iso (InvRotIso_Mor D). Proof. use make_TriMor_is_iso. - exact (is_z_isomorphism_identity (Ob1 D)). - exact (is_z_isomorphism_identity (Ob2 D)). - exact (is_z_iso_inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D))). Defined. (** ** Extension of morphisms at 2 and 1 *) Local Lemma ExtMor'_Comm1 (D1 D2 : @DTri PT) (Mor : TriMor (RotDTri PT D1) (RotDTri PT D2)) : (AddEquivUnit Trans) (Ob1 D1) · # (AddEquiv2 Trans) (MPMor3 Mor) · inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D2)) · Mor1 D2 = Mor1 D1 · MPMor1 Mor. Proof. set (tmp := DComm3 Mor). cbn in tmp. rewrite <- PreAdditive_invlcomp in tmp. rewrite <- PreAdditive_invrcomp in tmp. apply cancel_inv in tmp. rewrite <- functor_comp in tmp. use (AddEquiv1Inj Trans). use (pathscomp0 _ tmp). clear tmp. rewrite functor_comp. apply cancel_postcomposition. set (tmp := AddEquivCounitMorComm Trans (MPMor3 Mor)). use (pathscomp0 _ (! tmp)). clear tmp. cbn. rewrite functor_comp. rewrite functor_comp. set (tmp := AddEquivCounitUnit Trans (Ob1 D1)). apply (maponpaths (λ gg : _, gg · # (AddEquiv1 Trans) (# (AddEquiv2 Trans) (MPMor3 Mor)) · # (AddEquiv1 Trans) (inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D2))))) in tmp. use (pathscomp0 (! tmp)). clear tmp. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. use (! AddEquivCounitUnit' Trans (Ob1 D2)). Qed. Local Lemma ExtMor'_Comm3 (D1 D2 : @DTri PT) (Mor : TriMor (RotDTri PT D1) (RotDTri PT D2)): MPMor2 Mor · Mor3 D2 = Mor3 D1 · # (AddEquiv1 Trans) ((AddEquivUnit Trans) (Ob1 D1) · # (AddEquiv2 Trans) (MPMor3 Mor) · inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D2))). Proof. set (tmp := MPComm2 Mor). cbn in tmp. cbn. rewrite tmp. clear tmp. apply cancel_precomposition. use (pathscomp0 (AddEquivCounitMorComm Trans (MPMor3 Mor))). set (tmp := AddEquivCounitUnit Trans (Ob1 D1)). apply (maponpaths (λ gg : _, gg · (# (functor_composite (AddEquiv2 Trans) (AddEquiv1 Trans)) (MPMor3 Mor)) · (AddEquivCounit Trans) ((AddEquiv1 Trans) (Ob1 D2)))) in tmp. use (pathscomp0 tmp). clear tmp. rewrite <- assoc. rewrite <- assoc. rewrite functor_comp. apply cancel_precomposition. rewrite functor_comp. apply cancel_precomposition. exact (AddEquivCounitUnit' Trans (Ob1 D2)). Qed. Definition ExtMor1 (D1 D2 : @DTri PT) (f2 : Ob2 D1 --> Ob2 D2) (f3 : Ob3 D1 --> Ob3 D2) (H : f2 · Mor2 D2 = Mor2 D1 · f3) (Ext : @TExt _ (RotDTri PT D1) (RotDTri PT D2) f2 f3 H) : TriMor D1 D2. Proof. set (Mor := TExtMor Ext). use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (((AddEquivUnitIso Trans (Ob1 D1)) : PT⟦_, _⟧) · (# (AddEquiv2 Trans) (MPMor3 Mor)) · (inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D2)))). * exact (MPMor1 Mor). * exact (MPMor2 Mor). + use make_MPMorComms. * exact (ExtMor'_Comm1 D1 D2 Mor). * exact (MPComm1 Mor). - exact (ExtMor'_Comm3 D1 D2 Mor). Defined. Local Lemma ExtMor2_Comm (D1 D2 : @DTri PT) (f3 : Ob3 D1 --> Ob3 D2) (f4 : (AddEquiv1 Trans (Ob1 D1)) --> (AddEquiv1 Trans (Ob1 D2))) (H : f3 · Mor3 D2 = Mor3 D1 · f4) : let D1' := InvRotDTri PT D1 in let D2' := InvRotDTri PT D2 in (# (AddEquiv2 Trans) f3) · (to_inv (# (AddEquiv2 Trans) (Mor3 D2)) · AddEquivUnitInvMor Trans (Ob1 D2)) = (to_inv (# (AddEquiv2 Trans) (Mor3 D1))) · AddEquivUnitInvMor Trans (Ob1 D1) · (((AddEquivUnit Trans) (Ob1 D1)) · # (AddEquiv2 Trans) f4 · AddEquivUnitInvMor Trans (Ob1 D2)). Proof. intros D1' D2'. rewrite assoc. rewrite assoc. rewrite assoc. rewrite <- PreAdditive_invrcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invlcomp. apply maponpaths. apply cancel_postcomposition. rewrite <- functor_comp. apply (maponpaths (# (AddEquiv2 Trans))) in H. use (pathscomp0 H). rewrite functor_comp. apply cancel_postcomposition. rewrite <- assoc. set (tmp := is_inverse_in_precat2 (AddEquivUnitIso Trans (Ob1 D1))). apply (maponpaths (compose (# (AddEquiv2 Trans) (Mor3 D1)))) in tmp. use (pathscomp0 _ (! tmp)). rewrite id_right. apply idpath. Qed. Local Lemma ExtMor2_Comm2 (D1 D2 : @DTri PT) (Mor : TriMor (InvRotDTri PT D1) (InvRotDTri PT D2)) : MPMor3 Mor · Mor2 D2 = Mor2 D1 · (AddEquivCounitInvMor Trans (Ob3 D1) · # (AddEquiv1 Trans) (MPMor1 Mor) · (AddEquivCounit Trans) (Ob3 D2)). Proof. use (post_comp_with_z_iso_inv_is_inj (AddEquivCounitIso Trans (Ob3 D2))). rewrite <- assoc. use (pathscomp0 (DComm3 Mor)). rewrite <- assoc. rewrite <- assoc. cbn. rewrite <- assoc. apply cancel_precomposition. rewrite <- assoc. apply cancel_precomposition. set (tmp := is_inverse_in_precat1 (AddEquivCounitIso Trans (Ob3 D2))). apply (maponpaths (compose (# (AddEquiv1 Trans) (MPMor1 Mor)))) in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite id_right. apply idpath. Qed. Local Lemma ExtMor2_Comm3 (D1 D2 : @DTri PT) (Mor : TriMor (InvRotDTri PT D1) (InvRotDTri PT D2)) : (AddEquivCounitInvMor Trans (Ob3 D1)) · # (AddEquiv1 Trans) (MPMor1 Mor) · (AddEquivCounit Trans) (Ob3 D2) · Mor3 D2 = Mor3 D1 · # (AddEquiv1 Trans) (MPMor2 Mor). Proof. use (pre_comp_with_z_iso_is_inj (AddEquivCounitIso Trans (Ob3 D1))). rewrite assoc. rewrite assoc. rewrite assoc. set (tmp' := is_inverse_in_precat1 (AddEquivCounitIso Trans (Ob3 D1))). cbn in tmp'. apply (maponpaths (postcompose ((# (AddEquiv1 Trans) (MPMor1 Mor)) · (AddEquivCounit Trans) (Ob3 D2) · Mor3 D2))) in tmp'. unfold postcompose in tmp'. rewrite assoc in tmp'. rewrite assoc in tmp'. use (pathscomp0 tmp'). clear tmp'. rewrite id_left. rewrite <- assoc. set (tmp' := AddEquivCounitComm Trans _ _ (Mor3 D2)). apply (maponpaths (compose (# (AddEquiv1 Trans) (MPMor1 Mor)))) in tmp'. use (pathscomp0 (! tmp')). clear tmp'. set (tmp' := AddEquivCounitUnit' Trans (Ob1 D2)). apply (maponpaths (λ gg : _, # (AddEquiv1 Trans) (MPMor1 Mor) · (# (AddEquiv1 Trans) (# (AddEquiv2 Trans) (Mor3 D2)) · gg))) in tmp'. use (pathscomp0 tmp'). clear tmp'. rewrite <- functor_comp. rewrite <- functor_comp. rewrite assoc. rewrite assoc. set (tmp' := AddEquivCounitComm Trans _ _ (Mor3 D1)). apply (maponpaths (postcompose (# (AddEquiv1 Trans) (MPMor2 Mor)))) in tmp'. use (pathscomp0 _ tmp'). clear tmp'. unfold postcompose. set (tmp' := AddEquivCounitUnit' Trans (Ob1 D1)). apply (maponpaths (λ gg : _, # (AddEquiv1 Trans) (# (AddEquiv2 Trans) (Mor3 D1)) · gg · # (AddEquiv1 Trans) (MPMor2 Mor))) in tmp'. use (pathscomp0 _ (! tmp')). clear tmp'. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. set (tmp := MPComm1 Mor). apply cancel_inv. rewrite PreAdditive_invlcomp. rewrite PreAdditive_invrcomp. rewrite <- assoc. use (pathscomp0 tmp). clear tmp. rewrite PreAdditive_invlcomp. rewrite PreAdditive_invlcomp. apply idpath. Qed. Definition ExtMor2 (D1 D2 : @DTri PT) (f3 : Ob3 D1 --> Ob3 D2) (f4 : (AddEquiv1 Trans (Ob1 D1)) --> (AddEquiv1 Trans (Ob1 D2))) (H : f3 · Mor3 D2 = Mor3 D1 · f4) : ∥ TriMor D1 D2 ∥. Proof. set (D1' := InvRotDTri PT D1). set (D2' := InvRotDTri PT D2). set (Ext' := DExt PT D1' D2' (# (AddEquiv2 Trans) f3) (((AddEquivUnitIso Trans (Ob1 D1)) : PT⟦_, _⟧) · (# (AddEquiv2 Trans) f4) · inv_from_z_iso (AddEquivUnitIso Trans (Ob1 D2))) (ExtMor2_Comm D1 D2 f3 f4 H)). use (squash_to_prop Ext' (propproperty _)). intros Ext. set (Mor := TExtMor Ext). use hinhpr. use make_TriMor. - use make_MPMor. + use make_MPMorMors. * exact (MPMor2 Mor). * exact (MPMor3 Mor). * exact ((inv_from_z_iso (AddEquivCounitIso Trans (Ob3 D1))) · (# (AddEquiv1 Trans) (MPMor1 Mor)) · (AddEquivCounitIso Trans (Ob3 D2))). + use make_MPMorComms. * exact (MPComm2 Mor). * exact (ExtMor2_Comm2 D1 D2 Mor). - exact (ExtMor2_Comm3 D1 D2 Mor). Defined. (** ** Rotations of DTris *) Definition RotDTriMor {D1 D2 : @DTri PT} (M : TriMor D1 D2) : TriMor (@RotDTri PT PT D1) (@RotDTri PT PT D2) := RotTriMor M. Definition InvRotDTriMor {D1 D2 : @DTri PT} (M : TriMor D1 D2) : TriMor (@InvRotDTri PT PT D1) (@InvRotDTri PT PT D2) := InvRotTriMor M. End rotation_isos. (** * Composition is zero *) (** ** Introduction Composition of consecutive morphisms of a distinguished triangle is 0. *) Section comp_zero. Context {PT : PreTriang}. Lemma DTriCompZero (D : @DTri PT) : Mor1 D · Mor2 D = ZeroArrow (to_Zero PT) _ _. Proof. set (D2 := TrivialDTri PT (Ob1 D)). set (Ext' := DExt PT D2 D (identity (Ob1 D)) (Mor1 D) (idpath _)). use (squash_to_prop Ext'). - apply to_has_homsets. - intros Ext. clear Ext'. set (M := TExtMor Ext). use (pathscomp0 (MPComm2 M)). cbn. apply ZeroArrow_comp_left. Qed. Lemma DTriCompZero' (D : @DTri PT) : Mor2 D · Mor3 D = ZeroArrow (to_Zero PT) _ _. Proof. exact (DTriCompZero (RotDTri PT D)). Qed. Lemma DTriCompZero'' (D : @DTri PT) : Mor3 D · to_inv (# (AddEquiv1 Trans) (Mor1 D)) = ZeroArrow (to_Zero PT) _ _. Proof. exact (DTriCompZero (RotDTri PT (RotDTri PT D))). Qed. End comp_zero. (** ** Introduction We construct the short exact sequences out from distinguished triangles. These can be used to define the long exact sequences associated to a distinguished triangle. Suppose (X, Y, Z, f, g, h) is a distinguished triangle. Then for every object W we have shortshortexact sequences Mor(W, X) --> Mor(W, Y) --> Mor(W, Z) and Mor(Z, W) --> Mor(Y, W) --> Mor(X, W) These shortshortexact sequences are constructed in [DTriSSE1_ShortShortExact_from_object] and [DTriSSE1_ShortShortExact_to_object]. *) Section short_short_exact_sequences. Context {PT : PreTriang}. Local Opaque ZeroArrow. Definition MorphismPair_from_object (D : @DTri PT) (X : ob PT) : @MorphismPair abgr_Abelian. Proof. use make_MorphismPair. - exact (@to_abgr PT X (Ob1 D)). - exact (@to_abgr PT X (Ob2 D)). - exact (@to_abgr PT X (Ob3 D)). - exact (to_postmor_monoidfun PT X (Ob1 D) (Ob2 D) (Mor1 D)). - exact (to_postmor_monoidfun PT X (Ob2 D) (Ob3 D) (Mor2 D)). Defined. Local Lemma ShortShortExactData_Eq_from_object (D : @DTri PT) (X : ob PT): monoidfuncomp (to_postmor_monoidfun PT X (Ob1 D) (Ob2 D) (Mor1 D)) (to_postmor_monoidfun PT X (Ob2 D) (Ob3 D) (Mor2 D)) = ZeroArrow abgr_Zero (to_abgr X (Ob1 D)) (to_abgr X (Ob3 D)). Proof. cbn. rewrite <- (@AdditiveZeroArrow_postmor_Abelian PT). use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. apply cancel_precomposition. exact (DTriCompZero D). Qed. Definition ShortShortExactData_from_object (D : @DTri PT) (X : ob PT) : @ShortShortExactData abgr_Abelian abgr_Zero. Proof. use make_ShortShortExactData. - exact (MorphismPair_from_object D X). - exact (ShortShortExactData_Eq_from_object D X). Defined. Lemma ShortShortExact_isKernel_from_object (D : @DTri PT) (X : ob PT) : isKernel (Abelian.to_Zero abgr_Abelian) (KernelArrow (Image (ShortShortExactData_from_object D X))) (Mor2 (ShortShortExactData_from_object D X)) (@Image_Eq abgr_Abelian (ShortShortExactData_from_object D X)). Proof. use abgr_isKernel_Criteria. - intros D0. induction D0 as [y yH]. set (D' := TrivialDTri PT X). assert (e : y · Mor2 D = ZeroArrow (to_Zero PT) _ (to_Zero PT) · ZeroArrow (to_Zero PT) _ _). { cbn in yH. unfold to_postmor in yH. rewrite yH. rewrite ZeroArrow_comp_left. set (tmp := PreAdditive_unel_zero PT (to_Zero PT) X (Ob3 D)). unfold to_unel in tmp. exact tmp. } set (Ext' := @DExt _ PT (RotDTri PT D') (RotDTri PT D) y (ZeroArrow (Additive.to_Zero PT) _ _) e). use (squash_to_prop Ext' (propproperty _)). intros Ext. clear Ext'. set (Mor := ExtMor1 D' D y (ZeroArrow (Additive.to_Zero PT) _ _) e Ext). use hinhpr. use tpair. + exact (((factorization1_epi abgr_Abelian (Mor1 (ShortShortExactData_from_object D X)) : abgr_Abelian⟦_, _⟧) : monoidfun _ _) (MPMor1 Mor)). + cbn beta. set (comm1 := MPComm1 Mor). rewrite id_left in comm1. use (pathscomp0 _ comm1). clear comm1. set (tmp := @factorization1 abgr_Abelian _ _ (Mor1 (ShortShortExactData_from_object D X))). apply base_paths in tmp. exact (! (toforallpaths _ _ _ tmp (MPMor1 Mor))). - use KernelArrowisMonic. Qed. Definition ShortShortExact_from_object (D : @DTri PT) (X : ob PT) : @ShortShortExact abgr_Abelian. Proof. use make_ShortShortExact. - exact (ShortShortExactData_from_object D X). - exact (ShortShortExact_isKernel_from_object D X). Defined. (** ShortShortExacts to X *) Definition MorphismPair_to_object (D : @DTri PT) (X : ob PT) : @MorphismPair abgr_Abelian. Proof. use make_MorphismPair. - exact (@to_abgr PT (Ob3 D) X). - exact (@to_abgr PT (Ob2 D) X). - exact (@to_abgr PT (Ob1 D) X). - exact (to_premor_monoidfun PT (Ob2 D) (Ob3 D) X (Mor2 D)). - exact (to_premor_monoidfun PT (Ob1 D) (Ob2 D) X (Mor1 D)). Defined. Local Lemma ShortShortExactData_Eq_to_object (D : @DTri PT) (X : ob PT) : monoidfuncomp (to_premor_monoidfun PT (Ob2 D) (Ob3 D) X (Mor2 D)) (to_premor_monoidfun PT (Ob1 D) (Ob2 D) X (Mor1 D)) = ZeroArrow (Abelian.to_Zero abgr_Abelian) (to_abgr (Ob3 D) X) (to_abgr (Ob1 D) X). Proof. rewrite <- (@AdditiveZeroArrow_premor_Abelian PT). use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. apply cancel_postcomposition. exact (DTriCompZero D). Qed. Definition ShortShortExactData_to_object (D : @DTri PT) (X : ob PT) : @ShortShortExactData abgr_Abelian abgr_Zero. Proof. use make_ShortShortExactData. - exact (MorphismPair_to_object D X). - exact (ShortShortExactData_Eq_to_object D X). Defined. Lemma ShortShortExact_isKernel_to_object (D : @DTri PT) (X : ob PT) : isKernel (Abelian.to_Zero abgr_Abelian) (KernelArrow (Image (ShortShortExactData_to_object D X))) (Mor2 (ShortShortExactData_to_object D X)) (@Image_Eq abgr_Abelian (ShortShortExactData_to_object D X)). Proof. use abgr_isKernel_Criteria. - intros D0. induction D0 as [y yH]. set (D' := InvRotDTri PT (TrivialDTri PT X)). assert (e : ZeroArrow (to_Zero PT) (Ob1 D) (Ob1 D') · Mor1 D' = Mor1 D · y). { rewrite ZeroArrow_comp_left. cbn in yH. unfold to_premor in yH. use (pathscomp0 _ (! yH)). set (tmp := PreAdditive_unel_zero PT (to_Zero PT) (Ob1 D) (Ob2 D')). unfold to_unel in tmp. exact (! tmp). } set (Ext' := DExt PT D D' (ZeroArrow (Additive.to_Zero PT) _ _) y e). use (squash_to_prop Ext' (propproperty _)). intros Ext. clear Ext'. set (Mor := TExtMor Ext). use hinhpr. use tpair. + exact (((factorization1_epi abgr_Abelian (Mor1 (ShortShortExactData_to_object D X)) : abgr_Abelian⟦_, _⟧) : monoidfun _ _) (MPMor3 Mor)). + cbn beta. set (comm2 := MPComm2 Mor). rewrite id_right in comm2. use (pathscomp0 _ (! comm2)). clear comm2. set (tmp := @factorization1 abgr_Abelian _ _ (Mor1 (ShortShortExactData_to_object D X))). apply base_paths in tmp. exact (! (toforallpaths _ _ _ tmp (MPMor3 Mor))). - use KernelArrowisMonic. Qed. Definition ShortShortExact_to_object (D : @DTri PT) (X : ob PT) : @ShortShortExact abgr_Abelian. Proof. use make_ShortShortExact. - exact (ShortShortExactData_to_object D X). - exact (ShortShortExact_isKernel_to_object D X). Defined. End short_short_exact_sequences. (** ** Introduction Suppose you have a morphism of distinguished triangles represented by the following diagram X -f-> Y -g-> Z -h-> X[1] φ1 | φ2 | φ3 | φ1[1] | X' -f-> Y' -g-> Z' -h-> X'[1]. The five lemma for triangulated categories says that if φ1 and φ2 are isomorphisms, then so is φ3. Using rotations we show also the following versions: if φ1 and φ3 are isomorphisms, then so is φ2, and if φ2 and φ3 are isomorphisms, then so is φ1. These are proved in [TriangulatedFiveLemma], TriangulatedFiveLemma2], and [TriangulatedFiveLemma1], respectively. *) Section triangulated_five_lemma. Context {PT : PreTriang}. Local Opaque ZeroArrow. Definition TriangulatedRowObs_from_object (D : @DTri PT) (X : ob PT) : @FiveRowObs abgr_Abelian. Proof. use make_FiveRowObs. - exact (to_abgr X (Ob1 D)). - exact (to_abgr X (Ob2 D)). - exact (to_abgr X (Ob3 D)). - exact (to_abgr X (AddEquiv1 Trans (Ob1 D))). - exact (to_abgr X (AddEquiv1 Trans (Ob2 D))). Defined. Definition TriangulatedRowDiffs_from_object (D : @DTri PT) (X : ob PT) : @FiveRowDiffs abgr_Abelian (TriangulatedRowObs_from_object D X). Proof. use make_FiveRowDiffs. - exact (to_postmor_monoidfun PT _ _ _ (Mor1 D)). - exact (to_postmor_monoidfun PT _ _ _ (Mor2 D)). - exact (to_postmor_monoidfun PT _ _ _ (Mor3 D)). - exact (to_postmor_monoidfun PT _ _ _ (to_inv (# (AddEquiv1 Trans) (Mor1 D)))). Defined. Definition TriangulatedRowDiffsEq_from_object (D : @DTri PT) (X : ob PT) : @FiveRowDiffsEq abgr_Abelian _ (TriangulatedRowDiffs_from_object D X). Proof. use make_FiveRowDiffsEq. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. set (tmp := DTriCompZero D). apply (maponpaths (compose x)) in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_right. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. set (tmp := DTriCompZero' D). apply (maponpaths (compose x)) in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_right. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. set (tmp := DTriCompZero' (RotDTri PT D)). apply (maponpaths (compose x)) in tmp. cbn in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_right. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. Qed. Definition TriangulatedRowExacts_from_object (D : @DTri PT) (X : ob PT) : @FiveRowExacts abgr_Abelian _ _ (TriangulatedRowDiffsEq_from_object D X). Proof. use make_FiveRowExacts. - unfold isExact. exact_op (@ShortShortExact_isKernel_from_object PT D X). - unfold isExact. exact_op (@ShortShortExact_isKernel_from_object PT (RotDTri PT D) X). - unfold isExact. exact_op (@ShortShortExact_isKernel_from_object PT (RotDTri PT (RotDTri PT D)) X). Qed. Definition TriangulatedRow_from_object (D : @DTri PT) (X : ob PT) : @FiveRow abgr_Abelian. Proof. use make_FiveRow. - exact (TriangulatedRowObs_from_object D X). - exact (TriangulatedRowDiffs_from_object D X). - exact (TriangulatedRowDiffsEq_from_object D X). - exact (TriangulatedRowExacts_from_object D X). Defined. Definition TriangulatedRowMors_from_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMors abgr_Abelian (TriangulatedRow_from_object D1 X) (TriangulatedRow_from_object D2 X). Proof. use make_FiveRowMors. - exact (to_postmor_monoidfun PT _ _ _ (MPMor1 M)). - exact (to_postmor_monoidfun PT _ _ _ (MPMor2 M)). - exact (to_postmor_monoidfun PT _ _ _ (MPMor3 M)). - exact (to_postmor_monoidfun PT _ _ _ (# (AddEquiv1 Trans) (MPMor1 M))). - exact (to_postmor_monoidfun PT _ _ _ (# (AddEquiv1 Trans) (MPMor2 M))). Defined. Definition TriangulatedMorsComm_from_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMorsComm abgr_Abelian _ _ (TriangulatedRowMors_from_object M X). Proof. use make_FiveRowMorsComm. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (! MPComm1 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (! MPComm2 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. exact (! DComm3 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_postmor. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. exact (! MPComm1 M). Qed. Definition TriangulatedMorphism_from_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMorphism abgr_Abelian (TriangulatedRow_from_object D1 X) (TriangulatedRow_from_object D2 X). Proof. use make_FiveRowMorphism. - exact (TriangulatedRowMors_from_object M X). - exact (TriangulatedMorsComm_from_object M X). Defined. Definition TriangulatedRowObs_to_object (D : @DTri PT) (X : ob PT) : @FiveRowObs abgr_Abelian. Proof. use make_FiveRowObs. - exact (to_abgr (AddEquiv1 Trans (Ob2 D)) X). - exact (to_abgr (AddEquiv1 Trans (Ob1 D)) X). - exact (to_abgr (Ob3 D) X). - exact (to_abgr (Ob2 D) X). - exact (to_abgr (Ob1 D) X). Defined. Definition TriangulatedRowDiffs_to_object (D : @DTri PT) (X : ob PT) : @FiveRowDiffs abgr_Abelian (TriangulatedRowObs_to_object D X). Proof. use make_FiveRowDiffs. - exact (to_premor_monoidfun PT _ _ _ (to_inv (# (AddEquiv1 Trans) (Mor1 D)))). - exact (to_premor_monoidfun PT _ _ _ (Mor3 D)). - exact (to_premor_monoidfun PT _ _ _ (Mor2 D)). - exact (to_premor_monoidfun PT _ _ _ (Mor1 D)). Defined. Definition TriangulatedRowDiffsEq_to_object (D : @DTri PT) (X : ob PT) : @FiveRowDiffsEq abgr_Abelian _ (TriangulatedRowDiffs_to_object D X). Proof. use make_FiveRowDiffsEq. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. set (tmp := DTriCompZero (RotDTri PT (RotDTri PT D))). cbn in tmp. cbn. apply (maponpaths (postcompose x)) in tmp. unfold postcompose in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_left. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. set (tmp := DTriCompZero (RotDTri PT D)). cbn in tmp. cbn. apply (maponpaths (postcompose x)) in tmp. unfold postcompose in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_left. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. set (tmp := DTriCompZero D). cbn in tmp. cbn. apply (maponpaths (postcompose x)) in tmp. unfold postcompose in tmp. cbn in tmp. use (pathscomp0 tmp). clear tmp. rewrite ZeroArrow_comp_left. rewrite <- PreAdditive_unel_zero. unfold to_unel. apply idpath. Qed. Definition TriangulatedRowExacts_to_object (D : @DTri PT) (X : ob PT) : @FiveRowExacts abgr_Abelian _ _ (TriangulatedRowDiffsEq_to_object D X). Proof. use make_FiveRowExacts. - unfold isExact. exact_op (@ShortShortExact_isKernel_to_object PT (RotDTri PT (RotDTri PT D)) X). - unfold isExact. exact_op (@ShortShortExact_isKernel_to_object PT (RotDTri PT D) X). - unfold isExact. exact_op (@ShortShortExact_isKernel_to_object PT D X). Qed. Definition TriangulatedRow_to_object (D : @DTri PT) (X : ob PT) : @FiveRow abgr_Abelian. Proof. use make_FiveRow. - exact (TriangulatedRowObs_to_object D X). - exact (TriangulatedRowDiffs_to_object D X). - exact (TriangulatedRowDiffsEq_to_object D X). - exact (TriangulatedRowExacts_to_object D X). Defined. Definition TriangulatedRowMors_to_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMors abgr_Abelian (TriangulatedRow_to_object D2 X) (TriangulatedRow_to_object D1 X). Proof. use make_FiveRowMors. - exact (to_premor_monoidfun PT _ _ _ (# (AddEquiv1 Trans) (MPMor2 M))). - exact (to_premor_monoidfun PT _ _ _ (# (AddEquiv1 Trans) (MPMor1 M))). - exact (to_premor_monoidfun PT _ _ _ (MPMor3 M)). - exact (to_premor_monoidfun PT _ _ _ (MPMor2 M)). - exact (to_premor_monoidfun PT _ _ _ (MPMor1 M)). Defined. Definition TriangulatedMorsComm_to_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMorsComm abgr_Abelian _ _ (TriangulatedRowMors_to_object M X). Proof. use make_FiveRowMorsComm. - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. rewrite assoc. apply cancel_postcomposition. rewrite <- PreAdditive_invlcomp. rewrite <- PreAdditive_invrcomp. apply maponpaths. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. exact (MPComm1 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. rewrite assoc. apply cancel_postcomposition. exact (DComm3 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. rewrite assoc. apply cancel_postcomposition. exact (MPComm2 M). - use monoidfun_paths. use funextfun. intros x. cbn. unfold to_premor. rewrite assoc. rewrite assoc. apply cancel_postcomposition. exact (MPComm1 M). Qed. Definition TriangulatedMorphism_to_object {D1 D2 : @DTri PT} (M : TriMor D1 D2) (X : ob PT) : @FiveRowMorphism abgr_Abelian (TriangulatedRow_to_object D2 X) (TriangulatedRow_to_object D1 X) . Proof. use make_FiveRowMorphism. - exact (TriangulatedRowMors_to_object M X). - exact (TriangulatedMorsComm_to_object M X). Defined. Lemma TriangulatedFiveLemma {D1 D2 : @DTri PT} (M : TriMor D1 D2) (H1 : is_z_isomorphism (MPMor1 M)) (H2 : is_z_isomorphism (MPMor2 M)) : is_z_isomorphism (MPMor3 M). Proof. set (Mor1 := TriangulatedMorphism_from_object M (Ob3 D2)). set (Mor2 := TriangulatedMorphism_to_object M (Ob3 D1)). assert (e1 : is_z_isomorphism (@FMor3 abgr_Abelian _ _ Mor1)). { use FiveLemma. - exact (@abgr_Additive_is_iso_postmor PT _ _ _ _ H1). - exact (@abgr_Additive_is_iso_postmor PT _ _ _ _ H2). - exact (abgr_Additive_is_iso_postmor (Ob3 D2) _ _ (functor_on_is_z_isomorphism (AddEquiv1 (@Trans PT)) H1)). - exact (abgr_Additive_is_iso_postmor (Ob3 D2) _ _ (functor_on_is_z_isomorphism (AddEquiv1 (@Trans PT)) H2)). } assert (e2 : is_z_isomorphism (@FMor3 abgr_Abelian _ _ Mor2)). { use FiveLemma. - exact (abgr_Additive_is_iso_premor _ _ (Ob3 D1) (functor_on_is_z_isomorphism (AddEquiv1 (@Trans PT)) H2)). - exact (abgr_Additive_is_iso_premor _ _ (Ob3 D1) (functor_on_is_z_isomorphism (AddEquiv1 (@Trans PT)) H1)). - exact (@abgr_Additive_is_iso_premor PT _ _ _ _ H2). - exact (@abgr_Additive_is_iso_premor PT _ _ _ _ H1). } exact (@abgr_Additive_premor_postmor_is_iso PT _ _ (MPMor3 M) e2 e1). Qed. Lemma TriangulatedFiveLemma2 {D1 D2 : @DTri PT} (M : TriMor D1 D2) (H1 : is_z_isomorphism (MPMor1 M)) (H2 : is_z_isomorphism (MPMor3 M)) : is_z_isomorphism (MPMor2 M). Proof. exact (TriangulatedFiveLemma (InvRotDTriMor M) (functor_on_is_z_isomorphism (AddEquiv2 Trans) H2) H1). Qed. Lemma TriangulatedFiveLemma1 {D1 D2 : @DTri PT} (M : TriMor D1 D2) (H1 : is_z_isomorphism (MPMor2 M)) (H2 : is_z_isomorphism (MPMor3 M)) : is_z_isomorphism (MPMor1 M). Proof. exact (TriangulatedFiveLemma (InvRotDTriMor (InvRotDTriMor M)) (functor_on_is_z_isomorphism (AddEquiv2 Trans) H1) (functor_on_is_z_isomorphism (AddEquiv2 Trans) H2)). Qed. End triangulated_five_lemma. (** ** Change triangles in extension using isomorphisms *) Section Ext_isomorphisms. Lemma DExtIso_Comm1 {PT : PreTriangData} {D1 D2 : DTri} (D1' D2' : Tri) (I1 : TriIso D1 D1') (I2 : TriIso D2 D2') {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} (H : f1 · Mor1 D2 = Mor1 D1 · f2) (h : Ob3 D1' --> Ob3 D2') (comm1 : Mor2 D1' · h = MPMor2 (TriIsoInv I1) · f2 · MPMor2 I2 · Mor2 D2') (comm2 : Mor3 D1' · (# (AddEquiv1 (@Trans PT)) (MPMor1 (TriIsoInv I1) · f1 · MPMor1 I2)) = h · Mor3 D2') : Mor2 D1 · (MPMor3 I1 · h · MPMor3 (TriIsoInv I2)) = f2 · Mor2 D2. Proof. rewrite assoc. rewrite assoc. rewrite <- (MPComm2 I1). rewrite <- (assoc _ (Mor2 D1')). rewrite comm1. rewrite assoc. rewrite assoc. rewrite assoc. cbn. rewrite (is_inverse_in_precat1 (TriMor_is_iso2 I1)). rewrite id_left. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite assoc. rewrite (MPComm2 I2). rewrite <- assoc. rewrite (is_inverse_in_precat1 (TriMor_is_iso3 I2)). apply id_right. Qed. Lemma DExtIso_Comm2 {PT : PreTriangData} {D1 D2 : DTri} (D1' D2' : Tri) (I1 : TriIso D1 D1') (I2 : TriIso D2 D2') {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} (H : f1 · Mor1 D2 = Mor1 D1 · f2) (h : Ob3 D1' --> Ob3 D2') (comm1 : Mor2 D1' · h = MPMor2 (TriIsoInv I1) · f2 · MPMor2 I2 · Mor2 D2') (comm2 : Mor3 D1' · (# (AddEquiv1 (@Trans PT)) (MPMor1 (TriIsoInv I1) · f1 · MPMor1 I2)) = h · Mor3 D2') : Mor3 D1 · # (AddEquiv1 Trans) f1 = MPMor3 I1 · h · MPMor3 (TriIsoInv I2) · Mor3 D2. Proof. rewrite functor_comp in comm2. rewrite functor_comp in comm2. rewrite assoc in comm2. rewrite assoc in comm2. rewrite <- (DComm3 (TriIsoInv I1)) in comm2. rewrite <- assoc. rewrite (DComm3 (TriIsoInv I2)). use (pre_comp_with_z_iso_inv_is_inj (TriMor_is_iso3 I1)). use (post_comp_with_z_iso_is_inj (functor_on_is_z_isomorphism (AddEquiv1 Trans) (TriMor_is_iso1 I2))). rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- assoc. rewrite <- functor_comp. rewrite <- functor_comp. cbn. rewrite (is_inverse_in_precat2 (TriMor_is_iso1 I2)). rewrite functor_id. rewrite id_right. rewrite assoc. rewrite assoc. rewrite assoc. rewrite (is_inverse_in_precat2 (TriMor_is_iso3 I1)). rewrite id_left. rewrite <- comm2. rewrite functor_comp. rewrite assoc. apply idpath. Qed. Definition DExtIso {PT : PreTriangData} {D1 D2 : DTri} (D1' D2' : Tri) (I1 : TriIso D1 D1') (I2 : TriIso D2 D2') {f1 : Ob1 D1 --> Ob1 D2} {f2 : Ob2 D1 --> Ob2 D2} (H : f1 · Mor1 D2 = Mor1 D1 · f2) (h : Ob3 D1' --> Ob3 D2') (comm1 : Mor2 D1' · h = MPMor2 (TriIsoInv I1) · f2 · MPMor2 I2 · Mor2 D2') (comm2 : Mor3 D1' · (# (AddEquiv1 (@Trans PT)) (MPMor1 (TriIsoInv I1) · f1 · MPMor1 I2)) = h · Mor3 D2') : TExt H. Proof. use make_TExt. - exact (MPMor3 I1 · h · MPMor3 (TriIsoInv I2)). - exact (DExtIso_Comm1 D1' D2' I1 I2 H h comm1 comm2). - exact (DExtIso_Comm2 D1' D2' I1 I2 H h comm1 comm2). Defined. End Ext_isomorphisms. (** ** Change triangles in octa using isomorphisms *) Section Octa_isomorphisms. Lemma OctaIsoMPMorMors {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : MPMorMors (make_MorphismPair (MPMor3 I1 · OctaMor1 O · is_z_isomorphism_mor (TriMor_is_iso3 I3)) (MPMor3 I3 · OctaMor2 O · is_z_isomorphism_mor (TriMor_is_iso3 I2))) (make_MorphismPair (dirprod_pr1 (pr1 O)) (dirprod_pr2 (pr1 O))). Proof. use make_MPMorMors. - exact (MPMor3 I1). - exact (MPMor3 I3). - exact (MPMor3 I2). Defined. Lemma OctaIsoMorComms {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : MPMorComms (OctaIsoMPMorMors H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). Proof. use make_MPMorComms. - cbn. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := is_inverse_in_precat2 (TriMor_is_iso3 I3)). apply (maponpaths (compose (OctaMor1 O))) in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite id_right. apply idpath. - cbn. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. set (tmp := is_inverse_in_precat2 (TriMor_is_iso3 I2)). apply (maponpaths (compose (OctaMor2 O))) in tmp. use (pathscomp0 _ (! tmp)). clear tmp. rewrite id_right. apply idpath. Qed. Lemma OctaIsoMorComm3 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : MPMor3 I2 · (g3' · # (AddEquiv1 Trans) f2') = g3 · # (AddEquiv1 Trans) f2 · # (AddEquiv1 Trans) (MPMor3 I1). Proof. cbn. rewrite assoc. set (tmp := DComm3 I2). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. set (tmp := MPComm2 I1). cbn in tmp. rewrite <- tmp. apply cancel_postcomposition. exact II12. Qed. Definition OctaIsoComm1 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : MPMor3 I1 · OctaMor1 O · is_z_isomorphism_mor (TriMor_is_iso3 I3) · h3 = f3. Proof. set (tmp := DComm3 (TriIsoInv I3)). cbn in tmp. rewrite <- assoc. cbn. rewrite tmp. clear tmp. rewrite assoc. rewrite <- (assoc _ (OctaMor1 O)). rewrite (OctaComm1 O). set (tmp := DComm3 I1). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. rewrite <- functor_comp. cbn in II13. rewrite II13. set (tmp := is_inverse_in_precat1 (TriMor_is_iso1 I3)). cbn in tmp. rewrite tmp. clear tmp. rewrite functor_id. apply id_right. Qed. Definition OctaIsoComm2 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : h2 · (MPMor3 I3 · OctaMor2 O · is_z_isomorphism_mor (TriMor_is_iso3 I2)) = g2. Proof. rewrite assoc. rewrite assoc. set (tmp := MPComm2 I3). cbn in tmp. cbn. rewrite <- tmp. clear tmp. rewrite <- (assoc _ h2'). rewrite (OctaComm2 O). set (tmp := MPComm2 (TriIsoInv I2)). cbn in tmp. rewrite <- (assoc _ g2'). rewrite <- tmp. clear tmp. rewrite assoc. cbn in II23. rewrite <- II23. set (tmp := is_inverse_in_precat1 (TriMor_is_iso2 I2)). cbn in tmp. rewrite tmp. clear tmp. apply id_left. Qed. Definition OctaIsoComm3 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : f2 · (MPMor3 I1 · OctaMor1 O · is_z_isomorphism_mor (TriMor_is_iso3 I3)) = g1 · h2. Proof. cbn. rewrite assoc. rewrite assoc. set (tmp := MPComm2 I1). cbn in tmp. rewrite <- tmp. clear tmp. set (tmp := OctaComm3 O). rewrite <- (assoc _ f2'). rewrite tmp. clear tmp. rewrite assoc. set (tmp := MPComm1 I2). cbn in tmp. cbn in II12. rewrite <- II12. rewrite tmp. clear tmp. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition. cbn in II23. rewrite II23. rewrite assoc. set (tmp := MPComm2 I3). cbn in tmp. rewrite tmp. clear tmp. rewrite <- assoc. set (tmp := is_inverse_in_precat1 (TriMor_is_iso3 I3)). cbn in tmp. rewrite tmp. apply id_right. Qed. Definition OctaIsoComm4 {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : MPMor3 I3 · OctaMor2 O · is_z_isomorphism_mor (TriMor_is_iso3 I2) · g3 = h3 · # (AddEquiv1 Trans) f1. Proof. rewrite <- assoc. set (tmp := DComm3 (TriIsoInv I2)). cbn in tmp. cbn. rewrite tmp. clear tmp. set (tmp := OctaComm4 O). rewrite <- (assoc _ (OctaMor2 O)). rewrite (assoc (OctaMor2 O)). rewrite tmp. clear tmp. rewrite <- assoc. rewrite <- functor_comp. set (tmp := MPComm1 (TriIsoInv I1)). cbn in tmp. assert (e : is_z_isomorphism_mor (TriMor_is_iso1 I2) = is_z_isomorphism_mor (TriMor_is_iso2 I1)). { use is_z_isomorphism_mor_eq. exact II12. } cbn in e. rewrite e. clear e. rewrite <- tmp. clear tmp. rewrite functor_comp. rewrite assoc. rewrite assoc. apply cancel_postcomposition. set (tmp := DComm3 I3). cbn in tmp. rewrite tmp. clear tmp. cbn. use (pathscomp0 _ (id_right _)). rewrite <- assoc. apply cancel_precomposition. rewrite <- functor_id. use (pathscomp0 (! (functor_comp (AddEquiv1 Trans) _ _))). apply maponpaths. cbn in II13. rewrite <- II13. exact (is_inverse_in_precat1 (TriMor_is_iso1 I1)). Qed. Definition OctaIso {PT : PreTriang} {x1 x2 y1 y2 z1 z2 : ob PT} {f1 : x1 --> y1} {f2 : y1 --> z2} {f3 : z2 --> (AddEquiv1 Trans x1)} {g1 : y1 --> z1} {g2 : z1 --> x2} {g3 : x2 --> (AddEquiv1 Trans y1)} {h2 : z1 --> y2} {h3 : y2 --> (AddEquiv1 Trans x1)} (H1 : isDTri (make_Tri f1 f2 f3)) (H2 : isDTri (make_Tri g1 g2 g3)) (H3 : isDTri (make_Tri (f1 · g1) h2 h3)) {x1' x2' y1' y2' z1' z2' : ob PT} {f1' : x1' --> y1'} {f2' : y1' --> z2'} {f3' : z2' --> (AddEquiv1 Trans x1')} {g1' : y1' --> z1'} {g2' : z1' --> x2'} {g3' : x2' --> (AddEquiv1 Trans y1')} {h2' : z1' --> y2'} {h3' : y2' --> (AddEquiv1 Trans x1')} (H1' : isDTri (make_Tri f1' f2' f3')) (H2' : isDTri (make_Tri g1' g2' g3')) (H3' : isDTri (make_Tri (f1' · g1') h2' h3')) (I1 : TriIso (make_Tri f1 f2 f3) (make_Tri f1' f2' f3')) (I2 : TriIso (make_Tri g1 g2 g3) (make_Tri g1' g2' g3')) (I3 : TriIso (make_Tri (f1 · g1) h2 h3) (make_Tri (f1' · g1') h2' h3')) (II12 : MPMor1 I2 = MPMor2 I1) (II13 : MPMor1 I1 = MPMor1 I3) (II23 : MPMor2 I2 = MPMor2 I3) (O : Octa H1' H2' H3') : Octa H1 H2 H3. Proof. use make_Octa. - exact (MPMor3 I1 · OctaMor1 O · is_z_isomorphism_mor (TriMor_is_iso3 (TriIso_is_iso I3))). - exact (MPMor3 I3 · OctaMor2 O · is_z_isomorphism_mor (TriMor_is_iso3 (TriIso_is_iso I2))). - use (DTrisUnderIso PT (OctaDTri O) _ _ (DTriisDTri (OctaDTri O))). use hinhpr. use TriIsoInv. use make_TriIso. + use make_TriMor. * use make_MPMor. -- exact (OctaIsoMPMorMors H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). -- exact (OctaIsoMorComms H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). * exact (OctaIsoMorComm3 H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). + use make_TriMor_is_iso. * exact (TriMor_is_iso3 I1). * exact (TriMor_is_iso3 I3). * exact (TriMor_is_iso3 I2). - exact (OctaIsoComm1 H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). - exact (OctaIsoComm2 H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). - exact (OctaIsoComm3 H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). - exact (OctaIsoComm4 H1 H2 H3 H1' H2' H3' I1 I2 I3 II12 II13 II23 O). Defined. End Octa_isomorphisms. UniMath-20231010/UniMath/Induction/000077500000000000000000000000001451125700300166105ustar00rootroot00000000000000UniMath-20231010/UniMath/Induction/.package/000077500000000000000000000000001451125700300202615ustar00rootroot00000000000000UniMath-20231010/UniMath/Induction/.package/files000066400000000000000000000003311451125700300213030ustar00rootroot00000000000000FunctorAlgebras_legacy.v FunctorCoalgebras_legacy.v PolynomialFunctors.v ImpredicativeInductiveSets.v M/Core.v M/Limits.v M/Uniqueness.v W/Core.v W/Fibered.v W/Naturals.v W/Uniqueness.v M/Chains.v M/ComputationalM.v UniMath-20231010/UniMath/Induction/FunctorAlgebras_legacy.v000066400000000000000000000446131451125700300234140ustar00rootroot00000000000000(** **************************************************************** Benedikt Ahrens started March 2015 Extended by: Anders Mörtberg. October 2015 *******************************************************************) (** *************************************************************** Contents : - Category of algebras of an endofunctor - This category is saturated if base precategory is - Lambek's lemma: if (A,a) is an inital F-algebra then a is an iso - The natural numbers are initial for X ↦ 1 + X ******************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.initial. (* The following are used for examples *) Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.NNO. Local Open Scope cat. (** ** Category of algebras of an endofunctor *) Section Algebra_Definition. Context {C : precategory} (F : functor C C). Definition algebra_ob : UU := ∑ X : C, F X --> X. (* this coercion causes confusion, and it is not inserted when parsing most of the time thus removing coercion globally *) Definition alg_carrier (X : algebra_ob) : C := pr1 X. Local Coercion alg_carrier : algebra_ob >-> ob. Definition alg_map (X : algebra_ob) : F X --> X := pr2 X. (** A morphism of an F-algebras (F X, g : F X --> X) and (F Y, h : F Y --> Y) is a morphism f : X --> Y such that the following diagram commutes: << F f F x ----> F y | | | g | h V V x ------> y f >> *) Definition is_algebra_mor (X Y : algebra_ob) (f : alg_carrier X --> alg_carrier Y) : UU := alg_map X · f = #F f · alg_map Y. Definition algebra_mor (X Y : algebra_ob) : UU := ∑ f : X --> Y, is_algebra_mor X Y f. Coercion mor_from_algebra_mor (X Y : algebra_ob) (f : algebra_mor X Y) : X --> Y := pr1 f. Lemma algebra_mor_commutes (X Y : algebra_ob) (f : algebra_mor X Y) : alg_map X · f = #F f · alg_map Y. Proof. exact (pr2 f). Qed. Definition algebra_mor_id (X : algebra_ob) : algebra_mor X X. Proof. exists (identity _ ). abstract (unfold is_algebra_mor; rewrite id_right ; rewrite functor_id; rewrite id_left; apply idpath). Defined. Definition algebra_mor_comp (X Y Z : algebra_ob) (f : algebra_mor X Y) (g : algebra_mor Y Z) : algebra_mor X Z. Proof. exists (f · g). abstract (unfold is_algebra_mor; rewrite assoc; rewrite algebra_mor_commutes; rewrite <- assoc; rewrite algebra_mor_commutes; rewrite functor_comp, assoc; apply idpath). Defined. Definition precategory_alg_ob_mor : precategory_ob_mor. Proof. exists algebra_ob. exact algebra_mor. Defined. Definition precategory_alg_data : precategory_data. Proof. exists precategory_alg_ob_mor. exists algebra_mor_id. exact algebra_mor_comp. Defined. End Algebra_Definition. Definition isaset_algebra_mor {C : category} (F : functor C C) (X Y : algebra_ob F) : isaset (algebra_mor F X Y). Proof. apply (isofhleveltotal2 2). - apply C. - intro f. apply isasetaprop. apply C. Qed. Definition algebra_mor_eq {C : category} (F : functor C C) {X Y : algebra_ob F} {f g : algebra_mor F X Y} : (f : alg_carrier F X --> alg_carrier F Y) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro a. apply C. Defined. Lemma is_precategory_precategory_alg_data {C : category} (F : functor C C) : is_precategory (precategory_alg_data F). Proof. repeat split; intros; simpl. - apply algebra_mor_eq. apply id_left. - apply algebra_mor_eq. apply id_right. - apply algebra_mor_eq. apply assoc. - apply algebra_mor_eq. apply assoc'. Qed. Definition precategory_FunctorAlg {C : category} (F : functor C C) : precategory := tpair _ _ (is_precategory_precategory_alg_data F). Lemma has_homsets_FunctorAlg {C : category} (F : functor C C) : has_homsets (precategory_FunctorAlg F). Proof. intros f g. apply isaset_algebra_mor. Qed. Definition category_FunctorAlg {C : category} (F : functor C C) : category := make_category (precategory_FunctorAlg F) (has_homsets_FunctorAlg F). Notation FunctorAlg := category_FunctorAlg. Section fixacategory. Context {C : category} (F : functor C C). (** forgetful functor from FunctorAlg to its underlying category *) (* first step of definition *) Definition forget_algebras_data : functor_data (FunctorAlg F) C. Proof. set (onobs := fun alg : FunctorAlg F => alg_carrier F alg). apply (make_functor_data onobs). intros alg1 alg2 m. simpl in m. exact (mor_from_algebra_mor _ _ _ m). Defined. (* the forgetful functor *) Definition forget_algebras : functor (FunctorAlg F) C. Proof. apply (make_functor forget_algebras_data). abstract ( split; [intro alg; apply idpath | intros alg1 alg2 alg3 m n; apply idpath] ). Defined. End fixacategory. (** ** This category is saturated if the base category is *) Section FunctorAlg_saturated. Context {C : category} (H : is_univalent C) (F : functor C C). Definition algebra_eq_type (X Y : FunctorAlg F) : UU := ∑ p : z_iso (pr1 X) (pr1 Y), is_algebra_mor F X Y p. Definition algebra_ob_eq (X Y : FunctorAlg F) : (X = Y) ≃ algebra_eq_type X Y. Proof. eapply weqcomp. - apply total2_paths_equiv. - set (H1 := make_weq _ (H (pr1 X) (pr1 Y))). apply (weqbandf H1). simpl. intro p. destruct X as [X α]. destruct Y as [Y β]; simpl in *. destruct p. rewrite idpath_transportf. unfold is_algebra_mor; simpl. rewrite functor_id. rewrite id_left, id_right. apply idweq. Defined. Definition is_z_iso_from_is_algebra_iso (X Y : FunctorAlg F) (f : X --> Y) : is_z_isomorphism f → is_z_isomorphism (pr1 f). Proof. intro p. set (H' := z_iso_inv_after_z_iso (make_z_iso' f p)). set (H'':= z_iso_after_z_iso_inv (make_z_iso' f p)). exists (pr1 (inv_from_z_iso (make_z_iso' f p))). split; simpl. - apply (maponpaths pr1 H'). - apply (maponpaths pr1 H''). Defined. Definition inv_algebra_mor_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y) : is_z_isomorphism (pr1 f) → (Y --> X). Proof. intro T. set (fiso:=make_z_iso' (pr1 f) T). set (finv:=inv_from_z_iso fiso). exists finv. unfold finv. apply pathsinv0. apply z_iso_inv_on_left. simpl. rewrite functor_on_inv_from_z_iso. rewrite <- assoc. apply pathsinv0. apply z_iso_inv_on_right. simpl. apply (pr2 f). Defined. Definition is_algebra_iso_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y) : is_z_isomorphism (pr1 f) → is_z_isomorphism f. Proof. intro T. exists (inv_algebra_mor_from_is_z_iso f T). split; simpl. - apply algebra_mor_eq. apply (z_iso_inv_after_z_iso (make_z_iso' (pr1 f) T)). - apply algebra_mor_eq. apply (z_iso_after_z_iso_inv (make_z_iso' (pr1 f) T)). Defined. Definition algebra_iso_first_z_iso {X Y : FunctorAlg F} : z_iso X Y ≃ ∑ f : X --> Y, is_z_isomorphism (pr1 f). Proof. apply (weqbandf (idweq _ )). unfold idweq. simpl. intro f. apply weqimplimpl. - apply is_z_iso_from_is_algebra_iso. - apply is_algebra_iso_from_is_z_iso. - apply (isaprop_is_z_isomorphism(C:=FunctorAlg F) f). - apply (isaprop_is_z_isomorphism f). Defined. Definition swap (A B : UU) : A × B → B × A. Proof. intro ab. exists (pr2 ab). exact (pr1 ab). Defined. Definition swapweq (A B : UU) : (A × B) ≃ (B × A). Proof. exists (swap A B). apply (isweq_iso _ (swap B A)). - abstract ( intro ab; destruct ab; apply idpath ). - abstract ( intro ba; destruct ba; apply idpath ). Defined. Definition algebra_z_iso_rearrange {X Y : FunctorAlg F} : (∑ f : X --> Y, is_z_isomorphism (pr1 f)) ≃ algebra_eq_type X Y. Proof. eapply weqcomp. - apply weqtotal2asstor. - simpl. unfold algebra_eq_type. apply invweq. eapply weqcomp. + apply weqtotal2asstor. + simpl. apply (weqbandf (idweq _ )). unfold idweq. simpl. intro f; apply swapweq. Defined. Definition algebra_idtoiso (X Y : FunctorAlg F) : (X = Y) ≃ z_iso X Y. Proof. eapply weqcomp. - apply algebra_ob_eq. - eapply weqcomp. + apply (invweq (algebra_z_iso_rearrange)). + apply (invweq algebra_iso_first_z_iso). Defined. Lemma isweq_idtoiso_FunctorAlg (X Y : FunctorAlg F) : isweq (@idtoiso _ X Y). Proof. apply (isweqhomot (algebra_idtoiso X Y)). - intro p. induction p. simpl. apply (z_iso_eq(C:=FunctorAlg F)). apply algebra_mor_eq. apply idpath. - apply (pr2 _ ). Defined. Lemma is_univalent_FunctorAlg : is_univalent (FunctorAlg F). Proof. intros X Y. apply isweq_idtoiso_FunctorAlg. Defined. Lemma idtomor_FunctorAlg_commutes (X Y: FunctorAlg F)(e: X = Y): mor_from_algebra_mor F _ _ (idtomor _ _ e) = idtomor _ _ (maponpaths (alg_carrier F) e). Proof. induction e. apply idpath. Qed. Corollary idtoiso_FunctorAlg_commutes (X Y: FunctorAlg F)(e: X = Y): mor_from_algebra_mor F _ _ (morphism_from_z_iso _ _ (idtoiso e)) = idtoiso (maponpaths (alg_carrier F) e). Proof. unfold morphism_from_z_iso. rewrite eq_idtoiso_idtomor. etrans. 2: { apply pathsinv0, eq_idtoiso_idtomor. } apply idtomor_FunctorAlg_commutes. Qed. End FunctorAlg_saturated. (** ** Lambek's lemma: If (A,a) is an initial F-algebra then a is an iso *) Section Lambeks_lemma. Variables (C : category) (F : functor C C). Variables (Aa : algebra_ob F) (AaIsInitial : isInitial (FunctorAlg F) Aa). Local Definition AaInitial : Initial (FunctorAlg F) := make_Initial _ AaIsInitial. Local Notation A := (alg_carrier _ Aa). Local Notation a := (alg_map _ Aa). (* (FA,Fa) is an F-algebra *) Local Definition FAa : algebra_ob F := tpair (λ X, C ⟦F X,X⟧) (F A) (# F a). Local Definition Fa' := InitialArrow AaInitial FAa. Local Definition a' : C⟦A,F A⟧ := mor_from_algebra_mor _ _ _ Fa'. Local Definition Ha' := algebra_mor_commutes _ _ _ Fa'. Lemma initialAlg_is_iso_subproof : is_inverse_in_precat a a'. Proof. assert (Ha'a : a' · a = identity A). { assert (algMor_a'a : is_algebra_mor _ _ _ (a' · a)). { unfold is_algebra_mor, a'; rewrite functor_comp. eapply pathscomp0; [|eapply cancel_postcomposition; apply Ha']. apply assoc. } apply pathsinv0; set (X := tpair _ _ algMor_a'a). apply (maponpaths pr1 (!@InitialEndo_is_identity _ AaInitial X)). } split; trivial. eapply pathscomp0; [apply Ha'|]; cbn. rewrite <- functor_comp. eapply pathscomp0; [eapply maponpaths; apply Ha'a|]. apply functor_id. Qed. Lemma initialAlg_is_z_iso : is_z_isomorphism a. Proof. exists a'. exact initialAlg_is_iso_subproof. Defined. End Lambeks_lemma. (** ** The natural numbers are intial for X ↦ 1 + X *) (** This can be used as a definition of a natural numbers object (NNO) in any category with binary coproducts and a terminal object. We prove the universal property of NNOs below. *) Section Nats. Context (C : category). Context (bc : BinCoproducts C). Context (hsC : has_homsets C). Context (T : Terminal C). Local Notation "1" := T. Local Notation "f + g" := (BinCoproductOfArrows _ _ _ f g). Local Notation "[ f , g ]" := (BinCoproductArrow _ _ f g). Let F : functor C C := BinCoproduct_of_functors _ _ bc (constant_functor _ _ 1) (functor_identity _). (** F on objects: X ↦ 1 + X *) Definition F_compute1 : ∏ c : C, F c = BinCoproductObject (bc 1 c) := fun c => (idpath _). (** F on arrows: f ↦ [identity 1, f] *) Definition F_compute2 {x y : C} : ∏ f : x --> y, # F f = (identity 1) + f := fun c => (idpath _). Definition nat_ob : UU := Initial (FunctorAlg F). Definition nat_ob_carrier (N : nat_ob) : ob C := alg_carrier _ (InitialObject N). Local Coercion nat_ob_carrier : nat_ob >-> ob. (** We have an arrow alg_map : (F N = 1 + N) --> N, so by the η-rule (UMP) for the coproduct, we can assume that it arises from a pair of maps [nat_ob_z,nat_ob_s] by composing with coproduct injections. << in1 in2 1 ----> 1 + N <---- N | | | nat_ob_z | | alg_map | nat_ob_s | V | +-------> N <-------+ >> *) Definition nat_ob_z (N : nat_ob) : (1 --> N) := BinCoproductIn1 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)). Definition nat_ob_s (N : nat_ob) : (N --> N) := BinCoproductIn2 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)). Local Notation "0" := (nat_ob_z _). (** Use the universal property of the coproduct to make any object with a point and an endomorphism into an F-algebra *) Definition make_F_alg {X : ob C} (f : 1 --> X) (g : X --> X) : ob (FunctorAlg F). Proof. refine (X,, _). exact (BinCoproductArrow _ f g). Defined. (** Using make_F_alg, X will be an F-algebra, and by initiality of N, there will be a unique morphism of F-algebras N --> X, which can be projected to a morphism in C. *) Definition nat_ob_rec (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), (N --> X) := fun f g => mor_from_algebra_mor _ _ _ (InitialArrow N (make_F_alg f g)). (** When calling the recursor on 0, you get the base case. Specifically, nat_ob_z · nat_ob_rec = f *) Lemma nat_ob_rec_z (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), nat_ob_z N · nat_ob_rec N f g = f. Proof. intros f g. pose (inlN := BinCoproductIn1 (bc 1 N)). pose (succ := nat_ob_s N). (** By initiality of N, there is a unique morphism making the following diagram commute: << inlN identity 1 + nat_ob_rec 1 -----> 1 + N -------------------------> 1 + X | | alg_map N | | alg_map X V V N --------------------------> X nat_ob_rec >> This proof uses somewhat idiosyncratic "forward reasoning", transforming the term "diagram" rather than the goal. *) pose (diagram := maponpaths (fun x => inlN · x) (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))). rewrite (F_compute2 _) in diagram. (** Using the η-rules for coproducts, we can assume that alg_map X = [f,g] for f : 1 --> X, g : X --> X. *) rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram. (** Using the β-rules for coproducts, we can simplify some of the terms *) (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *) rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X) (identity 1) _ _ _) in diagram. (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *) rewrite (BinCoproductIn1Commutes C 1 N (bc 1 _) _ _ _) in diagram. (** We can dispense with the identity *) rewrite (id_left _) in diagram. rewrite assoc in diagram. rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram. refine (_ @ (BinCoproductIn1Commutes C _ _ (bc 1 _) _ f g)). rewrite (!BinCoproductIn1Commutes C _ _ (bc 1 _) _ 0 succ). unfold nat_ob_rec in *. exact diagram. Defined. Opaque nat_ob_rec_z. (** The succesor case: nat_ob_s · nat_ob_rec = nat_ob_rec · g The proof is very similar. *) Lemma nat_ob_rec_s (N : nat_ob) {X : ob C} : ∏ (f : 1 --> X) (g : X --> X), nat_ob_s N · nat_ob_rec N f g = nat_ob_rec N f g · g. Proof. intros f g. pose (inrN := BinCoproductIn2 (bc 1 N)). pose (succ := nat_ob_s N). (** By initiality of N, there is a unique morphism making the same diagram commute as above, but with "inrN" in place of "inlN". *) pose (diagram := maponpaths (fun x => inrN · x) (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))). rewrite (F_compute2 _) in diagram. rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram. (** Using the β-rules for coproducts, we can simplify some of the terms *) (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *) rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X) (identity 1) _ _ _) in diagram. (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *) rewrite (BinCoproductIn2Commutes C 1 N (bc 1 _) _ _ _) in diagram. rewrite assoc in diagram. rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram. refine (_ @ maponpaths (fun x => nat_ob_rec N f g · x) (BinCoproductIn2Commutes C _ _ (bc 1 _) _ f g)). rewrite (!BinCoproductIn2Commutes C _ _ (bc 1 _) _ 0 (nat_ob_s N)). unfold nat_ob_rec in *. exact diagram. Defined. Opaque nat_ob_rec_s. End Nats. (** nat_ob implies NNO *) Lemma nat_ob_NNO {C : category} (BC : BinCoproducts C) (hsC : has_homsets C) (TC : Terminal C) : nat_ob _ BC TC → NNO TC. Proof. intros N. use make_NNO. - exact (nat_ob_carrier _ _ _ N). - apply nat_ob_z. - apply nat_ob_s. - intros n z s. use unique_exists. + apply (nat_ob_rec _ _ _ _ z s). + split; [ apply nat_ob_rec_z | apply nat_ob_rec_s ]. + intros x; apply isapropdirprod; apply hsC. + intros x [H1 H2]. transparent assert (xalg : (FunctorAlg (BinCoproduct_of_functors C C BC (constant_functor C C TC) (functor_identity C)) ⟦ InitialObject N, make_F_alg C BC TC z s ⟧)). { refine (x,,_). abstract (apply pathsinv0; etrans; [apply precompWithBinCoproductArrow |]; rewrite id_left, <- H1; etrans; [eapply maponpaths, pathsinv0, H2|]; now apply pathsinv0, BinCoproductArrowUnique; rewrite assoc; apply maponpaths). } exact (maponpaths pr1 (InitialArrowUnique N (make_F_alg C BC TC z s) xalg)). Defined. UniMath-20231010/UniMath/Induction/FunctorCoalgebras_legacy.v000066400000000000000000000132341451125700300237310ustar00rootroot00000000000000(** *************************************************************** Contents: - Category of coalgebras over an endofunctor. - Dual of Lambek's lemma: if (A,α) is terminal coalgebra, α is an isomorphism. ******************************************************************) Require Import UniMath.Foundations.Propositions. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.terminal. Local Open Scope cat. Section Coalgebra_Definition. Context {C : precategory} (F : functor C C). Definition coalgebra : UU := ∑ X : C, X --> F X. Definition coalgebra_ob (X : coalgebra) : C := pr1 X. Local Coercion coalgebra_ob : coalgebra >-> ob. Definition coalgebra_mor (X : coalgebra) : C ⟦X, F X ⟧ := pr2 X. (** A homomorphism of F-coalgebras (F A, α : C ⟦A, F A⟧) and (F B, β : C ⟦B, F B⟧) is a morphism f : C ⟦A, B⟧ s.t. the below diagram commutes. << f A -----> B | | | α | β | | V V F A ---> F B F f >> *) Definition is_coalgebra_homo {X Y : coalgebra} (f : C ⟦X, Y⟧) : UU := (coalgebra_mor X) · #F f = f · (coalgebra_mor Y). Definition coalgebra_homo (X Y : coalgebra) := ∑ f : C ⟦X, Y⟧, is_coalgebra_homo f. Definition mor_from_coalgebra_homo (X Y : coalgebra) (f : coalgebra_homo X Y) : C ⟦X, Y⟧ := pr1 f. Coercion mor_from_coalgebra_homo : coalgebra_homo >-> precategory_morphisms. Definition coalgebra_homo_eq (hasHom : has_homsets C) {X Y : coalgebra} (f g : coalgebra_homo X Y) : (f : C ⟦X, Y⟧) = g ≃ f = g. Proof. apply invweq. apply subtypeInjectivity. intro. apply hasHom. Defined. Lemma coalgebra_homo_commutes {X Y : coalgebra} (f : coalgebra_homo X Y) : (coalgebra_mor X) · #F f = f · (coalgebra_mor Y). Proof. exact (pr2 f). Defined. Definition coalgebra_homo_id (X : coalgebra) : coalgebra_homo X X. Proof. exists (identity _). unfold is_coalgebra_homo. rewrite id_left. rewrite functor_id. rewrite id_right. apply idpath. Defined. Definition coalgebra_homo_comp (X Y Z : coalgebra) (f : coalgebra_homo X Y) (g : coalgebra_homo Y Z) : coalgebra_homo X Z. Proof. exists (f · g). unfold is_coalgebra_homo. rewrite functor_comp. rewrite assoc. rewrite coalgebra_homo_commutes. rewrite <- assoc. rewrite coalgebra_homo_commutes. rewrite assoc. apply idpath. Defined. Definition CoAlg_precategory_ob_mor : precategory_ob_mor := make_precategory_ob_mor coalgebra coalgebra_homo. Definition CoAlg_precategory_data: precategory_data := make_precategory_data CoAlg_precategory_ob_mor coalgebra_homo_id coalgebra_homo_comp. End Coalgebra_Definition. Definition isaset_coalgebra_homo {C : category} (F : functor C C) {X Y : coalgebra F} : isaset (coalgebra_homo F X Y). Proof. apply (isofhleveltotal2 2). - apply C. - intro f. apply isasetaprop. apply C. Defined. Lemma CoAlg_is_precategory {C : category} (F : functor C C) : is_precategory (CoAlg_precategory_data F). Proof. split. - split. + intros. apply coalgebra_homo_eq. * apply C. * apply id_left. + intros. apply coalgebra_homo_eq. * apply C. * apply id_right. - { split. - intros. apply coalgebra_homo_eq. + apply C. + apply assoc. - intros. apply coalgebra_homo_eq. + apply C. + apply assoc'. } Defined. Definition CoAlg_precategory {C : category} (F : functor C C) : precategory := make_precategory (CoAlg_precategory_data F) (CoAlg_is_precategory F). Lemma has_homsets_coalgebra {C : category} (F : functor C C) : has_homsets (CoAlg_precategory F). Proof. intros f g. apply isaset_coalgebra_homo. Defined. Definition CoAlg_category {C : category} (F : functor C C) : category := make_category _ (has_homsets_coalgebra F). Section Lambek_dual. (** Dual of Lambeks Lemma : If (A,α) is terminal F-coalgebra, then α is an iso *) Context (C : category) (F : functor C C) (X : coalgebra F). Local Notation F_CoAlg := (CoAlg_category F). Context (isTerminalX : isTerminal F_CoAlg X). Definition TerminalX : Terminal F_CoAlg := make_Terminal _ isTerminalX. Local Notation α := (coalgebra_mor _ (TerminalObject TerminalX)). Local Notation A := (coalgebra_ob _ (TerminalObject TerminalX)). (** FX := (FA,Fα) is also an F-coalgebra *) Definition FX : coalgebra F := tpair _ (F A) (#F α). (** By terminality there is an arrow α' : FA → A, s.t.: << α' FA ------> A | | | Fα | α V V FFA ------> FA Fα' >> commutes *) Definition f : F_CoAlg ⟦FX, TerminalX⟧ := (@TerminalArrow F_CoAlg TerminalX FX). Definition α' : C ⟦F A, A⟧ := mor_from_coalgebra_homo F FX X f. Definition αα'_mor : coalgebra_homo F X X. Proof. exists (α · α'). unfold is_coalgebra_homo. rewrite <- assoc. apply cancel_precomposition. rewrite functor_comp. apply (coalgebra_homo_commutes F f). Defined. Definition αα'_idA : α · α' = identity A := maponpaths pr1 (TerminalEndo_is_identity (T:=TerminalX) αα'_mor). Lemma α'α_idFA : α' · α = identity (F A). Proof. rewrite <- functor_id. rewrite <- αα'_idA. rewrite functor_comp. unfold α'. apply pathsinv0. apply (coalgebra_homo_commutes F f). Defined. Lemma terminalcoalgebra_isiso : is_iso α. Proof. apply (is_iso_qinv α α'). split. - exact αα'_idA. - exact α'α_idFA. Defined. Definition terminalcoalgebra_iso : iso A (F A) := make_iso α terminalcoalgebra_isiso. End Lambek_dual. UniMath-20231010/UniMath/Induction/ImpredicativeInductiveSets.v000066400000000000000000000403631451125700300243040ustar00rootroot00000000000000(** ** Impredicative Construction of Inductive Types that are Sets and Eliminate into Sets *) (** This is based on Sam Speight's master's thesis A Lean formalization of this had been available at https://github.com/jonas-frey/Impredicative/blob/master/ The aim of this project at the UniMath School 2019 was to have the same results within UniMath - for the time being only binary products, binary coproducts and natural numbers. This has been achieved (with a minor addition afterwards). The Lean code we used is always put into a comment at the end of the sections. Authors: Ralph Matthes (@rmatthes), Sam Speight (@sspeight93) *) Require Import UniMath.Foundations.Init. Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Local Open Scope cat. Local Open Scope functions. Section BinaryProduct. Variable A B: HSET. Definition pre_prod: UU := ∏ (X: HSET), (pr1hSet A -> pr1hSet B -> pr1hSet X) -> pr1hSet X. Lemma pre_prod_isaset: isaset pre_prod. Proof. change (isofhlevel 2 pre_prod). do 2 (apply impred; intro). apply setproperty. Defined. Definition pre_prod_as_set: HSET := make_hSet pre_prod pre_prod_isaset. Definition nProduct (α: pre_prod): UU := ∏(X Y : HSET) (f : pr1hSet X → pr1hSet Y) (h : pr1hSet A -> pr1hSet B -> pr1hSet X), f (α X h) = α Y (λ a b, f (h a b)). Definition nProduct_isaset (α: pre_prod): isaset (nProduct α). Proof. change (isofhlevel 2 (nProduct α)). do 4 (apply impred; intro). apply hlevelntosn. apply setproperty. Defined. Definition nProduct_as_set (α: pre_prod): HSET := make_hSet _ (nProduct_isaset α). Definition Product: UU := ∑ α: pre_prod, pr1hSet (nProduct_as_set α). Definition Product_isaset: isaset Product. Proof. apply (isaset_total2_hSet pre_prod_as_set). Defined. Definition Product_as_set: HSET := make_hSet _ Product_isaset. Definition Pair (a : pr1hSet A) (b : pr1hSet B) : Product. Proof. use tpair. - exact (λ X f, f a b). - cbn. red. intros; apply idpath. Defined. Definition Proj1: HSET ⟦Product_as_set, A⟧. Proof. cbn. intro p. induction p as [α H]. apply α. exact (fun x y => x). Defined. Definition Proj2: HSET ⟦Product_as_set, B⟧. Proof. cbn. intro p. induction p as [α H]. apply α. exact (fun x y => y). Defined. Definition Product_rec {C: HSET} (f: pr1hSet A -> pr1hSet B -> pr1hSet C) (p: Product) : pr1hSet C. Proof. induction p. apply (pr1 C f). Defined. Lemma Product_beta (C: HSET) (f: pr1hSet A -> pr1hSet B -> pr1hSet C) (a: pr1hSet A) (b: pr1hSet B) : Product_rec f (Pair a b) = f a b. Proof. apply idpath. Defined. Lemma Product_weak_η (x: Product) : Product_rec (C := Product_as_set) Pair x = x. Proof. induction x as [P H]. use total2_paths_f. - cbn. (* UniMath.MoreFoundations.Tactics.show_id_type. *) unfold pre_prod in P. apply funextsec; intro X. apply funextfun; intro f. cbn in H; red in H. exact (H Product_as_set X (fun x => pr1 x X f) Pair). - cbn. cbn in H. red in H. do 4 (apply funextsec; intro). apply setproperty. Defined. Lemma Product_com_con {C D : HSET} (f : pr1hSet A → pr1hSet B → pr1hSet C) (g : pr1hSet C → pr1hSet D): Product_rec (λ a b, g (f a b)) = g ∘ Product_rec f. Proof. apply funextfun. intro x. induction x as [p H]. cbn in H. red in H. apply pathsinv0. exact (H C D g f). Defined. Lemma Product_η {C : HSET} (g : Product → pr1hSet C): Product_rec (λ a b, g (Pair a b)) = g. Proof. eapply pathscomp0. - apply (Product_com_con (C := Product_as_set) Pair). - apply funextfun; intro p. simpl. apply maponpaths. apply Product_weak_η. Defined. Lemma Product_classical_η (p: Product) : Pair (Proj1 p) (Proj2 p) = p. Proof. apply pathsinv0. eapply pathscomp0. - apply pathsinv0. apply Product_weak_η. - set (Product_η_inst := Product_η (C := Product_as_set) (fun x => Pair (Proj1 x) (Proj2 x))). cbn in Product_η_inst. apply toforallpaths in Product_η_inst. apply Product_η_inst. Defined. Lemma Product_univ_prop {C : HSET} : isweq (@Product_rec C). Proof. use isweq_iso. - exact (λ f a b, f (Pair a b)). - apply idpath. - apply Product_η. Defined. (* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L173 onwards: /- Product A × B of sets -/ -- System F encoding definition preProduct (A B : USet) : USet := tΠ (X : USet), (A ⇒ B ⇒ X) ⇒ X -- naturality condition definition nProduct {A B : USet} (α : preProduct A B) : UPrp := tΠ(X Y : USet) (f : X → Y) (h : A ⇒ B ⇒ X), f (α X h) == α Y (λ a, f ∘ h a) -- refined encoding definition Product (A B : USet) : USet := σ(α : preProduct A B), nProduct α -- constructor definition Pair {A B : USet} (a : A) (b : B) : Product A B := ⟨λ X f, f a b, λ X Y f g, rfl⟩ -- eliminators definition Proj1 {A B : USet} : Product A B → A := sigma.rec (λ alpha p, alpha A (λ x y, x)) definition Proj2 {A B : USet} : Product A B → B := sigma.rec (λ alpha p, alpha B (λ x y, y)) -- recursor definition Product_rec {A B C : Set} (f : A ⇒ B ⇒ C) (p : Product A B) : C := p.1 C f -- β rule definition Product_β {A B C : USet} (f : A → B → C) (a : A) (b : B) : Product_rec f (Pair a b) = f a b := rfl -- weak η rule definition Product_weak_η {A B : USet} (x : Product A B) : Product_rec Pair x = x := begin induction x with p n, fapply sigma_eq, apply eq_of_homotopy2, intros X f, exact (n _ _ (Product_rec f) Pair), apply is_prop.elimo end -- commuting conversion definition Product_com_con {A B C D : USet} (f : A → B → C) (g : C → D) : Product_rec (λ a b, g (f a b)) = g ∘ Product_rec f := (eq_of_homotopy (λ x, x.2 C D g f))⁻¹ -- strong η rule definition Product_η {A B C : USet} (g : Product A B → C) : Product_rec (λ a b, g (Pair a b)) = g := (Product_com_con Pair g) ⬝ eq_of_homotopy (λ x, ap g (Product_weak_η x)) -- classical η rule definition Product_classical_η {A B : USet} (p : Product A B) : Pair (Proj1 p) (Proj2 p) = p := ap (λ f, f p) (Product_η _)⁻¹ ⬝ (Product_weak_η p) -- universal property definition Product_univ_prop {A B C : USet} : is_equiv (@Product_rec A B C) := adjointify Product_rec (λ f a b, f (Pair a b)) Product_η (λ g, eq_of_homotopy2 (Product_β g)) *) End BinaryProduct. Section BinaryCoproduct. Variable A B: HSET. Definition pre_sum: UU := ∏ (X: HSET), (pr1hSet A -> pr1hSet X) -> (pr1hSet B -> pr1hSet X) -> pr1hSet X. Lemma pre_sum_isaset: isaset pre_sum. Proof. change (isofhlevel 2 pre_sum). do 3 (apply impred; intro). apply setproperty. Defined. Definition pre_sum_as_set: HSET := make_hSet pre_sum pre_sum_isaset. Definition nSum (α: pre_sum): UU := ∏(X Y : HSET) (f : pr1hSet X → pr1hSet Y) (h : pr1hSet A -> pr1hSet X) (k: pr1hSet B -> pr1hSet X), f (α X h k) = α Y (f ∘ h) (f ∘ k). Definition nSum_isaset (α: pre_sum): isaset (nSum α). Proof. change (isofhlevel 2 (nSum α)). do 5 (apply impred; intro). apply hlevelntosn. apply setproperty. Defined. Definition nSum_as_set (α: pre_sum): HSET := make_hSet _ (nSum_isaset α). Definition Sum: UU := ∑ α: pre_sum, pr1hSet (nSum_as_set α). Definition Sum_isaset: isaset Sum. Proof. apply (isaset_total2_hSet pre_sum_as_set). Defined. Definition Sum_as_set: HSET := make_hSet _ Sum_isaset. Definition Sum_inl: HSET ⟦A, Sum_as_set⟧. Proof. cbn. intro a. use tpair. - intros X f g. exact (f a). - cbn. red. intros ? ? ? ? k. apply idpath. Defined. Definition Sum_inr: HSET ⟦B, Sum_as_set⟧. Proof. cbn. intro a. use tpair. - intros X f g. exact (g a). - cbn. red. intros ? ? ? ? k. apply idpath. Defined. Definition Sum_rec {C: HSET} (f: pr1hSet A -> pr1hSet C) (g: pr1hSet B -> pr1hSet C)(c: Sum) : pr1hSet C := pr1 c C f g. Lemma Sum_β_l {C: HSET} (f: pr1hSet A -> pr1hSet C) (g: pr1hSet B -> pr1hSet C): (Sum_rec f g) ∘ Sum_inl = f. Proof. apply idpath. Defined. Lemma Sum_β_r {C: HSET} (f: pr1hSet A -> pr1hSet C) (g: pr1hSet B -> pr1hSet C): (Sum_rec f g) ∘ Sum_inr = g. Proof. apply idpath. Defined. Lemma Sum_weak_eta (x: Sum) : Sum_rec (C := Sum_as_set) Sum_inl Sum_inr x = x. Proof. induction x as [c H]. use total2_paths_f. - cbn. unfold pre_sum in c. apply funextsec; intro X. apply funextfun; intro f. apply funextfun; intro g. cbn in H; red in H. apply (H Sum_as_set X (fun x => pr1 x X f g)). - cbn. cbn in H; red in H. do 5 (apply funextsec; intro). apply setproperty. Defined. Lemma Sum_com_con {X Y: HSET} (f : pr1hSet A → pr1hSet X) (g : pr1hSet B → pr1hSet X) (h : pr1hSet X → pr1hSet Y): Sum_rec (h ∘ f) (h ∘ g) = h ∘ (Sum_rec f g). Proof. apply funextfun. intro x. induction x as [c H]. cbn in H; red in H. cbn. apply pathsinv0. apply H. Defined. Lemma Sum_η {X : HSET} (h : Sum → pr1hSet X) : Sum_rec (h ∘ Sum_inl) (h ∘ Sum_inr) = h. Proof. eapply pathscomp0. apply Sum_com_con. apply funextfun; intro s. simpl. apply maponpaths. apply Sum_weak_eta. Defined. Lemma Sum_univ_prop {X: HSET} : (HSET ⟦Sum_as_set, X⟧) ≃ (Product (exponential_functor A X) (exponential_functor B X)). Proof. use weq_iso. - intro h. apply Pair. + cbn. exact (h ∘ Sum_inl). + cbn. exact (h ∘ Sum_inr). - intro a. cbn. apply Sum_rec. + exact (Proj1 _ _ a). + exact (Proj2 _ _ a). - cbn. intro x. apply Sum_η. - cbn. intro y. intermediate_path (Pair _ _ (Proj1 _ _ y) (Proj2 _ _ y)). + apply idpath. + apply Product_classical_η. Defined. (* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L233 onwards: /- Sum A + B of sets -/ -- System F encoding definition preSum (A B : USet) : USet := tΠ(X : USet), (A ⇒ X) ⇒ (B ⇒ X) ⇒ X -- naturality condition definition nSum {A B : USet} (a : preSum A B) : UPrp := tΠ(X Y : USet) (f : X→Y) (h : A→X) (k : B→X), f(a X h k) == a Y (f∘h) (f∘k) -- refined encoding definition Sum (A B : USet) : USet := σ(α : preSum A B), nSum α -- constructors definition Sum_inl {A B : USet} (a : A) : Sum A B := ⟨λ X f g, f a, λ X Y f h k, rfl⟩ definition Sum_inr {A B : USet} (b : B) : Sum A B := ⟨λ X f g, g b, λ X Y f h k, rfl⟩ -- recursor definition Sum_rec {A B X : USet} (f : A → X) (g : B → X) (c : Sum A B) : X := c.1 X f g -- β rules definition Sum_β_l {A B X : USet} (f : A → X) (g : B → X) : Sum_rec f g ∘ Sum_inl = f := rfl definition Sum_β_r {A B X : USet} (f : A → X) (g : B → X) : Sum_rec f g ∘ Sum_inr = g := rfl -- weak η definition Sum_weak_η {A B : USet} (x : Sum A B) : Sum_rec Sum_inl Sum_inr x = x := begin induction x with α p, fapply sigma_eq, apply eq_of_homotopy3, intro X f g, unfold Sum_rec, apply p, apply is_prop.elimo end --commuting conversion definition Sum_com_con {A B X Y : USet} (f : A → X) (g : B → X) (h : X → Y) : Sum_rec (h ∘ f) (h ∘ g) = h ∘ Sum_rec f g := begin apply eq_of_homotopy, intro α, induction α with α p, symmetry, apply p end -- strong η definition Sum_η {A B X : USet} (h : Sum A B → X) : Sum_rec (h∘Sum_inl) (h∘Sum_inr) = h := !Sum_com_con ⬝ eq_of_homotopy (λ x, ap h (Sum_weak_η x)) --universal property definition Sum_univ_prop {A B X : USet} : (Sum A B ⇒ X) ≃ (Product (A ⇒ X) (B ⇒ X)) := equiv.MK (λ h, Pair (h ∘ Sum_inl) (h ∘ Sum_inr)) (λ a, Sum_rec (Proj1 a) (Proj2 a)) Product_classical_η Sum_η *) End BinaryCoproduct. Section NaturalNumbers. Definition pre_nat: UU := ∏ (X: HSET), (pr1hSet X -> pr1hSet X) -> pr1hSet X -> pr1hSet X. Lemma pre_nat_isaset: isaset pre_nat. Proof. change (isofhlevel 2 pre_nat). do 3 (apply impred; intro). apply setproperty. Defined. Definition pre_nat_as_set: HSET := make_hSet _ pre_nat_isaset. Definition nNat (α: pre_nat): UU := ∏(X Y : HSET) (x: pr1hSet X) (y: pr1hSet Y)(h: pr1hSet X → pr1hSet X)(k: pr1hSet Y → pr1hSet Y) (f : pr1hSet X -> pr1hSet Y), f x = y -> f ∘ h = k ∘ f -> f (α X h x) = α Y k y. Definition nNat_isaset (α: pre_nat): isaset (nNat α). Proof. change (isofhlevel 2 (nNat α)). do 9 (apply impred; intro). apply hlevelntosn. apply setproperty. Defined. Definition nNat_as_set (α: pre_nat): HSET := make_hSet _ (nNat_isaset α). Definition Nat: UU := ∑ α: pre_nat, pr1hSet (nNat_as_set α). Definition Nat_isaset: isaset Nat. Proof. apply (isaset_total2_hSet pre_nat_as_set). Defined. Definition Nat_as_set: HSET := make_hSet _ Nat_isaset. Definition Z: Nat. Proof. use tpair. - exact (λ X f x, x). - cbn; red. intros; assumption. Defined. Definition S: HSET ⟦Nat_as_set,Nat_as_set⟧. Proof. cbn. intro n. use tpair. - exact (λ X h x, h (pr1 n X h x)). - cbn; red. intros ? ? ? ? ? ? ? H1 H2. induction n as [n1 n2]. cbn in n2; red in n2. cbn. eapply pathscomp0. 2: { apply maponpaths. apply (n2 X Y x y h k f); assumption. } apply (toforallpaths _ _ _ H2). Defined. Definition Nat_rec {C: HSET} (h: pr1hSet C -> pr1hSet C) (x: pr1hSet C)(n: Nat) : pr1hSet C := pr1 n C h x. Lemma Nat_β {C: HSET} (h: pr1hSet C -> pr1hSet C) (x: pr1hSet C): Nat_rec h x Z = x. Proof. apply idpath. Defined. Lemma Nat_β' {C: HSET} (h: pr1hSet C -> pr1hSet C) (x: pr1hSet C) (n: Nat): Nat_rec h x (S n) = h (Nat_rec h x n). Proof. apply idpath. Defined. Lemma Nat_weak_eta (n: Nat) : Nat_rec (C := Nat_as_set) S Z n = n. Proof. induction n as [n0 H]. use total2_paths_f. - cbn. unfold pre_nat in n0. apply funextsec; intro X. apply funextfun; intro h. apply funextfun; intro x. cbn in H; red in H. apply (H Nat_as_set X Z x S h (fun n => pr1 n X h x)); apply idpath. - cbn. cbn in H; red in H. do 7 (apply funextsec; intro). do 2 (apply funextfun; intro). apply setproperty. Defined. Lemma Nat_η {C: HSET} (h: pr1hSet C -> pr1hSet C) (x: pr1hSet C) (f: Nat → pr1hSet C) (p : f Z = x) (q: funcomp S f = funcomp f h): f = Nat_rec h x. Proof. apply funextfun. intro n. eapply pathscomp0. - apply maponpaths. apply pathsinv0. apply Nat_weak_eta. - unfold Nat_rec. induction n as [n0 H]. cbn in H; red in H. cbn. apply H; assumption. Defined. (* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L289 onwards: /- Natural numbers -/ -- System F encoding definition preNat : USet := tΠ X : USet, (X ⇒ X) ⇒ X ⇒ X -- naturality condition definition nNat (α : preNat) : UPrp := tΠ (X Y : USet) (x : X) (y : Y) (h : X → X) (k : Y → Y) (f : X → Y), f x = y ⇒ f ∘ h = k ∘ f ⇒ f (α X h x) == α Y k y -- refined encoding definition Nat : USet := σ(α : preNat), nNat α -- constructors definition Z : Nat := ⟨λ X f x, x, λ X Y x y h k f u v, u⟩ definition S (n : Nat) : Nat := begin fconstructor, λ X h x, h (n.1 X h x), intros X Y x y h k f u v, refine (ap (λ f, f (n.1 X h x)) v) ⬝ _, apply ap k, apply n.2, exact u, assumption end -- recursor definition Nat_rec {X : USet} (h : X → X) (x : X) (n : Nat) : X := n.1 X h x -- β rules definition Nat_β {X : USet} (h : X → X) (x : X) : Nat_rec h x Z = x := rfl definition Nat_β' {X : USet} (h : X → X) (x : X) (n : Nat) : Nat_rec h x (S n) = h (Nat_rec h x n) := rfl -- η rules definition Nat_weak_η (n : Nat) : Nat_rec S Z n = n := begin induction n with n p, fapply sigma_eq, apply eq_of_homotopy3, intro X h x, apply p Nat X Z x S h (Nat_rec h x), reflexivity, apply eq_of_homotopy, intro, reflexivity, apply is_prop.elimo end definition Nat_η {X:USet} (h:X→X) (x:X) (f:Nat→X) (p : f Z = x) (q:f∘S=h∘ f) : f = Nat_rec h x := begin fapply eq_of_homotopy, intro n, refine (ap f (Nat_weak_η n))⁻¹ ⬝ _, unfold Nat_rec, induction n with m k, apply k, assumption, assumption end *) End NaturalNumbers. (* preparation for the general case: Variable F: HSET ⟦A, A⟧. *) UniMath-20231010/UniMath/Induction/M/000077500000000000000000000000001451125700300170045ustar00rootroot00000000000000UniMath-20231010/UniMath/Induction/M/Chains.v000066400000000000000000000351331451125700300204050ustar00rootroot00000000000000(** * Limits of chains and cochains in the precategory of types *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.MoreFoundations.WeakEquivalences. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.CategoryTheory.categories.Type.Limits. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Cochains. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.Induction.FunctorCoalgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.M.Limits. Require Import UniMath.Induction.M.Core. (** The shifted chain (X', π') from (X, π) is one where Xₙ' = Xₙ₊₁ and πₙ' = πₙ₊₁. *) Definition shift_chain (cha : chain type_precat) : chain type_precat. Proof. use tpair. - exact (dob cha ∘ S). - exact (λ _ _ path, dmor cha (maponpaths S path)). Defined. (** The shifted cochain (X', π') from (X, π) is one where Xₙ' = Xₙ₊₁ and πₙ' = πₙ₊₁. *) Definition shift_cochain {C : precategory} (cochn : cochain C) : cochain C. Proof. use cochain_weq; use tpair. - exact (dob cochn ∘ S). - intros n; cbn. apply (dmor cochn). exact (idpath _). Defined. (** Interaction between transporting over (maponpaths S ed) and shifting the cochain *) Definition transport_shift_cochain : ∏ cochn ver1 ver2 (ed : ver1 = ver2) (stdlim_shift : standard_limit (shift_cochain cochn)), transportf (dob cochn) (maponpaths S ed) (pr1 stdlim_shift ver1) = transportf (dob (shift_cochain cochn)) ed (pr1 stdlim_shift ver1). Proof. intros cochn ver1 ver2 ed stdlim_shift. induction ed. reflexivity. Defined. (** Ways to prove that [dmor]s are equal on cochains *) Lemma cochain_dmor_paths {C : precategory} {ver1 ver2 : vertex conat_graph} (cochn : cochain C) (p1 p2 : edge ver1 ver2) : dmor cochn p1 = dmor cochn p2. Proof. apply maponpaths, proofirrelevance, isasetnat. Defined. (** More ways to prove that [dmor]s are equal on cochains *) Lemma cochain_dmor_paths_type {ver1 ver2 ver3 : vertex conat_graph} (cochn : cochain type_precat) (p1 : edge ver1 ver3) (p2 : edge ver2 ver3) (q1 : ver1 = ver2) : ∏ v1 : dob cochn ver1, dmor cochn p1 v1 = dmor cochn p2 (transportf _ q1 v1). Proof. intro v1; cbn in *. induction q1. cbn. exact (toforallpaths _ _ _ (cochain_dmor_paths cochn p1 p2) v1). Defined. (** We use the following tactic notations to mirror the "equational style" of reasoning used in Ahrens, Capriotti, and Spadotti. *) Local Tactic Notation "≃" constr(H) "by" tactic(t) := intermediate_weq H; [t|]. Local Tactic Notation "≃'" constr(H) "by" tactic(t) := intermediate_weq H; [|t]. Local Tactic Notation "≃" constr(H) := intermediate_weq H. Local Tactic Notation "≃'" constr(H) := apply invweq; intermediate_weq H. Local Lemma combine_over_nat_basic {X Y Z : nat → UU} : X 0 ≃ Z 0 → (∏ n : nat, Y (S n) ≃ Z (S n)) → (X 0 × ∏ n : nat, Y (S n)) ≃ ∏ n : nat, Z n. Proof. intros x0z0 yszs. ≃ (Z 0 × (∏ n : nat, Z (S n))). - apply weqdirprodf; [apply x0z0|]. apply weqonsecfibers, yszs. - use weq_iso. + intros z0zs. intros n; induction n. * exact (dirprod_pr1 z0zs). * apply (dirprod_pr2 z0zs). + intros xs; use make_dirprod. * apply xs. * exact (xs ∘ S). + reflexivity. + intros xs. apply funextsec; intros n. induction n; reflexivity. Defined. Local Lemma combine_over_nat {X : nat → UU} {P : (X 0 × (∏ n : nat, X (S n))) → UU} : (∑ x0 : X 0, ∑ xs : ∏ n : nat, X (S n), P (make_dirprod x0 xs)) ≃ (∑ xs : ∏ n : nat, X n, P (make_dirprod (xs 0) (xs ∘ S))). Proof. ≃ (∑ pair : (X 0 × ∏ n : nat, X (S n)), P pair) by apply weqtotal2asstol. use weqbandf. - apply (@combine_over_nat_basic X X X); intros; apply idweq. - intros x0xs; cbn. apply idweq. Defined. Local Lemma combine_over_nat' {X : nat → UU} {P : X 0 → (∏ n : nat, X (S n)) → UU} : (∑ x0 : X 0, ∑ xs : ∏ n : nat, X (S n), P x0 xs) ≃ (∑ xs : ∏ n : nat, X n, P (xs 0) (xs ∘ S)). Proof. ≃ (∑ (x0 : X 0) (xs : ∏ n : nat, X (S n)), (uncurry (Z := λ _, UU) P) (make_dirprod x0 xs)) by apply idweq. ≃' (∑ xs : ∏ n : nat, X n, uncurry P (Z := λ _, UU) (make_dirprod (xs 0) (xs ∘ S))) by apply idweq. apply combine_over_nat. Defined. (** If the base type is contractible, so is the type of sections over it. *) Definition weqsecovercontr_uncurried {X : UU} {Y : X -> UU} (P : ∏ x : X, Y x -> UU) (isc : iscontr (∑ x : X, Y x)) : (∏ (x : X) (y : Y x), P x y) ≃ (P (pr1 (iscontrpr1 isc)) (pr2 (iscontrpr1 isc))). Proof. ≃ (∏ pair : (∑ x : X, Y x), uncurry (Z := λ _, UU) P pair) by apply invweq, weqsecovertotal2. ≃' (uncurry (Z := λ _, UU) P (iscontrpr1 isc)) by (apply idweq). apply weqsecovercontr. Defined. (** Shifted cochains have equivalent limits. (Lemma 12 in Ahrens, Capriotti, and Spadotti) *) Definition shifted_limit (cocha : cochain type_precat) : standard_limit (shift_cochain cocha) ≃ standard_limit cocha. Proof. pose (X := dob cocha); cbn in X. pose (π n := (@dmor _ _ cocha (S n) n (idpath _))). unfold standard_limit, shift_cochain; cbn. assert (isc : ∏ x : ∏ v : nat, dob cocha (S v), iscontr (∑ x0 : X 0, (π 0 (x 0)) = x0)). { intros x. apply iscontr_paths_from. } (** Step (2) *) (** This is the direct product with the type proven contractible above *) ≃ (∑ xs : ∏ v : nat, X (S v), (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v))))) (xs u) = xs v) × (∑ x0 : X 0, (π 0 (xs 0)) = x0)) by (apply weqfibtototal; intro; apply dirprod_with_contr_r; apply isc). (** Now, we swap the components in the direct product. *) ≃ (∑ xs : ∏ v : nat, X (S v), (∑ x0 : X 0, π 0 (xs 0) = x0) × (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v))))) (xs u) = xs v)) by (apply weqfibtototal; intro; apply weqdirprodcomm). (** Using associativity of Σ-types, *) ≃ (∑ xs : ∏ v : nat, X (S v), ∑ x0 : X 0, (π 0 (xs 0) = x0) × (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v))))) (xs u) = xs v)) by (apply weqfibtototal; intro; apply weqtotal2asstor). (** And again by commutativity of ×, we swap the first components *) ≃ (∑ x0 : X 0, ∑ xs : ∏ n : nat, X (S n), (π 0 (xs 0) = x0) × (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v))))) (xs u) = xs v)) by (apply weqtotal2comm). (** Step 3: combine the first bits *) ≃ (∑ xs : ∏ n : nat, X n, (π 0 (xs 1) = xs 0) × (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S v))) e (idfun (dob cocha (S (S v))))) (xs (S u)) = xs (S v))). apply (@combine_over_nat' X (λ x0 xs, π 0 (xs 0) = x0 × (∏ (u v : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, X (S o) → X (S (S v))) e (idfun (X (S (S v))))) (xs u) = xs v))). (** Now the first component is the same. *) apply weqfibtototal; intros xs. ≃ (π 0 (xs 1) = xs 0 × (∏ (v u : nat) (e : S v = u), (dmor cocha (idpath (S (S v))) ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S v))) e (idfun (dob cocha (S (S v))))) (xs (S u)) = xs (S v))) by apply weqdirprodf; [apply idweq|apply flipsec_weq]. ≃' (∏ (v u : nat) (e : S v = u), dmor cocha e (xs u) = xs v) by apply flipsec_weq. (** Split into cases on n = 0 or n > 0. *) (** Coq is bad about coming up with these implicit arguments, so we have to be very excplicit. *) apply (@combine_over_nat_basic (λ n, π n (xs (S n)) = xs n) (λ v, ∏ (u : nat) (e : v = u), (dmor cocha (idpath (S v)) ∘ _ (idfun (dob cocha (S v)))) (xs (S u)) = xs v) (λ v, ∏ (u : nat) (e : S v = u), dmor cocha e (xs u) = xs v)). (** We use the following fact over and over to simplify the remaining types: for any x : X, the type ∑ y : X, x = y is contractible. *) - apply invweq. apply (@weqsecovercontr_uncurried nat (λ n, 1 = n) (λ _ _, _ = xs 0) (iscontr_paths_from 1)). - intros u. ≃ ((dmor cocha (idpath (S (S u))) ∘ transportf (λ o : nat, dob cocha (S o) → dob cocha (S (S u))) (idpath (S u)) (idfun (dob cocha (S (S u))))) (xs (S (S u))) = xs (S u)). + apply (@weqsecovercontr_uncurried nat (λ n, (S u) = n) (λ _ _, _ _ = xs (S u)) (iscontr_paths_from _)). + cbn. apply invweq. apply (@weqsecovercontr_uncurried nat (λ n, (S (S u)) = n) (λ _ _, _ = xs (S u)) (iscontr_paths_from _)). Defined. (** Lemma 11 in Ahrens, Capriotti, and Spadotti *) Local Definition Z X l := ∑ (x : ∏ n, X n), ∏ n, x (S n) = l n (x n). Local Lemma lemma_11 (X : nat -> UU) (l : ∏ n, X n -> X (S n)) : Z X l ≃ X 0. Proof. set (f (xp : Z X l) := pr1 xp 0). transparent assert (g : (X 0 -> Z X l)). { intros x. exists (nat_rect _ x l). exact (λ n, idpath _). } apply (make_weq f). apply (isweq_iso f g). - cbn. intros xp; induction xp as [x p]. transparent assert ( q : (nat_rect X (x 0) l ~ x )). { intros n; induction n; cbn. * reflexivity. * exact (maponpaths (l n) IHn @ !p n). } set (q' := funextsec _ _ _ q). use total2_paths_f; cbn. + exact q'. + rewrite transportf_sec_constant. apply funextsec; intros n. intermediate_path (!maponpaths (λ x, x (S n)) q' @ maponpaths (λ x, l n (x n)) q'). { use transportf_paths_FlFr. } intermediate_path (!maponpaths (λ x, x (S n)) q' @ maponpaths (l n) (maponpaths (λ x, x n) q')). { apply maponpaths. symmetry. use maponpathscomp. } intermediate_path (! q (S n) @ maponpaths (l n) (q n)). { unfold q'. repeat rewrite maponpaths_funextsec. reflexivity. } intermediate_path (! (maponpaths (l n) (q n) @ ! p n) @ maponpaths (l n) (q n)). { reflexivity. } rewrite pathscomp_inv. rewrite <- path_assoc. rewrite pathsinv0l. rewrite pathsinv0inv0. rewrite pathscomp0rid. reflexivity. - cbn. reflexivity. Defined. (* Maybe easier to apply in Lemma *) Local Definition lemma_11_unfolded (X : nat -> UU) (l : ∏ n, X n -> X (S n)) : (∑ (x : ∏ n, X n), ∏ n, x (S n) = l n (x n)) ≃ X 0 := lemma_11 X l. Lemma cochain_limit_standard_limit_weq (cha cha' : cochain type_precat) : cochain_limit cha ≃ cochain_limit cha' → standard_limit cha ≃ standard_limit cha'. Proof. intro f. apply (weqcomp (invweq (lim_equiv _))). apply (weqcomp f). apply (lim_equiv _). Defined. (* There is a simpler way to give cones over the terminal cochain. *) Local Open Scope cat. Section CochainCone. Context (A C : UU) (B : A -> UU). Definition terminal_cochain : cochain type_precat := termCochain (TerminalType) (polynomial_functor A B). Definition m_type := standard_limit terminal_cochain. Definition apply_on_chain (cha : cochain type_precat) : cochain type_precat := mapcochain (polynomial_functor A B) cha. (* Shifting the terminal cochain is equivalent to applying the polynomial functor once *) Definition terminal_cochain_shifted_lim : standard_limit (shift_cochain terminal_cochain) ≃ standard_limit (apply_on_chain terminal_cochain). Proof. apply cochain_limit_standard_limit_weq. unfold shift_cochain, apply_on_chain, cochain_limit. apply weqfibtototal;intros. apply weqonsecfibers; intro n. apply idweq. Defined. Let W n := iter_functor (polynomial_functor A B) n unit. Let Cone0' := λ n : nat, C → W n. Let Cone0 := ∏ n : nat, Cone0' n. Let π := λ n : nat, dmor terminal_cochain (idpath (S n)). Definition simplified_cone : UU := (∑ (u : Cone0), ∏ n : nat, (π n ∘ u (S n))%functions = u n). Lemma simplify_cochain_cone : cone terminal_cochain C ≃ simplified_cone. Proof. unfold cone, Cone0. apply weqfibtototal; intro f. intermediate_weq ( (∏ (u v : vertex conat_graph) (e0 : edge u v), f _ · dmor terminal_cochain e0 ~ f v) ). { do 3 (apply weqonsecfibers; intro). apply invweq. apply weqfunextsec. } apply invweq. intermediate_weq (∏ u, (π u ∘ f (S u))%functions ~ f u). { apply invweq. apply weqonsecfibers; intro. apply weqfunextsec. } unfold homotsec. apply invweq. intermediate_weq ( (∏ (u v : vertex conat_graph) (c : C) (e0 : edge u v), (f u · dmor terminal_cochain e0) c = f v c)). { do 2 (apply weqonsecfibers; intro). apply flipsec_weq. } intermediate_weq ( (∏ (c : C) (u v : vertex conat_graph) (e0 : edge u v), (f u · dmor terminal_cochain e0) c = f v c)). { intermediate_weq ( (∏ (u : vertex conat_graph) (c : C) (v : vertex conat_graph) (e0 : edge u v), (f u · dmor terminal_cochain e0) c = f v c)). { apply weqonsecfibers; intro. apply flipsec_weq. } apply flipsec_weq. } apply invweq. intermediate_weq ((∏ (x : C) (u : nat), (π u ∘ f (S u))%functions x = f u x)); [apply flipsec_weq|]. apply weqonsecfibers; intro c. apply invweq. use weq_iso. - intros eq; intro; apply eq. - intros eq. intros ? ? e. induction e; apply eq. - abstract ( intro; do 2 (apply funextsec; intro); apply funextsec; intro e; induction e; reflexivity ). - abstract ( intro; apply funextsec; intro; reflexivity ). Defined. End CochainCone. UniMath-20231010/UniMath/Induction/M/ComputationalM.v000066400000000000000000000240171451125700300221330ustar00rootroot00000000000000(** ** Refinement of M-types M-types can be refined to satisfy the right definitional equalities. This idea is from Felix Rech's Bachelor's thesis, and Felix Rech also developed together with Luis Scoccola a first formalization in UniMath as project work of the UniMath 2017 school. The present formalization was obtained as project work of the UniMath 2019 school and is heavily inspired by that former formalization. Author: Dominik Kirst (@dominik-kirst) and Ralph Matthes (@rmatthes) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Induction.FunctorCoalgebras_legacy. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.M.Core. Require Import UniMath.Induction.M.Uniqueness. (** The construction is called a refinement: as input we take any final coalgebra for the respective polynomial functor describing an M-type (hence, with the provable coiteration rule), the output is the refined final coalgebra with the equational rule of coiteration holding definitionally: Lemma [corec_computation] is proved merely by [idpath]. Of course, both coalgebras are equal - provably (Lemma [coalgebras_eq]). *) Section Refinement. Context (A : UU). Context (B : A → UU). Local Notation F := (polynomial_functor A B). Variable M0 : coalgebra F. Local Notation carrierM0 := (coalgebra_ob _ M0). Local Notation destrM0 := (coalgebra_mor _ M0). Variable finalM0 : is_final M0. Local Notation corecM0 C := (pr11 (finalM0 C)). Local Open Scope cat. Local Open Scope functions. (* Refinement of the final coalgebra to computable elements *) Definition carrierM := ∑ m0 : carrierM0, ∃ C c, corecM0 C c = m0. (* Definition of the corecursor *) Definition corecM (C : coalgebra F) (c : coalgebra_ob _ C) : carrierM. Proof. exists (corecM0 C c). apply hinhpr. exists C, c. apply idpath. Defined. (* Definition of a proposition we factor the computation through *) Local Definition P (m0 : carrierM0) := ∑ af : F carrierM, destrM0 m0 = # F pr1 af. (** in order to show [P] to be a proposition, a not obviously equivalent formulation is given for which it is easy to show [isaprop] *) Local Definition P' (m0 : carrierM0) := ∑ ap : ∑ a : A, pr1 (destrM0 m0) = a, ∏ (b : B (pr1 ap)), ∑ mp : ∑ m0' : carrierM0, transportf (λ a, B a -> carrierM0) (pr2 ap) (pr2 (destrM0 m0)) b = m0', ∃ C c, corecM0 C c = pr1 mp. (** the easy auxiliary lemma *) Local Lemma P'_isaprop m0 : isaprop (P' m0). Proof. apply isofhleveltotal2. - apply isofhlevelcontr. apply iscontrcoconusfromt. - intro ap; induction ap as [a p]. apply impred; intros b. apply isofhleveltotal2. + apply isofhlevelcontr. apply iscontrcoconusfromt. + intro mp; induction mp as [m0' q]. apply isapropishinh. Defined. (** the crucial lemma *) Local Lemma P_isaprop (m0 : carrierM0) : isaprop (P m0). Proof. use (@isofhlevelweqb _ _ (P' m0) _ (P'_isaprop m0)). simple refine (weqcomp (weqtotal2asstor _ _) _). simple refine (weqcomp _ (invweq (weqtotal2asstor _ _))). apply weqfibtototal; intro a. intermediate_weq ( ∑ f : B a → carrierM, ∑ p : pr1 (destrM0 m0) = a, transportf (λ a, B a -> carrierM0) p (pr2 (destrM0 m0)) = pr1 ∘ f). { apply weqfibtototal; intro f. apply total2_paths_equiv. } intermediate_weq (∑ p : pr1 (destrM0 m0) = a, ∑ f : B a → carrierM, transportf (λ a, B a → carrierM0) p (pr2 (destrM0 m0)) = pr1 ∘ f). { apply weqtotal2comm. } apply weqfibtototal; intro p. intermediate_weq (∑ fg : ∑ f : B a -> carrierM0, ∏ b, ∃ C c, corecM0 C c = f b, transportf (λ a, B a -> carrierM0) p (pr2 (destrM0 m0)) = pr1 fg). { use weqbandf. - apply weqfuntototaltototal. - cbn. intro f. apply idweq. } intermediate_weq (∑ f : B a → carrierM0, ∑ _ : ∏ b, ∃ C c, corecM0 C c = f b, transportf (λ a, B a → carrierM0) p (pr2 (destrM0 m0)) = f). { apply weqtotal2asstor. } intermediate_weq (∑ f : B a → carrierM0, ∑ _ : ∏ b, ∃ C c, corecM0 C c = f b, ∏ b, transportf (λ a, B a → carrierM0) p (pr2 (destrM0 m0)) b = f b). { apply weqfibtototal; intro f. apply weqfibtototal; intros _. apply weqtoforallpaths. } intermediate_weq (∑ f : B a → carrierM0, ∏ b, ∑ _ : ∃ C c, corecM0 C c = f b, transportf (λ a, B a → carrierM0) p (pr2 (destrM0 m0)) b = f b). { apply weqfibtototal; intro f. apply invweq. apply weqforalltototal. } intermediate_weq (∏ b, ∑ m0' : carrierM0, ∑ _ : ∃ C c, corecM0 C c = m0', transportf (λ a, B a -> carrierM0) p (pr2 (destrM0 m0)) b = m0'). { apply invweq. apply weqforalltototal. } apply weqonsecfibers; intro b. intermediate_weq (∑ m0' : carrierM0, ∑ _ : transportf (λ a, B a -> carrierM0) p (pr2 (destrM0 m0)) b = m0', ∃ C c, corecM0 C c = m0'). { apply weqfibtototal; intro m0'. apply weqdirprodcomm. } intermediate_weq (∑ mp : ∑ m0', transportf (λ a, B a → carrierM0) p (pr2 (destrM0 m0)) b = m0', ∃ C c, corecM0 C c = pr1 mp). { apply invweq. apply weqtotal2asstor. } use weqbandf. - apply weqfibtototal; intro m0'. apply idweq. - cbn. intro mp. apply idweq. Defined. (* Now the destructor of M can be defined *) Local Definition destrM' (m : carrierM) : P (pr1 m). Proof. induction m as [m0 H]. apply (squash_to_prop H); try apply P_isaprop. intros [C [c H1]]. refine ((# F (corecM C) ∘ (pr2 C)) c,, _). cbn [pr1]. clear H. assert (H : is_coalgebra_homo F (corecM0 C)). { destruct finalM0 as [[G H] H']. apply H. } apply toforallpaths in H. apply pathsinv0. intermediate_path (destrM0 (corecM0 C c)). - apply H. - apply maponpaths. assumption. Defined. Definition destrM (m : carrierM) : F carrierM := pr1 (destrM' m). Definition M : coalgebra F := (carrierM,, destrM). (* The destructor satisfies the corecursion equation definitionally *) Lemma corec_computation C c : destrM (corecM C c) = # F (corecM C) (pr2 C c). Proof. apply idpath. Defined. (* The two carriers are equal *) Lemma eq_corecM0 m0 : corecM0 M0 m0 = m0. Proof. induction finalM0 as [[G H1] H2]. cbn. specialize (H2 (coalgebra_homo_id F M0)). change (pr1 (G,, H1) m0 = pr1 (coalgebra_homo_id F M0) m0). apply (maponpaths (fun X => pr1 X m0)). apply pathsinv0. assumption. Defined. Definition injectM0 m0 : ∃ C c, corecM0 C c = m0. Proof. apply hinhpr. exists M0, m0. apply eq_corecM0. Defined. Lemma carriers_weq : carrierM ≃ carrierM0. Proof. apply (weq_iso pr1 (λ m0, m0,, injectM0 m0)). - intros [m H]. cbn. apply maponpaths, ishinh_irrel. - intros x. cbn. apply idpath. Defined. Lemma carriers_eq : carrierM = carrierM0. Proof. apply weqtopaths, carriers_weq. Defined. (** needs to be transparent *) (* The two coalgebras are equal *) Local Lemma eq1 (m0 : carrierM0) : transportf (λ X, X → F X) carriers_eq destrM m0 = transportf (λ X, F X) carriers_eq (destrM (transportf (λ X, X) (!carriers_eq) m0)). Proof. destruct carriers_eq. apply idpath. Defined. Local Lemma eq2 (m0 : carrierM0) : transportf (λ X, X) (!carriers_eq) m0 = m0,, injectM0 m0. Proof. apply (transportf_pathsinv0' (idfun UU) carriers_eq). unfold carriers_eq. rewrite weqpath_transport. apply idpath. Defined. Local Lemma eq3 m0 : destrM (m0,, injectM0 m0) = pr1 (destrM0 m0),, corecM M0 ∘ pr2 (destrM0 m0). Proof. apply idpath. Defined. Lemma coalgebras_eq : M = M0. Proof. use total2_paths_f; try apply carriers_eq. apply funextfun. intro m0. rewrite eq1. rewrite eq2. rewrite eq3. cbn. unfold polynomial_functor_obj. rewrite transportf_total2_const. use total2_paths_f; try apply idpath. cbn. apply funextsec. intros b. rewrite <- helper_A. unfold carriers_eq. rewrite weqpath_transport. cbn. rewrite eq_corecM0. apply idpath. Defined. (* Thus M is final *) Lemma finalM : is_final M. Proof. rewrite coalgebras_eq. apply finalM0. Defined. End Refinement. UniMath-20231010/UniMath/Induction/M/Core.v000066400000000000000000000034011451125700300200610ustar00rootroot00000000000000(** ** M-types The M-type associated to (A, B) is the final coalgebra of the associated polynomial functor. We can't use (1) the definition of [Terminal], because we can't use (2) that (co)algebras and their morphisms form a precategory, because this is only true when the base category has homsets, which [UU] doesn't. Therefore, we must redefine what it means to be a final coalgebra here without categorical language. (Definition 4 in Ahrens, Capriotti, and Spadotti) (IsFinal in HoTT/M-types) Author: Langston Barrett (@siddharthist) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Induction.FunctorCoalgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. Section M. Context {A : UU} (B : A → UU). Local Notation F := (polynomial_functor A B). (* can be coerced to a function *) Definition is_prefinal (X : coalgebra F) := ∏ (Y : coalgebra F), coalgebra_homo F Y X. Definition is_final (X : coalgebra F) := ∏ (Y : coalgebra F), iscontr (coalgebra_homo F Y X). (** prop-IsFinal in HoTT/M-types *) Definition isaprop_is_final (X : coalgebra F) : isaprop (is_final X). Proof. apply impred. intro. apply isapropiscontr. Defined. Lemma is_prefinal_to_is_final (X : coalgebra F) : is_prefinal X -> (∏ Y, isaprop (coalgebra_homo F Y X)) -> is_final X. Proof. exact (λ is_pre is_prop Y, iscontraprop1 (is_prop Y) (is_pre Y)). Defined. Definition M := ∑ (X : coalgebra F), is_final X. Definition M_coalgebra : M → coalgebra F := pr1. Definition M_is_final : ∏ (m : M), is_final (pr1 m) := pr2. Coercion M_coalgebra : M >-> coalgebra. End M. Arguments isaprop_is_final {_ _} _. Arguments is_prefinal {_ _} _. Arguments is_final {_ _} _. UniMath-20231010/UniMath/Induction/M/Limits.v000066400000000000000000000161351451125700300204420ustar00rootroot00000000000000(** * Limits in the precategory of types This is a partial reconstruction of the results of "Homotopy limits in type theory" by Jeremy Avigad, Chris Kapulkin, and Peter LeFanu Lumsdaine (arXiv:1304.0680v3). *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.Cochains. Local Open Scope cat. Section StandardLimits. Context {g : graph} (d : diagram g type_precat). Definition standard_limit : UU := ∑ (x : ∏ (v : vertex g), dob d v), ∏ (u v : vertex g) (e : edge u v), dmor d e (x u) = x v. (** The condition that [standard_limit] is a cone is basically a rephrasing of its definition. *) Lemma type_cone : cone d standard_limit. use make_cone; cbn. - exact (λ n l, pr1 l n). - intros u v f. apply funextsec; intro l; cbn. apply (pr2 l). Defined. End StandardLimits. Section StandardLimitHomot. Context {g : graph} {d : diagram g type_precat} (x y : standard_limit d). (** A homotopy of cones *) Definition standard_limit_homot : UU := ∑ h : pr1 x ~ pr1 y, ∏ (u v : vertex g) (ed : edge u v), (maponpaths (dmor d ed) (h u) @ (pr2 y _ _) ed = pr2 x _ _ ed @ (h v)). (** Such homotopies can be made into paths *) Lemma type_cone_homot_to_path (h : standard_limit_homot) : x = y. Proof. apply (total2_paths_f (funextsec _ _ _ (pr1 h))). (** transport_lemma in peterlefanulumsdaine/hott-limits/Limits1.v. *) assert (transport_lemma : ∏ p : pr1 x = pr1 y, transportf _ p (pr2 x) = λ u v (ed : edge u v), maponpaths (dmor d ed) (!(toforallpaths _ _ _ p u)) @ pr2 x _ _ ed @ toforallpaths _ _ _ p v). { intros p; induction p; cbn. do 3 (apply funextsec; intro). exact (!(pathscomp0rid _)). } refine (transport_lemma _ @ _). apply funextsec; intro u; apply funextsec; intro v; apply funextsec; intro ed. rewrite toforallpaths_funextsec. change (pr2 y u v ed) with (idpath _ @ (pr2 y u v ed)). refine (_ @ maponpaths (λ p, p @ _) (pathsinv0l (maponpaths _ (pr1 h u)))). refine (_ @ (path_assoc (! maponpaths _ _) (maponpaths _ _) _)). rewrite maponpathsinv0. apply maponpaths, pathsinv0. exact (pr2 h u v ed). Defined. End StandardLimitHomot. (** The canonical cone given by an arrow X → Y where Y has a cone *) Definition into_cone_to_cone {X Y : UU} {g : graph} {d : diagram g _} (coneY : cone d (Y : ob type_precat)) (f : X → Y) : cone d X. use make_cone. - intro ver. exact (pr1 coneY ver ∘ (f : type_precat ⟦ X, Y ⟧)). - intros ver1 ver2 ed; cbn. apply funextsec; intro x. apply (toforallpaths _ _ _ (pr2 coneY ver1 ver2 ed)). Defined. Section StandardLimitUP. Context {g : graph} {d : diagram g type_precat}. (** A rephrasing of the universal property: the canonical map that makes a cone out of a map X → L is an equivalence. *) Definition is_limit_cone {L} (C : cone d L) := ∏ (X : UU), isweq (@into_cone_to_cone X L g d C). Lemma isaprop_isLimCone {L} (C : cone d L) : isaprop (is_limit_cone C). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. (** A weak equivalence expressing the above universal property. *) Definition limit_up_weq {X L} {C : cone d L} {is : is_limit_cone C} : (X → L) ≃ cone d X := make_weq (into_cone_to_cone C) (is X). (** The universal property of a limit. - Proposition 4.2.8 (limit_universal) in Avigad, Kapulkin, and Lumsdaine - Generalizes Lemma 10 in Ahrens, Capriotti, and Spadotti - Generalizes univ-iso in HoTT/M-types *) Lemma limit_universal : is_limit_cone (type_cone d). intro X. use isweq_iso. - intros xcone x. unfold standard_limit. use tpair. + exact (λ ver, pr1 xcone ver x). + intros ver1 ver2 ed. apply (toforallpaths _ _ _ (pr2 xcone _ _ _)). - intros f. apply funextfun; intro xcone. use total2_paths_f; cbn; [reflexivity|]. cbn. apply funextsec; intro ver1. apply funextsec; intro ver2. apply funextsec; intro ed. do 2 (rewrite toforallpaths_funextsec). reflexivity. - intro conex. unfold into_cone_to_cone; cbn. use total2_paths_f; cbn. + reflexivity. + apply funextsec; intro ver1. apply funextsec; intro ver2. apply funextsec; intro ed. cbn. rewrite toforallpaths_funextsec; cbn. rewrite funextsec_toforallpaths. reflexivity. Defined. (** The above weak equivalence specialized to the case of [standard_limit]s *) Definition standard_limit_up_weq {X} : (X → standard_limit d) ≃ cone d X := make_weq (into_cone_to_cone (type_cone d)) (limit_universal X). End StandardLimitUP. (** In the case of cochains, we can provide a somewhat simpler limit. *) Section CochainLimit. Context (coch : cochain type_precat). Let X := (pr1 coch). Let π := (pr2 coch). Let π' n := π (S n) n (idpath _). Definition cochain_limit := ∑ (x : forall n : nat, X n), forall n, π' n (x (S n)) = x n. Lemma simplify_cochain_step {u v : nat} (x : forall n, X n) (e : S v = u) : dmor coch e (x u) = π' v (x (S v)). Proof. unfold π', π in *; unfold dmor. (induction e; auto). Defined. Lemma simplify_cochain_step_idpath {u : nat} (x : forall n, X n) : @simplify_cochain_step (S u) u x (idpath _) = idpath _. Proof. reflexivity. Qed. Definition cochain_limit_cone : cone coch cochain_limit. Proof. use make_cone; cbn. - intros v cochain_limit_element. apply (pr1 cochain_limit_element). - intros u v e. apply funextsec; intro l; cbn. refine (_ @ pr2 l _). unfold dmor, π', π. apply simplify_cochain_step. Defined. Lemma lim_equiv : cochain_limit ≃ (standard_limit coch). Proof. unfold cochain_limit, standard_limit; cbn. apply weqfibtototal; intro. use weq_iso. - intros eq. intros u v e. specialize (eq v). unfold π', π in *; unfold dmor. refine (_ @ eq). apply simplify_cochain_step. - intros eq; intro; apply eq. - abstract ( intro; apply funextsec; intro; reflexivity ). - abstract ( intro; cbn; do 2 (apply funextsec; intro); apply funextsec; intro p; induction p; reflexivity ). Defined. Lemma cochain_limit_is_limit : ∑ c : cone coch cochain_limit, is_limit_cone c. Proof. assert (H : (∑ c : cone coch cochain_limit, is_limit_cone c) ≃ ∑ c : cone coch (standard_limit coch), is_limit_cone c ). { induction (weqtopaths lim_equiv). apply idweq. } apply H. eapply tpair. apply limit_universal. Defined. End CochainLimit. UniMath-20231010/UniMath/Induction/M/Uniqueness.v000066400000000000000000000117461451125700300213430ustar00rootroot00000000000000(** ** Uniqueness of M-types M-types are unique up to propositional equality. Author: Langston Barrett (@siddharthist) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Induction.FunctorCoalgebras_legacy. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.M.Core. Section Uniqueness. Local Open Scope functions. Local Open Scope cat. Context (A : UU). Context (B : A → UU). (** Following the paper, we have [X ⇒ Y] = Hom(X, Y) *) Local Notation F := (polynomial_functor A B). (* can be coerced to a function *) Local Notation "F*" := (polynomial_functor_arr A B). Local Notation "X ⇒ Y" := (coalgebra_homo F X Y). (** Since we can't use the standard categorical proof, we must re-prove that final coalgebras are unique up to isomorphism. (Lemma 5 in Ahrens, Capriotti, and Spadotti) *) (** We prove that their carriers (first projections) are isomorphic, and hence equal (by univalence). This is standard categorical reasoning: each has exactly one arrow to the other, which, composing, gives an endormorphism. However, each has exactly one endomorphism, the identity map. Therefore, they are isomorphic. *) Lemma M_carriers_iso : ∏ X Y : M B, (coalgebra_ob _ X) ≃ (coalgebra_ob _ Y). Proof. intros X Y. (** Get the coalgebra morphisms X → Y and Y → X via finality *) pose (X_mor_Y := iscontrpr1 (pr2 Y X)). pose (Y_mor_X := iscontrpr1 (pr2 X Y)). apply (weq_iso (mor_from_coalgebra_homo _ _ _ X_mor_Y) (mor_from_coalgebra_homo _ _ _ Y_mor_X)). - intro x. apply (@eqtohomot _ _ (Y_mor_X ∘ X_mor_Y) (idfun _)). refine (base_paths (coalgebra_homo_comp _ _ _ _ X_mor_Y Y_mor_X) (coalgebra_homo_id F X) _). apply (proofirrelevancecontr (pr2 X X)). - intro y. apply (@eqtohomot _ _ (X_mor_Y ∘ Y_mor_X) (idfun _)). refine (base_paths (coalgebra_homo_comp _ _ _ _ Y_mor_X X_mor_Y) (coalgebra_homo_id F Y) _). apply (proofirrelevancecontr (pr2 Y Y)). Defined. (** Note the crucial use of univalence *) Lemma M_carriers_eq : ∏ X Y : M B, (coalgebra_ob _ X) = (coalgebra_ob _ Y). Proof. exact (fun X Y => weqtopaths (M_carriers_iso X Y)). Defined. (** Now we must prove that the coalgebra morphisms, when transported along the path M_carriers_eq, will be equal. (≅⇒≡ in HoTT/M-types) *) (* We use "refine (x @ _)" instead of "rewrite" for more predictable proof terms. *) Lemma M_coalg_eq : ∏ X Y : M B, M_coalgebra B X = M_coalgebra B Y. Proof. intros X Y. pose (π1eq := (M_carriers_eq X Y)). pose (f := pr1 ((pr2 Y) (M_coalgebra B X))). apply (total2_paths_f π1eq). (** Some shorthands for items we'll use *) pose (is_final_X := pr2 X). pose (is_final_Y := pr2 Y). pose (θ := pr2 (pr1 X)). pose (ψ := pr2 (pr1 Y)). (** substⁱ-lemma in HoTT/M-types *) assert (trans_fun : forall {X Y : UU} {F : UU → UU} {f : X → F X} {g : Y → F Y} (p : X = Y), (forall (x : X), transportf F p (f x) = g (transportf (idfun UU) p x)) → transportf (λ X, X → F X) p f = g). { intros ? ? ? ? ? p H. induction p. unfold transportf. apply funextfun. exact H. } apply trans_fun. intro x. (** imap-subst in HoTT/M-types *) assert (arr_transport : forall {X Y : UU} (p : X = Y), F* (transportf (idfun _) p) = transportf F p). { intros ? ? p. induction p. reflexivity. } (** In HoTT/M-types: lemma₁ : ∀ i x → subst (λ Z → Z i) π₁≡ x ≡ proj₁ f i x *) assert (lemma1 : forall x : pr1 (pr1 X), transportf (idfun UU) π1eq x = (pr1 f) x). { intro. refine (toforallpaths _ _ _ _ x0). refine ((weqpath_transport (M_carriers_iso _ Y)) @ _). reflexivity. } (** lemma₂ in HoTT/M-types *) assert (lemma2 : transportf F π1eq = F* (pr1 f)). { refine (!(arr_transport _ _ π1eq) @ _). apply maponpaths. unfold π1eq, M_carriers_eq. refine ((weqpath_transport (M_carriers_iso _ _)) @ _). reflexivity. } refine (_ @ !(maponpaths ψ (lemma1 x))). refine (toforallpaths _ (transportf F π1eq) (F* (pr1 f)) lemma2 (θ x) @ _). (** Now our goal is simply the condition that f is a coalgebra morphism *) apply (toforallpaths _ (F* (pr1 f) ∘ θ) (ψ ∘ pr1 f)). exact (pr2 f). Defined. Lemma isaprop_M : isaprop (M B). apply invproofirrelevance. intros X Y. apply subtypePath. - exact isaprop_is_final. - exact (M_coalg_eq X Y). Defined. End Uniqueness. UniMath-20231010/UniMath/Induction/PolynomialFunctors.v000066400000000000000000000047121451125700300226520ustar00rootroot00000000000000(** ** Polynomial functors Using the formalism of a polynomial functor, one can build any functor combining constant types, +, and ×, where the variable X is to the right of the arrow →. W-types are (up to isomorphism) initial algebras of polynomial functors, whereas M-types are final coalgebras. (Definition 2 in Ahrens, Capriotti, and Spadotti) Author: Langston Barrett (@siddharthist) *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Induction.FunctorAlgebras_legacy. Require Import UniMath.Induction.FunctorCoalgebras_legacy. Require Import UniMath.CategoryTheory.categories.Type.Core. Section PolynomialFunctors. Context (A : UU). Context (B : A → UU). Definition polynomial_functor_obj := fun (X : UU) => ∑ (a : A), B a → X. (** The action on arrows is defined by composition in the second projection. *) Definition polynomial_functor_arr {X Y : UU} (f : X → Y) : (polynomial_functor_obj X) → (polynomial_functor_obj Y) := fun o => (pr1 o,, (f ∘ pr2 o)%functions). (** Polynomial functors aren't functors in the usual sense, since UU is an (∞,1)-category. However, they are functors in the sense of UniMath's definition. *) Definition polynomial_functor_data : functor_data type_precat type_precat := functor_data_constr _ _ (polynomial_functor_obj : type_precat → type_precat) (@polynomial_functor_arr). Lemma polynomial_functor_is_functor : is_functor polynomial_functor_data. Proof. split. - intro. reflexivity. - intros ? ? ? ? ?. reflexivity. Defined. Definition polynomial_functor : functor type_precat type_precat := make_functor polynomial_functor_data polynomial_functor_is_functor. (** An algebra with an uncurried structure map *) Definition polynomial_alg_uncurried : UU := ∑ (X : ob type_precat), ∏ (a : A), (B a → X) → X. (** The uncurried and curried versions are equivalent *) Lemma polynomial_alg_uncurried_equiv : polynomial_alg_uncurried ≃ (algebra_ob polynomial_functor). Proof. apply (weq_iso (λ p, (pr1 p,, uncurry (pr2 p))) (λ p, (pr1 p,, curry (pr2 p)))); try reflexivity. Defined. End PolynomialFunctors. UniMath-20231010/UniMath/Induction/README.md000066400000000000000000000017051451125700300200720ustar00rootroot00000000000000# (Co)inductive types This directory contains some results about inductive and coinductive types. Since UniMath doesn't support general definitions with Coq's (co)inductive types, these types are instead studied in the form of W-types (resp. M-types), which are characterized as initial (resp. final) algebras (resp. coalgebras) for polynomial functors. The proofs of uniqueness for M- and W-types are based on results in ["Non-wellfounded trees in homotopy type theory"](https://arxiv.org/abs/1504.02949v1) and [the corresponding Agda formalization](https://github.com/HoTT/m-types) by Benedikt Ahrens, Paolo Capriotti, and Régis Spadotti. The definition of fibered algebras is based on ["Homotopy-initial algebras in type theory"](https://arxiv.org/abs/1504.05531v1) and [the corresponding Coq formalization](https://github.com/kristinas/hinitiality) by Steve Awodey, Nicola Gambino, Kristina Sojakova. Package written by Langston Barrett (@siddharthist). UniMath-20231010/UniMath/Induction/W/000077500000000000000000000000001451125700300170165ustar00rootroot00000000000000UniMath-20231010/UniMath/Induction/W/Core.v000066400000000000000000000032401451125700300200740ustar00rootroot00000000000000Require Import UniMath.Foundations.PartD. Require Import UniMath.Induction.FunctorAlgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. (** The W-type associated to (A, B) is the initial algebra of the associated polynomial functor. See the comment in Induction.M.Core as to why we can't use category-theoretic terminology. *) Section W. Context {A : UU} (B : A → UU). Local Notation F := (polynomial_functor A B). (** The "recursion principle": there exists a morphism into any other algebra. (The first two rules in Proposition 5.8 in Awodey, Gambino, and Sojakova) *) Definition is_preinitial (X : algebra_ob F) := ∏ (Y : algebra_ob F), algebra_mor F X Y. (** The "homotopy-initiality principle": there is exactly one morphism into any other algebra. (Definition 5.6 in Awodey, Gambino, and Sojakova) *) Definition is_initial (X : algebra_ob F) := ∏ (Y : algebra_ob F), iscontr (algebra_mor F X Y). Definition isaprop_is_initial (X : algebra_ob F) : isaprop (is_initial X). Proof. apply impred. intro. apply isapropiscontr. Defined. Lemma is_preinitial_to_is_initial (X : algebra_ob F) : is_preinitial X -> (∏ Y, isaprop (algebra_mor F X Y)) -> is_initial X. Proof. exact (λ is_pre is_prop Y, iscontraprop1 (is_prop Y) (is_pre Y)). Defined. Definition W := ∑ (X : algebra_ob F), is_initial X. Definition W_algebra : W → algebra_ob F := pr1. Definition W_is_initial : ∏ (w : W), is_initial (pr1 w) := pr2. Coercion W_algebra : W >-> algebra_ob. End W. Arguments isaprop_is_initial {_ _} _. Arguments is_preinitial {_ _} _. Arguments is_initial {_ _} _. UniMath-20231010/UniMath/Induction/W/Fibered.v000066400000000000000000000141051451125700300205460ustar00rootroot00000000000000(** ** Fibered algebras Described in "Homotopy-initial algebras in type theory" by Steve Awodey, Nicola Gambino, Kristina Sojakova (arXiv:1504.05531v1). Ideas and proofs adapted from original code at https://github.com/kristinas/hinitiality by Langston Barrett (@siddharthist). *) Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Induction.FunctorAlgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.W.Core. Local Open Scope Cat. Section Fibered. Context {A : UU} {B : A -> UU}. Local Notation "X ⇒ Y" := (algebra_mor (polynomial_functor _ _) X Y). Local Notation F := (polynomial_functor A B). (** A fibered P-algebra. (Definition 4.5 in Awodey, Gambino, and Sojakova) *) Definition fibered_alg (X : algebra_ob F) : UU := (∑ (E : (alg_carrier _ X) -> UU), ∏ (x : F (alg_carrier _ X)), (* ∑ (a : A), B a → X *) (∏ (b : B (pr1 x)), E ((pr2 x) b)) -> E ((pr2 X) x)). (** Any P-algebra can be made into a fibered P-algebra. *) Definition alg2fibered_alg {X : algebra_ob F} : algebra_ob F -> fibered_alg X. Proof. intro Alg. split with (fun _ => pr1 Alg). intros f. exact (fun g => (pr2 Alg) (pr1 f,, g)). Defined. (** Any fibered P-algebra can be made into a 'total' P-algebra. *) Definition fibered_alg2alg {X : algebra_ob F} : fibered_alg X -> algebra_ob F. Proof. intro E. pose (supx := pr2 X). pose (supe := pr2 E). split with (∑ x : pr1 X, pr1 E x). intro z; cbn in z; unfold polynomial_functor_obj in *. pose (z' := ((pr1 z),, pr1 ∘ (pr2 z)) : (∑ a : A, B a → pr1 X)). refine (supx z',, supe z' (λ b, (pr2 (pr2 z b)))). Defined. (** A P-algebra section. (Definition 4.6 in Awodey, Gambino, and Sojakova) *) Definition algebra_section {X : algebra_ob F} : ∏ (Y : fibered_alg X), UU. Proof. intro E. pose (supx := pr2 X). pose (supe := pr2 E). exact ((∑ (f : ∏ x : pr1 X, pr1 E x), ∏ a, f (supx a) = supe a (f ∘ (pr2 a)))). Defined. (** A P-algebra section homotopy. (Definition 4.7 in Awodey, Gambino, and Sojakova) *) Definition algebra_sec_homot {X : algebra_ob F} : ∏ {Y : fibered_alg X} (i j : algebra_section Y), UU. Proof. intros E. pose (supx := pr2 X). pose (supe := pr2 E). intros f g. refine (∑ (n : pr1 f ~ pr1 g), ∏ x, pr2 f x @ maponpaths (supe x) _ = n (supx x) @ pr2 g x). exact (funextsec _ _ _ (@funhomotsec _ _ _ (pr2 x) (pr1 f) (pr1 g) n)). Defined. Definition algebra_mor_to_algsec {X Y : algebra_ob F} (f : X ⇒ Y) : @algebra_section X (alg2fibered_alg Y). Proof. unfold algebra_section; cbn. refine (pr1 f,, _). exact (eqtohomot (pr2 f)). Defined. (** A P-algebra homotopy. (Definition 4.7 in Awodey, Gambino, and Sojakova) *) Definition algebra_mor_homot {X Y : algebra_ob F} (i j : X ⇒ Y) : UU := algebra_sec_homot (algebra_mor_to_algsec i) (algebra_mor_to_algsec j). (** The identity homotopy on a P-algebra section. *) Definition algebra_sec_homot_id {X : algebra_ob F} {Y : fibered_alg X} {f : algebra_section Y} : algebra_sec_homot f f. Proof. pose (supx := pr2 X). pose (supy := pr2 Y). split with (fun _ => idpath _). intro x. transitivity (pr2 f x @ maponpaths (supy x) (idpath _)). - do 2 (apply maponpaths). unfold funhomotsec; cbn. assert (H : (λ x0 : B (pr1 x), idpath (pr1 f (pr2 x x0))) = (toforallpaths _ (pr1 f ∘ pr2 x) (pr1 f ∘ pr2 x) (idpath _))). reflexivity. refine ((maponpaths _ H) @ _). apply funextsec_toforallpaths. - cbn; apply pathscomp0rid. Defined. (** The canonical function from the path space between two P-algebra sections to the type of P-algebra section homotopies. *) Definition algebra_section_path_to_homot {X : algebra_ob _} {Y : fibered_alg X} (i j : algebra_section Y) (p : i = j) : algebra_sec_homot i j. Proof. induction p. exact algebra_sec_homot_id. Defined. (** The identity homotopy on a P-algebra morphism. *) Definition algebra_mor_homot_id {X Y : algebra_ob F} {i : algebra_mor _ X Y} : algebra_mor_homot i i := @algebra_sec_homot_id _ (alg2fibered_alg Y) (algebra_mor_to_algsec i). (** A "(homotopy) uniqueness principle" for a P-algebra X: there exists a homotopy (and hence a path) between any two P-algebra morphisms into any other P-algebra Y. This is a little different than in Awodey, Gambino, and Sojakova. The main difference is that here we relate arbitrary two morphisms i,j whereas the rules in 5.8 relate an arbitrary morphism i to the canonical morphism given by the first two rules in 5.8. Our formulation has the advantage that it does not require the canonical morphism to exist, i.e., the type X does not have to satisfy the recursion princple for the uniqueness principle to make sense. (Loosely corresponds to the last two rules in Proposition 5.8 in Awodey, Gambino, and Sojakova) *) Definition homotopy_uniqueness_principle (X : algebra_ob F) : UU := ∏ (Y : algebra_ob F) (i j : algebra_mor F X Y), algebra_mor_homot i j. (** The "induction principle" for a P-algebra X: any fibered P-algebra Y has a section. (Definition 5.1 in Awodey, Gambino, and Sojakova) *) Definition is_preinitial_sec (X : algebra_ob F) : UU := ∏ (Y : fibered_alg X), algebra_section Y. (** A "fibered uniqueness principle": there exists a homotopy (and hence a path) between any two P-algebra sections of any fibered algebra. (Loosely corresponds to the rules in Proposition 5.3 in Awodey, Gambino, and Sojakova) *) Definition fibered_uniqueness (X : algebra_ob F) : UU := ∏ (Y : fibered_alg X) (i j : algebra_section Y), algebra_sec_homot i j. End Fibered. UniMath-20231010/UniMath/Induction/W/Naturals.v000066400000000000000000000225671451125700300210120ustar00rootroot00000000000000(** ** Natural numbers The natural numbers are a motivating example of W-types, and one of the only W-types readily available in UniMath. We show that they are an initial algebra for a polynomial functor, and satisfy a few other properties. Author: Langston Barrett (@siddharthist) *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.categories.Type.Core. Require Import UniMath.Induction.FunctorAlgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.W.Core. Require Import UniMath.Induction.W.Fibered. Local Notation ℕ := nat. (** The signature for the nat functor is (bool, [true ↦ empty; false ↦ unit]) since the naturals have two constructors: one for zero and one for successor. *) Definition nat_functor : functor type_precat type_precat := polynomial_functor bool (bool_rect (λ _, UU) empty unit). (** The functor deals with functions from ∅ and unit; these lemmas will come in handy in several proofs. *) Lemma eqfromempty {X : UU} (f : empty -> X) : f = fromempty. Proof. apply proofirrelevancecontr, iscontrfunfromempty. Defined. Lemma eta_unit {X : UU} (f : unit -> X) : f = λ _, f tt. Proof. apply funextfun; intro; induction _; reflexivity. Defined. (** Simplifying the action of the functor on arrows *) Lemma nat_functor_arr_true {X Y : UU} (f : X -> Y) g : (functor_on_morphisms nat_functor) f (true,, g) = (true,, fromempty). Proof. cbn; unfold polynomial_functor_arr; cbn. apply maponpaths, eqfromempty. Defined. Lemma nat_functor_arr_false {X Y : UU} (f : X -> Y) g : (functor_on_morphisms nat_functor) f (false,, g) = (false,, λ _, f (g tt)). Proof. cbn; unfold polynomial_functor_arr; cbn. apply maponpaths, eta_unit. Defined. (** Here's how to prove two functions from a nat_functor are equal: check both cases. *) Lemma from_nat_functor_eq {X Y : UU} : ∏ f g : nat_functor X → Y, (f (true,, fromempty) = g (true,, fromempty)) -> (∏ h, f (false,, λ _, h tt) = g (false,, λ _, h tt)) -> f = g. Proof. intros f g ? eqfalse. apply funextsec; intro pair. induction pair as [b bfun]. induction b. - refine (maponpaths (λ z, f (true,, z)) (eqfromempty bfun) @ _). refine (_ @ !maponpaths (λ z, g (true,, z)) (eqfromempty bfun)). assumption. - cbn in eqfalse. refine (maponpaths (λ z, f (false,, z)) (eta_unit bfun) @ _). refine (_ @ !maponpaths (λ z, g (false,, z)) (eta_unit bfun)). apply eqfalse. Defined. (** The intuition is that an algebra X for this functor is given by a constant x : X and a function X → X. The following equivalence verifies this. *) Definition nat_functor_equiv : ∏ {X : UU}, (X × (X → X)) ≃ (nat_functor X -> X). Proof. intro X. use weq_iso. * intros dprodpair. intros pairfun. induction pairfun as [b bfun]; induction b. - exact (pr1 dprodpair). - exact (pr2 dprodpair (bfun tt)). * intro pairfun. exact (make_dirprod (pairfun (true,, fromempty)) (λ x, pairfun (false,, λ _, x))). * reflexivity. * intro Y; apply from_nat_functor_eq; reflexivity. Defined. (** Using our equivalence, we can consisely define the algebra corresponding to ℕ. Any choice of zero results in an isomorphic algebra. *) Definition nat_alg (n : ℕ) : algebra_ob nat_functor := (ℕ,, nat_functor_equiv (make_dirprod n S)). Definition nat_alg_z : algebra_ob nat_functor := nat_alg 0. (** We may also define it directly. This will be judgmentally equal to [nat_alg_z]. *) Example nat_alg' : algebra_ob nat_functor. Proof. unfold algebra_ob, nat_functor; cbn; unfold polynomial_functor_obj; cbn. refine (ℕ,, λ pair, _). induction pair as [b rect]. induction b; cbn in rect. - exact 0. - exact (S (rect tt)). Defined. Lemma nat_algs_eq : nat_alg_z = nat_alg'. Proof. reflexivity. Defined. (** An algebra morphism between algebras for the nat functor is a function that respects all the relevant structure. *) Definition make_nat_functor_algebra_mor {X Y : algebra_ob nat_functor} : let X' := invmap nat_functor_equiv (pr2 X) in let Y' := invmap nat_functor_equiv (pr2 Y) in ∏ (f : pr1 X → pr1 Y), (f (pr1 X') = (pr1 Y')) × (f ∘ (pr2 X') = (pr2 Y') ∘ f) → is_algebra_mor _ X Y f. Proof. intros X' Y' f p. apply from_nat_functor_eq. + refine (_ @ !maponpaths _ (nat_functor_arr_true f _)). refine (pr1 p @ _). apply (maponpaths (pr2 Y)), maponpaths. reflexivity. + intro; apply (eqtohomot (pr2 p)). Defined. (** Define the unique algebra morphism out of ℕ *) Lemma nat_alg_is_preinitial : is_preinitial nat_alg_z. Proof. intro X; pose (x := pr2 X). (** X has a "zero" and a "successor", just like ℕ, given by the algebra structure. We use these to define the unique morphism ℕ -> X by induction. *) pose (x0 := x (true,, fromempty)). pose (xsucc := (λ y, x (false,, λ _, y)) : pr1 X -> pr1 X). (** The recursor for ℕ gets an extra argument of type ℕ, which we don't pass to xsucc. Compare to [CategoryTheory.FunctorAlgebras.nat_ob_rec]. *) refine ((nat_rect _ x0 (λ _, xsucc)),, _). apply make_nat_functor_algebra_mor; split; reflexivity. Defined. (** The first projection of the morphism out of ℕ (the actual function) is unique. *) Lemma nat_alg_func_is_unique : ∏ X, ∏ (mor : algebra_mor _ nat_alg_z X), pr1 mor = pr1 (nat_alg_is_preinitial X). Proof. intros X mor. induction X as [X x]; induction mor as [mor is_mor]; cbn in x. cbn in mor. apply funextfun; intros n; induction n; cbn. - unfold is_algebra_mor in is_mor; cbn in mor, is_mor. (** Use the condition that mor is an algebra morphism *) refine ((eqtohomot is_mor (true,, fromempty)) @ _). apply (maponpaths x). apply nat_functor_arr_true. - (** Use the condition that mor is an algebra morphism *) refine ((eqtohomot is_mor (false,, _)) @ _); cbn. apply (maponpaths x). unfold polynomial_functor_arr; cbn. apply maponpaths. apply funextsec; intros ttt; induction ttt. apply IHn. Defined. (** Since fibered algebras are the "dependent version" of normal algebras, we need some kind of "dependent version" of the lemmas above. *) Lemma sec_fromempty {X : UU} {Y : X -> UU} (f : ∅ -> X) (t : ∏ z : ∅, Y (f z)) : t = λ e, fromempty e. Proof. apply funextsec; intro; induction _. Defined. (** A fibered algebra over ℕ consists of a family ℕ → UU, a point x0 : X 0, and a function from each X n to X (S n). *) Definition fibered_algebra_nat : fibered_alg nat_alg_z ≃ ∑ (X : ∏ n : ℕ, UU), (X 0) × (∏ n, X n → X (S n)). Proof. apply weqfibtototal; intro X; cbn in X. use weq_iso. - intro x. apply make_dirprod. + exact (x (true,, fromempty) (λ e, fromempty e)). + refine (λ n xn, _). unfold fibered_alg in x; cbn in x. apply (x (false,, λ _, n) (λ _, xn)). - intro x. unfold fibered_alg; cbn. intros pair from; induction pair as [b bfun]. induction b; cbn in *. + exact (pr1 x). + exact (pr2 x (bfun tt) (from tt)). - cbn. intro g. apply funextsec; intro pair. induction pair as [b bfun]. induction b; cbn; cbn in bfun. + apply funextsec; intro z. rewrite (sec_fromempty bfun z). rewrite (eqfromempty bfun). reflexivity. + rewrite (eta_unit bfun). apply funextsec; intro z. apply maponpaths. exact (!eta_unit z). - reflexivity. Defined. (** A section from ℕ consists of a "point" x : ∏ n, X n such that x agrees with the function which is a part of the fibered algebra (see above). *) Definition make_nat_alg_sec : ∏ (FA : fibered_alg nat_alg_z), let FA' := fibered_algebra_nat FA in ∏ (x : ∏ n : ℕ, pr1 FA' n) (p1 : x 0 = pr1 (pr2 FA')) (p2 : (∏ n, pr2 (pr2 FA') n (x n) = x (S n))), algebra_section FA. Proof. intros FA FA' x p1 p2. unfold algebra_section. refine (x,, _). intro pair. induction pair as [b bfun]. induction b; cbn; cbn in bfun. - (** They are equal at 0 by hypothesis p1, the rest is noise. *) refine (p1 @ _). unfold FA', fibered_algebra_nat; cbn. rewrite (eqfromempty bfun). apply maponpaths. apply funextsec. intro e; induction e. - refine (!p2 (bfun tt) @ _). rewrite (eta_unit (bfun)). reflexivity. Defined. (** Another way to make an algebra section given different starting data. *) Definition make_nat_alg_sec' {X : ℕ -> UU} {ρ : ∏ n, X n → X (S n)} (x : ∏ n : ℕ, X n) (H : ∏ n : ℕ, x (S n) = ρ n (x n)) : algebra_section (invmap fibered_algebra_nat (X,, (x 0,, ρ))). Proof. refine (x,, _). intros pair; induction pair as [b bfun]; induction b. - reflexivity. - apply H. Defined. (** Define the section out of ℕ, prove it's really a section *) Lemma nat_alg_is_preinitial_sec : is_preinitial_sec nat_alg_z. Proof. intro E. pose (x := pr2 E). unfold is_preinitial, algebra_section. use make_nat_alg_sec. - apply nat_rect. + exact (x (true,, fromempty) (empty_rect (pr1 E ∘ fromempty))). + intros ? fn. refine (x (false,, λ _, n) (λ b : unit, fn)). - cbn. apply maponpaths. apply funextsec; intro e; induction e. - reflexivity. Defined. UniMath-20231010/UniMath/Induction/W/Uniqueness.v000066400000000000000000000112261451125700300213460ustar00rootroot00000000000000(** ** Uniqueness of W-types W-types are unique up to propositional equality. Author: Langston Barrett (@siddharthist) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.Induction.FunctorAlgebras_legacy. Require Import UniMath.Induction.PolynomialFunctors. Require Import UniMath.Induction.W.Core. Section Uniqueness. Local Open Scope functions. Local Open Scope cat. Context (A : UU). Context (B : A → UU). (** Following the paper, we have [X ⇒ Y] = Hom(X, Y) *) Local Notation F := (polynomial_functor A B). (* can be coerced to a function *) Local Notation "F*" := (polynomial_functor_arr A B). Local Notation "X ⇒ Y" := (algebra_mor F X Y). (** Since we can't use the standard categorical proof, we must re-prove that initial algebras are unique up to isomorphism. *) (** We prove that their carriers (first projections) are isomorphic, and hence equal (by univalence). This is standard categorical reasoning: each has exactly one arrow to the other, which, composing, gives an endormorphism. However, each has exactly one endomorphism, the identity map. Therefore, they are isomorphic. *) Lemma W_carriers_iso : ∏ X Y : W B, (alg_carrier F X) ≃ (alg_carrier F Y). Proof. intros X Y. (** Get the algebra morphisms X → Y and Y → X via initiality *) pose (X_mor_Y := iscontrpr1 (pr2 X Y)). pose (Y_mor_X := iscontrpr1 (pr2 Y X)). apply (weq_iso (mor_from_algebra_mor _ _ _ X_mor_Y) (mor_from_algebra_mor _ _ _ Y_mor_X)). - intro x. apply (toforallpaths _ (Y_mor_X ∘ X_mor_Y) (idfun _)). refine (base_paths (algebra_mor_comp _ _ _ _ X_mor_Y Y_mor_X) (algebra_mor_id F X) _). apply (proofirrelevancecontr (pr2 X X)). - intro y. apply (toforallpaths _ (X_mor_Y ∘ Y_mor_X) (idfun _)). refine (base_paths (algebra_mor_comp _ _ _ _ Y_mor_X X_mor_Y) (algebra_mor_id F Y) _). apply (proofirrelevancecontr (pr2 Y Y)). Defined. (** Note the crucial use of univalence *) Lemma W_carriers_eq : ∏ X Y : W B, (alg_carrier _ X) = (alg_carrier _ Y). Proof. exact (fun X Y => weqtopaths (W_carriers_iso X Y)). Defined. (** Now we must prove that the algebra morphisms, when transported along the path W_carriers_eq, will be equal. *) Lemma W_alg_eq : ∏ X Y : W B, W_algebra B X = W_algebra B Y. Proof. intros X Y. pose (f := pr1 ((pr2 X) (W_algebra B Y))). pose (pr1eq := (W_carriers_eq X Y)). apply (total2_paths_f pr1eq). (** Some shorthands for items we'll use *) pose (is_final_X := pr2 X). pose (is_final_Y := pr2 Y). pose (θ := pr2 (pr1 X)). pose (ψ := pr2 (pr1 Y)). (** substⁱ-lemma in HoTT/W-types *) assert (trans_fun : forall {X Y : UU} {F : UU → UU} {f : F X → X} {g : F Y → Y} (p : X = Y), (forall (x : F X), g (transportf F p x) = (transportf (idfun UU) p (f x))) → (* (forall (x : X), *) (* transportf F p (f x) = g (transportf (idfun UU) p x)) → *) transportf (λ X, F X → X) p f = g). { intros ? ? ? ? ? p H. induction p. apply funextfun. intro x. exact (!H x). } apply trans_fun. intro x. assert (arr_transport : forall {X Y : UU} (p : X = Y), F* (transportf (idfun _) p) = transportf F p). { intros ? ? p. induction p. reflexivity. } assert (lemma1 : forall x : pr1 (pr1 X), (pr1 f) x = transportf (idfun UU) pr1eq x ). { intro. refine (toforallpaths _ _ _ _ x0). refine (_ @ !(weqpath_transport (W_carriers_iso X Y))). reflexivity. } assert (lemma2 : transportf F pr1eq = F* (pr1 f)). { refine (!(arr_transport _ _ pr1eq) @ _). apply maponpaths. unfold pr1eq, W_carriers_eq. refine ((weqpath_transport (W_carriers_iso X Y)) @ _). reflexivity. } refine (_ @ lemma1 (θ x)). refine (maponpaths ψ (toforallpaths _ _ _ lemma2 x) @ _). (** Now our goal is simply the condition that f is a algebra morphism *) apply (toforallpaths _ (λ x, ψ (F* (pr1 f) x)) (pr1 f ∘ θ)). exact (!pr2 f). Defined. Lemma isaprop_W : isaprop (W B). apply invproofirrelevance. intros X Y. apply subtypePath. - exact isaprop_is_initial. - exact (W_alg_eq X Y). Defined. End Uniqueness. UniMath-20231010/UniMath/Ktheory/000077500000000000000000000000001451125700300163015ustar00rootroot00000000000000UniMath-20231010/UniMath/Ktheory/.package/000077500000000000000000000000001451125700300177525ustar00rootroot00000000000000UniMath-20231010/UniMath/Ktheory/.package/files000066400000000000000000000000251451125700300207740ustar00rootroot00000000000000GrothendieckGroup.v UniMath-20231010/UniMath/Ktheory/GrothendieckGroup.v000066400000000000000000000110751451125700300221170ustar00rootroot00000000000000(** Grothendieck groups of exact categories *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Export UniMath.CategoryTheory.ExactCategories.ExactCategories. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.Free_Monoids_and_Groups. Import AddNotation. Local Open Scope addmonoid. Section setquot. Lemma setquot_map_epi {X : Type} {R : eqrel X} {Y : hSet} {h h' : setquot R → Y} : h ∘ setquotpr R ~ h' ∘ setquotpr R -> h ~ h'. Proof. use (surjectionisepitosets _ _ _ (issurjsetquotpr R) (setproperty Y)). Defined. Lemma setquot_map_recovery {X : Type} (R : eqrel X) (Y : hSet) (h : setquot R → Y) : ∏ w, setquotuniv R Y (h ∘ setquotpr R) (λ x x' (r : R x x'), maponpaths h (iscompsetquotpr R x x' r)) w = h w. Proof. exact (setquot_map_epi (λ x, idpath (h (setquotpr R x)))). Qed. Definition setquot_universal_property (X:Type) (R:eqrel X) (Y:hSet) : (setquot R -> Y) ≃ (∑ f : X -> Y, iscomprelfun R f). Proof. use weq_iso. - intros h. exists (h ∘ setquotpr R). intros x x' r. simpl. apply maponpaths. apply iscompsetquotpr. exact r. - intros f. exact (setquotuniv R Y (pr1 f) (pr2 f)). - intros h. apply funextsec. unfold pr1,pr2. intros w. apply setquot_map_recovery. - intros f. cbn beta. apply subtypePath. * intros f'. apply isapropiscomprelfun. * cbn. reflexivity. Defined. Goal ∏ (X:Type) (R:eqrel X) (Y:hSet) (h : setquot R -> Y), pr1 (setquot_universal_property X R Y h) = h ∘ setquotpr R. Proof. reflexivity. Defined. Goal ∏ (X:Type) (R:eqrel X) (Y:hSet) (q : ∑ f : X -> Y, iscomprelfun R f), invmap (setquot_universal_property X R Y) q = setquotuniv R Y (pr1 q) (pr2 q). Proof. reflexivity. Defined. End setquot. (* new stuff *) Definition K_0_hrel (M:ExactCategory) : hrel (free_abgr (π₀ (ob M))) := λ g h, ∃ E : ShortExactSequence M, g = free_abgr_unit (component (Ob2 E)) × h = free_abgr_unit (component (Ob1 E)) + free_abgr_unit (component (Ob3 E)). Definition K_0_related {M:ExactCategory} (E : ShortExactSequence M) : K_0_hrel M (free_abgr_unit (component (Ob2 E))) (free_abgr_unit (component (Ob1 E)) + free_abgr_unit (component (Ob3 E))) := hinhpr ( E ,, idpath _ ,, idpath _). Definition K_0 (M:ExactCategory) : abgr := presented_abgr (π₀ (ob M)) (K_0_hrel M). Definition K_0_map {M N:ExactCategory} (F:ExactFunctor M N) : monoidfun (K_0 M) (K_0 N). Proof. use (presented_abgrfun (π₀_map (functor_on_objects F))). intros g h. use hinhfun. intros [E [e e']]. exists (applyFunctorToShortExactSequence F E). now induction (!e), (!e'). Defined. Definition K_0_class {M:ExactCategory} : ob M -> K_0 M := λ A, @presented_abgr_intro (π₀ M) _ (pi0pr _ A). Lemma K_0_eqn {M:ExactCategory} (E : ShortExactSequence M) : K_0_class (Ob2 E) = K_0_class (Ob1 E) + K_0_class (Ob3 E). Proof. apply iscompsetquotpr. apply generated_binopeqrel_intro. apply hinhpr. exists E. split; reflexivity. Defined. Lemma K_0_map_universal_property {M:ExactCategory} {G:abgr} : monoidfun (K_0 M) G ≃ ∑ f : ob M -> G, ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E). Proof. apply (weqcomp (presented_abgr_universal_property (K_0_hrel M) G)). apply (weqtotal2 π₀_universal_property). intros h. apply weqiff. + split. * intros i E. exact (i _ _ (K_0_related E)). * intros k w w' r. apply (squash_to_prop r (setproperty _ _ _)). clear r; intros [E [e e']]. induction (!e), (!e'); clear e e'. exact (k E). + apply isapropiscomprelfun. + apply impred_isaprop; intros E. apply setproperty. Defined. Definition K_0_universal_map {M:ExactCategory} {G:abgr} (f : ob M -> G) : (∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)) -> monoidfun (K_0 M) G. Proof. intros c. exact (invmap K_0_map_universal_property (f,,c)). Defined. Goal ∏ (M:ExactCategory) (G:abgr) (f : ob M -> G) (add : ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)) (A:M), K_0_universal_map f add (K_0_class A) = f A. Proof. reflexivity. Qed. Goal ∏ (M:ExactCategory) (G:abgr) (h : monoidfun (K_0 M) G), pr1 (K_0_map_universal_property h) = h ∘ K_0_class. Proof. reflexivity. Qed. Goal ∏ (M:ExactCategory) (G:abgr) (f : ob M -> G) (add : ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)), invmap K_0_map_universal_property (f,,add) = K_0_universal_map f add. Proof. intros. apply pathsinv0. (* omit this and it is slow! *) reflexivity. Qed. UniMath-20231010/UniMath/Ktheory/README.md000066400000000000000000000005261451125700300175630ustar00rootroot00000000000000Ktheory ======= Author: Daniel R. Grayson This package aims to formalize theorems of higher algebraic K-theory. There used to be a lot more files here, but we moved them into other packages. Overview of contents ==================== ## GrothendieckGroup.v Definition of the Grothendieck group of an exact category. UniMath-20231010/UniMath/MoreFoundations/000077500000000000000000000000001451125700300177705ustar00rootroot00000000000000UniMath-20231010/UniMath/MoreFoundations/.package/000077500000000000000000000000001451125700300214415ustar00rootroot00000000000000UniMath-20231010/UniMath/MoreFoundations/.package/files000066400000000000000000000005651451125700300224740ustar00rootroot00000000000000Bool.v Test.v WeakEquivalences.v Tactics.v PartA.v PathsOver.v Nat.v Notations.v AlternativeProofs.v Subposets.v DoubleNegation.v DecidablePropositions.v Propositions.v NullHomotopies.v Interval.v NegativePropositions.v Sets.v Orders.v Equivalences.v MoreEquivalences.v QuotientSet.v Subtypes.v AxiomOfChoice.v StructureIdentity.v Univalence.v NoInjectivePairing.v PartD.v UniMath-20231010/UniMath/MoreFoundations/AlternativeProofs.v000066400000000000000000000013601451125700300236260ustar00rootroot00000000000000Require Export UniMath.MoreFoundations.Notations. (** ** An alternative proof of [total2_paths_equiv] *) Theorem total2_paths_equiv' {A : UU} (B : A -> UU) (x y : ∑ x, B x) : x = y ≃ x ╝ y. Proof. simple refine (weqtotaltofib _ _ _ _ _). - intros z p. exists (maponpaths pr1 p). induction p. reflexivity. - apply isweqcontrcontr. + apply iscontrcoconusfromt. + exists (x ,, idpath _ ,, idpath _). intro w. induction w as [w p], w as [a b], p as [p q], x as [a' b'], (p:a' = a), (q:b' = b). reflexivity. Defined. Lemma total2_paths_equiv'_compute {A : UU} (B : A -> UU) (x y : ∑ x, B x) : pr1weq (total2_paths_equiv' B x y) = (λ (r : x = y), base_paths _ _ r ,, fiber_paths r). Proof. reflexivity. Defined. UniMath-20231010/UniMath/MoreFoundations/AxiomOfChoice.v000066400000000000000000000134601451125700300226400ustar00rootroot00000000000000(** * Axiom of choice *) Require Export UniMath.MoreFoundations.DecidablePropositions. Require Export UniMath.MoreFoundations.Sets. (** ** Preliminaries *) Lemma pr1_issurjective {X : UU} {P : X -> UU} : (∏ x : X, ∥ P x ∥) -> issurjective (pr1 : (∑ x, P x) -> X). (* move upstream later *) Proof. intros ne x. simple refine (hinhuniv _ (ne x)). intros p. apply hinhpr. exact ((x,,p),,idpath _). Defined. (** ** Characterize equivalence relations on [bool] *) Definition eqrel_on_bool (P:hProp) : eqrel boolset. (* an equivalence relation on bool amounts to a single proposition *) Proof. set (ifb := bool_rect (λ _:bool, hProp)). exists (λ x y, ifb (ifb htrue P y) (ifb P htrue y) x). repeat split. { intros x y z a b. induction x. - induction z. + exact tt. + induction y. * exact b. * exact a. - induction z. + induction y. * exact a. * exact b. + exact tt. } { intros x. induction x; exact tt. } { intros x y a. induction x; induction y; exact a. } Defined. Lemma eqrel_on_bool_iff (P:hProp) (E := eqrel_on_bool P) (f := setquotpr E) : f true = f false <-> P. Proof. split. { intro q. change (E true false). apply (invmap (weqpathsinsetquot _ _ _)). change (f true = f false). exact q. } { intro p. apply iscompsetquotpr. exact p. } Defined. (** ** Statements of Axiom of Choice *) Local Open Scope logic. (** We write these axioms as types rather than as axioms, which would assert them to be true, to force them to be mentioned as explicit hypotheses whenever they are used. *) Definition AxiomOfChoice : hProp := ∀ (X:hSet), ischoicebase X. Definition AxiomOfChoice_surj : hProp := ∀ (X:hSet) (Y:UU) (f:Y→X), issurjective f ⇒ ∃ g, ∀ x, f (g x) = x. (** Notice that the equation above is a proposition only because X is a set, which is not required in the previous formulation. The notation for "=" currently in effect uses [eqset] instead of [paths]. *) (** ** Implications between forms of the Axiom of Choice *) Lemma AC_impl2 : AxiomOfChoice <-> AxiomOfChoice_surj. Proof. split. - intros AC X Y f surj. use (squash_to_prop (AC _ _ surj) (propproperty _)). intro s. use hinhpr. use tpair. + exact (λ y, hfiberpr1 f y (s y)). + exact (λ y, hfiberpr2 f y (s y)). - intros AC X P ne. use (hinhuniv _ (AC X _ _ (pr1_issurjective ne))). intros sec. use hinhpr. intros x. induction (pr2 sec x). exact (pr2 (pr1 sec x)). Defined. (** ** The Axiom of Choice implies a type receives a surjective map from a set *) Theorem SetCovering (X:Type) : AxiomOfChoice -> ∃ (S:hSet) (f:S->X), issurjective f. Proof. (** We use the axiom of choice to find a splitting f of the projection map g from X onto its set [pi0 X] of connected components. Since the image of f contains one point in every component of X, f is surjective. *) intros ac. assert (ac' := pr1 AC_impl2 ac); clear ac; unfold AxiomOfChoice_surj in ac'. set (S := pi0 X : hSet). set (g := pi0pr X : X -> S). assert (f := ac' _ _ g (issurjsetquotpr _)); clear ac'. apply (squash_to_prop f). { apply propproperty. } clear f; intros [f eqn]. apply hinhpr. exists S. exists f. intros x. use (@squash_to_prop (f (g x) = x)%type). { apply (invmap (weqpathsinsetquot (pathseqrel X) _ _)). change (g (f (g x)) = g x)%type. exact (eqn (g x)). } { apply propproperty. } intros e. apply hinhpr. exists (g x). exact e. Defined. (** ** The Axiom of Choice implies the Law of the Excluded Middle *) (** This result is covered in the HoTT book, is due to Radu Diaconescu, "Axiom of choice and complementation", Proceedings of the American Mathematical Society, 51 (1975) 176–178, and was first mentioned on page 4 in F. W. Lawvere, "Toposes, algebraic geometry and logic (Conf., Dalhousie Univ., Halifax, N.S., 1971)", pp. 1–12, Lecture Notes in Math., Vol. 274, Springer, Berlin, 1972. The idea is to define an equivalence relation E on bool by setting [E true false := P], to use AC to split the surjection f from bool to its quotient Y by E with a function g, and to observe bool has decidable equality, and thus so does Y, because then Y is a retract of bool, to use that to decide whether [f true = f false], and thus to decide P. *) Theorem AC_to_LEM : AxiomOfChoice -> LEM. Proof. intros AC P. set (f := setquotpr _ : bool -> setquotinset (eqrel_on_bool P)). assert (q := pr1 AC_impl2 AC _ _ f (issurjsetquotpr _)). apply (squash_to_prop q). { apply isapropdec, propproperty. } intro sec. induction sec as [g h]. (* reduce decidability of P to decidability of [f true = f false] *) apply (logeq_dec (eqrel_on_bool_iff P)). (* a retract of a type with decidable equality has decidable equality *) apply (retract_dec f g h isdeceqbool). Defined. (** A weaker Axiom of Choice *) (** Having proved above that the Axiom of Choice implies the Law of the Excluded Middle, we would like to formulate a weaker axiom of choice that would be usable in formalization, but without implying the Law of the Excluded Middle, thus making it a more acceptable omniscience principle. Our idea here is to add the hypothesis that the base set have decidable equality. Classically, there is no difference between the two axioms. Recall from [isasetifdeceq] that a type with decidable equality is a set, so we don't include being a set explicitly in the statement of the axiom. *) Definition AxiomOfDecidableChoice : hProp := ∀ (X:UU), isdeceq X ⇒ ischoicebase X. Theorem AC_iff_ADC_and_LEM : AxiomOfChoice ⇔ AxiomOfDecidableChoice ∧ LEM. Proof. split. - intros AC. split. + intros X i. exact (AC (make_hSet X (isasetifdeceq X i))). + exact (AC_to_LEM AC). - intros [adc lem] X. refine (adc X _). intros x y. exact (lem (x = y)). Defined. UniMath-20231010/UniMath/MoreFoundations/Bool.v000066400000000000000000000020251451125700300210510ustar00rootroot00000000000000(** * Booleans *) Require Import UniMath.Foundations.Init. Require Import UniMath.Foundations.Sets. Definition andb : bool -> bool -> bool. Proof. intros b1 b2; induction b1; [exact b2|exact false]. Defined. Definition orb : bool -> bool -> bool. Proof. intros b1 b2; induction b1; [exact true|exact b2]. Defined. Definition implb : bool -> bool -> bool. Proof. intros b1 b2; induction b1; [exact b2|exact true]. Defined. Lemma andb_is_associative : ∏ b1 b2 b3 : bool, andb (andb b1 b2) b3 = andb b1 (andb b2 b3). Proof. intros; induction b1; induction b2; induction b3; reflexivity. Qed. Lemma orb_is_associative : ∏ b1 b2 b3 : bool, orb (orb b1 b2) b3 = orb b1 (orb b2 b3). Proof. intros; induction b1; induction b2; induction b3; reflexivity. Qed. Lemma andb_is_commutative : ∏ b1 b2 : bool, andb b1 b2 = andb b2 b1. Proof. intros; induction b1; induction b2; reflexivity. Qed. Lemma orb_is_commutative : ∏ b1 b2 : bool, orb b1 b2 = orb b2 b1. Proof. intros; induction b1; induction b2; reflexivity. Qed.UniMath-20231010/UniMath/MoreFoundations/DecidablePropositions.v000066400000000000000000000322201451125700300244430ustar00rootroot00000000000000Require Export UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.Tactics. Lemma retract_dec {X Y} (f : X -> Y) (g : Y -> X) (h : f ∘ g ~ idfun Y) : isdeceq X -> isdeceq Y. Proof. intros i y y'. induction (i (g y) (g y')) as [eq|ne]. - apply ii1. exact (! h y @ maponpaths f eq @ h y'). - apply ii2. intro p. apply ne. exact (maponpaths g p). Defined. Lemma logeq_dec {X Y} : (X <-> Y) -> decidable X -> decidable Y. Proof. intros iff decX. induction iff as [XtoY YtoX]. induction decX as [x|nx]. - now apply ii1, XtoY. - now apply ii2, (negf YtoX). Defined. Definition decidable_prop (X:hProp) := make_hProp (decidable X) (isapropdec X (pr2 X)). Definition LEM : hProp := ∀ P : hProp, decidable_prop P. (** ** Decidability via complementary pairs *) Definition ComplementaryPair : UU := ∑ (P Q : UU), complementary P Q. Definition Part1 (C : ComplementaryPair) : UU := pr1 C. Definition Part2 (C : ComplementaryPair) : UU := pr1 (pr2 C). Definition pair_contradiction (C : ComplementaryPair) : Part1 C -> Part2 C -> ∅ := pr1 (pr2 (pr2 C)). Definition chooser (C : ComplementaryPair) : Part1 C ⨿ Part2 C := pr2 (pr2 (pr2 C)). Definition isTrue (C : ComplementaryPair) := hfiber (@ii1 (Part1 C) (Part2 C)) (chooser C). Definition isFalse (C : ComplementaryPair) := hfiber (@ii2 (Part1 C) (Part2 C)) (chooser C). Definition trueWitness {C : ComplementaryPair} : isTrue C -> Part1 C := pr1. Definition falseWitness {C : ComplementaryPair} : isFalse C -> Part2 C := pr1. Coercion trueWitness : isTrue >-> Part1. Coercion falseWitness : isFalse >-> Part2. Lemma complementaryDecisions (C : ComplementaryPair) : iscontr (isTrue C ⨿ isFalse C). Proof. (* the idea of this proof is to show that [isTrue C ⨿ isFalse C] is the same as the decomposition provided by [weqcoprodsplit] *) intros. apply iscontrifweqtounit. assert (w := weqcoprodsplit (λ _:unit, chooser C)). apply invweq. apply (weqcomp w). apply weqcoprodf; apply weqhfiberunit. Defined. Lemma isaprop_isTrue (C : ComplementaryPair) : isaprop (isTrue C). (* No axioms are used. *) Proof. intros. apply (isapropcomponent1 (isTrue C) (isFalse C)). apply isapropifcontr. apply complementaryDecisions. Defined. Lemma isaprop_isFalse (C : ComplementaryPair) : isaprop (isFalse C). (* No axioms are used. *) (* By contrast, to prove [¬P] is a proposition requires the use of functional extensionality. *) Proof. intros. apply (isapropcomponent2 (isTrue C) (isFalse C)). apply isapropifcontr. apply complementaryDecisions. Defined. Ltac unpack_pair C P Q con c := induction C as [P Qc]; induction Qc as [Q c]; induction c as [con c]; simpl in c, P, Q. Lemma pair_truth (C : ComplementaryPair) : Part1 C -> isTrue C. Proof. intros p. unpack_pair C P Q con c; unfold isTrue, hfiber, Part1, Part2, chooser in *; simpl in *. induction c as [p'|q]. - now exists p'. - apply fromempty. contradicts (con p) q. Defined. Lemma pair_falsehood (C : ComplementaryPair) : Part2 C -> isFalse C. Proof. intros q. unpack_pair C P Q con c; unfold isFalse, hfiber, Part1, Part2, chooser in *; simpl in *. induction c as [p|q']. - apply fromempty. contradicts (con p) q. - now exists q'. Defined. Definition to_ComplementaryPair {P : UU} (c : P ⨿ neg P) : ComplementaryPair (* By using [isTrue _] instead, we're effectively replacing P by a propositional subtype of it: *) (* the part connected to the element of [P ⨿ ¬P]. *) (* Similarly, by using [isFalse _] instead, we're effectively replacing [¬P] by a propositional subtype of it. *) (* Both are proved to be propositions without [funextemptyAxiom] *) := (P,,neg P,,(λ p n, n p),,c). (* Relate isolated points to complementary pairs *) Definition isolation {X : UU} (x : X) (is : isisolated X x) (y : X) : UU := isFalse (to_ComplementaryPair (is y)). Definition isaprop_isolation {X : UU} (x : X) (is : isisolated X x) (y : X) : isaprop (isolation x is y) := isaprop_isFalse _. Definition isolation_to_inequality {X : UU} (x : X) (is : isisolated X x) (y : X) : isolation x is y -> x != y := falseWitness. Definition inequality_to_isolation {X : UU} (x : X) (i : isisolated X x) (y : X) : x != y -> isolation x i y := pair_falsehood (to_ComplementaryPair (i y)). (* operations on complementary pairs *) Definition pairNegation (C : ComplementaryPair) : ComplementaryPair := Part2 C,, Part1 C ,, (λ q p, pair_contradiction C p q),, coprodcomm _ _ (chooser C). Definition pairConjunction (C C' : ComplementaryPair) : ComplementaryPair. Proof. unpack_pair C P Q con c; unpack_pair C' P' Q' con' c'; simpl in *. unfold ComplementaryPair. exists (P × P'); exists (Q ⨿ Q'). split. - simpl. intros a b. induction a as [p p']. induction b as [b|b]. + induction c' as [_|q']. * contradicts (con p) b. * contradicts (con p) b. + contradicts (con' p') b. - simpl. induction c as [p|q]. + induction c' as [p'|q']. * apply ii1. exact (p,,p'). * apply ii2, ii2. exact q'. + induction c' as [p'|q']. * apply ii2, ii1. exact q. * apply ii2, ii2. exact q'. Defined. Definition pairDisjunction (C C' : ComplementaryPair) : ComplementaryPair. Proof. intros. exact (pairNegation (pairConjunction (pairNegation C) (pairNegation C'))). Defined. Definition dnegelim {P Q : UU} : complementary P Q -> ¬¬ P -> P. Proof. intros c nnp. induction c as [n c]. induction c as [p|q]. - assumption. - contradicts nnp (λ p, n p q). Defined. (* Law of Excluded Middle We don't state LEM as an axiom, because we want to force it to be a hypothesis of any corollaries of any theorems that appeal to it. *) Lemma LEM_for_sets (X : UU) : LEM -> isaset X -> isdeceq X. Proof. intros lem is x y. exact (lem (make_hProp (x = y) (is x y))). Defined. Lemma isaprop_LEM : isaprop LEM. Proof. unfold LEM. apply impred_isaprop; intro P. apply isapropdec. apply propproperty. Defined. Lemma dneg_LEM (P : hProp) : LEM -> ¬¬ P -> P. Proof. intros lem. exact (dnegelim ((λ p np, np p),,lem P)). Defined. Corollary reversal_LEM (P Q : hProp) : LEM -> (¬ P -> Q) -> (¬ Q -> P). Proof. intros lem f n. assert (g := negf f); clear f. assert (h := g n); clear g n. apply (dneg_LEM _ lem). exact h. Defined. (*****************************************************************************) (* all of this stuff about decidable propositions will be replaced by the better code above *) (*****************************************************************************) Definition DecidableProposition : UU := ∑ X : UU, isdecprop X. Definition isdecprop_to_DecidableProposition {X : UU} (i : isdecprop X) : DecidableProposition := X,,i. Definition decidable_to_isdecprop {X : hProp} : decidable X -> isdecprop X. Proof. intros dec. apply isdecpropif. - apply propproperty. - exact dec. Defined. Definition decidable_to_isdecprop_2 {X : UU} : isaprop X -> X ⨿ ¬ X -> isdecprop X. Proof. intros i dec. apply isdecpropif. - exact i. - exact dec. Defined. Definition decidable_to_DecidableProposition {X : hProp} : decidable X -> DecidableProposition. Proof. intros dec. exists X. now apply decidable_to_isdecprop. Defined. Definition DecidableProposition_to_isdecprop (X : DecidableProposition) : isdecprop (pr1 X). Proof. apply pr2. Defined. Definition DecidableProposition_to_hProp : DecidableProposition -> hProp. Proof. intros X. exact (pr1 X,, isdecproptoisaprop (pr1 X) (pr2 X)). Defined. Coercion DecidableProposition_to_hProp : DecidableProposition >-> hProp. Definition decidabilityProperty (X : DecidableProposition) : isdecprop X := pr2 X. Definition DecidableSubtype (X : UU) : UU := X -> DecidableProposition. Definition DecidableRelation (X : UU) : UU := X -> X -> DecidableProposition. Definition decrel_to_DecidableRelation {X : UU} : decrel X -> DecidableRelation X. Proof. intros R x y. induction R as [R is]. exists (R x y). apply isdecpropif. { apply propproperty. } apply is. Defined. Definition decidableAnd (P Q : DecidableProposition) : DecidableProposition. Proof. intros. exists (P × Q). apply isdecpropdirprod; apply decidabilityProperty. Defined. Definition decidableOr (P Q : DecidableProposition) : DecidableProposition. Proof. intros. exists (P ∨ Q). apply isdecprophdisj; apply decidabilityProperty. Defined. Lemma neg_isdecprop {X : UU} : isdecprop X -> isdecprop (¬ X). Proof. intros i. set (j := isdecproptoisaprop X i). apply isdecpropif. - apply isapropneg. - unfold isdecprop in i. set (k := pr1 i). induction k as [k|k]. + apply ii2. now apply todneg. + now apply ii1. Defined. Definition decidableNot (P : DecidableProposition) : DecidableProposition. Proof. intros. exists (¬ P). apply neg_isdecprop; apply decidabilityProperty. Defined. Declare Scope decidable_logic. Notation "X ∨ Y" := (decidableOr X Y) (at level 85, right associativity) : decidable_logic. Notation "A ∧ B" := (decidableAnd A B) (at level 80, right associativity) : decidable_logic. Notation "'¬' X" := (decidableNot X) (at level 35, right associativity) : decidable_logic. Delimit Scope decidable_logic with declog. Ltac choose P yes no := induction (pr1 (decidabilityProperty P)) as [yes|no]. Definition choice {W : UU} : DecidableProposition -> W -> W -> W. Proof. intros P yes no. choose P p q. - exact yes. - exact no. Defined. Definition dependent_choice {W : UU} (P : DecidableProposition) : (P -> W) -> (¬ P -> W) -> W. Proof. intros yes no. choose P p q. - exact (yes p). - exact (no q). Defined. Definition choice_compute_yes {W : UU} (P : DecidableProposition) (p : P) (yes no : W) : choice P yes no = yes. Proof. intros. unfold choice. choose P a b. - simpl. reflexivity. - simpl. contradicts p b. Defined. Definition choice_compute_no {W : UU} (P : DecidableProposition) (p : ¬ P) (yes no : W) : choice P yes no = no. Proof. intros. unfold choice. choose P a b. - simpl. contradicts p a. - simpl. reflexivity. Defined. Definition decidableSubtypeCarrier {X : UU} : DecidableSubtype X -> UU. Proof. intros S. exact (∑ x, S x). Defined. Definition decidableSubtypeCarrier' {X : UU} : DecidableSubtype X -> UU. Proof. intros P. (* for use with isfinitedecsubset *) exact (hfiber (λ x, choice (P x) true false) true). Defined. Definition decidableSubtypeCarrier_weq {X : UU} (P : DecidableSubtype X) : decidableSubtypeCarrier' P ≃ decidableSubtypeCarrier P. Proof. intros. apply weqfibtototal. intros x. unfold choice. simpl. change (pr1 (decidabilityProperty (P x))) with (pr1 (decidabilityProperty (P x))). choose (P x) p q. - simpl. apply weqiff. + apply logeq_both_true. * reflexivity. * assumption. + apply isasetbool. + apply (propproperty (DecidableProposition_to_hProp _)). - simpl. apply weqiff. + apply logeq_both_false. * exact nopathsfalsetotrue. * assumption. + apply isasetbool. + apply (propproperty (DecidableProposition_to_hProp _)). Defined. Definition DecidableSubtype_to_hsubtype {X : UU} (P : DecidableSubtype X) : hsubtype X := λ x, DecidableProposition_to_hProp (P x). Coercion DecidableSubtype_to_hsubtype : DecidableSubtype >-> hsubtype. Definition DecidableRelation_to_hrel {X : UU} (P : DecidableRelation X) : hrel X := λ x y, DecidableProposition_to_hProp(P x y). Coercion DecidableRelation_to_hrel : DecidableRelation >-> hrel. Definition natlth_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natlthdec. Definition natleh_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natlehdec. Definition natgth_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natgthdec. Definition natgeh_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natgehdec. Definition nateq_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natdeceq. Definition natneq_DecidableProposition : DecidableRelation nat := decrel_to_DecidableRelation natdecneq. Declare Scope decidable_nat. Notation " x < y " := (natlth_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x <= y " := (natleh_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x ≤ y " := (natleh_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x ≥ y " := (natgeh_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x ≥ y " := (natgeh_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x > y " := (natgth_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x =? y " := (nateq_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Notation " x ≠ y " := (natneq_DecidableProposition x y) (at level 70, no associativity) : decidable_nat. Delimit Scope decidable_nat with dnat. UniMath-20231010/UniMath/MoreFoundations/DoubleNegation.v000066400000000000000000000020621451125700300230560ustar00rootroot00000000000000Require Import UniMath.Foundations.All. (** When proving a negation, we may undo a double negation. *) Lemma wma_dneg {X:Type} (P:Type) : ¬¬ P -> (P -> ¬ X) -> ¬ X. Proof. intros dnp p. apply dnegnegtoneg. assert (q := dnegf p); clear p. apply q; clear q. apply dnp. Defined. (** It's not false that a type is decidable. *) Lemma dneg_decidable (P:Type) : ¬¬ decidable P. Proof. intros ndec. unfold decidable in ndec. assert (q := fromnegcoprod ndec); clear ndec. contradicts (pr1 q) (pr2 q). Defined. (** When proving a negation, we may assume a type is decidable. *) Lemma wma_decidable {X:Type} (P:Type) : (decidable P -> ¬ X) -> ¬ X. Proof. apply (wma_dneg (decidable P)). apply dneg_decidable. Defined. Local Open Scope logic. (** Compare with [negforall_to_existsneg], which uses LEM instead. *) Lemma negforall_to_existsneg' {X:Type} (P:X->Type) : (¬ ∏ x, ¬¬ (P x)) -> ¬¬ (∃ x, ¬ (P x)). Proof. intros nf c. use nf; clear nf. intro x. assert (q := neghexisttoforallneg _ c x); clear c; simpl in q. exact q. Defined. UniMath-20231010/UniMath/MoreFoundations/Equivalences.v000066400000000000000000000355211451125700300226110ustar00rootroot00000000000000(** * Equivalences *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.Tactics. Definition post_cat {X} {x y z:X} {p:y = z} : x = y -> x = z. Proof. intros q. exact (pathscomp0 q p). Defined. Definition pre_cat {X} {x y z:X} {p:x = y} : y = z -> x = z. Proof. intros q. exact (pathscomp0 p q). Defined. Definition isEquivalence {X Y:Type} (f:X->Y) := ∑ (g:Y->X) (p:∏ y, f(g y) = y) (q:∏ x, g(f x) = x), ∏ x, maponpaths f (q x) = p(f x). Definition isEquivalence_toInverseFunction {X Y} {f:X->Y} : isEquivalence f -> Y->X := pr1. Definition isEquivalence_toTargetHomotopy {X Y} {f:X->Y} (i:isEquivalence f) : ∏ y, f (isEquivalence_toInverseFunction i y) = y := pr12 i. Definition isEquivalence_toSourceHomotopy {X Y} {f:X->Y} (i:isEquivalence f) : ∏ x, isEquivalence_toInverseFunction i (f x) = x := pr122 i. Definition isEquivalence_toAdjointness {X Y} {f:X->Y} (i:isEquivalence f) : ∏ x, maponpaths f (isEquivalence_toSourceHomotopy i x) = isEquivalence_toTargetHomotopy i (f x) := pr222 i. Definition Equivalence X Y := ∑ (f:X->Y), isEquivalence f. Notation "X ≅ Y" := (Equivalence X Y) (at level 60, no associativity) : type_scope. Definition makeEquivalence X Y f g p q h := (f,,g,,p,,q,,h) : X ≅ Y. Definition Equivalence_toFunction {X Y} : X≅Y -> X->Y := pr1. Coercion Equivalence_toFunction : Equivalence >-> Funclass. Definition Equivalence_to_isEquivalence {X Y} (w:X≅Y) : isEquivalence w := pr2 w. Definition Equivalence_toInverseFunction {X Y} : X≅Y -> Y->X. Proof. intros f. exact (pr1 (pr2 f)). Defined. Definition Equivalence_toTargetHomotopy {X Y} (f:Equivalence X Y) : ∏ y, f (Equivalence_toInverseFunction f y) = y := pr1 (pr2 (pr2 f)). Definition Equivalence_toSourceHomotopy {X Y} (f:Equivalence X Y) : ∏ x, Equivalence_toInverseFunction f (f x) = x := pr1 (pr2 (pr2 (pr2 f))). Definition Equivalence_toAdjointness {X Y} (f:Equivalence X Y) : ∏ x, maponpaths f (Equivalence_toSourceHomotopy f x) = Equivalence_toTargetHomotopy f (f x) := pr2 (pr2 (pr2 (pr2 f))). Lemma transportf_fun_idpath {X Y} {f:X->Y} x x' (w:x = x') (t:f x = f x) : transportf (λ x', f x' = f x) w (idpath (f x)) = maponpaths f (!w). Proof. induction w. reflexivity. Qed. Definition isEquivalence_to_isweq {X Y} {f:X->Y} : isEquivalence f -> isweq f. Proof. intros i. set (g := isEquivalence_toInverseFunction i). set (p := isEquivalence_toTargetHomotopy i). set (q := isEquivalence_toSourceHomotopy i). set (h := isEquivalence_toAdjointness i). intro y. exists (g y,,p y). intros xe. simple refine (hfibertriangle2 _ _ _ _ _). - exact (! (q (pr1 xe)) @ maponpaths g (pr2 xe)). - induction xe as [x e]; simpl. induction e; simpl. rewrite pathscomp0rid. rewrite maponpathsinv0. rewrite h. now rewrite pathsinv0l. Defined. Definition Equivalence_to_weq {X Y} : X ≅ Y -> X ≃ Y. Proof. intros w. exact (make_weq (Equivalence_toFunction w) (isEquivalence_to_isweq (Equivalence_to_isEquivalence w))). Defined. Definition weq_to_Equivalence {X Y} : X ≃ Y -> X ≅ Y. intros f. exact (makeEquivalence X Y f (invmap f) (homotweqinvweq f) (homotinvweqweq f) (homotweqinvweqweq f)). Defined. Lemma check1 X Y (w:X≅Y) : Equivalence_toFunction (weq_to_Equivalence (Equivalence_to_weq w)) = Equivalence_toFunction w. Proof. reflexivity. Defined. Lemma check2 X Y (w:X≅Y) : Equivalence_toInverseFunction (weq_to_Equivalence (Equivalence_to_weq w)) = Equivalence_toInverseFunction w. Proof. reflexivity. Defined. Lemma check3 X Y (w:X≅Y) : Equivalence_toTargetHomotopy (weq_to_Equivalence (Equivalence_to_weq w)) = Equivalence_toTargetHomotopy w. Proof. reflexivity. Defined. Lemma check4 X Y (w:X≅Y) : Equivalence_toSourceHomotopy (weq_to_Equivalence (Equivalence_to_weq w)) = Equivalence_toSourceHomotopy w. Proof. try reflexivity. revert w. intros [f [g [p [q h]]]]. unfold Equivalence_toSourceHomotopy; simpl. apply funextsec; intros x. try reflexivity. Abort. (* another proof *) Definition weq_to_Equivalence' X Y : X ≃ Y -> Equivalence X Y. intros [f r]. unfold isweq in r. set (g := λ y, hfiberpr1 f y (pr1 (r y))). set (p := λ y, pr2 (pr1 (r y))). simpl in p. set (L := λ x, pr2 (r (f x)) (make_hfiber f x (idpath (f x)))). set (q := λ x, maponpaths pr1 (L x)). set (q' := λ x, !q x). exact (makeEquivalence X Y f g p q' (λ x, ! transportf_fun_idpath x (pr1 (pr1 (r (f x)))) (q x) (idpath (f x)) @ (fiber_paths (L x)))). Defined. Definition path_inv_rotate_lr {X} {a b c:X} (r:a = b) (p:b = c) (q:a = c) : q = r @ p -> q @ !p = r. Proof. intros e. destruct p. destruct q. rewrite pathscomp0rid in e. exact e. Defined. Definition path_inv_rotate_rr {X} {a b c:X} (r:a = b) (p:b = c) (q:a = c) : r @ p = q -> r = q @ !p. Proof. intros e. destruct p. destruct q. rewrite pathscomp0rid in e. exact e. Defined. Definition path_inv_rotate_ll {X} {a b c:X} (p:a = b) (r:b = c) (q:a = c) : q = p @ r -> !p @ q = r. Proof. intros e. destruct p. destruct q. exact e. Defined. Definition path_inv_rotate_rl {X} {a b c:X} (p:a = b) (r:b = c) (q:a = c) : p @ r = q -> r = !p @ q. Proof. intros e. destruct p. destruct q. exact e. Defined. Definition path_inverse_from_right {X} {x y:X} (p q:x = y) : !q@p = idpath _ -> p = q. Proof. intros e. destruct q. exact e. Defined. Definition path_inverse_from_right' {X} {x y:X} (p q:x = y) : p@!q = idpath _ -> p = q. Proof. intros e. destruct q. intermediate_path (p @ idpath x). { apply pathsinv0. apply pathscomp0rid. } exact e. Defined. Definition maponpaths_fun_fun_natl {X Y Z} {g g':X->Y} {f f':Y->Z} (q:homot g g') (p:homot f f') x : maponpaths f (q x) @ p (g' x) = p (g x) @ maponpaths f' (q x). Proof. intros. destruct (q x). simpl. rewrite pathscomp0rid. reflexivity. Defined. Definition maponpaths_fun_fun_fun_natl {X Y Z W} {g g':X->Y} (q:homot g g') (h:Y->Z) {f f':Z->W} (p:homot f f') x : maponpaths f (maponpaths h (q x)) @ p (h (g' x)) = p (h (g x)) @ maponpaths f' (maponpaths h (q x)). Proof. intros. destruct (q x). simpl. rewrite pathscomp0rid. reflexivity. Defined. Definition path_comp_inv_inv {X} {a b c:X} (p:a = b) (q:b = c) : ! q @ ! p = ! (p @ q). Proof. intros. destruct p,q. reflexivity. Defined. Local Notation "p @' q" := (pathscomp0 p q) (only parsing, at level 61, left associativity). Local Arguments idpath {_ _}. Lemma other_adjoint {X Y} (f : X -> Y) (g : Y -> X) (p : ∏ y : Y, f (g y) = y) (q : ∏ x : X, g (f x) = x) (h : ∏ x : X, maponpaths f (q x) = p (f x)) : ∏ y : Y, maponpaths g (p y) = q (g y). Proof. intros. apply pathsinv0. intermediate_path ( !(maponpaths g (p (f (g y)))) @' maponpaths g (p (f (g y))) @' q (g y)). { rewrite pathsinv0l. reflexivity. } intermediate_path ( !(maponpaths g (maponpaths f (q (g y)))) @' maponpaths g (p (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. apply (maponpaths pathsinv0). apply (maponpaths (maponpaths g)). set (y' := g y). apply pathsinv0. exact (h y'). } intermediate_path ( !(maponpaths g (maponpaths f (q (g y)))) @' maponpaths g (p (f (g y))) @' ((!q (g (f (g y)))) @' q (g (f (g y))) @' q (g y))). { rewrite pathsinv0l. reflexivity. } intermediate_path ( !(maponpaths g (maponpaths f (q (g y)))) @' maponpaths g (p (f (g y))) @' ((!q (g (f (g y)))) @' (maponpaths g (p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y)))) @' q (g y))). { maponpaths_pre_post_cat. apply path_inv_rotate_rr. reflexivity. } apply path_inverse_from_right. repeat rewrite path_assoc. intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths (funcomp f g) (maponpaths g (p (f (g y)))) @' maponpaths g (p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. apply path_inv_rotate_lr. rewrite <- path_assoc. apply path_inv_rotate_rl. apply pathsinv0. rewrite <- (maponpathscomp f g). set (y' := f (g y)). assert (r := maponpaths_fun_fun_fun_natl p g q y'). simpl in r. rewrite (maponpathscomp f). rewrite (maponpathscomp g). rewrite (maponpathscomp g (λ x : X, g (f x))) in r. rewrite maponpathsidfun in r. exact r. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (maponpaths f (maponpaths g (p (f (g y))))) @' maponpaths g (p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp f g). reflexivity. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (maponpaths f (maponpaths g (p (f (g y)))) @' p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp0 g). reflexivity. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (maponpaths (funcomp g f) (p (f (g y))) @' p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp g f). reflexivity. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (p (f (g (f (g y)))) @' p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp g f). apply (maponpaths (maponpaths g)). generalize (f (g y)); clear y; intro y. assert (r := maponpaths_fun_fun_natl p p y); simpl in r. assert (s := maponpathsidfun (p y)); unfold idfun in s. rewrite s in r; clear s. rewrite (maponpathscomp g). exact r. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (p (f (g (f (g y))))) @' maponpaths g (p (f (g y))) @' !(maponpaths g (p (f (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp0 g). reflexivity. } intermediate_path ( !(maponpaths g (p y)) @' !(maponpaths g (maponpaths f (q (g y)))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (p (f (g (f (g y))))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. repeat rewrite <- path_assoc. rewrite pathsinv0r. rewrite pathscomp0rid. reflexivity. } intermediate_path ( maponpaths g ((!p y) @' maponpaths f (!q (g y))) @' !(q (g (f (g (f (g y)))))) @' maponpaths g (p (f (g (f (g y))))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. repeat rewrite <- maponpathsinv0. rewrite <- (maponpathscomp0 g). reflexivity. } intermediate_path ( !(q (g y)) @' maponpaths (funcomp f g) (maponpaths g ((!p y) @' maponpaths f (!q (g y)))) @' maponpaths g (p (f (g (f (g y))))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. repeat rewrite maponpathscomp0. repeat rewrite <- (maponpathscomp f g). repeat rewrite maponpathsinv0. repeat rewrite path_comp_inv_inv. apply (maponpaths pathsinv0). assert (r := ! maponpaths_fun_fun_fun_natl q (funcomp f g) q (g y)); simpl in r. rewrite maponpathsidfun in r. repeat rewrite <- (maponpathscomp f g) in r. simpl in r. repeat rewrite path_assoc. rewrite r. maponpaths_pre_post_cat. clear r. assert (r := ! maponpaths_fun_fun_fun_natl p g q y); simpl in r. rewrite maponpathsidfun in r. rewrite (maponpathscomp f). rewrite (maponpathscomp g). rewrite (maponpathscomp g) in r. exact r. } intermediate_path ( !(q (g y)) @' maponpaths g (maponpaths (funcomp g f) ((!p y) @' maponpaths f (!q (g y)))) @' maponpaths g (p (f (g (f (g y))))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp g f). rewrite <- (maponpathscomp f g). reflexivity. } intermediate_path ( !(q (g y)) @' maponpaths g (maponpaths (funcomp g f) ((!p y) @' maponpaths f (!q (g y))) @' p (f (g (f (g y))))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- maponpathscomp0. apply (maponpaths (maponpaths g)). reflexivity. } intermediate_path ( !(q (g y)) @' maponpaths g (p y @' ((!p y) @' maponpaths f (!q (g y)))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp g f). repeat rewrite maponpathscomp0. repeat rewrite maponpathsinv0. repeat rewrite <- path_assoc. repeat apply path_inv_rotate_ll. repeat rewrite path_assoc. repeat apply path_inv_rotate_rr. apply pathsinv0. repeat rewrite <- (maponpathscomp0 g). apply (maponpaths (maponpaths g)). rewrite h. assert (r := ! maponpaths_fun_fun_natl p p (f (g y))); simpl in r. rewrite maponpathsidfun in r. simpl in *. repeat rewrite <- (maponpathscomp g f) in r. repeat rewrite (path_assoc _ _ (p y)). rewrite r. repeat rewrite <- (path_assoc _ _ (p y)). apply (maponpaths pre_cat). clear r. assert (r := maponpaths_fun_fun_natl p p y); simpl in r. rewrite maponpathsidfun in r. repeat rewrite <- (maponpathscomp g f) in r. exact r. } intermediate_path ( (!q (g y)) @' maponpaths g (maponpaths f (!q (g y))) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. repeat rewrite <- maponpathsinv0. apply (maponpaths (maponpaths g)). rewrite pathsinv0r. reflexivity. } intermediate_path ( (!q (g y)) @' maponpaths (funcomp f g) (!q (g y)) @' q (g (f (g y))) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp f g). reflexivity. } intermediate_path ((!q (g y)) @' q (g y) @' (!q (g y)) @' q (g y)). { maponpaths_pre_post_cat. rewrite <- (maponpathscomp f g). apply path_inv_rotate_ll. repeat rewrite path_assoc. apply path_inv_rotate_rr. assert (r := ! maponpaths_fun_fun_natl q q (g y)); simpl in r. rewrite maponpathsidfun in r. rewrite (maponpathscomp f g). exact r. } rewrite pathsinv0l. simpl. rewrite pathsinv0l. reflexivity. Qed. Definition inverseEquivalence {X Y} : Equivalence X Y -> Equivalence Y X. Proof. intros [f [g [p [q h]]]]. simple refine (makeEquivalence Y X g f q p _). intro y. apply other_adjoint. assumption. Defined. UniMath-20231010/UniMath/MoreFoundations/Interval.v000066400000000000000000000023611451125700300217450ustar00rootroot00000000000000(** * A construction of the interval using propositional truncation *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.NullHomotopies. Require Import UniMath.MoreFoundations.Notations. Definition interval := ∥ bool ∥. Definition left := hinhpr true : interval. Definition right := hinhpr false : interval. Definition interval_path : left = right := squash_path true false. Definition interval_map {Y} {y y':Y} : y = y' -> interval -> Y. Proof. intros e. set (f := λ t:bool, if t then y else y'). refine (cone_squash_map f (f false) _). intros v. induction v. { exact e. } { reflexivity. } Defined. Goal ∏ Y {y y':Y} (e : y = y'), interval_map e left = y. reflexivity. Qed. Goal ∏ Y {y y':Y} (e : y = y'), interval_map e right = y'. reflexivity. Qed. (** ** An easy proof of functional extensionality for sections using the interval, which is derived from formal properlties of propositional truncation, but notice that propositional truncation uses functional extensionality for functions, already. *) Definition funextsec2 X (Y:X->Type) (f g:∏ x,Y x) : (∏ x, f x = g x) -> f = g. Proof. intros e. exact (maponpaths (λ h x, interval_map (e x) h) interval_path). Defined. UniMath-20231010/UniMath/MoreFoundations/MoreEquivalences.v000066400000000000000000000155371451125700300234410ustar00rootroot00000000000000(** * Equivalences *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Equivalences. Definition weq_to_InverseEquivalence X Y : X ≃ Y -> Equivalence Y X. intros [f r]. unfold isweq in r. set (g := λ y, hfiberpr1 f y (pr1 (r y))). set (p := λ y, pr2 (pr1 (r y))). simpl in p. set (L := λ x, pr2 (r (f x)) (make_hfiber f x (idpath (f x)))). set (q := λ x, maponpaths pr1 (L x)). set (q' := λ x, !q x). refine (makeEquivalence Y X g f q' p _). intro y. admit. Abort. Definition Equivalence_to_invweq X Y : Equivalence X Y -> Y ≃ X. Proof. intros [f [g [p [q h]]]]. exists g. unfold isweq. intro x. exists (f x,,q x). intros [y []]. apply (two_arg_paths_f (!p y)). admit. Abort. Definition weq_pathscomp0r {X} x {y z:X} (p:y = z) : (x = y) ≃ (x = z). Proof. intros. exact (make_weq _ (isweqpathscomp0r _ p)). Defined. Definition iscontrretract_compute {X Y} (p:X->Y) (s:Y->X) (eps:∏ y : Y, p (s y) = y) (is:iscontr X) : iscontrpr1 (iscontrretract p s eps is) = p (iscontrpr1 is). Proof. intros. unfold iscontrretract. destruct is as [ctr uni]. simpl. reflexivity. Defined. Definition iscontrweqb_compute {X Y} (w:X ≃ Y) (is:iscontr Y) : iscontrpr1 (iscontrweqb w is) = invmap w (iscontrpr1 is). Proof. intros. unfold iscontrweqb. rewrite iscontrretract_compute. reflexivity. Defined. Definition compute_iscontrweqb_weqfibtototal_1 {T} {P Q:T->Type} (f:∏ t, (P t) ≃ (Q t)) (is:iscontr (total2 Q)) : pr1 (iscontrpr1 (iscontrweqb (weqfibtototal P Q f) is)) = pr1 (iscontrpr1 is). Proof. intros. destruct is as [ctr uni]. reflexivity. Defined. Definition compute_pr1_invmap_weqfibtototal {T} {P Q:T->Type} (f:∏ t, (P t) ≃ (Q t)) (w:total2 Q) : pr1 (invmap (weqfibtototal P Q f) w) = pr1 w. Proof. intros. reflexivity. Defined. Definition compute_pr2_invmap_weqfibtototal {T} {P Q:T->Type} (f:∏ t, (P t) ≃ (Q t)) (w:total2 Q) : pr2 (invmap (weqfibtototal P Q f) w) = invmap (f (pr1 w)) (pr2 w). Proof. intros. reflexivity. Defined. Definition compute_iscontrweqb_weqfibtototal_3 {T} {P Q:T->Type} (f:∏ t, (P t) ≃ (Q t)) (is:iscontr (total2 Q)) : maponpaths pr1 (iscontrweqb_compute (weqfibtototal P Q f) is) = compute_iscontrweqb_weqfibtototal_1 f is. Proof. intros. destruct is as [ctr uni]. reflexivity. Defined. Definition iscontrcoconustot_comp {X} {x:X} : iscontrpr1 (iscontrcoconustot X x) = x,,idpath x. Proof. reflexivity. Defined. Definition funfibtototal {X} (P Q:X->Type) (f:∏ x:X, P x -> Q x) : total2 P -> total2 Q. Proof. intros [x p]. exact (x,,f x p). Defined. Definition weqfibtototal_comp {X} (P Q:X->Type) (f:∏ x:X, (P x) ≃ (Q x)) : invmap (weqfibtototal P Q f) = funfibtototal Q P (λ x, invmap (f x)). Proof. intros. apply funextsec; intros [x q]. reflexivity. Defined. Definition eqweqmapap_inv {T} (P:T->Type) {t u:T} (e:t = u) (p:P u) : (eqweqmap (maponpaths P e)) ((eqweqmap (maponpaths P (!e))) p) = p. Proof. intros. destruct e. reflexivity. Defined. Definition eqweqmapap_inv' {T} (P:T->Type) {t u:T} (e:t = u) (p:P t) : (eqweqmap (maponpaths P (!e))) ((eqweqmap (maponpaths P e)) p) = p. Proof. intros. destruct e. reflexivity. Defined. Definition weqpr1_irr_sec {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) : weq (total2 P) X. (* compare with weqpr1 *) Proof. intros. set (isc := λ x, iscontraprop1 (invproofirrelevance _ (irr x)) (sec x)). apply Equivalence_to_weq. simple refine (makeEquivalence _ _ _ _ _ _ _). { exact pr1. } { intro x. exact (x,,sec x). } { intro x. reflexivity. } { intros [x p]. simpl. apply maponpaths. apply irr. } { intros [x p]. simpl. apply pair_path_in2_comp1. } Defined. Definition invweqpr1_irr_sec {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) : X ≃ (total2 P). (* compare with weqpr1 *) Proof. intros. set (isc := λ x, iscontraprop1 (invproofirrelevance _ (irr x)) (sec x)). apply Equivalence_to_weq. simple refine (makeEquivalence _ _ _ _ _ _ _). { intro x. exact (x,,sec x). } { exact pr1. } { intros [x p]. simpl. apply maponpaths. apply irr. } { intro x. reflexivity. } { intro x'. simpl. rewrite (irrel_paths (irr _) (irr _ _ _) (idpath (sec x'))). reflexivity. } Defined. Definition homotinvweqweq' {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (s:∏ x, P x) (w:total2 P) : invmap (weqpr1_irr_sec irr s) (weqpr1_irr_sec irr s w) = w. Proof. revert w; intros [x p]. apply pair_path_in2. apply irr. Defined. Definition homotinvweqweq'_comp {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) (x:X) (p:P x) : let f := weqpr1_irr_sec irr sec in let w := x,,p in let w' := invweq f x in @paths (w' = w) (homotinvweqweq' irr sec w) (maponpaths _ (irr x (sec x) (pr2 w))). Proof. reflexivity. (* don't change the proof *) Defined. Definition homotinvweqweq_comp {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) (x:X) (p:P x) : let f := weqpr1_irr_sec irr sec in let w := x,,p in let w' := invweq f x in @paths (w' = w) (homotinvweqweq f w) (maponpaths _ (irr x (sec x) (pr2 w))). Proof. try reflexivity. (* this worked above but doesn't work here *) Abort. Definition homotinvweqweq_comp_3 {X} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) (x:X) (p:P x) : let f := weqpr1_irr_sec irr sec in let g := invweqpr1_irr_sec irr sec in let w := x,,p in let w' := g x in @paths (w' = w) (homotweqinvweq g w) (* !! *) (maponpaths _ (irr x (sec x) (pr2 w))). Proof. reflexivity. Defined. Definition loop_correspondence {T X Y} (f:T ≃ X) (g:T->Y) {t t':T} {l:t = t'} {m:f t = f t'} (mi:maponpaths f l = m) {n:g t = g t'} (ni:maponpaths g l = n) : maponpaths (funcomp (invmap f) g) m @ maponpaths g (homotinvweqweq f t') = maponpaths g (homotinvweqweq f t) @ n. Proof. intros. destruct ni, mi, l. simpl. rewrite pathscomp0rid. reflexivity. Defined. Definition loop_correspondence' {X Y} {P:X->Type} (irr:∏ x (p q:P x), p = q) (sec:∏ x, P x) (g:total2 P->Y) {w w':total2 P} {l:w = w'} {m:weqpr1_irr_sec irr sec w = weqpr1_irr_sec irr sec w'} (mi:maponpaths (weqpr1_irr_sec irr sec) l = m) {n:g w = g w'} (ni:maponpaths g l = n) : maponpaths (funcomp (invmap (weqpr1_irr_sec irr sec)) g) m @ maponpaths g (homotinvweqweq' irr sec w') = maponpaths g (homotinvweqweq' irr sec w) @ n. Proof. intros. destruct ni, mi, l. simpl. rewrite pathscomp0rid. reflexivity. Defined. (* Local Variables: compile-command: "make -C ../.. TAGS TAGS-Ktheory UniMath/Ktheory/Equivalences.vo" End: *) UniMath-20231010/UniMath/MoreFoundations/Nat.v000066400000000000000000000357101451125700300207070ustar00rootroot00000000000000(* -*- coding: utf-8 *) (** * Natural numbers *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. Local Open Scope nat. Definition ℕ := nat. Module Uniqueness. Lemma helper_A (P:nat->Type) (p0:P 0) (IH:∏ n, P n->P(S n)) (f:∏ n, P n) : weq (∏ n, f n = nat_rect P p0 IH n) (f 0=p0 × ∏ n, f(S n)=IH n (f n)). Proof. intros. simple refine (_,,isweq_iso _ _ _ _). { intros h. split. { exact (h 0). } { intros. exact (h (S n) @ maponpaths (IH n) (! h n)). } } { intros [h0 h'] ?. induction n as [|n' IHn']. { exact h0. } { exact (h' n' @ maponpaths (IH n') IHn'). } } { simpl. intros h. apply funextsec; intros n; simpl. induction n as [|n IHn]. { simpl. reflexivity. } { simpl. rewrite <- path_assoc. simple refine (_ @ pathscomp0rid _). rewrite <- maponpathscomp0. rewrite IHn. rewrite pathsinv0l. simpl. reflexivity. } } { intros [h0 h']. apply maponpaths. apply funextsec; intro n; simpl. rewrite <- path_assoc. rewrite <- maponpathscomp0. rewrite pathsinv0r. apply pathscomp0rid. } Defined. Lemma helper_B (P:nat->Type) (p0:P 0) (IH:∏ n, P n->P(S n)) (f:∏ n, P n) : weq (f = nat_rect P p0 IH) ((f 0=p0) × (∏ n, f(S n)=IH n (f n))). Proof. intros. exact (weqcomp (weqtoforallpaths _ _ _) (helper_A _ _ _ _)). Defined. Lemma helper_C (P:nat->Type) (p0:P 0) (IH:∏ n, P n->P(S n)) : (∑ f:∏ n, P n, f = nat_rect P p0 IH) ≃ (∑ f:∏ n, P n, f 0=p0 × ∏ n, f(S n)=IH n (f n)). Proof. intros. apply weqfibtototal. intros f. apply helper_B. Defined. Lemma hNatRecursionUniq (P:nat->Type) (p0:P 0) (IH:∏ n, P n->P(S n)) : ∃! (f:∏ n, P n), f 0=p0 × ∏ n, f(S n) = IH n (f n). Proof. intros. exact (iscontrweqf (helper_C _ _ _) (iscontrcoconustot _ _)). Defined. Lemma helper_D (P:nat->Type) (p0:P 0) (IH:∏ n, P n->P(S n)) : (∑ f:∏ n, P n, (f 0=p0) × (∏ n, f(S n)=IH n (f n))) ≃ (@hfiber (∑ (f:∏ n, P n), ∏ n, f(S n)=IH n (f n)) (P 0) (λ fh, pr1 fh 0) p0). Proof. intros. simple refine (make_weq _ (isweq_iso _ _ _ _)). { intros [f [h0 h']]. exact ((f,,h'),,h0). } { intros [[f h'] h0]. exact (f,,(h0,,h')). } { intros [f [h0 h']]. reflexivity. } { intros [[f h'] h0]. reflexivity. } Defined. Lemma hNatRecursion_weq (P:nat->Type) (IH:∏ n, P n->P(S n)) : weq (total2 (fun f:∏ n, P n => ∏ n, f(S n)=IH n (f n))) (P 0). Proof. intros. exists (λ f, pr1 f 0). intro p0. apply (iscontrweqf (helper_D _ _ _)). apply hNatRecursionUniq. Defined. End Uniqueness. Fixpoint nat_dist (m n:nat) : nat := match m , n with | S m, S n => nat_dist m n | 0, n => n | m, 0 => m end. Module Discern. Fixpoint nat_discern (m n:nat) : UU := match m , n with | S m, S n => nat_discern m n | 0, S n => empty | S m, 0 => empty | 0, 0 => unit end. Goal ∏ m n, nat_discern m n -> nat_discern (S m) (S n). Proof. intros ? ? e. exact e. Defined. Lemma nat_discern_inj m n : nat_discern (S m) (S n) -> nat_discern m n. Proof. intros e. induction m. { induction n. { exact tt. } { simpl in e. exact (fromempty e). } } { induction n. { simpl in e. exact (fromempty e). } { simpl in e. exact e. } } Defined. Lemma nat_discern_isaprop m n : isaprop (nat_discern m n). Proof. revert n; induction m as [|m IHm]. { intros n. induction n as [|n IHn]. { apply isapropifcontr. apply iscontrunit. } { simpl. apply isapropempty. } } { intros n. induction n as [|n IHn]. { simpl. apply isapropempty. } { simpl. apply IHm. } } Defined. Lemma nat_discern_unit m : nat_discern m m = unit. Proof. induction m as [|m IHm]. { reflexivity. } { simpl. apply IHm. } Defined. Lemma nat_discern_iscontr m : iscontr (nat_discern m m). Proof. apply iscontraprop1. { apply nat_discern_isaprop. } { induction m as [|m IHm]. { exact tt. } { simpl. exact IHm. } } Defined. Fixpoint helper_A m n : nat_dist m n = 0 -> nat_discern m n. Proof. destruct m as [|m']. { destruct n as [|n']. { intros _. exact tt. } { simpl. exact (negpathssx0 n'). } } { destruct n as [|n']. { simpl. exact (negpathssx0 m'). } { simpl. exact (helper_A m' n'). } } Defined. Fixpoint helper_B m n : nat_discern m n -> m = n. Proof. destruct m as [|m']. { destruct n as [|n']. { intros _. reflexivity. } { simpl. exact fromempty. } } { destruct n as [|n']. { simpl. exact fromempty. } { simpl. intro i. assert(b := helper_B _ _ i); clear i. destruct b. reflexivity. } } Defined. Goal ∏ m n (e:nat_discern m n), maponpaths S (helper_B m n e) = helper_B (S m) (S n) e. Proof. reflexivity. Defined. Fixpoint helper_C m n : m = n -> nat_discern m n. Proof. intros e. destruct e. (* alternatively: destruct m. { exact tt. } { simpl. exact (the (nat_discern_iscontr _)). } *) exact (cast (! nat_discern_unit m) tt). Defined. Lemma apSC m n (e:m=n) : helper_C m n e = helper_C (S m) (S n) (maponpaths S e). Proof. intros. apply proofirrelevance. apply nat_discern_isaprop. Defined. Definition helper_D m n : isweq (helper_B m n). Proof. intros. simple refine (isweq_iso _ (helper_C _ _) _ _). { intro e. assert(p := ! helper_B _ _ e). destruct p. apply proofirrelevancecontr. apply nat_discern_iscontr. } { intro e. destruct e. induction m as [|m IHm]. { reflexivity. } { exact ( maponpaths (helper_B (S m) (S m)) (! apSC _ _ (idpath m)) @ maponpaths (maponpaths S) IHm). } } Defined. Definition E m n : (nat_discern m n) ≃ (m = n). Proof. intros. exact (make_weq (helper_B _ _) (helper_D _ _)). Defined. Definition nat_dist_anti m n : nat_dist m n = 0 -> m = n. Proof. intros i. exact (helper_B _ _ (helper_A _ _ i)). Defined. End Discern. Fixpoint nat_dist_symm m n : nat_dist m n = nat_dist n m. Proof. destruct m as [|m']. { destruct n as [|n']. { reflexivity. } { simpl. reflexivity. } } { destruct n as [|n']. { simpl. reflexivity. } { simpl. apply nat_dist_symm. } } Defined. Fixpoint nat_dist_ge m n : m ≥ n -> nat_dist m n = m-n. Proof. induction m as [|m']. { induction n as [|n']. { reflexivity. } { intro f. now induction (!natleh0tois0 f). } } { induction n as [|n']. { reflexivity. } { exact (nat_dist_ge m' n'). } } Defined. Definition nat_dist_0m m : nat_dist 0 m = m. Proof. reflexivity. Defined. Definition nat_dist_m0 m : nat_dist m 0 = m. Proof. destruct m. { reflexivity. } { reflexivity. } Defined. Fixpoint nat_dist_plus m n : nat_dist (m + n) m = n. Proof. revert m n; intros [|m'] ?. { simpl. apply nat_dist_m0. } { simpl. apply nat_dist_plus. } Defined. Fixpoint nat_dist_le m n : m ≤ n -> nat_dist m n = n-m. Proof. destruct m as [|m']. { destruct n as [|n']. { reflexivity. } { simpl. intros _. reflexivity. } } { destruct n as [|n']. { intro f. now induction (!natleh0tois0 f). } { exact (nat_dist_le m' n'). } } Defined. Definition nat_dist_minus m n : m ≤ n -> nat_dist (n - m) n = m. Proof. intros e. set (k := n-m). assert(b := ! minusplusnmm n m e). rewrite (idpath _ : n-m = k) in b. rewrite b. rewrite nat_dist_symm. apply nat_dist_plus. Qed. Fixpoint nat_dist_gt m n : m > n -> S (nat_dist m (S n)) = nat_dist m n. Proof. destruct m as [|m']. { unfold natgth; simpl. intro x. apply fromempty. apply nopathsfalsetotrue. exact x. } { intro i. simpl. destruct n as [|n']. { apply (maponpaths S). apply nat_dist_m0. } { simpl. apply nat_dist_gt. exact i. } } Defined. Definition nat_dist_S m n : nat_dist (S m) (S n) = nat_dist m n. Proof. reflexivity. Defined. Definition natminuseqlr m n x : m≤n -> n-m = x -> n = x+m. Proof. intros i j. rewrite <- (minusplusnmm _ _ i). rewrite j. reflexivity. Defined. Definition nat_dist_between_le m n a b : m ≤ n -> nat_dist m n = a + b -> ∑ x, nat_dist x m = a × nat_dist x n = b. Proof. intros i j. exists (m+a). split. { apply nat_dist_plus. } { rewrite (nat_dist_le m n i) in j. assert (k := natminuseqlr _ _ _ i j); clear j. assert (l := nat_dist_plus (m+a) b). rewrite nat_dist_symm. rewrite (natpluscomm (a+b) m) in k. rewrite (natplusassoc m a b) in l. rewrite <- k in l. exact l. } Defined. Definition nat_dist_between_ge m n a b : n ≤ m -> nat_dist m n = a + b -> ∑ x:nat, nat_dist x m = a × nat_dist x n = b. Proof. intros i j. rewrite nat_dist_symm in j. rewrite natpluscomm in j. exists (pr1 (nat_dist_between_le n m b a i j)). apply (weqdirprodcomm _ _). exact (pr2 (nat_dist_between_le n m b a i j)). Defined. Definition nat_dist_between m n a b : nat_dist m n = a + b -> ∑ x:nat, nat_dist x m = a × nat_dist x n = b. Proof. intros j. induction (natgthorleh m n) as [r|s]. { apply nat_dist_between_ge. apply natlthtoleh. exact r. exact j. } { apply nat_dist_between_le. exact s. exact j. } Defined. Definition natleorle m n : (m≤n) ⨿ (n≤m). Proof. intros. induction (natgthorleh m n) as [r|s]. { apply ii2. apply natlthtoleh. exact r. } { apply ii1. exact s. } Defined. Definition nat_dist_trans x y z : nat_dist x z ≤ nat_dist x y + nat_dist y z. Proof. intros. induction (natleorle x y) as [r|s]. { rewrite (nat_dist_le _ _ r). induction (natleorle y z) as [t|u]. { assert (u := istransnatgeh _ _ _ t r). rewrite (nat_dist_le _ _ t). rewrite (nat_dist_le _ _ u). apply (natlehandplusrinv _ _ x). rewrite (minusplusnmm _ _ u). rewrite (natpluscomm _ x). rewrite <- natplusassoc. rewrite (natpluscomm x). rewrite (minusplusnmm _ _ r). rewrite (natpluscomm y). rewrite (minusplusnmm _ _ t). apply isreflnatleh. } { rewrite (nat_dist_ge _ _ u). induction (natleorle x z) as [p|q]. { rewrite (nat_dist_le _ _ p). apply (natlehandplusrinv _ _ x). rewrite (minusplusnmm _ _ p). rewrite natpluscomm. rewrite <- natplusassoc. rewrite (natpluscomm x). rewrite (minusplusnmm _ _ r). apply (natlehandplusrinv _ _ z). rewrite natplusassoc. rewrite (minusplusnmm _ _ u). apply (istransnatleh (m := y+z)). { apply natlehandplusr. exact u. } { apply natlehandplusl. exact u. } } { rewrite (nat_dist_ge _ _ q). apply (natlehandplusrinv _ _ z). rewrite (minusplusnmm _ _ q). rewrite natplusassoc. rewrite (minusplusnmm _ _ u). rewrite natpluscomm. apply (natlehandplusrinv _ _ x). rewrite natplusassoc. rewrite (minusplusnmm _ _ r). apply (istransnatleh (m := x+y)). { apply natlehandplusl. assumption. } { apply natlehandplusr. assumption. } } } } { rewrite (nat_dist_ge _ _ s). induction (natleorle z y) as [u|t]. { assert (w := istransnatleh u s). rewrite (nat_dist_ge _ _ w). rewrite (nat_dist_ge _ _ u). apply (natlehandplusrinv _ _ z). rewrite (minusplusnmm _ _ w). rewrite natplusassoc. rewrite (minusplusnmm _ _ u). rewrite (minusplusnmm _ _ s). apply isreflnatleh. } { rewrite (nat_dist_le _ _ t). induction (natleorle x z) as [p|q]. { rewrite (nat_dist_le _ _ p). apply (natlehandplusrinv _ _ x). rewrite (minusplusnmm _ _ p). apply (natlehandpluslinv _ _ y). rewrite (natplusassoc (x-y)). rewrite <- (natplusassoc y). rewrite (natpluscomm y (x-y)). rewrite (minusplusnmm _ _ s). apply (natlehandplusrinv _ _ y). rewrite (natplusassoc x). rewrite (natplusassoc _ x y). rewrite (natpluscomm x y). rewrite <- (natplusassoc _ y x). rewrite (minusplusnmm _ _ t). rewrite (natpluscomm z x). rewrite <- (natplusassoc x). rewrite (natplusassoc y). rewrite (natpluscomm z y). rewrite <- (natplusassoc y). apply (natlehandplusr _ _ z). apply (istransnatleh (m := x+y)). { apply natlehandplusr. assumption. } { apply natlehandplusl. assumption. } } { rewrite (nat_dist_ge _ _ q). apply (natlehandplusrinv _ _ z). rewrite (minusplusnmm _ _ q). apply (natlehandpluslinv _ _ y). rewrite (natplusassoc (x-y)). rewrite <- (natplusassoc y). rewrite (natpluscomm y (x-y)). rewrite (minusplusnmm _ _ s). apply (natlehandplusrinv _ _ y). rewrite (natplusassoc x). rewrite (natplusassoc _ z y). rewrite (natpluscomm z y). rewrite <- (natplusassoc _ y z). rewrite (minusplusnmm _ _ t). rewrite (natpluscomm y x). rewrite (natplusassoc x). apply natlehandplusl. apply (istransnatleh (m := z+y)). { apply natlehandplusr. assumption. } { apply natlehandplusl. assumption. } } } } Defined. Lemma plusmn0n0 m n : m + n = 0 -> n = 0. Proof. intros i. assert (a := natlehmplusnm m n). rewrite i in a. apply natleh0tois0. assumption. Defined. Lemma plusmn0m0 m n : m + n = 0 -> m = 0. Proof. intros i. assert (a := natlehnplusnm m n). rewrite i in a. apply natleh0tois0. assumption. Defined. Lemma natminus0le {m n} : m-n = 0 -> n ≥ m. Proof. intros i. apply negnatgthtoleh. intro k. assert (r := minusgth0 _ _ k); clear k. induction (!i); clear i. exact (negnatgth0n 0 r). Defined. Lemma minusxx m : m - m = 0. Proof. induction m as [|m IHm]. reflexivity. simpl. assumption. Defined. Lemma minusSxx m : S m - m = 1. Proof. induction m as [|m IHm]. reflexivity. assumption. Defined. Lemma natminusminus n m : m ≤ n -> n - (n - m) = m. Proof. intros i. assert (b := plusminusnmm m (n-m)). rewrite natpluscomm in b. rewrite (minusplusnmm _ _ i) in b. exact b. Defined. Lemma natplusminus m n k : k=m+n -> k-n=m. Proof. intros i. rewrite i. apply plusminusnmm. Defined. Lemma natleplusminus k m n : k + m ≤ n -> k ≤ n - m. Proof. intros i. apply (natlehandplusrinv _ _ m). rewrite minusplusnmm. { exact i. } { change (m ≤ n). simple refine (istransnatleh _ i); clear i. apply natlehmplusnm. } Defined. Lemma natltminus1 m n : m < n -> m ≤ n - 1. Proof. intros i. assert (a := natlthp1toleh m (n - 1)). assert (b := natleh0n m). assert (c := natlehlthtrans _ _ _ b i). assert (d := natlthtolehsn _ _ c). assert (e := minusplusnmm _ _ d). rewrite e in a. exact (a i). Defined. Fixpoint natminusminusassoc m n k : (m-n)-k = m-(n+k). Proof. intros. destruct m. { reflexivity. } { destruct n. { rewrite natminuseqn. reflexivity. } { simpl. apply natminusminusassoc. } } Defined. Definition natminusplusltcomm m n k : k ≤ n -> m ≤ n - k -> k ≤ n - m. Proof. intros i p. assert (a := natlehandplusr m (n-k) k p); clear p. assert (b := minusplusnmm n k i); clear i. rewrite b in a; clear b. apply natleplusminus. rewrite natpluscomm. exact a. Qed. Theorem nat_le_diff {n m : ℕ} (p : n ≤ m) : ∑ (k : ℕ), n + k = m. Proof. exists (m - n). rewrite natpluscomm. exact (minusplusnmm _ _ p). Qed. (* Local Variables: compile-command: "make -C ../.. TAGS UniMath/Ktheory/Nat.vo" End: *) UniMath-20231010/UniMath/MoreFoundations/NegativePropositions.v000066400000000000000000000305301451125700300243530ustar00rootroot00000000000000Require Export UniMath.Foundations.All. (** *** Propositions equivalent to negations of propositions *) Definition negProp P := ∑ Q, isaprop Q × (¬P <-> Q). Definition negProp_to_isaprop {P} (nP : negProp P) : isaprop (pr1 nP) := pr1 (pr2 nP). Definition negProp_to_hProp {P : UU} (Q : negProp P) : hProp. Proof. intros. exists (pr1 Q). apply negProp_to_isaprop. Defined. Coercion negProp_to_hProp : negProp >-> hProp. Definition negProp_to_iff {P} (nP : negProp P) : ¬P <-> nP := pr2 (pr2 nP). Definition negProp_to_neg {P} {nP : negProp P} : nP -> ¬P. Proof. intros np. exact (pr2 (negProp_to_iff nP) np). Defined. Coercion negProp_to_neg : negProp >-> Funclass. Definition neg_to_negProp {P} {nP : negProp P} : ¬P -> nP. Proof. intros np. exact (pr1 (negProp_to_iff nP) np). Defined. Definition negPred {X:UU} (x :X) (P:∏ y:X, UU) := ∏ y , negProp (P y). Definition negReln {X:UU} (P:∏ (x y:X), UU) := ∏ x y, negProp (P x y). Definition neqProp {X:UU} (x y:X) := negProp (x=y). Definition neqPred {X:UU} (x :X) := ∏ y, negProp (x=y). Definition neqReln (X:UU) := ∏ (x y:X), negProp (x=y). Lemma negProp_to_complementary P : ∏ (Q : negProp P), P ⨿ Q <-> complementary P Q. Proof. intros [Q [i [r s]]]; simpl in *. split. * intros pq. split. - intros p q. apply s. + assumption. + assumption. - assumption. * intros [j c]. assumption. Defined. Lemma negProp_to_uniqueChoice P : ∏ (Q:negProp P), (isaprop P × (P ⨿ Q)) <-> iscontr (P ⨿ Q). Proof. intros [Q [j [r s]]]; simpl in *. split. * intros [i v]. exists v. intro w. induction v as [v|v]. - induction w as [w|w]. + apply maponpaths, i. + contradicts (s w) v. - induction w as [w|w]. + contradicts (s v) w. + apply maponpaths, j. * intros [c e]. split. - induction c as [c|c]. + apply invproofirrelevance; intros p p'. exact (equality_by_case (e (ii1 p) @ !e (ii1 p'))). + apply invproofirrelevance; intros p p'. contradicts (s c) p. - exact c. Defined. (** Rework some foundational material using negative propositions. *) Definition isisolated_ne (X:UU) (x:X) (neq_x:neqPred x) := ∏ y:X, (x=y) ⨿ neq_x y. Definition isisolated_to_isisolated_ne {X x neq_x} : isisolated X x -> isisolated_ne X x neq_x. Proof. intros i y. induction (i y) as [eq|ne]. - exact (ii1 eq). - apply ii2. apply neg_to_negProp. assumption. Defined. Definition isisolated_ne_to_isisolated {X x neq_x} : isisolated_ne X x neq_x -> isisolated X x. Proof. intros i y. induction (i y) as [eq|ne]. - exact (ii1 eq). - apply ii2. use negProp_to_neg. + exact (neq_x y). + exact ne. Defined. Definition isolated_ne ( T : UU ) (neq:neqReln T) := ∑ t:T, isisolated_ne _ t (neq t). Definition make_isolated_ne (T : UU) (t:T) (neq:neqReln T) (i:isisolated_ne _ t (neq t)) : isolated_ne T neq := (t,,i). Definition pr1isolated_ne ( T : UU ) (neq:neqReln T) (x:isolated_ne T neq) : T := pr1 x. Theorem isaproppathsfromisolated_ne (X : UU) (x : X) (neq_x : neqPred x) (is : isisolated_ne X x neq_x) (y : X) : isaprop (x = y). Proof. (* we could follow the proof of isaproppathsfromisolated here, but we try a different way *) intros. unfold isisolated_ne in is. apply invproofirrelevance; intros m n. set (Q y := (x = y) ⨿ (neq_x y)). assert (a := (transport_section is m) @ !(transport_section is n)). induction (is x) as [j|k]. - assert (b := transport_map (λ y p, ii1 p : Q y) m j); simpl in b; assert (c := transport_map (λ y p, ii1 p : Q y) n j); simpl in c. assert (d := equality_by_case (!b @ a @ c)); simpl in d. rewrite 2? transportf_id1 in d. apply (pathscomp_cancel_left j). assumption. - contradicts (neq_x x k) (idpath x). Defined. Definition compl_ne (X:UU) (x:X) (neq_x : neqPred x) := ∑ y, neq_x y. Definition make_compl_ne (X : UU) (x : X) (neq_x : neqPred x) (y : X) (ne :neq_x y) : compl_ne X x neq_x := (y,,ne). Definition pr1compl_ne (X : UU) (x : X) (neq_x : neqPred x) (c : compl_ne X x neq_x) : X := pr1 c. Definition make_negProp {P : UU} : negProp P. Proof. intros. exists (¬ P). split. - apply isapropneg. (* uses [funextemptyAxiom] *) - apply isrefl_logeq. Defined. Definition make_neqProp {X : UU} (x y : X) : neqProp x y. Proof. intros. apply make_negProp. Defined. Lemma isinclpr1compl_ne (X : UU) (x : X) (neq_x : neqPred x) : isincl (pr1compl_ne X x neq_x). Proof. intros. apply isinclpr1. intro y. apply negProp_to_isaprop. Defined. Lemma compl_ne_weq_compl (X : UU) (x : X) (neq_x : neqPred x) : compl X x ≃ compl_ne X x neq_x. Proof. (* uses [funextemptyAxiom] *) intros. apply weqfibtototal; intro y. apply weqiff. - apply negProp_to_iff. - apply isapropneg. - apply negProp_to_isaprop. Defined. Lemma compl_weq_compl_ne (X : UU) (x : X) (neq_x : neqPred x) : compl_ne X x neq_x ≃ compl X x. Proof. (* uses [funextemptyAxiom] *) intros. apply weqfibtototal; intro y. apply weqiff. - apply issymm_logeq. apply negProp_to_iff. - apply negProp_to_isaprop. - apply isapropneg. Defined. Definition recompl_ne (X : UU) (x : X) (neq_x:neqPred x) : compl_ne X x neq_x ⨿ unit -> X. Proof. intros w. induction w as [c|t]. - exact (pr1compl_ne _ _ _ c). - exact x. Defined. Definition maponcomplincl_ne {X Y : UU} (f : X -> Y) (is : isincl f) (x : X) (neq_x : neqPred x) (neq_fx : neqPred (f x)) : compl_ne X x neq_x -> compl_ne Y (f x) neq_fx. Proof. intros c. set (x' := pr1 c). set (neqx := pr2 c). exact (f x',,neg_to_negProp (nP := neq_fx (f x')) (negf (invmaponpathsincl _ is x x') (negProp_to_neg neqx))). Defined. Definition weqoncompl_ne {X Y : UU} (w : X ≃ Y) (x : X) (neq_x : neqPred x) (neq_wx : neqPred (w x)) : compl_ne X x neq_x ≃ compl_ne Y (w x) neq_wx. Proof. intros. intermediate_weq (∑ x', neq_wx (w x')). - apply weqfibtototal; intro x'. apply weqiff. {apply (logeq_trans (Y := x != x')). {apply issymm_logeq, negProp_to_iff. } apply (logeq_trans (Y := w x != w x')). {apply logeqnegs. apply weq_to_iff. apply weqonpaths. } apply negProp_to_iff. } {apply negProp_to_isaprop. } {apply negProp_to_isaprop. } - refine (weqfp _ _). Defined. Definition weqoncompl_ne_compute {X Y : UU} (w : X ≃ Y) (x : X) (neq_x : neqPred x) (neq_wx : neqPred (w x)) x' : pr1 (weqoncompl_ne w x neq_x neq_wx x') = w (pr1 x'). Proof. intros. apply idpath. Defined. Definition invrecompl_ne (X : UU) (x : X) (neq_x : neqPred x) (is : isisolated X x) : X -> compl_ne X x neq_x ⨿ unit. Proof. intros y. induction (is y) as [k|k]. - exact (ii2 tt). - exact (ii1 (make_compl_ne X x neq_x y (neg_to_negProp k))). Defined. Theorem isweqrecompl_ne (X : UU) (x : X) (is : isisolated X x) (neq_x : neqPred x) : isweq (recompl_ne _ x neq_x). Proof. (* does not use [funextemptyAxiom] *) intros. set (f := recompl_ne X x neq_x). set (g := invrecompl_ne X x neq_x is). refine (isweq_iso f g _ _). {intro u. induction (is (f u)) as [ eq | ne ]. - induction u as [ c | u]. + simpl. induction c as [ t neq ]; simpl; simpl in eq. contradicts (negProp_to_neg neq) eq. + induction u. intermediate_path (g x). {apply maponpaths. exact (pathsinv0 eq). } {unfold g, invrecompl_ne. induction (is x) as [ i | e ]. {apply idpath. } {simpl. contradicts e (idpath x). }} - induction u as [ c | u ]. simpl. + induction c as [ y neq ]; simpl. unfold g, invrecompl_ne. induction (is y) as [ eq' | ne' ]. {contradicts (negProp_to_neg neq) eq'. } {induction (ii2 ne') as [eq|neq']. {simpl. contradicts eq ne'. } {simpl. apply maponpaths. unfold make_compl_ne. apply maponpaths. apply proofirrelevance. exact (pr1 (pr2 (neq_x y))). }} + induction u. unfold f,g,invrecompl_ne;simpl. induction (is x) as [eq|neq]. {simpl. apply idpath. } {apply fromempty. apply neq. apply idpath. }} {intro y. unfold f,g,invrecompl_ne;simpl. induction (is y) as [eq|neq]. - induction eq. apply idpath. - simpl. apply idpath. } Defined. Theorem isweqrecompl_ne' (X : UU) (x : X) (is : isisolated X x) (neq_x : neqPred x) : isweq (recompl_ne _ x neq_x). Proof. (* an alternative proof *) intros. set (f := recompl_ne X x neq_x). intro y. unfold neqPred,negProp in neq_x; unfold isisolated in is. apply (iscontrweqb (weqtotal2overcoprod _)). induction (is y) as [eq|ne]. {induction eq. refine (iscontrweqf (weqii2withneg _ _) _). {intros z; induction z as [z e]; induction z as [z neq]; simpl in *. contradicts (!e) (negProp_to_neg neq). } {change x with (f (ii2 tt)). simple refine ((_,,_),,_). {exact tt. } {apply idpath. } {intro w. induction w as [t e]. unfold f in *; simpl in *. induction t. apply maponpaths. apply isaproppathsfromisolated. exact is. }}} {refine (iscontrweqf (weqii1withneg _ _) _). {intros z; induction z as [z e]; simpl in *. contradicts ne e. } {simple refine ((_,,_),,_). {exists y. apply neg_to_negProp. assumption. } {simpl. apply idpath. } intros z; induction z as [z e]; induction z as [z neq]; induction e; simpl in *. induction (proofirrelevance _ (pr1 (pr2 (neq_x z))) neq (neg_to_negProp ne)). apply idpath. }} Defined. Definition weqrecompl_ne (X : UU) (x : X) (is : isisolated X x) (neq_x : neqPred x) : compl_ne X x neq_x ⨿ unit ≃ X := make_weq _ (isweqrecompl_ne X x is neq_x). Theorem isweqrecompl' (X : UU) (x : X) (is : isisolated X x) : isweq (recompl _ x). Proof. (* alternative proof, spoils a computation if used in [weqrecompl], so unused *) intros. set (neq_x := λ y, make_neqProp x y). apply (isweqhomot (weqrecompl_ne X x is neq_x ∘ weqcoprodf (compl_ne_weq_compl X x neq_x) (idweq unit))%weq). {intro y. induction y as [y|t]; apply idpath. } apply weqproperty. Defined. Lemma iscotrans_to_istrans_negReln {X : UU} {R : hrel X} (NR : negReln R) : isdeccotrans R -> istrans NR. (* uses no axioms; compare to istransnegrel *) Proof. intros i ? ? ? nxy nyz. apply neg_to_negProp. apply (negf (i x1 x2 x3)). intro c. induction c as [c|c]. - exact (negProp_to_neg nxy c). - exact (negProp_to_neg nyz c). Defined. Definition natneq (m n : nat) : negProp (m = n). Proof. intros. exists (m ≠ n). split. - apply propproperty. - apply natneq_iff_neq. Defined. (* this replaces an earlier notation: *) Notation " x ≠ y " := (natneq x y) (at level 70, no associativity) : nat_scope. Definition nat_compl (i : nat) := compl_ne _ i (λ j, i ≠ j). Theorem weqdicompl (i : nat) : nat ≃ nat_compl i. Proof. use weq_iso. - intro j. exists (di i j). apply di_neq_i. - intro j. exact (si i (pr1 j)). - simpl. intro j. unfold di. induction (natlthorgeh j i) as [lt|ge]. + unfold si. induction (natlthorgeh i j) as [lt'|ge']. * contradicts (isasymmnatlth _ _ lt') lt. * apply idpath. + unfold si. induction (natlthorgeh i (S j)) as [lt'|ge']. * change (S j) with (1 + j). rewrite natpluscomm. apply plusminusnmm. * unfold natgeh,natleh in ge. contradicts (natlehneggth ge') ge. - simpl. intro j. induction j as [j ne]; simpl. apply subtypePath. + intro k. apply negProp_to_isaprop. + simpl. unfold si. induction (natlthorgeh j i) as [lt|ge]. * clear ne. induction (natlthorgeh i j) as [lt'|_]. { contradicts (isasymmnatlth _ _ lt') lt. } { unfold di. induction (natlthorgeh j i) as [lt'|ge']. - apply idpath. - contradicts (natgehtonegnatlth _ _ ge') lt. } * assert (lt := natleh_neq ge ne); clear ne ge. induction (natlthorgeh i j) as [_|ge']. { unfold di. induction (natlthorgeh (j - 1) i) as [lt'|ge']. - apply fromempty. induction j as [|j _]. + exact (negnatlthn0 _ lt). + change (S j) with (1 + j) in lt'. rewrite natpluscomm in lt'. rewrite plusminusnmm in lt'. change (i < S j) with (i ≤ j) in lt. exact (natlehneggth lt lt'). - induction j as [|j _]. + contradicts (negnatlthn0 i) lt. + simpl. apply maponpaths. apply natminuseqn. } contradicts (natgehtonegnatlth _ _ ge') lt. Defined. UniMath-20231010/UniMath/MoreFoundations/NoInjectivePairing.v000066400000000000000000000065251451125700300237160ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Univalence. (** We prove that the following lemma ("injective pairing") is inconsistent with univalence: *) Definition injective_pairing_statement := ∏ A (B : A → UU) a (b b' : B a), a ,, b = a ,, b' → b = b'. (** Proof sketch by Folkmar Frederik Ramcke. Formalisation by Jannis Limperg with help from Joj Helfer. *) (** * Preliminaries *) Lemma univalence_pathsinv0 {A B : UU} (p : A = B) : univalence _ _ (!p) = invweq (univalence _ _ p). Proof. apply eqweqmap_pathsinv0. Defined. (** Inverting the path obtained from an equivalence is the same as inverting the equivalence. *) Lemma pathsinv0_weqtopaths {A B : UU} (eq : A ≃ B) : ! (weqtopaths eq) = weqtopaths (invweq eq). Proof. type_induction eq e. symmetry. refine (maponpaths _ (! univalence_pathsinv0 e) @ _). refine (homotinvweqweq _ _ @ _). refine (maponpaths _ (! homotinvweqweq _ _)). Defined. (** * Refutation of Injective Pairing *) (** Boolean negation is a weak equivalence. *) Definition negb_weq : bool ≃ bool. Proof. exists negb. cbv. intros. use tpair. - use tpair. + exact (negb y). + induction y; apply idpath. - cbn. intro t. induction t as [b eq]. induction b; induction eq; apply idpath. Defined. (** Thus, we can construct two equal pairs whose second components are different: *) Definition negb_weq_pair : @paths (∑ A : UU, A → bool) (bool ,, idfun bool) (bool ,, negb). Proof. refine ( total2_paths_f (B := λ A, A → bool) (s := bool ,, idfun bool) (s' := bool ,, negb) (weqtopaths negb_weq) _ ). refine (transportf_fun (idfun UU) (weqtopaths negb_weq) (idfun (idfun UU bool)) @ _). change (transportb (idfun UU) (weqtopaths negb_weq) = negb). refine (maponpaths _ (pathsinv0_weqtopaths _ ) @ _). apply weqpath_transport. Defined. (** By injective pairing, we get [idfun bool = negb], a contradiction. *) Theorem no_injective_pairing : injective_pairing_statement -> ∅. Proof. intro contra. specialize (contra _ _ _ _ _ negb_weq_pair). apply toforallpaths in contra. exact (nopathstruetofalse (contra true)). Defined. (** * Injective Pairing <-> Uniqueness of Identity Proofs *) (** Another way to see why injective pairing cannot hold: It is logically equivalent to uniqueness of identity proofs, which is in turn equivalent to the K axiom and incompatible with univalence. *) Definition uip_statement := ∏ A (x y : A) (p q : x = y), p = q. (** Injective pairing implies uniqueness of identity proofs. *) Theorem injective_pairing_uip : injective_pairing_statement → uip_statement. Proof. intros injpair A x y p q. assert (eqpair : @paths (∑ x, x = y) (x ,, p) (x ,, q)). { induction p. induction q. use total2_paths_f; apply idpath. } unfold injective_pairing_statement in injpair. exact (injpair _ (λ x, x = y) x p q eqpair). Defined. (** Uniqueness of identity proofs implies injective pairing. *) Theorem uip_injective_pairing : uip_statement → injective_pairing_statement. Proof. intros uip A B a b b' eqpair. set (eqa := base_paths _ _ eqpair). assert (eqb : transportf _ eqa b = b'). { apply (fiber_paths eqpair). } assert (eqa_idpath : eqa = idpath _). { apply uip. } symmetry. etrans. { exact (! eqb). } exact (maponpaths (λ p, transportf B p b) eqa_idpath). Defined. UniMath-20231010/UniMath/MoreFoundations/Notations.v000066400000000000000000000053111451125700300221350ustar00rootroot00000000000000(** * Notations *) Require Export UniMath.Foundations.All. Notation "A ⇒ B" := (himpl A B) : logic. Definition hequiv (P Q:hProp) : hProp := ((P ⇒ Q) ∧ (Q ⇒ P))%logic. Notation "A ⇔ B" := (hequiv A B) (at level 95, no associativity) : logic. Definition total2_hProp {X : hProp} (Y : X -> hProp) : hProp := make_hProp (∑ x, Y x) (isaprop_total2 X Y). Declare Scope prop. Delimit Scope prop with prop. Notation "'∑' x .. y , P" := (total2_hProp (λ x,.. (total2_hProp (λ y, P))..)) (at level 200, x binder, y binder, right associativity) : prop. (* type this in emacs in agda-input method with \sum *) Notation "'pr11' x" := (pr1 (pr1 x)) (at level 10, left associativity). Notation "'pr12' x" := (pr1 (pr2 x)) (at level 10, left associativity). Notation "'pr21' x" := (pr2 (pr1 x)) (at level 10, left associativity). Notation "'pr22' x" := (pr2 (pr2 x)) (at level 10, left associativity). Notation "'pr111' x" := (pr1 (pr1 (pr1 x))) (at level 10, left associativity). Notation "'pr112' x" := (pr1 (pr1 (pr2 x))) (at level 10, left associativity). Notation "'pr121' x" := (pr1 (pr2 (pr1 x))) (at level 10, left associativity). Notation "'pr122' x" := (pr1 (pr2 (pr2 x))) (at level 10, left associativity). Notation "'pr211' x" := (pr2 (pr1 (pr1 x))) (at level 10, left associativity). Notation "'pr212' x" := (pr2 (pr1 (pr2 x))) (at level 10, left associativity). Notation "'pr221' x" := (pr2 (pr2 (pr1 x))) (at level 10, left associativity). Notation "'pr222' x" := (pr2 (pr2 (pr2 x))) (at level 10, left associativity). (** ** Variants on paths and coconus *) Definition paths_from {X} (x:X) := coconusfromt X x. Definition point_to {X} {x:X} : paths_from x -> X := coconusfromtpr1 _ _. Definition paths_from_path {X} {x:X} (w:paths_from x) := pr2 w. Definition paths' {X} (x:X) := λ y, y = x. Definition idpath' {X} (x:X) := idpath x : paths' x x. Definition paths_to {X} (x:X) := coconustot X x. Definition point_from {X} {x:X} : paths_to x -> X := coconustotpr1 _ _. Definition paths_to_path {X} {x:X} (w:paths_to x) := pr2 w. Lemma iscontr_paths_to {X} (x:X) : iscontr (paths_to x). Proof. apply iscontrcoconustot. Defined. Lemma iscontr_paths_from {X} (x:X) : iscontr (paths_from x). Proof. apply iscontrcoconusfromt. Defined. Definition paths_to_prop {X} (x:X) := make_hProp (paths_to x) (isapropifcontr (iscontr_paths_to x)). Definition paths_from_prop {X} (x:X) := make_hProp (paths_from x) (isapropifcontr (iscontr_paths_from x)). (** ** Squashing *) Notation squash_fun := hinhfun (only parsing). Notation squash_fun2 := hinhfun2 (only parsing). Notation squash_element := hinhpr (only parsing). Lemma squash_path {X} (x y:X) : squash_element x = squash_element y. Proof. intros. apply propproperty. Defined. UniMath-20231010/UniMath/MoreFoundations/NullHomotopies.v000066400000000000000000000045311451125700300231430ustar00rootroot00000000000000(** ** Null homotopies, an aid for proving things about propositional truncation *) Require Export UniMath.Foundations.PartD. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Notations. Local Open Scope transport. Definition nullHomotopyTo {X Y} (f:X->Y) (y:Y) := ∏ x:X, f x = y. Definition NullHomotopyTo {X Y} (f:X->Y) := total2 (nullHomotopyTo f). Definition NullHomotopyTo_center {X Y} (f:X->Y) : NullHomotopyTo f -> Y := pr1. Definition NullHomotopyTo_path {X Y} {f:X->Y} (r:NullHomotopyTo f) := pr2 r. Definition nullHomotopyFrom {X Y} (f:X->Y) (y:Y) := ∏ x:X, y = f x. Definition NullHomotopyFrom {X Y} (f:X->Y) := total2 (nullHomotopyFrom f). Definition NullHomotopyFrom_center {X Y} (f:X->Y) : NullHomotopyFrom f -> Y := pr1. Definition NullHomotopyFrom_path {X Y} {f:X->Y} (r:NullHomotopyFrom f) := pr2 r. Definition nullHomotopyTo_transport {X Y} {f:X->Y} {y:Y} (h : nullHomotopyTo f y) {y':Y} (p:y = y') (x:X) : (p # h) x = h x @ p. Proof. intros. induction p. apply pathsinv0. apply pathscomp0rid. Defined. Lemma isaset_NullHomotopyTo {X Y} (i:isaset Y) (f:X->Y) : isaset (NullHomotopyTo f). Proof. intros. apply (isofhleveltotal2 2). { apply i. } intros y. apply impred; intros x. apply isasetaprop. apply i. Defined. Lemma isaprop_nullHomotopyTo {X Y} (is:isaset Y) (f:X->Y) (y:Y) : isaprop (nullHomotopyTo f y). Proof. apply impred; intros x. apply is. Defined. Lemma isaprop_NullHomotopyTo {X} {Y} (is:isaset Y) (f:X->Y) : ∥ X ∥ -> isaprop (NullHomotopyTo f). Proof. apply factor_through_squash. apply isapropisaprop. intros x. apply invproofirrelevance. intros [r i] [s j]. apply subtypePairEquality. - intros n. apply (isaprop_nullHomotopyTo is). - exact (!i x @ j x). Defined. (* We can get a map from '∥ X ∥' to any type 'Y' provided paths are given that allow us to map first into a cone in 'Y'. *) Definition cone_squash_map {X Y} (f:X->Y) (y:Y) : nullHomotopyTo f y -> ∥ X ∥ -> Y. Proof. intros e h. exact (point_from (h (paths_to_prop y) (λ x, f x,,e x))). Defined. Goal ∏ X Y (y:Y) (f:X->Y) (e:∏ m:X, f m = y), f = cone_squash_map f y e ∘ squash_element. Proof. reflexivity. Qed. (* Local Variables: compile-command: "make -C ../.. TAGS UniMath/MoreFoundations/NullHomotopies.vo" End: *) UniMath-20231010/UniMath/MoreFoundations/Orders.v000066400000000000000000000142261451125700300214220ustar00rootroot00000000000000(** ** More results on types of ordering *) Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.MoreFoundations.Sets. (** * Preorders *) (** [po] is defined in [Foundations.Sets], but with some access functions missing *) Section po_pty. Context {X : UU}. Context (R : po X). Definition istrans_po : istrans R := pr1 (pr2 R). Definition isrefl_po : isrefl R := pr2 (pr2 R). End po_pty. (** * Strong orders *) (** A _strong ordering_ is a transitive, irreflexive, and cotransitive relation. The terminology is our own, and the definition is not very well-established. Classically, this is nearly equivalent to the more established _strict total order_ (transitive, irreflexive, trichotomous). Constructively/computationally, cotransitivity is generally better than trichotomy — in particular, it is constructively provable for the reals — so it is more used in such settings. *) Definition isStrongOrder {X : UU} (R : hrel X) : UU := istrans R × iscotrans R × isirrefl R. Lemma isapropisStrongOrder {X : hSet} (R : hrel X) : isaprop (isStrongOrder R). Proof. apply isapropdirprod. - apply isaprop_istrans. - apply isapropdirprod. + apply isaprop_iscotrans. + apply isaprop_isirrefl. Defined. Section isso_pty. Context {X : UU}. Context {R : hrel X} (is : isStrongOrder R). Definition istrans_isStrongOrder : istrans R := pr1 is. Definition iscotrans_isStrongOrder : iscotrans R := pr1 (pr2 is). Definition isirrefl_isStrongOrder : isirrefl R := pr2 (pr2 is). Definition isasymm_isStrongOrder : isasymm R := istransandirrefltoasymm istrans_isStrongOrder isirrefl_isStrongOrder. End isso_pty. Lemma isStrongOrder_hnegispreorder : ∏ (X : hSet) (R : hrel X), isStrongOrder R → ispreorder (λ x y : X, (¬ R x y)%logic). Proof. intros X R is. split. - intros x y z Hxy Hyz Hxz. generalize (iscotrans_isStrongOrder is _ y _ Hxz). apply toneghdisj. split. + exact Hxy. + exact Hyz. - exact (isirrefl_isStrongOrder is). Defined. Lemma isStrongOrder_bck {X Y : UU} (f : Y → X) (gt : hrel X) : isStrongOrder gt → isStrongOrder (fun_hrel_comp f gt). Proof. intros is. split ; [ | split ]. - intros x y z. apply (istrans_isStrongOrder is). - intros x y z. apply (iscotrans_isStrongOrder is). - intros x. apply (isirrefl_isStrongOrder is). Qed. Definition StrongOrder (X : UU) := ∑ R : hrel X, isStrongOrder R. Definition make_StrongOrder {X : UU} (R : hrel X) (is : isStrongOrder R) : StrongOrder X := R,,is. Definition pr1StrongOrder {X : UU} : StrongOrder X → hrel X := pr1. Coercion pr1StrongOrder : StrongOrder >-> hrel. Definition pr2StrongOrder {X : UU} {R : StrongOrder X} : isStrongOrder R := pr2 R. Coercion pr2StrongOrder : StrongOrder >-> isStrongOrder. Definition StrongOrder_bck {X Y : UU} (f : Y → X) (gt : StrongOrder X) : StrongOrder Y := (fun_hrel_comp f gt) ,, isStrongOrder_bck f _ (pr2 gt). Lemma isStrongOrder_setquot {X : UU} {R : eqrel X} {L : hrel X} (is : iscomprelrel R L) : isStrongOrder L → isStrongOrder (quotrel is). Proof. intros H. split ; [ | split]. - apply istransquotrel, (istrans_isStrongOrder H). - apply iscotransquotrel, (iscotrans_isStrongOrder H). - apply isirreflquotrel, (isirrefl_isStrongOrder H). Qed. Definition StrongOrder_setquot {X : UU} {R : eqrel X} {L : StrongOrder X} (is : iscomprelrel R L) : StrongOrder (setquot R) := quotrel is,, isStrongOrder_setquot is (pr2 L). (** * Reverse orders *) (** or how easily define ge x y := le x y *) Definition hrel_reverse {X : UU} (l : hrel X) := λ x y, l y x. Lemma istrans_reverse {X : UU} (l : hrel X) : istrans l → istrans (hrel_reverse l). Proof. intros Hl x y z Hxy Hyz. now apply (Hl z y x). Qed. Lemma isrefl_reverse {X : UU} (l : hrel X) : isrefl l → isrefl (hrel_reverse l). Proof. intros Hl x. now apply Hl. Qed. Lemma ispreorder_reverse {X : UU} (l : hrel X) : ispreorder l → ispreorder (hrel_reverse l). Proof. intros H. split. now apply istrans_reverse, (pr1 H). now apply isrefl_reverse, (pr2 H). Qed. Definition po_reverse {X : UU} (l : po X) := make_po (hrel_reverse l) (ispreorder_reverse l (pr2 l)). Lemma po_reverse_correct {X : UU} (l : po X) : ∏ x y : X, po_reverse l x y = l y x. Proof. intros x y. now apply paths_refl. Qed. Lemma issymm_reverse {X : UU} (l : hrel X) : issymm l → issymm (hrel_reverse l). Proof. intros Hl x y. now apply Hl. Qed. Lemma iseqrel_reverse {X : UU} (l : hrel X) : iseqrel l → iseqrel (hrel_reverse l). Proof. intros H. split. now apply ispreorder_reverse, (pr1 H). now apply issymm_reverse, (pr2 H). Qed. Definition eqrel_reverse {X : UU} (l : eqrel X) := make_eqrel (hrel_reverse l) (iseqrel_reverse l (pr2 l)). Lemma eqrel_reverse_correct {X : UU} (l : eqrel X) : ∏ x y : X, eqrel_reverse l x y = l y x. Proof. intros x y. now apply paths_refl. Qed. Lemma isirrefl_reverse {X : UU} (l : hrel X) : isirrefl l → isirrefl (hrel_reverse l). Proof. intros Hl x. now apply Hl. Qed. Lemma iscotrans_reverse {X : UU} (l : hrel X) : iscotrans l -> iscotrans (hrel_reverse l). Proof. intros Hl x y z H. now apply islogeqcommhdisj, Hl. Qed. Lemma isStrongOrder_reverse {X : UU} (l : hrel X) : isStrongOrder l → isStrongOrder (hrel_reverse l). Proof. intros H. repeat split. - apply istrans_reverse, (istrans_isStrongOrder H). - apply iscotrans_reverse,(iscotrans_isStrongOrder H). - apply isirrefl_reverse, (isirrefl_isStrongOrder H). Qed. Definition StrongOrder_reverse {X : UU} (l : StrongOrder X) := make_StrongOrder (hrel_reverse l) (isStrongOrder_reverse l (pr2 l)). Lemma StrongOrder_reverse_correct {X : UU} (l : StrongOrder X) : ∏ x y : X, StrongOrder_reverse l x y = l y x. Proof. intros x y. now apply paths_refl. Qed. Lemma isasymm_reverse {X : UU} (l : hrel X) : isasymm l → isasymm (hrel_reverse l). Proof. intros Hl x y. now apply Hl. Qed. Lemma iscoasymm_reverse {X : UU} (l : hrel X) : iscoasymm l → iscoasymm (hrel_reverse l). Proof. intros Hl x y. now apply Hl. Qed. Lemma istotal_reverse {X : UU} (l : hrel X) : istotal l → istotal (hrel_reverse l). Proof. intros Hl x y. now apply Hl. Qed. UniMath-20231010/UniMath/MoreFoundations/PartA.v000066400000000000000000001211021451125700300211630ustar00rootroot00000000000000(** This file contain various results that could be upstreamed to Foundations/PartA.v *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Tactics. (** * Generalisations of [maponpaths] The following are a uniformly-named set of lemmas giving how multi-argument (non-dependent) functions act on paths, generalising [maponpaths]. The naming convention is that e.g. [maponpaths_135] takes paths in the 1st, 3rd, and 5th arguments, counting _backwards_ from the end. (The “counting backwards” is so that it doesn’t depend on the total number of arguments the function takes.) All are defined in terms of [maponpaths], to allow use of lemmas about it for reasoning about these. See below for a note about defining duplicates/special cases of these lemmas downstream. *) Definition maponpaths_1 {X A : UU} (f : X -> A) {x x'} (e : x = x') : f x = f x' := maponpaths f e. Definition maponpaths_2 {Y X A : UU} (f : Y -> X -> A) {y y'} (e_y : y = y') x : f y x = f y' x := maponpaths (fun y => f y x) e_y. (* TODO: should this be defined in terms of [two_arg_paths] or [map_on_two_paths], from [Foundations]?*) Definition maponpaths_12 {Y X A : UU} (f : Y -> X -> A) {y y'} (e_y : y = y') {x x'} (e_x : x = x') : f y x = f y' x' := maponpaths_1 _ e_x @ maponpaths_2 f e_y _. Definition maponpaths_3 {Z Y X A : UU} (f : Z -> Y -> X -> A) {z z'} (e_z : z = z') y x : f z y x = f z' y x := maponpaths (fun z => f z y x) e_z. Definition maponpaths_123 {Z Y X A : UU} (f : Z -> Y -> X -> A) {z z'} (e_z : z = z') {y y'} (e_y : y = y') {x x'} (e_x : x = x') : f z y x = f z' y' x' := maponpaths_12 _ e_y e_x @ maponpaths_3 f e_z _ _. Definition maponpaths_13 {Z Y X A : UU} (f : Z -> Y -> X -> A) {z z'} (e_z : z = z') (y:Y) {x x'} (e_x : x = x') : f z y x = f z' y x' := maponpaths_123 _ e_z (idpath y) e_x. Definition maponpaths_4 {W Z Y X A : UU} (f : W -> Z -> Y -> X -> A) {w w'} (e_w : w = w') z y x : f w z y x = f w' z y x := maponpaths (fun w => f w z y x) e_w. Definition maponpaths_1234 {W Z Y X A : UU} (f : W -> Z -> Y -> X -> A) {w w'} (e_w : w = w') {z z'} (e_z : z = z') {y y'} (e_y : y = y') {x x'} (e_x : x = x') : f w z y x = f w' z' y' x' := maponpaths_123 _ e_z e_y e_x @ maponpaths_4 _ e_w _ _ _. (** Notes on duplication issues: Duplicates and special cases of these lemmas have been re-written multiple times, in multiple packages, by multiple contributors. Sometimes this is intended and useful — e.g. for frequently-used specialisations such as [base_paths], especially when subsequent definitions mention them, like [fiber_paths]. Other times, it just happens because the contributor hasn’t been aware of the applicable general versions (or they weren’t available at the time of writing). These cases are code duplication, causing redundancy and inconsistent coding style, and should be avoided/refactored. To keep these clearly distinguished: if you are defining duplicates or special cases of these lemmas, please (a) define them in terms of the general ones, so that lemmas about these are applicable, and (b) add a comment noting why your definitions are desirable. A few direct duplicates remain: - [Foundations.PartA.two_arg_paths] and [Foundations.PartA.map_on_two_paths] are complete duplicates of [maponpaths_12], and of each other (modulo reordering of arguments). - [Foundations.PartA.pathsdirprod] and [Foundations.PartA.total2_paths2] are complete duplicates of each other. *) (* TODO: several of the [maponpaths] family could usefully be generalised, to work with functions whose output type is dependent on the arguments that aren’t being varied in the specific lemma. *) Lemma maponpaths_for_constant_function {T1 T2 : UU} (x : T2) {t1 t2 : T1} (e: t1 = t2): maponpaths (fun _: T1 => x) e = idpath x. Proof. induction e. apply idpath. Qed. Lemma base_paths_pair_path_in2 {X : UU} (P : X → UU) {x : X} {p q : P x} (e : p = q) : base_paths _ _ (pair_path_in2 P e) = idpath x. Proof. now induction e. Qed. Lemma transportf_transpose_right {X : UU} {P : X → UU} {x x' : X} {e : x = x'} {y : P x} {y' : P x'} : transportb P e y' = y -> y' = transportf P e y. Proof. induction e; apply idfun. Defined. Definition transportb_transpose_right {A : UU} {P : A → UU} {x x' : A} {e : x = x'} {y : P x} {y' : P x'} : transportf P e y = y' → y = transportb P e y'. Proof. induction e; apply idfun. Defined. Definition transportf_transpose_left {X : UU} {P : X → UU} {x x' : X} {e : x = x'} {y : P x} {y' : P x'} : y = transportb P e y' → transportf P e y = y'. Proof. induction e; apply idfun. Defined. Definition transportb_transpose_left {X : UU} {P : X → UU} {x x' : X} {e : x = x'} {y : P x} {y' : P x'} : y' = transportf P e y → transportb P e y' = y. Proof. induction e; apply idfun. Defined. (* taken from TypeTheory/Display_Cats/Auxiliary.v *) (** Very handy for reasoning with “dependent paths” — Note: similar to [transportf_pathsinv0_var], [transportf_pathsinv0'], but not quite a special case of them, or (as far as I can find) any other library lemma. *) Definition transportf_pathsinv0 {X} (P:X->UU) {x y:X} (p:x = y) (u:P x) (v:P y) : transportf _ (!p) v = u -> transportf _ p u = v. Proof. intro e. induction p, e. reflexivity. Defined. Lemma transportf_comp_lemma (X : UU) (B : X -> UU) {A A' A'': X} (e : A = A'') (e' : A' = A'') (x : B A) (x' : B A') : transportf _ (e @ !e') x = x' -> transportf _ e x = transportf _ e' x'. Proof. intro H. eapply pathscomp0. 2: { apply maponpaths. exact H. } eapply pathscomp0. 2: { symmetry. apply transport_f_f. } apply (maponpaths (λ p, transportf _ p x)). apply pathsinv0. eapply pathscomp0. - apply @pathsinv0, path_assoc. - eapply pathscomp0. apply maponpaths. apply pathsinv0l. apply pathscomp0rid. Defined. Lemma transportf_comp_lemma_hset (X : UU) (B : X -> UU) (A : X) (e : A = A) {x x' : B A} (hs : isaset X) : x = x' -> transportf _ e x = x'. Proof. intros ex. apply @pathscomp0 with (transportf _ (idpath _) x). - apply (maponpaths (λ p, transportf _ p x)). apply hs. - exact ex. Qed. Lemma transportf_bind {X : UU} {P : X → UU} {x x' x'' : X} (e : x' = x) (e' : x = x'') y y' : y = transportf P e y' -> transportf _ e' y = transportf _ (e @ e') y'. Proof. intro H; destruct e, e'; exact H. Defined. Lemma pathscomp0_dep {X : UU} {P : X → UU} {x x' x'' : X} {e : x' = x} {e' : x'' = x'} {y} {y'} {y''} : (y = transportf P e y') -> (y' = transportf _ e' y'') -> y = transportf _ (e' @ e) y''. Proof. intros ee ee'. etrans. apply ee. apply transportf_bind, ee'. Defined. Tactic Notation "etrans_dep" := eapply @pathscomp0_dep. Lemma transportf_set {A : UU} (B : A → UU) {a : A} (e : a = a) (b : B a) (X : isaset A) : transportf B e b = b. Proof. apply transportf_comp_lemma_hset. - apply X. - apply idpath. Defined. Lemma transportf_pair {A B} (P : A × B -> UU) {a a' : A} {b b' : B} (eA : a = a') (eB : b = b') (p : P (a,,b)) : transportf P (pathsdirprod eA eB) p = transportf (λ bb, P(a',,bb) ) eB (transportf (λ aa, P(aa,,b)) eA p). Proof. induction eA. induction eB. apply idpath. Defined. Lemma weqhomot {A B : UU} (f : A -> B) (w : A ≃ B) (H : w ~ f) : isweq f. Proof. apply isweqhomot with w. apply H. apply weqproperty. Defined. Lemma invmap_eq {A B : UU} (f : A ≃ B) (b : B) (a : A) : b = f a → invmap f b = a. Proof. intro H. apply (invmaponpathsweq f). etrans. apply homotweqinvweq. apply H. Defined. Lemma pr1_transportf {A : UU} {B : A -> UU} {P : ∏ a, B a -> UU} {a a' : A} (e : a = a') (xs : ∑ b : B a, P _ b): pr1 (transportf (λ x, ∑ b : B x, P _ b) e xs) = transportf (λ x, B x) e (pr1 xs). Proof. apply pathsinv0. apply (transport_map (λ a, pr1 (P := P a))). Defined. Lemma pr2_transportf {A} {B1 B2 : A → UU} {a a' : A} (e : a = a') (xs : B1 a × B2 a) : pr2 (transportf (λ a, B1 a × B2 a) e xs) = transportf _ e (pr2 xs). Proof. apply pathsinv0. apply (transport_map (λ a, pr2 (P := λ _, B2 a))). Defined. Lemma coprodcomm_coprodcomm {X Y : UU} (v : X ⨿ Y) : coprodcomm Y X (coprodcomm X Y v) = v. Proof. induction v as [x|y]; reflexivity. Defined. Definition sumofmaps_funcomp {X1 X2 Y1 Y2 Z : UU} (f1 : X1 → X2) (f2 : X2 → Z) (g1 : Y1 → Y2) (g2 : Y2 → Z) : sumofmaps (f2 ∘ f1) (g2 ∘ g1) ~ sumofmaps f2 g2 ∘ coprodf f1 g1. Proof. intro x. induction x as [x|y]; reflexivity. Defined. Definition sumofmaps_homot {X Y Z : UU} {f f' : X → Z} {g g' : Y → Z} (h : f ~ f') (h2 : g ~ g') : sumofmaps f g ~ sumofmaps f' g'. Proof. intro x. induction x as [x|y]. - exact (h x). - exact (h2 y). Defined. (** coprod computation helper lemmas *) Definition coprod_rect_compute_1 (A B : UU) (P : A ⨿ B -> UU) (f : ∏ (a : A), P (ii1 a)) (g : ∏ (b : B), P (ii2 b)) (a:A) : coprod_rect P f g (ii1 a) = f a. Proof. intros. apply idpath. Defined. Definition coprod_rect_compute_2 (A B : UU) (P : A ⨿ B -> UU) (f : ∏ a : A, P (ii1 a)) (g : ∏ b : B, P (ii2 b)) (b:B) : coprod_rect P f g (ii2 b) = g b. Proof. intros. apply idpath. Defined. (** Flip the arguments of a function *) Definition flipsec {A B : UU} {C : A -> B -> UU} (f : ∏ a b, C a b) : ∏ b a, C a b := λ x y, f y x. Notation flip := flipsec. (** Flip is a weak equivalence (in fact, it is an involution) *) Lemma isweq_flipsec {A B : UU} {C : A -> B -> UU} : isweq (@flipsec A B C). Proof. apply (isweq_iso _ flipsec); reflexivity. Defined. Definition flipsec_weq {A B : UU} {C : A -> B -> UU} : (∏ a b, C a b) ≃ (∏ b a, C a b) := make_weq flipsec isweq_flipsec. (** hlevel of empty type *) Definition empty_hlevel (n : nat) : isofhlevel (n + 1) ∅. Proof. induction n. - exact isapropempty. - exact (λ x, fromempty x). Defined. Definition empty_HLevel (n : nat) : HLevel (n + 1) := empty ,, empty_hlevel n. Definition HLevel_fun {n : nat} (X Y : HLevel n) : HLevel n. Proof. simple refine (_ ,, _). - exact (pr1 X → pr1 Y). - apply impredfun. exact (pr2 Y). Defined. (** The subtypes of a type of hlevel S n are also of hlevel S n. This doesn't work for types of hlevel 0: a subtype of a contractible type might be empty, not contractible! *) Lemma isofhlevel_hsubtype {X : UU} {n : nat} (isof : isofhlevel (S n) X) : ∏ subt : hsubtype X, isofhlevel (S n) subt. Proof. intros subt. apply isofhleveltotal2. - assumption. - intro. apply isofhlevelsnprop. apply propproperty. Defined. (** Homotopy equivalence on total spaces. This result combines weqfp and weqfibtototal conveniently. *) Lemma weqtotal2 {X Y:Type} {P:X->Type} {Q:Y->Type} (f : X ≃ Y) : (∏ x, P x ≃ Q (f x)) -> (∑ x:X, P x) ≃ (∑ y:Y, Q y). Proof. intros e. exists (λ xp, (f(pr1 xp),,e (pr1 xp) (pr2 xp))). exact (twooutof3c _ _ (isweqfibtototal P (Q ∘ f) e) (pr2 (weqfp f Q))). Defined. Lemma weq_subtypes' {X Y : UU} (w : X ≃ Y) {S : X -> UU} {T : Y -> UU} (HS : isPredicate S) (HT : isPredicate T) (HST : ∏ x : X, S x <-> T (w x)) : (∑ x, S x) ≃ (∑ y, T y). Proof. apply (weqbandf w). intros. apply weqiff. - apply HST. - apply HS. - apply HT. Defined. (* Specialisation of [weq_subtypes'] *) Lemma weq_subtypes_iff {X : UU} {S T : X -> UU} (HS : isPredicate S) (HT : isPredicate T) (HST : ∏ x, S x <-> T x) : (∑ x, S x) ≃ (∑ x, T x). Proof. apply (weq_subtypes' (idweq X)); assumption. Defined. Lemma hlevel_total2 n {A : UU} {B : A → UU} : isofhlevel n (∑ (x :A), B x) → isofhlevel (S n) A → ∏ (x : A), isofhlevel n (B x). Proof. intros ic ia x. exact (isofhlevelweqf _ (invweq (ezweqpr1 _ _)) (isofhlevelffromXY _ _ ic ia _)). Defined. Definition path_sigma_hprop {A : UU} (B : A → UU) (x y : ∑ (z : A), B z) (HB : isaprop (B (pr1 y))) : x = y ≃ pr1 x = pr1 y. Proof. refine (weqpr1 _ _ ∘ total2_paths_equiv _ _ _)%weq. intros. apply HB. Defined. (** ** Pointed types *) Section PointedTypes. Definition PointedType := ∑ X, X. Definition pointedType X x := X,,x : PointedType. Definition underlyingType (X:PointedType) := pr1 X. Coercion underlyingType : PointedType >-> UU. Definition basepoint (X:PointedType) := pr2 X. Definition loopSpace (X:PointedType) := pointedType (basepoint X = basepoint X) (idpath _). Definition underlyingLoop {X:PointedType} (l:loopSpace X) : basepoint X = basepoint X. Proof. intros. exact l. Defined. Definition Ω := loopSpace. End PointedTypes. (** associativity of ∑ *) Definition weq_total2_prod {X Y} (Z:Y->Type) : (∑ y, X × Z y) ≃ (X × ∑ y, Z y). Proof. (* move upstream *) intros. simple refine (make_weq _ (isweq_iso _ _ _ _)). { intros [y [x z]]. exact (x,,y,,z). } { intros [x [y z]]. exact (y,,x,,z). } { intros [y [x z]]. reflexivity. } { intros [x [y z]]. reflexivity. } Defined. Definition totalAssociativity {X:UU} {Y: ∏ (x:X), UU} (Z: ∏ (x:X) (y:Y x), UU) : (∑ (x:X) (y:Y x), Z x y) ≃ (∑ (p:∑ (x:X), Y x), Z (pr1 p) (pr2 p)). Proof. intros. simple refine (_,,isweq_iso _ _ _ _). { intros [x [y z]]. exact ((x,,y),,z). } { intros [[x y] z]. exact (x,,(y,,z)). } { intros [x [y z]]. reflexivity. } { intros [[x y] z]. reflexivity. } Defined. (* direct product of 3 paths; extends pathsdirprod *) Definition paths3 {X Y Z} {x x':X} {y y':Y} {z z':Z} : x = x' -> y = y' -> z = z' -> @paths (_×_×_) (x,,y,,z) (x',,y',,z'). Proof. intros p q r. induction p, q, r. reflexivity. Defined. (* paths *) Definition confun T {Y} (y:Y) := λ _:T, y. Definition path_type {X} {x x':X} (p:x = x') := X. Definition path_start {X} {x x':X} (p:x = x') := x. Definition path_end {X} {x x':X} (p:x = x') := x'. Definition uniqueness {T} (i:iscontr T) (t:T) : t = iscontrpr1 i. Proof. intros. exact (pr2 i t). Defined. Definition uniqueness' {T} (i:iscontr T) (t:T) : iscontrpr1 i = t. Proof. intros. exact (! (pr2 i t)). Defined. Definition path_inverse_to_right {X} {x y:X} (p q:x = y) : p = q -> !q@p = idpath _. Proof. intros e. induction e. induction p. reflexivity. Defined. Definition path_inverse_to_right' {X} {x y:X} (p q:x = y) : p = q -> p@!q = idpath _. Proof. intros e. induction e. induction p. reflexivity. Defined. (** ** Paths *) Definition pathsinv0_to_right {X} {x y z:X} (p:y = x) (q:y = z) (r:x = z) : q = p @ r -> !p @ q = r. Proof. intros e. induction p, q. exact e. Defined. Definition pathsinv0_to_right' {X} {x y:X} (p:y = x) (r:x = y) : idpath _ = p @ r -> !p = r. Proof. intros e. induction p. exact e. Defined. Definition pathsinv0_to_right'' {X} {x:X} (p:x = x) : idpath _ = p -> !p = idpath _. Proof. intros e. apply pathsinv0_to_right'. rewrite pathscomp0rid. exact e. Defined. Definition loop_power_nat {Y} {y:Y} (l:y = y) (n:nat) : y = y. Proof. intros. induction n as [|n p]. { exact (idpath _). } { exact (p@l). } Defined. Lemma irrel_paths {X} (irr:∏ x y:X, x = y) {x y:X} (p q:x = y) : p = q. Proof. intros. assert (k : ∏ z:X, ∏ r:x = z, r @ irr z z = irr x z). { intros. induction r. reflexivity. } assert (l := k y p @ !k y q). apply (pathscomp_cancel_right _ _ _ l). Defined. Definition path_inv_rotate_2 {X} {a b c d:X} (p:a = b) (p':c = d) (q:a = c) (q':b = d) : q @ p' = p @ q' -> p' @ ! q' = !q @ p. Proof. induction q,q'. simpl. repeat rewrite pathscomp0rid. apply idfun. Defined. Definition maponpaths_naturality {X Y : UU} {f : X -> Y} {x x' x'' : X} {p : x = x'} {q : x' = x''} {p': f x = f x'} {q': f x' = f x''} (r : maponpaths f p = p') (s : maponpaths f q = q') : maponpaths f (p @ q) = p' @ q'. Proof. intros. induction r, s. apply maponpathscomp0. Defined. Definition maponpaths_naturality' {X Y : UU} {f : X -> Y} {x x' x'' : X} {p : x' = x} {q : x' = x''} {p' : f x' = f x} {q' : f x' = f x''} (r : maponpaths f p = p') (s : maponpaths f q = q') : maponpaths f (!p @ q) = (!p') @ q'. Proof. intros. induction r, s, p, q. reflexivity. Defined. (** ** Pairs *) Definition pr2_of_make_hfiber {X Y} {f:X->Y} {x:X} {y:Y} {e:f x = y} : pr2 (make_hfiber f x e) = e. Proof. reflexivity. Defined. Definition pr2_of_pair {X} {P:X->Type} (x:X) (p:P x) : pr2 (tpair P x p) = p. Proof. reflexivity. Defined. Definition pr2_of_make_weq {X Y} (f:X->Y) (i:isweq f) : pr2 (make_weq f i) = i. Proof. reflexivity. Defined. (** ** Paths between pairs *) (* replace all uses of this by uses of subtypePairEquality *) Definition pair_path_props {X} {P:X->Type} {x y:X} {p:P x} {q:P y} : x = y -> (∏ z, isaprop (P z)) -> x,,p = y,,q. Proof. intros e is. now apply subtypePairEquality. Abort. Local Open Scope transport. Definition pair_path2 {A} {B:A->UU} {a a1 a2} {b1:B a1} {b2:B a2} (p:a1 = a) (q:a2 = a) (e:p#b1 = q#b2) : a1,,b1 = a2,,b2. Proof. intros. induction p,q; compute in e. induction e. reflexivity. Defined. (** ** Projections from pair types *) Definition pair_path_in2_comp1 {X} (P:X->Type) {x:X} {p q:P x} (e:p = q) : maponpaths pr1 (maponpaths (tpair P _) e) = idpath x. Proof. intros. induction e. reflexivity. Defined. Definition total2_paths2_comp1 {X} {Y:X->Type} {x} {y:Y x} {x'} {y':Y x'} (p:x = x') (q:p#y = y') : maponpaths pr1 (two_arg_paths_f (f := tpair Y) p q) = p. Proof. intros. induction p. induction q. reflexivity. Defined. Definition total2_paths2_comp2 {X} {Y:X->Type} {x} {y:Y x} {x'} {y':Y x'} (p:x = x') (q:p#y = y') : ! maponpaths_2 _ (total2_paths2_comp1 p q) y @ fiber_paths (two_arg_paths_f p q) = q. Proof. intros. induction p, q. reflexivity. Defined. (** ** Maps from pair types *) Definition from_total2 {X} {P:X->Type} {Y} : (∏ x, P x->Y) -> total2 P -> Y. Proof. intros f [x p]. exact (f x p). Defined. (** ** Paths in coproducts *) Definition inv_equality_by_case_equality_by_case {A B : UU} {x y : A ⨿ B} (p : x = y) : @inv_equality_by_case A B x y (equality_by_case p) = p. Proof. induction x, y, p ; apply idpath. Defined. Definition equality_by_case_inv_equality_by_case {A B : UU} {x y : A ⨿ B} (p : equality_cases x y) : equality_by_case (inv_equality_by_case p) = p. Proof. induction x, y, p; apply idpath. Defined. Lemma equality_by_case_equiv {A B} (t u : A ⨿ B) : (t = u) ≃ equality_cases t u. Proof. use weq_iso. - apply equality_by_case. - apply inv_equality_by_case. - apply inv_equality_by_case_equality_by_case. - apply equality_by_case_inv_equality_by_case. Defined. Definition paths_inl_inl_equiv {A B : UU} (a a' : A) : @inl A B a = inl a' ≃ a = a'. Proof. apply @equality_by_case_equiv. Defined. Definition paths_inl_inr_equiv {A B : UU} (a : A) (b : B) : inl a = inr b ≃ empty. Proof. apply @equality_by_case_equiv. Defined. Definition paths_inr_inr_equiv {A B : UU} (b b' : B) : @inr A B b = inr b' ≃ b = b'. Proof. apply @equality_by_case_equiv. Defined. Definition paths_inr_inl_equiv {A B : UU} (a : A) (b : B) : inr b = inl a ≃ empty. Proof. apply @equality_by_case_equiv. Defined. (* Note: the following lemmas are near-duplicates of [isinclii1], [isinclii2] provided in [Foundations]. *) Lemma isInjective_inl {A B : UU} : isInjective (@inl A B). Proof. intros ? ?. refine (isweqinvmap (@paths_inl_inl_equiv _ _ _ _)). Defined. Lemma isInjective_inr {A B : UU} : isInjective (@inr A B). Proof. intros ? ?. refine (isweqinvmap (@paths_inr_inr_equiv _ _ _ _)). Defined. (** ** Sections and functions *) Notation homotsec := homot. (** Naturality of homotopies *) Definition homotsec_natural {X Y : UU} {f g : X → Y} (e : f ~ g) {x y : X} (p : x = y) : maponpaths f p @ e y = e x @ maponpaths g p. Proof. induction p. exact (!(pathscomp0rid _)). Defined. (* compare with [adjev] *) Definition evalat {T} {P:T->UU} (t:T) (f:∏ t:T, P t) := f t. Definition apfun {X Y} {f f':X->Y} (p:f = f') {x x'} (q:x = x') : f x = f' x'. intros. induction q. exact (eqtohomot p x). Defined. Definition fromemptysec { X : empty -> UU } (nothing:empty) : X nothing. (* compare with [fromempty] in u00 *) Proof. induction nothing. Defined. Definition maponpaths_idpath {X Y} {f:X->Y} {x:X} : maponpaths f (idpath x) = idpath (f x). Proof. intros. reflexivity. Defined. (** ** Transport *) Definition cast {T U:Type} : T = U -> T -> U := transportf (λ T:Type, T). Definition transport_type_path {X Y:Type} (p:X = Y) (x:X) : transportf (λ T:Type, T) p x = cast p x. Proof. reflexivity. Defined. Definition transport_fun_path {X Y} {f g:X->Y} {x x':X} {p:x = x'} {e:f x = g x} {e':f x' = g x'} : e @ maponpaths g p = maponpaths f p @ e' -> transportf (λ x, f x = g x) p e = e'. Proof. intros k. induction p. rewrite maponpaths_idpath in k. rewrite maponpaths_idpath in k. rewrite pathscomp0rid in k. exact k. Defined. Definition transportf_pathsinv0' {X} (P:X->UU) {x y:X} (p:x = y) (u:P x) (v:P y) : p # u = v -> !p # v = u. Proof. intros e. induction p, e. reflexivity. Defined. Lemma transport_idfun {X} (P:X->UU) {x y:X} (p:x = y) (u:P x) : transportf P p u = transportf (idfun UU) (maponpaths P p) u. (* same as HoTT.PathGroupoids.transport_idmap_ap *) Proof. intros. induction p. reflexivity. Defined. Lemma transport_functions {X} {Y:X->Type} {Z:∏ x (y:Y x), Type} {f f':∏ x : X, Y x} (p:f = f') (z:∏ x, Z x (f x)) x : transportf (λ f, ∏ x, Z x (f x)) p z x = transportf (Z x) (toforallpaths _ _ _ p x) (z x). Proof. intros. induction p. reflexivity. Defined. Definition transport_funapp {T} {X Y:T->Type} (f:∏ t, X t -> Y t) (x:∏ t, X t) {t t':T} (p:t = t') : transportf _ p ((f t)(x t)) = (transportf (λ t, X t -> Y t) p (f t)) (transportf _ p (x t)). Proof. intros. induction p. reflexivity. Defined. Definition helper_A {T} {Y} (P:T->Y->Type) {y y':Y} (k:∏ t, P t y) (e:y = y') t : transportf (λ y, P t y) e (k t) = (transportf (λ y, ∏ t, P t y) e k) t. Proof. intros. induction e. reflexivity. Defined. Definition helper_B {T} {Y} (f:T->Y) {y y':Y} (k:∏ t, y = f t) (e:y = y') t : transportf (λ y, y = f t) e (k t) = (transportf (λ y, ∏ t, y = f t) e k) t. Proof. intros. exact (helper_A _ k e t). Defined. Definition transport_invweq {T} {X Y:T->Type} (f:∏ t, (X t) ≃ (Y t)) {t t':T} (p:t = t') : transportf (λ t, (Y t) ≃ (X t)) p (invweq (f t)) = invweq (transportf (λ t, (X t) ≃ (Y t)) p (f t)). Proof. intros. induction p. reflexivity. Defined. Definition transport_invmap {T} {X Y:T->Type} (f:∏ t, (X t) ≃ (Y t)) {t t':T} (p:t=t') : transportf (λ t, Y t -> X t) p (invmap (f t)) = invmap (transportf (λ t, (X t) ≃ (Y t)) p (f t)). Proof. intros. induction p. reflexivity. Defined. (** *** Double transport *) Definition transportf2 {X} {Y:X->Type} (Z:∏ x, Y x->Type) {x x'} (p:x = x') (y:Y x) (z:Z x y) : Z x' (p#y). Proof. intros. induction p. exact z. Defined. Definition transportb2 {X} {Y:X->Type} (Z:∏ x, Y x->Type) {x x'} (p:x=x') (y':Y x') (z':Z x' y') : Z x (p#'y'). Proof. intros. induction p. exact z'. Defined. Definition maponpaths_pr1_pr2 {X} {P:X->UU} {Q:∏ x, P x->Type} {w w': ∑ x p, Q x p} (p : w = w') : transportf P (maponpaths pr1 p) (pr1 (pr2 w)) = pr1 (pr2 w'). Proof. intros. induction p. reflexivity. Defined. (** *** Transport a pair *) (* (* replace this with transportf_total2 (?) : *) *) (* Definition transportf_pair X (Y:X->Type) (Z:∏ x, Y x->Type) *) (* x x' (p:x = x') (y:Y x) (z:Z x y) : *) (* transportf (λ x, total2 (Z x)) p (tpair (Z x) y z) *) (* = *) (* tpair (Z x') (transportf Y p y) (transportf2 _ p y z). *) (* Proof. *) (* intros. induction p. reflexivity. *) (* Defined. *) Definition transportb_pair X (Y:X->Type) (Z:∏ x, Y x->Type) x x' (p:x = x') (y':Y x') (z':Z x' y') (z'' : (Z x' y')) : transportb (λ x, total2 (Z x)) p (tpair (Z x') y' z') = tpair (Z x) (transportb Y p y') (transportb2 _ p y' z'). Proof. intros. induction p. reflexivity. Defined. Lemma transportf_total2_const (A B : UU) (P : B -> A -> UU) (b : B) (a1 a2 : A) (e : a1 = a2) (p : P b a1) : transportf (λ x, ∑ y, P y x) e (b,, p) = b,, transportf (P b) e p. Proof. induction e. apply idpath. Defined. (** ** h-levels and paths *) Lemma isaprop_wma_inhab X : (X -> isaprop X) -> isaprop X. Proof. intros f. apply invproofirrelevance. intros x y. apply (f x). Qed. Lemma isaprop_wma_inhab' X : (X -> iscontr X) -> isaprop X. Proof. intros f. apply isaprop_wma_inhab. intro x. apply isapropifcontr. apply (f x). Qed. Goal ∏ (X:hSet) (x y:X) (p q:x = y), p = q. Proof. intros. apply setproperty. Defined. Goal ∏ (X:Type) (x y:X) (p q:x = y), isaset X -> p = q. Proof. intros * is. apply is. Defined. Definition funset X (Y:hSet) : hSet := make_hSet (X->Y) (impredfun 2 _ _ (setproperty Y)). Lemma eq_equalities_between_pairs (A : UU) (B : A -> UU)(x y : total2 (λ x, B x)) (p q : x = y) (H : base_paths _ _ p = base_paths _ _ q) (H2 : transportf (fun p : pr1 x = pr1 y => transportf _ p (pr2 x) = pr2 y ) H (fiber_paths p) = fiber_paths q) : p = q. Proof. apply (invmaponpathsweq (total2_paths_equiv _ _ _ )). apply (total2_paths_f (B:=(fun p : pr1 x = pr1 y => transportf (λ x : A, B x) p (pr2 x) = pr2 y)) (s := (total2_paths_equiv B x y) p) (s' := (total2_paths_equiv B x y) q) H). assumption. Defined. (* perhaps consider name *) Lemma total2_reassoc_paths {A} {B : A → UU} {C : (∑ a, B a) -> UU} (BC : A -> UU := λ a, ∑ b, C (a,,b)) {a1 a2 : A} (bc1 : BC a1) (bc2 : BC a2) (ea : a1 = a2) (eb : transportf _ ea (pr1 bc1) = pr1 bc2) (ec : transportf C (two_arg_paths_f (*was total2_paths2*) ea eb) (pr2 bc1) = pr2 bc2) : transportf _ ea bc1 = bc2. Proof. destruct bc1 as [b1 c1], bc2 as [b2 c2]; simpl in *. destruct ea. destruct eb. simpl in *. destruct ec. apply idpath. Defined. (* perhaps consider name *) Lemma total2_reassoc_paths' {A} {B : A → UU} {C : (∑ a, B a) -> UU} (BC : A -> UU := λ a, ∑ b, C (a,,b)) {a1 a2 : A} (bc1 : BC a1) (bc2 : BC a2) (ea : a1 = a2) (eb : pr1 bc1 = transportb _ ea (pr1 bc2)) (ec : pr2 bc1 = transportb C (total2_paths2_b ea eb) (pr2 bc2)) : bc1 = transportb BC ea bc2. Proof. destruct ea, bc1 as [b1 c1], bc2 as [b2 c2]. cbn in eb; destruct eb; cbn in ec; destruct ec. apply idpath. Defined. Section InvRot. (** moving pathsinv0 to the other side in equations *) Local Set Implicit Arguments. Local Unset Strict Implicit. Definition invrot (X:Type) (x y:X) (p:x=y) (p':y=x) : !p = p' -> p = !p'. Proof. intros e. induction e. apply pathsinv0. apply pathsinv0inv0. Defined. Definition invrot' (X:Type) (x y:X) (p:x=y) (p':y=x) : p = !p' -> !p = p'. Proof. intros e. induction (!e); clear e. apply pathsinv0inv0. Defined. Definition invrot'rot (X:Type) (x y:X) (p:x=y) (p':y=x) (e : !p = p') : invrot' (invrot e) = e. Proof. now induction e,p. Defined. Definition invrotrot' (X:Type) (x y:X) (p:x=y) (p':y=x) (e : p = !p') : invrot (invrot' e) = e. Proof. rewrite <- (pathsinv0inv0 e). generalize (!e); clear e. intros e. now induction e, p'. Defined. End InvRot. Section Weqpaths. (** a more basic approach to proving isweqpathscomp0r *) Local Set Implicit Arguments. Local Unset Strict Implicit. Definition hornRotation_rr {X:Type} {x y z : X} {p : x = z} {q : y = z} {r : x = y} : r = p @ !q ≃ r @ q = p. Proof. induction q, r; cbn. apply eqweqmap. apply (maponpaths (λ k, idpath x = k)). apply pathscomp0rid. Defined. Definition hornRotation_lr {X:Type} {x y z : X} {p : x = z} {q : y = z} {r : x = y} : q = (!r) @ p ≃ r @ q = p. Proof. induction p, r; cbn. apply idweq. Defined. Definition hornRotation_rl {X:Type} {x y z : X} {p : x = z} {q : y = z} {r : x = y} : p @ !q = r ≃ p = r @ q. Proof. induction q, r; cbn. apply eqweqmap. apply (maponpaths (λ k, k = idpath x)). apply pathscomp0rid. Defined. Definition hornRotation_ll {X:Type} {x y z : X} {p : x = z} {q : y = z} {r : x = y} : (!r) @ p = q ≃ p = r @ q. Proof. induction p, r; cbn. apply idweq. Defined. Corollary uniqueFiller (X:Type) (x y z : X) (p : x = z) (q : y = z) : ∃! r, r @ q = p. Proof. refine (@iscontrweqf (∑ r, r = p @ !q) _ _ _). { apply weqfibtototal; intro r. exact hornRotation_rr. } { apply iscontrcoconustot. } Defined. Lemma fillerEquation {X:Type} {x y z : X} {p : x = z} {q : y = z} (r : x = y) (k : r @ q = p) : @paths (∑ r, r@q=p) (r ,, k) ((p @ !q) ,, hornRotation_rr (idpath _)). Proof. apply proofirrelevancecontr. apply uniqueFiller. Defined. Corollary isweqpathscomp0r' {X : UU} (x : X) {x' x'' : X} (e' : x' = x'') : isweq (λ e : x = x', e @ e'). Proof. (* make a direct proof of isweqpathscomp0r, without using isweq_iso *) intros p. use tpair. exists (p @ !e'). now apply hornRotation_rr. cbn. intros [q l]. apply fillerEquation. Defined. Definition transportPathTotal {X:Type} {x x':X} {Y : X -> Type} (y : Y x) (y' : Y x') (r : (x,,y) = (x',,y')) (T : ∏ (a:X) (b:Y a), Type) : T x y → T x' y'. Proof. induction (total2_paths_equiv _ _ _ r) as [p q]. change (x=x') in p. change (transportf _ p y = y') in q. induction p. change (y=y') in q. induction q. trivial. Defined. Definition inductionOnFiller {X:Type} {x y z:X} (p:x=z) (q:y=z) (S := λ r:x=y, r @ q = p) (T : ∏ r (e : S r), Type) (t : T (p @ !q) (hornRotation_rr (idpath _))) : ∏ (r:x=y) (e : r @ q = p), T r e. Proof. intros. use (transportPathTotal _ t). apply pathsinv0. apply fillerEquation. Defined. End Weqpaths. Lemma transportf_paths_FlFr {A B : UU} {f g : A -> B} {x1 x2 : A} (p : x1 = x2) (q : f x1 = g x1) : transportf (λ x, f x = g x) p q = !maponpaths f p @ q @ maponpaths g p. Proof. induction p. cbn. apply pathsinv0. apply pathscomp0rid. Qed. Lemma transportf_sec_constant {A B : UU} {C : A -> B -> UU} {x1 x2 : A} (p : x1 = x2) (f : ∏ y : B, C x1 y) : (transportf (λ x, ∏ y : B, C x y) p f) = (λ y, transportf (λ x, C x y) p (f y)). Proof. induction p; reflexivity. Qed. (** More facts on fiber products *) Definition path_hfp {X Y Z : UU} {f : X → Z} {g : Y → Z} {x y : hfp f g} (p₁ : hfpg f g x = hfpg f g y) (p₂ : hfpg' f g x = hfpg' f g y) (p₃ : commhfp f g x @ maponpaths f p₁ = maponpaths g p₂ @ commhfp f g y) : x = y. Proof. induction x as [ [ x₁ x₂ ] px ]. induction y as [ [ y₁ y₂ ] py ]. cbn in p₁, p₂. induction p₁, p₂. cbn in p₃. apply maponpaths. exact (!(pathscomp0rid _) @ p₃). Defined. Definition maponpaths_hfpg_path_hfp {X Y Z : UU} {f : X → Z} {g : Y → Z} {x y : hfp f g} (p₁ : hfpg f g x = hfpg f g y) (p₂ : hfpg' f g x = hfpg' f g y) (p₃ : commhfp f g x @ maponpaths f p₁ = maponpaths g p₂ @ commhfp f g y) : maponpaths (hfpg f g) (path_hfp p₁ p₂ p₃) = p₁. Proof. induction x as [ [ x₁ x₂ ] px ]. induction y as [ [ y₁ y₂ ] py ]. cbn in p₁, p₂. induction p₁, p₂. cbn in p₃. induction p₃ ; cbn. etrans. { apply (maponpathscomp (tpair (λ xx', g (pr2 xx') = f (pr1 xx')) (x₁,, x₂)) (hfpg f g)). } apply maponpaths_for_constant_function. Qed. Definition maponpaths_hfpg'_path_hfp {X Y Z : UU} {f : X → Z} {g : Y → Z} {x y : hfp f g} (p₁ : hfpg f g x = hfpg f g y) (p₂ : hfpg' f g x = hfpg' f g y) (p₃ : commhfp f g x @ maponpaths f p₁ = maponpaths g p₂ @ commhfp f g y) : maponpaths (hfpg' f g) (path_hfp p₁ p₂ p₃) = p₂. Proof. induction x as [ [ x₁ x₂ ] px ]. induction y as [ [ y₁ y₂ ] py ]. cbn in p₁, p₂. induction p₁, p₂. cbn in p₃. induction p₃ ; cbn. etrans. { apply (maponpathscomp (tpair (λ xx', g (pr2 xx') = f (pr1 xx')) (x₁,, x₂)) (hfpg' f g)). } apply maponpaths_for_constant_function. Qed. Definition path_hfp_eta {X Y Z : UU} {f : X → Z} {g : Y → Z} {x y : hfp f g} (p : x = y) : p = path_hfp (maponpaths (hfpg f g) p) (maponpaths (hfpg' f g) p) (maponpaths (λ z, _ @ z) (maponpathscomp (hfpg f g) f p) @ !(homotsec_natural (commhfp f g) p) @ maponpaths (λ z, z @ _) (!(maponpathscomp (hfpg' f g) g p))). Proof. induction p. cbn. refine (!_). etrans. { apply maponpaths. etrans. { apply maponpaths. etrans. { apply pathscomp0rid. } apply pathsinv0inv0. } apply pathsinv0l. } apply idpath. Qed. Definition homot_hfp {X Y Z : UU} {f : X → Z} {g : Y → Z} {x y : hfp f g} {h₁ h₁' : hfpg f g x = hfpg f g y} (e₁ : h₁ = h₁') {h₂ h₂' : hfpg' f g x = hfpg' f g y} (e₂ : h₂ = h₂') (h₃ : commhfp f g x @ maponpaths f h₁ = maponpaths g h₂ @ commhfp f g y) : path_hfp h₁ h₂ h₃ = path_hfp h₁' h₂' (maponpaths (λ z, _ @ maponpaths f z) (!e₁) @ h₃ @ maponpaths (λ z, maponpaths g z @ _) e₂). Proof. induction e₁ ; induction e₂. simpl. apply maponpaths. exact (!(pathscomp0rid _)). Qed. Definition homot_hfp_one_type {X Y Z : UU} (HZ : isofhlevel 3 Z) {f : X → Z} {g : Y → Z} {x y : hfp f g} (p q : x = y) (r₁ : maponpaths (hfpg f g) p = maponpaths (hfpg f g) q) (r₂ : maponpaths (hfpg' f g) p = maponpaths (hfpg' f g) q) : p = q. Proof. refine (path_hfp_eta p @ _ @ !(path_hfp_eta q)). etrans. { exact (homot_hfp r₁ r₂ _). } apply maponpaths. apply HZ. Qed. Definition hfp_is_of_hlevel (n : nat) {X Y Z : UU} (HX : isofhlevel n X) (HY : isofhlevel n Y) (HZ : isofhlevel n Z) (f : X → Z) (g : Y → Z) : isofhlevel n (hfp f g). Proof. use isofhleveltotal2. - use isofhleveldirprod. + exact HX. + exact HY. - simpl. intro x. apply (hlevelntosn n _ HZ). Qed. Definition hfp_HLevel (n : nat) {X Y Z : HLevel n} (f : pr1 X → pr1 Z) (g : pr1 Y → pr1 Z) : HLevel n. Proof. simple refine (hfp f g ,, _). apply hfp_is_of_hlevel. - exact (pr2 X). - exact (pr2 Y). - exact (pr2 Z). Defined. (** Transport along a path of total2 *) Definition transportf_total2_paths_f {A : UU} {B : A → UU} (C : A → UU) {a₁ a₂ : A} {b₁ : B a₁} {b₂ : B a₂} (p : a₁ = a₂) (q : transportf B p b₁ = b₂) (c₁ : C a₁) : transportf (λ z, C (pr1 z)) (@total2_paths_f A B (a₁ ,, b₁) (a₂ ,, b₂) p q) c₁ = transportf C p c₁. Proof. induction p. induction q. apply idpath. Defined. (** Paths of products *) Definition maponpaths_pr1_pathsdirprod {X Y : UU} {x₁ x₂ : X} {y₁ y₂ : Y} (p : x₁ = x₂) (q : y₁ = y₂) : maponpaths dirprod_pr1 (pathsdirprod p q) = p. Proof. induction p, q. apply idpath. Defined. Definition maponpaths_pr2_pathsdirprod {X Y : UU} {x₁ x₂ : X} {y₁ y₂ : Y} (p : x₁ = x₂) (q : y₁ = y₂) : maponpaths dirprod_pr2 (pathsdirprod p q) = q. Proof. induction p, q. apply idpath. Defined. Definition pathsdirprod_eta {X Y : UU} {x y : X × Y} (p : x = y) : p = pathsdirprod (maponpaths dirprod_pr1 p) (maponpaths dirprod_pr2 p). Proof. induction p. apply idpath. Defined. Definition paths_pathsdirprod {X Y : UU} {x₁ x₂ : X} {y₁ y₂ : Y} {p₁ p₂ : x₁ = x₂} {q₁ q₂ : y₁ = y₂} (r₁ : p₁ = p₂) (r₂ : q₁ = q₂) : pathsdirprod p₁ q₁ = pathsdirprod p₂ q₂. Proof. induction r₁, r₂. apply idpath. Defined. (** Paths on functions *) Definition app_fun {X Y : UU} : (X → Y) × X → Y := λ fx, pr1 fx (pr2 fx). Definition app_homot {X Y₁ Y₂ : UU} {f g : Y₁ → X → Y₂} (p : ∏ (z : Y₁ × X), f (pr1 z) (pr2 z) = g (pr1 z) (pr2 z)) (y : Y₁) : f y = g y := funextsec _ _ _ (λ x, p (y ,, x)). Definition maponpaths_app_fun {X Y : UU} {fx gx : (X → Y) × X} (p : fx = gx) : maponpaths (λ (fx : (X → Y) × X), app_fun fx) p = maponpaths (λ z, z (pr2 fx)) (maponpaths dirprod_pr1 p) @ maponpaths (pr1 gx) (maponpaths dirprod_pr2 p). Proof. induction p. apply idpath. Defined. (** Product of a propositions with itself *) Definition dirprod_with_prop (A : UU) (isa : isaprop A) : A × A ≃ A. Proof. apply weqpr1, iscontraprop1; assumption. Defined. (** A variation on the above theme *) Definition dirprod_with_prop' (A B : UU) (isa : isaprop A) : A × B × A ≃ B × A. Proof. intermediate_weq ((A × B) × A). apply invweq, weqtotal2asstor. intermediate_weq (A × (A × B)). apply weqdirprodcomm. intermediate_weq ((A × A) × B). apply invweq, weqtotal2asstor. intermediate_weq (A × B). apply weqdirprodf. - apply dirprod_with_prop; assumption. - apply idweq. - apply weqdirprodcomm. Defined. (** ** Surjectivity *) Section surjectivity. Lemma issurjective_idfun (X : UU) : issurjective (idfun X). Proof. exact(λ (x : X), hinhpr (x ,, idpath x)). Qed. Lemma issurjective_to_contr {X Y : UU} (x : X) (f : X → Y) (contr : iscontr Y) : issurjective f. Proof. intro; apply hinhpr. apply(make_hfiber f x). apply proofirrelevancecontr, contr. Qed. Lemma issurjective_tounit {X : UU} : X -> issurjective (@tounit X). Proof. intro x. apply(issurjective_to_contr x). apply iscontrunit. Qed. Lemma issurjective_coprodf {X Y W Z : UU} {f : X → W} {g : Y → Z} (fsurjective : issurjective f) (gsurjective : issurjective g) : issurjective (coprodf f g). Proof. red; apply coprod_rect. - intro w. apply(hinhfun (weqhfibercoprodf1 f g w)). exact(fsurjective w). - intro z. apply(hinhfun (weqhfibercoprodf2 f g z)). exact(gsurjective z). Qed. Lemma issurjective_dirprodf {X Y U W} {f : X → U} {g : Y → W} (fsurjective : issurjective f) (gsurjective : issurjective g) : issurjective (dirprodf f g). Proof. intros [u w]. use(hinhfun2 _ (fsurjective u) (gsurjective w)). intros ffiber gfiber. use make_hfiber. - exact(hfiberpr1 f u ffiber ,, hfiberpr1 g w gfiber). - apply dirprodeq ; apply hfiberpr2. Qed. Lemma issurjective_totalfun {X : UU} (P Q : X → UU) (f : ∏ (x : X), P x → Q x) (fsurjective : ∏ (x : X), issurjective (f x)) : issurjective (totalfun P Q f). Proof. intros [x qx]. use(hinhfun _ (fsurjective x qx)). intros [px pathpx]. (* pathpx : f x px = qx, in (Q x) *) use make_hfiber. - exact(x ,, px). - exact(pair_path_in2 Q pathpx). Qed. Lemma issurjective_sumofmaps_1 {X A B : UU} (f : A -> X) (g : B -> X) (fsurjective : issurjective f) : issurjective (sumofmaps f g). Proof. intro x. use(hinhfun _ (fsurjective x)). intro ffiber; apply coprodofhfiberstohfiber. exact(inl ffiber). Qed. Lemma issurjective_sumofmaps_2 {X A B : UU} (f : A -> X) (g : B -> X) (gsurjective : issurjective g) : issurjective (sumofmaps f g). Proof. intro x. use(hinhfun _ (gsurjective x)). intro gfiber; apply coprodofhfiberstohfiber. exact(inr gfiber). Qed. End surjectivity. UniMath-20231010/UniMath/MoreFoundations/PartD.v000066400000000000000000000033671451125700300212020ustar00rootroot00000000000000Require Export UniMath.Foundations.All. Lemma eqweqmap_transportb {T U: Type} (p: T = U) : (λ u:U, eqweqmap (! p) u) = transportb (λ X:Type, X) p. Proof. induction p. reflexivity. Defined. Lemma eqweqmap_weqtopaths {T U} (w : T≃U) : eqweqmap (weqtopaths w) = w. Proof. exact (homotweqinvweq (univalence T U) w). Defined. Lemma sum_of_fibers {A B:Type} (f: A -> B) : (∑ b:B, hfiber f b) ≃ A. Proof. use make_weq. - intro bap. exact (pr1 (pr2 bap)). - intro a. use make_iscontr. + use make_hfiber. * exists (f a). use make_hfiber. { exact a. } { reflexivity. } * cbn. reflexivity. + intro b1a1p1p. induction b1a1p1p as [b1a1p1 p]. induction p. induction b1a1p1 as [b1 [a1 p1]]. induction p1. reflexivity. Defined. Definition display {A: Type} : (∑ B, B -> A) -> (A -> Type). Proof. intro Bf. exact (hfiber (pr2 Bf)). Defined. Definition totalfst {A: Type} : (A -> Type) -> (∑ B, B -> A). Proof. intro P. exists (∑ a:A, P a). exact pr1. Defined. Lemma totalfst_display {A: Type} (Bf: ∑ B, B -> A) : totalfst (display Bf) = Bf. Proof. use total2_paths_f. - apply weqtopaths. apply sum_of_fibers. - rewrite transportf_fun. rewrite <- eqweqmap_transportb. rewrite eqweqmap_pathsinv0. rewrite eqweqmap_weqtopaths. reflexivity. Defined. Lemma display_totalfst {A: Type} (P: A -> Type) : display(totalfst(P)) = P. Proof. apply funextsec; intro a. apply pathsinv0. apply weqtopaths. apply ezweqpr1. Defined. Lemma display_weq (A:Type) : (∑ B, B -> A) ≃ (A -> Type). Proof. exists display. apply (isweq_iso display totalfst). - exact totalfst_display. - exact display_totalfst. Defined. UniMath-20231010/UniMath/MoreFoundations/PathsOver.v000066400000000000000000000516611451125700300221030ustar00rootroot00000000000000(** This file contains the definition of paths over a path, together with some facts about them developed by Marc Bezem and Ulrik Buchholtz. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. (** ** Paths over paths in families of types *) Local Set Implicit Arguments. Local Unset Strict Implicit. Declare Scope pathsover. Delimit Scope pathsover with pathsover. Local Open Scope pathsover. (** A path in a family of types "over" a path in the base *) Definition PathOver {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') : Type. Proof. induction p. exact (y=y'). Defined. (** Paths-over versus path pairs *) Definition PathOverToPathPair {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') : PathOver p y y' → PathPair (x,,y) (x',,y'). Proof. intros q. induction p. exists (idpath x). cbn. exact q. Defined. Definition apd {X:Type} {Y : X -> Type} (s : ∏ x, Y x) {x x':X} (p : x = x') : PathOver p (s x) (s x'). Proof. now induction p. Defined. Definition PathOverToTotalPath {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') : PathOver p y y' → (x,,y) = (x',,y'). Proof. intros q. exact (invmap (total2_paths_equiv Y (x,, y) (x',, y')) (PathOverToPathPair q)). Defined. Lemma PathOverUniqueness {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) : ∃! (y' : Y x'), PathOver p y y'. Proof. induction p. apply iscontrcoconusfromt. Defined. Definition stdPathOver {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) : PathOver p y (transportf Y p y). Proof. now induction p. Defined. Definition stdPathOver' {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y' : Y x') : PathOver p (transportb Y p y') y'. Proof. now induction p. Defined. Definition identityPathOver {X:Type} {x:X} {Y : X -> Type} (y : Y x) : PathOver (idpath x) y y := idpath y. Definition pathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) : PathOver (idpath x) y y' = (y = y') := idpath _. Definition toPathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) : y = y' -> PathOver (idpath x) y y' := idfun _. Local Notation "'∇' q" := (toPathOverIdpath q) (at level 10) : pathsover. Definition fromPathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) : PathOver (idpath x) y y' -> y = y' := idfun _. Local Notation "'Δ' q" := (fromPathOverIdpath q) (at level 10) : pathsover. Definition inductionPathOver {X:Type} {x:X} {Y : X -> Type} (y : Y x) (T : ∏ x' (p : x = x') (y' : Y x'), PathOver p y y' → Type) (t : T x (idpath x) y (identityPathOver y)) : ∏ x' (y' : Y x') (p : x = x') (q : PathOver p y y'), T x' p y' q. Proof. intros. induction p, q. exact t. Defined. Definition transportPathOver {X:Type} {x x':X} {Y : X -> Type} (y : Y x) (y' : Y x') (p:x=x') (q : PathOver p y y') (T : ∏ (a:X) (b:Y a), Type) : T x y → T x' y'. Proof. now induction p, q. Defined. Definition transportPathOver' {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') (q : PathOver p y y') (T : ∏ (a:X) (b:Y a), Type) : T x' y' → T x y. Proof. now induction p, q. Defined. Definition composePathOver {X:Type} {x x' x'':X} {p:x=x'} {p':x'=x''} {Y : X -> Type} {y : Y x} {y' : Y x'} {y'' : Y x''} : PathOver p y y' → PathOver p' y' y'' → PathOver (p @ p') y y''. Proof. induction p, p'. exact pathscomp0. Defined. Local Notation "x * y" := (composePathOver x y) : pathsover. Definition composePathOverPath {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' y'' : Y x'} : PathOver p y y' → y' = y'' → PathOver p y y''. Proof. intros q e. now induction e. Defined. Local Notation "q ⟥ e" := (composePathOverPath q e) (at level 56, left associativity) : pathsover. Definition composePathOverIdpath {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y': Y x'} (q : PathOver p y y') : q ⟥ idpath y' = q. Proof. reflexivity. Defined. Definition composePathPathOver {X:Type} {x' x'':X} {p:x'=x''} {Y : X -> Type} {y y': Y x'} {y'' : Y x''} : y = y' → PathOver p y' y'' → PathOver p y y''. Proof. intros e q. now induction e. Defined. Local Notation "e ⟤ q" := (composePathPathOver e q) (at level 56, left associativity) : pathsover. Lemma composeIdpathPathOver {X:Type} {x' x'':X} {p:x'=x''} {Y : X -> Type} {y': Y x'} {y'' : Y x''} (q : PathOver p y' y'') : idpath y' ⟤ q = q. Proof. reflexivity. Defined. Lemma composePathPathOverRotate {X:Type} {x' x'':X} {p:x'=x''} {Y : X -> Type} {y y': Y x'} (q : y = y') {y'' : Y x''} (r : PathOver p y' y'') (s : PathOver p y y'') : q ⟤ r = s <-> r = (!q) ⟤ s. Proof. induction q. simpl. apply isrefl_logeq. Defined. Lemma composePathOverPathRotate {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' y'': Y x'} (r : PathOver p y y') (q : y' = y'') (s : PathOver p y y'') : r ⟥ q = s <-> r = s ⟥ (!q). Proof. induction q. simpl. apply isrefl_logeq. Defined. Lemma composePathPathOverPath {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y y' : Y x} {y'' y''': Y x'} (q : y = y') (r : PathOver p y' y'') (s : y'' = y''') : q ⟤ (r ⟥ s) = (q ⟤ r) ⟥ s. Proof. now induction q. Defined. Definition composePathOverLeftUnit {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') (q:PathOver p y y') : identityPathOver y * q = q. Proof. now induction p. Defined. Definition composePathOverRightUnit {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') (q:PathOver p y y') : q * identityPathOver y' = transportb (λ p, PathOver p y y') (pathscomp0rid _) q. Proof. now induction p, q. Defined. Definition assocPathOver {X:Type} {x x' x'' x''':X} {p:x=x'} {p':x'=x''} {p'':x''=x'''} {Y : X -> Type} {y : Y x} {y' : Y x'} {y'' : Y x''} {y''' : Y x'''} (q : PathOver p y y') (q' : PathOver p' y' y'') (q'' : PathOver p'' y'' y''') : transportf (λ ppp, PathOver ppp y y''') (path_assoc p p' p'') (q * (q' * q'')) = (q * q') * q''. Proof. induction p, p', p'', q, q', q''. reflexivity. Defined. Definition inversePathOver {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' : Y x'} : PathOver p y y' → PathOver (!p) y' y. Proof. intros q. induction p, q. reflexivity. Defined. Definition inversePathOver' {X:Type} {x x':X} {p:x'=x} {Y : X -> Type} {y : Y x} {y' : Y x'} : PathOver (!p) y y' → PathOver p y' y. Proof. intros q. induction p, q. reflexivity. Defined. Definition inverseInversePathOver1 {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' : Y x'} (s : PathOver p y y') : inversePathOver' (inversePathOver s) = s. Proof. induction p, s. reflexivity. Defined. Definition inverseInversePathOver2 {X:Type} {x x':X} {p:x'=x} {Y : X -> Type} {y : Y x} {y' : Y x'} (s : PathOver (!p) y y') : inversePathOver (inversePathOver' s) = s. Proof. induction p, s. reflexivity. Defined. Local Notation "q '^-1'" := (inversePathOver q) : pathsover. Definition inversePathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) (e : y = y') : inversePathOver (∇ e) = ∇ (!e). Proof. reflexivity. Defined. Definition inversePathOverIdpath' {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) (e : y = y') : inversePathOver' (∇ e : PathOver (! idpath x) y y') = ∇ (!e). Proof. reflexivity. Defined. Definition inverseInversePathOver {X:Type} {Y : X -> Type} {x:X} {y : Y x} : ∏ {x':X} {y' : Y x'} {p:x=x'} (q : PathOver p y y'), transportf (λ pp, PathOver pp y y') (pathsinv0inv0 p) (q^-1^-1) = q. Proof. now use inductionPathOver. Defined. Definition inversePathOverWeq {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' : Y x'} : PathOver p y y' ≃ PathOver (!p) y' y. Proof. (* compare with weqpathsinv0 *) exists inversePathOver. intros s. use tpair. - exists (inversePathOver' s). apply inverseInversePathOver2. - cbn. induction p. intros [t []]. induction t. reflexivity. Defined. Lemma inversePathOverWeq' {X:Type} {x x':X} {p:x'=x} {Y : X -> Type} {y : Y x} {y' : Y x'} : PathOver (!p) y y' ≃ PathOver p y' y. Proof. (* compare with weqpathsinv0 *) exists inversePathOver'. intros s. use tpair. - exists (inversePathOver s). apply inverseInversePathOver1. - cbn. induction p. intros [t []]. induction t. reflexivity. Defined. (** Paths-over in a constant family *) Definition PathOverConstant_id {X:Type} {x x':X} (p:x=x') {Z : Type} (z : Z) (z' : Z) : (z = z') = (PathOver p z z'). Proof. now induction p. Defined. Definition PathOverConstant_map1 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' : Z} : z = z' -> PathOver p z z'. Proof. now induction p. Defined. Definition PathOverConstant_map1_eq1 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' z'' : Z} (q: z = z') (r : z' = z'') : PathOverConstant_map1 p (q @ r) = PathOverConstant_map1 p q ⟥ r. Proof. now induction r, q. Defined. Definition PathOverConstant_map1_eq2 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' z'' : Z} (q: z = z') (r : z' = z'') : PathOverConstant_map1 p (q @ r) = q ⟤ PathOverConstant_map1 p r. Proof. now induction r, q. Defined. Definition PathOverConstant_map2 {X:Type} {x x':X} {p:x=x'} {Z : Type} {z z' : Z} : PathOver p z z' -> z = z'. Proof. now induction p. Defined. Definition PathOverConstant_map2_apd {X:Type} {x x':X} {p:x=x'} {Z : Type} {f : X -> Z} : PathOverConstant_map2 (apd f p) = maponpaths f p. Proof. now induction p. Defined. Definition PathOverConstant_map2_eq1 {X:Type} {x x':X} {p:x=x'} {Z : Type} {z z' z'' : Z} (q: PathOver p z z') (r : z' = z'') : PathOverConstant_map2 (q ⟥ r) = PathOverConstant_map2 q @ r. Proof. induction r. change (q ⟥ idpath z') with q. apply pathsinv0, pathscomp0rid. Defined. Definition PathOverConstant_map2_eq2 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' z'' : Z} (r : z = z') (q: PathOver p z' z'') : PathOverConstant_map2 (r ⟤ q) = r @ PathOverConstant_map2 q. Proof. now induction r. Defined. Lemma PathOverConstant_map1_map2 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' : Z} (q : z = z') : PathOverConstant_map2 (PathOverConstant_map1 p q) = q. Proof. now induction p. Defined. (** lemmas *) Lemma Lemma023 (A:Type) (B:A->Type) (a1 a2 a3:A) (b1:B a1) (b2:B a2) (b3:B a3) (p1:a1=a2) (p2:a2=a3) (q:PathOver p1 b1 b2) : isweq (composePathOver q : PathOver p2 b2 b3 -> PathOver (p1@p2) b1 b3). Proof. induction p1, p2, q. apply idisweq. Defined. Definition composePathOver_weq (A:Type) (a1 a2 a3:A) (B:A->Type) (b1:B a1) (b2:B a2) (b3:B a3) (p1:a1=a2) (p2:a2=a3) (q:PathOver p1 b1 b2) : PathOver p2 b2 b3 ≃ PathOver (p1@p2) b1 b3 := make_weq (composePathOver q) (Lemma023 _). Lemma Lemma0_2_4 (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) : isweq ((transportf (λ pp, PathOver pp b1 b2) α) : PathOver p b1 b2 -> PathOver q b1 b2). Proof. induction α. apply idisweq. Defined. Definition cp (* "change path" *) (A:Type) (a1 a2:A) (p q:a1=a2) (α : p=q) (B:A->Type) (b1:B a1) (b2:B a2) : PathOver p b1 b2 ≃ PathOver q b1 b2 := make_weq (transportf (λ pq, PathOver pq b1 b2) α) (Lemma0_2_4 α). Arguments cp {_ _ _ _ _} _ {_ _ _}. Definition composePathOverPath_compute {X:Type} {x x':X} {p:x=x'} {Y : X -> Type} {y : Y x} {y' y'' : Y x'} (q : PathOver p y y') (e : y' = y'') : q ⟥ e = cp (pathscomp0rid p) (q * ∇ e). Proof. now induction p, q, e. Defined. Definition composePathPathOver_compute {X:Type} {x' x'':X} {p:x'=x''} {Y : X -> Type} {y y': Y x'} {y'' : Y x''} (e : y = y') (q : PathOver p y' y'') : e ⟤ q = ∇ e * q. Proof. now induction p. Defined. Definition cp_idpath (A:Type) (a1 a2:A) (p:a1=a2) (B:A->Type) (b1:B a1) (b2:B a2) (u:PathOver p b1 b2) : cp (idpath p) u = u. Proof. reflexivity. Defined. Definition cp_left (A:Type) (a2 a3:A) (p p':a2=a3) (α:p=p') (B:A->Type) (b1 b2:B a2) (b3:B a3) (r:PathOver (idpath a2) b1 b2) (q:PathOver p b2 b3) : r * cp α q = cp α (r*q). Proof. now induction r, α. Defined. Definition cp_right (A:Type) (a1 a2:A) (p p':a1=a2) (α:p=p') (B:A->Type) (b1:B a1) (b2 b3:B a2) (q:PathOver p b1 b2) (r:PathOver (idpath a2) b2 b3) : cp α q * r = cp (maponpaths (λ p, p @ idpath a2) α) (q*r). Proof. now induction r, α. Defined. Definition cp_in_family (A:Type) (a1 a2:A) (T:Type) (t0 t1:T) (v:t0=t1) (p:T->a1=a2) (B:A->Type) (b1:B a1) (b2:B a2) (s : ∏ t, PathOver (p t) b1 b2) : cp (maponpaths p v) (s t0) = s t1. Proof. now induction v. Defined. Definition cp_irrelevance (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α β: p=q) : isofhlevel 3 A -> cp (b1:=b1) (b2:=b2) α = cp (b1:=b1) (b2:=b2) β. Proof. intros ih. apply (maponpaths (λ α, cp α)). apply ih. Defined. Local Goal ∏ (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (r : PathOver p b1 b2) (s : PathOver q b1 b2), (cp α r = s) = (PathOver (Y := λ pq, PathOver pq _ _) α r s). Proof. intros. induction α, p. reflexivity. Defined. Definition inverse_cp_p (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (t : PathOver p b1 b2) : cp (! α) (cp α t) = t. Proof. now induction α. Defined. Definition inverse_cp_p' (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (t : PathOver p b1 b2) (u : PathOver q b1 b2) : PathOver (Y := λ pq, PathOver pq _ _) α t u -> PathOver (Y := λ pq, PathOver pq _ _) (!α) u t. Proof. exact inversePathOver. Defined. Definition inverse_cp_p'' (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (t : PathOver p b1 b2) (u : PathOver q b1 b2) : PathOver (Y := λ pq, PathOver pq _ _) α t u -> PathOver (Y := λ pq, PathOver pq _ _) (!α) u t. Proof. intros k. induction α, p, k. reflexivity. Defined. Lemma inverse_cp_p_compare (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (t : PathOver p b1 b2) (u : PathOver q b1 b2) (k : PathOver α t u) : inverse_cp_p' k = inverse_cp_p'' k. Proof. induction α,p. reflexivity. Defined. Definition cp_inverse_cp (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) (t : PathOver q b1 b2) : cp α (cp (! α) t) = t. Proof. now induction α. Defined. Definition composePathOverRightInverse {X:Type} {x x':X} {Y : X -> Type} {y : Y x} {y' : Y x'} {p:x=x'} (q : PathOver p y y') : q * q^-1 = cp (!pathsinv0r p) (identityPathOver y). Proof. now induction p, q. Defined. Definition composePathOverLeftInverse {X:Type} {x x':X} {Y : X -> Type} {y : Y x} {y' : Y x'} {p:x=x'} (q : PathOver p y y') : q^-1 * q = cp (!pathsinv0l p) (identityPathOver y'). Proof. now induction p, q. Defined. Lemma cp_pathscomp0 (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q r:a1=a2) (α : p=q) (β : q=r) (s : PathOver p b1 b2) : cp (b1:=b1) (b2:=b2) (α @ β) s = cp β (cp α s). Proof. now induction α. Defined. (* a frequently-useful specialisation of [maponpaths_12] *) Definition apstar (* 0.2.7 *) (A:Type) (a1 a2 a3:A) (p p':a1=a2) (q q':a2=a3) : p=p' -> q=q' -> p @ q = p' @ q'. Proof. intros; apply maponpaths_12; assumption. Defined. Definition cp_apstar (A:Type) (B:A->Type) (a1 a2 a3:A) (p p':a1=a2) (q q':a2=a3) (α : p=p') (β : q=q') (b1:B a1) (b2:B a2) (b3:B a3) (pp : PathOver p b1 b2) (qq : PathOver q b2 b3) : cp (apstar α β) (pp * qq) = cp α pp * cp β qq. Proof. now induction p, α, β. Defined. Definition cp_apstar' (A:Type) (B:A->Type) (a1 a2:A) (p:a2=a1) (p':a1=a2) (α : !p=p') (b1:B a1) (b2:B a2) (pp : PathOver (Y:=B) p b2 b1) : cp α (pp^-1) = inversePathOver' (cp (invrot α) pp). Proof. now induction α, p. Defined. (* what a path-over is in a family of equations *) Lemma pathOverEquations {X Y:Type} {f g : X -> Y} {x x' : X} (e : f x = g x) (e' : f x' = g x') (p : x = x') : PathOver (Y := λ x, f x = g x) p e e' = ( e @ maponpaths g p = maponpaths f p @ e' ). Proof. induction p. simpl. apply (maponpaths (λ r, r = e')). apply pathsinv0, pathscomp0rid. Defined. Lemma pathOverEquations1 {X:Type} {f : X -> X} {x x' : X} (e : f x = x) (e' : f x' = x') (p : x = x') : PathOver (Y := λ x, f x = x) p e e' = ( e @ p = maponpaths f p @ e' ). Proof. induction p. simpl. apply (maponpaths (λ r, r = e')). apply pathsinv0, pathscomp0rid. Defined. (* functoriality *) Definition mapPathOver {X:Type} {x x':X} (p:x=x') {Y Y': X -> Type} (f : ∏ x, Y x -> Y' x) (y : Y x) (y' : Y x') : PathOver p y y' -> PathOver p (f x y) (f x' y'). Proof. induction p. simpl. intros []. reflexivity. Defined. Definition binopPathOver {X:Type} {x x':X} (p:x=x') {Y Z W : X -> Type} (f : ∏ x, Y x -> Z x -> W x) (y : Y x) (y' : Y x') (z : Z x) (z' : Z x') : PathOver p y y' -> PathOver p z z' -> PathOver p (f x y z) (f x' y' z'). Proof. induction p. simpl. intros [] []. reflexivity. Defined. Local Unset Implicit Arguments. Definition pullBackFamily {X X':Type} (g : X -> X') (Y : X' -> Type) := λ x, Y (g x). Definition pullBackSection {X X':Type} (g : X -> X') {Y : X' -> Type} (f : ∏ x', Y x') := λ x, f (g x). Definition pullBackPointOver {X X':Type} (g : X -> X') {x:X} {x':X'} (r : g x = x') {Y : X' -> Type} (y : Y x') : (pullBackFamily g Y) (x). Proof. induction r. exact y. Defined. Definition pullBackPointOverWithSection {X X':Type} (g : X -> X') {x:X} {x':X'} (r : g x = x') {Y : X' -> Type} (f : ∏ x', Y x') : pullBackPointOver g r (f x') = pullBackSection g f x. Proof. induction r. reflexivity. Defined. Definition pullBackPointOverWithSection' (* redundant? *) {X X':Type} (g : X -> X') {x:X} {x':X'} (r : g x = x') {Y : X' -> Type} {y : Y x'} {f : ∏ x', Y x'} (k : y = f x') : pullBackPointOver g r y = pullBackSection g f x. Proof. induction (!k), r. reflexivity. Defined. Definition pullBackPathOverPoint {X X':Type} (g : X -> X') {x:X} {x':X'} (r : g x = x') {Y : X' -> Type} {y y' : Y x'} (t : y = y') : pullBackPointOver g r y = pullBackPointOver g r y'. Proof. apply maponpaths; assumption. Defined. Definition pullBackPathOver {X X':Type} (g : X -> X') {x1 x2:X} {x1' x2':X'} {r1 : g x1 = x1'} {r2 : g x2 = x2'} {s : x1 = x2} {s' : x1' = x2'} (r : r1 @ s' = maponpaths g s @ r2) {Y : X' -> Type} {y1 : Y x1'} {y2 : Y x2'} (q : PathOver s' y1 y2) : PathOver s (pullBackPointOver g r1 y1) (pullBackPointOver g r2 y2). Proof. induction r1, r2. simpl in r; simpl. assert (k' : s' = maponpaths g s). { refine (r @ pathscomp0rid _). } clear r. induction (!k'); clear k'. induction s. simpl in q. simpl. exact q. Defined. Definition pullBackPathOverPath {X X':Type} (g : X -> X') {x1 x2:X} {x1' x2':X'} {r1 : g x1 = x1'} {r2 : g x2 = x2'} {s : x1 = x2} {s' : x1' = x2'} (r : r1 @ s' = maponpaths g s @ r2) {Y : X' -> Type} (y1 : Y x1') (y2 y3 : Y x2') (q : PathOver s' y1 y2) (t : y2 = y3) : pullBackPathOver g r (q ⟥ t) = pullBackPathOver g r q ⟥ pullBackPathOverPoint g r2 t. Proof. induction t, r1, r2. reflexivity. Defined. Definition pullBackPathPathOver {X X':Type} (g : X -> X') {x1 x2:X} {x1' x2':X'} (r1 : g x1 = x1') (r2 : g x2 = x2') (s : x1 = x2) (s' : x1' = x2') (r : r1 @ s' = maponpaths g s @ r2) {Y : X' -> Type} (y0 y1 : Y x1') (y2 : Y x2') (q : PathOver s' y1 y2) (t : y0 = y1) : pullBackPathOver g r (t ⟤ q) = pullBackPathOverPoint g r1 t ⟤ pullBackPathOver g r q. Proof. induction t, r1, r2. reflexivity. Defined. Module PathsOverNotations. Notation "'Δ' q" := (fromPathOverIdpath q) (at level 10) : pathsover. Notation "'∇' q" := (toPathOverIdpath q) (at level 10) : pathsover. Notation "x * y" := (composePathOver x y) : pathsover. Notation "q ⟥ e" := (composePathOverPath q e) (at level 56, left associativity) : pathsover. Notation "e ⟤ q" := (composePathPathOver e q) (at level 56, left associativity) : pathsover. Notation "q '^-1'" := (inversePathOver q) : pathsover. End PathsOverNotations. UniMath-20231010/UniMath/MoreFoundations/Propositions.v000066400000000000000000000306171451125700300226760ustar00rootroot00000000000000Require Export UniMath.MoreFoundations.Notations. Require Export UniMath.MoreFoundations.PartA. Require Export UniMath.MoreFoundations.Tactics. Require Export UniMath.MoreFoundations.DecidablePropositions. Local Open Scope logic. Local Open Scope type. Lemma ishinh_irrel {X:UU} (x:X) (x':∥X∥) : hinhpr x = x'. Proof. apply proofirrelevance. apply propproperty. Defined. Corollary squash_to_hProp {X:UU} {Q:hProp} : ∥ X ∥ -> (X -> Q) -> Q. Proof. intros h f. exact (hinhuniv f h). Defined. Lemma hdisj_impl_1 {P Q : hProp} : P∨Q -> (Q->P) -> P. Proof. intros o f. apply (squash_to_hProp o). intros [p|q]. - exact p. - exact (f q). Defined. Lemma hdisj_impl_2 {P Q : hProp} : P∨Q -> (P->Q) -> Q. Proof. intros o f. apply (squash_to_hProp o). intros [p|q]. - exact (f p). - exact q. Defined. Definition weqlogeq (P Q : hProp) : (P = Q) ≃ (P ⇔ Q). Proof. intros. apply weqimplimpl. - intro e. induction e. apply isrefl_logeq. - intro c. apply hPropUnivalence. + exact (pr1 c). + exact (pr2 c). - apply isasethProp. - apply propproperty. Defined. Lemma decidable_proof_by_contradiction {P:hProp} : decidable P -> ¬ ¬ P -> P. Proof. intros dec nnp. induction dec as [p|np]. - exact p. - apply fromempty. exact (nnp np). Defined. Lemma proof_by_contradiction {P:hProp} : LEM -> ¬ ¬ P -> P. Proof. intro lem. exact (decidable_proof_by_contradiction (lem P)). Defined. Lemma dneg_elim_to_LEM : (∏ P:hProp, ¬ ¬ P -> P) -> LEM. (* a converse for Lemma dneg_LEM *) Proof. intros dne. intros P. simple refine (dne (_,,_) _). simpl. intros n. assert (q : ¬ (P ∨ ¬ P)). { now apply weqnegtonegishinh. } assert (r := fromnegcoprod_prop q). exact (pr2 r (pr1 r)). Defined. Lemma negforall_to_existsneg {X:UU} (P:X->hProp) : LEM -> (¬ ∀ x, P x) -> (∃ x, ¬ (P x)). (* was omitted from the section on "Negation and quantification" in Foundations/Propositions.v *) Proof. intros lem nf. apply (proof_by_contradiction lem); intro c. use nf; clear nf. intro x. assert (q := neghexisttoforallneg _ c x); clear c; simpl in q. exact (proof_by_contradiction lem q). Defined. Lemma negimpl_to_conj (P Q:hProp) : LEM -> ( ¬ (P ⇒ Q) -> P ∧ ¬ Q ). Proof. intros lem ni. assert (r := negforall_to_existsneg _ lem ni); clear lem ni. apply (squash_to_hProp r); clear r; intros [p nq]. exact (p,,nq). Defined. Definition hrel_set (X : hSet) : hSet := make_hSet (hrel X) (isaset_hrel X). Lemma isaprop_assume_it_is {X : UU} : (X -> isaprop X) -> isaprop X. Proof. intros f. apply invproofirrelevance; intros x y. apply proofirrelevance. now apply f. Defined. Lemma isaproptotal2 {X : UU} (P : X → UU) : isPredicate P → (∏ x y : X, P x → P y → x = y) → isaprop (∑ x : X, P x). Proof. intros HP Heq. apply invproofirrelevance. intros [x p] [y q]. induction (Heq x y p q). induction (iscontrpr1 (HP x p q)). apply idpath. Defined. (* this is the dependent eliminator for propositional truncation *) Lemma squash_rec {X : UU} (P : ∥ X ∥ -> hProp) : (∏ x, P (hinhpr x)) -> (∏ x, P x). Proof. intros xp x'. simple refine (hinhuniv _ x'). intro x. assert (q : hinhpr x = x'). { apply propproperty. } induction q. exact (xp x). Defined. (* here we show that the dependent eliminator does not compute judgmentally *) Goal ∏ {X:UU} {P:∥X∥ -> hProp} (h : ∏ x, P (hinhpr x)) (x:X), squash_rec _ h (hinhpr x) = h x. Proof. Fail reflexivity. (* too bad! *) Abort. (* here's another version *) Goal ∏ (X:Type) (P := λ x':∥X∥, ∃ x, (x' = hinhpr x)) (h := λ x, (hinhpr (x,,idpath _) : P (hinhpr x))) (x:X), squash_rec _ h (hinhpr x) = h x. Proof. Fail reflexivity. (* too bad! *) Abort. Lemma logeq_if_both_true (P Q : hProp) : P -> Q -> ( P ⇔ Q ). Proof. intros p q. split. - intros _. exact q. - intros _. exact p. Defined. Lemma logeq_if_both_false (P Q : hProp) : ¬P -> ¬Q -> ( P ⇔ Q ). Proof. intros np nq. split. - intros p. apply fromempty. exact (np p). - intros q. apply fromempty. exact (nq q). Defined. Definition proofirrelevance_hProp (X : hProp) : isProofIrrelevant X := proofirrelevance X (propproperty X). Ltac induction_hProp x y := induction (proofirrelevance_hProp _ x y). Definition iscontr_hProp (X:UU) : hProp := make_hProp (iscontr X) (isapropiscontr X). Notation "'∃!' x .. y , P" := (iscontr_hProp (∑ x, .. (∑ y, P) ..)) (at level 200, x binder, y binder, right associativity) : logic. (* type this in emacs in agda-input method with \ex ! *) (** Various algebraic properties of hProp *) Section hProp_logic. (** We first state the algebraic properties as bi-implications *) (* This is already in Foundations/Propositions.v *) (* Lemma islogeqcommhdisj {P Q : hProp} : hdisj P Q <-> hdisj Q P. *) Lemma islogeqassochconj {P Q R : hProp} : (P ∧ Q) ∧ R <-> P ∧ (Q ∧ R). Proof. split. - intros PQR. exact (pr1 (pr1 PQR),,(pr2 (pr1 PQR),,pr2 PQR)). - intros PQR. exact ((pr1 PQR,,pr1 (pr2 PQR)),,pr2 (pr2 PQR)). Defined. Lemma islogeqcommhconj {P Q : hProp} : P ∧ Q <-> Q ∧ P. Proof. split. - intros PQ. exact (pr2 PQ,,pr1 PQ). - intros QP. exact (pr2 QP,,pr1 QP). Defined. Lemma islogeqassochdisj {P Q R : hProp} : (P ∨ Q) ∨ R <-> P ∨ (Q ∨ R). Proof. split. - apply hinhuniv; intros hPQR. induction hPQR as [hPQ|hR]. + use (hinhuniv _ hPQ); clear hPQ; intros hPQ. induction hPQ as [hP|hQ]. * exact (hinhpr (ii1 hP)). * exact (hinhpr (ii2 (hinhpr (ii1 hQ)))). + exact (hinhpr (ii2 (hinhpr (ii2 hR)))). - apply hinhuniv; intros hPQR. induction hPQR as [hP|hQR]. + exact (hinhpr (ii1 (hinhpr (ii1 hP)))). + use (hinhuniv _ hQR); clear hQR; intros hQR. induction hQR as [hQ|hR]. * exact (hinhpr (ii1 (hinhpr (ii2 hQ)))). * exact (hinhpr (ii2 hR)). Defined. Lemma islogeqhconj_absorb_hdisj {P Q : hProp} : P ∧ (P ∨ Q) <-> P. Proof. split. - intros hPPQ; apply (pr1 hPPQ). - intros hP. split; [ apply hP | apply (hinhpr (ii1 hP)) ]. Defined. Lemma islogeqhdisj_absorb_hconj {P Q : hProp} : P ∨ (P ∧ Q) <-> P. Proof. split. - apply hinhuniv; intros hPPQ. induction hPPQ as [hP|hPQ]. + exact hP. + exact (pr1 hPQ). - intros hP; apply (hinhpr (ii1 hP)). Defined. Lemma islogeqhfalse_hdisj {P : hProp} : ∅ ∨ P <-> P. Proof. split. - apply hinhuniv; intros hPPQ. induction hPPQ as [hF|hP]. + induction hF. + exact hP. - intros hP; apply (hinhpr (ii2 hP)). Defined. Lemma islogeqhhtrue_hconj {P : hProp} : htrue ∧ P <-> P. Proof. split. - intros hP; apply (pr2 hP). - intros hP. split; [ apply tt | apply hP ]. Defined. (** We now turn these into equalities using univalence for propositions *) Lemma isassoc_hconj (P Q R : hProp) : ((P ∧ Q) ∧ R) = (P ∧ (Q ∧ R)). Proof. now apply hPropUnivalence; apply islogeqassochconj. Qed. Lemma iscomm_hconj (P Q : hProp) : (P ∧ Q) = (Q ∧ P). Proof. now apply hPropUnivalence; apply islogeqcommhconj. Qed. Lemma isassoc_hdisj (P Q R : hProp) : ((P ∨ Q) ∨ R) = (P ∨ (Q ∨ R)). Proof. now apply hPropUnivalence; apply islogeqassochdisj. Qed. Lemma iscomm_hdisj (P Q : hProp) : (P ∨ Q) = (Q ∨ P). Proof. now apply hPropUnivalence; apply islogeqcommhdisj. Qed. Lemma hconj_absorb_hdisj (P Q : hProp) : (P ∧ (P ∨ Q)) = P. Proof. now apply hPropUnivalence; apply islogeqhconj_absorb_hdisj. Qed. Lemma hdisj_absorb_hconj (P Q : hProp) : (P ∨ (P ∧ Q)) = P. Proof. now apply hPropUnivalence; apply islogeqhdisj_absorb_hconj. Qed. Lemma hfalse_hdisj (P : hProp) : (∅ ∨ P) = P. Proof. now apply hPropUnivalence; apply islogeqhfalse_hdisj. Qed. Lemma htrue_hconj (P : hProp) : (htrue ∧ P) = P. Proof. now apply hPropUnivalence; apply islogeqhhtrue_hconj. Qed. End hProp_logic. (** ** Factoring maps through squash *) Lemma squash_uniqueness {X} (x:X) (h:∥ X ∥) : squash_element x = h. Proof. intros. apply propproperty. Qed. Goal ∏ X Q (i:isaprop Q) (f:X -> Q) (x:X), factor_through_squash i f (squash_element x) = f x. Proof. reflexivity. Defined. Lemma factor_dep_through_squash {X} {Q:∥ X ∥->UU} : (∏ h, isaprop (Q h)) -> (∏ x, Q(squash_element x)) -> (∏ h, Q h). Proof. intros i f ?. apply (h (make_hProp (Q h) (i h))). intro x. simpl. induction (squash_uniqueness x h). exact (f x). Defined. Lemma factor_through_squash_hProp {X} : ∏ hQ:hProp, (X -> hQ) -> ∥ X ∥ -> hQ. Proof. intros [Q i] f h. refine (h _ _). assumption. Defined. Lemma funspace_isaset {X Y} : isaset Y -> isaset (X -> Y). Proof. intros is. apply (impredfun 2). assumption. Defined. Lemma squash_map_uniqueness {X S} (ip : isaset S) (g g' : ∥ X ∥ -> S) : g ∘ squash_element ~ g' ∘ squash_element -> g ~ g'. Proof. intros h. set ( Q := λ y, g y = g' y ). unfold homot. apply (@factor_dep_through_squash X). intros y. apply ip. intro x. apply h. Qed. Lemma squash_map_epi {X S} (ip : isaset S) (g g' : ∥ X ∥ -> S) : g ∘ squash_element = g'∘ squash_element -> g = g'. Proof. intros e. apply funextsec. apply squash_map_uniqueness. exact ip. intro x. induction e. apply idpath. Qed. Lemma uniqueExists {A : UU} {P : A -> UU} {a b : A} (Hexists : ∃! a, P a) (Ha : P a) (Hb : P b) : a = b. Proof. assert (H : tpair _ _ Ha = tpair _ _ Hb). { now apply proofirrelevancecontr. } exact (base_paths _ _ H). Defined. (** ** Connected types *) Definition isConnected X : hProp := ∥ X ∥ ∧ ∀ (x y:X), ∥ x = y ∥. Lemma predicateOnConnectedType {X:Type} (i : isConnected X) {P:X->hProp} (x0:X) (p:P x0) : ∏ x, P x. Proof. intros x. apply (squash_to_hProp (pr2 i x x0)); intros e. now induction e. Defined. Definition isBaseConnected (X:PointedType) : hProp := ∀ (y:X), ∥ basepoint X = y ∥. Lemma isConnected_isBaseConnected (X:PointedType) : isConnected X <-> isBaseConnected X. Proof. split. - intros [_ ic] x. use ic. - intros ibc. split. + exact (hinhpr (basepoint X)). + intros x y. apply (squash_to_hProp (ibc x)); intros p; apply (squash_to_hProp (ibc y)); intros q. exact (hinhpr (!p @ q)). Defined. Definition BasePointComponent (X:PointedType) : PointedType := pointedType (∑ (y:X), ∥ basepoint X = y ∥) (basepoint X,, hinhpr (idpath (basepoint X))). Definition basePointComponent_inclusion {X:PointedType} (x : BasePointComponent X) : X := pr1 x. Lemma BasePointComponent_isBaseConnected (X:PointedType) : isBaseConnected (BasePointComponent X). Proof. intros [x' c']. change (basepoint (BasePointComponent X)) with (tpair (λ (y:X), ∥ basepoint X = y ∥) (basepoint X) (hinhpr (idpath (basepoint X)))). use (hinhfun _ c'); intro q. induction q. apply maponpaths. apply propproperty. Defined. Lemma BasePointComponent_isincl {X:PointedType} : isincl (@basePointComponent_inclusion X). Proof. use isinclpr1. intros x. apply propproperty. Defined. Lemma BasePointComponent_isweq {X:PointedType} (bc : isBaseConnected X) : isweq (@basePointComponent_inclusion X). Proof. use isweqpr1. intros x. apply iscontraprop1. - apply propproperty. - exact (bc x). Defined. Definition BasePointComponent_weq {X:PointedType} (bc : isBaseConnected X) : BasePointComponent X ≃ X := make_weq (@basePointComponent_inclusion X) (BasePointComponent_isweq bc). Lemma baseConnectedness X : isBaseConnected X -> isConnected X. Proof. intros p. split. - exact (hinhpr (basepoint X)). - intros x y. assert (a := p x); assert (b := p y); clear p. apply (squash_to_prop a); [apply propproperty|]; clear a; intros a. apply (squash_to_prop b); [apply propproperty|]; clear b; intros b. apply hinhpr. exact (!a@b). Defined. Lemma predicateOnBaseConnectedType (X:PointedType) (b:isBaseConnected X) (P:X->hProp) (p:P (basepoint X)) : ∏ x, P x. Proof. intros x. apply (squash_to_hProp (b x)); intros e. now induction e. Defined. Goal ∏ (X:PointedType) (b:isBaseConnected X) (P:X->hProp) (p:P (basepoint X)), predicateOnBaseConnectedType X b P p (basepoint X) = p. Proof. Fail reflexivity. intros. (* stuck *) Abort. Lemma predicateOnBasePointComponent (X:PointedType) (X' := BasePointComponent X) (pt' := basepoint X') (P:X'->hProp) (p:P pt') : ∏ x, P x. Proof. intros x. apply (squash_to_hProp (BasePointComponent_isBaseConnected _ x)); intros e. now induction e. Defined. Goal ∏ (X:PointedType) (X' := BasePointComponent X) (pt' := basepoint X') (P:X'->hProp) (p:P pt'), predicateOnBasePointComponent X P p pt' = p. Proof. Fail reflexivity. intros. unfold pt', basepoint, X', BasePointComponent, pointedType, pr2; cbn beta. Abort. UniMath-20231010/UniMath/MoreFoundations/QuotientSet.v000066400000000000000000000043161451125700300224470ustar00rootroot00000000000000(* -*- coding: utf-8 -*- *) Require Import UniMath.Foundations.Sets UniMath.MoreFoundations.PartA. Definition iscomprelfun2' {X Y Z} (RX:hrel X) (RY:hrel Y) (f:X->Y->Z) : Type := (∏ x x', RX x x' -> ∏ y, f x y = f x' y) × (∏ y y', RY y y' -> ∏ x, f x y = f x y'). Definition iscomprelrelfun2' {X Y Z} (RX:hrel X) (RY:hrel Y) (RZ:eqrel Z) (f:X->Y->Z) : Type := (∏ x x' y, RX x x' -> RZ (f x y) (f x' y)) × (∏ x y y', RY y y' -> RZ (f x y) (f x y')). Lemma setquotuniv_equal { X : UU } ( R : hrel X ) ( Y : hSet ) ( f f' : X -> Y ) (p : f = f') ( is : iscomprelfun R f ) ( is' : iscomprelfun R f' ) : setquotuniv R Y f is = setquotuniv R Y f' is'. Proof. intros. destruct p. apply funextsec; intro c. assert(ip : isaprop (iscomprelfun R f)). { apply impred; intro x; apply impred; intro x'. apply impred; intro p. apply setproperty. } assert( q : is = is' ). { apply ip. } destruct q. reflexivity. Qed. Definition setquotuniv2' {X Y} (RX:hrel X) (RY:hrel Y) {Z:hSet} (f:X->Y->Z) (is:iscomprelfun2' RX RY f) : setquot RX -> setquot RY -> Z. Proof. intros x''. simple refine (setquotuniv RX (funset (setquot RY) Z) _ _ _). { simpl. intro x. apply (setquotuniv RY Z (f x)). intros y y' e. unfold iscomprelfun2 in is. apply (pr2 is). assumption. } { intros x x' e. assert( p : f x = f x' ). { apply funextsec; intro y. apply (pr1 is). assumption. } apply setquotuniv_equal. assumption. } assumption. Defined. Definition setquotfun2' {X Y Z} {RX:hrel X} {RY:hrel Y} {RZ:eqrel Z} (f:X->Y->Z) (is:iscomprelrelfun2' RX RY RZ f) : setquot RX -> setquot RY -> setquot RZ. Proof. set (f' := λ x y, setquotpr RZ (f x y) : setquotinset RZ). apply (setquotuniv2' RX RY f'). split. { intros ? ? p ?. apply iscompsetquotpr. exact (pr1 is x x' y p). } { intros ? ? p ?. apply iscompsetquotpr. exact (pr2 is x y y' p). } Defined. Lemma setquotfun2_equal {X Y Z} (RX:eqrel X) (RY:eqrel Y) (RZ:eqrel Z) (f:X->Y->Z) (is:iscomprelrelfun2' RX RY RZ f) (x:X) (y:Y) : setquotfun2' f is (setquotpr RX x) (setquotpr RY y) = setquotpr RZ (f x y). Proof. reflexivity. (* it computes! *) Defined. UniMath-20231010/UniMath/MoreFoundations/README.md000066400000000000000000000014631451125700300212530ustar00rootroot00000000000000MoreFoundations =============== This package is a repository for auxiliary material at a basic level, such as in the package "Foundations", which doesn't fit into one of the large categories represented by a later package. The material in this package is envisioned as being generally useful in any of the other later packages, so it comes second on the list of of packages in the Makefile. Overview of contents ==================== ## QuotientSet.v Some lemmas about quotient sets. ## Equivalences.v the proof that an equivalence, defined as a pair of maps with a pair of homotopies and an adjointness relation, is invertible. ## Interval.v A proof that squashing a two-element set yields an interval, together with the resulting proof of function extensionality for sections, using propositional truncation. UniMath-20231010/UniMath/MoreFoundations/Sets.v000066400000000000000000000220251451125700300210760ustar00rootroot00000000000000(** ** More results on sets *) Require Export UniMath.MoreFoundations.Propositions. Require Export UniMath.Foundations.Sets. (** ** Contents - (More entries need to be added here...) - Other universal properties for [setquot] - The equivalence relation of being in the same fiber - Subsets - Binary relations *) Local Open Scope logic. Definition hProp_set : hSet := make_hSet _ isasethProp. Definition isconst {X:UU} {Y:hSet} (f : X -> Y) : hProp := ∀ x x', f x = f x'. Definition squash_to_hSet {X : UU} {Y : hSet} (f : X -> Y) : isconst f -> ∥ X ∥ -> Y. Proof. apply squash_to_set, setproperty. Defined. Definition isconst_2 {X Y:UU} {Z:hSet} (f : X -> Y -> Z) : hProp := ∀ x x' y y', f x y = f x' y'. Definition squash_to_hSet_2 {X Y : UU} {Z : hSet} (f : X -> Y -> Z) : isconst_2 f -> ∥ X ∥ -> ∥ Y ∥ -> Z. Proof. intros c. use squash_to_set. { apply isaset_forall_hSet. } { intros x. use squash_to_hSet. exact (f x). intros y y'. exact (c x x y y'). } { intros x x'. apply funextfun; intros yn. apply (squash_to_prop yn). { apply setproperty. } intros y. assert (e : hinhpr y = yn). { apply propproperty. } induction e. change ( f x y = f x' y ). exact (c x x' y y). } Defined. Definition isconst_2' {X Y:UU} {Z:hSet} (f : X -> Y -> Z) : hProp := (∀ x x' y, f x y = f x' y) ∧ (∀ x y y', f x y = f x y'). Definition squash_to_hSet_2' {X Y : UU} {Z : hSet} (f : X -> Y -> Z) : isconst_2' f -> ∥ X ∥ -> ∥ Y ∥ -> Z. Proof. intros [c d]. use squash_to_set. { apply isaset_forall_hSet. } { intros x. use squash_to_hSet. exact (f x). intros y y'. exact (d x y y'). } { intros x x'. apply funextfun; intros yn. apply (squash_to_prop yn). { apply setproperty. } intros y. assert (e : hinhpr y = yn). { apply propproperty. } induction e. change ( f x y = f x' y ). exact (c x x' y). } Defined. Definition eqset_to_path {X:hSet} (x y:X) : eqset x y -> paths x y := λ e, e. Lemma isapropiscomprelfun {X : UU} {Y : hSet} (R : hrel X) (f : X -> Y) : isaprop (iscomprelfun R f). Proof. apply impred. intro x. apply impred. intro x'. apply impred. intro r. apply Y. Defined. Lemma iscomprelfun_funcomp {X Y Z : UU} {R : hrel X} {S : hrel Y} {f : X → Y} {g : Y → Z} (Hf : iscomprelrelfun R S f) (Hg : iscomprelfun S g) : iscomprelfun R (g ∘ f). Proof. intros x x' r. exact (Hg _ _ (Hf x x' r)). Defined. Definition fun_hrel_comp {X Y : UU} (f : X → Y) (gt : hrel Y) : hrel X := λ x y : X, gt (f x) (f y). (** ** Other universal properties for [setquot] *) Theorem setquotunivprop' {X : UU} {R : eqrel X} (P : setquot (pr1 R) -> UU) (H : ∏ x, isaprop (P x)) (ps : ∏ x : X, P (setquotpr R x)) : ∏ c : setquot (pr1 R), P c. Proof. exact (setquotunivprop R (λ x, make_hProp (P x) (H x)) ps). Defined. Theorem setquotuniv2prop' {X : UU} {R : eqrel X} (P : setquot (pr1 R) → setquot (pr1 R) → UU) (H : ∏ x1 x2, isaprop (P x1 x2)) (ps : ∏ x1 x2, P (setquotpr R x1) (setquotpr R x2)) : ∏ c1 c2 : setquot (pr1 R), P c1 c2. Proof. exact (setquotuniv2prop R (λ x1 x2, make_hProp (P x1 x2) (H x1 x2)) ps). Defined. Theorem setquotuniv3prop' {X : UU} {R : eqrel X} (P : setquot (pr1 R) → setquot (pr1 R) → setquot (pr1 R) → UU) (H : ∏ x1 x2 x3, isaprop (P x1 x2 x3)) (ps : ∏ x1 x2 x3, P (setquotpr R x1) (setquotpr R x2) (setquotpr R x3)) : ∏ c1 c2 c3 : setquot (pr1 R), P c1 c2 c3. Proof. exact (setquotuniv3prop R (λ x1 x2 x3, make_hProp (P x1 x2 x3) (H x1 x2 x3)) ps). Defined. Theorem setquotuniv4prop' {X : UU} {R : eqrel X} (P : setquot (pr1 R) → setquot (pr1 R) → setquot (pr1 R) → setquot (pr1 R) → UU) (H : ∏ x1 x2 x3 x4, isaprop (P x1 x2 x3 x4)) (ps : ∏ x1 x2 x3 x4, P (setquotpr R x1) (setquotpr R x2) (setquotpr R x3) (setquotpr R x4)) : ∏ c1 c2 c3 c4 : setquot (pr1 R), P c1 c2 c3 c4. Proof. exact (setquotuniv4prop R (λ x1 x2 x3 x4, make_hProp (P x1 x2 x3 x4) (H x1 x2 x3 x4)) ps). Defined. (** ** The equivalence relation of being in the same fiber *) Definition same_fiber_eqrel {X Y : hSet} (f : X → Y) : eqrel X. Proof. use make_eqrel. - intros x y. exact ((f x) = (f y)). - use iseqrelconstr. + intros ? ? ? xy yz; exact (xy @ yz). + intro; reflexivity. + intros ? ? eq; exact (!eq). Defined. (** ** Subsets *) Definition pi0 (X : UU) : hSet := setquotinset (pathseqrel X). Section Pi0. Definition π₀ : Type -> hSet := pi0. Definition component {X:Type} : X -> π₀ X := setquotpr (pathseqrel X). Definition π₀_map {X Y:Type} : (X -> Y) -> (π₀ X -> π₀ Y) := λ f, setquotfun (pathseqrel X) (pathseqrel Y) f (λ x x', hinhfun (maponpaths f)). Definition π₀_universal_property {X:Type} {Y:hSet} : (π₀ X -> Y) ≃ (X -> Y). Proof. exists (λ h, h ∘ component). intros f. apply iscontraprop1. - apply isaproptotal2. + intros h. use (_ : isaset _). apply impred_isaset. intros x. apply setproperty. + intros h h' e e'. apply funextsec. intro w. { apply (surjectionisepitosets component). - apply issurjsetquotpr. - apply setproperty. - intros x. exact (maponpaths (λ k, k x) (e @ ! e')). } - now exists (setquotuniv _ _ f (λ x y e, squash_to_prop e (setproperty Y (f x) (f y)) (maponpaths f))). Defined. Definition π₀_universal_map {X:Type} {Y:hSet} : (X -> Y) -> (π₀ X -> Y) := invmap π₀_universal_property. Lemma π₀_universal_map_eqn {X:Type} {Y:hSet} (f : X -> Y) : ∏ (x:X), π₀_universal_map f (component x) = f x. Proof. reflexivity. Defined. Lemma π₀_universal_map_uniq {X:Type} {Y:hSet} (h h' : π₀ X -> Y) : (∏ x, h (component x) = h' (component x)) -> h ~ h'. Proof. intros e x. apply (surjectionisepitosets component). - apply issurjsetquotpr. - apply setproperty. - exact e. Defined. End Pi0. (** ** Minimal equivalence relations *) (* Constructs the smallest eqrel containing a given relation *) Section mineqrel. Close Scope set. Context {A : UU} (R0 : hrel A). Lemma isaprop_eqrel_from_hrel a b : isaprop (∏ R : eqrel A, (∏ x y, R0 x y -> R x y) -> R a b). Proof. apply impred; intro R; apply impred_prop. Qed. Definition eqrel_from_hrel : hrel A := λ a b, make_hProp _ (isaprop_eqrel_from_hrel a b). Lemma iseqrel_eqrel_from_hrel : iseqrel eqrel_from_hrel. Proof. repeat split. - intros x y z H1 H2 R HR. exact (eqreltrans _ _ _ _ (H1 _ HR) (H2 _ HR)). - now intros x R _; apply (eqrelrefl R). - intros x y H R H'. exact (eqrelsymm _ _ _ (H _ H')). Qed. Lemma eqrel_impl a b : R0 a b -> eqrel_from_hrel a b. Proof. now intros H R HR; apply HR. Qed. (* eqrel_from_hrel is the *smallest* relation containing R0 *) Lemma minimal_eqrel_from_hrel (R : eqrel A) (H : ∏ a b, R0 a b -> R a b) : ∏ a b, eqrel_from_hrel a b -> R a b. Proof. now intros a b H'; apply (H' _ H). Qed. End mineqrel. Lemma eqreleq {A : UU} (R : eqrel A) (x y : A) : x = y → R x y. Proof. intros e. induction e. apply eqrelrefl. Defined. (** * Additional lemmas on binary relations *) Lemma isaprop_isirrefl {X : UU} (rel : hrel X) : isaprop (isirrefl rel). Proof. apply impred_isaprop ; intro. now apply isapropneg. Qed. Lemma isaprop_issymm {X : UU} (rel : hrel X) : isaprop (issymm rel). Proof. apply impred_isaprop ; intro x. apply impred_isaprop ; intro y. apply isapropimpl. now apply pr2. Qed. Lemma isaprop_iscotrans {X : UU} (rel : hrel X) : isaprop (iscotrans rel). Proof. apply impred_isaprop ; intro x. apply impred_isaprop ; intro y. apply impred_isaprop ; intro z. apply isapropimpl. now apply pr2. Qed. (** Useful functions for when using univalence of sets *) Definition univalence_hSet {X Y : hSet} (w : X ≃ Y) : X = Y := invmap (hSet_univalence _ _) w. Definition hSet_univalence_map_univalence_hSet {X Y : hSet} (w : X ≃ Y) : hSet_univalence_map X Y (univalence_hSet w) = w. Proof. exact (homotweqinvweq (hSet_univalence _ _) w). Defined. Definition hSet_univalence_univalence_hSet_map {X Y : hSet} (p : X = Y) : univalence_hSet (hSet_univalence_map X Y p) = p. Proof. exact (homotinvweqweq (hSet_univalence _ _) p). Qed. Definition univalence_hSet_idweq (X : hSet) : univalence_hSet (idweq X) = idpath X. Proof. refine (_ @ hSet_univalence_univalence_hSet_map (idpath _)). apply maponpaths. apply idpath. Defined. Definition hSet_univalence_map_inv {X Y : hSet} (p : X = Y) : hSet_univalence_map _ _ (!p) = invweq (hSet_univalence_map _ _ p). Proof. induction p. cbn. use subtypePath. { intro. apply isapropisweq. } apply idpath. Qed. Definition univalence_hSet_inv {X Y : hSet} (w : X ≃ Y) : !(univalence_hSet w) = univalence_hSet (invweq w). Proof. refine (!(hSet_univalence_univalence_hSet_map _) @ _). apply maponpaths. rewrite hSet_univalence_map_inv. rewrite hSet_univalence_map_univalence_hSet. apply idpath. Qed. UniMath-20231010/UniMath/MoreFoundations/StructureIdentity.v000066400000000000000000000040031451125700300236660ustar00rootroot00000000000000(** * Structure identity *) Require Export UniMath.MoreFoundations.Notations. Require Export UniMath.MoreFoundations.Tactics. Require Export UniMath.MoreFoundations.AlternativeProofs. Section StructureIdentity. (** ** abstract the proof of Poset_rect for use in multiple situations *) (** See Section 9.8 of the HoTT book, on "The structure identity principle". *) Open Scope poset. Context {Base : UU} (* base type *) (Data : Base -> Poset). (* the additional structure *) Definition Struc := ∑ b, Data b. (* the structures *) (** for example: Base = hSet, Data = PartialOrder, Struc = Poset *) Local Definition DataEquiv (b:Base) (d d':Data b) := d ≤ d' ∧ d' ≤ d. Local Definition StrucEquiv (X Y:Struc) := ∑ (p: pr1 X = pr1 Y), DataEquiv _ (transportf Data p (pr2 X)) (pr2 Y). Notation "X ≅ Y" := (StrucEquiv X Y). Theorem Struc_univalence (X Y:Struc) : X=Y ≃ X≅Y. Proof. simple refine (@remakeweq _ _ _ _ _). { intermediate_weq (X╝Y). { apply total2_paths_equiv'. } { use weqfibtototal; intro p. apply weqimplimpl. { intros q. split; induction q; apply isrefl_posetRelation. } { intros e. apply isantisymm_posetRelation. - exact (pr1 e). - exact (pr2 e). } { apply (setproperty (Data _)). } { apply (propproperty (DataEquiv _ _ _)). } } } { intros e. induction e. exists (idpath _). split; apply isrefl_posetRelation. } try reflexivity. (* fails, which is why we are using "remakeweq" here *) intro e. now induction e. Defined. Theorem Equiv_rect (X Y : Struc) (P : X ≅ Y -> UU) : (∏ e : X = Y, P (Struc_univalence _ _ e)) -> ∏ f, P f. Proof. intros ih f. set (p := ih (invmap (Struc_univalence _ _) f)). set (h := homotweqinvweq (Struc_univalence _ _) f). exact (transportf P h p). Defined. (* Ltac Struc_induction f e := generalize f; apply Equiv_rect; intro e; clear f. *) End StructureIdentity. UniMath-20231010/UniMath/MoreFoundations/Subposets.v000066400000000000000000000034001451125700300221430ustar00rootroot00000000000000Require Export UniMath.MoreFoundations.Notations. Definition Subposet (X:Poset) := hsubtype X. (* this seems simpler than the next one *) Definition Subposet' (X:Poset) := ∑ (S:Poset) (f:posetmorphism S X), isincl f. Definition Subposet'_to_Poset {X:Poset} (S:Subposet' X) := pr1 S. Coercion Subposet'_to_Poset : Subposet' >-> Poset. Definition Subposet_to_Subposet' {X:Poset} : Subposet X -> Subposet' X. Proof. intros S. use tpair. - exists (carrier_subset S). use tpair. + intros s t. exact (pr1 s ≤ pr1 t)%poset. + simpl. split. { split. { intros s t u. exact (istrans_posetRelation _ _ _ _). } { intros s. exact (isrefl_posetRelation _ _). } } { intros s t a b. apply subtypePath_prop. exact (isantisymm_posetRelation _ _ _ a b). } - simpl. use tpair. + exists (pr1carrier _). intros s t a. simpl in s,t. exact a. + simpl. apply isinclpr1carrier. Defined. Definition Subposet'_to_Subposet {X:Poset} : Subposet' X -> Subposet X. Proof. intros S x. set (f := pr1 (pr2 S)); simpl in f. exact (nonempty (hfiber f x)). Defined. Coercion Subposet_to_Subposet' : Subposet >-> Subposet'. Definition Subposet'_equiv_Subposet (X:Poset) : Subposet' X ≃ Subposet X. Proof. exists Subposet'_to_Subposet. apply set_bijection_to_weq. - split. + intros S. exists (Subposet_to_Subposet' S). apply funextfun; intro z. apply hPropUnivalence. * simple refine (hinhuniv _); intro w. simpl in w. induction w as [s p]. induction s as [y q]; simpl in p. induction p. exact q. * intro h. apply hinhpr. exists (z,,h). reflexivity. + intros S T p. (* first develop univalence for posets and Poset_rect *) admit. - unfold Subposet. apply isasethsubtype. Abort. UniMath-20231010/UniMath/MoreFoundations/Subtypes.v000066400000000000000000000360471451125700300220070ustar00rootroot00000000000000Require Export UniMath.MoreFoundations.Notations. Require Export UniMath.MoreFoundations.Propositions. Declare Scope subtype. Delimit Scope subtype with subtype. Local Open Scope subtype. Local Open Scope logic. Local Open Scope type. (** The powerset, or set of all subsets, of a set. *) Definition subtype_set X : hSet := make_hSet (hsubtype X) (isasethsubtype X). Definition subtype_isIn {X:UU} {S:hsubtype X} (s:S) (T:hsubtype X) : hProp := T (pr1 s). Notation " s ∈ T " := (subtype_isIn s T) (at level 70) : subtype. Notation " s ∉ T " := (¬ (subtype_isIn s T) : hProp) (at level 70) : subtype. Definition subtype_containedIn {X:UU} : hrel (subtype_set X) := λ S T, ∀ x:X, S x ⇒ T x. Notation " S ⊆ T " := (subtype_containedIn S T) (at level 70) : subtype. Definition subtype_notContainedIn {X:UU} (S T : hsubtype X) : hProp := ∃ x:X, S x ∧ ¬ (T x). Definition subtype_inc {X:UU} {S T : hsubtype X} : S ⊆ T -> S -> T. Proof. intros le s. exact (pr1 s,, le (pr1 s) (pr2 s)). Defined. Notation " S ⊈ T " := (subtype_notContainedIn S T) (at level 70) : subtype. Definition subtype_smallerThan {X:UU} (S T : hsubtype X) : hProp := (S ⊆ T) ∧ (T ⊈ S). Notation " S ⊊ T " := (subtype_smallerThan S T) (at level 70) : subtype. Definition subtype_equal {X:UU} (S T : hsubtype X) : hProp := ∀ x, S x ⇔ T x. Notation " S ≡ T " := (subtype_equal S T) (at level 70) : subtype. Definition subtype_notEqual {X:UU} (S T : hsubtype X) : hProp := (S ⊈ T) ∨ (T ⊈ S). Notation " S ≢ T " := (subtype_notEqual S T) (at level 70) : subtype. Lemma subtype_notEqual_containedIn {X:UU} (S T : hsubtype X) : S ⊆ T -> S ≢ T -> T ⊈ S. Proof. intros ci ne. apply (squash_to_hProp ne); clear ne; intros [n|n]. - apply (squash_to_hProp n); clear n; intros [x [p q]]. apply fromempty. change (neg (T x)) in q. apply q; clear q. apply (ci x). exact p. - exact n. Defined. Lemma subtype_notEqual_to_negEqual {X:UU} (S T : hsubtype X) : S ≢ T -> ¬ (S ≡ T). Proof. intros n. apply (squash_to_prop n). + apply isapropneg. (* uses funextemptyAxiom *) + intros [c|c]. * apply (squash_to_prop c). ** apply isapropneg. (* uses funextemptyAxiom *) ** intros [x [Sx nTx]] e. use nTx; clear nTx. exact (pr1 (e x) Sx). * apply (squash_to_prop c). ** apply isapropneg. (* uses funextemptyAxiom *) ** intros [x [Tx nSx]] e. use nSx; clear nSx. exact (pr2 (e x) Tx). Defined. Lemma subtype_notEqual_from_negEqual {X:UU} (S T : hsubtype X) : LEM -> (S ≢ T <- ¬ (S ≡ T)). Proof. intros lem ne. unfold subtype_equal in ne. assert (q := negforall_to_existsneg _ lem ne); clear ne. apply (squash_to_hProp q); clear q; intros [x n]. unfold subtype_notEqual. assert (r := weak_fromnegdirprod _ _ n); clear n. unfold dneg in r. assert (s := proof_by_contradiction lem r); clear r. apply (squash_to_hProp s); clear s. intros s. apply hinhpr. induction s as [s|s]. + apply ii1, hinhpr. exists x. now apply negimpl_to_conj. + apply ii2, hinhpr. exists x. now apply negimpl_to_conj. Defined. Definition emptysubtype (X : UU) : hsubtype X := λ x, hfalse. Definition subtype_difference {X:UU} (S T : hsubtype X) : hsubtype X := λ x, S x ∧ ¬ (T x). Notation " S - T " := (subtype_difference S T) : subtype. Definition subtype_difference_containedIn {X:UU} (S T : hsubtype X) : (S - T) ⊆ S. Proof. intros x u. exact (pr1 u). Defined. Lemma subtype_equal_cond {X:UU} (S T : hsubtype X) : S ⊆ T ∧ T ⊆ S ⇔ S ≡ T. Proof. split. - intros c x. induction c as [st ts]. split. + intro s. exact (st x s). + intro t. exact (ts x t). - intro e. split. + intros x s. exact (pr1 (e x) s). + intros x t. exact (pr2 (e x) t). Defined. Definition subtype_union {X I:UU} (S : I -> hsubtype X) : hsubtype X := λ x, ∃ i, S i x. Notation "⋃ S" := (subtype_union S) (at level 100, no associativity) : subtype. Definition subtype_binaryunion {X} (A B : hsubtype X) : hsubtype X := fun x => A x ∨ B x. Notation "A ∪ B" := (subtype_binaryunion A B) (at level 40, left associativity) : subtype. (* precedence tighter than "⊆", also than "-" [subtype_difference]. *) (* in agda-input method, type \cup or ∪ *) Definition subtype_binaryunion_leq1 {X} (A B : hsubtype X) : A ⊆ (A ∪ B) := fun x => hdisj_in1. Definition subtype_binaryunion_leq2 {X} (A B : hsubtype X) : B ⊆ (A ∪ B) := fun x => hdisj_in2. Definition subtype_union_containedIn {X:hSet} {I:UU} (S : I -> hsubtype X) i : S i ⊆ ⋃ S := λ x s, hinhpr (i,,s). (** Given a family of subtypes of X indexed by a type I, an element x : X is in their intersection if it is an element of each subtype. *) Definition subtype_intersection {X I:UU} (S : I -> hsubtype X) : hsubtype X := λ x, ∀ i, S i x. Notation "⋂ S" := (subtype_intersection S) (at level 100, no associativity) : subtype. Theorem hsubtype_univalence {X:UU} (S T : hsubtype X) : (S = T) ≃ (S ≡ T). Proof. intros. intermediate_weq (∏ x, S x = T x). - apply weqtoforallpaths. - unfold subtype_equal. apply weqonsecfibers; intro x. apply weqlogeq. Defined. Theorem hsubtype_rect {X:UU} (S T : hsubtype X) (P : S ≡ T -> UU) : (∏ e : S=T, P (hsubtype_univalence S T e)) ≃ ∏ f, P f. Proof. intros. apply weqinvweq, weqonsecbase. Defined. Ltac hsubtype_induction f e := generalize f; apply hsubtype_rect; intro e; clear f. Lemma subtype_containment_istrans X : istrans (@subtype_containedIn X). Proof. intros S T U i j x. exact (j x ∘ i x). Defined. Lemma subtype_containment_isrefl X : isrefl (@subtype_containedIn X). Proof. intros S x s. exact s. Defined. Lemma subtype_containment_ispreorder X : ispreorder (@subtype_containedIn X). Proof. use make_dirprod. - apply subtype_containment_istrans. - apply subtype_containment_isrefl. Defined. Lemma subtype_containment_isantisymm X : isantisymm (@subtype_containedIn X). Proof. intros S T i j. apply (invmap (hsubtype_univalence S T)). apply subtype_equal_cond. split; assumption. Defined. Lemma subtype_containment_isPartialOrder X : isPartialOrder (@subtype_containedIn X). Proof. use make_dirprod. - apply subtype_containment_ispreorder. - apply subtype_containment_isantisymm. Defined. Lemma subtype_inc_comp {X:UU} {S T U : hsubtype X} (i:S⊆T) (j:T⊆U) (s:S) : subtype_inc j (subtype_inc i s) = subtype_inc (λ x, j x ∘ i x) s. Proof. reflexivity. Defined. Lemma subtype_deceq {X} (S:hsubtype X) : isdeceq X -> isdeceq (carrier S). Proof. intro i. intros s t. induction (i (pr1 s) (pr1 t)) as [eq|ne]. - apply ii1, subtypePath_prop, eq. - apply ii2. intro eq. apply ne. apply maponpaths. exact eq. Defined. Definition isDecidablePredicate {X} (S:X->hProp) := ∏ x, decidable (S x). Definition subtype_plus {X} (S:hsubtype X) (z:X) : hsubtype X := λ x, S x ∨ z = x. Definition subtype_plus_incl {X} (S:hsubtype X) (z:X) : S ⊆ subtype_plus S z. Proof. intros s Ss. now apply hinhpr,ii1. Defined. Definition subtype_plus_has_point {X} (S:hsubtype X) (z:X) : subtype_plus S z z. Proof. now apply hinhpr, ii2. Defined. Definition subtype_plus_in {X} {S:hsubtype X} {z:X} {T:hsubtype X} : S ⊆ T -> T z -> subtype_plus S z ⊆ T. Proof. intros le Tz x S'x. apply (squash_to_hProp S'x). intros [Sx|e]. - exact (le x Sx). - induction e. exact Tz. Defined. Section Complement. Context {X : UU}. Definition subtype_complement (S : hsubtype X) : hsubtype X := fun x => hneg (S x). (** Something can't be in a subtype and its complement. *) Lemma not_in_subtype_and_complement (S : hsubtype X) : ∏ x, S x -> subtype_complement S x -> empty. Proof. intros x in_S in_neg_S; exact (in_neg_S in_S). Defined. (** The intersection of a family containing a set and its complement is empty. *) Lemma subtype_complement_intersection_empty {S} {I : UU} {f : I -> hsubtype X} : (∑ i : I, f i = S) -> (∑ j : I, f j = subtype_complement S) -> subtype_intersection f ≡ emptysubtype _. Proof. intros has_S has_neg_S x; use make_dirprod. - intros in_intersection. pose (in_S := in_intersection (pr1 has_S)). pose (in_neg_S := in_intersection (pr1 has_neg_S)). cbn in *. pose (in_S' := (eqtohomot (pr2 has_S)) x). pose (in_neg_S' := (eqtohomot (pr2 has_neg_S)) x). apply (not_in_subtype_and_complement S x). + abstract (induction in_S'; assumption). + abstract (induction in_neg_S'; assumption). - intros empt; induction empt. Qed. (** The union of a family containing a set and its complement is the whole set (assuming LEM). *) Lemma subtype_complement_union {S} (lem : LEM) {I : UU} {f : I -> hsubtype X} : (∑ i : I, f i = S) -> (∑ j : I, f j = subtype_complement S) -> subtype_union f ≡ totalsubtype _. Proof. intros has_S has_neg_S x; use make_dirprod. - intro; exact tt. - intro. induction (lem (S x)). + apply hinhpr. exists (pr1 has_S). abstract (rewrite (pr2 has_S); assumption). + apply hinhpr. exists (pr1 has_neg_S). abstract (rewrite (pr2 has_neg_S); assumption). Qed. End Complement. (* We could define the intersection as follows but this makes it more complicated than it should be *) Definition binary_intersection' {X : UU} (U V : hsubtype X) : hsubtype X := subtype_intersection (λ b, bool_rect (λ _ : bool, hsubtype X) U V b). Definition binary_intersection {X : UU} (U V : hsubtype X) : hsubtype X := λ x, U x ∧ V x. Lemma binary_intersection_commutative {X : UU} (U V : hsubtype X) : ∏ x : X, (binary_intersection U V) x -> (binary_intersection V U) x. Proof. intros ? p. exact (transportf _ (iscomm_hconj (U x) (V x)) p). Qed. Definition intersection_contained_l {X : UU} (U V : hsubtype X) : subtype_containedIn (binary_intersection U V) U. Proof. intros ? xinUV. apply xinUV. Qed. Definition intersection_contained_r {X : UU} (U V : hsubtype X) : subtype_containedIn (binary_intersection U V) V. Proof. intros ? xinUV. apply xinUV. Qed. Definition intersection_contained {X : UU} {U U' V V' : hsubtype X} (uu : subtype_containedIn U U') (vv : subtype_containedIn V V') : subtype_containedIn (binary_intersection U V) (binary_intersection U' V'). Proof. intros x p. cbn. split. - apply (uu x). exact ((intersection_contained_l U V) x p). - apply (vv x). exact ((intersection_contained_r U V) x p). Qed. Lemma isaprop_subtype_containedIn {X : UU} (U V : hsubtype X) : isaprop (subtype_containedIn U V). Proof. apply impred_isaprop ; intro. apply isapropimpl. apply V. Qed. Definition image_hsubtype {X Y : UU} (U : hsubtype X) (f : X → Y) : hsubtype Y := λ y : Y, (∃ x : X, f x = y × U x). Lemma image_hsubtype_emptyhsubtype {X Y : UU} (f : X → Y) : image_hsubtype (emptysubtype X) f = emptysubtype Y. Proof. apply funextsec ; intro y. apply hPropUnivalence. - intro yinfEmpty. use (factor_through_squash _ _ yinfEmpty). { apply emptysubtype. } intro x. apply (pr22 x). - intro yinEmpty. apply fromempty. exact (yinEmpty). Qed. Definition image_hsubtype_id {X : UU} (U : hsubtype X) : image_hsubtype U (idfun X) = U. Proof. apply funextsec ; intro x. apply hPropUnivalence. - intro xinIdU. use (factor_through_squash _ _ xinIdU). { apply U. } intro u0. assert (p0 : U (pr1 u0) = U x). { apply maponpaths. apply (pr12 u0). } induction p0. apply (pr22 u0). - intro xinU. apply hinhpr. exact (x,, idpath x,, xinU). Qed. Definition image_hsubtype_comp {X Y Z : UU} (U : hsubtype X) (f : X → Y) (g : Y → Z) : image_hsubtype U (funcomp f g) = image_hsubtype (image_hsubtype U f) g. Proof. apply funextsec ; intro z. apply hPropUnivalence. - intro zinCompU. use (factor_through_squash _ _ zinCompU). { apply ishinh. } intro x. apply hinhpr. exists (f (pr1 x)). exists (pr12 x). apply hinhpr. exact (pr1 x,, maponpaths f (idpath (pr1 x)),, pr22 x). - intro zinCompU. use (factor_through_squash _ _ zinCompU). { apply ishinh. } intro y. use (factor_through_squash _ _ (pr22 y)). { apply ishinh. } intro x. apply hinhpr. exists (pr1 x). split. + refine (_ @ (pr12 y)). unfold funcomp. unfold funcomp. apply maponpaths. exact (pr12 x). + exact (pr22 x). Qed. Definition hsubtype_preserving {X Y : UU} (U : hsubtype X) (V : hsubtype Y) (f : X → Y) : UU := subtype_containedIn (image_hsubtype U f) V. Lemma isaprop_hsubtype_preserving {X Y : UU} (U : hsubtype X) (V : hsubtype Y) (f : X → Y) : isaprop (hsubtype_preserving U V f). Proof. apply impred_isaprop ; intro. apply isapropimpl. apply V. Qed. Lemma id_hsubtype_preserving {X : UU} (U : hsubtype X) : hsubtype_preserving U U (idfun X). Proof. intros x xinU. rewrite image_hsubtype_id in xinU. exact xinU. Qed. Lemma comp_hsubtype_preserving {X Y Z : UU} {U : hsubtype X} {V : hsubtype Y} {W : hsubtype Z} {f : X → Y} {g : Y → Z} (fsp : hsubtype_preserving U V f) (gsp : hsubtype_preserving V W g) : hsubtype_preserving U W (funcomp f g). Proof. intros z zinU. rewrite image_hsubtype_comp in zinU. apply (gsp _). unfold image_hsubtype. use (factor_through_squash _ _ zinU). { apply ishinh. } intro y. apply hinhpr. exists (pr1 y). exists (pr12 y). apply (fsp _). exact (pr22 y). Qed. Lemma empty_hsubtype_preserving {X Y : UU} (f : X → Y) : hsubtype_preserving (emptysubtype X) (emptysubtype Y) f. Proof. unfold hsubtype_preserving. rewrite image_hsubtype_emptyhsubtype. apply subtype_containment_isrefl. Qed. Lemma total_hsubtype_preserving {X Y : UU} (f : X → Y) : hsubtype_preserving (totalsubtype X) (totalsubtype Y) f. Proof. exact (λ _ _, tt). Qed. Section singletons. Definition singleton {X : UU} (x : X) : hsubtype X := λ (a : X), ∥ a = x ∥. (* The canonical element of the singleton subtype. *) Definition singleton_point {X : UU} {x : X} : singleton x := (x ,, hinhpr (idpath x)). Definition iscontr_singleton {X : hSet} (x : X) : iscontr (singleton x). Proof. use make_iscontr. - exact singleton_point. - intros t. apply subtypePath_prop. apply(squash_to_prop (pr2 t)). apply setproperty. intro ; assumption. Defined. Definition singleton_is_in {X : UU} (A : hsubtype X) (a : A) : (singleton (pr1 a)) ⊆ A. Proof. intro y. use hinhuniv. exact(λ (p : y = (pr1 a)), transportb A p (pr2 a)). Defined. End singletons. (* Map from the coproduct of carriers to the carrier of the binary union. *) Definition coprod_carrier_binary_union {X} (A B : hsubtype X) : A ⨿ B -> A ∪ B. Proof. apply sumofmaps; apply subtype_inc. - apply subtype_binaryunion_leq1. - apply subtype_binaryunion_leq2. Defined. Lemma issurjective_coprod_carrier_binary_union {X} (A B : hsubtype X) : issurjective (coprod_carrier_binary_union A B). Proof. intros [x aub]. use(hinhfun _ aub). apply sumofmaps ; (intro y; use make_hfiber) ; try (apply subtypePath_prop). - exact(inl (x ,, y)). - apply idpath. - exact(inr (x ,, y)). - apply idpath. Qed. UniMath-20231010/UniMath/MoreFoundations/Tactics.v000066400000000000000000000065551451125700300215640ustar00rootroot00000000000000(************************************************************************ This file contains various useful tactics ************************************************************************) Require Import UniMath.Foundations.All. (** A version of "easy" specialized for the needs of UniMath. This tactic is supposed to be simple and predictable. The goal is to use it to finish "trivial" goals *) Ltac easy := trivial; intros; solve [ repeat (solve [trivial | apply pathsinv0; trivial] || split) | match goal with | H : ∅ |- _ => induction H end | match goal with | H : ¬ _ |- _ => induction H; trivial end | match goal with | H : _ → ∅ |- _ => induction H; trivial end | match goal with | H : _ → _ → ∅ |- _ => induction H; trivial end ]. (** Override the Coq now tactic so that it uses unimath_easy instead *) Tactic Notation "now" tactic(t) := t; easy. (* hSet_induction in Foundations is wrong, so redefine it here: *) Ltac hSet_induction f e := generalize f; apply hSet_rect; intro e; clear f. (* When the goal is displayed as x=y and the types of x and y are hard to discern, use this tactic -- it will add the type to the context in simplified form. *) Ltac show_id_type := match goal with |- @paths ?ID _ _ => set (TYPE := ID); simpl in TYPE end. Require Import UniMath.Foundations.Sets UniMath.Foundations.UnivalenceAxiom. Definition post_cat {X} {x y z:X} {p:y = z} : x = y -> x = z. Proof. intros q. exact (pathscomp0 q p). Defined. Definition pre_cat {X} {x y z:X} {p:x = y} : y = z -> x = z. Proof. intros q. exact (pathscomp0 p q). Defined. Ltac maponpaths_pre_post_cat := repeat rewrite path_assoc; repeat apply (maponpaths post_cat); repeat rewrite <- path_assoc; repeat apply (maponpaths pre_cat); repeat rewrite path_assoc; repeat rewrite maponpathsinv0; try reflexivity. Ltac prop_logic := abstract (intros; simpl; repeat (try (apply isapropdirprod);try (apply isapropishinh);apply impred ;intro); try (apply isapropiscontr); try assumption) using _L_. Lemma iscontrweqb' {X Y} (is:iscontr Y) (w:X ≃ Y) : iscontr X. Proof. intros. apply (iscontrweqb (Y:=Y)). assumption. assumption. Defined. Ltac intermediate_iscontr Y' := apply (iscontrweqb (Y := Y')). Ltac intermediate_iscontr' Y' := apply (iscontrweqb' (Y := Y')). Ltac isaprop_goal x := let G := match goal with |- ?G => constr:(G) end in assert (x : isaprop(G)). (* less fancy than [isaprop_goal ig.] is [apply isaprop_goal; intro ig.] *) Definition isaprop_goal X (ig:isaprop X) (f:isaprop X -> X) : X. Proof. intros. exact (f ig). Defined. Ltac isaset_goal x := let G := match goal with |- ?G => constr:(G) end in assert (x : isaset(G)). Ltac split3 := split; [| split]. Ltac split4 := split; [| split3]. Ltac split5 := split; [| split4]. Ltac split6 := split; [| split5]. Ltac split7 := split; [| split6]. Ltac split8 := split; [| split7]. Ltac split9 := split; [| split8]. Ltac split10 := split; [| split9]. Ltac split11 := split; [| split10]. Ltac split12 := split; [| split11]. Ltac split13 := split; [| split12]. Ltac split14 := split; [| split13]. Ltac split15 := split; [| split14]. Ltac split16 := split; [| split15]. Ltac split17 := split; [| split16]. Ltac split18 := split; [| split17]. Ltac split19 := split; [| split18]. Ltac split20 := split; [| split19]. Ltac split21 := split; [| split20]. (** this allows to decompose a goal for [prebicat_laws] *) UniMath-20231010/UniMath/MoreFoundations/Test.v000066400000000000000000000014211451125700300210740ustar00rootroot00000000000000(** * Tests *) Require Import UniMath.Foundations.Init. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Bool. (** ** Bool.v *) (* Double check they have the right truth tables: *) Goal andb true true = true. reflexivity. Qed. Goal andb true false = false. reflexivity. Qed. Goal andb false true = false. reflexivity. Qed. Goal andb false false = false. reflexivity. Qed. Goal orb true true = true. reflexivity. Qed. Goal orb true false = true. reflexivity. Qed. Goal orb false true = true. reflexivity. Qed. Goal orb false false = false. reflexivity. Qed. Goal implb true true = true. reflexivity. Qed. Goal implb true false = false. reflexivity. Qed. Goal implb false true = true. reflexivity. Qed. Goal implb false false = true. reflexivity. Qed.UniMath-20231010/UniMath/MoreFoundations/Univalence.v000066400000000000000000000115501451125700300222520ustar00rootroot00000000000000(** * Additional results about univalence *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.UnivalenceAxiom. Require Import UniMath.MoreFoundations.PartA. (** Funextsec and toforallpaths are mutually inverses *) Lemma funextsec_toforallpaths {T : UU} {P : T -> UU} {f g : ∏ t : T, P t} : ∏ (h : f = g), funextsec _ _ _ (toforallpaths _ _ _ h) = h. Proof. intro h; exact (!homotinvweqweq0 (weqtoforallpaths _ _ _) h). Defined. Lemma toforallpaths_funextsec {T : UU} {P : T -> UU} {f g : ∏ t : T, P t} : ∏ (h : ∏ t : T, f t = g t), toforallpaths _ _ _ (funextsec _ _ _ h) = h. Proof. intro h; exact (homotweqinvweq (weqtoforallpaths _ _ _) h). Defined. Definition toforallpaths_funextsec_comp {T : UU} {P : T -> UU} (f g : ∏ t, P t) : toforallpaths P f g ∘ funextsec P f g = idfun _. Proof. apply funextsec; intro. simpl. apply toforallpaths_funextsec. Defined. Lemma maponpaths_funextsec {T : UU} {P : T -> UU} (f g : ∏ t, P t) (t : T) (p : f ~ g) : maponpaths (λ h, h t) (funextsec _ f g p) = p t. Proof. intermediate_path (toforallpaths _ _ _ (funextsec _ f g p) t). - generalize (funextsec _ f g p); intros q. induction q. reflexivity. - apply (eqtohomot (eqtohomot (toforallpaths_funextsec_comp f g) p) t). Qed. Definition weqonsec {X Y} (P:X->Type) (Q:Y->Type) (f:X ≃ Y) (g:∏ x, weq (P x) (Q (f x))) : (∏ x:X, P x) ≃ (∏ y:Y, Q y). Proof. intros. exact (weqcomp (weqonsecfibers P (λ x, Q(f x)) g) (invweq (weqonsecbase Q f))). Defined. Definition weq_transportf {X} (P:X->Type) {x y:X} (p:x = y) : (P x) ≃ (P y). Proof. intros. induction p. apply idweq. Defined. Definition weq_transportf_comp {X} (P:X->Type) {x y:X} (p:x = y) (f:∏ x, P x) : weq_transportf P p (f x) = f y. Proof. intros. induction p. reflexivity. Defined. Definition weqonpaths2 {X Y} (w:X ≃ Y) {x x':X} {y y':Y} : w x = y -> w x' = y' -> (x = x') ≃ (y = y'). Proof. intros p q. induction p,q. apply weqonpaths. Defined. Definition eqweqmap_ap {T} (P:T->Type) {t t':T} (e:t = t') (f:∏ t:T, P t) : eqweqmap (maponpaths P e) (f t) = f t'. (* move near eqweqmap *) Proof. intros. induction e. reflexivity. Defined. Definition eqweqmap_ap' {T} (P:T->Type) {t t':T} (e:t = t') (f:∏ t:T, P t) : invmap (eqweqmap (maponpaths P e)) (f t') = f t. (* move near eqweqmap *) Proof. intros. induction e. reflexivity. Defined. (** weak equivalences *) Definition pr1_eqweqmap { X Y } ( e: X = Y ) : cast e = pr1 (eqweqmap e). Proof. intros. induction e. reflexivity. Defined. Definition path_to_fun {X Y} : X=Y -> X->Y. Proof. intros p. induction p. exact (idfun _). Defined. Definition pr1_eqweqmap2 { X Y } ( e: X = Y ) : pr1 (eqweqmap e) = transportf (λ T:Type, T) e. Proof. intros. induction e. reflexivity. Defined. Definition weqpath_transport {X Y} (w : X ≃ Y) : transportf (idfun UU) (weqtopaths w) = pr1 w. Proof. intros. exact (!pr1_eqweqmap2 _ @ maponpaths pr1 (weqpathsweq w)). Defined. Definition weqpath_cast {X Y} (w : X ≃ Y) : cast (weqtopaths w) = w. Proof. intros. exact (pr1_eqweqmap _ @ maponpaths pr1 (weqpathsweq w)). Defined. Definition switch_weq {X Y} (f:X ≃ Y) {x y} : y = f x -> invweq f y = x. Proof. intros p. exact (maponpaths (invweq f) p @ homotinvweqweq f x). Defined. Definition switch_weq' {X Y} (f:X ≃ Y) {x y} : invweq f y = x -> y = f x. Proof. intros p. exact (! homotweqinvweq f y @ maponpaths f p). Defined. Local Open Scope transport. Definition weq_over_sections {S T} (w:S ≃ T) {s0:S} {t0:T} (k:w s0 = t0) {P:T->Type} (p0:P t0) (pw0:P(w s0)) (l:k#pw0 = p0) (H:(∏ t, P t) -> UU) (J:(∏ s, P(w s)) -> UU) (g:∏ f:(∏ t, P t), weq (H f) (J (maponsec1 P w f))) : weq (hfiber (λ fh:total2 H, pr1 fh t0) p0 ) (hfiber (λ fh:total2 J, pr1 fh s0) pw0). Proof. intros. simple refine (weqbandf _ _ _ _). { simple refine (weqbandf _ _ _ _). { exact (weqonsecbase P w). } { unfold weqonsecbase; simpl. exact g. } } { intros [f h]. simpl. unfold maponsec1; simpl. induction k, l; simpl. unfold transportf; simpl. apply idweq. } Defined. Definition maponpaths_app_homot {X Y₁ Y₂ : UU} {f g : Y₁ → X → Y₂} (p : ∏ (z : Y₁ × X), f (pr1 z) (pr2 z) = g (pr1 z) (pr2 z)) (x : X) (y : Y₁) : maponpaths (λ f, f x) (app_homot p y) = p (y ,, x). Proof. apply (maponpaths_funextsec (f y)). Defined. Definition path_path_fun {X Y : UU} {f g : X → Y} {e₁ e₂ : f = g} (h : ∏ (x : X), eqtohomot e₁ x = eqtohomot e₂ x) : e₁ = e₂. Proof. refine (!(@funextsec_toforallpaths X (λ _, Y) f g e₁) @ _). refine (_ @ @funextsec_toforallpaths X (λ _, Y) f g e₂). apply maponpaths. use funextsec. intro x. apply h. Defined. UniMath-20231010/UniMath/MoreFoundations/WeakEquivalences.v000066400000000000000000000060401451125700300234130ustar00rootroot00000000000000(** * Weak equivalences *) Require Import UniMath.Foundations.PartA. (** ** Contents - Direct products *) (** If x = y, then x = z if and only if y = z by transitivity. *) Definition transitive_paths_weq {X : UU} {x y z : X} : x = y -> (x = z ≃ y = z). Proof. intro xeqy. use weq_iso. - intro xeqz. exact (!xeqy @ xeqz). - intro yeqz. exact (xeqy @ yeqz). - intro xeqz. refine (path_assoc _ _ _ @ _). refine (maponpaths (λ p, p @ xeqz) (pathsinv0r xeqy) @ _). reflexivity. - intro yeqz. refine (path_assoc _ _ _ @ _). refine (maponpaths (λ p, p @ yeqz) (pathsinv0l xeqy) @ _). reflexivity. Defined. (** TODO: can this be derived from [weqtotal2comm12] or similar? *) Definition weqtotal2comm {A B : UU} {C : A → B → UU} : (∑ (a : A) (b : B), C a b) ≃ (∑ (b : B) (a : A), C a b). Proof. use weq_iso. - exact (λ pair, pr1 (pr2 pair),, pr1 pair,, pr2 (pr2 pair)). - exact (λ pair, pr1 (pr2 pair),, pr1 pair,, pr2 (pr2 pair)). - reflexivity. - reflexivity. Defined. (** ** Direct products *) (** A rewrite of [pathsdirprod] as an equivalence: Two pairs are equal if and only if both of their components are. *) Definition pathsdirprodweq {X Y : UU} {x1 x2 : X} {y1 y2 : Y} : (make_dirprod x1 y1 = make_dirprod x2 y2) ≃ (x1 = x2) × (y1 = y2). Proof. intermediate_weq (make_dirprod x1 y1 ╝ make_dirprod x2 y2). - apply total2_paths_equiv. - unfold PathPair; cbn. use weqfibtototal; intro p; cbn. apply transitive_paths_weq. apply (toforallpaths _ _ _ (transportf_const p Y) y1). Defined. (** Contractible types are neutral elements for ×, up to weak equivalence. *) Lemma dirprod_with_contr_r : ∏ X Y : UU, iscontr X -> (Y ≃ Y × X). Proof. intros X Y iscontrX. intermediate_weq (Y × unit); [apply weqtodirprodwithunit|]. - apply weqdirprodf. * apply idweq. * apply invweq, weqcontrtounit; assumption. Defined. Lemma dirprod_with_contr_l : ∏ X Y : UU, iscontr X -> (Y ≃ X × Y). Proof. intros X Y iscontrX. intermediate_weq (Y × X). - apply dirprod_with_contr_r; assumption. - apply weqdirprodcomm. Defined. Lemma total2_assoc_fun_left {A B : UU} (C : A -> B -> UU) (D : (∏ a : A, ∑ b : B, C a b) -> UU) : (∑ (x : ∏ a : A, ∑ b : B, C a b), D x) ≃ ∑ (x : ∏ _ : A, B), ∑ (y : ∏ a : A, C a (x a)), D (fun a : A => (x a,, y a)). Proof. use weq_iso. - intros p. exists (fun a => (pr1 (pr1 p a))). exists (fun a => (pr2 (pr1 p a))). exact (pr2 p). - intros p. use tpair. + intros a. use tpair. * exact (pr1 p a). * exact (pr1 (pr2 p) a). + exact (pr2 (pr2 p)). - reflexivity. - reflexivity. Defined. Lemma sec_total2_distributivity {A : UU} {B : A -> UU} (C : ∏ a, B a -> UU) : (∏ a : A, ∑ b : B a, C a b) ≃ (∑ b : ∏ a : A, B a, ∏ a, C a (b a)). Proof. use weq_iso. - intro f. use tpair. + exact (fun a => pr1 (f a)). + exact (fun a => pr2 (f a)). - intro f. intro a. exists ((pr1 f) a). apply (pr2 f). - apply idpath. - apply idpath. Defined. UniMath-20231010/UniMath/MoreFoundations/dune000066400000000000000000000002231451125700300206430ustar00rootroot00000000000000(rule (deps (source_tree .)) (action (with-stdout-to All.v (run %{project_root}/util/generate-exports UniMath.MoreFoundations "%{deps}")))) UniMath-20231010/UniMath/NumberSystems/000077500000000000000000000000001451125700300174745ustar00rootroot00000000000000UniMath-20231010/UniMath/NumberSystems/.package/000077500000000000000000000000001451125700300211455ustar00rootroot00000000000000UniMath-20231010/UniMath/NumberSystems/.package/files000066400000000000000000000001331451125700300221670ustar00rootroot00000000000000NaturalNumbersAlgebra.v NaturalNumbers_le_Inductive.v Integers.v RationalNumbers.v Tests.v UniMath-20231010/UniMath/NumberSystems/Integers.v000066400000000000000000001665031451125700300214560ustar00rootroot00000000000000(** * Generalities on the type of integers and integer arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011. In this file we introduce the type [ hz ] of integers defined as the quotient set of [ dirprod nat nat ] by the standard equivalence relation and develop the main notions of the integer arithmetic using this definition . *) (** ** Preamble *) (** Settings *) Unset Kernel Term Sharing. (** Imports *) Require Export UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.PartA. Require Export UniMath.MoreFoundations.NegativePropositions. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Export UniMath.Algebra.RigsAndRings. Require Export UniMath.NumberSystems.NaturalNumbersAlgebra. (** Upstream *) (** ** The commutative ring [ hz ] of integres *) (** *** General definitions *) Definition hz : commring := commrigtocommring natcommrig . Definition hzaddabgr : abgr := hz . Definition hzmultabmonoid : abmonoid := ringmultabmonoid hz . Definition natnattohz : nat -> nat -> hz := λ n m, setquotpr _ ( make_dirprod n m ) . Definition hzplus : hz -> hz -> hz := @op1 hz. Definition hzsign : hz -> hz := grinv hzaddabgr . Definition hzminus : hz -> hz -> hz := λ x y, hzplus x ( hzsign y ) . Definition hzzero : hz := unel hzaddabgr . Definition hzmult : hz -> hz -> hz := @op2 hz . Definition hzone : hz := unel hzmultabmonoid . Declare Scope hz_scope. Bind Scope hz_scope with hz . Notation " x + y " := ( hzplus x y ) : hz_scope . Notation " 0 " := hzzero : hz_scope . Notation " 1 " := hzone : hz_scope . Notation " - x " := ( hzsign x ) : hz_scope . Notation " x - y " := ( hzminus x y ) : hz_scope . Notation " x * y " := ( hzmult x y ) : hz_scope . Delimit Scope hz_scope with hz . (** *** Properties of equlaity on [ hz ] *) Theorem isdeceqhz : isdeceq hz . Proof . change ( isdeceq ( abgrdiff ( rigaddabmonoid natcommrig ) ) ) . apply isdeceqabgrdiff . apply isinclnatplusr . apply isdeceqnat . Defined . Opaque isdeceqhz. Lemma isasethz : isaset hz . Proof . apply ( setproperty hzaddabgr ) . Defined . Opaque isasethz. Definition hzeq ( x y : hz ) : hProp := make_hProp ( x = y ) ( isasethz _ _ ) . Definition isdecrelhzeq : isdecrel hzeq := λ a b, isdeceqhz a b . Definition hzdeceq : decrel hz := make_decrel isdecrelhzeq . (* Canonical Structure hzdeceq. *) Definition hzbooleq := decreltobrel hzdeceq . Definition hzneq ( x y : hz ) : hProp := make_hProp ( neg ( x = y ) ) ( isapropneg _ ) . Definition isdecrelhzneq : isdecrel hzneq := isdecnegrel _ isdecrelhzeq . Definition hzdecneq : decrel hz := make_decrel isdecrelhzneq . (* Canonical Structure hzdecneq. *) Definition hzboolneq := decreltobrel hzdecneq . Local Open Scope hz_scope . (** *** [ hz ] is a non-zero ring *) Lemma isnonzerorighz : isnonzerorig hz . Proof . apply ( ct ( hzneq , isdecrelhzneq, 1 , 0 ) ) . Defined . (** *** Properties of addition and subtraction on [ hz ] *) Definition hzminuszero : ( - 0 ) = 0 := ringinvunel1 hz . Lemma hzplusr0 ( x : hz ) : ( x + 0 ) = x . Proof . apply ( ringrunax1 _ x ) . Defined . Lemma hzplusl0 ( x : hz ) : ( 0 + x ) = x . Proof . apply ( ringlunax1 _ x ) . Defined . Lemma hzplusassoc ( x y z : hz ) : ( ( x + y ) + z ) = ( x + ( y + z ) ) . Proof . intros . apply ( ringassoc1 hz x y z ) . Defined . Lemma hzpluscomm ( x y : hz ) : ( x + y ) = ( y + x ) . Proof . intros . apply ( ringcomm1 hz x y ) . Defined . Lemma hzlminus ( x : hz ) : ( -x + x ) = 0 . Proof . apply ( ringlinvax1 hz x ) . Defined . Lemma hzrminus ( x : hz ) : ( x - x ) = 0 . Proof . apply ( ringrinvax1 hz x ) . Defined . Lemma isinclhzplusr ( n : hz ) : isincl ( λ m : hz, m + n ) . Proof. apply ( pr2 ( weqtoincl ( weqrmultingr hzaddabgr n ) ) ) . Defined. Lemma isinclhzplusl ( n : hz ) : isincl ( λ m : hz, n + m ) . Proof. apply ( pr2 ( weqtoincl ( weqlmultingr hzaddabgr n ) ) ) . Defined . Lemma hzpluslcan ( a b c : hz ) ( is : ( c + a ) = ( c + b ) ) : a = b . Proof . intros . apply ( @grlcan hzaddabgr a b c is ) . Defined . Lemma hzplusrcan ( a b c : hz ) ( is : ( a + c ) = ( b + c ) ) : a = b . Proof . intros . apply ( @grrcan hzaddabgr a b c is ) . Defined . Definition hzinvmaponpathsminus { a b : hz } ( e : ( - a ) = ( - b ) ) : a = b := grinvmaponpathsinv hzaddabgr e . Lemma hzrplusminus (n m : hz) : n + m - m = n. Proof. unfold hzminus, hzplus, hzplus. rewrite ringassoc1. set (tmp := hzrminus m). unfold hzminus, hzplus in tmp. rewrite tmp. clear tmp. apply hzplusr0. Defined. Opaque hzrplusminus. Lemma hzrplusminus' (n m : hz) : n = n + m - m. Proof. apply pathsinv0. apply hzrplusminus. Defined. Opaque hzrplusminus'. Lemma hzrminusplus (n m : hz) : n - m + m = n. Proof. unfold hzplus, hzminus. rewrite ringassoc1. rewrite hzlminus. apply hzplusr0. Defined. Opaque hzrminusplus. Lemma hzrminusplus' (n m : hz) : n = n - m + m. Proof. apply pathsinv0. apply hzrminusplus. Defined. Opaque hzrminusplus'. (** *** Properties of multiplication on [ hz ] *) Lemma hzmultr1 ( x : hz ) : ( x * 1 ) = x . Proof . apply ( ringrunax2 _ x ) . Defined . Lemma hzmultl1 ( x : hz ) : ( 1 * x ) = x . Proof . apply ( ringlunax2 _ x ) . Defined . Lemma hzmult0x ( x : hz ) : ( 0 * x ) = 0 . Proof . apply ( ringmult0x _ x ) . Defined . Lemma hzmultx0 ( x : hz ) : ( x * 0 ) = 0 . Proof . apply ( ringmultx0 _ x ) . Defined . Lemma hzmultassoc ( x y z : hz ) : ( ( x * y ) * z ) = ( x * ( y * z ) ) . Proof . intros . apply ( ringassoc2 hz x y z ) . Defined . Lemma hzmultcomm ( x y : hz ) : ( x * y ) = ( y * x ) . Proof . intros . apply ( ringcomm2 hz x y ) . Defined . Definition hzneq0andmultlinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq n 0 := ringneq0andmultlinv hz n m isnm . Definition hzneq0andmultrinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq m 0 := ringneq0andmultrinv hz n m isnm . (** ** Definition and properties of "greater", "less", "greater or equal" and "less or equal" on [ hz ] . *) (** *** Definitions and notations *) Definition hzgth : hrel hz := rigtoringrel natcommrig isplushrelnatgth . Definition hzlth : hrel hz := λ a b, hzgth b a . Definition hzleh : hrel hz := λ a b, make_hProp ( neg ( hzgth a b ) ) ( isapropneg _ ) . Definition hzgeh : hrel hz := λ a b, make_hProp ( neg ( hzgth b a ) ) ( isapropneg _ ) . (** *** Decidability *) Lemma isdecrelhzgth : isdecrel hzgth . Proof . apply ( isdecrigtoringrel natcommrig isplushrelnatgth ) . apply isinvplushrelnatgth . apply isdecrelnatgth . Defined . Definition hzgthdec := make_decrel isdecrelhzgth . (* Canonical Structure hzgthdec . *) Definition isdecrelhzlth : isdecrel hzlth := λ x x', isdecrelhzgth x' x . Definition hzlthdec := make_decrel isdecrelhzlth . (* Canonical Structure hzlthdec . *) Definition isdecrelhzleh : isdecrel hzleh := isdecnegrel _ isdecrelhzgth . Definition hzlehdec := make_decrel isdecrelhzleh . (* Canonical Structure hzlehdec . *) Definition isdecrelhzgeh : isdecrel hzgeh := λ x x', isdecrelhzleh x' x . Definition hzgehdec := make_decrel isdecrelhzgeh . (* Canonical Structure hzgehdec . *) (** *** Properties of individual relations *) (** [ hzgth ] *) Lemma istranshzgth ( n m k : hz ) : hzgth n m -> hzgth m k -> hzgth n k . Proof. apply ( istransabgrdiffrel nataddabmonoid isplushrelnatgth ) . unfold istrans . apply istransnatgth . Defined. Lemma isirreflhzgth ( n : hz ) : neg ( hzgth n n ) . Proof. apply ( isirreflabgrdiffrel nataddabmonoid isplushrelnatgth ) . unfold isirrefl . apply isirreflnatgth . Defined . Lemma hzgthtoneq ( n m : hz ) ( g : hzgth n m ) : neg ( n = m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflhzgth _ g ) . Defined . Lemma isasymmhzgth ( n m : hz ) : hzgth n m -> hzgth m n -> empty . Proof. apply ( isasymmabgrdiffrel nataddabmonoid isplushrelnatgth ) . unfold isasymm . apply isasymmnatgth . Defined . Lemma isantisymmneghzgth ( n m : hz ) : neg ( hzgth n m ) -> neg ( hzgth m n ) -> n = m . Proof . apply ( isantisymmnegabgrdiffrel nataddabmonoid isplushrelnatgth ) . unfold isantisymmneg . apply isantisymmnegnatgth . Defined . Lemma isnegrelhzgth : isnegrel hzgth . Proof . apply isdecreltoisnegrel . apply isdecrelhzgth . Defined . Lemma iscoantisymmhzgth ( n m : hz ) : neg ( hzgth n m ) -> ( hzgth m n ) ⨿ ( n = m ) . Proof . revert n m. apply isantisymmnegtoiscoantisymm . apply isdecrelhzgth . intros n m . apply isantisymmneghzgth . Defined . Lemma iscotranshzgth ( n m k : hz ) : hzgth n k -> hdisj ( hzgth n m ) ( hzgth m k ) . Proof . intros gxz . destruct ( isdecrelhzgth n m ) as [ gxy | ngxy ] . apply ( hinhpr ( ii1 gxy ) ) . apply hinhpr . apply ii2 . destruct ( isdecrelhzgth m n ) as [ gyx | ngyx ] . apply ( istranshzgth _ _ _ gyx gxz ) . set ( e := isantisymmneghzgth _ _ ngxy ngyx ) . rewrite e in gxz . apply gxz . Defined . (** [ hzlth ] *) Definition istranshzlth ( n m k : hz ) : hzlth n m -> hzlth m k -> hzlth n k := λ lnm lmk, istranshzgth _ _ _ lmk lnm . Definition isirreflhzlth ( n : hz ) : neg ( hzlth n n ) := isirreflhzgth n . Lemma hzlthtoneq ( n m : hz ) ( g : hzlth n m ) : neg ( n = m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflhzlth _ g ) . Defined . Definition isasymmhzlth ( n m : hz ) : hzlth n m -> hzlth m n -> empty := λ lnm lmn, isasymmhzgth _ _ lmn lnm . Definition isantisymmneghztth ( n m : hz ) : neg ( hzlth n m ) -> neg ( hzlth m n ) -> n = m := λ nlnm nlmn, isantisymmneghzgth _ _ nlmn nlnm . Definition isnegrelhzlth : isnegrel hzlth := λ n m, isnegrelhzgth m n . Definition iscoantisymmhzlth ( n m : hz ) : neg ( hzlth n m ) -> ( hzlth m n ) ⨿ ( n = m ) . Proof . intros nlnm . destruct ( iscoantisymmhzgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . Definition iscotranshzlth ( n m k : hz ) : hzlth n k -> hdisj ( hzlth n m ) ( hzlth m k ) . Proof . intros lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshzgth _ _ _ lnk ) ) . Defined . (** [ hzleh ] *) Definition istranshzleh ( n m k : hz ) : hzleh n m -> hzleh m k -> hzleh n k . Proof. apply istransnegrel . unfold iscotrans. apply iscotranshzgth . Defined. Definition isreflhzleh ( n : hz ) : hzleh n n := isirreflhzgth n . Definition isantisymmhzleh ( n m : hz ) : hzleh n m -> hzleh m n -> n = m := isantisymmneghzgth n m . Definition isnegrelhzleh : isnegrel hzleh . Proof . apply isdecreltoisnegrel . apply isdecrelhzleh . Defined . Definition iscoasymmhzleh ( n m : hz ) ( nl : neg ( hzleh n m ) ) : hzleh m n := negf ( isasymmhzgth _ _ ) nl . Definition istotalhzleh : istotal hzleh . Proof . intros x y . destruct ( isdecrelhzleh x y ) as [ lxy | lyx ] . apply ( hinhpr ( ii1 lxy ) ) . apply hinhpr . apply ii2 . apply ( iscoasymmhzleh _ _ lyx ) . Defined . (** [ hzgeh ] . *) Definition istranshzgeh ( n m k : hz ) : hzgeh n m -> hzgeh m k -> hzgeh n k := λ gnm gmk, istranshzleh _ _ _ gmk gnm . Definition isreflhzgeh ( n : hz ) : hzgeh n n := isreflhzleh _ . Definition isantisymmhzgeh ( n m : hz ) : hzgeh n m -> hzgeh m n -> n = m := λ gnm gmn, isantisymmhzleh _ _ gmn gnm . Definition isnegrelhzgeh : isnegrel hzgeh := λ n m, isnegrelhzleh m n . Definition iscoasymmhzgeh ( n m : hz ) ( nl : neg ( hzgeh n m ) ) : hzgeh m n := iscoasymmhzleh _ _ nl . Definition istotalhzgeh : istotal hzgeh := λ n m, istotalhzleh m n . (** *** Simple implications between comparisons *) Definition hzgthtogeh ( n m : hz ) : hzgth n m -> hzgeh n m . Proof. intros g . apply iscoasymmhzgeh . apply ( todneg _ g ) . Defined . Definition hzlthtoleh ( n m : hz ) : hzlth n m -> hzleh n m := hzgthtogeh _ _ . Definition hzlehtoneghzgth ( n m : hz ) : hzleh n m -> neg ( hzgth n m ) . Proof. intros is is' . apply ( is is' ) . Defined . Definition hzgthtoneghzleh ( n m : hz ) : hzgth n m -> neg ( hzleh n m ) := λ g l , hzlehtoneghzgth _ _ l g . Definition hzgehtoneghzlth ( n m : hz ) : hzgeh n m -> neg ( hzlth n m ) := λ gnm lnm, hzlehtoneghzgth _ _ gnm lnm . Definition hzlthtoneghzgeh ( n m : hz ) : hzlth n m -> neg ( hzgeh n m ) := λ gnm lnm, hzlehtoneghzgth _ _ lnm gnm . Definition neghzlehtogth ( n m : hz ) : neg ( hzleh n m ) -> hzgth n m := isnegrelhzgth n m . Definition neghzgehtolth ( n m : hz ) : neg ( hzgeh n m ) -> hzlth n m := isnegrelhzlth n m . Definition neghzgthtoleh ( n m : hz ) : neg ( hzgth n m ) -> hzleh n m . Proof . intros ng . destruct ( isdecrelhzleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) . Defined . Definition neghzlthtogeh ( n m : hz ) : neg ( hzlth n m ) -> hzgeh n m := λ nl, neghzgthtoleh _ _ nl . (** *** Comparison alternatives *) Definition hzgthorleh ( n m : hz ) : ( hzgth n m ) ⨿ ( hzleh n m ) . Proof . intros . apply ( isdecrelhzgth n m ) . Defined . Definition hzlthorgeh ( n m : hz ) : ( hzlth n m ) ⨿ ( hzgeh n m ) := hzgthorleh _ _ . Definition hzneqchoice ( n m : hz ) ( ne : neg ( n = m ) ) : ( hzgth n m ) ⨿ ( hzlth n m ) . Proof . intros . destruct ( hzgthorleh n m ) as [ g | l ] . destruct ( hzlthorgeh n m ) as [ g' | l' ] . destruct ( isasymmhzgth _ _ g g' ) . apply ( ii1 g ) . destruct ( hzlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmhzleh _ _ l g' ) ) . Defined . Definition hzlehchoice ( n m : hz ) ( l : hzleh n m ) : ( hzlth n m ) ⨿ ( n = m ) . Proof . intros . destruct ( hzlthorgeh n m ) as [ l' | g ] . apply ( ii1 l' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined . Definition hzgehchoice ( n m : hz ) ( g : hzgeh n m ) : ( hzgth n m ) ⨿ ( n = m ) . Proof . intros . destruct ( hzgthorleh n m ) as [ g' | l ] . apply ( ii1 g' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined . (** *** Mixed transitivities *) Lemma hzgthgehtrans ( n m k : hz ) : hzgth n m -> hzgeh m k -> hzgth n k . Proof. intros gnm gmk . destruct ( hzgehchoice m k gmk ) as [ g' | e ] . apply ( istranshzgth _ _ _ gnm g' ) . rewrite e in gnm . apply gnm . Defined. Lemma hzgehgthtrans ( n m k : hz ) : hzgeh n m -> hzgth m k -> hzgth n k . Proof. intros gnm gmk . destruct ( hzgehchoice n m gnm ) as [ g' | e ] . apply ( istranshzgth _ _ _ g' gmk ) . rewrite e . apply gmk . Defined. Lemma hzlthlehtrans ( n m k : hz ) : hzlth n m -> hzleh m k -> hzlth n k . Proof . intros l1 l2 . apply ( hzgehgthtrans k m n l2 l1 ) . Defined . Lemma hzlehlthtrans ( n m k : hz ) : hzleh n m -> hzlth m k -> hzlth n k . Proof . intros l1 l2 . apply ( hzgthgehtrans k m n l2 l1 ) . Defined . (** *** Addition and comparisons *) (** [ hzgth ] *) Definition hzgthandplusl ( n m k : hz ) : hzgth n m -> hzgth ( k + n ) ( k + m ) . Proof. apply ( pr1 ( isbinopabgrdiffrel nataddabmonoid isplushrelnatgth ) ) . Defined . Definition hzgthandplusr ( n m k : hz ) : hzgth n m -> hzgth ( n + k ) ( m + k ) . Proof. apply ( pr2 ( isbinopabgrdiffrel nataddabmonoid isplushrelnatgth ) ) . Defined . Definition hzgthandpluslinv ( n m k : hz ) : hzgth ( k + n ) ( k + m ) -> hzgth n m . Proof. intros g . set ( g' := hzgthandplusl _ _ ( - k ) g ) . clearbody g' . rewrite ( pathsinv0 ( hzplusassoc _ _ n ) ) in g' . rewrite ( pathsinv0 ( hzplusassoc _ _ m ) ) in g' . rewrite ( hzlminus k ) in g' . rewrite ( hzplusl0 _ ) in g' . rewrite ( hzplusl0 _ ) in g' . apply g' . Defined . Definition hzgthandplusrinv ( n m k : hz ) : hzgth ( n + k ) ( m + k ) -> hzgth n m . Proof. intros l . rewrite ( hzpluscomm n k ) in l . rewrite ( hzpluscomm m k ) in l . apply ( hzgthandpluslinv _ _ _ l ) . Defined . Lemma hzgthsnn ( n : hz ) : hzgth ( n + 1 ) n . Proof . set ( int := hzgthandplusl _ _ n ( ct ( hzgth , isdecrelhzgth, 1 , 0 ) ) ) . clearbody int . rewrite ( hzplusr0 _ ) in int . apply int . Defined . (** [ hzlth ] *) Definition hzlthandplusl ( n m k : hz ) : hzlth n m -> hzlth ( k + n ) ( k + m ) := hzgthandplusl _ _ _ . Definition hzlthandplusr ( n m k : hz ) : hzlth n m -> hzlth ( n + k ) ( m + k ) := hzgthandplusr _ _ _ . Definition hzlthandpluslinv ( n m k : hz ) : hzlth ( k + n ) ( k + m ) -> hzlth n m := hzgthandpluslinv _ _ _ . Definition hzlthandplusrinv ( n m k : hz ) : hzlth ( n + k ) ( m + k ) -> hzlth n m := hzgthandplusrinv _ _ _ . Definition hzlthnsn ( n : hz ) : hzlth n ( n + 1 ) := hzgthsnn n . (** [ hzleh ] *) Definition hzlehandplusl ( n m k : hz ) : hzleh n m -> hzleh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv n m k ) . Definition hzlehandplusr ( n m k : hz ) : hzleh n m -> hzleh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv n m k ) . Definition hzlehandpluslinv ( n m k : hz ) : hzleh ( k + n ) ( k + m ) -> hzleh n m := negf ( hzgthandplusl n m k ) . Definition hzlehandplusrinv ( n m k : hz ) : hzleh ( n + k ) ( m + k ) -> hzleh n m := negf ( hzgthandplusr n m k ) . (** [ hzgeh ] *) Definition hzgehandplusl ( n m k : hz ) : hzgeh n m -> hzgeh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv m n k ) . Definition hzgehandplusr ( n m k : hz ) : hzgeh n m -> hzgeh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv m n k ) . Definition hzgehandpluslinv ( n m k : hz ) : hzgeh ( k + n ) ( k + m ) -> hzgeh n m := negf ( hzgthandplusl m n k ) . Definition hzgehandplusrinv ( n m k : hz ) : hzgeh ( n + k ) ( m + k ) -> hzgeh n m := negf ( hzgthandplusr m n k ) . (** *** Properties of [ hzgth ] in the terminology of algebra1.v (continued below) Note: at the moment we do not need properties of [ hzlth ] , [ hzleh ] and [ hzgeh ] in terminology of algebra1 since the corresponding relations on [ hq ] are bulid from [ hqgth ] . *) Lemma isplushrelhzgth : @isbinophrel hzaddabgr hzgth . Proof . split . apply hzgthandplusl . apply hzgthandplusr . Defined . Lemma isinvplushrelhzgth : @isinvbinophrel hzaddabgr hzgth . Proof . split . apply hzgthandpluslinv . apply hzgthandplusrinv . Defined . Lemma isringmulthzgth : isringmultgt _ hzgth . Proof . apply ( isringrigtoringmultgt natcommrig isplushrelnatgth isrigmultgtnatgth ) . Defined . Lemma isinvringmulthzgth : isinvringmultgt _ hzgth . Proof . apply ( isinvringrigtoringmultgt natcommrig isplushrelnatgth isinvplushrelnatgth isinvrigmultgtnatgth ) . Defined . (** *** Negation and comparisons *) (** [ hzgth ] *) Lemma hzgth0andminus { n : hz } ( is : hzgth n 0 ) : hzlth ( - n ) 0 . Proof . intros . apply ( ringfromgt0 hz isplushrelhzgth ) . apply is . Defined . Lemma hzminusandgth0 { n : hz } ( is : hzgth ( - n ) 0 ) : hzlth n 0 . Proof . intros . apply ( ringtolt0 hz isplushrelhzgth ) . apply is . Defined . (** [ hzlth ] *) Lemma hzlth0andminus { n : hz } ( is : hzlth n 0 ) : hzgth ( - n ) 0 . Proof . intros . apply ( ringfromlt0 hz isplushrelhzgth ) . apply is . Defined . Lemma hzminusandlth0 { n : hz } ( is : hzlth ( - n ) 0 ) : hzgth n 0 . Proof . intros . apply ( ringtogt0 hz isplushrelhzgth ) . apply is . Defined . (* ??? Coq slows down on the proofs of these two lemmas for no good reason. *) (** [ hzleh ] *) Lemma hzleh0andminus { n : hz } ( is : hzleh n 0 ) : hzgeh ( - n ) 0 . Proof . revert is. apply ( negf ( @hzminusandlth0 n ) ) . Defined . Lemma hzminusandleh0 { n : hz } ( is : hzleh ( - n ) 0 ) : hzgeh n 0 . Proof . revert is. apply ( negf ( @hzlth0andminus n ) ) . Defined . (** [ hzgeh ] *) Lemma hzgeh0andminus { n : hz } ( is : hzgeh n 0 ) : hzleh ( - n ) 0 . Proof . revert is . apply ( negf ( @hzminusandgth0 n ) ) . Defined . Lemma hzminusandgeh0 { n : hz } ( is : hzgeh ( - n ) 0 ) : hzleh n 0 . Proof . revert is . apply ( negf ( @hzgth0andminus n ) ) . Defined . (** *** Multiplication and comparisons *) (** [ hzgth ] *) Definition hzgthandmultl ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( k * n ) ( k * m ) . Proof. revert n m k is. apply ( isringmultgttoislringmultgt _ isplushrelhzgth isringmulthzgth ) . Defined . Definition hzgthandmultr ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( n * k ) ( m * k ) . Proof . revert n m k is. apply ( isringmultgttoisrringmultgt _ isplushrelhzgth isringmulthzgth ) . Defined . Definition hzgthandmultlinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( k * n ) ( k * m ) -> hzgth n m . Proof . intros is' . apply ( isinvringmultgttoislinvringmultgt hz isplushrelhzgth isinvringmulthzgth n m k is is' ) . Defined . Definition hzgthandmultrinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( n * k ) ( m * k ) -> hzgth n m . Proof. intros is' . apply ( isinvringmultgttoisrinvringmultgt hz isplushrelhzgth isinvringmulthzgth n m k is is' ) . Defined . (** [ hzlth ] *) Definition hzlthandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( k * n ) ( k * m ) := hzgthandmultl _ _ _ is . Definition hzlthandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( n * k ) ( m * k ) := hzgthandmultr _ _ _ is . Definition hzlthandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( k * n ) ( k * m ) -> hzlth n m := hzgthandmultlinv _ _ _ is . Definition hzlthandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( n * k ) ( m * k ) -> hzlth n m := hzgthandmultrinv _ _ _ is . (** [ hzleh ] *) Definition hzlehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) . Definition hzlehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) . Definition hzlehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( k * n ) ( k * m ) -> hzleh n m := negf ( hzgthandmultl _ _ _ is ) . Definition hzlehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( n * k ) ( m * k ) -> hzleh n m := negf ( hzgthandmultr _ _ _ is ) . (** [ hzgeh ] *) Definition hzgehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) . Definition hzgehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) . Definition hzgehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( k * n ) ( k * m ) -> hzgeh n m := negf ( hzgthandmultl _ _ _ is ) . Definition hzgehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( n * k ) ( m * k ) -> hzgeh n m := negf ( hzgthandmultr _ _ _ is ) . (** Multiplication of positive with positive, positive with negative, negative with positive, two negatives etc. *) Lemma hzmultgth0gth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgth n 0 ) : hzgth ( m * n ) 0 . Proof . intros . apply isringmulthzgth . apply ism . apply isn . Defined . Lemma hzmultgth0geh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . apply ( hzgthtogeh _ _ ( hzmultgth0gth0 ism gn ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultgeh0gth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgth n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ ism ) as [ gm | em ] . apply ( hzgthtogeh _ _ ( hzmultgth0gth0 gm isn ) ) . rewrite em . rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined . Lemma hzmultgeh0geh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . apply ( hzmultgeh0gth0 ism gn ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultgth0lth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzlth n 0 ) : hzlth ( m * n ) 0 . Proof . intros . apply ( ringmultgt0lt0 hz isplushrelhzgth isringmulthzgth ) . apply ism . apply isn . Defined . Lemma hzmultgth0leh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzlthtoleh _ _ ( hzmultgth0lth0 ism ln ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined . Lemma hzmultgeh0lth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzlth n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . apply ( hzlthtoleh _ _ ( hzmultgth0lth0 lm isn ) ) . destruct em . rewrite ( hzmult0x _ ) . apply isreflhzleh . Defined . Lemma hzmultgeh0leh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzmultgeh0lth0 ism ln ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined . Lemma hzmultlth0gth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgth n 0 ) : hzlth ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgth0lth0 . apply isn . apply ism . Defined . Lemma hzmultlth0geh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgeh0lth0 . apply isn . apply ism . Defined . Lemma hzmultleh0gth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgth n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgth0leh0 . apply isn . apply ism . Defined . Lemma hzmultleh0geh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgeh0leh0 . apply isn . apply ism . Defined . Lemma hzmultlth0lth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzlth n 0 ) : hzgth ( m * n ) 0 . Proof . intros . assert ( ism' := hzlth0andminus ism ) . assert ( isn' := hzlth0andminus isn ) . assert ( int := isringmulthzgth _ _ ism' isn' ) . rewrite ( ringmultminusminus hz ) in int . apply int . Defined . Lemma hzmultlth0leh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzgthtogeh _ _ ( hzmultlth0lth0 ism ln ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultleh0lth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzlth n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . apply ( hzgthtogeh _ _ ( hzmultlth0lth0 lm isn ) ) . rewrite em . rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined . Lemma hzmultleh0leh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzmultleh0lth0 ism ln ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . (** *** [ hz ] as an integral domain *) Lemma isintdomhz : isintdom hz . Proof . split with isnonzerorighz . intros a b e0 . destruct ( isdeceqhz a 0 ) as [ ea | nea ] . apply ( hinhpr ( ii1 ea ) ) . destruct ( isdeceqhz b 0 ) as [ eb | neb ] . apply ( hinhpr ( ii2 eb ) ) . destruct ( hzneqchoice _ _ nea ) as [ ga | la ] . destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] . destruct ( hzgthtoneq _ _ ( hzmultgth0gth0 ga gb ) e0 ) . destruct ( hzlthtoneq _ _ ( hzmultgth0lth0 ga lb ) e0 ) . destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] . destruct ( hzlthtoneq _ _ ( hzmultlth0gth0 la gb ) e0 ) . destruct ( hzgthtoneq _ _ ( hzmultlth0lth0 la lb ) e0 ) . Defined . Definition hzintdom : intdom := tpair _ _ isintdomhz . Definition hzneq0andmult ( n m : hz ) ( isn : hzneq n 0 ) ( ism : hzneq m 0 ) : hzneq ( n * m ) 0 := intdomneq0andmult hzintdom n m isn ism . Lemma hzmultlcan ( a b c : hz ) ( ne : neg ( c = 0 ) ) ( e : ( c * a ) = ( c * b ) ) : a = b . Proof . intros . apply ( intdomlcan hzintdom _ _ _ ne e ) . Defined . Lemma hzmultrcan ( a b c : hz ) ( ne : neg ( c = 0 ) ) ( e : ( a * c ) = ( b * c ) ) : a = b . Proof . intros . apply ( intdomrcan hzintdom _ _ _ ne e ) . Defined . Lemma isinclhzmultl ( n : hz )( ne : neg ( n = 0 ) ) : isincl ( λ m : hz, n * m ) . Proof. intros . apply ( pr1 ( intdomiscancelable hzintdom n ne ) ) . Defined . Lemma isinclhzmultr ( n : hz )( ne : neg ( n = 0 ) ) : isincl ( λ m : hz, m * n ) . Proof. intros . apply ( pr2 ( intdomiscancelable hzintdom n ne ) ) . Defined. (** *** Comparisons and [ n -> n + 1 ] *) Definition hzgthtogths ( n m : hz ) : hzgth n m -> hzgth ( n + 1 ) m . Proof. intros is . apply ( istranshzgth _ _ _ ( hzgthsnn n ) is ) . Defined . Definition hzlthtolths ( n m : hz ) : hzlth n m -> hzlth n ( m + 1 ) := hzgthtogths _ _ . Definition hzlehtolehs ( n m : hz ) : hzleh n m -> hzleh n ( m + 1 ) . Proof . intros is . apply ( istranshzleh _ _ _ is ( hzlthtoleh _ _ ( hzlthnsn _ ) ) ) . Defined . Definition hzgehtogehs ( n m : hz ) : hzgeh n m -> hzgeh ( n + 1 ) m := hzlehtolehs _ _ . (** *** Two comparisons and [ n -> n + 1 ] *) Lemma hzgthtogehsn ( n m : hz ) : hzgth n m -> hzgeh n ( m + 1 ) . Proof. assert ( int : ∏ n m , isaprop ( hzgth n m -> hzgeh n ( m + 1 ) ) ) . { intros . apply impred . intro . apply ( pr2 _ ) . } unfold hzgth in * . apply ( setquotuniv2prop _ ( λ n m, make_hProp _ ( int n m ) ) ) . set ( R := abgrdiffrelint nataddabmonoid natgth ) . intros x x' . change ( R x x' -> ( neg ( R ( @op ( abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig) ) x' ( make_dirprod 1%nat 0%nat ) ) x ) ) ) . unfold R . unfold abgrdiffrelint . simpl . apply ( @hinhuniv _ (make_hProp ( neg ( ishinh_UU _ ) ) ( isapropneg _ ) ) ) . intro t2 . simpl . unfold neg . apply ( @hinhuniv _ ( make_hProp _ isapropempty ) ) . intro t2' . set ( x1 := pr1 x ) . set ( a1 := pr2 x ) . set ( x2 := pr1 x' ) . set ( a2 := pr2 x' ) . set ( c1 := pr1 t2 ) . assert ( r1 := pr2 t2 ) . change ( pr1 ( ( x1 + a2 + c1 ) > ( x2 + a1 + c1 ) ) ) in r1 . set ( c2 := pr1 t2' ) . assert ( r2 := pr2 t2' ) . change ( pr1 ( ( ( x2 + 1 ) + a1 + c2 ) > ( x1 + ( a2 + 0 ) + c2 ) ) ) in r2 . assert ( r1' := natgthandplusrinv _ _ c1 r1 ) . assert ( r2' := natgthandplusrinv _ _ c2 r2 ) . rewrite ( natplusr0 _ ) in r2' . rewrite ( natpluscomm _ 1 ) in r2' . rewrite ( natplusassoc _ _ _ ) in r2' . change (1 + (x2 + a1) > x1 + a2) with (x1 + a2 ≤ x2 + a1) in r2'. contradicts (natlehneggth r2') r1'. Defined . Lemma hzgthsntogeh ( n m : hz ) : hzgth ( n + 1 ) m -> hzgeh n m . Proof. intros a . apply (hzgehandplusrinv n m 1) . apply ( hzgthtogehsn ( n + 1 ) m a ) . Defined. (* PeWa *) Lemma hzlehsntolth ( n m : hz ) : hzleh ( n + 1 ) m -> hzlth n m . Proof. intros X . apply ( hzlthlehtrans _ _ _ ( hzlthnsn n ) X ) . Defined . Lemma hzlthtolehsn ( n m : hz ) : hzlth n m -> hzleh ( n + 1 ) m . Proof. intros X . apply ( hzgthtogehsn m n X ) . Defined . Lemma hzlthsntoleh ( n m : hz ) : hzlth n ( m + 1 ) -> hzleh n m . Proof. intros a . apply (hzlehandplusrinv n m 1) . apply ( hzlthtolehsn n ( m + 1 ) a ) . Defined. (* PeWa *) Lemma hzgehsntogth ( n m : hz ) : hzgeh n ( m + 1 ) -> hzgth n m . Proof. intros X . apply ( hzlehsntolth m n X ) . Defined . (** *** Comparsion alternatives and [ n -> n + 1 ] *) Lemma hzlehchoice2 ( n m : hz ) : hzleh n m -> coprod ( hzleh ( n + 1 ) m ) ( n = m ) . Proof . intros l . destruct ( hzlehchoice n m l ) as [ l' | e ] . apply ( ii1 ( hzlthtolehsn _ _ l' ) ) . apply ( ii2 e ) . Defined . Lemma hzgehchoice2 ( n m : hz ) : hzgeh n m -> coprod ( hzgeh n ( m + 1 ) ) ( n = m ) . Proof . intros g . destruct ( hzgehchoice n m g ) as [ g' | e ] . apply ( ii1 ( hzgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined . Lemma hzgthchoice2 ( n m : hz ) : hzgth n m -> coprod ( hzgth n ( m + 1 ) ) ( n = ( m + 1 ) ) . Proof. intros g . destruct ( hzgehchoice _ _ ( hzgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) . apply ( ii2 e ) . Defined . Lemma hzlthchoice2 ( n m : hz ) : hzlth n m -> coprod ( hzlth ( n + 1 ) m ) ( ( n + 1 ) = m ) . Proof. intros l . destruct ( hzlehchoice _ _ ( hzlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) . apply ( ii2 e ) . Defined . (** *** Operations and comparisons on [ hz ] and [ natnattohz ] *) Lemma natnattohzandgth ( xa1 xa2 : dirprod nat nat ) ( is : hzgth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natgth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) . Proof . intros . change ( ishinh_UU ( total2 ( λ a0, natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) ) in is . generalize is . apply @hinhuniv . intro t2 . set ( a0 := pr1 t2 ) . assert ( g := pr2 t2 ) . change ( pr1 ( natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) in g . apply ( natgthandplusrinv _ _ a0 g ) . Defined . Lemma natnattohzandlth ( xa1 xa2 : dirprod nat nat ) ( is : hzlth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natlth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) . Proof . intros . apply ( natnattohzandgth xa2 xa1 is ) . Defined . (** *** Canonical rig homomorphism from [ nat ] to [ hz ] *) Definition nattohz : nat -> hz := λ n, setquotpr _ ( make_dirprod n 0%nat ) . Definition isinclnattohz : isincl nattohz := isincltoringdiff natcommrig ( λ n, isinclnatplusr n ) . Definition nattohzandneq ( n m : nat ) ( is : natnegpaths n m ) : hzneq ( nattohz n ) ( nattohz m ) := negf ( invmaponpathsincl _ isinclnattohz n m ) is . Definition nattohzand0 : ( nattohz 0%nat ) = 0 := idpath _ . Definition nattohzandS ( n : nat ) : ( nattohz ( S n ) ) = ( 1 + nattohz n ) := isbinop1funtoringdiff natcommrig 1%nat n . Definition nattohzand1 : ( nattohz 1%nat ) = 1 := idpath _ . Lemma nattorig_nattohz : ∏ n : nat, nattorig (X := hz) n = nattohz n. Proof. induction n as [|n IHn]. - unfold nattorig, nattohz ; simpl. reflexivity. - rewrite nattorigS, IHn. apply pathsinv0, nattohzandS. Qed. Definition nattohzandplus ( n m : nat ) : ( nattohz ( n + m )%nat ) = ( nattohz n + nattohz m ) := isbinop1funtoringdiff natcommrig n m . Definition nattohzandminus ( n m : nat ) ( is : natgeh n m ) : ( nattohz ( n - m )%nat ) = ( nattohz n - nattohz m ) . Proof . intros . apply ( hzplusrcan _ _ ( nattohz m ) ) . unfold hzminus . rewrite ( hzplusassoc ( nattohz n ) ( - nattohz m ) ( nattohz m ) ) . rewrite ( hzlminus _ ) . rewrite hzplusr0 . rewrite ( pathsinv0 ( nattohzandplus _ _ ) ) . rewrite ( minusplusnmm _ _ is ) . apply idpath . Defined . Opaque nattohzandminus . Definition nattohzandmult ( n m : nat ) : ( nattohz ( n * m )%nat ) = ( nattohz n * nattohz m ) . Proof . intros . simpl . change nattohz with ( toringdiff natcommrig ) . apply ( isbinop2funtoringdiff natcommrig n m ) . Defined . Definition nattohzandgth ( n m : nat ) ( is : natgth n m ) : hzgth ( nattohz n ) ( nattohz m ) := iscomptoringdiff natcommrig isplushrelnatgth n m is . Definition nattohzandlth ( n m : nat ) ( is : natlth n m ) : hzlth ( nattohz n ) ( nattohz m ) := nattohzandgth m n is . Definition nattohzandleh ( n m : nat ) ( is : natleh n m ) : hzleh ( nattohz n ) ( nattohz m ) . Proof . intros . destruct ( natlehchoice _ _ is ) as [ l | e ] . apply ( hzlthtoleh _ _ ( nattohzandlth _ _ l ) ) . rewrite e . apply ( isreflhzleh ) . Defined . Definition nattohzandgeh ( n m : nat ) ( is : natgeh n m ) : hzgeh ( nattohz n ) ( nattohz m ) := nattohzandleh _ _ is . (** *** Addition and subtraction on [ nat ] and [ hz ] *) (** *** Absolute value on [ hz ] *) Definition hzabsvalint : ( dirprod nat nat ) -> nat . Proof . intro nm . destruct ( natgthorleh ( pr1 nm ) ( pr2 nm ) ) . apply ( sub ( pr1 nm ) ( pr2 nm ) ) . apply ( sub ( pr2 nm ) ( pr1 nm ) ) . Defined . Lemma hzabsvalintcomp : @iscomprelfun ( dirprod nat nat ) nat ( hrelabgrdiff nataddabmonoid ) hzabsvalint . Proof . unfold iscomprelfun . intros x x' . unfold hrelabgrdiff . simpl . apply ( @hinhuniv _ ( make_hProp _ ( isasetnat (hzabsvalint x) (hzabsvalint x') ) ) ) . unfold hzabsvalint . set ( n := ( pr1 x ) : nat ) . set ( m := ( pr2 x ) : nat ) . set ( n' := ( pr1 x' ) : nat ) . set ( m' := ( pr2 x' ) : nat ) . set ( int := natgthorleh n m ) . set ( int' := natgthorleh n' m' ) . intro tt0 . simpl . destruct tt0 as [ x0 eq ] . simpl in eq . assert ( e' := invmaponpathsincl _ ( isinclnatplusr x0 ) _ _ eq ) . destruct int as [isgt | isle ] . destruct int' as [ isgt' | isle' ] . apply ( invmaponpathsincl _ ( isinclnatplusr ( m + m' ) ) ) . rewrite ( pathsinv0 ( natplusassoc ( n - m ) m m' ) ) . rewrite ( natpluscomm m m' ) . rewrite ( pathsinv0 ( natplusassoc ( n' - m' ) m' m ) ) . rewrite ( minusplusnmm n m ( natgthtogeh _ _ isgt ) ) . rewrite ( minusplusnmm n' m' ( natgthtogeh _ _ isgt' ) ) . apply e' . assert ( e'' := natlehandplusl n' m' n isle' ) . assert ( e''' := natgthandplusr n m n' isgt ) . assert ( e'''' := natlthlehtrans _ _ _ e''' e'' ) . rewrite e' in e'''' . rewrite ( natpluscomm m n' ) in e'''' . destruct ( isirreflnatgth _ e'''' ) . destruct int' as [ isgt' | isle' ] . destruct ( natpluscomm m n') . set ( e'' := natlehandplusr n m m' isle ) . set ( e''' := natgthandplusl n' m' m isgt' ) . set ( e'''' := natlehlthtrans _ _ _ e'' e''' ) . rewrite e' in e'''' . destruct ( isirreflnatgth _ e'''' ) . apply ( invmaponpathsincl _ ( isinclnatplusr ( n + n') ) ) . rewrite ( pathsinv0 ( natplusassoc ( m - n ) n n' ) ) . rewrite ( natpluscomm n n' ) . rewrite ( pathsinv0 ( natplusassoc ( m' - n') n' n ) ) . rewrite ( minusplusnmm m n isle ) . rewrite ( minusplusnmm m' n' isle' ) . rewrite ( natpluscomm m' n ) . rewrite ( natpluscomm m n' ) . apply ( pathsinv0 e' ) . Defined . Definition hzabsval : hz -> nat := setquotuniv _ natset hzabsvalint hzabsvalintcomp . Lemma hzabsval0 : ( hzabsval 0 ) = 0%nat . Proof . apply idpath . Defined . Lemma hzabsvalgth0 { x : hz } ( is : hzgth x 0 ) : ( nattohz ( hzabsval x ) ) = x . Proof . revert x is. assert ( int : ∏ x : hz , isaprop ( hzgth x 0 -> ( nattohz ( hzabsval x ) ) = x ) ) . intro . apply impred . intro . apply ( setproperty hz ) . apply ( setquotunivprop _ ( λ x, make_hProp _ ( int x ) ) ) . intros xa g . simpl in xa . assert ( g' := natnattohzandgth _ _ g ) . simpl in g' . simpl . change (( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( hzabsvalint xa ) 0%nat ) ) = ( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) xa ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat . change ( pr1 ( natgth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in g' . rewrite ( natplusr0 _ ) in g' . change ((hzabsvalint xa + pr2 xa + 0)%nat = (pr1 xa + 0 + 0)%nat ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . unfold hzabsvalint . destruct ( natgthorleh (pr1 xa) (pr2 xa) ) as [ g'' | l ] . rewrite ( minusplusnmm _ _ ( natlthtoleh _ _ g'' ) ) . apply idpath . contradicts (natlehneggth l) g'. Defined . Opaque hzabsvalgth0 . Lemma hzabsvalgeh0 { x : hz } ( is : hzgeh x 0 ) : ( nattohz ( hzabsval x ) ) = x . Proof . intros . destruct ( hzgehchoice _ _ is ) as [ g | e ] . apply ( hzabsvalgth0 g ) . rewrite e . apply idpath . Defined . Lemma hzabsvallth0 { x : hz } ( is : hzlth x 0 ) : ( nattohz ( hzabsval x ) ) = ( - x ) . Proof . revert x is. assert ( int : ∏ x : hz , isaprop ( hzlth x 0 -> ( nattohz ( hzabsval x ) ) = ( - x ) ) ) . intro . apply impred . intro . apply ( setproperty hz ) . apply ( setquotunivprop _ ( λ x, make_hProp _ ( int x ) ) ) . intros xa l . simpl in xa . assert ( l' := natnattohzandlth _ _ l ) . simpl in l' . simpl . change (( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( hzabsvalint xa ) 0%nat ) ) = ( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( pr2 xa ) ( pr1 xa ) ) ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat . change ( pr1 ( natlth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in l' . rewrite ( natplusr0 _ ) in l' . change ((hzabsvalint xa + pr1 xa + 0)%nat = (pr2 xa + 0 + 0)%nat). rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . unfold hzabsvalint . destruct ( natgthorleh (pr1 xa) (pr2 xa) ) as [ g | l'' ] . destruct ( isasymmnatgth _ _ g l' ) . rewrite ( minusplusnmm _ _ l'' ) . apply idpath . Defined . Opaque hzabsvallth0 . Lemma hzabsvalleh0 { x : hz } ( is : hzleh x 0 ) : ( nattohz ( hzabsval x ) ) = ( - x ) . Proof . intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] . apply ( hzabsvallth0 l ) . rewrite e . apply idpath . Defined . Lemma hzabsvaleq0 { x : hz } ( e : ( hzabsval x ) = 0%nat ) : x = 0 . Proof . intros . destruct ( isdeceqhz x 0 ) as [ e0 | ne0 ] . apply e0 . destruct ( hzneqchoice _ _ ne0 ) as [ g | l ] . assert ( e' := hzabsvalgth0 g ) . rewrite e in e' . change ( 0 = x ) in e' . apply ( pathsinv0 e' ) . assert ( e' := hzabsvallth0 l ) . rewrite e in e' . change ( 0 = ( - x ) ) in e' . assert ( g := hzlth0andminus l ) . rewrite e' in g . destruct ( isirreflhzgth _ g ) . Defined . Definition hzabsvalneq0 { x : hz } ne := neg_to_negProp (nP := natneq _ _) (negf ( @hzabsvaleq0 x ) ne). Lemma hzabsvalandmult ( a b : hz ) : ( ( hzabsval a ) * ( hzabsval b ) )%nat = ( hzabsval ( a * b ) ) . Proof . intros . apply ( invmaponpathsincl _ isinclnattohz ) . rewrite ( nattohzandmult _ _ ) . destruct ( hzgthorleh a 0 ) as [ ga | lea ] . destruct ( hzgthorleh b 0 ) as [ gb | leb ] . rewrite ( hzabsvalgth0 ga ) . rewrite ( hzabsvalgth0 gb ) . rewrite ( hzabsvalgth0 ( hzmultgth0gth0 ga gb ) ) . apply idpath . rewrite ( hzabsvalgth0 ga ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalleh0 ( hzmultgth0leh0 ga leb ) ) . apply ( ringrmultminus hz ) . destruct ( hzgthorleh b 0 ) as [ gb | leb ] . rewrite ( hzabsvalgth0 gb ) . rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 ( hzmultleh0gth0 lea gb ) ) . apply ( ringlmultminus hz ) . rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalgeh0 ( hzmultleh0leh0 lea leb ) ) . apply (ringmultminusminus hz ) . Defined . (** *** Some common equalities on integers *) (** These lemmas are used for example in Complexes.v to construct complexes. *) Local Opaque hz isdecrelhzeq iscommringops. Lemma hzeqbooleqii (i : hz) : hzbooleq i i = true. Proof. unfold hzbooleq. unfold decreltobrel. induction (pr2 hzdeceq i i) as [T | F]. - apply idpath. - apply fromempty. apply F. apply idpath. Qed. Lemma hzbooleqisi (i : hz) : hzbooleq i (i + 1) = false. Proof. apply negrtopaths. apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i. confirm_not_equal isdecrelhzeq. Qed. Lemma hzbooleqisi' (i : hz) : hzbooleq i (i + 1) = false. Proof. (* prove it again, to illustrate how to avoid the tactic [confirm_not_equal] *) apply negrtopaths. apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i. simple refine (confirm_not_equal isdecrelhzeq _ _ _). reflexivity. Qed. Lemma hzbooleqissi (i : hz) : hzbooleq i (i + 1 + 1) = false. Proof. apply negrtopaths. rewrite hzplusassoc. apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i. confirm_not_equal isdecrelhzeq. Qed. Lemma hzeqeisi {i i0 : hz} (e : hzeq i i0) (e' : hzeq i (i0 + 1)) : empty. Proof. apply nopathstruetofalse. use (pathscomp0 _ (hzbooleqisi i0)). rewrite <- e'. rewrite <- e. apply (! (hzeqbooleqii i)). Qed. Lemma hzeqisi {i : hz} (e' : hzeq i (i + 1)) : empty. Proof. apply nopathstruetofalse. rewrite <- (hzbooleqisi i). rewrite <- e'. apply (! (hzeqbooleqii i)). Qed. Lemma hzeqissi {i : hz} (e : hzeq i (i + 1 + 1)) : empty. Proof. set (tmp := hzbooleqissi i). cbn in e. rewrite <- e in tmp. rewrite (hzeqbooleqii i) in tmp. apply nopathstruetofalse. apply tmp. Qed. Lemma hzeqeissi {i i0 : hz} (e : hzeq i i0) (e' : hzeq i (i0 + 1 + 1)) : empty. Proof. cbn in e. rewrite e in e'. apply (hzeqissi e'). Qed. Lemma hzeqsnmnsm {n m : hz} (e : hzeq (n + 1) m) (e' : hzeq n (m + 1)) : empty. Proof. cbn in e. rewrite <- e in e'. apply (hzeqissi e'). Qed. Lemma hzeqnmplusr {n m i : hz} (e : n = m) (e' : ¬ (n + i = m + i)) : empty. Proof. apply e'. exact (maponpaths_2 _ e _). Qed. Lemma hzeqnmplusr' {n m i : hz} (e : ¬ (n = m)) (e' : n + i = m + i) : empty. Proof. apply e. exact (hzplusrcan _ _ i e'). Qed. Lemma isdecrelhzeqi (i : hz) : isdecrelhzeq i i = ii1 (idpath _). Proof. induction (isdecrelhzeq i i) as [T | F]. - apply maponpaths. apply isasethz. - apply fromempty. apply F. apply idpath. Qed. Lemma isdecrelhzeqminusplus (i j : hz) : isdecrelhzeq i (i - j + j) = ii1 (hzrminusplus' i j). Proof. induction (isdecrelhzeq i (i - j + j)) as [T | F]. - apply maponpaths. apply isasethz. - apply fromempty. apply F. apply (hzrminusplus' i j). Qed. Lemma isdecrelhzeqminusplus' (i j : hz) : isdecrelhzeq (i - j + j) i = ii1 (hzrminusplus i j). Proof. induction (isdecrelhzeq (i - j + j) i) as [T | F]. - apply maponpaths. apply isasethz. - apply fromempty. apply F. apply (hzrminusplus i j). Qed. Lemma hzeqpii {i : hz} : i - 1 != i. Proof. apply (negf (λ e, hzpluslcan _ _ _ (e @ ! hzplusr0 i))); clear i. confirm_not_equal isdecrelhzeq. Qed. Lemma isdecrelhzeqpii (i : hz) : isdecrelhzeq (i - 1) i = ii2 (fun (e : hzeq (i - 1) i) => hzeqpii e). Proof. induction (isdecrelhzeq (i - 1) i) as [e | n]. - apply fromempty. apply (hzeqpii e). - apply maponpaths. apply funextfun. intros e. apply fromempty. apply n. apply e. Qed. Local Transparent hz isdecrelhzeq iscommringops. (** *** [hz] is an archimedean ring *) Local Open Scope hz_scope . Lemma isarchhz : isarchring (X := hz) hzgth. Proof. simple refine (isarchrigtoring _ _ _ _ _ _). - reflexivity. - intros n m. apply istransnatgth. - apply isarchrig_setquot_aux. + split. * apply natgthandpluslinv. * apply natgthandplusrinv. + apply isarchnat. Qed. Lemma isarchhz_one : ∏ x : hz, hzgth x 0 → ∃ n : nat, hzgth (nattohz n * x) 1. Proof. intros x Hx. generalize (isarchring_1 _ isarchhz x Hx). apply hinhfun. intros n. exists (pr1 n). rewrite <- nattorig_nattohz. exact (pr2 n). Qed. Lemma isarchhz_gt : ∏ x : hz, ∃ n : nat, hzgth (nattohz n) x. Proof. intros x. generalize (isarchring_2 _ isarchhz x). apply hinhfun. intros n. exists (pr1 n). rewrite <- nattorig_nattohz. exact (pr2 n). Qed. (** **** hz -> abgr, 1 ↦ x, n ↦ x + x + ... + x (n times), [hz_abmonoid_monoidfun] *) Definition nat_to_monoid_fun {X : monoid} (x : X) : natset -> X. Proof. intros n. induction n as [ | n IHn]. - exact (unel X). - exact (@op X x IHn). Defined. Lemma nat_to_monoid_fun_unel {X : monoid} (x : X) : nat_to_monoid_fun x O = (unel X). Proof. exact (idpath (unel X)). Defined. Lemma nat_to_monoid_fun_S {X : abmonoid} (x : X) (n : nat) : nat_to_monoid_fun x (S n) = (nat_to_monoid_fun x n * x)%multmonoid. Proof. induction n as [ | n IHn]. - exact (commax X x (unel X)). - cbn. rewrite (assocax X). use two_arg_paths. + use idpath. + exact (commax X x _). Qed. Lemma nat_to_abmonoid_fun_plus {X : monoid} (x : X) (n m : nat) : nat_to_monoid_fun x (n + m)%nat = @op X (nat_to_monoid_fun x n) (nat_to_monoid_fun x m). Proof. revert m. induction n as [ | n IHn]. - intros m. rewrite (lunax X). use idpath. - intros m. cbn. rewrite (assocax X). use two_arg_paths. + use idpath. + exact (IHn m). Qed. Definition nat_nat_to_monoid_fun {X : gr} (x : X) : natset × natset -> X. Proof. intros n. exact (@op X (nat_to_monoid_fun x (dirprod_pr1 n)) (nat_to_monoid_fun (grinv X x) (dirprod_pr2 n))). Defined. Lemma nat_to_monoid_unel' {X : abgr} (x : X) (n : nat) : ((nat_to_monoid_fun x n) * (nat_to_monoid_fun (grinv X x) n))%multmonoid = (unel X). Proof. induction n as [ | n IHn]. - use (runax X). - Opaque nat_to_monoid_fun. cbn in *. rewrite (@nat_to_monoid_fun_S X x). rewrite (@nat_to_monoid_fun_S X (grinv X x)). rewrite (commax X _ x). rewrite (assocax X). rewrite <- (assocax X (@nat_to_monoid_fun X x n)). use (pathscomp0 (maponpaths (λ xx : pr1 X, (x * (xx * (grinv X x))))%multmonoid IHn)). clear IHn. use (pathscomp0 _ (grrinvax X x)). use two_arg_paths. + use idpath. + use (lunax X). Qed. Transparent nat_to_monoid_fun. Lemma nat_nat_to_monoid1 {X : gr} (x : X) {n1 n2 m2 : nat} (e : n2 = m2) : nat_nat_to_monoid_fun x (make_dirprod n1 n2) = nat_nat_to_monoid_fun x (make_dirprod n1 m2). Proof. induction e. use idpath. Qed. Lemma nat_nat_to_monoid2 {X : gr} (x : X) {n1 m1 n2 : nat} (e : n1 = m1) : nat_nat_to_monoid_fun x (make_dirprod n1 n2) = nat_nat_to_monoid_fun x (make_dirprod m1 n2). Proof. induction e. use idpath. Qed. Definition nataddabmonoid_nataddabmonoid_to_monoid_fun {X : gr} (x : X) : abmonoiddirprod nataddabmonoid nataddabmonoid -> X := nat_nat_to_monoid_fun x. Opaque nat_to_monoid_fun. Lemma nat_nat_monoid_fun_isbinopfun {X : abgr} (x : X) : isbinopfun (nataddabmonoid_nataddabmonoid_to_monoid_fun x). Proof. use make_isbinopfun. intros n m. induction n as [n1 n2]. induction m as [m1 m2]. cbn. unfold nataddabmonoid_nataddabmonoid_to_monoid_fun. unfold nat_nat_to_monoid_fun. cbn. rewrite nat_to_abmonoid_fun_plus. rewrite nat_to_abmonoid_fun_plus. rewrite (assocax X). rewrite (assocax X). use two_arg_paths. - use idpath. - rewrite <- (assocax X). rewrite (commax X (nat_to_monoid_fun (grinv X x) n2) _). rewrite (assocax X). rewrite (assocax X). use two_arg_paths. + use idpath. + use (commax X). Qed. Transparent nat_to_monoid_fun. Lemma nat_nat_to_monoid_plus1 {X : abgr} (x : X) {n1 m1 m2: nat} (e : m2 = (m1 + n1)%nat) : nat_to_monoid_fun (grinv X x) n1 = (nat_to_monoid_fun x m1 * nat_to_monoid_fun (grinv X x) m2)%multmonoid. Proof. rewrite e. clear e. rewrite nat_to_abmonoid_fun_plus. rewrite <- (assocax X). use pathsinv0. use (pathscomp0 (maponpaths (λ xx : X, (xx * (nat_to_monoid_fun (grinv X x) n1))%multmonoid) (nat_to_monoid_unel' x m1))). use (lunax X). Qed. Lemma nat_nat_prod_abmonoid_fun_unel {X : abgr} (x : X) : (nataddabmonoid_nataddabmonoid_to_monoid_fun x) (unel (abmonoiddirprod nataddabmonoid nataddabmonoid)) = (unel X). Proof. use (pathscomp0 (lunax X _)). use idpath. Qed. Definition nat_nat_prod_abmonoid_monoidfun {X : abgr} (x : X) : monoidfun (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) X. Proof. use monoidfunconstr. - exact (nataddabmonoid_nataddabmonoid_to_monoid_fun x). - use make_ismonoidfun. + exact (nat_nat_monoid_fun_isbinopfun x). + exact (nat_nat_prod_abmonoid_fun_unel x). Defined. Lemma hz_abmonoid_ismonoidfun : @ismonoidfun (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) hzaddabgr (@setquotpr (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) (binopeqrelabgrdiff (rigaddabmonoid natcommrig))). Proof. use make_ismonoidfun. - use make_isbinopfun. intros x x'. use idpath. - use idpath. Qed. Definition hz_abmonoid_monoidfun : monoidfun (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) hzaddabgr. Proof. use monoidfunconstr. - use setquotpr. - exact hz_abmonoid_ismonoidfun. Defined. Definition nat_nat_fun_unel {X : abgr} (x : X) (n : nat) : nat_nat_to_monoid_fun x (make_dirprod n n) = unel X. Proof. exact (nat_to_monoid_unel' x n). Qed. Opaque nat_to_monoid_fun. Definition nat_nat_fun_ind {X : abgr} (x : X) (n m : nat) : nat_nat_to_monoid_fun x (make_dirprod (n + m)%nat m) = nat_nat_to_monoid_fun x (make_dirprod n O). Proof. use (pathscomp0 (nat_nat_monoid_fun_isbinopfun x (make_dirprod n O) (make_dirprod m m))). unfold nataddabmonoid_nataddabmonoid_to_monoid_fun. rewrite (nat_nat_fun_unel x m). rewrite (runax X). use idpath. Qed. Transparent nat_to_monoid_fun. Opaque nat_to_monoid_fun. Definition nat_nat_fun_ind2 {X : abgr} (x : X) (n1 n2 m k : nat) : nat_nat_to_monoid_fun x (make_dirprod n1 m) = nat_nat_to_monoid_fun x (make_dirprod n2 k) -> nat_nat_to_monoid_fun x (make_dirprod n1 (S m)) = nat_nat_to_monoid_fun x (make_dirprod n2 (S k)). Proof. intros H. unfold nat_nat_to_monoid_fun in *. cbn in *. rewrite (@nat_to_monoid_fun_S X (grinv X x)). rewrite (@nat_to_monoid_fun_S X (grinv X x)). rewrite <- (assocax X). rewrite <- (assocax X). use two_arg_paths. - exact H. - use idpath. Qed. Transparent nat_to_monoid_fun. Opaque nat_to_monoid_fun. Definition abgr_precategory_integer_fun_iscomprelfun {X : abgr} (x : X) : iscomprelfun (binopeqrelabgrdiff (rigaddabmonoid natcommrig)) (nat_nat_prod_abmonoid_monoidfun x). Proof. intros x1. induction x1 as [x1 e1]. unfold nat_nat_prod_abmonoid_monoidfun. cbn. unfold nataddabmonoid_nataddabmonoid_to_monoid_fun. unfold nat_nat_to_monoid_fun. cbn. induction x1 as [ | x1 IHx1]. - intros x2 H. use (squash_to_prop H (setproperty X _ _)). intros H'. cbn in H'. induction H' as [H1 H2]. clear H. induction x2 as [x2 e2]. apply natplusrcan in H2. rewrite nat_to_monoid_fun_unel. rewrite (lunax X). cbn. cbn in H2. exact (nat_nat_to_monoid_plus1 x H2). - intros x2 H. use (squash_to_prop H (setproperty X _ _)). intros H'. cbn in H'. induction H' as [H1 H2]. clear H. induction x2 as [x2 e2]. cbn in H2. cbn. use (pathscomp0 (maponpaths (λ xx : X, (xx * (nat_to_monoid_fun (grinv X x) e1))%multmonoid) (@nat_to_monoid_fun_S X x x1))). rewrite (commax X _ x). rewrite (assocax X). cbn. assert (HH : ishinh_UU(∑ x0 : nat, (x1 + (S e2) + x0)%nat = (x2 + e1 + x0)%nat)). { use hinhpr. use tpair. - exact O. - cbn. rewrite natplusr0. rewrite natplusr0. cbn. rewrite natplusassoc in H2. rewrite plus_n_Sm in H2. rewrite plus_n_Sm in H2. rewrite natplusnsm in H2. rewrite <- natplusassoc in H2. apply natplusrcan in H2. exact H2. } set (tmp := IHx1 (make_dirprod x2 (S e2)) HH). cbn in tmp. use (pathscomp0 (maponpaths (λ xx : X, (x * xx)%multmonoid) tmp)). clear tmp. clear HH. clear H2. clear IHx1. rewrite (commax X x). rewrite (assocax X). use two_arg_paths. + use idpath. + use (pathscomp0 (maponpaths (λ xx : X, (xx * x)%multmonoid) (@nat_to_monoid_fun_S X (grinv X x) e2))). rewrite (assocax X). rewrite (grlinvax X x). use (runax X). Qed. Transparent nat_to_monoid_fun. (** Construction of tha map \mathbb{Z} --> A, 1 ↦ x *) Definition hz_abgr_fun {X : abgr} (x : X) : hzaddabgr -> X. Proof. use setquotuniv. - exact (nat_nat_prod_abmonoid_monoidfun x). - exact (abgr_precategory_integer_fun_iscomprelfun x). Defined. (** Hide ismonoidfun behind Qed. *) Definition hz_abgr_fun_ismonoidfun {X : abgr} (x : X) : ismonoidfun (hz_abgr_fun x). Proof. use make_ismonoidfun. - use isbinopfun_twooutof3b. + use (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)). + use (hz_abmonoid_monoidfun). + use issurjsetquotpr. + use binopfunisbinopfun. + use binopfunisbinopfun. - use (runax X). Qed. (** Construction of the monoidfun \mathbb{Z} --> A, 1 ↦ x *) Definition hz_abgr_fun_monoidfun {X : abgr} (x : X) : monoidfun hzaddabgr X. Proof. use monoidfunconstr. - exact (hz_abgr_fun x). - exact (hz_abgr_fun_ismonoidfun x). Defined. (** Commutativity of the following diagram nat × nat --- nat_nat_prod_abmonoid_monoidfun ---> X hz_abgr_fun_monoidfun | || hz -------- hz_abmonoid_monoidfun -------------> X *) Lemma abgr_natnat_hz_X_comm {X : abgr} (x : X) : monoidfuncomp hz_abmonoid_monoidfun (hz_abgr_fun_monoidfun x) = nat_nat_prod_abmonoid_monoidfun x. Proof. use monoidfun_paths. use funextfun. intros n. use setquotunivcomm. Qed. Opaque nat_to_monoid_fun. Lemma monoidfun_nat_to_monoid_fun {X Y : abgr} (f : monoidfun X Y) (x : X) (n : nat) : pr1 f (nat_to_monoid_fun x n) = nat_to_monoid_fun (f x) n. Proof. induction n as [ | n IHn]. - use monoidfununel. - use (pathscomp0 (maponpaths (pr1 f) (@nat_to_monoid_fun_S X x n))). use (pathscomp0 (binopfunisbinopfun f _ _)). use (pathscomp0 _ (! (@nat_to_monoid_fun_S Y (f x) n))). use two_arg_paths. + exact IHn. + use idpath. Qed. Transparent nat_to_monoid_fun. (** Some more facts about integers added by D. Grayson *) Definition ℤ := hzaddabgr. Definition toℤ (n:nat) : ℤ := nattohz n. Definition toℤneg (n:nat) : ℤ := natnattohz O n. Definition zero := toℤ 0. Definition one := toℤ 1. Definition hzabsvalnat n : hzabsval (natnattohz n 0) = n. (* move to hz.v *) Proof. intros. unfold hzabsval. unfold setquotuniv. simpl. unfold hzabsvalint. simpl. destruct (natgthorleh n 0). { apply natminuseqn. } { exact (! (natleh0tois0 h)). } Defined. Lemma hzsign_natnattohz m n : - natnattohz m n = natnattohz n m. (* move to hz.v *) Proof. reflexivity. (* don't change the proof *) Defined. Lemma hzsign_nattohz m : - nattohz m = natnattohz 0 m. (* move to hz.v *) Proof. reflexivity. (* don't change the proof *) Defined. Lemma hzsign_hzsign (i:hz) : - - i = i. Proof. apply (grinvinv ℤ). Defined. Definition hz_normal_form (i:ℤ) := coprod (∑ n, natnattohz n 0 = i) (∑ n, natnattohz 0 (S n) = i). Definition hznf_pos n := _,, inl (n,,idpath _) : total2 hz_normal_form. Definition hznf_neg n := _,, inr (n,,idpath _) : total2 hz_normal_form. Definition hznf_zero := hznf_pos 0. Definition hznf_neg_one := hznf_neg 0. Definition hz_to_normal_form (i:ℤ) : hz_normal_form i. Proof. intros. destruct (hzlthorgeh i 0) as [r|s]. { apply inr. assert (a := hzabsvallth0 r). assert (b := hzlthtoneq _ _ r). assert (c := hzabsvalneq0 b). assert (d := natneq0togth0 _ c). assert (f := natgthtogehsn _ _ d). assert (g := minusplusnmm _ _ f). rewrite natpluscomm in g. simpl in g. exists (hzabsval i - 1)%nat. rewrite g. apply hzinvmaponpathsminus. exact a. } { apply inl. exists (hzabsval i). exact (hzabsvalgeh0 s). } Defined. Lemma nattohz_inj {m n} : nattohz m = nattohz n -> m = n. Proof. revert m n; exact (invmaponpathsincl _ isinclnattohz). Defined. Lemma hzdichot {m n} : neg (nattohz m = - nattohz (S n)). Proof. intros. intro e. assert (d := maponpaths hzsign e); clear e. rewrite hzsign_hzsign in d. assert( f := maponpaths (λ i, nattohz m + i) d); simpl in f; clear d. change (nattohz m + - nattohz m) with (nattohz m - nattohz m) in f. rewrite hzrminus in f. change (0 = nattohz (m + S n)) in f. assert (g := nattohz_inj f); clear f. rewrite natpluscomm in g. exact (negpaths0sx _ g). Defined. Definition negpos' : isweq (@pr1 _ hz_normal_form). Proof. apply isweqpr1; intro i. exists (hz_to_normal_form i). generalize (hz_to_normal_form i) as s. intros [[m p]|[m p]] [[n q]|[n q]]. { apply (maponpaths (@ii1 (∑ n, natnattohz n 0 = i) (∑ n, natnattohz 0 (S n) = i))). apply (proofirrelevance _ (isinclnattohz i)). } { apply fromempty. assert (r := p@!q); clear p q. apply (hzdichot r). } { apply fromempty. assert (r := q@!p); clear p q. apply (hzdichot r). } { apply (maponpaths (@ii2 (∑ n, natnattohz n 0 = i) (∑ n, natnattohz 0 (S n) = i))). assert (p' := maponpaths hzsign p). assert (q' := maponpaths hzsign q). change (- natnattohz O (S m)) with (nattohz (S m)) in p'. change (- natnattohz O (S n)) with (nattohz (S n)) in q'. assert (c := proofirrelevance _ (isinclnattohz (-i)) (S m,,p') (S n,,q')). assert (d := maponpaths pr1 c); simpl in d. assert (e := invmaponpathsS _ _ d); clear d. apply subtypePath. - intro; apply setproperty. - exact (!e). } Defined. Definition negpos_weq := make_weq _ negpos' : weq (total2 hz_normal_form) ℤ. Definition negpos : weq (coprod nat nat) ℤ. (* ℤ = (-inf,-1) + (0,inf) *) Proof. simple refine (make_weq _ (isweq_iso _ _ _ _)). { intros [n'|n]. { exact (natnattohz 0 (S n')). } { exact (natnattohz n 0). } } { intro i. destruct (hz_to_normal_form i) as [[n p]|[m q]]. { exact (inr n). } { exact (inl m). } } { intros [n'|n]. { simpl. rewrite natminuseqn. reflexivity. } { simpl. rewrite hzabsvalnat. reflexivity. } } { simpl. intro i. destruct (hz_to_normal_form i) as [[n p]|[m q]]. { exact p. } { exact q. } } Defined. Lemma hzminusplus (x y:hz) : -(x+y) = (-x) + (-y). (* move to hz.v *) Proof. intros. apply (hzplusrcan _ _ (x+y)). rewrite hzlminus. rewrite (hzpluscomm (-x)). rewrite (hzplusassoc (-y)). rewrite <- (hzplusassoc (-x)). rewrite hzlminus. rewrite hzplusl0. rewrite hzlminus. reflexivity. Defined. Definition loop_power {Y} {y:Y} (l:y = y) (n:ℤ) : y = y. Proof. intros. assert (m := loop_power_nat l (hzabsval n)). destruct (hzlthorgeh n 0%hz). { exact (!m). } { exact m. } Defined. UniMath-20231010/UniMath/NumberSystems/NaturalNumbersAlgebra.v000066400000000000000000000210751451125700300241100ustar00rootroot00000000000000(** * Facts about the natural numbers that depend on definitions from algebra *) Require Export UniMath.Foundations.NaturalNumbers. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.NegativePropositions. Require Export UniMath.Algebra.Archimedean. Require Export UniMath.Algebra.Domains_and_Fields. Require Export UniMath.Algebra.IteratedBinaryOperations. Definition nataddabmonoid : abmonoid := make_abmonoid (make_setwithbinop natset (λ n m : nat, n + m)) (make_dirprod (make_dirprod natplusassoc (@make_isunital natset _ 0 (make_dirprod natplusl0 natplusr0))) natpluscomm). Definition natmultabmonoid : abmonoid := make_abmonoid (make_setwithbinop natset (λ n m : nat, n * m)) (make_dirprod (make_dirprod natmultassoc (@make_isunital natset _ 1 (make_dirprod natmultl1 natmultr1))) natmultcomm). (** *** Submonoid of non-zero elements in [nat] *) Local Open Scope nat_scope. Definition natnonzero : @subabmonoid natmultabmonoid. Proof. split with (λ a : natset, a ≠ 0). unfold issubmonoid. split. - unfold issubsetwithbinop. intros a a'. apply (natneq0andmult _ _ (pr2 a) (pr2 a')). - apply (ct (natneq, isdecrel_natneq, 1, 0)). Defined. Lemma natnonzerocomm (a b : natnonzero) : (@op natnonzero a b) = (@op natnonzero b a). Proof. intros. apply (invmaponpathsincl _ (isinclpr1carrier _) (@op natnonzero a b) (@op natnonzero b a)). simpl. apply natmultcomm. Defined. Theorem nat_plus_commutativity : isCommutative_fun_mon nataddabmonoid. Proof. intros ? ? ?. apply weqtoeqstn. intermediate_weq (∑ i, stn (x i)). - intermediate_weq (∑ i, stn (x(f i))). + apply invweq. rewrite iterop_fun_nat. apply weqstnsum1. + apply (weqfp _ (stn∘x)). - rewrite iterop_fun_nat. apply weqstnsum1. Defined. Arguments nat_plus_commutativity {_} _ _. Definition finsum {X} (fin : isfinite X) (f : X -> nat) : nat. Proof. intros. unfold isfinite,finstruct,nelstruct in fin. simple refine (squash_to_set isasetnat (λ (x : ∑ n, stn n ≃ X), iterop_fun_mon (M := nataddabmonoid) (f ∘ pr2 x)) _ fin). intros. induction x as [n x]. induction x' as [n' x']. assert (p := weqtoeqstn (invweq x' ∘ x)%weq). induction p. assert (w := nat_plus_commutativity (f ∘ x') (invweq x' ∘ x)%weq). simple refine (_ @ w). unfold iterop_fun_mon. apply maponpaths. rewrite weqcomp_to_funcomp. apply funextfun; intro i. simpl. apply maponpaths. exact (! homotweqinvweq x' (x i)). Defined. (** *** [nat] as a commutative rig *) Definition natcommrig : commrig. Proof. split with (make_setwith2binop natset (make_dirprod (λ n m : nat, n + m) (λ n m : nat, n * m))). split. - split. + split with (make_dirprod (make_dirprod (make_dirprod natplusassoc (@make_isunital natset _ 0 (make_dirprod natplusl0 natplusr0))) natpluscomm) (make_dirprod natmultassoc (@make_isunital natset _ 1 (make_dirprod natmultl1 natmultr1)))). apply (make_dirprod natmult0n natmultn0). + apply (make_dirprod natldistr natrdistr). - unfold iscomm. apply natmultcomm. Defined. Lemma nattorig_nat : ∏ n : nat, nattorig (X := natcommrig) n = n. Proof. induction n as [|n IHn]. reflexivity. rewrite nattorigS, IHn. reflexivity. Qed. (** *** Properties of comparisons in the terminology of algebra1.v *) Local Open Scope rig_scope. (** [natgth] *) Lemma isplushrelnatgth : @isbinophrel nataddabmonoid natgth. Proof. split. apply natgthandplusl. apply natgthandplusr. Defined. Lemma isinvplushrelnatgth : @isinvbinophrel nataddabmonoid natgth. Proof. split. apply natgthandpluslinv. apply natgthandplusrinv. Defined. Lemma isinvmulthrelnatgth : @isinvbinophrel natmultabmonoid natgth. Proof. split. - intros a b c r. apply (natlthandmultlinv _ _ _ r). - intros a b c r. apply (natlthandmultrinv _ _ _ r). Defined. Lemma isrigmultgtnatgth : isrigmultgt natcommrig natgth. Proof. intros a. induction a as [|a IHa]. - intros ? ? ? rab rcd. contradicts rab (negnatgth0n b). - intros ? ? ? rab rcd. induction b as [|b IHb]. + simpl. rewrite 2 natplusr0. apply natlthandmultl. * exact tt. * exact rcd. + simpl. set (rer := abmonoidrer nataddabmonoid). unfold op1, op2; simpl. rewrite (rer _ _ _ d). rewrite (rer _ _ _ c). unfold op1, op2; simpl. rewrite (natpluscomm c d). apply (natlthandplusr (a * d + b * c) (a * c + b * d) (d + c)). apply (IHa _ _ _ rab rcd). Defined. Lemma isinvrigmultgtnatgth : isinvrigmultgt natcommrig natgth. Proof. set (rer := abmonoidrer nataddabmonoid). simpl in rer. apply isinvrigmultgtif. intros a b c d. generalize a b c. clear a b c. induction d as [ | d IHd ]. - intros a b c g gab. change (pr1 ((a * c + b * 0) > (a * 0 + b * c))) in g. destruct c as [ | c ]. + rewrite (natmultn0 _) in g. destruct (isirreflnatgth _ g). + apply natgthsn0. - intros a b c g gab. destruct c as [ | c ]. + change (pr1 ((a * 0 + b * S d) > (a * S d + b * 0))) in g. rewrite (natmultn0 _) in g. rewrite (natmultn0 _) in g. rewrite (natplusl0 _) in g. rewrite (natplusr0 _) in g. set (g' := natgthandmultrinv _ _ _ g). destruct (isasymmnatgth _ _ gab g'). + change (pr1 (natgth (a * S c + b * S d) (a * S d + b * S c))) in g. rewrite (multnsm _ _) in g. rewrite (multnsm _ _) in g. rewrite (multnsm _ _) in g. rewrite (multnsm _ _) in g. rewrite (rer _ (a * c) _ _) in g. rewrite (rer _ (a * d) _ _) in g. set (g' := natgthandpluslinv _ _ (a + b) g). apply (IHd a b c g' gab). Defined. (** [natlth] *) Lemma isplushrelnatlth : @isbinophrel nataddabmonoid natlth. Proof. split. - intros a b c. apply (natgthandplusl b a c). - intros a b c. apply (natgthandplusr b a c). Defined. Lemma isinvplushrelnatlth : @isinvbinophrel nataddabmonoid natlth. Proof. split. - intros a b c. apply (natgthandpluslinv b a c). - intros a b c. apply (natgthandplusrinv b a c). Defined. Lemma isinvmulthrelnatlth : @isinvbinophrel natmultabmonoid natlth. Proof. split. - intros a b c r. apply (natlthandmultlinv _ _ _ r). - intros a b c r. apply (natlthandmultrinv _ _ _ r). Defined. (** [natleh] *) Lemma isplushrelnatleh : @isbinophrel nataddabmonoid natleh. Proof. split. apply natlehandplusl. apply natlehandplusr. Defined. Lemma isinvplushrelnatleh : @isinvbinophrel nataddabmonoid natleh. Proof. split. apply natlehandpluslinv. apply natlehandplusrinv. Defined. Lemma ispartinvmulthrelnatleh : @ispartinvbinophrel natmultabmonoid (λ x, x ≠ 0) natleh. Proof. split. - intros a b c s r. apply (natlehandmultlinv _ _ _ s r). - intros a b c s r. apply (natlehandmultrinv _ _ _ s r). Defined. (** [natgeh] *) Lemma isplushrelnatgeh : @isbinophrel nataddabmonoid natgeh. Proof. split. - intros a b c. apply (natlehandplusl b a c). - intros a b c. apply (natlehandplusr b a c). Defined. Lemma isinvplushrelnatgeh : @isinvbinophrel nataddabmonoid natgeh. Proof. split. - intros a b c. apply (natlehandpluslinv b a c). - intros a b c. apply (natlehandplusrinv b a c). Defined. Lemma ispartinvmulthrelnatgeh : @ispartinvbinophrel natmultabmonoid (λ x, x ≠ 0) natgeh. Proof. split. - intros a b c s r. apply (natlehandmultlinv _ _ _ s r). - intros a b c s r. apply (natlehandmultrinv _ _ _ s r). Defined. (** *** [nat] is an archimedean rig *) Lemma isarchnat_diff : ∏ (y1 y2 : nat), y1 > y2 → ∃ n : nat, n * y1 > 1 + n * y2. Proof. intros y1 y2 Hy. apply natlthchoice2 in Hy. induction Hy as [Hy | <-]. - apply hinhpr. exists 1%nat. exact Hy. - apply hinhpr. exists 2%nat. rewrite !multsnm ; simpl. rewrite natplusr0. apply natgthandplusl, natgthsnn. Defined. Lemma isarchnat_gth : ∏ x : nat, ∃ n : nat, n > x. Proof. intros n. apply hinhpr. exists (S n). now apply natgthsnn. Defined. Lemma isarchnat_pos : ∏ x : nat, ∃ n : nat, n + x > 0. Proof. intros n. apply hinhpr. now exists 1%nat. Defined. Lemma isarchnat : isarchrig (X := natcommrig) natgth. Proof. repeat split. - intros y1 y2 Hy. generalize (isarchnat_diff y1 y2 Hy). apply hinhfun. intros n. exists (pr1 n). rewrite nattorig_nat. exact (pr2 n). - intros n. generalize (isarchnat_gth n). apply hinhfun. intros n'. exists (pr1 n'). rewrite nattorig_nat. exact (pr2 n'). - intros n. generalize (isarchnat_pos n). apply hinhfun. intros n'. exists (pr1 n'). rewrite nattorig_nat. exact (pr2 n'). Defined. UniMath-20231010/UniMath/NumberSystems/NaturalNumbers_le_Inductive.v000066400000000000000000000113441451125700300253220ustar00rootroot00000000000000(** * Natural numbers and their properties. Vladimir Voevodsky. Apr. - Sep. 2011 This file contains the formulations and proofs of general properties of natural numbers from the univalent perspecive. *) (** ** Contents - Inductive types [le] with values in [UU] - A generalization of [le] and its properties - Inductive types [le] with values in [UU] are in [hProp] - Comparison between [le] with values in [UU] and [natleh] *) (** ** Preamble *) (** Settings *) (** Imports. *) Require Export UniMath.Foundations.NaturalNumbers. (** ** Inductive types [le] with values in [UU]. This part is included for illustration purposes only. In practice it is easier to work with [natleh] than with [le]. *) (** *** A generalization of [le] and its properties. *) Inductive leF {T : UU} (F : T -> T) (t : T) : T -> UU := | leF_O : leF F t t | leF_S : ∏ t' : T, leF F t t' -> leF F t (F t'). Lemma leFiter {T : UU} (F : T -> T) (t : T) (n : nat) : leF F t (iteration F n t). Proof. intros. induction n as [ | n IHn ]. - apply leF_O. - simpl. apply leF_S. assumption. Defined. Lemma leFtototal2withnat {T : UU} (F : T -> T) (t t' : T) (a : leF F t t') : total2 (λ n : nat, (iteration F n t) = t'). Proof. intros. induction a as [ | b H0 IH0 ]. - split with O. apply idpath. - split with (S (pr1 IH0)). simpl. apply (@maponpaths _ _ F (iteration F (pr1 IH0) t) b). apply (pr2 IH0). Defined. Lemma total2withnattoleF {T : UU} (F : T -> T) (t t' : T) (a : total2 (λ n : nat, (iteration F n t) = t')) : leF F t t'. Proof. intros. destruct a as [ n e ]. destruct e. apply leFiter. Defined. Lemma leFtototal2withnat_l0 {T : UU} (F : T -> T) (t : T) (n : nat) : (leFtototal2withnat F t _ (leFiter F t n)) = (tpair _ n (idpath (iteration F n t))). Proof. intros. induction n as [ | n IHn ]. - apply idpath. - simpl. set (h := fun ne : total2 (λ n0 : nat, paths (iteration F n0 t) (iteration F n t)) => tpair (λ n0 : nat, paths (iteration F n0 t) (iteration F (S n) t)) (S (pr1 ne)) (maponpaths F (pr2 ne))). apply (@maponpaths _ _ h _ _ IHn). Defined. Lemma isweqleFtototal2withnat {T : UU} (F : T -> T) (t t' : T) : isweq (leFtototal2withnat F t t'). Proof. intros. set (f := leFtototal2withnat F t t'). set (g := total2withnattoleF F t t'). assert (egf : ∏ x : _, paths (g (f x)) x). { intro x. induction x as [ | y H0 IHH0 ]. - apply idpath. - simpl. simpl in IHH0. destruct (leFtototal2withnat F t y H0) as [ m e ]. destruct e. simpl. simpl in IHH0. apply (@maponpaths _ _ (leF_S F t (iteration F m t)) _ _ IHH0). } assert (efg : ∏ x : _, paths (f (g x)) x). { intro x. destruct x as [ n e ]. destruct e. simpl. apply leFtototal2withnat_l0. } apply (isweq_iso _ _ egf efg). Defined. Definition weqleFtototalwithnat { T : UU } (F : T -> T) (t t' : T) : weq (leF F t t') (total2 (λ n : nat, (iteration F n t) = t')) := make_weq _ (isweqleFtototal2withnat F t t'). (** *** Inductive types [le] with values in [UU] are in [hProp] *) Definition le (n : nat) : nat -> UU := leF S n. Definition le_n : ∏ t : nat, leF S t t := leF_O S. Definition le_S : ∏ t t' : nat, leF S t t' → leF S t (S t') := leF_S S. Theorem isaprople (n m : nat) : isaprop (le n m). Proof. intros. apply (isofhlevelweqb 1 (weqleFtototalwithnat S n m)). apply invproofirrelevance. intros x x'. set (i := @pr1 _ (λ n0 : nat, (iteration S n0 n) = m)). assert (is : isincl i) by apply (isinclpr1 _ (λ n0 : nat, isasetnat (iteration S n0 n) m)). apply (invmaponpathsincl _ is). destruct x as [ n1 e1 ]. destruct x' as [ n2 e2 ]. simpl. set (int1 := pathsinv0 (pathsitertoplus n1 n)). set (int2 := pathsinv0 (pathsitertoplus n2 n)). set (ee1 := pathscomp0 int1 e1). set (ee2 := pathscomp0 int2 e2). set (e := pathscomp0 ee1 (pathsinv0 ee2)). apply (invmaponpathsincl _ (isinclnatplusr n) n1 n2 e). Defined. (** *** Comparison between [le] with values in [UU] and [natleh]. *) Lemma letoleh (n m : nat) : le n m -> n ≤ m. Proof. intros H. induction H as [ | m H0 IHH0 ]. - apply isreflnatleh. - apply natlehtolehs. assumption. Defined. Lemma natlehtole (n m : nat) : n ≤ m -> le n m. Proof. intros H. induction m as [|m IHm]. - assert (int := natleh0tois0 H). clear H. destruct int. apply le_n. - set (int2 := natlehchoice2 n (S m) H). destruct int2 as [ isnatleh | iseq ]. apply (le_S n m (IHm isnatleh)). destruct iseq. apply le_n. Defined. Lemma isweqletoleh (n m : nat) : isweq (letoleh n m). Proof. intros. set (is1 := isaprople n m). set (is2 := pr2 (n ≤ m)). apply (isweqimplimpl (letoleh n m) (natlehtole n m) is1 is2). Defined. Definition weqletoleh (n m : nat) : le n m ≃ n ≤ m := make_weq _ (isweqletoleh n m). UniMath-20231010/UniMath/NumberSystems/RationalNumbers.v000066400000000000000000000716371451125700300230060ustar00rootroot00000000000000(** * Generalities on the type of rationals and rational arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011. In this file we introduce the type [ hq ] of rationals defined as the quotient set of [ dirprod nat nat ] by the standard equivalence relation and develop the main notions of the rational arithmetic using this definition . *) (** ** Preamble *) (** Settings *) Unset Kernel Term Sharing. (** Imports *) Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Export UniMath.NumberSystems.Integers . Opaque hz . (** ** The commutative ring [ hq ] of integres *) (** *** General definitions *) Definition hq : fld := fldfrac hzintdom isdeceqhz . Definition hqaddabgr : abgr := hq . Definition hqmultabmonoid : abmonoid := ringmultabmonoid hq . Definition hqtype : UU := hq . Definition hzhztohq : hz -> ( intdomnonzerosubmonoid hzintdom ) -> hq := λ x a, setquotpr _ ( make_dirprod x a ) . Definition hqplus : hq -> hq -> hq := @op1 hq. Definition hqsign : hq -> hq := grinv hqaddabgr . Definition hqminus : hq -> hq -> hq := λ x y, hqplus x ( hqsign y ) . Definition hqzero : hq := unel hqaddabgr . Definition hqmult : hq -> hq -> hq := @op2 hq . Definition hqone : hq := unel hqmultabmonoid . Declare Scope hq_scope. Bind Scope hq_scope with hq . Notation " x + y " := ( hqplus x y ) : hq_scope . Notation " 0 " := hqzero : hq_scope . Notation " 1 " := hqone : hq_scope . Notation " - x " := ( hqsign x ) : hq_scope . Notation " x - y " := ( hqminus x y ) : hq_scope . Notation " x * y " := ( hqmult x y ) : hq_scope . Delimit Scope hq_scope with hq . (** *** Properties of equality on [ hq ] *) Definition isdeceqhq : isdeceq hq := isdeceqfldfrac hzintdom isdeceqhz . Definition isasethq := setproperty hq . Definition hqeq ( x y : hq ) : hProp := make_hProp ( x = y ) ( isasethq _ _ ) . Definition isdecrelhqeq : isdecrel hqeq := λ a b, isdeceqhq a b . Definition hqdeceq : decrel hq := make_decrel isdecrelhqeq . (* Canonical Structure hqdeceq. *) Definition hqbooleq := decreltobrel hqdeceq . Definition hqneq ( x y : hq ) : hProp := make_hProp ( neg ( x = y ) ) ( isapropneg _ ) . Definition isdecrelhqneq : isdecrel hqneq := isdecnegrel _ isdecrelhqeq . Definition hqdecneq : decrel hq := make_decrel isdecrelhqneq . (* Canonical Structure hqdecneq. *) Definition hqboolneq := decreltobrel hqdecneq . Local Open Scope hz_scope . (** *** Properties of addition and subtraction on [ hq ] *) Local Open Scope hq_scope . Lemma hqplusr0 ( x : hq ) : paths ( x + 0 ) x . Proof . apply ( ringrunax1 _ x ) . Defined . Lemma hqplusl0 ( x : hq ) : paths ( 0 + x ) x . Proof . apply ( ringlunax1 _ x ) . Defined . Lemma hqplusassoc ( x y z : hq ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) . Proof . intros . apply ( ringassoc1 hq x y z ) . Defined . Lemma hqpluscomm ( x y : hq ) : paths ( x + y ) ( y + x ) . Proof . intros . apply ( ringcomm1 hq x y ) . Defined . Lemma hqlminus ( x : hq ) : paths ( -x + x ) 0 . Proof . apply ( ringlinvax1 hq x ) . Defined . Lemma hqrminus ( x : hq ) : paths ( x - x ) 0 . Proof . apply ( ringrinvax1 hq x ) . Defined . Lemma isinclhqplusr ( n : hq ) : isincl ( λ m : hq, m + n ) . Proof. apply ( pr2 ( weqtoincl ( weqrmultingr hqaddabgr n ) ) ) . Defined. Lemma isinclhqplusl ( n : hq ) : isincl ( λ m : hq, n + m ) . Proof. intro. apply ( pr2 ( weqtoincl ( weqlmultingr hqaddabgr n ) ) ) . Defined . Lemma hqpluslcan ( a b c : hq ) ( is : paths ( c + a ) ( c + b ) ) : a = b . Proof . intros . apply ( @grlcan hqaddabgr a b c is ) . Defined . Lemma hqplusrcan ( a b c : hq ) ( is : paths ( a + c ) ( b + c ) ) : a = b . Proof . intros . apply ( @grrcan hqaddabgr a b c is ) . Defined . Definition hqinvmaponpathsminus { a b : hq } ( e : paths ( - a ) ( - b ) ) : a = b := grinvmaponpathsinv hqaddabgr e . (** *** Properties of multiplication on [ hq ] *) Lemma hqmultr1 ( x : hq ) : paths ( x * 1 ) x . Proof . apply ( ringrunax2 _ x ) . Defined . Lemma hqmultl1 ( x : hq ) : paths ( 1 * x ) x . Proof . apply ( ringlunax2 _ x ) . Defined . Lemma hqmult0x ( x : hq ) : paths ( 0 * x ) 0 . Proof . apply ( ringmult0x _ x ) . Defined . Lemma hqmultx0 ( x : hq ) : paths ( x * 0 ) 0 . Proof . apply ( ringmultx0 _ x ) . Defined . Lemma hqmultassoc ( x y z : hq ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) . Proof . intros . apply ( ringassoc2 hq x y z ) . Defined . Lemma hqmultcomm ( x y : hq ) : paths ( x * y ) ( y * x ) . Proof . intros . apply ( ringcomm2 hq x y ) . Defined . (** *** Multiplicative inverse and division on [ hq ] Note : in our definition it is possible to divide by 0 . The result in this case is 0 . *) Definition hqmultinv : hq -> hq := λ x, fldfracmultinv0 hzintdom isdeceqhz x . Lemma hqislinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths ( ( hqmultinv x ) * x ) 1 . Proof. intros . apply ( islinvinfldfrac hzintdom isdeceqhz x ne ) . Defined . Lemma hqisrinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths ( x * ( hqmultinv x ) ) 1 . Proof. intros . apply ( isrinvinfldfrac hzintdom isdeceqhz x ne ) . Defined . Definition hqdiv ( x y : hq ) : hq := hqmult x ( hqmultinv y ) . (** ** Definition and properties of "greater", "less", "greater or equal" and "less or equal" on [ hq ] . *) (** *** Definitions and notations *) Definition hqgth : hrel hq := fldfracgt hzintdom isdeceqhz isplushrelhzgth isringmulthzgth ( ct ( hzgth , isdecrelhzgth, 1%hz , 0%hz ) ) hzneqchoice . Definition hqlth : hrel hq := λ a b, hqgth b a . Definition hqleh : hrel hq := λ a b, make_hProp ( neg ( hqgth a b ) ) ( isapropneg _ ) . Definition hqgeh : hrel hq := λ a b, make_hProp ( neg ( hqgth b a ) ) ( isapropneg _ ) . (** *** Decidability *) Lemma isdecrelhqgth : isdecrel hqgth . Proof . apply isdecfldfracgt . exact isasymmhzgth . apply isdecrelhzgth . Defined . Definition hqgthdec := make_decrel isdecrelhqgth . (* Canonical Structure hqgthdec . *) Definition isdecrelhqlth : isdecrel hqlth := λ x x', isdecrelhqgth x' x . Definition hqlthdec := make_decrel isdecrelhqlth . (* Canonical Structure hqlthdec . *) Definition isdecrelhqleh : isdecrel hqleh := isdecnegrel _ isdecrelhqgth . Definition hqlehdec := make_decrel isdecrelhqleh . (* Canonical Structure hqlehdec . *) Definition isdecrelhqgeh : isdecrel hqgeh := λ x x', isdecrelhqleh x' x . Definition hqgehdec := make_decrel isdecrelhqgeh . (* Canonical Structure hqgehdec . *) (** *** Properties of individual relations *) (** [ hqgth ] *) Lemma istranshqgth ( n m k : hq ) : hqgth n m -> hqgth m k -> hqgth n k . Proof. apply istransfldfracgt . exact istranshzgth . Defined . Lemma isirreflhqgth ( n : hq ) : neg ( hqgth n n ) . Proof. apply isirreflfldfracgt . exact isirreflhzgth . Defined . Lemma isasymmhqgth ( n m : hq ) : hqgth n m -> hqgth m n -> empty . Proof. apply isasymmfldfracgt . exact isasymmhzgth . Defined . Lemma isantisymmneghqgth ( n m : hq ) : neg ( hqgth n m ) -> neg ( hqgth m n ) -> n = m . Proof . apply isantisymmnegfldfracgt . exact isirreflhzgth . exact isantisymmneghzgth . Defined . Lemma isnegrelhqgth : isnegrel hqgth . Proof . apply isdecreltoisnegrel . apply isdecrelhqgth . Defined . Lemma iscoantisymmhqgth ( n m : hq ) : neg ( hqgth n m ) -> ( hqgth m n ) ⨿ ( n = m ) . Proof . revert n m. apply isantisymmnegtoiscoantisymm . apply isdecrelhqgth . intros n m . apply isantisymmneghqgth . Defined . Lemma iscotranshqgth ( n m k : hq ) : hqgth n k -> hdisj ( hqgth n m ) ( hqgth m k ) . Proof . intros gnk . destruct ( isdecrelhqgth n m ) as [ gxy | ngxy ] . apply ( hinhpr ( ii1 gxy ) ) . apply hinhpr . apply ii2 . destruct ( isdecrelhqgth m n ) as [ gyx | ngyx ] . apply ( istranshqgth _ _ _ gyx gnk ) . set ( e := isantisymmneghqgth _ _ ngxy ngyx ) . rewrite e in gnk . apply gnk . Defined . (** [ hqlth ] *) Definition istranshqlth ( n m k : hq ) : hqlth n m -> hqlth m k -> hqlth n k := λ lnm lmk, istranshqgth _ _ _ lmk lnm . Definition isirreflhqlth ( n : hq ) : neg ( hqlth n n ) := isirreflhqgth n . Definition isasymmhqlth ( n m : hq ) : hqlth n m -> hqlth m n -> empty := λ lnm lmn, isasymmhqgth _ _ lmn lnm . Definition isantisymmneghqtth ( n m : hq ) : neg ( hqlth n m ) -> neg ( hqlth m n ) -> n = m := λ nlnm nlmn, isantisymmneghqgth _ _ nlmn nlnm . Definition isnegrelhqlth : isnegrel hqlth := λ n m, isnegrelhqgth m n . Definition iscoantisymmhqlth ( n m : hq ) : neg ( hqlth n m ) -> ( hqlth m n ) ⨿ ( n = m ) . Proof . intros nlnm . destruct ( iscoantisymmhqgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . Definition iscotranshqlth ( n m k : hq ) : hqlth n k -> hdisj ( hqlth n m ) ( hqlth m k ) . Proof . intros lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshqgth _ _ _ lnk ) ) . Defined . (** [ hqleh ] *) Definition istranshqleh ( n m k : hq ) : hqleh n m -> hqleh m k -> hqleh n k . Proof. apply istransnegrel . unfold iscotrans. apply iscotranshqgth . Defined. Definition isreflhqleh ( n : hq ) : hqleh n n := isirreflhqgth n . Definition isantisymmhqleh ( n m : hq ) : hqleh n m -> hqleh m n -> n = m := isantisymmneghqgth n m . Definition isnegrelhqleh : isnegrel hqleh . Proof . apply isdecreltoisnegrel . apply isdecrelhqleh . Defined . Definition iscoasymmhqleh ( n m : hq ) ( nl : neg ( hqleh n m ) ) : hqleh m n := negf ( isasymmhqgth _ _ ) nl . Definition istotalhqleh : istotal hqleh . Proof . intros x y . destruct ( isdecrelhqleh x y ) as [ lxy | lyx ] . apply ( hinhpr ( ii1 lxy ) ) . apply hinhpr . apply ii2 . apply ( iscoasymmhqleh _ _ lyx ) . Defined . (** [ hqgeh ] . *) Definition istranshqgeh ( n m k : hq ) : hqgeh n m -> hqgeh m k -> hqgeh n k := λ gnm gmk, istranshqleh _ _ _ gmk gnm . Definition isreflhqgeh ( n : hq ) : hqgeh n n := isreflhqleh _ . Definition isantisymmhqgeh ( n m : hq ) : hqgeh n m -> hqgeh m n -> n = m := λ gnm gmn, isantisymmhqleh _ _ gmn gnm . Definition isnegrelhqgeh : isnegrel hqgeh := λ n m, isnegrelhqleh m n . Definition iscoasymmhqgeh ( n m : hq ) ( nl : neg ( hqgeh n m ) ) : hqgeh m n := iscoasymmhqleh _ _ nl . Definition istotalhqgeh : istotal hqgeh := λ n m, istotalhqleh m n . (** ** [hq] is archimedean *) Lemma isarchhq : isarchfld (X := hq) hqgth. Proof. simple refine (isarchfldfrac hzintdom _ _ _ _ _ _ _ _). - exact isirreflhzgth. - exact istranshzgth. - apply isarchhz. Qed. (** *** Simple implications between comparisons *) Definition hqgthtogeh ( n m : hq ) : hqgth n m -> hqgeh n m . Proof. intros g . apply iscoasymmhqgeh . apply ( todneg _ g ) . Defined . Definition hqlthtoleh ( n m : hq ) : hqlth n m -> hqleh n m := hqgthtogeh _ _ . Definition hqlehtoneghqgth ( n m : hq ) : hqleh n m -> neg ( hqgth n m ) . Proof. intros is is' . apply ( is is' ) . Defined . Definition hqgthtoneghqleh ( n m : hq ) : hqgth n m -> neg ( hqleh n m ) := λ g l , hqlehtoneghqgth _ _ l g . Definition hqgehtoneghqlth ( n m : hq ) : hqgeh n m -> neg ( hqlth n m ) := λ gnm lnm, hqlehtoneghqgth _ _ gnm lnm . Definition hqlthtoneghqgeh ( n m : hq ) : hqlth n m -> neg ( hqgeh n m ) := λ gnm lnm, hqlehtoneghqgth _ _ lnm gnm . Definition neghqlehtogth ( n m : hq ) : neg ( hqleh n m ) -> hqgth n m := isnegrelhqgth n m . Definition neghqgehtolth ( n m : hq ) : neg ( hqgeh n m ) -> hqlth n m := isnegrelhqlth n m . Definition neghqgthtoleh ( n m : hq ) : neg ( hqgth n m ) -> hqleh n m . Proof . intros ng . destruct ( isdecrelhqleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) . Defined . Definition neghqlthtogeh ( n m : hq ) : neg ( hqlth n m ) -> hqgeh n m := λ nl, neghqgthtoleh _ _ nl . (** *** Comparison alternatives *) Definition hqgthorleh ( n m : hq ) : ( hqgth n m ) ⨿ ( hqleh n m ) . Proof . intros . apply ( isdecrelhqgth n m ) . Defined . Definition hqlthorgeh ( n m : hq ) : ( hqlth n m ) ⨿ ( hqgeh n m ) := hqgthorleh _ _ . Definition hqneqchoice ( n m : hq ) ( ne : neg ( n = m ) ) : ( hqgth n m ) ⨿ ( hqlth n m ) . Proof . intros . destruct ( hqgthorleh n m ) as [ g | l ] . destruct ( hqlthorgeh n m ) as [ g' | l' ] . destruct ( isasymmhqgth _ _ g g' ) . apply ( ii1 g ) . destruct ( hqlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmhqleh _ _ l g' ) ) . Defined . Definition hqlehchoice ( n m : hq ) ( l : hqleh n m ) : ( hqlth n m ) ⨿ ( n = m ) . Proof . intros . destruct ( hqlthorgeh n m ) as [ l' | g ] . apply ( ii1 l' ) . apply ( ii2 ( isantisymmhqleh _ _ l g ) ) . Defined . Definition hqgehchoice ( n m : hq ) ( g : hqgeh n m ) : ( hqgth n m ) ⨿ ( n = m ) . Proof . intros . destruct ( hqgthorleh n m ) as [ g' | l ] . apply ( ii1 g' ) . apply ( ii2 ( isantisymmhqleh _ _ l g ) ) . Defined . (** *** Mixed transitivities *) Lemma hqgthgehtrans ( n m k : hq ) : hqgth n m -> hqgeh m k -> hqgth n k . Proof. intros gnm gmk . destruct ( hqgehchoice m k gmk ) as [ g' | e ] . apply ( istranshqgth _ _ _ gnm g' ) . rewrite e in gnm . apply gnm . Defined. Lemma hqgehgthtrans ( n m k : hq ) : hqgeh n m -> hqgth m k -> hqgth n k . Proof. intros gnm gmk . destruct ( hqgehchoice n m gnm ) as [ g' | e ] . apply ( istranshqgth _ _ _ g' gmk ) . rewrite e . apply gmk . Defined. Lemma hqlthlehtrans ( n m k : hq ) : hqlth n m -> hqleh m k -> hqlth n k . Proof . intros l1 l2 . apply ( hqgehgthtrans k m n l2 l1 ) . Defined . Lemma hqlehlthtrans ( n m k : hq ) : hqleh n m -> hqlth m k -> hqlth n k . Proof . intros l1 l2 . apply ( hqgthgehtrans k m n l2 l1 ) . Defined . (** *** Addition and comparisons *) (** [ gth ] *) Definition isringaddhzgth : @isbinophrel hqaddabgr hqgth . Proof . apply isringaddfldfracgt . exact isirreflhzgth . Defined . Definition hqgthandplusl ( n m k : hq ) : hqgth n m -> hqgth ( k + n ) ( k + m ) := λ g, ( pr1 isringaddhzgth ) n m k g . Definition hqgthandplusr ( n m k : hq ) : hqgth n m -> hqgth ( n + k ) ( m + k ) := λ g, ( pr2 isringaddhzgth ) n m k g . Definition hqgthandpluslinv ( n m k : hq ) : hqgth ( k + n ) ( k + m ) -> hqgth n m . Proof. intros g . set ( g' := hqgthandplusl _ _ ( - k ) g ) . clearbody g' . rewrite ( pathsinv0 ( hqplusassoc _ _ n ) ) in g' . rewrite ( pathsinv0 ( hqplusassoc _ _ m ) ) in g' . rewrite ( hqlminus k ) in g' . rewrite ( hqplusl0 _ ) in g' . rewrite ( hqplusl0 _ ) in g' . apply g' . Defined . Definition hqgthandplusrinv ( n m k : hq ) : hqgth ( n + k ) ( m + k ) -> hqgth n m . Proof. intros l . rewrite ( hqpluscomm n k ) in l . rewrite ( hqpluscomm m k ) in l . apply ( hqgthandpluslinv _ _ _ l ) . Defined . Lemma hqgthsnn ( n : hq ) : hqgth ( n + 1 ) n . Proof . set ( int := hqgthandplusl _ _ n ( ct ( hqgth , isdecrelhqgth , 1 , 0 ) ) ) . clearbody int . rewrite ( hqplusr0 n ) in int . apply int . Defined . (** [ lth ] *) Definition hqlthandplusl ( n m k : hq ) : hqlth n m -> hqlth ( k + n ) ( k + m ) := hqgthandplusl _ _ _ . Definition hqlthandplusr ( n m k : hq ) : hqlth n m -> hqlth ( n + k ) ( m + k ) := hqgthandplusr _ _ _ . Definition hqlthandpluslinv ( n m k : hq ) : hqlth ( k + n ) ( k + m ) -> hqlth n m := hqgthandpluslinv _ _ _ . Definition hqlthandplusrinv ( n m k : hq ) : hqlth ( n + k ) ( m + k ) -> hqlth n m := hqgthandplusrinv _ _ _ . Definition hqlthnsn ( n : hq ) : hqlth n ( n + 1 ) := hqgthsnn n . (** [ leh ] *) Definition hqlehandplusl ( n m k : hq ) : hqleh n m -> hqleh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv n m k ) . Definition hqlehandplusr ( n m k : hq ) : hqleh n m -> hqleh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv n m k ) . Definition hqlehandpluslinv ( n m k : hq ) : hqleh ( k + n ) ( k + m ) -> hqleh n m := negf ( hqgthandplusl n m k ) . Definition hqlehandplusrinv ( n m k : hq ) : hqleh ( n + k ) ( m + k ) -> hqleh n m := negf ( hqgthandplusr n m k ) . (** [ geh ] *) Definition hqgehandplusl ( n m k : hq ) : hqgeh n m -> hqgeh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv m n k ) . Definition hqgehandplusr ( n m k : hq ) : hqgeh n m -> hqgeh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv m n k ) . Definition hqgehandpluslinv ( n m k : hq ) : hqgeh ( k + n ) ( k + m ) -> hqgeh n m := negf ( hqgthandplusl m n k ) . Definition hqgehandplusrinv ( n m k : hq ) : hqgeh ( n + k ) ( m + k ) -> hqgeh n m := negf ( hqgthandplusr m n k ) . (** *** Properties of [ hqgth ] in the terminology of algebra1.v *) Definition isplushrelhqgth : @isbinophrel hqaddabgr hqgth := isringaddhzgth . Lemma isinvplushrelhqgth : @isinvbinophrel hqaddabgr hqgth . Proof . split . apply hqgthandpluslinv . apply hqgthandplusrinv . Defined . Lemma isringmulthqgth : isringmultgt _ hqgth . Proof . apply isringmultfldfracgt . exact isirreflhzgth . Defined . Lemma isinvringmulthqgth : isinvringmultgt _ hqgth . Proof . apply isinvringmultgtif . apply isplushrelhqgth . apply isringmulthqgth . exact hqneqchoice . exact isasymmhqgth . Defined . (** *** Negation and comparisons *) (** [ hqgth ] *) Lemma hqgth0andminus { n : hq } ( is : hqgth n 0 ) : hqlth ( - n ) 0 . Proof . intros . unfold hqlth . apply ( ringfromgt0 hq isplushrelhqgth is ) . Defined . Lemma hqminusandgth0 { n : hq } ( is : hqgth ( - n ) 0 ) : hqlth n 0 . Proof . intros . unfold hqlth . apply ( ringtolt0 hq isplushrelhqgth is ) . Defined . (** [ hqlth ] *) Lemma hqlth0andminus { n : hq } ( is : hqlth n 0 ) : hqgth ( - n ) 0 . Proof . intros . unfold hqlth . apply ( ringfromlt0 hq isplushrelhqgth is ) . Defined . Lemma hqminusandlth0 { n : hq } ( is : hqlth ( - n ) 0 ) : hqgth n 0 . Proof . intros . unfold hqlth . apply ( ringtogt0 hq isplushrelhqgth is ) . Defined . (* ??? Coq slows down for no good reason at Defined in the previous four lemmas. *) (** [ hqleh ] *) Lemma hqleh0andminus { n : hq } ( is : hqleh n 0 ) : hqgeh ( - n ) 0 . Proof . revert is. apply ( negf ( @hqminusandlth0 n ) ) . Defined . Lemma hqminusandleh0 { n : hq } ( is : hqleh ( - n ) 0 ) : hqgeh n 0 . Proof . revert is. apply ( negf ( @hqlth0andminus n ) ) . Defined . (** [ hqgeh ] *) Lemma hqgeh0andminus { n : hq } ( is : hqgeh n 0 ) : hqleh ( - n ) 0 . Proof . revert is. apply ( negf ( @hqminusandgth0 n ) ) . Defined . Lemma hqminusandgeh0 { n : hq } ( is : hqgeh ( - n ) 0 ) : hqleh n 0 . Proof . revert is. apply ( negf ( @hqgth0andminus n ) ) . Defined . (** *** Multiplication and comparisons *) (** [ gth ] *) Definition hqgthandmultl ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( k * n ) ( k * m ) . Proof. revert n m k is. apply ( isringmultgttoislringmultgt _ isplushrelhqgth isringmulthqgth ) . Defined . Definition hqgthandmultr ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( n * k ) ( m * k ) . Proof . revert n m k is. apply ( isringmultgttoisrringmultgt _ isplushrelhqgth isringmulthqgth ) . Defined . Definition hqgthandmultlinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( k * n ) ( k * m ) -> hqgth n m . Proof . intros is' . apply ( isinvringmultgttoislinvringmultgt hq isplushrelhqgth isinvringmulthqgth n m k is is' ) . Defined . Definition hqgthandmultrinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( n * k ) ( m * k ) -> hqgth n m . Proof. intros is' . apply ( isinvringmultgttoisrinvringmultgt hq isplushrelhqgth isinvringmulthqgth n m k is is' ) . Defined . (** [ lth ] *) Definition hqlthandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( k * n ) ( k * m ) := hqgthandmultl _ _ _ is . Definition hqlthandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( n * k ) ( m * k ) := hqgthandmultr _ _ _ is . Definition hqlthandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( k * n ) ( k * m ) -> hqlth n m := hqgthandmultlinv _ _ _ is . Definition hqlthandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( n * k ) ( m * k ) -> hqlth n m := hqgthandmultrinv _ _ _ is . (** [ leh ] *) Definition hqlehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) . Definition hqlehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( n * k ) ( m * k ) := negf ( hqgthandmultrinv _ _ _ is ) . Definition hqlehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( k * n ) ( k * m ) -> hqleh n m := negf ( hqgthandmultl _ _ _ is ) . Definition hqlehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( n * k ) ( m * k ) -> hqleh n m := negf ( hqgthandmultr _ _ _ is ) . (** [ geh ] *) Definition hqgehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) . Definition hqgehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( n * k ) ( m * k ) := negf ( hqgthandmultrinv _ _ _ is ) . Definition hqgehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( k * n ) ( k * m ) -> hqgeh n m := negf ( hqgthandmultl _ _ _ is ) . Definition hqgehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( n * k ) ( m * k ) -> hqgeh n m := negf ( hqgthandmultr _ _ _ is ) . (** Multiplication of positive with negative, negative with positive and two negatives. *) Lemma hqmultgth0gth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgth n 0 ) : hqgth ( m * n ) 0 . Proof . intros . apply isringmulthqgth . apply ism . apply isn . Defined . Lemma hqmultgth0geh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . destruct ( hqgehchoice _ _ isn ) as [ gn | en ] . apply ( hqgthtogeh _ _ ( hqmultgth0gth0 ism gn ) ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined . Lemma hqmultgeh0gth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgth n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . destruct ( hqgehchoice _ _ ism ) as [ gm | em ] . apply ( hqgthtogeh _ _ ( hqmultgth0gth0 gm isn ) ) . rewrite em . rewrite ( hqmult0x _ ) . apply isreflhqgeh . Defined . Lemma hqmultgeh0geh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . destruct ( hqgehchoice _ _ isn ) as [ gn | en ] . apply ( hqmultgeh0gth0 ism gn ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined . Lemma hqmultgth0lth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqlth n 0 ) : hqlth ( m * n ) 0 . Proof . intros . apply ( ringmultgt0lt0 hq isplushrelhqgth isringmulthqgth ) . apply ism . apply isn . Defined . Lemma hqmultgth0leh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 . Proof . intros . destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . apply ( hqlthtoleh _ _ ( hqmultgth0lth0 ism ln ) ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined . Lemma hqmultgeh0lth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqlth n 0 ) : hqleh ( m * n ) 0 . Proof . intros . destruct ( hqlehchoice _ _ ism ) as [ lm | em ] . apply ( hqlthtoleh _ _ ( hqmultgth0lth0 lm isn ) ) . destruct em . rewrite ( hqmult0x _ ) . apply isreflhqleh . Defined . Lemma hqmultgeh0leh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 . Proof . intros . destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . apply ( hqmultgeh0lth0 ism ln ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined . Lemma hqmultlth0gth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgth n 0 ) : hqlth ( m * n ) 0 . Proof . intros . rewrite ( hqmultcomm ) . apply hqmultgth0lth0 . apply isn . apply ism . Defined . Lemma hqmultlth0geh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 . Proof . intros . rewrite ( hqmultcomm ) . apply hqmultgeh0lth0 . apply isn . apply ism . Defined . Lemma hqmultleh0gth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgth n 0 ) : hqleh ( m * n ) 0 . Proof . intros . rewrite ( hqmultcomm ) . apply hqmultgth0leh0 . apply isn . apply ism . Defined . Lemma hqmultleh0geh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 . Proof . intros . rewrite ( hqmultcomm ) . apply hqmultgeh0leh0 . apply isn . apply ism . Defined . Lemma hqmultlth0lth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqlth n 0 ) : hqgth ( m * n ) 0 . Proof . intros . assert ( ism' := hqlth0andminus ism ) . assert ( isn' := hqlth0andminus isn ) . assert ( int := isringmulthqgth _ _ ism' isn' ) . rewrite ( ringmultminusminus hq ) in int . apply int . Defined . Lemma hqmultlth0leh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . intros . destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . apply ( hqgthtogeh _ _ ( hqmultlth0lth0 ism ln ) ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined . Lemma hqmultleh0lth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqlth n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . destruct ( hqlehchoice _ _ ism ) as [ lm | em ] . apply ( hqgthtogeh _ _ ( hqmultlth0lth0 lm isn ) ) . rewrite em . rewrite ( hqmult0x _ ) . apply isreflhqgeh . Defined . Lemma hqmultleh0leh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 . Proof . intros . destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . apply ( hqmultleh0lth0 ism ln ) . rewrite en . rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined . (** *** Cancellation properties of multiplication on [ hq ] *) Lemma hqmultlcan ( a b c : hq ) ( ne : neg ( c = 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : a = b . Proof . intros . apply ( intdomlcan hq _ _ _ ne e ) . Defined . Lemma hqmultrcan ( a b c : hq ) ( ne : neg ( c = 0 ) ) ( e : paths ( a * c ) ( b * c ) ) : a = b . Proof . intros . apply ( intdomrcan hq _ _ _ ne e ) . Defined . (** *** Positive rationals *) Definition hqpos : @subabmonoid hqmultabmonoid . Proof . split with ( λ x, hqgth x 0 ) . split . intros x1 x2 . apply ( isringmulthqgth ) . apply ( pr2 x1 ) . apply ( pr2 x2 ) . apply ( ct ( hqgth , isdecrelhqgth , 1 , 0 ) ) . Defined . (** *** Canonical ring homomorphism from [ hz ] to [ hq ] *) Definition hztohq : hz -> hq := tofldfrac hzintdom isdeceqhz. Definition isinclhztohq : isincl hztohq := isincltofldfrac hzintdom isdeceqhz . Definition hztohqandneq ( n m : hz ) ( is : hzneq n m ) : hqneq ( hztohq n ) ( hztohq m ) := negf ( invmaponpathsincl _ isinclhztohq n m ) is . Definition hztohqand0 : paths ( hztohq 0%hz ) 0 := idpath _ . Definition hztohqand1 : paths ( hztohq 1%hz ) 1 := idpath _ . Definition hztohqandplus ( n m : hz ) : paths ( hztohq ( n + m )%hz ) ( hztohq n + hztohq m ) := isbinop1funtofldfrac hzintdom isdeceqhz n m . Definition hztohqandminus ( n m : hz ) : paths ( hztohq ( n - m )%hz ) ( hztohq n - hztohq m ) := tofldfracandminus hzintdom isdeceqhz n m . Definition hztohqandmult ( n m : hz ) : paths ( hztohq ( n * m )%hz ) ( hztohq n * hztohq m ) := isbinop2funtofldfrac hzintdom isdeceqhz n m . Definition hztohqandgth ( n m : hz ) ( is : hzgth n m ) : hqgth ( hztohq n ) ( hztohq m ) := iscomptofldfrac hzintdom isdeceqhz isplushrelhzgth isringmulthzgth ( ct ( hzgth , isdecrelhzgth , 1 , 0 )%hz ) ( hzneqchoice ) ( isasymmhzgth ) n m is . Definition hztohqandlth ( n m : hz ) ( is : hzlth n m ) : hqlth ( hztohq n ) ( hztohq m ) := hztohqandgth m n is . Definition hztohqandleh ( n m : hz ) ( is : hzleh n m ) : hqleh ( hztohq n ) ( hztohq m ) . Proof . intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] . apply ( hqlthtoleh _ _ ( hztohqandlth _ _ l ) ) . rewrite e . apply ( isreflhqleh ) . Defined . Definition hztohqandgeh ( n m : hz ) ( is : hzgeh n m ) : hqgeh ( hztohq n ) ( hztohq m ) := hztohqandleh _ _ is . (** *** Integral part of a rational *) Definition intpartint0 ( xa : dirprod hz ( intdomnonzerosubmonoid hzintdom ) ) : nat := natdiv ( hzabsval (pr1 xa ) ) ( hzabsval ( pr1 ( pr2 xa ) ) ) . Lemma iscompintpartint0 : iscomprelfun ( eqrelabmonoidfrac hzmultabmonoid ( intdomnonzerosubmonoid hzintdom ) ) intpartint0 . Proof . Opaque hq. unfold iscomprelfun . intros xa1 xa2 . set ( x1 := pr1 xa1 ) . set ( aa1 := pr2 xa1 ) . set ( a1 := pr1 aa1 ) . set ( x2 := pr1 xa2 ) . set ( aa2 := pr2 xa2 ) . set ( a2 := pr1 aa2 ) . simpl . apply ( @hinhuniv _ ( make_hProp _ ( setproperty natset _ _ ) ) ) . intro t2 . assert ( e := pr2 t2 ) . simpl in e . assert ( e' := ( maponpaths hzabsval ( hzmultrcan _ _ _ ( pr2 ( pr1 t2 ) ) e ) ) : paths ( hzabsval ( x1 * a2 )%hz ) ( hzabsval ( x2 * a1 )%hz ) ) . clear e . clear t2 . rewrite ( pathsinv0 ( hzabsvalandmult _ _ ) ) in e' . rewrite ( pathsinv0 ( hzabsvalandmult _ _ ) ) in e' . unfold intpartint0 . simpl . change ( paths ( natdiv ( hzabsval x1 ) ( hzabsval a1 ) ) ( natdiv ( hzabsval x2 ) ( hzabsval a2 ) ) ) . rewrite ( pathsinv0 ( natdivandmultr (hzabsval x1 ) (hzabsval a1 ) ( hzabsval a2 ) ( hzabsvalneq0 ( pr2 aa1 ) ) ( natneq0andmult _ _ ( hzabsvalneq0 (pr2 aa1) ) ( hzabsvalneq0 (pr2 aa2) ) ) ) ) . rewrite ( pathsinv0 ( natdivandmultr (hzabsval x2 ) (hzabsval a2 ) ( hzabsval a1 ) ( hzabsvalneq0 ( pr2 aa2 ) ) ( natneq0andmult _ _ ( hzabsvalneq0 (pr2 aa2) ) ( hzabsvalneq0 (pr2 aa1) ) ) ) ) . rewrite ( natmultcomm ( hzabsval a1 ) ( hzabsval a2 ) ) . rewrite e' . apply idpath . Transparent hq . Defined . Opaque iscompintpartint0 . Definition intpart0 : hq -> nat := setquotuniv ( eqrelabmonoidfrac hzmultabmonoid (intdomnonzerosubmonoid hzintdom) ) natset _ ( iscompintpartint0 ) . Definition intpart ( x : hq ) : hz . Proof . destruct ( hqlthorgeh x 0 ) as [ l | ge ] . destruct ( isdeceqhq ( x + ( hztohq ( nattohz ( intpart0 x ) ) ) ) 0 ) as [ e | ne ] . apply ( - (nattohz (intpart0 x)))%hz . apply ( - ( 1 + (nattohz (intpart0 x)) ) )%hz . apply (nattohz (intpart0 x)) . Defined . (* End of the file hq.v *) UniMath-20231010/UniMath/NumberSystems/Tests.v000066400000000000000000000166001451125700300207700ustar00rootroot00000000000000Require UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.Groups. Require UniMath.MoreFoundations.DecidablePropositions. Require UniMath.MoreFoundations.NegativePropositions. Module Test_nat. Import UniMath.Foundations.NaturalNumbers. Import UniMath.MoreFoundations.DecidablePropositions. Import UniMath.MoreFoundations.NegativePropositions. Local Open Scope nat_scope. Goal 3 ≠ 5. exact tt. Defined. Goal ¬ (3 ≠ 3). intro n. apply n. Defined. Section Test_A. Let C := compl nat 0. Let C' := compl_ne nat 0 (λ m, 0 ≠ m). Let w := compl_ne_weq_compl nat 0 (λ m, 0 ≠ m) : C ≃ C'. Let cn : C := (3,,negpaths0sx _). Let cn' : C' := (3,,tt). Goal w cn = cn'. reflexivity. Defined. Goal invmap w cn' = cn. reflexivity. Defined. Goal homotinvweqweq w cn = idpath _. try reflexivity. Abort. (* prevented by funextfun *) Goal homotweqinvweq w cn' = idpath _. reflexivity. Defined. (* 2 seconds *) Let f := weqrecompl nat 0 (isdeceqnat 0). Let f' := weqrecompl_ne nat 0 (isdeceqnat 0) (λ m, 0 ≠ m). Goal f (ii1 cn) = 3. reflexivity. Defined. Goal f' (ii1 cn') = 3. reflexivity. Defined. Goal invmap f 3 = (ii1 cn). reflexivity. Defined. Goal invmap f' 3 = (ii1 cn'). reflexivity. Defined. Goal homotweqinvweq f 3 = idpath _. reflexivity. Defined. Goal homotweqinvweq f' 3 = idpath _. reflexivity. Defined. Goal homotinvweqweq f (ii1 cn) = idpath _. try reflexivity. Abort. (* prevented by funextfun *) Goal homotinvweqweq f' (ii1 cn') = idpath _. reflexivity. Defined. (* succeeds by avoiding funextfun *) End Test_A. Goal choice (3 < 4)%dnat true false = true. reflexivity. Defined. Goal choice (3 < 4 ∧ 4 < 5)%dnat%declog true false = true. reflexivity. Defined. Goal choice (¬ (3 < 4))%dnat%declog true false = false. reflexivity. Defined. Goal choice (3 < 4 ∨ 4 < 3)%dnat%declog true false = true. reflexivity. Defined. Goal choice (4 < 3 ∨ 2 < 1)%dnat%declog true false = false. reflexivity. Defined. Goal si 3 (di 3 2) = 2. reflexivity. Defined. Goal si 3 (di 3 3) = 3. reflexivity. Defined. Goal si 3 (di 3 4) = 4. reflexivity. Defined. Goal si 3 2 = 2. reflexivity. Defined. Goal si 3 3 = 3. reflexivity. Defined. Goal si 3 4 = 3. reflexivity. Defined. Goal si 3 5 = 4. reflexivity. Defined. Section Test_weqdicompl. Let w := weqdicompl 3 : nat ≃ nat_compl 3. Goal w 2 = (2,,tt). reflexivity. Defined. Goal w 3 = (4,,tt). reflexivity. Defined. Goal invmap w (2,,tt) = 2. reflexivity. Defined. Goal invmap w (4,,tt) = 3. reflexivity. Defined. Goal homotweqinvweq w (2,,tt) = idpath _. reflexivity. Defined. Goal homotweqinvweq w (4,,tt) = idpath _. reflexivity. Defined. Goal homotinvweqweq w 2 = idpath _. reflexivity. Defined. Goal homotinvweqweq w 4 = idpath _. reflexivity. Defined. Goal homotweqinvweqweq w 2 = idpath _. reflexivity. Defined. Goal homotweqinvweqweq w 4 = idpath _. reflexivity. Defined. End Test_weqdicompl. End Test_nat. Require UniMath.Algebra.IteratedBinaryOperations. Require UniMath.Combinatorics.FiniteSets. Require UniMath.NumberSystems.NaturalNumbersAlgebra. Module Test_finsum. Import UniMath.Algebra.IteratedBinaryOperations. Import UniMath.Combinatorics.FiniteSets. Import UniMath.NumberSystems.NaturalNumbersAlgebra. Goal ∏ X (fin : finstruct X) (f : X -> nat), finsum (hinhpr fin) f = stnsum (f ∘ pr1weq (pr2 fin)). Proof. intros. intermediate_path (iterop_fun_mon (M := nataddabmonoid) (f ∘ pr1weq (pr2 fin))). - reflexivity. - apply iterop_fun_nat. Qed. Goal 15 = finsum (isfinitestn _) (λ i:stn 6, i). reflexivity. Qed. Goal 20 = finsum isfinitebool (λ i:bool, 10). reflexivity. Qed. Goal 21 = finsum (isfinitecoprod isfinitebool isfinitebool) (coprod_rect (λ _, nat) (bool_rect _ 10 4) (bool_rect _ 6 1)). reflexivity. (* fixed *) Qed. Goal 10 = finsum' (isfinitestn _) (λ i:stn 5, i). reflexivity. Defined. (* fixed! *) Goal 20 = finsum' isfinitebool (λ i:bool, 10). reflexivity. Qed. Goal 21 = finsum' (isfinitecoprod isfinitebool isfinitebool) (coprod_rect (λ _, nat) (bool_rect _ 10 4) (bool_rect _ 6 1)). try reflexivity. (* fails, for some reason *) Abort. Section Iteration. Local Notation "s □ x" := (append s x) (at level 64, left associativity). Context (G:abgr) (R:ring) (S:commring) (g g' g'':G) (r r' r'':R) (s s' s'':S). Local Open Scope multmonoid. Goal iterop_unoseq_abgr (nil : Sequence G) = 1. reflexivity. Qed. Goal iterop_unoseq_abgr (nil □ g □ g') = g*g'. reflexivity. Qed. Goal iterop_unoseq_abgr (nil □ g □ g' □ g'') = g*g'*g''. reflexivity. Qed. Goal iterop_unoseq_unoseq_mon (M:=G) (sequenceToUnorderedSequence(nil □ sequenceToUnorderedSequence(nil □ g □ g') □ sequenceToUnorderedSequence(nil □ g □ g' □ g''))) = (g*g') * (g*g'*g''). reflexivity. Qed. Goal iterop_unoseq_unoseq_mon (M:=G) (sequenceToUnorderedSequence(nil □ sequenceToUnorderedSequence(nil □ g) □ sequenceToUnorderedSequence(nil))) = g * 1. reflexivity. Qed. Goal iterop_unoseq_unoseq_mon (M:=G) (sequenceToUnorderedSequence(nil □ sequenceToUnorderedSequence(nil) □ sequenceToUnorderedSequence(nil □ g))) = 1 * g. reflexivity. Qed. Close Scope multmonoid. Local Open Scope ring. Goal sum_unoseq_ring (nil : Sequence R) = 0. reflexivity. Qed. Goal sum_unoseq_ring (nil □ r □ r') = r+r'. reflexivity. Qed. Goal sum_unoseq_ring (nil □ r □ r' □ r'') = r+r'+r''. reflexivity. Qed. Goal product_unoseq_ring (nil : Sequence S) = 1. reflexivity. Qed. Goal product_unoseq_ring (nil □ s □ s') = s*s'. reflexivity. Qed. Goal product_unoseq_ring (nil □ s □ s' □ s'') = s*s'*s''. reflexivity. Qed. End Iteration. End Test_finsum. Require UniMath.NumberSystems.Integers. Module Test_int. Import UniMath.NumberSystems.Integers. Goal true = (hzbooleq (natnattohz 3 4) (natnattohz 17 18)) . reflexivity. Qed. Goal false = (hzbooleq (natnattohz 3 4) (natnattohz 17 19)) . reflexivity. Qed. Goal 2 * 100 + 7 * 10 + 4 = (hzabsval (natnattohz (5 * 10 + 8) (3 * 100 + 3 * 10 + 2))) . reflexivity. Qed. Goal O = (hzabsval (hzplus (natnattohz 2 3) (natnattohz 3 2))) . reflexivity. Qed. Goal 2 = (hzabsval (hzminus (natnattohz 2 3) (natnattohz 3 2))) . reflexivity. Qed. Goal 3 * 100 = (hzabsval (hzmult (natnattohz (2 * 10) (5 * 10)) (natnattohz (3 * 10) (2 * 10)))) . reflexivity. Qed. End Test_int. Require UniMath.NumberSystems.RationalNumbers. Module Test_rat. Import UniMath.NumberSystems.RationalNumbers. Open Scope hz_scope . Open Scope hq_scope . Transparent hz . Goal true = ( hqbooleq ( hzhztohq ( natnattohz 4 0 ) ( tpair _ ( natnattohz 3 0 ) ( ct ( hzneq , isdecrelhzneq, ( natnattohz 3 0 ) , 0 %hz ) ) ) ) ( hzhztohq ( natnattohz 13 1 ) ( tpair _ ( natnattohz 11 2 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 11 2 ) , 0 %hz ) ) ) ) ) . reflexivity. Qed. Goal true = ( decreltobrel hqgthdec ( hzhztohq ( natnattohz 5 0 ) ( tpair _ ( natnattohz 3 0 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 3 0 ) , hzzero ) ) ) ) ( hzhztohq ( natnattohz 13 1 ) ( tpair _ ( natnattohz 11 2 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 11 2 ) , hzzero ) ) ) ) ) . reflexivity. Qed. Goal 4 = ( hzabsval ( intpart ( hqdiv ( hztohq ( nattohz ( 10 ) ) ) ( - ( 1 + 1 + 1 ) ) ) ) ) . reflexivity. Qed. End Test_rat.UniMath-20231010/UniMath/OrderTheory/000077500000000000000000000000001451125700300171225ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/.package/000077500000000000000000000000001451125700300205735ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/.package/files000066400000000000000000000022241451125700300216200ustar00rootroot00000000000000Posets/Basics.v Posets/MonotoneFunctions.v Posets/PosetSum.v Posets/PointedPosets.v Posets/LiftPoset.v Posets/QuotientPoset.v Posets.v Lattice/Lattice.v Lattice/Bounded.v Lattice/Complement.v Lattice/Distributive.v Lattice/Heyting.v Lattice/Boolean.v Lattice/Examples/Bool.v Lattice/Examples/Subsets.v DCPOs/Core/DirectedSets.v DCPOs/Core/Basics.v DCPOs/Core/WayBelow.v DCPOs/Basis/Continuous.v DCPOs/Basis/Algebraic.v DCPOs/Core/ScottTopology.v DCPOs/Core/IntrinsicApartness.v DCPOs/Core/ScottContinuous.v DCPOs/Basis/Basis.v DCPOs/Basis/CompactBasis.v DCPOs/Elements/Sharp.v DCPOs/Elements/Maximal.v DCPOs/Examples/Unit.v DCPOs/Examples/Propositions.v DCPOs/Examples/Discrete.v DCPOs/Examples/SubDCPO.v DCPOs/Examples/Fixpoints.v DCPOs/Examples/Equalizers.v DCPOs/Examples/BinaryProducts.v DCPOs/Examples/Products.v DCPOs/Examples/BinarySums.v DCPOs/Examples/Sums.v DCPOs/Examples/IdealCompletion.v DCPOs/Core/FubiniTheorem.v DCPOs/Core/CoordinateContinuity.v DCPOs/Examples/Exponentials.v DCPOs/FixpointTheorems/LeastFixpoint.v DCPOs/FixpointTheorems/Pataraia.v DCPOs/AlternativeDefinitions/Dcpo.v DCPOs/AlternativeDefinitions/FixedPointTheorems.v DCPOs.v UniMath-20231010/UniMath/OrderTheory/DCPOs.v000066400000000000000000000034041451125700300202220ustar00rootroot00000000000000(** This file exports the files about dcpos in the combinatorics directory. *) Require Export UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Export UniMath.OrderTheory.DCPOs.Core.Basics. Require Export UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Export UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Export UniMath.OrderTheory.DCPOs.Basis.Continuous. Require Export UniMath.OrderTheory.DCPOs.Basis.Algebraic. Require Export UniMath.OrderTheory.DCPOs.Basis.Basis. Require Export UniMath.OrderTheory.DCPOs.Basis.CompactBasis. Require Export UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Export UniMath.OrderTheory.DCPOs.Core.IntrinsicApartness. Require Export UniMath.OrderTheory.DCPOs.Elements.Sharp. Require Export UniMath.OrderTheory.DCPOs.Elements.Maximal. Require Export UniMath.OrderTheory.DCPOs.Examples.Unit. Require Export UniMath.OrderTheory.DCPOs.Examples.Propositions. Require Export UniMath.OrderTheory.DCPOs.Examples.Discrete. Require Export UniMath.OrderTheory.DCPOs.Examples.SubDCPO. Require Export UniMath.OrderTheory.DCPOs.Examples.Fixpoints. Require Export UniMath.OrderTheory.DCPOs.Examples.Equalizers. Require Export UniMath.OrderTheory.DCPOs.Examples.BinaryProducts. Require Export UniMath.OrderTheory.DCPOs.Examples.Products. Require Export UniMath.OrderTheory.DCPOs.Examples.BinarySums. Require Export UniMath.OrderTheory.DCPOs.Examples.Sums. Require Export UniMath.OrderTheory.DCPOs.Examples.IdealCompletion. Require Export UniMath.OrderTheory.DCPOs.Core.FubiniTheorem. Require Export UniMath.OrderTheory.DCPOs.Core.CoordinateContinuity. Require Export UniMath.OrderTheory.DCPOs.Examples.Exponentials. Require Export UniMath.OrderTheory.DCPOs.FixpointTheorems.LeastFixpoint. Require Export UniMath.OrderTheory.DCPOs.FixpointTheorems.Pataraia. UniMath-20231010/UniMath/OrderTheory/DCPOs/000077500000000000000000000000001451125700300200325ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/AlternativeDefinitions/000077500000000000000000000000001451125700300245045ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/AlternativeDefinitions/Dcpo.v000066400000000000000000000507571451125700300255760ustar00rootroot00000000000000(** Tom de Jong Created: November 2018 Refactored: January 2019 **************************************************************************** Note: a newer and different implementation of DCPOs and fixed point theorems can be found in OrderTheory.DCPOs. **************************************************************************** *******************************************************************************) (** * Directed complete posets and least fixed points *) (** ** Contents - Least upper bounds ([leastupperbound]) - Definition of a directed family ([directedfamily]) - Definition of a directed complete poset (dcpo) ([dcpo]) - Definition of a morphisms of dcpos ([morphismofdcpos]) - The morphisms between two dcpos form a dcpo with the pointwise order ([morphismsofdcpos_formdcpo]) - Definition of a dcpo with bottom ([dcpowithbottom]) - The least fixed point operator for morphisms between dcpos with bottom ([leastfixedpoint]) *) Require Import UniMath.Foundations.All. Local Open Scope poset. (* So we can write ≤ *) (** ** Least upper bounds *) Section leastupperbound. Context {X : Poset}. Context {I : UU}. Variable (f : I -> X). (* Indexing family *) Definition isupperbound (u : X) : UU := ∏ (i : I), f i ≤ u. Lemma isaprop_isupperbound (u : X) : isaprop (isupperbound u). Proof. apply impred_isaprop; intro i; apply propproperty. Qed. (* Definition of least upper bound (lub) *) Definition islub (u : X) : UU := isupperbound u × ∏ (y : X), (∏ (i : I), f i ≤ y) -> u ≤ y. Lemma isaprop_islub (u : X) : isaprop (islub u). Proof. apply isapropdirprod. - apply isaprop_isupperbound. - apply impred_isaprop; intro x. apply isapropimpl; apply propproperty. Qed. Definition islub_isupperbound {u : X} : islub u -> isupperbound u := pr1. Definition islub_isleast {u : X} : islub u -> ∏ (y : X), (∏ (i : I), f i ≤ y) -> u ≤ y := pr2. Lemma lubsareunique {u v : X} : islub u -> islub v -> u = v. Proof. intros islubu islubv. apply isantisymm_posetRelation. - apply (islub_isleast islubu). exact (islub_isupperbound islubv). - apply (islub_isleast islubv). exact (islub_isupperbound islubu). Qed. End leastupperbound. (** ** Directed families *) Section directedfamily. Context {X : Poset}. Context {I : UU}. Definition isdirected (f : I -> X) : UU := ∥ I ∥ × ∏ (i j : I), ∥∑ (k : I), f i ≤ f k × f j ≤ f k∥. Lemma isaprop_isdirected (f : I -> X) : isaprop (isdirected f). Proof. apply isapropdirprod. - apply isapropishinh. - apply impred_isaprop; intro i; apply impred_isaprop; intro j. apply isapropishinh. Qed. Definition directeduntruncated (f : I -> X) (i j : I) : UU := ∑ (k : I), f i ≤ f k × f j ≤ f k. Definition isdirected_inhabited {f : I -> X} : isdirected f -> ∥ I ∥ := pr1. Definition isdirected_compatible {f : I -> X} : isdirected f -> ∏ (i j : I), ∥∑ (k : I), f i ≤ f k × f j ≤ f k∥ := pr2. End directedfamily. (** ** Directed complete posets (dcpos) *) Section dcpo. Definition isdirectedcomplete (X : Poset) : UU := ∏ (I : UU) (f : I -> X), isdirected f -> ∑ (u : X), islub f u. Lemma isaprop_isdirectedcomplete (X : Poset) : isaprop (isdirectedcomplete X). Proof. apply impred_isaprop; intro I. apply impred_isaprop; intro f. apply isapropimpl. apply invproofirrelevance. intros [u p] [v q]. apply total2_paths_equiv. exists (lubsareunique _ p q). apply proofirrelevance. apply isaprop_islub. Qed. Definition dcpo := ∑ (X : Poset), isdirectedcomplete X. Definition dcpoposet : dcpo -> Poset := pr1. Coercion dcpoposet : dcpo >-> Poset. Definition dcpoisdirectedcomplete (D : dcpo) : isdirectedcomplete D := pr2 D. Definition make_dcpo (X : Poset) (i : isdirectedcomplete X) : dcpo := (X,,i). Definition make_dcpo_lub {D : dcpo} {I : UU} {f : I -> D} : isdirected f -> D. Proof. intro isdirec. exact (pr1 (dcpoisdirectedcomplete D I f isdirec)). Defined. Definition make_dcpo_lub_islub {D : dcpo} {I : UU} {f : I -> D} (isdirec : isdirected f) : islub f (make_dcpo_lub isdirec). Proof. exact (pr2 (dcpoisdirectedcomplete D I f isdirec)). Defined. End dcpo. (** ** Morphisms of dcpos *) Section morphismofdcpos. Definition preserveslub {P Q : Poset} (f : P -> Q) {I : UU} (u : I -> P) : UU := ∏ (v : P), islub u v -> islub (f ∘ u) (f v). Lemma isaprop_preserveslub {P Q : Poset} (f : P -> Q) {I : UU} (u : I -> P) : isaprop (preserveslub f u). Proof. apply impred_isaprop; intro v. apply isapropimpl. apply isaprop_islub. Qed. Definition isdcpomorphism {D D' : dcpo} (f : D -> D') := isaposetmorphism f × ∏ (I : UU) (u : I -> D), isdirected u -> preserveslub f u. Lemma isaprop_isdcpomorphism {D D' : dcpo} (f : D -> D') : isaprop (isdcpomorphism f). Proof. apply isapropdirprod. - apply isaprop_isaposetmorphism. - apply impred_isaprop; intro I. apply impred_isaprop; intro u. apply isapropimpl; apply isaprop_preserveslub. Qed. Definition dcpomorphism (D D' : dcpo) := ∑ (f : D -> D'), isdcpomorphism f. Definition dcpomorphism_posetmorphism (D D' : dcpo) : dcpomorphism D D' -> posetmorphism D D'. Proof. intros [f isdcpomor]. exists f. exact (pr1 isdcpomor). Defined. Coercion dcpomorphism_posetmorphism : dcpomorphism >-> posetmorphism. Lemma dcpomorphism_preservesorder {D D' : dcpo} (f : dcpomorphism D D') : isaposetmorphism f. Proof. exact (pr1 (pr2 f)). Qed. Lemma dcpomorphism_preservesdirected {D D' : dcpo} (f : dcpomorphism D D') {I : UU} {u : I -> D} : isdirected u -> isdirected (pr1 f ∘ u). Proof. intro isdirec. split. - exact (isdirected_inhabited isdirec). - intros i j. apply (@factor_through_squash (directeduntruncated u i j)). + apply isapropishinh. + intro direc. apply hinhpr. induction direc as [k ineqs]. split with k. split. * apply dcpomorphism_preservesorder. exact (pr1 ineqs). * apply dcpomorphism_preservesorder. exact (pr2 ineqs). + exact (isdirected_compatible isdirec i j). Qed. Lemma dcpomorphism_preserveslub {D D' : dcpo} (f : dcpomorphism D D') {I : UU} {u : I -> D} : isdirected u -> preserveslub f u. Proof. intro isdirec. apply (pr2 (pr2 f)). exact isdirec. Qed. (* In fact, requiring that a dcpo morphism is a poset morphism is redundant *) Definition isdcpomorphism' {D D' : dcpo} (f : D -> D') := ∏ (I : UU) (u : I -> D), isdirected u -> preserveslub f u. Lemma preservesdirectedlub_isdcpomorphism {D D' : dcpo} (f : D -> D') : isdcpomorphism' f -> isdcpomorphism f. Proof. intro preservesdireclub. split. - intros x y ineq. set (two := coprod unit unit). set (fam := (λ t : two, match t with | inl _ => x | inr _ => y end)). assert (isdirec : isdirected fam). { split. - apply hinhpr. exact (inl tt). - intros i j. apply hinhpr. exists (inr tt). induction i, j. + simpl. exact (ineq,,ineq). + simpl. split. ++ exact ineq. ++ apply isrefl_posetRelation. + simpl. split. ++ apply isrefl_posetRelation. ++ exact ineq. + simpl. split. ++ apply isrefl_posetRelation. ++ apply isrefl_posetRelation. } assert (islubfam : islub fam y). { split. - intro t. induction t. + simpl. exact ineq. + simpl. apply isrefl_posetRelation. - intros d ineqs. exact (ineqs (inr tt)). } set (islubfam' := preservesdireclub two fam isdirec y islubfam). apply (islub_isupperbound (f ∘ fam) islubfam' (inl tt)). - exact preservesdireclub. Qed. Definition make_dcpomorphism {D D' : dcpo} (f : D -> D') (i : isdcpomorphism' f) : dcpomorphism D D'. Proof. exists f. apply preservesdirectedlub_isdcpomorphism. exact i. Defined. (** Constant functions between dcpos are continuous *) Definition const_dcpomor (D E : dcpo) (e : E) : dcpomorphism D E. Proof. use make_dcpomorphism. - exact (λ _, e). - intros I u isdirec v islubv. split. + intro i. simpl. apply isrefl_posetRelation. + intros d' ineqs. apply (@factor_through_squash I). * apply propproperty. * intro i. exact (ineqs i). * exact (isdirected_inhabited isdirec). Defined. End morphismofdcpos. (** ** The morphisms between two dcpos form a dcpo with the pointwise order. *) Section morphismsofdcpos_formdcpo. Definition pointwiseorder (D D' : dcpo) : hrel (dcpomorphism D D'). Proof. intros f g. use make_hProp. - exact (∏ (d : D), f d ≤ g d). - apply impred_isaprop; intro d. apply propproperty. Defined. Lemma ispartialorder_pointwiseorder (D D' : dcpo) : isPartialOrder (pointwiseorder D D'). Proof. split. - split. + intros f g h ineq1 ineq2 d. eapply istrans_posetRelation. ++ use ineq1. ++ use ineq2. + intros f p. apply isrefl_posetRelation. - intros f g ineq1 ineq2. apply total2_paths_equiv. assert (funeq : pr1 f = pr1 g). { use funextfun; intro d. apply isantisymm_posetRelation. - use ineq1. - use ineq2. } exists funeq. apply proofirrelevance, isaprop_isdcpomorphism. Qed. Definition posetofdcpomorphisms (D D' : dcpo) : Poset. Proof. use make_Poset. - use make_hSet. + exact (dcpomorphism D D'). + apply (isofhleveltotal2 2). ++ apply impred_isaset; intro d. apply setproperty. ++ intro f; apply isasetaprop, isaprop_isdcpomorphism. - use make_PartialOrder. + apply pointwiseorder. + apply ispartialorder_pointwiseorder. Defined. Lemma lubpreservesorder {X : Poset} {I : UU} (u v : I -> X) : (∏ (i : I), u i ≤ v i) -> ∏ (lu lv : X), islub u lu -> islub v lv -> lu ≤ lv. Proof. intros ineqs lu lv islubu islubv. eapply islub_isleast. - exact islubu. - intro i. eapply istrans_posetRelation. + exact (ineqs i). + apply (islub_isupperbound v islubv). Qed. (** Given a family of dcpo morphisms from D to D' and a point d : D we have a pointwise family in D' by evaluating each morphism at d. *) Definition pointwisefamily {D D' : dcpo} {I : UU} (F : I -> dcpomorphism D D') : D -> I -> D' := λ (d : D), λ (i : I), (F i) d. Lemma pointwisefamily_isdirected {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') : isdirected F -> ∏ (d : D), isdirected (pointwisefamily F d). Proof. intros isdirec d. split. - exact (isdirected_inhabited isdirec). - intros i j. use factor_through_squash. + exact (directeduntruncated F i j). + apply isapropishinh. + intro direc. apply hinhpr. induction direc as [k ineqs]. exists k. unfold pointwisefamily. induction ineqs as [ineq1 ineq2]. split. * use ineq1. * use ineq2. + apply (isdirected_compatible isdirec). Qed. Definition pointwiselub {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') (isdir : isdirected F) : D -> D'. Proof. intro d. set (ptfamdir := pointwisefamily_isdirected F isdir d). exact (make_dcpo_lub ptfamdir). Defined. Lemma pointwiselub_islubpointwise {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') (isdirec : isdirected F) : ∏ (d : D), islub (pointwisefamily F d) (pointwiselub F isdirec d). Proof. intro d. set (ptfamdir := pointwisefamily_isdirected F isdirec d). exact (make_dcpo_lub_islub ptfamdir). Qed. Lemma pointwiselub_preservesorder {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') (isdirec : isdirected F) : isaposetmorphism (pointwiselub F isdirec). Proof. intros x y ineq. use lubpreservesorder. - exact I. - intro i. apply (F i). exact x. - intro i. apply (F i). exact y. - intro i. simpl. apply dcpomorphism_preservesorder. exact ineq. - simpl. apply pointwiselub_islubpointwise. - simpl. apply pointwiselub_islubpointwise. Qed. Lemma pointwiselub_isdcpomorphism' {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') (isdirec : isdirected F) : isdcpomorphism' (pointwiselub F isdirec). Proof. unfold isdcpomorphism'. intros J v isdirecv. intros w wislub. split. - intro j. apply pointwiselub_preservesorder. apply islub_isupperbound. exact wislub. - intros d' ineqs. eapply islub_isleast. + apply pointwiselub_islubpointwise. + intro i. unfold pointwisefamily. eapply dcpomorphism_preserveslub. * exact isdirecv. * exact wislub. * intro j. eapply istrans_posetRelation. 2: { exact (ineqs j). } apply pointwiselub_islubpointwise. Qed. Lemma pointwiselub_islub {D D' : dcpo} {I : UU} (F : I -> posetofdcpomorphisms D D') (isdirec : isdirected F) : islub F (make_dcpomorphism (pointwiselub F isdirec) (pointwiselub_isdcpomorphism' F isdirec)). Proof. split. - intro i; simpl. intro d; simpl. apply pointwiselub_islubpointwise. - intros h ineqs; simpl. intro d; simpl. apply pointwiselub_islubpointwise. intro i. use (ineqs i). Qed. Lemma islub_islubpointwise {D D' : dcpo} {I : UU} {g : posetofdcpomorphisms D D'} {F : I -> posetofdcpomorphisms D D'} (isdirec : isdirected F) : islub F g -> ∏ (d : D), islub (pointwisefamily F d) (pr1 g d). Proof. intros islubFg d. set (ptlub := make_dcpomorphism (pointwiselub F isdirec) (pointwiselub_isdcpomorphism' F isdirec)). assert (lubeq : g = ptlub). { apply (lubsareunique F islubFg). apply pointwiselub_islub. } rewrite lubeq. apply pointwiselub_islubpointwise. Qed. Lemma posetofdcpomorphisms_isdirectedcomplete (D D' : dcpo) : isdirectedcomplete (posetofdcpomorphisms D D'). Proof. intros I F isdirec. exists (make_dcpomorphism (pointwiselub F isdirec) (pointwiselub_isdcpomorphism' F isdirec)). apply pointwiselub_islub. Qed. Definition dcpoofdcpomorphisms (D D' : dcpo) : dcpo. Proof. eapply make_dcpo. - exact (posetofdcpomorphisms_isdirectedcomplete D D'). Defined. End morphismsofdcpos_formdcpo. (** ** Dcpos with bottom *) Section dcpowithbottom. Definition dcpowithbottom := ∑ (D : dcpo), ∑ (l : D), isMinimal l. Definition dcpowithbottom_dcpo : dcpowithbottom -> dcpo := pr1. Coercion dcpowithbottom_dcpo : dcpowithbottom >-> dcpo. Definition dcpowithbottom_isMinimal (D : dcpowithbottom) := (pr2 (pr2 D)). Definition dcpowithbottom_bottom (D : dcpowithbottom) := pr1 (pr2 D). Definition dcpowithbottom_ofdcpomorphisms (D D' : dcpowithbottom) : dcpowithbottom. Proof. exists (dcpoofdcpomorphisms D D'). set (leastD' := dcpowithbottom_bottom D'). set (l := const_dcpomor D D' leastD'). exists l. intro f. simpl. intro d. apply dcpowithbottom_isMinimal. Defined. End dcpowithbottom. Declare Scope DCPO. Delimit Scope DCPO with DCPO. Local Open Scope DCPO. Notation "A --> B" := (dcpowithbottom_ofdcpomorphisms A B) : DCPO. (** ** The least fixed point *) Section leastfixedpoint. Definition iter {D : dcpowithbottom} (n : nat) (f : D --> D) : D. Proof. induction n as [ | m IH]. - exact (dcpowithbottom_bottom D). - apply f. exact IH. Defined. Lemma iter_preservesorder {D : dcpowithbottom} (f g : D --> D) : (f ≤ g) -> ∏ (n : nat), (iter n f ≤ iter n g). Proof. intros ineq n; induction n as [ | m IH]. - apply isrefl_posetRelation. - simpl. eapply istrans_posetRelation. + apply dcpomorphism_preservesorder. exact IH. + use ineq. Qed. (** Next, we show that each iter n is continuous, but first a small lemma. It could be generalised using monotone nets, c.f. Proposition 2.1.12 in Abramsky's and Jung's chapter "Domain Theory" in "Handbook of Logic in Computer Science". We're saying that: ⊔ f^(n+1)(⊥) = ⊔ g(⊔ f^n(⊥)), where f,g are in the family F. One inequality is easy; the other crucially relies on the fact that F is directed. *) Lemma doublelubdirected {D : dcpowithbottom} {I : UU} (F : I -> D -->D) (isdirec : isdirected F) (n : nat) (u u' : D) : islub (λ i : I, iter n (F i)) u' -> islub (λ j : I, (pr1) (F j) u') u -> islub (λ i : I, iter (S n) (F i)) u. Proof. intros islubu' islubu. split. - intro i. simpl. eapply istrans_posetRelation. + apply dcpomorphism_preservesorder. apply (islub_isupperbound _ islubu'). + apply (islub_isupperbound _ islubu). - intros d ineqs. apply (islub_isleast _ islubu). intro i. set (fam := λ i : I, iter n (F i)). assert (isdirec' : isdirected (λ i : I, iter n (F i))). { split. - exact (isdirected_inhabited isdirec). - intros i1 i2. use factor_through_squash. + exact (directeduntruncated F i1 i2). + apply isapropishinh. + intro direc. apply hinhpr. induction direc as [k ineqs']. exists k. split. * apply iter_preservesorder. exact (pr1 ineqs'). * apply iter_preservesorder. exact (pr2 ineqs'). + apply (isdirected_compatible isdirec). } eapply dcpomorphism_preserveslub. + exact isdirec'. + exact islubu'. + intro j. simpl. use factor_through_squash. * exact (directeduntruncated F i j). * apply propproperty. * intro direc. induction direc as [k ineqs']. eapply istrans_posetRelation. -- apply dcpomorphism_preservesorder. apply iter_preservesorder. apply (pr2 ineqs'). -- eapply istrans_posetRelation. ++ use (pr1 ineqs'). ++ exact (ineqs k). * apply (isdirected_compatible isdirec). Qed. Lemma iter_isdcpomorphism' (D : dcpowithbottom) : ∏ (n : nat), isdcpomorphism' (@iter D n). Proof. intros n I F isdirec g islubg. induction n as [| m IH]. - split. + intro i. simpl. apply dcpowithbottom_isMinimal. + intros y ineqs. apply dcpowithbottom_isMinimal. - simpl. eapply doublelubdirected. + exact isdirec. + exact IH. + set (islub' := pointwiselub_islub F isdirec). set (eq := lubsareunique _ islubg islub'). rewrite eq; cbn. apply pointwiselub_islubpointwise. Qed. (** Iter as dcpo morphism *) Definition iter' {D : dcpowithbottom} (n : nat) : (D --> D) --> D. Proof. eapply make_dcpomorphism. exact (iter_isdcpomorphism' D n). Defined. Lemma iter'_isomegachain (D : dcpowithbottom) : ∏ (n : nat), (@iter' D n ≤ @iter' D (S n)). Proof. induction n as [ | m IH]. - simpl. intro f. apply dcpowithbottom_isMinimal. - simpl. intro f. apply dcpomorphism_preservesorder. use IH. Qed. Lemma iter'_increases (D : dcpowithbottom) : ∏ (n m : nat), (n ≤ m)%nat -> (@iter' D n ≤ @iter' D m). Proof. intros n m ineq. induction m as [ | m' IH]. - set (nis0 := natleh0tois0 ineq). rewrite nis0. apply isrefl_posetRelation. - set (cases := natlehchoice _ _ ineq). induction cases as [less | equal]. + eapply istrans_posetRelation. * apply IH. apply less. * apply iter'_isomegachain. + rewrite equal. apply isrefl_posetRelation. Qed. Lemma iter'_isdirected (D : dcpowithbottom) : isdirected (@iter' D). Proof. split. - apply hinhpr. exact O. - intros n m. apply hinhpr. exists (n + m). split. + apply iter'_increases. apply natlehnplusnm. + apply iter'_increases, natlehmplusnm. Qed. Definition leastfixedpoint {D : dcpowithbottom} : (D --> D) --> D. Proof. use make_dcpomorphism. - eapply pointwiselub. apply iter'_isdirected. - apply pointwiselub_isdcpomorphism'. Defined. Notation "'μ'" := leastfixedpoint : DCPO. Lemma leastfixedpoint_isfixedpoint {D : dcpowithbottom} : ∏ (f : D --> D), (pr1 f) (pr1 μ f) = pr1 μ f. Proof. intro f. unfold leastfixedpoint; cbn. apply isantisymm_posetRelation. - set (isdirec := pointwisefamily_isdirected iter' (iter'_isdirected D) f). eapply dcpomorphism_preserveslub. + exact isdirec. + apply pointwiselub_islubpointwise. + intro n. simpl. eapply (istrans_posetRelation _ _ (pointwisefamily iter' f (S n)) _). * apply isrefl_posetRelation. * apply pointwiselub_islubpointwise. - eapply (islub_isleast). + apply pointwiselub_islubpointwise. + intro n. induction n as [ | m IH]. * apply dcpowithbottom_isMinimal. * unfold pointwisefamily; simpl. apply dcpomorphism_preservesorder. eapply istrans_posetRelation. -- use iter'_increases. ++ exact (S m). ++ apply natlehnsn. -- exact (islub_isupperbound _ (pointwiselub_islubpointwise iter' (iter'_isdirected D) f) (S m)). Qed. Lemma leastfixedpoint_isleast {D : dcpowithbottom} (f : D --> D) : ∏ (d : D), ((pr1 f) d ≤ d) -> (pr1 μ f ≤ d). Proof. intros d ineq. eapply islub_isleast. - apply pointwiselub_islubpointwise. - intro n; induction n as [ | m IH]. + apply dcpowithbottom_isMinimal. + unfold pointwisefamily. simpl. eapply istrans_posetRelation. * apply dcpomorphism_preservesorder. exact IH. * exact ineq. Qed. Close Scope DCPO. End leastfixedpoint. UniMath-20231010/UniMath/OrderTheory/DCPOs/AlternativeDefinitions/FixedPointTheorems.v000066400000000000000000001466631451125700300304730ustar00rootroot00000000000000 (** * Fixed-point theorems on posets This file aims to state and develop various fixed-point theorems on posets; in particular, the classical Tarski, Bourbaki-Witt, and Knaster–Tarski fixed-point theorems and their variants, especially constructively provable ones. In particular, it aims to formalise some of the results of Pataraia, Dacar, Bauer, and Lumsdaine, given in https://arxiv.org/abs/1201.0340 . Note: There is some duplication with material on posets elsewhere in the library, e.g. [Algebra.Dcpo] and [Combinatorics.WellOrderedSets], which should ideally be refactored. (Indeed, there is some duplication of material also between those files.) **************************************************************************** Note: a newer and different implementation of DCPOs and fixed point theorems can be found in OrderTheory.DCPOs. **************************************************************************** *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.WellOrderedSets. Require Import UniMath.OrderTheory.DCPOs.AlternativeDefinitions.Dcpo. Local Open Scope poset. (* for ≤, < *) Local Open Scope logic. (* for logic in hProp *) Local Open Scope subtype. (** ** Overview *) Section Overview. (** The following are the main results of the file (stated for now with some black boxes, for concepts not yet defined). In [Section Check_Overview] at the end of the file, we confirm that these statements have been proven. *) Context (is_complete : Poset -> UU) (is_directed_complete : Poset -> UU) (is_chain_complete : Poset -> UU) (Progressive_map : forall P:Poset, hsubtype (P -> P)) (Postfixedpoint : forall P:Poset, (P -> P) -> hsubtype P) (Fixedpoint : forall P:Poset, (P -> P) -> hsubtype P). Arguments Postfixedpoint {_} _. Arguments Fixedpoint {_} _. (** The master form of the Tarski/Knaster fixed-point theorems: the fixed points of a monotone map on a complete poset are themselves complete. *) Definition Tarski_fixpoint_theorem_statement := forall (P:Poset) (P_complete : is_complete P) (f : posetmorphism P P), is_complete (Fixedpoint f : Subposet P). (** A constructive fixed-point theorem, due to Pataraia. *) Definition fixpoint_for_monotone_on_dcpo_statement := forall (P : Poset) (P_dir: is_directed_complete P) (f : posetmorphism P P) (x : Postfixedpoint f), ∑ y : Fixedpoint f, pr1 x ≤ pr1 y. (** Classical theorem, usually attrib. Bourbaki (1949) and Witt (1951). *) Definition Bourbaki_Witt_fixpoint_theorem_statement := LEM -> forall (P : Poset) (_ : is_chain_complete P) (f : Progressive_map P), Fixedpoint (pr1 f). End Overview. (** ** Background material Material not really belonging to this file. All could (?should) eventually be upstreamed, and (in a few cases) unified with overlapping material upstream. *) Section Auxiliary. (** *** Partial orders *) Definition lt_to_nleq {P : Poset} {x y : P} : x < y ⇒ ¬ (y ≤ x). Proof. intros [leq_xy neq_xy] leq_yx. apply neq_xy. apply isantisymm_posetRelation; assumption. Defined. Definition isrefl'_posetRelation {P : Poset} {x y : P} : x = y ⇒ x ≤ y. Proof. intros e; destruct e. apply isrefl_posetRelation. Defined. (* [isaposetmorphism] is defined as in [Foundations.Sets], but (a) isn’t an hProp, and (b) lacks access function. *) Definition isaposetmorphism_hProp {P Q : Poset} (f : P -> Q) : hProp := ∀ x x' : P, x ≤ x' ⇒ f x ≤ f x'. Definition posetmorphism_property {P Q} (f : posetmorphism P Q) : isaposetmorphism f := pr2 f. Lemma isaposetmorphism_idfun {P : Poset} : isaposetmorphism (idfun P). Proof. intros ? ? ?; assumption. Defined. Lemma isaposetmorphism_compose {P P' P'' : Poset} {f : P -> P'} (f_monot : isaposetmorphism f) {g : P' -> P''} (g_monot : isaposetmorphism g) : isaposetmorphism (g ∘ f). Proof. intros x y le_xy. apply g_monot, f_monot, le_xy. Defined. (** *** HProp logic *) (* TODO: look for naming convention for similar lemmas *) Definition hdisj_monot {p q p' q'} : (p ⇒ p') ⇒ (q ⇒ q') ⇒ (p ∨ q ⇒ p' ∨ q'). Proof. intros ? ?. apply hconjtohdisj; split; intro; auto using hdisj_in1, hdisj_in2. Defined. (** This order of arguments is often more convenient to use than the original [hdisj_monot] *) (* TODO: consider naming *) Definition hdisj_monot' {p q p' q'} : (p ∨ q) ⇒ (p ⇒ p') ⇒ (q ⇒ q') ⇒ (p' ∨ q'). Proof. intros ? ? ?. eapply hdisj_monot; eassumption. Defined. (** This order of arguments is often more convenient to use than the original [hconjtohdisj] *) (* TODO: consider naming *) Definition hconjtohdisj' {p q r} : (p ∨ q) ⇒ (p ⇒ r) ⇒ (q ⇒ r) ⇒ r. Proof. intros ? ? ?. apply (hconjtohdisj p q r); try split; assumption. Defined. (* TODO: look for naming convention for similar lemmas *) Definition hdisj_comm {p q} : (p ∨ q) ⇒ (q ∨ p). Proof. apply hconjtohdisj; split; intro; auto using hdisj_in1, hdisj_in2. Defined. (* TODO: consider naming *) Definition exists_monotone {X:UU} (A B : X -> UU) : (forall x, A x -> B x) -> (∃ x, A x) -> ∃ x, B x. Proof. intros le_A_B. apply hinhfun, totalfun, le_A_B. Defined. (** *** Hsubtypes *) (* TODO: upstream, and factor out rest of [subtype_containment_isPartialOrder] too? *) Definition istrans_subtype_containment {X} {A B C : hsubtype X} (leq_AB : A ⊆ B) (leq_BC : B ⊆ C) : A ⊆ C. Proof. cbn in *; auto. Defined. (* A restricted-quantifier version of [neghexisttoforallneg] *) Definition negexists_to_forallneg_restricted {X:UU} {A B : hsubtype X} : ¬ (∃ x, A x ∧ B x) ⇒ (∀ x, A x ⇒ ¬ B x). Proof. intros H_nex x A_x B_x. use H_nex. apply hinhpr. exists x. split; assumption. Defined. (* A restricted-quantifier version of [negforall_to_existsneg] *) Definition negforall_to_existsneg_restricted (H_LEM : LEM) {X:UU} {A B : hsubtype X} : ¬ (∀ x, A x ⇒ B x) ⇒ ∃ x, A x ∧ ¬ B x. Proof. intros H_forall. apply (proof_by_contradiction H_LEM). intros H_nex. use H_forall. intros x A_x. apply (proof_by_contradiction H_LEM). use (negexists_to_forallneg_restricted H_nex); assumption. Defined. Definition subtype_binaryintersection {X} (A B : hsubtype X) : hsubtype X := fun x => A x ∧ B x. Notation "A ∩ B" := (subtype_binaryintersection A B) (at level 40, left associativity) : subtype. (* precedence tighter than "⊆", also than "-" [subtype_difference]. *) (* in agda-input method, type \cap *) Definition subtype_binaryintersection_leq1 {X} (A B : hsubtype X) : A ∩ B ⊆ A := fun x => pr1. Definition subtype_binaryintersection_leq2 {X} (A B : hsubtype X) : A ∩ B ⊆ B := fun x => pr2. (* TODO: upstream; rename to eg [binaryintersection_equiv]? *) Definition hconj_equiv {X:UU} {A A' B B' : hsubtype X} (e_A : A ≡ A') (e_B : B ≡ B') : (A ∩ B) ≡ (A' ∩ B'). Proof. intros x; split; intros [? ?]; split; try apply e_A; try apply e_B; assumption. Defined. Definition subtype_binaryintersection_univ {X} (A B C : hsubtype X) : C ⊆ A ∩ B <-> C ⊆ A ∧ C ⊆ B. Proof. split. - intros C_AB. split; apply (istrans_subtype_containment C_AB). + apply subtype_binaryintersection_leq1. + apply subtype_binaryintersection_leq2. - cbn. intros [? ?]; split; auto. Defined. (* *** Images of functions, as hsubtypes *) (* TODO: surely this must be in the library somewhere, along with its essential properties?? *) Definition image {X Y : UU} (f : X -> Y) : hsubtype Y := fun y => ∥ hfiber f y ∥. Definition value_in_image {X Y : UU} (f : X -> Y) (x : X) : image f (f x) := hinhpr (x ,, idpath _). Definition to_image {X Y : UU} (f : X -> Y) (x : X) : image f := (f x,, value_in_image f x). (** See [image_univ] below for a version that plays better with [apply]. *) Definition image_univ {X Y : UU} (f : X -> Y) (A : hsubtype Y ) : (∀ x:X, A (f x)) <-> (image f ⊆ A). Proof. split. - intros H_A y Hy. refine (factor_through_squash_hProp _ _ Hy); intros [x e_xy]; destruct e_xy. use H_A. - intros H_A x. use H_A. apply value_in_image. Defined. (** Alias of [image_univ] using explicit “forall” instead of “⊆” or “∀”, for easier use with the [apply] tactic. *) Definition image_univ' {X Y : UU} (f : X -> Y) (A : hsubtype Y ) : (forall x:X, A (f x)) <-> (forall y:Y, (image f y) -> A y). Proof. apply image_univ. Defined. Definition image_carrier_univ {X Y : UU} (f : X -> Y) (A : hsubtype Y ) : (∀ x:X, A (f x)) <-> (∀ y : image f, A (pr1 y)). Proof. split. - intros H [y im_y]. eapply image_univ'; eassumption. - intros H; cbn. apply image_univ'. intros y im_y. exact (H (y,,im_y)). Defined. (** Like [image_univ'], alias using explicit “forall” instead of “∀”, for easier use with the [apply] tactic. *) Definition image_carrier_univ' {X Y : UU} (f : X -> Y) (A : hsubtype Y ) : (forall x:X, A (f x)) <-> (forall y : image f, A (pr1 y)). Proof. apply image_carrier_univ. Defined. End Auxiliary. Notation "A ∩ B" := (subtype_binaryintersection A B) (at level 40, left associativity) : subtype. (* precedence tighter than "⊆", also than "-" [subtype_difference]. *) (* in agda-input method, type \cap *) Notation "A ∪ B" := (subtype_binaryunion A B) (at level 40, left associativity) : subtype. (* precedence tighter than "⊆", also than "-" [subtype_difference]. *) (* in agda-input method, type \cup or ∪ *) (** ** Completeness properties *) (** We use the treatment of upper bounds from [Algebra.Dcpo], but give a slightly different treatment of _least_ upper bounds, factoring out the general definitions of “greatest/least elements” and “upper/lower bounds”, both of a family, or satisfying some predicate. *) Section LowerBounds. (* NOTE: this should be kept in sync with [Section UpperBounds] below. *) Context {P : Poset}. Definition islowerbound {I} (p : I -> P) (x : P) : hProp := ∀ i : I, x ≤ p i. Definition islowerbound_subtype (A : hsubtype P) (x : P) : hProp := islowerbound (pr1carrier A) x. Definition islowerbound_subtype_equiv {A B : hsubtype P} : (A ≡ B) -> islowerbound_subtype A ≡ islowerbound_subtype B. Proof. intros e_A_B x; split; intros x_lb [y H_y]; refine (x_lb (_,,_)); apply e_A_B; assumption. Defined. (* NOTE: For an alternative approach to [is_lower_bound_subfamily] and [image_same_lower_bounds], see analogues for upper bounds below. *) Definition is_lower_bound_subfamily {I} (f : I -> P) {J} (g : J -> P) (ff : forall j, (image f) (g j)) {x} (x_lb : islowerbound f x) : islowerbound g x. Proof. intros j. refine (factor_through_squash_hProp _ _ (ff j)). intros [i e]; destruct e. use x_lb. Defined. Definition image_same_lower_bounds {I} (f : I -> P) {x : P} : islowerbound f x <-> islowerbound_subtype (image f) x. Proof. apply (image_carrier_univ' f (fun y => _ ≤ y)). Defined. End LowerBounds. Section UpperBounds. (* NOTE: this should be kept in sync with [Section LowerBounds] above. *) (* TODO: it would be natural to just refactor [isupperbound] in [Algebra.Dcpo] as an hProp from the start, using [∀] and so on. However, that turns out to slightly interfere with the use of [apply] on lemmas in that file, especially bidirectional such as [pointwiselub_islubpointwise]. Is that cosmetic cost worth paying? Or can it be avoided? *) Context {P : Poset}. Definition isupperbound_hprop {I} (p : I -> P) (x:P) : hProp := make_hProp _ (isaprop_isupperbound p x). Definition isupperbound_subtype (A : hsubtype P) (x : P) : hProp := isupperbound_hprop (pr1carrier A) x. Definition isupperbound_subtype_equiv {A B : hsubtype P} : (A ≡ B) -> isupperbound_subtype A ≡ isupperbound_subtype B. Proof. intros e_A_B x; split; intros x_ub [y H_y]; refine (x_ub (_,,_)); apply e_A_B; assumption. Defined. (* NOTE: An aternative approach alternative to comparing the upper bounds of families and their images: factor a bit. Show that for two families, if f ≤ image g, then every upper bound of g is an upper bound for f. Thence: the non-image version. Thence: image has same upper bounds, so same least upper bound. *) Definition is_upper_bound_subfamily {I} (f : I -> P) {J} (g : J -> P) (ff : forall j, (image f) (g j)) {x} (x_ub : isupperbound f x) : isupperbound g x. Proof. intros j. refine (factor_through_squash_hProp _ _ (ff j)). intros [i e]; destruct e. apply x_ub. Defined. Definition image_same_upper_bounds {I} (f : I -> P) {x : P} : isupperbound f x <-> isupperbound_subtype (image f) x. Proof. apply (image_carrier_univ' f (fun y => y ≤ _)). Defined. End UpperBounds. Section Least. (* NOTE: this should generally be kept in sync with [Section Greatest] below. *) Context {P : Poset}. Definition least_of_family {I} (p : I -> P) := ∑ i : I, islowerbound p (p i). Definition least_of_family_index {I} {p : I -> P} : least_of_family p -> I := pr1. (* Would be nice to make [least_of_family_index] a coercion, but can’t since its target is an arbitrary type. The best we can do instead is [realise_least_of_family]: *) Coercion realise_least_of_family {I} (p : I -> P) : least_of_family p -> P := fun ih => p (pr1 ih). Definition least_is_least {I} (p : I -> P) (x : least_of_family p) : islowerbound p x := pr2 x. Definition least_suchthat (A : P -> UU) : UU := least_of_family (pr1 : (∑ x:P, A x) -> P). Identity Coercion id_least_suchthat : least_suchthat >-> least_of_family. Definition least_suchthat_satisfies {A : P -> UU} (x : least_suchthat A) : A x := pr2 (least_of_family_index x). Definition least_suchthat_is_least {A : P -> UU} (x : least_suchthat A) : ∏ y, A y -> x ≤ y. Proof. intros y A_y. exact (least_is_least _ x (_,,A_y)). Defined. (** It’s useful to define [least_suchthat] as above, for interaction with [least_of_family], etc; but also helpful to have a standalone predicate version. *) (* TODO: is that really useful? could it be better to refactor [least_suchthat] as [carrier (is_least_suchthat …)]? *) Definition is_least_suchthat (A : P -> hProp) (x : P) : hProp := (A x) ∧ (islowerbound_subtype A x). Definition least_suchthat_property {A : P -> hProp} (x : least_suchthat A) : is_least_suchthat A x. Proof. split. - apply @least_suchthat_satisfies. - apply least_is_least. Defined. Definition make_least_suchthat {A : P -> hProp} (x : P) (x_least : is_least_suchthat A x) : least_suchthat A. Proof. use tpair. { exists x. apply x_least. } apply x_least. Defined. End Least. Section Greatest. (* NOTE: this should generally be kept in sync with [Section Least] above. *) Context {P : Poset}. Definition greatest_of_family {I} (p : I -> P) := ∑ i : I, isupperbound p (p i). Definition greatest_of_family_index {I} {p : I -> P} : greatest_of_family p -> I := pr1. (* Would be nice to make [greatest_of_family_index] a coercion, but can’t since its target is an arbitrary type. The best we can do instead is [realise_greatest_of_family]: *) Coercion realise_greatest_of_family {I} (p : I -> P) : greatest_of_family p -> P := fun ih => p (pr1 ih). Definition greatest_is_greatest {I} (p : I -> P) (x : greatest_of_family p) : isupperbound p x := pr2 x. Definition greatest_suchthat (A : P -> UU) : UU := greatest_of_family (pr1 : (∑ x:P, A x) -> P). Identity Coercion id_greatest_suchthat : greatest_suchthat >-> greatest_of_family. Definition greatest_suchthat_satisfies {A : P -> UU} (x : greatest_suchthat A) : A x := pr2 (greatest_of_family_index x). Definition greatest_suchthat_is_greatest {A : P -> UU} (x : greatest_suchthat A) : ∏ y, A y -> y ≤ x. Proof. intros y A_y. exact (greatest_is_greatest _ x (_,,A_y)). Defined. (** It’s useful to define [greatest_suchthat] as above, for interaction with [greatest_of_family], etc; but also helpful to have a standalone predicate version. *) (* TODO: is that really useful? could it be better to refactor [greatest_suchthat] as [carrier (is_greatest_suchthat …)]? *) Definition is_greatest_suchthat (A : P -> hProp) (x : P) : hProp := (A x) ∧ (isupperbound_subtype A x). Definition greatest_suchthat_property {A : P -> hProp} (x : greatest_suchthat A) : is_greatest_suchthat A x. Proof. split. - apply @greatest_suchthat_satisfies. - apply greatest_is_greatest. Defined. Definition make_greatest_suchthat {A : P -> hProp} (x : P) (x_greatest : is_greatest_suchthat A x) : greatest_suchthat A. Proof. use tpair. { exists x. apply x_greatest. } apply x_greatest. Defined. End Greatest. Section LeastUpperBounds. Context {P : Poset}. Definition least_upper_bound {I} (p : I -> P) := least_suchthat (isupperbound_hprop p). Identity Coercion id_least_upper_bound : least_upper_bound >-> least_suchthat. Definition least_upper_bound_is_upper_bound {I} {p : I -> P} (x : least_upper_bound p) : isupperbound p x := least_suchthat_satisfies x. (** It’s useful to define [least_upper_bound] as above, for interaction with [upper_bound], etc; but also helpful to have a standalone predicate version. *) Definition is_least_upper_bound {I} (p : I -> P) (x : P) : hProp := is_least_suchthat (isupperbound_hprop p) x. Definition make_least_upper_bound {I} {p : I -> P} (x:P) (x_lub : is_least_upper_bound p x) : least_upper_bound p := make_least_suchthat x x_lub. Definition least_upper_bound_property {I} {p : I -> P} (x : least_upper_bound p) : is_least_upper_bound p x := least_suchthat_property x. (** The universal property of the least upper bound *) Definition least_upper_bound_univ {I} {p : I -> P} (x : least_upper_bound p) (x' : P) : x ≤ x' <-> isupperbound p x'. Proof. split. - intros xx' i. eapply istrans_posetRelation; try eassumption. apply least_upper_bound_is_upper_bound. - intros H. refine (least_is_least _ x (_,,H)). Defined. (** Specialisation of the above functions to least upper bounds of _subtypes_ — a common use-case, and the functions are often easier to use in this form. *) Definition is_least_upper_bound_subtype (A : hsubtype P) (x : P) : hProp := is_least_upper_bound (pr1carrier A) x. Definition least_upper_bound_subtype (A : hsubtype P) : UU := least_upper_bound (pr1carrier A). Identity Coercion id_least_upper_bound_subtype : least_upper_bound_subtype >-> least_upper_bound. Definition least_upper_bound_subtype_is_upper_bound {A : hsubtype P} (x : least_upper_bound_subtype A) {y : P} (A_y : A y) : y ≤ x := least_upper_bound_is_upper_bound x (y,,A_y). Definition least_upper_bound_subtype_univ {A : hsubtype P} (x : least_upper_bound (pr1carrier A)) (x' : P) : x ≤ x' <-> (forall y, A y -> y ≤ x'). Proof. split. - intros H y A_y. refine (pr1 (least_upper_bound_univ x x') H (_,,_)); assumption. - intros H. apply least_upper_bound_univ. intros [y A_y]; apply H; assumption. Defined. (** Comparison of least upper bounds between families and their images *) Definition is_least_upper_bound_image {I} (f : I -> P) {x : P} : is_least_upper_bound f x <-> is_least_upper_bound (pr1carrier (image f)) x. Proof. revert x. apply hconj_equiv. - use image_same_upper_bounds. - apply islowerbound_subtype_equiv. use image_same_upper_bounds. Defined. (* TODO: upgrade this to an equivalence? easiest if done once refactoring [least_upper_bound] as [carrier is_least_upper_bound]. *) Definition least_upper_bound_image {I} (f : I -> P) : least_upper_bound f <-> least_upper_bound (pr1carrier (image f)). Proof. split; intros x; apply (make_least_upper_bound x); apply is_least_upper_bound_image, least_upper_bound_property. Defined. (* A useful miscellaneous lemma *) Lemma greatest_if_contains_sup (A : hsubtype P) (x : P) : A x -> is_least_upper_bound_subtype A x -> is_greatest_suchthat A x. Proof. intros A_x x_lub. split. - assumption. - apply (pr1 x_lub). Defined. End LeastUpperBounds. (* TODO: give [Section GreatestLowerBounds] dual to the above section! *) Section Chains. Definition comparable {P : Poset} (x y : P) : hProp := (x ≤ y) ∨ (y ≤ x). Definition is_chain {P : Poset} {I} (p : I -> P) : hProp := ∀ i j : I, comparable (p i) (p j). Definition Chain (P : Poset) : UU := ∑ (I : UU), ∑ (p : I -> P), is_chain p. Coercion chain_index {P} (C : Chain P) : UU := pr1 C. Definition chain_family {P} (C : Chain P) : C -> P := pr1 (pr2 C). Coercion chain_family : Chain >-> Funclass. Definition chain_property {P} (C : Chain P) : is_chain C := pr2 (pr2 C). Definition fmap_is_chain {P Q} (f : posetmorphism P Q) {I : UU} (p : I -> P) : is_chain p -> is_chain (f ∘ p). Proof. intros p_chain x y. apply (hdisj_monot' (p_chain x y)); intro; apply posetmorphism_property; assumption. Defined. Definition fmap_chain {P Q} (f : posetmorphism P Q) : Chain P -> Chain Q. Proof. apply funfibtototal; intros I. use bandfmap. - apply (fun C => f ∘ C). - apply fmap_is_chain. Defined. Definition Chain_hsubtype (P : Poset) : UU := ∑ A : hsubtype P, is_chain (pr1carrier A). Coercion pr1_Chain_hsubtype {P} : Chain_hsubtype P -> hsubtype P := pr1. Coercion Chain_of_Chain_hsubtype (P : Poset) : Chain_hsubtype P -> Chain P. Proof. intros C. exact (carrier C,, (pr1carrier C,, pr2 C)). Defined. Definition image_is_chain {P:Poset} {I:UU} (p : I -> P) : is_chain p -> is_chain (pr1carrier (image p)). Proof. intros p_chain. unfold is_chain. apply (image_carrier_univ p (fun x => ∀ j, comparable x _)); intros i. apply (image_carrier_univ p); intros j. use p_chain. Defined. Definition image_chain {P:Poset} : Chain P -> Chain_hsubtype P. Proof. intros p. exists (image p). apply image_is_chain, chain_property. Defined. End Chains. Section Directed. Definition Directed_family (P : Poset) : UU := ∑ (I : UU), ∑ (p : I -> P), isdirected p. Coercion directed_index {P} (C : Directed_family P) : UU := pr1 C. Definition directed_family {P} (C : Directed_family P) : C -> P := pr1 (pr2 C). Coercion directed_family : Directed_family >-> Funclass. Definition directed_property {P} (C : Directed_family P) : isdirected C := pr2 (pr2 C). (* TODO: add similar builder function for chains *) Definition make_directed {P:Poset} {I} {p : I -> P} (p_directed : isdirected p) : Directed_family P := (I,,(p,,p_directed)). Definition fmap_is_directed {P Q} (f : posetmorphism P Q) {I : UU} (p : I -> P) : isdirected p -> isdirected (f ∘ p). Proof. intros p_directed; split. - eapply isdirected_inhabited, p_directed. - intros i j. eapply exists_monotone. 2: { exact (isdirected_compatible p_directed i j). } intros x [le_i_x le_j_x]. split; apply posetmorphism_property; assumption. Defined. Definition fmap_directed {P Q} (f : posetmorphism P Q) : Directed_family P -> Directed_family Q. Proof. apply funfibtototal; intros I. use bandfmap. - apply (fun C => f ∘ C). - apply fmap_is_directed. Defined. Definition Directed_hsubtype (P : Poset) : UU := ∑ A : hsubtype P, isdirected (pr1carrier A). Coercion pr1_Directed_hsubtype {P} : Directed_hsubtype P -> hsubtype P := pr1. Coercion Directed_of_Directed_hsubtype (P : Poset) : Directed_hsubtype P -> Directed_family P. Proof. intros C. exact (carrier C,, (pr1carrier C,, pr2 C)). Defined. Definition image_is_directed {P:Poset} {I:UU} (p : I -> P) : isdirected p -> isdirected (pr1carrier (image p)). Proof. intros p_directed. split. - apply (squash_to_hProp (isdirected_inhabited p_directed)). intros i; apply hinhpr. apply to_image; assumption. - use (pr1 (image_carrier_univ' p (fun x => ∀ j, ∃ k, x ≤ _ ∧ _))). intros i. use (pr1 (image_carrier_univ' p (fun y => ∃ k, _ ∧ y ≤ _))); intros j. apply (squash_to_hProp (isdirected_compatible p_directed i j)). intros [k [le_ik le_jk]]. apply hinhpr. exists (to_image _ k). split; assumption. Defined. Definition image_directed {P:Poset} : Directed_family P -> Directed_hsubtype P. Proof. intros p. exists (image p). apply image_is_directed, directed_property. Defined. End Directed. Section Completeness. (* TODO: show that completeness is a property, once we’ve shown above that least upper bounds are unique. *) Definition is_complete (P : Poset) : UU := ∏ A : hsubtype P, least_upper_bound (pr1carrier A). (** [is_complete] is defined just in terms of hsubtypes, to agree with the classical definition and keep its quantification “small”. However, it implies completeness for arbitrarily families. *) (* TODO: consider naming! *) Definition family_lub {P:Poset} (P_complete : is_complete P) {I:UU} (f : I -> P) : least_upper_bound f. Proof. apply least_upper_bound_image, P_complete. Defined. Definition is_chain_complete (P : Poset) : UU := ∏ C : Chain_hsubtype P, least_upper_bound_subtype C. (** Like [is_complete], [is_chain_complete] is defined just in terms of hsubtype-chains, to keep quantification small. However, it implies least upper bounds for arbitarily-indexed chains. *) Definition chain_lub {P : Poset} (P_CC : is_chain_complete P) (p : Chain P) : least_upper_bound p. Proof. apply least_upper_bound_image. exact (P_CC (image_chain p)). Defined. (** Version with [is_chain] split out, for easier application *) Definition chain_lub' {P : Poset} (P_CC : is_chain_complete P) {I:UU} (p:I->P) : is_chain p -> least_upper_bound p. Proof. intros p_chain. exact (chain_lub P_CC (I,,(p,,p_chain))). Defined. Definition is_directed_complete (P : Poset) : UU := ∏ A : Directed_hsubtype P, least_upper_bound (directed_family A). (** Like [is_complete], [is_directed_complete] is defined just in terms of directed subtypes, to keep quantification small. However, it implies least upper bounds for arbitary directed families. *) Definition directed_lub {P : Poset} (P_DC : is_directed_complete P) (p : Directed_family P) : least_upper_bound p. Proof. apply least_upper_bound_image. exact (P_DC (image_directed p)). Defined. Definition isdirected_lub {P : Poset} (P_DC : is_directed_complete P) {I} (p : I -> P) (p_directed : isdirected p) : least_upper_bound p. Proof. exact (directed_lub P_DC (make_directed p_directed)). Defined. (* TODO: unify this treatment of directed completeness with that given in [Algebra.Dcpo] *) End Completeness. (** ** Upper bounds, completeness, etc in sub-posets *) Section Subposets. (* TODO: upstream to [MoreFoundations.Subposets]? *) Definition subposet_incl {P : Poset} {A : Subposet' P} : posetmorphism A P := pr1 (pr2 A). Definition is_upper_bound_in_subposet {P : Poset} {A : Subposet P} {I} {p : I -> A} {x : A} : isupperbound (subposet_incl ∘ p) (subposet_incl x) <-> isupperbound p x. Proof. split; auto. Defined. (* TODO: unsure which arguments should be implicit. Revisit this after some use downstream! *) (** Given a chain in a sub-poset with a least upper bound in the ambient poset, if the l.u.b. lies in the sub-poset, then it’s an l.u.b. there. *) Definition is_least_upper_bound_in_subposet {P : Poset} {A : Subposet P} {I} {p : I -> A} {x : A} (x_lub : is_least_upper_bound (subposet_incl ∘ p) (subposet_incl x)) : is_least_upper_bound p x. Proof. split. - apply is_upper_bound_in_subposet, x_lub. - intros [x' x'_ub]. apply (least_upper_bound_univ (make_least_upper_bound _ x_lub)). apply is_upper_bound_in_subposet; assumption. Defined. Definition least_upper_bound_in_subposet {P : Poset} {A : Subposet P} {I} {p : I -> A} (x : least_upper_bound (pr1 ∘ p)) (x_A : A x) : least_upper_bound p. Proof. use make_least_upper_bound. { exists x. apply x_A. } apply is_least_upper_bound_in_subposet, least_upper_bound_property. Defined. Definition is_chain_in_subposet {P : Poset} {A : Subposet P} {I : Type} (p : I -> A) : is_chain p <-> is_chain (subposet_incl ∘ p). Proof. split; auto. Defined. (* This lemma can be given in several alternative forms, e.g. in terms of the canonical given lubs, or arbitrary lubs; and in terms of chains in [A], or chains in [P] satisfying [A]; and in terms of general chains, or subtype-chains. TODO: once it’s in use, reconsider which form might be best. *) Definition is_chain_complete_subposet {P : Poset} (P_CC : is_chain_complete P) {A : Subposet P} (A_chain_closed : forall C : Chain_hsubtype A, A (chain_lub P_CC (fmap_chain subposet_incl C))) : is_chain_complete A. Proof. intros C. use make_least_upper_bound. { exists (chain_lub P_CC (fmap_chain subposet_incl C)). apply A_chain_closed. } apply is_least_upper_bound_in_subposet. apply least_upper_bound_property. Defined. (* TODO: add similar treatment of directed-completeness in subsets. *) End Subposets. (** ** Function posets Products of posets; posets of (classes of) functions *) Section Function_Posets. (** The most general poset of functions is just the product of a family of posets. We set this up first, and then give other posets of functions (e.g. the poset of poset maps) as subposets of this general one. *) (* TODO: possibly some examples upstream could eventually be unified with this, e.g. [dcpoofdcpomorphisms]? *) Definition pointwiseorder {X:UU} (P : X -> Poset) : hrel (∏ x, P x) := fun f g => ∀ x, f x ≤ g x. Lemma ispartialorder_pointwiseorder {X:UU} (P : X -> Poset) : isPartialOrder (pointwiseorder P). Proof. repeat split. - repeat intro. eapply istrans_posetRelation; auto. - repeat intro. apply isrefl_posetRelation. - intros f g le_f_g le_g_f. use funextsec; intro. apply isantisymm_posetRelation; auto. Defined. (** Note: could also be called e.g. [Poset_product], or various other names. *) (* TODO: consider naming convention. Are there analogous constructions elsewhere in UniMath that this should fit with? This name fits with type-theoretical lemmas in UniMath, but is less natural from a classical mathematical perspective. *) Definition forall_Poset {X:UU} (P : X -> Poset) : Poset. Proof. use make_Poset. { exact (forall_hSet P). } use make_PartialOrder. { apply pointwiseorder. } apply ispartialorder_pointwiseorder. Defined. Definition arrow_Poset (X:UU) (P : Poset) : Poset := forall_Poset (fun _:X => P). Definition isupperbound_if_pointwise {X:UU} {P : X -> Poset} {I} {f : I -> forall_Poset P} {g : forall_Poset P} : isupperbound f g <-> forall x, isupperbound (fun i => f i x) (g x). Proof. split; intro H; repeat intro; use H. Defined. Definition is_least_upper_bound_pointwise {X:UU} {P : X -> Poset} {I} (f : I -> forall_Poset P) (g : forall_Poset P) : hProp := ∀ x, is_least_upper_bound (fun i => f i x) (g x). Definition is_least_upper_bound_if_pointwise {X:UU} {P : X -> Poset} {I} {f : I -> forall_Poset P} {g : forall_Poset P} : is_least_upper_bound_pointwise f g -> is_least_upper_bound f g. Proof. intro pointwise_lub. set (g_pwlub := fun x => make_least_upper_bound _ (pointwise_lub x)). split. - intros i x. apply (least_upper_bound_is_upper_bound (g_pwlub x)). - intros [g' g'_ub] x. apply (least_upper_bound_univ (g_pwlub x)). apply isupperbound_if_pointwise, g'_ub. Defined. Lemma isaposetmorphism_pointwise_lub {P : Poset} {I} {f : I -> P -> P} (f_monot : forall i, isaposetmorphism (f i)) {g} (g_pw_lub : is_least_upper_bound_pointwise f g) : isaposetmorphism g. Proof. intros x y le_x_y. apply (least_upper_bound_univ (make_least_upper_bound _ (g_pw_lub _))). intros i. eapply istrans_posetRelation. 2: { apply (least_upper_bound_is_upper_bound (make_least_upper_bound _ (g_pw_lub _))). } apply f_monot; assumption. Defined. End Function_Posets. (** ** Classes of maps *) (** Progressive maps as also known as ascending, inflationary, increasing, and more. Note these are just endo-_functions_, not “maps” in the sense of morphisms of posets. *) Section ProgressiveMaps. Definition isprogressive {P : Poset} : hsubtype (P -> P) : UU := fun f => ∀ (x : P), x ≤ f x. Definition Progressive_map (P : Poset) := carrier (@isprogressive P). Definition pr1_Progressive_map {P : Poset} : Progressive_map P -> (P -> P) := pr1carrier _. Coercion pr1_Progressive_map : Progressive_map >-> Funclass. Definition progressive_property {P} (f : Progressive_map P) : isprogressive f := pr2 f. Lemma isprogressive_idfun {P : Poset} : isprogressive (idfun P). Proof. intro; apply isrefl_posetRelation. Defined. Lemma isprogressive_compose {P : Poset} {f g : P -> P} (f_prog : isprogressive f) (g_prog : isprogressive g) : isprogressive (f ∘ g). Proof. intros x. eapply istrans_posetRelation. - use g_prog. - use f_prog. Defined. Lemma progressive_pointwise_lub {P : Poset} {I} {f : I -> P -> P} (f_prog : forall i, isprogressive (f i)) {g} (g_pw_lub : is_least_upper_bound_pointwise f g) (I_inhab : ∥ I ∥) : isprogressive g. Proof. intros x. eapply factor_through_squash_hProp. 2: { apply I_inhab. } intros i. eapply istrans_posetRelation. { use f_prog; apply i. } revert i. (* TODO: make version that takes the [is_lub] as separate input *) refine (@least_upper_bound_is_upper_bound _ _ _ (make_least_upper_bound _ _)). use g_pw_lub. Defined. End ProgressiveMaps. (** ** Fixpoints of endofunctions *) Section Fixpoints. (* TODO: this approach to types of fixedpoints doesn’t play well with the setup of subposets. Perhaps try refactoring? But working with hsubtypes/subposets throughout creates so much extra [pr1] overhead, impacting readability; this approach avoids that nicely. *) Definition isfixedpoint {P : Poset} (f : P -> P) : hsubtype P := fun (x:P) => f x = x. Definition Fixedpoint {P : Poset} (f : P -> P) : UU := carrier (isfixedpoint f). Coercion pr1_Fixedpoint {P : Poset} {f : P -> P} : Fixedpoint f -> P := pr1carrier _. Definition fixedpoint_property {P : Poset} {f : P -> P} (x : Fixedpoint f) : f x = x := pr2 x. Definition ispostfixedpoint {P : Poset} (f : P -> P) : hsubtype P := fun (x:P) => x ≤ f x. Definition Postfixedpoint {P : Poset} (f : P -> P) : UU := carrier (ispostfixedpoint f). Coercion pr1_Postfixedpoint {P : Poset} {f : P -> P} : Postfixedpoint f -> P := pr1carrier _. Definition postfixedpoint_property {P : Poset} {f : P -> P} (x : Postfixedpoint f) : x ≤ f x := pr2 x. End Fixpoints. (** ** The (Knaster–)Tarski fixpoint theorems This classical theorem is in several forms. The strong general form, due to Tarski, states that given a monotone endo-map [f] on a complete poset [P], the sub-poset of fixed points of [f] is again complete. The key lemma for this is close to the earlier weaker form, due essentially to Knaster and Tarski independently: a monotone endo-map [f] on a complete poset [P] has a least fixed point above any post-fixed point. *) Section Tarski. Theorem Knaster_Tarski_fixpoint {P:Poset} (P_complete : is_complete P) (f : posetmorphism P P) {x0} (x0_postfix : x0 ≤ f x0) : least_suchthat (fun x:P => f x = x ∧ x0 ≤ x). Proof. (* Let C be the least subset containing x0 that is closed under f and taking least upper bounds. We take some time to set up C and its universal property cleanly. *) set (is_f_closed := (fun A => (∀ y, A y ⇒ A (f y))) : hsubtype P -> hProp). set (is_sup_closed := (fun A => ∀ C' : hsubtype P, C' ⊆ A ⇒ A (P_complete C')) : hsubtype P -> hProp). set (C := (fun x => ∀ A : hsubtype P, A x0 ⇒ is_f_closed A ⇒ is_sup_closed A ⇒ A x) : hsubtype P). assert (C_x0 : C x0). { intros A A_x0 A_f_closed A_sup_closed; assumption. } assert (C_f_closed : is_f_closed C). { intros x C_x A A_x0 A_f_closed A_sup_closed. use A_f_closed. use C_x; assumption. } assert (C_sup_closed : is_sup_closed C). { intros X C_X A A_x0 A_f_closed A_sup_closed. use A_sup_closed; intros ? ?; use C_X; assumption. } assert (C_induction : ∀ (A : hsubtype P), A x0 ⇒ is_f_closed (A ∩ C) ⇒ is_sup_closed (A ∩ C) ⇒ C ⊆ A). { intros A A_x0 A_sup_closed A_f_closed x Cx. apply (Cx (fun x => A x ∧ C x)); [ split | | ]; assumption. } (* Now establish a few facts about C and (post-)fixed points *) assert (postfix_supclosed : is_sup_closed (fun x => x ≤ f x)). { intros A A_postfix. apply least_upper_bound_subtype_univ. intros x A_x. eapply istrans_posetRelation. { use A_postfix; apply A_x. } apply posetmorphism_property. apply least_upper_bound_subtype_is_upper_bound, A_x. } assert (postfix_C : C ⊆ (fun x => x ≤ f x)). { use C_induction. - apply x0_postfix. - intros x [x_postfix C_x]. split. 2: { use C_f_closed; assumption. } apply posetmorphism_property, x_postfix. - intros A IH_A. split. 2: { use C_sup_closed; apply (istrans_subtype_containment IH_A), subtype_binaryintersection_leq2. } use postfix_supclosed. apply (istrans_subtype_containment IH_A). apply subtype_binaryintersection_leq1. } assert (C_below_allfix : ∏ x, (f x = x) ⇒ x0 ≤ x ⇒ C ⊆ (fun y => y ≤ x)). { intros x x_fix leq_x0_x. use C_induction. - assumption. - intros y [le_yx C_y]. split. 2: { use C_f_closed; assumption. } eapply istrans_posetRelation. { apply posetmorphism_property, le_yx. } apply isrefl'_posetRelation, x_fix. - intros A IH_A. split. 2: { use C_sup_closed. apply (istrans_subtype_containment IH_A), subtype_binaryintersection_leq2. } apply least_upper_bound_subtype_univ. apply (istrans_subtype_containment IH_A), subtype_binaryintersection_leq1. } (* From these, it follows that sup C is a least fixed point. *) set (sup_C := P_complete C). assert (C_sup_C : C sup_C). { use C_sup_closed. intros ? ?; assumption. } simple refine (((sup_C : P),,(_,,_)),,_); simpl. - apply isantisymm_posetRelation. + refine (least_upper_bound_is_upper_bound sup_C (_,,_)). use C_f_closed. apply C_sup_C. + use postfix_C. apply C_sup_C. - refine (least_upper_bound_is_upper_bound sup_C (_,,_)); assumption. - intros [x [x_fix leq_x0_x]]; simpl. apply least_upper_bound_subtype_univ, C_below_allfix; assumption. Defined. Theorem Tarski_fixpoint_theorem {P:Poset} (P_complete : is_complete P) (f : posetmorphism P P) : is_complete ((fun x:P => f x = x) : Subposet P). Proof. intros A. set (A_in_P := (fun x:P => ∑ x_fix : (f x = x)%logic, A (x,,x_fix))%prop). set (sup_P_A := P_complete A_in_P). assert (sup_fix_A : least_suchthat (fun x:P => f x = x ∧ sup_P_A ≤ x)). { apply Knaster_Tarski_fixpoint; try assumption. apply least_upper_bound_subtype_univ. intros y [y_fix A_y]. apply (istrans_posetRelation _ _ (f y)). { apply isrefl'_posetRelation, pathsinv0; assumption. } apply posetmorphism_property, least_upper_bound_subtype_is_upper_bound. use tpair; assumption. } assert (sup_A_isfix : f sup_fix_A = sup_fix_A). { apply (least_suchthat_satisfies sup_fix_A). } use make_least_upper_bound. { exists sup_fix_A. assumption. } split. - intros [[x x_fix] A_x]. simpl. apply (istrans_posetRelation _ _ (sup_P_A)). + apply least_upper_bound_subtype_is_upper_bound. use tpair; assumption. + apply (least_suchthat_satisfies sup_fix_A). - intros [[x x_fix] x_ub]. cbn. apply least_suchthat_is_least. split; try assumption. apply least_upper_bound_subtype_univ. intros y [y_fix A_y]. use (x_ub ((_,,_),,_)); assumption. Defined. End Tarski. (** ** Bourbaki-Witt The classical Bourbaki–Witt theorem says: Any progressive map on a chain-complete partial order has a fixed point. Constructively, this may fail, as shown in Bauer–Lumsdaine https://arxiv.org/abs/1201.0340. Here we aim to give both the classical theorem, and some weaker constructively-provable results. *) Section Bourbaki_Witt. Definition Bourbaki_Witt_property (P : Poset) := ∏ (f : Progressive_map P), Fixedpoint f. (** Theorem traditionally credited to Bourbaki (1949) and Witt (1951). This proof is based on Lang, Algebra (2002), Appendix 2, Thm 2.1. *) Theorem Bourbaki_Witt_fixpoint : LEM -> ∏ P : Poset, is_chain_complete P -> Bourbaki_Witt_property P. Proof. (* Let C be the least subset closed under f and suprema of chains. We take some time to set up C and its universal property cleanly. *) intros H_LEM P P_CC f. set (is_f_closed := (fun A => (∀ y, A y ⇒ A (f y))) : hsubtype P -> hProp). set (is_chain_closed := (fun A => (∀ C' : Chain_hsubtype P, (∏ y:C', A (pr1 y)) ⇒ A (P_CC C'))) : hsubtype P -> hProp). set (C := (fun x => ∀ A : hsubtype P, is_f_closed A ⇒ is_chain_closed A ⇒ A x) : hsubtype P). assert (C_f_closed : is_f_closed C). { intros x C_x A A_f_closed A_chain_closed. use A_f_closed. use C_x; assumption. } assert (C_chain_closed : is_chain_closed C). { intros x C_x A A_f_closed A_chain_closed. use A_chain_closed. intro; use C_x; assumption. } assert (C_induction : ∀ (A : hsubtype P), is_f_closed (A ∩ C) ⇒ is_chain_closed (A ∩ C) ⇒ C ⊆ A). { intros A A_chain_closed A_f_closed x Cx. apply (Cx (fun x => A x ∧ C x)); assumption. } (* Now, if C is a chain, then its least upper bound will be a fixed point. *) assert (C_is_chain : is_chain (pr1carrier C)). 2: { set (C_Chain := (C,, C_is_chain) : Chain_hsubtype P). exists (P_CC C_Chain). apply isantisymm_posetRelation. 2: { use progressive_property. } refine (least_upper_bound_is_upper_bound (P_CC _) (_,,_)). use C_f_closed. use C_chain_closed. intros [? ?]; assumption. } (* It remains to show C is a chain. This is the hard (and nonconstructive) part. Say [x ∈ C] is a _bottleneck_ if for all y ≤ x in C, either [f y ≤ x] or [y = x]. We show, in each case by C-induction: (1) if x is a bottleneck, then for all y in C, y ≤ x or f x ≤ y; (2) every x ∈ C is a bottleneck. It follows that C is a chain. *) set (is_bottleneck := (fun x => ∀ y, C y ⇒ y ≤ x ⇒ (f y ≤ x) ∨ (y = x)) : hsubtype P). assert (bottleneck_comparison : ∀ x, C x ⇒ is_bottleneck x ⇒ ∀ y, C y ⇒ (y ≤ x) ∨ (f x ≤ y)). { intros x C_x x_bottleneck. use C_induction. - intros y [y_comp C_y]. split. 2: { use C_f_closed; assumption. } apply (hconjtohdisj' y_comp). 2: { intros leq_fx_y. apply hdisj_in2. eapply istrans_posetRelation; try eassumption. use progressive_property. } intros leq_y_x. use (hdisj_monot' (x_bottleneck y _ _)); try assumption. + intro; assumption. + intro e_yx; destruct e_yx; apply isrefl_posetRelation. - intros C' IH_C'. split. 2: { use C_chain_closed; intros; apply IH_C'. } destruct (H_LEM (∃ y, C' y ∧ f x ≤ y)) as [C'_passes_fx | C'_notpasses_fx ]. + apply hdisj_in2. refine (factor_through_squash_hProp _ _ C'_passes_fx); intros [y [C'_y leq_fx_y]]. eapply istrans_posetRelation; try eassumption. use least_upper_bound_subtype_is_upper_bound; assumption. + apply hdisj_in1. apply least_upper_bound_univ. intros [y C'_y]. eapply hdisjtoimpl. apply hdisj_comm, IH_C'. intros leq_fx_y. apply C'_notpasses_fx. apply hinhpr; exists y. split; assumption. } assert (all_C_bottleneck : forall x, C x ⇒ is_bottleneck x). { use C_induction. - intros x [x_bottleneck C_x]. split. 2: { use C_f_closed; assumption. } intros y C_y le_y_fx. use (hconjtohdisj' (bottleneck_comparison x _ _ y _)); try assumption. 2: { intro. apply hdisj_in2, isantisymm_posetRelation; assumption. } intro le_yx. apply hdisj_in1. use (hconjtohdisj' (x_bottleneck y _ _)); try assumption. + intro. eapply istrans_posetRelation; try eassumption. use progressive_property. + intros e_yx; destruct e_yx. apply isrefl_posetRelation. - intros C' IH_C'. split. 2: { use C_chain_closed; intros; apply IH_C'. } intros x C_x le_x_supC'. destruct (H_LEM (∃ y, C' y ∧ f x ≤ y)) as [ C'_passes_fx | C'_notpasses_fx ]. { apply hdisj_in1. refine (factor_through_squash_hProp _ _ C'_passes_fx); intros [y [? ?]]. eapply istrans_posetRelation; eauto using least_upper_bound_subtype_is_upper_bound. } apply hdisj_in2. apply isantisymm_posetRelation; try assumption. apply least_upper_bound_subtype_univ. intros y C'_y. destruct (IH_C' (y,,C'_y)) as [y_bottleneck C_y]. use (hconjtohdisj' (bottleneck_comparison y _ _ x _)); try assumption. 2: { intro. eapply istrans_posetRelation; try eassumption. use progressive_property. } intro le_x_y. apply isrefl'_posetRelation, pathsinv0. refine (hdisjtoimpl (y_bottleneck x C_x _) _); try assumption. use (negexists_to_forallneg_restricted C'_notpasses_fx); assumption. } intros [x Cx] [y Cy]; simpl pr1carrier. assert (comparison : x ≤ y ∨ f y ≤ x). { use bottleneck_comparison; try apply all_C_bottleneck; assumption. } apply (hdisj_monot' comparison). { intro; assumption. } intro. eapply istrans_posetRelation; try eassumption. use progressive_property. Defined. (** “Pataraia’s Lemma”: on any DCPO, there is a maximal monotone+progressive endo-map. This is the main lemma for Pataraia’s theorem, [fixpoint_for_monotone_on_dcpo]. *) Lemma maximal_progressive_endomorphism_on_dcpo {P : Poset} (P_DC : is_directed_complete P) : greatest_suchthat (fun f : arrow_Poset P P => isaposetmorphism_hProp f ∧ isprogressive f). Proof. (* Outline: The monotone progressive maps form a directed set, so have a pointwise sup. Also, they are closed under (inhabited) sups. So their sup is a maximal such map. The proof follows this outline, but reasoning bottom-up/backwards. *) set (mon_prog_maps := (fun f : arrow_Poset P P => isaposetmorphism_hProp f ∧ isprogressive f) : hsubtype _). cut (carrier (is_greatest_suchthat mon_prog_maps)). (* just munging the goal *) { intros f. exact (make_greatest_suchthat (pr1 f) (pr2 f)). } cut (carrier (mon_prog_maps ∩ is_least_upper_bound_subtype mon_prog_maps)). { use subtype_inc. intros ? [? ?]. apply greatest_if_contains_sup; assumption. } cut (carrier (is_least_upper_bound_pointwise (@pr1carrier _ mon_prog_maps))). { use subtype_inc. intros f f_pw_lub; split; [ split | ]. - eapply isaposetmorphism_pointwise_lub; try eassumption. intros [g [g_mon g_prog]]; exact g_mon. - eapply progressive_pointwise_lub; try eassumption. { intros [g [g_mon g_prog]]; exact g_prog. } apply hinhpr. exists (idfun _); split. + apply isaposetmorphism_idfun. + apply isprogressive_idfun. - apply is_least_upper_bound_if_pointwise; assumption. } (* TODO: perhaps factor the following as “a directed set of functions has a pointwise l.u.b.”? *) use (foralltototal _ (fun _ y => is_least_upper_bound _ y)). (* munge goal again *) intros x. cut (least_upper_bound (fun g : mon_prog_maps => pr1 g x)). { intros p. exists p. apply least_upper_bound_property. } apply isdirected_lub; try assumption. split. - apply hinhpr. exists (idfun _); split. + apply isaposetmorphism_idfun. + apply isprogressive_idfun. - intros [f [f_mon f_prog]] [g [g_mon g_prog]]. apply hinhpr. use tpair. { exists (f ∘ g); split. + apply isaposetmorphism_compose; assumption. + apply isprogressive_compose; assumption. } split; simpl. + use f_mon; use g_prog. + use f_prog. Defined. (** A constructive fixed-point theorem, due to Pataraia. This proof transmitted via Dacar and Bauer–Lumsdaine (where it is Thm 3.2). *) Theorem fixpoint_for_monotone_on_dcpo {P : Poset} (P_dir: is_directed_complete P) (f : posetmorphism P P) (x : Postfixedpoint f) : ∑ y : Fixedpoint f, x ≤ y. Proof. (* Outline: - restrict attention to the sub-poset of post-fixed-points of P - by Pataraia’s Lemma [maximal_progressive_endomorphism_on_dcpo], there is a maximal monotone progressive map on this sub-poset - note that values of this maximal map are fixed points of f *) revert x. set (postfix_f := (fun x => x ≤ f x) : Subposet P). assert (postfix_dc : is_directed_complete postfix_f). { intros [A A_dir]. use least_upper_bound_in_subposet. { use (isdirected_lub P_dir). assumption. } (* Uncannily, [A_dir] works off the bat, without needing to be converted from directedness in Q to directedness in P! It’s clear that these types are convertible, but impressive that Coq recognises it so easily. *) apply least_upper_bound_univ. intros [[x x_postfix] x_A]. eapply istrans_posetRelation. { apply x_postfix. } apply posetmorphism_property. refine (least_upper_bound_is_upper_bound _ (_,,_)). simple refine (value_in_image _ ((_,,_),,_)); assumption. } set (max_monprog_map := maximal_progressive_endomorphism_on_dcpo postfix_dc). destruct max_monprog_map as [[max_map [max_is_mon max_is_prog]] max_is_max]. transparent assert (f_restr_postfix : (arrow_Poset postfix_f postfix_f)). { intros x. exists (f (pr1 x)). apply posetmorphism_property, postfixedpoint_property. } assert (max_map_gives_fixedpoints : f_restr_postfix ∘ max_map ~ max_map). { intros x; apply isantisymm_posetRelation. 2: { apply postfixedpoint_property. } revert x. refine (max_is_max (_,,_)); split. - refine (@isaposetmorphism_compose _ _ _ max_map _ f_restr_postfix _). { assumption. } intros ? ?; apply (posetmorphism_property f). (* TODO: make argument order consistent on the [_compose] lemmas *) - refine (@isprogressive_compose _ f_restr_postfix max_map _ _). 2: { assumption. } intro; apply postfixedpoint_property. } intros x. simple refine ((pr1 (max_map x),,_),,_); simpl. - exact (maponpaths _ (max_map_gives_fixedpoints x)). - use max_is_prog. Defined. End Bourbaki_Witt. (** Finally, we check that the promises listed in the overview have been fulfilled. Note: we give these here to ensure that the overview always accurately reflects the theorems of the file. However, we make them local, since they should probably not be used outside this file — the original versions proved above are the versions intended for use. *) Section Check_Overview. Local Theorem fulfil_Tarski_fixpoint_theorem : Tarski_fixpoint_theorem_statement (is_complete) (@isfixedpoint). Proof. use @Tarski_fixpoint_theorem. Defined. Local Theorem fulfil_fixpoint_for_monotone_on_dcpo : fixpoint_for_monotone_on_dcpo_statement (is_directed_complete) (@ispostfixedpoint) (@isfixedpoint). Proof. use @fixpoint_for_monotone_on_dcpo. Defined. (** Classical theorem, usually attrbi. Bourbaki (1949) and Witt (1951). *) Local Theorem fulfil_Bourbaki_Witt_fixpoint_theorem : Bourbaki_Witt_fixpoint_theorem_statement (is_chain_complete) (@isprogressive) (@isfixedpoint). Proof. use @Bourbaki_Witt_fixpoint. Defined. End Check_Overview. UniMath-20231010/UniMath/OrderTheory/DCPOs/Basis/000077500000000000000000000000001451125700300210735ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/Basis/Algebraic.v000066400000000000000000000147771451125700300231530ustar00rootroot00000000000000(****************************************************************************** Algebraic DCPOs Continuous DCPOs are those with a basis: every elements is the supremum of all elements that are way below it. The notion of algebraic DCPO is stronger. It says that there is a basis consisting of only compact elements (which are the elements `x` such that `x ≪ x`). References: - Section 2 in the chapter 'Domain Theory' of the Handbook for Logic in Computer Science, Volume 3 (https://www.cs.ox.ac.uk/files/298/handbook.pdf) - Section 4.6 in Domain Theory in Constructive and Predicative Univalent Foundations (https://tdejong.com/writings/phd-thesis.pdf) Contents 1. Compact elements 2. Algebraic DCPOs (as structure) 3. Algebraic DCPOs (as property) 4. Algebraic DCPOs to continuous DCPOs 5. Structure from property for algebraic DCPOs ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. (** 1. Compact elements *) Definition is_compact_el {X : dcpo} (x : X) : hProp := x ≪ x. Proposition is_compact_bot (X : dcppo) : is_compact_el (⊥_{X}). Proof. apply bot_way_below. Qed. Proposition compact_el_way_below_le {X : dcpo} {x y : X} (p : is_compact_el x) (q : x ⊑ y) : x ≪ y. Proof. exact (trans_way_below_le p q). Qed. Definition compact_elements (X : dcpo) : UU := ∑ (x : X), is_compact_el x. (** 2. Algebraic DCPOs (as structure) *) Definition algebraic_dcpo_struct (X : dcpo) : UU := ∏ (x : X), ∑ (D : directed_set X), (∏ (i : D), is_compact_el (D i)) × is_least_upperbound X D x. Section AlgebraicDCPOAccessors. Context {X : dcpo} (AX : algebraic_dcpo_struct X). Definition compact_approximating_family (x : X) : directed_set X := pr1 (AX x). Proposition is_compact_approximating_family (x : X) (i : compact_approximating_family x) : is_compact_el (compact_approximating_family x i). Proof. exact (pr12 (AX x) i). Qed. Proposition compact_approximating_family_lub (x : X) : ⨆ (compact_approximating_family x) = x. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. exact (pr122 (AX x) i). - use (is_least_upperbound_is_least (pr22 (AX x))). apply is_least_upperbound_is_upperbound. apply is_least_upperbound_dcpo_lub. Qed. Proposition compact_approximating_family_way_below (x : X) (i : compact_approximating_family x) : compact_approximating_family x i ≪ x. Proof. refine (trans_way_below_le (is_compact_approximating_family x i) _). exact (pr122 (AX x) i). Qed. End AlgebraicDCPOAccessors. (** 3. Algebraic DCPOs (as property) *) Definition is_algebraic_dcpo (X : dcpo) : hProp := ∥ algebraic_dcpo_struct X ∥. (** 4. Algebraic DCPOs to continuous DCPOs *) Definition algebraic_dcpo_struct_to_continuous {X : dcpo} (AX : algebraic_dcpo_struct X) : continuous_dcpo_struct X. Proof. intro x. refine (compact_approximating_family AX x ,, _ ,, _). - abstract (intro i ; apply compact_approximating_family_way_below). - abstract (apply AX). Defined. (** 5. Structure from property for algebraic DCPOs *) Proposition is_algebraic_is_directed {X : dcpo} (CX : is_algebraic_dcpo X) (x : X) : is_directed X (λ (z : ∑ (b : X), is_compact_el b ∧ b ≪ x), pr1 z). Proof. revert CX. use factor_through_squash_hProp. intros CX. pose (D := compact_approximating_family CX x). split. - assert (H := directed_set_el D). revert H. use factor_through_squash_hProp. intros d. use hinhpr. refine (D d ,, _). split. + apply is_compact_approximating_family. + apply compact_approximating_family_way_below. - intros [ b₁ p₁ ] [ b₂ p₂ ]. assert (x ⊑ ⨆ D) as q. { rewrite <- (compact_approximating_family_lub CX x). apply refl_dcpo. } assert (H := way_below_elem (pr2 p₁) D q). revert H. use factor_through_squash_hProp. intros [ c₁ r₁ ]. assert (H := way_below_elem (pr2 p₂) D q). revert H. use factor_through_squash_hProp. intros [ c₂ r₂ ]. assert (H := directed_set_top D c₁ c₂). revert H. use factor_through_squash_hProp. intros [ k [ s₂ s₃ ]]. use hinhpr. simple refine ((D k ,, _) ,, _ ,, _). + split. * apply is_compact_approximating_family. * apply compact_approximating_family_way_below. + exact (trans_dcpo r₁ s₂). + exact (trans_dcpo r₂ s₃). Qed. Definition is_algebraic_dcpo_directed_set {X : dcpo} (CX : is_algebraic_dcpo X) (x : X) : directed_set X. Proof. use make_directed_set. - exact (∑ (b : X), is_compact_el b ∧ b ≪ x). - exact (λ z, pr1 z). - exact (is_algebraic_is_directed CX x). Defined. Proposition is_algebraic_dcpo_directed_set_lub {X : dcpo} (CX : is_algebraic_dcpo X) (x : X) : ⨆ (is_algebraic_dcpo_directed_set CX x) = x. Proof. revert CX. use factor_dep_through_squash. { intro. apply setproperty. } intros CX. pose (D := compact_approximating_family CX x). cbn. use antisymm_dcpo. - use dcpo_lub_is_least. intros i. apply way_below_to_le. exact (pr22 i). - refine (trans_dcpo _ _). { apply eq_to_le_dcpo. exact (!(compact_approximating_family_lub CX x)). } use dcpo_lub_is_least. intros i. use less_than_dcpo_lub ; cbn -[way_below]. + refine (D i ,, _). split. * apply is_compact_approximating_family. * apply compact_approximating_family_way_below. + apply refl_dcpo. Qed. Definition is_algebraic_to_algebraic_struct {X : dcpo} (CX : is_algebraic_dcpo X) : algebraic_dcpo_struct X. Proof. intros x. refine (is_algebraic_dcpo_directed_set CX x ,, _ ,, _). - abstract (intros i ; apply i). - abstract (pose (is_least_upperbound_dcpo_lub (is_algebraic_dcpo_directed_set CX x)) as h ; rewrite (is_algebraic_dcpo_directed_set_lub CX x) in h ; exact h). Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Basis/Basis.v000066400000000000000000000407251451125700300223330ustar00rootroot00000000000000(****************************************************************************** Bases in DCPOs We define the notion of a basis of a DCPO. There are two possible approaches: 1. A basis is given by a predicate on the elements of the DCPO 2. We have a type of basis elements and a map from that type to the DCPO For both approaches, suitable requirements need to be demanded as well. We follow Section 4.7 in https://tdejong.com/writings/phd-thesis.pdf, and we use the second approach. We also study some properties of bases. First of all, we show that every continuous DCPO comes equipped with a bases and that every DCPO with a basis comes equipped with a continuity structure. Second, we look at the standard properties of continuous DCPOs and we reformulate them using the basis. For example, in a continuous DCPO the order relation can be characterized using the approximations (i.e., `x ⊑ y` if and only if for every `z` such that `z ≪ x`, we have `z ≪ y`). Another standard property would be interpolation: if we have `x ≪ y`, then we can find an element of the basis `x ≪ b ≪ y`. Lastly, we look at the mapping property of a DCPO with a basis. We look at three properties: 1. Two maps are equal if they are equal on the basis 2. We have `f x ⊑ g x` for every `x` if for every basis element `b` we have `f b ⊑ g b` 3. If we have a monotone map from the basis to some DCPO `Y`, then we can extend that map to `X`. Note that the map from the third point is unique. The uniqueness would be guaranteed if the DCPO is algebraic, but not in general if the DCPO is only continuous. Contents 1. Definition of a basis 2. Accessors and builders for bases 3. Bases versus continuity 4. Approximation via bases 5. Interpolation using bases 6. Equality of maps via bases 7. The order on maps via basis elements 8. Constructing maps from their action on the basis ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. Unset Universe Checking. Section BasisInDCPO. Context {X : dcpo}. (** 1. Definition of a basis *) Definition dcpo_basis_data : UU := ∑ (B : UU), B → X. Coercion dcpo_basis_data_to_type (B : dcpo_basis_data) : UU := pr1 B. Definition dcpo_basis_data_to_dcpo (B : dcpo_basis_data) (b : B) : X := pr2 B b. Coercion dcpo_basis_data_to_dcpo : dcpo_basis_data >-> Funclass. Definition make_dcpo_basis_data (B : UU) (β : B → X) : dcpo_basis_data := B ,, β. Definition basis_below_element (B : dcpo_basis_data) (x : X) : UU := ∑ (b : B), B b ≪ x. Definition basis_below_map (B : dcpo_basis_data) (x : X) : basis_below_element B x → X := λ b, B(pr1 b). Definition dcpo_basis_laws (B : dcpo_basis_data) : UU := ∏ (x : X), is_directed X (basis_below_map B x) × is_least_upperbound X (basis_below_map B x) x. Definition dcpo_basis : UU := ∑ (B : dcpo_basis_data), dcpo_basis_laws B. (** 2. Accessors and builders for bases *) Definition make_dcpo_basis (B : dcpo_basis_data) (HB : dcpo_basis_laws B) : dcpo_basis := B ,, HB. Coercion dcpo_basis_to_data (B : dcpo_basis) : dcpo_basis_data := pr1 B. Coercion dcpo_basis_to_laws (B : dcpo_basis) : dcpo_basis_laws B := pr2 B. Proposition is_directed_basis (B : dcpo_basis) (x : X) : is_directed X (basis_below_map B x). Proof. exact (pr1 (pr2 B x)). Qed. Definition directed_set_from_basis (B : dcpo_basis) (x : X) : directed_set X. Proof. use make_directed_set. - exact (basis_below_element B x). - exact (basis_below_map B x). - exact (is_directed_basis B x). Defined. Proposition is_least_upperbound_basis (B : dcpo_basis) (x : X) : is_least_upperbound X (basis_below_map B x) x. Proof. exact (pr2 (pr2 B x)). Qed. Proposition approximating_basis_lub (B : dcpo_basis) (x : X) : ⨆ (directed_set_from_basis B x) = x. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. apply way_below_to_le. exact (pr2 i). - use (is_least_upperbound_is_least (is_least_upperbound_basis B x)). apply is_least_upperbound_is_upperbound. exact (is_least_upperbound_dcpo_lub (directed_set_from_basis B x)). Qed. End BasisInDCPO. Set Universe Checking. Arguments dcpo_basis_data : clear implicits. Arguments dcpo_basis_laws : clear implicits. Arguments dcpo_basis : clear implicits. (** 3. Bases versus continuity *) Definition continuous_struct_from_basis {X : dcpo} (B : dcpo_basis X) : continuous_dcpo_struct X. Proof. intro x. refine (directed_set_from_basis B x ,, _ ,, _). - intro i. exact (pr2 i). - apply is_least_upperbound_basis. Defined. Definition basis_data_from_continuous_struct {X : dcpo} (CX : continuous_dcpo_struct X) : dcpo_basis_data X. Proof. use make_dcpo_basis_data. - exact X. - exact (λ x, x). Defined. Proposition basis_laws_from_continuous_struct {X : dcpo} (CX : continuous_dcpo_struct X) : dcpo_basis_laws X (basis_data_from_continuous_struct CX). Proof. intro x. split. - split. + exact (nullary_interpolation CX x). + intros i j. unfold basis_below_element, basis_data_from_continuous_struct in i, j. cbn -[way_below] in i, j. assert (H := binary_interpolation CX (pr2 i) (pr2 j)). revert H. use factor_through_squash. { apply propproperty. } intros z. induction z as [ z [ p₁ [ p₂ p₃ ]]]. refine (hinhpr ((z ,, p₃) ,, _ ,, _)). * apply way_below_to_le. exact p₁. * apply way_below_to_le. exact p₂. - split. + intros i. induction i as [ i p ]. apply way_below_to_le. exact p. + intros y Hy. rewrite <- (approximating_family_lub CX x). use dcpo_lub_is_least. intro i. use (Hy (approximating_family CX x i ,, _)). cbn -[way_below]. apply approximating_family_way_below. Qed. Definition basis_from_continuous_struct {X : dcpo} (CX : continuous_dcpo_struct X) : dcpo_basis X. Proof. use make_dcpo_basis. - exact (basis_data_from_continuous_struct CX). - exact (basis_laws_from_continuous_struct CX). Defined. Section BasisProperties. Context {X : dcpo} (B : dcpo_basis X). (** 4. Approximation via bases *) (** We can characterize the order of the DCPO using the way-below relation and the basis *) Proposition dcpo_basis_le_via_approximation (x y : X) : x ⊑ y ≃ ∀ (z : B), (B z ≪ x ⇒ B z ≪ y)%logic. Proof. use weqimplimpl. - intros p z q. exact (trans_way_below_le q p). - intros H. rewrite <- (approximating_basis_lub B x). use dcpo_lub_is_least. intro i. apply way_below_to_le. apply (H (pr1 i) (pr2 i)). - apply propproperty. - apply propproperty. Qed. Let CX : continuous_dcpo_struct X := continuous_struct_from_basis B. (** 5. Interpolation using bases *) Proposition basis_nullary_interpolation (x : X) : ∃ (i : B), B i ≪ x. Proof. assert (H := nullary_interpolation CX x). revert H. use factor_through_squash. { apply propproperty. } intro y. induction y as [ y p ]. assert (H := directed_set_el (directed_set_from_basis B y)). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ i q ]. refine (hinhpr (i ,, _)). exact (trans_way_below q p). Qed. Proposition basis_unary_interpolation {x y : X} (p : x ≪ y) : ∃ (i : B), x ≪ B i ∧ B i ≪ y. Proof. assert (H := unary_interpolation CX p). revert H. use factor_through_squash. { apply propproperty. } intro z. induction z as [ z [ q₁ q₂ ] ]. assert (r : y ⊑ ⨆ directed_set_from_basis B y). { rewrite approximating_basis_lub. apply refl_dcpo. } assert (H := q₂ (directed_set_from_basis B y) r). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ [ i s₁ ] s₂ ]. refine (hinhpr (i ,, _ ,, _)). - exact (trans_way_below_le q₁ s₂). - exact s₁. Qed. Proposition basis_binary_interpolation {x₁ x₂ y : X} (p₁ : x₁ ≪ y) (p₂ : x₂ ≪ y) : ∃ (i : B), x₁ ≪ B i ∧ x₂ ≪ B i ∧ B i ≪ y. Proof. assert (H := binary_interpolation CX p₁ p₂). revert H. use factor_through_squash. { apply propproperty. } intro z. induction z as [ z [ q₁ [ q₂ q₃ ] ] ]. assert (H := basis_unary_interpolation q₃). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ i [ r₁ r₂ ]]. refine (hinhpr (i ,, _ ,, _ ,, _)). - exact (trans_way_below q₁ r₁). - exact (trans_way_below q₂ r₁). - exact r₂. Qed. (** 6. Equality of maps via bases *) (** Two maps from a continuous DCPO to any DCPO are equal if they are equal on the basis elements. *) Proposition scott_continuous_map_eq_on_basis {Y : dcpo} {f g : scott_continuous_map X Y} (p : ∏ (i : B), f (B i) = g (B i)) : f = g. Proof. use eq_scott_continuous_map. intro x. refine (maponpaths f (!((approximating_basis_lub B x))) @ _). refine (_ @ maponpaths g (approximating_basis_lub B x)). rewrite !scott_continuous_map_on_lub. use antisymm_dcpo. - use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; cbn. + exact i. + unfold basis_below_map. rewrite p. apply refl_dcpo. - use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; cbn. + exact i. + unfold basis_below_map. rewrite p. apply refl_dcpo. Qed. Proposition map_eq_on_basis_if_scott_continuous {Y : dcpo} {f g : X → Y} (p : ∏ (i : B), f (B i) = g (B i)) (Hf : is_scott_continuous X Y f) (Hg : is_scott_continuous X Y g) (x : X) : f x = g x. Proof. exact (maponpaths (λ z, pr1 z x) (@scott_continuous_map_eq_on_basis Y (f ,, Hf) (g ,, Hg) p)). Qed. (** 7. The order on maps via basis elements *) Proposition scott_continuous_map_le_on_basis {Y : dcpo} {f g : scott_continuous_map X Y} (p : ∏ (i : B), f (B i) ⊑ g (B i)) (x : X) : f x ⊑ g x. Proof. rewrite (maponpaths f (!((approximating_basis_lub B x)))). rewrite (maponpaths g (!(approximating_basis_lub B x))). rewrite !scott_continuous_map_on_lub. use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; cbn. - exact i. - unfold basis_below_map. apply p. Qed. Proposition map_le_on_basis_if_scott_continuous {Y : dcpo} {f g : X → Y} (p : ∏ (i : B), f (B i) ⊑ g (B i)) (Hf : is_scott_continuous X Y f) (Hg : is_scott_continuous X Y g) (x : X) : f x ⊑ g x. Proof. exact (@scott_continuous_map_le_on_basis Y (f ,, Hf) (g ,, Hg) p x). Qed. (** 8. Constructing maps from their action on the basis *) Section ScottContinuousFromBasis. Context {Y : dcpo} (f : B → Y) (Hf : ∏ (i₁ i₂ : B), B i₁ ≪ B i₂ → f i₁ ⊑ f i₂). Proposition is_directed_map_from_basis (x : X) : is_directed Y (λ (i : basis_below_element B x), f (pr1 i)). Proof. split. - assert (H := directed_set_el (directed_set_from_basis B x)). revert H. use factor_through_squash. { apply propproperty. } intro i. exact (hinhpr i). - intros i j. induction i as [i Hix]. induction j as [j Hjx]. assert (H := basis_binary_interpolation Hix Hjx). revert H. use factor_through_squash. { apply propproperty. } intro k. induction k as [ k [ p [ q r ]]]. refine (hinhpr ((k ,, r) ,, _ ,, _)). + apply Hf. exact p. + apply Hf. exact q. Qed. Definition map_directed_set_from_basis (x : X) : directed_set Y. Proof. use make_directed_set. - exact (basis_below_element B x). - exact (λ i, f (pr1 i)). - exact (is_directed_map_from_basis x). Defined. Definition map_from_basis (x : X) : Y := ⨆ (map_directed_set_from_basis x). Proposition map_from_basis_monotone (x₁ x₂ : X) (p : x₁ ⊑ x₂) : map_from_basis x₁ ⊑ map_from_basis x₂. Proof. unfold map_from_basis. use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub. - refine (pr1 i ,, _). exact (trans_way_below_le (pr2 i) p). - cbn. apply refl_dcpo. Qed. Proposition map_from_basis_lub (D : directed_set X) : map_from_basis (⨆ D) = ⨆_{ D} (map_from_basis ,, map_from_basis_monotone). Proof. unfold map_from_basis. use antisymm_dcpo. - unfold map_from_basis. use dcpo_lub_is_least ; cbn. intro i. induction i as [ i p ] ; cbn. assert (H := unary_interpolation CX p). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ j [ q₁ q₂ ]]. assert (H := q₂ D (refl_dcpo _)). revert H. use factor_through_squash. { apply propproperty. } intro k. induction k as [ k r ]. use less_than_dcpo_lub. + exact k. + cbn. use less_than_dcpo_lub. * refine (i ,, _). exact (trans_way_below_le q₁ r). * cbn. apply refl_dcpo. - unfold map_from_basis. use dcpo_lub_is_least ; cbn. intro i. use dcpo_lub_is_least ; cbn. intro j. induction j as [ j p ] ; cbn. use less_than_dcpo_lub. + refine (j ,, _). refine (trans_way_below_le p _). use less_than_dcpo_lub. * exact i. * apply refl_dcpo. + cbn. apply refl_dcpo. Qed. Proposition is_scott_continuous_map_from_basis : is_scott_continuous (pr2 X) (pr2 Y) map_from_basis. Proof. use make_is_scott_continuous. - exact map_from_basis_monotone. - exact map_from_basis_lub. Qed. Definition scott_continuous_map_from_basis : scott_continuous_map X Y := map_from_basis ,, is_scott_continuous_map_from_basis. Proposition scott_continuous_map_from_basis_le (i : B) : scott_continuous_map_from_basis (B i) ⊑ f i. Proof. use dcpo_lub_is_least ; cbn. intro j. induction j as [ j p ] ; cbn. apply Hf. exact p. Qed. Proposition scott_continuous_map_from_basis_greatest (g : scott_continuous_map X Y) (Hg : ∏ (i : B), g (B i) ⊑ f i) (x : X) : g x ⊑ scott_continuous_map_from_basis x. Proof. assert (g x ⊑ g (⨆ directed_set_from_basis B x)) as p. { apply (is_monotone_scott_continuous_map g). rewrite (approximating_basis_lub B x). apply refl_dcpo. } refine (trans_dcpo p _). rewrite scott_continuous_map_on_lub. cbn ; unfold map_from_basis. use dcpo_lub_is_least. intro i. cbn in i. use less_than_dcpo_lub. - exact i. - apply Hg. Qed. End ScottContinuousFromBasis. End BasisProperties. UniMath-20231010/UniMath/OrderTheory/DCPOs/Basis/CompactBasis.v000066400000000000000000000302601451125700300236330ustar00rootroot00000000000000(****************************************************************************** Compact Basis In this file, we define the notion of a compact basis. The difference between a basis and a compact basis is that a compact basis is required to only consist of compact elements. We show that every compact basis gives the DCPO the structure of an algebraic DCPO. In addition, we also look at how to define maps using a compact basis. If we have a basis on a DCPO, then every monotone map from the basis to a DCPO can be extended to a Scott continuous map. However, this Scott continuous is in general not unique. If the basis only consists of compact elements, then the acquired map is actually unique. In addition, we have a stronger computation rule [scott_continuous_map_from_compact_basis_eq]. For ordinary basis, this rule only holds up to inequality. References: - Section 4.8 in https://tdejong.com/writings/phd-thesis.pdf Contents 1. Compact basis 2. Accessors and builders for compact bases 3. Every compact basis gives rise to a basis 4. Compact bases from bases of which every element is compact 5. Compact bases versus algebraicity 6. Constructing maps from their action on the basis ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Require Import UniMath.OrderTheory.DCPOs.Basis.Algebraic. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Local Open Scope dcpo. Section CompactBasisInDCPO. Context {X : dcpo}. (** 1. Compact basis *) Definition compact_basis_le_element (B : dcpo_basis_data X) (x : X) : UU := ∑ (b : B), B b ⊑ x. Definition compact_basis_le_map (B : dcpo_basis_data X) (x : X) : compact_basis_le_element B x → X := λ b, B(pr1 b). Definition compact_basis_laws (B : dcpo_basis_data X) : UU := (∏ (b : B), is_compact_el (B b)) × (∏ (x : X), is_directed X (compact_basis_le_map B x)) × (∏ (x : X), is_least_upperbound X (compact_basis_le_map B x) x). Definition compact_basis : UU := ∑ (B : dcpo_basis_data X), compact_basis_laws B. (** 2. Accessors and builders for compact bases *) Definition make_compact_basis (B : dcpo_basis_data X) (HB : compact_basis_laws B) : compact_basis := B ,, HB. Coercion compact_basis_to_data (B : compact_basis) : dcpo_basis_data X := pr1 B. Coercion compact_basis_to_laws (B : compact_basis) : compact_basis_laws B := pr2 B. Proposition is_compact_el_basis (B : compact_basis) (b : B) : is_compact_el (B b). Proof. exact (pr12 B b). Qed. Proposition is_directed_compact_basis (B : compact_basis) (x : X) : is_directed X (compact_basis_le_map B x). Proof. exact (pr122 B x). Qed. Definition directed_set_from_compact_basis (B : compact_basis) (x : X) : directed_set X. Proof. use make_directed_set. - exact (compact_basis_le_element B x). - exact (compact_basis_le_map B x). - exact (is_directed_compact_basis B x). Defined. Proposition is_least_upperbound_compact_basis (B : compact_basis) (x : X) : is_least_upperbound X (compact_basis_le_map B x) x. Proof. exact (pr222 B x). Qed. Proposition approximating_compact_basis_lub (B : compact_basis) (x : X) : ⨆ (directed_set_from_compact_basis B x) = x. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. exact (pr2 i). - use (is_least_upperbound_is_least (is_least_upperbound_compact_basis B x)). apply is_least_upperbound_is_upperbound. exact (is_least_upperbound_dcpo_lub (directed_set_from_compact_basis B x)). Qed. End CompactBasisInDCPO. Arguments compact_basis_laws : clear implicits. Arguments compact_basis : clear implicits. (** 3. Every compact basis gives rise to a basis *) Proposition compact_basis_to_dcpo_basis_laws {X : dcpo} (B : compact_basis X) : dcpo_basis_laws X B. Proof. intro x. split. - split. + assert (H := directed_set_el (directed_set_from_compact_basis B x)). revert H. use factor_through_squash ; [ apply propproperty | ]. intro i. refine (hinhpr (pr1 i ,, _)). exact (trans_way_below_le (is_compact_el_basis B (pr1 i)) (pr2 i)). + intros i j. assert (H := directed_set_top (directed_set_from_compact_basis B x) (pr1 i ,, way_below_to_le (pr2 i)) (pr1 j ,, way_below_to_le (pr2 j))). revert H. use factor_through_squash ; [ apply propproperty | ]. intro k. induction k as [ k [ p q ]]. refine (hinhpr ((pr1 k ,, _) ,, p ,, q)). exact (trans_way_below_le (is_compact_el_basis B (pr1 k)) (pr2 k)). - split. + intro i. exact (pr1 (is_least_upperbound_compact_basis B x) (pr1 i ,, way_below_to_le (pr2 i))). + intros y p. use (pr2 (is_least_upperbound_compact_basis B x) y). intro i. use (p (pr1 i ,, _)). exact (trans_way_below_le (is_compact_el_basis B (pr1 i)) (pr2 i)). Qed. Definition compact_basis_to_dcpo_basis {X : dcpo} (B : compact_basis X) : dcpo_basis X. Proof. use make_dcpo_basis. - exact B. - exact (compact_basis_to_dcpo_basis_laws B). Defined. (** 4. Compact bases from bases of which every element is compact *) Section BasisToCompact. Context {X : dcpo} (B : dcpo_basis X) (HB : ∏ (b : B), is_compact_el (B b)). Proposition dcpo_basis_with_compact_to_compact_basis_laws : compact_basis_laws X B. Proof. refine (_ ,, _ ,, _). - exact HB. - intro x. split. + assert (H := directed_set_el (directed_set_from_basis B x)). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b p ]. refine (hinhpr (b ,, _)). apply way_below_to_le. exact p. + intros i j. induction i as [ b₁ p₁ ]. induction j as [ b₂ p₂ ]. assert (q₁ : B b₁ ≪ x). { refine (compact_el_way_below_le _ p₁). apply HB. } assert (q₂ : B b₂ ≪ x). { refine (compact_el_way_below_le _ p₂). apply HB. } assert (H := directed_set_top (directed_set_from_basis B x) (b₁ ,, q₁) (b₂ ,, q₂)). revert H. use factor_through_squash. { apply propproperty. } intros t. induction t as [ [ t r₁ ] [ r₂ r₃ ]]. refine (hinhpr ((t ,, _) ,, (r₂ ,, r₃))). apply way_below_to_le. exact r₁. - intro x. split. + intros b. exact (pr2 b). + intros y Hy. use (pr2 (is_least_upperbound_basis B x) y). intros b. induction b as [ b p ]. use (Hy (b ,, _)). apply way_below_to_le. exact p. Qed. Definition dcpo_basis_with_compact_to_compact_basis : compact_basis X. Proof. use make_compact_basis. - exact B. - exact dcpo_basis_with_compact_to_compact_basis_laws. Defined. End BasisToCompact. (** 5. Compact bases versus algebraicity *) Definition algebraic_struct_from_compact_basis {X : dcpo} (B : compact_basis X) : algebraic_dcpo_struct X. Proof. intro x. refine (directed_set_from_compact_basis B x ,, _ ,, _). - intro i. apply is_compact_el_basis. - apply is_least_upperbound_compact_basis. Defined. Definition compact_basis_data_from_algebraic_struct {X : dcpo} (AX : algebraic_dcpo_struct X) : dcpo_basis_data X. Proof. use make_dcpo_basis_data. - exact (compact_elements X). - exact (λ x, pr1 x). Defined. Proposition compact_basis_laws_from_algebraic_struct {X : dcpo} (AX : algebraic_dcpo_struct X) : compact_basis_laws X (compact_basis_data_from_algebraic_struct AX). Proof. pose (CX := algebraic_dcpo_struct_to_continuous AX). simple refine (_ ,, _ ,, _). - intro b. exact (pr2 b). - intro x. pose (D := compact_approximating_family AX x). split. + assert (H := directed_set_el D). revert H. use factor_through_squash ; [ apply propproperty | ]. intro y. simple refine (hinhpr ((D y ,, _) ,, _)) ; cbn -[way_below]. * apply is_compact_approximating_family. * rewrite <- (compact_approximating_family_lub AX x). use (less_than_dcpo_lub D _ y). apply refl_dcpo. + intros y z. induction y as [ [ y Hy ] p ]. induction z as [ [ z Hz ] q ]. assert (Hxy : y ⊑ ⨆ D). { unfold D. rewrite (compact_approximating_family_lub AX x). exact p. } assert (Hxz : z ⊑ ⨆ D). { unfold D. rewrite (compact_approximating_family_lub AX x). exact q. } assert (H₁ := Hy D Hxy). revert H₁. use factor_through_squash ; [ apply propproperty | ]. intros i. induction i as [ i ri ]. assert (H₂ := Hz D Hxz). revert H₂. use factor_through_squash ; [ apply propproperty | ]. intros j. induction j as [ j rj ]. assert (H₃ := directed_set_top D i j). revert H₃. use factor_through_squash ; [ apply propproperty | ]. intros k. induction k as [ k [ s₁ s₂ ] ]. simple refine (hinhpr (((D k ,, _) ,, _) ,, (_ ,, _))). * apply is_compact_approximating_family. * cbn. rewrite <- (compact_approximating_family_lub AX x). use (less_than_dcpo_lub _ _ k). apply refl_dcpo. * exact (trans_dcpo ri s₁). * exact (trans_dcpo rj s₂). - intro x. split. + intros i. induction i as [ i p ]. exact p. + intros y Hy. rewrite <- (compact_approximating_family_lub AX x). use dcpo_lub_is_least. intro i. simple refine (Hy ((compact_approximating_family AX x i ,, _) ,, _)). * apply is_compact_approximating_family. * apply way_below_to_le. apply compact_approximating_family_way_below. Qed. Definition compact_basis_from_algebraic_struct {X : dcpo} (AX : algebraic_dcpo_struct X) : compact_basis X. Proof. use make_compact_basis. - exact (compact_basis_data_from_algebraic_struct AX). - exact (compact_basis_laws_from_algebraic_struct AX). Defined. (** 6. Constructing maps from their action on the basis *) Proposition scott_continuous_map_from_compact_basis_eq {X : dcpo} (B : compact_basis X) {Y : dcpo} (f : B → Y) (Hf : ∏ (i₁ i₂ : B), B i₁ ≪ B i₂ → f i₁ ⊑ f i₂) (i : B) : scott_continuous_map_from_basis (compact_basis_to_dcpo_basis B) f Hf (B i) = f i. Proof. use antisymm_dcpo. - apply scott_continuous_map_from_basis_le. - use less_than_dcpo_lub. + refine (i ,, _). apply is_compact_el_basis. + apply refl_dcpo. Qed. Definition scott_continuous_map_from_compact_basis_ump {X : dcpo} (B : compact_basis X) {Y : dcpo} (f : B → Y) (Hf : ∏ (i₁ i₂ : B), B i₁ ≪ B i₂ → f i₁ ⊑ f i₂) : ∃! (g : scott_continuous_map X Y), ∏ (i : B), g (B i) = f i. Proof. pose (CB := compact_basis_to_dcpo_basis B). use iscontraprop1. - abstract (use invproofirrelevance ; intros φ₁ φ₂ ; use subtypePath ; [ intro ; use impred ; intro ; apply setproperty | ] ; use (scott_continuous_map_eq_on_basis CB) ; intro i ; exact (pr2 φ₁ i @ !(pr2 φ₂ i))). - refine (scott_continuous_map_from_basis CB f Hf ,, _). apply scott_continuous_map_from_compact_basis_eq. Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Basis/Continuous.v000066400000000000000000000372341451125700300234410ustar00rootroot00000000000000(****************************************************************************** Continuous DCPOs We define the notion of continuous DCPOs. A DCPO is called continuous if every element is the least upper bound of a directed set consisting only of elements way below that element. Note that there are multiple ways to formulate this definition in univalent foundations: 1. We can formulate it as structure [continuous_dcpo_struct] 2. We can formulate it as a property [is_continuous_dcpo] There also is a third way, called pseudocontinuity, which also is a property. Furthermore, we study properties of continuous DCPOs. The first properties that we look at, characterize the order relation and the way-below relation in continuous DCPOs. The last properties that we look at, are about interpolation. These come in three flavors: 1. Nullary interpolation: given an element, we can find some element that is way-below the original element. 2. Unary interpolation: given two elements `x` and `y` such that `x ⊑ y`, we can find an element inbetween `x` and `y`: `x ≪ i ≪ y`. 3. Binary interpolation: given three elements `x₁, x₂, y` such that `x₁ ⊑ y` and `x₂ ⊑ y`, we can find an element `i` such that `x₁ ≪ i ≪ y` and `x₂ ≪ i ≪ y`. Note that we can generalize interpolation to finite sets. These interpolation properties are useful when proving stuff about continuous DCPOs. We also show that if a DCPO is continuous (as a property), then we have a canonical continuity structure on that DCPO. We define the approximating family for `x` to consist of all elements `y` such that `y ≪ x`. We can show that this set is directed, and for that we use that we know that the DCPO is continuous (as a property). We can use this assumption, because being directed is a proposition. In addition, we can also show that the supremum of the approximating family of `x` is indeed `x`. Here we again use the continuity, and since equality of elements in DCPOs is a proposition, we can indeed do so. Intuitively, what is happening here, is that there is a canonical choice for the approximating family, and this allows us to choose a continuity structure if we know one exists. References: - Section 2 in the chapter 'Domain Theory' of the Handbook for Logic in Computer Science, Volume 3 (https://www.cs.ox.ac.uk/files/298/handbook.pdf) - Section 4.4 and 4.5 in Domain Theory in Constructive and Predicative Univalent Foundations (https://tdejong.com/writings/phd-thesis.pdf) Contents 1. Continuous DCPOs (as structure) 2. Continuous DCPOs (as property) 3. Equivalent formulations of inequality in continuous DCPOs 4. Characterization of the way-below relation in continuous DCPOs 5. Nullary interpolation 6. Unary interpolation 7. Binary interpolation 8. Continuity structure from the property ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Local Open Scope dcpo. (** 1. Continuous DCPOs (as structure) *) Definition continuous_dcpo_struct (X : dcpo) : UU := ∏ (x : X), ∑ (D : directed_set X), (∏ (i : D), D i ≪ x) × is_least_upperbound X D x. (** 2. Continuous DCPOs (as property) *) Definition is_continuous_dcpo (X : dcpo) : hProp := ∥ continuous_dcpo_struct X ∥. Section ContinuousDCPOAccessors. Context {X : dcpo} (CX : continuous_dcpo_struct X). Definition approximating_family (x : X) : directed_set X := pr1 (CX x). Proposition approximating_family_way_below (x : X) (i : approximating_family x) : approximating_family x i ≪ x. Proof. exact (pr12 (CX x) i). Qed. Proposition approximating_family_lub (x : X) : ⨆ (approximating_family x) = x. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. apply way_below_to_le. exact (approximating_family_way_below x i). - use (is_least_upperbound_is_least (pr22 (CX x))). apply is_least_upperbound_is_upperbound. apply is_least_upperbound_dcpo_lub. Qed. End ContinuousDCPOAccessors. Section PropertiesContinuousDCPO. Context {X : dcpo} (CX : continuous_dcpo_struct X). (** 3. Equivalent formulations of inequality in continuous DCPOs *) Proposition continuous_dcpo_struct_le_to_way_below {x y : X} (p : x ⊑ y) (i : approximating_family CX x) : approximating_family CX x i ≪ y. Proof. use (trans_way_below_le _ p). apply approximating_family_way_below. Qed. Proposition continuous_dcpo_struct_approx_way_below_to_le {x y : X} (p : ∏ (i : approximating_family CX x), approximating_family CX x i ≪ y) (i : approximating_family CX x) : approximating_family CX x i ⊑ y. Proof. use way_below_to_le. apply p. Qed. Proposition continuous_dcpo_struct_approx_le_to_le {x y : X} (p : ∏ (i : approximating_family CX x), approximating_family CX x i ⊑ y) : x ⊑ y. Proof. rewrite <- (approximating_family_lub CX x). use dcpo_lub_is_least. exact p. Qed. Proposition continuous_dcpo_struct_le_weq_approx_le (x y : X) : x ⊑ y ≃ ∀ (i : approximating_family CX x), approximating_family CX x i ⊑ y. Proof. use weqimplimpl. - intros p i. apply continuous_dcpo_struct_approx_way_below_to_le. intro j. apply continuous_dcpo_struct_le_to_way_below. exact p. - intros H. apply continuous_dcpo_struct_approx_le_to_le. exact H. - apply propproperty. - apply propproperty. Qed. Proposition continuous_dcpo_struct_le_weq_approx_way_below (x y : X) : x ⊑ y ≃ ∀ (i : approximating_family CX x), approximating_family CX x i ≪ y. Proof. use weqimplimpl. - exact continuous_dcpo_struct_le_to_way_below. - intros H. apply continuous_dcpo_struct_approx_le_to_le. intro i. apply continuous_dcpo_struct_approx_way_below_to_le. exact H. - apply propproperty. - apply propproperty. Qed. Proposition continuous_dcpo_struct_le_via_approximation (x y : X) : x ⊑ y ≃ ∀ (z : X), (z ≪ x ⇒ z ≪ y)%logic. Proof. use weqimplimpl. - intros p z q. exact (trans_way_below_le q p). - intros H. rewrite <- (approximating_family_lub CX x). use dcpo_lub_is_least. pose (D := approximating_family CX x). fold D. intro i. apply way_below_to_le. apply (H (D i)). apply approximating_family_way_below. - apply propproperty. - apply propproperty. Qed. (** 4. Characterization of the way-below relation in continuous DCPOs *) Proposition continuous_dcpo_struct_way_below (x y : X) : x ≪ y ≃ ∃ (i : approximating_family CX y), x ⊑ approximating_family CX y i. Proof. use weqimplimpl. - intro p. apply (p (approximating_family CX y)). rewrite approximating_family_lub. apply refl_dcpo. - use factor_through_squash. { apply propproperty. } intro H. induction H as [ i p ]. refine (trans_le_way_below p _). apply approximating_family_way_below. - apply propproperty. - apply propproperty. Qed. (** 5. Nullary interpolation *) Proposition nullary_interpolation (x : X) : ∃ (y : X), y ≪ x. Proof. pose (D := approximating_family CX x). assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intro i. refine (hinhpr (D i ,, _)). apply approximating_family_way_below. Qed. (** 6. Unary interpolation *) Section UnaryInterpolation. Context {x y : X} (p : x ≪ y). Let D : directed_set X := approximating_family CX y. Let D_a : D → directed_set X := λ i, approximating_family CX (D i). Proposition unary_interpolation_cofinal_lem {i₁ i₂ : D} (q : D i₁ ⊑ D i₂) (j₁ : D_a i₁) : D_a i₁ j₁ ≪ ⨆ (D_a i₂). Proof. refine (trans_way_below_le _ _). - apply approximating_family_way_below. - refine (trans_dcpo q _). unfold D_a. rewrite approximating_family_lub. apply refl_dcpo. Qed. Proposition unary_interpolation_cofinal {i₁ i₂ : D} (q : D i₁ ⊑ D i₂) (j₁ : D_a i₁) : ∃ (j₂ : D_a i₂), D_a i₁ j₁ ⊑ D_a i₂ j₂. Proof. use (unary_interpolation_cofinal_lem q j₁ (D_a i₂)). apply refl_dcpo. Qed. Proposition is_directed_unary_interpolation_directed_set : is_directed X (λ (ij : ∑ (i : D), D_a i), D_a (pr1 ij) (pr2 ij)). Proof. split. - assert (H := directed_set_el D). revert H. use factor_through_squash ; [ apply propproperty | ]. intro i. assert (H := directed_set_el (D_a i)). revert H. use factor_through_squash ; [ apply propproperty | ]. intro j. exact (hinhpr (i ,, j)). - intros ij₁ ij₂. induction ij₁ as [ i₁ j₁ ]. induction ij₂ as [ i₂ j₂ ]. assert (H := directed_set_top D i₁ i₂). revert H. use factor_through_squash ; [ apply propproperty | ]. intros k. induction k as [ k [ q₁ q₂ ]]. assert (H := unary_interpolation_cofinal q₁ j₁). revert H. use factor_through_squash ; [ apply propproperty | ]. intros H₁. induction H₁ as [ l₁ H₁ ]. assert (H := unary_interpolation_cofinal q₂ j₂). revert H. use factor_through_squash ; [ apply propproperty | ]. intros H₂. induction H₂ as [ l₂ H₂ ]. assert (H := directed_set_top (D_a k) l₁ l₂). revert H. use factor_through_squash ; [ apply propproperty | ]. intros H. induction H as [ m [ r₁ r₂ ]]. refine (hinhpr ((k ,, m) ,, _ ,, _)). + exact (trans_dcpo H₁ r₁). + exact (trans_dcpo H₂ r₂). Qed. Definition unary_interpolation_directed_set : directed_set X. Proof. use make_directed_set. - exact (∑ (i : D), D_a i). - exact (λ ij, D_a (pr1 ij) (pr2 ij)). - exact is_directed_unary_interpolation_directed_set. Defined. Proposition unary_interpolation : ∃ (z : X), x ≪ z ∧ z ≪ y. Proof. assert (s : y ⊑ ⨆ unary_interpolation_directed_set). { apply continuous_dcpo_struct_approx_le_to_le. intro i. use continuous_dcpo_struct_approx_le_to_le. intro j. use less_than_dcpo_lub. { exact (i ,, j). } apply refl_dcpo. } assert (H := p unary_interpolation_directed_set s). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ i r ]. refine (hinhpr (D (pr1 i) ,, _ ,, _)). - refine (trans_le_way_below r _). apply approximating_family_way_below. - apply approximating_family_way_below. Qed. End UnaryInterpolation. (** 7. Binary interpolation *) Proposition binary_interpolation {x₁ x₂ y : X} (p₁ : x₁ ≪ y) (p₂ : x₂ ≪ y) : ∃ (z : X), x₁ ≪ z ∧ x₂ ≪ z ∧ z ≪ y. Proof. pose (D := approximating_family CX y). assert (s : y ⊑ ⨆ D). { unfold D. rewrite approximating_family_lub. apply refl_dcpo. } assert (z₁ := unary_interpolation p₁). revert z₁. use factor_through_squash. { apply propproperty. } intro z₁. induction z₁ as [ z₁ [ q₁ r₁ ]]. assert (H := r₁ D s). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ i₁ H₁ ]. assert (z₂ := unary_interpolation p₂). revert z₂. use factor_through_squash. { apply propproperty. } intro z₂. induction z₂ as [ z₂ [ q₂ r₂ ]]. assert (H := r₂ D s). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ i₂ H₂ ]. assert (H := directed_set_top D i₁ i₂). revert H. use factor_through_squash. { apply propproperty. } intros H. induction H as [ k [ w₁ w₂ ]]. refine (hinhpr (D k ,, _ ,, _ ,, _)). - exact (trans_way_below_le q₁ (trans_dcpo H₁ w₁)). - exact (trans_way_below_le q₂ (trans_dcpo H₂ w₂)). - apply approximating_family_way_below. Qed. End PropertiesContinuousDCPO. (** 8. Continuity structure from the property *) Proposition is_continuous_dcpo_is_directed {X : dcpo} (CX : is_continuous_dcpo X) (x : X) : is_directed X (λ (z : ∑ (b : X), b ≪ x), pr1 z). Proof. revert CX. use factor_through_squash_hProp. intros CX. pose (D := approximating_family CX x). split. - assert (H := directed_set_el D). revert H. use factor_through_squash_hProp. intros d. use hinhpr. refine (D d ,, _). apply approximating_family_way_below. - intros [ b₁ p₁ ] [ b₂ p₂ ]. assert (x ⊑ ⨆ D) as q. { rewrite <- (approximating_family_lub CX x). apply refl_dcpo. } assert (H := way_below_elem p₁ D q). revert H. use factor_through_squash_hProp. intros [ c₁ r₁ ]. assert (H := way_below_elem p₂ D q). revert H. use factor_through_squash_hProp. intros [ c₂ r₂ ]. assert (H := directed_set_top D c₁ c₂). revert H. use factor_through_squash_hProp. intros [ k [ s₂ s₃ ]]. use hinhpr. simple refine ((D k ,, _) ,, _ ,, _). + apply approximating_family_way_below. + exact (trans_dcpo r₁ s₂). + exact (trans_dcpo r₂ s₃). Qed. Definition is_continuous_dcpo_directed_set {X : dcpo} (CX : is_continuous_dcpo X) (x : X) : directed_set X. Proof. use make_directed_set. - exact (∑ (b : X), b ≪ x). - exact (λ z, pr1 z). - exact (is_continuous_dcpo_is_directed CX x). Defined. Proposition is_continuous_dcpo_directed_set_lub {X : dcpo} (CX : is_continuous_dcpo X) (x : X) : ⨆ (is_continuous_dcpo_directed_set CX x) = x. Proof. revert CX. use factor_dep_through_squash. { intro. apply setproperty. } intros CX. pose (D := approximating_family CX x). cbn. use antisymm_dcpo. - use dcpo_lub_is_least. intros i. apply way_below_to_le. exact (pr2 i). - refine (trans_dcpo _ _). { apply eq_to_le_dcpo. exact (!(approximating_family_lub CX x)). } use dcpo_lub_is_least. intros i. use less_than_dcpo_lub ; cbn -[way_below]. + refine (D i ,, _). apply approximating_family_way_below. + apply refl_dcpo. Qed. Definition is_continuous_to_continuous_struct {X : dcpo} (CX : is_continuous_dcpo X) : continuous_dcpo_struct X. Proof. intros x. refine (is_continuous_dcpo_directed_set CX x ,, _ ,, _). - abstract (intros i ; apply i). - abstract (pose (is_least_upperbound_dcpo_lub (is_continuous_dcpo_directed_set CX x)) as h ; rewrite (is_continuous_dcpo_directed_set_lub CX x) in h ; exact h). Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/000077500000000000000000000000001451125700300207225ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/Basics.v000066400000000000000000000216121451125700300223170ustar00rootroot00000000000000(***************************************************************** Basic notions in DCPOs In this file, we define the basic notions on DCPOs. We define a notion of DCPO structure on sets, because such a notion is necessary when using displayed categories. We also give bundled definitions, and we provide the necessary lemmas and notations for them. Note: in the definition of `directed_complete_poset`, there is a quantification over all `I` of type `UU`. The universe levels are left implicit in Coq, so implicitly, there is an argument that indicates the universe level of `I`. This corresponds to how DCPOs are developed in Tom de Jong's thesis. Contents 1. Upperbounds 2. DCPO structures 3. DCPOs 4. Accessors for DCPOs 5. Lemmas for least upperbounds 6. Pointed DCPOs *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Local Open Scope dcpo. (** 1. Upperbounds *) Section Upperbounds. Context {X : hSet} (PX : PartialOrder X) {I : UU} (D : I → X). Definition is_upperbound (x : X) : hProp := ∀ (i : I), PX (D i) x. Definition is_least_upperbound (x : X) : hProp := (is_upperbound x ∧ ∀ (y : X), is_upperbound y ⇒ PX x y)%logic. Proposition is_least_upperbound_is_upperbound {x : X} (Hx : is_least_upperbound x) : is_upperbound x. Proof. exact (pr1 Hx). Qed. Proposition is_least_upperbound_is_least {x : X} (Hx : is_least_upperbound x) {y : X} (Hy : is_upperbound y) : PX x y. Proof. exact (pr2 Hx y Hy). Qed. Definition lub : UU := ∑ (x : X), is_least_upperbound x. Definition make_lub (x : X) (Hx : is_least_upperbound x) : lub := x ,, Hx. Coercion lub_to_el (x : lub) : X := pr1 x. Proposition lub_is_upperbound (x : lub) : is_upperbound x. Proof. exact (is_least_upperbound_is_upperbound (pr2 x)). Qed. Proposition lub_is_least (x : lub) (y : X) (Hy : is_upperbound y) : PX x y. Proof. exact (is_least_upperbound_is_least (pr2 x) Hy). Qed. Proposition eq_lub {x y : X} (Hx : is_least_upperbound x) (Hy : is_least_upperbound y) : x = y. Proof. pose (x' := (x ,, Hx) : lub). pose (y' := (y ,, Hy) : lub). use (antisymm_PartialOrder PX). - apply (lub_is_least x' y'). exact (lub_is_upperbound y'). - apply (lub_is_least y' x'). exact (lub_is_upperbound x'). Qed. Definition isaprop_lub : isaprop lub. Proof. use invproofirrelevance. intros x₁ x₂. use subtypePath. { intro ; apply propproperty. } use eq_lub. - exact (pr2 x₁). - exact (pr2 x₂). Qed. End Upperbounds. Arguments is_least_upperbound_is_upperbound {X PX I D x} Hx. Arguments is_least_upperbound_is_least {X PX I D x} Hx. Arguments lub_is_upperbound {X PX I D} x. Arguments lub_is_least {X PX I D} x. (** 2. DCPO structures *) Definition directed_complete_poset {X : hSet} (PX : PartialOrder X) : UU := ∏ (I : UU) (f : I → X), is_directed PX f → lub PX f. Proposition isaprop_directed_complete_poset {X : hSet} (PX : PartialOrder X) : isaprop (directed_complete_poset PX). Proof. repeat (use impred ; intro). apply isaprop_lub. Qed. Definition dcpo_struct (X : hSet) : UU := ∑ (PX : PartialOrder X), directed_complete_poset PX. Definition make_dcpo_struct {X : hSet} (PX : PartialOrder X) (HX : directed_complete_poset PX) : dcpo_struct X := PX ,, HX. Proposition isaset_dcpo_struct (X : hSet) : isaset (dcpo_struct X). Proof. use isaset_total2. - apply isaset_PartialOrder. - intro. apply isasetaprop. apply isaprop_directed_complete_poset. Qed. Coercion dcpo_struct_to_PartialOrder {X : hSet} (DX : dcpo_struct X) : PartialOrder X := pr1 DX. Definition dcpo_struct_lub {X : hSet} (DX : dcpo_struct X) {I : UU} (f : I → X) (Hf : is_directed DX f) : lub DX f := pr2 DX I f Hf. (** 3. DCPOs *) Definition dcpo : UU := ∑ (X : hSet), dcpo_struct X. Coercion dcpo_to_hSet (X : dcpo) : hSet := pr1 X. Coercion dcpo_to_PartialOrder (X : dcpo) : PartialOrder X := pr12 X. Definition dcpo_order {X : dcpo} (x y : X) : hProp := pr12 X x y. Notation "x ⊑ y" := (dcpo_order x y) (no associativity, at level 70) : dcpo. (* ⊑ - \sqsubseteq *) (** 4. Accessors for DCPOs *) Proposition refl_dcpo {X : dcpo} (x : X) : x ⊑ x. Proof. apply refl_PartialOrder. Qed. Definition eq_to_le_dcpo {X : dcpo} {x y : X} (p : x = y) : x ⊑ y. Proof. induction p. apply refl_dcpo. Qed. Proposition trans_dcpo {X : dcpo} {x y z : X} (p : x ⊑ y) (q : y ⊑ z) : x ⊑ z. Proof. exact (trans_PartialOrder X p q). Qed. Proposition antisymm_dcpo {X : dcpo} {x y : X} (p : x ⊑ y) (q : y ⊑ x) : x = y. Proof. exact (antisymm_PartialOrder X p q). Qed. Definition dcpo_lub {X : dcpo} (D : directed_set X) : X := pr22 X _ D (directed_set_is_directed D). Notation "⨆ D" := (dcpo_lub D) (at level 20) : dcpo. (* ⊔ - \sqcup *) Notation "⨆_{ D } f" := (⨆ (f {{ D }})) (at level 20) : dcpo. Definition make_dcpo_is_least_upperbound {X : dcpo} (D : directed_set X) (x : X) (H₁ : ∏ (i : D), D i ⊑ x) (H₂ : ∏ (x' : X), (∏ (i : D), D i ⊑ x') → x ⊑ x') : is_least_upperbound X D x. Proof. split. - exact H₁. - exact H₂. Qed. Proposition is_least_upperbound_dcpo_lub {X : dcpo} (D : directed_set X) : is_least_upperbound X D (⨆ D). Proof. apply (pr22 X _ D (directed_set_is_directed D)). Qed. Proposition less_than_dcpo_lub {X : dcpo} (D : directed_set X) (x : X) (i : D) (H : x ⊑ D i) : x ⊑ ⨆ D. Proof. exact (trans_PartialOrder X H (is_least_upperbound_is_upperbound (is_least_upperbound_dcpo_lub D) i)). Qed. Proposition dcpo_lub_is_least {X : dcpo} (D : directed_set X) (x : X) (H : ∏ (i : D), D i ⊑ x) : ⨆ D ⊑ x. Proof. exact (is_least_upperbound_is_least (is_least_upperbound_dcpo_lub D) x H). Qed. (** 5. Lemmas for least upperbounds *) Proposition const_lub {X : dcpo} (x : X) (I : UU) (i : ∥ I ∥) : ⨆ (const_directed_set X x I i) = x. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro j ; cbn. apply refl_dcpo. - revert i. use factor_dep_through_squash. { intro i. apply propproperty. } intro i ; cbn. use less_than_dcpo_lub. + exact i. + cbn. apply refl_dcpo. Qed. Proposition is_least_upperbound_dcpo_comp_lub {X Y : dcpo} (f : monotone_function X Y) (D : directed_set X) : is_least_upperbound Y (f{{D}}) (⨆_{ D } f). Proof. apply is_least_upperbound_dcpo_lub. Qed. Proposition dcpo_lub_eq_pointwise {X Y : dcpo} (f f' : monotone_function X Y) (D : directed_set X) (H : ∏ (x : X), f x = f' x) : ⨆_{D} f = ⨆_{D} f'. Proof. apply maponpaths. apply maponpaths_2. apply eq_monotone_function. exact H. Qed. (** 6. Pointed DCPOs *) Definition dcppo_struct (X : hSet) : UU := ∑ (DX : dcpo_struct X), bottom_element DX. Coercion dcppo_struct_to_dcpo_struct {X : hSet} (DX : dcppo_struct X) : dcpo_struct X := pr1 DX. Coercion dcppo_to_pointed_PartialOrder {X : hSet} (DX : dcppo_struct X) : pointed_PartialOrder X := pr11 DX ,, pr2 DX. Proposition isaset_dcppo_struct (X : hSet) : isaset (dcppo_struct X). Proof. use isaset_total2. - exact (isaset_dcpo_struct X). - intro. apply isasetaprop. apply isaprop_bottom_element. Qed. Definition dcppo : UU := ∑ (X : hSet), dcppo_struct X. Coercion dcppo_to_dcpo (X : dcppo) : dcpo := pr1 X ,, pr12 X. Definition bottom_dcppo (X : dcppo) : X := pr122 X. Notation "⊥_{ X }" := (bottom_dcppo X) : dcpo. (* ⊥ - \bot*) Proposition is_min_bottom_dcppo {X : dcppo} (x : X) : ⊥_{ X } ⊑ x. Proof. exact (pr222 X x). Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/CoordinateContinuity.v000066400000000000000000000056731451125700300253010ustar00rootroot00000000000000(***************************************************************** Scott Continuity can be checked coordinatewise *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.FubiniTheorem. Require Import UniMath.OrderTheory.DCPOs.Examples.BinaryProducts. Local Open Scope dcpo. Section Coordinates. Context {X Y Z : dcpo} (f : X × Y → Z) (Hf₁ : ∏ (x : X), is_scott_continuous Y Z (λ y, f (x ,, y))) (Hf₂ : ∏ (y : Y), is_scott_continuous X Z (λ x, f (x ,, y))). Lemma scott_continuous_map_coordinates_monotone : is_monotone (X × Y) Z f. Proof. intros xy₁ xy₂ pq. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. induction pq as [ p q ]. pose (is_scott_continuous_monotone (Hf₁ x₁) _ _ q) as r₁. pose (is_scott_continuous_monotone (Hf₂ y₂) _ _ p) as r₂. cbn in *. exact (trans_PartialOrder Z r₁ r₂). Qed. Let F : monotone_function (X × Y) Z := _ ,, scott_continuous_map_coordinates_monotone. Let Fy (D : directed_set (X × Y)) : scott_continuous_map X Z := _ ,, Hf₂ (⨆ (π₂ {{ D }})). Lemma scott_continuous_map_coordinates_lub (D : directed_set (X × Y)) : F (⨆ D) = ⨆ (F {{ D }}). Proof. rewrite prod_dcpo_lub. etrans. { exact (scott_continuous_map_on_lub (Fy D) (π₁ {{ D }})). } refine (_ @ !(monotone_prod_map_fubini_pair_l _ _)). use dcpo_lub_eq_pointwise. intro i ; cbn. etrans. { exact (scott_continuous_map_on_lub (_ ,, Hf₁ i) (π₂ {{ D }})). } use dcpo_lub_eq_pointwise. intro. apply idpath. Qed. Proposition scott_continuous_map_coordinates : scott_continuous_map (X × Y) Z. Proof. refine (f ,, _). use is_scott_continuous_chosen_lub. - exact scott_continuous_map_coordinates_monotone. - intros I D HD. exact (scott_continuous_map_coordinates_lub (I ,, D ,, HD)). Defined. End Coordinates. Proposition is_scott_continuous_coordinates {X Y Z : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (DZ : dcpo_struct Z) (f : X × Y → Z) (Hf₁ : ∏ (x : X), is_scott_continuous DY DZ (λ y, f (x ,, y))) (Hf₂ : ∏ (y : Y), is_scott_continuous DX DZ (λ x, f (x ,, y))) : is_scott_continuous (prod_dcpo_struct DX DY) DZ f. Proof. exact (pr2 (@scott_continuous_map_coordinates (X ,, DX) (Y ,, DY) (Z ,, DZ) f Hf₁ Hf₂)). Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/DirectedSets.v000066400000000000000000000167561451125700300235120ustar00rootroot00000000000000(***************************************************************** Directed sets To define DCPOs, we need a suitable notion of directed sets. In this file, we define these basic notions and give some elementary constructions of directed sets. Contents 1. Directed sets in a poset 2. Accessors and builders 3. Precomposing a directed set with a monotone map 4. The constant directed set 5. The product of directed sets 6. Directed sets indexed by the natural numbers *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Declare Scope dcpo. Delimit Scope dcpo with dcpo. (** 1. Directed sets in a poset *) Section Directed. Context {X : hSet} (PX : PartialOrder X) {I : UU} (D : I → X). Definition is_directed : hProp := ∥ I ∥ ∧ ∀ (i j : I), ∃ (k : I), PX (D i) (D k) × PX (D j) (D k). Definition is_directed_el (H : is_directed) : ∥ I ∥ := pr1 H. Definition is_directed_top (H : is_directed) (i j : I) : ∃ (k : I), PX (D i) (D k) × PX (D j) (D k) := pr2 H i j. End Directed. Arguments is_directed_el {X PX I D} H. Arguments is_directed_top {X PX I D} H i j. Definition directed_set {X : hSet} (PX : PartialOrder X) : UU := ∑ (I : UU) (D : I → X), is_directed PX D. (** 2. Accessors and builders *) Coercion directed_set_dom {X : hSet} {PX : PartialOrder X} (D : directed_set PX) : UU := pr1 D. Definition directed_set_map {X : hSet} {PX : PartialOrder X} (D : directed_set PX) : directed_set_dom D → X := pr12 D. Coercion directed_set_map : directed_set >-> Funclass. Definition directed_set_is_directed {X : hSet} {PX : PartialOrder X} (D : directed_set PX) : is_directed PX D := pr22 D. Definition directed_set_el {X : hSet} {PX : PartialOrder X} (D : directed_set PX) : ∥ D ∥ := is_directed_el (directed_set_is_directed D). Definition directed_set_top {X : hSet} {PX : PartialOrder X} (D : directed_set PX) (i j : D) : ∃ (k : D), PX (D i) (D k) × PX (D j) (D k) := is_directed_top (directed_set_is_directed D) i j. Definition make_directed_set {X : hSet} (PX : PartialOrder X) (I : UU) (D : I → X) (HD : is_directed PX D) : directed_set PX := I ,, (D ,, HD). (** 3. Precomposing a directed set with a monotone map *) Proposition is_directed_comp {X Y : hSet} {PX : PartialOrder X} {PY : PartialOrder Y} (f : X → Y) (Hf : is_monotone PX PY f) {I : UU} {D : I → X} (HD : is_directed PX D) : is_directed PY (λ i, f(D i)). Proof. induction HD as [ H₁ H₂ ]. split. - exact H₁. - clear H₁. intros i j. specialize (H₂ i j). revert H₂. use factor_through_squash. { apply propproperty. } intros kp. apply hinhpr. refine (pr1 kp ,, _ ,, _). + apply Hf. exact (pr12 kp). + apply Hf. exact (pr22 kp). Qed. Definition directed_set_comp {X Y : hSet} {PX : PartialOrder X} {PY : PartialOrder Y} (f : monotone_function PX PY) (D : directed_set PX) : directed_set PY. Proof. use (make_directed_set _ D). - exact (λ i, f(D i)). - use (is_directed_comp f (pr2 f)). exact (directed_set_is_directed D). Defined. Notation "f '{{' D '}}'" := (directed_set_comp f D) (at level 30) : dcpo. (** 4. The constant directed set *) Proposition is_directed_const {X : hSet} (PX : PartialOrder X) (x : X) (I : UU) (i : ∥ I ∥) : is_directed PX (λ _ : I, x). Proof. split. - exact i. - intros i₁ i₂. apply hinhpr. exists i₁. split ; apply refl_PartialOrder. Qed. Definition const_directed_set {X : hSet} (PX : PartialOrder X) (x : X) (I : UU) (i : ∥ I ∥) : directed_set PX. Proof. use (make_directed_set _ I). - exact (λ _, x). - exact (is_directed_const PX x I i). Defined. (** 5. The product of directed sets *) Proposition is_directed_prod {X Y : hSet} {PX : PartialOrder X} {PY : PartialOrder Y} (D₁ : directed_set PX) (D₂ : directed_set PY) : is_directed (prod_PartialOrder PX PY) (λ (xy : D₁ × D₂), D₁ (pr1 xy),, D₂ (pr2 xy)). Proof. split. - assert (i₁ := directed_set_el D₁). assert (i₂ := directed_set_el D₂). apply hinhand; assumption. - intros ij₁ ij₂. induction ij₁ as [ i₁ j₁ ]. induction ij₂ as [ i₂ j₂ ]. assert (k₁ := directed_set_top D₁ i₁ i₂). assert (k₂ := directed_set_top D₂ j₁ j₂). simple refine (hinhuniv2 _ k₁ k₂). clear k₁ k₂. intros k₁ k₂. induction k₁ as [ k₁ [ H₁ H₂ ]]. induction k₂ as [ k₂ [ H₃ H₄ ]]. refine (hinhpr ((k₁ ,, k₂) ,, _)) ; cbn. split. + exact (H₁ ,, H₃). + exact (H₂ ,, H₄). Qed. Definition prod_directed_set {X Y : hSet} {PX : PartialOrder X} {PY : PartialOrder Y} (D₁ : directed_set PX) (D₂ : directed_set PY) : directed_set (prod_PartialOrder PX PY). Proof. use make_directed_set. - exact (D₁ × D₂). - exact (λ xy, D₁ (pr1 xy) ,, D₂ (pr2 xy)). - exact (is_directed_prod D₁ D₂). Defined. (** 6. Directed sets indexed by the natural numbers *) Proposition is_directed_nat {X : hSet} (PX : PartialOrder X) (D : ℕ → X) (HD : ∏ (i j : ℕ), i ≤ j → PX (D i) (D j)) : is_directed PX D. Proof. split. - exact (hinhpr 0). - intros i₁ i₂. assert (p := istotalnatleh i₁ i₂). revert p. use factor_through_squash. { apply propproperty. } intro p. apply hinhpr. induction p as [ p | p ]. + refine (i₂ ,, HD _ _ _ ,, HD _ _ _). * exact p. * apply isreflnatleh. + refine (i₁ ,, HD _ _ _ ,, HD _ _ _). * apply isreflnatleh. * exact p. Qed. Definition nat_directed_set_monotone {X : hSet} (PX : PartialOrder X) (D : ℕ → X) (HD : ∏ (i j : ℕ), i ≤ j → PX (D i) (D j)) : directed_set PX := ℕ ,, D ,, is_directed_nat PX D HD. Proposition nat_directed_set_help_monotone {X : hSet} (PX : PartialOrder X) (D : ℕ → X) (HD : ∏ (i : ℕ), PX (D i) (D (S i))) (i k : ℕ) : PX (D i) (D (i + k)). Proof. induction k as [ | k IHk ]. - rewrite natplusr0. apply refl_PartialOrder. - rewrite <- plus_n_Sm. refine (trans_PartialOrder PX IHk _). apply HD. Qed. Definition nat_directed_set {X : hSet} (PX : PartialOrder X) (D : ℕ → X) (HD : ∏ (i : ℕ), PX (D i) (D (S i))) : directed_set PX. Proof. use (nat_directed_set_monotone PX D). abstract (intros i j p ; pose (k := nat_le_diff p) ; induction k as [ k q ] ; rewrite <- q ; use nat_directed_set_help_monotone ; exact HD). Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/FubiniTheorem.v000066400000000000000000000146751451125700300236660ustar00rootroot00000000000000(***************************************************************** A Fubini-like Theorem for DCPOs Fubini's theorem in analysis allows one to swap double integrals. For DCPO's, we can state a similar theorem, namely that one can switch the order of double suprema. Contents 1. Preliminary definitions 2. Fubini's theorem *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Examples.BinaryProducts. Local Open Scope dcpo. (** 1. Preliminary definitions *) Definition monotone_function_app_l {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (x : X) : monotone_function Y Z. Proof. simple refine (_ ,, _). - exact (λ y, f (x ,, y)). - abstract (intros y₁ y₂ p ; cbn ; apply f ; exact (refl_PartialOrder X x ,, p)). Defined. Definition monotone_function_app_r {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (y : Y) : monotone_function X Z. Proof. simple refine (_ ,, _). - exact (λ x, f (x ,, y)). - abstract (intros y₁ y₂ p ; cbn ; apply f ; exact (p ,, refl_PartialOrder Y y)). Defined. Notation "f ·l x" := (monotone_function_app_l f x) (at level 60). Notation "f ·r y" := (monotone_function_app_r f y) (at level 60). Definition fubini_monotone_function_l {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (D : directed_set (X × Y)) : monotone_function X Z. Proof. refine ((λ x, ⨆_{π₂ {{ D }}} (f ·l x)) ,, _). abstract (intros x₁ x₂ p ; use dcpo_lub_is_least ; cbn ; intro i ; use less_than_dcpo_lub ; [ exact i | ] ; cbn ; apply f ; split ; [ exact p | ] ; apply refl_PartialOrder). Defined. Definition fubini_monotone_function_r {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (D : directed_set (X × Y)) : monotone_function Y Z. Proof. refine ((λ x, ⨆_{π₁ {{ D }}} (f ·r x)) ,, _). abstract (intros x₁ x₂ p ; use dcpo_lub_is_least ; cbn ; intro i ; use less_than_dcpo_lub ; [ exact i | ] ; cbn ; apply f ; split ; [ | exact p ] ; apply refl_PartialOrder). Defined. (** 2. Fubini's theorem *) Proposition monotone_prod_map_fubini_pair_l {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (D : directed_set (X × Y)) : ⨆_{D} f = ⨆_{π₁ {{D}}} fubini_monotone_function_l f D. Proof. use (eq_lub Z (f {{ D }})). - apply is_least_upperbound_dcpo_comp_lub. - use make_dcpo_is_least_upperbound. + cbn ; intro i. use less_than_dcpo_lub. * exact i. * cbn. use less_than_dcpo_lub. ** exact i. ** apply refl_PartialOrder. + intros x' Hx'. use dcpo_lub_is_least ; cbn ; cbn in Hx'. intro i. use dcpo_lub_is_least ; cbn. intro j. assert (H := is_directed_top (directed_set_is_directed D) i j). revert H. use factor_through_squash. { apply propproperty. } intros kH. induction kH as [ k [ H₁ H₂ ]]. refine (trans_PartialOrder Z _ (Hx' k)). apply f. split. * exact (pr1 H₁). * exact (pr2 H₂). Qed. Proposition monotone_prod_map_fubini_pair_r {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (D : directed_set (X × Y)) : ⨆_{D} f = ⨆_{π₂ {{D}}} fubini_monotone_function_r f D. Proof. use (eq_lub Z (f {{ D }})). - apply is_least_upperbound_dcpo_comp_lub. - use make_dcpo_is_least_upperbound. + cbn ; intro i. use less_than_dcpo_lub. * exact i. * cbn. use less_than_dcpo_lub. ** exact i. ** apply refl_PartialOrder. + intros x' Hx'. use dcpo_lub_is_least ; cbn ; cbn in Hx'. intro i. use dcpo_lub_is_least ; cbn. intro j. assert (H := is_directed_top (directed_set_is_directed D) i j). revert H. use factor_through_squash. { apply propproperty. } intros kH. induction kH as [ k [ H₁ H₂ ]]. refine (trans_PartialOrder Z _ (Hx' k)). apply f. use prod_dcpo_le ; cbn. * exact (pr1 H₂). * exact (pr2 H₁). Qed. Proposition monotone_fubini_swap {X Y Z : dcpo} (f : monotone_function (X × Y) Z) (D : directed_set (X × Y)) : ⨆_{π₁ {{D}}} fubini_monotone_function_l f D = ⨆_{π₂ {{D}}} fubini_monotone_function_r f D. Proof. rewrite <- monotone_prod_map_fubini_pair_l. rewrite <- monotone_prod_map_fubini_pair_r. apply idpath. Qed. Proposition monotone_fubini_swap' {X Y Z : dcpo} (D₁ : directed_set X) (D₂ : directed_set Y) (f : monotone_function (X × Y) Z) : ⨆_{D₁} (fubini_monotone_function_l f (prod_directed_set D₁ D₂)) = ⨆_{D₂} (fubini_monotone_function_r f (prod_directed_set D₁ D₂)). Proof. refine (_ @ monotone_fubini_swap f (prod_directed_set D₁ D₂) @ _). - use antisymm_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact (i ,, pr2 j). * cbn. use less_than_dcpo_lub. ** exact (i ,, pr2 j). ** cbn. apply refl_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact (pr1 i). * cbn. use less_than_dcpo_lub. ** exact j. ** cbn. apply refl_dcpo. - use antisymm_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact (pr2 i). * cbn. use less_than_dcpo_lub. ** exact j. ** cbn. apply refl_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact (pr1 j ,, i). * cbn. use less_than_dcpo_lub. ** exact (pr1 j ,, i). ** cbn. apply refl_dcpo. Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/IntrinsicApartness.v000066400000000000000000000145641451125700300247460ustar00rootroot00000000000000(****************************************************************************** The intrinsic apartness relation of a DCPO Every DCPO gives rise to an intrinsic apartness relation. To define it, we take the following steps 1. We define the specialization preorder. An element `x` is a specialization of an element `y` if every open set that contains `x` also contains `y`. 2. We define the `does not specialize` relation. Classically, this relation is equivalent to the negation of the specialization preorder, but constructively, that is not true. 3. We define the intrinsic apartness relation. Note that in general, the intrinsic apartness relation is neither tight nor cotransitive in constructive foundations. See Theorem 5.6 in https://arxiv.org/pdf/2106.05064.pdf We also prove some properties of every relation that we define in this file. Contents 1. The specialization preorder 2. Properties of the specialization preorder 3. The 'does not specialize' relation 4. Properties of the 'does not specialize' relation 5. The intrinsic apartness relation 6. Properties of the intrinsic apartness relation ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. (** 1. The specialization preorder *) Definition dcpo_specialization {X : dcpo} (x y : X) : hProp := (∀ (P : X → hProp), is_scott_open P ⇒ P x ⇒ P y)%logic. Notation "x ⊑s y" := (dcpo_specialization x y) (at level 70) : dcpo. (** 2. Properties of the specialization preorder *) Section PropertiesSpecialization. Context {X : dcpo}. Proposition refl_dcpo_specialization (x : X) : x ⊑s x. Proof. intros P HP Px. exact Px. Qed. Proposition trans_dcpo_specialization {x y z : X} (p : x ⊑s y) (q : y ⊑s z) : x ⊑s z. Proof. intros P HP Px. apply (q P HP). apply (p P HP Px). Qed. Proposition le_dcpo_specialization {x y : X} (p : x ⊑ y) : x ⊑s y. Proof. intros P HP Px. exact (is_scott_open_upper_set HP Px p). Qed. Proposition le_dcpo_specialization_equiv (CX : continuous_dcpo_struct X) (x y : X) : x ⊑ y ≃ x ⊑s y. Proof. use weqimplimpl. - exact le_dcpo_specialization. - intros p. use (invmap (continuous_dcpo_struct_le_via_approximation CX x y)). intro z. intro q. exact (p _ (upper_set_is_scott_open CX z) q). - apply propproperty. - apply propproperty. Qed. End PropertiesSpecialization. (** 3. The 'does not specialize' relation *) Definition dcpo_not_specialization {X : dcpo} (x y : X) : hProp := (∃ (P : X → hProp), is_scott_open P ∧ P x ∧ ¬(P y))%logic. Notation "x ⊄ y" := (dcpo_not_specialization x y) (at level 70) : dcpo. (* \nsubset *) (** 4. Properties of the 'does not specialize' relation *) Section PropertiesNotSpecialization. Context {X : dcpo}. Proposition irrefl_dcpo_not_specialization (x : X) : ¬(x ⊄ x). Proof. use factor_through_squash. { apply isapropempty. } intro P. induction P as [ P [ HP [ p n ]]]. exact (n p). Qed. Proposition dcpo_not_specialization_le {x y : X} (p : x ⊄ y) : ¬(x ⊑ y). Proof. intro q. revert p. use factor_through_squash. { apply isapropempty. } intros P. induction P as [ P [ HP [ Px Py ]]]. refine (Py _). exact (is_scott_open_upper_set HP Px q). Qed. Proposition continuous_not_specialization_weq (CX : continuous_dcpo_struct X) (x y : X) : x ⊄ y ≃ (∃ (b : X), b ≪ x ∧ ¬(b ⊑ y))%logic. Proof. use weqimplimpl. - use factor_through_squash. { apply propproperty. } intros P. induction P as [ P [ HP [ p₁ p₂ ]]] ; cbn in p₂. pose (D := approximating_family CX x). assert (HD : P (⨆ D)). { unfold D. rewrite approximating_family_lub. exact p₁. } assert (H := is_scott_open_lub_inaccessible HP D HD). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ i Pi ]. refine (hinhpr (D i ,, _ ,, _)). + apply approximating_family_way_below. + intro n. apply p₂. apply (is_scott_open_upper_set HP Pi n). - use factor_through_squash. { apply propproperty. } intro b. induction b as [ b [ p₁ p₂ ]] ; cbn in p₂. apply hinhpr. refine (_ ,, upper_set_is_scott_open CX b ,, p₁ ,, _). intro p. apply p₂. apply way_below_to_le. exact p. - apply propproperty. - apply propproperty. Qed. End PropertiesNotSpecialization. (** 5. The intrinsic apartness relation *) Definition dcpo_intrinsic_apartness {X : dcpo} (x y : X) : hProp := dcpo_not_specialization x y ∨ dcpo_not_specialization y x. Notation "x # y" := (dcpo_intrinsic_apartness x y). (** 6. Properties of the intrinsic apartness relation *) Section PropertiesApartness. Context {X : dcpo}. Proposition irrefl_intrinsic_apartness (x : X) : ¬(x # x). Proof. use factor_through_squash. { apply isapropempty. } intros p. induction p as [ p | p ]. - apply (irrefl_dcpo_not_specialization x). exact p. - apply (irrefl_dcpo_not_specialization x). exact p. Qed. Proposition symmetric_intrinsic_apartness {x y : X} (p : x # y) : y # x. Proof. revert p. use factor_through_squash. { apply propproperty. } intros p. induction p as [ p | p ]. - exact (hinhpr (inr p)). - exact (hinhpr (inl p)). Qed. Proposition intrinsic_apartness_not_eq {x y : X} (p : x # y) : ¬(x = y). Proof. intro q. induction q. exact (irrefl_intrinsic_apartness x p). Qed. End PropertiesApartness. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/ScottContinuous.v000066400000000000000000000376441451125700300243120ustar00rootroot00000000000000(***************************************************************** Scott Continuous functions We define the notion of Scott continuous functions between DCPOs. Again we give both bundled and unbundled definitions: the former is more convenient to use while the latter is necessary in the setting of displayed categories. Contents 1. Scott continuity 2. Accessors for scott continuity 3. Examples of Scott continuous maps 4. Structure-identity 5. Bundled approach 6. Accessors and builders for the bundled approach 7. Examples of Scott continuous maps (bundled) 8. Scott continuous maps are continuous in the Scott topology 9. Scott continuous maps reflect apartness *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Import UniMath.OrderTheory.DCPOs.Core.IntrinsicApartness. Local Open Scope dcpo. (** 1. Scott continuity *) Definition is_scott_continuous {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (f : X → Y) : UU := is_monotone DX DY f × (∀ (I : UU) (D : I → X) (HD : is_directed DX D) (x : X) (Hx : is_least_upperbound DX D x), is_least_upperbound DY (λ i, f(D i)) (f x)). Definition is_strict_scott_continuous {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) (f : X → Y) : UU := is_scott_continuous DX DY f × f (pointed_PartialOrder_to_point DX) = pointed_PartialOrder_to_point DY. Coercion is_strict_scott_continuous_to_scott_continuous {X Y : hSet} {DX : dcppo_struct X} {DY : dcppo_struct Y} {f : X → Y} (Hf : is_strict_scott_continuous DX DY f) : is_scott_continuous DX DY f := pr1 Hf. (** 2. Accessors for scott continuity *) Proposition isaprop_is_scott_continuous {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (f : X → Y) : isaprop (is_scott_continuous DX DY f). Proof. use isapropdirprod. - apply isaprop_is_monotone. - apply propproperty. Qed. Proposition isaprop_is_strict_scott_continuous {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) (f : X → Y) : isaprop (is_strict_scott_continuous DX DY f). Proof. use isapropdirprod. - apply isaprop_is_scott_continuous. - apply setproperty. Qed. Proposition is_scott_continuous_monotone {X Y : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {f : X → Y} (Df : is_scott_continuous DX DY f) : is_monotone DX DY f. Proof. exact (pr1 Df). Qed. Proposition is_scott_continuous_lub {X Y : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {f : X → Y} (Df : is_scott_continuous DX DY f) {I : UU} {D : I → X} (HD : is_directed DX D) (x : X) (Hx : is_least_upperbound DX D x) : is_least_upperbound DY (λ i, f(D i)) (f x). Proof. exact (pr2 Df I D HD x Hx). Qed. Proposition is_scott_continuous_chosen_lub {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (f : X → Y) (Hf₁ : is_monotone DX DY f) (Hf₂ : ∏ (I : UU) (D : I → X) (HD : is_directed DX D), f (dcpo_struct_lub DX D HD) = dcpo_struct_lub DY (λ i, f (D i)) (is_directed_comp f Hf₁ HD)) : is_scott_continuous DX DY f. Proof. split. - exact Hf₁. - intros I D HD x Hx. refine (transportb (λ z, is_least_upperbound _ _ z) (maponpaths f _ @ Hf₂ I D HD) _). + exact (maponpaths pr1 (proofirrelevance _ (isaprop_lub DX D) (x ,, Hx) (dcpo_struct_lub DX D HD))). + apply dcpo_struct_lub. Qed. Proposition is_scott_continuous_on_lub {X Y : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {f : X → Y} (Hf : is_scott_continuous DX DY f) {I : UU} (D : I → X) (HD : is_directed DX D) : f (dcpo_struct_lub DX D HD) = dcpo_struct_lub DY (λ i, f (D i)) (is_directed_comp f (pr1 Hf) HD). Proof. use (eq_lub DY (λ i, f(D i))). - use (is_scott_continuous_lub Hf HD). apply dcpo_struct_lub. - apply dcpo_struct_lub. Qed. Proposition is_strict_scott_continuous_on_bot {X Y : hSet} {DX : dcppo_struct X} {DY : dcppo_struct Y} {f : X → Y} (Hf : is_strict_scott_continuous DX DY f) : f (pointed_PartialOrder_to_point DX) = pointed_PartialOrder_to_point DY. Proof. exact (pr2 Hf). Qed. (** 3. Examples of Scott continuous maps *) Proposition id_is_scott_continuous {X : hSet} (DX : dcpo_struct X) : is_scott_continuous DX DX (λ x, x). Proof. split. - intros x₁ x₂ p. exact p. - intros I D HD x Hx. exact Hx. Qed. Proposition id_is_strict_scott_continuous {X : hSet} (DX : dcppo_struct X) : is_strict_scott_continuous DX DX (λ x, x). Proof. split. - apply id_is_scott_continuous. - apply idpath. Qed. Proposition comp_is_scott_continuous {X Y Z : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {DZ : dcpo_struct Z} {f : X → Y} {g : Y → Z} (Df : is_scott_continuous DX DY f) (Dg : is_scott_continuous DY DZ g) : is_scott_continuous DX DZ (λ x, g(f x)). Proof. split. - intros x₁ x₂ p. apply (is_scott_continuous_monotone Dg). apply (is_scott_continuous_monotone Df). exact p. - intros I D HD x Hx. use (is_scott_continuous_lub Dg). + exact (is_directed_comp _ (pr1 Df) HD). + use (is_scott_continuous_lub Df HD). exact Hx. Qed. Proposition comp_is_strict_scott_continuous {X Y Z : hSet} {DX : dcppo_struct X} {DY : dcppo_struct Y} {DZ : dcppo_struct Z} {f : X → Y} {g : Y → Z} (Df : is_strict_scott_continuous DX DY f) (Dg : is_strict_scott_continuous DY DZ g) : is_strict_scott_continuous DX DZ (λ x, g(f x)). Proof. split. - exact (comp_is_scott_continuous Df Dg). - rewrite (is_strict_scott_continuous_on_bot Df). exact (is_strict_scott_continuous_on_bot Dg). Qed. Proposition is_scott_continuous_constant {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (y : Y) : is_scott_continuous DX DY (λ _, y). Proof. split. - intros x₁ x₂ p. apply refl_PartialOrder. - intros I D HD x HX. split. + intro i. apply refl_PartialOrder. + intros z Hz. cbn in *. induction HD as [ i HD ]. revert i. use factor_through_squash. { apply propproperty. } exact Hz. Qed. Proposition is_strict_scott_continuous_constant {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) : is_strict_scott_continuous DX DY (λ _, pointed_PartialOrder_to_point DY). Proof. split. - apply is_scott_continuous_constant. - apply idpath. Qed. (** 4. Structure-identity *) Proposition eq_dcpo_struct {X : hSet} (DX DX' : dcpo_struct X) (H₁ : is_scott_continuous DX DX' (λ x, x)) (H₂ : is_scott_continuous DX' DX (λ x, x)) : DX = DX'. Proof. use subtypePath. { intro. apply isaprop_directed_complete_poset. } use eq_PartialOrder. - exact (is_scott_continuous_monotone H₁). - exact (is_scott_continuous_monotone H₂). Qed. Proposition eq_dcppo_struct {X : hSet} (DX DX' : dcppo_struct X) (H₁ : is_scott_continuous DX DX' (λ x, x)) (H₂ : is_scott_continuous DX' DX (λ x, x)) : DX = DX'. Proof. use subtypePath. { intro. apply isaprop_bottom_element. } use subtypePath. { intro. apply isaprop_directed_complete_poset. } use eq_PartialOrder. - exact (is_scott_continuous_monotone H₁). - exact (is_scott_continuous_monotone H₂). Qed. Proposition eq_dcppo_strict_struct {X : hSet} (DX DX' : dcppo_struct X) (H₁ : is_strict_scott_continuous DX DX' (λ x, x)) (H₂ : is_strict_scott_continuous DX' DX (λ x, x)) : DX = DX'. Proof. use subtypePath. { intro. apply isaprop_bottom_element. } use subtypePath. { intro. apply isaprop_directed_complete_poset. } use eq_PartialOrder. - exact (is_scott_continuous_monotone H₁). - exact (is_scott_continuous_monotone H₂). Qed. (** 5. Bundled approach *) Definition scott_continuous_map (X Y : dcpo) : UU := ∑ (f : X → Y), is_scott_continuous X Y f. Definition strict_scott_continuous_map (X Y : dcppo) : UU := ∑ (f : X → Y), is_strict_scott_continuous X Y f. Coercion strict_scott_continuous_map_to_scott_continuous_map {X Y : dcppo} (f : strict_scott_continuous_map X Y) : scott_continuous_map X Y := pr1 f ,, pr12 f. (** 6. Accessors and builders for the bundled approach *) Definition scott_continuous_map_to_fun {X Y : dcpo} (f : scott_continuous_map X Y) (x : X) : Y := pr1 f x. Coercion scott_continuous_map_to_fun : scott_continuous_map >-> Funclass. Proposition is_monotone_scott_continuous_map {X Y : dcpo} (f : scott_continuous_map X Y) {x₁ x₂ : X} (p : x₁ ⊑ x₂) : f x₁ ⊑ f x₂. Proof. exact (pr12 f x₁ x₂ p). Qed. Proposition eq_scott_continuous_map {X Y : dcpo} {f g : scott_continuous_map X Y} (p : ∏ (x : X), f x = g x) : f = g. Proof. use subtypePath. { intro. apply isaprop_is_scott_continuous. } use funextsec. exact p. Qed. Coercion scott_continuous_map_to_monotone {X Y : dcpo} (f : scott_continuous_map X Y) : monotone_function X Y. Proof. refine (pr1 f ,, _). intros x₁ x₂ p. exact (is_monotone_scott_continuous_map f p). Defined. Section MakeScottContinuous. Context {X Y : dcpo} (f : X → Y) (Hf₁ : ∏ (x₁ x₂ : X), x₁ ⊑ x₂ → f x₁ ⊑ f x₂). Definition make_dcpo_is_monotone : monotone_function X Y := f ,, Hf₁. Context (Hf₂ : ∏ (D : directed_set X), f (⨆ D) = ⨆_{D} (f ,, Hf₁)). Definition make_is_scott_continuous : is_scott_continuous X Y f. Proof. use is_scott_continuous_chosen_lub. - exact Hf₁. - intros I D HD. exact (Hf₂ (I ,, (D ,, HD))). Qed. End MakeScottContinuous. Proposition scott_continuous_map_on_lub {X Y : dcpo} (f : scott_continuous_map X Y) (D : directed_set X) : f (⨆ D) = ⨆_{D} f. Proof. refine (is_scott_continuous_on_lub (pr2 f) _ (pr22 D) @ _). use (eq_lub Y (f {{ D }})). - use make_dcpo_is_least_upperbound. + cbn ; intro i. exact (lub_is_upperbound (dcpo_struct_lub Y _ (is_directed_comp (pr1 f) (pr12 f) (pr22 D))) i). + intros x Hx. exact (lub_is_least (dcpo_struct_lub Y _ (is_directed_comp (pr1 f) (pr12 f) (pr22 D))) x Hx). - apply is_least_upperbound_dcpo_comp_lub. Qed. Definition strict_scott_continuous_map_to_fun {X Y : dcppo} (f : strict_scott_continuous_map X Y) (x : X) : Y := pr1 f x. Coercion strict_scott_continuous_map_to_fun : strict_scott_continuous_map >-> Funclass. Proposition eq_strict_scott_continuous_map {X Y : dcppo} {f g : strict_scott_continuous_map X Y} (p : ∏ (x : X), f x = g x) : f = g. Proof. use subtypePath. { intro. apply isaprop_is_strict_scott_continuous. } use funextsec. exact p. Qed. Section MakeStrictScottContinuous. Context {X Y : dcppo} (f : X → Y) (Hf₁ : ∏ (x₁ x₂ : X), x₁ ⊑ x₂ → f x₁ ⊑ f x₂) (Hf₂ : ∏ (D : directed_set X), f (⨆ D) = ⨆_{D} (f ,, Hf₁)) (Hf₃ : f ⊥_{X} = ⊥_{Y}). Definition make_is_strict_scott_continuous : is_strict_scott_continuous X Y f. Proof. split. - use is_scott_continuous_chosen_lub. + exact Hf₁. + intros I D HD. exact (Hf₂ (I ,, (D ,, HD))). - exact Hf₃. Qed. End MakeStrictScottContinuous. Proposition strict_scott_continuous_map_on_point {X Y : dcppo} (f : strict_scott_continuous_map X Y) : f ⊥_{X} = ⊥_{Y}. Proof. exact (pr22 f). Qed. (** 7. Examples of Scott continuous maps (bundled) *) Definition id_scott_continuous_map (X : dcpo) : scott_continuous_map X X := (λ x, x) ,, id_is_scott_continuous X. Definition comp_scott_continuous_map {X Y Z : dcpo} (f : scott_continuous_map X Y) (g : scott_continuous_map Y Z) : scott_continuous_map X Z := (λ x, g(f x)) ,, comp_is_scott_continuous (pr2 f) (pr2 g). Notation "f '·' g" := (comp_scott_continuous_map f g) : dcpo. Definition constant_scott_continuous_map (X : dcpo) {Y : dcpo} (y : Y) : scott_continuous_map X Y := (λ x, y) ,, is_scott_continuous_constant _ _ _. Definition id_strict_scott_continuous_map (X : dcppo) : strict_scott_continuous_map X X := (λ x, x) ,, id_is_strict_scott_continuous X. Definition comp_strict_scott_continuous_map {X Y Z : dcppo} (f : strict_scott_continuous_map X Y) (g : strict_scott_continuous_map Y Z) : strict_scott_continuous_map X Z := (λ x, g(f x)) ,, comp_is_strict_scott_continuous (pr2 f) (pr2 g). Definition constant_strict_scott_continuous_map (X : dcppo) {Y : dcppo} : strict_scott_continuous_map X Y := (λ x, ⊥_{Y}) ,, is_strict_scott_continuous_constant _ _. (** 8. Scott continuous maps are continuous in the Scott topology *) Proposition preimage_scott_open {X Y : dcpo} (f : scott_continuous_map X Y) {P : Y → hProp} (HP : is_scott_open P) : is_scott_open (λ x, P (f x)). Proof. split. - intros y₁ y₂ p q. use (is_scott_open_upper_set HP p). apply (is_monotone_scott_continuous_map f). exact q. - intros D H. rewrite scott_continuous_map_on_lub in H. assert (H' := is_scott_open_lub_inaccessible HP _ H). revert H'. use factor_through_squash_hProp. exact (λ ip, hinhpr ip). Qed. (** 9. Scott contiuous maps reflect apartness *) Proposition reflect_apartness {X Y : dcpo} (f : scott_continuous_map X Y) {x y : X} : f x # f y → x # y. Proof. use factor_through_squash_hProp. intro p. induction p as [ p | p ]. - revert p. use factor_through_squash_hProp. intros ( P & HP & HPfx & HPfy ). use hdisj_in1. use hinhpr. simple refine (_ ,, _ ,, _ ,, _). + exact (λ x, P(f x)). + exact (preimage_scott_open f HP). + exact HPfx. + exact HPfy. - revert p. use factor_through_squash_hProp. intros ( P & HP & HPfx & HPfy ). use hdisj_in2. use hinhpr. simple refine (_ ,, _ ,, _ ,, _). + exact (λ x, P(f x)). + exact (preimage_scott_open f HP). + exact HPfx. + exact HPfy. Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/ScottTopology.v000066400000000000000000000154201451125700300237440ustar00rootroot00000000000000(****************************************************************************** The Scott topology We define the notions of Scott open and of Scott closed subsets of DCPOs. A Scott open set is upwards closed and inaccessible by least upperbounds, and Scott closed sets are downwards closed and closed under suprema. Note that to prove that the complement of a Scott closed set is Scott open, one needs the law of excluded middle (Lemma 2.9 in https://arxiv.org/pdf/2106.05064.pdf). We also prove some basic properties of these sets. References: - Section 2 in the chapter 'Domain Theory' of the Handbook for Logic in Computer Science, Volume 3 (https://www.cs.ox.ac.uk/files/298/handbook.pdf) - https://arxiv.org/pdf/2106.05064.pdf Contents 1. Lower and upper sets 2. Scott open and Scott closed sets 3. Bundled definitions of Scott open and Scott closed sets 4. Accessors for Scott open and Scott closed sets 5. Lower sets are Scott closed 6. Upper sets (with respect to the way-below relation) are Scott open 7. Empty and top sets are Scott open 8. Complements of Scott open sets ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. Section ScottTopology. Context {X : dcpo}. (** 1. Lower and upper sets *) Definition is_lower_set (P : X → hProp) : hProp := (∀ (x y : X), P y ⇒ x ⊑ y ⇒ P x)%logic. Definition is_upper_set (P : X → hProp) : hProp := (∀ (x y : X), P x ⇒ x ⊑ y ⇒ P y)%logic. (** 2. Scott open and Scott closed sets *) Definition is_lub_inaccessible (P : X → hProp) : hProp := (∀ (D : directed_set X), P(⨆ D) ⇒ ∃ (i : D), P(D i))%logic. Definition is_closed_under_lub (P : X → hProp) : hProp := (∀ (D : directed_set X), (∀ (i : D), P (D i)) ⇒ P(⨆ D))%logic. Definition is_scott_closed (P : X → hProp) : hProp := is_lower_set P ∧ is_closed_under_lub P. Definition is_scott_open (P : X → hProp) : hProp := is_upper_set P ∧ is_lub_inaccessible P. End ScottTopology. (** 3. Bundled definitions of Scott open and Scott closed sets *) Definition scott_open_set (X : dcpo) : UU := ∑ (P : X → hProp), is_scott_open P. Definition scott_open_set_to_pred {X : dcpo} (P : scott_open_set X) (x : X) : hProp := pr1 P x. Coercion scott_open_set_to_pred : scott_open_set >-> Funclass. Coercion is_scott_open_scott_open_set {X : dcpo} (P : scott_open_set X) : is_scott_open P := pr2 P. Definition scott_closed_set (X : dcpo) : UU := ∑ (P : X → hProp), is_scott_closed P. Definition scott_closed_set_to_pred {X : dcpo} (P : scott_closed_set X) (x : X) : hProp := pr1 P x. Coercion scott_closed_set_to_pred : scott_closed_set >-> Funclass. Coercion is_scott_closed_scott_closed_set {X : dcpo} (P : scott_closed_set X) : is_scott_closed P := pr2 P. (** 4. Accessors for Scott open and Scott closed sets *) Section ScottClosedAccessors. Context {X : dcpo} {P : X → hProp} (HP : is_scott_closed P). Proposition is_scott_closed_lower_set {x y : X} (Py : P y) (p : x ⊑ y) : P x. Proof. exact (pr1 HP x y Py p). Qed. Proposition is_scott_closed_lub (D : directed_set X) (HD : ∀ (i : D), P (D i)) : P(⨆ D). Proof. exact (pr2 HP D HD). Qed. End ScottClosedAccessors. Section ScottOpenAccessors. Context {X : dcpo} {P : X → hProp} (HP : is_scott_open P). Proposition is_scott_open_upper_set {x y : X} (Py : P x) (p : x ⊑ y) : P y. Proof. exact (pr1 HP x y Py p). Qed. Proposition is_scott_open_lub_inaccessible (D : directed_set X) (HD : P(⨆ D)) : ∃ (i : D), P (D i). Proof. exact (pr2 HP D HD). Qed. End ScottOpenAccessors. Section PropertiesScottTopology. Context {X : dcpo}. (** 5. Lower sets are Scott closed *) Proposition lower_set_is_scott_closed (x : X) : is_scott_closed (λ y, y ⊑ x). Proof. split. - intros y₁ y₂ p q. exact (trans_dcpo q p). - intros D H. use dcpo_lub_is_least. exact H. Qed. (** 6. Upper sets (with respect to the way-below relation) are Scott open *) Proposition upper_set_is_scott_open (CX : continuous_dcpo_struct X) (x : X) : is_scott_open (λ y, x ≪ y). Proof. split. - intros y₁ y₂ p q. exact (trans_way_below_le p q). - intros D p. assert (H := unary_interpolation CX p). revert H. use factor_through_squash. { apply propproperty. } intro z. induction z as [ z [ q₁ q₂ ]]. assert (H := q₂ D (refl_dcpo _)). revert H. use factor_through_squash. { apply propproperty. } intro i. induction i as [ i r ]. refine (hinhpr (i ,, _)). exact (trans_way_below_le q₁ r). Qed. (** * 7. Empty and top sets are Scott open *) Definition true_scott_open_set (A : dcpo) : scott_open_set A. Proof. simple refine (_ ,, _). - exact (λ _, htrue). - split. + abstract (intros x y p q ; exact tt). + abstract (intros D x ; assert (H := directed_set_el D) ; revert H ; use factor_through_squash_hProp ; intro d ; exact (hinhpr (d ,, tt))). Defined. Definition false_scott_open_set (A : dcpo) : scott_open_set A. Proof. simple refine (_ ,, _). - exact (λ _, hfalse). - split. + abstract (intros x y p q; exact (fromempty p)). + abstract (intros D p; exact (fromempty p)). Defined. (** 8. Complements of Scott open sets *) Proposition complement_of_scott_open (P : X → hProp) (HP : is_scott_open P) : is_scott_closed (λ x, ¬(P x))%logic. Proof. split. - cbn ; intros x y p q H. apply p. use (pr1 HP x). + exact H. + exact q. - cbn ; intros D HD p. assert (H := is_scott_open_lub_inaccessible HP D p). revert H. use factor_through_squash. { apply isapropempty. } intro i. induction i as [ i Hi ]. apply (HD i). exact Hi. Qed. End PropertiesScottTopology. UniMath-20231010/UniMath/OrderTheory/DCPOs/Core/WayBelow.v000066400000000000000000000113241451125700300226430ustar00rootroot00000000000000(****************************************************************************** The way-below relation in DCPOs In this file, we define the way-below relation in DCPOs. The way-below relation is defined as followed: an element `x` is way-below `y` (written as `x ≪ y`) if for every directed set `D` such that `y` is lesser than or equal to the supremum of `D`, we can find an element in `D` such that `x` is already lesser than or equal than that element. Note that usually, the way-below relation is formulated using subsets. However, just as for suprema, we take slightly different approach: we look at directed sets indexed by some type. We also look at properties of the way-below relation. References: - Section 2 in the chapter 'Domain Theory' of the Handbook for Logic in Computer Science, Volume 3 (https://www.cs.ox.ac.uk/files/298/handbook.pdf) - Section 4.2 in Domain Theory in Constructive and Predicative Univalent Foundations (https://tdejong.com/writings/phd-thesis.pdf) Contents: 1. Definition of the way-below relation 2. Transitivity of the way-below relation 3. Interaction between the order of the DCPO and the way-below relation 4. Antisymmetry of the way-below relation 5. The bottom is way-below every element 6. Principal lower sets for the way-below relation ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Local Open Scope dcpo. (** 1. Definition of the way-below relation *) Definition way_below {X : dcpo} (x y : X) : hProp := (∀ (D : directed_set X), y ⊑ ⨆ D ⇒ ∃ (i : D), x ⊑ D i)%logic. Notation "x ≪ y" := (way_below x y) (at level 70). (* \ll *) Proposition way_below_elem {X : dcpo} {x y : X} (p : x ≪ y) (D : directed_set X) (HD : y ⊑ ⨆ D) : ∃ (i : D), x ⊑ D i. Proof. exact (p D HD). Qed. Section PropertiesOfWayBelow. Context {X : dcpo}. (** 2. Transitivity of the way-below relation *) Proposition trans_way_below {x y z : X} (p : x ≪ y) (q : y ≪ z) : x ≪ z. Proof. intros D HD. assert (H := way_below_elem q D HD). revert H. use factor_through_squash. { apply propproperty. } intros H. induction H as [ i H ]. assert (H' : y ⊑ ⨆ D). { refine (trans_dcpo H _). use (less_than_dcpo_lub D _ i). apply refl_dcpo. } exact (way_below_elem p D H'). Qed. (** 3. Interaction between the order of the DCPO and the way-below relation *) Proposition trans_way_below_le {x y z : X} (p : x ≪ y) (q : y ⊑ z) : x ≪ z. Proof. intros D HD. exact (way_below_elem p D (trans_dcpo q HD)). Qed. Proposition trans_le_way_below {x y z : X} (p : x ⊑ y) (q : y ≪ z) : x ≪ z. Proof. intros D HD. assert (H := way_below_elem q D HD). revert H. use factor_through_squash. { apply propproperty. } intros H. induction H as [ i H ]. refine (hinhpr (i ,, _)). exact (trans_dcpo p H). Qed. Proposition way_below_to_le {x y : X} (p : x ≪ y) : x ⊑ y. Proof. pose (D := nat_directed_set X (λ _, y) (λ _, refl_dcpo _)). assert (q : y ⊑ ⨆ D). { exact (less_than_dcpo_lub D y 0 (refl_dcpo _)). } assert (H := way_below_elem p D q). revert H. use factor_through_squash. { apply propproperty. } intros H. exact (pr2 H). Qed. (** 4. Antisymmetry of the way-below relation *) Proposition antisymm_way_below {x y : X} (p : x ≪ y) (q : y ≪ x) : x = y. Proof. use antisymm_dcpo. - apply way_below_to_le. exact p. - apply way_below_to_le. exact q. Qed. End PropertiesOfWayBelow. (** 5. The bottom is way-below every element *) Proposition bot_way_below {X : dcppo} (x : X) : ⊥_{X} ≪ x. Proof. intros D HD. assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intro i. refine (hinhpr (i ,, _)). apply is_min_bottom_dcppo. Qed. (** 6. Principal lower sets for the way-below relation *) Definition way_below_principal {X : dcpo} (x : X) : UU := ∑ (y : X), y ≪ x. Notation "↡ x" := (way_below_principal x) (at level 10). (* \d+9 *) Definition way_below_principal_incl {X : dcpo} (x : X) : ↡ x → X := pr1. UniMath-20231010/UniMath/OrderTheory/DCPOs/Elements/000077500000000000000000000000001451125700300216065ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/Elements/Maximal.v000066400000000000000000000310231451125700300233640ustar00rootroot00000000000000(****************************************************************************** Maximal elements in a DCPO In this file, we define maximal elements in DCPOs. In classical foundations, an element `x` is called maximal if for every `y` such that `x ⊑ y`, we have that `x = y`. However, constructively, there is a better notion, namely that of a strongly maximal element (see https://arxiv.org/pdf/2106.05064.pdf). We also prove some properties of strongly maximal elements. In particular, we show that they are sharp and that they are maximal if the DCPO is continuous. Contents 1. Maximal elements 2. Hausdorff separated elements 3. Properties of Hausdorff separated elements 4. Hausdorff separatedness in continuous DCPOs 5. Strongly maximal elements 6. Strongly maximal elements are sharp 7. The intrinsic apartness relation on strongly maximal elements 8. In a continuous DCPO, strongly maximal elements are maximal 9. A simplified strong maximality condition in a continuous DCPO 10. Apartness for strongly maximal elements is Hausdorff separatedness ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Import UniMath.OrderTheory.DCPOs.Core.IntrinsicApartness. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Require Import UniMath.OrderTheory.DCPOs.Elements.Sharp. Local Open Scope dcpo. Definition are_disjoint {X : UU} (P₁ P₂ : X → hProp) : hProp := (∀ (z : X), ¬(P₁ z ∧ P₂ z))%logic. Proposition symm_are_disjoint {X : UU} {P₁ P₂ : X → hProp} (H : are_disjoint P₁ P₂) : are_disjoint P₂ P₁. Proof. intros z p. exact (H z (pr2 p ,, pr1 p)). Qed. (** * 1. Maximal elements *) Definition is_maximal {X : dcpo} (x : X) : hProp := (∀ (y : X), x ⊑ y ⇒ y ⊑ x)%logic. (** * 2. Hausdorff separated elements *) Definition is_hausdorff_separated {X : dcpo} (x y : X) : hProp := ∃ (P₁ P₂ : scott_open_set X), P₁ x ∧ P₂ y ∧ are_disjoint P₁ P₂. (** * 3. Properties of Hausdorff separated elements *) Section PropertiesHausdorffSeparated. Context {X : dcpo}. Proposition irrefl_is_hausdorff_separated (x : X) : ¬(is_hausdorff_separated x x). Proof. use factor_through_squash. { apply isapropempty. } intros H. induction H as [ P₁ [ P₂ [ Px [ Px' H ]]]]. exact (H x (Px ,, Px')). Qed. Proposition symm_is_hausdorff_separated {x y : X} (H : is_hausdorff_separated x y) : is_hausdorff_separated y x. Proof. revert H. use factor_through_squash. { apply propproperty. } intros H. induction H as [ P₁ [ P₂ [ Px [ Py H ]]]]. refine (hinhpr (P₂ ,, P₁ ,, Py ,, Px ,, _)). apply symm_are_disjoint. exact H. Qed. Proposition is_hausdorff_separated_not_le {x y : X} (H : is_hausdorff_separated x y) : ¬(x ⊑ y). Proof. intro p. revert H. use factor_through_squash. { apply isapropempty. } intros H. induction H as [ P₁ [ P₂ [ Px [ Py H ]]]]. refine (H y (_ ,, _)). - refine (is_scott_open_upper_set P₁ Px p). - exact Py. Qed. Lemma is_hausdorff_separated_le (x y z : X) : y ⊑ z → is_hausdorff_separated y x → is_hausdorff_separated z x. Proof. intros Hyz. use factor_through_squash_hProp. intros (S1 & S2 & H1 & H2 & Hdisj). apply hinhpr. use (S1,, S2,, _,, H2,, Hdisj). exact (is_scott_open_upper_set S1 H1 Hyz). Qed. End PropertiesHausdorffSeparated. (** * 4. Hausdorff separatedness in continuous DCPOs *) Definition from_hausdorff_separated_continuous_dcpo {X : dcpo} (B : dcpo_basis X) (x y : X) : is_hausdorff_separated x y → (∃ (b₁ b₂ : B), B b₁ ≪ x ∧ B b₂ ≪ y ∧ ¬(∃ (t : B), B b₁ ≪ B t ∧ B b₂ ≪ B t))%logic. Proof. use factor_through_squash_hProp. intros (S1 & S2 & H1 & H2 & Hdisj). pose (H := is_scott_open_lub_inaccessible S1 (directed_set_from_basis B x)). rewrite approximating_basis_lub in H. specialize (H H1). revert H. use factor_through_squash_hProp. intros ( i₁ & Hi₁ ). pose (H := is_scott_open_lub_inaccessible S2 (directed_set_from_basis B y)). rewrite approximating_basis_lub in H. specialize (H H2). revert H. use factor_through_squash_hProp. intros ( i₂ & Hi₂ ). cbn in i₁, i₂, Hi₁, Hi₂. refine (hinhpr _). refine (pr1 i₁ ,, pr1 i₂ ,, pr2 i₁ ,, pr2 i₂ ,, _). use factor_through_squash. { apply isapropempty. } intros [ k [ Hik₁ Hik₂ ]]. refine (Hdisj (B k) _). split. - apply (is_scott_open_upper_set S1 Hi₁). apply way_below_to_le. exact Hik₁. - apply (is_scott_open_upper_set S2 Hi₂). apply way_below_to_le. exact Hik₂. Qed. Definition to_hausdorff_separated_continuous_dcpo {X : dcpo} (B : dcpo_basis X) (x y : X) : (∃ (b₁ b₂ : B), B b₁ ≪ x ∧ B b₂ ≪ y ∧ ¬(∃ (t : B), B b₁ ≪ B t ∧ B b₂ ≪ B t))%logic → is_hausdorff_separated x y. Proof. use factor_through_squash_hProp. intros ( b₁ & b₂ & p₁ & p₂ & p₃ ). refine (hinhpr _). simple refine (_ ,, _ ,, _ ,, _ ,, _). - refine (_ ,, _). exact (upper_set_is_scott_open (continuous_struct_from_basis B) (B b₁)). - refine (_ ,, _). exact (upper_set_is_scott_open (continuous_struct_from_basis B) (B b₂)). - exact p₁. - exact p₂. - cbn -[way_below] ; intros z ( Hz₁ & Hz₂ ). refine (p₃ _). assert (H := basis_binary_interpolation B Hz₁ Hz₂). revert H. use factor_through_squash_hProp. intros ( i & r₁ & r₂ & r₃ ). exact (hinhpr (i ,, r₁ ,, r₂)). Qed. Definition hausdorff_separated_continuous_dcpo_weq {X : dcpo} (B : dcpo_basis X) (x y : X) : (is_hausdorff_separated x y ≃ ∃ (b₁ b₂ : B), B b₁ ≪ x ∧ B b₂ ≪ y ∧ ¬(∃ (t : B), B b₁ ≪ B t ∧ B b₂ ≪ B t))%logic. Proof. use logeqweq. - exact (from_hausdorff_separated_continuous_dcpo B x y). - exact (to_hausdorff_separated_continuous_dcpo B x y). Defined. (** * 5. Strongly maximal elements *) Definition is_strongly_maximal {X : dcpo} (x : X) : hProp := (∀ (u v : X), u ≪ v ⇒ (u ≪ x ∨ is_hausdorff_separated v x))%logic. Definition strongly_maximal (X : dcpo) : hSet := (∑ (x : X), hProp_to_hSet (is_strongly_maximal x))%set. Coercion element_of_strongly_maximal {X : dcpo} (x : strongly_maximal X) : X := pr1 x. Definition eq_strongly_maximal {X : dcpo} {x y : strongly_maximal X} (p : pr1 x = pr1 y) : x = y. Proof. use subtypePath. { intro. apply propproperty. } exact p. Qed. (** * 6. Strongly maximal elements are sharp *) Proposition is_sharp_is_strongly_maximal {X : dcpo} {x : X} (Hx : is_strongly_maximal x) : is_sharp x. Proof. intros u v p. specialize (Hx u v p). revert Hx. use factor_through_squash. { apply propproperty. } intro H. induction H as [ q | q ]. - exact (hinhpr (inl q)). - refine (hinhpr (inr _)). apply is_hausdorff_separated_not_le. exact q. Qed. (** * 7. The intrinsic apartness relation on strongly maximal elements *) Proposition is_strongly_maximal_tight_apartness {X : dcpo} (CX : continuous_dcpo_struct X) {x y : X} (Hx : is_strongly_maximal x) (Hy : is_strongly_maximal y) (p : ¬(x # y)) : x = y. Proof. refine (is_sharp_tight_apartness CX _ _ p). - apply is_sharp_is_strongly_maximal. exact Hx. - apply is_sharp_is_strongly_maximal. exact Hy. Qed. Proposition is_strongly_maximal_cotransitive_apartness {X : dcpo} (CX : continuous_dcpo_struct X) {x y z : X} (Hz : is_strongly_maximal z) (p : x # y) : x # z ∨ y # z. Proof. refine (is_sharp_cotransitive_apartness CX _ p). apply is_sharp_is_strongly_maximal. exact Hz. Qed. (** * 8. In a continuous DCPO, strongly maximal elements are maximal *) Proposition is_maximal_is_strongly_maximal {X : dcpo} (CX : continuous_dcpo_struct X) {x : X} (Hx : is_strongly_maximal x) : is_maximal x. Proof. intros y p. use (invmap (continuous_dcpo_struct_le_via_approximation CX y x)). intros z q. assert (H := Hx z y q). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ r | r ]. - exact r. - apply fromempty. exact (is_hausdorff_separated_not_le (symm_is_hausdorff_separated r) p). Qed. Definition eq_strongly_maximal_via_le {X : dcpo} (CX : continuous_dcpo_struct X) {x y : strongly_maximal X} (p : x ⊑ y) : x = y. Proof. use subtypePath. { intro. apply propproperty. } use antisymm_dcpo. - exact p. - exact (is_maximal_is_strongly_maximal CX (pr2 x) _ p). Qed. Definition eq_strongly_maximal_via_top {X : dcpo} (CX : continuous_dcpo_struct X) {x y : strongly_maximal X} (z : X) (p : x ⊑ z) (q : y ⊑ z) : x = y. Proof. use subtypePath. { intro. apply propproperty. } transitivity z. - use antisymm_dcpo. + exact p. + exact (is_maximal_is_strongly_maximal CX (pr2 x) _ p). - refine (!_). use antisymm_dcpo. + exact q. + exact (is_maximal_is_strongly_maximal CX (pr2 y) _ q). Qed. (** * 9. A simplified strong maximality condition in a continuous DCPO, in terms of the basis *) Lemma is_strongly_maximal_basis_1 {X : dcpo} (B : dcpo_basis X) (x : X) : (∀ (i j : B), B i ≪ B j ⇒ (B i ≪ x ∨ is_hausdorff_separated (B j) x))%logic → is_strongly_maximal x. Proof. intros HB u v Huv. assert (Hb := basis_unary_interpolation B Huv). revert Hb. use factor_through_squash. { apply propproperty. } intros [i [Hui Hiv]]. assert (Hb := basis_unary_interpolation B Hiv). revert Hb. use factor_through_squash. { apply propproperty. } intros [j [Hij Hjv]]. specialize (HB _ _ Hij). revert HB. use factor_through_squash. { apply propproperty. } intros [Hix | Hsep]. { apply hinhpr. left. use (trans_way_below Hui Hix). } { apply hinhpr. right. use (is_hausdorff_separated_le _ _ _ _ Hsep). apply way_below_to_le, Hjv. } Qed. Lemma is_strongly_maximal_basis_2 {X : dcpo} (B : dcpo_basis X) (x : X) : is_strongly_maximal x → (∀ (i j : B), B i ≪ B j ⇒ (B i ≪ x ∨ is_hausdorff_separated (B j) x))%logic. Proof. intros HX i j p. exact (HX (B i) (B j) p). Qed. Lemma is_strongly_maximal_basis {X : dcpo} (B : dcpo_basis X) (x : X) : (∀ (i j : B), B i ≪ B j ⇒ (B i ≪ x ∨ is_hausdorff_separated (B j) x))%logic ≃ is_strongly_maximal x. Proof. use weqimplimpl. - apply is_strongly_maximal_basis_1. - apply is_strongly_maximal_basis_2. - apply propproperty. - apply propproperty. Qed. (** * 10. Apartness for strongly maximal elements is Hausdorff separatedness *) Lemma strongly_maximal_apart {D : dcpo} (C : continuous_dcpo_struct D) {x y : D} (Hx : is_strongly_maximal x) (Hy : is_strongly_maximal y) (p : x # y) : is_hausdorff_separated x y. Proof. revert p. use factor_through_squash_hProp. intros [Hxy | Hyx]. - assert (Hb := continuous_not_specialization_weq C _ _ Hxy). revert Hb. use factor_through_squash_hProp. intros (b & Hbx & Hby). specialize (Hy b x Hbx). revert Hy. use factor_through_squash_hProp. intros [Hby' | Hxy' ]. + apply fromempty. use (Hby _). exact (way_below_to_le Hby'). + exact Hxy'. - assert (Hb := continuous_not_specialization_weq C _ _ Hyx). revert Hb. use factor_through_squash_hProp. intros (b & Hby & Hbx). specialize (Hx b y Hby). revert Hx. use factor_through_squash_hProp. intros [Hbx' | Hxy' ]. + apply fromempty. use (Hbx _). exact (way_below_to_le Hbx'). + apply symm_is_hausdorff_separated. exact Hxy'. Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Elements/Sharp.v000066400000000000000000000133051451125700300230540ustar00rootroot00000000000000(****************************************************************************** Sharp elements in a DCPO In this file, we define the notion of sharp elements of a DCPO. Every DCPO gives rise to an intrinsic apartness relation, which, in general, is neither tight nor cotransitive in constructive foundations. However, if we restrict ourselves to a subclass of elements, called the sharp elements, then we can prove constructively that the apartness relation is both tight and cotransitive. Reference: - https://arxiv.org/pdf/2106.05064.pdf Contents: 1. Definition of sharp elements 2. Characterization of sharp elements in a continuous DCPO 3. Tightness of the intrinsic apartness relation for sharp elements 4. Cotransitivity of the intrinsic apartness relation for sharp elements ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Import UniMath.OrderTheory.DCPOs.Core.IntrinsicApartness. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. (** 1. Definition of sharp elements *) Definition is_sharp {X : dcpo} (x : X) : hProp := (∀ (y z : X), y ≪ z ⇒ (y ≪ x ∨ ¬(z ⊑ x)))%logic. (** 2. Characterization of sharp elements in a continuous DCPO *) Proposition is_sharp_continuous_dcpo {X : dcpo} (CX : continuous_dcpo_struct X) (x : X) : is_sharp x ≃ (∀ (y z : X), y ≪ z ⇒ (y ≪ x ∨ z ⊄ x))%logic. Proof. use weqimplimpl. - intros Hx y z p. assert (H := unary_interpolation CX p). revert H. use factor_through_squash. { apply propproperty. } intro u. induction u as [ u [ q₁ q₂ ]]. assert (H := unary_interpolation CX q₂). revert H. use factor_through_squash. { apply propproperty. } intro v. induction v as [ v [ r₁ r₂ ]]. specialize (Hx u v r₁). revert Hx. use factor_through_squash. { apply propproperty. } intro s. induction s as [ s | s ]. + refine (hinhpr (inl _)). exact (trans_way_below q₁ s). + cbn in s. refine (hinhpr (inr _)). use (invmap (continuous_not_specialization_weq CX z x)). exact (hinhpr (v ,, r₂ ,, s)). - intros Hx y z p. specialize (Hx y z p). revert Hx. use factor_through_squash. { apply propproperty. } intro q. induction q as [ q | q ]. + exact (hinhpr (inl q)). + refine (hinhpr (inr _)). apply dcpo_not_specialization_le. exact q. - apply propproperty. - apply propproperty. Qed. (** 3. Tightness of the instrinsic apartness relation for sharp elements *) Lemma is_sharp_to_le {X : dcpo} (CX : continuous_dcpo_struct X) {x y : X} (Hy : is_sharp y) (p : ¬(x ⊄ y)) : x ⊑ y. Proof. use (invmap (continuous_dcpo_struct_le_via_approximation CX x y)). intros z q. assert (H := unary_interpolation CX q). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ u [ r₁ r₂ ]]. assert (H := Hy _ _ r₁). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ s | s ]. - exact s. - cbn in s. refine (fromempty (p _)). refine (hinhpr (_ ,, upper_set_is_scott_open CX u ,, r₂ ,, _)). intro w. apply s. apply way_below_to_le. exact w. Qed. Proposition is_sharp_tight_apartness {X : dcpo} (CX : continuous_dcpo_struct X) {x y : X} (Hx : is_sharp x) (Hy : is_sharp y) (p : ¬(x # y)) : x = y. Proof. use antisymm_dcpo. - use (is_sharp_to_le CX Hy). intro q. apply p. exact (hinhpr (inl q)). - use (is_sharp_to_le CX Hx). intro q. apply p. exact (hinhpr (inr q)). Qed. (** 4. Cotransitivity of the intrinsic apartness relation for sharp elements *) Lemma is_sharp_cotransitive_apartness_help {X : dcpo} (CX : continuous_dcpo_struct X) {x y z : X} (Hz : is_sharp z) (p : x ⊄ y) : x # z ∨ y # z. Proof. assert (H := continuous_not_specialization_weq CX x y p). revert H. use factor_through_squash. { apply propproperty. } intro u. induction u as [ u [ q₁ q₂ ]]. assert (H := unary_interpolation CX q₁). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ v [ r₁ r₂ ]]. assert (H := Hz u v r₁). revert H. use factor_through_squash. { apply propproperty. } intro s. induction s as [ s | s ]. - refine (hinhpr (inr (hinhpr (inr _)))). use (invmap (continuous_not_specialization_weq CX z y)). exact (hinhpr (u ,, s ,, q₂)). - refine (hinhpr (inl (hinhpr (inl _)))). use (invmap (continuous_not_specialization_weq CX x z)). exact (hinhpr (v ,, r₂ ,, s)). Qed. Proposition is_sharp_cotransitive_apartness {X : dcpo} (CX : continuous_dcpo_struct X) {x y z : X} (Hz : is_sharp z) (p : x # y) : x # z ∨ y # z. Proof. revert p. use factor_through_squash. { apply propproperty. } intro p. induction p as [ p | p ]. - exact (is_sharp_cotransitive_apartness_help CX Hz p). - assert (H := is_sharp_cotransitive_apartness_help CX Hz p). revert H. use factor_through_squash. { apply propproperty. } intro q. induction q as [ q | q ]. + exact (hinhpr (inr q)). + exact (hinhpr (inl q)). Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/000077500000000000000000000000001451125700300216105ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/BinaryProducts.v000066400000000000000000000660251451125700300247600ustar00rootroot00000000000000(***************************************************************** Binary products of DCPOs The product of two DCPOs is again a DCPO, and this satisfies the usual universal property. In addition, we construct a basis for the product DCPO. Contents 1. Upperbounds in the product 2. The DCPO 3. The first projection 4. The second projection 5. Pairing and products of functions 6. Swap & associativity functions 7. Lemmas on upperbounds in the product 8. A basis for the product 9. Products of Scott opens sets *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.ScottTopology. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Require Import UniMath.OrderTheory.DCPOs.Elements.Maximal. Local Open Scope dcpo. (** * 1. Upperbounds in the product *) Proposition is_least_upperbound_pair {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (I : UU) (D : I → (X × Y)%set) (x : X) (y : Y) (Hx : is_least_upperbound DX (λ i, pr1 (D i)) x) (Hy : is_least_upperbound DY (λ i, pr2 (D i)) y) : is_least_upperbound (prod_PartialOrder DX DY) D (x ,, y). Proof. pose (x' := (x ,, Hx) : lub DX _). pose (y' := (y ,, Hy) : lub DY _). split. - intros i. exact (lub_is_upperbound x' i ,, lub_is_upperbound y' i). - intros z Hz. exact (lub_is_least x' _ (λ i, pr1 (Hz i)) ,, lub_is_least y' _ (λ i, pr2 (Hz i))). Qed. Definition prod_lub {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) (I : UU) (D : I → (X × Y)%set) (x : lub DX (λ i, pr1 (D i))) (y : lub DY (λ i, pr2 (D i))) : lub (prod_PartialOrder DX DY) D. Proof. use make_lub. - exact (pr1 x ,, pr1 y). - use is_least_upperbound_pair. + exact (pr2 x). + exact (pr2 y). Defined. (** * 2. The DCPO *) Definition prod_dcpo_struct {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) : dcpo_struct (X × Y)%set. Proof. use make_dcpo_struct. - exact (prod_PartialOrder DX DY). - intros I D HD. use prod_lub. + use (dcpo_struct_lub DX (λ i, pr1 (D i))). abstract (use (is_directed_comp _ _ HD) ; apply dirprod_pr1_is_monotone). + use (dcpo_struct_lub DY (λ i, pr2 (D i))). abstract (use (is_directed_comp _ _ HD) ; apply dirprod_pr2_is_monotone). Defined. Definition prod_dcppo_struct {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) : dcppo_struct (X × Y)%set. Proof. refine (prod_dcpo_struct DX DY ,, _). exact (pr2 (prod_pointed_PartialOrder DX DY)). Defined. Definition prod_dcpo (X Y : dcpo) : dcpo := _ ,, prod_dcpo_struct X Y. Definition prod_dcppo (X Y : dcppo) : dcppo := _ ,, prod_dcppo_struct X Y. Notation "X × Y" := (prod_dcpo X Y) : dcpo. Proposition prod_dcpo_le {X Y : dcpo} (xy₁ xy₂ : (X × Y)%dcpo) (p : pr1 xy₁ ⊑ pr1 xy₂) (q : pr2 xy₁ ⊑ pr2 xy₂) : xy₁ ⊑ xy₂. Proof. exact (p ,, q). Qed. (** * 3. The first projection *) Proposition pr1_is_least_upperbound {X Y : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {I : UU} {D : I → X × Y} (xy : X × Y) (Hxy : is_least_upperbound (prod_dcpo_struct DX DY) D xy) : is_least_upperbound DX (λ i, pr1 (D i)) (pr1 xy). Proof. split. - intros i. exact (pr1 (is_least_upperbound_is_upperbound Hxy i)). - intros x Hx. refine (pr1 (is_least_upperbound_is_least Hxy (x ,, pr2 xy) _)). intros i. split ; cbn. + exact (Hx i). + exact (pr2 (is_least_upperbound_is_upperbound Hxy i)). Qed. Proposition is_scott_continuous_dirprod_pr1 {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) : is_scott_continuous (prod_dcpo_struct DX DY) DX dirprod_pr1. Proof. split. - apply dirprod_pr1_is_monotone. - intros I DI HD x Hx. split. + intros i. exact (pr1 (is_least_upperbound_is_upperbound Hx i)). + intros x' Hx'. refine (pr1 (is_least_upperbound_is_least Hx (x' ,, pr2 x) _)). intro i. split ; cbn. * exact (Hx' i). * exact (pr2 (is_least_upperbound_is_upperbound Hx i)). Qed. Proposition is_strict_scott_continuous_dirprod_pr1 {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) : is_strict_scott_continuous (prod_dcppo_struct DX DY) DX dirprod_pr1. Proof. split. - apply is_scott_continuous_dirprod_pr1. - apply idpath. Qed. Definition dirprod_pr1_scott_continuous_map (X Y : dcpo) : scott_continuous_map (X × Y) X := _ ,, is_scott_continuous_dirprod_pr1 X Y. Notation "'π₁'" := (dirprod_pr1_scott_continuous_map _ _) : dcpo. (** * 4. The second projection *) Proposition pr2_is_least_upperbound {X Y : hSet} {DX : dcpo_struct X} {DY : dcpo_struct Y} {I : UU} {D : I → X × Y} (xy : X × Y) (Hxy : is_least_upperbound (prod_dcpo_struct DX DY) D xy) : is_least_upperbound DY (λ i, pr2 (D i)) (pr2 xy). Proof. split. - intros i. exact (pr2 (is_least_upperbound_is_upperbound Hxy i)). - intros y Hy. refine (pr2 (is_least_upperbound_is_least Hxy (pr1 xy ,, y) _)). intros i. split ; cbn. + exact (pr1 (is_least_upperbound_is_upperbound Hxy i)). + exact (Hy i). Qed. Proposition is_scott_continuous_dirprod_pr2 {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) : is_scott_continuous (prod_dcpo_struct DX DY) DY dirprod_pr2. Proof. split. - apply dirprod_pr2_is_monotone. - intros I DI HD x Hx. split. + intros i. exact (pr2 (is_least_upperbound_is_upperbound Hx i)). + intros y' Hy'. refine (pr2 (is_least_upperbound_is_least Hx (pr1 x ,, y') _)). intro i. split ; cbn. * exact (pr1 (is_least_upperbound_is_upperbound Hx i)). * exact (Hy' i). Qed. Proposition is_strict_scott_continuous_dirprod_pr2 {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) : is_strict_scott_continuous (prod_dcppo_struct DX DY) DY dirprod_pr2. Proof. split. - apply is_scott_continuous_dirprod_pr2. - apply idpath. Qed. Definition dirprod_pr2_scott_continuous_map (X Y : dcpo) : scott_continuous_map (X × Y) Y := _ ,, is_scott_continuous_dirprod_pr2 X Y. Notation "'π₂'" := (dirprod_pr2_scott_continuous_map _ _) : dcpo. (** * 5. Pairing and (tensor) products of functions *) Proposition is_scott_continuous_prodtofun {W X Y : hSet} {DW : dcpo_struct W} {DX : dcpo_struct X} {DY : dcpo_struct Y} {f : W → X} (Hf : is_scott_continuous DW DX f) {g : W → Y} (Hg : is_scott_continuous DW DY g) : is_scott_continuous DW (prod_dcpo_struct DX DY) (prodtofuntoprod (f ,, g)). Proof. split. - apply prodtofun_is_monotone. + exact (is_scott_continuous_monotone Hf). + exact (is_scott_continuous_monotone Hg). - intros I D HD w Hw. split. + intro i. split ; cbn. * exact (is_least_upperbound_is_upperbound (is_scott_continuous_lub Hf HD w Hw) i). * exact (is_least_upperbound_is_upperbound (is_scott_continuous_lub Hg HD w Hw) i). + intros xy Hxy. split ; cbn. * use (is_least_upperbound_is_least (is_scott_continuous_lub Hf HD w Hw) (pr1 xy)). intro i. exact (pr1 (Hxy i)). * use (is_least_upperbound_is_least (is_scott_continuous_lub Hg HD w Hw) (pr2 xy)). intro i. exact (pr2 (Hxy i)). Qed. Proposition is_strict_scott_continuous_prodtofun {W X Y : hSet} {DW : dcppo_struct W} {DX : dcppo_struct X} {DY : dcppo_struct Y} {f : W → X} (Hf : is_strict_scott_continuous DW DX f) {g : W → Y} (Hg : is_strict_scott_continuous DW DY g) : is_strict_scott_continuous DW (prod_dcppo_struct DX DY) (prodtofuntoprod (f ,, g)). Proof. split. - exact (is_scott_continuous_prodtofun Hf Hg). - use pathsdirprod. + apply Hf. + apply Hg. Qed. Definition pair_scott_continuous {W X Y : dcpo} (f : scott_continuous_map W X) (g : scott_continuous_map W Y) : scott_continuous_map W (X × Y) := _ ,, is_scott_continuous_prodtofun (pr2 f) (pr2 g). Notation "⟨ f , g ⟩" := (pair_scott_continuous f g) : dcpo. Definition tensor_scott_continuous_map {X₁ X₂ Y₁ Y₂ : dcpo} (f₁ : scott_continuous_map X₁ Y₁) (f₂ : scott_continuous_map X₂ Y₂) : scott_continuous_map (X₁ × X₂) (Y₁ × Y₂) := ⟨ π₁ · f₁ , π₂ · f₂ ⟩. Notation "f₁ ⊗ f₂" := (tensor_scott_continuous_map f₁ f₂) : dcpo. (** * 6. Swap & associativity functions *) Definition dcpo_swap (A B : dcpo) : scott_continuous_map (A × B) (B × A) := ⟨ dirprod_pr2_scott_continuous_map _ _ , dirprod_pr1_scott_continuous_map _ _ ⟩. Definition assoc_scott_continuous_map (X Y Z : dcpo) : scott_continuous_map (X × Y × Z) ((X × Y) × Z) := ⟨ ⟨ π₁ , π₂ · π₁ ⟩ , π₂ · π₂ ⟩. Notation "'α'" := (assoc_scott_continuous_map _ _ _) : dcpo. (** * 7. Lemmas on upperbounds in the product *) Proposition prod_dcpo_lub {X Y : dcpo} (D : directed_set (X × Y)) : ⨆ D = (⨆ (π₁ {{ D }}) ,, ⨆ (π₂ {{ D }})). Proof. use (eq_lub (X × Y) D). - apply is_least_upperbound_dcpo_lub. - use is_least_upperbound_pair. + exact (is_least_upperbound_dcpo_comp_lub (dirprod_pr1_scott_continuous_map X Y) D). + exact (is_least_upperbound_dcpo_comp_lub (dirprod_pr2_scott_continuous_map X Y) D). Qed. Definition prod_directed_set_dcpo {X Y : dcpo} (D₁ : directed_set X) (D₂ : directed_set Y) : directed_set (X × Y) := prod_directed_set D₁ D₂. Proposition prod_dcpo_lub' {X Y : dcpo} (D : directed_set X) (D' : directed_set Y) : ⨆ (prod_directed_set_dcpo D D') = (⨆ D ,, ⨆ D'). Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. use prod_dcpo_le ; cbn in *. + use less_than_dcpo_lub. * exact (pr1 i). * apply refl_dcpo. + use less_than_dcpo_lub. * exact (pr2 i). * apply refl_dcpo. - assert (Di := directed_set_el D). revert Di. use factor_through_squash ; [ apply propproperty | ]. intro Di. assert (Di' := directed_set_el D'). revert Di'. use factor_through_squash ; [ apply propproperty | ]. intro Di'. use prod_dcpo_le. + use dcpo_lub_is_least. intro i. refine (pr1 (less_than_dcpo_lub (prod_directed_set_dcpo D D') (D i ,, D' Di') (i ,, Di') _)). use prod_dcpo_le ; cbn. * apply refl_dcpo. * apply refl_dcpo. + use dcpo_lub_is_least. intro i'. refine (pr2 (less_than_dcpo_lub (prod_directed_set_dcpo D D') (D Di ,, D' i') (Di ,, i') _)). use prod_dcpo_le ; cbn. * apply refl_dcpo. * apply refl_dcpo. Qed. (** * 8. A basis for the product *) Section ProductBasis. Context {X Y : dcpo} (BX : dcpo_basis X) (BY : dcpo_basis Y). Proposition way_below_prod_pr1 {xy₁ xy₂ : prod_dcpo X Y} (p : xy₁ ≪ xy₂) : pr1 xy₁ ≪ pr1 xy₂. Proof. intros D q. pose (D' := prod_directed_set_dcpo D (directed_set_from_basis BY (pr2 xy₂))). assert (HD : xy₂ ⊑ ⨆ D'). { unfold D'. rewrite prod_dcpo_lub'. rewrite approximating_basis_lub. exact (q ,, refl_dcpo _). } assert (H := p D' HD). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ i H ]. exact (hinhpr (pr1 i ,, pr1 H)). Qed. Proposition way_below_prod_pr2 {xy₁ xy₂ : prod_dcpo X Y} (p : xy₁ ≪ xy₂) : pr2 xy₁ ≪ pr2 xy₂. Proof. intros D q. pose (D' := prod_directed_set_dcpo (directed_set_from_basis BX (pr1 xy₂)) D). assert (HD : xy₂ ⊑ ⨆ D'). { unfold D'. rewrite prod_dcpo_lub'. rewrite approximating_basis_lub. exact (refl_dcpo _ ,, q). } assert (H := p D' HD). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ i H ]. exact (hinhpr (pr2 i ,, pr2 H)). Qed. Proposition to_way_below_prod {xy₁ xy₂ : prod_dcpo X Y} (p : pr1 xy₁ ≪ pr1 xy₂) (q : pr2 xy₁ ≪ pr2 xy₂) : xy₁ ≪ xy₂. Proof. intros D r. rewrite prod_dcpo_lub in r. assert (H := p (directed_set_comp π₁ D) (pr1 r)). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ i s₁ ]. assert (H := q (directed_set_comp π₂ D) (pr2 r)). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ j s₂ ]. assert (H := directed_set_top D i j). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ t [ u₁ u₂ ]]. simple refine (hinhpr (t ,, _ ,, _)). - exact (trans_dcpo s₁ (pr1 u₁)). - exact (trans_dcpo s₂ (pr2 u₂)). Qed. Proposition way_below_prod_weq (xy₁ xy₂ : prod_dcpo X Y) : xy₁ ≪ xy₂ ≃ ((pr1 xy₁ ≪ pr1 xy₂) ∧ (pr2 xy₁ ≪ pr2 xy₂)). Proof. use weqimplimpl. - intros p. split. + exact (way_below_prod_pr1 p). + exact (way_below_prod_pr2 p). - intros p. exact (to_way_below_prod (pr1 p) (pr2 p)). - apply propproperty. - apply propproperty. Qed. Definition prod_dcpo_basis_data : dcpo_basis_data (prod_dcpo X Y). Proof. use make_dcpo_basis_data. - exact (BX × BY)%type. - exact (dirprodf BX BY). Defined. Proposition prod_dcpo_basis_laws : dcpo_basis_laws (X × Y) prod_dcpo_basis_data. Proof. intros xy. split. - split. + assert (H := directed_set_el (directed_set_from_basis BX (pr1 xy))). revert H. use factor_through_squash. { apply propproperty. } intros a. induction a as [ a p ]. assert (H := directed_set_el (directed_set_from_basis BY (pr2 xy))). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b q ]. refine (hinhpr ((a ,, b) ,, _)). use to_way_below_prod. * exact p. * exact q. + intros ij₁ ij₂. assert (H := directed_set_top (directed_set_from_basis BX (pr1 xy)) (pr11 ij₁ ,, way_below_prod_pr1 (pr2 ij₁)) (pr11 ij₂ ,, way_below_prod_pr1 (pr2 ij₂))). revert H. use factor_through_squash. { apply propproperty. } intros k. induction k as [ k [ p₁ p₂ ]]. assert (H := directed_set_top (directed_set_from_basis BY (pr2 xy)) (pr21 ij₁ ,, way_below_prod_pr2 (pr2 ij₁)) (pr21 ij₂ ,, way_below_prod_pr2 (pr2 ij₂))). revert H. use factor_through_squash. { apply propproperty. } intros l. induction l as [ l [ q₁ q₂ ]]. simple refine (hinhpr (((_ ,, _) ,, _) ,, (_ ,, _) ,, (_ ,, _))). * exact (pr1 k). * exact (pr1 l). * use to_way_below_prod. ** exact (pr2 k). ** exact (pr2 l). * exact p₁. * exact q₁. * exact p₂. * exact q₂. - use is_least_upperbound_pair. + split. * intros a. refine (is_least_upperbound_is_upperbound (is_least_upperbound_basis BX (pr1 xy)) (pr11 a ,, _)). apply (way_below_prod_pr1 (pr2 a)). * intros a Ha. apply (is_least_upperbound_is_least (is_least_upperbound_basis BX (pr1 xy))). intros b. assert (H := basis_nullary_interpolation BY (pr2 xy)). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ c p ]. simple refine (Ha ((pr1 b ,, c) ,, _)). use to_way_below_prod. ** exact (pr2 b). ** exact p. + split. * intros a. refine (is_least_upperbound_is_upperbound (is_least_upperbound_basis BY (pr2 xy)) (pr21 a ,, _)). apply (way_below_prod_pr2 (pr2 a)). * intros a Ha. apply (is_least_upperbound_is_least (is_least_upperbound_basis BY (pr2 xy))). intros b. assert (H := basis_nullary_interpolation BX (pr1 xy)). revert H. use factor_through_squash. { apply propproperty. } intro H. induction H as [ c p ]. simple refine (Ha ((c ,, pr1 b) ,, _)). use to_way_below_prod. ** exact p. ** exact (pr2 b). Qed. Definition prod_dcpo_basis : dcpo_basis (prod_dcpo X Y). Proof. use make_dcpo_basis. - exact prod_dcpo_basis_data. - exact prod_dcpo_basis_laws. Defined. End ProductBasis. Definition dcpo_continuous_struct_product {X Y : dcpo} (CX : continuous_dcpo_struct X) (CY : continuous_dcpo_struct Y) : continuous_dcpo_struct (prod_dcpo X Y). Proof. use continuous_struct_from_basis. use prod_dcpo_basis. - use basis_from_continuous_struct. exact CX. - use basis_from_continuous_struct. exact CY. Defined. (** * 9. Products of Scott-open sets The Scott-open sets in the binary product are the products of Scott-open sets. *) Section scott_open_binprod. Context {A B : dcpo}. Proposition is_scott_open_pr1 (P : scott_open_set (A × B)%dcpo) (b : B) : is_scott_open (λ a, P (a ,, b)). Proof. split. - intros a₁ a₂ p₁ p₂. use (is_scott_open_upper_set P p₁). split. + exact p₂. + apply refl_dcpo. - intros D Dp. pose (is_scott_open_lub_inaccessible P (prod_directed_set_dcpo D (const_directed_set B b D (directed_set_el D)))) as p. rewrite prod_dcpo_lub' in p. rewrite const_lub in p. assert (H := p Dp). revert H. use factor_through_squash_hProp. intros ( i & H ) ; cbn in i, H. refine (hinhpr (pr1 i ,, _)). exact H. Qed. Definition scott_open_pr1 (P : scott_open_set (A × B)) (b : B) : scott_open_set A. Proof. simple refine (_ ,, _). - exact (λ a, P (a ,, b)). - exact (is_scott_open_pr1 P b). Defined. Proposition is_scott_open_pr2 (P : scott_open_set (A × B)) (a : A) : is_scott_open (λ b, P (a ,, b)). Proof. split. - intros b₁ b₂ p₁ p₂. use (is_scott_open_upper_set P p₁). split. + apply refl_dcpo. + exact p₂. - intros D Dp. pose (is_scott_open_lub_inaccessible P (prod_directed_set_dcpo (const_directed_set A a D (directed_set_el D)) D)) as p. rewrite prod_dcpo_lub' in p. rewrite const_lub in p. assert (H := p Dp). revert H. use factor_through_squash_hProp. intros ( i & H ) ; cbn in i, H. refine (hinhpr (pr2 i ,, _)). exact H. Qed. Definition scott_open_pr2 (P : scott_open_set (A × B)) (a : A) : scott_open_set B. Proof. simple refine (_ ,, _). - exact (λ b, P (a ,, b)). - exact (is_scott_open_pr2 P a). Defined. Proposition prod_is_scott_open (PA : scott_open_set A) (PB : scott_open_set B) : is_scott_open (λ (x : (A × B)%dcpo), PA (pr1 x) ∧ PB (pr2 x)). Proof. split. - intros ( a₁ & b₁ ) ( a₂ & b₂ ) ( p₁ & p₂ ) ( q₁ & q₂ ). exact (is_scott_open_upper_set PA p₁ q₁ ,, is_scott_open_upper_set PB p₂ q₂). - intros D ( p & q ). rewrite prod_dcpo_lub in p, q. cbn in p, q. assert (H₁ := is_scott_open_lub_inaccessible PA (directed_set_comp π₁ D) p). assert (H₂ := is_scott_open_lub_inaccessible PB (directed_set_comp π₂ D) q). revert H₁. use factor_through_squash_hProp. intros ( i₁ & H₁ ) ; cbn in i₁, H₁. revert H₂. use factor_through_squash_hProp. intros ( i₂ & H₂ ) ; cbn in i₂, H₂. assert (H₃ := directed_set_top D i₁ i₂). revert H₃. use factor_through_squash_hProp. intros ( k & r₁ & r₂ ) ; cbn in k, r₁, r₂. refine (hinhpr (k ,, _ ,, _)). + exact (is_scott_open_upper_set PA H₁ (pr1 r₁)). + exact (is_scott_open_upper_set PB H₂ (pr2 r₂)). Qed. Definition prod_scott_open (PA : scott_open_set A) (PB : scott_open_set B) : scott_open_set (A × B). Proof. simple refine (_ ,, _). - exact (λ x, PA (pr1 x) ∧ PB (pr2 x)). - exact (prod_is_scott_open PA PB). Defined. End scott_open_binprod. (** * 10. Strongly maximal elements in products Applies to continuous DCPOs *) Section StronglyMaximal. Context {A B : dcpo} (CA : continuous_dcpo_struct A) (CB : continuous_dcpo_struct B). Let basis_A : dcpo_basis A := basis_from_continuous_struct CA. Let basis_B : dcpo_basis B := basis_from_continuous_struct CB. Proposition strongly_maximal_pr1 {a : A} {b : B} (Hab : @is_strongly_maximal (A × B)%dcpo (a ,, b)) : is_strongly_maximal a. Proof. assert (H := nullary_interpolation CB b). revert H. use factor_through_squash_hProp. intros ( bl & p ). intros x y q. pose (qp := @to_way_below_prod A B (x ,, bl) (y ,, b) q p). assert (H := Hab (x ,, bl) (y ,, b) qp). revert H. use factor_through_squash_hProp. intros [ H | H ]. - use hdisj_in1. exact (way_below_prod_pr1 basis_B H). - use hdisj_in2. revert H. use factor_through_squash_hProp. intros ( P₁ & P₂ & H₁ & H₂ & H₃ ). use hinhpr. refine (scott_open_pr1 P₁ b ,, scott_open_pr1 P₂ b ,, _ ,, _ ,, _) ; cbn. + exact H₁. + exact H₂. + intros z n. refine (H₃ (z ,, b) _). exact n. Qed. Proposition strongly_maximal_pr2 {a : A} {b : B} (Hab : @is_strongly_maximal (A × B)%dcpo (a ,, b)) : is_strongly_maximal b. Proof. assert (H := nullary_interpolation CA a). revert H. use factor_through_squash_hProp. intros ( al & p ). intros x y q. pose (qp := @to_way_below_prod A B (al ,, x) (a ,, y) p q). assert (H := Hab (al ,, x) (a ,, y) qp). revert H. use factor_through_squash_hProp. intros [ H | H ]. - use hdisj_in1. exact (way_below_prod_pr2 basis_A H). - use hdisj_in2. revert H. use factor_through_squash_hProp. intros ( P₁ & P₂ & H₁ & H₂ & H₃ ). use hinhpr. refine (scott_open_pr2 P₁ a ,, scott_open_pr2 P₂ a ,, _ ,, _ ,, _) ; cbn. + exact H₁. + exact H₂. + intros z n. refine (H₃ (a ,, z) _). exact n. Qed. Proposition strongly_maximal_pair {a : A} {b : B} (Ha : is_strongly_maximal a) (Hb : is_strongly_maximal b) : @is_strongly_maximal (A × B)%dcpo (a ,, b). Proof. intros ( x₁ & y₁ ) ( x₂ & y₂ ) q. pose (p₁ := way_below_prod_pr1 basis_B q : x₁ ≪ x₂). pose (p₂ := way_below_prod_pr2 basis_A q : y₁ ≪ y₂). assert (H := Ha x₁ x₂ p₁). revert H. use factor_through_squash_hProp. intros H₁. assert (H := Hb y₁ y₂ p₂). revert H. use factor_through_squash_hProp. intros H₂. induction H₁ as [ H₁ | H₁ ], H₂ as [ H₂ | H₂ ]. - use hdisj_in1. use to_way_below_prod. + exact H₁. + exact H₂. - use hdisj_in2. revert H₂. use factor_through_squash_hProp. intros ( P₁ & P₂ & r₁ & r₂ & r₃ ). refine (hinhpr _). refine (prod_scott_open (true_scott_open_set _) P₁ ,, _). refine (prod_scott_open (true_scott_open_set _) P₂ ,, _ ,, _ ,, _) ; cbn. + exact (tt ,, r₁). + exact (tt ,, r₂). + intros ( x₃ & y₃ ). intros ( ( _ & s₁ ) & ( _ & s₂ ) ) ; cbn in s₁, s₂. exact (r₃ _ (s₁ ,, s₂)). - use hdisj_in2. revert H₁. use factor_through_squash_hProp. intros ( P₁ & P₂ & r₁ & r₂ & r₃ ). refine (hinhpr _). refine (prod_scott_open P₁ (true_scott_open_set _) ,, _). refine (prod_scott_open P₂ (true_scott_open_set _) ,, _ ,, _ ,, _) ; cbn. + exact (r₁ ,, tt). + exact (r₂ ,, tt). + intros ( x₃ & y₃ ). intros ( ( s₁ & _ ) & ( s₂ & _ ) ) ; cbn in s₁, s₂. exact (r₃ _ (s₁ ,, s₂)). - use hdisj_in2. revert H₁. use factor_through_squash_hProp. intros ( P₁ & P₂ & r₁ & r₂ & r₃ ). refine (hinhpr _). refine (prod_scott_open P₁ (true_scott_open_set _) ,, _). refine (prod_scott_open P₂ (true_scott_open_set _) ,, _ ,, _ ,, _) ; cbn. + exact (r₁ ,, tt). + exact (r₂ ,, tt). + intros ( x₃ & y₃ ). intros ( ( s₁ & _ ) & ( s₂ & _ ) ) ; cbn in s₁, s₂. exact (r₃ _ (s₁ ,, s₂)). Qed. Definition strongly_maximal_prod_weq (a : A) (b : B) : @is_strongly_maximal (A × B)%dcpo (a ,, b) ≃ (is_strongly_maximal a ∧ is_strongly_maximal b). Proof. use logeqweq. - exact (λ p, strongly_maximal_pr1 p ,, strongly_maximal_pr2 p). - exact (λ p, strongly_maximal_pair (pr1 p) (pr2 p)). Defined. End StronglyMaximal. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/BinarySums.v000066400000000000000000000542161451125700300241030ustar00rootroot00000000000000(**************************************************************** Coproducts of DCPOs We construct coproducts of DCPOs, and we show that the inclusion functions are Scott continuous. In addition, we show that the map coming from the universal property is Scott continuous. To construct the coproduct, we take the coproduct of the underlying posets, and then it remains to prove completeness. The idea of this proof as follows: a directed set in the coproduct of `X` and `Y` is either a directed set in `X` or a directed set in `Y`. The main statement for this is proven in [directed_set_all_inl_or_all_inr]. It says that either every value of the directed set is in `X` or that every value is in `Y`. We can determine in which of these cases we are by looking at the element of the directed set and since every two elements have an upper bound, all other elements must be in the same one. Note that it is essential here to use propositional truncations, because they are necessary to make use of directedness. The statement [directed_set_all_inl_or_all_inr] gives us two cases to consider, and these are treated similarly. In the first case, we construct a directed set in `X`: [all_inl_directed_set_to_left] while in the second case, we construct a directed set in `Y`: [all_inr_directed_set_to_right]. We also prove that the least upperbound of these directed sets correspond to the least upperbound of the original directed set. Afterwards, we prove two statements: 1. [directed_set_coproduct_with_eq] 2. [directed_set_coproduct] These collect all the facts about directed sets in the coproduct. The first is a bit stronger, because it also gives equality between members of the two directed sets. Contents 1. Directed sets in the coproduct 2. Coproduct of DCPOs 3. Scott continuity of inclusion 4. The sum of Scott continuous maps is Scott continuous ****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. Section CoproductOfDCPO. Context (X Y : dcpo). (** 1. Directed sets in the coproduct *) Section DirectedSetInCoproduct. Context (D : directed_set (coproduct_PartialOrder X Y)). Definition directed_set_all_inl_or_all_inr : (∀ (i : D), ∃ (x : X), D i = inl x) ∨ (∀ (i : D), ∃ (y : Y), D i = inr y). Proof. assert (h := directed_set_el D). revert h. use factor_through_squash. { apply propproperty. } intros i. pose (d := D i). assert (p : d = D i) by apply idpath. induction d as [ x | y ]. - refine (hinhpr (inl (λ j, _))). assert (t := directed_set_top D i j). revert t. use factor_through_squash. { apply propproperty. } intros k. induction k as [ t [ H₁ H₂ ]]. pose (Dt := D t). assert (q : Dt = D t) by apply idpath. induction Dt as [ x' | y' ]. + use hinhpr. pose (w := D j). assert (r : w = D j) by apply idpath. induction w as [ x'' | y'' ]. * exact (x'' ,, !r). * rewrite <- q, <- r in H₂. cbn in H₂. apply fromempty. exact H₂. + rewrite <- p, <- q in H₁. cbn in H₁. apply fromempty. exact H₁. - refine (hinhpr (inr (λ j, _))). assert (t := directed_set_top D i j). revert t. use factor_through_squash. { apply propproperty. } intros k. induction k as [ t [ H₁ H₂ ]]. pose (Dt := D t). assert (q : Dt = D t) by apply idpath. induction Dt as [ x' | y' ]. + use hinhpr. pose (w := D j). rewrite <- p, <- q in H₁. cbn in H₁. apply fromempty. exact H₁. + use hinhpr. pose (w := D j). assert (r : w = D j) by apply idpath. induction w as [ x'' | y'' ]. * rewrite <- q, <- r in H₂. cbn in H₂. apply fromempty. exact H₂. * exact (y'' ,, !r). Qed. Section LeftDirectedSet. Context (H : ∀ (i : D), ∃ (x : X), D i = inl x). Definition all_inl_directed_set_map_help (i : D) (w : X ⨿ Y) (r : w = D i) : X. Proof. induction w as [ x | y ]. - exact x. - abstract (apply fromempty ; assert (bot := H i) ; revert bot ; use factor_through_squash ; [ apply isapropempty | ] ; intros dx ; destruct dx as [ x p ] ; exact (negpathsii1ii2 x y (!p @ !r))). Defined. Proposition all_inl_directed_set_map_eq_help (i : D) (x : X) (r : inl x = D i) : all_inl_directed_set_map_help i (inl x) r = x. Proof. apply idpath. Qed. Definition all_inl_directed_set_map (i : D) : X := all_inl_directed_set_map_help i (D i) (idpath _). Proposition all_inl_directed_set_map_eq (i : D) (x : X) (p : D i = inl x) : all_inl_directed_set_map i = x. Proof. unfold all_inl_directed_set_map. refine (_ @ all_inl_directed_set_map_eq_help i x (!p)). induction p. apply idpath. Qed. Proposition is_directed_all_inl_directed_set_to_left : is_directed X all_inl_directed_set_map. Proof. split. - exact (directed_set_el D). - intros i j. assert (w := directed_set_top D i j). revert w. use factor_through_squash. { apply propproperty. } intros t. induction t as [ t [ H₁ H₂ ]]. assert (q := H t). revert q. use factor_through_squash. { apply propproperty. } intros [ x Hx ]. rewrite Hx in H₁, H₂. pose (wi := D i). assert (pi : wi = D i) by apply idpath. pose (wj := D j). assert (pj : wj = D j) by apply idpath. induction wi as [ xi | yi ]. + induction wj as [ xj | yj ]. * rewrite <- pi in H₁. rewrite <- pj in H₂. cbn in H₁, H₂. refine (hinhpr (t ,, _)). rewrite (all_inl_directed_set_map_eq t x Hx). rewrite (all_inl_directed_set_map_eq i xi (!pi)). rewrite (all_inl_directed_set_map_eq j xj (!pj)). split. ** exact H₁. ** exact H₂. * rewrite <- pj in H₂. cbn in H₂. exact (fromempty H₂). + rewrite <- pi in H₁. cbn in H₁. exact (fromempty H₁). Qed. Definition all_inl_directed_set_to_left : directed_set X. Proof. use make_directed_set. - exact D. - exact all_inl_directed_set_map. - exact is_directed_all_inl_directed_set_to_left. Defined. Proposition is_lub_all_inl_directed_set_to_left : is_least_upperbound (coproduct_PartialOrder X Y) D (inl (⨆ all_inl_directed_set_to_left)). Proof. split. - intros i. assert (p := H i). revert p. use factor_through_squash. { apply propproperty. } intro p. induction p as [ x p ]. rewrite p. use (less_than_dcpo_lub all_inl_directed_set_to_left _ i). cbn. rewrite (all_inl_directed_set_map_eq i x p). apply refl_dcpo. - intros y Hy. induction y as [ x | y ]. + use dcpo_lub_is_least ; cbn. intro i. pose (Hy i) as p. cbn in p. assert (H' := H i). revert H'. use factor_through_squash. { apply propproperty. } intros H'. induction H' as [ x' H' ]. rewrite H' in p. cbn in p. rewrite (all_inl_directed_set_map_eq i x' H'). exact p. + cbn. assert (el := directed_set_el D). revert el. use factor_through_squash. { apply isapropempty. } intro i. assert (H' := H i). revert H'. use factor_through_squash. { apply isapropempty. } intros H'. induction H' as [ x H' ]. pose (Hy i) as p. cbn in p. rewrite H' in p. exact p. Qed. End LeftDirectedSet. Section RightDirectedSet. Context (H : ∀ (i : D), ∃ (y : Y), D i = inr y). Definition all_inr_directed_set_map_help (i : D) (w : X ⨿ Y) (r : w = D i) : Y. Proof. induction w as [ x | y ]. - abstract (apply fromempty ; assert (bot := H i) ; revert bot ; use factor_through_squash ; [ apply isapropempty | ] ; intros dy ; destruct dy as [ y p ] ; exact (negpathsii1ii2 _ _ (r @ p))). - exact y. Defined. Proposition all_inr_directed_set_map_eq_help (i : D) (y : Y) (r : inr y = D i) : all_inr_directed_set_map_help i (inr y) r = y. Proof. apply idpath. Qed. Definition all_inr_directed_set_map (i : D) : Y := all_inr_directed_set_map_help i (D i) (idpath _). Proposition all_inr_directed_set_map_eq (i : D) (y : Y) (p : D i = inr y) : all_inr_directed_set_map i = y. Proof. unfold all_inr_directed_set_map. refine (_ @ all_inr_directed_set_map_eq_help i y (!p)). induction p. apply idpath. Qed. Proposition is_directed_all_inr_directed_set_to_right : is_directed Y all_inr_directed_set_map. Proof. split. - exact (directed_set_el D). - intros i j. assert (w := directed_set_top D i j). revert w. use factor_through_squash. { apply propproperty. } intros t. induction t as [ t [ H₁ H₂ ]]. assert (q := H t). revert q. use factor_through_squash. { apply propproperty. } intros [ y Hy ]. rewrite Hy in H₁, H₂. pose (wi := D i). assert (pi : wi = D i) by apply idpath. pose (wj := D j). assert (pj : wj = D j) by apply idpath. induction wi as [ xi | yi ]. + rewrite <- pi in H₁. cbn in H₁. exact (fromempty H₁). + induction wj as [ xj | yj ]. * rewrite <- pj in H₂. cbn in H₂. exact (fromempty H₂). * rewrite <- pi in H₁. rewrite <- pj in H₂. cbn in H₁, H₂. refine (hinhpr (t ,, _)). rewrite (all_inr_directed_set_map_eq t y Hy). rewrite (all_inr_directed_set_map_eq i yi (!pi)). rewrite (all_inr_directed_set_map_eq j yj (!pj)). split. ** exact H₁. ** exact H₂. Qed. Definition all_inr_directed_set_to_right : directed_set Y. Proof. use make_directed_set. - exact D. - exact all_inr_directed_set_map. - exact is_directed_all_inr_directed_set_to_right. Defined. Proposition is_lub_all_inr_directed_set_to_right : is_least_upperbound (coproduct_PartialOrder X Y) D (inr (⨆ all_inr_directed_set_to_right)). Proof. split. - intros i. assert (p := H i). revert p. use factor_through_squash. { apply propproperty. } intro p. induction p as [ y p ]. rewrite p. use (less_than_dcpo_lub all_inr_directed_set_to_right _ i). cbn. rewrite (all_inr_directed_set_map_eq i y p). apply refl_dcpo. - intros y Hy. induction y as [ x | y ]. + cbn. assert (el := directed_set_el D). revert el. use factor_through_squash. { apply isapropempty. } intro i. assert (H' := H i). revert H'. use factor_through_squash. { apply isapropempty. } intros H'. induction H' as [ y' H' ]. pose (Hy i) as p. cbn in p. rewrite H' in p. exact p. + use dcpo_lub_is_least ; cbn. intro i. pose (Hy i) as p. cbn in p. assert (H' := H i). revert H'. use factor_through_squash. { apply propproperty. } intros H'. induction H' as [ y' H' ]. rewrite H' in p. cbn in p. rewrite (all_inr_directed_set_map_eq i y' H'). exact p. Qed. End RightDirectedSet. Definition directed_set_coproduct_with_eq : ((∑ (D' : D → X) (HD : is_directed X D'), let DX := make_directed_set _ D D' HD in (is_least_upperbound (coproduct_PartialOrder X Y) D (inl (⨆ DX))) × (∏ (i : D), D i = inl (D' i))) ∨ (∑ (D' : D → Y) (HD : is_directed Y D'), let DY := make_directed_set _ D D' HD in is_least_upperbound (coproduct_PartialOrder X Y) D (inr (⨆ DY)) × (∏ (i : D), D i = inr (D' i))))%type. Proof. assert (h := directed_set_all_inl_or_all_inr). revert h. use factor_through_squash. { apply propproperty. } intros H. destruct H as [ H | H ]. - use hinhpr. use inl. refine (all_inl_directed_set_map H ,, _). refine (is_directed_all_inl_directed_set_to_left H ,, _). split. + apply is_lub_all_inl_directed_set_to_left. + intro i. assert (p := H i). revert p. use factor_through_squash. { apply setproperty. } intros xH. induction xH as [ x p ]. rewrite (all_inl_directed_set_map_eq H i x p). exact p. - use hinhpr. use inr. refine (all_inr_directed_set_map H ,, _). refine (is_directed_all_inr_directed_set_to_right H ,, _). split. + apply is_lub_all_inr_directed_set_to_right. + intro i. assert (p := H i). revert p. use factor_through_squash. { apply setproperty. } intros xH. induction xH as [ x p ]. rewrite (all_inr_directed_set_map_eq H i x p). exact p. Defined. Definition directed_set_coproduct : (∑ (D' : directed_set X), is_least_upperbound (coproduct_PartialOrder X Y) D (inl (⨆ D'))) ∨ (∑ (D' : directed_set Y), is_least_upperbound (coproduct_PartialOrder X Y) D (inr (⨆ D'))). Proof. assert (h := directed_set_all_inl_or_all_inr). revert h. use factor_through_squash. { apply propproperty. } intros H. destruct H as [ H | H ]. - refine (hinhpr (inl (all_inl_directed_set_to_left H ,, _))). apply is_lub_all_inl_directed_set_to_left. - refine (hinhpr (inr (all_inr_directed_set_to_right H ,, _))). apply is_lub_all_inr_directed_set_to_right. Defined. End DirectedSetInCoproduct. (** 2. Coproduct of DCPOs *) Definition coproduct_dcpo_inl_lub (D : directed_set X) : lub (coproduct_PartialOrder X Y) (directed_set_comp (inl_monotone_function X Y) D). Proof. use make_lub. - exact (inl (⨆ D)). - split. + abstract (intro i ; apply (less_than_dcpo_lub _ _ i (refl_dcpo _))). + abstract (intros y Hy ; cbn in y, Hy ; induction y as [ x' | y' ] ; [ exact (dcpo_lub_is_least D x' Hy) | ] ; cbn in * ; assert (w := directed_set_el D) ; revert w ; use factor_through_squash ; [ apply isapropempty | ] ; exact Hy). Defined. Definition coproduct_dcpo_inr_lub (D : directed_set Y) : lub (coproduct_PartialOrder X Y) (directed_set_comp (inr_monotone_function X Y) D). Proof. use make_lub. - exact (inr (⨆ D)). - split. + abstract (intro i ; apply (less_than_dcpo_lub _ _ i (refl_dcpo _))). + abstract (intros y Hy ; cbn in y, Hy ; induction y as [ x' | y' ] ; [ | exact (dcpo_lub_is_least D y' Hy) ] ; cbn in * ; assert (w := directed_set_el D) ; revert w ; use factor_through_squash ; [ apply isapropempty | ] ; exact Hy). Defined. Definition coproduct_dcpo_lub (D : directed_set (coproduct_PartialOrder X Y)) : lub (coproduct_PartialOrder X Y) D. Proof. assert (D' := directed_set_coproduct D). revert D'. use factor_through_squash. { apply isaprop_lub. } intros D'. induction D' as [ D' | D' ]. - induction D' as [ D' H ]. use make_lub. + exact (inl (⨆ D')). + exact H. - induction D' as [ D' H ]. use make_lub. + exact (inr (⨆ D')). + exact H. Defined. Definition coproduct_dcpo_struct : dcpo_struct (setcoprod X Y). Proof. use make_dcpo_struct. - exact (coproduct_PartialOrder X Y). - intros I Df HDf. pose (D := make_directed_set _ I Df HDf). exact (coproduct_dcpo_lub D). Defined. Definition coproduct_dcpo : dcpo := _ ,, coproduct_dcpo_struct. (** 3. Scott continuity of inclusion *) Proposition is_scott_continuous_inl : is_scott_continuous X coproduct_dcpo inl. Proof. use make_is_scott_continuous. - apply inl_monotone_function. - intro D ; cbn. use (eq_lub coproduct_dcpo (directed_set_comp (inl_monotone_function X Y) D)). + exact (pr2 (coproduct_dcpo_inl_lub D)). + exact (is_least_upperbound_dcpo_comp_lub _ D). Qed. Definition inl_scott_continuous_map : scott_continuous_map X coproduct_dcpo := inl ,, is_scott_continuous_inl. Proposition is_scott_continuous_inr : is_scott_continuous Y coproduct_dcpo inr. Proof. use make_is_scott_continuous. - apply inr_monotone_function. - intro D ; cbn. use (eq_lub coproduct_dcpo (directed_set_comp (inr_monotone_function X Y) D)). + exact (pr2 (coproduct_dcpo_inr_lub D)). + exact (is_least_upperbound_dcpo_comp_lub _ D). Qed. Definition inr_scott_continuous_map : scott_continuous_map Y coproduct_dcpo := inr ,, is_scott_continuous_inr. (** 4. The sum of Scott continuous maps is Scott continuous *) Proposition is_scott_continuous_sumofmaps {Z : dcpo} {f : X → Z} (Pf : is_scott_continuous X Z f) {g : Y → Z} (Pg : is_scott_continuous Y Z g) : is_scott_continuous coproduct_dcpo Z (sumofmaps f g). Proof. use make_is_scott_continuous. - exact (is_monotone_sumofmaps _ _ (pr1 Pf) (pr1 Pg)). - intros D. assert (D' := directed_set_coproduct_with_eq D). revert D'. use factor_through_squash. { apply (pr1 Z). } intros D'. induction D' as [ D' | D' ]. + induction D' as [ D' [ HD' [ H p ]]]. pose (DX := make_directed_set _ _ D' HD'). assert (⨆ D = inl (⨆ DX)) as q. { use (eq_lub coproduct_dcpo D _ H). apply is_least_upperbound_dcpo_lub. } rewrite q. cbn. refine (scott_continuous_map_on_lub (f ,, Pf) DX @ _). use antisymm_dcpo. * use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. ** exact i. ** cbn. rewrite p ; cbn. apply refl_dcpo. * use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. ** exact i. ** cbn. rewrite p ; cbn. apply refl_dcpo. + induction D' as [ D' [ HD' [ H p ]]]. pose (DY := make_directed_set _ _ D' HD'). assert (⨆ D = inr (⨆ DY)) as q. { use (eq_lub coproduct_dcpo D _ H). apply is_least_upperbound_dcpo_lub. } rewrite q. cbn. refine (scott_continuous_map_on_lub (g ,, Pg) DY @ _). use antisymm_dcpo. * use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. ** exact i. ** cbn. rewrite p ; cbn. apply refl_dcpo. * use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. ** exact i. ** cbn. rewrite p ; cbn. apply refl_dcpo. Qed. Definition sumof_scott_continuous_maps {Z : dcpo} (f : scott_continuous_map X Z) (g : scott_continuous_map Y Z) : scott_continuous_map coproduct_dcpo Z := sumofmaps f g ,, is_scott_continuous_sumofmaps (pr2 f) (pr2 g). End CoproductOfDCPO. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Discrete.v000066400000000000000000000172771451125700300235570ustar00rootroot00000000000000(***************************************************************** Discrete DCPOs Every set gives rise to a DCPO whose relation is given by equality. Contents 1. Definition of the discrete DCPO 2. Maps from the discrete DCPO 3. Counit of the discrete DCPO adjunction 4. A basis for the discrete DCPO *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. (** 1. Definition of the discrete DCPO *) Section DiscreteDCPO. Context (A : hSet). Definition directed_complete_poset_discrete_partial_order : directed_complete_poset (discrete_partial_order A). Proof. intros I D HD. assert (h := is_directed_el HD). revert h. use factor_through_squash. { apply isaprop_lub. } intro i. use make_lub. - exact (D i). - split. + intros j ; cbn. assert (h := is_directed_top HD i j). revert h. use factor_through_squash. { apply setproperty. } cbn. intros k. induction k as [ k [ p q ]]. rewrite p, q. apply idpath. + intros a p ; cbn in *. apply p. Defined. Definition discrete_dcpo_struct : dcpo_struct A := discrete_partial_order A ,, directed_complete_poset_discrete_partial_order. Definition discrete_dcpo : dcpo := A ,, discrete_dcpo_struct. End DiscreteDCPO. Proposition discrete_dcpo_lub {A : hSet} (D : directed_set (discrete_dcpo A)) (i : D) : ⨆ D = D i. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro j. cbn. assert (H := directed_set_top D i j). revert H. use factor_through_squash. { apply setproperty. } cbn ; intros H. induction H as [ k [ p q ]]. rewrite p, q. apply idpath. - use less_than_dcpo_lub. + exact i. + apply refl_dcpo. Qed. (** 2. Maps from the discrete DCPO *) Definition monotone_function_discrete_dcpo {A : hSet} (X : dcpo) (f : A → X) : monotone_function (discrete_dcpo A) X. Proof. refine (f ,, _). abstract (intros x₁ x₂ p ; induction p ; apply refl_dcpo). Defined. Proposition is_scott_continuous_map_from_discrete_dcpo {A : hSet} {X : dcpo} (f : A → X) : is_scott_continuous (pr2 (discrete_dcpo A)) (pr2 X) f. Proof. use make_is_scott_continuous. - apply (pr2 (monotone_function_discrete_dcpo X f)). - intros D. assert (H := directed_set_el D). revert H. use factor_through_squash. { apply setproperty. } cbn ; intros i. rewrite (discrete_dcpo_lub D i). use antisymm_dcpo. + use less_than_dcpo_lub. * exact i. * cbn. apply refl_dcpo. + use dcpo_lub_is_least. intro j ; cbn. cbn in *. assert (H := directed_set_top D i j). revert H. use factor_through_squash. { apply propproperty. } cbn ; intros H. induction H as [ k [ p q ]]. rewrite p, q. apply refl_dcpo. Qed. Definition map_from_discrete_dcpo {A : hSet} {X : dcpo} (f : A → X) : scott_continuous_map (discrete_dcpo A) X := f ,, is_scott_continuous_map_from_discrete_dcpo f. Definition discrete_dcpo_mor {A B : hSet} (f : A → B) : is_scott_continuous (discrete_dcpo A) (discrete_dcpo B) f. Proof. apply is_scott_continuous_map_from_discrete_dcpo. Qed. Definition monotone_function_discrete_dcpo_counit (A : dcpo) : monotone_function (discrete_dcpo A) A. Proof. refine (idfun _ ,, _). abstract (cbn ; intros x₁ x₂ p ; induction p ; apply refl_dcpo). Defined. (** 3. Counit of the discrete DCPO adjunction *) Definition discrete_dcpo_counit (A : dcpo) : is_scott_continuous (discrete_dcpo A) A (λ z, z). Proof. use make_is_scott_continuous. - exact (pr2 (monotone_function_discrete_dcpo_counit A)). - intro D. use antisymm_dcpo. + cbn. pose (@dcpo_lub_is_least (discrete_dcpo A) D (⨆_{D} (monotone_function_discrete_dcpo_counit A))) as p. rewrite p. * apply refl_dcpo. * intro i. use antisymm_dcpo. ** exact (@less_than_dcpo_lub A (directed_set_comp (monotone_function_discrete_dcpo_counit A) D) (D i) i (refl_dcpo _)). ** use dcpo_lub_is_least. intro j. cbn. assert (h := directed_set_top D i j). revert h. use factor_through_squash. { apply propproperty. } cbn. intros k. induction k as [ k [ r r' ]]. rewrite r, r'. apply refl_dcpo. + use dcpo_lub_is_least. intro i ; cbn. pose (@less_than_dcpo_lub (discrete_dcpo A) D (D i) i (refl_dcpo _)) as p. cbn in p. rewrite p. apply refl_dcpo. Qed. (** 4. A basis for the discrete DCPO *) Section DiscreteDCPOBasis. Context (X : hSet). Proposition discrete_eq_to_way_below {x y : discrete_dcpo X} (p : x = y) : x ≪ y. Proof. induction p. intros D HD. assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intros i. refine (hinhpr (i ,, _)). rewrite (less_than_dcpo_lub D (D i) i (refl_dcpo _)). exact HD. Qed. Proposition discrete_way_below_to_eq {x y : discrete_dcpo X} (p : x ≪ y) : x = y. Proof. exact (way_below_to_le p). Qed. Definition discrete_dcpo_basis_data : dcpo_basis_data (discrete_dcpo X). Proof. use make_dcpo_basis_data. - exact X. - exact (λ x, x). Defined. Proposition discrete_dcpo_basis_laws : dcpo_basis_laws (discrete_dcpo X) discrete_dcpo_basis_data. Proof. intro x. split. - split. + refine (hinhpr (x ,, _)). apply discrete_eq_to_way_below. apply idpath. + intros i j. induction i as [ y₁ p₁ ]. induction j as [ y₂ p₂ ]. simple refine (hinhpr ((_ ,, _) ,, _ ,, _)). * exact x. * apply discrete_eq_to_way_below. apply idpath. * apply discrete_way_below_to_eq. exact p₁. * apply discrete_way_below_to_eq. exact p₂. - split. + intros y. induction y as [ y p ]. apply discrete_way_below_to_eq. exact p. + intros y Hy. refine (Hy (x ,, _)). apply discrete_eq_to_way_below. apply idpath. Qed. Definition discrete_dcpo_basis : dcpo_basis (discrete_dcpo X). Proof. use make_dcpo_basis. - exact discrete_dcpo_basis_data. - exact discrete_dcpo_basis_laws. Defined. Definition dcpo_continuous_struct_discrete : continuous_dcpo_struct (discrete_dcpo X). Proof. use continuous_struct_from_basis. exact discrete_dcpo_basis. Defined. End DiscreteDCPOBasis. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Equalizers.v000066400000000000000000000142751451125700300241340ustar00rootroot00000000000000(***************************************************************** Equalizers of DCPOs In this file, we construct equalizers of both DCPOs and pointed DCPOs, and we prove the expected universal property for these. Contents 1. Equalizers 2. Equalizers of pointed DCPOs *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. (** 1. Equalizers *) Section Equalizers. Context {X Y : dcpo} (f g : scott_continuous_map X Y). Definition Equalizer_directed_set (D : directed_set (Equalizer_order X Y f g)) : directed_set X. Proof. use make_directed_set. - exact D. - exact (λ i, pr1 (D i)). - abstract (refine (directed_set_el D ,, _) ; intros i j ; assert (k := directed_set_top D i j) ; revert k ; use factor_through_squash ; [ apply propproperty | ] ; intros k ; induction k as [ k [ H₁ H₂ ]] ; exact (hinhpr (k ,, (H₁ ,, H₂)))). Defined. Definition equalizer_lub_el (D : directed_set (Equalizer_order X Y f g)) : X := ⨆ Equalizer_directed_set D. Proposition equalizer_lub_path (D : directed_set (Equalizer_order X Y f g)) : f (equalizer_lub_el D) = g (equalizer_lub_el D). Proof. unfold equalizer_lub_el. rewrite !scott_continuous_map_on_lub. use antisymm_dcpo. - use dcpo_lub_is_least. intro i. use less_than_dcpo_lub ; [ exact i | ]. change ((f {{Equalizer_directed_set D}}) i) with (f (pr1 (D i))). change ((g {{Equalizer_directed_set D}}) i) with (g (pr1 (D i))). rewrite (pr2 (D i)). apply refl_dcpo. - use dcpo_lub_is_least. intro i. use less_than_dcpo_lub ; [ exact i | ]. change ((f {{Equalizer_directed_set D}}) i) with (f (pr1 (D i))). change ((g {{Equalizer_directed_set D}}) i) with (g (pr1 (D i))). rewrite (pr2 (D i)). apply refl_dcpo. Qed. Proposition is_lub_equalizer_lub (D : directed_set (Equalizer_order X Y f g)) : is_least_upperbound (Equalizer_order X Y f g) D (equalizer_lub_el D ,, equalizer_lub_path D). Proof. split. - intros i. refine (less_than_dcpo_lub (Equalizer_directed_set D) _ i _). apply refl_dcpo. - intros y Hy. use (dcpo_lub_is_least (Equalizer_directed_set D)). intro i. exact (Hy i). Qed. Definition equalizer_lub (D : directed_set (Equalizer_order X Y f g)) : lub (Equalizer_order X Y f g) D. Proof. use make_lub. - exact (⨆ Equalizer_directed_set D ,, equalizer_lub_path D). - exact (is_lub_equalizer_lub D). Defined. Definition directed_complete_equalizer : directed_complete_poset (Equalizer_order X Y f g). Proof. intros I D HD. exact (equalizer_lub (I ,, (D ,, HD))). Defined. Definition equalizer_dcpo_struct : dcpo_struct (∑ (x : X), hProp_to_hSet (f x = g x)%logic)%set. Proof. simple refine (_ ,, _). - exact (Equalizer_order X _ f g). - exact directed_complete_equalizer. Defined. Definition equalizer_dcpo : dcpo := _ ,, equalizer_dcpo_struct. Proposition is_scott_continuous_equalizer_pr1 : is_scott_continuous equalizer_dcpo X pr1. Proof. use make_is_scott_continuous. - exact (Equalizer_pr1_monotone X Y f g). - intros D ; cbn. use antisymm_dcpo. + use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; [ exact i | ] ; cbn. apply refl_dcpo. + use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; [ exact i | ] ; cbn. apply refl_dcpo. Qed. Proposition is_scott_continuous_equalizer_map {W : dcpo} (h : scott_continuous_map W X) (p : (λ w : W, f (h w)) = (λ w : W, g (h w))) : is_scott_continuous W equalizer_dcpo (λ w, h w ,, eqtohomot p w). Proof. use make_is_scott_continuous. - exact (Equalizer_map_monotone X Y f g W (pr12 h) (eqtohomot p)). - intro D. use subtypePath. { intro. apply propproperty. } cbn. rewrite scott_continuous_map_on_lub. use antisymm_dcpo. + use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; [ exact i | ] ; cbn. apply refl_dcpo. + use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub ; [ exact i | ] ; cbn. apply refl_dcpo. Qed. End Equalizers. (** 2. Equalizers of pointed DCPOs *) Section EqualizersDCPPO. Context {X Y : dcppo} (f g : strict_scott_continuous_map X Y). Definition equalizer_dcppo_struct : dcppo_struct (∑ (x : X), hProp_to_hSet (f x = g x)%logic)%set. Proof. simple refine (equalizer_dcpo_struct f g ,, (⊥_{X} ,, _) ,, _). - abstract (cbn ; refine (strict_scott_continuous_map_on_point f @ !_) ; apply (strict_scott_continuous_map_on_point g)). - abstract (cbn ; intros xp ; apply is_min_bottom_dcppo). Defined. Proposition is_strict_scott_continuous_equalizer_pr1 : is_strict_scott_continuous equalizer_dcppo_struct X pr1. Proof. simple refine (_ ,, _). - exact (is_scott_continuous_equalizer_pr1 f g). - apply idpath. Qed. Proposition is_strict_scott_continuous_equalizer_map {W : dcppo} (h : strict_scott_continuous_map W X) (p : (λ w : W, f (h w)) = (λ w : W, g (h w))) : is_strict_scott_continuous W equalizer_dcppo_struct (λ w, h w ,, eqtohomot p w). Proof. simple refine (_ ,, _). - exact (is_scott_continuous_equalizer_map f g h p). - use subtypePath. { intro. apply propproperty. } cbn. apply strict_scott_continuous_map_on_point. Qed. End EqualizersDCPPO. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Exponentials.v000066400000000000000000000223141451125700300244520ustar00rootroot00000000000000(***************************************************************** Exponentials for DCPOs We construct exponentials for the category of DCPOs. Concretely, we show that the set of Scott continuous functions between DCPOs is a DCPO as well. Contents 1. Lemmas for calculation purposes 2. The exponential 3. Completeness of the exponential 4. Evaluation 5. Abstraction *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.FubiniTheorem. Require Import UniMath.OrderTheory.DCPOs.Core.CoordinateContinuity. Require Import UniMath.OrderTheory.DCPOs.Examples.BinaryProducts. Local Open Scope dcpo. (** 1. Lemmas for calculation purposes *) Proposition prod_dcpo_monotone_lub_const_l {X Y Z : dcpo} (D : directed_set Y) (f : monotone_function (X × Y) Z) (x : X) {I : UU} (i : ∥ I ∥) : ⨆_{prod_directed_set_dcpo (const_directed_set X x I i) D} f = ⨆_{D} (f ·l x). Proof. use antisymm_dcpo. - use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub ; cbn. + exact (pr2 j). + apply refl_dcpo. - revert i. use factor_dep_through_squash. { intro. apply propproperty. } intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub ; cbn. + exact (i ,, j). + apply refl_dcpo. Qed. Proposition prod_dcpo_monotone_lub_const_r {X Y Z : dcpo} (D : directed_set X) (f : monotone_function (X × Y) Z) (y : Y) {I : UU} (i : ∥ I ∥) : ⨆_{prod_directed_set_dcpo D (const_directed_set Y y I i)} f = ⨆_{D} (f ·r y). Proof. use antisymm_dcpo. - use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub ; cbn. + exact (pr1 j). + apply refl_dcpo. - revert i. use factor_dep_through_squash. { intro. apply propproperty. } intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub ; cbn. + exact (j ,, i). + apply refl_dcpo. Qed. (** 2. The exponential *) Definition scott_continuous_map_hSet (X Y : dcpo) : hSet. Proof. refine (scott_continuous_map X Y ,, _). use isaset_total2. - use funspace_isaset. apply setproperty. - intros f. apply isasetaprop. apply isaprop_is_scott_continuous. Defined. Definition scott_continuous_map_PartialOrder (X Y : dcpo) : PartialOrder (scott_continuous_map_hSet X Y). Proof. use make_PartialOrder. - exact (λ f g, ∀ (x : X), pr1 f x ⊑ pr1 g x). - refine ((_ ,, _) ,, _). + abstract (intros f g h p q x ; exact (trans_dcpo (p x) (q x))). + abstract (intros f x ; exact (refl_dcpo (pr1 f x))). + abstract (intros f g p q ; use subtypePath ; [ intro ; apply isaprop_is_scott_continuous | ] ; use funextsec ; intro x ; exact (antisymm_dcpo (p x) (q x))). Defined. Definition scott_continuous_app (X Y : dcpo) (x : X) : monotone_function (scott_continuous_map_PartialOrder X Y) Y. Proof. simple refine (_ ,, _). - exact (λ f, pr1 f x). - abstract (intros f₁ f₂ p ; exact (p x)). Defined. (** 3. Completeness of the exponential *) Section FunctionLub. Context {X Y : dcpo} (D : directed_set (scott_continuous_map_PartialOrder X Y)). Definition pointwise_lub (x : X) : Y := ⨆ (scott_continuous_app X Y x {{ D }}). Proposition is_monotone_pointwise_lub (x₁ x₂ : X) (p : x₁ ⊑ x₂) : pointwise_lub x₁ ⊑ pointwise_lub x₂. Proof. unfold pointwise_lub. use dcpo_lub_is_least ; cbn. intro i. use less_than_dcpo_lub. - exact i. - exact (is_monotone_scott_continuous_map (_ ,, pr2 (D i)) p). Qed. Proposition is_scott_continuous_pointwise_lub : is_scott_continuous X Y pointwise_lub. Proof. use make_is_scott_continuous. - exact is_monotone_pointwise_lub. - intros D' ; unfold pointwise_lub. use antisymm_dcpo. + use dcpo_lub_is_least. cbn ; intro i. rewrite (scott_continuous_map_on_lub (D i)). use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact j. * cbn. use less_than_dcpo_lub. ** exact i. ** cbn. apply refl_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use dcpo_lub_is_least. cbn ; intro j. use less_than_dcpo_lub. * exact j. * cbn. rewrite (scott_continuous_map_on_lub (D j)). use less_than_dcpo_lub. ** exact i. ** cbn. apply refl_dcpo. Qed. Definition scott_continuous_lub_map : scott_continuous_map_hSet X Y := pointwise_lub ,, is_scott_continuous_pointwise_lub. Proposition scott_continuous_lub_map_is_least_upperbound : is_least_upperbound (scott_continuous_map_PartialOrder X Y) D scott_continuous_lub_map. Proof. split. - intros i x. use less_than_dcpo_lub. + exact i. + apply refl_dcpo. - intros f Hf x ; cbn. unfold pointwise_lub. use dcpo_lub_is_least. intro i ; cbn. exact (Hf i x). Qed. Definition scott_continuous_lub : lub (scott_continuous_map_PartialOrder X Y) D := scott_continuous_lub_map ,, scott_continuous_lub_map_is_least_upperbound. End FunctionLub. Definition dcpo_struct_funspace_order_complete (X Y : dcpo) : directed_complete_poset (scott_continuous_map_PartialOrder X Y) := λ I D HD, scott_continuous_lub (I ,, (D ,, HD)). Definition dcpo_funspace (X Y : dcpo) : dcpo := _ ,, (_ ,, dcpo_struct_funspace_order_complete X Y). Definition dcpo_struct_funspace {X Y : hSet} (DX : dcpo_struct X) (DY : dcpo_struct Y) : dcpo_struct (scott_continuous_map_hSet (X ,, DX) (Y ,, DY)) := pr2 (dcpo_funspace (X ,, DX) (Y ,, DY)). Definition dcppo_struct_funspace {X Y : hSet} (DX : dcppo_struct X) (DY : dcppo_struct Y) : dcppo_struct (scott_continuous_map_hSet (X ,, pr1 DX) (Y ,, pr1 DY)). Proof. refine (dcpo_struct_funspace DX DY ,, _). simple refine ((_ ,, _) ,, _). - exact (λ _, pr12 DY). - apply is_scott_continuous_constant. - intros f x ; cbn. apply (pr22 DY). Defined. (** 4. Evaluation *) Proposition is_scott_continuous_eval (X Y : dcpo) : is_scott_continuous (X × dcpo_funspace X Y) Y (λ xf, (pr12 xf) (pr1 xf)). Proof. use is_scott_continuous_coordinates. - intros x. use make_is_scott_continuous. + intros f g p ; cbn in *. apply p. + intros D. cbn ; unfold pointwise_lub ; cbn. use dcpo_lub_eq_pointwise. intros f ; cbn. apply idpath. - intros f. use make_is_scott_continuous. + intros x₁ x₂ p ; cbn in *. exact (is_monotone_scott_continuous_map f p). + intros D. exact (scott_continuous_map_on_lub f D). Qed. Definition eval_scott_continuous_map (X Y : dcpo) : scott_continuous_map (X × dcpo_funspace X Y) Y := _ ,, is_scott_continuous_eval X Y. (** 5. Abstraction *) Proposition is_scott_continuous_lam {X Y Z : dcpo} (f : scott_continuous_map (X × Z) Y) (H : ∏ (z : Z), is_scott_continuous (pr2 X) (pr2 Y) (λ x, f (x ,, z))) : is_scott_continuous Z (dcpo_funspace X Y) (λ z, (λ x, f(x ,, z)) ,, H z). Proof. use make_is_scott_continuous. - abstract (intros z₁ z₂ p x ; apply (is_monotone_scott_continuous_map f) ; exact (prod_dcpo_le (x ,, z₁) (x ,, z₂) (refl_dcpo _) p)). - intros D. use eq_scott_continuous_map. intro x ; cbn. etrans. { apply maponpaths. apply maponpaths_2. exact (!(const_lub x D (directed_set_el D))). } etrans. { apply maponpaths. refine (!_). apply prod_dcpo_lub'. } rewrite scott_continuous_map_on_lub. rewrite prod_dcpo_monotone_lub_const_l. unfold pointwise_lub. use antisymm_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use less_than_dcpo_lub ; cbn. * exact i. * apply refl_dcpo. + use dcpo_lub_is_least. cbn ; intro i. use less_than_dcpo_lub ; cbn. * exact i. * apply refl_dcpo. Qed. Definition lam_scott_continuous_map {X Y Z : dcpo} (f : scott_continuous_map (X × Z) Y) : scott_continuous_map Z (dcpo_funspace X Y). Proof. refine (_ ,, is_scott_continuous_lam f _). abstract (intro z ; refine (comp_is_scott_continuous _ (pr2 f)) ; use is_scott_continuous_prodtofun ; [ apply id_is_scott_continuous | apply is_scott_continuous_constant ]). Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Fixpoints.v000066400000000000000000000035561451125700300237730ustar00rootroot00000000000000(***************************************************************** The DCPO of fixpoints Let `f` be a Scott continuous map from a DCPO `X` to itself. Then there is a DCPO whose inhabitants are fixpoints of `f`. To construct this DCPO, it suffices to show that fixpoints are closed under least upperbounds. This allows us to construct the desired DCPO as a subDCPO. Contents 1. Fixpoints are closed under least upperbounds 2. The DCPO of fixpoint of a Scott continuous maps *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Examples.SubDCPO. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. Section FixpointDCPO. Context {X : dcpo} (f : scott_continuous_map X X). (** 1. Fixpoints are closed under least upperbounds *) Proposition lub_fixpoint (D : directed_set X) (HD : ∏ (d : D), f(D d) = D d) : f (⨆ D) = ⨆ D. Proof. rewrite scott_continuous_map_on_lub. use antisymm_dcpo. - use dcpo_lub_is_least. intro i ; cbn in i ; cbn. use less_than_dcpo_lub. + exact i. + exact (eq_to_le_dcpo (HD i)). - use dcpo_lub_is_least. intro i ; cbn in i ; cbn. use less_than_dcpo_lub. + exact i. + exact (eq_to_le_dcpo (!(HD i))). Qed. (** 2. The DCPO of fixpoint of a Scott continuous maps *) Definition fixpoint_dcpo : dcpo := sub_dcpo X (λ x, f x = x)%logic lub_fixpoint. End FixpointDCPO. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/IdealCompletion.v000066400000000000000000000505541451125700300250600ustar00rootroot00000000000000(****************************************************************************** The rounded ideal completion In this file, we study the rounded ideal completion. Given an abstract basis, the rounded ideal completion gives a continuous DCPO with that particular basis. If the basis is reflexive (a preorder), then the resulting DCPO is algebraic. Given an abstract basis, the rounded ideal completion is defined to be the DCPO whose inhabitants are ideal (i.e., directed lower sets of the basis). As such, there are some nuances regarding the universe level. Let's say, the basis lives in some universe U_ℓ. Then the ideal completion lives in the universe U_{ℓ⁺}. However, using propositional resizing, we can improve on this situation. This is because all propositions are equivalent to one in the lowest universe (which we call U_0). Then the rounded ideal completion lives in U_{max ℓ 1}. References: - Section 2.2.6 in the chapter 'Domain Theory' of the Handbook for Logic in Computer Science, Volume 3 (https://www.cs.ox.ac.uk/files/298/handbook.pdf) - Section 4.10 in Domain Theory in Constructive and Predicative Univalent Foundations (https://tdejong.com/writings/phd-thesis.pdf) Contents 1. Abstract bases 2. Preorder to abstract basis 3. Ideals 4. Rounded ideal completion 5. Rounded ideal completion for reflexive bases 6. Hausdorff separatedness in the ideal completion ******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Require Import UniMath.OrderTheory.DCPOs.Basis.Algebraic. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Require Import UniMath.OrderTheory.DCPOs.Basis.CompactBasis. Require Import UniMath.OrderTheory.DCPOs.Elements.Maximal. Require Import UniMath.OrderTheory.DCPOs.Examples.Products. Require Import UniMath.OrderTheory.DCPOs.Examples.SubDCPO. Require Import UniMath.OrderTheory.DCPOs.Examples.Propositions. Local Open Scope dcpo. (** 1. Abstract bases *) Definition abstract_basis_data : UU := ∑ (X : UU), X → X → hProp. Coercion type_of_abstract_basis_data (B : abstract_basis_data) : UU := pr1 B. Definition rel_of_abstract_basis_data {B : abstract_basis_data} (b₁ b₂ : B) : hProp := pr2 B b₁ b₂. Notation "b₁ ≺ b₂" := (rel_of_abstract_basis_data b₁ b₂) (at level 70). Definition make_abstract_basis_data (X : Type) (R : X → X → UU) (HR : ∏ (x y : X), isaprop (R x y)) : abstract_basis_data := X ,, λ x y, make_hProp (R x y) (HR x y). Definition abstract_basis_laws (B : abstract_basis_data) : UU := (istrans (λ (b₁ b₂ : B), b₁ ≺ b₂) × (∏ (a : B), ∃ (b : B), b ≺ a) × (∏ (a₁ a₂ b : B), a₁ ≺ b → a₂ ≺ b → ∃ (a : B), a ≺ b × a₁ ≺ a × a₂ ≺ a))%type. Definition abstract_basis : UU := ∑ (B : abstract_basis_data), abstract_basis_laws B. Definition make_abstract_basis (B : abstract_basis_data) (HB : abstract_basis_laws B) : abstract_basis := B ,, HB. Coercion abstract_basis_to_data (B : abstract_basis) : abstract_basis_data := pr1 B. Proposition trans_abstract_basis {B : abstract_basis} {b₁ b₂ b₃ : B} (p : b₁ ≺ b₂) (q : b₂ ≺ b₃) : b₁ ≺ b₃. Proof. exact (pr12 B b₁ b₂ b₃ p q). Qed. Proposition nullary_interpolation_abstract_basis {B : abstract_basis} (a : B) : ∃ (b : B), b ≺ a. Proof. exact (pr122 B a). Qed. Proposition binary_interpolation_abstract_basis {B : abstract_basis} {a₁ a₂ b : B} (p : a₁ ≺ b) (q : a₂ ≺ b) : (∃ (a : B), a ≺ b × a₁ ≺ a × a₂ ≺ a)%type. Proof. exact (pr222 B a₁ a₂ b p q). Qed. Definition is_reflexive_abstract_basis (B : abstract_basis) : UU := isrefl (λ (b₁ b₂ : B), b₁ ≺ b₂). (** 2. Preorder to abstract basis *) Section PreorderToBasis. Context (X : PreorderedSet). Definition preorder_to_abstract_basis_data : abstract_basis_data. Proof. use make_abstract_basis_data. - exact X. - exact (λ x y, PreorderedSetRelation X x y). - intros x y. apply propproperty. Defined. Proposition preorder_to_abstract_basis_laws : abstract_basis_laws preorder_to_abstract_basis_data. Proof. repeat split. - apply istrans_po. - intros a. refine (hinhpr (a ,, _)). apply isrefl_po. - intros a₁ a₂ b p q. refine (hinhpr (b ,, _ ,, p ,, q)). apply isrefl_po. Qed. Definition preorder_to_abstract_basis : abstract_basis. Proof. use make_abstract_basis. - exact preorder_to_abstract_basis_data. - exact preorder_to_abstract_basis_laws. Defined. End PreorderToBasis. (** 3. Ideals *) Section Ideals. Context {B : abstract_basis}. Definition is_ideal (P : B → hProp) : hProp := ((∃ (b : B), P b) ∧ (∀ (a₁ a₂ : B), P a₁ ⇒ P a₂ ⇒ ∃ (b : B), P b ∧ a₁ ≺ b ∧ a₂ ≺ b) ∧ (∀ (a b : B), P b ⇒ a ≺ b ⇒ P a))%logic. Definition is_ideal_el {P : B → hProp} (HP : is_ideal P) : ∃ (b : B), P b := pr1 HP. Definition is_ideal_top {P : B → hProp} (HP : is_ideal P) {a₁ a₂ : B} (Ha₁ : P a₁) (Ha₂ : P a₂) : ∃ (b : B), P b ∧ a₁ ≺ b ∧ a₂ ≺ b := pr12 HP a₁ a₂ Ha₁ Ha₂. Definition is_ideal_lower_set {P : B → hProp} (HP : is_ideal P) {a b : B} (Hb : P b) (p : a ≺ b) : P a := pr22 HP a b Hb p. Proposition is_ideal_rounded {P : B → hProp} (HP : is_ideal P) {a : B} (Ha : P a) : ∃ (b : B), a ≺ b ∧ P b. Proof. assert (H := is_ideal_top HP Ha Ha). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as ( b & p₁ & p₂ & p₃ ). exact (hinhpr (b ,, p₂ ,, p₁)). Qed. End Ideals. (** 4. Rounded ideal completion *) Section RoundedIdealCompletion. Context (B : abstract_basis). Proposition lub_of_ideals (D : directed_set (funset_dcpo B hProp_dcpo)) (HD : ∏ (d : D), is_ideal (D d)) : is_ideal (⨆ D). Proof. simple refine (_ ,, _ ,, _). - assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intro d. assert (H := is_ideal_el (HD d)). revert H. use factor_through_squash. { apply propproperty. } intro b. induction b as [ b p ]. exact (hinhpr (b ,, hinhpr (d ,, p))). - intros a₁ a₂. use factor_through_squash. { apply propproperty. } intros Ha₁ ; cbn in Ha₁. induction Ha₁ as [ d₁ p₁ ]. use factor_through_squash. { apply propproperty. } intros Ha₂ ; cbn in Ha₂. induction Ha₂ as [ d₂ p₂ ]. assert (H := directed_set_top D d₁ d₂). revert H. use factor_through_squash. { apply propproperty. } intro H ; cbn in H. induction H as [ dt [ H₁ H₂ ]]. assert (H := is_ideal_top (HD dt) (H₁ a₁ p₁) (H₂ a₂ p₂)). revert H. use factor_through_squash. { apply propproperty. } intros H. induction H as ( b & q₁ & q₂ & q₃ ). exact (hinhpr (b ,, hinhpr (dt ,, q₁) ,, q₂ ,, q₃)). - intros a b. use factor_through_squash. { apply propproperty. } intros H q ; cbn in H. induction H as [ d p ] ; cbn. refine (hinhpr (d ,, _)). exact (is_ideal_lower_set (HD d) p q). Qed. Definition rounded_ideal_completion : dcpo := sub_dcpo (funset_dcpo B hProp_dcpo) is_ideal lub_of_ideals. Definition in_rounded_ideal (b : B) (I : rounded_ideal_completion) : hProp := pr1 I b. Local Notation "b ∈ I" := (in_rounded_ideal b I). Proposition is_ideal_principal_ideal (b : B) : is_ideal (λ a, a ≺ b). Proof. repeat split. - exact (nullary_interpolation_abstract_basis b). - intros a₁ a₂ p q. exact (binary_interpolation_abstract_basis p q). - intros a₁ a₂ p q. exact (trans_abstract_basis q p). Qed. Definition principal_ideal : B → rounded_ideal_completion := λ b, ((λ a, a ≺ b) ,, is_ideal_principal_ideal b). Proposition principal_ideal_monotone {b₁ b₂ : B} (p : b₁ ≺ b₂) : principal_ideal b₁ ⊑ principal_ideal b₂. Proof. intros a q ; cbn in *. exact (trans_abstract_basis q p). Qed. Proposition is_directed_below_ideal (I : rounded_ideal_completion) : is_directed rounded_ideal_completion (λ (b : ∑ b : B, b ∈ I), principal_ideal (pr1 b)). Proof. split. - exact (is_ideal_el (pr2 I)). - intros i j. assert (H := is_ideal_top (pr2 I) (pr2 i) (pr2 j)). revert H. use factor_through_squash. { apply propproperty. } intro t. induction t as ( t & p₁ & p₂ & p₃ ). refine (hinhpr ((t ,, p₁) ,, _ ,, _)) ; cbn. + intros x q. exact (trans_abstract_basis q p₂). + intros x q. exact (trans_abstract_basis q p₃). Qed. Definition below_ideal_directed_set (I : rounded_ideal_completion) : directed_set rounded_ideal_completion. Proof. use make_directed_set. - exact (∑ (b : B), b ∈ I). - exact (λ b, principal_ideal (pr1 b)). - exact (is_directed_below_ideal I). Defined. Proposition rounded_ideal_lub_2 (I : rounded_ideal_completion) : ⨆ below_ideal_directed_set I ⊑ I. Proof. apply dcpo_lub_is_least. intros [b Hb]. intros x Hx. simpl in Hx. use (is_ideal_lower_set _ Hb Hx). apply I. Qed. Proposition rounded_ideal_lub_1 (I : rounded_ideal_completion) : I ⊑ ⨆ below_ideal_directed_set I. Proof. intros x Hx. assert (H := is_ideal_rounded (pr2 I) Hx). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b [ p₁ p₂ ]]. exact (hinhpr ((b ,, p₂) ,, p₁)). Qed. Proposition rounded_ideal_lub (I : rounded_ideal_completion) : I = ⨆ below_ideal_directed_set I. Proof. apply antisymm_dcpo. - apply rounded_ideal_lub_1. - apply rounded_ideal_lub_2. Qed. Proposition principal_ideal_way_below {I : rounded_ideal_completion} (b : B) (Hb : b ∈ I) : principal_ideal b ≪ I. Proof. intros D HD. assert (H := HD _ Hb). revert H. use factor_through_squash_hProp. intro d ; cbn in d. induction d as [ d Hd ]. refine (hinhpr (d ,, _)). cbn ; intros x Hx. exact (is_ideal_lower_set (pr2 (D d)) Hd Hx). Qed. Proposition lt_way_below (b1 b2 : B) (Hb : b1 ≺ b2) : principal_ideal b1 ≪ principal_ideal b2. Proof. apply principal_ideal_way_below. exact Hb. Qed. Proposition from_way_below_ideal_completion {I J : rounded_ideal_completion} (Hb : I ≪ J) : ∃ b₁, b₁ ∈ J ∧ I ⊑ principal_ideal b₁. Proof. specialize (Hb (below_ideal_directed_set J) (rounded_ideal_lub_1 J)). revert Hb. use factor_through_squash. { apply propproperty. } intros [[b' Hb'] Hi]. simpl in Hi. assert (H := is_ideal_el (pr2 I)). revert H. use factor_through_squash. { apply propproperty. } intros [b₀ Hb0]. use (hinhpr (b',, (Hb',, _))). - simpl. intros x Hx. apply Hi. exact Hx. Qed. Proposition to_way_below_ideal_completion {I J : rounded_ideal_completion} (b₁ : B) (Hb1 : b₁ ∈ J) (HI : I ⊑ principal_ideal b₁) : I ≪ J. Proof. intros D HJ. assert (HbJ : principal_ideal b₁ ≪ J). { apply principal_ideal_way_below, Hb1. } specialize (HbJ D HJ). revert HbJ. use factor_through_squash. { apply propproperty. } intros [i Hi]. use (hinhpr (i,, _)). exact (trans_dcpo HI Hi). Qed. Proposition way_below_ideal_completion_eq (I J : rounded_ideal_completion) : I ≪ J ≃ ∃ b₁, b₁ ∈ J ∧ I ⊑ principal_ideal b₁. Proof. use weqimplimpl. - apply from_way_below_ideal_completion. - use factor_through_squash. { apply propproperty. } intros [b [HJ HI]]. apply (to_way_below_ideal_completion b HJ HI). - apply propproperty. - apply propproperty. Defined. Definition rounded_ideal_completion_basis_data : dcpo_basis_data rounded_ideal_completion. Proof. use make_dcpo_basis_data. - exact B. - exact principal_ideal. Defined. Proposition rounded_ideal_completion_basis_laws : dcpo_basis_laws rounded_ideal_completion rounded_ideal_completion_basis_data. Proof. intro I. split. - split. + assert (H := is_ideal_el (pr2 I)). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b p ]. refine (hinhpr (b ,, _)). apply principal_ideal_way_below. exact p. + intros b₁ b₂. induction b₁ as [ b₁ p₁ ]. induction b₂ as [ b₂ p₂ ]. cbn -[way_below] in b₁, p₁, b₂, p₂. assert (H := p₁ _ (rounded_ideal_lub_1 I)). revert H. use factor_through_squash. { apply propproperty. } intros c₁. induction c₁ as ( ( c₁ & q₁ ) & s₁ ). assert (H := p₂ _ (rounded_ideal_lub_1 I)). revert H. use factor_through_squash. { apply propproperty. } intros c₂. induction c₂ as ( ( c₂ & q₂ ) & s₂ ). cbn in c₁, q₁, s₁, c₂, q₂, s₂. assert (H := is_ideal_top (pr2 I) q₁ q₂). revert H. use factor_through_squash. { apply propproperty. } intros t. induction t as ( t & r₁ & r₂ & r₃ ). simple refine (hinhpr ((t ,, _) ,, (_ ,, _))) ; cbn -[way_below]. * apply principal_ideal_way_below. exact r₁. * intros x v. refine (trans_abstract_basis _ r₂). use s₁. exact v. * intros x v. refine (trans_abstract_basis _ r₃). use s₂. exact v. - (* `I` is the supremum of all principal ideals way below `I` *) split. + intros b x p. induction b as [ b q ]. cbn -[way_below] in b, q, p. exact (way_below_to_le q x p). + intros I' HI' x p. assert (H := is_ideal_rounded (pr2 I) p). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b [ q₁ q₂ ]]. assert (H : principal_ideal b ≪ I). { apply principal_ideal_way_below. exact q₂. } exact (HI' (b ,, H) x q₁). Qed. Definition rounded_ideal_completion_basis : dcpo_basis rounded_ideal_completion. Proof. use make_dcpo_basis. - exact rounded_ideal_completion_basis_data. - exact rounded_ideal_completion_basis_laws. Defined. Definition rounded_ideal_completion_continuous_struct : continuous_dcpo_struct rounded_ideal_completion. Proof. use continuous_struct_from_basis. exact rounded_ideal_completion_basis. Defined. End RoundedIdealCompletion. (** 5. Rounded ideal completion for reflexive bases *) Section RoundedIdealCompletionAlgebraic. Context (B : abstract_basis) (HB : is_reflexive_abstract_basis B). Proposition rounded_ideal_completion_compact_basis_laws : compact_basis_laws (rounded_ideal_completion B) (rounded_ideal_completion_basis_data B). Proof. refine (_ ,, _ ,, _). - intros b ; cbn -[way_below] in *. apply principal_ideal_way_below. apply HB. - intro I. split. + assert (H := is_ideal_el (pr2 I)). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b p ]. refine (hinhpr (b ,, _)). intros x q ; cbn in q. exact (is_ideal_lower_set (pr2 I) p q). + intros b₁ b₂. induction b₁ as [ b₁ p₁ ]. induction b₂ as [ b₂ p₂ ]. cbn in b₁, p₁, b₂, p₂. assert (Hb₁ : in_rounded_ideal B b₁ I). { apply p₁. apply HB. } assert (Hb₂ : in_rounded_ideal B b₂ I). { apply p₂. apply HB. } assert (H := is_ideal_top (pr2 I) Hb₁ Hb₂). revert H. use factor_through_squash. { apply propproperty. } intro t. induction t as ( t & q₁ & q₂ & q₃ ). simple refine (hinhpr ((t ,, _) ,, _ ,, _)) ; cbn. * intros x r. exact (is_ideal_lower_set (pr2 I) q₁ r). * intros x r. exact (trans_abstract_basis r q₂). * intros x r. exact (trans_abstract_basis r q₃). - (* `I` is the supremum of all principal ideals way below `I` *) intro I. split. + intros b x p. induction b as [ b q ]. cbn in b, q, p. apply q. exact p. + intros I' HI' x p. assert (H := is_ideal_rounded (pr2 I) p). revert H. use factor_through_squash. { apply propproperty. } intros b. induction b as [ b [ q₁ q₂ ]]. refine (HI' (b ,, _) x q₁) ; cbn. intros c r. exact (is_ideal_lower_set (pr2 I) q₂ r). Qed. Definition rounded_ideal_completion_compact_basis : compact_basis (rounded_ideal_completion B). Proof. use make_compact_basis. - exact (rounded_ideal_completion_basis_data B). - exact rounded_ideal_completion_compact_basis_laws. Defined. End RoundedIdealCompletionAlgebraic. (** * 6. Hausdorff separatedness in the ideal completion *) Lemma hausdorff_separated_ideal_completion (B : abstract_basis) (x y : rounded_ideal_completion B) : is_hausdorff_separated x y ≃ (∃ (b1 b2 : B), in_rounded_ideal _ b1 x ∧ in_rounded_ideal _ b2 y ∧ ¬(∃ (b3 : B), principal_ideal _ b1 ≪ principal_ideal _ b3 ∧ principal_ideal _ b2 ≪ principal_ideal _ b3))%logic. Proof. use logeqweq. - intros H. assert (H' := hausdorff_separated_continuous_dcpo_weq (rounded_ideal_completion_basis B) x y H). revert H'. use factor_through_squash_hProp. intros ( b₁ & b₂ & p₁ & p₂ & p₃ ). assert (Q := from_way_below_ideal_completion B p₁). revert Q. use factor_through_squash_hProp. intros ( c & r₁ & r₂ ). assert (Q := from_way_below_ideal_completion B p₂). revert Q. use factor_through_squash_hProp. intros ( d & s₁ & s₂ ). refine (hinhpr (c ,, d ,, _ ,, _ ,, _)). + exact r₁. + exact s₁. + use factor_through_squash. { apply isapropempty. } intros ( e & t₁ & t₂ ). refine (p₃ _). refine (hinhpr (e ,, _ ,, _)). * exact (trans_le_way_below r₂ t₁). * exact (trans_le_way_below s₂ t₂). - use factor_through_squash_hProp. intros ( b₁ & b₂ & p₁ & p₂ & p₃ ). apply (invmap (hausdorff_separated_continuous_dcpo_weq (rounded_ideal_completion_basis B) x y)). refine (hinhpr (b₁ ,, b₂ ,, _ ,, _ ,, _)). + apply principal_ideal_way_below. exact p₁. + apply principal_ideal_way_below. exact p₂. + exact p₃. Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Products.v000066400000000000000000000150371451125700300236100ustar00rootroot00000000000000(***************************************************************** Type indexed products of DCPOs In this file, we construct type indexed products of DCPOs, and we prove the usual universal property. In addition, we use this construction to construct the DCPO whose inhabitants are subsets of a fixed set. Contents 1. Type indexed products 2. The universal property 3. It is pointed 4. Functions to a fixed DCPO 5. The subtype DCPO *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Examples.Propositions. Require Import UniMath.OrderTheory.DCPOs.Examples.SubDCPO. Local Open Scope dcpo. (** 1. Type indexed products *) Section TypeIndexedProductsDCPO. Context {I : UU} (D : I → dcpo). Definition app_directed_set_depfun (E : directed_set (depfunction_poset (λ i, D i) (λ i, D i))) (i : I) : directed_set (D i). Proof. use make_directed_set. - exact E. - exact (λ e, E e i). - split. + exact (directed_set_el E). + abstract (intros e₁ e₂ ; assert (k := directed_set_top E e₁ e₂) ; revert k ; use factor_through_squash ; [ apply propproperty | ] ; intros k ; induction k as [ k [ H₁ H₂ ]] ; exact (hinhpr (k ,, (H₁ i ,, H₂ i)))). Defined. Section DepFunctionLub. Context (E : directed_set (depfunction_poset (λ i, D i) (λ i, D i))). Definition type_prod_pointwise_lub (i : I) : D i := ⨆ (app_directed_set_depfun E i). Proposition is_lub_type_prod_pointwise_lub : is_least_upperbound (depfunction_poset (λ i : I, D i) (λ i : I, D i)) E type_prod_pointwise_lub. Proof. split. - intros e i ; cbn. use less_than_dcpo_lub ; [ exact e | ] ; cbn. apply refl_dcpo. - intros f Hf i. use dcpo_lub_is_least. intro e ; cbn. exact (Hf e i). Qed. End DepFunctionLub. Definition directed_complete_depfunction : directed_complete_poset (depfunction_poset (λ i, D i) (λ i, D i)). Proof. intros J E HE. use make_lub. - exact (type_prod_pointwise_lub (J ,, (E ,, HE))). - exact (is_lub_type_prod_pointwise_lub (J ,, (E ,, HE))). Defined. Definition depfunction_dcpo_struct : dcpo_struct (∏ y, D y)%set := depfunction_poset _ (λ i, D i) ,, directed_complete_depfunction. Definition depfunction_dcpo : dcpo := _ ,, depfunction_dcpo_struct. (** 2. The universal property *) Proposition is_scott_continuous_depfunction_pr (i : I) : is_scott_continuous depfunction_dcpo (D i) (λ f, f i). Proof. use make_is_scott_continuous. - exact (is_monotone_depfunction_poset_pr (λ i, D i) (λ i, D i) i). - intros E. cbn ; unfold type_prod_pointwise_lub. use antisymm_dcpo. + use dcpo_lub_is_least ; cbn. intro e. use less_than_dcpo_lub ; [ exact e | ] ; cbn. apply refl_dcpo. + use dcpo_lub_is_least ; cbn. intro e. use less_than_dcpo_lub ; [ exact e | ] ; cbn. apply refl_dcpo. Qed. Proposition is_scott_continuous_depfunction_map {W : dcpo} (fs : ∏ (i : I), scott_continuous_map W (D i)) : is_scott_continuous W depfunction_dcpo (λ w i, fs i w). Proof. use make_is_scott_continuous. - exact (is_monotone_depfunction_poset_pair fs (λ i, pr12 (fs i))). - intros E. use funextsec ; intro i. cbn ; unfold type_prod_pointwise_lub. rewrite scott_continuous_map_on_lub. use antisymm_dcpo. + use dcpo_lub_is_least ; cbn. intro e. use less_than_dcpo_lub ; [ exact e | ] ; cbn. apply refl_dcpo. + use dcpo_lub_is_least ; cbn. intro e. use less_than_dcpo_lub ; [ exact e | ] ; cbn. apply refl_dcpo. Qed. End TypeIndexedProductsDCPO. (** 3. It is pointed *) Definition depfunction_dcppo_struct {I : UU} (D : I → dcppo) : dcppo_struct (∏ y, D y)%set. Proof. simple refine (depfunction_dcpo_struct (λ i, D i) ,, _ ,, _). - exact (λ i, ⊥_{ D i }). - abstract (intros f i ; cbn ; apply is_min_bottom_dcppo). Defined. Definition depfunction_dcppo {I : UU} (D : I → dcppo) : dcppo := _ ,, depfunction_dcppo_struct D. Proposition is_strict_scott_continuous_depfunction_pr {I : UU} (D : I → dcppo) (i : I) : is_strict_scott_continuous (depfunction_dcppo_struct D) (D i) (λ f, f i). Proof. simple refine (_ ,, _). - exact (is_scott_continuous_depfunction_pr D i). - apply idpath. Qed. Proposition is_strict_scott_continuous_depfunction_map {I : UU} (D : I → dcppo) {W : dcppo} (fs : ∏ (i : I), strict_scott_continuous_map W (D i)) : is_strict_scott_continuous W (depfunction_dcppo D) (λ w i, fs i w). Proof. simple refine (_ ,, _). - exact (is_scott_continuous_depfunction_map D fs). - use funextsec. intro. apply strict_scott_continuous_map_on_point. Qed. (** 4. Functions to a fixed DCPO *) Definition funset_dcpo (X : UU) (D : dcpo) : dcpo := @depfunction_dcpo X (λ _, D). Definition funset_dcppo (X : UU) (D : dcppo) : dcppo := @depfunction_dcppo X (λ _, D). (** 5. The subtype DCPO *) Definition subtype_dcppo (X : UU) : dcppo := funset_dcppo X hProp_dcppo. (** 6. The DCPO of monotone functions *) Proposition lub_is_monotone {X Y : dcpo} (D : directed_set (funset_dcpo X Y)) (HD : ∏ (d : D), is_monotone X Y (D d)) : is_monotone X Y (⨆ D). Proof. intros x y p. use dcpo_lub_is_least. intro d ; cbn in d ; cbn. use less_than_dcpo_lub. { exact d. } cbn. apply HD. exact p. Qed. Definition monotone_map_dcpo (X Y : dcpo) : dcpo := sub_dcpo (funset_dcpo X Y) (λ f, make_hProp (is_monotone X Y f) (isaprop_is_monotone _ _ _)) lub_is_monotone. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Propositions.v000066400000000000000000000037621451125700300245170ustar00rootroot00000000000000(***************************************************************** hProp as a DCPO In this file, we show that hProp is a DCPO. This DCPO is also known as the Sierpinski space. Contents: 1. hProp is a DCPO 2. hProp is pointed *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. (** 1. hProp is a DCPO *) Proposition isPartialOrder_hProp : isPartialOrder (λ (P₁ P₂ : hProp), (P₁ ⇒ P₂)%logic). Proof. refine ((_ ,, _) ,, _). - exact (λ P₁ P₂ P₃ f g x, g(f x)). - exact (λ P x, x). - exact (λ P₁ P₂ f g, hPropUnivalence _ _ f g). Qed. Definition hProp_PartialOrder : PartialOrder hProp_set. Proof. use make_PartialOrder. - exact (λ (P₁ P₂ : hProp), P₁ ⇒ P₂)%logic. - exact isPartialOrder_hProp. Defined. Definition hProp_lub {D : UU} {f : D → hProp} (Hf : is_directed hProp_PartialOrder f) : lub hProp_PartialOrder f. Proof. use make_lub. - exact (∃ (d : D), f d). - refine (_ ,, _). + exact (λ d x, hinhpr (d ,, x)). + abstract (intros P HP ; use factor_through_squash ; [ apply propproperty | ] ; intro x ; exact (HP (pr1 x) (pr2 x))). Defined. Definition hProp_dcpo_struct : dcpo_struct hProp_set. Proof. use make_dcpo_struct. - exact hProp_PartialOrder. - exact (λ D f Hf, hProp_lub Hf). Defined. Definition hProp_dcpo : dcpo := _ ,, hProp_dcpo_struct. (** 2. hProp is pointed *) Definition hProp_dcppo : dcppo. Proof. refine (_ ,, hProp_dcpo_struct ,, hfalse ,, _). abstract (intros P ; exact fromempty). Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/SubDCPO.v000066400000000000000000000064121451125700300232010ustar00rootroot00000000000000(***************************************************************** Sub DCPO If we have a DCPO and a predicate on it, then the subtype of the elements satisfying that predicate, is a DCPO if the predicate is closed under suprema. Contents 1. The sub DCPO 2. The first projection is continuous *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. (** 1. The sub DCPO *) Section SubPartialOrder. Context {X : hSet} (PX : PartialOrder X) (P : X → hProp). Let S : hSet := (∑ (x : X), hProp_to_hSet (P x))%set. Definition sub_isPartialOrder : isPartialOrder (λ (x y : S), PX (pr1 x) (pr1 y)). Proof. repeat split. - intros x₁ x₂ x₃ p q. exact (trans_PartialOrder PX p q). - intros x. apply refl_PartialOrder. - intros x y p q. use subtypePath. { intro. apply propproperty. } exact (antisymm_PartialOrder PX p q). Qed. Definition sub_PartialOrder : PartialOrder S. Proof. use make_PartialOrder. - exact (λ x y, PX (pr1 x) (pr1 y)). - exact sub_isPartialOrder. Defined. Definition is_monotone_pr1_sub : is_monotone sub_PartialOrder PX pr1. Proof. intros x y p. exact p. Qed. Definition pr1_sub_monotone : monotone_function sub_PartialOrder PX := _ ,, is_monotone_pr1_sub. End SubPartialOrder. Section SubDCPO. Context (X : dcpo) (P : X → hProp) (HP : ∏ (D : directed_set X), (∏ (d : D), P (D d)) → P (⨆ D)). Let S : hSet := (∑ (x : X), hProp_to_hSet (P x))%set. Definition sub_dcpo_lub (D : directed_set (sub_PartialOrder X P)) : lub (sub_PartialOrder X P) D. Proof. pose (D' := directed_set_comp (pr1_sub_monotone X P) D). use make_lub. - refine (⨆ D' ,, HP D' _). abstract (intro d ; exact (pr2 (D d))). - split. + abstract (intro i ; cbn ; exact (less_than_dcpo_lub D' (pr1 (D i)) i (refl_dcpo _))). + abstract (intros x Hx ; use (dcpo_lub_is_least D') ; intro i ; apply (Hx i)). Defined. Definition sub_dcpo_struct : dcpo_struct S. Proof. use make_dcpo_struct. - exact (sub_PartialOrder X P). - intros I D HD. exact (sub_dcpo_lub (make_directed_set _ I D HD)). Defined. Definition sub_dcpo : dcpo := _ ,, sub_dcpo_struct. Proposition is_scott_continuous_pr1_sub : is_scott_continuous sub_dcpo X pr1. Proof. use make_is_scott_continuous. - exact (is_monotone_pr1_sub X P). - cbn. intro. apply idpath. Qed. (** 2. The first projection is continuous *) Definition pr1_sub_scott_continuous : scott_continuous_map sub_dcpo X := _ ,, is_scott_continuous_pr1_sub. End SubDCPO. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Sums.v000066400000000000000000000310671451125700300227350ustar00rootroot00000000000000(**************************************************************** Set indexed coproducts of DCPOs We construct set-indexed coproducts of DCPOs. For the idea behind the construction see the header of the file about binary sums. Contents 1. Directed sets in set-indexed coproducts 2. Set-indexed coproducts of DCPOs 3. Scott continuity of inclusion of set-indexed coproducts 4. The set-indexed sum of Scott continuous maps ****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Local Open Scope dcpo. Section CoproductOfDCPO. Context {X : hSet} (Y : X → dcpo). (** 1. Directed sets in set-indexed coproducts *) Section DirectedSet. Context (D : directed_set (coproduct_set_PartialOrder _ (λ x, Y x))). Definition directed_set_all_incl : ∃ (x : X), ∀ (i : D), ∃ (y : Y x), D i = (x ,, y). Proof. assert (h := directed_set_el D). revert h. use factor_through_squash. { apply propproperty. } intros i. refine (hinhpr (pr1 (D i) ,, λ j, _)). assert (t := directed_set_top D i j). revert t. use factor_through_squash. { apply propproperty. } intros k. induction k as [ t [ [ p₁ q₁ ] [ p₂ q₂ ] ]]. destruct (D i) as [ di di' ]. destruct (D j) as [ dj dj' ]. destruct (D t) as [ dt dt' ]. cbn in p₁, q₁, p₂, q₂. induction p₁, p₂. refine (hinhpr (dj' ,, _)). apply idpath. Qed. Section DirectedSetPoint. Context (x : X) (H : ∀ (i : D), ∃ (y : Y x), D i = (x ,, y)). Definition directed_set_point_map (i : D) : Y x. Proof. refine (transportf Y _ (pr2 (D i))). abstract (assert (h := H i) ; revert h ; use factor_through_squash ; [ apply setproperty | ] ; intro p ; exact (base_paths _ _ (pr2 p))). Defined. Proposition directed_set_point_map_eq (i : D) (y : Y x) (p : D i = x ,, y) : directed_set_point_map i = y. Proof. refine (_ @ fiber_paths p). unfold directed_set_point_map. apply maponpaths_2. apply setproperty. Qed. Proposition is_directed_directed_set_point : is_directed (Y x) directed_set_point_map. Proof. split. - exact (directed_set_el D). - intros i j. assert (w := directed_set_top D i j). revert w. use factor_through_squash. { apply propproperty. } intros t. induction t as [ t [ [ p₁ q₁ ] [ p₂ q₂ ] ]] ; cbn in p₁, p₂. assert (q := H t). revert q. use factor_through_squash. { apply propproperty. } intros [ y r ]. refine (hinhpr (t ,, _)). rewrite (directed_set_point_map_eq t _ r). induction (D t) as [ dt dt' ]. assert (s := total2_paths_equiv _ _ _ (!r)). clear r. induction s as [ s₁ s₂ ]. cbn in p₁, p₂, s₁, s₂. induction s₁ ; cbn in s₂. induction s₂. assert (D i = x ,, transportf (λ z, Y z) p₁ (pr2 (D i))) as ri. { use total2_paths_b. - exact p₁. - cbn. rewrite transportbfinv. apply idpath. } rewrite (directed_set_point_map_eq i _ ri). assert (D j = x ,, transportf (λ z, Y z) p₂ (pr2 (D j))) as rj. { use total2_paths_b. - exact p₂. - cbn. rewrite transportbfinv. apply idpath. } rewrite (directed_set_point_map_eq j _ rj). induction (D i) as [ di di' ]. induction (D j) as [ dj dj' ]. cbn in *. induction p₁, p₂ ; cbn in *. exact (q₁ ,, q₂). Qed. Definition directed_set_point : directed_set (Y x). Proof. use make_directed_set. - exact D. - exact directed_set_point_map. - exact is_directed_directed_set_point. Defined. Proposition is_lub_directed_set_point : is_least_upperbound (coproduct_set_PartialOrder _ (λ x, Y x)) D (x ,, ⨆ directed_set_point). Proof. split. - intros i. assert (p := H i). revert p. use factor_through_squash. { apply propproperty. } intro p. induction p as [ y p ]. rewrite p. refine (idpath _ ,, _) ; cbn. use (less_than_dcpo_lub directed_set_point _ i) ; cbn. rewrite (directed_set_point_map_eq _ _ p). apply refl_dcpo. - intros y Hy ; cbn. induction y as [ x' y' ]. cbn in *. assert (p : x = x'). { assert (el := directed_set_el D). revert el. use factor_through_squash. { apply setproperty. } intro i. assert (H' := H i). revert H'. use factor_through_squash. { apply setproperty. } intros H'. induction H' as [ z H' ]. pose (Hy i) as p. cbn in p. rewrite H' in p. exact (pr1 p). } induction p. refine (idpath _ ,, _) ; cbn. use dcpo_lub_is_least. intro i. pose (Hy i) as p. cbn in p. assert (H' := H i). revert H'. use factor_through_squash. { apply propproperty. } intros H'. induction H' as [ x' H' ]. rewrite H' in p. cbn in p ; cbn. rewrite (directed_set_point_map_eq i _ H'). induction p as [ p q ]. assert (r : idpath _ = p) by apply setproperty. induction r. exact q. Qed. End DirectedSetPoint. Definition directed_set_coproduct_set_with_eq : ∃ (x : X), ∑ (D' : D → Y x) (HD : is_directed (Y x) D'), let DX := make_directed_set _ D D' HD in is_least_upperbound (coproduct_set_PartialOrder _ (λ x, Y x)) D (x ,, ⨆ DX) × (∏ (i : D), D i = (x ,, D' i)). Proof. assert (h := directed_set_all_incl). revert h. use factor_through_squash. { apply propproperty. } intros xH. induction xH as [ x H ]. refine (hinhpr (x ,, _)). refine (directed_set_point_map x H ,, _). refine (is_directed_directed_set_point x H ,, _). split. - apply is_lub_directed_set_point. - intro i. assert (p := H i). revert p. use factor_through_squash. { apply setproperty. } intros yH. induction yH as [ y p ]. rewrite (directed_set_point_map_eq x H i y p). exact p. Defined. Definition directed_set_set_coproduct : ∃ (x : X), ∑ (D' : D → Y x) (HD : is_directed (Y x) D'), let DX := make_directed_set _ D D' HD in is_least_upperbound (coproduct_set_PartialOrder _ (λ x, Y x)) D (x ,, ⨆ DX). Proof. assert (h := directed_set_all_incl). revert h. use factor_through_squash. { apply propproperty. } intros xH. induction xH as [ x H ]. refine (hinhpr (x ,, _)). refine (directed_set_point_map x H ,, _). refine (is_directed_directed_set_point x H ,, _). apply is_lub_directed_set_point. Defined. End DirectedSet. (** 2. Set-indexed coproducts of DCPOs *) Definition coproduct_dcpo_incl_lub (x : X) (D : directed_set (Y x)) : lub (coproduct_set_PartialOrder _ (λ x, Y x)) (directed_set_comp (set_in_monotone_function Y Y x) D). Proof. use make_lub. - exact (x ,, ⨆ D). - split. + abstract (intro i ; refine (idpath _ ,, _) ; cbn in * ; apply (less_than_dcpo_lub _ _ i (refl_dcpo _))). + abstract (intros y Hy ; cbn in y, Hy ; induction y as [ x' y' ] ; cbn in * ; assert (p : x = x') ; [ assert (w := directed_set_el D) ; revert w ; use factor_through_squash ; [ apply setproperty | ] ; intro i ; exact (pr1 (Hy i)) | ] ; induction p ; refine (idpath _ ,, _) ; cbn ; use (dcpo_lub_is_least D y') ; intro i ; specialize (Hy i) ; induction Hy as [ p q ] ; assert (idpath _ = p) as r by apply setproperty ; induction r ; cbn in * ; exact q). Defined. Definition coproduct_set_dcpo_lub (D : directed_set (coproduct_set_PartialOrder _ (λ x, Y x))) : lub (coproduct_set_PartialOrder _ (λ x, Y x)) D. Proof. assert (D' := directed_set_set_coproduct D). revert D'. use factor_through_squash. { apply isaprop_lub. } intros D'. induction D' as [ x D' ]. induction D' as [ D' HD ]. induction HD as [ HD H ]. use make_lub. - exact (x ,, ⨆ (make_directed_set _ _ D' HD)). - exact H. Defined. Definition coproduct_set_dcpo_struct : dcpo_struct (∑ (x : X), Y x)%set. Proof. use make_dcpo_struct. - exact (coproduct_set_PartialOrder _ (λ x, Y x)). - intros I Df HDf. pose (D := make_directed_set _ I Df HDf). exact (coproduct_set_dcpo_lub D). Defined. Definition coproduct_set_dcpo : dcpo := _ ,, coproduct_set_dcpo_struct. (** 3. Scott continuity of inclusion of set-indexed coproducts *) Proposition is_scott_continuous_incl (x : X) : is_scott_continuous (Y x) coproduct_set_dcpo (λ y, x ,, y). Proof. use make_is_scott_continuous. - exact (λ y₁ y₂ p, is_monotone_set_in Y Y x y₁ y₂ p). - intro D ; cbn. use (eq_lub coproduct_set_dcpo (directed_set_comp (set_in_monotone_function Y Y x) D)). + exact (pr2 (coproduct_dcpo_incl_lub x D)). + exact (is_least_upperbound_dcpo_comp_lub _ D). Qed. Definition incl_scott_continuous_map (x : X) : scott_continuous_map (Y x) coproduct_set_dcpo := (λ y, x ,, y) ,, is_scott_continuous_incl x. (** 4. The set-indexed sum of Scott continuous maps *) Proposition is_scott_continuous_set_coproduct_map {Z : dcpo} {f : ∏ (x : X), Y x → Z} (Pf : ∏ (x : X), is_scott_continuous (Y x) Z (f x)) : is_scott_continuous coproduct_set_dcpo Z (λ xy, f (pr1 xy) (pr2 xy)). Proof. use make_is_scott_continuous. - exact (λ xy₁ xy₂ p, is_monotone_set_coproduct_map Y Y (λ x, pr1 (Pf x)) xy₁ xy₂ p). - intros D. assert (D' := directed_set_coproduct_set_with_eq D). revert D'. use factor_through_squash. { apply (pr1 Z). } intros D'. induction D' as [ x [ D' [ HD' H ]]]. pose (DX := make_directed_set _ _ D' HD'). assert (⨆ D = x ,, ⨆ DX) as q. { use (eq_lub coproduct_set_dcpo D _ (pr1 H)). apply is_least_upperbound_dcpo_lub. } rewrite q. cbn. refine (scott_continuous_map_on_lub (f x ,, Pf x) DX @ _). use antisymm_dcpo. + use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. * exact i. * cbn. rewrite (pr2 H i) ; cbn. apply refl_dcpo. + use dcpo_lub_is_least. intro i ; cbn. use less_than_dcpo_lub. * exact i. * cbn. rewrite (pr2 H i) ; cbn. apply refl_dcpo. Qed. Definition set_coproduct_scott_continuous_map {Z : dcpo} (f : ∏ (x : X), scott_continuous_map (Y x) Z) : scott_continuous_map coproduct_set_dcpo Z := (λ xy, f (pr1 xy) (pr2 xy)) ,, is_scott_continuous_set_coproduct_map (λ x, pr2 (f x)). End CoproductOfDCPO. UniMath-20231010/UniMath/OrderTheory/DCPOs/Examples/Unit.v000066400000000000000000000061121451125700300227160ustar00rootroot00000000000000(***************************************************************** The unit DCPO In this file we give the unit DCPO and we prove properties about it. Contents 1. Definition of the unit DCPO 2. The unit DCPO is pointed 3. The universal property 4. The way below relation 5. A basis for the unit DCPO *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Core.WayBelow. Require Import UniMath.OrderTheory.DCPOs.Basis.Basis. Require Import UniMath.OrderTheory.DCPOs.Basis.Continuous. Local Open Scope dcpo. (** 1. The unit DCPO *) Definition unit_dcpo_struct : dcpo_struct unitset. Proof. use make_dcpo_struct. - exact unit_PartialOrder. - intros I D HD. use make_lub. + exact tt. + split. * abstract (intro i ; cbn ; exact tt). * abstract (intros i Hi ; cbn ; exact tt). Defined. Definition unit_dcpo : dcpo := _ ,, unit_dcpo_struct. (** 2. The unit DCPO is pointed *) Definition unit_dcppo_struct : dcppo_struct unitset. Proof. refine (unit_dcpo_struct ,, _). refine (tt ,, _). abstract (intro x ; cbn ; exact tt). Defined. Definition unit_dcppo : dcppo := _ ,, unit_dcppo_struct. (** 3. The universal property *) Proposition is_scott_continuous_to_unit {X : hSet} (DX : dcpo_struct X) : is_scott_continuous DX unit_dcpo_struct (λ _, tt). Proof. split. - intros x y p. exact tt. - intros I D HD x Hx. split. + intro ; cbn. exact tt. + intros ? ? ; cbn. exact tt. Qed. (** 4. The way below relation *) Proposition unit_dcpo_way_below (x y : unit_dcpo) : x ≪ y. Proof. intros D HD. assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intro d. exact (hinhpr (d ,, tt)). Qed. (** 5. A basis for the unit DCPO *) Definition unit_dcpo_basis_data : dcpo_basis_data unit_dcpo. Proof. use make_dcpo_basis_data. - exact unit. - exact (λ _, tt). Defined. Proposition unit_dcpo_basis_laws : dcpo_basis_laws unit_dcpo unit_dcpo_basis_data. Proof. intro x. split. - split. + refine (hinhpr (tt ,, _)). apply unit_dcpo_way_below. + intros i j. refine (hinhpr ((tt ,, _) ,, (tt ,, tt))). apply unit_dcpo_way_below. - split. + intro ; exact tt. + intros ? ?. exact tt. Qed. Definition unit_dcpo_basis : dcpo_basis unit_dcpo. Proof. use make_dcpo_basis. - exact unit_dcpo_basis_data. - exact unit_dcpo_basis_laws. Defined. Definition dcpo_continuous_struct_unit : continuous_dcpo_struct unit_dcpo. Proof. use continuous_struct_from_basis. exact unit_dcpo_basis. Defined. UniMath-20231010/UniMath/OrderTheory/DCPOs/FixpointTheorems/000077500000000000000000000000001451125700300233415ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/DCPOs/FixpointTheorems/LeastFixpoint.v000066400000000000000000000170161451125700300263260ustar00rootroot00000000000000(***************************************************************** Fixpoints in DCPO In this file, we prove the classical fixpoint theorem for DCPOs that says that every Scott continuous map has a least fixpoint. We also show that we have a continuous function that assigns to every Scott continuous function the least fixpoint. The construction of this map is based on the proof of Theorem 1.2.17 of 'The Lambda Calculus, its Syntax and Semantics' by Barendregt. The idea is as follows: we already defined numerous combinators for Scott continuous maps (lambda, application), and we reuse those to reproduce the construction of the least fixpoint. The following steps are key: - [iterate_scott_continuous_map]: this function assigns to every `f` and `n` the map `f ∘ ... ∘ f` (`n` times). For this definition, we use the lambda combinator of Scott continuous maps. - [least_fixpoint_scott_continuous_map_on_N]: this function assigns to every `f` and `n` the point `f(...f(⊥_{X})...)`. We use the evaluation, pairing, and the function defined in the previous point for it. - [least_fixpoint_scott_continuous_map]: this function takes the least upperbound for every `n` of all the functions defined in the previous point. This is the same construction as used in the Knaster-Tarski fixpoint theorem, and we prove that in [least_fixpoint_scott_continuous_map_is_least_fixpoint]. Contents 1. The least fixpoint 2. Pointed DCPPO of fixpoints 3. Continuous map that assigns to a function its least fixpoint *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Core.ScottContinuous. Require Import UniMath.OrderTheory.DCPOs.Examples.Fixpoints. Require Import UniMath.OrderTheory.DCPOs.Examples.Exponentials. Require Import UniMath.OrderTheory.DCPOs.Examples.BinaryProducts. Local Open Scope dcpo. Section FixpointTheorem. Context {X : dcppo} (f : scott_continuous_map X X). (** 1. The least fixpoint *) Definition bot_iteration_map (n : ℕ) : X. Proof. induction n as [ | n IHn ]. - exact (⊥_{X}). - exact (f IHn). Defined. Lemma is_monotone_bot_iteration_map_S (n : ℕ) : bot_iteration_map n ⊑ f (bot_iteration_map n). Proof. induction n as [ | n IHn ]. - apply is_min_bottom_dcppo. - exact (is_monotone_scott_continuous_map f IHn). Qed. Definition bot_iteration_directed_set : directed_set X. Proof. use nat_directed_set. - exact bot_iteration_map. - apply is_monotone_bot_iteration_map_S. Defined. Definition least_fixpoint : X := ⨆ bot_iteration_directed_set. Proposition is_fixpoint_least_fixpoint : f least_fixpoint = least_fixpoint. Proof. unfold least_fixpoint. rewrite scott_continuous_map_on_lub. use antisymm_dcpo. - use dcpo_lub_is_least. cbn ; intro i. use less_than_dcpo_lub. + exact (S i). + apply refl_dcpo. - use dcpo_lub_is_least. cbn ; intro i. use less_than_dcpo_lub. + exact i. + apply is_monotone_bot_iteration_map_S. Qed. Theorem is_least_fixpoint_least_fixpoint (x : X) (p : f x = x) : least_fixpoint ⊑ x. Proof. use dcpo_lub_is_least ; cbn. intro n. induction n as [ | n IHn ]. - apply is_min_bottom_dcppo. - rewrite <- p. exact (is_monotone_scott_continuous_map f IHn). Qed. Definition bottom_element_fixpoint_dcpo : bottom_element (fixpoint_dcpo f). Proof. simple refine ((least_fixpoint ,, _) ,, _). - apply is_fixpoint_least_fixpoint. - exact (λ x, is_least_fixpoint_least_fixpoint _ (pr2 x)). Defined. (** 2. Pointed DCPPO of fixpoints *) Definition fixpoint_dcppo : dcppo := _ ,, pr2 (fixpoint_dcpo f) ,, bottom_element_fixpoint_dcpo. End FixpointTheorem. (** 3. Continuous map that assigns to a function its least fixpoint *) Definition iterate_on_pt_scott_continuous_map {X : dcpo} (n : ℕ) : scott_continuous_map (X × dcpo_funspace X X) X. Proof. induction n as [ | n IHn ]. - exact π₁. - exact (comp_scott_continuous_map ⟨ eval_scott_continuous_map X X , π₂ ⟩ IHn). Defined. Proposition iterate_on_pt_scott_continuous_map_fun_pt {X : dcpo} (n : ℕ) (f : scott_continuous_map X X) (x : X) : iterate_on_pt_scott_continuous_map n (f x ,, f) = f (iterate_on_pt_scott_continuous_map n (x ,, f)). Proof. revert x. induction n as [ | n IHn ]. - intro ; cbn. apply idpath. - intro x. simpl ; unfold prodtofuntoprod ; simpl. apply IHn. Qed. Definition iterate_scott_continuous_map {X : dcppo} (n : ℕ) : scott_continuous_map (dcpo_funspace X X) (dcpo_funspace X X) := lam_scott_continuous_map (iterate_on_pt_scott_continuous_map n). Definition iterate_scott_continuous_map_S {X : dcppo} (n : ℕ) (f : scott_continuous_map X X) (x : X) : pr1 (iterate_scott_continuous_map (S n) f) x = f (pr1 (iterate_scott_continuous_map n f) x). Proof. simpl ; unfold prodtofuntoprod ; simpl. exact (iterate_on_pt_scott_continuous_map_fun_pt n f x). Qed. Definition least_fixpoint_scott_continuous_map_on_N {X : dcppo} (n : ℕ) : dcpo_funspace (dcpo_funspace X X) X := comp_scott_continuous_map ⟨ constant_scott_continuous_map _ ⊥_{X} , iterate_scott_continuous_map n ⟩ (eval_scott_continuous_map _ _). Definition least_fixpoint_scott_continuous_map_directed_set (X : dcppo) : directed_set (dcpo_funspace (dcpo_funspace X X) X). Proof. use nat_directed_set. - exact least_fixpoint_scott_continuous_map_on_N. - abstract (intros i f ; simpl ; unfold prodtofuntoprod ; simpl ; use is_monotone_scott_continuous_map ; split ; [ apply is_min_bottom_dcppo | ] ; intro ; apply refl_dcpo). Defined. Definition least_fixpoint_scott_continuous_map (X : dcppo) : dcpo_funspace (dcpo_funspace X X) X := ⨆ least_fixpoint_scott_continuous_map_directed_set X. Proposition least_fixpoint_scott_continuous_map_is_least_fixpoint_on_N {X : dcppo} (f : scott_continuous_map X X) (n : ℕ) : pr1 (least_fixpoint_scott_continuous_map_on_N n) f = bot_iteration_directed_set f n. Proof. induction n as [ | n IHn ]. - apply idpath. - refine (_ @ maponpaths _ IHn). simpl ; unfold prodtofuntoprod ; simpl. apply (iterate_on_pt_scott_continuous_map_fun_pt n f). Qed. Proposition least_fixpoint_scott_continuous_map_is_least_fixpoint {X : dcppo} (f : scott_continuous_map X X) : pr1 (least_fixpoint_scott_continuous_map X) f = least_fixpoint f. Proof. use antisymm_dcpo. - use dcpo_lub_is_least. intro i ; cbn in i. use less_than_dcpo_lub. + exact i. + rewrite <- least_fixpoint_scott_continuous_map_is_least_fixpoint_on_N. apply refl_dcpo. - use dcpo_lub_is_least. intro i ; cbn in i. use less_than_dcpo_lub. + exact i. + rewrite <- least_fixpoint_scott_continuous_map_is_least_fixpoint_on_N. apply refl_dcpo. Qed. UniMath-20231010/UniMath/OrderTheory/DCPOs/FixpointTheorems/Pataraia.v000066400000000000000000000166301451125700300252600ustar00rootroot00000000000000(****************************************************************** Pataraia's fixpoint theorem In this file, we formalize Pataraia's fixpoint theorem for DCPOs. This theorem says that monotone function on a DCPO has a fixpoint. There are two fundamental notions required for this proof. The first one is the notion of progressive maps. A map `f` is called progressive if for all `x` we have `x ⊑ f x`. The second one is the notion of post fixpoints. A post fixpoint for a map `f` is a point `x` such that `x ⊑ f x`. The key observation of the proof is that every DCPO has a largest progressive map [largest_progressive_map]. This is so because the progressive maps form a directed set and thus one can take the least upperbound. One can then look at the largest progressive map on the DCPO of post fixpoints for a function `f` ([post_fixpoint_dcpo]). By applying this map to the bottom element, one acquires the desired fixpoint. References: - Theorem 3.2 in On the Bourbaki–Witt principle in toposes https://arxiv.org/abs/1201.0340 Contents 1. Progressive maps 2. Examples of progressive maps 3. Every DCPO has a largest progressive map 4. The DCPO of post fixpoints 5. Pataraia's fixpoint theorem ******************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.DCPOs.Core.DirectedSets. Require Import UniMath.OrderTheory.DCPOs.Core.Basics. Require Import UniMath.OrderTheory.DCPOs.Examples.Products. Require Import UniMath.OrderTheory.DCPOs.Examples.SubDCPO. Local Open Scope dcpo. (** 1. Progressive maps *) Definition is_progressive {X : dcpo} (f : monotone_function X X) : hProp := ∀ (x : X), x ⊑ f x. Definition progressive_map (X : dcpo) : UU := ∑ (f : monotone_function X X), is_progressive f. Coercion monotone_function_of_progressive_map {X : dcpo} (f : progressive_map X) : monotone_function X X := pr1 f. Proposition progressive_map_is_progressive {X : dcpo} (f : progressive_map X) : is_progressive f. Proof. exact (pr2 f). Qed. Definition make_progressive_map {X : dcpo} (f : monotone_function X X) (Hf : is_progressive f) : progressive_map X := f ,, Hf. (** 2. Examples of progressive maps *) Proposition is_progressive_id (X : dcpo) : is_progressive (id_monotone_function X). Proof. intro. apply refl_dcpo. Qed. Definition id_progressive_map (X : dcpo) : progressive_map X. Proof. use make_progressive_map. - exact (id_monotone_function X). - apply is_progressive_id. Defined. Proposition is_progressive_comp {X : dcpo} {f g : monotone_function X X} (Hf : is_progressive f) (Hg : is_progressive g) : is_progressive (comp_monotone_function f g). Proof. intros x ; cbn. exact (trans_dcpo (Hf x) (Hg (f x))). Qed. Definition comp_progressive_map {X : dcpo} (f g : progressive_map X) : progressive_map X. Proof. use make_progressive_map. - exact (comp_monotone_function f g). - exact (is_progressive_comp (pr2 f) (pr2 g)). Defined. Proposition is_progressive_lub {X : dcpo} (D : directed_set (monotone_map_dcpo X X)) (HD : ∏ (d : D), is_progressive (D d)) : is_progressive (⨆ D). Proof. intros x. assert (H := directed_set_el D). revert H. use factor_through_squash. { apply propproperty. } intro d. use less_than_dcpo_lub. - exact d. - exact (HD d x). Qed. Proposition is_directed_progressive_maps (X : dcpo) : is_directed (monotone_map_dcpo X X) (λ (f : progressive_map X), pr1 f). Proof. split. - apply hinhpr. apply id_progressive_map. - intros f g. apply hinhpr. refine (comp_progressive_map f g ,, _ ,, _). + intro x ; cbn. exact (progressive_map_is_progressive g (f x)). + intro x ; cbn. apply (pr1 g). apply (progressive_map_is_progressive f x). Qed. (** 3. Every DCPO has a largest progressive map *) Definition directed_set_progressive_maps (X : dcpo) : directed_set (monotone_map_dcpo X X). Proof. use make_directed_set. - exact (progressive_map X). - exact (λ f, pr1 f). - exact (is_directed_progressive_maps X). Defined. Definition largest_progressive_map_monotone (X : dcpo) : monotone_map_dcpo X X := ⨆ directed_set_progressive_maps X. Definition largest_progressive_map (X : dcpo) : progressive_map X. Proof. use make_progressive_map. - exact (largest_progressive_map_monotone X). - abstract (apply is_progressive_lub ; intro d ; apply progressive_map_is_progressive). Defined. Proposition le_largest_progressive_map {X : dcpo} (f : progressive_map X) (x : X) : f x ⊑ largest_progressive_map X x. Proof. exact (less_than_dcpo_lub (directed_set_progressive_maps X) (pr1 f) f (refl_dcpo _) x). Qed. (** 4. The DCPO of post fixpoints *) Proposition lub_post_fixpoint {X : dcpo} (f : monotone_function X X) (D : directed_set X) (HD : ∏ (d : D), D d ⊑ f (D d)) : ⨆ D ⊑ f (⨆ D). Proof. use dcpo_lub_is_least. intro d. refine (trans_dcpo (HD d) _). apply f. use less_than_dcpo_lub. - exact d. - apply refl_dcpo. Qed. Definition post_fixpoint_dcpo {X : dcpo} (f : monotone_function X X) : dcpo := sub_dcpo X (λ x, x ⊑ f x) (lub_post_fixpoint f). Definition restriction_to_post_fixpoint {X : dcpo} (f : monotone_function X X) : progressive_map (post_fixpoint_dcpo f). Proof. use make_progressive_map. - simple refine (_ ,, _). + refine (λ x, f (pr1 x) ,, _). abstract (cbn ; apply f ; apply (pr2 x)). + abstract (intros x₁ x₂ p ; cbn ; apply f ; exact p). - abstract (exact (λ x, pr2 x)). Defined. Definition bot_post_fixpoint {X : dcppo} (f : monotone_function X X) : post_fixpoint_dcpo f := ⊥_{X} ,, is_min_bottom_dcppo _. (** 5. Pataraia's fixpoint theorem *) Section PataraiaFixpoint. Context {X : dcppo} (f : monotone_function X X). Let m : progressive_map (post_fixpoint_dcpo f) := largest_progressive_map (post_fixpoint_dcpo f). Proposition pataraia_fixpoint_compose_lemma (g : progressive_map (post_fixpoint_dcpo f)) (x : post_fixpoint_dcpo f) : g(m x) = m x. Proof. use antisymm_dcpo. - pose (le_largest_progressive_map (comp_progressive_map m g) x) as p. refine (trans_dcpo _ p). cbn -[largest_progressive_map]. apply refl_dcpo. - exact (progressive_map_is_progressive g (m x)). Qed. Definition pataraia_fixpoint : X := pr1 (m (bot_post_fixpoint f)). Proposition is_fixpoint_pataraia_fixpoint : f pataraia_fixpoint = pataraia_fixpoint. Proof. unfold pataraia_fixpoint. pose (p := maponpaths pr1 (pataraia_fixpoint_compose_lemma (restriction_to_post_fixpoint f) (bot_post_fixpoint f))). refine (p @ _). apply idpath. Qed. End PataraiaFixpoint. UniMath-20231010/UniMath/OrderTheory/Lattice/000077500000000000000000000000001451125700300205075ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/Lattice/Boolean.v000066400000000000000000000050221451125700300222540ustar00rootroot00000000000000(** * Boolean algebras *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Algebra.Monoids. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.OrderTheory.Lattice.Complement. Require Import UniMath.OrderTheory.Lattice.Distributive. Require Import UniMath.OrderTheory.Lattice.Heyting. Section Def. Context {X : hSet} (L : bounded_lattice X). (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas "+", "×" conflict with notation for types. *) Local Notation "x ≤ y" := (Lle L x y). Local Notation "x ⊗ y" := (Lmin L x y). Local Notation "x ⊕ y" := (Lmax L x y). Local Notation "⊤" := (Ltop L). Local Notation "⊥" := (Lbot L). (** While complements are in general not unique, we regain uniqueness in the case of Boolean algebras. Therefore, Boolean algebra structure is a proposition. *) Definition is_boolean : hProp. Proof. use make_hProp. - refine (∑ is_distr : is_distributive L, _). use make_hProp. + exact (complemented_structure L). + apply impred; intro. apply distributive_lattice_complements_are_unique; auto. - abstract (apply isaprop_total2). Defined. End Def. Definition make_is_boolean {X : hSet} (L : bounded_lattice X) : is_distributive L -> complemented_structure L -> is_boolean L. Proof. intros ? ?. use tpair. - assumption. - assumption. Defined. Definition boolean_algebra (X : hSet) := ∑ L : bounded_lattice X, is_boolean L. Section Accessors. Context {X : hSet} (B : boolean_algebra X). Definition boolean_algebra_lattice : bounded_lattice X := pr1 B. Definition boolean_algebra_is_boolean : is_boolean boolean_algebra_lattice := pr2 B. Definition boolean_algebra_complement : complemented_structure boolean_algebra_lattice := pr2 (pr2 B). End Accessors. Coercion boolean_algebra_lattice : boolean_algebra >-> bounded_lattice. (** Every Boolean algebra has eponentials (is a Heyting algebra). *) Section Heyting. Context {X : hSet} (L : boolean_algebra X). (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas "+", "×" conflict with notation for types. *) Local Notation "x ⊕ y" := (Lmax L x y). Local Notation "¬ x" := (boolean_algebra_complement L x). Lemma boolean_algebra_exponential : exponential L. Proof. use make_exponential. - intros x y; exact ((¬ x) ⊕ y). - intros x y z; use make_dirprod; cbn; intros H. Abort. End Heyting. UniMath-20231010/UniMath/OrderTheory/Lattice/Bounded.v000066400000000000000000000032621451125700300222610ustar00rootroot00000000000000(** * Bounded lattices *) Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.OrderTheory.Lattice.Lattice. Definition bounded_latticeop {X : hSet} (l : lattice X) (bot top : X) := (islunit (Lmax l) bot) × (islunit (Lmin l) top). Definition bounded_lattice (X : hSet) := ∑ (l : lattice X) (bot top : X), bounded_latticeop l bot top. Definition make_bounded_lattice {X : hSet} {l : lattice X} {bot top : X} : bounded_latticeop l bot top → bounded_lattice X := λ bl, l,, bot,, top,, bl. Definition bounded_lattice_to_lattice X : bounded_lattice X → lattice X := pr1. Coercion bounded_lattice_to_lattice : bounded_lattice >-> lattice. Definition Lbot {X : hSet} (is : bounded_lattice X) : X := pr1 (pr2 is). Definition Ltop {X : hSet} (is : bounded_lattice X) : X := pr1 (pr2 (pr2 is)). Section bounded_lattice_pty. Context {X : hSet} (l : bounded_lattice X). Definition islunit_Lmax_Lbot : islunit (Lmax l) (Lbot l) := pr1 (pr2 (pr2 (pr2 l))). Definition islunit_Lmin_Ltop : islunit (Lmin l) (Ltop l) := pr2 (pr2 (pr2 (pr2 l))). Lemma Lmin_Lbot (x : X) : Lmin l (Lbot l) x = Lbot l. Proof. now rewrite <- (islunit_Lmax_Lbot x), Lmin_absorb. Qed. Lemma Lmax_Ltop (x : X) : Lmax l (Ltop l) x = Ltop l. Proof. now rewrite <- (islunit_Lmin_Ltop x), Lmax_absorb. Qed. End bounded_lattice_pty. Definition hProp_bounded_lattice : bounded_lattice (hProp,,isasethProp). Proof. use make_bounded_lattice. - exact hProp_lattice. - exact hfalse. - exact htrue. - split. + intros P; apply hfalse_hdisj. + intros P; apply htrue_hconj. Defined. UniMath-20231010/UniMath/OrderTheory/Lattice/Complement.v000066400000000000000000000022631451125700300230040ustar00rootroot00000000000000(** * Complements *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.Sets. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Section Def. Context {X : hSet} (L : bounded_lattice X). (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas "+", "×" conflict with notation for types. *) Local Notation "x ≤ y" := (Lle L x y). Local Notation "x ⊗ y" := (Lmin L x y). Local Notation "x ⊕ y" := (Lmax L x y). Local Notation "⊤" := (Ltop L). Local Notation "⊥" := (Lbot L). Definition complement (x : X) : UU := ∑ y : X, (x ⊕ y = ⊤) × (x ⊗ y = ⊥). Definition complement_to_element {x : X} (y : complement x) : X := pr1 y. Coercion complement_to_element : complement >-> pr1hSet. Definition complement_top_axiom (x : X) (y : complement x) : x ⊕ y = ⊤ := dirprod_pr1 (pr2 y). Definition complement_bottom_axiom (x : X) (y : complement x) : x ⊗ y = ⊥ := dirprod_pr2 (pr2 y). (** This is _not_ a proposition: complements need not be unique. *) Definition complemented_structure : UU := ∏ x : X, complement x. End Def. UniMath-20231010/UniMath/OrderTheory/Lattice/Distributive.v000066400000000000000000000043011451125700300233510ustar00rootroot00000000000000(** * Distributive lattices *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Algebra.Monoids. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.OrderTheory.Lattice.Complement. Section Def. Context {X : hSet} (L : lattice X). (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas "+", "×" conflict with notation for types. *) Local Notation "x ≤ y" := (Lle L x y). Local Notation "x ⊗ y" := (Lmin L x y). Local Notation "x ⊕ y" := (Lmax L x y). Definition is_distributive : hProp. Proof. use make_hProp. - exact (∏ x y z : X, x ⊗ (y ⊕ z) = ((x ⊗ y) ⊕ (x ⊗ z))). - do 3 (apply impred; intro); apply setproperty. Defined. End Def. Definition distributive_lattice : UU := ∑ (X : hSet) (L : lattice X), is_distributive L. Section Bounded. Context {X : hSet} (L : bounded_lattice X). (** The normal "∧", "∨" notation conflicts with that for [hProp], whereas "+", "×" conflict with notation for types. *) Local Notation "x ≤ y" := (Lle L x y). Local Notation "x ⊗ y" := (Lmin L x y). Local Notation "x ⊕ y" := (Lmax L x y). Lemma distributive_lattice_complements_are_unique : is_distributive L -> ∏ x, isaprop (complement L x). Proof. intros is_distr x; apply invproofirrelevance; intros b a. apply subtypePath. - intro. apply isapropdirprod; apply setproperty. - refine (!islunit_Lmin_Ltop L (pr1 b) @ _ @ islunit_Lmin_Ltop L (pr1 a)). refine (_ @ maponpaths (fun z => Lmin L z _) (complement_top_axiom _ _ b)). refine (iscomm_Lmin _ _ _ @ _ @ iscomm_Lmin _ _ _). refine (!maponpaths (fun z => Lmin L _ z) (complement_top_axiom _ _ a) @ _). refine (is_distr _ _ _ @ _ @ !is_distr _ _ _). refine (iscomm_Lmax _ _ _ @ _ @iscomm_Lmax _ _ _ ). refine (maponpaths _ (iscomm_Lmin _ _ _) @ _ @ maponpaths _ (iscomm_Lmin _ _ _)). refine (maponpaths _ (complement_bottom_axiom _ _ b) @ _). refine (_ @ !maponpaths _ (complement_bottom_axiom _ _ a)). refine (_ @ maponpaths (fun z => Lmax L z _) (iscomm_Lmin _ _ _)). reflexivity. Qed. End Bounded. UniMath-20231010/UniMath/OrderTheory/Lattice/Examples/000077500000000000000000000000001451125700300222655ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/Lattice/Examples/Bool.v000066400000000000000000000036721451125700300233570ustar00rootroot00000000000000(** * Lattice structure on [boolset] *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Bool. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.OrderTheory.Lattice.Distributive. Require Import UniMath.OrderTheory.Lattice.Complement. Require Import UniMath.OrderTheory.Lattice.Boolean. Lemma boolset_lattice : lattice boolset. Proof. use make_lattice. - exact andb. (** [Lmin] *) - exact orb. (** [Lmax] *) - (** TODO: constructor for this *) apply make_dirprod; [apply make_dirprod|apply make_dirprod; [apply make_dirprod|apply make_dirprod]]. + intros ? ? ?; apply andb_is_associative. + intros ? ?; apply andb_is_commutative. + intros ? ? ?; apply orb_is_associative. + intros ? ?; apply orb_is_commutative. + intros b1 b2; abstract (induction b1, b2; reflexivity). + intros b1 b2; abstract (induction b1, b2; reflexivity). Defined. Lemma boolset_lattice_is_bounded : bounded_latticeop boolset_lattice false true. Proof. use make_dirprod; compute; reflexivity. Qed. Lemma boolset_lattice_is_complemented : complemented_structure (make_bounded_lattice boolset_lattice_is_bounded). Proof. intros b. exists (negb b). use make_dirprod. - abstract (induction b; reflexivity). - abstract (induction b; reflexivity). Qed. Definition boolset_bounded_lattice : bounded_lattice boolset. Proof. use make_bounded_lattice. - exact boolset_lattice. - exact false. - exact true. - exact boolset_lattice_is_bounded. Defined. Lemma boolset_lattice_is_distributive : is_distributive boolset_lattice. Proof. intros b1 b2 b3; induction b1, b2, b3; reflexivity. Qed. Definition subset_lattice_is_boolean : is_boolean boolset_bounded_lattice. Proof. use make_is_boolean. - apply boolset_lattice_is_distributive. - apply boolset_lattice_is_complemented. Qed. UniMath-20231010/UniMath/OrderTheory/Lattice/Examples/Subsets.v000066400000000000000000000152211451125700300241050ustar00rootroot00000000000000(** * Lattice of subsets *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Sets. Require Export UniMath.MoreFoundations.Propositions. Require Export UniMath.MoreFoundations.Subtypes. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Require Import UniMath.OrderTheory.Lattice.Distributive. Require Import UniMath.OrderTheory.Lattice.Complement. Require Import UniMath.OrderTheory.Lattice.Boolean. Section Subsets. Context {X : hSet}. Definition intersection_binop : binop (subtype_set X). Proof. apply infinitary_op_to_binop; exact (@subtype_intersection X). Defined. Lemma isassoc_intersection_binop : isassoc intersection_binop. Proof. intros W Y Z. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod; cbn; intros z f b; induction b; cbn in *. + (** [z ∈ W] *) exact (f true true). + intro b; induction b; cbn in *. * (** [z ∈ Y] *) exact (f true false). * (** [z ∈ Z] *) exact (f false). + intro b; induction b; cbn in *. * exact (f true). * exact (f false true). + exact (f false false). Qed. Lemma iscomm_intersection_binop : iscomm intersection_binop. Proof. intros ? ?; unfold intersection_binop, infinitary_op_to_binop; cbn. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod; intro; cbn; intros f b; induction b. - exact (f false). - exact (f true). - exact (f false). - exact (f true). Qed. Definition union_binop : binop (subtype_set X). Proof. apply infinitary_op_to_binop; exact (@subtype_union X). Defined. Local Lemma squash_to_prop_ishinh {Y Q : UU} : ∥ Y ∥ → (Y → ∥ Q ∥) → ∥ Q ∥. Proof. intros z ?. apply (squash_to_prop z); [apply isapropishinh|]. assumption. Qed. Lemma isassoc_union_binop : isassoc union_binop. Proof. intros ? ? ?. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod; cbn; intros ? ain; apply (squash_to_prop_ishinh ain); clear ain; intro ain; induction ain as [b bin]. - induction b; cbn in bin. + apply (squash_to_prop_ishinh bin); clear bin; intro bin. induction bin as [c cin]. induction c. * apply hinhpr; exists true; assumption. * apply hinhpr; exists false; cbn in *. apply hinhpr; exists true; assumption. + do 2 (apply hinhpr; exists false); assumption. - induction b; cbn in bin. + do 2 (apply hinhpr; exists true); assumption. + apply (squash_to_prop_ishinh bin); clear bin; intro bin. induction bin as [c cin]. induction c. * apply hinhpr; exists true; cbn in *. apply hinhpr; exists false; assumption. * apply hinhpr; exists false; assumption. Qed. Lemma iscomm_union_binop : iscomm union_binop. intros ? ?; unfold union_binop, infinitary_op_to_binop; cbn. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod; intro; cbn; intros ain; apply (squash_to_prop_ishinh ain); clear ain; intro ain; induction ain as [b bin]; induction b; cbn in *; apply hinhpr. - exists false; assumption. - exists true; assumption. - exists false; assumption. - exists true; assumption. Qed. Lemma subset_lattice : lattice (subtype_set X). Proof. use make_lattice. - exact intersection_binop. (** [Lmin] *) - exact union_binop. (** [Lmax] *) - (** TODO: constructor for this *) apply make_dirprod; [apply make_dirprod|apply make_dirprod; [apply make_dirprod|apply make_dirprod]]. + apply isassoc_intersection_binop. + apply iscomm_intersection_binop. + apply isassoc_union_binop. + apply iscomm_union_binop. + intros ? ?. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod. * intros ? f; exact (f true). * intros ? ?. intros b; induction b; cbn. -- assumption. -- apply hinhpr; exists true; assumption. + intros ? ?. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond. use make_dirprod. * intros ? f; cbn in f. refine (hinhuniv _ f); clear f; intro f. induction f as [b bin]; induction b; cbn in bin. -- assumption. -- apply (bin true). * intros ? ?; apply hinhpr; exists true; assumption. Defined. Lemma subset_lattice_is_bounded : bounded_latticeop subset_lattice (emptysubtype X) (totalsubtype X). Proof. (** TODO: constructor *) use make_dirprod. - intros x; cbn. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond; use make_dirprod. + intros ? in_union. refine (hinhuniv _ in_union); clear in_union; intro in_union. induction in_union as [b bin]; induction b; cbn in bin. * induction bin. (* can't be in the empty subset *) * assumption. + intros ? ?; apply hinhpr; exists false; assumption. - intros x; cbn. apply (invweq (hsubtype_univalence _ _)), subtype_equal_cond; use make_dirprod. + intros ? in_intersection; exact (in_intersection false). + intros ? ? b; induction b; cbn. * exact tt. (* always in total subtype *) * assumption. Qed. (** Using [LEM], we can show the lattice is complemented *) Lemma subset_lattice_is_complemented : LEM -> complemented_structure (make_bounded_lattice subset_lattice_is_bounded). Proof. intros lem sub. exists (subtype_complement sub). use make_dirprod. - apply (invweq (hsubtype_univalence _ _)). eapply (subtype_complement_union lem). + exists true; reflexivity. + exists false; reflexivity. - (** We don't need [LEM] for this branch. *) apply (invweq (hsubtype_univalence _ _)). eapply subtype_complement_intersection_empty. + exists true; reflexivity. + exists false; reflexivity. Defined. Definition subset_bounded_lattice : bounded_lattice (subtype_set X). Proof. use make_bounded_lattice. - exact subset_lattice. - exact (emptysubtype X). - exact (totalsubtype X). - exact subset_lattice_is_bounded. Defined. Lemma subset_lattice_is_distributive : is_distributive subset_lattice. Proof. Abort. Definition subset_lattice_is_boolean : LEM -> is_boolean subset_bounded_lattice. Proof. intros lem. use make_is_boolean. 2: apply (subset_lattice_is_complemented lem). Abort. End Subsets. UniMath-20231010/UniMath/OrderTheory/Lattice/Heyting.v000066400000000000000000000020431451125700300223040ustar00rootroot00000000000000(** * Heyting algebras *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.Algebra.Monoids. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.OrderTheory.Lattice.Bounded. Section Def. Context {X : hSet} (L : lattice X). Local Notation "x ≤ y" := (Lle L x y). Local Notation "x ∧ y" := (Lmin L x y). (** An exponential is a binary operation on [X] satisfying this law *) Definition exponential : UU := ∑ exponential_map : X -> X -> X, ∏ x y z : X, z ≤ (exponential_map x y) <-> (z ∧ x) ≤ y. Definition make_exponential (exponential_map : X -> X -> X) (prop : ∏ x y z : X, z ≤ (exponential_map x y) <-> (z ∧ x) ≤ y) : exponential := tpair _ exponential_map prop. Definition exponential_map (exp : exponential) : X -> X -> X := pr1 exp. Coercion exponential_map : exponential >-> Funclass. Definition exponential_is_exponential (exp : exponential) : ∏ x y z : X, z ≤ (exponential_map exp x y) <-> (z ∧ x) ≤ y := pr2 exp. End Def. UniMath-20231010/UniMath/OrderTheory/Lattice/Lattice.v000066400000000000000000001351351451125700300222730ustar00rootroot00000000000000(** * Lattice *) (** Catherine Lelay. Nov. 2016 - *) (** Definition of a lattice: (Burris, S., & Sankappanavar, H. P. (2006). A Course in Universal Algebra-With 36 Illustrations. Chapter I) A lattice is a set with two binary operators min and max such that: - min and max are associative - min and max are commutative - ∏ x y : X, min x (max x y) = x - ∏ x y : X, max x (min x y) = x In a lattice, we can define a partial order: - le := λ (x y : X), min lat x y = x Lattice with a strong order: A lattice equipped with a strong order gt such that additionally: - ∏ (x y : X), (¬ gt x y) <-> le x y - ∏ x y z : X, gt x z → gt y z → gt (min x y) z - ∏ x y z : X, gt z x → gt z y → gt z (max lat x y) Lattice with a total and decidable order: - le is total and decidable - it is a lattice with a strong order *) (** Lattice in an abelian monoid: - compatibility and cancelation of addition for le Truncated minus is a lattice: - a function minus such that: ∏ (x y : X), (minus x y) + y = max x y *) (** Define new lattices using: - weq - abmonoidfrac *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. (** ** Definition *) Definition islatticeop {X : hSet} (min max : binop X) : UU := ((isassoc min) × (iscomm min)) × ((isassoc max) × (iscomm max)) × (isabsorb min max) × (isabsorb max min). Lemma isaprop_islatticeop {X : hSet} (min max : binop X) : isaprop (islatticeop min max). Proof. apply isapropdirprod ; [ | apply isapropdirprod] ; apply isapropdirprod. apply isapropisassoc. apply isapropiscomm. apply isapropisassoc. apply isapropiscomm. apply isapropisabsorb. apply isapropisabsorb. Qed. Definition lattice (X : hSet) := ∑ min max : binop X, islatticeop min max. Definition make_lattice {X : hSet} {min max : binop X} : islatticeop min max → lattice X := λ (is : islatticeop min max), min,, max ,, is. Definition Lmin {X : hSet} (lat : lattice X) : binop X := pr1 lat. Definition Lmax {X : hSet} (lat : lattice X) : binop X := pr1 (pr2 lat). Section lattice_pty. Context {X : hSet} (lat : lattice X). Definition isassoc_Lmin : isassoc (Lmin lat) := pr1 (pr1 (pr2 (pr2 lat))). Definition iscomm_Lmin : iscomm (Lmin lat) := pr2 (pr1 (pr2 (pr2 lat))). Definition isassoc_Lmax : isassoc (Lmax lat) := pr1 (pr1 (pr2 (pr2 (pr2 lat)))). Definition iscomm_Lmax : iscomm (Lmax lat) := pr2 (pr1 (pr2 (pr2 (pr2 lat)))). Definition Lmin_absorb : isabsorb (Lmin lat) (Lmax lat) := pr1 (pr2 (pr2 (pr2 (pr2 lat)))). Definition Lmax_absorb : isabsorb (Lmax lat) (Lmin lat) := pr2 (pr2 (pr2 (pr2 (pr2 lat)))). Lemma Lmin_id : ∏ x : X, Lmin lat x x = x. Proof. intros x. intermediate_path (Lmin lat x (Lmax lat x (Lmin lat x x))). - apply maponpaths, pathsinv0, Lmax_absorb. - apply Lmin_absorb. Qed. Lemma Lmax_id : ∏ x : X, Lmax lat x x = x. Proof. intros x. intermediate_path (Lmax lat x (Lmin lat x (Lmax lat x x))). - apply maponpaths, pathsinv0, Lmin_absorb. - apply Lmax_absorb. Qed. End lattice_pty. (** ** Partial order in a lattice *) (** [Lle] *) Definition Lle {X : hSet} (lat : lattice X) : hrel X := λ (x y : X), (Lmin lat x y = x)%logic. Section lattice_le. Context {X : hSet} (lat : lattice X). Definition isrefl_Lle : isrefl (Lle lat) := Lmin_id lat. Lemma isantisymm_Lle : isantisymm (Lle lat). Proof. intros x y Hxy Hyx. apply pathscomp0 with (1 := pathsinv0 Hxy). apply pathscomp0 with (2 := Hyx). apply iscomm_Lmin. Qed. Lemma istrans_Lle : istrans (Lle lat). Proof. intros x y z <- <-. simpl. rewrite !isassoc_Lmin, Lmin_id. reflexivity. Qed. Lemma isPartialOrder_Lle : isPartialOrder (Lle lat). Proof. split ; [ split | ]. - exact istrans_Lle. - exact isrefl_Lle. - exact isantisymm_Lle. Qed. Lemma Lmin_le_l : ∏ x y : X, Lle lat (Lmin lat x y) x. Proof. intros x y. simpl. rewrite iscomm_Lmin, <- isassoc_Lmin, Lmin_id. reflexivity. Qed. Lemma Lmin_le_r : ∏ x y : X, Lle lat (Lmin lat x y) y. Proof. intros x y. rewrite iscomm_Lmin. apply Lmin_le_l. Qed. Lemma Lmin_le_case : ∏ x y z : X, Lle lat z x → Lle lat z y → Lle lat z (Lmin lat x y). Proof. intros x y z <- <-. simpl. rewrite (iscomm_Lmin _ x), <- isassoc_Lmin. rewrite (isassoc_Lmin _ _ _ y), Lmin_id. rewrite isassoc_Lmin, (iscomm_Lmin _ y). rewrite isassoc_Lmin, <- (isassoc_Lmin _ x), Lmin_id. apply pathsinv0, isassoc_Lmin. Qed. Lemma Lmax_le_l : ∏ x y : X, Lle lat x (Lmax lat x y). Proof. intros x y. simpl. apply Lmin_absorb. Qed. Lemma Lmax_le_r : ∏ x y : X, Lle lat y (Lmax lat x y). Proof. intros x y. rewrite iscomm_Lmax. apply Lmax_le_l. Qed. Lemma Lmax_le_case : ∏ x y z : X, Lle lat x z → Lle lat y z → Lle lat (Lmax lat x y) z. Proof. intros x y z <- <-. set (w := Lmax _ (Lmin _ x z) (Lmin _ y z)). assert (c : z = (Lmax lat w z)). - unfold w. now rewrite isassoc_Lmax, (iscomm_Lmax _ (Lmin _ y z) _), (iscomm_Lmin _ y z), Lmax_absorb, iscomm_Lmax, iscomm_Lmin, Lmax_absorb. - rewrite c. use (Lmin_absorb lat). Qed. Lemma Lmin_le_eq_l : ∏ x y : X, Lle lat x y → Lmin lat x y = x. Proof. intros x y H. apply H. Qed. Lemma Lmin_le_eq_r : ∏ x y : X, Lle lat y x → Lmin lat x y = y. Proof. intros x y H. rewrite iscomm_Lmin. apply H. Qed. Lemma Lmax_le_eq_l : ∏ x y : X, Lle lat y x → Lmax lat x y = x. Proof. intros x y <-. rewrite iscomm_Lmin. apply Lmax_absorb. Qed. Lemma Lmax_le_eq_r : ∏ x y : X, Lle lat x y → Lmax lat x y = y. Proof. intros x y H. rewrite iscomm_Lmax. now apply Lmax_le_eq_l. Qed. End lattice_le. (** [Lge] *) Definition Lge {X : hSet} (lat : lattice X) : hrel X := λ x y : X, Lle lat y x. Section Lge_pty. Context {X : hSet} (lat : lattice X). Definition isrefl_Lge : isrefl (Lge lat) := isrefl_Lle lat. Lemma isantisymm_Lge : isantisymm (Lge lat). Proof. intros x y Hle Hge. apply (isantisymm_Lle lat). exact Hge. exact Hle. Qed. Lemma istrans_Lge : istrans (Lge lat). Proof. intros x y z Hxy Hyz. apply (istrans_Lle lat) with y. exact Hyz. exact Hxy. Qed. Lemma isPartialOrder_Lge : isPartialOrder (Lge lat). Proof. split ; [ split | ]. - exact istrans_Lge. - exact isrefl_Lge. - exact isantisymm_Lge. Qed. Definition Lmin_ge_l : ∏ (x y : X), Lge lat x (Lmin lat x y) := Lmin_le_l lat. Definition Lmin_ge_r : ∏ (x y : X), Lge lat y (Lmin lat x y) := Lmin_le_r lat. Definition Lmin_ge_case : ∏ (x y z : X), Lge lat x z → Lge lat y z → Lge lat (Lmin lat x y) z := Lmin_le_case lat. Definition Lmax_ge_l : ∏ (x y : X), Lge lat (Lmax lat x y) x := Lmax_le_l lat. Definition Lmax_ge_r : ∏ (x y : X), Lge lat (Lmax lat x y) y := Lmax_le_r lat. Definition Lmax_ge_case : ∏ x y z : X, Lge lat z x → Lge lat z y → Lge lat z (Lmax lat x y) := Lmax_le_case lat. Definition Lmin_ge_eq_l : ∏ (x y : X), Lge lat y x → Lmin lat x y = x := Lmin_le_eq_l lat. Definition Lmin_ge_eq_r : ∏ (x y : X), Lge lat x y → Lmin lat x y = y := Lmin_le_eq_r lat. Definition Lmax_ge_eq_l : ∏ (x y : X), Lge lat x y → Lmax lat x y = x := Lmax_le_eq_l lat. Definition Lmax_ge_eq_r : ∏ (x y : X), Lge lat y x → Lmax lat x y = y := Lmax_le_eq_r lat. End Lge_pty. (** ** Lattice with a strong order *) Definition islatticewithgtrel {X : hSet} (lat : lattice X) (gt : StrongOrder X) := (∏ x y : X, (¬ (gt x y)) <-> Lle lat x y) × (∏ x y z : X, gt x z → gt y z → gt (Lmin lat x y) z) × (∏ x y z : X, gt z x → gt z y → gt z (Lmax lat x y)). Definition latticewithgt (X : hSet) := ∑ (lat : lattice X) (gt : StrongOrder X), islatticewithgtrel lat gt. Definition lattice_latticewithgt {X : hSet} : latticewithgt X → lattice X := pr1. Coercion lattice_latticewithgt : latticewithgt >-> lattice. (** [Lgt] *) Definition Lgt {X : hSet} (lat : latticewithgt X) : StrongOrder X := pr1 (pr2 lat). Section latticewithgt_pty. Context {X : hSet} (lat : latticewithgt X). Definition notLgt_Lle : ∏ x y : X, (¬ Lgt lat x y) → Lle lat x y := λ x y : X, pr1 (pr1 (pr2 (pr2 lat)) x y). Definition Lle_notLgt : ∏ x y : X, Lle lat x y → ¬ Lgt lat x y := λ x y : X, pr2 (pr1 (pr2 (pr2 lat)) x y). Definition isirrefl_Lgt : isirrefl (Lgt lat) := isirrefl_isStrongOrder (Lgt lat). Definition istrans_Lgt : istrans (Lgt lat) := istrans_isStrongOrder (Lgt lat). Definition iscotrans_Lgt : iscotrans (Lgt lat) := iscotrans_isStrongOrder (Lgt lat). Definition isasymm_Lgt : isasymm (Lgt lat) := isasymm_isStrongOrder (Lgt lat). Lemma Lgt_Lge : ∏ x y : X, Lgt lat x y → Lge lat x y. Proof. intros x y H. apply notLgt_Lle. intro H0. eapply isasymm_Lgt. exact H. exact H0. Qed. Lemma istrans_Lgt_Lge : ∏ x y z : X, Lgt lat x y → Lge lat y z → Lgt lat x z. Proof. intros x y z Hgt Hge. generalize (iscotrans_Lgt _ z _ Hgt). apply hinhuniv. apply sumofmaps ; intros H. - exact H. - apply fromempty. refine (Lle_notLgt _ _ _ _). exact Hge. exact H. Qed. Lemma istrans_Lge_Lgt : ∏ x y z : X, Lge lat x y → Lgt lat y z → Lgt lat x z. Proof. intros x y z Hge Hgt. generalize (iscotrans_Lgt _ x _ Hgt). apply hinhuniv. apply sumofmaps ; intros H. - apply fromempty. refine (Lle_notLgt _ _ _ _). exact Hge. exact H. - exact H. Qed. Definition Lmin_Lgt : ∏ x y z : X, Lgt lat x z → Lgt lat y z → Lgt lat (Lmin lat x y) z := pr1 (pr2 (pr2 (pr2 lat))). Definition Lmax_Lgt : ∏ x y z : X, Lgt lat z x → Lgt lat z y → Lgt lat z (Lmax lat x y) := pr2 (pr2 (pr2 (pr2 lat))). End latticewithgt_pty. (** ** Lattice with a total order *) Definition latticedec (X : hSet) := ∑ lat : lattice X, istotal (Lle lat) × (isdecrel (Lle lat)). Definition lattice_latticedec {X : hSet} (lat : latticedec X) : lattice X := pr1 lat. Coercion lattice_latticedec : latticedec >-> lattice. Definition istotal_latticedec {X : hSet} (lat : latticedec X) : istotal (Lle lat) := pr1 (pr2 lat). Definition isdecrel_latticedec {X : hSet} (lat : latticedec X) : isdecrel (Lle lat) := pr2 (pr2 lat). Section latticedec_pty. Context {X : hSet} (lat : latticedec X). Lemma Lmin_case_strong : ∏ (P : X → UU) (x y : X), (Lle lat x y → P x) → (Lle lat y x → P y) → P (Lmin lat x y). Proof. intros P x y Hx Hy. generalize (isdecrel_latticedec lat x y). apply sumofmaps ; intros H. - rewrite Lmin_le_eq_l. apply Hx, H. exact H. - enough (H0 : Lle lat y x). + rewrite Lmin_le_eq_r. apply Hy, H0. exact H0. + generalize (istotal_latticedec lat x y). apply hinhuniv, sumofmaps ; intros H0. apply fromempty, H, H0. exact H0. Qed. Lemma Lmin_case : ∏ (P : X → UU) (x y : X), P x → P y → P (Lmin lat x y). Proof. intros P x y Hx Hy. apply Lmin_case_strong ; intros _. - exact Hx. - exact Hy. Qed. Lemma Lmax_case_strong : ∏ (P : X → UU) (x y : X), (Lle lat y x → P x) → (Lle lat x y → P y) → P (Lmax lat x y). Proof. intros P x y Hx Hy. generalize (isdecrel_latticedec lat x y). apply sumofmaps ; intros H. - rewrite Lmax_le_eq_r. apply Hy, H. exact H. - enough (H0 : Lle lat y x). + rewrite Lmax_le_eq_l. apply Hx, H0. exact H0. + generalize (istotal_latticedec lat x y). apply hinhuniv, sumofmaps ; intros H0. apply fromempty, H, H0. exact H0. Qed. Lemma Lmax_case : ∏ (P : X → UU) (x y : X), P x → P y → P (Lmax lat x y). Proof. intros P x y Hx Hy. apply Lmax_case_strong ; intros _. - exact Hx. - exact Hy. Qed. End latticedec_pty. (** It is a lattice with a strong order *) Section latticedec_gt. Context {X : hSet} (lat : latticedec X). Definition latticedec_gt_rel : hrel X := λ x y, hneg (Lle lat x y). Lemma latticedec_gt_ge : ∏ x y : X, latticedec_gt_rel x y → Lge lat x y. Proof. intros x y Hxy. generalize (istotal_latticedec lat x y). apply hinhuniv, sumofmaps ; intros H. - apply fromempty. exact (Hxy H). - exact H. Qed. Lemma istrans_latticedec_gt_rel : istrans latticedec_gt_rel. Proof. intros x y z Hxy Hyz Hxz. simple refine (Hxy _). apply istrans_Lle with z. apply Hxz. apply latticedec_gt_ge. exact Hyz. Qed. Lemma iscotrans_latticedec_gt_rel : iscotrans latticedec_gt_rel. Proof. intros x y z Hxz. induction (isdecrel_latticedec lat x y) as [Hxy | Hyx]. - apply hinhpr, ii2. intros Hyz. simple refine (Hxz _). apply istrans_Lle with y. exact Hxy. exact Hyz. - apply hinhpr, ii1. exact Hyx. Qed. Definition latticedec_gt_so : StrongOrder X. Proof. exists latticedec_gt_rel. repeat split. - apply istrans_latticedec_gt_rel. - apply iscotrans_latticedec_gt_rel. - intros x Hx. simple refine (Hx _). apply isrefl_Lle. Defined. Lemma latticedec_notgtle : ∏ (x y : X), ¬ latticedec_gt_so x y → Lle lat x y. Proof. intros x y H. induction (isdecrel_latticedec lat x y) as [H0 | H0]. + exact H0. + apply fromempty, H. exact H0. Qed. Lemma latticedec_lenotgt : ∏ (x y : X), Lle lat x y → ¬ latticedec_gt_so x y. Proof. intros x y H H0. simple refine (H0 _). exact H. Qed. Lemma latticedec_gtmin : ∏ (x y z : X), latticedec_gt_so x z → latticedec_gt_so y z → latticedec_gt_so (Lmin lat x y) z. Proof. intros x y z Hxz Hyz. apply (Lmin_case lat (λ t : X, latticedec_gt_so t z)). - exact Hxz. - exact Hyz. Qed. Lemma latticedec_gtmax : ∏ (x y z : X), latticedec_gt_so z x → latticedec_gt_so z y → latticedec_gt_so z (Lmax lat x y). Proof. intros x y z Hxz Hyz. apply (Lmax_case lat (latticedec_gt_so z)). - exact Hxz. - exact Hyz. Qed. Definition latticedec_gt : latticewithgt X. Proof. exists (lattice_latticedec lat). exists latticedec_gt_so. split ; split. - apply latticedec_notgtle. - apply latticedec_lenotgt. - apply latticedec_gtmin. - apply latticedec_gtmax. Defined. End latticedec_gt. (** ** Lattice in an abmonoid *) Local Open Scope addmonoid. Import UniMath.Algebra.Monoids.AddNotation. Section lattice_abmonoid. Context {X : abmonoid} (lat : lattice X) (is0 : isrcancellative (@op X)) (is2 : isrdistr (Lmin lat) op). Lemma op_le_r : ∏ k x y : X, Lle lat x y → Lle lat (x + k) (y + k). Proof. intros k x y H. unfold Lle ; simpl. now rewrite <- is2, H. Qed. Lemma op_le_r' : ∏ k x y : X, Lle lat (x + k) (y + k) → Lle lat x y. Proof. intros k x y H. eapply rcancel. { apply is0. } now rewrite is2, H. Qed. End lattice_abmonoid. (** ** Truncated minus *) Definition istruncminus {X : abmonoid} (lat : lattice X) (minus : binop X) := ∏ x y : X, minus x y + y = Lmax lat x y. Lemma isaprop_istruncminus {X : abmonoid} (lat : lattice X) (minus : binop X) : isaprop (istruncminus lat minus). Proof. apply impred_isaprop ; intros x. apply impred_isaprop ; intros y. apply setproperty. Qed. Definition extruncminus {X : abmonoid} (lat : lattice X) := ∑ minus : binop X, istruncminus lat minus. Lemma isaprop_extruncminus {X : abmonoid} (lat : lattice X) (Hop : isrcancellative (@op X)) : isaprop (extruncminus lat). Proof. intros minus1 minus2 ; simpl. apply iscontraprop1. - apply isaset_total2. apply impred_isaset ; intros _. apply impred_isaset ; intros _. apply setproperty. intros minus. apply isasetaprop. apply isaprop_istruncminus. - apply subtypePath. + intros f. apply isaprop_istruncminus. + apply weqfunextsec ; intros x. apply weqfunextsec ; intros y. eapply rcancel. { apply Hop. } rewrite (pr2 minus1). apply pathsinv0, (pr2 minus2). Qed. Definition truncminus {X : abmonoid} {lat : lattice X} (ex : extruncminus lat) : binop X := pr1 ex. Lemma istruncminus_ex {X : abmonoid} {lat : lattice X} (ex : extruncminus lat) : ∏ x y : X, truncminus ex x y + y = Lmax lat x y. Proof. apply (pr2 ex). Qed. Section truncminus_pty. Context {X : abmonoid} {lat : lattice X} (ex : extruncminus lat) (is1 : isrcancellative (@op X)) (is2 : isrdistr (Lmax lat) op) (is3 : isrdistr (Lmin lat) op) (is4 : isrdistr (Lmin lat) (Lmax lat)) (is5 : isrdistr (Lmax lat) (Lmin lat)). Lemma truncminus_0_r : ∏ x : X, truncminus ex x 0 = Lmax lat x 0. Proof. intros x. rewrite <- (runax _ (truncminus _ _ _)). apply (istruncminus_ex). Qed. Lemma truncminus_eq_0 : ∏ x y : X, Lle lat x y → truncminus ex x y = 0. Proof. intros x y H. eapply rcancel. { apply is1. } simpl. refine (pathscomp0 _ _). apply istruncminus_ex. refine (pathscomp0 _ _). apply Lmax_le_eq_r, H. apply pathsinv0, (lunax X). Qed. Lemma truncminus_0_l_ge0 : ∏ x : X, Lle lat 0 x → truncminus ex 0 x = 0. Proof. intros x Hx. apply truncminus_eq_0, Hx. Qed. Lemma truncminus_0_l_le0 : ∏ x : X, Lle lat x 0 → truncminus ex 0 x + x = 0. Proof. intros x Hx. rewrite istruncminus_ex. apply Lmax_le_eq_l, Hx. Qed. Lemma truncminus_ge_0 : ∏ x y : X, Lle lat 0 (truncminus ex x y). Proof. intros x y. apply (op_le_r' _ is1 is3 y). rewrite istruncminus_ex, lunax. apply Lmax_ge_r. Qed. Lemma truncminus_le : ∏ x y : X, Lle lat 0 x → Lle lat 0 y → Lle lat (truncminus ex x y) x. Proof. intros x y Hx Hy. apply (op_le_r' _ is1 is3 y). rewrite istruncminus_ex. apply Lmax_le_case. - apply istrans_Lle with (0 + x). + rewrite (lunax _ x). apply isrefl_Lle. + rewrite (commax _ x). now apply op_le_r. - apply istrans_Lle with (0 + y). + rewrite (lunax _ y). apply isrefl_Lle. + now apply op_le_r. Qed. Lemma truncminus_truncminus : ∏ x y, Lle lat 0 x → Lle lat x y → truncminus ex y (truncminus ex y x) = x. Proof. intros x y Hx Hxy. eapply rcancel. { apply is1. } simpl. erewrite (commax _ x), istruncminus_ex. refine (pathscomp0 _ _). apply istruncminus_ex. rewrite !Lmax_le_eq_l. - reflexivity. - exact Hxy. - apply truncminus_le. apply istrans_Lle with x. exact Hx. exact Hxy. exact Hx. Qed. Lemma truncminus_le_r : ∏ k x y : X, Lle lat x y → Lle lat (truncminus ex x k) (truncminus ex y k). Proof. intros k x y <-. eapply rcancel. { apply is1. } simpl. rewrite is3, 2!istruncminus_ex. rewrite is4, isassoc_Lmin, Lmin_id. rewrite <- is4. apply pathsinv0, istruncminus_ex. Qed. Lemma truncminus_le_l : ∏ k x y : X, Lle lat y x → Lle lat (truncminus ex k x) (truncminus ex k y). Proof. intros k x y H. apply (rcancel (is1 y)). rewrite is3, istruncminus_ex. apply (rcancel (is1 x)). rewrite is3, assocax, (commax _ y), <- assocax, istruncminus_ex. rewrite !is2, (commax _ y), <- is4, !(commax _ k), <- is3, H. reflexivity. Qed. Lemma truncminus_Lmax_l : ∏ (k x y : X), truncminus ex (Lmax lat x y) k = Lmax lat (truncminus ex x k) (truncminus ex y k). Proof. intros k x y. apply (rcancel (is1 k)). rewrite is2, !istruncminus_ex. rewrite !isassoc_Lmax, (iscomm_Lmax _ k), isassoc_Lmax, Lmax_id. reflexivity. Qed. Lemma truncminus_Lmax_r : ∏ (k x y : X), Lle lat (Lmin lat (y + y) (x + x)) (x + y) → truncminus ex k (Lmax lat x y) = Lmin lat (truncminus ex k x) (truncminus ex k y). Proof. intros k x y H. eapply rcancel. { apply is1. } rewrite is3, istruncminus_ex. rewrite !(commax _ _ (Lmax _ _ _)), !is2. rewrite !(commax _ _ (truncminus _ _ _)), !istruncminus_ex. rewrite (iscomm_Lmax _ (_*_)%multmonoid (Lmax _ _ _)). rewrite !isassoc_Lmax, !(iscomm_Lmax _ k). rewrite <- is4. eapply rcancel. { apply is1. } rewrite !is2, is3, !is2. rewrite assocax, (commax _ y x), <- assocax. rewrite istruncminus_ex, is2. eapply rcancel. { apply (is1 y). } rewrite !is2, is3, !is2. rewrite !assocax, (commax _ (truncminus _ _ _)), !assocax, (commax _ _ (truncminus _ _ _)). rewrite istruncminus_ex. rewrite (commax _ _ (Lmax _ _ _)), is2. rewrite (commax _ _ (Lmax _ _ _)), is2. rewrite 4!(commax _ _ x). rewrite <- (isassoc_Lmax _ _ _ (x * (y * y))%multmonoid). rewrite (iscomm_Lmax _ (x * (y * y))%multmonoid (Lmax _ _ _)). rewrite <- is4. rewrite (iscomm_Lmax _ (x * (x * y))%multmonoid (k * (y * y))%multmonoid), <- is4. rewrite !(commax _ k), <- !assocax. rewrite <- is3. rewrite !(iscomm_Lmax _ _ (x * y * k)%multmonoid), <- !isassoc_Lmax. rewrite (Lmax_le_eq_l _ (x * y * k)%multmonoid (Lmin lat (y * y) (x * x) * k)%multmonoid). reflexivity. apply op_le_r. exact is3. exact H. Qed. Lemma truncminus_Lmin_l : ∏ k x y : X, truncminus ex (Lmin lat x y) k = Lmin lat (truncminus ex x k) (truncminus ex y k). Proof. intros k x y. eapply rcancel. { apply (is1 k). } simpl. rewrite is3, 2!istruncminus_ex. apply (pathscomp0 (istruncminus_ex _ _ _)). apply is4. Qed. End truncminus_pty. Lemma abgr_truncminus {X : abgr} (lat : lattice X) : isrdistr (Lmax lat) op → istruncminus (X := abgrtoabmonoid X) lat (λ x y : X, Lmax lat 0 (x + grinv X y)). Proof. intros H x y. rewrite H, assocax, grlinvax, lunax, runax. apply iscomm_Lmax. Qed. Section truncminus_gt. Context {X : abmonoid} (lat : latticewithgt X) (ex : extruncminus lat) (is0 : ∏ x y z : X, Lgt lat y z → Lgt lat (y + x) (z + x)) (is1 : ∏ x y z : X, Lgt lat (y + x) (z + x) → Lgt lat y z). Lemma truncminus_pos : ∏ x y : X, Lgt lat x y → Lgt lat (truncminus ex x y) 0. Proof. intros x y. intros H. apply (is1 y). rewrite lunax, istruncminus_ex. rewrite Lmax_le_eq_l. exact H. apply Lgt_Lge, H. Qed. Lemma truncminus_pos' : ∏ x y : X, Lgt lat (truncminus ex x y) 0 → Lgt lat x y. Proof. intros x y Hgt. apply (is0 y) in Hgt. rewrite istruncminus_ex, lunax in Hgt. rewrite <- (Lmax_le_eq_l lat x y). exact Hgt. apply notLgt_Lle. intros H ; revert Hgt. apply Lle_notLgt. rewrite Lmax_le_eq_r. apply isrefl_Lle. apply Lgt_Lge. exact H. Qed. End truncminus_gt. Close Scope addmonoid. (** ** lattice and [weq] *) (** *** Definition *) Lemma islatticeop_weq {X Y : hSet} (H : weq Y X) {min max : binop X} (lat : islatticeop min max) : islatticeop (binop_weq_bck H min) (binop_weq_bck H max). Proof. intros. split ; [ | split] ; split. - apply (isassoc_weq_bck H), (isassoc_Lmin (_,,_,,lat)). - apply (iscomm_weq_bck H), (iscomm_Lmin (_,,_,,lat)). - apply (isassoc_weq_bck H), (isassoc_Lmax (_,,_,,lat)). - apply (iscomm_weq_bck H), (iscomm_Lmax (_,,_,,lat)). - apply (isabsorb_weq_bck H), (Lmin_absorb (_,,_,,lat)). - apply (isabsorb_weq_bck H), (Lmax_absorb (_,,_,,lat)). Qed. Definition lattice_weq {X Y : hSet} (H : weq Y X) (lat : lattice X) : lattice Y. Proof. exists (binop_weq_bck H (Lmin lat)), (binop_weq_bck H (Lmax lat)). apply islatticeop_weq. apply (pr2 (pr2 lat)). Defined. (** *** Value of [Lle] *) Lemma Lle_correct_weq {X Y : hSet} (H : weq Y X) (lat : lattice X) : fun_hrel_comp H (Lle lat) = Lle (lattice_weq H lat). Proof. apply funextfun ; intros x. apply funextfun ; intros y. apply hPropUnivalence ; intros Hle. - apply pathsinv0, pathsweq1, pathsinv0. apply Hle. - apply pathsinv0, pathsweq1', pathsinv0. apply Hle. Qed. (** *** Lattice with strong order *) Lemma islatticewithgtrel_weq {X Y : hSet} (H : weq Y X) {gt : StrongOrder X} (lat : lattice X) : islatticewithgtrel lat gt → islatticewithgtrel (lattice_weq H lat) (StrongOrder_bck H gt). Proof. intros Hgt. split ; split. - intros Hngt. unfold Lle ; simpl. unfold binop_weq_bck. rewrite (pr1 (pr1 Hgt _ _)). apply homotinvweqweq. apply Hngt. - intros Hle. apply (pr2 (pr1 Hgt _ _)). unfold Lle ; simpl. apply pathsinv0, pathsweq1', pathsinv0. apply Hle. - simpl ; intros x y z Hx Hy. unfold binop_weq_bck, fun_hrel_comp. rewrite homotweqinvweq. apply (pr1 (pr2 Hgt)). exact Hx. exact Hy. - unfold Lmax ; simpl ; intros x y z Hx Hy. unfold binop_weq_bck, fun_hrel_comp. rewrite homotweqinvweq. apply (pr2 (pr2 Hgt)). exact Hx. exact Hy. Qed. Definition latticewithgt_weq {X Y : hSet} (H : weq Y X) (lat : latticewithgt X) : latticewithgt Y. Proof. exists (lattice_weq H lat), (StrongOrder_bck H (Lgt lat)). apply islatticewithgtrel_weq. apply (pr2 (pr2 lat)). Defined. (** *** Lattice with a decidable order *) Lemma istotal_Lle_weq {X Y : hSet} (H : weq Y X) (lat : lattice X) (is' : istotal (Lle lat)) : istotal (Lle (lattice_weq H lat)). Proof. intros x y. generalize (is' (H x) (H y)). apply hinhfun, sumofmaps ; intros Hmin. - apply ii1, (pathscomp0 (maponpaths (invmap H) Hmin)), homotinvweqweq. - apply ii2, (pathscomp0 (maponpaths (invmap H) Hmin)), homotinvweqweq. Qed. Lemma isdecrel_Lle_weq {X Y : hSet} (H : weq Y X) (lat : lattice X) (is' : isdecrel (Lle lat)) : isdecrel (Lle (lattice_weq H lat)). Proof. intros x y. generalize (is' (H x) (H y)). apply sumofmaps ; intros Hmin. - apply ii1, (pathscomp0 (maponpaths (invmap H) Hmin)), homotinvweqweq. - apply ii2. intros Hinv ; apply Hmin. apply pathsinv0, pathsweq1', pathsinv0, Hinv. Qed. Definition latticedec_weq {X Y : hSet} (H : weq Y X) : latticedec X → latticedec Y. Proof. intros lat. exists (lattice_weq H (lattice_latticedec lat)). split. - apply istotal_Lle_weq. apply istotal_latticedec. - apply isdecrel_Lle_weq. apply isdecrel_latticedec. Defined. (** ** lattice in [abmonoid] *) Open Scope multmonoid. Lemma abmonoidfrac_setquotpr_equiv {X : abmonoid} {Y : @submonoid X} : ∏ (k : Y) (x : X) (y : Y), setquotpr (binopeqrelabmonoidfrac X Y) (x,,y) = setquotpr (binopeqrelabmonoidfrac X Y) (x * pr1 k,, @op Y y k). Proof. intros k x y. apply iscompsetquotpr, hinhpr. exists y ; simpl. rewrite !(assocax X) ; apply maponpaths. rewrite commax, !assocax. reflexivity. Qed. Definition ispartrdistr {X : abmonoid} (Y : @submonoid X) (opp1 opp2 : binop X) := ∏ (x y : X) (k : Y), opp2 (opp1 x y) (pr1 k) = opp1 (opp2 x (pr1 k)) (opp2 y (pr1 k)). Section abmonoidfrac_lattice. Context (X : abmonoid) (Y : @submonoid X) {min max : binop X} (Hmin_assoc : isassoc min) (Hmin_comm : iscomm min) (Hmax_assoc : isassoc max) (Hmax_comm : iscomm max) (Hmin_max : isabsorb min max) (Hmax_min : isabsorb max min) (Hmin : ispartrdistr Y min op) (Hmax : ispartrdistr Y max op). (** generic lemmas *) Local Definition abmonoidfrac_lattice_fun (f : binop X) : binop (X × Y) := λ x y, (f (pr1 x * pr1 (pr2 y))%multmonoid (pr1 y * pr1 (pr2 x))%multmonoid ,, @op Y (pr2 x) (pr2 y)). Local Lemma abmonoidfrac_lattice_def : ∏ (f : X → X → X), ispartrdistr Y f op → iscomprelrelfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) (abmonoidfrac_lattice_fun f). Proof. intros f Hf. intros x y x' y'. apply hinhfun2. intros c c'. unfold abmonoidfrac_lattice_fun. change (∑ a0 : Y, f (pr1 x * pr1 (pr2 x')) (pr1 x' * pr1 (pr2 x)) * pr1 (pr2 y * pr2 y') * pr1 a0 = f (pr1 y * pr1 (pr2 y')) (pr1 y' * pr1 (pr2 y)) * pr1 (pr2 x * pr2 x') * pr1 a0). exists (@op Y (pr1 c) (pr1 c')). - do 4 rewrite Hf. apply map_on_two_paths. + change ((pr1 x * pr1 (pr2 x') * (pr1 (pr2 y) * pr1 (pr2 y')) * (pr1 (pr1 c) * pr1 (pr1 c')))%multmonoid = (pr1 y * pr1 (pr2 y') * (pr1 (pr2 x) * pr1 (pr2 x')) * (pr1 (pr1 c) * pr1 (pr1 c')))%multmonoid). rewrite (assocax X (pr1 x)), (assocax X (pr1 y)). rewrite (commax X (pr1 (pr2 x'))), (commax X (pr1 (pr2 y'))). do 2 rewrite <- (assocax X (pr1 x)), <- (assocax X (pr1 y)). do 2 rewrite (assocax X (pr1 x * pr1 (pr2 y))%multmonoid), (assocax X (pr1 y * pr1 (pr2 x))%multmonoid). do 2 rewrite (commax X _ (pr1 (pr1 c) * _)%multmonoid). do 2 rewrite <- (assocax X _ (pr1 (pr1 c) * _)%multmonoid). do 2 rewrite <- (assocax X _ (pr1 (pr1 c))%multmonoid). rewrite (commax X (pr1 (pr2 y'))). apply (maponpaths (λ x, (x * _ * _)%multmonoid)). apply (pr2 c). + rewrite (commax _ (pr2 y)), (commax _ (pr2 x)), (iscommcarrier Y (pr1 c)). change ((pr1 x' * pr1 (pr2 x) * (pr1 (pr2 y') * pr1 (pr2 y)) * (pr1 (pr1 c') * pr1 (pr1 c)))%multmonoid = (pr1 y' * pr1 (pr2 y) * (pr1 (pr2 x') * pr1 (pr2 x)) * (pr1 (pr1 c') * pr1 (pr1 c)))%multmonoid). rewrite (assocax X (pr1 x')), (assocax X (pr1 y')). rewrite (commax X (pr1 (pr2 x))), (commax X (pr1 (pr2 y))). do 2 rewrite <- (assocax X (pr1 x')), <- (assocax X (pr1 y')). do 2 rewrite (assocax X (pr1 x' * pr1 (pr2 y'))%multmonoid), (assocax X (pr1 y' * pr1 (pr2 x'))%multmonoid). do 2 rewrite (commax X _ (pr1 (pr1 c') * _)%multmonoid). do 2 rewrite <- (assocax X _ (pr1 (pr1 c') * _)%multmonoid). do 2 rewrite <- (assocax X _ (pr1 (pr1 c'))%multmonoid). rewrite (commax X (pr1 (pr2 y))). apply (maponpaths (λ x, (x * _ * _)%multmonoid)). apply (pr2 c'). Qed. Local Lemma iscomm_abmonoidfrac_def : ∏ (f : X → X → X) Hf, iscomm f → iscomm (X := abmonoidfrac X Y) (setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def f Hf)). Proof. intros f Hf Hcomm. simple refine (setquotuniv2prop _ (λ x y, (_ x y = _ y x) ,, _) _). - apply (pr2 (pr1 (pr1 (abmonoidfrac X Y)))). - intros x y. simpl. rewrite !(setquotfun2comm (eqrelabmonoidfrac X Y)). unfold abmonoidfrac_lattice_fun. rewrite Hcomm, (commax X (pr1 x)), (commax _ (pr2 x)). reflexivity. Qed. Local Lemma isassoc_abmonoidfrac_def : ∏ (f : X → X → X) Hf, isassoc f → isassoc (X := abmonoidfrac X Y) (setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def f Hf)). Proof. intros f Hf Hassoc. simple refine (setquotuniv3prop _ (λ x y z, (_ (_ x y) z = _ x (_ y z)) ,, _) _). - apply (pr2 (pr1 (pr1 (abmonoidfrac X Y)))). - intros x y z ; simpl. rewrite !(setquotfun2comm (eqrelabmonoidfrac X Y)). apply (iscompsetquotpr (eqrelabmonoidfrac X Y)), hinhpr. exists (pr2 x). apply (maponpaths (λ x, (x * _)%multmonoid)). unfold abmonoidfrac_lattice_fun. simpl ; unfold pr1carrier ; simpl. rewrite (assocax X (pr1 (pr2 x))). apply (maponpaths (λ x: X, op x _)). do 2 rewrite Hf. rewrite Hassoc. do 4 rewrite (assocax X). do 2 rewrite (commax X (pr1 (pr2 x))). reflexivity. Qed. Local Lemma isabsorb_abmonoidfrac_def : ∏ f g Hf Hg, isabsorb f g → isabsorb (X := abmonoidfrac X Y) (setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def f Hf)) (setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def g Hg)). Proof. intros f g Hf Hg Habsorb. simple refine (setquotuniv2prop _ (λ x y, (_ x (_ x y) = x) ,, _) _). - apply (setproperty (abmonoidfrac X Y)). - intros x y. simpl. rewrite !(setquotfun2comm (eqrelabmonoidfrac X Y)). unfold abmonoidfrac_lattice_fun. apply (iscompsetquotpr (eqrelabmonoidfrac X Y)), hinhpr. exists (pr2 x). apply (maponpaths (λ x, (x * _)%multmonoid)). simpl ; unfold pr1carrier ; simpl. rewrite Hf, Hg, Hg. do 3 rewrite (assocax X (pr1 x)). rewrite (commax X (pr1 (pr2 y))). do 2 rewrite (assocax X (pr1 (pr2 x))). do 3 rewrite (commax X (pr1 (pr2 x))). apply Habsorb. Qed. (** definition of abmonoidfrac_lattice *) Definition abmonoidfrac_min : binop (abmonoidfrac X Y) := setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def min Hmin). Definition abmonoidfrac_max : binop (abmonoidfrac X Y) := setquotfun2 (binopeqrelabmonoidfrac X Y) (binopeqrelabmonoidfrac X Y) _ (abmonoidfrac_lattice_def max Hmax). Lemma iscomm_abmonoidfrac_min : iscomm abmonoidfrac_min. Proof. apply iscomm_abmonoidfrac_def. apply Hmin_comm. Qed. Lemma isassoc_abmonoidfrac_min : isassoc abmonoidfrac_min. Proof. apply isassoc_abmonoidfrac_def. apply Hmin_assoc. Qed. Lemma iscomm_abmonoidfrac_max : iscomm abmonoidfrac_max. Proof. apply iscomm_abmonoidfrac_def. apply Hmax_comm. Qed. Lemma isassoc_abmonoidfrac_max : isassoc abmonoidfrac_max. Proof. apply isassoc_abmonoidfrac_def. apply Hmax_assoc. Qed. Lemma isabsorb_abmonoidfrac_max_min : isabsorb abmonoidfrac_max abmonoidfrac_min. Proof. apply isabsorb_abmonoidfrac_def. apply Hmax_min. Qed. Lemma isabsorb_abmonoidfrac_min_max : isabsorb abmonoidfrac_min abmonoidfrac_max. Proof. apply isabsorb_abmonoidfrac_def. apply Hmin_max. Qed. End abmonoidfrac_lattice. Lemma abmonoidfrac_islatticeop (X : abmonoid) (Y : @submonoid X) (lat : lattice X) : ∏ (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op), islatticeop (abmonoidfrac_min X Y Hmin) (abmonoidfrac_max X Y Hmax). Proof. intros Hmin Hmax. repeat split. - apply isassoc_abmonoidfrac_min, isassoc_Lmin. - apply iscomm_abmonoidfrac_min, iscomm_Lmin. - apply isassoc_abmonoidfrac_max, isassoc_Lmax. - apply iscomm_abmonoidfrac_max, iscomm_Lmax. - apply isabsorb_abmonoidfrac_min_max, Lmin_absorb. - apply isabsorb_abmonoidfrac_max_min, Lmax_absorb. Qed. Definition abmonoidfrac_lattice (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : lattice (abmonoidfrac X Y). Proof. exists (abmonoidfrac_min X Y Hmin). exists (abmonoidfrac_max X Y Hmax). apply abmonoidfrac_islatticeop. Defined. Lemma ispartbinophrel_Lle (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (Hmin : ispartrdistr Y (Lmin lat) op) : ispartbinophrel Y (Lle lat). Proof. split. - intros a b c Yc. rewrite !(commax _ c). unfold Lle ; rewrite <- (Hmin _ _ (c,,Yc)). apply (maponpaths (λ x, op x _)). - intros a b c Yc. unfold Lle ; rewrite <- (Hmin _ _ (c,,Yc)). apply (maponpaths (λ x, op x _)). Qed. Lemma abmonoidfrac_Lle_1 (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (Hmin : ispartrdistr _ (Lmin lat) op) : ∏ (x y : abmonoiddirprod X _), abmonoidfracrel X Y (ispartbinophrel_Lle X Y lat Hmin) (setquotpr (binopeqrelabmonoidfrac X Y) x) (setquotpr (binopeqrelabmonoidfrac X Y) y) → abmonoidfrac_min X Y Hmin (setquotpr (binopeqrelabmonoidfrac X Y) x) (setquotpr (binopeqrelabmonoidfrac X Y) y) = setquotpr (binopeqrelabmonoidfrac X Y) x. Proof. intros x y. unfold abmonoidfracrel, quotrel, abmonoidfrac_min. rewrite setquotuniv2comm, setquotfun2comm. intros H. apply iscompsetquotpr. revert H. apply hinhfun. intros c. exists (pr1 c). simpl in c |- *. rewrite (assocax X), (commax _ _ (pr1 (pr1 c))), <- (assocax X). rewrite Hmin. refine (pathscomp0 _ _). refine (maponpaths (λ x, x * _) _). apply (pr2 c). do 3 rewrite (assocax X) ; apply maponpaths. do 2 rewrite commax, assocax. apply pathsinv0, assocax. Qed. Lemma abmonoidfrac_Lle_2 (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (Hmin : ispartrdistr _ (Lmin lat) op) : ∏ (x y : abmonoiddirprod X _), abmonoidfrac_min X Y Hmin (setquotpr (binopeqrelabmonoidfrac X Y) x) (setquotpr (binopeqrelabmonoidfrac X Y) y) = setquotpr (binopeqrelabmonoidfrac X Y) x → abmonoidfracrel X Y (ispartbinophrel_Lle X Y lat Hmin) (setquotpr (binopeqrelabmonoidfrac X Y) x) (setquotpr (binopeqrelabmonoidfrac X Y) y). Proof. intros x y. unfold abmonoidfracrel, quotrel, abmonoidfrac_min. rewrite setquotuniv2comm, setquotfun2comm. intros H. generalize (invmap (weqpathsinsetquot _ _ _) H). apply hinhfun. simpl. intros c. exists (pr2 x * pr1 c). rewrite <- Hmin. change (pr1 (pr2 x * pr1 c))%multmonoid with (pr1 (pr2 x) * pr1 (pr1 c))%multmonoid. rewrite <- assocax. refine (pathscomp0 _ _). apply (pr2 c). do 3 rewrite (assocax X) ; apply maponpaths. rewrite commax, assocax. apply maponpaths. apply commax. Qed. Lemma abmonoidfrac_Lle (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : ∏ x y : abmonoidfrac X Y, abmonoidfracrel X Y (ispartbinophrel_Lle X Y lat Hmin) x y <-> Lle (abmonoidfrac_lattice X Y lat Hmin Hmax) x y. Proof. simple refine (setquotuniv2prop _ (λ x y, _ ,, _) _). - apply isapropdirprod ; apply isapropimpl, propproperty. - intros x y. split. + apply abmonoidfrac_Lle_1. + apply abmonoidfrac_Lle_2. Qed. (** *** lattice with a strong order in [abmonoidfrac] *) Section abmonoidfrac_latticewithgt. Context (X : abmonoid) (Y : @submonoid X) (lat : lattice X) (gt : StrongOrder X) (Hnotgtle : ∏ x y : X, ¬ gt x y → Lle lat x y) (Hlenotgt : ∏ x y : X, Lle lat x y → ¬ gt x y) (Hgtmin : ∏ x y z : X, gt x z → gt y z → gt (Lmin lat x y) z) (Hgtmax : ∏ x y z : X, gt z x → gt z y → gt z (Lmax lat x y)) (Hgt : ispartbinophrel Y gt) (Hop : ∏ (x : Y) (y z : X), y * pr1 x = z * pr1 x → y = z) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op). Lemma abmonoidfrac_notgtle : ∏ (x y : abmonoidfrac X Y), ¬ (StrongOrder_abmonoidfrac Y gt Hgt) x y → Lle (abmonoidfrac_lattice X Y lat Hmin Hmax) x y. Proof. simple refine (setquotuniv2prop (eqrelabmonoidfrac X Y) (λ _ _, _ ,, _) _). - apply isapropimpl, propproperty. - intros x y H. apply abmonoidfrac_Lle. unfold abmonoidfracrel, quotrel. rewrite setquotuniv2comm. apply hinhpr. exists (pr2 x). apply Hnotgtle. intros H0 ; apply H. change (abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) x) (setquotpr (eqrelabmonoidfrac X Y) y)). unfold abmonoidfracrel, quotrel. rewrite setquotuniv2comm. apply hinhpr. exists (pr2 x). exact H0. Qed. Lemma abmonoidfrac_lenotgt : ∏ (x y : abmonoidfrac X Y), Lle (abmonoidfrac_lattice X Y lat Hmin Hmax) x y → ¬ (StrongOrder_abmonoidfrac Y gt Hgt) x y. Proof. simple refine (setquotuniv2prop (eqrelabmonoidfrac X Y) (λ _ _, _ ,, _) _). + apply isapropimpl, isapropimpl, isapropempty. + intros x y H. apply (pr2 (abmonoidfrac_Lle _ _ _ _ _ _ _)) in H. change (abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) x) (setquotpr (eqrelabmonoidfrac X Y) y) → ∅). revert H. unfold abmonoidfracrel, quotrel. do 2 rewrite setquotuniv2comm. apply (hinhuniv2 (P := make_hProp _ isapropempty)). intros c c'. refine (Hlenotgt _ _ _ _). 2: apply (pr2 c'). unfold Lle. rewrite <- Hmin. apply (maponpaths (λ x, op x _)). apply (Hop (pr1 c)). rewrite Hmin. apply (pr2 c). Qed. Lemma abmonoidfrac_gtmin : ∏ (x y z : abmonoidfrac X Y), (StrongOrder_abmonoidfrac Y gt Hgt) x z → (StrongOrder_abmonoidfrac Y gt Hgt) y z → (StrongOrder_abmonoidfrac Y gt Hgt) (Lmin (abmonoidfrac_lattice X Y lat Hmin Hmax) x y) z. Proof. simple refine (setquotuniv3prop (eqrelabmonoidfrac X Y) (λ _ _ _, _ ,, _) _). - apply isapropimpl, isapropimpl, propproperty. - intros x y z. change (abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) x) (setquotpr (eqrelabmonoidfrac X Y) z) → abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) y) (setquotpr (eqrelabmonoidfrac X Y) z) → abmonoidfracrel X Y Hgt (abmonoidfrac_min X Y Hmin (setquotpr (eqrelabmonoidfrac X Y) x) (setquotpr (eqrelabmonoidfrac X Y) y)) (setquotpr (eqrelabmonoidfrac X Y) z)). unfold abmonoidfrac_min, abmonoidfracrel, quotrel. rewrite setquotfun2comm ; do 3 rewrite setquotuniv2comm. apply hinhfun2. intros cx cy. unfold abmonoidfrac_lattice_fun. simpl. exists (@op Y (pr1 cx) (pr1 cy)). do 2 rewrite Hmin. apply Hgtmin. + change (gt (pr1 x * pr1 (pr2 y) * pr1 (pr2 z) * (pr1 (pr1 cx) * pr1 (pr1 cy))) (pr1 z * (pr1 (pr2 x) * pr1 (pr2 y)) * (pr1 (pr1 cx) * pr1 (pr1 cy)))). rewrite (assocax X (pr1 x)). rewrite (commax X (pr1 (pr2 y))). rewrite <- (assocax X (pr1 x)), <- (assocax X (pr1 z)). rewrite (assocax X (pr1 x * pr1 (pr2 z))%multmonoid), (assocax X (pr1 z * pr1 (pr2 x))%multmonoid). generalize (commax X (pr1 (pr2 y)) (pr1 (pr1 cx) * pr1 (pr1 cy))). intros ->. do 2 rewrite <- (assocax X (pr1 x * pr1 (pr2 z))%multmonoid), <- (assocax X (pr1 z * pr1 (pr2 x))%multmonoid). apply (pr2 Hgt). apply (pr2 (pr2 y)). apply (pr2 Hgt). apply (pr2 (pr1 cy)). apply (pr2 cx). + change (gt (pr1 y * pr1 (pr2 x) * pr1 (pr2 z) * (pr1 (pr1 cx) * pr1 (pr1 cy))) (pr1 z * (pr1 (pr2 x) * pr1 (pr2 y)) * (pr1 (pr1 cx) * pr1 (pr1 cy)))). rewrite (commax X (pr1 (pr1 cx))). rewrite (assocax X (pr1 y)). do 2 rewrite (commax X (pr1 (pr2 x))). rewrite <- (assocax X (pr1 y)), <- (assocax X (pr1 z)). rewrite (assocax X (pr1 y * pr1 (pr2 z))%multmonoid), (assocax X (pr1 z * pr1 (pr2 y))%multmonoid). rewrite (commax X (pr1 (pr2 x))). do 2 rewrite <- (assocax X (pr1 y * pr1 (pr2 z))%multmonoid), <- (assocax X (pr1 z * pr1 (pr2 y))%multmonoid). apply (pr2 Hgt). apply (pr2 (pr2 x)). apply (pr2 Hgt). apply (pr2 (pr1 cx)). apply (pr2 cy). Qed. Lemma abmonoidfrac_gtmax : ∏ (x y z : abmonoidfrac X Y), (StrongOrder_abmonoidfrac Y gt Hgt) z x → (StrongOrder_abmonoidfrac Y gt Hgt) z y → (StrongOrder_abmonoidfrac Y gt Hgt) z (Lmax (abmonoidfrac_lattice X Y lat Hmin Hmax) x y). Proof. simple refine (setquotuniv3prop (eqrelabmonoidfrac X Y) (λ _ _ _, _ ,, _) _). - apply isapropimpl, isapropimpl, propproperty. - intros x y z. change (abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) z) (setquotpr (eqrelabmonoidfrac X Y) x) → abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) z) (setquotpr (eqrelabmonoidfrac X Y) y) → abmonoidfracrel X Y Hgt (setquotpr (eqrelabmonoidfrac X Y) z) (abmonoidfrac_max X Y Hmax (setquotpr (eqrelabmonoidfrac X Y) x) (setquotpr (eqrelabmonoidfrac X Y) y))). unfold abmonoidfrac_max, abmonoidfracrel, quotrel. rewrite setquotfun2comm ; do 3 rewrite setquotuniv2comm. apply hinhfun2. intros cx cy. unfold abmonoidfrac_lattice_fun. change (∑ c0 : Y, gt (pr1 z * pr1 (pr2 x * pr2 y) * pr1 c0) (Lmax lat (pr1 x * pr1 (pr2 y)) (pr1 y * pr1 (pr2 x)) * pr1 (pr2 z) * pr1 c0)). exists (@op Y (pr1 cx) (pr1 cy)). do 2 rewrite Hmax. apply Hgtmax. + change (gt (pr1 z * (pr1 (pr2 x) * pr1 (pr2 y)) * (pr1 (pr1 cx) * pr1 (pr1 cy))) (pr1 x * pr1 (pr2 y) * pr1 (pr2 z) * (pr1 (pr1 cx) * pr1 (pr1 cy)))). rewrite (assocax X (pr1 x)). rewrite (commax X (pr1 (pr2 y))). rewrite <- (assocax X (pr1 x)), <- (assocax X (pr1 z)). rewrite (assocax X (pr1 x * pr1 (pr2 z))%multmonoid), (assocax X (pr1 z * pr1 (pr2 x))%multmonoid). generalize (commax X (pr1 (pr2 y)) (pr1 (pr1 cx) * pr1 (pr1 cy))). intros ->. do 2 rewrite <- (assocax X (pr1 x * pr1 (pr2 z))%multmonoid), <- (assocax X (pr1 z * pr1 (pr2 x))%multmonoid). apply (pr2 Hgt). apply (pr2 (pr2 y)). apply (pr2 Hgt). apply (pr2 (pr1 cy)). apply (pr2 cx). + change (gt (pr1 z * (pr1 (pr2 x) * pr1 (pr2 y)) * (pr1 (pr1 cx) * pr1 (pr1 cy))) (pr1 y * pr1 (pr2 x) * pr1 (pr2 z) * (pr1 (pr1 cx) * pr1 (pr1 cy)))). rewrite (commax X (pr1 (pr1 cx))). rewrite (assocax X (pr1 y)). do 2 rewrite (commax X (pr1 (pr2 x))). rewrite <- (assocax X (pr1 y)), <- (assocax X (pr1 z)). rewrite (assocax X (pr1 y * pr1 (pr2 z))%multmonoid), (assocax X (pr1 z * pr1 (pr2 y))%multmonoid). rewrite (commax X (pr1 (pr2 x))). do 2 rewrite <- (assocax X (pr1 y * pr1 (pr2 z))%multmonoid), <- (assocax X (pr1 z * pr1 (pr2 y))%multmonoid). apply (pr2 Hgt). apply (pr2 (pr2 x)). apply (pr2 Hgt). apply (pr2 (pr1 cx)). apply (pr2 cy). Qed. End abmonoidfrac_latticewithgt. Definition abmonoidfrac_latticewithgt (X : abmonoid) (Y : @submonoid X) (lat : latticewithgt X) (Hgt : ispartbinophrel Y (Lgt lat)) (Hop : ∏ (x : Y) (y z : X), y * pr1 x = z * pr1 x → y = z) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : latticewithgt (abmonoidfrac X Y). Proof. simple refine (tpair _ _ _). refine (abmonoidfrac_lattice _ _ _ _ _). exact Hmin. exact Hmax. simple refine (tpair _ _ _). simple refine (StrongOrder_abmonoidfrac _ _ _). apply (Lgt lat). apply Hgt. split ; split. - apply abmonoidfrac_notgtle. apply notLgt_Lle. - apply abmonoidfrac_lenotgt. apply Lle_notLgt. apply Hop. - apply abmonoidfrac_gtmin. apply Lmin_Lgt. - apply abmonoidfrac_gtmax. apply Lmax_Lgt. Defined. (** *** lattice with a decidable order in [abmonoidfrac] *) Lemma istotal_Lle_abmonoidfrac {X : abmonoid} (Y : @submonoid X) (lat : lattice X) (is' : istotal (Lle lat)) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : istotal (Lle (abmonoidfrac_lattice X Y lat Hmin Hmax)). Proof. refine (istotallogeqf _ _). - apply abmonoidfrac_Lle. - apply istotalabmonoidfracrel, is'. Qed. Lemma isdecrel_Lle_abmonoidfrac {X : abmonoid} (Y : @submonoid X) (lat : lattice X) (is' : isdecrel (Lle lat)) (Hop : ∏ (x : Y) (y z : X), y * pr1 x = z * pr1 x → y = z) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : isdecrel (Lle (abmonoidfrac_lattice X Y lat Hmin Hmax)). Proof. refine (isdecrellogeqf _ _). - apply abmonoidfrac_Lle. - apply isdecabmonoidfracrel. split. + clear -Hmin Hop. intros x y z Hz ; rewrite !(commax X z) ; unfold Lle ; rewrite <- (Hmin _ _ (z,,Hz)) ; apply Hop. + clear -Hmin Hop. intros x y z Hz ; unfold Lle ; rewrite <- (Hmin _ _ (z,,Hz)) ; apply Hop. + apply is'. Qed. Definition abmonoidfrac_latticedec {X : abmonoid} (Y : @submonoid X) (lat : latticedec X) (Hop : ∏ (x : Y) (y z : X), y * pr1 x = z * pr1 x → y = z) (Hmin : ispartrdistr Y (Lmin lat) op) (Hmax : ispartrdistr Y (Lmax lat) op) : latticedec (abmonoidfrac X Y). Proof. exists (abmonoidfrac_lattice X Y lat Hmin Hmax). split. - apply istotal_Lle_abmonoidfrac. apply istotal_latticedec. - apply isdecrel_Lle_abmonoidfrac. + apply isdecrel_latticedec. + apply Hop. Defined. Close Scope multmonoid. Section hProp_lattice. Definition hProp_lattice : lattice (hProp,,isasethProp). Proof. use make_lattice. - intros P Q; exact (P ∧ Q). - simpl; intros P Q; exact (P ∨ Q). - repeat split. + intros P Q R; apply isassoc_hconj. + intros P Q; apply iscomm_hconj. + intros P Q R; apply isassoc_hdisj. + intros P Q; apply iscomm_hdisj. + intros P Q; apply hconj_absorb_hdisj. + intros P Q; apply hdisj_absorb_hconj. Defined. End hProp_lattice. UniMath-20231010/UniMath/OrderTheory/Posets.v000066400000000000000000000006341451125700300205710ustar00rootroot00000000000000(** This file exports the files about posets in the combinatorics directory. *) Require Export UniMath.OrderTheory.Posets.Basics. Require Export UniMath.OrderTheory.Posets.MonotoneFunctions. Require Export UniMath.OrderTheory.Posets.PosetSum. Require Export UniMath.OrderTheory.Posets.PointedPosets. Require Export UniMath.OrderTheory.Posets.LiftPoset. Require Export UniMath.OrderTheory.Posets.QuotientPoset. UniMath-20231010/UniMath/OrderTheory/Posets/000077500000000000000000000000001451125700300203775ustar00rootroot00000000000000UniMath-20231010/UniMath/OrderTheory/Posets/Basics.v000066400000000000000000000113611451125700300217740ustar00rootroot00000000000000(***************************************************************** Posets In this file, we some basic constructions and theory on posets. Contents 1. Accessors for posets 2. The unit poset 3. The product of posets 4. Type indexed products of posets 5. The equalizer of posets 6. The booleans as partial order 7. Discrete partial orders *****************************************************************) Require Import UniMath.MoreFoundations.All. (** 1. Accessors for posets *) Proposition trans_PartialOrder {X : hSet} (R : PartialOrder X) {x₁ x₂ x₃ : X} (p : R x₁ x₂) (q : R x₂ x₃) : R x₁ x₃. Proof. exact (pr112 R _ _ _ p q). Qed. Proposition refl_PartialOrder {X : hSet} (R : PartialOrder X) (x : X) : R x x. Proof. exact (pr212 R x). Qed. Proposition antisymm_PartialOrder {X : hSet} (R : PartialOrder X) {x y : X} (p : R x y) (q : R y x) : x = y. Proof. exact (pr22 R _ _ p q). Qed. (** 2. The unit poset *) Definition unit_PartialOrder : PartialOrder unitset. Proof. use make_PartialOrder. - exact (λ _ _, htrue). - repeat split. intros x y p q. apply isapropunit. Defined. (** 3. The product of posets *) Section ProdOrder. Context {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂). Let R : hrel (X₁ × X₂)%set := λ x y, R₁ (pr1 x) (pr1 y) ∧ R₂ (pr2 x) (pr2 y). Proposition prod_PartialOrderLaws : isPartialOrder R. Proof. simple refine ((_ ,, _) ,, _). - refine (λ x y z p q, _ ,, _). + exact (trans_PartialOrder R₁ (pr1 p) (pr1 q)). + exact (trans_PartialOrder R₂ (pr2 p) (pr2 q)). - refine (λ x, _ ,, _). + exact (refl_PartialOrder R₁ (pr1 x)). + exact (refl_PartialOrder R₂ (pr2 x)). - refine (λ x y p q, _). use pathsdirprod. + exact (antisymm_PartialOrder R₁ (pr1 p) (pr1 q)). + exact (antisymm_PartialOrder R₂ (pr2 p) (pr2 q)). Qed. Definition prod_PartialOrder : PartialOrder (X₁ × X₂)%set. Proof. use make_PartialOrder. - exact R. - exact prod_PartialOrderLaws. Defined. End ProdOrder. (** 4. Type indexed products of posets *) Definition depfunction_poset {X : UU} (Y : X → hSet) (RY : ∏ (x : X), PartialOrder (Y x)) : PartialOrder (forall_hSet Y). Proof. use make_PartialOrder. - exact (λ f g, ∀ (x : X), RY x (f x) (g x)). - repeat split. + abstract (intros f g h p q x ; exact (trans_PartialOrder (RY x) (p x) (q x))). + abstract (intros f x ; exact (refl_PartialOrder (RY x) (f x))). + abstract (intros f g p q ; use funextsec ; intro x ; exact (antisymm_PartialOrder (RY x) (p x) (q x))). Defined. (** 5. The equalizer of posets *) Section Equalizer. Context {X : hSet} (RX : PartialOrder X) (Y : hSet) (f g : X → Y). Let Eq : hSet := (∑ (x : X), f x = g x) ,, isaset_total2 _ (pr2 X) (λ _, isasetaprop (pr2 Y _ _)). Definition Equalizer_order : PartialOrder Eq. Proof. simple refine (_ ,, ((_ ,, _) ,, _)). - exact (λ x y, RX (pr1 x) (pr1 y)). - abstract (exact (λ x y z p q, trans_PartialOrder RX p q)). - abstract (exact (λ x, refl_PartialOrder RX (pr1 x))). - abstract (intros x y p q ; use subtypePath ; [ intro ; apply (pr2 Y) | ] ; exact (antisymm_PartialOrder RX p q)). Defined. End Equalizer. (** 6. The booleans as partial order *) Definition PartialOrder_boolset : PartialOrder boolset. Proof. use make_PartialOrder. - exact (λ b₁ b₂, if b₁ then if b₂ then htrue else hfalse else htrue). - repeat split. + abstract (intros b₁ b₂ b₃ p q ; induction b₁, b₂, b₃ ; induction p ; induction q ; apply tt). + abstract (intros b ; induction b ; exact tt). + abstract (intros b₁ b₂ p q ; induction b₁, b₂ ; induction p ; induction q ; apply idpath). Defined. (** 7. Discrete partial orders *) Section DiscretePartialOrder. Context (A : hSet). Definition discrete_hrel : hrel A := λ x y, (x = y)%logic. Proposition isPartialOrder_discrete_hrel : isPartialOrder discrete_hrel. Proof. refine ((_ ,, _) ,, _). - intros x y z p q. exact (p @ q). - exact (λ x, idpath _). - exact (λ x y p q, p). Qed. Definition discrete_partial_order : PartialOrder A. Proof. use make_PartialOrder. - exact discrete_hrel. - exact isPartialOrder_discrete_hrel. Defined. End DiscretePartialOrder. UniMath-20231010/UniMath/OrderTheory/Posets/LiftPoset.v000066400000000000000000000101531451125700300224770ustar00rootroot00000000000000(***************************************************************** The lift of a partial order We construct the lifting of partial order (adding a minimum element). We also show that this gives the basic operations that show that this operation is a comonad on pointed partial orders. Note that on not necessarily pointed partial orders, this operation would be a monad. Contents 1. The order on the lift 2. Action on morphisms 3. The comonad structure *****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. (** 1. The order on the lift *) Definition lift_hrel {X : hSet} (PX : hrel X) : hrel (setcoprod X unitset). Proof. intros x₁ x₂. induction x₁ as [ x₁ | ]. - induction x₂ as [ x₂ | ]. + exact (PX x₁ x₂). + exact hfalse. - exact htrue. Defined. Proposition lift_isPartialOrder {X : hSet} (PX : PartialOrder X) : isPartialOrder (lift_hrel PX). Proof. repeat split. - intros [ x₁ | [] ] [ x₂ | [] ] [ x₃ | [] ] p q ; cbn in *. + exact (trans_PartialOrder PX p q). + exact q. + exact (fromempty p). + exact p. + exact tt. + exact tt. + exact tt. + exact tt. - intros [ x | [] ] ; cbn. + exact (refl_PartialOrder PX x). + exact tt. - intros [ x | [] ] [ y | [] ] p q ; cbn in *. + apply maponpaths. exact (antisymm_PartialOrder PX p q). + exact (fromempty p). + exact (fromempty q). + apply idpath. Qed. Definition lift_PartialOrder {X : hSet} (PX : PartialOrder X) : PartialOrder (setcoprod X unitset). Proof. use make_PartialOrder. - exact (lift_hrel PX). - exact (lift_isPartialOrder PX). Defined. Definition lift_pointed_PartialOrder {X : hSet} (PX : PartialOrder X) : pointed_PartialOrder (setcoprod X unitset). Proof. use make_pointed_PartialOrder. - exact (lift_PartialOrder PX). - exact (inr tt). - exact (λ _, tt). Defined. (** 2. Action on morphisms *) Proposition lift_strict_and_monotone_map {X Y : hSet} {f : X → Y} {PX : PartialOrder X} {PY : PartialOrder Y} (Pf : is_monotone PX PY f) : is_strict_and_monotone (lift_pointed_PartialOrder PX) (lift_pointed_PartialOrder PY) (coprodf1 f). Proof. split. - intros [ x | [] ] [ y | [] ] p ; cbn in *. + apply Pf. exact p. + exact p. + exact p. + exact p. - cbn. apply idpath. Qed. (** 3. The comonad structure *) Definition lift_pointed_PartialOrder_extract {X : hSet} (PX : pointed_PartialOrder X) (x : setcoprod X unitset) : X. Proof. induction x as [ x | ]. - exact x. - exact (⊥_{PX}). Defined. Proposition is_strict_and_monotone_lift_pointed_PartialOrder_extract {X : hSet} (PX : pointed_PartialOrder X) : is_strict_and_monotone (lift_pointed_PartialOrder PX) PX (lift_pointed_PartialOrder_extract PX). Proof. split. - intros [ x | [] ] [ y | [] ] p ; cbn in *. + exact p. + exact (fromempty p). + apply pointed_PartialOrder_min_point. + apply refl_PartialOrder. - cbn. apply idpath. Qed. Definition lift_pointed_PartialOrder_dupl {X : hSet} (PX : pointed_PartialOrder X) (x : setcoprod X unitset) : setcoprod (setcoprod X unitset) unitset. Proof. induction x as [ x | ]. - exact (inl (inl x)). - exact (inr tt). Defined. Proposition is_strict_and_monotone_lift_pointed_PartialOrder_dupl {X : hSet} (PX : pointed_PartialOrder X) : is_strict_and_monotone (lift_pointed_PartialOrder PX) (lift_pointed_PartialOrder (lift_pointed_PartialOrder PX)) (lift_pointed_PartialOrder_dupl PX). Proof. split. - intros [ x | [] ] [ y | [] ] p ; cbn in *. + exact p. + exact (fromempty p). + exact tt. + exact tt. - cbn. apply idpath. Qed. UniMath-20231010/UniMath/OrderTheory/Posets/MonotoneFunctions.v000066400000000000000000000225061451125700300242620ustar00rootroot00000000000000(***************************************************************** Monotone functions between posets We define the notion of monotone function and we give some basic examples of them Contents 1. Monotone functions 2. Equality of posets via monotone functions 3. Examples of monotone functions 4. The poset of monotone functions *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. (** 1. Monotone functions *) Definition is_monotone {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) (f : X₁ → X₂) : UU := ∏ (x₁ x₂ : X₁), R₁ x₁ x₂ → R₂ (f x₁) (f x₂). Proposition isaprop_is_monotone {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) (f : X₁ → X₂) : isaprop (is_monotone R₁ R₂ f). Proof. repeat (use impred ; intro). apply (pr1 R₂). Qed. Definition monotone_function {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : UU := ∑ (f : X₁ → X₂), is_monotone R₁ R₂ f. Definition monotone_function_to_function {X₁ X₂ : hSet} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} (f : monotone_function R₁ R₂) : X₁ → X₂ := pr1 f. Coercion monotone_function_to_function : monotone_function >-> Funclass. Proposition eq_monotone_function {X₁ X₂ : hSet} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} (f g : monotone_function R₁ R₂) (p : ∏ (x : X₁), f x = g x) : f = g. Proof. use subtypePath. { intro. apply isaprop_is_monotone. } use funextsec. exact p. Qed. Definition monotone_function_hSet {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : hSet. Proof. use make_hSet. - exact (monotone_function R₁ R₂). - use isaset_total2. + use funspace_isaset. exact (pr2 X₂). + intro f. apply isasetaprop. apply isaprop_is_monotone. Defined. (** 2. Equality of posets via monotone functions *) Proposition eq_PartialOrder {X : hSet} {PX PX' : PartialOrder X} (p : is_monotone PX PX' (λ x, x)) (q : is_monotone PX' PX (λ x, x)) : PX = PX'. Proof. use subtypePath. { intro. apply isaprop_isPartialOrder. } use funextsec ; intro. use funextsec ; intro. use weqtopathshProp. use weqimplimpl. - apply p. - apply q. - apply (pr1 PX). - apply (pr1 PX'). Defined. (** 3. Examples of monotone functions *) Proposition idfun_is_monotone {X : hSet} (R : PartialOrder X) : is_monotone R R (idfun X). Proof. exact (λ x₁ x₂ p, p). Qed. Definition id_monotone_function {X : hSet} (R : PartialOrder X) : monotone_function R R := _ ,, idfun_is_monotone R. Proposition comp_is_monotone {X₁ X₂ X₃ : hSet} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} {R₃ : PartialOrder X₃} {f : X₁ → X₂} {g : X₂ → X₃} (Hf : is_monotone R₁ R₂ f) (Hg : is_monotone R₂ R₃ g) : is_monotone R₁ R₃ (λ z, g(f z)). Proof. exact (λ x₁ x₂ p, Hg _ _ (Hf _ _ p)). Qed. Definition comp_monotone_function {X₁ X₂ X₃ : hSet} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} {R₃ : PartialOrder X₃} (f : monotone_function R₁ R₂) (g : monotone_function R₂ R₃) : monotone_function R₁ R₃ := _ ,, comp_is_monotone (pr2 f) (pr2 g). Proposition dirprod_pr1_is_monotone {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : is_monotone (prod_PartialOrder R₁ R₂) R₁ pr1. Proof. exact (λ x₁ x₂ p, pr1 p). Qed. Definition pr1_monotone_function {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : monotone_function (prod_PartialOrder R₁ R₂) R₁ := _ ,, dirprod_pr1_is_monotone R₁ R₂. Proposition dirprod_pr2_is_monotone {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : is_monotone (prod_PartialOrder R₁ R₂) R₂ pr2. Proof. exact (λ x₁ x₂ p, pr2 p). Qed. Definition pr2_monotone_function {X₁ X₂ : hSet} (R₁ : PartialOrder X₁) (R₂ : PartialOrder X₂) : monotone_function (prod_PartialOrder R₁ R₂) R₂ := _ ,, dirprod_pr2_is_monotone R₁ R₂. Proposition prodtofun_is_monotone {W X₁ X₂ : hSet} {RW : PartialOrder W} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} {f : W → X₁} {g : W → X₂} (Hf : is_monotone RW R₁ f) (Hg : is_monotone RW R₂ g) : is_monotone RW (prod_PartialOrder R₁ R₂) (prodtofuntoprod (f,, g)). Proof. exact (λ x y p, Hf _ _ p ,, Hg _ _ p). Qed. Definition prodtofun_monotone_function {W X₁ X₂ : hSet} {RW : PartialOrder W} {R₁ : PartialOrder X₁} {R₂ : PartialOrder X₂} (f : monotone_function RW R₁) (g : monotone_function RW R₂) : monotone_function RW (prod_PartialOrder R₁ R₂) := _ ,, prodtofun_is_monotone (pr2 f) (pr2 g). Proposition Equalizer_pr1_monotone {X : hSet} (RX : PartialOrder X) (Y : hSet) (f g : X → Y) : is_monotone (Equalizer_order RX Y f g) RX (λ z, pr1 z). Proof. intros x y p. exact p. Qed. Definition Equalizer_monotone_function {X Y : hSet} (RX : PartialOrder X) (RY : PartialOrder Y) (f g : X → Y) : monotone_function (Equalizer_order RX Y f g) RX := (λ z, pr1 z) ,, Equalizer_pr1_monotone RX Y f g. Proposition Equalizer_map_monotone {X : hSet} (RX : PartialOrder X) (Y : hSet) (f g : X → Y) {W : hSet} (RW : PartialOrder W) {h : W → X} (Rh : is_monotone RW RX h) (p : ∏ (w : W), f(h w) = g(h w)) : is_monotone RW (Equalizer_order RX Y f g) (λ w, h w ,, p w). Proof. intros w₁ w₂ q. apply Rh. exact q. Qed. Proposition is_monotone_depfunction_poset_pr {X : UU} (Y : X → hSet) (RY : ∏ (x : X), PartialOrder (Y x)) (x : X) : is_monotone (depfunction_poset Y RY) (RY x) (λ f, f x). Proof. intros f g p. exact (p x). Qed. Proposition is_monotone_depfunction_poset_pair {W : hSet} {X : UU} {Y : X → hSet} {RW : PartialOrder W} {RY : ∏ (x : X), PartialOrder (Y x)} (fs : ∏ (x : X), W → Y x) (Hfs : ∏ (x : X), is_monotone RW (RY x) (fs x)) : is_monotone RW (depfunction_poset Y RY) (λ w x, fs x w). Proof. intros w₁ w₂ p x. exact (Hfs x _ _ p). Qed. (** 4. The poset of monotone functions *) Section FunctionOrder. Context {X Y : hSet} (RX : PartialOrder X) (RY : PartialOrder Y). Definition monotone_function_order : hrel (monotone_function_hSet RX RY). Proof. intros f g ; cbn in *. use make_hProp. - exact (∏ (x : X), RY (f x) (g x)). - abstract (use impred ; intro ; apply (pr1 RY)). Defined. Proposition monotone_function_isPartialOrder : isPartialOrder monotone_function_order. Proof. simple refine ((_ ,, _) ,, _). - exact (λ f g h p q x, trans_PartialOrder RY (p x) (q x)). - exact (λ f x, refl_PartialOrder RY (pr1 f x)). - intros f g p q. use eq_monotone_function. intro x. exact (antisymm_PartialOrder RY (p x) (q x)). Qed. Definition monotone_function_PartialOrder : PartialOrder (monotone_function_hSet RX RY). Proof. use make_PartialOrder. - exact monotone_function_order. - exact monotone_function_isPartialOrder. Defined. Definition eval_monotone_function : monotone_function (prod_PartialOrder RX monotone_function_PartialOrder) RY. Proof. simple refine (_ ,, _) ; cbn. - exact (λ xf, pr2 xf (pr1 xf)). - abstract (intros xf yg pq ; induction xf as [ x f ] ; induction yg as [ y g ] ; induction pq as [ p q ] ; cbn in * ; exact (trans_PartialOrder RY (q x) (pr2 g x y p))). Defined. Definition lam_monotone_function {Z : hSet} {RZ : PartialOrder Z} (f : monotone_function (prod_PartialOrder RX RZ) RY) : monotone_function RZ monotone_function_PartialOrder. Proof. simple refine (_ ,, _) ; cbn. - intro z. simple refine (_ ,, _). + exact (λ x, f (x ,, z)). + abstract (intros x₁ x₂ p ; apply f ; cbn ; refine (p ,, _) ; apply refl_PartialOrder). - abstract (intros z₁ z₂ p x ; cbn ; apply f ; cbn ; exact (refl_PartialOrder RX x ,, p)). Defined. End FunctionOrder. UniMath-20231010/UniMath/OrderTheory/Posets/PointedPosets.v000066400000000000000000000325001451125700300233660ustar00rootroot00000000000000(***************************************************************** Pointed posets We look at posets with a bottom element. This bottom element can either be part of the structure or it can be required to only merely exist. Contents 1. Pointed posets 2. Basic constructions on pointed posets 3. Strict and monotone functions 4. Equality of pointed posets 5. Examples of strict and monotone functions 6. The equalizer of pointed posets 7. Type indexed products of pointed posets 8. Function spaces of pointed posets *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. (** 1. Pointed posets *) Definition bottom_element {X : hSet} (RX : PartialOrder X) : UU := ∑ (x : X), ∏ (y : X), RX x y. Proposition bottom_element_eq {X : hSet} (RX : PartialOrder X) (b₁ b₂ : bottom_element RX) : b₁ = b₂. Proof. use subtypePath. { intro. use impred ; intro. apply propproperty. } use (antisymm_PartialOrder RX). - apply b₁. - apply b₂. Qed. Proposition isaprop_bottom_element {X : hSet} (RX : PartialOrder X) : isaprop (bottom_element RX). Proof. use invproofirrelevance. exact (bottom_element_eq RX). Qed. Definition pointed_PartialOrder (X : hSet) : UU := ∑ (RX : PartialOrder X), bottom_element RX. Definition make_pointed_PartialOrder {X : hSet} (RX : PartialOrder X) (x : X) (p : ∏ (y : X), RX x y) : pointed_PartialOrder X := RX ,, x ,, p. Coercion pointed_PartialOrder_to_Partial_order {X : hSet} (RX : pointed_PartialOrder X) : PartialOrder X := pr1 RX. Definition pointed_PartialOrder_to_point {X : hSet} (RX : pointed_PartialOrder X) : X := pr12 RX. Notation "⊥_{ RX }" := (pointed_PartialOrder_to_point RX). Proposition pointed_PartialOrder_min_point {X : hSet} (RX : pointed_PartialOrder X) (y : X) : RX ⊥_{RX} y. Proof. exact (pr22 RX y). Qed. (** 2. Basic constructions on pointed posets *) Definition unit_pointed_PartialOrder : pointed_PartialOrder unitset. Proof. use make_pointed_PartialOrder. - exact unit_PartialOrder. - exact tt. - exact (λ _, tt). Defined. Definition prod_pointed_PartialOrder {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) : pointed_PartialOrder (X × Y)%set. Proof. use make_pointed_PartialOrder. - exact (prod_PartialOrder RX RY). - exact (⊥_{RX} ,, ⊥_{RY}). - intro y. refine (_ ,, _). + apply pointed_PartialOrder_min_point. + apply pointed_PartialOrder_min_point. Defined. Definition bottom_PartialOrder_boolset : bottom_element PartialOrder_boolset. Proof. refine (false ,, _). abstract (intro b ; induction b ; cbn ; exact tt). Defined. Definition pointed_PartialOrder_boolset : pointed_PartialOrder boolset := PartialOrder_boolset ,, bottom_PartialOrder_boolset. (** 3. Strict and monotone functions *) Definition is_strict_and_monotone {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) (f : X → Y) : UU := is_monotone RX RY f × f ⊥_{RX} = ⊥_{RY}. Coercion is_strict_and_monotone_function_to_is_monotone {X Y : hSet} {RX : pointed_PartialOrder X} {RY : pointed_PartialOrder Y} {f : X → Y} (Hf : is_strict_and_monotone RX RY f) : is_monotone RX RY f := pr1 Hf. Definition strict_function_on_point {X Y : hSet} {RX : pointed_PartialOrder X} {RY : pointed_PartialOrder Y} {f : X → Y} (Hf : is_strict_and_monotone RX RY f) : f ⊥_{RX} = ⊥_{RY} := pr2 Hf. Proposition isaprop_is_strict_and_monotone {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) (f : X → Y) : isaprop (is_strict_and_monotone RX RY f). Proof. apply isapropdirprod. - apply isaprop_is_monotone. - apply setproperty. Qed. Definition strict_and_monotone_function {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) : UU := ∑ (f : X → Y), is_strict_and_monotone RX RY f. Definition strict_and_monotone_function_set {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) : hSet. Proof. use make_hSet. - exact (strict_and_monotone_function RX RY). - abstract (use isaset_total2 ; [ use funspace_isaset ; apply Y | intro f ; apply isasetaprop ; apply isaprop_is_strict_and_monotone ]). Defined. Definition strict_and_monotone_function_to_fun {X Y : hSet} {RX : pointed_PartialOrder X} {RY : pointed_PartialOrder Y} (f : strict_and_monotone_function RX RY) : X → Y := pr1 f. Coercion strict_and_monotone_function_to_fun : strict_and_monotone_function >-> Funclass. Proposition eq_strict_and_monotone_function {X Y : hSet} {RX : pointed_PartialOrder X} {RY : pointed_PartialOrder Y} {f g : strict_and_monotone_function RX RY} (p : ∏ (x : X), f x = g x) : f = g. Proof. use subtypePath ; [ intro ; apply isaprop_is_strict_and_monotone | ]. use funextsec. exact p. Qed. (** 4. Equality of pointed posets *) Proposition transportf_bottom_element {X : hSet} {PX PX' : PartialOrder X} (p : PX = PX') (x : bottom_element PX) : pr1 (transportf bottom_element p x) = pr1 x. Proof. induction p ; cbn. apply idpath. Qed. Proposition eq_pointed_PartialOrder_monotone {X : hSet} {PX PX' : pointed_PartialOrder X} (p : is_monotone PX PX' (λ x, x)) (q : is_monotone PX' PX (λ x, x)) : PX = PX'. Proof. use subtypePath. { intro. apply isaprop_bottom_element. } use eq_PartialOrder. - apply p. - apply q. Qed. Proposition eq_pointed_PartialOrder_strict_and_monotone {X : hSet} {PX PX' : pointed_PartialOrder X} (p : is_strict_and_monotone PX PX' (λ x, x)) (q : is_strict_and_monotone PX' PX (λ x, x)) : PX = PX'. Proof. use eq_pointed_PartialOrder_monotone. - apply p. - apply q. Qed. (** 5. Examples of strict and monotone functions *) Proposition idfun_is_strict_and_monotone {X : hSet} (RX : pointed_PartialOrder X) : is_strict_and_monotone RX RX (idfun X). Proof. split. - apply idfun_is_monotone. - apply idpath. Qed. Proposition comp_is_strict_and_monotone {X₁ X₂ X₃ : hSet} {R₁ : pointed_PartialOrder X₁} {R₂ : pointed_PartialOrder X₂} {R₃ : pointed_PartialOrder X₃} {f : X₁ → X₂} {g : X₂ → X₃} (Hf : is_strict_and_monotone R₁ R₂ f) (Hg : is_strict_and_monotone R₂ R₃ g) : is_strict_and_monotone R₁ R₃ (λ z, g(f z)). Proof. split. - exact (comp_is_monotone (pr1 Hf) (pr1 Hg)). - rewrite (strict_function_on_point Hf). rewrite (strict_function_on_point Hg). apply idpath. Qed. Proposition dirprod_pr1_is_strict_and_monotone {X₁ X₂ : hSet} (R₁ : pointed_PartialOrder X₁) (R₂ : pointed_PartialOrder X₂) : is_strict_and_monotone (prod_pointed_PartialOrder R₁ R₂) R₁ dirprod_pr1. Proof. split. - apply dirprod_pr1_is_monotone. - apply idpath. Qed. Proposition dirprod_pr2_is_strict_and_monotone {X₁ X₂ : hSet} (R₁ : pointed_PartialOrder X₁) (R₂ : pointed_PartialOrder X₂) : is_strict_and_monotone (prod_pointed_PartialOrder R₁ R₂) R₂ dirprod_pr2. Proof. split. - apply dirprod_pr2_is_monotone. - apply idpath. Qed. Proposition prodtofun_is_strict_and_monotone {W X₁ X₂ : hSet} {RW : pointed_PartialOrder W} {R₁ : pointed_PartialOrder X₁} {R₂ : pointed_PartialOrder X₂} {f : W → X₁} {g : W → X₂} (Hf : is_strict_and_monotone RW R₁ f) (Hg : is_strict_and_monotone RW R₂ g) : is_strict_and_monotone RW (prod_pointed_PartialOrder R₁ R₂) (prodtofuntoprod (f,, g)). Proof. split. - exact (prodtofun_is_monotone Hf Hg). - use pathsdirprod ; cbn. + exact (strict_function_on_point Hf). + exact (strict_function_on_point Hg). Qed. Proposition constant_is_strict_and_monotone {X : hSet} {Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y) : is_strict_and_monotone RX RY (λ _, ⊥_{RY}). Proof. split. - intros ? ? p. apply refl_PartialOrder. - apply idpath. Qed. (** 6. The equalizer of pointed posets *) Section Equalizer. Context {X Y : hSet} {RX : pointed_PartialOrder X} {RY : pointed_PartialOrder Y} {f g : X → Y} (Hf : is_strict_and_monotone RX RY f) (Hg : is_strict_and_monotone RX RY g). Let Eq : hSet := (∑ (x : X), f x = g x) ,, isaset_total2 _ (pr2 X) (λ _, isasetaprop (pr2 Y _ _)). Definition Equalizer_pointed_PartialOrder : pointed_PartialOrder Eq. Proof. use make_pointed_PartialOrder. - exact (Equalizer_order RX Y f g). - refine (⊥_{RX} ,, _). abstract (rewrite (strict_function_on_point Hf) ; rewrite (strict_function_on_point Hg) ; apply idpath). - intros x. apply pointed_PartialOrder_min_point. Defined. Proposition Equalizer_pr1_strict_and_monotone : is_strict_and_monotone Equalizer_pointed_PartialOrder RX (λ z, pr1 z). Proof. split. - apply Equalizer_pr1_monotone. - apply idpath. Qed. Proposition Equalizer_map_strict_and_monotone {W : hSet} (RW : pointed_PartialOrder W) {h : W → X} (Rh : is_strict_and_monotone RW RX h) (p : ∏ (w : W), f(h w) = g(h w)) : is_strict_and_monotone RW Equalizer_pointed_PartialOrder (λ w, h w ,, p w). Proof. split. - apply Equalizer_map_monotone. exact Rh. - use subtypePath. { intro. apply setproperty. } cbn. apply (strict_function_on_point Rh). Qed. End Equalizer. (** 7. Type indexed products of pointed posets *) Definition depfunction_pointed_poset {X : UU} (Y : X → hSet) (RY : ∏ (x : X), pointed_PartialOrder (Y x)) : pointed_PartialOrder (forall_hSet Y). Proof. use make_pointed_PartialOrder. - exact (depfunction_poset Y RY). - exact (λ x, ⊥_{RY x}). - intros y x. apply pointed_PartialOrder_min_point. Defined. Proposition is_strict_and_monotone_depfunction_pointed_poset_pr {X : UU} (Y : X → hSet) (RY : ∏ (x : X), pointed_PartialOrder (Y x)) (x : X) : is_strict_and_monotone (depfunction_pointed_poset Y RY) (RY x) (λ f, f x). Proof. split. - apply (is_monotone_depfunction_poset_pr Y). - apply idpath. Qed. Proposition is_strict_and_monotone_depfunction_pointed_poset_pair {W : hSet} {X : UU} {Y : X → hSet} {RW : pointed_PartialOrder W} {RY : ∏ (x : X), pointed_PartialOrder (Y x)} (fs : ∏ (x : X), W → Y x) (Hfs : ∏ (x : X), is_strict_and_monotone RW (RY x) (fs x)) : is_strict_and_monotone RW (depfunction_pointed_poset Y RY) (λ w x, fs x w). Proof. split. - apply is_monotone_depfunction_poset_pair. intro x. exact (Hfs x). - use funextsec. intro x ; cbn. apply (strict_function_on_point (Hfs x)). Qed. (** 8. Function spaces of pointed posets *) Section FunctionPoset. Context {X Y : hSet} (PX : pointed_PartialOrder X) (PY : pointed_PartialOrder Y). Definition strict_and_monotone_PartialOrder : PartialOrder (strict_and_monotone_function_set PX PY). Proof. simple refine (_ ,, _) ; cbn. - exact (λ f g, ∀ (x : X), PY (f x) (g x)). - refine ((_ ,, _) ,, _). + abstract (intros f g h p q x ; exact (trans_PartialOrder PY (p x) (q x))). + abstract (intros f x ; exact (refl_PartialOrder PY (f x))). + abstract (intros f g p q ; use eq_strict_and_monotone_function ; intro x ; exact (antisymm_PartialOrder PY (p x) (q x))). Defined. Definition strict_and_monotone_PartialOrder_bottom : bottom_element strict_and_monotone_PartialOrder. Proof. refine ((_ ,, constant_is_strict_and_monotone PX PY) ,, _). abstract (intros f x ; cbn ; apply (pr2 PY)). Defined. Definition strict_and_monotone_pointed_PartialOrder : pointed_PartialOrder (strict_and_monotone_function_set PX PY) := strict_and_monotone_PartialOrder ,, strict_and_monotone_PartialOrder_bottom. End FunctionPoset. UniMath-20231010/UniMath/OrderTheory/Posets/PosetSum.v000066400000000000000000000144241451125700300223520ustar00rootroot00000000000000(**************************************************************** Coproducts of partial orders We construct coproducts of partial orders, and we show that the inclusion functions are monotone. In addition, we show that the map coming from the universal property is monotone. We consider both the case of binary coproducts and set-indexed coproducts. Contents 1. Coproduct of partial orders 2. Monotonicity of inclusion 3. The sum of monotone maps is monotone 4. Set indexed coproducts of partial order 5. Monotonicity of the set-indexed inclusion 6. The set-indexed sum of monotope maps is monotone ****************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Section CoproductOfPartialOrder. Context {X Y : hSet} (PX : PartialOrder X) (PY : PartialOrder Y). (** 1. Coproduct of partial orders *) Definition coproduct_hrel : hrel (setcoprod X Y). Proof. intros xy₁ xy₂. induction xy₁ as [ x₁ | y₁ ] ; induction xy₂ as [ x₂ | y₂ ]. - exact (PX x₁ x₂). - exact hfalse. - exact hfalse. - exact (PY y₁ y₂). Defined. Proposition isPartialOrder_coproduct_hrel : isPartialOrder coproduct_hrel. Proof. repeat split. - intros xy₁ xy₂ xy₃ p q. induction xy₁ as [ x₁ | y₁ ] ; induction xy₂ as [ x₂ | y₂ ] ; induction xy₃ as [ x₃ | y₃ ] ; cbn ; cbn in p, q ; try (apply (fromempty p)) ; try (apply (fromempty q)). + exact (trans_PartialOrder PX p q). + exact (trans_PartialOrder PY p q). - intros xy ; induction xy as [ x | y ] ; cbn. + exact (refl_PartialOrder PX x). + exact (refl_PartialOrder PY y). - intros xy₁ xy₂ p q. induction xy₁ as [ x₁ | y₁ ] ; induction xy₂ as [ x₂ | y₂ ] ; cbn in p, q ; try (apply (fromempty p)) ; try (apply (fromempty q)). + exact (maponpaths inl (antisymm_PartialOrder PX p q)). + exact (maponpaths inr (antisymm_PartialOrder PY p q)). Qed. Definition coproduct_PartialOrder : PartialOrder (setcoprod X Y). Proof. use make_PartialOrder. - exact coproduct_hrel. - exact isPartialOrder_coproduct_hrel. Defined. (** 2. Monotonicity of inclusion *) Definition is_monotone_inl : is_monotone PX coproduct_PartialOrder inl. Proof. intros x₁ x₂ p. exact p. Qed. Definition inl_monotone_function : monotone_function PX coproduct_PartialOrder := _ ,, is_monotone_inl. Definition is_monotone_inr : is_monotone PY coproduct_PartialOrder inr. Proof. intros x₁ x₂ p. exact p. Qed. Definition inr_monotone_function : monotone_function PY coproduct_PartialOrder := _ ,, is_monotone_inr. (** 3. The sum of monotone maps is monotone *) Definition is_monotone_sumofmaps {Z : hSet} {PZ : PartialOrder Z} {f : X → Z} (Pf : is_monotone PX PZ f) {g : Y → Z} (Pg : is_monotone PY PZ g) : is_monotone coproduct_PartialOrder PZ (sumofmaps f g). Proof. intros xy₁ xy₂ p. induction xy₁ as [ x₁ | y₁ ] ; induction xy₂ as [ x₂ | y₂ ] ; cbn in *. - apply Pf. exact p. - apply fromempty. exact p. - apply fromempty. exact p. - apply Pg. exact p. Qed. End CoproductOfPartialOrder. Section CoproductOfPartialOrder. Context {X : hSet} (Y : X → hSet) (PY : ∏ (x : X), PartialOrder (Y x)). (** 4. Set indexed coproducts of partial order *) Definition set_coproduct_hrel : hrel (∑ (x : X), Y x)%set := λ xy₁ xy₂, let x₁ := pr1 xy₁ in let x₂ := pr1 xy₂ in let y₁ := pr2 xy₁ in let y₂ := pr2 xy₂ in (∑ (p : eqset x₁ x₂), PY x₂ (transportf Y p y₁) y₂)%prop. Proposition isPartialOrder_set_coproduct_hrel : isPartialOrder set_coproduct_hrel. Proof. repeat split. - intros xy₁ xy₂ xy₃ pq₁ pq₂. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. induction xy₃ as [ x₃ y₃ ]. induction pq₁ as [ p₁ q₁ ]. induction pq₂ as [ p₂ q₂ ]. cbn in *. induction p₁, p₂ ; cbn in *. refine (idpath _ ,, _) ; cbn. exact (trans_PartialOrder (PY _) q₁ q₂). - intros xy. induction xy as [ x y ] ; cbn. refine (idpath _ ,, _). exact (refl_PartialOrder (PY x) y). - intros xy₁ xy₂ pq₁ pq₂. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. induction pq₁ as [ p₁ q₁ ]. induction pq₂ as [ p₂ q₂ ]. cbn in *. induction p₁ ; cbn in *. assert (p₂ = idpath _) as r. { apply setproperty. } rewrite r in q₂ ; clear p₂ r. cbn in q₂. apply maponpaths. exact (antisymm_PartialOrder (PY _) q₁ q₂). Qed. Definition coproduct_set_PartialOrder : PartialOrder (∑ (x : X), Y x)%set. Proof. use make_PartialOrder. - exact set_coproduct_hrel. - exact isPartialOrder_set_coproduct_hrel. Defined. (** 5. Monotonicity of the set-indexed inclusion *) Definition is_monotone_set_in (x : X) : is_monotone (PY x) coproduct_set_PartialOrder (λ (y : Y x), x ,, y). Proof. intros x₁ x₂ p ; cbn. exact (idpath _ ,, p). Qed. Definition set_in_monotone_function (x : X) : monotone_function (PY x) coproduct_set_PartialOrder := _ ,, is_monotone_set_in x. (** 6. The set-indexed sum of monotope maps is monotone *) Definition is_monotone_set_coproduct_map {Z : hSet} {PZ : PartialOrder Z} {f : ∏ (x : X), Y x → Z} (Pf : ∏ (x : X), is_monotone (PY x) PZ (f x)) : is_monotone coproduct_set_PartialOrder PZ (λ xy, f (pr1 xy) (pr2 xy)). Proof. intros xy₁ xy₂ p. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. induction p as [ p q ]. cbn in *. induction p. cbn in q. apply Pf. exact q. Qed. End CoproductOfPartialOrder. UniMath-20231010/UniMath/OrderTheory/Posets/QuotientPoset.v000066400000000000000000000320621451125700300234140ustar00rootroot00000000000000(***************************************************************** Quotients of posets If we have a poset and a downward closed set in that poset, then we can collapse that subset (i.e., identify all its elements) and acquire a new poset. Contents 1. Downward closed sets 2. The quotient of posets 3. Lower set for smash product 4. Quotients of posets *****************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets.Basics. Require Import UniMath.OrderTheory.Posets.MonotoneFunctions. Require Import UniMath.OrderTheory.Posets.PointedPosets. (** 1. Downward closed sets *) Definition downward_closed {X : hSet} (RX : PartialOrder X) (I : X → hProp) : UU := ∏ (x₁ x₂ : X), RX x₁ x₂ → I x₂ → I x₁. (** 2. The quotient of posets *) Section PosetQuotientLowerSet. Context {X : hSet} (RX : PartialOrder X) (I : X → hProp) (I_down : downward_closed RX I). Definition downward_closed_to_hrel : hrel X := λ x₁ x₂, eqset x₁ x₂ ∨ I x₁ ∧ I x₂. Proposition iseqrel_downward_closed_to_hrel : iseqrel downward_closed_to_hrel. Proof. refine ((_ ,, _) ,, _). - intros x₁ x₂ x₃. use factor_through_squash. { use impred ; intro. apply propproperty. } intros p₁. use factor_through_squash. { apply propproperty. } intros p₂. apply hinhpr. induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ] ; cbn in *. + exact (inl (p₁ @ p₂)). + induction p₁. exact (inr p₂). + induction p₂. exact (inr p₁). + exact (inr (pr1 p₁ ,, pr2 p₂)). - intros x ; cbn in *. exact (hinhpr (inl (idpath x))). - intros x₁ x₂. use factor_through_squash. { apply propproperty. } intros p. apply hinhpr. induction p as [ p | p ] ; cbn in *. + exact (inl (!p)). + exact (inr (pr2 p ,, pr1 p)). Qed. Definition downward_closed_to_eqrel : eqrel X. Proof. use make_eqrel. - exact downward_closed_to_hrel. - exact iseqrel_downward_closed_to_hrel. Defined. Local Definition quotient_lower_set_order_on_el : hrel X := λ x₁ x₂, I x₁ ∨ RX x₁ x₂. Proposition quotient_lower_set_order_on_el_comprel : iscomprelrel downward_closed_to_eqrel quotient_lower_set_order_on_el. Proof. intros x₁ x₂ y₁ y₂. use factor_through_squash. { use impred ; intro. apply hProp_set. } intros p₁. use factor_through_squash. { apply hProp_set. } intros p₂. induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ] ; use hPropUnivalence ; (use factor_through_squash ; [ apply propproperty | ]) ; cbn in * ; intro q ; apply hinhpr. - induction p₁, p₂. exact q. - induction p₁, p₂. exact q. - induction p₁. destruct q as [ q | q ]. + exact (inl q). + refine (inl _). exact (I_down x₁ y₁ q (pr1 p₂)). - induction p₁. induction q as [ q | q ]. + exact (inl q). + refine (inl _). exact (I_down x₁ y₂ q (pr2 p₂)). - exact (inl (pr2 p₁)). - exact (inl (pr1 p₁)). - exact (inl (pr2 p₁)). - exact (inl (pr1 p₁)). Qed. Definition quotient_lower_set_order : hrel (setquotinset downward_closed_to_eqrel). Proof. use quotrel. - exact quotient_lower_set_order_on_el. - exact quotient_lower_set_order_on_el_comprel. Defined. Proposition istrans_quotient_lower_set_order : istrans quotient_lower_set_order. Proof. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₁. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₂. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₃. use factor_through_squash. { repeat (use impred ; intro). apply propproperty. } intro p₁. use factor_through_squash. { repeat (use impred ; intro). apply propproperty. } intro p₂. cbn in *. apply hinhpr. induction p₁ as [ p₁ | p₁ ]. - exact (inl p₁). - induction p₂ as [ p₂ | p₂ ]. + apply inl. exact (I_down x₁ x₂ p₁ p₂). + apply inr. exact (trans_PartialOrder RX p₁ p₂). Qed. Proposition isrefl_quotient_lower_set_order : isrefl quotient_lower_set_order. Proof. use setquotunivprop. intro x ; cbn in *. apply hinhpr. exact (inr (refl_PartialOrder RX x)). Qed. Proposition isantisymm_quotient_lower_set_order : isantisymm quotient_lower_set_order. Proof. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply setproperty. } intros x₁. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply setproperty. } intros x₂. use factor_through_squash. { repeat (use impred ; intro). apply setproperty. } intro p₁. use factor_through_squash. { apply setproperty. } intro p₂. use iscompsetquotpr ; cbn in *. apply hinhpr. induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ]. - exact (inr (p₁ ,, p₂)). - refine (inr (p₁ ,, _)). exact (I_down x₂ x₁ p₂ p₁). - refine (inr (_ ,, _)). + exact (I_down x₁ x₂ p₁ p₂). + exact p₂. - apply inl. exact (antisymm_PartialOrder RX p₁ p₂). Qed. Definition quotient_lower_set : PartialOrder (setquotinset downward_closed_to_eqrel). Proof. use make_PartialOrder. - exact quotient_lower_set_order. - refine ((_ ,, _) ,, _). + exact istrans_quotient_lower_set_order. + exact isrefl_quotient_lower_set_order. + exact isantisymm_quotient_lower_set_order. Defined. Proposition is_monotone_lower_set_setquot_pr : is_monotone RX quotient_lower_set (setquotpr _). Proof. intros x₁ x₂ p. apply hinhpr ; cbn. exact (inr p). Qed. Definition quotient_lower_set_bottom (pX : bottom_element RX) : bottom_element quotient_lower_set. Proof. simple refine (_ ,, _). - exact (setquotpr _ (pr1 pX)). - abstract (use setquotunivprop' ; [ intro ; apply propproperty | ] ; intro y ; exact (hinhpr (inr (pr2 pX y)))). Defined. End PosetQuotientLowerSet. Definition pointed_quotient_lower_set {X : hSet} (RX : pointed_PartialOrder X) (I : X → hProp) (I_down : downward_closed RX I) : pointed_PartialOrder (setquotinset (downward_closed_to_eqrel I)) := quotient_lower_set RX I I_down ,, quotient_lower_set_bottom _ _ _ (pr2 RX). (** 3. Lower set for smash product *) Section SmashLowerSet. Context {X Y : hSet} (RX : pointed_PartialOrder X) (RY : pointed_PartialOrder Y). Definition smash_set : X × Y → hProp := λ xy, pr1 xy = ⊥_{RX} ∨ pr2 xy = ⊥_{RY}. Definition smash_set_downward_closd : downward_closed (prod_pointed_PartialOrder RX RY) smash_set. Proof. intros xy₁ xy₂ p. induction xy₁ as [ x₁ y₁ ]. induction xy₂ as [ x₂ y₂ ]. induction p as [ p₁ p₂ ]. use factor_through_squash. { apply propproperty. } intro q. induction q as [ q | q ] ; cbn in *. - apply hinhpr. use inl. use (antisymm_PartialOrder RX). + induction q. exact p₁. + apply pointed_PartialOrder_min_point. - apply hinhpr. use inr. use (antisymm_PartialOrder RY). + induction q. exact p₂. + apply pointed_PartialOrder_min_point. Qed. End SmashLowerSet. (** 4. Quotients of posets *) Section QuotientEquivRel. Context {X : hSet} (RX : PartialOrder X) (I : X → hProp) (I_down : downward_closed RX I) (eqX : eqrel X) (H : ∏ (x₁ x₂ : X), eqX x₁ x₂ <-> downward_closed_to_eqrel I x₁ x₂). Definition quotient_poset_hrel_on_el : hrel X := λ x₁ x₂, I x₁ ∨ RX x₁ x₂. Proposition quotient_poset_hrel_comp : iscomprelrel eqX quotient_poset_hrel_on_el. Proof. intros x₁ x₂ y₁ y₂ p q. assert (p' := pr1 (H x₁ x₂) p). revert p'. use factor_through_squash. { apply hPropset. } intros p'. assert (q' := pr1 (H y₁ y₂) q). revert q'. use factor_through_squash. { apply hPropset. } intros q'. induction p' as [ p' | p' ] ; induction q' as [ q' | q' ] ; use hPropUnivalence ; (use factor_through_squash ; [ apply propproperty | ]) ; cbn in * ; intro r ; apply hinhpr. - induction p', q'. exact r. - induction p', q'. exact r. - induction p'. induction r as [ r | r ]. + exact (inl r). + refine (inl _). exact (I_down x₁ y₁ r (pr1 q')). - induction p'. induction r as [ r | r ]. + exact (inl r). + refine (inl _). exact (I_down x₁ y₂ r (pr2 q')). - exact (inl (pr2 p')). - exact (inl (pr1 p')). - exact (inl (pr2 p')). - exact (inl (pr1 p')). Qed. Definition quotient_poset_hrel : hrel (setquotinset eqX). Proof. use quotrel. - exact quotient_poset_hrel_on_el. - exact quotient_poset_hrel_comp. Defined. Proposition istrans_quotient_poset : istrans quotient_poset_hrel. Proof. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₁. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₂. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply propproperty. } intros x₃. use factor_through_squash. { repeat (use impred ; intro). apply propproperty. } intro p₁. use factor_through_squash. { repeat (use impred ; intro). apply propproperty. } intro p₂. cbn in *. apply hinhpr. induction p₁ as [ p₁ | p₁ ]. - exact (inl p₁). - induction p₂ as [ p₂ | p₂ ]. + apply inl. exact (I_down x₁ x₂ p₁ p₂). + apply inr. exact (trans_PartialOrder RX p₁ p₂). Qed. Proposition isrefl_quotient_poset : isrefl quotient_poset_hrel. Proof. use setquotunivprop. intro x ; cbn in *. apply hinhpr. exact (inr (refl_PartialOrder RX x)). Qed. Proposition isantisymm_quotient_poset : isantisymm quotient_poset_hrel. Proof. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply setproperty. } intros x₁. use setquotunivprop'. { intro x. repeat (use impred ; intro). apply setproperty. } intros x₂. use factor_through_squash. { repeat (use impred ; intro). apply setproperty. } intro p₁. use factor_through_squash. { apply setproperty. } intro p₂. use iscompsetquotpr ; cbn in *. apply (pr2 (H x₁ x₂)). apply hinhpr. induction p₁ as [ p₁ | p₁ ] ; induction p₂ as [ p₂ | p₂ ]. - exact (inr (p₁ ,, p₂)). - refine (inr (p₁ ,, _)). exact (I_down x₂ x₁ p₂ p₁). - refine (inr (_ ,, _)). + exact (I_down x₁ x₂ p₁ p₂). + exact p₂. - apply inl. exact (antisymm_PartialOrder RX p₁ p₂). Qed. Definition quotient_poset : PartialOrder (setquotinset eqX). Proof. use make_PartialOrder. - exact quotient_poset_hrel. - refine ((_ ,, _) ,, _). + exact istrans_quotient_poset. + exact isrefl_quotient_poset. + exact isantisymm_quotient_poset. Defined. Proposition is_monotone_quotient_setquot_pr : is_monotone RX quotient_poset (setquotpr _). Proof. intros x₁ x₂ p. apply hinhpr ; cbn. exact (inr p). Qed. Definition quotient_poset_bottom (pX : bottom_element RX) : bottom_element quotient_poset. Proof. simple refine (_ ,, _). - exact (setquotpr _ (pr1 pX)). - abstract (use setquotunivprop' ; [ intro ; apply propproperty | ] ; intro y ; exact (hinhpr (inr (pr2 pX y)))). Defined. End QuotientEquivRel. Definition pointed_quotient_poset {X : hSet} (RX : pointed_PartialOrder X) (I : X → hProp) (I_down : downward_closed RX I) (eqX : eqrel X) (H : ∏ (x₁ x₂ : X), eqX x₁ x₂ <-> downward_closed_to_eqrel I x₁ x₂) : pointed_PartialOrder (setquotinset eqX) := quotient_poset RX I I_down eqX H ,, quotient_poset_bottom _ _ _ _ _ (pr2 RX). UniMath-20231010/UniMath/PAdics/000077500000000000000000000000001451125700300160175ustar00rootroot00000000000000UniMath-20231010/UniMath/PAdics/.package/000077500000000000000000000000001451125700300174705ustar00rootroot00000000000000UniMath-20231010/UniMath/PAdics/.package/files000066400000000000000000000000511451125700300205110ustar00rootroot00000000000000lemmas.v fps.v frac.v z_mod_p.v padics.v UniMath-20231010/UniMath/PAdics/README.md000066400000000000000000000014501451125700300172760ustar00rootroot00000000000000# p-adic numbers Formalization of p-adic numbers, described in Álvaro Pelayo, Vladimir Voevodsky, and Michael A. Warren A univalent formalization of the p-adic numbers Math. Struct. in Comp. Science (2015), vol. 25, pp. 1147–1171. [doi:10.1017/S0960129514000541](https://doi.org/10.1017/S0960129514000541) Also see Álvaro Pelayo, Vladimir Voevodsky and Michael A. Warren, [A preliminary univalent formalization of the p-adic numbers](https://arxiv.org/abs/1302.1207v1) at arXiv. # Contents (alphabetic order of files) * *fps.v* --- formal power series, only based on lemmas.v * *frac.v* --- fractions, only based on lemmas.v * *lemmas.v* --- preparations, needed for all other files * *padics.v* --- the p-adic numbers, needs all other files * *z_mod_p.v* --- integers mod p, only based on lemmas.v UniMath-20231010/UniMath/PAdics/fps.v000066400000000000000000002035141451125700300170030ustar00rootroot00000000000000(** *Formal Power Series *) (** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) (** January 2011 *) (** made compatible with the current UniMath library again by Benedikt Ahrens in 2014 and by Ralph Matthes in 2017 *) (** Imports *) Require Import UniMath.PAdics.lemmas. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.NumberSystems.Integers. (** ** I. Summation in a commutative ring *) Local Open Scope ring_scope. Definition natsummation0 { R : commring } ( upper : nat ) ( f : nat -> R ) : R. Proof. revert f. induction upper. - intros. exact ( f 0%nat ). - intros. exact ( IHupper f + f ( S upper ) ). Defined. Lemma natsummationpathsupperfixed { R : commring } { upper : nat } ( f f' : nat -> R ) ( p : forall x : nat, natleh x upper -> f x = f' x ): natsummation0 upper f = natsummation0 upper f'. Proof. revert f f' p. induction upper. - intros f f' p. simpl. apply p. apply isreflnatleh. - intros. simpl. rewrite ( IHupper f f' ). + rewrite ( p ( S upper ) ). * apply idpath. * apply isreflnatleh. + intros x p'. apply p. apply ( istransnatleh(m := upper) ). * assumption. * apply natlthtoleh. apply natlthnsn. Defined. (* Here we consider summation of functions which are, in a fixed interval, 0 for all but either the first or last value. *) Lemma natsummationae0bottom { R : commring } { f : nat -> R } ( upper : nat ) ( p : forall x : nat, natlth 0 x -> f x = 0 ) : natsummation0 upper f = f 0%nat. Proof. revert p. induction upper. - auto. - intro p. simpl. rewrite IHupper. + rewrite ( p ( S upper ) ). * rewrite ( ringrunax1 R ). apply idpath. * apply ( natlehlthtrans _ upper _ ). -- apply natleh0n. -- apply natlthnsn. + assumption. Defined. Lemma natsummationae0top { R : commring } { f : nat -> R } ( upper : nat ) ( p : forall x : nat, natlth x upper -> f x = 0 ) : natsummation0 upper f = f upper. Proof. revert p. induction upper. - auto. - intro p. assert ( natsummation0 upper f = natsummation0 ( R := R ) upper ( fun x : nat => 0 ) ) as g. { apply natsummationpathsupperfixed. intros m q. apply p. exact ( natlehlthtrans m upper ( S upper ) q ( natlthnsn upper ) ). } simpl. rewrite g. assert ( natsummation0 ( R := R ) upper ( fun _ : nat => 0 ) = 0 ) as g'. { set ( g'' := fun x : nat => ringunel1 ( X := R ) ). assert ( forall x : nat, natlth 0 x -> g'' x = 0 ) as q0. { intros k pp. apply idpath. } exact ( natsummationae0bottom upper q0 ). } rewrite g'. rewrite ( ringlunax1 R ). apply idpath. Defined. Lemma natsummationshift0 { R : commring } ( upper : nat ) ( f : nat -> R ) : natsummation0 ( S upper ) f = ( natsummation0 upper ( fun x : nat => f ( S x ) ) + f 0%nat ). Proof. revert f. induction upper. - intros f. simpl. set (H:=pr2 R). simpl in H. set (H1:=pr1 H). set (H2:=pr1 H1). set (H3:=pr1 H2). set (H4:=pr2 H3). simpl in H4. apply H4. - intros. change ( natsummation0 ( S upper ) f + f ( S ( S upper ) ) = ( natsummation0 upper ( fun x : nat => f ( S x ) ) + f ( S ( S upper ) ) + f 0%nat ) ). rewrite IHupper. rewrite 2! ( ringassoc1 R ). rewrite ( ringcomm1 R ( f 0%nat ) _ ). apply idpath. Defined. Lemma natsummationshift { R : commring } ( upper : nat ) ( f : nat -> R ) { i : nat } ( p : natleh i upper ) : natsummation0 ( S upper ) f = natsummation0 upper ( funcomp ( natcoface i ) f ) + f i. Proof. revert f i p. induction upper. - intros f i p. destruct i. + unfold natcoface. simpl. set (H:=pr2 R). simpl in H. set (H1:=pr1 H). set (H2:=pr1 H1). set (H3:=pr1 H2). set (H4:=pr2 H3). simpl in H4. apply H4. + apply fromempty. exact ( negnatlehsn0 i p ). - intros f i p. destruct i. + apply natsummationshift0. + destruct ( natlehchoice ( S i ) ( S upper ) p ) as [ h | k ]. * change ( natsummation0 ( S upper ) f + f ( S ( S upper ) ) = natsummation0 ( S upper ) ( funcomp ( natcoface ( S i ) ) f ) + f ( S i ) ). rewrite ( IHupper f ( S i ) ). -- simpl. unfold natcoface at 3. rewrite 2! ( ringassoc1 R ). rewrite ( ringcomm1 R _ ( f ( S i ) ) ). simpl. rewrite ( natgehimplnatgtbfalse i upper ). ++ apply idpath. ++ apply p. -- apply natlthsntoleh. assumption. * simpl. assert ( natsummation0 upper ( funcomp ( natcoface ( S i ) ) f ) = natsummation0 upper f ) as h. { apply natsummationpathsupperfixed. intros m q. unfold natcoface. assert ( natlth m ( S i ) ) as q'. { apply ( natlehlthtrans _ upper ). -- assumption. -- rewrite k. apply natlthnsn. } unfold natlth in q'. unfold funcomp. rewrite q'. apply idpath. } rewrite <- h. unfold natcoface at 3. simpl. rewrite ( natgehimplnatgtbfalse i upper ). -- rewrite 2! ( ringassoc1 R ). rewrite ( ringcomm1 R ( f ( S ( S upper ) ) ) ). rewrite k. apply idpath. -- apply p. Defined. Lemma natsummationplusdistr { R : commring } ( upper : nat ) ( f g : nat -> R ) : natsummation0 upper ( fun x : nat => f x + g x ) = natsummation0 upper f + natsummation0 upper g. Proof. revert f g. induction upper. - auto. - intros f g. simpl. rewrite <- ( ringassoc1 R _ ( natsummation0 upper g ) _ ). rewrite ( ringassoc1 R ( natsummation0 upper f ) ). rewrite ( ringcomm1 R _ ( natsummation0 upper g ) ). rewrite <- ( ringassoc1 R ( natsummation0 upper f ) ). rewrite <- ( IHupper f g ). rewrite ( ringassoc1 R ). apply idpath. Defined. Lemma natsummationtimesdistr { R : commring } ( upper : nat ) ( f : nat -> R ) ( k : R ) : k * ( natsummation0 upper f ) = natsummation0 upper ( fun x : nat => k * f x ). Proof. revert f k. induction upper. - auto. - intros f k. simpl. rewrite <- IHupper. rewrite <- ( ringldistr R ). apply idpath. Defined. Lemma natsummationtimesdistl { R : commring } ( upper : nat ) ( f : nat -> R ) ( k : R ) : natsummation0 upper f * k = natsummation0 upper ( fun x : nat => f x * k ). Proof. revert f k. induction upper. - auto. - intros f k. simpl. rewrite <- IHupper. rewrite ( ringrdistr R ). apply idpath. Defined. Lemma natsummationsswapminus { R : commring } { upper n : nat } ( f : nat -> R ) ( q : natleh n upper ) : natsummation0 ( S ( sub upper n ) ) f = natsummation0 ( sub ( S upper ) n ) f. Proof. revert n f q. induction upper. - intros n f q. destruct n. + auto. + apply fromempty. exact ( negnatlehsn0 n q ). - intros n f q. destruct n. + auto. + change ( natsummation0 ( S ( sub upper n ) ) f = natsummation0 ( sub ( S upper ) n ) f ). apply IHupper. apply q. Defined. (** The following lemma asserts that $\sum^{n}_{k=0}\sum^{k}_{l=0}f(l,k-l)=\sum^{n}_{k=0}\sum^{n-k}_{l=0}f(k,l)$ *) Lemma natsummationswap { R : commring } ( upper : nat ) ( f : nat -> nat -> R ) : natsummation0 upper ( fun i : nat => natsummation0 i (fun j : nat => f j ( sub i j ) ) ) = natsummation0 upper ( fun k : nat => natsummation0 ( sub upper k ) ( fun l : nat => f k l ) ). Proof. revert f. induction upper. - auto. - intros f. change ( natsummation0 upper (fun i : nat => natsummation0 i (fun j : nat => f j ( sub i j ))) + natsummation0 ( S upper ) ( fun j : nat => f j ( sub ( S upper ) j ) ) = natsummation0 upper (fun k : nat => natsummation0 (S upper - k) (fun l : nat => f k l)) + natsummation0 ( sub ( S upper ) ( S upper ) ) ( fun l : nat => f ( S upper ) l ) ). change ( natsummation0 upper (fun i : nat => natsummation0 i (fun j : nat => f j ( sub i j))) + ( natsummation0 upper ( fun j : nat => f j ( sub ( S upper ) j ) ) + f ( S upper ) ( sub ( S upper ) ( S upper ) ) ) = natsummation0 upper (fun k : nat => natsummation0 (S upper - k) (fun l : nat => f k l)) + natsummation0 ( sub ( S upper ) ( S upper ) ) ( fun l : nat => f ( S upper ) l ) ). assert ( natsummation0 upper (fun k : nat => natsummation0 ( S ( sub upper k ) ) (fun l : nat => f k l)) = natsummation0 upper (fun k : nat => natsummation0 (sub ( S upper ) k) (fun l : nat => f k l)) ) as A. { apply natsummationpathsupperfixed. intros n q. apply natsummationsswapminus. exact q. } rewrite <- A. change ( fun k : nat => natsummation0 (S ( sub upper k)) (fun l : nat => f k l) ) with ( fun k : nat => natsummation0 ( sub upper k ) ( fun l : nat => f k l ) + f k ( S ( sub upper k ) ) ). rewrite ( natsummationplusdistr upper _ ( fun k : nat => f k ( S ( sub upper k ) ) ) ). rewrite IHupper. rewrite minusnn0. rewrite ( ringassoc1 R). assert ( natsummation0 upper ( fun j : nat => f j ( sub ( S upper ) j ) ) = natsummation0 upper ( fun k : nat => f k ( S ( sub upper k ) ) ) ) as g. { apply natsummationpathsupperfixed. intros m q. rewrite pathssminus. + apply idpath. + apply ( natlehlthtrans _ upper ). * assumption. * apply natlthnsn. } rewrite g. apply idpath. Defined. (** * II. Reindexing along functions i : nat -> nat which are automorphisms of the interval of summation.*) Definition isnattruncauto ( upper : nat ) ( i : nat -> nat ) := ( forall x : nat, natleh x upper -> ∑ (y : nat), natleh y upper × ( i y = x × forall z : nat, natleh z upper -> i z = x -> y = z ) ) × forall x : nat, natleh x upper -> natleh ( i x ) upper. Lemma nattruncautoisinj { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) { n m : nat } ( n' : natleh n upper ) ( m' : natleh m upper ) : i n = i m -> n = m. Proof. intros h. assert ( natleh ( i m ) upper ) as q. { apply (pr2 p). assumption. } set ( x := pr1 p ( i m ) q ). set ( v := pr1 x ). set ( w := pr1 ( pr2 x ) ). set ( y := pr1 ( pr2 ( pr2 x ) ) ). change ( pr1 x ) with v in w, y. assert ( v = n ) as a. { apply (pr2 (pr2 (pr2 x))). (*apply ( pr2 x).*) - assumption. - assumption. } rewrite <- a. apply (pr2 (pr2 ( pr2 x))). - assumption. - apply idpath. Defined. Definition nattruncautopreimage { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : nat := pr1 ( pr1 p n n' ). Definition nattruncautopreimagepath { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : i ( nattruncautopreimage p n' ) = n := pr1 ( pr2 ( pr2 ( pr1 p n n' ) ) ). Definition nattruncautopreimageineq { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : natleh ( nattruncautopreimage p n' ) upper := pr1 ( pr2 ( pr1 p n n' ) ). Definition nattruncautopreimagecanon { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) { m : nat } ( m' : natleh m upper ) ( q : i m = n ) : nattruncautopreimage p n' = m := pr2 ( pr2 ( pr2 ( pr1 p n n' ) ) ) m m' q. Definition nattruncautoinv { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) : nat -> nat. Proof. intros n. destruct ( natgthorleh n upper ) as [ l | r ]. - exact n. - exact ( nattruncautopreimage p r ). Defined. Lemma nattruncautoinvisnattruncauto { upper : nat } { i : nat -> nat } ( p : isnattruncauto upper i ) : isnattruncauto upper ( nattruncautoinv p ). Proof. intros. split. - intros n n'. split with ( i n ). split. + apply (pr2 p). assumption. + split. * unfold nattruncautoinv. destruct ( natgthorleh ( i n ) upper ) as [ l | r ]. -- apply fromempty. apply ( isirreflnatlth ( i n ) ). apply ( natlehlthtrans _ upper ). ++ apply (pr2 p). assumption. ++ assumption. -- apply ( nattruncautoisinj p ). ++ apply ( nattruncautopreimageineq ). ++ assumption. ++ apply ( nattruncautopreimagepath p r ). * intros m x v. unfold nattruncautoinv in v. destruct ( natgthorleh m upper ) as [ l | r ]. -- apply fromempty. apply ( isirreflnatlth upper ). apply ( natlthlehtrans _ m ); assumption. -- rewrite <- v. apply ( nattruncautopreimagepath p r ). - intros x X. unfold nattruncautoinv. destruct ( natgthorleh x upper ) as [ l | r ]. * assumption. * apply ( nattruncautopreimageineq p r ). Defined. Definition truncnattruncauto { upper : nat } { i : nat -> nat } ( p : isnattruncauto ( S upper ) i ) : nat -> nat. Proof. intros n. destruct ( natlthorgeh ( i n ) ( S upper ) ) as [ l | r ]. - exact ( i n ). - destruct ( natgehchoice _ _ r ) as [ a | b ]. + exact ( i n ). + destruct ( isdeceqnat n ( S upper ) ) as [ h | k ]. * exact ( i n ). * exact ( i ( S upper ) ). Defined. Lemma truncnattruncautobound { upper : nat } ( i : nat -> nat ) ( p : isnattruncauto ( S upper ) i ) ( n : nat ) ( q : natleh n upper ) : natleh ( truncnattruncauto p n ) upper. Proof. intros. unfold truncnattruncauto. destruct ( natlthorgeh ( i n ) ( S upper) ) as [ l | r ]. - apply natlthsntoleh. assumption. - destruct ( natgehchoice ( i n ) ( S upper ) ) as [ l' | r' ]. + apply fromempty. apply ( isirreflnatlth ( i n ) ). apply ( natlehlthtrans _ ( S upper ) ). * apply (pr2 p). apply natlthtoleh. apply ( natlehlthtrans _ upper ). -- assumption. -- apply natlthnsn. * assumption. + destruct ( isdeceqnat n ( S upper ) ) as [ l'' | r'' ]. * apply fromempty. apply ( isirreflnatlth upper ). apply ( natlthlehtrans _ ( S upper ) ). -- apply natlthnsn. -- rewrite <- l''. assumption. * assert ( natleh ( i ( S upper ) ) ( S upper ) ) as aux. { apply (pr2 p). apply isreflnatleh. } destruct ( natlehchoice _ _ aux ) as [ l''' | r''' ]. -- apply natlthsntoleh. assumption. -- apply fromempty. apply r''. apply ( nattruncautoisinj p ). ++ apply natlthtoleh. apply ( natlehlthtrans _ upper ). ** assumption. ** apply natlthnsn. ++ apply isreflnatleh. ++ rewrite r'. rewrite r'''. apply idpath. Defined. Lemma truncnattruncautoisinj { upper : nat } { i : nat -> nat } ( p : isnattruncauto ( S upper ) i ) { n m : nat } ( q : natleh n upper ) ( r : natleh m upper ) : truncnattruncauto p n = truncnattruncauto p m -> n = m. Proof. intros s. apply ( nattruncautoisinj p ). - apply natlthtoleh. apply ( natlehlthtrans _ upper ). + assumption. + apply natlthnsn. - apply natlthtoleh. apply ( natlehlthtrans _ upper ). + assumption. + apply natlthnsn. - unfold truncnattruncauto in s. destruct ( natlthorgeh ( i n ) ( S upper ) ) as [ a0 | a1 ]. + destruct ( natlthorgeh ( i m ) ( S upper ) ) as [ b0 | b1 ]. * assumption. * apply fromempty. assert ( i m = S upper ) as f0. { destruct ( natgehchoice ( i m ) ( S upper ) b1 ) as [ l | l' ]. -- apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ ( i n ) ). ++ rewrite s. assumption. ++ assumption. -- assumption. } destruct (natgehchoice ( i m ) ( S upper ) b1 ) as [ a00 | a10 ]. -- apply (isirreflnatgth ( S upper ) ). rewrite f0 in a00. assumption. -- destruct ( isdeceqnat m ( S upper ) ) as [ a000 | a100 ]. ++ rewrite s in a0. rewrite f0 in a0. apply ( isirreflnatlth ( S upper ) ). assumption. ++ assert ( i m = n ) as f1. { apply ( nattruncautoisinj p ). ** rewrite f0. apply isreflnatleh. ** apply natlthtoleh. apply ( natlehlthtrans _ upper ). --- assumption. --- apply natlthnsn. ** rewrite f0. rewrite s. apply idpath. } apply ( isirreflnatlth upper ). apply ( natlthlehtrans _ n ). ** rewrite <- f1, f0. apply natlthnsn. ** assumption. + destruct ( natgehchoice ( i n ) ( S upper ) a1 ) as [ a00 | a01 ]. * apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlthlehtrans _ ( i n ) ). -- assumption. -- apply ( pr2 p ). apply natlthtoleh. apply ( natlehlthtrans _ upper ). ++ assumption. ++ apply natlthnsn. * destruct ( natlthorgeh ( i m ) ( S upper ) ) as [ b0 | b1 ]. -- destruct ( isdeceqnat n ( S upper ) ) as [ a000 | a001 ]. ++ assumption. ++ assert ( S upper = m ) as f0. { apply ( nattruncautoisinj p ). ** apply isreflnatleh. ** apply natlthtoleh. apply ( natlehlthtrans _ upper ). --- assumption. --- apply natlthnsn. ** assumption. } apply fromempty. apply a001. rewrite f0. apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). ** rewrite f0. assumption. ** apply natlthnsn. -- destruct ( natgehchoice ( i m ) ( S upper ) b1 ) as [ b00 | b01 ]. ++ apply fromempty. apply ( isirreflnatlth ( i m ) ). apply ( natlehlthtrans _ ( S upper ) ). ** apply (pr2 p). apply ( natlthtoleh ). apply ( natlehlthtrans _ upper ). --- assumption. --- apply natlthnsn. ** assumption. ++ rewrite b01. rewrite a01. apply idpath. Defined. Lemma truncnattruncautoisauto { upper : nat } { i : nat -> nat } ( p : isnattruncauto ( S upper ) i ) : isnattruncauto upper ( truncnattruncauto p ). Proof. intros. split. - intros n q. assert ( natleh n ( S upper ) ) as q'. { apply natlthtoleh. apply ( natlehlthtrans _ upper ). + assumption. + apply natlthnsn. } destruct ( isdeceqnat ( nattruncautopreimage p q' ) ( S upper ) ) as [ i0 | i1 ]. + split with ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ). split. * assert ( natleh ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ( S upper ) ) as aux by apply nattruncautopreimageineq. destruct ( natlehchoice _ _ aux ) as [ l | r ]. -- apply natlthsntoleh. assumption. -- assert ( n = S upper ) as f0. { rewrite <- ( nattruncautopreimagepath p q' ). rewrite i0. rewrite <- r. rewrite ( nattruncautopreimagepath p ( isreflnatleh ( S upper) ) ). rewrite r. apply idpath. } apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). ++ rewrite <- f0. assumption. ++ apply natlthnsn. * split. -- apply ( nattruncautoisinj p ). ++ apply natlthtoleh. apply ( natlehlthtrans _ upper ). ** apply truncnattruncautobound. destruct ( natlehchoice _ _ ( nattruncautopreimageineq p ( isreflnatleh ( S upper ) ) ) ) as [ l | r]. --- apply natlthsntoleh. assumption. --- apply fromempty. assert ( S upper = n ) as f0. { rewrite <- ( nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ). rewrite r. rewrite <- i0. rewrite ( nattruncautopreimagepath p q' ). apply idpath. } apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). +++ rewrite f0. assumption. +++ apply natlthnsn. ** apply natlthnsn. ++ assumption. ++ unfold truncnattruncauto. destruct ( isdeceqnat ( nattruncautopreimage p (isreflnatleh ( S upper ) ) ) ) as [ l | r ]. ** apply fromempty. assert ( S upper = n ) as f0. { rewrite <- ( nattruncautopreimagepath p (isreflnatleh ( S upper ) ) ). rewrite l. rewrite <- i0. rewrite ( nattruncautopreimagepath p q' ). apply idpath. } apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). --- rewrite f0. assumption. --- apply natlthnsn. ** destruct ( natlthorgeh ( i ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ) ( S upper ) ) as [ l' | r' ]. --- apply fromempty. apply ( isirreflnatlth ( S upper ) ). rewrite ( nattruncautopreimagepath p ) in l'. assumption. --- destruct ( natgehchoice _ _ r' ) as [ l'' | r'' ]. +++ apply fromempty. apply ( isirreflnatlth ( S upper ) ). rewrite ( nattruncautopreimagepath p ) in l''. assumption. +++ rewrite <- i0. rewrite ( nattruncautopreimagepath p q' ). apply idpath. -- intros x X y. apply ( nattruncautoisinj p ). ++ apply nattruncautopreimageineq. ++ apply natlthtoleh. apply ( natlehlthtrans _ upper ). ** assumption. ** apply natlthnsn. ++ unfold truncnattruncauto in y. destruct ( natlthorgeh ( i x ) ( S upper ) ) as [ l | r ]. ** assert ( S upper = x ) as f0. { apply ( nattruncautoisinj p ). --- apply isreflnatleh. --- apply natlthtoleh. apply ( natlehlthtrans _ upper ). +++ assumption. +++ apply natlthnsn. --- rewrite <- i0. rewrite y. rewrite ( nattruncautopreimagepath p q' ). apply idpath. } apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). --- rewrite f0. assumption. --- apply natlthnsn. ** destruct ( isdeceqnat x ( S upper ) ) as [ l' | r' ]. --- apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). +++ rewrite <- l'. assumption. +++ apply natlthnsn. --- destruct ( natgehchoice _ _ r ) as [ l'' | r'' ]. +++ apply fromempty. apply ( isirreflnatlth n ). apply ( natlehlthtrans _ ( S upper ) ). *** assumption. *** rewrite <- y. assumption. +++ rewrite ( nattruncautopreimagepath p _ ). rewrite r''. apply idpath. + split with ( nattruncautopreimage p q' ). split. * destruct ( natlehchoice _ _ ( nattruncautopreimageineq p q' ) ) as [ l | r ]. -- apply natlthsntoleh. assumption. -- apply fromempty. apply i1. assumption. * split. -- unfold truncnattruncauto. destruct ( natlthorgeh ( i ( nattruncautopreimage p q' ) ) ( S upper ) ) as [ l | r ]. ++ apply nattruncautopreimagepath. ++ destruct ( natgehchoice _ _ r ) as [ l' | r' ]. ** apply nattruncautopreimagepath. ** apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). --- rewrite <- r'. rewrite ( nattruncautopreimagepath p q' ). assumption. --- apply natlthnsn. -- intros x X y. apply ( nattruncautoisinj p ). ++ set (H:=pr1 p). simpl in H. set (H1:=pr2 p). simpl in H1. set (H2:=H n q'). apply (pr2 H2). (* apply ( pr1 p ). *) ++ apply natlthtoleh. apply ( natlehlthtrans _ upper ). ** assumption. ** apply natlthnsn. ++ rewrite ( nattruncautopreimagepath p q' ). unfold truncnattruncauto in y. destruct ( natlthorgeh ( i x ) ( S upper ) ) as [ l | r ]. ** rewrite y. apply idpath. ** destruct ( isdeceqnat x ( S upper ) ) as [ l' | r' ]. --- apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). +++ rewrite <- l'. assumption. +++ apply natlthnsn. --- destruct ( natgehchoice _ _ r ). +++ rewrite y. apply idpath. +++ apply fromempty. apply i1. apply ( nattruncautoisinj p ). *** apply ( nattruncautopreimageineq p ). *** apply isreflnatleh. *** rewrite ( nattruncautopreimagepath p q' ). rewrite y. apply idpath. - apply truncnattruncautobound. Defined. Definition truncnattruncautoinv { upper : nat } { i : nat -> nat } ( p : isnattruncauto ( S upper ) i ) : nat -> nat := nattruncautoinv ( truncnattruncautoisauto p ). Lemma precompwithnatcofaceisauto { upper : nat } ( i : nat -> nat ) ( p : isnattruncauto ( S upper ) i ) ( bound : natlth 0 ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ) : isnattruncauto upper (funcomp ( natcoface ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ) i ). Proof. intros. set ( v := nattruncautopreimage p ( isreflnatleh ( S upper ) ) ). change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in bound. unfold isnattruncauto. split. - intros m q. unfold funcomp. assert ( natleh m ( S upper ) ) as aaa. { apply natlthtoleh. apply natlehlthtrans with ( m := upper). + assumption. + exact ( natlthnsn upper ). } set ( m' := nattruncautopreimage p aaa ). destruct ( natlthorgeh m' v ) as [ l | r ]. + (* CASE m' < v *) split with m'. split. * apply natlthsntoleh. apply ( natlthlehtrans _ v ). -- assumption. -- apply ( nattruncautopreimageineq p _ ). * split. -- unfold natcoface. rewrite l. apply ( nattruncautopreimagepath p aaa ). -- intros n j w. assert ( natcoface v n = m' ) as f0. { apply pathsinv0. apply ( nattruncautopreimagecanon p aaa ). ++ apply natcofaceleh. assumption. ++ assumption. } rewrite <- f0. destruct ( natgthorleh v n ) as [ l' | r' ]. ++ unfold natcoface. rewrite l'. apply idpath. ++ apply fromempty. apply ( isirreflnatlth v ). apply ( natlehlthtrans _ n ). ** assumption. ** apply ( istransnatlth _ ( S n ) ). { apply natlthnsn. } unfold natcoface in f0. rewrite ( natgehimplnatgtbfalse v n r' ) in f0. rewrite f0. assumption. + (* CASE v <= m' *) set ( j := nattruncautopreimagepath p aaa ). change ( nattruncautopreimage p aaa ) with m' in j. set ( m'' := sub m' 1 ). assert ( natleh m'' upper ) as a0. { destruct ( natlthorgeh 0 m' ) as [ h | h' ]. * rewrite <- ( minussn1 upper ). apply minus1leh. -- assumption. -- apply ( natlehlthtrans _ upper ). ++ apply natleh0n. ++ apply natlthnsn. -- apply nattruncautopreimageineq. * destruct ( natgehchoice 0 m' h' ) as [ k | k' ]. -- apply fromempty. apply ( negnatgth0n m' k ). -- unfold m''. rewrite <- k'. apply natleh0n. } destruct ( natgehchoice m' v r ) as [ l' | r' ]. * assert ( natleh v m'' ) as a2. { apply natlthsntoleh. unfold m''. rewrite pathssminus. -- rewrite minussn1. assumption. -- destruct ( natlehchoice 0 m' ( natleh0n m' ) ) as [ k | k' ]. ++ assumption. ++ apply fromempty. apply ( negnatgth0n v ). rewrite k'. assumption. } assert ( i ( natcoface v m'' ) = m ) as a1. { unfold natcoface. rewrite ( natgehimplnatgtbfalse v m'' a2 ). unfold m''. rewrite pathssminus. -- rewrite minussn1. assumption. -- destruct ( natlehchoice 0 m' ( natleh0n m' ) ) as [ k | k' ]. ++ assumption. ++ apply fromempty. apply ( negnatgth0n v ). rewrite k'. assumption. } split with m''. split. -- assumption. -- split. ++ assumption. ++ intros n s t. assert ( natcoface v n = natcoface v m'' ) as g. { assert ( natcoface v n = m' ) as g0. { apply pathsinv0. apply ( nattruncautopreimagecanon p aaa ). ** apply natcofaceleh. assumption. ** assumption. } assert ( natcoface v m'' = m' ) as g1. { unfold m'. unfold nattruncautopreimage. apply pathsinv0. apply ( nattruncautopreimagecanon p aaa ). ** apply natcofaceleh. assumption. ** assumption. } rewrite g0, g1. apply idpath. } change ( idfun _ m'' = idfun _ n ). rewrite <- ( natcofaceretractisretract v ). simpl. rewrite g. apply idpath. * apply fromempty. apply ( isirreflnatlth ( S upper ) ). apply ( natlehlthtrans _ upper ). -- assert ( S upper = m ) as g. { rewrite <- ( nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ). change ( i v = m ). rewrite <- j. rewrite r'. apply idpath. } rewrite g. assumption. -- apply natlthnsn. - intros x X. assert ( natleh ( i ( natcoface v x ) ) ( S upper ) ) as a0. { apply (pr2 p). apply natcofaceleh. assumption. } destruct ( natlehchoice _ _ a0 ) as [ l | r ]. + apply natlthsntoleh. assumption. + assert ( v = natcoface v x ) as g. { unfold v. apply ( nattruncautopreimagecanon p ( isreflnatleh ( S upper ) ) ). * unfold natcoface. -- destruct ( natgthorleh v x ) as [ a | b ]. ++ unfold v in a. rewrite a. apply natlthtoleh. apply ( natlehlthtrans _ upper ). ** assumption. ** apply natlthnsn. ++ unfold v in b. rewrite ( natgehimplnatgtbfalse _ x b ). assumption. * assumption. } apply fromempty. destruct ( natgthorleh v x ) as [ a | b ]. * unfold natcoface in g. rewrite a in g. apply ( isirreflnatlth x ). rewrite g in a. assumption. * unfold natcoface in g. rewrite ( natgehimplnatgtbfalse v x b ) in g. apply ( isirreflnatlth x ). apply ( natlthlehtrans _ ( S x ) ). -- apply natlthnsn. -- rewrite <- g. assumption. Defined. Lemma nattruncautocompstable { R : commring } { upper : nat } ( i j : nat -> nat ) ( p : isnattruncauto upper i ) ( p' : isnattruncauto upper j ) : isnattruncauto upper ( funcomp j i ). Proof. intros. split. - intros n n'. split with ( nattruncautopreimage p' ( nattruncautopreimageineq p n' ) ). split. + apply ( nattruncautopreimageineq p' ). + split. * simpl. rewrite ( nattruncautopreimagepath p' _ ). rewrite ( nattruncautopreimagepath p _ ). apply idpath. * intros x X y. simpl in y. apply ( nattruncautoisinj p' ). -- apply nattruncautopreimageineq. -- assumption. -- apply ( nattruncautoisinj p ). ++ apply (pr2 p'). apply nattruncautopreimageineq. ++ apply (pr2 p') . assumption. ++ rewrite ( nattruncautopreimagepath p' ). rewrite ( nattruncautopreimagepath p ). rewrite y. apply idpath. - intros x X. apply (pr2 p). apply (pr2 p'). assumption. Defined. Definition nattruncreverse ( upper : nat ) : nat -> nat. Proof. intros n. destruct ( natgthorleh n upper ) as [ h | k ]. - exact n. - exact ( sub upper n ). Defined. Definition nattruncbottomtopswap ( upper : nat ) : nat -> nat. Proof. intros n. destruct ( isdeceqnat 0%nat n ) as [ h | k ]. - exact upper. - destruct ( isdeceqnat upper n ) as [ l | r ]. + exact ( 0%nat ). + exact n. Defined. Lemma nattruncreverseisnattruncauto ( upper : nat ) : isnattruncauto upper ( nattruncreverse upper ). Proof. intros. unfold isnattruncauto. split. - intros m q. set ( m' := sub upper m ). assert ( natleh m' upper ) as a0 by apply minusleh. assert ( nattruncreverse upper m' = m ) as a1. { unfold nattruncreverse. + destruct ( natgthorleh m' upper ). * apply fromempty. apply isirreflnatlth with ( n := m' ). apply natlehlthtrans with ( m := upper ). -- assumption. -- assumption. * unfold m'. rewrite doubleminuslehpaths. -- apply idpath. -- assumption. } split with m'. split. + assumption. + split. * assumption. * intros n qq u. unfold m'. rewrite <- u. unfold nattruncreverse. destruct ( natgthorleh n upper ) as [ l | r ]. -- apply fromempty. apply ( isirreflnatlth n ). apply ( natlehlthtrans _ upper ). ++ assumption. ++ assumption. -- rewrite doubleminuslehpaths. ++ apply idpath. ++ assumption. - intros x X. unfold nattruncreverse. destruct ( natgthorleh x upper ) as [ l | r ]. + assumption. + apply minusleh. Defined. Lemma nattruncbottomtopswapselfinv ( upper n : nat ) : nattruncbottomtopswap upper ( nattruncbottomtopswap upper n ) = n. Proof. intros. unfold nattruncbottomtopswap. destruct ( isdeceqnat upper n ) as [ i | e ]. - destruct ( isdeceqnat 0%nat n ) as [i0 | _ ]. + destruct ( isdeceqnat 0%nat upper ) as [ i1 | e1 ]. * rewrite <- i0. rewrite <- i1. apply idpath. * apply fromempty. apply e1. rewrite i. rewrite i0. apply idpath. + destruct ( isdeceqnat 0%nat 0%nat ) as [ _ | e1 ]. * assumption. * apply fromempty. apply e1. auto. - destruct ( isdeceqnat 0%nat n ) as [i0 | e0 ]. + destruct ( isdeceqnat 0%nat upper ) as [ i1 | _ ]. * rewrite <- i0. rewrite i1. apply idpath. * destruct ( isdeceqnat upper upper ) as [ _ | e2 ]. -- assumption. -- apply fromempty. apply e2. auto. + destruct ( isdeceqnat 0%nat n ) as [ i1 | _ ]. * apply fromempty. apply e0. assumption. * destruct ( isdeceqnat upper n ) as [ i2 | _ ]. -- apply fromempty. apply e. assumption. -- apply idpath. Defined. Lemma nattruncbottomtopswapbound ( upper n : nat ) ( p : natleh n upper ) : natleh (nattruncbottomtopswap upper n ) upper. Proof. intros. unfold nattruncbottomtopswap. destruct (isdeceqnat 0%nat n). - auto. (* does not seem to do anything *) destruct ( isdeceqnat upper n ). (* logically not needed *) + apply isreflnatleh. + apply isreflnatleh. - destruct ( isdeceqnat upper n ). + apply natleh0n. + assumption. Defined. Lemma nattruncbottomtopswapisnattruncauto ( upper : nat ) : isnattruncauto upper ( nattruncbottomtopswap upper ). Proof. intros. unfold isnattruncauto. split. - intros m p. set ( m' := nattruncbottomtopswap upper m ). assert ( natleh m' upper ) as a0. { apply nattruncbottomtopswapbound. assumption. } assert (nattruncbottomtopswap upper m' = m) as a1 by apply nattruncbottomtopswapselfinv. split with m'. split. + assumption. + split. * assumption. * intros k q u. unfold m'. rewrite <- u. rewrite nattruncbottomtopswapselfinv. apply idpath. - intros n p. apply nattruncbottomtopswapbound. assumption. Defined. Lemma isnattruncauto0S { upper : nat } { i : nat -> nat } ( p : isnattruncauto (S upper) i ) ( j : i 0%nat = S upper ) : isnattruncauto upper ( funcomp S i ). Proof. intros. unfold isnattruncauto. split. - intros m q. set ( v := nattruncautopreimage p (natlthtoleh m (S upper) (natlehlthtrans m upper (S upper) q (natlthnsn upper)))). destruct ( isdeceqnat 0%nat v ) as [ i0 | i1 ]. + apply fromempty. apply ( isirreflnatlth ( i 0%nat ) ). apply ( natlehlthtrans _ upper ). * rewrite i0. unfold v. rewrite nattruncautopreimagepath. assumption. * rewrite j. apply natlthnsn. + assert ( natlth 0 v ) as aux. { destruct ( natlehchoice _ _ ( natleh0n v ) ). * assumption. * apply fromempty. apply i1. assumption. } split with ( sub v 1 ). split. * rewrite <- ( minussn1 upper ). apply ( minus1leh aux ( natlehlthtrans _ _ _ ( natleh0n upper ) ( natlthnsn upper ) ) ( nattruncautopreimageineq p ( natlthtoleh m ( S upper ) ( natlehlthtrans m upper ( S upper ) q ( natlthnsn upper ) ) ) ) ). * split. -- simpl. rewrite pathssminus. ++ rewrite minussn1. apply nattruncautopreimagepath. ++ assumption. -- intros n uu k. simpl in k. rewrite <- ( minussn1 n ). assert ( v = S n ) as f. { apply ( nattruncautopreimagecanon p _ ); assumption. } rewrite f. apply idpath. - intros x X. unfold funcomp. assert ( natleh ( i ( S x ) ) ( S upper ) ) as aux. + apply (pr2 p). assumption. + destruct ( natlehchoice _ _ aux ) as [ h | k ]. * apply natlthsntoleh. assumption. * apply fromempty. assert ( 0%nat = S x ) as ii. { apply ( nattruncautoisinj p ). -- apply natleh0n. -- assumption. -- rewrite j. rewrite k. apply idpath. } apply ( isirreflnatlth ( S x ) ). apply ( natlehlthtrans _ x ). -- rewrite <- ii. apply natleh0n. -- apply natlthnsn. Defined. (* The following lemma says that we may reindex sums along automorphisms of the interval over which the finite summation is being taken. *) Lemma natsummationreindexing { R : commring } { upper : nat } ( i : nat -> nat ) ( p : isnattruncauto upper i ) ( f : nat -> R ) : natsummation0 upper f = natsummation0 upper (funcomp i f ). Proof. revert i p f. induction upper. - intros. simpl. assert ( 0%nat = i 0%nat ) as f0. { destruct ( natlehchoice ( i 0%nat ) 0%nat ( pr2 p 0%nat ( isreflnatleh 0%nat ) ) ) as [ h | k ]. + apply fromempty. exact ( negnatlthn0 ( i 0%nat ) h ). + rewrite k. apply idpath. } rewrite <- f0. apply idpath. - intros. simpl ( natsummation0 ( S upper ) f ). set ( j := nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ). set ( v := nattruncautopreimage p ( isreflnatleh ( S upper ) ) ). change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in j. destruct ( natlehchoice 0%nat v ( natleh0n v ) ) as [ h | p0 ] . + set ( aaa := nattruncautopreimageineq p ( isreflnatleh ( S upper ) ) ). change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in aaa. destruct ( natlehchoice v ( S upper ) aaa ) as [ l | r ]. * rewrite ( IHupper ( funcomp ( natcoface v ) i ) ). -- change ( funcomp ( funcomp ( natcoface v ) i ) f ) with ( funcomp ( natcoface v ) ( funcomp i f ) ). assert ( f ( S upper ) = ( funcomp i f ) v ) as f0. { simpl. rewrite j. apply idpath. } rewrite f0. assert ( natleh v upper ) as aux. { apply natlthsntoleh. assumption. } rewrite ( natsummationshift upper ( funcomp i f ) aux ). apply idpath. -- apply precompwithnatcofaceisauto. assumption. * rewrite ( IHupper ( funcomp ( natcoface v ) i ) ). -- assert ( natsummation0 upper ( funcomp ( funcomp ( natcoface v ) i) f ) = natsummation0 upper ( funcomp i f ) ) as f0. { apply natsummationpathsupperfixed. intros x X. simpl. unfold natcoface. assert ( natlth x v ) as a0. { apply ( natlehlthtrans _ upper ). ++ assumption. ++ rewrite r. apply natlthnsn. } rewrite a0. apply idpath. } rewrite f0. assert ( f ( S upper ) = funcomp i f ( S upper ) ) as f1. { simpl. rewrite <- r. rewrite j. rewrite <- r. apply idpath. } rewrite f1. apply idpath. -- apply precompwithnatcofaceisauto. assumption. + rewrite natsummationshift0. simpl. rewrite p0. rewrite j. assert ( i 0%nat = S upper ) as j'. { rewrite p0. rewrite j. apply idpath. } rewrite ( IHupper ( funcomp S i ) ( isnattruncauto0S p j' ) ). apply idpath. Defined. (** * III. Formal Power Series *) Definition seqson ( A : UU ) := nat -> A. Lemma seqsonisaset ( A : hSet ) : isaset ( seqson A ). Proof. intros. unfold seqson. change ( isofhlevel 2 ( nat -> A ) ). apply impredfun. apply (pr2 A). Defined. Definition isasetfps ( R : commring ) : isaset ( seqson R ) := seqsonisaset R. Definition fps ( R : commring ) : hSet := make_hSet _ ( isasetfps R ). Definition fpsplus ( R : commring ) : binop ( fps R ) := fun v w n => ( ( v n ) + ( w n ) ). Definition fpstimes ( R : commring ) : binop ( fps R ) := fun s t n => natsummation0 n ( fun x : nat => s x * t ( sub n x ) ). (* SOME TESTS OF THE SUMMATION AND FPSTIMES DEFINITIONS: *) Local Definition test0 : seqson hz. Proof. intro n. induction n. - exact 0. - exact ( nattohz ( S n ) ). Defined. (* Eval lazy in ( hzabsval ( natsummation0 1 test0 ) ). *) Local Definition test1 : seqson hz. Proof. intro n. induction n. - exact ( 1 + 1 ). - exact ( ( 1 + 1 ) * IHn ). Defined. (* Eval lazy in ( hzabsval ( fpstimes hz test0 test1 0%nat ) ). Eval lazy in ( hzabsval ( fpstimes hz test0 test1 1%nat ) ). Eval lazy in ( hzabsval ( fpstimes hz test0 test1 2%nat ) ). Eval lazy in ( hzabsval ( fpstimes hz test0 test1 3%nat ) ). Eval lazy in ( hzabsval ( fpstimes hz test0 test1 4%nat ) ). *) Definition fpszero ( R : commring ) : fps R := fun n : nat => 0. Definition fpsone ( R : commring ) : fps R. Proof. intros. intro n. destruct n. - exact 1. - exact 0. Defined. Definition fpsminus ( R : commring ) : fps R -> fps R := fun s n => - ( s n ). Lemma ismonoidopfpsplus ( R : commring ) : ismonoidop ( fpsplus R ). Proof. intros. unfold ismonoidop. split. - unfold isassoc. intros s t u. unfold fpsplus. (* This is a hack which should work immediately without such a workaround! *) change ( (fun n : nat => s n + t n + u n) = (fun n : nat => s n + (t n + u n)) ). apply funextfun. intro n. set ( H := pr2 R ). set ( H1 := pr1 H ). set ( H2 := pr1 H1 ). set ( H3 := pr1 H2 ). set ( H4 := pr1 H3 ). set ( H5 := pr1 H4 ). set ( H6 := pr1 H5 ). apply H6. (* apply R. *) - unfold isunital. assert ( isunit ( fpsplus R ) ( fpszero R ) ) as a. { unfold isunit. split. + unfold islunit. intro s. unfold fpsplus. unfold fpszero. change ( (fun n : nat => 0 + s n) = s ). apply funextfun. intro n. apply ringlunax1. + unfold isrunit. intro s. unfold fpsplus. unfold fpszero. change ( (fun n : nat => s n + 0) = s ). apply funextfun. intro n. apply ringrunax1. } exact ( tpair ( fpszero R ) a ). Defined. Lemma isgropfpsplus ( R : commring ) : isgrop ( fpsplus R ). Proof. intros. unfold isgrop. assert ( invstruct ( fpsplus R ) ( ismonoidopfpsplus R ) ) as a. { unfold invstruct. assert ( isinv (fpsplus R) (unel_is (ismonoidopfpsplus R)) ( fpsminus R ) ) as b. { unfold isinv. split. - unfold islinv. intro s. unfold fpsplus. unfold fpsminus. unfold unel_is. simpl. unfold fpszero. apply funextfun. intro n. exact ( ringlinvax1 R ( s n ) ). - unfold isrinv. intro s. unfold fpsplus. unfold fpsminus. unfold unel_is. simpl. unfold fpszero. apply funextfun. intro n. exact ( ringrinvax1 R ( s n ) ). } exact ( tpair ( fpsminus R ) b ). } exact ( tpair ( ismonoidopfpsplus R ) a ). Defined. Lemma iscommfpsplus ( R : commring ) : iscomm ( fpsplus R ). Proof. intros. unfold iscomm. intros s t. unfold fpsplus. change ((fun n : nat => s n + t n) = (fun n : nat => t n + s n) ). apply funextfun. intro n. set (H1:= pr2 (pr1 (pr1 (pr1 (pr2 R))))). apply H1. (* apply R. *) Defined. Lemma isassocfpstimes ( R : commring ) : isassoc (fpstimes R). Proof. intros. unfold isassoc. intros s t u. unfold fpstimes. assert ( (fun n : nat => natsummation0 n (fun x : nat => natsummation0 ( sub n x) (fun x0 : nat => s x * ( t x0 * u ( sub ( sub n x ) x0) )))) = (fun n : nat => natsummation0 n (fun x : nat => s x * natsummation0 ( sub n x) (fun x0 : nat => t x0 * u ( sub ( sub n x ) x0)))) ) as A. { apply funextfun. intro n. apply natsummationpathsupperfixed. intros. rewrite natsummationtimesdistr. apply idpath. } rewrite <- A. assert ( (fun n : nat => natsummation0 n (fun x : nat => natsummation0 ( sub n x) (fun x0 : nat => s x * t x0 * u ( sub ( sub n x ) x0 )))) = (fun n : nat => natsummation0 n (fun x : nat => natsummation0 ( sub n x) (fun x0 : nat => s x * ( t x0 * u ( sub ( sub n x ) x0) )))) ) as B. { apply funextfun. intro n. apply maponpaths. apply funextfun. intro m. apply maponpaths. apply funextfun. intro x. apply R. } assert ( (fun n : nat => natsummation0 n (fun x : nat => natsummation0 x (fun x0 : nat => s x0 * t ( sub x x0 ) * u ( sub n x )))) = (fun n : nat => natsummation0 n (fun x : nat => natsummation0 ( sub n x) (fun x0 : nat => s x * t x0 * u ( sub ( sub n x ) x0 )))) ) as C. { apply funextfun. intro n. set ( f := fun x : nat => ( fun x0 : nat => s x * t x0 * u ( sub ( sub n x ) x0 ) ) ). assert ( natsummation0 n ( fun x : nat => natsummation0 x ( fun x0 : nat => f x0 ( sub x x0 ) ) ) = natsummation0 n ( fun x : nat => natsummation0 ( sub n x ) ( fun x0 : nat => f x x0 ) ) ) as D by apply natsummationswap. unfold f in D. assert ( natsummation0 n ( fun x : nat => natsummation0 x ( fun x0 : nat => s x0 * t ( sub x x0 ) * u ( sub n x ) ) ) = natsummation0 n ( fun x : nat => natsummation0 x ( fun x0 : nat => s x0 * t ( sub x x0 ) * u ( sub ( sub n x0 ) ( sub x x0 ) ) ) ) ) as E. { apply natsummationpathsupperfixed. intros k p. apply natsummationpathsupperfixed. intros l q. rewrite ( natdoubleminus p q ). apply idpath. } rewrite E, D. apply idpath. } rewrite <- B. rewrite <- C. assert ( (fun n : nat => natsummation0 n (fun x : nat => natsummation0 x (fun x0 : nat => s x0 * t ( sub x x0)) * u ( sub n x))) = (fun n : nat => natsummation0 n (fun x : nat => natsummation0 x (fun x0 : nat => s x0 * t ( sub x x0) * u ( sub n x)))) ) as D. { apply funextfun. intro n. apply maponpaths. apply funextfun. intro m. apply natsummationtimesdistl. } rewrite <- D. apply idpath. Defined. Lemma natsummationandfpszero ( R : commring ) : forall m : nat, natsummation0 m ( fun x : nat => fpszero R x ) = @ringunel1 R. Proof. intros m. induction m. - apply idpath. - simpl. rewrite IHm. rewrite ( ringlunax1 R ). apply idpath. Defined. Lemma ismonoidopfpstimes ( R : commring ) : ismonoidop ( fpstimes R ). Proof. intros. unfold ismonoidop. split. - apply isassocfpstimes. - split with ( fpsone R). split. + intro s. unfold fpstimes. change ( ( fun n : nat => natsummation0 n ( fun x : nat => fpsone R x * s ( sub n x ) ) ) = s ). apply funextfun. intro n. destruct n. * simpl. rewrite ( ringlunax2 R ). apply idpath. * rewrite natsummationshift0. rewrite ( ringlunax2 R). rewrite minus0r. assert ( natsummation0 n ( fun x : nat => fpsone R ( S x ) * s ( sub n x ) ) = natsummation0 n ( fun x : nat => fpszero R x ) ) as f. { apply natsummationpathsupperfixed. intros m m'. rewrite ( ringmult0x R ). apply idpath. } change ( natsummation0 n ( fun x : nat => fpsone R ( S x ) * s ( sub n x ) ) + s ( S n ) = s ( S n ) ). rewrite f. rewrite natsummationandfpszero. apply ( ringlunax1 R ). + intros s. unfold fpstimes. change ( ( fun n : nat => natsummation0 n ( fun x : nat => s x * fpsone R ( sub n x ) ) ) = s ). apply funextfun. intro n. destruct n. * simpl. rewrite ( ringrunax2 R ). apply idpath. * change ( natsummation0 n ( fun x : nat => s x * fpsone R ( sub ( S n ) x ) ) + s ( S n ) * fpsone R ( sub n n ) = s ( S n ) ). rewrite minusnn0. rewrite ( ringrunax2 R ). assert ( natsummation0 n ( fun x : nat => s x * fpsone R ( sub ( S n ) x )) = ( natsummation0 n ( fun x : nat => fpszero R x ) ) ) as f. { apply natsummationpathsupperfixed. intros m m'. rewrite <- pathssminus. -- rewrite ( ringmultx0 R ). apply idpath. -- apply ( natlehlthtrans _ n ). ++ assumption. ++ apply natlthnsn. } rewrite f. rewrite natsummationandfpszero. apply ( ringlunax1 R ). Defined. Lemma iscommfpstimes ( R : commring ) ( s t : fps R ) : fpstimes R s t = fpstimes R t s. Proof. intros. unfold fpstimes. change ( ( fun n : nat => natsummation0 n (fun x : nat => s x * t ( sub n x) ) ) = ( fun n : nat => natsummation0 n (fun x : nat => t x * s ( sub n x) ) ) ). apply funextfun. intro n. assert ( natsummation0 n ( fun x : nat => s x * t ( sub n x ) ) = natsummation0 n ( fun x : nat => t ( sub n x ) * s x ) ) as a0. { apply maponpaths. apply funextfun. intro m. apply R. } assert ( ( natsummation0 n ( fun x : nat => t ( sub n x ) * s x ) ) = natsummation0 n ( funcomp ( nattruncreverse n ) ( fun x : nat => t x * s ( sub n x ) ) ) ) as a1. { apply natsummationpathsupperfixed. intros m q. unfold funcomp. unfold nattruncreverse. destruct (natgthorleh m n ). - apply fromempty. apply isirreflnatlth with ( n := n ). apply natlthlehtrans with ( m := m ). + apply h. + assumption. - apply maponpaths. apply maponpaths. apply pathsinv0. apply doubleminuslehpaths. assumption. } assert ( natsummation0 n ( funcomp ( nattruncreverse n ) ( fun x : nat => t x * s ( sub n x ) ) ) = natsummation0 n ( fun x : nat => t x * s ( sub n x ) ) ) as a2. { apply pathsinv0. apply natsummationreindexing. apply nattruncreverseisnattruncauto. } exact ( pathscomp0 a0 ( pathscomp0 a1 a2 ) ). Defined. Lemma isldistrfps ( R : commring ) ( s t u : fps R ) : fpstimes R s ( fpsplus R t u ) = fpsplus R ( fpstimes R s t ) ( fpstimes R s u ). Proof. intros. unfold fpstimes. unfold fpsplus. change ((fun n : nat => natsummation0 n (fun x : nat => s x * (t (sub n x) + u ( sub n x)))) = (fun n : nat => natsummation0 n (fun x : nat => s x * t (sub n x)) + natsummation0 n (fun x : nat => s x * u (sub n x)))). apply funextfun. intro upper. assert ( natsummation0 upper ( fun x : nat => s x * ( t ( sub upper x ) + u ( sub upper x ) ) ) = natsummation0 upper ( fun x : nat => ( ( s x * t ( sub upper x ) ) + ( s x * u ( sub upper x ) ) ) ) ) as a0. { apply maponpaths. apply funextfun. intro n. apply R. } assert ( natsummation0 upper ( fun x : nat => ( ( s x * t ( sub upper x ) ) + ( s x * u ( sub upper x ) ) ) ) = natsummation0 upper ( fun x : nat => s x * t ( sub upper x ) ) + natsummation0 upper ( fun x : nat => s x * u ( sub upper x ) ) ) as a1 by apply natsummationplusdistr. exact ( pathscomp0 a0 a1 ). Defined. Lemma isrdistrfps ( R : commring ) ( s t u : fps R ) : fpstimes R ( fpsplus R t u ) s = fpsplus R ( fpstimes R t s ) ( fpstimes R u s ). Proof. intros. unfold fpstimes. unfold fpsplus. change ((fun n : nat => natsummation0 n (fun x : nat => (t x + u x) * s ( sub n x ))) = (fun n : nat => natsummation0 n (fun x : nat => t x * s ( sub n x ) ) + natsummation0 n (fun x : nat => u x * s ( sub n x ) ) ) ). apply funextfun. intro upper. assert ( natsummation0 upper ( fun x : nat => ( t x + u x ) * s ( sub upper x ) ) = natsummation0 upper ( fun x : nat => ( t x * s ( sub upper x ) ) + ( u x * s ( sub upper x ) ) ) ) as a0. { apply maponpaths. apply funextfun. intro n. apply R. } assert ( natsummation0 upper ( fun x : nat => ( ( t x * s ( sub upper x ) ) + ( u x * s ( sub upper x ) ) ) ) = natsummation0 upper ( fun x : nat => t x * s ( sub upper x ) ) + natsummation0 upper ( fun x : nat => u x * s ( sub upper x ) ) ) as a1 by apply natsummationplusdistr. exact ( pathscomp0 a0 a1 ). Defined. Definition fpsring ( R : commring ) := make_setwith2binop ( make_hSet ( seqson R ) ( isasetfps R ) ) ( make_dirprod ( fpsplus R ) ( fpstimes R ) ). Theorem fpsiscommring ( R : commring ) : iscommring ( fpsring R ). Proof. unfold iscommring. unfold iscommringops. split. - unfold isringops. split. + split. * unfold isabgrop. -- split. ++ exact ( isgropfpsplus R ). ++ exact ( iscommfpsplus R ). * exact ( ismonoidopfpstimes R ). + unfold isdistr. * split. -- unfold isldistr. intros. apply ( isldistrfps R ). -- unfold isrdistr. intros. apply ( isrdistrfps R ). - unfold iscomm. intros. apply ( iscommfpstimes R ). Defined. Definition fpscommring ( R : commring ) : commring := make_commring ( fpsring R ) ( fpsiscommring R ). Definition fpsshift { R : commring } ( a : fpscommring R ) : fpscommring R := fun n : nat => a ( S n ). Lemma fpsshiftandmult { R : commring } ( a b : fpscommring R ) ( p : b 0%nat = 0 ) : forall n : nat, ( a * b ) ( S n ) = ( a * ( fpsshift b ) ) n. Proof. intros. induction n. - change ( a * b ) with ( fpstimes R a b ). change ( a * fpsshift b ) with ( fpstimes R a ( fpsshift b ) ). unfold fpstimes. unfold fpsshift. simpl. rewrite p. rewrite ( ringmultx0 R ). rewrite ( ringrunax1 R ). apply idpath. - change ( a * b ) with ( fpstimes R a b ). change ( a * fpsshift b ) with ( fpstimes R a ( fpsshift b ) ). unfold fpsshift. unfold fpstimes. change ( natsummation0 (S (S n)) (fun x : nat => a x * b (sub ( S (S n) ) x)) ) with ( natsummation0 ( S n ) ( fun x : nat => a x * b ( sub ( S ( S n ) ) x ) ) + a ( S ( S n ) ) * b ( sub ( S ( S n ) ) ( S ( S n ) ) ) ). rewrite minusnn0. rewrite p. rewrite ( ringmultx0 R ). rewrite ringrunax1. apply natsummationpathsupperfixed. intros x j. apply maponpaths. apply maponpaths. rewrite pathssminus. + apply idpath. + apply ( natlehlthtrans _ ( S n ) _ ). * assumption. * apply natlthnsn. Defined. (** * IV. Apartness relation on formal power series *) Lemma apartbinarysum0 ( R : acommring ) ( a b : R ) ( p : a + b # 0 ) : a # 0 ∨ b # 0. Proof. intros. intros P s. use ( hinhuniv _ ( acommring_acotrans R ( a + b ) a 0 p ) ). intro k. destruct k as [ l | r ]. - apply s. apply ii2. assert ( a + b # a ) as l' by apply l. assert ( ( a + b ) # ( a + 0 ) ) as l''. { rewrite ringrunax1. assumption. } apply ( pr1 ( acommring_aadd R ) a b 0 ). assumption. - apply s. apply ii1. assumption. Defined. Lemma apartnatsummation0 ( R : acommring ) ( upper : nat ) ( f : nat -> R ) ( p : ( natsummation0 upper f ) # 0 ) : ∃ n : nat, natleh n upper × f n # 0. Proof. revert f p. induction upper. - simpl. intros. intros P s. apply s. split with 0%nat. split. + apply idpath. + assumption. - intros. intros P s. simpl in p. use ( hinhuniv _ (apartbinarysum0 R _ _ p ) ). intro k. destruct k as [ l | r ]. + use ( hinhuniv _ (IHupper f l ) ). intro k. destruct k as [ n ab ]. destruct ab as [ a b ]. apply s. split with n. split. * apply ( istransnatleh( m := upper ) ). -- assumption. -- apply natlthtoleh. apply natlthnsn. * assumption. + apply s. split with ( S upper ). split. * apply isreflnatleh. * assumption. Defined. Definition fpsapart0 ( R : acommring ) : hrel ( fpscommring R ) := fun s t : fpscommring R => ∃ n : nat, s n # t n. Definition fpsapart ( R : acommring ) : apart ( fpscommring R ). Proof. intros. split with ( fpsapart0 R ). split. - intros s f. assert ( hfalse ) as i. { use (hinhuniv _ f). intro k. destruct k as [ n p ]. apply (acommring_airrefl R ( s n ) p). } apply i. - split. + intros s t p P j. use (hinhuniv _ p). intro k. destruct k as [ n q ]. apply j. split with n. apply ( acommring_asymm R ( s n ) ( t n ) q ). + intros s t u p P j. use (hinhuniv _ p). intro k. destruct k as [ n q ]. use ( hinhuniv _ (acommring_acotrans R ( s n ) ( t n ) ( u n ) q ) ). intro l. destruct l as [ l | r ]. * apply j. apply ii1. intros v V. apply V. split with n. assumption. * apply j. apply ii2. intros v V. apply V. split with n. assumption. Defined. Lemma fpsapartisbinopapartplusl ( R : acommring ) : isbinopapartl ( fpsapart R ) ( @op1 ( fpscommring R ) ). Proof. intros. intros a b c p. intros P s. use (hinhuniv _ p). intro k. destruct k as [ n q ]. apply s. change ( ( a + b ) n ) with ( ( a n ) + ( b n ) ) in q. change ( ( a + c ) n ) with ( ( a n ) + ( c n ) ) in q. split with n. apply ( pr1 ( acommring_aadd R ) ( a n ) ( b n ) ( c n ) q ). Defined. Lemma fpsapartisbinopapartplusr ( R : acommring ) : isbinopapartr ( fpsapart R ) ( @op1 ( fpscommring R ) ). Proof. intros. intros a b c p. rewrite ( ringcomm1 ( fpscommring R ) ) in p. rewrite ( ringcomm1 ( fpscommring R ) c ) in p. apply ( fpsapartisbinopapartplusl _ a b c ). assumption. Defined. Lemma fpsapartisbinopapartmultl ( R : acommring ) : isbinopapartl ( fpsapart R ) ( @op2 ( fpsring R ) ). Proof. intros. intros a b c p. intros P s. use (hinhuniv _ p). intro k. destruct k as [ n q ]. change ( ( a * b ) n ) with ( natsummation0 n ( fun x : nat => a x * b ( sub n x ) ) ) in q. change ( ( a * c ) n ) with ( natsummation0 n ( fun x : nat => a x * c ( sub n x ) ) ) in q. assert ( natsummation0 n ( fun x : nat => ( a x * b ( sub n x ) - ( a x * c ( sub n x ) ) ) ) # 0 ) as q'. { assert ( natsummation0 n ( fun x : nat => ( a x * b ( sub n x ) ) ) - natsummation0 n ( fun x : nat => ( a x * c ( sub n x ) ) ) # 0 ) as q''. { apply aaminuszero. assumption. } assert ( (fun x : nat => a x * b (sub n x) - a x * c ( sub n x)) = (fun x : nat => a x * b ( sub n x) + ( - 1%ring ) * ( a x * c ( sub n x)) ) ) as i. { apply funextfun. intro x. apply maponpaths. rewrite <- ( ringmultwithminus1 R ). apply idpath. } rewrite i. rewrite natsummationplusdistr. rewrite <- ( natsummationtimesdistr n ( fun x : nat => a x * c ( sub n x ) ) ( - 1%ring ) ). rewrite ( ringmultwithminus1 R ). assumption. } use ( hinhuniv _ ( apartnatsummation0 R n _ q' ) ). intro k. destruct k as [ m g ]. destruct g as [ g g' ]. apply s. split with ( sub n m ). apply ( pr1 ( acommring_amult R ) ( a m ) ( b ( sub n m ) ) ( c ( sub n m ) ) ). apply aminuszeroa. assumption. Defined. Lemma fpsapartisbinopapartmultr ( R : acommring ) : isbinopapartr ( fpsapart R ) ( @op2 ( fpsring R ) ). Proof. intros. intros a b c p. rewrite ( ringcomm2 ( fpscommring R ) ) in p. rewrite ( ringcomm2 ( fpscommring R ) c ) in p. apply ( fpsapartisbinopapartmultl _ a b c ). assumption. Defined. Definition acommringfps ( R : acommring ) : acommring. Proof. intros. split with ( fpscommring R ). split with ( fpsapart R ). split. - split. + apply ( fpsapartisbinopapartplusl R). + apply ( fpsapartisbinopapartplusr R ). - split. + apply ( fpsapartisbinopapartmultl R ). + apply ( fpsapartisbinopapartmultr R ). Defined. Definition isacommringapartdec ( R : acommring ) := isapartdec ( pr1 ( pr2 R ) ). Lemma leadingcoefficientapartdec ( R : aintdom ) ( a : fpscommring R ) ( is : isacommringapartdec R ) ( p : a 0%nat # 0 ) : forall n : nat, forall b : fpscommring R, ( b n # 0 ) -> acommringapartrel ( acommringfps R ) ( a * b ) 0. Proof. intros n. induction n. - intros b q. intros P s. apply s. split with 0%nat. change ( ( a * b ) 0%nat ) with ( ( a 0%nat ) * ( b 0%nat ) ). apply R; assumption. - intros b q. destruct ( is ( b 0%nat ) 0 ) as [ left | right ]. + intros P s. apply s. split with 0%nat. change ( ( a * b ) 0%nat ) with ( ( a 0%nat ) * ( b 0%nat ) ). apply R; assumption. + assert ( acommringapartrel ( acommringfps R ) ( a * ( fpsshift b ) ) 0 ) as j. { apply IHn. unfold fpsshift. assumption. } use (hinhuniv _ j). intro k. destruct k as [ k i ]. intros P s. apply s. rewrite <- ( fpsshiftandmult a b right k ) in i. split with ( S k ). assumption. Defined. Lemma apartdecintdom0 ( R : aintdom ) ( is : isacommringapartdec R ) : forall n : nat, forall a b : fpscommring R, ( a n # 0 ) -> acommringapartrel ( acommringfps R ) b 0 -> acommringapartrel ( acommringfps R ) ( a * b ) 0. Proof. intros n. induction n. - intros a b p q. use (hinhuniv _ q). intros k. destruct k as [ k k0 ]. apply ( leadingcoefficientapartdec R a is p k ). assumption. - intros a b p q. destruct ( is ( a 0%nat ) 0 ) as [ left | right ]. + use (hinhuniv _ q). intros k. destruct k as [ k k0 ]. apply ( leadingcoefficientapartdec R a is left k ). assumption. + assert ( acommringapartrel ( acommringfps R ) ( ( fpsshift a ) * b ) 0 ) as i. { apply IHn. * unfold fpsshift. assumption. * assumption. } use (hinhuniv _ i). intros k. destruct k as [ k k0 ]. intros P s. apply s. split with ( S k ). rewrite ringcomm2. rewrite fpsshiftandmult. * rewrite ringcomm2. assumption. * assumption. Defined. Theorem apartdectoisaintdomfps ( R : aintdom ) ( is : isacommringapartdec R ) : aintdom. Proof. revert is. split with ( acommringfps R ). split. - intros P s. apply s. split with 0%nat. change ( @ringunel1 ( fpscommring R ) 0%nat ) with ( @ringunel1 R ). change ( @ringunel2 R # ( @ringunel1 R ) ). apply R. - intros a b p q. use (hinhuniv _ p). intro n. destruct n as [ n n0 ]. apply ( apartdecintdom0 R is n); assumption. Defined. Close Scope ring_scope. (** END OF FILE *) UniMath-20231010/UniMath/PAdics/frac.v000066400000000000000000000477201451125700300171330ustar00rootroot00000000000000(** *The Heyting field of fractions for an apartness domain *) (** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) (** February 2011 and August 2012 *) (** made compatible with the current UniMath library by Ralph Matthes in October 2017 *) (** Imports *) Require Import UniMath.PAdics.lemmas. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Domains_and_Fields. (** * I. The field of fractions for an integrable domain with an apartness relation *) Local Open Scope ring_scope. Section aint. Variable A : aintdom. Ltac permute := solve [ repeat rewrite ringassoc2; match goal with | [ |- ?X = ?X ] => apply idpath | [ |- ?X * ?Y = ?X * ?Z ] => apply maponpaths; permute | [ |- ?Y * ?X = ?Z * ?X ] => apply ( maponpaths ( fun x => x * X ) ); permute | [ |- ?X * ?Y = ?Y * ?X ] => apply ringcomm2 | [ |- ?X * ?Y = ?K ] => solve [ repeat rewrite <- ringassoc2; match goal with | [ |- ?H = ?V * X ] => rewrite ( @ringcomm2 A V X ); repeat rewrite ringassoc2; apply maponpaths; permute end | repeat rewrite ringassoc2; match goal with | [ |- ?H = ?Z * ?V ] => repeat rewrite <- ringassoc2; match goal with | [ |- ?W * Z = ?L ] => rewrite ( @ringcomm2 A W Z ); repeat rewrite ringassoc2; apply maponpaths; permute end end ] | [ |- ?X * ( ?Y * ?Z ) = ?K ] => rewrite ( @ringcomm2 A Y Z ); permute end | repeat rewrite <- ringassoc2; match goal with | [ |- ?X * ?Y = ?X * ?Z ] => apply maponpaths; permute | [ |- ?Y * ?X = ?Z * ?X ] => apply ( maponpaths ( fun x => x * X ) ); permute | [ |- ?X * ?Y = ?Y * ?X ] => apply ringcomm2 end | apply idpath | idtac "The tactic permute does not apply to the current goal!" ]. Lemma azerorelcomp ( cd : A × aintdomazerosubmonoid A ) ( ef : A × aintdomazerosubmonoid A ) ( p : pr1 cd * pr1 ( pr2 ef ) = pr1 ef * pr1 ( pr2 cd ) ) ( q : pr1 cd # 0 ) : pr1 ef # 0. Proof. intros. change ( @op2 A ( pr1 cd ) ( pr1 ( pr2 ef ) ) = @op2 A ( pr1 ef ) ( pr1 ( pr2 cd ) ) ) in p. assert ( ( @op2 A ( pr1 cd ) ( pr1 ( pr2 ef ) ) ) # 0 ) as v. { apply A. - assumption. - apply ( pr2 ( pr2 ef ) ). } rewrite p in v. apply ( pr1 ( timesazero v ) ). Defined. Lemma azerolmultcomp { a b c : A } ( p : a # 0 ) ( q : b # c ) : a * b # a * c. Proof. intros. apply aminuszeroa. rewrite <- ringminusdistr. apply ( pr2 A ). - assumption. - apply aaminuszero. assumption. Defined. Lemma azerormultcomp { a b c : A } ( p : a # 0 ) ( q : b # c ) : b * a # c * a. Proof. intros. rewrite ( @ringcomm2 A b ). rewrite ( @ringcomm2 A c ). apply ( azerolmultcomp p q ). Defined. Definition afldfracapartrelpre : hrel ( A × aintdomazerosubmonoid A ) := fun ab cd => ( pr1 ab * pr1 ( pr2 cd ) ) # ( pr1 cd * pr1 ( pr2 ab ) ). Lemma afldfracapartiscomprel : iscomprelrel ( eqrelcommringfrac A ( aintdomazerosubmonoid A ) ) ( afldfracapartrelpre ). Proof. intros ab cd ef gh p q. unfold afldfracapartrelpre. destruct ab as [ a b ]. destruct b as [ b b' ]. destruct cd as [ c d ]. destruct d as [ d d' ]. destruct ef as [ e f ]. destruct f as [ f f' ]. destruct gh as [ g h ]. destruct h as [ h h' ]. simpl in *. apply hPropUnivalence. - intro u. apply p. intro p'. apply q. intro q'. destruct p' as [ p' j ]. destruct p' as [ i p' ]. destruct q' as [ q' j']. destruct q' as [ i' q' ]. simpl in *. assert ( a * f * d * i * h * i' # e * b * d * i * h * i') as v0. { assert ( a * f * d # e * b * d ) as v0. { apply azerormultcomp. + apply d'. + assumption. } assert ( a * f * d * i # e * b * d * i ) as v1 by (apply azerormultcomp; assumption). assert ( a * f * d * i * h # e * b * d * i * h ) as v2 by (apply azerormultcomp; assumption). apply azerormultcomp; assumption. } apply ( pr2 ( acommring_amult A ) b ). apply ( pr2 ( acommring_amult A ) f ). apply ( pr2 ( acommring_amult A ) i ). apply ( pr2 ( acommring_amult A ) i' ). assert ( a * f * d * i * h * i' = c * h * b * f * i * i' ) as l. { assert ( a * f * d * i * h * i' = a * d * i * f * h * i' ) as l0. { change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A a f ) d ) i ) h ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A a d ) i ) f ) h ) i' ). permute. } rewrite l0. rewrite j. change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A c b ) i ) f ) h ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A c h ) b ) f ) i ) i' ). permute. } rewrite l in v0. assert ( e * b * d * i * h * i' = g * d * b * f * i * i' ) as k. { assert ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A e b ) d ) i ) h ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A e h ) i' ) i ) b ) d ) as k0 by permute. change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A e b ) d ) i ) h ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A g d ) b ) f ) i ) i' ). rewrite k0. assert ( @op2 A ( @op2 A e h ) i' = @op2 A ( @op2 A g f ) i' ) as j'' by assumption. rewrite j''. permute. } rewrite k in v0. assumption. - intro u. apply p. intro p'. apply q. intro q'. destruct p' as [ p' j ]. destruct p' as [ i p' ]. destruct q' as [ q' j' ]. destruct q' as [ i' q' ]. simpl in *. assert ( c * h * b * f * i * i' # g * d * b * f * i * i' ) as v. { apply azerormultcomp. + apply q'. + apply azerormultcomp. * apply p'. * apply azerormultcomp. -- apply f'. -- apply azerormultcomp. ++ apply b'. ++ assumption. } apply ( pr2 ( acommring_amult A ) d ). apply ( pr2 ( acommring_amult A ) h ). apply ( pr2 ( acommring_amult A ) i ). apply ( pr2 ( acommring_amult A ) i' ). assert ( c * h * b * f * i * i' = a * f * d * h * i * i' ) as k. { assert ( c * h * b * f * i * i' = c * b * i * f * h * i' ) as k0. { change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A c h ) b ) f ) i ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A c b ) i ) f ) h ) i' ). permute. } rewrite k0. rewrite <- j. change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A a d ) i ) f ) h ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A a f ) d ) h ) i ) i' ). permute. } rewrite k in v. assert ( g * d * b * f * i * i' = e * b * d * h * i * i' ) as l. { assert ( g * d * b * f * i * i' = g * f * i' * d * i * b ) as l0. { change ( @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A g d ) b ) f ) i ) i' = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A g f ) i' ) d ) i ) b ). permute. } rewrite l0. rewrite <- j'. change (@op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A e h ) i' ) d ) i ) b = @op2 A ( @op2 A ( @op2 A ( @op2 A ( @op2 A e b ) d ) h ) i ) i' ). permute. } rewrite l in v. assumption. Defined. (** We now arrive at the apartness relation on the field of fractions itself.*) Definition afldfracapartrel := quotrel afldfracapartiscomprel. Lemma isirreflafldfracapartrelpre : isirrefl afldfracapartrelpre. Proof. intros ab. apply acommring_airrefl. Defined. Lemma issymmafldfracapartrelpre : issymm afldfracapartrelpre. Proof. intros ab cd. apply ( acommring_asymm A ). Defined. Lemma iscotransafldfracapartrelpre : iscotrans afldfracapartrelpre. Proof. intros ab cd ef p. destruct ab as [ a b ]. destruct b as [ b b' ]. destruct cd as [ c d ] . destruct d as [ d d' ] . destruct ef as [ e f ]. destruct f as [ f f' ]. assert ( a * f * d # e * b * d ) as v. { apply azerormultcomp; assumption. } use (hinhuniv _ ( acommring_acotrans A ( a * f * d ) ( c * b * f ) ( e * b * d ) v )). intro u. intros P k. apply k. unfold afldfracapartrelpre in *. simpl in *. destruct u as [ left | right ]. - apply ii1. apply ( pr2 ( acommring_amult A ) f ). assert ( @op2 A ( @op2 A a f ) d = @op2 A ( @op2 A a d ) f ) as i by permute. change ( @op2 A ( @op2 A a d ) f # @op2 A ( @op2 A c b ) f ). rewrite <- i. assumption. - apply ii2. apply ( pr2 ( acommring_amult A ) b ). assert ( @op2 A ( @op2 A c f ) b = @op2 A ( @op2 A c b ) f ) as i by permute. change ( @op2 A ( @op2 A c f ) b # @op2 A ( @op2 A e d ) b ). rewrite i. assert ( @op2 A ( @op2 A e d ) b = @op2 A ( @op2 A e b ) d ) as j by permute. change ( @op2 A ( @op2 A c b ) f # @op2 A ( @op2 A e d ) b ). rewrite j. assumption. Defined. Lemma isapartafldfracapartrel : isapart afldfracapartrel. Proof. intros. split. - apply isirreflquotrel. exact isirreflafldfracapartrelpre. - split. + apply issymmquotrel. exact issymmafldfracapartrelpre. + apply iscotransquotrel. exact iscotransafldfracapartrelpre. Defined. Definition afldfracapart : apart ( commringfrac A (aintdomazerosubmonoid A)). Proof. intros. unfold apart. split with afldfracapartrel. exact isapartafldfracapartrel. Defined. Lemma isbinapartlafldfracop1 : isbinopapartl afldfracapart op1. Proof. intros. unfold isbinopapartl. assert ( forall a b c : commringfrac A ( aintdomazerosubmonoid A ), isaprop ( pr1 (afldfracapart) ( commringfracop1 A ( aintdomazerosubmonoid A ) a b) ( commringfracop1 A ( aintdomazerosubmonoid A ) a c) -> pr1 (afldfracapart ) b c) ) as int. { intros a b c. apply impred. intro p. apply ( pr1 ( afldfracapart ) b c ). } apply ( setquotuniv3prop _ ( fun a b c => make_hProp _ ( int a b c ) ) ). intros ab cd ef p. destruct ab as [ a b ]. destruct b as [ b b' ]. destruct cd as [ c d ]. destruct d as [ d d' ]. destruct ef as [ e f ]. destruct f as [ f f' ]. unfold afldfracapart in *. simpl. unfold afldfracapartrel. unfold quotrel. rewrite setquotuniv2comm. unfold afldfracapartrelpre. simpl. assert ( afldfracapartrelpre ( make_dirprod ( @op1 A ( @op2 A d a ) ( @op2 A b c ) ) ( @op ( aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair d d' ) ) ) ( make_dirprod ( @op1 A ( @op2 A f a ) ( @op2 A b e ) ) ( @op ( aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair f f' ) ) ) ) as u by apply p. unfold afldfracapartrelpre in u. simpl in u. rewrite 2! ( @ringrdistr A ) in u. do 4 rewrite <- ringassoc2 in u. assert ( (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) d a) b) f) = (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) f a) b) d) ) as i by permute. rewrite i in u. assert ( (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) b c) b) f) = (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) c f) b) b) ) as j by permute. rewrite j in u. assert ( (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) b e) b) d) = (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (pr1ring (commringtoring (acommringtocommring (pr1aintdom A)))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) e d) b) b) ) as j' by permute. rewrite j' in u. apply ( pr2 ( acommring_amult A ) b ). apply ( pr2 ( acommring_amult A ) b ). apply ( pr1 ( acommring_aadd A) ( f * a * b * d ) ). assumption. Defined. Lemma isbinapartrafldfracop1 : isbinopapartr afldfracapart op1. Proof. intros a b c. rewrite ringcomm1. rewrite ( ringcomm1 _ c ). apply isbinapartlafldfracop1. Defined. Lemma isbinapartlafldfracop2 : isbinopapartl afldfracapart op2. Proof. intros. unfold isbinopapartl. assert ( forall a b c : commringfrac A ( aintdomazerosubmonoid A ), isaprop ( pr1 (afldfracapart ) ( commringfracop2 A ( aintdomazerosubmonoid A ) a b) ( commringfracop2 A ( aintdomazerosubmonoid A ) a c) -> pr1 (afldfracapart ) b c) ) as int. { intros a b c. apply impred. intro p. apply ( pr1 ( afldfracapart ) b c ). } apply ( setquotuniv3prop _ ( fun a b c => make_hProp _ ( int a b c ) ) ). intros ab cd ef p. destruct ab as [ a b ]. destruct b as [ b b' ]. destruct cd as [ c d ]. destruct d as [ d d' ]. destruct ef as [ e f ]. destruct f as [ f f' ]. assert ( afldfracapartrelpre ( make_dirprod ( ( a * c ) ) ( @op ( aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair d d' ) ) ) ( make_dirprod ( a * e ) ( @op ( aintdomazerosubmonoid A ) ( tpair b b' ) ( tpair f f' ) ) ) ) as u by apply p. unfold afldfracapart in *. simpl. unfold afldfracapartrel. unfold quotrel. rewrite ( setquotuniv2comm ( eqrelcommringfrac A ( aintdomazerosubmonoid A ) ) ). unfold afldfracapartrelpre in *. simpl. simpl in u. apply ( pr2 ( acommring_amult A ) a ). apply ( pr2 ( acommring_amult A ) b ). assert ( c * f * a * b = (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) a c) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) b f)) ) as i. { change ( c * f * a * b = a * c * ( b * f ) ). permute. } change ( c * f * a * b # e * d * a * b ). rewrite i. assert ( e * d * a * b = (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) a e) (@op2 (@pr1 setwith2binop (fun X : setwith2binop => @iscommringops (pr1setwith2binop X) (@op1 X) (@op2 X)) (acommringtocommring (pr1aintdom A))) b d)) ) as i'. { change ( e * d * a * b = a * e * ( b * d ) ). permute. } rewrite i'. assumption. Defined. Lemma isbinapartrafldfracop2 : isbinopapartr (afldfracapart ) op2. Proof. intros a b c. rewrite ringcomm2. rewrite ( ringcomm2 _ c ). apply isbinapartlafldfracop2. Defined. Definition afldfrac0 : acommring. Proof. split with ( commringfrac A ( aintdomazerosubmonoid A ) ). split with afldfracapart. split. - split. + apply isbinapartlafldfracop1. + apply isbinapartrafldfracop1. - split. + apply isbinapartlafldfracop2. + apply isbinapartrafldfracop2. Defined. Definition afldfracmultinvint ( ab : A × aintdomazerosubmonoid A ) ( is : afldfracapartrelpre ab ( make_dirprod ( @ringunel1 A ) ( unel ( aintdomazerosubmonoid A ) ) ) ) : A × aintdomazerosubmonoid A. Proof. intros. destruct ab as [ a b ]. destruct b as [ b b' ]. split with b. simpl in is. split with a. unfold afldfracapartrelpre in is. simpl in is. change ( a # 0 ). rewrite ( @ringmult0x A ) in is. rewrite ( @ringrunax2 A ) in is. assumption. Defined. Definition afldfracmultinv ( a : afldfrac0 ) ( is : a # 0 ) : multinvpair afldfrac0 a. Proof. intros. assert ( forall b : afldfrac0, isaprop ( b # 0 -> multinvpair afldfrac0 b ) ) as int. { intros. apply impred. intro p. apply ( isapropmultinvpair afldfrac0 ). } assert ( forall b : afldfrac0, b # 0 -> multinvpair afldfrac0 b ) as p. { apply ( setquotunivprop _ ( fun x0 => make_hProp _ ( int x0 ) ) ). intros bc q. destruct bc as [ b c ]. assert ( afldfracapartrelpre ( make_dirprod b c ) ( make_dirprod ( @ringunel1 A ) ( unel (aintdomazerosubmonoid A ) ) ) ) as is' by apply q. split with (setquotpr (eqrelcommringfrac A (aintdomazerosubmonoid A)) (afldfracmultinvint ( make_dirprod b c ) is' ) ). split. - change ( setquotpr ( eqrelcommringfrac A ( aintdomazerosubmonoid A ) ) ( make_dirprod ( @op2 A ( pr1 ( afldfracmultinvint ( make_dirprod b c ) is' ) ) b ) ( @op ( aintdomazerosubmonoid A ) ( pr2 ( afldfracmultinvint ( make_dirprod b c ) is' ) ) c ) ) = ( commringfracunel2 A ( aintdomazerosubmonoid A ) ) ). apply iscompsetquotpr. unfold commringfracunel2int. destruct c as [ c c' ]. simpl. apply total2tohexists. split with ( make_carrier ( fun x : pr1 A => x # 0 ) 1 ( pr1 ( pr2 A ) ) ). simpl. rewrite 3! ( @ringrunax2 A ). rewrite ( @ringlunax2 A ). apply ( @ringcomm2 A ). - change ( setquotpr ( eqrelcommringfrac A ( aintdomazerosubmonoid A ) ) ( make_dirprod ( @op2 A b ( pr1 ( afldfracmultinvint ( make_dirprod b c ) is' ) ) ) ( @op ( aintdomazerosubmonoid A ) c ( pr2 ( afldfracmultinvint ( make_dirprod b c ) is' ) ) ) ) = ( commringfracunel2 A ( aintdomazerosubmonoid A ) ) ). apply iscompsetquotpr. destruct c as [ c c' ]. simpl. apply total2tohexists. split with ( make_carrier ( fun x : pr1 A => x # 0 ) 1 ( pr1 ( pr2 A ) ) ). simpl. rewrite 3! ( @ringrunax2 A ). rewrite ( @ringlunax2 A ). apply ( @ringcomm2 A ). } apply p. assumption. Defined. Theorem afldfracisafld : isaafield afldfrac0. Proof. intros. split. - change ( afldfracapartrel ( @ringunel2 ( commringfrac A (aintdomazerosubmonoid A ) ) ) ( @ringunel1 ( commringfrac A ( aintdomazerosubmonoid A ) ) ) ). unfold afldfracapartrel. set ( aux := @op2 A ( @ringunel2 A ) ( @ringunel2 A ) # @op2 A ( @ringunel1 A ) ( @ringunel2 A ) ). cut (pr1 aux). (* [pr1] is needed here *) + intro v. apply v. + unfold aux. rewrite 2! ( @ringrunax2 A ). apply A. - intros a p. apply afldfracmultinv. assumption. Defined. Definition afldfrac := make_afld afldfrac0 afldfracisafld. End aint. Close Scope ring_scope. (** END OF FILE *) UniMath-20231010/UniMath/PAdics/lemmas.v000066400000000000000000001001441451125700300174640ustar00rootroot00000000000000(** *Fixing notation, terminology and basic lemmas *) (** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) (** made compatible with the current UniMath library again by Benedikt Ahrens in 2014 and by Ralph Matthes in 2017 *) (** Imports *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.Propositions. Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.Algebra.RigsAndRings. Require Import UniMath.Algebra.Domains_and_Fields. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.Algebra.Monoids. Unset Kernel Term Sharing. (** for quicker proof-checking, approx. by factor 25 *) (** Fixing some notation *) (** * Notation, terminology *) Arguments tpair [ T P ]. Definition neq ( X : UU ) : hrel X := fun x y : X => make_hProp (neg (x = y)) (isapropneg (x = y)). (** * I. Lemmas on natural numbers *) Lemma minus0r ( n : nat ) : sub n 0 = n. Proof. destruct n; apply idpath. Defined. Lemma minusnn0 ( n : nat ) : sub n n = 0%nat. Proof. induction n. - apply idpath. - assumption. Defined. Lemma minussn1 ( n : nat ) : sub ( S n ) 1 = n. Proof. destruct n; apply idpath. Defined. Lemma minussn1non0 ( n : nat ) ( p : natlth 0 n ) : S ( sub n 1 ) = n. Proof. revert p. destruct n. - intro p. apply fromempty. exact (isirreflnatlth 0%nat p ). - intro. apply maponpaths. apply minus0r. Defined. Lemma minusleh ( n m : nat ) : natleh ( sub n m ) n. Proof. revert m. induction n. - intros m. apply isreflnatleh. - intros m. destruct m. + apply isreflnatleh. + apply ( istransnatleh (IHn m)). apply natlthtoleh. apply natlthnsn. Defined. Lemma minus1leh { n m : nat } ( p : natlth 0 n ) ( q : natlth 0 m ) ( r : natleh n m ) : natleh ( sub n 1 ) ( sub m 1 ). Proof. revert m p q r. destruct n. - auto. - intros m p q r. destruct m. + apply fromempty. exact (isirreflnatlth 0%nat q ). + assert ( natleh n m ) as a. { apply r. } assert ( natleh ( sub n 0%nat ) m ) as a0. { exact (transportf ( fun x : nat => natleh x m ) ( pathsinv0 ( minus0r n ) ) a). } exact ( transportf ( fun x : nat => natleh ( sub n 0 ) x ) (pathsinv0 ( minus0r m ) ) a0 ). Defined. Lemma minuslth ( n m : nat ) ( p : natlth 0 n ) ( q : natlth 0 m ) : natlth ( sub n m ) n. Proof. revert m p q. destruct n. - auto. - intros m p q. destruct m. + apply fromempty. exact ( isirreflnatlth 0%nat q). + apply ( natlehlthtrans _ n _ ). * apply ( minusleh n m ). * apply natlthnsn. Defined. Lemma natlthsntoleh ( n m : nat ) : natlth m ( S n ) -> natleh m n. Proof. revert m. induction n. - intros m p. destruct m. + apply isreflnatleh. + assert ( natlth m 0 ) as q by apply p. apply fromempty. exact ( negnatgth0n m q ). - intros m p. destruct m. + apply natleh0n. + apply ( IHn m ). assumption. Defined. Lemma natlthminus0 { n m : nat } ( p : natlth m n ) : natlth 0 ( sub n m ). Proof. revert m p. induction n. - intros m p. apply fromempty. exact ( negnatlthn0 m p ). - intros m p. destruct m. + auto. + apply IHn. apply p. Defined. Lemma natlthsnminussmsn ( n m : nat ) ( p : natlth m n ) : natlth ( sub ( S n ) ( S m ) ) ( S n ). Proof. revert m p. induction n. - intros m p. apply fromempty. apply (negnatlthn0 m p). - intros m p. destruct m. + assert ( sub ( S ( S n ) ) 1 = S n ) as f. { destruct n. * auto. * auto. } rewrite f. apply natlthnsn. + apply ( istransnatlth _ ( S n ) _ ). * apply IHn. assumption. * apply natlthnsn. Defined. Lemma natlehsnminussmsn ( n m : nat ) ( p : natleh m n ) : natleh (sub ( S n ) ( S m ) ) ( S n ). Proof. revert m p. induction n. - intros m p. apply negnatgthtoleh. intro X. apply nopathsfalsetotrue. assumption. - intros m p. destruct m. + apply natlthtoleh. apply natlthnsn. + apply ( istransnatleh( m := S n ) ). * apply IHn. assumption. * apply natlthtoleh. apply natlthnsn. Defined. Lemma pathssminus ( n m : nat ) ( p : natlth m ( S n ) ) : S ( sub n m ) = sub ( S n ) m. Proof. revert m p. induction n. - intros m p. destruct m. + auto. + apply fromempty. apply nopathstruetofalse. apply pathsinv0. assumption. - intros m p. destruct m. + auto. + apply IHn. apply p. Defined. Lemma natlehsminus ( n m : nat ) : natleh ( sub ( S n ) m ) ( S (sub n m ) ). Proof. revert m. induction n. - intros m. apply negnatgthtoleh. intro X. apply nopathstruetofalse. apply pathsinv0. destruct m. + assumption. + assumption. - intros m. destruct m. + apply isreflnatleh. + apply IHn. Defined. Lemma natlthssminus { n m l : nat } ( p : natlth m ( S n ) ) ( q : natlth l ( S ( sub ( S n ) m ) ) ) : natlth l ( S ( S n ) ). Proof. apply ( natlthlehtrans _ ( S ( sub ( S n ) m ) ) ). - assumption. - destruct m. + apply isreflnatleh. + apply natlthtoleh. apply natlthsnminussmsn. assumption. Defined. Lemma natdoubleminus { n k l : nat } ( p : natleh k n ) ( q : natleh l k ) : sub n k = sub ( sub n l ) ( sub k l ). Proof. revert k l p q. induction n. - auto. - intros k l p q. destruct k. + destruct l. * auto. * apply fromempty. exact ( negnatlehsn0 l q ). + destruct l. * auto. * apply ( IHn k l ); assumption. Defined. Lemma minusnleh1 ( n m : nat ) ( p : natlth m n ) : natleh m ( sub n 1 ). Proof. revert m p. destruct n. - intros m p. apply fromempty. exact (negnatlthn0 m p ). - intros m p. destruct m. + apply natleh0n. + apply natlthsntoleh. change ( sub ( S n ) 1 ) with ( sub n 0 ). rewrite minus0r. assumption. Defined. Lemma doubleminuslehpaths ( n m : nat ) ( p : natleh m n ) : sub n (sub n m ) = m. Proof. revert m p. induction n. - intros m p. destruct ( natlehchoice m 0 p ) as [ h | k ]. + apply fromempty. apply negnatlthn0 with ( n := m ). assumption. + simpl. apply pathsinv0. assumption. - intros. destruct m. + simpl. apply minusnn0. + change ( sub ( S n ) (sub n m ) = S m ). rewrite <- pathssminus. * rewrite IHn. -- apply idpath. -- assumption. * apply ( minuslth ( S n ) ( S m ) ). -- apply (natlehlthtrans _ n ). ++ apply natleh0n. ++ apply natlthnsn. -- apply (natlehlthtrans _ m ). ++ apply natleh0n. ++ apply natlthnsn. Defined. Lemma boolnegtrueimplfalse ( v : bool ) ( p : neg ( v = true ) ) : v = false. Proof. intros. destruct v. - apply fromempty. apply p; auto. - auto. Defined. Definition natcoface ( i : nat ) : nat -> nat. Proof. intros n. destruct ( natgtb i n ). - exact n. - exact ( S n ). Defined. Lemma natcofaceleh ( i n upper : nat ) ( p : natleh n upper ) : natleh ( natcoface i n ) ( S upper ). Proof. intros. unfold natcoface. destruct ( natgtb i n ). - apply natlthtoleh. apply (natlehlthtrans _ upper ). + assumption. + apply natlthnsn. - apply p. Defined. Lemma natgehimplnatgtbfalse ( m n : nat ) ( p : natgeh n m ) : natgtb m n = false. Proof. intros. unfold natgeh in p. unfold natgth in p. apply boolnegtrueimplfalse. intro q. apply natlehneggth in p. apply p. auto. Defined. Definition natcofaceretract ( i : nat ) : nat -> nat. Proof. intros n. destruct ( natgtb i n ). - exact n. - exact ( sub n 1 ). Defined. Lemma natcofaceretractisretract ( i : nat ) : funcomp ( natcoface i ) ( natcofaceretract i ) = idfun nat. Proof. simpl. apply funextfun. intro n. simpl. set ( c := natlthorgeh n i ). destruct c as [ h | k ]. - unfold natcoface. rewrite h. unfold natcofaceretract. rewrite h. apply idpath. - assert ( natgtb i n = false ) as f. { apply natgehimplnatgtbfalse. assumption. } unfold natcoface. rewrite f. unfold natcofaceretract. assert ( natgtb i ( S n ) = false ) as ff. { apply natgehimplnatgtbfalse. apply ( istransnatgeh _ n ). + apply natgthtogeh. apply natgthsnn. + assumption. } rewrite ff. rewrite minussn1. apply idpath. Defined. Lemma isinjnatcoface ( i x y : nat ) : natcoface i x = natcoface i y -> x = y. Proof. intros p. change x with ( idfun _ x). rewrite <- ( natcofaceretractisretract i ). change y with ( idfun _ y ). rewrite <- ( natcofaceretractisretract i ). simpl. rewrite p. apply idpath. Defined. Lemma natlehdecomp ( b a : nat ) : ( ∃ c : nat, ( a + c )%nat = b ) -> natleh a b. Proof. revert a. induction b. - intros a p. use (hinhuniv _ p). intro t. destruct t as [ c f ]. destruct a. + apply isreflnatleh. + apply fromempty. simpl in f . exact ( negpathssx0 ( a + c ) f ). - intros a p. use (hinhuniv _ p). intro t. destruct t as [ c f ]. destruct a. + apply natleh0n. + assert ( natleh a b ) as q. { simpl in f. apply IHb. intro P. intro s. apply s. split with c. apply invmaponpathsS. assumption. } apply q. Defined. Lemma natdivleh ( a b k : nat ) ( f : ( a * k )%nat = b ) : natleh a b ⨿ ( b = 0%nat ). Proof. intros. destruct k. - rewrite natmultcomm in f. simpl in f. apply ii2. apply pathsinv0. assumption. - rewrite natmultcomm in f. simpl in f. apply ii1. apply natlehdecomp. intro P. intro g. apply g. split with ( k * a )%nat. rewrite natpluscomm. assumption. Defined. (** * II. Lemmas on rings *) Local Open Scope ring_scope. Lemma ringminusdistr { X : commring } ( a b c : X ) : a * (b - c) = a * b - a * c. Proof. intros. rewrite ringldistr. rewrite ringrmultminus. apply idpath. Defined. Lemma ringminusdistl { X : commring } ( a b c : X ) : (b - c) * a = b * a - c * a. Proof. intros. rewrite ringrdistr. rewrite ringlmultminus. apply idpath. Defined. Lemma multinvmultstable ( A : commring ) ( a b : A ) ( p : multinvpair A a ) ( q : multinvpair A b ) : multinvpair A ( a * b ). Proof. intros. destruct p as [ a' p ]. destruct q as [ b' q ]. split with ( b' * a' ). split. - change ( ( ( b' * a' ) * ( a * b ) )%ring = @ringunel2 A ). rewrite ( ringassoc2 A b'). rewrite <- ( ringassoc2 A a' ). change ( ( ( a' * a )%ring = @ringunel2 A ) × ( ( a * a' )%ring = @ringunel2 A ) ) in p. change ( ( ( b' * b )%ring = @ringunel2 A ) × ( ( b * b' )%ring = @ringunel2 A ) ) in q. rewrite <- ( pr1 q ). apply maponpaths. assert ( a' * a * b = 1 * b ) as f by apply ( maponpaths ( fun x => x * b ) ( pr1 p ) ). rewrite ringlunax2 in f. assumption. - change ( ( ( a * b ) * ( b' * a' ) )%ring = @ringunel2 A ). rewrite ( ringassoc2 A a). rewrite <- ( ringassoc2 A b ). change ( ( ( a' * a )%ring = @ringunel2 A ) × ( ( a * a' )%ring = @ringunel2 A ) ) in p. change ( ( ( b' * b )%ring = @ringunel2 A ) × ( ( b * b' )%ring = @ringunel2 A ) ) in q. rewrite <- ( pr2 q ). rewrite ( pr2 q ). rewrite ringlunax2. apply (pr2 p). Defined. Lemma commringaddinvunique ( X : commring ) ( a b c : X ) ( p : @op1 X a b = @ringunel1 X ) ( q : @op1 X a c = @ringunel1 X ) : b = c. Proof. intros. rewrite ( pathsinv0 ( ringrunax1 X b ) ). rewrite ( pathsinv0 q ). rewrite ( pathsinv0 ( ringassoc1 X _ _ _ ) ). rewrite ( ringcomm1 X b _ ). rewrite p. rewrite ringlunax1. apply idpath. Defined. Lemma isapropmultinvpair ( X : commring ) ( a : X ) : isaprop ( multinvpair X a ). Proof. intros. unfold isaprop. intros b c. assert ( b = c ) as f. { destruct b as [ b b' ]. destruct c as [ c c']. assert ( b = c ) as f0. { rewrite <- ( @ringrunax2 X b ). change ( b * @ringunel2 X ) with ( b * 1 )%multmonoid. rewrite <- ( pr2 c' ). change ( ( b * ( a * c ) )%ring = c ). rewrite <- ( ringassoc2 X ). change ( b * a )%ring with ( b * a )%multmonoid. rewrite ( pr1 b' ). change ( ( @ringunel2 X ) * c = c )%ring. apply ringlunax2. } apply (total2_paths2_f f0 ). assert ( isaprop ( c * a = ( @ringunel2 X ) × a * c = ( @ringunel2 X ) ) ) as is. { apply isofhleveldirprod. - apply ( setproperty X ). - apply ( setproperty X ). } apply is. } split with f. intros g. assert ( isaset ( multinvpair X a ) ) as is. { unfold multinvpair. unfold invpair. change isaset with ( isofhlevel 2 ). apply isofhleveltotal2. - apply ( pr2 ( pr1 ( pr1 ( rigmultmonoid X ) ) ) ). - intros. apply isofhleveldirprod. + apply hlevelntosn. apply ( setproperty X ). + apply hlevelntosn. apply (setproperty X ). } apply is. Defined. Close Scope ring_scope. (** * III. Lemmas on hz *) Local Open Scope hz_scope. Lemma hzaddinvplus ( n m : hz ) : - ( n + m ) = ( - n ) + ( - m ). Proof. intros. apply commringaddinvunique with ( a := n + m ). - apply ringrinvax1. - assert ( ( n + m ) + ( - n + - m ) = n + - n + m + - m ) as i. { assert ( n + m + ( - n + - m ) = n + ( m + ( - n + - m ) ) ) as i0 by apply ringassoc1. assert ( n + ( m + ( - n + - m ) ) = n + ( m + - n + - m ) ) as i1. { apply maponpaths. apply pathsinv0. apply ringassoc1. } assert ( n + ( m + - n + - m ) = n + (- n + m + - m ) ) as i2. { apply maponpaths. apply ( maponpaths ( fun x => x + - m ) ). apply ringcomm1. } assert ( n + ( - n + m + - m ) = n + ( - n + m ) + - m ) as i3. { apply pathsinv0. apply ringassoc1. } assert ( n + ( - n + m ) + - m = n + - n + m + - m ) as i4. { apply pathsinv0. apply ( maponpaths ( fun x => x + - m ) ). apply ringassoc1. } exact ( pathscomp0 i0 ( pathscomp0 i1 ( pathscomp0 i2 ( pathscomp0 i3 i4 ) ) ) ). } assert ( n + - n + m + -m = 0 ) as j. { assert ( n + - n + m + - m = 0 + m + - m ) as j0. { apply ( maponpaths ( fun x => x + m + - m ) ). apply ringrinvax1. } assert ( 0 + m + - m = m + - m ) as j1. { apply ( maponpaths ( fun x => x + - m ) ). apply ringlunax1. } assert ( m + - m = 0 ) as j2 by apply ringrinvax1. exact ( pathscomp0 j0 ( pathscomp0 j1 j2 ) ). } exact ( pathscomp0 i j ). Defined. Lemma hzgthsntogeh ( n m : hz ) ( p : hzgth ( n + 1 ) m ) : hzgeh n m. Proof. intros. set ( c := hzgthchoice2 ( n + 1 ) m ). destruct c as [ h | k ]. - exact p. - assert ( hzgth n m ) as a by exact ( hzgthandplusrinv n m 1 h ). apply hzgthtogeh. exact a. - rewrite ( hzplusrcan n m 1 k ). apply isreflhzgeh. Defined. Lemma hzlthsntoleh ( n m : hz ) ( p : hzlth m ( n + 1 ) ) : hzleh m n. Proof. intros. unfold hzlth in p. assert ( hzgeh n m ) as a by (apply hzgthsntogeh; exact p). exact a. Defined. Lemma hzabsvalchoice ( n : hz ) : ( 0%nat = hzabsval n ) ⨿ ( ∑ x : nat, S x = hzabsval n ). Proof. intros. destruct ( natlehchoice _ _ ( natleh0n ( hzabsval n ) ) ) as [ l | r ]. - apply ii2. split with ( sub ( hzabsval n ) 1 ). rewrite pathssminus. + change ( sub ( hzabsval n ) 0 = hzabsval n ). rewrite minus0r. apply idpath. + assumption. - apply ii1. assumption. Defined. Lemma hzlthminusswap ( n m : hz ) ( p : hzlth n m ) : hzlth ( - m ) (- n ). Proof. intros. rewrite <- ( hzplusl0 ( - m ) ). rewrite <- ( hzrminus n ). change ( hzlth ( n + - n + - m ) ( - n ) ). rewrite hzplusassoc. rewrite ( hzpluscomm ( -n ) ). rewrite <- hzplusassoc. assert ( - n = 0 + - n ) as f. { apply pathsinv0. apply hzplusl0. } assert ( hzlth ( n + - m + - n ) ( 0 + - n ) ) as q. { apply hzlthandplusr. rewrite <- ( hzrminus m ). change ( m - m ) with ( m + - m ). apply hzlthandplusr. assumption. } rewrite <- f in q. assumption. Defined. Lemma hzlthminusequiv ( n m : hz ) : ( hzlth n m -> hzlth 0 ( m - n ) ) × ( hzlth 0 ( m - n ) -> hzlth n m ). Proof. intros. rewrite <- ( hzrminus n ). change ( n - n ) with ( n + - n ). change ( m - n ) with ( m + - n ). split. - intro p. apply hzlthandplusr. assumption. - intro p. rewrite <- ( hzplusr0 n ). rewrite <- ( hzplusr0 m ). rewrite <- ( hzlminus n ). rewrite <- 2! hzplusassoc. apply hzlthandplusr. assumption. Defined. Lemma hzlthminus ( n m k : hz ) ( p : hzlth n k ) ( q : hzlth m k ) ( q' : hzleh 0 m ) : hzlth ( n - m ) k. Proof. intros. destruct ( hzlehchoice 0 m q' ) as [ l | r ]. - apply ( istranshzlth _ n _ ). + assert ( hzlth ( n - m ) ( n + 0 ) ) as i0. { rewrite <- ( hzrminus m ). change ( m - m ) with ( m + - m ). rewrite <- hzplusassoc. apply hzlthandplusr. assert ( hzlth ( n + 0 ) ( n + m ) ) as i00. { apply hzlthandplusl. assumption. } rewrite hzplusr0 in i00. assumption. } rewrite hzplusr0 in i0. assumption. + assumption. - rewrite <- r. change ( n - 0 ) with ( n + - 0 ). rewrite hzminuszero. rewrite ( hzplusr0 n ). assumption. Defined. Lemma hzabsvalandminuspos ( n m : hz ) ( p : hzleh 0 n ) ( q : hzleh 0 m ) : nattohz ( hzabsval ( n - m ) ) = nattohz ( hzabsval ( m - n ) ). Proof. intros. destruct ( hzlthorgeh n m ) as [ l | r ]. - assert ( hzlth ( n - m ) 0 ) as a. { change ( n - m ) with ( n + - m ). rewrite <- ( hzrminus m ). change ( m - m ) with ( m + - m ). apply hzlthandplusr. assumption. } assert ( hzlth 0 ( m - n ) ) as b. { change ( m - n ) with ( m + - n ). rewrite <- ( hzrminus n ). change ( n - n ) with ( n + - n ). apply hzlthandplusr. assumption. } rewrite ( hzabsvallth0 a ). rewrite hzabsvalgth0. + change ( n - m ) with ( n + - m ). rewrite hzaddinvplus. change ( - - m ) with ( - - m )%ring. rewrite ringminusminus. rewrite hzpluscomm. apply idpath. + apply b. - destruct ( hzgehchoice n m r ) as [ h | k ]. + assert ( hzlth 0 ( n - m ) ) as a. { change ( n - m ) with ( n + - m ). rewrite <- ( hzrminus m ). change ( m - m ) with ( m + - m ). apply hzlthandplusr. assumption. } assert ( hzlth ( m - n ) 0 ) as b. { change ( m - n ) with ( m + - n ). rewrite <- ( hzrminus n ). apply hzlthandplusr. apply h. } rewrite ( hzabsvallth0 b ). rewrite hzabsvalgth0. * change ( n + - m = - ( m + - n ) ). rewrite hzaddinvplus. change ( - - n ) with ( - - n )%ring. rewrite ringminusminus. rewrite hzpluscomm. apply idpath. * apply a. + rewrite k. apply idpath. Defined. Lemma hzabsvalneq0 ( n : hz ) ( p : hzneq 0 n ) : hzlth 0 ( nattohz ( hzabsval n ) ). Proof. intros. destruct ( hzneqchoice 0 n p ) as [ left | right ]. - rewrite hzabsvallth0. + apply hzlth0andminus. apply left. + apply left. - rewrite hzabsvalgth0. + assumption. + apply right. Defined. Definition hzrdistr ( a b c : hz ) : ( a + b ) * c = ( a * c ) + ( b * c ) := ringrdistr hz a b c. Definition hzldistr ( a b c : hz ) : c * ( a + b ) = ( c * a ) + ( c * b ) := ringldistr hz a b c. Lemma hzabsvaland1 : hzabsval 1 = 1%nat. Proof. apply ( invmaponpathsincl _ isinclnattohz ). rewrite hzabsvalgth0. - rewrite nattohzand1. apply idpath. - rewrite <- ( hzplusl0 1 ). apply ( hzlthnsn 0 ). Defined. Lemma hzabsvalandplusnonneg ( n m : hz ) ( p : hzleh 0 n ) ( q : hzleh 0 m ) : hzabsval ( n + m ) = ( ( hzabsval n ) + ( hzabsval m ) )%nat. Proof. intros. assert ( hzleh 0 ( n + m ) ) as r. { rewrite <- ( hzrminus n ). change ( n - n ) with ( n + - n ). apply hzlehandplusl. apply ( istranshzleh _ 0 _ ). - apply hzgeh0andminus. apply p. - assumption. } apply ( invmaponpathsincl _ isinclnattohz ). rewrite nattohzandplus. rewrite hzabsvalgeh0. (* used to start with rewrite 3! hzabsvalgeh0 *) - rewrite hzabsvalgeh0. + rewrite hzabsvalgeh0. * apply idpath. * assumption. + assumption. - assumption. Defined. Lemma hzabsvalandplusneg ( n m : hz ) ( p : hzlth n 0 ) ( q : hzlth m 0 ) : hzabsval ( n + m ) = ( ( hzabsval n ) + ( hzabsval m ) )%nat. Proof. intros. assert ( hzlth ( n + m ) 0 ) as r. { rewrite <- ( hzrminus n ). change ( n - n ) with ( n + - n ). apply hzlthandplusl. apply ( istranshzlth _ 0 _ ). - assumption. - apply hzlth0andminus. assumption. } apply ( invmaponpathsincl _ isinclnattohz ). rewrite nattohzandplus. rewrite hzabsvallth0. - rewrite hzabsvallth0. + rewrite hzabsvallth0. * rewrite hzaddinvplus. apply idpath. * assumption. + assumption. - assumption. Defined. Lemma hzabsvalandnattohz ( n : nat ) : hzabsval ( nattohz n ) = n. Proof. induction n. - rewrite nattohzand0. rewrite hzabsval0. apply idpath. - rewrite nattohzandS. rewrite hzabsvalandplusnonneg. + rewrite hzabsvaland1. simpl. apply maponpaths. assumption. + rewrite <- (hzplusl0 1). apply hzlthtoleh. apply ( hzlthnsn 0 ). + rewrite <- nattohzand0. apply nattohzandleh. apply natleh0n. Defined. Lemma hzabsvalandlth ( n m : hz ) ( p : hzleh 0 n ) ( p' : hzlth n m ) : natlth ( hzabsval n ) ( hzabsval m ). Proof. intros. destruct ( natlthorgeh ( hzabsval n ) ( hzabsval m ) ) as [ h | k ]. - assumption. - apply fromempty. apply ( isirreflhzlth m ). apply ( hzlehlthtrans _ n _ ). + rewrite <- ( hzabsvalgeh0 ). * rewrite <- ( hzabsvalgeh0 p ). apply nattohzandleh. apply k. * apply hzgthtogeh. apply ( hzgthgehtrans _ n _ ); assumption. + assumption. Defined. Lemma nattohzandlthinv ( n m : nat ) ( p : hzlth ( nattohz n ) (nattohz m ) ) : natlth n m. Proof. intros. rewrite <- ( hzabsvalandnattohz n ). rewrite <- ( hzabsvalandnattohz m ). apply hzabsvalandlth. - change 0 with ( nattohz 0%nat ). apply nattohzandleh. apply natleh0n . - assumption. Defined. Close Scope hz_scope. (** * IV. Generalities on apartness relations *) Definition iscomparel { X : UU } ( R : hrel X ) := forall x y z : X, R x y -> R x z ⨿ R z y. Definition isapart { X : UU } ( R : hrel X ) := isirrefl R × ( issymm R × iscotrans R ). Definition istightapart { X : UU } ( R : hrel X ) := isapart R × forall x y : X, neg ( R x y ) -> x = y. Definition apart ( X : hSet ) := ∑ R : hrel X, isapart R. Definition isbinopapartl { X : hSet } ( R : apart X ) ( opp : binop X ) := forall a b c : X, ( pr1 R ( opp a b ) ( opp a c ) ) -> pr1 R b c. Definition isbinopapartr { X : hSet } ( R : apart X ) ( opp : binop X ) := forall a b c : X, pr1 R ( opp b a ) ( opp c a ) -> pr1 R b c. Definition isbinopapart { X : hSet } ( R : apart X ) ( opp : binop X ) := isbinopapartl R opp × isbinopapartr R opp. Lemma deceqtoneqapart { X : UU } ( is : isdeceq X ) : isapart ( neq X ). Proof. intros. split. - intros a p. simpl in p. apply p. apply idpath. - split. + intros a b p q. simpl in p. apply p. apply pathsinv0. assumption. + intros a c b p P s. apply s. destruct ( is a c ) as [ l | r ]. * apply ii2. rewrite <- l. assumption. * apply ii1. assumption. Defined. Definition isapartdec { X : hSet } ( R : apart X ) := forall a b : X, pr1 R a b ⨿ ( a = b ). Lemma isapartdectodeceq { X : hSet } ( R : apart X ) ( is : isapartdec R ) : isdeceq X. Proof. intros y z. destruct ( is y z ) as [ l | r ]. - apply ii2. intros f. apply ( pr1 ( pr2 R ) z). rewrite f in l. assumption. - apply ii1. assumption. Defined. Lemma isdeceqtoisapartdec ( X : hSet ) ( is : isdeceq X ) : isapartdec ( tpair _ ( deceqtoneqapart is ) ). Proof. intros a b. destruct ( is a b ) as [ l | r ]. - apply ii2. assumption. - apply ii1. intros f. apply r. assumption. Defined. (** * V. Apartness relations on rings *) Local Open Scope ring_scope. Definition acommring := ∑ (X : commring) (R : apart X), isbinopapart R ( @op1 X ) × isbinopapart R ( @op2 X ). Definition make_acommring := tpair ( P := fun X : commring => ∑ R : apart X, isbinopapart R ( @op1 X ) × isbinopapart R ( @op2 X ) ). Definition acommringconstr := make_acommring. Definition acommringtocommring : acommring -> commring := @pr1 _ _. Coercion acommringtocommring : acommring >-> commring. Definition acommringapartrel ( X : acommring ) : hrel (pr1 X) := pr1 ( pr1 ( pr2 X ) ). Notation " a # b " := ( acommringapartrel _ a b ) (* ( at level 50 ) *) : ring_scope. Definition acommring_aadd ( X : acommring ) : isbinopapart ( pr1 ( pr2 X ) ) op1 := pr1 ( pr2 ( pr2 X ) ). Definition acommring_amult ( X : acommring ) : isbinopapart ( pr1 ( pr2 X ) ) op2 := pr2 ( pr2 ( pr2 X ) ). Definition acommring_airrefl ( X : acommring ) : isirrefl ( pr1 ( pr1 ( pr2 X ) ) ) := pr1 ( pr2 ( pr1 ( pr2 X ) ) ). Definition acommring_asymm ( X : acommring ) : issymm ( pr1 ( pr1 ( pr2 X ) ) ) := pr1 ( pr2 ( pr2 ( pr1 ( pr2 X ) ) ) ). Definition acommring_acotrans ( X : acommring ) : iscotrans ( pr1 ( pr1 ( pr2 X ) ) ) := pr2 ( pr2 ( pr2 ( pr1 ( pr2 X ) ) ) ). Definition aintdom := ∑ A : acommring, ( ringunel2 ( X := A ) ) # 0 × forall a b : A, a # 0 -> b # 0 -> ( a * b ) # 0. Definition make_aintdom := tpair ( P := fun A : acommring => ( ringunel2 ( X := A ) ) # 0 × forall a b : A, a # 0 -> b # 0 -> ( a * b ) # 0 ). Definition aintdomconstr := make_aintdom. Definition pr1aintdom : aintdom -> acommring := @pr1 _ _. Coercion pr1aintdom : aintdom >-> acommring. Definition aintdomazerosubmonoid ( A : aintdom ) : @subabmonoid ( ringmultabmonoid A ). Proof. intros. split with ( fun x : A => x # 0 ). split. - intros a b. simpl in *. apply (pr2 (pr2 A)). + simpl in a. apply (pr2 a). + apply (pr2 b). - apply (pr2 A). Defined. Definition isaafield ( A : acommring ) := ( ringunel2 ( X := A ) ) # 0 × forall x : A, x # 0 -> multinvpair A x. Definition afld := ∑ A : acommring, isaafield A. Definition make_afld ( A : acommring ) ( is : isaafield A ) : afld := tpair A is . Definition pr1afld : afld -> acommring := @pr1 _ _ . Coercion pr1afld : afld >-> acommring. Lemma afldinvertibletoazero ( A : afld ) ( a : A ) ( p : multinvpair A a ) : a # 0. Proof. intros. destruct p as [ a' p ]. assert ( a' * a # 0 ) as q. { change ( a' * a # 0 ). assert ( a' * a = a * a' ) as f by apply ( ringcomm2 A ). assert ( a * a' = 1 ) as g by apply (pr2 p). rewrite f, g. apply (pr2 A). } assert ( a' * a # a' * ( ringunel1 ( X := A ) ) ) as q'. { assert ( ringunel1 ( X := A ) = a' * ( ringunel1 ( X := A ) ) ) as f. { apply pathsinv0. apply ( ringmultx0 A ). } rewrite <- f. assumption. } apply ( pr1 ( acommring_amult A ) a' ). assumption. Defined. Definition afldtoaintdom ( A : afld ) : aintdom . Proof. split with ( pr1 A ). split. - apply (pr2 A). - intros a b p q. apply afldinvertibletoazero. apply multinvmultstable. + apply (pr2 (pr2 A)). assumption. + apply (pr2 (pr2 A)). assumption. Defined. Lemma timesazero { A : acommring } { a b : A } ( p : a * b # 0 ) : a # 0 × b # 0. Proof. intros. split. - assert ( a * b # 0 * b ) as h. { rewrite ( ringmult0x A ). assumption. } apply ( pr2 ( acommring_amult A ) b ). assumption. - apply ( pr1 ( acommring_amult A ) a ). rewrite ( ringmultx0 A ). assumption. Defined. Lemma aaminuszero { A : acommring } { a b : A } ( p : a # b ) : ( a - b ) # 0. Proof. intros. rewrite <- ( ringrunax1 A a ) in p. rewrite <- ( ringrunax1 A b ) in p. assert ( a + 0 = a + ( b - b ) ) as f. { rewrite <- ( ringrinvax1 A b ). apply idpath. } rewrite f in p. rewrite <- ( ringmultwithminus1 A ) in p. rewrite <- ( ringassoc1 A) in p. rewrite ( ringcomm1 A a ) in p. rewrite ( ringassoc1 A b ) in p. rewrite ( ringmultwithminus1 A ) in p. apply ( pr1 ( acommring_aadd A ) b ( a - b ) 0 ). assumption. Defined. Lemma aminuszeroa { A : acommring } { a b : A } ( p : ( a - b ) # 0 ) : a # b. Proof. intros. change 0 with ( @ringunel1 A ) in p. rewrite <- ( ringrinvax1 A b ) in p. rewrite <- ( ringmultwithminus1 A ) in p. apply ( pr2 ( acommring_aadd A ) ( -1 * b ) a b ). assumption. Defined. Close Scope ring_scope. (** * VI. Lemmas on logic *) Lemma horelim ( A B : UU ) ( P : hProp ) : ( ishinh_UU A -> P ) × ( ishinh_UU B -> P ) -> A ∨ B -> P. Proof. intros p q. simpl in q. apply q. intro u. destruct u as [ u | v ]. - apply ( pr1 p ). intro Q. intro H. apply H. assumption. - apply ( pr2 p ). intro Q. intro H. apply H. assumption. Defined. Lemma stronginduction { E : nat -> UU } ( p : E 0%nat ) ( q : forall n : nat, natneq n 0%nat -> ( forall m : nat, natlth m n -> E m ) -> E n ) : forall n : nat, E n. Proof. intros. destruct n. - assumption. - apply q. + split. + induction n. * intros m t. rewrite ( natlth1tois0 m t ). assumption. * intros m t. destruct ( natlehchoice _ _ ( natlthsntoleh _ _ t ) ) as [ left | right ]. -- apply IHn. assumption. -- apply q. ++ rewrite right. split. ++ intros k s. rewrite right in s. apply ( IHn k ). assumption. Defined. (* Some lemmas on decidable properties of natural numbers. *) Definition isdecnatprop ( P : nat -> hProp ) := forall m : nat, P m ⨿ neg ( P m ). Lemma negisdecnatprop ( P : nat -> hProp ) ( is : isdecnatprop P ) : isdecnatprop ( fun n : nat => hneg ( P n ) ). Proof. intros n. destruct ( is n ) as [ l | r ]. - apply ii2. intro j. assert hfalse as x. { simpl in j. apply j. assumption. } apply x. - apply ii1. assumption. Defined. Lemma bndexistsisdecnatprop ( P : nat -> hProp ) ( is : isdecnatprop P ) : isdecnatprop ( fun n : nat => ∃ m : nat, natleh m n × P m ). Proof. intros n. induction n. - destruct ( is 0%nat ) as [ l | r ]. + apply ii1. apply total2tohexists. split with 0%nat. split. * apply isreflnatleh. * assumption. + apply ii2. intro j. assert hfalse as x. { simpl in j. apply j. intro m. destruct m as [ m m' ]. apply r. change ( natleh m 0 × P m ) in m'. rewrite ( natleh0tois0 ( pr1 m' ) ) in m'. apply (pr2 m'). } apply x. - destruct ( is ( S n ) ) as [ l | r ]. + apply ii1. apply total2tohexists. split with ( S n ). split. * apply ( isreflnatleh ( S n ) ). * assumption. + destruct IHn as [ l' | r' ]. * apply ii1. use (hinhuniv _ l'). intro m. destruct m as [ m m' ]. apply total2tohexists. split with m. split. -- apply ( istransnatleh(m := n) ). ++ apply m'. ++ apply natlthtoleh. apply natlthnsn. -- apply (pr2 m'). * apply ii2. intro j. apply r'. use (hinhuniv _ j). intro m. destruct m as [ m m' ]. -- apply total2tohexists. split with m. split. ++ destruct ( natlehchoice m ( S n ) ( pr1 m' ) ) as [ h | p ]. ** apply natlthsntoleh. assumption. ** apply fromempty. apply r. rewrite <- p. apply (pr2 m'). ++ apply (pr2 m'). Defined. Lemma isdecisbndqdec ( P : nat -> hProp ) ( is : isdecnatprop P ) ( n : nat ) : ( forall m : nat, natleh m n -> P m ) ⨿ ∃ m : nat, natleh m n × neg ( P m ). Proof. destruct ( bndexistsisdecnatprop _ ( negisdecnatprop P is ) n ) as [ l | r ]. - apply ii2. assumption. - apply ii1. intros m j. destruct ( is m ) as [ l' | r' ]. + assumption. + apply fromempty. apply r. apply total2tohexists. split with m. split; assumption. Defined. Lemma leastelementprinciple ( n : nat ) ( P : nat -> hProp ) ( is : isdecnatprop P ) : P n -> ∃ k : nat, P k × forall m : nat, natlth m k -> neg ( P m ). Proof. revert P is. induction n. - intros P is u. apply total2tohexists. split with 0%nat. split. + assumption. + intros m i. apply fromempty. apply ( negnatgth0n m i ). - intros P is u. destruct ( is 0%nat ) as [ l | r ]. + apply total2tohexists. split with 0%nat. split. * assumption. * intros m i. apply fromempty. apply ( negnatgth0n m i ). + set ( P' := fun m : nat => P ( S m ) ). assert ( forall m : nat, P' m ⨿ neg ( P' m ) ) as is'. { intros m. unfold P'. apply ( is ( S m ) ). } set ( c := IHn P' is' u ). use (hinhuniv _ c). intros k. destruct k as [ k v ]. destruct v as [ v0 v1 ]. apply total2tohexists. split with ( S k ). split. * assumption. * intros m. destruct m. -- intros i. assumption. -- intros i. apply v1. apply i. Defined. (** END OF FILE *) UniMath-20231010/UniMath/PAdics/padics.v000066400000000000000000002326101451125700300174550ustar00rootroot00000000000000(** *p adic numbers *) (** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) (** 2012 *) (** made compatible with the current UniMath library by Ralph Matthes in October 2017 *) (** Imports *) Require Import UniMath.PAdics.lemmas. Require Import UniMath.PAdics.fps. Require Import UniMath.PAdics.frac. Require Import UniMath.PAdics.z_mod_p. Require Import UniMath.NumberSystems.Integers. Unset Kernel Term Sharing. (** crucial for timely proof-checking, otherwise unbearable *) (** * I. Several basic lemmas *) Local Open Scope hz_scope. Lemma hzqrandnatsummation0r ( m : hz ) ( x : hzneq 0 m ) ( a : nat -> hz ) ( upper : nat ) : hzremaindermod m x ( natsummation0 upper a ) = hzremaindermod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ). Proof. intros. induction upper. - simpl. rewrite hzremaindermoditerated. apply idpath. - change ( hzremaindermod m x ( natsummation0 upper a + a ( S upper ) ) = hzremaindermod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) + hzremaindermod m x ( a ( S upper ) ) ) ). rewrite hzremaindermodandplus. rewrite IHupper. rewrite <- ( hzremaindermoditerated m x ( a ( S upper ) ) ). rewrite <- hzremaindermodandplus. rewrite hzremaindermoditerated. apply idpath. Defined. Lemma hzqrandnatsummation0q ( m : hz ) ( x : hzneq 0 m ) ( a : nat -> hz ) ( upper : nat ) : hzquotientmod m x ( natsummation0 upper a ) = ( natsummation0 upper ( fun n : nat => hzquotientmod m x ( a n ) ) + hzquotientmod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) ). Proof. intros. induction upper. - simpl. rewrite <- hzqrandremainderq. rewrite hzplusr0. apply idpath. - change ( natsummation0 ( S upper ) a ) with ( natsummation0 upper a + a ( S upper ) ). rewrite hzquotientmodandplus. rewrite IHupper. rewrite ( hzplusassoc ( natsummation0 upper ( fun n : nat => hzquotientmod m x ( a n ) ) ) _ ( hzquotientmod m x ( a ( S upper ) ) ) ). rewrite ( hzpluscomm ( hzquotientmod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) ) ( hzquotientmod m x ( a ( S upper ) ) ) ). rewrite <- ( hzplusassoc ( natsummation0 upper ( fun n : nat => hzquotientmod m x ( a n ) ) ) ( hzquotientmod m x ( a ( S upper ) ) ) _ ). change ( natsummation0 upper ( fun n : nat => hzquotientmod m x ( a n ) ) + hzquotientmod m x ( a ( S upper ) ) ) with ( natsummation0 ( S upper ) ( fun n : nat => hzquotientmod m x ( a n ) ) ). rewrite hzqrandnatsummation0r. rewrite hzquotientmodandplus. rewrite <- hzqrandremainderq. rewrite hzplusl0. rewrite hzremaindermoditerated. rewrite ( hzplusassoc (natsummation0 ( S upper ) ( fun n : nat => hzquotientmod m x ( a n ) ) ) ( hzquotientmod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) ) _ ). rewrite <- ( hzplusassoc ( hzquotientmod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) ) _ _ ). rewrite <- hzquotientmodandplus. apply idpath. Defined. Lemma hzquotientandtimesl ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) : hzquotientmod m x ( a * b ) = ( hzquotientmod m x a ) * b + hzremaindermod m x a * hzquotientmod m x b + hzquotientmod m x ( hzremaindermod m x a * hzremaindermod m x b ). Proof. intros. rewrite hzquotientmodandtimes. rewrite ( hzmultcomm ( hzremaindermod m x b ) ( hzquotientmod m x a ) ). rewrite hzmultassoc. rewrite <- ( hzldistr ( hzquotientmod m x b * m ) _ ( hzquotientmod m x a )). rewrite ( hzmultcomm _ m ). rewrite <- ( hzdivequationmod m x b ). rewrite hzplusassoc. apply idpath. Defined. Lemma hzquotientandfpstimesl ( m : hz ) ( x : hzneq 0 m ) ( a b : nat -> hz ) ( upper : nat ) : hzquotientmod m x ( fpstimes hz a b upper ) = natsummation0 upper ( fun i : nat => hzquotientmod m x ( a i ) * b ( sub upper i ) ) + hzquotientmod m x ( natsummation0 upper ( fun i : nat => hzremaindermod m x ( a i ) * b ( sub upper i ) ) ). Proof. intros. destruct upper as [ | upper]. - simpl. unfold fpstimes. simpl. rewrite hzquotientandtimesl. rewrite hzplusassoc. apply ( maponpaths ( fun v : _ => hzquotientmod m x ( a 0%nat ) * b 0%nat + v ) ). rewrite ( hzquotientmodandtimes m x ( hzremaindermod m x ( a 0%nat ) ) ( b 0%nat ) ). rewrite <- hzqrandremainderq. rewrite hzmultx0. rewrite 2! hzmult0x. rewrite hzplusl0. rewrite hzremaindermoditerated. apply idpath. - unfold fpstimes. rewrite hzqrandnatsummation0q. assert ( forall n : nat, hzquotientmod m x (a n * b ( sub ( S upper ) n)%nat) = ( hzquotientmod m x ( a n ) * b ( sub ( S upper ) n ) + hzremaindermod m x ( a n ) * hzquotientmod m x ( b ( sub ( S upper ) n ) ) + hzquotientmod m x ( hzremaindermod m x ( a n ) * hzremaindermod m x ( b ( sub ( S upper ) n ) ) ) ) ) as f. { intro k. rewrite hzquotientandtimesl. apply idpath. } rewrite ( natsummationpathsupperfixed _ _ ( fun x0 p => f x0 ) ). rewrite ( natsummationplusdistr ( S upper ) ( fun x0 : nat => hzquotientmod m x (a x0) * b ( sub ( S upper ) x0)%nat + hzremaindermod m x (a x0) * hzquotientmod m x (b (S upper - x0)%nat) ) ). rewrite ( natsummationplusdistr ( S upper ) ( fun x0 : nat => hzquotientmod m x (a x0) * b (S upper - x0)%nat ) ). rewrite 2! hzplusassoc. apply ( maponpaths ( fun v => natsummation0 ( S upper ) ( fun i : nat => hzquotientmod m x ( a i ) * b ( sub ( S upper ) i ) ) + v ) ). rewrite ( hzqrandnatsummation0q m x ( fun i : nat => hzremaindermod m x ( a i ) * b ( sub ( S upper ) i ) ) ). assert (natsummation0 (S upper) (fun n : nat => hzremaindermod m x (hzremaindermod m x (a n) * b (S upper - n)%nat))= natsummation0 ( S upper ) ( fun n : nat => hzremaindermod m x ( a n * b ( sub ( S upper ) n ) ) ) ) as g. { apply natsummationpathsupperfixed. intros j p. rewrite hzremaindermodandtimes. rewrite hzremaindermoditerated. rewrite <- hzremaindermodandtimes. apply idpath. } rewrite g. rewrite <- hzplusassoc. assert ( natsummation0 (S upper) (fun x0 : nat => hzremaindermod m x (a x0) * hzquotientmod m x (b (S upper - x0)%nat)) + natsummation0 (S upper) (fun x0 : nat => hzquotientmod m x (hzremaindermod m x (a x0) * hzremaindermod m x (b (S upper - x0)%nat))) = natsummation0 (S upper) (fun n : nat => hzquotientmod m x (hzremaindermod m x (a n) * b (S upper - n)%nat)) ) as h. { rewrite <- ( natsummationplusdistr ( S upper ) ( fun x0 : nat => hzremaindermod m x ( a x0 ) * hzquotientmod m x ( b ( sub ( S upper ) x0 ) ) ) ). apply natsummationpathsupperfixed. intros j p. rewrite ( hzquotientmodandtimes m x ( hzremaindermod m x ( a j ) ) ( b ( sub ( S upper ) j ) ) ). rewrite <- hzqrandremainderq. rewrite 2! hzmult0x. rewrite hzmultx0. rewrite hzplusl0. rewrite hzremaindermoditerated. apply idpath. } rewrite h. apply idpath. Defined. Close Scope hz_scope. (** * II. The carrying operation and induced equivalence relation on formal power series *) (** A lemma that does not depend on a non-zero integer and that used to appear where needed below - the point has been marked by a comment. *) Local Open Scope ring_scope. Lemma natsummationplusshift { R : commring } ( upper : nat ) ( f g : nat -> R ) : natsummation0 ( S upper ) f + natsummation0 upper g = f 0%nat + natsummation0 upper ( fun x : nat => f ( S x ) + g x ). Proof. intros. destruct upper. - unfold natsummation0. simpl. apply ( ringassoc1 R ). - rewrite (natsummationshift0 ( S upper ) f ). rewrite ( ringcomm1 R _ ( f 0%nat ) ). rewrite ( ringassoc1 R ). rewrite natsummationplusdistr. apply idpath. Defined. Close Scope hz_scope. Section carry. Local Open Scope ring_scope. Variable m : hz. Variable is : hzneq 0 m. Fixpoint precarry ( a : fpscommring hz ) ( n : nat ) : hz := match n with | 0%nat => a 0%nat | S n => a ( S n ) + hzquotientmod m is ( precarry a n ) end. Definition carry : fpscommring hz -> fpscommring hz := fun (a : fpscommring hz) (n : nat) => hzremaindermod m is ( precarry a n ). (* precarry and carry are as described in the following example: CASE: mod 3 First we normalize the sequence as we go along: 5 6 8 4 (13) 2 2 ( remainder 2 mod 3 = 2 ) 4 1 ( remainder 13 mod 3 = 1, quotient 13 mod 3 = 4 ) 2 2 ( remainder 8 mod 3 = 2, quotient 8 mod 3 = 2 ) 3 1 ( remainder 10 mod 3 = 1, quotient 10 mod 3 = 3 ) 3 0 ( remainder 9 mod 3 = 0, quotient 9 mod 3 = 3 ) 2 2 ( remainder 8 mod 3 = 2, quotient 8 mod 3 = 2 ) 2 2 0 1 2 1 2 Next we first precarry and then carry: 5 6 8 4 (13) 2 2 4 13 2 8 3 (10) 3 9 2 8 2 8 9 (10) 8 (13) 2 <--- precarried sequence 2 2 0 1 2 1 2 <--- carried sequence *) Lemma isapropcarryequiv ( a b : fpscommring hz ) : isaprop ( carry a = carry b ). Proof. intros. apply ( fps hz ). Defined. Definition carryequiv0 : hrel ( fpscommring hz ) := fun a b : fpscommring hz => make_hProp _ ( isapropcarryequiv a b ). Lemma carryequiviseqrel : iseqrel carryequiv0. Proof. split. - split. + intros a b c i j. simpl. rewrite i. apply j. + intros a. simpl. apply idpath. - intros a b i. simpl. rewrite i. apply idpath. Defined. Lemma carryandremainder ( a : fpscommring hz ) ( n : nat ) : hzremaindermod m is ( carry a n ) = carry a n. Proof. intros. unfold carry. rewrite hzremaindermoditerated. apply idpath. Defined. Definition carryequiv : eqrel ( fpscommring hz ) := make_eqrel _ carryequiviseqrel. Lemma precarryandcarry_pointwise ( a : fpscommring hz ) : forall n : nat, precarry ( carry a ) n = ( carry a ) n. Proof. intros. induction n. - exact (idpath _). - unfold precarry. fold precarry. rewrite IHn. unfold carry at 2. rewrite <- hzqrandremainderq. apply hzplusr0. Defined. Lemma precarryandcarry ( a : fpscommring hz ) : precarry ( carry a ) = carry a. Proof. intros. apply funextfun. intro n. apply precarryandcarry_pointwise. Defined. Lemma hzqrandcarryeq ( a : fpscommring hz ) ( n : nat ) : carry a n = m * 0 + carry a n. Proof. intros. rewrite hzmultx0. rewrite hzplusl0. apply idpath. Defined. Lemma hzqrandcarryineq ( a : fpscommring hz ) ( n : nat ) : hzleh 0 ( carry a n ) × hzlth ( carry a n ) ( nattohz ( hzabsval m ) ). Proof. intros. split. - unfold carry. apply ( pr2 ( pr1 ( divalgorithm ( precarry a n ) m is ) ) ). - unfold carry. apply ( pr2 ( pr1 ( divalgorithm ( precarry a n ) m is ) ) ). Defined. Lemma hzqrandcarryq ( a : fpscommring hz ) ( n : nat ) : 0 = hzquotientmod m is ( carry a n ). Proof. intros. apply ( hzqrtestq m is ( carry a n ) 0 ( carry a n ) ). split. - apply hzqrandcarryeq. - apply hzqrandcarryineq. Defined. Lemma hzqrandcarryr ( a : fpscommring hz ) ( n : nat ) : carry a n = hzremaindermod m is ( carry a n ). Proof. intros. apply ( hzqrtestr m is ( carry a n ) 0 ( carry a n ) ). split. - apply hzqrandcarryeq. - apply hzqrandcarryineq. Defined. Lemma doublecarry ( a : fpscommring hz ): carry ( carry a ) = carry a. Proof. intros. assert ( forall n : nat, carry ( carry a ) n = carry a n ) as f. { intros. induction n. - unfold carry. simpl. apply hzremaindermoditerated. - unfold carry. simpl. change (precarry (fun n0 : nat => hzremaindermod m is (precarry a n0)) n) with ( precarry ( carry a ) n ). rewrite precarryandcarry. rewrite <- hzqrandcarryq. rewrite hzplusr0. rewrite hzremaindermoditerated. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma carryandcarryequiv ( a : fpscommring hz ) : carryequiv ( carry a ) a. Proof. intros. simpl. rewrite doublecarry. apply idpath. Defined. Lemma quotientprecarryplus ( a b : fpscommring hz ) ( n : nat ) : hzquotientmod m is ( precarry ( a + b ) n ) = hzquotientmod m is ( precarry a n ) + hzquotientmod m is ( precarry b n ) + hzquotientmod m is ( precarry ( carry a + carry b ) n ). Proof. intros. induction n. - simpl. change ( hzquotientmod m is ( a 0%nat + b 0%nat ) = hzquotientmod m is (a 0%nat) + hzquotientmod m is (b 0%nat) + hzquotientmod m is ( hzremaindermod m is ( a 0%nat ) + hzremaindermod m is ( b 0%nat ) ) ). rewrite hzquotientmodandplus. apply idpath. - change ( hzquotientmod m is ( a ( S n ) + b ( S n ) + hzquotientmod m is ( precarry (a + b) n ) ) = hzquotientmod m is (precarry a (S n)) + hzquotientmod m is (precarry b (S n)) + hzquotientmod m is (carry a ( S n ) + carry b ( S n ) + hzquotientmod m is ( precarry (carry a + carry b) n)) ). rewrite IHn. rewrite ( ringassoc1 hz ( a ( S n ) ) ( b ( S n ) ) _ ). rewrite <- ( ringassoc1 hz ( b ( S n ) ) ). rewrite ( ringcomm1 hz ( b ( S n ) ) _ ). rewrite <- 3! ( ringassoc1 hz ( a ( S n ) ) _ _ ). change ( a ( S n ) + hzquotientmod m is ( precarry a n ) ) with ( precarry a ( S n ) ). set ( pa := precarry a ( S n ) ). rewrite ( ringassoc1 hz pa _ ( b ( S n ) ) ). rewrite ( ringcomm1 hz _ ( b ( S n ) ) ). change ( b ( S n ) + hzquotientmod m is ( precarry b n ) ) with ( precarry b ( S n ) ). set ( pb := precarry b ( S n ) ). set ( ab := precarry ( carry a + carry b ) ). rewrite ( ringassoc1 hz ( carry a ( S n ) ) ( carry b ( S n ) ) ( hzquotientmod m is ( ab n ) ) ). rewrite ( hzquotientmodandplus m is ( carry a ( S n ) ) _ ). unfold carry at 1. rewrite <- hzqrandremainderq. rewrite hzplusl0. rewrite ( hzquotientmodandplus m is ( carry b ( S n ) ) _ ). unfold carry at 1. rewrite <- hzqrandremainderq. rewrite hzplusl0. rewrite ( ringassoc1 hz pa pb _ ). rewrite ( hzquotientmodandplus m is pa _ ). change (pb + hzquotientmod m is (ab n)) with (pb + hzquotientmod m is (ab n))%hz. rewrite ( hzquotientmodandplus m is pb ( hzquotientmod m is ( ab n ) ) ). rewrite <- 2! ( ringassoc1 hz ( hzquotientmod m is pa ) _ _ ). rewrite <- 2! ( ringassoc1 hz ( hzquotientmod m is pa + hzquotientmod m is pb ) _ ). rewrite 2! ( ringassoc1 hz ( hzquotientmod m is pa + hzquotientmod m is pb + hzquotientmod m is (hzquotientmod m is (ab n)) ) _ _ ). apply ( maponpaths ( fun x : hz => hzquotientmod m is pa + hzquotientmod m is pb + hzquotientmod m is (hzquotientmod m is (ab n)) + x ) ). unfold carry at 1 2. rewrite 2! hzremaindermoditerated. change ( precarry b ( S n ) ) with pb. change ( precarry a ( S n ) ) with pa. apply ( maponpaths ( fun x : hz => ( hzquotientmod m is (hzremaindermod m is pb + hzremaindermod m is (hzquotientmod m is (ab n)))%hz ) + x ) ). apply maponpaths. apply ( maponpaths ( fun x : hz => hzremaindermod m is pa + x ) ). rewrite ( hzremaindermodandplus m is ( carry b ( S n ) ) _ ). unfold carry. rewrite hzremaindermoditerated. rewrite <- ( hzremaindermodandplus m is ( precarry b ( S n ) ) _ ). apply idpath. Defined. Lemma carryandplus ( a b : fpscommring hz ) : carry ( a + b ) = carry ( carry a + carry b ). Proof. intros. assert ( forall n : nat, carry ( a + b ) n = ( carry ( carry a + carry b ) n ) ) as f. { intros n. destruct n. - change ( hzremaindermod m is ( a 0%nat + b 0%nat ) = hzremaindermod m is ( hzremaindermod m is ( a 0%nat ) + hzremaindermod m is ( b 0%nat ) ) ). rewrite hzremaindermodandplus. apply idpath. - change ( hzremaindermod m is ( a ( S n ) + b ( S n ) + hzquotientmod m is ( precarry ( a + b ) n ) ) = hzremaindermod m is ( hzremaindermod m is ( a ( S n ) + hzquotientmod m is ( precarry a n ) ) + hzremaindermod m is ( b ( S n ) + hzquotientmod m is ( precarry b n ) ) + hzquotientmod m is ( precarry ( carry a + carry b ) n ) ) ). rewrite quotientprecarryplus. rewrite ( hzremaindermodandplus m is ( hzremaindermod m is (a (S n) + hzquotientmod m is (precarry a n)) + hzremaindermod m is (b (S n) + hzquotientmod m is (precarry b n)) ) _ ). change (hzremaindermod m is (a (S n) + hzquotientmod m is (precarry a n)) + hzremaindermod m is (b (S n) + hzquotientmod m is (precarry b n))) with (hzremaindermod m is (a (S n) + hzquotientmod m is (precarry a n))%ring + hzremaindermod m is (b (S n) + hzquotientmod m is (precarry b n))%ring)%hz. + rewrite <- (hzremaindermodandplus m is (a (S n) + hzquotientmod m is (precarry a n)) (b (S n) + hzquotientmod m is (precarry b n)) ). rewrite <- hzremaindermodandplus. change ( ((a (S n) + hzquotientmod m is (precarry a n))%ring + (b (S n) + hzquotientmod m is (precarry b n))%ring + hzquotientmod m is (precarry (carry a + carry b)%ring n))%hz ) with ((a (S n) + hzquotientmod m is (precarry a n))%ring + (b (S n) + hzquotientmod m is (precarry b n))%ring + hzquotientmod m is (precarry (carry a + carry b)%ring n))%ring. rewrite <- ( ringassoc1 hz ( a ( S n ) + hzquotientmod m is ( precarry a n ) ) (b (S n) ) ( hzquotientmod m is (precarry b n)) ). rewrite ( ringassoc1 hz ( a ( S n ) ) (hzquotientmod m is ( precarry a n ) ) ( b ( S n ) ) ). rewrite ( ringcomm1 hz ( hzquotientmod m is ( precarry a n ) ) ( b ( S n ) ) ). rewrite <- 3! ( ringassoc1 hz ). apply idpath. } apply ( funextfun _ _ f ). Defined. Definition quotientprecarry ( a : fpscommring hz ) : fpscommring hz := fun x : nat => hzquotientmod m is ( precarry a x ). Lemma quotientandtimesrearrangel ( x y : hz ) : hzquotientmod m is ( x * y ) = ( hzquotientmod m is x ) * y + hzquotientmod m is ( ( hzremaindermod m is x ) * y ). Proof. intros. rewrite hzquotientmodandtimes. change (hzquotientmod m is x * hzquotientmod m is y * m + hzremaindermod m is y * hzquotientmod m is x + hzremaindermod m is x * hzquotientmod m is y + hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y))%hz with (hzquotientmod m is x * hzquotientmod m is y * m + hzremaindermod m is y * hzquotientmod m is x + hzremaindermod m is x * hzquotientmod m is y + hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y))%ring. rewrite ( ringcomm2 hz ( hzremaindermod m is y ) ( hzquotientmod m is x ) ). rewrite ( ringassoc2 hz ). rewrite <- ( ringldistr hz ). rewrite ( ringcomm2 hz ( hzquotientmod m is y ) m ). change (m * hzquotientmod m is y + hzremaindermod m is y)%ring with (m * hzquotientmod m is y + hzremaindermod m is y)%hz. rewrite <- ( hzdivequationmod m is y ). change (hzremaindermod m is x * y)%ring with (hzremaindermod m is x * y)%hz. rewrite ( hzquotientmodandtimes m is ( hzremaindermod m is x ) y ). rewrite hzremaindermoditerated. rewrite <- hzqrandremainderq. rewrite hzmultx0. rewrite 2! hzmult0x. rewrite hzplusl0. rewrite ( ringassoc1 hz ). change (hzquotientmod m is x * y + (hzremaindermod m is x * hzquotientmod m is y + hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y))%hz) with (hzquotientmod m is x * y + (hzremaindermod m is x * hzquotientmod m is y + hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y)))%ring. apply idpath. Defined. (** here used to be shown the lemma [natsummationplusshift] *) Lemma precarryandtimesl ( a b : fpscommring hz ) ( n : nat ) : hzquotientmod m is ( precarry ( a * b ) n ) = ( quotientprecarry a * b ) n + hzquotientmod m is ( precarry ( carry a * b ) n ). Proof. intros. induction n. - unfold precarry. change ( ( a * b ) 0%nat ) with ( a 0%nat * b 0%nat ). change ( ( quotientprecarry a * b ) 0%nat ) with ( hzquotientmod m is ( a 0%nat ) * b 0%nat ). rewrite quotientandtimesrearrangel. change ( ( carry a * b ) 0%nat ) with ( hzremaindermod m is ( a 0%nat ) * b 0%nat ). apply idpath. - change ( precarry ( a * b ) ( S n ) ) with ( ( a * b ) ( S n ) + hzquotientmod m is ( precarry ( a * b ) n ) ). rewrite IHn. rewrite <- ( ringassoc1 hz ). assert ( ( ( a * b ) ( S n ) + ( quotientprecarry a * b ) n ) = ( @op2 ( fpscommring hz ) ( precarry a ) b ) ( S n ) ) as f. { change ( ( a * b ) ( S n ) ) with ( natsummation0 ( S n ) ( fun x : nat => a x * b ( sub ( S n ) x ) ) ). change ( ( quotientprecarry a * b ) n ) with ( natsummation0 n ( fun x : nat => quotientprecarry a x * b ( sub n x ) ) ). rewrite natsummationplusshift. change ( ( @op2 ( fpscommring hz ) ( precarry a ) b ) ( S n ) ) with ( natsummation0 ( S n ) ( fun x : nat => ( precarry a ) x * b ( sub ( S n ) x ) ) ). rewrite natsummationshift0. unfold precarry at 2. simpl. rewrite <- ( ringcomm1 hz ( a 0%nat * b ( S n ) ) _ ). apply ( maponpaths ( fun x : hz => a 0%nat * b ( S n ) + x ) ). apply natsummationpathsupperfixed. intros k j. unfold quotientprecarry. rewrite ( ringrdistr hz ). apply idpath. } rewrite f. rewrite hzquotientmodandplus. change ( @op2 ( fpscommring hz ) ( precarry a ) b ) with ( fpstimes hz ( precarry a ) b ). rewrite ( hzquotientandfpstimesl m is ( precarry a ) b ). change ( @op2 ( fpscommring hz ) ( carry a ) b ) with ( fpstimes hz ( carry a ) b ) at 1. unfold fpstimes at 1. unfold carry at 1. change (fun n0 : nat => let t' := fun m0 : nat => b (n0 - m0)%nat in natsummation0 n0 (fun x : nat => (hzremaindermod m is (precarry a x) * t' x)%ring)) with ( carry a * b ). change ( ( quotientprecarry a * b ) ( S n ) ) with ( natsummation0 ( S n ) ( fun i : nat => hzquotientmod m is ( precarry a i ) * b ( S n - i )%nat ) ). rewrite 2! hzplusassoc. apply ( maponpaths ( fun v => natsummation0 ( S n ) ( fun i : nat => hzquotientmod m is ( precarry a i ) * b ( S n - i )%nat ) + v ) ). change ( precarry ( carry a * b ) ( S n ) ) with ( ( carry a * b ) ( S n ) + hzquotientmod m is ( precarry ( carry a * b ) n ) ). change ((carry a * b) (S n) + hzquotientmod m is (precarry (carry a * b) n)) with ((carry a * b)%ring (S n) + hzquotientmod m is (precarry (carry a * b) n)%ring)%hz. rewrite ( hzquotientmodandplus m is ( ( carry a * b ) ( S n ) ) ( hzquotientmod m is ( precarry ( carry a * b ) n ) ) ). change ( ( carry a * b ) ( S n ) ) with ( natsummation0 ( S n ) ( fun i : nat => hzremaindermod m is ( precarry a i ) * b ( S n - i )%nat ) ). rewrite hzplusassoc. apply ( maponpaths ( fun v => ( hzquotientmod m is ( natsummation0 ( S n ) ( fun i : nat => hzremaindermod m is ( precarry a i ) * b ( S n - i )%nat ) ) ) + v ) ). apply ( maponpaths ( fun v => hzquotientmod m is ( hzquotientmod m is ( precarry ( carry a * b )%ring n ) ) + v ) ). apply maponpaths. apply ( maponpaths ( fun v => v + hzremaindermod m is ( hzquotientmod m is ( precarry ( carry a * b )%ring n ) ) ) ). unfold fpstimes. rewrite hzqrandnatsummation0r. rewrite ( hzqrandnatsummation0r m is ( fun i : nat => hzremaindermod m is ( precarry a i ) * b ( S n - i )%nat ) ). apply maponpaths. apply natsummationpathsupperfixed. intros j p. change ( hzremaindermod m is (hzremaindermod m is (precarry a j) * b ( sub ( S n ) j)) ) with ( hzremaindermod m is (hzremaindermod m is (precarry a j) * b (S n - j)%nat)%hz ). rewrite ( hzremaindermodandtimes m is ( hzremaindermod m is ( precarry a j ) ) ( b ( sub ( S n ) j ) ) ). rewrite hzremaindermoditerated. rewrite <- hzremaindermodandtimes. apply idpath. Defined. Lemma carryandtimesl ( a b : fpscommring hz ) : carry ( a * b ) = carry ( carry a * b ). Proof. intros. assert ( forall n : nat, carry ( a * b ) n = carry ( carry a * b ) n ) as f. { intros n. destruct n. - unfold carry at 1 2. change ( precarry ( a * b ) 0%nat ) with ( a 0%nat * b 0%nat ). change ( precarry ( carry a * b ) 0%nat ) with ( carry a 0%nat * b 0%nat ). unfold carry. change (hzremaindermod m is (precarry a 0) * b 0%nat) with (hzremaindermod m is (precarry a 0) * b 0%nat )%hz. rewrite ( hzremaindermodandtimes m is ( hzremaindermod m is ( precarry a 0%nat ) ) ( b 0%nat ) ). rewrite hzremaindermoditerated. rewrite <- hzremaindermodandtimes. change ( precarry a 0%nat ) with ( a 0%nat ). apply idpath. - unfold carry at 1 2. change ( precarry ( a * b ) ( S n ) ) with ( ( a * b ) ( S n ) + hzquotientmod m is ( precarry ( a * b ) n ) ). rewrite precarryandtimesl. rewrite <- ( ringassoc1 hz ). rewrite hzremaindermodandplus. assert ( hzremaindermod m is ( ( a * b ) ( S n ) + ( quotientprecarry a * b ) n ) = hzremaindermod m is ( ( carry a * b ) ( S n ) ) ) as g. { change ( hzremaindermod m is ( ( natsummation0 ( S n ) ( fun u : nat => a u * b ( sub ( S n ) u ) ) ) + ( natsummation0 n ( fun u : nat => ( quotientprecarry a ) u * b ( sub n u ) ) ) ) = hzremaindermod m is ( natsummation0 ( S n ) ( fun u : nat => ( carry a ) u * b ( sub ( S n ) u ) ) ) ). rewrite ( natsummationplusshift n ). rewrite ( natsummationshift0 n ( fun u : nat => carry a u * b ( sub ( S n ) u ) ) ). assert ( hzremaindermod m is ( natsummation0 n ( fun x : nat => a ( S x ) * b ( sub ( S n ) ( S x ) ) + quotientprecarry a x * b ( sub n x ) ) ) = hzremaindermod m is (natsummation0 n ( fun x : nat => carry a ( S x ) * b ( sub ( S n ) ( S x ) ) ) ) ) as h. { rewrite hzqrandnatsummation0r. rewrite ( hzqrandnatsummation0r m is ( fun x : nat => carry a ( S x ) * b ( sub ( S n ) ( S x ) ) ) ). apply maponpaths. apply natsummationpathsupperfixed. intros j p. unfold quotientprecarry. simpl. (* the following command takes overly long on Oct. 30, 2017: change (a (S j) * b ( sub n j) + hzquotientmod m is (precarry a j) * b ( sub n j)) with (a (S j) * b ( sub n j) + hzquotientmod m is (precarry a j) * b ( sub n j) )%hz. *) intermediate_path (hzremaindermod m is ((a (S j) * b ( sub n j) + hzquotientmod m is (precarry a j) * b ( sub n j) )%hz)). + exact (idpath _). + rewrite <- ( hzrdistr ( a ( S j ) ) ( hzquotientmod m is ( precarry a j ) ) ( b ( sub n j ) ) ). rewrite hzremaindermodandtimes. change ( hzremaindermod m is (hzremaindermod m is (a (S j) + hzquotientmod m is (precarry a j)) * hzremaindermod m is (b ( sub n j))) = hzremaindermod m is (carry a (S j) * b(sub n j)) )%ring. rewrite <- ( hzremaindermoditerated m is (a (S j) + hzquotientmod m is (precarry a j)) ). unfold carry. rewrite <- hzremaindermodandtimes. apply idpath. } rewrite hzremaindermodandplus. rewrite h. rewrite <- hzremaindermodandplus. unfold carry at 3. rewrite ( hzremaindermodandplus m is _ ( hzremaindermod m is ( precarry a 0%nat ) * b ( sub ( S n ) 0%nat ) ) ). rewrite hzremaindermodandtimes. rewrite hzremaindermoditerated. rewrite <- hzremaindermodandtimes. change ( precarry a 0%nat ) with ( a 0%nat ). rewrite <- hzremaindermodandplus. rewrite hzpluscomm. apply idpath. } rewrite g. rewrite <- hzremaindermodandplus. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma carryandtimesr ( a b : fpscommring hz ) : carry ( a * b ) = carry ( a * carry b ). Proof. intros. rewrite ( @ringcomm2 ( fpscommring hz ) ). rewrite carryandtimesl. rewrite ( @ringcomm2 ( fpscommring hz ) ). apply idpath. Defined. Lemma carryandtimes ( a b : fpscommring hz ) : carry ( a * b ) = carry ( carry a * carry b ). Proof. intros. rewrite carryandtimesl. rewrite carryandtimesr. apply idpath. Defined. Lemma ringcarryequiv : @ringeqrel ( fpscommring hz ). Proof. intros. split with carryequiv. split. - split. + intros a b c q. simpl. simpl in q. rewrite carryandplus. rewrite q. rewrite <- carryandplus. apply idpath. + intros a b c q. simpl. rewrite carryandplus. rewrite q. rewrite <- carryandplus. apply idpath. - split. + intros a b c q. simpl. rewrite carryandtimes. rewrite q. rewrite <- carryandtimes. apply idpath. + intros a b c q. simpl. rewrite carryandtimes. rewrite q. rewrite <- carryandtimes. apply idpath. Defined. End carry. (** ** Some preparation for parts III/IV that does not depend on a prime number *) (** Those used to appear where needed below, those points have been marked by comments. *) Lemma commringquotprandop1 { A : commring } ( R : @ringeqrel A ) ( a b : A ) : @op1 ( commringquot R ) ( setquotpr ( pr1 R ) a ) ( setquotpr ( pr1 R ) b ) = setquotpr ( pr1 R ) ( a + b ). Proof. intros. change ( @op1 ( commringquot R ) ) with ( setquotfun2 R R ( @op1 A ) ( pr1 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) ). unfold setquotfun2. rewrite setquotuniv2comm. apply idpath. Defined. Lemma commringquotprandop2 { A : commring } ( R : @ringeqrel A ) ( a b : A ) : @op2 ( commringquot R ) ( setquotpr ( pr1 R ) a ) ( setquotpr ( pr1 R ) b ) = setquotpr ( pr1 R ) ( a * b ). Proof. intros. change ( @op2 ( commringquot R ) ) with ( setquotfun2 R R ( @op2 A ) ( pr2 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) ). unfold setquotfun2. rewrite setquotuniv2comm. apply idpath. Defined. Lemma hzfpstimesnonzero ( a : fpscommring hz ) ( k : nat ) ( is : neq hz ( a k ) 0%hz × forall m : nat, natlth m k -> a m = 0%hz ) : forall k' : nat, forall b : fpscommring hz , forall is' : neq hz ( b k' ) 0%hz × forall m : nat, natlth m k' -> b m = 0%hz, ( a * b ) ( k + k' )%nat = a k * b k'. Proof. intros k'. induction k'. - intros. destruct k. + simpl. apply idpath. + rewrite natplusr0. change ( natsummation0 k ( fun x : nat => a x * b ( sub ( S k ) x ) ) + a ( S k ) * b ( sub ( S k ) ( S k ) ) = a ( S k ) * b 0%nat ). assert ( natsummation0 k ( fun x : nat => a x * b ( sub ( S k ) x ) ) = natsummation0 k ( fun x : nat => 0%hz ) ) as f. { apply natsummationpathsupperfixed. intros m i. assert ( natlth m ( S k ) ) as i0. * apply ( natlehlthtrans _ k _ ). -- assumption. -- apply natlthnsn. * rewrite ( pr2 is m i0 ). rewrite hzmult0x. apply idpath. } rewrite f. rewrite natsummationae0bottom. * rewrite hzplusl0. rewrite minusnn0. apply idpath. * intros m i. apply idpath. - intros. rewrite natplusnsm. change ( natsummation0 ( k + k' )%nat ( fun x : nat => a x * b ( sub ( S k + k' ) x ) ) + a ( S k + k' )%nat * b ( sub ( S k + k' ) ( S k + k' ) ) = a k * b ( S k' ) ). set ( b' := fpsshift b ). rewrite minusnn0. rewrite ( pr2 is' 0%nat ( natlehlthtrans 0 k' ( S k' ) ( natleh0n k' ) ( natlthnsn k' ) ) ). rewrite hzmultx0. rewrite hzplusr0. assert ( natsummation0 ( k + k' )%nat ( fun x : nat => a x * b ( sub ( S k + k' ) x ) ) = fpstimes hz a b' ( k + k' )%nat ) as f. { apply natsummationpathsupperfixed. intros m v. change ( S k + k' )%nat with ( S ( k + k' ) ). rewrite <- ( pathssminus ( k + k' )%nat m ). + apply idpath. + apply ( natlehlthtrans _ ( k + k' )%nat _ ). * assumption. * apply natlthnsn. } rewrite f. apply ( IHk' b' ). split. + apply is'. + intros m v. unfold b'. unfold fpsshift. apply is'. assumption. Defined. Lemma hzfpstimeswhenzero ( a : fpscommring hz ) ( m k : nat ) ( is : ( forall m : nat, natlth m k -> a m = 0%hz ) ) : forall b : fpscommring hz, forall k' : nat, forall is' : ( forall m : nat, natlth m k' -> b m = 0%hz ) , natlth m ( k + k' )%nat -> ( a * b ) m = 0%hz. Proof. revert k is. induction m. - intros k. intros is b k' is' j. change ( a 0%nat * b 0%nat = 0%hz ). destruct k. + rewrite ( is' 0%nat j ). rewrite hzmultx0. apply idpath. + assert ( natlth 0 ( S k ) ) as i. { apply ( natlehlthtrans _ k _ ). * apply natleh0n. * apply natlthnsn. } rewrite ( is 0%nat i ). rewrite hzmult0x. apply idpath. - intros k is b k' is' j. change ( natsummation0 ( S m ) ( fun x : nat => a x * b ( sub ( S m ) x ) ) = 0%hz ). change ( natsummation0 m ( fun x : nat => a x * b ( sub ( S m ) x ) ) + a ( S m ) * b ( sub ( S m ) ( S m ) ) = 0%hz ). assert ( a ( S m ) * b ( sub ( S m ) ( S m ) ) = 0%hz ) as g. { destruct k. + destruct k'. * apply fromempty. apply ( negnatgth0n ( S m ) j ). * rewrite minusnn0. rewrite ( is' 0%nat ( natlehlthtrans 0%nat k' ( S k' ) ( natleh0n k' ) ( natlthnsn k' ) ) ). rewrite hzmultx0. apply idpath. + destruct k'. * rewrite natplusr0 in j. rewrite ( is ( S m ) j ). rewrite hzmult0x. apply idpath. * rewrite minusnn0. rewrite ( is' 0%nat ( natlehlthtrans 0%nat k' ( S k' ) ( natleh0n k' ) ( natlthnsn k' ) ) ). rewrite hzmultx0. apply idpath. } rewrite g. rewrite hzplusr0. set ( b' := fpsshift b ). assert ( natsummation0 m ( fun x : nat => a x * b ( sub ( S m ) x ) ) = natsummation0 m ( fun x : nat => a x * b' ( sub m x ) ) ) as f. { apply natsummationpathsupperfixed. intros n i. unfold b'. unfold fpsshift. rewrite pathssminus. + apply idpath. + apply ( natlehlthtrans _ m _ ). * assumption. * apply natlthnsn. } rewrite f. change ( ( a * b' ) m = 0%hz ). assert ( natlth m ( k + k' ) ) as one. { apply ( istransnatlth _ ( S m ) _ ). + apply natlthnsn. + assumption. } destruct k'. + assert ( forall m : nat, natlth m 0%nat -> b' m = 0%hz ) as two. { intros m0 j0. apply fromempty. apply ( negnatgth0n m0). assumption. } apply ( IHm k is b' 0%nat two one ). + assert ( forall m : nat, natlth m k' -> b' m = 0%hz ) as two. { intros m0 j0. change ( b ( S m0 ) = 0%hz ). apply is'. assumption. } assert ( natlth m ( k + k' )%nat ) as three. { rewrite natplusnsm in j. apply j. } apply ( IHm k is b' k' two three ). Defined. (** ** Definition of p-adic integers *) Section A. Variable p : hz. Variable is : isaprime p. Definition commringofpadicints := commringquot ( ringcarryequiv p ( isaprimetoneq0 is ) ). Definition padicplus := @op1 commringofpadicints. Definition padictimes := @op2 commringofpadicints. (** * III. The apartness relation on p-adic integers *) Definition padicapart0 : hrel ( fpscommring hz ) := fun a b => ∃ n : nat, neq _ ( carry p ( isaprimetoneq0 is) a n ) ( carry p ( isaprimetoneq0 is) b n ). Lemma padicapartiscomprel : iscomprelrel ( carryequiv p ( isaprimetoneq0 is ) ) padicapart0. Proof. intros a a' b b' i j. apply hPropUnivalence. - intro k. use (hinhuniv _ k). intros u. destruct u as [ n u ]. apply total2tohexists. split with n. rewrite <- i , <- j. assumption. - intro k. use (hinhuniv _ k). intros u. destruct u as [ n u ]. apply total2tohexists. split with n. rewrite i, j. assumption. Defined. Definition padicapart1 : hrel commringofpadicints := quotrel padicapartiscomprel. Lemma isirreflpadicapart0 : isirrefl padicapart0. Proof. intros a f. simpl in f. assert hfalse as x. { apply f. intros u. destruct u as [ n u ]. apply u. apply idpath. } exact x. Defined. Lemma issymmpadicapart0 : issymm padicapart0. Proof. intros a b f. use (hinhuniv _ f). intros u. destruct u as [ n u ]. apply total2tohexists. split with n. intros g. unfold neq in u. apply u. rewrite g. apply idpath. Defined. Lemma iscotranspadicapart0 : iscotrans padicapart0. Proof. intros a b c f. use (hinhuniv _ f). intro u. destruct u as [ n u ]. intros P j. apply j. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a n ) ( carry p ( isaprimetoneq0 is ) b n ) ) as [ l | r ]. - apply ii2. intros Q k. apply k. split with n. intros g. unfold neq in u. apply u. rewrite l, g. apply idpath. - apply ii1. intros Q k. apply k. split with n. intros g. apply r. assumption. Defined. Definition padicapart : apart commringofpadicints. Proof. intros. split with padicapart1. split. - unfold padicapart1. apply ( isirreflquotrel padicapartiscomprel isirreflpadicapart0 ). - split. + apply ( issymmquotrel padicapartiscomprel issymmpadicapart0 ). + apply ( iscotransquotrel padicapartiscomprel iscotranspadicapart0 ). Defined. Lemma precarryandzero : precarry p ( isaprimetoneq0 is ) 0 = @ringunel1 ( fpscommring hz ). Proof. intros. assert ( forall n : nat, precarry p ( isaprimetoneq0 is ) 0 n = @ringunel1 (fpscommring hz ) n ) as f. { intros n. induction n. - unfold precarry. change ( @ringunel1 ( fpscommring hz ) 0%nat ) with 0%hz. apply idpath. - change ( ( ( @ringunel1 ( fpscommring hz ) ( S n ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( @ringunel1 ( fpscommring hz ) ) n ) ) ) = 0%hz ). rewrite IHn. change ( @ringunel1 ( fpscommring hz ) n ) with 0%hz. change ( @ringunel1 ( fpscommring hz ) ( S n ) ) with 0%hz. rewrite hzqrand0q. rewrite hzplusl0. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma carryandzero : carry p ( isaprimetoneq0 is ) 0 = 0. Proof. intros. unfold carry. rewrite precarryandzero. assert ( forall n : nat, (fun n : nat => hzremaindermod p (isaprimetoneq0 is) ( @ringunel1 ( fpscommring hz ) n)) n = @ringunel1 ( fpscommring hz ) n ) as f. { intros n. rewrite hzqrand0r. unfold carry. change ( @ringunel1 ( fpscommring hz) n ) with 0%hz. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma precarryandone : precarry p ( isaprimetoneq0 is ) 1 = @ringunel2 ( fpscommring hz ). Proof. intros. assert ( forall n : nat, precarry p ( isaprimetoneq0 is ) 1 n = @ringunel2 (fpscommring hz ) n ) as f. { intros n. induction n. - unfold precarry. apply idpath. - simpl. rewrite IHn. destruct n. + change ( @ringunel2 ( fpscommring hz ) 0%nat ) with 1%hz. rewrite hzqrand1q. rewrite hzplusr0. apply idpath. + change ( @ringunel2 ( fpscommring hz ) ( S n ) ) with 0%hz. rewrite hzqrand0q. rewrite hzplusr0. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma carryandone : carry p ( isaprimetoneq0 is ) 1 = 1. Proof. intros. unfold carry. rewrite precarryandone. assert ( forall n : nat, (fun n : nat => hzremaindermod p (isaprimetoneq0 is) ( @ringunel2 ( fpscommring hz ) n)) n = @ringunel2 ( fpscommring hz ) n ) as f. { intros n. destruct n. - change ( @ringunel2 ( fpscommring hz ) 0%nat ) with 1%hz. rewrite hzqrand1r. apply idpath. - change ( @ringunel2 ( fpscommring hz ) ( S n ) ) with 0%hz. rewrite hzqrand0r. apply idpath. } apply ( funextfun _ _ f ). Defined. Lemma padicapartcomputation ( a b : fpscommring hz ) : ( pr1 padicapart ) ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a ) ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) = padicapart0 a b. Proof. intros. apply hPropUnivalence. - intros i. apply i. - intro u. apply u. Defined. Lemma padicapartandplusprecarryl ( a b c : fpscommring hz ) ( n : nat ) ( x : neq _ ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) b ) n ) ( ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) c ) ) n ) ) : padicapart0 b c. Proof. intros. set ( P := fun x : nat => neq hz (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a + carry p (isaprimetoneq0 is) b) x) (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a + carry p (isaprimetoneq0 is) c) x) ). assert ( isdecnatprop P ) as isdec. { intros m. destruct ( isdeceqhz (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a + carry p (isaprimetoneq0 is) b) m) (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a + carry p (isaprimetoneq0 is) c) m) ) as [ l | r ]. - apply ii2. intros j. unfold P in j. unfold neq in j. apply j. assumption. - apply ii1. assumption. } set ( leexists := leastelementprinciple n P isdec x ). use (hinhuniv _ leexists). intro k. destruct k as [ k k' ]. destruct k' as [ k' k'' ]. destruct k. - apply total2tohexists. split with 0%nat. intros i. unfold P in k'. unfold neq in k'. (* crucial *) apply k'. change (carry p (isaprimetoneq0 is) a 0%nat + carry p (isaprimetoneq0 is) b 0%nat = (carry p (isaprimetoneq0 is) a 0%nat + carry p (isaprimetoneq0 is) c 0%nat) ). rewrite i. apply idpath. - apply total2tohexists. split with ( S k ). intro i. apply ( k'' k ). + apply natlthnsn. + intro j. unfold P in k'. unfold neq in k'. (* crucial *) apply k'. change ( carry p ( isaprimetoneq0 is ) a ( S k ) + carry p ( isaprimetoneq0 is ) b ( S k ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) b ) k ) = ( carry p ( isaprimetoneq0 is ) a ( S k ) + carry p ( isaprimetoneq0 is ) c ( S k ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) c ) k ) ) ). rewrite i. rewrite j. apply idpath. Defined. Lemma padicapartandplusprecarryr ( a b c : fpscommring hz ) ( n : nat ) ( x : neq _ ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) b + carry p ( isaprimetoneq0 is ) a ) n ) ( ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) c + carry p ( isaprimetoneq0 is ) a ) ) n ) ) : padicapart0 b c. Proof. intros. rewrite 2! ( ringcomm1 ( fpscommring hz ) _ ( carry p ( isaprimetoneq0 is ) a ) ) in x. apply ( padicapartandplusprecarryl a b c n x ). Defined. (** here used to be shown the lemmas [commringquotprandop1] and [commringquotprandop2] *) Lemma setquotprandpadicplus ( a b : fpscommring hz ) : @op1 commringofpadicints ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a ) ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) = setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( a + b ). Proof. intros. apply commringquotprandop1. Defined. Lemma setquotprandpadictimes ( a b : fpscommring hz ) : @op2 commringofpadicints ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a ) ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) = setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( a * b ). Proof. intros. apply commringquotprandop2. Defined. Lemma padicplusisbinopapart0 ( a b c : fpscommring hz ) ( u : padicapart0 ( a + b ) ( a + c ) ) : padicapart0 b c. Proof. intros. use (hinhuniv _ u). intros n. destruct n as [ n n' ]. set ( P := fun x : nat => neq hz ( carry p ( isaprimetoneq0 is ) ( a + b) x) ( carry p ( isaprimetoneq0 is ) ( a + c) x) ). assert ( isdecnatprop P ) as isdec. { intros m. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) ( a + b) m) ( carry p ( isaprimetoneq0 is ) ( a + c) m) ) as [ l | r ]. - apply ii2. intros j. unfold P in j. unfold neq in j. (* crucial *) apply j. assumption. - apply ii1. assumption. } set ( le := leastelementprinciple n P isdec n'). use (hinhuniv _ le). intro k. destruct k as [ k k' ]. destruct k' as [ k' k'' ]. destruct k. - apply total2tohexists. split with 0%nat. intros j. unfold P in k'. unfold neq in k'. (* crucial *) apply k'. unfold carry. unfold precarry. change ( ( a + b ) 0%nat ) with ( a 0%nat + b 0%nat ). change ( ( a + c ) 0%nat ) with ( a 0%nat + c 0%nat ). unfold carry in j. unfold precarry in j. rewrite hzremaindermodandplus. rewrite j. rewrite <- hzremaindermodandplus. apply idpath. - destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b ( S k ) ) ( carry p ( isaprimetoneq0 is ) c ( S k ) ) ) as [ l | r ]. + apply ( padicapartandplusprecarryl a b c k ). intros j. unfold P in k'. unfold neq in k'. apply k'. rewrite carryandplus. unfold carry at 1. change (hzremaindermod p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a ( S k ) + carry p ( isaprimetoneq0 is ) b ( S k ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) b ) k ) ) = carry p ( isaprimetoneq0 is ) ( a + c ) ( S k ) ). rewrite l. rewrite j. rewrite ( carryandplus p ( isaprimetoneq0 is ) a c ). unfold carry at 5. change ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) c ) ( S k ) ) with ( carry p ( isaprimetoneq0 is ) a ( S k ) + carry p ( isaprimetoneq0 is ) c ( S k ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a + carry p ( isaprimetoneq0 is ) c ) k ) ). apply idpath. + apply total2tohexists. split with ( S k ). assumption. Defined. Lemma padicplusisbinopapartl : isbinopapartl padicapart padicplus. Proof. intros. unfold isbinopapartl. assert ( forall x x' x'' : commringofpadicints, isaprop ( pr1 padicapart ( padicplus x x' ) ( padicplus x x'' ) -> ( pr1 padicapart x' x'' ) ) ) as int. { intros. apply impred. intros. apply ( pr1 padicapart ). } apply ( setquotuniv3prop _ ( fun x x' x'' => make_hProp _ ( int x x' x'' ) ) ). intros a b c. change (pr1 padicapart (padicplus (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) a) (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) b)) (padicplus (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) a) (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) c)) -> pr1 padicapart (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) b) (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) c)). unfold padicplus. rewrite 2! setquotprandpadicplus. rewrite 2! padicapartcomputation. apply padicplusisbinopapart0. Defined. Lemma padicplusisbinopapartr : isbinopapartr padicapart padicplus. Proof. intros. unfold isbinopapartr. intros a b c. unfold padicplus. rewrite ( @ringcomm1 commringofpadicints b a ). rewrite ( @ringcomm1 commringofpadicints c a ). apply padicplusisbinopapartl. Defined. Lemma padicapartandtimesprecarryl ( a b c : fpscommring hz ) ( n : nat ) ( x : neq _ ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) n ) ( ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) c ) ) n ) ) : padicapart0 b c. Proof. intros. set ( P := fun x : nat => neq hz (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a * carry p (isaprimetoneq0 is) b) x) (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a * carry p (isaprimetoneq0 is) c) x) ). assert ( isdecnatprop P ) as isdec. { intros m. destruct ( isdeceqhz (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a * carry p (isaprimetoneq0 is) b) m) (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a * carry p (isaprimetoneq0 is) c) m) ) as [ l | r ]. - apply ii2. intros j. unfold P in j. unfold neq in j. apply j. assumption. - apply ii1. assumption. } set ( leexists := leastelementprinciple n P isdec x ). use (hinhuniv _ leexists). intro k. destruct k as [ k k' ]. destruct k' as [ k' k'' ]. induction k. - apply total2tohexists. split with 0%nat. intros i. unfold P in k'. unfold neq in k'. apply k'. change (carry p (isaprimetoneq0 is) a 0%nat * carry p(isaprimetoneq0 is) b 0%nat = carry p (isaprimetoneq0 is) a 0%nat * carry p (isaprimetoneq0 is) c 0%nat ). rewrite i. apply idpath. - set ( Q := ( fun o : nat => make_hProp ( carry p ( isaprimetoneq0 is ) b o = carry p ( isaprimetoneq0 is ) c o ) ( isasethz _ _ ) ) ). assert ( isdecnatprop Q ) as isdec'. { intro o. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b o ) ( carry p ( isaprimetoneq0 is ) c o ) ) as [ l | r ]. + apply ii1. assumption. + apply ii2. assumption. } destruct ( isdecisbndqdec Q isdec' ( S k ) ) as [ l | r ]. + apply fromempty. apply ( k'' k ). { apply natlthnsn. } intro j. unfold P in k'. unfold neq in k'. apply k'. change ( ( natsummation0 ( S k ) ( fun x : nat => carry p ( isaprimetoneq0 is ) a x * carry p ( isaprimetoneq0 is ) b ( sub ( S k ) x ) ) ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) k ) = (( natsummation0 ( S k ) ( fun x : nat => carry p ( isaprimetoneq0 is ) a x * carry p ( isaprimetoneq0 is ) c ( sub ( S k ) x ) ) ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) c ) k ) ) ). assert ( natsummation0 ( S k ) (fun x0 : nat => carry p (isaprimetoneq0 is) a x0 * carry p (isaprimetoneq0 is) b ( sub ( S k ) x0)) = natsummation0 ( S k ) (fun x0 : nat => carry p (isaprimetoneq0 is) a x0 * carry p (isaprimetoneq0 is) c ( sub ( S k ) x0)) ) as f. { apply natsummationpathsupperfixed. intros m y. rewrite ( l ( sub ( S k ) m ) ). * apply idpath. * apply minusleh. } rewrite f. rewrite j. apply idpath. + use (hinhuniv _ r). intros o. destruct o as [ o o' ]. apply total2tohexists. split with o. apply o'. Defined. Lemma padictimesisbinopapart0 ( a b c : fpscommring hz ) ( u : padicapart0 ( a * b ) ( a * c ) ) : padicapart0 b c. Proof. intros. use (hinhuniv _ u). intros n. destruct n as [ n n' ]. destruct n. - apply total2tohexists. split with 0%nat. intros j. unfold neq in n'. apply n'. rewrite carryandtimes. rewrite ( carryandtimes p ( isaprimetoneq0 is ) a c ). change ( hzremaindermod p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a 0%nat * carry p ( isaprimetoneq0 is ) b 0%nat ) = hzremaindermod p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a 0%nat * carry p ( isaprimetoneq0 is ) c 0%nat ) ). rewrite j. apply idpath. - set ( Q := ( fun o : nat => make_hProp ( carry p ( isaprimetoneq0 is ) b o = carry p ( isaprimetoneq0 is ) c o ) ( isasethz _ _ ) ) ). assert ( isdecnatprop Q ) as isdec'. { intro o. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b o ) ( carry p ( isaprimetoneq0 is ) c o ) ) as [ l | r ]. + apply ii1. assumption. + apply ii2. assumption. } destruct ( isdecisbndqdec Q isdec'( S n ) ) as [ l | r ]. + apply ( padicapartandtimesprecarryl a b c n ). intros j. apply fromempty. unfold neq in n'. apply n'. rewrite carryandtimes. rewrite ( carryandtimes p ( isaprimetoneq0 is ) a c ). change ( hzremaindermod p ( isaprimetoneq0 is ) ( natsummation0 ( S n ) ( fun x : nat => carry p ( isaprimetoneq0 is ) a x * carry p ( isaprimetoneq0 is ) b ( sub ( S n ) x ) ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) n ) ) = ( hzremaindermod p ( isaprimetoneq0 is ) ( natsummation0 ( S n ) ( fun x : nat => carry p ( isaprimetoneq0 is ) a x * carry p ( isaprimetoneq0 is ) c ( sub ( S n ) x ) ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) c ) n ) ) ) ). rewrite j. assert ( natsummation0 ( S n ) (fun x0 : nat => carry p (isaprimetoneq0 is) a x0 * carry p (isaprimetoneq0 is) b ( sub ( S n ) x0)) = natsummation0 ( S n ) (fun x0 : nat => carry p (isaprimetoneq0 is) a x0 * carry p (isaprimetoneq0 is) c ( sub ( S n ) x0)) ) as f. { apply natsummationpathsupperfixed. intros m y. rewrite ( l ( sub ( S n ) m ) ). * apply idpath. * apply minusleh. } rewrite f. apply idpath. + use (hinhuniv _ r). intros k. destruct k as [ k k' ]. apply total2tohexists. split with k. apply k'. Defined. Lemma padictimesisbinopapartl : isbinopapartl padicapart padictimes. Proof. intros. unfold isbinopapartl. assert ( forall x x' x'' : commringofpadicints, isaprop ( pr1 padicapart ( padictimes x x' ) ( padictimes x x'' ) -> ( pr1 padicapart x' x'' ) ) ) as int. { intros. apply impred. intros. apply ( pr1 padicapart ). } apply ( setquotuniv3prop _ ( fun x x' x'' => make_hProp _ ( int x x' x'' ) ) ). intros a b c. change (pr1 padicapart (padictimes (setquotpr (carryequiv p (isaprimetoneq0 is)) a) (setquotpr (carryequiv p (isaprimetoneq0 is)) b)) (padictimes (setquotpr (carryequiv p (isaprimetoneq0 is)) a) (setquotpr (carryequiv p (isaprimetoneq0 is)) c)) -> pr1 padicapart (setquotpr (carryequiv p (isaprimetoneq0 is)) b) (setquotpr (carryequiv p (isaprimetoneq0 is)) c)). unfold padictimes. rewrite 2! setquotprandpadictimes. rewrite 2! padicapartcomputation. intros j. apply ( padictimesisbinopapart0 a b c j ). Defined. Lemma padictimesisbinopapartr : isbinopapartr padicapart padictimes. Proof. intros. unfold isbinopapartr. intros a b c. unfold padictimes. rewrite ( @ringcomm2 commringofpadicints b a ). rewrite ( @ringcomm2 commringofpadicints c a ). apply padictimesisbinopapartl. Defined. Definition acommringofpadicints : acommring. Proof. intros. split with commringofpadicints. split with padicapart. split. - split. + apply padicplusisbinopapartl. + apply padicplusisbinopapartr. - split. + apply padictimesisbinopapartl. + apply padictimesisbinopapartr. Defined. (** * IV. The apartness domain of p-adic integers and the Heyting field of p-adic numbers *) Lemma precarryandzeromultl ( a b : fpscommring hz ) ( n : nat ) ( x : forall m : nat, natlth m n -> carry p ( isaprimetoneq0 is ) a m = 0%hz ) : forall m : nat, natlth m n -> precarry p ( isaprimetoneq0 is ) ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) m = 0%hz. Proof. intros m y. induction m. - simpl. unfold fpstimes. simpl. rewrite ( x 0%nat y ). rewrite hzmult0x. apply idpath. - change ( natsummation0 ( S m ) ( fun z : nat => ( carry p ( isaprimetoneq0 is ) a z ) * ( carry p ( isaprimetoneq0 is ) b ( sub ( S m ) z ) ) ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) m ) = 0%hz ). assert ( natlth m n ) as u. + apply ( istransnatlth _ ( S m ) _ ). { apply natlthnsn. } assumption. + rewrite ( IHm u ). rewrite hzqrand0q. rewrite hzplusr0. assert ( natsummation0 (S m) (fun z : nat => carry p (isaprimetoneq0 is) a z * carry p (isaprimetoneq0 is) b ( sub ( S m ) z)) = natsummation0 ( S m ) ( fun z : nat => 0%hz ) ) as f. { apply natsummationpathsupperfixed. intros k v. assert ( natlth k n ) as uu. * apply ( natlehlthtrans _ ( S m ) _ ); assumption. * rewrite ( x k uu ). rewrite hzmult0x. apply idpath. } rewrite f. rewrite natsummationae0bottom. * apply idpath. * intros k l. apply idpath. Defined. Lemma precarryandzeromultr ( a b : fpscommring hz ) ( n : nat ) ( x : forall m : nat, natlth m n -> carry p ( isaprimetoneq0 is ) b m = 0%hz ) : forall m : nat, natlth m n -> precarry p ( isaprimetoneq0 is ) ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) m = 0%hz. Proof. intros m y. change (fpstimes hz (carry p (isaprimetoneq0 is) a) (carry p (isaprimetoneq0 is) b)) with ( (carry p (isaprimetoneq0 is) a) * (carry p (isaprimetoneq0 is) b)). rewrite ( @ringcomm2 ( fpscommring hz ) ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ). apply ( precarryandzeromultl b a n x m y ). Defined. (** here used to be shown the lemmas [hzfpstimesnonzero] and [hzfpstimeswhenzero], now before part III *) Lemma precarryandzeromult ( a b : fpscommring hz ) ( k k' : nat ) ( x : forall m : nat, natlth m k -> carry p ( isaprimetoneq0 is ) a m = 0%hz ) ( x' : forall m : nat, natlth m k' -> carry p ( isaprimetoneq0 is ) b m = 0%hz ) : forall m : nat, natlth m ( k + k' )%nat -> precarry p ( isaprimetoneq0 is ) ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) m = 0%hz. Proof. intros m i. induction m. - apply ( hzfpstimeswhenzero ( carry p ( isaprimetoneq0 is ) a ) 0%nat k x ( carry p ( isaprimetoneq0 is ) b ) k' x' i ). - change ( ( ( carry p ( isaprimetoneq0 is ) a ) * ( carry p ( isaprimetoneq0 is ) b ) ) ( S m ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) m ) = 0%hz ). rewrite ( hzfpstimeswhenzero ( carry p ( isaprimetoneq0 is ) a ) ( S m ) k x ( carry p ( isaprimetoneq0 is ) b ) k' x' i ). rewrite hzplusl0. assert ( natlth m ( k + k' )%nat ) as one. { apply ( istransnatlth _ ( S m ) _ ). + apply natlthnsn. + assumption. } rewrite ( IHm one ). rewrite hzqrand0q. apply idpath. Defined. Lemma primedivorcoprime ( a : hz ) : hzdiv p a ∨ gcd p a ( isaprimetoneq0 is ) = 1. Proof. intros P i. use (hinhuniv _ ( pr2 is ( gcd p a ( isaprimetoneq0 is ) ) ( pr1 ( gcdiscommondiv p a ( isaprimetoneq0 is ) ) ) )). intro t. apply i. destruct t as [ t0 | t1 ]. - apply ii2. assumption. - apply ii1. rewrite <- t1. exact ( pr2 ( gcdiscommondiv p a ( isaprimetoneq0 is ) ) ). Defined. Lemma primeandtimes ( a b : hz ) ( x : hzdiv p ( a * b ) ) : hzdiv p a ∨ hzdiv p b. Proof. intros. use (hinhuniv _ ( primedivorcoprime a )). intros j. intros P i. apply i. destruct j as [ j0 | j1 ]. - apply ii1. assumption. - apply ii2. use (hinhuniv _ x). intro u. destruct u as [ k u ]. unfold hzdiv0 in u. set ( cd := bezoutstrong a p ( isaprimetoneq0 is ) ). destruct cd as [ cd f ]. destruct cd as [ c d ]. rewrite j1 in f. simpl in f. assert ( b = ( b * c + d * k ) * p ) as g. { assert ( b = b * 1 ) as g0. { rewrite hzmultr1. apply idpath. } rewrite g0. rewrite ( ringrdistr hz ( b * 1 * c ) ( d * k ) p ). assert ( b * ( c * p + d * a ) = b * 1 * c * p + d * k * p ) as h. { rewrite ( ringldistr hz ( c * p ) ( d * a ) b ). rewrite hzmultr1. rewrite 2! ( @ringassoc2 hz ). rewrite ( @ringcomm2 hz k p ). change ( p * k )%hz with ( p * k )%ring in u. rewrite u. rewrite ( @ringcomm2 hz b ( d * a ) ). rewrite ( @ringassoc2 hz ). apply idpath. } rewrite <- h. rewrite f. apply idpath. } intros Q uu. apply uu. split with ( b * c + d * k ). rewrite ( @ringcomm2 hz _ p ) in g. unfold hzdiv0. apply pathsinv0. assumption. Defined. Lemma hzremaindermodprimeandtimes ( a b : hz ) ( x : hzremaindermod p ( isaprimetoneq0 is ) ( a * b ) = 0 ) : hzremaindermod p ( isaprimetoneq0 is ) a = 0 ∨ hzremaindermod p ( isaprimetoneq0 is ) b = 0. Proof. intros. assert ( hzdiv p ( a * b ) ) as i. { intros P i'. apply i'. split with ( hzquotientmod p ( isaprimetoneq0 is ) ( a * b ) ). unfold hzdiv0. apply pathsinv0. rewrite <- ( hzplusr0 (p * hzquotientmod p (isaprimetoneq0 is) (a * b)%ring) )%hz. change (a * b = (p * hzquotientmod p (isaprimetoneq0 is) (a * b)%ring + 0)%ring). rewrite <- x. change (p * hzquotientmod p (isaprimetoneq0 is) (a * b) + hzremaindermod p (isaprimetoneq0 is) a * b) with (p * hzquotientmod p (isaprimetoneq0 is) (a * b)%ring + ( hzremaindermod p (isaprimetoneq0 is) a * b )%ring )%hz. apply ( hzdivequationmod p ( isaprimetoneq0 is ) ( a * b ) ). } use (hinhuniv _ ( primeandtimes a b i )). intro t. destruct t as [ t0 | t1 ]. - use (hinhuniv _ t0). intros k. destruct k as [ k k' ]. intros Q j. apply j. apply ii1. apply pathsinv0. apply ( hzqrtestr p ( isaprimetoneq0 is ) a k ). split. + rewrite hzplusr0. unfold hzdiv0 in k'. rewrite k'. apply idpath. + split. * apply isreflhzleh. * rewrite hzabsvalgth0. -- apply ( istranshzlth _ 1 _ ). ++ apply hzlthnsn. ++ apply is. -- apply ( istranshzlth _ 1 _ ). ++ apply hzlthnsn. ++ apply is. - use (hinhuniv _ t1). intros k. destruct k as [ k k' ]. intros Q j. apply j. apply ii2. apply pathsinv0. apply ( hzqrtestr p ( isaprimetoneq0 is ) b k ). split. + rewrite hzplusr0. unfold hzdiv0 in k'. rewrite k'. apply idpath. + split. * apply isreflhzleh. * rewrite hzabsvalgth0. -- apply ( istranshzlth _ 1 _ ). ++ apply hzlthnsn. ++ apply is. -- apply ( istranshzlth _ 1 _ ). ++ apply hzlthnsn. ++ apply is. Defined. Definition padiczero := @ringunel1 commringofpadicints. Definition padicone := @ringunel2 commringofpadicints. Lemma padiczerocomputation : padiczero = setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( @ringunel1 ( fpscommring hz ) ). Proof. intros. apply idpath. Defined. Lemma padiconecomputation : padicone = setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( @ringunel2 ( fpscommring hz ) ). Proof. intros. apply idpath. Defined. Lemma padicintsareintdom ( a b : acommringofpadicints ) : a # 0 -> b # 0 -> a * b # 0. Proof. assert ( forall a b : commringofpadicints, isaprop ( pr1 padicapart a padiczero -> pr1 padicapart b padiczero -> pr1 padicapart ( padictimes a b ) padiczero ) ) as int. { intros. apply impred. intros. apply impred. intros. apply ( pr1 padicapart ). } revert a b. apply ( setquotuniv2prop _ ( fun x y => make_hProp _ ( int x y ) ) ). intros a b. change (pr1 padicapart (setquotpr (carryequiv p (isaprimetoneq0 is)) a) padiczero -> pr1 padicapart (setquotpr (carryequiv p (isaprimetoneq0 is)) b) padiczero -> pr1 padicapart (padictimes (setquotpr (carryequiv p (isaprimetoneq0 is)) a) (setquotpr (carryequiv p (isaprimetoneq0 is)) b)) padiczero). unfold padictimes. rewrite padiczerocomputation. rewrite setquotprandpadictimes. rewrite 3! padicapartcomputation. intros i j. use (hinhuniv _ i). intros i0. destruct i0 as [ i0 i1 ]. use (hinhuniv _ j). intros j0. destruct j0 as [ j0 j1 ]. rewrite carryandzero in i1, j1. change ( ( @ringunel1 ( fpscommring hz ) ) i0 ) with 0%hz in i1. change ( ( @ringunel1 ( fpscommring hz ) ) j0 ) with 0%hz in j1. set ( P := fun x : nat => neq hz ( carry p ( isaprimetoneq0 is ) a x ) 0 ). set ( P' := fun x : nat => neq hz ( carry p ( isaprimetoneq0 is ) b x ) 0 ). assert ( isdecnatprop P ) as isdec1. { intros m. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a m ) 0%hz ) as [ l | r ]. - apply ii2. intro v. unfold P in v. unfold neq in v. apply v. assumption. - apply ii1. assumption. } assert ( isdecnatprop P' ) as isdec2. { intros m. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b m ) 0%hz ) as [ l | r ]. - apply ii2. intro v. unfold P' in v. unfold neq in v. apply v. assumption. - apply ii1. assumption. } set ( le1 := leastelementprinciple i0 P isdec1 i1 ). set ( le2 := leastelementprinciple j0 P' isdec2 j1 ). use (hinhuniv _ le1). intro k. destruct k as [ k k' ]. use (hinhuniv _ le2). intro o. destruct o as [ o o' ]. apply total2tohexists. split with ( k + o )%nat. assert ( forall m : nat, natlth m k -> carry p ( isaprimetoneq0 is ) a m = 0%hz ) as one. { intros m m0. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a m ) 0%hz ) as [ left0 | right0 ]. - assumption. - apply fromempty. apply ( ( pr2 k' ) m m0 ). assumption. } assert ( forall m : nat, natlth m o -> carry p ( isaprimetoneq0 is ) b m = 0%hz ) as two. { intros m m0. destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b m ) 0%hz ) as [ left0 | right0 ]. - assumption. - apply fromempty. apply ( ( pr2 o' ) m m0 ). assumption. } assert ( neq hz ( carry p ( isaprimetoneq0 is ) a k ) 0%hz × forall m : nat, natlth m k -> ( carry p ( isaprimetoneq0 is ) a m ) = 0%hz ) as three. { split. - apply k'. - assumption. } assert ( neq hz ( carry p ( isaprimetoneq0 is ) b o ) 0%hz × forall m : nat, natlth m o -> ( carry p ( isaprimetoneq0 is ) b m ) = 0%hz ) as four. { split. - apply o'. - assumption. } set ( f := hzfpstimesnonzero ( carry p ( isaprimetoneq0 is ) a ) k three o ( carry p ( isaprimetoneq0 is ) b ) four ). rewrite carryandzero. change ( ( @ringunel1 ( fpscommring hz ) ) ( k + o )%nat ) with 0%hz. rewrite carryandtimes. destruct k. - destruct o. + rewrite <- carryandtimes. intros v. change ( hzremaindermod p ( isaprimetoneq0 is ) ( a 0%nat * b 0%nat ) = 0%hz ) in v. assert hfalse. { use (hinhuniv _ ( hzremaindermodprimeandtimes ( a 0%nat ) ( b 0%nat ) v )). intros t. destruct t as [ t0 | t1 ]. * unfold P in k'. unfold neq in k'. apply ( pr1 k' ). apply t0. * unfold P' in o'. unfold neq in o'. apply ( pr1 o' ). apply t1. } assumption. + intros v. unfold carry at 1 in v. change ( 0 + S o )%nat with ( S o ) in v. change ( hzremaindermod p ( isaprimetoneq0 is ) ( ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) ( S o ) + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) o ) ) = 0%hz ) in v. change ( 0 + S o )%nat with ( S o) in f. rewrite f in v. change ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) with ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) in v. rewrite ( precarryandzeromult a b 0%nat ( S o ) ) in v. * rewrite hzqrand0q in v. rewrite hzplusr0 in v. assert hfalse. { set (aux := hzremaindermodprimeandtimes ( carry p ( isaprimetoneq0 is ) a 0%nat ) ( carry p ( isaprimetoneq0 is ) b ( S o ) ) v). use (hinhuniv _ aux). intros s. destruct s as [ l | r ]. -- unfold P in k'. unfold neq in k'. apply k'. rewrite hzqrandcarryr. assumption. -- unfold P' in o'. unfold neq in o'. apply o'. rewrite hzqrandcarryr. assumption. } assumption. * apply one. * apply two. * apply natlthnsn. - intros v. unfold carry at 1 in v. change ( hzremaindermod p ( isaprimetoneq0 is ) ( ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) ( S k + o )%nat + hzquotientmod p ( isaprimetoneq0 is ) ( precarry p ( isaprimetoneq0 is ) ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) ( k + o )%nat ) ) = 0%hz ) in v. rewrite f in v. change ( carry p ( isaprimetoneq0 is ) a * carry p ( isaprimetoneq0 is ) b ) with ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a ) ( carry p ( isaprimetoneq0 is ) b ) ) in v. rewrite ( precarryandzeromult a b ( S k ) o ) in v. + rewrite hzqrand0q in v. rewrite hzplusr0 in v. assert hfalse. { set (aux := hzremaindermodprimeandtimes ( carry p ( isaprimetoneq0 is ) a ( S k ) ) ( carry p ( isaprimetoneq0 is ) b (o ) ) v). use (hinhuniv _ aux). intros s. destruct s as [ l | r ]. * unfold P in k'. unfold neq in k'. apply k'. rewrite hzqrandcarryr. assumption. * unfold P' in o'. unfold neq in o'. apply o'. rewrite hzqrandcarryr. assumption. } assumption. + apply one. + apply two. + apply natlthnsn. Defined. Definition padicintegers : aintdom. Proof. intros. split with acommringofpadicints. split. - change ( pr1 padicapart padicone padiczero ). rewrite padiczerocomputation. rewrite padiconecomputation. rewrite padicapartcomputation. apply total2tohexists. split with 0%nat. unfold carry. unfold precarry. rewrite hzqrand1r. rewrite hzqrand0r. apply isnonzerorighz. - apply padicintsareintdom. Defined. Definition padics : afld := afldfrac padicintegers. End A. Close Scope ring_scope. (** END OF FILE*) UniMath-20231010/UniMath/PAdics/z_mod_p.v000066400000000000000000002231261451125700300176430ustar00rootroot00000000000000(** *Integers mod p *) (** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *) (** December 2011 *) (** made compatible with the current UniMath library by Ralph Matthes in October 2017 *) (** Imports *) Require Import UniMath.PAdics.lemmas. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.Foundations.Preamble. Unset Kernel Term Sharing. (** for quicker proof-checking, approx. by factor 10 *) Local Open Scope hz_scope. (** * I. Divisibility and the division algorithm *) Definition hzdiv0 : hz -> hz -> hz -> UU := fun n m k => n * k = m. Definition hzdiv : hrel hz := fun n m => ∃ k : hz, hzdiv0 n m k. Lemma hzdivisrefl : isrefl hzdiv. Proof. red. intro. unfold hzdiv. apply total2tohexists. split with 1. apply hzmultr1. Defined. Lemma hzdivistrans : istrans hzdiv. Proof. intros a b c p q. use (hinhuniv _ p). intro k. destruct k as [ k f ]. use (hinhuniv _ q). intro l. destruct l as [ l g ]. intros P s. apply s. unfold hzdiv0 in f, g. split with ( k * l ). red. rewrite <- hzmultassoc. rewrite f. assumption. Defined. Lemma hzdivlinearcombleft ( a b c d : hz ) ( f : a = b + c ) ( x : hzdiv d a ) ( y : hzdiv d b ) : hzdiv d c. Proof. intros P s. use (hinhuniv _ x). intro x'. use (hinhuniv _ y). intro y'. apply s. destruct x' as [ k g ]. destruct y' as [ l h ]. unfold hzdiv0 in *. split with ( k + - l ). rewrite hzldistr. rewrite g. rewrite ( ringrmultminus hz ). change ( ( a + ( - ( d * l ) ) )%hz = c ). rewrite h. apply ( hzplusrcan _ _ b ). rewrite hzplusassoc. rewrite hzlminus. rewrite hzplusr0. rewrite hzpluscomm. assumption. Defined. Lemma hzdivlinearcombright ( a b c d : hz ) ( f : a = b + c ) ( x: hzdiv d b ) ( y : hzdiv d c ) : hzdiv d a. Proof. intros P s. use (hinhuniv _ x). intro x'. use (hinhuniv _ y). intro y'. apply s. destruct x' as [ k g ]. destruct y' as [ l h ]. unfold hzdiv0 in *. split with ( k + l ). rewrite hzldistr. change ( (d * k + d * l)%hz = a ). rewrite g, h, f. apply idpath. Defined. Lemma divalgorithmnonneg ( n : nat ) ( m : nat ) ( p : hzlth 0 ( nattohz m ) ) : ∑ qr : hz × hz, nattohz n = ( ( nattohz m ) * ( pr1 qr ) ) + ( pr2 qr ) × ( hzleh 0 ( pr2 qr ) × hzlth ( pr2 qr ) ( nattohz m ) ). Proof. revert p. induction n. - intros. split with ( make_dirprod 0 0 ). split. + simpl. rewrite ( ringrunax1 hz ). rewrite ( ringmultx0 hz ). rewrite nattohzand0. change ( 0 = 0%hz ). apply idpath. + split. * apply isreflhzleh. * assumption. - intro p. set ( q' := pr1 ( pr1 ( IHn p ) ) ). set ( r' := pr2 ( pr1 ( IHn p ) ) ). set ( f := pr1 ( pr2 ( IHn p ) ) ). assert ( hzleh ( r' + 1 ) ( nattohz m ) ) as p'. { assert ( hzlth ( r' + 1 ) ( nattohz m + 1 ) ) as p''. { apply hzlthandplusr. apply ( pr2 ( pr2 ( pr2 ( IHn p ) ) ) ). } apply hzlthsntoleh. assumption. } set ( choice := hzlehchoice ( r' + 1 ) ( nattohz m ) p' ). destruct choice as [ k | h ]. + split with ( make_dirprod q' ( r' + 1 ) ). split. * rewrite (nattohzandS _ ). rewrite hzpluscomm. rewrite f. change ( nattohz m * q' + r' + 1 = nattohz m * q' + ( r' + 1 ) ). apply ringassoc1. * split. -- apply ( istranshzleh 0 r' ( r' + 1 ) ). ++ apply ( pr2 ( pr2 ( IHn p ) ) ). ++ apply hzlthtoleh. apply hzlthnsn. -- assumption. + split with ( make_dirprod ( q' + 1 ) 0 ). split. * rewrite ( nattohzandS _ ). rewrite hzpluscomm. rewrite f. change ( nattohz m * q' + r' + 1 = nattohz m * ( q' + 1 ) + 0 ). rewrite hzplusassoc. rewrite h. rewrite ( ringldistr _ q' _ ). rewrite ringrunax2. rewrite hzplusr0. apply idpath. * split. -- apply isreflhzleh. -- assumption. Defined. (* A test of the division algorithm for non-negative integers: *) Local Lemma testlemma1 : hzneq 0 1. Proof. change 0 with ( nattohz 0%nat ). rewrite <- nattohzand1. apply nattohzandneq. intro f. apply ( isirreflnatlth 1 ). assert ( natlth 0 1 ) as i by apply natlthnsn. rewrite <- f in *. assumption. Defined. Local Lemma testlemma2 : hzneq 0 ( 1 + 1 ). Proof. change 0 with ( nattohz 0%nat ). rewrite <- nattohzand1. rewrite <- nattohzandplus. apply nattohzandneq. assert ( natneq ( 1 + 1 ) 0 ) as x. { apply ( natgthtoneq ( 1 + 1 ) 0 ). simpl. apply idpath. } intro f. apply pathsinv0 in f. simpl in f. assert (natneq ( 1 + 1 ) 2 ) as y. { rewrite f. assumption. } simpl in y. assumption. Defined. Local Lemma testlemma21 : hzlth 0 ( nattohz 2 ). Proof. change 0 with ( nattohz 0%nat ). apply nattohzandlth. apply ( istransnatlth _ 1 ). - apply natlthnsn. - apply natlthnsn. Defined. Local Lemma testlemma3 : hzlth 0 ( nattohz 3 ). Proof. apply ( istranshzlth _ ( nattohz 2 ) ). - apply testlemma21. - change 0 with ( nattohz 0%nat ). apply nattohzandlth. apply natlthnsn. Defined. Lemma testlemma9 : hzlth 0 ( nattohz 9 ). Proof. apply ( istranshzlth _ ( nattohz 3 ) ). - apply testlemma3. - apply ( istranshzlth _ ( nattohz 6 ) ). + apply testlemma3. + apply testlemma3. Defined. (* Eval lazy in hzabsval ( pr1 ( pr1 ( divalgorithmnonneg 1 ( 1 + 1 ) testlemma21 ) ) ). Eval lazy in hzabsval ( pr1 ( pr1 ( divalgorithmnonneg ( 5 ) ( 1 + 1 ) testlemma21 ) ) ). Eval lazy in hzabsval ( pr2 ( pr1 ( divalgorithmnonneg ( 5 ) ( 1 + 1 ) testlemma21 ) ) ). Eval lazy in hzabsval ( pr1 ( pr1 ( divalgorithmnonneg 16 3 testlemma3 ) ) ). Eval lazy in hzabsval ( pr2 ( pr1 ( divalgorithmnonneg 16 3 testlemma3 ) ) ). Eval lazy in hzabsval ( pr1 ( pr1 ( divalgorithmnonneg 18 9 testlemma9 ) ) ). Eval lazy in hzabsval ( pr2 ( pr1 ( divalgorithmnonneg 18 9 testlemma9 ) ) ). *) Theorem divalgorithmexists ( n m : hz ) ( p : hzneq 0 m ) : ∑ qr : hz × hz, n = m * ( pr1 qr ) + pr2 qr × ( hzleh 0 ( pr2 qr ) × hzlth ( pr2 qr ) ( nattohz ( hzabsval m ) ) ). Proof. intros. destruct ( hzlthorgeh n 0 ) as [ n_neg | n_nonneg ]. - destruct ( hzlthorgeh m 0 ) as [ m_neg | m_nonneg ]. + (*Case I: n<0, m<0:*) set ( n' := hzabsval n ). set ( m' := hzabsval m ). assert ( nattohz m' = ( - m ) ) as f. { apply hzabsvallth0. assumption. } assert ( - - n = - ( nattohz n' ) ) as f0. { rewrite <- ( hzabsvallth0 n_neg ). rewrite ( hzabsvallth0 n_neg ). unfold n'. rewrite ( hzabsvallth0 n_neg ). apply idpath. } assert ( hzlth 0 ( nattohz m' ) ) as p'. { assert ( hzlth 0 ( - m ) ) as q. { apply hzlth0andminus. assumption. } rewrite f. assumption. } set ( a := divalgorithmnonneg n' m' p' ). set ( q := pr1 ( pr1 a ) ). set ( r := pr2 ( pr1 a ) ). set ( Q := q + 1 ). set ( R := - m - r ). destruct ( hzlehchoice 0 r ( pr1 ( pr2 ( pr2 a ) ) )) as [ less | equal ]. * split with ( make_dirprod Q R ). split. -- rewrite ( pathsinv0( ringminusminus hz n) ). assert ( - nattohz n' = ( m * Q + R ) ) as f1. { unfold Q. unfold R. rewrite ( pr1 ( ( pr2 a ) ) ). change ( pr1 ( pr1 a ) ) with q. change ( pr2 ( pr1 a ) ) with r. rewrite hzaddinvplus. rewrite <- ( ringlmultminus hz ). rewrite f. rewrite ringminusminus. rewrite ( ringldistr _ q _ _ ). rewrite hzmultr1. change ( ( m * q ) + - r = ( m * q + m ) + ( - m + - r ) ). rewrite hzplusassoc. rewrite <- ( hzplusassoc m _ _ ). change ( m + - m ) with ( m - m ). rewrite hzrminus. rewrite hzplusl0. apply idpath. } exact ( pathscomp0 f0 f1 ). -- split. ++ unfold R. assert ( hzlth r ( - m ) ) as u. { rewrite <- hzabsvalleh0. ** apply ( pr2 ( pr2 ( pr2 ( a ) ) ) ). ** apply hzlthtoleh. assumption. } rewrite <- ( hzlminus m ). change ( pr2 ( make_dirprod Q ( - m - r ) ) ) with ( - m - r ). apply hzlehandplusl. apply hzlthtoleh. rewrite <- ( ringminusminus hz m ). apply hzlthminusswap. assumption. ++ unfold R. unfold m'. rewrite hzabsvalleh0. ** change ( hzlth ( - m + - r ) ( - m ) ). assert ( hzlth ( - m - r ) ( - m + 0 ) ) as u. { apply hzlthandplusl. apply hzgth0andminus. exact less. } assert ( - m + 0 = ( - m ) ) as f' by apply hzplusr0. exact ( transportf ( fun x => hzlth ( - m + - r ) x ) f' u ). ** apply hzlthtoleh. assumption. * split with (make_dirprod q 0 ). split. -- rewrite <- ( ringminusminus hz n ). assert ( - nattohz n' = m * q + 0 ) as f1. { rewrite ( pr1 ( pr2 a ) ). change ( pr1 (pr1 a ) ) with q. change ( pr2 ( pr1 a ) ) with r. rewrite hzplusr0. rewrite ( pathsinv0 equal ). rewrite hzplusr0. assert ( - ( nattohz m' * q ) = - ( nattohz m' ) * q ) as f2. { apply pathsinv0. apply ringlmultminus. } rewrite f2. unfold m'. rewrite hzabsvalleh0. ++ apply ( maponpaths ( fun x => x * q ) ). apply ringminusminus. ++ apply hzlthtoleh. assumption. } exact ( pathscomp0 f0 f1 ). -- split. ++ change ( pr2 ( make_dirprod q 0 ) ) with 0. apply isreflhzleh. ++ rewrite equal. change ( pr2 ( make_dirprod q r ) ) with r. apply ( pr2 ( pr2 ( pr2 a ) ) ). + destruct ( hzgehchoice m 0 m_nonneg ) as [ h | k ]. * (*====*) (*Case II: n<0, m>0. *) assert ( hzlth 0 ( nattohz ( hzabsval m ) ) ) as p'. { rewrite hzabsvalgth0. -- apply h. -- assumption. } set ( a := divalgorithmnonneg ( hzabsval n ) ( hzabsval m ) p' ). set ( q' := pr1 ( pr1 a ) ). set ( r' := pr2 ( pr1 a ) ). assert ( n = - - n ) as f0. { apply pathsinv0. apply ringminusminus. } assert ( - - n = - ( nattohz ( hzabsval n ) ) ) as f1. { apply pathsinv0. apply maponpaths. apply hzabsvalleh0. apply hzlthtoleh. assumption. } destruct ( hzlehchoice 0 r' ( pr1 ( pr2 ( pr2 a ) ) ) ) as [ less | equal ]. -- split with (make_dirprod ( - q' - 1 ) ( m - r' ) ). split. ++ change ( pr1 ( make_dirprod ( - q' - 1 ) ( m - r' ) ) ) with ( - q' - 1 ). change ( pr2 ( make_dirprod ( - q' - 1 ) ( m - r' ) ) ) with ( m - r' ). change ( - q' - 1 ) with ( - q' + ( - 1%hz ) ). rewrite hzldistr. assert ( - nattohz ( hzabsval n ) = ( m * ( - q' ) + m * ( - 1%hz ) ) + ( m - r' ) ) as f2. { rewrite ( pr1 ( pr2 a ) ). change ( pr1 ( pr1 a ) ) with q'. change ( pr2 ( pr1 a ) ) with r'. rewrite hzabsvalgth0. ** rewrite hzaddinvplus. rewrite ( ringrmultminus hz ). rewrite ( hzplusassoc _ ( m * ( - 1%hz ) ) ). apply ( maponpaths ( fun x => - ( m * q' ) + x ) ). assert ( - m + ( m - r' ) = m * ( - 1%hz ) + ( m - r' ) ) as f3. { apply ( maponpaths ( fun x => x + ( m - r' ) ) ). apply pathsinv0. assert ( m * ( - 1%hz ) = - ( m * 1%hz ) ) as f30 by apply ringrmultminus. assert ( - ( m * 1 ) = - m ) as f31. { rewrite hzmultr1. apply idpath. } rewrite f30. assumption. } assert ( - r' = - m + ( m - r' ) ) as f4. { change ( - r' = -m + ( m + - r' ) ). rewrite <- hzplusassoc. rewrite hzlminus, hzplusl0. apply idpath. } rewrite f4. assumption. ** assumption. } rewrite f0, f1. assumption. ++ split. ** change ( pr2 ( make_dirprod ( - q' - 1 ) ( m - r' ) ) ) with ( m - r' ). apply hzlthtoleh. rewrite <- ( hzrminus r' ). apply hzlthandplusr. rewrite <- ( hzabsvalgeh0 m_nonneg ). apply ( pr2 ( pr2 a ) ). ** rewrite ( hzabsvalgeh0 m_nonneg ). assert ( hzlth ( m - r' ) ( m + 0 ) ) as u. { apply hzlthandplusl. apply hzgth0andminus. apply less. } rewrite hzplusr0 in u. assumption. -- split with ( make_dirprod ( - q' ) 0 ). split. ++ change ( pr1 ( make_dirprod ( - q' ) 0 ) ) with ( - q' ). change ( pr2 ( make_dirprod ( - q' ) 0 ) ) with 0. assert ( - nattohz ( hzabsval n ) = m * - q' + 0 ) as f2. { rewrite hzplusr0. rewrite ( pr1 ( pr2 a ) ). change ( pr1 ( pr1 a ) ) with q'. change ( pr2 ( pr1 a ) ) with r'. rewrite <- equal. rewrite hzplusr0. rewrite hzabsvalgeh0. ** apply pathsinv0. apply ringrmultminus. ** assumption. } rewrite f0, f1. assumption. ++ split. ** apply isreflhzleh. ** rewrite equal. apply ( pr2 ( pr2 ( pr2 a ) ) ). * apply fromempty. rewrite k in p. simpl in p. apply p. apply idpath. - set ( choice2 := hzlthorgeh m 0 ). destruct choice2 as [ m_neg | m_nonneg ]. + (*Case III. Assume n>=0, m<0:*) assert ( hzlth 0 ( nattohz ( hzabsval m ) ) ) as p'. { rewrite hzabsvallth0. * rewrite <- ( ringminusminus hz m ) in m_neg. set ( d:= hzlth0andminus m_neg ). rewrite ringminusminus in d. apply d. * assumption. } set ( a := divalgorithmnonneg ( hzabsval n ) ( hzabsval m ) p' ). set ( q' := pr1 ( pr1 a ) ). set ( r' := pr2 ( pr1 a ) ). split with ( make_dirprod ( - q' ) r' ). split. * rewrite <- hzabsvalgeh0. -- rewrite ( pr1 ( pr2 a ) ). change ( pr1 ( pr1 a ) ) with q'. change ( pr2 ( pr1 a ) ) with r'. change ( pr1 ( make_dirprod ( - q' ) r' ) ) with ( - q' ). change ( pr2 ( make_dirprod ( - q' ) r' ) ) with r'. rewrite hzabsvalleh0. ++ apply ( maponpaths ( fun x => x + r' ) ). assert ( - m * q' = - ( m * q' ) ) as f0 by apply ringlmultminus. assert ( - ( m * q' ) = m * ( - q' ) ) as f1. { apply pathsinv0. apply ringrmultminus. } exact ( pathscomp0 f0 f1 ). ++ apply hzlthtoleh. assumption. -- assumption. * split. -- apply (pr1 ( pr2 ( pr2 a ) ) ). -- apply ( pr2 ( pr2 ( pr2 a ) ) ). + (*Case IV: n>=0, m>0.*) assert ( hzlth 0 ( nattohz ( hzabsval m ) ) ) as p'. { rewrite hzabsvalgeh0. * destruct ( hzneqchoice 0 m ) as [ l | r ]. -- apply p. -- apply fromempty. apply ( isirreflhzgth 0 ). apply ( hzgthgehtrans 0 m 0 ); assumption. -- assumption. * assumption. } set ( a := divalgorithmnonneg ( hzabsval n ) ( hzabsval m ) p' ). set ( q' := pr1 ( pr1 a ) ). set ( r' := pr2 ( pr1 a ) ). split with ( make_dirprod q' r' ). split. -- rewrite <- hzabsvalgeh0. ++ rewrite ( pr1 ( pr2 a ) ). change ( pr1 ( pr1 a ) ) with q'. change ( pr2 ( pr1 a ) ) with r'. change ( pr1 ( make_dirprod q' r' ) ) with q'. change ( pr2 ( make_dirprod q' r' ) ) with r'. rewrite hzabsvalgeh0. ** apply idpath. ** assumption. ++ assumption. -- split. ++ apply ( pr1 ( pr2 ( pr2 a ) ) ). ++ apply ( pr2 ( pr2 ( pr2 a ) ) ). Defined. Lemma hzdivhzabsval ( a b : hz ) ( p : hzdiv a b ) : natleh ( hzabsval a ) ( hzabsval b ) ∨ hzabsval b = 0%nat. Proof. intros P q. apply ( p P ). intro t. destruct t as [ k f ]. unfold hzdiv0 in f. apply q. apply natdivleh with ( hzabsval k ). rewrite hzabsvalandmult. rewrite f. apply idpath. Defined. Lemma divalgorithm ( n m : hz ) ( p : hzneq 0 m ) : iscontr ( ∑ qr : hz × hz, n = ( m * ( pr1 qr ) ) + ( pr2 qr ) × ( hzleh 0 ( pr2 qr ) × hzlth ( pr2 qr ) ( nattohz ( hzabsval m ) ) ) ). Proof. intros. split with ( divalgorithmexists n m p ). intro t. destruct t as [ qr' t' ]. destruct qr' as [ q' r' ]. simpl in t'. destruct t' as [ f' p2p2t ]. destruct p2p2t as [ p1p2p2t p2p2p2t ]. destruct divalgorithmexists as [ qr v ]. destruct qr as [ q r ]. destruct v as [ f p2p2dae ]. destruct p2p2dae as [ p1p2p2dae p2p2p2dae ]. simpl in f. simpl in p1p2p2dae. simpl in p2p2p2dae. assert ( r' = r ) as h. { (* Proof that r' = r : *) assert ( m * ( q - q' ) = ( r' - r ) ) as h0. { change ( q - q' ) with ( q + - q' ). rewrite hzldistr. rewrite <- ( hzplusr0 ( r' - r ) ). rewrite <- ( hzrminus ( m * q' ) ). change ( r' - r ) with ( r' + ( - r ) ). rewrite ( hzplusassoc r' ). change ( ( m * q' ) - ( m * q' ) ) with ( ( m * q' ) + ( - ( m * q' ) ) ). rewrite <- ( hzplusassoc ( - r ) ). rewrite ( hzpluscomm ( -r ) ). rewrite <- ( hzplusassoc r' ). rewrite <- ( hzplusassoc r' ). rewrite ( hzpluscomm r' ). rewrite <- f'. rewrite f. rewrite ( hzplusassoc ( m * q ) ). change ( r + - r ) with ( r - r ). rewrite hzrminus. rewrite hzplusr0. rewrite ( ringrmultminus hz ). change ( m * q + - ( m * q' ) ) with ( ( m * q + - ( m * q' ) )%ring ). apply idpath. } assert ( natleh ( hzabsval m ) ( hzabsval ( r' - r ) ) ∨ hzabsval ( r' - r ) = 0%nat ) as v. { apply hzdivhzabsval. intro P. intro s. apply s. split with ( q - q' ). unfold hzdiv0. assumption. } assert ( isaprop ( r' = r ) ) as P by apply isasethz. apply ( v ( make_hProp ( r' = r ) P ) ). intro s. destruct s as [ left | right ]. - assert ( hzlth ( nattohz ( hzabsval ( r' - r ) ) ) ( nattohz ( hzabsval m ) ) ) as u. { destruct ( hzgthorleh r' r ) as [ greater | lesseq ]. + assert ( hzlth 0 ( r' - r ) ) as e. { rewrite <- ( hzrminus r ). apply hzlthandplusr. assumption. } rewrite hzabsvalgth0. * apply hzlthminus. -- exact p2p2p2t. -- exact p2p2p2dae. -- exact p1p2p2dae. * apply e. + destruct ( hzlehchoice r' r lesseq ) as [ less | equal ]. * rewrite hzabsvalandminuspos. -- rewrite hzabsvalgth0. ++ apply hzlthminus. ** exact p2p2p2dae. ** exact p2p2p2t. ** exact p1p2p2t. ++ apply hzlthminusequiv. assumption. -- exact p1p2p2t. -- exact p1p2p2dae. * rewrite equal. rewrite hzrminus. rewrite hzabsval0. rewrite nattohzand0. assert (hzabsval m ≠ 0). { apply hzabsvalneq0. intro Q. rewrite Q in p. simpl in p. apply p. apply idpath. } apply lemmas.hzabsvalneq0. (* the culprit is the prefix [lemmas] *) assumption. } apply fromempty. apply ( isirreflhzlth ( nattohz ( hzabsval m ) ) ). apply ( hzlehlthtrans _ ( nattohz ( hzabsval ( r' - r ) ) ) _ ). + apply nattohzandleh. assumption. + assumption. - assert ( r' = r ) as i. { assert ( r' - r = 0 ) as i0. { apply hzabsvaleq0. assumption. } rewrite <- ( hzplusl0 r ). rewrite <- ( hzplusr0 r' ). assert ( r' + ( r - r ) = ( 0 + r ) ) as i00. { change ( r - r ) with ( r + - r ). rewrite ( hzpluscomm _ ( - r ) ). rewrite <- hzplusassoc. apply ( maponpaths ( fun x : _ => x + r ) ). apply i0. } exact ( transportf ( fun x : _ => ( r' + x = ( 0 + r ) ) ) ( ( hzrminus r ) ) i00 ). } apply i. } assert ( q' = q ) as g. { (* Proof that q' = q:*) rewrite h in f'. rewrite f in f'. apply ( hzmultlcan q' q m ). - intro i. rewrite i in p. simpl in p. apply p. apply idpath. - apply ( hzplusrcan ( m * q' ) ( m * q ) r ). apply pathsinv0. apply f'. } (* Path in direct product: *) assert ( make_dirprod q' r' = ( make_dirprod q r ) ) as j by (apply pathsdirprod; assumption). (* Proof of general path: *) apply ( total2_paths2_f j ). assert ( iscontr ( n = m * q + r × ( hzleh 0 r × hzlth r ( nattohz ( hzabsval m ) ) ) ) ) as contract. { change iscontr with ( isofhlevel 0 ). apply isofhleveldirprod. - split with f. intro t. apply isasethz. - apply isofhleveldirprod. + split with p1p2p2dae. intro t. apply hzleh. + split with p2p2p2dae. intro t. apply hzlth. } apply proofirrelevancecontr. assumption. Defined. Definition hzquotientmod ( p : hz ) ( x : hzneq 0 p ) : hz -> hz := fun n : hz => pr1 ( pr1 ( divalgorithmexists n p x ) ). Definition hzremaindermod ( p : hz ) ( x : hzneq 0 p ) : hz -> hz := fun n : hz => pr2 ( pr1 ( divalgorithmexists n p x ) ). Definition hzdivequationmod ( p : hz ) ( x : hzneq 0 p ) ( n : hz ) : n = p * ( hzquotientmod p x n ) + ( hzremaindermod p x n ) := pr1 ( pr2 ( divalgorithmexists n p x ) ). Definition hzleh0remaindermod ( p : hz ) ( x : hzneq 0 p ) ( n : hz ) : hzleh 0 ( hzremaindermod p x n ) := pr1 ( pr2 ( pr2 ( divalgorithmexists n p x ) ) ). Definition hzlthremaindermodmod ( p : hz ) ( x : hzneq 0 p ) ( n : hz ) : hzlth ( hzremaindermod p x n ) ( nattohz ( hzabsval p ) ) := pr2 ( pr2 ( pr2 ( divalgorithmexists n p x ) ) ). (* Eval lazy in hzabsval ( ( ( hzquotientmod ( 1 + 1 ) testlemma2 ( 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 ) ) ) ). Eval lazy in hzabsval ( ( ( hzremaindermod ( 1 + 1 ) testlemma2 ( 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 ) ) ) ). *) (** * II. QUOTIENTS AND REMAINDERS *) Definition isaprime ( p : hz ) : UU := hzlth 1 p × forall m : hz, hzdiv m p -> m = 1 ∨ m = p. Lemma isapropisaprime ( p : hz ) : isaprop ( isaprime p ). Proof. intros. apply isofhleveldirprod. - apply ( hzlth 1 p ). - apply impred. intro m. apply impredfun. apply ( m = 1 ∨ m = p ). Defined. Lemma isaprimetoneq0 { p : hz } ( x : isaprime p ) : hzneq 0 p. Proof. intros. intros f. apply ( isirreflhzlth 0 ). apply ( istranshzlth _ 1 _ ). - apply hzlthnsn. - rewrite f. apply ( pr1 x ). Defined. Lemma hzqrtest ( m : hz ) ( x : hzneq 0 m ) ( a q r : hz ) : a = ( m * q ) + r × ( hzleh 0 r × hzlth r ( nattohz (hzabsval m ) ) ) -> q = hzquotientmod m x a × r = hzremaindermod m x a. Proof. intros d. set ( k := tpair ( P := ( fun qr : hz × hz => a = m * ( pr1 qr ) + pr2 qr × ( hzleh 0 ( pr2 qr ) × hzlth ( pr2 qr ) ( nattohz ( hzabsval m ) ) ) ) ) ( make_dirprod q r ) d ). assert ( k = pr1 ( divalgorithm a m x ) ) as f by apply ( pr2 ( divalgorithm a m x ) ). split. - change q with ( pr1 ( pr1 k ) ). rewrite f. apply idpath. - change r with ( pr2 ( pr1 k ) ). rewrite f. apply idpath. Defined. Definition hzqrtestq ( m : hz ) ( x : hzneq 0 m ) ( a q r : hz ) ( d : a = ( m * q ) + r × ( hzleh 0 r × hzlth r ( nattohz ( hzabsval m ) ) ) ) := pr1 ( hzqrtest m x a q r d ). Definition hzqrtestr ( m : hz ) ( x : hzneq 0 m ) ( a q r : hz ) ( d : a = ( m * q ) + r × ( hzleh 0 r × hzlth r ( nattohz ( hzabsval m ) ) ) ) := pr2 ( hzqrtest m x a q r d ). Lemma hzqrand0eq ( p : hz ) ( x : hzneq 0 p ) : 0 = ( p * 0 ) + 0. Proof. intros. rewrite hzmultx0. rewrite hzplusl0. apply idpath. Defined. Lemma hzqrand0ineq ( p : hz ) ( x : hzneq 0 p ) : hzleh 0 0 × hzlth 0 ( nattohz ( hzabsval p ) ). Proof. intros. split. - apply isreflhzleh. - apply lemmas.hzabsvalneq0. (* [lemmas] is the culprit *) assumption. Defined. Lemma hzqrand0q ( p : hz ) ( x : hzneq 0 p ) : hzquotientmod p x 0 = 0. Proof. intros. apply pathsinv0. apply ( hzqrtestq p x 0 0 0 ). split. - apply ( hzqrand0eq p x ). - apply ( hzqrand0ineq p x ). Defined. Lemma hzqrand0r ( p : hz ) ( x : hzneq 0 p ) : hzremaindermod p x 0 = 0. Proof. intros. apply pathsinv0. apply ( hzqrtestr p x 0 0 0 ). split. - apply ( hzqrand0eq p x ). - apply ( hzqrand0ineq p x ). Defined. Lemma hzqrand1eq ( p : hz ) ( is : isaprime p ) : 1 = ( ( p * 0 ) + 1 ). Proof. intros. rewrite hzmultx0. rewrite hzplusl0. apply idpath. Defined. Lemma hzqrand1ineq ( p : hz ) ( is : isaprime p ) : hzleh 0 1 × hzlth 1 ( nattohz ( hzabsval p ) ). Proof. intros. split. - apply hzlthtoleh. apply hzlthnsn. - rewrite hzabsvalgth0. + apply is. + apply ( istranshzgth _ 1 _ ). * apply is. * apply ( hzgthsnn 0 ). Defined. Lemma hzqrand1q ( p : hz ) ( is : isaprime p ) : hzquotientmod p ( isaprimetoneq0 is ) 1 = 0. Proof. intros. apply pathsinv0. apply ( hzqrtestq p ( isaprimetoneq0 is ) 1 0 1 ). split. - apply ( hzqrand1eq p is ). - apply ( hzqrand1ineq p is ). Defined. Lemma hzqrand1r ( p : hz ) ( is : isaprime p ) : hzremaindermod p ( isaprimetoneq0 is ) 1 = 1. Proof. intros. apply pathsinv0. apply ( hzqrtestr p ( isaprimetoneq0 is ) 1 0 1 ). split. - apply ( hzqrand1eq p is ). - apply ( hzqrand1ineq p is ). Defined. Lemma hzqrandselfeq ( p : hz ) ( x : hzneq 0 p ) : p = ( p * 1 + 0 ). Proof. intros. rewrite hzmultr1. rewrite hzplusr0. apply idpath. Defined. Lemma hzqrandselfineq ( p : hz ) ( x : hzneq 0 p ) : hzleh 0 0 × hzlth 0 ( nattohz ( hzabsval p ) ). Proof. split. - apply isreflhzleh. - apply lemmas.hzabsvalneq0. assumption. Defined. Lemma hzqrandselfq ( p : hz ) ( x : hzneq 0 p ) : hzquotientmod p x p = 1. Proof. intros. apply pathsinv0. apply ( hzqrtestq p x p 1 0 ). split. - apply ( hzqrandselfeq p x ). - apply ( hzqrandselfineq p x ). Defined. Lemma hzqrandselfr ( p : hz ) ( x : hzneq 0 p ) : hzremaindermod p x p = 0. Proof. intros. apply pathsinv0. apply ( hzqrtestr p x p 1 0 ). split. - apply ( hzqrandselfeq p x ). - apply ( hzqrandselfineq p x ). Defined. Lemma hzqrandpluseq ( p : hz ) ( x : hzneq 0 p ) ( a c : hz ) : ( a + c ) = ( ( p * ( hzquotientmod p x a + hzquotientmod p x c + hzquotientmod p x ( hzremaindermod p x a + hzremaindermod p x c ) ) ) + hzremaindermod p x ( ( hzremaindermod p x a ) + ( hzremaindermod p x c ) ) ). Proof. intros. rewrite 2! hzldistr. rewrite hzplusassoc. rewrite <- ( hzdivequationmod p x ( hzremaindermod p x a + hzremaindermod p x c ) ). rewrite hzplusassoc. rewrite ( hzpluscomm ( hzremaindermod p x a ) ). rewrite <- ( hzplusassoc ( p * hzquotientmod p x c ) ). rewrite <- ( hzdivequationmod p x c ). rewrite ( hzpluscomm c ). rewrite <- hzplusassoc. rewrite <- ( hzdivequationmod p x a ). apply idpath. Defined. Lemma hzqrandplusineq ( p : hz ) ( x : hzneq 0 p ) ( a c : hz ) : hzleh 0 ( hzremaindermod p x ( hzremaindermod p x a + hzremaindermod p x c ) ) × hzlth ( hzremaindermod p x ( hzremaindermod p x a + hzremaindermod p x c ) ) ( nattohz ( hzabsval p ) ). Proof. intros. split. - apply hzleh0remaindermod. - apply hzlthremaindermodmod. Defined. Lemma hzremaindermodandplus ( p : hz ) ( x : hzneq 0 p ) ( a c : hz ) : hzremaindermod p x ( a + c ) = hzremaindermod p x ( hzremaindermod p x a + hzremaindermod p x c ). Proof. intros. apply pathsinv0. apply ( hzqrtest p x ( a + c ) _ _ ( make_dirprod ( hzqrandpluseq p x a c ) ( hzqrandplusineq p x a c ) ) ). Defined. Lemma hzquotientmodandplus ( p : hz ) ( x : hzneq 0 p ) ( a c : hz ) : hzquotientmod p x ( a + c ) = ( hzquotientmod p x a + hzquotientmod p x c + hzquotientmod p x ( hzremaindermod p x a + hzremaindermod p x c ) ). Proof. intros. apply pathsinv0. apply ( hzqrtest p x ( a + c ) _ _ ( make_dirprod ( hzqrandpluseq p x a c ) ( hzqrandplusineq p x a c ) ) ). Defined. Lemma hzqrandtimeseq ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) : ( a * b ) = ( ( m * ( ( hzquotientmod m x ) a * ( hzquotientmod m x ) b * m + ( hzremaindermod m x b ) * ( hzquotientmod m x a ) + ( hzremaindermod m x a ) * ( hzquotientmod m x b ) + ( hzquotientmod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ) ) + hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ). Proof. intros. rewrite 3! hzldistr. rewrite ( hzplusassoc _ _ ( hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ). rewrite <- hzdivequationmod. rewrite ( hzmultassoc _ _ m ). rewrite <- ( hzmultassoc m _ ( hzquotientmod m x b * m ) ). rewrite ( hzmultcomm _ m ). change ( ((m * hzquotientmod m x a * (m * hzquotientmod m x b))%hz + m * (hzremaindermod m x b * hzquotientmod m x a)%hz)%ring ) with ((m * hzquotientmod m x a * (m * hzquotientmod m x b)) + m * (hzremaindermod m x b * hzquotientmod m x a) )%hz. change ( a * b = (((m * hzquotientmod m x a * (m * hzquotientmod m x b) + m * (hzremaindermod m x b * hzquotientmod m x a))%hz + m * (hzremaindermod m x a * hzquotientmod m x b)%hz)%ring + hzremaindermod m x a * hzremaindermod m x b) ) with ( a * b = (((m * hzquotientmod m x a * (m * hzquotientmod m x b) + m * (hzremaindermod m x b * hzquotientmod m x a)) + m * (hzremaindermod m x a * hzquotientmod m x b))%hz + hzremaindermod m x a * hzremaindermod m x b) ). rewrite ( hzplusassoc ( m * hzquotientmod m x a * ( m * hzquotientmod m x b ) ) _ _ ). rewrite ( hzpluscomm ( m * ( hzremaindermod m x b * hzquotientmod m x a ) ) ( m * ( hzremaindermod m x a * hzquotientmod m x b ) ) ). rewrite <- ( hzmultassoc m ( hzremaindermod m x a ) ( hzquotientmod m x b ) ). rewrite ( hzmultcomm m ( hzremaindermod m x a ) ). rewrite ( hzmultassoc ( hzremaindermod m x a ) m ( hzquotientmod m x b ) ). rewrite <- ( hzplusassoc ( m * hzquotientmod m x a * ( m * hzquotientmod m x b ) ) ( hzremaindermod m x a * ( m * hzquotientmod m x b ) ) _ ). rewrite <- hzrdistr. rewrite <- hzdivequationmod. rewrite hzplusassoc. rewrite ( hzmultcomm ( hzremaindermod m x b ) ( hzquotientmod m x a ) ). rewrite <- ( hzmultassoc m ( hzquotientmod m x a ) ( hzremaindermod m x b ) ). rewrite <- hzrdistr. rewrite <- hzdivequationmod. rewrite <- hzldistr. rewrite <- hzdivequationmod. apply idpath. Defined. Lemma hzqrandtimesineq ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) : hzleh 0 ( hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) × hzlth ( hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ( nattohz ( hzabsval m ) ). Proof. intros. split. - apply hzleh0remaindermod. - apply hzlthremaindermodmod. Defined. Lemma hzquotientmodandtimes ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) : hzquotientmod m x ( a * b ) = ( ( hzquotientmod m x ) a * ( hzquotientmod m x ) b * m + ( hzremaindermod m x b ) * ( hzquotientmod m x a ) + ( hzremaindermod m x a ) * ( hzquotientmod m x b ) + ( hzquotientmod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ). Proof. intros. apply pathsinv0. apply ( hzqrtestq m x ( a * b ) _ ( hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ). split. - apply hzqrandtimeseq. - apply hzqrandtimesineq. Defined. Lemma hzremaindermodandtimes ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) : hzremaindermod m x ( a * b ) = ( hzremaindermod m x ( hzremaindermod m x a * hzremaindermod m x b ) ). Proof. intros. apply pathsinv0. apply ( hzqrtestr m x ( a * b ) ( ( hzquotientmod m x ) a * ( hzquotientmod m x ) b * m + ( hzremaindermod m x b ) * ( hzquotientmod m x a ) + ( hzremaindermod m x a ) * ( hzquotientmod m x b ) + ( hzquotientmod m x ( hzremaindermod m x a * hzremaindermod m x b ) ) ) _ ). split. - apply hzqrandtimeseq. - apply hzqrandtimesineq. Defined. Lemma hzqrandremaindereq ( m : hz ) ( is : hzneq 0 m ) ( n : hz ) : hzremaindermod m is n = ( ( m * ( pr1 ( make_dirprod 0 ( hzremaindermod m is n ) ) ) + ( pr2 ( make_dirprod (@ringunel1 hz ) ( hzremaindermod m is n ) ) ) ) ). Proof. intros. simpl. rewrite hzmultx0. rewrite hzplusl0. apply idpath. Defined. Lemma hzqrandremainderineq ( m : hz ) ( is : hzneq 0 m ) ( n : hz ) : hzleh ( @ringunel1 hz ) ( hzremaindermod m is n ) × hzlth ( hzremaindermod m is n ) ( nattohz ( hzabsval m ) ). Proof. intros. split. - apply hzleh0remaindermod. - apply hzlthremaindermodmod. Defined. Lemma hzremaindermoditerated ( m : hz ) ( is : hzneq 0 m ) ( n : hz ) : hzremaindermod m is ( hzremaindermod m is n ) = ( hzremaindermod m is n ). Proof. intros. apply pathsinv0. apply ( hzqrtestr m is ( hzremaindermod m is n ) 0 ( hzremaindermod m is n ) ). split. - apply hzqrandremaindereq. - apply hzqrandremainderineq. Defined. Lemma hzqrandremainderq ( m : hz ) ( is : hzneq 0 m ) ( n : hz ) : 0 = hzquotientmod m is ( hzremaindermod m is n ). Proof. intros. apply ( hzqrtestq m is ( hzremaindermod m is n ) 0 ( hzremaindermod m is n ) ). split. - apply hzqrandremaindereq. - apply hzqrandremainderineq. Defined. (** * III. THE EUCLIDEAN ALGORITHM *) Definition iscommonhzdiv ( k n m : hz ) := hzdiv k n × hzdiv k m. Lemma isapropiscommonhzdiv ( k n m : hz ) : isaprop ( iscommonhzdiv k n m ). Proof. intros. unfold isaprop. apply isofhleveldirprod. - apply hzdiv. - apply hzdiv. Defined. Definition hzgcd ( n m : hz ) : UU := ∑ k : hz, iscommonhzdiv k n m × forall l : hz, iscommonhzdiv l n m -> hzleh l k. Lemma isaprophzgcd0 ( k n m : hz ) : isaprop ( iscommonhzdiv k n m × forall l : hz, iscommonhzdiv l n m -> hzleh l k ). Proof. intros. apply isofhleveldirprod. - apply isapropiscommonhzdiv. - apply impred. intro t. apply impredfun. apply hzleh. Defined. Lemma isaprophzgcd ( n m : hz ) : isaprop ( hzgcd n m ). Proof. intros. intros k l. assert ( isofhlevel 2 ( hzgcd n m ) ) as aux. { apply isofhleveltotal2. - apply isasethz. - intros x. apply hlevelntosn. apply isofhleveldirprod. + apply isapropiscommonhzdiv. + apply impred. intro t. apply impredfun. apply ( hzleh t x ). } assert ( k = l ) as f. { destruct k as [ k pq ]. destruct pq as [ p q ]. destruct l as [ l pq ]. destruct pq as [ p' q' ]. assert ( k = l ) as f0. { apply isantisymmhzleh. - apply q'. assumption. - apply q. assumption. } apply ( total2_paths2_f f0 ). assert ( isaprop ( iscommonhzdiv l n m × forall x : hz, iscommonhzdiv x n m -> hzleh x l ) ) as is. { apply isofhleveldirprod. - apply isapropiscommonhzdiv. - apply impred. intro t. apply impredfun. apply ( hzleh t l ). } apply is. } split with f. intro g. destruct k as [ k pq ]. destruct pq as [ p q ]. destruct l as [ l pq ]. destruct pq as [ p' q' ]. apply aux. Defined. (* Euclidean algorithm for calculating the GCD of two numbers (here assumed to be natural numbers ( m <= n )): gcd ( n , m ) := 1. if m = 0, then take n. 2. if m \neq 0, then divide n = q * m + r and take g := gcd ( m , r ). *) Lemma hzdivandmultl ( a c d : hz ) ( p : hzdiv d a ) : hzdiv d ( c * a ). Proof. intros. intros P s. use (hinhuniv _ p). intro k. destruct k as [ k f ]. apply s. unfold hzdiv0. split with ( c * k ). rewrite ( hzmultcomm d ). rewrite hzmultassoc. unfold hzdiv0 in f. rewrite ( hzmultcomm k ). rewrite f. apply idpath. Defined. Lemma hzdivandmultr ( a c d : hz ) ( p : hzdiv d a ) : hzdiv d ( a * c ). Proof. intros. rewrite hzmultcomm. apply hzdivandmultl. assumption. Defined. Lemma hzdivandminus ( a d : hz ) ( p : hzdiv d a ) : hzdiv d ( - a ). Proof. intros. intros P s. use (hinhuniv _ p). intro k. destruct k as [ k f ]. apply s. split with ( - k ). unfold hzdiv0. unfold hzdiv0 in f. rewrite ( ringrmultminus hz ). apply maponpaths. assumption. Defined. Definition natgcd ( m n : nat ) : ( natneq 0%nat n ) -> ( natleh m n ) -> ( hzgcd ( nattohz n ) ( nattohz m ) ). Proof. revert m n. set ( E := ( fun m : nat => forall n : nat, ( natneq 0%nat n ) -> ( natleh m n ) -> (hzgcd ( nattohz n ) ( nattohz m ) ) ) ). assert ( forall x : nat, E x ) as goal. { apply stronginduction. - (* BASE CASE: *) intros n x0 x1. split with ( nattohz n ). split. + unfold iscommonhzdiv. split. * unfold hzdiv. intros P s. apply s. unfold hzdiv0. split with 1. rewrite hzmultr1. apply idpath. * unfold hzdiv. intros P s. apply s. unfold hzdiv0. split with 0. rewrite hzmultx0. rewrite nattohzand0. apply idpath. + intros l t. destruct t as [ t0 t1 ]. destruct ( hzgthorleh l 0 ) as [ left | right ]. * rewrite <- hzabsvalgth0. -- apply nattohzandleh. unfold hzdiv in t0. use (hinhuniv _ t0). intro t2. destruct t2 as [ k t2 ]. unfold hzdiv0 in t2. assert ( natleh ( hzabsval l ) n ⨿ ( n = 0%nat ) ) as C. { apply ( natdivleh ( hzabsval l ) n ( hzabsval k ) ). apply ( invmaponpathsincl _ isinclnattohz ). rewrite nattohzandmult. rewrite 2! hzabsvalgeh0. ++ assumption. ++ assert ( hzgeh ( l * k ) ( l * 0 ) ) as i. { rewrite hzmultx0. rewrite t2. change 0 with ( nattohz 0%nat ). apply nattohzandgeh. apply x1. } apply ( hzgehandmultlinv _ _ l ); assumption. ++ apply hzgthtogeh. assumption. } destruct C as [ C0 | C1 ]. ++ assumption. ++ apply fromempty. rewrite C1 in x0. apply x0. -- assumption. * apply ( istranshzleh _ 0 _ ). { assumption. } change 0 with ( nattohz 0%nat ). apply nattohzandleh. assumption. - (* INDUCTION CASE: *) intros m p q. intros n i j. assert ( hzlth 0 ( nattohz m ) ) as p'. { change 0 with ( nattohz 0%nat ). apply nattohzandlth. apply natneq0togth0. apply p. } set ( a := divalgorithmnonneg n m p' ). destruct a as [ qr a ]. destruct qr as [ quot rem ]. destruct a as [ f a ]. destruct a as [ a b ]. simpl in b. simpl in f. assert ( natlth ( hzabsval rem ) m ) as p''. { rewrite <- ( hzabsvalandnattohz m ). apply nattohzandlthinv. rewrite 2! hzabsvalgeh0. + assumption. + apply hzgthtogeh. apply ( hzgthgehtrans _ rem ); assumption. + assumption. } assert ( natleh ( hzabsval rem ) n ) as i''. { apply natlthtoleh. apply nattohzandlthinv. rewrite hzabsvalgeh0. + apply ( hzlthlehtrans _ ( nattohz m ) _ ). * assumption. * apply nattohzandleh. assumption. + assumption. } assert ( natneq 0%nat m ) as p'''. { apply issymm_natneq. (* the culprit is using this lemma instead of direct arguments *) assumption. } destruct ( q ( hzabsval rem ) p'' m p''' ( natlthtoleh _ _ p'' ) ) as [ rr c ]. destruct c as [ c0 c1 ]. split with rr. split. + split. * apply ( hzdivlinearcombright ( nattohz n ) ( nattohz m * quot ) rem rr f ). -- apply hzdivandmultr. exact ( pr1 c0 ). -- rewrite hzabsvalgeh0 in c0. ++ exact ( pr2 c0 ). ++ assumption. * exact ( pr1 c0 ). + intros l o. apply c1. split. * exact ( pr2 o ). * rewrite hzabsvalgeh0. -- apply ( hzdivlinearcombleft ( nattohz n ) ( nattohz m * quot ) rem l f ). ++ exact ( pr1 o ). ++ apply hzdivandmultr. exact ( pr2 o ). -- assumption. } assumption. Defined. Lemma hzgcdandminusl ( m n : hz ) : hzgcd m n = hzgcd ( - m ) n. Proof. intros. assert ( make_hProp ( hzgcd m n ) ( isaprophzgcd _ _ ) = ( make_hProp ( hzgcd ( - m ) n ) ( isaprophzgcd _ _ ) ) ) as x. { apply hPropUnivalence. - intro i. destruct i as [ a i ]. destruct i as [ i0 i1 ]. destruct i0 as [ j0 j1 ]. split with a. split. + split. * use (hinhuniv _ j0). intro k. destruct k as [ k f ]. unfold hzdiv0 in f. intros P s. apply s. split with ( - k ). unfold hzdiv0. rewrite ( ringrmultminus hz ). apply maponpaths. assumption. * assumption. + intros l f. apply i1. split. * use (hinhuniv _ ( pr1 f )). intro k. destruct k as [ k g ]. unfold hzdiv0 in g. intros P s. apply s. split with ( - k ). unfold hzdiv0. rewrite ( ringrmultminus hz ). rewrite <- ( ringminusminus hz m). apply maponpaths. assumption. * exact ( pr2 f ). - intro i. destruct i as [ a i ]. destruct i as [ i0 i1 ]. destruct i0 as [ j0 j1 ]. split with a. split. + split. * use (hinhuniv _ j0). intro k. destruct k as [ k f ]. unfold hzdiv0 in f. intros P s. apply s. split with ( - k ). unfold hzdiv0. rewrite ( ringrmultminus hz ). rewrite <- ( ringminusminus hz m ). apply maponpaths. assumption. * assumption. + intros l f. apply i1. split. * use (hinhuniv _ ( pr1 f )). intro k. destruct k as [ k g ]. unfold hzdiv0 in g. intros P s. apply s. split with ( - k ). unfold hzdiv0. rewrite (ringrmultminus hz ). apply maponpaths. assumption. * exact ( pr2 f ). } apply ( base_paths _ _ x ). Defined. Lemma hzgcdsymm ( m n : hz ) : hzgcd m n = hzgcd n m. Proof. intros. assert ( make_hProp ( hzgcd m n ) ( isaprophzgcd _ _ ) = ( make_hProp ( hzgcd n m ) ( isaprophzgcd _ _ ) ) ) as x. { apply hPropUnivalence. - intro i. destruct i as [ a i ]. destruct i as [ i0 i1 ]. destruct i0 as [ j0 j1 ]. split with a. split. + split; assumption. + intros l o. apply i1. split. * exact ( pr2 o ). * exact ( pr1 o ). - intro i. destruct i as [ a i ]. destruct i as [ i0 i1 ]. destruct i0 as [ j0 j1 ]. split with a. split. + split; assumption. + intros l o. apply i1. split. * exact ( pr2 o ). * exact ( pr1 o ). } apply ( base_paths _ _ x ). Defined. Lemma hzgcdandminusr ( m n : hz ) : hzgcd m n = hzgcd m ( - n ). Proof. intros. rewrite 2! ( hzgcdsymm m ). rewrite hzgcdandminusl. apply idpath. Defined. Definition euclidean ( n m : hz ) ( i : hzneq 0 n ) ( p : natleh ( hzabsval m ) ( hzabsval n ) ) : hzgcd n m. Proof. intros. assert ( natneq 0%nat ( hzabsval n ) ) as j. { (* this proof very different from the original development: *) apply issymm_natneq. apply hzabsvalneq0. intro x. rewrite x in i. simpl in i. apply i. apply idpath. } set ( a := natgcd ( hzabsval m ) ( hzabsval n ) j p ). destruct ( hzlthorgeh 0 n ) as [ left_n | right_n ]. - destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. + rewrite 2! ( hzabsvalgth0 ) in a; assumption. + rewrite hzabsvalgth0 in a. * rewrite hzabsvalleh0 in a. -- rewrite hzgcdandminusr. assumption. -- assumption. * assumption. - destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. + rewrite ( hzabsvalgth0 left_m ) in a. rewrite hzabsvalleh0 in a. * rewrite hzgcdandminusl. assumption. * assumption. + rewrite 2! hzabsvalleh0 in a. * rewrite hzgcdandminusl. rewrite hzgcdandminusr. assumption. * assumption. * assumption. Defined. Theorem euclideanalgorithm ( n m : hz ) ( i : hzneq 0 n ) : iscontr ( hzgcd n m ). Proof. intros. destruct ( natgthorleh ( hzabsval m ) ( hzabsval n ) ) as [ left | right ]. - assert ( hzneq 0 m ) as i'. { intro f. apply ( negnatlthn0 ( hzabsval n ) ). rewrite <- f in left. rewrite hzabsval0 in left. assumption. } set ( a := euclidean m n i' ( natlthtoleh _ _ left ) ). rewrite hzgcdsymm in a. split with a. intro. apply isaprophzgcd. - split with ( euclidean n m i right ). intro. apply isaprophzgcd. Defined. Definition gcd ( n m : hz ) ( i : hzneq 0 n ) : hz := pr1 ( pr1 ( euclideanalgorithm n m i ) ). Definition gcdiscommondiv ( n m : hz ) ( i : hzneq 0 n ) : iscommonhzdiv (gcd n m i) n m := pr1 ( pr2 ( pr1 ( euclideanalgorithm n m i ) ) ). Definition gcdisgreatest ( n m : hz ) ( i : hzneq 0 n ): ∏ l : hz, iscommonhzdiv l n m → hzleh l (gcd n m i) := pr2 ( pr2 ( pr1 ( euclideanalgorithm n m i ) ) ). Lemma hzdivand0 ( n : hz ) : hzdiv n 0. Proof. intros. intros P s. apply s. split with 0. unfold hzdiv0. apply hzmultx0. Defined. Lemma nozerodiv ( n : hz ) ( i : hzneq 0 n ) : neg ( hzdiv 0 n ). Proof. intros. intro p. unfold hzneq in i. (* is crucial *) simpl in i. apply i. apply ( p ( make_hProp ( 0 = n ) ( isasethz 0 n ) ) ). intro t. destruct t as [ k f ]. unfold hzdiv0 in f. rewrite ( hzmult0x ) in f. assumption. Defined. (** * IV. Bezout's lemma and the commutative ring Z/pZ *) Lemma commonhzdivsignswap ( k n m : hz ) ( p : iscommonhzdiv k n m ) : iscommonhzdiv ( - k ) n m . Proof. intros. destruct p as [ p0 p1 ]. split. - use (hinhuniv _ p0). intro t. intros P s. apply s. destruct t as [ l f ]. unfold hzdiv0 in f. split with ( - l ). unfold hzdiv0. change ( k * l ) with ( k * l )%ring in f. rewrite <- ringmultminusminus in f. assumption. - use (hinhuniv _ p1). intro t. destruct t as [ l f ]. unfold hzdiv0 in f. intros P s. apply s. split with ( - l ). unfold hzdiv0. change ( k * l ) with ( k * l )%ring in f. rewrite <- ringmultminusminus in f. assumption. Defined. Lemma gcdneq0 ( n m : hz ) ( i : hzneq 0 n ) : hzneq 0 ( gcd n m i ). Proof. intros. intro f. apply ( nozerodiv n ). - assumption. - rewrite f. exact ( pr1 ( gcdiscommondiv n m i ) ). Defined. Lemma gcdpositive ( n m : hz ) ( i : hzneq 0 n ) : hzlth 0 ( gcd n m i ). Proof. intros. destruct ( hzneqchoice 0 ( gcd n m i ) ( gcdneq0 n m i ) ) as [ left | right ]. - apply fromempty. assert ( hzleh ( - ( gcd n m i ) ) ( gcd n m i ) ) as i0. { apply ( gcdisgreatest n m i ). apply commonhzdivsignswap. exact ( gcdiscommondiv n m i ). } apply ( isirreflhzlth 0 ). apply ( istranshzlth _ ( - ( gcd n m i ) ) _ ). + apply hzlth0andminus. assumption. + apply ( hzlehlthtrans _ ( gcd n m i ) _ ); assumption. - assumption. Defined. Lemma gcdanddiv ( n m : hz ) ( i : hzneq 0 n ) ( p : hzdiv n m ) : ( gcd n m i = n ) ⨿ ( gcd n m i = - n ). Proof. intros. destruct ( hzneqchoice 0 n i ) as [ left | right ]. - apply ii2. apply isantisymmhzleh. + use (hinhuniv _ ( hzdivhzabsval ( gcd n m i ) n ( pr1 ( gcdiscommondiv n m i ) ) )). intro c'. destruct c' as [ c0 | c1 ]. * rewrite <- hzabsvalgeh0. -- rewrite <- hzabsvallth0. ++ apply nattohzandleh. assumption. ++ assumption. -- apply hzgthtogeh. apply ( gcdpositive n m i ). * apply fromempty. assert ( n = 0 ) as f. { rewrite hzabsvaleq0. -- apply idpath. -- assumption. } unfold hzneq in i. (* crucial *) apply i. apply pathsinv0. assumption. + apply gcdisgreatest. apply commonhzdivsignswap. split. * apply hzdivisrefl. * assumption. - apply ii1. apply isantisymmhzleh. + use (hinhuniv _ ( hzdivhzabsval ( gcd n m i ) n ( pr1 ( gcdiscommondiv n m i ) ) )). intro c'. destruct c' as [ c0 | c1 ]. * rewrite <- hzabsvalgth0. -- assert ( n = nattohz ( hzabsval n ) ) as f. { apply pathsinv0. apply hzabsvalgth0. assumption. } assert ( hzleh ( nattohz ( hzabsval ( gcd n m i ) ) ) ( nattohz ( hzabsval n ) ) ) as j. { apply nattohzandleh. assumption. } exact ( transportf ( fun x => hzleh ( nattohz ( hzabsval ( gcd n m i ) ) ) x ) ( pathsinv0 f ) j ). -- apply gcdpositive. * apply fromempty. unfold hzneq in i. (* crucial *) apply i. apply pathsinv0. rewrite hzabsvaleq0. -- apply idpath. -- assumption. + apply ( gcdisgreatest n m i ). split. * apply hzdivisrefl. * assumption. Defined. Lemma gcdand0 ( n : hz ) ( i : hzneq 0 n ) : ( gcd n 0 i = n ) ⨿ ( gcd n 0 i = - n ). Proof. intros. apply gcdanddiv. apply hzdivand0. Defined. Lemma natbezoutstrong ( m n : nat ) ( i : hzneq 0 ( nattohz n ) ) : ∑ ab : hz × hz, gcd ( nattohz n ) ( nattohz m ) i = pr1 ab * nattohz n + pr2 ab * nattohz m. Proof. revert m n i. set ( E := ( fun m : nat => forall n : nat, forall i : hzneq 0 ( nattohz n ), ∑ ab : hz × hz, gcd ( nattohz n ) ( nattohz m ) i = pr1 ab * nattohz n + pr2 ab * nattohz m ) ). assert ( forall x : nat, E x ) as goal. { apply stronginduction. - (* Base Case: *) unfold E. intros. split with ( make_dirprod 1 0 ). simpl. rewrite nattohzand0. destruct ( gcdand0 ( nattohz n ) i ) as [ left | right ]. + rewrite hzmultl1. rewrite hzplusr0. assumption. + apply fromempty. apply ( isirreflhzlth ( gcd ( nattohz n ) 0 i ) ). apply ( istranshzlth _ 0 _ ). * rewrite right. apply hzgth0andminus. change 0 with ( nattohz 0%nat ). apply nattohzandgth. apply natneq0togth0. use (pr1 (natneq_iff_neq _ _)). (* this is the culprit for advancing *) intro f. unfold hzneq in i. (* crucial *) apply i. rewrite f. apply idpath. * apply gcdpositive. - (* Induction Case: *) intros m x y. intros n i. assert ( hzneq 0 ( nattohz m ) ) as p. { intro f. set (aux := pr2 (natneq_iff_neq _ _) x). (* this is the culprit for advancing *) apply aux. apply pathsinv0. rewrite <- hzabsvalandnattohz. change 0%nat with ( hzabsval ( nattohz 0%nat ) ). apply maponpaths. assumption. } set ( r := hzremaindermod ( nattohz m ) p ( nattohz n ) ). set ( q := hzquotientmod ( nattohz m ) p ( nattohz n ) ). assert ( natlth (hzabsval r ) m ) as p'. { rewrite <- ( hzabsvalandnattohz m ). apply hzabsvalandlth. + exact ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ). + unfold r. rewrite <- ( hzabsvalgeh0 ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ) ). apply nattohzandlth. assert ( natlth ( hzabsval ( hzremaindermod ( nattohz m ) p ( nattohz n ) ) ) ( hzabsval ( nattohz m ) ) ) as ii. { apply hzabsvalandlth. * exact ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ). * assert ( nattohz ( hzabsval ( nattohz m ) ) = nattohz m ) as f. { apply maponpaths. apply hzabsvalandnattohz. } exact ( transportf ( fun x => hzlth ( hzremaindermod ( nattohz m ) p ( nattohz n ) ) x ) f ( hzlthremaindermodmod ( nattohz m ) p ( nattohz n ) ) ). } exact ( transportf ( fun x => natlth ( hzabsval ( hzremaindermod ( nattohz m ) p ( nattohz n ) ) ) x ) ( hzabsvalandnattohz m ) ii ). } set ( c := y ( hzabsval r ) p' m p ). destruct c as [ ab f ]. destruct ab as [ a b ]. simpl in f. (* split with ( make_dirprod ( ( nattohz n ) - q * ( nattohz m ) ) ( a - b * q ) ).*) split with ( make_dirprod b ( a - b * q ) ). assert ( gcd ( nattohz m ) ( nattohz ( hzabsval r ) ) p = ( gcd ( nattohz n ) ( nattohz m ) i ) ) as g. { apply isantisymmhzleh. + apply ( gcdisgreatest ( nattohz n ) ( nattohz m ) i ). split. * apply ( hzdivlinearcombright ( nattohz n ) ( nattohz m * hzquotientmod ( nattohz m ) p ( nattohz n ) ) r ). -- exact ( hzdivequationmod ( nattohz m ) p ( nattohz n ) ). -- apply hzdivandmultr. apply gcdiscommondiv. -- unfold r. rewrite ( hzabsvalgeh0 ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ) ) . apply ( pr2 ( gcdiscommondiv ( nattohz m ) ( hzremaindermod ( nattohz m ) p ( nattohz n ) ) p ) ). * apply gcdiscommondiv. + apply gcdisgreatest. split. * apply ( pr2 ( gcdiscommondiv _ _ _ ) ). * apply ( hzdivlinearcombleft ( nattohz n ) ( nattohz m * hzquotientmod ( nattohz m ) p ( nattohz n ) ) ( nattohz ( hzabsval r ) ) ). -- unfold r. rewrite ( hzabsvalgeh0 ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ) ). exact ( hzdivequationmod ( nattohz m ) p ( nattohz n ) ). -- apply gcdiscommondiv. -- apply hzdivandmultr. apply ( pr2 ( gcdiscommondiv _ _ _ ) ). } rewrite <- g. rewrite f. simpl. assert ( nattohz ( hzabsval r ) = ( nattohz n - ( q * nattohz m ) ) ) as h. { rewrite ( hzdivequationmod ( nattohz m ) p ( nattohz n ) ). change ( hzquotientmod ( nattohz m ) p ( nattohz n ) ) with q. change ( hzremaindermod ( nattohz m ) p ( nattohz n ) ) with r. rewrite hzpluscomm. change (r + nattohz m * q - q * nattohz m) with ( ( r + nattohz m * q ) + ( - ( q * nattohz m ) ) ). rewrite hzmultcomm. rewrite hzplusassoc. (* Coq hangs on the following command: change (q * nattohz m + - (q * nattohz m)) with (q * nattohz m - (q * nattohz m)). *) intermediate_path (r + 0). + rewrite hzplusr0. apply hzabsvalgeh0. apply ( hzleh0remaindermod ( nattohz m ) p ( nattohz n ) ). + apply maponpaths. (* Coq again hangs on the following command: change (q * nattohz m + - (q * nattohz m)) with (q * nattohz m - (q * nattohz m)). *) rewrite <- (hzrminus (q * nattohz m)). apply idpath. } rewrite h. change ( (nattohz n - q * nattohz m) ) with ( (nattohz n + ( - ( q * nattohz m) ) ) ) at 1. rewrite ( ringldistr hz ). rewrite <- hzplusassoc. rewrite ( hzpluscomm ( a * nattohz m ) ). rewrite ringrmultminus. rewrite <- hzmultassoc. rewrite <- ringlmultminus. rewrite hzplusassoc. rewrite <- ( ringrdistr hz ). change (b * nattohz n + (a - b * q) * nattohz m) with ((b * nattohz n)%ring + ((a + - (b * q)%hz) * nattohz m)%ring). apply idpath. } apply goal. Defined. Lemma divandhzabsval ( n : hz ) : hzdiv n ( nattohz ( hzabsval n ) ). Proof. intros. destruct ( hzlthorgeh 0 n ) as [ left | right ]. - intros P s. apply s. split with 1. unfold hzdiv0. rewrite hzmultr1. rewrite hzabsvalgth0. + apply idpath. + assumption. - intros P s. apply s. split with ( - 1%hz ). unfold hzdiv0. rewrite ( ringrmultminus hz ). rewrite hzmultr1. rewrite hzabsvalleh0. + apply idpath. + assumption. Defined. Lemma bezoutstrong ( m n : hz ) ( i : hzneq 0 n ) : ∑ ab : hz × hz, gcd n m i = pr1 ab * n + pr2 ab * m. Proof. intros. assert ( hzneq 0 ( nattohz ( hzabsval n ) ) ) as i'. { intro f. unfold hzneq in i. (* crucial *) apply i. destruct ( hzneqchoice 0 n i ) as [ left | right ]. - rewrite hzabsvallth0 in f. + rewrite <- ( ringminusminus hz ). change 0 with ( - - 0 ). apply maponpaths. assumption. + assumption. - rewrite hzabsvalgth0 in f; assumption. } set ( c := (natbezoutstrong (hzabsval m) (hzabsval n) i')). destruct c as [ ab f ]. destruct ab as [ a b ]. simpl in f. assert ( gcd n m i = gcd ( nattohz ( hzabsval n ) ) ( nattohz ( hzabsval m ) ) i' ) as g. { destruct ( hzneqchoice 0 n i ) as [ left_n | right_n ]. - apply isantisymmhzleh. + apply gcdisgreatest. split. * rewrite hzabsvallth0. -- apply hzdivandminus. apply gcdiscommondiv. -- assumption. * destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. -- rewrite hzabsvalgth0. ++ apply ( pr2 ( gcdiscommondiv _ _ _ ) ). ++ assumption. -- rewrite hzabsvalleh0. ++ apply hzdivandminus. apply ( pr2 ( gcdiscommondiv _ _ _ ) ). ++ assumption. + apply gcdisgreatest. split. * apply ( hzdivistrans _ ( nattohz ( hzabsval n ) ) _ ). -- apply gcdiscommondiv. -- rewrite hzabsvallth0. ++ rewrite <- ( ringminusminus hz n ). apply hzdivandminus. rewrite ( ringminusminus hz n ). apply hzdivisrefl. ++ assumption. * apply ( hzdivistrans _ ( nattohz ( hzabsval m ) ) _ ). -- apply ( pr2 ( gcdiscommondiv _ _ _ ) ). -- destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. ++ rewrite hzabsvalgth0. ** apply hzdivisrefl. ** assumption. ++ rewrite hzabsvalleh0. ** rewrite <- ( ringminusminus hz m ). apply hzdivandminus. rewrite ( ringminusminus hz m ). apply hzdivisrefl. ** assumption. - apply isantisymmhzleh. + apply gcdisgreatest. split. * rewrite hzabsvalgth0. -- apply gcdiscommondiv. -- assumption. * apply ( hzdivistrans _ ( nattohz ( hzabsval m ) ) _ ). -- destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. ++ rewrite hzabsvalgth0. ** apply ( pr2 ( gcdiscommondiv _ _ _ ) ). ** assumption. ++ rewrite hzabsvalleh0. ** apply hzdivandminus. apply ( pr2 ( gcdiscommondiv _ _ _ ) ). ** assumption. -- apply hzdivisrefl. + apply gcdisgreatest. split. * apply ( hzdivistrans _ ( nattohz ( hzabsval n ) ) _ ). -- apply gcdiscommondiv. -- rewrite hzabsvalgth0. ++ apply hzdivisrefl. ++ assumption. * apply ( hzdivistrans _ ( nattohz ( hzabsval m ) ) _ ). -- apply ( pr2 ( gcdiscommondiv _ _ _ ) ). -- destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. ++ rewrite hzabsvalgth0. ** apply hzdivisrefl. ** assumption. ++ rewrite hzabsvalleh0. ** rewrite <- ( ringminusminus hz m ). apply hzdivandminus. rewrite ( ringminusminus hz m ). apply hzdivisrefl. ** assumption. } destruct ( hzneqchoice 0 n i ) as [ left_n | right_n ]. - destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. + split with ( make_dirprod ( - a ) b ). simpl. assert ( - a * n + b * m = ( a * nattohz ( hzabsval n ) + b * nattohz ( hzabsval m ) ) ) as l. { rewrite hzabsvallth0. * rewrite hzabsvalgth0. -- rewrite ( ringlmultminus hz ). rewrite <- ( ringrmultminus hz ). apply idpath. -- assumption. * assumption. } rewrite l. rewrite g. exact f. + split with ( make_dirprod ( - a ) ( - b ) ). simpl. rewrite 2! ( ringlmultminus hz ). rewrite <- 2! ( ringrmultminus hz ). rewrite <- hzabsvallth0. * rewrite <- hzabsvalleh0. -- rewrite g. exact f. -- assumption. * assumption. - destruct ( hzlthorgeh 0 m ) as [ left_m | right_m ]. + split with ( make_dirprod a b ). simpl. rewrite g. rewrite f. rewrite 2! hzabsvalgth0. * apply idpath. * assumption. * assumption. + split with ( make_dirprod a ( - b ) ). rewrite g. rewrite f. simpl. rewrite hzabsvalgth0. * rewrite hzabsvalleh0. -- rewrite ( ringrmultminus hz ). rewrite <- ( ringlmultminus hz ). apply idpath. -- assumption. * assumption. Defined. (** * V. Z/nZ *) Lemma hzmodisaprop ( p : hz ) ( x : hzneq 0 p ) ( n m : hz ) : isaprop ( hzremaindermod p x n = hzremaindermod p x m ). Proof. intros. apply isasethz. Defined. Definition hzmod ( p : hz ) ( x : hzneq 0 p ) : hrel hz. Proof. intros n m. exact ( make_hProp ( hzremaindermod p x n = hzremaindermod p x m ) ( hzmodisaprop p x n m ) ). Defined. Lemma hzmodisrefl ( p : hz ) ( x : hzneq 0 p ) : isrefl ( hzmod p x ). Proof. intros. unfold isrefl. intro n. unfold hzmod. assert ( hzremaindermod p x n = hzremaindermod p x n ) as a by apply idpath. apply a. Defined. Lemma hzmodissymm ( p : hz ) ( x : hzneq 0 p ) : issymm ( hzmod p x ). Proof. intros. unfold issymm. intros n m. unfold hzmod. intro v. assert ( hzremaindermod p x m = hzremaindermod p x n ) as a by exact ( pathsinv0 v ). apply a. Defined. Lemma hzmodistrans ( p : hz ) ( x : hzneq 0 p ) : istrans ( hzmod p x ). Proof. intros. unfold istrans. intros n m k. intros u v. unfold hzmod. unfold hzmod in u. unfold hzmod in v. assert ( hzremaindermod p x n = hzremaindermod p x k ) as a by exact ( pathscomp0 u v ). apply a. Defined. Lemma hzmodiseqrel ( p : hz ) ( x : hzneq 0 p ) : iseqrel ( hzmod p x ). Proof. intros. apply iseqrelconstr. - exact ( hzmodistrans p x ). - exact ( hzmodisrefl p x ). - exact ( hzmodissymm p x ). Defined. Lemma hzmodcompatmultl ( p : hz ) ( x : hzneq 0 p ) : forall a b c : hz, hzmod p x a b -> hzmod p x ( c * a ) ( c * b ). Proof. intros a b c v. unfold hzmod. change (hzremaindermod p x (c * a) = hzremaindermod p x (c * b)). rewrite hzremaindermodandtimes. rewrite v. rewrite <- hzremaindermodandtimes. apply idpath. Defined. Lemma hzmodcompatmultr ( p : hz ) ( x : hzneq 0 p ) : forall a b c : hz, hzmod p x a b -> hzmod p x ( a * c ) ( b * c ). Proof. intros a b c v. rewrite hzmultcomm. rewrite ( hzmultcomm b ). apply hzmodcompatmultl. assumption. Defined. Lemma hzmodcompatplusl ( p : hz ) ( x : hzneq 0 p ) : forall a b c : hz, hzmod p x a b -> hzmod p x ( c + a ) ( c + b ). Proof. intros a b c v. unfold hzmod. change ( hzremaindermod p x ( c + a ) = hzremaindermod p x ( c + b ) ). rewrite hzremaindermodandplus. rewrite v. rewrite <- hzremaindermodandplus. apply idpath. Defined. Lemma hzmodcompatplusr ( p : hz ) ( x : hzneq 0 p ) : forall a b c : hz, hzmod p x a b -> hzmod p x ( a + c ) ( b + c ). Proof. intros a b c v. rewrite hzpluscomm. rewrite ( hzpluscomm b ). apply hzmodcompatplusl. assumption. Defined. Lemma hzmodisringeqrel ( p : hz ) ( x : hzneq 0 p ) : ringeqrel ( X := hz ). Proof. intros. split with ( tpair ( hzmod p x ) ( hzmodiseqrel p x ) ). split. - split. + apply hzmodcompatplusl. + apply hzmodcompatplusr. - split. + apply hzmodcompatmultl. + apply hzmodcompatmultr. Defined. Definition hzmodp ( p : hz ) ( x : hzneq 0 p ) := commringquot ( hzmodisringeqrel p x ). Lemma isdeceqhzmodp ( p : hz ) ( x : hzneq 0 p ) : isdeceq ( hzmodp p x ). Proof. intros. apply ( isdeceqsetquot ( hzmodisringeqrel p x ) ). intros a b. unfold isdecprop. - destruct ( isdeceqhz ( hzremaindermod p x a ) ( hzremaindermod p x b ) ) as [ l | r ]. + unfold hzmodisringeqrel. simpl. split. * apply ii1. assumption. * apply isasethz. + unfold hzmodisringeqrel. simpl. split. * apply ii2. assumption. * apply isasethz. Defined. Definition acommring_hzmod ( p : hz ) ( x : hzneq 0 p ) : acommring. Proof. intros. split with ( hzmodp p x ). split with ( tpair _ ( deceqtoneqapart ( isdeceqhzmodp p x ) ) ). split. - split. + intros a b c q. simpl. simpl in q. intro f. apply q. rewrite f. apply idpath. + intros a b c q. simpl in q. simpl. intro f. apply q. rewrite f. apply idpath. - split. + intros a b c q. simpl in q. simpl. intros f. apply q. rewrite f. apply idpath. + intros a b c q. simpl. simpl in q. intro f. apply q. rewrite f. apply idpath. Defined. Lemma hzremaindermodanddiv ( p : hz ) ( x : hzneq 0 p ) ( a : hz ) ( y : hzdiv p a ) : hzremaindermod p x a = 0. Proof. intros. assert ( isaprop ( hzremaindermod p x a = 0 ) ) as v by apply isasethz. apply ( y ( make_hProp _ v ) ). intro t. destruct t as [ k f ]. unfold hzdiv0 in f. assert ( a = p * k + 0 ) as f'. { rewrite f. rewrite hzplusr0. apply idpath. } set ( e := tpair ( P := (fun qr : hz × hz => a = p * pr1 qr + pr2 qr × ( hzleh 0 (pr2 qr) × hzlth (pr2 qr) (nattohz (hzabsval p)))) ) ( make_dirprod k 0 ) (make_dirprod f' ( make_dirprod ( isreflhzleh 0 ) ( lemmas.hzabsvalneq0 p x ) ) ) ). assert ( e = pr1 ( divalgorithm a p x ) ) as s by apply ( pr2 ( divalgorithm a p x ) ). set ( w := base_paths _ _ ( pathsinv0 s ) ). unfold e in w. unfold hzremaindermod. apply ( maponpaths ( fun z : hz × hz => pr2 z ) w ). Defined. Lemma gcdandprime ( p : hz ) ( x : hzneq 0 p ) ( y : isaprime p ) ( a : hz ) ( q : neg ( hzmod p x a 0 ) ) : gcd p a x = 1. Proof. intros. assert ( isaprop ( gcd p a x = 1) ) as is by apply isasethz. apply ( pr2 y ( gcd p a x ) ( pr1 ( gcdiscommondiv p a x ) ) (make_hProp _ is ) ). intro t. destruct t as [ t0 | t1 ]. - apply t0. - apply fromempty. apply q. simpl. assert ( hzremaindermod p x a = 0 ) as f. { assert ( hzdiv p a ) as u. { rewrite <- t1. apply ( pr2 ( gcdiscommondiv _ _ _ ) ). } rewrite hzremaindermodanddiv. + apply idpath. + assumption. } rewrite f. rewrite hzqrand0r. apply idpath. Defined. Lemma hzremaindermodandmultl ( p : hz ) ( x : hzneq 0 p ) ( a b : hz ) : hzremaindermod p x ( p * a + b ) = hzremaindermod p x b. Proof. intros. assert ( p * a + b = ( p * ( a + hzquotientmod p x b ) + hzremaindermod p x b ) ) as f. { rewrite hzldistr. rewrite hzplusassoc. rewrite <- ( hzdivequationmod p x b ). apply idpath. } rewrite hzremaindermodandplus. rewrite hzremaindermodandtimes. rewrite hzqrandselfr. rewrite hzmult0x. rewrite hzqrand0r. rewrite hzplusl0. rewrite hzremaindermoditerated. apply idpath. Defined. Lemma hzmodprimeinv ( p : hz ) ( x : hzneq 0 p ) ( y : isaprime p ) ( a : hz ) ( q : neg ( hzmod p x a 0 ) ) : ∑ v : hz, hzmod p x ( a * v ) 1 × hzmod p x ( v * a ) 1. Proof. intros. split with ( pr2 ( pr1 ( bezoutstrong a p x ) ) ). assert ( 1 = pr1 (pr1 (bezoutstrong a p x)) * p + pr2 (pr1 (bezoutstrong a p x)) * a ) as f'. { assert ( 1 = gcd p a x ) as f''. { apply pathsinv0. apply gcdandprime; assumption. } rewrite f''. apply ( bezoutstrong a p x ). } split. - rewrite f'. simpl. rewrite ( hzmultcomm ( pr1 ( pr1 ( bezoutstrong a p x ) ) ) _ ). rewrite hzremaindermodandmultl. rewrite hzmultcomm. apply idpath. - rewrite f'. simpl. rewrite hzremaindermodandplus. rewrite ( hzremaindermodandtimes p x _ p ). rewrite hzqrandselfr. rewrite hzmultx0. rewrite hzqrand0r. rewrite hzplusl0. rewrite hzremaindermoditerated. apply idpath. Defined. Lemma quotientringsumdecom ( X : commring ) ( R : ringeqrel ( X := X ) ) ( a b : X ) : @op2 ( commringquot R ) ( setquotpr R a ) ( setquotpr R b ) = ( setquotpr R ( a * b )%ring ). Proof. intros. apply idpath. Defined. Definition ahzmod ( p : hz ) ( y : isaprime p ) : afld. Proof. intros. split with ( acommring_hzmod p ( isaprimetoneq0 y ) ). split. - simpl. intro f. apply ( isirreflhzlth 0 ). assert ( hzlth 0 1 ) as i by apply hzlthnsn. change ( 1%ring ) with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 1%hz ) in f. change ( 0%ring ) with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 0%hz ). assert ( hzmodisringeqrel p ( isaprimetoneq0 y ) 1%hz 0%hz ) as o. { apply ( weqpathsinsetquot ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 1%hz 0%hz ). assumption. } unfold hzmodisringeqrel in o. simpl in o. assert ( hzremaindermod p ( isaprimetoneq0 y ) 0 = 0 ) as o'. { rewrite hzqrand0r. apply idpath. } rewrite o' in o. assert ( hzremaindermod p ( isaprimetoneq0 y ) 1 = 1 ) as o''. { assert ( hzlth 1 p ) as v by apply y. rewrite hzqrand1r. apply idpath. } rewrite o'' in o. assert ( hzlth 0 1 ) as o''' by apply hzlthnsn. rewrite o in o'''. assumption. - assert ( forall x0 : acommring_hzmod p ( isaprimetoneq0 y ), isaprop ( ( x0 # 0)%ring -> multinvpair ( acommring_hzmod p ( isaprimetoneq0 y ) ) x0 ) ) as int. { intro a. apply impred. intro q. apply isapropmultinvpair. } apply ( setquotunivprop _ ( fun x0 => make_hProp _ ( int x0 ) ) ). intro a. simpl. intro q. assert ( neg ( hzmod p ( isaprimetoneq0 y ) a 0 ) ) as q'. { intro g. unfold hzmod in g. simpl in g. apply q. change ( 0%ring ) with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 0%hz ). apply ( iscompsetquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ). apply g. } split with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ( pr1 ( hzmodprimeinv p ( isaprimetoneq0 y ) y a q' ) ) ). split. + simpl. rewrite ( quotientringsumdecom hz ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ). change 1%multmonoid with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 1%hz ). apply ( iscompsetquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ). simpl. change (pr2 (pr1 (bezoutstrong a p ( isaprimetoneq0 y ))) * a)%ring with (pr2 (pr1 (bezoutstrong a p ( isaprimetoneq0 y ))) * a)%hz. exact ( ( pr2 ( pr2 ( hzmodprimeinv p ( isaprimetoneq0 y ) y a q' ) ) )). + simpl. rewrite ( quotientringsumdecom hz ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ). change 1%multmonoid with ( setquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) 1%hz ). apply ( iscompsetquotpr ( hzmodisringeqrel p ( isaprimetoneq0 y ) ) ). change (a * pr2 (pr1 (bezoutstrong a p ( isaprimetoneq0 y ))))%ring with (a * pr2 (pr1 (bezoutstrong a p ( isaprimetoneq0 y ))))%hz. exact ( ( pr1 ( pr2 ( hzmodprimeinv p ( isaprimetoneq0 y ) y a q' ) ) )). Defined. Close Scope hz_scope. (** END OF FILE *) UniMath-20231010/UniMath/Paradoxes/000077500000000000000000000000001451125700300166025ustar00rootroot00000000000000UniMath-20231010/UniMath/Paradoxes/.package/000077500000000000000000000000001451125700300202535ustar00rootroot00000000000000UniMath-20231010/UniMath/Paradoxes/.package/files000066400000000000000000000000211451125700300212710ustar00rootroot00000000000000GirardsParadox.v UniMath-20231010/UniMath/Paradoxes/GirardsParadox.v000066400000000000000000000146231451125700300217110ustar00rootroot00000000000000(** This file provides a direct formalizatoin of Girard's paradox, as explained in Martin-Lof's 1972 "An intuitionistic theory of types". It can serve as a test as to whether the version of Coq being used is (in the most obvious way) inconsistent. **) Require Import UniMath.Foundations.All. Require Export UniMath.Tactics.EnsureStructuredProofs. (* This section has an arbitrary type instead of False *) Section girard. Variable Flse : Type. (* an "ordering without infinite descending chains" (wf is for "well-founded") *) Definition wf (T : Type) : Type := ∑ lt : T -> T -> Type, (∏ x y z: T, lt x y -> lt y z -> lt x z) × (∏ h : (nat -> T), (∏ n : nat, lt (h (S n)) (h n)) -> Flse). (* the type of such orderings *) Definition wfs : Type := total2 wf. (* the underyling set *) Definition uset (w : wfs) : Type := pr1 w. (* the underlying order *) Definition uord (w : wfs) : uset w -> uset w -> Type := pr1 (pr2 w). (* the transitivity property *) Definition trans (w : wfs) {x y z : uset w} : pr1 (pr2 w) x y → pr1 (pr2 w) y z → pr1 (pr2 w) x z := pr1 (pr2 (pr2 w)) x y z. (* the well-foundedness property *) Definition wfp (w : wfs) : (λ _ : ∏ x y z : pr1 w, pr1 (pr2 w) x y → pr1 (pr2 w) y z → pr1 (pr2 w) x z, ∏ h : nat → pr1 w, (∏ n : nat, pr1 (pr2 w) (h (S n)) (h n)) → Flse) (pr1 (pr2 (pr2 w))) := pr2 (pr2 (pr2 w)). (* the order on wfs: an order-preserving function on underlying sets and an element of the second set which dominates the image *) Definition wfs_wf_uord (v : wfs) (w : wfs) : Type := ∑ f : uset v -> uset w, (∏ x y : uset v, (uord v) x y -> (uord w) (f x) (f y)) × (∑ y : uset w, ∏ (x: uset v), (uord w) (f x) y). (* the underlying function *) Definition ufun {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : uset v → uset w := pr1 a. (* the homomorpshim property *) Definition homo {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : ∏ (x y : uset v), uord v x y → uord w (pr1 a x) (pr1 a y) := pr1 (pr2 a). (* the dominating element *) Definition domi {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : uset w := pr1 (pr2 (pr2 a)). (* the relation comparing the dominating element to the various images *) Definition domicom {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : (λ y : uset w, ∏ x : uset v, uord w (pr1 a x) y) (pr1 (pr2 (pr2 a))) := pr2 (pr2 (pr2 a)). (* transitivty of the ordering on wfs *) Definition wfs_wf_trans : forall x y z : wfs, wfs_wf_uord x y -> wfs_wf_uord y z -> wfs_wf_uord x z. Proof. intros x y z. intros f g. exists (fun a : uset x => (ufun g) ((ufun f) a)). split. + intros x0 y0. intro x0y0. exact (homo g _ _ (homo f _ _ x0y0)). + exists (domi g). intro x0. set (y0 := ufun f x0). set (ydom := domi f). set (co := domicom f x0). exact (trans z (homo g _ _ co) (domicom g (domi f))). Defined. (* the following three definitions and lemmas are for showing that wfs_wf_uord is well founded *) (* given a descending sequence f : nat -> wfs, map each f(n) to f(0) by composing all the maps *) Definition wfs_wf_wfp_shift (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) : ∏ (n : nat), (uset (f n) -> uset (f 0)). Proof. intro n. induction n. - intro a; exact a. - intro x. exact (IHn (ufun (b n) x)). Defined. (* thus obtain a sequence in (f 0) *) Definition wfs_wf_wfp_seq (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) : nat -> uset (f 0). Proof. intro n. exact (wfs_wf_wfp_shift f b n (domi (b n))). Defined. (* obtain comparisons between the shifted elements *) Definition wfs_wf_wfp_compshift (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) : ∏ (n : nat) {x y : uset (f n)}, uord (f n) x y -> uord (f 0) (wfs_wf_wfp_shift f b n x) (wfs_wf_wfp_shift f b n y). Proof. intros n. induction n. - intros x y p. exact p. - intros x y p. exact (IHn _ _ (homo (b n) x y p)). Qed. (* show that the resulting sequence on (f 0) is descending *) Lemma wfs_wf_wfp_desc (f : nat -> wfs) (b : forall n : nat, wfs_wf_uord (f (S n)) (f n)) : ∏ n : nat, uord (f 0) (wfs_wf_wfp_seq f b (S n)) (wfs_wf_wfp_seq f b n). Proof. intro n. exact (wfs_wf_wfp_compshift f b n (domicom (b n) (domi (b (S n))))). Defined. (* the wf on wfs *) Definition wfs_wf : wf wfs. Proof. exists wfs_wf_uord. split. - exact wfs_wf_trans. - intro h. intro b. exact (wfp _ (wfs_wf_wfp_seq h b) (wfs_wf_wfp_desc h b)). Defined. (* the wf on wfs as an element of wfs *) Definition wfs_wf_t : wfs := tpair (fun T => wf T) wfs (wfs_wf). (* this definition and the following three lemmas show that wfs_wf has a maximal element *) (* function mapping each wf to the set of wfs (by taking inital segments) *) Definition maxi_fun (w : wfs) : uset w -> wfs. Proof. intro x. exists (∑ y : uset w, uord w y x). exists (fun a b => uord w (pr1 a) (pr1 b)). split. - intros x0 y z p q. exact (trans w p q). - intro h. intro b. exact (wfp w (fun n => pr1 (h n)) b). Defined. (* maxi_fun preserves the order *) Lemma maxi_homo (w : wfs) : ∏ (x y : uset w), uord w x y -> wfs_wf_uord (maxi_fun w x) (maxi_fun w y). Proof. intros x y p. exists (fun (z : uset (maxi_fun w x)) => tpair _ (pr1 z) (trans w (pr2 z) p)). split. - intros x0 y0 q. exact q. - exists (tpair _ x p). intro x0. exact (pr2 x0). Defined. (* w itself dominates the image of w under maxi_fun *) Lemma maxidom (w : wfs) : ∏ (x : uset w), wfs_wf_uord (maxi_fun w x) w. Proof. intro x. exists (fun (z : uset (maxi_fun w x)) => pr1 z). split. - intros x0 y p. exact p. - exists x. intro x0. exact (pr2 x0). Defined. (* wfs_wf_t is maximal with respect to wfs_wf *) Lemma maxi (w : wfs) : wfs_wf_uord w wfs_wf_t. Proof. exists (maxi_fun w). split. - exact (maxi_homo w). - exact (tpair _ _ (maxidom w)). Defined. (* in particular wfs_wf_t is greather than itself *) Proposition whoa : uord wfs_wf_t wfs_wf_t wfs_wf_t. Proof. apply maxi. Defined. (* but wfs are irreflexive *) Proposition irref (w : wfs) : ∏ (x : uset w), (uord w) x x -> Flse. Proof. intro x. intro p. exact (wfp w (fun n => x) (fun n => p)). Defined. (* therefore the world explodes *) Proposition the_world_explodes : Flse. Proof. exact (irref wfs_wf_t wfs_wf_t whoa). Defined. End girard. (* especially if Flse=False *) Proposition but_seriously_the_world_explodes : empty. exact (the_world_explodes empty). Defined. UniMath-20231010/UniMath/Paradoxes/README.md000066400000000000000000000006621451125700300200650ustar00rootroot00000000000000Paradoxes ========= This package just contains the file GirardsParadox.v, which is a formalization of Girards Paradox, and which compiles in versions of Coq which allow "Type in Type". It should not be seen as part of the UniMath project proper, but is just provided as a record that an inconsistency is formalizable in the present (at the time of this writing) version of UniMath, as will hopefully be impossible in future versions.UniMath-20231010/UniMath/README.md000066400000000000000000000211001451125700300161250ustar00rootroot00000000000000Univalent Mathematics Coq files =============================== Each subdirectory of this directory consists of a separate package, with various authors, as recorded in the README (or README.md) file in it. ## Contributing code to UniMath Volunteers may look at unassigned issues at github and volunteer to be assigned one of them. New proposals and ideas may be submitted as issues at github for discussion and feedback. Contributions are submitted in the form of pull requests at github and are subject to approval by the UniMath Development Team. Changes to the package "Foundations" are normally not accepted, for we are trying to keep it in a state close to what Vladimir Voevodsky originally intended. A warning is issued if you run `make` or `make all` and have changed a file in the Foundations package. ## Adding a file to a package Each package contains a subdirectory called ".package". The file ".packages/files" consists of a list of the paths to the *.v files of the package, in order, i.e., a file is listed after files it depends on. (That's just so the TAGS file will be correctly sequenced.) To add a file to a package, add its path to that file. ## Adding a new package Create a subdirectory of this directory, populate it with your files, add a README (or README.md) file, and add a file .package/files, listing the *.v files of your package, as above. Then add the name of your package to the head of the list assigned to "PACKAGES" in the file "./Makefile", or, alternatively, if you'd like to test your package without modifying "./Makefile", which you might accidentally commit and push, add its name to the head of the list in "../build/Makefile-configuration", which is created from "../build/Makefile-configuration-template". ## The UniMath formal language The formal language used in the UniMath project is based on Martin-Löf type theory, as present in MLTT79 below. We are currently on version 2. UniMath-1 is MLTT79 except: - the bound variable in a λ-expression is annotated with its type - we omit W-types - just the finite types of cardinality 0, 1, and 2 are used, although there would be no problem with introducing further ones - we omit reflection from identities to judgmental equalities - we add the resizing rules from the [slides](https://www.math.ias.edu/vladimir/sites/math.ias.edu.vladimir/files/2011_Bergen.pdf) of Voevodsky's 2011 talk in Bergen UniMath-2 is UniMath-1 except: - we add η for pairs The axioms accepted are: the univalence axiom, the law of excluded middle, the axiom of choice, and a few new variants of the axiom of choice, validated by the semantic model. MLTT79 is this paper: ``` @incollection {MLTT79, AUTHOR = {Martin-L\"of, Per}, TITLE = {Constructive mathematics and computer programming}, BOOKTITLE = {Logic, methodology and philosophy of science, {VI} ({H}annover, 1979)}, SERIES = {Stud. Logic Found. Math.}, VOLUME = {104}, PAGES = {153--175}, PUBLISHER = {North-Holland, Amsterdam}, YEAR = {1982}, MRCLASS = {03F50 (03B70 03F55 68Q45)}, MRNUMBER = {682410}, MRREVIEWER = {B. H. Mayoh}, DOI = {10.1016/S0049-237X(09)70189-2}, URL = {http://dx.doi.org/10.1016/S0049-237X(09)70189-2}, } ``` ## UniMath coding style In the following rules, we purposely restrict our use of Coq to a subset whose semantics is more likely to be rigorously verifiable and portable to new proof checking systems, and we follow a style of coding designed to render proofs less fragile and to make the files have a more uniform and pleasing appearance. * Identifiers and function names * Form identifiers by concatenating English words or existing identifiers in lower case, separating them by underscores. * Unless it impedes clarity or goes against common practice avoid using abbreviations. * In some parts of the library uppercase is used for bundled mathematical objects (e.g. `Pullback`, `Topos`). It is sometimes justified to introduce new identifiers using this naming scheme. The following guidelines should then be applied: * Identifiers with capital letters must not use underscores to separate words, they must use `CamelCase`. * Only use `CamelCase` when it is already used in the parts of the library you are working in or there is some compelling reason for it to be introduced. * Do not use `CamelCase` for intermediary structures. Example: if `CamelCase`contains a data part and a property part then name these `camel_case_data` and `is_camel_case`, do not call them `CamelCaseData` and `IsCamelCase`. * Upper-case letters should not be used in function names unless there is specific good reason to do so. In general name your functions `make_camel_case` and `camel_case_property`, not `make_CamelCase` and `CamelCase_property`, even if the object is called `CamelCase`. * Do not use `Admitted` or introduce new axioms. * Do not use `apply` with a term that needs no additional arguments filled in, because using `exact` would be clearer. * Do not use `Prop` or `Set`, and ensure definitions don't produce elements of them. * Do not use `Inductive` or `Record`. Their use is limited to just a few basic types, which are defined in `Foundations/Preamble.v`. * Do not use `Structure`. * Use `Module` only naively, to create blocks of code that can be imported. Do not use `Module Type`. * Do not use `Fixpoint`. * Do not use `destruct`, `match`, `case`, square brackets with `intros`, or nested square brackets with `induction`. (The goal is to prevent generation of proof terms using `match`.) * Use `do` with a specific numerical count, rather than `repeat`, to make proofs easier to repair. * Use `as` to name all new variables introduced by `induction` or `destruct`, if the corresponding type is defined in a remote location, because different names might be used by Coq when the definition of the type is changed. Name all variables introduced by `assert`, if they are used by name later, with `as` or to the left of a colon. * Avoid ending proofs with `Qed`, because that may prevent future computation. If you decide to make a proof opaque, then make sure that its type is a proposition. It is undesirable to write multiple opaque proofs of properties, for then proofs of equality of objects containing them cannot be accomplished by reflexivity. * Start all proofs with `Proof.` on a separate line and end it with `Defined.` on a separate line, as this makes it possible for us to generate HTML with expansible/collapsible proofs. * Use `Lemma`, `Proposition`, or `Theorem` for proofs of propositions; for defining elements of types that are not propositions, use `Definition`. * Use Unicode notation freely, but make the parsing conventions uniform across files. All notations, except for certain notations in the Foundations package used everywhere, should be local or in a scope. All scopes, if opened, should be opened only locally. Consider also putting them into a submodule, for then they won't be activated even for printing. * When introducing a notation using Unicode characters, document in a comment how to input that character using the Agda input method. * Each line should be limited to at most 100 (unicode) characters. The makefile target `enforce-max-line-length` can be used to detect nonconforming files, and the target `show-long-lines` can be used to display the nonconforming lines. * Always use Coq's proof structuring syntax ( ` { } + - * ` ) to focus on a single goal immediately after a tactic creates additional goals. * Indentation should normally be that produced automatically by emacs' `coq-mode`. * When using `abstract` in a proof, it is unsound to refer later by name to the abstracted lemma (whose name typically ends with `_subproof`), because its type may vary from one version of Coq to another. Coq's current behavior is also unlikely to be duplicated precisely by a future proof assistant. * Define and use accessor functions for structures instead of chains of `pr1` and `pr2`. This makes the code easier to maintain in the long run (if the structure is rearranged the proofs will still work if the accessor functions are changed accordingly). * Define constructor functions for structures taking all of the required data in the right order. This way one can write `use constructor` instead of having a nested chain of `use tpair` leading to flatter proof scripts for instantiating structures. Our files don't adhere yet to all of these conventions, but it's a goal we strive for. Another advantage of coding in this style is that the proofs should be easier to transport to another proof assistant. UniMath-20231010/UniMath/RealNumbers/000077500000000000000000000000001451125700300170735ustar00rootroot00000000000000UniMath-20231010/UniMath/RealNumbers/.package/000077500000000000000000000000001451125700300205445ustar00rootroot00000000000000UniMath-20231010/UniMath/RealNumbers/.package/files000066400000000000000000000001621451125700300215700ustar00rootroot00000000000000Prelim.v Fields.v Sets.v NonnegativeRationals.v NonnegativeReals.v Reals.v DedekindCuts.v DecidableDedekindCuts.v UniMath-20231010/UniMath/RealNumbers/DecidableDedekindCuts.v000066400000000000000000000033561451125700300234140ustar00rootroot00000000000000(** * A library about decidable Dedekind Cuts *) (** Author: Catherine LELAY. Oct 2015 - *) (** Additional results about Dedekind cuts which cannot be proved *) (** without decidability *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.RealNumbers.Prelim. Require Import UniMath.RealNumbers.Sets. Require Import UniMath.RealNumbers.NonnegativeRationals. Require Export UniMath.RealNumbers.NonnegativeReals. Local Open Scope Dcuts_scope. Local Open Scope DC_scope. (** ** Definition *) Lemma isboolDcuts_isaprop (x : Dcuts) : isaprop (∏ r, (r ∈ x) ∨ (neg (r ∈ x))). Proof. apply impred_isaprop. intros r. apply pr2. Qed. Definition isboolDcuts : hsubtype Dcuts := (λ x : Dcuts, make_hProp _ (isboolDcuts_isaprop x)). Lemma isaset_boolDcuts : isaset isboolDcuts. Proof. apply isasetsubset with pr1. - apply pr2. - apply isinclpr1. intro x. apply pr2. Qed. Definition boolDcuts : hSet. Proof. apply (make_hSet (carrier isboolDcuts)). exact isaset_boolDcuts. Defined. Definition make_boolDcuts (x : Dcuts) (Hdec : ∏ r : NonnegativeRationals, (r ∈ x) ⨿ ¬ (r ∈ x)) : boolDcuts := x,, (λ r : NonnegativeRationals, hinhpr (Hdec r)). Lemma is_zero_dec : ∏ x : Dcuts, isboolDcuts x -> (x = 0) ∨ (¬ (x = 0)). Proof. intros x Hx. generalize (Hx 0%NRat) ; apply hinhfun ; apply sumofmaps ; intros Hx0. - right ; intro H. rewrite H in Hx0. now apply Dcuts_zero_empty in Hx0. - left ; apply Dcuts_eq_is_eq. split. + intros Hr. apply fromempty. apply Hx0. apply (is_Dcuts_bot x r). * now apply Hr. * apply isnonnegative_NonnegativeRationals. + intros Hr. now apply Dcuts_zero_empty in Hr. Qed. UniMath-20231010/UniMath/RealNumbers/DedekindCuts.v000066400000000000000000000461011451125700300216320ustar00rootroot00000000000000(** * Usual constructive Dedekind cuts *) (** Catherine LELAY. July 2017 *) (** This file formalizes the usual definitions of constructive Dedekind cuts. - The two-sided definition come from the HoTT-book - The one-sided definition come from Robert S Lubarsky and Michael Rathjen. On the constructive Dedekind reals. Logic and Analysis. I first prove the equivalence between these two definitions, then I prove the equivalence between the non-negative numbers of the one-sided definition and the set Dcuts *) Require Export UniMath.NumberSystems.RationalNumbers. Require Import UniMath.RealNumbers.Prelim. Require Import UniMath.RealNumbers.NonnegativeRationals. Require Import UniMath.RealNumbers.NonnegativeReals. Unset Kernel Term Sharing. (** ** Usual definitions *) Local Open Scope hq_scope. Definition isTwoSided (L U : hq → hProp) : UU := ((∏ q : hq, L q <-> ∃ r : hq, L r ∧ hqlth q r) × (∏ q : hq, U q <-> ∃ r : hq, U r ∧ hqlth r q)) × ((∃ q : hq, L q) × (∃ q : hq, U q)) × (∏ q : hq, ¬ (U q ∧ L q)) × (∏ q r : hq, hqlth q r → L q ∨ U r). Definition isOneSided (S : hq → hProp) : UU := ((∃ r : hq, S r) ∧ (∃ r : hq, ¬ S r)) × (∏ r : hq, S r → ∃ q : hq, S q ∧ hqlth r q) × (∏ r s : hq, hqlth r s → S r ∨ ¬ S s). (** ** Equivalence between these two definitions *) Lemma isTwoSided_OneSided : ∏ (L U : hq → hProp), isTwoSided L U → isOneSided L. Proof. intros L U H. split ; split. - exact (pr1 (pr1 (pr2 H))). - generalize (pr1 (pr2 (pr2 H))) (pr2 (pr1 (pr2 H))) ; intros H0. apply hinhfun. intros q. exists (pr1 q). intros Lq. apply (H0 (pr1 q)). split. + exact (pr2 q). + exact Lq. - intros r Lr. generalize (pr1 (pr1 H)) ; intros H0. exact (pr1 (H0 r) Lr). - intros r s Hrs. generalize (pr1 (pr2 (pr2 H))) (pr2 (pr2 (pr2 H))) ; intros H0 H1. generalize (H1 _ _ Hrs). apply hinhfun, sumofmaps. + exact ii1. + intros Us. apply ii2. intros Ls. apply (H0 s). split. * exact Us. * exact Ls. Qed. Lemma isOneSided_TwoSided : ∏ (S : hq → hProp), isOneSided S → isTwoSided S (λ s : hq, ∃ r : hq, hqlth r s × ¬ S r). Proof. intros S H. split ; split ; [ | | split | split]. - intros q ; split. + exact (pr1 (pr2 H) q). + apply hinhuniv ; intros r. generalize (pr2 (pr2 H) _ _ (pr2 (pr2 r))). apply hinhuniv, sumofmaps. * intros Sq ; apply Sq. * intros Sr. apply fromempty. apply Sr, (pr1 (pr2 r)). - intros q ; split. + apply hinhfun. intros r. set (s := Prelim.hqlth_between _ _ (pr1 (pr2 r))). exists (pr1 s). split. * apply hinhpr. exists (pr1 r). { split. - exact (pr1 (pr2 s)). - exact (pr2 (pr2 r)). } * exact (pr2 (pr2 s)). + apply hinhuniv. intros r. generalize (pr1 (pr2 r)). apply hinhfun. intros s. exists (pr1 s). split. * apply istranshqlth with (pr1 r). ** exact (pr1 (pr2 s)). ** exact (pr2 (pr2 r)). * exact (pr2 (pr2 s)). - exact (pr1 (pr1 H)). - generalize (pr2 (pr1 H)). apply hinhfun. intros r. exists (pr1 r+1). apply hinhpr. exists (pr1 r). split. + exact (hqlthnsn _). + exact (pr2 r). - intros q Hq. generalize (pr1 Hq). apply (hinhuniv (P := make_hProp _ isapropempty)). intros r. generalize (pr2 (pr2 H) _ _ (pr1 (pr2 r))). apply hinhuniv, sumofmaps. + exact (pr2 (pr2 r)). + intros Sq ; apply Sq. exact (pr2 Hq). - intros q r Hqr. set (s := Prelim.hqlth_between _ _ Hqr). generalize (pr2 (pr2 H) _ _ (pr1 (pr2 s))). apply hinhfun, sumofmaps. + exact ii1. + intros Sr. apply ii2, hinhpr. exists (pr1 s). split. * exact (pr2 (pr2 s)). * exact Sr. Qed. Lemma weqTwoSidedOneSided : (∑ L U : hq → hProp, isTwoSided L U) ≃ (∑ S : hq → hProp, isOneSided S). Proof. set (f := (λ (LU : ∑ L U : hq → hProp, isTwoSided L U), pr1 LU,, isTwoSided_OneSided (pr1 LU) (pr1 (pr2 LU)) (pr2 (pr2 LU))) : (∑ L U : hq → hProp, isTwoSided L U) → ∑ S, isOneSided S). set (g := (λ S : (∑ S : hq → hProp, isOneSided S), pr1 S ,, (λ s : hq, ∃ r : hq, r < s × ¬ pr1 S r) ,, isOneSided_TwoSided (pr1 S) (pr2 S)) : (∑ S, isOneSided S) → ∑ L U : hq → hProp, isTwoSided L U). apply (weq_iso f g). - intros LU. change (pr1 (g (f LU)),, pr2 (g (f LU)) = pr1 LU,, pr2 LU). apply pair_path_in2. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). + apply isapropdirprod. * apply isapropdirprod ; apply impred_isaprop ; intro q ; apply isapropdirprod ; apply isapropimpl, propproperty. * apply isapropdirprod. ** apply isapropdirprod ; apply propproperty. ** apply isapropdirprod. *** apply impred_isaprop ; intro q. apply isapropneg. *** apply impred_isaprop ; intro q. apply impred_isaprop ; intro r. apply isapropimpl, propproperty. + apply funextfun ; intros q. apply hPropUnivalence. * apply hinhuniv. intros r. generalize (pr2 (pr2 (pr2 (pr2 (pr2 LU)))) _ _ (pr1 (pr2 r))). apply hinhuniv, sumofmaps. { intro Lr ; apply fromempty, (pr2 (pr2 r)), Lr. } intros Uq ; apply Uq. * intros Uq. generalize (pr1 (pr2 (pr1 (pr2 (pr2 LU))) _) Uq). apply hinhfun. intros r. exists (pr1 r). split. ** apply (pr2 (pr2 r)). ** intros Lr. apply (pr1 (pr2 (pr2 (pr2 (pr2 LU)))) (pr1 r)). split. *** apply (pr1 (pr2 r)). *** apply Lr. - intros S. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). + apply isapropdirprod. * apply propproperty. * apply isapropdirprod. ** apply impred_isaprop ; intro r. apply isapropimpl, propproperty. ** apply impred_isaprop ; intro r. apply impred_isaprop ; intro s. apply isapropimpl, propproperty. + reflexivity. Qed. (** ** Equivalence of Dcuts with usual definitions *) Lemma isOneSided_Dcuts_bot : ∏ D, isOneSided D → Dcuts_def_bot (λ r, D (pr1 r)). Proof. intros D H r Dr q Hq. generalize (le_eqorltNonnegativeRationals _ _ Hq) ; clear Hq. apply sumofmaps ; intros H0. - rewrite H0. exact Dr. - rewrite ltNonnegativeRationals_correct in H0. generalize (pr2 (pr2 H) _ _ H0). apply hinhuniv, sumofmaps ; intros Dq. + exact Dq. + apply fromempty, Dq, Dr. Qed. Lemma isOneSided_Dcuts_open : ∏ D, isOneSided D → Dcuts_def_open (λ r, D (pr1 r)). Proof. intros D H r Dr. generalize ((pr1 (pr2 H)) (pr1 r) Dr). apply hinhfun. intros q. assert (Hq : 0 <= pr1 q). { apply istranshqleh with (pr1 r). { exact (pr2 r). } apply hqlthtoleh, (pr2 (pr2 q)). } exists (pr1 q,,Hq). split. - change (D (NonnegativeRationals_to_Rationals (pr1 q,,Hq))). exact (pr1 (pr2 q)). - rewrite ltNonnegativeRationals_correct. change (pr1 r < (NonnegativeRationals_to_Rationals (pr1 q,,Hq))). exact (pr2 (pr2 q)). Qed. Lemma isOneSided_translation : ∏ (D : hq → hProp) (c : hq), isOneSided D → isOneSided (λ q, D (q + c)). Proof. intros D c Hd. split ; split. - generalize (pr1 (pr1 Hd)). apply hinhfun. intros r. exists (pr1 r - c). unfold hqminus. rewrite hqplusassoc, hqlminus, hqplusr0. exact (pr2 r). - generalize (pr2 (pr1 Hd)). apply hinhfun. intros r. exists (pr1 r - c). unfold hqminus. rewrite hqplusassoc, hqlminus, hqplusr0. exact (pr2 r). - intros r D'r. generalize (pr1 (pr2 Hd) _ D'r). apply hinhfun. intros q. exists (pr1 q - c). split. + unfold hqminus. rewrite hqplusassoc, hqlminus, hqplusr0. exact (pr1 (pr2 q)). + apply hqlthandplusrinv with c. unfold hqminus. rewrite hqplusassoc, hqlminus, hqplusr0. exact (pr2 (pr2 q)). - intros r s Hrs. apply (pr2 (pr2 Hd)). apply hqlthandplusr, Hrs. Qed. Lemma isOneSided_Dcuts_corr : ∏ D, isOneSided D → Dcuts_def_corr (λ r, D (pr1 r)). Proof. intros D H c Hc. rewrite ltNonnegativeRationals_correct in Hc. generalize (pr2 (pr2 H) _ _ Hc). apply hinhuniv ; intros H0. apply coprodcomm in H0. revert H0 ; apply sumofmaps ; intros H0. { apply hinhpr, ii1, H0. } enough (Hq : ∃ q : NonnegativeRationals, D (pr1 q) × ¬ D (pr1 (q + c)%NRat)). { revert Hq. apply hinhfun, ii2. } generalize (pr2 (pr1 H)). apply hinhuniv. intros r. generalize (isarchhq (hqdiv (pr1 r) (hqdiv (pr1 c) 2%hq))). apply hinhuniv. intros n. assert (Hc' : hqdiv (pr1 c) 2 > 0). { apply hqmultgth0gth0. { exact Hc. } apply hqgthandmultlinv with 2. { exact hq2_gt0. } rewrite hqmultx0, hqisrinvmultinv. { exact hq1_gt0. } apply hqgth_hqneq, hq2_gt0. } assert (H1 : hqlth (pr1 r) (nattoring (pr1 n) * (hqdiv (pr1 c) 2))). { unfold hqlth in Hc. apply hqgthandmultrinv with (/ (hqdiv (pr1 c) 2)). - apply hqgthandmultlinv with (hqdiv (pr1 c) 2). + exact Hc'. + rewrite hqmultx0, hqisrinvmultinv. { exact hq1_gt0. } apply hqgth_hqneq, Hc'. - rewrite hqmultassoc, hqisrinvmultinv. + rewrite hqmultr1. unfold hqdiv in n. exact (pr2 n). + apply hqgth_hqneq, Hc'. } assert (Hn : ¬ D (nattoring (pr1 n) * hqdiv (pr1 c) 2)). { generalize (pr2 (pr2 H) _ _ H1). apply (hinhuniv (P := hneg _)), sumofmaps ; intro H2. - apply fromempty, (pr2 r), H2. - apply H2. } assert (H2 : ∏ (m : nat), nattoring m * hqdiv (pr1 c) 2 + pr1 c = nattoring (m + 2) * hqdiv (pr1 c) 2). { intros m. unfold nattoring. rewrite 2!(@nattorig_natmult hq). rewrite natmult_plus. apply maponpaths. simpl. unfold hqdiv. rewrite <- hqmult2r, hqmultassoc. rewrite hqislinvmultinv. - apply pathsinv0, hqmultr1. - apply hqgth_hqneq, hq2_gt0. } generalize (pr1 n) Hn. clear -H H0 Hc Hc' H2 ; intros n Hn. assert (Hm : D (nattoring O * hqdiv (pr1 c) 2)). { rewrite hqmult0x. exact H0. } destruct n. { apply fromempty, Hn, Hm. } rewrite <- (natplusl0 n), plus_n_Sm in Hn. revert Hm Hn. set (m := O). change (D (nattoring m * hqdiv (pr1 c) 2) → ¬ D (nattoring (m + S n) * hqdiv (pr1 c) 2) → ∃ q : NonnegativeRationals, D (pr1 q) × ¬ D (pr1 (q + c)%NRat)). generalize m ; clear m H0. revert D H. induction n as [ | n IHn] ; intros D H m Hm Hn. - apply hinhpr. use tpair. + use tpair. * apply (nattoring m * hqdiv (pr1 c) 2). * abstract (apply hq0lehandmult ; [ clear ; induction m ; [ apply isreflhqleh | unfold nattoring ; rewrite nattorigS ; apply hq0lehandplus ; [ exact hq1ge0 | exact IHm ]] | apply hqlthtoleh, Hc' ]). + simpl. split. * exact Hm. * change (¬ D ((nattoring m * hqdiv (pr1 c) 2) + (pr1 c))). intros H0. refine (factor_through_squash isapropempty _ _). 2: apply (pr2 (pr2 H) (nattoring (m + 1) * hqdiv (pr1 c) 2) (nattoring m * hqdiv (pr1 c) 2 + pr1 c)). ** apply sumofmaps. *** exact Hn. *** intros H1 ; apply H1, H0. ** rewrite H2. apply hqlthandmultr. *** exact Hc'. *** unfold nattoring. rewrite <- (plus_n_Sm m 1%nat). rewrite nattorigS, hqpluscomm. apply hqlthnsn. - refine (hinhuniv _ _). 2: apply (pr2 (pr2 H) (nattoring (m + 1) * hqdiv (pr1 c) 2) (nattoring (m + 2) * hqdiv (pr1 c) 2)). + apply sumofmaps ; intros Hm'. * apply IHn with (m + 1)%nat. ** exact H. ** exact Hm'. ** rewrite natplusassoc. exact Hn. * apply hinhpr. use tpair. ** use tpair. *** apply (nattoring m * hqdiv (pr1 c) 2). *** abstract (apply hq0lehandmult ; [ clear ; induction m ; [ apply isreflhqleh | unfold nattoring ; rewrite nattorigS ; apply hq0lehandplus ; [ exact hq1ge0 | exact IHm ]] | apply hqlthtoleh, Hc' ]). ** simpl. split. *** exact Hm. *** change (¬ D ((nattoring m * hqdiv (pr1 c) 2) + (pr1 c))). rewrite H2. exact Hm'. + apply hqlthandmultr. * exact Hc'. * unfold nattoring. rewrite <- (plus_n_Sm m 1%nat). rewrite nattorigS, hqpluscomm. apply hqlthnsn. Qed. Lemma isDcuts_OneSided : ∏ (D : NonnegativeRationals → hProp), Dcuts_def_bot D → Dcuts_def_open D → Dcuts_def_corr D → isOneSided (λ q : hq, sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, D (q,, Hq)) (hqgthorleh 0 q)). Proof. intros D Hbot Hopen Hcorr. split ; split. - apply hinhpr. exists (-(1)). induction (hqgthorleh 0 (- (1))) as [H | H]. + exact tt. + apply fromempty. refine (hqlehtoneghqgth _ _ _ _). * apply H. * apply hqgthandplusrinv with 1. rewrite hqlminus, hqplusl0. exact hq1_gt0. - generalize (Hcorr _ ispositive_oneNonnegativeRationals). apply hinhfun, sumofmaps ; intros H. + exists 1. induction (hqgthorleh 0 1) as [H0 | H0]. * apply fromempty. refine (hqgthtoneghqleh _ _ _ _). ** exact H0. ** exact hq1ge0. * assert (H1 : 1%NRat = (1 ,, H0)) by (apply subtypePath_prop ; reflexivity). rewrite H1 in H. exact H. + rename H into q. exists (pr1 (pr1 q) + 1). induction (hqgthorleh 0 (pr1 (pr1 q) + 1)) as [H0 | H0]. * apply fromempty. refine (hqgthtoneghqleh _ _ _ _). ** apply H0. ** apply hq0lehandplus. *** exact (pr2 (pr1 q)). *** exact hq1ge0. * assert (Hq1 : (pr1 q + 1)%NRat = (pr1 (pr1 q) + 1 ,, H0)) by (apply subtypePath_prop ; reflexivity). generalize (pr2 (pr2 q)) ; intro Hq. rewrite Hq1 in Hq. exact Hq. - intros r Dr. induction (hqgthorleh 0 r) as [Hr | Hr]. + set (q := hqlth_between _ _ Hr). apply hinhpr. exists (pr1 q). split. * induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq]. ** exact tt. ** apply fromempty. refine (hqlehtoneghqgth _ _ _ _). *** exact Hq. *** unfold hqlth in q. exact (pr2 (pr2 q)). * exact (pr1 (pr2 q)). + generalize (Hopen _ Dr). apply hinhfun. intros q. exists (pr1 (pr1 q)). induction (hqgthorleh 0 (pr1 (pr1 q))) as [Hq | Hq]. * apply fromempty. refine (hqgthtoneghqleh _ _ _ _). ** apply Hq. ** exact (pr2 (pr1 q)). * split. ** assert (Hq1 : pr1 q = (pr1 (pr1 q) ,, Hq)) by (apply subtypePath_prop ; reflexivity). generalize (pr1 (pr2 q)) ; intro Hq'. rewrite Hq1 in Hq'. exact Hq'. ** generalize (pr2 (pr2 q)) ; intro Hq'. rewrite ltNonnegativeRationals_correct in Hq'. exact Hq'. -intros r q Hrq. induction (hqgthorleh 0 r) as [Hr | Hr]. { apply hinhpr, ii1, tt. } induction (hqgthorleh 0 q) as [Hq | Hq]. + apply fromempty. refine (hqlehtoneghqgth _ _ _ _). * apply Hr. * apply istranshqgth with q. ** exact Hq. ** unfold hqlth in Hrq. exact Hrq. + apply (Dcuts_locatedness (D,,Hbot,,Hopen,,Hcorr)). rewrite ltNonnegativeRationals_correct. exact Hrq. Qed. Lemma weqOneSidedDcuts : weq (∑ S : hq → hProp, isOneSided S × ∏ q : hq, q < 0 → S q) Dcuts. Proof. set (f := (λ (D : ∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)), make_Dcuts (λ r : NonnegativeRationals, pr1 D (pr1 r)) (isOneSided_Dcuts_bot (pr1 D) (pr1 (pr2 D))) (isOneSided_Dcuts_open (pr1 D) (pr1 (pr2 D))) (isOneSided_Dcuts_corr (pr1 D) (pr1 (pr2 D)))) : (∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)) → Dcuts). assert (Hg : ∏ (D : Dcuts) (q : hq), q < 0 → sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, pr1 D (q,, Hq)) (hqgthorleh 0 q)). { intros D q Hq. induction (hqgthorleh 0 q) as [Hq' | Hq']. { exact tt. } apply fromempty. refine (hqlehtoneghqgth _ _ _ _). - apply Hq'. - unfold hqlth in Hq. exact Hq. } set (g := (λ D : Dcuts, (λ q : hq, sumofmaps (λ _ : 0 > q, htrue) (λ Hq : 0 <= q, pr1 D (q,, Hq)) (hqgthorleh 0 q)),, isDcuts_OneSided (pr1 D) (is_Dcuts_bot D) (is_Dcuts_open D) (is_Dcuts_corr D),, Hg D) : Dcuts → ∑ S : hq → hProp, isOneSided S × (∏ q : hq, q < 0 → S q)). apply (weq_iso f g). - intros D. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). + apply isapropdirprod. * apply isapropdirprod. ** apply propproperty. ** apply isapropdirprod. *** apply impred_isaprop ; intro r. apply isapropimpl, propproperty. *** apply impred_isaprop ; intro r. apply impred_isaprop ; intro s. apply isapropimpl, propproperty. * apply impred_isaprop ; intro q. apply isapropimpl, propproperty. + apply funextfun ; intros q. apply hPropUnivalence. * change (sumofmaps (λ _ : 0 > q, htrue) (λ _ : ¬ (0 > q), pr1 D q) (hqgthorleh 0 q) → pr1 D q). induction (hqgthorleh 0 q) as [Hq | Hq]. ** intros _. apply (pr2 (pr2 D)). exact Hq. ** intros H ; apply H. * change (pr1 D q → sumofmaps (λ _ : 0 > q, htrue) (λ _ : ¬ (0 > q), pr1 D q) (hqgthorleh 0 q)). intros Dq. induction (hqgthorleh 0 q) as [Hq | Hq]. ** exact tt. ** exact Dq. - intros D. apply subtypePath_prop. apply funextfun ; intros q. apply hPropUnivalence. + change (sumofmaps (λ _ : 0 > pr1 q, htrue) (λ Hq : ¬ (0 > pr1 q), pr1 D (pr1 q,, Hq)) (hqgthorleh 0 (pr1 q)) → pr1 D q). induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq]. * apply fromempty. refine (hqlehtoneghqgth _ _ _ _). ** exact (pr2 q). ** exact Hq. * intros H. assert (Hq1 : q = (pr1 q,, Hq)) by (apply subtypePath_prop ; reflexivity). rewrite Hq1 ; exact H. + change (pr1 D q → sumofmaps (λ _ : 0 > pr1 q, htrue) (λ Hq : ¬ (0 > pr1 q), pr1 D (pr1 q,, Hq)) (hqgthorleh 0 (pr1 q))). intros Dq. induction (hqgthorleh 0 (pr1 q)) as [Hq | Hq]. * apply fromempty. refine (hqlehtoneghqgth _ _ _ _). ** exact (pr2 q). ** exact Hq. * assert (Hq1 : q = (pr1 q,, Hq)) by (apply subtypePath_prop ; reflexivity). rewrite Hq1 in Dq ; exact Dq. Qed. UniMath-20231010/UniMath/RealNumbers/Fields.v000066400000000000000000000021651451125700300204740ustar00rootroot00000000000000(** * Additional theorems about fields *) Require Export UniMath.Algebra.Domains_and_Fields. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Lemma isapropmultinvpair : ∏ (X : rig) (x : X), isaprop (multinvpair X x). Proof. intros X x. apply isapropinvpair. Qed. (** ** Projections for [fld] *) Section fld_proj. Context {X : fld}. Definition zero_fld : X := 0%ring. Definition one_fld : X := 1%ring. Definition plus_fld (x y : X) : X := (x + y)%ring. Definition opp_fld (x : X) : X := (- x)%ring. Definition minus_fld (x y : X) : X := (x - y)%ring. Definition mult_fld (x y : X) : X := (x * y)%ring. Definition inv_fld (x : X) : X. Proof. apply sumofmaps with (3 := fldchoice x) ; intro x'. - exact (pr1 x'). - exact x. Defined. Definition div_fld (x y : X) : X := mult_fld x (inv_fld y). End fld_proj. (** ** [fld] and the other structures *) Section fld_struct. Context (X : fld). Definition fld_to_gr1 : gr := abgrtogr (pr1fld X). Definition fld_to_monoid1 : monoid := grtomonoid fld_to_gr1. Definition fld_to_monoid2 : monoid := ringmultmonoid (pr1fld X). End fld_struct. UniMath-20231010/UniMath/RealNumbers/NonnegativeRationals.v000066400000000000000000001520041451125700300234160ustar00rootroot00000000000000(** Catherine Lelay. Sep. 2015 *) Unset Kernel Term Sharing. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.Orders. Require Import UniMath.RealNumbers.Sets. Require Import UniMath.RealNumbers.Fields. Require Export UniMath.Algebra.DivisionRig. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.RealNumbers.Prelim. Opaque hq. Local Open Scope hq_scope. (** * Definition of non-negative rational numbers *) Definition hnnq_set := carrier_subset (hqleh 0). Local Definition hnnq_set_to_hq (r : hnnq_set) : hq := pr1 r. Local Definition hq_to_hnnq_set (r : hq) (Hr : hqleh 0 r) : hnnq_set := r ,, Hr. Local Definition hnnq_zero: hnnq_set := hq_to_hnnq_set 0 (isreflhqleh 0). Local Definition hnnq_one: hnnq_set := hq_to_hnnq_set 1 (hqlthtoleh 0 1 hq1_gt0). Local Definition hnnq_plus: binop hnnq_set := λ x y : hnnq_set, hq_to_hnnq_set (pr1 x + pr1 y) (hq0lehandplus _ _ (pr2 x) (pr2 y)). Local Definition hnnq_minus: binop hnnq_set. Proof. intros x y. induction (hqgthorleh (pr1 x) (pr1 y)) as [H | _]. - exact (hq_to_hnnq_set (pr1 x - pr1 y) (hq0leminus _ _ (hqlthtoleh _ _ H))). - exact hnnq_zero. Defined. Local Definition hnnq_mult: binop hnnq_set := λ x y : hnnq_set, hq_to_hnnq_set (pr1 x * pr1 y) (hqmultgeh0geh0 (pr2 x) (pr2 y)). Local Definition hnnq_inv: unop hnnq_set. Proof. intros x. induction (hqlehchoice 0 (pr1 x) (pr2 x)) as [Hx0 | _]. - exact (hq_to_hnnq_set (/ pr1 x) (hqlthtoleh 0 (/ pr1 x) (hqinv_gt0 (pr1 x) Hx0))). - exact x. Defined. Local Definition hnnq_div : binop hnnq_set := λ x y : hnnq_set, hnnq_mult x (hnnq_inv y). (** ** Equality and order on non-negative rational numbers *) Local Definition hnnq_le : hrel hnnq_set := resrel hqleh (hqleh 0). Local Lemma ispreorder_hnnq_le : ispreorder hnnq_le. Proof. split. - intros x y z. now apply istranshqleh. - intros x. now apply isreflhqleh. Qed. Local Definition hnnq_ge : hrel hnnq_set := resrel hqgeh (hqleh 0). Local Lemma ispreorder_hnnq_ge : ispreorder hnnq_ge. Proof. set (H := ispreorder_hnnq_le). split. - intros x y z Hxy Hyz. now apply (pr1 H) with y. - intros x. now apply (pr2 H). Qed. Local Definition hnnq_lt : hrel hnnq_set := resrel hqlth (hqleh 0). Local Lemma isStrongOrder_hnnq_lt : isStrongOrder hnnq_lt. Proof. repeat split. - intros x y z. now apply istranshqlth. - intros x y z Hxz. generalize (hqlthorgeh (pr1 x) (pr1 y)) ; apply sumofmaps ; intros Hxy. + apply hinhpr ; left. exact Hxy. + apply hinhpr ; right. apply hqlehlthtrans with (pr1 x). * exact Hxy. * exact Hxz. - intros x. now apply isirreflhqlth. Qed. Local Definition hnnq_gt : hrel hnnq_set := resrel hqgth (hqleh 0). Local Lemma isStrongOrder_hnnq_gt : isStrongOrder hnnq_gt. Proof. set (H := isStrongOrder_reverse _ isStrongOrder_hnnq_lt). repeat split. - intros x y z. apply (istrans_isStrongOrder H). - intros x y z. apply (iscotrans_isStrongOrder H). - intros x. apply (isirrefl_isStrongOrder H). Qed. Local Lemma isEffectiveOrder_hnnq : isEffectiveOrder hnnq_le hnnq_lt. Proof. split ; [ split | repeat split ]. - exact ispreorder_hnnq_le. - exact isStrongOrder_hnnq_lt. - intros. assumption. - intros. assumption. - intros x y z. now apply hqlthlehtrans. - intros x y z. now apply hqlehlthtrans. Qed. (** ** hnnq is a half field *) Local Lemma iscomm_hnnq_plus: iscomm hnnq_plus. Proof. intros x y. apply subtypePath_prop. now apply hqpluscomm. Qed. Local Lemma isassoc_hnnq_plus : isassoc hnnq_plus. Proof. intros x y z. apply subtypePath_prop. now apply hqplusassoc. Qed. Local Lemma islunit_hnnq_zero_plus: islunit hnnq_plus hnnq_zero. Proof. intros x. apply subtypePath_prop. now apply hqplusl0. Qed. Local Lemma isrunit_hnnq_zero_plus: isrunit hnnq_plus hnnq_zero. Proof. intros x. rewrite iscomm_hnnq_plus. now apply islunit_hnnq_zero_plus. Qed. Local Lemma iscomm_hnnq_mult: iscomm hnnq_mult. Proof. intros x y. apply subtypePath_prop. now apply hqmultcomm. Qed. Local Lemma isassoc_hnnq_mult: isassoc hnnq_mult. Proof. intros x y z. apply subtypePath_prop. now apply hqmultassoc. Qed. Local Lemma islunit_hnnq_one_mult: islunit hnnq_mult hnnq_one. Proof. intros x. apply subtypePath_prop. now apply hqmultl1. Qed. Local Lemma isrunit_hnnq_one_mult: isrunit hnnq_mult hnnq_one. Proof. intros x. rewrite iscomm_hnnq_mult. now apply islunit_hnnq_one_mult. Qed. Local Lemma islinv'_hnnq_inv: islinv' hnnq_one hnnq_mult (hnnq_lt hnnq_zero) (λ x : carrier_subset (hnnq_lt hnnq_zero), hnnq_inv (pr1 x)). Proof. intros x Hx0. unfold hnnq_inv. change (hqlehchoice 0 (pr1 (pr1 (x,, Hx0))) (pr2 (pr1 (x,, Hx0)))) with (hqlehchoice 0 (pr1 x) (pr2 x)). generalize (hqlehchoice 0 (pr1 x) (pr2 x)). apply coprod_rect ; intros Hx0'. - apply subtypePath_prop. apply hqislinvmultinv. now apply (hqgth_hqneq (pr1 x) 0), Hx0'. - apply fromempty. generalize (pathsinv0 Hx0'). apply hqgth_hqneq, Hx0. Qed. Local Lemma isrinv'_hnnq_inv: isrinv' hnnq_one hnnq_mult (hnnq_lt hnnq_zero) (λ x : carrier_subset (hnnq_lt hnnq_zero), hnnq_inv (pr1 x)). Proof. intros x Hx. rewrite iscomm_hnnq_mult. now apply islinv'_hnnq_inv. Qed. Local Lemma isldistr_hnnq_plus_mult: isldistr hnnq_plus hnnq_mult. Proof. intros x y z. apply subtypePath_prop. now apply hqldistr. Qed. Local Lemma isrdistr_hnnq_plus_mult: isrdistr hnnq_plus hnnq_mult. Proof. intros x y z. rewrite !(iscomm_hnnq_mult _ z). now apply isldistr_hnnq_plus_mult. Qed. Local Definition isabmonoidop_hnnq_plus: isabmonoidop hnnq_plus. Proof. repeat split. - exact isassoc_hnnq_plus. - exists hnnq_zero ; split. + exact islunit_hnnq_zero_plus. + exact isrunit_hnnq_zero_plus. - exact iscomm_hnnq_plus. Defined. Local Definition ismonoidop_hnnq_mult : ismonoidop hnnq_mult. Proof. split. - exact isassoc_hnnq_mult. - exists hnnq_one ; split. + exact islunit_hnnq_one_mult. + exact isrunit_hnnq_one_mult. Defined. Local Definition commrig_hnnq: commrig. Proof. exists (hnnq_set,,hnnq_plus,,hnnq_mult). repeat split. - exists (isabmonoidop_hnnq_plus,,ismonoidop_hnnq_mult) ; split. + intro x. apply subtypePath_prop. apply hqmult0x. + intro x. apply subtypePath_prop. apply hqmultx0. - exact isldistr_hnnq_plus_mult. - exact isrdistr_hnnq_plus_mult. - exact iscomm_hnnq_mult. Defined. Local Definition CommDivRig_hnnq: CommDivRig. Proof. exists commrig_hnnq. split. - intro H. apply base_paths in H. apply hqgth_hqneq in H. + exact H. + exact hq1_gt0. - intros x Hx. assert (Hx' : hnnq_lt hnnq_zero x). { apply neghqlehtogth. intro Hx0 ; apply Hx. apply subtypePath. - now intro ;apply pr2. - apply isantisymmhqleh. + apply Hx0. + apply (pr2 x). } exists (hnnq_inv x) ; split. + now apply (islinv'_hnnq_inv x Hx'). + now apply (isrinv'_hnnq_inv x Hx'). Defined. (** * Exportable definitions and theorems *) Definition NonnegativeRationals : CommDivRig := CommDivRig_hnnq. Definition NonnegativeRationals_to_Rationals : NonnegativeRationals → hq := pr1. Definition Rationals_to_NonnegativeRationals (r : hq) (Hr : hqleh 0%hq r) : NonnegativeRationals := tpair _ r Hr. Declare Scope NRat_scope. Delimit Scope NRat_scope with NRat. (** ** Definitions *) Definition NonnegativeRationals_EffectivelyOrderedSet := @pairEffectivelyOrderedSet NonnegativeRationals (pairEffectiveOrder _ _ isEffectiveOrder_hnnq). Definition leNonnegativeRationals : po NonnegativeRationals := EOle (X := NonnegativeRationals_EffectivelyOrderedSet). Definition geNonnegativeRationals : po NonnegativeRationals := EOge (X := NonnegativeRationals_EffectivelyOrderedSet). Definition ltNonnegativeRationals : StrongOrder NonnegativeRationals := EOlt (X := NonnegativeRationals_EffectivelyOrderedSet). Definition gtNonnegativeRationals : StrongOrder NonnegativeRationals := EOgt (X := NonnegativeRationals_EffectivelyOrderedSet). Notation "x <= y" := (EOle_rel (X := NonnegativeRationals_EffectivelyOrderedSet) x y) (at level 70, no associativity) : NRat_scope. Notation "x >= y" := (EOge_rel (X := NonnegativeRationals_EffectivelyOrderedSet) x y) (at level 70, no associativity) : NRat_scope. Notation "x < y" := (EOlt_rel (X := NonnegativeRationals_EffectivelyOrderedSet) x y) (at level 70, no associativity) : NRat_scope. Notation "x > y" := (EOgt_rel (X := NonnegativeRationals_EffectivelyOrderedSet) x y) (at level 70, no associativity) : NRat_scope. Definition zeroNonnegativeRationals : NonnegativeRationals := hnnq_zero. Definition oneNonnegativeRationals : NonnegativeRationals := hnnq_one. Definition plusNonnegativeRationals (x y : NonnegativeRationals) : NonnegativeRationals := hnnq_plus x y. Definition minusNonnegativeRationals (x y : NonnegativeRationals) : NonnegativeRationals := hnnq_minus x y. Definition multNonnegativeRationals (x y : NonnegativeRationals) : NonnegativeRationals := hnnq_mult x y. Definition invNonnegativeRationals (x : NonnegativeRationals) : NonnegativeRationals := hnnq_inv x. Definition divNonnegativeRationals (x y : NonnegativeRationals) : NonnegativeRationals := multNonnegativeRationals x (invNonnegativeRationals y). Definition twoNonnegativeRationals : NonnegativeRationals := Rationals_to_NonnegativeRationals 2 (hqlthtoleh _ _ hq2_gt0). Definition nat_to_NonnegativeRationals (n : nat) : NonnegativeRationals := Rationals_to_NonnegativeRationals (hztohq (nattohz n)) (hztohqandleh 0%hz _ (nattohzandleh O n (natleh0n n))). Notation "0" := zeroNonnegativeRationals : NRat_scope. Notation "1" := oneNonnegativeRationals : NRat_scope. Notation "2" := twoNonnegativeRationals : NRat_scope. Notation "x + y" := (plusNonnegativeRationals x y) (at level 50, left associativity) : NRat_scope. Notation "x - y" := (minusNonnegativeRationals x y) (at level 50, left associativity) : NRat_scope. Notation "x * y" := (multNonnegativeRationals x y) (at level 40, left associativity) : NRat_scope. Notation "/ x" := (invNonnegativeRationals x) (at level 35, right associativity) : NRat_scope. Notation "x / y" := (divNonnegativeRationals x y) (at level 40, left associativity) : NRat_scope. Local Open Scope NRat_scope. (** *** Correctness of definitions *) Lemma zeroNonnegativeRationals_correct : 0 = Rationals_to_NonnegativeRationals 0%hq (isreflhqleh 0%hq). Proof. apply subtypePath_prop. reflexivity. Qed. Lemma oneNonnegativeRationals_correct : 1 = Rationals_to_NonnegativeRationals 1%hq hq1ge0. Proof. apply subtypePath_prop. reflexivity. Qed. Lemma twoNonnegativeRationals_correct : 2 = Rationals_to_NonnegativeRationals 2%hq (hqlthtoleh _ _ hq2_gt0). Proof. apply subtypePath_prop. reflexivity. Qed. Lemma plusNonnegativeRationals_correct : ∏ (x y : NonnegativeRationals), x + y = Rationals_to_NonnegativeRationals (pr1 x + pr1 y)%hq (hq0lehandplus _ _ (pr2 x) (pr2 y)). Proof. intros x y. apply subtypePath_prop. reflexivity. Qed. Lemma minusNonnegativeRationals_correct : ∏ (x y : NonnegativeRationals) (Hminus : y <= x), x - y = Rationals_to_NonnegativeRationals (pr1 x - pr1 y)%hq (hq0leminus _ _ Hminus). Proof. intros x y H. apply subtypePath_prop. unfold minusNonnegativeRationals, hnnq_minus. generalize (hqgthorleh (pr1 x) (pr1 y)). apply coprod_rect ; [intros Hgt | intros Hle]. - reflexivity. - generalize (isantisymmhqleh _ _ Hle H) ; intros Heq. rewrite coprod_rect_compute_2. generalize (hq0leminus (pr1 y) (pr1 x) H). rewrite Heq, hqrminus. intros H0. reflexivity. Qed. Lemma multNonnegativeRationals_correct : ∏ (x y : NonnegativeRationals), x * y = Rationals_to_NonnegativeRationals (pr1 x * pr1 y)%hq ( hq0lehandmult _ _ (pr2 x) (pr2 y)). Proof. intros x y. apply subtypePath_prop. reflexivity. Qed. Lemma invNonnegativeRationals_correct : ∏ (x : NonnegativeRationals) (Hx : 0 < x), / x = Rationals_to_NonnegativeRationals (/ pr1 x)%hq (hqlthtoleh _ _ (hqinv_gt0 _ Hx)). Proof. intros x Hx0. apply subtypePath_prop. unfold invNonnegativeRationals, hnnq_inv. generalize (hqlehchoice 0%hq (pr1 x) (pr2 x)). apply coprod_rect ; [intros Hlt | intros Heq]. - reflexivity. - apply fromempty ; generalize Hx0. change x with (pr1 x,,pr2 x). generalize (pr2 x). rewrite <- Heq ; intro. exact (isirreflhqlth 0%hq). Qed. Lemma leNonnegativeRationals_correct : ∏ x y : NonnegativeRationals, (x <= y) = (pr1 x <= pr1 y)%hq. Proof. intros x y. reflexivity. Qed. Lemma geNonnegativeRationals_correct : ∏ x y : NonnegativeRationals, (x >= y) = (pr1 x >= pr1 y)%hq. Proof. intros x y. reflexivity. Qed. Lemma ltNonnegativeRationals_correct : ∏ x y : NonnegativeRationals, (x < y) = (pr1 x < pr1 y)%hq. Proof. intros x y. reflexivity. Qed. Lemma gtNonnegativeRationals_correct : ∏ x y : NonnegativeRationals, (x > y) = (pr1 x > pr1 y)%hq. Proof. intros x y. reflexivity. Qed. (** ** Theorems about order *) (** *** Decidability *) Lemma isdeceq_NonnegativeRationals : ∏ x y : NonnegativeRationals, (x = y) ⨿ (x != y). Proof. intros x y. generalize (isdeceqhq (pr1 x) (pr1 y)) ; apply sumofmaps ; intros H. - left. apply subtypePath_prop. exact H. - right. intros H0 ; apply H. revert H0. apply base_paths. Qed. Lemma isdecrel_leNonnegativeRationals : ∏ x y : NonnegativeRationals, (x <= y) ⨿ ¬ (x <= y). Proof. intros x y. apply isdecrelhqleh. Qed. Lemma isdecrel_ltNonnegativeRationals : ∏ x y : NonnegativeRationals, (x < y) ⨿ ¬ (x < y). Proof. intros x y. apply isdecrelhqlth. Qed. Lemma le_eqorltNonnegativeRationals : ∏ x y : NonnegativeRationals, x <= y -> (x = y) ⨿ (x < y). Proof. intros x y Hle. generalize (hqlehchoice (pr1 x) (pr1 y) Hle) ; apply sumofmaps ; [intros Hlt | intros Heq]. - right ; exact Hlt. - left. now apply subtypePath_prop, Heq. Qed. Lemma noteq_ltorgtNonnegativeRationals : ∏ x y : NonnegativeRationals, x != y -> (x < y) ⨿ (x > y). Proof. intros x y Hneq. generalize (isdecrel_leNonnegativeRationals x y) ; apply sumofmaps ; [intros Hle|intros Hlt]. - left. apply le_eqorltNonnegativeRationals in Hle. revert Hle ; apply sumofmaps ; [intros Heq | intros Hlt]. + now apply fromempty, Hneq, Heq. + exact Hlt. - right. apply neghqgehtolth. exact Hlt. Qed. Lemma eq0orgt0NonnegativeRationals : ∏ x : NonnegativeRationals, (x = 0) ⨿ (0 < x). Proof. intros x. generalize (le_eqorltNonnegativeRationals 0 x (pr2 x)) ; apply sumofmaps ; intros Hx. - rewrite Hx ; now left. - right ; exact Hx. Qed. (** *** Basic theorems about order *) Definition lt_leNonnegativeRationals : ∏ x y : NonnegativeRationals, x < y -> x <= y := EOlt_le (X := NonnegativeRationals_EffectivelyOrderedSet). Definition isrefl_leNonnegativeRationals: ∏ x : NonnegativeRationals, x <= x := isrefl_EOle (X := NonnegativeRationals_EffectivelyOrderedSet). Definition istrans_leNonnegativeRationals: ∏ x y z : NonnegativeRationals, x <= y -> y <= z -> x <= z := istrans_EOle (X := NonnegativeRationals_EffectivelyOrderedSet). Definition isirrefl_ltNonnegativeRationals: ∏ x : NonnegativeRationals, ¬ (x < x) := isirrefl_EOlt (X := NonnegativeRationals_EffectivelyOrderedSet). Definition istrans_ltNonnegativeRationals : ∏ x y z : NonnegativeRationals, x < y -> y < z -> x < z := istrans_EOlt (X := NonnegativeRationals_EffectivelyOrderedSet). Definition istrans_lt_le_ltNonnegativeRationals: ∏ x y z : NonnegativeRationals, x < y -> y <= z -> x < z := istrans_EOlt_le (X := NonnegativeRationals_EffectivelyOrderedSet). Definition istrans_le_lt_ltNonnegativeRationals : ∏ x y z : NonnegativeRationals, x <= y -> y < z -> x < z := istrans_EOle_lt (X := NonnegativeRationals_EffectivelyOrderedSet). Lemma isantisymm_leNonnegativeRationals : ∏ x y : NonnegativeRationals, x <= y -> y <= x -> x = y. Proof. intros x y Hle Hge. apply subtypePath_prop. now apply isantisymmhqleh. Qed. Definition ge_leNonnegativeRationals: ∏ x y : NonnegativeRationals, (x >= y) <-> (y <= x) := EOge_le (X := NonnegativeRationals_EffectivelyOrderedSet). Definition lt_gtNonnegativeRationals: ∏ x y : NonnegativeRationals, (x > y) <-> (y < x) := EOgt_lt (X := NonnegativeRationals_EffectivelyOrderedSet). Definition notlt_geNonnegativeRationals: ∏ x y : NonnegativeRationals, (¬ (x < y)) <-> (y <= x) := not_EOlt_le (X := NonnegativeRationals_EffectivelyOrderedSet). Lemma notge_ltNonnegativeRationals : ∏ x y : NonnegativeRationals, (¬ (y <= x)) <-> (x < y). Proof. intros x y. split. - now apply neghqgehtolth. - now apply hqlthtoneghqgeh. Qed. Definition ltNonnegativeRationals_noteq : ∏ x y, x < y -> x != y := EOlt_noteq (X := NonnegativeRationals_EffectivelyOrderedSet). Definition gtNonnegativeRationals_noteq : ∏ x y, x > y -> x != y := EOgt_noteq (X := NonnegativeRationals_EffectivelyOrderedSet). Lemma between_ltNonnegativeRationals : ∏ x y : NonnegativeRationals, x < y -> ∑ t : NonnegativeRationals, x < t × t < y. Proof. intros x y H. set (z := hqlth_between (pr1 x) (pr1 y) H). assert (Hz : hqleh 0%hq (pr1 z)). { apply istranshqleh with (pr1 x). { now apply (pr2 x). } apply (hqlthtoleh (pr1 x) (pr1 z)), (pr1 (pr2 z)). } exists (hq_to_hnnq_set _ Hz). exact (pr2 z). Qed. (** *** Order and 0 *) Lemma isnonnegative_NonnegativeRationals : ∏ x : NonnegativeRationals , 0 <= x. Proof. intros x. apply (pr2 x). Qed. Lemma isnonnegative_NonnegativeRationals' : ∏ x : NonnegativeRationals , ¬ (x < 0). Proof. intros x. apply (pr2 x). Qed. Lemma NonnegativeRationals_eq0_le0 : ∏ r : NonnegativeRationals, (r <= 0) -> (r = 0). Proof. intros r Hr0. apply subtypePath_prop. apply isantisymmhqleh. - apply Hr0. - apply (pr2 r). Qed. Lemma NonnegativeRationals_neq0_gt0 : ∏ r : NonnegativeRationals, (r != 0) -> (0 < r). Proof. intros r Hr0. apply neghqlehtogth. intro H ; apply Hr0. now apply NonnegativeRationals_eq0_le0. Qed. Lemma ispositive_oneNonnegativeRationals : 0 < 1. Proof. exact hq1_gt0. Qed. Lemma ispositive_twoNonnegativeRationals : 0 < 2. Proof. exact hq2_gt0. Qed. Lemma one_lt_twoNonnegativeRationals : 1 < 2. Proof. change (1 < 2)%hq. rewrite <- (hqplusr0 1%hq), hq2eq1plus1. apply hqlthandplusl. exact hq1_gt0. Qed. (** ** Theorems about algebra *) (** *** Addition *) (** Rewritings *) Definition isassoc_plusNonnegativeRationals: ∏ x y z : NonnegativeRationals, x + y + z = x + (y + z) := CommDivRig_isassoc_plus. Definition islunit_zeroNonnegativeRationals: ∏ r : NonnegativeRationals, 0 + r = r := CommDivRig_islunit_zero. Definition isrunit_zeroNonnegativeRationals: ∏ r : NonnegativeRationals, r + 0 = r := CommDivRig_isrunit_zero. Definition iscomm_plusNonnegativeRationals: ∏ x y : NonnegativeRationals, x + y = y + x := CommDivRig_iscomm_plus. (** Order *) Lemma plusNonnegativeRationals_ltcompat_r : ∏ x y z : NonnegativeRationals, (y < z) <-> (y + x < z + x). Proof. intros x y z. split. - now apply hqlthandplusr. - now apply hqlthandplusrinv. Qed. Lemma plusNonnegativeRationals_ltcompat_l : ∏ x y z : NonnegativeRationals, (y < z) <-> (x + y < x + z). Proof. intros x y z. rewrite !(iscomm_plusNonnegativeRationals x). now apply plusNonnegativeRationals_ltcompat_r. Qed. Lemma plusNonnegativeRationals_lecompat_r : ∏ r q n : NonnegativeRationals, (q <= n) <-> (q + r <= n + r). Proof. intros r q n. split. - now apply hqlehandplusr. - now apply hqlehandplusrinv. Qed. Lemma plusNonnegativeRationals_lecompat_l : ∏ r q n : NonnegativeRationals, (q <= n) <-> (r + q <= r + n). Proof. intros r q n. rewrite ! (iscomm_plusNonnegativeRationals r). now apply plusNonnegativeRationals_lecompat_r. Qed. Lemma plusNonnegativeRationals_eqcompat_l: ∏ k x y : NonnegativeRationals, (k + x = k + y) -> (x = y). Proof. intros k x y H. apply isantisymm_leNonnegativeRationals ; apply_pr2 (plusNonnegativeRationals_lecompat_l k) ; rewrite H ; apply isrefl_leNonnegativeRationals. Qed. Lemma plusNonnegativeRationals_eqcompat_r: ∏ k x y : NonnegativeRationals, (x + k = y + k) -> (x = y). Proof. intros k x y. rewrite !(iscomm_plusNonnegativeRationals _ k). now apply plusNonnegativeRationals_eqcompat_l. Qed. Lemma plusNonnegativeRationals_ltcompat : ∏ x x' y y' : NonnegativeRationals, x < x' -> y < y' -> x + y < x' + y'. Proof. intros x x' y y' Hx Hy. apply istrans_ltNonnegativeRationals with (x + y'). - now apply hqlthandplusl, Hy. - now apply hqlthandplusr, Hx. Qed. Lemma plusNonnegativeRationals_le_lt_ltcompat : ∏ x x' y y' : NonnegativeRationals, x <= x' -> y < y' -> x + y < x' + y'. Proof. intros x x' y y' Hx Hy. apply istrans_lt_le_ltNonnegativeRationals with (x + y'). - now apply hqlthandplusl, Hy. - now apply hqlehandplusr, Hx. Qed. Lemma plusNonnegativeRationals_lt_le_ltcompat : ∏ x x' y y' : NonnegativeRationals, x < x' -> y <= y' -> x + y < x' + y'. Proof. intros x x' y y' Hx Hy. apply istrans_le_lt_ltNonnegativeRationals with (x + y'). - now apply hqlehandplusl, Hy. - now apply hqlthandplusr, Hx. Qed. Lemma plusNonnegativeRationals_le_r : ∏ r q : NonnegativeRationals, r <= r + q. Proof. intros r q. pattern r at 1. rewrite <- (isrunit_zeroNonnegativeRationals r). apply hqlehandplusl. apply (pr2 q). Qed. Lemma plusNonnegativeRationals_le_l : ∏ r q : NonnegativeRationals, r <= q + r. Proof. intros r q. rewrite iscomm_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. Qed. Lemma ispositive_plusNonnegativeRationals_l : ∏ x y : NonnegativeRationals, 0 < x -> 0 < x + y. Proof. intros x y Hx. apply istrans_lt_le_ltNonnegativeRationals with x. - exact Hx. - now apply plusNonnegativeRationals_le_r. Qed. Lemma ispositive_plusNonnegativeRationals_r : ∏ x y : NonnegativeRationals, 0 < y -> 0 < x + y. Proof. intros x y Hy. apply istrans_lt_le_ltNonnegativeRationals with y. - exact Hy. - now apply plusNonnegativeRationals_le_l. Qed. Lemma plusNonnegativeRationals_lt_r : ∏ r q : NonnegativeRationals, 0 < q -> r < r + q. Proof. intros x y Hy0. pattern x at 1. rewrite <- (isrunit_zeroNonnegativeRationals x). apply plusNonnegativeRationals_ltcompat_l. exact Hy0. Qed. Lemma plusNonnegativeRationals_lt_l : ∏ r q : NonnegativeRationals, 0 < r -> q < r + q. Proof. intros x y. rewrite iscomm_plusNonnegativeRationals. now apply plusNonnegativeRationals_lt_r. Qed. (** *** Substraction *) (** Rewriting *) Lemma minusNonnegativeRationals_eq_zero: ∏ x y : NonnegativeRationals, x <= y -> x - y = 0. Proof. intros x y Hle. unfold minusNonnegativeRationals, hnnq_minus. generalize (hqgthorleh (pr1 x) (pr1 y)). apply coprod_rect ; intros H. - apply fromempty. exact (Hle H). - reflexivity. Qed. Lemma minusNonnegativeRationals_plus_r : ∏ r q : NonnegativeRationals, r <= q -> (q - r) + r = q. Proof. intros r q H. unfold minusNonnegativeRationals, hnnq_minus. generalize (hqgthorleh (pr1 q) (pr1 r)). apply coprod_rect ; intros H'. - rewrite coprod_rect_compute_1. apply subtypePath_prop. unfold hqminus. pattern r at 4. simpl. generalize (pr1 r) (pr1 q) (pr2 r) (hq0leminus (pr1 r) (pr1 q) (hqlthtoleh (pr1 r) (pr1 q) H')) ; intros r' q' Hr Hrq. now rewrite hqplusassoc, hqlminus, hqplusr0. - rewrite coprod_rect_compute_2. apply subtypePath_prop. generalize (isantisymmhqleh _ _ H H'). simpl. generalize (pr1 r) (pr2 r) (pr1 q) ; intros r' Hr' q' Heq. now rewrite hqplusl0. Qed. Lemma plusNonnegativeRationals_minus_r : ∏ q r : NonnegativeRationals, (r + q) - q = r. Proof. intros q r. change r with (pr1 r,,pr2 r). generalize (pr1 r) (pr2 r) (pr1 q) (pr2 q) ; intros r' Hr q' Hq. rewrite (minusNonnegativeRationals_correct _ _ (plusNonnegativeRationals_le_l _ _)). apply subtypePath_prop. simpl pr1. unfold hqminus. rewrite hqplusassoc. rewrite (hqpluscomm (pr1 q)). rewrite hqlminus. rewrite hqplusr0. reflexivity. Qed. Lemma plusNonnegativeRationals_minus_l : ∏ q r : NonnegativeRationals, (q + r) - q = r. Proof. intros q r. rewrite iscomm_plusNonnegativeRationals. now apply plusNonnegativeRationals_minus_r. Qed. Lemma minusNonnegativeRationals_correct_l : ∏ x y z : NonnegativeRationals, x = y + z -> z = x - y. Proof. intros x y z ->. now rewrite plusNonnegativeRationals_minus_l. Qed. Lemma minusNonnegativeRationals_correct_r : ∏ x y z : NonnegativeRationals, x = y + z -> y = x - z. Proof. intros x y z ->. now rewrite plusNonnegativeRationals_minus_r. Qed. Lemma minusNonnegativeRationals_zero_l : ∏ x : NonnegativeRationals, 0 - x = 0. Proof. intros x. apply minusNonnegativeRationals_eq_zero. now apply isnonnegative_NonnegativeRationals. Qed. Lemma minusNonnegativeRationals_zero_r : ∏ x : NonnegativeRationals, x - 0 = x. Proof. intros x. rewrite <- (isrunit_zeroNonnegativeRationals (x - 0)). apply minusNonnegativeRationals_plus_r. now apply isnonnegative_NonnegativeRationals. Qed. Lemma minusNonnegativeRationals_plus_exchange : ∏ x y z : NonnegativeRationals, y <= x -> x - y + z = (x + z) - y. Proof. intros x y z Hxy. assert (Hxzy : y <= x + z). { apply istrans_leNonnegativeRationals with x. { exact Hxy. } apply plusNonnegativeRationals_le_r. } rewrite (minusNonnegativeRationals_correct _ _ Hxy), (minusNonnegativeRationals_correct _ _ Hxzy). revert Hxy Hxzy. intros. apply subtypePath_prop. change (pr1 x - pr1 y + pr1 z = (pr1 x + pr1 z) - pr1 y)%hq. now unfold hqminus ; rewrite !hqplusassoc, (hqpluscomm (pr1 z)). Qed. (** Order *) Lemma ispositive_minusNonnegativeRationals : ∏ x y : NonnegativeRationals, (x < y) <-> (0 < y - x). Proof. intros x y. split ; intro Hlt. - apply_pr2 (plusNonnegativeRationals_ltcompat_r x). rewrite islunit_zeroNonnegativeRationals, minusNonnegativeRationals_plus_r. + exact Hlt. + now apply lt_leNonnegativeRationals, Hlt. - revert Hlt. unfold minusNonnegativeRationals, hnnq_minus. generalize (hqgthorleh (pr1 y) (pr1 x)). apply (coprod_rect (λ _, _ → _)) ; intros H0 ; intro Hlt. + exact H0. + now apply isirrefl_ltNonnegativeRationals in Hlt. Qed. Lemma minusNonnegativeRationals_le : ∏ x y : NonnegativeRationals, x - y <= x. Proof. intros x y. apply_pr2 (plusNonnegativeRationals_lecompat_r y). generalize (isdecrel_leNonnegativeRationals y x) ; apply sumofmaps ; [intros Hle | intros Hlt]. - rewrite minusNonnegativeRationals_plus_r. + now apply plusNonnegativeRationals_le_r. + exact Hle. - rewrite minusNonnegativeRationals_eq_zero. + rewrite islunit_zeroNonnegativeRationals. apply plusNonnegativeRationals_le_l. + apply lt_leNonnegativeRationals. now apply notge_ltNonnegativeRationals. Qed. Lemma minusNonnegativeRationals_lecompat_l : ∏ k x y : NonnegativeRationals, x <= y -> x - k <= y - k. Proof. intros k x y Hxy. generalize (isdecrel_leNonnegativeRationals k x) ; apply sumofmaps ; intros Hkx. - apply_pr2 (plusNonnegativeRationals_lecompat_r k). rewrite !minusNonnegativeRationals_plus_r. + exact Hxy. + now apply istrans_leNonnegativeRationals with (2 := Hxy). + exact Hkx. - rewrite minusNonnegativeRationals_eq_zero. + now apply isnonnegative_NonnegativeRationals. + now apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. Qed. Lemma minusNonnegativeRationals_lecompat_l' : ∏ k x y : NonnegativeRationals, k <= y -> x - k <= y - k -> x <= y. Proof. intros k x y Hky H. generalize (isdecrel_leNonnegativeRationals k x) ; apply sumofmaps ; intros Hkx. - rewrite <- (minusNonnegativeRationals_plus_r _ _ Hkx), <- (minusNonnegativeRationals_plus_r _ _ Hky). apply plusNonnegativeRationals_lecompat_r. exact H. - apply istrans_leNonnegativeRationals with k. + apply lt_leNonnegativeRationals. now apply notge_ltNonnegativeRationals. + exact Hky. Qed. Lemma minusNonnegativeRationals_lecompat_r : ∏ k x y : NonnegativeRationals, x <= y -> k - y <= k - x. Proof. intros k x y Hxy. generalize (isdecrel_leNonnegativeRationals y k) ; apply sumofmaps ; intros Hky. - apply_pr2 (plusNonnegativeRationals_lecompat_r y). rewrite minusNonnegativeRationals_plus_r, minusNonnegativeRationals_plus_exchange, iscomm_plusNonnegativeRationals, <- minusNonnegativeRationals_plus_exchange. + apply plusNonnegativeRationals_le_l. + exact Hxy. + apply istrans_leNonnegativeRationals with y. * exact Hxy. * exact Hky. + exact Hky. - rewrite minusNonnegativeRationals_eq_zero. + now apply isnonnegative_NonnegativeRationals. + now apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. Qed. Lemma minusNonnegativeRationals_lecompat_r' : ∏ k x y : NonnegativeRationals, x <= k -> k - y <= k - x -> x <= y. Proof. intros k x y Hkx H. generalize (isdecrel_leNonnegativeRationals y k) ; apply sumofmaps ; intros Hky. - apply (plusNonnegativeRationals_lecompat_r y) in H. rewrite minusNonnegativeRationals_plus_r, iscomm_plusNonnegativeRationals in H. + apply (plusNonnegativeRationals_lecompat_r x) in H ; rewrite isassoc_plusNonnegativeRationals, minusNonnegativeRationals_plus_r, iscomm_plusNonnegativeRationals in H. * now apply_pr2 (plusNonnegativeRationals_lecompat_r k). * exact Hkx. + exact Hky. - apply istrans_leNonnegativeRationals with k. + exact Hkx. + apply lt_leNonnegativeRationals. now apply notge_ltNonnegativeRationals. Qed. Lemma minusNonnegativeRationals_ltcompat_l: ∏ x y z : NonnegativeRationals, x < y -> z < y -> x - z < y - z. Proof. intros x y z Hxy Hyz. generalize (isdecrel_leNonnegativeRationals x z) ; apply sumofmaps ; intros Hxz. - rewrite minusNonnegativeRationals_eq_zero. + apply ispositive_minusNonnegativeRationals. exact Hyz. + exact Hxz. - apply (notge_ltNonnegativeRationals z x) in Hxz. apply_pr2 (plusNonnegativeRationals_ltcompat_r z) ; rewrite !minusNonnegativeRationals_plus_r. + exact Hxy. + now apply lt_leNonnegativeRationals, Hyz. + now apply lt_leNonnegativeRationals, Hxz. Qed. Lemma minusNonnegativeRationals_ltcompat_l' : ∏ x y z : NonnegativeRationals, x - z < y - z -> x < y. Proof. intros x y z Hlt. assert (Hyz : (z < y)%NRat). { apply_pr2 ispositive_minusNonnegativeRationals. apply istrans_le_lt_ltNonnegativeRationals with (x - z). { now apply isnonnegative_NonnegativeRationals. } exact Hlt. } generalize (isdecrel_leNonnegativeRationals x z) ; apply sumofmaps ; intro Hxz. - apply istrans_le_lt_ltNonnegativeRationals with (1 := Hxz). exact Hyz. - apply notge_ltNonnegativeRationals in Hxz ; apply lt_leNonnegativeRationals in Hxz. apply lt_leNonnegativeRationals in Hyz. rewrite <- (minusNonnegativeRationals_plus_r _ _ Hxz), <- (minusNonnegativeRationals_plus_r _ _ Hyz). apply plusNonnegativeRationals_ltcompat_r. exact Hlt. Qed. Lemma minusNonnegativeRationals_ltcompat_r: ∏ x y z : NonnegativeRationals, x < y -> x < z -> z - y < z - x. Proof. intros x y z Hxy Hxz. generalize (isdecrel_leNonnegativeRationals y z) ; apply sumofmaps ; intros Hky. - apply_pr2 (plusNonnegativeRationals_ltcompat_r y). rewrite minusNonnegativeRationals_plus_r, minusNonnegativeRationals_plus_exchange, iscomm_plusNonnegativeRationals, <- minusNonnegativeRationals_plus_exchange. + pattern z at 1 ; rewrite <- (islunit_zeroNonnegativeRationals z). apply plusNonnegativeRationals_ltcompat_r. now apply (pr1 (ispositive_minusNonnegativeRationals _ _)), Hxy. + now apply lt_leNonnegativeRationals, Hxy. + now apply lt_leNonnegativeRationals, Hxz. + exact Hky. - rewrite minusNonnegativeRationals_eq_zero. + now apply (pr1 (ispositive_minusNonnegativeRationals _ _)), Hxz. + now apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals, Hky. Qed. Lemma minusNonnegativeRationals_ltcompat_r': ∏ x y z : NonnegativeRationals, z - y < z - x -> x < y. Proof. intros x y z H. apply notge_ltNonnegativeRationals. intro H0 ; revert H. change (neg (z - y < z - x)). apply notlt_geNonnegativeRationals. now apply minusNonnegativeRationals_lecompat_r, H0. Qed. (** *** Multiplication *) (** Rewritings *) Definition isassoc_multNonnegativeRationals: ∏ x y z : NonnegativeRationals, x * y * z = x * (y * z) := CommDivRig_isassoc_mult. Definition islunit_oneNonnegativeRationals: ∏ x : NonnegativeRationals, 1 * x = x := CommDivRig_islunit_one. Definition isrunit_oneNonnegativeRationals: ∏ x : NonnegativeRationals, x * 1 = x := CommDivRig_isrunit_one. Definition iscomm_multNonnegativeRationals: ∏ x y : NonnegativeRationals, x * y = y * x := CommDivRig_iscomm_mult. Definition isldistr_mult_plusNonnegativeRationals: ∏ x y z : NonnegativeRationals, z * (x + y) = z * x + z * y := CommDivRig_isldistr. Definition isrdistr_mult_plusNonnegativeRationals: ∏ x y z : NonnegativeRationals, (x + y) * z = x * z + y * z := CommDivRig_isrdistr. Definition islabsorb_zero_multNonnegativeRationals: ∏ x : NonnegativeRationals, 0 * x = 0 := rigmult0x _. Definition israbsorb_zero_multNonnegativeRationals: ∏ x : NonnegativeRationals, x * 0 = 0 := rigmultx0 _. (** Order *) Lemma multNonnegativeRationals_ltcompat_l : ∏ k x y : NonnegativeRationals, 0 < k -> (x < y) <-> (k * x < k * y). Proof. intros k x y Hk. split ; intro H. - apply (hqlthandmultl (pr1 x) (pr1 y) (pr1 k)). + exact Hk. + exact H. - apply (hqlthandmultlinv (pr1 x) (pr1 y) (pr1 k)). + exact Hk. + exact H. Qed. Lemma multNonnegativeRationals_ltcompat_r : ∏ k x y : NonnegativeRationals, 0 < k -> (x < y) <-> (x * k < y * k). Proof. intros k x y Hk. rewrite !(iscomm_multNonnegativeRationals _ k). now apply multNonnegativeRationals_ltcompat_l. Qed. Lemma multNonnegativeRationals_lecompat_l : ∏ k x y : NonnegativeRationals, x <= y -> k * x <= k * y. Proof. intros k x y Hle. generalize (eq0orgt0NonnegativeRationals k) ; apply sumofmaps ; intros Hk0. - rewrite Hk0. rewrite !islabsorb_zero_multNonnegativeRationals. now apply isrefl_leNonnegativeRationals. - apply hqlehandmultl, Hle. exact Hk0. Qed. Lemma multNonnegativeRationals_lecompat_l' : ∏ k x y : NonnegativeRationals, 0 < k -> k * x <= k * y -> x <= y. Proof. intros k x y Hk0. apply (hqlehandmultlinv (pr1 x) (pr1 y) (pr1 k)). exact Hk0. Qed. Lemma multNonnegativeRationals_lecompat_r : ∏ k x y : NonnegativeRationals, x <= y -> x * k <= y * k. Proof. intros k x y Hk. rewrite !(iscomm_multNonnegativeRationals _ k). now apply multNonnegativeRationals_lecompat_l. Qed. Lemma multNonnegativeRationals_lecompat_r' : ∏ k x y : NonnegativeRationals, 0 < k -> x * k <= y * k -> x <= y. Proof. intros k x y Hk. rewrite !(iscomm_multNonnegativeRationals _ k). exact (multNonnegativeRationals_lecompat_l' k x y Hk). Qed. Lemma multNonnegativeRationals_eqcompat_l: ∏ k x y : NonnegativeRationals, 0 < k -> k * x = k * y -> x = y. Proof. intros k x y Hk0 H. rewrite <- (islunit_oneNonnegativeRationals x). change 1 with (1%dr : NonnegativeRationals). assert (Hk : k != 0). { apply gtNonnegativeRationals_noteq, Hk0. } rewrite <- (CommDivRig_islinv k Hk). rewrite isassoc_multNonnegativeRationals. rewrite H. rewrite <- isassoc_multNonnegativeRationals. change ((/ (k,, Hk))%dr * k) with (/ (k,, Hk) * k)%dr. rewrite (CommDivRig_islinv k Hk). now apply islunit_oneNonnegativeRationals. Qed. Lemma multNonnegativeRationals_eqcompat_r: ∏ k x y : NonnegativeRationals, 0 < k -> x * k = y * k -> x = y. Proof. intros k x y. rewrite !(iscomm_multNonnegativeRationals _ k). now apply multNonnegativeRationals_eqcompat_l. Qed. Lemma ispositive_multNonnegativeRationals: ∏ x y : NonnegativeRationals, 0 < x -> 0 < y -> 0 < x * y. Proof. intros x y Hx Hy. rewrite <- (israbsorb_zero_multNonnegativeRationals x). apply multNonnegativeRationals_ltcompat_l. + exact Hx. + exact Hy. Qed. Lemma multNonnegativeRationals_ltcompat: ∏ x x' y y' : NonnegativeRationals, x < x' -> y < y' -> x * y < x' * y'. Proof. intros x x' y y' Hx Hy. generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; intros Hx0. - rewrite Hx0, islabsorb_zero_multNonnegativeRationals. apply ispositive_multNonnegativeRationals. + rewrite <- Hx0 ; exact Hx. + apply istrans_le_lt_ltNonnegativeRationals with y. * now apply isnonnegative_NonnegativeRationals. * exact Hy. - apply istrans_lt_le_ltNonnegativeRationals with (x * y'). + apply multNonnegativeRationals_ltcompat_l. * exact Hx0. * exact Hy. + apply multNonnegativeRationals_lecompat_r. now apply lt_leNonnegativeRationals. Qed. Lemma multNonnegativeRationals_le_lt: ∏ x x' y y' : NonnegativeRationals, 0 < x -> x <= x' -> y < y' -> x * y < x' * y'. Proof. intros x x' y y' Hx0 Hx Hy. apply istrans_lt_le_ltNonnegativeRationals with (x* y'). - apply multNonnegativeRationals_ltcompat_l. + exact Hx0. + exact Hy. - now apply multNonnegativeRationals_lecompat_r, Hx. Qed. Lemma multNonnegativeRationals_lt_le: ∏ x x' y y' : NonnegativeRationals, 0 < y -> x < x' -> y <= y' -> x * y < x' * y'. Proof. intros x x' y y' Hy0 Hx Hy. apply istrans_lt_le_ltNonnegativeRationals with (x' * y). - apply multNonnegativeRationals_ltcompat_r. + exact Hy0. + exact Hx. - now apply multNonnegativeRationals_lecompat_l, Hy. Qed. Lemma multNonnegativeRationals_le1_r : ∏ q r : NonnegativeRationals, q <= 1 -> r * q <= r. Proof. intros q r Hq. pattern r at 2 ; rewrite <- isrunit_oneNonnegativeRationals. now apply multNonnegativeRationals_lecompat_l. Qed. Lemma multNonnegativeRationals_le1_l : ∏ q r : NonnegativeRationals, q <= 1 -> q * r <= r. Proof. intros q r Hq. pattern r at 2 ; rewrite <- islunit_oneNonnegativeRationals. now apply multNonnegativeRationals_lecompat_r. Qed. Lemma isldistr_mult_minusNonnegativeRationals: ∏ x y z : NonnegativeRationals, z * (x - y) = z * x - z * y. Proof. intros x y z. generalize (isdecrel_leNonnegativeRationals x y) ; apply sumofmaps ; [ intros Hle | intros Hlt]. - rewrite !minusNonnegativeRationals_eq_zero. + now apply israbsorb_zero_multNonnegativeRationals. + now apply multNonnegativeRationals_lecompat_l, Hle. + exact Hle. - apply notge_ltNonnegativeRationals in Hlt ; apply lt_leNonnegativeRationals in Hlt. apply plusNonnegativeRationals_eqcompat_r with (z * y). rewrite <- isldistr_mult_plusNonnegativeRationals. rewrite !minusNonnegativeRationals_plus_r. + reflexivity. + now apply multNonnegativeRationals_lecompat_l, Hlt. + exact Hlt. Qed. Lemma isrdistr_mult_minusNonnegativeRationals: ∏ x y z : NonnegativeRationals, (x - y) * z = x * z - y * z. Proof. intros x y z. rewrite !(iscomm_multNonnegativeRationals _ z). now apply isldistr_mult_minusNonnegativeRationals. Qed. (** *** Multiplicative Inverse *) (** Rewritings *) Definition islinv_NonnegativeRationals: ∏ x : NonnegativeRationals, 0 < x -> / x * x = 1. Proof. intros x Hx0. assert (Hx : x != 0). { apply gtNonnegativeRationals_noteq, Hx0. } clear Hx0. revert x Hx. apply @CommDivRig_islinv. Qed. Definition isrinv_NonnegativeRationals: ∏ x : NonnegativeRationals, 0 < x -> x * / x = 1. Proof. intros x. rewrite iscomm_multNonnegativeRationals. now apply islinv_NonnegativeRationals. Qed. Local Lemma inv_zeroNonnegativeRationals : / 0 = 0. Proof. unfold zeroNonnegativeRationals, invNonnegativeRationals, hnnq_zero, hnnq_inv ; simpl pr1 ; simpl pr2. generalize (hqlehchoice 0%hq 0%hq (isreflhqleh 0%hq)) ; apply coprod_rect ; intro H0. - now apply fromempty ; apply isirreflhqlth in H0. - reflexivity. Qed. Lemma ispositive_invNonnegativeRationals : ∏ x, (0 < x) <-> (0 < / x). Proof. intros x. split ; intro Hx. - apply_pr2 (multNonnegativeRationals_ltcompat_l x). + exact Hx. + rewrite israbsorb_zero_multNonnegativeRationals, isrinv_NonnegativeRationals. * exact ispositive_oneNonnegativeRationals. * apply NonnegativeRationals_neq0_gt0 ; intros Hx0. revert Hx ; rewrite Hx0. now apply isirrefl_ltNonnegativeRationals. - apply_pr2 (multNonnegativeRationals_ltcompat_r (/ x)). + exact Hx. + rewrite islabsorb_zero_multNonnegativeRationals, isrinv_NonnegativeRationals. * exact ispositive_oneNonnegativeRationals. * apply NonnegativeRationals_neq0_gt0 ; intros Hx0. revert Hx ; rewrite Hx0. unfold invNonnegativeRationals, hnnq_inv. generalize (hqlehchoice 0%hq (pr1 0) (pr2 0)). apply (coprod_rect (λ _, _ → _)) ; intros Hx. ** apply fromempty ; revert Hx. now apply isirreflhqlth. ** now apply isirrefl_ltNonnegativeRationals. Qed. Lemma isinvolutive_invNonnegativeRationals : ∏ x, / / x = x. Proof. intros x. generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; intro Hx0. - now rewrite Hx0, !inv_zeroNonnegativeRationals. - apply (multNonnegativeRationals_eqcompat_l (/ x)). + apply ispositive_invNonnegativeRationals ; exact Hx0. + rewrite islinv_NonnegativeRationals, isrinv_NonnegativeRationals. * reflexivity. * apply ispositive_invNonnegativeRationals ; exact Hx0. * exact Hx0. Qed. (** Order *) Lemma invNonnegativeRationals_lecompat : ∏ x y : NonnegativeRationals, 0 < x -> x <= y -> / y <= / x. Proof. intros x y Hx0 Hxy. assert (Hy0 : 0 < y). { apply istrans_lt_le_ltNonnegativeRationals with x. { exact Hx0. } exact Hxy. } apply (multNonnegativeRationals_lecompat_l' x). - exact Hx0. - rewrite isrinv_NonnegativeRationals. + apply (multNonnegativeRationals_lecompat_r' y). * exact Hy0. * rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, islunit_oneNonnegativeRationals, isrunit_oneNonnegativeRationals. ** exact Hxy. ** exact Hy0. + exact Hx0. Qed. Lemma invNonnegativeRationals_lecompat' : ∏ x y : NonnegativeRationals, 0 < y -> / y <= / x -> x <= y. Proof. intros x y Hy0 Hxy. rewrite <- (isinvolutive_invNonnegativeRationals x), <- (isinvolutive_invNonnegativeRationals y). apply invNonnegativeRationals_lecompat. - now apply ispositive_invNonnegativeRationals. - exact Hxy. Qed. Lemma invNonnegativeRationals_ltcompat : ∏ x y : NonnegativeRationals, 0 < x -> x < y -> / y < / x. Proof. intros x y Hx0 Hxy. apply notge_ltNonnegativeRationals. intros H ; revert Hxy. change (neg (x < y)). apply notlt_geNonnegativeRationals. apply invNonnegativeRationals_lecompat'. - exact Hx0. - exact H. Qed. Lemma invNonnegativeRationals_ltcompat' : ∏ x y : NonnegativeRationals, 0 < y -> / y < / x -> x < y. Proof. intros x y Hy0 Hxy. rewrite <- (isinvolutive_invNonnegativeRationals x), <- (isinvolutive_invNonnegativeRationals y). apply invNonnegativeRationals_ltcompat. - apply ispositive_invNonnegativeRationals. exact Hy0. - exact Hxy. Qed. Lemma issublinear_invNonnegativeRationals : ∏ x y : NonnegativeRationals, / (x + y) <= / x + / y. Proof. intros x y. generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; intros Hx0. - rewrite Hx0, islunit_zeroNonnegativeRationals ; clear Hx0 x. now apply plusNonnegativeRationals_le_l. - generalize (eq0orgt0NonnegativeRationals y) ; apply sumofmaps ; intros Hy0. + rewrite Hy0, isrunit_zeroNonnegativeRationals ; clear Hy0 y. now apply plusNonnegativeRationals_le_r. + apply (multNonnegativeRationals_lecompat_l' _ _ _ Hx0). rewrite isldistr_mult_plusNonnegativeRationals, (isrinv_NonnegativeRationals _ Hx0), !(iscomm_multNonnegativeRationals x). apply (multNonnegativeRationals_lecompat_l' _ _ _ Hy0). rewrite isldistr_mult_plusNonnegativeRationals, <- (isassoc_multNonnegativeRationals _ (/ y)%NRat), (isrinv_NonnegativeRationals _ Hy0), islunit_oneNonnegativeRationals, isrunit_oneNonnegativeRationals, (iscomm_multNonnegativeRationals y). apply (multNonnegativeRationals_lecompat_l' (x + y)). * now apply ispositive_plusNonnegativeRationals_l, Hx0. * rewrite <- ! isassoc_multNonnegativeRationals , isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals, isldistr_mult_plusNonnegativeRationals, !isrdistr_mult_plusNonnegativeRationals, !isassoc_plusNonnegativeRationals. ** now apply plusNonnegativeRationals_le_r. ** now apply ispositive_plusNonnegativeRationals_l, Hx0. Qed. Lemma issublinear_invNonnegativeRationals_lt : ∏ x y : NonnegativeRationals, (0 < x)%NRat -> (0 < y)%NRat -> (/ (x + y) < / x + / y)%NRat. Proof. intros x y Hx0 Hy0. apply_pr2 (multNonnegativeRationals_ltcompat_l x). - exact Hx0. - rewrite isldistr_mult_plusNonnegativeRationals, (isrinv_NonnegativeRationals _ Hx0), !(iscomm_multNonnegativeRationals x). apply_pr2 (multNonnegativeRationals_ltcompat_l y). + exact Hy0. + rewrite isldistr_mult_plusNonnegativeRationals, <- (isassoc_multNonnegativeRationals _ (/ y)%NRat), (isrinv_NonnegativeRationals _ Hy0), islunit_oneNonnegativeRationals, isrunit_oneNonnegativeRationals, (iscomm_multNonnegativeRationals y). apply_pr2 (multNonnegativeRationals_ltcompat_l (x + y)). * apply ispositive_plusNonnegativeRationals_l. exact Hx0. * rewrite <- ! isassoc_multNonnegativeRationals , isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals, isldistr_mult_plusNonnegativeRationals, !isrdistr_mult_plusNonnegativeRationals, !isassoc_plusNonnegativeRationals. ** apply plusNonnegativeRationals_lt_r. apply ispositive_plusNonnegativeRationals_l. now apply ispositive_multNonnegativeRationals ; apply Hy0. ** now apply ispositive_plusNonnegativeRationals_l, Hx0. Qed. (** *** Division *) (** Rewritings *) Lemma multdivNonnegativeRationals : ∏ q r : NonnegativeRationals, 0 < r -> r * (q / r) = q. Proof. intros q r Hr0. unfold divNonnegativeRationals. rewrite iscomm_multNonnegativeRationals, isassoc_multNonnegativeRationals. rewrite islinv_NonnegativeRationals. - now apply isrunit_oneNonnegativeRationals. - exact Hr0. Qed. Lemma minus_divNonnegativeRationals : ∏ x y : NonnegativeRationals, 0 < y -> / x - / y = (y - x) / (x * y). Proof. intros x y Hy0. generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; intros Hx0. - unfold divNonnegativeRationals. rewrite Hx0, islabsorb_zero_multNonnegativeRationals, inv_zeroNonnegativeRationals, israbsorb_zero_multNonnegativeRationals, minusNonnegativeRationals_zero_l. reflexivity. - apply multNonnegativeRationals_eqcompat_l with (x * y). + apply ispositive_multNonnegativeRationals, Hy0. exact Hx0. + rewrite multdivNonnegativeRationals. 2: apply ispositive_multNonnegativeRationals, Hy0. * rewrite isldistr_mult_minusNonnegativeRationals. rewrite iscomm_multNonnegativeRationals, <- isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, islunit_oneNonnegativeRationals. 2: exact Hx0. rewrite isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. 2: exact Hy0. reflexivity. * exact Hx0. Qed. (** Order *) Lemma ispositive_divNonnegativeRationals : ∏ x y, 0 < x -> 0 < y -> 0 < x / y. Proof. intros x y Hx Hy. apply ispositive_multNonnegativeRationals. - exact Hx. - apply ispositive_invNonnegativeRationals. exact Hy. Qed. Lemma divNonnegativeRationals_le1 : ∏ q r : NonnegativeRationals, q <= r -> q / r <= 1. Proof. intros q r Hrq. generalize (eq0orgt0NonnegativeRationals r) ; apply sumofmaps ; intros Hr0. - unfold divNonnegativeRationals. rewrite Hr0, inv_zeroNonnegativeRationals. rewrite israbsorb_zero_multNonnegativeRationals. now apply isnonnegative_NonnegativeRationals. - apply (multNonnegativeRationals_lecompat_r' r). + exact Hr0. + unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals. * rewrite isrunit_oneNonnegativeRationals, islunit_oneNonnegativeRationals. exact Hrq. * exact Hr0. Qed. (** ** NQhalf *) Lemma NQhalf_double : ∏ x, x = x / 2 + x / 2. Proof. intros x. change x with (pr1 x,,pr2 x). generalize (pr1 x) (pr2 x) ; clear x ; intros x Hx. unfold divNonnegativeRationals, invNonnegativeRationals, hnnq_inv, twoNonnegativeRationals, Rationals_to_NonnegativeRationals ; simpl pr1 ; simpl pr2. generalize (hqlehchoice 0%hq 2%hq (hqlthtoleh 0%hq 2%hq hq2_gt0)) ; apply coprod_rect ; intros H2. - apply subtypePath_prop ; simpl pr1. rewrite !(hqmultcomm x), <- hqldistr, hqmultcomm. apply hqplusdiv2. - apply fromempty ; generalize hq2_gt0. rewrite H2. now apply (isirreflhqlth 2%hq). Qed. Lemma ispositive_NQhalf : ∏ x, (0 < x) <-> (0 < x / 2). Proof. intro x. split ; intro Hx. - apply_pr2 (multNonnegativeRationals_ltcompat_r 2). + now apply ispositive_twoNonnegativeRationals. + unfold divNonnegativeRationals ; rewrite isassoc_multNonnegativeRationals, islabsorb_zero_multNonnegativeRationals. rewrite islinv_NonnegativeRationals. * now rewrite isrunit_oneNonnegativeRationals. * now apply ispositive_twoNonnegativeRationals. - apply_pr2 (multNonnegativeRationals_ltcompat_r (/2)). + apply (pr1 (ispositive_invNonnegativeRationals _)). now apply ispositive_twoNonnegativeRationals. + rewrite islabsorb_zero_multNonnegativeRationals. exact Hx. Qed. (** ** NQmax *) Definition NQmax : binop NonnegativeRationals. Proof. intros x y. refine (sumofmaps _ _ (isdecrel_leNonnegativeRationals x y)) ; intros _. - exact y. - exact x. Defined. Lemma NQmax_eq_zero : ∏ x y : NonnegativeRationals, NQmax x y = 0 -> (x = 0) × (y = 0). Proof. intros x y. unfold NQmax. generalize (isdecrel_leNonnegativeRationals x y). apply (coprod_rect (λ _, _ → _)) ; [ intros Hle | intros Hlt] ; intro H ; simpl in H ; split. - apply NonnegativeRationals_eq0_le0. apply istrans_leNonnegativeRationals with (1 := Hle). now rewrite H ; apply isrefl_leNonnegativeRationals. - exact H. - exact H. - apply NonnegativeRationals_eq0_le0 ; rewrite <- H. now apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. Qed. Lemma NQmax_case : ∏ (P : NonnegativeRationals -> UU), ∏ x y : NonnegativeRationals, P x -> P y -> P (NQmax x y). Proof. intros P x y Hx Hy. unfold NQmax. generalize (isdecrel_leNonnegativeRationals x y). now apply coprod_rect. Qed. Lemma NQmax_case_strong : ∏ (P : NonnegativeRationals -> UU), ∏ x y : NonnegativeRationals, (y <= x -> P x) -> (x <= y -> P y) -> P (NQmax x y). Proof. intros P x y Hx Hy. unfold NQmax. generalize ( isdecrel_leNonnegativeRationals x y). apply coprod_rect ; [intros Hle | intros Hlt]. - now apply Hy. - apply Hx. now apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. Qed. Lemma iscomm_NQmax : ∏ x y, NQmax x y = NQmax y x. Proof. intros x y. apply NQmax_case_strong ; intro Hle ; apply NQmax_case_strong ; intro Hle'. - now apply isantisymm_leNonnegativeRationals. - reflexivity. - reflexivity. - now apply isantisymm_leNonnegativeRationals. Qed. Lemma NQmax_le_l : ∏ x y : NonnegativeRationals, x <= NQmax x y. Proof. intros x y. apply NQmax_case_strong ; intro Hle. - apply isrefl_leNonnegativeRationals. - exact Hle. Qed. Lemma NQmax_le_r : ∏ x y : NonnegativeRationals, y <= NQmax x y. Proof. intros x y. rewrite iscomm_NQmax. now apply NQmax_le_l. Qed. (** ** NQmin *) Definition NQmin : binop NonnegativeRationals. Proof. intros x y. refine (sumofmaps _ _ (isdecrel_leNonnegativeRationals x y)) ; intros _. - exact x. - exact y. Defined. (** ** intpart *) Lemma nat_to_NonnegativeRationals_O : nat_to_NonnegativeRationals O = 0. Proof. apply subtypePath_prop. reflexivity. Qed. Lemma nat_to_NonnegativeRationals_Sn : ∏ n : nat, nat_to_NonnegativeRationals (S n) = nat_to_NonnegativeRationals n + 1. Proof. intro n. apply subtypePath_prop. simpl. rewrite nattohzandS, hztohqandplus. apply hqpluscomm. Qed. Definition isarchNonnegativeRationals : isarchrig gtNonnegativeRationals. Proof. set (H := isarchhq). apply isarchfld_isarchring in H. - apply isarchring_isarchrig in H. + assert (∏ n, pr1 (nattorig (X := pr1 (CommDivRig_DivRig NonnegativeRationals)) n) = nattorig (X := pr1fld hq) n). { induction n as [|n IHn]. - reflexivity. - rewrite !nattorigS, <- IHn. reflexivity. } repeat split. * intros y1 y2 Hy. generalize (isarchrig_diff _ H (pr1 y1) (pr1 y2) Hy). apply hinhfun. intros n. exists (pr1 n). generalize (pr2 n) ; intros Hn. rewrite <- !X in Hn. exact Hn. * intros x. generalize (isarchrig_gt _ H (pr1 x)). apply hinhfun. intros n. exists (pr1 n). generalize (pr2 n) ; intros Hn. rewrite <- X in Hn. exact Hn. * intros x. generalize (isarchrig_pos _ H (pr1 x)). apply hinhfun. intros n. exists (pr1 n). generalize (pr2 n) ; intros Hn. rewrite <- X in Hn. exact Hn. + exact isringaddhzgth. - exact isringaddhzgth. - exact isringmulthqgth. - exact isirreflhqgth. Qed. Close Scope NRat_scope. (** ** Opacify *) Global Opaque NonnegativeRationals NonnegativeRationals_EffectivelyOrderedSet. (* End of the file hnnq.v *) UniMath-20231010/UniMath/RealNumbers/NonnegativeReals.v000066400000000000000000006011201451125700300225260ustar00rootroot00000000000000(** * Definition of Dedekind cuts for non-negative real numbers *) (** Catherine Lelay. Sep. 2015 *) Require Import UniMath.MoreFoundations.Orders. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.RealNumbers.Sets. Require Export UniMath.Algebra.ConstructiveStructures. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.RealNumbers.Prelim. Require Import UniMath.RealNumbers.NonnegativeRationals. Declare Scope Dcuts_scope. Delimit Scope Dcuts_scope with Dcuts. Local Open Scope NRat_scope. Local Open Scope Dcuts_scope. Local Open Scope tap_scope. (** ** Definition of Dedekind cuts *) Definition Dcuts_def_bot (X : hsubtype NonnegativeRationals) : UU := ∏ x : NonnegativeRationals, X x -> ∏ y : NonnegativeRationals, y <= x -> X y. Definition Dcuts_def_open (X : hsubtype NonnegativeRationals) : UU := ∏ x : NonnegativeRationals, X x -> ∃ y : NonnegativeRationals, (X y) × (x < y). Definition Dcuts_def_finite (X : hsubtype NonnegativeRationals) : hProp := ∃ ub : NonnegativeRationals, ¬ (X ub). Definition Dcuts_def_corr (X : hsubtype NonnegativeRationals) : UU := ∏ r : NonnegativeRationals, 0 < r -> (¬ (X r)) ∨ ∑ q : NonnegativeRationals, (X q) × (¬ (X (q + r))). Lemma Dcuts_def_corr_finite (X : hsubtype NonnegativeRationals) : Dcuts_def_corr X → Dcuts_def_finite X. Proof. intros Hx. specialize (Hx _ ispositive_oneNonnegativeRationals). revert Hx ; apply hinhuniv ; apply sumofmaps ; [intros Hx | intros x]. - apply hinhpr. exists 1 ; exact Hx. - apply hinhpr ; exists (pr1 x + 1) ; exact (pr2 (pr2 x)). Qed. Lemma Dcuts_def_corr_not_empty (X : hsubtype NonnegativeRationals) : X 0 -> Dcuts_def_corr X -> ∏ c : NonnegativeRationals, (0 < c)%NRat -> ∃ x : NonnegativeRationals, X x × ¬ X (x + c). Proof. intros X0 Hx c Hc. generalize (Hx c Hc). apply hinhuniv ; apply sumofmaps ; [intros nXc | intros Hx' ]. - apply hinhpr ; exists 0%NRat ; split. + exact X0. + rewrite islunit_zeroNonnegativeRationals. exact nXc. - apply hinhpr ; exact Hx'. Qed. Lemma isaprop_Dcuts_def_bot (X : hsubtype NonnegativeRationals) : isaprop (Dcuts_def_bot X). Proof. repeat (apply impred_isaprop ; intro). now apply pr2. Qed. Lemma isaprop_Dcuts_def_open (X : hsubtype NonnegativeRationals) : isaprop (Dcuts_def_open X). Proof. repeat (apply impred_isaprop ; intro). now apply pr2. Qed. Lemma isaprop_Dcuts_def_corr (X : hsubtype NonnegativeRationals) : isaprop (Dcuts_def_corr X). Proof. repeat (apply impred_isaprop ; intro). now apply pr2. Qed. Lemma isaprop_Dcuts_hsubtype (X : hsubtype NonnegativeRationals) : isaprop (Dcuts_def_bot X × Dcuts_def_open X × Dcuts_def_corr X). Proof. apply isofhleveldirprod, isofhleveldirprod. - exact (isaprop_Dcuts_def_bot X). - exact (isaprop_Dcuts_def_open X). - exact (isaprop_Dcuts_def_corr X). Qed. Definition Dcuts_hsubtype : hsubtype (hsubtype NonnegativeRationals) := λ X : hsubtype NonnegativeRationals, make_hProp _ (isaprop_Dcuts_hsubtype X). Lemma isaset_Dcuts : isaset (carrier Dcuts_hsubtype). Proof. apply isasetsubset with pr1. - apply isasethsubtype. - apply isinclpr1. intro x. apply pr2. Qed. Definition Dcuts_set : hSet := make_hSet _ isaset_Dcuts. Definition pr1Dcuts (x : Dcuts_set) : hsubtype NonnegativeRationals := pr1 x. Declare Scope DC_scope. Notation "x ∈ X" := (pr1Dcuts X x) (at level 70, no associativity) : DC_scope. Local Open Scope DC_scope. Lemma is_Dcuts_bot (X : Dcuts_set) : Dcuts_def_bot (pr1 X). Proof. exact (pr1 (pr2 X)). Qed. Lemma is_Dcuts_open (X : Dcuts_set) : Dcuts_def_open (pr1 X). Proof. exact (pr1 (pr2 (pr2 X))). Qed. Lemma is_Dcuts_corr (X : Dcuts_set) : Dcuts_def_corr (pr1 X). Proof. exact (pr2 (pr2 (pr2 X))). Qed. Definition make_Dcuts (X : NonnegativeRationals → hProp) (Hbot : Dcuts_def_bot X) (Hopen : Dcuts_def_open X) (Herror : Dcuts_def_corr X) : Dcuts_set. Proof. exists X ; repeat split. - now apply Hbot. - now apply Hopen. - now apply Herror. Defined. Lemma Dcuts_finite : ∏ X : Dcuts_set, ∏ r : NonnegativeRationals, neg (r ∈ X) -> ∏ n : NonnegativeRationals, n ∈ X -> n < r. Proof. intros X r Hr n Hn. apply notge_ltNonnegativeRationals ; intro Hn'. apply Hr. apply is_Dcuts_bot with n. - exact Hn. - exact Hn'. Qed. (** ** [Dcuts] is a effectively ordered set *) (** Partial order on [Dcuts] *) Definition Dcuts_le_rel : hrel Dcuts_set := λ X Y : Dcuts_set, make_hProp (∏ x : NonnegativeRationals, x ∈ X -> x ∈ Y) (impred_isaprop _ (λ _, isapropimpl _ _ (pr2 _))). Lemma istrans_Dcuts_le_rel : istrans Dcuts_le_rel. Proof. intros x y z Hxy Hyz r Xr. refine (Hyz _ _). now refine (Hxy _ _). Qed. Lemma isrefl_Dcuts_le_rel : isrefl Dcuts_le_rel. Proof. now intros X x Xx. Qed. Lemma ispreorder_Dcuts_le_rel : ispreorder Dcuts_le_rel. Proof. split. - exact istrans_Dcuts_le_rel. - exact isrefl_Dcuts_le_rel. Qed. (** Strict partial order on [Dcuts] *) Definition Dcuts_lt_rel : hrel Dcuts_set := λ (X Y : Dcuts_set), ∃ x : NonnegativeRationals, dirprod (neg (x ∈ X)) (x ∈ Y). Lemma istrans_Dcuts_lt_rel : istrans Dcuts_lt_rel. Proof. intros x y z. apply hinhfun2. intros r n. exists (pr1 r) ; split. - exact (pr1 (pr2 r)). - apply is_Dcuts_bot with (pr1 n). + exact (pr2 (pr2 n)). + apply lt_leNonnegativeRationals. apply Dcuts_finite with y. * exact (pr1 (pr2 n)). * exact (pr2 (pr2 r)). Qed. Lemma isirrefl_Dcuts_lt_rel : isirrefl Dcuts_lt_rel. Proof. intros x. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)). intros r. apply (pr1 (pr2 r)). exact (pr2 (pr2 r)). Qed. Lemma iscotrans_Dcuts_lt_rel : iscotrans Dcuts_lt_rel. Proof. intros x y z. apply hinhuniv ; intros r. generalize (is_Dcuts_open _ _ (pr2 (pr2 r))) ; apply hinhuniv ; intros r'. assert (Hr0 : 0%NRat < pr1 r' - pr1 r). { apply ispositive_minusNonnegativeRationals. exact (pr2 (pr2 r')). } generalize (is_Dcuts_corr y _ Hr0) ; apply hinhuniv ; apply sumofmaps ; [intros Yq | intros q]. - apply squash_element ; right ; apply squash_element. exists (pr1 r') ; split. + intro H0 ; apply Yq. apply is_Dcuts_bot with (pr1 r'). * exact H0. * now apply minusNonnegativeRationals_le. + exact (pr1 (pr2 r')). - generalize (isdecrel_leNonnegativeRationals (pr1 q + (pr1 r' - pr1 r)) (pr1 r')) ; apply sumofmaps ; intros Hdec. + apply hinhpr ; right ; apply hinhpr. exists (pr1 r') ; split. * intro Yr' ; apply (pr2 (pr2 q)). apply is_Dcuts_bot with (pr1 r'). ** exact Yr'. ** exact Hdec. * exact (pr1 (pr2 r')). + apply hinhpr ; left ; apply hinhpr. exists (pr1 q) ; split. * intro Xq ; apply (pr1 (pr2 r)). apply is_Dcuts_bot with (pr1 q). ** exact Xq. ** apply notge_ltNonnegativeRationals in Hdec. apply (plusNonnegativeRationals_ltcompat_r (pr1 r)) in Hdec ; rewrite isassoc_plusNonnegativeRationals, minusNonnegativeRationals_plus_r, iscomm_plusNonnegativeRationals in Hdec. *** apply_pr2_in plusNonnegativeRationals_ltcompat_r Hdec. now apply lt_leNonnegativeRationals, Hdec. *** now apply lt_leNonnegativeRationals, (pr2 (pr2 r')). * exact (pr1 (pr2 q)). Qed. Lemma isstpo_Dcuts_lt_rel : isStrongOrder Dcuts_lt_rel. Proof. repeat split. - exact istrans_Dcuts_lt_rel. - exact iscotrans_Dcuts_lt_rel. - exact isirrefl_Dcuts_lt_rel. Qed. (** Effectively Ordered Set *) Lemma Dcuts_lt_le_rel : ∏ x y : Dcuts_set, Dcuts_lt_rel x y -> Dcuts_le_rel x y. Proof. intros x y ; apply hinhuniv ; intros r. intros n Xn. apply is_Dcuts_bot with (pr1 r). - exact (pr2 (pr2 r)). - apply lt_leNonnegativeRationals. apply Dcuts_finite with x. + exact (pr1 (pr2 r)). + exact Xn. Qed. Lemma Dcuts_le_ngt_rel : ∏ x y : Dcuts_set, ¬ Dcuts_lt_rel x y <-> Dcuts_le_rel y x. Proof. intros X Y. split. - intros Hnlt y Yy. generalize (is_Dcuts_open _ _ Yy) ; apply hinhuniv ; intros y'. generalize (pr1 (ispositive_minusNonnegativeRationals _ _) (pr2 (pr2 y'))) ; intros Hy. generalize (is_Dcuts_corr X _ Hy). apply hinhuniv. apply sumofmaps ; [intros nXc | ]. + apply fromempty, Hnlt. apply hinhpr. exists (pr1 y') ; split. * intro Xy' ; apply nXc. apply is_Dcuts_bot with (1 := Xy'). now apply minusNonnegativeRationals_le. * exact (pr1 (pr2 y')). + intros x. apply is_Dcuts_bot with (1 := pr1 (pr2 x)). apply notlt_geNonnegativeRationals ; intro H ; apply Hnlt. apply hinhpr. exists (pr1 x + (pr1 y' - y)) ; split. * exact (pr2 (pr2 x)). * apply is_Dcuts_bot with (1 := pr1 (pr2 y')). pattern (pr1 y') at 2; rewrite <- (minusNonnegativeRationals_plus_r y (pr1 y')). ** rewrite iscomm_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. now apply lt_leNonnegativeRationals, H. ** apply lt_leNonnegativeRationals ; apply_pr2 ispositive_minusNonnegativeRationals. exact Hy. - intros Hxy ; unfold neg. apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros r. refine (pr1 (pr2 r) _). refine (Hxy _ _). exact (pr2 (pr2 r)). Qed. Lemma istrans_Dcuts_lt_le_rel : ∏ x y z : Dcuts_set, Dcuts_lt_rel x y -> Dcuts_le_rel y z -> Dcuts_lt_rel x z. Proof. intros x y z Hlt Hle. revert Hlt ; apply hinhfun ; intros r. exists (pr1 r) ; split. - exact (pr1 (pr2 r)). - refine (Hle _ _). exact (pr2 (pr2 r)). Qed. Lemma istrans_Dcuts_le_lt_rel : ∏ x y z : Dcuts_set, Dcuts_le_rel x y -> Dcuts_lt_rel y z -> Dcuts_lt_rel x z. Proof. intros x y z Hle. apply hinhfun ; intros r. exists (pr1 r) ; split. - intros Xr ; apply (pr1 (pr2 r)). now refine (Hle _ _). - exact (pr2 (pr2 r)). Qed. Lemma iseo_Dcuts_le_lt_rel : isEffectiveOrder Dcuts_le_rel Dcuts_lt_rel. Proof. split. - split. + exact ispreorder_Dcuts_le_rel. + exact isstpo_Dcuts_lt_rel. - repeat split. + now apply Dcuts_le_ngt_rel. + apply (pr2 (Dcuts_le_ngt_rel _ _)). + exact istrans_Dcuts_lt_le_rel. + exact istrans_Dcuts_le_lt_rel. Qed. Definition iseo_Dcuts : EffectiveOrder Dcuts_set := pairEffectiveOrder Dcuts_le_rel Dcuts_lt_rel iseo_Dcuts_le_lt_rel. Definition eo_Dcuts : EffectivelyOrderedSet := pairEffectivelyOrderedSet iseo_Dcuts. Definition Dcuts_le : po Dcuts_set := @EOle eo_Dcuts. Definition Dcuts_ge : po Dcuts_set := @EOge eo_Dcuts. Definition Dcuts_lt : StrongOrder Dcuts_set := @EOlt eo_Dcuts. Definition Dcuts_gt : StrongOrder Dcuts_set := @EOgt eo_Dcuts. Notation "x <= y" := (@EOle_rel eo_Dcuts x y) : Dcuts_scope. Notation "x >= y" := (@EOge_rel eo_Dcuts x y) : Dcuts_scope. Notation "x < y" := (@EOlt_rel eo_Dcuts x y) : Dcuts_scope. Notation "x > y" := (@EOgt_rel eo_Dcuts x y) : Dcuts_scope. (** ** Equivalence on [Dcuts] *) Definition Dcuts_eq_rel := λ X Y : Dcuts_set, ∏ r : NonnegativeRationals, (r ∈ X -> r ∈ Y) × (r ∈ Y -> r ∈ X). Lemma isaprop_Dcuts_eq_rel : ∏ X Y : Dcuts_set, isaprop (Dcuts_eq_rel X Y). Proof. intros X Y. apply impred_isaprop ; intro r. apply isapropdirprod. - now apply isapropimpl, pr2. - now apply isapropimpl, pr2. Qed. Definition Dcuts_eq : hrel Dcuts_set := λ X Y : Dcuts_set, make_hProp (∏ r, (r ∈ X -> r ∈ Y) × (r ∈ Y -> r ∈ X)) (isaprop_Dcuts_eq_rel X Y). Lemma istrans_Dcuts_eq : istrans Dcuts_eq. Proof. intros x y z Hxy Hyz r. split. - intros Xr. now apply (pr1 (Hyz r)), (pr1 (Hxy r)), Xr. - intros Zr. now apply (pr2 (Hxy r)), (pr2 (Hyz r)), Zr. Qed. Lemma isrefl_Dcuts_eq : isrefl Dcuts_eq. Proof. intros x r. now split. Qed. Lemma ispreorder_Dcuts_eq : ispreorder Dcuts_eq. Proof. split. - exact istrans_Dcuts_eq. - exact isrefl_Dcuts_eq. Qed. Lemma issymm_Dcuts_eq : issymm Dcuts_eq. Proof. intros x y Hxy r. split. - exact (pr2 (Hxy r)). - exact (pr1 (Hxy r)). Qed. Lemma iseqrel_Dcuts_eq : iseqrel Dcuts_eq. Proof. split. - exact ispreorder_Dcuts_eq. - exact issymm_Dcuts_eq. Qed. Lemma Dcuts_eq_is_eq : ∏ x y : Dcuts_set, Dcuts_eq x y -> x = y. Proof. intros x y Heq. apply subtypePath_prop. apply funextsec. intro r. apply hPropUnivalence. - exact (pr1 (Heq r)). - exact (pr2 (Heq r)). Qed. (** ** Apartness on [Dcuts] *) Lemma isaprop_Dcuts_ap_rel (X Y : Dcuts_set) : isaprop ((X < Y) ⨿ (Y < X)). Proof. apply (isapropcoprod (X < Y) (Y < X) (propproperty (X < Y)) (propproperty (Y < X)) (λ Hlt : X < Y, pr2 (Dcuts_le_ngt_rel Y X) (Dcuts_lt_le_rel X Y Hlt))). Qed. Definition Dcuts_ap_rel (X Y : Dcuts_set) : hProp := make_hProp ((X < Y) ⨿ (Y < X)) (isaprop_Dcuts_ap_rel X Y). Lemma isirrefl_Dcuts_ap_rel : isirrefl Dcuts_ap_rel. Proof. intros x. unfold neg. apply sumofmaps. - now apply isirrefl_Dcuts_lt_rel. - now apply isirrefl_Dcuts_lt_rel. Qed. Lemma issymm_Dcuts_ap_rel : issymm Dcuts_ap_rel. Proof. intros x y. apply coprodcomm. Qed. Lemma iscotrans_Dcuts_ap_rel : iscotrans Dcuts_ap_rel. Proof. intros x y z. apply sumofmaps ; intros Hap. - generalize (iscotrans_Dcuts_lt_rel _ y _ Hap) ; apply hinhfun. apply sumofmaps ; intros Hy. + now left ; left. + now right ; left. - generalize (iscotrans_Dcuts_lt_rel _ y _ Hap) ; apply hinhfun. apply sumofmaps ; intros Hy. + now right ; right. + now left ; right. Qed. Lemma istight_Dcuts_ap_rel : istight Dcuts_ap_rel. Proof. intros X Y Hap. apply Dcuts_eq_is_eq. intros r ; split ; revert r. - change (X <= Y). apply Dcuts_le_ngt_rel. intro Hlt ; apply Hap. now right. - change (Y <= X). apply Dcuts_le_ngt_rel. intro Hlt ; apply Hap. now left. Qed. Definition Dcuts : tightapSet := Dcuts_set ,, Dcuts_ap_rel ,, (isirrefl_Dcuts_ap_rel ,, issymm_Dcuts_ap_rel ,, iscotrans_Dcuts_ap_rel) ,, istight_Dcuts_ap_rel. Lemma not_Dcuts_ap_eq : ∏ x y : Dcuts, ¬ (x ≠ y) -> (x = y). Proof. intros x y. now apply istight_Dcuts_ap_rel. Qed. (** *** Various theorems about order *) Lemma Dcuts_ge_le : ∏ x y : Dcuts, x >= y -> y <= x. Proof. intros. assumption. Qed. Lemma Dcuts_le_ge : ∏ x y : Dcuts, x <= y -> y >= x. Proof. intros. assumption. Qed. Lemma Dcuts_eq_le : ∏ x y : Dcuts, Dcuts_eq x y -> x <= y. Proof. intros x y Heq. intro r ; now apply (pr1 (Heq _)). Qed. Lemma Dcuts_eq_ge : ∏ x y : Dcuts, Dcuts_eq x y -> x >= y. Proof. intros x y Heq. apply Dcuts_eq_le. now apply issymm_Dcuts_eq. Qed. Lemma Dcuts_le_ge_eq : ∏ x y : Dcuts, x <= y -> x >= y -> x = y. Proof. intros x y le_xy ge_xy. apply Dcuts_eq_is_eq. split. - now refine (le_xy _). - now refine (ge_xy _). Qed. Lemma Dcuts_gt_lt : ∏ x y : Dcuts, (x > y) <-> (y < x). Proof. now split. Qed. Lemma Dcuts_gt_ge : ∏ x y : Dcuts, x > y -> x >= y. Proof. intros x y. now apply Dcuts_lt_le_rel. Qed. Lemma Dcuts_gt_nle : ∏ x y : Dcuts, x > y -> neg (x <= y). Proof. intros x y Hlt Hle. now apply (pr2 (Dcuts_le_ngt_rel _ _)) in Hle. Qed. Lemma Dcuts_nlt_ge : ∏ x y : Dcuts, neg (x < y) <-> (x >= y). Proof. intros X Y. now apply Dcuts_le_ngt_rel. Qed. Lemma Dcuts_lt_nge : ∏ x y : Dcuts, x < y -> neg (x >= y). Proof. intros x y. now apply Dcuts_gt_nle. Qed. (** * Algebraic structures on Dcuts *) (** ** From non negative rational numbers to Dedekind cuts *) Lemma NonnegativeRationals_to_Dcuts_bot (q : NonnegativeRationals) : Dcuts_def_bot (λ r : NonnegativeRationals, (r < q)%NRat). Proof. intros r Hr n Hnr. now apply istrans_le_lt_ltNonnegativeRationals with r. Qed. Lemma NonnegativeRationals_to_Dcuts_open (q : NonnegativeRationals) : Dcuts_def_open (λ r : NonnegativeRationals, (r < q)%NRat). Proof. intros r Hr. apply hinhpr. generalize (between_ltNonnegativeRationals r q Hr) ; intros n. exists (pr1 n). split. - exact (pr2 (pr2 n)). - exact (pr1 (pr2 n)). Qed. Lemma NonnegativeRationals_to_Dcuts_corr (q : NonnegativeRationals) : Dcuts_def_corr (λ r : NonnegativeRationals, (r < q)%NRat). Proof. intros r Hr0. apply hinhpr. generalize (isdecrel_ltNonnegativeRationals r q) ; apply sumofmaps ; intros Hqr. - right. assert (Hn0 : (0 < q - r)%NRat) by (now apply ispositive_minusNonnegativeRationals). exists (q - r). split. + apply_pr2 (plusNonnegativeRationals_ltcompat_r r). rewrite minusNonnegativeRationals_plus_r. * pattern q at 1 ; rewrite <- isrunit_zeroNonnegativeRationals. apply plusNonnegativeRationals_ltcompat_l. exact Hr0. * now apply lt_leNonnegativeRationals, Hqr. + rewrite minusNonnegativeRationals_plus_r. * now apply isirrefl_ltNonnegativeRationals. * now apply lt_leNonnegativeRationals, Hqr. - now left. Qed. Definition NonnegativeRationals_to_Dcuts (q : NonnegativeRationals) : Dcuts := make_Dcuts (λ r, (r < q)%NRat) (NonnegativeRationals_to_Dcuts_bot q) (NonnegativeRationals_to_Dcuts_open q) (NonnegativeRationals_to_Dcuts_corr q). Lemma isapfun_NonnegativeRationals_to_Dcuts_aux : ∏ q q' : NonnegativeRationals, NonnegativeRationals_to_Dcuts q < NonnegativeRationals_to_Dcuts q' <-> (q < q')%NRat. Proof. intros q q'. split. - apply hinhuniv. intros r. apply istrans_le_lt_ltNonnegativeRationals with (pr1 r). + apply notlt_geNonnegativeRationals. exact (pr1 (pr2 r)). + exact (pr2 (pr2 r)). - intros H. apply hinhpr. exists q ; split. + now apply (isirrefl_ltNonnegativeRationals q). + exact H. Qed. Lemma isapfun_NonnegativeRationals_to_Dcuts : ∏ q q' : NonnegativeRationals, NonnegativeRationals_to_Dcuts q ≠ NonnegativeRationals_to_Dcuts q' → q != q'. Proof. intros q q'. apply sumofmaps ; intros Hap. - now apply ltNonnegativeRationals_noteq, isapfun_NonnegativeRationals_to_Dcuts_aux. - now apply gtNonnegativeRationals_noteq, isapfun_NonnegativeRationals_to_Dcuts_aux. Qed. Lemma isapfun_NonnegativeRationals_to_Dcuts' : ∏ q q' : NonnegativeRationals, q != q' → NonnegativeRationals_to_Dcuts q ≠ NonnegativeRationals_to_Dcuts q'. Proof. intros q q' H. apply noteq_ltorgtNonnegativeRationals in H. induction H as [H | H]. - now left ; apply (pr2 (isapfun_NonnegativeRationals_to_Dcuts_aux _ _)). - now right ; apply (pr2 (isapfun_NonnegativeRationals_to_Dcuts_aux _ _)). Qed. Definition Dcuts_zero : Dcuts := NonnegativeRationals_to_Dcuts 0%NRat. Definition Dcuts_one : Dcuts := NonnegativeRationals_to_Dcuts 1%NRat. Definition Dcuts_two : Dcuts := NonnegativeRationals_to_Dcuts 2. Notation "0" := Dcuts_zero : Dcuts_scope. Notation "1" := Dcuts_one : Dcuts_scope. Notation "2" := Dcuts_two : Dcuts_scope. (** Various usefull theorems *) Lemma Dcuts_zero_empty : ∏ r : NonnegativeRationals, neg (r ∈ 0). Proof. intros r ; simpl. change (neg (r < 0)%NRat). now apply isnonnegative_NonnegativeRationals'. Qed. Lemma Dcuts_notempty_notzero : ∏ (x : Dcuts) (r : NonnegativeRationals), r ∈ x -> x ≠ 0. Proof. intros x r Hx. right. apply hinhpr. exists r. split. - now apply Dcuts_zero_empty. - exact Hx. Qed. Lemma Dcuts_ge_0 : ∏ x : Dcuts, Dcuts_zero <= x. Proof. intros x r Hr. apply fromempty. revert Hr. now apply Dcuts_zero_empty. Qed. Lemma Dcuts_notlt_0 : ∏ x : Dcuts, ¬ (x < Dcuts_zero). Proof. intros x. unfold neg. apply factor_through_squash. - exact isapropempty. - intros r. exact (Dcuts_zero_empty _ (pr2 (pr2 r))). Qed. Lemma Dcuts_apzero_notempty : ∏ (x : Dcuts), (0%NRat ∈ x) <-> x ≠ 0. Proof. intros x ; split. - now apply Dcuts_notempty_notzero. - apply sumofmaps. + apply hinhuniv ; intros r. apply fromempty. now apply (Dcuts_zero_empty _ (pr2 (pr2 r))). + apply hinhuniv ; intros r. apply is_Dcuts_bot with (1 := pr2 (pr2 r)). now apply isnonnegative_NonnegativeRationals. Qed. Lemma NonnegativeRationals_to_Dcuts_notin_le : ∏ (x : Dcuts) (r : NonnegativeRationals), ¬ (r ∈ x) -> x <= NonnegativeRationals_to_Dcuts r. Proof. intros x r Hr q Hq. simpl. now apply (Dcuts_finite x). Qed. (** ** Addition in Dcuts *) Section Dcuts_plus. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_plus_val : hsubtype NonnegativeRationals := λ r : NonnegativeRationals, ((X r) ⨿ (Y r)) ∨ (∑ xy : NonnegativeRationals × NonnegativeRationals, (r = (pr1 xy + pr2 xy)%NRat) × ((X (pr1 xy)) × (Y (pr2 xy)))). Lemma Dcuts_plus_bot : Dcuts_def_bot Dcuts_plus_val. Proof. intros r Hr n Hn. revert Hr ; apply hinhfun ; apply sumofmaps ; [apply sumofmaps ; intros Hr | intros xy]. - left ; left. now apply X_bot with r. - left ; right. now apply Y_bot with r. - right. generalize (isdeceq_NonnegativeRationals r 0%NRat) ; apply sumofmaps ; intros Hr0. + rewrite Hr0 in Hn. apply NonnegativeRationals_eq0_le0 in Hn. exists (0%NRat,,0%NRat). rewrite Hn ; simpl. repeat split. * now rewrite isrunit_zeroNonnegativeRationals. * apply X_bot with (1 := pr1 (pr2 (pr2 xy))). apply isnonnegative_NonnegativeRationals. * apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). apply isnonnegative_NonnegativeRationals. + set (nx := (pr1 (pr1 xy) * (n / r))%NRat). set (ny := (pr2 (pr1 xy) * (n / r))%NRat). exists (nx,,ny). repeat split. * unfold nx,ny ; simpl. rewrite <- isrdistr_mult_plusNonnegativeRationals, <- (pr1 (pr2 xy)). rewrite multdivNonnegativeRationals. ** reflexivity. ** now apply NonnegativeRationals_neq0_gt0. * apply X_bot with (1 := pr1 (pr2 (pr2 xy))). apply multNonnegativeRationals_le1_r. now apply divNonnegativeRationals_le1. * apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). apply multNonnegativeRationals_le1_r. now apply divNonnegativeRationals_le1. Qed. Lemma Dcuts_plus_open : Dcuts_def_open Dcuts_plus_val. Proof. intros r. apply hinhuniv, sumofmaps. - apply sumofmaps ; intro Hr. + generalize (X_open r Hr). apply hinhfun ; intros n. exists (pr1 n). split. * apply hinhpr ; left ; left. exact (pr1 (pr2 n)). * exact (pr2 (pr2 n)). + generalize (Y_open r Hr). apply hinhfun ; intros n. exists (pr1 n). split. * apply hinhpr ; left ; right. exact (pr1 (pr2 n)). * exact (pr2 (pr2 n)). - intros xy. generalize (X_open _ (pr1 (pr2 (pr2 xy)))) (Y_open _ (pr2 (pr2 (pr2 xy)))). apply hinhfun2. intros nx ny. exists (pr1 nx + pr1 ny). split. + apply hinhpr ; right ; exists (pr1 nx ,, pr1 ny). repeat split. * exact (pr1 (pr2 nx)). * exact (pr1 (pr2 ny)). + pattern r at 1 ; rewrite (pr1 (pr2 xy)). apply plusNonnegativeRationals_ltcompat. * exact (pr2 (pr2 nx)). * exact (pr2 (pr2 ny)). Qed. Lemma Dcuts_plus_corr : Dcuts_def_corr Dcuts_plus_val. Proof. intros c Hc. apply ispositive_NQhalf in Hc. generalize (X_corr _ Hc) (Y_corr _ Hc). apply hinhfun2 ; apply (sumofmaps (Z := _ → _)) ; intros Hx ; apply sumofmaps ; intros Hy. - left. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps. + apply sumofmaps ; intros Hz. * apply Hx. apply X_bot with (1 := Hz). pattern c at 2 ; rewrite (NQhalf_double c). apply plusNonnegativeRationals_le_r. * apply Hy. apply Y_bot with (1 := Hz). pattern c at 2 ; rewrite (NQhalf_double c). apply plusNonnegativeRationals_le_r. + intros xy. generalize (isdecrel_ltNonnegativeRationals (pr1 (pr1 xy)) (c / 2)%NRat) ; apply sumofmaps ; intros Hx'. * generalize (isdecrel_ltNonnegativeRationals (pr2 (pr1 xy)) (c / 2)%NRat) ; apply sumofmaps ; intros Hy'. ** apply (isirrefl_isStrongOrder ltNonnegativeRationals c). pattern c at 2 ; rewrite (NQhalf_double c). pattern c at 1 ; rewrite (pr1 (pr2 xy)). apply plusNonnegativeRationals_ltcompat. *** exact Hx'. *** exact Hy'. ** apply Hy. apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). now apply notlt_geNonnegativeRationals ; apply Hy'. * apply Hx. apply X_bot with (1 := pr1 (pr2 (pr2 xy))). now apply notlt_geNonnegativeRationals ; apply Hx'. - right. rename Hy into q. exists (pr1 q) ; split. + apply hinhpr. left ; right ; exact (pr1 (pr2 q)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps. * apply sumofmaps ; [intros Xq | intros Yq']. ** apply Hx ; apply X_bot with (1 := Xq). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_le_l. ** apply (pr2 (pr2 q)) ; apply Y_bot with (1 := Yq'). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_le_r. * intros xy. apply (isirrefl_isStrongOrder ltNonnegativeRationals (pr1 q + c)). pattern c at 2; rewrite (NQhalf_double c). pattern (pr1 q + c) at 1 ; rewrite (pr1 (pr2 xy)). rewrite <- isassoc_plusNonnegativeRationals. rewrite iscomm_plusNonnegativeRationals. apply plusNonnegativeRationals_ltcompat. ** apply notge_ltNonnegativeRationals ; intro H. apply (pr2 (pr2 q)) ; apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). exact H. ** apply notge_ltNonnegativeRationals ; intro H. apply Hx ; apply X_bot with (1 := pr1 (pr2 (pr2 xy))). exact H. - right. rename Hx into q. exists (pr1 q) ; split. + apply hinhpr. left ; left ; exact (pr1 (pr2 q)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps. * apply sumofmaps ; [intros Xq' | intros Yq]. ** apply (pr2 (pr2 q)) ; apply X_bot with (1 := Xq'). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_le_r. ** apply Hy ; apply Y_bot with (1 := Yq). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_le_l. * intros xy. apply (isirrefl_isStrongOrder ltNonnegativeRationals (pr1 q + c)). pattern c at 2; rewrite (NQhalf_double c). pattern (pr1 q + c) at 1 ; rewrite (pr1 (pr2 xy)). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_ltcompat. ** apply notge_ltNonnegativeRationals ; intro H. apply (pr2 (pr2 q)) ; apply X_bot with (1 := pr1 (pr2 (pr2 xy))). exact H. ** apply notge_ltNonnegativeRationals ; intro H. apply Hy ; apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). exact H. - right. rename Hx into qx ; rename Hy into qy. exists (pr1 qx + pr1 qy). split. + apply hinhpr. right. exists (pr1 qx,,pr1 qy) ; repeat split. * exact (pr1 (pr2 qx)). * exact (pr1 (pr2 qy)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps. * apply sumofmaps ; [ intros Xq' | intros Yq']. ** apply (pr2 (pr2 qx)), X_bot with (1 := Xq'). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_r. rewrite isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_le_r. ** apply (pr2 (pr2 qy)), Y_bot with (1 := Yq'). pattern c at 2; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_r. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_le_r. apply plusNonnegativeRationals_le_l. * intros xy. apply (isirrefl_isStrongOrder ltNonnegativeRationals (pr1 qx + pr1 qy + c)). pattern c at 2; rewrite (NQhalf_double c). pattern (pr1 qx + pr1 qy + c) at 1 ; rewrite (pr1 (pr2 xy)). rewrite <- isassoc_plusNonnegativeRationals. rewrite (isassoc_plusNonnegativeRationals (pr1 qx) (pr1 qy) (c / 2)%NRat). rewrite (iscomm_plusNonnegativeRationals (pr1 qy)). rewrite <- isassoc_plusNonnegativeRationals. rewrite (isassoc_plusNonnegativeRationals (pr1 qx + (c/2)%NRat)). apply plusNonnegativeRationals_ltcompat. ** apply notge_ltNonnegativeRationals ; intro H. apply (pr2 (pr2 qx)) ; apply X_bot with (1 := pr1 (pr2 (pr2 xy))) ; exact H. ** apply notge_ltNonnegativeRationals ; intro H. apply (pr2 (pr2 qy)) ; apply Y_bot with (1 := pr2 (pr2 (pr2 xy))) ; exact H. Qed. End Dcuts_plus. Definition Dcuts_plus (X Y : Dcuts) : Dcuts := make_Dcuts (Dcuts_plus_val (pr1 X) (pr1 Y)) (Dcuts_plus_bot (pr1 X) (is_Dcuts_bot X) (pr1 Y) (is_Dcuts_bot Y)) (Dcuts_plus_open (pr1 X) (is_Dcuts_open X) (pr1 Y) (is_Dcuts_open Y)) (Dcuts_plus_corr (pr1 X) (is_Dcuts_bot X) (is_Dcuts_corr X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). (** ** Multiplication in Dcuts *) Section Dcuts_NQmult. Context (x : NonnegativeRationals). Context (Hx : (0 < x)%NRat). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_finite : Dcuts_def_finite Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_NQmult_val : hsubtype NonnegativeRationals := λ r, ∃ ry : NonnegativeRationals, r = x * ry × Y ry. Lemma Dcuts_NQmult_bot : Dcuts_def_bot Dcuts_NQmult_val. Proof. intros r Hr n Hn. revert Hr ; apply hinhfun ; intros ry. generalize (isdeceq_NonnegativeRationals r 0%NRat) ; apply sumofmaps ; intros Hr0. - rewrite Hr0 in Hn. apply NonnegativeRationals_eq0_le0 in Hn. exists 0%NRat. rewrite Hn ; simpl. split. + now rewrite israbsorb_zero_multNonnegativeRationals. + apply Y_bot with (1 := pr2 (pr2 ry)). apply isnonnegative_NonnegativeRationals. - set (ny := pr1 ry * (n / r)%NRat). exists ny. split. + unfold ny ; simpl. rewrite <- isassoc_multNonnegativeRationals, <- (pr1 (pr2 ry)). rewrite multdivNonnegativeRationals. * reflexivity. * now apply NonnegativeRationals_neq0_gt0. + apply Y_bot with (1 := pr2 (pr2 ry)). apply multNonnegativeRationals_le1_r. now apply divNonnegativeRationals_le1. Qed. Lemma Dcuts_NQmult_open : Dcuts_def_open Dcuts_NQmult_val. Proof. intros r. apply hinhuniv ; intros ry. generalize (Y_open _ (pr2 (pr2 ry))). apply hinhfun. intros ny. exists (x * pr1 ny). split. - apply hinhpr ; exists (pr1 ny). split. + reflexivity. + exact (pr1 (pr2 ny)). - pattern r at 1 ; rewrite (pr1 (pr2 ry)). apply multNonnegativeRationals_ltcompat_l. + exact Hx. + exact (pr2 (pr2 ny)). Qed. Lemma Dcuts_NQmult_finite : Dcuts_def_finite Dcuts_NQmult_val. Proof. revert Y_finite. apply hinhfun. intros y. exists (x * pr1 y). unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros ry. generalize (pr1 (pr2 ry)). apply gtNonnegativeRationals_noteq. apply (pr2 (lt_gtNonnegativeRationals _ _)). apply (multNonnegativeRationals_ltcompat_l x (pr1 ry) (pr1 y) Hx). apply notge_ltNonnegativeRationals. intro Hy' ; apply (pr2 y). apply Y_bot with (pr1 ry). - exact (pr2 (pr2 ry)). - exact Hy'. Qed. Lemma Dcuts_NQmult_corr : Dcuts_def_corr Dcuts_NQmult_val. Proof. intros c Hc. assert (Hcx : (0 < c / x)%NRat) by (now apply ispositive_divNonnegativeRationals). generalize (Y_corr _ Hcx). apply hinhfun ; apply sumofmaps ; intros Hy. - left. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros ry. generalize (pr1 (pr2 ry)). apply gtNonnegativeRationals_noteq. pattern c at 1 ; rewrite <- (multdivNonnegativeRationals c x). + apply (pr2 (lt_gtNonnegativeRationals _ _)). apply (multNonnegativeRationals_ltcompat_l x (pr1 ry) (c / x)%NRat Hx). apply notge_ltNonnegativeRationals. intro Hy' ; apply Hy. apply Y_bot with (pr1 ry). * exact (pr2 (pr2 ry)). * exact Hy'. + exact Hx. - right. rename Hy into q. exists (x * pr1 q). split. + apply hinhpr. exists (pr1 q). split. * reflexivity. * exact (pr1 (pr2 q)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros ry. generalize (pr1 (pr2 ry)). apply gtNonnegativeRationals_noteq. pattern c at 1; rewrite <- (multdivNonnegativeRationals c x), <-isldistr_mult_plusNonnegativeRationals. * apply (pr2 ( lt_gtNonnegativeRationals _ _)). apply (multNonnegativeRationals_ltcompat_l x (pr1 ry) (pr1 q + c / x)%NRat Hx). apply notge_ltNonnegativeRationals. intro Hy' ; apply (pr2 (pr2 q)). apply Y_bot with (pr1 ry). ** exact (pr2 (pr2 ry)). ** exact Hy'. * exact Hx. Qed. End Dcuts_NQmult. Definition Dcuts_NQmult x (Y : Dcuts) Hx : Dcuts := make_Dcuts (Dcuts_NQmult_val x (pr1 Y)) (Dcuts_NQmult_bot x (pr1 Y) (is_Dcuts_bot Y)) (Dcuts_NQmult_open x Hx (pr1 Y) (is_Dcuts_open Y)) (Dcuts_NQmult_corr x Hx (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). Section Dcuts_mult. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_finite : Dcuts_def_finite Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_mult_val : hsubtype NonnegativeRationals := λ r, ∃ xy : NonnegativeRationals × NonnegativeRationals, r = (pr1 xy * pr2 xy)%NRat × X (pr1 xy) × Y (pr2 xy). Lemma Dcuts_mult_bot : Dcuts_def_bot Dcuts_mult_val. Proof. intros r Hr n Hn. revert Hr ; apply hinhfun ; intros xy. generalize (isdeceq_NonnegativeRationals r 0%NRat) ; apply sumofmaps ; intros Hr0. - rewrite Hr0 in Hn. apply NonnegativeRationals_eq0_le0 in Hn. exists (0%NRat,,0%NRat). rewrite Hn ; simpl. repeat split. + now rewrite israbsorb_zero_multNonnegativeRationals. + apply X_bot with (1 := pr1 (pr2 (pr2 xy))). apply isnonnegative_NonnegativeRationals. + apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). apply isnonnegative_NonnegativeRationals. - set (nx := pr1 (pr1 xy)). set (ny := (pr2 (pr1 xy) * (n / r))%NRat). exists (nx,,ny). repeat split. + unfold nx,ny ; simpl. rewrite <- isassoc_multNonnegativeRationals, <- (pr1 (pr2 xy)). rewrite multdivNonnegativeRationals. * reflexivity. * now apply NonnegativeRationals_neq0_gt0. + exact (pr1 (pr2 (pr2 xy))). + apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). apply multNonnegativeRationals_le1_r. now apply divNonnegativeRationals_le1. Qed. Lemma Dcuts_mult_open : Dcuts_def_open Dcuts_mult_val. Proof. intros r. apply hinhuniv ; intros xy. generalize (X_open _ (pr1 (pr2 (pr2 xy)))) (Y_open _ (pr2 (pr2 (pr2 xy)))). apply hinhfun2. intros nx ny. exists (pr1 nx * pr1 ny). split. - apply hinhpr ; exists (pr1 nx ,, pr1 ny). repeat split. + exact (pr1 (pr2 nx)). + exact (pr1 (pr2 ny)). - pattern r at 1 ; rewrite (pr1 (pr2 xy)). apply multNonnegativeRationals_ltcompat. + exact (pr2 (pr2 nx)). + exact (pr2 (pr2 ny)). Qed. Lemma Dcuts_mult_finite : Dcuts_def_finite Dcuts_mult_val. Proof. revert X_finite Y_finite. apply hinhfun2. intros x y. exists (pr1 x * pr1 y). unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros xy. generalize (isdecrel_ltNonnegativeRationals (pr1 (pr1 xy)) (pr1 x)) ; apply sumofmaps ; intros Hx'. - generalize (isdecrel_ltNonnegativeRationals (pr2 (pr1 xy)) (pr1 y)) ; apply sumofmaps ; intros Hy'. + apply (isirrefl_isStrongOrder ltNonnegativeRationals (pr1 x * pr1 y)). pattern (pr1 x * pr1 y) at 1 ; rewrite (pr1 (pr2 xy)). now apply multNonnegativeRationals_ltcompat. + apply (pr2 y). apply Y_bot with (1 := pr2 (pr2 (pr2 xy))). now apply notlt_geNonnegativeRationals ; apply Hy'. - apply (pr2 x). apply X_bot with (1 := pr1 (pr2 (pr2 xy))). now apply notlt_geNonnegativeRationals ; apply Hx'. Qed. Context (Hx1 : ¬ X 1%NRat). Lemma Dcuts_mult_corr_aux : Dcuts_def_corr Dcuts_mult_val. Proof. intros c Hc0. apply ispositive_NQhalf in Hc0. generalize (Y_corr _ Hc0). apply hinhuniv ; apply sumofmaps ; intros Hy. - apply hinhpr ; left. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros xy. generalize (pr1 (pr2 xy)). apply gtNonnegativeRationals_noteq. pattern c at 1 ; rewrite <- (islunit_oneNonnegativeRationals c). apply multNonnegativeRationals_ltcompat. + apply notge_ltNonnegativeRationals ; intro H. apply Hx1, X_bot with (1 := pr1 (pr2 (pr2 xy))). exact H. + apply notge_ltNonnegativeRationals ; intro H. apply Hy, Y_bot with (1 := pr2 (pr2 (pr2 xy))). apply istrans_leNonnegativeRationals with (2 := H). pattern c at 2 ; rewrite (NQhalf_double c). now apply plusNonnegativeRationals_le_r. - rename Hy into y. assert (Hq1 : (0 < pr1 y + c / 2)%NRat). { apply istrans_lt_le_ltNonnegativeRationals with (c / 2)%NRat. { exact Hc0. } now apply plusNonnegativeRationals_le_l. } set (cx := ((c / 2) / (pr1 y + (c / 2)))%NRat). assert (Hcx0 : (0 < cx)%NRat) by (now apply ispositive_divNonnegativeRationals). generalize (X_corr _ Hcx0) ; apply hinhfun ; apply sumofmaps ; intros H. + left. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros xy. generalize (pr1 (pr2 xy)). apply gtNonnegativeRationals_noteq. apply istrans_ltNonnegativeRationals with (c / 2)%NRat. * rewrite <- (multdivNonnegativeRationals (c / 2)%NRat (pr1 y + (c / 2)%NRat)). ** rewrite iscomm_multNonnegativeRationals. apply multNonnegativeRationals_ltcompat. *** apply notge_ltNonnegativeRationals ; intro H0. apply (pr2 (pr2 y)), Y_bot with (1 := pr2 (pr2 (pr2 xy))). exact H0. *** apply notge_ltNonnegativeRationals ; intro H0. apply H, X_bot with (1 := pr1 (pr2 (pr2 xy))). exact H0. ** exact Hq1. * rewrite <- (islunit_zeroNonnegativeRationals (c / 2)%NRat). pattern c at 2 ; rewrite (NQhalf_double c). now apply plusNonnegativeRationals_ltcompat_r. + right. rename H into x. exists (pr1 x * pr1 y) ; repeat split. * apply hinhpr. exists (pr1 x,, pr1 y) ; simpl ; repeat split. ** exact (pr1 (pr2 x)). ** exact (pr1 (pr2 y)). * unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros xy. generalize (pr1 (pr2 xy)). apply gtNonnegativeRationals_noteq. apply istrans_lt_le_ltNonnegativeRationals with ((pr1 x + cx)* (pr1 y + (c / 2)%NRat)). ** apply multNonnegativeRationals_ltcompat. *** apply notge_ltNonnegativeRationals. intros H ; apply (pr2 (pr2 x)), X_bot with (1 := pr1 (pr2 (pr2 xy))). exact H. *** apply notge_ltNonnegativeRationals. intros H ; apply (pr2 (pr2 y)), Y_bot with (1 := pr2 (pr2 (pr2 xy))). exact H. ** rewrite isrdistr_mult_plusNonnegativeRationals, (iscomm_multNonnegativeRationals cx). unfold cx ; rewrite multdivNonnegativeRationals. *** pattern c at 3; rewrite (NQhalf_double c), <- isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_r. rewrite isldistr_mult_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. rewrite iscomm_multNonnegativeRationals. apply multNonnegativeRationals_le1_r. apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. intro H ; apply Hx1. now apply X_bot with (1 := pr1 (pr2 x)). *** exact Hq1. Qed. End Dcuts_mult. Section Dcuts_mult'. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_finite : Dcuts_def_finite Y). Context (Y_corr : Dcuts_def_corr Y). Lemma Dcuts_mult_corr : Dcuts_def_corr (Dcuts_mult_val X Y). Proof. intros c Hc. generalize (X_corr 1%NRat ispositive_oneNonnegativeRationals). apply hinhuniv ; apply sumofmaps ; [ intros Hx1 | intros x]. - now apply Dcuts_mult_corr_aux. - assert (Hx1 : (0 < pr1 x + 1)%NRat). { apply istrans_lt_le_ltNonnegativeRationals with (1 := ispositive_oneNonnegativeRationals). apply plusNonnegativeRationals_le_l. } assert (Heq : Dcuts_mult_val X Y = (Dcuts_NQmult_val (pr1 x + 1%NRat) (Dcuts_mult_val (Dcuts_NQmult_val (/ (pr1 x + 1))%NRat X) Y))). { apply funextfun ; intro r. apply hPropUnivalence. - apply hinhfun. intros xy. exists (r / (pr1 x + 1))%NRat ; split. + now rewrite multdivNonnegativeRationals. + apply hinhpr. exists (pr1 (pr1 xy) / (pr1 x + 1%NRat),,pr2 (pr1 xy))%NRat ; simpl ; repeat split. * unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals, (iscomm_multNonnegativeRationals (/ (pr1 x + 1))%NRat). rewrite <- isassoc_multNonnegativeRationals. now pattern r at 1 ; rewrite (pr1 (pr2 xy)). * apply hinhpr. exists (pr1 (pr1 xy)) ; split. ** now apply iscomm_multNonnegativeRationals. ** exact (pr1 (pr2 (pr2 xy))). * exact (pr2 (pr2 (pr2 xy))). - apply hinhuniv. intros rx. generalize (pr2 (pr2 rx)) ; apply hinhuniv. intros xy. generalize (pr1 (pr2 (pr2 xy))) ; apply hinhfun ; intros rx'. rewrite (pr1 (pr2 rx)), (pr1 (pr2 xy)), (pr1 (pr2 rx')). exists (pr1 rx',,pr2 (pr1 xy)) ; repeat split. + now rewrite <- !isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals. + exact (pr2 (pr2 rx')). + exact (pr2 (pr2 (pr2 xy))). } rewrite Heq. revert c Hc. apply Dcuts_NQmult_corr. + exact Hx1. + apply Dcuts_mult_bot, Y_bot. now apply Dcuts_NQmult_bot. + apply Dcuts_mult_corr_aux. * now apply Dcuts_NQmult_bot. * apply Dcuts_NQmult_corr. ** now apply ispositive_invNonnegativeRationals. ** exact X_bot. ** exact X_corr. * exact Y_bot. * exact Y_corr. * unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros rx. apply (pr2 (pr2 x)), X_bot with (1 := pr2 (pr2 rx)). rewrite <- (isrunit_oneNonnegativeRationals (pr1 x + 1%NRat)). pattern 1%NRat at 2; rewrite (pr1 (pr2 rx)), <- isassoc_multNonnegativeRationals. rewrite isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals. ** now apply isrefl_leNonnegativeRationals. ** exact Hx1. Qed. End Dcuts_mult'. Definition Dcuts_mult (X Y : Dcuts) : Dcuts := make_Dcuts (Dcuts_mult_val (pr1 X) (pr1 Y)) (Dcuts_mult_bot (pr1 X) (is_Dcuts_bot X) (pr1 Y) (is_Dcuts_bot Y)) (Dcuts_mult_open (pr1 X) (is_Dcuts_open X) (pr1 Y) (is_Dcuts_open Y)) (Dcuts_mult_corr (pr1 X) (is_Dcuts_bot X) (is_Dcuts_corr X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). (** ** Multiplicative inverse in Dcuts *) Section Dcuts_inv. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (X_0 : X 0%NRat). Definition Dcuts_inv_val : hsubtype NonnegativeRationals := λ r : NonnegativeRationals, hexists (λ l : NonnegativeRationals, (∏ rx : NonnegativeRationals, X rx -> (r * rx <= l)%NRat) × (0 < l)%NRat × (l < 1)%NRat). Lemma Dcuts_inv_in : ∏ x, (0 < x)%NRat -> X x -> (Dcuts_inv_val (/ x)%NRat) -> empty. Proof. intros x Hx0 Xx. unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros l. set (H := pr1 (pr2 l) _ Xx). rewrite islinv_NonnegativeRationals in H. - apply (pr2 (notlt_geNonnegativeRationals _ _)) in H. now apply H, (pr2 (pr2 (pr2 l))). - exact Hx0. Qed. Lemma Dcuts_inv_out : ∏ x, ¬ (X x) -> ∏ y, (x < y)%NRat -> Dcuts_inv_val (/ y)%NRat. Proof. intros x nXx y Hy. apply hinhpr. exists (x / y)%NRat ; repeat split. - intros rx Hrx. unfold divNonnegativeRationals. rewrite iscomm_multNonnegativeRationals. apply multNonnegativeRationals_lecompat_r. apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. intros H ; apply nXx. now apply X_bot with (1 := Hrx). - apply ispositive_divNonnegativeRationals. + apply notge_ltNonnegativeRationals. intros H ; apply nXx. now apply X_bot with (1 := X_0). + apply istrans_le_lt_ltNonnegativeRationals with (2 := Hy). now apply isnonnegative_NonnegativeRationals. - apply_pr2 (multNonnegativeRationals_ltcompat_r y). + apply istrans_le_lt_ltNonnegativeRationals with (2 := Hy). now apply isnonnegative_NonnegativeRationals. + unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, islunit_oneNonnegativeRationals, isrunit_oneNonnegativeRationals. * exact Hy. * apply istrans_le_lt_ltNonnegativeRationals with (2 := Hy). now apply isnonnegative_NonnegativeRationals. Qed. Lemma Dcuts_inv_bot : Dcuts_def_bot Dcuts_inv_val. Proof. intros r Hr q Hq. revert Hr. apply hinhfun ; intros l. exists (pr1 l) ; repeat split. - intros rx Xrx. apply istrans_leNonnegativeRationals with (2 := pr1 (pr2 l) _ Xrx). now apply multNonnegativeRationals_lecompat_r. - exact (pr1 (pr2 (pr2 l))). - exact (pr2 (pr2 (pr2 l))). Qed. Lemma Dcuts_inv_open : Dcuts_def_open Dcuts_inv_val. Proof. intros r. apply hinhuniv. intros l. generalize (eq0orgt0NonnegativeRationals r) ; apply sumofmaps ; intros Hr0. - rewrite Hr0 in l |- * ; clear r Hr0. revert X_finite. apply hinhfun. intros r'. set (r := NQmax 2%NRat (pr1 r')). assert (Hr1 : (1 < r)%NRat). { apply istrans_lt_le_ltNonnegativeRationals with (2 := NQmax_le_l _ _). exact one_lt_twoNonnegativeRationals. } assert (Hr0 : (0 < r)%NRat). { simple refine (istrans_le_lt_ltNonnegativeRationals _ _ _ _ Hr1). now apply isnonnegative_NonnegativeRationals. } exists (/ (r * r))%NRat ; split. + apply hinhpr. exists (/ r)%NRat ; repeat split. * intros rx Xrx. apply (multNonnegativeRationals_lecompat_l' (r * r)). ** now apply ispositive_multNonnegativeRationals. ** rewrite <- isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals. *** rewrite isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. **** apply istrans_leNonnegativeRationals with (2 := NQmax_le_r _ _). apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals ; intro H ; apply (pr2 r'). now apply X_bot with (1 := Xrx). **** exact Hr0. *** now apply ispositive_multNonnegativeRationals. * now apply ispositive_invNonnegativeRationals. * apply_pr2 (multNonnegativeRationals_ltcompat_l r). ** assumption. ** now rewrite isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. + apply ispositive_invNonnegativeRationals. now apply ispositive_multNonnegativeRationals. - set (l' := between_ltNonnegativeRationals _ _ (pr2 (pr2 (pr2 l)))). apply hinhpr. exists ((pr1 l'/pr1 l) * r)%NRat ; split. + apply hinhpr. exists (pr1 l') ; repeat split. * intros rx Xrx. rewrite isassoc_multNonnegativeRationals. pattern l' at 1 ; rewrite <- (multdivNonnegativeRationals (pr1 l') (pr1 l)), iscomm_multNonnegativeRationals. ** apply multNonnegativeRationals_lecompat_r. now apply (pr1 (pr2 l)). ** exact (pr1 (pr2 (pr2 l))). * apply istrans_le_lt_ltNonnegativeRationals with (2 := pr1 (pr2 l')). now apply isnonnegative_NonnegativeRationals. * exact (pr2 (pr2 l')). + pattern r at 1 ; rewrite <- (islunit_oneNonnegativeRationals r). apply multNonnegativeRationals_ltcompat_r. * exact Hr0. * apply_pr2 (multNonnegativeRationals_ltcompat_r (pr1 l)). ** exact (pr1 (pr2 (pr2 l))). ** rewrite islunit_oneNonnegativeRationals. rewrite iscomm_multNonnegativeRationals, multdivNonnegativeRationals. *** exact (pr1 (pr2 l')). *** exact (pr1 (pr2 (pr2 l))). Qed. Context (X_1 : X 1%NRat). Lemma Dcuts_inv_corr_aux : Dcuts_def_corr Dcuts_inv_val. Proof. assert (∏ c, (0 < c)%NRat -> hexists (λ q : NonnegativeRationals, X q × ¬ X (q + c))). { intros c Hc0. generalize (X_corr c Hc0) ; apply hinhuniv ; apply sumofmaps ; [ intros nXc | intros H]. - apply hinhpr. exists 0%NRat ; split. + exact X_0. + now rewrite islunit_zeroNonnegativeRationals. - apply hinhpr ; exact H. } clear X_corr ; rename X0 into X_corr. intros c Hc0. apply ispositive_NQhalf in Hc0. specialize (X_corr _ Hc0) ; revert X_corr. apply hinhfun ; intros r. right. exists (/ (NQmax 1%NRat (pr1 r) + c))%NRat ; split. - apply Dcuts_inv_out with (1 := pr2 (pr2 r)). pattern c at 2; rewrite (NQhalf_double c), <- isassoc_plusNonnegativeRationals. eapply istrans_le_lt_ltNonnegativeRationals, plusNonnegativeRationals_lt_r. + apply plusNonnegativeRationals_lecompat_r ; apply NQmax_le_r. + exact Hc0. - assert (Xmax : X (NQmax 1%NRat (pr1 r))). { apply NQmax_case. { exact X_1. } exact (pr1 (pr2 r)). } assert (Hmax : (0 < NQmax 1 (pr1 r))%NRat). { eapply istrans_lt_le_ltNonnegativeRationals, NQmax_le_l. now eapply ispositive_oneNonnegativeRationals. } intro Hinv ; apply (Dcuts_inv_in _ Hmax Xmax), Dcuts_inv_bot with (1 := Hinv). apply lt_leNonnegativeRationals, minusNonnegativeRationals_ltcompat_l' with (/ (NQmax 1 (pr1 r) + c))%NRat. rewrite plusNonnegativeRationals_minus_l. rewrite minus_divNonnegativeRationals, plusNonnegativeRationals_minus_l. * unfold divNonnegativeRationals ; apply_pr2 (multNonnegativeRationals_ltcompat_r (NQmax 1 (pr1 r) * (NQmax 1 (pr1 r) + c))%NRat). ** apply ispositive_multNonnegativeRationals. *** exact Hmax. *** now apply ispositive_plusNonnegativeRationals_l. ** rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals. *** apply multNonnegativeRationals_ltcompat_l. { now apply_pr2 ispositive_NQhalf. } pattern 1%NRat at 1 ; rewrite <- (islunit_oneNonnegativeRationals 1%NRat). apply istrans_le_lt_ltNonnegativeRationals with (NQmax 1 (pr1 r) * 1)%NRat. { now apply multNonnegativeRationals_lecompat_r, NQmax_le_l. } apply multNonnegativeRationals_ltcompat_l. { exact Hmax. } apply istrans_le_lt_ltNonnegativeRationals with (1 := NQmax_le_l _ (pr1 r)). apply plusNonnegativeRationals_lt_r. now apply_pr2 ispositive_NQhalf. *** apply ispositive_multNonnegativeRationals. { exact Hmax. } now apply ispositive_plusNonnegativeRationals_l. * now apply ispositive_plusNonnegativeRationals_l. Qed. End Dcuts_inv. Section Dcuts_inv'. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (X_0 : X 0%NRat). Lemma Dcuts_inv_corr : Dcuts_def_corr (Dcuts_inv_val X). Proof. generalize (X_open _ X_0) ; apply (hinhuniv (P := make_hProp _ (isaprop_Dcuts_def_corr _))) ; intros x. set (Y := Dcuts_NQmult_val (/ (pr1 x))%NRat X). assert (Y_1 : Y 1%NRat). { unfold Y ; apply hinhpr ; exists (pr1 x) ; split. - apply pathsinv0, islinv_NonnegativeRationals. exact (pr2 (pr2 x)). - exact (pr1 (pr2 x)). } assert (Heq : Dcuts_inv_val X = Dcuts_NQmult_val (/(pr1 x))%NRat (Dcuts_inv_val Y)). { apply funextfun ; intro r. apply hPropUnivalence. - apply hinhfun ; intros l. exists (pr1 x * r) ; split. + rewrite <- isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, islunit_oneNonnegativeRationals. * reflexivity. * exact (pr2 (pr2 x)). + apply hinhpr. exists (pr1 l) ; repeat split. * intros q ; unfold Y. apply hinhuniv ; intros s. rewrite (pr1 (pr2 s)). rewrite (iscomm_multNonnegativeRationals (pr1 x)), <- isassoc_multNonnegativeRationals. rewrite iscomm_multNonnegativeRationals, !isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals, iscomm_multNonnegativeRationals. ** apply (pr1 (pr2 l)). exact (pr2 (pr2 s)). ** exact (pr2 (pr2 x)). * exact (pr1 (pr2 (pr2 l))). * exact (pr2 (pr2 (pr2 l))). - apply hinhuniv. intros q. rewrite (pr1 (pr2 q)). generalize (pr2 (pr2 q)). apply hinhfun ; intros l. exists (pr1 l) ; repeat split. + intros s Xs. rewrite (iscomm_multNonnegativeRationals (/ pr1 x)%NRat), isassoc_multNonnegativeRationals. apply (pr1 (pr2 l)). unfold Y ; apply hinhpr. now exists s. + exact (pr1 (pr2 (pr2 l))). + exact (pr2 (pr2 (pr2 l))). } rewrite Heq. apply Dcuts_NQmult_corr. - apply ispositive_invNonnegativeRationals. exact (pr2 (pr2 x)). - now apply Dcuts_inv_bot. - apply Dcuts_inv_corr_aux. + now unfold Y ; apply Dcuts_NQmult_bot. + unfold Y ; apply Dcuts_NQmult_corr. * apply ispositive_invNonnegativeRationals. exact (pr2 (pr2 x)). * exact X_bot. * exact X_corr. + apply hinhpr ; exists 0%NRat ; split. * now rewrite israbsorb_zero_multNonnegativeRationals. * exact X_0. + exact Y_1. Qed. End Dcuts_inv'. Definition Dcuts_inv (X : Dcuts) (X_0 : X ≠ 0) : Dcuts. Proof. intros. apply (make_Dcuts (Dcuts_inv_val (pr1 X))). - now apply Dcuts_inv_bot. - apply Dcuts_inv_open. + now apply is_Dcuts_bot. + now apply Dcuts_def_corr_finite, is_Dcuts_corr. - apply Dcuts_inv_corr. + now apply is_Dcuts_bot. + now apply is_Dcuts_open. + now apply is_Dcuts_corr. + now apply_pr2 Dcuts_apzero_notempty. Defined. (** ** Algebraic properties *) Lemma Dcuts_NQmult_mult : ∏ (x : NonnegativeRationals) (y : Dcuts) (Hx0 : (0 < x)%NRat), Dcuts_NQmult x y Hx0 = Dcuts_mult (NonnegativeRationals_to_Dcuts x) y. Proof. intros x y Hx0. apply Dcuts_eq_is_eq. intros r ; split. - apply hinhuniv. intros ry. generalize (is_Dcuts_open _ _ (pr2 (pr2 ry))). apply hinhfun ; intros ry'. exists (((x * (pr1 ry)) / (pr1 ry'))%NRat,, (pr1 ry')). simpl. assert (Hry' : (0 < pr1 ry')%NRat). { eapply istrans_le_lt_ltNonnegativeRationals, (pr2 (pr2 ry')). apply isnonnegative_NonnegativeRationals. } split ; [ | split]. + unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. * exact (pr1 (pr2 ry)). * exact Hry'. + pattern x at 2. rewrite <- (isrunit_oneNonnegativeRationals x). unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals. apply multNonnegativeRationals_ltcompat_l. * exact Hx0. * rewrite <- (isrinv_NonnegativeRationals (pr1 ry')). ** apply multNonnegativeRationals_ltcompat_r. *** apply ispositive_invNonnegativeRationals. exact Hry'. *** exact (pr2 (pr2 ry')). ** exact Hry'. + exact (pr1 (pr2 ry')). - apply hinhfun ; simpl. intros xy. exists (pr1 (pr1 xy) * pr2 (pr1 xy) / x). split. + rewrite iscomm_multNonnegativeRationals. unfold divNonnegativeRationals. rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. * exact (pr1 (pr2 xy)). * exact Hx0. + apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 xy))). pattern (pr2 (pr1 xy)) at 2. rewrite <- (isrunit_oneNonnegativeRationals (pr2 (pr1 xy))), <- (isrinv_NonnegativeRationals x), <- isassoc_multNonnegativeRationals. * apply multNonnegativeRationals_lecompat_r. rewrite iscomm_multNonnegativeRationals. apply multNonnegativeRationals_lecompat_l. apply lt_leNonnegativeRationals. exact (pr1 (pr2 (pr2 xy))). * exact Hx0. Qed. Lemma iscomm_Dcuts_plus : iscomm Dcuts_plus. Proof. assert (H : ∏ x y, ∏ x0 : NonnegativeRationals, x0 ∈ Dcuts_plus x y -> x0 ∈ Dcuts_plus y x). { intros x y r. apply hinhuniv, sumofmaps ; simpl pr1. - apply sumofmaps ; intros Hr. + now apply hinhpr ; left ; right. + now apply hinhpr ; left ; left. - intros xy. apply hinhpr ; right ; exists (pr2 (pr1 xy),, pr1 (pr1 xy)). repeat split. + pattern r at 1 ; rewrite (pr1 (pr2 xy)). apply iscomm_plusNonnegativeRationals. + exact (pr2 (pr2 (pr2 xy))). + exact (pr1 (pr2 (pr2 xy))). } intros x y. apply Dcuts_eq_is_eq ; intro r ; split. - now apply H. - now apply H. Qed. Lemma Dcuts_plus_lt_l : ∏ x x' y : Dcuts, Dcuts_plus x y < Dcuts_plus x' y -> x < x'. Proof. intros x x' y. apply hinhuniv ; intros r. generalize (pr2 (pr2 r)) ; apply hinhfun ; apply sumofmaps ; [ apply sumofmaps ; [ intros Xr | intros Yr] | intros xy ]. - exists (pr1 r) ; split. + intro H ; apply (pr1 (pr2 r)). now apply hinhpr ; left ; left. + exact Xr. - apply fromempty, (pr1 (pr2 r)). now apply hinhpr ; left ; right. - exists (pr1 (pr1 xy)) ; split. + intro H ; apply (pr1 (pr2 r)). apply hinhpr ; right ; exists (pr1 xy). repeat split. * exact (pr1 (pr2 xy)). * exact H. * exact (pr2 (pr2 (pr2 xy))). + exact (pr1 (pr2 (pr2 xy))). Qed. Lemma islapbinop_Dcuts_plus : islapbinop Dcuts_plus. Proof. intros y x x'. apply sumofmaps ; intros Hlt. - left. now apply Dcuts_plus_lt_l with y. - right. now apply Dcuts_plus_lt_l with y. Qed. Lemma israpbinop_Dcuts_plus : israpbinop Dcuts_plus. Proof. intros x y y'. rewrite !(iscomm_Dcuts_plus x). now apply islapbinop_Dcuts_plus. Qed. Lemma iscomm_Dcuts_mult : iscomm Dcuts_mult. Proof. intros x y. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhfun. intros xy. exists (pr2 (pr1 xy),, pr1 (pr1 xy)) ; repeat split. + rewrite iscomm_multNonnegativeRationals. exact (pr1 (pr2 xy)). + exact (pr2 (pr2 (pr2 xy))). + exact (pr1 (pr2 (pr2 xy))). - apply hinhfun ; intros xy. exists (pr2 (pr1 xy),, pr1 (pr1 xy)) ; repeat split. + rewrite iscomm_multNonnegativeRationals. exact (pr1 (pr2 xy)). + exact (pr2 (pr2 (pr2 xy))). + exact (pr1 (pr2 (pr2 xy))). Qed. Lemma Dcuts_mult_lt_l : ∏ x x' y : Dcuts, Dcuts_mult x y < Dcuts_mult x' y -> x < x'. Proof. intros x x' y. apply hinhuniv ; intros r. generalize (pr2 (pr2 r)). apply hinhfun ; intros xy. exists (pr1 (pr1 xy)) ; split. - intro H ; apply (pr1 (pr2 r)). apply hinhpr ; exists (pr1 xy). repeat split. + exact (pr1 (pr2 xy)). + exact H. + exact (pr2 (pr2 (pr2 xy))). - exact (pr1 (pr2 (pr2 xy))). Qed. Lemma islapbinop_Dcuts_mult : islapbinop Dcuts_mult. Proof. intros y x x'. apply sumofmaps. - intros Hlt. left. now apply Dcuts_mult_lt_l with y. - right. now apply Dcuts_mult_lt_l with y. Qed. Lemma israpbinop_Dcuts_mult : israpbinop Dcuts_mult. Proof. intros x y y'. rewrite !(iscomm_Dcuts_mult x). now apply islapbinop_Dcuts_mult. Qed. Lemma isassoc_Dcuts_plus : isassoc Dcuts_plus. Proof. intros x y z. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv, sumofmaps ; simpl pr1. + apply sumofmaps. * apply hinhuniv, sumofmaps. { apply sumofmaps ; intros Hr. - now apply hinhpr ; left ; left. - apply hinhpr ; left ; right. now apply hinhpr ; left ; left. } { intros xy. apply hinhpr ; right ; exists (pr1 xy). repeat split. - exact (pr1 (pr2 xy)). - exact (pr1 (pr2 (pr2 xy))). - apply hinhpr ; left ; left. exact (pr2 (pr2 (pr2 xy))). } * intros Hr. apply hinhpr ; left ; right. now apply hinhpr ; left ; right. + intros xyz. generalize (pr1 (pr2 (pr2 xyz))) ; apply hinhuniv, sumofmaps. * apply sumofmaps ; intros Hxy. { apply hinhpr ; right ; exists (pr1 xyz). repeat split. - exact (pr1 (pr2 xyz)). - exact Hxy. - apply hinhpr ; left ; right. exact (pr2 (pr2 (pr2 xyz))). } { apply hinhpr ; left ; right. apply hinhpr ; right ; exists (pr1 xyz). repeat split. - exact (pr1 (pr2 xyz)). - exact Hxy. - exact (pr2 (pr2 (pr2 xyz))). } * intros xy. apply hinhpr ; right ; exists (pr1 (pr1 xy),,pr2 (pr1 xy) + pr2 (pr1 xyz)). repeat split ; simpl. { pattern r at 1 ; rewrite (pr1 (pr2 xyz)), (pr1 (pr2 xy)). now apply isassoc_plusNonnegativeRationals. } { exact (pr1 (pr2 (pr2 xy))). } { apply hinhpr ; right ; exists (pr2 (pr1 xy),,pr2 (pr1 xyz)). repeat split. - exact (pr2 (pr2 (pr2 xy))). - exact (pr2 (pr2 (pr2 xyz))). } - apply hinhuniv, sumofmaps. + apply sumofmaps. * intros Hr. apply hinhpr ; left ; left. now apply hinhpr ; left ; left. * apply hinhuniv, sumofmaps. { apply sumofmaps ; intros Hr. - apply hinhpr ; left ; left. now apply hinhpr ; left ; right. - now apply hinhpr ; left ; right. } { intros yz ; simpl in * |-. apply hinhpr ; right ; exists (pr1 yz). repeat split. - exact (pr1 (pr2 yz)). - apply hinhpr ; left ; right. exact (pr1 (pr2 (pr2 yz))). - exact (pr2 (pr2 (pr2 yz))). } + intros xyz. generalize (pr2 (pr2 (pr2 xyz))) ; apply hinhuniv, sumofmaps. * apply sumofmaps ; intros Hyz. { apply hinhpr ; left ; left. apply hinhpr ; right ; exists (pr1 xyz). repeat split. - exact (pr1 (pr2 xyz)). - exact (pr1 (pr2 (pr2 xyz))). - exact Hyz. } { apply hinhpr ; right ; exists (pr1 xyz). repeat split. - exact (pr1 (pr2 xyz)). - apply hinhpr ; left ; left. exact (pr1 (pr2 (pr2 xyz))). - exact Hyz. } * intros yz. apply hinhpr ; right ; exists ((pr1 (pr1 xyz)+ pr1 (pr1 yz),, pr2 (pr1 yz))). repeat split ; simpl. { pattern r at 1 ; rewrite (pr1 (pr2 xyz)), (pr1 (pr2 yz)). now rewrite isassoc_plusNonnegativeRationals. } { apply hinhpr ; right ; exists (pr1 (pr1 xyz),,(pr1 (pr1 yz))). repeat split. - exact (pr1 (pr2 (pr2 xyz))). - exact (pr1 (pr2 (pr2 yz))). } { exact (pr2 (pr2 (pr2 yz))). } Qed. Lemma islunit_Dcuts_plus_zero : islunit Dcuts_plus 0. Proof. intros x. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv, sumofmaps. + apply sumofmaps ; intro Hr. * now apply Dcuts_zero_empty in Hr. * exact Hr. + intros x0. apply fromempty. exact (Dcuts_zero_empty _ (pr1 (pr2 (pr2 x0)))). - intros Hr. now apply hinhpr ; left ; right. Qed. Lemma isrunit_Dcuts_plus_zero : isrunit Dcuts_plus 0. Proof. intros x. rewrite iscomm_Dcuts_plus. now apply islunit_Dcuts_plus_zero. Qed. Lemma isassoc_Dcuts_mult : isassoc Dcuts_mult. Proof. intros x y z. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv ; intros xyz. generalize (pr1 (pr2 (pr2 xyz))). apply hinhfun ; intros xy. pattern r at 1 ; rewrite (pr1 (pr2 xyz)), (pr1 (pr2 xy)), isassoc_multNonnegativeRationals. exists (pr1 (pr1 xy),,(pr2 (pr1 xy) * pr2 (pr1 xyz))) ; simpl ; repeat split. + exact (pr1 (pr2 (pr2 xy))). + apply hinhpr ; exists (pr2 (pr1 xy),,pr2 (pr1 (xyz))). repeat split. * exact (pr2 (pr2 (pr2 xy))). * exact (pr2 (pr2 (pr2 xyz))). - apply hinhuniv ; intros xyz. generalize (pr2 (pr2 (pr2 xyz))). apply hinhfun ; intros yz. pattern r at 1 ; rewrite (pr1 (pr2 xyz)), (pr1 (pr2 yz)), <- isassoc_multNonnegativeRationals. exists ((pr1 (pr1 xyz) * pr1 (pr1 yz)) ,, pr2 (pr1 yz)) ; simpl ; repeat split. + apply hinhpr ; exists (pr1 (pr1 xyz),,pr1 (pr1 yz)). repeat split. * exact (pr1 (pr2 (pr2 xyz))). * exact (pr1 (pr2 (pr2 yz))). + exact (pr2 (pr2 (pr2 yz))). Qed. Lemma islunit_Dcuts_mult_one : islunit Dcuts_mult Dcuts_one. Proof. intros x. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv ; intros ix. apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 ix))). pattern r at 1 ; rewrite (pr1 (pr2 ix)), iscomm_multNonnegativeRationals. apply multNonnegativeRationals_le1_r, lt_leNonnegativeRationals. exact (pr1 (pr2 (pr2 ix))). - intros Xr. generalize (is_Dcuts_open x r Xr). apply hinhfun ; intros q. exists ((r/pr1 q)%NRat,,pr1 q) ; repeat split. + simpl. rewrite iscomm_multNonnegativeRationals, multdivNonnegativeRationals. * reflexivity. * apply istrans_le_lt_ltNonnegativeRationals with (2 := pr2 (pr2 q)). apply isnonnegative_NonnegativeRationals. + change (r / pr1 q < 1)%NRat. apply_pr2 (multNonnegativeRationals_ltcompat_l (pr1 q)). * apply istrans_le_lt_ltNonnegativeRationals with (2 := pr2 (pr2 q)). apply isnonnegative_NonnegativeRationals. * rewrite multdivNonnegativeRationals, isrunit_oneNonnegativeRationals. ** exact (pr2 (pr2 q)). ** apply istrans_le_lt_ltNonnegativeRationals with (2 := pr2 (pr2 q)). apply isnonnegative_NonnegativeRationals. + exact (pr1 (pr2 q)). Qed. Lemma isrunit_Dcuts_mult_one : isrunit Dcuts_mult Dcuts_one. Proof. intros x. rewrite iscomm_Dcuts_mult. now apply islunit_Dcuts_mult_one. Qed. Lemma islabsorb_Dcuts_mult_zero : ∏ x : Dcuts, Dcuts_mult Dcuts_zero x = Dcuts_zero. Proof. intros x. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv ; intros ix. apply fromempty. now apply (Dcuts_zero_empty _ (pr1 (pr2 (pr2 ix)))). - intro Hr. now apply Dcuts_zero_empty in Hr. Qed. Lemma israbsorb_Dcuts_mult_zero : ∏ x : Dcuts, Dcuts_mult x Dcuts_zero = Dcuts_zero. Proof. intros x. rewrite iscomm_Dcuts_mult. now apply islabsorb_Dcuts_mult_zero. Qed. Lemma isldistr_Dcuts_plus_mult : isldistr Dcuts_plus Dcuts_mult. Proof. intros x y z. apply Dcuts_eq_is_eq ; intro r ; split. - apply hinhuniv ; intros xyz. rewrite (pr1 (pr2 xyz)). generalize (pr2 (pr2 (pr2 xyz))). apply hinhfun ; apply sumofmaps ; [ apply sumofmaps ; [intros Xr | intros Yr] | intros xy ]. + left ; left ; apply hinhpr. exists (pr1 xyz) ; repeat split. * exact (pr1 (pr2 (pr2 xyz))). * exact Xr. + left ; right ; apply hinhpr. exists (pr1 xyz) ; repeat split. * exact (pr1 (pr2 (pr2 xyz))). * exact Yr. + rewrite (pr1 (pr2 xy)), isldistr_mult_plusNonnegativeRationals. right ; exists (pr1 (pr1 xyz) * pr1 (pr1 xy),, pr1 (pr1 xyz) * pr2 (pr1 xy)) ; repeat split. * apply hinhpr ; exists (pr1 (pr1 xyz),,pr1 (pr1 xy)). repeat split. ** exact (pr1 (pr2 (pr2 xyz))). ** exact (pr1 (pr2 (pr2 xy))). * apply hinhpr ; exists (pr1 (pr1 xyz),,pr2 (pr1 xy)). repeat split. ** exact (pr1 (pr2 (pr2 xyz))). ** exact (pr2 (pr2 (pr2 xy))). - apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps | intros zxzy ]. + apply hinhfun ; intros zx. rewrite (pr1 (pr2 zx)). exists (pr1 zx) ; repeat split. * exact (pr1 (pr2 (pr2 zx))). * apply hinhpr ; left ; left. exact (pr2 (pr2 (pr2 zx))). + apply hinhfun ; intros zy. rewrite (pr1 (pr2 zy)). exists (pr1 zy) ; repeat split. * exact (pr1 (pr2 (pr2 zy))). * apply hinhpr ; left ; right. exact (pr2 (pr2 (pr2 zy))). + rewrite (pr1 (pr2 zxzy)). generalize (pr1 (pr2 (pr2 zxzy))) (pr2 (pr2 (pr2 zxzy))). apply hinhfun2 ; intros zx zy. rewrite (pr1 (pr2 zx)), (pr1 (pr2 zy)). generalize (isdecrel_leNonnegativeRationals (NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy))) 0%NRat) ; apply sumofmaps ; [intros Heq| intros Hlt]. * apply NonnegativeRationals_eq0_le0 in Heq. apply NQmax_eq_zero in Heq. rewrite (pr1 Heq), (pr2 Heq). exists (0%NRat,,pr2 (pr1 zx)) ; simpl ; repeat split. ** rewrite !islabsorb_zero_multNonnegativeRationals. now apply isrunit_zeroNonnegativeRationals. ** apply (is_Dcuts_bot _ _ (pr1 (pr2 (pr2 zx)))). apply isnonnegative_NonnegativeRationals. ** apply hinhpr ; left ; left. exact (pr2 (pr2 (pr2 zx))). * apply notge_ltNonnegativeRationals in Hlt. exists (NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy)),, (pr1 (pr1 zx) * pr2 (pr1 zx) / NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy)) + (pr1 (pr1 zy) * pr2 (pr1 zy) / NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy))))) ; simpl ; repeat split. ** unfold divNonnegativeRationals. rewrite <- isrdistr_mult_plusNonnegativeRationals. now apply pathsinv0, multdivNonnegativeRationals. ** apply NQmax_case. *** exact (pr1 (pr2 (pr2 zx))). *** exact (pr1 (pr2 (pr2 zy))). ** apply hinhpr ; right. exists (pr1 (pr1 zx) * pr2 (pr1 zx) / NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy)) ,, pr1 (pr1 zy) * pr2 (pr1 zy) / NQmax (pr1 (pr1 zx)) (pr1 (pr1 zy))) ; simpl ; repeat split. *** apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 zx))). rewrite iscomm_multNonnegativeRationals. unfold divNonnegativeRationals ; rewrite isassoc_multNonnegativeRationals. apply multNonnegativeRationals_le1_r, divNonnegativeRationals_le1. now apply NQmax_le_l. *** apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 zy))). rewrite iscomm_multNonnegativeRationals. unfold divNonnegativeRationals ; rewrite isassoc_multNonnegativeRationals. apply multNonnegativeRationals_le1_r, divNonnegativeRationals_le1. now apply NQmax_le_r. Qed. Lemma isrdistr_Dcuts_plus_mult : isrdistr Dcuts_plus Dcuts_mult. Proof. intros x y z. rewrite <- ! (iscomm_Dcuts_mult z). now apply isldistr_Dcuts_plus_mult. Qed. Lemma Dcuts_ap_one_zero : 1 ≠ 0. Proof. apply isapfun_NonnegativeRationals_to_Dcuts'. apply gtNonnegativeRationals_noteq. exact ispositive_oneNonnegativeRationals. Qed. Definition islinv_Dcuts_inv : ∏ x : Dcuts, ∏ Hx0 : x ≠ 0, Dcuts_mult (Dcuts_inv x Hx0) x = 1. Proof. intros x Hx0. apply Dcuts_eq_is_eq ; intros q ; split. - apply hinhuniv ; intros xy. rewrite (pr1 (pr2 xy)). generalize (pr1 (pr2 (pr2 xy))). apply hinhuniv ; intros l. change (pr1 (pr1 xy) * pr2 (pr1 xy) < 1)%NRat. apply istrans_le_lt_ltNonnegativeRationals with (pr1 l). + apply (pr1 (pr2 l)). exact (pr2 (pr2 (pr2 xy))). + exact (pr2 (pr2 (pr2 l))). - change (q ∈ 1) with (q < 1)%NRat ; intro Hq. generalize Hx0 ; intro Hx. apply_pr2_in Dcuts_apzero_notempty Hx0. generalize (eq0orgt0NonnegativeRationals q) ; apply sumofmaps ; intros Hq0. + rewrite Hq0. apply hinhpr. exists (0%NRat,,0%NRat) ; repeat split. * simpl ; now rewrite islabsorb_zero_multNonnegativeRationals. * apply hinhpr. exists (/ 2)%NRat ; split. ** simpl pr1 ; intros. rewrite islabsorb_zero_multNonnegativeRationals. now apply isnonnegative_NonnegativeRationals. ** split. *** apply (pr1 (ispositive_invNonnegativeRationals _)). exact ispositive_twoNonnegativeRationals. *** apply_pr2 (multNonnegativeRationals_ltcompat_l 2%NRat). **** exact ispositive_twoNonnegativeRationals. **** rewrite isrunit_oneNonnegativeRationals, isrinv_NonnegativeRationals. { exact one_lt_twoNonnegativeRationals. } exact ispositive_twoNonnegativeRationals. * exact Hx0. + generalize (is_Dcuts_open _ _ Hx0). apply hinhuniv ; intros r. apply between_ltNonnegativeRationals in Hq. rename Hq into t. set (c := pr1 r * (/ pr1 t - 1)%NRat). assert (Hc0 : (0 < c)%NRat). { unfold c. apply ispositive_multNonnegativeRationals. - exact (pr2 (pr2 r)). - apply ispositive_minusNonnegativeRationals. apply_pr2 (multNonnegativeRationals_ltcompat_l (pr1 t)). + apply istrans_ltNonnegativeRationals with q. * exact Hq0. * exact (pr1 (pr2 t)). + rewrite isrunit_oneNonnegativeRationals, isrinv_NonnegativeRationals. * exact (pr2 (pr2 t)). * apply istrans_ltNonnegativeRationals with q. ** exact Hq0. ** exact (pr1 (pr2 t)). } generalize (Dcuts_def_corr_not_empty _ Hx0 (is_Dcuts_corr x) _ Hc0). apply hinhfun ; intros r'. exists ((q * / (NQmax (pr1 r) (pr1 r')))%NRat,,NQmax (pr1 r) (pr1 r')) ; repeat split. * simpl. rewrite isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. ** reflexivity. ** apply istrans_lt_le_ltNonnegativeRationals with (pr1 r). *** exact (pr2 (pr2 r)). *** now apply NQmax_le_l. * apply hinhpr ; simpl pr1. exists (q / NQmax (pr1 r) (pr1 r') * (NQmax (pr1 r) (pr1 r') + c))%NRat. repeat split. ** intros rx Xrx. apply multNonnegativeRationals_lecompat_l, lt_leNonnegativeRationals. apply (Dcuts_finite x). *** intro H ; apply (pr2 (pr2 r')). apply is_Dcuts_bot with (1 := H). now apply plusNonnegativeRationals_lecompat_r ; apply NQmax_le_r. *** exact Xrx. ** apply ispositive_multNonnegativeRationals. *** apply ispositive_divNonnegativeRationals. { exact Hq0. } apply istrans_lt_le_ltNonnegativeRationals with (pr1 r). { exact (pr2 (pr2 r)). } now apply NQmax_le_l. *** rewrite iscomm_plusNonnegativeRationals. now apply ispositive_plusNonnegativeRationals_l. ** unfold divNonnegativeRationals. apply_pr2 (multNonnegativeRationals_ltcompat_l (/ q)%NRat). { now apply ispositive_invNonnegativeRationals. } rewrite isrunit_oneNonnegativeRationals, <- !isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, islunit_oneNonnegativeRationals. 2: exact Hq0. apply_pr2 (multNonnegativeRationals_ltcompat_l (NQmax (pr1 r) (pr1 r'))). *** apply istrans_lt_le_ltNonnegativeRationals with (pr1 r). { exact (pr2 (pr2 r)). } now apply NQmax_le_l. *** rewrite <- !isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, islunit_oneNonnegativeRationals. 2: apply istrans_lt_le_ltNonnegativeRationals with (pr1 r). 2: exact (pr2 (pr2 r)). 2: now apply NQmax_le_l. apply (minusNonnegativeRationals_ltcompat_l' _ _ (NQmax (pr1 r) (pr1 r') * 1)%NRat). rewrite <- isldistr_mult_minusNonnegativeRationals, isrunit_oneNonnegativeRationals, plusNonnegativeRationals_minus_l. unfold c. apply multNonnegativeRationals_le_lt. 1: exact (pr2 (pr2 r)). 1: now apply NQmax_le_l. 1: apply_pr2 (multNonnegativeRationals_ltcompat_l q). { exact Hq0. } rewrite !isldistr_mult_minusNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. 2: exact Hq0. apply_pr2 (multNonnegativeRationals_ltcompat_r (pr1 t)). { apply istrans_ltNonnegativeRationals with q. { exact Hq0. } exact (pr1 (pr2 t)). } rewrite !isrdistr_mult_minusNonnegativeRationals, isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, isrunit_oneNonnegativeRationals, islunit_oneNonnegativeRationals. 2: apply istrans_ltNonnegativeRationals with q. { apply minusNonnegativeRationals_ltcompat_l. { exact (pr1 (pr2 t)). } pattern t at 1 ; rewrite <- (islunit_oneNonnegativeRationals (pr1 t)). apply multNonnegativeRationals_ltcompat_r. { apply istrans_ltNonnegativeRationals with q. { exact Hq0. } exact (pr1 (pr2 t)). } apply istrans_ltNonnegativeRationals with (pr1 t). { exact (pr1 (pr2 t)). } exact (pr2 (pr2 t)). } { exact Hq0. } exact (pr1 (pr2 t)). * simpl. apply NQmax_case. ** exact (pr1 (pr2 r)). ** exact (pr1 (pr2 r')). Qed. Lemma isrinv_Dcuts_inv : ∏ x : Dcuts, ∏ Hx0 : x ≠ 0, Dcuts_mult x (Dcuts_inv x Hx0) = 1. Proof. intros x Hx0. rewrite iscomm_Dcuts_mult. now apply islinv_Dcuts_inv. Qed. Lemma Dcuts_plus_ltcompat_l : ∏ x y z: Dcuts, (y < z) <-> (Dcuts_plus y x < Dcuts_plus z x). Proof. intros x y z. split. - apply hinhuniv ; intros r. generalize (is_Dcuts_open _ _ (pr2 (pr2 r))) ; apply hinhuniv ; intros r'. generalize (pr1 r') (pr1 (pr2 r')) (pr2 (pr2 r')) ; clear r' ; intros r' Zr' Hr. apply ispositive_minusNonnegativeRationals in Hr. generalize (is_Dcuts_corr x _ Hr). apply hinhuniv ; apply sumofmaps ; [intros nXc | ]. + apply hinhpr ; exists r' ; split. * unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [apply sumofmaps ; [intros Yr' | intros Xr'] | intros yx ]. ** apply (pr1 (pr2 r)), is_Dcuts_bot with (1 := Yr'), lt_leNonnegativeRationals. now apply_pr2 ispositive_minusNonnegativeRationals. ** apply nXc, is_Dcuts_bot with (1 := Xr'), minusNonnegativeRationals_le. ** generalize (pr1 (pr2 yx)) ; apply gtNonnegativeRationals_noteq. pattern r' at 1 ; rewrite <- (minusNonnegativeRationals_plus_r (pr1 r) r'), iscomm_plusNonnegativeRationals. *** apply plusNonnegativeRationals_ltcompat. { apply (Dcuts_finite y). { exact (pr1 (pr2 r)). } exact (pr1 (pr2 (pr2 yx))). } apply (Dcuts_finite x). { exact nXc. } exact (pr2 (pr2 (pr2 yx))). *** apply lt_leNonnegativeRationals. now apply_pr2 ispositive_minusNonnegativeRationals. * now apply hinhpr ; left ; left. + intros q. generalize (pr1 q) (pr1 (pr2 q)) (pr2 (pr2 q)) ; clear q ; intros q Xq nXq. apply hinhpr. exists (r' + q)%NRat ; split. * unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [ apply sumofmaps ; [ intros Yr' | intros Xr'] | intros yx ]. ** apply (pr1 (pr2 r)), is_Dcuts_bot with (1 := Yr'), lt_leNonnegativeRationals. rewrite <- (isrunit_zeroNonnegativeRationals (pr1 r)). apply plusNonnegativeRationals_lt_le_ltcompat. *** now apply_pr2 ispositive_minusNonnegativeRationals. *** now apply isnonnegative_NonnegativeRationals. ** apply nXq, is_Dcuts_bot with (1 := Xr'). rewrite iscomm_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_r. now apply minusNonnegativeRationals_le. ** generalize (pr1 (pr2 yx)) ; apply gtNonnegativeRationals_noteq. pattern (r' + q) at 1 ; rewrite (iscomm_plusNonnegativeRationals r' q). pattern r' at 1 ; rewrite <- (minusNonnegativeRationals_plus_r (pr1 r) r'), <- isassoc_plusNonnegativeRationals, iscomm_plusNonnegativeRationals. *** apply plusNonnegativeRationals_ltcompat. **** apply (Dcuts_finite y). { exact (pr1 (pr2 r)). } exact (pr1 (pr2 (pr2 yx))). **** apply (Dcuts_finite x). { exact nXq. } exact (pr2 (pr2 (pr2 yx))). *** apply lt_leNonnegativeRationals. now apply_pr2 ispositive_minusNonnegativeRationals. * apply hinhpr ; right ; exists (r',,q) ; repeat split. ** exact Zr'. ** exact Xq. - now apply Dcuts_plus_lt_l. Qed. Lemma Dcuts_plus_lecompat_l : ∏ x y z: Dcuts, (y <= z) <-> (Dcuts_plus y x <= Dcuts_plus z x). Proof. intros x y z. split. - intros H ; apply Dcuts_nlt_ge ; intro H0 ; apply (pr2 (Dcuts_nlt_ge _ _) H). now apply_pr2 (Dcuts_plus_ltcompat_l x). - intros H ; apply Dcuts_nlt_ge ; intro H0 ; apply (pr2 (Dcuts_nlt_ge _ _) H). now apply Dcuts_plus_ltcompat_l. Qed. Lemma Dcuts_plus_ltcompat_r : ∏ x y z: Dcuts, (y < z) <-> (Dcuts_plus x y < Dcuts_plus x z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_plus x). now apply Dcuts_plus_ltcompat_l. Qed. Lemma Dcuts_plus_lecompat_r : ∏ x y z: Dcuts, (y <= z) <-> (Dcuts_plus x y <= Dcuts_plus x z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_plus x). now apply Dcuts_plus_lecompat_l. Qed. Lemma Dcuts_plus_le_l : ∏ x y, x <= Dcuts_plus x y. Proof. intros x y r Xr. now apply hinhpr ; left ; left. Qed. Lemma Dcuts_plus_le_r : ∏ x y, y <= Dcuts_plus x y. Proof. intros x y r Xr. now apply hinhpr ; left ; right. Qed. Lemma Dcuts_mult_ltcompat_l : ∏ x y z: Dcuts, (0 < x) -> (y < z) -> (Dcuts_mult y x < Dcuts_mult z x). Proof. intros X Y Z. apply hinhuniv2 ; intros x r. generalize (is_Dcuts_bot _ _ (pr2 (pr2 x)) _ (isnonnegative_NonnegativeRationals _)) ; clear x ; intro X0. induction (eq0orgt0NonnegativeRationals (pr1 r)) as [Hr0 | Hr0]. - apply hinhpr ; exists 0%NRat ; split. + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros yx. apply (pr1 (pr2 r)). rewrite Hr0. apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 yx))). now apply isnonnegative_NonnegativeRationals. + apply hinhpr ; exists (pr1 r,,0%NRat) ; simpl ; repeat split. * now rewrite israbsorb_zero_multNonnegativeRationals. * exact (pr2 (pr2 r)). * exact X0. - generalize (is_Dcuts_open _ _ X0) ; apply hinhuniv ; intros x. generalize (is_Dcuts_open _ _ (pr2 (pr2 r))) ; apply hinhuniv ; intros r'. set (c := ((pr1 r' - pr1 r) / pr1 r * pr1 x)%NRat). assert (Hc0 : (0 < c)%NRat). { unfold c. apply ispositive_multNonnegativeRationals. - apply ispositive_divNonnegativeRationals. + apply ispositive_minusNonnegativeRationals. exact (pr2 (pr2 r')). + exact Hr0. - exact (pr2 (pr2 x)). } generalize (Dcuts_def_corr_not_empty _ X0 (is_Dcuts_corr _) _ Hc0) ; apply hinhfun ; intros x'. exists (pr1 r * (NQmax (pr1 x) (pr1 x') + c))%NRat ; split. + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros yx. generalize (pr1 (pr2 yx)) ; apply gtNonnegativeRationals_noteq. apply multNonnegativeRationals_ltcompat. * apply (Dcuts_finite Y). ** exact (pr1 (pr2 r)). ** exact (pr1 (pr2 (pr2 yx))). * apply (Dcuts_finite X). ** intro ; apply (pr2 (pr2 x')). apply is_Dcuts_bot with (1 := X1). apply plusNonnegativeRationals_lecompat_r. now apply NQmax_le_r. ** exact (pr2 (pr2 (pr2 yx))). + apply hinhpr ; exists (pr1 r',,((pr1 r * (NQmax (pr1 x) (pr1 x') + c)) / (pr1 r'))%NRat) ; simpl ; repeat split. * rewrite multdivNonnegativeRationals. { reflexivity. } apply istrans_le_lt_ltNonnegativeRationals with (pr1 r). ** exact (isnonnegative_NonnegativeRationals _). ** exact (pr2 (pr2 r')). * exact (pr1 (pr2 r')). * apply (is_Dcuts_bot _ (NQmax (pr1 x) (pr1 x'))%NRat). ** apply NQmax_case. { exact (pr1 (pr2 x)). } exact (pr1 (pr2 x')). ** apply multNonnegativeRationals_lecompat_r' with (pr1 r'). *** apply istrans_le_lt_ltNonnegativeRationals with (pr1 r). { exact (isnonnegative_NonnegativeRationals _). } exact (pr2 (pr2 r')). *** unfold divNonnegativeRationals. rewrite !isassoc_multNonnegativeRationals, islinv_NonnegativeRationals, isrunit_oneNonnegativeRationals, isldistr_mult_plusNonnegativeRationals, iscomm_multNonnegativeRationals. **** apply (minusNonnegativeRationals_lecompat_l' (NQmax (pr1 x) (pr1 x') * pr1 r)%NRat). { apply multNonnegativeRationals_lecompat_l, lt_leNonnegativeRationals. exact (pr2 (pr2 r')). } rewrite plusNonnegativeRationals_minus_l. rewrite <- isldistr_mult_minusNonnegativeRationals, iscomm_multNonnegativeRationals. apply multNonnegativeRationals_lecompat_r' with (/ pr1 r). { now apply ispositive_invNonnegativeRationals. } rewrite !isassoc_multNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals, iscomm_multNonnegativeRationals. { apply multNonnegativeRationals_lecompat_l. now apply NQmax_le_l. } exact Hr0. **** apply istrans_ltNonnegativeRationals with (pr1 r). { exact Hr0. } exact (pr2 (pr2 r')). Qed. Lemma Dcuts_mult_ltcompat_l' : ∏ x y z: Dcuts, (Dcuts_mult y x < Dcuts_mult z x) -> (y < z). Proof. intros x y z. now apply Dcuts_mult_lt_l. Qed. Lemma Dcuts_mult_lecompat_l : ∏ x y z: Dcuts, (0 < x) -> (Dcuts_mult y x <= Dcuts_mult z x) -> (y <= z). Proof. intros x y z Hx0. intros H ; apply Dcuts_nlt_ge ; intro H0 ; apply (pr2 (Dcuts_nlt_ge _ _) H). now apply Dcuts_mult_ltcompat_l. Qed. Lemma Dcuts_mult_lecompat_l' : ∏ x y z: Dcuts, (y <= z) -> (Dcuts_mult y x <= Dcuts_mult z x). Proof. intros x y z. intros H ; apply Dcuts_nlt_ge ; intro H0 ; apply (pr2 (Dcuts_nlt_ge _ _) H). now apply (Dcuts_mult_ltcompat_l' x). Qed. Lemma Dcuts_mult_ltcompat_r : ∏ x y z: Dcuts, (0 < x) -> (y < z) -> (Dcuts_mult x y < Dcuts_mult x z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_mult x). now apply Dcuts_mult_ltcompat_l. Qed. Lemma Dcuts_mult_ltcompat_r' : ∏ x y z: Dcuts, (Dcuts_mult x y < Dcuts_mult x z) -> (y < z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_mult x). now apply Dcuts_mult_ltcompat_l'. Qed. Lemma Dcuts_mult_lecompat_r : ∏ x y z: Dcuts, (0 < x) -> (Dcuts_mult x y <= Dcuts_mult x z) -> (y <= z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_mult x). now apply Dcuts_mult_lecompat_l. Qed. Lemma Dcuts_mult_lecompat_r' : ∏ x y z: Dcuts, (y <= z) -> (Dcuts_mult x y <= Dcuts_mult x z). Proof. intros x y z. rewrite ! (iscomm_Dcuts_mult x). now apply Dcuts_mult_lecompat_l'. Qed. Lemma Dcuts_plus_double : ∏ x : Dcuts, Dcuts_plus x x = Dcuts_mult Dcuts_two x. Proof. intros x. rewrite <- (Dcuts_NQmult_mult _ _ ispositive_twoNonnegativeRationals). apply Dcuts_eq_is_eq. intros r ; split. - apply hinhfun ; apply sumofmaps ; [ apply sumofmaps ; intros Xr | intros xy ; rewrite (pr1 (pr2 xy))]. + exists (r / 2)%NRat. simpl ; split. * apply pathsinv0, multdivNonnegativeRationals. exact ispositive_twoNonnegativeRationals. * apply is_Dcuts_bot with (1 := Xr). pattern r at 2 ; rewrite (NQhalf_double r). apply plusNonnegativeRationals_le_l. + exists (r / 2)%NRat. simpl ; split. * apply pathsinv0, multdivNonnegativeRationals. exact ispositive_twoNonnegativeRationals. * apply is_Dcuts_bot with (1 := Xr). pattern r at 2 ; rewrite (NQhalf_double r). apply plusNonnegativeRationals_le_l. + exists ((pr1 (pr1 xy) + pr2 (pr1 xy)) / 2)%NRat. split. * apply pathsinv0, multdivNonnegativeRationals. exact ispositive_twoNonnegativeRationals. * generalize (isdecrel_ltNonnegativeRationals (pr1 (pr1 xy)) (pr2 (pr1 xy))) ; apply sumofmaps ; intros H. { apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 xy))). pattern (pr2 (pr1 xy)) at 2 ; rewrite (NQhalf_double (pr2 (pr1 xy))). unfold divNonnegativeRationals. rewrite isrdistr_mult_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_r. apply multNonnegativeRationals_lecompat_r. now apply lt_leNonnegativeRationals. } apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). pattern (pr1 (pr1 xy)) at 2 ; rewrite (NQhalf_double (pr1 (pr1 xy))). unfold divNonnegativeRationals. rewrite isrdistr_mult_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. apply multNonnegativeRationals_lecompat_r. now apply notlt_geNonnegativeRationals. - apply hinhfun ; intros q ; rewrite (pr1 (pr2 q)). right. exists (pr1 q,,pr1 q). repeat split. + assert (X : (2 = 1+1)%NRat). { apply subtypePath_prop ; simpl. apply hq2eq1plus1. } pattern 2%NRat at 1 ; rewrite X ; clear X. rewrite isrdistr_mult_plusNonnegativeRationals, islunit_oneNonnegativeRationals. reflexivity. + exact (pr2 (pr2 q)). + exact (pr2 (pr2 q)). Qed. (** ** Structures *) Definition Dcuts_setwith2binop : setwith2binop. Proof. exists Dcuts. split. - exact Dcuts_plus. - exact Dcuts_mult. Defined. Definition isabmonoidop_Dcuts_plus : isabmonoidop Dcuts_plus. Proof. repeat split. - exact isassoc_Dcuts_plus. - exists Dcuts_zero. split. + exact islunit_Dcuts_plus_zero. + exact isrunit_Dcuts_plus_zero. - exact iscomm_Dcuts_plus. Defined. Definition ismonoidop_Dcuts_mult : ismonoidop Dcuts_mult. Proof. split. - exact isassoc_Dcuts_mult. - exists Dcuts_one. split. + exact islunit_Dcuts_mult_one. + exact isrunit_Dcuts_mult_one. Defined. Definition Dcuts_commrig : commrig. Proof. exists Dcuts_setwith2binop. repeat split. - exists (isabmonoidop_Dcuts_plus,,ismonoidop_Dcuts_mult). split. + exact islabsorb_Dcuts_mult_zero. + exact israbsorb_Dcuts_mult_zero. - exact isldistr_Dcuts_plus_mult. - exact isrdistr_Dcuts_plus_mult. - exact iscomm_Dcuts_mult. Defined. Definition Dcuts_ConstructiveCommutativeDivisionRig : ConstructiveCommutativeDivisionRig. Proof. exists Dcuts_commrig. exists (pr2 Dcuts). repeat split. - exact islapbinop_Dcuts_plus. - exact israpbinop_Dcuts_plus. - exact islapbinop_Dcuts_mult. - exact israpbinop_Dcuts_mult. - exact Dcuts_ap_one_zero. - intros x Hx. exists (Dcuts_inv x Hx) ; split. + exact (islinv_Dcuts_inv x Hx). + exact (isrinv_Dcuts_inv x Hx). Defined. (** ** Additional useful definitions *) (** *** Dcuts_minus *) Section Dcuts_minus. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_minus_val : hsubtype NonnegativeRationals := λ r, ∃ x, X x × ∏ y, (Y y) ⨿ (y = 0%NRat) -> (r + y < x)%NRat. Lemma Dcuts_minus_bot : Dcuts_def_bot Dcuts_minus_val. Proof. intros r Hr q Hle. revert Hr ; apply hinhfun ; intros x. exists (pr1 x) ; split. - exact (pr1 (pr2 x)). - intros y Yy. apply istrans_le_lt_ltNonnegativeRationals with (r + y). + apply plusNonnegativeRationals_lecompat_r. exact Hle. + now apply (pr2 (pr2 x)). Qed. Lemma Dcuts_minus_open : Dcuts_def_open Dcuts_minus_val. Proof. intros r. apply hinhuniv ; intros x. generalize (X_open _ (pr1 (pr2 x))). apply hinhfun ; intros x'. exists (r + (pr1 x' - pr1 x)) ; split. - apply hinhpr ; exists (pr1 x') ; split. + exact (pr1 (pr2 x')). + intros y Yy. pattern (pr1 x') at 2 ; rewrite <- (minusNonnegativeRationals_plus_r _ _ (lt_leNonnegativeRationals _ _ (pr2 (pr2 x')))). rewrite (iscomm_plusNonnegativeRationals r), isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_ltcompat_l. now apply (pr2 (pr2 x)). - apply plusNonnegativeRationals_lt_r. apply ispositive_minusNonnegativeRationals. exact (pr2 (pr2 x')). Qed. Lemma Dcuts_minus_corr : Dcuts_def_corr Dcuts_minus_val. Proof. assert (Y_corr' : Dcuts_def_corr (λ y, Y y ∨ (y = 0%NRat))). { intros c Hc. generalize (Y_corr c Hc) ; apply hinhfun ; apply sumofmaps ; [intros Yc | intros y ]. - left. intros H ; apply Yc ; clear Yc ; revert H. apply hinhuniv ; apply sumofmaps ; [intros Yc | intros Hc0]. + exact Yc. + rewrite Hc0 in Hc. now apply fromempty, (isirrefl_ltNonnegativeRationals 0%NRat). - right. exists (pr1 y) ; split. + apply hinhpr ; left. exact (pr1 (pr2 y)). + intros H ; apply (pr2 (pr2 y)) ; revert H. apply hinhuniv ; apply sumofmaps ; [intros H | intros Hc0]. * exact H. * apply fromempty ; revert Hc0. apply gtNonnegativeRationals_noteq. now apply ispositive_plusNonnegativeRationals_r. } intros c Hc. apply ispositive_NQhalf in Hc. apply (λ X X0 Xerr, Dcuts_def_corr_not_empty X X0 Xerr _ Hc) in Y_corr'. - revert Y_corr' ; apply hinhuniv ; intros y. generalize (pr1 (pr2 y)) ; apply hinhuniv ; intros Yy. assert (X0 : ¬ Y (pr1 y + c / 2%NRat)). { intro ; apply (pr2 (pr2 y)). now apply hinhpr ; left. } rename X0 into nYy. generalize (X_corr _ Hc) ; apply hinhuniv ; apply sumofmaps ; [intros Xc | intros x]. + apply hinhpr ; left ; intro H ; apply Xc. revert H ; apply hinhuniv ; intros x. apply X_bot with (1 := pr1 (pr2 x)). apply istrans_leNonnegativeRationals with c. * pattern c at 2 ; rewrite (NQhalf_double c). now apply plusNonnegativeRationals_le_r. * apply lt_leNonnegativeRationals. pattern c at 1 ; rewrite <- (isrunit_zeroNonnegativeRationals c). apply (pr2 (pr2 x)). now right. + generalize (isdecrel_leNonnegativeRationals (pr1 y + c / 2)%NRat (pr1 x)) ; apply sumofmaps ; intro Hxy. * assert (HY : ∏ y', (Y y') ⨿ (y' = 0%NRat) -> (y' < pr1 y + c / 2)%NRat). { intros y' ; apply sumofmaps ; intros Yy'. - apply notge_ltNonnegativeRationals ; intro H ; apply nYy. now apply Y_bot with (1 := Yy'). - rewrite Yy'. now apply ispositive_plusNonnegativeRationals_r. } apply hinhpr ; right ; exists (pr1 x - (pr1 y + c / 2))%NRat ; split. ** apply hinhpr. exists (pr1 x) ; split. *** exact (pr1 (pr2 x)). *** intros y' Yy'. pattern (pr1 x) at 2 ; rewrite <- (minusNonnegativeRationals_plus_r _ _ Hxy). apply plusNonnegativeRationals_ltcompat_l. now apply HY. ** unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros x'. generalize (pr2 (pr2 x') (pr1 y) Yy). apply_pr2 notlt_geNonnegativeRationals. apply istrans_leNonnegativeRationals with (pr1 x + c / 2)%NRat. *** apply lt_leNonnegativeRationals. apply notge_ltNonnegativeRationals ; intro H ; apply (pr2 (pr2 x)). now apply X_bot with (1 := pr1 (pr2 x')). *** rewrite isassoc_plusNonnegativeRationals, (iscomm_plusNonnegativeRationals _ (pr1 y)). pattern c at 3; rewrite (NQhalf_double c). rewrite <- (isassoc_plusNonnegativeRationals (pr1 y)), <- isassoc_plusNonnegativeRationals. rewrite minusNonnegativeRationals_plus_r. **** apply isrefl_leNonnegativeRationals. **** exact Hxy. * apply notge_ltNonnegativeRationals in Hxy. apply hinhpr ; left ; unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; intros x'. generalize (pr2 (pr2 x') _ Yy). apply_pr2 notlt_geNonnegativeRationals. induction (isdecrel_leNonnegativeRationals (pr1 y) (pr1 x')) as [Hxy' | Hxy']. ** rewrite iscomm_plusNonnegativeRationals. pattern c at 1; rewrite (NQhalf_double c), <- isassoc_plusNonnegativeRationals. apply istrans_leNonnegativeRationals with (pr1 x + c / 2)%NRat. *** apply lt_leNonnegativeRationals ; apply notge_ltNonnegativeRationals ; intro ; apply (pr2 (pr2 x)). now apply X_bot with (1 := pr1 (pr2 x')). *** apply plusNonnegativeRationals_lecompat_r. now apply lt_leNonnegativeRationals. ** apply notge_ltNonnegativeRationals in Hxy'. apply istrans_leNonnegativeRationals with (pr1 y). *** now apply lt_leNonnegativeRationals. *** now apply plusNonnegativeRationals_le_l. - now apply hinhpr ; right. Qed. End Dcuts_minus. Definition Dcuts_minus (X Y : Dcuts) : Dcuts := make_Dcuts (Dcuts_minus_val (pr1 X) (pr1 Y)) (Dcuts_minus_bot (pr1 X) (pr1 Y)) (Dcuts_minus_open (pr1 X) (is_Dcuts_open X) (pr1 Y)) (Dcuts_minus_corr (pr1 X) (is_Dcuts_bot X) (is_Dcuts_corr X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). Lemma Dcuts_minus_correct_l: ∏ x y z : Dcuts, x = Dcuts_plus y z -> z = Dcuts_minus x y. Proof. intros _ Y Z ->. apply Dcuts_eq_is_eq ; intro r ; split. - intros Zr. generalize (is_Dcuts_open _ _ Zr) ; apply hinhuniv ; intros q. generalize (pr1 (ispositive_minusNonnegativeRationals _ _) (pr2 (pr2 q))) ; intros Hq. generalize (is_Dcuts_corr Y _ Hq) ; apply hinhuniv ; apply sumofmaps ; [intros nYy | ]. + apply hinhpr ; exists (pr1 q) ; split. * apply hinhpr ; left ; right. exact (pr1 (pr2 q)). * intros y ; apply sumofmaps ; [intros Yy | intros ->]. ** apply minusNonnegativeRationals_ltcompat_l' with r. rewrite plusNonnegativeRationals_minus_l. now apply (Dcuts_finite Y). ** rewrite isrunit_zeroNonnegativeRationals. now apply_pr2 ispositive_minusNonnegativeRationals. + intros y. apply hinhpr. exists (pr1 y + pr1 q) ; split. * apply hinhpr ; right ; exists (pr1 y,,pr1 q) ; simpl ; repeat split. ** exact (pr1 (pr2 y)). ** exact (pr1 (pr2 q)). * intros y' ; apply sumofmaps ; [intros Yy' | intros ->]. ** apply minusNonnegativeRationals_ltcompat_l' with r. rewrite plusNonnegativeRationals_minus_l. rewrite iscomm_plusNonnegativeRationals, <- minusNonnegativeRationals_plus_exchange, iscomm_plusNonnegativeRationals. *** apply (Dcuts_finite Y). **** exact (pr2 (pr2 y)). **** exact Yy'. *** now apply lt_leNonnegativeRationals ; apply_pr2 ispositive_minusNonnegativeRationals. ** rewrite isrunit_zeroNonnegativeRationals. apply istrans_lt_le_ltNonnegativeRationals with (pr1 q). *** now apply_pr2 ispositive_minusNonnegativeRationals. *** now apply plusNonnegativeRationals_le_l. - apply hinhuniv ; intros q. generalize (pr1 (pr2 q)) ; apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Yq | intros Zq ] | intros yz ]. + apply fromempty, (isnonnegative_NonnegativeRationals' r). apply_pr2 (plusNonnegativeRationals_ltcompat_r (pr1 q)). rewrite islunit_zeroNonnegativeRationals. apply (pr2 (pr2 q)). now left. + apply is_Dcuts_bot with (1 := Zq), lt_leNonnegativeRationals. pattern r at 1 ; rewrite <- (isrunit_zeroNonnegativeRationals r). apply (pr2 (pr2 q)). now right. + apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 yz))), lt_leNonnegativeRationals. apply_pr2 (plusNonnegativeRationals_ltcompat_l (pr1 (pr1 yz))). rewrite <- (pr1 (pr2 yz)), iscomm_plusNonnegativeRationals. apply (pr2 (pr2 q)). left. exact (pr1 (pr2 (pr2 yz))). Qed. Lemma Dcuts_minus_correct_r: ∏ x y z : Dcuts, x = Dcuts_plus y z -> y = Dcuts_minus x z. Proof. intros x y z Hx. apply Dcuts_minus_correct_l. rewrite Hx. now apply iscomm_Dcuts_plus. Qed. Lemma Dcuts_minus_eq_zero: ∏ x y : Dcuts, x <= y -> Dcuts_minus x y = 0. Proof. intros X Y Hxy. apply Dcuts_eq_is_eq ; intros r ; split. - apply hinhuniv ; intros x. apply_pr2 (plusNonnegativeRationals_ltcompat_r (pr1 x)). rewrite islunit_zeroNonnegativeRationals. apply (pr2 (pr2 x)). left ; simple refine (Hxy _ _). exact (pr1 (pr2 x)). - intro H. now apply fromempty ; apply (Dcuts_zero_empty r). Qed. Lemma Dcuts_minus_plus_r: ∏ x y z : Dcuts, z <= y -> x = Dcuts_minus y z -> y = Dcuts_plus x z. Proof. intros _ Y Z Hyz ->. apply Dcuts_eq_is_eq ; intro r ; split. - intros Yr. generalize (is_Dcuts_open _ _ Yr) ; apply hinhuniv ; intros q. generalize (pr1 (ispositive_minusNonnegativeRationals _ _) (pr2 (pr2 q))) ; intros Hq. generalize (is_Dcuts_corr Z _ Hq). apply hinhuniv ; apply sumofmaps ; [intros nZ | ]. + apply hinhpr ; left ; left. apply hinhpr. exists (pr1 q) ; split. * exact (pr1 (pr2 q)). * intros z ; apply sumofmaps ; [intros Zz | intros ->]. ** apply (minusNonnegativeRationals_ltcompat_l' _ _ r). rewrite plusNonnegativeRationals_minus_l. now apply (Dcuts_finite Z). ** now rewrite isrunit_zeroNonnegativeRationals ; apply_pr2 ispositive_minusNonnegativeRationals. + intros z. induction (isdecrel_leNonnegativeRationals r (pr1 z)) as [Hzr | Hzr]. * apply hinhpr ; left ; right. now apply (is_Dcuts_bot _ _ (pr1 (pr2 z))). * apply notge_ltNonnegativeRationals in Hzr ; apply lt_leNonnegativeRationals in Hzr. apply hinhpr ; right. exists (r - pr1 z ,, pr1 z) ; repeat split. ** simpl. now rewrite minusNonnegativeRationals_plus_r. ** apply hinhpr ; simpl. exists (pr1 q) ; split. { exact (pr1 (pr2 q)). } intros z' ; apply sumofmaps ; [intros Zz' | intros ->]. *** apply_pr2 (plusNonnegativeRationals_ltcompat_r (pr1 z)). rewrite isassoc_plusNonnegativeRationals, (iscomm_plusNonnegativeRationals z'), <- isassoc_plusNonnegativeRationals. rewrite minusNonnegativeRationals_plus_r. **** apply (minusNonnegativeRationals_ltcompat_l' _ _ r) ; rewrite plusNonnegativeRationals_minus_l. rewrite <- minusNonnegativeRationals_plus_exchange, iscomm_plusNonnegativeRationals. { apply (Dcuts_finite Z). - exact (pr2 (pr2 z)). - exact Zz'. } now apply lt_leNonnegativeRationals ; apply_pr2 ispositive_minusNonnegativeRationals. **** now apply Hzr. *** rewrite isrunit_zeroNonnegativeRationals. apply istrans_le_lt_ltNonnegativeRationals with r. **** now apply minusNonnegativeRationals_le. **** now apply_pr2 ispositive_minusNonnegativeRationals. ** exact (pr1 (pr2 z)). - apply hinhuniv ; apply sumofmaps ; [apply sumofmaps ; [ | intros Zr] | intros ryzz ; rewrite (pr1 (pr2 ryzz)) ]. + apply hinhuniv ; intros y. apply (is_Dcuts_bot _ _ (pr1 (pr2 y))). apply lt_leNonnegativeRationals. pattern r at 1 ; rewrite <- (isrunit_zeroNonnegativeRationals r). apply (pr2 (pr2 y)). now right. + now simple refine (Hyz _ _). + generalize (pr1 (pr2 (pr2 ryzz))) ; apply hinhuniv ; simpl ; intros y. apply (is_Dcuts_bot _ _ (pr1 (pr2 y))). apply lt_leNonnegativeRationals, (pr2 (pr2 y)). left. exact (pr2 (pr2 (pr2 ryzz))). Qed. Lemma Dcuts_minus_le : ∏ x y, Dcuts_minus x y <= x. Proof. intros X Y r. apply hinhuniv ; intros x. apply is_Dcuts_bot with (1 := pr1 (pr2 x)). apply lt_leNonnegativeRationals. pattern r at 1 ; rewrite <- (isrunit_zeroNonnegativeRationals r). apply (pr2 (pr2 x)). now right. Qed. Lemma ispositive_Dcuts_minus : ∏ x y : Dcuts, (y < x) <-> (0 < Dcuts_minus x y). Proof. intros X Y. split. - apply hinhuniv ; intros x. generalize (is_Dcuts_open _ _ (pr2 (pr2 x))) ; apply hinhfun ; intros x'. exists 0%NRat ; split. + now apply (isnonnegative_NonnegativeRationals' 0%NRat). + apply hinhpr. exists (pr1 x') ; split. * exact (pr1 (pr2 x')). * intros y ; apply sumofmaps ; [intros Yy | intros ->]. ** rewrite islunit_zeroNonnegativeRationals. apply istrans_ltNonnegativeRationals with (pr1 x). *** apply (Dcuts_finite Y). { exact (pr1 (pr2 x)). } exact Yy. *** exact (pr2 (pr2 x')). ** rewrite islunit_zeroNonnegativeRationals. apply istrans_le_lt_ltNonnegativeRationals with (pr1 x). *** now apply isnonnegative_NonnegativeRationals. *** exact (pr2 (pr2 x')). - apply hinhuniv ; intros r ; generalize (pr2 (pr2 r)). apply hinhfun ; intros x. exists (pr1 x) ; split. + intros Yx ; apply (isnonnegative_NonnegativeRationals' (pr1 r)). apply_pr2 (plusNonnegativeRationals_ltcompat_r (pr1 x)). rewrite islunit_zeroNonnegativeRationals. now apply (pr2 (pr2 x)) ; left. + exact (pr1 (pr2 x)). Qed. (** *** Dcuts_max *) Section Dcuts_max. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_finite : Dcuts_def_finite Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_max_val : hsubtype NonnegativeRationals := λ r : NonnegativeRationals, X r ∨ Y r. Lemma Dcuts_max_bot : Dcuts_def_bot Dcuts_max_val. Proof. intros r Hr q Hqr. revert Hr ; apply hinhfun ; apply sumofmaps ; [ intros Xr| intros Yr]. - left ; now apply X_bot with (1 := Xr). - right ; now apply Y_bot with (1 := Yr). Qed. Lemma Dcuts_max_open : Dcuts_def_open Dcuts_max_val. Proof. intros r ; apply hinhuniv ; apply sumofmaps ; [ intros Xr | intros Yr]. - generalize (X_open _ Xr). apply hinhfun ; intros q. exists (pr1 q) ; split. + apply hinhpr ; left. exact (pr1 (pr2 q)). + exact (pr2 (pr2 q)). - generalize (Y_open _ Yr). apply hinhfun ; intros q. exists (pr1 q) ; split. + apply hinhpr ; right. exact (pr1 (pr2 q)). + exact (pr2 (pr2 q)). Qed. Lemma Dcuts_max_corr : Dcuts_def_corr Dcuts_max_val. Proof. intros c Hc. generalize (X_corr _ Hc) (Y_corr _ Hc) ; apply hinhfun2 ; apply (sumofmaps (Z := _ → _)) ; [intros nXc | intros x] ; apply sumofmaps ; [intros nYc | intros y |intros nYc | intros y]. - left ; unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [intros Xc | intros Yc]. + now apply nXc. + now apply nYc. - right. exists (pr1 y) ; split. + apply hinhpr ; right. exact (pr1 (pr2 y)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [intros Xy | intros Yy]. * now apply nXc, X_bot with (1 := Xy), plusNonnegativeRationals_le_l. * now apply (pr2 (pr2 y)). - right. exists (pr1 x) ; split. + apply hinhpr ; left. exact (pr1 (pr2 x)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [intros Xx | intros Yx]. * now apply (pr2 (pr2 x)). * now apply nYc, Y_bot with (1 := Yx), plusNonnegativeRationals_le_l. - right. exists (NQmax (pr1 x) (pr1 y)) ; split. + apply NQmax_case. * apply hinhpr ; left. exact (pr1 (pr2 x)). * apply hinhpr ; right. exact (pr1 (pr2 y)). + unfold neg ; apply (hinhuniv (P := make_hProp _ isapropempty)) ; apply sumofmaps ; [ intros Xxy | intros Yxy]. * apply (pr2 (pr2 x)), X_bot with (1 := Xxy). apply plusNonnegativeRationals_lecompat_r. now apply NQmax_le_l. * apply (pr2 (pr2 y)), Y_bot with (1 := Yxy). apply plusNonnegativeRationals_lecompat_r. now apply NQmax_le_r. Qed. End Dcuts_max. Definition Dcuts_max (X Y : Dcuts) : Dcuts := make_Dcuts (Dcuts_max_val (pr1 X) (pr1 Y)) (Dcuts_max_bot (pr1 X) (is_Dcuts_bot X) (pr1 Y) (is_Dcuts_bot Y)) (Dcuts_max_open (pr1 X) (is_Dcuts_open X) (pr1 Y) (is_Dcuts_open Y)) (Dcuts_max_corr (pr1 X) (is_Dcuts_bot X) (is_Dcuts_corr X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). Lemma iscomm_Dcuts_max : ∏ x y : Dcuts, Dcuts_max x y = Dcuts_max y x. Proof. intros x y. apply Dcuts_eq_is_eq ; intros r. split ; apply islogeqcommhdisj. Qed. Lemma isassoc_Dcuts_max : ∏ x y z : Dcuts, Dcuts_max (Dcuts_max x y) z = Dcuts_max x (Dcuts_max y z). Proof. intros x y z. apply Dcuts_eq_is_eq ; intros r. split. - apply hinhuniv ; apply sumofmaps ; [ | intros Zr]. + apply hinhfun ; apply sumofmaps ; [ intros Xr | intros Yr]. * now left. * right ; apply hinhpr. now left. + apply hinhpr. right ; apply hinhpr. now right. - apply hinhuniv ; apply sumofmaps ; [intros Xr | ]. + apply hinhpr. left ; apply hinhpr. now left. + apply hinhfun ; apply sumofmaps ; [intros Yr | intros Zr]. * left ; apply hinhpr. now right. * now right. Qed. Lemma Dcuts_max_le_l : ∏ x y : Dcuts, x <= Dcuts_max x y. Proof. intros x y r Xr. apply hinhpr. now left. Qed. Lemma Dcuts_max_le_r : ∏ x y : Dcuts, y <= Dcuts_max x y. Proof. intros x y r Xr. apply hinhpr. now right. Qed. Lemma Dcuts_max_carac_l : ∏ x y : Dcuts, y <= x -> Dcuts_max x y = x. Proof. intros x y Hxy. apply Dcuts_eq_is_eq ; intros r ; split. - apply hinhuniv ; apply sumofmaps ; [ intros Xr | intros Yr ]. + exact Xr. + now refine (Hxy _ _). - intros Xr. now apply hinhpr ; left. Qed. Lemma Dcuts_max_carac_r : ∏ x y : Dcuts, x <= y -> Dcuts_max x y = y. Proof. intros x y Hxy. rewrite iscomm_Dcuts_max. now apply Dcuts_max_carac_l. Qed. Lemma Dcuts_minus_plus_max : ∏ x y : Dcuts, Dcuts_plus (Dcuts_minus x y) y = Dcuts_max x y. Proof. intros X Y. apply Dcuts_eq_is_eq ; intros r ; split. - apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros XYr | intros Yr] | intros xyy ; rewrite (pr1 (pr2 xyy))]. + apply hinhpr ; left. revert XYr ; now refine (Dcuts_minus_le _ _ _). + now apply hinhpr ; right. + generalize (pr1 (pr2 (pr2 xyy))) ; apply hinhfun ; intros x. left ; apply is_Dcuts_bot with (1 := pr1 (pr2 x)). apply lt_leNonnegativeRationals. apply (pr2 (pr2 x)). left. exact (pr2 (pr2 (pr2 xyy))). - apply hinhuniv ; apply sumofmaps ; [intros Xr|intros Yr]. + generalize (is_Dcuts_open _ _ Xr) ; apply hinhuniv ; intros x. generalize (pr1 (ispositive_minusNonnegativeRationals _ _) (pr2 (pr2 x))) ; intros Hx. generalize (is_Dcuts_corr Y _ Hx) ; apply hinhuniv ; apply sumofmaps ; [ intros nYx | intros Hyx ] ; apply_pr2_in ispositive_minusNonnegativeRationals Hx. * rewrite <- (Dcuts_minus_plus_r (Dcuts_minus X Y) X Y). ** exact Xr. ** apply Dcuts_lt_le_rel. apply hinhpr ; exists (pr1 x - r) ; split. { exact nYx. } apply is_Dcuts_bot with (1 := pr1 (pr2 x)). now apply minusNonnegativeRationals_le. ** reflexivity. * rename Hyx into y. generalize (pr2 (pr2 y)) ; intros nYy. rewrite iscomm_plusNonnegativeRationals, minusNonnegativeRationals_plus_exchange in nYy. 2: now apply lt_leNonnegativeRationals. generalize (isdecrel_leNonnegativeRationals r (pr1 y)) ; apply sumofmaps ; intros Hle. { apply hinhpr ; left ; right. now apply is_Dcuts_bot with (1 := pr1 (pr2 y)). } apply notge_ltNonnegativeRationals in Hle. rewrite <- (Dcuts_minus_plus_r (Dcuts_minus X Y) X Y). ** exact Xr. ** apply Dcuts_lt_le_rel. apply hinhpr ; exists ((pr1 x + pr1 y) - r) ; split. { exact nYy. } apply is_Dcuts_bot with (1 := pr1 (pr2 x)). pattern (pr1 x) at 2; rewrite <- (plusNonnegativeRationals_minus_r r (pr1 x)). apply minusNonnegativeRationals_lecompat_l. apply plusNonnegativeRationals_lecompat_l. now apply lt_leNonnegativeRationals. ** reflexivity. + now apply hinhpr ; left ; right. Qed. Lemma Dcuts_max_le : ∏ x y z, x <= z -> y <= z -> Dcuts_max x y <= z. Proof. intros x y z Hx Hy r. apply hinhuniv ; apply sumofmaps ; [intros Xr|intros Yr]. - now refine (Hx _ _). - now refine (Hy _ _). Qed. Lemma Dcuts_max_lt : ∏ x y z : Dcuts, x < z -> y < z -> Dcuts_max x y < z. Proof. intros x y z. apply hinhfun2 ; intros rx ry. exists (NQmax (pr1 rx) (pr1 ry)) ; split. - apply NQmax_case_strong ; intro Hr. + intro Hr' ; apply (pr1 (pr2 ry)). revert Hr' ; apply hinhuniv ; apply sumofmaps ; [ intros Xr | intros Yr]. * now apply fromempty, (pr1 (pr2 rx)). * now apply is_Dcuts_bot with (1 := Yr). + intro Hr' ; apply (pr1 (pr2 rx)). revert Hr' ; apply hinhuniv ; apply sumofmaps ; [intros Xr | intros Yr]. * now apply is_Dcuts_bot with (1 := Xr). * now apply fromempty, (pr1 (pr2 ry)). - apply NQmax_case. + exact (pr2 (pr2 rx)). + exact (pr2 (pr2 ry)). Qed. Lemma isldistr_Dcuts_max_mult : isldistr Dcuts_max Dcuts_mult. Proof. intros x y z. apply Dcuts_eq_is_eq. intros r ; split. - apply hinhuniv. intros zxy. rewrite (pr1 (pr2 zxy)). generalize (pr2 (pr2 (pr2 zxy))). apply hinhfun. apply sumofmaps ; [intros Xr | intros Yr]. + left. apply hinhpr. exists (pr1 zxy). repeat split. * exact (pr1 (pr2 (pr2 zxy))). * exact Xr. + right. apply hinhpr. exists (pr1 zxy). repeat split. * exact (pr1 (pr2 (pr2 zxy))). * exact Yr. - apply hinhuniv. apply sumofmaps. + apply hinhfun. intros zx. rewrite (pr1 (pr2 zx)). exists (pr1 zx). repeat split. * exact (pr1 (pr2 (pr2 zx))). * apply hinhpr. left. exact (pr2 (pr2 (pr2 zx))). + apply hinhfun. intros zy. rewrite (pr1 (pr2 zy)). exists (pr1 zy). repeat split. * exact (pr1 (pr2 (pr2 zy))). * apply hinhpr. right. exact (pr2 (pr2 (pr2 zy))). Qed. Lemma isrdistr_Dcuts_max_mult : isrdistr Dcuts_max Dcuts_mult. Proof. intros x y z. rewrite !(iscomm_Dcuts_mult _ z). now apply isldistr_Dcuts_max_mult. Qed. Lemma isldistr_Dcuts_max_plus : isldistr Dcuts_max Dcuts_plus. Proof. intros x y z. apply Dcuts_eq_is_eq. intros r ; split. - apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Zr | ] | intros zxy ; rewrite (pr1 (pr2 zxy)) ; generalize (pr2 (pr2 (pr2 zxy))) ]. + apply hinhpr. left. apply hinhpr. left. now left. + apply hinhfun. apply sumofmaps ; [intros Xr | intros Yr]. * left. apply hinhpr. left. now right. * right. apply hinhpr. left. now right. + apply hinhfun. apply sumofmaps ; [intros Xr | intros Yr]. * left. apply hinhpr. right. exists (pr1 zxy). repeat split. ** exact (pr1 (pr2 (pr2 zxy))). ** exact Xr. * right. apply hinhpr. right. exists (pr1 zxy). repeat split. ** exact (pr1 (pr2 (pr2 zxy))). ** exact Yr. - apply hinhuniv ; apply sumofmaps ; apply hinhuniv ; apply sumofmaps. + apply sumofmaps ; [ intros Zr | intros Xr] ; apply hinhpr ; left. * now left. * right. apply hinhpr. now left. + intros zx ; rewrite (pr1 (pr2 zx)). apply hinhpr. right. exists (pr1 zx). repeat split. * exact (pr1 (pr2 (pr2 zx))). * apply hinhpr. left. exact (pr2 (pr2 (pr2 zx))). + apply sumofmaps ; [intros Zr | intros Yr] ; apply hinhpr ; left. * now left. * right. apply hinhpr. now right. + intros zx ; rewrite (pr1 (pr2 zx)). apply hinhpr. right. exists (pr1 zx). repeat split. * exact (pr1 (pr2 (pr2 zx))). * apply hinhpr. right. exact (pr2 (pr2 (pr2 zx))). Qed. Lemma Dcuts_max_plus : ∏ x y : Dcuts, (0 < x -> y = 0) -> Dcuts_max x y = Dcuts_plus x y. Proof. intros x y H. apply Dcuts_le_ge_eq. - intros r. apply hinhfun. intros H0. left. exact H0. - intros r. apply hinhfun. apply sumofmaps ; [intros H0 | ]. { exact H0. } intros xy ; rewrite (pr1 (pr2 xy)). apply fromempty. refine (Dcuts_zero_empty _ _). rewrite <- H. { apply (pr2 (pr2 (pr2 xy))). } apply hinhpr. exists (pr1 (pr1 xy)). split. + apply Dcuts_zero_empty. + exact (pr1 (pr2 (pr2 xy))). Qed. (** *** Dcuts_min *) Section Dcuts_min. Context (X : hsubtype NonnegativeRationals). Context (X_bot : Dcuts_def_bot X). Context (X_open : Dcuts_def_open X). Context (X_finite : Dcuts_def_finite X). Context (X_corr : Dcuts_def_corr X). Context (Y : hsubtype NonnegativeRationals). Context (Y_bot : Dcuts_def_bot Y). Context (Y_open : Dcuts_def_open Y). Context (Y_finite : Dcuts_def_finite Y). Context (Y_corr : Dcuts_def_corr Y). Definition Dcuts_min_val : hsubtype NonnegativeRationals := λ r : NonnegativeRationals, X r ∧ Y r. Lemma Dcuts_min_bot : Dcuts_def_bot Dcuts_min_val. Proof. intros r Hr q Hqr. split. - apply X_bot with (1 := pr1 Hr), Hqr. - apply Y_bot with (1 := pr2 Hr), Hqr. Qed. Lemma Dcuts_min_open : Dcuts_def_open Dcuts_min_val. Proof. intros r Hr. generalize (X_open _ (pr1 Hr)) (Y_open _ (pr2 Hr)). apply hinhfun2 ; intros q q'. generalize (isdecrel_ltNonnegativeRationals (pr1 q) (pr1 q')) ; apply sumofmaps ; intros H. - exists (pr1 q) ; repeat split. + exact (pr1 (pr2 q)). + apply Y_bot with (1 := pr1 (pr2 q')), lt_leNonnegativeRationals, H. + exact (pr2 (pr2 q)). - exists (pr1 q') ; repeat split. + apply X_bot with (1 := pr1 (pr2 q)), notlt_geNonnegativeRationals, H. + exact (pr1 (pr2 q')). + exact (pr2 (pr2 q')). Qed. Lemma Dcuts_min_corr : Dcuts_def_corr Dcuts_min_val. Proof. intros c Hc0. generalize (X_corr _ Hc0) (Y_corr _ Hc0) ; apply hinhfun2 ; apply (sumofmaps (Z := _ → _)) ; [intros nXc | intros q] ; intros Hy. - left ; intros Hc. apply nXc. exact (pr1 Hc). - revert Hy ; apply sumofmaps ; [intros nYc | intros q']. + left ; intros Hc. apply nYc. exact (pr2 Hc). + right. generalize (isdecrel_ltNonnegativeRationals (pr1 q) (pr1 q')) ; apply sumofmaps ; intros H. * exists (pr1 q) ; repeat split. ** exact (pr1 (pr2 q)). ** apply Y_bot with (1 := pr1 (pr2 q')), lt_leNonnegativeRationals, H. ** intros Hc. apply (pr2 (pr2 q)). exact (pr1 Hc). * exists (pr1 q') ; repeat split. ** apply X_bot with (1 := pr1 (pr2 q)), notlt_geNonnegativeRationals, H. ** exact (pr1 (pr2 q')). ** intros Hc. apply (pr2 (pr2 q')). exact (pr2 Hc). Qed. End Dcuts_min. Definition Dcuts_min (X Y : Dcuts) : Dcuts := make_Dcuts (Dcuts_min_val (pr1 X) (pr1 Y)) (Dcuts_min_bot (pr1 X) (is_Dcuts_bot X) (pr1 Y) (is_Dcuts_bot Y)) (Dcuts_min_open (pr1 X) (is_Dcuts_bot X) (is_Dcuts_open X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_open Y)) (Dcuts_min_corr (pr1 X) (is_Dcuts_bot X) (is_Dcuts_corr X) (pr1 Y) (is_Dcuts_bot Y) (is_Dcuts_corr Y)). Lemma iscomm_Dcuts_min : ∏ x y : Dcuts, Dcuts_min x y = Dcuts_min y x. Proof. intros x y. apply Dcuts_eq_is_eq ; intros r. split ; apply weqdirprodcomm. Qed. Lemma isassoc_Dcuts_min : ∏ x y z : Dcuts, Dcuts_min (Dcuts_min x y) z = Dcuts_min x (Dcuts_min y z). Proof. intros x y z. apply Dcuts_eq_is_eq ; intros r. split ; intros Hr ; repeat split. - apply (pr1 (pr1 Hr)). - apply (pr2 (pr1 Hr)). - apply (pr2 Hr). - apply (pr1 Hr). - apply (pr1 (pr2 Hr)). - apply (pr2 (pr2 Hr)). Qed. Lemma Dcuts_min_le_l : ∏ x y : Dcuts, Dcuts_min x y <= x. Proof. intros x y r Hr. exact (pr1 Hr). Qed. Lemma Dcuts_min_le_r : ∏ x y : Dcuts, Dcuts_min x y <= y. Proof. intros x y r Hr. exact (pr2 Hr). Qed. Lemma Dcuts_min_carac_r : ∏ x y : Dcuts, y <= x -> Dcuts_min x y = y. Proof. intros x y Hxy. apply Dcuts_eq_is_eq ; intros r ; split. - intros Hr. exact (pr2 Hr). - intros Yr. split. + now simple refine (Hxy _ _). + exact Yr. Qed. Lemma Dcuts_min_carac_l : ∏ x y : Dcuts, x <= y -> Dcuts_min x y = x. Proof. intros x y Hxy. rewrite iscomm_Dcuts_min. now apply Dcuts_min_carac_r. Qed. Lemma Dcuts_min_max : ∏ x y : Dcuts, Dcuts_min x (Dcuts_max x y) = x. Proof. intros x y. apply Dcuts_eq_is_eq ; intros r. split. - intros Hr. exact (pr1 Hr). - intros Xr. split. + exact Xr. + apply hinhpr. now left. Qed. Lemma Dcuts_max_min : ∏ x y : Dcuts, Dcuts_max x (Dcuts_min x y) = x. Proof. intros x y. apply Dcuts_eq_is_eq ; intros r. split. - apply hinhuniv ; apply sumofmaps ; [intros Xr | intros Hr]. + exact Xr. + exact (pr1 Hr). - intros Xr. apply hinhpr. now left. Qed. Lemma Dcuts_min_gt : ∏ x y z : Dcuts, z < x → z < y → z < (Dcuts_min x y). Proof. intros x y z. apply hinhfun2. intros r q. generalize (isdecrel_ltNonnegativeRationals (pr1 r) (pr1 q)) ; apply sumofmaps ; intros H. - exists (pr1 r). repeat split. + exact (pr1 (pr2 r)). + exact (pr2 (pr2 r)). + apply is_Dcuts_bot with (1 := pr2 (pr2 q)), lt_leNonnegativeRationals, H. - exists (pr1 q). repeat split. + exact (pr1 (pr2 q)). + apply is_Dcuts_bot with (1 := pr2 (pr2 r)), notlt_geNonnegativeRationals, H. + exact (pr2 (pr2 q)). Qed. (** *** Dcuts_half *) Lemma Dcuts_two_ap_zero : Dcuts_two ≠ 0. Proof. apply isapfun_NonnegativeRationals_to_Dcuts'. apply gtNonnegativeRationals_noteq. exact ispositive_twoNonnegativeRationals. Qed. Section Dcuts_half. Context (X : hsubtype NonnegativeRationals) (X_bot : Dcuts_def_bot X) (X_open : Dcuts_def_open X) (X_corr : Dcuts_def_corr X). Definition Dcuts_half_val : hsubtype NonnegativeRationals := λ r, X (r + r). Lemma Dcuts_half_bot : Dcuts_def_bot Dcuts_half_val. Proof. intros r Hr q Hq. apply X_bot with (1 := Hr). eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_lecompat_l, Hq. now apply plusNonnegativeRationals_lecompat_r, Hq. Qed. Lemma Dcuts_half_open : Dcuts_def_open Dcuts_half_val. Proof. intros r Hr. generalize (X_open _ Hr). apply hinhfun ; intros q. exists (pr1 q / 2)%NRat ; split. - unfold Dcuts_half_val. rewrite <- NQhalf_double. exact (pr1 (pr2 q)). - apply_pr2 (multNonnegativeRationals_ltcompat_l 2%NRat). + exact ispositive_twoNonnegativeRationals. + pattern r at 1 ; rewrite (NQhalf_double r), isldistr_mult_plusNonnegativeRationals, !multdivNonnegativeRationals. * exact (pr2 (pr2 q)). * exact ispositive_twoNonnegativeRationals. * exact ispositive_twoNonnegativeRationals. Qed. Lemma Dcuts_half_corr : Dcuts_def_corr Dcuts_half_val. Proof. intros c Hc. assert (Hc0 : (0 < c + c)%NRat) by (now apply ispositive_plusNonnegativeRationals_l). generalize (X_corr _ Hc0) ; apply hinhfun ; apply sumofmaps ; [intros Hx | intros r]. - left ; exact Hx. - right. exists (pr1 r / 2)%NRat ; split. + unfold Dcuts_half_val. rewrite <- NQhalf_double. exact (pr1 (pr2 r)). + intro H ; apply (pr2 (pr2 r)). apply X_bot with (1 := H). pattern (pr1 r) at 1 ; rewrite (NQhalf_double (pr1 r)), !isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. rewrite iscomm_plusNonnegativeRationals, !isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. rewrite iscomm_plusNonnegativeRationals. now apply isrefl_leNonnegativeRationals. Qed. End Dcuts_half. Definition Dcuts_half (x : Dcuts) : Dcuts := make_Dcuts (Dcuts_half_val (pr1 x)) (Dcuts_half_bot (pr1 x) (is_Dcuts_bot x)) (Dcuts_half_open (pr1 x) (is_Dcuts_open x)) (Dcuts_half_corr (pr1 x) (is_Dcuts_bot x) (is_Dcuts_corr x)). Lemma Dcuts_half_le : ∏ x : Dcuts, Dcuts_half x <= x. Proof. intros x. intros r Hr. apply is_Dcuts_bot with (1 := Hr). now apply plusNonnegativeRationals_le_l. Qed. Lemma isdistr_Dcuts_half_plus : ∏ x y : Dcuts, Dcuts_half (Dcuts_plus x y) = Dcuts_plus (Dcuts_half x) (Dcuts_half y). Proof. intros x y. apply Dcuts_eq_is_eq. intros r ; split. - apply hinhfun ; apply sumofmaps ; [apply sumofmaps ; [intros Xr | intros Yr] | intros xy ]. + left. left. exact Xr. + left. right. exact Yr. + right. exists (pr1 (pr1 xy) / 2%NRat,, pr2 (pr1 xy)/2%NRat). unfold Dcuts_half_val ; simpl ; repeat split. * unfold divNonnegativeRationals. rewrite <- isrdistr_mult_plusNonnegativeRationals. pattern r at 1 ; rewrite (NQhalf_double r) ; unfold divNonnegativeRationals ; rewrite <- isrdistr_mult_plusNonnegativeRationals. apply (maponpaths (λ x, x * _)), (pr1 (pr2 xy)). * unfold Dcuts_half_val ; rewrite <- NQhalf_double. exact (pr1 (pr2 (pr2 xy))). * unfold Dcuts_half_val ; rewrite <- NQhalf_double. exact (pr2 (pr2 (pr2 xy))). - apply hinhfun ; apply sumofmaps ; [apply sumofmaps ; [intros Xr | intros Yr] | intros xy ; rewrite (pr1 (pr2 xy))]. + left. left. exact Xr. + left. right. exact Yr. + right. exists (pr1 (pr1 xy) + pr1 (pr1 xy),, pr2 (pr1 xy) + pr2 (pr1 xy)). simpl ; repeat split. * rewrite !isassoc_plusNonnegativeRationals. apply maponpaths. rewrite iscomm_plusNonnegativeRationals, isassoc_plusNonnegativeRationals. reflexivity. * exact (pr1 (pr2 (pr2 xy))). * exact (pr2 (pr2 (pr2 xy))). Qed. Lemma Dcuts_half_double : ∏ x : Dcuts, x = Dcuts_plus (Dcuts_half x) (Dcuts_half x). Proof. intros x. rewrite <- isdistr_Dcuts_half_plus. apply Dcuts_eq_is_eq ; split. - intros Hr. apply hinhpr ; right ; exists (r,,r). now repeat split. - apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps | intros xy ]. + now simple refine (Dcuts_half_le _ _). + now simple refine (Dcuts_half_le _ _). + generalize (isdecrel_ltNonnegativeRationals r (pr1 (pr1 xy))) ; apply sumofmaps ; intro Hrx. * apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). now apply lt_leNonnegativeRationals. * apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_l r). pattern (r+r) at 1 ; rewrite (pr1 (pr2 xy)). apply plusNonnegativeRationals_lecompat_r. now apply notlt_geNonnegativeRationals. Qed. Lemma Dcuts_half_correct : ∏ x, Dcuts_half x = Dcuts_mult x (Dcuts_inv Dcuts_two Dcuts_two_ap_zero). Proof. intros x. pattern x at 2 ; rewrite (Dcuts_half_double x). rewrite Dcuts_plus_double, iscomm_Dcuts_mult, <- isassoc_Dcuts_mult, islinv_Dcuts_inv, islunit_Dcuts_mult_one. reflexivity. Qed. Lemma ispositive_Dcuts_half: ∏ x : Dcuts, (0 < x) <-> (0 < Dcuts_half x). Proof. intros. rewrite Dcuts_half_correct. pattern 0 at 2 ; rewrite <- (islabsorb_Dcuts_mult_zero (Dcuts_inv Dcuts_two Dcuts_two_ap_zero)). split. - intro Hx0. apply Dcuts_mult_ltcompat_l. + apply Dcuts_mult_ltcompat_l' with Dcuts_two. rewrite islabsorb_Dcuts_mult_zero, islinv_Dcuts_inv. unfold Dcuts_zero, Dcuts_one. apply (pr2 (isapfun_NonnegativeRationals_to_Dcuts_aux 0%NRat 1%NRat)). now apply ispositive_oneNonnegativeRationals. + exact Hx0. - now apply Dcuts_mult_ltcompat_l'. Qed. (** ** Locatedness *) Lemma Dcuts_locatedness : ∏ X : Dcuts, ∏ p q : NonnegativeRationals, (p < q)%NRat -> p ∈ X ∨ ¬ (q ∈ X). Proof. intros X p q Hlt. apply ispositive_minusNonnegativeRationals in Hlt. generalize (is_Dcuts_corr X _ Hlt). apply_pr2_in ispositive_minusNonnegativeRationals Hlt. apply hinhuniv ; apply sumofmaps ; [ intros Xr | ]. - apply hinhpr ; right. intro H ; apply Xr. apply is_Dcuts_bot with (1 := H). now apply minusNonnegativeRationals_le. - intros r. generalize (isdecrel_leNonnegativeRationals p (pr1 r)) ; apply sumofmaps ; [ intros Hle | intros Hnle]. + apply hinhpr ; left. now apply is_Dcuts_bot with (1 := pr1 (pr2 r)). + apply notge_ltNonnegativeRationals in Hnle. apply hinhpr ; right. intro H ; apply (pr2 (pr2 r)). apply is_Dcuts_bot with (1 := H). apply_pr2 (plusNonnegativeRationals_lecompat_r p). rewrite isassoc_plusNonnegativeRationals, minusNonnegativeRationals_plus_r, iscomm_plusNonnegativeRationals. * apply plusNonnegativeRationals_lecompat_l. now apply lt_leNonnegativeRationals. * now apply lt_leNonnegativeRationals. Qed. (** ** Limits of Cauchy sequences *) Section Dcuts_lim. Context (U : nat -> hsubtype NonnegativeRationals) (U_bot : ∏ n : nat, Dcuts_def_bot (U n)) (U_open : ∏ n : nat, Dcuts_def_open (U n)) (U_corr : ∏ n : nat, Dcuts_def_corr (U n)). Context (U_cauchy : ∏ eps : NonnegativeRationals, (0 < eps)%NRat -> hexists (λ N : nat, ∏ n m : nat, N ≤ n -> N ≤ m -> (∏ r, U n r -> Dcuts_plus_val (U m) (λ q, (q < eps)%NRat) r) × (∏ r, U m r -> Dcuts_plus_val (U n) (λ q, (q < eps)%NRat) r))). Definition Dcuts_lim_cauchy_val : hsubtype NonnegativeRationals := λ r : NonnegativeRationals, hexists (λ c : NonnegativeRationals, (0 < c)%NRat × ∑ N : nat, ∏ n : nat, N ≤ n -> U n (r + c)). Lemma Dcuts_lim_cauchy_bot : Dcuts_def_bot Dcuts_lim_cauchy_val. Proof. intros r Hr q Hq. revert Hr ; apply hinhfun ; intros c. exists (pr1 c) ; split. - exact (pr1 (pr2 c)). - exists (pr1 (pr2 (pr2 c))) ; intros n Hn. apply (U_bot n) with (1 := pr2 (pr2 (pr2 c)) n Hn). apply plusNonnegativeRationals_lecompat_r. exact Hq. Qed. Lemma Dcuts_lim_cauchy_open : Dcuts_def_open Dcuts_lim_cauchy_val. Proof. intros r. apply hinhfun ; intros c. exists (r + (pr1 c / 2))%NRat ; split. - apply hinhpr. exists (pr1 c / 2)%NRat ; split. + now apply ispositive_NQhalf, (pr1 (pr2 c)). + exists (pr1 (pr2 (pr2 c))) ; intros n Hn. rewrite isassoc_plusNonnegativeRationals, <- NQhalf_double. now apply (pr2 (pr2 (pr2 c))). - apply plusNonnegativeRationals_lt_r, ispositive_NQhalf. exact (pr1 (pr2 c)). Qed. Lemma Dcuts_lim_cauchy_corr : Dcuts_def_corr Dcuts_lim_cauchy_val. Proof. intros c Hc. apply ispositive_NQhalf, ispositive_NQhalf in Hc. generalize (U_cauchy _ Hc) ; clear U_cauchy ; apply hinhuniv ; intros N. generalize (λ n Hn, pr2 N n (pr1 N) Hn (isreflnatleh _)) ; intro Hu. generalize (U_corr (pr1 N) _ Hc). apply hinhuniv ; apply sumofmaps ; intros HuN. - apply hinhpr ; left. intro ; apply HuN ; clear HuN. revert X ; apply hinhuniv ; intros eps. generalize (natgthorleh (pr1 N) (pr1 (pr2 (pr2 eps)))) ; apply sumofmaps ; intros HN. + apply natlthtoleh in HN. apply (U_bot (pr1 N)) with (1 := pr2 (pr2 (pr2 eps)) _ HN). pattern c at 2 ; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. + generalize (pr2 (pr2 (pr2 eps)) _ (isreflnatleh _)) ; intros HuN'. generalize (pr1 (Hu _ HN) _ HuN') ; clear Hu HuN'. apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; intros H | intros xy ]. * apply (U_bot (pr1 N)) with (1 := H). pattern c at 2 ; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. * apply fromempty. revert H. apply_pr2 notlt_geNonnegativeRationals. pattern c at 2 ; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. * apply (U_bot (pr1 N)) with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr2 (pr1 xy))). rewrite <- (pr1 (pr2 xy)). pattern c at 2; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. pattern (c / 2)%NRat at 2; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. apply istrans_leNonnegativeRationals with (c / 2 / 2)%NRat. ** apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). ** now apply plusNonnegativeRationals_le_r. - rename HuN into q. generalize (isdecrel_leNonnegativeRationals (pr1 q) (c / 2)%NRat) ; apply sumofmaps ; intros Hq. + apply hinhpr ; left. intro ; apply (pr2 (pr2 q)). revert X ; apply hinhuniv ; intros eps. generalize (natgthorleh (pr1 N) (pr1 (pr2 (pr2 eps)))) ; apply sumofmaps ; intros HN. * apply natlthtoleh in HN. apply (U_bot (pr1 N)) with (1 := pr2 (pr2 (pr2 eps)) _ HN). pattern c at 2; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. apply istrans_leNonnegativeRationals with (c / 2 + c / 2 / 2)%NRat. ** apply plusNonnegativeRationals_lecompat_r. exact Hq. ** apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. * generalize (pr2 (pr2 (pr2 eps)) _ (isreflnatleh _)) ; intros HuN'. generalize (pr1 (Hu _ HN) _ HuN') ; clear Hu HuN'. apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; intros H | intros xy]. { apply (U_bot (pr1 N)) with (1 := H). pattern c at 2; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals, iscomm_plusNonnegativeRationals. apply istrans_leNonnegativeRationals with (c / 2 / 2 + c / 2)%NRat. ** apply plusNonnegativeRationals_lecompat_l. exact Hq. ** rewrite iscomm_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. } { apply fromempty. revert H. apply_pr2 notlt_geNonnegativeRationals. pattern c at 2 ; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. } { apply (U_bot (pr1 N)) with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr2 (pr1 xy))). rewrite <- (pr1 (pr2 xy)). pattern c at 2; rewrite (NQhalf_double c), !isassoc_plusNonnegativeRationals. eapply istrans_leNonnegativeRationals. - apply plusNonnegativeRationals_lecompat_r. now apply Hq. - apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. apply istrans_leNonnegativeRationals with (c / 2 / 2)%NRat. + apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). + now apply plusNonnegativeRationals_le_r. } + apply hinhpr ; right. apply notge_ltNonnegativeRationals in Hq. exists (pr1 q - c / 2)%NRat ; split. * apply hinhpr. exists (c / 2 / 2)%NRat ; split. ** exact Hc. ** exists (pr1 N) ; intros n Hn. generalize (pr2 (Hu _ Hn) _ (pr1 (pr2 q))). apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Xr | intros Yr] | intros xy]. { apply (U_bot n) with (1 := Xr). pattern (pr1 q) at 2 ; rewrite <- (minusNonnegativeRationals_plus_r (c / 2)%NRat (pr1 q)). - apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat). now apply plusNonnegativeRationals_le_r. - now apply lt_leNonnegativeRationals. } { apply fromempty. revert Yr. apply_pr2 notlt_geNonnegativeRationals. eapply istrans_leNonnegativeRationals, lt_leNonnegativeRationals, Hq. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat). now apply plusNonnegativeRationals_le_r. } { apply (U_bot n) with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr2 (pr1 xy))). rewrite <- (pr1 (pr2 xy)). pattern (pr1 q) at 2; rewrite <- (minusNonnegativeRationals_plus_r (c / 2)%NRat (pr1 q)), isassoc_plusNonnegativeRationals. - apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2; rewrite (NQhalf_double (c / 2)%NRat). apply plusNonnegativeRationals_lecompat_l. apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). - now apply lt_leNonnegativeRationals. } * intro ; apply (pr2 (pr2 q)). revert X ; apply hinhuniv ; intros eps. generalize (natgthorleh (pr1 N) (pr1 (pr2 (pr2 eps)))) ; apply sumofmaps ; intros HN. { apply natlthtoleh in HN. apply (U_bot (pr1 N)) with (1 := pr2 (pr2 (pr2 eps)) _ HN). pattern c at 3; rewrite (NQhalf_double c), <- isassoc_plusNonnegativeRationals, minusNonnegativeRationals_plus_r. - pattern (c / 2)%NRat at 2; rewrite (NQhalf_double (c / 2)%NRat), !isassoc_plusNonnegativeRationals, <- (isassoc_plusNonnegativeRationals (pr1 q) (c / 2 / 2)%NRat). now apply plusNonnegativeRationals_le_r. - now apply lt_leNonnegativeRationals. } { generalize (pr2 (pr2 (pr2 eps)) _ (isreflnatleh _)) ; intros HuN. generalize (pr1 (Hu _ HN) _ HuN) ; clear Hu HuN. apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; intros H | intros xy]. - apply (U_bot (pr1 N)) with (1 := H). pattern (pr1 q) at 1 ; rewrite <- (minusNonnegativeRationals_plus_r (c / 2)%NRat (pr1 q)), !isassoc_plusNonnegativeRationals. + apply plusNonnegativeRationals_lecompat_l. pattern c at 3 ; rewrite (NQhalf_double c), isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. + now apply lt_leNonnegativeRationals. - apply fromempty. revert H. apply_pr2 notlt_geNonnegativeRationals. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_le_r. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_le_l. pattern c at 2 ; rewrite (NQhalf_double c). pattern (c / 2)%NRat at 2 ; rewrite (NQhalf_double (c / 2)%NRat), isassoc_plusNonnegativeRationals. now apply plusNonnegativeRationals_le_r. - apply (U_bot (pr1 N)) with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr2 (pr1 xy))). rewrite <- (pr1 (pr2 xy)). pattern (pr1 q) at 1 ; rewrite <- (minusNonnegativeRationals_plus_r (c / 2)%NRat (pr1 q)), !isassoc_plusNonnegativeRationals. + pattern (pr1 q - c / 2 + c + pr1 eps)%NRat; rewrite (isassoc_plusNonnegativeRationals (pr1 q - c / 2)%NRat c (pr1 eps)). apply plusNonnegativeRationals_lecompat_l. pattern c at 3; rewrite (NQhalf_double c). pattern (c / 2 + c / 2 + pr1 eps)%NRat at 1 ; rewrite isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. pattern (c / 2)%NRat at 2; rewrite (NQhalf_double (c / 2)%NRat). pattern (c / 2 / 2 + c / 2 / 2 + pr1 eps)%NRat at 1 ; rewrite isassoc_plusNonnegativeRationals. apply plusNonnegativeRationals_lecompat_l. apply istrans_leNonnegativeRationals with (c / 2 / 2)%NRat. * apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). * now apply plusNonnegativeRationals_le_r. + now apply lt_leNonnegativeRationals. } Qed. End Dcuts_lim. Definition Dcuts_Cauchy_seq (u : nat -> Dcuts) : hProp := make_hProp (∏ eps : Dcuts, 0 < eps -> hexists (λ N : nat, ∏ n m : nat, N ≤ n -> N ≤ m -> u n < Dcuts_plus (u m) eps × u m < Dcuts_plus (u n) eps)) (impred_isaprop _ (λ _, isapropimpl _ _ (pr2 _))). Definition is_Dcuts_lim_seq (u : nat -> Dcuts) (l : Dcuts) : hProp := make_hProp (∏ eps : Dcuts, 0 < eps -> hexists (λ N : nat, ∏ n : nat, N ≤ n -> u n < Dcuts_plus l eps × l < Dcuts_plus (u n) eps)) (impred_isaprop _ (λ _, isapropimpl _ _ (pr2 _))). Definition Dcuts_lim_cauchy_seq (U : nat → Dcuts) (HU : Dcuts_Cauchy_seq U) : Dcuts. Proof. exists (Dcuts_lim_cauchy_val (λ n, pr1 (U n))). repeat split. - apply Dcuts_lim_cauchy_bot. intro ; now apply is_Dcuts_bot. - apply Dcuts_lim_cauchy_open. - apply Dcuts_lim_cauchy_corr. + intro ; now apply is_Dcuts_bot. + intro ; now apply is_Dcuts_corr. + intros eps Heps. assert (X : 0 < NonnegativeRationals_to_Dcuts eps) by (now apply_pr2 isapfun_NonnegativeRationals_to_Dcuts_aux). generalize (HU _ X) ; clear HU. apply hinhfun ; intros HU. exists (pr1 HU) ; intros n m Hn Hm. set (pr2 HU n m Hn Hm) ; clearbody d ; clear -d ; rename d into HU. split. * now refine (Dcuts_lt_le_rel _ _ (pr1 HU)). * now refine (Dcuts_lt_le_rel _ _ (pr2 HU)). Defined. Lemma Dcuts_Cauchy_seq_impl_ex_lim_seq (U : nat → Dcuts) (HU : Dcuts_Cauchy_seq U) : is_Dcuts_lim_seq U (Dcuts_lim_cauchy_seq U HU). Proof. intros eps. apply hinhuniv ; intros c'. generalize (is_Dcuts_open _ _ (pr2 (pr2 c'))). apply hinhuniv ; intros c. assert (Hc0 : (0 < pr1 c)%NRat). { eapply istrans_le_lt_ltNonnegativeRationals, (pr2 (pr2 c)). now apply isnonnegative_NonnegativeRationals. } apply ispositive_NQhalf in Hc0. generalize (HU _ (pr2 (isapfun_NonnegativeRationals_to_Dcuts_aux _ _) Hc0)). apply hinhfun ; intros N. exists (pr1 N) ; intros n Hn. generalize (λ n Hn, pr2 N n (pr1 N) Hn (isreflnatleh _)) ; intros Hu. split. - eapply istrans_Dcuts_lt_le_rel. { now apply (Hu n Hn). } pattern eps at 1; rewrite (Dcuts_half_double eps), <- isassoc_Dcuts_plus. eapply istrans_Dcuts_le_rel, Dcuts_plus_lecompat_l. + apply Dcuts_plus_lecompat_r. intros r Hr. simpl. apply is_Dcuts_bot with (1 := pr1 (pr2 c)). rewrite (NQhalf_double (pr1 c)). now apply lt_leNonnegativeRationals, plusNonnegativeRationals_ltcompat ; apply Hr. + intros r Hr. generalize (isdecrel_ltNonnegativeRationals r (pr1 c / 2)%NRat) ; apply sumofmaps ; intro Hrc. * apply hinhpr ; left ; right. apply is_Dcuts_bot with (1 := pr1 (pr2 c)). rewrite (NQhalf_double (pr1 c)). now apply lt_leNonnegativeRationals, plusNonnegativeRationals_ltcompat ; apply Hrc. * apply notlt_geNonnegativeRationals in Hrc. generalize (is_Dcuts_open _ _ Hr). apply hinhuniv ; intros q. apply hinhpr ; right ; exists (r - pr1 c / 2%NRat,, pr1 c / 2%NRat) ; repeat split. ** now simpl ; rewrite minusNonnegativeRationals_plus_r. ** generalize (pr1 q) (pr1 (pr2 q)) (pr2 (pr2 q)) ; clear q ; intros q UNq Hrq. apply hinhpr ; exists (q - r) ; split. { apply ispositive_minusNonnegativeRationals, Hrq. } exists (pr1 N) ; intros m Hm. simpl. rewrite minusNonnegativeRationals_plus_exchange, iscomm_plusNonnegativeRationals, minusNonnegativeRationals_plus_r. *** generalize (Dcuts_lt_le_rel _ _ (pr2 (Hu m Hm)) _ UNq) ; clear Hu. apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [ intros Xr | intros Yr] | intros xy ; rewrite (pr1 (pr2 xy))]. { apply is_Dcuts_bot with (1 := Xr). now apply minusNonnegativeRationals_le. } { simpl in Yr. apply_pr2_in notge_ltNonnegativeRationals Yr. apply fromempty, Yr. apply istrans_leNonnegativeRationals with r. - exact Hrc. - now apply lt_leNonnegativeRationals. } apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr1 c / 2)%NRat). rewrite minusNonnegativeRationals_plus_r. { apply plusNonnegativeRationals_lecompat_l, lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). } apply lt_leNonnegativeRationals. rewrite <- (pr1 (pr2 xy)). eapply istrans_le_lt_ltNonnegativeRationals, Hrq. exact Hrc. *** now apply lt_leNonnegativeRationals. *** exact Hrc. ** simpl ; unfold Dcuts_half_val. rewrite <- NQhalf_double. exact (pr1 (pr2 c)). - apply istrans_Dcuts_le_lt_rel with (Dcuts_plus (U (pr1 N)) (Dcuts_half eps)). + intros r. apply hinhuniv ; intros c''. generalize (isdecrel_ltNonnegativeRationals r (pr1 c / 2)%NRat) ; apply sumofmaps ; intro Hrc. * apply hinhpr ; left ; right. apply is_Dcuts_bot with (1 := pr1 (pr2 c)). rewrite (NQhalf_double (pr1 c)). now apply lt_leNonnegativeRationals, plusNonnegativeRationals_ltcompat ; apply Hrc. * apply notlt_geNonnegativeRationals in Hrc. apply hinhpr ; right ; exists (r - pr1 c / 2%NRat,, pr1 c / 2%NRat) ; simpl ; repeat split. ** now rewrite minusNonnegativeRationals_plus_r. ** generalize (natgthorleh (pr1 N) (pr1 (pr2 (pr2 c'')))) ; apply sumofmaps ; intro HN. { apply natlthtoleh in HN. apply is_Dcuts_bot with (1 := pr2 (pr2 (pr2 c'')) _ HN). apply istrans_leNonnegativeRationals with r. - now apply minusNonnegativeRationals_le. - now apply plusNonnegativeRationals_le_r. } generalize (Dcuts_lt_le_rel _ _ (pr1 (Hu _ HN)) _ (pr2 (pr2 (pr2 c'')) _ (isreflnatleh _))). apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Xr | intros Yr] | intros xy ]. *** apply is_Dcuts_bot with (1 := Xr). apply istrans_leNonnegativeRationals with r. **** now apply minusNonnegativeRationals_le. **** now apply plusNonnegativeRationals_le_r. *** simpl in Yr. (* this simplification helps when primitive projections are enabled *) apply_pr2_in notge_ltNonnegativeRationals Yr. apply fromempty, Yr. apply istrans_leNonnegativeRationals with r. **** exact Hrc. **** now apply plusNonnegativeRationals_le_r. *** apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr1 c / 2)%NRat). rewrite minusNonnegativeRationals_plus_r. **** apply istrans_leNonnegativeRationals with (r + pr1 c''). { now apply plusNonnegativeRationals_le_r. } pattern (r + pr1 c'') at 1 ; rewrite (pr1 (pr2 xy)). apply plusNonnegativeRationals_lecompat_l. apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). **** exact Hrc. ** unfold Dcuts_half_val. rewrite <- NQhalf_double. exact (pr1 (pr2 c)). + pattern eps at 2; rewrite (Dcuts_half_double eps), <- isassoc_Dcuts_plus. apply Dcuts_plus_ltcompat_l. apply istrans_Dcuts_lt_le_rel with (Dcuts_plus (U n) (NonnegativeRationals_to_Dcuts (pr1 c / 2)%NRat)). { now apply (pr2 (Hu _ Hn)). } apply Dcuts_plus_lecompat_r. intros r Hr. apply is_Dcuts_bot with (1 := pr1 (pr2 c)). rewrite (NQhalf_double (pr1 c)). apply lt_leNonnegativeRationals, plusNonnegativeRationals_ltcompat ; apply Hr. Qed. (** ** Dedekind Completeness *) Section Dcuts_of_Dcuts. Context (E : hsubtype Dcuts). Context (E_bot : ∏ x : Dcuts, E x -> ∏ y : Dcuts, y <= x -> E y). Context (E_open : ∏ x : Dcuts, E x -> ∃ y : Dcuts, x < y × E y). Context (E_corr: ∏ c : Dcuts, 0 < c -> (¬ E c) ∨ (hexists (λ P, E P × ¬ E (Dcuts_plus P c)))). Definition Dcuts_of_Dcuts_val : NonnegativeRationals → hProp := λ r : NonnegativeRationals, ∃ X : Dcuts, (E X) × (r ∈ X). Lemma Dcuts_of_Dcuts_bot : ∏ (x : NonnegativeRationals), Dcuts_of_Dcuts_val x -> ∏ y : NonnegativeRationals, (y <= x)%NRat -> Dcuts_of_Dcuts_val y. Proof. intros r Xr n Xn. revert Xr ; apply hinhfun ; intros X. exists (pr1 X) ; split. - exact (pr1 (pr2 X)). - apply is_Dcuts_bot with r. + exact (pr2 (pr2 X)). + exact Xn. Qed. Lemma Dcuts_of_Dcuts_open : ∏ (x : NonnegativeRationals), Dcuts_of_Dcuts_val x -> hexists (λ y : NonnegativeRationals, (Dcuts_of_Dcuts_val y) × (x < y)%NRat). Proof. intros r. apply hinhuniv ; intros X. generalize (is_Dcuts_open _ _ (pr2 (pr2 X))). apply hinhfun ; intros n. exists (pr1 n) ; split. - apply hinhpr. exists (pr1 X) ; split. + exact (pr1 (pr2 X)). + exact (pr1 (pr2 n)). - exact (pr2 (pr2 n)). Qed. Lemma Dcuts_of_Dcuts_corr: Dcuts_def_corr Dcuts_of_Dcuts_val. Proof. intros c Hc. apply ispositive_NQhalf in Hc. apply (pr2 (isapfun_NonnegativeRationals_to_Dcuts_aux _ _)) in Hc. generalize (E_corr _ Hc). apply isapfun_NonnegativeRationals_to_Dcuts_aux in Hc. apply hinhuniv ; apply sumofmaps ; [intros He | ]. - apply hinhpr ; left. use factor_through_squash. { exact isapropempty. } intros X. apply He. apply E_bot with (1 := pr1 (pr2 X)). intros r Hr. apply is_Dcuts_bot with c. { exact (pr2 (pr2 X)). } apply lt_leNonnegativeRationals. eapply istrans_lt_le_ltNonnegativeRationals. { exact Hr. } pattern c at 2 ; rewrite (NQhalf_double c). apply plusNonnegativeRationals_le_r. - apply hinhuniv ; intros X. generalize (is_Dcuts_corr (pr1 X) _ Hc). apply hinhfun ; apply sumofmaps ; [intros Xc | ]. + left. use factor_through_squash. { exact isapropempty. } intros Y. apply (pr2 (pr2 X)). apply E_bot with (1 := pr1 (pr2 Y)). apply Dcuts_lt_le_rel. apply hinhpr. exists c ; split. 2: exact (pr2 (pr2 Y)). intros H ; apply Xc. revert H ; apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Xc' | intros Yc'] | ]. * apply is_Dcuts_bot with (1 := Xc'). pattern c at 2. rewrite (NQhalf_double c). apply plusNonnegativeRationals_le_r. * apply fromempty. revert Yc' ; simpl. change (¬ (c < c / 2)%NRat). apply (pr2 (notlt_geNonnegativeRationals _ _)). pattern c at 2. rewrite (NQhalf_double c). apply plusNonnegativeRationals_le_r. * intros xy. apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). apply_pr2 (plusNonnegativeRationals_lecompat_r (pr2 (pr1 xy))). rewrite <- (pr1 (pr2 xy)). pattern c at 2; rewrite (NQhalf_double c). apply plusNonnegativeRationals_lecompat_l. apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). + intro ; right. rename X0 into q. exists (pr1 q) ; split. * apply hinhpr. exists (pr1 X) ; split. ** exact (pr1 (pr2 X)). ** exact (pr1 (pr2 q)). * use factor_through_squash. { exact isapropempty. } intros Y. apply (pr2 (pr2 X)). apply E_bot with (1 := pr1 (pr2 Y)). intros r. apply hinhuniv ; apply sumofmaps. ** apply sumofmaps ; [intros Xc' | intros Yc' ]. *** apply is_Dcuts_bot with (1 := pr2 (pr2 Y)). pattern c at 1; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_le_r. apply lt_leNonnegativeRationals. apply notge_ltNonnegativeRationals. intro ; apply (pr2 (pr2 q)). now apply is_Dcuts_bot with (1 := Xc'). *** apply is_Dcuts_bot with (1 := pr2 (pr2 Y)). pattern c at 1; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_le_l. apply lt_leNonnegativeRationals. exact Yc'. ** intros xy. apply is_Dcuts_bot with (1 := pr2 (pr2 Y)). rewrite (pr1 (pr2 xy)). pattern c at 1; rewrite (NQhalf_double c). rewrite <- isassoc_plusNonnegativeRationals. eapply istrans_leNonnegativeRationals, plusNonnegativeRationals_lecompat_l. *** apply plusNonnegativeRationals_lecompat_r. apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. intro ; apply (pr2 (pr2 q)). now apply is_Dcuts_bot with (1 := pr1 (pr2 (pr2 xy))). *** apply lt_leNonnegativeRationals. exact (pr2 (pr2 (pr2 xy))). Qed. End Dcuts_of_Dcuts. Definition Dcuts_of_Dcuts (E : hsubtype Dcuts) E_bot E_corr : Dcuts := make_Dcuts (Dcuts_of_Dcuts_val E) (Dcuts_of_Dcuts_bot E) (Dcuts_of_Dcuts_open E) (Dcuts_of_Dcuts_corr E E_bot E_corr). Section Dcuts_of_Dcuts'. Context (E : hsubtype NonnegativeRationals). Context (E_bot : Dcuts_def_bot E). Context (E_open : Dcuts_def_open E). Context (E_corr : Dcuts_def_corr E). Definition Dcuts_of_Dcuts'_val : hsubtype Dcuts := λ x : Dcuts, ∃ r : NonnegativeRationals, (¬ (r ∈ x)) × E r. Lemma Dcuts_of_Dcuts'_bot : ∏ (x : Dcuts), Dcuts_of_Dcuts'_val x -> ∏ y : Dcuts, (y <= x) -> Dcuts_of_Dcuts'_val y. Proof. intros r Xr n Xn. revert Xr. apply hinhfun. intros q. exists (pr1 q). split. - intros Nq. apply (pr1 (pr2 q)). now simple refine (Xn _ _). - exact (pr2 (pr2 q)). Qed. Lemma Dcuts_of_Dcuts'_open : ∏ (x : Dcuts), Dcuts_of_Dcuts'_val x -> hexists (λ y : Dcuts, (Dcuts_of_Dcuts'_val y) × (x < y)). Proof. intros r. apply hinhuniv. intros q. generalize (E_open _ (pr2 (pr2 q))). apply hinhfun. intros s. exists (NonnegativeRationals_to_Dcuts (pr1 s)). split. - apply hinhpr. exists (pr1 s). split. + simpl. now apply isirrefl_ltNonnegativeRationals. + exact (pr1 (pr2 s)). - apply hinhpr. exists (pr1 q). split. + exact (pr1 (pr2 q)). + simpl. exact (pr2 (pr2 s)). Qed. Lemma Dcuts_of_Dcuts'_corr: ∏ c : Dcuts, 0 < c -> (¬ Dcuts_of_Dcuts'_val c) ∨ (hexists (λ P, Dcuts_of_Dcuts'_val P × ¬ Dcuts_of_Dcuts'_val (Dcuts_plus P c))). Proof. intros C HC. assert (∃ c : NonnegativeRationals, c ∈ C × (0 < c)%NRat). { revert HC ; apply hinhuniv ; intro d. generalize (is_Dcuts_open _ _ (pr2 (pr2 d))). apply hinhfun. intro c. exists (pr1 c). split. - exact (pr1 (pr2 c)). - eapply istrans_le_lt_ltNonnegativeRationals, (pr2 (pr2 c)). now apply isnonnegative_NonnegativeRationals. } revert X ; apply hinhuniv ; intros c. generalize (E_corr _ (pr2 (pr2 c))). apply hinhfun. apply sumofmaps ; [intros Ec | intros q]. - left. use factor_through_squash. { exact isapropempty. } intros r. apply Ec. apply E_bot with (1 := (pr2 (pr2 r))). apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. intro H. apply (pr1 (pr2 r)). now apply is_Dcuts_bot with (1 := pr1 (pr2 c)). - right. apply hinhpr. exists (NonnegativeRationals_to_Dcuts (pr1 q)). split. + apply hinhpr. exists (pr1 q). split. * simpl. apply isirrefl_ltNonnegativeRationals. * exact (pr1 (pr2 q)). + intro H ; apply (pr2 (pr2 q)). revert H. apply hinhuniv. intros r. apply E_bot with (1 := (pr2 (pr2 r))). apply notlt_geNonnegativeRationals. intro H. apply (pr1 (pr2 r)). generalize (isdecrel_ltNonnegativeRationals (pr1 r) (pr1 c)) ; apply sumofmaps ; intros H0. * apply hinhpr. left. right. apply is_Dcuts_bot with (1 := pr1 (pr2 c)). now apply lt_leNonnegativeRationals. * apply notlt_geNonnegativeRationals in H0. apply hinhpr. right. exists ((pr1 r - pr1 c)%NRat,, pr1 c). simpl ; split ; [ | split]. ** now apply pathsinv0, minusNonnegativeRationals_plus_r. ** apply_pr2 (plusNonnegativeRationals_ltcompat_r (pr1 c)). now rewrite minusNonnegativeRationals_plus_r. ** exact (pr1 (pr2 c)). Qed. End Dcuts_of_Dcuts'. Lemma Dcuts_of_Dcuts_bij : ∏ x : Dcuts, Dcuts_of_Dcuts (Dcuts_of_Dcuts'_val (pr1 x)) (Dcuts_of_Dcuts'_bot (pr1 x)) (Dcuts_of_Dcuts'_corr (pr1 x) (is_Dcuts_bot x) (is_Dcuts_corr x)) = x. Proof. intros x. apply Dcuts_eq_is_eq. intros r. split. - apply hinhuniv. intros y. generalize (pr1 (pr2 y)). apply hinhuniv. intros q. apply is_Dcuts_bot with (1 := pr2 (pr2 q)). apply lt_leNonnegativeRationals, notge_ltNonnegativeRationals. intro H. apply (pr1 (pr2 q)). now apply is_Dcuts_bot with (1 := pr2 (pr2 y)). - intros Xr. generalize (is_Dcuts_open _ _ Xr). apply hinhfun. intros q. exists (NonnegativeRationals_to_Dcuts (pr1 q)). split. + apply hinhpr. exists (pr1 q). split. * simpl. now apply isirrefl_ltNonnegativeRationals. * exact (pr1 (pr2 q)). + simpl. exact (pr2 (pr2 q)). Qed. Lemma Dcuts_of_Dcuts_bij' : ∏ E : hsubtype Dcuts, ∏ (E_bot : ∏ x : Dcuts, E x -> ∏ y : Dcuts, y <= x -> E y) (E_open : ∏ x : Dcuts, E x -> ∃ y : Dcuts, x < y × E y), Dcuts_of_Dcuts'_val (Dcuts_of_Dcuts_val E) = E. Proof. intros. apply funextfun. intros x. apply hPropUnivalence. - apply hinhuniv. simpl pr1. intros r ; generalize (pr2 (pr2 r)). apply hinhuniv. intros X. apply E_bot with (1 := pr1 (pr2 X)). apply Dcuts_lt_le_rel. apply hinhpr. exists (pr1 r). split. + exact (pr1 (pr2 r)). + exact (pr2 (pr2 X)). - intros Ex. generalize (E_open _ Ex). apply hinhuniv. intros y. generalize (pr1 (pr2 y)). apply hinhfun. intros r. exists (pr1 r). split. + exact (pr1 (pr2 r)). + apply hinhpr. exists (pr1 y). split. * apply (pr2 (pr2 y)). * apply (pr2 (pr2 r)). Qed. Lemma isub_Dcuts_of_Dcuts (E : hsubtype Dcuts) E_bot E_corr : isUpperBound (X := PreorderedSetEffectiveOrder eo_Dcuts) E (Dcuts_of_Dcuts E E_bot E_corr). Proof. intros ; intros x Ex r Hr. apply hinhpr. now exists x. Qed. Lemma islbub_Dcuts_of_Dcuts (E : hsubtype Dcuts) E_bot E_corr : isSmallerThanUpperBounds (X := PreorderedSetEffectiveOrder eo_Dcuts) E (Dcuts_of_Dcuts E E_bot E_corr). Proof. intros. intros x Hx ; simpl. intros r ; apply hinhuniv ; intros y. generalize (Hx _ (pr1 (pr2 y))). intros H ; simple refine (H _ _). exact (pr2 (pr2 y)). Qed. Lemma islub_Dcuts_of_Dcuts (E : hsubtype eo_Dcuts) E_bot E_corr : isLeastUpperBound (X := PreorderedSetEffectiveOrder eo_Dcuts) E (Dcuts_of_Dcuts E E_bot E_corr). Proof. split. - exact (isub_Dcuts_of_Dcuts E E_bot E_corr). - exact (islbub_Dcuts_of_Dcuts E E_bot E_corr). Qed. (** * Definition of non-negative real numbers *) Global Opaque Dcuts. Global Opaque Dcuts_le_rel Dcuts_lt_rel Dcuts_ap_rel. Global Opaque Dcuts_zero Dcuts_one Dcuts_two Dcuts_plus Dcuts_minus Dcuts_mult Dcuts_inv Dcuts_max Dcuts_min Dcuts_half. Global Opaque Dcuts_lim_cauchy_seq. Declare Scope NR_scope. Delimit Scope NR_scope with NR. Local Open Scope NR_scope. Definition NonnegativeReals : ConstructiveCommutativeDivisionRig := Dcuts_ConstructiveCommutativeDivisionRig. Definition EffectivelyOrdered_NonnegativeReals : EffectivelyOrderedSet. Proof. exists NonnegativeReals. apply (pairEffectiveOrder Dcuts_le_rel Dcuts_lt_rel iseo_Dcuts_le_lt_rel). Defined. (** ** Relations *) Definition apNonnegativeReals : hrel NonnegativeReals := CCDRap. Definition leNonnegativeReals : po NonnegativeReals := EOle (X := EffectivelyOrdered_NonnegativeReals). Definition geNonnegativeReals : po NonnegativeReals := EOge (X := EffectivelyOrdered_NonnegativeReals). Definition ltNonnegativeReals : StrongOrder NonnegativeReals := EOlt (X := EffectivelyOrdered_NonnegativeReals). Definition gtNonnegativeReals : StrongOrder NonnegativeReals := EOgt (X := EffectivelyOrdered_NonnegativeReals). Notation "x ≠ y" := (apNonnegativeReals x y) (at level 70, no associativity) : NR_scope. Notation "x <= y" := (EOle_rel (X := EffectivelyOrdered_NonnegativeReals) x y) : NR_scope. Notation "x >= y" := (EOge_rel (X := EffectivelyOrdered_NonnegativeReals) x y) : NR_scope. Notation "x < y" := (EOlt_rel (X := EffectivelyOrdered_NonnegativeReals) x y) : NR_scope. Notation "x > y" := (EOgt_rel (X := EffectivelyOrdered_NonnegativeReals) eo_Dcuts x y) : NR_scope. (** ** Constants and Functions *) Definition zeroNonnegativeReals : NonnegativeReals := CCDRzero. Definition oneNonnegativeReals : NonnegativeReals := CCDRone. Definition twoNonnegativeReals : NonnegativeReals := Dcuts_two. Definition plusNonnegativeReals : binop NonnegativeReals := CCDRplus. Definition multNonnegativeReals : binop NonnegativeReals := CCDRmult. Definition NonnegativeRationals_to_NonnegativeReals (r : NonnegativeRationals) : NonnegativeReals := NonnegativeRationals_to_Dcuts r. Definition nat_to_NonnegativeReals (n : nat) : NonnegativeReals := NonnegativeRationals_to_NonnegativeReals (nat_to_NonnegativeRationals n). Notation "0" := zeroNonnegativeReals : NR_scope. Notation "1" := oneNonnegativeReals : NR_scope. Notation "2" := twoNonnegativeReals : NR_scope. Notation "x + y" := (plusNonnegativeReals x y) (at level 50, left associativity) : NR_scope. Notation "x * y" := (multNonnegativeReals x y) (at level 40, left associativity) : NR_scope. Definition invNonnegativeReals (x : NonnegativeReals) (Hx0 : x ≠ 0) : NonnegativeReals := CCDRinv x Hx0. Definition divNonnegativeReals (x y : NonnegativeReals) (Hy0 : y ≠ 0) : NonnegativeReals := x * (invNonnegativeReals y Hy0). (** ** Special functions *) Definition NonnegativeReals_to_hsubtypeNonnegativeRationals : NonnegativeReals → (hsubtype NonnegativeRationals) := pr1. Definition hsubtypeNonnegativeRationals_to_NonnegativeReals (X : NonnegativeRationals -> hProp) (Xbot : ∏ x : NonnegativeRationals, X x -> ∏ y : NonnegativeRationals, (y <= x)%NRat -> X y) (Xopen : ∏ x : NonnegativeRationals, X x -> hexists (λ y : NonnegativeRationals, (X y) × (x < y)%NRat)) (Xtop : Dcuts_def_corr X) : NonnegativeReals := make_Dcuts X Xbot Xopen Xtop. Definition minusNonnegativeReals : binop NonnegativeReals := Dcuts_minus. Definition halfNonnegativeReals : unop NonnegativeReals := Dcuts_half. Definition maxNonnegativeReals : binop NonnegativeReals := Dcuts_max. Definition minNonnegativeReals : binop NonnegativeReals := Dcuts_min. Notation "x - y" := (minusNonnegativeReals x y) (at level 50, left associativity) : NR_scope. Notation "x / 2" := (halfNonnegativeReals x) (at level 35, no associativity) : NR_scope. (** ** Theorems *) (** ** Compatibility with NonnegativeRationals *) Lemma NonnegativeRationals_to_NonnegativeReals_lt : ∏ x y : NonnegativeRationals, (x < y)%NRat <-> NonnegativeRationals_to_NonnegativeReals x < NonnegativeRationals_to_NonnegativeReals y. Proof. intros x y ; split. - intros Hxy. apply hinhpr. exists x. split ; simpl. + now apply isirrefl_ltNonnegativeRationals. + exact Hxy. - apply hinhuniv ; simpl ; intros q. eapply istrans_le_lt_ltNonnegativeRationals, (pr2 (pr2 q)). apply notlt_geNonnegativeRationals. exact (pr1 (pr2 q)). Qed. Lemma NonnegativeRationals_to_NonnegativeReals_le : ∏ x y : NonnegativeRationals, (x <= y)%NRat <-> NonnegativeRationals_to_NonnegativeReals x <= NonnegativeRationals_to_NonnegativeReals y. Proof. intros x y ; split. - intros H. apply Dcuts_nlt_ge. intro H0. revert H. apply_pr2 notge_ltNonnegativeRationals. apply_pr2 NonnegativeRationals_to_NonnegativeReals_lt. exact H0. - intros H. apply notlt_geNonnegativeRationals. intros H0. revert H. apply Dcuts_gt_nle. apply NonnegativeRationals_to_NonnegativeReals_lt. exact H0. Qed. Lemma NonnegativeRationals_to_NonnegativeReals_zero : NonnegativeRationals_to_NonnegativeReals 0%NRat = 0. Proof. reflexivity. Qed. Lemma NonnegativeRationals_to_NonnegativeReals_one : NonnegativeRationals_to_NonnegativeReals 1%NRat = 1. Proof. reflexivity. Qed. Lemma NonnegativeRationals_to_NonnegativeReals_plus : ∏ x y : NonnegativeRationals, NonnegativeRationals_to_NonnegativeReals (x + y)%NRat = NonnegativeRationals_to_NonnegativeReals x + NonnegativeRationals_to_NonnegativeReals y. Proof. intros x y. apply Dcuts_eq_is_eq. intros r. split. - intros Hr. generalize (eq0orgt0NonnegativeRationals y) ; apply sumofmaps ; intros Hy. 2: generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; intros Hx. + rewrite Hy in Hr |- * ; clear y Hy. rewrite isrunit_zeroNonnegativeRationals in Hr. rewrite isrunit_Dcuts_plus_zero. exact Hr. + rewrite Hx in Hr |- * ; clear x Hx. rewrite islunit_zeroNonnegativeRationals in Hr. rewrite islunit_Dcuts_plus_zero. exact Hr. + assert (Hxy : (0 < x + y)%NRat). { apply ispositive_plusNonnegativeRationals_r. exact Hy. } apply hinhpr ; right. exists ((r * (x / (x + y)))%NRat,,(r * (y / (x + y)))%NRat). simpl. split ; [ | split]. * unfold divNonnegativeRationals. rewrite <- isldistr_mult_plusNonnegativeRationals, <- isrdistr_mult_plusNonnegativeRationals, isrinv_NonnegativeRationals, isrunit_oneNonnegativeRationals. { reflexivity. } exact Hxy. * unfold divNonnegativeRationals. rewrite <- isassoc_multNonnegativeRationals, (iscomm_multNonnegativeRationals _ x), isassoc_multNonnegativeRationals. pattern x at 3 ; rewrite <- (isrunit_oneNonnegativeRationals x). apply multNonnegativeRationals_ltcompat_l. { exact Hx. } rewrite <- (isrinv_NonnegativeRationals (x + y)%NRat). ** apply multNonnegativeRationals_ltcompat_r. *** apply ispositive_invNonnegativeRationals. exact Hxy. *** exact Hr. ** exact Hxy. * unfold divNonnegativeRationals. rewrite <- isassoc_multNonnegativeRationals, (iscomm_multNonnegativeRationals _ y), isassoc_multNonnegativeRationals. pattern y at 3 ; rewrite <- (isrunit_oneNonnegativeRationals y). apply multNonnegativeRationals_ltcompat_l. { exact Hy. } rewrite <- (isrinv_NonnegativeRationals (x + y)%NRat). ** apply multNonnegativeRationals_ltcompat_r. *** apply ispositive_invNonnegativeRationals. exact Hxy. *** exact Hr. ** exact Hxy. - apply hinhuniv ; apply sumofmaps ; [ apply sumofmaps ; [intros Hrx | intros Hry] | intros xy ; rewrite (pr1 (pr2 xy))] ; simpl. + eapply istrans_lt_le_ltNonnegativeRationals, plusNonnegativeRationals_le_r. exact Hrx. + eapply istrans_lt_le_ltNonnegativeRationals, plusNonnegativeRationals_le_l. exact Hry. + apply plusNonnegativeRationals_ltcompat. * exact (pr1 (pr2 (pr2 xy))). * exact (pr2 (pr2 (pr2 xy))). Qed. Lemma NonnegativeRationals_to_NonnegativeReals_minus : ∏ x y : NonnegativeRationals, NonnegativeRationals_to_NonnegativeReals (x - y)%NRat = NonnegativeRationals_to_NonnegativeReals x - NonnegativeRationals_to_NonnegativeReals y. Proof. intros x y. generalize (isdecrel_leNonnegativeRationals x y) ; apply sumofmaps ; intros Hxy. - rewrite minusNonnegativeRationals_eq_zero, Dcuts_minus_eq_zero. + reflexivity. + apply NonnegativeRationals_to_NonnegativeReals_le. exact Hxy. + exact Hxy. - apply Dcuts_minus_correct_r. rewrite <- NonnegativeRationals_to_NonnegativeReals_plus, minusNonnegativeRationals_plus_r. + reflexivity. + apply lt_leNonnegativeRationals. apply notge_ltNonnegativeRationals. exact Hxy. Qed. Lemma NonnegativeRationals_to_NonnegativeReals_mult : ∏ x y : NonnegativeRationals, NonnegativeRationals_to_NonnegativeReals (x * y)%NRat = NonnegativeRationals_to_NonnegativeReals x * NonnegativeRationals_to_NonnegativeReals y. Proof. intros x y. generalize (eq0orgt0NonnegativeRationals x) ; apply sumofmaps ; [intros -> | intros Hx]. - rewrite islabsorb_zero_multNonnegativeRationals, islabsorb_Dcuts_mult_zero. reflexivity. - rewrite <- (Dcuts_NQmult_mult _ _ Hx). apply Dcuts_eq_is_eq. intros r. split. + simpl ; intros Hr ; apply hinhpr. exists (r / x)%NRat. split. * apply pathsinv0, multdivNonnegativeRationals. exact Hx. * rewrite <- (isrunit_oneNonnegativeRationals y), <- (isrinv_NonnegativeRationals x), <- isassoc_multNonnegativeRationals. ** apply multNonnegativeRationals_ltcompat_r. *** apply ispositive_invNonnegativeRationals. exact Hx. *** rewrite iscomm_multNonnegativeRationals. exact Hr. ** exact Hx. + apply hinhuniv. simpl. intros ry. rewrite (pr1 (pr2 ry)). apply multNonnegativeRationals_ltcompat_l. * exact Hx. * exact (pr2 (pr2 ry)). Qed. Lemma NonnegativeRationals_to_NonnegativeReals_nattorig : ∏ n : nat, NonnegativeRationals_to_NonnegativeReals (nattorig n) = nattorig n. Proof. induction n as [|n IHn]. - reflexivity. - rewrite !nattorigS. rewrite NonnegativeRationals_to_NonnegativeReals_plus, IHn. reflexivity. Qed. Lemma nat_to_NonnegativeReals_O : nat_to_NonnegativeReals O = 0. Proof. unfold nat_to_NonnegativeReals. rewrite nat_to_NonnegativeRationals_O. reflexivity. Qed. Lemma nat_to_NonnegativeReals_Sn : ∏ n : nat, nat_to_NonnegativeReals (S n) = nat_to_NonnegativeReals n + 1. Proof. intros n. unfold nat_to_NonnegativeReals. rewrite nat_to_NonnegativeRationals_Sn. rewrite NonnegativeRationals_to_NonnegativeReals_plus. reflexivity. Qed. (** Order, apartness, and equality *) Definition istrans_leNonnegativeReals : ∏ x y z : NonnegativeReals, x <= y -> y <= z -> x <= z := istrans_EOle (X := EffectivelyOrdered_NonnegativeReals). Definition isrefl_leNonnegativeReals : ∏ x : NonnegativeReals, x <= x := isrefl_EOle (X := EffectivelyOrdered_NonnegativeReals). Lemma isantisymm_leNonnegativeReals : ∏ x y : NonnegativeReals, x <= y × y <= x <-> x = y. Proof. intros x y ; split. - intros H. apply Dcuts_le_ge_eq. + now apply (pr1 H). + now apply (pr2 H). - intros ->. split ; apply isrefl_leNonnegativeReals. Qed. Lemma eqNonnegativeReals_le : ∏ x y : NonnegativeReals, x = y -> x <= y. Proof. intros x y ->. apply isrefl_leNonnegativeReals. Qed. Definition istrans_ltNonnegativeReals : ∏ x y z : NonnegativeReals, x < y -> y < z -> x < z := istrans_EOlt (X := EffectivelyOrdered_NonnegativeReals). Definition iscotrans_ltNonnegativeReals : ∏ x y z : NonnegativeReals, x < z -> x < y ∨ y < z := iscotrans_Dcuts_lt_rel. Definition isirrefl_ltNonnegativeReals : ∏ x : NonnegativeReals, ¬ (x < x) := isirrefl_EOlt (X := EffectivelyOrdered_NonnegativeReals). Definition istrans_lt_le_ltNonnegativeReals : ∏ x y z : NonnegativeReals, x < y -> y <= z -> x < z := istrans_EOlt_le (X := EffectivelyOrdered_NonnegativeReals). Definition istrans_le_lt_ltNonnegativeReals : ∏ x y z : NonnegativeReals, x <= y -> y < z -> x < z := istrans_EOle_lt (X := EffectivelyOrdered_NonnegativeReals). Lemma lt_leNonnegativeReals : ∏ x y : NonnegativeReals, x < y -> x <= y. Proof. exact Dcuts_lt_le_rel. Qed. Lemma notlt_leNonnegativeReals : ∏ x y : NonnegativeReals, ¬ (x < y) <-> (y <= x). Proof. exact Dcuts_nlt_ge. Qed. Lemma isnonnegative_NonnegativeReals : ∏ x : NonnegativeReals, 0 <= x. Proof. intros x. now apply Dcuts_ge_0. Qed. Lemma isnonnegative_NonnegativeReals' : ∏ x : NonnegativeReals, ¬ (x < 0). Proof. intros x. now apply Dcuts_notlt_0. Qed. Lemma le0_NonnegativeReals : ∏ x : NonnegativeReals, (x <= 0) <-> (x = 0). Proof. intros x ; split ; intros Hx. - apply isantisymm_leNonnegativeReals. split. + exact Hx. + apply isnonnegative_NonnegativeReals. - rewrite Hx. apply isrefl_leNonnegativeReals. Qed. Lemma ap_ltNonnegativeReals : ∏ x y : NonnegativeReals, x ≠ y <-> (x < y) ⨿ (y < x). Proof. now intros x y ; split. Qed. Definition isirrefl_apNonnegativeReals : ∏ x : NonnegativeReals, ¬ (x ≠ x) := isirrefl_Dcuts_ap_rel. Definition issymm_apNonnegativeReals : ∏ x y : NonnegativeReals, x ≠ y -> y ≠ x := issymm_Dcuts_ap_rel. Definition iscotrans_apNonnegativeReals : ∏ x y z : NonnegativeReals, x ≠ z -> x ≠ y ∨ y ≠ z := iscotrans_Dcuts_ap_rel. Lemma istight_apNonnegativeReals: ∏ x y : NonnegativeReals, (¬ (x ≠ y)) <-> (x = y). Proof. intros x y. split. - now apply istight_Dcuts_ap_rel. - intros ->. now apply isirrefl_Dcuts_ap_rel. Qed. Lemma ispositive_apNonnegativeReals : ∏ x : NonnegativeReals, x ≠ 0 <-> 0 < x. Proof. intros X ; split. - apply sumofmaps ; [ | intros Hlt ]. + apply hinhuniv ; intros x. apply fromempty. now apply (Dcuts_zero_empty _ (pr2 (pr2 x))). + exact Hlt. - intros Hx. now right. Qed. Definition isnonzeroNonnegativeReals: 1 ≠ 0 := isnonzeroCCDR (X := NonnegativeReals). Lemma ispositive_oneNonnegativeReals: 0 < 1. Proof. apply ispositive_apNonnegativeReals. exact isnonzeroNonnegativeReals. Qed. (** addition *) Definition ap_plusNonnegativeReals: ∏ x x' y y' : NonnegativeReals, x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y' := apCCDRplus (X := NonnegativeReals). Definition islunit_zero_plusNonnegativeReals: ∏ x : NonnegativeReals, 0 + x = x := islunit_CCDRzero_CCDRplus (X := NonnegativeReals). Definition isrunit_zero_plusNonnegativeReals: ∏ x : NonnegativeReals, x + 0 = x := isrunit_CCDRzero_CCDRplus (X := NonnegativeReals). Definition isassoc_plusNonnegativeReals: ∏ x y z : NonnegativeReals, x + y + z = x + (y + z) := isassoc_CCDRplus (X := NonnegativeReals). Definition iscomm_plusNonnegativeReals: ∏ x y : NonnegativeReals, x + y = y + x := iscomm_CCDRplus (X := NonnegativeReals). Definition plusNonnegativeReals_ltcompat_l : ∏ x y z: NonnegativeReals, (y < z) <-> (y + x < z + x) := Dcuts_plus_ltcompat_l. Definition plusNonnegativeReals_ltcompat_r : ∏ x y z: NonnegativeReals, (y < z) <-> (x + y < x + z) := Dcuts_plus_ltcompat_r. Lemma plusNonnegativeReals_ltcompat : ∏ x y z t : NonnegativeReals, x < y -> z < t -> x + z < y + t. Proof. intros x y z t Hxy Hzt. eapply istrans_ltNonnegativeReals, plusNonnegativeReals_ltcompat_l. - now apply plusNonnegativeReals_ltcompat_r. - exact Hxy. Qed. Lemma plusNonnegativeReals_lt_l: ∏ x y : NonnegativeReals, 0 < x <-> y < x + y. Proof. intros x y. pattern y at 1. rewrite <- (islunit_zero_plusNonnegativeReals y). now apply plusNonnegativeReals_ltcompat_l. Qed. Lemma plusNonnegativeReals_lt_r: ∏ x y : NonnegativeReals, 0 < y <-> x < x + y. Proof. intros x y. pattern x at 1. rewrite <- (isrunit_zero_plusNonnegativeReals x). now apply plusNonnegativeReals_ltcompat_r. Qed. Definition plusNonnegativeReals_lecompat_l : ∏ x y z: NonnegativeReals, (y <= z) <-> (y + x <= z + x) := Dcuts_plus_lecompat_l. Definition plusNonnegativeReals_lecompat_r : ∏ x y z: NonnegativeReals, (y <= z) <-> (x + y <= x + z) := Dcuts_plus_lecompat_r. Lemma plusNonnegativeReals_lecompat : ∏ x y x' y' : NonnegativeReals, x <= y -> x' <= y' -> x + x' <= y + y'. Proof. intros x y x' y' H H'. refine (istrans_leNonnegativeReals _ _ _ _ _). - apply plusNonnegativeReals_lecompat_l. apply H. - apply plusNonnegativeReals_lecompat_r. exact H'. Qed. Lemma plusNonnegativeReals_le_l : ∏ (x y : NonnegativeReals), x <= x + y. Proof. exact Dcuts_plus_le_l. Qed. Lemma plusNonnegativeReals_le_r : ∏ (x y : NonnegativeReals), y <= x + y. Proof. exact Dcuts_plus_le_r. Qed. Lemma plusNonnegativeReals_le_ltcompat : ∏ x y z t : NonnegativeReals, x <= y -> z < t -> x + z < y + t. Proof. intros x y z t Hxy Hzt. eapply istrans_le_lt_ltNonnegativeReals, plusNonnegativeReals_ltcompat_r, Hzt. now apply plusNonnegativeReals_lecompat_l. Qed. Lemma plusNonnegativeReals_eqcompat_l : ∏ x y z: NonnegativeReals, (y + x = z + x) <-> (y = z). Proof. intros x y z ; split. - intro H ; apply isantisymm_leNonnegativeReals ; split. + apply_pr2 (plusNonnegativeReals_lecompat_l x). rewrite H ; refine (isrefl_leNonnegativeReals _). + apply_pr2 (plusNonnegativeReals_lecompat_l x). rewrite H ; refine (isrefl_leNonnegativeReals _). - now intros ->. Qed. Lemma plusNonnegativeReals_eqcompat_r : ∏ x y z: NonnegativeReals, (x + y = x + z) <-> (y = z). Proof. intros x y z. rewrite ! (iscomm_plusNonnegativeReals x). now apply plusNonnegativeReals_eqcompat_l. Qed. Lemma plusNonnegativeReals_apcompat_l : ∏ x y z: NonnegativeReals, (y ≠ z) <-> (y + x ≠ z + x). Proof. intros a b c. split. - intro H. apply ap_ltNonnegativeReals. apply_pr2_in ap_ltNonnegativeReals H. induction H as [H | H]. + left ; now apply plusNonnegativeReals_ltcompat_l. + right ; now apply plusNonnegativeReals_ltcompat_l. - now apply islapbinop_Dcuts_plus. Qed. Lemma plusNonnegativeReals_apcompat_r : ∏ x y z: NonnegativeReals, (y ≠ z) <-> (x + y ≠ x + z). Proof. intros x y z. rewrite ! (iscomm_plusNonnegativeReals x). now apply plusNonnegativeReals_apcompat_l. Qed. (** Subtraction *) Definition minusNonnegativeReals_plus_r : ∏ x y z : NonnegativeReals, z <= y -> x = y - z -> y = x + z := Dcuts_minus_plus_r. Definition minusNonnegativeReals_eq_zero : ∏ x y : NonnegativeReals, x <= y -> x - y = 0 := Dcuts_minus_eq_zero. Definition minusNonnegativeReals_correct_r : ∏ x y z : NonnegativeReals, x = y + z -> y = x - z := Dcuts_minus_correct_r. Definition minusNonnegativeReals_correct_l : ∏ x y z : NonnegativeReals, x = y + z -> z = x - y := Dcuts_minus_correct_l. Definition ispositive_minusNonnegativeReals : ∏ x y : NonnegativeReals, (y < x) <-> (0 < x - y) := ispositive_Dcuts_minus. Definition minusNonnegativeReals_le : ∏ x y : NonnegativeReals, x - y <= x := Dcuts_minus_le. (** Multiplication *) Definition ap_multNonnegativeReals: ∏ x x' y y' : NonnegativeReals, x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y' := apCCDRmult (X := NonnegativeReals). Definition islunit_one_multNonnegativeReals: ∏ x : NonnegativeReals, 1 * x = x := islunit_CCDRone_CCDRmult (X := NonnegativeReals). Definition isrunit_one_multNonnegativeReals: ∏ x : NonnegativeReals, x * 1 = x := isrunit_CCDRone_CCDRmult (X := NonnegativeReals). Definition isassoc_multNonnegativeReals: ∏ x y z : NonnegativeReals, x * y * z = x * (y * z) := isassoc_CCDRmult (X := NonnegativeReals). Definition iscomm_multNonnegativeReals: ∏ x y : NonnegativeReals, x * y = y * x := iscomm_CCDRmult (X := NonnegativeReals). Definition islabsorb_zero_multNonnegativeReals: ∏ x : NonnegativeReals, 0 * x = 0 := islabsorb_CCDRzero_CCDRmult (X := NonnegativeReals). Definition israbsorb_zero_multNonnegativeReals: ∏ x : NonnegativeReals, x * 0 = 0 := israbsorb_CCDRzero_CCDRmult (X := NonnegativeReals). Definition multNonnegativeReals_ltcompat_l : ∏ x y z: NonnegativeReals, (0 < x) -> (y < z) -> (y * x < z * x) := Dcuts_mult_ltcompat_l. Definition multNonnegativeReals_ltcompat_l' : ∏ x y z: NonnegativeReals, (y * x < z * x) -> (y < z) := Dcuts_mult_ltcompat_l'. Definition multNonnegativeReals_lecompat_l : ∏ x y z: NonnegativeReals, (0 < x) -> (y * x <= z * x) -> (y <= z) := Dcuts_mult_lecompat_l. Definition multNonnegativeReals_lecompat_l' : ∏ x y z: NonnegativeReals, (y <= z) -> (y * x <= z * x) := Dcuts_mult_lecompat_l'. Definition multNonnegativeReals_ltcompat_r : ∏ x y z: NonnegativeReals, (0 < x) -> (y < z) -> (x * y < x * z) := Dcuts_mult_ltcompat_r. Definition multNonnegativeReals_ltcompat_r' : ∏ x y z: NonnegativeReals, (x * y < x * z) -> (y < z) := Dcuts_mult_ltcompat_r'. Definition multNonnegativeReals_lecompat_r : ∏ x y z: NonnegativeReals, (0 < x) -> (x * y <= x * z) -> (y <= z) := Dcuts_mult_lecompat_r. Definition multNonnegativeReals_lecompat_r' : ∏ x y z: NonnegativeReals, (y <= z) -> (x * y <= x * z) := Dcuts_mult_lecompat_r'. (** Multiplicative Inverse *) Definition islinv_invNonnegativeReals: ∏ (x : NonnegativeReals) (Hx0 : x ≠ 0), invNonnegativeReals x Hx0 * x = 1 := islinv_CCDRinv (X := NonnegativeReals). Definition isrinv_invNonnegativeReals: ∏ (x : NonnegativeReals) (Hx0 : x ≠ 0), x * invNonnegativeReals x Hx0 = 1 := isrinv_CCDRinv (X := NonnegativeReals). Definition isldistr_plus_multNonnegativeReals: ∏ x y z : NonnegativeReals, z * (x + y) = z * x + z * y := isldistr_CCDRplus_CCDRmult (X := NonnegativeReals). Definition isrdistr_plus_multNonnegativeReals: ∏ x y z : NonnegativeReals, (x + y) * z = x * z + y * z := isrdistr_CCDRplus_CCDRmult (X := NonnegativeReals). (** maximum *) Lemma iscomm_maxNonnegativeReals : ∏ x y : NonnegativeReals, maxNonnegativeReals x y = maxNonnegativeReals y x. Proof. exact iscomm_Dcuts_max. Qed. Lemma isassoc_maxNonnegativeReals : ∏ x y z : NonnegativeReals, maxNonnegativeReals (maxNonnegativeReals x y) z = maxNonnegativeReals x (maxNonnegativeReals y z). Proof. exact isassoc_Dcuts_max. Qed. Lemma isldistr_max_plusNonnegativeReals : ∏ x y z : NonnegativeReals, z + maxNonnegativeReals x y = maxNonnegativeReals (z + x) (z + y). Proof. exact isldistr_Dcuts_max_plus. Qed. Lemma isrdistr_max_plusNonnegativeReals : ∏ x y z : NonnegativeReals, maxNonnegativeReals x y + z = maxNonnegativeReals (x + z) (y + z). Proof. intros x y z. rewrite !(iscomm_plusNonnegativeReals _ z). now apply isldistr_max_plusNonnegativeReals. Qed. Lemma isldistr_max_multNonnegativeReals : ∏ x y z : NonnegativeReals, z * maxNonnegativeReals x y = maxNonnegativeReals (z * x) (z * y). Proof. exact isldistr_Dcuts_max_mult. Qed. Lemma isrdistr_max_multNonnegativeReals : ∏ x y z : NonnegativeReals, maxNonnegativeReals x y * z = maxNonnegativeReals (x * z) (y * z). Proof. intros x y z. rewrite !(iscomm_multNonnegativeReals _ z). now apply isldistr_max_multNonnegativeReals. Qed. Lemma maxNonnegativeReals_carac_l : ∏ x y : NonnegativeReals, y <= x -> maxNonnegativeReals x y = x. Proof. exact Dcuts_max_carac_l. Qed. Lemma maxNonnegativeReals_carac_r : ∏ x y : NonnegativeReals, x <= y -> maxNonnegativeReals x y = y. Proof. exact Dcuts_max_carac_r. Qed. Lemma maxNonnegativeReals_le_l : ∏ x y : NonnegativeReals, x <= maxNonnegativeReals x y. Proof. exact Dcuts_max_le_l. Qed. Lemma maxNonnegativeReals_le_r : ∏ x y : NonnegativeReals, y <= maxNonnegativeReals x y. Proof. exact Dcuts_max_le_r. Qed. Lemma maxNonnegativeReals_lt : ∏ x y z : NonnegativeReals, x < z -> y < z -> maxNonnegativeReals x y < z. Proof. exact Dcuts_max_lt. Qed. Lemma maxNonnegativeReals_le : ∏ x y z : NonnegativeReals, x <= z -> y <= z -> maxNonnegativeReals x y <= z. Proof. exact Dcuts_max_le. Qed. Lemma maxNonnegativeReals_minus_plus: ∏ x y : NonnegativeReals, maxNonnegativeReals x y = (x - y) + y. Proof. intros x y. apply pathsinv0. now apply Dcuts_minus_plus_max. Qed. Lemma isldistr_minus_multNonnegativeReals : ∏ x y z : NonnegativeReals, z * (x - y) = z * x - z * y. Proof. intros x y z. apply plusNonnegativeReals_eqcompat_l with (Dcuts_mult z y). rewrite <- isldistr_plus_multNonnegativeReals, <- !maxNonnegativeReals_minus_plus. apply isldistr_max_multNonnegativeReals. Qed. Lemma isrdistr_minus_multNonnegativeReals : ∏ x y z : NonnegativeReals, (x - y) * z = x * z - y * z. Proof. intros x y z. rewrite !(iscomm_multNonnegativeReals _ z). now apply isldistr_minus_multNonnegativeReals. Qed. Lemma isassoc_minusNonnegativeReals : ∏ x y z : NonnegativeReals, (x - y) - z = x - (y + z). Proof. intros x y z. apply plusNonnegativeReals_eqcompat_l with (y + z). rewrite <- maxNonnegativeReals_minus_plus. rewrite (iscomm_plusNonnegativeReals y). rewrite <- isassoc_plusNonnegativeReals. rewrite <- maxNonnegativeReals_minus_plus. rewrite isrdistr_max_plusNonnegativeReals. rewrite <- maxNonnegativeReals_minus_plus. rewrite isassoc_maxNonnegativeReals. apply maponpaths. apply maxNonnegativeReals_carac_r. now apply plusNonnegativeReals_le_r. Qed. Lemma iscomm_minusNonnegativeReals : ∏ x y z : NonnegativeReals, x - y - z = x - z - y. Proof. intros x y z. rewrite !isassoc_minusNonnegativeReals. apply maponpaths. now apply iscomm_plusNonnegativeReals. Qed. Lemma max_plusNonnegativeReals : ∏ x y : NonnegativeReals, (0 < x -> y = 0) -> maxNonnegativeReals x y = x + y. Proof. exact Dcuts_max_plus. Qed. (** half of a non-negative real numbers *) Lemma double_halfNonnegativeReals : ∏ x : NonnegativeReals, x = (x / 2) + (x / 2). Proof. exact Dcuts_half_double. Qed. Lemma isdistr_plus_halfNonnegativeReals: ∏ x y : NonnegativeReals, (x + y) / 2 = (x / 2) + (y / 2). Proof. exact isdistr_Dcuts_half_plus. Qed. Lemma ispositive_halfNonnegativeReals: ∏ x : NonnegativeReals, (0 < x) <-> (0 < x / 2). Proof. exact ispositive_Dcuts_half. Qed. (** ** NonnegativeRationals is dense in NonnegativeReals *) Lemma NonnegativeReals_dense : ∏ x y : NonnegativeReals, x < y -> ∃ r : NonnegativeRationals, x < NonnegativeRationals_to_NonnegativeReals r × NonnegativeRationals_to_NonnegativeReals r < y. Proof. intros x y. apply hinhuniv ; intros q. generalize (is_Dcuts_open y (pr1 q) (pr2 (pr2 q))). apply hinhfun ; intros r. exists (pr1 r) ; split ; apply hinhpr. - exists (pr1 q) ; split. + exact (pr1 (pr2 q)). + exact (pr2 (pr2 r)). - exists (pr1 r) ; split. + exact (isirrefl_ltNonnegativeRationals _). + exact (pr1 (pr2 r)). Qed. (** ** Archimedean property *) Lemma NonnegativeReals_Archimedean : isarchrig gtNonnegativeReals. Proof. set (H := isarchNonnegativeRationals). repeat split. - intros y1 y2 Hy. generalize (NonnegativeReals_dense _ _ Hy). apply hinhuniv ; clear Hy. intros r2. generalize (NonnegativeReals_dense _ _ (pr2 (pr2 r2))). apply hinhuniv. intros r1. generalize (isarchrig_diff _ H _ _ (pr2 (NonnegativeRationals_to_NonnegativeReals_lt (pr1 r2) (pr1 r1)) (pr1 (pr2 r1)))). apply hinhfun. intros n. exists (pr1 n). eapply istrans_le_lt_ltNonnegativeReals, istrans_lt_le_ltNonnegativeReals. 2: apply NonnegativeRationals_to_NonnegativeReals_lt, (pr2 n). 1: rewrite NonnegativeRationals_to_NonnegativeReals_plus, NonnegativeRationals_to_NonnegativeReals_mult, NonnegativeRationals_to_NonnegativeReals_nattorig. 1: apply plusNonnegativeReals_lecompat_r, multNonnegativeReals_lecompat_r'. 1: apply lt_leNonnegativeReals, (pr1 (pr2 r2)). rewrite NonnegativeRationals_to_NonnegativeReals_mult, NonnegativeRationals_to_NonnegativeReals_nattorig. apply multNonnegativeReals_lecompat_r'. apply lt_leNonnegativeReals, (pr2 (pr2 r1)). - intros x. generalize (Dcuts_def_corr_finite _ (is_Dcuts_corr x)). apply hinhuniv ; intros r. generalize (isarchrig_gt _ H (pr1 r)). apply hinhfun. intros n. exists (pr1 n). apply istrans_le_lt_ltNonnegativeReals with (NonnegativeRationals_to_NonnegativeReals (pr1 r)). + apply NonnegativeRationals_to_Dcuts_notin_le. exact (pr2 r). + rewrite <- NonnegativeRationals_to_NonnegativeReals_nattorig. apply NonnegativeRationals_to_NonnegativeReals_lt. exact (pr2 n). - intros x. apply hinhpr. exists 1%nat. apply istrans_lt_le_ltNonnegativeReals with 1. + apply ispositive_oneNonnegativeReals. + apply plusNonnegativeReals_le_l. Qed. (** ** Completeness *) Definition Cauchy_seq (u : nat -> NonnegativeReals) : hProp := make_hProp (∏ eps : NonnegativeReals, 0 < eps -> hexists (λ N : nat, ∏ n m : nat, N ≤ n -> N ≤ m -> u n < u m + eps × u m < u n + eps)) (impred_isaprop _ (λ _, isapropimpl _ _ (pr2 _))). Definition is_lim_seq (u : nat -> NonnegativeReals) (l : NonnegativeReals) : hProp := make_hProp (∏ eps : NonnegativeReals, 0 < eps -> hexists (λ N : nat, ∏ n : nat, N ≤ n -> u n < l + eps × l < u n + eps)) (impred_isaprop _ (λ _, isapropimpl _ _ (pr2 _))). Definition Cauchy_lim_seq (u : nat → NonnegativeReals) (Cu : Cauchy_seq u) : NonnegativeReals := (Dcuts_lim_cauchy_seq u Cu). Definition Cauchy_seq_impl_ex_lim_seq (u : nat → NonnegativeReals) (Cu : Cauchy_seq u) : is_lim_seq u (Cauchy_lim_seq u Cu) := (Dcuts_Cauchy_seq_impl_ex_lim_seq u Cu). (** Additional theorems and definitions about limits *) Lemma is_lim_seq_unique_aux (u : nat → NonnegativeReals) (l l' : NonnegativeReals) : is_lim_seq u l → is_lim_seq u l' → l < l' → empty. Proof. intros Hl Hl' Hlt. assert (Hlt0 : 0 < l' - l). { now apply ispositive_minusNonnegativeReals. } assert (Hlt0' : 0 < (l' - l) / 2). { now apply ispositive_Dcuts_half. } generalize (Hl _ Hlt0') (Hl' _ Hlt0') ; clear Hl Hl'. apply (hinhuniv2 (P := make_hProp _ isapropempty)). intros N M. generalize (pr2 N (max (pr1 N) (pr1 M)) (max_le_l _ _)) ; intros Hn. generalize (pr2 M (max (pr1 N) (pr1 M)) (max_le_r _ _)) ; intros Hm. apply (isirrefl_Dcuts_lt_rel ((l + l') / 2)). apply istrans_Dcuts_lt_rel with (u (max (pr1 N) (pr1 M))). - apply_pr2 (plusNonnegativeReals_ltcompat_l ((l' - l) / 2)). rewrite <- isdistr_Dcuts_half_plus. rewrite (iscomm_plusNonnegativeReals l), isassoc_plusNonnegativeReals, (iscomm_plusNonnegativeReals l). rewrite <- (minusNonnegativeReals_plus_r (l' - l) l' l), isdistr_Dcuts_half_plus, <- Dcuts_half_double. + exact (pr2 Hm). + now apply Dcuts_lt_le_rel. + reflexivity. - pattern l' at 1; rewrite (minusNonnegativeReals_plus_r (l' - l) l' l), (iscomm_plusNonnegativeReals _ l), <- isassoc_plusNonnegativeReals, !isdistr_Dcuts_half_plus, <- Dcuts_half_double. + exact (pr1 Hn). + now apply Dcuts_lt_le_rel. + reflexivity. Qed. Lemma is_lim_seq_unique (u : nat → NonnegativeReals) (l l' : NonnegativeReals) : is_lim_seq u l → is_lim_seq u l' → l = l'. Proof. intros Hl Hl'. apply istight_apNonnegativeReals. unfold neg ; apply sumofmaps. - now apply (is_lim_seq_unique_aux u). - now apply (is_lim_seq_unique_aux u). Qed. Lemma isaprop_ex_lim_seq : ∏ u : nat -> NonnegativeReals, isaprop (∑ l : NonnegativeReals, is_lim_seq u l). Proof. intros u l l'. apply (iscontrweqf (X := (pr1 l = pr1 l'))). - now apply invweq, total2_paths_hProp_equiv. - rewrite (is_lim_seq_unique _ _ _ (pr2 l) (pr2 l')). apply iscontrloopsifisaset. apply pr2. Qed. Definition ex_lim_seq (u : nat → NonnegativeReals) : hProp := make_hProp (∑ l : NonnegativeReals, is_lim_seq u l) (isaprop_ex_lim_seq u). Definition Lim_seq (u : nat → NonnegativeReals) (Lu : ex_lim_seq u) : NonnegativeReals := pr1 Lu. (* End of the file NonnegativeReals.v *) UniMath-20231010/UniMath/RealNumbers/Prelim.v000066400000000000000000000071331451125700300205160ustar00rootroot00000000000000(** * Additional theorems and definitions *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Tactics. Require Export UniMath.Topology.Prelim. (** ** for RationalNumbers.v *) Require Export UniMath.NumberSystems.RationalNumbers. Require Export UniMath.Algebra.Archimedean. Local Open Scope hq_scope. Notation "x <= y" := (hqleh x y) : hq_scope. Notation "x >= y" := (hqgeh x y) : hq_scope. Notation "x < y" := (hqlth x y) : hq_scope. Notation "x > y" := (hqgth x y) : hq_scope. Notation "/ x" := (hqmultinv x) : hq_scope. Notation "x / y" := (hqdiv x y) : hq_scope. Notation "2" := (hztohq (nattohz 2)) : hq_scope. Lemma hzone_neg_hzzero : neg (1%hz = 0%hz). Proof. confirm_not_equal isdeceqhz. Qed. Definition one_intdomnonzerosubmonoid : intdomnonzerosubmonoid hzintdom. Proof. exists 1%hz ; simpl. exact hzone_neg_hzzero. Defined. Opaque hz. Lemma hq2eq1plus1 : 2 = 1 + 1. Proof. confirm_equal isdeceqhq. Qed. Lemma hq2_gt0 : 2 > 0. Proof. confirm_yes hqgthdec 2 0. Qed. Lemma hq1_gt0 : 1 > 0. Proof. confirm_yes hqgthdec 1 0. Qed. Lemma hq1ge0 : (0 <= 1)%hq. Proof. confirm_yes hqlehdec 0 1. Qed. Lemma hqgth_hqneq : ∏ x y : hq, x > y -> hqneq x y. Proof. intros x y Hlt Heq. rewrite Heq in Hlt. now apply isirreflhqgth with y. Qed. Lemma hqldistr : ∏ x y z, x * (y + z) = x * y + x * z. Proof. intros x y z. now apply ringldistr. Qed. Lemma hqmult2r : ∏ x : hq, x * 2 = x + x. Proof. intros x. now rewrite hq2eq1plus1, hqldistr, (hqmultr1 x). Qed. Lemma hqplusdiv2 : ∏ x : hq, x = (x + x) / 2. intros x. apply hqmultrcan with 2. - now apply hqgth_hqneq, hq2_gt0. - unfold hqdiv. rewrite hqmultassoc. rewrite (hqislinvmultinv 2). 2: now apply hqgth_hqneq, hq2_gt0. rewrite (hqmultr1 (x + x)). apply hqmult2r. Qed. Lemma hqlth_between : ∏ x y : hq, x < y -> total2 (λ z, (x < z) × (z < y)). Proof. assert (H0 : / 2 > 0). { apply hqgthandmultlinv with 2. - apply hq2_gt0. - rewrite hqisrinvmultinv, hqmultx0. + now apply hq1_gt0. + now apply hqgth_hqneq, hq2_gt0. } intros x y Hlt. exists ((x + y) / 2). split. - pattern x at 1. rewrite (hqplusdiv2 x). unfold hqdiv. apply (hqlthandmultr _ _ (/ 2)). + exact H0. + now apply (hqlthandplusl _ _ x Hlt). - pattern y at 2. rewrite (hqplusdiv2 y). unfold hqdiv. apply (hqlthandmultr _ _ (/ 2)). + exact H0. + now apply (hqlthandplusr _ _ y Hlt). Qed. Lemma hq0lehandplus: ∏ n m : hq, 0 <= n -> 0 <= m -> 0 <= (n + m). Proof. intros n m Hn Hm. eapply istranshqleh, hqlehandplusl, Hm. now rewrite hqplusr0. Qed. Lemma hq0lehandmult: ∏ n m : hq, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. intros n m. exact hqmultgeh0geh0. Qed. Lemma hq0leminus : ∏ r q : hq, r <= q -> 0 <= q - r. Proof. intros r q Hr. apply hqlehandplusrinv with r. unfold hqminus. rewrite hqplusassoc, hqlminus. now rewrite hqplusl0, hqplusr0. Qed. Lemma hqinv_gt0 (x : hq) : 0 < x → 0 < / x. Proof. unfold hqlth. intros Hx. apply hqgthandmultlinv with x. - exact Hx. - rewrite hqmultx0. rewrite hqisrinvmultinv. + exact hq1_gt0. + apply hqgth_hqneq. exact Hx. Qed. Lemma hztohqandleh': ∏ n m : hz, (hztohq n <= hztohq m)%hq → hzleh n m. Proof. intros n m Hle Hlt. simple refine (Hle _). apply hztohqandgth. exact Hlt. Qed. Lemma hztohqandlth': ∏ n m : hz, (hztohq n < hztohq m)%hq -> hzlth n m. Proof. intros n m Hlt. apply neghzgehtolth. intro Hle. apply hztohqandgeh in Hle. apply hqgehtoneghqlth in Hle. apply Hle. exact Hlt. Qed. Close Scope hq_scope. UniMath-20231010/UniMath/RealNumbers/README.md000066400000000000000000000022471451125700300203570ustar00rootroot00000000000000Dedekind =============== Authors: Catherine Lelay This Coq library provides a formalization of real numbers built using Dedekind cuts. It builds upon V. Voevodsky's Foundations library, available on http://arxiv.org/abs/1401.0053. For any question about this library, send an email to Catherine Lelay. ## Contents * *Sets.v - additional results about sets* * a definition of subsets * definition of a complete partial order * definition of effectively ordered sets * *Field.v* * additional results about fields * *Complements.v* * few theorems about maximum in nat * additional theorems about rational numbers * tactics for logical equivalence * *NonnegativeRationals.v* * definition of non-negative rational numbers * large and strong orders * commutative division rig structure * *NonnegativeReals.v* * definition of Dedekind cuts on non-negative rational numbers * equality and tight apartness on Dedekind cuts * constructive commutative division rig of Dedekind cuts * large and strong orders * convergence and limit of Cauchy sequences * definition of the least upper bound * *DecidableDedekindCuts.v* * results about decidable Dedekind cuts UniMath-20231010/UniMath/RealNumbers/Reals.v000066400000000000000000001613571451125700300203450ustar00rootroot00000000000000(** * A library about decidable Real Numbers *) (** Author: Catherine LELAY. Oct 2015 - *) Require Export UniMath.Algebra.Groups. Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Orders. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.OrderTheory.Lattice.Lattice. Require Import UniMath.RealNumbers.Prelim. Require Import UniMath.RealNumbers.Sets. Require Import UniMath.RealNumbers.NonnegativeRationals. Require Export UniMath.RealNumbers.NonnegativeReals. Local Open Scope NR_scope. (** ** Definition *) (** *** [commring] *) Definition hr_commring : commring := commrigtocommring NonnegativeReals. Definition NR_to_hr : NonnegativeReals × NonnegativeReals → hr_commring := setquotpr (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals)). Definition nat_to_hr (n : nat) : hr_commring := NR_to_hr (nat_to_NonnegativeReals n,,0). Lemma NR_to_hr_inside : ∏ x : NonnegativeReals × NonnegativeReals, pr1 (NR_to_hr x) x. Proof. intros x. apply hinhpr ; simpl. exists 0 ; reflexivity. Qed. Local Lemma iscomprelfun_NRminus : ∏ x y : NonnegativeReals × NonnegativeReals, pr1 x + pr2 y = pr1 y + pr2 x → pr1 x - pr2 x = pr1 y - pr2 y. Proof. intros x y H. apply (plusNonnegativeReals_eqcompat_l (pr2 x)). rewrite <- maxNonnegativeReals_minus_plus. apply (plusNonnegativeReals_eqcompat_l (pr2 y)). rewrite isrdistr_max_plusNonnegativeReals, H. rewrite (iscomm_plusNonnegativeReals (pr2 x) (pr2 y)), <- isrdistr_max_plusNonnegativeReals, maxNonnegativeReals_minus_plus. now rewrite !isassoc_plusNonnegativeReals, (iscomm_plusNonnegativeReals (pr2 x)). Qed. Lemma iscomprelfun_hr_to_NR : iscomprelfun (Y := NonnegativeReals × NonnegativeReals) (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals)) (λ x : NonnegativeReals × NonnegativeReals, pr1 x - pr2 x ,, pr2 x - pr1 x). Proof. intros x y. apply factor_through_squash. { refine (isasetdirprod _ _ _ _ _ _) ; apply (pr2 (pr1 (pr1 (pr1 NonnegativeReals)))). } intros c. apply dirprodeq. + apply iscomprelfun_NRminus. apply (plusNonnegativeReals_eqcompat_l (pr1 c)). exact (pr2 c). + apply (iscomprelfun_NRminus (pr2 x ,, pr1 x) (pr2 y ,, pr1 y)). simpl. rewrite (iscomm_plusNonnegativeReals (pr2 x)), (iscomm_plusNonnegativeReals (pr2 y)). apply (plusNonnegativeReals_eqcompat_l (pr1 c)), pathsinv0. exact (pr2 c). Qed. Definition hr_to_NR (x : hr_commring) : NonnegativeReals × NonnegativeReals. Proof. revert x. simple refine (setquotuniv _ (_,,_) _ _). - apply isasetdirprod ; apply (pr2 (pr1 (pr1 (pr1 NonnegativeReals)))). - intros x. apply (pr1 x - pr2 x ,, pr2 x - pr1 x). - apply iscomprelfun_hr_to_NR. Defined. Definition hr_to_NRpos (x : hr_commring) : NonnegativeReals := pr1 (hr_to_NR x). Definition hr_to_NRneg (x : hr_commring) : NonnegativeReals := pr2 (hr_to_NR x). Lemma hr_to_NR_correct : ∏ (x : hr_commring), pr1 x (hr_to_NR x). Proof. intros X. generalize (pr1 (pr2 X)). apply hinhuniv. intros x. pattern X at 2. rewrite <- (setquotl0 _ X x). unfold hr_to_NR. rewrite setquotunivcomm. generalize (pr2 x). apply (pr1 (pr2 (pr2 X))). apply hinhpr. exists 0 ; simpl. change ((pr1 (pr1 x) + (pr2 (pr1 x) - pr1 (pr1 x)) + 0) = ((pr1 (pr1 x) - pr2 (pr1 x)) + pr2 (pr1 x) + 0))%NR. rewrite !isrunit_zero_plusNonnegativeReals. rewrite iscomm_plusNonnegativeReals, <- !maxNonnegativeReals_minus_plus. now apply iscomm_maxNonnegativeReals. Qed. Lemma hr_to_NRpos_NR_to_hr : ∏ (x : NonnegativeReals × NonnegativeReals), hr_to_NRpos (NR_to_hr x) = pr1 x - pr2 x. Proof. intros x. unfold hr_to_NRpos, hr_to_NR, NR_to_hr. now rewrite setquotunivcomm. Qed. Lemma hr_to_NRneg_NR_to_hr : ∏ (x : NonnegativeReals × NonnegativeReals), hr_to_NRneg (NR_to_hr x) = pr2 x - pr1 x. Proof. intros x. unfold hr_to_NRneg, hr_to_NR, NR_to_hr. now rewrite setquotunivcomm. Qed. Lemma hr_to_NR_bij : ∏ x : hr_commring, NR_to_hr (hr_to_NR x) = x. Proof. intros x. unfold NR_to_hr. pattern x at 2. apply (setquotl0 _ x ((hr_to_NR x),,(hr_to_NR_correct x))). Qed. Lemma hr_to_NRposneg_zero : ∏ x : hr_commring, 0 < hr_to_NRpos x -> hr_to_NRneg x = 0. Proof. intros x. rewrite <- (hr_to_NR_bij x). generalize (hr_to_NR x) ; clear x ; intros x. rewrite hr_to_NRpos_NR_to_hr, hr_to_NRneg_NR_to_hr. intros Hx. apply minusNonnegativeReals_eq_zero. apply lt_leNonnegativeReals. apply_pr2 ispositive_minusNonnegativeReals. exact Hx. Qed. Lemma hr_to_NRnegpos_zero : ∏ x : hr_commring, 0 < hr_to_NRneg x -> hr_to_NRpos x = 0. Proof. intros x. rewrite <- (hr_to_NR_bij x). generalize (hr_to_NR x) ; clear x ; intros x. rewrite hr_to_NRpos_NR_to_hr, hr_to_NRneg_NR_to_hr. intros Hx. apply minusNonnegativeReals_eq_zero. apply lt_leNonnegativeReals. apply_pr2 ispositive_minusNonnegativeReals. exact Hx. Qed. Lemma hr_to_NRpos_NR_to_hr_std : ∏ (x : NonnegativeReals × NonnegativeReals), (0 < pr1 x -> pr2 x = 0) -> hr_to_NRpos (NR_to_hr x) = pr1 x. Proof. intros x Hx. rewrite hr_to_NRpos_NR_to_hr. apply (plusNonnegativeReals_eqcompat_l (pr2 x)). rewrite <- maxNonnegativeReals_minus_plus. now apply max_plusNonnegativeReals. Qed. Lemma hr_to_NRneg_NR_to_hr_std : ∏ (x : NonnegativeReals × NonnegativeReals), (0 < pr1 x -> pr2 x = 0) -> hr_to_NRneg (NR_to_hr x) = pr2 x. Proof. intros x Hx. rewrite hr_to_NRneg_NR_to_hr. apply (plusNonnegativeReals_eqcompat_l (pr1 x)). rewrite <- maxNonnegativeReals_minus_plus. rewrite iscomm_plusNonnegativeReals, iscomm_maxNonnegativeReals. now apply max_plusNonnegativeReals. Qed. (** Caracterisation of equality *) Lemma NR_to_hr_eq : ∏ x y : NonnegativeReals × NonnegativeReals, pr1 x + pr2 y = pr1 y + pr2 x <-> NR_to_hr x = NR_to_hr y. Proof. intros x y. split ; intros H. - apply iscompsetquotpr. apply hinhpr. exists 0. apply_pr2 plusNonnegativeReals_eqcompat_l. exact H. - generalize (invmap (weqpathsinsetquot _ _ _) H) ; clear H. apply factor_through_squash. { apply (pr2 (pr1 (pr1 (pr1 NonnegativeReals)))). } intros (c,p); generalize p; clear p. apply plusNonnegativeReals_eqcompat_l. Qed. (** *** Constants and Operations *) (** 0 *) Lemma hr_to_NR_zero : hr_to_NR 0%ring = (0,,0). Proof. unfold ringunel1, unel_is ; simpl. unfold hr_to_NR. rewrite setquotunivcomm ; simpl. rewrite !minusNonnegativeReals_eq_zero. { reflexivity. } apply isrefl_leNonnegativeReals. Qed. (** 1 *) Lemma hr_to_NR_one : hr_to_NR 1%ring = (1,,0). Proof. unfold ringunel2, unel_is ; simpl. unfold rigtoringunel2, hr_to_NR. rewrite setquotunivcomm ; simpl. erewrite <- minusNonnegativeReals_correct_r. - rewrite minusNonnegativeReals_eq_zero. + reflexivity. + apply isnonnegative_NonnegativeReals. - apply pathsinv0, isrunit_zero_plusNonnegativeReals. Qed. (** plus *) Lemma NR_to_hr_plus : ∏ x y : NonnegativeReals × NonnegativeReals, (NR_to_hr x + NR_to_hr y)%ring = NR_to_hr (pr1 x + pr1 y ,, pr2 x + pr2 y). Proof. intros x y. unfold BinaryOperations.op1 ; simpl. unfold rigtoringop1 ; simpl. unfold NR_to_hr. apply (setquotfun2comm (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals)) (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals))). Qed. (** opp *) Lemma NR_to_hr_opp : ∏ x : NonnegativeReals × NonnegativeReals, (- NR_to_hr x)%ring = NR_to_hr (pr2 x ,, pr1 x). Proof. intros x. unfold ringinv1, grinv_is ; simpl. unfold abgrdiffinv. unfold NR_to_hr. apply (setquotfuncomm (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals)) (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals))). Qed. Lemma hr_to_NR_opp : ∏ x : hr_commring, hr_to_NR (- x)%ring = (hr_to_NRneg x ,, hr_to_NRpos x). Proof. intros x. rewrite <- (hr_to_NR_bij x), NR_to_hr_opp. unfold hr_to_NRneg, hr_to_NRpos. generalize (hr_to_NR x) ; clear x ; intros x. unfold hr_to_NR, NR_to_hr. rewrite !setquotunivcomm. reflexivity. Qed. Lemma hr_to_NRpos_opp : ∏ x : hr_commring, hr_to_NRpos (- x)%ring = hr_to_NRneg x. Proof. intros x. unfold hr_to_NRpos. now rewrite hr_to_NR_opp. Qed. Lemma hr_to_NRneg_opp : ∏ x : hr_commring, hr_to_NRneg (- x)%ring = hr_to_NRpos x. Proof. intros x. unfold hr_to_NRneg. now rewrite hr_to_NR_opp. Qed. (** minus *) Lemma NR_to_hr_minus : ∏ x y : NonnegativeReals × NonnegativeReals, (NR_to_hr x - NR_to_hr y)%ring = NR_to_hr (pr1 x + pr2 y ,, pr2 x + pr1 y). Proof. intros x y. rewrite NR_to_hr_opp, NR_to_hr_plus. reflexivity. Qed. Lemma hr_opp_minus : ∏ x y : hr_commring, (x - y = - ((- x) - (- y)))%ring. Proof. intros x y. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij y). rewrite !NR_to_hr_opp, !NR_to_hr_plus, NR_to_hr_opp ; simpl. reflexivity. Qed. Lemma hr_to_NRpos_minus : ∏ x y : hr_commring, hr_to_NRpos x - hr_to_NRpos y <= hr_to_NRpos (x - y)%ring. Proof. intros X Y. set (x := hr_to_NRpos X) ; set (y := hr_to_NRpos Y). rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y). rewrite NR_to_hr_minus. change (pr1 (hr_to_NR X)) with x. change (pr1 (hr_to_NR Y)) with y. change (pr2 (hr_to_NR X)) with (hr_to_NRneg X). change (pr2 (hr_to_NR Y)) with (hr_to_NRneg Y). rewrite hr_to_NRpos_NR_to_hr. simpl pr1 ; simpl pr2. apply_pr2 (plusNonnegativeReals_lecompat_l (hr_to_NRneg X + y)). rewrite <- maxNonnegativeReals_minus_plus. rewrite (iscomm_plusNonnegativeReals _ y), <- isassoc_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus. rewrite isrdistr_max_plusNonnegativeReals. apply maxNonnegativeReals_le. - rewrite <- max_plusNonnegativeReals. + apply maxNonnegativeReals_le. * eapply istrans_leNonnegativeReals, maxNonnegativeReals_le_l. apply plusNonnegativeReals_le_l. * eapply istrans_leNonnegativeReals, maxNonnegativeReals_le_r. apply plusNonnegativeReals_le_r. + apply hr_to_NRposneg_zero. - apply maxNonnegativeReals_le_r. Qed. Lemma hr_to_NRneg_minus : ∏ x y : hr_commring, hr_to_NRneg x - hr_to_NRneg y <= hr_to_NRneg (x - y)%ring. Proof. intros x y. rewrite hr_opp_minus. pattern x at 1 ; rewrite <- (grinvinv hr_commring x) ; pattern y at 1 ; rewrite <- (grinvinv hr_commring y). change (hr_to_NRneg (- (- x))%ring - hr_to_NRneg (- (- y))%ring <= hr_to_NRneg (- (- x - - y))%ring). rewrite !hr_to_NRneg_opp. apply hr_to_NRpos_minus. Qed. (** mult *) Lemma NR_to_hr_mult : ∏ x y : NonnegativeReals × NonnegativeReals, (NR_to_hr x * NR_to_hr y)%ring = NR_to_hr (pr1 x * pr1 y + pr2 x * pr2 y ,, pr1 x * pr2 y + pr2 x * pr1 y). Proof. intros x y. unfold BinaryOperations.op2 ; simpl. unfold rigtoringop2 ; simpl. unfold NR_to_hr. apply (setquotfun2comm (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals)) (binopeqrelabgrdiff (rigaddabmonoid NonnegativeReals))). Qed. (** *** Order *) (** [hr_lt_rel] *) Local Lemma isbinophrel_ltNonnegativeReals : isbinophrel (X := rigaddabmonoid NonnegativeReals) ltNonnegativeReals. Proof. split. - intros x y z Hlt. apply plusNonnegativeReals_ltcompat_r, Hlt. - intros x y z Hlt. apply plusNonnegativeReals_ltcompat_l, Hlt. Qed. Definition hr_lt_rel : hrel hr_commring := rigtoringrel NonnegativeReals isbinophrel_ltNonnegativeReals. Lemma NR_to_hr_lt : ∏ x y : NonnegativeReals × NonnegativeReals, pr1 x + pr2 y < pr1 y + pr2 x <-> hr_lt_rel (NR_to_hr x) (NR_to_hr y). Proof. intros x y. split. - intros H. apply hinhpr ; exists 0 ; simpl. apply plusNonnegativeReals_ltcompat_l, H. - apply hinhuniv ; intros H. apply_pr2 (plusNonnegativeReals_ltcompat_l (pr1 H)). exact (pr2 H). Qed. (** [hr_le_rel] *) Local Lemma isbinophrel_leNonnegativeReals : isbinophrel (X := rigaddabmonoid NonnegativeReals) leNonnegativeReals. Proof. split. - intros x y z Hlt. apply plusNonnegativeReals_lecompat_r, Hlt. - intros x y z Hlt. apply plusNonnegativeReals_lecompat_l, Hlt. Qed. Definition hr_le_rel : hrel hr_commring := rigtoringrel NonnegativeReals isbinophrel_leNonnegativeReals. Lemma NR_to_hr_le : ∏ x y : NonnegativeReals × NonnegativeReals, pr1 x + pr2 y <= pr1 y + pr2 x <-> hr_le_rel (NR_to_hr x) (NR_to_hr y). Proof. intros x y. split. - intros H. apply hinhpr ; exists 0 ; simpl. apply plusNonnegativeReals_lecompat_l, H. - apply hinhuniv ; intros H. apply_pr2 (plusNonnegativeReals_lecompat_l (pr1 H)). exact (pr2 H). Qed. (** Theorems about order *) Lemma hr_notlt_le : ∏ X Y, ¬ hr_lt_rel X Y <-> hr_le_rel Y X. Proof. intros x y. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij y). split ; intro H. - apply NR_to_hr_le. apply notlt_leNonnegativeReals. intro H0 ; apply H. apply NR_to_hr_lt. exact H0. - intro H0. refine (pr2 (notlt_leNonnegativeReals _ _) _ _). + refine (pr2 (NR_to_hr_le _ _) _). apply H. + apply_pr2 NR_to_hr_lt. exact H0. Qed. Lemma hr_lt_le : ∏ X Y, hr_lt_rel X Y -> hr_le_rel X Y. Proof. intros x y. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij y). intro H. apply NR_to_hr_le. apply lt_leNonnegativeReals. apply_pr2 NR_to_hr_lt. exact H. Qed. Lemma isantisymm_hr_le : isantisymm hr_le_rel. Proof. apply isantisymmabgrdiffrel. intros X Y Hxy Hyx. apply isantisymm_leNonnegativeReals. now split. Qed. Lemma isStrongOrder_hr_lt : isStrongOrder hr_lt_rel. Proof. apply isStrongOrder_abgrdiff. repeat split. - exact istrans_ltNonnegativeReals. - exact iscotrans_ltNonnegativeReals. - exact isirrefl_ltNonnegativeReals. Qed. Lemma iscotrans_hr_lt : iscotrans hr_lt_rel. Proof. apply iscotrans_isStrongOrder. apply isStrongOrder_hr_lt. Qed. Lemma hr_to_NR_nonnegative : ∏ x : hr_commring, (hr_to_NRneg x = 0) <-> hr_le_rel 0%ring x. Proof. intros x. pattern x at 2. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero. unfold hr_to_NRneg. split. - generalize (hr_to_NR x). intros hx. change hx with (pr1 hx,,pr2 hx). generalize (pr1 hx), (pr2 hx). clear hx. intros x1 x2 ; simpl pr1 ; simpl pr2 ; clear x ; intros ->. apply NR_to_hr_le ; simpl. rewrite !isrunit_zero_plusNonnegativeReals. now apply isnonnegative_NonnegativeReals. - pattern x at 2. rewrite <- (hr_to_NR_bij x). generalize (hr_to_NR x) ; clear x ; intros x Hx. unfold hr_to_NR, NR_to_hr. rewrite setquotunivcomm ; simpl. apply_pr2_in NR_to_hr_le Hx. rewrite isrunit_zero_plusNonnegativeReals, islunit_zero_plusNonnegativeReals in Hx. now apply minusNonnegativeReals_eq_zero. Qed. Lemma hr_to_NR_positive : ∏ x : hr_commring, (hr_to_NRpos x ≠ 0 × hr_to_NRneg x = 0) <-> hr_lt_rel 0%ring x. Proof. intros x. repeat split. - pattern x at 3. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero. unfold hr_to_NRpos, hr_to_NRneg. change (hr_to_NR x) with (pr1 (hr_to_NR x),,pr2 _). generalize (pr1 (hr_to_NR x)), (pr2 (hr_to_NR x)) ; intros x1 x2 ; simpl pr1 ; simpl pr2 ; clear x ; intros H1 ; rewrite (pr2 H1). apply NR_to_hr_lt ; simpl. rewrite !isrunit_zero_plusNonnegativeReals. now apply ispositive_apNonnegativeReals, (pr1 H1). - rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero in X. apply_pr2_in NR_to_hr_lt X. rewrite isrunit_zero_plusNonnegativeReals, islunit_zero_plusNonnegativeReals in X. apply_pr2 ispositive_apNonnegativeReals. eapply istrans_le_lt_ltNonnegativeReals, X. now apply isnonnegative_NonnegativeReals. - apply_pr2 hr_to_NR_nonnegative. now apply hr_lt_le. Qed. Lemma hr_to_NR_nonpositive : ∏ x : hr_commring, (hr_to_NRpos x = 0) <-> hr_le_rel x 0%ring. Proof. intros x. pattern x at 2. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero. unfold hr_to_NRpos. split. - change (hr_to_NR x) with (pr1 (hr_to_NR x),,pr2 _). simpl pr1 ; simpl pr2 ; intros ->. apply NR_to_hr_le ; simpl. rewrite !islunit_zero_plusNonnegativeReals. now apply isnonnegative_NonnegativeReals. - pattern x at 2. rewrite <- (hr_to_NR_bij x). generalize (hr_to_NR x) ; clear x ; intros x Hx. unfold hr_to_NR, NR_to_hr. rewrite setquotunivcomm ; simpl. apply_pr2_in NR_to_hr_le Hx. rewrite isrunit_zero_plusNonnegativeReals, islunit_zero_plusNonnegativeReals in Hx. now apply minusNonnegativeReals_eq_zero. Qed. Lemma hr_to_NR_negative : ∏ x : hr_commring, (hr_to_NRpos x = 0 × hr_to_NRneg x ≠ 0) <-> hr_lt_rel x 0%ring. Proof. intros x. repeat split. - pattern x at 3. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero. unfold hr_to_NRpos, hr_to_NRneg. change (hr_to_NR x) with (pr1 (hr_to_NR x),,pr2 _). simpl pr1 ; simpl pr2 ; intros H2 ; rewrite (pr1 H2). apply NR_to_hr_lt ; simpl. rewrite !islunit_zero_plusNonnegativeReals. now apply ispositive_apNonnegativeReals, (pr2 H2). - apply_pr2 hr_to_NR_nonpositive. now apply hr_lt_le. - rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij 0%ring), hr_to_NR_zero in X. apply_pr2_in NR_to_hr_lt X. rewrite isrunit_zero_plusNonnegativeReals, islunit_zero_plusNonnegativeReals in X. apply_pr2 ispositive_apNonnegativeReals. eapply istrans_le_lt_ltNonnegativeReals, X. now apply isnonnegative_NonnegativeReals. Qed. Lemma hr_plus_ltcompat_l : ∏ x y z : hr_commring, hr_lt_rel y z <-> hr_lt_rel (y+x)%ring (z+x)%ring. Proof. intros X Y Z. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y), <- (hr_to_NR_bij Z). rewrite !NR_to_hr_plus. split ; intro Hlt. - apply NR_to_hr_lt ; simpl. rewrite !(iscomm_plusNonnegativeReals _ (pr1 (hr_to_NR X))), !isassoc_plusNonnegativeReals. apply plusNonnegativeReals_ltcompat_r. rewrite <- ! isassoc_plusNonnegativeReals. apply plusNonnegativeReals_ltcompat_l. now apply_pr2 NR_to_hr_lt. - apply NR_to_hr_lt ; simpl. apply_pr2 (plusNonnegativeReals_ltcompat_l (pr2 (hr_to_NR X))). apply_pr2 (plusNonnegativeReals_ltcompat_r (pr1 (hr_to_NR X))). rewrite <- ! isassoc_plusNonnegativeReals. rewrite !(iscomm_plusNonnegativeReals (pr1 (hr_to_NR X))), !(isassoc_plusNonnegativeReals (_ + pr1 (hr_to_NR X))). now apply_pr2_in NR_to_hr_lt Hlt. Qed. Lemma hr_plus_ltcompat_r : ∏ x y z : hr_commring, hr_lt_rel y z <-> hr_lt_rel (x + y)%ring (x + z)%ring. Proof. intros x y z. rewrite !(ringcomm1 _ x). apply hr_plus_ltcompat_l. Qed. Lemma hr_plus_lecompat_l : ∏ x y z : hr_commring, hr_le_rel y z <-> hr_le_rel (y + x)%ring (z + x)%ring. Proof. intros x y z ; split ; intro Hle. - apply hr_notlt_le. apply_pr2_in hr_notlt_le Hle. intro Hlt ; apply Hle. apply_pr2 (hr_plus_ltcompat_l x). exact Hlt. - apply hr_notlt_le. apply_pr2_in hr_notlt_le Hle. intro Hlt ; apply Hle. apply hr_plus_ltcompat_l. exact Hlt. Qed. Lemma hr_plus_lecompat_r : ∏ x y z : hr_commring, hr_le_rel y z <-> hr_le_rel (x + y)%ring (x + z)%ring. Proof. intros x y z. rewrite !(ringcomm1 _ x). apply hr_plus_lecompat_l. Qed. Lemma hr_mult_ltcompat_l : ∏ x y z : hr_commring, hr_lt_rel 0%ring x -> hr_lt_rel y z -> hr_lt_rel (y * x)%ring (z * x)%ring. Proof. intros X Y Z Hx0 Hlt. apply_pr2_in hr_to_NR_positive Hx0. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y), <- (hr_to_NR_bij Z). rewrite !NR_to_hr_mult ; simpl pr1 ; simpl pr2. change (pr2 (hr_to_NR X)) with (hr_to_NRneg X) ; rewrite (pr2 Hx0). rewrite !israbsorb_zero_multNonnegativeReals, !isrunit_zero_plusNonnegativeReals, !islunit_zero_plusNonnegativeReals. apply NR_to_hr_lt ; simpl. rewrite <- !isrdistr_plus_multNonnegativeReals. apply multNonnegativeReals_ltcompat_l. - apply ispositive_apNonnegativeReals. exact (pr1 Hx0). - apply_pr2 NR_to_hr_lt. now rewrite !hr_to_NR_bij. Qed. Lemma hr_mult_ltcompat_l' : ∏ x y z : hr_commring, hr_le_rel 0%ring x -> hr_lt_rel (y * x)%ring (z * x)%ring -> hr_lt_rel y z. Proof. intros X Y Z Hx0. apply_pr2_in hr_to_NR_nonnegative Hx0. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y), <- (hr_to_NR_bij Z). rewrite !NR_to_hr_mult ; simpl pr1 ; simpl pr2. change (pr2 (hr_to_NR X)) with (hr_to_NRneg X). rewrite Hx0. rewrite !israbsorb_zero_multNonnegativeReals, !isrunit_zero_plusNonnegativeReals, !islunit_zero_plusNonnegativeReals. intros Hlt. apply NR_to_hr_lt. apply multNonnegativeReals_ltcompat_l' with (pr1 (hr_to_NR X)). rewrite !isrdistr_plus_multNonnegativeReals. now apply_pr2_in NR_to_hr_lt Hlt. Qed. Lemma hr_mult_ltcompat_r' : ∏ x y z : hr_commring, hr_le_rel 0%ring x -> hr_lt_rel (x * y)%ring (x * z)%ring -> hr_lt_rel y z. Proof. intros x y z. rewrite !(ringcomm2 _ x). apply hr_mult_ltcompat_l'. Qed. Lemma hr_mult_lecompat_l : ∏ x y z : hr_commring, hr_le_rel 0%ring x -> hr_le_rel y z -> hr_le_rel (y * x)%ring (z * x)%ring. Proof. intros x y z Hx0 Hle. apply hr_notlt_le. apply_pr2_in hr_notlt_le Hle. intro Hlt ; apply Hle. apply (hr_mult_ltcompat_l' x). - exact Hx0. - exact Hlt. Qed. Lemma hr_mult_lecompat_l' : ∏ x y z : hr_commring, hr_lt_rel 0%ring x -> hr_le_rel (y * x)%ring (z * x)%ring -> hr_le_rel y z. Proof. intros x y z Hx0 Hle. apply hr_notlt_le. apply_pr2_in hr_notlt_le Hle. intro Hlt ; apply Hle. apply (hr_mult_ltcompat_l x). - exact Hx0. - exact Hlt. Qed. Lemma hr_mult_lecompat_r : ∏ x y z : hr_commring, hr_le_rel 0%ring x -> hr_le_rel y z -> hr_le_rel (x * y)%ring (x * z)%ring. Proof. intros x y z. rewrite !(ringcomm2 _ x). apply hr_mult_lecompat_l. Qed. Lemma hr_mult_lecompat_r' : ∏ x y z : hr_commring, hr_lt_rel 0%ring x -> hr_le_rel (x * y)%ring (x * z)%ring -> hr_le_rel y z. Proof. intros x y z. rewrite !(ringcomm2 _ x). apply hr_mult_lecompat_l'. Qed. (** *** Appartness *) Local Lemma isbinophrel_apNonnegativeReals : isbinophrel (X := rigaddabmonoid NonnegativeReals) apNonnegativeReals. Proof. split. - intros x y z Hlt. apply plusNonnegativeReals_apcompat_r, Hlt. - intros x y z Hlt. apply plusNonnegativeReals_apcompat_l, Hlt. Qed. Definition hr_ap_rel : hrel hr_commring := rigtoringrel NonnegativeReals isbinophrel_apNonnegativeReals. Lemma NR_to_hr_ap : ∏ x y : NonnegativeReals × NonnegativeReals, pr1 x + pr2 y ≠ pr1 y + pr2 x <-> hr_ap_rel (NR_to_hr x) (NR_to_hr y). Proof. intros x y. split. - intros H. apply hinhpr ; exists 0 ; simpl. apply plusNonnegativeReals_apcompat_l, H. - apply hinhuniv ; intros H. apply_pr2 (plusNonnegativeReals_apcompat_l (pr1 H)). exact (pr2 H). Qed. (** Theorems about apartness *) Lemma hr_ap_lt : ∏ X Y : hr_commring, hr_ap_rel X Y <-> (hr_lt_rel X Y) ⨿ (hr_lt_rel Y X). Proof. intros X Y. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y). split ; intro Hap. - apply_pr2_in NR_to_hr_ap Hap. revert Hap. apply sumofmaps ; intros Hlt. + now left ; apply NR_to_hr_lt. + now right ; apply NR_to_hr_lt. - apply NR_to_hr_ap. revert Hap ; apply sumofmaps ; intros Hlt. + now left ; apply_pr2 NR_to_hr_lt. + now right ; apply_pr2 NR_to_hr_lt. Qed. Lemma istightap_hr_ap : istightap hr_ap_rel. Proof. repeat split. - intros X Hap. rewrite <- (hr_to_NR_bij X) in Hap. apply_pr2_in NR_to_hr_ap Hap. revert Hap. now apply isirrefl_apNonnegativeReals. - intros X Y. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y). intros Hap. apply NR_to_hr_ap. apply issymm_apNonnegativeReals. now apply_pr2 NR_to_hr_ap. - intros X Y Z Hap. apply hr_ap_lt in Hap. revert Hap ; apply sumofmaps ; intros Hlt. + apply (iscotrans_hr_lt X Y Z) in Hlt. revert Hlt ; apply hinhfun ; apply sumofmaps ; intros Hlt. * left ; apply_pr2 hr_ap_lt. now left. * right ; apply_pr2 hr_ap_lt. now left. + apply (iscotrans_hr_lt _ Y _) in Hlt. revert Hlt ; apply hinhfun ; apply sumofmaps ; intros Hlt. * right ; apply_pr2 hr_ap_lt. now right. * left ; apply_pr2 hr_ap_lt. now right. - intros X Y Hap. apply isantisymm_hr_le. + apply hr_notlt_le. intro Hlt ; apply Hap. apply_pr2 hr_ap_lt. now right. + apply hr_notlt_le. intro Hlt ; apply Hap. apply_pr2 hr_ap_lt. now left. Qed. (** Structures *) Lemma islapbinop_plus : islapbinop (X := _,,_,,istightap_hr_ap) BinaryOperations.op1. Proof. intros X Y Z. unfold tightapSet_rel ; simpl pr1. intro Hap. apply_pr2 hr_ap_lt. apply hr_ap_lt in Hap. revert Hap ; apply sumofmaps ; intros Hlt. - left. apply_pr2 (hr_plus_ltcompat_l X). exact Hlt. - right. apply_pr2 (hr_plus_ltcompat_l X). exact Hlt. Qed. Lemma israpbinop_plus : israpbinop (X := _,,_,,istightap_hr_ap) BinaryOperations.op1. Proof. intros X Y Z Hap. apply islapbinop_plus with X. rewrite !(ringcomm1 _ _ X). exact Hap. Qed. Lemma islapbinop_mult : islapbinop (X := _,,_,,istightap_hr_ap) BinaryOperations.op2. Proof. intros X Y Z. unfold tightapSet_rel ; simpl pr1. rewrite <- (hr_to_NR_bij X), <- (hr_to_NR_bij Y), <- (hr_to_NR_bij Z), !NR_to_hr_mult. intros Hap. apply_pr2_in NR_to_hr_ap Hap ; simpl in Hap. cut (∏ Y Z, (pr1 (hr_to_NR Z) * pr1 (hr_to_NR X) + pr2 (hr_to_NR Z) * pr2 (hr_to_NR X) + (pr1 (hr_to_NR Y) * pr2 (hr_to_NR X) + pr2 (hr_to_NR Y) * pr1 (hr_to_NR X))) = (pr1 (hr_to_NR Z) + pr2 (hr_to_NR Y)) * pr1 (hr_to_NR X) + (pr2 (hr_to_NR Z) + pr1 (hr_to_NR Y)) * pr2 (hr_to_NR X)). - intro H ; simpl in H,Hap ; rewrite !H in Hap ; clear H. apply ap_plusNonnegativeReals in Hap. apply NR_to_hr_ap. revert Hap ; apply hinhuniv ; apply sumofmaps ; intros Hap. + apply ap_multNonnegativeReals in Hap. revert Hap ; apply hinhuniv ; apply sumofmaps ; intros Hap. * exact Hap. * now eapply fromempty, (isirrefl_apNonnegativeReals _), Hap . + apply ap_multNonnegativeReals in Hap. revert Hap ; apply hinhuniv ; apply sumofmaps ; intros Hap. * rewrite (iscomm_plusNonnegativeReals (pr1 (hr_to_NR Z))), iscomm_plusNonnegativeReals. now apply issymm_apNonnegativeReals, Hap. * now eapply fromempty, (isirrefl_apNonnegativeReals _), Hap. - clear ; intros Y Z. rewrite !isrdistr_plus_multNonnegativeReals. rewrite !isassoc_plusNonnegativeReals. apply_pr2 plusNonnegativeReals_eqcompat_r. do 2 rewrite iscomm_plusNonnegativeReals, !isassoc_plusNonnegativeReals. reflexivity. Qed. Lemma israpbinop_mult : israpbinop (X := _,,_,,istightap_hr_ap) BinaryOperations.op2. Proof. intros X Y Z Hap. apply islapbinop_mult with X. rewrite !(ringcomm2 _ _ X). exact Hap. Qed. Lemma hr_ap_0_1 : isnonzeroCR hr_commring (hr_ap_rel,, istightap_hr_ap). Proof. change (hr_ap_rel 1%ring 0%ring). rewrite <- (hr_to_NR_bij 1%ring), <- (hr_to_NR_bij 0%ring), hr_to_NR_one, hr_to_NR_zero. apply NR_to_hr_ap. rewrite !isrunit_zero_plusNonnegativeReals. apply isnonzeroNonnegativeReals. Qed. Lemma hr_islinv_neg : ∏ (x : hr_commring) (Hap : hr_lt_rel x 0%ring), (NR_to_hr (0%NR,, invNonnegativeReals (hr_to_NRneg x) (pr2 (pr2 (hr_to_NR_negative _) Hap))) * x)%ring = 1%ring. Proof. intros x Hap. pattern x at 3; rewrite <- (hr_to_NR_bij x). rewrite NR_to_hr_mult ; simpl. rewrite !islabsorb_zero_multNonnegativeReals , !islunit_zero_plusNonnegativeReals. rewrite islinv_invNonnegativeReals. rewrite <- (hr_to_NR_bij 1%ring), hr_to_NR_one. apply maponpaths. apply maponpaths. erewrite <- israbsorb_zero_multNonnegativeReals. apply maponpaths. apply (pr1 (pr2 (hr_to_NR_negative x) Hap)). Qed. Lemma hr_isrinv_neg : ∏ (x : hr_commring) (Hap : hr_lt_rel x 0%ring), (x * NR_to_hr (0%NR,, invNonnegativeReals (hr_to_NRneg x) (pr2 (pr2 (hr_to_NR_negative _) Hap))))%ring = 1%ring. Proof. intros x Hap. rewrite ringcomm2. now apply (hr_islinv_neg x Hap). Qed. Lemma hr_islinv_pos : ∏ (x : hr_commring) (Hap : hr_lt_rel 0%ring x), (NR_to_hr (invNonnegativeReals (hr_to_NRpos x) (pr1 (pr2 (hr_to_NR_positive _) Hap)) ,, 0%NR) * x)%ring = 1%ring. Proof. intros x Hap. pattern x at 3; rewrite <- (hr_to_NR_bij x). rewrite NR_to_hr_mult ; simpl. rewrite !islabsorb_zero_multNonnegativeReals , !isrunit_zero_plusNonnegativeReals. rewrite islinv_invNonnegativeReals. rewrite <- (hr_to_NR_bij 1%ring), hr_to_NR_one. apply maponpaths. apply maponpaths. erewrite <- israbsorb_zero_multNonnegativeReals. apply maponpaths. apply (pr2 (pr2 (hr_to_NR_positive x) Hap)). Qed. Lemma hr_isrinv_pos : ∏ (x : hr_commring) (Hap : hr_lt_rel 0%ring x), (x * NR_to_hr (invNonnegativeReals (hr_to_NRpos x) (pr1 (pr2 (hr_to_NR_positive _) Hap)) ,, 0%NR))%ring = 1%ring. Proof. intros x Hap. rewrite ringcomm2. now apply (hr_islinv_pos x Hap). Qed. Lemma hr_ex_inv : ∏ x : hr_commring, hr_ap_rel x 0%ring -> multinvpair hr_commring x. Proof. intros x Hap. generalize (pr1 (hr_ap_lt _ _) Hap) ; apply sumofmaps ; intros Hlt ; simpl. - eexists ; split. + refine (hr_islinv_neg _ _). exact Hlt. + exact (hr_isrinv_neg _ _). - eexists ; split. + refine (hr_islinv_pos _ _). exact Hlt. + exact (hr_isrinv_pos _ _). Defined. Definition hr_ConstructiveField : ConstructiveField. Proof. exists hr_commring. exists (_,,istightap_hr_ap). repeat split. - exact islapbinop_plus. - exact israpbinop_plus. - exact islapbinop_mult. - exact israpbinop_mult. - exact hr_ap_0_1. - exact hr_ex_inv. Defined. (** ** hr_abs *) Definition hr_abs (x : hr_ConstructiveField) : NonnegativeReals := maxNonnegativeReals (hr_to_NRpos x) (hr_to_NRneg x). Lemma NR_to_hr_abs : ∏ x : NonnegativeReals × NonnegativeReals, hr_abs (NR_to_hr x) <= maxNonnegativeReals (pr1 x) (pr2 x). Proof. intros x. unfold hr_abs. rewrite hr_to_NRpos_NR_to_hr, hr_to_NRneg_NR_to_hr. apply maxNonnegativeReals_le. - eapply istrans_leNonnegativeReals, maxNonnegativeReals_le_l. now apply minusNonnegativeReals_le. - eapply istrans_leNonnegativeReals, maxNonnegativeReals_le_r. now apply minusNonnegativeReals_le. Qed. Lemma hr_abs_opp : ∏ x : hr_ConstructiveField, hr_abs (- x)%ring = hr_abs x. Proof. intros x. unfold hr_abs. rewrite hr_to_NRpos_opp, hr_to_NRneg_opp. apply iscomm_maxNonnegativeReals. Qed. Lemma istriangle_hr_abs : ∏ x y : hr_ConstructiveField, hr_abs (x + y)%ring <= hr_abs x + hr_abs y. Proof. intros x y. pattern x at 1 ; rewrite <- (hr_to_NR_bij x) ; pattern y at 1 ; rewrite <- (hr_to_NR_bij y). rewrite NR_to_hr_plus. eapply istrans_leNonnegativeReals. { apply NR_to_hr_abs. } apply maxNonnegativeReals_le ; apply plusNonnegativeReals_lecompat. - apply maxNonnegativeReals_le_l. - apply maxNonnegativeReals_le_l. - apply maxNonnegativeReals_le_r. - apply maxNonnegativeReals_le_r. Qed. Lemma istriangle_hr_abs' : ∏ x y : hr_ConstructiveField, hr_abs x - hr_abs y <= hr_abs (x + y)%ring. Proof. intros x y. apply_pr2 (plusNonnegativeReals_lecompat_l (hr_abs y)). rewrite <- maxNonnegativeReals_minus_plus. apply maxNonnegativeReals_le. - assert (Hx : x = ((x + y) + (- y))%ring). { now rewrite ringassoc1, ringrinvax1, ringrunax1. } pattern x at 1 ; rewrite Hx. rewrite <- (hr_abs_opp y). apply istriangle_hr_abs. - apply plusNonnegativeReals_le_r. Qed. Lemma hr_abs_minus : ∏ x y : hr_ConstructiveField, hr_abs x - hr_abs y <= hr_abs (x - y)%ring. Proof. intros x y. rewrite <- (hr_abs_opp y). apply istriangle_hr_abs'. Qed. Lemma multNonnegativeReals_lecompat : ∏ x y z t : NonnegativeReals, x <= y -> z <= t -> x * z <= y * t. Proof. intros x y z t H H0. eapply istrans_leNonnegativeReals, multNonnegativeReals_lecompat_l', H. apply multNonnegativeReals_lecompat_r', H0. Qed. Lemma ispositive_multNonnegativeReals : ∏ x y : NonnegativeReals, 0 < x ∧ 0 < y <-> 0 < x * y. Proof. intros x y. split. - intros H. rewrite <- (islabsorb_zero_multNonnegativeReals y). apply multNonnegativeReals_ltcompat_l. + apply (pr2 H). + apply (pr1 H). - intros H ; split. + eapply multNonnegativeReals_ltcompat_l'. rewrite islabsorb_zero_multNonnegativeReals. exact H. + eapply multNonnegativeReals_ltcompat_r'. rewrite israbsorb_zero_multNonnegativeReals. exact H. Qed. Lemma maxNonnegativeReals_lt' : ∏ x y z : NonnegativeReals, z < maxNonnegativeReals x y -> z < x ∨ z < y. Proof. intros x y z. intros H. generalize (iscotrans_ltNonnegativeReals _ x _ H). apply hinhfun. apply sumofmaps ; intros Hx. - now left. - right. rewrite <- (maxNonnegativeReals_carac_r x y). + apply H. + apply notlt_leNonnegativeReals ; intros Hy. apply (isirrefl_ltNonnegativeReals (maxNonnegativeReals x y)). apply maxNonnegativeReals_lt. * exact Hx. * now apply istrans_ltNonnegativeReals with x. Qed. Lemma hr_abs_mult : ∏ x y : hr_ConstructiveField, hr_abs (x * y)%ring = hr_abs x * hr_abs y. Proof. intros x y. pattern x at 1 ; rewrite <- (hr_to_NR_bij x) ; pattern y at 1 ; rewrite <- (hr_to_NR_bij y). rewrite NR_to_hr_mult. change (pr1 (hr_to_NR x)) with (hr_to_NRpos x) ; change (pr1 (hr_to_NR y)) with (hr_to_NRpos y) ; change (pr2 (hr_to_NR x)) with (hr_to_NRneg x) ; change (pr2 (hr_to_NR y)) with (hr_to_NRneg y). rewrite <- !max_plusNonnegativeReals. - unfold hr_abs. rewrite hr_to_NRpos_NR_to_hr_std, hr_to_NRneg_NR_to_hr_std ; simpl. + rewrite isldistr_max_multNonnegativeReals, !isrdistr_max_multNonnegativeReals. rewrite !isassoc_maxNonnegativeReals. apply maponpaths. rewrite iscomm_maxNonnegativeReals, !isassoc_maxNonnegativeReals. rewrite iscomm_maxNonnegativeReals, !isassoc_maxNonnegativeReals. apply maponpaths. apply iscomm_maxNonnegativeReals. + intros H. apply maxNonnegativeReals_lt' in H. apply le0_NonnegativeReals. revert H ; apply hinhuniv ; apply sumofmaps ; intros H ; apply_pr2_in ispositive_multNonnegativeReals H ; apply maxNonnegativeReals_le ; apply_pr2 le0_NonnegativeReals. * now rewrite (hr_to_NRposneg_zero _ (pr2 H)), israbsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRposneg_zero _ (pr1 H)), islabsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRnegpos_zero _ (pr1 H)), islabsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRnegpos_zero _ (pr2 H)), israbsorb_zero_multNonnegativeReals. + intros H. apply maxNonnegativeReals_lt' in H. apply le0_NonnegativeReals. revert H ; apply hinhuniv ; apply sumofmaps ; intros H ; apply_pr2_in ispositive_multNonnegativeReals H ; apply maxNonnegativeReals_le ; apply_pr2 le0_NonnegativeReals. * now rewrite (hr_to_NRposneg_zero _ (pr2 H)), israbsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRposneg_zero _ (pr1 H)), islabsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRnegpos_zero _ (pr1 H)), islabsorb_zero_multNonnegativeReals. * now rewrite (hr_to_NRnegpos_zero _ (pr2 H)), israbsorb_zero_multNonnegativeReals. - intros H. apply_pr2_in ispositive_multNonnegativeReals H. rewrite hr_to_NRposneg_zero. + apply islabsorb_zero_multNonnegativeReals. + exact (pr1 H). - intros H. apply_pr2_in ispositive_multNonnegativeReals H. rewrite hr_to_NRposneg_zero. + apply islabsorb_zero_multNonnegativeReals. + exact (pr1 H). Qed. (** ** Archimedean *) Lemma nat_to_hr_O : nat_to_hr O = 0%ring. Proof. unfold nat_to_hr. rewrite nat_to_NonnegativeReals_O. reflexivity. Qed. Lemma nat_to_hr_S : ∏ n : nat, nat_to_hr (S n) = (1 + nat_to_hr n)%ring. Proof. intros n. unfold nat_to_hr. rewrite nat_to_NonnegativeReals_Sn, iscomm_plusNonnegativeReals. rewrite <- (hr_to_NR_bij 1%ring), hr_to_NR_one, NR_to_hr_plus. rewrite !isrunit_zero_plusNonnegativeReals. reflexivity. Qed. Lemma hr_archimedean : isarchCF (λ x y : hr_ConstructiveField, hr_lt_rel y x). Proof. assert (Hadd : @isbinophrel (rigaddabmonoid NonnegativeReals) gtNonnegativeReals). { split ; intros a b c. - apply plusNonnegativeReals_ltcompat_r. - apply plusNonnegativeReals_ltcompat_l. } assert (Htra : istrans gtNonnegativeReals). { intros a b c Hab Hbc. now apply istrans_ltNonnegativeReals with b. } assert (Harch : isarchrig (@setquot_aux (rigaddabmonoid NonnegativeReals) gtNonnegativeReals)). { set (H := NonnegativeReals_Archimedean). repeat split. - intros y1 y2. apply hinhuniv. intros c. generalize (pr2 c) ; intros Hc. apply_pr2_in plusNonnegativeReals_ltcompat_l Hc. generalize (isarchrig_diff _ H _ _ Hc). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%NR. apply plusNonnegativeReals_ltcompat_l. exact (pr2 n). - intros x. generalize (isarchrig_gt _ H x). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%NR. apply plusNonnegativeReals_ltcompat_l. exact (pr2 n). - intros x. generalize (isarchrig_pos _ H x). apply hinhfun. intros n. exists (pr1 n). apply hinhpr. exists 0%NR. apply plusNonnegativeReals_ltcompat_l. exact (pr2 n). } intros x. generalize (isarchring_isarchCF (X := hr_ConstructiveField) _ (isarchrigtoring NonnegativeReals gtNonnegativeReals ispositive_oneNonnegativeReals Hadd Htra Harch) x). apply hinhfun. intros n. exists (pr1 n). generalize (pr1 n) (pr2 n) ; clear n ; intros n Hn. simpl pr1. rewrite <- (hr_to_NR_bij x), <- (hr_to_NR_bij (@nattoring hr_ConstructiveField n)) in Hn |- *. revert Hn. apply hinhfun ; simpl. intros c. exact c. Qed. (** ** Completeness *) Definition Cauchy_seq (u : nat → hr_ConstructiveField) : hProp. Proof. apply (make_hProp (∏ c : NonnegativeReals, 0 < c -> ∃ N : nat, ∏ n m : nat, N ≤ n -> N ≤ m -> hr_abs (u m - u n)%ring < c)). apply impred_isaprop ; intro. apply isapropimpl. apply pr2. Defined. Lemma Cauchy_seq_pr1 (u : nat → hr_ConstructiveField) : let x := λ n : nat, hr_to_NRpos (u n) in Cauchy_seq u → NonnegativeReals.Cauchy_seq x. Proof. intros x. set (y := λ n : nat, hr_to_NRneg (u n)). assert (Hxy : ∏ n, NR_to_hr (x n ,, y n) = u n). { intros n. unfold x, y, hr_to_NRpos, hr_to_NRneg. apply hr_to_NR_bij. } intros Cu c Hc. generalize (Cu c Hc). apply hinhfun ; intros N. exists (pr1 N) ; intros n m Hn Hm. generalize ((pr2 N) _ _ Hn Hm) ; intros Hu. split. - apply (plusNonnegativeReals_ltcompat_r (x m)) in Hu. eapply istrans_le_lt_ltNonnegativeReals, Hu. rewrite hr_opp_minus, hr_abs_opp, ringcomm1. change (- - u n)%ring with (grinv hr_commring (grinv hr_commring (u n))). rewrite (grinvinv hr_commring (u n)). eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, maxNonnegativeReals_le_l. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, hr_to_NRpos_minus. change (hr_to_NRpos (u n)) with (x n) ; change (hr_to_NRpos (u m)) with (x m). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus. now apply maxNonnegativeReals_le_l. - apply (plusNonnegativeReals_ltcompat_r (x n)) in Hu. eapply istrans_le_lt_ltNonnegativeReals, Hu. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, maxNonnegativeReals_le_l. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, hr_to_NRpos_minus. change (hr_to_NRpos (u n)) with (x n) ; change (hr_to_NRpos (u m)) with (x m). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus. now apply maxNonnegativeReals_le_l. Qed. Lemma Cauchy_seq_pr2 (u : nat → hr_ConstructiveField) : let y := λ n : nat, hr_to_NRneg (u n) in Cauchy_seq u → NonnegativeReals.Cauchy_seq y. Proof. intros y. set (x := λ n : nat, hr_to_NRpos (u n)). assert (Hxy : ∏ n, NR_to_hr (x n ,, y n) = u n). { intros n. unfold x, y, hr_to_NRpos, hr_to_NRneg. apply hr_to_NR_bij. } intros Cu c Hc. generalize (Cu c Hc). apply hinhfun ; intros N. exists (pr1 N) ; intros n m Hn Hm. generalize ((pr2 N) _ _ Hn Hm) ; intros Hu. split. - apply (plusNonnegativeReals_ltcompat_r (y m)) in Hu. eapply istrans_le_lt_ltNonnegativeReals, Hu. rewrite hr_opp_minus, hr_abs_opp, ringcomm1. change (- - u n)%ring with (grinv hr_commring (grinv hr_commring (u n))). rewrite (grinvinv hr_commring (u n)). eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, maxNonnegativeReals_le_r. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, hr_to_NRneg_minus. change (hr_to_NRneg (u n)) with (y n) ; change (hr_to_NRneg (u m)) with (y m). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus. now apply maxNonnegativeReals_le_l. - apply (plusNonnegativeReals_ltcompat_r (y n)) in Hu. eapply istrans_le_lt_ltNonnegativeReals, Hu. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, maxNonnegativeReals_le_r. eapply istrans_leNonnegativeReals, plusNonnegativeReals_lecompat_r, hr_to_NRneg_minus. change (hr_to_NRneg (u n)) with (y n) ; change (hr_to_NRneg (u m)) with (y m). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus. now apply maxNonnegativeReals_le_l. Qed. Definition is_lim_seq (u : nat → hr_ConstructiveField) (l : hr_ConstructiveField) : hProp. Proof. apply (make_hProp (∏ c : NonnegativeReals, 0 < c -> ∃ N : nat, ∏ n : nat, N ≤ n -> hr_abs (u n - l)%ring < c)). apply impred_isaprop ; intro. apply isapropimpl. apply pr2. Defined. Definition ex_lim_seq (u : nat → hr_ConstructiveField) := ∑ l, is_lim_seq u l. Lemma Cauchy_seq_impl_ex_lim_seq (u : nat → hr_ConstructiveField) : Cauchy_seq u → ex_lim_seq u. Proof. intros Cu. set (x := λ n, hr_to_NRpos (u n)). set (y := λ n, hr_to_NRneg (u n)). assert (Hxy : ∏ n, NR_to_hr (x n ,, y n) = u n). { intros n. unfold x, y, hr_to_NRpos, hr_to_NRneg. apply hr_to_NR_bij. } generalize (Cauchy_seq_impl_ex_lim_seq x (Cauchy_seq_pr1 u Cu)). set (lx := Cauchy_lim_seq x (Cauchy_seq_pr1 u Cu)) ; clearbody lx ; intro Hx. generalize (Cauchy_seq_impl_ex_lim_seq y (Cauchy_seq_pr2 u Cu)). set (ly := Cauchy_lim_seq y (Cauchy_seq_pr2 u Cu)) ; clearbody ly ; intro Hy. exists (NR_to_hr (lx,,ly)). intros c Hc. apply ispositive_halfNonnegativeReals in Hc. generalize (Hx _ Hc) (Hy _ Hc) ; apply hinhfun2 ; clear Hy Hx ; intros Nx Ny. exists (max (pr1 Nx) (pr1 Ny)) ; intros n Hn. rewrite <- Hxy ; simpl pr1. rewrite NR_to_hr_minus ; simpl. apply maxNonnegativeReals_lt. - rewrite hr_to_NRpos_NR_to_hr. apply_pr2 (plusNonnegativeReals_ltcompat_r (y n + lx)). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus ; simpl. apply maxNonnegativeReals_lt. + rewrite (double_halfNonnegativeReals c), (iscomm_plusNonnegativeReals (y n)), (isassoc_plusNonnegativeReals lx (y n)), <- (isassoc_plusNonnegativeReals (y n)), (iscomm_plusNonnegativeReals (y n)), <- !isassoc_plusNonnegativeReals, (isassoc_plusNonnegativeReals (lx + _)). apply plusNonnegativeReals_ltcompat. * apply (pr2 Nx). apply istransnatleh with (2 := Hn). apply max_le_l. * apply_pr2 (pr2 Ny). apply istransnatleh with (2 := Hn). apply max_le_r. + apply plusNonnegativeReals_lt_r . now apply_pr2 ispositive_halfNonnegativeReals. - rewrite hr_to_NRneg_NR_to_hr. apply_pr2 (plusNonnegativeReals_ltcompat_r (x n + ly)). rewrite iscomm_plusNonnegativeReals, <- maxNonnegativeReals_minus_plus ; simpl. apply maxNonnegativeReals_lt. + rewrite (double_halfNonnegativeReals c), (iscomm_plusNonnegativeReals (x n)), (isassoc_plusNonnegativeReals ly (x n)), <- (isassoc_plusNonnegativeReals (x n)), (iscomm_plusNonnegativeReals (x n)), <- !isassoc_plusNonnegativeReals, (isassoc_plusNonnegativeReals (ly + _)). apply plusNonnegativeReals_ltcompat. * apply (pr2 Ny). apply istransnatleh with (2 := Hn). apply max_le_r. * apply_pr2 (pr2 Nx). apply istransnatleh with (2 := Hn). apply max_le_l. + apply plusNonnegativeReals_lt_r . now apply_pr2 ispositive_halfNonnegativeReals. Qed. (** * Interface for Reals *) Definition Reals : ConstructiveField := hr_ConstructiveField. (** ** Operations and relations *) Definition Rap : hrel Reals := CFap. Definition Rlt : hrel Reals := hr_lt_rel. Definition Rgt : hrel Reals := λ x y : Reals, Rlt y x. Definition Rle : hrel Reals := hr_le_rel. Definition Rge : hrel Reals := λ x y : Reals, Rle y x. Definition Rzero : Reals := CFzero. Definition Rplus : binop Reals := CFplus. Definition Ropp : unop Reals := CFopp. Definition Rminus : binop Reals := CFminus. Definition Rone : Reals := CFone. Definition Rmult : binop Reals := CFmult. Definition Rinv : ∏ x : Reals, (Rap x Rzero) -> Reals := CFinv. Definition Rdiv : Reals -> ∏ y : Reals, (Rap y Rzero) -> Reals := CFdiv. Definition Rtwo : Reals := Rplus Rone Rone. Definition Rabs : Reals → NonnegativeReals := hr_abs. Definition NRNRtoR : NonnegativeReals → NonnegativeReals → Reals := λ (x y : NonnegativeReals), NR_to_hr (x,,y). Definition RtoNRNR : Reals → NonnegativeReals × NonnegativeReals := λ x : Reals, (hr_to_NR x). Declare Scope R_scope. Delimit Scope R_scope with R. Local Open Scope R_scope. Infix "≠" := Rap : R_scope. Infix "<" := Rlt : R_scope. Infix ">" := Rgt : R_scope. Infix "<=" := Rle : R_scope. Infix ">=" := Rge : R_scope. Notation "0" := Rzero : R_scope. Notation "1" := Rone : R_scope. Notation "2" := Rtwo : R_scope. Infix "+" := Rplus : R_scope. Notation "- x" := (Ropp x) : R_scope. Infix "-" := Rminus : R_scope. Infix "*" := Rmult : R_scope. Notation "/ x" := (Rinv (pr1 x) (pr2 x)) : R_scope. Notation "x / y" := (Rdiv x (pr1 y) (pr2 y)) : R_scope. (** ** NRNRtoR and RtoNRNR *) Lemma NRNRtoR_RtoNRNR : ∏ x : Reals, NRNRtoR (pr1 (RtoNRNR x)) (pr2 (RtoNRNR x)) = x. Proof. intros X. unfold NRNRtoR. apply hr_to_NR_bij. Qed. Lemma RtoNRNR_NRNRtoR : ∏ x y : NonnegativeReals, (RtoNRNR (NRNRtoR x y)) = ((x - y)%NR ,, (y - x)%NR). Proof. intros X Y. unfold RtoNRNR, NRNRtoR. unfold hr_to_NR, NR_to_hr. now rewrite setquotunivcomm. Qed. Lemma NRNRtoR_inside : ∏ x y : NonnegativeReals, pr1 (NRNRtoR x y) (x,,y). Proof. intros x y. apply hinhpr. exists 0%NR ; simpl. reflexivity. Qed. Lemma NRNRtoR_zero : NRNRtoR 0%NR 0%NR = 0. Proof. unfold NRNRtoR, NR_to_hr. refine (setquotl0 _ 0 (_,,_)). apply hinhpr. exists 0%NR ; simpl. reflexivity. Qed. Lemma NRNRtoR_one : NRNRtoR 1%NR 0%NR = 1. Proof. unfold NRNRtoR, NR_to_hr. refine (setquotl0 _ 1 (_,,_)). apply hinhpr. exists 0%NR ; simpl. reflexivity. Qed. Lemma NRNRtoR_eq : ∏ x x' y y' : NonnegativeReals, (x + y' = x' + y)%NR <-> NRNRtoR x y = NRNRtoR x' y'. Proof. intros x x' y y'. apply (NR_to_hr_eq (x,,y) (x' ,, y')). Qed. Lemma NRNRtoR_ap : ∏ x x' y y' : NonnegativeReals, (x + y' ≠ x' + y)%NR <-> NRNRtoR x y ≠ NRNRtoR x' y'. Proof. intros x x' y y'. apply (NR_to_hr_ap (x,,y) (x' ,, y')). Qed. Lemma NRNRtoR_lt : ∏ x x' y y' : NonnegativeReals, (x + y' < x' + y)%NR <-> NRNRtoR x y < NRNRtoR x' y'. Proof. intros x x' y y'. apply (NR_to_hr_lt (x,,y) (x' ,, y')). Qed. Lemma NRNRtoR_le : ∏ x x' y y' : NonnegativeReals, (x + y' <= x' + y)%NR <-> NRNRtoR x y <= NRNRtoR x' y'. Proof. intros x x' y y'. apply (NR_to_hr_le (x,,y) (x' ,, y')). Qed. Lemma NRNRtoR_plus : ∏ x x' y y' : NonnegativeReals, NRNRtoR (x + x')%NR (y + y')%NR = NRNRtoR x y + NRNRtoR x' y'. Proof. intros x x' y y'. apply pathsinv0, NR_to_hr_plus. Qed. Lemma NRNRtoR_opp : ∏ x y : NonnegativeReals, NRNRtoR y x = - NRNRtoR x y. Proof. intros x y. apply pathsinv0, NR_to_hr_opp. Qed. Lemma NRNRtoR_minus : ∏ x x' y y' : NonnegativeReals, NRNRtoR (x + y')%NR (y + x')%NR = NRNRtoR x y - NRNRtoR x' y'. Proof. intros x x' y y'. apply pathsinv0, NR_to_hr_minus. Qed. Lemma NRNRtoR_mult : ∏ x x' y y' : NonnegativeReals, NRNRtoR (x * x' + y * y')%NR (x * y' + y * x')%NR = NRNRtoR x y * NRNRtoR x' y'. Proof. intros x x' y y'. apply pathsinv0, NR_to_hr_mult. Qed. Lemma NRNRtoR_inv_pos : ∏ (x : NonnegativeReals) Hrn Hr, NRNRtoR (invNonnegativeReals x Hrn) 0%NR = Rinv (NRNRtoR x 0%NR) Hr. Proof. intros x Hrn Hr. rewrite <- (isrunit_CFone_CFmult (NRNRtoR (invNonnegativeReals x Hrn) 0%NR)), <- (isrunit_CFone_CFmult (Rinv (NRNRtoR x 0%NR) Hr)). rewrite <- (isrinv_CFinv (X := Reals) (NRNRtoR x 0%NR) Hr). rewrite <- !(isassoc_CFmult (X := Reals)). apply (maponpaths (λ x, (x * _)%CF)). rewrite <- NRNRtoR_mult. unfold Rinv. rewrite (islinv_CFinv (X := Reals) (NRNRtoR x 0%NR) Hr). rewrite !israbsorb_zero_multNonnegativeReals, islabsorb_zero_multNonnegativeReals. rewrite !isrunit_zero_plusNonnegativeReals. rewrite islinv_invNonnegativeReals. apply NRNRtoR_one. Qed. Lemma NRNRtoR_inv_neg : ∏ (x : NonnegativeReals) Hrn Hr, NRNRtoR 0%NR (invNonnegativeReals x Hrn) = Rinv (NRNRtoR 0%NR x) Hr. Proof. intros x Hrn Hr. rewrite <- (isrunit_CFone_CFmult (NRNRtoR 0%NR (invNonnegativeReals x Hrn))), <- (isrunit_CFone_CFmult (Rinv (NRNRtoR 0%NR x) Hr)). rewrite <- (isrinv_CFinv (X := Reals) (NRNRtoR 0%NR x) Hr). rewrite <- !(isassoc_CFmult (X := Reals)). apply (maponpaths (λ x, (x * _)%CF)). rewrite <- NRNRtoR_mult. unfold Rinv. rewrite (islinv_CFinv (X := Reals) (NRNRtoR 0%NR x) Hr). rewrite !israbsorb_zero_multNonnegativeReals, islabsorb_zero_multNonnegativeReals. rewrite !islunit_zero_plusNonnegativeReals. rewrite islinv_invNonnegativeReals. apply NRNRtoR_one. Qed. Lemma Rabs_pr1RtoNRNR : ∏ x : Reals, (pr1 (RtoNRNR x) <= Rabs x)%NR. Proof. intros x. rewrite <- (NRNRtoR_RtoNRNR x). generalize (pr1 (RtoNRNR x)) (pr2 (RtoNRNR x)) ; clear x ; intros x y ; simpl. apply maxNonnegativeReals_le_l. Qed. Lemma Rabs_pr2RtoNRNR : ∏ x : Reals, (pr2 (RtoNRNR x) <= Rabs x)%NR. Proof. intros x. rewrite <- (NRNRtoR_RtoNRNR x). generalize (pr1 (RtoNRNR x)) (pr2 (RtoNRNR x)) ; clear x ; intros x y ; simpl. apply maxNonnegativeReals_le_r. Qed. (** ** Theorems about apartness and order *) Lemma ispositive_Rone : 0 < 1. Proof. rewrite <- NRNRtoR_zero, <- NRNRtoR_one. apply NRNRtoR_lt. rewrite !isrunit_zero_plusNonnegativeReals. apply ispositive_apNonnegativeReals. apply isnonzeroNonnegativeReals. Qed. Lemma isirrefl_Rlt : ∏ x : Reals, ¬ (x < x). Proof. exact (isirrefl_isStrongOrder (isStrongOrder_hr_lt)). Qed. Lemma istrans_Rlt : ∏ x y z : Reals, x < y -> y < z -> x < z. Proof. exact (istrans_isStrongOrder (isStrongOrder_hr_lt)). Qed. Lemma iscotrans_Rlt : ∏ (x y z : Reals), (x < z) -> (x < y) ∨ (y < z). Proof. exact iscotrans_hr_lt. Qed. Lemma Rplus_ltcompat_l: ∏ x y z : Reals, y < z <-> (y + x) < (z + x). Proof. exact hr_plus_ltcompat_l. Qed. Lemma Rplus_ltcompat_r: ∏ x y z : Reals, y < z <-> (x + y) < (x + z). Proof. exact hr_plus_ltcompat_r. Qed. Lemma Rmult_ltcompat_l: ∏ x y z : Reals, 0 < x -> y < z -> (y * x) < (z * x). Proof. exact hr_mult_ltcompat_l. Qed. Lemma Rmult_ltcompat_l': ∏ x y z : Reals, 0 <= x -> (y * x) < (z * x) -> y < z. Proof. exact hr_mult_ltcompat_l'. Qed. Lemma Rmult_ltcompat_r: ∏ x y z : Reals, 0 < x -> y < z -> (x * y) < (x * z). Proof. intros x y z. rewrite !(iscomm_CFmult x). now apply Rmult_ltcompat_l. Qed. Lemma Rmult_ltcompat_r': ∏ x y z : Reals, 0 <= x -> (x * y) < (x * z) -> y < z. Proof. exact hr_mult_ltcompat_r'. Qed. Lemma Rarchimedean: ∏ x : Reals, ∃ n : nat, x < nattoring n. Proof. exact hr_archimedean. Qed. Lemma notRlt_Rle : ∏ x y : Reals, ¬ (x < y) <-> (y <= x). Proof. exact hr_notlt_le. Qed. Lemma Rlt_Rle : ∏ x y : Reals, x < y -> x <= y. Proof. intros x y H. apply notRlt_Rle. intros H0. refine (isirrefl_Rlt _ _). refine (istrans_Rlt _ _ _ _ _). - exact H. - exact H0. Qed. Lemma isantisymm_Rle : ∏ x y : Reals, x <= y -> y <= x -> x = y. Proof. exact isantisymm_hr_le. Qed. Lemma istrans_Rle : ∏ x y z : Reals, x <= y -> y <= z -> x <= z. Proof. intros x y z Hxy Hyz. apply notRlt_Rle ; intro H. generalize (iscotrans_Rlt _ y _ H). apply factor_through_squash. { exact isapropempty. } apply sumofmaps. + apply_pr2 notRlt_Rle. exact Hyz. + apply_pr2 notRlt_Rle. exact Hxy. Qed. Lemma istrans_Rle_lt : ∏ x y z : Reals, x <= y -> y < z -> x < z. Proof. intros x y z Hxy Hyz. generalize (iscotrans_Rlt _ x _ Hyz). apply hinhuniv. apply sumofmaps ; intros H. - apply fromempty. revert H. apply_pr2 notRlt_Rle. exact Hxy. - exact H. Qed. Lemma istrans_Rlt_le : ∏ x y z : Reals, x < y -> y <= z -> x < z. Proof. intros x y z Hxy Hyz. generalize (iscotrans_Rlt _ z _ Hxy). apply hinhuniv. apply sumofmaps ; intros H. - exact H. - apply fromempty. revert H. apply_pr2 notRlt_Rle. exact Hyz. Qed. Lemma Rplus_lecompat_l: ∏ x y z : Reals, y <= z <-> (y + x) <= (z + x). Proof. exact hr_plus_lecompat_l. Qed. Lemma Rplus_lecompat_r: ∏ x y z : Reals, y <= z <-> (x + y) <= (x + z). Proof. exact hr_plus_lecompat_r. Qed. Lemma Rmult_lecompat_l: ∏ x y z : Reals, 0 <= x -> y <= z -> (y * x) <= (z * x). Proof. exact hr_mult_lecompat_l. Qed. Lemma Rmult_lecompat_l': ∏ x y z : Reals, 0 < x -> (y * x) <= (z * x) -> y <= z. Proof. exact hr_mult_lecompat_l'. Qed. Lemma Rmult_lecompat_r: ∏ x y z : Reals, 0 <= x -> y <= z -> (x * y) <= (x * z). Proof. exact hr_mult_lecompat_r. Qed. Lemma Rmult_lecompat_r': ∏ x y z : Reals, 0 < x -> (x * y) <= (x * z) -> y <= z. Proof. exact hr_mult_lecompat_r'. Qed. Lemma Rap_Rlt: ∏ x y : Reals, x ≠ y <-> (x < y) ⨿ (y < x). Proof. exact hr_ap_lt. Qed. Lemma isnonzeroReals : (1 ≠ 0). Proof. exact isnonzeroCF. Qed. Lemma isirrefl_Rap : ∏ x : Reals, ¬ (x ≠ x). Proof. exact isirrefl_CFap. Qed. Lemma issymm_Rap : ∏ (x y : Reals), (x ≠ y) -> (y ≠ x). Proof. exact issymm_CFap. Qed. Lemma iscotrans_Rap : ∏ (x y z : Reals), (x ≠ z) -> (x ≠ y) ∨ (y ≠ z). Proof. exact iscotrans_CFap. Qed. Lemma istight_Rap : ∏ (x y : Reals), ¬ (x ≠ y) -> x = y. Proof. exact istight_CFap. Qed. Lemma apRplus : ∏ (x x' y y' : Reals), (x + y ≠ x' + y') -> (x ≠ x') ∨ (y ≠ y'). Proof. exact apCFplus. Qed. Lemma Rplus_apcompat_l : ∏ x y z : Reals, y + x ≠ z + x <-> y ≠ z. Proof. exact CFplus_apcompat_l. Qed. Lemma Rplus_apcompat_r : ∏ x y z : Reals, x + y ≠ x + z <-> y ≠ z. Proof. exact CFplus_apcompat_r. Qed. Lemma apRmult: ∏ (x x' y y' : Reals), (x * y ≠ x' * y') -> (x ≠ x') ∨ (y ≠ y'). Proof. apply apCFmult. Qed. Lemma Rmult_apcompat_l: ∏ (x y z : Reals), (y * x ≠ z * x) -> (y ≠ z). Proof. exact CFmult_apcompat_l. Qed. Lemma Rmult_apcompat_l': ∏ (x y z : Reals), (x ≠ 0) -> (y ≠ z) -> (y * x ≠ z * x). Proof. exact CFmult_apcompat_l'. Qed. Lemma Rmult_apcompat_r: ∏ (x y z : Reals), (x * y ≠ x * z) -> (y ≠ z). Proof. exact CFmult_apcompat_r. Qed. Lemma Rmult_apcompat_r': ∏ (x y z : Reals), (x ≠ 0) -> (y ≠ z) -> (x * y ≠ x * z). Proof. exact CFmult_apcompat_r'. Qed. Lemma RmultapRzero: ∏ (x y : Reals), (x * y ≠ 0) -> (x ≠ 0) ∧ (y ≠ 0). Proof. exact CFmultapCFzero. Qed. (** ** Algrebra *) Lemma islunit_Rzero_Rplus : ∏ x : Reals, 0 + x = x. Proof. exact islunit_CFzero_CFplus. Qed. Lemma isrunit_Rzero_Rplus : ∏ x : Reals, x + 0 = x. Proof. exact isrunit_CFzero_CFplus. Qed. Lemma isassoc_Rplus : ∏ x y z : Reals, x + y + z = x + (y + z). Proof. exact isassoc_CFplus. Qed. Lemma islinv_Ropp : ∏ x : Reals, - x + x = 0. Proof. exact islinv_CFopp. Qed. Lemma isrinv_Ropp : ∏ x : Reals, x + - x = 0. Proof. exact isrinv_CFopp. Qed. Lemma iscomm_Rplus : ∏ x y : Reals, x + y = y + x. Proof. exact iscomm_CFplus. Qed. Lemma islunit_Rone_Rmult : ∏ x : Reals, 1 * x = x. Proof. exact islunit_CFone_CFmult. Qed. Lemma isrunit_Rone_Rmult : ∏ x : Reals, x * 1 = x. Proof. exact isrunit_CFone_CFmult. Qed. Lemma isassoc_Rmult : ∏ x y z : Reals, x * y * z = x * (y * z). Proof. exact isassoc_CFmult. Qed. Lemma iscomm_Rmult : ∏ x y : Reals, x * y = y * x. Proof. exact iscomm_CFmult. Qed. Lemma islinv_Rinv : ∏ (x : Reals) (Hx0 : x ≠ 0), (Rinv x Hx0) * x = 1. Proof. exact islinv_CFinv. Qed. Lemma isrinv_Rinv : ∏ (x : Reals) (Hx0 : x ≠ 0), x * (Rinv x Hx0) = 1. Proof. exact isrinv_CFinv. Qed. Lemma islabsorb_Rzero_Rmult : ∏ x : Reals, 0 * x = 0. Proof. exact islabsorb_CFzero_CFmult. Qed. Lemma israbsorb_Rzero_Rmult : ∏ x : Reals, x * 0 = 0. Proof. exact israbsorb_CFzero_CFmult. Qed. Lemma isldistr_Rplus_Rmult : ∏ x y z : Reals, z * (x + y) = z * x + z * y. Proof. exact isldistr_CFplus_CFmult. Qed. Lemma isrdistr_Rplus_Rmult : ∏ x y z : Reals, (x + y) * z = x * z + y * z. Proof. exact isrdistr_CFplus_CFmult. Qed. (** ** Rabs *) Lemma istriangle_Rabs : ∏ x y : Reals, (Rabs (x + y)%R <= Rabs x + Rabs y)%NR. Proof. exact istriangle_hr_abs. Qed. Lemma istriangle_Rabs' : ∏ x y : Reals, (Rabs x - Rabs y <= Rabs (x + y)%R)%NR. Proof. exact istriangle_hr_abs'. Qed. Lemma Rabs_Rmult : ∏ x y : Reals, (Rabs (x * y)%R = Rabs x * Rabs y)%NR. Proof. exact hr_abs_mult. Qed. Lemma Rabs_Ropp : ∏ x : Reals, (Rabs (- x)%R = Rabs x). Proof. intros x. rewrite <- (NRNRtoR_RtoNRNR x). apply iscomm_maxNonnegativeReals. Qed. UniMath-20231010/UniMath/RealNumbers/Sets.v000066400000000000000000000205041451125700300202010ustar00rootroot00000000000000(** * Additional theorems for Sets.v *) (** Previous theorems about hSet and order *) Require Export UniMath.Foundations.Sets UniMath.MoreFoundations.QuotientSet. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Sets. Require Import UniMath.MoreFoundations.Orders. Require Import UniMath.Algebra.BinaryOperations UniMath.Algebra.Apartness UniMath.OrderTheory.Lattice.Lattice. (** * Partially-defined inverse functions *) Definition islinv' {X : hSet} (x1 : X) (op : binop X) (exinv : hsubtype X) (inv : carrier_subset exinv -> X) := ∏ (x : X) (Hx : exinv x), op (inv (x ,, Hx)) x = x1. Definition isrinv' {X : hSet} (x1 : X) (op : binop X) (exinv : hsubtype X) (inv : carrier_subset exinv -> X) := ∏ (x : X) (Hx : exinv x), op x (inv (x ,, Hx)) = x1. Definition isinv' {X : hSet} (x1 : X) (op : binop X) (exinv : hsubtype X) (inv : carrier_subset exinv -> X) := islinv' x1 op exinv inv × isrinv' x1 op exinv inv. (** * Effective Orders *) (** An alternative to total orders *) Definition isEffectiveOrder {X : UU} (le lt : hrel X) := dirprod ((ispreorder le) × (isStrongOrder lt)) ((∏ x y : X, (¬ lt x y) <-> (le y x)) × (∏ x y z : X, lt x y -> le y z -> lt x z) × (∏ x y z : X, le x y -> lt y z -> lt x z)). Definition EffectiveOrder (X : UU) := ∑ le lt : hrel X, isEffectiveOrder le lt. Definition pairEffectiveOrder {X : UU} (le lt : hrel X) (is : isEffectiveOrder le lt) : EffectiveOrder X := (le,,lt,,is). Definition EffectivelyOrderedSet := ∑ X : hSet, EffectiveOrder X. Definition pairEffectivelyOrderedSet {X : hSet} (is : EffectiveOrder X) : EffectivelyOrderedSet := tpair _ X is. Definition pr1EffectivelyOrderedSet : EffectivelyOrderedSet → hSet := pr1. Coercion pr1EffectivelyOrderedSet : EffectivelyOrderedSet >-> hSet. Definition EOle {X : EffectivelyOrderedSet} : po X := let R := pr2 X in make_po (pr1 R) (pr1 (pr1 (pr2 (pr2 R)))). Definition EOle_rel {X : EffectivelyOrderedSet} : hrel X := pr1 EOle. Arguments EOle_rel {X} x y: simpl never. Definition EOge {X : EffectivelyOrderedSet} : po X := po_reverse (@EOle X). Definition EOge_rel {X : EffectivelyOrderedSet} : hrel X := pr1 EOge. Arguments EOge_rel {X} x y: simpl never. Definition EOlt {X : EffectivelyOrderedSet} : StrongOrder (pr1 X) := let R := pr2 X in make_StrongOrder (pr1 (pr2 R)) (pr2 (pr1 (pr2 (pr2 R)))). Definition EOlt_rel {X : EffectivelyOrderedSet} : hrel X := pr1 EOlt. Arguments EOlt_rel {X} x y: simpl never. Definition EOgt {X : EffectivelyOrderedSet} : StrongOrder (pr1 X) := StrongOrder_reverse (@EOlt X). Definition EOgt_rel {X : EffectivelyOrderedSet} : hrel X := pr1 EOgt. Arguments EOgt_rel {X} x y: simpl never. Definition PreorderedSetEffectiveOrder (X : EffectivelyOrderedSet) : PreorderedSet := PreorderedSetPair _ (@EOle X). Declare Scope eo_scope. Delimit Scope eo_scope with eo. Notation "x <= y" := (EOle_rel x y) : eo_scope. Notation "x >= y" := (EOge_rel x y) : eo_scope. Notation "x < y" := (EOlt_rel x y) : eo_scope. Notation "x > y" := (EOgt_rel x y) : eo_scope. Section eo_pty. Context {X : EffectivelyOrderedSet}. Local Open Scope eo_scope. Lemma not_EOlt_le : ∏ x y : X, (¬ (x < y)) <-> (y <= x). Proof. exact (pr1 (pr2 (pr2 (pr2 (pr2 X))))). Qed. Lemma EOge_le: ∏ x y : X, (x >= y) <-> (y <= x). Proof. now split. Qed. Lemma EOgt_lt: ∏ x y : X, (x > y) <-> (y < x). Proof. now split. Qed. Definition isrefl_EOle: ∏ x : X, x <= x := isrefl_po EOle. Definition istrans_EOle: ∏ x y z : X, x <= y -> y <= z -> x <= z := istrans_po EOle. Definition isirrefl_EOgt: ∏ x : X, ¬ (x > x) := isirrefl_isStrongOrder EOgt. Definition istrans_EOgt: ∏ x y z : X, x > y -> y > z -> x > z := istrans_isStrongOrder EOgt. Definition isirrefl_EOlt: ∏ x : X, ¬ (x < x) := isirrefl_isStrongOrder EOlt. Definition istrans_EOlt: ∏ x y z : X, x < y -> y < z -> x < z := istrans_isStrongOrder EOlt. Lemma EOlt_le : ∏ x y : X, x < y -> x <= y. Proof. intros x y Hxy. apply not_EOlt_le. intros H. refine (isirrefl_EOlt _ _). refine (istrans_EOlt _ _ _ _ _). exact Hxy. exact H. Qed. Lemma istrans_EOlt_le: ∏ x y z : X, x < y -> y <= z -> x < z. Proof. exact (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 X)))))). Qed. Lemma istrans_EOle_lt: ∏ x y z : X, x <= y -> y < z -> x < z. Proof. exact (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 X)))))). Qed. Lemma EOlt_noteq : ∏ x y : X, x < y -> x != y. Proof. intros x y Hgt Heq. rewrite Heq in Hgt. now apply isirrefl_EOgt in Hgt. Qed. Lemma EOgt_noteq : ∏ x y : X, x > y -> x != y. Proof. intros x y Hgt Heq. rewrite Heq in Hgt. now apply isirrefl_EOgt in Hgt. Qed. Close Scope eo_scope. End eo_pty. (** ** Constructive Total Effective Order *) Definition isConstructiveTotalEffectiveOrder {X : UU} (ap le lt : hrel X) := istightap ap × isEffectiveOrder le lt × (isantisymm le) × (∏ x y : X, ap x y <-> (lt x y) ⨿ (lt y x)). Definition ConstructiveTotalEffectiveOrder X := ∑ ap lt le : hrel X, isConstructiveTotalEffectiveOrder ap lt le. Definition ConstructiveTotalEffectivellyOrderedSet := ∑ X : hSet, ConstructiveTotalEffectiveOrder X. (** ** Complete Ordered Space *) Section LeastUpperBound. Context {X : PreorderedSet}. Local Notation "x <= y" := (pr1 (pr2 X) x y). Definition isUpperBound (E : hsubtype X) (ub : X) : UU := ∏ x : X, E x -> x <= ub. Definition isSmallerThanUpperBounds (E : hsubtype X) (lub : X) : UU := ∏ ub : X, isUpperBound E ub -> lub <= ub. Definition isLeastUpperBound (E : hsubtype X) (lub : X) : UU := (isUpperBound E lub) × (isSmallerThanUpperBounds E lub). Definition LeastUpperBound (E : hsubtype X) : UU := ∑ lub : X, isLeastUpperBound E lub. Definition pairLeastUpperBound (E : hsubtype X) (lub : X) (is : isLeastUpperBound E lub) : LeastUpperBound E := tpair (isLeastUpperBound E) lub is. Definition pr1LeastUpperBound {E : hsubtype X} : LeastUpperBound E → X := pr1. Lemma isapropLeastUpperBound (E : hsubtype X) (H : isantisymm (λ x y : X, x <= y)) : isaprop (LeastUpperBound E). Proof. intros x y. apply (iscontrweqf (X := (pr1 x) = (pr1 y))). - apply invweq, subtypeInjectivity. intro t. apply isapropdirprod. apply impred_isaprop ; intro. apply isapropimpl. now apply pr2. apply impred_isaprop ; intro. apply isapropimpl. now apply pr2. - assert (Heq : (pr1 x) = (pr1 y)). { apply H. now apply (pr2 (pr2 x)), (pr1 (pr2 y)). now apply (pr2 (pr2 y)), (pr1 (pr2 x)). } rewrite <- Heq. apply iscontrloopsifisaset. apply pr2. Qed. End LeastUpperBound. Section GreatestLowerBound. Context {X : PreorderedSet}. Local Notation "x >= y" := (pr1 (pr2 X) y x). Definition isLowerBound (E : hsubtype X) (ub : X) : UU := ∏ x : X, E x -> x >= ub. Definition isBiggerThanLowerBounds (E : hsubtype X) (lub : X) : UU := ∏ ub : X, isLowerBound E ub -> lub >= ub. Definition isGreatestLowerBound (E : hsubtype X) (glb : X) : UU := (isLowerBound E glb) × (isBiggerThanLowerBounds E glb). Definition GreatestLowerBound (E : hsubtype X) : UU := ∑ glb : X, isGreatestLowerBound E glb. Definition pairGreatestLowerBound (E : hsubtype X) (glb : X) (is : isGreatestLowerBound E glb) : GreatestLowerBound E := tpair (isGreatestLowerBound E) glb is. Definition pr1GreatestLowerBound {E : hsubtype X} : GreatestLowerBound E → X := pr1. Lemma isapropGreatestLowerBound (E : hsubtype X) (H : isantisymm (λ x y : X, x >= y)) : isaprop (GreatestLowerBound E). Proof. intros x y. apply (iscontrweqf (X := (pr1 x) = (pr1 y))). - apply invweq, subtypeInjectivity. intro t. apply isapropdirprod. apply impred_isaprop ; intro. apply isapropimpl. now apply pr2. apply impred_isaprop ; intro. apply isapropimpl. now apply pr2. - assert (Heq : (pr1 x) = (pr1 y)). { apply H. now apply (pr2 (pr2 x)), (pr1 (pr2 y)). now apply (pr2 (pr2 y)), (pr1 (pr2 x)). } rewrite <- Heq. apply iscontrloopsifisaset. apply pr2. Qed. End GreatestLowerBound. Definition isCompleteSpace (X : PreorderedSet) := ∏ E : hsubtype X, hexists (isUpperBound E) -> hexists E -> LeastUpperBound E. Definition CompleteSpace := ∑ X : PreorderedSet, isCompleteSpace X. Definition pr1CompleteSpace : CompleteSpace → UU := pr1. Coercion pr1CompleteSpace : CompleteSpace >-> UU. UniMath-20231010/UniMath/Semantics/000077500000000000000000000000001451125700300166025ustar00rootroot00000000000000UniMath-20231010/UniMath/Semantics/.package/000077500000000000000000000000001451125700300202535ustar00rootroot00000000000000UniMath-20231010/UniMath/Semantics/.package/files000066400000000000000000000005371451125700300213050ustar00rootroot00000000000000LinearLogic/LinearNonLinear.v LinearLogic/LafontCategory.v LinearLogic/LinearCategory.v LinearLogic/LinearCategoryEilenbergMooreAdjunction.v LinearLogic/LinearToLinearNonLinear.v LinearLogic/RelationalModel.v LinearLogic/LiftingModel.v EnrichedEffectCalculus/EECModel.v EnrichedEffectCalculus/ContinuationModel.v EnrichedEffectCalculus/CopowerModel.vUniMath-20231010/UniMath/Semantics/EnrichedEffectCalculus/000077500000000000000000000000001451125700300231345ustar00rootroot00000000000000UniMath-20231010/UniMath/Semantics/EnrichedEffectCalculus/ContinuationModel.v000066400000000000000000000521471451125700300267670ustar00rootroot00000000000000(********************************************************************** The continuation model of the enriched effect calculus In this file, we formalize Example 6.10 from the following paper: http://www.itu.dk/people/mogel/papers/eec.pdf The example considers a specific model of the enriched effect calculus such that the monad associated to the adjunction is the continuation monad. Most of the building blocks of the model are already present in other files, namely limits and colimits in the self-enriched category and limits and colimits in the opposite enriched category. The only missing part is the construction of the required adjunction. Contents: 1. Continuation adjunction 1.1. The functors 1.2. The unit and counit 1.3. The adjunction 2. The continuation model **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentAdjunction. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.Examples.SelfEnrichedLimits. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.Examples.OppositeEnrichedLimits. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.Examples.SelfEnrichedColimits. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.Examples.OppositeEnrichedColimits. Require Import UniMath.Semantics.EnrichedEffectCalculus.EECModel. Import MonoidalNotations. Local Open Scope moncat. Local Open Scope cat. Opaque sym_mon_braiding. (** 1. Continuation adjunction *) Section ContinuationAdjunction. Context (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (IV : Initial VC) (VCP : BinCoproducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (r : V). Opaque V. (** 1.1. The functors *) Definition continuation_functor_data : functor_data V (V^opp). Proof. use make_functor_data. - exact (λ y, y ⊸ r). - exact (λ x y f, internal_precomp f r). Defined. Proposition continuation_functor_laws : is_functor continuation_functor_data. Proof. split. - intros y. apply internal_precomp_id. - intros y₁ y₂ y₃ f g. apply internal_precomp_comp. Qed. Definition continuation_functor : V ⟶ V^opp. Proof. use make_functor. - exact continuation_functor_data. - exact continuation_functor_laws. Defined. Proposition continuation_functor_enrichment_laws : @is_functor_enrichment V V (V ^opp) continuation_functor (self_enrichment V) (op_enrichment V (self_enrichment V)) (λ x y, internal_lam (sym_mon_braiding V _ _ · internal_comp x y r)). Proof. repeat split ; cbn. - intro x. use internal_funext. intros a h. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. unfold internal_id. rewrite internal_beta. rewrite tensor_lunitor. apply idpath. } use internal_funext. intros a' h'. refine (!_). rewrite !tensor_comp_r_id_r. unfold internal_comp. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_r_id_r. rewrite id_right. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. unfold internal_id. rewrite internal_beta. rewrite tensor_split. apply idpath. } rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. rewrite <- mon_triangle. rewrite <- tensor_comp_mor. rewrite id_right. rewrite sym_mon_braiding_runitor. apply idpath. - intros x y z. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). etrans. { do 2 apply maponpaths. apply internal_beta. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_mor. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } rewrite tensor_split. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. clear a h. rewrite !assoc. rewrite tensor_sym_mon_braiding. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. etrans. { apply maponpaths. unfold internal_comp. rewrite internal_beta. apply idpath. } rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_id_l. unfold internal_comp. rewrite internal_beta. apply idpath. } refine (!_). etrans. { do 4 apply maponpaths. unfold internal_comp. rewrite internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite tensor_id_id. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !tensor_comp_l_id_r. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_id_id. rewrite tensor_lassociator. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. rewrite tensor_split. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. clear a h. rewrite mon_lassociator_lassociator. rewrite !assoc. do 2 apply maponpaths_2. rewrite <- !tensor_comp_id_r. apply maponpaths_2. refine (!_). etrans. { apply maponpaths_2. rewrite !assoc'. rewrite <- tensor_sym_mon_braiding. rewrite !assoc. apply maponpaths_2. refine (!_). apply sym_mon_hexagon_lassociator. } apply lassociator_hexagon_two. - intros x y f. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite !internal_beta. use internal_funext. intros a' h'. rewrite !tensor_comp_r_id_r. unfold internal_precomp. rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. refine (!_). rewrite !assoc. etrans. { rewrite <- tensor_comp_mor. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_r_id_r. rewrite id_right. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite internal_beta. rewrite id_right. rewrite tensor_comp_l_id_r. rewrite tensor_split. apply idpath. } rewrite !assoc. do 2 apply maponpaths_2. rewrite !assoc'. rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)). rewrite <- mon_triangle. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_right. apply maponpaths_2. rewrite sym_mon_braiding_runitor. rewrite tensor_lunitor. apply idpath. Qed. Definition continuation_functor_enrichment : functor_enrichment continuation_functor (self_enrichment V) (op_enrichment V (self_enrichment V)). Proof. simple refine (_ ,, _). - exact (λ x y, internal_lam (sym_mon_braiding _ _ _ · internal_comp _ _ _)). - exact continuation_functor_enrichment_laws. Defined. Definition continuation_functor_op_data : functor_data (V^opp) V. Proof. use make_functor_data ; cbn. - exact (λ y, y ⊸ r). - exact (λ x y f, internal_precomp f r). Defined. Proposition continuation_functor_op_laws : is_functor continuation_functor_op_data. Proof. split. - intros y ; cbn. apply internal_precomp_id. - intros y₁ y₂ y₃ f g ; cbn. apply internal_precomp_comp. Qed. Definition continuation_functor_op : V^opp ⟶ V. Proof. use make_functor. - exact continuation_functor_op_data. - exact continuation_functor_op_laws. Defined. Proposition continuation_functor_op_enrichment_laws : @is_functor_enrichment V (V ^opp) V continuation_functor_op (op_enrichment V (self_enrichment V)) (self_enrichment V) (λ x y, internal_lam (sym_mon_braiding V _ _ · internal_comp _ _ _)). Proof. repeat split. - intro x. exact (pr1 continuation_functor_enrichment_laws x). - intros x y z. cbn. rewrite !assoc'. etrans. { apply maponpaths. exact (pr12 continuation_functor_enrichment_laws z y x). } cbn. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. rewrite sym_mon_braiding_inv. apply id_right. - intros x y f. exact (pr22 continuation_functor_enrichment_laws y x f). Qed. Definition continuation_functor_op_enrichment : functor_enrichment continuation_functor_op (op_enrichment V (self_enrichment V)) (self_enrichment V). Proof. simple refine (_ ,, _). - exact (λ x y, internal_lam (sym_mon_braiding _ _ _ · internal_comp _ _ _)). - exact continuation_functor_op_enrichment_laws. Defined. (** 1.2. The unit and counit *) Definition continuation_adjunction_unit_data : nat_trans_data (functor_identity V) (continuation_functor ∙ continuation_functor_op) := λ x, internal_lam (sym_mon_braiding _ _ _ · internal_eval _ _). Proposition continuation_adjunction_unit_laws : is_nat_trans _ _ continuation_adjunction_unit_data. Proof. intros x y f ; cbn ; unfold continuation_adjunction_unit_data. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_precomp. rewrite !internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. refine (!_). etrans. { rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_split'. apply idpath. Qed. Definition continuation_adjunction_unit : functor_identity V ⟹ continuation_functor ∙ continuation_functor_op. Proof. use make_nat_trans. - exact continuation_adjunction_unit_data. - exact continuation_adjunction_unit_laws. Defined. Proposition continuation_adjunction_unit_enrichment : nat_trans_enrichment continuation_adjunction_unit (functor_id_enrichment (self_enrichment V)) (functor_comp_enrichment continuation_functor_enrichment continuation_functor_op_enrichment). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. unfold continuation_adjunction_unit_data. rewrite self_enrichment_precomp. rewrite self_enrichment_postcomp. rewrite id_left. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. refine (!_). etrans. { rewrite tensor_split. rewrite !assoc'. apply idpath. } apply maponpaths. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. apply idpath. } use internal_funext. intros a' h'. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite !internal_beta. etrans. { do 2 apply maponpaths. unfold internal_comp. rewrite !internal_beta. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply idpath. } rewrite !assoc. rewrite <- tensor_comp_mor. rewrite !tensor_sym_mon_braiding. rewrite id_right. rewrite tensor_comp_r_id_r. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite <- !tensor_comp_mor. rewrite !id_left, !id_right. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. cbn. rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite !assoc'. unfold internal_comp. rewrite internal_beta. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite tensor_split. refine (!_). rewrite <- tensor_sym_mon_braiding. rewrite tensor_split. rewrite !assoc'. apply maponpaths. clear a h a' h'. refine (!_). rewrite !assoc. rewrite tensor_sym_mon_braiding. apply maponpaths_2. rewrite <- sym_mon_hexagon_lassociator. cbn. apply lassociator_hexagon_two. Qed. Proposition continuation_adjunction_counit_laws : is_nat_trans (continuation_functor_op ∙ continuation_functor) (functor_identity (V^opp)) continuation_adjunction_unit_data. Proof. intros x y f ; cbn ; unfold continuation_adjunction_unit_data. refine (!_). apply continuation_adjunction_unit_laws. Qed. Definition continuation_adjunction_counit : continuation_functor_op ∙ continuation_functor ⟹ functor_identity (V^opp). Proof. use make_nat_trans. - exact continuation_adjunction_unit_data. - exact continuation_adjunction_counit_laws. Defined. Proposition continuation_adjunction_counit_enrichment : nat_trans_enrichment continuation_adjunction_counit (functor_comp_enrichment continuation_functor_op_enrichment continuation_functor_enrichment) (functor_id_enrichment (op_enrichment V (self_enrichment V))). Proof. use nat_trans_enrichment_via_comp. intros x y. pose (nat_trans_enrichment_to_comp continuation_adjunction_unit_enrichment y x) as p. cbn ; cbn in p. rewrite op_enrichment_postcomp. rewrite op_enrichment_precomp. exact (!p). Qed. (** 1.3. The adjunction *) Definition continuation_adjunction_data : adjunction_data V (V^opp). Proof. use make_adjunction_data. - exact continuation_functor. - exact continuation_functor_op. - exact continuation_adjunction_unit. - exact continuation_adjunction_counit. Defined. Proposition continuation_adjunction_triangle (x : V) : continuation_adjunction_unit_data (x ⊸ r) · internal_precomp (continuation_adjunction_unit_data x) r = identity _. Proof. cbn. unfold continuation_adjunction_unit_data. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_precomp. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. rewrite tensor_sym_mon_braiding. rewrite tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_sym_mon_braiding. rewrite !assoc'. rewrite sym_mon_braiding_inv. apply id_right. Qed. Proposition continuation_adjunction_laws : form_adjunction' continuation_adjunction_data. Proof. split. - intro x. exact (continuation_adjunction_triangle x). - intro x. exact (continuation_adjunction_triangle x). Qed. Definition continuation_adjunction : adjunction V (V^opp). Proof. use make_adjunction. - exact continuation_adjunction_data. - exact continuation_adjunction_laws. Defined. Definition continuation_adjunction_enrichment : adjunction_enrichment continuation_adjunction (self_enrichment V) (op_enrichment V (self_enrichment V)). Proof. use make_adjunction_enrichment. - exact continuation_functor_enrichment. - exact continuation_functor_op_enrichment. - exact continuation_adjunction_unit_enrichment. - exact continuation_adjunction_counit_enrichment. Defined. Definition continuation_enriched_adjunction : enriched_adjunction (self_enrichment V) (op_enrichment V (self_enrichment V)) := continuation_adjunction ,, continuation_adjunction_enrichment. End ContinuationAdjunction. (** 2. The continuation model *) Section ContinuationModel. Context (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (IV : Initial VC) (VCP : BinCoproducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (r : V). Definition continuation_eec_model : eec_model := VC ,, TV ,, VP ,, expV ,, (VC^opp) ,, op_enrichment _ (self_enrichment V) ,, continuation_enriched_adjunction V TV VP expV r ,, opposite_terminal_enriched _ (self_enrichment_initial V IV) ,, opposite_initial_enriched _ (self_enrichment_terminal V TV) ,, opposite_enrichment_power _ (self_enrichment_copowers V) ,, opposite_enrichment_copower _ (self_enrichment_powers V) ,, (opposite_enrichment_binary_prod (self_enrichment V) (self_enrichment_binary_coproducts V VCP)) ,, (opposite_enrichment_binary_coprod (self_enrichment V) (self_enrichment_binary_products V VP)). Definition continuation_eec_plus_model : eec_plus_model := continuation_eec_model ,, IV ,, VCP. End ContinuationModel. UniMath-20231010/UniMath/Semantics/EnrichedEffectCalculus/CopowerModel.v000066400000000000000000000472341451125700300257340ustar00rootroot00000000000000(********************************************************************** The copower model In this file, we formalize Proposition 6.9 from the following paper: http://www.itu.dk/people/mogel/papers/eec.pdf Contents: 1. Copower adjunction 1.1. The functors 1.2. The unit and counit 1.3. The adjunction 2. The copower model **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.OppositeCategory.Core. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentAdjunction. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.Examples.SelfEnrichedLimits. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.Examples.OppositeEnrichedLimits. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.CopowerFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.Examples.SelfEnrichedColimits. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.Examples.OppositeEnrichedColimits. Require Import UniMath.Semantics.EnrichedEffectCalculus.EECModel. Import MonoidalNotations. Local Open Scope moncat. Local Open Scope cat. Section CopowerModel. Context (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (IV : Initial VC) (VCP : BinCoproducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (C : category) (r : C) (EC : enrichment C V) (TC : terminal_enriched EC) (IC : initial_enriched EC) (powC : enrichment_power EC) (copowC : enrichment_copower EC) (PC : enrichment_binary_prod EC) (CPC : enrichment_binary_coprod EC). Opaque V. (** 1. Copower adjunction *) (** 1.1. The functors *) Definition copow_functor_data : functor_data VC C. Proof. use make_functor_data. - exact (λ v, copow_ob copowC v r). - exact (λ v₁ v₂ (f : V ⟦ v₁ , v₂ ⟧), copow_mor copowC f r). Defined. Proposition copow_functor_laws : is_functor copow_functor_data. Proof. split. - intro v. exact (copow_id_mor copowC v r). - intros v₁ v₂ v₃ f g ; cbn. exact (copow_comp_mor copowC f g r). Qed. Definition copow_functor : VC ⟶ C. Proof. use make_functor. - exact copow_functor_data. - exact copow_functor_laws. Defined. Proposition copow_functor_enrichment_laws : @is_functor_enrichment V VC C copow_functor (self_enrichment V) EC (λ x y, copow_enriched_mor copowC x y r). Proof. repeat split. - intro x. use mor_to_copower_eq. { exact (pr2 (copowC _ r)). } cbn. rewrite !assoc'. etrans. { apply maponpaths. apply mor_to_copower_commutes. } use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_postcomp, is_copower_enriched_map. rewrite !internal_beta. rewrite tensor_split. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. refine (!_). rewrite !assoc. unfold internal_id. rewrite internal_beta. refine (!_). rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply idpath. - intros x y z ; cbn. use mor_to_copower_eq. { exact (pr2 (copowC _ r)). } rewrite !assoc'. etrans. { apply maponpaths. apply mor_to_copower_commutes. } use internal_funext. intros a h. etrans. { rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_postcomp. rewrite internal_beta. rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. unfold internal_comp. rewrite internal_beta. apply idpath. } rewrite !assoc'. rewrite <- (copow_enriched_mor_commute copowC y z r). etrans. { rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. apply idpath. } refine (!_). rewrite !tensor_comp_r_id_r. rewrite tensor_split. rewrite !assoc'. apply maponpaths. etrans. { unfold is_copower_enriched_map. rewrite internal_beta. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite enrichment_assoc. apply idpath. } rewrite !assoc. do 2 apply maponpaths_2. rewrite <- !tensor_comp_mor. rewrite !id_left, !id_right. rewrite tensor_lassociator. apply idpath. } rewrite !assoc. apply maponpaths_2. rewrite !assoc'. apply maponpaths. rewrite tensor_split'. refine (!_). rewrite !assoc. rewrite <- tensor_split. rewrite tensor_split'. rewrite !assoc'. apply maponpaths. rewrite <- !tensor_comp_mor. rewrite !id_left. apply maponpaths. clear z a h. etrans. { refine (!_). exact (copow_enriched_mor_commute copowC x y r). } rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_split'. apply idpath. - intros x y f ; cbn. use mor_to_copower_eq. { exact (pr2 (copowC _ r)). } etrans. { apply copow_mor_commute. } refine (!_). rewrite !assoc'. etrans. { apply maponpaths. apply mor_to_copower_commutes. } refine (!_). use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite tensor_split. rewrite !assoc'. unfold internal_postcomp. rewrite !internal_beta. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. unfold internal_from_arr. rewrite internal_beta. apply idpath. Qed. Definition copow_functor_enrichment : functor_enrichment copow_functor (self_enrichment V) EC := (λ x y, copow_enriched_mor _ _ _ _) ,, copow_functor_enrichment_laws. Definition hom_l_functor_data : functor_data C VC. Proof. use make_functor_data. - exact (λ c, EC ⦃ r , c ⦄). - exact (λ c₁ c₂ f, postcomp_arr EC r f). Defined. Proposition hom_l_functor_laws : is_functor hom_l_functor_data. Proof. split. - intro c ; cbn. apply (postcomp_arr_id EC). - intros c₁ c₂ c₃ f g ; cbn. apply (postcomp_arr_comp EC). Qed. Definition hom_l_functor : C ⟶ VC. Proof. use make_functor. - exact hom_l_functor_data. - exact hom_l_functor_laws. Defined. Proposition hom_l_functor_enrichment_laws : @is_functor_enrichment V C VC hom_l_functor EC (self_enrichment V) (λ x y, internal_lam (enriched_comp EC r x y)). Proof. repeat split. - intro x ; cbn. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. rewrite internal_beta. refine (!_). unfold internal_id. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. rewrite enrichment_id_left. rewrite !assoc. rewrite <- tensor_split. apply idpath. - intros x y z ; cbn. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold internal_comp. rewrite !internal_beta. refine (!_). rewrite !assoc. rewrite tensor_lassociator. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_comp_mor. rewrite id_right. etrans. { apply maponpaths_2. apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite tensor_comp_l_id_l. rewrite !assoc'. apply maponpaths. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite !assoc. rewrite <- tensor_lassociator. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite tensor_id_id. apply maponpaths. rewrite enrichment_assoc. rewrite !assoc. apply idpath. - intros x y f ; cbn. use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite tensor_split. rewrite !assoc'. unfold internal_from_arr. rewrite !internal_beta. unfold postcomp_arr. rewrite !assoc. apply maponpaths_2. rewrite !assoc'. etrans. { apply maponpaths. rewrite !assoc. rewrite mon_lunitor_linvunitor. apply id_left. } rewrite <- tensor_split. apply idpath. Qed. Definition hom_l_functor_enrichment : functor_enrichment hom_l_functor EC (self_enrichment V). Proof. simple refine (_ ,, _). - exact (λ x y, internal_lam (enriched_comp EC _ _ _)). - exact hom_l_functor_enrichment_laws. Defined. (** 1.2. The unit and counit *) Definition copow_adjunction_unit_data : nat_trans_data (functor_identity VC) (copow_functor ∙ hom_l_functor) := λ v, mor_of_copow_ob copowC v r. Proposition copow_adjunction_unit_enrichment : nat_trans_enrichment copow_adjunction_unit_data (functor_id_enrichment (self_enrichment V)) (functor_comp_enrichment copow_functor_enrichment hom_l_functor_enrichment). Proof. use nat_trans_enrichment_via_comp. intros x y ; cbn. rewrite id_left. rewrite (self_enrichment_precomp V), (self_enrichment_postcomp V). use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite !internal_beta. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite internal_beta. apply idpath. } rewrite tensor_split. rewrite !assoc'. apply maponpaths. clear a h. rewrite !assoc. rewrite <- tensor_split'. refine (_ @ copow_enriched_mor_commute copowC _ _ _). rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split'. apply idpath. Qed. Proposition copow_adjunction_unit_laws : is_nat_trans (functor_identity VC) (copow_functor ∙ hom_l_functor) (λ v, mor_of_copow_ob copowC v r). Proof. exact (is_nat_trans_from_enrichment copow_adjunction_unit_enrichment). Qed. Definition copow_adjunction_unit : functor_identity VC ⟹ copow_functor ∙ hom_l_functor. Proof. use make_nat_trans. - exact (λ v, mor_of_copow_ob copowC v r). - exact copow_adjunction_unit_laws. Defined. Definition copow_adjunction_counit_data : nat_trans_data (hom_l_functor ∙ copow_functor) (functor_identity C) := λ x, copow_on_enriched_mor copowC r x. Proposition copow_adjunction_counit_enrichment : nat_trans_enrichment copow_adjunction_counit_data (functor_comp_enrichment hom_l_functor_enrichment copow_functor_enrichment) (functor_id_enrichment EC). Proof. use nat_trans_enrichment_via_comp. unfold copow_adjunction_counit_data. intros x y ; cbn. rewrite id_left. use mor_to_copower_eq. { exact (pr2 (copowC _ r)). } use internal_funext. intros a h. rewrite tensor_split. rewrite !assoc'. etrans. { apply maponpaths. apply precomp_copow_on_enriched_mor_commute. } refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. refine (_ @ internal_beta _). rewrite !tensor_comp_id_r. rewrite !assoc'. apply maponpaths. refine (_ @ id_right _). refine (!_). rewrite <- mon_linvunitor_lunitor. rewrite <- (copow_on_enriched_mor_commute copowC). rewrite !tensor_comp_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite !internal_beta. refine (!_). etrans. { apply maponpaths. rewrite !assoc. rewrite <- tensor_split'. rewrite tensor_split. rewrite !assoc'. rewrite <- enriched_comp_postcomp_arr. apply idpath. } unfold postcomp_arr. rewrite !assoc. rewrite !tensor_linvunitor. rewrite !assoc'. apply maponpaths. rewrite !assoc. apply maponpaths_2. rewrite <- !tensor_comp_r_id_r. rewrite !id_left. etrans. { rewrite tensor_split'. rewrite !assoc'. apply idpath. } refine (!_). etrans. { rewrite tensor_split'. rewrite !assoc'. apply idpath. } apply maponpaths. rewrite !assoc. rewrite <- !tensor_comp_id_l. apply maponpaths. refine (!(copow_enriched_mor_commute _ _ _ _) @ _). rewrite !tensor_comp_r_id_r. rewrite !assoc'. apply maponpaths. unfold is_copower_enriched_map. rewrite internal_beta. apply idpath. Qed. Proposition copow_adjunction_counit_laws : is_nat_trans (hom_l_functor ∙ copow_functor) (functor_identity C) (λ x, copow_on_enriched_mor copowC r x). Proof. exact (is_nat_trans_from_enrichment copow_adjunction_counit_enrichment). Qed. Definition copow_adjunction_counit : hom_l_functor ∙ copow_functor ⟹ functor_identity C. Proof. use make_nat_trans. - exact (λ x, copow_on_enriched_mor copowC r x). - exact copow_adjunction_counit_laws. Defined. (** 1.3. The adjunction *) Definition copow_adjunction_data : adjunction_data VC C. Proof. use make_adjunction_data. - exact copow_functor. - exact hom_l_functor. - exact copow_adjunction_unit. - exact copow_adjunction_counit. Defined. Proposition copow_adjunction_laws : form_adjunction' copow_adjunction_data. Proof. split. - intro v ; cbn. use arr_to_copower_eq. { exact (pr2 (copowC _ r)). } rewrite enriched_from_arr_id. etrans. { apply maponpaths_2. apply maponpaths. apply arr_to_copower_precomp. } etrans. { apply arr_to_copower_commutes. } use internal_funext. intros a h. rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map, internal_postcomp. rewrite !internal_beta. rewrite tensor_split. refine (!_). rewrite tensor_split. rewrite !assoc'. apply maponpaths. clear a h. refine (!_). rewrite !assoc. rewrite internal_beta. rewrite <- tensor_split'. refine (!_). rewrite tensor_split. rewrite !assoc'. rewrite <- enrichment_id_left. rewrite tensor_lunitor. apply maponpaths. refine (!(id_right _) @ _). apply maponpaths. refine (!_). unfold postcomp_arr. rewrite !assoc. rewrite tensor_linvunitor. refine (_ @ mon_linvunitor_lunitor _). rewrite !assoc'. apply maponpaths. refine (_ @ copow_on_enriched_mor_commute copowC _ _). rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. rewrite !assoc. apply maponpaths_2. rewrite <- tensor_split. rewrite <- tensor_split'. apply idpath. - intro x ; cbn. unfold postcomp_arr. rewrite !assoc. rewrite tensor_linvunitor. rewrite !assoc'. refine (_ @ mon_linvunitor_lunitor _). apply maponpaths. rewrite !assoc. rewrite <- tensor_split. refine (_ @ copow_on_enriched_mor_commute copowC r x). rewrite !tensor_comp_r_id_r. rewrite !assoc'. unfold is_copower_enriched_map. rewrite internal_beta. rewrite !assoc. rewrite <- tensor_split'. apply idpath. Qed. Definition copow_adjunction : adjunction VC C. Proof. use make_adjunction. - exact copow_adjunction_data. - exact copow_adjunction_laws. Defined. Definition copow_adjunction_enrichment : adjunction_enrichment copow_adjunction (self_enrichment (sym_mon_closed_cartesian_cat VC VP TV expV)) EC. Proof. use make_adjunction_enrichment ; cbn. - exact copow_functor_enrichment. - exact hom_l_functor_enrichment. - exact copow_adjunction_unit_enrichment. - exact copow_adjunction_counit_enrichment. Defined. Definition copow_enriched_adjunction : enriched_adjunction (self_enrichment (sym_mon_closed_cartesian_cat VC VP TV expV)) EC := copow_adjunction ,, copow_adjunction_enrichment. (** 2. The copower model *) Definition copow_eec_model : eec_model := VC ,, TV ,, VP ,, expV ,, C ,, EC ,, copow_enriched_adjunction ,, TC ,, IC ,, powC ,, copowC ,, PC ,, CPC. Definition copow_eec_plus_model : eec_plus_model := copow_eec_model ,, IV ,, VCP. End CopowerModel. UniMath-20231010/UniMath/Semantics/EnrichedEffectCalculus/EECModel.v000066400000000000000000000102471451125700300247040ustar00rootroot00000000000000(********************************************************************** Models of the enriched effect calculus In this file, we define models for the enriched effect calculus and we follow the following paper: http://www.itu.dk/people/mogel/papers/eec.pdf In this paper, the authors first define the effect calculus, which is closely related to call-by-push-value, and then they extend it with linear type formers to obtain the enriched effect calculus. The syntax of the enriched effect calculus has similarities to call-by-push-value and the computational λ-calculus. There are the following judgments: - `⊢ Γ Con`, which says that `Γ` is a valid context - `⊢ A Ty`, which says that `A` is a value type - `⊢ A CTy`, which says that `A` is a computation type - `Γ | _ ⊢ t : A`, which says that `t` is a term of type `A`. Note that in this judgment, `A` is a value type. - `Γ | A ⊢ t : B`, which says that `t` is a term of type `B` given a computation of type `A`. Here both `A` and `B` are computation types. Note that there is a distinction between value types and computation types. Terms of value types represent values, while terms of computation types represent possibly effectful computations. Contents 1. Definition of models of the enriched calculus 1.1. Model of the enriched effect calculus 1.2. Model of the enriched effect calculus with additives **********************************************************************) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.CartesianMonoidal. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation. Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentAdjunction. Require Import UniMath.CategoryTheory.EnrichedCats.Examples.SelfEnriched. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts. Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts. Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers. Local Open Scope cat. (** 1. Definition of models of the enriched calculus *) (** 1.1. Model of the enriched effect calculus *) Definition eec_model : UU := ∑ (VC : category) (TV : Terminal VC) (VP : BinProducts VC) (expV : Exponentials VP) (V : sym_mon_closed_cat := sym_mon_closed_cartesian_cat VC VP TV expV) (C : category) (EC : enrichment C V), (enriched_adjunction (self_enrichment V) EC) × (terminal_enriched EC) × (initial_enriched EC) × (enrichment_power EC) × (enrichment_copower EC) × (enrichment_binary_prod EC) × (enrichment_binary_coprod EC). (** 1.2. Model of the enriched effect calculus with additives *) Definition eec_plus_model : UU := ∑ (M : eec_model), Initial (pr1 M) × BinCoproducts (pr1 M). Coercion eec_plus_model_to_eec_model (E : eec_plus_model) : eec_model := pr1 E. UniMath-20231010/UniMath/Semantics/LinearLogic/000077500000000000000000000000001451125700300207725ustar00rootroot00000000000000UniMath-20231010/UniMath/Semantics/LinearLogic/LafontCategory.v000066400000000000000000000061551451125700300241110ustar00rootroot00000000000000(**************************************************************************** Lafont Categories In this file, we define Lafont categories and we show that every Lafont category gives rise to a linear-non-linear model. Contents 1. Lafont category 2. Every Lafont category gives rise to a linear-non-linear model 3. Builder for Lafont categories ****************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Adjunctions. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.CommComonoidsCartesian. Require Import UniMath.Semantics.LinearLogic.LinearNonLinear. Import MonoidalNotations. Local Open Scope cat. (** 1. Lafont category *) Definition lafont_category : UU := ∑ (V : sym_mon_closed_cat), is_left_adjoint (underlying_commutative_comonoid V). Coercion lafont_category_to_sym_mon_closed_cat (V : lafont_category) : sym_mon_closed_cat := pr1 V. Definition is_left_adjoint_lafont_category (V : lafont_category) : is_left_adjoint (underlying_commutative_comonoid V) := pr2 V. (** 2. Every Lafont category gives rise to a linear-non-linear model *) Definition linear_non_linear_model_from_lafont_category (V : lafont_category) : linear_non_linear_model. Proof. use make_linear_non_linear_from_strong. - exact V. - exact (symmetric_cat_commutative_comonoids V). - use make_adjunction. + use make_adjunction_data. * exact (underlying_commutative_comonoid V). * exact (right_adjoint (is_left_adjoint_lafont_category V)). * exact (adjunit (is_left_adjoint_lafont_category V)). * exact (adjcounit (is_left_adjoint_lafont_category V)). + exact (pr22 (is_left_adjoint_lafont_category V)). - apply cartesian_monoidal_cat_of_comm_comonoids. - apply projection_fmonoidal. - apply projection_is_symmetric. Defined. (** 3. Builder for Lafont categories Note: it is convenient to use `left_adjoint_from_partial` to construct Lafont categories. *) Definition make_lafont_category (V : sym_mon_closed_cat) (HV : is_left_adjoint (underlying_commutative_comonoid V)) : lafont_category := V ,, HV. UniMath-20231010/UniMath/Semantics/LinearLogic/LiftingModel.v000066400000000000000000000102101451125700300235300ustar00rootroot00000000000000(**************************************************************************** Linear category from the lifting operation on posets We construct an example of a linear category coming from lifting posets. ****************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.OrderTheory.Posets. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.CartesianStructure. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructureLimitsAndColimits. Require Import UniMath.CategoryTheory.DisplayedCats.Structures.StructuresSmashProduct. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.PointedPosetStrict. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Examples.SmashProductMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.PosetsMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Examples.LiftPoset. Require Import UniMath.Semantics.LinearLogic.LinearCategory. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Definition lifting_linear_category_data : linear_category_data. Proof. use make_linear_category_data. - exact pointed_poset_sym_mon_closed_cat. - exact lift_poset_symmetric_monoidal_comonad. - exact (λ X, lift_poset_comult X). - exact (λ X, lift_poset_counit X). Defined. Proposition lifting_linear_category_laws : linear_category_laws lifting_linear_category_data. Proof. repeat split. - intros X Y f. exact (nat_trans_ax lift_poset_comult X Y f). - intros X Y f. refine (nat_trans_ax lift_poset_counit X Y f @ _). apply id_right. - intros X. use eq_mor_hset_struct. intro x ; cbn in x. induction x as [ x | ]. + cbn ; apply idpath. + cbn ; apply idpath. - intros X. use eq_mor_hset_struct. intro x ; cbn in x. induction x as [ x | ]. + cbn ; apply idpath. + cbn ; apply idpath. - intros X. use eq_mor_hset_struct. intro x ; cbn in x. induction x as [ x | ]. + cbn ; apply idpath. + cbn ; apply idpath. - intros X. use eq_mor_hset_struct. intro x ; cbn in x. induction x as [ x | ]. + cbn ; apply idpath. + cbn ; apply idpath. - intros X. rewrite <-tensor_mor_left. rewrite <-tensor_mor_right. apply pathsinv0, (comonoid_to_law_assoc _ (lift_commutative_comonoid X)). - intros X. rewrite <-tensor_mor_right. etrans. 2: { apply (comonoid_to_law_unit_left _ (lift_commutative_comonoid X)). } apply idpath. - intros X. apply (commutative_comonoid_is_commutative _ (lift_commutative_comonoid X)). - intros X Y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ], y as [ y | ] ; simpl ; apply idpath. - use eq_mor_hset_struct. intro x. induction x as [ | ]. + cbn. apply idpath. + use iscompsetquotpr ; cbn. refine (hinhpr (inr _)). split. * unfold product_point_coordinate ; cbn. exact (inl (idpath _)). * unfold product_point_coordinate ; cbn. exact (inr (idpath _)). - intros X Y. use eq_mor_hset_struct. use setquotunivprop' ; [ intro ; apply setproperty | ]. intros xy. induction xy as [ x y ]. induction x as [ x | ], y as [ y | ] ; cbn. + apply idpath. + apply idpath. + apply idpath. + apply idpath. - use eq_mor_hset_struct. intro x. induction x as [ | ] ; cbn. + apply idpath. + apply idpath. Qed. Definition lifting_linear_category : linear_category. Proof. use make_linear_category. - exact lifting_linear_category_data. - exact lifting_linear_category_laws. Defined. UniMath-20231010/UniMath/Semantics/LinearLogic/LinearCategory.v000066400000000000000000000365271451125700300241060ustar00rootroot00000000000000(**************************************************************************** Linear categories In this file, we define linear categories. Note that the thirteen laws in [linear_category_laws] are written out explicitly. In the "other accessors" (part 3 below), each of the laws enters a mathematical structure, so as to validate its purpose. Contents 1. Data of linear categories 2. Laws of linear categories 3. Other accessors for linear categories ****************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Examples.ConstantFunctor. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.DiagonalFunctor. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. (** 1. Data of linear categories *) Definition linear_category_data : UU := ∑ (𝕃 : sym_mon_closed_cat) (bang : sym_monoidal_cmd 𝕃), (∏ (x : 𝕃), bang x --> bang x ⊗ bang x) × (∏ (x : 𝕃), bang x --> I_{𝕃}). Definition make_linear_category_data (𝕃 : sym_mon_closed_cat) (bang : sym_monoidal_cmd 𝕃) (δ : ∏ (x : 𝕃), bang x --> bang x ⊗ bang x) (ε : ∏ (x : 𝕃), bang x --> I_{𝕃}) : linear_category_data := 𝕃 ,, bang ,, δ ,, ε. Coercion linear_category_data_to_sym_mon_closed_cat (𝕃 : linear_category_data) : sym_mon_closed_cat := pr1 𝕃. Definition linear_category_bang (𝕃 : linear_category_data) : sym_monoidal_cmd 𝕃 := pr12 𝕃. Definition linear_category_bang_functor (𝕃 : linear_category_data) : lax_monoidal_functor 𝕃 𝕃 := _ ,, lax_monoidal_from_symmetric_monoidal_comonad _ (linear_category_bang 𝕃). Definition linear_category_comult (𝕃 : linear_category_data) (x : 𝕃) : linear_category_bang 𝕃 x --> linear_category_bang 𝕃 x ⊗ linear_category_bang 𝕃 x := pr122 𝕃 x. Definition linear_category_counit (𝕃 : linear_category_data) (x : 𝕃) : linear_category_bang 𝕃 x --> I_{𝕃} := pr222 𝕃 x. (** 2. Laws of linear categories *) Definition linear_category_laws (𝕃 : linear_category_data) : UU := (* naturality of comultiplication *) (∏ (x y : 𝕃) (f : x --> y), #(linear_category_bang 𝕃) f · linear_category_comult 𝕃 y = linear_category_comult 𝕃 x · (#(linear_category_bang 𝕃) f #⊗ #(linear_category_bang 𝕃) f)) × (* naturality of counit *) (∏ (x y : 𝕃) (f : x --> y), #(linear_category_bang 𝕃) f · linear_category_counit 𝕃 y = linear_category_counit 𝕃 x) × (* the comultiplication is a coalgebra morphism *) (∏ (x : 𝕃), linear_category_comult 𝕃 x · (δ (linear_category_bang 𝕃) x #⊗ δ (linear_category_bang 𝕃) x) · mon_functor_tensor (linear_category_bang_functor 𝕃) _ _ = δ (linear_category_bang 𝕃) x · #(linear_category_bang 𝕃) (linear_category_comult 𝕃 x)) × (* the counit is a coalgebra morphism *) (∏ (x : 𝕃), linear_category_counit 𝕃 x · mon_functor_unit (linear_category_bang_functor 𝕃) = δ (linear_category_bang 𝕃) x · #(linear_category_bang 𝕃) (linear_category_counit 𝕃 x)) × (* the comultiplication of the comonad is a comonoid morphism (counit) *) (∏ (x : 𝕃), δ (linear_category_bang 𝕃) x · linear_category_counit 𝕃 (linear_category_bang 𝕃 x) = linear_category_counit 𝕃 x) × (* the comultiplication of the comonad is a comonoid morphism (comultiplication) *) (∏ (x : 𝕃), δ (linear_category_bang 𝕃) x · linear_category_comult 𝕃 (linear_category_bang 𝕃 x) = linear_category_comult 𝕃 x · (δ (linear_category_bang 𝕃) x #⊗ δ (linear_category_bang 𝕃) x)) × (* coassociativity *) (∏ (x : 𝕃), linear_category_comult 𝕃 x · (identity _ #⊗ linear_category_comult 𝕃 x) = linear_category_comult 𝕃 x · (linear_category_comult 𝕃 x #⊗ identity _) · mon_lassociator _ _ _) × (* counitality *) (∏ (x : 𝕃), linear_category_comult 𝕃 x · (linear_category_counit 𝕃 x #⊗ identity _) · mon_lunitor _ = identity _) × (* cocommutativity *) (∏ (x : 𝕃), linear_category_comult 𝕃 x · sym_mon_braiding 𝕃 _ _ = linear_category_comult 𝕃 x) × (* comult preserves tensor *) (∏ x y : 𝕃, mon_functor_tensor (linear_category_bang_functor 𝕃) x y · linear_category_comult 𝕃 (x ⊗ y) = (linear_category_comult 𝕃 x) #⊗ (linear_category_comult 𝕃 y) · (inner_swap 𝕃 (linear_category_bang 𝕃 x) (linear_category_bang 𝕃 x) (linear_category_bang 𝕃 y) (linear_category_bang 𝕃 y) · mon_functor_tensor (linear_category_bang_functor 𝕃) x y #⊗ mon_functor_tensor (linear_category_bang_functor 𝕃) x y)) × (* comult preserves unit *) (mon_functor_unit (linear_category_bang_functor 𝕃) · linear_category_comult 𝕃 I_{𝕃} = mon_linvunitor I_{𝕃} · mon_functor_unit (linear_category_bang_functor 𝕃) #⊗ mon_functor_unit (linear_category_bang_functor 𝕃)) × (* counit preserves tensor *) (∏ x y : 𝕃, mon_functor_tensor (linear_category_bang_functor 𝕃) x y · linear_category_counit 𝕃 (x ⊗ y) = linear_category_counit 𝕃 x #⊗ linear_category_counit 𝕃 y · mon_lunitor (monoidal_unit 𝕃)) × (* counit preserves unit *) (mon_functor_unit (linear_category_bang_functor 𝕃) · linear_category_counit 𝕃 I_{𝕃} = identity I_{𝕃}). Definition linear_category : UU := ∑ (𝕃 : linear_category_data), linear_category_laws 𝕃. Definition make_linear_category (𝕃 : linear_category_data) (H : linear_category_laws 𝕃) : linear_category := 𝕃 ,, H. Coercion linear_category_to_data (𝕃 : linear_category) : linear_category_data := pr1 𝕃. Section AccessorsLaws. Context {𝕃 : linear_category}. Proposition linear_category_comult_nat {x y : 𝕃} (f : x --> y) : #(linear_category_bang 𝕃) f · linear_category_comult 𝕃 y = linear_category_comult 𝕃 x · (#(linear_category_bang 𝕃) f #⊗ #(linear_category_bang 𝕃) f). Proof. exact (pr12 𝕃 x y f). Qed. Proposition linear_category_counit_nat {x y : 𝕃} (f : x --> y) : #(linear_category_bang 𝕃) f · linear_category_counit 𝕃 y = linear_category_counit 𝕃 x. Proof. exact (pr122 𝕃 x y f). Qed. Proposition linear_category_comult_coalgebra_mor (x : 𝕃) : linear_category_comult 𝕃 x · (δ (linear_category_bang 𝕃) x #⊗ δ (linear_category_bang 𝕃) x) · mon_functor_tensor (linear_category_bang_functor 𝕃) _ _ = δ (linear_category_bang 𝕃) x · #(linear_category_bang 𝕃) (linear_category_comult 𝕃 x). Proof. exact (pr1 (pr222 𝕃) x). Qed. Proposition linear_category_counit_coalgebra_mor (x : 𝕃) : linear_category_counit 𝕃 x · mon_functor_unit (linear_category_bang_functor 𝕃) = δ (linear_category_bang 𝕃) x · #(linear_category_bang 𝕃) (linear_category_counit 𝕃 x). Proof. exact (pr12 (pr222 𝕃) x). Qed. Proposition linear_category_counit_comonoid_mor_counit (x : 𝕃) : δ (linear_category_bang 𝕃) x · linear_category_counit 𝕃 (linear_category_bang 𝕃 x) = linear_category_counit 𝕃 x. Proof. exact (pr122 (pr222 𝕃) x). Qed. Proposition linear_category_counit_comonoid_mor_comult (x : 𝕃) : δ (linear_category_bang 𝕃) x · linear_category_comult 𝕃 (linear_category_bang 𝕃 x) = linear_category_comult 𝕃 x · (δ (linear_category_bang 𝕃) x #⊗ δ (linear_category_bang 𝕃) x). Proof. exact (pr1 (pr222 (pr222 𝕃)) x). Qed. Proposition linear_category_coassoc (x : 𝕃) : linear_category_comult 𝕃 x · (identity _ #⊗ linear_category_comult 𝕃 x) = linear_category_comult 𝕃 x · (linear_category_comult 𝕃 x #⊗ identity _) · mon_lassociator _ _ _. Proof. exact (pr12 (pr222 (pr222 𝕃)) x). Qed. Proposition linear_category_counitality (x : 𝕃) : linear_category_comult 𝕃 x · (linear_category_counit 𝕃 x #⊗ identity _) · mon_lunitor _ = identity _. Proof. exact (pr122 (pr222 (pr222 𝕃)) x). Qed. Proposition linear_category_cocommutative (x : 𝕃) : linear_category_comult 𝕃 x · sym_mon_braiding 𝕃 _ _ = linear_category_comult 𝕃 x. Proof. exact (pr1 (pr222 (pr222 (pr222 𝕃))) x). Qed. Proposition linear_category_comult_preserves_tensor (x y : 𝕃) : mon_functor_tensor (linear_category_bang_functor 𝕃) x y · linear_category_comult 𝕃 (x ⊗ y) = (linear_category_comult 𝕃 x) #⊗ (linear_category_comult 𝕃 y) · (inner_swap 𝕃 (linear_category_bang 𝕃 x) (linear_category_bang 𝕃 x) (linear_category_bang 𝕃 y) (linear_category_bang 𝕃 y) · mon_functor_tensor (linear_category_bang_functor 𝕃) x y #⊗ mon_functor_tensor (linear_category_bang_functor 𝕃) x y). Proof. exact (pr12 (pr222 (pr222 (pr222 𝕃))) x y). Qed. Proposition linear_category_comult_preserves_unit : mon_functor_unit (linear_category_bang_functor 𝕃) · linear_category_comult 𝕃 I_{𝕃} = mon_linvunitor I_{𝕃} · mon_functor_unit (linear_category_bang_functor 𝕃) #⊗ mon_functor_unit (linear_category_bang_functor 𝕃). Proof. exact (pr122 (pr222 (pr222 (pr222 𝕃)))). Qed. Proposition linear_category_counit_preserves_tensor (x y : 𝕃) : mon_functor_tensor (linear_category_bang_functor 𝕃) x y · linear_category_counit 𝕃 (x ⊗ y) = linear_category_counit 𝕃 x #⊗ linear_category_counit 𝕃 y · mon_lunitor (monoidal_unit 𝕃). Proof. exact (pr1 (pr222 (pr222 (pr222 (pr222 𝕃)))) x y). Qed. Proposition linear_category_counit_preserves_unit : mon_functor_unit (linear_category_bang_functor 𝕃) · linear_category_counit 𝕃 I_{𝕃} = identity I_{𝕃}. Proof. exact (pr2 (pr222 (pr222 (pr222 (pr222 𝕃))))). Qed. End AccessorsLaws. (** 3. Other accessors for linear categories *) Definition linear_category_cocommutative_comonoid (𝕃 : linear_category) (x : 𝕃) : commutative_comonoid 𝕃. Proof. use make_commutative_comonoid. - exact (linear_category_bang 𝕃 x). - exact (linear_category_comult 𝕃 x). - exact (linear_category_counit 𝕃 x). - exact (linear_category_counitality x). - exact (!(linear_category_coassoc x)). - exact (linear_category_cocommutative x). Defined. Proposition linear_category_counit_comonoid_mor_struct (𝕃 : linear_category) (x : 𝕃) : comonoid_mor_struct 𝕃 (linear_category_cocommutative_comonoid 𝕃 x) (linear_category_cocommutative_comonoid 𝕃 (linear_category_cocommutative_comonoid 𝕃 x)) (δ (linear_category_bang 𝕃) x). Proof. use make_is_comonoid_mor ; cbn. - exact (!(linear_category_counit_comonoid_mor_comult x)). - rewrite id_right. exact (!(linear_category_counit_comonoid_mor_counit x)). Qed. Definition linear_category_comult_nat_trans (𝕃 : linear_category) : linear_category_bang 𝕃 ⟹ linear_category_bang 𝕃∙ diag_functor 𝕃. Proof. use make_nat_trans. - exact (λ x, linear_category_comult 𝕃 x). - abstract (intros x y f ; cbn ; apply linear_category_comult_nat). Defined. Definition linear_category_counit_nat_trans (𝕃 : linear_category) : linear_category_bang 𝕃 ⟹ constant_functor _ _ I_{𝕃}. Proof. use make_nat_trans. - exact (λ x, linear_category_counit 𝕃 x). - abstract (intros x y f ; cbn ; rewrite id_right ; apply linear_category_counit_nat). Defined. Definition linear_category_comult_is_mon_nat_trans (𝕃 : linear_category): is_mon_nat_trans (linear_category_bang_functor 𝕃) (comp_fmonoidal_lax (linear_category_bang_functor 𝕃) (diag_functor_fmonoidal_lax 𝕃)) (linear_category_comult_nat_trans 𝕃). Proof. split. - intros x y. apply linear_category_comult_preserves_tensor. - apply linear_category_comult_preserves_unit. Defined. Definition linear_category_counit_is_mon_nat_trans (𝕃 : linear_category): is_mon_nat_trans (linear_category_bang_functor 𝕃) (constant_functor_fmonoidal_lax _ (unit_monoid 𝕃)) (linear_category_counit_nat_trans 𝕃). Proof. split. - intros x y. apply linear_category_counit_preserves_tensor. - apply linear_category_counit_preserves_unit. Qed. Definition linear_category_comult_coalgebra_morphism (𝕃 : linear_category) (x : 𝕃) : CoAlg_category (linear_category_bang 𝕃) ⟦ ((linear_category_bang 𝕃) x) ,, δ (linear_category_bang 𝕃) x, (linear_category_bang 𝕃 x ⊗ linear_category_bang 𝕃 x ,, (δ (linear_category_bang 𝕃) x #⊗ δ (linear_category_bang 𝕃) x) · mon_functor_tensor (linear_category_bang_functor 𝕃) _ _ )⟧. Proof. use tpair. - exact (linear_category_comult 𝕃 x). - abstract (cbn; rewrite assoc; apply pathsinv0, linear_category_comult_coalgebra_mor). Defined. Definition linear_category_counit_coalgebra_morphism (𝕃 : linear_category) (x : 𝕃) : CoAlg_category (linear_category_bang 𝕃) ⟦ ((linear_category_bang 𝕃) x) ,, δ (linear_category_bang 𝕃) x, (I_{𝕃} ,, mon_functor_unit (linear_category_bang_functor 𝕃)) ⟧. Proof. use tpair. - exact (linear_category_counit 𝕃 x). - abstract (apply pathsinv0, linear_category_counit_coalgebra_mor). Defined. UniMath-20231010/UniMath/Semantics/LinearLogic/LinearCategoryEilenbergMooreAdjunction.v000066400000000000000000000077721451125700300307440ustar00rootroot00000000000000(** In this file, the cofree adjunction between a linear category and its Eilenberg-Moore category is constructed. *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Adjunctions. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.categories.CoEilenbergMoore. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.SymmetricMonoidalCoEilenbergMoore. Require Import UniMath.Semantics.LinearLogic.LinearCategory. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Section CofreeAdjunction. Context (𝕃 : linear_category). Definition eilenberg_moore_cofree : 𝕃 ⟶ cat_co_eilenberg_moore (linear_category_bang 𝕃). Proof. use functor_to_co_eilenberg_moore_cat. - apply (linear_category_bang 𝕃). - use nat_trans_comp. 2: { apply nat_trans_functor_id_left. } exact (δ (linear_category_bang 𝕃)). - abstract ( intro x; refine (_ @ Comonad_law1 (T := linear_category_bang 𝕃) x); refine (assoc' _ _ _ @ _); apply id_left). - abstract ( intro x; cbn; rewrite id_left; exact (Comonad_law3 (T := linear_category_bang 𝕃) x)). Defined. Local Definition eilenberg_moore_forget : cat_co_eilenberg_moore (linear_category_bang 𝕃) ⟶ 𝕃. Proof. exact (functor_composite (pr1_category _) (pr1_category _)). Defined. Local Definition eilenberg_moore_adj_unit : functor_identity (cat_co_eilenberg_moore (linear_category_bang 𝕃)) ⟹ eilenberg_moore_forget ∙ eilenberg_moore_cofree. Proof. use make_nat_trans. - intro x. use make_mor_co_eilenberg_moore. + exact (pr21 x). + abstract ( refine (! pr22 x @ _); apply maponpaths, pathsinv0, id_left). - abstract ( intros x y f; use eq_mor_co_eilenberg_moore; exact (! pr21 f)). Defined. Lemma eilenberg_moore_cmd_form_adj : form_adjunction' (eilenberg_moore_forget,, eilenberg_moore_cofree,, eilenberg_moore_adj_unit,, ε (linear_category_bang 𝕃)). Proof. split. - exact (λ x, pr12 x). - intro x. use eq_mor_co_eilenberg_moore. cbn. refine (assoc' _ _ _ @ _). refine (id_left _ @ _). exact (Comonad_law2 (T := linear_category_bang 𝕃) x). Qed. Definition eilenberg_moore_cmd_adj : adjunction (cat_co_eilenberg_moore (linear_category_bang 𝕃)) 𝕃. Proof. use make_adjunction. - simple refine (_ ,, _ ,, _ ,, _). + exact eilenberg_moore_forget. + exact eilenberg_moore_cofree. + exact eilenberg_moore_adj_unit. + exact (ε (linear_category_bang 𝕃)). - exact eilenberg_moore_cmd_form_adj. Defined. End CofreeAdjunction. UniMath-20231010/UniMath/Semantics/LinearLogic/LinearNonLinear.v000066400000000000000000000074071451125700300242110ustar00rootroot00000000000000(**************************************************************************** Linear-non-linear models of linear logic In this file, we define the notion of linear-non-linear models, which is one of the basic notions of models for linear logic. See for example - "Categorical Semantics of Linear Logic" - "A Mixed Linear Non-Linear Logic: Proofs, Terms, and Models" - "Categorical Models of Linear Logic Revisited" We also give a symmetric monoidal comonad arising from these models, which gives an interpretation to the !-modality. Contents 1. Linear-non-linear models 2. Accessors and builders 3. !-modality ****************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Adjunctions. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Import MonoidalNotations. Local Open Scope cat. (** 1. Linear-non-linear models *) Definition linear_non_linear_model : UU := ∑ (𝕃 : sym_mon_closed_cat) (* \bL *) (𝕄 : sym_monoidal_cat) (* \bM *) (A : adjunction 𝕄 𝕃), is_cartesian 𝕄 × sym_monoidal_adjunction 𝕄 𝕃 A. (** 2. Accessors and builders *) Coercion linear_non_linear_model_to_linear (𝕃 : linear_non_linear_model) : sym_mon_closed_cat := pr1 𝕃. Definition cartesian_cat_from_linear_non_linear_model (𝕃 : linear_non_linear_model) : sym_monoidal_cat := pr12 𝕃. Definition adjunction_from_linear_non_linear_model (𝕃 : linear_non_linear_model) : adjunction (cartesian_cat_from_linear_non_linear_model 𝕃) 𝕃 := pr122 𝕃. Proposition is_cartesian_cat_from_linear_non_linear_model (𝕃 : linear_non_linear_model) : is_cartesian (cartesian_cat_from_linear_non_linear_model 𝕃). Proof. exact (pr1 (pr222 𝕃)). Qed. Definition sym_monoidal_adjunction_from_linear_non_linear_model (𝕃 : linear_non_linear_model) : sym_monoidal_adjunction (cartesian_cat_from_linear_non_linear_model 𝕃) 𝕃 (adjunction_from_linear_non_linear_model 𝕃) := pr2 (pr222 𝕃). Definition make_linear_non_linear (𝕃 : sym_mon_closed_cat) (𝕄 : sym_monoidal_cat) (A : adjunction 𝕄 𝕃) (HM : is_cartesian 𝕄) (HA : sym_monoidal_adjunction 𝕄 𝕃 A) : linear_non_linear_model := 𝕃 ,, 𝕄 ,, A ,, HM ,, HA. Definition make_linear_non_linear_from_strong (𝕃 : sym_mon_closed_cat) (𝕄 : sym_monoidal_cat) (A : adjunction 𝕄 𝕃) (HM : is_cartesian 𝕄) (HL₁ : fmonoidal 𝕄 𝕃 (left_adjoint A)) (HL₂ : is_symmetric_monoidal_functor 𝕄 𝕃 HL₁) : linear_non_linear_model. Proof. use make_linear_non_linear. - exact 𝕃. - exact 𝕄. - exact A. - exact HM. - use sym_monoidal_adjunction_from_strong. + exact HL₁. + exact HL₂. Defined. (** 3. !-modality *) Definition bang_modality (𝕃 : linear_non_linear_model) : sym_monoidal_cmd 𝕃 := sym_monoidal_adjunction_to_sym_monoidal_cmd (adjunction_from_linear_non_linear_model 𝕃) (sym_monoidal_adjunction_from_linear_non_linear_model 𝕃). UniMath-20231010/UniMath/Semantics/LinearLogic/LinearToLinearNonLinear.v000066400000000000000000000442531451125700300256470ustar00rootroot00000000000000(** In this file, we show how any linear category induces a linear/non-linear model. This boils down to proving that the Eilenberg-Moore category of the (symmetric monoidal) comonad, given by a linear category, is cartesian monoidal. *) Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Adjunctions. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Structure.SymmetricDiagonal. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.categories.Dialgebras. Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.MonoidalCartesianBuilder. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.TransportComonoidAlongRetraction. Require Import UniMath.CategoryTheory.categories.CoEilenbergMoore. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalDialgebras. Require Import UniMath.CategoryTheory.Monoidal.Examples.SymmetricMonoidalCoEilenbergMoore. Require Import UniMath.Semantics.LinearLogic.LinearCategory. Require Import UniMath.Semantics.LinearLogic.LinearCategoryEilenbergMooreAdjunction. Require Import UniMath.Semantics.LinearLogic.LinearNonLinear. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Import ComonoidNotations. Section LiftingPropertyCoalgebraMorSection. Lemma postcomp_with_section_reflect_coalg_mor (𝕃 : linear_category) (xx aa bb : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) (i : aa --> bb) (f : 𝕃⟦pr11 xx, pr11 aa⟧) (f_i_coalg : pr21 xx · #(linear_category_bang 𝕃) (f · pr11 i) = (f · pr11 i) · pr21 bb) (r : 𝕃⟦pr11 bb, pr11 aa⟧) (ir_id : is_retraction (pr11 i) r) : pr21 xx · #(linear_category_bang 𝕃) f = f · pr21 aa. Proof. pose (p := cancel_postcomposition _ _ (#(linear_category_bang 𝕃) r) f_i_coalg). rewrite assoc' in p. rewrite <- functor_comp in p. rewrite assoc' in p. refine (_ @ p @ _). - do 2 apply maponpaths. refine (! id_right _ @ _). apply maponpaths. apply pathsinv0, ir_id. - rewrite ! assoc'. apply maponpaths. rewrite assoc. etrans. { apply maponpaths_2. exact (! pr21 i). } rewrite assoc'. rewrite <- functor_comp. refine (_ @ id_right _). apply maponpaths. refine (_ @ functor_id (linear_category_bang 𝕃) _). apply maponpaths. exact ir_id. Qed. Definition lifting_is_coalg_mor {𝕃 : linear_category} {xx aa bb : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)} {g : xx --> bb} {i : aa --> bb} {f : 𝕃⟦pr11 xx, pr11 aa⟧} {r : 𝕃⟦pr11 bb, pr11 aa⟧} (ir_id : is_retraction (pr11 i) r) (p : f · pr11 i = pr11 g) : pr21 xx · #(linear_category_bang 𝕃) f = f · pr21 aa. Proof. use (postcomp_with_section_reflect_coalg_mor 𝕃 xx aa bb i f _ r ir_id). etrans. { do 2 apply maponpaths. exact p. } etrans. 2: { apply maponpaths_2. exact (! p). } exact (pr21 g). Qed. End LiftingPropertyCoalgebraMorSection. Section TransportationFreeCoalgebraComonoid. Context (𝕃 : linear_category). Let bang : sym_monoidal_cmd 𝕃 := linear_category_bang 𝕃. Context (xx : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)). Let x : 𝕃 := pr11 xx. Let hx : 𝕃⟦x, bang x⟧ := pr21 xx. Let comonoid_on_bang_x := linear_category_cocommutative_comonoid 𝕃 x. Lemma linear_category_comult_factors_through_comult_bang : δ (linear_category_bang 𝕃) x · (linear_category_comult 𝕃 (bang x) · ε bang (bang x) #⊗ ε bang (bang x)) = linear_category_comult 𝕃 x. Proof. rewrite assoc. etrans. { apply maponpaths_2. apply linear_category_counit_comonoid_mor_comult. } rewrite assoc'. rewrite <- tensor_comp_mor. refine (_ @ id_right _). apply maponpaths. rewrite <- tensor_id_id. use two_arg_paths ; apply Comonad_law1. Qed. Local Lemma transport_comonoid_from_free_lem : hx · δ_{comonoid_on_bang_x} · ε bang x #⊗ ε bang x · hx #⊗ hx = hx · δ_{comonoid_on_bang_x}. Proof. cbn. etrans. { rewrite assoc'. apply maponpaths. rewrite <- tensor_comp_mor. apply maponpaths. apply pathsinv0. apply (pr2 (disp_ε _) _ _ hx). } etrans. { apply maponpaths. apply maponpaths_2. apply pathsinv0. apply (pr2 (disp_ε _) _ _ hx). } rewrite tensor_comp_mor. rewrite assoc. etrans. { apply maponpaths_2. rewrite assoc'. apply maponpaths. apply pathsinv0. apply linear_category_comult_nat. } rewrite assoc. etrans. { do 2 apply maponpaths_2. apply pathsinv0, (pr22 xx). } rewrite ! assoc'. apply maponpaths. exact linear_category_comult_factors_through_comult_bang. Qed. Definition transport_comonoid_struct_from_free : disp_cat_of_comonoids 𝕃 x. Proof. use transported_comonoid. - exact comonoid_on_bang_x. - exact hx. - exact (ε (linear_category_bang 𝕃) x). - exact (pr12 xx). - exact transport_comonoid_from_free_lem. Defined. Definition transport_comonoid_from_free : comonoid 𝕃. Proof. exists x. exact transport_comonoid_struct_from_free. Defined. End TransportationFreeCoalgebraComonoid. Section MakeComonoidInEilenbergMooreFromComonoidInLinear. Context (𝕃 : linear_category). Context (m : comonoid 𝕃). Let bang := linear_category_bang 𝕃. Context (x_b : 𝕃⟦m, bang m⟧) (x_b_u : x_b · ε bang m = identity (pr1 m)) (x_b_m : x_b · δ bang (pr1 m) = x_b · #bang x_b) (mx_t : x_b · #bang δ_{ m} = δ_{ m} · (x_b #⊗ x_b · mon_functor_tensor (_ ,, lax_monoidal_from_symmetric_monoidal_comonad 𝕃 bang) m m)) (mx_u : x_b · #bang ε_{ m} = ε_{ m} · mon_functor_unit (_ ,, lax_monoidal_from_symmetric_monoidal_comonad 𝕃 bang)). Definition make_comonoid_object_in_eilenberg_moore : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃). Proof. use make_ob_co_eilenberg_moore. - apply m. - exact x_b. - exact x_b_u. - exact x_b_m. Defined. Definition make_comonoid_struct_data_in_eilenberg_moore : disp_cat_of_comonoids_data (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) make_comonoid_object_in_eilenberg_moore. Proof. use tpair. - use make_mor_co_eilenberg_moore. + exact δ_{m}. + abstract ( refine (mx_t @ _); apply maponpaths; apply pathsinv0; refine (assoc' _ _ _ @ _); apply id_left). - use make_mor_co_eilenberg_moore. + exact ε_{m}. + abstract ( refine (mx_u @ _); apply maponpaths; apply pathsinv0; apply id_left). Defined. Definition make_comonoid_laws_in_eilenberg_moore : comonoid_laws (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) (make_comonoid_object_in_eilenberg_moore ,, make_comonoid_struct_data_in_eilenberg_moore). Proof. refine (_ ,, _ ,, _) ; use eq_mor_co_eilenberg_moore. - apply comonoid_to_law_unit_left. - apply comonoid_to_law_unit_right. - apply comonoid_to_law_assoc. Qed. Definition make_comonoid_in_eilenberg_moore : comonoid (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)). Proof. exists make_comonoid_object_in_eilenberg_moore. exists make_comonoid_struct_data_in_eilenberg_moore. exact make_comonoid_laws_in_eilenberg_moore. Defined. End MakeComonoidInEilenbergMooreFromComonoidInLinear. Section ConstructionOfComonoidsInEilenbergMoore. Context (𝕃 : linear_category). Let EM := sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃). Let bang : sym_monoidal_cmd 𝕃 := linear_category_bang 𝕃. Context (xx : EM). Let x : 𝕃 := pr11 xx. Let hx : 𝕃⟦x, bang x⟧ := pr21 xx. Lemma comonoid_in_eilenberg_moore_from_coalg_counit_alg_mor : hx · #bang ε_{transport_comonoid_from_free 𝕃 xx} = ε_{transport_comonoid_from_free 𝕃 xx} · mon_functor_unit (_,, lax_monoidal_from_symmetric_monoidal_comonad 𝕃 bang). Proof. cbn. unfold transported_comonoid_counit_data. rewrite functor_comp. rewrite assoc. etrans. { apply maponpaths_2. apply pathsinv0. exact (pr22 xx). } do 2 rewrite assoc'. apply maponpaths. apply pathsinv0. apply linear_category_counit_coalgebra_mor. Qed. Lemma comonoid_in_eilenberg_moore_from_coalg_comult_alg_mor : hx · #bang δ_{transport_comonoid_from_free 𝕃 xx} = δ_{transport_comonoid_from_free 𝕃 xx} · (hx #⊗ hx · mon_functor_tensor (_,,lax_monoidal_from_symmetric_monoidal_comonad 𝕃 (linear_category_bang 𝕃)) x x). Proof. assert (p : pr21 (xx ⊗ xx) = (hx #⊗ hx · mon_functor_tensor (_,,lax_monoidal_from_symmetric_monoidal_comonad 𝕃 (linear_category_bang 𝕃)) x x)). { refine (assoc' _ _ _ @ _). apply id_left. } rewrite <- p. assert (retr : is_retraction (hx #⊗ hx) (ε bang x #⊗ ε bang x)). { refine (! tensor_comp_mor _ _ _ _ @ _ @ tensor_id_id _ _). use two_arg_paths ; apply (pr2 xx). } use (lifting_is_coalg_mor (xx := xx) (aa := xx ⊗ xx) (bb := (eilenberg_moore_cofree 𝕃 x : EM) ⊗ (eilenberg_moore_cofree 𝕃 x : EM)) (g := (hx · linear_category_comult 𝕃 x ,, _) ,, tt) (i := (hx #⊗ hx,, _) ,, tt) (f := δ_{transport_comonoid_from_free 𝕃 xx}) (r := ε bang x #⊗ ε bang x) retr ). - (* (hx · linear_category_comult L x) is a coalgebra morphism, because it is the composition of coalgebra morphisms *) cbn. unfold dialgebra_disp_tensor_op. cbn. rewrite id_left. rewrite ! assoc'. rewrite ! id_left. rewrite functor_comp. rewrite assoc. etrans. { apply maponpaths_2. exact (! pr22 xx). } etrans. 2: { apply maponpaths. apply pathsinv0. exact (assoc _ _ _ @ linear_category_comult_coalgebra_mor x). } apply assoc'. - cbn. unfold dialgebra_disp_tensor_op. cbn. rewrite ! id_left. etrans. { rewrite assoc'. apply maponpaths. apply pathsinv0. apply (tensor_mon_functor_tensor (_ ,, lax_monoidal_from_symmetric_monoidal_comonad _ bang) hx hx). } do 2 rewrite assoc. apply maponpaths_2. refine (! tensor_comp_mor _ _ _ _ @ _ @ tensor_comp_mor _ _ _ _). use two_arg_paths ; exact (! pr22 xx). - apply transport_comonoid_from_free_lem. Qed. Definition comonoid_in_eilenberg_moore_from_coalg : comonoid EM. Proof. use (make_comonoid_in_eilenberg_moore 𝕃). - exact (transport_comonoid_from_free 𝕃 xx). - exact hx. - exact (pr12 xx). - exact (pr22 xx). - exact comonoid_in_eilenberg_moore_from_coalg_comult_alg_mor. - exact comonoid_in_eilenberg_moore_from_coalg_counit_alg_mor. Defined. End ConstructionOfComonoidsInEilenbergMoore. Section EilenbergMooreCartesian. Context (𝕃 : linear_category). (* naturality of the comultiplication and counit *) Lemma comonoid_mor_in_eilenberg_moore {x y : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)} (f : x --> y) : comonoid_mor_struct (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) (comonoid_in_eilenberg_moore_from_coalg 𝕃 x) (comonoid_in_eilenberg_moore_from_coalg 𝕃 y) f. Proof. use make_is_comonoid_mor. - use eq_mor_co_eilenberg_moore. cbn. unfold transported_comonoid_comult_data. cbn. refine (_ @ assoc' _ _ _). etrans. 2: { apply maponpaths_2. rewrite assoc. apply maponpaths_2. exact (pr21 f). } rewrite ! assoc'. apply maponpaths. etrans. 2: { rewrite assoc. apply maponpaths_2. exact (! linear_category_comult_nat (pr11 f)). } rewrite ! assoc'. apply maponpaths. rewrite tensor_mor_right. rewrite tensor_mor_left. etrans. { apply maponpaths. apply pathsinv0. apply tensor_split'. } refine (! tensor_comp_mor _ _ _ _ @ _). refine (_ @ tensor_comp_mor _ _ _ _). use two_arg_paths ; apply (! pr2 (disp_ε _) _ _ (pr11 f)). - use eq_mor_co_eilenberg_moore. refine (_ @ assoc' _ _ _). etrans. 2: { apply maponpaths_2. exact (pr21 f). } rewrite id_right. cbn. unfold transported_comonoid_counit_data. rewrite assoc'. apply maponpaths. exact (! linear_category_counit_nat (pr11 f)). Qed. (* Unfortunately, I'm unable to clean up this lemma. If I do this, I will have to do some manipulation in definition linear_category_eilenberg_moore_cartesian. The purpose of this lemma is to avoid having to prove this property in that definition. *) Local Lemma linear_category_eilenberg_moore_cartesian_lem (x y : sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) : identity (pr11 x ⊗ pr11 y) · (pr21 x #⊗ pr21 y) · fmonoidal_preservestensordata (lax_monoidal_from_symmetric_monoidal_comonad _ (linear_category_bang 𝕃)) (pr11 x) (pr11 y) · linear_category_comult 𝕃 (pr11 x ⊗ pr11 y) · ε (linear_category_bang 𝕃) (pr11 x ⊗ pr11 y) #⊗ ε (linear_category_bang 𝕃) (pr11 x ⊗ pr11 y) = rightwhiskering_on_morphisms (pr1 𝕃) (pr11 y) _ _ (pr21 x · linear_category_comult 𝕃 (pr11 x) · ε (linear_category_bang 𝕃) (pr11 x) #⊗ ε (linear_category_bang 𝕃) (pr11 x)) · leftwhiskering_on_morphisms (pr1 𝕃) (pr11 x ⊗ pr11 x) _ _ (pr21 y · linear_category_comult 𝕃 (pr11 y) · ε (linear_category_bang 𝕃) (pr11 y) #⊗ ε (linear_category_bang 𝕃) (pr11 y)) · pr11 (inner_swap (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) x x y y). Proof. Opaque inner_swap. rewrite ! tensor_mor_right. rewrite ! tensor_mor_left. unfold dialgebra_disp_tensor_op. cbn. rewrite id_left. etrans. 2: { apply maponpaths_2. apply tensor_split'. } etrans. 2: { apply maponpaths_2. apply pathsinv0, tensor_comp_mor. } etrans. 2: { do 2 apply maponpaths_2. apply pathsinv0, tensor_comp_mor. } rewrite ! assoc'. apply maponpaths. etrans. 2: { apply maponpaths. apply naturality_inner_swap. } etrans. 2: { do 2 apply maponpaths. etrans. 2: { apply maponpaths. refine (_ @ id_right _). apply (symmetric_monoidal_comonad_extra_laws _ (linear_category_bang 𝕃)). } apply maponpaths_2. refine (_ @ id_right _). apply (symmetric_monoidal_comonad_extra_laws _ (linear_category_bang 𝕃)). } rewrite ! tensor_comp_mor. rewrite ! assoc. apply maponpaths_2. refine (linear_category_comult_preserves_tensor (pr11 x) (pr11 y) @ _). apply assoc. Qed. Definition linear_category_eilenberg_moore_cartesian : is_cartesian (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)). Proof. use symm_monoidal_is_cartesian_from_comonoid. - intro ; apply comonoid_in_eilenberg_moore_from_coalg. - intro ; intros ; apply comonoid_mor_in_eilenberg_moore. - abstract ( use eq_mor_co_eilenberg_moore; refine (assoc' _ _ _ @ _); refine (id_left _ @ _); apply linear_category_counit_preserves_unit). - intros x y. use eq_mor_co_eilenberg_moore. apply linear_category_eilenberg_moore_cartesian_lem. Qed. End EilenbergMooreCartesian. Section LinearToLNL. Context (𝕃 : linear_category). Local Definition em_projection : fmonoidal (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) 𝕃 (left_adjoint (eilenberg_moore_cmd_adj 𝕃)). Proof. use comp_fmonoidal. - apply mon_cat_co_eilenberg_moore_base. - apply projection_fmonoidal. - apply projection_fmonoidal. Defined. Local Lemma em_projection_is_symmetric : is_symmetric_monoidal_functor (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)) 𝕃 em_projection. Proof. intros x y. etrans. { apply maponpaths. apply id_right. } refine (id_right _ @ _). cbn. refine (_ @ id_left _). rewrite id_right. apply pathsinv0. refine (id_left _ @ _). apply id_left. Qed. Definition linear_to_lnl : linear_non_linear_model. Proof. use make_linear_non_linear_from_strong. - exact (linear_category_data_to_sym_mon_closed_cat 𝕃). - exact (sym_monoidal_cat_co_eilenberg_moore (linear_category_bang 𝕃)). - apply eilenberg_moore_cmd_adj. - apply linear_category_eilenberg_moore_cartesian. - exact em_projection. - exact em_projection_is_symmetric. Defined. End LinearToLNL. UniMath-20231010/UniMath/Semantics/LinearLogic/RelationalModel.v000066400000000000000000000634041451125700300242430ustar00rootroot00000000000000(******************************************************************************* The relational model of linear logic In this file, we formalize the relational model of linear logic. To do so, we use Lafont categories. As such, the only thing that we have to verify is that the symmetric monoidal category of relations has cofree commutative comonoids. The proof in this file is based on two sources: - Theorems 4.1 and 4.7 Free Commutative Monoids in Homotopy Type Theory - Section 1.1.4 in Bicategorical Orthogonality Constructions for Linear Logic The idea behind the construction of the cofree commutative comonoid is as follows: 1. In `SET`, we have free commutative monoids. In UniMath, we can construct these as quotients, but they can also be constructed with higher inductive types. 2. `REL` is equivalent to the Kleisli category of the powerset monad on `SET`. 3. We can lift monoids in `SET` to monoids in `REL`. 4. `REL` is self-dual. The main idea behind the third point is that there is a distributive law between the power set monad and the free commutative monoid monad. The proof in this file combines these 4 facts. First we construct the cofree comonoid ([cofree_comonoid_REL]) using the free commutative monoid. Second we show that comonoids in `REL` give rise to monoids in `SET` ([REL_comonoid_to_monoid]). We need this to prove the universal property. This is because for the universal property of the cofree comonoid, we get a comonoid in `REL`, but we can only instantiate the universal property of the free commutative monoid to commutative monoids. This translation is what allows us to use this universal property. Note that we use the power set here: a comonoid over `X` in `REL` gives a monoid in `SET` whose carrier is the power set of `X`. Third we show that monoid homomorphisms in `SET` give rise to comonoid homomorphisms in `REL` ([cofree_comonoid_REL_map]). The universal property of the free commutative monoid gives a monoid homomorphism, but we want a comonoid homomorphism. Fourth we show the converse: comonoid morphisms in `REL` give rise to monoid homomorphisms in `SET` ([comonoid_mor_REL_to_monoid_mor]). This is so that we can instantiate the uniqueness of the universal property. The construction of comonoids in `REL` from monoids in `SET` can be seen as the composition of the following functors. - We have a functor from `Mon(SET) -> Mon(REL)`. It sends a monoid `X` to the powerset of `X`. The reason why this functor exists, is because we have a distributive law between the free monoid monad and the powerset monad. - For every symmetric monoidal category `V` we have an equivalence `Mon(V) ≃ Comon(V^op)`. This follows from the fact that the notion of monoid and comonoid are dual to each other. - From an equivalence `V ≃ V'` we get an equivalence `Comon(V) ≃ Comon(V')`. - We have that `REL ≃ REL^op`, because relations can be reversed. Now we can make the following composition of functors: `Mon(SET) -> Mon(REL) ≃ Comon(REL^op) ≃ Comon(REL)` Contents 1. The cofree comonoid on a set 2. Every comonoid in `REL` gives rise to a monoid in `SET` 3. The universal property of the cofree comonoid in `REL` 4. The relational model of linear logic *******************************************************************************) Require Import UniMath.MoreFoundations.All. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Free_Monoids_and_Groups. Require Import UniMath.CategoryTheory.Core.Prelude. Require Import UniMath.CategoryTheory.categories.Relations. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Comonads. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Functors. Require Import UniMath.CategoryTheory.Monoidal.Adjunctions. Require Import UniMath.CategoryTheory.Monoidal.FunctorCategories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Monoidal.Displayed.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Cartesian. Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Category. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Monoidal. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.Symmetric. Require Import UniMath.CategoryTheory.Monoidal.Comonoids.CommComonoidsCartesian. Require Import UniMath.CategoryTheory.Monoidal.Examples.Relations. Require Import UniMath.Semantics.LinearLogic.LafontCategory. Import MonoidalNotations. Local Open Scope cat. Local Open Scope moncat. Opaque free_abmonoid free_abmonoid_extend free_abmonoid_unit. (** * 1. The cofree comonoid on a set *) Section CofreeComonoid. Context (X : hSet). Let Mmonoid : abmonoid := free_abmonoid X. Let M : hSet := Mmonoid. Let z : M := unel Mmonoid. Let m : M → M → M := λ x y, op x y. Definition cofree_comonoid_REL_comult : REL_sym_mon_closed_cat ⟦ M , (M × M)%set ⟧ := λ x y, (m (pr1 y) (pr2 y) = x)%logic. Definition cofree_comonoid_REL_counit : REL_sym_mon_closed_cat ⟦ M , unitset ⟧ := λ x y, (x = z)%logic. Proposition cofree_comonoid_REL_counit_left : cofree_comonoid_REL_comult · (cofree_comonoid_REL_counit #⊗ identity _) · mon_lunitor _ = identity _. Proof. use funextsec ; intro x. use funextsec ; intro y. use hPropUnivalence. - use factor_through_squash_hProp. intros H. induction H as [ [ [] a ] [ H p ] ] ; cbn in a, p. revert H. use factor_through_squash_hProp. intros H. induction H as [ [ b c ] [ q H ] ] ; cbn in q. revert H. use factor_through_squash_hProp. intros [ [ [] d ] [ [ r₁ r₂ ] [ r₃ r₄ ] ] ]. cbn in r₁, r₂, r₃, r₄ ; cbn. refine (!q @ _ @ p). rewrite <- r₄. rewrite <- r₁. rewrite r₂. apply (lunax Mmonoid). - intros p ; cbn in p. induction p. refine (hinhpr _). refine ((tt ,, x) ,, _). refine (_ ,, idpath _). refine (hinhpr _). refine ((z ,, x) ,, _ ,, _). + apply (lunax Mmonoid). + refine (hinhpr _). refine ((tt ,, x) ,, _) ; cbn. repeat split ; apply idpath. Qed. Proposition cofree_comonoid_REL_coassoc : cofree_comonoid_REL_comult · cofree_comonoid_REL_comult #⊗ identity _ · mon_lassociator _ _ _ = cofree_comonoid_REL_comult · identity _ #⊗ cofree_comonoid_REL_comult. Proof. use funextsec ; intro x. use funextsec ; intro y. induction y as [ y₁ [ y₂ y₃ ]]. use hPropUnivalence. - use factor_through_squash_hProp. intros H. induction H as [ [ [ a₁ a₂ ] a₃ ] [ H [ p₁ [ p₂ p₃ ] ] ] ] ; cbn in p₁, p₂, p₃. revert H. use factor_through_squash_hProp. intros H. induction H as [ [ b₁ b₂ ] [ q H ] ] ; cbn in q. revert H. use factor_through_squash_hProp. intros H. cbn in H. induction H as [ [ [ c₁ c₂ ] c₃ ] [ [ r₁ r₂ ] [ r₃ r₄ ] ] ] ; cbn in r₁, r₂, r₃, r₄. induction p₁, p₂, p₃, r₁, r₄. pose (r₅ := maponpaths dirprod_pr1 r₃) ; cbn in r₅. pose (r₆ := maponpaths dirprod_pr2 r₃) ; cbn in r₆. induction r₅, r₆. rewrite <- r₂ in q. assert (m (m c₁ c₂) b₂ = m c₁ (m c₂ b₂)) as s. { exact (assocax Mmonoid c₁ c₂ b₂). } rewrite s in q. refine (hinhpr _). refine ((c₁ ,, m c₂ b₂) ,, _). split. + exact q. + refine (hinhpr _). exact ((_ ,, _) ,, (idpath _ ,, idpath _) ,, (idpath _ ,, idpath _)). - use factor_through_squash_hProp. intros H. induction H as [ [ a₁ a₂ ] [ p H ]] ; cbn in p. revert H. use factor_through_squash_hProp. intros H. induction H as [ [ b₁ b₂ ] [ [ q₁ q₂ ] [ q₃ q₄ ]]] ; cbn in q₁, q₂, q₃, q₄. induction q₁, q₂, q₃. rewrite <- q₄ in p ; clear q₄. assert (m a₁ (m y₂ y₃) = m (m a₁ y₂) y₃) as s. { exact (!(assocax Mmonoid a₁ y₂ y₃)). } rewrite s in p. refine (hinhpr (((a₁ ,, y₂) ,, y₃) ,, _)). refine (_ ,, idpath _ ,, idpath _ ,, idpath _). refine (hinhpr ((m a₁ y₂ ,, y₃) ,, p ,, _)). refine (hinhpr _) ; cbn. simple refine (((a₁ ,, y₂) ,, y₃) ,, _) ; repeat split. Qed. Proposition cofree_comonoid_REL_comm : cofree_comonoid_REL_comult · sym_mon_braiding REL_sym_mon_closed_cat _ _ = cofree_comonoid_REL_comult. Proof. use funextsec ; intro x. use funextsec ; intro y. induction y as [ y₁ y₂ ]. use hPropUnivalence. - use factor_through_squash_hProp ; cbn. intros [ [ a₁ a₂ ] [ p₁ [ p₂ p₃ ] ] ] ; cbn in p₁, p₂, p₃. induction p₂, p₃. refine (_ @ p₁). apply (commax Mmonoid). - intro p ; cbn in p. refine (hinhpr ((y₂ ,, y₁) ,, _ ,, _ ,, _)) ; cbn. + refine (_ @ p). apply (commax Mmonoid). + apply idpath. + apply idpath. Qed. Definition cofree_comonoid_REL : commutative_comonoid REL_sym_mon_closed_cat. Proof. use make_commutative_comonoid. - exact M. - exact cofree_comonoid_REL_comult. - exact cofree_comonoid_REL_counit. - exact cofree_comonoid_REL_counit_left. - exact cofree_comonoid_REL_coassoc. - exact cofree_comonoid_REL_comm. Defined. End CofreeComonoid. Definition map_to_cofree_comonoid_REL (X : REL) : REL ⟦ cofree_comonoid_REL X , X ⟧ := λ y x, (free_abmonoid_unit x = y)%logic. (** * 2. Every comonoid in `REL` gives rise to a monoid in `SET` *) Section ComonoidToMonoid. Context (C : commutative_comonoid REL_sym_mon_closed_cat). Let U : hSet := underlying_commutative_comonoid _ C. Definition REL_comonoid_to_mult (X Y : U → hProp) (y : U) : hProp := ∃ (x₁ x₂ : U), X x₁ ∧ Y x₂ ∧ comonoid_comult _ C y (x₁ ,, x₂). Definition REL_comonoid_to_unit : U → hProp := λ x, comonoid_counit _ C x tt. Definition REL_comonoid_to_setwithbinop : setwithbinop. Proof. use make_setwithbinop. - exact (funset U hPropset). - exact REL_comonoid_to_mult. Defined. Proposition REL_comonoid_to_assoc : isassoc (pr2 REL_comonoid_to_setwithbinop). Proof. intros X Y Z. use funextsec ; intro y. use hPropUnivalence. - use factor_through_squash_hProp. intros ( a₁ & a₂ & H & p₁ & p₂ ). revert H. use factor_through_squash_hProp. intros ( b₁ & b₂ & q₁ & q₂ & q₃ ). pose (eqweqmaphProp (eqtohomot (eqtohomot (comonoid_to_law_assoc _ C) y) (b₁ ,, (b₂ ,, a₂)))) as H. cbn in H. assert (H' := H (hinhpr ((((b₁ ,, b₂) ,, a₂) ,, hinhpr ((a₁ ,, a₂) ,, p₂ ,, idpath _ ,, q₃) ,, idpath _ ,, idpath _ ,, idpath _)))). revert H'. use factor_through_squash_hProp. intros [ [ c₁ c₂ ] [ r₁ [ r₂ r₃ ] ] ] ; cbn in r₁, r₂, r₃. induction r₂. apply hinhpr. simple refine (c₁ ,, c₂ ,, q₁ ,, _ ,, _). + use hinhpr ; cbn. exact (b₂ ,, a₂ ,, q₂ ,, p₁ ,, r₃). + exact r₁. - use factor_through_squash_hProp. intros ( a₁ & a₂ & p₁ & H & p₂ ). revert H. use factor_through_squash_hProp. intros ( b₁ & b₂ & q₁ & q₂ & q₃ ). pose (eqweqmaphProp (!eqtohomot (eqtohomot (comonoid_to_law_assoc _ C) y) (a₁ ,, (b₁ ,, b₂)))) as H. assert (H' := H (hinhpr ((a₁ ,, a₂) ,, p₂ ,, idpath _ ,, q₃))). revert H'. use factor_through_squash_hProp. intros [ [ [ c₁ c₂ ] c₃ ] [ K [ r₁ [ r₂ r₃ ] ] ] ] ; cbn in r₁, r₂, r₃. revert K. use factor_through_squash_hProp. intros [ [ d₁ d₂ ] [ s₁ [ s₂ s₃ ] ] ] ; cbn in s₁, s₂, s₃. induction r₁, r₂, r₃, s₂. apply hinhpr. simple refine (d₁ ,, d₂ ,, _ ,, q₂ ,, s₁). apply hinhpr ; cbn. simple refine (c₁ ,, c₂ ,, p₁ ,, q₁ ,, _) ; cbn. exact s₃. Qed. Proposition REL_comonoid_to_lunit : islunit (pr2 REL_comonoid_to_setwithbinop) REL_comonoid_to_unit. Proof. intro X. use funextsec ; intro y ; cbn in y. use hPropUnivalence. - use factor_through_squash_hProp. intros ( x₁ & x₂ & p₁ & p₂ & p₃ ). unfold REL_comonoid_to_unit in p₁. assert (y = x₂) as q. { apply (eqweqmaphProp (eqtohomot (eqtohomot (comonoid_to_law_unit_left _ C) y) x₂)). cbn. use hinhpr. refine ((tt ,, x₂) ,, _ ,, idpath _). use hinhpr ; cbn. refine ((x₁ ,, x₂) ,, _) ; cbn. refine (p₃ ,, idpath _ ,, p₁). } rewrite q. exact p₂. - intro Hy. assert (q := eqweqmaphProp (!eqtohomot (eqtohomot (comonoid_to_law_unit_left _ C) y) y) (idpath _)). revert q. use factor_through_squash_hProp. intros [ [ [] a ] [ H p ] ] ; cbn in p. induction p. revert H. use factor_through_squash_hProp. intros [ [ b₁ b₂ ] [ q₁ [ q₂ q₃ ] ] ] ; cbn in q₁, q₂, q₃. induction q₂. use hinhpr. refine (b₁ ,, b₂ ,, _ ,, _ ,, _) ; cbn. + exact q₃. + exact Hy. + exact q₁. Qed. Proposition REL_comonoid_to_comm : iscomm (pr2 REL_comonoid_to_setwithbinop). Proof. intros X Y. use funextsec ; intro y ; cbn in y. use hPropUnivalence. - use factor_through_squash_hProp. intros ( x₁ & x₂ & p₁ & p₂ & H ). use hinhpr. refine (x₂ ,, x₁ ,, p₂ ,, p₁ ,, _). assert (q := eqweqmaphProp (!eqtohomot (eqtohomot (commutative_comonoid_is_commutative _ C) y) (x₁ ,, x₂)) H). revert q. use factor_through_squash_hProp. intros [ [ a₁ a₂ ] [ q₁ [ q₂ q₃ ] ] ] ; cbn in q₁, q₂, q₃. induction q₂, q₃. exact q₁. - use factor_through_squash_hProp. intros ( x₁ & x₂ & p₁ & p₂ & H ). use hinhpr. refine (x₂ ,, x₁ ,, p₂ ,, p₁ ,, _). assert (q := eqweqmaphProp (!eqtohomot (eqtohomot (commutative_comonoid_is_commutative _ C) y) (x₁ ,, x₂)) H). revert q. use factor_through_squash_hProp. intros [ [ a₁ a₂ ] [ q₁ [ q₂ q₃ ] ] ] ; cbn in q₁, q₂, q₃. induction q₂, q₃. exact q₁. Qed. Proposition REL_comonoid_to_runit : isrunit (pr2 REL_comonoid_to_setwithbinop) REL_comonoid_to_unit. Proof. intro X. refine (REL_comonoid_to_comm _ _ @ _). apply REL_comonoid_to_lunit. Qed. Definition REL_comonoid_to_is_unital : isunital (pr2 REL_comonoid_to_setwithbinop). Proof. use make_isunital. - exact REL_comonoid_to_unit. - split. + exact REL_comonoid_to_lunit. + exact REL_comonoid_to_runit. Defined. Definition REL_comonoid_to_is_monoidop : ismonoidop (pr2 REL_comonoid_to_setwithbinop). Proof. use make_ismonoidop. - exact REL_comonoid_to_assoc. - exact REL_comonoid_to_is_unital. Defined. Definition REL_comonoid_to_is_abmonoidop : isabmonoidop (pr2 REL_comonoid_to_setwithbinop). Proof. use make_isabmonoidop. - exact REL_comonoid_to_is_monoidop. - exact REL_comonoid_to_comm. Defined. Definition REL_comonoid_to_monoid : abmonoid. Proof. use make_abmonoid. - exact REL_comonoid_to_setwithbinop. - exact REL_comonoid_to_is_abmonoidop. Defined. End ComonoidToMonoid. (** * 3. The universal property of the cofree comonoid in `REL` *) Section CofreeComonoidUMP. Context (X : REL) (C : commutative_comonoid REL_sym_mon_closed_cat) (f : underlying_commutative_comonoid _ C --> X). Definition cofree_comonoid_REL_underlying : underlying_commutative_comonoid _ C --> underlying_commutative_comonoid _ (cofree_comonoid_REL X) := λ c x, @free_abmonoid_extend X (REL_comonoid_to_monoid C) (λ c x, f x c) x c. Proposition cofree_comonoid_REL_map_comult : comonoid_comult REL_sym_mon_closed_cat C · cofree_comonoid_REL_underlying #⊗ cofree_comonoid_REL_underlying = cofree_comonoid_REL_underlying · comonoid_comult REL_sym_mon_closed_cat (cofree_comonoid_REL X). Proof. use funextsec ; intro y. use funextsec ; intros [ x₁ x₂ ] ; cbn in x₁, x₂. use hPropUnivalence. - use factor_through_squash_hProp. intros [ [ a₁ a₂ ] [ p H ] ]. revert H. use factor_through_squash_hProp. intros [ [ b₁ b₂ ] [ [ q₁ q₂ ] [ q₃ q₄ ] ] ] ; cbn in q₁, q₂, q₃, q₄. induction q₁, q₃. pose (eqweqmaphProp (!(eqtohomot (monoidfunmul (@free_abmonoid_extend X (REL_comonoid_to_monoid C) (λ c x, f x c)) b₁ x₂) y)) (hinhpr (a₁ ,, a₂ ,, q₂ ,, q₄ ,, p))) as q. apply hinhpr. exact (_ ,, q ,, idpath _). - use factor_through_squash_hProp. intros [ a [ p₁ p₂ ]] ; cbn in p₁, p₂. induction p₂. assert (H := eqweqmaphProp (eqtohomot (monoidfunmul (@free_abmonoid_extend X (REL_comonoid_to_monoid C) (λ c x, f x c)) x₁ x₂) y) p₁). revert H. use factor_through_squash_hProp. intros [ a₁ [ a₂ [ q₁ [ q₂ q₃ ] ] ] ] ; cbn in a₁, a₂, q₁, q₂, q₃. refine (hinhpr ((a₁ ,, a₂) ,, q₃ ,, _)). apply hinhpr ; cbn. simple refine ((x₁ ,, a₂) ,, (_ ,, _) ,, (_ ,, _)) ; cbn. + apply idpath. + exact q₁. + apply idpath. + exact q₂. Qed. Proposition cofree_comonoid_REL_map_counit : comonoid_counit REL_sym_mon_closed_cat C = cofree_comonoid_REL_underlying · comonoid_counit REL_sym_mon_closed_cat (cofree_comonoid_REL X). Proof. use funextsec ; intros x₁. use funextsec ; intros x₂. induction x₂. use hPropUnivalence. - intros y. refine (hinhpr (_ ,, _ ,, idpath _)). exact (eqweqmaphProp (!eqtohomot (monoidfununel (@free_abmonoid_extend X (REL_comonoid_to_monoid C) (λ c x, f x c))) x₁) y). - use factor_through_squash_hProp. intros [ a [ p₁ p₂ ]] ; cbn in p₁, p₂, a. apply (eqweqmaphProp (eqtohomot (monoidfununel (@free_abmonoid_extend X (REL_comonoid_to_monoid C) (λ c x, f x c))) x₁)). rewrite <- p₂. exact p₁. Qed. Definition cofree_comonoid_REL_map : C --> cofree_comonoid_REL X. Proof. use make_commutative_comonoid_mor. - exact (cofree_comonoid_REL_underlying). - exact cofree_comonoid_REL_map_comult. - exact cofree_comonoid_REL_map_counit. Defined. Proposition cofree_comonoid_REL_map_comm : f = cofree_comonoid_REL_underlying · map_to_cofree_comonoid_REL X. Proof. use funextsec ; intro x. use funextsec ; intro y. use hPropUnivalence. - intro p. use hinhpr. exact (free_abmonoid_unit y ,, p ,, idpath _). - use factor_through_squash_hProp. intros ( a & H & p ). simpl in a, H, p. rewrite <- p in H. exact H. Qed. Section ToMonoidMor. Context (φ : C --> cofree_comonoid_REL X). Definition comonoid_mor_REL_to_map : free_abmonoid X → REL_comonoid_to_monoid C := λ x y, pr1 φ y x. Proposition ismonoidfun_comonoid_mor_REL_to_map : ismonoidfun comonoid_mor_REL_to_map. Proof. split. - intros y₁ y₂. use funextsec ; intro x. use hPropUnivalence. + intro z. assert (H := eqweqmaphProp (!eqtohomot (eqtohomot (underlying_comonoid_mor_comult φ) x) (y₁ ,, y₂)) (hinhpr (_ ,, z ,, idpath _))). revert H. use factor_through_squash_hProp. intros [ [ a₁ a₂ ] [ p H ] ]. revert H. use factor_through_squash_hProp. intros [ [ b₁ b₂ ] [ [ q₁ q₂ ] [ q₃ q₄ ] ] ] ; cbn in q₁, q₂, q₃, q₄. induction q₁, q₃. apply hinhpr. exact (a₁ ,, a₂ ,, q₂ ,, q₄ ,, p). + use factor_through_squash_hProp. intros ( a₁ & a₂ & p₁ & p₂ & p₃ ). assert (H := eqweqmaphProp (eqtohomot (eqtohomot (underlying_comonoid_mor_comult φ) x) (y₁ ,, y₂)) (hinhpr ((a₁ ,, a₂) ,, p₃ ,, hinhpr ((_ ,, _) ,, (idpath _ ,, p₁) ,, (idpath _ ,, p₂))))). revert H. use factor_through_squash_hProp. cbn. intros [ b [ q₁ q₂ ]]. rewrite <- q₂ in q₁. exact q₁. - use funextsec ; intro x. use hPropUnivalence. + intro z. exact (eqweqmaphProp (!eqtohomot (eqtohomot (underlying_comonoid_mor_counit φ) x) tt) (hinhpr (_ ,, z ,, idpath _))). + intro z ; cbn in z. assert (H := eqweqmaphProp (eqtohomot (eqtohomot (underlying_comonoid_mor_counit φ) x) tt) z). revert H. use factor_through_squash_hProp. intros [ a [ p q ]] ; cbn in q. rewrite q in p. exact p. Qed. Definition comonoid_mor_REL_to_monoid_mor : monoidfun (free_abmonoid X) (REL_comonoid_to_monoid C) := comonoid_mor_REL_to_map ,, ismonoidfun_comonoid_mor_REL_to_map. End ToMonoidMor. Proposition cofree_comonoid_REL_map_unique : isaprop (∑ f', f = # (underlying_commutative_comonoid REL_sym_mon_closed_cat) f' · map_to_cofree_comonoid_REL X). Proof. use invproofirrelevance. intros φ₁ φ₂. use subtypePath. { intro. apply homset_property. } use subtypePath. { intro. apply is_locally_propositional_commutative_comonoid. } enough (comonoid_mor_REL_to_monoid_mor (pr1 φ₁) = comonoid_mor_REL_to_monoid_mor (pr1 φ₂)) as H. { use funextsec ; intro y₁. use funextsec ; intro y₂. use hPropUnivalence. - intro p. exact (eqweqmaphProp (eqtohomot (eqtohomot (maponpaths pr1 H) y₂) y₁) p). - intro p. exact (eqweqmaphProp (!eqtohomot (eqtohomot (maponpaths pr1 H) y₂) y₁) p). } use free_abmonoid_mor_eq. intro x ; cbn. use funextsec ; intro y. use hPropUnivalence. - intros a. unfold comonoid_mor_REL_to_map in a. assert (p := eqweqmaphProp (eqtohomot (eqtohomot (!(pr2 φ₁) @ pr2 φ₂) y) x) (hinhpr (_ ,, a ,, idpath _))). revert p. use factor_through_squash_hProp. cbn ; intros [ b [ p₁ p₂ ] ]. rewrite <- p₂ in p₁. exact p₁. - intros a. unfold comonoid_mor_REL_to_map in a. assert (p := eqweqmaphProp (!eqtohomot (eqtohomot (!(pr2 φ₁) @ pr2 φ₂) y) x) (hinhpr (_ ,, a ,, idpath _))). revert p. use factor_through_squash_hProp. cbn ; intros [ b [ p₁ p₂ ] ]. rewrite <- p₂ in p₁. exact p₁. Qed. Corollary cofree_comonoid_REL_map_contr : iscontr (∑ f' : commutative_comonoid_category REL_sym_mon_closed_cat ⟦ C, cofree_comonoid_REL X ⟧, f = # (underlying_commutative_comonoid REL_sym_mon_closed_cat) f' · map_to_cofree_comonoid_REL X). Proof. use iscontraprop1. - apply cofree_comonoid_REL_map_unique. - simple refine (_ ,, _). + exact cofree_comonoid_REL_map. + exact cofree_comonoid_REL_map_comm. Defined. End CofreeComonoidUMP. (** * 4. The relational model of linear logic *) Definition relational_model : lafont_category. Proof. use make_lafont_category. - exact REL_sym_mon_closed_cat. - use left_adjoint_from_partial. + exact cofree_comonoid_REL. + exact map_to_cofree_comonoid_REL. + exact cofree_comonoid_REL_map_contr. Defined. UniMath-20231010/UniMath/SubstitutionSystems/000077500000000000000000000000001451125700300207605ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/.package/000077500000000000000000000000001451125700300224315ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/.package/files000066400000000000000000000040041451125700300234540ustar00rootroot00000000000000Notation.v Signatures.v BinSumOfSignatures.v SumOfSignatures.v BinProductOfSignatures.v SubstitutionSystems.v SimplifiedHSS/SubstitutionSystems.v SignaturesEquivRelativeStrength.v GeneralizedSubstitutionSystems.v MonadsFromSubstitutionSystems.v SimplifiedHSS/MonadsFromSubstitutionSystems.v GenMendlerIteration.v GenMendlerIteration_alt.v ActionScenarioForGenMendlerIteration_alt.v ApplicationsGenMendlerIteration_alt.v LiftingInitial.v SimplifiedHSS/LiftingInitial.v LiftingInitial_alt.v SimplifiedHSS/LiftingInitial_alt.v ModulesFromSignatures.v SimplifiedHSS/ModulesFromSignatures.v LamSignature.v Lam.v SimplifiedHSS/Lam.v SignatureExamples.v SignatureCategory.v SubstitutionSystems_Summary.v SimplifiedHSS/SubstitutionSystems_Summary.v LamHSET.v SimplifiedHSS/LamHSET.v BindingSigToMonad.v SimplifiedHSS/BindingSigToMonad.v LamFromBindingSig.v SimplifiedHSS/LamFromBindingSig.v MLTT79.v SimplifiedHSS/MLTT79.v FromBindingSigsToMonads_Summary.v SimplifiedHSS/FromBindingSigsToMonads_Summary.v MonadsMultiSorted.v MonadsMultiSorted_alt.v MultiSorted.v MultiSortedMonadConstruction.v SimplifiedHSS/MultiSortedMonadConstruction.v MultiSorted_alt.v MultiSortedMonadConstruction_alt.v SimplifiedHSS/MultiSortedMonadConstruction_alt.v MonadicSubstitution_alt.v SimplifiedHSS/MonadicSubstitution_alt.v STLC.v SimplifiedHSS/STLC.v STLC_alt.v SimplifiedHSS/STLC_alt.v CCS.v SimplifiedHSS/CCS.v CCS_alt.v SimplifiedHSS/CCS_alt.v PCF_alt.v SimplifiedHSS/PCF_alt.v ActionBasedStrengthOnHomsInBicat.v EquivalenceSignaturesWithActegoryMorphisms.v EquivalenceLaxLineatorsHomogeneousCase.v SigmaMonoids.v ConstructionOfGHSS.v BindingSigToMonad_actegorical.v ContinuitySignature/GeneralLemmas.v ContinuitySignature/CommutingOfOmegaLimitsAndCoproducts.v ContinuitySignature/ContinuityOfMultiSortedSigToFunctor.v ContinuitySignature/MultiSortedSignatureFunctorEquivalence.v ContinuitySignature/InstantiateHSET.v MultiSorted_actegorical.v MultiSortedMonadConstruction_actegorical.v MultiSortedMonadConstruction_coind_actegorical.v MultiSortedEmbeddingIndCoindHSET.v UniMath-20231010/UniMath/SubstitutionSystems/ActionBasedStrengthOnHomsInBicat.v000066400000000000000000001161531451125700300274270ustar00rootroot00000000000000(** Constructs instance of action-based strength for the actions of the endomorphisms by precomposition on fixed hom-categories of a bicategory, and from this, a signature. Author: Ralph Matthes 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ConstructionOfActions. Require Import UniMath.Bicategories.MonoidalCategories.ActionOfEndomorphismsInBicat. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorCategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SignatureCategory. Require Import UniMath.CategoryTheory.Core.Univalence. Import Bicat.Notations. Local Open Scope cat. Section ActionBased_Strength_Between_Homs_In_Bicat. Context {C : bicat}. Context (c0 d0 d0': ob C). Context {Mon_M : monoidal_cat}. Local Definition Mon_endo: monoidal_cat := swapping_of_monoidal_cat (monoidal_cat_from_bicat_and_ob c0). Context (U: strong_monoidal_functor Mon_M Mon_endo). Local Definition ab_strength_domain_action : action Mon_M (hom c0 d0') := reindexed_action Mon_M U (action_from_precomp c0 d0'). Local Definition ab_strength_target_action : action Mon_M (hom c0 d0) := reindexed_action Mon_M U (action_from_precomp c0 d0). Context (F: hom c0 d0' ⟶ hom c0 d0). Definition ab_strength_on_homs_in_bicat: UU := actionbased_strength Mon_M ab_strength_domain_action ab_strength_target_action F. Identity Coercion ab_strength_on_homs_in_bicat_to_actionbased_strength : ab_strength_on_homs_in_bicat >-> actionbased_strength. Context (ab_str : ab_strength_on_homs_in_bicat). Definition triangle_eq := actionbased_strength_triangle_eq Mon_M ab_strength_domain_action ab_strength_target_action F ab_str. Definition pentagon_eq := actionbased_strength_pentagon_eq Mon_M ab_strength_domain_action ab_strength_target_action F ab_str. Lemma triangle_eq_readable : triangle_eq = ∏ a : C ⟦ c0, d0' ⟧, ab_str (a,, monoidal_cat_unit Mon_M) • # F (id₂ a ⋆⋆ (strong_monoidal_functor_ϵ_inv U) • lunitor a) = id₂ (F a) ⋆⋆ (strong_monoidal_functor_ϵ_inv U) • lunitor (F a). Proof. apply idpath. Qed. Definition triangle_eq_nice : UU := ∏ X : C ⟦ c0, d0' ⟧, ab_str (X,, monoidal_cat_unit Mon_M) • # F (strong_monoidal_functor_ϵ_inv U ▹ X • lunitor X) = strong_monoidal_functor_ϵ_inv U ▹ F X • lunitor (F X). Lemma triangle_eq_implies_triangle_eq_nice : triangle_eq -> triangle_eq_nice. Proof. intro Heq. intro X. set (HeqX := Heq X). cbn in HeqX. do 2 rewrite hcomp_identity_right in HeqX. assumption. Qed. Lemma triangle_eq_nice_implies_triangle_eq : triangle_eq_nice -> triangle_eq. Proof. intro Heq. intro X. cbn. do 2 rewrite hcomp_identity_right. apply Heq. Qed. Lemma pentagon_eq_readable : pentagon_eq = ∏ (a : C ⟦ c0, d0' ⟧) (x y : Mon_M), (lassociator (U y) (U x) (F a) • id₂ (F a) ⋆⋆ lax_monoidal_functor_μ U (x,, y)) • ab_str (a,, monoidal_cat_tensor Mon_M (x, y)) = ab_str (a,, x) ⋆⋆ # U (id₁ y) • ab_str (U x · a,, y) • # F (lassociator (U y) (U x) a • id₂ a ⋆⋆ lax_monoidal_functor_μ U (x,, y)). Proof. apply idpath. Qed. (** the variables chosen in the following make the link with the notion of signature in the TYPES'15 paper by Ahrens and Matthes more visible - but Z is written insted of (Z,e), and likewise for Z' *) Definition pentagon_eq_nice : UU := ∏ (X : C ⟦ c0, d0' ⟧) (Z' Z : Mon_M), lassociator (U Z) (U Z') (F X) • (lax_monoidal_functor_μ U (Z',, Z) ▹ F X) • ab_str (X,, monoidal_cat_tensor Mon_M (Z', Z)) = U Z ◃ ab_str (X,, Z') • ab_str (U Z' · X,, Z) • # F (lassociator (U Z) (U Z') X • (lax_monoidal_functor_μ U (Z',, Z) ▹ X)). Lemma pentagon_eq_implies_pentagon_eq_nice : pentagon_eq -> pentagon_eq_nice. Proof. intros Heq X Z' Z. assert (Heqinst := Heq X Z' Z). clear Heq. revert Heqinst. simpl. rewrite (functor_id U). intro Heqinst. refine (!_ @ Heqinst @ _). - cbn. apply maponpaths_2. apply maponpaths. exact (hcomp_identity_right _ _ (F X) (lax_monoidal_functor_μ U (Z',, Z))). - etrans. { do 2 apply maponpaths_2. apply hcomp_identity_left. } cbn. do 3 apply maponpaths. apply hcomp_identity_right. Qed. Lemma pentagon_eq_nice_implies_pentagon_eq : pentagon_eq_nice -> pentagon_eq. Proof. intros Heq X Z' Z. simpl. rewrite (functor_id U). refine (_ @ Heq _ _ _ @ _). - cbn. apply maponpaths_2. apply maponpaths. apply hcomp_identity_right. - refine (!_). etrans. { do 2 apply maponpaths_2. apply hcomp_identity_left. } cbn. do 3 apply maponpaths. apply hcomp_identity_right. Qed. Definition μ_UZ'Zinv (Z' Z : Mon_M) : hom c0 c0 ⟦ monoidal_functor_map_codom Mon_M Mon_endo U (Z',, Z), monoidal_functor_map_dom Mon_M Mon_endo U (Z',, Z) ⟧ := strong_monoidal_functor_μ_inv U (Z',,Z). Definition pentagon_eq_nicer : UU := ∏ (X : C ⟦ c0, d0' ⟧) (Z' Z : Mon_M), lassociator (U Z) (U Z') (F X) • (lax_monoidal_functor_μ U (Z',, Z) ▹ F X) • ab_str (X,, monoidal_cat_tensor Mon_M (Z', Z)) • # F ((μ_UZ'Zinv Z' Z ▹ X) • rassociator (U Z) (U Z') X) = U Z ◃ ab_str (X,, Z') • ab_str (U Z' · X,, Z). Lemma pentagon_eq_nice_implies_pentagon_eq_nicer : pentagon_eq_nice -> pentagon_eq_nicer. Proof. intro Heq'. intros X Z' Z. assert (Heqinst := Heq' X Z' Z). clear Heq'. rewrite Heqinst. clear Heqinst. etrans. 2: { apply id2_right. } rewrite <- vassocr. apply maponpaths. apply pathsinv0. etrans. 2: { apply (functor_comp(C:=hom c0 d0')(C':=hom c0 d0)). } apply pathsinv0. apply (functor_id_id (hom c0 d0') (hom c0 d0)). cbn. rewrite <- vassocr. apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_lassociator _ _ _)). rewrite id2_right. rewrite vassocr. etrans. 2: { apply id2_left. } apply maponpaths_2. rewrite rwhisker_vcomp. etrans. { apply maponpaths. apply (z_iso_inv_after_z_iso (nat_z_iso_pointwise_z_iso (strong_monoidal_functor_μ U) (Z',,Z))). } apply id2_rwhisker. Qed. Lemma pentagon_eq_nicer_implies_pentagon_eq_nice : pentagon_eq_nicer -> pentagon_eq_nice. Proof. intro Heq. intros X Z' Z. specialize (Heq X Z' Z). etrans. 2: { apply maponpaths_2. exact Heq. } clear Heq. repeat rewrite <- vassocr. do 2 apply maponpaths. etrans. { apply pathsinv0. apply id2_right. } apply maponpaths. etrans. 2: { apply (functor_comp(C:=hom c0 d0')(C':=hom c0 d0)). } apply pathsinv0. apply (functor_id_id (hom c0 d0') (hom c0 d0)). refine (vassocr _ _ _ @ _). etrans. { apply maponpaths_2. apply vassocl. } etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply rassociator_lassociator. } apply id2_right. } rewrite rwhisker_vcomp. etrans. { apply maponpaths. apply (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso (strong_monoidal_functor_μ U) (Z',,Z))). } apply id2_rwhisker. Qed. End ActionBased_Strength_Between_Homs_In_Bicat. Section Instantiation_To_FunctorCategory_And_PointedEndofunctors. Section a_different_type_for_the_forgetful_functor_from_ptd. Context (C : category). Definition functor_ptd_forget_alt : category_Ptd C ⟶ category_from_bicat_and_ob(C:=bicat_of_cats) C. Proof. use make_functor. - exists (λ a, pr1 a). exact (λ a b f, pr1 f). - abstract (split; intros; red; intros; apply idpath). Defined. Local Definition aux : monoidal_functor_map (monoidal_cat_of_pointedfunctors _) (monoidal_cat_from_bicat_and_ob(C:=bicat_of_cats) C) functor_ptd_forget_alt. Proof. red. use make_nat_trans. - intro x. cbn. apply nat_trans_id. - abstract ( intros xy xy' fg; apply nat_trans_eq_alt; intro c; cbn; rewrite id_left, id_right; apply idpath ). Defined. Definition forgetful_functor_from_ptd_as_strong_monoidal_functor_alt : strong_monoidal_functor (monoidal_cat_of_pointedfunctors C) (monoidal_cat_from_bicat_and_ob (C:=bicat_of_cats) C). Proof. use tpair. - apply (make_lax_monoidal_functor (monoidal_cat_of_pointedfunctors C) (monoidal_cat_from_bicat_and_ob (C:=bicat_of_cats) C) functor_ptd_forget_alt (nat_trans_id _) aux). + abstract (intros PF1 PF2 PF3 ; apply nat_trans_eq_alt ; intro c ; cbn ; do 2 rewrite functor_id ; repeat rewrite id_right ; apply functor_id). + abstract (intro PF ; split; apply nat_trans_eq_alt; intro c; cbn ; [ do 3 rewrite id_right ; apply pathsinv0 ; apply functor_id | do 3 rewrite id_right ; apply idpath]). - split ; [ apply (nat_trafo_z_iso_if_pointwise_z_iso (homset_property _)); apply is_nat_z_iso_nat_trans_id | red ; intro c ; exists (nat_trans_id _) ; split; cbn ; [ apply nat_trans_eq; [apply homset_property |] ; intro c'; cbn ; apply id_left | apply nat_trans_eq; [apply homset_property |]; intro c'; cbn ; apply id_left ]]. Defined. End a_different_type_for_the_forgetful_functor_from_ptd. Context (C D D' : category). Local Definition forget := swapping_of_strong_monoidal_functor(forgetful_functor_from_ptd_as_strong_monoidal_functor_alt C). (* the following in order to understand why [forgetful_functor_from_ptd_as_strong_monoidal_functor_alt] is needed here *) Local Definition moncat1 : monoidal_cat := swapping_of_monoidal_cat (EndofunctorsMonoidal.monoidal_cat_of_endofunctors C). Local Definition moncat2 := Mon_endo (C:=bicat_of_cats) C. (* Lemma same_precategory : pr1 moncat1 = pr1 moncat2. Proof. UniMath.MoreFoundations.Tactics.show_id_type. unfold moncat1, moncat2. unfold EndofunctorsMonoidal.monoidal_cat_of_endofunctors, Mon_endo. cbn. The unachievable goal is then: [C, C, hs] = category_from_bicat_and_ob (C,, hs) *) Lemma same_precategory_data : pr111 moncat1 = pr111 moncat2. Proof. apply idpath. Qed. Lemma same_tensor_data : pr112 moncat1 = pr112 moncat2. Proof. (* show_id_type. *) unfold moncat1, moncat2. unfold EndofunctorsMonoidal.monoidal_cat_of_endofunctors, Mon_endo. cbn. (* UniMath.MoreFoundations.Tactics.show_id_type. *) use functor_data_eq. - intro x. cbn. (* The goal is then: pr2 x ∙ pr1 = pr2 x ∙ pr1 x *) apply idpath. - intros C1 C2 f. cbn. apply idpath. Qed. (* cannot be typechecked any longer Lemma same_I : pr222 moncat1 = pr222 moncat2. *) Local Definition Mon_endo' : monoidal_cat := swapping_of_monoidal_cat (monoidal_cat_of_pointedfunctors C). Local Definition domain_action : action Mon_endo' (hom(C:=bicat_of_cats) C D') := ab_strength_domain_action(C:=bicat_of_cats) C D' forget. Local Definition target_action : action Mon_endo' (hom(C:=bicat_of_cats) C D) := ab_strength_target_action(C:=bicat_of_cats) C D forget. Section Signature_From_ActionBased_Strength. Section IndividualFunctorsWithABStrength. Context (H : functor [C, D'] [C, D]). Definition ab_strength_for_functors_and_pointed_functors : UU := ab_strength_on_homs_in_bicat(C:=bicat_of_cats) C D D' forget H. Definition ab_strength_for_functors_and_pointed_functors_to_actionbased_strength (ab_str : ab_strength_for_functors_and_pointed_functors) : actionbased_strength (swapping_of_monoidal_cat (monoidal_cat_of_pointedfunctors C)) (ab_strength_domain_action(C:=bicat_of_cats) C D' forget) (ab_strength_target_action(C:=bicat_of_cats) C D forget) H := ab_str. Coercion ab_strength_for_functors_and_pointed_functors_to_actionbased_strength : ab_strength_for_functors_and_pointed_functors >-> actionbased_strength. Context (ab_str : ab_strength_for_functors_and_pointed_functors). (* adapt typing of [pr1 ab_str] for use in [Signature] *) Definition θ_for_signature_nat_trans_data : nat_trans_data (θ_source H) (θ_target H). Proof. intro x. set (result := ab_str x : functor_composite_data (pr12 x) (pr1 (pr1 H (pr1 x))) ⟹ pr1 (pr1 H (functor_compose (pr12 x) (pr1 x)))). (** this typing is crucial for termination of type-checking *) exact result. Defined. Lemma θ_for_signature_is_nat_trans : is_nat_trans (θ_source H) (θ_target H) θ_for_signature_nat_trans_data. Proof. intros x x' f. (* UniMath.MoreFoundations.Tactics.show_id_type. *) apply nat_trans_eq_alt. intro c. cbn. assert (Heq := nat_trans_ax ab_str x x' f). assert (Heqc := nat_trans_eq_weq (homset_property D) _ _ Heq c). clear Heq. cbn in Heqc. unfold θ_for_signature_nat_trans_data. exact Heqc. Qed. Definition θ_for_signature : θ_source H ⟹ θ_target H := (θ_for_signature_nat_trans_data,,θ_for_signature_is_nat_trans). Lemma signature_from_ab_strength_law1 : θ_Strength1_int θ_for_signature. Proof. red. intro X. apply nat_trans_eq_alt. intro c. cbn. assert (HypX := triangle_eq_implies_triangle_eq_nice _ _ _ _ _ _ (ab_strength_triangle _ ab_str) X). assert (Heqc := nat_trans_eq_weq (homset_property D) _ _ HypX c). cbn in Heqc. intermediate_path (# (pr1 (H X)) (id₁ c) · id₁ (pr1(pr1 H X) c)). 2: { etrans. { apply id_right. } apply (functor_id (H X)). } etrans. 2: { exact Heqc. } clear HypX Heqc. apply maponpaths. apply nat_trans_eq_pointwise. clear c. apply maponpaths. apply nat_trans_eq_alt. intro c. cbn. apply pathsinv0. etrans. { apply id_right. } apply functor_id. Qed. Definition test (X : [C, D']) (Z Z' : category_Ptd C) (c : C) : UU. Proof. refine (id₁ _ · # (pr1 (H X)) (id₁ _) · pr1 (ab_str (X,, PointedFunctorsComposition.ptd_compose C Z Z')) c · pr1 (# H _) c = pr1 (θ_for_signature_nat_trans_data (X, Z')) ((pr111 Z) c) · pr1 (θ_for_signature_nat_trans_data (functor_compose (pr1 Z') X, Z)) c). exact (nat_trans_comp (post_whisker (nat_trans_id _) _) (nat_trans_id _)). Defined. Definition test' (X : [C, D']) (Z Z' : category_Ptd C) (c : C) : test X Z Z' c. Proof. unfold test. simpl. assert (HypX := pentagon_eq_nice_implies_pentagon_eq_nicer _ _ _ _ _ _ (pentagon_eq_implies_pentagon_eq_nice _ _ _ _ _ _ (ab_strength_pentagon _ ab_str)) X Z' Z). simpl in HypX. exact (nat_trans_eq_pointwise HypX c). Qed. Lemma signature_from_ab_strength_law2 : θ_Strength2_int θ_for_signature. Proof. intros X Z Z'. apply nat_trans_eq_alt. intro c. etrans. 2: { apply assoc. } etrans. 2: { apply maponpaths. exact (test' X Z Z' c). } simpl. etrans. 2: { apply pathsinv0. apply id_left. } etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply remove_id_left. - etrans. { apply id_left. } apply functor_id. - apply idpath. } simpl. apply maponpaths_12. - apply idpath. - apply nat_trans_eq_pointwise. clear c. apply maponpaths. apply nat_trans_eq_alt. intro c. etrans. 2: { apply pathsinv0. apply id_right. } apply pathsinv0. simpl. apply functor_id. Qed. Definition signature_from_ab_strength : Signature C D D'. Proof. exists H. exists θ_for_signature. split. - exact signature_from_ab_strength_law1. - exact signature_from_ab_strength_law2. Defined. End IndividualFunctorsWithABStrength. Section IndividualStrongFunctors. Context (FF : actionbased_strong_functor Mon_endo' domain_action target_action). Definition signature_from_strong_functor : Signature C D D' := signature_from_ab_strength FF (pr2 FF). End IndividualStrongFunctors. Section Morphisms. Context {FF GG : actionbased_strong_functor Mon_endo' domain_action target_action}. Context (sη : Strong_Functor_Category_Mor Mon_endo' domain_action target_action FF GG). Lemma signature_mor_from_ab_strength_mor_diagram (X : [C, D']) (Y : category_Ptd C) : Signature_category_mor_diagram C D D' (signature_from_strong_functor FF) (signature_from_strong_functor GG) sη X Y. Proof. red. cbn. assert (Hyp := pr2 sη X Y). red in Hyp. cbn in Hyp. etrans. { exact Hyp. } clear Hyp. apply maponpaths_2. apply pathsinv0. apply (horcomp_post_pre _ _ D). Qed. Definition signature_mor_from_ab_strength_mor : SignatureMor C D D' (signature_from_strong_functor FF) (signature_from_strong_functor GG). Proof. exists (pr1 sη). (* better not first cbn and then omission of pr1 - for the sake of efficiency *) exact signature_mor_from_ab_strength_mor_diagram. Defined. End Morphisms. Definition ActionBasedStrongFunctorCategoryToSignatureCategory_data : functor_data (Strong_Functor_category Mon_endo' domain_action target_action) (Signature_category C D D'). Proof. use make_functor_data. - exact signature_from_strong_functor. - intros FF GG sη. exact (signature_mor_from_ab_strength_mor sη). Defined. Lemma ActionBasedStrongFunctorCategoryToSignatureCategory_is_functor : is_functor ActionBasedStrongFunctorCategoryToSignatureCategory_data. Proof. split. - intro FF. apply SignatureMor_eq. apply nat_trans_eq_alt. intro H. apply nat_trans_eq_alt. intro c. apply idpath. - intros FF GG HH sη sη'. apply SignatureMor_eq. apply nat_trans_eq_alt. intro H. apply nat_trans_eq_alt. intro c. apply idpath. Qed. Definition ActionBasedStrongFunctorCategoryToSignatureCategory : functor (Strong_Functor_category Mon_endo' domain_action target_action) (Signature_category C D D') := (_,,ActionBasedStrongFunctorCategoryToSignatureCategory_is_functor). End Signature_From_ActionBased_Strength. Section ActionBased_Strength_From_Signature. Section IndividualSignatures. Context (sig : Signature C D D'). Local Lemma aux0 ( x : [C, D'] ⊠ Mon_endo') : hom(C:=bicat_of_cats) C D ⟦ actionbased_strength_dom Mon_endo' target_action sig x, actionbased_strength_codom Mon_endo' domain_action sig x ⟧ = functor_composite_data (pr12 x) (pr1 (sig (pr1 x))) ⟹ pr1 (sig (pr12 x ∙ pr1 x)). Proof. apply idpath. Defined. Definition θ_for_ab_strength_data : nat_trans_data (actionbased_strength_dom Mon_endo' target_action sig) (actionbased_strength_codom Mon_endo' domain_action sig). Proof. intro x. exact (eqweqmap (!aux0 x) (theta sig x)). Defined. Lemma θ_for_ab_strength_ax : is_nat_trans _ _ θ_for_ab_strength_data. Proof. intros x x' f. apply nat_trans_eq_alt. intro c. assert (Heq := nat_trans_ax (theta sig) x x' f). assert (Heqc := nat_trans_eq_weq (homset_property D) _ _ Heq c). clear Heq. simpl in Heqc. simpl. etrans. { exact Heqc. } clear Heqc. apply idpath. Qed. Definition θ_for_ab_strength : actionbased_strength_nat Mon_endo' domain_action target_action sig. Proof. use make_nat_trans. - exact θ_for_ab_strength_data. - exact θ_for_ab_strength_ax. Defined. (* very slow processing of both steps then verification *) Lemma θ_for_ab_strength_law1 : actionbased_strength_triangle_eq Mon_endo' domain_action target_action sig θ_for_ab_strength. Proof. red. intro X. assert (HypX := Sig_strength_law1 sig X). apply nat_trans_eq_alt. intro c. cbn. etrans. 2: { apply pathsinv0. etrans. { apply id_right. } etrans. { apply id_right. } apply (functor_id (sig X)). } assert (Heqc := nat_trans_eq_weq (homset_property D) _ _ HypX c). clear HypX. cbn in Heqc. etrans. 2: { exact Heqc. } clear Heqc. apply maponpaths. apply nat_trans_eq_pointwise. clear c. apply maponpaths. apply nat_trans_eq_alt. intro c. cbn. do 2 rewrite id_right. apply functor_id. Time Qed. (* 5.172 seconds *) (* slow verification *) Lemma θ_for_ab_strength_law2 : actionbased_strength_pentagon_eq Mon_endo' domain_action target_action sig θ_for_ab_strength. Proof. intros X Z' Z. apply nat_trans_eq_alt. intro c. simpl. assert (HypX := θ_Strength2_int_implies_θ_Strength2_int_nicer _ (Sig_strength_law2 sig) X Z Z'). assert (Heqc := nat_trans_eq_weq (homset_property D) _ _ HypX c). clear HypX. cbn in Heqc. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply id_right. } apply id_left. } etrans. { etrans. { apply maponpaths_2. apply functor_id. } apply id_left. } refine (!_). etrans. { do 2 apply maponpaths_2. etrans. { apply maponpaths_2. etrans. { apply maponpaths. apply functor_id. } apply functor_id. } apply id_left. } refine (!_). refine (Heqc @ _). clear Heqc. etrans. { do 2 apply maponpaths_2. apply id_left. } apply maponpaths. apply nat_trans_eq_pointwise. clear c. apply maponpaths. apply nat_trans_eq_alt. intro c. cbn. rewrite id_right. rewrite id_left. apply pathsinv0. apply functor_id. Time Qed. (* 78.153 secs *) Definition ab_strength_from_signature : ab_strength_for_functors_and_pointed_functors sig. Proof. exists θ_for_ab_strength. split. - exact θ_for_ab_strength_law1. - exact θ_for_ab_strength_law2. Defined. Definition ab_strong_functor_from_signature : actionbased_strong_functor Mon_endo' domain_action target_action := (pr1 sig,,ab_strength_from_signature). End IndividualSignatures. Section Morphisms. Context {sig1 sig2 : Signature C D D'}. Context (f : SignatureMor C D D' sig1 sig2). Lemma ab_strength_mor_from_signature_mor_is_nat_trans : is_nat_trans _ _ (pr11 f). Proof. red. intros F F' g. cbn. assert (Hyp := pr21 f F F' g). exact Hyp. Qed. Definition ab_strength_mor_from_signature_mor_nat_trans : ab_strong_functor_from_signature sig1 ⟹ ab_strong_functor_from_signature sig2. Proof. exists (pr11 f). exact ab_strength_mor_from_signature_mor_is_nat_trans. Defined. Lemma ab_strength_mor_from_signature_mor_diagram (a : hom(C:=bicat_of_cats) C D') (v : Mon_endo') : Strong_Functor_Category_mor_diagram Mon_endo' domain_action target_action (ab_strong_functor_from_signature sig1) (ab_strong_functor_from_signature sig2) ab_strength_mor_from_signature_mor_nat_trans a v. Proof. red. cbn. assert (Hyp := pr2 f a v). red in Hyp. cbn in Hyp. etrans. { exact Hyp. } clear Hyp. apply maponpaths_2. apply (horcomp_post_pre _ _ D). Qed. Definition ab_strength_mor_from_signature_mor : Strong_Functor_Category_Mor Mon_endo' domain_action target_action (ab_strong_functor_from_signature sig1) (ab_strong_functor_from_signature sig2). Proof. exists ab_strength_mor_from_signature_mor_nat_trans. exact ab_strength_mor_from_signature_mor_diagram. Defined. End Morphisms. Definition SignatureCategoryToActionBasedStrongFunctorCategory_data : functor_data (Signature_category C D D') (Strong_Functor_category Mon_endo' domain_action target_action). Proof. use make_functor_data. - intro sig. exact (ab_strong_functor_from_signature sig). - intros sig1 sig2 f. exact (ab_strength_mor_from_signature_mor f). Defined. Lemma SignatureCategoryToActionBasedStrongFunctorCategory_is_functor : is_functor SignatureCategoryToActionBasedStrongFunctorCategory_data. Proof. split. - intro H. apply Strong_Functor_Category_Mor_eq. apply nat_trans_eq_alt. intro X. apply nat_trans_eq_alt. intro c. apply idpath. - intros F G H f g. apply Strong_Functor_Category_Mor_eq. apply nat_trans_eq_alt. intro X. apply nat_trans_eq_alt. intro c. apply idpath. Qed. Definition SignatureCategoryToActionBasedStrongFunctorCategory : functor (Signature_category C D D') (Strong_Functor_category Mon_endo' domain_action target_action) := (_,,SignatureCategoryToActionBasedStrongFunctorCategory_is_functor). End ActionBased_Strength_From_Signature. (* the following lemma cannot be used in the construction of the equivalence of categories *) Lemma roundtrip1_ob_as_equality (sig : Signature C D D') : signature_from_strong_functor (ab_strong_functor_from_signature sig) = sig. Proof. use total2_paths_f. - apply idpath. - cbn. use total2_paths_f. + apply nat_trans_eq_alt. intro x; apply idpath. + apply dirprodeq. * apply isaprop_θ_Strength1_int. * apply isaprop_θ_Strength2_int. Defined. Definition roundtrip1_ob_nat_trans_data : nat_trans_data (functor_identity (Signature_category C D D')) (SignatureCategoryToActionBasedStrongFunctorCategory ∙ ActionBasedStrongFunctorCategoryToSignatureCategory). Proof. intro sig. cbn. use tpair. - use make_nat_trans. + intro X. exact (identity (pr1(pr1 sig) X)). + intros X1 X2 f. etrans. { apply (id_right (# (pr11 sig) f)). } etrans. 2: { apply pathsinv0. apply (id_left (# (pr11 sig) f)). } apply idpath. - intros X Y. red. apply nat_trans_eq_alt. intro c. etrans. { apply id_right. } etrans. 2: { apply cancel_postcomposition. cbn. apply pathsinv0. apply id_left. } etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply (functor_id (pr11 sig X)). } apply pathsinv0. apply id_left. Defined. Definition roundtrip1_ob_nat_trans_data_pointwise_inv (sig : Signature_category C D D') : SignatureMor C D D' (signature_from_strong_functor (ab_strong_functor_from_signature sig)) sig. Proof. use tpair. - use make_nat_trans. + intro X. exact (identity (pr11 sig X)). + intros X1 X2 f. etrans. { apply id_right. } etrans. 2: { apply pathsinv0. apply id_left. } apply idpath. - intros X Y. red. apply nat_trans_eq_alt. intro c. etrans. { apply id_right. } etrans. 2: { apply cancel_postcomposition. cbn. apply pathsinv0. apply id_left. } etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply (functor_id (pr11 sig X)). } apply pathsinv0. apply id_left. Defined. Definition roundtrip1_ob_data_is_nat_z_iso : is_nat_z_iso roundtrip1_ob_nat_trans_data. Proof. intro sig. exists (roundtrip1_ob_nat_trans_data_pointwise_inv sig). abstract (split; apply SignatureMor_eq; apply nat_trans_eq_alt; intro X; cbn; apply (id_left(C:=[C, D]))). Defined. Lemma roundtrip1_ob_data_is_nat_trans : is_nat_trans _ _ roundtrip1_ob_nat_trans_data. Proof. intros sig1 sig2 f. apply SignatureMor_eq. apply nat_trans_eq_alt. intro X. etrans. { cbn. apply (id_right(C:=[C, D])). } etrans. 2: { cbn. apply pathsinv0. apply (id_left(C:=[C, D])). } apply idpath. Qed. Definition roundtrip1_ob_nat_trans : (functor_identity (Signature_category C D D')) ⟹ SignatureCategoryToActionBasedStrongFunctorCategory ∙ ActionBasedStrongFunctorCategoryToSignatureCategory := (roundtrip1_ob_nat_trans_data,,roundtrip1_ob_data_is_nat_trans). (* the following lemma cannot be used in the construction of the equivalence of categories *) Lemma roundtrip2_ob_as_equality (FF : actionbased_strong_functor Mon_endo' domain_action target_action) : ab_strong_functor_from_signature (signature_from_strong_functor FF) = FF. Proof. use total2_paths_f. - apply idpath. - cbn. use total2_paths_f. + apply nat_trans_eq_alt. intro x; apply idpath. + apply dirprodeq. * apply isaprop_actionbased_strength_triangle_eq. * apply isaprop_actionbased_strength_pentagon_eq. Qed. Definition roundtrip2_ob_nat_trans_data : nat_trans_data (ActionBasedStrongFunctorCategoryToSignatureCategory ∙ SignatureCategoryToActionBasedStrongFunctorCategory) (functor_identity (Strong_Functor_category Mon_endo' domain_action target_action)). Proof. intro FF. cbn. use tpair. - use make_nat_trans. + intro X. exact (identity (pr1 (pr1 FF) X)). + intros X1 X2 f. etrans. { apply (id_right (#(pr11 FF) f)). } etrans. 2: { apply pathsinv0. apply (id_left (#(pr11 FF) f)). } apply idpath. - intros X Y. red. apply nat_trans_eq_alt. intro c. etrans. { apply id_right. } etrans. 2: { apply cancel_postcomposition. cbn. apply pathsinv0. apply id_right. } etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply (functor_id (pr11 FF X)). } apply pathsinv0. apply id_left. Defined. Definition roundtrip2_ob_nat_trans_data_pointwise_inv (FF : Strong_Functor_category Mon_endo' domain_action target_action) : Strong_Functor_Category_Mor Mon_endo' domain_action target_action FF (ab_strong_functor_from_signature (signature_from_strong_functor FF)). Proof. use tpair. - use make_nat_trans. + intro X. exact (identity (pr11 FF X)). + intros X1 X2 f. etrans. { apply id_right. } etrans. 2: { apply pathsinv0. apply id_left. } apply idpath. - intros X Y. red. apply nat_trans_eq_alt. intro c. etrans. { apply id_right. } etrans. 2: { apply cancel_postcomposition. cbn. apply pathsinv0. apply id_right. } etrans. 2: { apply cancel_postcomposition. apply pathsinv0. apply (functor_id (pr11 FF X)). } apply pathsinv0. apply id_left. Defined. Definition roundtrip2_ob_data_is_nat_z_iso : is_nat_z_iso roundtrip2_ob_nat_trans_data. Proof. intro FF. exists (roundtrip2_ob_nat_trans_data_pointwise_inv FF). abstract (split; apply Strong_Functor_Category_Mor_eq; apply nat_trans_eq_alt; intro X; cbn; apply (id_left(C:=[C, D]))). Defined. Lemma roundtrip2_ob_data_is_nat_trans : is_nat_trans _ _ roundtrip2_ob_nat_trans_data. Proof. intros FF GG sη. apply Strong_Functor_Category_Mor_eq. apply nat_trans_eq_alt. intro X. etrans. { cbn. apply (id_right(C:=[C, D])). } etrans. 2: { cbn. apply pathsinv0. apply (id_left(C:=[C, D])). } apply idpath. Qed. Definition roundtrip2_ob_nat_trans : ActionBasedStrongFunctorCategoryToSignatureCategory ∙ SignatureCategoryToActionBasedStrongFunctorCategory ⟹ functor_identity (Strong_Functor_category Mon_endo' domain_action target_action) := (roundtrip2_ob_nat_trans_data,,roundtrip2_ob_data_is_nat_trans). Definition EquivalenceSignaturesABStrongFunctors: adj_equivalence_of_cats SignatureCategoryToActionBasedStrongFunctorCategory. Proof. use make_adj_equivalence_of_cats. - exact ActionBasedStrongFunctorCategoryToSignatureCategory. - exact roundtrip1_ob_nat_trans. - exact roundtrip2_ob_nat_trans. - split. + intro sig. apply Strong_Functor_Category_Mor_eq. cbn. apply nat_trans_eq; [ apply (has_homsets_hom_data(C:=bicat_of_cats)) |]. intro X. cbn. apply (id_left(C:=[C, D])). + intro FF. apply SignatureMor_eq. cbn. apply nat_trans_eq; [ apply (has_homsets_hom_data(C:=bicat_of_cats)) |]. intro X. cbn. apply (id_left(C:=[C, D])). - split. + intro sig. apply (_,,roundtrip1_ob_data_is_nat_z_iso sig). + intro FF. apply (_,,roundtrip2_ob_data_is_nat_z_iso FF). Defined. (* source and target category of the functors are deemed to be univalent if parameter category D is *) Definition Signature_category_is_univalent (univD : is_univalent D) : is_univalent (Signature_category C D D'). Proof. set (univalentD := make_univalent_category D univD). exact (is_univalent_Signature_category C univalentD D'). Defined. (** the remainder of this file documents failing efforts - these problems ought to be gone after merging PR #1402 *) (* (* some hopeless efforts *) Lemma Strong_Functor_category_is_univalent (univD : is_univalent D) : is_univalent (Strong_Functor_category Mon_endo' domain_action target_action (functor_category_has_homsets _ _ hsD)). Proof. set (univalentD := make_univalent_category D (make_is_univalent (pr1 univD) hsD)). set (univalentA' := make_univalent_category [C, D, hsD] (make_is_univalent (pr1(is_univalent_functor_category C D (pr1 univD,,hsD))) (functor_category_has_homsets _ _ hsD))). change (is_univalent (Strong_Functor_category Mon_endo' domain_action target_action (homset_property univalentA'))). assert (target_action' := target_action). change (action Mon_endo' (hom(C:=bicat_of_cats) (C,, hs) (univalent_category_to_category univalentD))) in target_action'. (* exact (is_univalent_Strong_Functor_category Mon_endo' [C, D', hsD'] univalentA' domain_action target_action'). *) (* the following lemma can only come from univalence of the involved categories *) Lemma SignatureCategoryAndActionBasedStrongFunctorCategory_z_iso_law : is_inverse_in_precat(C:=bicat_of_cats) (a:=Signature_category (C,,hs) (D,,hsD) (D',,hsD')) (b:=Strong_Functor_category Mon_endo' domain_action target_action (functor_category_has_homsets _ _ hsD)) SignatureCategoryToActionBasedStrongFunctorCategory ActionBasedStrongFunctorCategoryToSignatureCategory. Proof. (* Definition SignatureCategoryAndActionBasedStrongFunctorCategory_z_iso : z_iso(C:=bicat_of_cats) (Signature_category (C,,hs) (D,,hsD) (D',,hsD')) (Strong_Functor_category Mon_endo' domain_action target_action (functor_category_has_homsets _ _ hsD)). Proof. exists SignatureCategoryToActionBasedStrongFunctorCategory. exists ActionBasedStrongFunctorCategoryToSignatureCategory. exact SignatureCategoryAndActionBasedStrongFunctorCategory_z_iso_law. Defined. *) *) End Instantiation_To_FunctorCategory_And_PointedEndofunctors. (* Section Instantiation_To_FunctorCategory_And_PointedEndofunctors_Univalence. Context (C : category) (D : univalent_category) (D' : category). Definition BothCategoriesUnivalent: is_univalent (Signature_category C D D') × is_univalent (Strong_Functor_category (Mon_endo' C (homset_property C)) (domain_action C (homset_property C) D' (homset_property D')) (target_action C (homset_property C) D (homset_property D)) (functor_category_has_homsets _ _ (homset_property D))). Proof. split. - exact (is_univalent_Signature_category C D D'). - set (univalentA' := make_univalent_category [C, D, homset_property D] (is_univalent_functor_category C D (univalent_category_is_univalent D))). change (is_univalent (Strong_Functor_category (Mon_endo' C (homset_property C)) (domain_action C (homset_property C) D' (homset_property D')) (target_action C (homset_property C) D (homset_property D)) (homset_property univalentA'))). (* for checking purposes: *) assert (target := target_action C (homset_property C) D (homset_property D)). (* the following works but does not help in the sequel: change (action (Mon_endo' C (homset_property C)) (hom(C:=bicat_of_cats) C (univalent_category_to_category D))) in target. *) assert (test1 : pr1 univalentA' = [C, D, homset_property D]). { apply idpath. } clear test1. set (test2 := pr22 univalentA'). cbn in test2. unfold functor_category_has_homsets in test2. set (test3 := pr2 bicat_of_cats C (univalent_category_to_category D)). cbn in test3. unfold isaset_cells_prebicat_of_cats in test3. assert (test4 : test3 = test2). { apply idpath. } (* okay thanks to changes in UniMath/Bicategories/Core/Examples/BicatOfCatsWithoutUnivalence.v and UniMath/CategoryTheory/FunctorCategory.v *) clear test2 test3 test4. (* does not terminate: change (action (Mon_endo' C (homset_property C)) (univalentA')) in target. *) (* assert (Hyp: action (Mon_endo' C (homset_property C)) (hom(C:=bicat_of_cats) C (univalent_category_to_category D)) <-> action (Mon_endo' C (homset_property C)) (univalentA')). { split. intro act. induction act as [odot [ρ [χ [triangle pentagon]]]]. exists odot. exists ρ. (* does not terminate: exists χ. *) } *) set (what_we_want_without_last_argument := is_univalent_Strong_Functor_category (Mon_endo' C (homset_property C)) (hom(C:=bicat_of_cats) C D') univalentA' (domain_action C (homset_property C) D' (homset_property D'))). (* does not terminate set (what_we_want := what_we_want_without_last_argument (target_action C (homset_property C) D (homset_property D))). *) (* exact what_we_want. Defined.*) End Instantiation_To_FunctorCategory_And_PointedEndofunctors_Univalence. *) UniMath-20231010/UniMath/SubstitutionSystems/ActionScenarioForGenMendlerIteration_alt.v000066400000000000000000000243321451125700300312030ustar00rootroot00000000000000(** instantiates the scheme from [GenMendlerIteration_alt] for use in the analysis of recursion schemes involving actegories (hence, with actions of monoidal categories on categories) author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Adamek. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Local Open Scope cat. Import BifunctorNotations. Import ActegoryNotations. Section FixAnActegory. Context {V : category} (Mon_V : monoidal V) {C : category} (IC : Initial C) (CC : Colims_of_shape nat_graph C) (Act : actegory Mon_V C) (v : V). Section FixAFunctor. Context (F : functor C C) (HF : is_omega_cocont F). Let AF : category := FunctorAlg F. Let chnF : chain C := initChain IC F. Let μF_Initial : Initial AF := colimAlgInitial IC HF (CC chnF). Let μF : C := alg_carrier _ (InitialObject μF_Initial). Let α : F μF --> μF := alg_map F (pr1 μF_Initial). Context (y : C) (G : functor C C) (ρ' : G y --> y). Let L : functor C C := leftwhiskering_functor Act v. Context (IL : isInitial C (v ⊗_{Act} (InitialObject IC))) (HL : is_omega_cocont L). Definition SpecialGenMendlerIterationWithActegory (θ' : F ∙ L ⟹ L ∙ G) : ∃! h : v ⊗_{Act} μF --> y, v ⊗^{Act}_{l} α · h = θ' μF · #G h · ρ' := SpecialGenMendlerIteration IC CC F HF y L IL HL G ρ' θ'. End FixAFunctor. Section Const_H_AsFunctor. Context (CP : BinCoproducts C). Context (H : functor C C) (HH : is_omega_cocont H) (c0 : C). Let Const_plus_H (c : C) : functor C C := GeneralizedSubstitutionSystems.Const_plus_H H CP c. Let AF : category := FunctorAlg (Const_plus_H c0). Let chnF : chain C := initChain IC (Const_plus_H c0). Local Lemma HF : is_omega_cocont (Const_plus_H c0). Proof. apply is_omega_cocont_BinCoproduct_of_functors. - apply is_omega_cocont_constant_functor. - exact HH. Qed. Let μF_Initial : Initial AF := colimAlgInitial IC HF (CC chnF). Let μF : C := alg_carrier _ (InitialObject μF_Initial). Let α : Const_plus_H c0 μF --> μF := alg_map (Const_plus_H c0) (pr1 μF_Initial). Let η : constant_functor C C c0 μF --> μF := BinCoproductIn1 (CP _ _) · α. Let τ : H μF --> μF := BinCoproductIn2 (CP _ _) · α. Context (y : C) (θ : lineator_lax Mon_V Act Act H) (ρ : H y --> y) (f : v ⊗_{Act} c0 --> y). Context (IL : isInitial C (v ⊗_{Act} (InitialObject IC))). Let L : functor C C := leftwhiskering_functor Act v. Context (HL : is_omega_cocont L). Definition charprop_SpecialGenMendlerIterationWithActegoryAndStrength (h : C ⟦v ⊗_{Act} μF, y⟧) : UU := v ⊗^{Act}_{l} η · h = f × v ⊗^{Act}_{l} τ · h = θ v μF · #H h · ρ. Lemma isaprop_charprop_SpecialGenMendlerIterationWithActegoryAndStrength (h : C ⟦v ⊗_{Act} μF, y⟧) : isaprop (charprop_SpecialGenMendlerIterationWithActegoryAndStrength h). Proof. apply isapropdirprod; apply C. Qed. Definition singleeq_SpecialGenMendlerIterationWithActegoryAndStrength (h : C ⟦v ⊗_{Act} μF, y⟧) : UU := actegory_bincoprod_antidistributor Mon_V CP Act _ _ _ · v ⊗^{Act}_{l} α · h = BinCoproductArrow (CP _ _) f (θ v μF · #H h · ρ). Context (δ : actegory_bincoprod_distributor Mon_V CP Act). Definition instance_SpecialGenMendlerIterationWithActegory (h : C ⟦v ⊗_{Act} μF, y⟧) : UU := v ⊗^{Act}_{l} α · h = δ v c0 (H μF) · BinCoproductOfArrows _ (CP _ _) (CP _ _) f (θ v μF) · #(Const_plus_H y) h · BinCoproductArrow (CP _ _) (identity y) ρ. Local Lemma charpropequivsingleeq (h : v ⊗_{Act} μF --> y) : charprop_SpecialGenMendlerIterationWithActegoryAndStrength h <-> singleeq_SpecialGenMendlerIterationWithActegoryAndStrength h. Proof. split. - intros [Hchar1 Hchar2]. red. use BinCoproductArrowsEq. + etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans. { apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } etrans. { exact Hchar1. } apply pathsinv0, BinCoproductIn1Commutes. + etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans. { apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Act v)). } etrans. { exact Hchar2. } apply pathsinv0, BinCoproductIn2Commutes. - intro Hsingle. red in Hsingle. split. + apply (maponpaths (fun m => BinCoproductIn1 (CP _ _) · m)) in Hsingle. unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in Hsingle. repeat rewrite assoc in Hsingle. rewrite BinCoproductIn1Commutes in Hsingle. assert (aux := functor_comp (leftwhiskering_functor Act v) (BinCoproductIn1 (CP (constant_functor C C c0 μF) (H μF))) α). cbn in aux. apply (maponpaths (fun m => m · h)) in aux. assert (Hsingle' := aux @ Hsingle). clear Hsingle aux. rewrite BinCoproductIn1Commutes in Hsingle'. exact Hsingle'. + apply (maponpaths (fun m => BinCoproductIn2 (CP _ _) · m)) in Hsingle. unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in Hsingle. repeat rewrite assoc in Hsingle. rewrite BinCoproductIn2Commutes in Hsingle. assert (aux := functor_comp (leftwhiskering_functor Act v) (BinCoproductIn2 (CP (constant_functor C C c0 μF) (H μF))) α). cbn in aux. apply (maponpaths (fun m => m · h)) in aux. assert (Hsingle' := aux @ Hsingle). clear Hsingle aux. rewrite BinCoproductIn2Commutes in Hsingle'. exact Hsingle'. Qed. Local Lemma instanceequivsingle (h : v ⊗_{Act} μF --> y) : instance_SpecialGenMendlerIterationWithActegory h <-> singleeq_SpecialGenMendlerIterationWithActegoryAndStrength h. Proof. split. - intro Hinst. red in Hinst. red. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (_,,bincoprod_functor_lineator_strongly Mon_V CP Act δ v (_,,_))). etrans. { exact Hinst. } repeat rewrite assoc'. apply maponpaths. etrans. { apply maponpaths. apply precompWithBinCoproductArrow. } etrans. { apply precompWithBinCoproductArrow. } apply maponpaths_2. cbn. rewrite id_left. apply id_right. - intro Hsingle. red in Hsingle. red. rewrite assoc' in Hsingle. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly Mon_V CP Act δ v (_,,_))) in Hsingle. etrans. { exact Hsingle. } repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply maponpaths. apply pathsinv0, precompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } apply maponpaths_2. cbn. rewrite id_left. apply pathsinv0, id_right. Qed. Local Definition θ'_data := fun (c : C) => δ v c0 (H c) · BinCoproductOfArrows _ (CP _ _) (CP _ _) f (θ v c). Let δll : lineator Mon_V (ProductActegory.actegory_binprod Mon_V Act Act) Act (bincoproduct_functor CP) := bincoprod_functor_lineator Mon_V CP Act δ. Local Lemma θ'_data_is_nat_trans : is_nat_trans ((Const_plus_H c0) ∙ L) (L ∙ (Const_plus_H y)) θ'_data. Proof. intros c c' g. unfold θ'_data. cbn. etrans. { rewrite assoc. apply cancel_postcomposition. apply (lineator_linnatleft _ _ _ _ δll v (_,,_) (_,,_) (_,,_)). } repeat rewrite assoc'. apply maponpaths. cbn. etrans. { apply BinCoproductOfArrows_comp. } etrans. 2: { apply pathsinv0, BinCoproductOfArrows_comp. } cbn. rewrite (lineator_linnatleft _ _ _ _ θ v). apply maponpaths_2. etrans. { apply cancel_postcomposition. apply (functor_id (leftwhiskering_functor Act v)). } rewrite id_right. apply id_left. Qed. Local Definition θ' : (Const_plus_H c0) ∙ L ⟹ L ∙ (Const_plus_H y) := _,, θ'_data_is_nat_trans. Definition SpecialGenMendlerIterationWithActegoryAndStrength : ∃! h : v ⊗_{Act} μF --> y, charprop_SpecialGenMendlerIterationWithActegoryAndStrength h. Proof. simple refine (iscontrretract _ _ _ (SpecialGenMendlerIterationWithActegory (Const_plus_H c0) HF y (Const_plus_H y) (BinCoproductArrow (CP _ _) (identity y) ρ) IL HL θ')). - intros [h Hyp]. exists h. apply charpropequivsingleeq. apply instanceequivsingle. exact Hyp. - intros [h Hyp]. exists h. apply charpropequivsingleeq in Hyp. apply instanceequivsingle in Hyp. exact Hyp. - intros [h Hyp]. use total2_paths_f. + apply idpath. + apply isaprop_charprop_SpecialGenMendlerIterationWithActegoryAndStrength. Defined. End Const_H_AsFunctor. End FixAnActegory. UniMath-20231010/UniMath/SubstitutionSystems/ApplicationsGenMendlerIteration_alt.v000066400000000000000000000133371451125700300302640ustar00rootroot00000000000000(** proves Theorem 4.7 in Fiore & Saville, List Objects with Algebraic Structures, FSCD'17 also instantiates it to present a variant of Lemma 4.8 in that paper author: Ralph Matthes formulation of Theorem 4.7 inspired by code provided by Ambroise Lafont available at https://github.com/amblafont/Skew-Monoidalcategories 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Adamek. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Import BifunctorNotations. Local Open Scope cat. Local Notation carrier := (alg_carrier _ ). Section A. Context {D C B A : category} (OC : Initial C) (chC : Colims_of_shape nat_graph C) (* (chA : Colims_of_shape nat_graph A) - superfluous assumption in the paper *) {J : C ⟶ A} (OJ : isInitial _ (J (InitialObject OC))) (omegaJ : is_omega_cocont J) {F : bifunctor D C C} (omegaF : ∏ d , is_omega_cocont (leftwhiskering_functor F d)) (G : bifunctor B A A) (* (omegaG : ∏ b , is_omega_cocont (leftwhiskering_functor G b)) - superfluous assumption in the paper *) {K : D ⟶ B} (h : binat_trans (compose_bifunctor_with_functor F J) (compose_functor_with_bifunctor K J G)). Let OA : Initial A := make_Initial _ OJ. Context {a : A} {d : D} (α : A ⟦ (K d) ⊗_{G} a , a ⟧). Let iniChd : chain C := (initChain OC (leftwhiskering_functor F d)). Let μFd : category_FunctorAlg (leftwhiskering_functor F d) := (InitialObject (colimAlgInitial OC (omegaF d) (chC iniChd))). Definition statement_Thm47 : UU := ∃! (β : A ⟦ J (carrier μFd) , a ⟧), h d (carrier μFd) · K d ⊗^{G}_{l} β · α = # J (alg_map (leftwhiskering_functor F d) μFd) · β. Definition Thm47 : statement_Thm47. Proof. red. set (Mendler := GenMendlerIteration OC chC (leftwhiskering_functor F d) (omegaF d) a J OJ omegaJ). transparent assert (ψ : (ψ_source a J ⟹ ψ_target (leftwhiskering_functor F d) a J)). { use make_nat_trans. - intros y f. cbn; red. exact (h d y · (K d) ⊗^{G}_{l} f · α). - intros y y' f. cbn in f. apply funextsec. intro g. cbn in g. red in g. cbn. repeat rewrite assoc. apply cancel_postcomposition. rewrite bifunctor_leftcomp. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (pr12 h). } set (Mendlerinst := Mendler ψ). use tpair. - exists (pr11 Mendlerinst). apply pathsinv0. exact (pr21 Mendlerinst). - intro t. induction t as [β βeq]. assert (Mendlerinst2 := pr2 Mendlerinst (β,,!βeq)). use subtypePath. { intro g. apply A. } apply (maponpaths pr1) in Mendlerinst2. etrans. { exact Mendlerinst2. } apply idpath. Defined. End A. Section B. Context {C : category } (Mon_V : monoidal C) (OC : Initial C) (chC : Colims_of_shape nat_graph C) {F : bifunctor C C C} (omegaF : ∏ c , is_omega_cocont (leftwhiskering_functor F c)) (** Lemma 4.8 in the paper asks for global omega-cocontinuity of [F] *) (p : C). (** we formulate the statement for each [p] individually *) Let J : C ⟶ C := rightwhiskering_functor Mon_V p. Let G : bifunctor C C C := compose_functor_with_bifunctor J (functor_identity C) F. (** the next two lemmas are no longer needed without the continuity requirement on [G] of the theorem *) Local Lemma lwG_is_lwF (c : C) : leftwhiskering_functor G c = leftwhiskering_functor F (c ⊗_{Mon_V} p). Proof. apply functor_eq. { apply C. } apply idpath. Qed. Local Lemma omegaG (c : C) : is_omega_cocont (leftwhiskering_functor G c). Proof. rewrite lwG_is_lwF. apply omegaF. Qed. Context (OJ : isInitial _ (J (InitialObject OC))) (omegaJ : is_omega_cocont J) (h: binat_trans (compose_bifunctor_with_functor F J) (compose_functor_with_bifunctor (functor_identity C) J G)) (** the target functor of [h] is "morally" [compose_functor_with_bifunctor J J F], hence [h] qualifies as strength data for [F], in the sense of p.3 of the paper, however with only naturality in the arguments to [F] and w/o the coherence conditions *) (z c : C) (γ : C ⟦ (z ⊗_{ Mon_V} p) ⊗_{ F} c, c ⟧). Definition statement_Lemma_48 : UU := statement_Thm47 (D:=C)(B:=C)(A:=C) OC chC omegaF (* omegaG *) (K:=functor_identity C) G h (a:=c)(d:=z) γ. Let cc : ColimCocone (initChain OC (leftwhiskering_functor F z)) := chC (initChain OC (leftwhiskering_functor F z)). Local Lemma statement_Lemma_48_ok : statement_Lemma_48 = ∃! β : C ⟦ colim cc ⊗_{ Mon_V} p, c ⟧, h z (colim cc) · (z ⊗_{ Mon_V} p) ⊗^{ F}_{l} β · γ = colim_algebra_mor OC (omegaF z) cc ⊗^{ Mon_V}_{r} p · β. Proof. apply idpath. Qed. Definition Lemma48 : statement_Lemma_48. Proof. red. apply Thm47. - exact OJ. - exact omegaJ. Defined. End B. UniMath-20231010/UniMath/SubstitutionSystems/BinProductOfSignatures.v000066400000000000000000000152751451125700300255640ustar00rootroot00000000000000(** ********************************************************** Contents: - Definition of the binary product of two signatures ([BinProduct_of_Signatures]), in particular proof of strength laws for the product Written by Anders Mörtberg, 2016 (adapted from SumOfSignatures.v) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.exponentials. Section binproduct_of_signatures. Context (C D D' : category) (PD : BinProducts D). Section construction. Local Notation "'PCD'" := (BinProducts_functor_precat C D PD : BinProducts [C, D]). Variables H1 H2 : functor [C, D'] [C, D]. Variable θ1 : θ_source H1 ⟹ θ_target H1. Variable θ2 : θ_source H2 ⟹ θ_target H2. Variable S11 : θ_Strength1 θ1. Variable S12 : θ_Strength2 θ1. Variable S21 : θ_Strength1 θ2. Variable S22 : θ_Strength2 θ2. (** * Definition of the data of the product of two signatures *) Definition H : functor [C, D'] [C, D] := BinProduct_of_functors _ _ PCD H1 H2. Local Definition θ_ob_fun (X : [C, D']) (Z : category_Ptd C) : ∏ c : C, (functor_composite_data (pr1 Z) (BinProduct_of_functors_data C D PD (H1 X) (H2 X))) c --> (BinProduct_of_functors_data C D PD (H1 (functor_composite (pr1 Z) X)) (H2 (functor_composite (pr1 Z) X))) c. Proof. intro c. apply BinProductOfArrows. - exact (pr1 (θ1 (X ⊗ Z)) c). - exact (pr1 (θ2 (X ⊗ Z)) c). Defined. Local Lemma is_nat_trans_θ_ob_fun (X : [C, D']) (Z : category_Ptd C): is_nat_trans _ _ (θ_ob_fun X Z). Proof. intros x x' f. eapply pathscomp0; [ apply BinProductOfArrows_comp | ]. eapply pathscomp0; [ | eapply pathsinv0; apply BinProductOfArrows_comp]. apply maponpaths_12. * apply (nat_trans_ax (θ1 (X ⊗ Z))). * apply (nat_trans_ax (θ2 (X ⊗ Z))). Qed. Definition θ_ob : ∏ XZ, θ_source H XZ --> θ_target H XZ. Proof. intro XZ. exists (θ_ob_fun (pr1 XZ) (pr2 XZ)). apply is_nat_trans_θ_ob_fun. Defined. Local Lemma is_nat_trans_θ_ob : is_nat_trans (θ_source H) (θ_target H) θ_ob. Proof. intros [X Z] [X' Z'] [α β]. apply nat_trans_eq_alt; intro c; simpl. eapply pathscomp0; [ | eapply pathsinv0, BinProductOfArrows_comp]. eapply pathscomp0; [ apply cancel_postcomposition, BinProductOfArrows_comp |]. eapply pathscomp0; [ apply BinProductOfArrows_comp |]. apply maponpaths_12. + exact (nat_trans_eq_pointwise (nat_trans_ax θ1 _ _ (α,,β)) c). + exact (nat_trans_eq_pointwise (nat_trans_ax θ2 _ _ (α,,β)) c). Qed. Local Definition θ : θ_source H ⟹ θ_target H. Proof. exists θ_ob. apply is_nat_trans_θ_ob. Defined. (** * Proof of the laws of the product of two signatures *) Lemma ProductStrength1 : θ_Strength1 θ. Proof. intro X. apply nat_trans_eq_alt; intro x. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0, BinProduct_endo_is_identity. + rewrite BinProductOfArrowsPr1. eapply pathscomp0; [ | apply id_right]. apply maponpaths, (nat_trans_eq_pointwise (S11 X) x). + rewrite BinProductOfArrowsPr2. eapply pathscomp0; [ | apply id_right]. apply maponpaths, (nat_trans_eq_pointwise (S21 X) x). Qed. Lemma ProductStrength2 : θ_Strength2 θ. Proof. intros X Z Z' Y α. apply nat_trans_eq_alt; intro x. eapply pathscomp0; [ apply BinProductOfArrows_comp |]. apply pathsinv0. eapply pathscomp0; [ apply cancel_postcomposition; simpl; apply BinProductOfArrows_comp|]. eapply pathscomp0; [ apply BinProductOfArrows_comp|]. apply pathsinv0, maponpaths_12. - assert (Ha := S12 X Z Z' Y α); simpl in Ha. apply (nat_trans_eq_pointwise Ha x). - assert (Ha := S22 X Z Z' Y α); simpl in Ha. apply (nat_trans_eq_pointwise Ha x). Qed. Variable S11' : θ_Strength1_int θ1. Variable S12' : θ_Strength2_int θ1. Variable S21' : θ_Strength1_int θ2. Variable S22' : θ_Strength2_int θ2. Lemma ProductStrength1' : θ_Strength1_int θ. Proof. clear S11 S12 S21 S22 S12' S22'; intro X. apply nat_trans_eq_alt; intro x. eapply pathscomp0; [ apply BinProductOfArrows_comp |]. apply pathsinv0, BinProduct_endo_is_identity. + rewrite BinProductOfArrowsPr1. eapply pathscomp0; [ | apply id_right]; apply maponpaths. exact (nat_trans_eq_pointwise (S11' X) x). + rewrite BinProductOfArrowsPr2. eapply pathscomp0; [ | apply id_right]; apply maponpaths. exact (nat_trans_eq_pointwise (S21' X) x). Qed. Lemma ProductStrength2' : θ_Strength2_int θ. Proof. clear S11 S12 S21 S22 S11' S21'; intros X Z Z'. apply nat_trans_eq_alt; intro x; simpl. rewrite id_left. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0. eapply pathscomp0; [apply BinProductOfArrows_comp|]. apply pathsinv0, maponpaths_12. - assert (Ha_x := nat_trans_eq_pointwise (S12' X Z Z') x). simpl in Ha_x; rewrite id_left in Ha_x. exact Ha_x. - assert (Ha_x := nat_trans_eq_pointwise (S22' X Z Z') x). simpl in Ha_x; rewrite id_left in Ha_x. exact Ha_x. Qed. End construction. (** Binary product of signatures *) Definition BinProduct_of_Signatures (S1 S2 : Signature C D D') : Signature C D D'. Proof. (* destruct S1 as [H1 [θ1 [S11' S12']]]. *) (* destruct S2 as [H2 [θ2 [S21' S22']]]. *) exists (H (pr1 S1) (pr1 S2)). exists (θ (pr1 S1) (pr1 S2) (pr1 (pr2 S1)) (pr1 (pr2 S2))). split. + apply ProductStrength1'; [apply (pr1 (pr2 (pr2 S1))) | apply (pr1 (pr2 (pr2 S2)))]. + apply ProductStrength2'; [apply (pr2 (pr2 (pr2 S1))) | apply (pr2 (pr2 (pr2 S2)))]. Defined. Lemma is_omega_cocont_BinProduct_of_Signatures (S1 S2 : Signature C D D') (h1 : is_omega_cocont S1) (h2 : is_omega_cocont S2) (PC: BinProducts D') (hE : ∏ x, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C D PD) x)) : is_omega_cocont (BinProduct_of_Signatures S1 S2). Proof. apply is_omega_cocont_BinProduct_of_functors; try assumption. apply (BinProducts_functor_precat _ _ PC). Defined. End binproduct_of_signatures. UniMath-20231010/UniMath/SubstitutionSystems/BinSumOfSignatures.v000066400000000000000000000163051451125700300247030ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents: - Definition of the sum of two signatures ([BinSum_of_Signatures]), in particular proof of strength laws for the sum ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.limits.binproducts. Local Open Scope cat. Section binsum_of_signatures. Variable C : category. Variable D : category. Variable D' : category. Variable CD : BinCoproducts D. Section construction. Local Notation "'CCD'" := (BinCoproducts_functor_precat C D CD : BinCoproducts [C, D]). Variables H1 H2 : functor [C, D'] [C, D]. Variable θ1 : θ_source H1 ⟹ θ_target H1. Variable θ2 : θ_source H2 ⟹ θ_target H2. Variable S11 : θ_Strength1 θ1. Variable S12 : θ_Strength2 θ1. Variable S21 : θ_Strength1 θ2. Variable S22 : θ_Strength2 θ2. (** * Definition of the data of the sum of two signatures *) Definition H : functor [C, D'] [C, D] := BinCoproduct_of_functors _ _ CCD H1 H2. (* This becomes too slow: *) (* Definition H : functor [C, C, hs] [C, C, hs] := BinCoproduct_of_functors_alt CCC H1 H2. *) Local Definition θ_ob_fun (X : [C, D']) (Z : category_Ptd C) : ∏ c : C, (functor_composite_data (pr1 Z) (BinCoproduct_of_functors C D CD (H1 X) (H2 X))) c --> (BinCoproduct_of_functors C D CD (H1 (functor_composite (pr1 Z) X)) (H2 (functor_composite (pr1 Z) X))) c. Proof. intro c. apply BinCoproductOfArrows. - exact (pr1 (θ1 (X ⊗ Z)) c). - exact (pr1 (θ2 (X ⊗ Z)) c). Defined. Local Lemma is_nat_trans_θ_ob_fun (X : [C, D']) (Z : category_Ptd C): is_nat_trans _ _ (θ_ob_fun X Z). Proof. intros x x' f. etrans; [ apply BinCoproductOfArrows_comp | ]. etrans; [ | eapply pathsinv0; apply BinCoproductOfArrows_comp]. apply maponpaths_12. * apply (nat_trans_ax (θ1 (X ⊗ Z))). * apply (nat_trans_ax (θ2 (X ⊗ Z))). Qed. Definition θ_ob : ∏ XF, θ_source H XF --> θ_target H XF. Proof. intros [X Z]. exists (θ_ob_fun X Z). apply is_nat_trans_θ_ob_fun. Defined. Local Lemma is_nat_trans_θ_ob : is_nat_trans (θ_source H) (θ_target H) θ_ob. Proof. intros XZ X'Z' αβ. assert (Hyp1:= nat_trans_ax θ1 _ _ αβ). assert (Hyp2:= nat_trans_ax θ2 _ _ αβ). apply nat_trans_eq. - apply homset_property. - intro c; simpl. destruct XZ as [X Z]. destruct X'Z' as [X' Z']. destruct αβ as [α β]. simpl in *. (* on the right-hand side, there is a second but unfolded BinCoproductOfArrows in the row - likewise a first such on the left-hand side, to be treater further below *) etrans; [ | eapply pathsinv0; apply BinCoproductOfArrows_comp]. etrans. { apply cancel_postcomposition. apply BinCoproductOfArrows_comp. } etrans. { apply BinCoproductOfArrows_comp. } apply maponpaths_12. + apply (nat_trans_eq_pointwise Hyp1 c). + apply (nat_trans_eq_pointwise Hyp2 c). Qed. Local Definition θ : θ_source H ⟹ θ_target H. Proof. exists θ_ob. apply is_nat_trans_θ_ob. Defined. (** * Proof of the laws of the sum of two signatures *) Lemma SumStrength1 : θ_Strength1 θ. Proof. intro X. apply nat_trans_eq_alt. intro x; simpl. etrans; [ apply BinCoproductOfArrows_comp |]. apply pathsinv0, BinCoproduct_endo_is_identity. + rewrite BinCoproductOfArrowsIn1. unfold θ_Strength1 in S11. assert (Ha := nat_trans_eq_pointwise (S11 X) x). eapply pathscomp0; [ | apply id_left]. apply cancel_postcomposition. apply Ha. + rewrite BinCoproductOfArrowsIn2. unfold θ_Strength1 in S21. assert (Ha := nat_trans_eq_pointwise (S21 X) x). eapply pathscomp0; [ | apply id_left]. apply cancel_postcomposition. apply Ha. Qed. Lemma SumStrength2 : θ_Strength2 θ. Proof. intros X Z Z' Y α. apply nat_trans_eq_alt; intro x. etrans; [ apply BinCoproductOfArrows_comp |]. apply pathsinv0. etrans. { apply cancel_postcomposition. simpl. apply BinCoproductOfArrows_comp. } etrans; [apply BinCoproductOfArrows_comp |]. apply pathsinv0. apply maponpaths_12. - assert (Ha:=S12 X Z Z' Y α). simpl in Ha. assert (Ha_x := nat_trans_eq_pointwise Ha x). apply Ha_x. - assert (Ha:=S22 X Z Z' Y α). simpl in Ha. assert (Ha_x := nat_trans_eq_pointwise Ha x). apply Ha_x. Qed. Variable S11' : θ_Strength1_int θ1. Variable S12' : θ_Strength2_int θ1. Variable S21' : θ_Strength1_int θ2. Variable S22' : θ_Strength2_int θ2. Lemma SumStrength1' : θ_Strength1_int θ. Proof. clear S11 S12 S21 S22 S12' S22'; intro X. apply nat_trans_eq_alt; intro x. etrans; [ apply BinCoproductOfArrows_comp |]. apply pathsinv0, BinCoproduct_endo_is_identity. + rewrite BinCoproductOfArrowsIn1. assert (Ha := nat_trans_eq_pointwise (S11' X) x). simpl in Ha. etrans; [ | apply id_left]. apply cancel_postcomposition. apply Ha. + rewrite BinCoproductOfArrowsIn2. assert (Ha := nat_trans_eq_pointwise (S21' X) x). simpl in Ha. etrans; [ | apply id_left]. apply cancel_postcomposition. apply Ha. Qed. Lemma SumStrength2' : θ_Strength2_int θ. Proof. clear S11 S12 S21 S22 S11' S21'; intros X Z Z'. apply nat_trans_eq_alt; intro x; simpl; rewrite id_left. etrans; [ apply BinCoproductOfArrows_comp |]. apply pathsinv0. etrans; [ apply BinCoproductOfArrows_comp |]. apply pathsinv0. apply maponpaths_12. - assert (Ha:=S12' X Z Z'). simpl in Ha. assert (Ha_x := nat_trans_eq_pointwise Ha x). simpl in Ha_x. rewrite id_left in Ha_x. apply Ha_x. - assert (Ha:=S22' X Z Z'). simpl in Ha. assert (Ha_x := nat_trans_eq_pointwise Ha x). simpl in Ha_x. rewrite id_left in Ha_x. apply Ha_x. Qed. End construction. Definition BinSum_of_Signatures (S1 S2 : Signature C D D') : Signature C D D'. Proof. destruct S1 as [H1 [θ1 [S11' S12']]]. destruct S2 as [H2 [θ2 [S21' S22']]]. exists (H H1 H2). exists (θ H1 H2 θ1 θ2). split. + apply SumStrength1'; assumption. + apply SumStrength2'; assumption. Defined. Lemma is_omega_cocont_BinSum_of_Signatures (S1 S2 : Signature C D D') (h1 : is_omega_cocont S1) (h2 : is_omega_cocont S2) : is_omega_cocont (BinSum_of_Signatures S1 S2). Proof. apply is_omega_cocont_BinCoproduct_of_functors; assumption. Defined. End binsum_of_signatures. UniMath-20231010/UniMath/SubstitutionSystems/BindingSigToMonad.v000066400000000000000000000275061451125700300244600ustar00rootroot00000000000000(** Definition of binding signatures ([BindingSig]) and translation from from binding signatures to monads ([BindingSigToMonad]). This is defined in multiple steps: - Binding signature to a signature with strength ([BindingSigToSignature]) - Construction of initial algebra for a signature with strength ([SignatureInitialAlgebra]) - Signature with strength and initial algebra to a HSS ([SignatureToHSS]) - Construction of a monad from a HSS ([Monad_from_hss] in MonadsFromSubstitutionSystems.v) - Composition of these maps to get a function from binding signatures to monads ([BindingSigToMonad]) Written by: Anders Mörtberg, 2016 - *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Notation "[ C , D ]" := (functor_category C D). Local Notation "'chain'" := (diagram nat_graph). (** * Definition of binding signatures *) Section BindingSig. (** A binding signature is a collection of lists of natural numbers indexed by types I *) Definition BindingSig : UU := ∑ (I : UU) (h : isaset I), I → list nat. Definition BindingSigIndex : BindingSig -> UU := pr1. Definition BindingSigIsaset (s : BindingSig) : isaset (BindingSigIndex s) := pr1 (pr2 s). Definition BindingSigMap (s : BindingSig) : BindingSigIndex s -> list nat := pr2 (pr2 s). Definition make_BindingSig {I : UU} (h : isaset I) (f : I -> list nat) : BindingSig := (I,,h,,f). (** Sum of binding signatures *) Definition SumBindingSig : BindingSig -> BindingSig -> BindingSig. Proof. intros s1 s2. use tpair. - apply (BindingSigIndex s1 ⨿ BindingSigIndex s2). - use tpair. + apply (isasetcoprod _ _ (BindingSigIsaset s1) (BindingSigIsaset s2)). + induction 1 as [i|i]; [ apply (BindingSigMap s1 i) | apply (BindingSigMap s2 i) ]. Defined. End BindingSig. (** * Translation from a binding signature to a monad << S : BindingSig |-> functor(S) : functor [C,C] [C,C] |-> Initial (Id + functor(S)) |-> I := Initial (HSS(func(S), θ) |-> M := Monad_from_HSS(I) >> *) Section BindingSigToMonad. Context {C : category}. Local Notation "'[C,C]'" := (functor_category C C). (** Form "_ o option^n" and return Id if n = 0 *) Definition precomp_option_iter (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : functor [C,C] [C,C]. Proof. induction n as [|n IHn]. - apply functor_identity. - apply (pre_composition_functor _ _ _ (iter_functor1 _ (option_functor BCC TC) n)). Defined. Lemma is_omega_cocont_precomp_option_iter (BCC : BinCoproducts C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (n : nat) : is_omega_cocont (precomp_option_iter BCC TC n). Proof. destruct n; simpl. - apply is_omega_cocont_functor_identity. - apply is_omega_cocont_pre_composition_functor, CLC. Defined. Definition precomp_option_iter_Signature (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : Signature C C C. Proof. use tpair. - exact (precomp_option_iter BCC TC n). - destruct n; simpl. + apply θ_functor_identity. + exact (pr2 (θ_from_δ_Signature C _ (DL_iter_functor1 C (option_functor BCC TC) (option_DistributiveLaw C TC BCC) n))). Defined. (* will not be used, is just a confirmation of proper construction *) Local Lemma functor_in_precomp_option_iter_Signature_ok (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : Signature_Functor (precomp_option_iter_Signature BCC TC n) = precomp_option_iter BCC TC n. Proof. apply idpath. Qed. (* From here on all constructions need these hypotheses *) Context (BPC : BinProducts C) (BCC : BinCoproducts C). (** [nat] to a Signature *) Definition Arity_to_Signature (TC : Terminal C) (xs : list nat) : Signature C C C:= foldr1 (BinProduct_of_Signatures _ _ _ BPC) (ConstConstSignature C C C (TerminalObject TC)) (map (precomp_option_iter_Signature BCC TC) xs). Let BPC2 BPC := BinProducts_functor_precat C C BPC. Let constprod_functor1 := constprod_functor1 (BPC2 BPC). (** The H assumption follows directly if [C,C] has exponentials *) Lemma is_omega_cocont_Arity_to_Signature (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (H : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (xs : list nat) : is_omega_cocont (Arity_to_Signature TC xs). Proof. destruct xs as [[|n] xs]. - destruct xs; apply is_omega_cocont_constant_functor. - induction n as [|n IHn]. + destruct xs as [m []]; simpl. unfold Arity_to_Signature. apply is_omega_cocont_precomp_option_iter, CLC. + destruct xs as [m [k xs]]. apply is_omega_cocont_BinProduct_of_Signatures. * apply is_omega_cocont_precomp_option_iter, CLC. * apply (IHn (k,,xs)). * assumption. * intro x; apply (H x). Defined. (** ** Binding signature to a signature with strength *) Definition BindingSigToSignature (TC : Terminal C) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Signature C C C. Proof. apply (Sum_of_Signatures (BindingSigIndex sig)). - apply CC. - intro i; apply (Arity_to_Signature TC (BindingSigMap sig i)). Defined. Lemma is_omega_cocont_BindingSigToSignature (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : is_omega_cocont (BindingSigToSignature TC sig CC). Proof. unfold BindingSigToSignature. apply is_omega_cocont_Sum_of_Signatures. now intro i; apply is_omega_cocont_Arity_to_Signature, HF. Defined. Let Id_H := Id_H C BCC. (** ** Construction of initial algebra for a signature with strength *) Definition SignatureInitialAlgebra (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply (Initial_functor_precat _ _ IC). - apply (is_omega_cocont_Id_H _ _ _ Hs). - apply ColimsFunctorCategory_of_shape, CLC. Defined. (** ** Construction of datatype specified by a binding signature *) Definition DatatypeOfBindingSig (IC : Initial C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Initial (FunctorAlg (Id_H (Presignature_Signature(BindingSigToSignature TC sig CC)))). Proof. apply SignatureInitialAlgebra; trivial. now apply is_omega_cocont_BindingSigToSignature. Defined. Let HSS := @hss_category C BCC. (* Redefine this here so that it uses the arguments above *) Let InitialHSS (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : Initial (HSS H). Proof. apply InitialHSS; assumption. Defined. (** ** Signature with strength and initial algebra to a HSS *) Definition SignatureToHSS (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : HSS H. Proof. now apply InitialHSS; assumption. Defined. (** The above HSS is initial *) Definition SignatureToHSSisInitial (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : isInitial _ (SignatureToHSS IC CLC H Hs). Proof. now unfold SignatureToHSS; destruct InitialHSS. Qed. (* Redefine this here so that it uses the arguments above *) Let Monad_from_hss (H : Signature C C C) : HSS H → Monad C. Proof. exact (Monad_from_hss _ BCC H). Defined. (** ** Function from binding signatures to monads *) Definition BindingSigToMonad (TC : Terminal C) (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Monad C. Proof. use Monad_from_hss. - apply (BindingSigToSignature TC sig CC). - apply (SignatureToHSS IC CLC). apply (is_omega_cocont_BindingSigToSignature TC CLC HF _ _). Defined. End BindingSigToMonad. (** * Specialized versions of some of the above functions for HSET *) Section BindingSigToMonadHSET. (** ** Binding signature to signature with strength for HSET *) Definition BindingSigToSignatureHSET (sig : BindingSig) : Signature HSET HSET HSET. Proof. use BindingSigToSignature. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply TerminalHSET. - apply sig. - apply CoproductsHSET, (BindingSigIsaset sig). Defined. Lemma is_omega_cocont_BindingSigToSignatureHSET (sig : BindingSig) : is_omega_cocont (BindingSigToSignatureHSET sig). Proof. apply is_omega_cocont_Sum_of_Signatures. intro i; apply is_omega_cocont_Arity_to_Signature. + apply ColimsHSET_of_shape. + intros F. apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. Defined. (** ** Construction of initial algebra for a signature with strength for HSET *) Definition SignatureInitialAlgebraHSET (s : Presignature HSET _ _) (Hs : is_omega_cocont s) : Initial (FunctorAlg (Id_H _ BinCoproductsHSET s)). Proof. apply SignatureInitialAlgebra; try assumption. - apply InitialHSET. - apply ColimsHSET_of_shape. Defined. (** ** Binding signature to a monad for HSET *) Definition BindingSigToMonadHSET : BindingSig → Monad HSET. Proof. intros sig; use (BindingSigToMonad _ _ _ _ _ _ sig). - apply BinProductsHSET. - apply BinCoproductsHSET. - apply TerminalHSET. - apply InitialHSET. - apply ColimsHSET_of_shape. - intros F. apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. - apply CoproductsHSET. apply BindingSigIsaset. Defined. End BindingSigToMonadHSET. (* Old code for translation from lists of lists *) (* (* [[nat]] to Signature *) *) (* Definition SigToSignature : Sig -> Signature HSET has_homsets_HSET. *) (* Proof. *) (* intro xs. *) (* generalize (map_list Arity_to_Signature xs). *) (* apply foldr1_list. *) (* - apply (BinSum_of_Signatures _ _ BinCoproductsHSET). *) (* - apply IdSignature. *) (* Defined. *) (* Lemma is_omega_cocont_SigToSignature (s : Sig) : is_omega_cocont (SigToSignature s). *) (* Proof. *) (* destruct s as [n xs]. *) (* destruct n. *) (* - destruct xs. *) (* apply (is_omega_cocont_functor_identity has_homsets_HSET2). *) (* - induction n. *) (* + destruct xs as [xs []]; simpl. *) (* apply is_omega_cocont_Arity_to_Signature. *) (* + destruct xs as [m xs]. *) (* generalize (IHn xs). *) (* destruct xs. *) (* intro IH. *) (* apply is_omega_cocont_BinSum_of_Signatures. *) (* apply is_omega_cocont_Arity_to_Signature. *) (* apply IH. *) (* apply BinProductsHSET. *) (* Defined. *) UniMath-20231010/UniMath/SubstitutionSystems/BindingSigToMonad_actegorical.v000066400000000000000000000400451451125700300270060ustar00rootroot00000000000000(** a follow-up of [BindingSigToMonad], where the semantic signatures [Signature] are replaced by functors with tensorial strength the concept of binding signatures is inherited, as well as the reasoning about omega-cocontinuity the strength notion is the one of monoidal heterogeneous substitution systems (MHSS), and accordingly a MHSS is constructed and a monad obtained through it author: Ralph Matthes, 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonadsAsMonoidsElementary. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Require Import UniMath.SubstitutionSystems.ConstructionOfGHSS. Require Import UniMath.SubstitutionSystems.SigmaMonoids. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Import MonoidalNotations. Local Notation "[ C , D ]" := (functor_category C D). Local Notation "'chain'" := (diagram nat_graph). Section FixACategory. Context {C : category}. Local Definition endoCAT : category := [C, C]. Local Definition Mon_endo_CAT : monoidal endoCAT := monendocat_monoidal C. Local Definition ptdendo_CAT : category := coslice_cat_total endoCAT I_{Mon_endo_CAT}. Local Definition Mon_ptdendo_CAT : monoidal ptdendo_CAT := monoidal_pointed_objects Mon_endo_CAT. Local Definition precomp_omegacocont_CAT (CLC : Colims_of_shape nat_graph C) (F : endoCAT) : is_omega_cocont (leftwhiskering_functor Mon_endo_CAT F). Proof. apply is_omega_cocont_pre_composition_functor, CLC. Defined. Local Definition ptdtensorialstrength_CAT := pointedtensorialstrength Mon_endo_CAT. Local Definition coprod_distributor_CAT {I : UU} (CP : Coproducts I C) : actegory_coprod_distributor Mon_endo_CAT (Coproducts_functor_precat I C C CP) (actegory_with_canonical_self_action Mon_endo_CAT). Proof. use tpair. - intro F. apply precomp_coprod_distributor_data. - intro F. apply precomp_coprod_distributor_law. Defined. Local Definition coprod_distributor_pointed_CAT {I : UU} (CP : Coproducts I C) : actegory_coprod_distributor Mon_ptdendo_CAT (Coproducts_functor_precat I C C CP) (actegory_with_canonical_pointed_action Mon_endo_CAT). Proof. apply reindexed_coprod_distributor. apply coprod_distributor_CAT. Defined. Local Definition bincoprod_distributor_CAT (BCP : BinCoproducts C) : actegory_bincoprod_distributor Mon_endo_CAT (BinCoproducts_functor_precat C C BCP) (actegory_with_canonical_self_action Mon_endo_CAT). Proof. use tpair. - intro F. apply precomp_bincoprod_distributor_data. - intro F. apply precomp_bincoprod_distributor_law. Defined. Local Definition bincoprod_distributor_pointed_CAT (BCP : BinCoproducts C) : actegory_bincoprod_distributor Mon_ptdendo_CAT (BinCoproducts_functor_precat C C BCP) (actegory_with_canonical_pointed_action Mon_endo_CAT). Proof. apply reindexed_bincoprod_distributor. apply bincoprod_distributor_CAT. Defined. Local Definition pointedlaxcommutator_CAT (G : functor C C) := relativelaxcommutator Mon_endo_CAT Mon_ptdendo_CAT (forget_monoidal_pointed_objects_monoidal Mon_endo_CAT) G. Local Definition pointedlaxcommutator_CAT_data (G : functor C C) := relativelaxcommutator_data Mon_endo_CAT (F:=pr1_category (coslice_cat_disp endoCAT I_{Mon_endo_CAT})) G. Section ConstConst. Context (c : C). Local Definition ConstConst : functor [C, C] [C, C] := constant_functor endoCAT endoCAT (constant_functor C C c). Definition ConstConst_strengthCAT : ptdtensorialstrength_CAT ConstConst. Proof. use tpair. - intros Ze c'. cbn. apply nat_trans_id. - abstract (split4; (intro; intros; apply (nat_trans_eq C); intro c'); try (apply idpath); cbn; repeat rewrite id_right; apply idpath). Defined. End ConstConst. Section genopt. Context (a : C) (BC : BinCoproducts C). Local Definition genopt : endoCAT := constcoprod_functor1 BC a. Definition ptdlaxcommutator_genopt_data : pointedlaxcommutator_CAT_data genopt. Proof. apply δ_genoption. Defined. (* the data part of the previous item with an interactive definition, could be put upstream: intros Ze. use make_nat_trans. - intro c. use BinCoproductArrow. + refine (BinCoproductIn1 (BC a c) · _). apply (pr2 Ze). + apply (#(pr1 Ze: functor _ _)). apply BinCoproductIn2. *) Lemma ptdlaxcommutator_genopt_nat : relativelaxcommutator_nat Mon_endo_CAT ptdlaxcommutator_genopt_data. Proof. intro Ze; induction Ze as [Z e]; intro Z'e'; induction Z'e' as [Z' e']; intro αX; induction αX as [α X]; simpl in *. apply nat_trans_eq; [apply homset_property |]; intro c; simpl. unfold BinCoproduct_of_functors_mor, BinCoproduct_of_functors_ob, δ_genoption_mor; simpl. rewrite precompWithBinCoproductArrow. rewrite postcompWithBinCoproductArrow. apply maponpaths_12. - rewrite id_left, assoc'. apply maponpaths. apply pathsinv0. rewrite <- X. apply idpath. - apply pathsinv0, nat_trans_ax. Qed. Lemma ptdlaxcommutator_genopt_tensor : relativelaxcommutator_tensor Mon_endo_CAT Mon_ptdendo_CAT (forget_monoidal_pointed_objects_monoidal Mon_endo_CAT) ptdlaxcommutator_genopt_data. Proof. intros Ze Z'e'; induction Ze as [Z e]; induction Z'e' as [Z' e']. apply nat_trans_eq_alt; intro c; simpl. unfold δ_genoption_mor, BinCoproduct_of_functors_ob, BinCoproduct_of_functors_mor; simpl. repeat rewrite id_right. rewrite id_left. rewrite precompWithBinCoproductArrow. rewrite postcompWithBinCoproductArrow. apply maponpaths_12. - rewrite id_left. cbn in Z, e, Z', e'. etrans. 2: { rewrite assoc'. apply maponpaths. apply (nat_trans_ax e'). } simpl. do 2 rewrite assoc. rewrite BinCoproductIn1Commutes. apply idpath. - rewrite id_left. etrans. 2: { apply functor_comp. } apply pathsinv0, maponpaths, BinCoproductIn2Commutes. Qed. Lemma ptdlaxcommutator_genopt_unit : relativelaxcommutator_unit Mon_endo_CAT Mon_ptdendo_CAT (forget_monoidal_pointed_objects_monoidal Mon_endo_CAT) ptdlaxcommutator_genopt_data. Proof. apply nat_trans_eq_alt; intro c; simpl. unfold δ_genoption_mor, BinCoproduct_of_functors_ob, BinCoproduct_of_functors_mor, BinCoproductOfArrows; simpl. repeat rewrite id_left. repeat rewrite id_right. apply idpath. Qed. Definition ptdlaxcommutator_genopt : pointedlaxcommutator_CAT genopt. Proof. exists ptdlaxcommutator_genopt_data. split3. - exact ptdlaxcommutator_genopt_nat. - exact ptdlaxcommutator_genopt_tensor. - exact ptdlaxcommutator_genopt_unit. Defined. End genopt. (** Define δ for G = F^n *) Definition ptdlaxcommutator_iter_functor1 (G : functor C C) (δ : pointedlaxcommutator_CAT G) (n: nat) : pointedlaxcommutator_CAT (iter_functor1 _ G n). Proof. induction n as [|n IHn]. - exact δ. - use composedrelativelaxcommutator. + apply IHn. + exact δ. Defined. Definition precomp_option_iter_strengthCAT (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : ptdtensorialstrength_CAT (precomp_option_iter BCC TC n). Proof. destruct n; simpl. - apply identity_lineator. - use reindexedstrength_from_commutator. refine (ptdlaxcommutator_iter_functor1 (option_functor BCC TC) (ptdlaxcommutator_genopt TC BCC) n). Defined. (* From here on all constructions need these hypotheses *) Context (BPC : BinProducts C) (BCC : BinCoproducts C). Let BPC2 : BinProducts [C, C] := BinProducts_functor_precat C C BPC. Let BCC2 : BinCoproducts [C, C] := BinCoproducts_functor_precat C C BCC. (** [nat] to a Signature *) Definition Arity_to_functor (TC : Terminal C) (xs : list nat) : functor [C, C] [C, C]. Proof. exact (foldr1 (BinProduct_of_functors _ _ BPC2) (constant_functor [C, C] [C, C] (constant_functor C C (TerminalObject TC))) (map (precomp_option_iter BCC TC) xs)). Defined. (** the functor is that previously found in the semantic signature - but not w.r.t. convertibility *) Lemma Arity_to_functor_agrees (TC : Terminal C) (xs : list nat) : Arity_to_functor TC xs = Signature_Functor (Arity_to_Signature BPC BCC TC xs). Proof. induction xs as [[|n] xs]. - induction xs. apply idpath. - induction n as [|n IH]. + induction xs as [m []]. apply idpath. + induction xs as [m [k xs]]. assert (IHinst := IH (k,,xs)). change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))). unfold Arity_to_functor. do 2 rewrite map_cons. rewrite foldr1_cons. change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst. etrans. { apply maponpaths. exact IHinst. } apply idpath. Defined. Definition Arity_to_strengthCAT (TC : Terminal C) (xs : list nat) : ptdtensorialstrength_CAT (Arity_to_functor TC xs). Proof. induction xs as [[|n] xs]. - induction xs. cbn. exact (ConstConst_strengthCAT TC). - induction n as [|n IH]. + induction xs as [m []]. cbn. exact (precomp_option_iter_strengthCAT BCC TC m). + induction xs as [m [k xs]]. refine (lax_lineator_binprod _ _ _ (precomp_option_iter_strengthCAT BCC TC _) (IH (k,,xs)) _). Defined. Definition BindingSigToFunctor (TC : Terminal C) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : functor [C, C] [C, C]. Proof. exact (coproduct_of_functors (BindingSigIndex sig) _ _ (Coproducts_functor_precat (BindingSigIndex sig) C C CC) (fun i => Arity_to_functor TC (BindingSigMap sig i))). Defined. (** the functor is that previously found in the semantic signature - but not w.r.t. convertibility *) Lemma BindingSigToFunctor_agrees (TC : Terminal C) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : BindingSigToFunctor TC sig CC = Signature_Functor (BindingSigToSignature BPC BCC TC sig CC). Proof. unfold BindingSigToFunctor, BindingSigToSignature. assert (aux : (λ i : BindingSigIndex sig, Arity_to_functor TC (BindingSigMap sig i)) = (λ i : BindingSigIndex sig, Arity_to_Signature BPC BCC TC (BindingSigMap sig i))). { apply funextsec. intro i. apply Arity_to_functor_agrees. } rewrite aux. apply idpath. Qed. Let Id_H : [C, C] ⟶ [C, C] → [C, C] ⟶ [C, C] := Id_H C BCC. Let constprod_functor1 : [C, C] → [C, C] ⟶ [C, C] := constprod_functor1 BPC2. Lemma is_omega_cocont_BindingSigToFunctor (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : is_omega_cocont (BindingSigToFunctor TC sig CC). Proof. rewrite BindingSigToFunctor_agrees. apply is_omega_cocont_BindingSigToSignature; assumption. Defined. (* notice that it depends on an opaque proof of equality of types *) Definition BindingSigToStrengthCAT (TC : Terminal C) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : ptdtensorialstrength_CAT (BindingSigToFunctor TC sig CC). Proof. exact (lax_lineator_coprod _ _ _ (fun i => Arity_to_strengthCAT TC (BindingSigMap sig i)) (Coproducts_functor_precat (BindingSigIndex sig) C C CC) (coprod_distributor_pointed_CAT CC)). Qed. Section PuttingAllTogether. Context (IC : Initial C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C). (** Construction of initial algebra for the omega-cocontinuous signature functor with lax lineator *) Definition DatatypeOfBindingSig_CAT : Initial (FunctorAlg (Id_H (BindingSigToFunctor TC sig CC))). Proof. use colimAlgInitial. - apply (Initial_functor_precat _ _ IC). - apply (is_omega_cocont_Id_H _ _ _ (is_omega_cocont_BindingSigToFunctor TC CLC HF sig CC)). - apply ColimsFunctorCategory_of_shape, CLC. Defined. (** the associated MHSS *) Definition MHSSOfBindingSig_CAT : mhss Mon_endo_CAT (BindingSigToFunctor TC sig CC) (BindingSigToStrengthCAT TC sig CC). Proof. use (initial_alg_to_mhss (BindingSigToStrengthCAT TC sig CC) BCC2 (bincoprod_distributor_pointed_CAT BCC)). - apply (Initial_functor_precat _ _ IC). - apply ColimsFunctorCategory_of_shape, CLC. - apply (is_omega_cocont_BindingSigToFunctor TC CLC HF sig CC). - intro F. apply Initial_functor_precat. - exact (precomp_omegacocont_CAT CLC). Defined. (** the associated Sigma-monoid *) Definition SigmaMonoidOfBindingSig_CAT : SigmaMonoid (BindingSigToStrengthCAT TC sig CC). Proof. apply mhss_to_sigma_monoid. exact MHSSOfBindingSig_CAT. Defined. (** the associated monad *) Definition MonadOfBindingSig_CAT : Monad C. Proof. use monoid_to_monad_CAT. use SigmaMonoid_to_monoid. - exact (BindingSigToFunctor TC sig CC). - exact (BindingSigToStrengthCAT TC sig CC). - exact SigmaMonoidOfBindingSig_CAT. Defined. End PuttingAllTogether. End FixACategory. Section InstanceHSET. Definition BindingSigToMonadHSET_viaCAT : BindingSig → Monad HSET. Proof. intros sig; use (MonadOfBindingSig_CAT _ _ _ _ _ _ sig). - apply BinProductsHSET. - apply BinCoproductsHSET. - apply InitialHSET. - apply TerminalHSET. - apply ColimsHSET_of_shape. - intro F. apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. - apply CoproductsHSET. apply BindingSigIsaset. Defined. End InstanceHSET. UniMath-20231010/UniMath/SubstitutionSystems/CCS.v000066400000000000000000000244421451125700300215650ustar00rootroot00000000000000(** Syntax of the calculus of constructions as in Streicher "Semantics of Type Theory" formalized as a multisorted binding signature. Written by: Anders Mörtberg, 2017 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction. Local Open Scope cat. Section ccs. (* Preliminary stuff, upstream? *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "C / X" := (slice_cat C X). Local Notation "a + b" := (setcoprod a b) : set. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (a b c d e f : A) : stn 6 -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a two element set of sorts *) Definition sort : hSet := @tpair _ (λ X, isaset X) bool isasetbool. Definition ty : sort := true. Definition el : sort := false. Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let HSET_over_sort2 := [HSET/sort,HSET_over_sort]. (** The grammar of expressions and objects from page 157: << E ::= (Πx:E) E product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t ::= x variable | (λx:E) t function abstraction | App([x:E] E, t, t) function application | (∀x:E) t universal quantification >> We refer to the first syntactic class as ty and the second as el. We first reformulate the rules as follows: << A,B ::= Π(A,x.B) product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t,u ::= x variable | λ(A,x.t) function abstraction | App(A,x.B,t,u) function application | ∀(A,x.t) universal quantification >> This grammar then gives 6 operations, to the left as Vladimir's restricted 2-sorted signature (where el is 0 and ty is 1) and to the right as a multisorted signature: ((0, 1), (1, 1), 1) = (([],ty), ([el], ty), ty) (1) = ([],ty) ((0, 0), 1) = (([], el), ty) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) ((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) *) (** The multisorted signature of CC-S *) Definition CCS_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - exact (stn 6,,isasetstn 6). - apply six_rec. + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty). + exact ([],,ty). + exact ((([],,el) :: nil),,ty). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). Defined. Definition CCS_Signature : Signature (HSET / sort) _ _ := MultiSortedSigToSignature sort CCS_Sig. Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort). Definition CCS_Functor : functor HSET_over_sort2 HSET_over_sort2 := Id_H CCS_Signature. Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor). Proof. apply SignatureInitialAlgebraSetSort. apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Definition CCS_Monad : Monad (HSET / sort) := MultiSortedSigToMonad sort CCS_Sig. (** Extract the constructors from the initial algebra *) Definition CCS : HSET_over_sort2 := alg_carrier _ (InitialObject CCS_Functor_Initial). Let CCS_mor : HSET_over_sort2⟦CCS_Functor CCS,CCS⟧ := alg_map _ (InitialObject CCS_Functor_Initial). Let CCS_alg : algebra_ob CCS_Functor := InitialObject CCS_Functor_Initial. Local Lemma BP : BinProducts [HSET_over_sort,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Notation "'Id'" := (functor_identity HSET_over_sort). Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)). (** The variables *) Definition var_map : HSET_over_sort2⟦Id,CCS⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_mor. Definition Pi_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort ty)) ∙ hat_functor sort ty. (** The Pi constructor *) Definition Pi_map : HSET_over_sort2⟦Pi_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition Prop_source (X : HSET_over_sort2) : HSET_over_sort2 := constant_functor (slice_cat HSET _) HSET 1%CS ∙ hat_functor sort ty. Definition Prop_map : HSET_over_sort2⟦Prop_source CCS,CCS⟧. Proof. use ((CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor). Defined. Definition Proof_source (X : HSET_over_sort2) : HSET_over_sort2 := (X ∙ proj_functor sort el) ∙ hat_functor sort ty. (** The Proof constructor *) Definition Proof_map : HSET_over_sort2⟦Proof_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition lam_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el. (** The lambda constructor *) Definition lam_map : HSET_over_sort2⟦lam_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition app_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ ((sorted_option_functor sort el ∙ X ∙ proj_functor sort ty) ⊗ ((X ∙ proj_functor sort el) ⊗ (X ∙ proj_functor sort el)))) ∙ hat_functor sort el. (** The app constructor *) Definition app_map : HSET_over_sort2⟦app_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition forall_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el. (** The ∀ constructor *) Definition forall_map : HSET_over_sort2⟦forall_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition make_CCS_Algebra X (fvar : HSET_over_sort2⟦Id,X⟧) (fPi : HSET_over_sort2⟦Pi_source X,X⟧) (fProp : HSET_over_sort2⟦Prop_source X,X⟧) (fProof : HSET_over_sort2⟦Proof_source X,X⟧) (flam : HSET_over_sort2⟦lam_source X,X⟧) (fapp : HSET_over_sort2⟦app_source X,X⟧) (fforall : HSET_over_sort2⟦forall_source X,X⟧) : algebra_ob CCS_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intros i. induction i as [n p]. repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)). - exact fPi. - exact fProp. - exact fProof. - exact flam. - simpl in fapp. exact fapp. - exact fforall. Defined. (* This is slow *) (** The recursor for ccs *) Definition foldr_map X (fvar : HSET_over_sort2⟦Id,X⟧) (fPi : HSET_over_sort2⟦Pi_source X,X⟧) (fProp : HSET_over_sort2⟦Prop_source X,X⟧) (fProof : HSET_over_sort2⟦Proof_source X,X⟧) (flam : HSET_over_sort2⟦lam_source X,X⟧) (fapp : HSET_over_sort2⟦app_source X,X⟧) (fforall : HSET_over_sort2⟦forall_source X,X⟧) : algebra_mor _ CCS_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall). Proof. apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)). Defined. End ccs. UniMath-20231010/UniMath/SubstitutionSystems/CCS_alt.v000066400000000000000000000262631451125700300224300ustar00rootroot00000000000000(** Syntax of the calculus of constructions as in Streicher "Semantics of Type Theory" formalized as a 2-sorted binding signature. Written by: Anders Mörtberg, 2021 (adapted from CCS.v) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Local Open Scope cat. Section ccs. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (a b c d e f : A) : stn 6 → A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a two element set of sorts *) Definition sort : hSet := (bool,,isasetbool). Local Lemma hsort : isofhlevel 3 sort. Proof. exact (isofhlevelssnset 1 sort (setproperty sort)). Defined. Definition ty : sort := true. Definition el : sort := false. Let sortToSet : category := [path_pregroupoid sort hsort,HSET]. Let sortToSet2 := [sortToSet,sortToSet]. Local Lemma BinCoprodSortToSet : BinCoproducts sortToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma TerminalSortToSet : Terminal sortToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinProd : BinProducts [sortToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodSortToSet a b)). Local Notation "'1'" := (TerminalObject TerminalSortToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). (** The grammar of expressions and objects from page 157: << E ::= (Πx:E) E product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t ::= x variable | (λx:E) t function abstraction | App([x:E] E, t, t) function application | (∀x:E) t universal quantification >> We refer to the first syntactic class as ty and the second as el. We first reformulate the rules as follows: << A,B ::= Π(A,x.B) product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t,u ::= x variable | λ(A,x.t) function abstraction | App(A,x.B,t,u) function application | ∀(A,x.t) universal quantification >> This grammar then gives 6 operations, to the left as Vladimir's restricted 2-sorted signature (where el is 0 and ty is 1) and to the right as a multisorted signature: ((0, 1), (1, 1), 1) = (([],ty), ([el], ty), ty) (1) = ([],ty) ((0, 0), 1) = (([], el), ty) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) ((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) *) (** The multisorted signature of CC-S *) Definition CCS_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - exact (stn 6,,isasetstn 6). - apply six_rec. + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty). + exact ([],,ty). + exact ((([],,el) :: nil),,ty). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). Defined. Definition CCS_Signature : Signature sortToSet _ _ := MultiSortedSigToSignatureSet sort hsort CCS_Sig. Definition CCS_Functor : functor sortToSet2 sortToSet2 := Id_H _ BinCoprodSortToSet CCS_Signature. Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition CCS_Monad : Monad sortToSet := MultiSortedSigToMonadSet sort hsort CCS_Sig. (** Extract the constructors from the initial algebra *) Definition CCS_M : sortToSet2 := alg_carrier _ (InitialObject CCS_Functor_Initial). Let CCS_M_mor : sortToSet2⟦CCS_Functor CCS_M,CCS_M⟧ := alg_map _ (InitialObject CCS_Functor_Initial). Let CCS_M_alg : algebra_ob CCS_Functor := InitialObject CCS_Functor_Initial. (** The variables *) Definition var_map : sortToSet2⟦Id,CCS_M⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_M_mor. Definition Pi_source : functor sortToSet2 sortToSet2 := ( post_comp_functor (projSortToSet sort hsort ty) ⊗ ( pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToC sort hsort _ ty))) ∙ (post_comp_functor (hat_functorSet sort hsort ty)). (** The Pi constructor *) Definition Pi_map : sortToSet2⟦Pi_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition Prop_source : functor sortToSet2 sortToSet2. Proof. set (T := constant_functor [sortToSet,sortToSet] [sortToSet,HSET] (constant_functor sortToSet HSET (TerminalObject TerminalHSET))). exact (T ∙ post_comp_functor (hat_functorSet sort hsort ty)). Defined. Definition Prop_map : sortToSet2⟦Prop_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1%nat)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition Proof_source : functor sortToSet2 sortToSet2 := post_comp_functor (projSortToSet sort hsort el) ∙ post_comp_functor (hat_functorSet sort hsort ty). (** The Proof constructor *) Definition Proof_map : sortToSet2⟦Proof_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition lam_source : functor sortToSet2 sortToSet2 := (post_comp_functor (projSortToSet sort hsort ty) ⊗ (pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToC sort hsort _ el))) ∙ (post_comp_functor (hat_functorSet sort hsort el)). (** The lambda constructor *) Definition lam_map : sortToSet2⟦lam_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition app_source : functor sortToSet2 sortToSet2 := ((post_comp_functor (projSortToSet sort hsort ty)) ⊗ ((pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort ty)) ⊗ ((post_comp_functor (projSortToSet sort hsort el)) ⊗ (post_comp_functor (projSortToSet sort hsort el))))) ∙ (post_comp_functor (hat_functorSet sort hsort el)). (** The app constructor *) Definition app_map : sortToSet2⟦app_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition forall_source : functor sortToSet2 sortToSet2 := ((post_comp_functor (projSortToSet sort hsort ty)) ⊗ (pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort el))) ∙ post_comp_functor (hat_functorSet sort hsort el). (** The ∀ constructor *) Definition forall_map : sortToSet2⟦forall_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition make_CCS_Algebra X (fvar : sortToSet2⟦Id,X⟧) (fPi : sortToSet2⟦Pi_source X,X⟧) (fProp : sortToSet2⟦Prop_source X,X⟧) (fProof : sortToSet2⟦Proof_source X,X⟧) (flam : sortToSet2⟦lam_source X,X⟧) (fapp : sortToSet2⟦app_source X,X⟧) (fforall : sortToSet2⟦forall_source X,X⟧) : algebra_ob CCS_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intros i. induction i as [n p]. repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)). - exact fPi. - exact fProp. - exact fProof. - exact flam. - simpl in fapp. exact fapp. - exact fforall. Defined. (** The recursor for ccs *) Definition foldr_map X (fvar : sortToSet2⟦Id,X⟧) (fPi : sortToSet2⟦Pi_source X,X⟧) (fProp : sortToSet2⟦Prop_source X,X⟧) (fProof : sortToSet2⟦Proof_source X,X⟧) (flam : sortToSet2⟦lam_source X,X⟧) (fapp : sortToSet2⟦app_source X,X⟧) (fforall : sortToSet2⟦forall_source X,X⟧) : algebra_mor _ CCS_M_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall). Proof. apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)). Defined. End ccs. UniMath-20231010/UniMath/SubstitutionSystems/ConstructionOfGHSS.v000066400000000000000000000602011451125700300246120ustar00rootroot00000000000000(** construction of monoidal heterogeneous substitution systems from arbitrary final coalgebras and from initial algebras arising from iteration in omega-cocontinuous functors authors: Ralph Matthes, Kobe Wullaert, 2023 Note: the name of the file still refers to GHSS although it would more appropriately be MHSS after the renaming from "generalized" to "monoidal" done in July 2023. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.FunctorCoalgebras. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Adamek. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.CompletelyIterativeAlgebras. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Require Import UniMath.SubstitutionSystems.ActionScenarioForGenMendlerIteration_alt. Require Import UniMath.SubstitutionSystems.SigmaMonoids. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section FixTheContext. Context {V : category} {Mon_V : monoidal V} {H : V ⟶ V} (θ : pointedtensorialstrength Mon_V H). Let PtdV : category := GeneralizedSubstitutionSystems.PtdV Mon_V. Let Mon_PtdV : monoidal PtdV := GeneralizedSubstitutionSystems.Mon_PtdV Mon_V. Let Act : actegory Mon_PtdV V:= GeneralizedSubstitutionSystems.Act Mon_V. Context (CP : BinCoproducts V) (δ : actegory_bincoprod_distributor Mon_PtdV CP Act). Let Const_plus_H (v : V) : functor V V := GeneralizedSubstitutionSystems.Const_plus_H H CP v. Definition I_H : functor V V := Const_plus_H I_{Mon_V}. Section FinalCoalgebraToMHSS. Context (νH : coalgebra_ob I_H) (isTerminalνH : isTerminal (CoAlg_category I_H) νH). Let t : V := pr1 νH. Let out : t --> I_H t := pr2 νH. Let out_z_iso : z_iso t (I_H t) := finalcoalgebra_z_iso _ I_H νH isTerminalνH. Let out_inv : I_H t --> t := inv_from_z_iso out_z_iso. Definition final_coalg_to_mhss_step_term {Z : PtdV} (f : pr1 Z --> t) : Z ⊗_{Act} t --> I_H (CP (Z ⊗_{Act} t) t). Proof. refine (Z ⊗^{Act}_{l} out · _). refine (δ _ _ _ · _). refine (BinCoproductOfArrows _ (CP _ _) (CP _ _) (ru_{Mon_V} _) (pr1 θ Z t) · _). refine (# (Const_plus_H (pr1 Z)) (BinCoproductIn1 (CP _ t)) · _). exact (BinCoproductArrow (CP _ _) (f · out · #I_H (BinCoproductIn2 (CP _ _))) (BinCoproductIn2 _)). Defined. (** an alternative route through completely iterative algebras *) Definition final_coalg_to_mhss_equation_morphism {Z : PtdV} (f : pr1 Z --> t) : Z ⊗_{Act} t --> CP (I_H (Z ⊗_{Act} t)) t. Proof. refine (Z ⊗^{Act}_{l} out · _). refine (δ _ _ _ · _). refine (BinCoproductOfArrows _ (CP _ _) (CP _ _) (ru_{Mon_V} _) (pr1 θ Z t) · _). refine (BinCoproductArrow (CP _ _) _ _). - refine (f · _). apply BinCoproductIn2. - refine (BinCoproductIn2 (CP _ _) · _). apply BinCoproductIn1. Defined. Lemma final_coalg_to_mhss_equation_morphism_is_factor {Z : PtdV} (f : pr1 Z --> t) : final_coalg_to_mhss_step_term f = CompletelyIterativeAlgebras.ϕ_for_cia CP I_H νH isTerminalνH (Z ⊗_{Act} t) (final_coalg_to_mhss_equation_morphism f). Proof. unfold final_coalg_to_mhss_step_term, CompletelyIterativeAlgebras.ϕ_for_cia, final_coalg_to_mhss_equation_morphism. repeat rewrite assoc'. do 3 apply maponpaths. unfold Const_plus_H, GeneralizedSubstitutionSystems.Const_plus_H. cbn. unfold BinCoproduct_of_functors_mor. etrans. { apply precompWithBinCoproductArrow. } rewrite postcompWithBinCoproductArrow. apply maponpaths_12. - cbn. rewrite id_left. rewrite assoc'. apply maponpaths. rewrite BinCoproductIn2Commutes. apply idpath. - etrans. 2: { repeat rewrite assoc'. rewrite BinCoproductIn1Commutes. apply pathsinv0, BinCoproductOfArrowsIn2. } apply idpath. Qed. (** This clarifies that in the proof below, primitive corecursion can be replaced by only exploiting that [out_inv] is a completely iterative algebra (cia), see the alternative proof further below. The lemma itself is not used in the sequel. *) Let η : I_{Mon_V} --> t := BinCoproductIn1 (CP I_{Mon_V} (H t)) · out_inv. Let τ : H t --> t := BinCoproductIn2 (CP I_{Mon_V} (H t)) · out_inv. Lemma ητ_is_out_inv : BinCoproductArrow (CP I_{ Mon_V} (H t)) η τ = out_inv. Proof. apply pathsinv0, BinCoproductArrowEta. Qed. Local Definition ϕ {Z : PtdV} (f : pr1 Z --> t) := final_coalg_to_mhss_step_term f. Local Definition Corec_ϕ {Z : PtdV} (f : pr1 Z --> t) := primitive_corecursion CP isTerminalνH (x := Z ⊗_{Act} t) (ϕ f). (** a hand-crafted auxiliary lemma *) Local Lemma changing_the_constant_Const_plus_H (x y v w : V) (f : v --> w) (fm : w --> v) (g : x --> Const_plus_H y w) (fmf : fm · f = identity _) : # (Const_plus_H x) f · BinCoproductArrow (CP _ _) g (BinCoproductIn2 _) = BinCoproductArrow (CP _ _) (g · # (Const_plus_H y) fm) (BinCoproductIn2 _) · # (Const_plus_H y) f. Proof. use BinCoproductArrowsEq. - etrans. { rewrite assoc. apply cancel_postcomposition. apply BinCoproductOfArrowsIn1. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn1Commutes. } etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, BinCoproductIn1Commutes. } etrans. 2: { rewrite assoc'. apply maponpaths. apply functor_comp. } rewrite fmf. rewrite functor_id. rewrite id_right. apply id_left. - etrans. { rewrite assoc. apply cancel_postcomposition. apply BinCoproductOfArrowsIn2. } etrans. { rewrite assoc'. apply maponpaths. apply BinCoproductIn2Commutes. } etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, BinCoproductIn2Commutes. } etrans. 2: { apply pathsinv0, BinCoproductOfArrowsIn2. } apply idpath. Qed. Lemma final_coalg_to_mhss_has_equivalent_characteristic_formula {Z : PtdV} (f : pr1 Z --> t) (h : Z ⊗_{Act} t --> t) : primitive_corecursion_characteristic_formula CP (ϕ f) h ≃ mbracket_property_parts Mon_V H θ t η τ (pr2 Z) f h. Proof. apply weqimplimpl. - intro Hcorec. apply (pr2 (mbracket_property_single_equivalent _ _ _ _ _ _ CP _ _ _)). red. red in Hcorec. fold out t in Hcorec. rewrite ητ_is_out_inv. apply pathsinv0, (z_iso_inv_on_left _ _ _ _ out_z_iso) in Hcorec. etrans. { apply maponpaths. exact Hcorec. } clear Hcorec. unfold ϕ, final_coalg_to_mhss_step_term. etrans. { repeat rewrite assoc. do 6 apply cancel_postcomposition. rewrite assoc'. apply maponpaths. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act Z)). } etrans. { apply maponpaths. apply (pr222 out_z_iso). } apply (functor_id (leftwhiskering_functor Act Z)). } rewrite id_right. etrans. { do 5 apply cancel_postcomposition. apply (pr2 δ). } rewrite id_left. repeat rewrite assoc'. apply maponpaths. etrans. { apply maponpaths. rewrite assoc. apply cancel_postcomposition. rewrite (assoc f out). apply pathsinv0. use changing_the_constant_Const_plus_H. apply BinCoproductIn2Commutes. } etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. etrans. { apply pathsinv0, (functor_comp (Const_plus_H (pr1 Z))). } apply maponpaths. apply BinCoproductIn1Commutes. } repeat rewrite assoc'. apply maponpaths. etrans. { apply postcompWithBinCoproductArrow. } rewrite assoc'. apply maponpaths_2. etrans. { apply maponpaths. apply (pr122 out_z_iso). } apply id_right. - intro Hmhss. apply (pr1 (mbracket_property_single_equivalent _ _ _ _ _ _ CP _ _ _)) in Hmhss. red. red in Hmhss. fold out t. rewrite ητ_is_out_inv in Hmhss. rewrite assoc' in Hmhss. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly Mon_PtdV CP Act δ (pr1 Z,, pr2 Z) (I_{ Mon_V},,H t))) in Hmhss. apply (z_iso_inv_to_left _ _ _ (functor_on_z_iso (leftwhiskering_functor Act (pr1 Z,, pr2 Z)) out_z_iso)) in Hmhss. etrans. { apply cancel_postcomposition. exact Hmhss. } clear Hmhss. unfold ϕ, final_coalg_to_mhss_step_term. repeat rewrite assoc'. do 2 apply maponpaths. etrans. 2: { do 2 apply maponpaths. rewrite (assoc f out). use changing_the_constant_Const_plus_H. apply BinCoproductIn2Commutes. } apply maponpaths. etrans. 2: { repeat rewrite assoc. apply cancel_postcomposition. etrans. 2: { apply (functor_comp (Const_plus_H (pr1 Z))). } apply maponpaths. apply pathsinv0, BinCoproductIn1Commutes. } apply maponpaths. etrans. { apply postcompWithBinCoproductArrow. } apply maponpaths. unfold τ. etrans. { rewrite assoc'. apply maponpaths. apply (pr222 out_z_iso). } apply id_right. - apply V. - apply isaprop_mbracket_property_parts. Qed. Definition final_coalg_to_mhss : mhss Mon_V H θ. Proof. exists t. exists η. exists τ. intros Z f. simple refine (iscontrretract _ _ _ (Corec_ϕ f)). - intros [h Hyp]. exists h. apply final_coalg_to_mhss_has_equivalent_characteristic_formula. exact Hyp. - intros [h Hyp]. exists h. apply final_coalg_to_mhss_has_equivalent_characteristic_formula. exact Hyp. - intros [h Hyp]. use total2_paths_f. + apply idpath. + apply isaprop_mbracket_property_parts. Defined. (** the alternative proof through cia *) Lemma final_coalg_to_mhss_equation_morphism_has_equivalent_characteristic_formula {Z : PtdV} (f : pr1 Z --> t) (h : Z ⊗_{Act} t --> t) : cia_characteristic_formula CP I_H (CompletelyIterativeAlgebras.Xinv _ _ isTerminalνH) (final_coalg_to_mhss_equation_morphism f) h ≃ mbracket_property_parts Mon_V H θ t η τ (pr2 Z) f h. Proof. apply weqimplimpl. - intro Hcia. apply (pr2 (mbracket_property_single_equivalent _ _ _ _ _ _ CP _ _ _)). red. red in Hcia. rewrite ητ_is_out_inv. etrans. { apply maponpaths. exact Hcia. } clear Hcia. unfold final_coalg_to_mhss_equation_morphism. etrans. { repeat rewrite assoc'. apply maponpaths. repeat rewrite assoc. do 5 apply cancel_postcomposition. etrans. { apply pathsinv0, (functor_comp (leftwhiskering_functor Act Z)). } etrans. { apply maponpaths. apply (pr222 out_z_iso). } apply (functor_id (leftwhiskering_functor Act Z)). } rewrite id_left. etrans. { repeat rewrite assoc. do 4 apply cancel_postcomposition. apply (pr2 δ). } rewrite id_left. repeat rewrite assoc'. apply maponpaths. unfold GeneralizedSubstitutionSystems.Const_plus_H. cbn. unfold BinCoproduct_of_functors_mor. rewrite precompWithBinCoproductArrow. etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } rewrite postcompWithBinCoproductArrow. apply maponpaths_12. + rewrite assoc'. rewrite BinCoproductIn2Commutes. do 2 rewrite id_right. apply pathsinv0, id_left. + repeat rewrite assoc'. etrans. { apply maponpaths. apply BinCoproductIn1Commutes. } rewrite assoc. etrans. { apply cancel_postcomposition. apply BinCoproductOfArrowsIn2. } rewrite assoc'. apply idpath. - intro Hmhss. apply (pr1 (mbracket_property_single_equivalent _ _ _ _ _ _ CP _ _ _)) in Hmhss. red. red in Hmhss. rewrite ητ_is_out_inv in Hmhss. rewrite assoc' in Hmhss. apply (z_iso_inv_to_left _ _ _ (_,,bincoprod_functor_lineator_strongly Mon_PtdV CP Act δ (pr1 Z,, pr2 Z) (I_{ Mon_V},,H t))) in Hmhss. apply (z_iso_inv_to_left _ _ _ (functor_on_z_iso (leftwhiskering_functor Act (pr1 Z,, pr2 Z)) out_z_iso)) in Hmhss. etrans. { exact Hmhss. } clear Hmhss. unfold final_coalg_to_mhss_equation_morphism. repeat rewrite assoc'. do 3 apply maponpaths. unfold GeneralizedSubstitutionSystems.Const_plus_H. cbn. unfold BinCoproduct_of_functors_mor. rewrite precompWithBinCoproductArrow. etrans. { apply precompWithBinCoproductArrow. } rewrite postcompWithBinCoproductArrow. apply maponpaths_12. + rewrite assoc'. rewrite BinCoproductIn2Commutes. do 2 rewrite id_right. apply id_left. + repeat rewrite assoc'. etrans. 2: { apply maponpaths. apply pathsinv0, BinCoproductIn1Commutes. } rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn2. } rewrite assoc'. apply idpath. - apply V. - apply isaprop_mbracket_property_parts. Qed. (** this proof is a bit shorter and does not need the hand-crafted auxiliary lemma [changing_the_constant_Const_plus_H] *) Definition final_coalg_to_mhss_alt : mhss Mon_V H θ. Proof. exists t. exists η. exists τ. intros Z f. simple refine (iscontrretract _ _ _ (cia_from_final_coalgebra CP I_H _ isTerminalνH _ (final_coalg_to_mhss_equation_morphism f))). - intros [h Hyp]. exists h. apply final_coalg_to_mhss_equation_morphism_has_equivalent_characteristic_formula. exact Hyp. - intros [h Hyp]. exists h. apply final_coalg_to_mhss_equation_morphism_has_equivalent_characteristic_formula. exact Hyp. - intros [h Hyp]. use total2_paths_f. + apply idpath. + apply isaprop_mbracket_property_parts. Defined. End FinalCoalgebraToMHSS. Section InitialAlgebraToMHSS. Context (IV : Initial V) (CV : Colims_of_shape nat_graph V) (HH : is_omega_cocont H). Let AF : category := FunctorAlg I_H. Let chnF : chain V := initChain IV I_H. Let t_Initial : Initial AF := colimAlgInitial IV (ActionScenarioForGenMendlerIteration_alt.HF CP H HH I_{Mon_V}) (CV chnF). Let t : V := alg_carrier _ (InitialObject t_Initial). Let α : I_H t --> t := alg_map I_H (pr1 t_Initial). Let η : constant_functor V V I_{Mon_V} t --> t := BinCoproductIn1 (CP _ _) · α. Let τ : H t --> t := BinCoproductIn2 (CP _ _) · α. (** a more comfortable presentation of the standard iteration scheme *) Lemma Iteration_I_H_aux1 (av : V) (aη : I_{Mon_V} --> av) (aτ : H av --> av) (aα := av,, BinCoproductArrow (CP I_{ Mon_V} (H av)) aη aτ) (h : t --> pr1 aα) : pr21 t_Initial -->[ h] pr2 aα → τ · h = # H h · aτ × η · h = aη. Proof. intro Hyp. cbn in Hyp. split. + apply (maponpaths (fun x => BinCoproductIn2 _ · x)) in Hyp. rewrite assoc in Hyp. etrans. { exact Hyp. } etrans. { apply maponpaths. apply precompWithBinCoproductArrow. } apply BinCoproductIn2Commutes. + apply (maponpaths (fun x => BinCoproductIn1 _ · x)) in Hyp. rewrite assoc in Hyp. etrans. { exact Hyp. } etrans. { apply maponpaths. apply precompWithBinCoproductArrow. } cbn. rewrite id_left. apply BinCoproductIn1Commutes. Qed. Lemma Iteration_I_H_aux2 (av : V) (aη : I_{Mon_V} --> av) (aτ : H av --> av) (aα := av,, BinCoproductArrow (CP I_{ Mon_V} (H av)) aη aτ) (h : t --> av) : τ · h = # H h · aτ → η · h = aη → pr21 t_Initial -->[ h] pr2 aα. Proof. intros Hyp1 Hyp2. cbn. etrans. { apply cancel_postcomposition. apply BinCoproductArrowEta. } etrans. { apply postcompWithBinCoproductArrow. } etrans. 2: { apply pathsinv0, precompWithBinCoproductArrow. } apply maponpaths_12. + cbn. rewrite id_left. exact Hyp2. + cbn. exact Hyp1. Qed. Definition Iteration_I_H (av : V) (aη : I_{Mon_V} --> av) (aτ : H av --> av) : ∃! h : t --> av, τ · h = # H h · aτ × η · h = aη. Proof. transparent assert (aα : (ob AF)). { use tpair. - exact av. - exact (BinCoproductArrow (CP _ _) aη aτ). } simple refine (iscontrretract _ _ _ (pr2 t_Initial aα)). - intros [h Hyp]. exists h. apply Iteration_I_H_aux1. exact Hyp. - intros [h [Hyp1 Hyp2]]. exists h. apply Iteration_I_H_aux2. + exact Hyp1. + exact Hyp2. - abstract (intros [h Hyp]; use total2_paths_f; [ apply idpath | apply isapropdirprod; apply V]). Defined. Context (initial_annihilates : ∏ (v : V), isInitial V (v ⊗_{Mon_V} (InitialObject IV))). Context (left_whiskering_omega_cocont : ∏ (v : V), is_omega_cocont (leftwhiskering_functor Mon_V v)). Definition initial_alg_to_mhss : mhss Mon_V H θ. Proof. exists t. exists η. exists τ. intros Z f. red. unfold mbracket_property_parts. set (Mendler_inst := SpecialGenMendlerIterationWithActegoryAndStrength Mon_PtdV IV CV Act Z CP H HH I_{Mon_V} t θ τ (ru^{Mon_V}_{ pr1 Z} · f) (initial_annihilates (pr1 Z)) (left_whiskering_omega_cocont (pr1 Z)) δ). simple refine (iscontrretract _ _ _ Mendler_inst). - intros [h [Hyp1 Hyp2]]. exists h. split; apply pathsinv0; assumption. - intros [h [Hyp1 Hyp2]]. exists h. split; apply pathsinv0; assumption. - intros [h Hyp]. use total2_paths_f. + apply idpath. + cbn. do 2 rewrite pathsinv0inv0. apply idpath. Defined. Let σ : SigmaMonoid θ := mhss_to_sigma_monoid θ initial_alg_to_mhss. Let μ : pr1 σ ⊗_{Mon_V} pr1 σ --> pr1 σ := pr11 (pr212 σ). Theorem SigmaMonoidFromInitialAlgebra_is_initial : isInitial _ σ. Proof. intro asigma. induction asigma as [av [[aτ [[aμ aη] Hμη]] Hτ]]. red in Hτ. cbn in Hτ. set (It_inst := Iteration_I_H av aη aτ). set (h := pr11 It_inst). use tpair. - exists h. use tpair. 2: { exact tt. } assert (aux := pr21 It_inst). hnf in aux. split. + exact (pr1 aux). + red. split. 2: { red. exact (pr2 aux). } red. change (h ⊗^{ Mon_V} h · aμ = μ · h). destruct aux as [auxτ auxη]. fold h in auxτ, auxη. (** both sides are identical as unique morphism from the Mendler iteration scheme *) set (Mendler_inst := SpecialGenMendlerIterationWithActegoryAndStrength Mon_PtdV IV CV Act (t,,η) CP H HH I_{Mon_V} av θ aτ (ru^{Mon_V}_{t} · h) (initial_annihilates t) (left_whiskering_omega_cocont t) δ). intermediate_path (pr11 Mendler_inst). * apply path_to_ctr. red; split. -- change (t ⊗^{Mon_V}_{l} η · (h ⊗^{ Mon_V} h · aμ) = ru^{ Mon_V }_{ t} · h). etrans. 2: { apply monoidal_rightunitornat. } etrans. 2: { apply maponpaths. apply (pr12 Hμη). } repeat rewrite assoc. apply cancel_postcomposition. rewrite (bifunctor_equalwhiskers Mon_V). unfold functoronmorphisms2. rewrite assoc. etrans. { apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V t)). } rewrite auxη. apply pathsinv0, (bifunctor_equalwhiskers Mon_V). -- change (t ⊗^{Mon_V}_{l} τ · (h ⊗^{ Mon_V} h · aμ) = θ (t,, η) t · # H (h ⊗^{ Mon_V} h · aμ) · aτ). etrans. 2: { apply cancel_postcomposition. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. transparent assert (h_ptd : (PtdV⟦(t,,η),(av,,aη)⟧)). { exists h. exact auxη. } apply (lineator_is_nattrans_full Mon_PtdV Act Act H (lineator_linnatleft _ _ _ _ θ) (lineator_linnatright _ _ _ _ θ)_ _ _ _ h_ptd h). } etrans. 2: { repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply pathsinv0, Hτ. } repeat rewrite assoc. apply cancel_postcomposition. change (t ⊗^{Mon_V}_{l} τ · h ⊗^{Mon_V} h = h ⊗^{Mon_V} #H h · av ⊗^{Mon_V}_{l} aτ). etrans. 2: { unfold functoronmorphisms1. rewrite assoc'. apply maponpaths. apply (functor_comp (leftwhiskering_functor Mon_V av)). } rewrite <- auxτ. etrans. { rewrite (bifunctor_equalwhiskers Mon_V). unfold functoronmorphisms2. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V t)). } apply pathsinv0, (bifunctor_equalwhiskers Mon_V). * apply pathsinv0, path_to_ctr. red; split. -- change (t ⊗^{Mon_V}_{l} η · (μ · h) = ru^{ Mon_V }_{ t} · h). rewrite assoc. etrans. { apply cancel_postcomposition. apply (monoid_to_unit_right_law Mon_V (pr212 σ)). } apply idpath. -- change (t ⊗^{Mon_V}_{l} τ · (μ · h) = θ (t,, η) t · # H (μ · h) · aτ). rewrite assoc. etrans. { apply cancel_postcomposition. apply pathsinv0, (pr22 σ). } repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, functor_comp. } rewrite assoc'. apply maponpaths. exact auxτ. - hnf. intros [ah Hyp]. use total2_paths_f. { apply (path_to_ctr _ _ It_inst). cbn in Hyp. split. + exact (pr11 Hyp). + exact (pr221 Hyp). } show_id_type. assert (aux: isaprop TYPE). { apply isapropdirprod. + apply isapropdirprod. * apply V. * apply isaprop_is_monoid_mor. + apply isapropunit. } apply aux. Qed. Definition SigmaMonoidFromInitialAlgebraInitial : Initial (SigmaMonoid θ) := σ,,SigmaMonoidFromInitialAlgebra_is_initial. End InitialAlgebraToMHSS. End FixTheContext. UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignature/000077500000000000000000000000001451125700300250075ustar00rootroot00000000000000CommutingOfOmegaLimitsAndCoproducts.v000066400000000000000000000236741451125700300342060ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignatureRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors. Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas. Local Open Scope cat. Section OmegaLimitsCommutingWithCoproducts. (* We ask for the canonical morphism from canonical : ∐ ω-lim -> ω-lim ∐ to be an isomorphism. *) Context (C : category). Context (ω_lim_given : Lims_of_shape conat_graph C). Context {I : UU} (Iset : isaset I). Context (coproducts_given : Coproducts I C). Variable (ind : I → cochain C). Let coproduct_n (n : nat) := coproducts_given (λ i, pr1 (ind i) n). Definition coproduct_n_cochain : cochain C. Proof. exists (λ n, pr11 (coproduct_n n)). intros n m f. use CoproductArrow. exact (λ j, pr2 (ind j) n m f · CoproductIn I C (coproducts_given (λ i0 : I, pr1 (ind i0) m)) j). Defined. Definition limit_of_coproduct := ω_lim_given coproduct_n_cochain. Definition coproduct_of_limit := coproducts_given (λ i, pr11 (ω_lim_given (ind i))). Definition limit_of_coproduct_as_cone_of_coproduct_to_limit : cone coproduct_n_cochain (pr11 coproduct_of_limit). Proof. use tpair. - intro n. use CoproductOfArrows. exact (λ i, pr1 (pr21 (ω_lim_given (ind i))) n). - intros n m p. cbn. etrans. 1: apply precompWithCoproductArrow. use CoproductArrowUnique. intro i. etrans. 1: apply (CoproductInCommutes _ _ _ coproduct_of_limit _ ( (λ i0 : I, (pr121 (ω_lim_given (ind i0))) n · (pr2 (ind i0) n m p · CoproductIn I C (coproducts_given (λ i1 : I, pr1 (ind i1) m)) i0)))). etrans. 1: apply assoc. apply maponpaths_2. exact (pr221 (ω_lim_given (ind i)) n m p). Defined. Definition coproduct_of_limit_to_limit_of_coproduct : pr11 coproduct_of_limit --> pr11 limit_of_coproduct := pr11 (pr2 limit_of_coproduct _ limit_of_coproduct_as_cone_of_coproduct_to_limit). Definition coproduct_distribute_over_omega_limits := is_z_isomorphism coproduct_of_limit_to_limit_of_coproduct. End OmegaLimitsCommutingWithCoproducts. Definition ω_limits_distribute_over_I_coproducts (C : category) (I : HSET) (ω_lim : Lims_of_shape conat_graph C) (coprd : Coproducts (pr1 I) C) : UU := ∏ ind, coproduct_distribute_over_omega_limits C ω_lim coprd ind. (* A coproducts of omega-continuous functors is in general not omega-continuous. This boils down to the commutativity of ω-limits and coproducts. *) Section CoproductOfFunctorsContinuity. Context (D : category) (I : HSET) (ω_lim : Lims_of_shape conat_graph D) (CP : Coproducts (pr1 I) D). Definition ω_complete_functor_cat : ∏ C : category, Lims_of_shape conat_graph [C, D]. Proof. intro C; apply LimsFunctorCategory_of_shape, ω_lim. Defined. Let coproduct_functor_cat : ∏ C : category, Coproducts (pr1 I) [C,D] := λ C, Coproducts_functor_precat (pr1 I) C D CP. Definition functor_category_ω_limits_distribute_over_I_coproducts : ω_limits_distribute_over_I_coproducts D I ω_lim CP -> ∏ C : category, ω_limits_distribute_over_I_coproducts [C,D] I (ω_complete_functor_cat C) (coproduct_functor_cat C). Proof. intros distr C ind. use nat_trafo_z_iso_if_pointwise_z_iso. intro c. transparent assert (ind_c : (pr1 I -> cochain D)). { intro i. exists (λ n, pr1 (pr1 (ind i) n) c). exact (λ n m p, pr1 (pr2 (ind i) n m p) c). } exists (pr1 (distr ind_c)). split. - refine (_ @ pr12 (distr ind_c)). apply maponpaths_2. use limArrowUnique ; intro. use CoproductArrowUnique ; intro. etrans. 1: { apply maponpaths. apply (limArrowCommutes (ω_lim (diagram_pointwise (coproduct_n_cochain [C, D] (coproduct_functor_cat C) ind) c))). } apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, lim (ω_lim (ind_c i0))))). - refine (_ @ pr22 (distr ind_c)). apply maponpaths. use limArrowUnique ; intro. use CoproductArrowUnique ; intro. etrans. 1: { apply maponpaths. apply (limArrowCommutes (ω_lim (diagram_pointwise (coproduct_n_cochain [C, D] (coproduct_functor_cat C) ind) c))). } apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, lim (ω_lim (ind_c i0))))). Defined. Definition coproduct_of_functors_omega_cont (C : category) (F : (pr1 I) → C ⟶ D) (ω_distr : ω_limits_distribute_over_I_coproducts D I ω_lim CP) : (∏ i : pr1 I, is_omega_cont (F i)) -> is_omega_cont (coproduct_of_functors _ _ _ CP F). Proof. intro Fi_cont. intros coch l l_cone l_lim. use limits.is_z_iso_isLim. { apply ω_lim. } transparent assert (ind : (pr1 I -> cochain D)). { intro i. exists (λ n, F i (pr1 coch n)). exact (λ n m p, #(F i) (pr2 coch n m p)). } set (distr := ω_distr ind). set (distr1 := pr1 distr). unfold limit_of_coproduct in distr1. unfold coproduct_of_limit in distr1. use make_is_z_isomorphism. - refine (distr1 · _). use CoproductOfArrows. intro i. set (Fi_l := Fi_cont i coch l l_cone l_lim). apply (pr1 (isLim_is_z_iso _ _ _ _ Fi_l)). (* apply (Fi_l (pr11 (ω_lim (ind i))) (pr21 (ω_lim (ind i)))). *) - split. + cbn. transparent assert (i_iso : (is_z_isomorphism (CoproductOfArrows (pr1 I) D (CP (λ i : pr1 I, pr11 (ω_lim (ind i)))) (CP (λ i : pr1 I, F i l)) (λ i : pr1 I, limArrow (make_LimCone (mapdiagram (F i) coch) (F i l) (mapcone (F i) coch l_cone) (Fi_cont i coch l l_cone l_lim)) (lim (ω_lim (ind i))) (limCone (ω_lim (ind i))))))). { use CoproductOfArrowsIsos. intro i. set (Fi_l := Fi_cont i coch l l_cone l_lim). apply (pr2 (z_iso_inv (_ ,, isLim_is_z_iso _ _ _ _ Fi_l))). } etrans. 1: apply assoc. use (z_iso_inv_to_right _ _ _ _ (_ ,, i_iso)). etrans. 2: apply pathsinv0, id_left. use CoproductArrowUnique. intro i. cbn. etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, postCompWithLimArrow. use (z_iso_inv_to_right _ _ _ _ (distr1 ,, _)). { unfold coproduct_distribute_over_omega_limits in distr. apply (pr2 (z_iso_inv (_,,distr))). } apply pathsinv0, limArrowUnique. intro n. cbn. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. set (t := limArrowCommutes (ω_lim (mapdiagram (coproduct_of_functors (pr1 I) C D CP F) coch))). exact (t (pr11 (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))) (limit_of_coproduct_as_cone_of_coproduct_to_limit D ω_lim CP ind) n). } cbn. unfold CoproductOfArrows. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))). } etrans. 2: apply pathsinv0, (CoproductInCommutes _ _ _ (CP (λ j : pr1 I, F j l))). etrans. 1: apply assoc. apply maponpaths_2. exact (limArrowCommutes (ω_lim (ind i)) (F i l) (mapcone (F i) coch l_cone) n). + cbn. etrans. 1: apply assoc'. apply pathsinv0. use (z_iso_inv_to_left _ _ _ (_,,_)). { unfold coproduct_distribute_over_omega_limits in distr. apply (pr2 (z_iso_inv (_,,distr))). } etrans. 1: apply id_right. apply pathsinv0. use limArrowUnique. intro n. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (limArrowCommutes (ω_lim (mapdiagram (coproduct_of_functors (pr1 I) C D CP F) coch))). } etrans. 1: apply CoproductOfArrows_comp. use CoproductArrowUnique. intro i. etrans. 1: apply (CoproductInCommutes _ _ _ (CP (λ i0 : pr1 I, pr11 (ω_lim (ind i0))))). apply maponpaths_2. exact (limArrowCommutes ( (make_LimCone (mapdiagram (F i) coch) (F i l) (mapcone (F i) coch l_cone) (Fi_cont i coch l l_cone l_lim))) _ (pr21 (ω_lim (ind i))) n). Defined. End CoproductOfFunctorsContinuity. ContinuityOfMultiSortedSigToFunctor.v000066400000000000000000000377021451125700300342650ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignature(* - Proof that the functor obtained from a multisorted binding signature is omega-cocontinuous ([is_omega_cont_MultiSortedSigToFunctor]) *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors. Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas. Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts. Local Open Scope cat. Section FixTheContext. Variables (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). Variables (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). (** Define the discrete category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. Lemma sortToC1_binproducts : BinProducts [sortToC, sortToC]. Proof. repeat (apply BinProducts_functor_precat) ; exact BP. Defined. (* not used in the present file *) Lemma sortToC1_coproducts : ∏ I : UU, isaset I -> Coproducts I [sortToC, sortToC]. Proof. intros I Iset. repeat (apply Coproducts_functor_precat) ; exact (CC I Iset). Defined. Section DefinitionOfMultiSortedSigToFunctorPrime. Definition hat_exp_functor_list'_piece (xt : (list sort × sort) × sort) : functor [sortToC,sortToC] [sortToC,sortToC]. Proof. induction xt as [[si s] t]. set (op_f := option_list sort Hsort C TC BC CC si). refine (functor_composite (pre_comp_functor op_f) _). set (prs := projSortToC sort Hsort C s). set (hatt := hat_functor sort Hsort C CC t). set (prshatt := functor_composite prs hatt). exact (post_comp_functor prshatt). Defined. Definition hat_exp_functor_list' (xst : list (list sort × sort) × sort) : functor [sortToC,sortToC] [sortToC,sortToC]. Proof. induction xst as [a t]. (* a := [a1,...,am] Each ai := ([si_1, ... si_n],si) *) set (T := constant_functor [sortToC,sortToC] [sortToC,C] (constant_functor sortToC C TC)). set (TT := (functor_composite T (post_comp_functor (hat_functor sort Hsort C CC t)))). use (list_ind _ _ _ a). - exact TT. - intros ap ap1 ap_func. use (BinProduct_of_functors _ ap_func (hat_exp_functor_list'_piece (ap,,t))). repeat (apply BinProducts_functor_precat) ; exact BP. Defined. (** optimized version that does not introduce the terminal element in the singleton case: *) Definition hat_exp_functor_list'_optimized (xst : list (list sort × sort) × sort) : functor [sortToC,sortToC] [sortToC,sortToC]. Proof. induction xst as [xs t]. set (T := constant_functor [sortToC,sortToC] [sortToC,C] (constant_functor sortToC C TC)). set (TT := (functor_composite T (post_comp_functor (hat_functor sort Hsort C CC t)))). set (HH := fun ap => (hat_exp_functor_list'_piece (ap,,t))). exact (foldr1_map (λ F G, BinProduct_of_functors sortToC1_binproducts F G) TT HH xs). Defined. Definition MultiSortedSigToFunctor' (M : MultiSortedSig sort) : functor [sortToC,sortToC] [sortToC,sortToC]. Proof. use (coproduct_of_functors (ops sort M)). + apply Coproducts_functor_precat, Coproducts_functor_precat, CC, setproperty. + intros op. exact (hat_exp_functor_list'_optimized (arity sort M op)). Defined. End DefinitionOfMultiSortedSigToFunctorPrime. (** * the following is a deviation from the main topic of this file *) Section OmegaCocontinuityOfMultiSortedSigToFunctorPrime. Let BPCsortToC : BinProducts sortToC := BinProducts_functor_precat _ C BP. Let BPC1 : BinProducts [sortToC,sortToC] := BinProducts_functor_precat sortToC sortToC BPCsortToC. Context (expSortToC1 : Exponentials BPC1) (** this requires exponentials in a higher space than before *) (HC : Colims_of_shape nat_graph C). Local Lemma is_omega_cocont_hat_exp_functor_list'_piece (xt : (list sort × sort) × sort) : is_omega_cocont (hat_exp_functor_list'_piece xt). Proof. apply is_omega_cocont_functor_composite. - apply is_omega_cocont_pre_composition_functor. apply (ColimsFunctorCategory_of_shape nat_graph sort_cat _ HC). - use is_omega_cocont_post_composition_functor. apply is_left_adjoint_functor_composite. + apply MultiSorted_alt.is_left_adjoint_projSortToC, PC. + apply MultiSorted_alt.is_left_adjoint_hat. Defined. Local Lemma is_omega_cocont_hat_exp_functor_list' (xst : list (list sort × sort) × sort) : is_omega_cocont (hat_exp_functor_list' xst). Proof. induction xst as [xs t]. revert t. use (list_ind (fun xs => ∏ t : sort, is_omega_cocont (hat_exp_functor_list' (xs,, t))) _ _ xs). - intro t. apply is_omega_cocont_functor_composite. + apply is_omega_cocont_constant_functor. + apply is_omega_cocont_post_composition_functor, MultiSorted_alt.is_left_adjoint_hat. - intros ap ap1 ap_func t. apply is_omega_cocont_BinProduct_of_functors. * apply BinProducts_functor_precat, BinProducts_functor_precat, BP. * apply is_omega_cocont_constprod_functor1. apply expSortToC1. * apply (ap_func t). * apply is_omega_cocont_hat_exp_functor_list'_piece. Defined. Local Lemma is_omega_cocont_hat_exp_functor_list'_optimized (xst : list (list sort × sort) × sort) : is_omega_cocont (hat_exp_functor_list'_optimized xst). Proof. induction xst as [xs t]. revert t. induction xs as [[|n] xs]. - induction xs. intro t. apply is_omega_cocont_functor_composite. + apply is_omega_cocont_constant_functor. + apply is_omega_cocont_post_composition_functor, MultiSorted_alt.is_left_adjoint_hat. - induction n as [|n IH]. + induction xs as [m []]. change (1,, m,, tt) with (cons m nil). intro t. unfold hat_exp_functor_list'_optimized. rewrite foldr1_map_cons_nil. apply is_omega_cocont_hat_exp_functor_list'_piece. + induction xs as [m [k xs]]. intro t. assert (IHinst := IH (k,,xs) t). change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))). unfold hat_exp_functor_list'_optimized. rewrite foldr1_map_cons. change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst. unfold hat_exp_functor_list'_optimized in IHinst. apply is_omega_cocont_BinProduct_of_functors. * apply sortToC1_binproducts. * apply is_omega_cocont_constprod_functor1. apply expSortToC1. * apply is_omega_cocont_hat_exp_functor_list'_piece. * exact IHinst. Defined. Lemma is_omega_cocont_MultiSortedSigToFunctor' (M : MultiSortedSig sort) : is_omega_cocont (MultiSortedSigToFunctor' M). Proof. apply is_omega_cocont_coproduct_of_functors. intros op; apply is_omega_cocont_hat_exp_functor_list'_optimized. Defined. End OmegaCocontinuityOfMultiSortedSigToFunctorPrime. Section OmegaContinuityOfMultiSortedSigToFunctorPrime. Variable (LC : Lims_of_shape conat_graph C). Variable (distr : ∏ I : HSET, ω_limits_distribute_over_I_coproducts C I LC (CC (pr1 I) (pr2 I))). (* Should also be split up into multiple definitions/lemmas *) Lemma post_comp_with_pr_and_hat_is_omega_cont (s t : sort) : is_omega_cont (post_comp_functor (A := sortToC) (projSortToC sort Hsort C s ∙ hat_functor sort Hsort C CC t) ). Proof. intros coch L con isLimcon. apply limits.pointwise_Lim_is_isLimFunctor ; intro F. apply limits.pointwise_Lim_is_isLimFunctor ; intro G. use limits.is_z_iso_isLim. { apply LC. } transparent assert (x : (t = G → cochain C)). { intro p. use tpair. - intro n. exact (pr1 (pr1 (dob coch n) F) s). - intros n m q. exact (pr1 (pr1 (dmor coch q) F) s). } use make_is_z_isomorphism. - refine (pr1 (distr (_,,Hsort t G) x) · _). assert (bla : (∏ a : sortToC, LimCone (diagram_pointwise coch a))). { intro ; apply ω_complete_functor_cat ; exact LC. } assert (bla' : (∏ a : path_pregroupoid sort Hsort, LimCone (diagram_pointwise (diagram_pointwise coch F) a))). { intro ; apply LC. } set (LF_lim := limits.isLimFunctor_is_pointwise_Lim coch bla _ _ isLimcon F). set (LFs_lim := limits.isLimFunctor_is_pointwise_Lim _ bla' _ _ LF_lim s). set (LFs_cone := make_LimCone _ _ _ LFs_lim). use CoproductOfArrows. intro i. (* The following proof "justifies" the exact statement *) (* assert (diagram_pointwise (diagram_pointwise coch F) s = x i). { apply idpath. } *) exact (pr1 (z_iso_inv (z_iso_from_lim_to_lim LFs_cone (LC (x i))))). - split. + etrans. 1: apply assoc. use (z_iso_inv_to_right _ _ _ _ (_ ,, CoproductOfArrowsIsos _ _ _ _ _ _ _ _: z_iso _ _)). { intro ; apply (pr2 (z_iso_inv _)). } rewrite ! id_left. use (z_iso_inv_to_right _ _ _ _ (z_iso_inv (make_z_iso _ _ (pr2 (distr _ _))))). apply pathsinv0, limArrowUnique. intro n. rewrite assoc'. etrans. 1: { apply maponpaths. apply limArrowCommutes. } etrans. 1: { apply precompWithCoproductArrow. } cbn. unfold CoproductOfArrows. apply maponpaths. apply funextsec ; intro p. rewrite ! assoc. apply maponpaths_2. apply (graphs.limits.limArrowCommutes (LC (x p))). + etrans. 1: apply assoc'. apply pathsinv0. transparent assert (d_i : (is_z_isomorphism ( pr1 (distr ((t = G),, Hsort t G) x)))). { exists (coproduct_of_limit_to_limit_of_coproduct C LC (CC (t = G) (Hsort t G)) x). set (q := distr ((t = G),, Hsort t G) x). split ; apply (pr2 q). } use (z_iso_inv_to_left _ _ _ (_,,d_i)). refine (id_right _ @ _). use (z_iso_inv_to_left _ _ _ (CoproductOfArrows _ _ _ _ _,, _ : z_iso _ _)). { use CoproductOfArrowsIsos ; intro. apply is_z_iso_inv_from_z_iso. } apply limArrowUnique. intro n. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (limArrowCommutes (LC (diagram_pointwise (diagram_pointwise (mapdiagram (post_comp_functor (projSortToC sort Hsort C s ∙ hat_functor sort Hsort C CC t)) coch) F) G))). } etrans. 1: { apply precompWithCoproductArrow. } cbn. unfold CoproductOfArrows. apply maponpaths. apply funextsec ; intro p. rewrite ! assoc. apply maponpaths_2. apply (graphs.limits.limArrowCommutes (LC (x p))). Defined. (* In case no constructors were given, i.e. just H := Id. *) Lemma pre_comp_option_list_omega_cont (xst : (list sort × sort) × sort) : is_omega_cont (pre_comp_functor (C := sortToC) (option_list sort Hsort C TC BC CC (pr11 xst))). Proof. apply is_omega_cont_pre_composition_functor'. intro. apply ω_complete_functor_cat ; exact LC. Defined. Lemma is_omega_cont_hat_exp_functor_list'_piece (xst : (list sort × sort) × sort) : is_omega_cont (hat_exp_functor_list'_piece xst). Proof. apply is_omega_cont_functor_composite. - exact (pre_comp_option_list_omega_cont xst). - exact (post_comp_with_pr_and_hat_is_omega_cont (pr21 xst) (pr2 xst)). Defined. Lemma is_omega_cont_hat_exp_functor_list' (xst : list (list sort × sort) × sort) : is_omega_cont (hat_exp_functor_list' xst). Proof. induction xst as [a t] ; revert a. use list_ind. - use nat_z_iso_preserve_ωlimits. 3: apply nat_z_iso_inv, constant_functor_composition_nat_z_iso. apply is_omega_cont_constant_functor. - intros x xs IHn. apply is_omega_cont_BinProduct_of_functors. + apply IHn. + apply is_omega_cont_hat_exp_functor_list'_piece. Defined. Lemma is_omega_cont_hat_exp_functor_list'_optimized (xst : list (list sort × sort) × sort) : is_omega_cont (hat_exp_functor_list'_optimized xst). Proof. induction xst as [xs t]. revert t. induction xs as [[|n] xs]. - induction xs. intro t. use nat_z_iso_preserve_ωlimits. 3: apply nat_z_iso_inv, constant_functor_composition_nat_z_iso. apply is_omega_cont_constant_functor. - induction n as [|n IH]. + induction xs as [m []]. change (1,, m,, tt) with (cons m nil). intro t. unfold hat_exp_functor_list'_optimized. rewrite foldr1_map_cons_nil. apply is_omega_cont_hat_exp_functor_list'_piece. + induction xs as [m [k xs]]. intro t. assert (IHinst := IH (k,,xs) t). change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))). unfold hat_exp_functor_list'_optimized. rewrite foldr1_map_cons. change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst. unfold hat_exp_functor_list'_optimized in IHinst. apply is_omega_cont_BinProduct_of_functors. * apply is_omega_cont_hat_exp_functor_list'_piece. * exact IHinst. Defined. (** The functor obtained from a multisorted binding signature is omega-continuous *) Lemma is_omega_cont_MultiSortedSigToFunctor' (M : MultiSortedSig sort) : is_omega_cont (MultiSortedSigToFunctor' M). Proof. use coproduct_of_functors_omega_cont. - do 2 apply ω_complete_functor_cat ; exact LC. - do 2 apply functor_category_ω_limits_distribute_over_I_coproducts ; apply distr. - intro ; apply is_omega_cont_hat_exp_functor_list'_optimized. Defined. End OmegaContinuityOfMultiSortedSigToFunctorPrime. End FixTheContext. UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignature/GeneralLemmas.v000066400000000000000000000157451451125700300277260ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.limits.coproducts. (** only for the last constructions that should be moved to [CategoryTheory.Chains.Omegacontfunctors] *) Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Local Open Scope cat. Lemma CoproductOfArrowsIsos_aux (I : UU) (C : category) (a : I -> C) (CC : Coproduct I C a) (c : I -> C) (CC' : Coproduct I C c) (f : ∏ i : I, C⟦a i, c i⟧) (fi_iso :∏ i : I, is_z_isomorphism (f i)) : is_inverse_in_precat (CoproductOfArrows I C CC CC' f) (CoproductOfArrows I C CC' CC (λ i : I, pr1 (fi_iso i))). Proof. split. + etrans. { apply precompWithCoproductArrow. } apply pathsinv0, CoproductArrowUnique. intro i. refine (id_right _ @ ! id_left _ @ _). refine (_ @ assoc' _ _ _). apply maponpaths_2. apply pathsinv0, (pr2 (fi_iso i)). + etrans. { apply precompWithCoproductArrow. } apply pathsinv0, CoproductArrowUnique. intro i. refine (id_right _ @ ! id_left _ @ _). refine (_ @ assoc' _ _ _). apply maponpaths_2. apply pathsinv0, (pr2 (fi_iso i)). Qed. Definition CoproductOfArrowsIsos (I : UU) (C : category) (a : I -> C) (CC : Coproduct I C a) (c : I -> C) (CC' : Coproduct I C c) (f : ∏ i : I, C⟦a i, c i⟧) : (∏ i : I, is_z_isomorphism (f i)) -> is_z_isomorphism (CoproductOfArrows I C CC CC' f). Proof. intro fi_iso. use make_is_z_isomorphism. - use CoproductOfArrows. exact (λ i, pr1 (fi_iso i)). - apply CoproductOfArrowsIsos_aux. Defined. Lemma constant_functor_composition_nat_trans (A B C : category) (b : B) (F : functor B C) : nat_trans (functor_composite (constant_functor A B b) F) (constant_functor A C (F b)). Proof. use make_nat_trans. + intro; apply identity. + abstract (intro; intros; apply maponpaths_2; exact (functor_id F b)). Defined. Lemma constant_functor_composition_nat_z_iso (A B C : category) (b : B) (F : functor B C) : nat_z_iso (functor_composite (constant_functor A B b) F) (constant_functor A C (F b)). Proof. exists (constant_functor_composition_nat_trans A B C b F). intro; apply identity_is_z_iso. Defined. Lemma coproduct_of_functors_nat_trans_aux {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D} (α : ∏ i : I, nat_trans (F i) (G i)) : is_nat_trans (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G) (λ c : C, CoproductOfArrows I D (CP (λ i : I, F i c)) (CP (λ i : I, G i c)) (λ i : I, α i c)). Proof. intros c1 c2 f. etrans. 1: apply precompWithCoproductArrow. etrans. 2: apply pathsinv0, precompWithCoproductArrow. apply maponpaths. apply funextsec ; intro i. etrans. 1: apply assoc. etrans. 2: apply assoc'. apply maponpaths_2. exact (pr2 (α i) _ _ f). Qed. Lemma coproduct_of_functors_nat_trans {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D} (α : ∏ i : I, nat_trans (F i) (G i)) : nat_trans (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G). Proof. use make_nat_trans. - intro c. use CoproductOfArrows. exact (λ i, α i c). - apply coproduct_of_functors_nat_trans_aux. Defined. Lemma coproduct_of_functors_is_inverse {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D} (α : ∏ i : I, nat_z_iso (F i) (G i)) (c : C) : is_inverse_in_precat (coproduct_of_functors_nat_trans CP (λ i : I, α i) c) (CoproductOfArrows I D (CP (λ i : I, G i c)) (CP (λ i : I, F i c)) (λ i : I, pr1 (pr2 (α i) c))). Proof. split. + etrans. 1: apply precompWithCoproductArrow. apply pathsinv0, CoproductArrowUnique. intro i. etrans. 2: apply assoc'. etrans. 2: apply maponpaths_2, pathsinv0, (pr2 (pr2 (α i) c)). exact (id_right _ @ ! id_left _). + etrans. 1: apply precompWithCoproductArrow. apply pathsinv0, CoproductArrowUnique. intro i. etrans. 2: apply assoc'. etrans. 2: apply maponpaths_2, pathsinv0, (pr2 (pr2 (α i) c)). exact (id_right _ @ ! id_left _). Qed. Lemma coproduct_of_functors_nat_z_iso {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D} (α : ∏ i : I, nat_z_iso (F i) (G i)) : nat_z_iso (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G). Proof. exists (coproduct_of_functors_nat_trans CP α). intro c. use tpair. - use CoproductOfArrows. exact (λ i, pr1 (pr2 (α i) c)). - apply coproduct_of_functors_is_inverse. Defined. (* The following lemmas has to be moved accordingly, e.g. in the file CategoryTheory.Chains.Omegacontfunctors *) Lemma nat_trans_preserve_cone {A B : category} {F G : functor A B} (α : nat_trans F G) {coch : cochain A} {b : B} (b_con : cone (mapdiagram F coch) b) : cone (mapdiagram G coch) b. Proof. exists (λ v, pr1 b_con v · α (dob coch v)). intros u v p. etrans. 1: apply assoc'. cbn. etrans. 1: apply maponpaths, pathsinv0, (pr2 α). etrans. 1: apply assoc. apply maponpaths_2. exact (pr2 b_con u v p). Defined. Lemma nat_z_iso_preserve_ωlimits {A B : category} (F G : functor A B) : is_omega_cont F -> nat_z_iso F G -> is_omega_cont G. Proof. (* This lemma should be split up in data and property and there is also a repeat of proof, need a more "general, but easy" lemma. *) intros Fc i. intros coch a a_con a_lim. intros b b_con. set (b'_con := nat_trans_preserve_cone (nat_z_iso_inv i) b_con). set (t := Fc coch a a_con a_lim b b'_con). use tpair. - exists (pr11 t · pr1 i a). intro v. etrans. 1: apply assoc'. etrans. 1: apply maponpaths, pathsinv0, (pr21 i). etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, (pr21 t v). etrans. 1: apply assoc'. etrans. 1: apply maponpaths, (pr2 i (dob coch v)). apply id_right. - intro f. use total2_paths_f. + use (cancel_z_iso _ _ (_ ,, pr2 (nat_z_iso_inv i) a)). etrans. 2: apply assoc. etrans. 2: apply maponpaths, pathsinv0, (pr2 (pr2 i a)). etrans. 2: apply pathsinv0, id_right. transparent assert (c' : (∑ x : B ⟦ b, F a ⟧, limits.is_cone_mor b'_con (limits.mapcone F coch a_con) x)). { exists (pr1 f · pr1 (pr2 i a)). intro v. cbn. etrans. 1: apply assoc'. etrans. 1: apply maponpaths, pathsinv0, (pr21 (nat_z_iso_inv i)). etrans. 1: apply assoc. apply maponpaths_2, (pr2 f v). } exact (base_paths _ _ (pr2 t c')). + apply (impred_isaprop) ; intro ; apply homset_property. Defined. UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignature/InstantiateHSET.v000066400000000000000000000172031451125700300301500ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors. Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas. Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts. Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor. Require Import UniMath.SubstitutionSystems.ContinuitySignature.MultiSortedSignatureFunctorEquivalence. Local Open Scope cat. Section CoproductsIndexedOverHPropCommutesWithBinproductsInSET. Definition propcoproducts_commute_binproductsHSET : propcoproducts_commute_binproducts HSET BinProductsHSET (λ p, CoproductsHSET p (isasetaprop (pr2 p))). Proof. intros p x y. use make_is_z_isomorphism. - intros [ix iy]. exists (pr1 ix). exact (pr2 ix,,pr2 iy). - split. + apply funextsec ; intro ixy. apply idpath. + apply funextsec ; intros [ix iy]. use total2_paths_f. * apply idpath. * use total2_paths_f. -- apply (pr2 p). -- cbn. induction (pr1 (pr2 p (pr1 ix) (pr1 iy))). apply idpath. Defined. End CoproductsIndexedOverHPropCommutesWithBinproductsInSET. Section OmegaLimitsCommutingWithCoproductsHSET. Definition HSET_ω_limits : Lims_of_shape conat_graph HSET. Proof. intro coch. apply LimConeHSET. Defined. Lemma cochain_on_n_is_zero {I : HSET} (ind : pr1 I → cochain SET) (f : pr111 (limit_of_coproduct SET HSET_ω_limits (CoproductsHSET (pr1 I) (pr2 I)) ind)) : ∏ n : nat, pr1 (pr1 f n) = pr1 (pr1 f 0). Proof. induction f as [f p]. assert (q0 : ∏ n : nat, S n = n + 1). { exact (λ n, ! natpluscomm n 1). } assert (q : ∏ n : nat, pr1 (f (n+1)) = pr1 (f n)). { exact (λ n, base_paths _ _ (p (n+1) n (q0 n))). } assert (q' : ∏ n : nat, pr1 (f (S n)) = pr1 (f n)). { intro n. refine (_ @ q n). apply (maponpaths (λ z, pr1 (f z))). exact (q0 n). } intro n. induction n. - apply idpath. - exact (q' n @ IHn). Defined. Local Lemma dmor_distribute_over_transport_ω {I : UU} (J : I -> nat -> hSet) (Jmor : ∏ i : I, ∏ n : nat, J i (S n) -> J i n) (f0 : nat -> I) (f : ∏ n : nat, J (f0 n) n) (m : nat) (p : ∏ n : nat, f0 n = f0 0) : Jmor (f0 0) m (transportf (λ i : I, J i (S m)) (p (S m)) (f (S m))) = transportf (λ i : I, J i m) (p (S m)) (Jmor (f0 (S m)) _ (f (S m))). Proof. induction (p (S m)). apply idpath. Qed. Definition I_coproduct_distribute_over_omega_limit_HSET_inverse {I : HSET} (ind : pr1 I → cochain SET) : SET ⟦ pr11 (limit_of_coproduct SET HSET_ω_limits (CoproductsHSET (pr1 I) (pr2 I)) ind), pr11 (coproduct_of_limit SET HSET_ω_limits (CoproductsHSET (pr1 I) (pr2 I)) ind) ⟧. Proof. intros [f p]. exists (pr1 (f 0)). exists (λ n, transportf (λ u, pr1 (dob (ind u) n)) ((cochain_on_n_is_zero ind (f,,p) n)) (pr2 (f n))). intros n m h. etrans. 2: { apply maponpaths. exact (fiber_paths (p n m h)). } rewrite transport_f_f. cbn. set (q := base_paths (pr1 (f n),, pr2 (ind (pr1 (f n))) n m h (pr2 (f n))) (f m) (p n m h) @ cochain_on_n_is_zero ind (f,, p) m). set (q' := cochain_on_n_is_zero ind (f,,p) n). assert (q0 : q = q'). { apply (pr2 I). } etrans. 2: { apply maponpaths_2. exact (! q0). } set (J := λ i n, (pr1 (ind i) n)). transparent assert (Jmor : (∏ (i : pr1 I) (n : nat), pr1 (J i (S n)) → pr1 (J i n))). { intros i0 n0. use (dmor (ind i0)). apply idpath. } set (f0 := λ n0, pr1 (f n0)). transparent assert (f' : (∏ n : nat, pr1 (J (f0 n) n))). { exact (λ n0, pr2 (f n0)). } transparent assert (p' : (∏ n : nat, f0 n = f0 0)). { exact (cochain_on_n_is_zero ind (f,,p)). } induction h. exact (dmor_distribute_over_transport_ω J Jmor f0 f' m p'). Defined. Definition I_coproduct_distribute_over_omega_limits_HSET (I : HSET) : ω_limits_distribute_over_I_coproducts HSET I HSET_ω_limits (CoproductsHSET (pr1 I) (pr2 I)). Proof. intro ind. use make_is_z_isomorphism. - exact (I_coproduct_distribute_over_omega_limit_HSET_inverse ind). - split. + apply funextsec ; intros [i [f p]]. use total2_paths_f. { apply idpath. } use total2_paths_f. 2: { repeat (apply funextsec ; intro). apply (pr2 (dob (ind (pr1 (identity (pr11 (coproduct_of_limit SET HSET_ω_limits (CoproductsHSET (pr1 I) (pr2 I)) ind)) _))) _)). } rewrite idpath_transportf. repeat (apply funextsec ; intro). apply (transportf_set ((λ u : pr1 I, pr1 (dob (ind u) x)))). apply (pr2 I). + apply funextsec ; intros [f p]. use total2_paths_f. * apply funextsec ; intro n. use total2_paths_f. { exact (! cochain_on_n_is_zero ind (f,,p) n). } cbn. etrans. 1: apply (transport_f_f (λ x : pr1 I, pr1 (pr1 (ind x) n))). etrans. 1: apply maponpaths_2, pathsinv0r. apply (idpath_transportf (λ x : pr1 I, pr1 (pr1 (ind x) n))). * repeat (apply funextsec ; intro). apply ( dob (coproduct_n_cochain SET (CoproductsHSET (pr1 I) (pr2 I)) ind) _). Defined. End OmegaLimitsCommutingWithCoproductsHSET. Lemma is_omega_cont_MultiSortedSigToFunctor_HSET (sort : UU) (Hsort_set : isaset sort) (M : MultiSortedSig sort) : is_omega_cont (MultiSortedSigToFunctor sort (hlevelntosn 2 _ Hsort_set) HSET TerminalHSET BinProductsHSET BinCoproductsHSET CoproductsHSET M). Proof. use is_omega_cont_MultiSortedSigToFunctor. - exact InitialHSET. - exact ProductsHSET. - exact HSET_ω_limits. - exact propcoproducts_commute_binproductsHSET. - exact I_coproduct_distribute_over_omega_limits_HSET. Defined. MultiSortedSignatureFunctorEquivalence.v000066400000000000000000000731311451125700300350040ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/ContinuitySignatureRequire Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors. Require Import UniMath.SubstitutionSystems.ContinuitySignature.GeneralLemmas. Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts. Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor. Require Import UniMath.CategoryTheory.limits.Preservation. Local Open Scope cat. Section B. Lemma make_isBinProduct' {C : category} {x y : C} (Pxy : BinProduct _ x y) (z : C) (zx : C⟦z,x⟧) (zy : C⟦z,y⟧) : (∑ i : is_z_isomorphism (BinProductArrow C Pxy zx zy), pr1 i · zx = BinProductPr1 _ Pxy × pr1 i · zy = BinProductPr2 _ Pxy) -> isBinProduct C x y z zx zy. Proof. intros [i [px py]]. use make_isBinProduct. intros c f g. use tpair. - exists (BinProductArrow _ Pxy f g · pr1 i). split. + etrans. 1: apply assoc'. etrans. 1: apply maponpaths, px. apply BinProductPr1Commutes. + etrans. 1: apply assoc'. etrans. 1: apply maponpaths, py. apply BinProductPr2Commutes. - intro co. use total2_paths_f. + apply pathsinv0. use (z_iso_inv_to_right _ _ _ _ (z_iso_inv (_,,i))). apply pathsinv0. use BinProductArrowUnique. * etrans. 1: apply assoc'. etrans. 1: apply maponpaths, BinProductPr1Commutes. exact (pr12 co). * etrans. 1: apply assoc'. etrans. 1: apply maponpaths, BinProductPr2Commutes. exact (pr22 co). + use total2_paths_f ; apply homset_property. Defined. Definition coproducts_commute_binproducts_mor {C : category} (BP : BinProducts C) {I : UU} (CP : Coproducts I C) (x y : C) : C⟦CP (λ p : I, BP x y), BP (CP (λ p : I, x)) (CP (λ p : I, y))⟧. Proof. use BinProductArrow ; use CoproductOfArrows. - exact (λ i, BinProductPr1 C (BP x y)). - exact (λ i, BinProductPr2 C (BP x y)). Defined. Definition propcoproducts_commute_binproducts (C : category) (BP : BinProducts C) (pcp : ∏ p : hProp, Coproducts p C) : UU := ∏ p : hProp, ∏ x y : C, is_z_isomorphism (coproducts_commute_binproducts_mor BP (pcp p) x y). End B. Section A. Definition post_comp_functor_of_comp {A B C D E : category} (F : functor A [B,C]) (G : functor C D) (H : functor D E) : nat_z_iso (functor_composite F (post_comp_functor (functor_composite G H))) (functor_composite (functor_composite F (post_comp_functor G)) (post_comp_functor H)). Proof. use make_nat_z_iso. - use make_nat_trans. + intro ; apply nat_trans_id. + intro ; intros. use nat_trans_eq. { apply homset_property. } exact (λ _, id_right _ @ ! id_left _). - intro. use make_is_z_isomorphism. + apply nat_trans_id. + split ; (use nat_trans_eq ; [apply homset_property | intro ; apply id_right]). Defined. Definition BinProduct_of_functors_distr {C D E : category} (F G : functor C D) (H : functor D E) (Hp : preserves_binproduct H) (BPD : BinProducts D) (BPE : BinProducts E) : nat_z_iso (functor_composite (BinProduct_of_functors BPD F G) H) (BinProduct_of_functors BPE (functor_composite F H) (functor_composite G H)). Proof. set (P := λ c, make_BinProduct _ _ _ _ _ _ (Hp (F c) (G c) _ _ _ (pr2 (BPD (F c) (G c))))). set (i := λ c, iso_between_BinProduct (P c) (BPE (H (F c)) (H (G c)))). use make_nat_z_iso. - use make_nat_trans. + intro c. apply (i c). + intro ; intros. use (z_iso_inv_to_right _ _ _ _ (i x')). etrans. 2: { apply maponpaths_2. apply pathsinv0, (postcompWithBinProductArrow). } cbn. use pathscomp0. * exact (BinProductArrow _ (P x') (#H (pr121 (BPD (F x) (G x)) · # F f)) (#H (pr221 (BPD (F x) (G x)) · # G f))). * use (BinProductArrowUnique _ _ _ (P x')). -- etrans. 1: apply pathsinv0, functor_comp. apply maponpaths, BinProductPr1Commutes. -- etrans. 1: apply pathsinv0, functor_comp. apply maponpaths, BinProductPr2Commutes. * apply pathsinv0. use (BinProductArrowUnique _ _ _ (P x')). -- etrans. 1: apply assoc'. etrans. 1: apply maponpaths, (BinProductPr1Commutes _ _ _ (P x')). etrans. 1: apply BinProductPr1Commutes. apply pathsinv0, functor_comp. -- etrans. 1: apply assoc'. etrans. 1: apply maponpaths, (BinProductPr2Commutes _ _ _ (P x')). etrans. 1: apply BinProductPr2Commutes. apply pathsinv0, functor_comp. - intro c. apply (i c). Defined. Lemma BinProductArrowId {C : category} {c d : C} (P : BinProduct C c d) : identity _ = BinProductArrow C P (BinProductPr1 C P) (BinProductPr2 C P). Proof. refine (BinProductArrowEta _ _ _ P _ (identity _) @ _). etrans. 1: apply maponpaths_2, id_left. apply maponpaths, id_left. Qed. Definition isBinProduct_is_objectwise {C D : category} {F1 F2 P : [C, D]} {P1 : [C, D] ⟦ P, F1 ⟧} {P2 : [C, D] ⟦ P, F2 ⟧} (Pc_prod : ∏ c: C, isBinProduct D (pr1 F1 c) (pr1 F2 c) (pr1 P c) (pr1 P1 c) (pr1 P2 c)) : BinProducts D -> isBinProduct [C, D] F1 F2 P P1 P2. Proof. intro BP. use make_isBinProduct'. { apply functor_precat_binproduct_cone ; exact BP. } use tpair. - use nat_trafo_z_iso_if_pointwise_z_iso. intro c. set (Pc := make_BinProduct _ _ _ _ _ _ (Pc_prod c)). use make_is_z_isomorphism. + use (BinProductArrow _ Pc). * apply BinProductPr1. * apply BinProductPr2. + split. * etrans. 1: apply (precompWithBinProductArrow D Pc). etrans. 1: apply maponpaths, BinProductPr2Commutes. etrans. 1: apply maponpaths_2, BinProductPr1Commutes. exact (! BinProductArrowId Pc). * etrans. 1: apply (precompWithBinProductArrow D (BP _ _)). etrans. 1: apply maponpaths, (BinProductPr2Commutes D _ _ Pc). etrans. 1: apply maponpaths_2, (BinProductPr1Commutes D _ _ Pc). exact (! BinProductArrowId (BP _ _)). - split. + use nat_trans_eq. { apply homset_property. } intro c. set (Pc := make_BinProduct _ _ _ _ _ _ (Pc_prod c)). apply (BinProductPr1Commutes D _ _ Pc). + use nat_trans_eq. { apply homset_property. } intro c. set (Pc := make_BinProduct _ _ _ _ _ _ (Pc_prod c)). apply (BinProductPr2Commutes D _ _ Pc). Defined. Definition isBinProduct_to_objectwise {C D : category} {F1 F2 P : [C, D]} {P1 : [C, D] ⟦ P, F1 ⟧} {P2 : [C, D] ⟦ P, F2 ⟧} (P_prod : isBinProduct [C, D] F1 F2 P P1 P2) (BP : BinProducts D) (c : C) : isBinProduct D (pr1 F1 c) (pr1 F2 c) (pr1 P c) (pr1 P1 c) (pr1 P2 c). Proof. use make_isBinProduct'. { apply BP. } set (i := iso_between_BinProduct (make_BinProduct _ _ _ _ _ _ P_prod) (functor_precat_binproduct_cone C D BP F1 F2)). set (ni := nat_z_iso_from_z_iso _ i). use tpair. { apply (pr2 ni c). } split. - set (p := BinProductPr1Commutes [C,D] _ _ (make_BinProduct [C, D] F1 F2 P P1 P2 P_prod)). set (p' := p _ (binproduct_nat_trans_pr1 C D BP F1 F2) (binproduct_nat_trans_pr2 C D BP F1 F2)). exact (eqtohomot (base_paths _ _ p') c). - set (p := BinProductPr2Commutes [C,D] _ _ (make_BinProduct [C, D] F1 F2 P P1 P2 P_prod)). set (p' := p _ (binproduct_nat_trans_pr1 C D BP F1 F2) (binproduct_nat_trans_pr2 C D BP F1 F2)). exact (eqtohomot (base_paths _ _ p') c). Defined. Definition post_comp_functor_preserves_binproduct (C : category) {D E : category} (F : functor D E) (BPD : BinProducts D) (BPE : BinProducts E) (Fp : preserves_binproduct F) : preserves_binproduct (post_comp_functor (A := C) F). Proof. intros F1 F2 P P1 P2 P_prod. use (isBinProduct_is_objectwise _ BPE). intro c. apply Fp. exact (isBinProduct_to_objectwise P_prod BPD c). Defined. Definition BinProductOfArrows_is_z_iso {C : category} {a b : C} (Pab : BinProduct C a b) {c d : C} (Pcd : BinProduct C c d) (f : C ⟦ a, c ⟧) (g : C ⟦ b, d ⟧) : is_z_isomorphism f -> is_z_isomorphism g -> is_z_isomorphism (BinProductOfArrows C Pcd Pab f g) := λ pf pg, make_is_z_isomorphism _ _ (binproduct_of_z_iso_inv Pab Pcd (_,,pf) (_,,pg)). Definition nat_z_iso_BinProduct_of_functors {C D : category} (F1 F2 G1 G2 : functor C D) (BP : BinProducts D) : nat_z_iso F1 G1 -> nat_z_iso F2 G2 -> nat_z_iso (BinProduct_of_functors BP F1 F2) (BinProduct_of_functors BP G1 G2). Proof. intros α1 α2. use make_nat_z_iso. - use make_nat_trans. + intro c. use BinProductOfArrows. * apply α1. * apply α2. + intros x y f. etrans. 1: apply postcompWithBinProductArrow. etrans. 2: apply pathsinv0, postcompWithBinProductArrow. etrans. 1: apply maponpaths_2, assoc'. etrans. 1: apply maponpaths_2, maponpaths, (pr21 α1). etrans. 2: apply maponpaths_2, assoc. apply maponpaths. etrans. 1: apply assoc'. etrans. 1: apply maponpaths, (pr21 α2). apply assoc. - intro. apply BinProductOfArrows_is_z_iso. + apply (pr2 α1). + apply (pr2 α2). Defined. End A. Section EquivalenceBetweenDifferentCharacterizationsOfMultiSortedSignatureToFunctor. Variables (sort : UU) (Hsort_set : isaset sort) (C : category). Variables (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Let Hsort := hlevelntosn 2 _ Hsort_set. (** Define the discrete category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. Let TsortToCC : Terminal [sortToC,C] := Terminal_functor_precat _ _ TC. Lemma sortToC_hasbinproducts : BinProducts [sortToC, sortToC]. Proof. repeat (apply BinProducts_functor_precat) ; exact BP. Defined. Lemma sortToC_hascoproducts : ∏ I : UU, isaset I -> Coproducts I [sortToC, sortToC]. Proof. intros I Iset. repeat (apply Coproducts_functor_precat) ; exact (CC I Iset). Defined. Let hat_exp_functor_list'_piece0 := hat_exp_functor_list'_piece sort Hsort C TC BC CC. Let hat_exp_functor_list0 := hat_exp_functor_list sort Hsort C TC BP BC CC. Let hat_exp_functor_list'0 := hat_exp_functor_list' sort Hsort C TC BP BC CC. Let hat_exp_functor_list'_optimized0 := hat_exp_functor_list'_optimized sort Hsort C TC BP BC CC. Definition hat_exp_functor_list'_piece_test (xst : (list sort × sort) × sort) : nat_z_iso (exp_functor sort Hsort C TC BC CC (pr1 xst) ∙ post_comp_functor (hat_functor sort Hsort C CC (pr2 xst))) (hat_exp_functor_list'_piece0 xst). Proof. induction xst as [[x s] t]. revert x. use list_ind. - simpl. (* This is necessary *) use make_nat_z_iso. + use make_nat_trans. * intro ; apply (nat_trans_id (C := sortToC) (C' := sortToC)). * intro ; intros. use nat_trans_eq. { exact (pr2 sortToC). } exact (λ _, id_right _ @ ! id_left _). + intro. use nat_trafo_z_iso_if_pointwise_z_iso. { apply (pr2 sortToC). } intro. apply identity_is_z_iso. - intro ; intros. use nat_z_iso_inv. apply post_comp_functor_of_comp. Defined. Definition hat_functor_preserves_binproducts (t : sort) (c : propcoproducts_commute_binproducts C BP (λ p, CC p (isasetaprop (pr2 p)))) : preserves_binproduct (hat_functor sort Hsort C CC t). Proof. intros x y p p1 p2 p_prod. use (isBinProduct_is_objectwise _ BP). intro F. simpl. assert (ts_pr : isaprop (t = F)). { apply Hsort_set. } use make_isBinProduct'. { apply BP. } use tpair. - use make_is_z_isomorphism. + refine (_ · pr1 (c (_,,ts_pr) x y) · _). ++ use BinProductOfArrows ; use CoproductOfArrows ; intro ; apply identity. ++ use CoproductOfArrows. exact (λ _, BinProductOfArrows _ (make_BinProduct _ _ _ _ _ _ p_prod) (BP x y) (identity _) (identity _)). + split. * etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, assoc. etrans. 1: do 2 apply maponpaths_2 ; apply postcompWithBinProductArrow. transparent assert (ii : (is_z_isomorphism (CoproductOfArrows (t = F) C (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, BP x y)) (CC (t = F) (Hsort t F) (λ _ : t = F, p)) (λ _ : t = F, BinProductOfArrows C (make_BinProduct C x y p p1 p2 p_prod) (BP x y) (identity x) (identity y))))). { apply CoproductOfArrowsIsos. intro. exact (BinProductOfArrows_is_z_iso (BP x y) (make_BinProduct C x y p p1 p2 p_prod) (identity _) (identity _) (identity_is_z_iso _) (identity_is_z_iso _)). } apply (z_iso_inv_to_right _ _ _ _ (_,,ii)). etrans. 2: apply pathsinv0, id_left. apply pathsinv0. apply (z_iso_inv_on_left _ _ _ _ (_ ,, c ((t = F),, ts_pr) x y)). etrans. 2: apply pathsinv0, precompWithBinProductArrow. use BinProductArrowUnique. -- etrans. 1: apply BinProductPr1Commutes. simpl. unfold inv_from_z_iso. simpl. etrans. 1: apply precompWithCoproductArrow. etrans. 2: apply pathsinv0, precompWithCoproductArrow. use CoproductArrowUnique. intro. etrans. 1: apply (CoproductInCommutes _ _ _ (CC (t = F) (Hsort t F) (λ _ : t = F, p))). etrans. 2: apply assoc'. etrans. 2: apply maponpaths_2, pathsinv0, BinProductPr1Commutes. apply assoc. -- etrans. 1: apply BinProductPr2Commutes. simpl. unfold inv_from_z_iso. simpl. etrans. 1: apply precompWithCoproductArrow. etrans. 2: apply pathsinv0, precompWithCoproductArrow. use CoproductArrowUnique. intro. etrans. 1: apply (CoproductInCommutes _ _ _ (CC (t = F) (Hsort t F) (λ _ : t = F, p))). etrans. 2: apply assoc'. etrans. 2: apply maponpaths_2, pathsinv0, BinProductPr2Commutes. apply assoc. * transparent assert (ii : (is_z_isomorphism (BinProductOfArrows C (BP (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, x)) (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, y))) (BP (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (Hsort t F) (λ _ : t = F, y))) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, x)) (λ _ : t = F, identity x)) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, y)) (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, y)) (λ _ : t = F, identity y))))). { apply BinProductOfArrows_is_z_iso ; (apply CoproductOfArrowsIsos ; intro ; apply identity_is_z_iso). } rewrite ! assoc'. apply pathsinv0. apply (z_iso_inv_to_left _ _ _ ((_,,ii))). etrans. 1: apply id_right. apply (z_iso_inv_to_left _ _ _ (z_iso_inv (_ ,, c ((t = F),, ts_pr) x y))). etrans. 1: apply postcompWithBinProductArrow. etrans. 2: apply pathsinv0, precompWithBinProductArrow. use BinProductArrowUnique. -- etrans. 1: apply BinProductPr1Commutes. etrans. 1: apply precompWithCoproductArrow. etrans. 2: apply pathsinv0, precompWithCoproductArrow. use CoproductArrowUnique. intro. etrans. 1: apply (CoproductInCommutes _ _ _ (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, BP x y))). etrans. 1: apply maponpaths, id_left. unfold BinProductOfArrows. etrans. 2: apply assoc'. apply maponpaths_2. etrans. 2: apply pathsinv0, (BinProductPr1Commutes _ _ _ ((make_BinProduct C x y p p1 p2 p_prod))). apply pathsinv0, id_right. -- etrans. 1: apply BinProductPr2Commutes. etrans. 1: apply precompWithCoproductArrow. etrans. 2: apply pathsinv0, precompWithCoproductArrow. use CoproductArrowUnique. intro. etrans. 1: apply (CoproductInCommutes _ _ _ (CC (t = F) (isasetaprop (pr2 ((t = F),, ts_pr))) (λ _ : t = F, BP x y))). etrans. 1: apply maponpaths, id_left. unfold BinProductOfArrows. etrans. 2: apply assoc'. apply maponpaths_2. etrans. 2: apply pathsinv0, (BinProductPr2Commutes _ _ _ ((make_BinProduct C x y p p1 p2 p_prod))). apply pathsinv0, id_right. - split. + etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply precompWithCoproductArrow. } transparent assert (i : (is_z_isomorphism (BinProductOfArrows C (BP (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, x)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, y))) (BP (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (Hsort t F) (λ _ : t = F, y))) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, x)) (λ _ : t = F, identity x)) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, y)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, y)) (λ _ : t = F, identity y))))). { use BinProductOfArrows_is_z_iso ; (use CoproductOfArrowsIsos ; intro ; apply identity_is_z_iso). } apply pathsinv0. etrans. 2: apply assoc. use (z_iso_inv_to_left _ _ _ (_,,i)). etrans. 1: apply BinProductPr1Commutes. use (z_iso_inv_to_left _ _ _ (z_iso_inv (_,,(c ((t = F),, ts_pr) x y)))). etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, BinProductPr1Commutes. use CoproductArrowUnique. intro. etrans. 1: apply assoc. etrans. 1: { apply maponpaths_2. apply (CoproductInCommutes _ _ _ ((CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, BP x y)))). } etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (CoproductInCommutes _ _ _ (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, x))). } etrans. 2: apply assoc'. etrans. 2: { apply maponpaths_2, pathsinv0. apply (BinProductPr1Commutes _ _ _ (make_BinProduct C x y p p1 p2 p_prod)). } apply assoc. + etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply precompWithCoproductArrow. } transparent assert (i : (is_z_isomorphism (BinProductOfArrows C (BP (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, x)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, y))) (BP (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (Hsort t F) (λ _ : t = F, y))) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, x)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, x)) (λ _ : t = F, identity x)) (CoproductOfArrows (t = F) C (CC (t = F) (Hsort t F) (λ _ : t = F, y)) (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, y)) (λ _ : t = F, identity y))))). { use BinProductOfArrows_is_z_iso ; (use CoproductOfArrowsIsos ; intro ; apply identity_is_z_iso). } apply pathsinv0. etrans. 2: apply assoc. use (z_iso_inv_to_left _ _ _ (_,,i)). etrans. 1: apply BinProductPr2Commutes. use (z_iso_inv_to_left _ _ _ (z_iso_inv (_,,(c ((t = F),, ts_pr) x y)))). etrans. 1: apply assoc. etrans. 1: apply maponpaths_2, BinProductPr2Commutes. use CoproductArrowUnique. intro. etrans. 1: apply assoc. etrans. 1: { apply maponpaths_2. apply (CoproductInCommutes _ _ _ ((CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, BP x y)))). } etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (CoproductInCommutes _ _ _ (CC (t = F) (isasetaprop ts_pr) (λ _ : t = F, y))). } etrans. 2: apply assoc'. etrans. 2: { apply maponpaths_2, pathsinv0. apply (BinProductPr2Commutes _ _ _ (make_BinProduct C x y p p1 p2 p_prod)). } apply assoc. Defined. Definition hat_exp_functor_list'_test (xst : list (list sort × sort) × sort) (c : propcoproducts_commute_binproducts C BP (λ p, CC p (isasetaprop (pr2 p)))) : nat_z_iso (hat_exp_functor_list0 xst) (hat_exp_functor_list'0 xst). Proof. induction xst as [a t] ; revert a. use list_ind. - use tpair. + apply (nat_trans_id (C := [sortToC,sortToC]) (C' := [sortToC,sortToC])). + intro ; apply (identity_is_z_iso (C := [sortToC,sortToC])). - intros x xs IHn. use nat_z_iso_comp. 3: { use nat_z_iso_BinProduct_of_functors. 3: exact IHn. 2: exact (hat_exp_functor_list'_piece_test (x ,, t)). } clear IHn. transparent assert (q : (nat_z_iso (exp_functor_list sort Hsort C TC BP BC CC (cons x xs)) (BinProduct_of_functors BPC (exp_functor_list sort Hsort C TC BP BC CC xs) (exp_functor sort Hsort C TC BC CC x)))). { induction xs as [[|n] xs]. - induction xs. unfold exp_functor_list at 1. change (cons x (0,, tt)) with (cons x nil). rewrite foldr1_map_cons_nil. unfold exp_functor_list at 1. change (0,, tt) with (nil(A:=list sort × sort)). rewrite foldr1_map_nil. apply nat_z_iso_inv. exact (terminal_BinProduct_of_functors_unit_l _ _ BPC TsortToCC (exp_functor sort Hsort C TC BC CC x)). - induction xs. change (cons x (S n,, pr1,, pr2)) with (cons x (cons pr1 (n,,pr2))). unfold exp_functor_list at 1. rewrite foldr1_map_cons. change (nat_z_iso (BinProduct_of_functors BPC (exp_functor sort Hsort C TC BC CC x) (exp_functor_list sort Hsort C TC BP BC CC (S n,, pr1,, pr2)) ) (BinProduct_of_functors BPC (exp_functor_list sort Hsort C TC BP BC CC (S n,, pr1,, pr2)) (exp_functor sort Hsort C TC BC CC x))). apply BinProduct_of_functors_commutes. } use (nat_z_iso_comp (post_whisker_nat_z_iso q _)). apply BinProduct_of_functors_distr. apply post_comp_functor_preserves_binproduct. + apply BP. + apply (BinProducts_functor_precat _ C BP). + apply hat_functor_preserves_binproducts. exact c. Defined. (* the result will not be needed in the sequel *) Definition hat_exp_functor_list'_optimized_test (xst : list (list sort × sort) × sort) (c : propcoproducts_commute_binproducts C BP (λ p, CC p (isasetaprop (pr2 p)))) : nat_z_iso (hat_exp_functor_list0 xst) (hat_exp_functor_list'_optimized0 xst). Proof. induction xst as [xs t]; revert t. induction xs as [[|n] xs]. - induction xs. intro t. use tpair. + apply (nat_trans_id (C := [sortToC,sortToC]) (C' := [sortToC,sortToC])). + intro ; apply (identity_is_z_iso (C := [sortToC,sortToC])). - induction n as [|n IH]. + induction xs as [m []]. change (1,, m,, tt) with (cons m nil). intro t. unfold hat_exp_functor_list'_optimized0, hat_exp_functor_list'_optimized. rewrite foldr1_map_cons_nil. (* unfold hat_exp_functor_list0, hat_exp_functor_list. *) exact (hat_exp_functor_list'_piece_test (m,,t)). + induction xs as [m [k xs]]. intro t. assert (IHinst := IH (k,,xs) t). change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))). unfold hat_exp_functor_list'_optimized0, hat_exp_functor_list'_optimized. rewrite foldr1_map_cons. change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst. unfold hat_exp_functor_list'_optimized0, hat_exp_functor_list'_optimized in IHinst. use nat_z_iso_comp. 3: { use nat_z_iso_BinProduct_of_functors. 4: exact IHinst. 2: exact (hat_exp_functor_list'_piece_test (m ,, t)). } clear IH IHinst. unfold hat_exp_functor_list0, hat_exp_functor_list. unfold exp_functor_list. change (pr1 (cons m (cons k (n,, xs)),, t)) with (cons m (cons k (n,, xs))). rewrite foldr1_map_cons. apply BinProduct_of_functors_distr. apply post_comp_functor_preserves_binproduct. * apply BP. * apply (BinProducts_functor_precat _ C BP). * apply hat_functor_preserves_binproducts. exact c. Defined. Definition MultiSortedSigToFunctor_test (M : MultiSortedSig sort) (c : propcoproducts_commute_binproducts C BP (λ p : hProp, CC p (isasetaprop (pr2 p)))) : nat_z_iso (MultiSortedSigToFunctor sort Hsort C TC BP BC CC M) (MultiSortedSigToFunctor' sort Hsort C TC BP BC CC M). Proof. use coproduct_of_functors_nat_z_iso. intro i. apply hat_exp_functor_list'_optimized_test. exact c. Defined. End EquivalenceBetweenDifferentCharacterizationsOfMultiSortedSignatureToFunctor. (** The functor obtained from a multisorted binding signature is omega-continuous *) Lemma is_omega_cont_MultiSortedSigToFunctor (sort : UU) (Hsort_set : isaset sort) (C : category) (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C) (M : MultiSortedSig sort) (l : Lims_of_shape conat_graph C) (c : propcoproducts_commute_binproducts C BP (λ p : hProp, CC p (isasetaprop (pr2 p)))) (d : ∏ I : SET, ω_limits_distribute_over_I_coproducts C I l (CC (pr1 I) (pr2 I))) : is_omega_cont (MultiSortedSigToFunctor sort (hlevelntosn 2 _ Hsort_set) C TC BP BC CC M). Proof. use nat_z_iso_preserve_ωlimits. 3: apply (nat_z_iso_inv (MultiSortedSigToFunctor_test _ _ _ _ _ _ CC _ c)). apply (is_omega_cont_MultiSortedSigToFunctor' sort (hlevelntosn 2 _ Hsort_set) C TC BP BC CC _ d M). Defined. UniMath-20231010/UniMath/SubstitutionSystems/EquivalenceLaxLineatorsHomogeneousCase.v000066400000000000000000000150271451125700300307500ustar00rootroot00000000000000(** links the homogeneous instance of lax lineators with the linears based on the self action this is w.r.t. the elementary notion of the monoidal category of endofunctors, not the instance to the bicategory of categories of the general bicategorical constructions Author: Ralph Matthes 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. (* Require Import UniMath.SubstitutionSystems.EquivalenceSignaturesWithActegoryMorphisms. *) Import MonoidalNotations. Local Open Scope cat. Section FixACategory. Context (C : category). Local Definition endoCAT : category := [C, C]. Local Definition Mon_endo_CAT : monoidal endoCAT := monendocat_monoidal C. Local Definition ptdendo_CAT : category := coslice_cat_total endoCAT I_{Mon_endo_CAT}. Local Definition Mon_ptdendo_CAT : monoidal ptdendo_CAT := monoidal_pointed_objects Mon_endo_CAT. Local Definition actegoryPtdEndosOnFunctors_CAT (E : category) : actegory Mon_ptdendo_CAT [C,E] := reindexed_actegory Mon_endo_CAT (actegory_from_precomp_CAT C E) Mon_ptdendo_CAT (forget_monoidal_pointed_objects_monoidal Mon_endo_CAT). (* not possible without some transparent proofs Local Lemma actegoryPtdEndosOnFunctors_CAT_as_actegory_with_canonical_pointed_action : actegoryPtdEndosOnFunctors_CAT C = actegory_with_canonical_pointed_action Mon_endo_CAT. Proof. unfold actegoryPtdEndosOnFunctors_CAT. unfold actegory_from_precomp_CAT. rewrite actegory_from_precomp_as_self_action_CAT. apply idpath. Qed. *) Local Lemma action_in_actegoryPtdEndosOnFunctors_CAT_as_actegory_with_canonical_pointed_action : actegory_action Mon_ptdendo_CAT (actegoryPtdEndosOnFunctors_CAT C) = actegory_action Mon_ptdendo_CAT (actegory_with_canonical_pointed_action Mon_endo_CAT). Proof. use total2_paths_f. 2: { apply WhiskeredBifunctors.isaprop_is_bifunctor. } cbn. apply idpath. Qed. (* > 16 times faster than for [EquivalenceSignaturesWithActegoryMorphisms.action_in_actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action] *) (* commented for reasons of time consumption (easily more than 3 minutes compilation time) Local Lemma lax_lineators_data_from_reindexed_precomp_CAT_and_reindexed_self_action_agree (H : functor [C, C] [C, C]) : lineator_data Mon_ptdendo_CAT (actegoryPtdEndosOnFunctors_CAT C) (actegoryPtdEndosOnFunctors_CAT C) H ≃ lineator_data Mon_ptdendo_CAT (actegory_with_canonical_pointed_action Mon_endo_CAT) (actegory_with_canonical_pointed_action Mon_endo_CAT) H. Proof. use weq_iso. - intro ld. intros Z F. cbn. set (ldinst := ld Z F). cbn in ldinst. exact ldinst. - intro ld. intros Z F. cbn. set (ldinst := ld Z F). cbn in ldinst. exact ldinst. - abstract (intro ld; (* apply funextsec; intro; simpl; apply funextsec; intro; *) apply idpath). - abstract (intro ld; apply idpath). (* both cases are very slow *) Defined. (* 57s on modern Intel machine *) *) (* commented for reasons of time consumption (easily more than 30 minutes compilation time) - no longer needed with the modified definition [MultiSortedSigToStrength'] of signature functor Local Lemma lax_lineators_from_reindexed_precomp_CAT_and_reindexed_self_action_agree (H : functor [C, C] [C, C]) : lineator_lax Mon_ptdendo_CAT (actegoryPtdEndosOnFunctors_CAT C) (actegoryPtdEndosOnFunctors_CAT C) H ≃ lineator_lax Mon_ptdendo_CAT (actegory_with_canonical_pointed_action Mon_endo_CAT) (actegory_with_canonical_pointed_action Mon_endo_CAT) H. Proof. use (weqbandf (lax_lineators_data_from_reindexed_precomp_CAT_and_reindexed_self_action_agree H)). intro ld. use weqimplimpl. 4: { apply isaprop_lineator_laxlaws. } 3: { apply isaprop_lineator_laxlaws. } - intro Hyps. split4. + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypnatleft_inst := eqtohomot (maponpaths pr1 (pr1 Hyps v x1 x2 g)) c); cbn; cbn in Hypnatleft_inst; exact Hypnatleft_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypnatright_inst := eqtohomot (maponpaths pr1 (pr12 Hyps v1 v2 x f)) c); cbn; cbn in Hypnatright_inst; exact Hypnatright_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypactor_inst := eqtohomot (maponpaths pr1 (pr122 Hyps v w x)) c); cbn; cbn in Hypactor_inst; exact Hypactor_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypunitor_inst := eqtohomot (maponpaths pr1 (pr222 Hyps x)) c); cbn; cbn in Hypunitor_inst; exact Hypunitor_inst). - intro Hyps. split4. + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypnatleft_inst := eqtohomot (maponpaths pr1 (pr1 Hyps v x1 x2 g)) c); cbn; cbn in Hypnatleft_inst; exact Hypnatleft_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypnatright_inst := eqtohomot (maponpaths pr1 (pr12 Hyps v1 v2 x f)) c); cbn; cbn in Hypnatright_inst; exact Hypnatright_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypactor_inst := eqtohomot (maponpaths pr1 (pr122 Hyps v w x)) c); cbn; cbn in Hypactor_inst; exact Hypactor_inst). + abstract (intro; intros; apply (nat_trans_eq C); intro c; assert (Hypunitor_inst := eqtohomot (maponpaths pr1 (pr222 Hyps x)) c); cbn; cbn in Hypunitor_inst; exact Hypunitor_inst). Defined. (* instantaneous, but the abstracted parts require 26-42min on a modern Intel machine, depending on if UniMath master was merged *) *) End FixACategory. UniMath-20231010/UniMath/SubstitutionSystems/EquivalenceSignaturesWithActegoryMorphisms.v000066400000000000000000000571271451125700300317250ustar00rootroot00000000000000(** Links signatures to lax morphisms in suitable actegories, by exploiting the already established link with action-based strength (in the non-whiskered setting) Author: Ralph Matthes 2022 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored. Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.Actions. Require Import UniMath.Bicategories.MonoidalCategories.ConstructionOfActions. Require Import UniMath.Bicategories.MonoidalCategories.ActionOfEndomorphismsInBicat. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorCategory. Require Import UniMath.Bicategories.Core.Bicat. Require Import UniMath.Bicategories.Core.Examples.BicatOfCats. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.ActionBasedStrengthOnHomsInBicat. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsWhiskeredMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.ActionOfEndomorphismsInBicatWhiskered. Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories. Import Bicat.Notations. Import MonoidalNotations. Local Open Scope cat. Section A. Context (C D D' : category). Local Definition Mon_endo' : MonoidalCategoriesTensored.monoidal_cat := swapping_of_monoidal_cat (monoidal_cat_of_pointedfunctors C). Local Definition domain_action : Actions.action Mon_endo' (hom(C:=bicat_of_cats) C D') := ActionBasedStrengthOnHomsInBicat.ab_strength_domain_action(C:=bicat_of_cats) C D' (ActionBasedStrengthOnHomsInBicat.forget C). Local Definition target_action : Actions.action Mon_endo' (hom(C:=bicat_of_cats) C D) := ActionBasedStrengthOnHomsInBicat.ab_strength_target_action(C:=bicat_of_cats) C D (ActionBasedStrengthOnHomsInBicat.forget C). Lemma weqSignatureABStrength : Signature C D D' ≃ actionbased_strong_functor Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D). Proof. use weq_iso. - apply ab_strong_functor_from_signature. - apply signature_from_strong_functor. - apply roundtrip1_ob_as_equality. - apply roundtrip2_ob_as_equality. Defined. (* Local Definition endo : category := [C,C]. would not be okay for convertibility *) Local Definition endofrombicat : category := ActionOfEndomorphismsInBicatWhiskered.endocat(C:=bicat_of_cats) C. Local Definition Mon_endo : monoidal endofrombicat := ActionOfEndomorphismsInBicatWhiskered.Mon_endo(C:=bicat_of_cats) C. Local Definition ptdendo : category := coslice_cat_total endofrombicat I_{Mon_endo}. Local Definition Mon_ptdendo : monoidal ptdendo := monoidal_pointed_objects Mon_endo. Local Definition actegoryPtdEndosOnFunctors (E : category) : actegory Mon_ptdendo [C,E] := reindexed_actegory Mon_endo (actegoryfromprecomp C E) Mon_ptdendo (forget_monoidal_pointed_objects_monoidal Mon_endo). (* not possible without some transparent proofs Local Lemma actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action : actegoryPtdEndosOnFunctors C = actegory_with_canonical_pointed_action Mon_endo. Proof. unfold actegoryPtdEndosOnFunctors. unfold actegoryfromprecomp. rewrite actegory_from_precomp_as_self_action. apply idpath. Qed. *) Local Lemma action_in_actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action : actegory_action Mon_ptdendo (actegoryPtdEndosOnFunctors C) = actegory_action Mon_ptdendo (actegory_with_canonical_pointed_action Mon_endo). Proof. use total2_paths_f. 2: { apply WhiskeredBifunctors.isaprop_is_bifunctor. } cbn. apply idpath. Qed. (* slow *) (* Local Lemma lax_lineators_from_reindexed_precomp_and_reindexed_self_action_agree (F : functor [C, C] [C, C]) : lineator_lax Mon_ptdendo (actegoryPtdEndosOnFunctors C) (actegoryPtdEndosOnFunctors C) F ≃ lineator_lax Mon_ptdendo (actegory_with_canonical_pointed_action Mon_endo) (actegory_with_canonical_pointed_action Mon_endo) F. Proof. use weqfibtototal. (* not seen to terminate *) *) Section AA. Context (H : [C, D'] ⟶ [C, D]). Lemma functor_comp_id_lax_specialized (F F' : C ⟶ D') (α: F ⟹ F') (β: F' ⟹ F) : nat_trans_comp α β = nat_trans_id F -> nat_trans_comp (#H α) (#H β) = nat_trans_id (pr1 (H F)). Proof. intro e. intermediate_path (#H (nat_trans_id F)). - rewrite <- e. change ( (# H α) · (# H β) = # H ((α:[C,D']⟦ F, F' ⟧) · (β:[C,D']⟦ F', F ⟧)) ). apply (! functor_comp _ _ _). - apply functor_id_id. apply idpath. Qed. Lemma weqABStrengthLaxMorphismActegories : actionbased_strength Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D) H ≃ lineator_lax Mon_ptdendo (actegoryPtdEndosOnFunctors D') (actegoryPtdEndosOnFunctors D) H. Proof. unfold actionbased_strength. unfold actionbased_strength_nat. unfold nat_trans. eapply weqcomp. { apply weqtotal2asstor. } (* set (P := is_nat_trans (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H) (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H)). set (Q := fun (ζ: actionbased_strength_nat Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D) H) => actionbased_strength_triangle_eq Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D) H ζ × actionbased_strength_pentagon_eq Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D) H ζ). (* a test for speeding up - not very successful (one would then use [Q'] in place of [Q] in the invocation of [weqtotal2asstor]): set (Q' := fun ζ: ∑ t: nat_trans_data (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H) (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H), is_nat_trans (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H) (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H) t => Q ζ). *) exact (weqtotal2asstor P Q). *) cbn. unfold actionbased_strength_triangle_eq, actionbased_strength_pentagon_eq. cbn. unfold lineator_lax. use weqbandf. - use weq_iso. + intros α v f. exact (α (f,,v)). + intros β fv. induction fv as [f v]. exact (β v f). + intro α. cbn. apply idpath. + intro β. cbn. apply idpath. - intro γ. cbn. use weqimplimpl. 4: { apply isaprop_lineator_laxlaws. } 3: { apply isapropdirprod ; [| apply isapropdirprod]; repeat (apply impred; intro); apply isaset_nat_trans; apply D. } + intro Hyps. induction Hyps as [Hypnat [Hyptriangle Hyppentagon]]. red in Hypnat; cbn in Hypnat. repeat split. * intros v f1 f2 β. cbn. apply (nat_trans_eq D). intro x. cbn. assert (Hypnatinst := toforallpaths _ _ _ (maponpaths pr1 (Hypnat (f1,,v) (f2,,v) (β,,identity(C:=PointedFunctors.category_Ptd C) v))) x). cbn in Hypnatinst. rewrite (functor_id (H f1)) in Hypnatinst. rewrite post_whisker_identity in Hypnatinst. rewrite id_left in Hypnatinst. etrans. { exact Hypnatinst. } apply maponpaths. apply (maponpaths (fun z => pr1(# H z) x)). apply (@id_left [C,D'] _ _ ((pre_whisker (pr11 v)) β: functor_composite (pr1 v) f1 ⟹ functor_composite (pr1 v) f2)). * intros v1 v2 f α. cbn. apply (nat_trans_eq D). intro x. cbn. assert (Hypnatinst0 := Hypnat (f,,v1) (f,,v2)). transparent assert (αbetter : (PointedFunctors.category_Ptd C ⟦v1,v2⟧)). { use tpair. - exact (pr1 α). - intro c. unfold PointedFunctors.ptd_pt. apply (toforallpaths _ _ _ (maponpaths pr1 (pr2 α)) c). } assert (Hypnatinst := toforallpaths _ _ _ (maponpaths pr1 (Hypnat (f,,v1) (f,,v2) (catbinprodmor (identity(C:=functor_category C D') f) αbetter))) x). cbn in Hypnatinst. rewrite (functor_id (H)) in Hypnatinst. rewrite pre_whisker_identity in Hypnatinst. rewrite id_right in Hypnatinst. etrans. { exact Hypnatinst. } apply maponpaths. apply (maponpaths (fun z => pr1(# H z) x)). apply (@id_right [C,D'] _ _ ((post_whisker (pr1 α)) f: functor_composite (pr1 v1) f ⟹ functor_composite (pr1 v2) f)). * clear Hyptriangle. intros v w f. cbn. repeat rewrite post_whisker_identity. apply (nat_trans_eq D). intro x. cbn. assert (Hyppentagoninst0 := Hyppentagon f w v). clear Hyppentagon. repeat rewrite post_whisker_identity in Hyppentagoninst0. repeat rewrite pre_whisker_identity in Hyppentagoninst0. assert (Hyppentagoninst := toforallpaths _ _ _ (maponpaths pr1 Hyppentagoninst0) x). clear Hyppentagoninst0. cbn in Hyppentagoninst. rewrite id_right. rewrite id_left. do 4 rewrite id_left in Hyppentagoninst. unfold PointedFunctorsComposition.ptd_compose in Hyppentagoninst. cbn in Hyppentagoninst. unfold post_whisker_in_funcat, pre_whisker_in_funcat, PointedFunctors.ptd_pt in Hyppentagoninst. (* "morally", hypothesis and goal are the same. *) (* match goal with |[ H1 : _ = _ · ?f |- _ = _ ] => set (Hf := f) end. *) set (aux1 := pr1 (#H (identity(C:=[C,D']) (functor_composite (pr1 v) ((pr1 w) · f)) · (identity _ · identity(C:=[C,D']) (functor_compose (pr1 v) (pr1 w) ∙ f)))) x). (* assert (auxH : Hf = aux1). { apply idpath. } *) match goal with |[ H1 : _ = _ · ?f |- _ = _ ] => change f with aux1 in H1 end. unfold aux1 in Hyppentagoninst. clear aux1. rewrite (functor_comp H) in Hyppentagoninst. rewrite id_left in Hyppentagoninst. rewrite (functor_id H) in Hyppentagoninst. rewrite id_left in Hyppentagoninst. (* match goal with | [ |- ?l _ · _ = _ ] => set (Hl := l) end. *) set (aux2 := nat_trans_data_from_nat_trans_funclass (γ (f,,functor_compose (pr1 v) (pr1 w),, identity(C:=[C,C]) _ · nat_trans_comp (post_whisker_in_funcat C C C (PointedFunctors.ptd_pt C v) (functor_identity C)) (pre_whisker_in_funcat C C C (pr1 v) (PointedFunctors.ptd_pt C w))))). (* assert (auxH : Hl = aux2). { apply idpath. } *) match goal with | [ |- ?l _ · _ = _ ] => change l with aux2 end. unfold aux2. rewrite id_left. clear aux2. etrans. { apply cancel_postcomposition. exact Hyppentagoninst. } clear Hyppentagoninst. repeat rewrite assoc'. apply maponpaths. etrans. 2: { apply id_right. } apply maponpaths. (* only # H applied to identities remains *) match goal with | [ |- _ ?l1 _ · _ ?l2 _ = _] => set (Hl1 := l1); set (Hl2 := l2) end. assert (aux5: Hl1 · Hl2 = identity _). { apply functor_comp_id. apply (nat_trans_eq D'). intro x'. cbn. rewrite id_left. apply id_left. } exact (toforallpaths _ _ _ (maponpaths pr1 aux5) x). * clear Hyppentagon. intro f. cbn. do 2 rewrite post_whisker_identity. unfold total_unit. apply (nat_trans_eq D). intro x. cbn. rewrite id_left. assert (Hyptriangleinst0 := Hyptriangle f). clear Hyptriangle. repeat rewrite pre_whisker_identity in Hyptriangleinst0. assert (Hyptriangleinst := toforallpaths _ _ _ (maponpaths pr1 Hyptriangleinst0) x). clear Hyptriangleinst0. cbn in Hyptriangleinst. rewrite (functor_id (H f)) in Hyptriangleinst. do 2 rewrite id_left in Hyptriangleinst. etrans. 2: { exact Hyptriangleinst. } clear Hyptriangleinst. apply maponpaths. (* match goal with | [ |- ?l _ = _ ] => set (Hl := l) end. *) set (aux3 := nat_trans_data_from_nat_trans_funclass (# H ((identity (functor_compose (functor_identity C) f)) · (identity f)))). (* assert (Hl = aux3). { apply idpath. } *) match goal with | [ |- ?l _ = _ ] => change l with aux3 end. unfold aux3; clear aux3. rewrite id_left. rewrite functor_id. (* only # H applied to identities remains *) (* match goal with | [ |- _ = _ ?r _ ] => set (Hr := r) end. *) set (argtoH := nat_trans_comp (nat_trans_comp (post_whisker (nat_z_iso_to_trans_inv (make_nat_z_iso (functor_identity C) (functor_identity C) (nat_trans_id (functor_identity_data C)) (is_nat_z_iso_nat_trans_id (functor_identity C)))) f) (nat_trans_id (functor_composite_data (functor_identity_data C) (pr1 f)))) (nat_trans_id (pr1 f))). (* assert (G1: Hr = # H argtoH). { apply idpath. } *) match goal with | [ |- _ = _ ?r _ ] => change r with (# H argtoH) end. assert (G2: # H argtoH = identity(C:=[C,D]) (H (functor_identity C ∙ f))). { apply functor_id_id. apply nat_trans_eq_alt; intro c. cbn. do 2 rewrite id_right. apply functor_id. } rewrite G2. apply idpath. + (* the other direction that is very similar in spirit (but the two naturality laws give the composite one) *) intro Hyps. induction Hyps as [Hypnatleft [Hypnatright [Hypactor Hypunitor]]]. repeat split. * red. intros f1v1 f2v2 βα. induction f1v1 as [f1 v1]; induction f2v2 as [f2 v2]; induction βα as [β α]. cbn. red in Hypnatleft. assert (Hypnatleftinst := Hypnatleft v2 f1 f2 β). clear Hypnatleft. cbn in Hypnatleftinst. transparent assert (αbetter : (ptdendo ⟦v1,v2⟧)). { use tpair. - exact (pr1 α). - cbn. apply (nat_trans_eq C). intro c. cbn. apply (pr2 α). } assert (Hypnatrightinst := Hypnatright v1 v2 f1 αbetter). clear Hypnatright. cbn in Hypnatrightinst. change (((post_whisker_in_funcat _ _ _ (pr1 α) (H f1)) · (pre_whisker_in_funcat _ _ _ (pr1 v2) (# H β))) · (γ (f2,, v2)) = nat_trans_comp (γ (f1,, v1)) (# H ((post_whisker_in_funcat _ _ _ (pr1 α) f1) · (pre_whisker_in_funcat _ _ _ (pr1 v2) β)))). rewrite assoc'. rewrite functor_comp. etrans. { apply maponpaths. exact Hypnatleftinst. } clear Hypnatleftinst. apply (nat_trans_eq D); intro x. cbn. repeat rewrite assoc. apply cancel_postcomposition. exact (toforallpaths _ _ _ (maponpaths pr1 Hypnatrightinst) x). * clear Hypnatleft Hypnatright Hypactor. intro f. do 2 rewrite pre_whisker_identity. apply (nat_trans_eq D); intro x. cbn. rewrite (functor_id (H f)). do 2 rewrite id_left. assert (Hypunitorinst0 := Hypunitor f). cbn in Hypunitorinst0. do 2 rewrite post_whisker_identity in Hypunitorinst0. assert (Hypunitorinst := toforallpaths _ _ _ (maponpaths pr1 Hypunitorinst0) x). clear Hypunitorinst0. cbn in Hypunitorinst. rewrite id_right in Hypunitorinst. unfold total_unit in Hypunitorinst. etrans. 2: { exact Hypunitorinst. } clear Hypunitorinst. apply maponpaths. (* only # H applied to identities remains *) (* match goal with | [ |- _ = _ ?r _ ] => set (Hr := r) end. *) set (aux3 := # H ((identity (functor_compose (functor_identity C) f)) · (identity(C:=[C,D']) f))). match goal with | [ |- _ = _ ?r _ ] => change r with aux3 end. unfold aux3; clear aux3. rewrite id_left. rewrite functor_id. set (argtoH := nat_trans_comp (nat_trans_comp (post_whisker (nat_z_iso_to_trans_inv (make_nat_z_iso (functor_identity C) (functor_identity C) (nat_trans_id (functor_identity_data C)) (is_nat_z_iso_nat_trans_id (functor_identity C)))) f) (nat_trans_id (functor_composite_data (functor_identity_data C) (pr1 f)))) (nat_trans_id (pr1 f))). match goal with | [ |- _ ?l _ = _ ] => change l with (# H argtoH) end. assert (G2': # H argtoH = identity(C:=[C,D]) (H (functor_identity C ∙ f))). { apply functor_id_id. apply nat_trans_eq_alt; intro c. cbn. do 2 rewrite id_right. apply functor_id. } rewrite G2'. apply idpath. * (* the pentagon law as last remaining proof obligation *) clear Hypnatleft Hypnatright Hypunitor. intros f w v. assert (Hypactorinst0 := Hypactor v w f). cbn in Hypactorinst0. repeat rewrite post_whisker_identity in Hypactorinst0. do 3 rewrite post_whisker_identity. do 2 rewrite pre_whisker_identity. apply (nat_trans_eq D); intro x. cbn. repeat rewrite id_left. assert (Hypactorinst := toforallpaths _ _ _ (maponpaths pr1 Hypactorinst0) x). clear Hypactorinst0. cbn in Hypactorinst. do 2 rewrite id_left in Hypactorinst. etrans. 2: { apply cancel_postcomposition. exact Hypactorinst. } clear Hypactorinst. rewrite assoc'. etrans. { apply pathsinv0, id_right. } (* match goal with | [ |- _ = ?r _ · _ ] => set (Hr := r) end. *) set (aux6 := nat_trans_data_from_nat_trans_funclass (γ (f,,functor_compose (pr1 v) (pr1 w),, identity(C:=[C,C]) _ · nat_trans_comp (post_whisker_in_funcat C C C (PointedFunctors.ptd_pt C v) (functor_identity C)) (pre_whisker_in_funcat C C C (pr1 v) (PointedFunctors.ptd_pt C w))))). (* assert (auxH : Hr = aux6). { apply idpath. } *) match goal with | [ |- _ = ?r _ · _ ] => change r with aux6 end. unfold aux6. clear aux6. rewrite id_left. apply maponpaths. (* only # H applied to identities remains *) (* match goal with |[ |- _ = _ · ?f ] => set (Hf := f) end. *) set (aux5' := pr1 (#H (identity(C:=[C,D']) (functor_composite (pr1 v) (functor_composite (pr1 w) f)) · (identity (C:=[C,D'])(functor_composite (functor_composite (pr1 v) (pr1 w)) f) · identity(C:=[C,D']) (functor_compose (pr1 v) (pr1 w) ∙ f)))) x). (* assert (auxH : Hf = aux5'). { apply idpath. } *) match goal with |[ |- _ = _ · ?f ] => change f with aux5' end. unfold aux5'. clear aux5'. rewrite (functor_comp H). rewrite id_left. rewrite (functor_id H). rewrite id_left. apply pathsinv0. match goal with | [ |- _ ?l1 _ · _ ?l2 _ = _] => set (Hl1 := l1); set (Hl2 := l2) end. (* It looked like being stuck. One cannot proceed as in the opposite direction stating aux7: Hl1 · Hl2 = identity _ because this does not type-check. But one can state: *) assert (aux7: nat_trans_comp Hl1 Hl2 = nat_trans_id _). 2: { exact (toforallpaths _ _ _ (maponpaths pr1 aux7) x). } (* but how can we prove it? Is there something like functor_comp_id available? Yes, specialized for the situation with endofunctor categories as domain a codomain *) apply functor_comp_id_lax_specialized. apply nat_trans_eq_alt. intro x'. cbn. rewrite id_left. apply id_left. Defined. End AA. Lemma weqSignatureLaxMorphismActegories : Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) ([C, D'],,actegoryPtdEndosOnFunctors D') ([C, D],,actegoryPtdEndosOnFunctors D). Proof. apply (weqcomp weqSignatureABStrength). apply weqfibtototal. intro H. apply weqABStrengthLaxMorphismActegories. Defined. Lemma weqSignatureLaxMorphismActegories_alt : Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) (hom(C:=bicat_of_cats) C D',,actegoryPtdEndosOnFunctors D') (hom(C:=bicat_of_cats) C D,,actegoryPtdEndosOnFunctors D). Proof. apply (weqcomp weqSignatureLaxMorphismActegories). apply weqfibtototal. intro H. exact (idweq _). Defined. (* slow *) (* a direct proof without going through weqSignatureLaxMorphismActegories: Lemma weqSignatureLaxMorphismActegories_alt_alt : Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) (hom(C:=bicat_of_cats) C D',,actegoryPtdEndosOnFunctors D') (hom(C:=bicat_of_cats) C D,,actegoryPtdEndosOnFunctors D). Proof. apply (weqcomp weqSignatureABStrength). apply weqfibtototal. intro H. apply weqABStrengthLaxMorphismActegories. (* very slow *) Defined. (* very slow *) *) End A. Section HomogeneousCase. Context (C : category). (** this part can be resurrected with some transparent proofs, or hopefully by moving to pointed tensorial strength that is not instantiated from bicategories *) (* Corollary weqSignatureLaxMorphismActegoriesHomogeneous : Signature C C C ≃ ∑ H : endofrombicat C ⟶ endofrombicat C, pointedtensorialstrength (Mon_endo C) H. Proof. eapply weqcomp. { apply weqSignatureLaxMorphismActegories_alt. } cbn. apply weqfibtototal. intro H. unfold pointedtensorialstrength. rewrite (actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action C). apply idweq. Defined. Corollary weqSignatureLaxMorphismActegoriesHomogeneous_alt : Signature C C C ≃ ∑ H : [C, C] ⟶ [C, C], pointedtensorialstrength (Mon_endo C) H. Proof. cbn. apply (weqcomp weqSignatureLaxMorphismActegoriesHomogeneous). apply weqfibtototal. intro H. apply idweq. Defined. *) End HomogeneousCase. UniMath-20231010/UniMath/SubstitutionSystems/FromBindingSigsToMonads_Summary.v000066400000000000000000000370401451125700300273610ustar00rootroot00000000000000(** This file provides a stable interface to the formalization of the paper: From binding signatures to monads in UniMath https://arxiv.org/abs/1612.00693 by Benedikt Ahrens, Ralph Matthes and Anders Mörtberg. PLEASE DO NOT RENAME THIS FILE - its name is referenced in the article about this formalization. *) Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.SignatureCategory. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Local Open Scope cat. Local Notation "[ C , D ]" := (functor_category C D). (** Definition 1: Binding signature *) Definition BindingSig : UU := @UniMath.SubstitutionSystems.BindingSigToMonad.BindingSig. (** Definition 4: Signatures with strength *) Definition Signature : ∏ (C D D' : category), UU := @UniMath.SubstitutionSystems.Signatures.Signature. (** Definition 5: Morphism of signatures with strength *) Definition SignatureMor : ∏ C D D' : category, Signatures.Signature C D D' → Signatures.Signature C D D' → UU := @UniMath.SubstitutionSystems.SignatureCategory.SignatureMor. (** Definition 6: Coproduct of signatures with strength *) Definition Sum_of_Signatures : ∏ (I : UU) (C D D': category), Coproducts I D → (I → Signature C D D') → Signature C D D' := @UniMath.SubstitutionSystems.SumOfSignatures.Sum_of_Signatures. (** Definition 7: Binary product of signatures with strength *) Definition BinProduct_of_Signatures : ∏ (C D D' : category), BinProducts D → Signature C D D' → Signature C D D' → Signature C D D' := @UniMath.SubstitutionSystems.BinProductOfSignatures.BinProduct_of_Signatures. (** Problem 8: Signatures with strength from binding signatures *) Definition BindingSigToSignature : ∏ {C : category}, BinProducts C → BinCoproducts C → Terminal C → ∏ sig : BindingSig, Coproducts (BindingSigIndex sig) C → Signature C C C := @UniMath.SubstitutionSystems.BindingSigToMonad.BindingSigToSignature. (** Definition 10 and Lemma 11 and 12: see UniMath/SubstitutionSystems/SignatureExamples.v *) (** Definition 15: Graph *) Definition graph : UU := @UniMath.CategoryTheory.limits.graphs.colimits.graph. (** Definition 16: Diagram *) Definition diagram : graph → category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.diagram. (** Definition 17: Cocone *) Definition cocone : ∏ {C : category} {g : graph}, diagram g C → C → UU := @UniMath.CategoryTheory.limits.graphs.colimits.cocone. (** Definition 18: Colimiting cocone *) Definition isColimCocone : ∏ {C : category} {g : graph} (d : diagram g C) (c0 : C), cocone d c0 → UU := @UniMath.CategoryTheory.limits.graphs.colimits.isColimCocone. (** Colimits of a specific shape *) Definition Colims_of_shape : graph → category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.Colims_of_shape. (** Colimits of any shape *) Definition Colims : category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.Colims. (** Remark 19: Uniqueness of colimits *) Lemma isaprop_Colims : ∏ C : univalent_category, isaprop (Colims C). Proof. exact @UniMath.CategoryTheory.limits.graphs.colimits.isaprop_Colims. Defined. (** Definition 20: Preservation of colimits *) Definition preserves_colimit : ∏ {C D : category}, functor C D → ∏ {g : graph} (d : diagram g C) (L : C), cocone d L → UU := @UniMath.CategoryTheory.limits.graphs.colimits.preserves_colimit. Definition is_cocont : ∏ {C D : category}, functor C D → UU := @UniMath.CategoryTheory.Chains.Chains.is_cocont. Definition is_omega_cocont : ∏ {C D : category}, functor C D → UU := @UniMath.CategoryTheory.Chains.Chains.is_omega_cocont. (** Lemma 21: Invariance of cocontinuity under isomorphism *) Lemma preserves_colimit_z_iso : ∏ (C D : category) (F G : functor C D) (α : @z_iso [C, D] F G) (g : graph) (d : diagram g C) (L : C) (cc : cocone d L), preserves_colimit F d L cc → preserves_colimit G d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_z_iso. Defined. (** Problem 22: Colimits in functor categories *) Definition ColimsFunctorCategory_of_shape : ∏ (g : graph) (A C : category), Colims_of_shape g C → Colims_of_shape g [A, C] := @UniMath.CategoryTheory.limits.graphs.colimits.ColimsFunctorCategory_of_shape. (** Problem 24: Initial algebras of ω-cocontinuous functors *) Definition colimAlgInitial : ∏ (C : category) (InitC : Initial C) (F : functor C C), is_omega_cocont F → ColimCocone (initChain InitC F) → Initial (FunctorAlg F) := @UniMath.CategoryTheory.Chains.Adamek.colimAlgInitial. (** Lemma 25: Lambek's lemma *) Lemma initialAlg_is_z_iso : ∏ (C : category) (F : functor C C) (Aa : algebra_ob F), isInitial (FunctorAlg F) Aa → is_z_isomorphism (alg_map F Aa). Proof. exact @UniMath.CategoryTheory.FunctorAlgebras.initialAlg_is_z_iso. Defined. (** Problem 27: Colimits in Set *) Lemma ColimsHSET_of_shape : ∏ (g : graph), Colims_of_shape g HSET. Proof. exact @UniMath.CategoryTheory.categories.HSET.Colimits.ColimsHSET_of_shape. Defined. (** Lemma 31: Left adjoints preserve colimits *) Lemma left_adjoint_cocont : ∏ (C D : category) (F : functor C D), is_left_adjoint F → is_cocont F. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.left_adjoint_cocont. Defined. (** Lemma 32: Examples of preservation of colimits *) (** (i): Identity functor *) Lemma preserves_colimit_identity : ∏ (C : category) (g : colimits.graph) (d : colimits.diagram g C) (L : C) (cc : colimits.cocone d L), preserves_colimit (functor_identity C) d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_identity. Defined. (** (ii): Constant functor *) Lemma is_omega_cocont_constant_functor : ∏ (C D : category) (x : D), Chains.Chains.is_omega_cocont (constant_functor C D x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constant_functor. Defined. (** (iii): Diagonal functor *) Lemma is_cocont_delta_functor : ∏ (I : UU) (C : category), Products I C → is_cocont (delta_functor I C). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_delta_functor. Defined. Lemma is_omega_cocont_delta_functor : ∏ (I : UU) (C : category), Products I C → is_omega_cocont (delta_functor I C). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_delta_functor. Defined. (** (iv): Coproduct functor *) Lemma is_cocont_coproduct_functor : ∏ (I : UU) (C : category) (PC : Coproducts I C), is_cocont (coproduct_functor I PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_coproduct_functor. Defined. Lemma is_omega_cocont_coproduct_functor : ∏ (I : UU) (C : category) (PC : Coproducts I C), is_omega_cocont (coproduct_functor I PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_coproduct_functor. Defined. (** Lemma 33: Examples of preservation of cocontinuity *) (** (i): Composition of functors *) Lemma preserves_colimit_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E) (g : graph) (d : diagram g C) (L : C) (cc : cocone d L), preserves_colimit F d L cc → preserves_colimit G (mapdiagram F d) (F L) (mapcocone F d cc) → preserves_colimit (functor_composite F G) d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_functor_composite. Defined. Lemma is_cocont_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E), is_cocont F → is_cocont G → is_cocont (functor_composite F G). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_functor_composite. Defined. Lemma is_omega_cocont_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E), is_omega_cocont F → is_omega_cocont G → is_omega_cocont (functor_composite F G). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_functor_composite. Defined. (** (ii) Tuple functor *) Lemma is_cocont_tuple_functor : ∏ (I : UU) (A : category) (B: I -> category) (F : ∏ i, functor A (B i)), (∏ i, is_cocont (F i)) -> is_cocont (tuple_functor F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_tuple_functor. Defined. Lemma is_omega_cocont_tuple_functor : ∏ (I : UU) (A : category) (B: I -> category) (F : ∏ i, functor A (B i)), (∏ i, is_omega_cocont (F i)) -> is_omega_cocont (tuple_functor F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_tuple_functor. Defined. (** (iii): Families of functors *) Lemma is_cocont_family_functor : ∏ (I : UU) (A B : category), isdeceq I → ∏ F : I → functor A B, (∏ i : I, is_cocont (F i)) → is_cocont (family_functor I F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_family_functor. Defined. Lemma is_omega_cocont_family_functor : ∏ (I : UU) (A B : category), isdeceq I → ∏ F : I → functor A B, (∏ i : I, is_omega_cocont (F i)) → is_omega_cocont (family_functor I F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_family_functor. Defined. (** Example 35: Exponentials in Set *) Definition Exponentials_HSET : Exponentials BinProductsHSET := @UniMath.CategoryTheory.categories.HSET.Structures.Exponentials_HSET. (** Lemma 36: Left and right product functors preserves colimits *) Lemma is_cocont_constprod_functor1 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_cocont (constprod_functor1 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_constprod_functor1. Defined. Lemma is_omega_cocont_constprod_functor1 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_omega_cocont (constprod_functor1 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constprod_functor1. Defined. Lemma is_cocont_constprod_functor2 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_cocont (constprod_functor2 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_constprod_functor2. Defined. Lemma is_omega_cocont_constprod_functor2 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_omega_cocont (constprod_functor2 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constprod_functor2. Defined. (** Theorem 37: Binary product functor is ω-cocontinuous *) Lemma is_omega_cocont_binproduct_functor : ∏ (C : category) (PC : BinProducts C), (∏ x : C, is_omega_cocont (constprod_functor1 PC x)) → is_omega_cocont (binproduct_functor PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_binproduct_functor. Defined. (** Example 38: Lists of sets *) (* see: UniMath/CategoryTheory/Inductives/Lists.v *) (** Theorem 41: Precomposition functor preserves colimits *) Lemma preserves_colimit_pre_composition_functor : ∏ (A B C : category) (F : functor A B) (g : graph) (d : diagram g [B, C]) (G : [B, C]) (ccG : cocone d G), (∏ b : B, ColimCocone (diagram_pointwise d b)) → preserves_colimit (pre_composition_functor A B C F) d G ccG. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_pre_composition_functor. Defined. Lemma is_omega_cocont_pre_composition_functor : ∏ (A B C : category) (F : functor A B), Colims_of_shape nat_graph C → is_omega_cocont (pre_composition_functor A B C F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_pre_composition_functor. Defined. (** Theorem 43: Signature functor associated to a binding signature is ω-cocontinuous *) Lemma is_omega_cocont_BindingSigToSignature : ∏ (C : category) (BPC : BinProducts C) (BCC : BinCoproducts C) (TC : Terminal C), Colims_of_shape nat_graph C → (∏ F : functor_category C C, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) → ∏ (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C), is_omega_cocont (pr1 (BindingSigToSignature BPC BCC TC sig CC)). Proof. exact @UniMath.SubstitutionSystems.BindingSigToMonad.is_omega_cocont_BindingSigToSignature. Defined. (** Problem 45: Datatypes specified by binding signatures *) Definition DatatypeOfBindingSig : ∏ (C : category) (BPC : BinProducts C) (BCC : BinCoproducts C) (_ : Initial C) (TC : Terminal C) (_ : Colims_of_shape nat_graph C) (_ : ∏ (F : functor_category C C), is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C), Initial (FunctorAlg (Id_H C BCC (pr1 (BindingSigToSignature BPC BCC TC sig CC)))). Proof. exact @UniMath.SubstitutionSystems.BindingSigToMonad.DatatypeOfBindingSig. Defined. (** Theorem 48: Construction of a substitution operation on an initial algebra *) Definition InitHSS : ∏ (C : category) (CP : BinCoproducts C), Initial C → Colims_of_shape nat_graph C → ∏ H : UniMath.SubstitutionSystems.Signatures.Presignature C C C, is_omega_cocont (pr1 H) → hss_category CP H. Proof. exact @UniMath.SubstitutionSystems.LiftingInitial_alt.InitHSS. Defined. Lemma isInitial_InitHSS : ∏ (C : category) (CP : BinCoproducts C) (IC : Initial C) (CC : Colims_of_shape nat_graph C) (H : UniMath.SubstitutionSystems.Signatures.Presignature C C C) (HH : is_omega_cocont (pr1 H)), isInitial (hss_category CP H) (InitHSS C CP IC CC H HH). Proof. exact @UniMath.SubstitutionSystems.LiftingInitial_alt.isInitial_InitHSS. Defined. (** Section 4.2: Binding signatures to monads *) Definition BindingSigToMonad : ∏ (C : category) (BPC : BinProducts C), BinCoproducts C → Terminal C → Initial C → Colims_of_shape nat_graph C → (∏ F, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) → ∏ sig : BindingSig, Coproducts (BindingSigIndex sig) C → Monad C. Proof. exact @UniMath.SubstitutionSystems.BindingSigToMonad.BindingSigToMonad. Defined. (** Example 50: Untyped lambda calculus *) (* See: UniMath/SubstitutionSystems/LamFromBindingSig.v *) (** Example 51: Raw syntax of Martin-Löf type theory *) (* See: UniMath/SubstitutionSystems/MLTT79.v *) UniMath-20231010/UniMath/SubstitutionSystems/GenMendlerIteration.v000066400000000000000000000216461451125700300250570ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Derivation of Generalized Iteration in Mendler-style - Instantiation to a special case, Specialized Mendler Iteration - Proof of a fusion law à la Bird-Paterson (Generalised folds for nested datatypes) for Generalized Iteration in Mendler-style ************************************************************) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.Adjunctions.Core. Arguments functor_composite {_ _ _} _ _ . Arguments nat_trans_comp {_ _ _ _ _} _ _ . Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35). Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Local Notation "↓ f" := (mor_from_algebra_mor _ f) (at level 3, format "↓ f"). (* in Agda mode \downarrow *) (** Goal: derive Generalized Iteration in Mendler-style and a fusion law *) (** * Generalized Iteration in Mendler-style *) Section GenMenIt. Context (C : category) (F : functor C C). Let AF := FunctorAlg F. Definition AlgConstr (A : C) (α : F A --> A) : AF. Proof. exists A. exact α. Defined. Notation "⟨ A , α ⟩" := (AlgConstr A α). (* \< , \> *) Variable μF_Initial : Initial AF. Let μF : C := alg_carrier _ (InitialObject μF_Initial). Let inF : F μF --> μF := alg_map _ (InitialObject μF_Initial). Let iter {A : C} (α : F A --> A) : μF --> A := ↓(InitialArrow μF_Initial ⟨A,α⟩). Context (C' : category). Section the_iteration_principle. Variable X : C'. Let Yon : functor C'^op HSET := yoneda_objects C' X. Variable L : functor C C'. Variable is_left_adj_L : is_left_adjoint L. Let φ := @φ_adj _ _ _ _ (pr2 is_left_adj_L). Let φ_inv := @φ_adj_inv _ _ _ _ (pr2 is_left_adj_L). Let R : functor _ _ := right_adjoint is_left_adj_L. Let η : nat_trans _ _ := unit_from_left_adjoint is_left_adj_L. Let ε : nat_trans _ _ := counit_from_left_adjoint is_left_adj_L. (* Let φ_natural_precomp := @φ_adj_natural_precomp _ _ _ is_left_adj_L. Let φ_inv_natural_precomp := @φ_adj_inv_natural_precomp _ _ _ is_left_adj_L. Let φ_after_φ_inv := @φ_adj_after_φ_adj_inv _ _ _ is_left_adj_L. Let φ_inv_after_φ := @φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L.*) Arguments φ {_ _} _ . Arguments φ_inv {_ _} _ . Definition ψ_source : functor C^op HSET := functor_composite (functor_opp L) Yon. Definition ψ_target : functor C^op HSET := functor_composite (functor_opp F) ψ_source. Section general_case. Variable ψ : ψ_source ⟹ ψ_target. Definition preIt : L μF --> X := φ_inv (iter (φ (ψ (R X) (ε X)))). Lemma ψ_naturality (A B: C)(h: B --> A)(f: L A --> X): ψ B (#L h· f) = #L (#F h)· ψ A f. Proof. assert (ψ_is_nat := nat_trans_ax ψ); assert (ψ_is_nat_inst1 := ψ_is_nat _ _ h). (* assert (ψ_is_nat_inst2 := aux0 _ _ _ _ f ψ_is_nat_inst1). *) assert (ψ_is_nat_inst2 := eqtohomot ψ_is_nat_inst1 f). apply ψ_is_nat_inst2. Qed. Lemma truth_about_ε (A: C'): ε A = φ_inv (identity (R A)). Proof. unfold φ_inv, φ_adj_inv. rewrite functor_id. apply pathsinv0. apply id_left. Qed. Lemma φ_ψ_μF_eq (h: L μF --> X): φ (ψ μF h) = #F (φ h) · φ(ψ (R X) (ε X)). Proof. rewrite <- (φ_adj_natural_precomp (pr2 is_left_adj_L)). apply maponpaths. eapply pathscomp0. 2: apply ψ_naturality. apply maponpaths. rewrite truth_about_ε. rewrite <- (φ_adj_inv_natural_precomp (pr2 is_left_adj_L)). rewrite id_right. apply pathsinv0. change (φ_inv(φ h) = h). apply φ_adj_inv_after_φ_adj. Qed. Lemma cancel_φ {A: C}{B: C'} (f g : L A --> B): φ f = φ g -> f = g. Proof. intro Hyp. (* pedestrian way: rewrite <- (φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L f). rewrite <- (φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L g). apply maponpaths. exact Hyp. *) apply (invmaponpathsweq (adjunction_hom_weq (pr2 is_left_adj_L) _ _)). exact Hyp. Qed. Lemma preIt_ok : # L inF· preIt = ψ μF preIt. Proof. apply cancel_φ. rewrite φ_ψ_μF_eq. rewrite (φ_adj_natural_precomp (pr2 is_left_adj_L)). unfold preIt. rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)). rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)). assert (iter_eq := algebra_mor_commutes _ _ _ (InitialArrow μF_Initial ⟨_,φ (ψ (R X) (ε X))⟩)). exact iter_eq. Qed. Lemma preIt_uniq (t : ∑ h : L μF --> X, # L inF· h = ψ μF h): t = tpair (λ h : L μF --> X, # L inF· h = ψ μF h) preIt preIt_ok. Proof. destruct t as [h h_rec_eq]; simpl. assert (same: h = preIt). 2: { apply subtypePath. + intro. apply homset_property. + simpl. exact same. } apply cancel_φ. unfold preIt. rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)). (* assert (iter_uniq := algebra_mor_commutes _ _ _ *) (* (InitialArrow μF_Initial ⟨_,φ (ψ (R X) (ε X))⟩)). *) (* simpl in iter_uniq. *) assert(φh_is_alg_mor: inF · φ h = #F(φ h) · φ (ψ (R X) (ε X))). (* remark: I am missing a definition of the algebra morphism property in UniMath.CategoryTheory.FunctorAlgebras *) + rewrite <- φ_ψ_μF_eq. rewrite <- (φ_adj_natural_precomp (pr2 is_left_adj_L)). apply maponpaths. exact h_rec_eq. + (* set(φh_alg_mor := tpair _ _ φh_is_alg_mor : pr1 μF_Initial --> ⟨ R X, φ (ψ (R X) (ε X)) ⟩). *) use (let X : AF ⟦ InitialObject μF_Initial, ⟨ R X, φ (ψ (R X) (ε X)) ⟩ ⟧ := _ in _). * apply (tpair _ (φ h)); assumption. * apply (maponpaths pr1 (InitialArrowUnique _ _ X0)). Qed. Theorem GenMendlerIteration : iscontr (∑ h : L μF --> X, #L inF · h = ψ μF h). Proof. use tpair. - exists preIt. exact preIt_ok. - exact preIt_uniq. Defined. Definition It : L μF --> X := pr1 (pr1 GenMendlerIteration). Lemma It_is_preIt : It = preIt. Proof. apply idpath. Qed. End general_case. (** * Specialized Mendler Iteration *) Section special_case. Variable G : functor C' C'. Variable ρ : G X --> X. Variable θ : functor_composite F L ⟹ functor_composite L G. Lemma is_nat_trans_ψ_from_comps : is_nat_trans ψ_source ψ_target (λ (A : C^op) (f : yoneda_objects_ob C' X (L A)), θ A· # G f· ρ). Proof. intros A B h. apply funextfun. intro f. simpl. unfold compose at 1 5; simpl. rewrite functor_comp. repeat rewrite assoc. assert (θ_nat_trans_ax := nat_trans_ax θ). unfold functor_composite in θ_nat_trans_ax. simpl in θ_nat_trans_ax. rewrite <- θ_nat_trans_ax. apply idpath. Qed. Definition ψ_from_comps : ψ_source ⟹ ψ_target. Proof. use tpair. - intro A. simpl. intro f. unfold yoneda_objects_ob in *. exact (θ A · #G f · ρ). - apply is_nat_trans_ψ_from_comps. Defined. Definition SpecialGenMendlerIteration : iscontr (∑ h : L μF --> X, # L inF · h = θ μF · #G h · ρ) := GenMendlerIteration ψ_from_comps. End special_case. End the_iteration_principle. (** * Fusion law for Generalized Iteration in Mendler-style *) Variable X X': C'. Let Yon : functor C'^op HSET := yoneda_objects C' X. Let Yon' : functor C'^op HSET := yoneda_objects C' X'. Variable L : functor C C'. Variable is_left_adj_L : is_left_adjoint L. Variable ψ : ψ_source X L ⟹ ψ_target X L. Variable L' : functor C C'. Variable is_left_adj_L' : is_left_adjoint L'. Variable ψ' : ψ_source X' L' ⟹ ψ_target X' L'. Variable Φ : functor_composite (functor_opp L) Yon ⟹ functor_composite (functor_opp L') Yon'. Section fusion_law. Variable H : ψ μF · Φ (F μF) = Φ μF · ψ' μF. Theorem fusion_law : Φ μF (It X L is_left_adj_L ψ) = It X' L' is_left_adj_L' ψ'. Proof. apply pathsinv0. apply pathsinv0. apply path_to_ctr. assert (Φ_is_nat := nat_trans_ax Φ). assert (Φ_is_nat_inst1 := Φ_is_nat _ _ inF). assert (Φ_is_nat_inst2 := eqtohomot Φ_is_nat_inst1 (It X L is_left_adj_L ψ)). unfold compose in Φ_is_nat_inst2; simpl in Φ_is_nat_inst2. simpl. rewrite <- Φ_is_nat_inst2. assert (H_inst := eqtohomot H (It X L is_left_adj_L ψ)). unfold compose in H_inst; simpl in H_inst. rewrite <- H_inst. apply maponpaths. rewrite It_is_preIt. apply preIt_ok. Qed. End fusion_law. End GenMenIt. UniMath-20231010/UniMath/SubstitutionSystems/GenMendlerIteration_alt.v000066400000000000000000000223331451125700300257110ustar00rootroot00000000000000(** ********************************************************** Contents: - Derivation of Generalized Iteration in Mendler-style Instantiation to a special case, Specialized - Mendler Iteration Proof of a fusion law à la Bird-Paterson (Generalised folds for nested datatypes, theorem 1) for Generalized Iteration in Mendler-style This file differs from GenMendlerIteration.v in the hypotheses. Here we use omega cocontinuity instead of Kan extensions. Written by: Anders Mörtberg, 2016. Based on a note by Ralph Matthes. ************************************************************) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Adamek. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.whiskering. Local Open Scope cat. Arguments functor_composite {_ _ _} _ _ . Arguments nat_trans_comp {_ _ _ _ _} _ _ . Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35). Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Local Notation "↓ f" := (mor_from_algebra_mor _ _ _ f) (at level 3, format "↓ f"). Local Notation "'chain'" := (diagram nat_graph). (** Goal: derive Generalized Iteration in Mendler-style and a fusion law *) (** * Generalized Iteration in Mendler-style *) Section GenMenIt. Context {C : category} (IC : Initial C) (CC : Colims_of_shape nat_graph C) (F : functor C C) (HF : is_omega_cocont F). Local Notation "0" := (InitialObject IC). Let AF : category := FunctorAlg F. Let chnF : chain C := initChain IC F. Let μF_Initial : Initial AF := colimAlgInitial IC HF (CC chnF). Let μF : C := alg_carrier _ (InitialObject μF_Initial). Let inF : C⟦F μF,μF⟧ := alg_map _ (InitialObject μF_Initial). Let e : ∏ (n : nat), C⟦iter_functor F n IC,μF⟧ := colimIn (CC chnF). Let cocone_μF : cocone chnF μF := colimCocone (CC chnF). Local Lemma e_comm (n : nat) : e (S n) = # F (e n) · inF. Proof. apply pathsinv0, (colimArrowCommutes (make_ColimCocone _ _ _ (HF _ _ _ (isColimCocone_from_ColimCocone (CC chnF))))). Qed. Context {D : category}. Section the_iteration_principle. Variables (X : D) (L : functor C D) (IL : isInitial D (L 0)) (HL : is_omega_cocont L). Let ILD : Initial D := tpair _ _ IL. Local Notation "'L0'" := (InitialObject ILD). Let Yon : functor D^op HSET := yoneda_objects D X. Definition ψ_source : functor C^op HSET := functor_composite (functor_opp L) Yon. Definition ψ_target : functor C^op HSET := functor_composite (functor_opp F) ψ_source. Section general_case. Variable (ψ : ψ_source ⟹ ψ_target). Let LchnF : chain D := mapchain L chnF. Let z : D⟦L0,X⟧ := InitialArrow ILD X. Local Definition Pow_source : functor C^op HSET := ψ_source. Local Definition Pow_target (n : nat) : functor C^op HSET := functor_composite (functor_opp (iter_functor F n)) ψ_source. Local Definition Pow (n : nat) : Pow_source ⟹ Pow_target n. Proof. induction n as [|n Pown]. - apply nat_trans_id. - apply (nat_trans_comp Pown (pre_whisker (functor_opp (iter_functor F n)) ψ)). Defined. Local Lemma Pow_cocone_subproof n : dmor LchnF (idpath (S n)) · pr1 (Pow (S n)) IC z = pr1 (Pow n) IC z. Proof. induction n as [|n IHn]. + cbn. apply (InitialArrowUnique ILD). + change (pr1 (Pow (S (S n))) _ z) with (ψ (iter_functor F (S n) 0) (Pow (S n) _ z)). assert (H : dmor LchnF (idpath (S (S n))) · ψ ((iter_functor F (S n)) IC) ((Pow (S n)) IC z) = ψ (iter_functor F n 0) (dmor LchnF (idpath (S n)) · pr1 (Pow (S n)) _ z)). { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (dmor chnF (idpath (S n))))). } now rewrite H, IHn. Qed. Local Definition Pow_cocone : cocone LchnF X. Proof. use make_cocone. - intro n. apply (pr1 (Pow n) _ z). - abstract (intros n m k; induction k; apply Pow_cocone_subproof). Defined. Local Definition CC_LchnF : ColimCocone LchnF. Proof. use make_ColimCocone. - apply (L μF). - apply (mapcocone L _ cocone_μF). - apply HL, (isColimCocone_from_ColimCocone (CC chnF)). Defined. Definition preIt : D⟦L μF,X⟧ := colimArrow CC_LchnF X Pow_cocone. Local Lemma eqSS n : # L (e n) · preIt = Pow n IC z. Proof. apply (colimArrowCommutes CC_LchnF). Qed. Local Lemma is_z_iso_inF : is_z_isomorphism inF. Proof. (* Use Lambek's lemma, this could be extracted from the concrete proof as well *) apply initialAlg_is_z_iso, pr2. Defined. Let inF_z_iso : z_iso (F μF) μF := make_z_iso' _ is_z_iso_inF. Let inF_inv : C⟦μF,F μF⟧ := inv_from_z_iso inF_z_iso. (* The direction * -> ** *) Lemma S_imp_SS h n : # L inF · h = ψ μF h → # L (e n) · h = Pow n IC z. Proof. intros Hh. induction n. - cbn. apply (InitialArrowUnique ILD). - rewrite e_comm, functor_comp, <- assoc, Hh. assert (H : # L (# F (e n)) · ψ μF h = ψ (iter_functor F n 0) (# L (e n) · h)). { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (e n))). } now rewrite H, IHn. Qed. (* The direction ** -> * *) Local Lemma SS_imp_S (H : ∏ n, # L (e n) · preIt = Pow n IC z) : # L inF · preIt = ψ μF preIt. Proof. assert (H'' : # L inF · # L inF_inv = identity _). { rewrite <- functor_comp, <- functor_id. apply maponpaths, (z_iso_inv_after_z_iso inF_z_iso). } assert (H' : ∏ n, # L (e (S n)) · # L inF_inv · ψ μF preIt = pr1 (Pow (S n)) _ z). { intro n. rewrite e_comm, functor_comp. etrans; [apply cancel_postcomposition; rewrite <-assoc; apply maponpaths, H''|]. rewrite id_right. assert (H1 : # L (# F (e n)) · ψ μF preIt = ψ (iter_functor F n 0) (# L (e n) · preIt)). { apply pathsinv0, (eqtohomot (nat_trans_ax ψ _ _ (e n))). } etrans; [ apply H1|]. now rewrite H. } assert (HH : preIt = # L inF_inv · ψ μF preIt). { apply pathsinv0, (colimArrowUnique CC_LchnF); simpl; intro n. destruct n. - apply (InitialArrowUnique ILD). - simpl; etrans; [| apply H']. now apply assoc. } etrans; [ apply maponpaths, HH|]. now rewrite assoc, H'', id_left. Qed. Lemma preIt_ok : # L inF · preIt = ψ μF preIt. Proof. now apply SS_imp_S; intro n; apply eqSS. Qed. Lemma preIt_uniq (t : ∑ h, # L inF · h = ψ μF h) : t = (preIt,,preIt_ok). Proof. apply subtypePath; [intros f; apply homset_property|]; simpl. destruct t as [f Hf]; simpl. apply (colimArrowUnique CC_LchnF); intro n. now apply S_imp_SS, Hf. Qed. Theorem GenMendlerIteration : ∃! (h : L μF --> X), #L inF · h = ψ μF h. Proof. use tpair. - apply (preIt,,preIt_ok). - exact preIt_uniq. Defined. Definition It : L μF --> X := pr1 (pr1 GenMendlerIteration). Lemma It_is_preIt : It = preIt. Proof. apply idpath. Qed. End general_case. (** * Specialized Mendler Iteration *) Section special_case. Variables (G : functor D D) (ρ : G X --> X). Variables (θ : functor_composite F L ⟹ functor_composite L G). Lemma is_nat_trans_ψ_from_comps : is_nat_trans ψ_source ψ_target (λ A (f : yoneda_objects_ob D X (L A)), θ A · # G f · ρ). Proof. intros A B h; apply funextfun; intro f; cbn. rewrite functor_comp, !assoc. assert (θ_nat_trans_ax := nat_trans_ax θ); simpl in θ_nat_trans_ax. now rewrite <- θ_nat_trans_ax. Qed. Definition ψ_from_comps : ψ_source ⟹ ψ_target. Proof. use tpair. - intros A f. exact (θ A · #G f · ρ). - apply is_nat_trans_ψ_from_comps. Defined. Definition SpecialGenMendlerIteration : ∃! (h : L μF --> X), # L inF · h = θ μF · #G h · ρ := GenMendlerIteration ψ_from_comps. End special_case. End the_iteration_principle. (** * Fusion law for Generalized Iteration in Mendler-style *) Section fusion_law. Variables (X X' : D). Let Yon : functor D^op HSET := yoneda_objects D X. Let Yon' : functor D^op HSET := yoneda_objects D X'. Variables (L : functor C D) (HL : is_omega_cocont L) (IL : isInitial D (L 0)). Variables (ψ : ψ_source X L ⟹ ψ_target X L). Variables (L' : functor C D) (HL' : is_omega_cocont L') (IL' : isInitial D (L' 0)). Variables (ψ' : ψ_source X' L' ⟹ ψ_target X' L'). Variables (Φ : functor_composite (functor_opp L) Yon ⟹ functor_composite (functor_opp L') Yon'). Variables (H : ψ μF · Φ (F μF) = Φ μF · ψ' μF). Theorem fusion_law : Φ μF (It X L IL HL ψ) = It X' L' IL' HL' ψ'. Proof. apply path_to_ctr. assert (Φ_is_nat := nat_trans_ax Φ). assert (Φ_is_nat_inst1 := Φ_is_nat _ _ inF). assert (Φ_is_nat_inst2 := eqtohomot Φ_is_nat_inst1 (It X L IL HL ψ)). unfold compose in Φ_is_nat_inst2; simpl in Φ_is_nat_inst2. simpl. rewrite <- Φ_is_nat_inst2. assert (H_inst := eqtohomot H (It X L IL HL ψ)). unfold compose in H_inst; simpl in H_inst. rewrite <- H_inst. apply maponpaths. rewrite It_is_preIt. apply preIt_ok. Qed. End fusion_law. End GenMenIt. UniMath-20231010/UniMath/SubstitutionSystems/GeneralizedSubstitutionSystems.v000066400000000000000000000435621451125700300274370ustar00rootroot00000000000000(** a generalization of heterogeneous substitution systems to monoidal categories in place of endofunctor categories author: Ralph Matthes 2022 Update in 2023: Instead of speaking about generalized heterogeneous substitution systems (short ghss), it seems better to call them monoidal heterogeneous substitution systems (short mhss). The name of the file stays the same. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.coslicecat. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. (* Import ActegoryNotations. *) Section hss. Context {V : category} (Mon_V : monoidal V). Local Definition PtdV : category := coslice_cat_total V I_{Mon_V}. Local Definition Mon_PtdV : monoidal PtdV := monoidal_pointed_objects Mon_V. Local Definition Act : actegory Mon_PtdV V := actegory_with_canonical_pointed_action Mon_V. Context (H : V ⟶ V). Context (θ : pointedtensorialstrength Mon_V H). Section TheProperty. Context (t : V) (η : I_{Mon_V} --> t) (τ : H t --> t). Definition mbracket_property_parts {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : UU := (ru^{Mon_V}_{z} · f = z ⊗^{Mon_V}_{l} η · h) × (θ (z,,e) t · #H h · τ = z ⊗^{Mon_V}_{l} τ · h). Definition mbracket_parts_at {z : V} (e : I_{Mon_V} --> z) (f : z --> t) : UU := ∃! h : z ⊗_{Mon_V} t --> t, mbracket_property_parts e f h. Definition mbracket : UU := ∏ (Z : PtdV) (f : pr1 Z --> t), mbracket_parts_at (pr2 Z) f. Lemma isaprop_mbracket_property_parts {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : isaprop (mbracket_property_parts e f h). Proof. apply isapropdirprod; apply V. Qed. Lemma isaprop_mbracket : isaprop mbracket. Proof. apply impred_isaprop; intro Z. apply impred_isaprop; intro f. apply isapropiscontr. Qed. Section PropertyAsOneEquation. Context (CP : BinCoproducts V). Definition Const_plus_H (v : V) : functor V V := BinCoproduct_of_functors _ _ CP (constant_functor _ _ v) H. Definition mbracket_property_single {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : UU := actegory_bincoprod_antidistributor Mon_PtdV CP Act (z,,e) I_{Mon_V} (H t) · (z,,e) ⊗^{Act}_{l} (BinCoproductArrow (CP _ _) η τ) · h = BinCoproductOfArrows _ (CP _ _) (CP _ _) (ru_{Mon_V} z) (θ (z,,e) t) · #(Const_plus_H z) h · BinCoproductArrow (CP _ _) f τ. Lemma isaprop_mbracket_property_single {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : isaprop (mbracket_property_single e f h). Proof. apply V. Qed. Lemma mbracket_property_single_equivalent {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : mbracket_property_parts e f h <-> mbracket_property_single e f h. Proof. split. - intros [Hη Hτ]. use BinCoproductArrowsEq. + etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans. { apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Act (z,,e))). } rewrite BinCoproductIn1Commutes. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn1. } etrans. { apply pathsinv0, Hη. } repeat rewrite assoc'. apply maponpaths. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn1. } rewrite assoc'. rewrite id_left. apply pathsinv0, BinCoproductIn1Commutes. + etrans. { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans. { apply cancel_postcomposition. apply pathsinv0, (functor_comp (leftwhiskering_functor Act (z,,e))). } rewrite BinCoproductIn2Commutes. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn2. } etrans. { apply pathsinv0, Hτ. } repeat rewrite assoc'. apply maponpaths. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn2. } rewrite assoc'. apply maponpaths. apply pathsinv0, BinCoproductIn2Commutes. - intro H1. split. + apply (maponpaths (fun m => BinCoproductIn1 (CP _ _) · m)) in H1. unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in H1. repeat rewrite assoc in H1. rewrite BinCoproductIn1Commutes in H1. assert (aux := functor_comp (leftwhiskering_functor Act (z,,e)) (BinCoproductIn1 (CP I_{ Mon_V} (H t))) (BinCoproductArrow (CP I_{ Mon_V} (H t)) η τ)). cbn in aux. apply (maponpaths (fun m => m · h)) in aux. assert (H1' := aux @ H1). clear H1 aux. rewrite BinCoproductIn1Commutes in H1'. etrans. 2: { apply pathsinv0, H1'. } clear H1'. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn1. } repeat rewrite assoc'. apply maponpaths. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn1. } rewrite assoc'. rewrite id_left. apply pathsinv0, BinCoproductIn1Commutes. + apply (maponpaths (fun m => BinCoproductIn2 (CP _ _) · m)) in H1. unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in H1. repeat rewrite assoc in H1. rewrite BinCoproductIn2Commutes in H1. assert (aux := functor_comp (leftwhiskering_functor Act (z,,e)) (BinCoproductIn2 (CP I_{ Mon_V} (H t))) (BinCoproductArrow (CP I_{ Mon_V} (H t)) η τ)). cbn in aux. apply (maponpaths (fun m => m · h)) in aux. assert (H1' := aux @ H1). clear H1 aux. rewrite BinCoproductIn2Commutes in H1'. etrans. 2: { apply pathsinv0, H1'. } clear H1'. etrans. 2: { repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn2. } repeat rewrite assoc'. apply maponpaths. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply pathsinv0, BinCoproductOfArrowsIn2. } rewrite assoc'. apply maponpaths. apply pathsinv0, BinCoproductIn2Commutes. Qed. End PropertyAsOneEquation. End TheProperty. Definition mhss : UU := ∑ (t : V) (η : I_{Mon_V} --> t) (τ : H t --> t), mbracket t η τ. Coercion carriermhss (t : mhss) : V := pr1 t. Section FixAMhss. Context (gh : mhss). Definition eta_from_alg : I_{Mon_V} --> gh := pr12 gh. Definition tau_from_alg : H gh --> gh := pr122 gh. Local Notation η := eta_from_alg. Local Notation τ := tau_from_alg. Definition Ptd_from_mhss : PtdV := (pr1 gh,,η). Definition mfbracket (Z : PtdV) (f : pr1 Z --> gh) : pr1 Z ⊗_{Mon_V} gh --> gh := pr1 (pr1 (pr222 gh Z f)). Notation "⦃ f ⦄_{ Z }" := (mfbracket Z f)(at level 0). Lemma mfbracket_unique {Z : PtdV} (f : pr1 Z --> gh) : ∏ α : pr1 Z ⊗_{Mon_V} gh --> gh, mbracket_property_parts gh η τ (pr2 Z) f α → α = ⦃f⦄_{Z}. Proof. intros α Hyp. apply path_to_ctr. assumption. Qed. Lemma mfbracket_η {Z : PtdV} (f : pr1 Z --> gh) : ru^{Mon_V}_{pr1 Z} · f = pr1 Z ⊗^{Mon_V}_{l} η · ⦃f⦄_{Z}. Proof. exact (pr1 ((pr2 (pr1 (pr222 gh Z f))))). Qed. Lemma mfbracket_τ {Z : PtdV} (f : pr1 Z --> gh) : θ Z gh · #H ⦃f⦄_{Z} · τ = pr1 Z ⊗^{Mon_V}_{l} τ · ⦃f⦄_{Z}. Proof. exact (pr2 ((pr2 (pr1 (pr222 gh Z f))))). Qed. (** there is a restricted form of naturality in the [f] argument, only for pointed [f] *) Lemma mfbracket_natural {Z Z' : PtdV} (f : Z --> Z') (g : pr1 Z' --> gh) : pr1 f ⊗^{ Mon_V}_{r} gh · ⦃g⦄_{Z'} = ⦃pr1 f · g⦄_{Z}. Proof. apply mfbracket_unique. split. - etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). } unfold functoronmorphisms1. etrans. 2: { rewrite assoc'. apply maponpaths. apply mfbracket_η. } repeat rewrite assoc. apply cancel_postcomposition. apply pathsinv0, monoidal_rightunitornat. - etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). } unfold functoronmorphisms1. etrans. 2: { rewrite assoc'. apply maponpaths. apply mfbracket_τ. } rewrite functor_comp. repeat rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0, (lineator_linnatright Mon_PtdV Act Act). Qed. (** As a consequence of naturality, we can compute [mfbracket f] from [mfbracket identity] for pointed morphisms [f] *) Lemma compute_mfbracket {Z : PtdV} (f : Z --> Ptd_from_mhss) : ⦃pr1 f⦄_{Z} = pr1 f ⊗^{ Mon_V}_{r} gh · ⦃identity gh⦄_{Ptd_from_mhss}. Proof. etrans. { rewrite <- (id_right (pr1 f)). apply pathsinv0, mfbracket_natural. } apply idpath. Qed. (** we are constructing a monoid in the monoidal base category *) Definition mu_from_mhss : gh ⊗_{Mon_V} gh --> gh := ⦃identity gh⦄_{Ptd_from_mhss}. Local Notation μ := mu_from_mhss. Definition μ_0 : I_{Mon_V} --> gh := η. Definition μ_0_Ptd : I_{Mon_PtdV} --> Ptd_from_mhss. Proof. exists μ_0. cbn. apply id_left. Defined. Definition μ_1 : I_{Mon_V} ⊗_{Mon_V} gh --> gh := ⦃μ_0⦄_{I_{Mon_PtdV}}. Lemma μ_1_is_instance_of_left_unitor : μ_1 = lu^{Mon_V}_{gh}. Proof. apply pathsinv0, (mfbracket_unique(Z:=I_{Mon_PtdV})). split. - cbn. unfold μ_0. rewrite monoidal_leftunitornat. apply cancel_postcomposition. apply pathsinv0, unitors_coincide_on_unit. - etrans. { apply cancel_postcomposition. apply pointedtensorialstrength_preserves_unitor. apply lineator_preservesunitor. } cbn. apply pathsinv0, monoidal_leftunitornat. Qed. Definition mhss_monoid_data : monoid_data Mon_V gh := μ,,μ_0. Lemma mhss_first_monoidlaw : monoid_laws_unit_right Mon_V mhss_monoid_data. Proof. red. cbn. etrans. { apply pathsinv0, (mfbracket_η(Z:=Ptd_from_mhss)). } apply id_right. Qed. Lemma mhss_second_monoidlaw_aux : ru^{Mon_V}_{I_{Mon_V}} · η = I_{Mon_V} ⊗^{Mon_V}_{l} η · (η ⊗^{Mon_V}_{r} gh · μ). Proof. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). } unfold functoronmorphisms1. rewrite assoc'. etrans. 2: { apply maponpaths. apply pathsinv0, mhss_first_monoidlaw. } apply pathsinv0, monoidal_rightunitornat. Qed. Lemma mhss_second_monoidlaw : monoid_laws_unit_left Mon_V mhss_monoid_data. Proof. red. cbn. etrans. 2: { apply μ_1_is_instance_of_left_unitor. } apply (mfbracket_unique(Z:=I_{Mon_PtdV})). split. - exact mhss_second_monoidlaw_aux. - rewrite functor_comp. transitivity (μ_0 ⊗^{ Mon_V}_{r} H (pr1 gh) · θ Ptd_from_mhss (pr1 gh) · # H μ · τ). (* give this term due to efficiency problems *) { apply cancel_postcomposition. rewrite assoc. apply cancel_postcomposition. apply pathsinv0. set (aux := lineator_linnatright Mon_PtdV (actegory_with_canonical_pointed_action Mon_V) (actegory_with_canonical_pointed_action Mon_V) H θ I_{ Mon_PtdV} Ptd_from_mhss (pr1 gh) μ_0_Ptd). cbn in aux. etrans. { exact aux. } apply idpath. } etrans. { do 2 rewrite assoc'. apply maponpaths. rewrite assoc. apply (mfbracket_τ(Z:=Ptd_from_mhss)). } repeat rewrite assoc. apply cancel_postcomposition. cbn. apply (bifunctor_equalwhiskers Mon_V). Qed. Definition mh_squared : PtdV := Ptd_from_mhss ⊗_{Mon_PtdV} Ptd_from_mhss. Definition μ_2 : gh ⊗_{Mon_V} gh --> gh := μ. Lemma μ_2_is_Ptd_mor : luinv^{Mon_V}_{I_{Mon_V}} · η ⊗^{Mon_V} η · μ_2 = η. Proof. rewrite assoc'. apply (z_iso_inv_on_right _ _ _ (nat_z_iso_pointwise_z_iso (leftunitor_nat_z_iso Mon_V) I_{ Mon_V})). cbn. rewrite unitors_coincide_on_unit. etrans. 2: { apply pathsinv0, mhss_second_monoidlaw_aux. } rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). Qed. Definition μ_2_Ptd : mh_squared --> Ptd_from_mhss := μ_2,,μ_2_is_Ptd_mor. Definition μ_3 : (gh ⊗_{Mon_V} gh) ⊗_{Mon_V} gh --> gh := ⦃μ_2⦄_{mh_squared}. Lemma mhss_third_monoidlaw_aux : θ (pr1 mh_squared,, pr2 mh_squared) gh · # H (μ ⊗^{Mon_V}_{r} gh) = μ_2 ⊗^{Mon_V}_{r} H gh · θ Ptd_from_mhss gh. Proof. apply pathsinv0. assert (aux := lineator_linnatright Mon_PtdV (actegory_with_canonical_pointed_action Mon_V) (actegory_with_canonical_pointed_action Mon_V) H θ mh_squared Ptd_from_mhss gh μ_2_Ptd). simpl in aux. (* simpl not cbn for efficiency of Qed *) etrans. { exact aux. } apply idpath. Qed. Lemma mhss_third_monoidlaw : monoid_laws_assoc Mon_V mhss_monoid_data. Proof. red. cbn. apply pathsinv0. transitivity μ_3. - (** this case is the monoidal generalization of the second item on p.168 of Matthes & Uustalu, TCS 2004 *) apply (mfbracket_unique(Z:=mh_squared)). split. + cbn. etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply (bifunctor_equalwhiskers Mon_V). } unfold functoronmorphisms1. etrans. 2: { rewrite assoc'. apply maponpaths. apply pathsinv0, mhss_first_monoidlaw. } apply pathsinv0, monoidal_rightunitornat. + etrans. { apply cancel_postcomposition. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. exact mhss_third_monoidlaw_aux. } etrans. { do 2 rewrite assoc'. apply maponpaths. rewrite assoc. apply (mfbracket_τ(Z:=Ptd_from_mhss)). } do 2 rewrite assoc. apply cancel_postcomposition. cbn. apply (bifunctor_equalwhiskers Mon_V). - (** this case is the monoidal generalization of the first item on p.168 of Matthes & Uustalu, TCS 2004 *) apply pathsinv0, (mfbracket_unique(Z:=mh_squared)). split. + cbn. etrans. 2: { rewrite assoc. apply cancel_postcomposition. rewrite assoc. rewrite <- monoidal_associatornatleft. rewrite assoc'. apply maponpaths. apply (bifunctor_leftcomp Mon_V). } etrans. 2: { apply cancel_postcomposition. do 2 apply maponpaths. apply pathsinv0, mhss_first_monoidlaw. } apply cancel_postcomposition. apply pathsinv0, left_whisker_with_runitor. + etrans. { apply cancel_postcomposition. rewrite assoc'. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. apply pointedtensorialstrength_preserves_actor. apply lineator_preservesactor. } cbn. etrans. { repeat rewrite assoc'. do 2 apply maponpaths. etrans. { rewrite assoc. apply cancel_postcomposition. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (lineator_linnatleft Mon_PtdV _ _ H θ Ptd_from_mhss _ _ μ). } repeat rewrite assoc'. apply maponpaths. rewrite assoc. apply (mfbracket_τ(Z:=Ptd_from_mhss)). } cbn. repeat rewrite assoc. apply cancel_postcomposition. etrans. { repeat rewrite assoc'. apply maponpaths. do 2 rewrite <- (bifunctor_leftcomp Mon_V). apply maponpaths. rewrite assoc. apply (mfbracket_τ(Z:=Ptd_from_mhss)). } cbn. rewrite (bifunctor_leftcomp Mon_V). repeat rewrite assoc. apply cancel_postcomposition. apply monoidal_associatornatleft. Qed. Definition mhss_monoid : monoid Mon_V gh. Proof. exists mhss_monoid_data. exact (mhss_second_monoidlaw,,mhss_first_monoidlaw,,mhss_third_monoidlaw). Defined. End FixAMhss. End hss. UniMath-20231010/UniMath/SubstitutionSystems/Lam.v000066400000000000000000000415571451125700300216740ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Specification of an initial morphism of substitution systems from lambda calculus with explicit flattening to lambda calculus ************************************************************) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.LiftingInitial. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Section Lambda. Context (C : category). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variable terminal : Terminal C. Variable CC : BinCoproducts C. Variable CP : BinProducts C. Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CC. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let one : C := @TerminalObject C terminal. Variable KanExt : ∏ Z : precategory_Ptd C, RightKanExtension.GlobalRightKanExtensionExists C C (U Z) C. Let Lam_S : Signature _ _ _ := Lam_Sig C terminal CC CP. Let LamE_S : Signature _ _ _ := LamE_Sig C terminal CC CP. (* assume initial algebra for signature Lam *) Variable Lam_Initial : Initial (@category_FunctorAlg [C, C] (Id_H C CC Lam_S)). Let Lam := InitialObject Lam_Initial. (** bracket for Lam from the initial hss obtained via theorem 15+ *) Definition LamHSS_Initial : Initial (hss_category CC Lam_S). Proof. apply InitialHSS. - apply KanExt. - apply Lam_Initial. Defined. Let LamHSS := InitialObject LamHSS_Initial. (** extract constructors *) Definition Lam_Var : EndC ⟦functor_identity C, `Lam ⟧. Proof. exact (BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam). Defined. (* we later prefer leaving App and Abs bundled in the definition of LamE_algebra_on_Lam *) Definition Lam_App : [C, C] ⟦ (App_H C CP) `Lam , `Lam ⟧. Proof. exact (BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam)). Defined. Definition Lam_Abs : [C, C] ⟦ (Abs_H C terminal CC) `Lam, `Lam ⟧. Proof. exact (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam)). Defined. Definition Lam_App_Abs : [C, C] ⟦ (H C C C CC (App_H C CP) (Abs_H C terminal CC)) `Lam , `Lam ⟧. Proof. exact (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam). Defined. (** * Definition of a "model" of the flattening arity in pure lambda calculus *) (** we need a flattening in order to get a model for LamE *) Definition Lam_Flatten : [C, C] ⟦ (Flat_H C) `Lam , `Lam ⟧. Proof. exact (prejoin_from_hetsubst (hetsubst_from_hss _ _ _ LamHSS)). Defined. (** now get a LamE-algebra *) Definition LamE_algebra_on_Lam : FunctorAlg (Id_H _ CC LamE_S). Proof. exists ((*ob_from_algebra_ob _ _*) `Lam). use (BinCoproductArrow (CPEndC _ _ )). + exact Lam_Var. + use (BinCoproductArrow (CPEndC _ _ )). * apply Lam_App_Abs. (* do NOT destruct and reassemble more, use App_Abs directly *) * apply Lam_Flatten. Defined. Lemma τ_LamE_algebra_on_Lam : τ LamE_algebra_on_Lam = BinCoproductArrow (CPEndC _ _ ) Lam_App_Abs Lam_Flatten. Proof. apply BinCoproductIn2Commutes. Defined. (** now define bracket operation for a given [Z] and [f] *) (** preparations for typedness *) Local Definition helper_to: (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam) --> (ptd_from_alg_functor CC _ Lam). Proof. use tpair. + apply (nat_trans_id _ ). + abstract (intro c; rewrite id_right ; apply BinCoproductIn1Commutes_left_dir; apply idpath). Defined. Local Definition helper_from: (ptd_from_alg_functor CC _ Lam) --> (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam). Proof. use tpair. + apply (nat_trans_id _ ). + abstract (intro c; rewrite id_right ; apply BinCoproductIn1Commutes_right_dir; apply idpath) . Defined. (** this iso does nothing, but is needed to make the argument to [fbracket] below well-typed *) (* maybe a better definition somewhere above could make this iso superfluous *) (* maybe don't need iso, but only morphism *) Local Definition bracket_property_for_LamE_algebra_on_Lam_helper : iso (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam) (ptd_from_alg_functor CC _ Lam). Proof. unfold iso. exists helper_to. apply is_iso_from_is_z_iso. exists helper_from. abstract ( split; [ apply (invmap (eq_ptd_mor _ _)); apply nat_trans_eq; [apply homset_property |] ; intro c ; apply id_left | apply eq_ptd_mor_cat; (* idem *) apply (invmap (eq_ptd_mor _ _)) ; apply nat_trans_eq; [apply homset_property |]; intro c ; apply id_left ] ). Defined. Definition fbracket_for_LamE_algebra_on_Lam (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam ⟧ ) : [C, C]⟦ functor_composite (U Z) `LamE_algebra_on_Lam, `LamE_algebra_on_Lam ⟧ . Proof. exact (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)). Defined. (** Main lemma: our "model" for the flatten arity in pure lambda calculus is compatible with substitution *) Lemma bracket_property_for_LamE_algebra_on_Lam (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f (fbracket_for_LamE_algebra_on_Lam Z f). Proof. (* Could we have this in a more declarative style? *) assert (Hyp := pr2 (pr1 (pr2 LamHSS _ (f · bracket_property_for_LamE_algebra_on_Lam_helper)))). apply parts_from_whole in Hyp. apply whole_from_parts. split. - (* the "easy" eta part *) apply pr1 in Hyp. apply (maponpaths (λ x, x · #U (inv_from_iso bracket_property_for_LamE_algebra_on_Lam_helper))) in Hyp. rewrite <- functor_comp in Hyp. rewrite <- assoc in Hyp. rewrite iso_inv_after_iso in Hyp. rewrite id_right in Hyp. etrans; [ exact Hyp |]. clear Hyp. fold (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)). unfold fbracket_for_LamE_algebra_on_Lam. match goal with |[ |- _· _ · ?h = _ ] => assert (idness : h = nat_trans_id _) end. { apply nat_trans_eq_alt. intro c. unfold functor_ptd_forget. apply id_left. } rewrite idness. clear idness. rewrite id_right. (* does not work: apply cancel_postcomposition. although the terms are of identical type: match goal with | [ |- _ · ?l = _ ] => let ty:= (type of l) in idtac ty end. (* ([C, C] hs ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS) :[C, C] hs, LamHSS ⟧) *) match goal with | [ |- _ = _ · ?l ] => let ty:= (type of l) in idtac ty end. (* ([C, C] hs ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS) :[C, C] hs, LamHSS ⟧) *) *) apply nat_trans_eq_alt. intro c. apply cancel_postcomposition. apply BinCoproductIn1Commutes_right_dir. apply idpath. (* this proof did not work with pointedness but with brute force *) - (* now the difficult case of the domain-specific constructors *) destruct Hyp as [_ Hyp2]. fold (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)) in Hyp2. unfold fbracket_for_LamE_algebra_on_Lam. apply nat_trans_eq_alt. intro c. (* from here slightly interesting, because it is crucial to see that the τ considered here is a BinCoproduct arrow *) rewrite τ_LamE_algebra_on_Lam. etrans; [ apply cancel_postcomposition ; apply BinCoproductOfArrows_comp |]. etrans; [ apply precompWithBinCoproductArrow |]. apply pathsinv0. (* showing that a diagram of coproduct arrows splits into two is slightly cumbersome, but a general theorem seems difficult to formulate instead we apply [BinCoproductArrowUnique] and then use the coproduct beta laws in each branch; this gives precisely what we want *) apply BinCoproductArrowUnique. + etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } assert (T:= nat_trans_eq_pointwise Hyp2 c). clear Hyp2. apply pathsinv0. assumption. (* There should be a more general hypothesis than 'Hyp' defined above, one where one has a quantification over maps 'f', no? *) + clear Hyp2. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } unfold Lam_Flatten. (* from here on 'simpl' is feasible after some opacification, at least *) Opaque fbracket. Opaque LamHSS. set (X := f · bracket_property_for_LamE_algebra_on_Lam_helper). assert (TT := compute_fbracket C CC Lam_S LamHSS(Z:=Z)). simpl in *. assert (T3 := TT X); clear TT. unfold X; unfold X in T3; clear X. do 2 rewrite id_left. Local Notation "⦃ f ⦄" := (fbracket _ f)(at level 0). (* written '\{{' and '\}}', respectively *) set (Tη := ptd_from_alg _ ). destruct Z as [Z e]. simpl in *. set (T := Lam). (* now we want to rewrite with T3 in 3 places *) assert (T3' := nat_trans_eq_pointwise T3 c). simpl in *. match goal with |[ T3' : _ = ?f |- ?a · _ = _ ] => transitivity (a · f) end. { apply maponpaths. apply T3'. } repeat rewrite assoc. (* apply cancel_postcomposition. (* that's a bad idea, because it fucks up use of third monad law and leads to something that is generally false *) *) etrans. 2: { do 2 apply cancel_postcomposition. do 3 apply maponpaths. apply pathsinv0, T3'. } clear T3'. apply pathsinv0. assert (T3' := nat_trans_eq_pointwise T3 (pr1 T c)). simpl in T3'. rewrite id_right in T3'. etrans. { apply cancel_postcomposition. apply maponpaths. exact T3'. } clear T3'. apply pathsinv0. destruct f as [f fptdmor]. simpl in *. repeat rewrite assoc. rewrite <- (functor_comp (pr1 T)). repeat rewrite <- assoc. etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply (nat_trans_ax e). } repeat rewrite assoc. rewrite <- (functor_comp (pr1 T)). assert (X := fptdmor ((pr1 T) c)). clear T3 fptdmor. unfold functor_identity_data. simpl. apply pathsinv0. etrans. { do 2 apply cancel_postcomposition. apply maponpaths. repeat rewrite <- assoc. do 2 apply maponpaths. apply X. } clear X. assert (X := Monad_law_2_from_hss _ CC Lam_S LamHSS ((pr1 T) c)). unfold μ_0 in X. unfold μ_2 in X. change (pr1 ⦃ identity (ptd_from_alg (pr1 LamHSS)) ⦄ c) with (prejoin_from_hetsubst LamHSS c). (* does not do anything *) etrans. { do 2 apply cancel_postcomposition. apply maponpaths. apply assoc. } rewrite (functor_comp (pr1 T)). repeat rewrite <- assoc. match goal with |[ X : ?e = _ |- _ · (?a · (?b · _)) = _ ] => assert (X' : e = a · b) end. { apply cancel_postcomposition. apply maponpaths. cbn. apply pathsinv0, BinCoproductIn1Commutes. } rewrite X' in X. clear X'. etrans. { apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply X. } clear X. rewrite id_left. assert (μ_2_nat := nat_trans_ax (μ_2 C CC Lam_S LamHSS)). assert (X := μ_2_nat _ _ (f c · identity (pr1 Lam c))). unfold μ_2 in X. etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply X. } clear X. rewrite functor_comp. repeat rewrite <- assoc. apply maponpaths. assert (X := third_monad_law_from_hss _ CC Lam_S LamHSS). assert (X' := nat_trans_eq_pointwise X). clear X. simpl in X'. etrans; [ apply X' |]. clear X'. apply cancel_postcomposition. apply id_left. Qed. (** * Uniqueness of the bracket operation *) (** That is a consequence of uniqueness of that operation for a larger signature, namely for that of lambda calculus with flattening. We thus only have to extract the relevant parts, which is still a bit cumbersome. *) Lemma bracket_for_LamE_algebra_on_Lam_unique (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : ∏ t : ∑ h, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f h, t = tpair (λ h, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f h) (fbracket_for_LamE_algebra_on_Lam Z f) (bracket_property_for_LamE_algebra_on_Lam Z f). Proof. intro t. apply subtypePath. - intro; apply (isaset_nat_trans (homset_property C)). - cbn. destruct t as [t Ht]; cbn. unfold fbracket_for_LamE_algebra_on_Lam. apply (fbracket_unique LamHSS). split. + apply parts_from_whole in Ht. destruct Ht as [H1 _]. apply nat_trans_eq_alt. intro c. assert (HT := nat_trans_eq_pointwise H1 c). cbn. rewrite id_right. etrans; [ apply HT |]. cbn. repeat rewrite assoc. apply cancel_postcomposition. apply BinCoproductIn1Commutes. + apply parts_from_whole in Ht. destruct Ht as [_ H2]. apply nat_trans_eq_alt. intro c. assert (HT := nat_trans_eq_pointwise H2 c). match goal with |[H2 : ?e = ?f |- _ ] => assert (X: BinCoproductIn1 _ · e = BinCoproductIn1 _ · f) end. { apply maponpaths . assumption. } clear HT. clear H2. match goal with |[X : _ = ?f |- _ ] => transitivity f end. 2: { rewrite τ_LamE_algebra_on_Lam. etrans; [apply assoc |]. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } match goal with |[X : ?e = _ |- _ ] => transitivity e end. 2: apply X. rewrite τ_LamE_algebra_on_Lam. apply pathsinv0. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply assoc. } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } repeat rewrite <- assoc. etrans. { apply maponpaths. apply assoc. } etrans. { apply maponpaths. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans. { apply maponpaths. apply assoc'. } cbn. do 2 apply maponpaths. apply BinCoproductIn1Commutes. Qed. Definition bracket_for_LamE_algebra_on_Lam_at (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : bracket_at C CC LamE_S (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) LamE_algebra_on_Lam f. Proof. use tpair. - exists (fbracket_for_LamE_algebra_on_Lam Z f). apply (bracket_property_for_LamE_algebra_on_Lam Z f). - simpl; apply bracket_for_LamE_algebra_on_Lam_unique. Defined. Definition bracket_for_LamE_algebra_on_Lam : bracket (theta LamE_S) LamE_algebra_on_Lam. Proof. intros Z f. simpl. apply bracket_for_LamE_algebra_on_Lam_at. Defined. Definition LamE_model_on_Lam : hss CC LamE_S. Proof. exists LamE_algebra_on_Lam. exact bracket_for_LamE_algebra_on_Lam. Defined. (* assume initial algebra for signature LamE *) Variable LamE_Initial : Initial (@category_FunctorAlg [C, C] (Id_H C CC LamE_S)). Definition LamEHSS_Initial : Initial (hss_category CC LamE_S). Proof. apply InitialHSS. - apply KanExt. - apply LamE_Initial. Defined. Let LamEHSS := InitialObject LamEHSS_Initial. (** * Specification of a morphism from lambda calculus with flattening to pure lambda calculus *) Definition FLATTEN : (hss_category CC LamE_S) ⟦LamEHSS, LamE_model_on_Lam⟧ := InitialArrow _ _ . End Lambda. UniMath-20231010/UniMath/SubstitutionSystems/LamFromBindingSig.v000066400000000000000000000220041451125700300244400ustar00rootroot00000000000000(** Obtain the lambda calculus and a substitution monad on Set from the signature { [0,0], [1] }. Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Local Open Scope cat. Section Lam. (** A lot of notations and preliminary definitions *) Local Infix "::" := (@cons nat). Local Notation "[]" := (@nil nat) (at level 0, format "[]"). Local Notation "'HSET2'":= [HSET, HSET]. Local Notation "'Id'" := (functor_identity _). Local Notation "F * G" := (H HSET HSET HSET BinProductsHSET F G). (* Local Notation "F + G" := (BinSumOfSignatures.H _ _ _ _ _ _ BinCoproductsHSET F G). *) Local Notation "'_' 'o' 'option'" := (ℓ (option_functor BinCoproductsHSET TerminalHSET)) (at level 10). Local Definition BinProductsHSET2 : BinProducts HSET2. Proof. apply (BinProducts_functor_precat _ _ BinProductsHSET). Defined. Local Notation "x ⊗ y" := (BinProductObject _ (BinProductsHSET2 x y)). Let precomp_option X := (pre_composition_functor _ _ HSET (option_functor BinCoproductsHSET TerminalHSET) X). Local Notation "X + 1" := (precomp_option X) (at level 50). Local Notation "'1'" := (functor_identity HSET). (** * The lambda calculus from a binding signature *) (** The signature of the lambda calculus: { [0,0], [1] } *) Definition LamSig : BindingSig := make_BindingSig isasetbool (λ b, if b then 0 :: 0 :: [] else 1 :: [])%nat. (** The signature with strength for the lambda calculus *) Definition LamSignature : Signature HSET _ _ := BindingSigToSignatureHSET LamSig. Let Id_H := Id_H _ BinCoproductsHSET. Definition LamFunctor : functor HSET2 HSET2 := Id_H LamSignature. Lemma lambdaFunctor_Initial : Initial (FunctorAlg LamFunctor). Proof. apply (SignatureInitialAlgebraHSET (Presignature_Signature LamSignature)), is_omega_cocont_BindingSigToSignatureHSET. Defined. Definition LamMonad : Monad HSET := BindingSigToMonadHSET LamSig. Definition LC : HSET2 := alg_carrier _ (InitialObject lambdaFunctor_Initial). Let LC_mor : HSET2⟦LamFunctor LC,LC⟧ := alg_map _ (InitialObject lambdaFunctor_Initial). Let LC_alg : algebra_ob LamFunctor := InitialObject lambdaFunctor_Initial. Definition var_map : HSET2⟦1,LC⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition app_map : HSET2⟦LC ⊗ LC,LC⟧ := CoproductIn bool HSET2 (Coproducts_functor_precat _ _ _ _ _) true · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition lam_map : HSET2⟦LC + 1,LC⟧ := CoproductIn bool HSET2 (Coproducts_functor_precat _ _ _ _ _) false · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition make_lambdaAlgebra X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : algebra_ob LamFunctor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intro b; induction b. - apply fapp. - apply flam. Defined. Definition foldr_map X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : algebra_mor _ LC_alg (make_lambdaAlgebra X fvar fapp flam). Proof. apply (InitialArrow lambdaFunctor_Initial (make_lambdaAlgebra X fvar fapp flam)). Defined. Lemma foldr_var X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. apply id_left. Defined. (* Lemma foldr_var_pt X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) (A : HSET) (x : pr1 A) : *) (* pr1 (pr1 (foldr_map X fvar fapp flam)) A (pr1 var_map A x) = pr1 fvar A x. *) (* Proof. *) (* set (H := (toforallpaths _ _ _ (nat_trans_eq_pointwise (foldr_var X fvar fapp flam) A) x)). *) (* (* now rewrite foldr_var. *) *) (* (* Arguments foldr_map : simpl never. *) *) (* (* Arguments alg_carrier : simpl never. *) *) (* (* Arguments var_map : simpl never. *) *) (* cbn in *. *) (* apply H. *) (* Qed. *) Lemma foldr_app X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : app_map · foldr_map X fvar fapp flam = # (pr1 (Id * Id)) (foldr_map X fvar fapp flam) · fapp. Proof. assert (F := maponpaths (λ x, CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) true · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. etrans; [apply F|]. rewrite assoc. etrans. { eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. } rewrite assoc. etrans. { eapply @cancel_postcomposition. eapply @cancel_postcomposition. apply (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ i, pr1 (Arity_to_Signature BinProductsHSET BinCoproductsHSET TerminalHSET (BindingSigMap LamSig i)) `LC_alg))). } rewrite <- assoc. etrans; [eapply maponpaths, BinCoproductIn2Commutes|]. rewrite <- assoc. etrans; eapply maponpaths. - exact (CoproductInCommutes _ _ _ _ _ _ true). - apply idpath. Defined. Lemma foldr_lam X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : lam_map · foldr_map X fvar fapp flam = # (pr1 (_ o option)) (foldr_map X fvar fapp flam) · flam. Proof. assert (F := maponpaths (λ x, CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) false · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. etrans; [apply F|]. rewrite assoc. etrans. { eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. } rewrite assoc. etrans. { eapply @cancel_postcomposition, @cancel_postcomposition. apply (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ i, pr1 (Arity_to_Signature BinProductsHSET BinCoproductsHSET TerminalHSET (BindingSigMap LamSig i)) `LC_alg))). } rewrite <- assoc. etrans. { eapply maponpaths, BinCoproductIn2Commutes. } rewrite <- assoc. etrans; eapply maponpaths. - exact (CoproductInCommutes _ _ _ _ _ _ false). - apply idpath. Defined. Local Notation "'1'" := (TerminalHSET). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoproductsHSET a b)). Local Notation "x ⊛ y" := (BinProductObject _ (BinProductsHSET x y)) (at level 60). (** This makes cbn not unfold things too much below *) Arguments LamMonad : simpl never. Arguments BinCoproductObject : simpl never. Definition substLam (X : HSET) : HSET⟦LamMonad (1 ⊕ X) ⊛ LamMonad X, LamMonad X⟧. Proof. intro H. set (f := monadSubst LamMonad BinCoproductsHSET TerminalHSET X). set (g := λ (_ : unit), pr2 H). cbn in H, f, g. apply (f g (pr1 H)). Defined. End Lam. UniMath-20231010/UniMath/SubstitutionSystems/LamHSET.v000066400000000000000000000060671451125700300223550ustar00rootroot00000000000000(** Instantiate the hypotheses of InitialHSS with Lam for HSET. Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Chains.All. Section LamHSET. Let Lam_S : Signature HSET _ _ := Lam_Sig HSET TerminalHSET BinCoproductsHSET BinProductsHSET. Local Notation "'EndHSET'":= ([HSET, HSET]) . Local Lemma is_omega_cocont_Lam_S : is_omega_cocont Lam_S. Proof. apply is_omega_cocont_Lam. * apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. * apply ColimsHSET_of_shape. Defined. Lemma Lam_Initial_HSET : Initial (category_FunctorAlg (Id_H _ BinCoproductsHSET Lam_S)). Proof. use colimAlgInitial. - apply (Initial_functor_precat _ _ InitialHSET). - unfold Id_H, Const_plus_H. apply is_omega_cocont_BinCoproduct_of_functors. + apply is_omega_cocont_constant_functor. + apply is_omega_cocont_Lam_S. - apply ColimsFunctorCategory_of_shape; apply ColimsHSET_of_shape. Defined. (* Lemma KanExt_HSET : ∏ Z : precategory_Ptd HSET has_homsets_HSET, *) (* RightKanExtension.GlobalRightKanExtensionExists HSET HSET *) (* (U Z) HSET has_homsets_HSET has_homsets_HSET. *) (* Proof. *) (* intro Z. *) (* apply RightKanExtension_from_limits, LimsHSET. *) (* Defined. *) Definition LamHSS_Initial_HSET : Initial (hss_category BinCoproductsHSET Lam_S). Proof. apply InitialHSS. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_Lam_S. Defined. Definition LamMonad : Monad HSET. Proof. use Monad_from_hss. - apply BinCoproductsHSET. - apply Lam_S. - apply LamHSS_Initial_HSET. Defined. End LamHSET. UniMath-20231010/UniMath/SubstitutionSystems/LamSignature.v000066400000000000000000000410411451125700300235420ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of the arities of the constructors of lambda calculus - Definition of the signatures of lambda calculus and lambda calculus with explicit flattening ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Section Preparations. Variable C : category. Variable CP : BinProducts C. Variable CC : BinCoproducts C. Definition square_functor := BinProduct_of_functors C C CP (functor_identity C) (functor_identity C). End Preparations. Section Lambda. Variable C : category. (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variable terminal : Terminal C. Variable CC : BinCoproducts C. Variable CP : BinProducts C. Let one : C := @TerminalObject C terminal. (** [App_H (X) (A) := X(A) × X(A)] *) Definition App_H : functor EndC EndC. Proof. apply square_functor. apply BinProducts_functor_precat. exact CP. Defined. Lemma is_omega_cocont_App_H (hE : ∏ x, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C CP) x)) : is_omega_cocont App_H. Proof. unfold App_H, square_functor. apply is_omega_cocont_BinProduct_of_functors; try assumption. - apply (BinProducts_functor_precat _ _ CP). - apply is_omega_cocont_functor_identity. - apply is_omega_cocont_functor_identity. Defined. (** [Abs_H (X) := X o option] *) (* Definition Abs_H_ob (X: EndC): functor C C := functor_composite (option_functor _ CC terminal) X. *) (* (* works only with -type-in-type: *) (* Definition Abs_H_mor_nat_trans_data (X X': EndC)(α: X --> X'): ∏ c, Abs_H_ob X c --> Abs_H_ob X' c. *) (* Proof. *) (* intro. *) (* unfold Abs_H_ob. *) (* red. simpl. apply α. *) (* Defined. *) (* *) *) (* Definition Abs_H_mor_nat_trans_data (X X': functor C C)(α: nat_trans X X'): ∏ c, Abs_H_ob X c --> Abs_H_ob X' c. *) (* Proof. *) (* intro. *) (* apply α. *) (* Defined. *) (* Lemma is_nat_trans_Abs_H_mor_nat_trans_data (X X': EndC)(α: X --> X'): is_nat_trans _ _ (Abs_H_mor_nat_trans_data X X' α). *) (* Proof. *) (* red. *) (* intros c c' f. *) (* destruct α as [α α_nat_trans]. *) (* unfold Abs_H_mor_nat_trans_data, Abs_H_ob. *) (* simpl. *) (* apply α_nat_trans. *) (* Qed. *) (* Definition Abs_H_mor (X X': EndC)(α: X --> X'): (Abs_H_ob X: ob EndC) --> Abs_H_ob X'. *) (* Proof. *) (* exists (Abs_H_mor_nat_trans_data X X' α). *) (* exact (is_nat_trans_Abs_H_mor_nat_trans_data X X' α). *) (* Defined. *) (* Definition Abs_H_functor_data: functor_data EndC EndC. *) (* Proof. *) (* exists Abs_H_ob. *) (* exact Abs_H_mor. *) (* Defined. *) (* Lemma is_functor_Abs_H_data: is_functor Abs_H_functor_data. *) (* Proof. *) (* red. *) (* split; red. *) (* + intros X. *) (* unfold Abs_H_functor_data. *) (* simpl. *) (* apply nat_trans_eq; try assumption. *) (* intro c. *) (* unfold Abs_H_mor. *) (* simpl. *) (* apply idpath. *) (* + intros X X' X'' α β. *) (* unfold Abs_H_functor_data. *) (* simpl. *) (* apply nat_trans_eq; try assumption. *) (* intro c. *) (* unfold Abs_H_mor. *) (* simpl. *) (* apply idpath. *) (* Qed. *) Definition Abs_H : functor [C, C] [C, C] := (* tpair _ _ is_functor_Abs_H_data. *) pre_composition_functor _ _ _ (option_functor CC terminal). Lemma is_omega_cocont_Abs_H (CLC : Colims_of_shape nat_graph C) : is_omega_cocont Abs_H. Proof. unfold Abs_H. apply (is_omega_cocont_pre_composition_functor _ CLC). Defined. (** [Flat_H (X) := X o X] free in two arguments, then precomposed with diagonal *) Definition Flat_H : functor [C, C] [C, C] := functor_composite (bindelta_functor [C, C]) (functorial_composition _ _ _). (** here definition of suitable θ's together with their strength laws *) Definition App_θ_data: ∏ XZ, (θ_source App_H) XZ --> (θ_target App_H) XZ. Proof. intro XZ. apply nat_trans_id. Defined. Lemma is_nat_trans_App_θ_data: is_nat_trans _ _ App_θ_data. Proof. red. unfold App_θ_data. intros XZ XZ' αβ. (* the following only for better readability: *) (* destruct XZ as [X Z]; *) (* destruct XZ' as [X' Z']; *) (* destruct αβ as [α β]; *) (* simpl in *. *) apply nat_trans_eq_alt. intro c. simpl. rewrite id_left. rewrite id_right. unfold binproduct_nat_trans_data, BinProduct_of_functors_mor. unfold BinProductOfArrows. etrans; [ apply precompWithBinProductArrow |]. simpl. unfold binproduct_nat_trans_pr1_data. unfold binproduct_nat_trans_pr2_data. simpl. apply BinProductArrowUnique. + rewrite BinProductPr1Commutes. repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinProductPr1Commutes. } apply idpath. + rewrite BinProductPr2Commutes. repeat rewrite assoc. etrans. { apply cancel_postcomposition. apply BinProductPr2Commutes. } apply idpath. Qed. Definition App_θ: PrestrengthForSignature App_H := tpair _ _ is_nat_trans_App_θ_data. Lemma App_θ_strength1_int: θ_Strength1_int App_θ. Proof. red. intro. unfold App_θ, App_H. simpl. unfold App_θ_data. apply nat_trans_eq; [apply homset_property |]. intro c. simpl. rewrite id_left. unfold binproduct_nat_trans_data. apply pathsinv0. apply BinProductArrowUnique. + rewrite id_left. simpl. rewrite id_right. apply idpath. + rewrite id_left. simpl. rewrite id_right. apply idpath. Qed. Lemma App_θ_strength2_int: θ_Strength2_int App_θ. Proof. red. intros. unfold App_θ, App_H. simpl. unfold App_θ_data. apply nat_trans_eq; [apply homset_property |]. intro c. simpl. do 3 rewrite id_left. unfold binproduct_nat_trans_data. apply pathsinv0. apply BinProductArrowUnique. + rewrite id_left. simpl. rewrite id_right. apply idpath. + rewrite id_left. simpl. rewrite id_right. apply idpath. Qed. Definition Abs_θ_data_data: ∏ XZ c, pr1 (θ_source Abs_H XZ) c --> pr1 (θ_target Abs_H XZ) c. Proof. intros XZ c. (* destruct XZ as [X Z]. *) simpl. apply (functor_on_morphisms (functor_data_from_functor _ _ (pr1 XZ))). unfold constant_functor. (* destruct Z as [Z e]. *) simpl. apply BinCoproductArrow. + exact (BinCoproductIn1 _ · nat_trans_data_from_nat_trans (pr2 (pr2 XZ)) (BinCoproductObject (CC (TerminalObject terminal) c))). + exact (# (pr1 (pr2 XZ)) (BinCoproductIn2 (CC (TerminalObject terminal) c))). Defined. Lemma is_nat_trans_Abs_θ_data_data (XZ: [C, C] ⊠ category_Ptd C): is_nat_trans _ _ (Abs_θ_data_data XZ). Proof. intros c c' f. unfold Abs_θ_data_data. simpl. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. etrans. { apply precompWithBinCoproductArrow. } etrans; [| apply (!(postcompWithBinCoproductArrow _ _ _ _ _)) ]. simpl. rewrite id_left. rewrite <- assoc. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths_12. + assert (NN := nat_trans_ax (pr2 (pr2 XZ)) _ _ (BinCoproductOfArrows C (CC (TerminalObject terminal) c) (CC (TerminalObject terminal) c') (identity (TerminalObject terminal)) f)). match goal with |[ H1: _ = ?f·?g |- _ = ?h · _ ] => intermediate_path (h·(f·g)) end. * rewrite <- NN. clear NN. unfold functor_identity. simpl. rewrite assoc. rewrite BinCoproductOfArrowsIn1. rewrite id_left. apply idpath. * apply idpath. + apply maponpaths. etrans; [| apply (!(BinCoproductOfArrowsIn2 _ _ _ _ _ )) ]. apply idpath. (* intros [X [Z e]]. red. intros c c' f. simpl. rewrite <- functor_comp. rewrite <- functor_comp. apply maponpaths. unfold coproduct_functor_mor. eapply pathscomp0. apply precompWithBinCoproductArrow. eapply pathscomp0. Focus 2. apply (!(postcompWithBinCoproductArrow _ _ _ _ _)). simpl. rewrite id_left. rewrite <- assoc. rewrite <- functor_comp. rewrite <- functor_comp. simpl. apply maponpaths_12. + assert (NN := nat_trans_ax e _ _ (BinCoproductOfArrows C (CC (TerminalObject terminal) c) (CC (TerminalObject terminal) c') (identity (TerminalObject terminal)) f)). match goal with |[ H1: _ = ?f·?g |- _ = ?h · _ ] => intermediate_path (h·(f·g)) end. * rewrite <- NN. clear NN. unfold functor_identity. simpl. rewrite assoc. rewrite BinCoproductOfArrowsIn1. rewrite id_left. apply idpath. * apply idpath. + apply maponpaths. eapply pathscomp0. Focus 2. apply (!(BinCoproductOfArrowsIn2 _ _ _ _ _ )). apply idpath. *) Qed. Definition Abs_θ_data (XZ: [C, C] ⊠ category_Ptd C): (θ_source Abs_H) XZ --> (θ_target Abs_H) XZ. Proof. exact (tpair _ _ (is_nat_trans_Abs_θ_data_data XZ)). Defined. Lemma is_nat_trans_Abs_θ_data: is_nat_trans _ _ Abs_θ_data. Proof. red. intros XZ XZ' αβ. destruct XZ as [X [Z e]]. destruct XZ' as [X' [Z' e']]. destruct αβ as [α β]. simpl in *. apply nat_trans_eq; [apply homset_property |]. intro c. simpl. unfold constant_functor. simpl. rewrite assoc. unfold Abs_θ_data_data. simpl. rewrite (nat_trans_ax α). etrans. 2: { apply cancel_postcomposition. apply functor_comp. } rewrite (nat_trans_ax α). rewrite <- assoc. apply maponpaths. etrans. { apply pathsinv0, functor_comp. } apply maponpaths. unfold constant_functor_data. simpl. etrans; [ apply precompWithBinCoproductArrow |]. rewrite id_left. etrans. 2: { eapply pathsinv0. apply postcompWithBinCoproductArrow. } apply BinCoproductArrowUnique. - rewrite BinCoproductIn1Commutes. rewrite <- assoc. apply maponpaths. apply pathsinv0, (ptd_mor_commutes _ β). - rewrite BinCoproductIn2Commutes. apply pathsinv0, (nat_trans_ax β). Qed. Definition Abs_θ: PrestrengthForSignature Abs_H := tpair _ _ is_nat_trans_Abs_θ_data. Lemma Abs_θ_strength1_int: θ_Strength1_int Abs_θ. Proof. intro X. unfold Abs_θ, Abs_H, Abs_θ_data. apply nat_trans_eq_alt. intro c. simpl. rewrite id_right. apply functor_id_id. apply pathsinv0. apply BinCoproductArrowUnique. + apply idpath. + apply id_right. Qed. Lemma Abs_θ_strength2_int: θ_Strength2_int Abs_θ. Proof. intros X Z Z'. unfold Abs_θ, Abs_H, Abs_θ_data. apply nat_trans_eq_alt. intro c. simpl. rewrite id_left. rewrite id_right. unfold Abs_θ_data_data. simpl. unfold horcomp_data; simpl. rewrite <- functor_comp. apply maponpaths. clear X. destruct Z as [Z e]; destruct Z' as [Z' e']; etrans. 2: { eapply pathsinv0. apply postcompWithBinCoproductArrow. } simpl. apply maponpaths_12. + rewrite <- assoc. assert (NN := nat_trans_ax e' _ _ (e (BinCoproductObject (CC (TerminalObject terminal) c)))). simpl in NN. (* is important for success of the trick *) match goal with |[ H1: _ = ?f·?g |- ?h · _ = _ ] => intermediate_path (h·(f·g)) end. * apply maponpaths, NN. * assert (NNN := nat_trans_ax e' _ _ (BinCoproductArrow (CC (TerminalObject terminal) (Z c)) (BinCoproductIn1 (CC (TerminalObject terminal) c)· e (BinCoproductObject (CC (TerminalObject terminal) c))) (# Z (BinCoproductIn2 (CC (TerminalObject terminal) c))))). simpl in NNN. match goal with |[ H1: _ = ?f·?g |- _ = ?h · _] => intermediate_path (h·(f·g)) end. - simpl. rewrite <- NNN. clear NNN. do 2 rewrite assoc. rewrite BinCoproductIn1Commutes. do 2 rewrite <- assoc. apply maponpaths, pathsinv0, NN. - apply idpath. + rewrite <- functor_comp. apply maponpaths. etrans. 2: { eapply pathsinv0. apply BinCoproductIn2Commutes. } apply idpath. Qed. Definition Flat_θ_data (XZ: [C, C] ⊠ category_Ptd C): [C, C] ⟦θ_source Flat_H XZ, θ_target Flat_H XZ⟧. Proof. (* destruct XZ as [X [Z e]]. simpl. *) set (h:= nat_trans_comp (linvunitor_CAT (pr1 XZ)) ((nat_trans_id _) ⋆ (pr2 (pr2 XZ)))). set (F1' := pr1 (pr2 (left_unit_as_nat_z_iso _ _) (pr1 XZ))). set (F2' := # (post_comp_functor (pr1 XZ)) (pr2 (pr2 XZ))). set (h' := F1' · F2'). set (obsolete := nat_trans_comp (lassociator_CAT (pr1 (pr2 XZ)) (pr1 XZ) (pr1 XZ)) (h ⋆ (nat_trans_id (functor_composite (pr1 (pr2 XZ)) (pr1 XZ))))). set (F3' := rassociator_CAT (pr12 XZ) (pr1 XZ) (pr1 XZ)). set (F4' := # (pre_comp_functor (functor_compose (pr1 (pr2 XZ)) (pr1 XZ))) h'). exact (F3' · F4'). Defined. Lemma is_nat_trans_Flat_θ_data: is_nat_trans _ _ Flat_θ_data. Proof. intros XZ XZ' αβ. apply nat_trans_eq_alt. intro c. simpl. destruct XZ as [X [Z e]]; destruct XZ' as [X' [Z' e']]; destruct αβ as [α β]; simpl in *. repeat rewrite id_left. rewrite (functor_comp Z). rewrite (functor_comp X). repeat rewrite assoc. do 4 rewrite <- functor_comp. rewrite (nat_trans_ax α). repeat rewrite <- assoc. rewrite <- functor_comp. do 2 rewrite (nat_trans_ax α). do 2 apply maponpaths. repeat rewrite assoc. etrans. 2: { do 2 apply cancel_postcomposition. apply (nat_trans_ax e). } cbn. assert (β_is_pointed := ptd_mor_commutes _ β). simpl in β_is_pointed. rewrite <- (nat_trans_ax α). repeat rewrite <- assoc. apply maponpaths. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply (nat_trans_ax e). } cbn. rewrite <- assoc. rewrite β_is_pointed. apply idpath. Qed. Definition Flat_θ: PrestrengthForSignature Flat_H := tpair _ _ is_nat_trans_Flat_θ_data. Lemma Flat_θ_strength1_int: θ_Strength1_int Flat_θ. Proof. intro. unfold Flat_θ, Flat_H. apply nat_trans_eq_alt. intro c. simpl. do 2 rewrite id_left. rewrite functor_id. rewrite id_left. rewrite id_right. apply functor_id. Qed. Lemma Flat_θ_strength2_int: θ_Strength2_int Flat_θ. Proof. intros ? ? ?. apply nat_trans_eq_alt. intro c. cbn. repeat rewrite id_left. rewrite id_right. repeat rewrite <- functor_comp. apply maponpaths. repeat rewrite functor_id. rewrite id_right. set (c' := pr1 X (pr1 Z' (pr1 Z c))). change (pr1 (ptd_pt C Z) c' · pr1 (ptd_pt C Z') (pr1 (pr1 (pr1 Z)) c') = pr1 (pr2 Z') c' · # (pr1 Z') (pr1 (pr2 Z) c')). etrans. 2: { apply (nat_trans_ax (pr2 Z')). } apply idpath. Qed. (** finally, constitute the 3 signatures *) Definition App_Sig: Signature C C C. Proof. exists App_H. exists App_θ. split. + exact App_θ_strength1_int. + exact App_θ_strength2_int. Defined. Definition Abs_Sig: Signature C C C. Proof. exists Abs_H. exists Abs_θ. split. + exact Abs_θ_strength1_int. + exact Abs_θ_strength2_int. Defined. Definition Flat_Sig: Signature C C C. Proof. exists Flat_H. exists Flat_θ. split. + exact Flat_θ_strength1_int. + exact Flat_θ_strength2_int. Defined. Definition Lam_Sig: Signature C C C := BinSum_of_Signatures C C C CC App_Sig Abs_Sig. Lemma is_omega_cocont_Lam (hE : ∏ x, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C CP) x)) (LC : Colims_of_shape nat_graph C) : is_omega_cocont (Signature_Functor Lam_Sig). Proof. apply is_omega_cocont_BinCoproduct_of_functors. - apply (is_omega_cocont_App_H hE). - apply (is_omega_cocont_Abs_H LC). Defined. Definition LamE_Sig: Signature C C C := BinSum_of_Signatures C C C CC Lam_Sig Flat_Sig. End Lambda. UniMath-20231010/UniMath/SubstitutionSystems/LiftingInitial.v000066400000000000000000000713611451125700300240650ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Construction of a substitution system from an initial algebra - Proof that the substitution system constructed from an initial algebra is an initial substitution system ************************************************************) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Coercion alg_carrier : algebra_ob >-> ob. Section category_Algebra. Context (C : category) (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Variable KanExt : ∏ Z : Ptd, GlobalRightKanExtensionExists _ _ (U Z) C. Variable H : Presignature C C C. Let θ := theta H. Definition Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. (* := sum_of_functors CPEndC (constant_functor _ _ X) H. *) Definition Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Let Alg : category := FunctorAlg Id_H. Variable IA : Initial Alg. Definition SpecializedGMIt (Z : Ptd) (X : EndC) : ∏ (G : functor [C, C] [C, C]) (ρ : [C, C] ⟦ G X, X ⟧) (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G), ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), X ⟧, # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h = θ (` (InitialObject IA)) · # G h · ρ := SpecialGenMendlerIteration _ _ IA EndC X _ (KanExt Z) . Definition θ_in_first_arg (Z: Ptd) : functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z ⟹ functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z := nat_trans_fix_snd_arg _ _ _ _ _ θ Z. Definition InitAlg : Alg := InitialObject IA. Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg. Local Lemma aux_iso_1_is_nat_trans (Z : Ptd) : is_nat_trans (functor_composite Id_H (ℓ (U Z))) (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (U Z) (functor_identity C)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. etrans; [apply BinCoproductOfArrows_comp |]. etrans. 2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. } apply maponpaths_12. - etrans; [ apply id_left |]. apply pathsinv0. apply id_right. - rewrite id_right. rewrite id_left. rewrite (functor_id (H X)). apply pathsinv0, id_left. Qed. Definition aux_iso_1 (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact (aux_iso_1_is_nat_trans Z). Defined. Local Lemma aux_iso_1_inv_is_nat_trans (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) ) (functor_composite Id_H (ℓ (U Z))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (functor_identity C) (U Z)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. etrans; [apply BinCoproductOfArrows_comp |]. etrans. 2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. } apply maponpaths_12. - rewrite id_right. apply pathsinv0. apply id_right. - rewrite (functor_id (H X)). do 2 rewrite id_left. apply id_right. Qed. Local Definition aux_iso_1_inv (Z: Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), functor_composite Id_H (ℓ (U Z)) ⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact (aux_iso_1_inv_is_nat_trans Z). Defined. (* Definition G_Thm15 (X : EndC) := coproduct_functor _ _ CPEndC (constant_functor _ _ X) H. *) Local Lemma aux_iso_2_inv_is_nat_trans (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) ) (functor_composite (ℓ (U Z)) (Const_plus_H (U Z))) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite (@id_left EndC). rewrite (@id_right EndC). apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)). + apply idpath. + unfold functor_fix_snd_arg_mor; simpl. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c. simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition aux_iso_2_inv (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z) ) (Const_plus_H (U Z)) ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (aux_iso_2_inv_is_nat_trans Z). Defined. Definition θ'_Thm15 (Z: Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ := BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_category EndC EndC)) (θ_in_first_arg Z). Definition ρ_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptdInitAlg ⟧) : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧ := @BinCoproductArrow EndC _ _ (CPEndC (U Z) (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) (#U f) (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)). Definition SpecializedGMIt_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), pr1 InitAlg ⟧, # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h = pr1 ((aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z)) (` (InitialObject IA)) · # (Const_plus_H (U Z)) h · ρ_Thm15 Z f := SpecializedGMIt Z (pr1 InitAlg) (Const_plus_H (U Z)) (ρ_Thm15 Z f) (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z). Definition bracket_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), `InitAlg ⟧ := pr1 (pr1 (SpecializedGMIt_Thm15 Z f)). Notation "⦃ f ⦄" := (bracket_Thm15 _ f) (at level 0). (* we prove the individual components for ease of compilation *) Lemma bracket_Thm15_ok_part1 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧): # U f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt. intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))). assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_ ⟹ _)) _)· m) h_eq); clear h_eq. simpl in h_eq'. assert (h_eq1' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (BinCoproductIn1 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c); clear h_eq1'. (* match goal right in the beginning in contrast with earlier approach - suggestion by Benedikt *) match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path f end. - clear h_eq1'_inst. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data ; simpl. repeat rewrite <- assoc . apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite (@id_left EndC). rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite (@id_left EndC). apply BinCoproductIn1Commutes_right_dir. apply idpath. - rewrite <- h_eq1'_inst. clear h_eq1'_inst. apply BinCoproductIn1Commutes_left_in_ctx_dir. unfold nat_trans_id; simpl. rewrite id_left. repeat rewrite (id_left EndEndC). repeat rewrite (id_left EndC). unfold functor_fix_snd_arg_ob. repeat rewrite assoc. (* apply maponpaths. *) apply idpath. Qed. Lemma bracket_Thm15_ok_part2 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧): (theta H) ((alg_carrier _ InitAlg) ⊗ Z) · # H ⦃f⦄ · τ InitAlg = # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt. intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))). assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_⟹_)) _)· m) h_eq); clear h_eq. (* simpl in h_eq'. (* until here same as in previous lemma *) *) assert (h_eq2' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (BinCoproductIn2 (CPEndC _ _))· m) h_eq'). clear h_eq'. assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c). clear h_eq2'. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path f end. - clear h_eq2'_inst. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold aux_iso_1; simpl. rewrite id_right. rewrite id_left. do 3 rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_id; simpl. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. rewrite <- assoc. apply maponpaths. eapply pathscomp0. 2: apply assoc. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. (* alternative with slightly less precise control: *) (* do 4 rewrite <- assoc. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* rewrite id_left. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* unfold nat_trans_fix_snd_arg_data. *) (* rewrite id_left. *) (* apply BinCoproductIn2Commutes_right_in_double_ctx_dir. *) (* do 2 rewrite <- assoc. *) (* apply maponpaths. *) (* apply maponpaths. *) (* apply pathsinv0. *) (* apply BinCoproductIn2Commutes. *) (* *) - rewrite <- h_eq2'_inst. clear h_eq2'_inst. apply BinCoproductIn2Commutes_left_in_ctx_dir. repeat rewrite id_left. apply assoc. Qed. Lemma bracket_Thm15_ok (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧): bracket_property_parts (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f ⦃f⦄. Proof. split. + exact (bracket_Thm15_ok_part1 Z f). + exact (bracket_Thm15_ok_part2 Z f). Qed. Lemma bracket_Thm15_ok_cor (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧): bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f (bracket_Thm15 Z f). Proof. apply whole_from_parts. apply bracket_Thm15_ok. Qed. Local Lemma foo' (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h, t = tpair (λ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h) ⦃f⦄ (bracket_Thm15_ok_cor Z f). Proof. intros [h' h'_eq]. apply subtypePath. - intro. unfold bracket_property. apply (isaset_nat_trans (homset_property C)). - simpl. apply parts_from_whole in h'_eq. (* destruct h'_eq as [h'_eq1 h'_eq2]. *) unfold bracket_Thm15. apply path_to_ctr. apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data. repeat rewrite (@id_left EndC). rewrite id_right. repeat rewrite <- @assoc. etrans. 2: { eapply pathsinv0. apply postcompWithBinCoproductArrow. } apply BinCoproductArrowUnique. + destruct h'_eq as [h'_eq1 _ ]. (*clear h'_eq2.*) simpl. rewrite id_left. assert (h'_eq1_inst := nat_trans_eq_pointwise h'_eq1 c); clear h'_eq1. simpl in h'_eq1_inst. unfold coproduct_nat_trans_in1_data in h'_eq1_inst; simpl in h'_eq1_inst. rewrite <- @assoc in h'_eq1_inst. etrans. { eapply pathsinv0; exact h'_eq1_inst. } clear h'_eq1_inst. apply BinCoproductIn1Commutes_right_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. apply BinCoproductIn1Commutes_right_dir. apply idpath. + destruct h'_eq as [_ h'_eq2]. (*clear h'_eq2.*) assert (h'_eq2_inst := nat_trans_eq_pointwise h'_eq2 c); clear h'_eq2. simpl in h'_eq2_inst. unfold coproduct_nat_trans_in2_data in h'_eq2_inst; simpl in h'_eq2_inst. apply pathsinv0 in h'_eq2_inst. rewrite <- assoc in h'_eq2_inst. etrans; [ exact h'_eq2_inst |]. clear h'_eq2_inst. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. unfold nat_trans_fix_snd_arg_data; simpl. do 2 rewrite <- assoc. apply maponpaths. rewrite <- assoc. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. Qed. Definition bracket_for_InitAlg : bracket θ InitAlg. Proof. intros Z f. use tpair. - use tpair. + exact (bracket_Thm15 Z f). + exact (bracket_Thm15_ok_cor Z f). (* B: better to prove the whole outside, and apply it here *) (* when the first components were not opaque, the following proof became extremely slow *) - simpl; apply foo'. Defined. Definition InitHSS : hss_category CP H. Proof. (* red. (* FORBIDDEN, otherwise universe problem when checking the definition *) unfold hss_precategory; simpl. *) exists (InitAlg). exact bracket_for_InitAlg. Defined. Local Definition Ghat : EndEndC := Const_plus_H (pr1 InitAlg). Definition constant_nat_trans (C' D : category) (d d' : D) (m : d --> d') : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧. Proof. exists (λ _, m). abstract ( intros ? ? ? ; intermediate_path m ; [ apply id_left | apply pathsinv0 ; apply id_right] ). Defined. Definition thetahat_0 (Z : Ptd) (f : Z --> ptdInitAlg): EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ . Proof. exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (constant_nat_trans _ _ _ _ (#U f)) (θ_in_first_arg Z)). Defined. Local Definition iso1' (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)) ⟧. Proof. exact (aux_iso_1 Z). Defined. Local Lemma is_nat_trans_iso2' (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)))) (functor_composite (ℓ (U Z)) Ghat) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X) ((θ_target H) (X ⊗ Z))) : functor C C)). Proof. intros X X' α. rewrite (@id_left EndC). rewrite (@id_right EndC). apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)). - apply idpath. - unfold functor_fix_snd_arg_mor; simpl. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c. simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition iso2' (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z)) Ghat ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (is_nat_trans_iso2' Z). Defined. Definition thetahat (Z : Ptd) (f : Z --> ptdInitAlg) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), functor_composite (ℓ (U Z)) (Ghat) ⟧. Proof. exact (iso1' Z · thetahat_0 Z f · iso2' Z). Defined. Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X. Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) : functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg)) ⟹ functor_composite (functor_opp (ℓ (U Z))) (Yon X) . Proof. use tpair. - intro Y. intro a. exact (a · b). - abstract ( intros ? ? ?; simpl; apply funextsec; intro; unfold yoneda_objects_ob; simpl; unfold compose; simpl; apply nat_trans_eq; [ apply homset_property |]; simpl; intro; apply assoc'). Defined. Lemma ishssMor_InitAlg (T' : hss CP H) : @ishssMor C CP H InitHSS T' (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. set (β0 := InitialArrow IA (pr1 T')). match goal with | [|- _ · ?b = _ ] => set (β := b) end. set ( rhohat := BinCoproductArrow (CPEndC _ _ ) β (tau_from_alg T') : pr1 Ghat T' --> T'). set (X:= SpecializedGMIt Z _ Ghat rhohat (thetahat Z f)). intermediate_path (pr1 (pr1 X)). - set (TT:= fusion_law _ _ IA _ (pr1 InitAlg) T' _ (KanExt Z)). set (Psi := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Const_plus_H (U Z)) (ρ_Thm15 Z f) (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z) ). set (T2 := TT Psi). set (T3 := T2 (ℓ (U Z)) (KanExt Z)). set (Psi' := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Ghat) (rhohat) (iso1' Z · thetahat_0 Z f · iso2' Z) ). set (T4 := T3 Psi'). set (Φ := (Phi_fusion Z T' β)). set (T5 := T4 Φ). intermediate_path (Φ _ (fbracket InitHSS f)). + apply idpath. + eapply pathscomp0. 2: { apply T5. (* hypothesis of fusion law *) apply funextsec. intro t. simpl. unfold compose. simpl. apply nat_trans_eq_alt. simpl. intro c. rewrite id_right. rewrite id_right. (* should be decomposed into two diagrams *) apply BinCoproductArrow_eq_cor. * (* first diagram *) clear TT T2 T3 T4 T5. do 5 rewrite <- assoc. apply BinCoproductIn1Commutes_left_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. * (* second diagram *) clear TT T2 T3 T4 T5. do 5 rewrite <- assoc. apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite (@id_left EndC). apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold nat_trans_fix_snd_arg_data. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. assert (H_nat_inst := functor_comp H t β). assert (H_nat_inst_c := nat_trans_eq_pointwise H_nat_inst c); clear H_nat_inst. { match goal with |[ H1 : _ = ?f |- _ = _· ?g · ?h ] => intermediate_path (f·g·h) end. + clear H_nat_inst_c. simpl. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_left_in_ctx_dir. simpl. unfold coproduct_nat_trans_in2_data, coproduct_nat_trans_data. assert (Hyp := τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))). assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. simpl in Hyp_c. etrans; [ eapply pathsinv0; exact Hyp_c |]. clear Hyp_c. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. + rewrite <- H_nat_inst_c. apply idpath. } } apply cancel_postcomposition. apply idpath. - apply pathsinv0. apply path_to_ctr. (* now a lot of serious verification work to be done *) apply nat_trans_eq_alt. intro c. simpl. rewrite id_right. (* look at type: *) (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply BinCoproductArrow_eq_cor. + repeat rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. assert (ptd_mor_commutes_inst := ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)). apply ptd_mor_commutes_inst. } assert (fbracket_η_inst := fbracket_η T' (f· ptd_from_alg_mor _ CP H β0)). assert (fbracket_η_inst_c := nat_trans_eq_pointwise fbracket_η_inst c); clear fbracket_η_inst. apply (!fbracket_η_inst_c). + (* now the difficult case *) repeat rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. eapply pathsinv0. assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0). assert (τ_part_of_alg_mor_inst_Zc := nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c)); clear τ_part_of_alg_mor_inst. apply τ_part_of_alg_mor_inst_Zc. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. { apply maponpaths. rewrite assoc. eapply pathsinv0. assert (fbracket_τ_inst := fbracket_τ T' (f · ptd_from_alg_mor _ CP H β0)). assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst. apply fbracket_τ_inst_c. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. assert (Hyp: ((# (pr1 (ℓ(U Z))) (# H β))· (theta H) ((alg_carrier _ T') ⊗ Z)· # H (fbracket T' (f · ptd_from_alg_mor C CP H β0)) = θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) · # H (# (pr1 (ℓ(U Z))) β · fbracket T' (f · ptd_from_alg_mor C CP H β0)))). 2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. exact Hyp_c. } clear c. clear X. clear rhohat. rewrite (functor_comp H). rewrite assoc. apply cancel_postcomposition. fold θ. apply nat_trans_eq_alt. intro c. assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c). etrans ; [exact θ_nat_1_pointwise_inst | ]. clear θ_nat_1_pointwise_inst. simpl. apply maponpaths. rewrite horcomp_id_prewhisker. apply idpath. Qed. Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'. Proof. intro T'. exists (InitialArrow IA (pr1 T')). apply ishssMor_InitAlg. Defined. Lemma hss_InitMor_unique (T' : hss_category CP H): ∏ t : hss_precategory CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'. Proof. intro t. apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)). apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)). Qed. Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS. Proof. use make_isInitial. intro T. exists (hss_InitMor T). apply hss_InitMor_unique. Defined. Lemma InitialHSS : Initial (hss_category CP H). Proof. use (make_Initial InitHSS). apply isInitial_InitHSS. Defined. End category_Algebra. UniMath-20231010/UniMath/SubstitutionSystems/LiftingInitial_alt.v000066400000000000000000000620671451125700300247300ustar00rootroot00000000000000(** ********************************************************** Contents: - Construction of a substitution system from an initial algebra - Proof that the substitution system constructed from an initial algebra is an initial substitution system This file differs from LiftingInitial.v in the hypotheses. Here we use omega cocontinuity instead of Kan extensions. Written by: Anders Mörtberg, 2016 (adapted from LiftingInitial.v) ************************************************************) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Coercion alg_carrier : algebra_ob >-> ob. Section category_Algebra. Variables (C : category) (CP : BinCoproducts C). Variables (IC : Initial C) (CC : Colims_of_shape nat_graph C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply ColimsFunctorCategory_of_shape, CC. Defined. Section fix_an_H. Context (H : functor [C, C] [C, C]) (HH : is_omega_cocont H). Definition Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. Definition Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Let Alg : precategory := FunctorAlg Id_H. Lemma is_omega_cocont_Id_H : is_omega_cocont Id_H. Proof. apply is_omega_cocont_BinCoproduct_of_functors; try apply functor_category_has_homsets. - apply is_omega_cocont_constant_functor. - apply HH. Defined. Definition InitAlg : Alg := InitialObject (colimAlgInitial InitialEndC is_omega_cocont_Id_H (Colims_of_shape_nat_graph_EndC _)). Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg. Section fix_a_Z. Context (Z : Ptd). Lemma isInitial_pre_comp : isInitial [C, C] (ℓ (U Z) InitialEndC). Proof. use make_isInitial; intros F. use tpair. - use tpair. + intros c; simpl; apply InitialArrow. + abstract (intros x y f; cbn; apply InitialArrowEq). - abstract (intros G; apply subtypePath; [ intros x; apply isaprop_is_nat_trans, homset_property | apply funextsec; intro c; apply InitialArrowUnique]). Defined. Local Lemma HU : is_omega_cocont (pre_composition_functor C C C (U Z)). Proof. apply is_omega_cocont_pre_composition_functor, CC. Defined. Definition SpecializedGMIt (X : EndC) : ∏ (G : functor [C, C] [C, C]) (ρ : [C, C] ⟦ G X, X ⟧) (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G), ∃! h : [C, C] ⟦ ℓ (U Z) (alg_carrier _ InitAlg), X ⟧, # (ℓ (U Z)) (alg_map Id_H InitAlg) · h = θ (alg_carrier _ InitAlg) · # G h · ρ := SpecialGenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC Id_H is_omega_cocont_Id_H X (ℓ (U Z)) isInitial_pre_comp HU. Context (prestrength_in_first_arg : PrestrengthForSignatureAtPoint _ _ _ H Z). Local Lemma aux_iso_1_is_nat_trans : is_nat_trans (functor_composite Id_H (ℓ (U Z))) (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (U Z) (functor_identity C)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt; intro c; simpl. etrans; [ apply BinCoproductOfArrows_comp |]. etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl. repeat rewrite id_right. rewrite (functor_id (H X)). do 2 rewrite id_left. apply idpath. Qed. Definition aux_iso_1 : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact aux_iso_1_is_nat_trans. Defined. Local Lemma aux_iso_1_inv_is_nat_trans : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) ) (functor_composite Id_H (ℓ (U Z))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (functor_identity C) (U Z)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt; intro c; simpl. etrans; [ apply BinCoproductOfArrows_comp |]. etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl. repeat rewrite id_right. rewrite (functor_id (H X)). repeat rewrite id_left. apply idpath. Qed. Local Definition aux_iso_1_inv : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), functor_composite Id_H (ℓ (U Z)) ⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact aux_iso_1_inv_is_nat_trans. Defined. Local Lemma aux_iso_2_inv_is_nat_trans : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) ) (functor_composite (ℓ (U Z)) (Const_plus_H (U Z))) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite id_left, id_right. apply nat_trans_eq_alt; intro c; simpl. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath. unfold functor_fix_snd_arg_mor; simpl. revert c; apply nat_trans_eq_pointwise, maponpaths. apply nat_trans_eq_alt; intro c; simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition aux_iso_2_inv : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z) ) (Const_plus_H (U Z)) ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact aux_iso_2_inv_is_nat_trans. Defined. Definition θ'_Thm15 : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ := BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_category EndC EndC)) prestrength_in_first_arg. Definition ρ_Thm15 (f : Ptd ⟦ Z, ptdInitAlg ⟧) : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧ := @BinCoproductArrow EndC _ _ (CPEndC (U Z) (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) (#U f) (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)). Definition SpecializedGMIt_Thm15 (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : ∃! h : [C, C] ⟦ ℓ (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, # (ℓ (U Z)) (alg_map Id_H InitAlg) · h = pr1 (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv) (pr1 InitAlg) · # (Const_plus_H (U Z)) h · ρ_Thm15 f := (SpecializedGMIt (pr1 InitAlg) (Const_plus_H (U Z)) (ρ_Thm15 f) (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv)). Definition bracket_Thm15 (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : [C, C]⟦ ℓ (U Z) (pr1 InitAlg), pr1 InitAlg ⟧ := pr1 (pr1 (SpecializedGMIt_Thm15 f)). Notation "⦃ f ⦄" := (bracket_Thm15 f) (at level 0). (* we prove the individual components for ease of compilation *) Lemma bracket_Thm15_ok_part1 (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : # U f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt; intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))). assert (h_eq' := maponpaths (λ m, ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq. assert (h_eq1' := maponpaths (λ m, (BinCoproductIn1 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c); clear h_eq1'. eapply pathscomp0, pathscomp0; [|apply (!h_eq1'_inst)|]; clear h_eq1'_inst. - apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl. rewrite id_left, <- !assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl. rewrite !id_left, !(@id_left EndC). now apply BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_dir. - apply BinCoproductIn1Commutes_left_in_ctx_dir; simpl. now rewrite id_left, assoc. Qed. Lemma bracket_Thm15_ok_part2 (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : prestrength_in_first_arg (alg_carrier _ InitAlg) · # H ⦃f⦄ · τ InitAlg = # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt; intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))). assert (h_eq' := maponpaths (λ m, ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq. (* until here same as in previous lemma *) assert (h_eq2' := maponpaths (λ m, (BinCoproductIn2 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c); clear h_eq2'. eapply pathscomp0, pathscomp0; [|apply (!h_eq2'_inst)|]; clear h_eq2'_inst. - apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl. rewrite id_right, id_left, <- !assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. rewrite <- assoc; apply maponpaths. apply pathsinv0; simpl. rewrite <- assoc; apply maponpaths. now apply BinCoproductIn2Commutes. - apply BinCoproductIn2Commutes_left_in_ctx_dir. now rewrite id_left; apply assoc. Qed. Lemma bracket_Thm15_ok (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : bracket_property_parts prestrength_in_first_arg InitAlg f ⦃f⦄. Proof. split. + exact (bracket_Thm15_ok_part1 f). + exact (bracket_Thm15_ok_part2 f). Qed. Lemma bracket_Thm15_ok_cor (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : bracket_property prestrength_in_first_arg InitAlg f (bracket_Thm15 f). Proof. now apply whole_from_parts, bracket_Thm15_ok. Qed. Local Lemma bracket_unique (f : Ptd ⟦ Z, ptd_from_alg InitAlg ⟧) : ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property prestrength_in_first_arg InitAlg f h, t = tpair _ ⦃f⦄ (bracket_Thm15_ok_cor f). Proof. intros [h' h'_eq]; apply subtypePath; [intro; apply (isaset_nat_trans (homset_property C))|]. simpl; apply parts_from_whole in h'_eq. apply path_to_ctr, nat_trans_eq_alt; intro c. simpl; rewrite !(@id_left EndC), id_right, <- !assoc. etrans; [| eapply pathsinv0, postcompWithBinCoproductArrow ]. apply BinCoproductArrowUnique. + destruct h'_eq as [h'_eq1 _]; simpl. rewrite id_left, assoc. etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq1 c) |]. now apply BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_dir. + destruct h'_eq as [_ h'_eq2]. rewrite assoc. etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq2 c) |]. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. simpl; rewrite <- !assoc. now apply maponpaths, maponpaths, pathsinv0, BinCoproductIn2Commutes. Qed. End fix_a_Z. End fix_an_H. Context (H : @Presignature C C C) (HH : is_omega_cocont H). Let Id_H := Id_H H. Let θ := theta H. Let InitAlg := InitAlg H HH. Let ptdInitAlg := ptdInitAlg H HH. Definition bracket_for_InitAlg : bracket θ InitAlg. Proof. intros Z f. use tpair. - use tpair. + exact (bracket_Thm15 H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f). + exact (bracket_Thm15_ok_cor H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f). (* B: better to prove the whole outside, and apply it here *) (* when the first components were not opaque, the following proof became extremely slow *) - cbn. apply bracket_unique. Defined. Definition InitHSS : hss_category CP H. Proof. (* red. (* FORBIDDEN, otherwise universe problem when checking the definition *) unfold hss_precategory; simpl. *) exists InitAlg. exact bracket_for_InitAlg. Defined. Local Definition Ghat : EndEndC := Const_plus_H H (pr1 InitAlg). Definition constant_nat_trans (C' D : category) (d d' : D) (m : D⟦d,d'⟧) : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧. Proof. exists (λ _, m). abstract (intros ? ? ?; intermediate_path m; [ apply id_left | apply pathsinv0, id_right]). Defined. Definition thetahat_0 (Z : Ptd) (f : Z --> ptdInitAlg) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧. Proof. exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (constant_nat_trans _ _ _ _ (#U f)) (nat_trans_fix_snd_arg _ _ _ _ _ θ Z)). Defined. Local Definition iso1' (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor _ _ (U Z)) (functor_fix_snd_arg _ _ _ (θ_source H) Z)) ⟧. Proof. exact (aux_iso_1 H Z). Defined. Local Lemma is_nat_trans_iso2' (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)))) (functor_composite (ℓ (U Z)) Ghat) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite id_left, id_right. apply nat_trans_eq_alt; intro c; simpl. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath. unfold functor_fix_snd_arg_mor; simpl. revert c; apply nat_trans_eq_pointwise, maponpaths. apply nat_trans_eq_alt; intro c; simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition iso2' (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z)) Ghat ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (is_nat_trans_iso2' Z). Defined. Definition thetahat (Z : Ptd) (f : Z --> ptdInitAlg) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), functor_composite (ℓ (U Z)) (Ghat) ⟧. Proof. exact (iso1' Z · thetahat_0 Z f · iso2' Z). Defined. Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X. Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) : functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg)) ⟹ functor_composite (functor_opp (ℓ (U Z))) (Yon X) . Proof. use tpair. - intros Y a. exact (a · b). - abstract (intros ? ? ?; simpl; apply funextsec; intro; unfold yoneda_objects_ob; simpl; unfold compose; simpl; apply nat_trans_eq; [apply homset_property |]; simpl; intro; apply assoc'). Defined. Let IA := colimAlgInitial InitialEndC (is_omega_cocont_Id_H H HH) (Colims_of_shape_nat_graph_EndC _). Lemma ishssMor_InitAlg (T' : hss CP H) : @ishssMor C CP H InitHSS T' (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ). Proof. intros Z f. set (β0 := InitialArrow IA (pr1 T')). match goal with | [|- _ · ?b = _ ] => set (β := b) end. set (rhohat := BinCoproductArrow (CPEndC _ _ ) β (tau_from_alg T') : pr1 Ghat T' --> T'). set (X:= SpecializedGMIt H HH Z _ Ghat rhohat (thetahat Z f)). intermediate_path (pr1 (pr1 X)). - set (TT := @fusion_law EndC InitialEndC Colims_of_shape_nat_graph_EndC Id_H (is_omega_cocont_Id_H H HH) _ (pr1 (InitAlg)) T'). set (Psi := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Const_plus_H H (U Z)) (ρ_Thm15 H HH Z f) (aux_iso_1 H Z · θ'_Thm15 H Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) · aux_iso_2_inv H Z) ). set (T2 := TT _ (HU Z) (isInitial_pre_comp Z) Psi). set (T3 := T2 (ℓ (U Z)) (HU Z)). set (Psi' := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Ghat) (rhohat) (iso1' Z · thetahat_0 Z f · iso2' Z) ). set (T4 := T3 (isInitial_pre_comp Z) Psi'). set (Φ := (Phi_fusion Z T' β)). set (T5 := T4 Φ). intermediate_path (Φ _ (fbracket InitHSS f)); try apply idpath. etrans; [| apply T5 ]; clear TT T2 T3 T4 T5 X. * now apply cancel_postcomposition. * (* hypothesis of fusion law *) apply funextsec; intro t. apply nat_trans_eq_alt; intro c; simpl. rewrite !id_right. (* should be decomposed into two diagrams *) apply BinCoproductArrow_eq_cor. + (* first diagram *) rewrite <- !assoc. apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. rewrite <- assoc. apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. now apply BinCoproductIn1Commutes_right_dir. + (* second diagram *) rewrite <- !assoc. apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl; rewrite <- !assoc. apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- !assoc. etrans; [| eapply pathsinv0, cancel_postcomposition, (nat_trans_eq_pointwise (functor_comp H t β) c) ]. simpl; rewrite <- assoc. apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir. assert (Hyp_c := nat_trans_eq_pointwise (τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))) c). simpl in Hyp_c. etrans; [ eapply pathsinv0, Hyp_c |]. now apply maponpaths, pathsinv0, BinCoproductIn2Commutes. - apply pathsinv0, path_to_ctr. (* now a lot of serious verification work to be done *) apply nat_trans_eq_alt; intro c. simpl; rewrite id_right. (* look at type: *) (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply BinCoproductArrow_eq_cor. + rewrite <- !assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite <- assoc. etrans; [| apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir; simpl; rewrite id_left; apply BinCoproductIn1Commutes_right_dir, idpath ]. rewrite !assoc. assert (fbracket_η_inst_c := nat_trans_eq_pointwise (fbracket_η T' (f · ptd_from_alg_mor _ CP H β0)) c). etrans; [| apply (!fbracket_η_inst_c) ]. apply cancel_postcomposition, (ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)). + (* now the difficult case *) repeat rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. eapply pathsinv0. assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0). assert (τ_part_of_alg_mor_inst_Zc := nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c)); clear τ_part_of_alg_mor_inst. apply τ_part_of_alg_mor_inst_Zc. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. { apply maponpaths. rewrite assoc. eapply pathsinv0. assert (fbracket_τ_inst := fbracket_τ T' (f · ptd_from_alg_mor _ CP H β0)). assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst. apply fbracket_τ_inst_c. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. assert (Hyp: ((# (pr1 (ℓ(U Z))) (# H β))· θ ((alg_carrier _ T') ⊗ Z)· # H (fbracket T' (f · ptd_from_alg_mor C CP H β0)) = θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) · # H (# (pr1 (ℓ(U Z))) β · fbracket T' (f · ptd_from_alg_mor C CP H β0)))). 2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. exact Hyp_c. } clear c. clear X. clear rhohat. rewrite (functor_comp H). rewrite assoc. apply cancel_postcomposition. apply nat_trans_eq_alt; intro c. assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c). etrans; [ exact θ_nat_1_pointwise_inst |]. clear θ_nat_1_pointwise_inst. simpl. apply maponpaths. rewrite horcomp_id_prewhisker. apply idpath. Qed. Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'. Proof. intro T'. exists (InitialArrow IA (pr1 T')). apply ishssMor_InitAlg. Defined. Lemma hss_InitMor_unique (T' : hss_category CP H): ∏ t : hss_category CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'. Proof. intro t. apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)). apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)). Qed. Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS. Proof. use make_isInitial; intro T. exists (hss_InitMor T). apply hss_InitMor_unique. Defined. Lemma InitialHSS : Initial (hss_category CP H). Proof. apply (make_Initial InitHSS), isInitial_InitHSS. Defined. End category_Algebra. UniMath-20231010/UniMath/SubstitutionSystems/MLTT79.v000066400000000000000000000152631451125700300221160ustar00rootroot00000000000000(** This file constructs a substitution monad on Set from a binding signature for the syntax of Martin-Löf type theory a la "Constructive Mathematics and Computer Programming" (1979). Written by: Anders Mörtberg, 2016 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Local Infix "::" := (@cons nat). Local Notation "[]" := (@nil nat) (at level 0, format "[]"). Local Notation "'HSET2'":= [HSET, HSET]. Section preamble. Definition four_rec {A : UU} (a b c d : A) : stn 4 -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction (nopathsfalsetotrue p). Defined. End preamble. Infix "++" := SumBindingSig. Section MLTT79. (** This is the syntax as presented on page 158: << Pi types (∏x:A)B [0,1] lambda (λx)b [1] application (c)a [0,0] Sigma types (∑x:A)B [0,1] pair (a,b) [0,0] pair-elim (Ex,y)(c,d) [0,2] Sum types A + B [0,0] inl i(a) [0] inr j(b) [0] sum-elim (Dx,y)(c,d,e) [0,1,1] Id types I(A,a,b) [0,0,0] refl r [] J J(c,d) [0,0] Fin types N_i [] Fin elems 0_i ... (i-1)_i [] ... [] (i times) Fin-elim R_i(c,c_0,...,c_(i-1)) [0,0,...,0] (i+1 zeroes) Nat N [] zero 0 [] suc a' [0] nat-elim (Rx,y)(c,d,e) [0,0,2] W-types (Wx∈A)B [0,1] sup sup(a,b) [0,0] W-elim (Tx,y,z)(c,d) [0,3] Universes U_0,U_1,... [],[],... >> *) (** Some convenient notations *) Local Notation "[0]" := (0 :: []). Local Notation "[1]" := (1 :: []). Local Notation "[0,0]" := (0 :: 0 :: []). Local Notation "[0,1]" := (0 :: 1 :: []). Local Notation "[0,2]" := (0 :: 2 :: []). Local Notation "[0,3]" := (0 :: 3 :: []). Local Notation "[0,0,0]" := (0 :: 0 :: 0 :: []). Local Notation "[0,0,2]" := (0 :: 0 :: 2 :: []). Local Notation "[0,1,1]" := (0 :: 1 :: 1 :: []). Definition PiSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [1] [0,0]). Definition SigmaSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [0,0] [0,2]). Definition SumSig : BindingSig := make_BindingSig (isasetstn 4) (four_rec [0,0] [0] [0] [0,1,1]). Definition IdSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,0,0] [] [0,0]). (** Define the arity of the eliminators for Fin by recursion *) Definition FinSigElim (n : nat) : list nat. Proof. induction n as [|n ih]. - apply [0]. - apply (0 :: ih). Defined. (** Define the signature of the constructors for Fin *) Definition FinSigConstructors (n : nat) : stn n -> list nat := λ _, []. (* The FinSig family is defined by recursion and decomposed into the type, the constructors and the eliminator *) (* Definition FinSig (n : nat) : BindingSig (unit ⨿ (stn n ⨿ unit)). *) (* Proof. *) (* induction 1 as [_|p]. *) (* - apply []. *) (* - induction p as [p|]. *) (* + apply (FinSigConstructors _ p). *) (* + apply (FinSigElim n). *) (* Defined. *) (** Uncurried version of the FinSig family *) Definition FinSigFun : (∑ n : nat, unit ⨿ (stn n ⨿ unit)) → list nat. Proof. induction 1 as [n p]. induction p as [_|p]. - apply []. - induction p as [p|]. + apply (FinSigConstructors _ p). + apply (FinSigElim n). Defined. Lemma isasetFinSig : isaset (∑ n, unit ⨿ (stn n ⨿ unit)). Proof. apply isaset_total2. - apply isasetnat. - intros. repeat apply isasetcoprod; try apply isasetunit. apply isasetstn. Qed. Lemma isdeceqFinSig : isdeceq (∑ n, unit ⨿ (stn n ⨿ unit)). Proof. apply isdeceq_total2. - apply isdeceqnat. - intros. repeat apply isdeceqcoprod; try apply isdecequnit. apply isdeceqstn. Defined. Definition FinSig : BindingSig := make_BindingSig isasetFinSig FinSigFun. Definition NatSig : BindingSig := make_BindingSig (isasetstn 4) (four_rec [] [] [0] [0,0,2]). Definition WSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [0,0] [0,3]). Definition USig : BindingSig := make_BindingSig isasetnat (λ _, []). Let SigHSET := Signature HSET HSET HSET. (** The binding signature of MLTT79 *) Definition MLTT79Sig := PiSig ++ SigmaSig ++ SumSig ++ IdSig ++ FinSig ++ NatSig ++ WSig ++ USig. (* Check MLTT79Sig. *) Definition MLTT79Signature : SigHSET := BindingSigToSignatureHSET MLTT79Sig. Let Id_H := Id_H _ BinCoproductsHSET. Definition MLTT79Functor : functor HSET2 HSET2 := Id_H (Presignature_Signature MLTT79Signature). Definition MLTT79Monad : Monad HSET := BindingSigToMonadHSET MLTT79Sig. Lemma MLTT79Functor_Initial : Initial (FunctorAlg MLTT79Functor). Proof. apply SignatureInitialAlgebraHSET, is_omega_cocont_BindingSigToSignatureHSET. Defined. Definition MLTT79 : HSET2 := alg_carrier _ (InitialObject MLTT79Functor_Initial). Let MLTT79_mor : HSET2⟦MLTT79Functor MLTT79,MLTT79⟧ := alg_map _ (InitialObject MLTT79Functor_Initial). Let MLTT79_alg : algebra_ob MLTT79Functor := InitialObject MLTT79Functor_Initial. Definition var_map : HSET2⟦functor_identity HSET,MLTT79⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · MLTT79_mor. (* TODO: define the rest of the constructors and computation rules? *) End MLTT79. UniMath-20231010/UniMath/SubstitutionSystems/ModulesFromSignatures.v000066400000000000000000000471051451125700300254570ustar00rootroot00000000000000(** Reference : "Initial Semantics for Strengthened Signatures" (André Hirschowitz , Marco Maggesi) Let (H, θ) be a strengthened signature, M an endo-functor. If M has a structure of (left) module over a monad T, then it can be lifted to endow H(M) with a structure of module over T. Let T be the initial Id+H algebra. Then T is the initial representation in the sense of H&M. Note : A shorter proof of this statment could be formalized by using the proof of initiality in the category of heterogeneous substitution systems, provided we weaken the notion of heterogeneous substitution system so that the bracket associated to the functor is not unique. The proof of initiality in the category of "weak" heterogeneous substitution systems is the same as the one one already proved formally for the standard notion of heterogeneous substitution system. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Monads.LModules. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Presheaf. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.CategoryTheory.limits.initial. (** A monad is a pointed endofunctor *) Definition ptd_from_mon {C:category} (T:Monad C) : category_Ptd C := ((T:functor C C),, η T). (** Let (Z, e : 1 -> Z) be a pointed endofunctor. Then e is a morphism (actually the initial morphism) in the category of pointed endofunctors *) Lemma is_ptd_mor_pt {C : category} (F : ptd_obj C) : is_ptd_mor _ (F:=id_Ptd C) (ptd_pt _ F). Proof. intro c; apply id_left. Qed. Definition ptd_mor_pt {C:category} (F:ptd_obj C) : ptd_mor _ (id_Ptd C) F := (ptd_pt _ F ,, is_ptd_mor_pt F). Local Notation σ := (lm_mult _). Section SignatureLiftModule. Context {C D : category} (H : Signature C D C). (** The forgetful functor from pointed endofunctors to endofunctors *) Local Notation "'U'" := (functor_ptd_forget C). (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variables (T : Monad C) (M : LModule T C). Local Notation Mf := (M : functor _ _). Local Notation "'p' T" := (ptd_from_mon T) (at level 3). (** The pointed functor TT *) Let T2 := (ptd_compose _ (p T) (p T)) . (** The multiplication of a monad is a morphism of pointed endofunctors *) Lemma is_ptd_mor_μ : is_ptd_mor _ (F:= T2) (G:=p T) (μ T). Proof. intro c. unfold T2. unfold ptd_compose. rewrite functorial_composition_pre_post. cbn. rewrite <- assoc. etrans; [|apply id_right]. apply cancel_precomposition. apply Monad_law2. Qed. Definition ptd_mor_from_μ : ptd_mor _ T2 (p T) := (_ ,, is_ptd_mor_μ). Let strength_law1_pw M x := nat_trans_eq_pointwise (θ_Strength1_int_implies_θ_Strength1 _ (Sig_strength_law1 H ) M) x. (** A pointwise version of the second strength law with only one identity instead of two α_functor *) Lemma strength_law2_pw : ∏ (X : EndC) (Z Z' : Ptd) x, ((theta H) (X ⊗ (Z p• Z')) : nat_trans _ _) x = ((theta H) (X ⊗ Z') •• (U Z):nat_trans _ _) x · ((theta H) ((functor_compose (U Z') X) ⊗ Z):nat_trans _ _) x · (# H (identity (functor_compose (U Z ∙ U Z') X) : [C, C] ⟦ functor_compose (U Z) (U Z' ∙ X : [C, C]), functor_compose (U Z ∙ U Z') X ⟧) : nat_trans _ _) x. Proof. intros X Z Z' x. etrans; revgoals. { apply (nat_trans_eq_pointwise (θ_Strength2_int_implies_θ_Strength2 _ (Sig_strength_law2 H) X Z Z' _ (identity _) ) x). } etrans;[eapply pathsinv0;apply id_right|]. apply cancel_precomposition. apply pathsinv0. etrans. { eapply nat_trans_eq_pointwise. apply (functor_id H). } apply idpath. Qed. Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)). Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ). (** The module multiplication is given by Θ_M,T H(σ) H(M) T ------> H(MT) ------> H(M) *) Local Definition lift_lm_mult : [C,D] ⟦ T ∙ H Mf , H Mf⟧ := nat_trans_comp ((theta H) ((M : C ⟶ C),, ptd_from_mon T)) (# H (σ M)). Local Definition lift_LModule_data : LModule_data T D := tpair (fun x=> [C,D] ⟦ T ∙ x, x⟧) (H Mf) lift_lm_mult. Local Lemma lift_lm_mult_laws : LModule_laws _ lift_LModule_data. Proof. split. - intro c. etrans; [apply assoc|]. etrans. { apply cancel_postcomposition. apply ( θ_nat_2_pw Mf (id_Ptd C) (p T) (ptd_mor_pt _) c). } etrans. { apply cancel_postcomposition. rewrite horcomp_pre_post. rewrite (functor_comp H). etrans; [apply assoc|]. apply cancel_postcomposition. rewrite pre_whisker_identity; try assumption. apply strength_law1_pw. } etrans;[|apply id_right]. rewrite <- assoc. apply cancel_precomposition. etrans; [ apply functor_comp_pw|]. etrans; [|apply (nat_trans_eq_pointwise (functor_id H Mf))]. apply functor_cancel_pw. apply nat_trans_eq_alt. apply (LModule_law1). - intro c. cbn. etrans. { rewrite assoc. apply cancel_postcomposition. etrans; [ apply (θ_nat_2_pw Mf _ _ (ptd_mor_from_μ) c)|]. apply cancel_postcomposition. apply (strength_law2_pw Mf (p T) (p T)). } etrans; revgoals. { rewrite <- assoc. apply cancel_precomposition. rewrite assoc. apply cancel_postcomposition. eapply pathsinv0. apply (θ_nat_1_pw _ _ (σ M) (p T) c). } cbn. repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. etrans; revgoals. { eapply pathsinv0. apply (functor_comp_pw _ _ H). } etrans. { apply cancel_precomposition. apply (functor_comp_pw _ _ H). } etrans; [ apply (functor_comp_pw _ _ H)|]. apply functor_cancel_pw. apply nat_trans_eq_alt. intro x. cbn. unfold horcomp_data; simpl. repeat rewrite id_left. rewrite functor_id,id_right. apply LModule_law2. Qed. Local Definition lift_lmodule : LModule T D := (lift_LModule_data,, lift_lm_mult_laws). End SignatureLiftModule. Section InitialRep. (** ** Some variables and assumptions *) Variable C : category. Variable CP : BinCoproducts C. Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. (** Assume having a signature on [C] *) Variable H : Signature C C C. Let θ := theta H. Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)). Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H)). Let Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. Let Alg : category := FunctorAlg Id_H. (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Local Notation "'p' T" := (ptd_from_alg T) (at level 3). Local Notation η := @eta_from_alg. (** Let [T] be a heterogeneous substitution system. Then [τ : H T --> T] is a module morphism *) Section TauModuleMorphism. Variable T : hss CP H. Local Notation T_mon := (Monad_from_hss _ _ _ T). Local Notation T_mod := (tautological_LModule T_mon). Local Notation HT_mod := (lift_lmodule H _ T_mod). Lemma τ_lmodule_laws : LModule_Mor_laws T_mon (T:=HT_mod) (T' := T_mod) (τ T). Proof. intro a. apply pathsinv0. (* It is precisely the square diagram satisfied by μ = { id } *) exact (nat_trans_eq_pointwise (fbracket_τ T (Z:= p T)(identity _ )) a). Qed. Definition τ_lmodule_mor : LModule_Mor _ _ _ := tpair (λ x, LModule_Mor_laws _ x) _ τ_lmodule_laws. End TauModuleMorphism. (** Let (M, τ_M) be a representation in the sense of Hirschowitz & Maggesi : - M is a monad - [τ_M : HM ---> M] is a module morphism Then there exists a unique monad morphism j : T --> M that is compatible with τ_M, τ_T where T is the initial HSS. In other words, T is the initial representation in the sense of H&M *) Variables (IC : Initial C) (CC : Colims_of_shape nat_graph C) (HH : is_omega_cocont H). Let T := InitHSS _ CP IC CC H HH. Local Notation T_alg := (alg_from_hetsubst _ _ _ (hetsubst_from_hss _ _ _ T)). Local Notation T_mon := (Monad_from_hss _ _ _ T). Local Notation T_func := (T_mon : functor _ _). Local Notation T_hss := (T:hss _ _). Section fix_a_representation. Variables (M : Monad C). Local Notation M_mod := (tautological_LModule M). Local Notation HM_mod := (lift_lmodule H _ M_mod). Variable (τ_M: LModule_Mor M HM_mod M_mod). Local Definition M_alg : Alg. Proof. apply (tpair (λ x, EndC ⟦ Id_H x, x ⟧) (M:functor _ _)). apply BinCoproductArrow. - apply Monads.η. - apply τ_M. Defined. (** j : T --> M is the initial Id+H-algebra morphism *) Let j : Alg ⟦T_alg, M_alg⟧ := InitialArrow _ M_alg. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply colimits.ColimsFunctorCategory_of_shape, CC. Defined. Let is_omega_cocont_Id_H' := LiftingInitial_alt.is_omega_cocont_Id_H C CP H HH. Local Notation j_mor := ((mor_from_algebra_mor _ j):nat_trans _ _). (** Following Ralph's proof : we want to prove the square diagram for the monad morphism induced by the initial algebra morphism j : T --> M : << jj TT ------> MM | | μ_T| | μ_M | | V V T ------> M j >> The strategy is to show that both paths of the diagram satisfy the characteristic equation of the same Mendler iterator. We use Lemma 8 from "Heteregenous substitution system revisited" (Benedikt Ahrens & Ralph Matthes) with the following parameters : X := M L Z := Z·T F Z := (Id+H) Z And for any Z : EndC, h : LZ -> X ψ_Z(h) := [j, τ_M ∘ H h ∘ Θ_Z,(T,η)] *) Let L := (pre_composition_functor C C C T_func). Let X := (M:functor _ _). (* inspired by LiftingInitial_alt *) Local Lemma HL : is_omega_cocont L. Proof. apply OmegaCocontFunctors.is_omega_cocont_pre_composition_functor, CC. Defined. Let isInitial_precomp' : isInitial [C, C] (L InitialEndC) := LiftingInitial_alt.isInitial_pre_comp C IC p T_hss : isInitial [C, C] (L InitialEndC). Local Definition ψ_pw (Z:[C,C]) : Core.hset_precategory ⟦ψ_source(D:=[C,C]) X L Z, ψ_target(D:=[C,C]) Id_H X L Z⟧ . Proof. intros h. cbn. apply (BinCoproductArrow (a:= `T_hss) (b:= functor_composite `T_hss (H Z)) (CPEndC _ _) (c:=X)). - apply j. - apply ((θ (Z ⊗ (p T_hss)))·#H h· (τ_M:nat_trans _ _)). Defined. Local Lemma ψ_nt : is_nat_trans (ψ_source(D:=[C,C]) X L) (ψ_target(D:=[C,C]) Id_H X L) ψ_pw. Proof. intros x x' a. cbn in a. apply weqfunextsec. intros f. apply nat_trans_eq_alt. intro c. etrans; revgoals. { eapply pathsinv0. apply (precompWithBinCoproductArrow C (CP _ _) (CP _ _) (identity _) (((# H a):nat_trans _ _) (T_func c))). } use (maponpaths_12 (@BinCoproductArrow _ _ _ _ _)). + apply pathsinv0,id_left. + apply pathsinv0. etrans; [ apply assoc |]. apply cancel_postcomposition. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (θ_nat_1_pw _ _ a (p T_alg)). } rewrite <- assoc. apply cancel_precomposition. etrans; revgoals. { eapply pathsinv0. eapply nat_trans_eq_pointwise. apply (functor_comp H (_:EndC⟦ T_mon ∙ x', T_mon ∙ x⟧)). } apply cancel_postcomposition. apply functor_cancel_pw. apply nat_trans_eq_alt. intro c'. etrans; [| apply id_right ]. apply cancel_precomposition. apply (functor_id x). Qed. Local Definition ψ : (PreShv EndC)⟦ψ_source(D:=[C,C]) X L , ψ_target(D:=[C,C]) Id_H X L⟧ := (ψ_pw ,, ψ_nt). (** Uniqueness of the Mendler iterator characteristized by its equation *) Local Definition uniq_iter : ∃! h : [C, C] ⟦ L `T_hss, X ⟧, # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h := GenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC Id_H is_omega_cocont_Id_H' (D:=[C,C]) X _ isInitial_precomp' HL ψ. (** The previous characteristic equation can be split as an equality between coproduct of arrows : - h ∘ η_T = j_mor - h ∘ τ_T = τ_M ∘ H h ∘ Θ_T,T where [η_T, τ_T] : Id + HT --> T *) Local Lemma coprod_iter_eq (h:nat_trans _ _) : (∏ x, BinCoproductIn1 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) · (# L (alg_map Id_H T_alg):nat_trans _ _) x · h x = j_mor x) -> (∏ x, BinCoproductIn2 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) · (# L (alg_map Id_H T_alg):nat_trans _ _) x · h x = (θ (`T_alg ⊗ p T_alg):nat_trans _ _) x · (# H h:nat_trans _ _) x · τ_M x) -> # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h. Proof. intros hB1 hB2. apply nat_trans_eq_alt. intros x. etrans. { etrans. { apply cancel_postcomposition. apply BinCoproductArrowEta. } apply postcompWithBinCoproductArrow. } use maponpaths_12. - apply hB1. - apply hB2. Qed. Let τT := τ_lmodule_mor T. (** j is a morphism of representation. It is exactly the 'H' part of the Id + H algebra morphism diagram *) Lemma j_mor_rep x : τT x · j_mor x = (# H j_mor:nat_trans _ _) x · τ_M x. Proof. etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) x). } etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans; [ apply assoc' |]. apply cancel_precomposition. apply BinCoproductIn2Commutes. Qed. (** j satisfies the η-related diagram of monad morphism. This is Id part of the Id+H-algebra morphism diagram *) Lemma j_mon_η : ∏ a : C, (Monads.η T_mon) a · j_mor a = (Monads.η M) a. Proof. intro a. etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) a). } etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply BinCoproductIn1Commutes. } apply id_left. Qed. Let j_ptd : category_Ptd C ⟦ ptd_from_mon T_mon, ptd_from_mon M⟧. Proof. use tpair. - apply j. - intros x. apply j_mon_η. Defined. (** j is a monad morphism (following Ralph's proof). For the square diagram, we show that both parts satisfies the same Mendler iterator characteristic equation *) Lemma j_mon_square_eq1 : # L (alg_map Id_H T_alg) · ((μ T_mon : EndC ⟦_, _⟧) · j_mor) = (ψ : nat_trans _ _) `T_alg ((μ T_mon : EndC ⟦_, _⟧) · j_mor). Proof. apply coprod_iter_eq; intro x. - (* T monad law *) etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (Monad_law1 (T:=T_mon)). } apply id_left. - (* tau_T is a module morphism *) etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (LModule_Mor_σ _ τT). } etrans; [ apply assoc' |]. etrans; [ apply assoc' |]. etrans; [| apply assoc ]. apply cancel_precomposition. rewrite functor_comp. etrans; [| apply assoc ]. apply cancel_precomposition. apply j_mor_rep. Qed. Lemma j_mon_square_eq2 : # L (alg_map Id_H T_alg) · ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M) = (ψ : nat_trans _ _) `T_alg ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M). Proof. apply coprod_iter_eq; intro x. - etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. etrans; [ apply assoc |]. apply cancel_postcomposition. apply j_mon_η. } etrans. { apply cancel_postcomposition. eapply pathsinv0. apply (nat_trans_ax (Monads.η M )). } etrans; [| apply id_right ]. rewrite <- assoc. apply cancel_precomposition. apply Monad_law1. - etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply j_mor_rep. } rewrite <- assoc. apply cancel_precomposition. eapply pathsinv0. apply (nat_trans_ax τ_M). } etrans. { repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. apply (LModule_Mor_σ _ τ_M ( x)). } repeat rewrite assoc. apply cancel_postcomposition. etrans. { repeat rewrite <- assoc. apply cancel_precomposition. etrans; [ apply assoc |]. apply cancel_postcomposition. apply (θ_nat_2_pw _ _ _ j_ptd). } etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. apply (θ_nat_1_pw _ _ j_mor (ptd_from_mon T_mon)). } repeat rewrite <- assoc. apply cancel_precomposition. rewrite functor_comp. rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. rewrite <- functor_comp. etrans; [ apply functor_comp_pw |]. apply functor_cancel_pw. apply nat_trans_eq_alt. intro y. etrans. { apply cancel_postcomposition. etrans. { apply cancel_precomposition. apply functor_id. } apply id_right. } apply cancel_precomposition. apply id_left. Qed. Lemma j_mon_laws : Monad_Mor_laws (T:=T_mon) (T':=M) (mor_from_algebra_mor _ j). Proof. split. - apply (nat_trans_eq_pointwise (a:= compose (C:=EndC) (μ T_mon) j_mor) (a':= compose(C:=EndC) (compose (C:=EndC) (a:=_∙_) (b:=_∙_) (c:=_∙_) (j_mor ø T_mon ) (M ∘ j_mor) ) (μ M))). apply (uniqueExists uniq_iter). + exact j_mon_square_eq1. + exact j_mon_square_eq2. - apply j_mon_η. Qed. Definition j_mon : Monad_Mor T_mon M := _ ,, j_mon_laws. End fix_a_representation. (** TODO: To assemble the above results into a concise statement, we would need to define the category of representations of a signature (H,θ). *) End InitialRep. UniMath-20231010/UniMath/SubstitutionSystems/MonadicSubstitution_alt.v000066400000000000000000000106601451125700300260210ustar00rootroot00000000000000(** Shows global results that do not fit into a particular file but rather put the different strands together. We focus on the results that are based on omega-cocontinuity (and not the existence of right Kan extensions), which also explains the suffix "_alt" to the proper file name. Written by Ralph Matthes, 2021 *) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Section MainResult. Context (C : category) (CP : BinCoproducts C). Context (IC : Initial C) (CC : Colims_of_shape nat_graph C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply ColimsFunctorCategory_of_shape, CC. Defined. Context (H : functor [C, C] [C, C]) (θ : StrengthForSignature H) (HH : is_omega_cocont H). Let Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. Let Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Definition TermHSS : hss_category CP (Presignature_Signature (H,,θ)) := InitHSS C CP IC CC (Presignature_Signature (H,,θ)) HH. Definition TermHetSubst: heterogeneous_substitution C CP H := hetsubst_from_hss C CP (Presignature_Signature (H,,θ)) TermHSS. Definition Terms: [C, C] := pr1 (pr1 TermHSS). Definition TermAlgebra: FunctorAlg Id_H:= pr1 TermHSS. Goal TermAlgebra = InitAlg C CP IC CC H HH. Proof. apply idpath. Qed. Definition isInitialTermAlgebra: isInitial (FunctorAlg Id_H) TermAlgebra. Proof. set (aux := colimAlgInitial InitialEndC (is_omega_cocont_Id_H C CP H HH) (Colims_of_shape_nat_graph_EndC _)). exact (pr2 aux). Defined. Definition TermMonad: Monad C := Monad_from_hss C CP (H,,θ) TermHSS. Definition VarTerms: [C, C] ⟦ functor_identity C, Terms ⟧:= eta_from_alg TermAlgebra. Definition ConstrTerms: [C, C] ⟦ H Terms, Terms ⟧ := tau_from_alg TermAlgebra. Goal ConstrTerms = τ TermHetSubst. Proof. apply idpath. Qed. Definition join: [C, C] ⟦ functor_compose Terms Terms, Terms ⟧ := prejoin_from_hetsubst TermHetSubst. Goal join = μ TermMonad. Proof. apply idpath. Qed. Definition joinLookup: ∏ c : C, pr1 VarTerms (pr1 Terms c) · pr1 join c = identity (pr1 Terms c) := @Monad_law1 C TermMonad. Definition θforTerms := θ_from_hetsubst C CP H TermHetSubst Terms. Goal θforTerms = PrecategoryBinProduct.nat_trans_fix_snd_arg_data [C, C] Ptd [C, C] (θ_source H) (θ_target H) (pr1 θ) (ptd_from_alg (InitAlg C CP IC CC H HH)) Terms. Proof. apply idpath. Qed. Definition joinHomomorphic: θforTerms · # H join · ConstrTerms = #(pre_composition_functor _ _ _ Terms) ConstrTerms · join := prejoin_from_hetsubst_τ TermHetSubst. Definition joinHasEtaLaw: ∏ c : C, # (pr1 Terms) (pr1 VarTerms c) · pr1 join c = identity (pr1 Terms c) := @Monad_law2 C TermMonad. Definition joinHasPermutationLaw: ∏ c : C, # (pr1 Terms) (pr1 join c) · pr1 join c = pr1 join (pr1 Terms c) · pr1 join c := @Monad_law3 C TermMonad. End MainResult. UniMath-20231010/UniMath/SubstitutionSystems/MonadsFromSubstitutionSystems.v000066400000000000000000000514641451125700300272530ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Construction of a monad from a substitution system - Proof that morphism of hss gives morphism of monads - Bundling that into a functor - Proof that the functor is faithful ************************************************************) Unset Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Local Open Scope cat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Section monad_from_hss. (** ** Some variables and assumptions *) Context (C : category). Context (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Variable H : Signature C C C. Let θ := theta H. Let θ_strength1_int := Sig_strength_law1 H. Let θ_strength2_int := Sig_strength_law2 H. Let Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . (** ** Derivation of the monad laws from a heterogeneous substitution system for signature with strength [H] *) Section mu_from_fbracket. (** We assume given a hss [T] *) Variable T : hss CP H. Local Notation "'p' T" := (ptd_from_alg T) (at level 3). Local Notation "f ⊕ g" := (BinCoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g). Definition μ_0 : functor_identity C ⟹ functor_data_from_functor _ _ `T := η T. (*ptd_pt _ (pr1 (pr1 T)).*) (** [η T] as pointed morphism *) Definition μ_0_ptd : id_Ptd C --> p T. Proof. exists μ_0. intro c. simpl. apply id_left. Defined. (** the bracket of the "degenerate" argument [η T] *) Definition μ_1 : functor_composite (U (id_Ptd C)) (`T) ⟹ functor_data_from_functor _ _ `T := fbracket _ μ_0_ptd. (** using uniqueness of bracket for [η T] *) Lemma μ_1_identity : μ_1 = identity `T . Proof. apply pathsinv0. apply fbracket_unique. split. - apply nat_trans_eq_alt. intros; simpl. rewrite id_right. apply idpath. - apply nat_trans_eq_alt. intro c. simpl. rewrite id_right. assert (H':= θ_Strength1_int_implies_θ_Strength1 _ θ_strength1_int). red in H'. simpl in H'. assert (H2 := H' (`T)). assert (H3 := nat_trans_eq_pointwise H2 c). simpl in *. intermediate_path (identity _ · pr1 (τ T) c). + apply cancel_postcomposition. apply H3. + apply id_left. Qed. Lemma μ_1_identity' : ∏ c : C, μ_1 c = identity _. Proof. intros c. assert (HA:= nat_trans_eq_pointwise μ_1_identity). apply HA. Qed. (* The whole secret is that this typechecks Check (μ_1:U T-->U T). *) (* therefore, it is not just the type itself that makes it necessary to introduce μ_1_alt, it is rather the question of the formulation of the first strength law of θ *) (* Lemma μ_1_identity_stronger : μ_1 = identity (U T). Proof. set (t':=nat_trans_eq_weq C C hs _ _ μ_1 (identity (U T))). apply invweq in t'. set (t'' := t' μ_1_identity'). exact t''. Qed. *) (** This is the multiplication of the monad to be constructed *) Definition μ_2 : functor_composite (`T) (`T) ⟹ pr1 (`T) := prejoin_from_hetsubst T. Goal μ_2 = fbracket T (identity _ ). Proof. apply idpath. Qed. Definition disp_Monad_data_from_hss : disp_Monad_data `T := μ_2 ,, μ_0. (** *** Proof of the first monad law *) (** this directly comes from the contained heterogeneous substitution *) Lemma Monad_law_1_from_hss : ∏ c : C, μ_0 (pr1 (`T) c) · μ_2 c = identity ((pr1 (`T)) c). Proof. intro c. unfold μ_0. set (H' := prejoin_from_hetsubst_η T). set (H2:= nat_trans_eq_weq (homset_property C) _ _ H'). apply pathsinv0. apply H2. Qed. (** *** Proof of the second monad law *) (** using uniqueness of bracket for [η T] *) Lemma Monad_law_2_from_hss: ∏ c : C, # (pr1 (`T)) (μ_0 c)· μ_2 c = identity ((pr1 (`T)) c). Proof. intro c. intermediate_path (μ_1 c). - unfold μ_1. assert (H' := @fbracket_unique_target_pointwise _ _ _ T). assert (H1 := H' _ μ_0_ptd). set (x := post_whisker μ_0 (`T) : EndC ⟦ `T • functor_identity _ , `T • `T ⟧). set (x' := x · μ_2). assert (H2 := H1 x'). apply H2; clear H2. unfold x'. clear x'. unfold x; clear x. clear H1. clear H'. clear c. split. + apply nat_trans_eq_alt. intro c. assert (H' := nat_trans_ax (η T)). simpl in H'. rewrite assoc. cbn. rewrite <- H'; clear H'. assert (H' := prejoin_from_hetsubst_η T). assert (H2 := nat_trans_eq_weq (homset_property C) _ _ H'). simpl in H2. rewrite <- assoc. rewrite <- H2. apply pathsinv0. apply id_right. + rewrite functor_comp. apply nat_trans_eq_alt. intro c. rewrite <- horcomp_id_postwhisker. do 2 rewrite assoc. simpl in *. unfold horcomp_data; simpl. intermediate_path ( # (pr1 (H ( (` T)))) (μ_0 c) · pr1 (θ ((`T) ⊗ (p T))) c · pr1 (# H μ_2) c · pr1 (τ T) c). * unfold tau_from_alg; cbn. do 2 rewrite assoc. do 3 apply cancel_postcomposition. assert (H' := θ_nat_2 _ _ _ H θ). assert (H2 := H' (`T) _ _ μ_0_ptd); clear H'. assert (H3 := nat_trans_eq_weq (homset_property C) _ _ H2 c); clear H2. simpl in H3. unfold horcomp_data in H3; simpl in H3. rewrite id_left in H3. apply (!H3). * assert (H' := prejoin_from_hetsubst_τ T). assert (H2 := nat_trans_eq_weq (homset_property C) _ _ H' c); clear H'. simpl in *. do 2 rewrite <- assoc. { intermediate_path ( # (pr1 (H (` T))) (μ_0 c) · (pr1 (τ T) (pr1 (`T) c) · pr1 μ_2 c)). - apply maponpaths. rewrite assoc. apply H2. (* rewrite done *) - clear H2. do 2 rewrite assoc. apply cancel_postcomposition. etrans. { apply (nat_trans_ax (τ T) ). } apply cancel_postcomposition. apply pathsinv0. apply id_right. } - apply μ_1_identity'. Qed. (** [T_squared] is [T∙T, η∙η], that is, the selfcomposition of [T] as a pointed functor *) Definition T_squared : Ptd := ptd_compose _ (p T) (p T). (** [μ_2] is not just a natural transformation from [T∙T] to [T], but also compatible with the pointed structure given by [η] *) Lemma μ_2_is_ptd_mor : ∏ c : C, (ptd_pt C T_squared) c · μ_2 c = pr1 (η T) c. Proof. intro c. unfold μ_2. unfold T_squared. unfold ptd_compose. rewrite functorial_composition_pre_post. simpl. assert (H' := Monad_law_2_from_hss c). simpl in H'. intermediate_path (pr1 (η T) c · identity _ ). - unfold eta_from_alg; simpl. repeat rewrite <- assoc. apply maponpaths. apply maponpaths. exact H'. - apply id_right. Qed. Definition μ_2_ptd : T_squared --> p T. Proof. exists μ_2. red. apply μ_2_is_ptd_mor. Defined. Definition μ_3 : EndC ⟦ U T_squared • `T, `T⟧ := fbracket T μ_2_ptd. (** *** Proof of the third monad law via transitivity *) (** We show that both sides are equal to [μ_3 = fbracket μ_2] *) (** using uniqueness of bracket for the prejoin *) Lemma μ_3_T_μ_2_μ_2 : μ_3 = (`T ∘ μ_2 : EndC ⟦ `T • _ , `T • `T ⟧ ) · μ_2. Proof. apply pathsinv0. apply (fbracket_unique T μ_2_ptd). split. - apply nat_trans_eq_alt. intro c. assert (H2 := nat_trans_ax (η T)); simpl in H2. rewrite assoc. simpl; rewrite <- H2 ; clear H2. intermediate_path (μ_2 c · identity _ ). + apply pathsinv0, id_right. + etrans; [| apply assoc ]. apply maponpaths. apply pathsinv0. apply Monad_law_1_from_hss. - rewrite functor_comp. assert (H1 := θ_nat_2 _ _ _ H θ (`T) _ _ μ_2_ptd). simpl in H1. repeat rewrite assoc. match goal with |[H1 : ?g = _ |- _ · _ · ?f · ?h = _ ] => intermediate_path (g · f · h) end. + do 2 apply cancel_postcomposition. apply pathsinv0. etrans; [apply H1 |]. clear H1. do 2 apply maponpaths. assert (H3 := horcomp_id_postwhisker). assert (H4 := H3 _ _ _ _ _ μ_2 (`T)); clear H3. apply H4. + clear H1. apply nat_trans_eq_alt. intro c; simpl. unfold horcomp_data; simpl. rewrite id_left. assert (H2 := prejoin_from_hetsubst_τ T). assert (H3 := nat_trans_eq_pointwise H2 c); clear H2. simpl in *. match goal with |[H3 : _ = ?f |- ?e · _ · _ · _ = _ ] => intermediate_path (e · f) end. * etrans; [ apply assoc' |]. etrans; [ apply assoc' |]. apply maponpaths. etrans; [| apply H3 ]. apply assoc. * clear H3. repeat rewrite assoc. apply cancel_postcomposition. assert (H1 := nat_trans_ax (τ T )). unfold tau_from_alg in H1. etrans; [ | apply H1]; clear H1. apply assoc'. Qed. Local Notation "'T•T²'" := (functor_compose (functor_composite (`T) (`T)) (`T) : [C, C]). Local Notation "'T²∙T'" := (@functor_composite C C C (@functor_composite C C C (`T) (` T)) (` T) : functor C C). (** using uniqueness of bracket for the prejoin also here *) Lemma μ_3_μ_2_T_μ_2 : ( @compose (functor_category C C) (* TtimesTthenT *) T²∙T _ _ (* (@functor_composite C C C ((functor_ptd_forget C hs) T) ((functor_ptd_forget C hs) T)) ((functor_ptd_forget C hs) T) *) ((μ_2 •• `T) (* : TtimesTthenT' --> _ *) (*:@functor_compose C C C hs hs (@functor_composite C C C ((functor_ptd_forget C hs) T) ((functor_ptd_forget C hs) T)) ((functor_ptd_forget C hs) T) --> _*) ) μ_2 : (*TtimesTthenT'*) T•T² --> `T) = μ_3. Proof. apply (fbracket_unique (*_pointwise*) T μ_2_ptd). split. - apply nat_trans_eq_alt; intro c. simpl. intermediate_path (identity _ · μ_2 c). + apply pathsinv0, id_left. + etrans; [ | apply assoc' ]. apply cancel_postcomposition. assert (H1 := Monad_law_1_from_hss (pr1 (`T) c)). apply (!H1). - set (B := τ T). match goal with | [|- _ · # ?H (?f · _ ) · _ = _ ] => set (F := f : (*TtimesTthenT'*) T•T² --> _ ) end. assert (H3 := functor_comp H F μ_2). unfold functor_compose in H3. etrans. { apply cancel_postcomposition. apply maponpaths. apply H3. } clear H3. apply nat_trans_eq_alt. intro c. simpl. match goal with | [ |- ?a · _ · _ = _ ] => set (Ac := a) end. simpl in Ac. simpl in *. unfold functor_compose in *. assert (HX := θ_nat_1 _ _ _ H θ _ _ μ_2). (* it may be tested with the primed version *) assert (HX1 := HX (ptd_from_alg T)); clear HX. simpl in HX1. assert (HXX := nat_trans_eq_pointwise HX1 c); clear HX1. simpl in HXX. unfold horcomp_data in HXX. rewrite (functor_id ( H (`T))) in HXX. rewrite id_right in HXX. (* last two lines needed because of def. of theta on product category *) match goal with |[HXX : ?f · ?h = _ · _ |- _ · (_ · ?x ) · ?y = _ ] => intermediate_path (pr1 (θ ((`T) ⊗ (ptd_from_alg T))) (pr1 (pr1 (pr1 T)) c)· f · h · x · y) end. * repeat rewrite assoc. do 3 apply cancel_postcomposition. unfold Ac. clear Ac. etrans; [| apply assoc ]. etrans. 2: { apply maponpaths. apply (!HXX). } clear HXX. assert (Strength_2 : ∏ α : functor_compose (functor_composite (`T) (`T))(`T) --> functor_composite (` T) (`T), pr1 (θ (`T ⊗ T_squared)) c · pr1 (# H α) c = pr1 (θ ((`T) ⊗ (ptd_from_alg T))) ((pr1 (pr1 (pr1 T))) c)· pr1 (θ (( ((`T) • (`T) : [_, _])) ⊗ (ptd_from_alg T))) c· pr1 (# H (α : functor_compose (`T) (functor_composite (`T) (` T))--> _)) c ). { intro α; assert (HA := θ_Strength2_int_implies_θ_Strength2 _ θ_strength2_int); assert (HA' := HA (`T) (ptd_from_alg T) (ptd_from_alg T) _ α); clear HA; assert (HA2 := nat_trans_eq_pointwise HA' c ); clear HA'; simpl in HA2; apply HA2. } etrans; [ apply (Strength_2 F) |]. clear Strength_2. etrans; [ apply assoc' |]. do 2 apply maponpaths. match goal with |[ |- _ = ?pr1 (# ?G ?g) _ ] => assert (X : F = g) end. { apply nat_trans_eq; try apply homset_property. intros. unfold F. simpl. unfold horcomp_data; simpl. rewrite functor_id. apply pathsinv0, id_right. } apply (maponpaths (λ T, pr1 (# H T) c)). apply X. * clear HXX. clear Ac. clear F. clear B. assert (H4 := prejoin_from_hetsubst_τ T). assert (H5 := nat_trans_eq_pointwise H4 c); clear H4. simpl in H5. { match goal with |[ H5 : _ = ?e |- ?a · ?b · _ · _ · _ = _ ] => intermediate_path (a · b · e) end. - repeat rewrite <- assoc. do 2 apply maponpaths. repeat rewrite <- assoc in H5. apply H5. - clear H5. repeat rewrite assoc. apply cancel_postcomposition. assert (HT := prejoin_from_hetsubst_τ T). assert (H6 := nat_trans_eq_pointwise HT); clear HT. unfold coproduct_nat_trans_in2_data. unfold tau_from_alg in H6. rewrite assoc in H6. apply H6. } Qed. (** proving a variant of the third monad law with assoc iso explicitly inserted *) Section third_monad_law_with_assoc. Lemma third_monad_law_from_hss : (`T ∘ μ_2 : EndC ⟦ functor_composite (functor_composite `T `T) `T , `T • `T ⟧) · μ_2 = (rassociator_CAT _ _ _) · (μ_2 •• `T) · μ_2. Proof. intermediate_path μ_3; [apply pathsinv0, μ_3_T_μ_2_μ_2 | ]. apply pathsinv0. (** we only aim at a proof alternative to [μ_3_μ_2_T_μ_2] *) apply (fbracket_unique (*_pointwise*) T μ_2_ptd). split. - apply nat_trans_eq_alt; intro c. simpl. rewrite assoc. intermediate_path (identity _ · μ_2 c). + apply pathsinv0, id_left. + apply cancel_postcomposition. rewrite id_left. assert (H1 := Monad_law_1_from_hss (pr1 (`T) c)). simpl in H1. apply (!H1). - do 2 rewrite functor_comp. do 4 rewrite assoc. unfold T_squared. apply nat_trans_eq_alt. intro c; simpl. assert (HTT := θ_strength2_int). assert (HX := HTT (`T) (ptd_from_alg T) (ptd_from_alg T)); clear HTT. assert (HX' := nat_trans_eq_pointwise HX c); clear HX. simpl in HX'. match goal with | [ H : _ = ?f |- _ · _ · ?g · ?h · ?i = _ ] => intermediate_path (f · g · h · i) end. + do 3 apply cancel_postcomposition. apply HX'. + clear HX'. rewrite id_left. rewrite id_right. assert (HX :=θ_nat_1 _ _ _ H θ _ _ μ_2). assert (HX1 := HX (ptd_from_alg T)); clear HX. simpl in HX1. assert (HXX := nat_trans_eq_pointwise HX1 c); clear HX1. simpl in HXX. unfold horcomp_data in HXX; simpl in HXX. match goal with | [ H : ?x = _ |- ?e · _ · _ · ?f · ?g = _ ] => intermediate_path (e · x · f · g) end. * do 2 apply cancel_postcomposition. repeat rewrite <- assoc. apply maponpaths. { match goal with | [ H : _ = ?x |- _ ] => intermediate_path x end. - clear HXX. apply maponpaths. match goal with | [ |- _ ?a ?x = _ ?b ?y ] => assert (TTT : a = b) end. { match goal with | [ |- _ ?a = _ ?b ] => assert (TTTT : a = b) end. { apply nat_trans_eq_alt. intros. simpl. unfold horcomp_data; simpl. rewrite functor_id. apply pathsinv0, id_right. } apply maponpaths. apply TTTT. } apply (nat_trans_eq_pointwise TTT). - repeat rewrite assoc. repeat rewrite assoc in HXX. apply (!HXX). } * clear HXX. assert (H4 := prejoin_from_hetsubst_τ T). assert (H5 := nat_trans_eq_pointwise H4 c); clear H4. unfold μ_2. repeat rewrite <- assoc. simpl in H5; repeat rewrite <- assoc in H5. etrans. { do 3 apply maponpaths. apply H5. } clear H5. rewrite functor_id. rewrite id_left. repeat rewrite assoc. apply cancel_postcomposition. assert (H4' := prejoin_from_hetsubst_τ T). assert (H6 := nat_trans_eq_pointwise H4' (pr1 `T c)); clear H4'. simpl in H6. unfold coproduct_nat_trans_in2_data in H6. simpl in H6. rewrite assoc in H6. apply H6. Qed. End third_monad_law_with_assoc. (* Unset Printing All. Set Printing Notations. Unset Printing Implicit. *) (** Finally putting together all the preparatory results to obtain a monad *) Lemma disp_Monad_laws_from_hss : disp_Monad_laws disp_Monad_data_from_hss. Proof. split. - unfold disp_Monad_data_from_hss; simpl; split. + apply Monad_law_1_from_hss. + apply Monad_law_2_from_hss. - unfold disp_Monad_data_from_hss; simpl. intro c. intermediate_path (pr1 μ_3 c). + set (H1 := μ_3_T_μ_2_μ_2). set (H2 := nat_trans_eq_weq (homset_property C) _ _ H1). apply pathsinv0, H2. + set (H1 := μ_3_μ_2_T_μ_2). set (H2 := nat_trans_eq_weq (homset_property C) _ _ H1). apply pathsinv0, H2. Qed. Definition Monad_from_hss : Monad C := _ ,, _ ,, disp_Monad_laws_from_hss. End mu_from_fbracket. (** ** A functor from hss to monads *) (** Objects are considered above, now morphisms *) Definition Monad_Mor_laws_from_hssMor (T T' : hss CP H)(β : hssMor T T') : Monad_Mor_laws (T:=Monad_from_hss T) (T':=Monad_from_hss T') (pr1 (pr1 β)). Proof. repeat split; simpl. - intro c. unfold μ_2. simpl. set (H' := isbracketMor_hssMor _ _ _ β). unfold isbracketMor in H'. set (H2 := H' _ (identity _ )). set (H3 := nat_trans_eq_weq (homset_property C) _ _ H2). rewrite id_left in H3. simpl in H3. rewrite H3; clear H3 H2 H'. rewrite compute_fbracket. rewrite <- assoc. apply maponpaths. apply cancel_postcomposition. apply idpath. - unfold μ_0. intro c. set (H' := ptd_mor_commutes _ (ptd_from_alg_mor _ _ _ β)). apply H'. Qed. Definition Monad_Mor_from_hssMor {T T' : hss CP H}(β : hssMor T T') : Monad_Mor (Monad_from_hss T) (Monad_from_hss T') := tpair _ _ (Monad_Mor_laws_from_hssMor T T' β). Definition hss_to_monad_functor_data : functor_data (hss_precategory CP H) (category_Monad C). Proof. exists Monad_from_hss. exact @Monad_Mor_from_hssMor. Defined. Lemma is_functor_hss_to_monad : is_functor hss_to_monad_functor_data. Proof. split; simpl. - intro a. apply (invmap (Monad_Mor_equiv _ _ )). apply idpath. - intros a b c f g. apply (invmap (Monad_Mor_equiv _ _ )). apply idpath. Qed. Definition hss_to_monad_functor : functor _ _ := tpair _ _ is_functor_hss_to_monad. Definition hssMor_Monad_Mor_eq {T T' : hss CP H} (β β' : hssMor T T') : β = β' ≃ Monad_Mor_from_hssMor β = Monad_Mor_from_hssMor β'. Proof. eapply weqcomp. - apply hssMor_eq. - apply invweq. use Monad_Mor_equiv. Defined. (** *** The functor from hss to monads is faithful, i.e. forgets at most structure *) Lemma faithful_hss_to_monad : faithful hss_to_monad_functor. Proof. unfold faithful. intros T T'. apply isinclbetweensets. - apply isaset_hssMor. - apply isaset_Monad_Mor. - intros β β'. apply (invmap (hssMor_Monad_Mor_eq _ _ )). Qed. End monad_from_hss. UniMath-20231010/UniMath/SubstitutionSystems/MonadsMultiSorted.v000066400000000000000000000436531451125700300245770ustar00rootroot00000000000000(** Monads in SET/sort This file contains the consideration of monads in the slice category SET/sort that are obtained in our approach to multi-sorted binding signatures. As such, it has nothing to with multi-sorted binding signatures, but the identifiers refer to that situation. Written by Ralph Matthes, 2017. *) Require Export UniMath.Tactics.EnsureStructuredProofs. (* Require Import UniMath.Foundations.PartD. *) Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.slicecat. Local Open Scope cat. Local Notation "C / X" := (slicecat_ob C X). Local Notation "C / X" := (slice_precat_data C X). Local Notation "C / X" := (slice_cat C X). Local Notation "C / X ⟦ a , b ⟧" := (slicecat_mor C X a b) (at level 50, format "C / X ⟦ a , b ⟧"). Section MonadsInHSET_over_sort. Variables (sort : hSet). Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let hs : has_homsets (HSET / sort) := homset_property HSET_over_sort. Let BC := BinCoproducts_slice_precat _ BinCoproductsHSET sort: BinCoproducts (HSET / sort). (** The object (1,λ _,s) in SET/sort that can be seen as a sorted variable *) Definition constHSET_slice (s : sort) : HSET / sort. Proof. exists (TerminalObject TerminalHSET); simpl. apply (λ x, s). Defined. Definition sorted_option_functor (s : sort) : functor (HSET / sort) (HSET / sort) := constcoprod_functor1 (BinCoproducts_HSET_slice sort) (constHSET_slice s). (** The following definitions do not depend on the monad coming from our construction, only on the slice category we are working in. *) Local Definition bind_instantiated {T:Monad (HSET / sort)}{Γ1 Γ2 : HSET_over_sort} (f : HSET_over_sort⟦Γ1,T Γ2⟧) : HSET_over_sort⟦T Γ1,T Γ2⟧ := bind f. (* the following would be on the right level of generality but make problems later (the monads are not coerced into their underlying functors): Definition wellsorted_in (T:[SET_over_sort,SET_over_sort])(Γ:SET_over_sort): hSet := pr1(pr1 T Γ). Definition sort_in (T:[SET_over_sort,SET_over_sort]){Γ:SET_over_sort}(M:wellsorted_in T Γ): sort := pr2 (pr1 T Γ) M. *) Context {T : Monad (HSET / sort)}. Local Definition T0 : functor (HSET / sort) (HSET / sort) := T. Definition wellsorted_in (Γ:HSET_over_sort): hSet := pr1(T0 Γ). Definition sort_in {Γ:HSET_over_sort}(M:wellsorted_in Γ): sort := pr2 (T0 Γ) M. Definition aux_fh {A1:hSet}{f1:A1->sort}{Γ2:HSET_over_sort} (f : A1->wellsorted_in Γ2)(H: forall a1:A1, sort_in (f a1) = f1 a1) : HSET_over_sort⟦(A1,,f1),T Γ2⟧. Proof. use tpair. * exact f. * cbn. abstract(apply funextsec; intro a1; now apply pathsinv0). Defined. Definition bind_slice {A1:hSet}{f1:A1->sort}{Γ2:HSET_over_sort} (f : A1->wellsorted_in Γ2)(H: forall a1:A1, sort_in (f a1) = f1 a1)(M: wellsorted_in (A1,,f1)) : wellsorted_in Γ2. Proof. exact (pr1 (bind_instantiated (aux_fh f H)) M). Defined. Lemma bind_slice_ok {A1: hSet} {f1: A1->sort} {Γ2: HSET_over_sort} (f : A1 -> wellsorted_in Γ2) (H: forall a1:A1, sort_in (f a1) = f1 a1) (M: wellsorted_in (A1,,f1)) : sort_in (bind_slice f H M) = sort_in M. Proof. assert (H1 := pr2 (bind_instantiated (aux_fh f H))). apply toforallpaths in H1. apply pathsinv0. now rewrite H1. Qed. Definition η_slice {Γ:HSET_over_sort} (a: pr1 (pr1 Γ)) : wellsorted_in Γ := pr1 ((Monads.η T) Γ) a. Lemma η_slice_ok {Γ: HSET_over_sort} (a: pr1 (pr1 Γ)) : sort_in (η_slice(Γ:=Γ) a) = (pr2 Γ) a. Proof. unfold η_slice. set (H1 := pr2 ((Monads.η T) Γ)). simpl in H1. apply toforallpaths in H1. now rewrite H1. Qed. Lemma η_bind_slice {A1: hSet} {f1: A1 -> sort} {Γ2: HSET_over_sort} (f : A1 -> wellsorted_in Γ2) (H: forall a1:A1, sort_in (f a1) = f1 a1) (a1:A1) : bind_slice f H (η_slice(Γ:=(A1,,f1)) a1) = f a1. Proof. unfold bind_slice. unfold η_slice. set (H1 := η_bind(aux_fh f H)). apply (maponpaths pr1) in H1. apply toforallpaths in H1. apply H1. Qed. Lemma bind_η_slice {A1: hSet}{f1: A1 -> sort} (H: forall a1:A1, sort_in (η_slice(Γ:=(A1,,f1)) a1) = f1 a1) (M: wellsorted_in (A1,,f1)) : bind_slice (η_slice(Γ:=(A1,,f1))) H M = M. Proof. unfold bind_slice, η_slice. unfold bind_instantiated. assert (H1 : aux_fh (λ a:A1, pr1 ((Monads.η T) (A1,, f1)) a) H = (Monads.η T) (A1,, f1)). + unfold aux_fh. now apply eq_mor_slicecat. + intermediate_path (pr1 (bind ((Monads.η T) (A1,, f1))) M). * apply (maponpaths (λ f, f M)). apply maponpaths. apply maponpaths. exact H1. * now rewrite bind_η. Qed. (** notice that the hypothesis [H] can be instantiated with [η_slice_ok] *) Lemma bind_η_slice_inst {A1: hSet} {f1: A1 -> sort} (M: wellsorted_in (A1,,f1)) : bind_slice (η_slice(Γ:=(A1,,f1))) (η_slice_ok(Γ:=(A1,,f1))) M = M. Proof. apply bind_η_slice. Qed. (** would rather be used from right to left *) Lemma bind_bind_slice {A1: hSet} {f1: A1 -> sort} {A2: hSet} {f2: A2 -> sort} {Γ3: HSET_over_sort} (f : A1 -> wellsorted_in (A2,,f2)) (H1: forall a1:A1, sort_in (f a1) = f1 a1) (g : A2 -> wellsorted_in Γ3) (H2: forall a2:A2, sort_in (g a2) = f2 a2) (HH: forall a1:A1, sort_in (bind_slice g H2 (f a1)) = f1 a1) (M: wellsorted_in (A1,,f1)) : bind_slice g H2 (bind_slice f H1 M) = bind_slice (λ a1:A1, bind_slice g H2 (f a1)) HH M. Proof. unfold bind_slice. intermediate_path (pr1 (bind_instantiated (aux_fh f H1) · bind_instantiated (aux_fh g H2)) M). + apply idpath. + apply (maponpaths (λ f, f M)). apply maponpaths. unfold bind_instantiated. rewrite bind_bind. apply maponpaths. now apply eq_mor_slicecat. Qed. Local Definition HH_bind_bind_slice {A1: hSet} {f1: A1 -> sort} {A2: hSet} {f2: A2 -> sort} {Γ3: HSET_over_sort} (f : A1 -> wellsorted_in (A2,,f2)) (H1: forall a1:A1, sort_in (f a1) = f1 a1) (g : A2 -> wellsorted_in Γ3) (H2: forall a2:A2, sort_in (g a2) = f2 a2) (a1:A1) : sort_in (bind_slice g H2 (f a1)) = f1 a1. Proof. eapply pathscomp0. + apply (bind_slice_ok g H2). + apply H1. Defined. Lemma bind_bind_slice_inst {A1: hSet} {f1: A1 -> sort} {A2: hSet} {f2: A2 -> sort} {Γ3: HSET_over_sort} (f : A1 -> wellsorted_in (A2,,f2)) (H1: forall a1:A1, sort_in (f a1) = f1 a1) (g : A2 -> wellsorted_in Γ3) (H2: forall a2:A2, sort_in (g a2) = f2 a2) (HH: forall a1:A1, sort_in (bind_slice g H2 (f a1)) = f1 a1) (M: wellsorted_in (A1,,f1)) : bind_slice g H2 (bind_slice f H1 M) = bind_slice (λ a1:A1, bind_slice g H2 (f a1)) (HH_bind_bind_slice f H1 g H2) M. Proof. apply bind_bind_slice. Qed. (** now we only substitute a single sorted variable *) Definition aux_inject_N {Γ: HSET_over_sort} (N : wellsorted_in Γ): HSET_over_sort⟦constHSET_slice (sort_in N),T Γ⟧. Proof. use tpair. + exact (fun _=> N). + now apply funextsec. Defined. (* first approach not instantiating from the general situation of a monad: Definition subst_slice {Γ:SET_over_sort}(N : wellsorted_in Γ) (M : wellsorted_in (sorted_option_functor (sort_in N) Γ)): wellsorted_in Γ. Proof. set (aux0 := (CategoryTheory.Monads.η T Γ)). set (auxf := BinCoproductArrow _ (BC _ _) (aux_inject_N N) (CategoryTheory.Monads.η T Γ)). refine (bind_slice (pr1 auxf) _ M). intro a. simpl in a. induction a as [a | a]. + now idtac. + generalize (ii2(A:=unit) a). clear a. apply toforallpaths. (* intermediate_path ((BinCoproductArrow HSET (BinCoproductsHSET 1%CS (pr1 Γ)) (λ _ : unit, N) (pr1 ((Monads.η T) Γ))) · (sort_in T)).*) change ((BinCoproductArrow HSET (BinCoproductsHSET 1%CS (pr1 Γ)) (λ _ : unit, N) (pr1 ((Monads.η T) Γ))) · sort_in = BinCoproductArrow HSET (BinCoproductsHSET 1%CS (pr1 Γ)) (λ _ : unit, sort_in N) (pr2 Γ)). rewrite postcompWithBinCoproductArrow. apply map_on_two_paths. - apply idpath. - set (aux1 := pr2 ((Monads.η T) Γ)). apply pathsinv0. now (etrans; try eapply aux1). Defined. *) Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). Local Definition monadSubstGen_instantiated {T: Monad (HSET / sort)} {Γ2 : HSET_over_sort} (Γ1: HSET_over_sort) (e : HSET_over_sort⟦Γ2,T Γ1⟧) : HSET_over_sort⟦T (Γ2 ⊕ Γ1),T Γ1⟧ := monadSubstGen T BC Γ1 e. Definition subst_slice {Γ: HSET_over_sort}(N : wellsorted_in Γ) (M : wellsorted_in (sorted_option_functor (sort_in N) Γ)): wellsorted_in Γ := pr1 (monadSubstGen_instantiated _ (aux_inject_N N)) M. Lemma subst_slice_ok {Γ: HSET_over_sort} (N : wellsorted_in Γ) (M : wellsorted_in (sorted_option_functor (sort_in N) Γ)): sort_in (subst_slice N M) = sort_in M. Proof. assert (H1 := pr2 (monadSubstGen_instantiated _ (aux_inject_N N))). apply toforallpaths in H1. apply pathsinv0. now rewrite H1. Qed. Definition subst_slice_as_bind_slice {Γ: HSET_over_sort} (N : wellsorted_in Γ) (M : wellsorted_in (sorted_option_functor (sort_in N) Γ)): wellsorted_in Γ. Proof. use (bind_slice (BinCoproductArrow (BinCoproductsHSET _ _) (λ _, N) (η_slice(Γ:=Γ))) _ M). abstract(intro a1; induction a1 as [u | a1]; [apply idpath | unfold BinCoproductArrow; simpl; now rewrite η_slice_ok]). Defined. Lemma subst_slice_as_bind_slice_agrees {Γ: HSET_over_sort} (N : wellsorted_in Γ) (M : wellsorted_in (sorted_option_functor (sort_in N) Γ)) : subst_slice_as_bind_slice N M =subst_slice N M. Proof. unfold subst_slice_as_bind_slice, subst_slice. unfold bind_slice, monadSubstGen_instantiated. apply (maponpaths (λ f, f M)). apply maponpaths. unfold monadSubstGen, bind_instantiated. apply maponpaths. now apply eq_mor_slicecat. Qed. Definition subst_slice_eqn {Γ: HSET_over_sort} (N : wellsorted_in Γ) {s : sort} (M : wellsorted_in (sorted_option_functor s Γ)) (H: sort_in N = s) : wellsorted_in Γ. Proof. apply (subst_slice N). now rewrite <- H in M. Defined. Lemma subst_slice_eqn_ok {Γ: HSET_over_sort} (N : wellsorted_in Γ) {s : sort} (M : wellsorted_in (sorted_option_functor s Γ)) (H: sort_in N = s) : sort_in (subst_slice_eqn N M H) = sort_in M. Proof. unfold subst_slice_eqn. rewrite subst_slice_ok. now induction H. Qed. Local Definition mweak_instantiated (Γ1: HSET_over_sort) {Γ2: HSET_over_sort} : HSET_over_sort⟦T Γ2,T (Γ1 ⊕ Γ2)⟧ := mweak T BC _ _. Definition mweak_slice (Γ1: HSET_over_sort)(Γ2: HSET_over_sort): wellsorted_in Γ2 -> wellsorted_in (Γ1 ⊕ Γ2) := pr1 (mweak_instantiated Γ1). Arguments mweak_slice _ _ _ : clear implicits. Lemma mweak_slice_ok (Γ1: HSET_over_sort) {Γ2: HSET_over_sort} (M: wellsorted_in Γ2) : sort_in (mweak_slice Γ1 Γ2 M) = sort_in M. Proof. set (H1 := pr2 (mweak_instantiated(Γ2:=Γ2) Γ1)). apply toforallpaths in H1. apply pathsinv0. now rewrite H1. Qed. Definition mweak_slice_as_bind_slice (Γ1: HSET_over_sort) (Γ2: HSET_over_sort) (M: wellsorted_in Γ2) : wellsorted_in (Γ1 ⊕ Γ2). Proof. use (bind_slice (λ a1, η_slice(Γ:=Γ1 ⊕ Γ2) (pr1 (BinCoproductIn2 (BC _ _)) a1)) _ M). intro a1. simpl; now rewrite η_slice_ok. Defined. Lemma mweak_slice_as_bind_slice_agrees (Γ1: HSET_over_sort) {Γ2: HSET_over_sort} (M: wellsorted_in Γ2) : mweak_slice_as_bind_slice Γ1 Γ2 M = mweak_slice Γ1 Γ2 M. Proof. unfold mweak_slice_as_bind_slice, mweak_slice. unfold bind_slice, mweak_instantiated. apply (maponpaths (λ f, f M)). apply maponpaths. unfold mweak, bind_instantiated. apply maponpaths. now apply eq_mor_slicecat. Qed. Lemma mweak_slice_as_bind_slice_ok (Γ1: HSET_over_sort) {Γ2: HSET_over_sort} (M: wellsorted_in Γ2) : sort_in (mweak_slice_as_bind_slice Γ1 Γ2 M) = sort_in M. Proof. rewrite mweak_slice_as_bind_slice_agrees; apply mweak_slice_ok. Qed. Local Definition mexch_instantiated {Γ1 Γ2 Γ3: HSET_over_sort} : HSET_over_sort⟦T (Γ1 ⊕ (Γ2 ⊕ Γ3)), T (Γ2 ⊕ (Γ1 ⊕ Γ3))⟧ := mexch T BC _ _ _. Definition mexch_slice {Γ1 Γ2 Γ3: HSET_over_sort} : wellsorted_in (Γ1 ⊕ (Γ2 ⊕ Γ3)) -> wellsorted_in (Γ2 ⊕ (Γ1 ⊕ Γ3)) := pr1 (mexch_instantiated). Lemma mexch_slice_ok {Γ1 Γ2 Γ3: HSET_over_sort} (M: wellsorted_in (Γ1 ⊕ (Γ2 ⊕ Γ3))) : sort_in (mexch_slice M) = sort_in M. Proof. set (H1 := pr2 (mexch_instantiated(Γ1:=Γ1)(Γ2:=Γ2)(Γ3:=Γ3))). apply toforallpaths in H1. apply pathsinv0. now rewrite H1. Qed. Definition mexch_slice_as_bind_slice {Γ1 Γ2 Γ3: HSET_over_sort} (M: wellsorted_in (Γ1 ⊕ (Γ2 ⊕ Γ3))) : wellsorted_in (Γ2 ⊕ (Γ1 ⊕ Γ3)). Proof. (* first important preparations *) unfold BinCoproductObject in M. simpl in M. set (a1 := BinCoproductIn1 (BinCoproductsHSET _ _) · BinCoproductIn2 (BinCoproductsHSET _ _): HSET⟦pr1 Γ1, pr1(Γ2 ⊕ (Γ1 ⊕ Γ3))⟧). set (a21 := BinCoproductIn1 (BinCoproductsHSET _ _): HSET⟦pr1 Γ2, pr1(Γ2 ⊕ (Γ1 ⊕ Γ3))⟧). set (a22 := BinCoproductIn2 (BinCoproductsHSET _ _) · BinCoproductIn2 (BinCoproductsHSET _ _): HSET⟦pr1 Γ3, pr1(Γ2 ⊕ (Γ1 ⊕ Γ3))⟧). use (bind_slice ((BinCoproductArrow _ a1 (BinCoproductArrow _ a21 a22)) · η_slice(Γ:=Γ2 ⊕ (Γ1 ⊕ Γ3))) _ M). intro x. induction x as [x1 | x2]. + unfold BinCoproductArrow. simpl. unfold compose. simpl. now rewrite η_slice_ok. + induction x2 as [x21 | x22]. * unfold BinCoproductArrow. simpl. unfold compose. simpl. now rewrite η_slice_ok. * unfold BinCoproductArrow. simpl. unfold compose. simpl. now rewrite η_slice_ok. Defined. Lemma mexch_slice_as_bind_slice_agrees {Γ1 Γ2 Γ3: HSET_over_sort} (M : wellsorted_in (Γ1 ⊕ (Γ2 ⊕ Γ3))) : mexch_slice_as_bind_slice M = mexch_slice M. Proof. unfold mexch_slice_as_bind_slice, mexch_slice. unfold bind_slice, mexch_instantiated. apply (maponpaths (λ f, f M)). apply maponpaths. unfold mexch, bind_instantiated. apply maponpaths. now apply eq_mor_slicecat. Qed. Lemma mexch_slice_as_bind_slice_ok {Γ1 Γ2 Γ3: HSET_over_sort} (M : wellsorted_in (Γ1 ⊕ (Γ2 ⊕ Γ3))) : sort_in (mexch_slice_as_bind_slice M) = sort_in M. Proof. rewrite mexch_slice_as_bind_slice_agrees; apply mexch_slice_ok. Qed. Lemma subst_interchange_law_instantiated {t s: sort} {Γ: HSET_over_sort} (NN: HSET_over_sort⟦constHSET_slice t, T (constHSET_slice s ⊕ Γ)⟧) (LL: HSET_over_sort⟦constHSET_slice s, T Γ⟧): (monadSubstGen_instantiated _ NN) · (monadSubstGen_instantiated _ LL) = (mexch_instantiated (Γ1:=constHSET_slice t) (Γ2:=constHSET_slice s) (Γ3:=Γ)) · (monadSubstGen_instantiated _ (LL · (mweak_instantiated _))) · (monadSubstGen_instantiated _ (NN · (monadSubstGen_instantiated _ LL))). Proof. apply subst_interchange_law_gen. Qed. (* (* we were heading for the following lemma that presents the result in terms of the application domain and not category theory: *) Lemma subst_interchange_law_slice {Γ : SET_over_sort} (L : wellsorted_in Γ) (N : wellsorted_in (sorted_option_functor (sort_in L) Γ)) (M : wellsorted_in (sorted_option_functor (sort_in N) (sorted_option_functor (sort_in L) Γ))) : subst_slice L (subst_slice N M) = subst_slice_eqn (subst_slice L N) (subst_slice_eqn (mweak_slice _ _ L) (mexch_slice M) (mweak_slice_ok _ L)) (subst_slice_ok L N). Proof. set (ls := subst_slice L (subst_slice N M)). set (rs1 := subst_slice_eqn (mweak_slice _ _ L) (mexch_slice M) (mweak_slice_ok _ L)). set (rs2 := subst_slice L N). simpl in rs1. (* Problem: mweak_slice is not an instance of bind_slice, and rewriting is not possible since also *) (* mweak_slice_ok appears in the term. *) Admitted. *) Context {Γ : HSET_over_sort} (L : wellsorted_in Γ) (N : wellsorted_in (sorted_option_functor (sort_in L) Γ)) (M : wellsorted_in (sorted_option_functor (sort_in N) (sorted_option_functor (sort_in L) Γ))). Local Definition LHS : wellsorted_in Γ := subst_slice L (subst_slice N M). Local Definition RHS : wellsorted_in Γ := subst_slice_eqn (subst_slice L N) (subst_slice_eqn (mweak_slice_as_bind_slice _ _ L) (mexch_slice M) (mweak_slice_as_bind_slice_ok _ L)) (subst_slice_ok L N). Local Lemma same_sort_LHS_RHS : sort_in LHS = sort_in RHS. Proof. unfold LHS. rewrite subst_slice_ok. rewrite subst_slice_ok. unfold RHS. do 2 rewrite subst_slice_eqn_ok. apply pathsinv0. apply mexch_slice_ok. Qed. (* Lemma subst_interchange_law_slice: LHS = RHS. Proof. unfold LHS. do 2 rewrite <- subst_slice_as_bind_slice_agrees. unfold subst_slice_as_bind_slice. rewrite bind_bind_slice_inst. (* first treat the question of having the right sort *) Focus 2. simpl. induction a1 as [u | a1]. + rewrite bind_slice_ok. now rewrite postcompWithBinCoproductArrowHSET. Focus 2. simpl. rewrite bind_slice_ok. rewrite postcompWithBinCoproductArrowHSET. unfold BinCoproductArrow. simpl. unfold compose. simpl. unfold BinCoproduct_of_functors_ob. simpl. intermediate_path (sort_in (η_slice(Γ:=BinCoproductObject (slice_precat HSET sort has_homsets_HSET) (BinCoproducts_HSET_slice sort (constHSET_slice (sort_in L)) Γ)) a1)). Focus 2. now rewrite η_slice_ok. apply maponpaths. apply idpath. (* end of verifying the right sort *) (* the left-hand side is now of the form bind_slice f' H' M *) Admitted. *) End MonadsInHSET_over_sort. UniMath-20231010/UniMath/SubstitutionSystems/MonadsMultiSorted_alt.v000066400000000000000000000123521451125700300254270ustar00rootroot00000000000000(** Monads in [sort,C] Written by Anders Mörtberg, 2021 (adapted from MonadsMultiSorted.v) *) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.PartA. Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Local Open Scope cat. Section MonadInSortToC. Variables (sort : hSet) (Hsort : isofhlevel 3 sort) (C : category) (BC : BinCoproducts C) (TC : Terminal C). Let sortToC : category := [path_pregroupoid sort Hsort, C]. Local Lemma BinCoproductsSortToC : BinCoproducts sortToC. Proof. apply BinCoproducts_functor_precat, BC. Defined. Local Lemma TerminalSortToC : Terminal sortToC. Proof. apply Terminal_functor_precat, TC. Defined. Local Notation "a ⊕ b" := (BinCoproductObject (BinCoproductsSortToC a b)). Local Notation "1" := (TerminalObject TerminalSortToC). Context {M : Monad sortToC}. (* We can instantiate the monad laws at a specific sort t *) Definition sortToC_fun {X Y : sortToC} (f : ∏ t, C⟦pr1 X t,pr1 Y t⟧) : sortToC⟦X,Y⟧ := nat_trans_functor_path_pregroupoid f. Definition bind_fun {X Y : sortToC} (f : ∏ t, C⟦pr1 X t,pr1 (M Y) t⟧) : ∏ t, C⟦pr1 (M X) t,pr1 (M Y) t⟧ := λ t, pr1 (bind (sortToC_fun f)) t. Definition η_fun {X : sortToC} (t : sort) : C⟦pr1 X t,pr1 (M X) t⟧ := pr1 (η M X) t. Lemma η_bind_fun {X Y : sortToC} (f : ∏ t, C⟦pr1 X t,pr1 (M Y) t⟧) (t : sort) : η_fun t · bind_fun f t = f t. Proof. exact (nat_trans_eq_pointwise (η_bind (sortToC_fun f)) t). Qed. Lemma bind_η_fun {X : sortToC} (t : sort) : bind_fun η_fun t = pr1 (identity (M X)) t. Proof. etrans; [|apply (nat_trans_eq_pointwise (@bind_η _ M X) t)]. apply cancel_postcomposition. assert (H : sortToC_fun η_fun = η M X). { now apply nat_trans_eq; [apply homset_property|]. } exact (nat_trans_eq_pointwise (maponpaths (λ a, # M a) H) t). Qed. Lemma bind_bind_fun {X Y Z : sortToC} (f : ∏ t, C⟦pr1 X t,pr1 (M Y) t⟧) (g : ∏ t, C⟦pr1 Y t, pr1 (M Z) t ⟧) (t : sort) : bind_fun f t · bind_fun g t = bind_fun (λ s, f s · bind_fun g s) t. Proof. etrans; [apply (nat_trans_eq_pointwise (bind_bind (sortToC_fun f) (sortToC_fun g)) t)|]. apply cancel_postcomposition. assert (H : sortToC_fun f · bind (sortToC_fun g) = sortToC_fun (λ s, f s · bind_fun g s)). { now apply nat_trans_eq; [apply homset_property|]. } exact (nat_trans_eq_pointwise (maponpaths (λ a, # M a) H) t). Qed. (* As the instantiation at a specific sort t does not add much we don't do it for the exchange law *) Definition monadSubstGen_instantiated {X Y : sortToC} (f : sortToC⟦X,M Y⟧) : sortToC⟦M (X ⊕ Y),M Y⟧ := monadSubstGen M BinCoproductsSortToC Y f. Definition monadSubstGen_fun {X Y : sortToC} (f : ∏ s, C⟦pr1 X s,pr1 (M Y) s⟧) : ∏ t, C⟦pr1 (M (X ⊕ Y)) t,pr1 (M Y) t⟧ := λ t, pr1 (monadSubstGen_instantiated (sortToC_fun f)) t. Definition monadSubst_instantiated {X : sortToC} (f : sortToC⟦1,M X⟧) : sortToC⟦M (1 ⊕ X),M X⟧ := monadSubst M BinCoproductsSortToC TerminalSortToC X f. Definition mweak_instantiated {X Y : sortToC} : sortToC⟦M Y,M (X ⊕ Y)⟧ := mweak M BinCoproductsSortToC _ _. Definition mexch_instantiated {X Y Z : sortToC} : sortToC⟦M (X ⊕ (Y ⊕ Z)), M (Y ⊕ (X ⊕ Z))⟧ := mexch M BinCoproductsSortToC _ _ _. Lemma subst_interchange_law_gen_instantiated {X Y Z : sortToC} (f : sortToC⟦X,M (Y ⊕ Z)⟧) (g : sortToC⟦Y, M Z⟧) : monadSubstGen_instantiated f · monadSubstGen_instantiated g = mexch_instantiated · monadSubstGen_instantiated (g · mweak_instantiated) · monadSubstGen_instantiated (f · monadSubstGen_instantiated g). Proof. apply subst_interchange_law_gen. Qed. Lemma subst_interchange_law_instantiated {X : sortToC} (f : sortToC⟦1,M (1 ⊕ X)⟧) (g : sortToC⟦1,M X⟧) : monadSubst_instantiated f · monadSubst_instantiated g = mexch_instantiated · monadSubst_instantiated (g · mweak_instantiated) · monadSubst_instantiated (f · monadSubst_instantiated g). Proof. apply subst_interchange_law. Qed. End MonadInSortToC. UniMath-20231010/UniMath/SubstitutionSystems/MultiSorted.v000066400000000000000000000414331451125700300234270ustar00rootroot00000000000000(** This file contains a formalization of multisorted binding signatures: - Definition of multisorted binding signatures ([MultiSortedSig]) - Construction of a functor from a multisorted binding signature ([MultiSortedSigToFunctor]) - Construction of signature with strength from a multisorted binding signature ([MultiSortedSigToSignature]) - Proof that the functor obtained from a multisorted binding signature is omega-cocontinuous ([is_omega_cocont_MultiSortedSigToFunctor]) The construction of a monad on Set/sort from a multisorted signature is now found in [UniMath.SubstitutionSystems.MultiSortedMonadConstruction]. Written by: Anders Mörtberg, 2016. The formalization follows a note written by Benedikt Ahrens and Ralph Matthes, and is also inspired by discussions with them and Vladimir Voevodsky. Strength calculation added by Ralph Matthes, 2017. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.pullbacks. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Local Open Scope cat. Local Notation "C / X" := (slicecat_ob C X). Local Notation "C / X" := (slice_precat_data C X). Local Notation "C / X" := (slice_cat C X). Local Notation "C / X ⟦ a , b ⟧" := (slicecat_mor C X a b) (at level 50, format "C / X ⟦ a , b ⟧"). (* These should be global *) Arguments Gθ_Signature {_ _ _ _} _ _. Arguments Signature_Functor {_ _ _} _. Arguments BinProduct_of_functors {_ _} _ _ _. Arguments DL_comp {_ _} _ {_} _. Arguments θ_from_δ_Signature {_ _} _. Arguments BinProduct_of_Signatures {_ _ _} _ _ _. Arguments Sum_of_Signatures _ {_ _ _} _ _. (** * Definition of multisorted binding signatures *) Section MBindingSig. Variables (sort : hSet). Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let BC := BinCoproducts_slice_precat _ BinCoproductsHSET sort: BinCoproducts (HSET / sort). (** Definition of multi sorted signatures *) Definition MultiSortedSig : UU := ∑ (I : hSet), I → list (list sort × sort) × sort. Definition ops (M : MultiSortedSig) : hSet := pr1 M. Definition arity (M : MultiSortedSig) : ops M → list (list sort × sort) × sort := λ x, pr2 M x. Definition make_MultiSortedSig {I : hSet} (ar : I → list (list sort × sort) × sort) : MultiSortedSig := (I,,ar). (** * Construction of an endofunctor on [HSET/sort,HSET/sort] from a multisorted signature *) Section functor. Local Definition proj_fun (s : sort) : HSET / sort -> HSET := λ p, hfiber_hSet (pr2 p) s. Definition proj_functor (s : sort) : functor (HSET / sort) HSET. Proof. use tpair. - exists (proj_fun s). intros X Y f p. exists (pr1 f (pr1 p)). abstract (now induction f as [h hh]; induction p as [x hx]; simpl in *; rewrite <- hx, hh). - abstract (split; [intros X|intros X Y Z f g]; apply funextsec; intro p; apply subtypePath; try apply idpath; intros x; apply setproperty). Defined. (** The left adjoint to the proj_functor *) Definition hat_functor (t : sort) : functor HSET (HSET / sort). Proof. use tpair. - use tpair. + intro A; apply (A,,λ _, t). + intros A B f; apply (tpair _ f), idpath. - abstract (now split; [intros A|intros A B C f g]; apply subtypePath; try (intro x; apply has_homsets_HSET)). Defined. (* (** The object (1,λ _,s) in HSET/sort that can be seen as a sorted variable *) Local Definition constHSET_slice (s : sort) : HSET / sort. Proof. exists (TerminalObject TerminalHSET); simpl. apply (λ x, s). Defined. *) Local Definition constHSET_slice := constHSET_slice sort. (* Definition sorted_option_functor (s : sort) : functor (HSET / sort) (HSET / sort) := constcoprod_functor1 (BinCoproducts_HSET_slice sort) (constHSET_slice s). *) Local Definition sorted_option_functor := sorted_option_functor sort. (** Sorted option functor for lists (also called option in the note) *) Local Definition option_list (xs : list sort) : functor (HSET / sort) (HSET / sort). Proof. (* This should be foldr1 in order to avoid composing with the identity functor in the base case *) use (foldr1 (λ F G, F ∙ G) (functor_identity _) (map sorted_option_functor xs)). Defined. (** Define a functor F^(l,t)(X) := proj_functor(t) ∘ X ∘ option_functor(l) if l is nonempty and F^(l,t)(X) := proj_functor(t) ∘ X otherwise *) Definition exp_functor (lt : list sort × sort) : functor [HSET_over_sort,HSET_over_sort] [HSET_over_sort,HSET]. Proof. induction lt as [l t]. (* use list_ind to do a case on whether l is empty or not *) use (list_ind _ _ _ l); clear l. - exact (post_comp_functor (proj_functor t)). - intros s l _. eapply functor_composite. + exact (pre_comp_functor (option_list (cons s l))). + exact (post_comp_functor (proj_functor t)). Defined. (** This defines F^lts where lts is a list of (l,t). Outputs a product of functors if the list is nonempty and otherwise the constant functor. *) Local Definition exp_functor_list (xs : list (list sort × sort)) : functor [HSET_over_sort,HSET_over_sort] [HSET_over_sort,HSET]. Proof. (* If the list is empty we output the constant functor *) set (T := constant_functor [HSET_over_sort,HSET_over_sort] [HSET_over_sort,HSET] (constant_functor HSET_over_sort HSET TerminalHSET)). (* TODO: Maybe use indexed finite products instead of a fold? *) set (XS := map exp_functor xs). (* This should be foldr1 in order to avoid composing with the constant functor in the base case *) use (foldr1 (λ F G, BinProduct_of_functors _ F G) T XS). apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Definition hat_exp_functor_list (xst : list (list sort × sort) × sort) : functor [HSET_over_sort,HSET_over_sort] [HSET_over_sort,HSET_over_sort] := exp_functor_list (pr1 xst) ∙ post_comp_functor (hat_functor (pr2 xst)). (** The function from multisorted signatures to functors *) Definition MultiSortedSigToFunctor (M : MultiSortedSig) : functor [HSET_over_sort,HSET_over_sort] [HSET_over_sort,HSET_over_sort]. Proof. use (coproduct_of_functors (ops M)). + apply Coproducts_functor_precat, Coproducts_slice_precat, CoproductsHSET, setproperty. + intros op. exact (hat_exp_functor_list (arity M op)). Defined. End functor. (** * Construction of the strength for the endofunctor on [HSET/sort,HSET/sort] derived from a multisorted signature *) Section strength. (* The DL for sorted_option_functor *) Local Definition DL_sorted_option_functor (s : sort) : DistributiveLaw _ (sorted_option_functor s) := genoption_DistributiveLaw _ (constHSET_slice s)(BinCoproducts_HSET_slice sort). (* The DL for option_list *) Local Definition DL_option_list (xs : list sort) : DistributiveLaw _ (option_list xs). Proof. induction xs as [[|n] xs]. + induction xs. apply DL_id. + induction n as [|n IH]. * induction xs as [m []]. apply DL_sorted_option_functor. * induction xs as [m [k xs]]. apply (DL_comp (DL_sorted_option_functor m) (IH (k,,xs))). Defined. (* The signature for exp_functor *) Local Definition Sig_exp_functor (lt : list sort × sort) : Signature HSET_over_sort HSET HSET_over_sort. Proof. exists (exp_functor lt). induction lt as [l t]. induction l as [[|n] xs]. + induction xs. exact (pr2 (Gθ_Signature (IdSignature _ _) (proj_functor t))). + induction n as [|n IH]. * induction xs as [m []]. set (Sig_option_list := θ_from_δ_Signature (DL_option_list (cons m (0,,tt)))). exact (pr2 (Gθ_Signature Sig_option_list (proj_functor t))). * induction xs as [m xs]. set (Sig_option_list := θ_from_δ_Signature (DL_option_list (cons m (S n,,xs)))). exact (pr2 (Gθ_Signature Sig_option_list (proj_functor t))). Defined. Local Lemma functor_in_Sig_exp_functor_ok (lt : list sort × sort) : Signature_Functor (Sig_exp_functor lt) = exp_functor lt. Proof. apply idpath. Qed. (* The signature for exp_functor_list *) Local Definition Sig_exp_functor_list (xs : list (list sort × sort)) : Signature HSET_over_sort HSET HSET_over_sort. Proof. exists (exp_functor_list xs). induction xs as [[|n] xs]. - induction xs. exact (pr2 (ConstConstSignature HSET_over_sort HSET HSET_over_sort TerminalHSET)). - induction n as [|n IH]. + induction xs as [m []]. exact (pr2 (Sig_exp_functor m)). + induction xs as [m [k xs]]. exact (pr2 (BinProduct_of_Signatures _ (Sig_exp_functor _) (tpair _ _ (IH (k,,xs))))). Defined. Local Lemma functor_in_Sig_exp_functor_list_ok (xs : list (list sort × sort)) : Signature_Functor (Sig_exp_functor_list xs) = exp_functor_list xs. Proof. apply idpath. Qed. (* the signature for hat_exp_functor_list *) Local Definition Sig_hat_exp_functor_list (xst : list (list sort × sort) × sort) : Signature HSET_over_sort HSET_over_sort HSET_over_sort. Proof. apply (Gθ_Signature (Sig_exp_functor_list (pr1 xst)) (hat_functor (pr2 xst))). Defined. Local Lemma functor_in_Sig_hat_exp_functor_list_ok (xst : list (list sort × sort) × sort) : Signature_Functor (Sig_hat_exp_functor_list xst) = hat_exp_functor_list xst. Proof. apply idpath. Qed. (* The signature for MultiSortedSigToFunctor *) Definition MultiSortedSigToSignature (M : MultiSortedSig) : Signature HSET_over_sort HSET_over_sort HSET_over_sort. Proof. set (Hyps := λ (op : ops M), Sig_hat_exp_functor_list (arity M op)). use (Sum_of_Signatures (ops M) _ Hyps). apply Coproducts_slice_precat, CoproductsHSET, setproperty. Defined. Local Lemma functor_in_MultiSortedSigToSignature_ok (M : MultiSortedSig) : Signature_Functor (MultiSortedSigToSignature M) = MultiSortedSigToFunctor M. Proof. apply idpath. Qed. End strength. (** * Proof that the functor obtained from a multisorted signature is omega-cocontinuous *) Section omega_cocont. (** The proj functor is naturally isomorphic to the following functor which is a left adjoint: *) Local Definition proj_functor' (s : sort) : functor (HSET / sort) HSET := functor_composite (constprod_functor1 (BinProducts_HSET_slice sort) (constHSET_slice s)) (slicecat_to_cat HSET sort). Local Lemma nat_trans_proj_functor (s : sort) : nat_trans (proj_functor' s) (proj_functor s). Proof. use make_nat_trans. - simpl; intros x H. exists (pr2 (pr1 H)). apply (!pr2 H). - intros x y f. apply funextsec; intro w. apply subtypePath; try apply idpath. intro z; apply setproperty. Defined. Local Lemma is_z_iso_nat_trans_proj_functor (s : sort) : @is_z_isomorphism [HSET/sort,HSET] _ _ (nat_trans_proj_functor s). Proof. use tpair. + use make_nat_trans. - simpl; intros x xy. exists (tt,,pr1 xy). apply (!pr2 xy). - abstract (intros X Y f; apply funextsec; intros x; apply subtypePath; try apply idpath; intros w; apply setproperty). + abstract (split; [ apply subtypePath; [intros x; apply isaprop_is_nat_trans, has_homsets_HSET|]; apply funextsec; intro x; apply funextsec; intro y; cbn; now rewrite pathsinv0inv0; induction y as [y' y3]; induction y' as [y'' y2]; induction y'' | apply (nat_trans_eq has_homsets_HSET); simpl; intros x; apply funextsec; intros z; simpl in *; now apply subtypePath; try apply idpath; intros w; apply setproperty]). Defined. Local Lemma is_left_adjoint_proj_functor' (s : sort) : is_left_adjoint (proj_functor' s). Proof. use is_left_adjoint_functor_composite. - apply Exponentials_HSET_slice. - apply is_left_adjoint_slicecat_to_cat_HSET. Defined. Local Lemma is_left_adjoint_proj_functor (s : sort) : is_left_adjoint (proj_functor s). Proof. apply (is_left_adjoint_closed_under_iso _ _ (_,,is_z_iso_nat_trans_proj_functor s)). apply is_left_adjoint_proj_functor'. Defined. Local Lemma is_omega_cocont_post_comp_proj (s : sort) : is_omega_cocont (@post_composition_functor (HSET/sort) _ _ (proj_functor s)). Proof. apply is_omega_cocont_post_composition_functor. apply is_left_adjoint_proj_functor. Defined. (** The hat_functor is left adjoint to proj_functor *) Local Lemma is_left_adjoint_hat (s : sort) : is_left_adjoint (hat_functor s). Proof. exists (proj_functor s). use make_are_adjoints. + use make_nat_trans. - intros X; simpl; intros x; apply (x,,idpath s). - intros X Y f; simpl; apply funextsec; intro x; cbn. now apply subtypePath; try apply idpath; intros y; apply setproperty. + use make_nat_trans. - intros X; simpl in *. use tpair; simpl. * intros H; apply (pr1 H). * abstract (apply funextsec; intro x; apply (! pr2 x)). - now intros X Y f; apply eq_mor_slicecat. + split. - now intros X; apply eq_mor_slicecat. - intros X; apply funextsec; intro x. now apply subtypePath; try apply idpath; intros x'; apply setproperty. Defined. Local Lemma is_omega_cocont_exp_functor (a : list sort × sort) (H : Colims_of_shape nat_graph HSET_over_sort) : is_omega_cocont (exp_functor a). Proof. induction a as [xs t]. induction xs as [[|n] xs]. - induction xs. apply is_omega_cocont_post_comp_proj. - induction n as [|n]. + induction xs as [m []]. use is_omega_cocont_functor_composite. * apply is_omega_cocont_pre_composition_functor, H. * apply is_omega_cocont_post_comp_proj. + induction xs as [m k]. apply (@is_omega_cocont_functor_composite _ _ _ (ℓ (option_list _))). * apply is_omega_cocont_pre_composition_functor, H. * apply is_omega_cocont_post_comp_proj. Defined. Local Lemma is_omega_cocont_exp_functor_list (xs : list (list sort × sort)) (H : Colims_of_shape nat_graph HSET_over_sort) : is_omega_cocont (exp_functor_list xs). Proof. induction xs as [[|n] xs]. - induction xs. apply is_omega_cocont_constant_functor. - induction n as [|n IHn]. + induction xs as [m []]. apply is_omega_cocont_exp_functor, H. + induction xs as [m [k xs]]. apply is_omega_cocont_BinProduct_of_functors. * apply BinProducts_functor_precat, BinProducts_slice_precat, PullbacksHSET. * apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. * apply is_omega_cocont_exp_functor, H. * apply (IHn (k,,xs)). Defined. Local Lemma is_omega_cocont_post_comp_hat_functor (s : sort) : is_omega_cocont (@post_composition_functor HSET_over_sort _ _ (hat_functor s)). Proof. apply is_omega_cocont_post_composition_functor, is_left_adjoint_hat. Defined. Local Lemma is_omega_cocont_hat_exp_functor_list (xst : list (list sort × sort) × sort) (H : Colims_of_shape nat_graph HSET_over_sort) : is_omega_cocont (hat_exp_functor_list xst). Proof. apply is_omega_cocont_functor_composite. + apply is_omega_cocont_exp_functor_list, H. + apply is_omega_cocont_post_comp_hat_functor. Defined. (** The functor obtained from a multisorted binding signature is omega-cocontinuous *) Lemma is_omega_cocont_MultiSortedSigToFunctor (M : MultiSortedSig) (H : Colims_of_shape nat_graph HSET_over_sort) : is_omega_cocont (MultiSortedSigToFunctor M). Proof. apply is_omega_cocont_coproduct_of_functors. intros op; apply is_omega_cocont_hat_exp_functor_list, H. Defined. Lemma is_omega_cocont_MultiSortedSigToSignature (M : MultiSortedSig) (H : Colims_of_shape nat_graph HSET_over_sort) : is_omega_cocont (MultiSortedSigToSignature M). Proof. apply is_omega_cocont_MultiSortedSigToFunctor, H. Defined. End omega_cocont. End MBindingSig. UniMath-20231010/UniMath/SubstitutionSystems/MultiSortedEmbeddingIndCoindHSET.v000066400000000000000000000056111451125700300273200ustar00rootroot00000000000000(** the embedding of generated inductive syntax into coinductive syntax is a morphism of Sigma-monoids this is only exemplified for [HSET] as base category author: Ralph Matthes 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.Cochains. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.SubstitutionSystems.SigmaMonoids. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.ContinuitySignature.InstantiateHSET. Require UniMath.SubstitutionSystems.MultiSortedMonadConstruction_actegorical. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_actegorical. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_coind_actegorical. Local Open Scope cat. Section A. Context (sort : UU) (Hsort : isofhlevel 3 sort) (*(Hsort_set : isaset sort)*) (sig : MultiSortedSig sort). (* Let Hsort := hlevelntosn 2 _ Hsort_set. *) Let sortToHSET : category := [path_pregroupoid sort Hsort, HSET]. Let θHSET := MultiSortedMonadConstruction_actegorical.MultiSortedSigToStrength' sort Hsort SET TerminalHSET BinProductsHSET BinCoproductsHSET CoproductsHSET sig. Local Definition Initialσind := InitialSigmaMonoidOfMultiSortedSig_CAT sort Hsort HSET TerminalHSET InitialHSET BinProductsHSET BinCoproductsHSET ProductsHSET CoproductsHSET (expSortToHSET1 sort Hsort) (ColimsHSET_of_shape nat_graph) sig. Local Definition σind : SigmaMonoid θHSET := pr1 Initialσind. Local Definition Tind : [sortToHSET, sortToHSET] := pr1 σind. Local Definition σcoind := coindSigmaMonoidOfMultiSortedSig_CAT sort Hsort HSET TerminalHSET BinProductsHSET BinCoproductsHSET CoproductsHSET (LimsHSET_of_shape conat_graph) I_coproduct_distribute_over_omega_limits_HSET sig is_univalent_HSET. Local Definition Tcoind : [sortToHSET, sortToHSET] := pr1 σcoind. Local Definition ind_into_coind : SigmaMonoid θHSET ⟦σind, σcoind⟧ := InitialArrow Initialσind σcoind. (* TODO: spell out the constituents *) End A. UniMath-20231010/UniMath/SubstitutionSystems/MultiSortedMonadConstruction.v000066400000000000000000000072121451125700300270160ustar00rootroot00000000000000(** This file contains the final step in the formalization of multisorted binding signatures: - Construction of a monad on Set/sort from a multisorted signature ([MultiSortedSigToMonad]) Written by: Anders Mörtberg, 2016. The formalization follows a note written by Benedikt Ahrens and Ralph Matthes, and is also inspired by discussions with them and Vladimir Voevodsky. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Local Open Scope cat. Local Notation "C / X" := (slicecat_ob C X). Local Notation "C / X" := (slice_precat_data C X). Local Notation "C / X" := (slice_cat C X). (** * Definition of multisorted binding signatures *) Section MBindingSig. Context (sort : hSet). Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. (** * Construction of a monad from a multisorted signature *) Section monad. Let Id_H := Id_H (HSET / sort) (BinCoproducts_HSET_slice sort). (* ** Construction of initial algebra for a signature with strength on Set / sort *) Definition SignatureInitialAlgebraSetSort (H : Signature HSET_over_sort HSET_over_sort HSET_over_sort) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply Initial_functor_precat, Initial_slice_precat, InitialHSET. - apply (is_omega_cocont_Id_H), Hs. - apply ColimsFunctorCategory_of_shape, slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Let HSS := @hss_category _ (BinCoproducts_HSET_slice sort). (* ** Multisorted signature to a HSS *) Definition MultiSortedSigToHSS (sig : MultiSortedSig sort) : HSS (MultiSortedSigToSignature sort sig). Proof. apply SignatureToHSS. + apply Initial_slice_precat, InitialHSET. + apply slice_precat_colims_of_shape, ColimsHSET_of_shape. + apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. (* The above HSS is initial *) Definition MultiSortedSigToHSSisInitial (sig : MultiSortedSig sort) : isInitial _ (MultiSortedSigToHSS sig). Proof. now unfold MultiSortedSigToHSS, SignatureToHSS; destruct InitialHSS. Qed. (** ** Function from multisorted binding signatures to monads *) Definition MultiSortedSigToMonad (sig : MultiSortedSig sort) : Monad (HSET / sort). Proof. use Monad_from_hss. - apply BinCoproducts_HSET_slice. - apply (MultiSortedSigToSignature sort sig). - apply MultiSortedSigToHSS. Defined. End monad. End MBindingSig. UniMath-20231010/UniMath/SubstitutionSystems/MultiSortedMonadConstruction_actegorical.v000066400000000000000000000314071451125700300313560ustar00rootroot00000000000000(** this file is a follow-up of [MultisortedMonadConstruction_alt], where the semantic signatures [Signature] are replaced by functors with tensorial strength and HSS by MHSS based on the lax lineator constructed in [Multisorted_actegories] and transferred (through weak equivalence) to the strength notion of monoidal heterogeneous substitution systems (MHSS), a MHSS is constructed and a monad obtained through it author: Ralph Matthes, 2023 notice: this file does not correspond to [MultisortedMonadConstruction] but to [MultisortedMonadConstruction_alt], even though this is not indicated in the name *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. (** for the additions in 2023 *) Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonadsAsMonoidsElementary. Require Import UniMath.SubstitutionSystems.EquivalenceLaxLineatorsHomogeneousCase. Require UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.MultiSorted_actegorical. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Require Import UniMath.SubstitutionSystems.ConstructionOfGHSS. Require UniMath.SubstitutionSystems.BindingSigToMonad_actegorical. Require Import UniMath.SubstitutionSystems.SigmaMonoids. Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor. (** for the instantiation to [HSET] *) Require Import UniMath.Bicategories.PseudoFunctors.Examples.CurryingInBicatOfCats. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.Equivalences.Core. Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses. Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section MBindingSig. (* Interestingly we only need that [sort] is a 1-type *) Context (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Context (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** Define the category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. Let BPCsortToC : BinProducts sortToC := BinProducts_functor_precat _ C BP. Let BPC1 : BinProducts [sortToC,sortToC] := BinProducts_functor_precat sortToC sortToC BPCsortToC. (* Assumptions needed to prove ω-cocontinuity of the functor *) Context (expSortToC1 : Exponentials BPC1) (** this requires exponentials in a higher space than before for [MultiSortedSigToFunctor] *) (HC : Colims_of_shape nat_graph C). (* The [expSortToC1] assumption is fulfilled for C = Set, to be seen in the instantiation. *) (** * Construction of a monad from a multisorted signature *) Section monad. Local Definition sortToC1 := [sortToC, sortToC]. Local Definition sortToC2 := [sortToC1, sortToC1]. Let BCsortToC1 : BinCoproducts sortToC1 := BinCoproducts_functor_precat _ _ BCsortToC. Let ICsortToC1 : Initial sortToC1 := Initial_functor_precat _ _ (Initial_functor_precat _ _ IC). Local Definition HCsortToC : Colims_of_shape nat_graph sortToC. Proof. apply ColimsFunctorCategory_of_shape, HC. Defined. Local Definition HCsortToC1 : Colims_of_shape nat_graph sortToC1. Proof. apply ColimsFunctorCategory_of_shape, HCsortToC. Defined. Local Definition MultiSortedSigToFunctor' : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor' sort Hsort C TC BP BC CC. Local Definition is_omega_cocont_MultiSortedSigToFunctor' : ∏ M : MultiSortedSig sort, is_omega_cocont (MultiSortedSigToFunctor' M) := is_omega_cocont_MultiSortedSigToFunctor' sort Hsort C TC BP BC PC CC expSortToC1 HC. Local Definition MultiSortedSigToStrength' : ∏ M : MultiSortedSig sort, MultiSorted_actegorical.pointedstrengthfromselfaction_CAT sort Hsort C (MultiSortedSigToFunctor' M) := MultiSortedSigToStrength' sort Hsort C TC BP BC CC. Let Id_H : sortToC2 → sortToC2 := LiftingInitial_alt.Id_H sortToC BCsortToC. (** Construction of initial algebra for the omega-cocontinuous signature functor with lax lineator *) Definition DatatypeOfMultisortedBindingSig_CAT (sig : MultiSortedSig sort) : Initial (FunctorAlg (Id_H (MultiSortedSigToFunctor' sig))). Proof. use colimAlgInitial. - exact ICsortToC1. - apply (LiftingInitial_alt.is_omega_cocont_Id_H _ _ _ (is_omega_cocont_MultiSortedSigToFunctor' sig)). - apply HCsortToC1. Defined. (** the associated MHSS *) Definition MHSSOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : mhss (monendocat_monoidal sortToC) (MultiSortedSigToFunctor' sig) (MultiSortedSigToStrength' sig). Proof. use (initial_alg_to_mhss (MultiSortedSigToStrength' sig) BCsortToC1). - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT. - exact ICsortToC1. - apply HCsortToC1. - apply (is_omega_cocont_MultiSortedSigToFunctor' sig). - intro F. apply Initial_functor_precat. - intro F. apply (is_omega_cocont_pre_composition_functor F HCsortToC). Defined. (** the associated initial Sigma-monoid *) Definition InitialSigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : Initial (SigmaMonoid (MultiSortedSigToStrength' sig)). Proof. use (SigmaMonoidFromInitialAlgebraInitial (MultiSortedSigToStrength' sig) BCsortToC1). - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT. - exact ICsortToC1. - apply HCsortToC1. - apply (is_omega_cocont_MultiSortedSigToFunctor' sig). - intro F. apply Initial_functor_precat. - intro F. apply (is_omega_cocont_pre_composition_functor F HCsortToC). Defined. (** the associated Sigma-monoid - defined separately *) Definition SigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : SigmaMonoid (MultiSortedSigToStrength' sig). Proof. apply mhss_to_sigma_monoid. exact (MHSSOfMultiSortedSig_CAT sig). Defined. (* currently obsolete because this was only for the original definition with [MultiSortedSigToFunctor] (** the characteristic equation of the Sigma monoid is even fulfilled w.r.t. to the original lax lineator, not only the one obtained through weak equivalence *) Section CharEq. Context (sig : MultiSortedSig sort). Let σ := SigmaMonoidOfMultiSortedSig_CAT sig. Let st' : sortToC1 ⟦ (SigmaMonoid_carrier _ σ) ⊗_{monendocat_monoidal sortToC : bifunctor _ _ _} (pr1 (MultiSortedSigToFunctor sig) (SigmaMonoid_carrier _ σ)), pr1 (MultiSortedSigToFunctor sig) ((SigmaMonoid_carrier _ σ) ⊗_{monendocat_monoidal sortToC} (SigmaMonoid_carrier _ σ)) ⟧ := pr1 (MultiSortedSigToStrengthCAT sort Hsort C TC BP BC CC sig) (SigmaMonoid_carrier _ σ ,, SigmaMonoid_η _ σ) (SigmaMonoid_carrier _ σ). Lemma SigmaMonoidOfMultiSortedSig_CAT_char_eq_ok : SigmaMonoid_characteristic_equation (SigmaMonoid_carrier _ σ) (SigmaMonoid_η _ σ) (SigmaMonoid_μ _ σ) (SigmaMonoid_τ _ σ) st'. Proof. Admitted. (* the proof depends on [lax_lineators_from_reindexed_precomp_CAT_and_reindexed_self_action_agree] to be defined! *) (* (** beginning of proof that depends on that currently deactivated definition *) assert (Hyp := SigmaMonoid_is_compatible (MultiSortedSigToStrengthFromSelfCAT sig) σ). hnf. hnf in Hyp. etrans. 2: { exact Hyp. } clear Hyp. do 2 apply cancel_postcomposition. apply idpath. (* no need for extensional reasoning: apply (nat_trans_eq sortToC). intro F. apply (nat_trans_eq C). intro s. simpl. apply idpath. *) Qed. (** end of proof that depends on that currently deactivated definition *) *) End CharEq. *) (** the associated monad *) Definition MonadOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : Monad sortToC. Proof. use monoid_to_monad_CAT. use SigmaMonoid_to_monoid. - exact (MultiSortedSigToFunctor' sig). - exact (MultiSortedSigToStrength' sig). - exact (SigmaMonoidOfMultiSortedSig_CAT sig). Defined. End monad. End MBindingSig. Section InstanceHSET. Context (sort : UU) (Hsort : isofhlevel 3 sort). Let sortToHSET : category := [path_pregroupoid sort Hsort, HSET]. Let BPCsortToHSET : BinProducts sortToHSET := BinProducts_functor_precat _ HSET BinProductsHSET. Let BPC1 : BinProducts [sortToHSET,sortToHSET] := BinProducts_functor_precat sortToHSET sortToHSET BPCsortToHSET. Definition expSortToHSET1 : Exponentials BPC1. Proof. set (aux := category_binproduct sortToHSET (path_pregroupoid sort Hsort)). set (BPaux' := BinProducts_functor_precat aux _ BinProductsHSET). assert (Hyp : Exponentials BPaux'). { apply Exponentials_functor_HSET. } transparent assert (HypAdj : (equivalence_of_cats [sortToHSET, sortToHSET] [aux, SET])). { apply currying_hom_equivalence. } use (exponentials_through_adj_equivalence_univalent_cats _ _ Hyp). 2: { apply is_univalent_functor_category. apply is_univalent_HSET. } 2: { do 2 apply is_univalent_functor_category. apply is_univalent_HSET. } transparent assert (HypAdj' : (adj_equivalence_of_cats (left_functor HypAdj))). { apply adjointification. } use tpair. 2: { apply (adj_equivalence_of_cats_inv HypAdj'). } Defined. Definition MultiSortedSigToMonadHSET_viaCAT : MultiSortedSig sort → Monad (sortToHSET). Proof. intros sig; simple refine (MonadOfMultiSortedSig_CAT sort Hsort HSET _ _ _ _ _ _ _ _ sig). - apply TerminalHSET. - apply InitialHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply ProductsHSET. - apply CoproductsHSET. - change (Exponentials BPC1). apply expSortToHSET1. - apply ColimsHSET_of_shape. Defined. End InstanceHSET. UniMath-20231010/UniMath/SubstitutionSystems/MultiSortedMonadConstruction_alt.v000066400000000000000000000143171451125700300276620ustar00rootroot00000000000000(** This file contains the final steps of the formalization of multisorted binding signatures: - Construction of a monad on C^sort from a multisorted signature ([MultiSortedSigToMonad]) - Instantiation of MultiSortedSigToMonad for C = Set ([MultiSortedSigToMonadSet]) Written by: Anders Mörtberg, 2021. The formalization is an adaptation of Multisorted.v *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Local Open Scope cat. Section MBindingSig. (* Interestingly we only need that [sort] is a 1-type *) Variables (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Variables (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** Define the category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. (* Assumptions needed to prove ω-cocontinuity of the functor *) Variables (expSortToCC : Exponentials BPC) (HC : Colims_of_shape nat_graph C). (* The expSortToCC assumption says that [sortToC,C] has exponentials. It could be reduced to exponentials in C, but we only have the case for C = Set formalized in CategoryTheory.categories.HSET.Structures.Exponentials_functor_HSET *) (** * Construction of a monad from a multisorted signature *) Section monad. Let Id_H := Id_H sortToC BCsortToC. (* ** Construction of initial algebra for a signature with strength on C^sort *) Definition SignatureInitialAlgebra (H : Signature sortToC sortToC sortToC) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply Initial_functor_precat, Initial_functor_precat, IC. - apply (is_omega_cocont_Id_H), Hs. - apply ColimsFunctorCategory_of_shape, ColimsFunctorCategory_of_shape, HC. Defined. Let HSS := @hss_category _ BCsortToC. (* ** Multisorted signature to a HSS *) Definition MultiSortedSigToHSS (sig : MultiSortedSig sort) : HSS (MultiSortedSigToSignature sort Hsort C TC BP BC CC sig). Proof. apply SignatureToHSS. + apply Initial_functor_precat, IC. + apply ColimsFunctorCategory_of_shape, HC. + apply is_omega_cocont_MultiSortedSigToSignature; try assumption. Defined. (* The above HSS is initial *) Definition MultiSortedSigToHSSisInitial (sig : MultiSortedSig sort) : isInitial _ (MultiSortedSigToHSS sig). Proof. now unfold MultiSortedSigToHSS, SignatureToHSS; destruct InitialHSS. Qed. (** ** Function from multisorted binding signatures to monads *) Definition MultiSortedSigToMonad (sig : MultiSortedSig sort) : Monad sortToC. Proof. use Monad_from_hss. - apply BCsortToC. - apply (MultiSortedSigToSignature sort Hsort C TC BP BC CC sig). - apply MultiSortedSigToHSS. Defined. End monad. End MBindingSig. Section MBindingSigMonadHSET. (* Assume a set of sorts *) Context (sort : hSet) (Hsort : isofhlevel 3 sort). Let sortToSet : category := [path_pregroupoid sort Hsort, HSET]. Definition projSortToSet : sort → functor sortToSet HSET := projSortToC sort Hsort HSET. Definition hat_functorSet : sort → HSET ⟶ sortToSet := hat_functor sort (isofhlevelssnset 1 _ (setproperty sort)) HSET CoproductsHSET. Definition sorted_option_functorSet : sort → sortToSet ⟶ sortToSet := sorted_option_functor _ (isofhlevelssnset 1 _ (setproperty sort)) HSET TerminalHSET BinCoproductsHSET CoproductsHSET. Definition MultiSortedSigToSignatureSet : MultiSortedSig sort → Signature sortToSet sortToSet sortToSet. Proof. use MultiSortedSigToSignature. - apply TerminalHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply CoproductsHSET. Defined. Definition MultiSortedSigToMonadSet (ms : MultiSortedSig sort) : Monad sortToSet. Proof. use MultiSortedSigToMonad. - apply TerminalHSET. - apply InitialHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply ProductsHSET. - apply CoproductsHSET. - apply Exponentials_functor_HSET. - apply ColimsHSET_of_shape. - apply ms. Defined. End MBindingSigMonadHSET. UniMath-20231010/UniMath/SubstitutionSystems/MultiSortedMonadConstruction_coind_actegorical.v000066400000000000000000000435341451125700300325360ustar00rootroot00000000000000(** the coinductive analogue of [MultiSortedMonadConstruction_actegorical] author: Ralph Matthes 2023 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.All. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.HSET.Univalence. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. (** for the additions in 2023 *) Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.FunctorCoalgebras. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.Chains.Cochains. Require Import UniMath.CategoryTheory.Chains.CoAdamek. Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonadsAsMonoidsElementary. Require Import UniMath.SubstitutionSystems.EquivalenceLaxLineatorsHomogeneousCase. Require UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.MultiSorted_actegorical. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Require Import UniMath.SubstitutionSystems.ConstructionOfGHSS. Require UniMath.SubstitutionSystems.BindingSigToMonad_actegorical. Require Import UniMath.SubstitutionSystems.SigmaMonoids. Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor. Require Import UniMath.SubstitutionSystems.ContinuitySignature.MultiSortedSignatureFunctorEquivalence. Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts. Require Import UniMath.SubstitutionSystems.ContinuitySignature.InstantiateHSET. Local Open Scope cat. Import BifunctorNotations. Import MonoidalNotations. Section ToBeMoved. (* Definition limArrowOfInverses {C : category} {g : graph} {d : diagram g C} (CC : LimCone d) (c : C) (cc : cone d c) : (∏ v : vertex g, is_z_isomorphism (pr1 cc v)) -> is_z_isomorphism (limArrow CC c cc). Proof. intro iv. apply isLim_is_z_iso. intros x x_con. use tpair. - unfold LimCone in CC. use tpair. + refine (pr11 (pr2 CC x x_con) · _). Search lim. Search lim. use make_is_z_isomorphism. - unfold cone in cc. Check pr1 cc. Search lim. *) Lemma isaprop_isCoproduct {C : category} {I : UU} {i : I -> C} {x : C} (j : ∏ i0 : I, C ⟦ i i0, x ⟧) : isaprop (isCoproduct I C i x j). Proof. repeat (apply impred; intro). apply isapropiscontr. Qed. Definition z_iso_from_coproduct_to_coproduct {C : category} {I : UU} {ind : I -> C} (CC CC' : Coproduct I C ind) : z_iso (pr11 CC) (pr11 CC'). Proof. use make_z_iso. - apply CoproductArrow, CoproductIn. - apply CoproductArrow, CoproductIn. - split. + etrans. 1: apply postcompWithCoproductArrow. apply pathsinv0, Coproduct_endo_is_identity. intro. etrans. 1: apply CoproductInCommutes. apply CoproductInCommutes. + etrans. 1: apply postcompWithCoproductArrow. apply pathsinv0, Coproduct_endo_is_identity. intro. etrans. 1: apply CoproductInCommutes. apply CoproductInCommutes. Defined. Definition eq_Coproduct {C : category} {I : UU} {ind : I -> C} (C1 C2 : Coproduct I C ind) (q : pr11 C1 = pr11 C2) (e : ∏ i : I, CoproductIn I C C2 i = CoproductIn I C C1 i · pr1 (Univalence.idtoiso q)) : C1 = C2. Proof. use subtypePath. { intro ; apply isaprop_isCoproduct. } use total2_paths_f. - exact q. - rewrite transportf_sec_constant. apply funextsec ; intro i. rewrite <- Univalence.idtoiso_postcompose. exact (! e i). Defined. Lemma isaprop_Coproducts {C : category} (Cuniv : Univalence.is_univalent C) (I : UU) : isaprop (Coproducts I C). Proof. use invproofirrelevance. intros C1 C2. apply funextsec ; intro ind. use eq_Coproduct. - refine (Univalence.isotoid _ Cuniv _). apply z_iso_from_coproduct_to_coproduct. - intro. rewrite Univalence.idtoiso_isotoid ; cbn. apply pathsinv0, CoproductInCommutes. Qed. Lemma ω_limits_distribute_over_I_coproducts_independent_of_product {C : category} {I : SET} (Cuniv : Univalence.is_univalent C) {l : Lims_of_shape conat_graph C} (p q : Coproducts (pr1 I) C) : ω_limits_distribute_over_I_coproducts C I l p -> ω_limits_distribute_over_I_coproducts C I l q. Proof. intro distr. transparent assert (pq : (p = q)). { apply isaprop_Coproducts. exact Cuniv. } induction pq. exact distr. Qed. Definition BinProduct_of_functors_BinProducts_of_shape {C D : category} (BC : Colims_of_shape two_graph D) (F G : functor C D) : nat_z_iso (BinCoproduct_of_functors C D (BinCoproducts_from_Colims _ BC) F G) (coproduct_of_functors bool C D (Coproducts_from_Colims _ _ BC) (λ x : bool, if x then F else G)). Proof. use make_nat_z_iso. - use make_nat_trans. + intro c. use colimOfArrows. * intro b. induction b ; apply identity. * intros b1 b2 e. apply fromempty. exact e. + intros c1 c2 f. cbn. etrans. 2: apply pathsinv0, precompWithColimOfArrows. etrans. 1: apply postcompWithColimArrow. apply colimArrowUnique. intro b. cbn. etrans. 1: apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c1) (G c1)))). cbn. induction b. * cbn. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c2) (G c2))) _ _ true). } cbn. etrans. 1: apply maponpaths, id_left. apply pathsinv0, id_left. * cbn. etrans. 1: apply assoc'. etrans. 1: { apply maponpaths. apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c2) (G c2))) _ _ false). } cbn. etrans. 1: apply maponpaths, id_left. apply pathsinv0, id_left. - intro c. use tpair. + use colimOfArrows. * intro b. induction b ; apply identity. * intros b1 b2 e. apply fromempty. exact e. + split ; cbn. * etrans. 1: apply postcompWithColimArrow. apply pathsinv0. use colimArrowUnique. intro b. etrans. 1: apply id_right. cbn. etrans. 2: apply assoc. etrans. 2: { apply maponpaths, pathsinv0. apply (colimArrowCommutes (BC (coproducts_diagram bool D (λ i : bool, (if i then F else G) c))) ). } induction b ; refine (_ @ ! id_left _) ; apply pathsinv0, id_left. * etrans. 1: apply postcompWithColimArrow. apply pathsinv0. use colimArrowUnique. intro b. etrans. 1: apply id_right. cbn. etrans. 2: apply assoc. etrans. 2: { apply maponpaths, pathsinv0. apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c) (G c))) ). } induction b ; refine (_ @ ! id_left _) ; apply pathsinv0, id_left. Defined. Definition Colims_from_BinCoproducts {C : category} (CC : BinCoproducts C) : Colims_of_shape two_graph C. Proof. unfold Colims_of_shape. intro d. unfold diagram in d. cbn in d. set (c := CC (pr1 d true) (pr1 d false)). unfold BinCoproduct in c. use make_ColimCocone. - exact (pr11 c). - use tpair. + intro b. induction b. * exact (pr121 c). * exact (pr221 c). + intros b1 b2 e. apply fromempty. exact e. - intros co cc. unfold cocone in cc. use tpair. + exists (pr11 (pr2 c co (pr1 cc true) (pr1 cc false))). intro b. induction b. * exact (pr121 (pr2 c co (pr1 cc true) (pr1 cc false))). * exact (pr221 (pr2 c co (pr1 cc true) (pr1 cc false))). + intro t. transparent assert (ϕ : (∑ fg : C ⟦ pr11 c, co ⟧, pr121 c · fg = pr1 cc true × pr221 c · fg = pr1 cc false)). { use tpair. - exact (pr1 t). - split ; apply (pr2 t). } set (p := pr2 (pr2 c co (pr1 cc true) (pr1 cc false)) ϕ). use total2_paths_f. * apply (base_paths _ _ p). * apply isaprop_is_cocone_mor. Defined. End ToBeMoved. Section Upstream. Context (C : category) (BC : BinCoproducts C). Local Definition Id_H := LiftingInitial_alt.Id_H C BC. Context (L : ∏ coch : cochain [C, C], LimCone coch). Context (distr : ω_limits_distribute_over_I_coproducts [C, C] (bool,, isasetbool) L (Coproducts_from_Colims bool [C, C] (Colims_from_BinCoproducts (BinCoproducts_functor_precat C C BC)))). Definition is_omega_cont_Id_H (H: [C, C] ⟶ [C, C]) : is_omega_cont H -> is_omega_cont (Id_H H). Proof. intro Hc. use is_omega_cont_z_iso. 2: { use z_iso_from_nat_z_iso. use nat_z_iso_inv. transparent assert (BC0 : (Colims_of_shape two_graph [C,C])). { use Colims_from_BinCoproducts. apply BinCoproducts_functor_precat. exact BC. } exact (BinProduct_of_functors_BinProducts_of_shape BC0 (constant_functor [C, C] [C, C] (functor_identity C)) H). } use (coproduct_of_functors_omega_cont [C,C] (bool,,isasetbool)). - exact L. - exact distr. - intro b. induction b. + apply is_omega_cont_constant_functor. + exact Hc. Defined. End Upstream. Section MBindingSig. Context (sort : UU) (* (Hsort_set : isaset sort) *) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Context (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (* Let Hsort := hlevelntosn 2 _ Hsort_set. *) (** Define the category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. (* Assumptions needed to prove ω-continuity of the functor *) Context (HcoC : Lims_of_shape conat_graph C) (* (HCcommuteBP : propcoproducts_commute_binproducts C BP (λ p : hProp, CC p (isasetaprop (pr2 p)))) *) (HCcommuteCC : ∏ I : SET, ω_limits_distribute_over_I_coproducts C I HcoC (CC (pr1 I) (pr2 I))). (** * Construction of a monad from a multisorted signature *) Section monad. Local Definition sortToC1 := [sortToC, sortToC]. Local Definition sortToC2 := [sortToC1, sortToC1]. Let BCsortToC1 : BinCoproducts sortToC1 := BinCoproducts_functor_precat _ _ BCsortToC. (* Let ICsortToC1 : Initial sortToC1 := Initial_functor_precat _ _ (Initial_functor_precat _ _ IC).*) Let TCsortToC1 : Terminal sortToC1 := Terminal_functor_precat _ _ (Terminal_functor_precat _ _ TC). Local Definition HcoCsortToC : Lims_of_shape conat_graph sortToC. Proof. apply LimsFunctorCategory_of_shape, HcoC. Defined. Local Definition HcoCsortToC1 : Lims_of_shape conat_graph sortToC1. Proof. apply LimsFunctorCategory_of_shape, HcoCsortToC. Defined. Local Definition MultiSortedSigToFunctor' : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor' sort Hsort C TC BP BC CC. Local Definition is_omega_cont_MultiSortedSigToFunctor' (M : MultiSortedSig sort) : is_omega_cont (MultiSortedSigToFunctor' M) := is_omega_cont_MultiSortedSigToFunctor' sort Hsort C TC BP BC CC HcoC HCcommuteCC M. Context (sortToC_exp : Exponentials (BinProducts_functor_precat [path_pregroupoid sort Hsort, C] C BP)). Local Definition MultiSortedSigToStrength' : ∏ M : MultiSortedSig sort, MultiSorted_actegorical.pointedstrengthfromselfaction_CAT sort Hsort C (MultiSortedSigToFunctor' M) := MultiSortedSigToStrength' sort Hsort C TC BP BC CC. Let Id_H : sortToC2 → sortToC2 := Id_H sortToC BCsortToC. (** Construction of terminal coalgebra for the omega-continuous signature functor with lax lineator *) Definition coindCodatatypeOfMultisortedBindingSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : Terminal (CoAlg_category (Id_H (MultiSortedSigToFunctor' sig))). Proof. use limCoAlgTerminal. - exact TCsortToC1. - use is_omega_cont_Id_H. + apply HcoCsortToC1. + set (CP' := CoproductsBool BCsortToC). transparent assert (CP'' : (Coproducts bool sortToC)). { use Coproducts_functor_precat. apply CC. apply isasetbool. } transparent assert (CP'_distr : (ω_limits_distribute_over_I_coproducts sortToC (bool,, isasetbool) HcoCsortToC CP'')). { use functor_category_ω_limits_distribute_over_I_coproducts. apply HCcommuteCC. } set (q := functor_category_ω_limits_distribute_over_I_coproducts sortToC (bool,, isasetbool) HcoCsortToC CP'' CP'_distr sortToC). use (ω_limits_distribute_over_I_coproducts_independent_of_product _ _ _ q). do 2 apply is_univalent_functor_category. apply Cuniv. + exact (is_omega_cont_MultiSortedSigToFunctor' sig). - apply HcoCsortToC1. Defined. Definition coindMHSSOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : mhss (monendocat_monoidal sortToC) (MultiSortedSigToFunctor' sig) (MultiSortedSigToStrength' sig). Proof. use (final_coalg_to_mhss (MultiSortedSigToStrength' sig) BCsortToC1). - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT. - exact (pr1 (coindCodatatypeOfMultisortedBindingSig_CAT sig Cuniv)). - exact (pr2 (coindCodatatypeOfMultisortedBindingSig_CAT sig Cuniv)). Defined. (** the associated Sigma-monoid *) Definition coindSigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : SigmaMonoid (MultiSortedSigToStrength' sig). Proof. apply mhss_to_sigma_monoid. exact (coindMHSSOfMultiSortedSig_CAT sig Cuniv). Defined. (** the associated monad *) Definition coindMonadOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : Monad sortToC. Proof. use monoid_to_monad_CAT. use SigmaMonoid_to_monoid. - exact (MultiSortedSigToFunctor' sig). - exact (MultiSortedSigToStrength' sig). - exact (coindSigmaMonoidOfMultiSortedSig_CAT sig Cuniv). Defined. End monad. End MBindingSig. Section InstanceHSET. Context (sort : UU) (Hsort : isofhlevel 3 sort) (*(Hsort_set : isaset sort)*). (* Let Hsort := hlevelntosn 2 _ Hsort_set.*) Let sortToHSET : category := [path_pregroupoid sort Hsort, HSET]. Definition coindMultiSortedSigToMonadHSET_viaCAT : MultiSortedSig sort → Monad (sortToHSET). Proof. intros sig; simple refine (coindMonadOfMultiSortedSig_CAT sort Hsort HSET _ _ _ _ _ _ sig _). - apply TerminalHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply CoproductsHSET. - apply LimsHSET_of_shape. - apply I_coproduct_distribute_over_omega_limits_HSET. - apply is_univalent_HSET. Defined. End InstanceHSET. UniMath-20231010/UniMath/SubstitutionSystems/MultiSorted_actegorical.v000066400000000000000000000360001451125700300257560ustar00rootroot00000000000000(** this file is a follow-up of [Multisorted_alt], where the semantic signatures [Signature] are replaced by functors with tensorial strength the concept of binding signatures is inherited, as well as the reasoning about omega-cocontinuity the strength notion is based on lax lineators where endofunctors act on possibly non-endofunctors, but the signature functor generated from a multi-sorted binding signature falls into the special case of endofunctors, and the lineator notion can be transferred (through weak equivalence) to the strength notion of monoidal heterogeneous substitution systems (MHSS) accordingly a MHSS is constructed and a monad obtained through it, cf. [MultiSortedMonadConstruction_actegorical] author: Ralph Matthes, 2023 notice: this file does not correspond to [Multisorted] but to [Multisorted_alt], even though this is not indicated in the name *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. (** for the additions in 2023 *) Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.Actegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories. Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms. Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects. Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary. Require Import UniMath.CategoryTheory.Actegories.Examples.SelfActionInCATElementary. (* Require Import UniMath.SubstitutionSystems.EquivalenceSignaturesWithActegoryMorphisms. *) Require Import UniMath.SubstitutionSystems.EquivalenceLaxLineatorsHomogeneousCase. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require UniMath.SubstitutionSystems.BindingSigToMonad_actegorical. Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor. Local Open Scope cat. (* These should be global *) Arguments Signature_Functor {_ _ _} _. Arguments BinProduct_of_functors {_ _} _ _ _. Section MBindingSig. (** Preamble copied from [Multisorted_alt] *) (* Interestingly we only need that [sort] is a 1-type *) Context (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Context (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** Define the discrete category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. (* Assumptions needed to prove ω-cocontinuity of the functor *) Context (expSortToCC : Exponentials BPC) (HC : Colims_of_shape nat_graph C). (* The expSortToCC assumption says that [sortToC,C] has exponentials. It could be reduced to exponentials in C, but we only have the case for C = Set formalized in CategoryTheory.categories.HSET.Structures.Exponentials_functor_HSET *) (** end of Preamble copied from [Multisorted_alt] *) Local Definition sortToC1 := [sortToC, sortToC]. Local Definition sortToC2 := [sortToC1, sortToC1]. Local Definition sortToCC := [sortToC, C]. Local Definition sortToC1C := [sortToC1, sortToCC]. Let ops : MultiSortedSig sort → hSet := ops sort. Let arity : ∏ M : MultiSortedSig sort, MultiSorted_alt.ops sort M → list (list sort × sort) × sort := arity sort. Local Definition sorted_option_functor := sorted_option_functor sort Hsort C TC BC CC. Local Definition projSortToC : sort -> sortToCC := projSortToC sort Hsort C. Local Definition option_list : list sort → sortToC1 := option_list sort Hsort C TC BC CC. Local Definition exp_functor : list sort × sort -> sortToC1C := exp_functor sort Hsort C TC BC CC. Local Definition exp_functor_list : list (list sort × sort) -> sortToC1C := exp_functor_list sort Hsort C TC BP BC CC. Local Definition hat_exp_functor_list : list (list sort × sort) × sort -> sortToC2 := hat_exp_functor_list sort Hsort C TC BP BC CC. Local Definition MultiSortedSigToFunctor : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor sort Hsort C TC BP BC CC. Local Definition CoproductsMultiSortedSig : ∏ M : MultiSortedSig sort, Coproducts (ops M) sortToC1 := CoproductsMultiSortedSig sort Hsort C CC. (** * Construction of the lineator for the endofunctor on [C^sort,C^sort] derived from a multisorted signature *) Section strength_through_actegories. Local Definition endoCAT : category := EquivalenceLaxLineatorsHomogeneousCase.endoCAT sortToC. Local Definition Mon_endo_CAT : monoidal endoCAT := EquivalenceLaxLineatorsHomogeneousCase.Mon_endo_CAT sortToC. Local Definition ptdendo_CAT : category := EquivalenceLaxLineatorsHomogeneousCase.ptdendo_CAT sortToC. Local Definition Mon_ptdendo_CAT : monoidal ptdendo_CAT := monoidal_pointed_objects Mon_endo_CAT. Local Definition ActPtd_CAT (E : category) : actegory Mon_ptdendo_CAT [sortToC,E] := EquivalenceLaxLineatorsHomogeneousCase.actegoryPtdEndosOnFunctors_CAT sortToC E. Local Definition ActPtd_CAT_Endo := ActPtd_CAT sortToC. Local Definition ActPtd_CAT_FromSelf : actegory Mon_ptdendo_CAT sortToC1 := actegory_with_canonical_pointed_action Mon_endo_CAT. Local Definition pointedstrengthfromprecomp_CAT (E : category) := lineator_lax Mon_ptdendo_CAT ActPtd_CAT_Endo (ActPtd_CAT E). (** we are only interested in [E] to have value either [sortToC] or [C] *) Local Definition pointedstrengthfromselfaction_CAT := lineator_lax Mon_ptdendo_CAT ActPtd_CAT_FromSelf ActPtd_CAT_FromSelf. Let pointedlaxcommutator_CAT (G : sortToC1) : UU := BindingSigToMonad_actegorical.pointedlaxcommutator_CAT G. Local Definition δCCCATEndo (M : MultiSortedSig sort) : actegory_coprod_distributor Mon_ptdendo_CAT (CoproductsMultiSortedSig M) ActPtd_CAT_Endo. Proof. use reindexed_coprod_distributor. use actegory_from_precomp_CAT_coprod_distributor. Defined. Local Definition δCCCATfromSelf (M : MultiSortedSig sort) : actegory_coprod_distributor Mon_ptdendo_CAT (CoproductsMultiSortedSig M) ActPtd_CAT_FromSelf. Proof. use reindexed_coprod_distributor. use SelfActCAT_CAT_coprod_distributor. Defined. Definition ptdlaxcommutatorCAT_option_functor (s : sort) : pointedlaxcommutator_CAT (sorted_option_functor s). Proof. use BindingSigToMonad_actegorical.ptdlaxcommutator_genopt. Defined. Definition ptdlaxcommutatorCAT_option_list (xs : list sort) : pointedlaxcommutator_CAT (option_list xs). Proof. induction xs as [[|n] xs]. + induction xs. apply unit_relativelaxcommutator. + induction n as [|n IH]. * induction xs as [m []]. apply ptdlaxcommutatorCAT_option_functor. * induction xs as [m [k xs]]. use composedrelativelaxcommutator. -- exact (ptdlaxcommutatorCAT_option_functor m). -- exact (IH (k,,xs)). Defined. Definition StrengthCAT_exp_functor (lt : list sort × sort) : pointedstrengthfromprecomp_CAT C (exp_functor lt). Proof. induction lt as [l t]; revert l. use list_ind. - cbn. (* in [MultiSorted_alt], the analogous construction [Sig_exp_functor] has a composition with the strength of the identity functor since [Gθ_Signature] needs a composition *) use reindexed_lax_lineator. exact (lax_lineator_postcomp_actegories_from_precomp_CAT _ _ _ (projSortToC t)). - intros x xs H; simpl. use comp_lineator_lax. 3: { use reindexed_lax_lineator. 2: { exact (lax_lineator_postcomp_actegories_from_precomp_CAT _ _ _ (projSortToC t)). } } use reindexedstrength_from_commutator. exact (ptdlaxcommutatorCAT_option_list (cons x xs)). Defined. Definition StrengthCAT_exp_functor_list (xs : list (list sort × sort)) : pointedstrengthfromprecomp_CAT C (exp_functor_list xs). Proof. induction xs as [[|n] xs]. - induction xs. use reindexed_lax_lineator. apply constconst_functor_lax_lineator. - induction n as [|n IH]. + induction xs as [m []]. exact (StrengthCAT_exp_functor m). + induction xs as [m [k xs]]. apply (lax_lineator_binprod Mon_ptdendo_CAT ActPtd_CAT_Endo (ActPtd_CAT C)). * apply StrengthCAT_exp_functor. * exact (IH (k,,xs)). Defined. (* the strength for hat_exp_functor_list *) Definition StrengthCAT_hat_exp_functor_list (xst : list (list sort × sort) × sort) : pointedstrengthfromprecomp_CAT sortToC (hat_exp_functor_list xst). Proof. use comp_lineator_lax. - exact (ActPtd_CAT C). - apply StrengthCAT_exp_functor_list. - use reindexed_lax_lineator. apply lax_lineator_postcomp_actegories_from_precomp_CAT. Defined. Definition MultiSortedSigToStrengthCAT (M : MultiSortedSig sort) : pointedstrengthfromprecomp_CAT sortToC (MultiSortedSigToFunctor M). Proof. unfold MultiSortedSigToFunctor, MultiSorted_alt.MultiSortedSigToFunctor. set (Hyps := λ (op : ops M), StrengthCAT_hat_exp_functor_list (arity M op)). apply (lax_lineator_coprod Mon_ptdendo_CAT ActPtd_CAT_Endo ActPtd_CAT_Endo Hyps (CoproductsMultiSortedSig M)). apply δCCCATEndo. Defined. (* commented for reasons of upstream time consumption - no longer needed since we can get everything with [MultiSortedSigToFunctor'] Definition MultiSortedSigToStrengthFromSelfCAT (M : MultiSortedSig sort) : pointedstrengthfromselfaction_CAT (MultiSortedSigToFunctor M). Proof. apply EquivalenceLaxLineatorsHomogeneousCase.lax_lineators_from_reindexed_precomp_CAT_and_reindexed_self_action_agree. apply MultiSortedSigToStrengthCAT. Defined. *) (* can the following be preserved somehow? (** this yields an alternative definition for the semantic signature *) Definition MultiSortedSigToSignature_alt (M : MultiSortedSig sort) : Signature sortToC sortToC sortToC. Proof. apply weqSignatureLaxMorphismActegoriesHomogeneous_alt. exists (MultiSortedSigToFunctor M). apply lax_lineators_from_reindexed_precomp_and_reindexed_self_action_agree. apply MultiSortedSigToStrength. Defined. Local Lemma functor_in_MultiSortedSigToSignature_alt_ok (M : MultiSortedSig) : Signature_Functor (MultiSortedSigToSignature_alt M) = MultiSortedSigToFunctor M. Proof. apply idpath. Qed. (** however, the computational behaviour of the lineator will not be available *) *) (** *** we now adapt the definitions to [MultiSortedSigToFunctor'] *) Local Definition MultiSortedSigToFunctor' : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor' sort Hsort C TC BP BC CC. Local Definition hat_exp_functor_list'_optimized : list (list sort × sort) × sort -> sortToC2 := hat_exp_functor_list'_optimized sort Hsort C TC BP BC CC. Local Definition hat_exp_functor_list'_piece : (list sort × sort) × sort -> sortToC2 := hat_exp_functor_list'_piece sort Hsort C TC BC CC. Definition StrengthCAT_hat_exp_functor_list'_piece (xt : (list sort × sort) × sort) : pointedstrengthfromselfaction_CAT (hat_exp_functor_list'_piece xt). Proof. unfold hat_exp_functor_list'_piece, ContinuityOfMultiSortedSigToFunctor.hat_exp_functor_list'_piece. use comp_lineator_lax. 2: { refine (reindexedstrength_from_commutator Mon_endo_CAT Mon_ptdendo_CAT (forget_monoidal_pointed_objects_monoidal Mon_endo_CAT) _ (SelfActCAT sortToC)). exact (ptdlaxcommutatorCAT_option_list (pr1 (pr1 xt))). } use reindexed_lax_lineator. apply (lax_lineator_postcomp_SelfActCAT). Defined. Definition StrengthCAT_hat_exp_functor_list'_optimized (xst : list (list sort × sort) × sort) : pointedstrengthfromselfaction_CAT (hat_exp_functor_list'_optimized xst). Proof. induction xst as [xs t]. induction xs as [[|n] xs]. - induction xs. use reindexed_lax_lineator. use comp_lineator_lax. (* the next two lines go through [actegory_from_precomp_CAT] *) 2: { apply constconst_functor_lax_lineator. } apply lax_lineator_postcomp_SelfActCAT_alt. - induction n as [|n IH]. + induction xs as [m []]. apply StrengthCAT_hat_exp_functor_list'_piece. + induction xs as [m [k xs]]. apply (lax_lineator_binprod Mon_ptdendo_CAT ActPtd_CAT_FromSelf ActPtd_CAT_FromSelf). * apply StrengthCAT_hat_exp_functor_list'_piece. * exact (IH (k,,xs)). Defined. Definition MultiSortedSigToStrength' (M : MultiSortedSig sort) : pointedstrengthfromselfaction_CAT (MultiSortedSigToFunctor' M). Proof. unfold MultiSortedSigToFunctor', ContinuityOfMultiSortedSigToFunctor.MultiSortedSigToFunctor'. set (Hyps := λ (op : ops M), StrengthCAT_hat_exp_functor_list'_optimized (arity M op)). apply (lax_lineator_coprod Mon_ptdendo_CAT ActPtd_CAT_FromSelf ActPtd_CAT_FromSelf Hyps (CoproductsMultiSortedSig M)). apply δCCCATfromSelf. Defined. End strength_through_actegories. End MBindingSig. UniMath-20231010/UniMath/SubstitutionSystems/MultiSorted_alt.v000066400000000000000000000436321451125700300242720ustar00rootroot00000000000000(** This file contains a formalization of multisorted binding signatures: - Definition of multisorted binding signatures ([MultiSortedSig]) - Construction of a functor from a multisorted binding signature ([MultiSortedSigToFunctor]) - Construction of signature with strength from a multisorted binding signature ([MultiSortedSigToSignature]) - Proof that the functor obtained from a multisorted binding signature is omega-cocontinuous ([is_omega_cocont_MultiSortedSigToFunctor]) The construction of a monad on C^sort from a multisorted signature and the instantiation of MultiSortedSigToMonad for C = Set are now found in [UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt]. Written by: Anders Mörtberg, 2021. The formalization is an adaptation of Multisorted. some adaptions in preparation of actegorical approach done in 2023 by Ralph Matthes *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. Local Open Scope cat. (* These should be global *) Arguments Gθ_Signature {_ _ _ _} _ _. Arguments Signature_Functor {_ _ _} _. Arguments BinProduct_of_functors {_ _} _ _ _. Arguments DL_comp {_ _} _ {_} _. Arguments θ_from_δ_Signature {_ _} _. Arguments BinProduct_of_Signatures {_ _ _} _ _ _. Arguments Sum_of_Signatures _ {_ _ _} _ _. (** * Definition of multisorted binding signatures *) Section MBindingSig. (* Interestingly we only need that [sort] is a 1-type *) Variables (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Variables (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** Define the category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. (* Assumptions needed to prove ω-cocontinuity of the functor *) Variables (expSortToCC : Exponentials BPC) (HC : Colims_of_shape nat_graph C). (* The expSortToCC assumption says that [sortToC,C] has exponentials. It could be reduced to exponentials in C, but we only have the case for C = Set formalized in CategoryTheory.categories.HSET.Structures.Exponentials_functor_HSET *) (** Definition of multisorted signatures *) Definition MultiSortedSig : UU := ∑ (I : hSet), I → list (list sort × sort) × sort. Definition ops (M : MultiSortedSig) : hSet := pr1 M. Definition CoproductsMultiSortedSig_base (M : MultiSortedSig) : Coproducts (ops M) sortToC. Proof. apply Coproducts_functor_precat, CC, setproperty. Defined. Definition CoproductsMultiSortedSig (M : MultiSortedSig) : Coproducts (ops M) [sortToC, sortToC]. Proof. apply Coproducts_functor_precat, CoproductsMultiSortedSig_base. Defined. Definition arity (M : MultiSortedSig) : ops M → list (list sort × sort) × sort := λ x, pr2 M x. Definition make_MultiSortedSig {I : hSet} (ar : I → list (list sort × sort) × sort) : MultiSortedSig := (I,,ar). (** Sum of multisorted binding signatures *) Definition SumMultiSortedSig : MultiSortedSig → MultiSortedSig → MultiSortedSig. Proof. intros s1 s2. use tpair. - apply (setcoprod (ops s1) (ops s2)). - induction 1 as [i|i]. + apply (arity s1 i). + apply (arity s2 i). Defined. (** * Construction of an endofunctor on [C^sort,C^sort] from a multisorted signature *) Section functor. (** Given a sort s this applies the sortToC to s and returns C *) Definition projSortToC (s : sort) : functor sortToC C. Proof. use tpair. + use tpair. - intro f; apply (pr1 f s). - simpl; intros a b f; apply (f s). + abstract (split; intros f *; apply idpath). Defined. (* The left adjoint to projSortToC *) Definition hat_functor (t : sort) : functor C sortToC. Proof. use tpair. + use tpair. - intros A. use make_sortToC; intros s. use (CoproductObject (t = s) C (CC _ (Hsort t s) (λ _, A))). - intros a b f. apply (nat_trans_functor_path_pregroupoid); intros s. apply CoproductOfArrows; intros p; apply f. + split. - abstract (intros x; apply nat_trans_eq_alt; intros s; apply pathsinv0, CoproductArrowUnique; intros p; now rewrite id_left, id_right). - abstract (intros x y z f g; apply nat_trans_eq_alt; intros s; apply pathsinv0, CoproductArrowUnique; intros p; cbn; now rewrite assoc, (CoproductOfArrowsIn _ _ (CC _ (Hsort t s) (λ _, x))), <- !assoc, (CoproductOfArrowsIn _ _ (CC _ (Hsort t s) (λ _, y)))). Defined. (* The option functor (without decidable equality) *) Section Sorted_Option_Functor. Context (s : sort). Definition option_fun_summand : sortToC. Proof. apply make_sortToC; intro t. (* Instead of an if-then-else we use a coproduct over "s = t". This lets us avoid assuming decidable equality for sort *) exact (CoproductObject (t = s) C (CC _ (Hsort t s) (λ _, 1))). Defined. Definition sorted_option_functor : functor sortToC sortToC := constcoprod_functor1 BCsortToC option_fun_summand. (** the following two definitions are currently not used *) Local Definition Some_sorted_option_functor : functor_identity sortToC ⟹ sorted_option_functor := BinCoproductIn2 (BinCoproducts_functor_precat _ _ BCsortToC (constant_functor _ _ option_fun_summand) (functor_identity sortToC)). Local Definition None_sorted_option_functor : constant_functor _ _ option_fun_summand ⟹ sorted_option_functor := BinCoproductIn1 (BinCoproducts_functor_precat _ _ BCsortToC (constant_functor _ _ option_fun_summand) (functor_identity sortToC)). End Sorted_Option_Functor. (** Sorted option functor for lists *) Definition option_list (xs : list sort) : [sortToC,sortToC]. Proof. (* This should be [foldr1] or [foldr1_map] in order to avoid composing with the identity functor on the right in the base case *) use (foldr1_map (λ F G, F ∙ G) (functor_identity _) sorted_option_functor xs). Defined. (** Define a functor F^(l,t)(X) := projSortToC(t) ∘ X ∘ sorted_option_functor(l) if l is nonempty and F^(l,t)(X) := projSortToC(t) ∘ X otherwise *) Definition exp_functor (lt : list sort × sort) : functor [sortToC,sortToC] [sortToC,C]. Proof. induction lt as [l t]. (* use list_ind to do a case on whether l is empty or not *) use (list_ind _ _ _ l); clear l. - exact (post_comp_functor (projSortToC t)). - intros s l _. exact (pre_comp_functor (option_list (cons s l)) ∙ post_comp_functor (projSortToC t)). Defined. (** This defines F^lts where lts is a list of (l,t). Outputs a product of functors if the list is nonempty and otherwise the constant functor. *) Definition exp_functor_list (xs : list (list sort × sort)) : functor [sortToC,sortToC] [sortToC,C]. Proof. (* If the list is empty we output the constant functor *) set (T := constant_functor [sortToC,sortToC] [sortToC,C] (constant_functor sortToC C TC)). (* This should be [foldr1] or [foldr1_map] in order to avoid composing with the constant functor in the base case *) exact (foldr1_map (λ F G, BinProduct_of_functors BPC F G) T exp_functor xs). Defined. Definition hat_exp_functor_list (xst : list (list sort × sort) × sort) : functor [sortToC,sortToC] [sortToC,sortToC] := exp_functor_list (pr1 xst) ∙ post_comp_functor (hat_functor (pr2 xst)). (** The function from multisorted signatures to functors *) Definition MultiSortedSigToFunctor (M : MultiSortedSig) : functor [sortToC,sortToC] [sortToC,sortToC]. Proof. use (coproduct_of_functors (ops M) _ _ (CoproductsMultiSortedSig M)). intros op. exact (hat_exp_functor_list (arity M op)). Defined. End functor. (** * Construction of the strength for the endofunctor on [C^sort,C^sort] derived from a multisorted signature *) Section strength. (* The distributive law for sorted_option_functor *) Definition DL_sorted_option_functor (s : sort) : DistributiveLaw sortToC (sorted_option_functor s) := genoption_DistributiveLaw sortToC (option_fun_summand s) BCsortToC. (* The DL for option_list *) Definition DL_option_list (xs : list sort) : DistributiveLaw _ (option_list xs). Proof. induction xs as [[|n] xs]. + induction xs. apply DL_id. + induction n as [|n IH]. * induction xs as [m []]. apply DL_sorted_option_functor. * induction xs as [m [k xs]]. apply (DL_comp (DL_sorted_option_functor m) (IH (k,,xs))). Defined. (* The signature for exp_functor *) Definition Sig_exp_functor (lt : list sort × sort) : Signature sortToC C sortToC. Proof. exists (exp_functor lt). induction lt as [l t]; revert l. use list_ind. + exact (pr2 (Gθ_Signature (IdSignature _ _) (projSortToC t))). + intros x xs H; simpl. set (Sig_option_list := θ_from_δ_Signature (DL_option_list (cons x xs))). apply (pr2 (Gθ_Signature Sig_option_list (projSortToC t))). Defined. Local Lemma functor_in_Sig_exp_functor_ok (lt : list sort × sort) : Signature_Functor (Sig_exp_functor lt) = exp_functor lt. Proof. apply idpath. Qed. (* The signature for exp_functor_list *) Definition Sig_exp_functor_list (xs : list (list sort × sort)) : Signature sortToC C sortToC. Proof. exists (exp_functor_list xs). induction xs as [[|n] xs]. - induction xs. exact (pr2 (ConstConstSignature _ _ _ _)). - induction n as [|n IH]. + induction xs as [m []]. exact (pr2 (Sig_exp_functor m)). + induction xs as [m [k xs]]. exact (pr2 (BinProduct_of_Signatures _ (Sig_exp_functor _) (tpair _ _ (IH (k,,xs))))). Defined. Local Lemma functor_in_Sig_exp_functor_list_ok (xs : list (list sort × sort)) : Signature_Functor (Sig_exp_functor_list xs) = exp_functor_list xs. Proof. apply idpath. Qed. (* the signature for hat_exp_functor_list *) Definition Sig_hat_exp_functor_list (xst : list (list sort × sort) × sort) : Signature sortToC sortToC sortToC. Proof. apply (Gθ_Signature (Sig_exp_functor_list (pr1 xst)) (hat_functor (pr2 xst))). Defined. Local Lemma functor_in_Sig_hat_exp_functor_list_ok (xst : list (list sort × sort) × sort) : Signature_Functor (Sig_hat_exp_functor_list xst) = hat_exp_functor_list xst. Proof. apply idpath. Qed. (* The signature for MultiSortedSigToFunctor *) Definition MultiSortedSigToSignature (M : MultiSortedSig) : Signature sortToC sortToC sortToC. Proof. set (Hyps := λ (op : ops M), Sig_hat_exp_functor_list (arity M op)). apply (Sum_of_Signatures (ops M) (CoproductsMultiSortedSig_base M) Hyps). Defined. Local Lemma functor_in_MultiSortedSigToSignature_ok (M : MultiSortedSig) : Signature_Functor (MultiSortedSigToSignature M) = MultiSortedSigToFunctor M. Proof. apply idpath. Qed. End strength. (** * Proof that the functor obtained from a multisorted signature is omega-cocontinuous *) Section omega_cocont. (* Direct definition of the right adjoint to projSortToC *) Local Definition projSortToC_rad (t : sort) : functor C sortToC. Proof. use tpair. + use tpair. - intros A. use make_sortToC; intros s. exact (ProductObject (t = s) C (PC _ (λ _, A))). - intros a b f. apply (nat_trans_functor_path_pregroupoid); intros s. apply ProductOfArrows; intros p; apply f. + split. - abstract (intros x; apply nat_trans_eq_alt; intros s; apply pathsinv0, ProductArrowUnique; intros p; now rewrite id_left, id_right). - abstract(intros x y z f g; apply nat_trans_eq_alt; intros s; cbn; now rewrite ProductOfArrows_comp). Defined. Local Lemma is_left_adjoint_projSortToC (s : sort) : is_left_adjoint (projSortToC s). Proof. exists (projSortToC_rad s). use make_are_adjoints. - use make_nat_trans. + intros A. use make_nat_trans. * intros t; apply ProductArrow; intros p; induction p; apply identity. * abstract (now intros a b []; rewrite id_right, (functor_id A), id_left). + abstract (intros A B F; apply nat_trans_eq_alt; intros t; cbn; rewrite precompWithProductArrow, postcompWithProductArrow; apply ProductArrowUnique; intros []; cbn; now rewrite (ProductPrCommutes _ _ _ (PC _ (λ _, pr1 B s))), id_left, id_right). - use make_nat_trans. + intros A. exact (ProductPr _ _ (PC _ (λ _, A)) (idpath _)). + abstract (now intros a b f; cbn; rewrite (ProductOfArrowsPr _ _ (PC _ (λ _, b)))). - use make_form_adjunction. + intros A; cbn. now rewrite (ProductPrCommutes _ _ _ (PC _ (λ _, pr1 A s))). + intros c; apply nat_trans_eq_alt; intros t; cbn. rewrite postcompWithProductArrow. apply pathsinv0, ProductArrowUnique; intros []. now rewrite !id_left. Qed. Local Lemma is_omega_cocont_post_comp_projSortToC (s : sort) : is_omega_cocont (post_comp_functor (A := sortToC) (projSortToC s)). Proof. apply is_omega_cocont_post_composition_functor. apply is_left_adjoint_projSortToC. Defined. Local Lemma is_omega_cocont_exp_functor (a : list sort × sort) : is_omega_cocont (exp_functor a). Proof. induction a as [xs t]; revert xs. use list_ind. - apply is_omega_cocont_post_comp_projSortToC. - intros x xs H. apply is_omega_cocont_functor_composite. + apply (is_omega_cocont_pre_composition_functor (option_list _)). apply (ColimsFunctorCategory_of_shape nat_graph sort_cat _ HC). + apply is_omega_cocont_post_comp_projSortToC. Defined. Local Lemma is_omega_cocont_exp_functor_list (xs : list (list sort × sort)) : is_omega_cocont (exp_functor_list xs). Proof. induction xs as [[|n] xs]. - induction xs. apply is_omega_cocont_constant_functor. - induction n as [|n IHn]. + induction xs as [m []]. apply is_omega_cocont_exp_functor. + induction xs as [m [k xs]]. apply is_omega_cocont_BinProduct_of_functors. * apply BinProducts_functor_precat, BinProducts_functor_precat, BP. * apply is_omega_cocont_constprod_functor1. apply expSortToCC. * apply is_omega_cocont_exp_functor. * apply (IHn (k,,xs)). Defined. (* The hat_functor is left adjoint to projSortToC *) Local Lemma is_left_adjoint_hat (s : sort) : is_left_adjoint (hat_functor s). Proof. exists (projSortToC s). use make_are_adjoints. - use make_nat_trans. + intros A. exact (CoproductIn _ _ (CC (s = s) _ (λ _, A)) (idpath _)). + abstract (now intros A B f; cbn; rewrite (CoproductOfArrowsIn _ _ (CC _ _ (λ _, A)))). - use make_nat_trans. + intros A. use make_nat_trans. * intros t; apply CoproductArrow; intros p. exact (transportf (λ z, C ⟦ pr1 A s , z ⟧) (maponpaths (pr1 A) p) (identity _)). * abstract (intros a b []; now rewrite id_left, (functor_id A), id_right). + abstract (intros A B F; apply nat_trans_eq_alt; intros t; cbn; rewrite precompWithCoproductArrow, postcompWithCoproductArrow; apply CoproductArrowUnique; intros []; cbn; now rewrite id_left, (CoproductInCommutes _ _ _ (CC _ _ (λ _, pr1 A s))), id_right). - use make_form_adjunction. + intros c; apply nat_trans_eq_alt; intros t; cbn. rewrite precompWithCoproductArrow. apply pathsinv0, CoproductArrowUnique; intros []. now rewrite !id_right. + intros A; cbn. now rewrite (CoproductInCommutes _ _ _ (CC _ _ (λ _, pr1 A s))). Qed. Local Lemma is_omega_cocont_post_comp_hat_functor (s : sort) : is_omega_cocont (post_comp_functor (A := sortToC) (hat_functor s)). Proof. apply is_omega_cocont_post_composition_functor, is_left_adjoint_hat. Defined. Local Lemma is_omega_cocont_hat_exp_functor_list (xst : list (list sort × sort) × sort) : is_omega_cocont (hat_exp_functor_list xst). Proof. apply is_omega_cocont_functor_composite. + apply is_omega_cocont_exp_functor_list. + apply is_omega_cocont_post_comp_hat_functor. Defined. (** The functor obtained from a multisorted binding signature is omega-cocontinuous *) Lemma is_omega_cocont_MultiSortedSigToFunctor (M : MultiSortedSig) : is_omega_cocont (MultiSortedSigToFunctor M). Proof. apply is_omega_cocont_coproduct_of_functors. intros op; apply is_omega_cocont_hat_exp_functor_list. Defined. Lemma is_omega_cocont_MultiSortedSigToSignature (M : MultiSortedSig) : is_omega_cocont (MultiSortedSigToSignature M). Proof. apply is_omega_cocont_MultiSortedSigToFunctor. Defined. End omega_cocont. End MBindingSig. UniMath-20231010/UniMath/SubstitutionSystems/Notation.v000066400000000000000000000035741451125700300227530ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) Require Export UniMath.Tactics.EnsureStructuredProofs. Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Arguments functor_composite {_ _ _} _ _ . Arguments nat_trans_comp {_ _ _ _ _} _ _ . Declare Scope subsys. Delimit Scope subsys with subsys. Notation "G • F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35) : subsys. Notation "α ⋆ β" := (horcomp β α) (at level 20) : subsys. Notation "α 'ø' Z" := (pre_whisker Z α) (at level 25) : subsys. Notation "Z ∘ α" := (post_whisker α Z) : subsys. Notation "` T" := (alg_carrier _ T) (at level 3, format "` T") : subsys. Notation "α •• Z" := (# (pre_composition_functor_data _ _ _ Z) α) (at level 25) : subsys. Notation "A ⊗ B" := (make_catbinprod A B) : subsys. Notation "A ⊠ B" := (category_binproduct A B) (at level 38) : subsys. Notation "'ℓ'" := (pre_composition_functor(*_data*) _ _ _) : subsys. Notation "Z 'p•' Z'" := (ptd_compose _ Z Z') (at level 25) : subsys. (** used to stand for (ptd_composite _ _ Z Z') *) (** The forgetful functor from pointed endofunctors to endofunctors *) Notation "'U'" := (functor_ptd_forget _ ) : subsys. UniMath-20231010/UniMath/SubstitutionSystems/PCF_alt.v000066400000000000000000000172721451125700300224300ustar00rootroot00000000000000(** Syntax of PCF as a multisorted binding signature. Written by: Anders Mörtberg, 2021 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Require Import UniMath.SubstitutionSystems.STLC_alt. Local Open Scope cat. Section pcf. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (i : stn 6) (a b c d e f : A) : A. Proof. induction i as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a set of types with bool, nat and function types *) Variable (type : hSet) (Bool Nat : type) (arr : type → type → type). Local Lemma htype : isofhlevel 3 type. Proof. exact (isofhlevelssnset 1 type (setproperty type)). Defined. Let typeToSet : category := [path_pregroupoid type htype,HSET]. Let typeToSet2 := [typeToSet,typeToSet]. Local Lemma BinCoprodTypeToSet : BinCoproducts typeToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma TerminalTypeToSet : Terminal typeToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinProd : BinProducts [typeToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Lemma BinCoprodTypeToSet2 : BinCoproducts typeToSet2. Proof. apply BinCoproducts_functor_precat, BinCoprodTypeToSet. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodTypeToSet a b)). Local Notation "'1'" := (TerminalObject TerminalTypeToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). Infix "++" := (SumMultiSortedSig _). (** The Inductive version of PCF that we are going to model (copied from https://github.com/benediktahrens/monads/blob/trunk/PCF/pcf.v): << Inductive TY := | Bool : TY | Nat : TY | arrow: TY -> TY -> TY. Inductive PCF_consts : TY -> Type := | Nats : nat -> PCF_consts Nat | tt : PCF_consts Bool | ff : PCF_consts Bool | succ : PCF_consts (arrow Nat Nat) | is_zero : PCF_consts (arr Nat Bool) | condN: PCF_consts (arrow Bool (arrow Nat (arrow Nat Nat))) | condB: PCF_consts (arrow Bool (arrow Bool (arrow Bool Bool))). Inductive PCF (V:TY -> Type) : TY -> Type:= | PCFVar : forall t, V t -> PCF V t | Const : forall t, PCF_consts t -> PCF V t | Bottom : forall t, PCF V t | PApp : forall t s, PCF V (arrow s t) -> PCF V s -> PCF V t | PLam : forall t s, PCF (opt_T t V) s -> PCF V (arrow t s) | PRec : forall t, PCF V (arrow t t) -> PCF V t. >> We do this by defining the constants and non-constants separately and then taking the sum of the signatures. *) Definition PCF_Consts : MultiSortedSig type. Proof. use make_MultiSortedSig. - exact ((nat,,isasetnat) + (stn 6,,isasetstn 6))%set. - induction 1 as [n|i]. + exact ([],,Nat). (* Nat (one for each nat) *) + apply (six_rec i). * exact ([],,Bool). (* True *) * exact ([],,Bool). (* False *) * exact ([],,arr Nat Nat). (* Succ *) * exact ([],,arr Nat Bool). (* is_zero *) * exact ([],,arr Bool (arr Nat (arr Nat Nat))). (* CondN *) * exact ([],,arr Bool (arr Bool (arr Bool Bool))). (* CondB *) Defined. (* We could define PCF as follows, but we instead get App and Lam from the STLC signature *) (* Definition PCF : MultiSortedSig type. *) (* Proof. *) (* use make_MultiSortedSig. *) (* - apply (type + (type × type) + (type × type) + type)%set. *) (* - intros [[[t|[t s]]|[t s]]|t]. *) (* * exact ([],,t). (* Bottom *) *) (* * exact ((([],,(arr s t)) :: ([],,s) :: nil),,t). (* App *) *) (* * exact (((cons t [],,s) :: []),,(arr t s)). (* Lam *) *) (* * exact ((([],,(arr t t)) :: nil),,t). (* Y *) *) (* Defined. *) Definition PCF_Bot_Y : MultiSortedSig type. Proof. use make_MultiSortedSig. - apply (type + type)%set. - intros [t|t]. * exact ([],,t). (* Bottom *) * exact ((([],,(arr t t)) :: nil),,t). (* Y *) Defined. Definition PCF_App_Lam : MultiSortedSig type := STLC_Sig type arr. Definition PCF_Sig : MultiSortedSig type := PCF_Consts ++ PCF_Bot_Y ++ PCF_App_Lam. Definition PCF_Signature : Signature typeToSet _ _ := MultiSortedSigToSignatureSet type htype PCF_Sig. Definition PCF_Functor : functor typeToSet2 typeToSet2 := Id_H _ BinCoprodTypeToSet PCF_Signature. Lemma PCF_Functor_Initial : Initial (FunctorAlg PCF_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition PCF_Monad : Monad typeToSet := MultiSortedSigToMonadSet type htype PCF_Sig. (** Extract the constructors from the initial algebra *) Definition PCF_M : typeToSet2 := alg_carrier _ (InitialObject PCF_Functor_Initial). Let PCF_M_mor : typeToSet2⟦PCF_Functor PCF_M,PCF_M⟧ := alg_map _ (InitialObject PCF_Functor_Initial). Let PCF_M_alg : algebra_ob PCF_Functor := InitialObject PCF_Functor_Initial. (** The variables *) Definition var_map : typeToSet2⟦Id,PCF_M⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · PCF_M_mor. (* We can also extract the other constructors *) End pcf. UniMath-20231010/UniMath/SubstitutionSystems/README.md000066400000000000000000000126041451125700300222420ustar00rootroot00000000000000# Heterogeneous substitution systems Formalization of heterogeneous substitution systems as defined in Matthes & Uustalu, [Substitution in Non-wellfounded Syntax with Variable Binding](http://www.irit.fr/~Ralph.Matthes/papers/MatthesUustalu-final.pdf) Report on the formalization and some additional results are given in Ahrens & Matthes, [Heterogeneous substitution systems revisited](http://arxiv.org/abs/1601.04299) Much more on signatures (binding signatures and signatures with strength) and effective constructions of initial algebras and fortiori heterogeneous substitution systems and monads is described in Ahrens, Matthes & Mörtberg, [From signatures to monads in UniMath](https://arxiv.org/abs/1612.00693) Still more recent material by Ahrens, Matthes & Mörtberg concerns multi-sorted systems. * *MultiSorted.v* --- the main file on multi-sorted binding signatures * *MonadsMultiSorted.v* --- an exploration of what a monad allows to do in the slice category * *STLC.v* --- the example of simply-typed lambda calculus * *CCS.v* --- the example of the calculus of constructions in the style of Streicher Not surprisingly, these files heavily depend on the implementation of category theory that had to be extended to fit the needs. # Contents (alphabetic order of files) * *BindingSigToMonad.v* * defines the notion of binding signature which captures a decidable set of constructors with finitely many binders in their finitely many arguments - this is a purely syntactic definition * signatures with strength are derived * get an initial algebra interpreting the binding signature and get the associated initial heterogeneous substitution system and monad * *BinProductOfSignatures.v* --- in particular infers strength for the binary product and proves omega-cocontinuity * *BinSumOfSignatures.v* --- same with binary sums instead of binary products (needed to model finitely many constructors) * *FromBindingSigsToMonads_Summary.v* --- provides a stable interface to the formalization described in the paper by Ahrens, Matthes & Mörtberg (with the correspondence to the numbering of the definitions, lemmas and theorems) * *GenMendlerIteration.v* * assumes an initial algebra * Derivation of Generalized Mendler Iteration * Instantiation to a special case, Specialized Mendler Iteration * Proof of a fusion law à la Bird-Paterson (Generalised folds for nested datatypes) for Generalized Mendler Iteration * *GenMendlerIteration_alt.v* --- a variant of GenMendlerIteration.v that differs in the hypotheses: here we use ω-cocontinuity instead of Kan extensions (also based on the paper by Bird & Paterson) * *LamFromBindingSig.v* * signature of lambda calculus obtained from general constructions * equational laws for catamorphisms/folds on lambda calculus * obtain substitution monad on Set * *LamHSET.v* --- instantiates the main result of LiftingInitial_alt.v for Lam in the category HSET and obtains an initial heterogeneous substitution system and a monad * *LamSignature.v* * "Manual" definition of the arities of the constructors of lambda calculus * "Manual" definition of the signatures of lambda calculus and lambda calculus with explicit flattening * ω-cocontinuity only for lambda calculus established by reference to general results, no such result for lambda calculus with explicit flattening * *Lam.v* * Specification of an initial morphism of substitution systems from lambda calculus with explicit flattening to lambda calculus * the bracket property still has a very long monolithic proof * *LiftingInitial.v* * Construction of a substitution system from an initial algebra * Proof that the substitution system constructed from an initial algebra is an initial substitution system * *LiftingInitial_alt.v* --- a variant of LiftingInitial.v that differs in the hypotheses: here we use ω-cocontinuity instead of Kan extensions (this means we use GenMendlerIteration_alt.v instead of GenMendlerIteration.v * *MLTT79.v* --- the syntax of Martin-Löf's type theory in the style of LamHSET.v * *MonadsFromSubstitutionSystems.v* * Construction of a monad from a substitution system * Proof that morphism of hss gives morphism of monads * Bundling that into a functor * Proof that the functor is faithful * *Notation.v* --- notation that is used in this package but that is not specific to the topic of the package * *SignatureCategory.v* * organize signatures with strength into a category as described in the paper by Ahrens, Matthes & Mörtberg * identify coproducts and binary products * *SignatureExamples.v* * provides a general construction of θ in a signature in the case when the functor is precomposition with a functor G by starting with a family of simpler distributive laws δ * multiplication of distributive laws δ * distributive laws δ for option and iterations of a functor * *Signatures.v* * Definition of signatures with strength * Proof that two forms of strength laws are equivalent * *SubstitutionSystems_Summary.v* --- provides a stable interface to the formalization of heterogeneous substitution systems as described in the paper by Ahrens & Matthes * *SubstitutionSystems.v* * Definition of heterogeneous substitution systems * Various lemmas about the substitution ("bracket") operation * Definition of precategory of substitution systems * *SumOfSignatures.v* --- generalization of BinSumOfSignatures.v to sums over a decidable index set UniMath-20231010/UniMath/SubstitutionSystems/STLC.v000066400000000000000000000150211451125700300217130ustar00rootroot00000000000000(** Syntax of the simply typed lambda calculus as a multisorted signature. Written by: Anders Mörtberg, 2017 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction. Local Open Scope cat. (** * The simply typed lambda calculus from a multisorted binding signature *) Section Lam. Variable (sort : hSet) (arr : sort → sort → sort). (** A lot of notations, upstream? *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "C / X" := (slice_cat C X). Local Notation "a + b" := (setcoprod a b) : set. Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let HSET_over_sort2 := [HSET/sort,HSET_over_sort]. Local Lemma BinProducts_HSET_over_sort2 : BinProducts HSET_over_sort2. Proof. apply BinProducts_functor_precat, BinProducts_slice_precat, PullbacksHSET. Defined. Local Lemma Coproducts_HSET_over_sort2 : Coproducts ((sort × sort) + (sort × sort))%set HSET_over_sort2. Proof. apply Coproducts_functor_precat, Coproducts_slice_precat, CoproductsHSET. apply setproperty. Defined. (** The signature of the simply typed lambda calculus *) Definition STLC_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - apply ((sort × sort) + (sort × sort))%set. (* todo: fix this once level of × is fixed *) - intros H; induction H as [st|st]; induction st as [s t]. + exact ((([],,arr s t) :: ([],,s) :: nil),,t). + exact (((cons s [],,t) :: []),,arr s t). Defined. (** The signature with strength for the simply typed lambda calculus *) Definition STLC_Signature : Signature (HSET / sort) _ _:= MultiSortedSigToSignature sort STLC_Sig. Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort). Definition STLC_Functor : functor HSET_over_sort2 HSET_over_sort2 := Id_H STLC_Signature. Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor). Proof. apply SignatureInitialAlgebraSetSort. apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Definition STLC_Monad : Monad (HSET / sort) := MultiSortedSigToMonad sort STLC_Sig. (** Extract the constructors of the stlc from the initial algebra *) Definition STLC : HSET_over_sort2 := alg_carrier _ (InitialObject STLC_Functor_Initial). Let STLC_mor : HSET_over_sort2⟦STLC_Functor STLC,STLC⟧ := alg_map _ (InitialObject STLC_Functor_Initial). Let STLC_alg : algebra_ob STLC_Functor := InitialObject STLC_Functor_Initial. Local Lemma BP : BinProducts [HSET_over_sort,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Notation "'1'" := (functor_identity HSET_over_sort). Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)). (** The variables *) Definition var_map : HSET_over_sort2⟦1,STLC⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor. (** The source of the application constructor *) Definition app_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort (arr s t)) ⊗ (X ∙ proj_functor sort s)) ∙ hat_functor sort t. (** The application constructor *) Definition app_map (s t : sort) : HSET_over_sort2⟦app_source s t STLC,STLC⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii1 (s,, t))) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · STLC_mor. (** The source of the lambda constructor *) Definition lam_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 := (sorted_option_functor sort s ∙ X ∙ proj_functor sort t) ∙ hat_functor sort (arr s t). Definition lam_map (s t : sort) : HSET_over_sort2⟦lam_source s t STLC,STLC⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii2 (s,,t))) · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor. Definition make_STLC_Algebra X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : algebra_ob STLC_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intro b; induction b as [st|st]; induction st as [s t]. - apply (fapp s t). - apply (flam s t). Defined. (** The recursor for the stlc *) Definition foldr_map X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : algebra_mor _ STLC_alg (make_STLC_Algebra X fvar fapp flam). Proof. apply (InitialArrow STLC_Functor_Initial (make_STLC_Algebra X fvar fapp flam)). Defined. (** The equation for variables *) Lemma foldr_var X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. apply id_left. Defined. (* TODO: how to define the equations for app and lam? *) End Lam. UniMath-20231010/UniMath/SubstitutionSystems/STLC_alt.v000066400000000000000000000257621451125700300225700ustar00rootroot00000000000000(** Syntax of the simply typed lambda calculus as a multisorted signature. Written by: Anders Mörtberg, 2021 (adapted from STLC.v) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Local Open Scope cat. (** * The simply typed lambda calculus from a multisorted binding signature *) Section Lam. Variable (sort : hSet) (arr : sort → sort → sort). Local Lemma hsort : isofhlevel 3 sort. Proof. exact (isofhlevelssnset 1 sort (setproperty sort)). Defined. Let sortToSet : category := [path_pregroupoid sort hsort,HSET]. Local Lemma TerminalSortToSet : Terminal sortToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinCoprodSortToSet : BinCoproducts sortToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma BinProd : BinProducts [sortToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "s ⇒ t" := (arr s t). Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodSortToSet a b)). Local Notation "'1'" := (TerminalObject TerminalSortToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). Let sortToSet2 := [sortToSet,sortToSet]. Local Lemma BinCoprodSortToSet2 : BinCoproducts sortToSet2. Proof. apply BinCoproducts_functor_precat, BinCoprodSortToSet. Defined. (** The signature of the simply typed lambda calculus *) Definition STLC_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - apply ((sort × sort) + (sort × sort))%set. - intros H; induction H as [st|st]; induction st as [s t]. + exact ((([],,(s ⇒ t)) :: ([],,s) :: nil),,t). + exact (((cons s [],,t) :: []),,(s ⇒ t)). Defined. (** The signature with strength for the simply typed lambda calculus *) Definition STLC_Signature : Signature sortToSet _ _ := MultiSortedSigToSignatureSet sort hsort STLC_Sig. Definition STLC_Functor : functor sortToSet2 sortToSet2 := Id_H _ BinCoprodSortToSet STLC_Signature. Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition STLC_Monad : Monad sortToSet := MultiSortedSigToMonadSet sort hsort STLC_Sig. (** Extract the constructors of the STLC from the initial algebra *) Definition STLC_M : sortToSet2 := alg_carrier _ (InitialObject STLC_Functor_Initial). (* The functor parts coincide *) Lemma STLC_Monad_ok : STLC_M = pr1 STLC_Monad. Proof. apply idpath. Qed. Let STLC_M_mor : sortToSet2⟦STLC_Functor STLC_M,STLC_M⟧ := alg_map _ (InitialObject STLC_Functor_Initial). Let STLC_M_alg : algebra_ob STLC_Functor := InitialObject STLC_Functor_Initial. (** The variables *) Definition var_map : sortToSet2⟦Id,STLC_M⟧ := BinCoproductIn1 (BinCoprodSortToSet2 _ _) · STLC_M_mor. (** The source of the application constructor *) Definition app_source (s t : sort) : functor sortToSet2 sortToSet2 := (post_comp_functor (projSortToSet sort hsort (s ⇒ t)) ⊗ post_comp_functor (projSortToSet sort hsort s)) ∙ (post_comp_functor (hat_functorSet sort hsort t)). (** The application constructor *) Definition app_map (s t : sort) : sortToSet2⟦app_source s t STLC_M,STLC_M⟧ := CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)) (ii1 (s,,t)) · BinCoproductIn2 (BinCoprodSortToSet2 _ _) · STLC_M_mor. (** The source of the lambda constructor *) Definition lam_source (s t : sort) : functor sortToSet2 sortToSet2 := pre_comp_functor (sorted_option_functorSet sort hsort s) ∙ post_comp_functor (projSortToC sort hsort _ t) ∙ post_comp_functor (hat_functorSet sort hsort (s ⇒ t)). Definition lam_map (s t : sort) : sortToSet2⟦lam_source s t STLC_M,STLC_M⟧ := CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)) (ii2 (s,,t)) · BinCoproductIn2 (BinCoprodSortToSet2 _ _) · STLC_M_mor. Definition make_STLC_M_Algebra X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : algebra_ob STLC_Functor. Proof. apply (tpair _ X), (BinCoproductArrow _ fvar), CoproductArrow; intros b. induction b as [st|st]; induction st as [s t]. - exact (fapp s t). - exact (flam s t). Defined. (** The recursor for the stlc *) Definition foldr_map X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : algebra_mor _ STLC_M_alg (make_STLC_M_Algebra X fvar fapp flam) := InitialArrow STLC_Functor_Initial (make_STLC_M_Algebra X fvar fapp flam). (** The equation for variables *) Lemma foldr_var X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. unfold var_map. rewrite <- assoc, (algebra_mor_commutes _ _ _ (foldr_map _ _ _ _)), assoc. etrans; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite id_left. apply BinCoproductIn1Commutes. Qed. Lemma foldr_app X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) (s t : sort) : app_map s t · foldr_map X fvar fapp flam = # (pr1 (app_source s t)) (foldr_map X fvar fapp flam) · fapp s t. Proof. unfold app_map. rewrite <- assoc. etrans; [apply maponpaths, (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))|]. rewrite assoc. etrans; [eapply cancel_postcomposition; rewrite <- assoc; apply maponpaths, BinCoproductOfArrowsIn2|]. rewrite <- !assoc. etrans; [apply maponpaths, maponpaths, BinCoproductIn2Commutes|]. rewrite assoc. etrans; [apply cancel_postcomposition; use (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)))|]. rewrite <- assoc. apply maponpaths. exact (CoproductInCommutes _ _ _ _ _ _ (inl (s,,t))). Qed. Lemma foldr_lam X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) (s t : sort) : lam_map s t · foldr_map X fvar fapp flam = # (pr1 (lam_source s t)) (foldr_map X fvar fapp flam) · flam s t. Proof. unfold lam_map. rewrite <- assoc. etrans; [apply maponpaths, (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))|]. rewrite assoc. etrans; [eapply cancel_postcomposition; rewrite <- assoc; apply maponpaths, BinCoproductOfArrowsIn2|]. rewrite <- !assoc. etrans; [apply maponpaths, maponpaths, BinCoproductIn2Commutes|]. rewrite assoc. etrans; [apply cancel_postcomposition; use (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)))|]. rewrite <- assoc. apply maponpaths. exact (CoproductInCommutes _ _ _ _ _ _ (inr (s,,t))). Qed. (* Now substitution *) Let STLC := STLC_Monad. (* Parallel substitution *) Definition psubst {X Y : sortToSet} (f : sortToSet⟦X, STLC Y ⟧) : sortToSet⟦ STLC (X ⊕ Y), STLC Y ⟧ := monadSubstGen_instantiated _ _ _ _ f. (* Substitution of a single variable *) Definition subst {X : sortToSet} (f : sortToSet⟦ 1, STLC X ⟧) : sortToSet⟦ STLC (1 ⊕ X), STLC X ⟧ := monadSubstGen_instantiated _ _ _ _ f. Definition weak {X Y : sortToSet} : sortToSet⟦STLC Y,STLC (X ⊕ Y)⟧ := mweak_instantiated sort hsort HSET BinCoproductsHSET. Definition exch {X Y Z : sortToSet} : sortToSet⟦STLC (X ⊕ (Y ⊕ Z)), STLC (Y ⊕ (X ⊕ Z))⟧ := mexch_instantiated sort hsort HSET BinCoproductsHSET. Lemma psubst_interchange {X Y Z : sortToSet} (f : sortToSet⟦X,STLC (Y ⊕ Z)⟧) (g : sortToSet⟦Y, STLC Z⟧) : psubst f · psubst g = exch · psubst (g · weak) · psubst (f · psubst g). Proof. apply subst_interchange_law_gen_instantiated. Qed. Lemma subst_interchange {X : sortToSet} (f : sortToSet⟦1,STLC (1 ⊕ X)⟧) (g : sortToSet⟦1,STLC X⟧) : subst f · subst g = exch · subst (g · weak) · subst (f · subst g). Proof. apply subst_interchange_law_gen_instantiated. Qed. (* We could also unfold these as statements about sort-indexed sets, but this quickly gets very cumbersome: *) (* Definition psubst {X Y : sort → hSet} (f : ∏ t, X t → STLC Y t) (t : sort) : *) (* STLC (λ t, (X t + Y t)%set) t → STLC Y t. *) (* Proof. *) (* intros u. *) (* transparent assert (X' : (sortToSet)). *) (* { use (functor_path_pregroupoid _); apply X. } *) (* transparent assert (Y' : (sortToSet)). *) (* { use (functor_path_pregroupoid _); apply Y. } *) (* transparent assert (f' : (sortToSet⟦ X' , STLC_Monad Y' ⟧)). *) (* { use nat_trans_functor_path_pregroupoid; apply homset_property; use f. } *) (* use (pr1 (@monadSubstGen_instantiated sort SET BinCoproductsHSET STLC_Monad X' Y' f') t). *) End Lam. UniMath-20231010/UniMath/SubstitutionSystems/SigmaMonoids.v000066400000000000000000000107411451125700300235430ustar00rootroot00000000000000(** a generalization of Σ-monoids to monoidal categories in place of functor categories author: Kobe Wullaert 2023 *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Constructions. Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Sigma. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors. Require Import UniMath.CategoryTheory.Monoidal.Categories. Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories. Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems. Local Open Scope cat. Import BifunctorNotations. Definition SigmaMonoid_characteristic_equation {V : category} {Mon_V : monoidal V} {H : V ⟶ V} (x : V) (η : V ⟦ monoidal_unit Mon_V, x ⟧) (μ : V ⟦ x ⊗_{ Mon_V} x, x ⟧) (τ : V ⟦ H x, x ⟧) (st : V ⟦ x ⊗_{ Mon_V} H x, H (x ⊗_{ Mon_V} x) ⟧) : UU := st · #H μ · τ = x ⊗^{Mon_V}_{l} τ · μ. Section SigmaMonoid. Context {V : category} {Mon_V : monoidal V} {H : V ⟶ V} (θ : pointedtensorialstrength Mon_V H). Definition SigmaMonoid_disp_cat_no_compatibility : disp_cat V := dirprod_disp_cat (algebra_disp_cat H) (monoid_disp_cat Mon_V). Definition SigmaMonoid_compatibility (X : total_category SigmaMonoid_disp_cat_no_compatibility) : UU. Proof. set (x := pr1 X). set (η := monoid_data_unit _ (pr22 X : monoid _ _)). set (μ := monoid_data_multiplication _ (pr22 X : monoid _ _)). set (τ := pr12 X : H x --> x). set (st := pr1 θ (x ,, η) x). exact (SigmaMonoid_characteristic_equation x η μ τ st). Defined. Definition SigmaMonoid_disp_cat_without_sigma_constr : disp_cat (total_category SigmaMonoid_disp_cat_no_compatibility) := disp_full_sub (total_category SigmaMonoid_disp_cat_no_compatibility) SigmaMonoid_compatibility. Definition SigmaMonoid_disp_cat : disp_cat V := sigma_disp_cat SigmaMonoid_disp_cat_without_sigma_constr. Definition SigmaMonoid : category := total_category SigmaMonoid_disp_cat. Definition SigmaMonoid_carrier (σ : SigmaMonoid) : V := pr1 σ. Definition SigmaMonoid_η (σ : SigmaMonoid) : V ⟦ monoidal_unit Mon_V, SigmaMonoid_carrier σ ⟧ := monoid_data_unit _ (pr212 σ : monoid _ _). Definition SigmaMonoid_μ (σ : SigmaMonoid) : V ⟦ SigmaMonoid_carrier σ ⊗_{ Mon_V} SigmaMonoid_carrier σ, SigmaMonoid_carrier σ ⟧ := monoid_data_multiplication _ (pr212 σ : monoid _ _). Definition SigmaMonoid_τ (σ : SigmaMonoid) : V ⟦ H (SigmaMonoid_carrier σ), SigmaMonoid_carrier σ⟧ := pr112 σ. Lemma SigmaMonoid_is_compatible (σ : SigmaMonoid) : SigmaMonoid_characteristic_equation (SigmaMonoid_carrier σ) (SigmaMonoid_η σ) (SigmaMonoid_μ σ) (SigmaMonoid_τ σ) (pr1 θ (SigmaMonoid_carrier σ ,, SigmaMonoid_η σ) (SigmaMonoid_carrier σ)). Proof. exact (pr22 σ). Qed. Let MON := category_of_monoids_in_monoidal_cat Mon_V. (** the following should be an instance of general results on projection into constituents *) Definition SigmaMonoid_to_monoid_data : functor_data SigmaMonoid MON. Proof. use make_functor_data. - intro σ. exact (pr1 σ,, pr212 σ). - intros σ1 σ2 m. exact (pr1 m,, pr212 m). Defined. Lemma SigmaMonoid_to_monoid_laws : is_functor SigmaMonoid_to_monoid_data. Proof. split. - intro. apply idpath. - intro; intros. apply idpath. Qed. Definition SigmaMonoid_to_monoid : functor SigmaMonoid MON := SigmaMonoid_to_monoid_data,,SigmaMonoid_to_monoid_laws. End SigmaMonoid. Section MHSS_to_SigmaMonoid. Context {V : category} {Mon_V : monoidal V} {H : V ⟶ V} (θ : pointedtensorialstrength Mon_V H). Definition mhss_to_sigma_monoid (t : mhss Mon_V H θ) : SigmaMonoid θ. Proof. exists (pr1 t). exists (tau_from_alg Mon_V H θ t ,, mhss_monoid Mon_V H θ t). exact (mfbracket_τ Mon_V H θ t (Z := (pr1 t,, μ_0 Mon_V H θ t)) (identity _)). Defined. End MHSS_to_SigmaMonoid. UniMath-20231010/UniMath/SubstitutionSystems/SignatureCategory.v000066400000000000000000000361301451125700300246110ustar00rootroot00000000000000(** Definition of the category of signatures with strength ([Signature_category]) with - Binary products ([BinProducts_Signature_category]) - Coproducts ([Coproducts_Signature_category]) Written by: Anders Mörtberg in October 2016 based on a note of Benedikt Ahrens. In 2021 obtained by Ralph Matthes from the Structure Identity Principle through a displayed category, hence allowing for a short proof of univalence. *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.DisplayedCats.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Total. Require Import UniMath.CategoryTheory.DisplayedCats.SIP. Require Import UniMath.CategoryTheory.DisplayedCats.Univalence. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Local Open Scope cat. Local Notation "[ C , D ]" := (functor_category C D). (** * The category of signatures with strength *) Section SignatureCategory. Variables (C D D': category). Local Notation "'U'" := (functor_ptd_forget C). Local Notation "'Ptd'" := (category_Ptd C). (** Define the commutative diagram used in the morphisms *) Section Signature_category_mor. Variables (Ht Ht' : Signature C D D'). Let H := Signature_Functor Ht. Let H' := Signature_Functor Ht'. Let θ : PrestrengthForSignature Ht := theta Ht. Let θ' : PrestrengthForSignature Ht' := theta Ht'. Variables (α : nat_trans H H'). Section Signature_category_mor_diagram. Variables (X : [C,D']) (Y : Ptd). Let f1 : [C,D] ⟦H X • U Y,H (X • U Y)⟧ := θ (X,,Y). Let f2 : [C,D] ⟦H (X • U Y),H' (X • U Y)⟧ := α (X • U Y). Let g1 : [C,D] ⟦H X • U Y,H' X • U Y⟧ := α X ⋆ identity (U Y). Let g2 : [C,D] ⟦H' X • U Y,H' (X • U Y)⟧ := θ' (X,,Y). Definition Signature_category_mor_diagram : UU := f1 · f2 = g1 · g2. (** Special comparison lemma that speeds things up a lot *) Lemma Signature_category_mor_diagram_pointwise (Hc : ∏ c, pr1 f1 c · pr1 f2 c = pr1 (α X) ((pr1 Y) c) · pr1 g2 c) : Signature_category_mor_diagram. Proof. apply nat_trans_eq_alt; intro c; simpl. unfold horcomp_data; simpl. rewrite functor_id, id_right; apply (Hc c). Qed. End Signature_category_mor_diagram. Definition quantified_signature_category_mor_diagram : UU := ∏ X Y, Signature_category_mor_diagram X Y. End Signature_category_mor. Local Lemma SignatureMor_id_subproof (Ht : Signature C D D') X Y : Signature_category_mor_diagram Ht Ht (nat_trans_id Ht) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c; simpl. now rewrite id_left, id_right. Qed. Local Lemma SignatureMor_comp_subproof (Ht1 Ht2 Ht3 : Signature C D D') (α : nat_trans Ht1 Ht2) (β : nat_trans Ht2 Ht3): quantified_signature_category_mor_diagram Ht1 Ht2 α -> quantified_signature_category_mor_diagram Ht2 Ht3 β -> quantified_signature_category_mor_diagram Ht1 Ht3 (nat_trans_comp α β). Proof. intros Hα Hβ X Y. unfold quantified_signature_category_mor_diagram in *|-. unfold Signature_category_mor_diagram in *; simpl. rewrite (assoc ((theta Ht1) (X,,Y))). etrans; [apply (cancel_postcomposition ((theta Ht1) (X,,Y) · _)), Hα|]. rewrite <- assoc; etrans; [apply maponpaths, Hβ|]. rewrite assoc; apply (cancel_postcomposition (C:=[C,D]) _ (_ ⋆ identity (U Y))). apply nat_trans_eq_alt; intro c; simpl. unfold horcomp_data; simpl. now rewrite assoc, !functor_id, !id_right. Qed. Definition Signature_category_displayed : disp_cat [[C,D'],[C,D]]. Proof. use disp_cat_from_SIP_data. - intro H. exact (@StrengthForSignature C D D' H). - intros H1 H2 str1 str2 α. exact (quantified_signature_category_mor_diagram (H1,,str1) (H2,,str2) α). - intros H1 H2 str1 str2 α. do 2 (apply impred; intro). apply functor_category_has_homsets. - intros H a X Z. apply SignatureMor_id_subproof. - intros H1 H2 H3 str1 str2 str3 a1 a2 a1mor a2mor. simpl in a1mor, a2mor. simpl. exact (SignatureMor_comp_subproof (H1,,str1) (H2,,str2) (H3,,str3) a1 a2 a1mor a2mor). Defined. Definition Signature_category : category := total_category Signature_category_displayed. Lemma Signature_category_ob_ok : ob Signature_category = Signature C D D'. Proof. apply idpath. Qed. (* what would be the right source class for the following coercion? Definition Signature_category_ob_to_functor_data (sig : Signature_category) : functor_data [C, D', hsD'] [C, D, hsD] := pr1 (pr1 sig). Coercion Signature_category_ob_to_functor_data : Signature_category >-> functor_data. *) Definition SignatureMor : Signature C D D' → Signature C D D' → UU. Proof. exact (pr2 (precategory_ob_mor_from_precategory_data Signature_category)). Defined. Lemma SignatureMor_ok (Ht Ht' : Signature C D D') : SignatureMor Ht Ht' = total2 (quantified_signature_category_mor_diagram Ht Ht'). Proof. apply idpath. Qed. Definition SignatureMor_to_nat_trans (Ht Ht' : Signature C D D') : SignatureMor Ht Ht' -> Ht ⟹ Ht'. Proof. intro f. exact (pr1 f). Defined. Coercion SignatureMor_to_nat_trans : SignatureMor >-> nat_trans. Lemma SignatureMor_eq (Ht Ht' : Signature C D D') (f g : SignatureMor Ht Ht') : (pr1 f: pr1 Ht ⟹ pr1 Ht') = (pr1 g: pr1 Ht ⟹ pr1 Ht') -> f = g. Proof. intros H. apply subtypePath; trivial. now intros α; repeat (apply impred; intro); apply functor_category_has_homsets. Qed. Definition SignatureForgetfulFunctor : functor Signature_category [[C,D'],[C,D]]. Proof. use tpair. - use tpair. + intros F; apply (Signature_Functor F). + intros F G α; apply α. - abstract (now split). Defined. Lemma SignatureForgetfulFunctorFaithful : faithful SignatureForgetfulFunctor. Proof. intros F G. apply isinclbetweensets. + apply Signature_category. + apply functor_category_has_homsets. + apply SignatureMor_eq. Qed. (** towards univalence *) Lemma Signature_category_Pisset (H : [[C, D'], [C, D]]) : isaset (@StrengthForSignature C D D' H). Proof. change isaset with (isofhlevel 2). apply isofhleveltotal2. { apply (functor_category_has_homsets ([C, D'] ⊠ category_Ptd C) ([C, D]) (functor_category_has_homsets _ _ _)). } intro θ. apply isasetaprop. apply isapropdirprod. + apply isaprop_θ_Strength1_int. + apply isaprop_θ_Strength2_int. Qed. Lemma Signature_category_Hstandard (H : [[C, D'], [C, D]]) (a a' : @StrengthForSignature C D D' H) : (∏ (X : [C, D']) (Y : category_Ptd C), Signature_category_mor_diagram (H,, a) (H,, a') (identity H) X Y) → (∏ (X : [C, D']) (Y : category_Ptd C), Signature_category_mor_diagram (H,, a') (H,, a) (identity H) X Y) → a = a'. Proof. intros leq geq. apply StrengthForSignature_eq. apply (nat_trans_eq (functor_category_has_homsets _ _ _)). intro XZ. assert (leqinst := leq (pr1 XZ) (pr2 XZ)). (* assert (geqinst := geq (pr1 XZ) (pr2 XZ)). *) clear leq geq. red in leqinst. unfold theta in leqinst. etrans. { apply pathsinv0. apply id_right. } etrans. { exact leqinst. } clear leqinst. etrans. 2: { apply id_left. } apply cancel_postcomposition. apply nat_trans_eq; [apply homset_property |]. intro c. cbn. unfold horcomp_data; simpl. rewrite id_left. apply functor_id. Qed. Definition is_univalent_Signature_category_displayed : is_univalent_disp Signature_category_displayed. Proof. use is_univalent_disp_from_SIP_data. - exact Signature_category_Pisset. - exact Signature_category_Hstandard. Defined. End SignatureCategory. Definition is_univalent_Signature_category (C : category) (D: univalent_category) (D' : category) : is_univalent (Signature_category C D D'). Proof. apply SIP. - exact (is_univalent_functor_category [C, D'] _ (is_univalent_functor_category C D (pr2 D))). - apply Signature_category_Pisset. - apply Signature_category_Hstandard. Defined. (** * Binary products in the category of signatures *) Section BinProducts. Variables (C : category) (BC : BinProducts C) (D : category) (BD : BinProducts D) (D' : category). Local Definition BCD : BinProducts [[C,D'],[C,D]]. Proof. apply BinProducts_functor_precat, (BinProducts_functor_precat C _ BD). Defined. Local Lemma Signature_category_pr1_diagram (Ht1 Ht2 : Signature C D D') X Y : Signature_category_mor_diagram _ _ _ (BinProduct_of_Signatures _ _ _ _ Ht1 Ht2) _ (BinProductPr1 _ (BCD _ _)) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c; apply BinProductOfArrowsPr1. Qed. Local Definition Signature_category_pr1 (Ht1 Ht2 : Signature C D D') : SignatureMor C D D' (BinProduct_of_Signatures C D D' BD Ht1 Ht2) Ht1. Proof. use tpair. + apply (BinProductPr1 _ (BCD (pr1 Ht1) (pr1 Ht2))). + cbn. intros X Y. apply Signature_category_pr1_diagram. Defined. Local Lemma Signature_category_pr2_diagram (Ht1 Ht2 : Signature C D D' ) X Y : Signature_category_mor_diagram _ _ _ (BinProduct_of_Signatures _ _ _ _ Ht1 Ht2) _ (BinProductPr2 _ (BCD _ _)) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c; apply BinProductOfArrowsPr2. Qed. Local Definition Signature_category_pr2 (Ht1 Ht2 : Signature C D D' ) : SignatureMor C D D' (BinProduct_of_Signatures C D D' BD Ht1 Ht2) Ht2. Proof. use tpair. + apply (BinProductPr2 _ (BCD (pr1 Ht1) (pr1 Ht2))). + cbn. intros X Y. apply Signature_category_pr2_diagram. Defined. Local Lemma BinProductArrow_diagram Ht1 Ht2 Ht3 (F : SignatureMor C D D' Ht3 Ht1) (G : SignatureMor C D D' Ht3 Ht2) X Y : Signature_category_mor_diagram _ _ _ _ (BinProduct_of_Signatures _ _ _ _ Ht1 Ht2) (BinProductArrow _ (BCD _ _) (pr1 F) (pr1 G)) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c. apply pathsinv0. etrans; [ apply postcompWithBinProductArrow |]. apply pathsinv0, BinProductArrowUnique; rewrite <- assoc. + etrans; [ apply maponpaths, BinProductPr1Commutes |]. etrans; [ apply (nat_trans_eq_pointwise (pr2 F X Y) c) |]. now etrans; [ apply cancel_postcomposition, horcomp_id_left |]. + etrans; [ apply maponpaths, BinProductPr2Commutes |]. etrans; [ apply (nat_trans_eq_pointwise (pr2 G X Y) c) |]. now etrans; [ apply cancel_postcomposition, horcomp_id_left |]. Qed. Local Lemma isBinProduct_Signature_category (Ht1 Ht2 : Signature C D D') : isBinProduct (Signature_category C D D') Ht1 Ht2 (BinProduct_of_Signatures C D D' BD Ht1 Ht2) (Signature_category_pr1 Ht1 Ht2) (Signature_category_pr2 Ht1 Ht2). Proof. apply make_isBinProduct. intros Ht3 F G. use unique_exists. - apply (tpair _ (BinProductArrow _ (BCD (pr1 Ht1) (pr1 Ht2)) (pr1 F) (pr1 G))). intros X Y. apply BinProductArrow_diagram. - abstract (split; [ apply SignatureMor_eq, (BinProductPr1Commutes _ _ _ (BCD _ _)) | apply SignatureMor_eq, (BinProductPr2Commutes _ _ _ (BCD _ _))]). - abstract (intros X; apply isapropdirprod; apply Signature_category). - abstract (intros X H1H2; apply SignatureMor_eq; simpl; apply (BinProductArrowUnique _ _ _ (BCD _ _)); [ apply (maponpaths pr1 (pr1 H1H2)) | apply (maponpaths pr1 (pr2 H1H2)) ]). Defined. Lemma BinProducts_Signature_category : BinProducts (Signature_category C D D'). Proof. intros Ht1 Ht2. use make_BinProduct. - apply (BinProduct_of_Signatures _ _ _ BD Ht1 Ht2). - apply Signature_category_pr1. - apply Signature_category_pr2. - apply isBinProduct_Signature_category. Defined. End BinProducts. (** * Coproducts in the category of signatures *) Section Coproducts. Variables (I : UU). Variables (C D D' : category) (CD : Coproducts I D). Local Definition CCD : Coproducts I [[C,D'],[C,D]]. Proof. now repeat apply Coproducts_functor_precat. Defined. Local Lemma Signature_category_in_diagram (Ht : I → Signature_category C D D') i X Y : Signature_category_mor_diagram _ _ _ _ (Sum_of_Signatures I C _ _ CD Ht) (CoproductIn _ _ (CCD (λ j : I, pr1 (Ht j))) i) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c. apply pathsinv0. set (C1 := CD (λ j, pr1 (pr1 (pr1 (Ht j)) X) ((pr1 Y) c))). set (C2 := CD (λ j, pr1 (pr1 (pr1 (Ht j)) (functor_composite (pr1 Y) X)) c)). apply (@CoproductOfArrowsIn I D _ C1 _ C2). Defined. Local Definition Signature_category_in (Ht : I → Signature_category C D D') (i : I) : SignatureMor C D D' (Ht i) (Sum_of_Signatures I C D D' CD Ht). Proof. use tpair. + apply (CoproductIn _ _ (CCD (λ j, pr1 (Ht j))) i). + cbn. intros X Y. apply Signature_category_in_diagram. Defined. Lemma CoproductArrow_diagram (Hti : I → Signature_category C D D') (Ht : Signature C D D') (F : ∏ i : I, SignatureMor C D D' (Hti i) Ht) X Y : Signature_category_mor_diagram C D D' (Sum_of_Signatures I C D D' CD Hti) Ht (CoproductArrow I _ (CCD _) (λ i, pr1 (F i))) X Y. Proof. apply Signature_category_mor_diagram_pointwise; intro c. etrans; [apply precompWithCoproductArrow|]. apply pathsinv0, CoproductArrowUnique; intro i; rewrite assoc; simpl. etrans; [apply cancel_postcomposition, (CoproductInCommutes _ _ _ (CD (λ j, pr1 (pr1 (pr1 (Hti j)) X) _)))|]. apply pathsinv0; etrans; [apply (nat_trans_eq_pointwise (pr2 (F i) X Y) c)|]. now etrans; [apply cancel_postcomposition, horcomp_id_left|]. Qed. Local Lemma isCoproduct_Signature_category (Hti : I → Signature_category C D D') : isCoproduct I (Signature_category C D D') _ (Sum_of_Signatures I C D D' CD Hti) (Signature_category_in Hti). Proof. apply (make_isCoproduct _ _ (Signature_category C D D')). intros Ht F. use unique_exists. + use tpair. - apply (CoproductArrow I _ (CCD (λ j, pr1 (Hti j))) (λ i, pr1 (F i))). - cbn. intros X Y. apply CoproductArrow_diagram. + abstract (intro i; apply SignatureMor_eq, (CoproductInCommutes _ _ _ (CCD (λ j, pr1 (Hti j))))). + abstract (intros X; apply impred; intro i; apply Signature_category). + abstract (intros X Hi; apply SignatureMor_eq; simpl; apply (CoproductArrowUnique _ _ _ (CCD (λ j, pr1 (Hti j)))); intro i; apply (maponpaths pr1 (Hi i))). Defined. Lemma Coproducts_Signature_category : Coproducts I (Signature_category C D D'). Proof. intros Ht. use make_Coproduct. - apply (Sum_of_Signatures I _ _ _ CD Ht). - apply Signature_category_in. - apply isCoproduct_Signature_category. Defined. End Coproducts. UniMath-20231010/UniMath/SubstitutionSystems/SignatureExamples.v000066400000000000000000000455261451125700300246230ustar00rootroot00000000000000(** Definitions of various signatures. Written by: Anders Mörtberg, 2016 Based on a note by Ralph Matthes Revised and extended by Ralph Matthes, 2017 *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Local Open Scope cat. Section around_δ. Context (C : category). (* G^n+1 *) Fixpoint iter_functor1 (G: functor C C) (n : nat) : functor C C := match n with | O => G | S n' => functor_composite (iter_functor1 G n') G end. (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . (** distributivity with laws as a simple form the strength with laws, for endofunctors on the base category in July 2023, it became clear that this should rather have been called a pointed lax commutator; since a paper is based on this notion, we keep the name *) Section def_of_δ. Variable G : EndC. Definition δ_source : functor Ptd EndC := functor_compose (functor_ptd_forget C) (post_comp_functor G). Definition δ_target : functor Ptd EndC := functor_compose (functor_ptd_forget C) (pre_comp_functor G). Section δ_laws. Variable δ : δ_source ⟹ δ_target. (* Should be ρ_G^-1 ∘ λ_G ? *) Definition δ_law1 : UU := δ (id_Ptd C) = identity G. Let D' Ze Ze' := nat_trans_comp (rassociator_CAT (pr1 Ze) (pr1 Ze') G) (nat_trans_comp (lwhisker_CAT (pr1 Ze) (δ Ze')) (nat_trans_comp (lassociator_CAT (pr1 Ze) G (pr1 Ze')) (nat_trans_comp (rwhisker_CAT (pr1 Ze') (δ Ze)) (rassociator_CAT G (pr1 Ze) (pr1 Ze'))))). Definition δ_law2 : UU := ∏ Ze Ze', δ (Ze p• Ze') = D' Ze Ze'. (** the following variant is more suitable for communication about the results *) Definition δ_law2_nicer : UU := ∏ Ze Ze', δ (Ze p• Ze') = # (pre_comp_functor (pr1 Ze)) (δ Ze') · # (post_comp_functor (pr1 Ze')) (δ Ze). Lemma δ_law2_implies_δ_law2_nicer: δ_law2 -> δ_law2_nicer. Proof. intros Hyp Ze Ze'. assert (Hypinst := Hyp Ze Ze'). etrans. { exact Hypinst. } unfold D'. apply nat_trans_eq_alt. intro c. cbn. do 2 rewrite id_left. rewrite id_right. apply idpath. Qed. Lemma δ_law2_nicer_implies_δ_law2: δ_law2_nicer -> δ_law2. Proof. intros Hyp Ze Ze'. assert (Hypinst := Hyp Ze Ze'). etrans. { exact Hypinst. } unfold D'. apply nat_trans_eq_alt. intro c. cbn. do 2 rewrite id_left. rewrite id_right. apply idpath. Qed. End δ_laws. Definition DistributiveLaw : UU := ∑ δ : δ_source ⟹ δ_target, δ_law1 δ × δ_law2 δ. Definition δ (DL : DistributiveLaw) : δ_source ⟹ δ_target := pr1 DL. Definition distributive_law1 (DL : DistributiveLaw) : δ_law1 _ := pr1 (pr2 DL). Definition distributive_law2 (DL : DistributiveLaw) : δ_law2 _ := pr2 (pr2 DL). End def_of_δ. Section δ_for_id. Definition DL_id : DistributiveLaw (functor_identity C). Proof. use tpair; simpl. + use tpair; simpl. * intro x. { use tpair. - intro y; simpl; apply identity. - abstract (now intros y y' f; rewrite id_left, id_right). } * abstract ( intros y y' f; apply nat_trans_eq_alt; intro z; simpl; rewrite id_left; apply id_right ). + split. * apply nat_trans_eq_alt; intro c; simpl; apply idpath. * intros Ze Ze'; apply nat_trans_eq_alt; intro c; simpl. do 3 rewrite id_left. rewrite id_right. apply pathsinv0. apply functor_id. Defined. End δ_for_id. (** Construct θ in a Signature in the case when the functor is precomposition with a functor G from a family of simpler distributive laws δ *) Section θ_from_δ. Variable G : functor C C. Variable DL : DistributiveLaw G. Let precompG := (pre_composition_functor _ C C G). (** See Lemma 11 of "From Signatures to Monads in UniMath" in Ahrens, Matthes and Mörtberg *) Definition θ_from_δ_mor (XZe : [C, C] ⊠ Ptd) : [C, C] ⟦ θ_source precompG XZe, θ_target precompG XZe ⟧. Proof. set (X := pr1 XZe); set (Z := pr1 (pr2 XZe)). set (F1 := rassociator_CAT G Z X). set (F2 := rwhisker_CAT X (δ G DL (pr2 XZe))). set (F3 := lassociator_CAT Z G X). exact (F3 · (F2 · F1)). Defined. Lemma is_nat_trans_θ_from_δ_mor : is_nat_trans (θ_source precompG) (θ_target precompG) θ_from_δ_mor. Proof. intros H1 H2 αη; induction H1 as [F1 Ze1]; induction H2 as [F2 Ze2]; induction αη as [α η]. apply nat_trans_eq_alt; intro c. simpl; rewrite !id_right, !id_left. generalize (nat_trans_eq_pointwise (nat_trans_ax (δ G DL) Ze1 Ze2 η) c); simpl. intro H. rewrite assoc. etrans. 2: { apply cancel_postcomposition. apply functor_comp. } etrans. 2: { apply cancel_postcomposition. apply maponpaths. exact H. } clear H. rewrite functor_comp. do 2 rewrite <- assoc. apply maponpaths. apply pathsinv0, nat_trans_ax. Qed. Definition θ_from_δ : PrestrengthForSignature precompG := tpair _ _ is_nat_trans_θ_from_δ_mor. Lemma θ_Strength1_int_from_δ : θ_Strength1_int θ_from_δ. Proof. intro F. apply nat_trans_eq_alt; intro c; simpl. rewrite id_left, !id_right. etrans; [apply maponpaths, (nat_trans_eq_pointwise (distributive_law1 G DL) c)|]. apply functor_id. Qed. Lemma θ_Strength2_int_from_δ : θ_Strength2_int θ_from_δ. Proof. intros F Ze Ze'; simpl. set (Z := pr1 Ze); set (Z' := pr1 Ze'). apply nat_trans_eq; [apply homset_property |] ; intro c; simpl. generalize (nat_trans_eq_pointwise (distributive_law2 G DL Ze Ze') c); simpl. rewrite !id_left, !id_right; intro H. etrans; [apply maponpaths, H|]. apply functor_comp. Qed. Definition θ_precompG : StrengthForSignature precompG := tpair _ θ_from_δ (θ_Strength1_int_from_δ ,, θ_Strength2_int_from_δ). Definition θ_from_δ_Signature : Signature C C C := tpair _ precompG θ_precompG. End θ_from_δ. (* Composition of δ's *) Section δ_mul. Variable G1 : [C, C]. Variable DL1 : DistributiveLaw G1. Variable G2 : [C, C]. Variable DL2 : DistributiveLaw G2. Definition δ_comp_mor (Ze : ptd_obj C) : [C, C] ⟦pr1 (δ_source (functor_compose G1 G2)) Ze, pr1 (δ_target (functor_compose G1 G2)) Ze⟧. Proof. set (Z := pr1 Ze). set (F1 := lassociator_CAT Z G1 G2). set (F2 := rwhisker_CAT G2 (δ G1 DL1 Ze)). set (F3 := rassociator_CAT G1 Z G2). set (F4 := lwhisker_CAT G1 (δ G2 DL2 Ze)). set (F5 := lassociator_CAT G1 G2 Z). exact (F1 · (F2 · (F3 · (F4 · F5)))). Defined. Lemma is_nat_trans_δ_comp_mor : is_nat_trans (δ_source (functor_compose G1 G2)) (δ_target (functor_compose G1 G2)) δ_comp_mor. Proof. intros Ze Z'e' αX; induction Ze as [Z e]; induction Z'e' as [Z' e']; induction αX as [α X]; simpl in *. apply nat_trans_eq; [apply homset_property |]; intro c; simpl. rewrite !id_right, !id_left. generalize (nat_trans_eq_pointwise (nat_trans_ax (δ G1 DL1) (Z,,e) (Z',, e') (α,,X)) c). generalize (nat_trans_eq_pointwise (nat_trans_ax (δ G2 DL2) (Z,,e) (Z',, e') (α,,X)) (G1 c)). intros Hyp1 Hyp2. cbn in Hyp1, Hyp2. etrans. 2: { rewrite <- assoc. apply maponpaths. exact Hyp1. } clear Hyp1. etrans. { rewrite assoc. apply cancel_postcomposition. apply pathsinv0, functor_comp. } etrans. { apply cancel_postcomposition. apply maponpaths. exact Hyp2. } rewrite (functor_comp G2). apply assoc'. Qed. Definition δ_comp : δ_source (functor_compose G1 G2) ⟹ δ_target (functor_compose G1 G2) := tpair _ δ_comp_mor is_nat_trans_δ_comp_mor. Lemma δ_comp_law1 : δ_law1 (functor_compose G1 G2) δ_comp. Proof. apply nat_trans_eq_alt; intro c; simpl; rewrite !id_left, id_right. etrans. { apply maponpaths, (nat_trans_eq_pointwise (distributive_law1 G2 DL2) (pr1 G1 c)). } etrans. { apply cancel_postcomposition, maponpaths, (nat_trans_eq_pointwise (distributive_law1 G1 DL1) c). } now rewrite id_right; apply functor_id. Qed. Lemma δ_comp_law2 : δ_law2 (functor_compose G1 G2) δ_comp. Proof. intros Ze Ze'. apply nat_trans_eq_alt; intro c; simpl; rewrite !id_left, !id_right. etrans. { apply cancel_postcomposition, maponpaths, (nat_trans_eq_pointwise (distributive_law2 G1 DL1 Ze Ze') c). } etrans. { apply maponpaths, (nat_trans_eq_pointwise (distributive_law2 G2 DL2 Ze Ze') (pr1 G1 c)). } simpl; rewrite !id_left, !id_right. etrans. { apply cancel_postcomposition, functor_comp. } rewrite <- !assoc. apply maponpaths. rewrite assoc. etrans. { apply cancel_postcomposition, (nat_trans_ax (δ G2 DL2 Ze') _ _ (pr1 (δ G1 DL1 Ze) c)). } simpl; rewrite <- !assoc. now apply maponpaths, pathsinv0, functor_comp. Qed. Definition DL_comp : DistributiveLaw (functor_compose G1 G2). Proof. use tpair. * exact δ_comp. * split. - exact δ_comp_law1. - exact δ_comp_law2. Defined. End δ_mul. (** Construct the δ when G is generalized option *) Section genoption_sig. Variables (A : C) (CC : BinCoproducts C). Let genopt := constcoprod_functor1 CC A. Definition δ_genoption_mor (Ze : Ptd) (c : C) : C ⟦ BinCoproductObject (CC A (pr1 Ze c)), pr1 Ze (BinCoproductObject (CC A c)) ⟧. Proof. apply (@BinCoproductArrow _ _ _ (CC A (pr1 Ze c)) (pr1 Ze (BinCoproductObject (CC A c)))). - apply (BinCoproductIn1 (CC A c) · pr2 Ze (BinCoproductObject (CC A c))). - apply (# (pr1 Ze) (BinCoproductIn2 (CC A c))). Defined. Lemma is_nat_trans_δ_genoption_mor (Ze : Ptd) : is_nat_trans (δ_source genopt Ze : functor C C) (δ_target genopt Ze : functor C C) (δ_genoption_mor Ze). Proof. intros a b f; simpl. induction Ze as [Z e]. unfold BinCoproduct_of_functors_mor; simpl. etrans. { apply precompWithBinCoproductArrow. } rewrite id_left. apply pathsinv0, BinCoproductArrowUnique. - etrans. { rewrite assoc. apply cancel_postcomposition, BinCoproductIn1Commutes. } rewrite <- assoc. etrans. { apply maponpaths, pathsinv0, (nat_trans_ax e). } simpl; rewrite assoc. apply cancel_postcomposition. etrans. { apply BinCoproductOfArrowsIn1. } now rewrite id_left. - rewrite assoc. etrans. { apply cancel_postcomposition, BinCoproductIn2Commutes. } rewrite <- !functor_comp. now apply maponpaths, BinCoproductOfArrowsIn2. Qed. Lemma is_nat_trans_δ_genoption_mor_nat_trans : is_nat_trans (δ_source genopt) (δ_target genopt) (λ Ze : Ptd, δ_genoption_mor Ze,, is_nat_trans_δ_genoption_mor Ze). Proof. intro Ze; induction Ze as [Z e]; intro Z'e'; induction Z'e' as [Z' e']; intro αX; induction αX as [α X]; simpl in *. apply nat_trans_eq; [apply homset_property |]; intro c; simpl. unfold BinCoproduct_of_functors_mor, BinCoproduct_of_functors_ob, δ_genoption_mor; simpl. rewrite precompWithBinCoproductArrow. apply pathsinv0, BinCoproductArrowUnique. - rewrite id_left, assoc. etrans. { apply cancel_postcomposition, BinCoproductIn1Commutes. } rewrite <- assoc. now apply maponpaths, X. - rewrite assoc. etrans. { apply cancel_postcomposition, BinCoproductIn2Commutes. } now apply nat_trans_ax. Qed. Definition δ_genoption : δ_source genopt ⟹ δ_target genopt. Proof. use tpair. - intro Ze. apply (tpair _ (δ_genoption_mor Ze) (is_nat_trans_δ_genoption_mor Ze)). - apply is_nat_trans_δ_genoption_mor_nat_trans. Defined. Lemma δ_law1_genoption : δ_law1 genopt δ_genoption. Proof. apply nat_trans_eq_alt; intro c; simpl. unfold δ_genoption_mor, BinCoproduct_of_functors_ob; simpl. rewrite id_right. apply pathsinv0, BinCoproduct_endo_is_identity. - apply BinCoproductIn1Commutes. - apply BinCoproductIn2Commutes. Qed. Lemma δ_law2_genoption : δ_law2 genopt δ_genoption. Proof. intros Ze Z'e'; induction Ze as [Z e]; induction Z'e' as [Z' e']. apply nat_trans_eq_alt; intro c; simpl. unfold δ_genoption_mor, BinCoproduct_of_functors_ob; simpl. rewrite !id_left, id_right. apply pathsinv0, BinCoproductArrowUnique. - rewrite assoc. etrans. { apply cancel_postcomposition, BinCoproductIn1Commutes. } rewrite <- assoc. etrans. { apply maponpaths, pathsinv0, (nat_trans_ax e'). } simpl; rewrite assoc. etrans. { apply cancel_postcomposition, BinCoproductIn1Commutes. } rewrite <- !assoc. now apply maponpaths. - rewrite assoc. etrans. { apply cancel_postcomposition, BinCoproductIn2Commutes. } etrans. { apply pathsinv0, functor_comp. } now apply maponpaths, BinCoproductIn2Commutes. Qed. Definition genoption_DistributiveLaw : DistributiveLaw genopt. Proof. exists δ_genoption. split. - exact δ_law1_genoption. - exact δ_law2_genoption. Defined. Definition precomp_genoption_Signature : Signature C C C := θ_from_δ_Signature genopt genoption_DistributiveLaw. End genoption_sig. (** trivially instantiate previous section to option functor *) Section option_sig. Variables (TC : Terminal C) (CC : BinCoproducts C). Let opt := option_functor CC TC. Definition δ_option: δ_source opt ⟹ δ_target opt := δ_genoption TC CC. Definition δ_law1_option := δ_law1_genoption TC CC. Definition δ_law2_option := δ_law2_genoption TC CC. Definition option_DistributiveLaw : DistributiveLaw opt := genoption_DistributiveLaw TC CC. Definition precomp_option_Signature : Signature C C C := precomp_genoption_Signature TC CC. End option_sig. (** Define δ for G = F^n *) Section iter1_dl. Variable G : functor C C. Variable DL : DistributiveLaw G. Definition DL_iter_functor1 (n: nat) : DistributiveLaw (iter_functor1 G n). Proof. induction n as [|n IHn]. - exact DL. - apply DL_comp. + apply IHn. + exact DL. Defined. End iter1_dl. End around_δ. Section id_signature. Context (C D : category). Definition θ_functor_identity : StrengthForSignature (functor_identity [C, D]). Proof. use tpair. + use tpair. * intro x. { use tpair. - intro y; simpl; apply identity. - abstract (now intros y y' f; rewrite id_left, id_right). } * abstract (now intros y y' f; apply nat_trans_eq_alt; intro z; simpl; rewrite id_left, id_right). (* If this part is abstract the eval cbn for the LC doesn't reduce properly *) + now split; intros x; intros; apply nat_trans_eq_alt; intro c; simpl; rewrite !id_left. Defined. (** Signature for the Id functor *) Definition IdSignature : Signature C D D := tpair _ (functor_identity _) θ_functor_identity. (** an alternative approach would be to go through θ_from_δ_Signature, based on the observation that functor_identity [C,C,hsC] and pre_comp_functor hsC hsC (functor_identity C) are isomorphic; however, they are probably not propositionally equal, and so the benefit is marginal *) End id_signature. Section constantly_constant_signature. Variable (C D D' : category). Variable (d : D). Let H := constant_functor (functor_category C D') (functor_category C D) (constant_functor C D d). Definition θ_const_const : StrengthForSignature H. Proof. use tpair; simpl. + use tpair; simpl. * intro x. { use tpair. - intro y; simpl; apply identity. - abstract (now intros y y' f; rewrite id_left, id_right). } * abstract ( now intros y y' f; apply (nat_trans_eq (homset_property D)); intro z; simpl; rewrite id_left, id_right ). + now split; intros x; intros; apply (nat_trans_eq (homset_property D)); intro c; simpl; rewrite !id_left. Defined. Definition ConstConstSignature : Signature C D D' := tpair _ H θ_const_const. End constantly_constant_signature. (** Transform a signature with strength θ with underlying functor H into a signature with strength Gθ for the functor that comes from post-composition of all HX with a functor G G need not be an endofunctor, which is why the strength concept had to be given more heterogeneously than only on endofunctors on endofunctor categories *) Section θ_for_postcomposition. Context (C D D' E : category). (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variable S: Signature C D D'. Let H : functor [C, D'] [C, D] := Signature_Functor S. Let θ : nat_trans (θ_source H) (θ_target H) := theta S. Let θ_strength1 := Sig_strength_law1 S. Let θ_strength2 := Sig_strength_law2 S. Variable G : [D, E]. Let GH : functor [C, D'] [C, E] := functor_composite H (post_comp_functor G). Definition Gθ_mor (XZe : [C, D'] ⊠ Ptd) : [C, E] ⟦ θ_source GH XZe, θ_target GH XZe ⟧. Proof. set (X := pr1 XZe); set (Z := pr1 (pr2 XZe) : [C, C]). set (F1 := lassociator_CAT Z (H X) G). set (F2 := rwhisker_CAT G (θ XZe)). exact (F1 · F2). Defined. Lemma is_nat_trans_Gθ_mor : is_nat_trans (θ_source GH) (θ_target GH) Gθ_mor. Proof. intros H1 H2 αX; induction H1 as [F1 X1]; induction H2 as [F2 X2]. apply nat_trans_eq_alt; intro c; simpl. do 2 rewrite id_left. rewrite <- assoc. etrans. { apply maponpaths, pathsinv0, functor_comp. } etrans. { apply pathsinv0, functor_comp. } apply pathsinv0; etrans. { apply pathsinv0, functor_comp. } apply maponpaths. apply pathsinv0. rewrite assoc. generalize (nat_trans_eq_pointwise (nat_trans_ax θ (F1,,X1) (F2,,X2) αX) c). intro Hyp. apply Hyp. Qed. Definition Gθ : PrestrengthForSignature GH := tpair _ _ is_nat_trans_Gθ_mor. Lemma Gθ_Strength1_int : θ_Strength1_int Gθ. Proof. intro F. apply nat_trans_eq_alt; intro c; simpl. rewrite <- assoc. rewrite id_left. etrans. { apply pathsinv0, functor_comp. } apply pathsinv0; etrans. { apply pathsinv0, functor_id. } apply maponpaths. generalize (nat_trans_eq_pointwise (θ_strength1 F) c); simpl. intro Hyp. apply pathsinv0, Hyp. Qed. Lemma Gθ_Strength2_int : θ_Strength2_int Gθ. Proof. intros F Ze Ze'. set (Z := pr1 Ze); set (Z' := pr1 Ze'). apply nat_trans_eq_alt; intro c; simpl. do 4 rewrite id_left. etrans. { apply pathsinv0, functor_comp. } apply pathsinv0; etrans. { apply pathsinv0, functor_comp. } apply maponpaths. generalize (nat_trans_eq_pointwise (θ_strength2 F Ze Ze') c); simpl. rewrite id_left. intro Hyp. apply pathsinv0, Hyp. Qed. Definition Gθ_with_laws : StrengthForSignature GH := tpair _ Gθ (Gθ_Strength1_int ,, Gθ_Strength2_int). Definition Gθ_Signature : Signature C E D' := tpair _ GH Gθ_with_laws. End θ_for_postcomposition. UniMath-20231010/UniMath/SubstitutionSystems/Signatures.v000066400000000000000000000370451451125700300233040ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of signatures - Proof that two forms of strength laws are equivalent - (Part on relation with relative strength moved into separate file in 2023) ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. (** Goal: define signatures as pairs of a rank-2 functor and a "strength" *) (** * Definition of signatures *) Section fix_a_category. Context (C : category). (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]). (** in the original definition, this second category was the same as the first one *) Context (D : category). (** we do not yet have a use of this third category being different from the very first one *) Context (D' : category). Section about_signatures. (** [H] is a rank-2 functor: a functor between functor categories *) Context (H : functor [C, D'] [C, D]). (** ** Source and target of the natural transformation [θ] *) (** Source is given by [(X,Z) => H(X)∙U(Z)] *) Definition θ_source: ([C, D'] ⊠ Ptd) ⟶ [C, D]. Proof. apply (functor_composite (pair_functor H U)). apply (functor_composite binswap_pair_functor). apply functorial_composition. Defined. Lemma θ_source_ok: functor_on_objects θ_source = λ FX : [C, D'] ⊠ Ptd, H (pr1 FX) • U (pr2 FX). Proof. apply idpath. Qed. (** Target is given by [(X,Z) => H(X∙U(Z))] *) Definition θ_target : ([C, D'] ⊠ Ptd) ⟶ [C, D]. Proof. apply (functor_composite (pair_functor (functor_identity _) U)). apply (functor_composite binswap_pair_functor). use (functor_composite _ H). apply functorial_composition. Defined. Lemma θ_target_ok: functor_on_objects θ_target = λ FX : [C, D'] ⊠ Ptd, H (pr1 FX • U (pr2 FX)). Proof. apply idpath. Qed. Section fix_a_θ. (** * Two alternative versions of the strength laws are defined and seen as equivalent *) (** We assume a suitable (bi)natural transformation [θ] *) Hypothesis θ : θ_source ⟹ θ_target. (** [θ] is supposed to satisfy two strength laws *) Definition θ_Strength1 : UU := ∏ X : [C, D'], (θ (X ⊗ (id_Ptd C))) · # H (identity X : functor_composite (functor_identity C) X ⟹ pr1 X) = nat_trans_id _ . Section Strength_law_1_intensional. (** needs the heterogeneous formulation of the monoidal operation to type-check *) Definition θ_Strength1_int : UU := ∏ X : [C, D'], θ (X ⊗ (id_Ptd C)) · # H (lunitor_CAT _) = lunitor_CAT _. (** the following naturally-looking definition is often not suitable to work with *) Definition θ_Strength1_int_nicer : UU := ∏ X : [C, D'], θ (X ⊗ (id_Ptd C)) = nat_trans_id ((H X): functor C D). (* Section Test. Context (X : [C, D']). Check (nat_trans_id ((H X): functor C D) : (θ_source (X ⊗ (id_Ptd C)): functor C D) ⟹ (θ_target (X ⊗ (id_Ptd C)): functor C D)). End Test. *) Lemma θ_Strength1_int_nicer_implies_θ_Strength1_int : θ_Strength1_int_nicer → θ_Strength1_int. Proof. intros T X. rewrite T. etrans. { apply maponpaths. apply (functor_id H X). } apply id_right. Qed. Lemma θ_Strength1_int_implies_θ_Strength1_int_nicer : θ_Strength1_int → θ_Strength1_int_nicer. Proof. intros T X. etrans; [| apply T]. etrans. 2: { apply pathsinv0. apply maponpaths. apply (functor_id H X). } apply pathsinv0. apply id_right. Qed. Lemma isaprop_θ_Strength1_int: isaprop θ_Strength1_int. Proof. apply impred; intros X x x'. apply isaset_nat_trans, homset_property. Qed. Lemma θ_Strength1_int_implies_θ_Strength1 : θ_Strength1_int → θ_Strength1. Proof. unfold θ_Strength1_int, θ_Strength1. intros T X. assert (TX := T X). apply nat_trans_eq_alt. intro c; cbn. assert (T2 := nat_trans_eq_pointwise TX c). cbn in *. exact T2. Qed. (* practically the same proof works in the opposite direction *) Lemma θ_Strength1_implies_θ_Strength1_int : θ_Strength1 → θ_Strength1_int. Proof. unfold θ_Strength1_int, θ_Strength1. intros T X. assert (TX := T X). apply nat_trans_eq_alt. intro c; cbn. assert (T2 := nat_trans_eq_pointwise TX c). cbn in *. exact T2. Qed. End Strength_law_1_intensional. (** we are using [Z p• Z'] for compatibility with legacy code - instead of [ptd_compose] *) Definition θ_Strength2 : UU := ∏ (X : [C, D']) (Z Z' : Ptd) (Y : [C, D']) (α : functor_compose (functor_composite (U Z) (U Z')) X --> Y), θ (X ⊗ (Z p• Z' : Ptd)) · # H α = θ (X ⊗ Z') •• (U Z) · θ ((functor_compose (U Z') X) ⊗ Z) · # H (α : functor_compose (U Z) (X • (U Z')) --> Y). Section Strength_law_2_intensional. Definition θ_Strength2_int : UU := ∏ (X : [C, D']) (Z Z' : Ptd), θ (X ⊗ (Z p• Z')) · #H (rassociator_CAT (U Z) (U Z') X ) = (lassociator_CAT (U Z) (U Z') (H X) : [C, D] ⟦ functor_compose (functor_composite (U Z) (U Z')) (H X), functor_composite (U Z) (functor_composite (U Z') (H X)) ⟧ ) · θ (X ⊗ Z') •• (U Z) · θ ((functor_compose (U Z') X) ⊗ Z) . Lemma isaprop_θ_Strength2_int: isaprop θ_Strength2_int. Proof. apply impred; intros X. apply impred; intros Z. apply impred; intros Z'. apply isaset_nat_trans, homset_property. Qed. Lemma θ_Strength2_int_implies_θ_Strength2 : θ_Strength2_int → θ_Strength2. Proof. unfold θ_Strength2_int, θ_Strength2. intros T X Z Z' Y a. apply nat_trans_eq_alt. intro c. assert (TXZZ' := T X Z Z'). assert (TXZZ'c := nat_trans_eq_pointwise TXZZ' c). cbn in TXZZ'c. clear T TXZZ'. rewrite id_left in TXZZ'c. cbn. rewrite <- TXZZ'c; clear TXZZ'c. rewrite <- assoc. apply maponpaths. assert (functor_comp_H := functor_comp H (rassociator_CAT (pr1 Z) (pr1 Z') X) (a : functor_compose (U Z) (functor_composite (U Z') X) --> Y)). assert (functor_comp_H_c := nat_trans_eq_pointwise functor_comp_H c). cbn in functor_comp_H_c. etrans; [| apply functor_comp_H_c ]. clear functor_comp_H functor_comp_H_c. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c; apply pathsinv0, id_left. Qed. (* for curiosity also the other direction *) Lemma θ_Strength2_implies_θ_Strength2_int : θ_Strength2 → θ_Strength2_int. Proof. unfold θ_Strength2_int, θ_Strength2. intros T X Z Z'. assert (TXZZ'_inst := T X Z Z' (functor_compose (U Z) (functor_composite (U Z') X)) (lassociator_CAT (pr1 Z) (pr1 Z') X)). eapply pathscomp0. { apply TXZZ'_inst. } clear T TXZZ'_inst. apply nat_trans_eq_alt. intro c. cbn. rewrite id_left. rewrite <- assoc. apply maponpaths. etrans; [| apply id_right]. apply maponpaths. assert (functor_id_H := functor_id H (functor_compose (pr1 Z) (functor_composite (pr1 Z') X))). assert (functor_id_H_c := nat_trans_eq_pointwise functor_id_H c). etrans; [| apply functor_id_H_c]. clear functor_id_H functor_id_H_c. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c; apply idpath. Qed. Definition θ_Strength2_int_nicer : UU := ∏ (X : [C, D']) (Z Z' : Ptd), θ (X ⊗ (Z p• Z')) = (lassociator_CAT (U Z) (U Z') (H X) : [C, D] ⟦ functor_compose (functor_composite (U Z) (U Z')) (H X), functor_composite (U Z) (functor_composite (U Z') (H X)) ⟧) · θ (X ⊗ Z') •• (U Z) · θ ((functor_compose (U Z') X) ⊗ Z) · #H (lassociator_CAT (U Z) (U Z') X ). Lemma θ_Strength2_int_implies_θ_Strength2_int_nicer: θ_Strength2_int -> θ_Strength2_int_nicer. Proof. intro Hyp. intros X Z Z'. assert (HypX := Hyp X Z Z'). set (auxiso := functor_on_z_iso H (z_iso_inv (_,,(lassociator_CAT_pointwise_is_z_iso (U Z) (U Z') X)))). apply pathsinv0 in HypX. apply (z_iso_inv_on_left _ _ _ _ auxiso) in HypX. assumption. Qed. Lemma θ_Strength2_int_nicer_implies_θ_Strength2_int: θ_Strength2_int_nicer -> θ_Strength2_int. intro Hyp. intros X Z Z'. assert (HypX := Hyp X Z Z'). set (auxiso := functor_on_z_iso H (z_iso_inv (_,,(lassociator_CAT_pointwise_is_z_iso (U Z) (U Z') X)))). apply (z_iso_inv_to_right _ _ _ _ auxiso). assumption. Qed. Definition θ_Strength2_int_nicest : UU := ∏ (X : [C, D']) (Z Z' : Ptd), θ (X ⊗ (Z p• Z')) = θ (X ⊗ Z') •• (U Z) · θ ((functor_compose (U Z') X) ⊗ Z) · #H (lassociator_CAT (U Z) (U Z') X ). Lemma θ_Strength2_int_nicest_implies_θ_Strength2_int_nicer: θ_Strength2_int_nicest -> θ_Strength2_int_nicer. Proof. intro Hyp. intros X Z Z'. assert (HypX := Hyp X Z Z'). do 2 rewrite <- assoc. etrans. 2: { apply maponpaths. rewrite assoc. exact HypX. } apply pathsinv0. apply (id_left(a:=functor_compose (U Z ∙ U Z') (H X))). Qed. Lemma θ_Strength2_int_nicer_implies_θ_Strength2_int_nicest: θ_Strength2_int_nicer -> θ_Strength2_int_nicest. Proof. intro Hyp. intros X Z Z'. assert (HypX := Hyp X Z Z'). etrans. { exact HypX. } etrans. { do 2 apply cancel_postcomposition. apply (id_left(a:=functor_compose (U Z ∙ U Z') (H X))). } apply idpath. Qed. End Strength_law_2_intensional. (** Not having a general theory of binatural transformations, we isolate naturality in each component here *) (** an experiment *) Lemma θ_nat_1_pointfree (X X' : [C, D']) (α : X --> X') (Z : Ptd) : compose (C := [C, D]) (# (functorial_composition _ _ _) ((nat_trans_id (pr1 (U Z)),,# H α): [C, C] ⊠ [C, D] ⟦(U Z,, H X), (U Z,, H X') ⟧)) (θ (X' ⊗ Z)) = θ (X ⊗ Z) · # H ( # (functorial_composition _ _ _) ((nat_trans_id (pr1 (U Z)),, α): [C, C] ⊠ [C, D'] ⟦(U Z,, X), (U Z,, X') ⟧) ). Proof. set (t := nat_trans_ax θ). set (t' := t (X ⊗ Z) (X' ⊗ Z)). set (t'' := t' (catbinprodmor α (identity _ ))). cbn in t''. exact t''. Qed. Lemma θ_nat_1 (X X' : [C, D']) (α : X --> X') (Z : Ptd) : compose (C := [C, D]) (# H α ⋆ nat_trans_id (pr1 (U Z))) (θ (X' ⊗ Z)) = θ (X ⊗ Z) · # H (α ⋆ nat_trans_id (pr1 (U Z))). Proof. set (t := nat_trans_ax θ). set (t' := t (X ⊗ Z) (X' ⊗ Z)). set (t'' := t' (catbinprodmor α (identity _ ))). rewrite (@horcomp_post_pre _ _ D). rewrite (@horcomp_post_pre _ _ D'). cbn in t''. exact t''. Qed. Lemma θ_nat_1_pointwise (X X' : [C, D']) (α : X --> X') (Z : Ptd) (c : C) : pr1 (# H α) ((pr1 Z) c) · pr1 (θ (X' ⊗ Z)) c = pr1 (θ (X ⊗ Z)) c · pr1 (# H (α ⋆ nat_trans_id (pr1 Z))) c. Proof. assert (t := θ_nat_1 _ _ α Z). assert (t' := nat_trans_eq_weq (homset_property D) _ _ t c). clear t. cbn in t'. unfold horcomp_data in t'. etrans; [| exact t' ]. clear t'. apply pathsinv0. etrans. { apply cancel_postcomposition. apply maponpaths. apply functor_id. } rewrite <- assoc. rewrite id_left. apply idpath. Qed. Lemma θ_nat_2 (X : [C, D']) (Z Z' : Ptd) (f : Z --> Z') : compose (C := [C, D]) (identity (H X) ⋆ pr1 f) (θ (X ⊗ Z')) = θ (X ⊗ Z) · # H (identity X ⋆ pr1 f). Proof. set (t := nat_trans_ax θ). set (t' := t (X ⊗ Z) (X ⊗ Z') (catbinprodmor (identity _ ) f)). rewrite (@horcomp_post_pre _ _ D). rewrite (@horcomp_post_pre _ _ D'). cbn in t'. unfold catbinprodmor in t'. cbn in t'. set (T := functor_id H X). cbn in *. rewrite T in t'. clear T. exact t'. Qed. Lemma θ_nat_2_pointwise (X : [C, D']) (Z Z' : Ptd) (f : Z --> Z') (c : C) : # (pr1 (H X)) ((pr1 f) c) · pr1 (θ (X ⊗ Z')) c = pr1 (θ (X ⊗ Z)) c · pr1 (# H (identity X ⋆ pr1 f)) c . Proof. set (t := θ_nat_2 X _ _ f). set (t' := nat_trans_eq_weq (homset_property D) _ _ t c). clearbody t'; clear t. cbn in t'. unfold horcomp_data in t'. rewrite id_left in t'. exact t'. Qed. End fix_a_θ. (** * Definition of encapsulations of strength (locally/globally, with/without laws *) Definition PrestrengthForSignatureAtPoint (Z: Ptd) : UU := functor_fix_snd_arg [C, D'] Ptd [C, D] θ_source Z ⟹ functor_fix_snd_arg [C, D'] Ptd [C, D] θ_target Z. Definition PrestrengthForSignature : UU := θ_source ⟹ θ_target. Definition nat_trans_data_from_PrestrengthForSignature_funclass (θ: PrestrengthForSignature) : ∏ x, θ_source x --> θ_target x := pr1 θ. Coercion nat_trans_data_from_PrestrengthForSignature_funclass: PrestrengthForSignature >-> Funclass. Definition nat_trans_data_from_PrestrengthForSignatureAtPoint_funclass (Z: Ptd)(θ: PrestrengthForSignatureAtPoint Z) : ∏ x, functor_fix_snd_arg [C, D'] Ptd [C, D] θ_source Z x --> functor_fix_snd_arg [C, D'] Ptd [C, D] θ_target Z x := pr1 θ. Coercion nat_trans_data_from_PrestrengthForSignatureAtPoint_funclass: PrestrengthForSignatureAtPoint >-> Funclass. Definition StrengthForSignature : UU := ∑ θ : PrestrengthForSignature, θ_Strength1_int θ × θ_Strength2_int θ. Coercion Strength_Prestrength (θwithlaws: StrengthForSignature) : PrestrengthForSignature := pr1 θwithlaws. End about_signatures. Definition Presignature : UU := ∑ H : [C, D'] ⟶ [C, D] , PrestrengthForSignature H. Definition Signature : UU := ∑ H : [C, D'] ⟶ [C, D] , StrengthForSignature H. Coercion Presignature_Functor (S : Presignature) : functor _ _ := pr1 S. Coercion Signature_Functor (S : Signature) : functor _ _ := pr1 S. Coercion Presignature_Signature (S : Signature) : Presignature := Signature_Functor S ,, Strength_Prestrength _ (pr2 S). Definition theta (H : Presignature) : PrestrengthForSignature H := pr2 H. Definition Sig_strength_law1 (H : Signature) : θ_Strength1_int _ _ := pr1 (pr2 (pr2 H)). Definition Sig_strength_law2 (H : Signature) : θ_Strength2_int _ _ := pr2 (pr2 (pr2 H)). Lemma StrengthForSignature_eq (H : [C, D'] ⟶ [C, D] ) (sθ1 sθ2 : StrengthForSignature H) : pr1 sθ1 = pr1 sθ2 -> sθ1 = sθ2. Proof. intro Heq. apply subtypePath; trivial. intro θ. apply isapropdirprod. + apply isaprop_θ_Strength1_int. + apply isaprop_θ_Strength2_int. Qed. End fix_a_category. Arguments PrestrengthForSignature {_ _ _} _ . Arguments StrengthForSignature {_ _ _} _ . Arguments Presignature_Signature {_ _ _} _ . Arguments theta {_ _ _} _ . Arguments θ_source {_ _ _ } _ . Arguments θ_target {_ _ _ } _ . Arguments θ_Strength1 {_ _ _ _ } _ . Arguments θ_Strength2 {_ _ _ _ } _ . Arguments θ_Strength1_int {_ _ _ _} _ . Arguments θ_Strength2_int {_ _ _ _} _ . Arguments Sig_strength_law1 {_ _ _} _. Arguments Sig_strength_law2 {_ _ _} _. Arguments Signature_Functor {_ _ _} _. Arguments θ_Strength1_int_implies_θ_Strength1 {_ _ _ _} _ _. Arguments θ_Strength2_int_implies_θ_Strength2 {_ _ _ _} _ _. Arguments θ_Strength2_int_implies_θ_Strength2_int_nicer {_ _ _ _} _ _. UniMath-20231010/UniMath/SubstitutionSystems/SignaturesEquivRelativeStrength.v000066400000000000000000000152661451125700300275320ustar00rootroot00000000000000(** material that was previously located in [Signatures.v] the relation between (semantic) signatures and relative strength (considered in TYPES 2015 post-proceedings paper by Ahrens and Matthes) *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength. Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsMonoidal. Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsMonoidal. Local Open Scope subsys. Section homogeneous_case. Context (C : category). Local Lemma auxH1 (H : functor [C, C] [C, C]) (X : functor C C) : # H (nat_trans_comp (X ∘ nat_z_iso_to_trans_inv (make_nat_z_iso (functor_identity C) (functor_identity C) (nat_trans_id (functor_identity_data C)) (is_nat_z_iso_nat_trans_id (functor_identity C)))) (nat_trans_id (pr1 X) ø functor_identity_data C)) = identity (H (functor_identity C ∙ X)). Proof. apply functor_id_id. apply nat_trans_eq_alt; intro c. cbn. rewrite id_right. apply functor_id. Qed. Local Lemma auxH2aux (X : functor C C) (Z Z': precategory_Ptd C): nat_trans_comp (X ∘ identity (functor_compose (pr1 Z) (pr1 Z'))) (identity(C:=[C, C]) (X) ø (pr1 (functor_compose (pr1 Z) (pr1 Z')))) = identity (functor_compose (functor_compose (pr1 Z) (pr1 Z')) X). Proof. apply nat_trans_eq; try apply homset_property; intro c. cbn. rewrite id_right. apply functor_id. Qed. Local Definition ptd := monoidal_cat_of_pointedfunctors C. Local Definition endo := monoidal_cat_of_endofunctors C. Local Definition forget := forgetful_functor_from_ptd_as_strong_monoidal_functor C. Section relative_strength_instantiates_to_signature. Context (H : functor [C, C] [C, C]) (rs : rel_strength forget H). Local Definition ϛ : rel_strength_nat forget H := pr1 rs. Local Definition ϛ_pentagon_eq : rel_strength_pentagon_eq forget H ϛ := pr1 (pr2 rs). Local Definition ϛ_rectangle_eq : rel_strength_rectangle_eq forget H ϛ := pr2 (pr2 rs). Local Definition θ : θ_source H ⟹ θ_target H := pre_whisker binswap_pair_functor ϛ. Lemma signature_from_rel_strength_laws : θ_Strength1_int θ × θ_Strength2_int θ. Proof. split; red. - intro X. cbn. apply nat_trans_eq_alt; intro c. cbn. assert (Hyp := nat_trans_eq_weq (homset_property C) _ _ (ϛ_pentagon_eq X) c). cbn in Hyp. rewrite (functor_id (H X)) in Hyp. do 2 rewrite id_left in Hyp. etrans; [| exact Hyp]. clear Hyp. rewrite <- assoc. apply maponpaths. etrans. { apply pathsinv0. apply id_left. } apply cancel_postcomposition. apply pathsinv0. apply (nat_trans_eq_weq (homset_property C) _ _ (auxH1 H X) c). - intros X Z Z'. cbn. apply nat_trans_eq; try apply homset_property; intro c. cbn. rewrite id_left. assert (Hyp := nat_trans_eq_weq (homset_property C) _ _ (ϛ_rectangle_eq Z Z' X) c). cbn in Hyp. do 2 rewrite functor_id in Hyp. rewrite (functor_id (H X)) in Hyp. do 2 rewrite id_right in Hyp. do 2 rewrite id_left in Hyp. etrans; [| exact Hyp ]. clear Hyp. apply cancel_postcomposition. etrans. { apply pathsinv0. apply id_right. } apply maponpaths. apply pathsinv0. etrans. { use (maponpaths (fun x => pr1 (# H x) c)). + exact (identity (functor_compose (functor_compose (pr1 Z) (pr1 Z')) X)). + apply auxH2aux. } rewrite functor_id. apply idpath. Qed. Definition signature_from_rel_strength : Signature C C C. Proof. exists H. exists θ. exact signature_from_rel_strength_laws. Defined. End relative_strength_instantiates_to_signature. Section strength_in_signature_is_a_relative_strength. Context (sig : Signature C C C). Local Definition H := pr1 sig. Local Definition θ' := pr1 (pr2 sig). Local Definition ϛ' : rel_strength_nat forget H := pre_whisker binswap_pair_functor θ'. Local Definition θ'_strength_law1 := Sig_strength_law1 sig. Local Definition θ'_strength_law2 := Sig_strength_law2 sig. Lemma rel_strength_from_signature_laws : rel_strength_pentagon_eq forget H ϛ' × rel_strength_rectangle_eq forget H ϛ'. Proof. split. - intro X. apply nat_trans_eq_alt; intro c. cbn. assert (Hyp := nat_trans_eq_weq (homset_property C) _ _ (θ'_strength_law1 X) c). cbn in Hyp. fold θ' H in Hyp. rewrite (functor_id (H X)). do 2 rewrite id_left. etrans; [| exact Hyp ]. clear Hyp. rewrite <- assoc. apply maponpaths. apply pathsinv0. etrans. { apply pathsinv0. apply id_left. } apply cancel_postcomposition. apply pathsinv0. apply (nat_trans_eq_weq (homset_property C) _ _ (auxH1 H X) c). - intros Z Z' X. apply nat_trans_eq_alt; intro c. cbn. unfold PointedFunctorsComposition.ptd_compose. rewrite functorial_composition_post_pre. assert (Hyp := nat_trans_eq_weq (homset_property C) _ _ (θ'_strength_law2 X Z Z') c). cbn in Hyp. fold θ' H in Hyp. do 2 rewrite functor_id. do 2 rewrite id_right. rewrite (functor_id (H X)). do 2 rewrite id_left. rewrite id_left in Hyp. etrans; [| exact Hyp ]. clear Hyp. apply cancel_postcomposition. etrans; [| apply id_right ]. apply maponpaths. (** now identical reasoning as in [signature_from_rel_strength_laws] *) etrans. { use (maponpaths (fun x => pr1 (# H x) c)). + exact (identity (functor_compose (functor_compose (pr1 Z) (pr1 Z')) X)). + apply auxH2aux. } rewrite functor_id. apply idpath. Qed. Definition rel_strength_from_signature : rel_strength forget H := (ϛ',,rel_strength_from_signature_laws). End strength_in_signature_is_a_relative_strength. End homogeneous_case. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/000077500000000000000000000000001451125700300234235ustar00rootroot00000000000000UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/BindingSigToMonad.v000066400000000000000000000300601451125700300271100ustar00rootroot00000000000000(** Definition of binding signatures ([BindingSig]) and translation from from binding signatures to monads ([BindingSigToMonad]). This is defined in multiple steps: - Binding signature to a signature with strength ([BindingSigToSignature]) - Construction of initial algebra for a signature with strength ([SignatureInitialAlgebra]) - Signature with strength and initial algebra to a HSS ([SignatureToHSS]) - Construction of a monad from a HSS ([Monad_from_hss] in MonadsFromSubstitutionSystems.v) - Composition of these maps to get a function from binding signatures to monads ([BindingSigToMonad]) Written by: Anders Mörtberg, 2016 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Notation "[ C , D ]" := (functor_category C D). Local Notation "'chain'" := (diagram nat_graph). (** * Definition of binding signatures *) Section BindingSig. (** A binding signature is a collection of lists of natural numbers indexed by types I *) Definition BindingSig : UU := ∑ (I : UU) (h : isaset I), I → list nat. Definition BindingSigIndex : BindingSig -> UU := pr1. Definition BindingSigIsaset (s : BindingSig) : isaset (BindingSigIndex s) := pr1 (pr2 s). Definition BindingSigMap (s : BindingSig) : BindingSigIndex s -> list nat := pr2 (pr2 s). Definition make_BindingSig {I : UU} (h : isaset I) (f : I -> list nat) : BindingSig := (I,,h,,f). (** Sum of binding signatures *) Definition SumBindingSig : BindingSig -> BindingSig -> BindingSig. Proof. intros s1 s2. use tpair. - apply (BindingSigIndex s1 ⨿ BindingSigIndex s2). - use tpair. + apply (isasetcoprod _ _ (BindingSigIsaset s1) (BindingSigIsaset s2)). + induction 1 as [i|i]; [ apply (BindingSigMap s1 i) | apply (BindingSigMap s2 i) ]. Defined. End BindingSig. (** * Translation from a binding signature to a monad << S : BindingSig |-> functor(S) : functor [C,C] [C,C] |-> Initial (Id + functor(S)) |-> I := Initial (HSS(func(S), θ) |-> M := Monad_from_HSS(I) >> *) Section BindingSigToMonad. Context {C : category}. Local Notation "'[C,C]'" := (functor_category C C). (** Form "_ o option^n" and return Id if n = 0 *) Definition precomp_option_iter (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : functor [C,C] [C,C]. Proof. induction n as [|n IHn]. - apply functor_identity. - apply (pre_composition_functor _ _ _ (iter_functor1 _ (option_functor BCC TC) n)). Defined. Lemma is_omega_cocont_precomp_option_iter (BCC : BinCoproducts C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (n : nat) : is_omega_cocont (precomp_option_iter BCC TC n). Proof. destruct n; simpl. - apply is_omega_cocont_functor_identity. - apply is_omega_cocont_pre_composition_functor, CLC. Defined. Definition precomp_option_iter_Signature (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : Signature C C C. Proof. use tpair. - exact (precomp_option_iter BCC TC n). - destruct n; simpl. + apply θ_functor_identity. + exact (pr2 (θ_from_δ_Signature C _ (DL_iter_functor1 C (option_functor BCC TC) (option_DistributiveLaw C TC BCC) n))). Defined. (* will not be used, is just a confirmation of proper construction *) Local Lemma functor_in_precomp_option_iter_Signature_ok (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : Signature_Functor (precomp_option_iter_Signature BCC TC n) = precomp_option_iter BCC TC n. Proof. apply idpath. Qed. (* From here on all constructions need these hypotheses *) Context (BPC : BinProducts C) (BCC : BinCoproducts C). (** [nat] to a Signature *) Definition Arity_to_Signature (TC : Terminal C) (xs : list nat) : Signature C C C:= foldr1 (BinProduct_of_Signatures _ _ _ BPC) (ConstConstSignature C C C (TerminalObject TC)) (map (precomp_option_iter_Signature BCC TC) xs). Let BPC2 BPC := BinProducts_functor_precat C C BPC. Let constprod_functor1 := constprod_functor1 (BPC2 BPC). (** The H assumption follows directly if [C,C] has exponentials *) Lemma is_omega_cocont_Arity_to_Signature (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (H : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (xs : list nat) : is_omega_cocont (Arity_to_Signature TC xs). Proof. destruct xs as [[|n] xs]. - destruct xs; apply is_omega_cocont_constant_functor. - induction n as [|n IHn]. + destruct xs as [m []]; simpl. unfold Arity_to_Signature. apply is_omega_cocont_precomp_option_iter, CLC. + destruct xs as [m [k xs]]. apply is_omega_cocont_BinProduct_of_Signatures. * apply is_omega_cocont_precomp_option_iter, CLC. * apply (IHn (k,,xs)). * assumption. * intro x; apply (H x). Defined. (** ** Binding signature to a signature with strength *) Definition BindingSigToSignature (TC : Terminal C) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Signature C C C. Proof. apply (Sum_of_Signatures (BindingSigIndex sig)). - apply CC. - intro i; apply (Arity_to_Signature TC (BindingSigMap sig i)). Defined. Lemma is_omega_cocont_BindingSigToSignature (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : is_omega_cocont (BindingSigToSignature TC sig CC). Proof. unfold BindingSigToSignature. apply is_omega_cocont_Sum_of_Signatures. now intro i; apply is_omega_cocont_Arity_to_Signature, HF. Defined. Let Id_H := Id_H C BCC. (** ** Construction of initial algebra for a signature with strength *) Definition SignatureInitialAlgebra (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply (Initial_functor_precat _ _ IC). - apply (is_omega_cocont_Id_H _ _ _ Hs). - apply ColimsFunctorCategory_of_shape, CLC. Defined. (** ** Construction of datatype specified by a binding signature *) Definition DatatypeOfBindingSig (IC : Initial C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Initial (FunctorAlg (Id_H (Presignature_Signature(BindingSigToSignature TC sig CC)))). Proof. apply SignatureInitialAlgebra; trivial. now apply is_omega_cocont_BindingSigToSignature. Defined. Let HSS := @hss_category C BCC. (* Redefine this here so that it uses the arguments above *) Let InitialHSS (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : Initial (HSS H). Proof. apply InitialHSS; assumption. Defined. (** ** Signature with strength and initial algebra to a HSS *) Definition SignatureToHSS (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : HSS H. Proof. now apply InitialHSS; assumption. Defined. (** The above HSS is initial *) Definition SignatureToHSSisInitial (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (H : Presignature C C C) (Hs : is_omega_cocont H) : isInitial _ (SignatureToHSS IC CLC H Hs). Proof. now unfold SignatureToHSS; destruct InitialHSS. Qed. (* Redefine this here so that it uses the arguments above *) Let Monad_from_hss (H : Signature C C C) : HSS H → Monad C. Proof. exact (Monad_from_hss _ BCC H). Defined. (** ** Function from binding signatures to monads *) Definition BindingSigToMonad (TC : Terminal C) (IC : Initial C) (CLC : Colims_of_shape nat_graph C) (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) : Monad C. Proof. use Monad_from_hss. - apply (BindingSigToSignature TC sig CC). - apply (SignatureToHSS IC CLC). apply (is_omega_cocont_BindingSigToSignature TC CLC HF _ _). Defined. End BindingSigToMonad. (** * Specialized versions of some of the above functions for HSET *) Section BindingSigToMonadHSET. (** ** Binding signature to signature with strength for HSET *) Definition BindingSigToSignatureHSET (sig : BindingSig) : Signature HSET HSET HSET. Proof. use BindingSigToSignature. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply TerminalHSET. - apply sig. - apply CoproductsHSET, (BindingSigIsaset sig). Defined. Lemma is_omega_cocont_BindingSigToSignatureHSET (sig : BindingSig) : is_omega_cocont (BindingSigToSignatureHSET sig). Proof. apply is_omega_cocont_Sum_of_Signatures. intro i; apply is_omega_cocont_Arity_to_Signature. + apply ColimsHSET_of_shape. + intros F. apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. Defined. (** ** Construction of initial algebra for a signature with strength for HSET *) Definition SignatureInitialAlgebraHSET (s : Presignature HSET _ _) (Hs : is_omega_cocont s) : Initial (FunctorAlg (Id_H _ BinCoproductsHSET s)). Proof. apply SignatureInitialAlgebra; try assumption. - apply InitialHSET. - apply ColimsHSET_of_shape. Defined. (** ** Binding signature to a monad for HSET *) Definition BindingSigToMonadHSET : BindingSig → Monad HSET. Proof. intros sig; use (BindingSigToMonad _ _ _ _ _ _ sig). - apply BinProductsHSET. - apply BinCoproductsHSET. - apply TerminalHSET. - apply InitialHSET. - apply ColimsHSET_of_shape. - intros F. apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. - apply CoproductsHSET. apply BindingSigIsaset. Defined. End BindingSigToMonadHSET. (* Old code for translation from lists of lists *) (* (* [[nat]] to Signature *) *) (* Definition SigToSignature : Sig -> Signature HSET has_homsets_HSET. *) (* Proof. *) (* intro xs. *) (* generalize (map_list Arity_to_Signature xs). *) (* apply foldr1_list. *) (* - apply (BinSum_of_Signatures _ _ BinCoproductsHSET). *) (* - apply IdSignature. *) (* Defined. *) (* Lemma is_omega_cocont_SigToSignature (s : Sig) : is_omega_cocont (SigToSignature s). *) (* Proof. *) (* destruct s as [n xs]. *) (* destruct n. *) (* - destruct xs. *) (* apply (is_omega_cocont_functor_identity has_homsets_HSET2). *) (* - induction n. *) (* + destruct xs as [xs []]; simpl. *) (* apply is_omega_cocont_Arity_to_Signature. *) (* + destruct xs as [m xs]. *) (* generalize (IHn xs). *) (* destruct xs. *) (* intro IH. *) (* apply is_omega_cocont_BinSum_of_Signatures. *) (* apply is_omega_cocont_Arity_to_Signature. *) (* apply IH. *) (* apply BinProductsHSET. *) (* Defined. *) UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/CCS.v000066400000000000000000000250501451125700300242240ustar00rootroot00000000000000(** Syntax of the calculus of constructions as in Streicher "Semantics of Type Theory" formalized as a multisorted binding signature. Written by: Anders Mörtberg, 2017 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction. Local Open Scope cat. Section ccs. (* Preliminary stuff, upstream? *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "C / X" := (slice_cat C X). Local Notation "a + b" := (setcoprod a b) : set. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (a b c d e f : A) : stn 6 -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a two element set of sorts *) Definition sort : hSet := @tpair _ (λ X, isaset X) bool isasetbool. Definition ty : sort := true. Definition el : sort := false. Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let HSET_over_sort2 := [HSET/sort,HSET_over_sort]. (** The grammar of expressions and objects from page 157: << E ::= (Πx:E) E product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t ::= x variable | (λx:E) t function abstraction | App([x:E] E, t, t) function application | (∀x:E) t universal quantification >> We refer to the first syntactic class as ty and the second as el. We first reformulate the rules as follows: << A,B ::= Π(A,x.B) product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t,u ::= x variable | λ(A,x.t) function abstraction | App(A,x.B,t,u) function application | ∀(A,x.t) universal quantification >> This grammar then gives 6 operations, to the left as Vladimir's restricted 2-sorted signature (where el is 0 and ty is 1) and to the right as a multisorted signature: ((0, 1), (1, 1), 1) = (([],ty), ([el], ty), ty) (1) = ([],ty) ((0, 0), 1) = (([], el), ty) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) ((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) *) (** The multisorted signature of CC-S *) Definition CCS_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - exact (stn 6,,isasetstn 6). - apply six_rec. + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty). + exact ([],,ty). + exact ((([],,el) :: nil),,ty). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). Defined. Definition CCS_Signature : Signature (HSET / sort) _ _ := MultiSortedSigToSignature sort CCS_Sig. Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort). Definition CCS_Functor : functor HSET_over_sort2 HSET_over_sort2 := Id_H CCS_Signature. Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor). Proof. apply SignatureInitialAlgebraSetSort. apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Definition CCS_Monad : Monad (HSET / sort) := MultiSortedSigToMonad sort CCS_Sig. (** Extract the constructors from the initial algebra *) Definition CCS : HSET_over_sort2 := alg_carrier _ (InitialObject CCS_Functor_Initial). Let CCS_mor : HSET_over_sort2⟦CCS_Functor CCS,CCS⟧ := alg_map _ (InitialObject CCS_Functor_Initial). Let CCS_alg : algebra_ob CCS_Functor := InitialObject CCS_Functor_Initial. Local Lemma BP : BinProducts [HSET_over_sort,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Notation "'Id'" := (functor_identity HSET_over_sort). Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)). (** The variables *) Definition var_map : HSET_over_sort2⟦Id,CCS⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_mor. Definition Pi_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort ty)) ∙ hat_functor sort ty. (** The Pi constructor *) Definition Pi_map : HSET_over_sort2⟦Pi_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition Prop_source (X : HSET_over_sort2) : HSET_over_sort2 := constant_functor (slice_cat HSET _) HSET 1%CS ∙ hat_functor sort ty. Definition Prop_map : HSET_over_sort2⟦Prop_source CCS,CCS⟧. Proof. use ((CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor). Defined. Definition Proof_source (X : HSET_over_sort2) : HSET_over_sort2 := (X ∙ proj_functor sort el) ∙ hat_functor sort ty. (** The Proof constructor *) Definition Proof_map : HSET_over_sort2⟦Proof_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition lam_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el. (** The lambda constructor *) Definition lam_map : HSET_over_sort2⟦lam_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition app_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ ((sorted_option_functor sort el ∙ X ∙ proj_functor sort ty) ⊗ ((X ∙ proj_functor sort el) ⊗ (X ∙ proj_functor sort el)))) ∙ hat_functor sort el. (** The app constructor *) Definition app_map : HSET_over_sort2⟦app_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition forall_source (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el. (** The ∀ constructor *) Definition forall_map : HSET_over_sort2⟦forall_source CCS,CCS⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor. Definition make_CCS_Algebra X (fvar : HSET_over_sort2⟦Id,X⟧) (fPi : HSET_over_sort2⟦Pi_source X,X⟧) (fProp : HSET_over_sort2⟦Prop_source X,X⟧) (fProof : HSET_over_sort2⟦Proof_source X,X⟧) (flam : HSET_over_sort2⟦lam_source X,X⟧) (fapp : HSET_over_sort2⟦app_source X,X⟧) (fforall : HSET_over_sort2⟦forall_source X,X⟧) : algebra_ob CCS_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intros i. induction i as [n p]. repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)). - exact fPi. - exact fProp. - exact fProof. - exact flam. - simpl in fapp. exact fapp. - exact fforall. Defined. (* This is slow *) (** The recursor for ccs *) Definition foldr_map X (fvar : HSET_over_sort2⟦Id,X⟧) (fPi : HSET_over_sort2⟦Pi_source X,X⟧) (fProp : HSET_over_sort2⟦Prop_source X,X⟧) (fProof : HSET_over_sort2⟦Proof_source X,X⟧) (flam : HSET_over_sort2⟦lam_source X,X⟧) (fapp : HSET_over_sort2⟦app_source X,X⟧) (fforall : HSET_over_sort2⟦forall_source X,X⟧) : algebra_mor _ CCS_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall). Proof. apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)). Defined. End ccs. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/CCS_alt.v000066400000000000000000000266531451125700300250760ustar00rootroot00000000000000(** Syntax of the calculus of constructions as in Streicher "Semantics of Type Theory" formalized as a 2-sorted binding signature. Written by: Anders Mörtberg, 2021 (adapted from CCS.v) version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Local Open Scope cat. Section ccs. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (a b c d e f : A) : stn 6 → A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a two element set of sorts *) Definition sort : hSet := (bool,,isasetbool). Local Lemma hsort : isofhlevel 3 sort. Proof. exact (isofhlevelssnset 1 sort (setproperty sort)). Defined. Definition ty : sort := true. Definition el : sort := false. Let sortToSet : category := [path_pregroupoid sort hsort,HSET]. Let sortToSet2 := [sortToSet,sortToSet]. Local Lemma BinCoprodSortToSet : BinCoproducts sortToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma TerminalSortToSet : Terminal sortToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinProd : BinProducts [sortToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodSortToSet a b)). Local Notation "'1'" := (TerminalObject TerminalSortToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). (** The grammar of expressions and objects from page 157: << E ::= (Πx:E) E product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t ::= x variable | (λx:E) t function abstraction | App([x:E] E, t, t) function application | (∀x:E) t universal quantification >> We refer to the first syntactic class as ty and the second as el. We first reformulate the rules as follows: << A,B ::= Π(A,x.B) product of types | Prop type of propositions | Proof(t) type of proofs of proposition t t,u ::= x variable | λ(A,x.t) function abstraction | App(A,x.B,t,u) function application | ∀(A,x.t) universal quantification >> This grammar then gives 6 operations, to the left as Vladimir's restricted 2-sorted signature (where el is 0 and ty is 1) and to the right as a multisorted signature: ((0, 1), (1, 1), 1) = (([],ty), ([el], ty), ty) (1) = ([],ty) ((0, 0), 1) = (([], el), ty) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) ((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el) ((0, 1), (1, 0), 0) = (([], ty), ([el], el), el) *) (** The multisorted signature of CC-S *) Definition CCS_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - exact (stn 6,,isasetstn 6). - apply six_rec. + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty). + exact ([],,ty). + exact ((([],,el) :: nil),,ty). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el). + exact ((([],,ty) :: (cons el [],,el) :: nil),,el). Defined. Definition CCS_Signature : Signature sortToSet _ _ := MultiSortedSigToSignatureSet sort hsort CCS_Sig. Definition CCS_Functor : functor sortToSet2 sortToSet2 := Id_H _ BinCoprodSortToSet CCS_Signature. Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition CCS_Monad : Monad sortToSet := MultiSortedSigToMonadSet sort hsort CCS_Sig. (** Extract the constructors from the initial algebra *) Definition CCS_M : sortToSet2 := alg_carrier _ (InitialObject CCS_Functor_Initial). Let CCS_M_mor : sortToSet2⟦CCS_Functor CCS_M,CCS_M⟧ := alg_map _ (InitialObject CCS_Functor_Initial). Let CCS_M_alg : algebra_ob CCS_Functor := InitialObject CCS_Functor_Initial. (** The variables *) Definition var_map : sortToSet2⟦Id,CCS_M⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_M_mor. Definition Pi_source : functor sortToSet2 sortToSet2 := ( post_comp_functor (projSortToSet sort hsort ty) ⊗ ( pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToC sort hsort _ ty))) ∙ (post_comp_functor (hat_functorSet sort hsort ty)). (** The Pi constructor *) Definition Pi_map : sortToSet2⟦Pi_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition Prop_source : functor sortToSet2 sortToSet2. Proof. set (T := constant_functor [sortToSet,sortToSet] [sortToSet,HSET] (constant_functor sortToSet HSET (TerminalObject TerminalHSET))). exact (T ∙ post_comp_functor (hat_functorSet sort hsort ty)). Defined. Definition Prop_map : sortToSet2⟦Prop_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1%nat)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition Proof_source : functor sortToSet2 sortToSet2 := post_comp_functor (projSortToSet sort hsort el) ∙ post_comp_functor (hat_functorSet sort hsort ty). (** The Proof constructor *) Definition Proof_map : sortToSet2⟦Proof_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition lam_source : functor sortToSet2 sortToSet2 := (post_comp_functor (projSortToSet sort hsort ty) ⊗ (pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToC sort hsort _ el))) ∙ (post_comp_functor (hat_functorSet sort hsort el)). (** The lambda constructor *) Definition lam_map : sortToSet2⟦lam_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition app_source : functor sortToSet2 sortToSet2 := ((post_comp_functor (projSortToSet sort hsort ty)) ⊗ ((pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort ty)) ⊗ ((post_comp_functor (projSortToSet sort hsort el)) ⊗ (post_comp_functor (projSortToSet sort hsort el))))) ∙ (post_comp_functor (hat_functorSet sort hsort el)). (** The app constructor *) Definition app_map : sortToSet2⟦app_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition forall_source : functor sortToSet2 sortToSet2 := ((post_comp_functor (projSortToSet sort hsort ty)) ⊗ (pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort el))) ∙ post_comp_functor (hat_functorSet sort hsort el). (** The ∀ constructor *) Definition forall_map : sortToSet2⟦forall_source CCS_M,CCS_M⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_M_mor. Definition make_CCS_Algebra X (fvar : sortToSet2⟦Id,X⟧) (fPi : sortToSet2⟦Pi_source X,X⟧) (fProp : sortToSet2⟦Prop_source X,X⟧) (fProof : sortToSet2⟦Proof_source X,X⟧) (flam : sortToSet2⟦lam_source X,X⟧) (fapp : sortToSet2⟦app_source X,X⟧) (fforall : sortToSet2⟦forall_source X,X⟧) : algebra_ob CCS_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intros i. induction i as [n p]. repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)). - exact fPi. - exact fProp. - exact fProof. - exact flam. - simpl in fapp. exact fapp. - exact fforall. Defined. (** The recursor for ccs *) Definition foldr_map X (fvar : sortToSet2⟦Id,X⟧) (fPi : sortToSet2⟦Pi_source X,X⟧) (fProp : sortToSet2⟦Prop_source X,X⟧) (fProof : sortToSet2⟦Proof_source X,X⟧) (flam : sortToSet2⟦lam_source X,X⟧) (fapp : sortToSet2⟦app_source X,X⟧) (fforall : sortToSet2⟦forall_source X,X⟧) : algebra_mor _ CCS_M_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall). Proof. apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)). Defined. End ccs. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/FromBindingSigsToMonads_Summary.v000066400000000000000000000375101451125700300320260ustar00rootroot00000000000000(** This file provides a stable interface to the formalization of the paper: From binding signatures to monads in UniMath https://arxiv.org/abs/1612.00693 by Benedikt Ahrens, Ralph Matthes and Anders Mörtberg. version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory (and adding SimplifiedHSS to the fully qualified identifiers) *) Require Import UniMath.Foundations.NaturalNumbers. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.Univalence. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.ProductCategory. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.SignatureCategory. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Local Open Scope cat. Local Notation "[ C , D ]" := (functor_category C D). (** Definition 1: Binding signature *) Definition BindingSig : UU := @UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.BindingSig. (** Definition 4: Signatures with strength *) Definition Signature : ∏ (C D D' : category), UU := @UniMath.SubstitutionSystems.Signatures.Signature. (** Definition 5: Morphism of signatures with strength *) Definition SignatureMor : ∏ C D D' : category, Signatures.Signature C D D' → Signatures.Signature C D D' → UU := @UniMath.SubstitutionSystems.SignatureCategory.SignatureMor. (** Definition 6: Coproduct of signatures with strength *) Definition Sum_of_Signatures : ∏ (I : UU) (C D D': category), Coproducts I D → (I → Signature C D D') → Signature C D D' := @UniMath.SubstitutionSystems.SumOfSignatures.Sum_of_Signatures. (** Definition 7: Binary product of signatures with strength *) Definition BinProduct_of_Signatures : ∏ (C D D' : category), BinProducts D → Signature C D D' → Signature C D D' → Signature C D D' := @UniMath.SubstitutionSystems.BinProductOfSignatures.BinProduct_of_Signatures. (** Problem 8: Signatures with strength from binding signatures *) Definition BindingSigToSignature : ∏ {C : category}, BinProducts C → BinCoproducts C → Terminal C → ∏ sig : BindingSig, Coproducts (BindingSigIndex sig) C → Signature C C C := @UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.BindingSigToSignature. (** Definition 10 and Lemma 11 and 12: see UniMath/SubstitutionSystems/SignatureExamples.v *) (** Definition 15: Graph *) Definition graph : UU := @UniMath.CategoryTheory.limits.graphs.colimits.graph. (** Definition 16: Diagram *) Definition diagram : graph → category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.diagram. (** Definition 17: Cocone *) Definition cocone : ∏ {C : category} {g : graph}, diagram g C → C → UU := @UniMath.CategoryTheory.limits.graphs.colimits.cocone. (** Definition 18: Colimiting cocone *) Definition isColimCocone : ∏ {C : category} {g : graph} (d : diagram g C) (c0 : C), cocone d c0 → UU := @UniMath.CategoryTheory.limits.graphs.colimits.isColimCocone. (** Colimits of a specific shape *) Definition Colims_of_shape : graph → category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.Colims_of_shape. (** Colimits of any shape *) Definition Colims : category → UU := @UniMath.CategoryTheory.limits.graphs.colimits.Colims. (** Remark 19: Uniqueness of colimits *) Lemma isaprop_Colims : ∏ C : univalent_category, isaprop (Colims C). Proof. exact @UniMath.CategoryTheory.limits.graphs.colimits.isaprop_Colims. Defined. (** Definition 20: Preservation of colimits *) Definition preserves_colimit : ∏ {C D : category}, functor C D → ∏ {g : graph} (d : diagram g C) (L : C), cocone d L → UU := @UniMath.CategoryTheory.limits.graphs.colimits.preserves_colimit. Definition is_cocont : ∏ {C D : category}, functor C D → UU := @UniMath.CategoryTheory.Chains.Chains.is_cocont. Definition is_omega_cocont : ∏ {C D : category}, functor C D → UU := @UniMath.CategoryTheory.Chains.Chains.is_omega_cocont. (** Lemma 21: Invariance of cocontinuity under isomorphism *) Lemma preserves_colimit_z_iso : ∏ (C D : category) (F G : functor C D) (α : @z_iso [C, D] F G) (g : graph) (d : diagram g C) (L : C) (cc : cocone d L), preserves_colimit F d L cc → preserves_colimit G d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_z_iso. Defined. (** Problem 22: Colimits in functor categories *) Definition ColimsFunctorCategory_of_shape : ∏ (g : graph) (A C : category), Colims_of_shape g C → Colims_of_shape g [A, C] := @UniMath.CategoryTheory.limits.graphs.colimits.ColimsFunctorCategory_of_shape. (** Problem 24: Initial algebras of ω-cocontinuous functors *) Definition colimAlgInitial : ∏ (C : category) (InitC : Initial C) (F : functor C C), is_omega_cocont F → ColimCocone (initChain InitC F) → Initial (FunctorAlg F) := @UniMath.CategoryTheory.Chains.Adamek.colimAlgInitial. (** Lemma 25: Lambek's lemma *) Lemma initialAlg_is_z_iso : ∏ (C : category) (F : functor C C) (Aa : algebra_ob F), isInitial (FunctorAlg F) Aa → is_z_isomorphism (alg_map F Aa). Proof. exact @UniMath.CategoryTheory.FunctorAlgebras.initialAlg_is_z_iso. Defined. (** Problem 27: Colimits in Set *) Lemma ColimsHSET_of_shape : ∏ (g : graph), Colims_of_shape g HSET. Proof. exact @UniMath.CategoryTheory.categories.HSET.Colimits.ColimsHSET_of_shape. Defined. (** Lemma 31: Left adjoints preserve colimits *) Lemma left_adjoint_cocont : ∏ (C D : category) (F : functor C D), is_left_adjoint F → is_cocont F. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.left_adjoint_cocont. Defined. (** Lemma 32: Examples of preservation of colimits *) (** (i): Identity functor *) Lemma preserves_colimit_identity : ∏ (C : category) (g : colimits.graph) (d : colimits.diagram g C) (L : C) (cc : colimits.cocone d L), preserves_colimit (functor_identity C) d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_identity. Defined. (** (ii): Constant functor *) Lemma is_omega_cocont_constant_functor : ∏ (C D : category) (x : D), Chains.Chains.is_omega_cocont (constant_functor C D x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constant_functor. Defined. (** (iii): Diagonal functor *) Lemma is_cocont_delta_functor : ∏ (I : UU) (C : category), Products I C → is_cocont (delta_functor I C). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_delta_functor. Defined. Lemma is_omega_cocont_delta_functor : ∏ (I : UU) (C : category), Products I C → is_omega_cocont (delta_functor I C). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_delta_functor. Defined. (** (iv): Coproduct functor *) Lemma is_cocont_coproduct_functor : ∏ (I : UU) (C : category) (PC : Coproducts I C), is_cocont (coproduct_functor I PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_coproduct_functor. Defined. Lemma is_omega_cocont_coproduct_functor : ∏ (I : UU) (C : category) (PC : Coproducts I C), is_omega_cocont (coproduct_functor I PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_coproduct_functor. Defined. (** Lemma 33: Examples of preservation of cocontinuity *) (** (i): Composition of functors *) Lemma preserves_colimit_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E) (g : graph) (d : diagram g C) (L : C) (cc : cocone d L), preserves_colimit F d L cc → preserves_colimit G (mapdiagram F d) (F L) (mapcocone F d cc) → preserves_colimit (functor_composite F G) d L cc. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_functor_composite. Defined. Lemma is_cocont_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E), is_cocont F → is_cocont G → is_cocont (functor_composite F G). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_functor_composite. Defined. Lemma is_omega_cocont_functor_composite : ∏ (C D E : category) (F : functor C D) (G : functor D E), is_omega_cocont F → is_omega_cocont G → is_omega_cocont (functor_composite F G). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_functor_composite. Defined. (** (ii) Tuple functor *) Lemma is_cocont_tuple_functor : ∏ (I : UU) (A : category) (B: I -> category) (F : ∏ i, functor A (B i)), (∏ i, is_cocont (F i)) -> is_cocont (tuple_functor F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_tuple_functor. Defined. Lemma is_omega_cocont_tuple_functor : ∏ (I : UU) (A : category) (B: I -> category) (F : ∏ i, functor A (B i)), (∏ i, is_omega_cocont (F i)) -> is_omega_cocont (tuple_functor F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_tuple_functor. Defined. (** (iii): Families of functors *) Lemma is_cocont_family_functor : ∏ (I : UU) (A B : category), isdeceq I → ∏ F : I → functor A B, (∏ i : I, is_cocont (F i)) → is_cocont (family_functor I F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_family_functor. Defined. Lemma is_omega_cocont_family_functor : ∏ (I : UU) (A B : category), isdeceq I → ∏ F : I → functor A B, (∏ i : I, is_omega_cocont (F i)) → is_omega_cocont (family_functor I F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_family_functor. Defined. (** Example 35: Exponentials in Set *) Definition Exponentials_HSET : Exponentials BinProductsHSET := @UniMath.CategoryTheory.categories.HSET.Structures.Exponentials_HSET. (** Lemma 36: Left and right product functors preserves colimits *) Lemma is_cocont_constprod_functor1 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_cocont (constprod_functor1 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_constprod_functor1. Defined. Lemma is_omega_cocont_constprod_functor1 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_omega_cocont (constprod_functor1 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constprod_functor1. Defined. Lemma is_cocont_constprod_functor2 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_cocont (constprod_functor2 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_cocont_constprod_functor2. Defined. Lemma is_omega_cocont_constprod_functor2 : ∏ (C : category) (PC : BinProducts C), Exponentials PC → ∏ x : C, is_omega_cocont (constprod_functor2 PC x). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_constprod_functor2. Defined. (** Theorem 37: Binary product functor is ω-cocontinuous *) Lemma is_omega_cocont_binproduct_functor : ∏ (C : category) (PC : BinProducts C), (∏ x : C, is_omega_cocont (constprod_functor1 PC x)) → is_omega_cocont (binproduct_functor PC). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_binproduct_functor. Defined. (** Example 38: Lists of sets *) (* see: UniMath/CategoryTheory/Inductives/Lists.v *) (** Theorem 41: Precomposition functor preserves colimits *) Lemma preserves_colimit_pre_composition_functor : ∏ (A B C : category) (F : functor A B) (g : graph) (d : diagram g [B, C]) (G : [B, C]) (ccG : cocone d G), (∏ b : B, ColimCocone (diagram_pointwise d b)) → preserves_colimit (pre_composition_functor A B C F) d G ccG. Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.preserves_colimit_pre_composition_functor. Defined. Lemma is_omega_cocont_pre_composition_functor : ∏ (A B C : category) (F : functor A B), Colims_of_shape nat_graph C → is_omega_cocont (pre_composition_functor A B C F). Proof. exact @UniMath.CategoryTheory.Chains.OmegaCocontFunctors.is_omega_cocont_pre_composition_functor. Defined. (** Theorem 43: Signature functor associated to a binding signature is ω-cocontinuous *) Lemma is_omega_cocont_BindingSigToSignature : ∏ (C : category) (BPC : BinProducts C) (BCC : BinCoproducts C) (TC : Terminal C), Colims_of_shape nat_graph C → (∏ F : functor_category C C, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) → ∏ (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C), is_omega_cocont (pr1 (BindingSigToSignature BPC BCC TC sig CC)). Proof. exact @UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.is_omega_cocont_BindingSigToSignature. Defined. (** Problem 45: Datatypes specified by binding signatures *) Definition DatatypeOfBindingSig : ∏ (C : category) (BPC : BinProducts C) (BCC : BinCoproducts C) (_ : Initial C) (TC : Terminal C) (_ : Colims_of_shape nat_graph C) (_ : ∏ (F : functor_category C C), is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C), Initial (FunctorAlg (Id_H C BCC (pr1 (BindingSigToSignature BPC BCC TC sig CC)))). Proof. exact @UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.DatatypeOfBindingSig. Defined. (** Theorem 48: Construction of a substitution operation on an initial algebra *) Definition InitHSS : ∏ (C : category) (CP : BinCoproducts C), Initial C → Colims_of_shape nat_graph C → ∏ H : UniMath.SubstitutionSystems.Signatures.Presignature C C C, is_omega_cocont (pr1 H) → hss_category CP H. Proof. exact @UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.InitHSS. Defined. Lemma isInitial_InitHSS : ∏ (C : category) (CP : BinCoproducts C) (IC : Initial C) (CC : Colims_of_shape nat_graph C) (H : UniMath.SubstitutionSystems.Signatures.Presignature C C C) (HH : is_omega_cocont (pr1 H)), isInitial (hss_category CP H) (InitHSS C CP IC CC H HH). Proof. exact @UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.isInitial_InitHSS. Defined. (** Section 4.2: Binding signatures to monads *) Definition BindingSigToMonad : ∏ (C : category) (BPC : BinProducts C), BinCoproducts C → Terminal C → Initial C → Colims_of_shape nat_graph C → (∏ F, is_omega_cocont (constprod_functor1 (BinProducts_functor_precat C C BPC) F)) → ∏ sig : BindingSig, Coproducts (BindingSigIndex sig) C → Monad C. Proof. exact @UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.BindingSigToMonad. Defined. (** Example 50: Untyped lambda calculus *) (* See: UniMath/SubstitutionSystems/LamFromBindingSig.v *) (** Example 51: Raw syntax of Martin-Löf type theory *) (* See: UniMath/SubstitutionSystems/MLTT79.v *) UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/Lam.v000066400000000000000000000430541451125700300243310ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Specification of an initial morphism of substitution systems from lambda calculus with explicit flattening to lambda calculus ************************************************************) (** version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory and WARNING: a big part of the previous development is commented out since the adaptation does to seem to be smooth here *) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Isos. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.LiftingInitial. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Section Lambda. Context (C : category). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variable terminal : Terminal C. Variable CC : BinCoproducts C. Variable CP : BinProducts C. Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CC. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let one : C := @TerminalObject C terminal. Variable KanExt : ∏ Z : precategory_Ptd C, RightKanExtension.GlobalRightKanExtensionExists C C (U Z) C. Let Lam_S : Signature _ _ _ := Lam_Sig C terminal CC CP. Let LamE_S : Signature _ _ _ := LamE_Sig C terminal CC CP. (* assume initial algebra for signature Lam *) Variable Lam_Initial : Initial (@category_FunctorAlg [C, C] (Id_H C CC Lam_S)). Let Lam := InitialObject Lam_Initial. (** bracket for Lam from the initial hss obtained via theorem 15+ *) Definition LamHSS_Initial : Initial (hss_category CC Lam_S). Proof. apply InitialHSS. - apply KanExt. - apply Lam_Initial. Defined. Let LamHSS := InitialObject LamHSS_Initial. (** extract constructors *) Definition Lam_Var : EndC ⟦functor_identity C, `Lam ⟧. Proof. exact (BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam). Defined. (* we later prefer leaving App and Abs bundled in the definition of LamE_algebra_on_Lam *) Definition Lam_App : [C, C] ⟦ (App_H C CP) `Lam , `Lam ⟧. Proof. exact (BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam)). Defined. Definition Lam_Abs : [C, C] ⟦ (Abs_H C terminal CC) `Lam, `Lam ⟧. Proof. exact (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam)). Defined. Definition Lam_App_Abs : [C, C] ⟦ (H C C C CC (App_H C CP) (Abs_H C terminal CC)) `Lam , `Lam ⟧. Proof. exact (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · alg_map _ Lam). Defined. (** * Definition of a "model" of the flattening arity in pure lambda calculus *) (** we need a flattening in order to get a model for LamE *) Definition Lam_Flatten : [C, C] ⟦ (Flat_H C) `Lam , `Lam ⟧. Proof. exact (prejoin_from_hetsubst (hetsubst_from_hss _ _ _ LamHSS)). Defined. (** now get a LamE-algebra *) Definition LamE_algebra_on_Lam : FunctorAlg (Id_H _ CC LamE_S). Proof. exists ((*ob_from_algebra_ob _ _*) `Lam). use (BinCoproductArrow (CPEndC _ _ )). + exact Lam_Var. + use (BinCoproductArrow (CPEndC _ _ )). * apply Lam_App_Abs. (* do NOT destruct and reassemble more, use App_Abs directly *) * apply Lam_Flatten. Defined. Lemma τ_LamE_algebra_on_Lam : τ LamE_algebra_on_Lam = BinCoproductArrow (CPEndC _ _ ) Lam_App_Abs Lam_Flatten. Proof. apply BinCoproductIn2Commutes. Defined. (** now define bracket operation for a given [Z] and [f] *) (** preparations for typedness *) Local Definition helper_to: (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam) --> (ptd_from_alg_functor CC _ Lam). Proof. use tpair. + apply (nat_trans_id _ ). + abstract (intro c; rewrite id_right ; apply BinCoproductIn1Commutes_left_dir; apply idpath). Defined. Local Definition helper_from: (ptd_from_alg_functor CC _ Lam) --> (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam). Proof. use tpair. + apply (nat_trans_id _ ). + abstract (intro c; rewrite id_right ; apply BinCoproductIn1Commutes_right_dir; apply idpath) . Defined. (** this iso does nothing, but is needed to make the argument to [fbracket] below well-typed *) (* maybe a better definition somewhere above could make this iso superfluous *) (* maybe don't need iso, but only morphism *) Local Definition bracket_property_for_LamE_algebra_on_Lam_helper : iso (ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam) (ptd_from_alg_functor CC _ Lam). Proof. unfold iso. exists helper_to. apply is_iso_from_is_z_iso. exists helper_from. abstract ( split; [ apply (invmap (eq_ptd_mor _ _)); apply nat_trans_eq; [apply homset_property |] ; intro c ; apply id_left | apply eq_ptd_mor_cat; (* idem *) apply (invmap (eq_ptd_mor _ _)) ; apply nat_trans_eq; [apply homset_property |]; intro c ; apply id_left ] ). Defined. (** WARNING: the rest is commented out since the adaptation to SimplifiedHSS is not yet clear *) (* Definition fbracket_for_LamE_algebra_on_Lam (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg_functor CC LamE_S LamE_algebra_on_Lam ⟧ ) : [C, C]⟦ functor_composite (U Z) `LamE_algebra_on_Lam, `LamE_algebra_on_Lam ⟧ . Proof. exact (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)). Defined. (** Main lemma: our "model" for the flatten arity in pure lambda calculus is compatible with substitution *) Lemma bracket_property_for_LamE_algebra_on_Lam (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f (fbracket_for_LamE_algebra_on_Lam Z f). Proof. (* Could we have this in a more declarative style? *) assert (Hyp := pr2 (pr1 (pr2 LamHSS _ (f · bracket_property_for_LamE_algebra_on_Lam_helper)))). apply parts_from_whole in Hyp. apply whole_from_parts. split. - (* the "easy" eta part *) apply pr1 in Hyp. apply (maponpaths (λ x, x · #U (inv_from_iso bracket_property_for_LamE_algebra_on_Lam_helper))) in Hyp. rewrite <- functor_comp in Hyp. rewrite <- assoc in Hyp. rewrite iso_inv_after_iso in Hyp. rewrite id_right in Hyp. etrans; [ exact Hyp |]. clear Hyp. fold (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)). unfold fbracket_for_LamE_algebra_on_Lam. match goal with |[ |- _· _ · ?h = _ ] => assert (idness : h = nat_trans_id _) end. { apply nat_trans_eq_alt. intro c. unfold functor_ptd_forget. apply id_left. } rewrite idness. clear idness. rewrite id_right. (* does not work: apply cancel_postcomposition. although the terms are of identical type: match goal with | [ |- _ · ?l = _ ] => let ty:= (type of l) in idtac ty end. (* ([C, C] hs ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS) :[C, C] hs, LamHSS ⟧) *) match goal with | [ |- _ = _ · ?l ] => let ty:= (type of l) in idtac ty end. (* ([C, C] hs ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS) :[C, C] hs, LamHSS ⟧) *) *) apply nat_trans_eq_alt. intro c. apply cancel_postcomposition. apply BinCoproductIn1Commutes_right_dir. apply idpath. (* this proof did not work with pointedness but with brute force *) - (* now the difficult case of the domain-specific constructors *) destruct Hyp as [_ Hyp2]. fold (fbracket LamHSS (f · bracket_property_for_LamE_algebra_on_Lam_helper)) in Hyp2. unfold fbracket_for_LamE_algebra_on_Lam. apply nat_trans_eq_alt. intro c. (* from here slightly interesting, because it is crucial to see that the τ considered here is a BinCoproduct arrow *) rewrite τ_LamE_algebra_on_Lam. etrans; [ apply cancel_postcomposition ; apply BinCoproductOfArrows_comp |]. etrans; [ apply precompWithBinCoproductArrow |]. apply pathsinv0. (* showing that a diagram of coproduct arrows splits into two is slightly cumbersome, but a general theorem seems difficult to formulate instead we apply [BinCoproductArrowUnique] and then use the coproduct beta laws in each branch; this gives precisely what we want *) apply BinCoproductArrowUnique. + etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } assert (T:= nat_trans_eq_pointwise Hyp2 c). clear Hyp2. apply pathsinv0. assumption. (* There should be a more general hypothesis than 'Hyp' defined above, one where one has a quantification over maps 'f', no? *) + clear Hyp2. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } unfold Lam_Flatten. (* from here on 'simpl' is feasible after some opacification, at least *) Opaque fbracket. Opaque LamHSS. set (X := f · bracket_property_for_LamE_algebra_on_Lam_helper). assert (TT := compute_fbracket C CC Lam_S LamHSS(Z:=Z)). simpl in *. assert (T3 := TT X); clear TT. unfold X; unfold X in T3; clear X. do 2 rewrite id_left. Local Notation "⦃ f ⦄" := (fbracket _ f)(at level 0). (* written '\{{' and '\}}', respectively *) set (Tη := ptd_from_alg _ ). destruct Z as [Z e]. simpl in *. set (T := Lam). (* now we want to rewrite with T3 in 3 places *) assert (T3' := nat_trans_eq_pointwise T3 c). simpl in *. match goal with |[ T3' : _ = ?f |- ?a · _ = _ ] => transitivity (a · f) end. { apply maponpaths. apply T3'. } repeat rewrite assoc. (* apply cancel_postcomposition. (* that's a bad idea, because it fucks up use of third monad law and leads to something that is generally false *) *) etrans. 2: { do 2 apply cancel_postcomposition. do 3 apply maponpaths. apply pathsinv0, T3'. } clear T3'. apply pathsinv0. assert (T3' := nat_trans_eq_pointwise T3 (pr1 T c)). simpl in T3'. rewrite id_right in T3'. etrans. { apply cancel_postcomposition. apply maponpaths. exact T3'. } clear T3'. apply pathsinv0. destruct f as [f fptdmor]. simpl in *. repeat rewrite assoc. rewrite <- (functor_comp (pr1 T)). repeat rewrite <- assoc. etrans. 2: { apply cancel_postcomposition. apply maponpaths. apply (nat_trans_ax e). } repeat rewrite assoc. rewrite <- (functor_comp (pr1 T)). assert (X := fptdmor ((pr1 T) c)). clear T3 fptdmor. unfold functor_identity_data. simpl. apply pathsinv0. etrans. { do 2 apply cancel_postcomposition. apply maponpaths. repeat rewrite <- assoc. do 2 apply maponpaths. apply X. } clear X. assert (X := Monad_law_2_from_hss _ CC Lam_S LamHSS ((pr1 T) c)). unfold μ_0 in X. unfold μ_2 in X. change (pr1 ⦃ identity (ptd_from_alg (pr1 LamHSS)) ⦄ c) with (prejoin_from_hetsubst LamHSS c). (* does not do anything *) etrans. { do 2 apply cancel_postcomposition. apply maponpaths. apply assoc. } rewrite (functor_comp (pr1 T)). repeat rewrite <- assoc. match goal with |[ X : ?e = _ |- _ · (?a · (?b · _)) = _ ] => assert (X' : e = a · b) end. { apply cancel_postcomposition. apply maponpaths. cbn. apply pathsinv0, BinCoproductIn1Commutes. } rewrite X' in X. clear X'. etrans. { apply maponpaths. rewrite assoc. apply cancel_postcomposition. apply X. } clear X. rewrite id_left. assert (μ_2_nat := nat_trans_ax (μ_2 C CC Lam_S LamHSS)). assert (X := μ_2_nat _ _ (f c · identity (pr1 Lam c))). unfold μ_2 in X. etrans. 2: { rewrite assoc. apply cancel_postcomposition. apply X. } clear X. rewrite functor_comp. repeat rewrite <- assoc. apply maponpaths. assert (X := third_monad_law_from_hss _ CC Lam_S LamHSS). assert (X' := nat_trans_eq_pointwise X). clear X. simpl in X'. etrans; [ apply X' |]. clear X'. apply cancel_postcomposition. apply id_left. Qed. (** * Uniqueness of the bracket operation *) (** That is a consequence of uniqueness of that operation for a larger signature, namely for that of lambda calculus with flattening. We thus only have to extract the relevant parts, which is still a bit cumbersome. *) Lemma bracket_for_LamE_algebra_on_Lam_unique (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (` LamE_algebra_on_Lam), `LamE_algebra_on_Lam ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f h, t = tpair (λ h : [C, C] ⟦ functor_composite (U Z) (` LamE_algebra_on_Lam), `LamE_algebra_on_Lam ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) _ f h) (fbracket_for_LamE_algebra_on_Lam Z f) (bracket_property_for_LamE_algebra_on_Lam Z f). Proof. intro t. apply subtypePath. - intro; apply (isaset_nat_trans (homset_property C)). - simpl. destruct t as [t Ht]; simpl. unfold fbracket_for_LamE_algebra_on_Lam. apply (fbracket_unique LamHSS). split. + apply parts_from_whole in Ht. destruct Ht as [H1 _]. apply nat_trans_eq_alt. intro c. assert (HT := nat_trans_eq_pointwise H1 c). simpl. rewrite id_right. etrans; [ apply HT |]. simpl. repeat rewrite assoc. apply cancel_postcomposition. apply BinCoproductIn1Commutes. + apply parts_from_whole in Ht. destruct Ht as [_ H2]. apply nat_trans_eq_alt. intro c. assert (HT := nat_trans_eq_pointwise H2 c). match goal with |[H2 : ?e = ?f |- _ ] => assert (X: BinCoproductIn1 _ · e = BinCoproductIn1 _ · f) end. { apply maponpaths . assumption. } clear HT. clear H2. match goal with |[X : _ = ?f |- _ ] => transitivity f end. 2: { rewrite τ_LamE_algebra_on_Lam. etrans; [apply assoc |]. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } match goal with |[X : ?e = _ |- _ ] => transitivity e end. 2: apply X. rewrite τ_LamE_algebra_on_Lam. apply pathsinv0. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply assoc. } etrans. { apply cancel_postcomposition. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } repeat rewrite <- assoc. etrans. { apply maponpaths. apply assoc. } etrans. { apply maponpaths. apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans. { apply maponpaths. apply assoc'. } simpl. do 2 apply maponpaths. apply BinCoproductIn1Commutes. Qed. Definition bracket_for_LamE_algebra_on_Lam_at (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg LamE_algebra_on_Lam ⟧) : bracket_at C CC LamE_S (nat_trans_fix_snd_arg _ _ _ _ _ (theta LamE_S) Z) LamE_algebra_on_Lam f. Proof. use tpair. - exists (fbracket_for_LamE_algebra_on_Lam Z f). apply (bracket_property_for_LamE_algebra_on_Lam Z f). - simpl; apply bracket_for_LamE_algebra_on_Lam_unique. Defined. Definition bracket_for_LamE_algebra_on_Lam : bracket (theta LamE_S) LamE_algebra_on_Lam. Proof. intros Z f. simpl. apply bracket_for_LamE_algebra_on_Lam_at. Defined. Definition LamE_model_on_Lam : hss CC LamE_S. Proof. exists LamE_algebra_on_Lam. exact bracket_for_LamE_algebra_on_Lam. Defined. (* assume initial algebra for signature LamE *) Variable LamE_Initial : Initial (@category_FunctorAlg [C, C] (Id_H C CC LamE_S)). Definition LamEHSS_Initial : Initial (hss_category CC LamE_S). Proof. apply InitialHSS. - apply KanExt. - apply LamE_Initial. Defined. Let LamEHSS := InitialObject LamEHSS_Initial. (** * Specification of a morphism from lambda calculus with flattening to pure lambda calculus *) Definition FLATTEN : (hss_category CC LamE_S) ⟦LamEHSS, LamE_model_on_Lam⟧ := InitialArrow _ _ . *) End Lambda. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/LamFromBindingSig.v000066400000000000000000000223361451125700300271130ustar00rootroot00000000000000(** Obtain the lambda calculus and a substitution monad on Set from the signature { [0,0], [1] }. Written by: Anders Mörtberg, 2016 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.limits.graphs.limits. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Local Open Scope cat. Section Lam. (** A lot of notations and preliminary definitions *) Local Infix "::" := (@cons nat). Local Notation "[]" := (@nil nat) (at level 0, format "[]"). Local Notation "'HSET2'":= [HSET, HSET]. Local Notation "'Id'" := (functor_identity _). Local Notation "F * G" := (H HSET HSET HSET BinProductsHSET F G). Local Notation "F + G" := (BinSumOfSignatures.H _ _ _ _ _ _ BinCoproductsHSET F G). Local Notation "'_' 'o' 'option'" := (ℓ (option_functor BinCoproductsHSET TerminalHSET)) (at level 10). Local Definition BinProductsHSET2 : BinProducts HSET2. Proof. apply (BinProducts_functor_precat _ _ BinProductsHSET). Defined. Local Notation "x ⊗ y" := (BinProductObject _ (BinProductsHSET2 x y)). Let precomp_option X := (pre_composition_functor _ _ HSET (option_functor BinCoproductsHSET TerminalHSET) X). Local Notation "X + 1" := (precomp_option X) (at level 50). Local Notation "'1'" := (functor_identity HSET). (** * The lambda calculus from a binding signature *) (** The signature of the lambda calculus: { [0,0], [1] } *) Definition LamSig : BindingSig := make_BindingSig isasetbool (λ b, if b then 0 :: 0 :: [] else 1 :: [])%nat. (** The signature with strength for the lambda calculus *) Definition LamSignature : Signature HSET _ _ := BindingSigToSignatureHSET LamSig. Let Id_H := Id_H _ BinCoproductsHSET. Definition LamFunctor : functor HSET2 HSET2 := Id_H LamSignature. Lemma lambdaFunctor_Initial : Initial (FunctorAlg LamFunctor). Proof. apply (SignatureInitialAlgebraHSET (Presignature_Signature LamSignature)), is_omega_cocont_BindingSigToSignatureHSET. Defined. Definition LamMonad : Monad HSET := BindingSigToMonadHSET LamSig. Definition LC : HSET2 := alg_carrier _ (InitialObject lambdaFunctor_Initial). Let LC_mor : HSET2⟦LamFunctor LC,LC⟧ := alg_map _ (InitialObject lambdaFunctor_Initial). Let LC_alg : algebra_ob LamFunctor := InitialObject lambdaFunctor_Initial. Definition var_map : HSET2⟦1,LC⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition app_map : HSET2⟦LC ⊗ LC,LC⟧ := CoproductIn bool HSET2 (Coproducts_functor_precat _ _ _ _ _) true · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition lam_map : HSET2⟦LC + 1,LC⟧ := CoproductIn bool HSET2 (Coproducts_functor_precat _ _ _ _ _) false · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · LC_mor. Definition make_lambdaAlgebra X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : algebra_ob LamFunctor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intro b; induction b. - apply fapp. - apply flam. Defined. Definition foldr_map X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : algebra_mor _ LC_alg (make_lambdaAlgebra X fvar fapp flam). Proof. apply (InitialArrow lambdaFunctor_Initial (make_lambdaAlgebra X fvar fapp flam)). Defined. Lemma foldr_var X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. apply id_left. Defined. (* Lemma foldr_var_pt X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) (A : HSET) (x : pr1 A) : *) (* pr1 (pr1 (foldr_map X fvar fapp flam)) A (pr1 var_map A x) = pr1 fvar A x. *) (* Proof. *) (* set (H := (eqtohomot (nat_trans_eq_pointwise (foldr_var X fvar fapp flam) A) x)). *) (* (* now rewrite foldr_var. *) *) (* (* Arguments foldr_map : simpl never. *) *) (* (* Arguments alg_carrier : simpl never. *) *) (* (* Arguments var_map : simpl never. *) *) (* cbn in *. *) (* apply H. *) (* Qed. *) Lemma foldr_app X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : app_map · foldr_map X fvar fapp flam = # (pr1 (Id * Id)) (foldr_map X fvar fapp flam) · fapp. Proof. assert (F := maponpaths (λ x, CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) true · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. etrans; [apply F|]. rewrite assoc. etrans. { eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. } rewrite assoc. etrans. { eapply @cancel_postcomposition. eapply @cancel_postcomposition. apply (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ i, pr1 (Arity_to_Signature BinProductsHSET BinCoproductsHSET TerminalHSET (BindingSigMap LamSig i)) `LC_alg))). } rewrite <- assoc. etrans; [eapply maponpaths, BinCoproductIn2Commutes|]. rewrite <- assoc. etrans; eapply maponpaths. - exact (CoproductInCommutes _ _ _ _ _ _ true). - apply idpath. Defined. Lemma foldr_lam X (fvar : HSET2⟦1,X⟧) (fapp : HSET2⟦X ⊗ X,X⟧) (flam : HSET2⟦X + 1,X⟧) : lam_map · foldr_map X fvar fapp flam = # (pr1 (_ o option)) (foldr_map X fvar fapp flam) · flam. Proof. assert (F := maponpaths (λ x, CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) false · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. etrans; [apply F|]. rewrite assoc. etrans. { eapply cancel_postcomposition. rewrite <- assoc. eapply maponpaths, BinCoproductOfArrowsIn2. } rewrite assoc. etrans. { eapply @cancel_postcomposition, @cancel_postcomposition. apply (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ i, pr1 (Arity_to_Signature BinProductsHSET BinCoproductsHSET TerminalHSET (BindingSigMap LamSig i)) `LC_alg))). } rewrite <- assoc. etrans. { eapply maponpaths, BinCoproductIn2Commutes. } rewrite <- assoc. etrans; eapply maponpaths. - exact (CoproductInCommutes _ _ _ _ _ _ false). - apply idpath. Defined. Local Notation "'1'" := (TerminalHSET). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoproductsHSET a b)). Local Notation "x ⊛ y" := (BinProductObject _ (BinProductsHSET x y)) (at level 60). (** This makes cbn not unfold things too much below *) Arguments LamMonad : simpl never. Arguments BinCoproductObject : simpl never. Definition substLam (X : HSET) : HSET⟦LamMonad (1 ⊕ X) ⊛ LamMonad X, LamMonad X⟧. Proof. intro H. set (f := monadSubst LamMonad BinCoproductsHSET TerminalHSET X). set (g := λ (_ : unit), pr2 H). cbn in H, f, g. apply (f g (pr1 H)). Defined. End Lam. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/LamHSET.v000066400000000000000000000064411451125700300250140ustar00rootroot00000000000000(** Instantiate the hypotheses of InitialHSS with Lam for HSET. Written by: Anders Mörtberg, 2016 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.Chains.All. Section LamHSET. Let Lam_S : Signature HSET _ _ := Lam_Sig HSET TerminalHSET BinCoproductsHSET BinProductsHSET. Local Notation "'EndHSET'":= ([HSET, HSET]) . Local Lemma is_omega_cocont_Lam_S : is_omega_cocont Lam_S. Proof. apply is_omega_cocont_Lam. * apply is_omega_cocont_constprod_functor1. apply Exponentials_functor_HSET. * apply ColimsHSET_of_shape. Defined. Lemma Lam_Initial_HSET : Initial (category_FunctorAlg (Id_H _ BinCoproductsHSET Lam_S)). Proof. use colimAlgInitial. - apply (Initial_functor_precat _ _ InitialHSET). - unfold Id_H, Const_plus_H. apply is_omega_cocont_BinCoproduct_of_functors. + apply is_omega_cocont_constant_functor. + apply is_omega_cocont_Lam_S. - apply ColimsFunctorCategory_of_shape; apply ColimsHSET_of_shape. Defined. (* Lemma KanExt_HSET : ∏ Z : precategory_Ptd HSET has_homsets_HSET, *) (* RightKanExtension.GlobalRightKanExtensionExists HSET HSET *) (* (U Z) HSET has_homsets_HSET has_homsets_HSET. *) (* Proof. *) (* intro Z. *) (* apply RightKanExtension_from_limits, LimsHSET. *) (* Defined. *) Definition LamHSS_Initial_HSET : Initial (hss_category BinCoproductsHSET Lam_S). Proof. apply InitialHSS. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_Lam_S. Defined. Definition LamMonad : Monad HSET. Proof. use Monad_from_hss. - apply BinCoproductsHSET. - apply Lam_S. - apply LamHSS_Initial_HSET. Defined. End LamHSET. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/LiftingInitial.v000066400000000000000000000721461451125700300265320ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Construction of a substitution system from an initial algebra - Proof that the substitution system constructed from an initial algebra is an initial substitution system version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is very close to the homonymous file in the parent directory basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated ************************************************************) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Coercion alg_carrier : algebra_ob >-> ob. Section category_Algebra. Context (C : category) (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Variable KanExt : ∏ Z : Ptd, GlobalRightKanExtensionExists _ _ (U Z) C. Variable H : Presignature C C C. Let θ := theta H. Definition Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. (* := sum_of_functors CPEndC (constant_functor _ _ X) H. *) Definition Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Let Alg : category := FunctorAlg Id_H. Variable IA : Initial Alg. Definition SpecializedGMIt (Z : Ptd) (X : EndC) : ∏ (G : functor [C, C] [C, C]) (ρ : [C, C] ⟦ G X, X ⟧) (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G), ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), X ⟧, # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h = θ (` (InitialObject IA)) · # G h · ρ := SpecialGenMendlerIteration _ _ IA EndC X _ (KanExt Z) . Definition θ_in_first_arg (Z: Ptd) : functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z ⟹ functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z := nat_trans_fix_snd_arg _ _ _ _ _ θ Z. Definition InitAlg : Alg := InitialObject IA. Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg. Local Lemma aux_iso_1_is_nat_trans (Z : Ptd) : is_nat_trans (functor_composite Id_H (ℓ (U Z))) (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (U Z) (functor_identity C)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. etrans; [apply BinCoproductOfArrows_comp |]. etrans. 2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. } apply maponpaths_12. - etrans; [ apply id_left |]. apply pathsinv0. apply id_right. - rewrite id_right. rewrite id_left. rewrite (functor_id (H X)). apply pathsinv0, id_left. Qed. Definition aux_iso_1 (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact (aux_iso_1_is_nat_trans Z). Defined. Local Lemma aux_iso_1_inv_is_nat_trans (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) ) (functor_composite Id_H (ℓ (U Z))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (functor_identity C) (U Z)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. etrans; [apply BinCoproductOfArrows_comp |]. etrans. 2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. } apply maponpaths_12. - rewrite id_right. apply pathsinv0. apply id_right. - rewrite (functor_id (H X)). do 2 rewrite id_left. apply id_right. Qed. Local Definition aux_iso_1_inv (Z: Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), functor_composite Id_H (ℓ (U Z)) ⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact (aux_iso_1_inv_is_nat_trans Z). Defined. (* Definition G_Thm15 (X : EndC) := coproduct_functor _ _ CPEndC (constant_functor _ _ X) H. *) Local Lemma aux_iso_2_inv_is_nat_trans (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) ) (functor_composite (ℓ (U Z)) (Const_plus_H (U Z))) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite (@id_left EndC). rewrite (@id_right EndC). apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)). + apply idpath. + unfold functor_fix_snd_arg_mor; simpl. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c. simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition aux_iso_2_inv (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z) ) (Const_plus_H (U Z)) ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (aux_iso_2_inv_is_nat_trans Z). Defined. Definition θ'_Thm15 (Z: Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ := BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_category EndC EndC)) (θ_in_first_arg Z). Definition ρ_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧ := @BinCoproductArrow EndC _ _ (CPEndC (U Z) (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) f (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)). Definition SpecializedGMIt_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), pr1 InitAlg ⟧, # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h = pr1 ((aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z)) (` (InitialObject IA)) · # (Const_plus_H (U Z)) h · ρ_Thm15 Z f := SpecializedGMIt Z (pr1 InitAlg) (Const_plus_H (U Z)) (ρ_Thm15 Z f) (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z). Definition bracket_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), `InitAlg ⟧ := pr1 (pr1 (SpecializedGMIt_Thm15 Z f)). Notation "⦃ f ⦄" := (bracket_Thm15 _ f) (at level 0). (* we prove the individual components for ease of compilation *) Lemma bracket_Thm15_ok_part1 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧): f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt. intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))). assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_ ⟹ _)) _)· m) h_eq); clear h_eq. simpl in h_eq'. assert (h_eq1' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (BinCoproductIn1 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c); clear h_eq1'. (* match goal right in the beginning in contrast with earlier approach - suggestion by Benedikt *) match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path f end. - clear h_eq1'_inst. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data ; simpl. repeat rewrite <- assoc . apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite (@id_left EndC). rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite (@id_left EndC). apply BinCoproductIn1Commutes_right_dir. apply idpath. - rewrite <- h_eq1'_inst. clear h_eq1'_inst. apply BinCoproductIn1Commutes_left_in_ctx_dir. unfold nat_trans_id; simpl. rewrite id_left. repeat rewrite (id_left EndEndC). repeat rewrite (id_left EndC). unfold functor_fix_snd_arg_ob. repeat rewrite assoc. (* apply maponpaths. *) apply idpath. Qed. Lemma bracket_Thm15_ok_part2 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧): (theta H) ((alg_carrier _ InitAlg) ⊗ Z) · # H ⦃f⦄ · τ InitAlg = # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt. intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))). assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_⟹_)) _)· m) h_eq); clear h_eq. (* simpl in h_eq'. (* until here same as in previous lemma *) *) assert (h_eq2' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (BinCoproductIn2 (CPEndC _ _))· m) h_eq'). clear h_eq'. assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c). clear h_eq2'. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path f end. - clear h_eq2'_inst. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold aux_iso_1; simpl. rewrite id_right. rewrite id_left. do 3 rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_id; simpl. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. rewrite <- assoc. apply maponpaths. eapply pathscomp0. 2: apply assoc. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. (* alternative with slightly less precise control: *) (* do 4 rewrite <- assoc. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* rewrite id_left. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* apply BinCoproductIn2Commutes_right_in_ctx_dir. *) (* unfold nat_trans_fix_snd_arg_data. *) (* rewrite id_left. *) (* apply BinCoproductIn2Commutes_right_in_double_ctx_dir. *) (* do 2 rewrite <- assoc. *) (* apply maponpaths. *) (* apply maponpaths. *) (* apply pathsinv0. *) (* apply BinCoproductIn2Commutes. *) (* *) - rewrite <- h_eq2'_inst. clear h_eq2'_inst. apply BinCoproductIn2Commutes_left_in_ctx_dir. repeat rewrite id_left. apply assoc. Qed. Lemma bracket_Thm15_ok (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧): bracket_property_parts (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f ⦃f⦄. Proof. split. + exact (bracket_Thm15_ok_part1 Z f). + exact (bracket_Thm15_ok_part2 Z f). Qed. Lemma bracket_Thm15_ok_cor (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧): bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f (bracket_Thm15 Z f). Proof. apply whole_from_parts. apply bracket_Thm15_ok. Qed. Local Lemma foo' (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h, t = tpair (λ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h) ⦃f⦄ (bracket_Thm15_ok_cor Z f). Proof. intros [h' h'_eq]. apply subtypePath. - intro. unfold bracket_property. apply (isaset_nat_trans (homset_property C)). - simpl. apply parts_from_whole in h'_eq. (* destruct h'_eq as [h'_eq1 h'_eq2]. *) unfold bracket_Thm15. apply path_to_ctr. apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data. repeat rewrite (@id_left EndC). rewrite id_right. repeat rewrite <- @assoc. etrans. 2: { eapply pathsinv0. apply postcompWithBinCoproductArrow. } apply BinCoproductArrowUnique. + destruct h'_eq as [h'_eq1 _ ]. (*clear h'_eq2.*) simpl. rewrite id_left. assert (h'_eq1_inst := nat_trans_eq_pointwise h'_eq1 c); clear h'_eq1. simpl in h'_eq1_inst. unfold coproduct_nat_trans_in1_data in h'_eq1_inst; simpl in h'_eq1_inst. rewrite <- @assoc in h'_eq1_inst. etrans. { eapply pathsinv0; exact h'_eq1_inst. } clear h'_eq1_inst. apply BinCoproductIn1Commutes_right_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. apply BinCoproductIn1Commutes_right_dir. apply idpath. + destruct h'_eq as [_ h'_eq2]. (*clear h'_eq2.*) assert (h'_eq2_inst := nat_trans_eq_pointwise h'_eq2 c); clear h'_eq2. simpl in h'_eq2_inst. unfold coproduct_nat_trans_in2_data in h'_eq2_inst; simpl in h'_eq2_inst. apply pathsinv0 in h'_eq2_inst. rewrite <- assoc in h'_eq2_inst. etrans; [ exact h'_eq2_inst |]. clear h'_eq2_inst. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. unfold nat_trans_fix_snd_arg_data; simpl. do 2 rewrite <- assoc. apply maponpaths. rewrite <- assoc. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. Qed. Definition bracket_for_InitAlg : bracket θ InitAlg. Proof. intros Z f. use tpair. - use tpair. + exact (bracket_Thm15 Z f). + exact (bracket_Thm15_ok_cor Z f). (* B: better to prove the whole outside, and apply it here *) (* when the first components were not opaque, the following proof became extremely slow *) - simpl; apply foo'. Defined. Definition InitHSS : hss_category CP H. Proof. (* red. (* FORBIDDEN, otherwise universe problem when checking the definition *) unfold hss_precategory; simpl. *) exists (InitAlg). exact bracket_for_InitAlg. Defined. Local Definition Ghat : EndEndC := Const_plus_H (pr1 InitAlg). Definition constant_nat_trans (C' D : category) (d d' : D) (m : d --> d') : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧. Proof. exists (λ _, m). abstract ( intros ? ? ? ; intermediate_path m ; [ apply id_left | apply pathsinv0 ; apply id_right] ). Defined. Definition thetahat_0 (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧): EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ . Proof. exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (constant_nat_trans _ _ _ _ f) (θ_in_first_arg Z)). Defined. Local Definition iso1' (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)) ⟧. Proof. exact (aux_iso_1 Z). Defined. Local Lemma is_nat_trans_iso2' (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)))) (functor_composite (ℓ (U Z)) Ghat) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X) ((θ_target H) (X ⊗ Z))) : functor C C)). Proof. intros X X' α. rewrite (@id_left EndC). rewrite (@id_right EndC). apply nat_trans_eq_alt. intro c; simpl. unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)). - apply idpath. - unfold functor_fix_snd_arg_mor; simpl. revert c. apply nat_trans_eq_pointwise. apply maponpaths. apply nat_trans_eq_alt. intro c. simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition iso2' (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z)) Ghat ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (is_nat_trans_iso2' Z). Defined. Definition thetahat (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), functor_composite (ℓ (U Z)) (Ghat) ⟧. Proof. exact (iso1' Z · thetahat_0 Z f · iso2' Z). Defined. Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X. Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) : functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg)) ⟹ functor_composite (functor_opp (ℓ (U Z))) (Yon X) . Proof. use tpair. - intro Y. intro a. exact (a · b). - abstract ( intros ? ? ?; simpl; apply funextsec; intro; unfold yoneda_objects_ob; simpl; unfold compose; simpl; apply nat_trans_eq; [ apply homset_property |]; simpl; intro; apply assoc'). Defined. Lemma ishssMor_InitAlg (T' : hss CP H) : @ishssMor C CP H InitHSS T' (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. set (β0 := InitialArrow IA (pr1 T')). match goal with | [|- _ · ?b = _ ] => set (β := b) end. set ( rhohat := BinCoproductArrow (CPEndC _ _ ) β (tau_from_alg T') : pr1 Ghat T' --> T'). set (X:= SpecializedGMIt Z _ Ghat rhohat (thetahat Z f)). intermediate_path (pr1 (pr1 X)). - set (TT:= fusion_law _ _ IA _ (pr1 InitAlg) T' _ (KanExt Z)). set (Psi := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Const_plus_H (U Z)) (ρ_Thm15 Z f) (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z) ). set (T2 := TT Psi). set (T3 := T2 (ℓ (U Z)) (KanExt Z)). set (Psi' := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Ghat) (rhohat) (iso1' Z · thetahat_0 Z f · iso2' Z) ). set (T4 := T3 Psi'). set (Φ := (Phi_fusion Z T' β)). set (T5 := T4 Φ). intermediate_path (Φ _ (fbracket InitHSS Z f)). + apply idpath. + eapply pathscomp0. 2: { apply T5. (* hypothesis of fusion law *) apply funextsec. intro t. simpl. unfold compose. simpl. apply nat_trans_eq_alt. simpl. intro c. rewrite id_right. rewrite id_right. (* should be decomposed into two diagrams *) apply BinCoproductArrow_eq_cor. * (* first diagram *) clear TT T2 T3 T4 T5. do 5 rewrite <- assoc. apply BinCoproductIn1Commutes_left_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. * (* second diagram *) clear TT T2 T3 T4 T5. do 5 rewrite <- assoc. apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite (@id_left EndC). apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold nat_trans_fix_snd_arg_data. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_left_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. assert (H_nat_inst := functor_comp H t β). assert (H_nat_inst_c := nat_trans_eq_pointwise H_nat_inst c); clear H_nat_inst. { match goal with |[ H1 : _ = ?f |- _ = _· ?g · ?h ] => intermediate_path (f·g·h) end. + clear H_nat_inst_c. simpl. repeat rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_left_in_ctx_dir. simpl. unfold coproduct_nat_trans_in2_data, coproduct_nat_trans_data. assert (Hyp := τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))). assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. simpl in Hyp_c. etrans; [ eapply pathsinv0; exact Hyp_c |]. clear Hyp_c. apply maponpaths. apply pathsinv0. apply BinCoproductIn2Commutes. + rewrite <- H_nat_inst_c. apply idpath. } } apply cancel_postcomposition. apply idpath. - apply pathsinv0. apply path_to_ctr. (* now a lot of serious verification work to be done *) apply nat_trans_eq_alt. intro c. simpl. rewrite id_right. (* look at type: *) (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply BinCoproductArrow_eq_cor. + repeat rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. assert (ptd_mor_commutes_inst := ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)). apply ptd_mor_commutes_inst. } assert (fbracket_η_inst := fbracket_η T' (f · #U (ptd_from_alg_mor _ CP H β0))). assert (fbracket_η_inst_c := nat_trans_eq_pointwise fbracket_η_inst c); clear fbracket_η_inst. apply (!fbracket_η_inst_c). + (* now the difficult case *) repeat rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. eapply pathsinv0. assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0). assert (τ_part_of_alg_mor_inst_Zc := nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c)); clear τ_part_of_alg_mor_inst. apply τ_part_of_alg_mor_inst_Zc. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. { apply maponpaths. rewrite assoc. eapply pathsinv0. assert (fbracket_τ_inst := fbracket_τ T' (f · #U (ptd_from_alg_mor _ CP H β0))). assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst. apply fbracket_τ_inst_c. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. assert (Hyp: ((# (pr1 (ℓ(U Z))) (# H β))· (theta H) ((alg_carrier _ T') ⊗ Z)· # H (fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))) = θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) · # H (# (pr1 (ℓ(U Z))) β · fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))))). 2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. exact Hyp_c. } clear c. clear X. clear rhohat. rewrite (functor_comp H). rewrite assoc. apply cancel_postcomposition. fold θ. apply nat_trans_eq_alt. intro c. assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c). etrans ; [exact θ_nat_1_pointwise_inst | ]. clear θ_nat_1_pointwise_inst. simpl. apply maponpaths. rewrite horcomp_id_prewhisker. apply idpath. Qed. Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'. Proof. intro T'. exists (InitialArrow IA (pr1 T')). apply ishssMor_InitAlg. Defined. Lemma hss_InitMor_unique (T' : hss_category CP H): ∏ t : hss_precategory CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'. Proof. intro t. apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)). apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)). Qed. Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS. Proof. use make_isInitial. intro T. exists (hss_InitMor T). apply hss_InitMor_unique. Defined. Lemma InitialHSS : Initial (hss_category CP H). Proof. use (make_Initial InitHSS). apply isInitial_InitHSS. Defined. End category_Algebra. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/LiftingInitial_alt.v000066400000000000000000000626551451125700300273760ustar00rootroot00000000000000(** ********************************************************** Contents: - Construction of a substitution system from an initial algebra - Proof that the substitution system constructed from an initial algebra is an initial substitution system This file differs from LiftingInitial.v in the hypotheses. Here we use omega cocontinuity instead of Kan extensions. Written by: Anders Mörtberg, 2016 (adapted from LiftingInitial.v) version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is very close to the homonymous file in the parent directory basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated ************************************************************) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Local Coercion alg_carrier : algebra_ob >-> ob. Section category_Algebra. Variables (C : category) (CP : BinCoproducts C). Variables (IC : Initial C) (CC : Colims_of_shape nat_graph C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply ColimsFunctorCategory_of_shape, CC. Defined. Section fix_an_H. Context (H : functor [C, C] [C, C]) (HH : is_omega_cocont H). Definition Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. Definition Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Let Alg : precategory := FunctorAlg Id_H. Lemma is_omega_cocont_Id_H : is_omega_cocont Id_H. Proof. apply is_omega_cocont_BinCoproduct_of_functors; try apply functor_category_has_homsets. - apply is_omega_cocont_constant_functor. - apply HH. Defined. Definition InitAlg : Alg := InitialObject (colimAlgInitial InitialEndC is_omega_cocont_Id_H (Colims_of_shape_nat_graph_EndC _)). Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg. Section fix_a_Z. Context (Z : Ptd). Lemma isInitial_pre_comp : isInitial [C, C] (ℓ (U Z) InitialEndC). Proof. use make_isInitial; intros F. use tpair. - use tpair. + intros c; simpl; apply InitialArrow. + abstract (intros x y f; cbn; apply InitialArrowEq). - abstract (intros G; apply subtypePath; [ intros x; apply isaprop_is_nat_trans, homset_property | apply funextsec; intro c; apply InitialArrowUnique]). Defined. Local Lemma HU : is_omega_cocont (pre_composition_functor C C C (U Z)). Proof. apply is_omega_cocont_pre_composition_functor, CC. Defined. Definition SpecializedGMIt (X : EndC) : ∏ (G : functor [C, C] [C, C]) (ρ : [C, C] ⟦ G X, X ⟧) (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G), ∃! h : [C, C] ⟦ ℓ (U Z) (alg_carrier _ InitAlg), X ⟧, # (ℓ (U Z)) (alg_map Id_H InitAlg) · h = θ (alg_carrier _ InitAlg) · # G h · ρ := SpecialGenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC Id_H is_omega_cocont_Id_H X (ℓ (U Z)) isInitial_pre_comp HU. Context (prestrength_in_first_arg : PrestrengthForSignatureAtPoint _ _ _ H Z). Local Lemma aux_iso_1_is_nat_trans : is_nat_trans (functor_composite Id_H (ℓ (U Z))) (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (U Z) (functor_identity C)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt; intro c; simpl. etrans; [ apply BinCoproductOfArrows_comp |]. etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl. repeat rewrite id_right. rewrite (functor_id (H X)). do 2 rewrite id_left. apply idpath. Qed. Definition aux_iso_1 : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact aux_iso_1_is_nat_trans. Defined. Local Lemma aux_iso_1_inv_is_nat_trans : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) ) (functor_composite Id_H (ℓ (U Z))) (λ X : [C, C], BinCoproductOfArrows [C, C] (CPEndC (functor_composite (functor_identity C) (U Z)) ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z))) (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))). Proof. intros X X' α. apply nat_trans_eq_alt; intro c; simpl. etrans; [ apply BinCoproductOfArrows_comp |]. etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl. repeat rewrite id_right. rewrite (functor_id (H X)). repeat rewrite id_left. apply idpath. Qed. Local Definition aux_iso_1_inv : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), functor_composite Id_H (ℓ (U Z)) ⟧. Proof. use tpair. - intro X. exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))). - exact aux_iso_1_inv_is_nat_trans. Defined. Local Lemma aux_iso_2_inv_is_nat_trans : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) ) (functor_composite (ℓ (U Z)) (Const_plus_H (U Z))) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite id_left, id_right. apply nat_trans_eq_alt; intro c; simpl. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath. unfold functor_fix_snd_arg_mor; simpl. revert c; apply nat_trans_eq_pointwise, maponpaths. apply nat_trans_eq_alt; intro c; simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition aux_iso_2_inv : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z) ) (Const_plus_H (U Z)) ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact aux_iso_2_inv_is_nat_trans. Defined. Definition θ'_Thm15 : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ := BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_category EndC EndC)) prestrength_in_first_arg. Definition ρ_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧ := @BinCoproductArrow EndC _ _ (CPEndC (U Z) (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) f (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)). Definition SpecializedGMIt_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : ∃! h : [C, C] ⟦ ℓ (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, # (ℓ (U Z)) (alg_map Id_H InitAlg) · h = pr1 (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv) (pr1 InitAlg) · # (Const_plus_H (U Z)) h · ρ_Thm15 f := (SpecializedGMIt (pr1 InitAlg) (Const_plus_H (U Z)) (ρ_Thm15 f) (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv)). Definition bracket_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : [C, C]⟦ ℓ (U Z) (pr1 InitAlg), pr1 InitAlg ⟧ := pr1 (pr1 (SpecializedGMIt_Thm15 f)). Notation "⦃ f ⦄" := (bracket_Thm15 f) (at level 0). (* we prove the individual components for ease of compilation *) Lemma bracket_Thm15_ok_part1 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt; intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))). assert (h_eq' := maponpaths (λ m, ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq. assert (h_eq1' := maponpaths (λ m, (BinCoproductIn1 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c); clear h_eq1'. eapply pathscomp0, pathscomp0; [|apply (!h_eq1'_inst)|]; clear h_eq1'_inst. - apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl. rewrite id_left, <- !assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl. rewrite !id_left, !(@id_left EndC). now apply BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_dir. - apply BinCoproductIn1Commutes_left_in_ctx_dir; simpl. now rewrite id_left, assoc. Qed. Lemma bracket_Thm15_ok_part2 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : prestrength_in_first_arg (alg_carrier _ InitAlg) · # H ⦃f⦄ · τ InitAlg = # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄. Proof. apply nat_trans_eq_alt; intro c. assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))). assert (h_eq' := maponpaths (λ m, ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq. (* until here same as in previous lemma *) assert (h_eq2' := maponpaths (λ m, (BinCoproductIn2 (CPEndC _ _))· m) h_eq'); clear h_eq'. assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c); clear h_eq2'. eapply pathscomp0, pathscomp0; [|apply (!h_eq2'_inst)|]; clear h_eq2'_inst. - apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl. rewrite id_right, id_left, <- !assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. rewrite <- assoc; apply maponpaths. apply pathsinv0; simpl. rewrite <- assoc; apply maponpaths. now apply BinCoproductIn2Commutes. - apply BinCoproductIn2Commutes_left_in_ctx_dir. now rewrite id_left; apply assoc. Qed. Lemma bracket_Thm15_ok (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : bracket_property_parts prestrength_in_first_arg InitAlg f ⦃f⦄. Proof. split. + exact (bracket_Thm15_ok_part1 f). + exact (bracket_Thm15_ok_part2 f). Qed. Lemma bracket_Thm15_ok_cor (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : bracket_property prestrength_in_first_arg InitAlg f (bracket_Thm15 f). Proof. now apply whole_from_parts, bracket_Thm15_ok. Qed. Local Lemma bracket_unique (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1 InitAlg), pr1 InitAlg ⟧, bracket_property prestrength_in_first_arg InitAlg f h, t = tpair _ ⦃f⦄ (bracket_Thm15_ok_cor f). Proof. intros [h' h'_eq]; apply subtypePath; [intro; apply (isaset_nat_trans (homset_property C))|]. simpl; apply parts_from_whole in h'_eq. apply path_to_ctr, nat_trans_eq_alt; intro c. simpl; rewrite !(@id_left EndC), id_right, <- !assoc. etrans; [| eapply pathsinv0, postcompWithBinCoproductArrow ]. apply BinCoproductArrowUnique. + destruct h'_eq as [h'_eq1 _]; simpl. rewrite id_left, assoc. etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq1 c) |]. now apply BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir, BinCoproductIn1Commutes_right_dir. + destruct h'_eq as [_ h'_eq2]. rewrite assoc. etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq2 c) |]. apply BinCoproductIn2Commutes_right_in_ctx_dir. apply BinCoproductIn2Commutes_right_in_double_ctx_dir. simpl; rewrite <- !assoc. now apply maponpaths, maponpaths, pathsinv0, BinCoproductIn2Commutes. Qed. End fix_a_Z. End fix_an_H. Context (H : @Presignature C C C) (HH : is_omega_cocont H). Let Id_H := Id_H H. Let θ := theta H. Let InitAlg := InitAlg H HH. Let ptdInitAlg := ptdInitAlg H HH. Definition bracket_for_InitAlg : bracket θ InitAlg. Proof. intros Z f. use tpair. - use tpair. + exact (bracket_Thm15 H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f). + exact (bracket_Thm15_ok_cor H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f). (* B: better to prove the whole outside, and apply it here *) (* when the first components were not opaque, the following proof became extremely slow *) - cbn. apply bracket_unique. Defined. Definition InitHSS : hss_category CP H. Proof. (* red. (* FORBIDDEN, otherwise universe problem when checking the definition *) unfold hss_precategory; simpl. *) exists InitAlg. exact bracket_for_InitAlg. Defined. Local Definition Ghat : EndEndC := Const_plus_H H (pr1 InitAlg). Definition constant_nat_trans (C' D : category) (d d' : D) (m : D⟦d,d'⟧) : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧. Proof. exists (λ _, m). abstract (intros ? ? ?; intermediate_path m; [ apply id_left | apply pathsinv0, id_right]). Defined. Definition thetahat_0 (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (U Z)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)), BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧. Proof. exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (constant_nat_trans _ _ _ _ f) (nat_trans_fix_snd_arg _ _ _ _ _ θ Z)). Defined. Local Definition iso1' (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), BinCoproductObject (CPEndEndC (constant_functor _ _ (U Z)) (functor_fix_snd_arg _ _ _ (θ_source H) Z)) ⟧. Proof. exact (aux_iso_1 H Z). Defined. Local Lemma is_nat_trans_iso2' (Z : Ptd) : is_nat_trans (pr1 (BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)))) (functor_composite (ℓ (U Z)) Ghat) (λ X : [C, C], nat_trans_id (BinCoproductObject (CPEndC ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X) ((θ_target H) (X ⊗ Z))) :functor C C)). Proof. intros X X' α. rewrite id_left, id_right. apply nat_trans_eq_alt; intro c; simpl. unfold coproduct_nat_trans_data; simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl. apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath. unfold functor_fix_snd_arg_mor; simpl. revert c; apply nat_trans_eq_pointwise, maponpaths. apply nat_trans_eq_alt; intro c; simpl. rewrite (functor_id X). apply id_left. Qed. Local Definition iso2' (Z : Ptd) : EndEndC ⟦ BinCoproductObject (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg)) (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)), functor_composite (ℓ (U Z)) Ghat ⟧. Proof. use tpair. - intro X. exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) ) : functor C C)). - exact (is_nat_trans_iso2' Z). Defined. Definition thetahat (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)), functor_composite (ℓ (U Z)) (Ghat) ⟧. Proof. exact (iso1' Z · thetahat_0 Z f · iso2' Z). Defined. Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op"). Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X. Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) : functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg)) ⟹ functor_composite (functor_opp (ℓ (U Z))) (Yon X) . Proof. use tpair. - intros Y a. exact (a · b). - abstract (intros ? ? ?; simpl; apply funextsec; intro; unfold yoneda_objects_ob; simpl; unfold compose; simpl; apply nat_trans_eq; [apply homset_property |]; simpl; intro; apply assoc'). Defined. Let IA := colimAlgInitial InitialEndC (is_omega_cocont_Id_H H HH) (Colims_of_shape_nat_graph_EndC _). Lemma ishssMor_InitAlg (T' : hss CP H) : @ishssMor C CP H InitHSS T' (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ). Proof. intros Z f. set (β0 := InitialArrow IA (pr1 T')). match goal with | [|- _ · ?b = _ ] => set (β := b) end. set (rhohat := BinCoproductArrow (CPEndC _ _ ) β (tau_from_alg T') : pr1 Ghat T' --> T'). set (X:= SpecializedGMIt H HH Z _ Ghat rhohat (thetahat Z f)). intermediate_path (pr1 (pr1 X)). - set (TT := @fusion_law EndC InitialEndC Colims_of_shape_nat_graph_EndC Id_H (is_omega_cocont_Id_H H HH) _ (pr1 (InitAlg)) T'). set (Psi := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Const_plus_H H (U Z)) (ρ_Thm15 H HH Z f) (aux_iso_1 H Z · θ'_Thm15 H Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) · aux_iso_2_inv H Z) ). set (T2 := TT _ (HU Z) (isInitial_pre_comp Z) Psi). set (T3 := T2 (ℓ (U Z)) (HU Z)). set (Psi' := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Ghat) (rhohat) (iso1' Z · thetahat_0 Z f · iso2' Z) ). set (T4 := T3 (isInitial_pre_comp Z) Psi'). set (Φ := (Phi_fusion Z T' β)). set (T5 := T4 Φ). intermediate_path (Φ _ (fbracket InitHSS Z f)); try apply idpath. etrans; [| apply T5 ]; clear TT T2 T3 T4 T5 X. * now apply cancel_postcomposition. * (* hypothesis of fusion law *) apply funextsec; intro t. apply nat_trans_eq_alt; intro c; simpl. rewrite !id_right. (* should be decomposed into two diagrams *) apply BinCoproductArrow_eq_cor. + (* first diagram *) rewrite <- !assoc. apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_left_in_ctx_dir. rewrite <- assoc. apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. now apply BinCoproductIn1Commutes_right_dir. + (* second diagram *) rewrite <- !assoc. apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl; rewrite <- !assoc. apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- !assoc. etrans; [| eapply pathsinv0, cancel_postcomposition, (nat_trans_eq_pointwise (functor_comp H t β) c) ]. simpl; rewrite <- assoc. apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir. assert (Hyp_c := nat_trans_eq_pointwise (τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))) c). simpl in Hyp_c. etrans; [ eapply pathsinv0, Hyp_c |]. now apply maponpaths, pathsinv0, BinCoproductIn2Commutes. - apply pathsinv0, path_to_ctr. (* now a lot of serious verification work to be done *) apply nat_trans_eq_alt; intro c. simpl; rewrite id_right. (* look at type: *) (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply BinCoproductArrow_eq_cor. + rewrite <- !assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. simpl; rewrite <- assoc. etrans; [| apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir; simpl; rewrite id_left; apply BinCoproductIn1Commutes_right_dir, idpath ]. rewrite !assoc. assert (fbracket_η_inst_c := nat_trans_eq_pointwise (fbracket_η T' (f · #U(ptd_from_alg_mor _ CP H β0))) c). etrans; [| apply (!fbracket_η_inst_c) ]. apply cancel_postcomposition, (ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)). + (* now the difficult case *) repeat rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data. rewrite id_left. apply BinCoproductIn2Commutes_right_in_ctx_dir. unfold nat_trans_fix_snd_arg_data. simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. 2: { apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. } do 2 rewrite assoc. etrans. { apply cancel_postcomposition. eapply pathsinv0. assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0). assert (τ_part_of_alg_mor_inst_Zc := nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c)); clear τ_part_of_alg_mor_inst. apply τ_part_of_alg_mor_inst_Zc. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite <- assoc. etrans. { apply maponpaths. rewrite assoc. eapply pathsinv0. assert (fbracket_τ_inst := fbracket_τ T' (f · #U(ptd_from_alg_mor _ CP H β0))). assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst. apply fbracket_τ_inst_c. } simpl. unfold coproduct_nat_trans_in2_data. repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. assert (Hyp: ((# (pr1 (ℓ(U Z))) (# H β))· θ ((alg_carrier _ T') ⊗ Z)· # H (fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))) = θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) · # H (# (pr1 (ℓ(U Z))) β · fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))))). 2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp. exact Hyp_c. } clear c. clear X. clear rhohat. rewrite (functor_comp H). rewrite assoc. apply cancel_postcomposition. apply nat_trans_eq_alt; intro c. assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c). etrans; [ exact θ_nat_1_pointwise_inst |]. clear θ_nat_1_pointwise_inst. simpl. apply maponpaths. rewrite horcomp_id_prewhisker. apply idpath. Qed. Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'. Proof. intro T'. exists (InitialArrow IA (pr1 T')). apply ishssMor_InitAlg. Defined. Lemma hss_InitMor_unique (T' : hss_category CP H): ∏ t : hss_category CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'. Proof. intro t. apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)). apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)). Qed. Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS. Proof. use make_isInitial; intro T. exists (hss_InitMor T). apply hss_InitMor_unique. Defined. Lemma InitialHSS : Initial (hss_category CP H). Proof. apply (make_Initial InitHSS), isInitial_InitHSS. Defined. End category_Algebra. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/MLTT79.v000066400000000000000000000156171451125700300245640ustar00rootroot00000000000000(** This file constructs a substitution monad on Set from a binding signature for the syntax of Martin-Löf type theory a la "Constructive Mathematics and Computer Programming" (1979). Written by: Anders Mörtberg, 2016 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Local Infix "::" := (@cons nat). Local Notation "[]" := (@nil nat) (at level 0, format "[]"). Local Notation "'HSET2'":= [HSET, HSET]. Section preamble. Definition four_rec {A : UU} (a b c d : A) : stn 4 -> A. Proof. induction 1 as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction (nopathsfalsetotrue p). Defined. End preamble. Infix "++" := SumBindingSig. Section MLTT79. (** This is the syntax as presented on page 158: << Pi types (∏x:A)B [0,1] lambda (λx)b [1] application (c)a [0,0] Sigma types (∑x:A)B [0,1] pair (a,b) [0,0] pair-elim (Ex,y)(c,d) [0,2] Sum types A + B [0,0] inl i(a) [0] inr j(b) [0] sum-elim (Dx,y)(c,d,e) [0,1,1] Id types I(A,a,b) [0,0,0] refl r [] J J(c,d) [0,0] Fin types N_i [] Fin elems 0_i ... (i-1)_i [] ... [] (i times) Fin-elim R_i(c,c_0,...,c_(i-1)) [0,0,...,0] (i+1 zeroes) Nat N [] zero 0 [] suc a' [0] nat-elim (Rx,y)(c,d,e) [0,0,2] W-types (Wx∈A)B [0,1] sup sup(a,b) [0,0] W-elim (Tx,y,z)(c,d) [0,3] Universes U_0,U_1,... [],[],... >> *) (** Some convenient notations *) Local Notation "[0]" := (0 :: []). Local Notation "[1]" := (1 :: []). Local Notation "[0,0]" := (0 :: 0 :: []). Local Notation "[0,1]" := (0 :: 1 :: []). Local Notation "[0,2]" := (0 :: 2 :: []). Local Notation "[0,3]" := (0 :: 3 :: []). Local Notation "[0,0,0]" := (0 :: 0 :: 0 :: []). Local Notation "[0,0,2]" := (0 :: 0 :: 2 :: []). Local Notation "[0,1,1]" := (0 :: 1 :: 1 :: []). Definition PiSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [1] [0,0]). Definition SigmaSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [0,0] [0,2]). Definition SumSig : BindingSig := make_BindingSig (isasetstn 4) (four_rec [0,0] [0] [0] [0,1,1]). Definition IdSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,0,0] [] [0,0]). (** Define the arity of the eliminators for Fin by recursion *) Definition FinSigElim (n : nat) : list nat. Proof. induction n as [|n ih]. - apply [0]. - apply (0 :: ih). Defined. (** Define the signature of the constructors for Fin *) Definition FinSigConstructors (n : nat) : stn n -> list nat := λ _, []. (* The FinSig family is defined by recursion and decomposed into the type, the constructors and the eliminator *) (* Definition FinSig (n : nat) : BindingSig (unit ⨿ (stn n ⨿ unit)). *) (* Proof. *) (* induction 1 as [_|p]. *) (* - apply []. *) (* - induction p as [p|]. *) (* + apply (FinSigConstructors _ p). *) (* + apply (FinSigElim n). *) (* Defined. *) (** Uncurried version of the FinSig family *) Definition FinSigFun : (∑ n : nat, unit ⨿ (stn n ⨿ unit)) → list nat. Proof. induction 1 as [n p]. induction p as [_|p]. - apply []. - induction p as [p|]. + apply (FinSigConstructors _ p). + apply (FinSigElim n). Defined. Lemma isasetFinSig : isaset (∑ n, unit ⨿ (stn n ⨿ unit)). Proof. apply isaset_total2. - apply isasetnat. - intros. repeat apply isasetcoprod; try apply isasetunit. apply isasetstn. Qed. Lemma isdeceqFinSig : isdeceq (∑ n, unit ⨿ (stn n ⨿ unit)). Proof. apply isdeceq_total2. - apply isdeceqnat. - intros. repeat apply isdeceqcoprod; try apply isdecequnit. apply isdeceqstn. Defined. Definition FinSig : BindingSig := make_BindingSig isasetFinSig FinSigFun. Definition NatSig : BindingSig := make_BindingSig (isasetstn 4) (four_rec [] [] [0] [0,0,2]). Definition WSig : BindingSig := make_BindingSig (isasetstn 3) (three_rec [0,1] [0,0] [0,3]). Definition USig : BindingSig := make_BindingSig isasetnat (λ _, []). Let SigHSET := Signature HSET HSET HSET. (** The binding signature of MLTT79 *) Definition MLTT79Sig := PiSig ++ SigmaSig ++ SumSig ++ IdSig ++ FinSig ++ NatSig ++ WSig ++ USig. (* Check MLTT79Sig. *) Definition MLTT79Signature : SigHSET := BindingSigToSignatureHSET MLTT79Sig. Let Id_H := Id_H _ BinCoproductsHSET. Definition MLTT79Functor : functor HSET2 HSET2 := Id_H (Presignature_Signature MLTT79Signature). Definition MLTT79Monad : Monad HSET := BindingSigToMonadHSET MLTT79Sig. Lemma MLTT79Functor_Initial : Initial (FunctorAlg MLTT79Functor). Proof. apply SignatureInitialAlgebraHSET, is_omega_cocont_BindingSigToSignatureHSET. Defined. Definition MLTT79 : HSET2 := alg_carrier _ (InitialObject MLTT79Functor_Initial). Let MLTT79_mor : HSET2⟦MLTT79Functor MLTT79,MLTT79⟧ := alg_map _ (InitialObject MLTT79Functor_Initial). Let MLTT79_alg : algebra_ob MLTT79Functor := InitialObject MLTT79Functor_Initial. Definition var_map : HSET2⟦functor_identity HSET,MLTT79⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · MLTT79_mor. (* TODO: define the rest of the constructors and computation rules? *) End MLTT79. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/ModulesFromSignatures.v000066400000000000000000000475601451125700300301270ustar00rootroot00000000000000(** Reference : "Initial Semantics for Strengthened Signatures" (André Hirschowitz , Marco Maggesi) Let (H, θ) be a strengthened signature, M an endo-functor. If M has a structure of (left) module over a monad T, then it can be lifted to endow H(M) with a structure of module over T. Let T be the initial Id+H algebra. Then T is the initial representation in the sense of H&M. Note : A shorter proof of this statment could be formalized by using the proof of initiality in the category of heterogeneous substitution systems, provided we weaken the notion of heterogeneous substitution system so that the bracket associated to the functor is not unique. The proof of initiality in the category of "weak" heterogeneous substitution systems is the same as the one one already proved formally for the standard notion of heterogeneous substitution system. version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Monads.LModules. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Presheaf. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt. Require Import UniMath.CategoryTheory.limits.initial. (** A monad is a pointed endofunctor *) Definition ptd_from_mon {C:category} (T:Monad C) : category_Ptd C := ((T:functor C C),, η T). (** Let (Z, e : 1 -> Z) be a pointed endofunctor. Then e is a morphism (actually the initial morphism) in the category of pointed endofunctors *) Lemma is_ptd_mor_pt {C : category} (F : ptd_obj C) : is_ptd_mor _ (F:=id_Ptd C) (ptd_pt _ F). Proof. intro c; apply id_left. Qed. Definition ptd_mor_pt {C:category} (F:ptd_obj C) : ptd_mor _ (id_Ptd C) F := (ptd_pt _ F ,, is_ptd_mor_pt F). Local Notation σ := (lm_mult _). Section SignatureLiftModule. Context {C D : category} (H : Signature C D C). (** The forgetful functor from pointed endofunctors to endofunctors *) Local Notation "'U'" := (functor_ptd_forget C). (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Variables (T : Monad C) (M : LModule T C). Local Notation Mf := (M : functor _ _). Local Notation "'p' T" := (ptd_from_mon T) (at level 3). (** The pointed functor TT *) Let T2 := (ptd_compose _ (p T) (p T)) . (** The multiplication of a monad is a morphism of pointed endofunctors *) Lemma is_ptd_mor_μ : is_ptd_mor _ (F:= T2) (G:=p T) (μ T). Proof. intro c. unfold T2. unfold ptd_compose. rewrite functorial_composition_pre_post. cbn. rewrite <- assoc. etrans; [|apply id_right]. apply cancel_precomposition. apply Monad_law2. Qed. Definition ptd_mor_from_μ : ptd_mor _ T2 (p T) := (_ ,, is_ptd_mor_μ). Let strength_law1_pw M x := nat_trans_eq_pointwise (θ_Strength1_int_implies_θ_Strength1 _ (Sig_strength_law1 H ) M) x. (** A pointwise version of the second strength law with only one identity instead of two α_functor *) Lemma strength_law2_pw : ∏ (X : EndC) (Z Z' : Ptd) x, ((theta H) (X ⊗ (Z p• Z')) : nat_trans _ _) x = ((theta H) (X ⊗ Z') •• (U Z):nat_trans _ _) x · ((theta H) ((functor_compose (U Z') X) ⊗ Z):nat_trans _ _) x · (# H (identity (functor_compose (U Z ∙ U Z') X) : [C, C] ⟦ functor_compose (U Z) (U Z' ∙ X : [C, C]), functor_compose (U Z ∙ U Z') X ⟧) : nat_trans _ _) x. Proof. intros X Z Z' x. etrans; revgoals. { apply (nat_trans_eq_pointwise (θ_Strength2_int_implies_θ_Strength2 _ (Sig_strength_law2 H) X Z Z' _ (identity _) ) x). } etrans;[eapply pathsinv0;apply id_right|]. apply cancel_precomposition. apply pathsinv0. etrans. { eapply nat_trans_eq_pointwise. apply (functor_id H). } apply idpath. Qed. Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)). Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ). (** The module multiplication is given by Θ_M,T H(σ) H(M) T ------> H(MT) ------> H(M) *) Local Definition lift_lm_mult : [C,D] ⟦ T ∙ H Mf , H Mf⟧ := nat_trans_comp ((theta H) ((M : C ⟶ C),, ptd_from_mon T)) (# H (σ M)). Local Definition lift_LModule_data : LModule_data T D := tpair (fun x=> [C,D] ⟦ T ∙ x, x⟧) (H Mf) lift_lm_mult. Local Lemma lift_lm_mult_laws : LModule_laws _ lift_LModule_data. Proof. split. - intro c. etrans; [apply assoc|]. etrans. { apply cancel_postcomposition. apply ( θ_nat_2_pw Mf (id_Ptd C) (p T) (ptd_mor_pt _) c). } etrans. { apply cancel_postcomposition. rewrite horcomp_pre_post. rewrite (functor_comp H). etrans; [apply assoc|]. apply cancel_postcomposition. rewrite pre_whisker_identity; try assumption. apply strength_law1_pw. } etrans;[|apply id_right]. rewrite <- assoc. apply cancel_precomposition. etrans; [ apply functor_comp_pw|]. etrans; [|apply (nat_trans_eq_pointwise (functor_id H Mf))]. apply functor_cancel_pw. apply nat_trans_eq_alt. apply (LModule_law1). - intro c. cbn. etrans. { rewrite assoc. apply cancel_postcomposition. etrans; [ apply (θ_nat_2_pw Mf _ _ (ptd_mor_from_μ) c)|]. apply cancel_postcomposition. apply (strength_law2_pw Mf (p T) (p T)). } etrans; revgoals. { rewrite <- assoc. apply cancel_precomposition. rewrite assoc. apply cancel_postcomposition. eapply pathsinv0. apply (θ_nat_1_pw _ _ (σ M) (p T) c). } cbn. repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. etrans; revgoals. { eapply pathsinv0. apply (functor_comp_pw _ _ H). } etrans. { apply cancel_precomposition. apply (functor_comp_pw _ _ H). } etrans; [ apply (functor_comp_pw _ _ H)|]. apply functor_cancel_pw. apply nat_trans_eq_alt. intro x. cbn. unfold horcomp_data; simpl. repeat rewrite id_left. rewrite functor_id,id_right. apply LModule_law2. Qed. Local Definition lift_lmodule : LModule T D := (lift_LModule_data,, lift_lm_mult_laws). End SignatureLiftModule. Section InitialRep. (** ** Some variables and assumptions *) (** Assume having a precategory [C] whose hom-types are sets *) Variable C : category. Variable CP : BinCoproducts C. Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. (** Assume having a signature on [C] *) Variable H : Signature C C C. Let θ := theta H. Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)). Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H)). Let Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. Let Alg : category := FunctorAlg Id_H. (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . Local Notation "'p' T" := (ptd_from_alg T) (at level 3). Local Notation η := @eta_from_alg. (** Let [T] be a heterogeneous substitution system. Then [τ : H T --> T] is a module morphism *) Section TauModuleMorphism. Variable T : hss CP H. Local Notation T_mon := (Monad_from_hss _ _ _ T). Local Notation T_mod := (tautological_LModule T_mon). Local Notation HT_mod := (lift_lmodule H _ T_mod). Lemma τ_lmodule_laws : LModule_Mor_laws T_mon (T:=HT_mod) (T' := T_mod) (τ T). Proof. intro a. apply pathsinv0. (* It is precisely the square diagram satisfied by μ = { id } *) exact (nat_trans_eq_pointwise (fbracket_τ T (Z:= p T)(identity _ )) a). Qed. Definition τ_lmodule_mor : LModule_Mor _ _ _ := tpair (λ x, LModule_Mor_laws _ x) _ τ_lmodule_laws. End TauModuleMorphism. (** Let (M, τ_M) be a representation in the sense of Hirschowitz & Maggesi : - M is a monad - [τ_M : HM ---> M] is a module morphism Then there exists a unique monad morphism j : T --> M that is compatible with τ_M, τ_T where T is the initial HSS. In other words, T is the initial representation in the sense of H&M *) Variables (IC : Initial C) (CC : Colims_of_shape nat_graph C) (HH : is_omega_cocont H). Let T := InitHSS _ CP IC CC H HH. Local Notation T_alg := (alg_from_hetsubst _ _ _ (hetsubst_from_hss _ _ _ T)). Local Notation T_mon := (Monad_from_hss _ _ _ T). Local Notation T_func := (T_mon : functor _ _). Local Notation T_hss := (T:hss _ _). Section fix_a_representation. Variables (M : Monad C). Local Notation M_mod := (tautological_LModule M). Local Notation HM_mod := (lift_lmodule H _ M_mod). Variable (τ_M: LModule_Mor M HM_mod M_mod). Local Definition M_alg : Alg. Proof. apply (tpair (λ x, EndC ⟦ Id_H x, x ⟧) (M:functor _ _)). apply BinCoproductArrow. - apply Monads.η. - apply τ_M. Defined. (** j : T --> M is the initial Id+H-algebra morphism *) Let j : Alg ⟦T_alg, M_alg⟧ := InitialArrow _ M_alg. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply colimits.ColimsFunctorCategory_of_shape, CC. Defined. Let is_omega_cocont_Id_H' := LiftingInitial_alt.is_omega_cocont_Id_H C CP H HH. Local Notation j_mor := ((mor_from_algebra_mor _ j):nat_trans _ _). (** Following Ralph's proof : we want to prove the square diagram for the monad morphism induced by the initial algebra morphism j : T --> M : << jj TT ------> MM | | μ_T| | μ_M | | V V T ------> M j >> The strategy is to show that both paths of the diagram satisfy the characteristic equation of the same Mendler iterator. We use Lemma 8 from "Heteregenous substitution system revisited" (Benedikt Ahrens & Ralph Matthes) with the following parameters : X := M L Z := Z·T F Z := (Id+H) Z And for any Z : EndC, h : LZ -> X ψ_Z(h) := [j, τ_M ∘ H h ∘ Θ_Z,(T,η)] *) Let L := (pre_composition_functor C C C T_func). Let X := (M:functor _ _). (* inspired by LiftingInitial_alt *) Local Lemma HL : is_omega_cocont L. Proof. apply OmegaCocontFunctors.is_omega_cocont_pre_composition_functor, CC. Defined. Let isInitial_precomp' : isInitial [C, C] (L InitialEndC) := LiftingInitial_alt.isInitial_pre_comp C IC p T_hss : isInitial [C, C] (L InitialEndC). Local Definition ψ_pw (Z:[C,C]) : Core.hset_precategory ⟦ψ_source(D:=[C,C]) X L Z, ψ_target(D:=[C,C]) Id_H X L Z⟧ . Proof. intros h. cbn. apply (BinCoproductArrow (a:= `T_hss) (b:= functor_composite `T_hss (H Z)) (CPEndC _ _) (c:=X)). - apply j. - apply ((θ (Z ⊗ (p T_hss)))·#H h· (τ_M:nat_trans _ _)). Defined. Local Lemma ψ_nt : is_nat_trans (ψ_source(D:=[C,C]) X L) (ψ_target(D:=[C,C]) Id_H X L) ψ_pw. Proof. intros x x' a. cbn in a. apply weqfunextsec. intros f. apply nat_trans_eq_alt. intro c. etrans; revgoals. { eapply pathsinv0. apply (precompWithBinCoproductArrow C (CP _ _) (CP _ _) (identity _) (((# H a):nat_trans _ _) (T_func c))). } use (maponpaths_12 (@BinCoproductArrow _ _ _ _ _)). + apply pathsinv0,id_left. + apply pathsinv0. etrans; [ apply assoc |]. apply cancel_postcomposition. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (θ_nat_1_pw _ _ a (p T_alg)). } rewrite <- assoc. apply cancel_precomposition. etrans; revgoals. { eapply pathsinv0. eapply nat_trans_eq_pointwise. apply (functor_comp H (_:EndC⟦ T_mon ∙ x', T_mon ∙ x⟧)). } apply cancel_postcomposition. apply functor_cancel_pw. apply nat_trans_eq_alt. intro c'. etrans; [| apply id_right ]. apply cancel_precomposition. apply (functor_id x). Qed. Local Definition ψ : (PreShv EndC)⟦ψ_source(D:=[C,C]) X L , ψ_target(D:=[C,C]) Id_H X L⟧ := (ψ_pw ,, ψ_nt). (** Uniqueness of the Mendler iterator characteristized by its equation *) Local Definition uniq_iter : ∃! h : [C, C] ⟦ L `T_hss, X ⟧, # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h := GenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC Id_H is_omega_cocont_Id_H' (D:=[C,C]) X _ isInitial_precomp' HL ψ. (** The previous characteristic equation can be split as an equality between coproduct of arrows : - h ∘ η_T = j_mor - h ∘ τ_T = τ_M ∘ H h ∘ Θ_T,T where [η_T, τ_T] : Id + HT --> T *) Local Lemma coprod_iter_eq (h:nat_trans _ _) : (∏ x, BinCoproductIn1 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) · (# L (alg_map Id_H T_alg):nat_trans _ _) x · h x = j_mor x) -> (∏ x, BinCoproductIn2 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) · (# L (alg_map Id_H T_alg):nat_trans _ _) x · h x = (θ (`T_alg ⊗ p T_alg):nat_trans _ _) x · (# H h:nat_trans _ _) x · τ_M x) -> # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h. Proof. intros hB1 hB2. apply nat_trans_eq_alt. intros x. etrans. { etrans. { apply cancel_postcomposition. apply BinCoproductArrowEta. } apply postcompWithBinCoproductArrow. } use maponpaths_12. - apply hB1. - apply hB2. Qed. Let τT := τ_lmodule_mor T. (** j is a morphism of representation. It is exactly the 'H' part of the Id + H algebra morphism diagram *) Lemma j_mor_rep x : τT x · j_mor x = (# H j_mor:nat_trans _ _) x · τ_M x. Proof. etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) x). } etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn2Commutes. } etrans; [ apply assoc' |]. apply cancel_precomposition. apply BinCoproductIn2Commutes. Qed. (** j satisfies the η-related diagram of monad morphism. This is Id part of the Id+H-algebra morphism diagram *) Lemma j_mon_η : ∏ a : C, (Monads.η T_mon) a · j_mor a = (Monads.η M) a. Proof. intro a. etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) a). } etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } etrans; [ apply assoc' |]. etrans. { apply cancel_precomposition. apply BinCoproductIn1Commutes. } apply id_left. Qed. Let j_ptd : category_Ptd C ⟦ ptd_from_mon T_mon, ptd_from_mon M⟧. Proof. use tpair. - apply j. - intros x. apply j_mon_η. Defined. (** j is a monad morphism (following Ralph's proof). For the square diagram, we show that both parts satisfies the same Mendler iterator characteristic equation *) Lemma j_mon_square_eq1 : # L (alg_map Id_H T_alg) · ((μ T_mon : EndC ⟦_, _⟧) · j_mor) = (ψ : nat_trans _ _) `T_alg ((μ T_mon : EndC ⟦_, _⟧) · j_mor). Proof. apply coprod_iter_eq; intro x. - (* T monad law *) etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (Monad_law1 (T:=T_mon)). } apply id_left. - (* tau_T is a module morphism *) etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply (LModule_Mor_σ _ τT). } etrans; [ apply assoc' |]. etrans; [ apply assoc' |]. etrans; [| apply assoc ]. apply cancel_precomposition. rewrite functor_comp. etrans; [| apply assoc ]. apply cancel_precomposition. apply j_mor_rep. Qed. Lemma j_mon_square_eq2 : # L (alg_map Id_H T_alg) · ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M) = (ψ : nat_trans _ _) `T_alg ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M). Proof. apply coprod_iter_eq; intro x. - etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. etrans; [ apply assoc |]. apply cancel_postcomposition. apply j_mon_η. } etrans. { apply cancel_postcomposition. eapply pathsinv0. apply (nat_trans_ax (Monads.η M )). } etrans; [| apply id_right ]. rewrite <- assoc. apply cancel_precomposition. apply Monad_law1. - etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. etrans; [ apply assoc |]. etrans. { apply cancel_postcomposition. apply j_mor_rep. } rewrite <- assoc. apply cancel_precomposition. eapply pathsinv0. apply (nat_trans_ax τ_M). } etrans. { repeat rewrite <- assoc. apply cancel_precomposition. apply cancel_precomposition. apply (LModule_Mor_σ _ τ_M ( x)). } repeat rewrite assoc. apply cancel_postcomposition. etrans. { repeat rewrite <- assoc. apply cancel_precomposition. etrans; [ apply assoc |]. apply cancel_postcomposition. apply (θ_nat_2_pw _ _ _ j_ptd). } etrans. { repeat rewrite assoc. apply cancel_postcomposition. apply cancel_postcomposition. apply (θ_nat_1_pw _ _ j_mor (ptd_from_mon T_mon)). } repeat rewrite <- assoc. apply cancel_precomposition. rewrite functor_comp. rewrite functor_comp. repeat rewrite assoc. apply cancel_postcomposition. rewrite <- functor_comp. etrans; [ apply functor_comp_pw |]. apply functor_cancel_pw. apply nat_trans_eq_alt. intro y. etrans. { apply cancel_postcomposition. etrans. { apply cancel_precomposition. apply functor_id. } apply id_right. } apply cancel_precomposition. apply id_left. Qed. Lemma j_mon_laws : Monad_Mor_laws (T:=T_mon) (T':=M) (mor_from_algebra_mor _ j). Proof. split. - apply (nat_trans_eq_pointwise (a:= compose (C:=EndC) (μ T_mon) j_mor) (a':= compose(C:=EndC) (compose (C:=EndC) (a:=_∙_) (b:=_∙_) (c:=_∙_) (j_mor ø T_mon ) (M ∘ j_mor) ) (μ M))). apply (uniqueExists uniq_iter). + exact j_mon_square_eq1. + exact j_mon_square_eq2. - apply j_mon_η. Qed. Definition j_mon : Monad_Mor T_mon M := _ ,, j_mon_laws. End fix_a_representation. (** TODO: To assemble the above results into a concise statement, we would need to define the category of representations of a signature (H,θ). *) End InitialRep. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/MonadicSubstitution_alt.v000066400000000000000000000112331451125700300304610ustar00rootroot00000000000000(** Shows global results that do not fit into a particular file but rather put the different strands together. We focus on the results that are based on omega-cocontinuity (and not the existence of right Kan extensions), which also explains the suffix "_alt" to the proper file name. Written by Ralph Matthes, 2021 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Set Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Local Open Scope cat. Section MainResult. Context (C : category) (CP : BinCoproducts C). Context (IC : Initial C) (CC : Colims_of_shape nat_graph C). Local Notation "'EndC'":= ([C, C]) . Local Notation "'Ptd'" := (category_Ptd C). Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Let EndEndC := [EndC, EndC]. Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC. Let InitialEndC : Initial EndC. Proof. apply Initial_functor_precat, IC. Defined. Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC. Proof. apply ColimsFunctorCategory_of_shape, CC. Defined. Context (H : functor [C, C] [C, C]) (θ : StrengthForSignature H) (HH : is_omega_cocont H). Let Const_plus_H (X : EndC) : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H. Let Id_H : functor [C, C] [C, C] := Const_plus_H (functor_identity _ : EndC). Definition TermHSS : hss_category CP (Presignature_Signature (H,,θ)) := InitHSS C CP IC CC (Presignature_Signature (H,,θ)) HH. Definition TermHetSubst: heterogeneous_substitution C CP H := hetsubst_from_hss C CP (Presignature_Signature (H,,θ)) TermHSS. Definition Terms: [C, C] := pr1 (pr1 TermHSS). Definition TermAlgebra: FunctorAlg Id_H:= pr1 TermHSS. Goal TermAlgebra = InitAlg C CP IC CC H HH. Proof. apply idpath. Qed. Definition isInitialTermAlgebra: isInitial (FunctorAlg Id_H) TermAlgebra. Proof. set (aux := colimAlgInitial InitialEndC (is_omega_cocont_Id_H C CP H HH) (Colims_of_shape_nat_graph_EndC _)). exact (pr2 aux). Defined. Definition TermMonad: Monad C := Monad_from_hss C CP (H,,θ) TermHSS. Definition VarTerms: [C, C] ⟦ functor_identity C, Terms ⟧:= eta_from_alg TermAlgebra. Definition ConstrTerms: [C, C] ⟦ H Terms, Terms ⟧ := tau_from_alg TermAlgebra. Goal ConstrTerms = τ TermHetSubst. Proof. apply idpath. Qed. Definition join: [C, C] ⟦ functor_compose Terms Terms, Terms ⟧ := prejoin_from_hetsubst TermHetSubst. Goal join = μ TermMonad. Proof. apply idpath. Qed. Definition joinLookup: ∏ c : C, pr1 VarTerms (pr1 Terms c) · pr1 join c = identity (pr1 Terms c) := @Monad_law1 C TermMonad. Definition θforTerms := θ_from_hetsubst C CP H TermHetSubst Terms. Goal θforTerms = PrecategoryBinProduct.nat_trans_fix_snd_arg_data [C, C] Ptd [C, C] (θ_source H) (θ_target H) (pr1 θ) (ptd_from_alg (InitAlg C CP IC CC H HH)) Terms. Proof. apply idpath. Qed. Definition joinHomomorphic: θforTerms · # H join · ConstrTerms = #(pre_composition_functor _ _ _ Terms) ConstrTerms · join := prejoin_from_hetsubst_τ TermHetSubst. Definition joinHasEtaLaw: ∏ c : C, # (pr1 Terms) (pr1 VarTerms c) · pr1 join c = identity (pr1 Terms c) := @Monad_law2 C TermMonad. Definition joinHasPermutationLaw: ∏ c : C, # (pr1 Terms) (pr1 join c) · pr1 join c = pr1 join (pr1 Terms c) · pr1 join c := @Monad_law3 C TermMonad. End MainResult. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/MonadsFromSubstitutionSystems.v000066400000000000000000000524371451125700300317170ustar00rootroot00000000000000(** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Construction of a monad from a substitution system - Proof that morphism of hss gives morphism of monads - Bundling that into a functor - Proof that the functor is faithful version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is very close to the homonymous file in the parent directory basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated ************************************************************) Unset Kernel Term Sharing. Require Import UniMath.Foundations.PartD. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.CategoryTheory.BicatOfCatsElementary. Local Open Scope cat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Section monad_from_hss. Notation "⦃ f ⦄_{ Z }" := (fbracket _ Z f)(at level 0). (** ** Some variables and assumptions *) Context (C : category). Context (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. Variable H : Signature C C C. Let θ := theta H. Let θ_strength1_int := Sig_strength_law1 H. Let θ_strength2_int := Sig_strength_law2 H. Let Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . (** ** Derivation of the monad laws from a heterogeneous substitution system for signature with strength [H] *) Section mu_from_fbracket. (** We assume given a hss [T] *) Variable T : hss CP H. Local Notation "'p' T" := (ptd_from_alg T) (at level 3). Local Notation "f ⊕ g" := (BinCoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g). Definition μ_0 : functor_identity C ⟹ functor_data_from_functor _ _ `T := η T. (*ptd_pt _ (pr1 (pr1 T)).*) (** [η T] as pointed morphism *) Definition μ_0_ptd : id_Ptd C --> p T. Proof. exists μ_0. intro c. simpl. apply id_left. Defined. (** the bracket of the "degenerate" argument [η T] *) Definition μ_1 : functor_composite (U (id_Ptd C)) (`T) ⟹ functor_data_from_functor _ _ `T := ⦃μ_0⦄_{id_Ptd C}. (** using uniqueness of bracket for [η T] *) Lemma μ_1_identity : μ_1 = identity `T . Proof. apply pathsinv0. apply fbracket_unique. split. - apply nat_trans_eq_alt. intros; simpl. rewrite id_right. apply idpath. - apply nat_trans_eq_alt. intro c. simpl. rewrite id_right. assert (H':= θ_Strength1_int_implies_θ_Strength1 _ θ_strength1_int). red in H'. simpl in H'. assert (H2 := H' (`T)). assert (H3 := nat_trans_eq_pointwise H2 c). simpl in *. intermediate_path (identity _ · pr1 (τ T) c). + apply cancel_postcomposition. apply H3. + apply id_left. Qed. Lemma μ_1_identity' : ∏ c : C, μ_1 c = identity _. Proof. intros c. assert (HA:= nat_trans_eq_pointwise μ_1_identity). apply HA. Qed. (* The whole secret is that this typechecks Check (μ_1:U T-->U T). *) (* therefore, it is not just the type itself that makes it necessary to introduce μ_1_alt, it is rather the question of the formulation of the first strength law of θ *) (* Lemma μ_1_identity_stronger : μ_1 = identity (U T). Proof. set (t':=nat_trans_eq_weq C C hs _ _ μ_1 (identity (U T))). apply invweq in t'. set (t'' := t' μ_1_identity'). exact t''. Qed. *) (** This is the multiplication of the monad to be constructed *) Definition μ_2 : functor_composite (`T) (`T) ⟹ pr1 (`T) := prejoin_from_hetsubst T. Goal μ_2 = ⦃identity `T⦄_{ptd_from_alg T}. Proof. apply idpath. Qed. Definition disp_Monad_data_from_hss : disp_Monad_data `T := μ_2 ,, μ_0. (** *** Proof of the first monad law *) (** this directly comes from the contained heterogeneous substitution *) Lemma Monad_law_1_from_hss : ∏ c : C, μ_0 (pr1 (`T) c) · μ_2 c = identity ((pr1 (`T)) c). Proof. intro c. unfold μ_0. set (H' := prejoin_from_hetsubst_η T). set (H2:= nat_trans_eq_weq (homset_property C) _ _ H'). apply pathsinv0. apply H2. Qed. (** *** Proof of the second monad law *) (** using uniqueness of bracket for [η T] *) Lemma Monad_law_2_from_hss: ∏ c : C, # (pr1 (`T)) (μ_0 c)· μ_2 c = identity ((pr1 (`T)) c). Proof. intro c. intermediate_path (μ_1 c). - unfold μ_1. assert (H' := @fbracket_unique_target_pointwise _ _ _ T). assert (H1 := H' (id_Ptd C) μ_0). set (x := post_whisker μ_0 (`T) : EndC ⟦ `T • functor_identity _ , `T • `T ⟧). set (x' := x · μ_2). assert (H2 := H1 x'). apply H2; clear H2. unfold x'. clear x'. unfold x; clear x. clear H1. clear H'. clear c. split. + apply nat_trans_eq_alt. intro c. assert (H' := nat_trans_ax (η T)). simpl in H'. rewrite assoc. cbn. rewrite <- H'; clear H'. assert (H' := prejoin_from_hetsubst_η T). assert (H2 := nat_trans_eq_weq (homset_property C) _ _ H'). simpl in H2. rewrite <- assoc. rewrite <- H2. apply pathsinv0. apply id_right. + rewrite functor_comp. apply nat_trans_eq_alt. intro c. rewrite <- horcomp_id_postwhisker. do 2 rewrite assoc. simpl in *. unfold horcomp_data; simpl. intermediate_path ( # (pr1 (H ( (` T)))) (μ_0 c) · pr1 (θ ((`T) ⊗ (p T))) c · pr1 (# H μ_2) c · pr1 (τ T) c). * unfold tau_from_alg; cbn. do 2 rewrite assoc. do 3 apply cancel_postcomposition. assert (H' := θ_nat_2 _ _ _ H θ). assert (H2 := H' (`T) _ _ μ_0_ptd); clear H'. assert (H3 := nat_trans_eq_weq (homset_property C) _ _ H2 c); clear H2. simpl in H3. unfold horcomp_data in H3; simpl in H3. rewrite id_left in H3. apply (!H3). * assert (H' := prejoin_from_hetsubst_τ T). assert (H2 := nat_trans_eq_weq (homset_property C) _ _ H' c); clear H'. simpl in *. do 2 rewrite <- assoc. { intermediate_path ( # (pr1 (H (` T))) (μ_0 c) · (pr1 (τ T) (pr1 (`T) c) · pr1 μ_2 c)). - apply maponpaths. rewrite assoc. apply H2. (* rewrite done *) - clear H2. do 2 rewrite assoc. apply cancel_postcomposition. etrans. { apply (nat_trans_ax (τ T) ). } apply cancel_postcomposition. apply pathsinv0. apply id_right. } - apply μ_1_identity'. Qed. (** [T_squared] is [T∙T, η∙η], that is, the selfcomposition of [T] as a pointed functor *) Definition T_squared : Ptd := ptd_compose _ (p T) (p T). (** [μ_2] is not just a natural transformation from [T∙T] to [T], but also compatible with the pointed structure given by [η] *) Lemma μ_2_is_ptd_mor : ∏ c : C, (ptd_pt C T_squared) c · μ_2 c = pr1 (η T) c. Proof. intro c. unfold μ_2. unfold T_squared. unfold ptd_compose. rewrite functorial_composition_pre_post. simpl. assert (H' := Monad_law_2_from_hss c). simpl in H'. intermediate_path (pr1 (η T) c · identity _ ). - unfold eta_from_alg; simpl. repeat rewrite <- assoc. apply maponpaths. apply maponpaths. exact H'. - apply id_right. Qed. Definition μ_2_ptd : T_squared --> p T. Proof. exists μ_2. red. apply μ_2_is_ptd_mor. Defined. Definition μ_3 : EndC ⟦U T_squared • `T, `T⟧ := ⦃μ_2⦄_{T_squared}. (** *** Proof of the third monad law via transitivity *) (** We show that both sides are equal to [μ_3 = fbracket μ_2] *) (** using uniqueness of bracket for the prejoin *) Lemma μ_3_T_μ_2_μ_2 : μ_3 = (`T ∘ μ_2 : EndC ⟦`T • _ , `T • `T⟧ ) · μ_2. Proof. apply pathsinv0. apply (fbracket_unique(Z:=T_squared) T μ_2). split. - apply nat_trans_eq_alt. intro c. assert (H2 := nat_trans_ax (η T)); simpl in H2. rewrite assoc. simpl; rewrite <- H2 ; clear H2. intermediate_path (μ_2 c · identity _ ). + apply pathsinv0, id_right. + etrans; [| apply assoc ]. apply maponpaths. apply pathsinv0. apply Monad_law_1_from_hss. - rewrite functor_comp. assert (H1 := θ_nat_2 _ _ _ H θ (`T) _ _ μ_2_ptd). simpl in H1. repeat rewrite assoc. match goal with |[H1 : ?g = _ |- _ · _ · ?f · ?h = _ ] => intermediate_path (g · f · h) end. + do 2 apply cancel_postcomposition. apply pathsinv0. etrans; [apply H1 |]. clear H1. do 2 apply maponpaths. assert (H3 := horcomp_id_postwhisker). assert (H4 := H3 _ _ _ _ _ μ_2 (`T)); clear H3. apply H4. + clear H1. apply nat_trans_eq_alt. intro c; simpl. unfold horcomp_data; simpl. rewrite id_left. assert (H2 := prejoin_from_hetsubst_τ T). assert (H3 := nat_trans_eq_pointwise H2 c); clear H2. simpl in *. match goal with |[H3 : _ = ?f |- ?e · _ · _ · _ = _ ] => intermediate_path (e · f) end. * etrans; [ apply assoc' |]. etrans; [ apply assoc' |]. apply maponpaths. etrans; [| apply H3 ]. apply assoc. * clear H3. repeat rewrite assoc. apply cancel_postcomposition. assert (H1 := nat_trans_ax (τ T )). unfold tau_from_alg in H1. etrans; [ | apply H1]; clear H1. apply assoc'. Qed. Local Notation "'T•T²'" := (functor_compose (functor_composite (`T) (`T)) (`T) : [C, C]). Local Notation "'T²∙T'" := (@functor_composite C C C (@functor_composite C C C (`T) (` T)) (` T) : functor C C). (** using uniqueness of bracket for the prejoin also here *) Lemma μ_3_μ_2_T_μ_2 : ( @compose (functor_category C C) (* TtimesTthenT *) T²∙T _ _ (* (@functor_composite C C C ((functor_ptd_forget C hs) T) ((functor_ptd_forget C hs) T)) ((functor_ptd_forget C hs) T) *) ((μ_2 •• `T) (* : TtimesTthenT' --> _ *) (*:@functor_compose C C C hs hs (@functor_composite C C C ((functor_ptd_forget C hs) T) ((functor_ptd_forget C hs) T)) ((functor_ptd_forget C hs) T) --> _*) ) μ_2 : (*TtimesTthenT'*) T•T² --> `T) = μ_3. Proof. apply (fbracket_unique(Z:=T_squared) (*_pointwise*) T μ_2). split. - apply nat_trans_eq_alt; intro c. simpl. intermediate_path (identity _ · μ_2 c). + apply pathsinv0, id_left. + etrans; [ | apply assoc' ]. apply cancel_postcomposition. assert (H1 := Monad_law_1_from_hss (pr1 (`T) c)). apply (!H1). - set (B := τ T). match goal with | [|- _ · # ?H (?f · _ ) · _ = _ ] => set (F := f : (*TtimesTthenT'*) T•T² --> _ ) end. assert (H3 := functor_comp H F μ_2). unfold functor_compose in H3. etrans. { apply cancel_postcomposition. apply maponpaths. apply H3. } clear H3. apply nat_trans_eq_alt. intro c. simpl. match goal with | [ |- ?a · _ · _ = _ ] => set (Ac := a) end. simpl in Ac. simpl in *. unfold functor_compose in *. assert (HX := θ_nat_1 _ _ _ H θ _ _ μ_2). (* it may be tested with the primed version *) assert (HX1 := HX (ptd_from_alg T)); clear HX. simpl in HX1. assert (HXX := nat_trans_eq_pointwise HX1 c); clear HX1. simpl in HXX. unfold horcomp_data in HXX. rewrite (functor_id ( H (`T))) in HXX. rewrite id_right in HXX. (* last two lines needed because of def. of theta on product category *) match goal with |[HXX : ?f · ?h = _ · _ |- _ · (_ · ?x ) · ?y = _ ] => intermediate_path (pr1 (θ ((`T) ⊗ (ptd_from_alg T))) (pr1 (pr1 (pr1 T)) c)· f · h · x · y) end. * repeat rewrite assoc. do 3 apply cancel_postcomposition. unfold Ac. clear Ac. etrans; [| apply assoc ]. etrans. 2: { apply maponpaths. apply (!HXX). } clear HXX. assert (Strength_2 : ∏ α : functor_compose (functor_composite (`T) (`T))(`T) --> functor_composite (` T) (`T), pr1 (θ (`T ⊗ T_squared)) c · pr1 (# H α) c = pr1 (θ ((`T) ⊗ (ptd_from_alg T))) ((pr1 (pr1 (pr1 T))) c)· pr1 (θ (( ((`T) • (`T) : [_, _])) ⊗ (ptd_from_alg T))) c· pr1 (# H (α : functor_compose (`T) (functor_composite (`T) (` T))--> _)) c ). { intro α; assert (HA := θ_Strength2_int_implies_θ_Strength2 _ θ_strength2_int); assert (HA' := HA (`T) (ptd_from_alg T) (ptd_from_alg T) _ α); clear HA; assert (HA2 := nat_trans_eq_pointwise HA' c ); clear HA'; simpl in HA2; apply HA2. } etrans; [ apply (Strength_2 F) |]. clear Strength_2. etrans; [ apply assoc' |]. do 2 apply maponpaths. match goal with |[ |- _ = ?pr1 (# ?G ?g) _ ] => assert (X : F = g) end. { apply nat_trans_eq; try apply homset_property. intros. unfold F. simpl. unfold horcomp_data; simpl. rewrite functor_id. apply pathsinv0, id_right. } apply (maponpaths (λ T, pr1 (# H T) c)). apply X. * clear HXX. clear Ac. clear F. clear B. assert (H4 := prejoin_from_hetsubst_τ T). assert (H5 := nat_trans_eq_pointwise H4 c); clear H4. simpl in H5. { match goal with |[ H5 : _ = ?e |- ?a · ?b · _ · _ · _ = _ ] => intermediate_path (a · b · e) end. - repeat rewrite <- assoc. do 2 apply maponpaths. repeat rewrite <- assoc in H5. apply H5. - clear H5. repeat rewrite assoc. apply cancel_postcomposition. assert (HT := prejoin_from_hetsubst_τ T). assert (H6 := nat_trans_eq_pointwise HT); clear HT. unfold coproduct_nat_trans_in2_data. unfold tau_from_alg in H6. rewrite assoc in H6. apply H6. } Qed. (** proving a variant of the third monad law with assoc iso explicitly inserted *) Section third_monad_law_with_assoc. Lemma third_monad_law_from_hss : (`T ∘ μ_2 : EndC ⟦ functor_composite (functor_composite `T `T) `T , `T • `T ⟧) · μ_2 = (rassociator_CAT _ _ _) · (μ_2 •• `T) · μ_2. Proof. intermediate_path μ_3; [apply pathsinv0, μ_3_T_μ_2_μ_2 | ]. apply pathsinv0. (** we only aim at a proof alternative to [μ_3_μ_2_T_μ_2] *) apply (fbracket_unique(Z:=T_squared) (*_pointwise*) T μ_2). split. - apply nat_trans_eq_alt; intro c. simpl. rewrite assoc. intermediate_path (identity _ · μ_2 c). + apply pathsinv0, id_left. + apply cancel_postcomposition. rewrite id_left. assert (H1 := Monad_law_1_from_hss (pr1 (`T) c)). simpl in H1. apply (!H1). - do 2 rewrite functor_comp. do 4 rewrite assoc. unfold T_squared. apply nat_trans_eq_alt. intro c; simpl. assert (HTT := θ_strength2_int). assert (HX := HTT (`T) (ptd_from_alg T) (ptd_from_alg T)); clear HTT. assert (HX' := nat_trans_eq_pointwise HX c); clear HX. simpl in HX'. match goal with | [ H : _ = ?f |- _ · _ · ?g · ?h · ?i = _ ] => intermediate_path (f · g · h · i) end. + do 3 apply cancel_postcomposition. apply HX'. + clear HX'. rewrite id_left. rewrite id_right. assert (HX :=θ_nat_1 _ _ _ H θ _ _ μ_2). assert (HX1 := HX (ptd_from_alg T)); clear HX. simpl in HX1. assert (HXX := nat_trans_eq_pointwise HX1 c); clear HX1. simpl in HXX. unfold horcomp_data in HXX; simpl in HXX. match goal with | [ H : ?x = _ |- ?e · _ · _ · ?f · ?g = _ ] => intermediate_path (e · x · f · g) end. * do 2 apply cancel_postcomposition. repeat rewrite <- assoc. apply maponpaths. { match goal with | [ H : _ = ?x |- _ ] => intermediate_path x end. - clear HXX. apply maponpaths. match goal with | [ |- _ ?a ?x = _ ?b ?y ] => assert (TTT : a = b) end. { match goal with | [ |- _ ?a = _ ?b ] => assert (TTTT : a = b) end. { apply nat_trans_eq_alt. intros. simpl. unfold horcomp_data; simpl. rewrite functor_id. apply pathsinv0, id_right. } apply maponpaths. apply TTTT. } apply (nat_trans_eq_pointwise TTT). - repeat rewrite assoc. repeat rewrite assoc in HXX. apply (!HXX). } * clear HXX. assert (H4 := prejoin_from_hetsubst_τ T). assert (H5 := nat_trans_eq_pointwise H4 c); clear H4. unfold μ_2. repeat rewrite <- assoc. simpl in H5; repeat rewrite <- assoc in H5. etrans. { do 3 apply maponpaths. apply H5. } clear H5. rewrite functor_id. rewrite id_left. repeat rewrite assoc. apply cancel_postcomposition. assert (H4' := prejoin_from_hetsubst_τ T). assert (H6 := nat_trans_eq_pointwise H4' (pr1 `T c)); clear H4'. simpl in H6. unfold coproduct_nat_trans_in2_data in H6. simpl in H6. rewrite assoc in H6. apply H6. Qed. End third_monad_law_with_assoc. (* Unset Printing All. Set Printing Notations. Unset Printing Implicit. *) (** Finally putting together all the preparatory results to obtain a monad *) Lemma disp_Monad_laws_from_hss : disp_Monad_laws disp_Monad_data_from_hss. Proof. split. - unfold disp_Monad_data_from_hss; simpl; split. + apply Monad_law_1_from_hss. + apply Monad_law_2_from_hss. - unfold disp_Monad_data_from_hss; simpl. intro c. intermediate_path (pr1 μ_3 c). + set (H1 := μ_3_T_μ_2_μ_2). set (H2 := nat_trans_eq_weq (homset_property C) _ _ H1). apply pathsinv0, H2. + set (H1 := μ_3_μ_2_T_μ_2). set (H2 := nat_trans_eq_weq (homset_property C) _ _ H1). apply pathsinv0, H2. Qed. Definition Monad_from_hss : Monad C := _ ,, _ ,, disp_Monad_laws_from_hss. End mu_from_fbracket. (** ** A functor from hss to monads *) (** Objects are considered above, now morphisms *) Definition Monad_Mor_laws_from_hssMor (T T' : hss CP H)(β : hssMor T T') : Monad_Mor_laws (T:=Monad_from_hss T) (T':=Monad_from_hss T') (pr1 (pr1 β)). Proof. repeat split; simpl. - intro c. unfold μ_2. simpl. set (H' := isbracketMor_hssMor _ _ _ β). unfold isbracketMor in H'. set (H2 := H' (ptd_from_alg T) (#U (identity _ ))). set (H3 := nat_trans_eq_weq (homset_property C) _ _ H2). rewrite id_left in H3. simpl in H3. rewrite H3; clear H3 H2 H'. rewrite assoc'. apply maponpaths. assert (aux := compute_fbracket(Z:=ptd_from_alg T) C CP H T' (ptd_from_alg_mor C CP H (pr1 β))). apply (maponpaths pr1) in aux. apply toforallpaths in aux. etrans. { apply (aux c). } apply idpath. - unfold μ_0. intro c. set (H' := ptd_mor_commutes _ (ptd_from_alg_mor _ _ _ β)). apply H'. Qed. Definition Monad_Mor_from_hssMor {T T' : hss CP H}(β : hssMor T T') : Monad_Mor (Monad_from_hss T) (Monad_from_hss T') := tpair _ _ (Monad_Mor_laws_from_hssMor T T' β). Definition hss_to_monad_functor_data : functor_data (hss_precategory CP H) (category_Monad C). Proof. exists Monad_from_hss. exact @Monad_Mor_from_hssMor. Defined. Lemma is_functor_hss_to_monad : is_functor hss_to_monad_functor_data. Proof. split; simpl. - intro a. apply (invmap (Monad_Mor_equiv _ _ )). apply idpath. - intros a b c f g. apply (invmap (Monad_Mor_equiv _ _ )). apply idpath. Qed. Definition hss_to_monad_functor : functor _ _ := tpair _ _ is_functor_hss_to_monad. Definition hssMor_Monad_Mor_eq {T T' : hss CP H} (β β' : hssMor T T') : β = β' ≃ Monad_Mor_from_hssMor β = Monad_Mor_from_hssMor β'. Proof. eapply weqcomp. - apply hssMor_eq. - apply invweq. use Monad_Mor_equiv. Defined. (** *** The functor from hss to monads is faithful, i.e. forgets at most structure *) Lemma faithful_hss_to_monad : faithful hss_to_monad_functor. Proof. unfold faithful. intros T T'. apply isinclbetweensets. - apply isaset_hssMor. - apply isaset_Monad_Mor. - intros β β'. apply (invmap (hssMor_Monad_Mor_eq _ _ )). Qed. End monad_from_hss. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/MultiSortedMonadConstruction.v000066400000000000000000000076031451125700300314650ustar00rootroot00000000000000(** This file contains the final step in the formalization of multisorted binding signatures: - Construction of a monad on Set/sort from a multisorted signature ([MultiSortedSigToMonad]) Written by: Anders Mörtberg, 2016. The formalization follows a note written by Benedikt Ahrens and Ralph Matthes, and is also inspired by discussions with them and Vladimir Voevodsky. version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Local Open Scope cat. Local Notation "C / X" := (slicecat_ob C X). Local Notation "C / X" := (slice_precat_data C X). Local Notation "C / X" := (slice_cat C X). (** * Definition of multisorted binding signatures *) Section MBindingSig. Context (sort : hSet). Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. (** * Construction of a monad from a multisorted signature *) Section monad. Let Id_H := Id_H (HSET / sort) (BinCoproducts_HSET_slice sort). (* ** Construction of initial algebra for a signature with strength on Set / sort *) Definition SignatureInitialAlgebraSetSort (H : Signature HSET_over_sort HSET_over_sort HSET_over_sort) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply Initial_functor_precat, Initial_slice_precat, InitialHSET. - apply (is_omega_cocont_Id_H), Hs. - apply ColimsFunctorCategory_of_shape, slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Let HSS := @hss_category _ (BinCoproducts_HSET_slice sort). (* ** Multisorted signature to a HSS *) Definition MultiSortedSigToHSS (sig : MultiSortedSig sort) : HSS (MultiSortedSigToSignature sort sig). Proof. apply SignatureToHSS. + apply Initial_slice_precat, InitialHSET. + apply slice_precat_colims_of_shape, ColimsHSET_of_shape. + apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. (* The above HSS is initial *) Definition MultiSortedSigToHSSisInitial (sig : MultiSortedSig sort) : isInitial _ (MultiSortedSigToHSS sig). Proof. now unfold MultiSortedSigToHSS, SignatureToHSS; destruct InitialHSS. Qed. (** ** Function from multisorted binding signatures to monads *) Definition MultiSortedSigToMonad (sig : MultiSortedSig sort) : Monad (HSET / sort). Proof. use Monad_from_hss. - apply BinCoproducts_HSET_slice. - apply (MultiSortedSigToSignature sort sig). - apply MultiSortedSigToHSS. Defined. End monad. End MBindingSig. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/MultiSortedMonadConstruction_alt.v000066400000000000000000000147201451125700300323230ustar00rootroot00000000000000(** This file contains the final steps of the formalization of multisorted binding signatures: - Construction of a monad on C^sort from a multisorted signature ([MultiSortedSigToMonad]) - Instantiation of MultiSortedSigToMonad for C = Set ([MultiSortedSigToMonadSet]) Written by: Anders Mörtberg, 2021. The formalization is an adaptation of Multisorted.v version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Local Open Scope cat. Section MBindingSig. (* Interestingly we only need that [sort] is a 1-type *) Variables (sort : UU) (Hsort : isofhlevel 3 sort) (C : category). (* Assumptions on [C] used to construct the functor *) (* Note that there is some redundancy in the assumptions *) Variables (TC : Terminal C) (IC : Initial C) (BP : BinProducts C) (BC : BinCoproducts C) (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C). Local Notation "'1'" := (TerminalObject TC). Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)). (** Define the discrete category of sorts *) Let sort_cat : category := path_pregroupoid sort Hsort. (** This represents "sort → C" *) Let sortToC : category := [sort_cat,C]. Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f. Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC. Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP. (* Assumptions needed to prove ω-cocontinuity of the functor *) Variables (expSortToCC : Exponentials BPC) (HC : Colims_of_shape nat_graph C). (* The expSortToCC assumption says that [sortToC,C] has exponentials. It could be reduced to exponentials in C, but we only have the case for C = Set formalized in CategoryTheory.categories.HSET.Structures.Exponentials_functor_HSET *) (** * Construction of a monad from a multisorted signature *) Section monad. Let Id_H := Id_H sortToC BCsortToC. (* ** Construction of initial algebra for a signature with strength on C^sort *) Definition SignatureInitialAlgebra (H : Signature sortToC sortToC sortToC) (Hs : is_omega_cocont H) : Initial (FunctorAlg (Id_H H)). Proof. use colimAlgInitial. - apply Initial_functor_precat, Initial_functor_precat, IC. - apply (is_omega_cocont_Id_H), Hs. - apply ColimsFunctorCategory_of_shape, ColimsFunctorCategory_of_shape, HC. Defined. Let HSS := @hss_category _ BCsortToC. (* ** Multisorted signature to a HSS *) Definition MultiSortedSigToHSS (sig : MultiSortedSig sort) : HSS (MultiSortedSigToSignature sort Hsort C TC BP BC CC sig). Proof. apply SignatureToHSS. + apply Initial_functor_precat, IC. + apply ColimsFunctorCategory_of_shape, HC. + apply is_omega_cocont_MultiSortedSigToSignature; try assumption. Defined. (* The above HSS is initial *) Definition MultiSortedSigToHSSisInitial (sig : MultiSortedSig sort) : isInitial _ (MultiSortedSigToHSS sig). Proof. now unfold MultiSortedSigToHSS, SignatureToHSS; destruct InitialHSS. Qed. (** ** Function from multisorted binding signatures to monads *) Definition MultiSortedSigToMonad (sig : MultiSortedSig sort) : Monad sortToC. Proof. use Monad_from_hss. - apply BCsortToC. - apply (MultiSortedSigToSignature sort Hsort C TC BP BC CC sig). - apply MultiSortedSigToHSS. Defined. End monad. End MBindingSig. Section MBindingSigMonadHSET. (* Assume a set of sorts *) Context (sort : hSet) (Hsort : isofhlevel 3 sort). Let sortToSet : category := [path_pregroupoid sort Hsort, HSET]. Definition projSortToSet : sort → functor sortToSet HSET := projSortToC sort Hsort HSET. Definition hat_functorSet : sort → HSET ⟶ sortToSet := hat_functor sort (isofhlevelssnset 1 _ (setproperty sort)) HSET CoproductsHSET. Definition sorted_option_functorSet : sort → sortToSet ⟶ sortToSet := sorted_option_functor _ (isofhlevelssnset 1 _ (setproperty sort)) HSET TerminalHSET BinCoproductsHSET CoproductsHSET. Definition MultiSortedSigToSignatureSet : MultiSortedSig sort → Signature sortToSet sortToSet sortToSet. Proof. use MultiSortedSigToSignature. - apply TerminalHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply CoproductsHSET. Defined. Definition MultiSortedSigToMonadSet (ms : MultiSortedSig sort) : Monad sortToSet. Proof. use MultiSortedSigToMonad. - apply TerminalHSET. - apply InitialHSET. - apply BinProductsHSET. - apply BinCoproductsHSET. - apply ProductsHSET. - apply CoproductsHSET. - apply Exponentials_functor_HSET. - apply ColimsHSET_of_shape. - apply ms. Defined. End MBindingSigMonadHSET. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/PCF_alt.v000066400000000000000000000177001451125700300250670ustar00rootroot00000000000000(** Syntax of PCF as a multisorted binding signature. Written by: Anders Mörtberg, 2021 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.StandardFiniteSets. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.STLC_alt. Local Open Scope cat. Section pcf. (* Was there a general version of this somewhere? *) Definition six_rec {A : UU} (i : stn 6) (a b c d e f : A) : A. Proof. induction i as [n p]. induction n as [|n _]; [apply a|]. induction n as [|n _]; [apply b|]. induction n as [|n _]; [apply c|]. induction n as [|n _]; [apply d|]. induction n as [|n _]; [apply e|]. induction n as [|n _]; [apply f|]. induction (nopathsfalsetotrue p). Defined. (** We assume a set of types with bool, nat and function types *) Variable (type : hSet) (Bool Nat : type) (arr : type → type → type). Local Lemma htype : isofhlevel 3 type. Proof. exact (isofhlevelssnset 1 type (setproperty type)). Defined. Let typeToSet : category := [path_pregroupoid type htype,HSET]. Let typeToSet2 := [typeToSet,typeToSet]. Local Lemma BinCoprodTypeToSet : BinCoproducts typeToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma TerminalTypeToSet : Terminal typeToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinProd : BinProducts [typeToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Lemma BinCoprodTypeToSet2 : BinCoproducts typeToSet2. Proof. apply BinCoproducts_functor_precat, BinCoprodTypeToSet. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodTypeToSet a b)). Local Notation "'1'" := (TerminalObject TerminalTypeToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). Infix "++" := (SumMultiSortedSig _). (** The Inductive version of PCF that we are going to model (copied from https://github.com/benediktahrens/monads/blob/trunk/PCF/pcf.v): << Inductive TY := | Bool : TY | Nat : TY | arrow: TY -> TY -> TY. Inductive PCF_consts : TY -> Type := | Nats : nat -> PCF_consts Nat | tt : PCF_consts Bool | ff : PCF_consts Bool | succ : PCF_consts (arrow Nat Nat) | is_zero : PCF_consts (arr Nat Bool) | condN: PCF_consts (arrow Bool (arrow Nat (arrow Nat Nat))) | condB: PCF_consts (arrow Bool (arrow Bool (arrow Bool Bool))). Inductive PCF (V:TY -> Type) : TY -> Type:= | PCFVar : forall t, V t -> PCF V t | Const : forall t, PCF_consts t -> PCF V t | Bottom : forall t, PCF V t | PApp : forall t s, PCF V (arrow s t) -> PCF V s -> PCF V t | PLam : forall t s, PCF (opt_T t V) s -> PCF V (arrow t s) | PRec : forall t, PCF V (arrow t t) -> PCF V t. >> We do this by defining the constants and non-constants separately and then taking the sum of the signatures. *) Definition PCF_Consts : MultiSortedSig type. Proof. use make_MultiSortedSig. - exact ((nat,,isasetnat) + (stn 6,,isasetstn 6))%set. - induction 1 as [n|i]. + exact ([],,Nat). (* Nat (one for each nat) *) + apply (six_rec i). * exact ([],,Bool). (* True *) * exact ([],,Bool). (* False *) * exact ([],,arr Nat Nat). (* Succ *) * exact ([],,arr Nat Bool). (* is_zero *) * exact ([],,arr Bool (arr Nat (arr Nat Nat))). (* CondN *) * exact ([],,arr Bool (arr Bool (arr Bool Bool))). (* CondB *) Defined. (* We could define PCF as follows, but we instead get App and Lam from the STLC signature *) (* Definition PCF : MultiSortedSig type. *) (* Proof. *) (* use make_MultiSortedSig. *) (* - apply (type + (type × type) + (type × type) + type)%set. *) (* - intros [[[t|[t s]]|[t s]]|t]. *) (* * exact ([],,t). (* Bottom *) *) (* * exact ((([],,(arr s t)) :: ([],,s) :: nil),,t). (* App *) *) (* * exact (((cons t [],,s) :: []),,(arr t s)). (* Lam *) *) (* * exact ((([],,(arr t t)) :: nil),,t). (* Y *) *) (* Defined. *) Definition PCF_Bot_Y : MultiSortedSig type. Proof. use make_MultiSortedSig. - apply (type + type)%set. - intros [t|t]. * exact ([],,t). (* Bottom *) * exact ((([],,(arr t t)) :: nil),,t). (* Y *) Defined. Definition PCF_App_Lam : MultiSortedSig type := STLC_Sig type arr. Definition PCF_Sig : MultiSortedSig type := PCF_Consts ++ PCF_Bot_Y ++ PCF_App_Lam. Definition PCF_Signature : Signature typeToSet _ _ := MultiSortedSigToSignatureSet type htype PCF_Sig. Definition PCF_Functor : functor typeToSet2 typeToSet2 := Id_H _ BinCoprodTypeToSet PCF_Signature. Lemma PCF_Functor_Initial : Initial (FunctorAlg PCF_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition PCF_Monad : Monad typeToSet := MultiSortedSigToMonadSet type htype PCF_Sig. (** Extract the constructors from the initial algebra *) Definition PCF_M : typeToSet2 := alg_carrier _ (InitialObject PCF_Functor_Initial). Let PCF_M_mor : typeToSet2⟦PCF_Functor PCF_M,PCF_M⟧ := alg_map _ (InitialObject PCF_Functor_Initial). Let PCF_M_alg : algebra_ob PCF_Functor := InitialObject PCF_Functor_Initial. (** The variables *) Definition var_map : typeToSet2⟦Id,PCF_M⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · PCF_M_mor. (* We can also extract the other constructors *) End pcf. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/STLC.v000066400000000000000000000153551451125700300243700ustar00rootroot00000000000000(** Syntax of the simply typed lambda calculus as a multisorted signature. Written by: Anders Mörtberg, 2017 version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Slice. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.slicecat. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted. Require Import UniMath.SubstitutionSystems.MultiSorted. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction. Local Open Scope cat. (** * The simply typed lambda calculus from a multisorted binding signature *) Section Lam. Variable (sort : hSet) (arr : sort → sort → sort). (** A lot of notations, upstream? *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "C / X" := (slice_cat C X). Local Notation "a + b" := (setcoprod a b) : set. Local Definition HSET_over_sort : category. Proof. exists (HSET / sort). now apply has_homsets_slice_precat. Defined. Let HSET_over_sort2 := [HSET/sort,HSET_over_sort]. Local Lemma BinProducts_HSET_over_sort2 : BinProducts HSET_over_sort2. Proof. apply BinProducts_functor_precat, BinProducts_slice_precat, PullbacksHSET. Defined. Local Lemma Coproducts_HSET_over_sort2 : Coproducts ((sort × sort) + (sort × sort))%set HSET_over_sort2. Proof. apply Coproducts_functor_precat, Coproducts_slice_precat, CoproductsHSET. apply setproperty. Defined. (** The signature of the simply typed lambda calculus *) Definition STLC_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - apply ((sort × sort) + (sort × sort))%set. (* todo: fix this once level of × is fixed *) - intros H; induction H as [st|st]; induction st as [s t]. + exact ((([],,arr s t) :: ([],,s) :: nil),,t). + exact (((cons s [],,t) :: []),,arr s t). Defined. (** The signature with strength for the simply typed lambda calculus *) Definition STLC_Signature : Signature (HSET / sort) _ _:= MultiSortedSigToSignature sort STLC_Sig. Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort). Definition STLC_Functor : functor HSET_over_sort2 HSET_over_sort2 := Id_H STLC_Signature. Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor). Proof. apply SignatureInitialAlgebraSetSort. apply is_omega_cocont_MultiSortedSigToSignature. apply slice_precat_colims_of_shape, ColimsHSET_of_shape. Defined. Definition STLC_Monad : Monad (HSET / sort) := MultiSortedSigToMonad sort STLC_Sig. (** Extract the constructors of the stlc from the initial algebra *) Definition STLC : HSET_over_sort2 := alg_carrier _ (InitialObject STLC_Functor_Initial). Let STLC_mor : HSET_over_sort2⟦STLC_Functor STLC,STLC⟧ := alg_map _ (InitialObject STLC_Functor_Initial). Let STLC_alg : algebra_ob STLC_Functor := InitialObject STLC_Functor_Initial. Local Lemma BP : BinProducts [HSET_over_sort,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. Local Notation "'1'" := (functor_identity HSET_over_sort). Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)). (** The variables *) Definition var_map : HSET_over_sort2⟦1,STLC⟧ := BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor. (** The source of the application constructor *) Definition app_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 := ((X ∙ proj_functor sort (arr s t)) ⊗ (X ∙ proj_functor sort s)) ∙ hat_functor sort t. (** The application constructor *) Definition app_map (s t : sort) : HSET_over_sort2⟦app_source s t STLC,STLC⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii1 (s,, t))) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · STLC_mor. (** The source of the lambda constructor *) Definition lam_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 := (sorted_option_functor sort s ∙ X ∙ proj_functor sort t) ∙ hat_functor sort (arr s t). Definition lam_map (s t : sort) : HSET_over_sort2⟦lam_source s t STLC,STLC⟧ := (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii2 (s,,t))) · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor. Definition make_STLC_Algebra X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : algebra_ob STLC_Functor. Proof. apply (tpair _ X). use (BinCoproductArrow _ fvar). use CoproductArrow. intro b; induction b as [st|st]; induction st as [s t]. - apply (fapp s t). - apply (flam s t). Defined. (** The recursor for the stlc *) Definition foldr_map X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : algebra_mor _ STLC_alg (make_STLC_Algebra X fvar fapp flam). Proof. apply (InitialArrow STLC_Functor_Initial (make_STLC_Algebra X fvar fapp flam)). Defined. (** The equation for variables *) Lemma foldr_var X (fvar : HSET_over_sort2⟦1,X⟧) (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧) (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x) (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))). rewrite assoc in F. eapply pathscomp0; [apply F|]. rewrite assoc. eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite <- assoc. eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|]. apply id_left. Defined. (* TODO: how to define the equations for app and lam? *) End Lam. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/STLC_alt.v000066400000000000000000000263521451125700300252270ustar00rootroot00000000000000(** Syntax of the simply typed lambda calculus as a multisorted signature. Written by: Anders Mörtberg, 2021 (adapted from STLC.v) version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is identical to the homonymous file in the parent directory, except for importing files from the present directory *) Require Import UniMath.Foundations.PartD. Require Import UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.Combinatorics.Lists. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.limits.graphs.colimits. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.products. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.exponentials. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.Chains.All. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.categories.HSET.Colimits. Require Import UniMath.CategoryTheory.categories.HSET.Limits. Require Import UniMath.CategoryTheory.categories.HSET.Structures. Require Import UniMath.CategoryTheory.categories.StandardCategories. Require Import UniMath.CategoryTheory.Groupoids. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.SumOfSignatures. Require Import UniMath.SubstitutionSystems.BinProductOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.SignatureExamples. Require Import UniMath.SubstitutionSystems.MultiSorted_alt. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction_alt. Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt. Local Open Scope cat. (** * The simply typed lambda calculus from a multisorted binding signature *) Section Lam. Variable (sort : hSet) (arr : sort → sort → sort). Local Lemma hsort : isofhlevel 3 sort. Proof. exact (isofhlevelssnset 1 sort (setproperty sort)). Defined. Let sortToSet : category := [path_pregroupoid sort hsort,HSET]. Local Lemma TerminalSortToSet : Terminal sortToSet. Proof. apply Terminal_functor_precat, TerminalHSET. Defined. Local Lemma BinCoprodSortToSet : BinCoproducts sortToSet. Proof. apply BinCoproducts_functor_precat, BinCoproductsHSET. Defined. Local Lemma BinProd : BinProducts [sortToSet,HSET]. Proof. apply BinProducts_functor_precat, BinProductsHSET. Defined. (** Some notations *) Local Infix "::" := (@cons _). Local Notation "[]" := (@nil _) (at level 0, format "[]"). Local Notation "a + b" := (setcoprod a b) : set. Local Notation "s ⇒ t" := (arr s t). Local Notation "'Id'" := (functor_identity _). Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodSortToSet a b)). Local Notation "'1'" := (TerminalObject TerminalSortToSet). Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G). Let sortToSet2 := [sortToSet,sortToSet]. Local Lemma BinCoprodSortToSet2 : BinCoproducts sortToSet2. Proof. apply BinCoproducts_functor_precat, BinCoprodSortToSet. Defined. (** The signature of the simply typed lambda calculus *) Definition STLC_Sig : MultiSortedSig sort. Proof. use make_MultiSortedSig. - apply ((sort × sort) + (sort × sort))%set. - intros H; induction H as [st|st]; induction st as [s t]. + exact ((([],,(s ⇒ t)) :: ([],,s) :: nil),,t). + exact (((cons s [],,t) :: []),,(s ⇒ t)). Defined. (** The signature with strength for the simply typed lambda calculus *) Definition STLC_Signature : Signature sortToSet _ _ := MultiSortedSigToSignatureSet sort hsort STLC_Sig. Definition STLC_Functor : functor sortToSet2 sortToSet2 := Id_H _ BinCoprodSortToSet STLC_Signature. Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor). Proof. apply SignatureInitialAlgebra. - apply InitialHSET. - apply ColimsHSET_of_shape. - apply is_omega_cocont_MultiSortedSigToSignature. + apply ProductsHSET. + apply Exponentials_functor_HSET. + apply ColimsHSET_of_shape. Defined. Definition STLC_Monad : Monad sortToSet := MultiSortedSigToMonadSet sort hsort STLC_Sig. (** Extract the constructors of the STLC from the initial algebra *) Definition STLC_M : sortToSet2 := alg_carrier _ (InitialObject STLC_Functor_Initial). (* The functor parts coincide *) Lemma STLC_Monad_ok : STLC_M = pr1 STLC_Monad. Proof. apply idpath. Qed. Let STLC_M_mor : sortToSet2⟦STLC_Functor STLC_M,STLC_M⟧ := alg_map _ (InitialObject STLC_Functor_Initial). Let STLC_M_alg : algebra_ob STLC_Functor := InitialObject STLC_Functor_Initial. (** The variables *) Definition var_map : sortToSet2⟦Id,STLC_M⟧ := BinCoproductIn1 (BinCoprodSortToSet2 _ _) · STLC_M_mor. (** The source of the application constructor *) Definition app_source (s t : sort) : functor sortToSet2 sortToSet2 := (post_comp_functor (projSortToSet sort hsort (s ⇒ t)) ⊗ post_comp_functor (projSortToSet sort hsort s)) ∙ (post_comp_functor (hat_functorSet sort hsort t)). (** The application constructor *) Definition app_map (s t : sort) : sortToSet2⟦app_source s t STLC_M,STLC_M⟧ := CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)) (ii1 (s,,t)) · BinCoproductIn2 (BinCoprodSortToSet2 _ _) · STLC_M_mor. (** The source of the lambda constructor *) Definition lam_source (s t : sort) : functor sortToSet2 sortToSet2 := pre_comp_functor (sorted_option_functorSet sort hsort s) ∙ post_comp_functor (projSortToC sort hsort _ t) ∙ post_comp_functor (hat_functorSet sort hsort (s ⇒ t)). Definition lam_map (s t : sort) : sortToSet2⟦lam_source s t STLC_M,STLC_M⟧ := CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)) (ii2 (s,,t)) · BinCoproductIn2 (BinCoprodSortToSet2 _ _) · STLC_M_mor. Definition make_STLC_M_Algebra X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : algebra_ob STLC_Functor. Proof. apply (tpair _ X), (BinCoproductArrow _ fvar), CoproductArrow; intros b. induction b as [st|st]; induction st as [s t]. - exact (fapp s t). - exact (flam s t). Defined. (** The recursor for the stlc *) Definition foldr_map X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : algebra_mor _ STLC_M_alg (make_STLC_M_Algebra X fvar fapp flam) := InitialArrow STLC_Functor_Initial (make_STLC_M_Algebra X fvar fapp flam). (** The equation for variables *) Lemma foldr_var X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) : var_map · foldr_map X fvar fapp flam = fvar. Proof. unfold var_map. rewrite <- assoc, (algebra_mor_commutes _ _ _ (foldr_map _ _ _ _)), assoc. etrans; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|]. rewrite id_left. apply BinCoproductIn1Commutes. Qed. Lemma foldr_app X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) (s t : sort) : app_map s t · foldr_map X fvar fapp flam = # (pr1 (app_source s t)) (foldr_map X fvar fapp flam) · fapp s t. Proof. unfold app_map. rewrite <- assoc. etrans; [apply maponpaths, (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))|]. rewrite assoc. etrans; [eapply cancel_postcomposition; rewrite <- assoc; apply maponpaths, BinCoproductOfArrowsIn2|]. rewrite <- !assoc. etrans; [apply maponpaths, maponpaths, BinCoproductIn2Commutes|]. rewrite assoc. etrans; [apply cancel_postcomposition; use (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)))|]. rewrite <- assoc. apply maponpaths. exact (CoproductInCommutes _ _ _ _ _ _ (inl (s,,t))). Qed. Lemma foldr_lam X (fvar : sortToSet2⟦Id,X⟧) (fapp : ∏ s t, sortToSet2⟦app_source s t X,X⟧) (flam : ∏ s t, sortToSet2⟦lam_source s t X,X⟧) (s t : sort) : lam_map s t · foldr_map X fvar fapp flam = # (pr1 (lam_source s t)) (foldr_map X fvar fapp flam) · flam s t. Proof. unfold lam_map. rewrite <- assoc. etrans; [apply maponpaths, (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))|]. rewrite assoc. etrans; [eapply cancel_postcomposition; rewrite <- assoc; apply maponpaths, BinCoproductOfArrowsIn2|]. rewrite <- !assoc. etrans; [apply maponpaths, maponpaths, BinCoproductIn2Commutes|]. rewrite assoc. etrans; [apply cancel_postcomposition; use (CoproductOfArrowsIn _ _ (Coproducts_functor_precat _ _ _ _ (λ _, _)))|]. rewrite <- assoc. apply maponpaths. exact (CoproductInCommutes _ _ _ _ _ _ (inr (s,,t))). Qed. (* Now substitution *) Let STLC := STLC_Monad. (* Parallel substitution *) Definition psubst {X Y : sortToSet} (f : sortToSet⟦X, STLC Y ⟧) : sortToSet⟦ STLC (X ⊕ Y), STLC Y ⟧ := monadSubstGen_instantiated _ _ _ _ f. (* Substitution of a single variable *) Definition subst {X : sortToSet} (f : sortToSet⟦ 1, STLC X ⟧) : sortToSet⟦ STLC (1 ⊕ X), STLC X ⟧ := monadSubstGen_instantiated _ _ _ _ f. Definition weak {X Y : sortToSet} : sortToSet⟦STLC Y,STLC (X ⊕ Y)⟧ := mweak_instantiated sort hsort HSET BinCoproductsHSET. Definition exch {X Y Z : sortToSet} : sortToSet⟦STLC (X ⊕ (Y ⊕ Z)), STLC (Y ⊕ (X ⊕ Z))⟧ := mexch_instantiated sort hsort HSET BinCoproductsHSET. Lemma psubst_interchange {X Y Z : sortToSet} (f : sortToSet⟦X,STLC (Y ⊕ Z)⟧) (g : sortToSet⟦Y, STLC Z⟧) : psubst f · psubst g = exch · psubst (g · weak) · psubst (f · psubst g). Proof. apply subst_interchange_law_gen_instantiated. Qed. Lemma subst_interchange {X : sortToSet} (f : sortToSet⟦1,STLC (1 ⊕ X)⟧) (g : sortToSet⟦1,STLC X⟧) : subst f · subst g = exch · subst (g · weak) · subst (f · subst g). Proof. apply subst_interchange_law_gen_instantiated. Qed. (* We could also unfold these as statements about sort-indexed sets, but this quickly gets very cumbersome: *) (* Definition psubst {X Y : sort → hSet} (f : ∏ t, X t → STLC Y t) (t : sort) : *) (* STLC (λ t, (X t + Y t)%set) t → STLC Y t. *) (* Proof. *) (* intros u. *) (* transparent assert (X' : (sortToSet)). *) (* { use (functor_path_pregroupoid _); apply X. } *) (* transparent assert (Y' : (sortToSet)). *) (* { use (functor_path_pregroupoid _); apply Y. } *) (* transparent assert (f' : (sortToSet⟦ X' , STLC_Monad Y' ⟧)). *) (* { use nat_trans_functor_path_pregroupoid; apply homset_property; use f. } *) (* use (pr1 (@monadSubstGen_instantiated sort SET BinCoproductsHSET STLC_Monad X' Y' f') t). *) End Lam. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/SubstitutionSystems.v000066400000000000000000000625241451125700300277270ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of heterogeneous substitution systems - Various lemmas about the substitution ("bracket") operation - Definition of precategory of substitution systems simplified notion of HSS by Ralph Matthes (2022, 2023) the file is very close to the homonymous file in the parent directory basically, the changes start with [bracket_property] and are then propagated throughout ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Section fix_a_category. (** ** Some variables and assumptions *) Context (C : category) (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . (** preparations for the definition of hss based on a functor [H] *) Section prep_hss. Context (H : functor [C, C] [C, C]). Definition Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. (* An Id_H algebra is a pointed functor *) Definition eta_from_alg (T : algebra_ob Id_H) : EndC ⟦ functor_identity _, `T ⟧. Proof. exact (BinCoproductIn1 (CPEndC _ _) · alg_map _ T). Defined. Local Notation η := eta_from_alg. Definition ptd_from_alg (T : algebra_ob Id_H) : Ptd. Proof. exists (pr1 T). exact (η T). Defined. Definition tau_from_alg (T : algebra_ob Id_H) : EndC ⟦H `T, `T⟧. Proof. exact (BinCoproductIn2 (CPEndC _ _) · alg_map _ T). Defined. Local Notation τ := tau_from_alg. (* Coercion functor_from_algebra_ob (X : algebra_ob _ Id_H) : functor C C := pr1 X. *) Local Notation "f ⊕ g" := (BinCoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g). (** analysis of the "bracket operation" individually for each pointed functor *) Section fix_a_pointed_functor. Context {Z: Ptd}. Context (θ : @PrestrengthForSignatureAtPoint C C C H Z). Definition bracket_property (T : algebra_ob Id_H) (f : U Z --> `T) (h : `T • (U Z) --> `T) : UU := alg_map _ T •• (U Z) · h = (identity (U Z) ⊕ θ `T) · (identity (U Z) ⊕ #H h) · (BinCoproductArrow (CPEndC _ _ ) f (tau_from_alg T)). Definition bracket_at (T : algebra_ob Id_H) (f : U Z --> `T): UU := ∃! h : `T • (U Z) --> `T, bracket_property T f h. Definition bracket_property_parts (T : algebra_ob Id_H) (f : U Z --> `T) (h : `T • (U Z) --> `T) : UU := (f = η T •• (U Z) · h) × (θ `T · #H h · τ T = τ T •• (U Z) · h). Definition bracket_parts_at (T : algebra_ob Id_H) (f : U Z --> `T) : UU := ∃! h : `T • (U Z) --> `T, bracket_property_parts T f h. (* show that for any h of suitable type, the following are equivalent *) Lemma parts_from_whole (T : algebra_ob Id_H) (f : U Z --> `T) (h : `T • (U Z) --> `T) : bracket_property T f h → bracket_property_parts T f h. Proof. intro Hyp. split. + unfold eta_from_alg. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_in1_data. assert (Hyp_inst := nat_trans_eq_pointwise Hyp c); clear Hyp. apply (maponpaths (λ m, BinCoproductIn1 (CP _ _)· m)) in Hyp_inst. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path (f) end. * clear Hyp_inst. rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. * rewrite <- Hyp_inst; clear Hyp_inst. rewrite <- assoc. apply idpath. + unfold tau_from_alg. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_in2_data. assert (Hyp_inst := nat_trans_eq_pointwise Hyp c); clear Hyp. apply (maponpaths (λ m, BinCoproductIn2 (CP _ _)· m)) in Hyp_inst. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path (f) end. * clear Hyp_inst. do 2 rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. unfold tau_from_alg. apply BinCoproductIn2Commutes_right_dir. apply idpath. * rewrite <- Hyp_inst; clear Hyp_inst. rewrite <- assoc. apply idpath. Qed. Lemma whole_from_parts (T : algebra_ob Id_H) (f : U Z --> `T) (h : `T • (U Z) --> `T) : bracket_property_parts T f h → bracket_property T f h. Proof. intros [Hyp1 Hyp2]. apply nat_trans_eq_alt. intro c. apply BinCoproductArrow_eq_cor. + clear Hyp2. assert (Hyp1_inst := nat_trans_eq_pointwise Hyp1 c); clear Hyp1. rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. simpl. simpl in Hyp1_inst. rewrite Hyp1_inst. simpl. apply assoc. + clear Hyp1. assert (Hyp2_inst := nat_trans_eq_pointwise Hyp2 c); clear Hyp2. rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite assoc. eapply pathscomp0. * eapply pathsinv0. exact Hyp2_inst. * clear Hyp2_inst. simpl. do 2 rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. Qed. (* show bracket_parts_point is logically equivalent to bracket_point, then use it to show that bracket_parts is equivalent to bracket using [weqonsecfibers: ∏ (X : UU) (P Q : X → UU), (∏ x : X, P x ≃ Q x) → (∏ x : X, P x) ≃ (∏ x : X, Q x)] *) End fix_a_pointed_functor. Section instantiate_with_identity. Context (T : algebra_ob Id_H). Context (θ : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T)). Definition bracket_property_parts_identity_nicer (h : `T • `T --> `T) : UU := (identity `T = η T •• `T · h) × (θ `T · #H h · τ T = τ T •• `T · h). Lemma bracket_property_parts_identity_nicer_impl1 (h : `T • `T --> `T): bracket_property_parts θ T (identity _) h -> bracket_property_parts_identity_nicer h. Proof. intro Hyp. induction Hyp as [Hyp1 Hyp2]. split. - etrans. 2: { exact Hyp1. } apply nat_trans_eq_alt. intro c. apply idpath. - etrans. { exact Hyp2. } apply idpath. Qed. (** basically the same proof *) Lemma bracket_property_parts_identity_nicer_impl2 (h : `T • `T --> `T): bracket_property_parts_identity_nicer h -> bracket_property_parts θ T (identity _) h. intro Hyp. induction Hyp as [Hyp1 Hyp2]. split. - etrans. 2: { exact Hyp1. } apply nat_trans_eq_alt. intro c. apply idpath. - etrans. { exact Hyp2. } apply idpath. Qed. End instantiate_with_identity. (** the notion one would be looking for: an algebra and a substitution operation that does lookup on variables and behaves homomorphically elsewhere, as instructed by the pre-strength at that point *) Definition heterogeneous_substitution : UU := ∑ (T: algebra_ob Id_H), ∑ (θ : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T)), bracket_at θ T (identity _). Coercion alg_from_hetsubst (T : heterogeneous_substitution) : algebra_ob Id_H := pr1 T. Definition θ_from_hetsubst (T : heterogeneous_substitution) : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T) := pr1 (pr2 T). (** we write prejoin as a warning that the monad laws are not necessarily fulfilled *) Definition prejoin_from_hetsubst (T : heterogeneous_substitution) : `T • `T --> `T := pr1 (pr1 (pr2 (pr2 T))). Lemma prejoin_from_hetsubst_η (T : heterogeneous_substitution) : identity `T = η T •• `T · (prejoin_from_hetsubst T). Proof. refine (pr1 (bracket_property_parts_identity_nicer_impl1 T (θ_from_hetsubst T) _ _)). apply parts_from_whole. exact (pr2 (pr1 (pr2 (pr2 T)))). Qed. Lemma prejoin_from_hetsubst_τ (T : heterogeneous_substitution) : θ_from_hetsubst T `T · #H (prejoin_from_hetsubst T) · τ T = τ T •• `T · (prejoin_from_hetsubst T). Proof. refine (pr2 (bracket_property_parts_identity_nicer_impl1 T (θ_from_hetsubst T) _ _)). apply parts_from_whole. exact (pr2 (pr1 (pr2 (pr2 T)))). Qed. Section fix_a_prestrength. Context (θ : @PrestrengthForSignature C C C H). Definition bracket (T : algebra_ob Id_H) : UU := ∏ (Z : Ptd) (f : U Z --> `T), bracket_at (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f. Lemma isaprop_bracket (T : algebra_ob Id_H) : isaprop (bracket T). Proof. apply impred_isaprop; intro Z. apply impred_isaprop; intro f. apply isapropiscontr. Qed. Definition bracket_parts (T : algebra_ob Id_H) : UU := ∏ (Z : Ptd) (f : U Z --> `T), bracket_parts_at (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f. End fix_a_prestrength. End prep_hss. Arguments ptd_from_alg {_} _ . Arguments prejoin_from_hetsubst {_} _ . Arguments prejoin_from_hetsubst_η {_} _ . Arguments prejoin_from_hetsubst_τ {_} _ . Arguments bracket_parts {_} _ _ . Section def_hss. Context (H : Presignature C C C). Local Notation η := (eta_from_alg H). Local Notation τ := (tau_from_alg H). Let θ : PrestrengthForSignature H := theta H. Let Id_H := Id_H H. (** the notion of a heterogeneous substitution system that asks for more operations to uniquely exist *) Definition hss : UU := ∑ (T: algebra_ob Id_H), bracket H θ T. Coercion hetsubst_from_hss (T : hss) : heterogeneous_substitution H. Proof. exists (pr1 T). use tpair. - apply (nat_trans_fix_snd_arg _ _ _ _ _ θ). - apply (pr2 T). Defined. Definition fbracket (T : hss) (Z : Ptd) (f : U Z --> `T) : `T • (U Z) --> `T := pr1 (pr1 (pr2 T Z f)). Notation "⦃ f ⦄_{ Z }" := (fbracket _ Z f)(at level 0). (** The bracket operation [fbracket] is unique *) Definition fbracket_unique_pointwise (T : hss) {Z : Ptd} (f : U Z --> `T) : ∏ (α : functor_composite (U Z) `T ⟹ pr1 `T), (∏ c : C, pr1 f c = pr1 (η T) (pr1 (U Z) c) · α c) → (∏ c : C, pr1 (θ (`T ⊗ Z)) c · pr1 (#H α) c · pr1 (τ T) c = pr1 (τ T) (pr1 (U Z) c) · α c) → α = ⦃f⦄_{Z}. Proof. intros α H1 H2. apply path_to_ctr. apply whole_from_parts. split. - apply nat_trans_eq_alt; assumption. - apply nat_trans_eq_alt; assumption. Qed. Definition fbracket_unique (T : hss) {Z : Ptd} (f : U Z --> `T) : ∏ α : (*functor_composite (C:=C)*) `T • (U Z) --> `T, bracket_property_parts H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f α → α = ⦃f⦄_{Z}. Proof. intros α [H1 H2]. apply path_to_ctr. apply whole_from_parts. split; assumption. Qed. Definition fbracket_unique_target_pointwise (T : hss) {Z : Ptd} (f : U Z --> `T) : ∏ α : `T • U Z --> `T, bracket_property_parts H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f α → ∏ c, pr1 α c = pr1 ⦃f⦄_{Z} c. Proof. intros α H12. set (t:= fbracket_unique _ _ α H12). apply (nat_trans_eq_weq (homset_property C) _ _ t). Qed. (** Properties of [fbracket] by definition: commutative diagrams *) Lemma fbracket_η (T : hss) : ∏ {Z : Ptd} (f : U Z --> `T), f = η T •• U Z · ⦃f⦄_{Z}. Proof. intros Z f. (* assert (H' := parts_from_whole T Z f (fbracket _ f)) . *) exact (pr1 (parts_from_whole _ _ _ _ _ (pr2 (pr1 (pr2 T Z f))))). Qed. Lemma fbracket_τ (T : hss) : ∏ {Z : Ptd} (f : U Z --> `T), θ (`T ⊗ Z) · #H ⦃f⦄_{Z} · τ T = τ T •• U Z · ⦃f⦄_{Z}. Proof. intros Z f. exact (pr2 (parts_from_whole _ _ _ _ _ (pr2 (pr1 (pr2 T Z f))))). Qed. (** [fbracket] is also natural *) Lemma fbracket_natural (T : hss) {Z Z' : Ptd} (f : Z --> Z') (g : U Z' --> `T) : (`T ∘ #U f : EndC⟦ `T • U Z , `T • U Z' ⟧) · ⦃g⦄_{Z'} = ⦃#U f · g⦄_{Z}. Proof. apply fbracket_unique_pointwise. - simpl. intro c. rewrite assoc. pose proof (nat_trans_ax (η T)) as H'. simpl in H'. rewrite <- H'; clear H'. rewrite <- assoc. apply maponpaths. pose proof (nat_trans_eq_weq (homset_property C) _ _ (fbracket_η T g)) as X. simpl in X. exact (X _ ). - intro c; simpl. assert (H':=nat_trans_ax (τ T)). simpl in H'. eapply pathscomp0. 2: apply assoc'. eapply pathscomp0. 2: { apply cancel_postcomposition. apply H'. } clear H'. set (H':=fbracket_τ T g). simpl in H'. assert (X:= nat_trans_eq_pointwise H' c). simpl in X. rewrite <- assoc. rewrite <- assoc. transitivity ( # (pr1 (H ((`T)))) (pr1 f c) · (pr1 (θ ((`T) ⊗ Z')) c)· pr1 (# H ⦃g⦄_{Z'}) c· pr1 (τ T) c). 2: { rewrite <- assoc. rewrite <- assoc. apply maponpaths. repeat rewrite assoc. apply X. } clear X. set (A:=θ_nat_2_pointwise). simpl in *. set (A':= A C C C H θ (`T) Z Z'). simpl in A'. set (A2:= A' f). clearbody A2; clear A'; clear A. rewrite A2; clear A2. repeat rewrite <- assoc. apply maponpaths. simpl. repeat rewrite assoc. apply cancel_postcomposition. rewrite (functor_comp H). apply cancel_postcomposition. clear H'. set (A:=horcomp_id_postwhisker C C C). rewrite A; try apply homset_property. apply idpath. Qed. (** As a consequence of naturality, we can compute [fbracket f] from [fbracket identity] *) Lemma compute_fbracket (T : hss) : ∏ {Z : Ptd} (f : Z --> ptd_from_alg T), ⦃#U f⦄_{Z} = (`T ∘ # U f : EndC⟦`T • U Z , `T • U (ptd_from_alg T)⟧) · ⦃identity (U (ptd_from_alg T))⦄_{ptd_from_alg T}. Proof. intros Z f. assert (A : f = f · identity _ ). { rewrite id_right; apply idpath. } rewrite A. rewrite functor_comp. rewrite <- fbracket_natural. rewrite id_right. apply idpath. Qed. Section from_identity_to_hss. (** the operations of an hss can be obtained through this formula from just a heterogeneous substitution *) Context (T : algebra_ob Id_H). Context (prejoin : bracket_at H (nat_trans_fix_snd_arg _ _ _ _ _ θ (ptd_from_alg T)) T (identity _)). Let T0 : heterogeneous_substitution H := T ,, (nat_trans_fix_snd_arg _ _ _ _ _ θ (ptd_from_alg T) ,, prejoin). Lemma heterogeneous_substitution_into_bracket {Z : Ptd} (f : Z --> ptd_from_alg T0) : bracket_property H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T0 (#U f) ((` T0 ∘ #U f : EndC ⟦ `T0 • U Z , `T0 • U (ptd_from_alg T0) ⟧) · prejoin_from_hetsubst T0). Proof. apply whole_from_parts. split. - apply nat_trans_eq_alt. intro c. induction f as [f pt]. simpl. assert (alg_map_nat := nat_trans_ax (alg_map Id_H T0) _ _ (pr1 f c)). etrans. 2: { rewrite <- assoc. apply maponpaths. rewrite assoc. apply cancel_postcomposition. exact alg_map_nat. } clear alg_map_nat. etrans. 2: { do 2 rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0. unfold Id_H. simpl. apply BinCoproductIn1Commutes. } simpl. etrans. { apply pathsinv0. apply id_right. } do 2 rewrite <- assoc. apply maponpaths. rewrite assoc. assert (prejoin_ok := prejoin_from_hetsubst_η T0). apply (maponpaths pr1) in prejoin_ok. apply toforallpaths in prejoin_ok. apply prejoin_ok. - rewrite functor_comp. apply nat_trans_eq_alt. intro c. induction f as [f pt]. simpl. assert (alg_map_nat := nat_trans_ax (alg_map Id_H T0) _ _ (pr1 f c)). etrans. 2: { rewrite <- assoc. apply maponpaths. rewrite assoc. apply cancel_postcomposition. exact alg_map_nat. } etrans. 2: { do 2 rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0. unfold Id_H. simpl. apply BinCoproductIn2Commutes. } assert (prejoin_ok := prejoin_from_hetsubst_τ T0). apply (maponpaths pr1) in prejoin_ok. apply toforallpaths in prejoin_ok. assert (prejoin_ok_inst := prejoin_ok c). simpl in prejoin_ok_inst. etrans. { repeat rewrite assoc. do 3 apply cancel_postcomposition. apply pathsinv0. assert (theta_nat_2 := θ_nat_2_pointwise _ _ _ H θ `T0 _ _ (f,,pt) c). rewrite horcomp_id_postwhisker in theta_nat_2; try apply homset_property. apply theta_nat_2. } etrans. { repeat rewrite <- assoc. apply maponpaths. rewrite assoc. exact prejoin_ok_inst. } clear prejoin_ok prejoin_ok_inst. repeat rewrite assoc. apply idpath. Qed. End from_identity_to_hss. (** ** Morphisms of heterogeneous substitution systems *) (** A morphism [f] of pointed functors is an algebra morphism when... *) (* Definition isAlgMor {T T' : Alg} (f : T --> T') : UU := #H (# U f) · τ T' = compose (C:=EndC) (τ T) (#U f). Lemma isaprop_isAlgMor (T T' : Alg) (f : T --> T') : isaprop (isAlgMor f). Proof. apply isaset_nat_trans. apply hs. Qed. *) (** a little preparation for much later *) Lemma τ_part_of_alg_mor (T T' : @algebra_ob [C, C] Id_H) (β : @algebra_mor [C, C] Id_H T T'): #H β · τ T' = compose (C:=EndC) (τ T) β. Proof. assert (β_is_alg_mor := pr2 β). simpl in β_is_alg_mor. assert (β_is_alg_mor_inst := maponpaths (fun m:EndC⟦_,_⟧ => (BinCoproductIn2 (CPEndC _ _))· m) β_is_alg_mor); clear β_is_alg_mor. simpl in β_is_alg_mor_inst. apply nat_trans_eq_alt. intro c. assert (β_is_alg_mor_inst':= nat_trans_eq_pointwise β_is_alg_mor_inst c); clear β_is_alg_mor_inst. simpl in β_is_alg_mor_inst'. rewrite assoc in β_is_alg_mor_inst'. eapply pathscomp0. 2: { eapply pathsinv0. exact β_is_alg_mor_inst'. } clear β_is_alg_mor_inst'. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply idpath. Qed. (** A morphism [β] of pointed functors is a bracket morphism when... *) Lemma is_ptd_mor_alg_mor (T T' : @algebra_ob [C, C] Id_H) (β : @algebra_mor [C, C] Id_H T T') : @is_ptd_mor C (ptd_from_alg T) (ptd_from_alg T') (pr1 β). Proof. simpl. unfold is_ptd_mor. simpl. intro c. rewrite <- assoc. assert (X:=pr2 β). assert (X':= nat_trans_eq_pointwise X c). simpl in *. etrans. { apply maponpaths. apply X'. } unfold coproduct_nat_trans_in1_data. repeat rewrite assoc. unfold coproduct_nat_trans_data. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } simpl. repeat rewrite <- assoc. apply id_left. Qed. Definition ptd_from_alg_mor {T T' : algebra_ob Id_H} (β : algebra_mor _ T T') : ptd_from_alg T --> ptd_from_alg T'. Proof. exists (pr1 β). apply is_ptd_mor_alg_mor. Defined. (** show functor laws for [ptd_from_alg] and [ptd_from_alg_mor] *) Definition ptd_from_alg_functor_data : functor_data (category_FunctorAlg Id_H) Ptd. Proof. exists ptd_from_alg. intros T T' β. apply ptd_from_alg_mor. exact β. Defined. Lemma is_functor_ptd_from_alg_functor_data : is_functor ptd_from_alg_functor_data. Proof. split; simpl; intros. + unfold functor_idax. intro T. (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply (invmap (eq_ptd_mor_cat _ _ _)). apply (invmap (eq_ptd_mor _ _)). (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply idpath. + unfold functor_compax. intros T T' T'' β β'. apply (invmap (eq_ptd_mor_cat _ _ _)). apply (invmap (eq_ptd_mor _ _)). apply idpath. Qed. Definition ptd_from_alg_functor: functor (category_FunctorAlg Id_H) Ptd := tpair _ _ is_functor_ptd_from_alg_functor_data. Definition isbracketMor {T T' : hss} (β : algebra_mor _ T T') : UU := ∏ (Z : Ptd) (f : U Z --> `T), ⦃f⦄_{Z} · β = β •• U Z · ⦃f · #U (# ptd_from_alg_functor β)⦄_{Z}. Lemma isaprop_isbracketMor (T T' : hss) (β : algebra_mor _ T T') : isaprop (isbracketMor β). Proof. do 2 (apply impred; intro). apply isaset_nat_trans. apply homset_property. Qed. (** A morphism of hss is a pointed morphism that is compatible with both [τ] and [fbracket] *) Definition ishssMor {T T' : hss} (β : algebra_mor _ T T') : UU := isbracketMor β. Definition hssMor (T T' : hss) : UU := ∑ β : algebra_mor _ T T', ishssMor β. Coercion ptd_mor_from_hssMor (T T' : hss) (β : hssMor T T') : algebra_mor _ T T' := pr1 β. (* Definition isAlgMor_hssMor {T T' : hss} (β : hssMor T T') : isAlgMor β := pr1 (pr2 β). *) Definition isbracketMor_hssMor {T T' : hss} (β : hssMor T T') : isbracketMor β := pr2 β. (** **** Equality of morphisms of hss *) Section hssMor_equality. (** Show that equality of hssMor is equality of underlying nat. transformations *) Variables T T' : hss. Variables β β' : hssMor T T'. Definition hssMor_eq1 : β = β' ≃ (pr1 β = pr1 β'). Proof. apply subtypeInjectivity. intro γ. apply isaprop_isbracketMor. Defined. Definition hssMor_eq : β = β' ≃ (β : EndC ⟦ _ , _ ⟧) = β'. Proof. eapply weqcomp. - apply hssMor_eq1. - apply subtypeInjectivity. intro. apply isaset_nat_trans. apply homset_property. Defined. End hssMor_equality. Lemma isaset_hssMor (T T' : hss) : isaset (hssMor T T'). Proof. intros β β'. apply (isofhlevelweqb _ (hssMor_eq _ _ β β')). apply isaset_nat_trans. apply homset_property. Qed. (** ** The precategory of hss *) (** *** Identity morphism of hss *) Lemma ishssMor_id (T : hss) : ishssMor (identity (C:=category_FunctorAlg _) (pr1 T)). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. rewrite id_right. rewrite functor_id. rewrite id_right. apply pathsinv0. set (H2:=pre_composition_functor _ _ C (U Z)). set (H2' := functor_id H2). simpl in H2'. simpl. rewrite H2'. rewrite (@id_left EndC). apply idpath. Qed. Definition hssMor_id (T : hss) : hssMor _ _ := tpair _ _ (ishssMor_id T). (** *** Composition of morphisms of hss *) Lemma ishssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'') : ishssMor (compose (C:=category_FunctorAlg _) (pr1 β) (pr1 γ)). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. eapply pathscomp0; [apply assoc|]. (* match goal with | [|- ?l = _ ] => assert (Hyp : l = fbracket T f· pr1 β· pr1 γ) end. *) etrans. { apply cancel_postcomposition. apply isbracketMor_hssMor. } rewrite <- assoc. etrans. { apply maponpaths. apply isbracketMor_hssMor. } rewrite assoc. do 2 rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (functor_comp (pre_composition_functor _ _ C (U Z)) ). Qed. Definition hssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'') : hssMor T T'' := tpair _ _ (ishssMor_comp β γ). Definition hss_obmor : precategory_ob_mor. Proof. exists hss. exact hssMor. Defined. Definition hss_precategory_data : precategory_data. Proof. exists hss_obmor. split. - exact hssMor_id. - exact @hssMor_comp. Defined. Lemma is_precategory_hss : is_precategory hss_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat split; intros. - apply (invmap (hssMor_eq _ _ _ _ )). apply (@id_left EndC). - apply (invmap (hssMor_eq _ _ _ _ )). apply (@id_right EndC). - apply (invmap (hssMor_eq _ _ _ _ )). apply (@assoc EndC). Qed. Definition hss_precategory : precategory := tpair _ _ is_precategory_hss. Lemma has_homsets_precategory_hss : has_homsets hss_precategory. Proof. red. intros T T'. apply isaset_hssMor. Qed. Definition hss_category : category := hss_precategory ,, has_homsets_precategory_hss. End def_hss. End fix_a_category. Arguments hss {_} _ _ . Arguments hssMor {_ _ _ } _ _ . Arguments fbracket {_ _ _} _ _ _ . Arguments fbracket_η {_ _ _} _ {_} _ . Arguments fbracket_τ {_ _ _} _ {_} _ . Arguments fbracket_unique_target_pointwise {_ _ _ } _ {_ _ _} _ _. Arguments fbracket_unique {_ _ _ } _ {_} _ {_} _ . (* Arguments Alg {_ _} _. *) Arguments hss_precategory {_} _ _ . Arguments hss_category {_} _ _ . Arguments eta_from_alg {_ _ _} _. Arguments tau_from_alg {_ _ _} _. Arguments ptd_from_alg {_ _ _} _. Arguments ptd_from_alg_functor {_} _ _ . Arguments bracket_property {_ _ _ _ } _ _ _ _ . Arguments bracket_property_parts {_ _ _ _} _ _ _ _ . Arguments bracket {_ _ _} _ _. Arguments prejoin_from_hetsubst {_ _ _} _ . Arguments prejoin_from_hetsubst_η {_ _ _} _ . Arguments prejoin_from_hetsubst_τ {_ _ _} _ . Notation τ := tau_from_alg. Notation η := eta_from_alg. UniMath-20231010/UniMath/SubstitutionSystems/SimplifiedHSS/SubstitutionSystems_Summary.v000066400000000000000000000244061451125700300314410ustar00rootroot00000000000000 (** Interface file to the package SubstitutionSystems *) (** The purpose of this file is to provide a stable interface to the formalization of heterogeneous substitution systems as defined by Matthes and Uustalu version for simplified notion of HSS by Ralph Matthes (2022, 2023) the file is very close to the homonymous file in the parent directory basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated WARNING: the last part of the previous development is commented out since SimplifiedHSS.Lam is an incomplete adaptation *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.SimplifiedHSS.Lam. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Notation "⦃ f ⦄_{ Z }" := (fbracket _ Z f)(at level 0). Notation "G • F" := (functor_composite F G). (** * Generalized Iteration in Mendler-style and fusion law *) (** Lemma 8 *) Definition GenMendlerIteration : ∏ (C : category) (F : functor C C) (μF_Initial : Initial (FunctorAlg F)) (C' : category) (X : C') (L : functor C C'), is_left_adjoint L → ∏ ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L, ∃! h : C' ⟦ L ` (InitialObject μF_Initial), X ⟧, # L (alg_map F (InitialObject μF_Initial)) · h = ψ ` (InitialObject μF_Initial) h. Proof. simpl. apply GenMendlerIteration. Defined. Arguments It {_ _} _ {_} _ _ _ _. (** Lemma 9 *) Theorem fusion_law : ∏ (C : category) (F : functor C C) (μF_Initial : Initial (category_FunctorAlg F)) (C' : category) (X X' : C') (L : functor C C') (is_left_adj_L : is_left_adjoint L) (ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L) (L' : functor C C') (is_left_adj_L' : is_left_adjoint L') (ψ' : ψ_source C C' X' L' ⟹ ψ_target C F C' X' L') (Φ : yoneda_objects C' X • functor_opp L ⟹ yoneda_objects C' X' • functor_opp L'), let T:= (` (InitialObject μF_Initial)) in ψ T · Φ (F T) = Φ T · ψ' T → Φ T (It μF_Initial X L is_left_adj_L ψ) = It μF_Initial X' L' is_left_adj_L' ψ'. Proof. apply fusion_law. Qed. (** * Heterogeneous Substitution Systems *) (** Lemma 15 *) Lemma fbracket_natural : ∏ (C : category) (CP : BinCoproducts C) (H : Presignature C C C) (T : hss CP H) (Z Z' : category_Ptd C) (f : category_Ptd C ⟦ Z, Z' ⟧) (g : [C,C] ⟦ U Z', `T ⟧), (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U Z' ⟧) · ⦃g⦄_{Z'} = ⦃#U f · g⦄_{Z} . Proof. apply fbracket_natural. Qed. Lemma compute_fbracket : ∏ (C : category) (CP : BinCoproducts C) (H : Presignature C C C) (T : hss CP H) (Z : category_Ptd C) (f : category_Ptd C ⟦ Z, ptd_from_alg T ⟧), ⦃#U f⦄_{Z} = (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U _ ⟧) · ⦃ identity (U (ptd_from_alg T)) ⦄_{ptd_from_alg T}. Proof. apply compute_fbracket. Qed. (** * Monads from hss *) (** Theorem 24 *) Definition Monad_from_hss : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), hss CP H → Monad C. Proof. apply Monad_from_hss. Defined. (** Theorem 25 *) Definition hss_to_monad_functor : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), functor (hss_precategory CP H) (category_Monad C). Proof. apply hss_to_monad_functor. Defined. (** Lemma 26 *) Lemma faithful_hss_to_monad : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), faithful (hss_to_monad_functor C CP H). Proof. apply faithful_hss_to_monad. Defined. (** * Lifting initiality *) (** Theorem 28 in three steps: - the operation itself - its compatibility with variables - its compatibility with signature-dependent constructions *) Definition bracket_for_initial_algebra : ∏ (C : category) (CP : BinCoproducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C), [C, C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA)) ⟧ → [C, C] ⟦ ℓ (U Z) ` (InitialObject IA), ` (InitAlg C CP H IA) ⟧. Proof. apply bracket_Thm15. Defined. Lemma bracket_Thm15_ok_η : ∏ (C : category) (CP : BinCoproducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C) (f : [C,C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA))⟧), f = # (pr1 (ℓ (U Z))) (η (InitAlg C CP H IA)) · bracket_Thm15 C CP KanExt H IA Z f. Proof. apply bracket_Thm15_ok_part1. Qed. Lemma bracket_Thm15_ok_τ : ∏ (C : category) (CP : BinCoproducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C) (f : [C,C] ⟦ U Z, U (ptd_from_alg (InitAlg C CP H IA)) ⟧), (theta H) (` (InitAlg C CP H IA) ⊗ Z) · # H (bracket_Thm15 C CP KanExt H IA Z f) · τ (InitAlg C CP H IA) = # (pr1 (ℓ (U Z))) (τ (InitAlg C CP H IA)) · bracket_Thm15 C CP KanExt H IA Z f. Proof. apply bracket_Thm15_ok_part2. Qed. (** Theorem 29 *) Definition Initial_HSS : ∏ (C : category) (CP : BinCoproducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ H : Presignature C C C, Initial (FunctorAlg (Id_H C CP H)) → Initial (hss_category CP H). Proof. apply InitialHSS. Defined. (** * Sum of signatures *) (** Lemma 30 *) Definition Sum_of_Signatures : ∏ (C D D': category), BinCoproducts D → Signature C D D' → Signature C D D' → Signature C D D'. Proof. apply BinSum_of_Signatures. Defined. (** * Arities of signatures for lambda calculus *) (** Definition 31 *) Definition App_Sig : ∏ (C : category), BinProducts C → Signature C C C. Proof. apply App_Sig. Defined. (** Definition 32 *) Definition Lam_Sig : ∏ (C : category), Terminal C → BinCoproducts C → BinProducts C → Signature C C C. Proof. apply Lam_Sig. Defined. (** Definition 33 *) Definition Flat_Sig : ∏ (C : category), Signature C C C. Proof. apply Flat_Sig. Defined. (** * Evaluation of explicit substitution as initial morphism *) (** this part not compatible with current modifications to the notion of hss (** Definition 36 *) Definition Lam_Flatten : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))), [C, C] ⟦ (Flat_H C) ` (InitialObject Lam_Initial), ` (InitialObject Lam_Initial) ⟧. Proof. apply Lam_Flatten. Defined. (** Lemma 37, construction of the bracket *) Definition fbracket_for_LamE_algebra_on_Lam : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP)))) (Z : category_Ptd C), category_Ptd C ⟦ Z , (ptd_from_alg_functor CC (LamE_Sig C terminal CC CP)) (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧ → [C, C] ⟦ functor_composite (U Z) ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial), ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧. Proof. apply fbracket_for_LamE_algebra_on_Lam. Defined. (** Morphism from initial hss to construed hss, consequence of Lemma 37 *) Definition EVAL : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (Lam_Initial : Initial (FunctorAlg (Id_H C CC (LamSignature.Lam_Sig C terminal CC CP)))) (LamE_Initial : Initial (FunctorAlg (Id_H C CC (LamE_Sig C terminal CC CP)))), hss_category CC (LamE_Sig C terminal CC CP) ⟦ InitialObject (LamEHSS_Initial C terminal CC CP KanExt LamE_Initial), LamE_model_on_Lam C terminal CC CP KanExt Lam_Initial ⟧. Proof. apply FLATTEN. Defined. *) UniMath-20231010/UniMath/SubstitutionSystems/SubstitutionSystems.v000066400000000000000000000623301451125700300252570ustar00rootroot00000000000000 (** ********************************************************** Benedikt Ahrens, Ralph Matthes SubstitutionSystems 2015 ************************************************************) (** ********************************************************** Contents : - Definition of heterogeneous substitution systems - Various lemmas about the substitution ("bracket") operation - Definition of precategory of substitution systems ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Require Import UniMath.CategoryTheory.FunctorCategory. Local Open Scope cat. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Section fix_a_category. (** ** Some variables and assumptions *) Context (C : category) (CP : BinCoproducts C). Local Notation "'EndC'":= ([C, C]) . Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP. (** The category of pointed endofunctors on [C] *) Local Notation "'Ptd'" := (category_Ptd C). (** The category of endofunctors on [C] *) Local Notation "'EndC'":= ([C, C]) . (** preparations for the definition of hss based on a functor [H] *) Section prep_hss. Context (H : functor [C, C] [C, C]). Definition Id_H : functor EndC EndC := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ (functor_identity _ : EndC)) H. (* An Id_H algebra is a pointed functor *) Definition eta_from_alg (T : algebra_ob Id_H) : EndC ⟦ functor_identity _, `T ⟧. Proof. exact (BinCoproductIn1 (CPEndC _ _) · alg_map _ T). Defined. Local Notation η := eta_from_alg. Definition ptd_from_alg (T : algebra_ob Id_H) : Ptd. Proof. exists (pr1 T). exact (η T). Defined. Definition tau_from_alg (T : algebra_ob Id_H) : EndC ⟦H `T, `T⟧. Proof. exact (BinCoproductIn2 (CPEndC _ _) · alg_map _ T). Defined. Local Notation τ := tau_from_alg. (* Coercion functor_from_algebra_ob (X : algebra_ob _ Id_H) : functor C C := pr1 X. *) Local Notation "f ⊕ g" := (BinCoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g). (** analysis of the "bracket operation" individually for each pointed functor *) Section fix_a_pointed_functor. Context {Z: Ptd}. Context (θ : @PrestrengthForSignatureAtPoint C C C H Z). Definition bracket_property (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T) (h : `T • (U Z) --> `T) : UU := alg_map _ T •• (U Z) · h = (identity (U Z) ⊕ θ `T) · (identity (U Z) ⊕ #H h) · (BinCoproductArrow (CPEndC _ _ ) (#U f) (tau_from_alg T)). Definition bracket_at (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T): UU := ∃! h : `T • (U Z) --> `T, bracket_property T f h. Definition bracket_property_parts (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T) (h : `T • (U Z) --> `T) : UU := (#U f = η T •• (U Z) · h) × (θ `T · #H h · τ T = τ T •• (U Z) · h). Definition bracket_parts_at (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T) : UU := ∃! h : `T • (U Z) --> `T, bracket_property_parts T f h. (* show that for any h of suitable type, the following are equivalent *) Lemma parts_from_whole (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T) (h : `T • (U Z) --> `T) : bracket_property T f h → bracket_property_parts T f h. Proof. intro Hyp. split. + unfold eta_from_alg. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_in1_data. assert (Hyp_inst := nat_trans_eq_pointwise Hyp c); clear Hyp. apply (maponpaths (λ m, BinCoproductIn1 (CP _ _)· m)) in Hyp_inst. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path (f) end. * clear Hyp_inst. rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. apply idpath. * rewrite <- Hyp_inst; clear Hyp_inst. rewrite <- assoc. apply idpath. + unfold tau_from_alg. apply nat_trans_eq_alt. intro c. simpl. unfold coproduct_nat_trans_in2_data. assert (Hyp_inst := nat_trans_eq_pointwise Hyp c); clear Hyp. apply (maponpaths (λ m, BinCoproductIn2 (CP _ _)· m)) in Hyp_inst. match goal with |[ H1 : _ = ?f |- _ = _ ] => intermediate_path (f) end. * clear Hyp_inst. do 2 rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. unfold tau_from_alg. apply BinCoproductIn2Commutes_right_dir. apply idpath. * rewrite <- Hyp_inst; clear Hyp_inst. rewrite <- assoc. apply idpath. Qed. Lemma whole_from_parts (T : algebra_ob Id_H) (f : Z --> ptd_from_alg T) (h : `T • (U Z) --> `T) : bracket_property_parts T f h → bracket_property T f h. Proof. intros [Hyp1 Hyp2]. apply nat_trans_eq_alt. intro c. apply BinCoproductArrow_eq_cor. + clear Hyp2. assert (Hyp1_inst := nat_trans_eq_pointwise Hyp1 c); clear Hyp1. rewrite <- assoc. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_in_ctx_dir. rewrite id_left. apply BinCoproductIn1Commutes_right_dir. simpl. simpl in Hyp1_inst. rewrite Hyp1_inst. simpl. apply assoc. + clear Hyp1. assert (Hyp2_inst := nat_trans_eq_pointwise Hyp2 c); clear Hyp2. rewrite <- assoc. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite assoc. eapply pathscomp0. * eapply pathsinv0. exact Hyp2_inst. * clear Hyp2_inst. simpl. do 2 rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply maponpaths. apply BinCoproductIn2Commutes_right_dir. apply idpath. Qed. (* show bracket_parts_point is logically equivalent to bracket_point, then use it to show that bracket_parts is equivalent to bracket using [weqonsecfibers: ∏ (X : UU) (P Q : X → UU), (∏ x : X, P x ≃ Q x) → (∏ x : X, P x) ≃ (∏ x : X, Q x)] *) End fix_a_pointed_functor. Section instantiate_with_identity. Context (T : algebra_ob Id_H). Context (θ : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T)). Definition bracket_property_parts_identity_nicer (h : `T • `T --> `T) : UU := (identity `T = η T •• `T · h) × (θ `T · #H h · τ T = τ T •• `T · h). Lemma bracket_property_parts_identity_nicer_impl1 (h : `T • `T --> `T): bracket_property_parts θ T (identity _) h -> bracket_property_parts_identity_nicer h. Proof. intro Hyp. induction Hyp as [Hyp1 Hyp2]. split. - etrans. 2: { exact Hyp1. } apply nat_trans_eq_alt. intro c. apply idpath. - etrans. { exact Hyp2. } apply idpath. Qed. (** basically the same proof *) Lemma bracket_property_parts_identity_nicer_impl2 (h : `T • `T --> `T): bracket_property_parts_identity_nicer h -> bracket_property_parts θ T (identity _) h. intro Hyp. induction Hyp as [Hyp1 Hyp2]. split. - etrans. 2: { exact Hyp1. } apply nat_trans_eq_alt. intro c. apply idpath. - etrans. { exact Hyp2. } apply idpath. Qed. End instantiate_with_identity. (** the notion one would be looking for: an algebra and a substitution operation that does lookup on variables and behaves homomorphically elsewhere, as instructed by the pre-strength at that point *) Definition heterogeneous_substitution : UU := ∑ (T: algebra_ob Id_H), ∑ (θ : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T)), bracket_at θ T (identity _). Coercion alg_from_hetsubst (T : heterogeneous_substitution) : algebra_ob Id_H := pr1 T. Definition θ_from_hetsubst (T : heterogeneous_substitution) : @PrestrengthForSignatureAtPoint C C C H (ptd_from_alg T) := pr1 (pr2 T). (** we write prejoin as a warning that the monad laws are not necessarily fulfilled *) Definition prejoin_from_hetsubst (T : heterogeneous_substitution) : `T • `T --> `T := pr1 (pr1 (pr2 (pr2 T))). Lemma prejoin_from_hetsubst_η (T : heterogeneous_substitution) : identity `T = η T •• `T · (prejoin_from_hetsubst T). Proof. refine (pr1 (bracket_property_parts_identity_nicer_impl1 T (θ_from_hetsubst T) _ _)). apply parts_from_whole. exact (pr2 (pr1 (pr2 (pr2 T)))). Qed. Lemma prejoin_from_hetsubst_τ (T : heterogeneous_substitution) : θ_from_hetsubst T `T · #H (prejoin_from_hetsubst T) · τ T = τ T •• `T · (prejoin_from_hetsubst T). Proof. refine (pr2 (bracket_property_parts_identity_nicer_impl1 T (θ_from_hetsubst T) _ _)). apply parts_from_whole. exact (pr2 (pr1 (pr2 (pr2 T)))). Qed. Section fix_a_prestrength. Context (θ : @PrestrengthForSignature C C C H). Definition bracket (T : algebra_ob Id_H) : UU := ∏ (Z : Ptd) (f : Z --> ptd_from_alg T), bracket_at (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f. Lemma isaprop_bracket (T : algebra_ob Id_H) : isaprop (bracket T). Proof. apply impred_isaprop; intro Z. apply impred_isaprop; intro f. apply isapropiscontr. Qed. Definition bracket_parts (T : algebra_ob Id_H) : UU := ∏ (Z : Ptd) (f : Z --> ptd_from_alg T), bracket_parts_at (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f. End fix_a_prestrength. End prep_hss. Arguments ptd_from_alg {_} _ . Arguments prejoin_from_hetsubst {_} _ . Arguments prejoin_from_hetsubst_η {_} _ . Arguments prejoin_from_hetsubst_τ {_} _ . Arguments bracket_parts {_} _ _ . Section def_hss. Context (H : Presignature C C C). Local Notation η := (eta_from_alg H). Local Notation τ := (tau_from_alg H). Let θ : PrestrengthForSignature H := theta H. Let Id_H : [C, C] ⟶ [C, C] := Id_H H. (** the notion of a heterogeneous substitution system that asks for more operations to uniquely exist *) Definition hss : UU := ∑ (T: algebra_ob Id_H), bracket H θ T. Coercion hetsubst_from_hss (T : hss) : heterogeneous_substitution H := pr1 T,, (nat_trans_fix_snd_arg _ _ _ _ _ θ (ptd_from_alg (pr1 T)) ,, pr2 T _ (identity _)). Definition fbracket (T : hss) {Z : Ptd} (f : Z --> ptd_from_alg T) : `T • (U Z) --> `T := pr1 (pr1 (pr2 T Z f)). Notation "⦃ f ⦄" := (fbracket _ f)(at level 0). (** The bracket operation [fbracket] is unique *) Definition fbracket_unique_pointwise (T : hss) {Z : Ptd} (f : Z --> ptd_from_alg T) : ∏ (α : functor_composite (U Z) `T ⟹ pr1 `T), (∏ c : C, pr1 (#U f) c = pr1 (η T) (pr1 (U Z) c) · α c) → (∏ c : C, pr1 (θ (`T ⊗ Z)) c · pr1 (#H α) c · pr1 (τ T) c = pr1 (τ T) (pr1 (U Z) c) · α c) → α = ⦃f⦄. Proof. intros α H1 H2. apply path_to_ctr. apply whole_from_parts. split. - apply nat_trans_eq_alt; assumption. - apply nat_trans_eq_alt; assumption. Qed. Definition fbracket_unique (T : hss) {Z : Ptd} (f : Z --> ptd_from_alg T) : ∏ α : (*functor_composite (C:=C)*) `T • (U Z) --> `T, bracket_property_parts H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f α → α = ⦃f⦄. Proof. intros α [H1 H2]. apply path_to_ctr. apply whole_from_parts. split; assumption. Qed. Definition fbracket_unique_target_pointwise (T : hss) {Z : Ptd} (f : Z --> ptd_from_alg T) : ∏ α : `T • U Z --> `T, bracket_property_parts H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T f α → ∏ c, pr1 α c = pr1 ⦃ f ⦄ c. Proof. intros α H12. set (t:= fbracket_unique _ _ α H12). apply (nat_trans_eq_weq (homset_property C) _ _ t). Qed. (** Properties of [fbracket] by definition: commutative diagrams *) Lemma fbracket_η (T : hss) : ∏ {Z : Ptd} (f : Z --> ptd_from_alg T), #U f = η T •• U Z · ⦃f⦄. Proof. intros Z f. (* assert (H' := parts_from_whole T Z f (fbracket _ f)) . *) exact (pr1 (parts_from_whole _ _ _ _ _ (pr2 (pr1 (pr2 T Z f))))). Qed. Lemma fbracket_τ (T : hss) : ∏ {Z : Ptd} (f : Z --> ptd_from_alg T), θ (`T ⊗ Z) · #H ⦃f⦄ · τ T = τ T •• U Z · ⦃f⦄. Proof. intros Z f. exact (pr2 (parts_from_whole _ _ _ _ _ (pr2 (pr1 (pr2 T Z f))))). Qed. (** [fbracket] is also natural *) Lemma fbracket_natural (T : hss) {Z Z' : Ptd} (f : Z --> Z') (g : Z' --> ptd_from_alg T) : (` T ∘ # U f : EndC ⟦ `T • U Z , `T • U Z' ⟧) · ⦃ g ⦄ = ⦃ f · g ⦄. Proof. apply fbracket_unique_pointwise. - simpl. intro c. rewrite assoc. pose proof (nat_trans_ax (η T)) as H'. simpl in H'. rewrite <- H'; clear H'. rewrite <- assoc. apply maponpaths. pose proof (nat_trans_eq_weq (homset_property C) _ _ (fbracket_η T g)) as X. simpl in X. exact (X _ ). - intro c; simpl. assert (H':=nat_trans_ax (τ T)). simpl in H'. eapply pathscomp0. 2: apply assoc'. eapply pathscomp0. 2: { apply cancel_postcomposition. apply H'. } clear H'. set (H':=fbracket_τ T g). simpl in H'. assert (X:= nat_trans_eq_pointwise H' c). simpl in X. rewrite <- assoc. rewrite <- assoc. transitivity ( # (pr1 (H ((`T)))) (pr1 (pr1 f) c) · (pr1 (θ ((`T) ⊗ Z')) c)· pr1 (# H (fbracket T g)) c· pr1 (τ T) c). 2: { rewrite <- assoc. rewrite <- assoc. apply maponpaths. repeat rewrite assoc. apply X. } clear X. set (A:=θ_nat_2_pointwise). simpl in *. set (A':= A C C C H θ (`T) Z Z'). simpl in A'. set (A2:= A' f). clearbody A2; clear A'; clear A. rewrite A2; clear A2. repeat rewrite <- assoc. apply maponpaths. simpl. repeat rewrite assoc. apply cancel_postcomposition. rewrite (functor_comp H). apply cancel_postcomposition. clear H'. set (A:=horcomp_id_postwhisker C C C). rewrite A; try apply homset_property. apply idpath. Qed. (** As a consequence of naturality, we can compute [fbracket f] from [fbracket identity] *) Lemma compute_fbracket (T : hss) : ∏ {Z : Ptd} (f : Z --> ptd_from_alg T), ⦃ f ⦄ = (` T ∘ # U f : EndC ⟦ `T • U Z , `T • U (ptd_from_alg T) ⟧) · ⦃ identity (ptd_from_alg T) ⦄. Proof. intros Z f. assert (A : f = f · identity _ ). { rewrite id_right; apply idpath. } rewrite A. rewrite <- fbracket_natural. rewrite id_right. apply idpath. Qed. Section from_identity_to_hss. (** the operations of an hss can be obtained through this formula from just a heterogeneous substitution *) Context (T : algebra_ob Id_H). Context (prejoin : bracket_at H (nat_trans_fix_snd_arg _ _ _ _ _ θ (ptd_from_alg T)) T (identity _)). Let T0 : heterogeneous_substitution H := T ,, (nat_trans_fix_snd_arg _ _ _ _ _ θ (ptd_from_alg T) ,, prejoin). Lemma heterogeneous_substitution_into_bracket {Z : Ptd} (f : Z --> ptd_from_alg T0) : bracket_property H (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) T0 f ((` T0 ∘ # U f : EndC ⟦ `T0 • U Z , `T0 • U (ptd_from_alg T0) ⟧) · prejoin_from_hetsubst T0). Proof. apply whole_from_parts. split. - apply nat_trans_eq_alt. intro c. induction f as [f pt]. simpl. assert (alg_map_nat := nat_trans_ax (alg_map Id_H T0) _ _ (pr1 f c)). etrans. 2: { rewrite <- assoc. apply maponpaths. rewrite assoc. apply cancel_postcomposition. exact alg_map_nat. } clear alg_map_nat. etrans. 2: { do 2 rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0. unfold Id_H. simpl. apply BinCoproductIn1Commutes. } simpl. etrans. { apply pathsinv0. apply id_right. } do 2 rewrite <- assoc. apply maponpaths. rewrite assoc. assert (prejoin_ok := prejoin_from_hetsubst_η T0). apply (maponpaths pr1) in prejoin_ok. apply toforallpaths in prejoin_ok. apply prejoin_ok. - rewrite functor_comp. apply nat_trans_eq_alt. intro c. induction f as [f pt]. simpl. assert (alg_map_nat := nat_trans_ax (alg_map Id_H T0) _ _ (pr1 f c)). etrans. 2: { rewrite <- assoc. apply maponpaths. rewrite assoc. apply cancel_postcomposition. exact alg_map_nat. } etrans. 2: { do 2 rewrite assoc. do 2 apply cancel_postcomposition. apply pathsinv0. unfold Id_H. simpl. apply BinCoproductIn2Commutes. } assert (prejoin_ok := prejoin_from_hetsubst_τ T0). apply (maponpaths pr1) in prejoin_ok. apply toforallpaths in prejoin_ok. assert (prejoin_ok_inst := prejoin_ok c). simpl in prejoin_ok_inst. etrans. { repeat rewrite assoc. do 3 apply cancel_postcomposition. apply pathsinv0. assert (theta_nat_2 := θ_nat_2_pointwise _ _ _ H θ `T0 _ _ (f,,pt) c). rewrite horcomp_id_postwhisker in theta_nat_2; try apply homset_property. apply theta_nat_2. } etrans. { repeat rewrite <- assoc. apply maponpaths. rewrite assoc. exact prejoin_ok_inst. } clear prejoin_ok prejoin_ok_inst. repeat rewrite assoc. apply idpath. Qed. End from_identity_to_hss. (** ** Morphisms of heterogeneous substitution systems *) (** A morphism [f] of pointed functors is an algebra morphism when... *) (* Definition isAlgMor {T T' : Alg} (f : T --> T') : UU := #H (# U f) · τ T' = compose (C:=EndC) (τ T) (#U f). Lemma isaprop_isAlgMor (T T' : Alg) (f : T --> T') : isaprop (isAlgMor f). Proof. apply isaset_nat_trans. apply hs. Qed. *) (** a little preparation for much later *) Lemma τ_part_of_alg_mor (T T' : @algebra_ob [C, C] Id_H) (β : @algebra_mor [C, C] Id_H T T'): #H β · τ T' = compose (C:=EndC) (τ T) β. Proof. assert (β_is_alg_mor := pr2 β). simpl in β_is_alg_mor. assert (β_is_alg_mor_inst := maponpaths (fun m:EndC⟦_,_⟧ => (BinCoproductIn2 (CPEndC _ _))· m) β_is_alg_mor); clear β_is_alg_mor. simpl in β_is_alg_mor_inst. apply nat_trans_eq_alt. intro c. assert (β_is_alg_mor_inst':= nat_trans_eq_pointwise β_is_alg_mor_inst c); clear β_is_alg_mor_inst. simpl in β_is_alg_mor_inst'. rewrite assoc in β_is_alg_mor_inst'. eapply pathscomp0. 2: { eapply pathsinv0. exact β_is_alg_mor_inst'. } clear β_is_alg_mor_inst'. apply BinCoproductIn2Commutes_right_in_ctx_dir. simpl. rewrite <- assoc. apply idpath. Qed. (** A morphism [β] of pointed functors is a bracket morphism when... *) Lemma is_ptd_mor_alg_mor (T T' : @algebra_ob [C, C] Id_H) (β : @algebra_mor [C, C] Id_H T T') : @is_ptd_mor C (ptd_from_alg T) (ptd_from_alg T') (pr1 β). Proof. simpl. unfold is_ptd_mor. simpl. intro c. rewrite <- assoc. assert (X:=pr2 β). assert (X':= nat_trans_eq_pointwise X c). simpl in *. etrans. { apply maponpaths. apply X'. } unfold coproduct_nat_trans_in1_data. repeat rewrite assoc. unfold coproduct_nat_trans_data. etrans. { apply cancel_postcomposition. apply BinCoproductIn1Commutes. } simpl. repeat rewrite <- assoc. apply id_left. Qed. Definition ptd_from_alg_mor {T T' : algebra_ob Id_H} (β : algebra_mor _ T T') : ptd_from_alg T --> ptd_from_alg T'. Proof. exists (pr1 β). apply is_ptd_mor_alg_mor. Defined. (** show functor laws for [ptd_from_alg] and [ptd_from_alg_mor] *) Definition ptd_from_alg_functor_data : functor_data (category_FunctorAlg Id_H) Ptd. Proof. exists ptd_from_alg. intros T T' β. apply ptd_from_alg_mor. exact β. Defined. Lemma is_functor_ptd_from_alg_functor_data : is_functor ptd_from_alg_functor_data. Proof. split; simpl; intros. + unfold functor_idax. intro T. (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply (invmap (eq_ptd_mor_cat _ _ _)). apply (invmap (eq_ptd_mor _ _)). (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *) apply idpath. + unfold functor_compax. intros T T' T'' β β'. apply (invmap (eq_ptd_mor_cat _ _ _)). apply (invmap (eq_ptd_mor _ _)). apply idpath. Qed. Definition ptd_from_alg_functor: functor (category_FunctorAlg Id_H) Ptd := tpair _ _ is_functor_ptd_from_alg_functor_data. Definition isbracketMor {T T' : hss} (β : algebra_mor _ T T') : UU := ∏ (Z : Ptd) (f : Z --> ptd_from_alg T), ⦃ f ⦄ · β = β •• U Z · ⦃ f · # ptd_from_alg_functor β ⦄. Lemma isaprop_isbracketMor (T T':hss) (β : algebra_mor _ T T') : isaprop (isbracketMor β). Proof. do 2 (apply impred; intro). apply isaset_nat_trans. apply homset_property. Qed. (** A morphism of hss is a pointed morphism that is compatible with both [τ] and [fbracket] *) Definition ishssMor {T T' : hss} (β : algebra_mor _ T T') : UU := isbracketMor β. Definition hssMor (T T' : hss) : UU := ∑ β : algebra_mor _ T T', ishssMor β. Coercion ptd_mor_from_hssMor (T T' : hss) (β : hssMor T T') : algebra_mor _ T T' := pr1 β. (* Definition isAlgMor_hssMor {T T' : hss} (β : hssMor T T') : isAlgMor β := pr1 (pr2 β). *) Definition isbracketMor_hssMor {T T' : hss} (β : hssMor T T') : isbracketMor β := pr2 β. (** **** Equality of morphisms of hss *) Section hssMor_equality. (** Show that equality of hssMor is equality of underlying nat. transformations *) Variables T T' : hss. Variables β β' : hssMor T T'. Definition hssMor_eq1 : β = β' ≃ (pr1 β = pr1 β'). Proof. apply subtypeInjectivity. intro γ. apply isaprop_isbracketMor. Defined. Definition hssMor_eq : β = β' ≃ (β : EndC ⟦ _ , _ ⟧) = β'. Proof. eapply weqcomp. - apply hssMor_eq1. - apply subtypeInjectivity. intro. apply isaset_nat_trans. apply homset_property. Defined. End hssMor_equality. Lemma isaset_hssMor (T T' : hss) : isaset (hssMor T T'). Proof. intros β β'. apply (isofhlevelweqb _ (hssMor_eq _ _ β β')). apply isaset_nat_trans. apply homset_property. Qed. (** ** The precategory of hss *) (** *** Identity morphism of hss *) Lemma ishssMor_id (T : hss) : ishssMor (identity (C:=category_FunctorAlg _) (pr1 T)). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. rewrite id_right. rewrite functor_id. rewrite id_right. apply pathsinv0. set (H2:=pre_composition_functor _ _ C (U Z)). set (H2' := functor_id H2). simpl in H2'. simpl. rewrite H2'. rewrite (@id_left EndC). apply idpath. Qed. Definition hssMor_id (T : hss) : hssMor _ _ := tpair _ _ (ishssMor_id T). (** *** Composition of morphisms of hss *) Lemma ishssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'') : ishssMor (compose (C:=category_FunctorAlg _) (pr1 β) (pr1 γ)). Proof. unfold ishssMor. unfold isbracketMor. intros Z f. eapply pathscomp0; [apply assoc|]. (* match goal with | [|- ?l = _ ] => assert (Hyp : l = fbracket T f· pr1 β· pr1 γ) end. *) etrans. { apply cancel_postcomposition. apply isbracketMor_hssMor. } rewrite <- assoc. etrans. { apply maponpaths. apply isbracketMor_hssMor. } rewrite assoc. rewrite functor_comp. rewrite assoc. apply cancel_postcomposition. apply pathsinv0, (functor_comp (pre_composition_functor _ _ C (U Z)) ). Qed. Definition hssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'') : hssMor T T'' := tpair _ _ (ishssMor_comp β γ). Definition hss_obmor : precategory_ob_mor. Proof. exists hss. exact hssMor. Defined. Definition hss_precategory_data : precategory_data. Proof. exists hss_obmor. split. - exact hssMor_id. - exact @hssMor_comp. Defined. Lemma is_precategory_hss : is_precategory hss_precategory_data. Proof. apply is_precategory_one_assoc_to_two. repeat split; intros. - apply (invmap (hssMor_eq _ _ _ _ )). apply (@id_left EndC). - apply (invmap (hssMor_eq _ _ _ _ )). apply (@id_right EndC). - apply (invmap (hssMor_eq _ _ _ _ )). apply (@assoc EndC). Qed. Definition hss_precategory : precategory := tpair _ _ is_precategory_hss. Lemma has_homsets_precategory_hss : has_homsets hss_precategory. Proof. red. intros T T'. apply isaset_hssMor. Qed. Definition hss_category : category := hss_precategory ,, has_homsets_precategory_hss. End def_hss. End fix_a_category. Arguments hss {_} _ _ . Arguments hssMor {_ _ _ } _ _ . Arguments fbracket {_ _ _} _ {_} _ . Arguments fbracket_η {_ _ _} _ {_} _ . Arguments fbracket_τ {_ _ _} _ {_} _ . Arguments fbracket_unique_target_pointwise {_ _ _ } _ {_ _ _} _ _. Arguments fbracket_unique {_ _ _ } _ {_} _ {_} _ . (* Arguments Alg {_ _} _. *) Arguments hss_precategory {_} _ _ . Arguments hss_category {_} _ _ . Arguments eta_from_alg {_ _ _} _. Arguments tau_from_alg {_ _ _} _. Arguments ptd_from_alg {_ _ _} _. Arguments ptd_from_alg_functor {_} _ _ . Arguments bracket_property {_ _ _ _ } _ _ _ _ . Arguments bracket_property_parts {_ _ _ _} _ _ _ _ . Arguments bracket {_ _ _} _ _. Arguments prejoin_from_hetsubst {_ _ _} _ . Arguments prejoin_from_hetsubst_η {_ _ _} _ . Arguments prejoin_from_hetsubst_τ {_ _ _} _ . Notation τ := tau_from_alg. Notation η := eta_from_alg. UniMath-20231010/UniMath/SubstitutionSystems/SubstitutionSystems_Summary.v000066400000000000000000000236441451125700300270010ustar00rootroot00000000000000 (** Interface file to the package SubstitutionSystems *) (** The purpose of this file is to provide a stable interface to the formalization of heterogeneous substitution systems as defined by Matthes and Uustalu PLEASE DO NOT RENAME THIS FILE - its name is referenced in an article about this formalization TODO: provide reference to the article/preprint *) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.Adjunctions.Core. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.Monads.Monads. Require Import UniMath.CategoryTheory.limits.binproducts. Require Import UniMath.CategoryTheory.limits.bincoproducts. Require Import UniMath.CategoryTheory.limits.initial. Require Import UniMath.CategoryTheory.limits.terminal. Require Import UniMath.CategoryTheory.FunctorAlgebras. Require Import UniMath.CategoryTheory.opp_precat. Require Import UniMath.CategoryTheory.yoneda. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.HorizontalComposition. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.SubstitutionSystems.BinSumOfSignatures. Require Import UniMath.SubstitutionSystems.SubstitutionSystems. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.CategoryTheory.RightKanExtension. Require Import UniMath.SubstitutionSystems.GenMendlerIteration. Require Import UniMath.SubstitutionSystems.LiftingInitial. Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems. Require Import UniMath.SubstitutionSystems.LamSignature. Require Import UniMath.SubstitutionSystems.Lam. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Notation "⦃ f ⦄" := (fbracket _ f)(at level 0). Notation "G • F" := (functor_composite F G). (** * Generalized Iteration in Mendler-style and fusion law *) (** Lemma 8 *) Definition GenMendlerIteration : ∏ (C : category) (F : functor C C) (μF_Initial : Initial (FunctorAlg F)) (C' : category) (X : C') (L : functor C C'), is_left_adjoint L → ∏ ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L, ∃! h : C' ⟦ L ` (InitialObject μF_Initial), X ⟧, # L (alg_map F (InitialObject μF_Initial)) · h = ψ ` (InitialObject μF_Initial) h. Proof. simpl. apply GenMendlerIteration. Defined. Arguments It {_ _} _ {_} _ _ _ _. (** Lemma 9 *) Theorem fusion_law : ∏ (C : category) (F : functor C C) (μF_Initial : Initial (category_FunctorAlg F)) (C' : category) (X X' : C') (L : functor C C') (is_left_adj_L : is_left_adjoint L) (ψ : ψ_source C C' X L ⟹ ψ_target C F C' X L) (L' : functor C C') (is_left_adj_L' : is_left_adjoint L') (ψ' : ψ_source C C' X' L' ⟹ ψ_target C F C' X' L') (Φ : yoneda_objects C' X • functor_opp L ⟹ yoneda_objects C' X' • functor_opp L'), let T:= (` (InitialObject μF_Initial)) in ψ T · Φ (F T) = Φ T · ψ' T → Φ T (It μF_Initial X L is_left_adj_L ψ) = It μF_Initial X' L' is_left_adj_L' ψ'. Proof. apply fusion_law. Qed. (** * Heterogeneous Substitution Systems *) (** Lemma 15 *) Lemma fbracket_natural : ∏ (C : category) (CP : BinCoproducts C) (H : Presignature C C C) (T : hss CP H) (Z Z' : category_Ptd C) (f : category_Ptd C ⟦ Z, Z' ⟧) (g : category_Ptd C ⟦ Z', ptd_from_alg T ⟧), (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U Z' ⟧) · ⦃ g ⦄ = ⦃ f · g ⦄ . Proof. apply fbracket_natural. Qed. Lemma compute_fbracket : ∏ (C : category) (CP : BinCoproducts C) (H : Presignature C C C) (T : hss CP H) (Z : category_Ptd C) (f : category_Ptd C ⟦ Z, ptd_from_alg T ⟧), ⦃ f ⦄ = (`T ∘ # U f : [C, C] ⟦ `T • U Z , `T • U _ ⟧) · ⦃ identity (ptd_from_alg T) ⦄. Proof. apply compute_fbracket. Qed. (** * Monads from hss *) (** Theorem 24 *) Definition Monad_from_hss : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), hss CP H → Monad C. Proof. apply Monad_from_hss. Defined. (** Theorem 25 *) Definition hss_to_monad_functor : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), functor (hss_precategory CP H) (category_Monad C). Proof. apply hss_to_monad_functor. Defined. (** Lemma 26 *) Lemma faithful_hss_to_monad : ∏ (C : category) (CP : BinCoproducts C) (H : Signature C C C), faithful (hss_to_monad_functor C CP H). Proof. apply faithful_hss_to_monad. Defined. (** * Lifting initiality *) (** Theorem 28 in three steps: - the operation itself - its compatibility with variables - its compatibility with signature-dependent constructions *) Definition bracket_for_initial_algebra : ∏ (C : category) (CP : BinCoproducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C), category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA) ⟧ → [C, C] ⟦ ℓ (U Z) ` (InitialObject IA), ` (InitAlg C CP H IA) ⟧. Proof. apply bracket_Thm15. Defined. Lemma bracket_Thm15_ok_η : ∏ (C : category) (CP : BinCoproducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C) (f : category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA)⟧), # U f = # (pr1 (ℓ (U Z))) (η (InitAlg C CP H IA)) · bracket_Thm15 C CP KanExt H IA Z f. Proof. apply bracket_Thm15_ok_part1. Qed. Lemma bracket_Thm15_ok_τ : ∏ (C : category) (CP : BinCoproducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (H : Presignature C C C) (IA : Initial (FunctorAlg (Id_H C CP H))) (Z : category_Ptd C) (f : category_Ptd C ⟦ Z, ptd_from_alg (InitAlg C CP H IA) ⟧), (theta H) (` (InitAlg C CP H IA) ⊗ Z) · # H (bracket_Thm15 C CP KanExt H IA Z f) · τ (InitAlg C CP H IA) = # (pr1 (ℓ (U Z))) (τ (InitAlg C CP H IA)) · bracket_Thm15 C CP KanExt H IA Z f. Proof. apply bracket_Thm15_ok_part2. Qed. (** Theorem 29 *) Definition Initial_HSS : ∏ (C : category) (CP : BinCoproducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ H : Presignature C C C, Initial (FunctorAlg (Id_H C CP H)) → Initial (hss_category CP H). Proof. apply InitialHSS. Defined. (** * Sum of signatures *) (** Lemma 30 *) Definition Sum_of_Signatures : ∏ (C D D': category), BinCoproducts D → Signature C D D' → Signature C D D' → Signature C D D'. Proof. apply BinSum_of_Signatures. Defined. (** * Arities of signatures for lambda calculus *) (** Definition 31 *) Definition App_Sig : ∏ (C : category), BinProducts C → Signature C C C. Proof. apply App_Sig. Defined. (** Definition 32 *) Definition Lam_Sig : ∏ (C : category), Terminal C → BinCoproducts C → BinProducts C → Signature C C C. Proof. apply Lam_Sig. Defined. (** Definition 33 *) Definition Flat_Sig : ∏ (C : category), Signature C C C. Proof. apply Flat_Sig. Defined. (** * Evaluation of explicit substitution as initial morphism *) (** Definition 36 *) Definition Lam_Flatten : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C), (∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) → ∏ Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP))), [C, C] ⟦ (Flat_H C) ` (InitialObject Lam_Initial), ` (InitialObject Lam_Initial) ⟧. Proof. apply Lam_Flatten. Defined. (** Lemma 37, construction of the bracket *) Definition fbracket_for_LamE_algebra_on_Lam : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (Lam_Initial : Initial (FunctorAlg (Id_H C CC (Lam_Sig C terminal CC CP)))) (Z : category_Ptd C), category_Ptd C ⟦ Z , (ptd_from_alg_functor CC (LamE_Sig C terminal CC CP)) (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧ → [C, C] ⟦ functor_composite (U Z) ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial), ` (LamE_algebra_on_Lam C terminal CC CP KanExt Lam_Initial) ⟧. Proof. apply fbracket_for_LamE_algebra_on_Lam. Defined. (** Morphism from initial hss to construed hss, consequence of Lemma 37 *) Definition EVAL : ∏ (C : category) (terminal : Terminal C) (CC : BinCoproducts C) (CP : BinProducts C) (KanExt : ∏ Z : category_Ptd C, GlobalRightKanExtensionExists C C (U Z) C) (Lam_Initial : Initial (FunctorAlg (Id_H C CC (LamSignature.Lam_Sig C terminal CC CP)))) (LamE_Initial : Initial (FunctorAlg (Id_H C CC (LamE_Sig C terminal CC CP)))), hss_category CC (LamE_Sig C terminal CC CP) ⟦ InitialObject (LamEHSS_Initial C terminal CC CP KanExt LamE_Initial), LamE_model_on_Lam C terminal CC CP KanExt Lam_Initial ⟧. Proof. apply FLATTEN. Defined. UniMath-20231010/UniMath/SubstitutionSystems/SumOfSignatures.v000066400000000000000000000114461451125700300242530ustar00rootroot00000000000000(** ********************************************************** Anders Mörtberg, 2016 ************************************************************) (** ********************************************************** Contents : - Definition of the sum of a family of signatures ([Sum_of_Signatures)] Adapted from the binary case ************************************************************) Require Import UniMath.Foundations.PartD. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.Core.Functors. Require Import UniMath.CategoryTheory.Core.NaturalTransformations. Local Open Scope cat. Require Import UniMath.CategoryTheory.FunctorCategory. Require Import UniMath.CategoryTheory.whiskering. Require Import UniMath.CategoryTheory.PrecategoryBinProduct. Require Import UniMath.CategoryTheory.PointedFunctors. Require Import UniMath.CategoryTheory.PointedFunctorsComposition. Require Import UniMath.SubstitutionSystems.Signatures. Require Import UniMath.CategoryTheory.limits.coproducts. Require Import UniMath.SubstitutionSystems.Notation. Local Open Scope subsys. Require Import UniMath.CategoryTheory.Chains.Chains. Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors. Require Import UniMath.CategoryTheory.limits.products. Section sum_of_signatures. Context (I : UU) (C D D' : category) (CD : Coproducts I D). Section construction. Local Notation "'CCD'" := (Coproducts_functor_precat I C D CD : Coproducts I [C, D]). Variables H1 : I -> functor [C, D'] [C, D]. Variable θ1 : ∏ i, θ_source (H1 i) ⟹ θ_target (H1 i). (** * Definition of the data of the sum of signatures *) Local Definition H : functor [C, D'] [C, D] := coproduct_of_functors _ _ _ CCD H1. Local Definition θ_ob_fun (X : [C, D']) (Z : category_Ptd C) (x : C) : D ⟦ coproduct_of_functors_ob _ _ _ CD (λ i, H1 i X) (pr1 Z x), coproduct_of_functors_ob _ _ _ CD (λ i, H1 i (functor_composite (pr1 Z) X)) x ⟧. Proof. apply CoproductOfArrows; intro i. exact (pr1 (θ1 i (X ⊗ Z)) x). Defined. Local Lemma is_nat_trans_θ_ob_fun (X : [C, D']) (Z : category_Ptd C) : is_nat_trans (functor_composite_data (pr1 Z) (coproduct_of_functors_data _ _ _ CD (λ i, H1 i X))) (coproduct_of_functors_data _ _ _ CD (λ i, H1 i (functor_composite (pr1 Z) X))) (θ_ob_fun X Z). Proof. intros x x' f. eapply pathscomp0; [ apply CoproductOfArrows_comp | ]. eapply pathscomp0; [ | eapply pathsinv0; apply CoproductOfArrows_comp]. apply maponpaths, funextsec; intro i. apply (nat_trans_ax (θ1 i (X ⊗ Z))). Qed. Definition θ_ob : ∏ XF, θ_source H XF --> θ_target H XF. Proof. intros [X Z]; exists (θ_ob_fun X Z); apply is_nat_trans_θ_ob_fun. Defined. Local Lemma is_nat_trans_θ_ob : is_nat_trans (θ_source H) (θ_target H) θ_ob. Proof. intros [X Z] [X' Z'] αβ. apply nat_trans_eq_alt; intro c. eapply pathscomp0; [ | eapply pathsinv0, CoproductOfArrows_comp]. eapply pathscomp0; [ apply cancel_postcomposition, CoproductOfArrows_comp |]. eapply pathscomp0; [ apply CoproductOfArrows_comp |]. apply maponpaths, funextsec; intro i. apply (nat_trans_eq_pointwise (nat_trans_ax (θ1 i) (X,,Z) (X',,Z') αβ) c). Qed. Local Definition θ : PrestrengthForSignature H := tpair _ _ is_nat_trans_θ_ob. (** * Proof of the strength laws of the sum of two signatures *) Variable S11' : ∏ i, θ_Strength1_int (θ1 i). Variable S12' : ∏ i, θ_Strength2_int (θ1 i). Lemma SumStrength1' : θ_Strength1_int θ. Proof. intro X. apply nat_trans_eq_alt; intro x; simpl. etrans; [apply CoproductOfArrows_comp|]. apply pathsinv0, Coproduct_endo_is_identity; intro i. etrans; [ apply (CoproductOfArrowsIn _ _ (CD (λ i, pr1 (pr1 (H1 i) X) x))) |]. etrans; [| apply id_left]. apply cancel_postcomposition, (nat_trans_eq_pointwise (S11' i X) x). Qed. Lemma SumStrength2' : θ_Strength2_int θ. Proof. intros X Z Z'. apply nat_trans_eq_alt; intro x; simpl; rewrite id_left. etrans; [apply CoproductOfArrows_comp|]. apply pathsinv0. etrans; [apply CoproductOfArrows_comp|]. apply pathsinv0, maponpaths, funextsec; intro i. assert (Ha_x := nat_trans_eq_pointwise (S12' i X Z Z') x); simpl in Ha_x. rewrite id_left in Ha_x; apply Ha_x. Qed. End construction. Definition Sum_of_Signatures (S : I -> Signature C D D') : Signature C D D'. Proof. use tpair. - apply H; intro i. apply (S i). - exists (θ (λ i, S i) (λ i, theta (S i))). split. + apply SumStrength1'; intro i; apply (Sig_strength_law1 (S i)). + apply SumStrength2'; intro i; apply (Sig_strength_law2 (S i)). Defined. Lemma is_omega_cocont_Sum_of_Signatures (S : I -> Signature C D D') (h : ∏ i, is_omega_cocont (S i)) : is_omega_cocont (Sum_of_Signatures S). Proof. apply is_omega_cocont_coproduct_of_functors; try assumption. Defined. End sum_of_signatures. UniMath-20231010/UniMath/SyntheticHomotopyTheory/000077500000000000000000000000001451125700300215605ustar00rootroot00000000000000UniMath-20231010/UniMath/SyntheticHomotopyTheory/.package/000077500000000000000000000000001451125700300232315ustar00rootroot00000000000000UniMath-20231010/UniMath/SyntheticHomotopyTheory/.package/files000066400000000000000000000000761451125700300242610ustar00rootroot00000000000000Coproduct.v Halfline.v AffineLine.v Circle.v Circle2.v Test.v UniMath-20231010/UniMath/SyntheticHomotopyTheory/AffineLine.v000066400000000000000000000613051451125700300237540ustar00rootroot00000000000000Local Unset Kernel Term Sharing. (** * Construction of affine lines We show that the propositional truncation of a ℤ-torsor, where ℤ is the additive group of the integers, behaves like an affine line. It's a contractible type, but maps from it to another type Y are determined by specifying where the points of T should go, and where the paths joining consecutive points of T should go. *) (** ** Preliminaries *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.NullHomotopies. Require Import UniMath.MoreFoundations.Univalence. Require Import UniMath.MoreFoundations.MoreEquivalences. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Nat. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.GroupAction UniMath.NumberSystems.Integers. Set Implicit Arguments. Unset Strict Implicit. Local Notation "g * x" := (ac_mult _ g x) : action_scope. Local Open Scope hz_scope. Local Open Scope transport. (** ** Recursion for ℤ *) Definition ℤRecursionData0 (P:ℤ->Type) (p0:P zero) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) := fun f:∏ i, P i => (f zero = p0) × (∏ n, f( toℤ (S n)) = IH n (f ( toℤ n))) × (∏ n, f(- toℤ (S n)) = IH' n (f (- toℤ n))). Definition ℤRecursionData (P:ℤ->Type) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) := fun f:∏ i, P i => (∏ n, f( toℤ (S n)) = IH n (f ( toℤ n))) × (∏ n, f(- toℤ (S n)) = IH' n (f (- toℤ n))). Lemma ℤRecursionUniq (P:ℤ->Type) (p0:P zero) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) : iscontr (total2 (ℤRecursionData0 p0 IH IH')). Proof. intros. unfold ℤRecursionData0. (* use hNatRecursion_weq *) apply (iscontrweqb (Y := ∑ f:∏ w, P (negpos w), (f (ii2 O) = p0) × (∏ n : nat, f (ii2 (S n)) = IH n (f (ii2 n))) × (f (ii1 O) = IH' O (f (ii2 O))) × (∏ n : nat, f (ii1 (S n)) = IH' (S n) (f (ii1 n))))). { apply (weqbandf (weqonsecbase _ negpos)). intro f. simple refine (make_weq _ (isweq_iso _ _ _ _)). { intros [h0 [hp hn]]. simple refine (_,,_,,_,,_). { exact h0. } { exact hp. } { exact (hn O). } { intro n. exact (hn (S n)). } } { intros [h0 [hp [h1' hn]]]. simple refine (_,,_,,_). { exact h0. } { exact hp. } { intros [|n']. { exact h1'. } { exact (hn n'). } } } { intros [h0 [hp hn]]. simpl. apply paths3. { reflexivity. } { reflexivity. } { apply funextsec; intros [|n']; reflexivity; reflexivity. } } { intros [h0 [h1' [hp hn]]]. reflexivity. } } intermediate_iscontr ( ∑ f : (∏ n, P (negpos (ii1 n))) × (∏ n, P (negpos (ii2 n))), (pr2 f O = p0) × (∏ n : nat, pr2 f (S n) = IH n (pr2 f n)) × (pr1 f O = IH' O (pr2 f O)) × (∏ n : nat, pr1 f (S n) = IH' (S n) (pr1 f n))). { apply (weqbandf (weqsecovercoprodtoprod (λ w, P (negpos w)))). intro f. apply idweq. } intermediate_iscontr ( ∑ f : (∏ n, P (negpos (ii2 n))) × (∏ n, P (negpos (ii1 n))), (pr1 f O = p0) × (∏ n : nat, pr1 f (S n) = IH n (pr1 f n)) × (pr2 f O = IH' O (pr1 f O)) × (∏ n : nat, pr2 f (S n) = IH' (S n) (pr2 f n))). { apply (weqbandf (weqdirprodcomm _ _)). intro f. apply idweq. } intermediate_iscontr ( ∑ (f2 : ∏ n : nat, P (negpos (ii2 n))) (f1 : ∏ n : nat, P (negpos (ii1 n))), (f2 O = p0) × (∏ n : nat, f2 (S n) = IH n (f2 n)) × (f1 O = IH' O (f2 O)) × (∏ n : nat, f1 (S n) = IH' (S n) (f1 n))). { apply weqtotal2asstor. } intermediate_iscontr ( ∑ f2 : ∏ n : nat, P (negpos (ii2 n)), (f2 O = p0) × ∑ f1 : ∏ n : nat, P (negpos (ii1 n)), (∏ n : nat, f2 (S n) = IH n (f2 n)) × (f1 O = IH' O (f2 O)) × (∏ n : nat, f1 (S n) = IH' (S n) (f1 n))). { apply weqfibtototal; intro f2. apply weq_total2_prod. } intermediate_iscontr ( ∑ f2 : ∏ n : nat, P (negpos (ii2 n)), (f2 O = p0) × (∏ n : nat, f2 (S n) = IH n (f2 n)) × ∑ f1 : ∏ n : nat, P (negpos (ii1 n)), (f1 O = IH' O (f2 O)) × (∏ n : nat, f1 (S n) = IH' (S n) (f1 n))). { apply weqfibtototal; intro f2. apply weqfibtototal; intro. apply weq_total2_prod. } intermediate_iscontr ( ∑ f2 : ∏ n : nat, P (negpos (ii2 n)), (f2 O = p0) × (∏ n : nat, f2 (S n) = IH n (f2 n))). { apply weqfibtototal; intro f2. apply weqfibtototal; intro h0. apply weqpr1; intro ih2. exact (Nat.Uniqueness.hNatRecursionUniq (λ n, P (negpos (ii1 n))) (IH' O (f2 O)) (λ n, IH' (S n))). } apply Nat.Uniqueness.hNatRecursionUniq. Defined. Lemma A (P:ℤ->Type) (p0:P zero) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) : weq (total2 (ℤRecursionData0 p0 IH IH')) (@hfiber (total2 (ℤRecursionData IH IH')) (P zero) (λ fh, pr1 fh zero) p0). Proof. intros. simple refine (make_weq _ (isweq_iso _ _ _ _)). { intros [f [h0 h]]. exact ((f,,h),,h0). } { intros [[f h] h0]. exact (f,,(h0,,h)). } { intros [f [h0 h]]. reflexivity. } { intros [[f h] h0]. reflexivity. } Defined. Lemma ℤRecursion_weq (P:ℤ->Type) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) : weq (total2 (ℤRecursionData IH IH')) (P 0). Proof. intros. exists (λ f, pr1 f zero). intro p0. apply (iscontrweqf (A _ _ _)). apply ℤRecursionUniq. Defined. Lemma ℤRecursion_weq_compute (P:ℤ->Type) (IH :∏ n, P( toℤ n) -> P( toℤ (S n))) (IH':∏ n, P(- toℤ n) -> P(- toℤ (S n))) (fh : total2 (ℤRecursionData IH IH')) : ℤRecursion_weq IH IH' fh = pr1 fh zero. Proof. reflexivity. (* don't change the proof *) Defined. (** ** Bidirectional recursion for ℤ *) Definition ℤBiRecursionData (P:ℤ->Type) (IH :∏ i, P(i) -> P(1+i)) := fun f:∏ i, P i => ∏ i, f(1+i)=IH i (f i). Definition ℤBiRecursion_weq (P:ℤ->Type) (IH :∏ i, weq (P i) (P(1+i))) : weq (total2 (ℤBiRecursionData IH)) (P 0). Proof. intros. assert (k : ∏ n, one + toℤ n = toℤ (S n)). { intro. rewrite nattohzandS. reflexivity. } set (l := λ n : nat, weq_transportf P (k n)). assert (k' : ∏ n, - toℤ n = one + (- toℤ (S n))). { intros. unfold one, toℤ. rewrite nattohzand1. rewrite nattohzandS. rewrite hzminusplus. rewrite <- (hzplusassoc one). rewrite (hzpluscomm one). rewrite hzlminus. rewrite hzplusl0. reflexivity. } set (l' := λ n, weq_transportf P (k' n)). set (ih := λ n, weqcomp (IH (toℤ n)) (l n)). set (ih':= λ n, (weqcomp (l' n) (invweq (IH (- toℤ (S n)))))). set (G := ℤRecursion_weq ih ih'). simple refine (weqcomp _ G). apply weqfibtototal. intro f. unfold ℤRecursionData, ℤBiRecursionData. simple refine (weqcomp (weqonsecbase _ negpos) _). simple refine (weqcomp (weqsecovercoprodtoprod _) _). simple refine (weqcomp (weqdirprodcomm _ _) _). apply weqdirprodf. { apply weqonsecfibers; intro n. simple refine (weqonpaths2 _ _ _). { change (negpos (ii2 n)) with (toℤ n). exact (l n). } { unfold l. apply weq_transportf_comp. } { reflexivity. } } { apply weqonsecfibers; intro n. simpl. simple refine (weqcomp (make_weq _ (isweqpathsinv0 _ _)) _). simple refine (weqonpaths2 _ _ _). { apply invweq. apply IH. } { simpl. rewrite homotinvweqweq. reflexivity. } { simpl. change (natnattohz 0 (S n)) with (- toℤ (S n)). unfold l'. rewrite weq_transportf_comp. reflexivity. } } Defined. Definition ℤBiRecursion_compute (P:ℤ->Type) (IH :∏ i, weq (P i) (P(1+i))) (fh : total2 (ℤBiRecursionData IH)) : ℤBiRecursion_weq IH fh = pr1 fh 0. Proof. reflexivity. (* don't change the proof *) Defined. Definition ℤBiRecursion_inv_compute (P : ℤ → Type) (f : ∏ z : ℤ, P z ≃ P (1 + z)) (p : P 0) : pr1 (invmap (ℤBiRecursion_weq f) p) 0 = p := ! ℤBiRecursion_compute (invmap (ℤBiRecursion_weq f) p) @ homotweqinvweq (ℤBiRecursion_weq f) p. Definition ℤBiRecursion_transition_inv (P : ℤ → Type) (f : ∏ z : ℤ, P z ≃ P (1 + z)) (p : P 0) (z : ℤ) : pr1 (invmap (ℤBiRecursion_weq f) p) (1 + z) = f z (pr1 (invmap (ℤBiRecursion_weq f) p) z) := pr2 (invmap (ℤBiRecursion_weq f) p) z. Definition ℤBiRecursion_transition_inv_reversed (P : ℤ → Type) (f : ∏ z : ℤ, P z ≃ P (1 + z)) (p : P 0) (z : ℤ) : pr1 (invmap (ℤBiRecursion_weq f) p) z = invmap (f z) (pr1 (invmap (ℤBiRecursion_weq f) p) (1 + z)) := !homotinvweqweq _ _ @ maponpaths (invmap (f z)) (! ℤBiRecursion_transition_inv f p z). Notation "n + x" := (ac_mult _ n x) : action_scope. Notation "n - m" := (quotient _ n m) : action_scope. Local Open Scope action_scope. (** ** Bidirectional recursion for ℤ-torsors *) Definition GuidedSection {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) := fun f:∏ t, P t => ∏ t, f (one + t) = IH t (f t). Definition ℤTorsorRecursion_weq {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) (t0:T) : weq (total2 (GuidedSection IH)) (P t0). Proof. intros. exists (λ fh, pr1 fh t0). intro q. set (w := triviality_isomorphism T t0). assert (k0 : ∏ i, one + w i = w (1+i)%hz). { intros. simpl. unfold right_mult, ac_mult. unfold act_mult. rewrite act_assoc. reflexivity. } set (l0 := (λ i, eqweqmap (maponpaths P (k0 i))) : ∏ i, weq (P(one + w i)) (P(w(1+i)%hz))). assert( e : right_mult t0 zero = t0 ). { apply act_unit. } set (H := λ f, ∏ t : T, f (one + t) = (IH t) (f t)). set ( IH' := (λ i, weqcomp (IH (w i)) (l0 i)) : ∏ i:ℤ, weq (P (w i)) (P (w(1+i)%hz))). set (J := λ f, ∏ i : ℤ, f (1 + i)%hz = (IH' i) (f i)). simple refine (iscontrweqb (@weq_over_sections ℤ T w 0 t0 e P q (e#'q) _ H J _) _). { apply transportfbinv. } { intro. apply invweq. unfold H,J,maponsec1. simple refine (weqonsec _ _ w _). intro i. simple refine (weqonpaths2 _ _ _). { exact (invweq (l0 i)). } { unfold l0. apply eqweqmap_ap'. } { unfold IH'. unfold weqcomp; simpl. rewrite (homotinvweqweq (l0 i)). reflexivity. } } exact (pr2 (ℤBiRecursion_weq IH') (e #' q)). Defined. Definition ℤTorsorRecursion_compute {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) t h : ℤTorsorRecursion_weq IH t h = pr1 h t. Proof. reflexivity. (* don't change the proof *) Defined. Definition ℤTorsorRecursion_inv_compute {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) (t0:T) (h0:P t0) : pr1 (invmap (ℤTorsorRecursion_weq IH t0) h0) t0 = h0. Proof. intros. exact (! ℤTorsorRecursion_compute t0 (invmap (ℤTorsorRecursion_weq IH t0) h0) @ homotweqinvweq (ℤTorsorRecursion_weq IH t0) h0). Defined. Definition ℤTorsorRecursion_transition {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) (t:T) (h:total2 (GuidedSection IH)) : ℤTorsorRecursion_weq IH (one+t) h = IH t (ℤTorsorRecursion_weq IH t h). Proof. intros. rewrite 2!ℤTorsorRecursion_compute. exact (pr2 h t). Defined. Definition ℤTorsorRecursion_transition_inv {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) (t:T) : ∏ h0, invmap (ℤTorsorRecursion_weq IH t) h0 = invmap (ℤTorsorRecursion_weq IH (one+t)) (IH t h0). Proof. intros. assert (a := ℤTorsorRecursion_transition t (invmap (ℤTorsorRecursion_weq IH t) h0)). rewrite homotweqinvweq in a. rewrite <- a. rewrite homotinvweqweq. reflexivity. Defined. Definition ℤTorsorRecursion {T:Torsor ℤ} (P:T->Type) (IH:∏ t, weq (P t) (P (one + t))) (t t':T) : (P t) ≃ (P t'). Proof. intros. exact (weqcomp (invweq (ℤTorsorRecursion_weq IH t)) (ℤTorsorRecursion_weq IH t')). Defined. (** ** Guided null-homotopies from ℤ-torsors Let f be a map from a ℤ-torsor T to a type Y, and let s be a collection of target paths, connecting the images under f of consecutive points of T. A null-homotopy for f is a point y of Y, together with paths from y to each point in the image of f. We say that it is "guided" by s if all the consecutive triangles commute. The main fact is that the type of guided null-homotopies for f is contractible. *) Definition target_paths {Y} {T:Torsor ℤ} (f:T->Y) := ∏ t, f t=f(one + t). Definition GHomotopy {Y} {T:Torsor ℤ} (f:T->Y) (s:target_paths f) := fun y:Y => ∑ h:nullHomotopyFrom f y, ∏ n, h(one + n) = h n @ s n. Definition GuidedHomotopy {Y} {T:Torsor ℤ} (f:T->Y) (s:target_paths f) := total2 (GHomotopy s). Definition GH_to_cone {Y} {T:Torsor ℤ} {f:T->Y} {s:target_paths f} (t:T) : GuidedHomotopy s -> coconustot Y (f t). Proof. intros [y hp]. exact (y,,pr1 hp t). Defined. Definition GH_point {Y} {T:Torsor ℤ} {f:T->Y} {s:target_paths f} (yhp : GuidedHomotopy s) := pr1 yhp : Y. Definition GH_homotopy {Y} {T:Torsor ℤ} {f:T->Y} {s:target_paths f} (yhp : GuidedHomotopy s) := pr1 (pr2 yhp) : nullHomotopyFrom f (GH_point yhp). Definition GH_equations {Y} {T:Torsor ℤ} (f:T->Y) (s:target_paths f) (yhp : GuidedHomotopy s) := pr2 (pr2 yhp) : let h := GH_homotopy yhp in ∏ n, h(one + n) = h n @ s n. Theorem iscontrGuidedHomotopy {Y} (T:Torsor ℤ) (f:T->Y) (s:target_paths f) : iscontr (GuidedHomotopy s). Proof. intros. apply (squash_to_prop (torsor_nonempty T)). { apply isapropiscontr. } intro t0. (* A better proof would construct the center explicitly now using [makeGuidedHomotopy] below. Or we could replace this theorem by a corollary of it, with the new center. *) apply ( iscontrweqb (Y := ∑ y:Y, y = f t0)). { apply weqfibtototal; intro y. exact (ℤTorsorRecursion_weq (λ t, weq_pathscomp0r _ _) t0). } apply iscontrcoconustot. Defined. Corollary proofirrGuidedHomotopy {Y} (T:Torsor ℤ) (f:T->Y) (s:target_paths f) : ∏ v w : GuidedHomotopy s, v=w. Proof. (* later give a more direct proof *) intros. apply proofirrelevancecontr. apply iscontrGuidedHomotopy. Defined. Definition iscontrGuidedHomotopy_comp_1 {Y} : let T := trivialTorsor ℤ in let t0 := 0 : T in ∏ (f:T->Y) (s:target_paths f), GH_point (iscontrpr1 (iscontrGuidedHomotopy s)) = f t0. Proof. reflexivity. (* don't change the proof *) Defined. Definition iscontrGuidedHomotopy_comp_2 {Y} : let T := trivialTorsor ℤ in let t0 := 0 : T in ∏ (f:T->Y) (s:target_paths f), (GH_homotopy (iscontrpr1 (iscontrGuidedHomotopy s)) t0) = (idpath (f t0)). Proof. intros. assert (a2 := fiber_paths (iscontrweqb_compute (weqfibtototal (GHomotopy s) (λ y : Y, y = f t0) (λ y : Y, ℤTorsorRecursion_weq (λ t : T, weq_pathscomp0r y (s t)) t0)) (iscontrcoconustot Y (f t0))) : @paths (GHomotopy s (f t0)) _ _). assert (Q1 := eqtohomot (maponpaths pr1 ((idpath _ : (pr2 (iscontrpr1 (iscontrweqb (weqfibtototal (GHomotopy s) (λ y : Y, y = f t0) (λ y : Y, ℤTorsorRecursion_weq (λ t : T, weq_pathscomp0r y (s t)) t0)) (iscontrcoconustot Y (f t0))))) = (path_start a2)) @ a2)) t0). assert (Q2 := eqtohomot (maponpaths pr1 (compute_pr2_invmap_weqfibtototal (λ y : Y, ℤTorsorRecursion_weq (λ t : T, weq_pathscomp0r y (s t)) t0) (f t0,, idpath (f t0)))) t0). assert (Q3 := ℤTorsorRecursion_inv_compute (λ t : T, weq_pathscomp0r (pr1 (invmap (weqfibtototal (λ y : Y, ∑ y0, GuidedSection (λ t1 : T, weq_pathscomp0r y (s t1)) y0) (λ y : Y, (λ t1 : T, y = f t1) t0) (λ y : Y, ℤTorsorRecursion_weq (λ t1 : T, weq_pathscomp0r y (s t1)) t0)) (f t0,, idpath (f t0)))) (s t)) (pr2 (f t0,, idpath (f t0)))). (* this proof used to work quickly before turning on primitive projections, so maybe it's a Coq bug *) (* exact (Q1 @ Q2 @ Q3). *) (* Defined. *) Abort. (* Definition iscontrGuidedHomotopy_comp_3 {Y} : *) (* let T := trivialTorsor ℤ in *) (* let t0 := 0 : T in *) (* ∏ (f:T->Y) (s:target_paths f), *) (* GH_to_cone t0 (iscontrpr1 (iscontrGuidedHomotopy T f s)) = f t0,, idpath (f t0). *) (* Proof. intros. *) (* admit. *) (* Defined. *) Definition makeGuidedHomotopy {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0:y=f t0) : GuidedHomotopy s. Proof. intros. exact (y ,, invweq (ℤTorsorRecursion_weq (λ t, weq_pathscomp0r y (s t)) t0) h0). Defined. Definition makeGuidedHomotopy1 {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) (t0:T) : GuidedHomotopy s. Proof. intros. exact (makeGuidedHomotopy s (idpath (f t0))). Defined. Definition makeGuidedHomotopy_localPath {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0 h0':y=f t0) (q:h0=h0') : makeGuidedHomotopy s h0 = makeGuidedHomotopy s h0'. Proof. intros. destruct q. reflexivity. Defined. Definition makeGuidedHomotopy_localPath_comp {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0 h0':y=f t0) (q:h0=h0') : maponpaths pr1 (makeGuidedHomotopy_localPath s q) = idpath y. Proof. intros. destruct q. reflexivity. Defined. Definition makeGuidedHomotopy_verticalPath {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0:y=f t0) {y':Y} (p:y' = y) : makeGuidedHomotopy s (p@h0) = makeGuidedHomotopy s h0. Proof. intros. apply (two_arg_paths_f p). destruct p. reflexivity. Defined. Definition makeGuidedHomotopy_verticalPath_comp {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0:y=f t0) {y':Y} (p:y' = y) : maponpaths pr1 (makeGuidedHomotopy_verticalPath s h0 p) = p. Proof. intros. apply total2_paths2_comp1. Defined. Definition makeGuidedHomotopy_transPath {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0:y=f t0) : makeGuidedHomotopy s h0 = makeGuidedHomotopy s (h0 @ s t0). Proof. intros. apply (maponpaths (tpair _ _)). exact (ℤTorsorRecursion_transition_inv (λ t, weq_pathscomp0r y (s t)) _). Defined. Definition makeGuidedHomotopy_transPath_comp {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) {y:Y} t0 (h0:y=f t0) : maponpaths pr1 (makeGuidedHomotopy_transPath s h0) = idpath y. Proof. intros. unfold makeGuidedHomotopy_transPath. exact (pair_path_in2_comp1 _ (ℤTorsorRecursion_transition_inv (λ t, weq_pathscomp0r y (s t)) _)). Defined. Definition makeGuidedHomotopy_diagonalPath {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) (t0:T) : makeGuidedHomotopy1 s t0 = makeGuidedHomotopy1 s (one + t0). Proof. intros. assert (b := makeGuidedHomotopy_transPath s (idpath(f t0))); simpl in b. assert (c := makeGuidedHomotopy_localPath s (! pathscomp0rid (s t0))). assert (a := makeGuidedHomotopy_verticalPath s (idpath(f(one + t0))) (s t0)) . exact (b @ c @ a). Defined. Definition makeGuidedHomotopy_diagonalPath_comp {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) (t0:T) : maponpaths pr1 (makeGuidedHomotopy_diagonalPath s t0) = s t0. Proof. intros. unfold makeGuidedHomotopy_diagonalPath. simple refine (maponpaths_naturality (makeGuidedHomotopy_transPath_comp _ _) _). simple refine (maponpaths_naturality (makeGuidedHomotopy_localPath_comp _ _) _). exact (makeGuidedHomotopy_verticalPath_comp _ _ _). Defined. Definition map {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) : ∥ T ∥ -> GuidedHomotopy s. Proof. intros t'. (* try to use transport as in Halfline.map *) apply (squash_to_prop t'). { apply isapropifcontr. apply iscontrGuidedHomotopy. } intro t; clear t'. exact (makeGuidedHomotopy1 s t). Defined. Definition map_path {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) : ∏ t, map s (squash_element t) = map s (squash_element (one + t)). Proof. intros. exact (makeGuidedHomotopy_diagonalPath s t). Defined. Definition map_path_check {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) : ∏ t, ∏ p : map s (squash_element t) = map s (squash_element (one + t)), maponpaths pr1 p = s t. Proof. intros. set (q := map_path s t). assert (k : q=p). { apply (hlevelntosn 1). apply (hlevelntosn 0). apply iscontrGuidedHomotopy. } destruct k. exact (makeGuidedHomotopy_diagonalPath_comp s t). Defined. (** ** From each torsor we get a guided homotopy *) Definition makeGuidedHomotopy2 (T:Torsor ℤ) {Y} (f:T->Y) (s:target_paths f) : GuidedHomotopy s. Proof. intros. exact (map s (torsor_nonempty T)). Defined. (** ** The construction of the affine line *) Definition affine_line (T:Torsor ℤ) := ∥ T ∥. Definition affine_line_point (T:Torsor ℤ) : affine_line T. Proof. intros. exact (torsor_nonempty T). Defined. Lemma iscontr_affine_line (T:Torsor ℤ) : iscontr (affine_line T). Proof. intros. apply iscontraprop1. { apply propproperty. } exact (torsor_nonempty T). Defined. Lemma affine_line_path {T:Torsor ℤ} (t u:affine_line T) : t = u. Proof. intros. apply proofirrelevancecontr, iscontr_affine_line. Defined. Definition affine_line_map {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) : affine_line T -> Y. Proof. intros t'. exact (pr1 (map s t')). Defined. Definition check_values {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) t : affine_line_map s (squash_element t) = f t. Proof. reflexivity. (* don't change the proof *) Defined. Definition check_paths {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) (t:T) : maponpaths (affine_line_map s) (squash_path t (one + t)) = s t. Proof. intros. refine (_ @ map_path_check (maponpaths (map s) (squash_path t (one + t)))). apply pathsinv0. apply maponpathscomp. Defined. Definition check_paths_any {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) (t:T) (p : squash_element t = squash_element (one + t)) : maponpaths (affine_line_map s) p = s t. Proof. intros. set (p' := squash_path t (one + t)). assert (e : p' = p). { apply (hlevelntosn 1). apply propproperty. } destruct e. apply check_paths. Defined. Definition add_one {T:Torsor ℤ} : affine_line T -> affine_line T. Proof. exact (squash_fun (λ t, one + t)). Defined. (** ** The image of the mere point in an affine line A torsor is nonempty, so it merely has a point, as does the corresponding affine line. Here we name its image in Y. *) Definition affine_line_value {T:Torsor ℤ} {Y} (f:T->Y) (s:target_paths f) : Y. Proof. exact (affine_line_map s (affine_line_point (T:=T))). Defined. (* Local Variables: compile-command: "make -C ../.. UniMath/SyntheticHomotopyTheory/AffineLine.vo" End: *) UniMath-20231010/UniMath/SyntheticHomotopyTheory/Circle.v000066400000000000000000000303131451125700300231500ustar00rootroot00000000000000 Unset Kernel Term Sharing. (** * Construction of the circle *) (** We will show that [B ℤ] has the universal property of the circle. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.NumberSystems.Integers UniMath.SyntheticHomotopyTheory.AffineLine UniMath.Algebra.GroupAction UniMath.MoreFoundations.MoreEquivalences. Declare Scope paths_scope. Delimit Scope paths_scope with paths. Local Open Scope paths_scope. Local Open Scope action_scope. Local Notation "g + x" := (ac_mult _ g x) : action_scope. Definition circle := B ℤ. Theorem loops_circle : ℤ ≃ Ω circle. Proof. apply loopsBG. Defined. Local Open Scope hz. Definition circle_loop := ! loops_circle 1 : Ω circle. Lemma loop_compute t : castTorsor (!circle_loop) t = one + t. Proof. intros. unfold circle_loop. rewrite pathsinv0inv0. exact (loopsBG_comp_2 _ one t @ commax _ t one). Defined. (** ** The total space of guided homotopies over BZ *) Definition ZGuidedHomotopy {Y} {y:Y} (l:y = y) (T:Torsor ℤ) := GuidedHomotopy (confun T l). Definition GH {Y} {y:Y} (l:y = y) := ∑ T:Torsor ℤ, ZGuidedHomotopy l T. Definition make_GH {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (g:ZGuidedHomotopy l T) := T,,g : GH l. Definition pr1_GH {Y} {y:Y} {l:y = y} := pr1 : GH l -> Torsor ℤ. Definition pr2_GH {Y} {y:Y} (l:y = y) (u:GH l) := pr2 u : ZGuidedHomotopy l (pr1_GH u). Definition GH_path3 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y} {g g':GHomotopy (confun T l) y'} (u:g = g') : make_GH l T (y',, g) = make_GH l T (y',,g'). Proof. intros. destruct u. reflexivity. Defined. Definition pr12_GH {Y} {y:Y} {l:y = y} (u:GH l) := pr1 (pr2_GH l u) : Y. Definition pr22_GH {Y} {y:Y} {l:y = y} (u:GH l) := pr2 (pr2_GH l u) : GHomotopy (confun (pr1_GH u) l) (pr12_GH u). Definition GH_path3_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y} {g g':GHomotopy (confun T l) y'} (u:g = g') : maponpaths pr1_GH (GH_path3 l u) = idpath T. Proof. intros. destruct u. reflexivity. Defined. Definition GH_path3_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y} {g g':GHomotopy (confun T l) y'} (u:g = g') : maponpaths pr12_GH (GH_path3 l u) = idpath y'. Proof. intros. destruct u. reflexivity. Defined. Local Definition irr {Y} {y:Y} (l:y = y) (T:Torsor ℤ) : ∏ (v w : GuidedHomotopy (confun T l)), v = w := (λ v w, proofirrGuidedHomotopy v w). Local Definition sec {Y} {y:Y} (l:y = y) (T:Torsor ℤ) := makeGuidedHomotopy2 (confun T l). Definition pr1_GH_weq {Y} {y:Y} {l:y = y} : (GH l) ≃ (Torsor ℤ) := weqpr1_irr_sec (irr l) (sec l). Definition homotinvweqweq_GH_comp {Y} {y:Y} {l:y = y} (T:Torsor ℤ) (gh:ZGuidedHomotopy l T) : @paths (@paths (GH l) (invweq (@pr1_GH_weq _ _ l) T) (T,,gh)) (homotinvweqweq' (irr l) (sec l) (T,,gh)) (@pair_path_in2 _ (ZGuidedHomotopy l) _ (sec l T) gh (irr l T (sec l T) gh)). Proof. reflexivity. (* don't change the proof *) Defined. Definition makeGH {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (t:T) {y':Y} (h:y' = y) : GH l := make_GH l T (makeGuidedHomotopy (t0:=t) _ h). Definition makeGH1 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (t:T) : GH l := makeGH l T t (idpath y). Definition pr12_pair_path_in2 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) {gh gh':ZGuidedHomotopy l T} (w : gh = gh') : maponpaths pr12_GH (pair_path_in2 (ZGuidedHomotopy l) w) = maponpaths pr1 w. Proof. intros. destruct w. reflexivity. Defined. Definition pr1_GH_weq_compute {Y} {y:Y} (l:y = y) : let T0 := trivialTorsor ℤ in let t0 := 0 : T0 in @paths (y = y) (maponpaths pr12_GH (homotinvweqweq' (irr l) (sec l) (makeGH1 l T0 t0))) (idpath y). Proof. intros. unfold makeGH1,makeGH,make_GH. refine (maponpaths (maponpaths pr12_GH) (homotinvweqweq_GH_comp T0 (makeGuidedHomotopy (confun T0 l) (idpath y))) @ _). refine (pr12_pair_path_in2 l T0 (irr l T0 (sec l T0) (makeGuidedHomotopy (confun T0 l) (idpath y))) @ _). unfold sec. change (makeGuidedHomotopy (confun T0 l) (idpath y)) with (sec l T0). change (makeGuidedHomotopy2 (confun T0 l)) with (sec l T0). change (idpath y) with (maponpaths pr1 (idpath (sec l T0))). apply (maponpaths (maponpaths pr1)). apply irrel_paths. apply (irr l). Defined. (** ** Various paths in GH *) Definition makeGH_localPath {Y} {y:Y} (l:y=y) (T:Torsor ℤ) {t t':T} (r:t = t') {y'} {h h':y' = y} (q:h = h') : makeGH l T t h = makeGH l T t' h'. Proof. intros. destruct q, r. reflexivity. (* compare with [makeGuidedHomotopy_localPath] *) Defined. Definition makeGH_localPath_comp1 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) {t t':T} (r:t = t') {y'} {h h':y' = y} (q:h = h') : maponpaths pr1_GH (makeGH_localPath l T r q) = idpath T. Proof. intros. destruct q,r. reflexivity. Defined. Definition makeGH_localPath_comp2 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) {t t':T} (r:t = t') {y'} {h h':y' = y} (q:h = h') : maponpaths pr12_GH (makeGH_localPath l T r q) = idpath y'. Proof. intros. destruct q,r. reflexivity. Defined. Definition makeGH_verticalPath {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y' y''} (h:y' = y) (p:y'' = y') : makeGH l T t (p@h) = makeGH l T t h. Proof. intros. destruct p. reflexivity. Defined. (* could also use [makeGuidedHomotopy_verticalPath] *) Definition makeGH_verticalPath_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y' y''} (h:y' = y) (p:y'' = y') : maponpaths pr1_GH (makeGH_verticalPath l t h p) = idpath T. Proof. intros. destruct p. reflexivity. Defined. Definition makeGH_verticalPath_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y' y''} (h:y' = y) (p:y'' = y') : maponpaths pr12_GH (makeGH_verticalPath l t h p) = p. Proof. intros. destruct p. reflexivity. Defined. Definition makeGH_horizontalPath {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T') (t:T) {y'} (h:y' = y) : makeGH l T t h = makeGH l T' (castTorsor q t) h. Proof. intros. destruct q. reflexivity. (* compare with [makeGuidedHomotopy_horizontalPath] *) Defined. Definition makeGH_horizontalPath_comp1 {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T') (t:T) {y'} (h:y' = y) : maponpaths pr1_GH (makeGH_horizontalPath l q t h) = q. Proof. intros. destruct q. reflexivity. Defined. Definition makeGH_horizontalPath_comp2 {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T') (t:T) {y'} (h:y' = y) : maponpaths pr12_GH (makeGH_horizontalPath l q t h) = idpath y'. Proof. intros. destruct q. reflexivity. Defined. Local Open Scope action_scope. Definition makeGH_transPath {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y) : makeGH l T t h = makeGH l T (one+t) (h@l). Proof. intros. apply GH_path3. (* copied from the proof of [makeGuidedHomotopy_transPath] *) exact (ℤTorsorRecursion_transition_inv (λ _, weq_pathscomp0r _ l) (t:=t) h). Defined. Definition makeGH_transPath_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y) : maponpaths pr1_GH (makeGH_transPath l t h) = idpath T. Proof. intros. exact (GH_path3_comp1 l _). Defined. Definition makeGH_transPath_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y) : maponpaths pr12_GH (makeGH_transPath l t h) = idpath y'. Proof. intros. exact (GH_path3_comp2 l _). Defined. Definition makeGH_diagonalLoop {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) (q:T = T) (r:castTorsor q t = one + t) : makeGH1 l T t = makeGH1 l T t. Proof. intros. assert (p2 := makeGH_transPath l t (idpath y)). assert (p0:= makeGH_localPath l T (!r) (idpath l)); clear r. assert (ph := makeGH_horizontalPath l q t l). assert (p1 := makeGH_localPath l T (idpath t) (! pathscomp0rid l)). assert (pv := makeGH_verticalPath l t (idpath y) l). assert (p := p2 @ p0 @ !ph @ p1 @ pv); clear p2 p0 ph p1 pv. exact p. Defined. Definition makeGH_diagonalLoop_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) (q:T = T) (r:castTorsor q t = one + t) : maponpaths pr1_GH (makeGH_diagonalLoop l t q r) = !q. Proof. intros. unfold makeGH_diagonalLoop. refine (maponpaths_naturality (makeGH_transPath_comp1 _ _ _) _). refine (maponpaths_naturality (makeGH_localPath_comp1 _ _ _ _) _). rewrite <- (pathscomp0rid (paths_rect _ _ (λ b _, b = T) _ _ q)). (* Used to be "rewrite <- (pathscomp0rid (! q))", which was more perspicuous. *) refine (maponpaths_naturality' (makeGH_horizontalPath_comp1 _ _ _ _) _). rewrite <- (pathscomp0rid (idpath T)). refine (maponpaths_naturality (makeGH_localPath_comp1 _ _ _ _) _). exact (makeGH_verticalPath_comp1 _ _ _ _). Defined. Definition makeGH_diagonalLoop_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) (q:T = T) (r:castTorsor q t = one + t) : maponpaths pr12_GH (makeGH_diagonalLoop l t q r) = l. Proof. intros. unfold makeGH_diagonalLoop. refine (maponpaths_naturality (makeGH_transPath_comp2 _ _ _) _). refine (maponpaths_naturality (makeGH_localPath_comp2 _ _ _ _) _). refine (maponpaths_naturality' (makeGH_horizontalPath_comp2 _ _ _ _) _). refine (maponpaths_naturality (makeGH_localPath_comp2 _ _ _ _) _). exact (makeGH_verticalPath_comp2 _ _ _ _). Defined. (** ** The universal property of the circle *) (** *** The recursion principle (non-dependent functions) *) Definition circle_map {Y} {y:Y} (l:y = y) : circle -> Y. Proof. exact (funcomp (invmap (@pr1_GH_weq _ _ l)) pr12_GH). Defined. Definition circle_map_check_values {Y} {y:Y} (l:y = y) : circle_map l (basepoint circle) = y. Proof. reflexivity. (* don't change the proof *) (* This proof works because the trivial torsor has an actual point that provides the accompanying proof of nonemptiness. *) Defined. Definition circle_map_check_paths {Y} {y:Y} (l:y = y) : maponpaths (circle_map l) circle_loop = l. Proof. intros. assert (p := pr1_GH_weq_compute l). refine (_ @ loop_correspondence' (irr l) (sec l) pr12_GH (makeGH_diagonalLoop_comp1 l _ _ (loop_compute 0)) (makeGH_diagonalLoop_comp2 l _ _ (loop_compute 0)) @ _). { intermediate_path (maponpaths (circle_map l) circle_loop @ idpath y). { apply pathsinv0. apply pathscomp0rid. } { apply pathsinv0. rewrite pathsinv0inv0. exact (maponpaths (λ r, maponpaths (circle_map l) circle_loop @ r) p). } } { exact (maponpaths (λ r, r @ l) p). } Defined. Definition circle_map_conjugation {Y} {y:Y} (l:y = y) {y':Y} (e:y=y') : circle_map l = circle_map (!e @ l @ e). Proof. induction e. change (circle_map l = circle_map (l @ idpath y)). rewrite pathscomp0rid. reflexivity. Defined. (** *** The induction principle (dependent functions) *) Local Open Scope transport. Definition CircleInduction : Type := ∏ (Y:circle->Type) (y:Y(basepoint circle)) (l:circle_loop#y = y), ∏ c:circle, Y c. Definition circle_map' : CircleInduction. Proof. (** (not proved yet) *) Abort. (* One approach to the theorem above would be through the results of the paper "Higher Inductive Types as Homotopy-Initial Algebras", by Kristina Sojakova, http://arxiv.org/abs/1402.0761 *) Section A. Context (circle_map': CircleInduction). Lemma circle_map_check_paths' {Y} (f:circle->Y) : circle_map (maponpaths f circle_loop) = f . Proof. intros. apply funextsec. simple refine (circle_map' _ _ _). { reflexivity. } { set (y := f (basepoint circle)). set (l := maponpaths f circle_loop). set (P := λ T : underlyingType circle, circle_map _ T = f T). apply transport_fun_path. rewrite pathscomp0rid. change (idpath y @ maponpaths f circle_loop) with (maponpaths f circle_loop). exact (! circle_map_check_paths l). } Defined. Lemma circle_map_uniqueness {Y} (f g:circle->Y) (e : f (basepoint circle) = g (basepoint circle)) (q : maponpaths f circle_loop = e @ maponpaths g circle_loop @ !e): f = g. Proof. Abort. Definition circle_map'' : CircleInduction. Proof. (** (not proved yet) *) Abort. End A. (* Local Variables: compile-command: "make -C ../.. UniMath/SyntheticHomotopyTheory/Circle.vo" End: *) UniMath-20231010/UniMath/SyntheticHomotopyTheory/Circle2.v000066400000000000000000000426311451125700300232400ustar00rootroot00000000000000(** In this file we formalize the approach of Marc Bezem and Ulrik Buchholtz for proving that the type of Z-torsors has the induction principle that the circle should have. In my older approach, (see the file Circle.v), I managed to show only the recursion principle for the circle (where the family of types is constant), and the computations were complicated and onerous. Their approach follows the same basic idea, goes further, and is simpler. It is described in the file https://github.com/UniMath/SymmetryBook/blob/master/ZTors.tex, commit 1ba615fa7625516ad79fe3ad9ef68e1fc001d485. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. Require Import UniMath.MoreFoundations.Propositions. Require Import UniMath.MoreFoundations.Equivalences. Require Import UniMath.MoreFoundations.PathsOver. Import PathsOverNotations. Require Import UniMath.Algebra.Monoids. Import AddNotation. Require Import UniMath.SyntheticHomotopyTheory.AffineLine. Require Import UniMath.NumberSystems.Integers. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.GroupAction. Require Import UniMath.Algebra.Groups. Local Set Implicit Arguments. Local Unset Strict Implicit. Declare Scope circle. Delimit Scope circle with circle. Local Open Scope hz. Local Open Scope addoperation. Local Open Scope abgr. Local Open Scope action_scope. Local Open Scope pathsover. Local Open Scope circle. Local Notation "0" := (toℤ 0). Local Notation "1" := (toℤ 1). Local Definition elem (G:gr) (X:Torsor G) : Type := X. Arguments elem {_} _. Local Notation "ℤ¹" := (trivialTorsor ℤ) : circle. (** Statements of circle recursion and induction *) (* Circle "recursion" is the non-dependent induction principle *) Definition CircleRecursion (circle : Type) (pt : circle) (loop : pt = pt) := ∏ (X:Type) (x:X) (p:x=x), ∑ (f:circle -> X) (r : f pt = x), PathOver (Y := λ t:X, t = t) r (maponpaths f loop) p. Arguments CircleRecursion : clear implicits. Definition CircleInduction (circle : Type) (pt : circle) (loop : pt = pt) := ∏ (X:circle->Type) (x:X pt) (p:PathOver loop x x), ∑ (f:∏ t:circle, X t) (r : f pt = x), PathOver (Y := λ t:X pt, PathOver loop t t) r (apd f loop) p. Arguments CircleInduction : clear implicits. (* the alternative definitions of recursion and induction used earlier: *) Definition CircleRecursion' (circle : Type) (pt : circle) (loop : pt = pt) := ∏ (X:Type) (x:X) (p:x=x), ∑ (f:circle -> X) (r : x = f pt), r @ maponpaths f loop = p @ r. Arguments CircleRecursion' : clear implicits. Definition CircleInduction' (circle : Type) (pt : circle) (loop : pt = pt) := ∏ (X:circle->Type) (x:X pt) (p:PathOver loop x x), ∑ (f:∏ t:circle, X t) (r : x = f pt), r ⟤ apd f loop = p ⟥ r. Arguments CircleInduction' : clear implicits. (* the equivalence of the new definitions with the old *) Lemma CircleRecursionEquiv (circle : Type) (pt : circle) (loop : pt = pt) : CircleRecursion circle pt loop ≃ CircleRecursion' circle pt loop. Proof. unfold CircleRecursion', CircleRecursion. apply weqonsecfibers; intro X. apply weqonsecfibers; intro x. apply weqonsecfibers; intro p. apply weqfibtototal; intro f. intermediate_weq (∑ r : f pt = x, maponpaths f loop @ r = r @ p). - apply weqfibtototal; intro r. apply eqweqmap. induction r. cbn. apply (maponpaths (λ k, k=p)). rewrite pathscomp0rid. reflexivity. - intermediate_weq (∑ r : f pt = x, (!r) @ maponpaths f loop = p @ (!r)). + apply weqfibtototal; intro r. induction r. cbn. rewrite 2 pathscomp0rid. apply idweq. + exact (weqfp (make_weq _ (isweqpathsinv0 (f pt) x)) _). Defined. Lemma CircleInductionEquiv (circle : Type) (pt : circle) (loop : pt = pt) : CircleInduction circle pt loop ≃ CircleInduction' circle pt loop. Proof. unfold CircleInduction', CircleInduction. apply weqonsecfibers; intro X. apply weqonsecfibers; intro x. apply weqonsecfibers; intro p. apply weqfibtototal; intro f. intermediate_weq (∑ r : f pt = x, !r ⟤ apd f loop = p ⟥ !r). - apply weqfibtototal; intro r. intermediate_weq (PathOver (Y := λ t:X pt, PathOver loop t t) (!r) p (apd f loop)). + apply inversePathOverWeq. + induction r. cbn. apply weqpathsinv0. - exact (weqfp (make_weq _ (isweqpathsinv0 _ _)) _). Defined. Lemma CircleInduction_isaprop (circle : Type) (pt : circle) (loop : pt = pt) : isaprop (CircleInduction circle pt loop). Proof. Abort. Lemma CircleInductionToRecursion' (circle : Type) (pt : circle) (loop : pt = pt) : CircleInduction' circle pt loop -> CircleRecursion' circle pt loop. Proof. intros I. unfold CircleRecursion'. intros X x p. set (w := I (λ _, X) x (PathOverConstant_map1 _ p)). simpl in w. exists (pr1 w). exists (pr12 w). refine (_ @ maponpaths PathOverConstant_map2 (pr22 w) @ _). { apply pathsinv0. refine (PathOverConstant_map2_eq2 _ _ @ _). apply maponpaths. apply PathOverConstant_map2_apd. } { refine (PathOverConstant_map2_eq1 _ _ @ _). apply (maponpaths (λ t, t @ _)). apply PathOverConstant_map1_map2. } Defined. (** A "circle" is a type with a point and a loop at that point that satisfies the induction principle of the circle. The type of all circles is called "Circle". *) Definition Circle := ∑ (circle : Type) (pt : circle) (loop : pt = pt), CircleInduction circle pt loop. Definition Circle' := ∑ (circle : Type) (pt : circle) (loop : pt = pt), CircleInduction' circle pt loop. Definition CircleEquiv : Circle ≃ Circle'. Proof. apply weqfibtototal; intro circle; apply weqfibtototal; intro pt; apply weqfibtototal; intro loop. apply CircleInductionEquiv. Defined. Definition CircleInductionMatch (C C' : Type) (pt : C) (pt' : C') (loop : pt = pt) (loop' : pt' = pt') (I : CircleInduction' C pt loop) (I' : CircleInduction' C' pt' loop') (g : C -> C') (r0 : g pt = pt') (r : r0 @ loop' = maponpaths g loop @ r0) : ∏ (X' : C' → Type) (x' : X' pt') (p' : PathOver loop' x' x'), Type. Proof. intros. set (X := X' ∘ g); cbn beta in X. set (x := pullBackPointOver g r0 x'). change (X' ∘ g) with X in x. set (p := pullBackPathOver g r p'). fold x in p. (* set (J := I X x p). *) set (typeofJ := ∑ (f : ∏ t : C, X t) (r : x = f pt), r ⟤ apd f loop = p ⟥ r). (* Check ( J : typeofJ ). *) assert (J'' : typeofJ). { unfold typeofJ. clear typeofJ. set (J' := I' X' x' p'). set (s' := pr1 J'). set (s := s' ∘ g); change (∏ x, X x) in (type of s). set (k := pr12 J'); change (pr1 J') with (s') in (type of k). set (ρ := pr22 J'); cbn beta in ρ; fold s k s' in ρ. exists s. exists (pullBackPointOverWithSection' _ _ k). set (kk := pullBackPathOver g r (apd s' loop')). Abort. Lemma Circle_isaprop : isaprop Circle. Proof. apply (isofhlevelweqb 1 CircleEquiv). apply invproofirrelevance. intros [C [pt [loop I]]] [C' [pt' [loop' I']]]. set (R := CircleInductionToRecursion' I ). set (R' := CircleInductionToRecursion' I'). set (gre := R C' pt' loop'). set (g := pr1 gre). set (r := pr12 gre). set (e := pr22 gre). set (gre' := R' C pt loop ). set (g' := pr1 gre'). set (r' := pr12 gre'). set (e' := pr22 gre'). fold g in r, e; fold g' in r', e'; fold r in e; fold r' in e'. cbn beta in e, e'. set (fib := (pt ,, pathsinv0 r) : hfiber g pt'). transparent assert (v : (pt = g' (g pt))). { refine (r' @ _). apply maponpaths. assumption. } transparent assert (v' : (pt' = g (g' pt'))). { refine (r @ _). apply maponpaths. assumption. } assert (ie : isweq g). { apply (isweq_iso _ g'). { intros x. apply pathsinv0. generalize x; clear x. simple refine (pr1 (I _ _ _)). - simpl. exact v. - set (Q := ! pathOverEquations (f := idfun _) (g := funcomp g g') v v loop). apply (cast Q); clear Q. intermediate_path (v @ maponpaths g' (maponpaths g loop)). + apply (maponpaths (λ k, v @ k)). apply pathsinv0, maponpathscomp. + rewrite maponpathsidfun. unfold v. rewrite <- path_assoc. rewrite <- maponpathscomp0. intermediate_path (r' @ maponpaths g' (loop' @ r)). * apply maponpaths. apply maponpaths. exact e. * rewrite maponpathscomp0. rewrite path_assoc. rewrite e'. rewrite path_assoc. reflexivity. } { intros x. apply pathsinv0. generalize x; clear x. simple refine (pr1 (I' _ _ _)). - simpl. exact v'. - set (Q := ! pathOverEquations (f := idfun _) (g := funcomp g' g) v' v' loop'). apply (cast Q); clear Q. intermediate_path (v' @ maponpaths g (maponpaths g' loop')). + apply (maponpaths (λ k, v' @ k)). apply pathsinv0, maponpathscomp. + rewrite maponpathsidfun. unfold v'. rewrite <- path_assoc. rewrite <- maponpathscomp0. intermediate_path (r @ maponpaths g (loop @ r')). * apply maponpaths. apply maponpaths. exact e'. * rewrite maponpathscomp0. rewrite path_assoc. rewrite e. rewrite path_assoc. reflexivity. } } (* We'll use univalence on g to identify C with C'. Then r will provide the match between pt and pt', and e will provide the corresponding match between loop and loop'. The question remains, how will we define matching I with I'? *) unfold CircleInduction' in I, I'. Abort. (** now start the formalization, following Marc and Ulrik *) Definition circle := B ℤ. Lemma loops_circle : ℤ ≃ Ω circle. Proof. apply loopsBG. Defined. Definition loop := loops_circle 1 : Ω circle. Definition loop' (X : Torsor ℤ) : X = X := invmap torsor_univalence (left_mult_Iso X 1). Definition pt := basepoint circle. Definition pt_0 : underlyingAction pt := 0. Definition pt_1 : underlyingAction pt := 1. Definition loop_loop' : loop = loop' pt. Proof. change ( invmap torsor_univalence (trivialTorsorAuto ℤ 1) = invmap torsor_univalence (left_mult_Iso pt 1)). apply maponpaths. apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n. change (n + 1 = 1 + n)%addmonoid. apply commax. Defined. Definition s {Z : Torsor ℤ} (x : Z) : pt = Z (* 0.5.6 *) := invmap torsor_univalence (triviality_isomorphism Z x). Section RelatedFacts. Definition fact0 (X Y : Torsor ℤ) (e : X = Y) (x : X) : s (transportf elem e x) = s x @ e. Proof. induction e. apply pathsinv0, pathscomp0rid. Defined. Lemma fact1 (X Y:Torsor ℤ) (e : X=Y) : loop' X @ e = e @ loop' Y. Proof. induction e. apply pathscomp0rid. Defined. Lemma fact2 (X: Torsor ℤ) (x:X) : s (transportf elem (loop' X) x) = s x @ loop' X. Proof. exact (fact0 (loop' X) x). Defined. Lemma fact3 (X: Torsor ℤ) (x:X) : loop' pt @ s x = s x @ loop' X. Proof. apply fact1. Defined. Lemma fact4 (X: Torsor ℤ) (x:X) : loop @ s x = s x @ loop' X. Proof. refine (_ @ fact3 x). apply (maponpaths (λ l, l @ s x)). apply loop_loop'. Defined. Lemma fact5 (X: Torsor ℤ) (x:X) : loop @ s x = s (transportf elem (loop' X) x). Proof. refine (_ @ !fact2 x). exact (fact4 x). Defined. End RelatedFacts. Definition ε' (X Y : Torsor ℤ) (e : X = Y) (x : X) : ! s x @ s (transportf elem e x) = e. Proof. (* 0.5.10 *) induction e. apply pathsinv0l. Defined. Lemma s_compute_0 : s pt_0 = idpath pt. Proof. intermediate_path (invmap torsor_univalence (idActionIso ℤ¹)). - change (s pt_0) with (invmap torsor_univalence (triviality_isomorphism ℤ¹ 0)). apply maponpaths. exact (triviality_isomorphism_compute ℤ). (* too slow *) - apply torsor_univalence_id. Defined. Definition ε {X : Torsor ℤ} (x : X) : loop @ s x = s (1 + x). (* 0.5.7 *) Proof. change ((invmap torsor_univalence (trivialTorsorRightMultiplication ℤ one)) @ s x = s (1 + x)). refine (invUnivalenceCompose _ _ @ _). unfold s. apply maponpaths. apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n. change (((n + 1)%addoperation + x) = (n + (1 + x))). apply ac_assoc. Defined. Definition ε1 {X : Torsor ℤ} (x : X) : s x @ loop' X = s (1 + x). Proof. unfold loop'. refine (invUnivalenceCompose _ _ @ _). unfold s. apply maponpaths. apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n. change (1 + (n + x) = n + (1 + x)). refine (! ac_assoc _ _ _ _ @ _ @ ac_assoc _ _ _ _). apply (maponpaths (right_mult x)). apply commax. Defined. Definition ε'' (x : underlyingAction pt) : ! s x @ s (1 + x) = loop. Proof. apply path_inv_rotate_ll, pathsinv0. refine (_ @ ε1 x). apply maponpaths; clear x. apply loop_loop'. Defined. Definition cp_irrelevance_circle (A:=circle) (B:circle->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α β: p=q) (v : PathOver p b1 b2) : cp α v = cp β v. Proof. apply (maponpaths (λ f, pr1weq f v)). apply cp_irrelevance. apply torsor_hlevel. Defined. Opaque PathOver. (* see the discussion at https://github.com/UniMath/UniMath/pull/1329 *) Section A. Context (A : circle -> Type) (a : A pt) (p : PathOver loop a a). Definition Q (X: Torsor ℤ) : Type (* 0.5.8 *) := ∑ (a' : A X), ∑ (h : ∏ (x:X), PathOver (s x) a a'), ∏ (x:X), h (1 + x) = cp (ε x) (p * h x). Lemma iscontr_Q (X: Torsor ℤ) (* 0.5.9 *) : iscontr_hProp (Q X). Proof. use (hinhuniv _ (torsor_nonempty X)). intros x. use (iscontrweqb (Y := ∑ a', PathOver (s x) a a')). 2 : { apply PathOverUniqueness. } apply weqfibtototal; intros a'. exact (ℤTorsorRecursion_weq (λ x, weqcomp (composePathOver_weq a' (s x) p) (cp (ε x))) x). Qed. Definition cQ (X:Torsor ℤ) := iscontrpr1 (iscontr_Q X). Definition c (X:Torsor ℤ) : A X := pr1 (cQ X). Definition c_tilde (X:Torsor ℤ) (x : X) : PathOver (s x) a (c X) := pr12 (cQ X) x. Arguments c_tilde : clear implicits. Definition c_hat (X:Torsor ℤ) (x : X) : c_tilde X (1 + x) = cp (ε x) (p * c_tilde X x) := pr22 (cQ X) x. Arguments c_hat : clear implicits. Definition apd_comparison (X Y : Torsor ℤ) (e : X = Y) (x : X) : (* 0.5.11 *) apd c e = cp (ε' e x) ((c_tilde X x)^-1 * c_tilde Y (transportf elem e x)). Proof. induction e. change (transportf elem (idpath X) x) with x. change (apd c (idpath X)) with (identityPathOver (c X)). rewrite composePathOverLeftInverse. change (ε' (idpath X) x) with (pathsinv0l (s x)). rewrite cp_inverse_cp. reflexivity. Defined. (* illustrate how to work around Coq not finding the right coercions: *) Local Goal ∏ (Y : B ℤ), Type. Proof. intros. Fail exact Y. exact (underlyingAction Y). Defined. Local Goal ∏ (X : circle), Type. Proof. intros. Fail exact X. exact (underlyingAction X). Defined. End A. Arguments c_tilde {_ _} _ _ _. Arguments c_hat {_ _} _ _ _. Theorem circle_induction : CircleInduction circle pt loop. Proof. apply CircleInductionEquiv. unfold CircleInduction'. intros A a p. set (f := c p). exists f. set (h := c_tilde p pt); fold f in h. set (h0 := h pt_0). set (e := Δ (cp s_compute_0 h0)). exists e. assert (q := c_hat p pt); fold h in q. set (s0 := s pt_0); unfold pt_0 in s0. set (s1 := s pt_1); unfold pt_1 in s1. set (one' := transportf elem loop pt_0); fold pt in one'. assert (r := apd_comparison p loop pt_0). fold pt h h0 f one' in r; unfold pt_0 in r. apply (pr2 (composePathPathOverRotate _ _ _)). rewrite composePathPathOverPath. refine (r @ _); clear r. assert (ss : one' = pt_1). { unfold one'. refine (castTorsor_transportf (invmap torsor_univalence _) _ @ _). apply torsor_univalence_inv_comp_eval. } unfold pt_1 in ss. set (s0sm := λ m:ℤ¹, ! s0 @ s m). assert (b : cp (ε' loop 0) (h0^-1 * h one') = cp (ε'' 0) (h0^-1 * h (1 + pt_0))). { intermediate_path (cp (ε'' 0) (cp (maponpaths s0sm ss) (h0^-1 * h one'))). - intermediate_path (cp (maponpaths s0sm ss @ ε'' 0) (h0^-1 * h one')). + apply cp_irrelevance_circle. + apply cp_pathscomp0. - apply maponpaths. exact (cp_in_family _ (λ m, h0^-1 * h m)). } refine (b @ _); clear s0sm b. unfold pt_0. rewrite (q 0). fold h0. clear q ss one'. set (α0 := invrot' (s_compute_0 : s0 = ! idpath _)). transparent assert (α : (!s0 @ s1 = idpath pt @ (loop @ s0))). { exact (apstar α0 (!ε pt_0)). } transparent assert (β : (idpath pt @ (loop @ s0) = idpath pt @ (loop @ idpath pt))). { exact (apstar (idpath _) (apstar (idpath loop) s_compute_0)). } transparent assert (γ : (idpath pt @ (loop @ idpath pt) = idpath pt @ loop)). { exact (apstar (idpath _) (pathscomp0rid _)). } intermediate_path (cp (α@β@γ) (h0^-1 * cp (ε pt_0) (p * h0))). (* try to make do with just two factors *) { apply cp_irrelevance_circle. } rewrite cp_pathscomp0. unfold α. rewrite cp_apstar. rewrite inverse_cp_p. rewrite cp_pathscomp0. unfold β. rewrite cp_apstar. rewrite cp_idpath. unfold γ. rewrite cp_apstar. rewrite cp_idpath. rewrite cp_apstar. change (cp s_compute_0 h0) with (∇ e). change (cp (idpath loop) p) with p. rewrite composePathOverPath_compute, composePathPathOver_compute. intermediate_path (cp (pathscomp0rid loop) (cp α0 (h0^-1) * p * ∇ e)). { rewrite cp_left. apply (maponpaths (cp (pathscomp0rid loop))). exact (assocPathOver (cp α0 (h0^-1)) p (cp s_compute_0 h0)). } rewrite cp_apstar'; fold s0. unfold α0. rewrite invrotrot'. change (cp s_compute_0 h0) with (∇ e). rewrite inversePathOverIdpath'. reflexivity. Defined. (* too slow *) Arguments circle_induction : clear implicits. UniMath-20231010/UniMath/SyntheticHomotopyTheory/Coproduct.v000066400000000000000000000041621451125700300237140ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.PartA. (** This file gives a characterisation of the path-types of coproducts, explicitly using the “encode-decode” heuristic from synthetic homotopy theory, to illustrate that method in a simple setting. However, this is essentially a duplicate of results already given in [Foundations], [MoreFoundations], and as such should be considered DEPRECATED, and not imported elsewhere. *) (** * Path spaces of coproducts *) Section coprod_paths. Variables A B : UU. Variable a : A. Definition code : A ⨿ B → UU. Proof. use coprod_rect; cbn. - exact (fun x => a = x). - exact (fun _ => empty). Defined. Definition decode : ∏ t : A ⨿ B, code t → (inl a = t). Proof. induction t. - cbn. apply maponpaths. - cbn. apply fromempty. Defined. Definition encode : ∏ t : A ⨿ B, (inl a = t) → code t. Proof. cbn. intros t p. apply (transportf _ p). apply idpath. Defined. Lemma encode_decode : ∏ (t : A ⨿ B) (p : inl a = t), decode _ (encode _ p) = p. Proof. intros t p. induction p. apply idpath. Defined. Lemma decode_encode : ∏ (t : A ⨿ B) (p : code t), encode _ (decode _ p) = p. Proof. intro t. induction t. - cbn. intro p. induction p. apply idpath. - cbn. intro. apply fromempty. apply p. Defined. Lemma coprod_paths : ∏ t : A ⨿ B, (inl a = t) ≃ code t. Proof. intro t. exists (encode _ ). use isweq_iso. - exact (decode _ ). - apply encode_decode. - apply decode_encode. Defined. End coprod_paths. Definition paths_inl (A B : UU) (a a' : A) : @inl A B a = inl a' ≃ a = a'. Proof. apply coprod_paths. Defined. Definition paths_inl_inr (A B : UU) (a : A) (b : B) : inl a = inr b ≃ empty. Proof. apply coprod_paths. Defined. Definition paths_inr (A B : UU) (b b' : B) : @inr A B b = inr b' ≃ b = b'. Proof. eapply weqcomp. - use (weqonpaths (weqcoprodcomm _ _ )). - apply coprod_paths. Defined. Definition paths_inr_inl (A B : UU) (a : A) (b : B) : inr b = inl a ≃ empty. Proof. eapply weqcomp. - use (weqonpaths (weqcoprodcomm _ _ )). - apply paths_inl_inr. Defined. UniMath-20231010/UniMath/SyntheticHomotopyTheory/Halfline.v000066400000000000000000000056031451125700300234750ustar00rootroot00000000000000(** * The induction principle for the half line. *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.NullHomotopies. Require Import UniMath.MoreFoundations.Nat. Require Import UniMath.MoreFoundations.Notations. Require Import UniMath.MoreFoundations.PartA. Notation ℕ := nat. Definition target_paths {Y} (f:ℕ->Y) := ∏ n, f n=f(S n). Definition gHomotopy {Y} (f:ℕ->Y) (s:target_paths f) := fun y:Y => ∑ (h:nullHomotopyFrom f y), ∏ n, h(S n) = h n @ s n. Definition GuidedHomotopy {Y} (f:ℕ->Y) (s:target_paths f) := total2 (gHomotopy f s). Theorem iscontrGuidedHomotopy {Y} {f:ℕ->Y} (s:target_paths f) : iscontr (GuidedHomotopy f s). Proof. intros. unfold GuidedHomotopy, nullHomotopyFrom. refine (@iscontrweqb _ (∑ y, y=f 0) _ _). { apply weqfibtototal. intro y. exact (Nat.Uniqueness.hNatRecursion_weq (λ n, y = f n) (λ n hn, hn @ s n)). } { apply iscontrcoconustot. } Defined. Definition halfline := ∥ ℕ ∥. Definition makeNullHomotopy {Y} {f:ℕ->Y} (s:target_paths f) {y:Y} (h0:y=f 0) : nullHomotopyFrom f y. Proof. intros. intro n. induction n as [|n IHn]. { exact (h0). } { exact (IHn @ s _). } Defined. Definition map {Y} {f:ℕ->Y} (s:target_paths f) : halfline -> GuidedHomotopy f s. Proof. intros r. apply (squash_to_prop r). { apply isapropifcontr. apply iscontrGuidedHomotopy. } { intro n. exists (f n). induction n as [|n IHn]. { exists (makeNullHomotopy s (idpath _)). intro n. reflexivity. } { exact (transportf (gHomotopy f s) (s n) IHn). } } Defined. Definition map_path {Y} {f:ℕ->Y} (s:target_paths f) : ∏ n, map s (squash_element n) = map s (squash_element (S n)). Proof. intros. apply (two_arg_paths_f (s n)). simpl. reflexivity. Defined. Definition map_path_check {Y} {f:ℕ->Y} (s:target_paths f) (n:ℕ) : ∏ p : map s (squash_element n) = map s (squash_element (S n)), maponpaths pr1 p = s n. Proof. intros. set (q := map_path s n). assert (path_inverse_to_right : q=p). { apply (hlevelntosn 1). apply (hlevelntosn 0). apply iscontrGuidedHomotopy. } destruct path_inverse_to_right. apply total2_paths2_comp1. Defined. (** ** universal property for the half line *) Definition halfline_map {Y} {target_points:ℕ->Y} (s:target_paths target_points) : halfline -> Y. Proof. intros r. exact (pr1 (map s r)). Defined. Definition check_values {Y} {target_points:ℕ->Y} (s:target_paths target_points) (n:ℕ) : halfline_map s (squash_element n) = target_points n. Proof. reflexivity. Defined. Definition check_paths {Y} {target_points:ℕ->Y} (s:target_paths target_points) (n:ℕ) : maponpaths (halfline_map s) (squash_path n (S n)) = s n. Proof. intros. refine (_ @ map_path_check s n _). apply pathsinv0. apply maponpathscomp. Defined. (* Local Variables: compile-command: "make -C ../.. UniMath/SyntheticHomotopyTheory/Halfline.vo" End: *) UniMath-20231010/UniMath/SyntheticHomotopyTheory/README.md000066400000000000000000000022121451125700300230340ustar00rootroot00000000000000Synthetic Homotopy Theory ========================= In this package we collect a few results about synthetic homotopy theory. The main one is the construction of the circle as the type of torsors over the group of integers and the proof of its induction principle. The files were written by Daniel Grayson. Overview of contents ==================== ## Halfline.v Construction of the "half line" by squashing nat. A Map from it to another type is determined by a sequence of points connected by paths. The techniques are a warm-up for the construction of the circle. ## AffineLine.v We show that the propositional truncation of a ℤ-torsor, where ℤ is the additive group of the integers, behaves like an affine line. It's a contractible type, but maps from it to another type Y are determined by specifying where the points of T should go, and where the paths joining consecutive points of T should go. This forms the basis for the construction of the circle as a quotient of the affine line. ## Circle.v Construction of the circle as Bℤ. A map from it to another type is determined by a point and a loop. Forthcoming: the dependent version. UniMath-20231010/UniMath/SyntheticHomotopyTheory/Test.v000066400000000000000000000053011451125700300226650ustar00rootroot00000000000000Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Import UniMath.SyntheticHomotopyTheory.Circle2. Require Import UniMath.SyntheticHomotopyTheory.AffineLine. Require Import UniMath.NumberSystems.Integers. Local Open Scope hz. Require Import UniMath.Algebra.BinaryOperations. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.GroupAction. Local Open Scope abgr. Local Open Scope action_scope. Local Notation "0" := (toℤ 0). Local Notation "1" := (toℤ 1). Section A. Goal ∏ (X:Type) (f := eqweqmap (idpath X)), f = idweq X. reflexivity. Qed. Goal ∏ (X:Type), invmap (idweq X) = idfun X. reflexivity. Qed. Goal ∏ (X:Type) (x:X), iscontrpr1 (iscontrcoconusfromt X x) = (x,,idpath x). reflexivity. Qed. Goal ∏ (X:Type) (x:X), iscontrpr1 (iscontrcoconustot X x) = (x,,idpath x). reflexivity. Qed. Goal ∏ (X Y:Type) (f:X≃Y), invmap (invweq f) = f. reflexivity. Qed. Goal ∏ (X Y Z:Type) (f:X≃Y) (g:Y≃Z), pr1weq (weqcomp f g) = funcomp f g. reflexivity. Qed. Goal ∏ (X Y Z:Type) (f:X≃Y) (g:Y≃Z), invmap (weqcomp f g) = funcomp (invmap g) (invmap f). reflexivity. Qed. Goal ∏ {X : UU} (P Q : X -> Type) (f : ∏ x, P x ≃ Q x) (x:X) (p:P x), weqfibtototal _ _ f (x,,p) = (x,,f x p). reflexivity. Qed. Goal ∏ {X : UU} (P Q : X -> Type) (f : ∏ x, P x ≃ Q x) (x:X) (q:Q x), invmap (weqfibtototal _ _ f) (x,,q) = (x,,invmap (f x) q). reflexivity. Qed. Goal ∏ {X Y : Type} (w : X ≃ Y) (is : iscontr Y), iscontrpr1 (iscontrweqb w is) = invmap w (iscontrpr1 is). reflexivity. Qed. Goal ∏ {X Y : Type} (w : X ≃ Y) (is : iscontr X), iscontrpr1 (iscontrweqf w is) = w (iscontrpr1 is). reflexivity. Qed. Goal ∏ (X:Type) (i : isConnected X) (P:X->hProp) (x0:X) (p:P x0), @predicateOnConnectedType X i P x0 p x0 = p. Fail reflexivity. Abort. Goal ∏ (X:Type) (i : iscontr X) (x0 := pr1 i : X), pr2 i x0 = idpath x0. Fail reflexivity. Abort. Goal ∏ (X Y:Type) (p:X=Y) (x:X), eqweqmap p x = cast p x. Fail reflexivity. Abort. Goal ∏ (X Y:Type) (p:X=Y) (x:X), eqweqmap p x = transportf (λ T, T) p x. Fail reflexivity. Abort. Goal ∏ {X:PointedType} (bc : isBaseConnected X) (t := basepoint X), pr2 (baseConnectedness X bc) t t = hinhpr (idpath t). Fail reflexivity. Abort. Goal ∏ (G:gr), isBaseConnected_BG G (trivialTorsor G) = hinhpr (idpath (trivialTorsor G)). Fail reflexivity. Abort. Goal ∏ (n:ℤ), (n+0 = n)%hz. Fail reflexivity. Abort. Goal ∏ (n:ℤ), (0+n = n)%hz. Fail reflexivity. Abort. Goal ∏ (X : UU) (P : hProp) (f : X → P) (x : X), hinhuniv f (hinhpr x) = f x. reflexivity. Qed. End A. UniMath-20231010/UniMath/Tactics/000077500000000000000000000000001451125700300162465ustar00rootroot00000000000000UniMath-20231010/UniMath/Tactics/.package/000077500000000000000000000000001451125700300177175ustar00rootroot00000000000000UniMath-20231010/UniMath/Tactics/.package/files000066400000000000000000000001521451125700300207420ustar00rootroot00000000000000EnsureStructuredProofs.v Utilities.v Monoids_Tactics.v Abmonoids_Tactics.v Groups_Tactics.v Nat_Tactics.v UniMath-20231010/UniMath/Tactics/Abmonoids_Tactics.v000066400000000000000000000272661451125700300220370ustar00rootroot00000000000000(** Author: Michael A. Warren.*) (** Date: Spring 2015.*) (** Description: Some tactics for abelian monoids.*) Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Tactics.Monoids_Tactics. Require Import UniMath.Tactics.Utilities. (** * I. Definitions.*) (** Because rewrite seems to have handling the two scopes multmonoid and addmonoid, the following definitions are for arbitrary commutative operations.*) Definition isabsemigrop {X : hSet} (opp : binop X) := (isassoc opp) ** (iscomm opp). Definition abmonoid_to_absemigr (M : abmonoid) : isabsemigrop (@op M) := make_dirprod (@assocax M) (@commax M). Definition absemigr_perm021 : ∏ X : hSet, ∏ opp : binop X, ∏ is : isabsemigrop opp, ∏ n0 n1 n2, opp (opp n0 n1) n2 = opp (opp n0 n2) n1 := λ X opp is n0 n1 n2, pathscomp0 (pathscomp0 ((pr1 is) n0 n1 n2) (maponpaths (λ z, opp n0 z) ((pr2 is) n1 n2))) (pathsinv0 ((pr1 is) n0 n2 n1)). Definition abmonoid_perm021 := λ M : abmonoid, absemigr_perm021 M (@op M) (abmonoid_to_absemigr M). Definition absemigr_perm102 : ∏ X : hSet, ∏ opp : binop X, ∏ is : isabsemigrop opp, ∏ n0 n1 n2, opp (opp n0 n1) n2 = opp (opp n1 n0) n2 := λ X opp is n0 n1 n2, maponpaths (λ z, opp z n2) ((pr2 is) n0 n1). Definition abmonoid_perm102 := λ M : abmonoid, absemigr_perm102 M (@op M) (abmonoid_to_absemigr M). Definition absemigr_perm120 : ∏ X : hSet, ∏ opp : binop X, ∏ is : isabsemigrop opp, ∏ n0 n1 n2, opp (opp n0 n1) n2 = opp (opp n2 n0) n1 := λ X opp is n0 n1 n2, pathscomp0 ((pr2 is) (opp n0 n1) n2) (pathsinv0 ((pr1 is) n2 n0 n1)). Definition abmonoid_perm120 := λ M : abmonoid, absemigr_perm120 M (@op M) (abmonoid_to_absemigr M). Definition absemigr_perm201 : ∏ X : hSet, ∏ opp : binop X, ∏ is : isabsemigrop opp, ∏ n0 n1 n2, opp (opp n0 n1) n2 = opp (opp n1 n2) n0 := λ X opp is n0 n1 n2, pathscomp0 ((pr1 is) n0 n1 n2) ((pr2 is) n0 (opp n1 n2)). Definition abmonoid_perm201 := λ M : abmonoid, absemigr_perm201 M (@op M) (abmonoid_to_absemigr M). Definition absemigr_perm210 : ∏ X : hSet, ∏ opp : binop X, ∏ is : isabsemigrop opp, ∏ n0 n1 n2, opp (opp n0 n1) n2 = opp (opp n2 n1) n0 := λ X opp is n0 n1 n2, pathscomp0 (absemigr_perm102 X opp is n0 n1 n2) (absemigr_perm120 X opp is n1 n0 n2). Definition abmonoid_perm210 := λ M : abmonoid, absemigr_perm210 M (@op M) (abmonoid_to_absemigr M). (** * II. Tactics for rearranging words.*) (** We employ the following naming conventions. By default a tactics given pertain only to equations and operate by default on the left-hand side of equations. Those that operate on both left- and right-hand sides of the goal are suffixed with [_goal]. Tactics that operate on the left-hand side of equations occurring as hypotheses are suffixed with [_in]. Those that operate on both left- and right-hand sides of equations occurring as hypotheses are suffixed with [_both_in]. Those that opexrate on all sides of goals and hypotheses are suffixed with [_all].*) (** TODO: More general version.*) Ltac absemigr_ternary_perm X opp is s t u := let f := eval hnf in opp in match goal with | |- ?lhs = ?rhs => match lhs with | context[f (f t s) u] => rewrite (absemigr_perm102 X f is t s u); idtac | context[f (f t u) s] => rewrite (absemigr_perm120 X f is t u s); idtac | context[f (f u s) t] => rewrite (absemigr_perm201 X f is u s t); idtac | context[f (f u t) s] => rewrite (absemigr_perm210 X f is u t s); idtac | context[f (f s u) t] => rewrite (absemigr_perm021 X f is s u t); idtac | context[f (f (f ?x t) s) u] => rewrite (pr1 is x t s); rewrite (pr1 is x (f t s) u); rewrite (absemigr_perm102 X f is t s u); rewrite <- (pr1 is x (f s t) u); rewrite <- (pr1 is x s t); idtac | context[f (f (f ?x t) u) s] => rewrite (pr1 is x t u); rewrite (pr1 is x (f t u) s); rewrite (absemigr_perm120 X f is t u s); rewrite <- (pr1 is x (f s t) u); rewrite <- (pr1 is x s t); idtac | context[f (f (f ?x u) s) t] => rewrite (pr1 is x u s); rewrite (pr1 is x (f u s) t); rewrite (absemigr_perm201 X f is u s t); rewrite <- (pr1 is x (f s t) u); rewrite <- (pr1 is x s t); idtac | context[f (f (f ?x u) t) s] => rewrite (pr1 is x u t); rewrite (pr1 is x (f u t) s); rewrite (absemigr_perm210 X f is u t s); rewrite <- (pr1 is x (f s t) u); rewrite <- (pr1 is x s t); idtac | context[f (f (f ?x s) u) t] => rewrite (pr1 is x s u); rewrite (pr1 is x (f s u) t); rewrite (absemigr_perm021 X f is s u t); rewrite <- (pr1 is x (f s t) u); rewrite <- (pr1 is x s t); idtac end end. Ltac abmonoid_ternary_perm M := absemigr_ternary_perm M (@op M) (abmonoid_to_absemigr M). Local Open Scope addmonoid. Ltac abmonoid_not_word M s := match s with | ?x + ?y => fail 1 | _ => idtac end. Ltac abmonoid_not_at_front M t s := match t with | s => fail 1 | context[s + ?x] => fail 1 | _ => idtac end. Ltac abmonoid_not_at_back M t s := match t with | s => fail 1 | ?x + s => fail 1 | _ => idtac end. Ltac abmonoid_move_to_back M s := repeat let lhs := get_current_lhs in abmonoid_not_at_back M lhs s; match lhs with | s + ?x => rewrite (commax M s x) | context[?x + s + ?y] => rewrite (abmonoid_perm021 M x s y) | context[s + ?x + ?y] => rewrite (abmonoid_perm201 M s x y) end. Ltac abmonoid_move_to_back_in M H s := repeat let lhs := get_current_lhs_in H in abmonoid_not_at_back M lhs s; match lhs with | s + ?x => rewrite (commax M s x) in H | context[?x + s + ?y] => rewrite (abmonoid_perm021 M x s y) in H | context[s + ?x + ?y] => rewrite (abmonoid_perm201 M s x y) in H end. Ltac abmonoid_move_to_front M s := repeat let lhs := get_current_lhs in abmonoid_not_at_front M lhs s; match lhs with | context[?x + s] => abmonoid_not_word M x; rewrite (commax M x s) | context[?x + ?y + s] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x y s) end. Ltac abmonoid_move_to_front_in M H s := repeat let lhs := get_current_lhs_in H in abmonoid_not_at_front M lhs s; match lhs with | context[?x + s] => abmonoid_not_word M x; rewrite (commax M x s) in H | context[?x + ?y + s] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x y s) in H end. Ltac abmonoid_move_to_front_goal M s := repeat let rhs := get_current_rhs in abmonoid_not_at_front M rhs s; match rhs with | context[?x + s] => abmonoid_not_word M x; rewrite (commax M x s) | context[?x + ?y + s] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x y s) end. Ltac abmonoid_move_to_front_both_in M H s := repeat let rhs := get_current_rhs_in H in abmonoid_not_at_front M rhs s; match rhs with | context[?x + s] => abmonoid_not_word M x; rewrite (commax M x s) in H | context[?x + ?y + s] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x y s) in H end. Ltac abmonoid_move_to_back_goal M s := repeat let rhs := get_current_rhs in abmonoid_not_at_back M rhs s; match rhs with | context [s + ?x] => rewrite (commax M s x) | context[?x + s + ?y] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x s y) | context[s + ?x + ?y] => abmonoid_not_word M x; abmonoid_not_word M y; rewrite (abmonoid_perm201 M s x y) end. Ltac abmonoid_move_to_back_both_in M H s := repeat let rhs := get_current_rhs_in H in abmonoid_not_at_back M rhs s; match rhs with | context [s + ?x] => rewrite (commax M s x) | context[?x + s + ?y] => abmonoid_not_word M y; rewrite (abmonoid_perm021 M x s y) in H | context[s + ?x + ?y] => abmonoid_not_word M x; abmonoid_not_word M y; rewrite (abmonoid_perm201 M s x y) in H end. Ltac abmonoid_group M s t := abmonoid_move_to_front M t; abmonoid_move_to_front M s. Ltac abmonoid_group_goal M s t := abmonoid_move_to_front_goal M t; abmonoid_move_to_front_goal M s. Ltac abmonoid_group_in M H s t := abmonoid_move_to_front_in M H t; abmonoid_move_to_front_in M H s. Ltac abmonoid_group_both_in M H s t := abmonoid_move_to_front_both_in M H t; abmonoid_move_to_front_both_in M H s. Ltac abmonoid_group_all M s t := abmonoid_group_goal M s t; repeat match goal with | H : _ |- _ => abmonoid_group_both_in M H s t end. (** t is a term of type M and abmonoid_group_as attempts to reorganize the lhs of the goal to include as a subterm t.*) Ltac abmonoid_group_as M t := match t with | ?x + ?y => abmonoid_not_word M y; abmonoid_move_to_front M y; abmonoid_group_as M x | ?x => abmonoid_not_word M x; abmonoid_move_to_front M x end. (** t is a term of type x = y for x, y : M and abmonoid_group_from attempts to reogranize the lhs of the goal to include as a subterm x.*) Ltac abmonoid_group_from M t := let T := type of t in match T with | ?lhs = ?rhs => abmonoid_group_as M lhs end. Ltac abmonoid_op_strip M := match goal with | |- ?lhs = ?rhs => match lhs with | context [?x] => match rhs with | context [x] => abmonoid_move_to_back_goal M x; apply (ap (λ v, v + x)) end end end. Ltac abmonoid_zap_body M f := match goal with | |- ?lhs = ?rhs => match lhs with | rhs => apply idpath | 0 => apply pathsinv0; abmonoid_zap_body M f | ?x + ?y => match rhs with | y + x => apply (commax M x y) end | _ => (abmonoid_op_strip M; abmonoid_zap_body M f) end | E : ?l = ?r |- ?lhs = ?rhs => f E; let g := make_hyp_check E in let h := check_cons g f in abmonoid_group_from M E; matched_rewrite E; abmonoid_zap_body M h end. Ltac abmonoid_zap M := monoid_clean_all M; abmonoid_zap_body M id_check. (** * TESTS *) (* Unset Ltac Debug. Section Tests. Hypothesis M : abmonoid. Hypothesis x y z u v w : M. Lemma test_abmonoid_zap_1 (is : w = v): x + (y + w) = x + (v + y). Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_2 (is : w = v): x + (y + w) = v + (x + y). Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_3 (t : x + (y + (u + z)) = (v + w) + u) : (((x + y) + z) + u) + w = v + (w + (u + w)). Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_4 (t : x + (u + (z + y)) = (u + w) + v) : (((x + y) + z) + u) + w = (w + (u + w)) + v. Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_5 (t : x + ((u + z) + y) = (v + w) + u) : ((x + (y + z)) + u) + w = v + (w + (u + w)). Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_6 (t : x + (y + (z + u)) = (v + w) + u) : ((u + (z + y)) + x) + w = w + (u + (w + v)). Proof. intros. abmonoid_zap M. Qed. Lemma test_monoid_zap_7 : x + y + x = x + x + y. Proof. intros. abmonoid_zap M. Qed. Lemma test_abmonoid_zap_8 (t : x + y = y + x) (i : z + x = @unel M) : x + (y + z) = y + (x + z). Proof. intros. abmonoid_zap M. Qed. Close Scope addmonoid. End Tests. *) UniMath-20231010/UniMath/Tactics/EnsureStructuredProofs.v000066400000000000000000000005611451125700300231560ustar00rootroot00000000000000(** This line is there to enforce that all tactics are used either on a single focused goal or with a local selector ("strict focusing mode"). Hence, it enforces an element of UniMath coding style. Do not copy this line into the files but put [[Require Export UniMath.Tactics.EnsureStructuredProofs.]] into the header part. *) Export Set Default Goal Selector "!". UniMath-20231010/UniMath/Tactics/Groups_Tactics.v000066400000000000000000000051011451125700300213630ustar00rootroot00000000000000(** Author: Michael A. Warren (maw@mawarren.net).*) (** Date: Spring 2015.*) (** Description: Some tactics for groups.*) Require Import UniMath.Algebra.Monoids. Require Import UniMath.Algebra.Groups. Require Import UniMath.Tactics.Utilities. Require Import UniMath.Tactics.Monoids_Tactics. Local Open Scope multmonoid. Ltac gr_preclean G := monoid_clean (grtomonoid G). Ltac gr_preclean_in G t := monoid_clean_in (grtomonoid G) t. Ltac gr_preclean_all G := monoid_clean_all (grtomonoid G). Ltac gr_prezap G := monoid_zap (grtomonoid G). Ltac gr_group_in G x s t := assocop_group_in (grtomonoid G) (@op (grtomonoid G)) x s t. Ltac gr_group G s t := assocop_group (grtomonoid G) (@op (grtomonoid G)) s t. Ltac gr_clean G := gr_preclean G; repeat rewrite (grlinvax G); repeat rewrite (grrinvax G); repeat (gr_preclean G; match goal with | |- context [?y * ?x * (@grinv G ?x)] => rewrite (assocax G y x (@grinv G x)), (grrinvax G); gr_clean G | |- context [?y * (@grinv G ?x) * ?x] => rewrite (assocax G y (@grinv G x) x), (grlinvax G); gr_clean G end); gr_preclean G. (** Tests*) (* Unset Ltac Debug. Section Tests. Hypothesis G : gr. Hypothesis x y z u v w : G. Lemma test_gr_prezap_1 (is : w = v): x * (y * w) = x * (y * v). Proof. intros. gr_prezap G. Qed. Lemma test_gr_prezap_2 (is : w = v): x * (y * w) = (x * y) * v. Proof. intros. gr_prezap G. Qed. Lemma test_gr_prezap_3 (t : x * (y * (z * u)) = (v * w) * u) : (((x * y) * z) * u) * w = v * (w * (u * w)). Proof. intros. gr_prezap G. Qed. Lemma test_gr_prezap_4 (t : x * (y * (z * u)) = (v * w) * u) : (((x * y) * z) * u) * w = v * (w * (u * w)). Proof. intros. gr_prezap G. Qed. Lemma test_gr_group_1 (t : x * (y * (z * u)) = (v * w) * u) : ((x * (y * z)) * u) * w = v * (w * (u * w)). Proof. intros. gr_group_in G t w u. gr_group G w u. gr_group G v (w * u). gr_prezap G. Qed. Lemma test_gr_prezap_5 (t : x * (y * (z * u)) = (v * w) * u) : ((x * (y * z)) * u) * w = v * (w * (u * w)). Proof. intros. gr_prezap G. Qed. Lemma test_gr_prezap_6 (t : x * y = y * x) : x * y * x = x * x * y. Proof. intros. gr_prezap G. Qed. Lemma test_gr_prezap_7 (t : x * y = y * x) (i : x * z = @unel G) : x * (y * z) = y * (x * z). Proof. intros. gr_prezap G. Qed. Lemma test_gr_clean_1 : x * (y * (@grinv G y)) * (@unel G) * ((@grinv G x) * v) = v. Proof. intros. gr_clean G. apply idpath. Qed. End Tests. Close Scope multmonoid. *) UniMath-20231010/UniMath/Tactics/Monoids_Tactics.v000066400000000000000000000100371451125700300215200ustar00rootroot00000000000000(** Author: Michael A. Warren.*) (** Date: Spring 2015.*) (** Description: Some tactics for monoids.*) Require Import UniMath.Algebra.Monoids. Require Import UniMath.Tactics.Utilities. Ltac op_strip f := repeat match goal with | |- f ?x ?y = f ?x ?z => apply (ap (λ v, f x v)) | |- f ?y ?x = f ?z ?x => apply (ap (λ v, f v x)) end. Ltac assocop_clean M f := repeat rewrite <- (assocax M). Ltac assocop_clean_in M f t := repeat rewrite <- (assocax M) in t. Ltac assocop_clean_all M f := assocop_clean M f; repeat match goal with | H : context[f ?x (f ?y ?z)] |- _ => assocop_clean_in M f H end. Ltac assocop_trivial M f := try (assocop_clean_all M f; op_strip f; apply idpath). Ltac assocop_group_in M f x s t := let T := type of x in match T with | context[f s t] => idtac | context [f (f ?u s) t] => rewrite (assocax M u s t) in x | context [f s (f t ?u)] => rewrite <- (assocax M s t u) in x end. Ltac assocop_group M f s t := match goal with | |- context [f s t] => idtac | |- context [f (f ?u s) t] => rewrite (assocax M u s t) | |- context [f s (f t ?u)] => rewrite <- (assocax M s t u) end. Ltac monoid_clean M := repeat rewrite (lunax M); repeat rewrite (runax M); assocop_clean M (@op M). Ltac monoid_clean_in M t := repeat rewrite (lunax M) in t; repeat rewrite (runax M) in t; assocop_clean_in M (@op M) t. Ltac monoid_clean_all M := monoid_clean M; repeat match goal with | H : _ |- _ => monoid_clean_in M H end. Ltac monoid_declean M := repeat rewrite (assocax M). Ltac monoid_op_strip_left M := (monoid_declean M; match goal with | |- (@op M) ?x ?y = (@op M) ?x ?z => apply (ap (λ v, (@op M) x v)) | |- (?x * ?y = ?x * ?z)%multmonoid => apply (ap (λ v, x * v))%multmonoid end; monoid_clean M). (** Some error handling should be added (e.g., to check that lhs, rhs are of type M; that they are words in M, etc.).*) Ltac monoid_zap_body M f := match goal with | |- ?lhs = ?rhs => match lhs with | rhs => apply idpath | (@unel M) => apply pathsinv0; monoid_zap_body M f | _ => (monoid_op_strip_left M; monoid_zap_body M f) end | E : ?l = ?r |- ?lhs = ?rhs => f E; let g := make_hyp_check E in let h := check_cons g f in matched_rewrite E; monoid_zap_body M h end. Ltac monoid_zap M := monoid_clean_all M; monoid_zap_body M id_check. (** * TESTS *) (* Unset Ltac Debug. Section Tests. Open Scope multmonoid. Hypothesis M : monoid. Hypothesis x y z u v w : M. Lemma test_op_strip_1 (is : w = v): x * (y * w) = x * (y * v). Proof. intros. op_strip (@op M). assumption. Qed. Lemma test_assocop_clean_1 (is : w = v): x * (y * w) = (x * y) * v. Proof. intros. assocop_clean M (@op M). op_strip (@op M). assumption. Qed. Lemma test_assocop_clean_in_1 (t : x * (y * (z * u)) = (v * w) * u) : (((x * y) * z) * u) * w = v * (w * (u * w)). Proof. intros. assocop_clean_in M (@op M) t. assocop_clean M (@op M). rewrite t. op_strip (@op M). apply idpath. Qed. Lemma test_assocop_clean_all_1 (t : x * (y * (z * u)) = (v * w) * u) : (((x * y) * z) * u) * w = v * (w * (u * w)). Proof. intros. assocop_clean_all M (@op M). rewrite t. op_strip (@op M). apply idpath. Qed. Lemma test_assocop_group_1 (t : x * (y * (z * u)) = (v * w) * u) : ((x * (y * z)) * u) * w = v * (w * (u * w)). Proof. intros. assocop_group_in M (@op M) t w u. assocop_group M (@op M) w u. assocop_group M (@op M) v (w * u). rewrite <- t. assocop_trivial M (@op M). Qed. Lemma test_monoid_zap_1 (t : x * (y * (z * u)) = (v * w) * u) : ((x * (y * z)) * u) * w = v * (w * (u * w)). Proof. intros. monoid_zap M. Qed. Lemma test_monoid_zap_2 (t : x * y = y * x) : x * y * x = x * x * y. Proof. intros. monoid_zap M. Qed. Lemma test_monoid_zap_3 (t : x * y = y * x) (i : x * z = @unel M) : x * (y * z) = y * (x * z). Proof. intros. monoid_zap M. Qed. Close Scope multmonoid. End Tests. *) UniMath-20231010/UniMath/Tactics/Nat_Tactics.v000066400000000000000000001075511451125700300206420ustar00rootroot00000000000000(** Author: Michael A. Warren (maw@mawarren.net) in consultation with Vladimir Voevodsky.*) (** Date: Spring - Summer 2015.*) (** Description: Some tactics for natural numbers. *) (** Tactics for natural numbers.*) (** by Michael A. Warren, April - June 2015.*) (** ADD: Disclaimer regarding connection with other tactics files.*) Require Import UniMath.Foundations.NaturalNumbers UniMath.Tactics.Utilities UniMath.Tactics.Abmonoids_Tactics. Local Open Scope nat_scope. (** * Basic definitions and hints. *) Definition natneqtwist n (p : ¬ (0 = n)) : ¬ (n = 0) := λ f, p (pathsinv0 f). Definition nat_plus_perm021 : ∏ n0 n1 n2, n0 + n1 + n2 = n0 + n2 + n1 := λ n0 n1 n2, pathscomp0 (pathscomp0 (natplusassoc n0 n1 n2) (maponpaths (λ z, n0 + z) (natpluscomm n1 n2))) (pathsinv0 (natplusassoc n0 n2 n1)). Definition nat_plus_perm102 : ∏ n0 n1 n2, n0 + n1 + n2 = n1 + n0 + n2 := λ n0 n1 n2, maponpaths (λ z, z + n2) (natpluscomm n0 n1). Definition nat_plus_perm120 : ∏ n0 n1 n2, n0 + n1 + n2 = n2 + n0 + n1 := λ n0 n1 n2, pathscomp0 (natpluscomm (n0 + n1) n2) (pathsinv0 (natplusassoc n2 n0 n1)). Definition nat_plus_perm201 : ∏ n0 n1 n2, n0 + n1 + n2 = n1 + n2 + n0 := λ n0 n1 n2, pathscomp0 (natplusassoc n0 n1 n2) (natpluscomm n0 (n1 + n2)). Definition nat_plus_perm210 : ∏ n0 n1 n2, n0 + n1 + n2 = n2 + n1 + n0 := λ n0 n1 n2, pathscomp0 (nat_plus_perm102 n0 n1 n2) (nat_plus_perm120 n1 n0 n2). Definition nat_mult_perm021 : ∏ n0 n1 n2, n0 * n1 * n2 = n0 * n2 * n1 := λ n0 n1 n2, pathscomp0 (pathscomp0 (natmultassoc n0 n1 n2) (maponpaths (λ z, n0 * z) (natmultcomm n1 n2))) (pathsinv0 (natmultassoc n0 n2 n1)). Definition nat_mult_perm102 : ∏ n0 n1 n2, n0 * n1 * n2 = n1 * n0 * n2 := λ n0 n1 n2, maponpaths (λ z, z * n2) (natmultcomm n0 n1). Definition nat_mult_perm120 : ∏ n0 n1 n2, n0 * n1 * n2 = n2 * n0 * n1 := λ n0 n1 n2, pathscomp0 (natmultcomm (n0 * n1) n2) (pathsinv0 (natmultassoc n2 n0 n1)). Definition nat_mult_perm201 : ∏ n0 n1 n2, n0 * n1 * n2 = n1 * n2 * n0 := λ n0 n1 n2, pathscomp0 (natmultassoc n0 n1 n2) (natmultcomm n0 (n1 * n2)). Definition nat_mult_perm210 : ∏ n0 n1 n2, n0 * n1 * n2 = n2 * n1 * n0 := λ n0 n1 n2, pathscomp0 (nat_mult_perm102 n0 n1 n2) (nat_mult_perm120 n1 n0 n2). Definition minus0r : ∏ n, n - 0 = n := λ n, match n with | 0 => (idpath _) | S _ => (idpath _) end. Definition minusnn0 n : n - n = 0. Proof. induction n as [|n IHn]; [exact (idpath 0) | exact IHn]. Defined. (** minus0l and Lemma minussn1 n : (S n) - 1 change to n - 0 should be changed in tactics.*) Definition minusgeh n m : n >= (n - m). Proof. revert m. induction n as [|n IHn]; intros. apply isreflnatgeh. destruct m. rewrite minus0r. apply isreflnatgeh. apply (istransnatgeh _ n _). apply natgthtogeh. apply natgthsnn. apply IHn. Defined. (** * Tactics for rearranging subterms of goals and hypotheses.*) (** ** Tactics for performing ternary permutations of words written in [+] and [*].*) (** TACTIC: [nat_plus_ternary_perm] SUMMARY: [nat_plus_ternary_perm] permutes words of length 3 in [+]. USAGE: Provided that the current [goal] is of the form [lhs = rhs], [nat_plus_ternary_perm x y z] will permute a subterm of [lhs] so that it now appears in the form [x + y + z]. EXAMPLE: If the current goal is [x + y + z = y + z + x], then [nat_plus_ternary_perm y z x] will change the goal to [y + z + x = y + z + x].*) Ltac nat_plus_ternary_perm s t u := match goal with | |- ?lhs = ?rhs => match lhs with | context[t + s + u] => rewrite (nat_plus_perm102 t s u); idtac | context[t + u + s] => rewrite (nat_plus_perm120 t u s); idtac | context[u + s + t] => rewrite (nat_plus_perm201 u s t); idtac | context[u + t + s] => rewrite (nat_plus_perm210 u t s); idtac | context[s + u + t] => rewrite (nat_plus_perm021 s u t); idtac | context[?x + t + s + u] => rewrite (natplusassoc x t s); rewrite (natplusassoc x (t + s) u); rewrite (nat_plus_perm102 t s u); rewrite <- (natplusassoc x (s + t) u); rewrite <- (natplusassoc x s t); idtac | context[?x + t + u + s] => rewrite (natplusassoc x t u); rewrite (natplusassoc x (t + u) s); rewrite (nat_plus_perm120 t u s); rewrite <- (natplusassoc x (s + t) u); rewrite <- (natplusassoc x s t); idtac | context[?x + u + s + t] => rewrite (natplusassoc x u s); rewrite (natplusassoc x (u + s) t); rewrite (nat_plus_perm201 u s t); rewrite <- (natplusassoc x (s + t) u); rewrite <- (natplusassoc x s t); idtac | context[?x + u + t + s] => rewrite (natplusassoc x u t); rewrite (natplusassoc x (u + t) s); rewrite (nat_plus_perm210 u t s); rewrite <- (natplusassoc x (s + t) u); rewrite <- (natplusassoc x s t); idtac | context[?x + s + u + t] => rewrite (natplusassoc x s u); rewrite (natplusassoc x (s + u) t); rewrite (nat_plus_perm021 s u t); rewrite <- (natplusassoc x (s + t) u); rewrite <- (natplusassoc x s t); idtac end end. (** TACTIC: [nat_mult_ternary_perm] SUMMARY: [nat_mult_ternary_perm] permutes words of length 3 in [*]. USAGE: See [nat_plus_ternary_perm] above.*) Ltac nat_mult_ternary_perm s t u := match goal with | |- ?lhs = ?rhs => match lhs with | context[t * s * u] => rewrite (nat_mult_perm102 t s u); idtac | context[t * u * s] => rewrite (nat_mult_perm120 t u s); idtac | context[u * s * t] => rewrite (nat_mult_perm201 u s t); idtac | context[u * t * s] => rewrite (nat_mult_perm210 u t s); idtac | context[s * u * t] => rewrite (nat_mult_perm021 s u t); idtac | context[?x * t * s * u] => rewrite (natmultassoc x t s); rewrite (natmultassoc x (t * s) u); rewrite (nat_mult_perm102 t s u); rewrite <- (natmultassoc x (s * t) u); rewrite <- (natmultassoc x s t); idtac | context[?x * t * u * s] => rewrite (natmultassoc x t u); rewrite (natmultassoc x (t * u) s); rewrite (nat_mult_perm120 t u s); rewrite <- (natmultassoc x (s * t) u); rewrite <- (natmultassoc x s t); idtac | context[?x * u * s * t] => rewrite (natmultassoc x u s); rewrite (natmultassoc x (u * s) t); rewrite (nat_mult_perm201 u s t); rewrite <- (natmultassoc x (s * t) u); rewrite <- (natmultassoc x s t); idtac | context[?x * u * t * s] => rewrite (natmultassoc x u t); rewrite (natmultassoc x (u * t) s); rewrite (nat_mult_perm210 u t s); rewrite <- (natmultassoc x (s * t) u); rewrite <- (natmultassoc x s t); idtac | context[?x * s * u * t] => rewrite (natmultassoc x s u); rewrite (natmultassoc x (s * u) t); rewrite (nat_mult_perm021 s u t); rewrite <- (natmultassoc x (s * t) u); rewrite <- (natmultassoc x s t); idtac end end. (** ** Tactics for grouping pairs of terms appearing in words written in [+] and [*].*) (** *** Helper tactics (which should not be considered as part of the public interface for these tactics).*) Ltac nat_plus_not_word s := match s with | ?x + ?y => fail 1 | _ => idtac end. Ltac nat_plus_not_at_front t s := match t with | s => fail 1 | context[s + ?x] => fail 1 | _ => idtac end. Ltac nat_plus_not_at_back t s := match t with | s => fail 1 "A" | ?x + s => fail 1 "B" | _ => idtac end. Ltac nat_plus_move_to_back s := repeat let lhs := get_current_lhs in nat_plus_not_at_back lhs s; match lhs with | s + ?x => rewrite (natpluscomm s x) | context[?x + s + ?y] => rewrite (nat_plus_perm021 x s y) | context[s + ?x + ?y] => rewrite (nat_plus_perm201 s x y) end. Ltac nat_plus_move_to_back_in H s := repeat let lhs := get_current_lhs_in H in nat_plus_not_at_back lhs s; match lhs with | s + ?x => rewrite (natpluscomm s x) in H | context[?x + s + ?y] => rewrite (nat_plus_perm021 x s y) in H | context[s + ?x + ?y] => rewrite (nat_plus_perm201 s x y) in H end. Ltac nat_plus_move_to_front s := repeat let lhs := get_current_lhs in nat_plus_not_at_front lhs s; match lhs with | context[?x + s] => nat_plus_not_word x; rewrite (natpluscomm x s) | context[?x + ?y + s] => nat_plus_not_word y; rewrite (nat_plus_perm021 x y s) end. Ltac nat_plus_move_to_front_in H s := repeat let lhs := get_current_lhs_in H in nat_plus_not_at_front lhs s; match lhs with | context[?x + s] => nat_plus_not_word x; rewrite (natpluscomm x s) in H | context[?x + ?y + s] => nat_plus_not_word y; rewrite (nat_plus_perm021 x y s) in H end. Ltac nat_plus_move_to_front_goal s := repeat let rhs := get_current_rhs in nat_plus_not_at_front rhs s; match rhs with | context[?x + s] => nat_plus_not_word x; rewrite (natpluscomm x s) | context[?x + ?y + s] => nat_plus_not_word y; rewrite (nat_plus_perm021 x y s) end. Ltac nat_plus_move_to_front_both_in H s := repeat let rhs := get_current_rhs_in H in nat_plus_not_at_front rhs s; match rhs with | context[?x + s] => nat_plus_not_word x; rewrite (natpluscomm x s) in H | context[?x + ?y + s] => nat_plus_not_word y; rewrite (nat_plus_perm021 x y s) in H end. Ltac nat_plus_move_to_back_goal s := repeat let rhs := get_current_rhs in nat_plus_not_at_back rhs s; match rhs with | context [s + ?x] => rewrite (natpluscomm s x) | context[?x + s + ?y] => nat_plus_not_word y; rewrite (nat_plus_perm021 x s y) | context[s + ?x + ?y] => nat_plus_not_word x; nat_plus_not_word y; rewrite (nat_plus_perm201 s x y) end. Ltac nat_plus_move_to_back_both_in H s := repeat let rhs := get_current_rhs_in H in nat_plus_not_at_back rhs s; match rhs with | context [s + ?x] => rewrite (natpluscomm s x) | context[?x + s + ?y] => nat_plus_not_word y; rewrite (nat_plus_perm021 x s y) in H | context[s + ?x + ?y] => nat_plus_not_word x; nat_plus_not_word y; rewrite (nat_plus_perm201 s x y) in H end. Ltac nat_mult_not_word s := match s with | ?x * ?y => fail 1 | _ => idtac end. Ltac nat_mult_not_at_front t s := match t with | s => fail 1 | context[s * ?x] => fail 1 | _ => idtac end. Ltac nat_mult_not_at_back t s := match t with | s => fail 1 "A" | ?x * s => fail 1 "B" | _ => idtac end. Ltac nat_mult_move_to_back s := repeat let lhs := get_current_lhs in nat_mult_not_at_back lhs s; match lhs with | s * ?x => rewrite (natmultcomm s x) | context[?x * s * ?y] => rewrite (nat_mult_perm021 x s y) | context[s * ?x * ?y] => rewrite (nat_mult_perm201 s x y) end. Ltac nat_mult_move_to_back_in H s := repeat let lhs := get_current_lhs_in H in nat_mult_not_at_back lhs s; match lhs with | s * ?x => rewrite (natmultcomm s x) in H | context[?x * s * ?y] => rewrite (nat_mult_perm021 x s y) in H | context[s * ?x * ?y] => rewrite (nat_mult_perm201 s x y) in H end. Ltac nat_mult_move_to_front s := repeat let lhs := get_current_lhs in nat_mult_not_at_front lhs s; match lhs with | context[?x * s] => nat_mult_not_word x; rewrite (natmultcomm x s) | context[?x * ?y * s] => nat_mult_not_word y; rewrite (nat_mult_perm021 x y s) end. Ltac nat_mult_move_to_front_in H s := repeat let lhs := get_current_lhs_in H in nat_mult_not_at_front lhs s; match lhs with | context[?x * s] => nat_mult_not_word x; rewrite (natmultcomm x s) in H | context[?x * ?y * s] => nat_mult_not_word y; rewrite (nat_mult_perm021 x y s) in H end. Ltac nat_mult_move_to_front_goal s := repeat let rhs := get_current_rhs in nat_mult_not_at_front rhs s; match rhs with | context[?x * s] => nat_mult_not_word x; rewrite (natmultcomm x s) | context[?x * ?y * s] => nat_mult_not_word y; rewrite (nat_mult_perm021 x y s) end. Ltac nat_mult_move_to_front_both_in H s := repeat let rhs := get_current_rhs_in H in nat_mult_not_at_front rhs s; match rhs with | context[?x * s] => nat_mult_not_word x; rewrite (natmultcomm x s) in H | context[?x * ?y * s] => nat_mult_not_word y; rewrite (nat_mult_perm021 x y s) in H end. Ltac nat_mult_move_to_back_goal s := repeat let rhs := get_current_rhs in nat_mult_not_at_back rhs s; match rhs with | context [s * ?x] => rewrite (natmultcomm s x) | context[?x * s * ?y] => nat_mult_not_word y; rewrite (nat_mult_perm021 x s y) | context[s * ?x * ?y] => nat_mult_not_word x; nat_mult_not_word y; rewrite (nat_mult_perm201 s x y) end. Ltac nat_mult_move_to_back_both_in H s := repeat let rhs := get_current_rhs_in H in nat_mult_not_at_back rhs s; match rhs with | context [s * ?x] => rewrite (natmultcomm s x) | context[?x * s * ?y] => nat_mult_not_word y; rewrite (nat_mult_perm021 x s y) in H | context[s * ?x * ?y] => nat_mult_not_word x; nat_mult_not_word y; rewrite (nat_mult_perm201 s x y) in H end. (** *** The tactics.*) (** We employ the following naming conventions. By default a tactics given pertain only to equations and operate by default on the left-hand side of equations. Those that operate on both left- and right-hand sides of the goal are suffixed with [_goal]. Tactics that operate on the left-hand side of equations occurring as hypotheses are suffixed with [_in]. Those that operate on both left- and right-hand sides of equations occurring as hypotheses are suffixed with [_both_in]. Those that opexrate on all sides of goals and hypotheses are suffixeD with [_all].*) Ltac nat_plus_group s t := nat_plus_move_to_front t; nat_plus_move_to_front s. Ltac nat_plus_group_goal s t := nat_plus_move_to_front_goal t; nat_plus_move_to_front_goal s. Ltac nat_plus_group_in H s t := nat_plus_move_to_front_in H t; nat_plus_move_to_front_in H s. Ltac nat_plus_group_both_in H s t := nat_plus_move_to_front_both_in H t; nat_plus_move_to_front_both_in H s. Ltac nat_plus_group_all s t := nat_plus_group_goal s t; repeat match goal with | H : _ |- _ => nat_plus_group_both_in H s t end. (** [t] is a term of type [nat] and [nat_plus_group_as] attempts to reorganize the [lhs] of the [goal] to include as a subterm [t].*) Ltac nat_plus_group_as t := match t with | ?x + ?y => nat_plus_not_word y; nat_plus_move_to_front y; nat_plus_group_as x | ?x => nat_plus_not_word x; nat_plus_move_to_front x end. (** t is a term of type x = y for x, y : nat and nat_plus_group_from attempts to reogranize the lhs of the goal to include as a subterm x.*) Ltac nat_plus_group_from t := let T := type of t in match T with | ?lhs = ?rhs => nat_plus_group_as lhs end. Ltac nat_mult_group s t := nat_mult_move_to_front t; nat_mult_move_to_front s. Ltac nat_mult_group_goal s t := nat_mult_move_to_front_goal t; nat_mult_move_to_front_goal s. Ltac nat_mult_group_in H s t := nat_mult_move_to_front_in H t; nat_mult_move_to_front_in H s. Ltac nat_mult_group_both_in H s t := nat_mult_move_to_front_both_in H t; nat_mult_move_to_front_both_in H s. Ltac nat_mult_group_all s t := nat_mult_group_goal s t; repeat match goal with | H : _ |- _ => nat_mult_group_both_in H s t end. (** [t] is a term of type [nat] and [nat_mult_group_as] attempts to reorganize the [lhs] of the [goal] to include as a subterm [t].*) Ltac nat_mult_group_as t := match t with | ?x + ?y => nat_mult_not_word y; nat_mult_move_to_front y; nat_mult_group_as x | ?x => nat_mult_not_word x; nat_mult_move_to_front x end. (** [t] is a term of type [x = y] for [x y : nat] and [nat_mult_group_from] attempts to reogranize the [lhs] of the [goal] to include as a subterm [x].*) Ltac nat_mult_group_from t := let T := type of t in match T with | ?lhs = ?rhs => nat_mult_group_as lhs end. (** * Tactics pertaining to inequalities.*) (** ** Preprocessing of the ambient goal and hypotheses.*) (** *** Helper tactics (which should not be considered as part of the public interface for these tactics).*) Ltac does_not_have_gth x y := match goal with | _ : hProptoType (x > y) |- _ => fail 1 | |- _ => idtac end. Ltac does_not_have_geh x y := match goal with | _ : hProptoType (x >= y) |- _ => fail 1 | |- _ => idtac end. (** It is convenient to have to only work with either [hzgth]/[hzgeh] or [hzlth]/[hzleh]. We choose the former and the following tactics replace instances of [hzlth]/[hzleh] with the corresponding inequalities involving [hzgth]/[hzgeh].*) Ltac reverse_lth := repeat match goal with | H : hProptoType (?y < ?u) |- _ => does_not_have_gth u y; assert (natgth u y); [apply H | ] end. Ltac reverse_leh := repeat match goal with | H : hProptoType (?y <= ?u) |- _ => does_not_have_geh u y; assert (natgeh u y); [apply H | ] end. Ltac gth_to_geh := repeat match goal with | H : hProptoType (?x > ?y) |- _ => does_not_have_geh x y; assert (natgeh x y); [apply natgthtogeh; assumption |] end. (** Clean the hypotheses in preparation for searching.*) Ltac nat_dfs_clean := reverse_lth; reverse_leh; gth_to_geh. (** ** Tactics for solving inequalities involving natural numbers.*) (** *** Tactics for solving very simple inequalities using known lemmas.*) (** The following tactic allows immediate solution of common goals involving [natgth] provided that the appropriate hypotheses are available. We probably want to eventually add additional "hints" here.*) Ltac natgth_simple := match goal with | _ : hProptoType (?x > ?y) |- hProptoType (?x > ?y) => assumption | P : hProptoType ((S ?x) > (S ?y)) |- hProptoType (?x > ?y) => apply P | |- hProptoType ((S ?x) > ?x) => apply (natgthsnn x) | |- hProptoType ((S ?x) > 0) => apply (natgthsn0 x) | P : hProptoType (?x > ?y) |- hProptoType ((S ?x) > (S ?y)) => apply P | P : hProptoType (?x ≠ 0)%nat |- hProptoType (?x > 0) => apply (natneq0togth0 x P) | P : hProptoType (0 ≠ ?x)%nat |- hProptoType (?x > 0) => apply (natneq0togth0 x (natneqtwist x P)) | P : (?x = 0) -> empty |- hProptoType (?x > 0) => apply (natneq0togth0 x P) | P : (0 = ?x) -> empty |- hProptoType (?x > 0) => apply (natneq0togth0 x (natneqtwist x P)) | |- hProptoType ((S ?x) > ?x) => apply (natgthsnn x) | P : hProptoType (?x > ?y) |- hProptoType ((S ?x) > ?y) => apply (natgthtogths x y P) | P : hProptoType (?x >= ?y) |- hProptoType ((S ?x) > ?y) => apply (natgehtogthsn x y P) | P : hProptoType (?x > ?y), Q : hProptoType (?y > ?z) |- hProptoType (?x > ?z) => apply (istransnatgth x y z P Q) | P : hProptoType (?x > ?y), Q : hProptoType (?y >= ?z) |- hProptoType (?x > ?z) => apply (natgthgehtrans x y z P Q) | P : hProptoType (?x >= ?y), Q : hProptoType (?y > ?z) |- hProptoType (?x > ?z) => apply (natgehgthtrans x y z P Q) end. Ltac natgeh_simple := match goal with | _ : hProptoType (?x >= ?y) |- hProptoType (?x >= ?y) => assumption | P : hProptoType (?x >= ?y) |- hProptoType ((S ?x) >= (S ?y)) => apply P | P : hProptoType ((S ?x) >= (S ?y)) |- hProptoType (?x >= ?y) => apply P | |- hProptoType (?x >= ?x) => apply isreflnatgeh | |- hProptoType (?x >= 0) => apply natgehn0 | |- hProptoType ((S ?x) >= ?x) => apply (natgehsnn x) | |- hProptoType (?x >= ?x - ?y) => apply (minusgeh x y) | H : hProptoType (?x > ?y) |- hProptoType (?x >= ?y) => apply (natgthtogeh x y H) | P : hProptoType (?x >= ?y), Q : hProptoType (?y >= ?z) |- hProptoType (?x >= ?z) => apply (istransnatgeh x y z P Q) | P : hProptoType ((S ?x) > ?y) |- hProptoType (?x >= ?y) => apply (natgthsntogeh x y P) end. (** *** General tactics for solving inequalities by depth-first search.*) (** The approach taken here for solving inequalities is to construct from the given collection of hypotheses HH a corresponding directed graph and then to perform a depth-first search of the graph.*) (** Although we will often employ our search method in order to traverse an acyclic graph, when we are proving that the hypotheses imply [empty] we are forced to consider the cyclic case. In these cases it may be possible to become trapped in a cycle. To prevent this from happening we must build helper functions that will allow us to check that the next goal we move to is not one we have previously considered.*) Ltac make_gth_check x y := let f T := match T with | hProptoType (x > y) => fail 1 | _ => idtac end in f. Ltac make_geh_check x y := let f T := match T with | hProptoType (x >= y) => fail 1 | _ => idtac end in f. (** Perform depth first search of the graph corresponding to the hypotheses. In standard continuation passing style we allow a helper ltac function [f] which is admitted to perform certain checks (or which can be ignored as in nat_dfs below).*) (** TODO: Try instead change. Think about strengthening clauses.*) Ltac nat_dfs_body f := natgth_simple || natgeh_simple || match goal with | |- hProptoType (?x < ?y) => let X := fresh "X" in assert (natgth y x) as X; [nat_dfs_body f | apply X] | |- hProptoType (?x <= ?y) => let X := fresh "X" in assert (natgeh y x) as X; [nat_dfs_body f | apply X] | _ : hProptoType (?u > ?y) |- hProptoType (?x > ?y) => f (hProptoType (x >= u)); let g := make_geh_check x u in let h := check_cons g f in apply (natgehgthtrans x u y); [nat_dfs_body h | assumption] | |- hProptoType (?x >= ?y) => f (hProptoType(x >= y)); let g := make_geh_check x y in let h := check_cons g f in apply (natgthtogeh x y); nat_dfs_body h | _ : hProptoType (?u >= ?y) |- hProptoType (?x >= ?y) => f (hProptoType (x >= u)); let g := make_geh_check x u in let h := check_cons g f in apply (istransnatgeh x u y); [nat_dfs_body h | assumption] | _ : hProptoType (?x >= ?u) |- hProptoType (?x > ?y) => f (hProptoType (u > y)); let g := make_gth_check u y in let h := check_cons g f in apply (natgehgthtrans x u y); [assumption | nat_dfs_body h] | _ : hProptoType (?u >= ?y) |- hProptoType (?x > ?y) => f (hProptoType (x > u)); let g := make_gth_check x u in let h := check_cons g f in apply (natgthgehtrans x u y); [nat_dfs_body h | assumption] | |- hProptoType (?x >= S ?y) => apply natgthtogehsn; nat_dfs_body f | |- hProptoType ((S ?x) > ?y) => let g := make_geh_check x y in let h := check_cons g f in (apply (natgthgehtrans _ x _); [apply natlthnsn | nat_dfs_body h]) | |- hProptoType (?x > ?y - ?z) => let g := make_gth_check x (y - z) in let h := check_cons g f in apply (natgthgehtrans x y (y - z)); [nat_dfs_body h | apply minusgeh] end. Ltac nat_dfs := nat_dfs_clean; nat_dfs_body id_check. (** * Tactics for deriving contradictions.*) Ltac nat_eq_contr := let f X := assert empty; [apply X; assumption | contradiction] in let i X := assert empty; [apply X; apply idpath | contradiction] in match goal with | H : ?x = ?y -> empty, _ : ?x = ?y |- _ => f H | H : neg (?x = ?y), _ : ?x = ?y |- _ => f H | H : ?x = ?x -> empty |- _ => i H | H : neg (?x = ?x) |- _ => i H | H : hProptoType (?x ≠ ?y)%nat, _ : ?x = ?y |- _ => f H | H : hProptoType (?x ≠ ?x)%nat |- _ => i H | H : hProptoType (?x ≠ ?y)%nat, _ : ?x = ?y |- _ => f H | H : hProptoType (?x ≠ ?x)%nat |- _ => i H end. Ltac nat_simple_contr := assert empty; [ match goal with | H : hProptoType (?x < 0) |- _ => exact (negnatlthn0 x H) | H : hProptoType (0 > ?x) |- _ => exact (negnatgth0n x H) | H : hProptoType ((S ?x) <= 0) |- _ => exact (negnatlehsn0 x H) | H : hProptoType (0 >= (S ?x)) |- _ => exact (negnatgeh0sn x H) | H : S ?x = 0 |- _ => exact (negpathssx0 x H) end | contradiction]. (** Note that the following tactic may not halt. SHOULD halt now.*) Ltac nat_ineq_contr_isirrefl := nat_dfs_clean; assert empty; [ match goal with | _ : hProptoType (?x > ?x) |- _ => apply (isirreflnatgth x); assumption | N : nat |- _ => let f := make_gth_check N N in apply (isirreflnatgth N); nat_dfs_body ltac:(f) end | contradiction]. Ltac nat_absurd := (nat_simple_contr || nat_eq_contr || nat_ineq_contr_isirrefl). Ltac nat_preclean_1 := repeat match goal with | |- context [0 - ?n] => change (0 - n) with 0 | |- context [(S ?n) - 1] => change ((S n) - 1) with (n - 0) | |- context[S ?x - S ?y] => change (S x - S y) with (x - y) end. Ltac nat_preclean_2 := repeat rewrite multsnm; repeat rewrite multnsm; repeat rewrite natldistr; repeat rewrite natrdistr; repeat rewrite natmultn0; repeat rewrite natmult0n; repeat rewrite natplusl0; repeat rewrite natplusr0; repeat rewrite natminuseqn; repeat rewrite natmultl1; repeat rewrite natmultr1; repeat rewrite <- natplusassoc; repeat rewrite <- natmultassoc; repeat rewrite minus0r; repeat rewrite minusnn0. Ltac nat_clean := nat_preclean_1; nat_preclean_2. Ltac nat_preclean_1_in H := repeat let T := type of H in match T with | context [0 - ?n] => change (0 - n) with 0 in H | context [(S ?n) - 1] => change ((S n) - 1) with (n - 0) in H | context[S ?x - S ?y] => change (S x - S y) with (x - y) in H end. Ltac nat_preclean_2_in H := repeat rewrite multsnm in H; repeat rewrite multnsm in H; repeat rewrite natldistr in H; repeat rewrite natrdistr in H; repeat rewrite natmultn0 in H; repeat rewrite natmult0n in H; repeat rewrite natplusl0 in H; repeat rewrite natplusr0 in H; repeat rewrite natminuseqn in H; repeat rewrite natmultl1 in H; repeat rewrite natmultr1 in H; repeat rewrite <- natplusassoc in H; repeat rewrite <- natmultassoc in H; repeat rewrite minus0r in H; repeat rewrite minusnn0 in H. Ltac nat_clean_in H := nat_preclean_1_in H; nat_preclean_2_in H. Ltac nat_clean_all := nat_clean; repeat match goal with | H : _ |- _ => nat_clean_in H end. (** * Several somewhat devious experimental tactics.*) Ltac nat_devious_ineq := match goal with | |- hProptoType (?x > ?y) => destruct (natgthorleh x y); [assumption | nat_absurd] | |- hProptoType (?x >= ?y) => destruct (natlthorgeh x y); [nat_absurd | assumption] | |- hProptoType (?x < ?y) => destruct (natlthorgeh x y); [assumption | nat_absurd] | |- hProptoType (?x <= ?y) => destruct (natgthorleh x y); [nat_absurd | assumption] end. (** * Tactics for solving equations.*) (** ** Helper tactics.*) Ltac make_check T := let f S := match S with | T => fail 1 end in f. Ltac nat_plus_strip := match goal with | |- ?lhs = ?rhs => match lhs with | context [?x] => match rhs with | context [x] => nat_plus_move_to_back_goal x; apply (ap (λ v, v + x)) end end end. Ltac nat_mult_strip := match goal with | |- ?lhs = ?rhs => match lhs with | context [?x] => match rhs with | context [x] => nat_mult_move_to_back_goal x; apply (ap (λ v, v * x)) end end end. (** ** Some simple solver tactics which are concerned exclusively with equations involving _only_ [+] or _only_ [*].*) Ltac nat_plus_prezap_body f := match goal with | |- ?lhs = ?rhs => match lhs with | rhs => apply idpath | 0 => apply pathsinv0; nat_plus_prezap_body f | ?x + ?y => match rhs with | y + x => apply (natpluscomm x y) end | _ => (nat_plus_strip; nat_plus_prezap_body f) end | E : ?l = ?r |- ?lhs = ?rhs => f E; let g := make_hyp_check E in let h := check_cons g f in nat_plus_group_from E; matched_rewrite E; nat_plus_prezap_body h end. Ltac nat_plus_prezap := nat_clean_all; nat_plus_prezap_body id_check. Ltac nat_mult_prezap_body f := match goal with | |- ?lhs = ?rhs => match lhs with | rhs => apply idpath | 0 => apply pathsinv0; nat_mult_prezap_body f | ?x * ?y => match rhs with | y * x => apply (natmultcomm x y) end | _ => (nat_mult_strip; nat_mult_prezap_body f) end | E : ?l = ?r |- ?lhs = ?rhs => f E; let g := make_hyp_check E in let h := check_cons g f in nat_mult_group_from E; matched_rewrite E; nat_mult_prezap_body h end. Ltac nat_mult_prezap := nat_clean_all; nat_mult_prezap_body id_check. (** ** A simple solver tactic for mixed [+] [*] equations.*) Ltac nat_plus_zap_body f := match goal with | |- ?lhs = ?rhs => match rhs with | ?x + ?y => nat_plus_not_word y; match lhs with | ?u + ?v => (nat_plus_not_word v; let F := fresh in assert (v = y) as F; [ nat_mult_prezap | rewrite F; apply (ap (λ v, v + y)); nat_plus_zap_body f ]) || (let l := get_current_lhs in let g := make_check l in let h := check_cons f g in nat_plus_move_to_front v; nat_plus_zap_body h) end | ?x => nat_plus_not_word x; match lhs with | ?v => nat_plus_not_word v; nat_mult_prezap end end end. Ltac nat_plus_zap := nat_plus_zap_body id_check. (** * Combined tactics for solving equations and inequalities of natural numbers.*) Ltac nat_simple := match goal with | H : hProptoType (?n <= 0) |- ?n = 0 => apply (natleh0tois0 n H) | H : hProptoType (0 >= ?n) |- ?n = 0 => apply (nat0gehtois0 n H) | H : hProptoType (?n <= 0) |- 0 = ?n => apply pathsinv0; apply (natleh0tois0 n H) | H : hProptoType (0 >= ?n) |- 0 = ?n => apply pathsinv0; apply (nat0gehtois0 n H) | |- ?x + ?y = ?y + ?x => apply natpluscomm end. Ltac nat_intros := repeat match goal with | |- ?x -> ?y => intro | |- ∏ _, _ => intro end. Ltac nat_try := repeat match goal with | H : _ |- _ => let T := type of H in match T with | nat => fail 1 | _ => idtac "About to try " H; apply H end end. Ltac nat_basic_destruct N := destruct N; nat_intros; nat_clean; (auto || assumption || nat_simple || nat_absurd || nat_dfs ). Ltac nat_basic_induction N := induction N; nat_intros; nat_clean; (auto || assumption || nat_simple || nat_absurd || nat_dfs || nat_try ). Ltac nat_zap := nat_clean_all; try (auto || assumption || nat_simple || nat_absurd || nat_dfs || nat_plus_zap || nat_try); match goal with | N : nat |- _ => nat_basic_destruct N || nat_basic_induction N end. Close Scope nat_scope. (** * TESTS *) (* Unset Ltac Debug. Section Tests. Open Scope nat_scope. Hypothesis x y z u v w x' y' z' u' v' w' : nat. (** Note that [nat_devious_ineq] also correctly solves all of the tests designed for [nat_dfs].*) Lemma test_nat_dfs_0 (i1 : natgth x y) (i2 : natgeh y z) (i3 : natgth z u) (i4 : natgeh u v) (i5 : natgeh v w) : natgth x w. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_1 (i1 : natgth x y) (i2 : natgth y z) (i3 : natlth u z) (i4 : natgth w u) (i5 : natgth z x') : natgth x x'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_2 (i1 : natgth x y) (i2 : natlth z y) (i3 : natgth u z) : natgth x z. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_3 (i1 : natgth x y) (i2 : natlth z y) (i3 : natlth z u) : natgth x z. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_4 (i1 : natgth x y) (i2 : natgth y z) (i3 : natlth z u) (i4 : natlth v z) (i5 : natgth v x') (i6 : natlth v w) (i7 : natlth z' x') (i8 : natlth u' z') (i9 : natgth u y') : natgth x u'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_5 (i1 : natlth x y) (i2 : natlth y z) (i3 : natgth z u) (i4 : natgth v z) (i5 : natlth v x') (i6 : natgth v w) (i7 : natgth z' x') (i8 : natgth u' z') (i9 : natlth u y') : natlth x u'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_6 (i1 : natgeh x y) (i2 : natgth y z) (i3 : natleh z u) (i4 : natlth v z) (i5 : natgth v x') (i6 : natleh v w) (i7 : natlth z' x') (i8 : natlth u' z') (i9 : natgeh u y') : natgeh x u'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_7 (i1 : natleh x y) (i2 : natlth y z) (i3 : natgeh z u) (i4 : natgth v z) (i5 : natlth v x') (i6 : natgeh v w) (i7 : natgth z' x') (i8 : natgth u' z') (i9 : natleh u y') : natleh x u'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_8 (i1 : natleh x y) (i2 : natlth y z) (i3 : natgeh z u) (i4 : natgth v z) (i5 : natlth v x') (i6 : natgeh v w) (i7 : natgth z' x') (i8 : natgth u' z') (i9 : natleh u y') : natleh x u'. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_10 (i1 : x ≠ 0)%nat (i2 : natgeh x 0) : natgth x 0. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_11 (i2 : 0 ≠ x)%nat (i2 : natgeh x 0) : natgth x 0. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_12 (i1 : 0 = x -> empty) (i2 : natgeh x 0) : natgth x 0. Proof. intros. nat_dfs. Qed. Lemma test_nat_dfs_13 (i : natleh y x) (l : natgth y x) : natlth x x. Proof. intros. nat_dfs. Qed. Lemma test_nat_absurd_1 (i : natleh x y) (j : natgth x (S z)) (k : natleh y z) : natgth u v. Proof. intros. nat_absurd. Qed. Lemma test_nat_absurd_2 (i : natlth x y) (j : natgeh x (S z)) (k : natlth y z) : natgth u v. Proof. intros. nat_absurd. Qed. Lemma test_nat_absurd_3 x y z u v w (i1 : natgth x y) (i2 : natgeh y z) (i3 : natgth z u) (i4 : natgeh u v) (i5 : natgeh v w) (i6 : natgeh w x) : natgth x w. Proof. intros. nat_absurd. Qed. Lemma test_nat_absurd_4 (i1 : natgth x y) (i2 : natlth z y) (i3 : natgth u z) (i4 : natleh x z ) : natgth x z. Proof. intros. nat_absurd. Qed. Lemma test_nat_plus_ternary_perm n m k l : n + m + k + l = l + m + n + k. Proof. intros. nat_plus_ternary_perm l m k. nat_plus_ternary_perm l m n. apply idpath. Qed. Lemma test_nat_mult_ternary_perm n m k l : n * m * k * l = k * l * n * m. Proof. intros. nat_mult_ternary_perm k n m. nat_mult_ternary_perm l n m. apply idpath. Qed. Lemma test_nat_plus_group n m k l : n + m + k + l = k + n + m + l. Proof. intros. nat_plus_group k n. apply idpath. Qed. Lemma test_nat_mult_group n m k l : n * m * k * l = k * n * m * l. Proof. intros. nat_mult_group k n. apply idpath. Qed. Close Scope nat_scope. End Tests. *) UniMath-20231010/UniMath/Tactics/Utilities.v000066400000000000000000000034771451125700300204230ustar00rootroot00000000000000(** Author: Michael A. Warren (maw@mawarren.net).*) (** Date: Spring 2015.*) (** Description: Some helper tactics.*) (** Imports *) Require Import UniMath.Foundations.PartD UniMath.Foundations.Propositions UniMath.Foundations.Sets. Arguments tpair {_ _} _ _. (** We introduce the notation ap for maponpaths as in KTheory. *) Module Export Notation. Notation ap := maponpaths. Notation "p # x" := (transportf _ p x) (right associativity, at level 65) : transport. Open Scope transport. Notation "{ x : X & P }" := (total2 (λ x:X, P)) : type_scope. Notation "X ** Y" := (X × Y) (right associativity, at level 80) : type_scope. End Notation. Definition neq (X : UU) : X -> X -> hProp := λ x y : X, make_hProp (x != y) (isapropneg (x = y)). Ltac check_cons f g := let h T := f T; g T in h. Ltac id_check T := idtac. Ltac make_hyp_check e := let T0 := type of e in let f T := match T with | T0 => fail 1 | _ => idtac end in f. (** In some cases we may need to obtain the current left-hand side of a goal equation (it may have been rewritten since initially being passed in via a match clause and a subsequent match on the new state should be performed. E.g., in matched_rewrite below.*) Ltac get_current_lhs := match goal with | |- ?lhs = ?rhs => lhs end. Ltac get_current_rhs := match goal with | |- ?lhs = ?rhs => rhs end. Ltac get_current_lhs_in H := let T := type of H in match T with | ?lhs = ?rhs => lhs end. Ltac get_current_rhs_in H := let T := type of H in match T with | ?lhs = ?rhs => rhs end. Ltac matched_rewrite e := match type of e with | ?l = ?r => let lhs := get_current_lhs in match lhs with | context [l] => rewrite e | context [r] => rewrite <- e end end. UniMath-20231010/UniMath/Topology/000077500000000000000000000000001451125700300164705ustar00rootroot00000000000000UniMath-20231010/UniMath/Topology/.package/000077500000000000000000000000001451125700300201415ustar00rootroot00000000000000UniMath-20231010/UniMath/Topology/.package/files000066400000000000000000000000531451125700300211640ustar00rootroot00000000000000Prelim.v Filters.v Topology.v CategoryTop.vUniMath-20231010/UniMath/Topology/CategoryTop.v000066400000000000000000000024131451125700300211170ustar00rootroot00000000000000(** * Results about Topology *) (** Author: Catherine LELAY. Jan 2016 - *) (** Based on Bourbaky *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Tactics. Require Export UniMath.Topology.Filters. Require Import UniMath.Algebra.DivisionRig. Require Import UniMath.Algebra.ConstructiveStructures. Require Import UniMath.Topology.Topology. Require Import UniMath.CategoryTheory.Core.Categories. Require Import UniMath.CategoryTheory.categories.HSET.Core. Require Import UniMath.CategoryTheory.DisplayedCats.Core. (** * Displayed category of topological spaces *) Definition top_disp_cat_ob_mor : disp_cat_ob_mor hset_category. Proof. use make_disp_cat_ob_mor. - intro X. exact (isTopologicalSpace X). - intros X Y T U f. exact (@continuous (X,,T) (Y,,U) f). Defined. Definition top_disp_cat_data : disp_cat_data hset_category. Proof. exists top_disp_cat_ob_mor. split. - do 5 intro. assumption. - intros *. apply continuous_funcomp. Defined. Definition top_disp_cat_axioms : disp_cat_axioms hset_category top_disp_cat_data. Proof. do 3 (split ; intros ; try (apply proofirrelevance, isaprop_continuous)). apply isasetaprop, isaprop_continuous. Defined. Definition disp_top : disp_cat hset_category := _ ,, top_disp_cat_axioms. UniMath-20231010/UniMath/Topology/Filters.v000066400000000000000000001164011451125700300202720ustar00rootroot00000000000000(** * Results about Filters *) (** Author: Catherine LELAY. Jan 2016 - *) (** Based on Bourbaky *) Require Import UniMath.Foundations.Preamble. Require Import UniMath.MoreFoundations.Tactics. Require Export UniMath.Topology.Prelim. Require Import UniMath.MoreFoundations.PartA. (** ** Definition of a Filter *) Section Filter_def. Context {X : UU}. Context (F : (X → hProp) → hProp). Definition isfilter_imply := ∏ A B : X → hProp, (∏ x : X, A x → B x) → F A → F B. Lemma isaprop_isfilter_imply : isaprop isfilter_imply. Proof. apply impred_isaprop ; intro A. apply impred_isaprop ; intro B. apply isapropimpl. apply isapropimpl. apply propproperty. Qed. Definition isfilter_finite_intersection := ∏ (L : Sequence (X → hProp)), (∏ n, F (L n)) → F (finite_intersection L). Lemma isaprop_isfilter_finite_intersection : isaprop isfilter_finite_intersection. Proof. apply impred_isaprop ; intros L. apply isapropimpl. apply propproperty. Qed. Definition isfilter_htrue : hProp := F (λ _ : X, htrue). Definition isfilter_and := ∏ A B : X → hProp, F A → F B → F (λ x : X, A x ∧ B x). Lemma isaprop_isfilter_and : isaprop isfilter_and. Proof. apply impred_isaprop ; intro A. apply impred_isaprop ; intro B. apply isapropimpl. apply isapropimpl. apply propproperty. Qed. Definition isfilter_notempty := ∏ A : X → hProp, F A → ∃ x : X, A x. Lemma isaprop_isfilter_notempty : isaprop isfilter_notempty. Proof. apply impred_isaprop ; intro A. apply isapropimpl. apply propproperty. Qed. Lemma isfilter_finite_intersection_htrue : isfilter_finite_intersection → isfilter_htrue. Proof. intros Hand. unfold isfilter_htrue. rewrite <- finite_intersection_htrue. apply Hand. intros m. apply fromempty. generalize (pr2 m). now apply negnatlthn0. Qed. Lemma isfilter_finite_intersection_and : isfilter_finite_intersection → isfilter_and. Proof. intros Hand A B Fa Fb. rewrite <- finite_intersection_and. apply Hand. intros m. induction m as [m Hm]. induction m as [ | m _]. - exact Fa. - exact Fb. Qed. Lemma isfilter_finite_intersection_carac : isfilter_htrue → isfilter_and → isfilter_finite_intersection. Proof. intros Htrue Hand L. apply (pr2 (finite_intersection_hProp F)). split. - exact Htrue. - exact Hand. Qed. End Filter_def. Definition isPreFilter {X : UU} (F : (X → hProp) → hProp) := isfilter_imply F × isfilter_finite_intersection F. Definition PreFilter (X : UU) := ∑ (F : (X → hProp) → hProp), isPreFilter F. Definition make_PreFilter {X : UU} (F : (X → hProp) → hProp) (Himpl : isfilter_imply F) (Htrue : isfilter_htrue F) (Hand : isfilter_and F) : PreFilter X := F,, Himpl,, isfilter_finite_intersection_carac F Htrue Hand. Definition pr1PreFilter (X : UU) (F : PreFilter X) : (X → hProp) → hProp := pr1 F. Coercion pr1PreFilter : PreFilter >-> Funclass. Definition isFilter {X : UU} (F : (X → hProp) → hProp) := isPreFilter F × isfilter_notempty F. Definition Filter (X : UU) := ∑ F : (X → hProp) → hProp, isFilter F. Definition pr1Filter (X : UU) (F : Filter X) : PreFilter X := pr1 F,, pr1 (pr2 F). Coercion pr1Filter : Filter >-> PreFilter. Definition make_Filter {X : UU} (F : (X → hProp) → hProp) (Himp : isfilter_imply F) (Htrue : isfilter_htrue F) (Hand : isfilter_and F) (Hempty : isfilter_notempty F) : Filter X := F ,, (Himp ,, (isfilter_finite_intersection_carac F Htrue Hand)) ,, Hempty. Lemma emptynofilter : ∏ F : (empty → hProp) → hProp, ¬ isFilter F. Proof. intros F Hf. generalize (isfilter_finite_intersection_htrue _ (pr2 (pr1 Hf))) ; intros Htrue. generalize (pr2 Hf _ Htrue). apply factor_through_squash. - apply isapropempty. - intros x. apply (pr1 x). Qed. Section PreFilter_pty. Context {X : UU}. Context (F : PreFilter X). Lemma filter_imply : isfilter_imply F. Proof. exact (pr1 (pr2 F)). Qed. Lemma filter_finite_intersection : isfilter_finite_intersection F. Proof. exact (pr2 (pr2 F)). Qed. Lemma filter_htrue : isfilter_htrue F. Proof. apply isfilter_finite_intersection_htrue. exact filter_finite_intersection. Qed. Lemma filter_and : isfilter_and F. Proof. apply isfilter_finite_intersection_and. exact filter_finite_intersection. Qed. Lemma filter_forall : ∏ A : X → hProp, (∏ x : X, A x) → F A. Proof. intros A Ha. generalize filter_htrue. apply filter_imply. intros x _. now apply Ha. Qed. End PreFilter_pty. Section Filter_pty. Context {X : UU}. Context (F : Filter X). Lemma filter_notempty : isfilter_notempty F. Proof. exact (pr2 (pr2 F)). Qed. Lemma filter_const : ∏ A : hProp, F (λ _ : X, A) → ¬ (¬ A). Proof. intros A Fa Ha. generalize (filter_notempty _ Fa). apply factor_through_squash. - apply isapropempty. - intros x ; generalize (pr2 x); clear x. exact Ha. Qed. End Filter_pty. Lemma isasetPreFilter (X : UU) : isaset (PreFilter X). Proof. simple refine (isaset_carrier_subset (make_hSet _ _) (λ _, make_hProp _ _)). - apply impred_isaset ; intros _. apply isasethProp. - apply isapropdirprod. + apply isaprop_isfilter_imply. + apply isaprop_isfilter_finite_intersection. Qed. Lemma isasetFilter (X : UU) : isaset (Filter X). Proof. simple refine (isaset_carrier_subset (make_hSet _ _) (λ _, make_hProp _ _)). - apply impred_isaset ; intros _. apply isasethProp. - apply isapropdirprod. + apply isapropdirprod. * apply isaprop_isfilter_imply. * apply isaprop_isfilter_finite_intersection. + apply isaprop_isfilter_notempty. Qed. (** *** Order on filters *) Definition filter_le {X : UU} (F G : PreFilter X) := ∏ A : X → hProp, G A → F A. Lemma istrans_filter_le {X : UU} : ∏ F G H : PreFilter X, filter_le F G → filter_le G H → filter_le F H. Proof. intros F G H Hfg Hgh A Fa. apply Hfg, Hgh, Fa. Qed. Lemma isrefl_filter_le {X : UU} : ∏ F : PreFilter X, filter_le F F. Proof. intros F A Fa. exact Fa. Qed. Lemma isantisymm_filter_le {X : UU} : ∏ F G : PreFilter X, filter_le F G → filter_le G F → F = G. Proof. intros F G Hle Hge. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). - apply isapropdirprod. + apply isaprop_isfilter_imply. + apply isaprop_isfilter_finite_intersection. - apply funextfun ; intros A. apply hPropUnivalence. + now apply Hge. + now apply Hle. Qed. Definition PartialOrder_filter_le (X : UU) : PartialOrder (make_hSet (PreFilter _) (isasetPreFilter X)). Proof. simple refine (make_PartialOrder _ _). - intros F G. simple refine (make_hProp _ _). + apply (filter_le F G). + apply impred_isaprop ; intros A. apply isapropimpl. apply propproperty. - repeat split. + intros F G H ; simpl. apply istrans_filter_le. + intros A ; simpl. apply isrefl_filter_le. + intros F G ; simpl. apply isantisymm_filter_le. Defined. (** *** Image of a filter *) Section filterim. Context {X Y : UU}. Context (f : X → Y) (F : (X → hProp) → hProp). Context (Himp : isfilter_imply F) (Htrue : isfilter_htrue F) (Hand : isfilter_and F) (Hempty : isfilter_notempty F). Definition filterim := λ A : (Y → hProp), F (λ x : X, A (f x)). Lemma filterim_imply : isfilter_imply filterim. Proof. intros A B H. apply Himp. intros x. apply H. Qed. Lemma filterim_htrue : isfilter_htrue filterim. Proof. apply Htrue. Qed. Lemma filterim_and : isfilter_and filterim. Proof. intros A B. apply Hand. Qed. Lemma filterim_notempty : isfilter_notempty filterim. Proof. intros A Fa. generalize (Hempty _ Fa). apply hinhfun. intros x. exists (f (pr1 x)). exact (pr2 x). Qed. End filterim. Definition PreFilterIm {X Y : UU} (f : X → Y) (F : PreFilter X) : PreFilter Y. Proof. simple refine (make_PreFilter _ _ _ _). - exact (filterim f F). - apply filterim_imply, filter_imply. - apply filterim_htrue, filter_htrue. - apply filterim_and, filter_and. Defined. Definition FilterIm {X Y : UU} (f : X → Y) (F : Filter X) : Filter Y. Proof. refine (tpair _ _ _). split. - apply (pr2 (PreFilterIm f F)). - apply filterim_notempty, filter_notempty. Defined. Lemma PreFilterIm_incr {X Y : UU} : ∏ (f : X → Y) (F G : PreFilter X), filter_le F G → filter_le (PreFilterIm f F) (PreFilterIm f G). Proof. intros f F G Hle A ; simpl. apply Hle. Qed. Lemma FilterIm_incr {X Y : UU} : ∏ (f : X → Y) (F G : Filter X), filter_le F G → filter_le (FilterIm f F) (FilterIm f G). Proof. intros f F G Hle A ; simpl. apply Hle. Qed. (** *** Limit: filter version *) Definition filterlim {X Y : UU} (f : X → Y) (F : PreFilter X) (G : PreFilter Y) := filter_le (PreFilterIm f F) G. Lemma filterlim_comp {X Y Z : UU} : ∏ (f : X → Y) (g : Y → Z) (F : PreFilter X) (G : PreFilter Y) (H : PreFilter Z), filterlim f F G → filterlim g G H → filterlim (funcomp f g) F H. Proof. intros f g F G H Hf Hg A Fa. specialize (Hg _ Fa). specialize (Hf _ Hg). apply Hf. Qed. Lemma filterlim_decr_1 {X Y : UU} : ∏ (f : X → Y) (F F' : PreFilter X) (G : PreFilter Y), filter_le F' F → filterlim f F G → filterlim f F' G. Proof. intros f F F' G Hf Hle A Ha. specialize (Hle _ Ha). specialize (Hf _ Hle). apply Hf. Qed. Lemma filterlim_incr_2 {X Y : UU} : ∏ (f : X → Y) (F : PreFilter X) (G G' : PreFilter Y), filter_le G G' → filterlim f F G → filterlim f F G'. Proof. intros f F G G' Hg Hle A Ha. specialize (Hg _ Ha). specialize (Hle _ Hg). exact Hle. Qed. (** ** Some usefull filters *) (** *** Filter on a domain *) Section filterdom. Context {X : UU}. Context (F : (X → hProp) → hProp) (Himp : isfilter_imply F) (Htrue : isfilter_htrue F) (Hand : isfilter_and F) (Hempty : isfilter_notempty F). Context (dom : X → hProp) (Hdom : ∏ P, F P → ∃ x, dom x ∧ P x). Definition filterdom : (X → hProp) → hProp := λ A : X → hProp, F (λ x : X, make_hProp (dom x → A x) (isapropimpl _ _ (propproperty _))). Lemma filterdom_imply : isfilter_imply filterdom. Proof. intros A B Himpl. apply Himp. intros x Ax Hx. apply Himpl, Ax, Hx. Qed. Lemma filterdom_htrue : isfilter_htrue filterdom. Proof. apply Himp with (2 := Htrue). intros x H _. exact H. Qed. Lemma filterdom_and : isfilter_and filterdom. Proof. intros A B Ha Hb. generalize (Hand _ _ Ha Hb). apply Himp. intros x ABx Hx. split. - apply (pr1 ABx), Hx. - apply (pr2 ABx), Hx. Qed. Lemma filterdom_notempty : isfilter_notempty filterdom. Proof. intros. intros A Fa. generalize (Hdom _ Fa). apply hinhfun. intros x. exists (pr1 x). apply (pr2 (pr2 x)), (pr1 (pr2 x)). Qed. End filterdom. Definition PreFilterDom {X : UU} (F : PreFilter X) (dom : X → hProp) : PreFilter X. Proof. simple refine (make_PreFilter _ _ _ _). - exact (filterdom F dom). - apply filterdom_imply, filter_imply. - apply filterdom_htrue. + apply filter_imply. + apply filter_htrue. - apply filterdom_and. + apply filter_imply. + apply filter_and. Defined. Definition FilterDom {X : UU} (F : Filter X) (dom : X → hProp) (Hdom : ∏ P, F P → ∃ x, dom x ∧ P x) : Filter X. Proof. refine (tpair _ _ _). split. - apply (pr2 (PreFilterDom F dom)). - apply filterdom_notempty. exact Hdom. Defined. (** *** Filter on a subtype *) Section filtersubtype. Context {X : UU}. Context (F : (X → hProp) → hProp) (Himp : isfilter_imply F) (Htrue : isfilter_htrue F) (Hand : isfilter_and F) (Hempty : isfilter_notempty F). Context (dom : X → hProp) (Hdom : ∏ P, F P → ∃ x, dom x ∧ P x). Definition filtersubtype : ((∑ x : X, dom x) → hProp) → hProp := λ A : (∑ x : X, dom x) → hProp, F (λ x : X, make_hProp (∏ Hx : dom x, A (x,, Hx)) (impred_isaprop _ (λ _, propproperty _))). Lemma filtersubtype_imply : isfilter_imply filtersubtype. Proof. intros A B Himpl. apply Himp. intros x Ax Hx. apply Himpl, Ax. Qed. Lemma filtersubtype_htrue : isfilter_htrue filtersubtype. Proof. apply Himp with (2 := Htrue). intros x H _. exact H. Qed. Lemma filtersubtype_and : isfilter_and filtersubtype. Proof. intros A B Ha Hb. generalize (Hand _ _ Ha Hb). apply Himp. intros x ABx Hx. split. - apply (pr1 ABx). - apply (pr2 ABx). Qed. Lemma filtersubtype_notempty : isfilter_notempty filtersubtype. Proof. intros A Fa. generalize (Hdom _ Fa). apply hinhfun. intros x. exists (pr1 x,,pr1 (pr2 x)). exact (pr2 (pr2 x) (pr1 (pr2 x))). Qed. End filtersubtype. Definition PreFilterSubtype {X : UU} (F : PreFilter X) (dom : X → hProp) : PreFilter (∑ x : X, dom x). Proof. simple refine (make_PreFilter _ _ _ _). - exact (filtersubtype F dom). - apply filtersubtype_imply, filter_imply. - apply filtersubtype_htrue. + apply filter_imply. + apply filter_htrue. - apply filtersubtype_and. + apply filter_imply. + apply filter_and. Defined. Definition FilterSubtype {X : UU} (F : Filter X) (dom : X → hProp) (Hdom : ∏ P, F P → ∃ x, dom x ∧ P x) : Filter (∑ x : X, dom x). Proof. refine (tpair _ _ _). split. - apply (pr2 (PreFilterSubtype F dom)). - apply filtersubtype_notempty. exact Hdom. Defined. (** *** Direct Product of filters *) Section filterdirprod. Context {X Y : UU}. Context (Fx : (X → hProp) → hProp) (Himp_x : isfilter_imply Fx) (Htrue_x : isfilter_htrue Fx) (Hand_x : isfilter_and Fx) (Hempty_x : isfilter_notempty Fx). Context (Fy : (Y → hProp) → hProp) (Himp_y : isfilter_imply Fy) (Htrue_y : isfilter_htrue Fy) (Hand_y : isfilter_and Fy) (Hempty_y : isfilter_notempty Fy). Definition filterdirprod : (X × Y → hProp) → hProp := λ A : (X × Y) → hProp, ∃ (Ax : X → hProp) (Ay : Y → hProp), Fx Ax × Fy Ay × (∏ (x : X) (y : Y), Ax x → Ay y → A (x,,y)). Lemma filterdirprod_imply : isfilter_imply filterdirprod. Proof. intros A B Himpl. apply hinhfun. intros C. generalize (pr1 C) (pr1 (pr2 C)) (pr1 (pr2 (pr2 C))) (pr1 (pr2 (pr2 (pr2 C)))) (pr2 (pr2 (pr2 (pr2 C)))) ; clear C ; intros Ax Ay Fax Fay Ha. exists Ax, Ay. repeat split. + exact Fax. + exact Fay. + intros x y Hx Hy. now apply Himpl, Ha. Qed. Lemma filterdirprod_htrue : isfilter_htrue filterdirprod. Proof. apply hinhpr. exists (λ _:X, htrue), (λ _:Y, htrue). repeat split. + apply Htrue_x. + apply Htrue_y. Qed. Lemma filterdirprod_and : isfilter_and filterdirprod. Proof. intros A B. apply hinhfun2. intros C D. generalize (pr1 C) (pr1 (pr2 C)) (pr1 (pr2 (pr2 C))) (pr1 (pr2 (pr2 (pr2 C)))) (pr2 (pr2 (pr2 (pr2 C)))) ; clear C ; intros Ax Ay Fax Fay Ha. generalize (pr1 D) (pr1 (pr2 D)) (pr1 (pr2 (pr2 D))) (pr1 (pr2 (pr2 (pr2 D)))) (pr2 (pr2 (pr2 (pr2 D)))) ; clear D ; intros Bx By Fbx Fby Hb. exists (λ x : X, Ax x ∧ Bx x), (λ y : Y, Ay y ∧ By y). repeat split. + now apply Hand_x. + now apply Hand_y. + apply Ha. * apply (pr1 X0). * apply (pr1 X1). + apply Hb. * apply (pr2 X0). * apply (pr2 X1). Qed. Lemma filterdirprod_notempty : isfilter_notempty filterdirprod. Proof. intros A. apply hinhuniv. intros C. generalize (pr1 C) (pr1 (pr2 C)) (pr1 (pr2 (pr2 C))) (pr1 (pr2 (pr2 (pr2 C)))) (pr2 (pr2 (pr2 (pr2 C)))) ; clear C ; intros Ax Ay Fax Fay Ha. generalize (Hempty_x _ Fax) (Hempty_y _ Fay). apply hinhfun2. intros x y. exists (pr1 x,,pr1 y). apply Ha. - exact (pr2 x). - exact (pr2 y). Qed. End filterdirprod. Definition PreFilterDirprod {X Y : UU} (Fx : PreFilter X) (Fy : PreFilter Y) : PreFilter (X × Y). Proof. simple refine (make_PreFilter _ _ _ _). - exact (filterdirprod Fx Fy). - apply filterdirprod_imply. - apply filterdirprod_htrue. + apply filter_htrue. + apply filter_htrue. - apply filterdirprod_and. + apply filter_and. + apply filter_and. Defined. Definition FilterDirprod {X Y : UU} (Fx : Filter X) (Fy : Filter Y) : Filter (X × Y). Proof. refine (tpair _ _ _). split. - apply (pr2 (PreFilterDirprod Fx Fy)). - apply filterdirprod_notempty. + apply filter_notempty. + apply filter_notempty. Defined. Definition PreFilterPr1 {X Y : UU} (F : PreFilter (X × Y)) : PreFilter X := (PreFilterIm pr1 F). Definition FilterPr1 {X Y : UU} (F : Filter (X × Y)) : Filter X := (FilterIm pr1 F). Definition PreFilterPr2 {X Y : UU} (F : PreFilter (X × Y)) : PreFilter Y := (PreFilterIm (@pr2 X (λ _ : X, Y)) F). Definition FilterPr2 {X Y : UU} (F : Filter (X × Y)) : Filter Y := (FilterIm (@pr2 X (λ _ : X, Y)) F). Goal ∏ {X Y : UU} (F : PreFilter (X × Y)), filter_le F (PreFilterDirprod (PreFilterPr1 F) (PreFilterPr2 F)). Proof. intros X Y F. intros A. apply hinhuniv. intros C ; generalize (pr1 C) (pr1 (pr2 C)) (pr1 (pr2 (pr2 C))) (pr1 (pr2 (pr2 (pr2 C)))) (pr2 (pr2 (pr2 (pr2 C)))) ; clear C ; intros Ax Ay Fax Fay Ha. simpl in *. generalize (filter_and _ _ _ Fax Fay). apply filter_imply. intros xy Fxy. apply Ha. - exact (pr1 Fxy). - exact (pr2 Fxy). Qed. Goal ∏ {X Y : UU} (F : PreFilter X) (G : PreFilter Y), filter_le (PreFilterPr1 (PreFilterDirprod F G)) F. Proof. intros X Y F G. intros A Fa. apply hinhpr. exists A, (λ _, htrue). repeat split. - exact Fa. - now apply filter_htrue. - intros. assumption. Qed. Goal ∏ {X Y : UU} (F : PreFilter X) (G : PreFilter Y), filter_le (PreFilterPr2 (PreFilterDirprod F G)) G. Proof. intros X Y F G. intros A Fa. apply hinhpr. exists (λ _, htrue), A. repeat split. - now apply filter_htrue. - exact Fa. - intros. assumption. Qed. (** ** Other filters *) (** *** Filter on nat *) Section filternat. Definition filternat : (nat → hProp) → hProp := λ P : nat → hProp, ∃ N : nat, ∏ n : nat, N ≤ n → P n. Lemma filternat_imply : isfilter_imply filternat. Proof. intros P Q H. apply hinhfun. intros N. exists (pr1 N). intros n Hn. now apply H, (pr2 N). Qed. Lemma filternat_htrue : isfilter_htrue filternat. Proof. apply hinhpr. now exists O. Qed. Lemma filternat_and : isfilter_and filternat. Proof. intros A B. apply hinhfun2. intros Na Nb. exists (max (pr1 Na) (pr1 Nb)). intros n Hn. split. + apply (pr2 Na). eapply istransnatleh, Hn. now apply max_le_l. + apply (pr2 Nb). eapply istransnatleh, Hn. now apply max_le_r. Qed. Lemma filternat_notempty : isfilter_notempty filternat. Proof. intros A. apply hinhfun. intros N. exists (pr1 N). apply (pr2 N (pr1 N)). now apply isreflnatleh. Qed. End filternat. Definition FilterNat : Filter nat. Proof. simple refine (make_Filter _ _ _ _ _). - apply filternat. - apply filternat_imply. - apply filternat_htrue. - apply filternat_and. - apply filternat_notempty. Defined. (** *** The upper filter *) Section filtertop. Context {X : UU} (x0 : ∥ X ∥). Definition filtertop : (X → hProp) → hProp := λ A : X → hProp, make_hProp (∏ x : X, A x) (impred_isaprop _ (λ _, propproperty _)). Lemma filtertop_imply : isfilter_imply filtertop. Proof. intros A B H Ha x. apply H. simple refine (Ha _). Qed. Lemma filtertop_htrue : isfilter_htrue filtertop. Proof. intros x. apply tt. Qed. Lemma filtertop_and : isfilter_and filtertop. Proof. intros A B Ha Hb x. split. + simple refine (Ha _). + simple refine (Hb _). Qed. Lemma filtertop_notempty : isfilter_notempty filtertop. Proof. intros A Fa. revert x0. apply hinhfun. intros x0. exists x0. simple refine (Fa _). Qed. End filtertop. Definition PreFilterTop {X : UU} : PreFilter X. Proof. simple refine (make_PreFilter _ _ _ _). - exact filtertop. - exact filtertop_imply. - exact filtertop_htrue. - exact filtertop_and. Defined. Definition FilterTop {X : UU} (x0 : ∥ X ∥) : Filter X. Proof. refine (tpair _ _ _). split. - apply (pr2 PreFilterTop). - apply filtertop_notempty, x0. Defined. Lemma PreFilterTop_correct {X : UU} : ∏ (F : PreFilter X), filter_le F PreFilterTop. Proof. intros F A Ha. apply filter_forall, Ha. Qed. Lemma FilterTop_correct {X : UU} : ∏ (x0 : ∥ X ∥) (F : Filter X), filter_le F (FilterTop x0). Proof. intros x0 F A Ha. apply PreFilterTop_correct, Ha. Qed. (** *** Intersection of filters *) Section filterintersection. Context {X : UU}. Context (is : ((X → hProp) → hProp) → UU). Context (FF : (∑ F : ((X → hProp) → hProp), is F) → hProp) (Himp : ∏ F, FF F → isfilter_imply (pr1 F)) (Htrue : ∏ F, FF F → isfilter_htrue (pr1 F)) (Hand : ∏ F, FF F → isfilter_and (pr1 F)) (Hempty : ∏ F, FF F → isfilter_notempty (pr1 F)). Context (His : ∃ F, FF F). Definition filterintersection : (X → hProp) → hProp := λ A : X → hProp, make_hProp (∏ F, FF F → (pr1 F) A) (impred_isaprop _ (λ _, isapropimpl _ _ (propproperty _))). Lemma filterintersection_imply : isfilter_imply filterintersection. Proof. intros A B H Ha F Hf. apply (Himp F Hf A). - apply H. - simple refine (Ha _ _). exact Hf. Qed. Lemma filterintersection_htrue : isfilter_htrue filterintersection. Proof. intros F Hf. now apply (Htrue F). Qed. Lemma filterintersection_and : isfilter_and filterintersection. Proof. intros A B Ha Hb F Hf. apply (Hand F Hf). * now simple refine (Ha _ _). * now simple refine (Hb _ _). Qed. Lemma filterintersection_notempty : isfilter_notempty filterintersection. Proof. intros A Fa. revert His. apply hinhuniv. intros F. apply (Hempty (pr1 F)). * exact (pr2 F). * simple refine (Fa _ _). exact (pr2 F). Qed. End filterintersection. Definition PreFilterIntersection {X : UU} (FF : PreFilter X → hProp) : PreFilter X. Proof. intros. simple refine (make_PreFilter _ _ _ _). - apply (filterintersection _ FF). - apply filterintersection_imply. intros F _. apply filter_imply. - apply filterintersection_htrue. intros F _. apply filter_htrue. - apply filterintersection_and. intros F _. apply filter_and. Defined. Definition FilterIntersection {X : UU} (FF : Filter X → hProp) (Hff : ∃ F : Filter X, FF F) : Filter X. Proof. simple refine (make_Filter _ _ _ _ _). - apply (filterintersection _ FF). - apply filterintersection_imply. intros F _. apply (filter_imply (pr1Filter _ F)). - apply filterintersection_htrue. intros F _. apply (filter_htrue (pr1Filter _ F)). - apply filterintersection_and. intros F _. apply (filter_and (pr1Filter _ F)). - apply filterintersection_notempty. + intros F _. apply (filter_notempty F). + exact Hff. Defined. Lemma PreFilterIntersection_glb {X : UU} (FF : PreFilter X → hProp) : (∏ F : PreFilter X, FF F → filter_le F (PreFilterIntersection FF)) × (∏ F : PreFilter X, (∏ G : PreFilter X, FF G → filter_le G F) → filter_le (PreFilterIntersection FF) F). Proof. split. - intros F Hf A Ha. now simple refine (Ha _ _). - intros F H A Fa G Hg. apply (H G Hg). apply Fa. Qed. Lemma FilterIntersection_glb {X : UU} (FF : Filter X → hProp) Hff : (∏ F : Filter X, FF F → filter_le F (FilterIntersection FF Hff)) × (∏ F : Filter X, (∏ G : Filter X, FF G → filter_le G F) → filter_le (FilterIntersection FF Hff) F). Proof. split. - intros F Hf A Ha. now simple refine (Ha _ _). - intros F H A Fa G Hg. apply (H G Hg). apply Fa. Qed. (** *** Filter generated by a set of subsets *) Section filtergenerated. Context {X : UU}. Context (L : (X → hProp) → hProp). Context (Hl : ∏ (L' : Sequence (X → hProp)), (∏ m, L (L' m)) → ∃ x : X, ∏ m, L' m x). Definition filtergenerated : (X → hProp) → hProp := λ A : X → hProp, ∃ (L' : Sequence (X → hProp)), (∏ m, L (L' m)) × (∏ x : X, finite_intersection L' x → A x). Lemma filtergenerated_imply : isfilter_imply filtergenerated. Proof. intros A B H. apply hinhfun ; intro Ha. exists (pr1 Ha), (pr1 (pr2 Ha)). intros x Hx. apply H. apply (pr2 (pr2 Ha)), Hx. Qed. Lemma filtergenerated_htrue : isfilter_htrue filtergenerated. Proof. apply hinhpr. exists nil. split. + intros m. induction (nopathsfalsetotrue (pr2 m)). + easy. Qed. Lemma filtergenerated_and : isfilter_and filtergenerated. Proof. intros A B. apply hinhfun2. intros Ha Hb. exists (concatenate (pr1 Ha) (pr1 Hb)). split. + simpl ; intros m. unfold concatenate'. set (Hm := (weqfromcoprodofstn_invmap (length (pr1 Ha)) (length (pr1 Hb))) m). change ((weqfromcoprodofstn_invmap (length (pr1 Ha)) (length (pr1 Hb))) m) with Hm. induction Hm as [Hm | Hm]. * rewrite coprod_rect_compute_1. apply (pr1 (pr2 Ha)). * rewrite coprod_rect_compute_2. apply (pr1 (pr2 Hb)). + intros x Hx. simpl in Hx. unfold concatenate' in Hx. split. * apply (pr2 (pr2 Ha)). intros m. specialize (Hx (weqfromcoprodofstn_map _ _ (ii1 m))). rewrite (weqfromcoprodofstn_eq1 _ _), coprod_rect_compute_1 in Hx. exact Hx. * apply (pr2 (pr2 Hb)). intros m. specialize (Hx (weqfromcoprodofstn_map _ _ (ii2 m))). rewrite (weqfromcoprodofstn_eq1 _ _), coprod_rect_compute_2 in Hx. exact Hx. Qed. Lemma filtergenerated_notempty : isfilter_notempty filtergenerated. Proof. intros A. apply hinhuniv. intros L'. generalize (Hl _ (pr1 (pr2 L'))). apply hinhfun. intros x. exists (pr1 x). apply (pr2 (pr2 L')). exact (pr2 x). Qed. End filtergenerated. Definition PreFilterGenerated {X : UU} (L : (X → hProp) → hProp) : PreFilter X. Proof. simple refine (make_PreFilter _ _ _ _). - apply (filtergenerated L). - apply filtergenerated_imply. - apply filtergenerated_htrue. - apply filtergenerated_and. Defined. Definition FilterGenerated {X : UU} (L : (X → hProp) → hProp) (Hl : ∏ L' : Sequence (X → hProp), (∏ m : stn (length L'), L (L' m)) → ∃ x : X, finite_intersection L' x) : Filter X. Proof. exists (PreFilterGenerated L). split. - apply (pr2 (PreFilterGenerated L)). - apply filtergenerated_notempty. exact Hl. Defined. Lemma PreFilterGenerated_correct {X : UU} : ∏ (L : (X → hProp) → hProp), (∏ A : X → hProp, L A → (PreFilterGenerated L) A) × (∏ F : PreFilter X, (∏ A : X → hProp, L A → F A) → filter_le F (PreFilterGenerated L)). Proof. intros L. split. - intros A La. apply hinhpr. exists (singletonSequence A). split. + intros. assumption. + intros x Hx. apply (Hx (O,,paths_refl _)). - intros F Hf A. apply hinhuniv. intros Ha. refine (filter_imply _ _ _ _ _). + apply (pr2 (pr2 Ha)). + apply filter_finite_intersection. intros m. apply Hf. apply (pr1 (pr2 Ha)). Qed. Lemma FilterGenerated_correct {X : UU} : ∏ (L : (X → hProp) → hProp) (Hl : ∏ L' : Sequence (X → hProp), (∏ m, L (L' m)) → (∃ x : X, finite_intersection L' x)), (∏ A : X → hProp, L A → (FilterGenerated L Hl) A) × (∏ F : Filter X, (∏ A : X → hProp, L A → F A) → filter_le F (FilterGenerated L Hl)). Proof. intros L Hl. split. - intros A La. apply hinhpr. exists (singletonSequence A). split. + intros; assumption. + intros x Hx. apply (Hx (O,,paths_refl _)). - intros F Hf A. apply hinhuniv. intros Ha. refine (filter_imply _ _ _ _ _). + apply (pr2 (pr2 Ha)). + apply filter_finite_intersection. intros m. apply Hf. apply (pr1 (pr2 Ha)). Qed. Lemma FilterGenerated_inv {X : UU} : ∏ (L : (X → hProp) → hProp) (F : Filter X), (∏ A : X → hProp, L A → F A) → ∏ (L' : Sequence (X → hProp)), (∏ m, L (L' m)) → (∃ x : X, finite_intersection L' x). Proof. intros L F Hf L' Hl'. apply (filter_notempty F). apply filter_finite_intersection. intros m. apply Hf, Hl'. Qed. Lemma ex_filter_le {X : UU} : ∏ (F : Filter X) (A : X → hProp), (∑ G : Filter X, filter_le G F × G A) <-> (∏ B : X → hProp, F B → (∃ x : X, A x ∧ B x)). Proof. intros F A. split. - intros G B Fb. apply (filter_notempty (pr1 G)). apply filter_and. + apply (pr2 (pr2 G)). + now apply (pr1 (pr2 G)). - intros H. simple refine (tpair _ _ _). + simple refine (FilterGenerated _ _). * intros B. apply (F B ∨ B = A). * intros L Hl. assert (B : ∃ B : X → hProp, F B × (∏ x, (A x ∧ B x → A x ∧ finite_intersection L x))). { revert L Hl. apply (Sequence_rect (P := λ L : Sequence (X → hProp), (∏ m : stn (length L), (λ B : X → hProp, F B ∨ B = A) (L m)) → ∃ B : X → hProp, F B × (∏ x : X, A x ∧ B x → A x ∧ finite_intersection L x))). - intros Hl. apply hinhpr. rewrite finite_intersection_htrue. exists (λ _, htrue). split. + exact (filter_htrue F). + intros; assumption. - intros L B IHl Hl. rewrite finite_intersection_append. simple refine (hinhuniv _ _). 3: apply IHl. + intros C. generalize (Hl lastelement) ; simpl. rewrite append_vec_compute_2. apply hinhfun. apply sumofmaps ; [intros Fl | intros ->]. * refine (tpair _ _ _). split. ** apply (filter_and F). *** apply (pr1 (pr2 C)). *** apply Fl. ** intros x H0 ; repeat split. *** exact (pr1 H0). *** exact (pr2 (pr2 H0)). *** simple refine (pr2 (pr2 (pr2 C) x _)). split. **** exact (pr1 H0). **** exact (pr1 (pr2 H0)). * exists (pr1 C) ; split. ** exact (pr1 (pr2 C)). ** intros x H0 ; repeat split. *** exact (pr1 H0). *** exact (pr1 H0). *** simple refine (pr2 (pr2 (pr2 C) x _)). exact H0. + intros. generalize (Hl (dni_lastelement m)) ; simpl. rewrite <- replace_dni_last. now rewrite append_vec_compute_1. } revert B. apply hinhuniv. intros B. generalize (H (pr1 B) (pr1 (pr2 B))). apply hinhfun. intros x. exists (pr1 x). simple refine (pr2 (pr2 (pr2 B) (pr1 x) _)). exact (pr2 x). + split. * intros B Fb. apply hinhpr. exists (singletonSequence B). split. ** intros m. apply hinhpr. now left. ** intros x Hx. apply (Hx (O ,, paths_refl _)). * apply hinhpr. exists (singletonSequence A). split. ** intros m. apply hinhpr. now right. ** intros x Hx. apply (Hx (O ,, paths_refl _)). Qed. (** *** Filter defined by a base *) Section base. Context {X : UU}. Context (base : (X → hProp) → hProp). Definition isbase_and := ∏ A B : X → hProp, base A → base B → ∃ C : X → hProp, base C × (∏ x, C x → A x ∧ B x). Definition isbase_notempty := ∃ A : X → hProp, base A. Definition isbase_notfalse := ∏ A, base A → ∃ x, A x. Definition isBaseOfPreFilter := isbase_and × isbase_notempty. Definition isBaseOfFilter := isbase_and × isbase_notempty × isbase_notfalse. End base. Definition BaseOfPreFilter (X : UU) := ∑ (base : (X → hProp) → hProp), isBaseOfPreFilter base. Definition pr1BaseOfPreFilter {X : UU} : BaseOfPreFilter X → ((X → hProp) → hProp) := pr1. Coercion pr1BaseOfPreFilter : BaseOfPreFilter >-> Funclass. Definition BaseOfFilter (X : UU) := ∑ (base : (X → hProp) → hProp), isBaseOfFilter base. Definition pr1BaseOfFilter {X : UU} : BaseOfFilter X → BaseOfPreFilter X. Proof. intros base. exists (pr1 base). split. - apply (pr1 (pr2 base)). - apply (pr1 (pr2 (pr2 base))). Defined. Coercion pr1BaseOfFilter : BaseOfFilter >-> BaseOfPreFilter. Lemma BaseOfPreFilter_and {X : UU} (base : BaseOfPreFilter X) : ∏ A B : X → hProp, base A → base B → ∃ C : X → hProp, base C × (∏ x, C x → A x ∧ B x). Proof. apply (pr1 (pr2 base)). Qed. Lemma BaseOfPreFilter_notempty {X : UU} (base : BaseOfPreFilter X) : ∃ A : X → hProp, base A. Proof. apply (pr2 (pr2 base)). Qed. Lemma BaseOfFilter_and {X : UU} (base : BaseOfFilter X) : ∏ A B : X → hProp, base A → base B → ∃ C : X → hProp, base C × (∏ x, C x → A x ∧ B x). Proof. apply (pr1 (pr2 base)). Qed. Lemma BaseOfFilter_notempty {X : UU} (base : BaseOfFilter X) : ∃ A : X → hProp, base A. Proof. apply (pr1 (pr2 (pr2 base))). Qed. Lemma BaseOfFilter_notfalse {X : UU} (base : BaseOfFilter X) : ∏ A, base A → ∃ x, A x. Proof. apply (pr2 (pr2 (pr2 base))). Qed. Section filterbase. Context {X : UU}. Context (base : (X → hProp) → hProp) (Hand : isbase_and base) (Hempty : isbase_notempty base) (Hfalse : isbase_notfalse base). Definition filterbase : (X → hProp) → hProp := λ A : X → hProp, (∃ B : X → hProp, base B × ∏ x, B x → A x). Lemma filterbase_imply : isfilter_imply filterbase. Proof. intros A B H. apply hinhfun. intros A'. exists (pr1 A'). split. - apply (pr1 (pr2 A')). - intros x Hx. apply H. now apply (pr2 (pr2 A')). Qed. Lemma filterbase_htrue : isfilter_htrue filterbase. Proof. revert Hempty. apply hinhfun. intros A. exists (pr1 A). split. - apply (pr2 A). - intros. exact tt. Qed. Lemma filterbase_and : isfilter_and filterbase. Proof. intros A B. apply hinhuniv2. intros A' B'. refine (hinhfun _ _). 2: apply Hand. 2: (apply (pr1 (pr2 A'))). 2: (apply (pr1 (pr2 B'))). intros C'. exists (pr1 C'). split. - apply (pr1 (pr2 C')). - intros x Cx ; split. + apply (pr2 (pr2 A')). now refine (pr1 (pr2 (pr2 C') _ _)). + apply (pr2 (pr2 B')). now refine (pr2 (pr2 (pr2 C') _ _)). Qed. Lemma filterbase_notempty : isfilter_notempty filterbase. Proof. intros A. apply hinhuniv. intros B. generalize (Hfalse _ (pr1 (pr2 B))). apply hinhfun. intros x. exists (pr1 x). apply (pr2 (pr2 B)), (pr2 x). Qed. Lemma base_finite_intersection : ∏ L : Sequence (X → hProp), (∏ n, base (L n)) → ∃ A, base A × (∏ x, A x → finite_intersection L x). Proof. intros L Hbase. apply (pr2 (finite_intersection_hProp (λ B, ∃ A : X → hProp, base A × (∏ x : X, A x → B x)))). - split. + revert Hempty. apply hinhfun. intros A. now exists (pr1 A), (pr2 A). + intros A B. apply hinhuniv2. intros A' B'. generalize (Hand _ _ (pr1 (pr2 A')) (pr1 (pr2 B'))). apply hinhfun. intros C. exists (pr1 C). split. * exact (pr1 (pr2 C)). * intros x Cx. split. ** apply (pr2 (pr2 A')), (pr1 (pr2 (pr2 C) _ Cx)). ** apply (pr2 (pr2 B')), (pr2 (pr2 (pr2 C) _ Cx)). - intros n. apply hinhpr. exists (L n). split. + now apply Hbase. + intros; assumption. Qed. Lemma filterbase_genetated : filterbase = filtergenerated base. Proof. apply funextfun ; intros P. apply hPropUnivalence. - apply hinhfun. intros A. exists (singletonSequence (pr1 A)). split. + intros m ; simpl. exact (pr1 (pr2 A)). + intros x Ax. apply (pr2 (pr2 A)). simple refine (Ax _). now exists 0%nat. - apply hinhuniv. intros L. generalize (base_finite_intersection (pr1 L) (pr1 (pr2 L))). apply hinhfun. intros A. exists (pr1 A) ; split. + exact (pr1 (pr2 A)). + intros x Ax. now apply (pr2 (pr2 L)), (pr2 (pr2 A)). Qed. Lemma filterbase_generated_hypothesis : ∏ L' : Sequence (X → hProp), (∏ m : stn (length L'), base (L' m)) → ∃ x : X, finite_intersection L' x. Proof. intros L Hbase. generalize (base_finite_intersection L Hbase). apply hinhuniv. intros A. generalize (Hfalse _ (pr1 (pr2 A))). apply hinhfun. intros x. exists (pr1 x). apply (pr2 (pr2 A)). exact (pr2 x). Qed. End filterbase. Definition PreFilterBase {X : UU} (base : BaseOfPreFilter X) : PreFilter X. Proof. simple refine (make_PreFilter _ _ _ _). - apply (filterbase base). - apply filterbase_imply. - apply filterbase_htrue, BaseOfPreFilter_notempty. - apply filterbase_and. intros A B. now apply BaseOfPreFilter_and. Defined. Definition FilterBase {X : UU} (base : BaseOfFilter X) : Filter X. Proof. intros. exists (pr1 (PreFilterBase base)). split. - simple refine (pr2 (PreFilterBase base)). - apply filterbase_notempty. intros A Ha. simple refine (BaseOfFilter_notfalse _ _ _). + apply base. + apply Ha. Defined. Lemma PreFilterBase_Generated {X : UU} (base : BaseOfPreFilter X) : PreFilterBase base = PreFilterGenerated base. Proof. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). - apply isapropdirprod. + apply isaprop_isfilter_imply. + apply isaprop_isfilter_finite_intersection. - simpl. apply filterbase_genetated. + intros A B. apply (BaseOfPreFilter_and base). + apply (BaseOfPreFilter_notempty base). Qed. Lemma FilterBase_Generated {X : UU} (base : BaseOfFilter X) Hbase : FilterBase base = FilterGenerated base Hbase. Proof. simple refine (subtypePath_prop (B := λ _, make_hProp _ _) _). - apply isapropdirprod. + apply isapropdirprod. * apply isaprop_isfilter_imply. * apply isaprop_isfilter_finite_intersection. + apply isaprop_isfilter_notempty. - simpl. apply filterbase_genetated. + intros A B. apply (BaseOfFilter_and base). + apply (BaseOfFilter_notempty base). Qed. Lemma FilterBase_Generated_hypothesis {X : UU} (base : BaseOfFilter X) : ∏ L' : Sequence (X → hProp), (∏ m : stn (length L'), base (L' m)) → ∃ x : X, finite_intersection L' x. Proof. apply filterbase_generated_hypothesis. - intros A B. apply (BaseOfFilter_and base). - apply (BaseOfFilter_notempty base). - intros A Ha. now apply (BaseOfFilter_notfalse base). Qed. Lemma filterbase_le {X : UU} (base base' : (X → hProp) → hProp) : (∏ P : X → hProp, base P → ∃ Q : X → hProp, base' Q × (∏ x, Q x → P x)) <-> (∏ P : X → hProp, filterbase base P → filterbase base' P). Proof. split. - intros Hbase P. apply hinhuniv. intros A. generalize (Hbase _ (pr1 (pr2 A))). apply hinhfun. intros B. exists (pr1 B). split. + apply (pr1 (pr2 B)). + intros x Bx. apply (pr2 (pr2 A)), (pr2 (pr2 B)), Bx. - intros Hbase P Hp. apply Hbase. apply hinhpr. now exists P. Qed. Lemma PreFilterBase_le {X : UU} (base base' : BaseOfPreFilter X) : (∏ P : X → hProp, base P → ∃ Q : X → hProp, base' Q × (∏ x, Q x → P x)) <-> filter_le (PreFilterBase base') (PreFilterBase base). Proof. split. - intros Hbase P. apply (pr1 (filterbase_le base base')), Hbase. - apply (pr2 (filterbase_le base base')). Qed. Lemma FilterBase_le {X : UU} (base base' : BaseOfFilter X) : (∏ P : X → hProp, base P → ∃ Q : X → hProp, base' Q × (∏ x, Q x → P x)) <-> filter_le (FilterBase base') (FilterBase base). Proof. split. - intros Hbase P. apply (pr1 (filterbase_le base base')), Hbase. - apply (pr2 (filterbase_le base base')). Qed. UniMath-20231010/UniMath/Topology/Prelim.v000066400000000000000000000207211451125700300201110ustar00rootroot00000000000000(** * Additional theorems *) Require Export UniMath.Foundations.Sets. Require Import UniMath.MoreFoundations.Tactics. Require Import UniMath.MoreFoundations.Subtypes. Require Export UniMath.Combinatorics.FiniteSequences. Require Export UniMath.Foundations.NaturalNumbers. Require Export UniMath.Tactics.EnsureStructuredProofs. (** ** hProp *) Lemma hinhuniv2' {P X Y : UU} : isaprop P → (X → Y → P) → (∥ X ∥ → ∥ Y ∥ → P). Proof. intros HP Hxy. apply (hinhuniv2 (P := make_hProp _ HP)). exact Hxy. Qed. (** ** A new tactic *) Ltac apply_pr2 T := first [ refine (pr2 (T) _) | refine (pr2 (T _) _) | refine (pr2 (T _ _) _) | refine (pr2 (T _ _ _) _) | refine (pr2 (T _ _ _ _) _) | refine (pr2 (T _ _ _ _ _) _) | refine (pr2 (T)) | refine (pr2 (T _)) | refine (pr2 (T _ _)) | refine (pr2 (T _ _ _)) | refine (pr2 (T _ _ _ _)) | refine (pr2 (T _ _ _ _ _)) ]. Ltac apply_pr2_in T H := first [ apply (pr2 (T)) in H | apply (λ H0, pr2 (T H0)) in H | apply (λ H0 H1, pr2 (T H0 H1)) in H | apply (λ H0 H1 H2, pr2 (T H0 H1 H2)) in H | apply (λ H0 H1 H2 H3, pr2 (T H0 H1 H2 H3)) in H | apply (λ H0 H1 H2 H3 H4, pr2 (T H0 H1 H2 H3 H4)) in H ]. (** ** About nat *) Lemma max_le_l : ∏ n m : nat, (n ≤ max n m)%nat. Proof. induction n as [ | n IHn] ; simpl max. - intros m ; reflexivity. - induction m as [ | m _]. + now apply isreflnatleh. + now apply IHn. Qed. Lemma max_le_r : ∏ n m : nat, (m ≤ max n m)%nat. Proof. induction n as [ | n IHn] ; simpl max. - intros m ; now apply isreflnatleh. - induction m as [ | m _]. + reflexivity. + now apply IHn. Qed. (** ** More about Sequence *) Definition singletonSequence {X} (A : X) : Sequence X := (1 ,, λ _, A). Definition pairSequence {X} (A B : X) : Sequence X. Proof. exists 2. intros m. induction m as [m _]. induction m as [ | _ _]. - exact A. - exact B. Defined. (** ** More about sets *) (** union *) Definition union {X : UU} (P : (X → hProp) → hProp) : X → hProp := λ x : X, ∃ A : X → hProp, P A × A x. Lemma union_hfalse {X : UU} : union (λ _ : X → hProp, hfalse) = (λ _ : X, hfalse). Proof. apply funextfun ; intros x. apply hPropUnivalence. - apply hinhuniv. intros A. apply (pr1 (pr2 A)). - apply fromempty. Qed. Lemma union_or {X : UU} : ∏ A B : X → hProp, union (λ C : X → hProp, C = A ∨ C = B) = (λ x : X, A x ∨ B x). Proof. intros A B. apply funextfun ; intro x. apply hPropUnivalence. - apply hinhuniv. intros C. generalize (pr1 (pr2 C)). apply hinhfun. apply sumofmaps. + intro e. rewrite <- e. left. apply (pr2 (pr2 C)). + intro e. rewrite <- e. right. apply (pr2 (pr2 C)). - apply hinhfun ; apply sumofmaps ; [ intros Ax | intros Bx]. + exists A. split. * apply hinhpr. now left. * exact Ax. + exists B. split. * apply hinhpr. now right. * exact Bx. Qed. Lemma union_hProp {X : UU} : ∏ (P : (X → hProp) → hProp), (∏ (L : (X → hProp) → hProp), (∏ A, L A → P A) → P (union L)) → (∏ A B, P A → P B → P (λ x : X, A x ∨ B x)). Proof. intros P Hp A B Pa Pb. rewrite <- union_or. apply Hp. intros C. apply hinhuniv. now apply sumofmaps ; intros ->. Qed. Local Open Scope logic. Local Open Scope subtype. Lemma union_not_contained_in {X : UU} (U : (X -> hProp) -> hProp) (S : X -> hProp) : union U ⊈ S ⇔ (∃ T, U T ∧ T ⊈ S). Proof. unfold subtype_notContainedIn, union. use make_dirprod; intro H. - use (hinhuniv _ H); intro Hx. induction Hx as [x Hx]. induction Hx as [Hx HSx]. use (hinhfun _ Hx); intro HT. induction HT as [T HT]. exists T. use make_dirprod. + exact (dirprod_pr1 HT). + apply hinhpr. exists x. exact (make_dirprod (dirprod_pr2 HT) HSx). - use (hinhuniv _ H); intro HT. induction HT as [T HT]. use (hinhfun _ (dirprod_pr2 HT)); intro Hx. induction Hx as [x Hx]. exists x. use make_dirprod. + apply hinhpr. exists T. exact (make_dirprod (dirprod_pr1 HT) (dirprod_pr1 Hx)). + exact (dirprod_pr2 Hx). Defined. (** finite intersection *) Definition finite_intersection {X : UU} (P : Sequence (X → hProp)) : X → hProp. Proof. intros x. simple refine (make_hProp _ _). - apply (∏ n, P n x). - apply (impred_isaprop _ (λ _, propproperty _)). Defined. Lemma finite_intersection_htrue {X : UU} : finite_intersection nil = (λ _ : X, htrue). Proof. apply funextfun ; intros x. apply hPropUnivalence. - intros _. apply tt. - intros _ m. generalize (pr1 m) (pr2 m). intros m' Hm. apply fromempty. revert Hm. apply negnatlthn0. Qed. Lemma finite_intersection_1 {X : UU} : ∏ (A : X → hProp), finite_intersection (singletonSequence A) = A. Proof. intros A. apply funextfun ; intros x. apply hPropUnivalence. - intros H. simple refine (H _). now exists 0. - intros Lx m. exact Lx. Qed. Lemma finite_intersection_and {X : UU} : ∏ A B : X → hProp, finite_intersection (pairSequence A B) = (λ x : X, A x ∧ B x). Proof. intros A B. apply funextfun ; intro x. apply hPropUnivalence. - intros H. split. + simple refine (H (0,,_)). reflexivity. + simple refine (H (1,,_)). reflexivity. - intros H m ; simpl. change m with (pr1 m,,pr2 m). generalize (pr1 m) (pr2 m). clear m. intros m Hm. induction m as [ | m _]. + apply (pr1 H). + apply (pr2 H). Qed. Lemma finite_intersection_case {X : UU} : ∏ (L : Sequence (X → hProp)), finite_intersection L = sumofmaps (λ _ _, htrue) (λ (AB : (X → hProp) × Sequence (X → hProp)) (x : X), pr1 AB x ∧ finite_intersection (pr2 AB) x) (disassembleSequence L). Proof. intros L. apply funextfun ; intros x. apply hPropUnivalence. - intros Hx. induction L as [n L]. induction n as [ | n _] ; simpl. + apply tt. + split. * simple refine (Hx _). * intros m. simple refine (Hx _). - induction L as [n L]. induction n as [ | n _] ; simpl. + intros _ n. apply fromempty. induction (negnatlthn0 _ (pr2 n)). + intros Hx m. change m with (pr1 m,,pr2 m). generalize (pr1 m) (pr2 m) ; clear m ; intros m Hm. induction (natlehchoice _ _ (natlthsntoleh _ _ Hm)) as [Hm' | ->]. * generalize (pr2 Hx (m,,Hm')). unfold dni_lastelement ; simpl. assert (H : Hm = natlthtolths m n Hm' ). { apply (pr2 (natlth m (S n))). } now rewrite H. * assert (H : lastelement = (n,, Hm)). { now apply subtypePath_prop. } rewrite <- H. exact (pr1 Hx). Qed. Lemma finite_intersection_append {X : UU} : ∏ (A : X → hProp) (L : Sequence (X → hProp)), finite_intersection (append L A) = (λ x : X, A x ∧ finite_intersection L x). Proof. intros A L. rewrite finite_intersection_case. simpl. rewrite append_vec_compute_2. apply funextfun ; intro x. apply maponpaths. apply map_on_two_paths. - induction L as [n L] ; simpl. apply maponpaths. apply funextfun ; intro m. simpl. rewrite <- replace_dni_last. apply append_vec_compute_1. - reflexivity. Qed. Lemma finite_intersection_hProp {X : UU} : ∏ (P : (X → hProp) → hProp), (∏ (L : Sequence (X → hProp)), (∏ n, P (L n)) → P (finite_intersection L)) <-> (P (λ _, htrue) × (∏ A B, P A → P B → P (λ x : X, A x ∧ B x))). Proof. intros P. split. - split. + rewrite <- finite_intersection_htrue. apply X0. intros n. induction (negnatlthn0 _ (pr2 n)). + intros A B Pa Pb. rewrite <- finite_intersection_and. apply X0. intros n. change n with (pr1 n,,pr2 n). generalize (pr1 n) (pr2 n) ; clear n ; intros n Hn. now induction n as [ | n _] ; simpl. - intros Hp. apply (Sequence_rect (P := λ L : Sequence (X → hProp), (∏ n : stn (length L), P (L n)) → P (finite_intersection L))). + intros _. rewrite finite_intersection_htrue. exact (pr1 Hp). + intros L A IHl Hl. rewrite finite_intersection_append. apply (pr2 Hp). * rewrite <- (append_vec_compute_2 L A). now apply Hl. * apply IHl. intros n. rewrite <- (append_vec_compute_1 L A). apply Hl. Qed. UniMath-20231010/UniMath/Topology/Topology.v000066400000000000000000001072171451125700300205030ustar00rootroot00000000000000(** * Results about Topology *) (** Author: Catherine LELAY. Jan 2016 - *) (** Based on Bourbaki *) Require Import UniMath.Foundations.All. Require Import UniMath.MoreFoundations.All. Require Export UniMath.Topology.Filters. Require Import UniMath.Algebra.Groups. Require Import UniMath.Algebra.DivisionRig. Require Import UniMath.Algebra.ConstructiveStructures. Section Open. Context {X : UU}. Context (O : (X → hProp) → hProp). Definition isSetOfOpen_union := ∏ P : (X → hProp) → hProp, (∏ A : X → hProp, P A → O A) → O (union P). Lemma isaprop_isSetOfOpen_union : isaprop isSetOfOpen_union. Proof. apply (impred_isaprop _ (λ _, isapropimpl _ _ (propproperty _))). Qed. Definition isSetOfOpen_finite_intersection := ∏ (P : Sequence (X → hProp)), (∏ m, O (P m)) → O (finite_intersection P). Lemma isaprop_isSetOfOpen_finite_intersection : isaprop isSetOfOpen_finite_intersection. Proof. apply (impred_isaprop _ (λ _, isapropimpl _ _ (propproperty _))). Qed. Definition isSetOfOpen_htrue := O (λ _, htrue). Definition isSetOfOpen_and := ∏ A B, O A → O B → O (λ x, A x ∧ B x). Lemma isaprop_isSetOfOpen_and : isaprop isSetOfOpen_and. Proof. apply impred_isaprop ; intros A. apply impred_isaprop ; intros B. apply isapropimpl, isapropimpl. now apply propproperty. Qed. Lemma isSetOfOpen_hfalse : isSetOfOpen_union → O (λ _ : X, hfalse). Proof. intros H0. rewrite <- union_hfalse. apply H0. intro. apply fromempty. Qed. Lemma isSetOfOpen_finite_intersection_htrue : isSetOfOpen_finite_intersection → isSetOfOpen_htrue. Proof. intro H0. unfold isSetOfOpen_htrue. rewrite <- finite_intersection_htrue. apply H0. intros m. induction (nopathsfalsetotrue (pr2 m)). Qed. Lemma isSetOfOpen_finite_intersection_and : isSetOfOpen_finite_intersection → isSetOfOpen_and. Proof. intros H0 A B Ha Hb. rewrite <- finite_intersection_and. apply H0. intros m ; simpl. induction m as [m Hm]. now induction m. Qed. Lemma isSetOfOpen_finite_intersection_carac : isSetOfOpen_htrue → isSetOfOpen_and → isSetOfOpen_finite_intersection. Proof. intros Htrue Hpair L. apply (pr2 (finite_intersection_hProp O)). split. - exact Htrue. - exact Hpair. Qed. Definition isSetOfOpen := isSetOfOpen_union × isSetOfOpen_finite_intersection. End Open. Definition isTopologicalSpace (X : hSet) := ∑ O : (X → hProp) → hProp, isSetOfOpen O. Definition TopologicalSpace := ∑ X : hSet, isTopologicalSpace X. Definition make_TopologicalSpace (X : hSet) (O : (X → hProp) → hProp) (is : isSetOfOpen_union O) (is0 : isSetOfOpen_htrue O) (is1 : isSetOfOpen_and O) : TopologicalSpace := (X,,O,,is,,(isSetOfOpen_finite_intersection_carac _ is0 is1)). Definition pr1TopologicatSpace : TopologicalSpace → hSet := pr1. Coercion pr1TopologicatSpace : TopologicalSpace >-> hSet. Definition isOpen {T : TopologicalSpace} : (T → hProp) → hProp := pr1 (pr2 T). Definition Open {T : TopologicalSpace} := ∑ O : T → hProp, isOpen O. Definition pr1Open {T : TopologicalSpace} : Open → (T → hProp) := pr1. Coercion pr1Open : Open >-> Funclass. Section Topology_pty. Context {T : TopologicalSpace}. Lemma isOpen_union : ∏ P : (T → hProp) → hProp, (∏ A : T → hProp, P A → isOpen A) → isOpen (union P). Proof. apply (pr1 (pr2 (pr2 T))). Qed. Lemma isOpen_finite_intersection : ∏ (P : Sequence (T → hProp)), (∏ m , isOpen (P m)) → isOpen (finite_intersection P). Proof. apply (pr2 (pr2 (pr2 T))). Qed. Lemma isOpen_hfalse : isOpen (λ _ : T, hfalse). Proof. apply isSetOfOpen_hfalse. intros P H. now apply isOpen_union. Qed. Lemma isOpen_htrue : isOpen (λ _ : T, htrue). Proof. rewrite <- finite_intersection_htrue. apply isOpen_finite_intersection. intros m. induction (nopathsfalsetotrue (pr2 m)). Qed. Lemma isOpen_and : ∏ A B : T → hProp, isOpen A → isOpen B → isOpen (λ x : T, A x ∧ B x). Proof. apply isSetOfOpen_finite_intersection_and. intros P Hp. apply isOpen_finite_intersection. apply Hp. Qed. Lemma isOpen_or : ∏ A B : T → hProp, isOpen A → isOpen B → isOpen (λ x : T, A x ∨ B x). Proof. intros A B Ha Hb. rewrite <- union_or. apply isOpen_union. intros C. apply hinhuniv. apply sumofmaps ; intros ->. - exact Ha. - exact Hb. Qed. End Topology_pty. (** ** Neighborhood *) Section Neighborhood. Context {T : TopologicalSpace}. Definition neighborhood (x : T) : (T → hProp) → hProp := λ P : T → hProp, ∃ O : Open, O x × (∏ y : T, O y → P y). Lemma neighborhood_isOpen (P : T → hProp) : (∏ x, P x → neighborhood x P) <-> isOpen P. Proof. split. - intros Hp. assert (H : ∏ A : T → hProp, isaprop (∏ y : T, A y → P y)). { intros A. apply impred_isaprop. intro y. apply isapropimpl. apply propproperty. } set (Q := λ A : T → hProp, isOpen A ∧ (make_hProp (∏ y : T, A y → P y) (H A))). assert (X : P = (union Q)). { apply funextfun. intros x. apply hPropUnivalence. - intros Px. generalize (Hp _ Px). apply hinhfun. intros A. exists (pr1 A) ; split. + split. * apply (pr2 (pr1 A)). * exact (pr2 (pr2 A)). + exact (pr1 (pr2 A)). - apply hinhuniv. intros A. apply (pr2 (pr1 (pr2 A))). exact (pr2 (pr2 A)). } rewrite X. apply isOpen_union. intros A Ha. apply (pr1 Ha). - intros Hp x Px. apply hinhpr. exists (P,,Hp). split. + exact Px. + intros y Py. exact Py. Qed. Lemma neighborhood_imply : ∏ (x : T) (P Q : T → hProp), (∏ y : T, P y → Q y) → neighborhood x P → neighborhood x Q. Proof. intros x P Q H. apply hinhfun. intros O. exists (pr1 O). split. - apply (pr1 (pr2 O)). - intros y Hy. apply H. apply (pr2 (pr2 O)). exact Hy. Qed. Lemma neighborhood_forall : ∏ (x : T) (P : T → hProp), (∏ y, P y) → neighborhood x P. Proof. intros x P H. apply hinhpr. exists ((λ _ : T, htrue),,isOpen_htrue). split. - reflexivity. - intros y _. now apply H. Qed. Lemma neighborhood_and : ∏ (x : T) (A B : T → hProp), neighborhood x A → neighborhood x B → neighborhood x (λ y, A y ∧ B y). Proof. intros x A B. apply hinhfun2. intros Oa Ob. exists ((λ x, pr1 Oa x ∧ pr1 Ob x) ,, isOpen_and _ _ (pr2 (pr1 Oa)) (pr2 (pr1 Ob))). simpl. split. - split. + apply (pr1 (pr2 Oa)). + apply (pr1 (pr2 Ob)). - intros y Hy. split. + apply (pr2 (pr2 Oa)). apply (pr1 Hy). + apply (pr2 (pr2 Ob)). apply (pr2 Hy). Qed. Lemma neighborhood_point : ∏ (x : T) (P : T → hProp), neighborhood x P → P x. Proof. intros x P. apply hinhuniv. intros O. apply (pr2 (pr2 O)). apply (pr1 (pr2 O)). Qed. Lemma neighborhood_neighborhood : ∏ (x : T) (P : T → hProp), neighborhood x P → ∃ Q : T → hProp, neighborhood x Q × ∏ y : T, Q y → neighborhood y P. Proof. intros x P. apply hinhfun. intros Q. exists (pr1 Q). split. - apply (pr2 (neighborhood_isOpen _)). + apply (pr2 (pr1 Q)). + apply (pr1 (pr2 Q)). - intros y Qy. apply hinhpr. exists (pr1 Q). split. + exact Qy. + exact (pr2 (pr2 Q)). Qed. End Neighborhood. Definition locally {T : TopologicalSpace} (x : T) : Filter T. Proof. simple refine (make_Filter _ _ _ _ _). - apply (neighborhood x). - abstract (intros A B ; apply neighborhood_imply). - abstract (apply (pr2 (neighborhood_isOpen _)) ; [ apply isOpen_htrue | apply tt]). - abstract (intros A B ; apply neighborhood_and). - abstract (intros A Ha ; apply hinhpr ; exists x ; now apply neighborhood_point in Ha). Defined. (** ** Base of Neighborhood *) Definition is_base_of_neighborhood {T : TopologicalSpace} (x : T) (B : (T → hProp) → hProp) := (∏ P : T → hProp, B P → neighborhood x P) × (∏ P : T → hProp, neighborhood x P → ∃ Q : T → hProp, B Q × (∏ t : T, Q t → P t)). Definition base_of_neighborhood {T : TopologicalSpace} (x : T) := ∑ (B : (T → hProp) → hProp), is_base_of_neighborhood x B. Definition pr1base_of_neighborhood {T : TopologicalSpace} (x : T) : base_of_neighborhood x → ((T → hProp) → hProp) := pr1. Coercion pr1base_of_neighborhood : base_of_neighborhood >-> Funclass. Section base_default. Context {T : TopologicalSpace} (x : T). Definition base_default : (T → hProp) → hProp := λ P : T → hProp, isOpen P ∧ P x. Lemma base_default_1 : ∏ P : T → hProp, base_default P → neighborhood x P. Proof. intros P Hp. apply hinhpr. exists (P,,(pr1 Hp)) ; split. - exact (pr2 Hp). - intros. assumption. Qed. Lemma base_default_2 : ∏ P : T → hProp, neighborhood x P → ∃ Q : T → hProp, base_default Q × (∏ t : T, Q t → P t). Proof. intros P. apply hinhfun. intros Q. exists (pr1 Q). repeat split. - exact (pr2 (pr1 Q)). - exact (pr1 (pr2 Q)). - exact (pr2 (pr2 Q)). Qed. End base_default. Definition base_of_neighborhood_default {T : TopologicalSpace} (x : T) : base_of_neighborhood x. Proof. exists (base_default x). split. - now apply base_default_1. - now apply base_default_2. Defined. Definition neighborhood' {T : TopologicalSpace} (x : T) (B : base_of_neighborhood x) : (T → hProp) → hProp := λ P : T → hProp, ∃ O : T → hProp, B O × (∏ t : T, O t → P t). Lemma neighborhood_equiv {T : TopologicalSpace} (x : T) (B : base_of_neighborhood x) : ∏ P, neighborhood' x B P <-> neighborhood x P. Proof. split. - apply hinhuniv. intros O. generalize ((pr1 (pr2 B)) (pr1 O) (pr1 (pr2 O))). apply neighborhood_imply. exact (pr2 (pr2 O)). - intros Hp. generalize (pr2 (pr2 B) P Hp). apply hinhfun. intros O. exists (pr1 O). exact (pr2 O). Qed. (** ** Some topologies *) (** *** Topology from neighborhood *) Definition isNeighborhood {X : UU} (B : X → (X → hProp) → hProp) := (∏ x, isfilter_imply (B x)) × (∏ x, isfilter_htrue (B x)) × (∏ x, isfilter_and (B x)) × (∏ x P, B x P → P x) × (∏ x P, B x P → ∃ Q, B x Q × ∏ y, Q y → B y P). Lemma isNeighborhood_neighborhood {T : TopologicalSpace} : isNeighborhood (neighborhood (T := T)). Proof. repeat split. - intros x A B. apply (neighborhood_imply x). - intros x. apply (pr2 (neighborhood_isOpen _)). + exact (isOpen_htrue (T := T)). + apply tt. - intros A B. apply neighborhood_and. - intros x P. apply neighborhood_point. - intros x P. apply neighborhood_neighborhood. Qed. Section TopologyFromNeighborhood. Context {X : hSet}. Context (N : X → (X → hProp) → hProp). Context (Himpl : ∏ x, isfilter_imply (N x)) (Htrue : ∏ x, isfilter_htrue (N x)) (Hand : ∏ x, isfilter_and (N x)) (Hpt : ∏ x P, N x P → P x) (H : ∏ x P, N x P → ∃ Q, N x Q × ∏ y, Q y → N y P). Definition topologyfromneighborhood (A : X → hProp) := ∏ x : X, A x → N x A. Lemma isaprop_topologyfromneighborhood : ∏ A, isaprop (topologyfromneighborhood A). Proof. intros A. apply impred_isaprop ; intros x ; apply isapropimpl, propproperty. Qed. Lemma topologyfromneighborhood_open : isSetOfOpen_union (λ A : X → hProp, make_hProp (topologyfromneighborhood A) (isaprop_topologyfromneighborhood A)). Proof. intros L Hl x. apply hinhuniv. intros A. apply Himpl with (pr1 A). - intros y Hy. apply hinhpr. now exists (pr1 A), (pr1 (pr2 A)). - apply Hl. + exact (pr1 (pr2 A)). + exact (pr2 (pr2 A)). Qed. End TopologyFromNeighborhood. Definition TopologyFromNeighborhood {X : hSet} (N : X → (X → hProp) → hProp) (H : isNeighborhood N) : TopologicalSpace. Proof. use make_TopologicalSpace. - apply X. - intros A. simple refine (make_hProp _ _). + apply (topologyfromneighborhood N A). + apply isaprop_topologyfromneighborhood. - apply topologyfromneighborhood_open. apply (pr1 H). - intros x _. apply (pr1 (pr2 H)). - intros A B Ha Hb x Hx. apply (pr1 (pr2 (pr2 H))). + now apply Ha, (pr1 Hx). + now apply Hb, (pr2 Hx). Defined. Lemma TopologyFromNeighborhood_correct {X : hSet} (N : X → (X → hProp) → hProp) (H : isNeighborhood N) : ∏ (x : X) (P : X → hProp), N x P <-> neighborhood (T := TopologyFromNeighborhood N H) x P. Proof. split. - intros Hx. apply hinhpr. simple refine (tpair _ _ _). + simple refine (tpair _ _ _). * intros y. apply (N y P). * simpl ; intros y Hy. generalize (pr2 (pr2 (pr2 (pr2 H))) _ _ Hy). apply hinhuniv. intros Q. apply (pr1 H) with (2 := pr1 (pr2 Q)). exact (pr2 (pr2 Q)). + split ; simpl. * exact Hx. * intros y. now apply (pr1 (pr2 (pr2 (pr2 H)))). - apply hinhuniv. intros O. apply (pr1 H) with (pr1 (pr1 O)). + apply (pr2 (pr2 O)). + simple refine (pr2 (pr1 O) _ _). exact (pr1 (pr2 O)). Qed. Lemma isNeighborhood_isPreFilter {X : hSet} N : isNeighborhood N -> ∏ x : X, isPreFilter (N x). Proof. intros Hn x. split. - apply (pr1 Hn). - apply isfilter_finite_intersection_carac. + apply (pr1 (pr2 Hn)). + apply (pr1 (pr2 (pr2 Hn))). Qed. Lemma isNeighborhood_isFilter {X : hSet} N : isNeighborhood N -> ∏ x : X, isFilter (N x). Proof. intros Hn x. split. - apply isNeighborhood_isPreFilter, Hn. - intros A Fa. apply hinhpr. exists x. apply ((pr1 (pr2 (pr2 (pr2 Hn)))) _ _ Fa). Qed. (** *** Generated Topology *) Section topologygenerated. Context {X : hSet} (O : (X → hProp) → hProp). Definition topologygenerated := λ (x : X) (A : X → hProp), (∃ L : Sequence (X → hProp), (∏ n, O (L n)) × (finite_intersection L x) × (∏ y, finite_intersection L y → A y)). Lemma topologygenerated_imply : ∏ x : X, isfilter_imply (topologygenerated x). Proof. intros x A B H. apply hinhfun. intros L. exists (pr1 L). repeat split. - exact (pr1 (pr2 L)). - exact (pr1 (pr2 (pr2 L))). - intros y Hy. apply H, (pr2 (pr2 (pr2 L))), Hy. Qed. Lemma topologygenerated_htrue : ∏ x : X, isfilter_htrue (topologygenerated x). Proof. intros x. apply hinhpr. exists nil. repeat split; intros n; induction (nopathsfalsetotrue (pr2 n)). Qed. Lemma topologygenerated_and : ∏ x : X, isfilter_and (topologygenerated x). Proof. intros x A B. apply hinhfun2. intros La Lb. exists (concatenate (pr1 La) (pr1 Lb)). repeat split. - simpl ; intro. apply (coprod_rect (λ x, O (coprod_rect _ _ _ x))) ; intros m. + rewrite coprod_rect_compute_1. exact (pr1 (pr2 La) _). + rewrite coprod_rect_compute_2. exact (pr1 (pr2 Lb) _). - simpl ; intro. apply (coprod_rect (λ y, (coprod_rect (λ _ : stn (length (pr1 La)) ⨿ stn (length (pr1 Lb)), X → hProp) (λ j : stn (length (pr1 La)), (pr1 La) j) (λ k : stn (length (pr1 Lb)), (pr1 Lb) k) y) x)) ; intros m. + rewrite coprod_rect_compute_1. exact (pr1 (pr2 (pr2 La)) _). + rewrite coprod_rect_compute_2. exact (pr1 (pr2 (pr2 Lb)) _). - apply (pr2 (pr2 (pr2 La))). intros n. simpl in X0. unfold concatenate' in X0. specialize (X0 (weqfromcoprodofstn_map (length (pr1 La)) (length (pr1 Lb)) (ii1 n))). now rewrite (weqfromcoprodofstn_eq1 _ _) , coprod_rect_compute_1 in X0. - apply (pr2 (pr2 (pr2 Lb))). intros n. simpl in X0. unfold concatenate' in X0. specialize (X0 (weqfromcoprodofstn_map (length (pr1 La)) (length (pr1 Lb)) (ii2 n))). now rewrite (weqfromcoprodofstn_eq1 _ _), coprod_rect_compute_2 in X0. Qed. Lemma topologygenerated_point : ∏ (x : X) (P : X → hProp), topologygenerated x P → P x. Proof. intros x P. apply hinhuniv. intros L. apply (pr2 (pr2 (pr2 L))). exact (pr1 (pr2 (pr2 L))). Qed. Lemma topologygenerated_neighborhood : ∏ (x : X) (P : X → hProp), topologygenerated x P → ∃ Q : X → hProp, topologygenerated x Q × (∏ y : X, Q y → topologygenerated y P). Proof. intros x P. apply hinhfun. intros L. exists (finite_intersection (pr1 L)). split. - apply hinhpr. exists (pr1 L). repeat split. + exact (pr1 (pr2 L)). + exact (pr1 (pr2 (pr2 L))). + intros. assumption. - intros y Hy. apply hinhpr. exists (pr1 L). repeat split. + exact (pr1 (pr2 L)). + exact Hy. + exact (pr2 (pr2 (pr2 L))). Qed. End topologygenerated. Definition TopologyGenerated {X : hSet} (O : (X → hProp) → hProp) : TopologicalSpace. Proof. simple refine (TopologyFromNeighborhood _ _). - apply X. - apply topologygenerated, O. - repeat split. + apply topologygenerated_imply. + apply topologygenerated_htrue. + apply topologygenerated_and. + apply topologygenerated_point. + apply topologygenerated_neighborhood. Defined. Lemma TopologyGenerated_included {X : hSet} : ∏ (O : (X → hProp) → hProp) (P : X → hProp), O P → isOpen (T := TopologyGenerated O) P. Proof. intros O P Op. apply neighborhood_isOpen. intros x Hx. apply TopologyFromNeighborhood_correct. apply hinhpr. exists (singletonSequence P). repeat split. - induction n as [n Hn]. exact Op. - intros n ; induction n as [n Hn]. exact Hx. - intros y Hy. now apply (Hy (0%nat,,paths_refl _)). Qed. Lemma TopologyGenerated_smallest {X : hSet} : ∏ (O : (X → hProp) → hProp) (T : isTopologicalSpace X), (∏ P : X → hProp, O P → pr1 T P) → ∏ P : X → hProp, isOpen (T := TopologyGenerated O) P → pr1 T P. Proof. intros O T Ht P Hp. apply (neighborhood_isOpen (T := (X,,T))). intros x Px. generalize (Hp x Px) ; clear Hp. apply hinhfun. intros L. simple refine (tpair _ _ _). - simple refine (tpair _ _ _). + apply (finite_intersection (pr1 L)). + apply (isOpen_finite_intersection (T := X,,T)). intros m. apply Ht. apply (pr1 (pr2 L)). - split. + exact (pr1 (pr2 (pr2 L))). + exact (pr2 (pr2 (pr2 L))). Qed. (** *** Product of topologies *) Section topologydirprod. Context (U V : TopologicalSpace). Definition topologydirprod := λ (z : U × V) (A : U × V → hProp), (∃ (Ax : U → hProp) (Ay : V → hProp), (Ax (pr1 z) × isOpen Ax) × (Ay (pr2 z) × isOpen Ay) × (∏ x y, Ax x → Ay y → A (x,,y))). Lemma topologydirprod_imply : ∏ x : U × V, isfilter_imply (topologydirprod x). Proof. intros x A B H. apply hinhfun. intros AB. exists (pr1 AB), (pr1 (pr2 AB)) ; split ; [ | split]. - exact (pr1 (pr2 (pr2 AB))). - exact (pr1 (pr2 (pr2 (pr2 AB)))). - intros x' y' Hx' Hy'. now apply H, (pr2 (pr2 (pr2 (pr2 AB)))). Qed. Lemma topologydirprod_htrue : ∏ x : U × V, isfilter_htrue (topologydirprod x). Proof. intros z. apply hinhpr. exists (λ _, htrue), (λ _, htrue). repeat split. - apply isOpen_htrue. - apply isOpen_htrue. Qed. Lemma topologydirprod_and : ∏ x : U × V, isfilter_and (topologydirprod x). Proof. intros z A B. apply hinhfun2. intros A' B'. exists (λ x, pr1 A' x ∧ pr1 B' x), (λ y, pr1 (pr2 A') y ∧ pr1 (pr2 B') y). repeat split. - apply (pr1 (pr1 (pr2 (pr2 A')))). - apply (pr1 (pr1 (pr2 (pr2 B')))). - apply isOpen_and. + apply (pr2 (pr1 (pr2 (pr2 A')))). + apply (pr2 (pr1 (pr2 (pr2 B')))). - apply (pr1 (pr1 (pr2 (pr2 (pr2 A'))))). - apply (pr1 (pr1 (pr2 (pr2 (pr2 B'))))). - apply isOpen_and. + apply (pr2 (pr1 (pr2 (pr2 (pr2 A'))))). + apply (pr2 (pr1 (pr2 (pr2 (pr2 B'))))). - apply (pr2 (pr2 (pr2 (pr2 A')))). + apply (pr1 X). + apply (pr1 X0). - apply (pr2 (pr2 (pr2 (pr2 B')))). + apply (pr2 X). + apply (pr2 X0). Qed. Lemma topologydirprod_point : ∏ (x : U × V) (P : U × V → hProp), topologydirprod x P → P x. Proof. intros xy A. apply hinhuniv. intros A'. apply (pr2 (pr2 (pr2 (pr2 A')))). - exact (pr1 (pr1 (pr2 (pr2 A')))). - exact (pr1 (pr1 (pr2 (pr2 (pr2 A'))))). Qed. Lemma topologydirprod_neighborhood : ∏ (x : U × V) (P : U × V → hProp), topologydirprod x P → ∃ Q : U × V → hProp, topologydirprod x Q × (∏ y : U × V, Q y → topologydirprod y P). Proof. intros xy P. apply hinhfun. intros A'. exists (λ z, pr1 A' (pr1 z) ∧ pr1 (pr2 A') (pr2 z)). split. - apply hinhpr. exists (pr1 A'), (pr1 (pr2 A')). split. + exact (pr1 (pr2 (pr2 A'))). + split. * exact (pr1 (pr2 (pr2 (pr2 A')))). * intros x' y' Ax' Ay'. now split. - intros z Az. apply hinhpr. exists (pr1 A'), (pr1 (pr2 A')). repeat split. + exact (pr1 Az). + exact (pr2 (pr1 (pr2 (pr2 A')))). + exact (pr2 Az). + exact (pr2 (pr1 (pr2 (pr2 (pr2 A'))))). + exact (pr2 (pr2 (pr2 (pr2 A')))). Qed. End topologydirprod. Definition TopologyDirprod (U V : TopologicalSpace) : TopologicalSpace. Proof. simple refine (TopologyFromNeighborhood _ _). - apply (U × V)%set. - apply topologydirprod. - repeat split. + apply topologydirprod_imply. + apply topologydirprod_htrue. + apply topologydirprod_and. + apply topologydirprod_point. + apply topologydirprod_neighborhood. Defined. Definition locally2d {T S : TopologicalSpace} (x : T) (y : S) : Filter (T × S) := FilterDirprod (locally x) (locally y). Lemma locally2d_correct {T S : TopologicalSpace} (x : T) (y : S) : ∏ P : T × S → hProp, locally2d x y P <-> locally (T := TopologyDirprod T S) (x,,y) P. Proof. intros P. split ; apply hinhuniv. - intros A. apply TopologyFromNeighborhood_correct. generalize (pr1 (pr2 (pr2 A))) (pr1 (pr2 (pr2 (pr2 A)))). apply hinhfun2. intros Ox Oy. exists (pr1 Ox), (pr1 Oy). repeat split. + exact (pr1 (pr2 Ox)). + exact (pr2 (pr1 Ox)). + exact (pr1 (pr2 Oy)). + exact (pr2 (pr1 Oy)). + intros x' y' Hx' Hy'. apply (pr2 (pr2 (pr2 (pr2 A)))). * now apply (pr2 (pr2 Ox)). * now apply (pr2 (pr2 Oy)). - intros O. generalize (pr2 (pr1 O) _ (pr1 (pr2 O))). apply hinhfun. intros A. exists (pr1 A), (pr1 (pr2 A)). repeat split. + apply (pr2 (neighborhood_isOpen _)). * exact (pr2 (pr1 (pr2 (pr2 A)))). * exact (pr1 (pr1 (pr2 (pr2 A)))). + apply (pr2 (neighborhood_isOpen _)). * exact (pr2 (pr1 (pr2 (pr2 (pr2 A))))). * exact (pr1 (pr1 (pr2 (pr2 (pr2 A))))). + intros x' y' Ax' Ay'. apply (pr2 (pr2 O)). now apply (pr2 (pr2 (pr2 (pr2 A)))). Qed. (** *** Topology on a subtype *) Section topologysubtype. Context {T : TopologicalSpace} (dom : T → hProp). Definition topologysubtype := λ (x : ∑ x : T, dom x) (A : (∑ x0 : T, dom x0) → hProp), ∃ B : T → hProp, (B (pr1 x) × isOpen B) × (∏ y : ∑ x0 : T, dom x0, B (pr1 y) → A y). Lemma topologysubtype_imply : ∏ x : ∑ x : T, dom x, isfilter_imply (topologysubtype x). Proof. intros x A B H. apply hinhfun. intros A'. exists (pr1 A'). split. - exact (pr1 (pr2 A')). - intros y Hy. now apply H, (pr2 (pr2 A')). Qed. Lemma topologysubtype_htrue : ∏ x : ∑ x : T, dom x, isfilter_htrue (topologysubtype x). Proof. intros x. apply hinhpr. exists (λ _, htrue). repeat split. now apply isOpen_htrue. Qed. Lemma topologysubtype_and : ∏ x : ∑ x : T, dom x, isfilter_and (topologysubtype x). Proof. intros x A B. apply hinhfun2. intros A' B'. exists (λ x, pr1 A' x ∧ pr1 B' x). repeat split. - exact (pr1 (pr1 (pr2 A'))). - exact (pr1 (pr1 (pr2 B'))). - apply isOpen_and. + exact (pr2 (pr1 (pr2 A'))). + exact (pr2 (pr1 (pr2 B'))). - apply (pr2 (pr2 A')), (pr1 X). - apply (pr2 (pr2 B')), (pr2 X). Qed. Lemma topologysubtype_point : ∏ (x : ∑ x : T, dom x) (P : (∑ x0 : T, dom x0) → hProp), topologysubtype x P → P x. Proof. intros x A. apply hinhuniv. intros B. apply (pr2 (pr2 B)), (pr1 (pr1 (pr2 B))). Qed. Lemma topologysubtype_neighborhood : ∏ (x : ∑ x : T, dom x) (P : (∑ x0 : T, dom x0) → hProp), topologysubtype x P → ∃ Q : (∑ x0 : T, dom x0) → hProp, topologysubtype x Q × (∏ y : ∑ x0 : T, dom x0, Q y → topologysubtype y P). Proof. intros x A. apply hinhfun. intros B. exists (λ y : ∑ x : T, dom x, pr1 B (pr1 y)). split. - apply hinhpr. exists (pr1 B). split. + exact (pr1 (pr2 B)). + intros. assumption. - intros y By. apply hinhpr. exists (pr1 B). repeat split. + exact By. + exact (pr2 (pr1 (pr2 B))). + exact (pr2 (pr2 B)). Qed. End topologysubtype. Definition TopologySubtype {T : TopologicalSpace} (dom : T → hProp) : TopologicalSpace. Proof. simple refine (TopologyFromNeighborhood _ _). - exact (carrier_subset dom). - apply topologysubtype. - repeat split. + apply topologysubtype_imply. + apply topologysubtype_htrue. + apply topologysubtype_and. + apply topologysubtype_point. + apply topologysubtype_neighborhood. Defined. (** ** Limits in a Topological Set *) Section locally_base. Context {T : TopologicalSpace} (x : T) (base : base_of_neighborhood x). Lemma locally_base_imply : isfilter_imply (neighborhood' x base). Proof. intros A B H Ha. apply (pr2 (neighborhood_equiv _ _ _)). eapply neighborhood_imply. - exact H. - eapply neighborhood_equiv. exact Ha. Qed. Lemma locally_base_htrue : isfilter_htrue (neighborhood' x base). Proof. apply (pr2 (neighborhood_equiv _ _ _)). apply (pr2 (neighborhood_isOpen _)). - apply isOpen_htrue. - apply tt. Qed. Lemma locally_base_and : isfilter_and (neighborhood' x base). Proof. intros A B Ha Hb. apply (pr2 (neighborhood_equiv _ _ _)). eapply neighborhood_and. - eapply neighborhood_equiv, Ha. - eapply neighborhood_equiv, Hb. Qed. End locally_base. Definition locally_base {T : TopologicalSpace} (x : T) (base : base_of_neighborhood x) : Filter T. Proof. simple refine (make_Filter _ _ _ _ _). - apply (neighborhood' x base). - apply locally_base_imply. - apply locally_base_htrue. - apply locally_base_and. - intros A Ha. apply neighborhood_equiv in Ha. apply neighborhood_point in Ha. apply hinhpr. now exists x. Defined. (** *** Limit of a filter *) Definition is_filter_lim {T : TopologicalSpace} (F : Filter T) (x : T) := filter_le F (locally x). Definition ex_filter_lim {T : TopologicalSpace} (F : Filter T) := ∃ (x : T), is_filter_lim F x. Definition is_filter_lim_base {T : TopologicalSpace} (F : Filter T) (x : T) base := filter_le F (locally_base x base). Definition ex_filter_lim_base {T : TopologicalSpace} (F : Filter T) := ∃ (x : T) base, is_filter_lim_base F x base. Lemma is_filter_lim_base_correct {T : TopologicalSpace} (F : Filter T) (x : T) base : is_filter_lim_base F x base <-> is_filter_lim F x. Proof. split. - intros Hx P HP. apply (pr2 (neighborhood_equiv _ base _)) in HP. apply Hx. exact HP. - intros Hx P HP. apply neighborhood_equiv in HP. apply Hx. exact HP. Qed. Lemma ex_filter_lim_base_correct {T : TopologicalSpace} (F : Filter T) : ex_filter_lim_base F <-> ex_filter_lim F. Proof. split. - apply hinhfun. intros x. exists (pr1 x). eapply is_filter_lim_base_correct. exact (pr2 (pr2 x)). - apply hinhfun. intros x. exists (pr1 x), (base_of_neighborhood_default (pr1 x)). apply (pr2 (is_filter_lim_base_correct _ _ _)). exact (pr2 x). Qed. (** *** Limit of a function *) Definition is_lim {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) := filterlim f F (locally x). Definition ex_lim {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) := ∃ (x : T), is_lim f F x. Definition is_lim_base {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) base := filterlim f F (locally_base x base). Definition ex_lim_base {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) := ∃ (x : T) base, is_lim_base f F x base. Lemma is_lim_base_correct {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) base : is_lim_base f F x base <-> is_lim f F x. Proof. split. - intros Hx P HP. apply Hx, (pr2 (neighborhood_equiv _ _ _)). exact HP. - intros Hx P HP. eapply Hx, neighborhood_equiv. exact HP. Qed. Lemma ex_lim_base_correct {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) : ex_lim_base f F <-> ex_lim f F. Proof. split. - apply hinhfun. intros x. exists (pr1 x). eapply is_lim_base_correct. exact (pr2 (pr2 x)). - apply hinhfun. intros x. exists (pr1 x), (base_of_neighborhood_default (pr1 x)). apply (pr2 (is_lim_base_correct _ _ _ _)). exact (pr2 x). Qed. (** *** Continuity *) Definition continuous_at {U V : TopologicalSpace} (f : U → V) (x : U) := is_lim f (locally x) (f x). Definition continuous_on {U V : TopologicalSpace} (dom : U → hProp) (f : ∏ (x : U), dom x → V) := ∏ (x : U) (Hx : dom x), ∃ H, is_lim (λ y : (∑ x : U, dom x), f (pr1 y) (pr2 y)) (FilterSubtype (locally x) dom H) (f x Hx). Definition continuous {U V : TopologicalSpace} (f : U → V) := ∏ x : U, continuous_at f x. Lemma isaprop_continuous (x y : TopologicalSpace) (f : x → y) : isaprop (continuous (λ x0 : x, f x0)). Proof. do 3 (apply impred_isaprop; intro). apply propproperty. Qed. Definition continuous_base_at {U V : TopologicalSpace} (f : U → V) (x : U) base_x base_fx := is_lim_base f (locally_base x base_x) (f x) base_fx. (** *** Continuity for 2 variable functions *) Definition continuous2d_at {U V W : TopologicalSpace} (f : U → V → W) (x : U) (y : V) := is_lim (λ z : U × V, f (pr1 z) (pr2 z)) (FilterDirprod (locally x) (locally y)) (f x y). Definition continuous2d {U V W : TopologicalSpace} (f : U → V → W) := ∏ (x : U) (y : V), continuous2d_at f x y. Definition continuous2d_base_at {U V W : TopologicalSpace} (f : U → V → W) (x : U) (y : V) base_x base_y base_fxy := is_lim_base (λ z : U × V, f (pr1 z) (pr2 z)) (FilterDirprod (locally_base x base_x) (locally_base y base_y)) (f x y) base_fxy. (** *** Continuity of basic functions *) Lemma continuous_comp {X : UU} {U V : TopologicalSpace} (f : X → U) (g : U → V) (F : Filter X) (l : U) : is_lim f F l → continuous_at g l → is_lim (funcomp f g) F (g l). Proof. apply filterlim_comp. Qed. Lemma continuous_funcomp {X Y Z : TopologicalSpace} (f : X → Y) (g : Y → Z) : continuous f → continuous g → continuous (funcomp f g). Proof. intros Hf Hg x. refine (continuous_comp _ _ _ _ _ _). - apply Hf. - apply Hg. Qed. Lemma continuous2d_comp {X : UU} {U V W : TopologicalSpace} (f : X → U) (g : X → V) (h : U → V → W) (F : Filter X) (lf : U) (lg : V) : is_lim f F lf → is_lim g F lg → continuous2d_at h lf lg → is_lim (λ x, h (f x) (g x)) F (h lf lg). Proof. intros Hf Hg. apply (filterlim_comp (λ x, (f x ,, g x))). intros P. apply hinhuniv. intros Hp. generalize (filter_and F _ _ (Hf _ (pr1 (pr2 (pr2 Hp)))) (Hg _ (pr1 (pr2 (pr2 (pr2 Hp)))))). apply (filter_imply F). intros x Hx. apply (pr2 (pr2 (pr2 (pr2 Hp)))). - exact (pr1 Hx). - exact (pr2 Hx). Qed. Lemma continuous_tpair {U V : TopologicalSpace} : continuous2d (W := TopologyDirprod U V) (λ (x : U) (y : V), (x,,y)). Proof. intros x y P. apply hinhuniv. intros O. simple refine (filter_imply _ _ _ _ _). - exact (pr1 O). - exact (pr2 (pr2 O)). - generalize (pr2 (pr1 O) _ (pr1 (pr2 O))). apply hinhfun. intros Ho. exists (pr1 Ho), (pr1 (pr2 Ho)). repeat split. + apply (pr2 (neighborhood_isOpen _)). * exact (pr2 (pr1 (pr2 (pr2 Ho)))). * exact (pr1 (pr1 (pr2 (pr2 Ho)))). + apply (pr2 (neighborhood_isOpen _)). * exact (pr2 (pr1 (pr2 (pr2 (pr2 Ho))))). * exact (pr1 (pr1 (pr2 (pr2 (pr2 Ho))))). + exact (pr2 (pr2 (pr2 (pr2 Ho)))). Qed. Lemma continuous_pr1 {U V : TopologicalSpace} : continuous (U := TopologyDirprod U V) (λ (xy : U × V), pr1 xy). Proof. intros xy P. apply hinhuniv. intros O. simple refine (filter_imply _ _ _ _ _). - exact (pr1 (pr1 O)). - exact (pr2 (pr2 O)). - apply hinhpr. use tpair. + use tpair. * apply (λ xy : U × V, pr1 O (pr1 xy)). * intros xy' Oxy. apply hinhpr. exists (pr1 O), (λ _, htrue). repeat split. ** exact Oxy. ** exact (pr2 (pr1 O)). ** exact isOpen_htrue. ** intros. assumption. + repeat split. * exact (pr1 (pr2 O)). * intros. assumption. Qed. Lemma continuous_pr2 {U V : TopologicalSpace} : continuous (U := TopologyDirprod U V) (λ (xy : U × V), pr2 xy). Proof. intros xy P. apply hinhuniv. intros O. simple refine (filter_imply _ _ _ _ _). - exact (pr1 (pr1 O)). - exact (pr2 (pr2 O)). - apply hinhpr. use tpair. + use tpair. * apply (λ xy : U × V, pr1 O (pr2 xy)). * intros xy' Oxy. apply hinhpr. exists (λ _, htrue), (pr1 O). repeat split. ** exact isOpen_htrue. ** exact Oxy. ** exact (pr2 (pr1 O)). ** intros. assumption. + repeat split. * exact (pr1 (pr2 O)). * intros. assumption. Qed. (** ** Topology in algebraic structures *) Definition isTopological_monoid (X : monoid) (is : isTopologicalSpace X) := continuous2d (U := (pr11 X) ,, is) (V := (pr11 X) ,, is) (W := (pr11 X) ,, is) BinaryOperations.op. Definition Topological_monoid := ∑ (X : monoid) (is : isTopologicalSpace X), isTopological_monoid X is. Definition isTopological_gr (X : gr) (is : isTopologicalSpace X) := isTopological_monoid X is × continuous (U := (pr11 X) ,, is) (V := (pr11 X) ,, is) (grinv X). Definition Topological_gr := ∑ (X : gr) is, isTopological_gr X is. Definition isTopological_rig (X : rig) (is : isTopologicalSpace X) := isTopological_monoid (rigaddabmonoid X) is × isTopological_monoid (rigmultmonoid X) is. Definition Topological_rig := ∑ (X : rig) is, isTopological_rig X is. Definition isTopological_ring (X : ring) (is : isTopologicalSpace X) := isTopological_gr (ringaddabgr X) is × isTopological_monoid (rigmultmonoid X) is. Definition Topological_ring := ∑ (X : ring) is, isTopological_ring X is. Definition isTopological_DivRig (X : DivRig) (is : isTopologicalSpace X) := isTopological_rig (pr1 X) is × continuous_on (U := (pr111 X) ,, is) (V := (pr111 X) ,, is) (λ x : X, make_hProp (x != 0%dr) (isapropneg _)) (λ x Hx, invDivRig (x,,Hx)). Definition Topological_DivRig := ∑ (X : DivRig) is, isTopological_DivRig X is. Definition isTopological_fld (X : fld) (is : isTopologicalSpace X) := isTopological_ring (pr1 X) is × continuous_on (U := (pr111 X) ,, is) (V := (pr111 X) ,, is) (λ x : X, make_hProp (x != 0%ring) (isapropneg _)) fldmultinv. Definition Topological_fld := ∑ (X : fld) is, isTopological_fld X is. Definition isTopological_ConstructiveDivisionRig (X : ConstructiveDivisionRig) (is : isTopologicalSpace X) := isTopological_rig X is × continuous_on (U := (pr111 X) ,, is) (V := (pr111 X) ,, is) (λ x : X, (x ≠ 0)%CDR) CDRinv. Definition Topological_ConstructiveDivisionRig := ∑ (X : ConstructiveDivisionRig) is, isTopological_ConstructiveDivisionRig X is. Definition isTopological_ConstructiveField (X : ConstructiveField) (is : isTopologicalSpace X) := isTopological_ring X is × continuous_on (U := (pr111 X) ,, is) (V := (pr111 X) ,, is) (λ x : X, (x ≠ 0)%CF) CFinv. Definition Topological_ConstructiveField := ∑ (X : ConstructiveField) is, isTopological_ConstructiveField X is. UniMath-20231010/UniMath/dune000066400000000000000000000005071451125700300155340ustar00rootroot00000000000000 (include_subdirs qualified) (coq.theory (name UniMath) (package coq-unimath) (flags :standard -noinit -indices-matter -type-in-type -w -notation-overridden)) (rule (deps (source_tree .)) (action (with-stdout-to All.v (run %{project_root}/util/generate-exports UniMath "%{deps}")))) UniMath-20231010/_config.yml000066400000000000000000000000331451125700300154320ustar00rootroot00000000000000theme: jekyll-theme-minimalUniMath-20231010/build/000077500000000000000000000000001451125700300144065ustar00rootroot00000000000000UniMath-20231010/build/Makefile-configuration-template000066400000000000000000000027661451125700300225370ustar00rootroot00000000000000# -*- makefile-gmake -*- # To configure the makefile, copy this file (Makefile-configuration-template) # to Makefile-configuration (in this directory) and then edit it. Do not edit # this file, for it is just a template, and you might accidentally check it in. # The first thing to change, when editing this file, is to remove this comment. # To remove the configurations, it is best to delete all the text in your copy # of this file, rather than removing the file, so the timestamp on the newly # empty file will trigger "make" to remake the files that depend on the # configuration. # The Boolean values are "yes" and "no". ############################################################################# # Whether to build coq by checking out the appropriate git repository and compiling # it with ocamlc and gcc: BUILD_COQ = yes # When coq is being built, whether also to build coqide. BUILD_COQIDE = no # When coq is being built, whether also to build it in a way useful for debugging Coq DEBUG_COQ = no # When BUILD_COQ is "no", give the path to the coq binary "coqtop", including the # final "/" (if nonempty), unless it is on the PATH: COQBIN = # List here any packages you'd like to try to build on a test basis. # When the packages work, add them to the list in ../Makefile. PACKAGES = # Memory limit, expressed as a multiple of 1024 bytes, for the command "ulimit -v". MEMORY_LIMIT = 2500000 # Whether to apply the memory limit. This will be set to "yes" when a pull request is tested. LIMIT_MEMORY = no UniMath-20231010/coq-unimath.opam000066400000000000000000000007271451125700300164200ustar00rootroot00000000000000opam-version: "2.0" maintainer: "The UniMath Development Team" homepage: "https://github.com/UniMath/UniMath" dev-repo: "git+https://github.com/UniMath/UniMath.git" bug-reports: "https://github.com/UniMath/UniMath/issues" license: "Similar to MIT license" authors: ["The UniMath Development Team"] build: [make "BUILD_COQ=no" "-j%{jobs}%"] install: [make "BUILD_COQ=no" "install"] depends: [ "ocaml" "coq" {>= "8.16.1"} ] synopsis: "Library of Univalent Mathematics" UniMath-20231010/dune-project000066400000000000000000000000571451125700300156330ustar00rootroot00000000000000(lang dune 3.5) (using coq 0.6) (name UniMath) UniMath-20231010/emacs/000077500000000000000000000000001451125700300143775ustar00rootroot00000000000000UniMath-20231010/emacs/agda/000077500000000000000000000000001451125700300152735ustar00rootroot00000000000000UniMath-20231010/emacs/agda/LICENSE000066400000000000000000000027701451125700300163060ustar00rootroot00000000000000Copyright (c) 2005-2015 Ulf Norell, Andreas Abel, Nils Anders Danielsson, Andrés Sicard-Ramírez, Dominique Devriese, Péter Divianszki, Francesco Mazzoli, Stevan Andjelkovic, Daniel Gustafsson, Alan Jeffrey, Makoto Takeyama, Andrea Vezzosi, Nicolas Pouillard, James Chapman, Jean-Philippe Bernardy, Fredrik Lindblad, Nobuo Yamashita, Fredrik Nordvall Forsberg, Patrik Jansson, Guilhem Moulin, Stefan Monnier, Marcin Benke, Olle Fredriksson, Darin Morrison, Jesper Cockx, Wolfram Kahl, Catarina Coquand Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. UniMath-20231010/emacs/agda/agda-input.el000066400000000000000000001054121451125700300176510ustar00rootroot00000000000000;;; agda-input.el --- The Agda input method ;;; Commentary: ;; A highly customisable input method which can inherit from other ;; Quail input methods. By default the input method is geared towards ;; the input of mathematical and other symbols in Agda programs. ;; ;; Use M-x customize-group agda-input to customise this input method. ;; Note that the functions defined under "Functions used to tweak ;; translation pairs" below can be used to tweak both the key ;; translations inherited from other input methods as well as the ;; ones added specifically for this one. ;; ;; Use agda-input-show-translations to see all the characters which ;; can be typed using this input method (except for those ;; corresponding to ASCII characters). ;;; Code: (require 'quail) (require 'cl) ;; Quail is quite stateful, so be careful when editing this code. Note ;; that with-temp-buffer is used below whenever buffer-local state is ;; modified. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utility functions (defun agda-input-concat-map (f xs) "Concat (map F XS)." (apply 'append (mapcar f xs))) (defun agda-input-to-string-list (s) "Convert a string S to a list of one-character strings, after removing all space and newline characters." (agda-input-concat-map (lambda (c) (if (member c (string-to-list " \n")) nil (list (string c)))) (string-to-list s))) (defun agda-input-character-range (from to) "A string consisting of the characters from FROM to TO." (let (seq) (dotimes (i (1+ (- to from))) (setq seq (cons (+ from i) seq))) (concat (nreverse seq)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions used to tweak translation pairs ;; lexical-let is used since Elisp lacks lexical scoping. (defun agda-input-compose (f g) "\x -> concatMap F (G x)" (lexical-let ((f1 f) (g1 g)) (lambda (x) (agda-input-concat-map f1 (funcall g1 x))))) (defun agda-input-or (f g) "\x -> F x ++ G x" (lexical-let ((f1 f) (g1 g)) (lambda (x) (append (funcall f1 x) (funcall g1 x))))) (defun agda-input-nonempty () "Only keep pairs with a non-empty first component." (lambda (x) (if (> (length (car x)) 0) (list x)))) (defun agda-input-prepend (prefix) "Prepend PREFIX to all key sequences." (lexical-let ((prefix1 prefix)) (lambda (x) `((,(concat prefix1 (car x)) . ,(cdr x)))))) (defun agda-input-prefix (prefix) "Only keep pairs whose key sequence starts with PREFIX." (lexical-let ((prefix1 prefix)) (lambda (x) (if (equal (substring (car x) 0 (length prefix1)) prefix1) (list x))))) (defun agda-input-suffix (suffix) "Only keep pairs whose key sequence ends with SUFFIX." (lexical-let ((suffix1 suffix)) (lambda (x) (if (equal (substring (car x) (- (length (car x)) (length suffix1))) suffix1) (list x))))) (defun agda-input-drop (ss) "Drop pairs matching one of the given key sequences. SS should be a list of strings." (lexical-let ((ss1 ss)) (lambda (x) (unless (member (car x) ss1) (list x))))) (defun agda-input-drop-beginning (n) "Drop N characters from the beginning of each key sequence." (lexical-let ((n1 n)) (lambda (x) `((,(substring (car x) n1) . ,(cdr x)))))) (defun agda-input-drop-end (n) "Drop N characters from the end of each key sequence." (lexical-let ((n1 n)) (lambda (x) `((,(substring (car x) 0 (- (length (car x)) n1)) . ,(cdr x)))))) (defun agda-input-drop-prefix (prefix) "Only keep pairs whose key sequence starts with PREFIX. This prefix is dropped." (agda-input-compose (agda-input-drop-beginning (length prefix)) (agda-input-prefix prefix))) (defun agda-input-drop-suffix (suffix) "Only keep pairs whose key sequence ends with SUFFIX. This suffix is dropped." (lexical-let ((suffix1 suffix)) (agda-input-compose (agda-input-drop-end (length suffix1)) (agda-input-suffix suffix1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization ;; The :set keyword is set to 'agda-input-incorporate-changed-setting ;; so that the input method gets updated immediately when users ;; customize it. However, the setup functions cannot be run before all ;; variables have been defined. Hence the :initialize keyword is set to ;; 'custom-initialize-default to ensure that the setup is not performed ;; until agda-input-setup is called at the end of this file. (defgroup agda-input nil "The Agda input method. After tweaking these settings you may want to inspect the resulting translations using `agda-input-show-translations'." :group 'agda2 :group 'leim) (defcustom agda-input-tweak-all '(agda-input-compose (agda-input-prepend "\\") (agda-input-nonempty)) "An expression yielding a function which can be used to tweak all translations before they are included in the input method. The resulting function (if non-nil) is applied to every \(KEY-SEQUENCE . TRANSLATION) pair and should return a list of such pairs. (Note that the translations can be anything accepted by `quail-defrule'.) If you change this setting manually (without using the customization buffer) you need to call `agda-input-setup' in order for the change to take effect." :group 'agda-input :set 'agda-input-incorporate-changed-setting :initialize 'custom-initialize-default :type 'sexp) (defcustom agda-input-inherit `(("TeX" . (agda-input-compose (agda-input-drop '("geq" "leq" "bullet" "qed" "par")) (agda-input-or (agda-input-drop-prefix "\\") (agda-input-or (agda-input-compose (agda-input-drop '("^l" "^o" "^r" "^v")) (agda-input-prefix "^")) (agda-input-prefix "_"))))) ) "A list of Quail input methods whose translations should be inherited by the Agda input method (with the exception of translations corresponding to ASCII characters). The list consists of pairs (qp . tweak), where qp is the name of a Quail package, and tweak is an expression of the same kind as `agda-input-tweak-all' which is used to tweak the translation pairs of the input method. The inherited translation pairs are added last, after `agda-input-user-translations' and `agda-input-translations'. If you change this setting manually (without using the customization buffer) you need to call `agda-input-setup' in order for the change to take effect." :group 'agda-input :set 'agda-input-incorporate-changed-setting :initialize 'custom-initialize-default :type '(repeat (cons (string :tag "Quail package") (sexp :tag "Tweaking function")))) (defcustom agda-input-translations (let ((max-lisp-eval-depth 2800)) `( ;; Equality and similar symbols. ("eq" . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕")) ("eqn" . ,(agda-input-to-string-list "≠≁ ≉ ≄ ≇≆ ≢ ≭ ")) ("=n" . ("≠")) ("~" . ("∼")) ("~n" . ("≁")) ("~~" . ("≈")) ("~~n" . ("≉")) ("~~~" . ("≋")) (":~" . ("∻")) ("~-" . ("≃")) ("~-n" . ("≄")) ("-~" . ("≂")) ("~=" . ("≅")) ("~=n" . ("≇")) ("~~-" . ("≊")) ("==" . ("≡")) ("==n" . ("≢")) ("===" . ("≣")) (".=" . ("≐")) (".=." . ("≑")) (":=" . ("≔")) ("=:" . ("≕")) ("=o" . ("≗")) ("(=" . ("≘")) ("and=" . ("≙")) ("or=" . ("≚")) ("*=" . ("≛")) ("t=" . ("≜")) ("def=" . ("≝")) ("m=" . ("≞")) ("?=" . ("≟")) ;; Inequality and similar symbols. ("leq" . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞")) ("leqn" . ,(agda-input-to-string-list "≮ ≰≨≴⋦≸⊀ ⋨⊄⊈⊊ ⋢⋤ ⋪⋬ ⋠")) ("geq" . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟")) ("geqn" . ,(agda-input-to-string-list "≯ ≱≩≵⋧≹⊁ ⋩⊅⊉⊋ ⋣⋥ ⋫⋭ ⋡")) ("<=" . ("≤")) (">=" . ("≥")) ("<=n" . ("≰")) (">=n" . ("≱")) ("len" . ("≰")) ("gen" . ("≱")) ("n" . ("≯")) ("<~" . ("≲")) (">~" . ("≳")) ("<~n" . ("⋦")) (">~n" . ("⋧")) ("<~nn" . ("≴")) (">~nn" . ("≵")) ("sub" . ("⊂")) ("sup" . ("⊃")) ("subn" . ("⊄")) ("supn" . ("⊅")) ("sub=" . ("⊆")) ("sup=" . ("⊇")) ("sub=n" . ("⊈")) ("sup=n" . ("⊉")) ("squb" . ("⊏")) ("squp" . ("⊐")) ("squb=" . ("⊑")) ("squp=" . ("⊒")) ("squb=n" . ("⋢")) ("squp=n" . ("⋣")) ;; Set membership etc. ("member" . ,(agda-input-to-string-list "∈∉∊∋∌∍⋲⋳⋴⋵⋶⋷⋸⋹⋺⋻⋼⋽⋾⋿")) ("inn" . ("∉")) ("nin" . ("∌")) ;; Intersections, unions etc. ("intersection" . ,(agda-input-to-string-list "∩⋂∧⋀⋏⨇⊓⨅⋒∏ ⊼ ⨉")) ("union" . ,(agda-input-to-string-list "∪⋃∨⋁⋎⨈⊔⨆⋓∐⨿⊽⊻⊍⨃⊎⨄⊌∑⅀")) ("and" . ("∧")) ("or" . ("∨")) ("And" . ("⋀")) ("Or" . ("⋁")) ("i" . ("∩")) ("un" . ("∪")) ("u+" . ("⊎")) ("u." . ("⊍")) ("I" . ("⋂")) ("Un" . ("⋃")) ("U+" . ("⨄")) ("U." . ("⨃")) ("glb" . ("⊓")) ("lub" . ("⊔")) ("Glb" . ("⨅")) ("Lub" . ("⨆")) ;; Entailment etc. ("entails" . ,(agda-input-to-string-list "⊢⊣⊤⊥⊦⊧⊨⊩⊪⊫⊬⊭⊮⊯")) ("|-" . ("⊢")) ("|-n" . ("⊬")) ("-|" . ("⊣")) ("|=" . ("⊨")) ("|=n" . ("⊭")) ("||-" . ("⊩")) ("||-n" . ("⊮")) ("||=" . ("⊫")) ("||=n" . ("⊯")) ("|||-" . ("⊪")) ;; Divisibility, parallelity. ("|" . ("∣")) ("|n" . ("∤")) ("||" . ("∥")) ("||n" . ("∦")) ;; Some symbols from logic and set theory. ("all" . ("∀")) ("ex" . ("∃")) ("exn" . ("∄")) ("0" . ("∅")) ("C" . ("∁")) ;; Corners, ceilings and floors. ("c" . ,(agda-input-to-string-list "⌜⌝⌞⌟⌈⌉⌊⌋")) ("cu" . ,(agda-input-to-string-list "⌜⌝ ⌈⌉ ")) ("cl" . ,(agda-input-to-string-list " ⌞⌟ ⌊⌋")) ("cul" . ("⌜")) ("cuL" . ("⌈")) ("cur" . ("⌝")) ("cuR" . ("⌉")) ("cll" . ("⌞")) ("clL" . ("⌊")) ("clr" . ("⌟")) ("clR" . ("⌋")) ;; Various operators/symbols. ("qed" . ("∎")) ("x" . ("×")) ("o" . ("∘")) ("comp" . ("∘")) ("." . ("∙")) ("*" . ("⋆")) (".+" . ("∔")) (".-" . ("∸")) (":" . ("∶")) ("::" . ("∷")) ("::-" . ("∺")) ("-:" . ("∹")) ("+ " . ("⊹")) ("surd3" . ("∛")) ("surd4" . ("∜")) ("increment" . ("∆")) ("inf" . ("∞")) ("&" . ("⅋")) ;; Circled operators. ("o+" . ("⊕")) ("o--" . ("⊖")) ("ox" . ("⊗")) ("o/" . ("⊘")) ("o." . ("⊙")) ("oo" . ("⊚")) ("o*" . ("⊛")) ("o=" . ("⊜")) ("o-" . ("⊝")) ("O+" . ("⨁")) ("Ox" . ("⨂")) ("O." . ("⨀")) ("O*" . ("⍟")) ;; Boxed operators. ("b+" . ("⊞")) ("b-" . ("⊟")) ("bx" . ("⊠")) ("b." . ("⊡")) ;; Various symbols. ("integral" . ,(agda-input-to-string-list "∫∬∭∮∯∰∱∲∳")) ("angle" . ,(agda-input-to-string-list "∟∡∢⊾⊿")) ("join" . ,(agda-input-to-string-list "⋈⋉⋊⋋⋌⨝⟕⟖⟗")) ;; Arrows. ("l" . ,(agda-input-to-string-list "←⇐⇚⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹ ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲ ")) ("r" . ,(agda-input-to-string-list "→⇒⇛⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴ ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸")) ("u" . ,(agda-input-to-string-list "↑⇑⟰⇈⇅↥⇧↟↿↾⇡⇞ ↰↱➦ ⇪⇫⇬⇭⇮⇯ ")) ("d" . ,(agda-input-to-string-list "↓⇓⟱⇊⇵↧⇩↡⇃⇂⇣⇟ ↵↲↳➥ ↯ ")) ("ud" . ,(agda-input-to-string-list "↕⇕ ↨⇳ ")) ("lr" . ,(agda-input-to-string-list "↔⇔ ⇼↭⇿⟷⟺↮⇎⇹ ")) ("ul" . ,(agda-input-to-string-list "↖⇖ ⇱↸ ")) ("ur" . ,(agda-input-to-string-list "↗⇗ ➶➹➚ ")) ("dr" . ,(agda-input-to-string-list "↘⇘ ⇲ ➴➷➘ ")) ("dl" . ,(agda-input-to-string-list "↙⇙ ")) ("l-" . ("←")) ("<-" . ("←")) ("l=" . ("⇐")) ("r-" . ("→")) ("->" . ("→")) ("r=" . ("⇒")) ("=>" . ("⇒")) ("u-" . ("↑")) ("u=" . ("⇑")) ("d-" . ("↓")) ("d=" . ("⇓")) ("ud-" . ("↕")) ("ud=" . ("⇕")) ("lr-" . ("↔")) ("<->" . ("↔")) ("lr=" . ("⇔")) ("<=>" . ("⇔")) ("ul-" . ("↖")) ("ul=" . ("⇖")) ("ur-" . ("↗")) ("ur=" . ("⇗")) ("dr-" . ("↘")) ("dr=" . ("⇘")) ("dl-" . ("↙")) ("dl=" . ("⇙")) ("l==" . ("⇚")) ("l-2" . ("⇇")) ("l-r-" . ("⇆")) ("r==" . ("⇛")) ("r-2" . ("⇉")) ("r-3" . ("⇶")) ("r-l-" . ("⇄")) ("u==" . ("⟰")) ("u-2" . ("⇈")) ("u-d-" . ("⇅")) ("d==" . ("⟱")) ("d-2" . ("⇊")) ("d-u-" . ("⇵")) ("l--" . ("⟵")) ("<--" . ("⟵")) ("l~" . ("↜" "⇜")) ("r--" . ("⟶")) ("-->" . ("⟶")) ("r~" . ("↝" "⇝" "⟿")) ("lr--" . ("⟷")) ("<-->" . ("⟷")) ("lr~" . ("↭")) ("l-n" . ("↚")) ("<-n" . ("↚")) ("l=n" . ("⇍")) ("r-n" . ("↛")) ("->n" . ("↛")) ("r=n" . ("⇏")) ("=>n" . ("⇏")) ("lr-n" . ("↮")) ("<->n" . ("↮")) ("lr=n" . ("⇎")) ("<=>n" . ("⇎")) ("l-|" . ("↤")) ("ll-" . ("↞")) ("r-|" . ("↦")) ("rr-" . ("↠")) ("u-|" . ("↥")) ("uu-" . ("↟")) ("d-|" . ("↧")) ("dd-" . ("↡")) ("ud-|" . ("↨")) ("l->" . ("↢")) ("r->" . ("↣")) ("r-o" . ("⊸")) ("-o" . ("⊸")) ("dz" . ("↯")) ;; Ellipsis. ("..." . ,(agda-input-to-string-list "⋯⋮⋰⋱")) ;; Box-drawing characters. ("---" . ,(agda-input-to-string-list "─│┌┐└┘├┤┬┼┴╴╵╶╷╭╮╯╰╱╲╳")) ("--=" . ,(agda-input-to-string-list "═║╔╗╚╝╠╣╦╬╩ ╒╕╘╛╞╡╤╪╧ ╓╖╙╜╟╢╥╫╨")) ("--_" . ,(agda-input-to-string-list "━┃┏┓┗┛┣┫┳╋┻╸╹╺╻ ┍┯┑┕┷┙┝┿┥┎┰┒┖┸┚┠╂┨┞╀┦┟╁┧┢╈┪┡╇┩ ┮┭┶┵┾┽┲┱┺┹╊╉╆╅╄╃ ╿╽╼╾")) ("--." . ,(agda-input-to-string-list "╌╎┄┆┈┊ ╍╏┅┇┉┋")) ;; Triangles. ;; Big/small, black/white. ("t" . ,(agda-input-to-string-list "◂◃◄◅▸▹►▻▴▵▾▿◢◿◣◺◤◸◥◹")) ("T" . ,(agda-input-to-string-list "◀◁▶▷▲△▼▽◬◭◮")) ("tb" . ,(agda-input-to-string-list "◂▸▴▾◄►◢◣◤◥")) ("tw" . ,(agda-input-to-string-list "◃▹▵▿◅▻◿◺◸◹")) ("Tb" . ,(agda-input-to-string-list "◀▶▲▼")) ("Tw" . ,(agda-input-to-string-list "◁▷△▽")) ;; Squares. ("sq" . ,(agda-input-to-string-list "■□◼◻◾◽▣▢▤▥▦▧▨▩◧◨◩◪◫◰◱◲◳")) ("sqb" . ,(agda-input-to-string-list "■◼◾")) ("sqw" . ,(agda-input-to-string-list "□◻◽")) ("sq." . ("▣")) ("sqo" . ("▢")) ;; Rectangles. ("re" . ,(agda-input-to-string-list "▬▭▮▯")) ("reb" . ,(agda-input-to-string-list "▬▮")) ("rew" . ,(agda-input-to-string-list "▭▯")) ;; Parallelograms. ("pa" . ,(agda-input-to-string-list "▰▱")) ("pab" . ("▰")) ("paw" . ("▱")) ;; Diamonds. ("di" . ,(agda-input-to-string-list "◆◇◈")) ("dib" . ("◆")) ("diw" . ("◇")) ("di." . ("◈")) ;; Circles. ("ci" . ,(agda-input-to-string-list "●○◎◌◯◍◐◑◒◓◔◕◖◗◠◡◴◵◶◷⚆⚇⚈⚉")) ("cib" . ("●")) ("ciw" . ("○")) ("ci." . ("◎")) ("ci.." . ("◌")) ("ciO" . ("◯")) ;; Stars. ("st" . ,(agda-input-to-string-list "⋆✦✧✶✴✹ ★☆✪✫✯✰✵✷✸")) ("st4" . ,(agda-input-to-string-list "✦✧")) ("st6" . ("✶")) ("st8" . ("✴")) ("st12" . ("✹")) ;; Blackboard bold letters. ("bn" . ("ℕ")) ("bz" . ("ℤ")) ("bq" . ("ℚ")) ("br" . ("ℝ")) ("bc" . ("ℂ")) ("bp" . ("ℙ")) ("bb" . ("𝔹")) ("bsum" . ("⅀")) ;; Blackboard bold numbers. ("b0" . ("𝟘")) ("b1" . ("𝟙")) ("b2" . ("𝟚")) ("b3" . ("𝟛")) ("b4" . ("𝟜")) ("b5" . ("𝟝")) ("b6" . ("𝟞")) ("b7" . ("𝟟")) ("b8" . ("𝟠")) ("b9" . ("𝟡")) ;; Parentheses. ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢")) (")" . ,(agda-input-to-string-list ")]}⁆⁾₎〉⎵⟆⟧⟩⟫⦄〉》」』】〕〗〛︶︸︺︼︾﹀﹂﹄﹚﹜﹞）］｝｣")) ("[[" . ("⟦")) ("]]" . ("⟧")) ("<" . ("⟨")) (">" . ("⟩")) ("<<" . ("⟪")) (">>" . ("⟫")) ("{{" . ("⦃")) ("}}" . ("⦄")) ("(b" . ("⟅")) (")b" . ("⟆")) ("lbag" . ("⟅")) ("rbag" . ("⟆")) ;; Primes. ("'" . ,(agda-input-to-string-list "′″‴⁗")) ("`" . ,(agda-input-to-string-list "‵‶‷")) ;; Fractions. ("frac" . ,(agda-input-to-string-list "¼½¾⅓⅔⅕⅖⅗⅘⅙⅚⅛⅜⅝⅞⅟")) ;; Bullets. ("bu" . ,(agda-input-to-string-list "•◦‣⁌⁍")) ("bub" . ("•")) ("buw" . ("◦")) ("but" . ("‣")) ;; Musical symbols. ("note" . ,(agda-input-to-string-list "♩♪♫♬")) ("b" . ("♭")) ("#" . ("♯")) ;; Other punctuation and symbols. ("\\" . ("\\")) ("en" . ("–")) ("em" . ("—")) ("!!" . ("‼")) ("??" . ("⁇")) ("?!" . ("‽" "⁈")) ("!?" . ("⁉")) ("die" . ,(agda-input-to-string-list "⚀⚁⚂⚃⚄⚅")) ("asterisk" . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋")) ("8<" . ("✂" "✄")) ("tie" . ("⁀")) ("undertie" . ("‿")) ("apl" . ,(agda-input-to-string-list "⌶⌷⌸⌹⌺⌻⌼⌽⌾⌿⍀⍁⍂⍃⍄⍅⍆⍇⍈ ⍉⍊⍋⍌⍍⍎⍏⍐⍑⍒⍓⍔⍕⍖⍗⍘⍙⍚⍛ ⍜⍝⍞⍟⍠⍡⍢⍣⍤⍥⍦⍧⍨⍩⍪⍫⍬⍭⍮ ⍯⍰⍱⍲⍳⍴⍵⍶⍷⍸⍹⍺⎕")) ;; Some combining characters. ;; ;; The following combining characters also have (other) ;; translations: ;; ̀ ́ ̂ ̃ ̄ ̆ ̇ ̈ ̋ ̌ ̣ ̧ ̱ ("^--" . ,(agda-input-to-string-list"̅̿")) ("_--" . ,(agda-input-to-string-list"̲̳")) ("^~" . ,(agda-input-to-string-list"̃͌")) ("_~" . ( "̰")) ("^." . ,(agda-input-to-string-list"̇̈⃛⃜")) ("_." . ,(agda-input-to-string-list"̣̤")) ("^l" . ,(agda-input-to-string-list"⃖⃐⃔")) ("^l-" . ( "⃖")) ("^r" . ,(agda-input-to-string-list"⃗⃑⃕")) ("^r-" . ( "⃗")) ("^lr" . ( "⃡")) ("_lr" . ( "͍")) ("^^" . ,(agda-input-to-string-list"̂̑͆")) ("_^" . ,(agda-input-to-string-list"̭̯̪")) ("^v" . ,(agda-input-to-string-list"̌̆")) ("_v" . ,(agda-input-to-string-list"̬̮̺")) ;; Shorter forms of many greek letters plus ƛ. ("Ga" . ("α")) ("GA" . ("Α")) ("Gb" . ("β")) ("GB" . ("Β")) ("Gg" . ("γ")) ("GG" . ("Γ")) ("Gd" . ("δ")) ("GD" . ("Δ")) ("Ge" . ("ε")) ("GE" . ("Ε")) ("Gz" . ("ζ")) ("GZ" . ("Ζ")) ;; \eta \Eta ("Gth" . ("θ")) ("GTH" . ("Θ")) ("Gi" . ("ι")) ("GI" . ("Ι")) ("Gk" . ("κ")) ("GK" . ("Κ")) ("Gl" . ("λ")) ("GL" . ("Λ")) ("Gl-" . ("ƛ")) ("Gm" . ("μ")) ("GM" . ("Μ")) ("Gn" . ("ν")) ("GN" . ("Ν")) ("Gx" . ("ξ")) ("GX" . ("Ξ")) ;; \omicron \Omicron ;; \pi \Pi ("Gr" . ("ρ")) ("GR" . ("Ρ")) ("Gs" . ("σ")) ("GS" . ("Σ")) ("Gt" . ("τ")) ("GT" . ("Τ")) ("Gu" . ("υ")) ("GU" . ("Υ")) ("Gf" . ("φ")) ("GF" . ("Φ")) ("Gc" . ("χ")) ("GC" . ("Χ")) ("Gp" . ("ψ")) ("GP" . ("Ψ")) ("Go" . ("ω")) ("GO" . ("Ω")) ;; Mathematical characters ("MiA" . ("𝐴")) ("MiB" . ("𝐵")) ("MiC" . ("𝐶")) ("MiD" . ("𝐷")) ("MiE" . ("𝐸")) ("MiF" . ("𝐹")) ("MiG" . ("𝐺")) ("MiH" . ("𝐻")) ("MiI" . ("𝐼")) ("MiJ" . ("𝐽")) ("MiK" . ("𝐾")) ("MiL" . ("𝐿")) ("MiM" . ("𝑀")) ("MiN" . ("𝑁")) ("MiO" . ("𝑂")) ("MiP" . ("𝑃")) ("MiQ" . ("𝑄")) ("MiR" . ("𝑅")) ("MiS" . ("𝑆")) ("MiT" . ("𝑇")) ("MiU" . ("𝑈")) ("MiV" . ("𝑉")) ("MiW" . ("𝑊")) ("MiX" . ("𝑋")) ("MiY" . ("𝑌")) ("MiZ" . ("𝑍")) ("Mia" . ("𝑎")) ("Mib" . ("𝑏")) ("Mic" . ("𝑐")) ("Mid" . ("𝑑")) ("Mie" . ("𝑒")) ("Mif" . ("𝑓")) ("Mig" . ("𝑔")) ("Mii" . ("𝑖")) ("Mij" . ("𝑗")) ("Mik" . ("𝑘")) ("Mil" . ("𝑙")) ("Mim" . ("𝑚")) ("Min" . ("𝑛")) ("Mio" . ("𝑜")) ("Mip" . ("𝑝")) ("Miq" . ("𝑞")) ("Mir" . ("𝑟")) ("Mis" . ("𝑠")) ("Mit" . ("𝑡")) ("Miu" . ("𝑢")) ("Miv" . ("𝑣")) ("Miw" . ("𝑤")) ("Mix" . ("𝑥")) ("Miy" . ("𝑦")) ("Miz" . ("𝑧")) ("MIA" . ("𝑨")) ("MIB" . ("𝑩")) ("MIC" . ("𝑪")) ("MID" . ("𝑫")) ("MIE" . ("𝑬")) ("MIF" . ("𝑭")) ("MIG" . ("𝑮")) ("MIH" . ("𝑯")) ("MII" . ("𝑰")) ("MIJ" . ("𝑱")) ("MIK" . ("𝑲")) ("MIL" . ("𝑳")) ("MIM" . ("𝑴")) ("MIN" . ("𝑵")) ("MIO" . ("𝑶")) ("MIP" . ("𝑷")) ("MIQ" . ("𝑸")) ("MIR" . ("𝑹")) ("MIS" . ("𝑺")) ("MIT" . ("𝑻")) ("MIU" . ("𝑼")) ("MIV" . ("𝑽")) ("MIW" . ("𝑾")) ("MIX" . ("𝑿")) ("MIY" . ("𝒀")) ("MIZ" . ("𝒁")) ("MIa" . ("𝒂")) ("MIb" . ("𝒃")) ("MIc" . ("𝒄")) ("MId" . ("𝒅")) ("MIe" . ("𝒆")) ("MIf" . ("𝒇")) ("MIg" . ("𝒈")) ("MIh" . ("𝒉")) ("MIi" . ("𝒊")) ("MIj" . ("𝒋")) ("MIk" . ("𝒌")) ("MIl" . ("𝒍")) ("MIm" . ("𝒎")) ("MIn" . ("𝒏")) ("MIo" . ("𝒐")) ("MIp" . ("𝒑")) ("MIq" . ("𝒒")) ("MIr" . ("𝒓")) ("MIs" . ("𝒔")) ("MIt" . ("𝒕")) ("MIu" . ("𝒖")) ("MIv" . ("𝒗")) ("MIw" . ("𝒘")) ("MIx" . ("𝒙")) ("MIy" . ("𝒚")) ("MIz" . ("𝒛")) ("McA" . ("𝒜")) ("McC" . ("𝒞")) ("McD" . ("𝒟")) ("McG" . ("𝒢")) ("McJ" . ("𝒥")) ("McK" . ("𝒦")) ("McN" . ("𝒩")) ("McO" . ("𝒪")) ("McP" . ("𝒫")) ("McQ" . ("𝒬")) ("McS" . ("𝒮")) ("McT" . ("𝒯")) ("McU" . ("𝒰")) ("McV" . ("𝒱")) ("McW" . ("𝒲")) ("McX" . ("𝒳")) ("McY" . ("𝒴")) ("McZ" . ("𝒵")) ("Mca" . ("𝒶")) ("Mcb" . ("𝒷")) ("Mcc" . ("𝒸")) ("Mcd" . ("𝒹")) ("Mcf" . ("𝒻")) ("Mch" . ("𝒽")) ("Mci" . ("𝒾")) ("Mcj" . ("𝒿")) ("Mck" . ("𝓀")) ("Mcl" . ("𝓁")) ("Mcm" . ("𝓂")) ("Mcn" . ("𝓃")) ("Mcp" . ("𝓅")) ("Mcq" . ("𝓆")) ("Mcr" . ("𝓇")) ("Mcs" . ("𝓈")) ("Mct" . ("𝓉")) ("Mcu" . ("𝓊")) ("Mcv" . ("𝓋")) ("Mcw" . ("𝓌")) ("Mcx" . ("𝓍")) ("Mcy" . ("𝓎")) ("Mcz" . ("𝓏")) ("MCA" . ("𝓐")) ("MCB" . ("𝓑")) ("MCC" . ("𝓒")) ("MCD" . ("𝓓")) ("MCE" . ("𝓔")) ("MCF" . ("𝓕")) ("MCG" . ("𝓖")) ("MCH" . ("𝓗")) ("MCI" . ("𝓘")) ("MCJ" . ("𝓙")) ("MCK" . ("𝓚")) ("MCL" . ("𝓛")) ("MCM" . ("𝓜")) ("MCN" . ("𝓝")) ("MCO" . ("𝓞")) ("MCP" . ("𝓟")) ("MCQ" . ("𝓠")) ("MCR" . ("𝓡")) ("MCS" . ("𝓢")) ("MCT" . ("𝓣")) ("MCU" . ("𝓤")) ("MCV" . ("𝓥")) ("MCW" . ("𝓦")) ("MCX" . ("𝓧")) ("MCY" . ("𝓨")) ("MCZ" . ("𝓩")) ("MCa" . ("𝓪")) ("MCb" . ("𝓫")) ("MCc" . ("𝓬")) ("MCd" . ("𝓭")) ("MCe" . ("𝓮")) ("MCf" . ("𝓯")) ("MCg" . ("𝓰")) ("MCh" . ("𝓱")) ("MCi" . ("𝓲")) ("MCj" . ("𝓳")) ("MCk" . ("𝓴")) ("MCl" . ("𝓵")) ("MCm" . ("𝓶")) ("MCn" . ("𝓷")) ("MCo" . ("𝓸")) ("MCp" . ("𝓹")) ("MCq" . ("𝓺")) ("MCr" . ("𝓻")) ("MCs" . ("𝓼")) ("MCt" . ("𝓽")) ("MCu" . ("𝓾")) ("MCv" . ("𝓿")) ("MCw" . ("𝔀")) ("MCx" . ("𝔁")) ("MCy" . ("𝔂")) ("MCz" . ("𝔃")) ("MfA" . ("𝔄")) ("MfB" . ("𝔅")) ("MfD" . ("𝔇")) ("MfE" . ("𝔈")) ("MfF" . ("𝔉")) ("MfG" . ("𝔊")) ("MfJ" . ("𝔍")) ("MfK" . ("𝔎")) ("MfL" . ("𝔏")) ("MfM" . ("𝔐")) ("MfN" . ("𝔑")) ("MfO" . ("𝔒")) ("MfP" . ("𝔓")) ("MfQ" . ("𝔔")) ("MfS" . ("𝔖")) ("MfT" . ("𝔗")) ("MfU" . ("𝔘")) ("MfV" . ("𝔙")) ("MfW" . ("𝔚")) ("MfX" . ("𝔛")) ("MfY" . ("𝔜")) ("Mfa" . ("𝔞")) ("Mfb" . ("𝔟")) ("Mfc" . ("𝔠")) ("Mfd" . ("𝔡")) ("Mfe" . ("𝔢")) ("Mff" . ("𝔣")) ("Mfg" . ("𝔤")) ("Mfh" . ("𝔥")) ("Mfi" . ("𝔦")) ("Mfj" . ("𝔧")) ("Mfk" . ("𝔨")) ("Mfl" . ("𝔩")) ("Mfm" . ("𝔪")) ("Mfn" . ("𝔫")) ("Mfo" . ("𝔬")) ("Mfp" . ("𝔭")) ("Mfq" . ("𝔮")) ("Mfr" . ("𝔯")) ("Mfs" . ("𝔰")) ("Mft" . ("𝔱")) ("Mfu" . ("𝔲")) ("Mfv" . ("𝔳")) ("Mfw" . ("𝔴")) ("Mfx" . ("𝔵")) ("Mfy" . ("𝔶")) ("Mfz" . ("𝔷")) ;; (Sub / Super) scripts ("_a" . ("ₐ")) ("_e" . ("ₑ")) ("_h" . ("ₕ")) ("_i" . ("ᵢ")) ("_j" . ("ⱼ")) ("_k" . ("ₖ")) ("_l" . ("ₗ")) ("_m" . ("ₘ")) ("_n" . ("ₙ")) ("_o" . ("ₒ")) ("_p" . ("ₚ")) ("_r" . ("ᵣ")) ("_s" . ("ₛ")) ("_t" . ("ₜ")) ("_u" . ("ᵤ")) ("_v" . ("ᵥ")) ("_x" . ("ₓ")) ("^a" . ("ᵃ")) ("^b" . ("ᵇ")) ("^c" . ("ᶜ")) ("^d" . ("ᵈ")) ("^e" . ("ᵉ")) ("^f" . ("ᶠ")) ("^g" . ("ᵍ")) ("^h" . ("ʰ")) ("^i" . ("ⁱ")) ("^j" . ("ʲ")) ("^k" . ("ᵏ")) ("^l" . ("ˡ")) ("^m" . ("ᵐ")) ("^n" . ("ⁿ")) ("^o" . ("ᵒ")) ("^p" . ("ᵖ")) ("^r" . ("ʳ")) ("^s" . ("ˢ")) ("^t" . ("ᵗ")) ("^u" . ("ᵘ")) ("^v" . ("ᵛ")) ("^w" . ("ʷ")) ("^x" . ("ˣ")) ("^y" . ("ʸ")) ("^z" . ("ᶻ")) ("^A" . ("ᴬ")) ("^B" . ("ᴮ")) ("^D" . ("ᴰ")) ("^E" . ("ᴱ")) ("^G" . ("ᴳ")) ("^H" . ("ᴴ")) ("^I" . ("ᴵ")) ("^J" . ("ᴶ")) ("^K" . ("ᴷ")) ("^L" . ("ᴸ")) ("^M" . ("ᴹ")) ("^N" . ("ᴺ")) ("^O" . ("ᴼ")) ("^P" . ("ᴾ")) ("^R" . ("ᴿ")) ("^T" . ("ᵀ")) ("^U" . ("ᵁ")) ("^V" . ("ⱽ")) ("^W" . ("ᵂ")) ;; Some ISO8859-1 characters. (" " . (" ")) ("!" . ("¡")) ("cent" . ("¢")) ("brokenbar" . ("¦")) ("degree" . ("°")) ("?" . ("¿")) ("^a_" . ("ª")) ("^o_" . ("º")) ;; Circled, parenthesised etc. numbers and letters. ( "(0)" . ,(agda-input-to-string-list " ⓪")) ( "(1)" . ,(agda-input-to-string-list "⑴①⒈❶➀➊")) ( "(2)" . ,(agda-input-to-string-list "⑵②⒉❷➁➋")) ( "(3)" . ,(agda-input-to-string-list "⑶③⒊❸➂➌")) ( "(4)" . ,(agda-input-to-string-list "⑷④⒋❹➃➍")) ( "(5)" . ,(agda-input-to-string-list "⑸⑤⒌❺➄➎")) ( "(6)" . ,(agda-input-to-string-list "⑹⑥⒍❻➅➏")) ( "(7)" . ,(agda-input-to-string-list "⑺⑦⒎❼➆➐")) ( "(8)" . ,(agda-input-to-string-list "⑻⑧⒏❽➇➑")) ( "(9)" . ,(agda-input-to-string-list "⑼⑨⒐❾➈➒")) ("(10)" . ,(agda-input-to-string-list "⑽⑩⒑❿➉➓")) ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒")) ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓")) ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔")) ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕")) ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖")) ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗")) ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘")) ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙")) ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚")) ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛")) ("(a)" . ,(agda-input-to-string-list "⒜Ⓐⓐ")) ("(b)" . ,(agda-input-to-string-list "⒝Ⓑⓑ")) ("(c)" . ,(agda-input-to-string-list "⒞Ⓒⓒ")) ("(d)" . ,(agda-input-to-string-list "⒟Ⓓⓓ")) ("(e)" . ,(agda-input-to-string-list "⒠Ⓔⓔ")) ("(f)" . ,(agda-input-to-string-list "⒡Ⓕⓕ")) ("(g)" . ,(agda-input-to-string-list "⒢Ⓖⓖ")) ("(h)" . ,(agda-input-to-string-list "⒣Ⓗⓗ")) ("(i)" . ,(agda-input-to-string-list "⒤Ⓘⓘ")) ("(j)" . ,(agda-input-to-string-list "⒥Ⓙⓙ")) ("(k)" . ,(agda-input-to-string-list "⒦Ⓚⓚ")) ("(l)" . ,(agda-input-to-string-list "⒧Ⓛⓛ")) ("(m)" . ,(agda-input-to-string-list "⒨Ⓜⓜ")) ("(n)" . ,(agda-input-to-string-list "⒩Ⓝⓝ")) ("(o)" . ,(agda-input-to-string-list "⒪Ⓞⓞ")) ("(p)" . ,(agda-input-to-string-list "⒫Ⓟⓟ")) ("(q)" . ,(agda-input-to-string-list "⒬Ⓠⓠ")) ("(r)" . ,(agda-input-to-string-list "⒭Ⓡⓡ")) ("(s)" . ,(agda-input-to-string-list "⒮Ⓢⓢ")) ("(t)" . ,(agda-input-to-string-list "⒯Ⓣⓣ")) ("(u)" . ,(agda-input-to-string-list "⒰Ⓤⓤ")) ("(v)" . ,(agda-input-to-string-list "⒱Ⓥⓥ")) ("(w)" . ,(agda-input-to-string-list "⒲Ⓦⓦ")) ("(x)" . ,(agda-input-to-string-list "⒳Ⓧⓧ")) ("(y)" . ,(agda-input-to-string-list "⒴Ⓨⓨ")) ("(z)" . ,(agda-input-to-string-list "⒵Ⓩⓩ")) )) "A list of translations specific to the Agda input method. Each element is a pair (KEY-SEQUENCE-STRING . LIST-OF-TRANSLATION-STRINGS). All the translation strings are possible translations of the given key sequence; if there is more than one you can choose between them using the arrow keys. Note that if you customize this setting you will not automatically benefit (or suffer) from modifications to its default value when the library is updated. If you just want to add some bindings it is probably a better idea to customize `agda-input-user-translations'. These translation pairs are included after those in `agda-input-user-translations', but before the ones inherited from other input methods (see `agda-input-inherit'). If you change this setting manually (without using the customization buffer) you need to call `agda-input-setup' in order for the change to take effect." :group 'agda-input :set 'agda-input-incorporate-changed-setting :initialize 'custom-initialize-default :type '(repeat (cons (string :tag "Key sequence") (repeat :tag "Translations" string)))) (defcustom agda-input-user-translations nil "Like `agda-input-translations', but more suitable for user customizations since by default it is empty. These translation pairs are included first, before those in `agda-input-translations' and the ones inherited from other input methods." :group 'agda-input :set 'agda-input-incorporate-changed-setting :initialize 'custom-initialize-default :type '(repeat (cons (string :tag "Key sequence") (repeat :tag "Translations" string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Inspecting and modifying translation maps (defun agda-input-get-translations (qp) "Return a list containing all translations from the Quail package QP (except for those corresponding to ASCII). Each pair in the list has the form (KEY-SEQUENCE . TRANSLATION)." (with-temp-buffer (activate-input-method qp) ; To make sure that the package is loaded. (unless (quail-package qp) (error "%s is not a Quail package." qp)) (let ((decode-map (list 'decode-map))) (quail-build-decode-map (list (quail-map)) "" decode-map 0) (cdr decode-map)))) (defun agda-input-show-translations (qp) "Display all translations used by the Quail package QP (a string). \(Except for those corresponding to ASCII)." (interactive (list (read-input-method-name "Quail input method (default %s): " "Agda"))) (let ((buf (concat "*" qp " input method translations*"))) (with-output-to-temp-buffer buf (with-current-buffer buf (quail-insert-decode-map (cons 'decode-map (agda-input-get-translations qp))))))) (defun agda-input-add-translations (trans) "Add the given translations TRANS to the Agda input method. TRANS is a list of pairs (KEY-SEQUENCE . TRANSLATION). The translations are appended to the current translations." (with-temp-buffer (dolist (tr (agda-input-concat-map (eval agda-input-tweak-all) trans)) (quail-defrule (car tr) (cdr tr) "Agda" t)))) (defun agda-input-inherit-package (qp &optional fun) "Let the Agda input method inherit the translations from the Quail package QP (except for those corresponding to ASCII). The optional function FUN can be used to modify the translations. It is given a pair (KEY-SEQUENCE . TRANSLATION) and should return a list of such pairs." (let ((trans (agda-input-get-translations qp))) (agda-input-add-translations (if fun (agda-input-concat-map fun trans) trans)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Setting up the input method (defun agda-input-setup () "Set up the Agda input method based on the customisable variables and underlying input methods." ;; Create (or reset) the input method. (with-temp-buffer (quail-define-package "Agda" "UTF-8" "∏" t ; guidance "Agda input method. The purpose of this input method is to edit Agda programs, but since it is highly customisable it can be made useful for other tasks as well." nil nil nil nil nil nil t ; maximum-shortest )) (agda-input-add-translations (mapcar (lambda (tr) (cons (car tr) (vconcat (cdr tr)))) (append agda-input-user-translations agda-input-translations))) (dolist (def agda-input-inherit) (agda-input-inherit-package (car def) (eval (cdr def))))) (defun agda-input-incorporate-changed-setting (sym val) "Update the Agda input method based on the customisable variables and underlying input methods. Suitable for use in the :set field of `defcustom'." (set-default sym val) (agda-input-setup)) ;; Set up the input method. (agda-input-setup) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Administrative details (provide 'agda-input) ;;; agda-input.el ends here UniMath-20231010/latex/000077500000000000000000000000001451125700300144245ustar00rootroot00000000000000UniMath-20231010/latex/hamsplain.bst000066400000000000000000000652201451125700300171170ustar00rootroot00000000000000%%% ==================================================================== %%% @BibTeX-style-file{ %%% author = "American Mathematical Society", %%% version = "1.2beta", %%% date = "13-Oct-1994", %%% time = "15:30:52 EDT", %%% filename = "hamsplain.bst", %%% copyright = "Copyright (C) 1994 American Mathematical Society, %%% all rights reserved. Copying of this file is %%% authorized only if either: %%% (1) you make absolutely no changes to your copy, %%% including name; OR %%% (2) if you do make changes, you first rename it %%% to some other name. %%% [Name changed to hamsplain.bst]", %%% address = "American Mathematical Society, %%% Technical Support, %%% Electronic Products and Services, %%% P. O. Box 6248, %%% Providence, RI 02940, %%% USA", %%% telephone = "401-455-4080 or (in the USA and Canada) %%% 800-321-4AMS (321-4267)", %%% FAX = "401-331-3842", %%% email = "tech-support@math.ams.org (Internet)", %%% codetable = "ISO/ASCII", %%% keywords = "bibtex, bibliography, amslatex, ams-latex", %%% supported = "yes?", %%% abstract = "BibTeX bibliography style `hamsplain' for BibTeX %%% versions 0.99a or later and LaTeX version 2e. %%% Produces alphabetic-label bibliography items in %%% a form typical for American Mathematical Society %%% publications. Modified by Greg Kuperberg to %%% include an eprint field for e-print archives." %%% } %%% ==================================================================== % See the file btxbst.doc for extra documentation other than % what is included here. And see btxhak.tex for a description % of the BibTeX language and how to use it. % This defines the types of fields that can occur in a database entry % for this particular bibliography style. Except for `language', % this is the standard list from plain.bst. %% Types of entries currently allowed in a BibTeX file: %% %% ARTICLE -- An article from a journal or magazine. %% %% BOOK -- A book with an explicit publisher. %% %% BOOKLET -- A work that is printed and bound, %% but without a named publisher or sponsoring institution. %% %% CONFERENCE -- The same as INPROCEEDINGS, %% included for Scribe compatibility. %% %% INBOOK -- A part of a book, %% which may be a chapter (or section or whatever) and/or a range of pages. %% %% INCOLLECTION -- A part of a book having its own title. %% %% INPROCEEDINGS -- An article in a conference proceedings. %% %% MANUAL -- Technical documentation. %% %% MASTERSTHESIS -- A Master's thesis. %% %% MISC -- Use this type when nothing else fits. %% %% PHDTHESIS -- A PhD thesis. %% %% PROCEEDINGS -- The proceedings of a conference. %% %% TECHREPORT -- A report published by a school or other institution, %% usually numbered within a series. %% %% UNPUBLISHED -- A document having an author and title, but not formally %% published. ENTRY { address author booktitle chapter edition editor eprint howpublished institution journal key language month note links number organization pages publisher school series title type volume year } {} { label extra.label } % Removed after.sentence, after.block---not needed. INTEGERS { output.state before.all mid.sentence } FUNCTION {init.state.consts} { #0 'before.all := #1 'mid.sentence := } % Scratch variables: STRINGS { s t } % Utility functions FUNCTION {shows} { duplicate$ ":::: `" swap$ * "'" * top$ } FUNCTION {showstack} {"STACK=====================================================================" top$ stack$ "ENDSTACK==================================================================" top$ } FUNCTION {not} { { #0 } { #1 } if$ } FUNCTION {and} { 'skip$ { pop$ #0 } if$ } FUNCTION {or} { { pop$ #1 } 'skip$ if$ } FUNCTION {field.or.null} { duplicate$ empty$ { pop$ "" } 'skip$ if$ } FUNCTION {emphasize} { duplicate$ empty$ { pop$ "" } { "\emph{" swap$ * "}" * } if$ } % n.dashify is used to make sure page ranges get the TeX code % (two hyphens) for en-dashes. FUNCTION {n.dashify} { 't := "" { t empty$ not } { t #1 #1 substring$ "-" = { t #1 #2 substring$ "--" = not { "--" * t #2 global.max$ substring$ 't := } { { t #1 #1 substring$ "-" = } { "-" * t #2 global.max$ substring$ 't := } while$ } if$ } { t #1 #1 substring$ * t #2 global.max$ substring$ 't := } if$ } while$ } % tie.or.space.connect connects two items with a ~ if the % second item is less than 3 letters long, otherwise it just puts an % ordinary space. FUNCTION {tie.or.space.connect} { duplicate$ text.length$ #3 < { "~" } { " " } if$ swap$ * * } FUNCTION {add.space.if.necessary} { duplicate$ "" = 'skip$ { " " * } if$ } % either.or.check gives a warning if two mutually exclusive fields % were used in the database. FUNCTION {either.or.check} { empty$ 'pop$ { "can't use both " swap$ * " fields in " * cite$ * warning$ } if$ } % output.nonnull is called by output. FUNCTION {output.nonnull} % remove the top item from the stack because it's in the way. { 's := output.state mid.sentence = % If we're in mid-sentence, add a comma to the new top item and write it { ", " * write$ } % Otherwise, if we're at the beginning of a bibitem, { output.state before.all = % just write out the top item from the stack; 'write$ % and the last alternative is that we're at the end of the current % bibitem, so we add a period to the top stack item and write it out. { add.period$ " " * write$ } if$ mid.sentence 'output.state := } if$ % Put the top item back on the stack that we removed earlier. s } % Output checks to see if the stack top is empty; if not, it % calls output.nonnull to write it out. FUNCTION {output} { duplicate$ empty$ 'pop$ 'output.nonnull if$ } % Standard warning message for a missing or empty field. For the user % we call any such field `missing' without respect to the distinction % made by BibTeX between missing and empty. FUNCTION {missing.warning} { "missing " swap$ * " in " * cite$ * warning$ } % Output.check is like output except that it gives a warning on-screen % if the given field in the database entry is empty. t is the field % name. FUNCTION {output.check} { 't := duplicate$ empty$ { pop$ t missing.warning } 'output.nonnull if$ } FUNCTION {output.bibitem} { newline$ "\bibitem{" write$ cite$ write$ "}" write$ newline$ % This empty string is the first thing that will be written % the next time write$ is called. Done this way because each % item is saved on the stack until we find out what punctuation % should be added after it. Therefore we need an empty first item. "" before.all 'output.state := } FUNCTION {fin.entry} { add.period$ write$ newline$ } % Removed new.block, new.block.checka, new.block.checkb, new.sentence, % new.sentence.checka, and new.sentence.checkb functions here, since they % don't seem to be needed in the AMS style. Also moved some real % basic functions like `and' and 'or' earlier in the file. INTEGERS { nameptr namesleft numnames } % The extra section to write out a language field was added % for AMSPLAIN.BST. Not present in plain.bst. FUNCTION {format.language} { language empty$ { "" } { " (" language * ")" * } if$ } % This version of format.names puts names in the format % % First von Last, Jr. % % (i.e., first name first, no abbreviating to initials). FUNCTION {format.names} { 's := #1 'nameptr := s num.names$ 'numnames := numnames 'namesleft := { namesleft #0 > } { s nameptr "{ff~}{vv~}{ll}{, jj}" format.name$ 't := nameptr #1 > { namesleft #1 > { ", " * t * } { numnames #2 > { "," * } 'skip$ if$ t "others" = { " et~al." * } { " and " * t * } if$ } if$ } 't if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ } FUNCTION {format.authors} { author empty$ { "" } { extra.label "\bysame" = {"\bysame"} { author format.names } if$ } if$ } FUNCTION {format.editors} { editor empty$ { "" } { editor format.names editor num.names$ #1 > { " (eds.)" * } { " (ed.)" * } if$ } if$ } FUNCTION {format.nonauthor.editors} { editor empty$ { "" } { editor format.names editor num.names$ #1 > { ", eds." * } { ", ed." * } if$ } if$ } FUNCTION {format.title} { title empty$ { "" } { title "t" change.case$ emphasize } if$ } % Function modified to wrap the eprint number in an mbox construction - GJK FUNCTION {format.eprint} { eprint empty$ { "" } { "\mbox{" eprint * "}" * } if$ } FUNCTION {format.journal.vol.year} { journal empty$ { "journal name" missing.warning ""} { journal } if$ volume empty$ 'skip$ { " \textbf{" * volume * "}" * } if$ year empty$ { "year" missing.warning } { " (" * year * ")" * } if$ } % For formatting the issue number for a journal article. FUNCTION {format.number} { number empty$ { "" } { "no.~" number * } if$ } % For formatting miscellaneous dates FUNCTION {format.date} { year empty$ { month empty$ { "" } { "there's a month but no year in " cite$ * warning$ month } if$ } { month empty$ 'year { month " " * year * } if$ } if$ } %% The volume, series and number information is sort of tricky. %% This code handles it as follows: %% If the series is present, and the volume, but not the number, %% then we do "\emph{Book title}, Series Name, vol. 000" %% If the series is present, and the number, but not the volume, %% then we do "\emph{Book title}, Series Name, no. 000" %% If the series is present, and both number and volume, %% then we do "\emph{Book title}, vol. XX, Series Name, no. 000" %% Finally, if the series is absent, %% then we do "\emph{Book title}, vol. XX" %% or "\emph{Book title}, no. 000" %% and if both volume and number are present, give a warning message. FUNCTION {format.bookvolume.series.number} { volume empty$ { "" % Push the empty string as a placeholder in case everything else % is empty too. series empty$ 'skip$ { pop$ series } % if series is not empty put in stack if$ number empty$ 'skip$ { duplicate$ empty$ % if no preceding material, 'skip$ % do nothing, otherwise { ", " * } % add a comma and space to separate. if$ "no." number tie.or.space.connect * % add the number information } if$ } %% If the volume is NOT EMPTY: { "vol." volume tie.or.space.connect % vol. XX number empty$ { series empty$ 'skip$ { series ", " * swap$ *} % Series Name, vol. XX if$ } { series empty$ { "can't use both volume and number if series info is missing" warning$ "in BibTeX entry type `" type$ * "'" * top$ } { ", " * series * ", no." * number tie.or.space.connect } if$ } if$ } if$ } % end of format.bookvolume.series.number %% format.inproc.title.where.editors is used by inproceedings entry types FUNCTION {format.inproc.title.address.editors} { booktitle empty$ { "" } %% No case changing or emphasizing for the title. We want initial %% caps, roman. { booktitle } if$ %% We add parentheses around the address (place where conference %% was held). address empty$ 'skip$ { add.space.if.necessary "(" * address * ")" * } if$ %% Likewise we add parentheses around the editors' names. editor empty$ 'skip$ { add.space.if.necessary "(" * format.nonauthor.editors * ")" * } if$ } %% format.incoll.title.editors is similar to format.inproc... but %% omits the address. For collections that are not proceedings volumes. FUNCTION {format.incoll.title.editors} { booktitle empty$ { "" } %% No case changing or emphasizing for the title. We want initial %% caps, roman. { booktitle } if$ %% We add parentheses around the editors' names. editor empty$ 'skip$ { add.space.if.necessary "(" * format.nonauthor.editors * ")" * } if$ } % Desired output for format.number.series: % % Lecture Notes in Math., no.~1224 FUNCTION {format.number.series} { series empty$ { number empty$ { "" } { "there's a number but no series in " cite$ * warning$ } if$ } { series number empty$ 'skip$ { ", no.~" * number * } if$ } if$ } FUNCTION {format.edition} { edition empty$ { "" } { output.state mid.sentence = { edition "l" change.case$ " ed." * } { edition "t" change.case$ " ed." * } if$ } if$ } INTEGERS { multiresult } FUNCTION {multi.page.check} { 't := #0 'multiresult := { multiresult not t empty$ not and } { t #1 #1 substring$ duplicate$ "-" = swap$ duplicate$ "," = swap$ "+" = or or { #1 'multiresult := } { t #2 global.max$ substring$ 't := } if$ } while$ multiresult } FUNCTION {format.pages} { pages empty$ { "" } { pages n.dashify } if$ } FUNCTION {format.book.pages} { pages empty$ { "" } { pages multi.page.check { "pp.~" pages n.dashify * } { "p.~" pages * } if$ } if$ } FUNCTION {format.chapter.pages} { chapter empty$ 'format.pages { type empty$ { "ch.~" } { type "l" change.case$ " " * } if$ chapter * pages empty$ 'skip$ { ", " * format.book.pages * } if$ } if$ } FUNCTION {empty.misc.check} { author empty$ title empty$ howpublished empty$ month empty$ year empty$ note empty$ links empty$ and and and and and key empty$ not and { "all relevant fields are empty in " cite$ * warning$ } 'skip$ if$ } FUNCTION {format.thesis.type} { type empty$ 'skip$ { pop$ type "t" change.case$ } if$ } FUNCTION {format.tr.number} { type empty$ { "Tech. Report" } 'type if$ number empty$ { "t" change.case$ } { number tie.or.space.connect } if$ } % The format.crossref functions haven't been paid much attention % at the present time (June 1990) and could probably use some % work. MJD FUNCTION {format.article.crossref} { key empty$ { journal empty$ { "need key or journal for " cite$ * " to crossref " * crossref * warning$ "" } { "In " journal * } if$ } { "In " key * } if$ " \cite{" * crossref * "}" * } FUNCTION {format.crossref.editor} { editor #1 "{vv~}{ll}" format.name$ editor num.names$ duplicate$ #2 > { pop$ " et~al." * } { #2 < 'skip$ { editor #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = { " et~al." * } { " and " * editor #2 "{vv~}{ll}" format.name$ * } if$ } if$ } if$ } FUNCTION {format.book.crossref} { volume empty$ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ "In " } { "Vol." volume tie.or.space.connect " of " * } if$ editor empty$ editor field.or.null author field.or.null = or { key empty$ { series empty$ { "need editor, key, or series for " cite$ * " to crossref " * crossref * warning$ "" * } { series * } if$ } { key * } if$ } { format.crossref.editor * } if$ " \cite{" * crossref * "}" * } FUNCTION {format.incoll.inproc.crossref} { editor empty$ editor field.or.null author field.or.null = or { key empty$ { booktitle empty$ { "need editor, key, or booktitle for " cite$ * " to crossref " * crossref * warning$ "" } { "In \emph{" booktitle * "}" * } if$ } { "In " key * } if$ } { "In " format.crossref.editor * } if$ " \cite{" * crossref * "}" * } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The main functions for each entry type. % journal, vol and year are formatted together because they are % not separated by commas. FUNCTION {article} { output.bibitem format.authors "author" output.check format.title "title" output.check crossref missing$ { format.journal.vol.year output format.number output format.pages "pages" output.check } { format.article.crossref output.nonnull format.pages output } if$ format.language * format.eprint output note output links output fin.entry } FUNCTION {book} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ format.title "title" output.check format.edition output crossref missing$ { format.bookvolume.series.number output publisher "publisher" output.check address output } { format.book.crossref output.nonnull } if$ format.date "year" output.check format.language * format.eprint output note output links output fin.entry } FUNCTION {booklet} { output.bibitem format.authors output format.title "title" output.check howpublished output address output format.date output format.eprint output note output links output fin.entry } FUNCTION {inbook} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ title "title" output.check crossref missing$ { format.bookvolume.series.number output format.chapter.pages "chapter and pages" output.check format.number.series output publisher "publisher" output.check address output } { format.chapter.pages "chapter and pages" output.check format.book.crossref output.nonnull } if$ format.edition output format.date "year" output.check format.book.pages output format.language * format.eprint output note output links output fin.entry } FUNCTION {incollection} { output.bibitem format.authors "author" output.check format.title "title" output.check crossref missing$ { format.incoll.title.editors "booktitle" output.check format.bookvolume.series.number output publisher "publisher" output.check address output format.edition output format.date "year" output.check } { format.incoll.inproc.crossref output.nonnull } if$ format.eprint output note output format.book.pages output format.language * links output fin.entry } FUNCTION {inproceedings} { output.bibitem format.authors "author" output.check format.title "title" output.check crossref missing$ { format.inproc.title.address.editors "booktitle" output.check format.bookvolume.series.number output organization output publisher output format.date "year" output.check } { format.incoll.inproc.crossref output.nonnull } if$ format.eprint output note output format.book.pages output format.language * links output fin.entry } FUNCTION {conference} { inproceedings } FUNCTION {manual} { output.bibitem author empty$ { organization empty$ 'skip$ { organization output.nonnull address output } if$ } { format.authors output.nonnull } if$ format.title "title" output.check author empty$ { organization empty$ { address output } 'skip$ if$ } { organization output address output } if$ format.edition output format.date output format.eprint output note output links output fin.entry } FUNCTION {mastersthesis} { output.bibitem format.authors "author" output.check format.title "title" output.check "Master's thesis" format.thesis.type output.nonnull school "school" output.check address output format.date "year" output.check format.eprint output note output links output fin.entry } FUNCTION {misc} { output.bibitem format.authors output format.title output howpublished output format.date output format.eprint output note output format.book.pages output links output fin.entry empty.misc.check } FUNCTION {phdthesis} { output.bibitem format.authors "author" output.check format.title "title" output.check "Ph.D. thesis" format.thesis.type output.nonnull school "school" output.check address output format.date "year" output.check format.eprint output note output format.book.pages output links output fin.entry } FUNCTION {proceedings} { output.bibitem editor empty$ { organization output } { format.editors output.nonnull } if$ format.title "title" output.check format.bookvolume.series.number output address empty$ { editor empty$ 'skip$ { organization output } if$ publisher output format.date "year" output.check } { address output.nonnull editor empty$ 'skip$ { organization output } if$ publisher output format.date "year" output.check } if$ format.eprint output note output links output fin.entry } FUNCTION {techreport} { output.bibitem format.authors "author" output.check format.title "title" output.check format.tr.number output.nonnull institution "institution" output.check address output format.date "year" output.check format.eprint output note output links output fin.entry } FUNCTION {unpublished} { output.bibitem format.authors "author" output.check format.title "title" output.check note "note" output.check format.date output format.eprint output links output fin.entry } FUNCTION {default.type} { misc } MACRO {jan} {"January"} MACRO {feb} {"February"} MACRO {mar} {"March"} MACRO {apr} {"April"} MACRO {may} {"May"} MACRO {jun} {"June"} MACRO {jul} {"July"} MACRO {aug} {"August"} MACRO {sep} {"September"} MACRO {oct} {"October"} MACRO {nov} {"November"} MACRO {dec} {"December"} READ FUNCTION {sortify} { purify$ "l" change.case$ } INTEGERS { len } FUNCTION {chop.word} { 's := 'len := s #1 len substring$ = { s len #1 + global.max$ substring$ } 's if$ } FUNCTION {sort.format.names} { 's := #1 'nameptr := "" s num.names$ 'numnames := numnames 'namesleft := { namesleft #0 > } { nameptr #1 > { " " * } 'skip$ if$ s nameptr "{vv{ } }{ll{ }}{ ff{ }}{ jj{ }}" format.name$ 't := nameptr numnames = t "others" = and { "et al" * } { t sortify * } if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ } FUNCTION {sort.format.title} { 't := "A " #2 "An " #3 "The " #4 t chop.word chop.word chop.word sortify #1 global.max$ substring$ } FUNCTION {author.sort} { author empty$ { key empty$ { "to sort, need author or key in " cite$ * warning$ "" } { key sortify } if$ } { author sort.format.names } if$ } FUNCTION {author.editor.sort} { author empty$ { editor empty$ { key empty$ { "to sort, need author, editor, or key in " cite$ * warning$ "" } { key sortify } if$ } { editor sort.format.names } if$ } { author sort.format.names } if$ } FUNCTION {author.organization.sort} { author empty$ { organization empty$ { key empty$ { "to sort, need author, organization, or key in " cite$ * warning$ "" } { key sortify } if$ } { "The " #4 organization chop.word sortify } if$ } { author sort.format.names } if$ } FUNCTION {editor.organization.sort} { editor empty$ { organization empty$ { key empty$ { "to sort, need editor, organization, or key in " cite$ * warning$ "" } { key sortify } if$ } { "The " #4 organization chop.word sortify } if$ } { editor sort.format.names } if$ } FUNCTION {presort} { type$ "book" = type$ "inbook" = or 'author.editor.sort { type$ "proceedings" = 'editor.organization.sort { type$ "manual" = 'author.organization.sort 'author.sort if$ } if$ } if$ " " * year field.or.null sortify * " " * title field.or.null sort.format.title * #1 entry.max$ substring$ 'sort.key$ := } ITERATE {presort} SORT STRINGS { longest.label prev.author this.author } INTEGERS { number.label longest.label.width } FUNCTION {initialize.longest.label} { "" 'longest.label := #1 'number.label := #0 'longest.label.width := "abcxyz" 'prev.author := "" 'this.author := } FUNCTION {longest.label.pass} { number.label int.to.str$ 'label := number.label #1 + 'number.label := label width$ longest.label.width > { label 'longest.label := label width$ 'longest.label.width := } 'skip$ if$ author empty$ { editor empty$ { "" } 'editor if$ } 'author if$ 'this.author := this.author prev.author = { "\bysame" 'extra.label := } { "" 'extra.label := this.author "" = { "abcxyz" } 'this.author if$ 'prev.author := } if$ } EXECUTE {initialize.longest.label} ITERATE {longest.label.pass} FUNCTION {begin.bib} { preamble$ empty$ 'skip$ { preamble$ write$ newline$ } if$ "\providecommand{\bysame}{\leavevmode\hbox to3em{\hrulefill}\thinspace}" write$ newline$ "\begin{thebibliography}{" longest.label * "}" * write$ newline$ } EXECUTE {begin.bib} EXECUTE {init.state.consts} ITERATE {call.type$} FUNCTION {end.bib} { newline$ "\end{thebibliography}" write$ newline$ } EXECUTE {end.bib} %% \CharacterTable %% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z %% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z %% Digits \0\1\2\3\4\5\6\7\8\9 %% Exclamation \! Double quote \" Hash (number) \# %% Dollar \$ Percent \% Ampersand \& %% Acute accent \' Left paren \( Right paren \) %% Asterisk \* Plus \+ Comma \, %% Minus \- Point \. Solidus \/ %% Colon \: Semicolon \; Less than \< %% Equals \= Greater than \> Question mark \? %% Commercial at \@ Left bracket \[ Backslash \\ %% Right bracket \] Circumflex \^ Underscore \_ %% Grave accent \` Left brace \{ Vertical bar \| %% Right brace \} Tilde \~} UniMath-20231010/latex/latex-epilogue.txt000066400000000000000000000001111451125700300201020ustar00rootroot00000000000000 \bibliographystyle{hamsplain} \bibliography{references} \end{document} UniMath-20231010/latex/latex-preamble.txt000066400000000000000000000025571451125700300201000ustar00rootroot00000000000000\documentclass[12pt]{report} \usepackage[utf8x]{inputenc} %Warning: tipa declares many non-standard macros used by utf8x to %interpret utf8 characters but extra packages might have to be added %such as "textgreek" for Greek letters not already in tipa %or "stmaryrd" for mathematical symbols. %Utf8 codes missing a LaTeX interpretation can be defined by using %\DeclareUnicodeCharacter{code}{interpretation}. %Use coqdoc's option -p to add new packages or declarations. \usepackage{tipa} \usepackage[T1]{fontenc} \usepackage{fullpage} \usepackage[color]{coqdoc} \usepackage{amsmath,amssymb} \usepackage{url} \usepackage{textgreek} \usepackage{stmaryrd} \usepackage{pmboxdraw} \usepackage{fdsymbol} \DeclareUnicodeCharacter{10627}{{\(\llparenthesis\)}} \DeclareUnicodeCharacter{10628}{{\(\rrparenthesis\)}} \DeclareUnicodeCharacter{10815}{{\(\amalg\)}} \DeclareUnicodeCharacter{9679}{{\(\bullet\)}} \DeclareUnicodeCharacter{9726}{{\(\blacksquare\)}} \DeclareUnicodeCharacter{9725}{{\(\square\)}} \DeclareUnicodeCharacter{10226}{{\(\circlearrowleft\)}} \DeclareUnicodeCharacter{10227}{{\(\circlearrowright\)}} \DeclareUnicodeCharacter{9645}{{\(\boxdot\)}} \DeclareUnicodeCharacter{981}{{\(\phi\)}} \DeclareUnicodeCharacter{9565}{{\textSFxxvi}} \DeclareUnicodeCharacter{8803}{{\(\mathop {\vbox {{\rlap =} \kern 3.9pt} {\rlap =} \phantom =} \)}} \hypersetup{linkcolor=blue} \begin{document} UniMath-20231010/latex/references.bib000066400000000000000000000031651451125700300172300ustar00rootroot00000000000000@article{DBLP:journals/corr/AltenkirchCU14, author = {Thorsten Altenkirch and James Chapman and Tarmo Uustalu}, title = {Monads need not be endofunctors}, journal = {Logical Methods in Computer Science}, volume = {11}, number = {1}, year = {2015}, url = {https://doi.org/10.2168/LMCS-11(1:3)2015}, doi = {10.2168/LMCS-11(1:3)2015}, timestamp = {Wed, 03 May 2017 14:47:56 +0200}, biburl = {http://dblp.uni-trier.de/rec/bib/journals/corr/AltenkirchCU14}, bibsource = {dblp computer science bibliography, http://dblp.org} } @book {BourbakiAlgebraI, AUTHOR = {Bourbaki, Nicolas}, TITLE = {Elements of mathematics. {A}lgebra, {P}art {I}: {C}hapters 1-3}, NOTE = {Translated from the French}, PUBLISHER = {Hermann, Paris; Addison-Wesley Publishing Co., Reading Mass.}, YEAR = {1974}, PAGES = {xxiii+709}, MRCLASS = {00A05 (15-XX)}, MRNUMBER = {0354207}, } @article{Adamek1974, author = {Adámek, Ji\^rí}, journal = {Commentationes Mathematicae Universitatis Carolinae}, language = {eng}, number = {4}, pages = {589-602}, publisher = {Charles University in Prague, Faculty of Mathematics and Physics}, title = {Free algebras and automata realizations in the language of categories}, url = {http://eudml.org/doc/16649}, volume = {015}, year = {1974}, } @InBook{Burris2006, author = {Burris, Stanley and Sankappanavar, Hanamantagida Pandappa}, title = {A Course in Universal Algebra-With 36 Illustrations}, chapter = {Chapter I - Lattices}, year = {2006} } UniMath-20231010/sub/000077500000000000000000000000001451125700300141005ustar00rootroot00000000000000UniMath-20231010/sub/coq/000077500000000000000000000000001451125700300146625ustar00rootroot00000000000000UniMath-20231010/sub/coq-tools/000077500000000000000000000000001451125700300160205ustar00rootroot00000000000000UniMath-20231010/util/000077500000000000000000000000001451125700300142645ustar00rootroot00000000000000UniMath-20231010/util/checkstyle000077500000000000000000000060171451125700300163540ustar00rootroot00000000000000#!/usr/bin/env bash # Check the code style of the UniMath project # Auke Booij, 2017 # # START helper functions # die() { echo "$@" >&2 exit 1 } check_grep() { typeset cmd="grep -E -Hn $1 $2" typeset ret_code output=$($cmd) ret_code=$? if [ $ret_code != 0 ] && [ $ret_code != 1 ] then die "Failed to run command:" "$cmd" fi if [[ ! -z $output ]] then (( FAILURES++ )) echo "$output" fi } check_command() { check_grep "^[[:space:]]*($2)(\.|[^a-zA-Z][^.]*?\.)" "$1" } check_type() { check_grep "[^[:space:]a-zA-Z.][^a-zA-Z.]+($2)($|[^a-zA-Z_])" "$1" } check_tactic() { check_grep "(^|\.|;)[[:space:]]*($2)[^.;]*(\.|;)" "$1" } check_freestanding() { check_grep "[^[:space:]](.*[^a-zA-Z])?($2)\." "$1" } check_line_length() { check_grep "^.{101}" "$1" } check_line_start() { check_grep "^[[:space:]]*:=?" "$1" } check_file() { # Do not use Admitted or introduce new axioms. check_command "$1" "Admitted" # Do not use Inductive or Record, except in Foundations/Basics/Preamble.v. if [[ $1 != *"Foundations/Basics/Preamble.v" ]] then check_command "$1" "Inductive|Record" fi # Do not use Module or Structure. # Do not use Fixpoint. check_command "$1" "Structure|Fixpoint" if [[ $1 != *"Tests.v" ]] then check_command "$1" "Module" fi # Do not use Prop or Set, and ensure definitions don't produce # elements of them. check_type "$1" "Prop|Set" # Do not use Type, except in Foundations/Basics/Preamble.v. Use UU # instead. If higher universes are needed, they should be added to # Foundations/Basics/Preamble.v if [[ $1 != *"Foundations/Basics/Preamble.v" ]] then check_type "$1" "Type" fi # Do not use destruct, match, case, square brackets with intros, # or nested square brackets with induction. (The goal is to # prevent generation of proof terms using match.) # # Use do with a specific numerical count, rather than repeat, to # make proofs easier to repair. check_tactic "$1" "destruct|match|case|intros[^.;]*\[|induction[^.;]*\[[^].;]*\[|repeat" # Start all proofs with Proof. on a separate line and end it with # Defined. on a separate line, as this makes it possible for us to # generate HTML with expansible/collapsible proofs. check_freestanding "$1" "Proof|Defined" # Each line should be limited to at most 100 (unicode) characters. check_line_length "$1" # Within the core Foundations package: # Do not start lines with : or with :=. if [[ $1 == *"/Foundations/"* ]] then check_line_start "$1" fi } # # END helper functions # # # START subcommand functions # cmd_check_files() { echo "Checking $# files for code style..." echo for file in "$@" do check_file "$file" done } # # END subcommand functions # PROGRAM="${0##*/}" COMMAND="$1" FAILURES=0 case "$1" in *) cmd_check_files "$@" ;; esac exit 0 UniMath-20231010/util/enhanced-doc/000077500000000000000000000000001451125700300165745ustar00rootroot00000000000000UniMath-20231010/util/enhanced-doc/alignment.pl000066400000000000000000000065311451125700300211140ustar00rootroot00000000000000# Copyright (c) 2014, Guillaume Verdier # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, this # list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. use strict; use warnings; use List::Util ('first'); my @all_cols = (); my @columns; my $in_align = 0; while (my $line = <>) { chomp($line); utf8::decode($line); if (!$in_align) { if (start_align($line)) { $in_align = 1; @all_cols = (); } else { utf8::encode($line); print "$line\n"; next; } } elsif (end_align($line)) { print_align(); $in_align = 0; utf8::encode($line); print "$line\n"; next; } my @cols = split(/( +)/, $line); my %line_cols = (); my $first_col = shift(@cols); $first_col =~ /^((?: )*)/; my $indent = length($1) / 6; $line_cols{$indent} = $first_col; my $offset = length(normalize($first_col)); for (my $index = 1; $index <= $#cols; $index += 2) { $offset += length($cols[$index - 1]); my $col = $cols[$index]; $line_cols{$offset} = $col; $offset += length(normalize($col)); } push(@all_cols, \%line_cols); @columns = get_all_columns(@all_cols); } print_align() if $in_align; sub start_align { return $_[0] =~ / /; } sub end_align { my ($line) = @_; return 0 if ($line =~ / /); $line =~ /^((?: )*)/; my $indent = length($1) / 6; my $index = first { $columns[$_] == $indent } 1..$#columns; return 0 if defined($index); return 1; } sub normalize { $_ = shift; s/&[^;]*;/_/g; s/<([^">]|("[^"]*"))*>//g; return $_; } sub print_align { print "\n"; for my $cols (@all_cols) { print "\t"; my $index = 0; while ($index <= $#columns) { my $col = $cols->{$columns[$index]}; $col = "" unless defined($col); $col =~ s/( )*// if $index > 0; $col =~ s///; $index += 1; my $colspan = 1; while ($index <= $#columns && !defined($cols->{$columns[$index]})) { $colspan += 1; $index += 1; } utf8::encode($col); print ""; } print "\n"; } print "
$col 
\n"; } sub get_all_columns { my (@cols) = @_; my @res = (); push(@res, keys(%$_)) for (@cols); my %h = map {$_, 1} @res; return sort {$a <=> $b} keys %h; } UniMath-20231010/util/enhanced-doc/header.html000066400000000000000000000007171451125700300207170ustar00rootroot00000000000000 Documentation
UniMath-20231010/util/enhanced-doc/proofs-toggle.js000066400000000000000000000053331451125700300217250ustar00rootroot00000000000000/* * Copyright(c) 2014, Guillaume Verdier * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * 1. Redistributions of source code must retain the above copyright notice, this * list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES *(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ $(function() { $('div.proof').each(function() { var html = $(this).html(); var indent = html.match(/^\s*((?: )*)/)[1]; var indentsize = indent.length / 6; $(this).html(html.replace(new RegExp(indent + "([^&])", 'g'), '$1')).css('margin-left', indentsize + 'ex'); }); $('div.code').each(function() { var first = $($(this).children()[0]); if(first.prop('tagName') === 'A' && first.hasClass('proof')) { var prev = $(this).prev(); if(prev.hasClass('doc')) { first.next().next().prepend("
" + prev.html() + "
"); prev.remove(); prev = $(this).prev(); if(prev.hasClass('code')) { prev.append($(this).contents()); $(this).remove(); } } } }); $('div.proof').each(function() { $(this).css('display', 'none'); var next = $(this).next(); while(next.prop('tagName') === 'A' && next.hasClass('proof')) { next.remove(); $(this).next().remove(); //
next = $(this).next(); //
if(!$(next.children()[0]).hasClass('proofcomment')) { $(this).append('
'); } $(this).append(next.contents()); next.remove(); next = $(this).next(); } }); $('a.proof').click(function(e) { e.preventDefault(); var proof = $(this).next().next(); $(this).text((proof.css('display') === 'none' ? 'Hide' : 'Show') + ' proof.'); proof.slideToggle(); }); }); UniMath-20231010/util/enhanced-doc/proofs-toggle.sed000066400000000000000000000035401451125700300220620ustar00rootroot00000000000000# Copyright (c) 2014, Guillaume Verdier # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, this # list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. s|Proof.\(
\)*|Show proof.
|g s|Next Obligation.\(
\)*|Show proof.
|g t goto-end-proof b :goto-end-proof s|\( \)*Qed.\(
\)*|
|g s|\( \)*Defined.\(
\)*|
|g t n b goto-end-proof UniMath-20231010/util/generate-exports000077500000000000000000000006531451125700300175120ustar00rootroot00000000000000#!/bin/bash prefix=$1 index=$2 echo "(* This file is automatically generated. Do not edit. *)" for i in $index; do # Currently there are some All.v files in the repository, we need to exclude them here. if [[ $i = *.v && (! $i = *.All.v) ]] then # This is essentially the same as echo $i | tr '/' '.' filename=${i////.} echo "Require Export $prefix.${filename%.v}." fi done | sort -d UniMath-20231010/util/slowest000077500000000000000000000004721451125700300157150ustar00rootroot00000000000000#! /bin/bash n=$1 min=$2 # print slowest $n step times, more than $min seconds shift shift "$@" >COQC.log || exit 1 echo "--- stdout ---" = $min" rm COQC.log